summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--.clang-format5
-rw-r--r--.clangd5
-rw-r--r--.dir-locals.el24
-rw-r--r--.gitattributes32
-rw-r--r--.gitignore52
-rw-r--r--.mailmap11
-rw-r--r--CONTRIBUTE2
-rw-r--r--ChangeLog.116
-rw-r--r--ChangeLog.314
-rw-r--r--ChangeLog.46
-rw-r--r--ChangeLog.android7279
-rw-r--r--GNUmakefile50
-rw-r--r--INSTALL17
-rw-r--r--INSTALL.REPO2
-rw-r--r--Makefile.in77
-rw-r--r--README7
-rw-r--r--admin/CPP-DEFINES15
-rw-r--r--admin/MAINTAINERS86
-rw-r--r--admin/admin.el8
-rw-r--r--admin/authors.el268
-rw-r--r--admin/charsets/Makefile.in2
-rwxr-xr-xadmin/charsets/mapconv3
-rw-r--r--admin/coccinelle/alloc_cast.cocci6
-rw-r--r--admin/coccinelle/build_string.cocci6
-rw-r--r--admin/coccinelle/nilp.cocci6
-rw-r--r--admin/coccinelle/unibyte_string.cocci6
-rw-r--r--admin/coccinelle/xsave.cocci11
-rw-r--r--admin/codespell/codespell.exclude72
-rw-r--r--admin/cus-test.el11
-rwxr-xr-xadmin/emake47
-rw-r--r--admin/find-gc.el2
-rwxr-xr-xadmin/git-bisect-start22
-rw-r--r--admin/gitmerge.el10
-rwxr-xr-xadmin/merge-gnulib35
-rw-r--r--admin/notes/copyright2
-rw-r--r--admin/notes/elpa2
-rw-r--r--admin/notes/emba40
-rw-r--r--admin/notes/git-workflow10
-rw-r--r--admin/notes/java1097
-rwxr-xr-xadmin/notes/tree-sitter/build-module/batch.sh32
-rwxr-xr-xadmin/notes/tree-sitter/build-module/build.sh95
-rw-r--r--admin/notes/tree-sitter/performance25
-rw-r--r--admin/notes/unicode42
-rw-r--r--admin/notes/years2
-rw-r--r--admin/syncdoc-type-hierarchy.el133
-rw-r--r--admin/unidata/BidiBrackets.txt10
-rw-r--r--admin/unidata/BidiMirroring.txt8
-rw-r--r--admin/unidata/Blocks.txt7
-rw-r--r--admin/unidata/IdnaMappingTable.txt23
-rw-r--r--admin/unidata/Makefile.in14
-rw-r--r--admin/unidata/NormalizationTest.txt6
-rw-r--r--admin/unidata/PropertyValueAliases.txt38
-rw-r--r--admin/unidata/ScriptExtensions.txt47
-rw-r--r--admin/unidata/Scripts.txt14
-rw-r--r--admin/unidata/SpecialCasing.txt6
-rw-r--r--admin/unidata/UnicodeData.txt7
-rw-r--r--admin/unidata/confusables.txt10
-rw-r--r--admin/unidata/copyright.html20
-rw-r--r--admin/unidata/emoji-data.txt6
-rw-r--r--admin/unidata/emoji-sequences.txt17
-rw-r--r--admin/unidata/emoji-test.txt337
-rw-r--r--admin/unidata/emoji-variation-sequences.txt1458
-rw-r--r--admin/unidata/emoji-zwj-sequences.txt144
-rw-r--r--admin/unidata/emoji-zwj.awk20
-rwxr-xr-xautogen.sh32
-rwxr-xr-xbuild-aux/config.guess60
-rwxr-xr-xbuild-aux/config.sub230
-rw-r--r--build-aux/git-hooks/commit-msg-files.awk128
-rwxr-xr-xbuild-aux/git-hooks/post-commit47
-rwxr-xr-xbuild-aux/git-hooks/pre-commit11
-rwxr-xr-xbuild-aux/git-hooks/pre-push88
-rwxr-xr-xbuild-aux/git-hooks/prepare-commit-msg4
-rwxr-xr-xbuild-aux/gitlog-to-changelog6
-rwxr-xr-xbuild-aux/install-sh8
-rwxr-xr-xbuild-aux/make-info-dir2
-rwxr-xr-xbuild-aux/makecounter.sh43
-rw-r--r--build-aux/ndk-build-helper-1.mk112
-rw-r--r--build-aux/ndk-build-helper-2.mk105
-rw-r--r--build-aux/ndk-build-helper-3.mk28
-rw-r--r--build-aux/ndk-build-helper-4.mk39
-rw-r--r--build-aux/ndk-build-helper.mk81
-rw-r--r--build-aux/ndk-module-extract.awk88
-rwxr-xr-xbuild-aux/update-copyright165
-rw-r--r--configure.ac1853
-rw-r--r--cross/Makefile.in194
-rw-r--r--cross/README5
-rw-r--r--cross/langinfo.h20
-rw-r--r--cross/ndk-build/Makefile.in148
-rw-r--r--cross/ndk-build/README353
-rw-r--r--cross/ndk-build/ndk-build-executable.mk22
-rw-r--r--cross/ndk-build/ndk-build-shared-library.mk171
-rw-r--r--cross/ndk-build/ndk-build-static-library.mk142
-rw-r--r--cross/ndk-build/ndk-build.mk.in70
-rw-r--r--cross/ndk-build/ndk-clear-vars.mk57
-rw-r--r--cross/ndk-build/ndk-prebuilt-shared-library.mk24
-rw-r--r--cross/ndk-build/ndk-prebuilt-static-library.mk24
-rw-r--r--cross/ndk-build/ndk-resolve.mk186
-rw-r--r--cross/verbose.mk.android56
-rw-r--r--doc/emacs/ChangeLog.138
-rw-r--r--doc/emacs/Makefile.in2
-rw-r--r--doc/emacs/ack.texi2
-rw-r--r--doc/emacs/android.texi1140
-rw-r--r--doc/emacs/basic.texi15
-rw-r--r--doc/emacs/buffers.texi91
-rw-r--r--doc/emacs/building.texi20
-rw-r--r--doc/emacs/cmdargs.texi5
-rw-r--r--doc/emacs/commands.texi2
-rw-r--r--doc/emacs/custom.texi32
-rw-r--r--doc/emacs/dired.texi17
-rw-r--r--doc/emacs/display.texi8
-rw-r--r--doc/emacs/emacs.texi19
-rw-r--r--doc/emacs/files.texi55
-rw-r--r--doc/emacs/fixit.texi15
-rw-r--r--doc/emacs/frames.texi30
-rw-r--r--doc/emacs/haiku.texi112
-rw-r--r--doc/emacs/help.texi22
-rw-r--r--doc/emacs/input.texi192
-rw-r--r--doc/emacs/killing.texi2
-rw-r--r--doc/emacs/kmacro.texi19
-rw-r--r--doc/emacs/maintaining.texi55
-rw-r--r--doc/emacs/mini.texi16
-rw-r--r--doc/emacs/misc.texi80
-rw-r--r--doc/emacs/msdos.texi27
-rw-r--r--doc/emacs/package.texi11
-rw-r--r--doc/emacs/programs.texi113
-rw-r--r--doc/emacs/regs.texi63
-rw-r--r--doc/emacs/screen.texi8
-rw-r--r--doc/emacs/search.texi13
-rw-r--r--doc/emacs/text.texi22
-rw-r--r--doc/emacs/trouble.texi2
-rw-r--r--doc/emacs/windows.texi29
-rw-r--r--doc/lispref/ChangeLog.110
-rw-r--r--doc/lispref/Makefile.in11
-rw-r--r--doc/lispref/abbrevs.texi2
-rw-r--r--doc/lispref/buffers.texi28
-rw-r--r--doc/lispref/commands.texi414
-rw-r--r--doc/lispref/compile.texi78
-rw-r--r--doc/lispref/control.texi196
-rw-r--r--doc/lispref/display.texi53
-rw-r--r--doc/lispref/edebug.texi2
-rw-r--r--doc/lispref/elisp.texi10
-rw-r--r--doc/lispref/elisp_type_hierarchy.jpgbin0 -> 288444 bytes
-rw-r--r--doc/lispref/elisp_type_hierarchy.txt33
-rw-r--r--doc/lispref/eval.texi50
-rw-r--r--doc/lispref/files.texi77
-rw-r--r--doc/lispref/frames.texi1195
-rw-r--r--doc/lispref/functions.texi66
-rw-r--r--doc/lispref/hash.texi54
-rw-r--r--doc/lispref/help.texi28
-rw-r--r--doc/lispref/internals.texi24
-rw-r--r--doc/lispref/keymaps.texi25
-rw-r--r--doc/lispref/lists.texi19
-rw-r--r--doc/lispref/loading.texi17
-rw-r--r--doc/lispref/markers.texi8
-rw-r--r--doc/lispref/minibuf.texi93
-rw-r--r--doc/lispref/modes.texi234
-rw-r--r--doc/lispref/nonascii.texi4
-rw-r--r--doc/lispref/numbers.texi11
-rw-r--r--doc/lispref/objects.texi70
-rw-r--r--doc/lispref/os.texi138
-rw-r--r--doc/lispref/package.texi48
-rw-r--r--doc/lispref/parsing.texi144
-rw-r--r--doc/lispref/positions.texi23
-rw-r--r--doc/lispref/processes.texi29
-rw-r--r--doc/lispref/records.texi4
-rw-r--r--doc/lispref/searching.texi235
-rw-r--r--doc/lispref/sequences.texi195
-rw-r--r--doc/lispref/streams.texi9
-rw-r--r--doc/lispref/strings.texi19
-rw-r--r--doc/lispref/symbols.texi170
-rw-r--r--doc/lispref/text.texi116
-rw-r--r--doc/lispref/tips.texi2
-rw-r--r--doc/lispref/variables.texi439
-rw-r--r--doc/lispref/windows.texi136
-rw-r--r--doc/man/ChangeLog.14
-rw-r--r--doc/misc/ChangeLog.14
-rw-r--r--doc/misc/autotype.texi8
-rw-r--r--doc/misc/calc.texi41
-rw-r--r--doc/misc/cc-mode.texi72
-rw-r--r--doc/misc/cl.texi155
-rw-r--r--doc/misc/dired-x.texi10
-rw-r--r--doc/misc/efaq.texi65
-rw-r--r--doc/misc/eglot.texi250
-rw-r--r--doc/misc/epa.texi12
-rw-r--r--doc/misc/erc.texi966
-rw-r--r--doc/misc/ert.texi155
-rw-r--r--doc/misc/eshell.texi1026
-rw-r--r--doc/misc/eww.texi65
-rw-r--r--doc/misc/flymake.texi43
-rw-r--r--doc/misc/gnus.texi78
-rw-r--r--doc/misc/idlwave.texi2
-rw-r--r--doc/misc/message.texi19
-rw-r--r--doc/misc/mh-e.texi5
-rw-r--r--doc/misc/modus-themes.org5562
-rw-r--r--doc/misc/newsticker.texi9
-rw-r--r--doc/misc/octave-mode.texi2
-rw-r--r--doc/misc/org.org8
-rw-r--r--doc/misc/rcirc.texi12
-rw-r--r--doc/misc/sc.texi4
-rw-r--r--doc/misc/ses.texi299
-rw-r--r--doc/misc/texinfo.tex1673
-rw-r--r--doc/misc/todo-mode.texi14
-rw-r--r--doc/misc/tramp.texi469
-rw-r--r--doc/misc/trampver.texi4
-rw-r--r--doc/misc/transient.texi1050
-rw-r--r--doc/misc/url.texi52
-rw-r--r--doc/misc/use-package.texi54
-rw-r--r--doc/misc/vtable.texi13
-rw-r--r--doc/translations/README211
-rw-r--r--doc/translations/fr/misc/ses-fr.texi1631
-rw-r--r--etc/CALC-NEWS2
-rw-r--r--etc/ChangeLog.136
-rw-r--r--etc/DEBUG258
-rw-r--r--etc/EGLOT-NEWS176
-rw-r--r--etc/ERC-NEWS710
-rw-r--r--etc/MACHINES20
-rw-r--r--etc/NEWS6210
-rw-r--r--etc/NEWS.204
-rw-r--r--etc/NEWS.2120
-rw-r--r--etc/NEWS.222
-rw-r--r--etc/NEWS.238
-rw-r--r--etc/NEWS.2412
-rw-r--r--etc/NEWS.255
-rw-r--r--etc/NEWS.264
-rw-r--r--etc/NEWS.294382
-rw-r--r--etc/PROBLEMS157
-rw-r--r--etc/TODO48
-rw-r--r--etc/compilation.txt13
-rw-r--r--etc/emacs_lldb.py116
-rw-r--r--etc/emacsclient-mail.desktop7
-rw-r--r--etc/images/README18
-rw-r--r--etc/images/alt.pbmbin0 -> 85 bytes
-rw-r--r--etc/images/commit.pbmbin0 -> 81 bytes
-rw-r--r--etc/images/commit.xpm101
-rw-r--r--etc/images/conceal.pbmbin0 -> 41 bytes
-rw-r--r--etc/images/conceal.svg4
-rw-r--r--etc/images/ctrl.pbmbin0 -> 104 bytes
-rw-r--r--etc/images/gen-changelog.pbmbin0 -> 81 bytes
-rw-r--r--etc/images/gen-changelog.xpm152
-rw-r--r--etc/images/gnus/gnus-pointer.svg94
-rw-r--r--etc/images/hyper.pbmbin0 -> 123 bytes
-rw-r--r--etc/images/ins-changelog.pbm3
-rw-r--r--etc/images/ins-changelog.xpm67
-rw-r--r--etc/images/last-page.pbmbin0 -> 81 bytes
-rw-r--r--etc/images/last-page.xpm122
-rw-r--r--etc/images/load-changelog.pbmbin0 -> 81 bytes
-rw-r--r--etc/images/load-changelog.xpm82
-rw-r--r--etc/images/meta.pbmbin0 -> 104 bytes
-rw-r--r--etc/images/reveal.pbmbin0 -> 41 bytes
-rw-r--r--etc/images/reveal.svg4
-rw-r--r--etc/images/shift.pbmbin0 -> 169 bytes
-rw-r--r--etc/images/super.pbmbin0 -> 123 bytes
-rw-r--r--etc/images/symbols/README43
-rw-r--r--etc/images/symbols/check-mark_16.pbmbin0 -> 41 bytes
-rw-r--r--etc/images/symbols/check-mark_16.svg3
-rw-r--r--etc/images/symbols/chevron_down_16.pbmbin0 -> 41 bytes
-rw-r--r--etc/images/symbols/chevron_down_16.svg3
-rw-r--r--etc/images/symbols/chevron_left_16.pbmbin0 -> 41 bytes
-rw-r--r--etc/images/symbols/chevron_left_16.svg3
-rw-r--r--etc/images/symbols/chevron_right_16.pbmbin0 -> 41 bytes
-rw-r--r--etc/images/symbols/chevron_right_16.svg3
-rw-r--r--etc/images/symbols/chevron_up_16.pbmbin0 -> 41 bytes
-rw-r--r--etc/images/symbols/chevron_up_16.svg3
-rw-r--r--etc/images/symbols/cross_16.pbmbin0 -> 41 bytes
-rw-r--r--etc/images/symbols/cross_16.svg3
-rw-r--r--etc/images/symbols/cross_circle_16.pbmbin0 -> 41 bytes
-rw-r--r--etc/images/symbols/cross_circle_16.svg3
-rw-r--r--etc/images/symbols/cross_circle_fill_16.pbmbin0 -> 41 bytes
-rw-r--r--etc/images/symbols/cross_circle_fill_16.svg3
-rw-r--r--etc/images/symbols/dot_large_16.pbmbin0 -> 41 bytes
-rw-r--r--etc/images/symbols/dot_large_16.svg3
-rw-r--r--etc/images/symbols/dot_medium_16.pbmbin0 -> 41 bytes
-rw-r--r--etc/images/symbols/dot_medium_16.svg3
-rw-r--r--etc/images/symbols/dot_small_16.pbmbin0 -> 41 bytes
-rw-r--r--etc/images/symbols/dot_small_16.svg3
-rw-r--r--etc/images/symbols/heart_16.pbmbin0 -> 41 bytes
-rw-r--r--etc/images/symbols/heart_16.svg3
-rw-r--r--etc/images/symbols/heart_fill_16.pbmbin0 -> 41 bytes
-rw-r--r--etc/images/symbols/heart_fill_16.svg3
-rw-r--r--etc/images/symbols/heart_half_16.pbmbin0 -> 41 bytes
-rw-r--r--etc/images/symbols/heart_half_16.svg3
-rw-r--r--etc/images/symbols/menu_16.pbmbin0 -> 41 bytes
-rw-r--r--etc/images/symbols/menu_16.svg3
-rw-r--r--etc/images/symbols/minus_16.pbmbin0 -> 41 bytes
-rw-r--r--etc/images/symbols/minus_16.svg3
-rw-r--r--etc/images/symbols/minus_circle_16.pbmbin0 -> 41 bytes
-rw-r--r--etc/images/symbols/minus_circle_16.svg3
-rw-r--r--etc/images/symbols/minus_circle_fill_16.pbmbin0 -> 41 bytes
-rw-r--r--etc/images/symbols/minus_circle_fill_16.svg3
-rw-r--r--etc/images/symbols/plus_16.pbmbin0 -> 41 bytes
-rw-r--r--etc/images/symbols/plus_16.svg3
-rw-r--r--etc/images/symbols/plus_circle_16.pbmbin0 -> 41 bytes
-rw-r--r--etc/images/symbols/plus_circle_16.svg3
-rw-r--r--etc/images/symbols/plus_circle_fill_16.pbmbin0 -> 41 bytes
-rw-r--r--etc/images/symbols/plus_circle_fill_16.svg3
-rw-r--r--etc/images/symbols/star_16.pbmbin0 -> 41 bytes
-rw-r--r--etc/images/symbols/star_16.svg3
-rw-r--r--etc/images/symbols/star_fill_16.pbmbin0 -> 41 bytes
-rw-r--r--etc/images/symbols/star_fill_16.svg3
-rw-r--r--etc/images/symbols/star_half_16.pbmbin0 -> 72 bytes
-rw-r--r--etc/images/symbols/star_half_16.svg3
-rw-r--r--etc/images/view-diff.pbmbin0 -> 81 bytes
-rw-r--r--etc/images/view-diff.xpm93
-rw-r--r--etc/publicsuffix.txt4888
-rw-r--r--etc/themes/deeper-blue-theme.el8
-rw-r--r--etc/themes/leuven-dark-theme.el8
-rw-r--r--etc/themes/leuven-theme.el8
-rw-r--r--etc/themes/manoj-dark-theme.el17
-rw-r--r--etc/themes/modus-operandi-deuteranopia-theme.el515
-rw-r--r--etc/themes/modus-operandi-theme.el502
-rw-r--r--etc/themes/modus-operandi-tinted-theme.el513
-rw-r--r--etc/themes/modus-operandi-tritanopia-theme.el515
-rw-r--r--etc/themes/modus-themes.el10120
-rw-r--r--etc/themes/modus-vivendi-deuteranopia-theme.el515
-rw-r--r--etc/themes/modus-vivendi-theme.el502
-rw-r--r--etc/themes/modus-vivendi-tinted-theme.el513
-rw-r--r--etc/themes/modus-vivendi-tritanopia-theme.el515
-rw-r--r--etc/themes/whiteboard-theme.el8
-rw-r--r--exec/Makefile.in143
-rw-r--r--exec/README3
-rw-r--r--exec/config-mips.m4.in42
-rw-r--r--exec/configure.ac560
-rw-r--r--exec/deps.mk21
-rw-r--r--exec/exec.c1168
-rw-r--r--exec/exec.h206
-rw-r--r--exec/exec1.c94
-rw-r--r--exec/loader-aarch64.s187
-rw-r--r--exec/loader-armeabi.s204
-rw-r--r--exec/loader-mips64el.s234
-rw-r--r--exec/loader-mipsel.s236
-rw-r--r--exec/loader-x86.s203
-rw-r--r--exec/loader-x86_64.s195
-rw-r--r--exec/mipsel-user.h42
-rw-r--r--exec/mipsfpu.c289
-rw-r--r--exec/mipsfpu.h82
-rw-r--r--exec/test.c105
-rw-r--r--exec/trace.c1702
-rw-r--r--java/AndroidManifest.xml.in335
-rw-r--r--java/INSTALL1026
-rw-r--r--java/Makefile.in343
-rw-r--r--java/README27
-rwxr-xr-xjava/debug.sh371
-rw-r--r--java/emacs.keystorebin0 -> 2776 bytes
-rw-r--r--java/org/gnu/emacs/EmacsActivity.java581
-rw-r--r--java/org/gnu/emacs/EmacsApplication.java159
-rw-r--r--java/org/gnu/emacs/EmacsClipboard.java47
-rw-r--r--java/org/gnu/emacs/EmacsContextMenu.java405
-rw-r--r--java/org/gnu/emacs/EmacsCursor.java47
-rw-r--r--java/org/gnu/emacs/EmacsDesktopNotification.java344
-rw-r--r--java/org/gnu/emacs/EmacsDialog.java419
-rw-r--r--java/org/gnu/emacs/EmacsDialogButtonLayout.java152
-rw-r--r--java/org/gnu/emacs/EmacsDirectoryEntry.java33
-rw-r--r--java/org/gnu/emacs/EmacsDocumentsProvider.java578
-rw-r--r--java/org/gnu/emacs/EmacsDrawLine.java77
-rw-r--r--java/org/gnu/emacs/EmacsDrawPoint.java34
-rw-r--r--java/org/gnu/emacs/EmacsDrawRectangle.java119
-rw-r--r--java/org/gnu/emacs/EmacsDrawable.java33
-rw-r--r--java/org/gnu/emacs/EmacsFillPolygon.java80
-rw-r--r--java/org/gnu/emacs/EmacsFillRectangle.java116
-rw-r--r--java/org/gnu/emacs/EmacsFontDriver.java180
-rw-r--r--java/org/gnu/emacs/EmacsGC.java121
-rw-r--r--java/org/gnu/emacs/EmacsHandleObject.java59
-rw-r--r--java/org/gnu/emacs/EmacsHolder.java30
-rw-r--r--java/org/gnu/emacs/EmacsInputConnection.java713
-rw-r--r--java/org/gnu/emacs/EmacsLauncherPreferencesActivity.java31
-rw-r--r--java/org/gnu/emacs/EmacsMultitaskActivity.java29
-rw-r--r--java/org/gnu/emacs/EmacsNative.java359
-rw-r--r--java/org/gnu/emacs/EmacsNoninteractive.java203
-rw-r--r--java/org/gnu/emacs/EmacsOpenActivity.java763
-rw-r--r--java/org/gnu/emacs/EmacsPixmap.java170
-rw-r--r--java/org/gnu/emacs/EmacsPreferencesActivity.java169
-rw-r--r--java/org/gnu/emacs/EmacsSafThread.java1708
-rw-r--r--java/org/gnu/emacs/EmacsSdk11Clipboard.java308
-rw-r--r--java/org/gnu/emacs/EmacsSdk23FontDriver.java120
-rw-r--r--java/org/gnu/emacs/EmacsSdk7FontDriver.java497
-rw-r--r--java/org/gnu/emacs/EmacsSdk8Clipboard.java147
-rw-r--r--java/org/gnu/emacs/EmacsService.java2120
-rw-r--r--java/org/gnu/emacs/EmacsSurfaceView.java223
-rw-r--r--java/org/gnu/emacs/EmacsThread.java82
-rw-r--r--java/org/gnu/emacs/EmacsView.java938
-rw-r--r--java/org/gnu/emacs/EmacsWindow.java1878
-rw-r--r--java/org/gnu/emacs/EmacsWindowAttachmentManager.java211
-rw-r--r--java/res/drawable/emacs.pngbin0 -> 13462 bytes
-rw-r--r--java/res/drawable/emacs_background.xml42
-rw-r--r--java/res/drawable/emacs_foreground.xml39
-rw-r--r--java/res/drawable/emacs_wrench.pngbin0 -> 24996 bytes
-rw-r--r--java/res/layout/sdk8_notifications_view.xml33
-rw-r--r--java/res/mipmap-v26/emacs_icon.xml23
-rw-r--r--java/res/mipmap/emacs_icon.pngbin0 -> 13462 bytes
-rw-r--r--java/res/values-v11/style.xml24
-rw-r--r--java/res/values-v14/style.xml25
-rw-r--r--java/res/values-v19/bool.xml22
-rw-r--r--java/res/values-v24/bool.xml22
-rw-r--r--java/res/values-v29/style.xml32
-rw-r--r--java/res/values/bool.xml23
-rw-r--r--java/res/values/strings.xml45
-rw-r--r--java/res/values/style.xml26
-rw-r--r--java/res/xml/preferences.xml30
-rw-r--r--leim/MISC-DIC/CTLau-b5.html4
-rw-r--r--leim/Makefile.in6
-rw-r--r--leim/SKK-DIC/SKK-JISYO.L4
-rw-r--r--lib-src/ChangeLog.112
-rw-r--r--lib-src/Makefile.in43
-rw-r--r--lib-src/asset-directory-tool.c289
-rw-r--r--lib-src/ebrowse.c10
-rw-r--r--lib-src/emacsclient.c15
-rw-r--r--lib-src/etags.c13
-rw-r--r--lib-src/movemail.c5
-rw-r--r--lib-src/seccomp-filter.c4
-rw-r--r--lib-src/update-game-score.c6
-rw-r--r--lib/Makefile.in28
-rw-r--r--lib/_Noreturn.h5
-rw-r--r--lib/acl-internal.h11
-rw-r--r--lib/acl.h5
-rw-r--r--lib/alloca.in.h4
-rw-r--r--lib/attribute.h19
-rw-r--r--lib/binary-io.h11
-rw-r--r--lib/boot-time-aux.h323
-rw-r--r--lib/boot-time.c294
-rw-r--r--lib/boot-time.h44
-rw-r--r--lib/c++defs.h6
-rw-r--r--lib/c-ctype.h7
-rw-r--r--lib/c-strcase.h5
-rw-r--r--lib/c-strcasecmp.c3
-rw-r--r--lib/c-strncasecmp.c3
-rw-r--r--lib/careadlinkat.c12
-rw-r--r--lib/careadlinkat.h5
-rw-r--r--lib/cdefs.h44
-rw-r--r--lib/cloexec.c3
-rw-r--r--lib/close-stream.c3
-rw-r--r--lib/count-leading-zeros.h8
-rw-r--r--lib/count-one-bits.h8
-rw-r--r--lib/count-trailing-zeros.h8
-rw-r--r--lib/diffseq.h40
-rw-r--r--lib/dirent-private.h67
-rw-r--r--lib/dirent.in.h55
-rw-r--r--lib/dirfd.c72
-rw-r--r--lib/dup2.c3
-rw-r--r--lib/eloop-threshold.h5
-rw-r--r--lib/execinfo.in.h4
-rw-r--r--lib/faccessat.c6
-rw-r--r--lib/fcntl.in.h5
-rw-r--r--lib/fdopendir.c83
-rw-r--r--lib/file-has-acl.c214
-rw-r--r--lib/filemode.h10
-rw-r--r--lib/filevercmp.h5
-rw-r--r--lib/flexmember.h18
-rw-r--r--lib/fpending.c6
-rw-r--r--lib/fpending.h10
-rw-r--r--lib/fsusage.c4
-rw-r--r--lib/getdelim.c143
-rw-r--r--lib/getgroups.c3
-rw-r--r--lib/getline.c27
-rw-r--r--lib/getloadavg.c4
-rw-r--r--lib/getopt-cdefs.in.h6
-rw-r--r--lib/getopt-pfx-core.h2
-rw-r--r--lib/getopt.c33
-rw-r--r--lib/getopt1.c2
-rw-r--r--lib/gettext.h4
-rw-r--r--lib/gettime.c7
-rw-r--r--lib/gettimeofday.c17
-rw-r--r--lib/gnulib.mk.in305
-rw-r--r--lib/group-member.c4
-rw-r--r--lib/intprops-internal.h5
-rw-r--r--lib/inttypes.in.h39
-rw-r--r--lib/libc-config.h22
-rw-r--r--lib/limits.in.h34
-rw-r--r--lib/malloc.c3
-rw-r--r--lib/malloc/dynarray_emplace_enlarge.c4
-rw-r--r--lib/malloc/dynarray_resize.c4
-rw-r--r--lib/md5-stream.c4
-rw-r--r--lib/md5.c4
-rw-r--r--lib/md5.h31
-rw-r--r--lib/memmem.c4
-rw-r--r--lib/memrchr.c4
-rw-r--r--lib/memset_explicit.c55
-rw-r--r--lib/mini-gmp.c11
-rw-r--r--lib/minmax.h5
-rw-r--r--lib/mktime.c11
-rw-r--r--lib/nanosleep.c6
-rw-r--r--lib/nproc.c4
-rw-r--r--lib/nstrftime.c1481
-rw-r--r--lib/open.c6
-rw-r--r--lib/openat-proc.c27
-rw-r--r--lib/openat.h9
-rw-r--r--lib/pathmax.h5
-rw-r--r--lib/pselect.c12
-rw-r--r--lib/qcopy-acl.c36
-rw-r--r--lib/rawmemchr.c26
-rw-r--r--lib/readutmp.h338
-rw-r--r--lib/regcomp.c2
-rw-r--r--lib/regex.c4
-rw-r--r--lib/regex_internal.h6
-rw-r--r--lib/regexec.c2
-rw-r--r--lib/save-cwd.h4
-rw-r--r--lib/set-permissions.c1
-rw-r--r--lib/sha1.c3
-rw-r--r--lib/sha1.h21
-rw-r--r--lib/sha256.h21
-rw-r--r--lib/sha512.h21
-rw-r--r--lib/sig2str.c3
-rw-r--r--lib/signal.in.h5
-rw-r--r--lib/stat-time.h58
-rw-r--r--lib/stdalign.in.h120
-rw-r--r--lib/stddef.in.h76
-rw-r--r--lib/stdint.in.h2
-rw-r--r--lib/stdio-impl.h8
-rw-r--r--lib/stdio.in.h154
-rw-r--r--lib/stdlib.in.h343
-rw-r--r--lib/strftime.c2051
-rw-r--r--lib/strftime.h73
-rw-r--r--lib/string.in.h220
-rw-r--r--lib/strtoimax.c4
-rw-r--r--lib/strtol.c18
-rw-r--r--lib/strtoll.c4
-rw-r--r--lib/sys_random.in.h5
-rw-r--r--lib/sys_select.in.h12
-rw-r--r--lib/sys_stat.in.h48
-rw-r--r--lib/sys_time.in.h12
-rw-r--r--lib/sys_types.in.h7
-rw-r--r--lib/tempname.c4
-rw-r--r--lib/time.in.h141
-rw-r--r--lib/time_r.c8
-rw-r--r--lib/timespec-add.c5
-rw-r--r--lib/timespec-sub.c5
-rw-r--r--lib/timespec.h14
-rw-r--r--lib/u64.h8
-rw-r--r--lib/unistd.c2
-rw-r--r--lib/unistd.in.h138
-rw-r--r--lib/unlocked-io.h7
-rw-r--r--lib/utimens.c24
-rw-r--r--lib/utimens.h8
-rw-r--r--lib/verify.h75
-rw-r--r--lib/warn-on-use.h4
-rw-r--r--lib/xalloc-oversized.h14
-rw-r--r--lisp/ChangeLog.1344
-rw-r--r--lisp/ChangeLog.1454
-rw-r--r--lisp/ChangeLog.1510
-rw-r--r--lisp/ChangeLog.167
-rw-r--r--lisp/ChangeLog.1724
-rw-r--r--lisp/ChangeLog.3150
-rw-r--r--lisp/ChangeLog.414
-rw-r--r--lisp/ChangeLog.54
-rw-r--r--lisp/ChangeLog.64
-rw-r--r--lisp/ChangeLog.74
-rw-r--r--lisp/Makefile.in13
-rw-r--r--lisp/abbrev.el7
-rw-r--r--lisp/align.el132
-rw-r--r--lisp/allout-widgets.el3
-rw-r--r--lisp/allout.el14
-rw-r--r--lisp/ansi-osc.el3
-rw-r--r--lisp/apropos.el245
-rw-r--r--lisp/arc-mode.el114
-rw-r--r--lisp/auth-source-pass.el6
-rw-r--r--lisp/auth-source.el131
-rw-r--r--lisp/battery.el80
-rw-r--r--lisp/bind-key.el (renamed from lisp/use-package/bind-key.el)69
-rw-r--r--lisp/bindings.el113
-rw-r--r--lisp/bookmark.el11
-rw-r--r--lisp/bs.el97
-rw-r--r--lisp/buff-menu.el133
-rw-r--r--lisp/button.el32
-rw-r--r--lisp/calc/calc-aent.el46
-rw-r--r--lisp/calc/calc-ext.el5
-rw-r--r--lisp/calc/calc-graph.el7
-rw-r--r--lisp/calc/calc-help.el238
-rw-r--r--lisp/calc/calc-misc.el45
-rw-r--r--lisp/calc/calc-prog.el17
-rw-r--r--lisp/calc/calc-units.el178
-rw-r--r--lisp/calc/calc.el111
-rw-r--r--lisp/calculator.el5
-rw-r--r--lisp/calendar/appt.el15
-rw-r--r--lisp/calendar/cal-dst.el12
-rw-r--r--lisp/calendar/cal-move.el6
-rw-r--r--lisp/calendar/calendar.el30
-rw-r--r--lisp/calendar/diary-lib.el6
-rw-r--r--lisp/calendar/holidays.el4
-rw-r--r--lisp/calendar/icalendar.el4
-rw-r--r--lisp/calendar/iso8601.el16
-rw-r--r--lisp/calendar/lunar.el59
-rw-r--r--lisp/calendar/solar.el10
-rw-r--r--lisp/calendar/time-date.el1
-rw-r--r--lisp/calendar/todo-mode.el421
-rw-r--r--lisp/cedet/cedet-global.el9
-rw-r--r--lisp/cedet/mode-local.el69
-rw-r--r--lisp/cedet/semantic.el27
-rw-r--r--lisp/cedet/semantic/complete.el2
-rw-r--r--lisp/cedet/semantic/db-ebrowse.el3
-rw-r--r--lisp/cedet/semantic/db.el6
-rw-r--r--lisp/cedet/semantic/decorate/include.el10
-rw-r--r--lisp/cedet/semantic/fw.el5
-rw-r--r--lisp/cedet/semantic/grammar.el11
-rw-r--r--lisp/cedet/semantic/imenu.el6
-rw-r--r--lisp/cedet/semantic/lex-spp.el14
-rw-r--r--lisp/cedet/semantic/lex.el6
-rw-r--r--lisp/cedet/semantic/symref/grep.el6
-rw-r--r--lisp/cedet/semantic/tag.el3
-rw-r--r--lisp/cedet/semantic/wisent/python.el25
-rw-r--r--lisp/cedet/srecode/find.el64
-rw-r--r--lisp/cedet/srecode/map.el2
-rw-r--r--lisp/cedet/srecode/table.el51
-rw-r--r--lisp/char-fold.el2
-rw-r--r--lisp/comint.el64
-rw-r--r--lisp/completion-preview.el419
-rw-r--r--lisp/completion.el8
-rw-r--r--lisp/composite.el2
-rw-r--r--lisp/cus-edit.el433
-rw-r--r--lisp/cus-face.el2
-rw-r--r--lisp/cus-start.el9
-rw-r--r--lisp/cus-theme.el34
-rw-r--r--lisp/custom.el3
-rw-r--r--lisp/descr-text.el54
-rw-r--r--lisp/desktop.el18
-rw-r--r--lisp/dired-aux.el501
-rw-r--r--lisp/dired-x.el79
-rw-r--r--lisp/dired.el790
-rw-r--r--lisp/dnd.el131
-rw-r--r--lisp/doc-view.el146
-rw-r--r--lisp/dom.el2
-rw-r--r--lisp/dynamic-setting.el1
-rw-r--r--lisp/edmacro.el143
-rw-r--r--lisp/elec-pair.el20
-rw-r--r--lisp/electric.el4
-rw-r--r--lisp/elide-head.el55
-rw-r--r--lisp/emacs-lisp/advice.el6
-rw-r--r--lisp/emacs-lisp/backtrace.el70
-rw-r--r--lisp/emacs-lisp/bindat.el7
-rw-r--r--lisp/emacs-lisp/byte-opt.el2441
-rw-r--r--lisp/emacs-lisp/byte-run.el34
-rw-r--r--lisp/emacs-lisp/bytecomp.el1867
-rw-r--r--lisp/emacs-lisp/cconv.el604
-rw-r--r--lisp/emacs-lisp/check-declare.el118
-rw-r--r--lisp/emacs-lisp/checkdoc.el35
-rw-r--r--lisp/emacs-lisp/cl-extra.el85
-rw-r--r--lisp/emacs-lisp/cl-generic.el168
-rw-r--r--lisp/emacs-lisp/cl-indent.el2
-rw-r--r--lisp/emacs-lisp/cl-lib.el22
-rw-r--r--lisp/emacs-lisp/cl-macs.el367
-rw-r--r--lisp/emacs-lisp/cl-preloaded.el252
-rw-r--r--lisp/emacs-lisp/cl-print.el392
-rw-r--r--lisp/emacs-lisp/comp-common.el554
-rw-r--r--lisp/emacs-lisp/comp-cstr.el252
-rw-r--r--lisp/emacs-lisp/comp-run.el483
-rw-r--r--lisp/emacs-lisp/comp.el2429
-rw-r--r--lisp/emacs-lisp/compat.el92
-rw-r--r--lisp/emacs-lisp/debug-early.el85
-rw-r--r--lisp/emacs-lisp/debug.el87
-rw-r--r--lisp/emacs-lisp/derived.el139
-rw-r--r--lisp/emacs-lisp/disass.el79
-rw-r--r--lisp/emacs-lisp/easy-mmode.el24
-rw-r--r--lisp/emacs-lisp/edebug.el368
-rw-r--r--lisp/emacs-lisp/eieio-core.el158
-rw-r--r--lisp/emacs-lisp/eieio-opt.el2
-rw-r--r--lisp/emacs-lisp/eieio.el29
-rw-r--r--lisp/emacs-lisp/eldoc.el248
-rw-r--r--lisp/emacs-lisp/elint.el21
-rw-r--r--lisp/emacs-lisp/ert-font-lock.el407
-rw-r--r--lisp/emacs-lisp/ert-x.el8
-rw-r--r--lisp/emacs-lisp/ert.el182
-rw-r--r--lisp/emacs-lisp/find-func.el28
-rw-r--r--lisp/emacs-lisp/gv.el25
-rw-r--r--lisp/emacs-lisp/inline.el4
-rw-r--r--lisp/emacs-lisp/lisp-mnt.el65
-rw-r--r--lisp/emacs-lisp/lisp-mode.el24
-rw-r--r--lisp/emacs-lisp/lisp.el4
-rw-r--r--lisp/emacs-lisp/loaddefs-gen.el74
-rw-r--r--lisp/emacs-lisp/macroexp.el383
-rw-r--r--lisp/emacs-lisp/map-ynp.el10
-rw-r--r--lisp/emacs-lisp/map.el60
-rw-r--r--lisp/emacs-lisp/nadvice.el110
-rw-r--r--lisp/emacs-lisp/oclosure.el14
-rw-r--r--lisp/emacs-lisp/package-vc.el352
-rw-r--r--lisp/emacs-lisp/package.el339
-rw-r--r--lisp/emacs-lisp/pcase.el184
-rw-r--r--lisp/emacs-lisp/pp.el389
-rw-r--r--lisp/emacs-lisp/range.el8
-rw-r--r--lisp/emacs-lisp/re-builder.el2
-rw-r--r--lisp/emacs-lisp/regexp-opt.el3
-rw-r--r--lisp/emacs-lisp/rmc.el3
-rw-r--r--lisp/emacs-lisp/rx.el795
-rw-r--r--lisp/emacs-lisp/seq.el20
-rw-r--r--lisp/emacs-lisp/shortdoc.el220
-rw-r--r--lisp/emacs-lisp/shorthands.el25
-rw-r--r--lisp/emacs-lisp/smie.el4
-rw-r--r--lisp/emacs-lisp/subr-x.el22
-rw-r--r--lisp/emacs-lisp/syntax.el302
-rw-r--r--lisp/emacs-lisp/tabulated-list.el68
-rw-r--r--lisp/emacs-lisp/timer.el7
-rw-r--r--lisp/emacs-lisp/trace.el118
-rw-r--r--lisp/emacs-lisp/unsafep.el2
-rw-r--r--lisp/emacs-lisp/vtable.el64
-rw-r--r--lisp/emacs-lisp/warnings.el1
-rw-r--r--lisp/emulation/cua-base.el2
-rw-r--r--lisp/emulation/viper-cmd.el68
-rw-r--r--lisp/emulation/viper-ex.el3
-rw-r--r--lisp/emulation/viper-init.el13
-rw-r--r--lisp/emulation/viper.el11
-rw-r--r--lisp/env.el4
-rw-r--r--lisp/epa.el34
-rw-r--r--lisp/epg.el10
-rw-r--r--lisp/erc/erc-backend.el588
-rw-r--r--lisp/erc/erc-button.el557
-rw-r--r--lisp/erc/erc-capab.el1
-rw-r--r--lisp/erc/erc-common.el498
-rw-r--r--lisp/erc/erc-compat.el57
-rw-r--r--lisp/erc/erc-dcc.el88
-rw-r--r--lisp/erc/erc-desktop-notifications.el24
-rw-r--r--lisp/erc/erc-fill.el778
-rw-r--r--lisp/erc/erc-goodies.el666
-rw-r--r--lisp/erc/erc-ibuffer.el17
-rw-r--r--lisp/erc/erc-imenu.el28
-rw-r--r--lisp/erc/erc-join.el48
-rw-r--r--lisp/erc/erc-log.el40
-rw-r--r--lisp/erc/erc-match.el64
-rw-r--r--lisp/erc/erc-netsplit.el17
-rw-r--r--lisp/erc/erc-networks.el193
-rw-r--r--lisp/erc/erc-nicks.el774
-rw-r--r--lisp/erc/erc-notify.el85
-rw-r--r--lisp/erc/erc-page.el7
-rw-r--r--lisp/erc/erc-pcomplete.el4
-rw-r--r--lisp/erc/erc-ring.el4
-rw-r--r--lisp/erc/erc-sasl.el61
-rw-r--r--lisp/erc/erc-services.el122
-rw-r--r--lisp/erc/erc-sound.el12
-rw-r--r--lisp/erc/erc-speedbar.el406
-rw-r--r--lisp/erc/erc-spelling.el9
-rw-r--r--lisp/erc/erc-stamp.el760
-rw-r--r--lisp/erc/erc-status-sidebar.el369
-rw-r--r--lisp/erc/erc-track.el314
-rw-r--r--lisp/erc/erc-truncate.el62
-rw-r--r--lisp/erc/erc.el4186
-rw-r--r--lisp/eshell/em-alias.el4
-rw-r--r--lisp/eshell/em-banner.el1
-rw-r--r--lisp/eshell/em-basic.el61
-rw-r--r--lisp/eshell/em-cmpl.el173
-rw-r--r--lisp/eshell/em-dirs.el62
-rw-r--r--lisp/eshell/em-elecslash.el2
-rw-r--r--lisp/eshell/em-extpipe.el176
-rw-r--r--lisp/eshell/em-glob.el77
-rw-r--r--lisp/eshell/em-hist.el108
-rw-r--r--lisp/eshell/em-ls.el43
-rw-r--r--lisp/eshell/em-pred.el25
-rw-r--r--lisp/eshell/em-prompt.el164
-rw-r--r--lisp/eshell/em-rebind.el26
-rw-r--r--lisp/eshell/em-script.el32
-rw-r--r--lisp/eshell/em-smart.el86
-rw-r--r--lisp/eshell/em-term.el6
-rw-r--r--lisp/eshell/em-tramp.el25
-rw-r--r--lisp/eshell/em-unix.el217
-rw-r--r--lisp/eshell/em-xtra.el2
-rw-r--r--lisp/eshell/esh-arg.el369
-rw-r--r--lisp/eshell/esh-cmd.el1098
-rw-r--r--lisp/eshell/esh-ext.el68
-rw-r--r--lisp/eshell/esh-io.el494
-rw-r--r--lisp/eshell/esh-mode.el123
-rw-r--r--lisp/eshell/esh-module.el32
-rw-r--r--lisp/eshell/esh-opt.el71
-rw-r--r--lisp/eshell/esh-proc.el300
-rw-r--r--lisp/eshell/esh-util.el298
-rw-r--r--lisp/eshell/esh-var.el485
-rw-r--r--lisp/eshell/eshell.el98
-rw-r--r--lisp/external-completion.el3
-rw-r--r--lisp/faces.el129
-rw-r--r--lisp/ffap.el37
-rw-r--r--lisp/filecache.el2
-rw-r--r--lisp/filenotify.el14
-rw-r--r--lisp/files-x.el165
-rw-r--r--lisp/files.el1161
-rw-r--r--lisp/filesets.el80
-rw-r--r--lisp/find-dired.el9
-rw-r--r--lisp/finder.el6
-rw-r--r--lisp/foldout.el2
-rw-r--r--lisp/follow.el5
-rw-r--r--lisp/font-lock.el4
-rw-r--r--lisp/format.el13
-rw-r--r--lisp/forms.el2
-rw-r--r--lisp/frame.el100
-rw-r--r--lisp/gnus/gmm-utils.el3
-rw-r--r--lisp/gnus/gnus-agent.el13
-rw-r--r--lisp/gnus/gnus-art.el37
-rw-r--r--lisp/gnus/gnus-cite.el42
-rw-r--r--lisp/gnus/gnus-cloud.el1
-rw-r--r--lisp/gnus/gnus-dired.el9
-rw-r--r--lisp/gnus/gnus-eform.el13
-rw-r--r--lisp/gnus/gnus-group.el25
-rw-r--r--lisp/gnus/gnus-icalendar.el22
-rw-r--r--lisp/gnus/gnus-logic.el10
-rw-r--r--lisp/gnus/gnus-msg.el42
-rw-r--r--lisp/gnus/gnus-notifications.el46
-rw-r--r--lisp/gnus/gnus-registry.el2
-rw-r--r--lisp/gnus/gnus-score.el92
-rw-r--r--lisp/gnus/gnus-search.el123
-rw-r--r--lisp/gnus/gnus-start.el21
-rw-r--r--lisp/gnus/gnus-sum.el191
-rw-r--r--lisp/gnus/gnus-util.el11
-rw-r--r--lisp/gnus/gnus-uu.el3
-rw-r--r--lisp/gnus/gnus.el40
-rw-r--r--lisp/gnus/legacy-gnus-agent.el260
-rw-r--r--lisp/gnus/mail-source.el89
-rw-r--r--lisp/gnus/message.el120
-rw-r--r--lisp/gnus/mm-decode.el6
-rw-r--r--lisp/gnus/mm-view.el2
-rw-r--r--lisp/gnus/mml.el74
-rw-r--r--lisp/gnus/mml2015.el2
-rw-r--r--lisp/gnus/nndiary.el11
-rw-r--r--lisp/gnus/nnheader.el2
-rw-r--r--lisp/gnus/nnimap.el14
-rw-r--r--lisp/gnus/nnmairix.el3
-rw-r--r--lisp/gnus/nnrss.el2
-rw-r--r--lisp/gnus/nnselect.el829
-rw-r--r--lisp/gnus/nnspool.el6
-rw-r--r--lisp/gnus/nntp.el3
-rw-r--r--lisp/gnus/nnweb.el39
-rw-r--r--lisp/gnus/spam.el3
-rw-r--r--lisp/help-fns.el293
-rw-r--r--lisp/help-macro.el268
-rw-r--r--lisp/help-mode.el22
-rw-r--r--lisp/help.el170
-rw-r--r--lisp/hexl.el2
-rw-r--r--lisp/htmlfontify.el6
-rw-r--r--lisp/ibuf-ext.el130
-rw-r--r--lisp/ibuf-macs.el9
-rw-r--r--lisp/ibuffer.el255
-rw-r--r--lisp/icomplete.el28
-rw-r--r--lisp/ido.el9
-rw-r--r--lisp/ielm.el38
-rw-r--r--lisp/iimage.el1
-rw-r--r--lisp/image-mode.el11
-rw-r--r--lisp/image.el281
-rw-r--r--lisp/image/exif.el21
-rw-r--r--lisp/image/image-dired-dired.el2
-rw-r--r--lisp/image/image-dired-external.el3
-rw-r--r--lisp/image/image-dired-util.el101
-rw-r--r--lisp/image/image-dired.el103
-rw-r--r--lisp/image/wallpaper.el2
-rw-r--r--lisp/imenu.el25
-rw-r--r--lisp/indent-aux.el76
-rw-r--r--lisp/indent.el2
-rw-r--r--lisp/info-look.el40
-rw-r--r--lisp/info-xref.el8
-rw-r--r--lisp/info.el200
-rw-r--r--lisp/international/characters.el220
-rw-r--r--lisp/international/emoji.el277
-rw-r--r--lisp/international/fontset.el39
-rw-r--r--lisp/international/iso-transl.el2
-rw-r--r--lisp/international/ja-dic-cnv.el4
-rw-r--r--lisp/international/mule-cmds.el17
-rw-r--r--lisp/international/mule-conf.el16
-rw-r--r--lisp/international/ogonek.el4
-rw-r--r--lisp/international/quail.el11
-rw-r--r--lisp/international/textsec.el3
-rw-r--r--lisp/international/titdic-cnv.el119
-rw-r--r--lisp/isearch.el56
-rw-r--r--lisp/jit-lock.el4
-rw-r--r--lisp/jsonrpc.el848
-rw-r--r--lisp/keymap.el12
-rw-r--r--lisp/kmacro.el75
-rw-r--r--lisp/language/chinese.el5
-rw-r--r--lisp/language/cyrillic.el3
-rw-r--r--lisp/language/hanja-util.el18
-rw-r--r--lisp/language/japan-util.el4
-rw-r--r--lisp/language/japanese.el3
-rw-r--r--lisp/language/korean.el1
-rw-r--r--lisp/language/lao-util.el19
-rw-r--r--lisp/language/tibetan.el49
-rw-r--r--lisp/language/vietnamese.el32
-rw-r--r--lisp/ldefs-boot.el3327
-rw-r--r--lisp/leim/quail/hangul.el43
-rw-r--r--lisp/leim/quail/indian.el6
-rw-r--r--lisp/leim/quail/latin-ltx.el3
-rw-r--r--lisp/leim/quail/latin-post.el50
-rw-r--r--lisp/leim/quail/latin-pre.el6
-rw-r--r--lisp/leim/quail/pakistan.el726
-rw-r--r--lisp/leim/quail/persian.el2
-rw-r--r--lisp/loadhist.el15
-rw-r--r--lisp/loadup.el245
-rw-r--r--lisp/locate.el58
-rw-r--r--lisp/lpr.el3
-rw-r--r--lisp/ls-lisp.el200
-rw-r--r--lisp/macros.el20
-rw-r--r--lisp/mail/binhex.el2
-rw-r--r--lisp/mail/emacsbug.el10
-rw-r--r--lisp/mail/feedmail.el78
-rw-r--r--lisp/mail/footnote.el7
-rw-r--r--lisp/mail/ietf-drums.el25
-rw-r--r--lisp/mail/mail-extr.el2
-rw-r--r--lisp/mail/mailabbrev.el12
-rw-r--r--lisp/mail/mailclient.el193
-rw-r--r--lisp/mail/rmail.el339
-rw-r--r--lisp/mail/rmailkwd.el2
-rw-r--r--lisp/mail/rmailout.el5
-rw-r--r--lisp/mail/rmailsum.el5
-rw-r--r--lisp/mail/sendmail.el11
-rw-r--r--lisp/mail/smtpmail.el91
-rw-r--r--lisp/mail/supercite.el9
-rw-r--r--lisp/mail/uudecode.el2
-rw-r--r--lisp/mail/yenc.el4
-rw-r--r--lisp/man.el205
-rw-r--r--lisp/menu-bar.el123
-rw-r--r--lisp/mh-e/mh-acros.el73
-rw-r--r--lisp/mh-e/mh-folder.el5
-rw-r--r--lisp/mh-e/mh-identity.el2
-rw-r--r--lisp/mh-e/mh-mime.el1
-rw-r--r--lisp/mh-e/mh-print.el3
-rw-r--r--lisp/mh-e/mh-show.el1
-rw-r--r--lisp/minibuffer.el1029
-rw-r--r--lisp/misc.el65
-rw-r--r--lisp/misearch.el151
-rw-r--r--lisp/mouse.el112
-rw-r--r--lisp/mpc.el13
-rw-r--r--lisp/mwheel.el174
-rw-r--r--lisp/net/ange-ftp.el79
-rw-r--r--lisp/net/browse-url.el74
-rw-r--r--lisp/net/dictionary.el400
-rw-r--r--lisp/net/dns.el4
-rw-r--r--lisp/net/eudc-vars.el7
-rw-r--r--lisp/net/eudcb-mab.el3
-rw-r--r--lisp/net/eww.el567
-rw-r--r--lisp/net/gnutls.el12
-rw-r--r--lisp/net/imap.el10
-rw-r--r--lisp/net/ldap.el69
-rw-r--r--lisp/net/mailcap.el4
-rw-r--r--lisp/net/mairix.el5
-rw-r--r--lisp/net/net-utils.el10
-rw-r--r--lisp/net/newst-backend.el45
-rw-r--r--lisp/net/newst-plainview.el44
-rw-r--r--lisp/net/newst-reader.el5
-rw-r--r--lisp/net/newst-ticker.el69
-rw-r--r--lisp/net/newsticker.el4
-rw-r--r--lisp/net/nsm.el32
-rw-r--r--lisp/net/ntlm.el4
-rw-r--r--lisp/net/rcirc.el43
-rw-r--r--lisp/net/secrets.el27
-rw-r--r--lisp/net/shr.el300
-rw-r--r--lisp/net/sieve-manage.el26
-rw-r--r--lisp/net/sieve-mode.el28
-rw-r--r--lisp/net/sieve.el2
-rw-r--r--lisp/net/soap-client.el15
-rw-r--r--lisp/net/socks.el31
-rw-r--r--lisp/net/tramp-adb.el341
-rw-r--r--lisp/net/tramp-androidsu.el561
-rw-r--r--lisp/net/tramp-archive.el73
-rw-r--r--lisp/net/tramp-cache.el130
-rw-r--r--lisp/net/tramp-cmds.el160
-rw-r--r--lisp/net/tramp-compat.el226
-rw-r--r--lisp/net/tramp-container.el433
-rw-r--r--lisp/net/tramp-crypt.el221
-rw-r--r--lisp/net/tramp-fuse.el42
-rw-r--r--lisp/net/tramp-gvfs.el489
-rw-r--r--lisp/net/tramp-integration.el45
-rw-r--r--lisp/net/tramp-message.el587
-rw-r--r--lisp/net/tramp-rclone.el107
-rw-r--r--lisp/net/tramp-sh.el1558
-rw-r--r--lisp/net/tramp-smb.el532
-rw-r--r--lisp/net/tramp-sshfs.el109
-rw-r--r--lisp/net/tramp-sudoedit.el257
-rw-r--r--lisp/net/tramp.el1948
-rw-r--r--lisp/net/trampver.el20
-rw-r--r--lisp/net/webjump.el53
-rw-r--r--lisp/notifications.el11
-rw-r--r--lisp/nxml/nxml-enc.el2
-rw-r--r--lisp/nxml/nxml-maint.el4
-rw-r--r--lisp/nxml/nxml-mode.el17
-rw-r--r--lisp/nxml/nxml-ns.el2
-rw-r--r--lisp/nxml/nxml-outln.el2
-rw-r--r--lisp/nxml/nxml-parse.el2
-rw-r--r--lisp/nxml/nxml-rap.el2
-rw-r--r--lisp/nxml/nxml-util.el2
-rw-r--r--lisp/nxml/rng-cmpct.el2
-rw-r--r--lisp/nxml/rng-dt.el2
-rw-r--r--lisp/nxml/rng-loc.el2
-rw-r--r--lisp/nxml/rng-maint.el2
-rw-r--r--lisp/nxml/rng-match.el2
-rw-r--r--lisp/nxml/rng-nxml.el2
-rw-r--r--lisp/nxml/rng-parse.el2
-rw-r--r--lisp/nxml/rng-pttrn.el2
-rw-r--r--lisp/nxml/rng-uri.el2
-rw-r--r--lisp/nxml/rng-util.el25
-rw-r--r--lisp/nxml/rng-valid.el2
-rw-r--r--lisp/nxml/rng-xsd.el2
-rw-r--r--lisp/nxml/xmltok.el2
-rw-r--r--lisp/nxml/xsd-regexp.el2
-rw-r--r--lisp/obarray.el25
-rw-r--r--lisp/obsolete/eieio-compat.el5
-rw-r--r--lisp/obsolete/iswitchb.el6
-rw-r--r--lisp/obsolete/landmark.el8
-rw-r--r--lisp/obsolete/longlines.el16
-rw-r--r--lisp/obsolete/mantemp.el2
-rw-r--r--lisp/obsolete/pgg.el4
-rw-r--r--lisp/obsolete/ps-def.el2
-rw-r--r--lisp/obsolete/quickurl.el2
-rw-r--r--lisp/obsolete/rcompile.el14
-rw-r--r--lisp/obsolete/terminal.el6
-rw-r--r--lisp/obsolete/url-ns.el5
-rw-r--r--lisp/org/ob-calc.el2
-rw-r--r--lisp/org/ob-eshell.el9
-rw-r--r--lisp/org/ob-lua.el2
-rw-r--r--lisp/org/ob-python.el4
-rw-r--r--lisp/org/ob-tangle.el2
-rw-r--r--lisp/org/ol-bbdb.el2
-rw-r--r--lisp/org/ol-bibtex.el2
-rw-r--r--lisp/org/ol-docview.el2
-rw-r--r--lisp/org/ol-gnus.el2
-rw-r--r--lisp/org/ol-info.el2
-rw-r--r--lisp/org/ol-man.el2
-rw-r--r--lisp/org/ol-mhe.el2
-rw-r--r--lisp/org/ol-rmail.el2
-rw-r--r--lisp/org/ol-w3m.el2
-rw-r--r--lisp/org/ol.el6
-rw-r--r--lisp/org/org-agenda.el4
-rw-r--r--lisp/org/org-archive.el2
-rw-r--r--lisp/org/org-capture.el2
-rw-r--r--lisp/org/org-clock.el16
-rw-r--r--lisp/org/org-colview.el2
-rw-r--r--lisp/org/org-compat.el2
-rw-r--r--lisp/org/org-ctags.el6
-rw-r--r--lisp/org/org-datetree.el2
-rw-r--r--lisp/org/org-duration.el2
-rw-r--r--lisp/org/org-element.el6
-rw-r--r--lisp/org/org-entities.el2
-rw-r--r--lisp/org/org-faces.el2
-rw-r--r--lisp/org/org-feed.el2
-rw-r--r--lisp/org/org-footnote.el2
-rw-r--r--lisp/org/org-goto.el2
-rw-r--r--lisp/org/org-habit.el2
-rw-r--r--lisp/org/org-id.el2
-rw-r--r--lisp/org/org-indent.el2
-rw-r--r--lisp/org/org-inlinetask.el2
-rw-r--r--lisp/org/org-lint.el2
-rw-r--r--lisp/org/org-list.el2
-rw-r--r--lisp/org/org-macro.el2
-rw-r--r--lisp/org/org-macs.el4
-rw-r--r--lisp/org/org-mobile.el2
-rw-r--r--lisp/org/org-mouse.el4
-rw-r--r--lisp/org/org-num.el2
-rw-r--r--lisp/org/org-pcomplete.el2
-rw-r--r--lisp/org/org-protocol.el2
-rw-r--r--lisp/org/org-refile.el2
-rw-r--r--lisp/org/org-src.el9
-rw-r--r--lisp/org/org-table.el18
-rw-r--r--lisp/org/org-tempo.el2
-rw-r--r--lisp/org/org-timer.el2
-rw-r--r--lisp/org/org.el43
-rw-r--r--lisp/org/ox-ascii.el2
-rw-r--r--lisp/org/ox-beamer.el16
-rw-r--r--lisp/org/ox-html.el3
-rw-r--r--lisp/org/ox-icalendar.el2
-rw-r--r--lisp/org/ox-koma-letter.el6
-rw-r--r--lisp/org/ox-latex.el11
-rw-r--r--lisp/org/ox-man.el2
-rw-r--r--lisp/org/ox-md.el2
-rw-r--r--lisp/org/ox-odt.el2
-rw-r--r--lisp/org/ox-org.el2
-rw-r--r--lisp/org/ox-publish.el2
-rw-r--r--lisp/org/ox-texinfo.el2
-rw-r--r--lisp/org/ox.el4
-rw-r--r--lisp/outline.el26
-rw-r--r--lisp/pcmpl-git.el2
-rw-r--r--lisp/pcmpl-gnu.el269
-rw-r--r--lisp/pcmpl-linux.el4
-rw-r--r--lisp/pcmpl-unix.el10
-rw-r--r--lisp/pcomplete.el125
-rw-r--r--lisp/pgtk-dnd.el30
-rw-r--r--lisp/pixel-scroll.el131
-rw-r--r--lisp/play/cookie1.el4
-rw-r--r--lisp/play/decipher.el6
-rw-r--r--lisp/play/doctor.el5
-rw-r--r--lisp/play/dunnet.el5
-rw-r--r--lisp/play/gamegrid.el4
-rw-r--r--lisp/play/handwrite.el2
-rw-r--r--lisp/printing.el5
-rw-r--r--lisp/proced.el215
-rw-r--r--lisp/profiler.el74
-rw-r--r--lisp/progmodes/antlr-mode.el2
-rw-r--r--lisp/progmodes/asm-mode.el10
-rw-r--r--lisp/progmodes/bug-reference.el45
-rw-r--r--lisp/progmodes/c-ts-common.el9
-rw-r--r--lisp/progmodes/c-ts-mode.el237
-rw-r--r--lisp/progmodes/cc-align.el10
-rw-r--r--lisp/progmodes/cc-awk.el16
-rw-r--r--lisp/progmodes/cc-cmds.el38
-rw-r--r--lisp/progmodes/cc-defs.el196
-rw-r--r--lisp/progmodes/cc-engine.el1604
-rw-r--r--lisp/progmodes/cc-fonts.el119
-rw-r--r--lisp/progmodes/cc-langs.el151
-rw-r--r--lisp/progmodes/cc-mode.el74
-rw-r--r--lisp/progmodes/cc-styles.el5
-rw-r--r--lisp/progmodes/cc-vars.el16
-rw-r--r--lisp/progmodes/cl-font-lock.el2
-rw-r--r--lisp/progmodes/cmake-ts-mode.el20
-rw-r--r--lisp/progmodes/compile.el113
-rw-r--r--lisp/progmodes/cperl-mode.el1630
-rw-r--r--lisp/progmodes/csharp-mode.el9
-rw-r--r--lisp/progmodes/dcl-mode.el2
-rw-r--r--lisp/progmodes/dockerfile-ts-mode.el7
-rw-r--r--lisp/progmodes/ebnf-abn.el2
-rw-r--r--lisp/progmodes/ebnf-bnf.el2
-rw-r--r--lisp/progmodes/ebnf-dtd.el2
-rw-r--r--lisp/progmodes/ebnf-ebx.el2
-rw-r--r--lisp/progmodes/ebnf-iso.el2
-rw-r--r--lisp/progmodes/ebnf-otz.el5
-rw-r--r--lisp/progmodes/ebnf-yac.el2
-rw-r--r--lisp/progmodes/ebnf2ps.el4
-rw-r--r--lisp/progmodes/ebrowse.el6
-rw-r--r--lisp/progmodes/eglot.el1923
-rw-r--r--lisp/progmodes/elisp-mode.el110
-rw-r--r--lisp/progmodes/elixir-ts-mode.el767
-rw-r--r--lisp/progmodes/erts-mode.el3
-rw-r--r--lisp/progmodes/etags-regen.el431
-rw-r--r--lisp/progmodes/etags.el27
-rw-r--r--lisp/progmodes/f90.el1
-rw-r--r--lisp/progmodes/flymake-proc.el5
-rw-r--r--lisp/progmodes/flymake.el390
-rw-r--r--lisp/progmodes/fortran.el2
-rw-r--r--lisp/progmodes/gdb-mi.el273
-rw-r--r--lisp/progmodes/go-ts-mode.el56
-rw-r--r--lisp/progmodes/grep.el66
-rw-r--r--lisp/progmodes/gud.el729
-rw-r--r--lisp/progmodes/heex-ts-mode.el198
-rw-r--r--lisp/progmodes/hideif.el386
-rw-r--r--lisp/progmodes/hideshow.el4
-rw-r--r--lisp/progmodes/idlw-help.el3
-rw-r--r--lisp/progmodes/idlw-shell.el10
-rw-r--r--lisp/progmodes/idlwave.el31
-rw-r--r--lisp/progmodes/java-ts-mode.el40
-rw-r--r--lisp/progmodes/js.el75
-rw-r--r--lisp/progmodes/json-ts-mode.el6
-rw-r--r--lisp/progmodes/lua-ts-mode.el797
-rw-r--r--lisp/progmodes/make-mode.el136
-rw-r--r--lisp/progmodes/modula2.el47
-rw-r--r--lisp/progmodes/opascal.el2
-rw-r--r--lisp/progmodes/perl-mode.el43
-rw-r--r--lisp/progmodes/prog-mode.el38
-rw-r--r--lisp/progmodes/project.el604
-rw-r--r--lisp/progmodes/prolog.el8
-rw-r--r--lisp/progmodes/ps-mode.el6
-rw-r--r--lisp/progmodes/python.el522
-rw-r--r--lisp/progmodes/ruby-mode.el215
-rw-r--r--lisp/progmodes/ruby-ts-mode.el89
-rw-r--r--lisp/progmodes/rust-ts-mode.el29
-rw-r--r--lisp/progmodes/scheme.el2
-rw-r--r--lisp/progmodes/sh-script.el64
-rw-r--r--lisp/progmodes/sql.el21
-rw-r--r--lisp/progmodes/tcl.el4
-rw-r--r--lisp/progmodes/typescript-ts-mode.el69
-rw-r--r--lisp/progmodes/vera-mode.el2
-rw-r--r--lisp/progmodes/verilog-mode.el1751
-rw-r--r--lisp/progmodes/vhdl-mode.el127
-rw-r--r--lisp/progmodes/which-func.el65
-rw-r--r--lisp/progmodes/xref.el71
-rw-r--r--lisp/ps-bdf.el2
-rw-r--r--lisp/ps-mule.el2
-rw-r--r--lisp/ps-print.el18
-rw-r--r--lisp/ps-samp.el2
-rw-r--r--lisp/recentf.el24
-rw-r--r--lisp/rect.el33
-rw-r--r--lisp/register.el481
-rw-r--r--lisp/replace.el17
-rw-r--r--lisp/reveal.el18
-rw-r--r--lisp/saveplace.el165
-rw-r--r--lisp/select.el39
-rw-r--r--lisp/server.el240
-rw-r--r--lisp/ses.el88
-rw-r--r--lisp/shell.el98
-rw-r--r--lisp/simple.el797
-rw-r--r--lisp/so-long.el30
-rw-r--r--lisp/sort.el13
-rw-r--r--lisp/speedbar.el90
-rw-r--r--lisp/sqlite-mode.el1
-rw-r--r--lisp/startup.el286
-rw-r--r--lisp/strokes.el74
-rw-r--r--lisp/subr.el848
-rw-r--r--lisp/svg.el3
-rw-r--r--lisp/tab-bar.el476
-rw-r--r--lisp/tab-line.el263
-rw-r--r--lisp/tar-mode.el187
-rw-r--r--lisp/tempo.el194
-rw-r--r--lisp/term.el35
-rw-r--r--lisp/term/AT386.el2
-rw-r--r--lisp/term/android-win.el622
-rw-r--r--lisp/term/bobcat.el4
-rw-r--r--lisp/term/haiku-win.el14
-rw-r--r--lisp/term/ns-win.el11
-rw-r--r--lisp/term/pgtk-win.el40
-rw-r--r--lisp/term/w32-win.el14
-rw-r--r--lisp/term/xterm.el2
-rw-r--r--lisp/textmodes/artist.el4
-rw-r--r--lisp/textmodes/bibtex.el16
-rw-r--r--lisp/textmodes/conf-mode.el7
-rw-r--r--lisp/textmodes/css-mode.el2
-rw-r--r--lisp/textmodes/enriched.el4
-rw-r--r--lisp/textmodes/fill.el4
-rw-r--r--lisp/textmodes/flyspell.el78
-rw-r--r--lisp/textmodes/glyphless-mode.el1
-rw-r--r--lisp/textmodes/html-ts-mode.el144
-rw-r--r--lisp/textmodes/ispell.el23
-rw-r--r--lisp/textmodes/less-css-mode.el2
-rw-r--r--lisp/textmodes/mhtml-mode.el2
-rw-r--r--lisp/textmodes/nroff-mode.el2
-rw-r--r--lisp/textmodes/page-ext.el2
-rw-r--r--lisp/textmodes/page.el10
-rw-r--r--lisp/textmodes/paragraphs.el17
-rw-r--r--lisp/textmodes/picture.el4
-rw-r--r--lisp/textmodes/refill.el6
-rw-r--r--lisp/textmodes/reftex-cite.el4
-rw-r--r--lisp/textmodes/reftex-global.el6
-rw-r--r--lisp/textmodes/reftex-index.el37
-rw-r--r--lisp/textmodes/reftex-ref.el5
-rw-r--r--lisp/textmodes/reftex-sel.el2
-rw-r--r--lisp/textmodes/reftex-toc.el31
-rw-r--r--lisp/textmodes/reftex-vars.el8
-rw-r--r--lisp/textmodes/reftex.el73
-rw-r--r--lisp/textmodes/remember.el9
-rw-r--r--lisp/textmodes/rst.el13
-rw-r--r--lisp/textmodes/sgml-mode.el182
-rw-r--r--lisp/textmodes/table.el6
-rw-r--r--lisp/textmodes/tex-mode.el65
-rw-r--r--lisp/textmodes/text-mode.el36
-rw-r--r--lisp/textmodes/tildify.el2
-rw-r--r--lisp/textmodes/toml-ts-mode.el6
-rw-r--r--lisp/textmodes/two-column.el2
-rw-r--r--lisp/textmodes/underline.el2
-rw-r--r--lisp/textmodes/yaml-ts-mode.el28
-rw-r--r--lisp/thingatpt.el88
-rw-r--r--lisp/time.el11
-rw-r--r--lisp/tool-bar.el292
-rw-r--r--lisp/tooltip.el4
-rw-r--r--lisp/touch-screen.el2043
-rw-r--r--lisp/transient.el1839
-rw-r--r--lisp/treesit.el1294
-rw-r--r--lisp/type-break.el25
-rw-r--r--lisp/uniquify.el77
-rw-r--r--lisp/url/url-cache.el2
-rw-r--r--lisp/url/url-cid.el11
-rw-r--r--lisp/url/url-domsuf.el22
-rw-r--r--lisp/url/url-future.el5
-rw-r--r--lisp/url/url-gw.el74
-rw-r--r--lisp/url/url-http.el6
-rw-r--r--lisp/url/url-irc.el14
-rw-r--r--lisp/url/url-ldap.el10
-rw-r--r--lisp/url/url-mailto.el21
-rw-r--r--lisp/url/url-privacy.el10
-rw-r--r--lisp/url/url-util.el2
-rw-r--r--lisp/url/url-vars.el9
-rw-r--r--lisp/use-package/use-package-bind-key.el1
-rw-r--r--lisp/use-package/use-package-core.el145
-rw-r--r--lisp/use-package/use-package-delight.el1
-rw-r--r--lisp/use-package/use-package-diminish.el1
-rw-r--r--lisp/use-package/use-package-ensure-system-package.el1
-rw-r--r--lisp/use-package/use-package-ensure.el4
-rw-r--r--lisp/use-package/use-package-jump.el1
-rw-r--r--lisp/use-package/use-package-lint.el1
-rw-r--r--lisp/use-package/use-package.el3
-rw-r--r--lisp/userlock.el35
-rw-r--r--lisp/vc/cvs-status.el4
-rw-r--r--lisp/vc/diff-mode.el246
-rw-r--r--lisp/vc/diff.el2
-rw-r--r--lisp/vc/ediff-diff.el2
-rw-r--r--lisp/vc/ediff-util.el89
-rw-r--r--lisp/vc/ediff-wind.el25
-rw-r--r--lisp/vc/emerge.el32
-rw-r--r--lisp/vc/log-edit.el238
-rw-r--r--lisp/vc/log-view.el6
-rw-r--r--lisp/vc/smerge-mode.el10
-rw-r--r--lisp/vc/vc-annotate.el43
-rw-r--r--lisp/vc/vc-cvs.el230
-rw-r--r--lisp/vc/vc-dir.el3
-rw-r--r--lisp/vc/vc-git.el398
-rw-r--r--lisp/vc/vc-hg.el113
-rw-r--r--lisp/vc/vc-hooks.el209
-rw-r--r--lisp/vc/vc-rcs.el7
-rw-r--r--lisp/vc/vc-svn.el4
-rw-r--r--lisp/vc/vc.el240
-rw-r--r--lisp/vcursor.el2
-rw-r--r--lisp/version.el80
-rw-r--r--lisp/visual-wrap.el204
-rw-r--r--lisp/w32-fns.el2
-rw-r--r--lisp/wdired.el29
-rw-r--r--lisp/whitespace.el45
-rw-r--r--lisp/wid-browse.el34
-rw-r--r--lisp/wid-edit.el775
-rw-r--r--lisp/windmove.el14
-rw-r--r--lisp/window.el270
-rw-r--r--lisp/winner.el3
-rw-r--r--lisp/woman.el14
-rw-r--r--lisp/x-dnd.el34
-rw-r--r--lisp/xml.el5
-rw-r--r--lisp/xt-mouse.el31
-rw-r--r--lisp/yank-media.el2
-rw-r--r--m4/00gnulib.m410
-rw-r--r--m4/absolute-header.m44
-rw-r--r--m4/acl.m460
-rw-r--r--m4/alloca.m44
-rw-r--r--m4/assert_h.m424
-rw-r--r--m4/canonicalize.m432
-rw-r--r--m4/clock_time.m441
-rw-r--r--m4/codeset.m424
-rw-r--r--m4/copy-file-range.m459
-rw-r--r--m4/d-type.m43
-rw-r--r--m4/dirent_h.m420
-rw-r--r--m4/dirfd.m426
-rw-r--r--m4/dup2.m47
-rw-r--r--m4/euidaccess.m413
-rw-r--r--m4/extensions.m411
-rw-r--r--m4/extern-inline.m44
-rw-r--r--m4/faccessat.m47
-rw-r--r--m4/fchmodat.m44
-rw-r--r--m4/fdopendir.m414
-rw-r--r--m4/filemode.m43
-rw-r--r--m4/fstatat.m44
-rw-r--r--m4/fsusage.m45
-rw-r--r--m4/futimens.m47
-rw-r--r--m4/getdelim.m4114
-rw-r--r--m4/getgroups.m49
-rw-r--r--m4/getline.m4111
-rw-r--r--m4/getloadavg.m426
-rw-r--r--m4/getopt.m46
-rw-r--r--m4/getrandom.m426
-rw-r--r--m4/gettime.m449
-rw-r--r--m4/gettimeofday.m47
-rw-r--r--m4/gnulib-common.m4710
-rw-r--r--m4/gnulib-comp.m4156
-rw-r--r--m4/group-member.m43
-rw-r--r--m4/include_next.m410
-rw-r--r--m4/inttypes.m46
-rw-r--r--m4/largefile.m4349
-rw-r--r--m4/libgmp.m44
-rw-r--r--m4/limits-h.m423
-rw-r--r--m4/lstat.m49
-rw-r--r--m4/malloc.m411
-rw-r--r--m4/manywarnings.m4119
-rw-r--r--m4/mempcpy.m411
-rw-r--r--m4/memrchr.m44
-rw-r--r--m4/memset_explicit.m424
-rw-r--r--m4/mkostemp.m47
-rw-r--r--m4/mktime.m415
-rw-r--r--m4/musl.m420
-rw-r--r--m4/nanosleep.m433
-rw-r--r--m4/ndk-build.m4651
-rw-r--r--m4/nproc.m46
-rw-r--r--m4/nstrftime.m48
-rw-r--r--m4/open.m44
-rw-r--r--m4/pathmax.m44
-rw-r--r--m4/pipe2.m49
-rw-r--r--m4/printf-posix-rpl.m426
-rw-r--r--m4/pselect.m44
-rw-r--r--m4/pthread_sigmask.m427
-rw-r--r--m4/readlink.m48
-rw-r--r--m4/readlinkat.m47
-rw-r--r--m4/readutmp.m4121
-rw-r--r--m4/realloc.m49
-rw-r--r--m4/regex.m412
-rw-r--r--m4/sig2str.m43
-rw-r--r--m4/ssize_t.m431
-rw-r--r--m4/stat-time.m44
-rw-r--r--m4/stdalign.m4188
-rw-r--r--m4/stddef_h.m426
-rw-r--r--m4/stdint.m415
-rw-r--r--m4/stdio_h.m436
-rw-r--r--m4/stdlib_h.m466
-rw-r--r--m4/stpcpy.m47
-rw-r--r--m4/string_h.m411
-rw-r--r--m4/strnlen.m44
-rw-r--r--m4/strtoimax.m417
-rw-r--r--m4/strtoll.m436
-rw-r--r--m4/symlink.m44
-rw-r--r--m4/time_h.m438
-rw-r--r--m4/time_r.m44
-rw-r--r--m4/timegm.m48
-rw-r--r--m4/timer_time.m415
-rw-r--r--m4/timespec.m43
-rw-r--r--m4/unistd_h.m48
-rw-r--r--m4/utimens.m421
-rw-r--r--m4/utimensat.m410
-rw-r--r--m4/utimes.m412
-rw-r--r--m4/warnings.m496
-rw-r--r--m4/xattr.m453
-rwxr-xr-xmake-dist3
-rw-r--r--msdos/autogen/Makefile.in6
-rw-r--r--msdos/sed1v2.inp25
-rw-r--r--msdos/sed2v2.inp2
-rw-r--r--msdos/sed3v2.inp6
-rw-r--r--msdos/sedleim.inp4
-rw-r--r--msdos/sedlibcf.inp1
-rw-r--r--msdos/sedlibmk.inp22
-rw-r--r--nextstep/Makefile.in12
-rw-r--r--nt/INSTALL.W642
-rw-r--r--nt/README.W322
-rw-r--r--nt/cmdproxy.c8
-rwxr-xr-xnt/ftime-nostartup.bat24
-rw-r--r--nt/ftime.bat24
-rw-r--r--nt/gnulib-cfg.mk24
-rw-r--r--nt/inc/ms-w32.h14
-rw-r--r--nt/mingw-cfg.site5
-rw-r--r--oldXMenu/ChangeLog.14
-rw-r--r--src/.gdbinit4
-rw-r--r--src/.lldbinit3
-rw-r--r--src/ChangeLog.1114
-rw-r--r--src/ChangeLog.122
-rw-r--r--src/ChangeLog.336
-rw-r--r--src/ChangeLog.42
-rw-r--r--src/Makefile.in125
-rw-r--r--src/alloc.c945
-rw-r--r--src/android-asset.h430
-rw-r--r--src/android-emacs.c178
-rw-r--r--src/android.c7711
-rw-r--r--src/android.h350
-rw-r--r--src/androidfns.c3694
-rw-r--r--src/androidfont.c1104
-rw-r--r--src/androidgui.h847
-rw-r--r--src/androidmenu.c861
-rw-r--r--src/androidselect.c1056
-rw-r--r--src/androidterm.c6756
-rw-r--r--src/androidterm.h490
-rw-r--r--src/androidvfs.c7707
-rw-r--r--src/bidi.c15
-rw-r--r--src/bignum.c2
-rw-r--r--src/buffer.c223
-rw-r--r--src/buffer.h22
-rw-r--r--src/bytecode.c174
-rw-r--r--src/callint.c6
-rw-r--r--src/callproc.c142
-rw-r--r--src/casefiddle.c29
-rw-r--r--src/category.c8
-rw-r--r--src/ccl.c49
-rw-r--r--src/ccl.h2
-rw-r--r--src/character.c24
-rw-r--r--src/charset.c35
-rw-r--r--src/charset.h75
-rw-r--r--src/cmds.c2
-rw-r--r--src/coding.c97
-rw-r--r--src/coding.h29
-rw-r--r--src/comp.c122
-rw-r--r--src/composite.c59
-rw-r--r--src/composite.h72
-rw-r--r--src/conf_post.h20
-rw-r--r--src/data.c290
-rw-r--r--src/dired.c76
-rw-r--r--src/dispextern.h138
-rw-r--r--src/dispnew.c130
-rw-r--r--src/disptab.h8
-rw-r--r--src/doc.c169
-rw-r--r--src/doprnt.c4
-rw-r--r--src/dosfns.c5
-rw-r--r--src/editfns.c119
-rw-r--r--src/emacs-module.c188
-rw-r--r--src/emacs-module.h.in15
-rw-r--r--src/emacs.c197
-rw-r--r--src/emacsgtkfixed.h4
-rw-r--r--src/epaths.in22
-rw-r--r--src/eval.c515
-rw-r--r--src/fileio.c820
-rw-r--r--src/filelock.c242
-rw-r--r--src/floatfns.c19
-rw-r--r--src/fns.c1586
-rw-r--r--src/font.c303
-rw-r--r--src/font.h44
-rw-r--r--src/fontset.c70
-rw-r--r--src/frame.c159
-rw-r--r--src/frame.h231
-rw-r--r--src/fringe.c23
-rw-r--r--src/ftfont.c6
-rw-r--r--src/gfilenotify.c8
-rw-r--r--src/gnutls.c191
-rw-r--r--src/gtkutil.c20
-rw-r--r--src/haiku_io.c2
-rw-r--r--src/haiku_select.cc146
-rw-r--r--src/haiku_support.cc100
-rw-r--r--src/haiku_support.h7
-rw-r--r--src/haikufns.c89
-rw-r--r--src/haikufont.c31
-rw-r--r--src/haikuselect.c127
-rw-r--r--src/haikuselect.h25
-rw-r--r--src/haikuterm.c52
-rw-r--r--src/image.c1338
-rw-r--r--src/indent.c12
-rw-r--r--src/inotify.c36
-rw-r--r--src/insdel.c51
-rw-r--r--src/intervals.c2
-rw-r--r--src/intervals.h4
-rw-r--r--src/itree.c10
-rw-r--r--src/itree.h9
-rw-r--r--src/json.c1478
-rw-r--r--src/keyboard.c863
-rw-r--r--src/keyboard.h48
-rw-r--r--src/keymap.c32
-rw-r--r--src/kqueue.c10
-rw-r--r--src/lisp.h994
-rw-r--r--src/lread.c1214
-rw-r--r--src/macfont.h4
-rw-r--r--src/macfont.m105
-rw-r--r--src/macros.c60
-rw-r--r--src/macros.h5
-rw-r--r--src/marker.c44
-rw-r--r--src/menu.c20
-rw-r--r--src/minibuf.c165
-rw-r--r--src/module-env-29.h3
-rw-r--r--src/module-env-30.h3
-rw-r--r--src/msdos.c25
-rw-r--r--src/nsfns.m87
-rw-r--r--src/nsfont.m4
-rw-r--r--src/nsimage.m4
-rw-r--r--src/nsmenu.m4
-rw-r--r--src/nsterm.h20
-rw-r--r--src/nsterm.m156
-rw-r--r--src/pdumper.c447
-rw-r--r--src/pdumper.h2
-rw-r--r--src/pgtkfns.c33
-rw-r--r--src/pgtkterm.c91
-rw-r--r--src/pgtkterm.h4
-rw-r--r--src/print.c422
-rw-r--r--src/process.c129
-rw-r--r--src/profiler.c561
-rw-r--r--src/puresize.h2
-rw-r--r--src/regex-emacs.c1413
-rw-r--r--src/regex-emacs.h7
-rw-r--r--src/scroll.c7
-rw-r--r--src/search.c140
-rw-r--r--src/sfnt.c21539
-rw-r--r--src/sfnt.h2151
-rw-r--r--src/sfntfont-android.c817
-rw-r--r--src/sfntfont.c4229
-rw-r--r--src/sfntfont.h78
-rw-r--r--src/sort.c483
-rw-r--r--src/sound.c2
-rw-r--r--src/sqlite.c17
-rw-r--r--src/syntax.c159
-rw-r--r--src/syntax.h24
-rw-r--r--src/sysdep.c286
-rw-r--r--src/sysstdio.h2
-rw-r--r--src/term.c196
-rw-r--r--src/termcap.c2
-rw-r--r--src/termhooks.h38
-rw-r--r--src/terminal.c4
-rw-r--r--src/textconv.c2374
-rw-r--r--src/textconv.h160
-rw-r--r--src/thread.c39
-rw-r--r--src/thread.h20
-rw-r--r--src/timefns.c30
-rw-r--r--src/tparam.c3
-rw-r--r--src/treesit.c984
-rw-r--r--src/treesit.h15
-rw-r--r--src/verbose.mk.in34
-rw-r--r--src/w16select.c2
-rw-r--r--src/w32.c10
-rw-r--r--src/w32console.c25
-rw-r--r--src/w32fns.c212
-rw-r--r--src/w32font.c8
-rw-r--r--src/w32heap.c4
-rw-r--r--src/w32inevt.c2
-rw-r--r--src/w32notify.c6
-rw-r--r--src/w32proc.c2
-rw-r--r--src/w32term.c12
-rw-r--r--src/w32term.h5
-rw-r--r--src/w32uniscribe.c12
-rw-r--r--src/w32xfns.c28
-rw-r--r--src/window.c170
-rw-r--r--src/window.h62
-rw-r--r--src/xdisp.c1488
-rw-r--r--src/xfaces.c175
-rw-r--r--src/xfns.c521
-rw-r--r--src/xftfont.c6
-rw-r--r--src/xmenu.c17
-rw-r--r--src/xselect.c974
-rw-r--r--src/xsmfns.c2
-rw-r--r--src/xterm.c2160
-rw-r--r--src/xterm.h166
-rw-r--r--src/xwidget.c10
-rw-r--r--test/Makefile.in13
-rw-r--r--test/infra/Dockerfile.emba74
-rw-r--r--test/infra/Makefile.in38
-rw-r--r--test/infra/gitlab-ci.yml61
-rw-r--r--test/infra/test-jobs.yml90
-rw-r--r--test/lisp/abbrev-tests.el4
-rw-r--r--test/lisp/align-resources/align-post.c3
-rw-r--r--test/lisp/align-resources/align-post.java9
-rw-r--r--test/lisp/align-resources/align-pre.c3
-rw-r--r--test/lisp/align-resources/align-pre.java9
-rw-r--r--test/lisp/align-resources/align-regexp.erts13
-rw-r--r--test/lisp/align-resources/c-mode.erts23
-rw-r--r--test/lisp/align-resources/conf-toml-mode.erts45
-rw-r--r--test/lisp/align-resources/css-mode.erts23
-rw-r--r--test/lisp/align-resources/java-mode.erts23
-rw-r--r--test/lisp/align-resources/latex-mode.erts29
-rw-r--r--test/lisp/align-resources/lua-ts-mode.erts67
-rw-r--r--test/lisp/align-resources/python-mode.erts29
-rw-r--r--test/lisp/align-tests.el60
-rw-r--r--test/lisp/arc-mode-tests.el79
-rw-r--r--test/lisp/auth-source-tests.el184
-rw-r--r--test/lisp/autorevert-tests.el2
-rw-r--r--test/lisp/calc/calc-tests.el67
-rw-r--r--test/lisp/calculator-tests.el6
-rw-r--r--test/lisp/calendar/icalendar-tests.el2
-rw-r--r--test/lisp/calendar/lunar-tests.el6
-rw-r--r--test/lisp/calendar/todo-mode-tests.el65
-rw-r--r--test/lisp/cedet/semantic/bovine/gcc-tests.el109
-rw-r--r--test/lisp/completion-preview-tests.el199
-rw-r--r--test/lisp/cus-edit-tests.el42
-rw-r--r--test/lisp/dired-aux-tests.el11
-rw-r--r--test/lisp/dired-tests.el12
-rw-r--r--test/lisp/dnd-tests.el160
-rw-r--r--test/lisp/dom-tests.el10
-rw-r--r--test/lisp/elide-head-tests.el106
-rw-r--r--test/lisp/emacs-lisp/backtrace-tests.el6
-rw-r--r--test/lisp/emacs-lisp/benchmark-tests.el4
-rw-r--r--test/lisp/emacs-lisp/byte-run-tests.el32
-rw-r--r--test/lisp/emacs-lisp/bytecomp-resources/no-byte-compile.el2
-rw-r--r--test/lisp/emacs-lisp/bytecomp-resources/warn-make-process-missing-keyword-arg.el3
-rw-r--r--test/lisp/emacs-lisp/bytecomp-resources/warn-make-process-missing-keyword-value.el3
-rw-r--r--test/lisp/emacs-lisp/bytecomp-resources/warn-make-process-repeated-keyword-arg.el3
-rw-r--r--test/lisp/emacs-lisp/bytecomp-resources/warn-make-process-unknown-keyword-arg.el4
-rw-r--r--test/lisp/emacs-lisp/bytecomp-resources/warn-wide-docstring-defun.el3
-rw-r--r--test/lisp/emacs-lisp/bytecomp-tests.el594
-rw-r--r--test/lisp/emacs-lisp/cconv-tests.el25
-rw-r--r--test/lisp/emacs-lisp/checkdoc-tests.el9
-rw-r--r--test/lisp/emacs-lisp/cl-generic-tests.el13
-rw-r--r--test/lisp/emacs-lisp/cl-lib-tests.el41
-rw-r--r--test/lisp/emacs-lisp/cl-macs-tests.el43
-rw-r--r--test/lisp/emacs-lisp/cl-print-tests.el25
-rw-r--r--test/lisp/emacs-lisp/comp-cstr-tests.el400
-rw-r--r--test/lisp/emacs-lisp/edebug-tests.el23
-rw-r--r--test/lisp/emacs-lisp/eieio-tests/eieio-test-methodinvoke.el2
-rw-r--r--test/lisp/emacs-lisp/eieio-tests/eieio-test-persist.el10
-rw-r--r--test/lisp/emacs-lisp/eieio-tests/eieio-tests.el49
-rw-r--r--test/lisp/emacs-lisp/ert-font-lock-resources/broken.js3
-rw-r--r--test/lisp/emacs-lisp/ert-font-lock-resources/correct.js3
-rw-r--r--test/lisp/emacs-lisp/ert-font-lock-resources/no-asserts.js2
-rw-r--r--test/lisp/emacs-lisp/ert-font-lock-tests.el567
-rw-r--r--test/lisp/emacs-lisp/ert-tests.el83
-rw-r--r--test/lisp/emacs-lisp/find-func-tests.el2
-rw-r--r--test/lisp/emacs-lisp/hierarchy-tests.el5
-rw-r--r--test/lisp/emacs-lisp/lisp-mnt-tests.el20
-rw-r--r--test/lisp/emacs-lisp/lisp-mode-tests.el23
-rw-r--r--test/lisp/emacs-lisp/macroexp-resources/vk.el2
-rw-r--r--test/lisp/emacs-lisp/macroexp-tests.el16
-rw-r--r--test/lisp/emacs-lisp/map-tests.el59
-rw-r--r--test/lisp/emacs-lisp/multisession-tests.el2
-rw-r--r--test/lisp/emacs-lisp/nadvice-tests.el72
-rw-r--r--test/lisp/emacs-lisp/package-tests.el27
-rw-r--r--test/lisp/emacs-lisp/pcase-tests.el14
-rw-r--r--test/lisp/emacs-lisp/pp-tests.el53
-rw-r--r--test/lisp/emacs-lisp/rx-tests.el114
-rw-r--r--test/lisp/emacs-lisp/shortdoc-tests.el43
-rw-r--r--test/lisp/emacs-lisp/subr-x-tests.el17
-rw-r--r--test/lisp/emacs-lisp/tabulated-list-tests.el41
-rw-r--r--test/lisp/epg-tests.el11
-rw-r--r--test/lisp/erc/erc-button-tests.el307
-rw-r--r--test/lisp/erc/erc-dcc-tests.el92
-rw-r--r--test/lisp/erc/erc-fill-tests.el453
-rw-r--r--test/lisp/erc/erc-goodies-tests.el612
-rw-r--r--test/lisp/erc/erc-networks-tests.el120
-rw-r--r--test/lisp/erc/erc-nicks-tests.el571
-rw-r--r--test/lisp/erc/erc-scenarios-auth-source.el2
-rw-r--r--test/lisp/erc/erc-scenarios-base-association.el2
-rw-r--r--test/lisp/erc/erc-scenarios-base-attach.el191
-rw-r--r--test/lisp/erc/erc-scenarios-base-auto-recon.el141
-rw-r--r--test/lisp/erc/erc-scenarios-base-buffer-display.el249
-rw-r--r--test/lisp/erc/erc-scenarios-base-chan-modes.el142
-rw-r--r--test/lisp/erc/erc-scenarios-base-local-module-modes.el211
-rw-r--r--test/lisp/erc/erc-scenarios-base-local-modules.el99
-rw-r--r--test/lisp/erc/erc-scenarios-base-misc-regressions.el4
-rw-r--r--test/lisp/erc/erc-scenarios-base-reconnect.el91
-rw-r--r--test/lisp/erc/erc-scenarios-base-renick.el16
-rw-r--r--test/lisp/erc/erc-scenarios-base-reuse-buffers.el2
-rw-r--r--test/lisp/erc/erc-scenarios-base-send-message.el126
-rw-r--r--test/lisp/erc/erc-scenarios-base-split-line.el202
-rw-r--r--test/lisp/erc/erc-scenarios-base-statusmsg.el103
-rw-r--r--test/lisp/erc/erc-scenarios-base-upstream-recon-znc.el46
-rw-r--r--test/lisp/erc/erc-scenarios-display-message.el63
-rw-r--r--test/lisp/erc/erc-scenarios-internal.el35
-rw-r--r--test/lisp/erc/erc-scenarios-join-display-context.el66
-rw-r--r--test/lisp/erc/erc-scenarios-keep-place-indicator.el141
-rw-r--r--test/lisp/erc/erc-scenarios-log.el264
-rw-r--r--test/lisp/erc/erc-scenarios-match.el555
-rw-r--r--test/lisp/erc/erc-scenarios-misc-commands.el216
-rw-r--r--test/lisp/erc/erc-scenarios-misc.el38
-rw-r--r--test/lisp/erc/erc-scenarios-prompt-format.el117
-rw-r--r--test/lisp/erc/erc-scenarios-sasl.el99
-rw-r--r--test/lisp/erc/erc-scenarios-scrolltobottom-relaxed.el140
-rw-r--r--test/lisp/erc/erc-scenarios-scrolltobottom.el68
-rw-r--r--test/lisp/erc/erc-scenarios-services-misc.el105
-rw-r--r--test/lisp/erc/erc-scenarios-stamp.el181
-rw-r--r--test/lisp/erc/erc-scenarios-status-sidebar.el174
-rw-r--r--test/lisp/erc/erc-services-tests.el225
-rw-r--r--test/lisp/erc/erc-stamp-tests.el352
-rw-r--r--test/lisp/erc/erc-tests.el2945
-rw-r--r--test/lisp/erc/erc-track-tests.el166
-rw-r--r--test/lisp/erc/resources/base/assoc/bouncer-history/barnet.eld4
-rw-r--r--test/lisp/erc/resources/base/assoc/bouncer-history/foonet.eld5
-rw-r--r--test/lisp/erc/resources/base/assoc/bumped/again.eld10
-rw-r--r--test/lisp/erc/resources/base/assoc/bumped/foisted.eld10
-rw-r--r--test/lisp/erc/resources/base/assoc/bumped/refoisted.eld8
-rw-r--r--test/lisp/erc/resources/base/assoc/multi-net/barnet.eld12
-rw-r--r--test/lisp/erc/resources/base/assoc/multi-net/foonet.eld12
-rw-r--r--test/lisp/erc/resources/base/assoc/reconplay/foonet.eld2
-rw-r--r--test/lisp/erc/resources/base/channel-buffer-revival/reattach.eld56
-rw-r--r--test/lisp/erc/resources/base/display-message/multibuf.eld45
-rw-r--r--test/lisp/erc/resources/base/display-message/statusmsg.eld47
-rw-r--r--test/lisp/erc/resources/base/flood/ascii.eld49
-rw-r--r--test/lisp/erc/resources/base/flood/koi8-r.eld47
-rw-r--r--test/lisp/erc/resources/base/flood/soju.eld2
-rw-r--r--test/lisp/erc/resources/base/flood/utf-8.eld54
-rw-r--r--test/lisp/erc/resources/base/gapless-connect/foonet.eld8
-rw-r--r--test/lisp/erc/resources/base/local-modules/first.eld6
-rw-r--r--test/lisp/erc/resources/base/local-modules/second.eld2
-rw-r--r--test/lisp/erc/resources/base/local-modules/third.eld2
-rw-r--r--test/lisp/erc/resources/base/modes/chan-changed.eld55
-rw-r--r--test/lisp/erc/resources/base/modes/speaker-status.eld69
-rw-r--r--test/lisp/erc/resources/base/netid/bouncer/barnet-drop.eld4
-rw-r--r--test/lisp/erc/resources/base/netid/bouncer/barnet.eld14
-rw-r--r--test/lisp/erc/resources/base/netid/bouncer/foonet-drop.eld6
-rw-r--r--test/lisp/erc/resources/base/netid/bouncer/foonet.eld14
-rw-r--r--test/lisp/erc/resources/base/reconnect/aborted-dupe.eld2
-rw-r--r--test/lisp/erc/resources/base/reconnect/aborted.eld2
-rw-r--r--test/lisp/erc/resources/base/reconnect/just-eof.eld3
-rw-r--r--test/lisp/erc/resources/base/reconnect/just-ping.eld4
-rw-r--r--test/lisp/erc/resources/base/reconnect/options-again.eld4
-rw-r--r--test/lisp/erc/resources/base/reconnect/options.eld10
-rw-r--r--test/lisp/erc/resources/base/reconnect/ping-pong.eld6
-rw-r--r--test/lisp/erc/resources/base/reconnect/unexpected-disconnect.eld24
-rw-r--r--test/lisp/erc/resources/base/renick/queries/bouncer-barnet.eld14
-rw-r--r--test/lisp/erc/resources/base/renick/queries/bouncer-foonet.eld12
-rw-r--r--test/lisp/erc/resources/base/renick/queries/solo.eld2
-rw-r--r--test/lisp/erc/resources/base/renick/self/qual-chester.eld2
-rw-r--r--test/lisp/erc/resources/base/renick/self/qual-tester.eld2
-rw-r--r--test/lisp/erc/resources/base/reuse-buffers/channel/barnet.eld2
-rw-r--r--test/lisp/erc/resources/base/reuse-buffers/channel/foonet.eld2
-rw-r--r--test/lisp/erc/resources/base/reuse-buffers/server/barnet.eld6
-rw-r--r--test/lisp/erc/resources/base/reuse-buffers/server/foonet.eld6
-rw-r--r--test/lisp/erc/resources/base/send-message/noncommands.eld52
-rw-r--r--test/lisp/erc/resources/base/upstream-reconnect/znc-severed.eld87
-rw-r--r--test/lisp/erc/resources/commands/amsg-barnet.eld54
-rw-r--r--test/lisp/erc/resources/commands/amsg-foonet.eld56
-rw-r--r--test/lisp/erc/resources/commands/motd.eld48
-rw-r--r--test/lisp/erc/resources/commands/squery.eld31
-rw-r--r--test/lisp/erc/resources/commands/vhost.eld40
-rw-r--r--test/lisp/erc/resources/dcc/chat/accept.eld2
-rw-r--r--test/lisp/erc/resources/erc-d/erc-d-t.el8
-rw-r--r--test/lisp/erc/resources/erc-d/erc-d-tests.el2
-rw-r--r--test/lisp/erc/resources/erc-d/erc-d-u.el1
-rw-r--r--test/lisp/erc/resources/erc-d/erc-d.el53
-rw-r--r--test/lisp/erc/resources/erc-d/resources/basic.eld5
-rw-r--r--test/lisp/erc/resources/erc-d/resources/dynamic-barnet.eld6
-rw-r--r--test/lisp/erc/resources/erc-d/resources/dynamic-foonet.eld6
-rw-r--r--test/lisp/erc/resources/erc-d/resources/dynamic.eld5
-rw-r--r--test/lisp/erc/resources/erc-d/resources/eof.eld5
-rw-r--r--test/lisp/erc/resources/erc-d/resources/fuzzy.eld4
-rw-r--r--test/lisp/erc/resources/erc-d/resources/incremental.eld5
-rw-r--r--test/lisp/erc/resources/erc-d/resources/linger.eld9
-rw-r--r--test/lisp/erc/resources/erc-d/resources/no-block.eld7
-rw-r--r--test/lisp/erc/resources/erc-d/resources/no-match.eld5
-rw-r--r--test/lisp/erc/resources/erc-d/resources/unexpected.eld5
-rw-r--r--test/lisp/erc/resources/erc-scenarios-common.el290
-rw-r--r--test/lisp/erc/resources/erc-tests-common.el301
-rw-r--r--test/lisp/erc/resources/fill/snapshots/merge-01-start.eld1
-rw-r--r--test/lisp/erc/resources/fill/snapshots/merge-02-right.eld1
-rw-r--r--test/lisp/erc/resources/fill/snapshots/merge-wrap-01.eld1
-rw-r--r--test/lisp/erc/resources/fill/snapshots/merge-wrap-indicator-post-01.eld1
-rw-r--r--test/lisp/erc/resources/fill/snapshots/merge-wrap-indicator-pre-01.eld1
-rw-r--r--test/lisp/erc/resources/fill/snapshots/monospace-01-start.eld1
-rw-r--r--test/lisp/erc/resources/fill/snapshots/monospace-02-right.eld1
-rw-r--r--test/lisp/erc/resources/fill/snapshots/monospace-03-left.eld1
-rw-r--r--test/lisp/erc/resources/fill/snapshots/monospace-04-reset.eld1
-rw-r--r--test/lisp/erc/resources/fill/snapshots/spacing-01-mono.eld1
-rw-r--r--test/lisp/erc/resources/fill/snapshots/stamps-left-01.eld1
-rw-r--r--test/lisp/erc/resources/join/buffer-display/mode-context.eld38
-rw-r--r--test/lisp/erc/resources/join/legacy/foonet.eld2
-rw-r--r--test/lisp/erc/resources/join/network-id/barnet.eld2
-rw-r--r--test/lisp/erc/resources/join/network-id/foonet-again.eld2
-rw-r--r--test/lisp/erc/resources/join/network-id/foonet.eld4
-rw-r--r--test/lisp/erc/resources/keep-place/follow.eld78
-rw-r--r--test/lisp/erc/resources/match/fools/fill-wrap.eld41
-rw-r--r--test/lisp/erc/resources/sasl/plain-failed.eld10
-rw-r--r--test/lisp/erc/resources/sasl/plain-overlong-aligned.eld39
-rw-r--r--test/lisp/erc/resources/sasl/plain-overlong-split.eld39
-rw-r--r--test/lisp/erc/resources/sasl/scram-sha-1.eld2
-rw-r--r--test/lisp/erc/resources/sasl/scram-sha-256.eld2
-rw-r--r--test/lisp/erc/resources/scrolltobottom/help.eld46
-rw-r--r--test/lisp/erc/resources/services/auth-source/libera.eld10
-rw-r--r--test/lisp/erc/resources/services/regain/reconnect-retry-again.eld56
-rw-r--r--test/lisp/erc/resources/services/regain/reconnect-retry.eld53
-rw-r--r--test/lisp/erc/resources/services/regain/taken-ghost.eld42
-rw-r--r--test/lisp/erc/resources/services/regain/taken-regain.eld42
-rw-r--r--test/lisp/eshell/em-alias-tests.el9
-rw-r--r--test/lisp/eshell/em-basic-tests.el34
-rw-r--r--test/lisp/eshell/em-cmpl-tests.el380
-rw-r--r--test/lisp/eshell/em-dirs-tests.el45
-rw-r--r--test/lisp/eshell/em-extpipe-tests.el33
-rw-r--r--test/lisp/eshell/em-glob-tests.el94
-rw-r--r--test/lisp/eshell/em-hist-tests.el134
-rw-r--r--test/lisp/eshell/em-prompt-tests.el192
-rw-r--r--test/lisp/eshell/em-script-tests.el45
-rw-r--r--test/lisp/eshell/em-tramp-tests.el181
-rw-r--r--test/lisp/eshell/em-unix-tests.el68
-rw-r--r--test/lisp/eshell/esh-arg-tests.el105
-rw-r--r--test/lisp/eshell/esh-cmd-tests.el222
-rw-r--r--test/lisp/eshell/esh-ext-tests.el32
-rw-r--r--test/lisp/eshell/esh-io-tests.el106
-rw-r--r--test/lisp/eshell/esh-opt-tests.el24
-rw-r--r--test/lisp/eshell/esh-proc-tests.el111
-rw-r--r--test/lisp/eshell/esh-util-tests.el106
-rw-r--r--test/lisp/eshell/esh-var-tests.el386
-rw-r--r--test/lisp/eshell/eshell-tests-helpers.el66
-rw-r--r--test/lisp/eshell/eshell-tests-unload.el99
-rw-r--r--test/lisp/eshell/eshell-tests.el219
-rw-r--r--test/lisp/filenotify-tests.el139
-rw-r--r--test/lisp/files-tests.el234
-rw-r--r--test/lisp/files-x-tests.el119
-rw-r--r--test/lisp/find-cmd-tests.el2
-rw-r--r--test/lisp/gnus/mml-sec-tests.el51
-rw-r--r--test/lisp/help-fns-tests.el37
-rw-r--r--test/lisp/help-tests.el12
-rw-r--r--test/lisp/hl-line-tests.el8
-rw-r--r--test/lisp/ibuffer-tests.el2
-rw-r--r--test/lisp/image-tests.el144
-rw-r--r--test/lisp/image/image-dired-util-tests.el17
-rw-r--r--test/lisp/info-tests.el10
-rw-r--r--test/lisp/international/mule-tests.el4
-rw-r--r--test/lisp/international/ucs-normalize-tests.el4
-rw-r--r--test/lisp/isearch-tests.el151
-rw-r--r--test/lisp/jsonrpc-tests.el11
-rw-r--r--test/lisp/ls-lisp-tests.el7
-rw-r--r--test/lisp/man-tests.el18
-rwxr-xr-xtest/lisp/mh-e/test-all-mh-variants.sh4
-rw-r--r--test/lisp/minibuffer-tests.el180
-rw-r--r--test/lisp/misc-tests.el96
-rw-r--r--test/lisp/net/eww-tests.el247
-rw-r--r--test/lisp/net/mailcap-tests.el24
-rw-r--r--test/lisp/net/network-stream-tests.el20
-rw-r--r--test/lisp/net/shr-resources/blockquote.html2
-rw-r--r--test/lisp/net/shr-resources/blockquote.txt3
-rw-r--r--test/lisp/net/shr-tests.el72
-rw-r--r--test/lisp/net/socks-tests.el84
-rw-r--r--test/lisp/net/tramp-archive-tests.el68
-rw-r--r--test/lisp/net/tramp-tests.el1044
-rw-r--r--test/lisp/net/webjump-tests.el2
-rw-r--r--test/lisp/obarray-tests.el31
-rw-r--r--test/lisp/proced-tests.el136
-rw-r--r--test/lisp/progmodes/bug-reference-tests.el15
-rw-r--r--test/lisp/progmodes/c-ts-mode-resources/indent.erts2
-rw-r--r--test/lisp/progmodes/compile-tests.el57
-rw-r--r--test/lisp/progmodes/cperl-mode-resources/cperl-bug-11733.pl50
-rw-r--r--test/lisp/progmodes/cperl-mode-resources/cperl-bug-35925.pl36
-rw-r--r--test/lisp/progmodes/cperl-mode-resources/cperl-bug-64190.pl24
-rw-r--r--test/lisp/progmodes/cperl-mode-resources/cperl-bug-64364.pl55
-rw-r--r--test/lisp/progmodes/cperl-mode-resources/cperl-bug-65834.pl5
-rw-r--r--test/lisp/progmodes/cperl-mode-resources/cperl-bug-66145.pl62
-rw-r--r--test/lisp/progmodes/cperl-mode-resources/cperl-bug-66161.pl13
-rw-r--r--test/lisp/progmodes/cperl-mode-resources/cperl-indents.erts55
-rw-r--r--test/lisp/progmodes/cperl-mode-resources/grammar.pl25
-rw-r--r--test/lisp/progmodes/cperl-mode-resources/perl-class.pl19
-rw-r--r--test/lisp/progmodes/cperl-mode-resources/proto-and-attrs.pl26
-rw-r--r--test/lisp/progmodes/cperl-mode-resources/sub-names.pl25
-rw-r--r--test/lisp/progmodes/cperl-mode-tests.el321
-rw-r--r--test/lisp/progmodes/eglot-tests.el373
-rw-r--r--test/lisp/progmodes/elisp-mode-tests.el13
-rw-r--r--test/lisp/progmodes/elixir-ts-mode-resources/indent.erts390
-rw-r--r--test/lisp/progmodes/elixir-ts-mode-tests.el31
-rw-r--r--test/lisp/progmodes/flymake-tests.el3
-rw-r--r--test/lisp/progmodes/grep-tests.el14
-rw-r--r--test/lisp/progmodes/heex-ts-mode-resources/indent.erts47
-rw-r--r--test/lisp/progmodes/heex-ts-mode-tests.el31
-rw-r--r--test/lisp/progmodes/java-ts-mode-tests.el2
-rw-r--r--test/lisp/progmodes/lua-ts-mode-resources/font-lock.lua339
-rw-r--r--test/lisp/progmodes/lua-ts-mode-resources/indent.erts785
-rw-r--r--test/lisp/progmodes/lua-ts-mode-resources/movement.erts603
-rw-r--r--test/lisp/progmodes/lua-ts-mode-tests.el42
-rw-r--r--test/lisp/progmodes/perl-mode-tests.el17
-rw-r--r--test/lisp/progmodes/project-tests.el1
-rw-r--r--test/lisp/progmodes/python-tests.el469
-rw-r--r--test/lisp/progmodes/ruby-mode-resources/ruby.rb6
-rw-r--r--test/lisp/progmodes/ruby-mode-tests.el2
-rw-r--r--test/lisp/progmodes/sh-script-resources/sh-indents.erts7
-rw-r--r--test/lisp/progmodes/sh-script-tests.el29
-rw-r--r--test/lisp/progmodes/which-func-tests.el58
-rw-r--r--test/lisp/server-tests.el12
-rw-r--r--test/lisp/ses-tests.el24
-rw-r--r--test/lisp/shadowfile-tests.el20
-rw-r--r--test/lisp/shell-tests.el31
-rw-r--r--test/lisp/simple-tests.el12
-rw-r--r--test/lisp/subr-tests.el182
-rw-r--r--test/lisp/term-tests.el20
-rw-r--r--test/lisp/textmodes/conf-mode-tests.el26
-rw-r--r--test/lisp/textmodes/fill-tests.el2
-rw-r--r--test/lisp/textmodes/page-tests.el6
-rw-r--r--test/lisp/textmodes/reftex-tests.el3
-rw-r--r--test/lisp/textmodes/tildify-tests.el2
-rw-r--r--test/lisp/thingatpt-tests.el42
-rw-r--r--test/lisp/thread-tests.el2
-rw-r--r--test/lisp/time-stamp-tests.el32
-rw-r--r--test/lisp/uniquify-tests.el150
-rw-r--r--test/lisp/url/url-domsuf-tests.el4
-rw-r--r--test/lisp/url/url-expand-tests.el1
-rw-r--r--test/lisp/url/url-future-tests.el2
-rw-r--r--test/lisp/url/url-parse-tests.el1
-rw-r--r--test/lisp/use-package/use-package-tests.el65
-rw-r--r--test/lisp/vc/log-edit-tests.el210
-rw-r--r--test/lisp/vc/vc-cvs-tests.el107
-rw-r--r--test/lisp/vc/vc-git-tests.el64
-rw-r--r--test/lisp/vc/vc-hg-tests.el4
-rw-r--r--test/lisp/vc/vc-tests.el4
-rw-r--r--test/lisp/whitespace-tests.el18
-rw-r--r--test/lisp/wid-edit-tests.el42
-rw-r--r--test/manual/BidiCharacterTest.txt6
-rw-r--r--test/manual/image-tests.el14
-rwxr-xr-xtest/manual/indent/shell.sh8
-rw-r--r--test/manual/noverlay/itree-tests.c182
-rw-r--r--test/manual/scroll-tests.el10
-rw-r--r--test/misc/test-custom-libs.el2
-rw-r--r--test/src/casefiddle-tests.el12
-rw-r--r--test/src/comp-resources/comp-test-funcs-dyn2.el31
-rw-r--r--test/src/comp-resources/comp-test-funcs.el48
-rw-r--r--test/src/comp-tests.el117
-rw-r--r--test/src/data-tests.el103
-rw-r--r--test/src/emacs-module-resources/mod-test.c4
-rw-r--r--test/src/emacs-module-tests.el17
-rw-r--r--test/src/eval-tests.el116
-rw-r--r--test/src/fileio-tests.el5
-rw-r--r--test/src/filelock-tests.el26
-rw-r--r--test/src/fns-tests.el334
-rw-r--r--test/src/image-tests.el6
-rw-r--r--test/src/keyboard-tests.el5
-rw-r--r--test/src/keymap-tests.el17
-rw-r--r--test/src/lread-tests.el35
-rw-r--r--test/src/minibuf-tests.el14
-rw-r--r--test/src/print-tests.el7
-rw-r--r--test/src/process-tests.el8
-rw-r--r--test/src/regex-emacs-tests.el124
-rw-r--r--test/src/regex-resources/PTESTS1
-rw-r--r--test/src/search-tests.el38
-rw-r--r--test/src/syntax-tests.el3
-rw-r--r--test/src/treesit-tests.el150
-rw-r--r--test/src/undo-tests.el72
-rw-r--r--test/src/xdisp-tests.el2
1934 files changed, 250581 insertions, 66106 deletions
diff --git a/.clang-format b/.clang-format
index 5c987536b0c..7929a7435f2 100644
--- a/.clang-format
+++ b/.clang-format
@@ -1,4 +1,3 @@
-Language: Cpp
BasedOnStyle: GNU
AlignEscapedNewlinesLeft: true
AlignOperands: Align
@@ -35,6 +34,10 @@ PenaltyBreakBeforeFirstCallParameter: 2000
SpaceAfterCStyleCast: true
SpaceBeforeParens: Always
UseTab: Always
+---
+Language: Cpp
+---
+Language: ObjC
# Local Variables:
# mode: yaml
diff --git a/.clangd b/.clangd
new file mode 100644
index 00000000000..469d33dfd03
--- /dev/null
+++ b/.clangd
@@ -0,0 +1,5 @@
+---
+If:
+ PathMatch: "src/*.c"
+CompileFlags:
+ Add: [-Wno-unused-macros, -include=config.h]
diff --git a/.dir-locals.el b/.dir-locals.el
index 0bcded4b5d1..b34949ae961 100644
--- a/.dir-locals.el
+++ b/.dir-locals.el
@@ -3,30 +3,40 @@
((nil . ((tab-width . 8)
(sentence-end-double-space . t)
- (fill-column . 70)
- (emacs-lisp-docstring-fill-column . 65)
+ (fill-column . 72)
+ (emacs-lisp-docstring-fill-column . 72)
(vc-git-annotate-switches . "-w")
(bug-reference-url-format . "https://debbugs.gnu.org/%s")
(diff-add-log-use-relative-names . t)
+ (etags-regen-regexp-alist
+ .
+ ((("c" "objc") .
+ ("/[ \t]*DEFVAR_[A-Z_ \t(]+\"\\([^\"]+\\)\"/\\1/"
+ "/[ \t]*DEFVAR_[A-Z_ \t(]+\"[^\"]+\",[ \t]\\([A-Za-z0-9_]+\\)/\\1/"))))
+ (etags-regen-ignores . ("test/manual/etags/"))
(vc-prepare-patches-separately . nil)))
(c-mode . ((c-file-style . "GNU")
(c-noise-macro-names . ("INLINE" "NO_INLINE" "ATTRIBUTE_NO_SANITIZE_UNDEFINED"
"UNINIT" "CALLBACK" "ALIGN_STACK" "ATTRIBUTE_MALLOC"
- "ATTRIBUTE_DEALLOC_FREE"))
+ "ATTRIBUTE_DEALLOC_FREE" "ANDROID_EXPORT" "TEST_STATIC"))
(electric-quote-comment . nil)
(electric-quote-string . nil)
(indent-tabs-mode . t)
(mode . bug-reference-prog)))
+ (java-mode . ((c-file-style . "GNU")
+ (electric-quote-comment . nil)
+ (electric-quote-string . nil)
+ (indent-tabs-mode . t)
+ (mode . bug-reference-prog)))
(objc-mode . ((c-file-style . "GNU")
(electric-quote-comment . nil)
(electric-quote-string . nil)
(mode . bug-reference-prog)))
- (c-ts-mode . ((c-ts-mode-indent-style . gnu)
- (indent-tabs-mode . t)
- (mode . bug-reference-prog)))
+ (c-ts-mode . ((c-ts-mode-indent-style . gnu))) ;Inherits `c-mode' settings.
(log-edit-mode . ((log-edit-font-lock-gnu-style . t)
(log-edit-setup-add-author . t)
- (vc-git-log-edit-summary-target-len . 50)))
+ (vc-git-log-edit-summary-target-len . 50)
+ (fill-column . 64)))
(change-log-mode . ((add-log-time-zone-rule . t)
(fill-column . 74)
(mode . bug-reference)))
diff --git a/.gitattributes b/.gitattributes
index f3175a5cce1..38cc45f3ee3 100644
--- a/.gitattributes
+++ b/.gitattributes
@@ -17,13 +17,11 @@
# You should have received a copy of the GNU General Public License
# along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>.
-# A few files use CRLF endings, even on non-Microsoft platforms.
+# A few UTF-8-compatible text files use CRLF endings,
+# even on non-Microsoft platforms.
# Do not warn about trailing whitespace with these files.
*.bat whitespace=cr-at-eol
admin/charsets/mapfiles/PTCP154 whitespace=cr-at-eol
-leim/MISC-DIC/cangjie-table.b5 whitespace=cr-at-eol
-leim/MISC-DIC/cangjie-table.cns whitespace=cr-at-eol
-leim/MISC-DIC/pinyin.map whitespace=cr-at-eol
test/manual/etags/c-src/dostorture.c whitespace=cr-at-eol
test/manual/etags/cp-src/c.C whitespace=cr-at-eol
test/manual/etags/html-src/algrthms.html whitespace=cr-at-eol
@@ -31,19 +29,41 @@ test/manual/etags/html-src/algrthms.html whitespace=cr-at-eol
# The todo-mode file format includes trailing whitespace.
*.tod[aorty] -whitespace=blank-at-eol
+# The following text files use encodings incompatible with UTF-8.
+# They should not be treated as text when diffing, as that could
+# cause the output to mix encodings.
+*.tit -diff
+admin/charsets/mapfiles/cns2ucsdkw.txt -diff
+leim/MISC-DIC/CTLau* -diff
+leim/MISC-DIC/cangjie-table.* -diff
+leim/MISC-DIC/pinyin.map -diff
+leim/MISC-DIC/ziranma.cin -diff
+leim/SKK-DIC/SKK-JISYO.L -diff
+src/msdos.c -diff
+test/lisp/gnus/mm-decode-resources/win1252-multipart.bin -diff
+
# Some files should not be treated as text when diffing or merging.
+*.bmp binary
*.cur binary
+*.gif binary
*.gpg binary
*.gz binary
*.icns binary
*.ico binary
+*.jpg binary
+*.kbx binary
+*.key binary
*.pbm binary
*.pdf binary
*.pif binary
*.png binary
*.sig binary
*.tiff binary
+*.webp binary
+*.zip binary
etc/e/eterm-color binary
+etc/e/eterm-direct binary
+java/emacs.keystore binary
# Git's builtin diff hunk header styles.
*.ad[abs] diff=ada
@@ -96,3 +116,7 @@ build-aux/msys-to-w32 diff=shell
build-aux/update-subdirs diff=shell
lib-src/rcs2log diff=shell
/make-dist diff=shell
+
+# This file contains in-line diffs, which can include trailing
+# whitespace.
+java/INSTALL -whitespace
diff --git a/.gitignore b/.gitignore
index 46fa860c291..29c571a3dcb 100644
--- a/.gitignore
+++ b/.gitignore
@@ -52,6 +52,23 @@ src/config.h
src/epaths.h
src/emacs-module.h
+# Built by recursive call to `configure'.
+*.android
+!INSTALL.android
+!verbose.mk.android
+
+# Built by `javac'.
+java/install_temp/*
+java/*.apk*
+java/*.dex
+java/org/gnu/emacs/*.class
+
+# Built by `aapt'.
+java/org/gnu/emacs/R.java
+
+# Built by `config.status'.
+java/AndroidManifest.xml
+
# C-level sources built by 'make'.
lib/alloca.h
lib/assert.h
@@ -70,8 +87,10 @@ lib/limits.h
lib/malloc/*.gl.h
lib/signal.h
lib/std*.h
+lib/math.h
!lib/std*.in.h
!lib/stdio-impl.h
+!lib/_Noreturn.h
lib/string.h
lib/sys/
lib/time.h
@@ -81,6 +100,19 @@ src/globals.h
src/lisp.mk
src/verbose.mk
+# Stuff built during cross compilation
+cross/lib/*
+cross/src/*
+cross/lib-src/*
+cross/sys/*
+cross/config.status
+cross/*.bak
+cross/etc/DOC
+
+cross/ndk-build/Makefile
+cross/ndk-build/ndk-build.mk
+cross/ndk-build/*.o
+
# Lisp-level sources built by 'make'.
*cus-load.el
*loaddefs.el
@@ -187,6 +219,7 @@ ID
# Executables.
*.exe
a.out
+lib-src/asset-directory-tool
lib-src/be-resources
lib-src/blessmail
lib-src/ctags
@@ -209,6 +242,7 @@ nextstep/GNUstep/Emacs.base/Resources/Info-gnustep.plist
src/bootstrap-emacs
src/emacs
src/emacs-[0-9]*
+src/sfnt
src/Emacs
src/temacs
src/dmpstruct.h
@@ -339,3 +373,21 @@ lib-src/seccomp-filter-exec.pfc
# GDB history
.gdb_history
_gdb_history
+
+# Files ignored in exec/.
+exec/aclocal.m4
+exec/config.guess
+exec/config.sub
+exec/config.status
+exec/install-sh
+exec/loader
+exec/test
+exec/exec1
+exec/deps/*
+exec/aclocal.m4
+exec/autom4te.cache
+exec/config.h
+exec/config.h.in
+exec/config-mips.m4
+exec/configure
+exec/*.s.s
diff --git a/.mailmap b/.mailmap
index 32f56c07e1e..c9bdede6c73 100644
--- a/.mailmap
+++ b/.mailmap
@@ -27,6 +27,8 @@ Andrew G Cohen <cohen@andy.bu.edu> <cohen@bu.edu>
Arash Esbati <arash@gnu.org> <arash.esbati@gmail.com>
Arash Esbati <arash@gnu.org> <esbati@gmx.de>
Artur Malabarba <bruce.connor.am@gmail.com> <am12548@it055607.users.bris.ac.uk>
+Artur Malabarba <bruce.connor.am@gmail.com> Artur Malabarba <address@hidden>
+Basil L. Contovounesios <basil@contovou.net> <contovob@tcd.ie>
Bastien Guerry <bzg@gnu.org>
Bastien Guerry <bzg@gnu.org> <bastien1@free.fr>
Bastien Guerry <bzg@gnu.org> <bzg@altern.org>
@@ -51,8 +53,7 @@ David M. Koppelman <koppel@ece.lsu.edu>
Deniz Dogan <deniz@dogan.se> <deniz.a.m.dogan@gmail.com>
Dick R. Chiang <dick.r.chiang@gmail.com>
Dick R. Chiang <dick.r.chiang@gmail.com> dickmao <none>
-Earl Hyatt <ej32u@protonmail.com>
-Earl Hyatt <ej32u@protonmail.com> <okamsn@protonmail.com>
+Earl Hyatt <okamsn@protonmail.com> <ej32u@protonmail.com>
Edward M. Reingold <reingold@emr.cs.iit.edu>
Eli Zaretskii <eliz@gnu.org> <eliz@is.elta.co.il>
Emilio C. Lopes <eclig@gmx.net>
@@ -90,6 +91,7 @@ Joakim Verona <joakim@verona.se> <root@exodia.verona.se>
John Wiegley <johnw@newartisans.com> <jwiegley@gmail.com>
Jose A. Ortega Ruiz <jao@gnu.org>
João Távora <joaotavora@gmail.com>
+João Távora <joaotavora@gmail.com> <capitaomorte@archlinux2022.linuxvmimages.local>
Julien Danjou <julien@danjou.info> <jd@dex.adm.naquadah.org>
Julien Danjou <julien@danjou.info> Julien Danjou <jd@abydos>
Juri Linkov <juri@linkov.net> <juri@jurta.org>
@@ -114,6 +116,7 @@ Lars Ingebrigtsen <larsi@gnus.org> <larsi@quimbies.gnus.org>
Lars Ingebrigtsen <larsi@gnus.org> <larsi@stories.gnus.org>
Laurence Warne <laurencewarne@gmail.com>
Lin Sun <lin.sun@zoom.us>
+Liu Hui <liuhui1610@gmail.com> <ilupin@users.noreply.github.com>
Ludovic Courtès <ludo@gnu.org>
Luke Lee <luke.yx.lee@gmail.com>
Martin Rudalics <rudalics@gmx.at>
@@ -122,6 +125,7 @@ Masatake YAMATO <yamato@redhat.com> <jet@gyve.org>
Matt Armstrong <matt@rfc20.org> <marmstrong@google.com>
Matt Armstrong <matt@rfc20.org> <matt@mdeb>
Mattias Engdegård <mattiase@acm.org>
+Mattias Engdegård <mattiase@acm.org> <mattias.engdegard@gmail.com>
Maxim Nikulin <manikulin@gmail.com>
Michael Albinus <michael.albinus@gmx.de> <albinus@detlef>
Michalis V <mvar.40k@gmail.com>
@@ -160,8 +164,8 @@ Ronnie Schnell <ronnie@driver-aces.com>
Ryan C. Thompson <rct@thompsonclan.org>
Sam Steingold <sds@gnu.org> <sdsg@amazon.com>
Simen Heggestøyl <simenheg@runbox.com>
-Simen Heggestøyl <simenheg@runbox.com> <simenheg@ifi.uio.no>
Simen Heggestøyl <simenheg@runbox.com> <simenheg@gmail.com>
+Simen Heggestøyl <simenheg@runbox.com> <simenheg@ifi.uio.no>
Simon Josefsson <simon@josefsson.org> <jas@extundo.com>
Stefan Kangas <stefankangas@gmail.com> <stefan@marxist.se>
Stefan Monnier <monnier@iro.umontreal.ca> <monnier@IRO.UMontreal.CA>
@@ -189,6 +193,7 @@ Wolfgang Scherer <wolfgang.scherer@gmx.de> <Wolfgang.Scherer@gmx.de>
Xi Lu <lx@shellcodes.org>
Xue Fuqiao <xfq.free@gmail.com> <xfq@gnu.org>
Yilkal Argaw <yilkalargawworkneh@gmail.com>
+Yuan Fu <casouri@gmail.com> <yuan@debian-BULLSEYE-live-builder-AMD64>
Yuuki Harano <masm+github@masm11.me> <masm@masm11.ddo.jp>
Óscar Fuentes <ofv@wanadoo.es>
İ. Göktuğ Kayaalp <self@gkayaalp.com>
diff --git a/CONTRIBUTE b/CONTRIBUTE
index af5519c1bb3..7c5c07771eb 100644
--- a/CONTRIBUTE
+++ b/CONTRIBUTE
@@ -18,7 +18,7 @@ To configure Git for Emacs development, you can run the following:
The following shell commands then build and run Emacs from scratch:
- git clone git://git.sv.gnu.org/emacs.git
+ git clone https://git.savannah.gnu.org/git/emacs.git
cd emacs
./autogen.sh
./configure
diff --git a/ChangeLog.1 b/ChangeLog.1
index 40d2920a97b..b592cc0bcab 100644
--- a/ChangeLog.1
+++ b/ChangeLog.1
@@ -1494,7 +1494,7 @@
2014-01-05 Paul Eggert <eggert@cs.ucla.edu>
Port to GNU/Linux with recent grsecurity/PaX patches (Bug#16343).
- Problem and proposed patch reported by Ulrich Mueller;
+ Problem and proposed patch reported by Ulrich Müller;
this patch uses a somewhat-different approach.
* configure.ac (SETFATTR): New variable.
@@ -7582,7 +7582,7 @@
* INSTALL.CVS: Clarify why `make bootstrap' sometimes fails.
-2008-06-08 Eric S. Raymond <esr@snark.thyrsus.com>
+2008-06-08 Eric S. Raymond <esr@thyrsus.com>
* INSTALL.CVS: Indicate when "cvs update -d" may be needed.
@@ -9672,7 +9672,7 @@
* configure.in: New entry for HP/UX-11.
* Makefile.in (SOURCES): Replace GETTING.GNU.SOFTWARE with FTP.
- From Eric S. Raymond <esr@golux.thyrsus.com>.
+ From Eric S. Raymond <esr@thyrsus.com>.
2001-10-28 Eli Zaretskii <eliz@is.elta.co.il>
@@ -13896,7 +13896,7 @@
places. Implement them by setting C_SWITCH_X_SITE and
LD_SWITCH_X_SITE in src/config.h.
-1993-03-22 Eric S. Raymond (eric@geech.gnu.ai.mit.edu)
+1993-03-22 Eric S. Raymond (esr@thyrsus.com)
* make-dist: Don't distribute etc/Old files.
@@ -13907,7 +13907,7 @@
* make-dist: Fix typo.
-1993-03-19 Eric S. Raymond (eric@geech.gnu.ai.mit.edu)
+1993-03-19 Eric S. Raymond (esr@thyrsus.com)
* make-dist: Corrected typo, fixed it to discard = and TAGS files
in some cases where it should but didn't seen to.
@@ -13924,11 +13924,11 @@
* configure: Recognize rs6000-ibm-aix32 and rs6000-ibm-aix, and
make rs6000-ibm-aix default to -aix32.
-1993-03-17 Eric S. Raymond (eric@geech.gnu.ai.mit.edu)
+1993-03-17 Eric S. Raymond (esr@thyrsus.com)
* Makefile.in: Added `Developer's configuration' section.
-1993-03-17 Eric S. Raymond (eric@mole.gnu.ai.mit.edu)
+1993-03-17 Eric S. Raymond (esr@thyrsus.com)
* Makefile.in: Add commented-out variable settings for developer's
configuration.
@@ -14299,7 +14299,7 @@
return handler, make a copy of it, not a symbolic link to it; that
way, it will work on systems that don't have symbolic links.
-1992-08-14 Eric S. Raymond (eric@mole.gnu.ai.mit.edu)
+1992-08-14 Eric S. Raymond (esr@thyrsus.com)
* make-dist: Taught it about vcdiff and rcs2log, added --newer
option for generating incremental distributions. Stopped it from
diff --git a/ChangeLog.3 b/ChangeLog.3
index d43ffa10bc7..7db4986410d 100644
--- a/ChangeLog.3
+++ b/ChangeLog.3
@@ -3672,7 +3672,7 @@
* lib-src/emacsclient.c (set_local_socket): Revert to the Emacs 27
behavior of not trying TMPDIR if XDG_RUNTIME_DIR is set.
This is one of the suggestions made by Jim Porter and
- independently by Ulrich Mueller in Bug#51327.
+ independently by Ulrich Müller in Bug#51327.
2021-12-09 Cameron Desautels <camdez@gmail.com>
@@ -44923,7 +44923,7 @@
* etc/NEWS: Announce the new 'cham' input method.
* etc/HELLO: Fix the order of letters in the Cham greeting.
- Remove redundant newlines (reported by Ulrich Mueller
+ Remove redundant newlines (reported by Ulrich Müller
<ulm@gentoo.org>).
* lisp/language/cham.el ("Cham"): Add input-method entry.
@@ -137530,7 +137530,7 @@
Bind `enable-local-variables' in `hack-connection-local-variables'
* lisp/files-x.el (hack-connection-local-variables):
- Bind `enable-local-variables', instead of re-declaring
+ Bind `enable-local-variables', instead of redeclaring
`safe-local-variable-p'.
2019-03-23 Eli Zaretskii <eliz@gnu.org>
@@ -155306,7 +155306,7 @@
Set group when installing, too
- From a patch by Ulrich Mueller in:
+ From a patch by Ulrich Müller in:
https://lists.gnu.org/r/emacs-devel/2018-06/msg00687.html
* Makefile.in (set_installuser): Also set the group, in order
to match install(1) behavior. Also, don’t clutter stderr
@@ -161872,7 +161872,7 @@
Port to 32-bit sparc64
- Problem reported by Ulrich Mueller; fix suggested by Eli Zaretskii
+ Problem reported by Ulrich Müller; fix suggested by Eli Zaretskii
and Andreas Schwab (Bug#30855).
* src/alloc.c (mark_memory): Call mark_maybe_object only on
pointers that are properly aligned for Lisp_Object.
@@ -163179,7 +163179,7 @@
Quieten compilation of octave.el
- * lisp/progmodes/octave.el (compilation-forget-errors): Re-declare.
+ * lisp/progmodes/octave.el (compilation-forget-errors): Redeclare.
2018-02-28 Glenn Morris <rgm@gnu.org>
@@ -178544,7 +178544,7 @@
Port to 32-bit sparc64
Backport from master.
- Problem reported by Ulrich Mueller; fix suggested by Eli Zaretskii
+ Problem reported by Ulrich Müller; fix suggested by Eli Zaretskii
and Andreas Schwab (Bug#30855).
* src/alloc.c (mark_memory): Call mark_maybe_object only on
pointers that are properly aligned for Lisp_Object.
diff --git a/ChangeLog.4 b/ChangeLog.4
index 4b806c21124..86fd1eb10d8 100644
--- a/ChangeLog.4
+++ b/ChangeLog.4
@@ -2440,7 +2440,7 @@
value of SMALL_JA_DIC option used to produce ja-dic.el.
* leim/Makefile.in (small-ja-dic-option): New target, triggers
regeneration of ja-dic.el when the value of SMALL_JA_DIC option
- changes by the configure script. Suggested by Ulrich Mueller
+ changes by the configure script. Suggested by Ulrich Müller
<ulm@gentoo.org>.
(${leimdir}/ja-dic/ja-dic.el): Depend on 'small-ja-dic-option'.
(Bug#66125)
@@ -120352,7 +120352,7 @@
Do not quote lambda expressions
- http://emacs.stackexchange.com/a/3596
+ https://emacs.stackexchange.com/a/3596
Quoting lambda expressions is at best redundant and at worst
detrimental; this commit removes all use of the sharp-quote to reduce
@@ -121086,7 +121086,7 @@
This change follows the regexp for require on emacs truck. See line
2327 on font-lock.el in the following patch.
- http://bzr.savannah.gnu.org/lh/emacs/trunk/revision/111821
+ https://bzr.savannah.gnu.org/lh/emacs/trunk/revision/111821
2013-09-04 John Wiegley <johnw@newartisans.com>
diff --git a/ChangeLog.android b/ChangeLog.android
new file mode 100644
index 00000000000..e86ef7a2a77
--- /dev/null
+++ b/ChangeLog.android
@@ -0,0 +1,7279 @@
+2023-08-07 Po Lu <luangruo@yahoo.com>
+
+ * nt/mingw-cfg.site: Remove additions for Gnulib printf.
+
+ * m4, lib: Update from Gnulib.
+
+ * msdos/sedlibmk.inp: Remove variables deleted as part of previous
+ change.
+
+ * admin/merge-gnulib (GNULIB_MODULES): Remove vasprintf and
+ printf-posix.
+
+2023-08-06 Po Lu <luangruo@yahoo.com>
+
+ * java/org/gnu/emacs/EmacsService.java (readDirectoryEntry): Fix
+ potential NULL dereference.
+
+ * java/org/gnu/emacs/EmacsSafThread.java (openDocument1): If
+ initially opening with rwt, verify the file descriptor is really
+ writable; if not, resort to rw and truncating the file descriptor
+ by hand instead.
+
+ * src/androidvfs.c (NATIVE_NAME (ftruncate)): New function.
+ Truncate file descriptor and return whether that was successful.
+
+ * src/androidvfs.c (android_saf_tree_chmod): Repair file access
+ permissions allowed within FLAGS.
+
+2023-08-05 Po Lu <luangruo@yahoo.com>
+
+ * doc/lispref/commands.texi (Touchscreen Events): Fix typo.
+
+ * lisp/subr.el (y-or-n-p): Don't call set-text-conversion-style
+ when not present.
+
+2023-08-04 Po Lu <luangruo@yahoo.com>
+
+ * ChangeLog.android: New file.
+
+2023-08-04 Po Lu <luangruo@yahoo.com>
+
+ * src/androidvfs.c (android_verify_jni_string): Move to
+ android.c.
+
+ * src/android.c (android_verify_jni_string): New function.
+ (android_build_string): Forgo encoding menu text if TEXT is a
+ multibyte string that's also a valid JNI string.
+
+ * src/android.h: Update prototypes.
+
+ * java/org/gnu/emacs/EmacsService.java (getDocumentTrees): Don't
+ encode some characters that need not be escaped within file
+ names.
+
+2023-08-03 Po Lu <luangruo@yahoo.com>
+
+ * src/fileio.c (check_vfs_filename): Revert earlier change.
+
+ * src/android.h: Update prototypes.
+
+ * src/androidvfs.c (unix_vfs_ops, android_unix_chmod, afs_vfs_ops)
+ (android_afs_chmod, content_vfs_ops, android_content_chmod)
+ (authority_vfs_ops, android_authority_chmod, saf_root_vfs_ops)
+ (android_saf_root_chmod, saf_tree_vfs_ops, android_saf_tree_chmod)
+ (saf_file_vfs_ops, saf_new_vfs_ops, android_saf_new_chmod)
+ (root_vfs_ops): Add `chmod' to the list of functions implemented
+ by each vnode.
+ (android_fchmodat): New function.
+
+ * src/fileio.c (Fset_file_modes): Use `emacs_fchmodat'.
+
+ * src/lisp.h:
+ * src/sysdep.c (emacs_fchmodat): Delegate to android_fchmodat on
+ Android.
+
+ * java/org/gnu/emacs/EmacsSafThread.java (CacheToplevel)
+ (EmacsSafThread, DocIdEntry, getCache, pruneCache)
+ (cacheDirectoryFromCursor, run, documentIdFromName1)
+ (statDocument1, openDocumentDirectory1, openDocument1): Introduce
+ a file status cache and populate it with files within directories
+ as they are opened.
+
+ * java/org/gnu/emacs/EmacsService.java (createDocument)
+ (createDirectory, moveDocument): Invalidate the file status cache
+ wherever needed.
+
+ * src/fileio.c (check_vfs_filename):
+ (Fset_file_modes): Permit `set-file-modes' to silently fail
+ on asset and content files.
+
+2023-08-02 Po Lu <luangruo@yahoo.com>
+
+ * doc/emacs/android.texi (Android, What is Android?)
+ (Android Startup, Android File System, Android Environment)
+ (Android Windowing, Android Fonts, Android Troubleshooting):
+ Improve section titles.
+ (Android Windowing): Describe the relation between keyboard
+ modifiers reported by Android and those in key events.
+
+ * java/org/gnu/emacs/EmacsWindow.java (onKeyDown, onKeyUp):
+ Clear META_SYM_ON and META_META_MASK when retrieving ASCII
+ characters.
+
+ * src/androidgui.h: Add ANDROID_META_MASK.
+
+ * src/androidterm.c (android_android_to_emacs_modifiers)
+ (android_emacs_to_android_modifiers): Transform META to Alt, and
+ vice versa.
+
+2023-08-01 Po Lu <luangruo@yahoo.com>
+
+ * doc/emacs/android.texi (Android File System): Describe how to
+ access real files named /assets or /contents if so required.
+
+ * java/org/gnu/emacs/EmacsService.java (validAuthority):
+ * src/android.c (android_init_emacs_service):
+ * src/android.h: New function.
+
+ * src/androidvfs.c (android_saf_valid_authority_p): New
+ function. Wrap the Java function.
+ (android_saf_root_stat, android_saf_root_access): Don't return
+ success if no authority by vp->authority's name exists.
+ (android_saf_tree_from_name): Check validity of string data
+ before giving it to JNI.
+
+ * src/sfnt.c (CHECK_STACK_AVAILABLE): New macro.
+ (PUSH, PUSH_UNCHECKED): Always define to unchecked versions,
+ even if TEST.
+ (PUSH2_UNCHECKED): New macro.
+ (NPUSHB, NPUSHW, PUSHB, PUSHW): Check the number of remaining
+ stack elements once.
+ (stack_overflow_test_args): Expect zero stack arguments.
+
+ * src/android.c (ANDROID_THROW): Remove unused macro.
+
+2023-07-31 Po Lu <luangruo@yahoo.com>
+
+ * src/sfnt.c (ISECT): Micro-optimize this instruction.
+
+ * src/sfntfont.c (sfnt_parse_style): Avoid GC safety problem.
+ (sfnt_parse_style): Fix misworded commentary.
+
+ * java/org/gnu/emacs/EmacsNative.java (EmacsNative):
+ * java/org/gnu/emacs/EmacsNoninteractive.java (main):
+ * java/org/gnu/emacs/EmacsService.java (run):
+ * java/org/gnu/emacs/EmacsThread.java (run):
+ * src/android.c (initEmacs, setEmacsParams): Set
+ `android_api_level' within setEmacsParams, not in initEmacs.
+
+ * src/androidvfs.c: Pacify compiler warnings.
+
+ * java/org/gnu/emacs/EmacsService.java (renameDocument): Don't
+ catch UnsupportedOperationException; handle ENOSYS in
+ android_saf_rename_document instead.
+ (moveDocument): New function.
+
+ * lisp/subr.el (y-or-n-p): Always change the text conversion
+ style.
+
+ * src/android.c (android_init_emacs_service)
+ (android_exception_check_4): New function.
+
+ * src/android.h: Update Java function table.
+
+ * src/androidvfs.c (android_saf_rename_document): Handle ENOSYS
+ here by setting errno to EXDEV.
+ (android_saf_move_document): New function.
+ (android_document_id_from_name): Take const `dir_name'.
+ (android_saf_tree_rename): Use delete-move-rename to implement
+ cross-directory renames.
+
+2023-07-30 Po Lu <luangruo@yahoo.com>
+
+ * java/org/gnu/emacs/EmacsSafThread.java
+ (postInvalidateCacheDir):
+ * java/org/gnu/emacs/EmacsService.java (renameDocument): New
+ functions.
+
+ * src/android.c (android_init_emacs_service):
+ * src/android.h (struct android_emacs_service): Link to new JNI
+ function.
+
+ * src/androidvfs.c (android_saf_rename_document): New function.
+ (android_saf_tree_rename): Implement in terms of that function
+ if possible.
+
+2023-07-29 Po Lu <luangruo@yahoo.com>
+
+ * java/org/gnu/emacs/EmacsSafThread.java (statDocument1):
+
+ * src/androidvfs.c (android_afs_stat, android_content_stat)
+ (android_saf_root_stat): Report search permissions for files.
+
+ * src/androidvfs.c: Improve commentary.
+
+2023-07-29 Po Lu <luangruo@yahoo.com>
+
+ * java/org/gnu/emacs/EmacsSafThread.java (postInvalidateCache):
+ New argument cacheName. Remove that file from the cache.
+ (accessDocument1): Consult the storage cache as well.
+
+ * java/org/gnu/emacs/EmacsService.java (deleteDocument): New
+ argument NAME.
+
+ * src/android.c (android_init_emacs_service): Add new argument.
+
+ * src/androidvfs.c (android_saf_delete_document)
+ (android_saf_tree_rmdir, android_saf_file_unlink): Pass name of
+ file being deleted to `deleteDocument'.
+
+2023-07-29 Po Lu <luangruo@yahoo.com>
+
+ * src/androidvfs.c (android_saf_exception_check): Describe
+ exceptions earlier.
+
+ * java/org/gnu/emacs/EmacsSafThread.java (DocIdEntry)
+ (getCacheEntry, CacheEntry, documentIdFromName1): Fix earlier
+ change.
+
+ * java/org/gnu/emacs/EmacsSafThread.java (DocIdEntry)
+ (getCacheEntry, CacheEntry): Use `uptimeMillis' as the basis for
+ cache expiration.
+
+ * java/org/gnu/emacs/EmacsSafThread.java (EmacsSafThread, getCache)
+ (pruneCache1, pruneCache, cacheChild, cacheDirectoryFromCursor)
+ (documentIdFromName1, openDocumentDirectory1): Implement the
+ cache referred to by the commentary.
+
+ * java/org/gnu/emacs/EmacsService.java (deleteDocument):
+ Invalidate the cache upon document removal.
+
+ * src/androidvfs.c (android_saf_exception_check)
+ (android_document_id_from_name): Correctly preserve or set errno
+ in error cases.
+
+2023-07-28 Po Lu <luangruo@yahoo.com>
+
+ * java/org/gnu/emacs/EmacsSafThread.java (documentIdFromName1):
+ Fix query argument placeholder string.
+
+ * src/androidvfs.c (android_document_id_from_name): Don't return
+ 0 if an SAF exception occurs.
+
+ * src/androidselect.c (Fandroid_get_clipboard): Don't return
+ data if clipboard is empty. Reported by Johan Widén
+ <j.e.widen@gmail.com>.
+
+2023-07-28 Po Lu <luangruo@yahoo.com>
+
+ * doc/emacs/android.texi (Android Document Providers): Say that
+ quitting is now possible.
+
+ * java/org/gnu/emacs/EmacsNative.java (EmacsNative): New
+ functions `safSyncAndReadInput', `safync' and `safPostRequest'.
+
+ * java/org/gnu/emacs/EmacsSafThread.java: New file. Move
+ cancel-able SAF operations here.
+
+ * java/org/gnu/emacs/EmacsService.java (EmacsService): Allow
+ quitting from most SAF operations.
+
+ * src/androidvfs.c (android_saf_exception_check): Return EINTR if
+ OperationCanceledException is received.
+ (android_saf_stat, android_saf_access)
+ (android_document_id_from_name, android_saf_tree_opendir_1)
+ (android_saf_file_open): Don't allow reentrant calls from async
+ input handlers.
+ (NATIVE_NAME): Implement new synchronization primitives for JNI.
+ (android_vfs_init): Initialize new class.
+
+ * src/dired.c (open_directory): Handle EINTR from opendir.
+
+ * src/sysdep.c: Describe which operations may return EINTR on
+ Android.
+
+2023-07-28 Po Lu <luangruo@yahoo.com>
+
+ * java/org/gnu/emacs/EmacsDirectoryEntry.java
+ (EmacsDirectoryEntry): Make class final.
+
+ * java/org/gnu/emacs/EmacsService.java (accessDocument)
+ (openDocumentDirectory, openDocument, createDocument): Throw
+ access and IO error exceptions instead of catching them.
+ (createDirectory, deleteDocument): New functions.
+
+ * src/android.c (android_init_emacs_service): Add new functions.
+
+ * src/android.h (struct android_emacs_service): Likewise.
+
+ * src/androidvfs.c (android_saf_exception_check): New function.
+ Translate between Java exceptions and errno values.
+ (android_saf_stat, android_saf_access, android_saf_delete_document)
+ (struct android_saf_tree_vnode, android_document_id_from_name)
+ (android_saf_tree_name, android_saf_tree_rmdir)
+ (android_saf_tree_opendir_1, android_saf_tree_opendir)
+ (android_saf_file_open, android_saf_file_unlink)
+ (android_saf_new_open, android_saf_new_mkdir): Implement missing
+ VFS operations and derive errno values from the type of any
+ exceptions thrown.
+ (android_vfs_init): Initialize exception classes.
+ (android_mkdir, android_fstat): Remove trailing whitespace.
+
+2023-07-27 Po Lu <luangruo@yahoo.com>
+
+ * doc/emacs/android.texi (Android Document Providers): Improve
+ wording of paragraph clarifying limits on subprocesses.
+
+ * java/org/gnu/emacs/EmacsService.java (getDocumentTrees): Use
+ Java standard US-ASCII coding standard instead of the
+ undocumented ``ASCII'' alias.
+ (decodeFileName): Remove unused function.
+ (documentIdFromName):
+ * src/android.c (android_init_emacs_service): Take a String for
+ NAME instead of a byte array.
+
+ * src/androidvfs.c (android_verify_jni_string): New function.
+ (android_document_id_from_name): Verify that STRING is a valid
+ Modified UTF-8 string.
+
+ * src/androidvfs.c (android_afs_initial)
+ (android_content_get_directory_name, android_saf_tree_name)
+ (android_saf_tree_from_name, android_vfs_init): Silence compiler
+ warnings.
+
+ * src/android.c (android_run_in_emacs_thread): Behave more
+ robustly if SIGIO arrives too late Emacs for Emacs to check for
+ signals, but too early to preempt a long running syscall.
+
+ * java/org/gnu/emacs/EmacsActivity.java (onActivityResult):
+
+ * src/androidvfs.c (android_renameat_noreplace, android_rename):
+ Free vdst using vdst->ops, not vp->ops.
+
+2023-07-27 Po Lu <luangruo@yahoo.com>
+
+ * configure.ac (ANDROID_STUBIFY): Add androidvfs.o when building
+ libemacs.so.
+
+ * doc/emacs/android.texi (Android): Add `Android Document
+ Providers'.
+ (Android Startup): Update the location of the content identifier
+ directory.
+ (Android File System): Describe access to document provider
+ directories.
+ (Android Document Providers): New node.
+
+ * doc/emacs/emacs.texi (Top): Update the menu for the Android
+ appendix.
+
+ * java/Makefile.in (filename, install_temp/assets/build_info):
+ Make directory-tree depend on build_info.
+
+ * java/org/gnu/emacs/EmacsActivity.java (onActivityResult): New
+ function. When a document tree is accepted, persist access to it.
+
+ * java/org/gnu/emacs/EmacsDirectoryEntry.java
+ (EmacsDirectoryEntry): New struct.
+
+ * java/org/gnu/emacs/EmacsOpenActivity.java (checkReadableOrCopy):
+ Use EmacsService.buildContentName.
+
+ * java/org/gnu/emacs/EmacsService.java (getEmacsView)
+ (openContentUri)
+ (checkContentUri): Remove excessive debug logging.
+ (buildContentName, getDocumentAuthorities, requestDirectoryAccess)
+ (getDocumentTrees, decodeFileName, documentIdFromName, getTreeUri)
+ (statDocument, accessDocument, openDocumentDirectory)
+ (readDirectoryEntry)
+ (openDocument, createDocument): New functions.
+
+ * lib-src/asset-directory-tool.c: Improve commentary by
+ illustrating the difference between directory and ordinary files.
+
+ * src/android.c (ANDROID_THROW, enum android_fd_table_entry_flags)
+ (struct android_emacs_service, android_extract_long)
+ (android_scan_directory_tree, android_is_directory)
+ (android_get_asset_name, android_url_encode)
+ (android_content_name_p)
+ (android_get_content_name, android_check_content_access)
+ (android_fstat)
+ (android_fstatat, android_file_access_p)
+ (android_hack_asset_fd_fallback)
+ (android_detect_ashmem, android_hack_asset_fd)
+ (android_close_on_exec)
+ (android_open, android_close, android_fclose)
+ (android_create_lib_link)
+ (android_faccessat, struct android_dir, android_opendir)
+ (android_dirfd)
+ (android_readdir, android_closedir)
+ (android_lookup_asset_directory_fd)
+ (android_exception_check_3, android_get_current_api_level)
+ (android_open_asset, android_close_asset, android_asset_read_quit)
+ (android_asset_read, android_asset_lseek, android_asset_fstat):
+ Move content and asset related functions to androidvfs.c.
+ (android_init_emacs_service): Obtain handles for new JNI
+ functions.
+ (initEmacsParams): Initialize the VFS layer.
+ (android_request_directory_access): New function.
+ (android_display_toast): Remove unused function.
+
+ * src/android.h (android_get_current_api_level): Assume that
+ this function never returns less than __ANDROID_API__.
+ (struct android_emacs_service): Move `struct
+ android_emacs_service' here.
+
+ * src/androidfns.c (Fandroid_request_directory_access): New
+ interactive function.
+ (syms_of_androidfns): Register new subr.
+
+ * src/androidvfs.c (struct android_vdir, struct android_vops)
+ (struct android_vnode, struct android_special_vnode)
+ (enum android_vnode_type, struct android_cursor_class)
+ (struct emacs_directory_entry_class)
+ (struct android_parcel_file_descriptor_class)
+ (android_init_cursor_class, android_init_entry_class)
+ (android_init_fd_class, android_vfs_canonicalize_name)
+ (struct android_unix_vnode, struct android_unix_vdir)
+ (unix_vfs_ops)
+ (android_unix_name, android_unix_vnode, android_unix_open)
+ (android_unix_close, android_unix_unlink, android_unix_symlink)
+ (android_unix_rmdir, android_unix_rename, android_unix_stat)
+ (android_unix_access, android_unix_mkdir, android_unix_readdir)
+ (android_unix_closedir, android_unix_dirfd, android_unix_opendir)
+ (android_extract_long, android_scan_directory_tree)
+ (android_is_directory, android_init_assets)
+ (android_hack_asset_fd_fallback, android_detect_ashmem)
+ (android_hack_asset_fd, struct android_afs_vnode)
+ (struct android_afs_vdir, struct android_afs_open_fd, afs_vfs_ops)
+ (android_afs_name, android_afs_initial, android_close_on_exec)
+ (android_afs_open, android_afs_close, android_afs_unlink)
+ (android_afs_symlink, android_afs_rmdir, android_afs_rename)
+ (android_afs_stat, android_afs_access, android_afs_mkdir)
+ (android_afs_readdir, android_afs_closedir, android_afs_dirfd)
+ (android_afs_opendir, android_afs_get_directory_name)
+ (struct android_content_vdir, content_vfs_ops)
+ (content_directory_contents, android_content_name)
+ (android_content_open, android_content_close)
+ (android_content_unlink, android_content_symlink)
+ (android_content_rmdir, android_content_rename)
+ (android_content_stat, android_content_access)
+ (android_content_mkdir, android_content_readdir)
+ (android_content_closedir, android_content_dirfd)
+ (android_content_opendir, android_content_get_directory_name)
+ (android_content_initial, android_get_content_name)
+ (android_check_content_access, struct android_authority_vnode)
+ (authority_vfs_ops, android_authority_name)
+ (android_authority_open)
+ (android_authority_close, android_authority_unlink)
+ (android_authority_symlink, android_authority_rmdir)
+ (android_authority_rename, android_authority_stat)
+ (android_authority_access, android_authority_mkdir)
+ (android_authority_opendir, android_authority_initial)
+ (struct android_saf_root_vnode, struct android_saf_root_vdir)
+ (saf_root_vfs_ops, android_saf_root_name, android_saf_root_open)
+ (android_saf_root_close, android_saf_root_unlink)
+ (android_saf_root_symlink, android_saf_root_rmdir)
+ (android_saf_root_rename, android_saf_root_stat)
+ (androqid_saf_root_access, android_saf_root_mkdir)
+ (android_saf_root_readdir, android_saf_root_closedir)
+ (android_saf_root_dirfd, android_saf_root_opendir)
+ (android_saf_root_initial, android_saf_root_get_directory)
+ (android_saf_stat, android_saf_access)
+ (struct android_saf_tree_vnode, struct android_saf_tree_vdir)
+ (saf_tree_vfs_ops, android_document_id_from_name)
+ (android_saf_tree_name, android_saf_tree_open)
+ (android_saf_tree_close, android_saf_tree_unlink)
+ (android_saf_tree_symlink, android_saf_tree_rmdir)
+ (android_saf_tree_rename, android_saf_tree_stat)
+ (android_saf_tree_access, android_saf_tree_mkdir)
+ (android_saf_tree_opendir_1, android_saf_tree_readdir)
+ (android_saf_tree_closedir, android_saf_tree_dirfd)
+ (android_saf_tree_opendir, android_saf_tree_from_name)
+ (android_saf_tree_get_directory, android_saf_file_vnode)
+ (saf_file_vfs_ops, android_saf_file_name, android_saf_file_open)
+ (android_saf_file_unlink, android_saf_file_rmdir)
+ (android_saf_file_opendir, android_close_parcel_fd)
+ (android_saf_new_vnode, android_saf_new_name)
+ (android_saf_new_open)
+ (android_saf_new_unlink, android_saf_new_symlink)
+ (android_saf_new_rmdir, android_saf_new_rename)
+ (android_saf_new_stat, android_saf_new_access)
+ (android_saf_new_mkdir, android_saf_new_opendir, root_vfs_ops)
+ (special_vnodes, android_root_name, android_name_file)
+ (android_vfs_init, android_open, android_unlink, android_symlink)
+ (android_rmdir, android_mkdir, android_renameat_noreplace)
+ (android_rename, android_fstat, android_fstatat_1)
+ (android_fstatat)
+ (android_faccessat, android_fdopen, android_close, android_fclose)
+ (android_open_asset, android_close_asset, android_asset_read_quit)
+ (android_asset_read, android_asset_lseek, android_asset_fstat)
+ (android_opendir, android_dirfd, android_readdir)
+ (android_closedir): Move file system emulation routines here.
+ Introduce a new ``VFS'' layer for translating between
+ Emacs-specific file names and the various disparate interfaces
+ for accessing files on Android.
+
+ * src/callproc.c (delete_temp_file):
+ * src/charset.c (load_charset_map_from_file):
+ * src/dired.c:
+ * src/emacs.c (Fkill_emacs):
+ * src/fileio.c (check_mutable_filename, Fcopy_file)
+ (Fmake_directory_internal, Fdelete_directory_internal)
+ (Fdelete_file, Frename_file, Fadd_name_to_file)
+ (Fmake_symbolic_link, file_accessible_directory_p)
+ (Fset_file_modes)
+ (Fset_file_times, write_region):
+ * src/filelock.c (get_boot_time, rename_lock_file)
+ (create_lock_file, current_lock_owner, unlock_file):
+ * src/image.c (slurp_file, png_load_body, jpeg_load_body):
+ * src/keyboard.c (Fopen_dribble_file):
+ * src/lisp.h:
+ * src/lread.c (Fload):
+ * src/process.c (handle_child_signal):
+ * src/sysdep.c (init_standard_fds, emacs_fopen, emacs_fdopen)
+ (emacs_unlink, emacs_symlink, emacs_rmdir, emacs_mkdir)
+ (emacs_renameat_noreplace, emacs_rename):
+ * src/term.c (Fresume_tty, init_tty): Use and add new wrappers
+ for fopen, fdopen, unlink, symlink, rmdir, mkdir,
+ renameat_norepalce and rename.
+
+2023-07-23 Po Lu <luangruo@yahoo.com>
+
+ * doc/emacs/android.texi (Android File System): Document where the
+ app library directory can probably be found.
+
+ * src/android.c (android_create_lib_link): New function. Try to
+ symlink `lib' in the directory holding the files directory to the
+ app library directory.
+ (setEmacsParams): Call that function if Emacs is being initialized
+ from an application context.
+
+2023-07-22 Po Lu <luangruo@yahoo.com>
+
+ * lisp/touch-screen.el (touch-screen-drag): If
+ touch-screen-word-select, also keep the initial word within the
+ region while scrolling.
+
+ * src/window.h (WINDOW_MENU_BAR_P): Check for external menu bars
+ using HAVE_WINDOW_SYSTEM && HAVE_EXT_MENU_BAR instead of hard
+ coding X without Xt or GTK.
+
+ * doc/lispref/commands.texi (Key Sequence Input): Describe which
+ events receive imaginary prefix keys.
+ * lisp/touch-screen.el (touch-screen-translate-touch): Consider
+ `vertical-line' a virtual function key.
+ (function-key-map): Translate events on vertical window borders.
+
+ * etc/NEWS: Announce `current-key-remap-sequence'.
+
+ * src/androidfns.c (Fx_create_frame): Default
+ Qvertical_scroll_bars to Qnil, but set scroll-bar-width and
+ scroll-bar-height.
+
+2023-07-21 Po Lu <luangruo@yahoo.com>
+
+ * doc/lispref/commands.texi (Key Sequence Input): Document new
+ argument to `read-key-sequence' etc.
+
+ * lisp/help-macro.el (make-help-screen):
+ * lisp/subr.el (read-key, read-char-choice-with-read-key): Disable
+ text conversion and display the OSK before reading a key sequence.
+
+ * lisp/touch-screen.el (touch-screen-window-selection-changed):
+ Only cancel the minibuffer OSK timer.
+ (touch-screen-handle-point-up): Update comment accordingly.
+
+ * src/keyboard.c (command_loop_1, read_menu_command)
+ (read_key_sequence, read_key_sequence_vs, Fread_key_sequence)
+ (Fread_key_sequence_vector): New arg DISABLE_TEXT_CONVERSION.
+ All callers changed.
+
+ * lisp/touch-screen.el (touch-screen-translate-touch): Check if a
+ prefix is specified separately from prefix being non-nil. Accept
+ `nil' as an imaginary prefix key.
+ (function-key-map): Register translation functions on the tab bar,
+ tab lines and internal border.
+
+ * lisp/touch-screen.el (touch-screen-preview-select): Avoid
+ unnecessary redisplays.
+ (touch-screen-drag): Scroll at window margins using window
+ scrolling functions instead of relying on redisplay to recenter
+ the window around point.
+
+ * doc/emacs/input.texi (Touchscreens): Document
+ `touch-screen-preview-select'.
+
+ * doc/lispref/commands.texi (Touchscreen Events): Fix typo in the
+ descriptions of two touch screen events.
+
+ * lisp/dired.el (dired-insert-set-properties): Adjust for changes
+ to file end computation.
+
+ * lisp/minibuffer.el (clear-minibuffer-message): Don't clear
+ minibuffer message if dragging.
+
+ * lisp/touch-screen.el (touch-screen-current-tool): Fix doc
+ string.
+ (touch-screen-preview-select): New function.
+ (touch-screen-drag): Call it if point changes.
+
+2023-07-20 Po Lu <luangruo@yahoo.com>
+
+ * exec/trace.c (handle_readlinkat): Adjust commentary to match
+ behavior.
+
+ * src/android.c (android_get_keysym_name): NULL terminate
+ *NAME_RETURN.
+
+ * lisp/international/mule-cmds.el (set-coding-system-map): Don't
+ display `set-terminal-coding-system' on Android.
+
+ * lisp/cus-edit.el (custom-display): Add `android' display type.
+
+ * src/android.c (struct android_event_queue): Don't make
+ unnecessarily volatile.
+
+ * lisp/touch-screen.el (touch-screen-handle-touch): Don't restart
+ dragging if point is at ZV and the tap falls on a different row.
+
+ * java/org/gnu/emacs/EmacsContextMenu.java (EmacsContextMenu): New
+ field `title'.
+ (addSubmenu): New arg TITLE. Set that field.
+ (expandTo): Set MENU's header title if it's a context menu.
+
+ * src/androidmenu.c (android_init_emacs_context_menu): Adjust
+ signature of `createContextMenu'.
+ (android_menu_show): Use TITLE instead of pane titles if there's
+ only one pane.
+
+ * doc/emacs/dired.texi (Marks vs Flags): Document command bound
+ to `touchscreen-hold'.
+
+ * doc/lispref/commands.texi (Touchscreen Events): Describe
+ `touch-screen-inhibit-drag'.
+
+ * etc/NEWS: Improve description of changes to touch screen
+ support.
+
+ * lisp/dired-aux.el (dired-do-chxxx, dired-do-chmod)
+ (dired-do-print, dired-do-shell-command, dired-do-compress-to)
+ (dired-do-create-files, dired-do-rename, dired-do-isearch)
+ (dired-do-isearch-regexp, dired-do-search)
+ (dired-do-query-replace-regexp, dired-do-find-regexp)
+ (dired-vc-next-action): Disable ``click to select'' after
+ running this command.
+
+ * lisp/dired.el (dired-insert-set-properties): Attach
+ click-to-select keymap to file names if necessary.
+ (dired-mode-map): Bind `touchscreen-hold' to click to select
+ mode.
+ (dired-post-do-command): New function.
+ (dired-do-delete): Call it.
+ (dired-mark-for-click, dired-enable-click-to-select-mode): New
+ functions.
+ (dired-click-to-select-mode): New minor mode.
+
+ * lisp/touch-screen.el (touch-screen-current-tool): Fix doc
+ string.
+ (touch-screen-inhibit-drag): New function.
+
+2023-07-19 Po Lu <luangruo@yahoo.com>
+
+ * src/sfnt.c (sfnt_infer_deltas): Improve commentary.
+
+ * lisp/touch-screen.el (touch-screen-handle-point-up): If what is
+ `restart-drag' (meaning that a drag has been restarted but the
+ touchpoint has not moved), translate the release into a regular
+ mouse click to deactivate the region.
+
+ * build-aux/makecounter.sh (curcount): Rename `counter' to
+ `emacs_shortlisp_counter'.
+
+ * doc/emacs/input.texi (Touchscreens): Document
+ `touch-screen-extend-selection'.
+
+ * doc/lispref/commands.texi (Touchscreen Events): Document
+ `touchscreen-restart-drag'.
+
+ * lisp/touch-screen.el (touch-screen-extend-selection): New user
+ option.
+ (touch-screen-restart-drag): New function.
+ (touch-screen-handle-point-update): Handle `restart-drag'
+ gestures.
+ (touch-screen-handle-touch): Check if the prerequisites for
+ extending a previous drag gesture are met, and generate such
+ events if so.
+ (touch-screen-translate-touch): Update doc string.
+
+ * src/Makefile.in (otherobj): Remove BUILD_COUNTER_OBJ.
+ ($(lispsource)/international/charprop.el):
+ (%.elc): Don't depend on bootstrap-emacs if cross configuring for
+ Android.
+ (libemacs.so): Directly depend on and link with BUILD_COUNTER_OBJ.
+
+ * build-aux/makecounter.sh: New script.
+
+ * src/Makefile.in (abs_top_builddir): New variable.
+ (BUILD_COUNTER_OBJ): Define to build-counter.o
+ if compiling for Android.
+ (build-counter.c): New target. Generate this file using
+ makecounter.sh upon changes to lisp.mk or shortlisp.
+ (lisp.mk): Make and load relative to abs_top_builddir.
+ (emacs$(EXEEXT)): Adjust accordingly.
+ (mostlyclean): Remove build-counter.c.
+
+2023-07-18 Po Lu <luangruo@yahoo.com>
+
+ * lisp/touch-screen.el (touch-screen-handle-point-update)
+ (touch-screen-handle-point-up): Fix typos.
+
+ * lisp/touch-screen.el (touch-screen-handle-point-update): Fix
+ typo.
+
+ * src/keyboard.c (make_lispy_event): Return nil if no menu item
+ is found.
+
+ * lisp/touch-screen.el (touch-screen-hold)
+ (touch-screen-handle-point-up): Don't select inactive minibuffer
+ windows.
+ (touch-screen-handle-point-update): Improve detection of left
+ and right edges.
+
+ * lisp/touch-screen.el (touch-screen-handle-touch): Fix treatment
+ of stray update events.
+
+ * src/frame.c (syms_of_frame): Default to nil if HAVE_ANDROID.
+
+ * src/keyboard.c (make_lispy_event): Fix botched merge.
+
+ * doc/lispref/commands.texi (Touchscreen Events): Describe
+ treatment of canceled touch sequences during touch event
+ translation.
+
+ * java/org/gnu/emacs/EmacsNative.java (EmacsNative): Update JNI
+ prototypes.
+
+ * java/org/gnu/emacs/EmacsWindow.java (motionEvent): Set
+ cancellation flag in events sent where appropriate.
+
+ * lisp/touch-screen.el (touch-screen-handle-point-update):
+ Improve treatment of horizontal scrolling near window edges.
+ (touch-screen-handle-touch): Don't handle point up if the touch
+ sequence has been canceled.
+
+ * src/android.c (sendTouchDown, sendTouchUp, sendTouchMove): New
+ argument `flags'.
+
+ * src/androidgui.h (enum android_touch_event_flags): New enum.
+ (struct android_touch_event): New field `flags'.
+
+ * src/androidterm.c (handle_one_android_event): Report
+ cancellation in TOUCHSCREEN_END_EVENTs.
+
+ * src/keyboard.c (make_lispy_event): Fix botched merge.
+
+2023-07-17 Po Lu <luangruo@yahoo.com>
+
+ * doc/lispref/commands.texi (Touchscreen Events): Document meaning
+ of `mouse-1-menu-command'.
+
+ * lisp/mouse.el (minor-mode-menu-from-indicator): New arg EVENT.
+ Give it to popup-menu.
+ (mouse-minor-mode-menu): Use posn specified within EVENT.
+
+ * lisp/touch-screen.el (touch-screen-handle-touch): Fix
+ interactive translation. Treat commands labeled
+ `mouse-1-menu-command' like ordinary keymaps.
+
+ * doc/lispref/commands.texi (Touchscreen Events): Document
+ changes to simple translation.
+
+ * lisp/touch-screen.el (touch-screen-handle-point-up): Generate
+ `down-mouse-1' if the current gesture is `mouse-1-menu'.
+ (touch-screen-handle-touch): If binding is a keymap, set state to
+ `mouse-1-menu' and wait for point to be released before generating
+ down-mouse-1.
+
+ * lisp/tab-bar.el (tab-bar-map): Don't bind touch-screen-drag.
+
+ * lisp/touch-screen.el (touch-screen-drag): Extend the region
+ based on the position of the mark, not the position of point
+ relative to EVENT.
+ (touch-screen-translate-touch): Don't generate virtual function
+ keys for non-mouse events.
+ (function-key-map): Remove redundant definitions.
+
+ * src/keyboard.c (read_key_sequence): Don't generate *-bar prefix
+ keys for mock input (such as input from function key translation.)
+
+ * doc/emacs/input.texi (Touchscreens): Document the new feature
+ for people who have trouble dragging to word boundaries.
+
+ * lisp/touch-screen.el (touch-screen-word-select): New defcustom.
+ (touch-screen-word-select-bounds)
+ (touch-screen-word-select-initial-word): New variable
+ definitions.
+ (touch-screen-hold): If `touch-screen-word-select', select the
+ word around EVENT.
+ (touch-screen-drag): If `touch-screen-word-select', extend the
+ region to the next word boundary if the character under point
+ constitutes a word.
+ (touch-screen-handle-point-update, touch-screen-handle-touch)
+ (touch-screen-translate-touch): Fix doc strings and fill
+ comments.
+
+2023-07-16 Po Lu <luangruo@yahoo.com>
+
+ * java/org/gnu/emacs/EmacsService.java (displayToast):
+ * src/android.c (android_init_emacs_service): Remove unused
+ function.
+
+ * lisp/touch-screen.el (touch-screen-handle-point-up): Correctly
+ compute posn point.
+ (touch-screen-translate-touch): Update doc string.
+ (function-key-map): Define touch screen translation functions
+ within the internal border.
+
+ * doc/lispref/commands.texi (Touchscreen Events): Improve
+ documentation.
+
+ * lisp/tab-bar.el (tab-bar-map): Bind `[tab-bar
+ touchscreen-hold]'.
+
+ * lisp/touch-screen.el (touch-screen-hold, touch-screen-drag):
+ New functions.
+ (touch-screen-handle-timeout): Generate a `touchscreen-hold'
+ event instead.
+ (touch-screen-handle-point-update): Generate a
+ `touchscreen-drag' event upon dragging.
+ (touch-screen-translate-touch): Cancel touch screen timer upon
+ exit.
+
+ * src/keyboard.c (access_keymap_keyremap): Take unsigned int
+ start and end instead.
+
+ * doc/emacs/emacs.texi (Top):
+ * doc/emacs/input.texi (Other Input Devices): Correctly
+ capitalize subsection name.
+ (Touchscreens): Document additional translation.
+
+ * doc/lispref/commands.texi (Touchscreen Events): Document that
+ `touchscreen-end' events now have prefix keys. Also, describe
+ mouse emulation and `touchscreen-scroll' events.
+
+ * doc/lispref/keymaps.texi (Translation Keymaps): Document
+ `current-key-remap-sequence'.
+
+ * lisp/touch-screen.el (touch-screen-translate-prompt): New
+ function.
+ (touch-screen-scroll): New command. Bind to `touchscreen-scroll'.
+ (touch-screen-handle-point-update, touch-screen-handle-point-up)
+ (touch-screen-handle-touch): Refactor to actually translate touch
+ screen event sequences, as opposed to looking up commands and
+ executing them.
+ (touch-screen-translate-touch): New function. Bind in
+ function-key-map to all touch screen events.
+ (touch-screen-drag-mode-line-1, touch-screen-drag-mode-line)
+ (touch-screen-tap-header-line): Remove special commands for
+ dragging the mode line and clicking on the header line.
+
+ * lisp/wid-edit.el (widget-button-click): Adjust accordingly.
+
+ * src/keyboard.c (access_keymap_keyremap): Bind
+ `current-key-remap-sequence' to the key sequence being remapped.
+ (keyremap_step): Give fkey->start and fkey->end to
+ access_keymap_keyremap.
+ (head_table): Add imaginary prefix to touchscreen-end events as
+ well.
+ (syms_of_keyboard): New variable Vcurrent_key_remap_sequence.
+
+2023-07-15 Po Lu <luangruo@yahoo.com>
+
+ * doc/emacs/android.texi (Android): Add new node to menu.
+ (Android Environment): Add footnote pointing to new node.
+ (Android Software): New node.
+
+ * doc/emacs/emacs.texi (Top): Add new node to menu.
+
+ * java/AndroidManifest.xml.in (manifest): Fix location of
+ sharedUserId property.
+
+ * java/INSTALL: Improve documentation of shared user ID
+ support.
+
+2023-07-14 Po Lu <luangruo@yahoo.com>
+
+ * configure.ac (ANDROID_SHARED_USER_NAME): New variable.
+ Substitute it.
+
+ * java/AndroidManifest.xml.in: Set `sharedUserLabel' if a shared
+ user ID is enabled.
+
+ * java/res/values/strings.xml (shared_user_name): New string
+ resource.
+
+ * src/android.c (android_blit_copy): Don't check for overflow
+ where not required.
+
+ * java/org/gnu/emacs/EmacsInputConnection.java
+ (getSurroundingText): Don't print debug information if DEBUG_IC is
+ off.
+
+ * lisp/calc/calc.el (calc): Fix typo.
+
+2023-07-13 Po Lu <luangruo@yahoo.com>
+
+ * etc/NEWS: Announce the new tool bar.
+
+ * etc/images/last-page.xpm:
+ * etc/images/last-page.pbm: New images. Mirrored from
+ next-page.xpm.
+
+ * lisp/doc-view.el (doc-view-menu): Use `doc-view-new-search'
+ instead of an anonymous function.
+ (doc-view-tool-bar-map): New keymap.
+ (doc-view-search): Update the tool bar after initiating a search.
+ (doc-view-new-search): New command.
+ (doc-view-mode): Set the tool bar map appropriately.
+
+ Restore hardware acceleration, as a small degree of tearing is
+ preferable towards large slowdowns on some specific devices. The
+ slight tearing remains, but a workaround for the GPU texture
+ remaining partially updated has been introduced.
+
+ * java/AndroidManifest.xml.in:
+ * java/org/gnu/emacs/EmacsDialog.java (toAlertDialog): Don't
+ change hardware acceleration state.
+
+ * java/org/gnu/emacs/EmacsNative.java (notifyPixelsChanged): New
+ function.
+
+ * java/org/gnu/emacs/EmacsSurfaceView.java (EmacsSurfaceView):
+ New field `bitmapChanged'.
+ (copyToFrontBuffer): Signal that the bitmap has changed.
+ (onDraw): If the bitmap has changed, increment the generation ID.
+
+ * src/android.c (JNICALL): Implement new function.
+
+2023-07-13 Po Lu <luangruo@yahoo.com>
+
+ Disable hardware acceleration on Android. It serves no purpose
+ and causes tearing. Uploading the bitmap to the GPU takes about
+ as long as it does to incrementally update the surface in
+ software.
+
+ * java/AndroidManifest.xml.in: Disable hardware acceleration.
+
+ * java/org/gnu/emacs/EmacsActivity.java (EmacsActivity): Make
+ lastClosedMenu static.
+
+ * java/org/gnu/emacs/EmacsDialog.java (toAlertDialog): Enable
+ hardware acceleration within alert dialogs.
+
+ * java/org/gnu/emacs/EmacsSurfaceView.java (onDraw): Describe
+ why hardware acceleration is disabled.
+
+ * java/org/gnu/emacs/EmacsWindow.java (run): Remove redundant
+ call.
+
+2023-07-12 Po Lu <luangruo@yahoo.com>
+
+ * src/android.c (android_run_select_thread): Fix typo.
+
+ * src/android.c (android_run_select_thread): Correctly return the
+ set of ready read and write descriptors on __ANDROID_API__ < 16
+ systems.
+ (android_select): Clear the set of ready file descriptors if
+ events from the event queue are present despite pselect failing.
+
+ * src/androidterm.c (android_android_to_emacs_modifiers)
+ (android_emacs_to_android_modifiers): Fix statement precedence
+ bugs.
+
+ * src/doc.c (doc_close): Remove unused macro.
+
+ * java/org/gnu/emacs/EmacsWindow.java (whatButtonWasIt): Handle
+ back and forward buttons along with styluses.
+
+ * src/doc.c (close_file_unwind_android_fd): New function.
+ (get_doc_string, Fsnarf_documentation): Don't create a temporary
+ fd if it can be avoided.
+
+2023-07-11 Po Lu <luangruo@yahoo.com>
+
+ * .gitignore: Ignore cross/etc/DOC.
+
+ * configure.ac: Make the directory `cross/etc'.
+
+ * cross/Makefile.in (CLEAN_SUBDIRS): Clean files inside `etc' as
+ well.
+
+ * java/Makefile.in (install_temp): Copy cross/etc/DOC to the
+ package if it is available.
+
+ * src/Makefile.in (SOME_MACHINE_OBJECTS): Add androidselect.c,
+ sfntfont-android.c and sfntfont.c.
+ (libemacs.so): Depend on $(etc)/DOC.
+
+ * src/sfnt.c (sfnt_fill_span): Correctly clip span to raster
+ width, ensuring that the last pixel is filled.
+ (main): Adjust test sizes.
+
+ * java/org/gnu/emacs/EmacsView.java (onGenericMotionEvent): Call
+ onGenericMotionEvent.
+
+ * java/org/gnu/emacs/EmacsWindow.java (Coordinate): New fields
+ `button' and `id'.
+ (<init>): Add new arguments to the constructor.
+ (whatButtonWasIt): Return 0 if the button state has not changed.
+ (buttonForEvent): New function.
+ (figureChange): Return the Coordinate object associated to EVENT.
+ Determine whether or not EVENT was accompanied by a change to the
+ button state, and ascertain which button that was.
+ (motionEvent): New function.
+ (onGenericMotionEvent, onTouchEvent): Factor out touch and mouse
+ event delivery to motionEvent.
+
+2023-07-10 Po Lu <luangruo@yahoo.com>
+
+ * java/org/gnu/emacs/EmacsService.java (browseUrl): New argument
+ SEND. Choose from a list of applications that want to share the
+ URL if true.
+
+ * lisp/net/browse-url.el (browse-url-android-share): New user
+ option.
+ (browse-url-default-android-browser): Respect said user option.
+
+ * src/android.c (android_init_emacs_service, android_browse_url):
+ Expose new option.
+
+ * src/android.h: Update prototypes.
+
+ * src/androidselect.c (Fandroid_browse_url): Likewise.
+
+ * lib/vasnprintf.c:
+ * m4/printf.m4:
+ * m4/vasnprintf.m4: Update from Gnulib.
+
+2023-07-09 Po Lu <luangruo@yahoo.com>
+
+ * java/org/gnu/emacs/EmacsWindow.java (eventModifiers)
+ (motionEventModifiers): New functions.
+ (onKeyDown, onKeyUp, onFocusChanged, onSomeKindOfMotionEvent):
+ Don't record the previous modifier mask; instead, always use the
+ modifier state specified in the event.
+
+ * src/androidterm.c (handle_one_android_event): Don't dispatch
+ button release events when a popup is active.
+
+ * java/org/gnu/emacs/EmacsService.java (onStartCommand): Fix typo
+ in notification message.
+ * java/org/gnu/emacs/EmacsWindow.java (onFocusChanged): Reset the
+ recorded modifier state upon a change to the window focus.
+
+ * java/org/gnu/emacs/EmacsService.java (onCreate): Fix typo.
+
+ * java/org/gnu/emacs/EmacsDrawPoint.java (perform): Don't fill an
+ extra pixel.
+ * java/org/gnu/emacs/EmacsService.java (onCreate): Make sure
+ scaledDensity is always at least 160 dpi.
+
+2023-07-08 Po Lu <luangruo@yahoo.com>
+
+ * java/org/gnu/emacs/EmacsDrawLine.java (perform): Symmetrically
+ adjust coordinates to cover the last pixel. Then, fill the left
+ most pixel of the line.
+
+ * java/org/gnu/emacs/EmacsService.java (DEBUG_IC)
+ (DEBUG_THREADS): Improve commentary.
+
+ * src/androidterm.c (handle_one_android_event): Signal completion
+ of IME events that have lost their frames.
+ (requestCursorUpdates): Don't set an edit counter as this event
+ won't be passed to the text conversion machinery.
+
+ * src/android.c (android_blit_xor, android_check_query_urgent)
+ (android_run_in_emacs_thread, android_update_extracted_text): Fix
+ whitespace.
+
+2023-07-07 Po Lu <luangruo@yahoo.com>
+
+ * java/org/gnu/emacs/EmacsSurfaceView.java (copyToFrontBuffer):
+ Use fallback bit blit function on Android 7.0 as well, as crashes
+ have been observed in drawBitmap.
+
+2023-07-07 Po Lu <luangruo@yahoo.com>
+
+ * lisp/tool-bar.el (modifier-bar-modifier-list): New variable.
+ (modifier-bar-button): New function.
+ (tool-bar-event-apply-alt-modifier)
+ (tool-bar-event-apply-super-modifier)
+ (tool-bar-event-apply-hyper-modifier)
+ (tool-bar-event-apply-shift-modifier)
+ (tool-bar-event-apply-control-modifier)
+ (tool-bar-event-apply-meta-modifier): Factor out modifier bar
+ logic to that function, and redisplay the tool bar where
+ necessary.
+ (modifier-bar-available-p): New function.
+ (modifier-bar-mode): Disable tool bar items corresponding to
+ modifier keys that've already been pressed.
+
+ * etc/images/shift.pbm: Regenerate using the same font as the
+ other modifier button bitmaps.
+
+2023-07-06 Po Lu <luangruo@yahoo.com>
+
+ * java/org/gnu/emacs/EmacsNative.java (scaledDensity): Announce
+ new argument `scaledDensity'.
+
+ * java/org/gnu/emacs/EmacsNoninteractive.java (main): Specify new
+ argument.
+
+ * java/org/gnu/emacs/EmacsService.java (onCreate): Compute an
+ adjusted DPI for the font size based on the ratio between density
+ and scaledDensity.
+ (run): Specify that adjusted density.
+
+ * src/android.c (setEmacsParams): Set
+ `android_scaled_pixel_density'.
+
+ * src/android.h (android_scaled_pixel_density) New variable.
+
+ * src/androidterm.c (android_term_init): Set `font_resolution'.
+
+ * src/androidterm.h (struct android_display_info): New field.
+
+ * src/font.c (font_pixel_size, font_find_for_lface)
+ (font_open_for_lface, Ffont_face_attributes, Fopen_font): Use
+ FRAME_RES instead of FRAME_RES_Y.
+
+ * src/frame.h (FRAME_RES): New macro. Use this to convert between
+ font point and pixel sizes as opposed to FRAME_RES_Y.
+
+ * src/w32font.c (fill_in_logfont):
+ * src/xfaces.c (Fx_family_fonts, set_lface_from_font): Use
+ FRAME_RES instead of FRAME_RES_Y. (bug#64444)
+
+2023-07-05 Po Lu <luangruo@yahoo.com>
+
+ * doc/emacs/android.texi (Android Environment): Document that
+ Emacs also receives READ_EXTERNAL_STORAGE by default on old
+ versions of Android.
+ * java/AndroidManifest.xml.in: Request READ_EXTERNAL_STORAGE.
+ (bug#64445)
+
+ * doc/emacs/emacs.texi (Emacs and Android): Fix menu.
+
+ * doc/emacs/android.texi (Android): Fix discrepancies between menu
+ and sectioning.
+
+ * java/org/gnu/emacs/EmacsService.java (detectMouse): Don't use
+ function that is not present on Android 4.0.
+
+ * doc/lispref/commands.texi (Misc Events): Correctly index
+ `set-text-conversion-style'.
+
+ * lisp/tool-bar.el (tool-bar-event-apply-alt-modifier)
+ (tool-bar-event-apply-super-modifier)
+ (tool-bar-event-apply-hyper-modifier)
+ (tool-bar-event-apply-shift-modifier)
+ (tool-bar-event-apply-control-modifier)
+ (tool-bar-event-apply-meta-modifier): Pass t when restoring text
+ conversion style.
+
+ * src/keyboard.c (restore_reading_key_sequence): New function.
+ (read_key_sequence): Set `reading_key_sequence' where necessary.
+
+ * src/keyboard.h: Declare variable.
+
+ * src/textconv.c (check_postponed_buffers): New function.
+ (Fset_text_conversion_style): New argument. If set, and a key
+ sequence is being read, postpone resetting the IME until the key
+ sequence is read.
+ (syms_of_textconv): Clear new variable and add staticpro.
+
+ * src/textconv.h: Update prototypes.
+
+2023-07-04 Po Lu <luangruo@yahoo.com>
+
+ * doc/emacs/frames.texi (Tool Bars): Describe modifier bars.
+
+ * doc/lispref/keymaps.texi (Extended Menu Items, Tool Bar):
+ Document changes to tool bar menu item handling and secondary tool
+ bars.
+
+ * etc/NEWS: Announce changes.
+
+ * lisp/simple.el (event-apply-modifier): Correctly apply Ctrl and
+ Shift modifiers to lower case ASCII key events that already have
+ other modifiers applied.
+
+ * lisp/tool-bar.el (tool-bar--cache-key)
+ (tool-bar--secondary-cache-key): New defsubsts.
+ (tool-bar--flush-cache): Flush secondary tool bar cache.
+ (tool-bar-make-keymap): Include secondary tool bar if necessary.
+ (tool-bar-make-keymap-1): New arg MAP. Generate a keymap for that
+ map if specified, else default to tool-bar-map.
+ (set-text-conversion-style, tool-bar-apply-modifiers)
+ (overriding-text-conversion-style)
+ (tool-bar-event-apply-alt-modifier)
+ (tool-bar-event-apply-super-modifier)
+ (tool-bar-event-apply-hyper-modifier)
+ (tool-bar-event-apply-shift-modifier)
+ (tool-bar-event-apply-control-modifier)
+ (tool-bar-event-apply-meta-modifier, modifier-bar-mode): New
+ functions.
+
+ * src/dispextern.h (enum tool_bar_item_idx): Add
+ TOOL_BAR_ITEM_WRAP.
+
+ * src/frame.c (make_frame): Clear new field `tool_bar_wraps_p'.
+
+ * src/frame.h (struct frame): New field `tool_bar_wraps_p'.
+
+ * src/keyboard.c (parse_tool_bar_item): Handle QCwrap properties
+ in tool bar menu items.
+ (syms_of_keyboard): New defsym QCwrap.
+
+ * src/xdisp.c (build_desired_tool_bar_string): Clear
+ f->tool_bar_wraps_p and set it appropriately. Insert new line
+ characters in the tool bar string upon encountering a wrap
+ character.
+ (display_tool_bar_line): Stop at EOB, not line end. Reseat on the
+ next line upon encountering EOL characters.
+ (redisplay_tool_bar): Allow rows to be different heights if
+ explicit new lines are present upon the tool bar string.
+
+ * src/sfnt.c (sfnt_decompose_compound_glyph): Pacify warning.
+
+2023-06-30 Po Lu <luangruo@yahoo.com>
+
+ * src/android.c (android_query_tree): Correctly return children.
+
+2023-06-27 Po Lu <luangruo@yahoo.com>
+
+ * doc/emacs/android.texi (Android Environment): Improve wording.
+
+ * doc/emacs/android.texi (Android Environment): Fix typos.
+
+ * src/android.c (android_exception_check)
+ (android_exception_check_1)
+ (android_exception_check_2)
+ (android_exception_check_nonnull)
+ (android_exception_check_nonnull_1): Tell the compiler to expect
+ that the object is non-NULL, or that no exception has been thrown.
+
+ * exec/loader-mips64el.s (rest_of_exec): Fix typo in comment.
+
+2023-06-26 Po Lu <luangruo@yahoo.com>
+
+ * doc/lispref/commands.texi (Touchscreen Events): Fix typo.
+
+2023-06-26 Po Lu <luangruo@yahoo.com>
+
+ * lisp/calc/calc.el (calc-mode, calc): Make sure the on-screen
+ keyboard is not hidden when a Calc buffer is created or a Calc
+ Trail window is being created for the first time.
+
+ * lisp/touch-screen.el (touch-screen-window-selection-changed):
+ Take touch-screen-display-keyboard in to account.
+
+ * src/sfnt.c (sfnt_decompose_compound_glyph)
+ (sfnt_interpret_compound_glyph_1): Reset `defer_offsets' before
+ processing each component.
+ (sfnt_lerp_half): Avoid undefined shift of negative value.
+ (sfnt_compute_tuple_scale): Pacify compiler warning.
+
+2023-06-23 Po Lu <luangruo@yahoo.com>
+
+ * java/org/gnu/emacs/EmacsDrawRectangle.java (perform):
+ * java/org/gnu/emacs/EmacsSdk7FontDriver.java (Sdk7FontEntity):
+ (hasChar): Clean up dead stores.
+
+ * src/android.c (android_wc_lookup_string): Fix typo.
+ (android_wc_lookup_string): Check that GetStringChars returns
+ non-NULL, not if it throws an exception.
+
+2023-06-21 Po Lu <luangruo@yahoo.com>
+
+ * src/androidfns.c (android_set_tool_bar_position)
+ (frame_geometry):
+ * src/androidterm.c (android_flash)
+ (android_clear_under_internal_border): Synchronize with X.
+
+2023-06-20 Po Lu <luangruo@yahoo.com>
+
+ * src/androidfns.c (android_frame_parm_handlers): Fix typo.
+ (android_set_tool_bar_position): New function.
+ (android_frame_parm_handlers): Add new frame param handler.
+
+2023-06-19 Po Lu <luangruo@yahoo.com>
+
+ * lib-src/Makefile.in (seccomp-filter$(EXEEXT)): Link with Gnulib.
+
+ * java/org/gnu/emacs/EmacsView.java (EmacsView, dimensionsLock):
+ New field.
+ (<init>): Create new lock object.
+ (handleDirtyBitmap, onLayout, onAttachedToWindow): Make sure
+ measuredWidth and measuredHeight are extracted and set atomically.
+ Send Expose upon layout changes if the view has grown.
+
+ * exec/Makefile.in (clean): Add `exec1'.
+
+2023-06-18 Po Lu <luangruo@yahoo.com>
+
+ * src/window.h (struct window): Improve documentation of
+ `last_mark'.
+
+ * src/xdisp.c (mark_window_display_accurate_1): Don't set
+ `last_mark' to -1 if the mark is inactive.
+
+ * lisp/textmodes/conf-mode.el (conf-mode-initialize): Set
+ text-conversion-style.
+
+2023-06-17 Po Lu <luangruo@yahoo.com>
+
+ * java/org/gnu/emacs/EmacsService.java (onCreate, run): Don't
+ initialize signal mask here.
+
+ * java/org/gnu/emacs/EmacsApplication.java (onCreate): Do it
+ here instead.
+
+ * src/android.c (JNICALL): Restore previous signal masks.
+
+ * java/README: More documentation.
+
+2023-06-16 Po Lu <luangruo@yahoo.com>
+
+ * src/android.c (android_write_event, JNICALL)
+ (android_run_in_emacs_thread): Don't rely on raise to call
+ deliver_process_signal.
+
+ * java/org/gnu/emacs/EmacsActivity.java (EmacsActivity):
+ * java/org/gnu/emacs/EmacsApplication.java (findDumpFile):
+ * java/org/gnu/emacs/EmacsContextMenu.java (EmacsContextMenu)
+ (addSubmenu, display):
+ * java/org/gnu/emacs/EmacsDocumentsProvider.java
+ (getNotificationUri, queryChildDocuments, deleteDocument):
+ * java/org/gnu/emacs/EmacsDrawRectangle.java (perform):
+ * java/org/gnu/emacs/EmacsFillRectangle.java (perform):
+ * java/org/gnu/emacs/EmacsOpenActivity.java (readEmacsClientLog)
+ (checkReadableOrCopy):
+ * java/org/gnu/emacs/EmacsSdk7FontDriver.java
+ (EmacsSdk7FontDriver):
+ * java/org/gnu/emacs/EmacsSurfaceView.java (EmacsSurfaceView):
+ * java/org/gnu/emacs/EmacsView.java (EmacsView):
+ * java/org/gnu/emacs/EmacsWindow.java (EmacsWindow, onKeyUp):
+ * java/org/gnu/emacs/EmacsWindowAttachmentManager.java
+ (EmacsWindowAttachmentManager): Remove various unused arguments
+ and variables, dead stores, and make minor cleanups and
+ performance improvements.
+
+ * src/androidmenu.c (FIND_METHOD_STATIC, android_menu_show):
+ Adjust accordingly.
+
+2023-06-15 Po Lu <luangruo@yahoo.com>
+
+ * java/org/gnu/emacs/EmacsInputConnection.java
+ (EmacsInputConnection, beginBatchEdit, reset, endBatchEdit): Keep
+ track of the number of batch edits and return an appropriate
+ value.
+ (takeSnapshot): Implement function.
+
+ * java/org/gnu/emacs/EmacsNative.java (takeSnapshot): New
+ function.
+
+ * java/org/gnu/emacs/EmacsService.java (resetIC): Improve
+ debugging output.
+
+ * java/org/gnu/emacs/EmacsView.java (onCreateInputConnection):
+ Call `reset' to clear the UI side batch edit count.
+
+ * src/androidterm.c (struct android_get_surrounding_text_context):
+ New fields `conversion_start' and `conversion_end'.
+ (android_get_surrounding_text): Return the conversion region.
+ (android_get_surrounding_text_internal, NATIVE_NAME): Factor out
+ `getSurroundingText'.
+ (takeSnapshot): New function.
+
+2023-06-14 Po Lu <luangruo@yahoo.com>
+
+ * java/org/gnu/emacs/EmacsInputConnection.java
+ (EmacsInputConnection): Reimplement as an InputConnection, not
+ BaseInputConnection.
+
+ * src/androidterm.c (performEditorAction): Sync prior to sending
+ keyboard events.
+
+2023-06-13 Po Lu <luangruo@yahoo.com>
+
+ * etc/NEWS: Fix typo.
+
+ * lisp/gnus/gnus-score.el (gnus-read-char): New function.
+ (gnus-summary-increase-score): Use it to display a dialog box on
+ Android, where input methods have trouble with plain old
+ read-char.
+
+2023-06-12 Po Lu <luangruo@yahoo.com>
+
+ * java/org/gnu/emacs/EmacsDialog.java (toAlertDialog): Resolve
+ dialog button style and use it instead.
+
+ * java/org/gnu/emacs/EmacsView.java (EmacsView)
+ (showOnScreenKeyboard, hideOnScreenKeyboard): Don't synchronize.
+
+ * java/org/gnu/emacs/EmacsWindow.java (EmacsWindow)
+ (toggleOnScreenKeyboard): Revert to calling IMM functions from the
+ main thread.
+
+ * src/android.c (struct android_event_container)
+ (android_pselect_nfds, android_pselect_readfds)
+ (android_pselect_writefds, android_pselect_exceptfds)
+ (android_pselect_timeout): Don't make volatile.
+ (android_wait_event): Run queries if necessary.
+
+2023-06-11 Po Lu <luangruo@yahoo.com>
+
+ * lisp/net/tramp.el (tramp-encoding-shell):
+ * lisp/obsolete/terminal.el (terminal-emulator):
+ * lisp/term.el (term-exec-1):
+ * lisp/textmodes/artist.el (artist-figlet-get-font-list):
+ * src/android.c (JNICALL): Where /bin/sh was previously used, use
+ /system/bin/sh on Android.
+
+ * java/org/gnu/emacs/EmacsSurfaceView.java (EmacsSurfaceView):
+ Document member variables.
+ (onDraw): Use separate Paint object on the UI thread.
+
+ * src/textconv.c (really_commit_text, really_set_composing_text)
+ (really_delete_surrounding_text): Run modification hooks when
+ deleting text.
+
+ * java/org/gnu/emacs/EmacsView.java (EmacsView)
+ (showOnScreenKeyboard, hideOnScreenKeyboard)
+ (onCheckIsTextEditor): Make synchronized.
+
+ * java/org/gnu/emacs/EmacsWindow.java (EmacsWindow)
+ (toggleOnScreenKeyboard): Don't post to the main thread.
+
+2023-06-10 Po Lu <luangruo@yahoo.com>
+
+ * src/keyboard.c (handle_input_available_signal): Don't generate
+ instructions not available in arm mode.
+
+ * src/android.c (android_select, android_check_query)
+ (android_check_query_urgent, android_answer_query)
+ (android_answer_query_spin, android_begin_query)
+ (android_end_query)
+ (android_run_in_emacs_thread): Use finer grained memory
+ synchronization semantics.
+
+ * src/androidterm.c (android_get_selection): Use the current
+ selection, not its value at the time of the last redisplay.
+
+ * src/keyboard.c (handle_input_available_signal): Place memory
+ barrier.
+
+ * src/textconv.c (really_commit_text)
+ (really_set_composing_text): Improve behavior of certain
+ fontification mechanisms by inheriting text properties from
+ surrounding text.
+
+ * src/android.c (android_select): Clear `android_urgent_query'.
+ (android_check_query): Make static. Clear `android_urgent_query'.
+ (android_check_query_urgent): New function; work like
+ `android_check_query', but only answer urgent queries.
+ (android_answer_query, android_end_query): Clear urgent query
+ flag.
+ (android_run_in_emacs_thread): Initially wait two seconds for the
+ query to run from the keyboard loop; upon a timeout, set
+ `android_urgent_query' to true and wait for it to run while
+ reading async input.
+
+ * src/android.h: Update prototypes.
+
+ * src/keyboard.c (handle_async_input): Call
+ `android_check_query_urgent'.
+
+2023-06-09 Po Lu <luangruo@yahoo.com>
+
+ * src/textconv.c (really_commit_text)
+ (handle_pending_conversion_events): Fix minor typos.
+
+ * src/androidterm.c (handle_one_android_event): Don't answer
+ queries here; just rely on the event interrupting android_select.
+ This avoids exposing buffer contents to input methods while a
+ command is being executed.
+
+ * src/textconv.c (TEXTCONV_DEBUG, really_commit_text)
+ (really_finish_composing_text, really_set_composing_text)
+ (really_set_composing_region, really_delete_surrounding_text)
+ (really_set_point_and_mark, get_extracted_text): Add debugging
+ printouts.
+
+ * lisp/progmodes/cc-mode.el (c-initialize-cc-mode): Always add
+ text conversion hooks.
+
+ * src/android.c (android_get_gc_values): Remove redundancy.
+
+ * java/org/gnu/emacs/EmacsNative.java (EmacsNative): New
+ function `setupSystemThread'.
+
+ * java/org/gnu/emacs/EmacsService.java (onCreate): Block all
+ signals except for SIGBUS and SIGSEGV in the UI thread.
+
+ * src/android.c (setupSystemThread): New function.
+
+ * java/org/gnu/emacs/EmacsThread.java (run): Correct check
+ against extraStartupArgument when an initial file is specified.
+
+2023-06-08 Po Lu <luangruo@yahoo.com>
+
+ * java/org/gnu/emacs/EmacsContextMenu.java (EmacsContextMenu):
+ Make subclasses final.
+
+ * java/org/gnu/emacs/EmacsDialog.java (display1): Check if an
+ instance of EmacsOpenActivity is open; if it is, try using it to
+ display the pop up dialog.
+
+ * java/org/gnu/emacs/EmacsDialogButtonLayout.java
+ (EmacsDialogButtonLayout): Make final.
+
+ * java/org/gnu/emacs/EmacsHolder.java (EmacsHolder<T>): Likewise.
+
+ * java/org/gnu/emacs/EmacsOpenActivity.java (EmacsOpenActivity):
+ New field `currentActivity'.
+ (onCreate, onDestroy, onWindowFocusChanged, onPause): Set that
+ field as appropriate.
+
+ * src/android.c (android_is_special_directory): New function.
+ (android_get_asset_name, android_content_name_p)
+ (android_get_content_name):
+ * src/android.h (android_is_special_directory)
+ (JNI_STACK_ALIGNMENT_PROLOGUE):
+ * src/fileio.c (check_mutable_filename):
+ * src/filelock.c (WTMP_FILE, make_lock_file_name):
+ * src/inotify.c (IN_ONLYDIR, Finotify_add_watch): Factor out
+ checks against asset and content directories to that function.
+
+2023-06-07 Po Lu <luangruo@yahoo.com>
+
+ * doc/emacs/android.texi (Android Startup): Fix reference to non
+ existent node.
+
+ * java/org/gnu/emacs/EmacsInputConnection.java (beginBatchEdit)
+ (endBatchEdit, commitCompletion, commitText)
+ (deleteSurroundingText)
+ (finishComposingText, getSelectedText, getTextAfterCursor)
+ (getTextBeforeCursor, setComposingText, setComposingRegion)
+ (performEditorAction, performContextMenuAction, getExtractedText)
+ (setSelection, sendKeyEvent, deleteSurroundingTextInCodePoints)
+ (requestCursorUpdates): Ensure that the input connection is up to
+ date.
+ (getSurroundingText): New function.
+
+ * java/org/gnu/emacs/EmacsNative.java (getSurroundingText): Export
+ new C function.
+
+ * java/org/gnu/emacs/EmacsService.java (resetIC): Invalidate
+ previously created input connections.
+
+ * java/org/gnu/emacs/EmacsView.java (EmacsView)
+ (onCreateInputConnection): Signify that input connections are
+ now up to date.
+
+ * src/androidterm.c (struct android_get_surrounding_text_context):
+ New structure.
+ (android_get_surrounding_text, NATIVE_NAME):
+ * src/textconv.c (get_surrounding_text):
+ * src/textconv.h: New functions.
+
+2023-06-06 Po Lu <luangruo@yahoo.com>
+
+ * lisp/simple.el (analyze-text-conversion): Remove old workaround.
+
+2023-06-06 Po Lu <luangruo@yahoo.com>
+
+ * java/org/gnu/emacs/EmacsContextMenu.java (display): Use
+ `EmacsHolder' instead of `Holder'.
+
+ * java/org/gnu/emacs/EmacsDialog.java (toAlertDialog): Use
+ `EmacsDialogButtonLayout' to ensure that buttons are wrapped
+ properly.
+ (display): Adjust for new holder class.
+
+ * java/org/gnu/emacs/EmacsDialogButtonLayout.java
+ (EmacsDialogButtonLayout, onMeasure, onLayout): New functions.
+
+ * java/org/gnu/emacs/EmacsDrawLine.java:
+ * java/org/gnu/emacs/EmacsFillPolygon.java: Remove redundant
+ imports.
+
+ * java/org/gnu/emacs/EmacsHolder.java (EmacsHolder<T>):
+ * java/org/gnu/emacs/EmacsService.java (class Holder<T>)
+ (getEmacsView, EmacsService): Rename `Holder' to `EmacsHolder'
+ and make it public.
+
+2023-06-06 Po Lu <luangruo@yahoo.com>
+
+ * lisp/simple.el (undo-auto-amalgamate): Update doc string to
+ describe new amalgamating commands.
+ (analyze-text-conversion): Make this an amalgamating command by
+ default, unless a new line has been inserted. Also, shorten the
+ undo boundary timer.
+
+ * src/textconv.c (really_commit_text)
+ (really_set_composing_text): Correctly report ephemeral deletions.
+ (syms_of_textconv): Fix doc strings.
+
+2023-06-05 Po Lu <luangruo@yahoo.com>
+
+ * src/androidterm.c (android_handle_ime_event): Clear batch edit
+ state, in case the previous input method forgot to do so.
+
+ * java/org/gnu/emacs/EmacsNative.java (EmacsNative): New
+ function clearInputFlags.
+
+ * java/org/gnu/emacs/EmacsView.java (onCreateInputConnection):
+ Stop reporting changes after a new input method connection is
+ established.
+
+ * src/androidterm.c (android_handle_ime_event): Implement that
+ change.
+ (JNICALL): New function.
+
+2023-06-04 Po Lu <luangruo@yahoo.com>
+
+ * src/keyboard.c: Fix build without window system
+
+ * configure.ac: Tune pty detection for Android.
+
+ * java/debug.sh (gdbserver_cmd, is_root): Prefer TCP again.
+
+ * java/org/gnu/emacs/EmacsNative.java (EmacsNative): New function
+ `queryAndSpin'.
+
+ * java/org/gnu/emacs/EmacsService.java (EmacsService)
+ (icBeginSynchronous, icEndSynchronous, viewGetSelection): New
+ synchronization functions.
+ (resetIC, updateCursorAnchorInfo): Call those instead.
+
+ * java/org/gnu/emacs/EmacsView.java (onCreateInputConnection):
+ Call viewGetSelection.
+
+ * src/android.c (JNICALL, android_answer_query_spin): New
+ functions.
+
+2023-06-03 Po Lu <luangruo@yahoo.com>
+
+ * lisp/bindings.el (global-map): Bind cut, copy and paste.
+
+ * src/androidterm.c (JNICALL): Use key.
+
+ * src/textconv.c (really_commit_text)
+ (really_set_composing_text): Delete text between mark and point if
+ the mark is active. Don't record changes if the text is empty.
+
+ * src/androidterm.c (struct android_get_extracted_text_context):
+ New field `mark_active'.
+ (android_get_extracted_text): Set that field.
+ (struct android_extracted_text_class): New field `flags'.
+ (android_build_extracted_text): New argument `mark_active'. Set
+ flags appropriately.
+ (NATIVE_NAME, android_update_selection): Likewise.
+
+ * src/textconv.c (get_extracted_text): New argument
+ `mark_active'. Set it if the mark is active.
+
+ * src/textconv.h: Update prototypes.
+
+ * etc/MACHINES: Fix reference to obsolete file.
+
+2023-06-02 Po Lu <luangruo@yahoo.com>
+
+ * lisp/emacs-lisp/eldoc.el ("back-to-indentation"): Register touch
+ screen and text conversion commands.
+
+ * lisp/progmodes/cc-cmds.el (c-post-text-conversion): New
+ function.
+
+ * lisp/progmodes/cc-mode.el (c-initialize-cc-mode): Add it as the
+ `post-texxt-conversion-hook'.
+
+ * lisp/simple.el (post-text-conversion-hook): New hook.
+ (analyze-text-conversion): Run it until success before trying post
+ insert functions.
+
+ * java/org/gnu/emacs/EmacsInputConnection.java
+ (EmacsInputConnection): Apply workarounds on Vivo devices as well.
+
+ * src/android.c (sendKeyPress, sendKeyRelease): Clear counter.
+
+ * src/androidgui.h (struct android_key_event): New field
+ `counter'.
+
+ * src/androidterm.c (handle_one_android_event): Generate barriers
+ as appropriate.
+ (JNICALL): Set `counter'.
+
+ * src/frame.h (enum text_conversion_operation):
+ * src/textconv.c (detect_conversion_events)
+ (really_set_composing_text, handle_pending_conversion_events_1)
+ (handle_pending_conversion_events, textconv_barrier):
+ * src/textconv.h: Implement text conversion barriers and fix
+ various typos.
+
+2023-06-01 Po Lu <luangruo@yahoo.com>
+
+ * java/org/gnu/emacs/EmacsService.java (browseUrl): If uri's
+ scheme is `file', rewrite it into a content URI.
+
+ * java/org/gnu/emacs/EmacsInputConnection.java
+ (EmacsInputConnection, performContextMenuAction): New function.
+
+ * java/org/gnu/emacs/EmacsNative.java (EmacsNative)
+ (performContextMenuAction): New function.
+
+ * src/android.c (android_get_gc_values): Implement more
+ efficiently.
+
+ * src/androidterm.c (android_handle_ime_event): Pass through
+ `update' argument to `finish_composing_text'. Fix thinko.
+
+ * src/textconv.c (really_finish_composing_text)
+ (really_set_composing_text, really_set_composing_region)
+ (handle_pending_conversion_events_1, finish_composing_text): New
+ argument `update'. Notify IME of conversion region changes if
+ set.
+
+ * src/textconv.h: Update structs and prototypes.
+
+ * java/org/gnu/emacs/EmacsInputConnection.java
+ (EmacsInputConnection): Add compatibility adjustments for Samsung
+ devices.
+
+ * src/androidterm.c (struct android_get_extracted_text_context):
+ New field `start_offset' and `end_offset'. Delete `offset'.
+ (android_get_extracted_text, android_build_extracted_text):
+ Replace `offset' with new args `start_offset' and `end_offset'.
+ (NATIVE_NAME): Set `start_offset' and `end_offset'.
+ (android_update_selection): Likewise.
+
+ * src/textconv.c (get_extracted_text): Likewise.
+
+ * src/textconv.h: Update prototypes.
+
+2023-05-31 Po Lu <luangruo@yahoo.com>
+
+ * configure.ac: Pass through `--enable-check-lisp-object-type' on
+ Android.
+
+ * src/alloc.c (android_make_lisp_symbol):
+ * src/android.c:
+ * src/androidfns.c (android_set_no_focus_on_map)
+ (android_set_no_accept_focus):
+ * src/androidfont.c (androidfont_match, androidfont_open_font):
+ * src/androidselect.c (Fandroid_get_clipboard)
+ (Fandroid_get_clipboard_targets):
+ * src/keyboard.c (make_lispy_event, syms_of_keyboard):
+ * src/sfntfont.c (sfnt_enum_font_1, sfntfont_list_1):
+ * src/textconv.c (really_set_point_and_mark): Fix Lisp_Object and
+ integer screw-ups.
+
+ * doc/emacs/input.texi (Other Input Devices, Touchscreens)
+ (On-Screen Keyboards):
+ * doc/lispref/commands.texi (Misc Events):
+ * src/android.c (android_faccessat): Improve word choices and
+ commentary.
+
+ * lisp/touch-screen.el (touch-screen-handle-scroll): Make
+ precision scrolling work better with horizontal movement.
+
+ * src/android.c (android_copy_area): Pacify compiler warning.
+
+ * exec/exec.c (insert_args): New argument `arg3'. Replace argv[1]
+ with that argument.
+ (exec_0): Pass file name of script to `insert_args'.
+
+ * doc/emacs/android.texi (What is Android?, Android Startup)
+ (Android File System, Android Environment, Android Windowing)
+ (Android Troubleshooting): Improve wording and various other
+ issues.
+
+ * java/debug.sh (is_root): Go back to using unix sockets; allow
+ adb to forward them correctly.
+
+ * java/org/gnu/emacs/EmacsInputConnection.java
+ (getExtractedText): Don't print text if NULL.
+
+ * java/org/gnu/emacs/EmacsService.java (EmacsService): New field
+ `imSyncInProgress'.
+ (updateIC): If an IM sync might be in progress, avoid deadlocks.
+
+ * java/org/gnu/emacs/EmacsView.java (onCreateInputConnection):
+ Set `imSyncInProgress' across synchronization point.
+
+ * src/android.c (android_check_query): Use __atomic_store_n.
+ (android_answer_query): New function.
+ (android_begin_query): Set `android_servicing_query' to 2. Check
+ once, and don't spin waiting for query to complete.
+ (android_end_query): Use __atomic_store_n.
+ (android_run_in_emacs_thread): Compare-and-exchange flag. If
+ originally 1, fail.
+
+ * src/textconv.c (really_set_composing_text): Clear conversion
+ region if text is empty.
+
+2023-05-29 Po Lu <luangruo@yahoo.com>
+
+ * src/android.c (android_blit_copy, android_blit_xor): Fix typos.
+
+ * java/org/gnu/emacs/EmacsNative.java (EmacsNative): New function
+ `blitRect'.
+
+ * java/org/gnu/emacs/EmacsSurfaceView.java (EmacsSurfaceView): Use
+ it on Android 8.x.
+
+ * src/android.c (blitRect): Implement new function.
+ (android_neon_mask_line): Fix iteration over remainder.
+ (android_blit_copy): Be more paranoid.
+
+ * java/org/gnu/emacs/EmacsCopyArea.java: Remove file.
+
+ * java/org/gnu/emacs/EmacsService.java (copyArea): Delete
+ function.
+
+ * src/android.c (struct android_emacs_service)
+ (android_init_emacs_service): Remove `copy_area'.
+ (android_create_gc, android_change_gc, android_get_gc_values):
+ Record new GC values.
+ (android_neon_mask_line): New function.
+ (android_blit_copy, android_blit_xor): New functions.
+ (android_copy_area): Implement in C.
+ (android_lock_bitmap): Accept drawables instead of windows.
+
+ * src/android.h: Adjust prototype for `android_lock_bitmap'.
+
+ * src/androidgui.h (struct android_gc): Record last known GC
+ values.
+
+2023-05-27 Po Lu <luangruo@yahoo.com>
+
+ * java/org/gnu/emacs/EmacsService.java (EmacsService)
+ (checkEmacsThread): New function.
+ (fillPolygon, drawRectangle, drawLine, drawPoint, copyArea)
+ (clearArea):
+ * java/org/gnu/emacs/EmacsThread.java (EmacsThread):
+ * java/org/gnu/emacs/EmacsView.java (EmacsView, swapBuffers): Call
+ where appropriate.
+
+ * java/org/gnu/emacs/EmacsView.java (EmacsView, swapBuffers):
+ Remove unnecessary documentation. `damageRegion' is only changed
+ from the Emacs thread.
+
+2023-05-26 Po Lu <luangruo@yahoo.com>
+
+ * doc/emacs/android.texi (Android Troubleshooting): Document
+ `debug-init' option.
+
+ * java/AndroidManifest.xml.in
+ (EmacsLauncherPreferencesActivity): New activity. Export on
+ systems older than Android 7.0.
+
+ * java/org/gnu/emacs/EmacsActivity.java (onCreate): Adjust for
+ string startup argument.
+
+ * java/org/gnu/emacs/EmacsLauncherPreferencesActivity.java: New
+ file.
+
+ * java/org/gnu/emacs/EmacsPreferencesActivity.java
+ (EmacsPreferencesActivity): Don't make final.
+ (startEmacsQ): Give start-up argument as an argument, not as a
+ boolean.
+ (startEmacsDebugInit): New function.
+ (onCreate): Register new listener; make final.
+
+ * java/org/gnu/emacs/EmacsService.java (onCreate): Pass
+ extraStartupArgument.
+
+ * java/org/gnu/emacs/EmacsThread.java (EmacsThread): Rename
+ startDashQ to extraStartupArgument.
+ (run): Adjust accordingly.
+
+ * java/res/values-v24/bool.xml:
+ * java/res/values/bool.xml:
+ * java/res/values/strings.xml: New files.
+
+ * java/res/xml/preferences.xml: Add new option. Move string
+ resources around.
+
+2023-05-24 Po Lu <luangruo@yahoo.com>
+
+ * src/sfnt.c (sfnt_decompose_compound_glyph): Allow decomposing up
+ to 16 nested components.
+ (CALL, LOOPCALL): Correctly error if no fdef storage exists.
+ (sfnt_interpret_run): New label `next_instruction', for CALL.
+ (sfnt_interpret_compound_glyph_1): Allow decomposing up to 16
+ nested components. Prevent crash if there are no end points or
+ points.
+ (sfnt_read_cvar_table): Prevent assigning uninitialized values.
+ (sfnt_vary_simple_glyph): Update commentary.
+
+2023-05-23 Po Lu <luangruo@yahoo.com>
+
+ * exec/exec.c (exec_0): Use strcpy.
+
+2023-05-20 Po Lu <luangruo@yahoo.com>
+
+ * exec/trace.c (handle_clone_prepare, handle_clone): When
+ !REENTRANT, use malloc to allocate tracees after running out of
+ static ones.
+
+ * java/org/gnu/emacs/EmacsView.java (swapBuffers): Restore missing
+ damage rect code.
+ (onDetachedFromWindow): Remove redundant synchronization.
+
+2023-05-19 Po Lu <luangruo@yahoo.com>
+
+ * lisp/touch-screen.el (touch-screen-tap-header-line): New
+ function.
+ ([header-line touchscreen-begin]): Define to
+ `touch-screen-tap-header-line'.
+
+2023-05-18 Po Lu <luangruo@yahoo.com>
+
+ * make-dist (possibly_non_vc_files): Add Android-specific files.
+
+ * doc/emacs/frames.texi (Tab Bars): Explain how to interact with
+ the tab bar from a touch screen.
+
+ * doc/emacs/input.texi (Touchscreens): Document exactly what a
+ ``long press'' is.
+
+ * doc/emacs/windows.texi (Tab Line): Likewise.
+
+ * lisp/tab-line.el (tab-line-tab-map, tab-line-add-map)
+ (tab-line-tab-close-map, tab-line-left-map, tab-line-right-map):
+ Bind `touchscreen-begin' to each command.
+ (tab-line-track-tap, tab-line-event-start): New functions.
+ (tab-line-hscroll-right, tab-line-hscroll-left, tab-line-new-tab)
+ (tab-line-select-tab, tab-line-close-tab): Use them.
+
+2023-05-16 Po Lu <luangruo@yahoo.com>
+
+ * lisp/menu-bar.el (popup-menu-normalize-position): Normalize
+ `touchscreen-begin' events correctly.
+
+ * lisp/tab-bar.el (tab-bar-mouse-context-menu): New argument POSN.
+ Use it if specified.
+ (touch-screen-track-tap, tab-bar-handle-timeout)
+ (tab-bar-touchscreen-begin): New functions.
+ (tab-bar-map): Bind [tab-bar touchscreen-begin].
+
+ * lisp/touch-screen.el (touch-screen-track-drag): Fix doc
+ string.
+
+ * src/dispextern.h: Export `get_tab_bar_item_kbd'.
+
+ * src/keyboard.c (coords_in_tab_bar_window): New function.
+ (make_lispy_event): Adjust touchscreen begin event mouse
+ position list for tab bar.
+
+ * src/xdisp.c (tab_bar_item_info): Allow CLOSE_P to be NULL.
+ (get_tab_bar_item): Adjust doc string.
+ (get_tab_bar_item_kbd): New function.
+
+2023-05-15 Po Lu <luangruo@yahoo.com>
+
+ * configure.ac: Also disable enable_year2038.
+
+ * msdos/sed1v2.inp: Fix removal of ANDROID_BUILD_CFLAGS.
+ * msdos/sedlibmk.inp: Clear DIR_HAS_FD_MEMBER and LOCALE_FR_UTF8.
+
+2023-05-14 Po Lu <luangruo@yahoo.com>
+
+ * java/org/gnu/emacs/EmacsDocumentsProvider.java
+ (notifyChangeByName): New function.
+ (queryDocument1): Set FLAG_SUPPORTS_MOVE where necessary.
+ (moveDocument): Implement new function.
+
+2023-05-08 Po Lu <luangruo@yahoo.com>
+
+ * java/Makefile.in (install_temp/assets/version): Fix generation
+ in out of tree builds.
+
+2023-05-07 Po Lu <luangruo@yahoo.com>
+
+ * java/org/gnu/emacs/EmacsInputConnection.java
+ (requestCursorUpdates):
+ * java/org/gnu/emacs/EmacsNative.java (requestCursorUpdates):
+ * java/org/gnu/emacs/EmacsService.java (updateCursorAnchorInfo):
+ New functions.
+
+ * src/android.c (struct android_emacs_service)
+ (android_init_emacs_service): Add new method.
+ (android_update_cursor_anchor_info): New function.
+
+ * src/androidfns.c (android_set_preeditarea): New function.
+
+ * src/androidgui.h (enum android_ime_operation): New operation
+ `REQUEST_CURSOR_UPDATES'.
+ (struct android_ime_event): Document new meaning of `length'.
+
+ * src/androidterm.c (android_request_cursor_updates): New
+ function.
+ (android_handle_ime_event): Handle new operations.
+ (handle_one_android_event, android_draw_window_cursor): Update
+ the preedit area if needed, like on X.
+ (requestCursorUpdates): New function.
+
+ * src/androidterm.h (struct android_output): New field
+ `need_cursor_updates'.
+
+2023-05-06 Po Lu <luangruo@yahoo.com>
+
+ * configure.ac (LIBGMP_CFLAGS): Avoid non portable test
+ expression.
+
+ * cross/verbose.mk.android (AM_V_CC): Get rid of badly aligned
+ ANDROID_CC messages.
+
+ * java/org/gnu/emacs/EmacsInputConnection.java (syncAfterCommit)
+ (extractAbsoluteOffsets): Add workarounds for several kinds of
+ machines.
+ (commitText, getExtractedText): Likewise.
+
+ * src/textconv.c (really_commit_text): Improve definition of
+ POSITION.
+ (get_extracted_text): Default to providing at least 4 characters.
+
+2023-05-05 Po Lu <luangruo@yahoo.com>
+
+ * exec/exec.h (struct exec_tracee): New field `new_child'. Also
+ make `waiting_for_syscall' a bitfield.
+
+ * exec/trace.c (PTRACE_GETEVENTMSG): New declaration.
+ (MAX_TRACEES): Bump to 4096.
+ (handle_clone_prepare): New function.
+ (handle_clone): If required, set `new_child' and wait for a ptrace
+ event describing the parent to arrive.
+ (after_fork): Clear new field.
+ (exec_waitpid): Upon a ptrace event describing a clone, create the
+ child's tracee if it doesn't already exist. Otherwise, copy over
+ the parent's cmdline and start running it.
+
+ * doc/emacs/android.texi (Android Environment): Document lossage
+ with SIGSTOP.
+
+ * exec/exec.c (exec_0): Check X_OK on file being opened. Also
+ handle /proc/self/exe.
+
+ * exec/trace.c (SYS_SECCOMP): Define when not present.
+
+2023-05-04 Po Lu <luangruo@yahoo.com>
+
+ * doc/emacs/android.texi (Android Environment): Describe how to
+ turn off process killing.
+
+ * exec/trace.c (check_signal): New function.
+ (handle_exec, process_system_call): Handle signal-delivery-stop
+ while waiting synchronously for syscall completion.
+
+2023-05-03 Po Lu <luangruo@yahoo.com>
+
+ * exec/config.h.in: Update from new automatically generated
+ headers.
+
+ * exec/configure.ac: Check for siginfo_t.si_syscall.
+
+ * exec/trace.c (exec_waitpid): If SIGSYS is received, and caused
+ by seccomp, drop it should the call number be the invalid system
+ call used by Emacs.
+
+ * exec/configure.ac: Use system extensions.
+ (HAVE_PROCESS_VM): Define if process_vm_readv and
+ process_vm_writev are available.
+
+ * exec/trace.c (read_memory, user_copy): Implement in terms of
+ process_vm if possible.
+
+ * exec/loader-mipsel.s (__start): Remove extraneous debugging
+ code.
+
+ * exec/Makefile.in: (.PHONY): Add `bootstrap-clean' and
+ `extraclean'.
+ (bootstrap-clean): New rule.
+
+ * java/Makefile.in (FIND_DELETE): New substitution.
+ (clean): Use FIND_DELETE.
+
+2023-05-02 Po Lu <luangruo@yahoo.com>
+
+ * doc/emacs/android.texi (Android Environment): Improve doc.
+
+ * exec/config.h.in (__bool_true_false_are_defined):
+ * exec/configure.ac (REENTRANT): New definitions.
+ (READLINKAT_SYSCALL, READLINK_SYSCALL): New defines. Set on all
+ hosts.
+
+ * exec/exec.c (MIN, MAX): Remove redundant declarations. Move to
+ config.h.
+ (exec_0): Copy name of executable into NAME when !REENTRANT.
+
+ * exec/exec.h (struct exec_tracee): New struct `exec_file'.
+
+ * exec/trace.c (remove_tracee, handle_exec, handle_readlinkat)
+ (process_system_call, after_fork): Handle readlinkat system calls.
+
+ * exec/Makefile.in (.SUFFIXES): Include ., then `srcdir'.
+
+ * exec/loader-aarch64.s (_start):
+ * exec/loader-armeabi.s (_start):
+ * exec/loader-mips64el.s (__start):
+ * exec/loader-mipsel.s (__start):
+ * exec/loader-x86.s (_start):
+ * exec/loader-x86_64.s (_start): Get basename of opened exec file
+ and make it the command name. Fix envp skipping on x86 and
+ various leaks.
+
+ * exec/configure.ac: Check for declarations of stpcpy and stpncpy.
+
+ * exec/exec.c (stpcpy, stpncpy): Use replacements if declarations
+ are not present; this happens when a new Android NDK is building
+ for an old version of Android.
+
+2023-05-01 Po Lu <luangruo@yahoo.com>
+
+ * exec/config.h.in: Update config.h.in.
+
+ * exec/configure.ac: Check for stpcpy and stpncpy.
+
+ * exec/exec.c (rpl_stpcpy, rpl_stpncpy): Define replacements when
+ they are not present on the system.
+ (process_program_header): Fill comment.
+
+ * src/term.c (syms_of_term): Pretend Android uses TERMINFO.
+
+ * exec/exec.c (format_pid): New function.
+ (exec_0): Make cwd relative file names relative to /proc/pid/cwd.
+
+ * exec/trace.c (handle_exec): Handle EINTR.
+
+ (process_system_call): Report failure without clobbering x0.
+
+ * README: Describe `exec' directory.
+
+ * lisp/subr.el (use-dialog-box-p): Always prefer dialog boxes.
+
+ * src/android.c (android_write_event, JNICALL): Raise SIGIO on key
+ press and window action events.
+
+ * exec/trace.c (process_system_call): Save and restore x0, x1 and
+ x2 regs after replacing them with an invalid file descriptor.
+
+ * Makefile.in (extraclean): Clean in exec as well.
+
+ * configure.ac: Fix detection of absolute srcdir. Also, pass
+ CFLAGS.
+
+ * exec/Makefile.in: (.c.o): Add -I. so config.h can be found.
+ (.s.o): Don't create m4 temporary in srcdir.
+
+ * exec/config-mips.m4.in (DADDI2, DADDI3): New macros. Define to
+ substitute if as cannot assemble daddi.
+
+ * exec/configure.ac (user_h): Look for user.h in asm/ as well.
+ Use new user.h. Also look in ptrace.h on arm systems. Check if
+ as supports daddi on mips64.
+
+ * exec/exec.c (check_interpreter): Fix char signedness bug.
+
+ * exec/loader-mips64el.s (__start): Use DADDI2 and DADDI3 for two-
+ and 3-operand daddi.
+
+ * exec/mipsel-user.h: Don't include sgidefs.h.
+
+ * java/INSTALL: Document that m4 is now required.
+
+ * src/android.c (android_rewrite_spawn_argv): Add missing NULL.
+
+ * doc/emacs/android.texi (Android Environment): Document
+ `android-use-exec-loader'.
+
+ * exec/exec1.c (main): Set program group of child process.
+
+ * src/android.c (android_rewrite_spawn_argv): New function.
+
+ * src/android.h: Update prototypes.
+
+ * src/androidfns.c (syms_of_androidfns): New variable
+ `android_use_exec_loader'.
+
+ * src/callproc.c (emacs_spawn): Rewrite the argument vector to use
+ exec1 if necessary.
+
+ * .gitignore: Add exec/configure.
+
+2023-04-30 Po Lu <luangruo@yahoo.com>
+
+ * .gitignore: New files.
+
+ * Makefile.in (mostlyclean_dirs): Add libexec, if its Makefile
+ exists.
+
+ * autogen.sh (do_git): Autoreconf in exec as well.
+
+ * configure.ac: Configure libexec on Android.
+
+ * exec/Makefile.in:
+ * exec/README:
+ * exec/config-mips.m4.in:
+ * exec/config.guess:
+ * exec/config.h.in:
+ * exec/config.sub:
+ * exec/configure:
+ * exec/configure.ac:
+ * exec/deps.mk:
+ * exec/exec.c (MIN, struct exec_open_command)
+ (struct exec_map_command, struct exec_jump_command)
+ (write_open_command, write_load_command, process_interpreter_1)
+ (process_interpreter, process_program_header, insert_args)
+ (exec_0):
+ * exec/exec.h (_EXEC_H_, struct elf_header_32)
+ (struct program_header_32, struct dt_entry_32)
+ (struct elf_header_64, struct program_header_64)
+ (struct dt_entry_64, struct exec_tracee):
+ * exec/exec1.c (main):
+ * exec/install-sh (scriptversion):
+ * exec/loader-aarch64.s (_start):
+ * exec/loader-armeabi.s (_start):
+ * exec/loader-mips64el.s (__start):
+ * exec/loader-mipsel.s (__start):
+ * exec/loader-x86.s (_start):
+ * exec/loader-x86_64.s (_start):
+ * exec/mipsel-user.h (_MIPSEL_USER_H_):
+ * exec/mipsfpu.c (MIPS_ABI_FP_ANY, fpu_reqs, valid_abi_p)
+ (fp_mode_for_abi, cpu_supports_fr0_p, determine_fpu_mode):
+ * exec/mipsfpu.h (_MIPSFPU_H_, FP_FR0):
+ * exec/test.c (print_usage, main):
+ * exec/trace.c (MAX_TRACEES, aarch64_set_regs, read_memory)
+ (user_alloca, user_copy, remove_tracee, handle_clone)
+ (syscall_trap_p, handle_exec, process_system_call, tracing_execve)
+ (after_fork, find_tracee, exec_waitpid, exec_init): New files.
+ * java/Makefile.in (CROSS_EXEC_BINS): Add exec1 and loader.
+ ($(CROSS_EXEC_BINS) &): New target.
+
+2023-04-29 Po Lu <luangruo@yahoo.com>
+
+ * build-aux/ndk-build-helper.mk (TARGET_ARCH): Define variable.
+
+ * configure.ac (ENABLE_CHECKING, CHECK_STRUCTS)
+ (GC_CHECK_STRING_OVERRUN, GC_CHECK_STRING_FREE_LIST, GLYPH_DEBUG)
+ (GC_CHECK_STRING_BYTES): Enable checking correctly on Android.
+
+ * java/README: Fix typos.
+
+ * m4/ndk-build.m4 (ndk_run_test): Pass target arch.
+
+ * src/android.c (android_get_content_name, android_close)
+ (android_fclose, android_check_string): Fix various typos caught
+ by checking.
+
+ * src/charset.c (load_charset_map_from_file): Call emacs_fclose,
+ not fclose.
+
+ * src/image.c (image_set_transform): Fix thinko.
+ (png_load_body, jpeg_load_body, gif_load): Call emacs_fclose, not
+ fclose. Use open instead of fdopen.
+
+ * src/xfaces.c (Fx_load_color_file): Likewise.
+
+2023-04-27 Po Lu <luangruo@yahoo.com>
+
+ * src/image.c (image_create_bitmap_from_data): Fix typo in
+ preprocessor conditionals.
+
+ * doc/emacs/android.texi (Android File System, Android Windowing):
+ Make Emacs manual more portable.
+
+ * doc/lispref/commands.texi (Misc Events):
+ * doc/lispref/frames.texi (Accessing Selections, X Selections):
+ Fix pieces of the Info manual.
+
+2023-04-26 Po Lu <luangruo@yahoo.com>
+
+ * lisp/play/doctor.el (text-conversion-style, doctor-mode):
+ * lisp/play/dunnet.el (text-conversion-style, dun-mode): Set
+ `text-conversion-style' to `action'.
+
+2023-04-13 Po Lu <luangruo@yahoo.com>
+
+ * doc/emacs/android.texi (Android Fonts): Update documentation.
+
+ * doc/lispref/frames.texi (Accessing Selections, X Selections):
+ Fix typos.
+
+ * src/sfntfont-android.c (system_font_directories)
+ (init_sfntfont_android): Add `/product/fonts'.
+
+2023-04-08 Po Lu <luangruo@yahoo.com>
+
+ * doc/lispref/elisp.texi (Top):
+ * doc/lispref/frames.texi (Frames): Add ``Accessing Selections''
+ to menu.
+ (Accessing Selections, X Selections, Other Selections): New nodes.
+
+2023-04-06 Po Lu <luangruo@yahoo.com>
+
+ * doc/emacs/android.texi (Android Windowing): Update selection
+ restrictions.
+
+ * java/org/gnu/emacs/EmacsClipboard.java (EmacsClipboard): New
+ functions `getClipboardTargets' and `getClipboardData'.
+
+ * java/org/gnu/emacs/EmacsSdk11Clipboard.java
+ (EmacsSdk11Clipboard, getClipboardTargets, getClipboardData):
+ Implement these virtual functions defined in EmacsClipboard.
+
+ * java/org/gnu/emacs/EmacsSdk8Clipboard.java: Stub out new
+ functions.
+
+ * lisp/term/android-win.el (android-get-clipboard-1): Implement
+ MIME type targets.
+
+ * src/android.c (android_exception_check)
+ (android_exception_check_1, android_exception_check_2): Fix
+ punctuation in warning message.
+ (android_exception_check_nonnull_1): New function.
+
+ * src/android.h: Update prototypes.
+
+ * src/androidselect.c (struct android_emacs_clipboard): New
+ methods.
+ (android_init_emacs_clipboard): Initialize new methods.
+ (Fandroid_get_clipboard_targets, android_xfree_inside)
+ (Fandroid_get_clipboard_data): New functions.
+ (syms_of_androidselect): Define new subrs.
+
+2023-04-04 Po Lu <luangruo@yahoo.com>
+
+ * lisp/subr.el (read-char-from-minibuffer): Don't use undefined
+ variable. Reported by Robert Pluim.
+
+2023-04-03 Po Lu <luangruo@yahoo.com>
+
+ * src/sfnt.c (sfnt_normalize_vector): Don't rely on undefined
+ sign extension semantics.
+
+2023-03-30 Po Lu <luangruo@yahoo.com>
+
+ * src/sfntfont.c: Adjust font cache size constants.
+
+ * src/sfnt.c (GETINFO): Fix typo.
+
+ * src/sfnt.h: Fix typo.
+
+ * src/sfnt.c (sfnt_make_interpreter): New argument `fvar'. Set
+ axis count.
+ (SCANCTRL): Implement selector bit 8.
+ (GXAXIS): New instruction.
+ (SFVTPV): Validate graphics state after changing freedom vector.
+ (sfnt_line_to_vector): Implement `original'.
+ (sfnt_move): Remove redundant division.
+ (sfnt_interpret_run): Implement distortable font related GXAXIS
+ instruction (0x91).
+ (sfnt_vary_interpreter): Set naxis and norm_coords.
+ (sfnt_make_test_interpreter, pushb_test_args, pushw_test_args)
+ (sfnt_name_instruction, main): Adjust accordingly.
+
+ * src/sfnt.h (struct sfnt_interpreter):
+ * src/sfntfont.c (sfntfont_setup_interpreter, sfntfont_open): Set
+ up distortion information.
+
+2023-03-29 Po Lu <luangruo@yahoo.com>
+
+ * doc/emacs/android.texi (Android Fonts): Document distortable
+ font replacement rules.
+
+ * src/sfntfont.c (sfnt_replace_fonts_p): New function.
+ (sfnt_enum_font_1): Call it.
+
+ * src/sfnt.c (sfnt_move_x, sfnt_move_y, sfnt_move): Set N flags
+ and don't forget to set N points too.
+ (sfnt_read_avar_table): Fix sequencing problem.
+
+ * src/sfntfont.c (sfntfont_setup_interpreter): Don't create
+ interpreter for blatantly broken fonts.
+ (sfntfont_open): Avoid specifying redundant blends.
+
+ * src/sfnt.c (sfnt_validate_gs): Fix validation of projection
+ vector.
+
+2023-03-28 Po Lu <luangruo@yahoo.com>
+
+ * src/sfnt.c (sfnt_vary_compound_glyph):
+ * src/sfntfont.c (sfntfont_get_glyph)
+ (sfntfont_get_glyph_outline): Avoid clobbering offset size flag
+ when varying compound glyph.
+
+ * src/sfnt.c (sfnt_vary_simple_glyph, sfnt_vary_compound_glyph):
+ Fix application of intermediate tuples.
+ * src/sfntfont.c (sfntfont_open): Set xlfd name after applying
+ distortion.
+
+ * src/sfnt.h (SFNT_ROUND_FIXED):
+ * src/sfntfont.c (sfntfont_probe_widths):
+ (sfntfont_measure_pcm): Round lbearing properly.
+ (sfnt_open_tables): Fix typos in non-HarfBuzz code.
+
+ * src/androidterm.c (android_draw_image_glyph_string): Restore
+ potentially clobbered GC clipping.
+
+ * src/sfnt.c (sfnt_large_integer_add, sfnt_multiply_divide_round)
+ (sfnt_mul_fixed_round): New functions.
+ (sfnt_build_glyph_outline): Take unscaled glyph metrics.
+ (sfnt_prepare_raster, sfnt_vary_simple_glyph)
+ (sfnt_vary_compound_glyph, sfnt_vary_interpreter): Use rounding
+ multiplication to scale deltas.
+ (main): Adjust tests.
+
+ * src/sfntfont.c (sfntfont_get_glyph_outline)
+ (sfntfont_probe_widths, sfntfont_open, sfntfont_measure_pcm)
+ (sfntfont_draw): More minor fixes to variable fonts.
+
+2023-03-27 Po Lu <luangruo@yahoo.com>
+
+ * src/sfnt.c (sfnt_normalize_blend): Don't crash when axis
+ variations are not present.
+
+ * configure.ac (HAVE_OTF_GET_VARIATION_GLYPHS): Check for
+ `hb_font_set_var_named_instance'.
+
+ * src/sfnt.c (main): Update tests.
+
+ * src/sfntfont-android.c (Fandroid_enumerate_fonts): Blacklist
+ bad font.
+
+ * src/sfntfont.c (struct sfnt_font_tables, struct sfnt_font_desc)
+ (sfnt_decode_instance_name, sfnt_weight_descriptions)
+ (sfnt_enum_font_1, sfntfont_list_1, sfntfont_desc_to_entity)
+ (sfntfont_list, struct sfntfont_get_glyph_outline_dcontext)
+ (sfntfont_get_glyph, sfntfont_get_glyph_outline)
+ (struct sfnt_font_info, sfnt_close_tables, sfnt_open_tables)
+ (sfntfont_open, sfntfont_measure_pcm, sfntfont_close)
+ (sfntfont_draw, sfntfont_begin_hb_font, syms_of_sfntfont)
+ (mark_sfntfont): Handle variable fonts correctly.
+
+ * src/sfnt.c (sfnt_build_glyph_outline): Take scale, not head
+ and pixel size.
+ (sfnt_scale_metrics_to_pixel_size): Delete function.
+ (sfnt_get_scale): New function.
+ (main): Update tests.
+
+ * src/sfnt.h: Update prototypes.
+
+ * src/sfntfont.c (struct sfnt_outline_cache)
+ (sfntfont_get_glyph_outline, struct sfnt_font_info)
+ (sfntfont_open): Save scale in font information and use it.
+ (sfntfont_measure_instructed_pcm): Delete function.
+ (sfntfont_measure_pcm): Make this the only ``measure pcm''
+ function.
+ (sfntfont_draw): Rely on sfntfont_get_glyph_outline for the scale.
+ (struct sfnt_font_tables): New structure.
+ (struct sfnt_font_desc): New field `tables'.
+ (struct sfnt_font_info): New field `desc'.
+ (sfntfont_setup_interpreter): Drop fd arguments and don't try to
+ load interpreter tables.
+ (sfnt_open_tables, sfnt_close_tables): New functions.
+ (sfnt_reference_font_tables, sfnt_dereference_font_tables): New
+ functions.
+ (sfntfont_open, sfntfont_close): Implement in terms of those
+ functions in order to share tables.
+
+2023-03-26 Po Lu <luangruo@yahoo.com>
+
+ * src/sfnt.c (sfnt_table_names): Add avar.
+ (sfnt_read_glyph): Clear distortion fields.
+ (sfnt_build_glyph_outline): Calculate the outline origin point.
+ (sfnt_prepare_raster): Apply the origin point to the X axis
+ offset.
+ (sfnt_scale_metrics_to_pixel_size): New function.
+ (sfnt_build_instructed_outline): Use instructed origin phantom
+ point to determine the outline origin.
+ (sfnt_compute_phantom_points): Apply origin and advance
+ distortion.
+ (struct sfnt_variation_axis, struct sfnt_instance)
+ (struct sfnt_fvar_table, sfnt_read_fvar_table)
+ (struct sfnt_gvar_table, sfnt_read_gvar_table)
+ (sfnt_read_avar_table, struct sfnt_blend, sfnt_init_blend)
+ (sfnt_free_blend, sfnt_normalize_blend, struct sfnt_tuple_header)
+ (struct sfnt_gvar_glyph_header, sfnt_read_packed_deltas)
+ (sfnt_compute_tuple_scale, sfnt_read_cvar_table)
+ (sfnt_infer_deltas_1, sfnt_vary_simple_glyph, sfnt_infer_deltas)
+ (sfnt_vary_glyph, sfnt_vary_compound_glyph)
+ (sfnt_vary_interpreter): New functions. Add structs to
+ sfntfont.h.
+ (struct sfnt_test_dcontext, sfnt_test_get_glyph, main): Test
+ distortable font handling.
+
+ * src/sfnt.h (SFNT_ENABLE_HINTING, enum sfnt_table)
+ (struct sfnt_glyph, struct sfnt_glyph_outline, struct sfnt_raster)
+ (struct sfnt_default_uvs_table, struct sfnt_unicode_value_range)
+ (struct sfnt_nondefault_uvs_table, struct sfnt_uvs_mapping)
+ (struct sfnt_mapped_variation_selector_record)
+ (struct sfnt_table_offset_rec, struct sfnt_uvs_context)
+ (struct sfnt_mapped_table, struct sfnt_variation_axis)
+ (struct sfnt_instance, struct sfnt_fvar_table)
+ (struct sfnt_short_frac_correspondence)
+ (struct sfnt_short_frac_segment, struct sfnt_avar_table)
+ (struct sfnt_tuple_variation, struct sfnt_cvar_table)
+ (struct sfnt_gvar_table, struct sfnt_blend)
+ (struct sfnt_metrics_distortion): Update prototypes.
+
+ * src/sfntfont.c (sfntfont_get_glyph_outline)
+ (sfntfont_measure_pcm): Adjust calls.
+
+2023-03-24 Po Lu <luangruo@yahoo.com>
+
+ * src/sfnt.c (sfnt_table_names): Add fvar, gvar, cvar.
+ (sfnt_read_maxp_table): Call xmalloc, not malloc.
+ (sfnt_read_simple_glyph): Avoid use-after-free if simple is
+ invalid.
+ (sfnt_fill_span): Fix max coverage.
+ (sfnt_normalize_vector): Fail if magnitude is zero.
+ (sfnt_measure_distance): Fix opcode order.
+ (sfnt_dot_fix_14): Fix implementation.
+ (struct sfnt_variation_axis, struct sfnt_instance)
+ (struct sfnt_fvar_table, struct sfnt_gvar_table)
+ (sfnt_read_fvar_table, sfnt_read_gvar_table, struct sfnt_blend)
+ (sfnt_init_blend, sfnt_free_blend, sfnt_normalize_blend)
+ (struct sfnt_tuple_header, struct sfnt_gvar_glyph_header)
+ (sfnt_read_packed_points, sfnt_read_packed_deltas)
+ (sfnt_compute_tuple_scale, sfnt_infer_deltas_1, sfnt_infer_deltas)
+ (sfnt_vary_glyph): Add WIP variation glyph implementation.
+
+ * src/sfnt.h (enum sfnt_table, struct sfnt_simple_glyph):
+ Likewise.
+
+2023-03-20 Po Lu <luangruo@yahoo.com>
+
+ * java/INSTALL: Fix typo.
+
+ * configure.ac: Add support for HarfBuzz on Android.
+
+ * java/INSTALL: Document where to get Emacs with HarfBuzz.
+
+ * lisp/subr.el (overriding-text-conversion-style, y-or-n-p):
+ Correctly set text conversion style if y-or-n-p is called inside
+ the minibuffer.
+
+ * src/sfnt.c (sfnt_read_cmap_format_8)
+ (sfnt_read_cmap_format_12): Fix typos.
+ (sfnt_read_24, sfnt_read_cmap_format_14): New function.
+ (sfnt_read_cmap_table_1, sfnt_read_cmap_table): Handle format 14
+ cmap tables.
+ (sfnt_read_default_uvs_table, sfnt_read_nondefault_uvs_table)
+ (sfnt_compare_table_offsets, sfnt_create_uvs_context)
+ (sfnt_free_uvs_context, sfnt_compare_uvs_mapping)
+ (sfnt_variation_glyph_for_char, sfnt_map_table, sfnt_unmap_table)
+ (sfnt_read_table, sfnt_test_uvs): New functions.
+ (main): Add UVS tests.
+
+ * src/sfnt.h (struct sfnt_cmap_format_14)
+ (struct sfnt_variation_selector_record)
+ (struct sfnt_default_uvs_table, struct sfnt_unicode_value_range)
+ (struct sfnt_nondefault_uvs_table, struct sfnt_uvs_mapping)
+ (struct sfnt_mapped_variation_selector_record)
+ (struct sfnt_table_offset_rec, struct sfnt_uvs_context)
+ (struct sfnt_mapped_table): New structures. Update prototypes.
+
+ * src/sfntfont-android.c (android_sfntfont_driver): Register
+ HarfBuzz callbacks where required.
+
+ * src/sfntfont.c (sfntfont_select_cmap): Look for a format 14
+ table. Save it in new arg FORMAT14.
+ (sfntfont_read_cmap): Adjust accordingly.
+ (struct sfnt_font_info): New field `uvs'. New fields `hb_font',
+ `fd' and `directory'.
+ (sfntfont_open): Open uvs context. Under HarfBuzz, don't close
+ the fd or subtable, but save them in the font info instead.
+ (sfntfont_close): Free UVS context. Close font fd and table
+ directory and HarfBuzz font.
+ (sfntfont_draw): Handle case where s->padding_p.
+ (sfntfont_get_variation_glyphs): New function.
+ (sfntfont_unmap_blob, sfntfont_get_font_table)
+ (sfntfont_begin_hb_font): New functions.
+
+ * src/sfntfont.h: Update prototypes.
+
+ * src/textconv.c (Fset_text_conversion_style): Fix doc string.
+
+2023-03-18 Po Lu <luangruo@yahoo.com>
+
+ * java/org/gnu/emacs/EmacsView.java (onAttachedToWindow): Send
+ measured width and height in exposures again.
+
+ * src/androidterm.c (handle_one_android_event): Don't log expose
+ events.
+
+ * src/android.c (android_run_select_thread): New flag. Use it
+ rather than the rc of pselect and errno to determine whether or
+ not it has been interrupted.
+ (android_handle_sigusr1): Set said flag.
+
+ * java/org/gnu/emacs/EmacsView.java (prepareForLayout): New
+ function. Call this prior to mapping the view.
+ (onGlobalLayout): New function. Register as global layout
+ listener.
+
+ * java/org/gnu/emacs/EmacsWindow.java (EmacsWindow)
+ (notifyContentRectPosition): New function. Use specified
+ xPosition and yPosition when reporting the offsets of children of
+ the root window.
+
+ * java/org/gnu/emacs/EmacsWindowAttachmentManager.java
+ (registerWindow): Specify activity launch bounds if necessary.
+
+ * src/androidterm.c (handle_one_android_event): Send
+ MOVE_FRAME_EVENT where necessary.
+
+2023-03-17 Po Lu <luangruo@yahoo.com>
+
+ * src/androidfns.c (Fx_server_vendor, Fx_server_version): New
+ functions.
+ (syms_of_androidfns): Define new functions.
+
+ * src/androidterm.c (android_set_build_fingerprint)
+ (syms_of_androidterm): Set new variable
+ Vandroid_build_manufacturer.
+
+ * src/xfns.c (Fx_server_vendor, Fx_server_version): Update doc
+ strings.
+
+ * src/fileio.c (emacs_fd_to_int): Don't define on WINDOWSNT.
+
+ * src/image.c (image_create_bitmap_from_data): Don't abort if
+ !defined HAVE_ANDROID.
+
+ * configure.ac:
+ * m4/ndk-build.m4 (ndk_INIT, ndk_LATE): Avoid AC_REQUIRE magic.
+
+ * java/org/gnu/emacs/EmacsContextMenu.java (EmacsContextMenu): New
+ field `lastGroupId'.
+ (Item): New field `isRadio'.
+ (addItem): New arg `isRadio'.
+ (inflateMenuItems): Apply an empty radio button group if required.
+
+ * src/androidmenu.c (android_init_emacs_context_menu): Adjust
+ accordingly.
+ (android_menu_show): Likewise.
+
+ * java/org/gnu/emacs/EmacsView.java (cancelPopupMenu): Dismiss
+ context menu correctly.
+ (isOpaque): New function.
+
+ * java/org/gnu/emacs/EmacsWindowAttachmentManager.java: Make
+ consumer list public.
+
+ * configure.ac: Add missing precious variable.
+
+2023-03-16 Po Lu <luangruo@yahoo.com>
+
+ * lisp/frame.el (android-detect-mouse):
+ * lisp/term/android-win.el (android-get-connection): Add function
+ declarations.
+
+ * configure.ac: Remove unnecessary escape.
+
+ * configure.ac (AUTO_DEPEND, ANDROID_STUBIFY, ANDROID_LDFLAGS):
+ * lib/Makefile.in (ANDROID_CFLAGS, ANDROID_BUILD_CFLAGS)
+ (ALL_CFLAGS):
+ * lib/gnulib.mk.in (AM_DEFAULT_VERBOSITY):
+ * msdos/sed1v2.inp:
+ * msdos/sedlibmk.inp:
+ * src/Makefile.in (ANDROID_OBJ, EMACS_CFLAGS): Make those
+ variables precious. Rename ANDROID_CFLAGS substitution to
+ ANDROID_BUILD_CFLAGS.
+
+ * nt/mingw-cfg.site: Suppress build of Gnulib printf.
+
+ * java/org/gnu/emacs/EmacsDocumentsProvider.java (queryRoots): Add
+ icon to document root.
+
+ * lisp/loadup.el (current-load-list): Set to empty load list after
+ startup.
+
+ * src/lread.c (build_load_history): Revert earlier changes.
+
+2023-03-15 Po Lu <luangruo@yahoo.com>
+
+ * configure.ac: Improve portability.
+
+2023-03-15 Robert Pluim <rpluim@gmail.com>
+
+ * src/fileio.c (Finsert_file_contents):
+ * src/window.c (replace_buffer_in_windows): Call Fboundp, not
+ boundp.
+
+2023-03-15 Po Lu <luangruo@yahoo.com>
+
+ * cross/Makefile.in (lib/gnulib.mk): Edit out build-aux stuff.
+ * m4/ndk-build.m4: Also look for cross ranlib.
+
+ * src/sfntfont.c (sfntfont_close): Fix warning w/o mmap.
+
+ * lib-src/asset-directory-tool.c (main_2): Port to systems without
+ htole32.
+
+2023-03-15 Po Lu <luangruo@yahoo.com>
+
+ * configure.ac (XCONFIGURE): Disable NS.
+
+ * cross/Makefile.in (lib-src/config.h, lib/libgnu.a)
+ (src/android-emacs): Port sed invocation to Mac OS without GNU
+ sed.
+
+2023-03-15 Po Lu <luangruo@yahoo.com>
+
+ * doc/lispref/commands.texi (Misc Events): Document variable
+ `disable-inhibit-text-conversion'.
+
+ * java/org/gnu/emacs/EmacsDialog.java (display1): Try an activity
+ that is certain to be focused first.
+
+ * lisp/touch-screen.el (touch-screen-track-tap)
+ (touch-screen-track-drag): Bind `disable-inhibit-text-conversion'.
+
+ * src/keyboard.c (read_key_sequence): Only disable text conversion
+ if an actual function or numeric key is found in the key sequence.
+ (syms_of_keyboard): New variable
+ `disable-inhibit-text-conversion'.
+
+ * src/lread.c (read_filtered_event): Check new variable.
+
+ * src/textconv.c (textconv_query): Remove unused label.
+
+ * nt/gnulib-cfg.mk: Omit new gnulib modules.
+
+2023-03-14 Po Lu <luangruo@yahoo.com>
+
+ * lisp/minibuffer.el (minibuffer-setup-on-screen-keyboard): Handle
+ cases where last-event-frame is a kbd macro.
+ * src/keyboard.c (lispy_function_keys): Remove duplicates.
+
+ * msdos/sed1v2.inp:
+ * msdos/sed3v2.inp:
+ * msdos/sedlibcf.inp:
+ * msdos/sedlibmk.inp: Update for Android port and new Gnulib
+ modules.
+
+ * java/org/gnu/emacs/EmacsWindow.java (figureChange): Detect mice
+ on up events as well.
+ (onSomeKindOfMotionEvent): Work past framework bug.
+
+ * src/androidterm.c (android_perform_conversion_query):
+ * src/textconv.c (textconv_query):
+ * src/textconv.h (TEXTCONV_SKIP_ACTIVE_REGION): Remove unused
+ code.
+
+ * doc/emacs/android.texi (Android Windowing): Document how to
+ display dialogs when Emacs is in the background.
+
+ * java/org/gnu/emacs/EmacsDialog.java (display1): Use system
+ dialogs if possible.
+
+2023-03-13 Po Lu <luangruo@yahoo.com>
+
+ * etc/NEWS: Announce new option.
+
+ * lisp/menu-bar.el (menu-bar-close-window): New option.
+ (kill-this-buffer, kill-this-buffer-enabled-p): Adjust
+ accordingly.
+
+ * src/keyboard.c (lispy_function_keys): Add more silly keys.
+
+ * src/android.c (android_check_string, android_build_string):
+ Reduce consing when building menu bar strings.
+
+ * etc/MACHINES (Android): Update with more recent information.
+
+ * doc/emacs/android.texi (Android Startup): Document changes to
+ emacsclient wrapper.
+
+ * java/org/gnu/emacs/EmacsOpenActivity.java (EmacsOpenActivity)
+ (startEmacsClient): Open EmacsActivity if the service is not
+ running.
+
+ * java/org/gnu/emacs/EmacsService.java (onCreate):
+ * java/org/gnu/emacs/EmacsThread.java (run): Pass any file to open
+ to Emacs.
+
+ * lisp/term/android-win.el (handle-args-function): Implement.
+
+ * src/image.c (image_create_bitmap_from_file, image_find_image_fd)
+ (close_android_fd, slurp_file): Return and use `struct
+ android_fd_or_asset' on Android.
+ (xbm_load, xpm_load, pbm_load, png_load_body, jpeg_load_body)
+ (webp_load, svg_load): Adjust accordingly.
+
+2023-03-12 Po Lu <luangruo@yahoo.com>
+
+ * src/android.c (android_get_screen_width)
+ (android_get_screen_height, android_get_mm_width)
+ (android_get_mm_height, android_detect_mouse): Correctly handle
+ Java exceptions.
+
+ * src/android.c (android_check_if_event): New function.
+
+ * src/androidgui.h: Update prototypes.
+
+ * src/androidterm.c (android_event_is_for_frame): New function.
+ (android_reset_conversion): Free and unqueue all text conversion
+ events for the given frame.
+
+ * src/androidterm.c (NATIVE_NAME, JNICALL)
+ (android_build_extracted_text, android_update_selection): Use
+ 0-based indices for Android buffer positions. Also, report
+ surrounding text relative to the region, not to the cursor.
+
+ * src/textconv.c (textconv_query): Accept new values of position.
+ (really_set_composing_text): Use ephemeral last point.
+
+ * java/org/gnu/emacs/EmacsOpenActivity.java (onCancel): New
+ function.
+ (displayFailureDialog): Handle dialog cancellation.
+
+ * src/sfntfont.c (sfnt_parse_languages): Look for SLNG tag if
+ DLNG is not present.
+
+ * src/androidgui.h (enum android_modifier_mask): New modifier
+ ANDROID_SUPER_MASK.
+
+ * src/androidterm.c (android_android_to_emacs_modifiers)
+ (android_emacs_to_android_modifiers): Add new modifier.
+
+ * src/androidterm.c (syms_of_androidterm): Initialize
+ Vandroid_build_fingerprint in case GC happens.
+
+ * src/emacs-module.c (module_reset_handlerlist): Fix macro
+ conflict.
+
+ * src/emacs-module.c (MODULE_HANDLE_NONLOCAL_EXIT)
+ (module_make_global_ref, module_free_global_ref)
+ (module_make_function, module_get_function_finalizer)
+ (module_set_function_finalizer, module_make_interactive)
+ (module_funcall, module_intern, module_type_of)
+ (module_extract_integer, module_make_integer, module_extract_float)
+ (module_make_float, module_copy_string_contents)
+ (module_make_string, module_make_unibyte_string)
+ (module_make_user_ptr, module_get_user_ptr, module_set_user_ptr)
+ (module_get_user_finalizer, module_set_user_finalizer)
+ (module_vec_set, module_vec_get, module_vec_size)
+ (module_process_input, module_extract_time, module_make_time)
+ (module_extract_big_integer, module_make_big_integer)
+ (module_open_channel, module_reset_handlerlist): Adjust as
+ recommended by Paul Eggert <eggert@cs.ucla.edu>.
+
+ * configure.ac: Take option `--with-shared-user-id' and give it to
+ AndroidManifest.xml.in.
+
+ * java/AndroidManifest.xml.in: Substitute that into the
+ application info.
+
+ * java/INSTALL (BUILDING WITH A SHARED USER ID): New section.
+
+2023-03-11 Po Lu <luangruo@yahoo.com>
+
+ * configure.ac (with_mailutils): Default to off on Android.
+ (HAVE_MAILUTILS, with_mailutils, ANDROID_SDK_8_OR_EARLIER)
+ (XCONFIGURE): Fix POP and mailutils configuration on Android.
+
+ * java/Makefile.in:
+ * src/callproc.c (syms_of_callproc): Avoid using built-in movemail
+ when --with-mailutils.
+
+ * src/android.c (android_resolve_handle)
+ (android_resolve_handle2): Don't perform checking done by CheckJNI
+ by default.
+ (android_copy_area): Check for errors here because CopyArea can
+ perform a lot of consing.
+ (android_define_cursor): Remove redundant code.
+
+ * java/org/gnu/emacs/EmacsActivity.java (onContextMenuClosed):
+ Process submenu closing normally if it happens more than 300 ms
+ after a submenu item was selected.
+
+ * java/org/gnu/emacs/EmacsContextMenu.java (EmacsContextMenu)
+ (onMenuItemClick, display1): Give `wasSubmenuSelected' different
+ values depending on how the submenu was selected.
+
+ * lib/gnulib.mk.in: Update from gnulib.
+
+ * configure.ac: Default modules to on. Remove check for
+ __attribute__((cleanup)). However, keep the new `ifavailable'
+ value for systems without dlopen.
+
+ * src/emacs-module.c (MODULE_HANDLE_NONLOCAL_EXIT): Don't rely on
+ cleanup attribute and correctly reset handlerlist upon longjmp.
+ (MODULE_INTERNAL_CLEANUP): New macro.
+ (module_make_global_ref, module_free_global_ref)
+ (module_make_function, module_get_function_finalizer)
+ (module_set_function_finalizer, module_make_interactive)
+ (module_funcall, module_intern, module_type_of)
+ (module_extract_integer, module_make_integer, module_extract_float)
+ (module_make_float, module_copy_string_contents)
+ (module_make_string, module_make_unibyte_string)
+ (module_make_user_ptr, module_get_user_ptr, module_set_user_ptr)
+ (module_get_user_finalizer, module_set_user_finalizer)
+ (module_vec_set, module_vec_get, module_vec_size)
+ (module_process_input, module_extract_time, module_make_time)
+ (module_extract_big_integer, module_make_big_integer)
+ (module_open_channel): Call MODULE_INTERNAL_CLEANUP prior to
+ returning.
+
+ * lisp/term/android-win.el (x-pointer-arrow, x-pointer-left-ptr)
+ (x-pointer-left-side, x-pointer-sb-h-double-arrow)
+ (x-pointer-sb-v-double-arrow, x-pointer-watch, x-pointer-xterm)
+ (x-pointer-invisible): New constants.
+
+ * src/androidterm.c (android_show_hourglass)
+ (android_hide_hourglass): New functions.
+ (android_toggle_visible_pointer, android_define_frame_cursor):
+ Define or don't define hourglass cursor if x->hourglass.
+ (android_redisplay_interface): Add new functions.
+
+ * src/androidterm.h (struct android_output): New field
+ `hourglass'.
+
+2023-03-10 Po Lu <luangruo@yahoo.com>
+
+ * doc/emacs/android.texi (Android Windowing): Document how to pass
+ multimedia keys to the system.
+
+ * java/org/gnu/emacs/EmacsNative.java
+ (shouldForwardMultimediaButtons): New function.
+
+ * java/org/gnu/emacs/EmacsView.java (onKeyDown, onKeyMultiple)
+ (onKeyUp): Check that function.
+
+ * java/org/gnu/emacs/EmacsWindow.java (defineCursor): Handle cases
+ where cursor is NULL.
+
+ * src/android.c (NATIVE_NAME): New function.
+
+ * src/androidfns.c (syms_of_androidfns): New variable.
+
+ * src/keyboard.c (lispy_function_keys): Add volume keys.
+
+ * java/org/gnu/emacs/EmacsCursor.java: New file.
+
+ * java/org/gnu/emacs/EmacsWindow.java (defineCursor): New
+ function.
+
+ * src/android.c (struct android_emacs_cursor): New struct.
+ (android_init_emacs_cursor): New function.
+ (initEmacs): Call it.
+ (android_create_font_cursor, android_define_cursor)
+ (android_free_cursor): New functions.
+
+ * src/android.h (enum android_handle_type): Add cursor handle
+ type.
+
+ * src/androidfns.c (Fx_create_frame, android_create_tip_frame)
+ (enum mouse_cursor, struct mouse_cursor_types, mouse_cursor_types)
+ (struct mouse_cursor_data, android_set_mouse_color)
+ (syms_of_androidfns):
+
+ * src/androidgui.h (enum android_cursor_shape):
+
+ * src/androidterm.c (make_invisible_cursor)
+ (android_toggle_invisible_pointer, android_free_frame_resources)
+ (android_define_frame_cursor):
+
+ * src/androidterm.h (struct android_display_info)
+ (struct android_output): Port mouse cursor code over from X.
+
+ * java/org/gnu/emacs/EmacsNative.java: Add missing dependency.
+
+ * lisp/battery.el (battery-status-function): Don't look for /sys
+ or /proc* on Android. Explain why.
+
+ * java/org/gnu/emacs/EmacsService.java (queryBattery19): New
+ function.
+ (queryBattery): Call it on old systems. Also, return AC line
+ status and temperature.
+
+ * lisp/battery.el (battery-android): Implement more format
+ directives.
+
+ * src/android.c (android_query_battery): Handle new status fields.
+
+ * src/android.h (struct android_battery_state): Add `plugged' and
+ `temperature'.
+
+ * src/androidfns.c (Fandroid_query_battery): Return new fields.
+
+2023-03-09 Po Lu <luangruo@yahoo.com>
+
+ * src/android.c (android_destroy_handle): Handle OOM errors in
+ android_destroy_handle.
+
+ * textconv.c: Remove out-of-date comment.
+
+ * java/org/gnu/emacs/EmacsActivity.java (onContextMenuClosed):
+
+ * java/org/gnu/emacs/EmacsContextMenu.java (EmacsContextMenu)
+ (onMenuItemClick, run):
+
+ * java/org/gnu/emacs/EmacsDialog.java (onClick, createDialog)
+ (onDismiss): Take menu event serial, and pass it along in context
+ menu events.
+
+ * java/org/gnu/emacs/EmacsNative.java (sendContextMenu): New
+ argument.
+
+ * src/android.c (sendContextMenu): Pass serial number in event.
+
+ * src/androidgui.h (struct android_menu_event): New field
+ `menu_event_serial'.
+
+ * src/androidmenu.c (android_init_emacs_dialog): Adjust method
+ declarations.
+ (android_menu_show, android_dialog_show):
+
+ * src/androidterm.c (handle_one_android_event): Expect serial in
+ context menu events.
+
+ * src/androidterm.h: Update prototypes.
+
+ * configure.ac (HAVE_WEBP): Disable WebPGetInfo check when
+ REALLY_ANDROID.
+
+ * java/debug.sh (is_root): Port to Android versions which don't
+ support `chmod +x'.
+
+ * src/android.c (android_content_name_p): Disable before API level
+ 19.
+
+ * java/org/gnu/emacs/EmacsContextMenu.java (addItem): New argument
+ `tooltip'.
+
+ * src/android.c (android_build_string): Convert the text to
+ UTF-16, and create the Java string using that.
+ (android_build_jstring): Update comment.
+
+ * src/androidmenu.c (android_init_emacs_context_menu): Add String
+ argument to `addItem'.
+
+ (android_menu_show): Correctly pass help strings in regular menu
+ items.
+
+ * src/sfnt.c (_sfnt_swap16, _sfnt_swap32): Avoid reserved names.
+
+ * src/android.c (android_set_input_focus): Don't call method on
+ window using service class.
+
+ * src/sfnt.c (ODD): Use PUSH_UNCHECKED.
+
+2023-03-08 Po Lu <luangruo@yahoo.com>
+
+ * src/fileio.c (Fcopy_file): On Android, ignore ENOSYS and ENOTSUP
+ when restoring file times, as many old kernel versions encountered
+ on Android devices omit support for the relevant system calls.
+
+ * src/androidterm.c (android_build_extracted_text): Return NULL if
+ text class not initialized.
+ (android_update_selection): Check that EXTRACTED is not NULL.
+
+ * doc/emacs/android.texi (Android File System): Document what
+ `temp~unlinked' means in the temporary files directory.
+
+ * java/org/gnu/emacs/EmacsService.java (updateExtractedText): New
+ function.
+
+ * java/org/gnu/emacs/EmacsView.java (onCreateInputConnection): Ask
+ the input method nicely to not display the extracted text UI.
+
+ * src/android.c (struct android_emacs_service): New method
+ `updateExtractedText'.
+ (android_hack_asset_fd_fallback): Improve naming convention. Fix
+ typo.
+ (android_init_emacs_service): Add new method.
+ (android_update_extracted_text): New function.
+ (android_open_asset): Fix typo.
+
+ * src/androidgui.h: Update prototypes.
+
+ * src/androidterm.c (struct android_get_extracted_text_context):
+ New field `flags'.
+ (android_get_extracted_text): Set flags on the frame's output
+ data.
+ (android_build_extracted_text): New function.
+ (getExtractedText): Move out class structures.
+ (android_update_selection): Send updates to extracted text if the
+ input method asked for them.
+ (android_reset_conversion): Clear extracted text flags.
+
+ * src/androidterm.h (struct android_output): New fields for
+ storing extracted text data.
+
+ * src/sfnt.c (sfnt_read_cmap_table): Don't allocate too big data.
+ Also, free elements of (*data), not offsets into data itself.
+
+2023-03-07 Po Lu <luangruo@yahoo.com>
+
+ * java/Makefile.in (install_temp/assets/build_info): New rule.
+ (emacs.apk-in): Depend on that file.
+
+ * lisp/version.el (android-read-build-system)
+ (android-read-build-time): New functions.
+ (emacs-build-system, emacs-build-time): Use those functions on
+ Android, as dumping is done after installation on Android.
+
+ * src/fileio.c (Finsert_file_contents):
+
+ * src/window.c (replace_buffer_in_windows): Don't call functions
+ if they are not defined, which can happen during loadup.
+
+ * java/org/gnu/emacs/EmacsWindow.java (onSomeKindOfMotionEvent):
+ Dismiss splurious LeaveNotify events from button presses.
+
+ * src/android.c (android_change_window_attributes)
+ (android_change_gc, android_set_clip_rectangles)
+ (android_reparent_window, android_clear_window)
+ (android_map_window, android_unmap_window, android_resize_window)
+ (android_move_window, android_swap_buffers)
+ (android_fill_rectangle, android_copy_area)
+ (android_fill_polygon, android_draw_rectangle, android_draw_point)
+ (android_draw_line, android_clear_area, android_bell)
+ (android_set_input_focus, android_raise_window)
+ (android_lower_window, android_set_dont_focus_on_map)
+ (android_set_dont_accept_focus, android_get_keysym_name)
+ (android_toggle_on_screen_keyboard, android_restart_emacs)
+ (android_display_toast, android_update_ic, android_reset_ic)
+ (android_set_fullscreen): Optimize by specifying the class
+ explicitly when calling a method.
+
+ * src/lread.c (lread_fd, file_tell, infile, skip_dyn_bytes)
+ (skip_dyn_eof, readbyte_from_stdio, safe_to_load_version)
+ (close_infile_unwind, close_file_unwind_android_fd): New function.
+ (Fload, Flocate_file_internal, openp): New argument PLATFORM. All
+ callers changed.
+ (skip_lazy_string): Add optimized versions of various functions
+ for accessing Android assets.
+
+2023-03-06 Po Lu <luangruo@yahoo.com>
+
+ * java/org/gnu/emacs/EmacsNative.java (EmacsNative): New function
+ requestSelectionUpdate.
+
+ * java/org/gnu/emacs/EmacsView.java (onCreateInputConnection):
+ Call it instead of losing if getting the current selection fails.
+
+ * src/android-asset.h (AAsset_seek): Define stub.
+
+ * src/android.c (android_open): Take mode_t MODE instead of int.
+ (android_open_asset, android_close_asset, android_asset_read_quit)
+ (android_asset_read, android_asset_lseek, android_asset_fstat):
+ New functions.
+
+ * src/android.h (struct android_fd_or_asset): Update prototypes.
+
+ * src/androidgui.h (enum android_ime_operation): Add new operation
+ to update the selection position.
+
+ * src/androidterm.c (android_handle_ime_event): Handle new
+ operation.
+ (requestSelectionUpdate): New function.
+
+ * src/fileio.c (close_file_unwind_emacs_fd): New function.
+ (Fcopy_file, union read_non_regular, read_non_regular)
+ (Finsert_file_contents): Use optimized codepath to insert Android
+ asset files.
+
+ * src/frame.h (enum text_conversion_operation): New operation.
+
+ * src/textconv.c (really_request_point_update)
+ (handle_pending_conversion_events_1, request_point_update): New
+ functions.
+
+ * src/textconv.h: Update prototypes.
+
+ * src/conf_post.h: Avoid macro redeclaration.
+
+ * java/org/gnu/emacs/EmacsService.java (sync): Delete function.
+
+ * java/org/gnu/emacs/EmacsView.java (handleDirtyBitmap): Erase
+ with window background.
+ (onDetachedFromWindow): Only recycle bitmap if non-NULL.
+
+ * java/org/gnu/emacs/EmacsWindow.java (background): New field.
+ (changeWindowBackground): Set it.
+
+ * src/android.c (struct android_emacs_service): Remove `sync'.
+ (android_init_emacs_service): Likewise.
+ (android_sync): Delete function.
+
+ * src/androidfns.c (android_create_tip_frame): Set frame
+ background color correctly.
+ (Fx_show_tip): Make the tip frame visible.
+
+ * src/androidgui.h: Update prototypes.
+
+ * src/androidterm.c (handle_one_android_event): Handle tooltip
+ movement correctly.
+
+2023-03-05 Po Lu <luangruo@yahoo.com>
+
+ * java/org/gnu/emacs/EmacsActivity.java (onCreate):
+ * java/org/gnu/emacs/EmacsContextMenu.java:
+ * java/org/gnu/emacs/EmacsDocumentsProvider.java (getMimeType):
+ * java/org/gnu/emacs/EmacsDrawLine.java (perform):
+ * java/org/gnu/emacs/EmacsDrawRectangle.java (perform):
+ * java/org/gnu/emacs/EmacsFillPolygon.java:
+ * java/org/gnu/emacs/EmacsFontDriver.java:
+ * java/org/gnu/emacs/EmacsHandleObject.java:
+ * java/org/gnu/emacs/EmacsInputConnection.java:
+ * java/org/gnu/emacs/EmacsMultitaskActivity.java:
+ * java/org/gnu/emacs/EmacsNative.java:
+ * java/org/gnu/emacs/EmacsNoninteractive.java (main):
+ * java/org/gnu/emacs/EmacsOpenActivity.java (startEmacsClient):
+ * java/org/gnu/emacs/EmacsSdk7FontDriver.java:
+ * java/org/gnu/emacs/EmacsSdk8Clipboard.java:
+ * java/org/gnu/emacs/EmacsService.java (onCreate):
+ * java/org/gnu/emacs/EmacsView.java (onLayout):
+ * java/org/gnu/emacs/EmacsWindow.java (EmacsWindow):
+ * java/org/gnu/emacs/EmacsWindowAttachmentManager.java: Remove
+ redundant includes. Reorganize some functions, remove duplicate
+ `getLibDir' functions, and remove unused local variables.
+
+ * java/org/gnu/emacs/EmacsOpenActivity.java (onCreate): Don't set
+ the style here.
+
+ * java/res/values-v11/style.xml:
+ * java/res/values-v14/style.xml:
+ * java/res/values-v29/style.xml:
+ * java/res/values/style.xml: Define styles for the emacsclient
+ wrapper.
+
+ * src/keyboard.c (read_key_sequence): Don't disable text
+ conversion if use_mouse_menu or if a menu bar prefix key is being
+ displayed.
+
+ * etc/PROBLEMS: Document problem with default monospace font.
+
+ * src/fileio.c (check_mutable_filename): Check if the file is a
+ constituent of /content as well.
+ (Fcopy_file, Fdelete_directory_internal, Fdelete_file)
+ (Frename_file, Fadd_name_to_file, Fmake_symbolic_link)
+ (Fset_file_modes, Fset_file_times, Ffile_newer_than_file_p)
+ (write_region): Adjust accordingly.
+ (Fset_visited_file_modtime): Remove unnecessary restriction.
+
+ * src/filelock.c (make_lock_file_name): Don't interlock files
+ under /assets and /content.
+
+ * src/inotify.c (Finotify_add_watch): Fix typo.
+
+ * cross/Makefile.in (config.status): Depend on
+ top_builddir/config.status instead.
+
+ * configure.ac: Fix another typo.
+
+ * cross/Makefile.in (builddir): Define.
+
+ * cross/README: Update.
+
+ * cross/lib: Delete. Make configure generate it instead.
+
+ * .gitignore: Simplify cross/lib rule.
+
+ * admin/merge-gnulib (avoided_flags): Stop copying to cross/lib.
+
+ * configure.ac: Link gnulib source and header files to cross/lib.
+
+ * cross/Makefile.in (LIB_SRCDIR): Make relative to builddir.
+ (maintainer-clean): Merge with distclean. Remove links created
+ by configure.
+
+2023-03-04 Po Lu <luangruo@yahoo.com>
+
+ * cross/ndk-build/ndk-build-shared-library.mk:
+ * cross/ndk-build/ndk-build-static-library.mk: Specify right ELF
+ format for 64 bit executables.
+
+ * cross/ndk-build/ndk-build-shared-library.mk:
+ * cross/ndk-build/ndk-build-static-library.mk: Ensure nasm
+ generates ELF objects.
+
+ * src/sfnt.c (sfnt_fill_span): Specifically handle spans that span
+ a single pixel by computing the coverage in the center.
+
+ * java/org/gnu/emacs/EmacsActivity.java (EmacsActivity): New field
+ `lastClosedMenu'.
+ (onContextMenuClosed): Don't send event if a menu is closed twice
+ in a row. Also, clear wasSubmenuSelected immediately.
+
+ * java/org/gnu/emacs/EmacsContextMenu.java: Display submenus
+ manually in Android 6.0 and earlier.
+
+ * java/org/gnu/emacs/EmacsView.java (onCreateContextMenu)
+ (popupMenu): Adjust accordingly.
+
+ * configure.ac: Check for __ctype_get_mb_cur_max. Then see if
+ MB_CUR_MAX is defined to it, and define REPLACEMENT_MB_CUR_MAX if
+ so and it does not link.
+
+ * java/INSTALL: Update documentation.
+
+ * src/conf_post.h (MB_CUR_MAX): Define replacement if
+ necessary.
+
+ * m4/ndk-build.m4 (ndk_INIT): Fix typo.
+
+ * configure.ac: Call ndk_LATE after gl_EARLY.
+
+ * cross/ndk-build/Makefile.in (NDK_BUILD_CXX): New variable.
+
+ * cross/ndk-build/ndk-build-shared-library.mk:
+ * cross/ndk-build/ndk-build-static-library.mk: Use it.
+
+ * java/INSTALL: Describe how to build C++ dependencies.
+
+ * m4/ndk-build.m4 (ndk_LATE): New macro.
+ (ndk_INIT): Try to find a suitable C++ compiler.
+ (ndk_CHECK_MODULES): Make sure the C++ compiler works before
+ allowing C++ dependencies.
+
+ * cross/ndk-build/Makefile.in (NDK_BUILD_CFLAGS_CXX): New
+ variable.
+
+ * cross/ndk-build/ndk-build-shared-library.mk
+ ($(call objname,$(LOCAL_MODULE),$(basename $(1)))):
+ * cross/ndk-build/ndk-build-static-library.mk
+ ($(call objname,$(LOCAL_MODULE),$(basename $(1)))): Use it to
+ build C++ code.
+
+2023-03-03 Po Lu <luangruo@yahoo.com>
+
+ * configure.ac (ANDROID_SDK_8_OR_EARLIER): Pass through
+ `--with-ndk-cxx-shared'.
+
+ * m4/ndk-build.m4 (ndk_INIT): Fix quoting of $CC.
+
+ * cross/ndk-build/ndk-build-shared-library.mk:
+ * cross/ndk-build/ndk-build-static-library.mk: Include
+ ndk-resolve.mk in srcdir.
+
+ * cross/ndk-build/README: Update accordingly.
+
+ * build-aux/ndk-build-helper.mk: Define in terms of BUILD_AUXDIR.
+
+ * m4/ndk-build.m4 (ndk_INIT): Find right build-aux directory.
+ Remove uses of unportable shell constructs.
+
+ * java/org/gnu/emacs/EmacsService.java (checkContentUri): Improve
+ debug output.
+
+ * lisp/files.el (basic-save-buffer): Check whether or not file
+ itself exists before checking for the existence of the directory
+ containing it.
+
+ * src/android.c (android_open): Don't forget to set errno after
+ open_content_uri fails.
+
+ * java/org/gnu/emacs/EmacsActivity.java (onCreate): Add view tree
+ observer.
+ (onGlobalLayout): Sync fullscreen state.
+ (syncFullscreenWith): Improve visibility flag setting.
+
+ * src/textconv.c (select_window): New function.
+ (textconv_query, restore_selected_window, really_commit_text)
+ (really_set_composing_text, really_set_composing_region)
+ (really_delete_surrounding_text, really_set_point_and_mark)
+ (get_extracted_text): Call it instead of Fselect_window to avoid
+ selecting the mini window if it is no longer active.
+
+2023-03-02 Po Lu <luangruo@yahoo.com>
+
+ * doc/emacs/input.texi (On-Screen Keyboards): Fix indexing.
+
+ * INSTALL: Document where to find Android installation
+ instructions.
+
+ * configure.ac (CHECK_LISP_OBJECT_TYPE): Pacify
+ -Wsuggest-attribute=noreturn only on Android.
+
+ * cross/ndk-build/README: New file.
+
+ * doc/emacs/android.texi (Android):
+ * doc/emacs/emacs.texi (Top):
+ * doc/emacs/input.texi (Other Input Devices): Untabify menus.
+
+ * etc/NEWS: Move INSTALL.android to java/INSTALL.
+
+ * java/INSTALL: New file.
+
+ * java/README:
+
+ * src/coding.c (from_unicode_buffer): Make Android specific code
+ only build on Android.
+
+ * INSTALL.android: Remove file.
+
+ * configure.ac: Make cross/* and related directories.
+
+ * cross/Makefile.in (src/verbose.mk, lib/libgnu.a)
+ (src/config.h): Stop making directories here.
+ (lib-src/config.h): New config.h rule.
+ ($(LIBSRC_BINARIES)): Add it.
+ (clean): Don't remove CLEAN_SUBDIRS, but clean inside.
+
+ * src/android.c (android_alloc_id): Return correct values upon
+ wraparound.
+
+ * java/Makefile.in ($(CLASS_FILES) &): Touch all class files, even
+ those the Java compiler elected not to rebuild.
+
+ * java/org/gnu/emacs/EmacsActivity.java (onWindowFocusChanged):
+ Restore fullscreen state here.
+ (onResume): And not here.
+
+ * doc/emacs/android.texi (Android):
+ * doc/emacs/emacs.texi (Top, GNU Free Documentation License):
+ Rearrange menu and sectioning.
+
+ * doc/emacs/android.texi (Android Windowing): Reword
+ documentation.
+
+ * java/org/gnu/emacs/EmacsActivity.java (EmacsActivity):
+ * java/org/gnu/emacs/EmacsContextMenu.java (EmacsContextMenu):
+ * java/org/gnu/emacs/EmacsFontDriver.java (EmacsFontDriver):
+ * java/org/gnu/emacs/EmacsSdk7FontDriver.java
+ (EmacsSdk7FontDriver):
+ * java/org/gnu/emacs/EmacsService.java (queryBattery):
+ * java/org/gnu/emacs/EmacsWindow.java (EmacsWindow): Make
+ functions final and classes static where possible. This
+ subsequently brings a small speed-up as the JVM can optimize
+ vtable dispatch away at run-time.
+
+ * src/android.c (struct android_emacs_service): New method
+ `display_toast'.
+ (android_init_emacs_service): Load new method.
+ (android_display_toast): New function.
+
+ * src/android.h (android_display_toast): Export that new function.
+
+ * src/androidfns.c (Fandroid_detect_mouse):
+ * src/androidselect.c (Fandroid_clipboard_owner_p)
+ (Fandroid_set_clipboard, Fandroid_get_clipboard)
+ (Fandroid_browse_url): Prevent crashes when called from
+ libandroid-emacs.so, where the Emacs service object is not
+ present.
+
+ * src/androidterm.c (handle_one_android_event): Fix out of date
+ commentary.
+
+2023-03-01 Po Lu <luangruo@yahoo.com>
+
+ * configure.ac (JAVA_PUSH_LINT): Push to WARN_JAVAFLAGS instead of
+ JAVAFLAGS.
+ (cross/lib): Always AS_MKDIR_P.
+
+ * cross/Makefile.in (srcdir): New variable.
+ (LIB_SRCDIR): Take realpath relative to srcdir, not.
+ (src/verbose.mk): Depend on verbose.mk.android in srcdir.
+ (lib/Makefile): Edit srcdir and VPATH to LIB_SRCDIR.
+ (src/Makefile): Edit -I$$(top_srcdir) to -I../$(srcdir)/lib,
+ instead of omitting it.
+ (clean): Allow ndk-build clean to fail.
+
+ * java/Makefile.in (builddir): New variable.
+ (WARN_JAVAFLAGS): Likewise.
+ (JAVAFLAGS): Define in terms of WARN_JAVAFLAGS.
+ (SIGN_EMACS, SIGN_EMACS_V2): Use emacs.keystore relative to
+ srcdir. Allow inclusion of ndk-build.mk to fail.
+ (install_temp, emacs.apk-in)
+ (../config.status): Depend relative to top_srcdir.
+ (AndroidManifest.xml, $(APK_NAME)): Likewise.
+ (RESOURCE_FILE, CLASS_FILES, classes.dex): Output class files to
+ $(srcdir); these are arch independents, so this is okay.
+
+2023-03-01 Po Lu <luangruo@yahoo.com>
+
+ * cross/Makefile.in: Remove outdated comment.
+
+ * src/Makefile.in (.PHONY): Clean android-emacs and libemacs.so,
+ not emacs.so and aemacs.
+
+ * doc/emacs/android.texi (Android File System): Document new
+ behavior of starting a subprocess from /assets.
+
+ * java/org/gnu/emacs/EmacsWindow.java (onSomeKindOfMotionEvent):
+ Don't use isFromSource where not present.
+
+ * src/androidterm.c (android_scroll_run): Avoid undefined behavior
+ writing to bitfields.
+
+ * src/callproc.c (get_current_directory): When trying to run a
+ subprocess inside /assets, run it from the home directory instead.
+
+ * java/AndroidManifest.xml.in: Specify @style/EmacsStyle.
+
+ * java/org/gnu/emacs/EmacsActivity.java (onCreate): Stop setting
+ the theme here.
+
+ * java/res/values-v11/style.xml:
+ * java/res/values-v14/style.xml:
+ * java/res/values-v29/style.xml:
+ * java/res/values/style.xml: Extract style resources into
+ res/values.
+
+ * java/Makefile.in (ETAGS, clean): New rules to generate tags.
+
+ * java/org/gnu/emacs/EmacsActivity.java (EmacsActivity):
+ * java/org/gnu/emacs/EmacsApplication.java (EmacsApplication):
+ * java/org/gnu/emacs/EmacsContextMenu.java (EmacsContextMenu):
+ * java/org/gnu/emacs/EmacsCopyArea.java (EmacsCopyArea):
+ * java/org/gnu/emacs/EmacsDialog.java (EmacsDialog):
+ * java/org/gnu/emacs/EmacsDocumentsProvider.java
+ (EmacsDocumentsProvider):
+ * java/org/gnu/emacs/EmacsDrawLine.java (EmacsDrawLine):
+ * java/org/gnu/emacs/EmacsDrawPoint.java (EmacsDrawPoint):
+ * java/org/gnu/emacs/EmacsDrawRectangle.java
+ (EmacsDrawRectangle):
+ * java/org/gnu/emacs/EmacsFillPolygon.java (EmacsFillPolygon):
+ * java/org/gnu/emacs/EmacsFillRectangle.java
+ (EmacsFillRectangle):
+ * java/org/gnu/emacs/EmacsGC.java (EmacsGC):
+ * java/org/gnu/emacs/EmacsInputConnection.java
+ (EmacsInputConnection):
+ * java/org/gnu/emacs/EmacsNative.java (EmacsNative):
+ * java/org/gnu/emacs/EmacsNoninteractive.java
+ (EmacsNoninteractive):
+ * java/org/gnu/emacs/EmacsOpenActivity.java (EmacsOpenActivity):
+ * java/org/gnu/emacs/EmacsPixmap.java (EmacsPixmap):
+ * java/org/gnu/emacs/EmacsPreferencesActivity.java
+ (EmacsPreferencesActivity):
+ * java/org/gnu/emacs/EmacsSdk11Clipboard.java
+ (EmacsSdk11Clipboard):
+ * java/org/gnu/emacs/EmacsSdk23FontDriver.java
+ (EmacsSdk23FontDriver):
+ * java/org/gnu/emacs/EmacsSdk8Clipboard.java
+ (EmacsSdk8Clipboard):
+ * java/org/gnu/emacs/EmacsService.java (EmacsService):
+ * java/org/gnu/emacs/EmacsSurfaceView.java (EmacsSurfaceView):
+ * java/org/gnu/emacs/EmacsView.java (EmacsView):
+ * java/org/gnu/emacs/EmacsWindow.java (EmacsWindow):
+ * java/org/gnu/emacs/EmacsWindowAttachmentManager.java
+ (EmacsWindowAttachmentManager): Make classes final where
+ appropriate. The Java virtual machine is capable of removing
+ vtable dispatch when a virtual function call is being performed on
+ an instance of a final class.
+
+ * src/android.c (android_query_tree, android_get_geometry)
+ (android_translate_coordinates, android_query_battery): Correctly
+ verify the results of calls to JNI Get<Type>ArrayElements
+ functions.
+ (android_exception_check_nonnull): New function.
+
+ * src/androidselect.c (Fandroid_get_clipboard): Also check the
+ return values of calls to JNI array extraction functions.
+
+2023-02-28 Po Lu <luangruo@yahoo.com>
+
+ * src/sfnt.c (main):
+
+ * src/sfntfont.c (sfntfont_get_glyph_outline): Remove outdated
+ commentary.
+
+2023-02-26 Po Lu <luangruo@yahoo.com>
+
+ * src/android.c (struct android_emacs_window): New methods.
+ (android_init_emacs_window): Add new methods.
+ (android_lookup_method): Delete now-unused function.
+ (android_change_window_attributes, android_reparent_window)
+ (android_map_window, android_unmap_window, android_resize_window)
+ (android_move_window, android_set_input_focus)
+ (android_raise_window, android_lower_window, android_get_geometry)
+ (android_translate_coordinates, android_set_dont_focus_on_map)
+ (android_set_dont_accept_focus): Don't look up the class and
+ method each time when calling a function; that's just wasteful.
+
+ * cross/lib/unistd.in.h:
+ * lib/gnulib.mk.in:
+ * m4/gnulib-comp.m4: Update from gnulib.
+
+ * doc/lispref/commands.texi (Misc Events): Update documentation.
+
+ * java/org/gnu/emacs/EmacsService.java (onStartCommand): Improve
+ notification message.
+
+ * src/android.c (android_hack_asset_fd): Detect if ashmem is
+ available dynamically.
+ (android_detect_ashmem): New function.
+
+ * src/textconv.c (record_buffer_change): Use markers to
+ represent BEG and END instead.
+ (syms_of_textconv): Update doc string.
+
+2023-02-25 Po Lu <luangruo@yahoo.com>
+
+ * java/debug.sh (is_root): Fix tee detection again for old systems
+ which don't return exit codes from adb shell.
+
+ * src/android.c (android_run_select_thread, initEmacs):
+ * src/android.h:
+ * src/androidterm.c: Apply stack alignment to all JNICALL
+ functions.
+
+ * src/android.c (android_open): Clean up unused variables.
+
+ * java/org/gnu/emacs/EmacsNoninteractive.java (main): Port to
+ Android 2.2.
+
+ * src/android-asset.h (AAsset_openFileDescriptor): Delete stub
+ function.
+
+ * src/android.c (android_check_compressed_file): Delete function.
+ (android_open): Stop trying to find compressed files or to use the
+ system provided file descriptor. Explain why.
+
+ * doc/emacs/android.texi (Android Startup, Android File System)
+ (Android Environment, Android Windowing, Android Troubleshooting):
+ Improve documentation; fix typos.
+
+ * doc/lispref/commands.texi (Misc Events): Likewise.
+
+ * java/org/gnu/emacs/EmacsService.java (queryBattery): New
+ function.
+
+ * lisp/battery.el (battery-status-function): Set appropriately
+ for Android.
+ (battery-android): New function.
+
+ * src/android.c (struct android_emacs_service): New method
+ `query_battery'.
+ (android_check_content_access): Improve exception checking.
+ (android_init_emacs_service): Look up new method.
+ (android_destroy_handle, android_create_window)
+ (android_init_android_rect_class, android_init_emacs_gc_class)
+ (android_set_clip_rectangles)
+ (android_create_pixmap_from_bitmap_data, android_fill_polygon)
+ (android_get_image, android_put_image, android_bell)
+ (android_set_input_focus, android_raise_window)
+ (android_lower_window, android_query_tree, android_get_geometry)
+ (android_translate_coordinates, android_wc_lookup_string)
+ (android_damage_window, android_build_string)
+ (android_build_jstring, android_exception_check_1)
+ (android_exception_check_2): New functions.
+ (android_browse_url): Improve exception handling. Always use
+ android_exception_check and don't leak local refs.
+ (android_query_battery): New function.
+
+ * src/android.h (struct android_battery_state): New struct.
+
+ * src/androidfns.c (Fandroid_query_battery, syms_of_androidfns):
+ New functions.
+
+ * src/androidfont.c (androidfont_from_lisp, DO_SYMBOL_FIELD)
+ (DO_CARDINAL_FIELD, androidfont_list, androidfont_match)
+ (androidfont_draw, androidfont_open_font)
+ (androidfont_close_font):
+ * src/androidselect.c (Fandroid_set_clipboard)
+ (Fandroid_get_clipboard):
+ * src/sfnt.c (sfnt_map_glyf_table):
+ * src/sfntfont.c (sfntfont_free_outline_cache)
+ (sfntfont_free_raster_cache, sfntfont_close): Allow calling font
+ close functions twice.
+
+2023-02-24 Po Lu <luangruo@yahoo.com>
+
+ * configure.ac (JAVA_PUSH_LINT): New macro.
+ (JAVAFLAGS): New variable. Check for various lint flags and
+ macros and enable them.
+
+ * java/Makefile.in (ANDROID_ABI):
+
+ * java/org/gnu/emacs/EmacsSdk7FontDriver.java: Remove compiler
+ warning.
+
+ * lisp/frame.el (display-symbol-keys-p):
+ * lisp/simple.el (normal-erase-is-backspace-setup-frame): Return
+ appropriate values on Android.
+
+ * src/inotify.c (Finotify_add_watch): Handle asset files by
+ returning nil.
+
+ * src/keyboard.c (lispy_function_keys): Add missing delete key.
+
+2023-02-23 Po Lu <luangruo@yahoo.com>
+
+ * lisp/loadup.el: Update commentary.
+
+ * src/androidterm.c (syms_of_androidterm): Define
+ Vx_toolkit_scroll_bars.
+
+ * src/xterm.c (syms_of_xterm): Update doc string.
+
+ * INSTALL.android:
+ * build-aux/ndk-build-helper-1.mk:
+ (NDK_$(LOCAL_MODULE)_STATIC_LIBRARIES)
+ (NDK_CXX_FLAG_$(LOCAL_MODULE)):
+ * build-aux/ndk-build-helper-2.mk:
+ (NDK_$(LOCAL_MODULE)_STATIC_LIBRARIES)
+ (NDK_CXX_FLAG_$(LOCAL_MODULE)):
+ * cross/ndk-build/ndk-build-shared-library.mk (objname)
+ ($(call objname,$(LOCAL_MODULE),$(basename $(1))))
+ (ALL_OBJECT_FILES$(LOCAL_MODULE)):
+ * cross/ndk-build/ndk-build-static-library.mk (objname)
+ ($(call objname,$(LOCAL_MODULE),$(basename $(1))))
+ (ALL_OBJECT_FILES$(LOCAL_MODULE)):
+ (ALL_SOURCE_FILES): Update ImageMagick build instructions and C++
+ module detection.
+
+ * src/android.c (android_run_select_thread): Fix typos.
+ (android_run_select_thread): Lock select_mutex before signaling
+ condition variable.
+ (android_select): Unlock event queue mutex prior to waiting for
+ it.
+
+2023-02-22 Po Lu <luangruo@yahoo.com>
+
+ * cross/ndk-build/ndk-build-shared-library.mk: Fix typo.
+
+ * src/image.c (imagemagick_load_image): Check HAVE_DECL_xxx.
+
+ * INSTALL.android: Document ImageMagick and caveats.
+
+ * build-aux/ndk-build-helper-1.mk (NDK_SO_NAMES):
+ * build-aux/ndk-build-helper-2.mk (NDK_A_NAMES):
+ * build-aux/ndk-build-helper.mk (TARGET_ARCH_ABI): Define
+ architecture and don't respect explicitly specified library names.
+ * configure.ac: Enable ImageMagick and lcms2 on Android.
+ * cross/ndk-build/ndk-build-shared-library.mk (objname)
+ ($(call objname,$(LOCAL_MODULE),$(basename $(1))))
+ (ALL_OBJECT_FILES$(LOCAL_MODULE)):
+ * cross/ndk-build/ndk-build-static-library.mk (objname)
+ ($(call objname,$(LOCAL_MODULE),$(basename $(1))))
+ (NDK_CFLAGS, ALL_SOURCE_FILES): Handle source files whose names
+ begin with $(LOCAL_PATH).
+
+ * cross/ndk-build/ndk-clear-vars.mk: Don't undefine; clear
+ variables instead.
+
+ * m4/ndk-build.m4 (ndk_SEARCH_MODULE): Redirect make stderr to
+ config.log.
+
+ * src/androidmenu.c (android_menu_show): Fix typo.
+
+ * doc/emacs/input.texi (On-Screen Keyboards): Document changes to
+ text conversion.
+
+ * java/org/gnu/emacs/EmacsInputConnection.java (getExtractedText):
+ * src/keyboard.c (read_key_sequence): Disable text conversion
+ after reading prefix key.
+
+ * src/textconv.c (get_extracted_text): Fix returned value when
+ request length is zero.
+
+ * configure.ac: Per title.
+
+ * INSTALL.android: Port to MIPS.
+
+ * configure.ac (modules): Default to ifavailable. Write actual
+ test for __attribute__((cleanup)).
+
+ * m4/ndk-build.m4: Recognize mips and mips64.
+
+ * src/emacs-module.c: Remove broken HAS_ATTRIBUTE test.
+
+2023-02-21 Po Lu <luangruo@yahoo.com>
+
+ * java/org/gnu/emacs/EmacsContextMenu.java (addSubmenu)
+ (inflateMenuItems): Handle tooltips correctly.
+
+ * src/android.c (android_scan_directory_tree): Fix limit
+ generation for root directory.
+
+ * src/androidmenu.c (android_init_emacs_context_menu)
+ (android_menu_show): Implement menu item help text on Android 8.0
+ and later.
+
+ * admin/merge-gnulib (GNULIB_MODULES): Add gnulib module stpncpy.
+
+ * m4, lib: Update from Gnulib.
+
+ * src/android.c: Include string.h.
+
+ * doc/emacs/android.texi (Android Startup): Document `content'
+ special directory.
+
+ * java/debug.sh (is_root): Improve /bin/tee detection.
+
+ * java/org/gnu/emacs/EmacsNative.java (dup): New function.
+
+ * java/org/gnu/emacs/EmacsOpenActivity.java (checkReadableOrCopy)
+ (onCreate): Create content directory names when the file is not
+ readable.
+
+ * java/org/gnu/emacs/EmacsService.java (openContentUri)
+ (checkContentUri): New functions.
+
+ * src/android.c (struct android_emacs_service): New methods.
+ (android_content_name_p, android_get_content_name)
+ (android_check_content_access): New function.
+ (android_fstatat, android_open): Implement opening content URIs.
+ (dup): Export to Java.
+ (android_init_emacs_service): Initialize new methods.
+ (android_faccessat): Implement content file names.
+
+2023-02-20 Po Lu <luangruo@yahoo.com>
+
+ * INSTALL.android: Explain where to get tree-sitter.
+
+ * configure.ac: Add support for dynamic modules and tree-sitter.
+
+ * doc/emacs/android.texi (Android Windowing):
+
+ * java/org/gnu/emacs/EmacsSdk11Clipboard.java
+ (ownsClipboard): Enhance the treatment of the clipboard and the
+ documentation addressing that subject.
+
+2023-02-20 Po Lu <luangruo@yahoo.com>
+
+ * src/androidfont.c (androidfont_list_family): Don't
+ unconditionally initialize the Android font driver.
+
+ * src/fontset.c (fontset_find_font): Add compatibility test to
+ registry strangeness case.
+
+ * src/sfnt.c (sfnt_read_cmap_table): Don't read subtable data if
+ DATA is NULL.
+
+ * src/sfntfont.c (struct sfnt_font_desc): New field `registry'.
+ (sfnt_registry_for_subtable): New function.
+ (sfntfont_identify_cmap): Move above sfnt_grok_registry.
+ (sfnt_grok_registry): New function.
+ (sfnt_enum_font_1): Call it.
+ (sfntfont_registries_compatible_p): New function.
+ (sfntfont_list_1): Check registry compatibility.
+ (sfntfont_registry_for_desc): New function.
+ (mark_sfntfont): Mark desc->registry.
+
+ * java/Makefile.in ($(CLASS_FILES)): Depend on the Java compiler's
+ internal dependency tracking.
+
+ * src/fontset.c (fontset_find_font): Work around TrueType
+ performance problem.
+
+ * cross/Makefile.in (src/libemacs.so): Depend on libgnu.a.
+
+ * cross/ndk-build/ndk-build.mk.in (NDK_BUILD_MODULES)
+ (NDK_BUILD_SHARED, NDK_BUILD_STATIC): Define group rule to build
+ all files so that they are built within one make process.
+
+ * java/Makefile.in: Reorganize cross compilation and make sure
+ there is only one make subprocess for each subdirectory of cross.
+
+ * cross/Makefile.in (.PHONY):
+ * java/Makefile.in (.PHONY):
+ * src/Makefile.in (libemacs.so): Avoid calling ndk-build from two
+ places at once. Build android-emacs separately from libemacs.so.
+
+ * cross/Makefile.in ($(top_builddir)/lib/libgnu.a):
+ * java/Makefile.in (CROSS_LIBS): Explicitly depend on Gnulib to
+ prevent it from being built at the same time from different jobs.
+
+ * src/sfntfont.c (sfntfont_close): Don't unlink font if mmap is
+ not available.
+
+ * INSTALL.android: Say where building Emacs is supported.
+
+ * doc/emacs/android.texi (Android Startup): Describe how to
+ connect via ADB.
+
+ * java/org/gnu/emacs/EmacsNative.java (getSelection): Return array
+ of ints.
+
+ * java/org/gnu/emacs/EmacsView.java (onCreateInputConnection):
+ Adjust accordingly.
+
+ * src/androidterm.c (struct android_get_selection_context): New
+ field `mark'.
+ (android_get_selection): Set the mark field as appropriate.
+ (getSelection): Adjust accordingly.
+
+ * lisp/play/gamegrid.el (gamegrid-setup-default-font): Clamp font
+ size at eight.
+
+ * java/org/gnu/emacs/EmacsOpenActivity.java (checkReadableOrCopy):
+ New function.
+ (onCreate): If the file specified is not readable from C, read it
+ into a temporary file and ask Emacs to open that.
+
+ * doc/emacs/android.texi (Android Windowing): Document what new
+ frame parameters are now supported.
+
+ * java/org/gnu/emacs/EmacsActivity.java (EmacsActivity): New field
+ `isFullscreen'.
+ (detachWindow, attachWindow): Sync fullscreen state.
+ (onWindowFocusChanged): Add more logging.
+ (onResume): Restore previous fullscreen state.
+ (syncFullscreen): New function.
+
+ * java/org/gnu/emacs/EmacsWindow.java (setFullscreen): New
+ function.
+
+ * src/android.c (struct android_emacs_window): Add new method.
+ (android_init_emacs_window): Look up new method.
+ (android_set_fullscreen): New function.
+
+ * src/androidgui.h:
+ * src/androidterm.c (android_fullscreen_hook): Implement
+ accordingly.
+
+ * lisp/subr.el (overriding-text-conversion-style, y-or-n-p):
+ Disable text conversion when reading from minibuffer.
+
+ * src/androidfns.c (android_make_monitor_attribute_list): New
+ function.
+ (Fandroid_display_monitor_attributes_list): Call it to set
+ monitor_frames, which avoids a NULL pointer dereference.
+ Reported by Angelo Graziosi <angelo.g0@libero.it>.
+
+2023-02-18 Po Lu <luangruo@yahoo.com>
+
+ * lisp/loadup.el: Fix merge typos.
+
+ * doc/emacs/input.texi (On-Screen Keyboards): Document
+ `touch-screen-always-display'.
+
+ * doc/lispref/commands.texi (Misc Events): Improve documentation
+ of text conversion events.
+
+ * java/org/gnu/emacs/EmacsDialog.java (toAlertDialog, display1):
+ Reorder buttons to make more sense.
+
+ * lisp/elec-pair.el (electric-pair-analyze-conversion): New
+ function.
+
+ * lisp/simple.el (analyze-text-conversion): Improve integration
+ with electric pair modes.
+
+ * lisp/term.el (term-mode): Always display the onscreen keyboard.
+
+ * lisp/touch-screen.el (touch-screen-display-keyboard)
+ (touch-screen-handle-point-up): Respect new options.
+
+ * src/textconv.c (really_set_composing_text): Stop widenining
+ unnecessarily.
+ (really_delete_surrounding_text): Really delete surrounding text.
+ Give text conversion analyzers the buffer text.
+ (syms_of_textconv): Update doc string.
+
+ * INSTALL.android: Clarify build instructions.
+
+ * src/textconv.c (struct complete_edit_check_context): New
+ structure.
+ (complete_edit_check): New function.
+ (handle_pending_conversion_events_1): If the window is known, then
+ ensure that any editing failures are reported to the input method.
+
+ * configure.ac: Fix typo. Check for madvise.
+
+ * lisp/international/fontset.el (script-representative-chars):
+ Improve detection of CJK fonts.
+
+ * src/pdumper.c (dump_discard_mem): Use madvise if possible.
+
+ * src/sfnt.c (sfnt_map_glyf_table, sfnt_unmap_glyf_table): New
+ functions.
+
+ * src/sfnt.h (struct sfnt_glyf_table): New field.
+
+ * src/sfntfont.c (struct sfnt_font_info, sfntfont_open)
+ (sfntfont_close, sfntfont_detect_sigbus): Map fonts into memory if
+ possible.
+
+ * src/sfntfont.h: Update prototypes.
+
+ * src/sysdep.c (handle_sigbus, init_sigbus, init_signals):
+ Initialize SIGBUS correctly.
+
+2023-02-17 Po Lu <luangruo@yahoo.com>
+
+ * src/androidterm.c (android_get_selection): Use ephemeral last
+ point.
+
+ * src/textconv.c (report_selected_window_change): Set
+ w->ephemeral_last_point to the window's point now.
+
+ * java/Makefile.in (install_temp/assets/version): New generated
+ file.
+
+ * lisp/loadup.el: Set Emacs versions appropriately prior to
+ dumping on Android.
+
+ * lisp/mail/emacsbug.el (emacs-build-description): Insert Android
+ build fingerprint.
+
+ * lisp/version.el (emacs-repository-version-android)
+ (emacs-repository-get-version, emacs-repository-get-branch):
+ Implement for Android.
+
+ * src/androidterm.c (android_set_build_fingerprint): New function.
+ (syms_of_androidterm): New variable `android-build-fingerprint'.
+
+ * src/android.c (android_exception_check): Fix typo.
+ (android_exception_check): Print more detailed information.
+
+ * java/org/gnu/emacs/EmacsService.java (nameKeysym): Implement
+ stub on Android 3.0 and earlier.
+
+ * INSTALL.android: Document that Android 2.2 is now supported)
+ (with caveats.
+
+ * configure.ac (ANDROID_MIN_SDK, ANDROID_SDK_18_OR_EARLIER)
+ (SYSTEM_TYPE, ANDROID_STUBIFY, SIZEOF_LONG): Correctly detect
+ things missing on Android 2.2.
+
+ * java/Makefile.in (ANDROID_JAR, JARSIGNER_FLAGS):
+ * java/debug.sh (jdb, gdbserver, line):
+ * java/org/gnu/emacs/EmacsApplication.java (findDumpFile):
+ * java/org/gnu/emacs/EmacsService.java (onCreate):
+ * java/org/gnu/emacs/EmacsThread.java (run): Run parameter
+ initialization on main thread.
+
+ * src/android-asset.h (struct android_asset_manager)
+ (struct android_asset, AAssetManager_fromJava, AAssetManager_open)
+ (AAsset_close, android_asset_create_stream)
+ (android_asset_read_internal, AAsset_openFileDescriptor)
+ (AAsset_getLength, AAsset_getBuffer, AAsset_read): New file.
+ Write substitutes for functions that aren't present within the NDK
+ on Android 2.2.
+
+ * src/android.c: Arrange to include android-asset.h if the minimum
+ supported Android version is 2.2.
+ (android_user_full_name, android_hack_asset_fd)
+ (android_check_compressed_file): Implement for Android 2.2.
+
+ * src/process.c (Fprocess_send_eof): Don't call tcdrain if
+ unavailable.
+
+ * src/sfntfont-android.c (system_font_directories): Fix compiler
+ warning.
+
+ * src/sfntfont.c (sfntfont_read_cmap): Correctly test rc of
+ emacs_open.
+
+ * src/textconv.c (handle_pending_conversion_events_1): Mark buffer
+ UNINIT.
+
+2023-02-16 Po Lu <luangruo@yahoo.com>
+
+ * doc/emacs/android.texi (Android Fonts):
+ * doc/emacs/input.texi (On-Screen Keyboards):
+ * doc/lispref/commands.texi (Misc Events): Update documentation.
+
+ * java/org/gnu/emacs/EmacsInputConnection.java (setSelection): New
+ function.
+ * java/org/gnu/emacs/EmacsSurfaceView.java
+ (reconfigureFrontBuffer): Make bitmap references weak references.
+
+ * java/org/gnu/emacs/EmacsView.java (handleDirtyBitmap): Don't
+ clear surfaceView bitmap.
+
+ * lisp/comint.el (comint-mode): Set text-conversion-style to
+ `action' so on screen keyboards' Return buttons send an actual key
+ press event.
+
+ * lisp/international/fontset.el (script-representative-chars)
+ (setup-default-fontset): Improve detection of CJK fonts.
+
+ * lisp/isearch.el (set-text-conversion-style): New variable.
+ (isearch-mode, isearch-done): Save and restore the text conversion
+ style.
+
+ * lisp/minibuffer.el (minibuffer-mode): Set an appropriate text
+ conversion style.
+
+ * lisp/simple.el (analyze-text-conversion): Run
+ post-self-insert-hook properly.
+
+ * lisp/subr.el (read-char-from-minibuffer): Disable text
+ conversion when reading character.
+
+ * src/androidterm.c (show_back_buffer): Don't check that F is not
+ garbaged.
+ (android_update_selection, android_reset_conversion): Use the
+ ephemeral last point and handle text conversion being disabled.
+
+ * src/buffer.c (syms_of_buffer): Convert old style DEFVAR.
+
+ * src/keyboard.c (kbd_buffer_get_event): Handle text conversion
+ first.
+
+ * src/lisp.h: Update prototypes.
+
+ * src/lread.c (read_filtered_event): Temporarily disable text
+ conversion.
+
+ * src/sfnt.c (sfnt_decompose_glyph_1, sfnt_decompose_glyph_2): New
+ functions.
+ (sfnt_decompose_glyph, sfnt_decompose_instructed_outline):
+ Refactor contour decomposition to those two functions.
+ (main): Update tests.
+
+ * src/sfntfont-android.c (system_font_directories): Add empty
+ field.
+ (Fandroid_enumerate_fonts, init_sfntfont_android): Enumerate fonts
+ in a user fonts directory.
+
+ * src/sfntfont.c (struct sfnt_font_desc): New field `num_glyphs'.
+ (sfnt_enum_font_1): Set num_glyphs and avoid duplicate fonts.
+ (sfntfont_glyph_valid): New function.
+ (sfntfont_lookup_char, sfntfont_list_1): Make sure glyphs found
+ are valid.
+
+ * src/textconv.c (sync_overlay, really_commit_text)
+ (really_set_composing_text, really_set_composing_region)
+ (really_delete_surrounding_text, really_set_point_and_mark)
+ (handle_pending_conversion_events_1)
+ (handle_pending_conversion_events, conversion_disabled_p)
+ (disable_text_conversion, resume_text_conversion)
+ (Fset_text_conversion_style, syms_of_textconv): Update to respect
+ new options.
+
+ * src/window.h (GCALIGNED_STRUCT): New field
+ `ephemeral_last_point'.
+
+ * src/xdisp.c (mark_window_display_accurate_1): Set it.
+
+2023-02-15 Po Lu <luangruo@yahoo.com>
+
+ * doc/emacs/input.texi (On-Screen Keyboards):
+ * doc/lispref/commands.texi (Misc Events): Improve documentation
+ of text conversion stuff.
+
+ * java/org/gnu/emacs/EmacsInputConnection.java (beginBatchEdit)
+ (endBatchEdit, commitCompletion, commitText)
+ (deleteSurroundingText)
+ (finishComposingText, getSelectedText, getTextAfterCursor)
+ (EmacsInputConnection, setComposingRegion, performEditorAction)
+ (getExtractedText): Condition debug code on DEBUG_IC.
+
+ * java/org/gnu/emacs/EmacsService.java (EmacsService, updateIC):
+ Likewise.
+
+ * lisp/bindings.el (global-map):
+ * lisp/electric.el (global-map): Make `text-conversion'
+ `analyze-text-conversion'.
+
+ * lisp/progmodes/prog-mode.el (prog-mode): Enable text conversion
+ in input methods.
+
+ * lisp/simple.el (analyze-text-conversion): New function.
+
+ * lisp/textmodes/text-mode.el (text-conversion-style)
+ (text-mode): Likewise.
+
+ * src/androidterm.c (android_handle_ime_event): Handle
+ set_point_and_mark.
+ (android_sync_edit): Give Emacs 100 ms instead.
+ (android_perform_conversion_query): Skip the active region, not
+ the conversion region.
+ (getSelectedText): Implement properly.
+ (android_update_selection): Expose mark to input methods.
+ (android_reset_conversion): Handle `text-conversion-style'.
+
+ * src/buffer.c (init_buffer_once, syms_of_buffer): Add buffer
+ local variable `text-conversion-style'.
+
+ * src/buffer.h (struct buffer, bset_text_conversion_style): New
+ fields.
+
+ * src/emacs.c (android_emacs_init): Call syms_of_textconv.
+
+ * src/frame.h (enum text_conversion_operation): Rename
+ TEXTCONV_SET_POINT.
+
+ * src/lisp.h (syms_of_textconv): Export syms_of_textconv.
+
+ * src/marker.c (set_marker_internal): Force redisplay when the
+ mark is set and the buffer is visible on builds that use text
+ conversion. Explain why.
+
+ * src/textconv.c (copy_buffer): Fix copying past gap.
+ (get_mark): New function.
+ (textconv_query): Implement new flag.
+ (sync_overlay): New function. Display conversion text in an
+ overlay.
+ (record_buffer_change, really_commit_text)
+ (really_set_composing_text, really_set_composing_region)
+ (really_delete_surrounding_text, really_set_point)
+ (handle_pending_conversion_events_1, decrement_inside)
+ (handle_pending_conversion_events, textconv_set_point)
+ (get_extracted_text, register_textconv_interface): Various fixes
+ and improvements.
+
+ * src/textconv.h (struct textconv_interface): Update
+ documentation.
+
+ * src/window.h (GCALIGNED_STRUCT): New field `prev_mark'.
+
+ * src/xdisp.c (mark_window_display_accurate_1): Handle prev_mark.
+
+ * java/debug.sh: Run gdbserver directly if possible.
+
+ * src/androidterm.c (android_handle_ime_event): Pacify compiler
+ warnings.
+
+ * src/textconv.c (really_set_composing_text)
+ (handle_pending_conversion_events, get_extracted_text): Fix
+ reentrancy problems and uses of uninitialized values.
+
+ * configure.ac (HAVE_TEXT_CONVERSION): Define on Android.
+
+ * doc/emacs/input.texi (On-Screen Keyboards): Document ``text
+ conversion'' slightly.
+
+ * doc/lispref/commands.texi (Misc Events): Document new
+ `text-conversion' event.
+
+ * java/org/gnu/emacs/EmacsContextMenu.java (display): Use
+ `syncRunnable'.
+
+ * java/org/gnu/emacs/EmacsDialog.java (display): Likewise.
+
+ * java/org/gnu/emacs/EmacsEditable.java: Delete file.
+
+ * java/org/gnu/emacs/EmacsInputConnection.java
+ (EmacsInputConnection): Reimplement from scratch.
+
+ * java/org/gnu/emacs/EmacsNative.java (EmacsNative): Add new
+ functions.
+
+ * java/org/gnu/emacs/EmacsService.java (getEmacsView)
+ (getLocationOnScreen, sync, getClipboardManager, restartEmacs):
+ Use syncRunnable.
+ (syncRunnable): New function.
+ (updateIC, resetIC): New functions.
+
+ * java/org/gnu/emacs/EmacsView.java (EmacsView): New field
+ `inputConnection' and `icMode'.
+ (onCreateInputConnection): Update accordingly.
+ (setICMode, getICMode): New functions.
+
+ * lisp/bindings.el (global-map): Ignore text conversion events.
+
+ * src/alloc.c (mark_frame): Mark text conversion data.
+
+ * src/android.c (struct android_emacs_service): New fields
+ `update_ic' and `reset_ic'.
+ (event_serial): Export.
+ (android_query_sem): New function.
+ (android_init_events): Initialize new semaphore.
+ (android_write_event): Export.
+ (android_select): Check for UI thread code.
+ (setEmacsParams, android_init_emacs_service): Initialize new
+ methods.
+ (android_check_query, android_begin_query, android_end_query)
+ (android_run_in_emacs_thread):
+ (android_update_ic, android_reset_ic): New functions for managing
+ synchronous queries from one thread to another.
+
+ * src/android.h: Export new functions.
+
+ * src/androidgui.h (enum android_event_type): Add input method
+ events.
+ (enum android_ime_operation, struct android_ime_event)
+ (union android_event, enum android_ic_mode): New structs and
+ enums.
+
+ * src/androidterm.c (android_window_to_frame): Allow DPYINFO to be
+ NULL.
+ (android_decode_utf16, android_handle_ime_event)
+ (handle_one_android_event, android_sync_edit)
+ (android_copy_java_string, beginBatchEdit, endBatchEdit)
+ (commitCompletion, deleteSurroundingText, finishComposingText)
+ (getSelectedtext, getTextAfterCursor, getTextBeforeCursor)
+ (setComposingText, setComposingRegion, setSelection, getSelection)
+ (performEditorAction, getExtractedText): New functions.
+ (struct android_conversion_query_context)
+ (android_perform_conversion_query, android_text_to_string)
+ (android_get_selection_context, android_get_selection)
+ (android_get_extracted_text_context, android_get_extracted_text)
+ (android_extracted_text_request_class)
+ (android_extracted_text_class, android_update_selection)
+ (android_reset_conversion, android_set_point)
+ (android_compose_region_changed, android_notify_conversion)
+ (text_conversion_interface): New functions and structures.
+ (android_term_init): Initialize text conversion.
+
+ * src/coding.c (syms_of_coding): Define Qutf_16le on Android.
+
+ * src/frame.c (make_frame): Clear conversion data.
+ (delete_frame): Reset conversion state.
+
+ * src/frame.h (enum text_conversion_operation)
+ (struct text_conversion_action, struct text_conversion_state)
+ (GCALIGNED_STRUCT): Update structures.
+
+ * src/keyboard.c (read_char, readable_events, kbd_buffer_get_event)
+ (syms_of_keyboard): Handle text conversion events.
+
+ * src/lisp.h:
+ * src/process.c: Fix includes.
+
+ * src/textconv.c (enum textconv_batch_edit_flags, textconv_query)
+ (reset_frame_state, detect_conversion_events)
+ (restore_selected_window, really_commit_text)
+ (really_finish_composing_text, really_set_composing_text)
+ (really_set_composing_region, really_delete_surrounding_text)
+ (really_set_point, complete_edit)
+ (handle_pending_conversion_events_1)
+ (handle_pending_conversion_events, start_batch_edit)
+ (end_batch_edit, commit_text, finish_composing_text)
+ (set_composing_text, set_composing_region, textconv_set_point)
+ (delete_surrounding_text, get_extracted_text)
+ (report_selected_window_change, report_point_change)
+ (register_texconv_interface): New functions.
+
+ * src/textconv.h (struct textconv_interface)
+ (TEXTCONV_SKIP_CONVERSION_REGION): Update prototype.
+
+ * src/xdisp.c (mark_window_display_accurate_1):
+ * src/xfns.c (xic_string_conversion_callback):
+ * src/xterm.c (init_xterm): Adjust accordingly.
+
+2023-02-12 Po Lu <luangruo@yahoo.com>
+
+ * doc/emacs/android.texi (Android Environment): Mention that Emacs
+ also requests the notifications permission.
+
+ * java/org/gnu/emacs/EmacsEditable.java:
+ * java/org/gnu/emacs/EmacsInputConnection.java: New files.
+
+ * java/org/gnu/emacs/EmacsNative.java (EmacsNative): Load library
+ dependencies in a less verbose fashion.
+
+ * java/org/gnu/emacs/EmacsView.java (EmacsView): Make imManager
+ public.
+ (onCreateInputConnection): Set InputType to TYPE_NULL for now.
+
+ * java/org/gnu/emacs/EmacsWindow.java (onKeyDown, onKeyUp)
+ (getEventUnicodeChar): Correctly handle key events with strings.
+
+ * lisp/term/android-win.el (android-clear-preedit-text)
+ (android-preedit-text): New special event handlers.
+
+ * src/android.c (struct android_emacs_window): Add function
+ lookup_string.
+ (android_init_emacs_window): Adjust accordingly.
+ (android_wc_lookup_string): New function.
+
+ * src/androidgui.h (struct android_key_event): Improve commentary.
+ (enum android_lookup_status): New enum.
+
+ * src/androidterm.c (handle_one_android_event): Synchronize IM
+ lookup code with X.
+
+ * src/coding.c (from_unicode_buffer): Implement on Android.
+
+ * src/coding.h:
+ * src/sfnt.c: Fix commentary.
+
+2023-02-11 Po Lu <luangruo@yahoo.com>
+
+ * java/org/gnu/emacs/EmacsActivity.java (onDestroy)
+ (onWindowFocusChanged): Keep track of the last focused activity.
+
+ * java/org/gnu/emacs/EmacsDialog.java (display1): Use it if there
+ is no current focus.
+
+2023-02-10 Po Lu <luangruo@yahoo.com>
+
+ * .gitignore: Add org/gnu/emacs/R.java.
+
+ * cross/Makefile.in (top_builddir): Include verbose.mk. Rewrite
+ rules to print nice looking statements.
+
+ * doc/emacs/android.texi (Android, Android Startup)
+ (Android Environment, Android Windowing, Android Fonts):
+ * doc/emacs/emacs.texi (Top): Add an extra ``Android
+ Troubleshooting'' node and move troubleshooting details there.
+
+ * java/Makefile.in: Generate R.java; improve appearance by using
+ verbose.mk.
+
+ * java/org/gnu/emacs/EmacsPreferencesActivity.java: Reimplement in
+ terms of PreferencesActivity.
+
+ * java/org/gnu/emacs/EmacsView.java (handleDirtyBitmap): Avoid
+ flicker.
+
+ * java/res/xml/preferences.xml: New file.
+
+ * src/verbose.mk.in (AM_V_AAPT, AM_V_SILENT): New variables.
+
+ * java/org/gnu/emacs/EmacsDocumentsProvider.java (queryRoots):
+ Implement isChild.
+ (getNotificationUri, notifyChange): New functions.
+ (queryDocument1): Set rename and remove flags.
+ (queryDocument, queryChildDocuments): Allow the requester to
+ detect changes in the directory hierarchy.
+ (createDocument, deleteDocument, removeDocument): Signal changes
+ to the directory hierarchy.
+
+ * java/org/gnu/emacs/EmacsCopyArea.java (perform): Fix typo.
+
+ * java/org/gnu/emacs/EmacsSurfaceView.java
+ (reconfigureFrontBuffer): Don't use function only present on
+ Android 8.0 and later.
+
+ * doc/emacs/android.texi (Android Windowing): Remove yet another
+ limitation.
+
+ * java/debug.sh: Make this work on systems which prohibit
+ attaching to app processes from adbd.
+
+ * java/org/gnu/emacs/EmacsCopyArea.java (perform): Avoid creating
+ copies whenever possible.
+
+ * java/org/gnu/emacs/EmacsSurfaceView.java (EmacsSurfaceView):
+ Remove SurfaceView based implementation and use manual double
+ buffering with invalidate instead.
+
+ * java/org/gnu/emacs/EmacsView.java (EmacsView, handleDirtyBitmap)
+ (raise, lower, onDetachedFromWindow): Adjust accordingly.
+
+ * java/org/gnu/emacs/EmacsWindow.java (windowUpdated): Remove
+ function.
+
+ * src/sfntfont.c (sfntfont_open): Set font->max_width correctly.
+
+ * src/sfnt.c (IUP_SINGLE_PAIR): If i is initially more than end,
+ make it start.
+ (sfnt_verbose): Handle cases where interpreter->glyph_zone is
+ NULL.
+ (main): Update tests.
+ (sfnt_read_cmap_table): Fix typo.
+ (main): Update tests.
+
+2023-02-09 Po Lu <luangruo@yahoo.com>
+
+ * java/AndroidManifest.xml.in: Declare the new documents provider.
+
+ * java/README: Describe the meaning of files in res/values.
+
+ * java/org/gnu/emacs/EmacsDocumentsProvider.java: New file.
+
+ * java/res/values-v19/bool.xml:
+ * java/res/values/bool.xml: New files.
+
+ * src/sfnt.c (main): Update tests.
+
+ * src/sfnt.c (sfnt_read_simple_glyph, sfnt_read_compound_glyph)
+ (sfnt_read_glyph): Take size_t offsets.
+ (struct sfnt_compound_glyph_context)
+ (sfnt_expand_compound_glyph_context)
+ (sfnt_decompose_compound_glyph): Take size_t contour offsets.
+ (sfnt_decompose_glyph): Always close contour even if the first
+ point isn't on-curve.
+ (sfnt_build_outline_edges): Fix coding style.
+ (sfnt_interpret_iup): Skip phantom points during IUP.
+ (sfnt_decompose_instructed_outline): Clarify documentation.
+ Always close contour even if the first point isn't on-curve.
+ (struct sfnt_test_dcontext, sfnt_test_move_to, sfnt_test_line_to)
+ (sfnt_test_curve_to, sfnt_transform_f26dot6, sfnt_test_get_glyph)
+ (sfnt_test_free_glyph, sfnt_test_span, sfnt_test_edge_ignore)
+ (sfnt_interpret_compound_glyph_2, sfnt_test_edges, main): Update
+ tests.
+
+ * src/sfnt.h: Export new function.
+
+ * src/sfntfont.c (sfntfont_get_glyph_outline): Handle compound
+ glyphs.
+ (sfntfont_measure_instructed_pcm, sfntfont_measure_pcm)
+ (sfntfont_draw): Update accordingly.
+
+2023-02-08 Po Lu <luangruo@yahoo.com>
+
+ * src/sfnt.c (SCFS): Fix order of arguments.
+ (sfnt_normalize_vector): Make sure vx and vy are within a
+ reasonable range.
+ (sfnt_move): Don't move when vectors are orthogonal.
+ (main): Update.
+
+ * doc/emacs/android.texi (Android Startup): Fix typos.
+
+ * src/sfnt.c (sfnt_interpret_msirp): Fix order in which operands
+ to MSIRP are popped.
+ (main): Reduce ppem values.
+
+ * doc/lispref/frames.texi (On-Screen Keyboards): Describe return
+ value of `frame-toggle-on-screen-keyboard'.
+
+ * java/org/gnu/emacs/EmacsSurfaceView.java (surfaceChanged)
+ (surfaceCreated): Remove purposeless synchronization code. The
+ framework doesn't seem to consult this at all.
+
+ * java/org/gnu/emacs/EmacsView.java (onLayout): Lay out the window
+ after children.
+ (swapBuffers): Properly implement `force'.
+ (windowUpdated): Delete function.
+
+ * lisp/frame.el (frame-toggle-on-screen-keyboard): Return whether
+ or not the on screen keyboard might've been displayed.
+
+ * lisp/minibuffer.el (minibuffer-on-screen-keyboard-timer)
+ (minibuffer-on-screen-keyboard-displayed)
+ (minibuffer-setup-on-screen-keyboard)
+ (minibuffer-exit-on-screen-keyboard): Improve OSK dismissal when
+ there are consecutive minibuffers.
+
+ * lisp/touch-screen.el (touch-screen-window-selection-changed):
+ New function.
+ (touch-screen-handle-point-up): Register it as a window selection
+ changed function.
+
+ * src/android.c (struct android_emacs_window)
+ (android_init_emacs_window): Remove references to `windowUpdated'.
+ (android_window_updated): Delete function.
+
+ * src/android.h (struct android_output): Remove
+ `last_configure_serial'.
+
+ * src/androidterm.c (handle_one_android_event)
+ (android_frame_up_to_date):
+
+ * src/androidterm.h (struct android_output): Remove frame
+ synchronization, as that does not work on Android.
+
+ * src/sfntfont.c (sfntfont_get_glyph_outline): Take new argument
+ STATE and restore it prior to instructing the glyph.
+ (sfntfont_measure_instructed_pcm, sfntfont_measure_pcm)
+ (sfntfont_draw): Adjust accordingly.
+ (sfntfont_measure_instructed_pcm)
+ (sfntfont_measure_pcm): Ceil rbearing value.
+
+ * src/sfnt.c (sfnt_build_glyph_outline): Clear
+ build_outline_context.
+ (sfnt_poly_coverage): Extend coverage map.
+ (sfnt_prepare_raster): Always floor coordinates, since the
+ increase in coverage makes this hack unnecessary.
+ (sfnt_build_outline_edges): Likewise.
+ (sfnt_compare_edges): Remove function.
+ (sfnt_edge_sort): New function. Since edges are already partially
+ sorted, and there are not many, insertion sort suffices.
+ (sfnt_poly_edges): Use sfnt_edge_sort.
+ (sfnt_fill_span): Stop rounding x0 and x1 to the grid, and make
+ coverage computation static.
+ (sfnt_lookup_glyph_metrics): Fix return code for unscaled metrics.
+ (sfnt_scale_metrics): New function.
+ (SFNT_ENABLE_HINTING): Remove define.
+ (struct sfnt_cvt_table, struct sfnt_fpgm_table)
+ (struct sfnt_prep_table): Move to sfnt.h.
+ (sfnt_read_cvt_table, sfnt_read_fpgm_table, sfnt_read_prep_table):
+ Make TEST_STATIC.
+ (struct sfnt_unit_vector, struct sfnt_interpreter_definition)
+ (struct sfnt_interpreter_zone, struct sfnt_graphics_state):
+ (struct sfnt_interpreter): Move to sfnt.h.
+ (sfnt_make_interpreter): Make TEST_STATIC.
+ (POP, PUSH, DELTAP1, DELTAP2, DELTAP3): When TEST, define to
+ regular push and pop.
+ (sfnt_deltac, sfnt_deltap): Fix order of arguments.
+ (IUP_SINGLE_PAIR): Fix interpolation loop wraparound.
+ (sfnt_interpret_font_program)
+ (sfnt_interpret_control_value_program): Make TEST_STATIC.
+ (struct sfnt_instructed_outline): Move to sfnt.h.
+ (sfnt_build_instructed_outline): Make TEST_STATIC.
+ (sfnt_interpret_simple_glyph, sfnt_x_raster, sfnt_test_raster)
+ (all_tests, sfnt_verbose, main): Improve test code.
+
+ * src/sfnt.h (SFNT_ENABLE_HINTING, struct sfnt_cvt_table)
+ (struct sfnt_fpgm_table, struct sfnt_prep_table)
+ (struct sfnt_unit_vector, struct sfnt_interpreter_definition)
+ (struct sfnt_interpreter_zone, struct sfnt_graphics_state)
+ (struct sfnt_interpreter, struct sfnt_instructed_outline)
+ (PROTOTYPE): New definitions.
+
+ * src/sfntfont-android.c (sfntfont_android_put_glyphs): Make
+ coordinate generation more straightforward.
+
+ * src/sfntfont.c (sfntfont_get_glyph_outline): New arguments
+ INTERPRETER and METRICS.
+ (struct sfnt_font_info): New tables.
+ (sfntfont_setup_interpreter): New function.
+ (sfntfont_open): Avoid memory leak. Set up interpreter.
+ (sfntfont_measure_instructed_pcm): New function.
+ (sfntfont_measure_pcm): Delegate to measure_instructed_pcm where
+ appropriate.
+ (sfntfont_close): Free new tables.
+ (sfntfont_draw): Scale metrics properly.
+
+2023-02-07 Po Lu <luangruo@yahoo.com>
+
+ * src/sfnt.c (sfnt_name_instruction): Remove junk from instruction
+ table.
+ (sfnt_step_edge, sfnt_step_edge_n)
+ (sfnt_build_outline_edges, sfnt_test_edge, main):
+ * src/sfnt.h (struct sfnt_edge): Stop using error corrected line
+ drawing, as it's actually slower.
+
+ * INSTALL.android: Describe patches for BoringSSL on ARM.
+
+ * src/sfnt.c (sfnt_build_glyph_outline): Remove redundant
+ multiplication.
+ (sfnt_prepare_raster): Update offset calculation for changes.
+ (sfnt_step_edge, sfnt_step_edge_n): Handle bresenham terms.
+ (sfnt_build_outline_edges): Don't subtract floored xmin, just
+ xmin.
+ (sfnt_saturate_short): Make clang generate better code.
+ (sfnt_fill_span): Stop rounding coordinates.
+ (sfnt_poly_span): Poly consecutive on transitions all in one go.
+ (sfnt_lookup_glyph_metrics): Remove redundant multiplication.
+ (struct sfnt_interpreter): New hooks for debugging.
+ (sfnt_large_integer_add): New function.
+ (sfnt_mul_f26dot6_fixed): Round product.
+ (sfnt_make_interpreter): Remove redundant multiplication.
+ (CHECK_STACK_ELEMENTS, POP_UNCHECKED, PUSH_UNCHECKED): New macros.
+ (MOVE, POP, SWAP, CINDEX, RS, RCVT, LT, LTEQ, GT, GTEQ, EQ, NEQ)
+ (EVEN, AND, OR, NOT, ADD, SUB, DIV, MUL, ABS, NEG, FLOOR, CEILING)
+ (GETINFO, ROLL, _MAX, _MIN, ROUND, NROUND, GC, MD): Don't check SP
+ redundantly, especially when pushing an element right after
+ popping one.
+ (sfnt_move_glyph_zone): Don't touch points by passing NULL as
+ flags.
+ (sfnt_direct_move_zp2): Touch P in the directions of the movement.
+ (sfnt_interpret_scfs): Fix coding style.
+ (sfnt_interpret_simple_glyph): Don't round Y coordinates.
+ (sfnt_test_span, sfnt_test_edges, sfnt_debug_edges)
+ (sfnt_test_edge)
+ (sfnt_x_raster, sfnt_test_raster, rcvt_test_args)
+ (deltac1_test_args, deltac2_test_args, deltac3_test_args)
+ (roll_1_test_args, sfnt_run_hook, sfnt_identify_instruction)
+ (sfnt_verbose, main): Improve debug code and tests.
+
+ * src/sfnt.h (struct sfnt_edge): Add bresenham terms.
+
+2023-02-06 Po Lu <luangruo@yahoo.com>
+
+ * java/org/gnu/emacs/EmacsNative.java
+ (EmacsNative) <static constructor>: Load every native library on
+ which Emacs depends prior to loading libemacs itself.
+
+ * java/org/gnu/emacs/EmacsOpenActivity.java (readEmacsClientLog)
+ (startEmacsClient): Don't use redirectError on Android 7.1 and
+ earlier.
+
+ * configure.ac: Pass ANDROID_CFLAGS to ndk_INIT.
+
+ * cross/ndk-build/Makefile.in (NDK_BUILD_CFLAGS):
+ * cross/ndk-build/ndk-build-shared-library.mk
+ ($(call objname,$(LOCAL_MODULE),$(basename $(1)))):
+ ($$(error Unsupported suffix):
+ * cross/ndk-build/ndk-build-static-library.mk
+ ($(call objname,$(LOCAL_MODULE),$(basename $(1)))):
+ ($$(error Unsupported suffix): Use NDK_BUILD_CFLAGS.
+
+ * m4/ndk-build.m4 (ndk_INIT): Accept cflags.
+ (ndk_CONFIG_FILES): Export NDK_BUILD_CFLAGS.
+
+ * java/AndroidManifest.xml.in: Prevent the Emacs activity from
+ being overlaid by the emacsclient wrapper.
+ * java/org/gnu/emacs/EmacsOpenActivity.java (run): Likewise.
+ (onCreate): Set an appropriate theme on ICS and up.
+
+ * java/org/gnu/emacs/EmacsWindow.java (onTouchEvent): Handle
+ ACTION_CANCEL correctly.
+
+ * src/sfnt.c (struct sfnt_build_glyph_outline_context)
+ (sfnt_build_glyph_outline, sfnt_fill_span): Improve glyph
+ appearance by rounding coordinate values.
+ (struct sfnt_interpreter): New fields `twilight_original_x',
+ `twilight_original_y'.
+ (sfnt_make_interpreter): Set new fields.
+ (DELTAP1, DELTAP2, DELTAP3, SVTCAy, SPVTL, SFVTL, MD): Implement
+ instructions.
+ (sfnt_save_projection_vector): New argument `dual_only'. All
+ callers changed.
+ (sfnt_address_zp2, sfnt_address_zp1, sfnt_address_zp0): Obtain
+ original positions in the twilight zone as well.
+ (sfnt_check_zp1, sfnt_interpret_fliprgoff)
+ (sfnt_interpret_fliprgon)
+ (sfnt_interpret_flippt, sfnt_interpret_scfs, sfnt_interpret_miap)
+ (sfnt_interpret_alignrp, sfnt_line_to_vector, P)
+ (sfnt_interpret_msirp, sfnt_interpret_ip, sfnt_interpret_call)
+ (load_point, sfnt_interpret_iup_1, sfnt_interpret_iup)
+ (sfnt_interpret_run, struct sfnt_scaled_outline)
+ (struct sfnt_instructed_outline)
+ (sfnt_decompose_instructed_outline)
+ (sfnt_build_instructed_outline, sfnt_compute_phantom_points)
+ (sfnt_interpret_simple_glyph, all_tests, sfnt_setup_debugger)
+ (sfnt_name_instruction, sfnt_draw_debugger, sfnt_run_hook)
+ (sfnt_verbose, main): Make glyph instructing work.
+
+ * src/sfnt.h (SFNT_POLY_ROUND): New enumerator.
+
+2023-02-05 Po Lu <luangruo@yahoo.com>
+
+ * INSTALL.android: Explain how to build selinux.
+
+ * configure.ac: Enable selinux on Android.
+
+ * cross/ndk-build/ndk-build-shared-library.mk
+ ($(call objname,$(LOCAL_MODULE),$(basename $(1))))
+ ($$(error Unsupported suffix))
+ (NDK_CFLAGS_$(LOCAL_MODULE)):
+ * cross/ndk-build/ndk-build-static-library.mk
+ ($(call objname,$(LOCAL_MODULE),$(basename $(1))))
+ ($$(error Unsupported suffix))
+ (NDK_CFLAGS_$(LOCAL_MODULE)): Correctly handle files with a .cc
+ suffix, and clang-specific asflags.
+
+ * cross/ndk-build/ndk-clear-vars.mk: Handle AOSP extensions
+ LOCAL_ADDITIONAL_DEPENDENCIES,
+ LOCAL_CLANG_ASFLAGS_$(NDK_BUILD_ARCH) and LOCAL_IS_HOST_MODULE.
+
+ * doc/emacs/android.texi (Android Startup): Explain emacsclient
+ wrapper.
+
+ * java/org/gnu/emacs/EmacsView.java (EmacsView): New flag
+ `isCurrentlyTextEditor'.
+ (showOnScreenKeyboard, hideOnScreenKeyboard): Set as appropriate.
+ (onCheckIsTextEditor): Return its value.
+
+ * lisp/touch-screen.el (touch-screen-handle-scroll): Don't ding
+ at buffer limits.
+
+ * m4/ndk-build.m4: Improve doc.
+
+ * src/Makefile.in (LIBSELINUX_CFLAGS): New variable.
+ (EMACS_CFLAGS): Add it.
+
+2023-02-05 Po Lu <luangruo@yahoo.com>
+
+ * m4, lib: Update from Gnulib.
+
+ * src/sfnt.c (struct sfnt_graphics_state, LOOPCALL, DELTAC3)
+ (PROJECT, SHPIX, sfnt_save_projection_vector, sfnt_check_zp0)
+ (sfnt_dual_project_vector, sfnt_interpret_scfs)
+ (sfnt_round_symmetric, sfnt_interpret_miap)
+ (sfnt_interpret_alignrp_1, sfnt_interpret_alignrp)
+ (sfnt_measure_distance, sfnt_interpret_msirp, sfnt_interpret_ip)
+ (sfnt_interpret_mdap, sfnt_deltap)
+ (sfnt_dual_project_onto_any_vector, sfnt_validate_gs)
+ (sfnt_set_projection_vector, sfnt_interpret_shp)
+ (sfnt_interpret_run, sfnt_check_sloop, main): Check in more WIP
+ font code.
+
+2023-02-04 Po Lu <luangruo@yahoo.com>
+
+ * doc/emacs/android.texi (Android File System):
+
+ * java/AndroidManifest.xml.in: Update with new activity. Remove
+ Android 10 restrictions through a special flag.
+
+ * java/org/gnu/emacs/EmacsNative.java (getProcName): New
+ function.
+
+ * java/org/gnu/emacs/EmacsOpenActivity.java: New file.
+
+ * java/org/gnu/emacs/EmacsService.java (getLibraryDirection):
+ Remove unused annotation.
+
+ * lib-src/emacsclient.c (decode_options): Set alt_display on
+ Android.
+
+ * src/android.c (android_proc_name): New function.
+ (getProcName): Export via JNI.
+
+ * doc/emacs/android.texi (Android Environment):
+
+ * java/AndroidManifest.xml.in: Add network state permissions.
+
+ * src/sfnt.c (sfnt_multiply_divide_signed)
+ (struct sfnt_interpreter_zone, struct sfnt_graphics_state)
+ (struct sfnt_interpreter, sfnt_mul_f2dot14)
+ (sfnt_interpret_trap, WCVTF)
+ (ALIGNPTS, sfnt_scale_by_freedom_vector, sfnt_interpret_utp)
+ (sfnt_address_zp2, sfnt_address_zp1, sfnt_address_zp0)
+ (sfnt_check_zp2, sfnt_move_zp0, sfnt_move_zp1)
+ (sfnt_move_glyph_zone, sfnt_move_twilight_zone)
+ (sfnt_direct_move_zp2, sfnt_interpret_alignpts)
+ (sfnt_interpret_isect, sfnt_line_to_vector, sfnt_deltac)
+ (sfnt_interpret_mdap, sfnt_interpret_call, sfnt_dot_fix_14)
+ (sfnt_move_x, sfnt_move_y, sfnt_move, sfnt_validate_gs)
+ (sfnt_interpret_shz, sfnt_interpret_shc, sfnt_interpret_shp)
+ (sfnt_interpret_iup_1, sfnt_interpret_iup, sfnt_interpret_run)
+ (sfnt_interpret_font_program)
+ (sfnt_interpret_control_value_program)
+ (sfnt_interpret_simple_glyph, jrot_test_args, jrof_test_args)
+ (all_tests, main): Check in more WIP code.
+
+2023-02-02 Po Lu <luangruo@yahoo.com>
+
+ * java/AndroidManifest.xml.in: Add new icon.
+
+ * java/Makefile.in (srcdir): New variable.
+ (JAVA_FILES, RESOURCE_FILES): Update variables.
+ (emacs.apk-in): Apply resources.
+
+ * java/README: Describe directory tree.
+
+ * java/res/drawable/emacs.png: New file.
+
+ * src/android.c (android_get_current_api_level): New function.
+
+ * src/android.h: Export it.
+
+ * src/sfntfont-android.c (init_sfntfont_android): Make device API
+ level detection always work.
+
+ * src/sfnt.c (sfnt_multiply_divide_signed): Add MAYBE_UNUSED.
+
+ * src/sfnt.c (xmalloc, xrealloc): Improve behavior upon allocation
+ failures during test.
+ (sfnt_table_names): Add prep.
+ (sfnt_transform_coordinates): Allow applying offsets during
+ coordinate transform.
+ (sfnt_decompose_compound_glyph): Defer offset computation until
+ any component compound glyph is loaded, then apply it during the
+ transform process.
+ (sfnt_multiply_divide): Make available everywhere. Implement on
+ 64 bit systems.
+ (sfnt_multiply_divide_signed): New function.
+ (sfnt_mul_fixed): Fix division overflow.
+ (sfnt_curve_to_and_build_1, sfnt_build_glyph_outline): Remove
+ outdated comment.
+ (sfnt_build_outline_edges): Fix coding style.
+ (sfnt_lookup_glyph_metrics): Allow looking up metrics without
+ scaling.
+ (struct sfnt_cvt_table): Fix type of cvt values.
+ (struct sfnt_prep_table): New structure.
+ (sfnt_read_cvt_table): Read cvt values in terms of fwords, not
+ longs (as Apple's doc seems to say).
+ (sfnt_read_fpgm_table): Fix memory allocation for font program
+ table.
+ (sfnt_read_prep_table): New function.
+ (struct sfnt_interpreter_zone): New structure.
+ (struct sfnt_interpreter_graphics_state): New fields `project',
+ `move', `vector_dot_product'. Rename to `sfnt_graphics_state'.
+ (struct sfnt_interpreter, sfnt_mul_f26dot6): Stop doing rounding
+ division.
+ (sfnt_init_graphics_state, sfnt_make_interpreter, MOVE, SSW, RAW)
+ (SDS, ADD, SUB, ABS, NEG, WCVTF, _MIN, S45ROUND, SVTCAx)
+ (sfnt_set_srounding_state, sfnt_skip_code)
+ (sfnt_interpret_unimplemented, sfnt_interpret_fdef)
+ (sfnt_interpret_idef, sfnt_interpret_if, sfnt_interpret_else)
+ (sfnt_round_none, sfnt_round_to_grid, sfnt_round_to_double_grid)
+ (sfnt_round_down_to_grid, sfnt_round_up_to_grid)
+ (sfnt_round_to_half_grid, sfnt_round_super, sfnt_validate_gs)
+ (sfnt_interpret_run, sfnt_interpret_font_program)
+ (struct sfnt_test_dcontext, sfnt_test_move_to, sfnt_test_line_to)
+ (sfnt_test_curve_to, sfnt_test_get_glyph, sfnt_test_free_glyph)
+ (sfnt_test_span, sfnt_test_edge_ignore, sfnt_test_edge)
+ (sfnt_test_raster, test_interpreter_profile, test_cvt_values)
+ (test_interpreter_cvt, test_interpreter_head)
+ (sfnt_make_test_interpreter, struct sfnt_interpreter_test)
+ (sfnt_run_interpreter_test, struct sfnt_generic_test_args)
+ (sfnt_generic_check, sfnt_check_srp0, sfnt_check_szp0)
+ (sfnt_check_sloop, struct sfnt_rounding_test_args)
+ (sfnt_check_rounding, sfnt_check_smd, sfnt_check_scvtci)
+ (sfnt_check_sswci, sfnt_check_ssw, sfnt_check_flipon)
+ (sfnt_check_flipoff, npushb_test_args, npushw_test_args)
+ (pushb_test_args, pushw_test_args, stack_overflow_test_args)
+ (stack_underflow_test_args, rtg_test_args)
+ (rtg_symmetric_test_args, rtg_1_test_args)
+ (rtg_1_symmetric_test_args, rthg_test_args, rthg_1_test_args)
+ (rtdg_test_args, rtdg_1_test_args, rtdg_2_test_args)
+ (rtdg_3_test_args, else_test_args, jmpr_test_args, dup_test_args)
+ (pop_test_args, clear_test_args, swap_test_args, depth_test_args)
+ (cindex_test_args, mindex_test_args, raw_test_args)
+ (loopcall_test_args, call_test_args, fdef_test_args)
+ (fdef_1_test_args, endf_test_args, ws_test_args, rs_test_args)
+ (wcvtp_test_args, rcvt_test_args, mppem_test_args, mps_test_args)
+ (debug_test_args, lt_test_args, all_tests, main): Implement more
+ instructions.
+
+ * src/sfnt.h (enum sfnt_table, struct sfnt_glyph_metrics): Add new
+ tables. Add comment.
+
+2023-01-30 Po Lu <luangruo@yahoo.com>
+
+ * cross/ndk-build/ndk-build-shared-library.mk
+ ($(call objname,$(LOCAL_MODULE),$(basename $(1)))):
+ * cross/ndk-build/ndk-build-static-library.mk
+ ($(call objname,$(LOCAL_MODULE),$(basename $(1)))): Revert broken
+ typo fixes.
+
+ * src/sfnt.c (TEST_STATIC): Define ARRAYELTS.
+ (sfnt_table_names): New CVT and FPGM tables.
+ (sfnt_decompose_compound_glyph, sfnt_decompose_glyph)
+ (struct sfnt_large_integer, sfnt_multiply_divide_1)
+ (sfnt_count_leading_zero_bits, sfnt_multiply_divide_2)
+ (sfnt_multiply_divide, sfnt_mul_fixed, sfnt_div_fixed)
+ (sfnt_ceil_fixed, sfnt_build_glyph_outline): Fix fixed point
+ multiplication routines on systems without 64 bit long long
+ type.
+ (SFNT_ENABLE_HINTING, struct sfnt_test_dcontext, sfnt_test_move_to)
+ (sfnt_test_line_to, sfnt_test_curve_to, sfnt_test_get_glyph)
+ (sfnt_test_free_glyph, sfnt_test_span, sfnt_test_edge_ignore)
+ (sfnt_read_cvt_table, sfnt_test_edge, sfnt_test_raster)
+ (sfnt_read_fpgm_table, struct sfnt_unit_vector)
+ (struct sfnt_interpreter_definition)
+ (struct sfnt_interpreter_graphics_state, struct sfnt_interpreter)
+ (sfnt_div_f26dot6, sfnt_mul_f26dot6, sfnt_floor_f26dot6)
+ (sfnt_ceil_f26dot6, sfnt_round_f26dot6, sfnt_init_graphics_state)
+ (sfnt_make_interpreter, enum sfnt_interpreter_run_context)
+ (sfnt_interpret_trap, STACKSIZE, sfnt_set_srounding_state)
+ (sfnt_skip_code, sfnt_interpret_unimplemented, sfnt_interpret_fdef)
+ (sfnt_interpret_idef, sfnt_interpret_if, sfnt_interpret_else)
+ (sfnt_round_none, sfnt_round_to_grid, sfnt_round_to_double_grid)
+ (sfnt_round_down_to_grid, sfnt_round_up_to_grid)
+ (sfnt_round_to_half_grid, sfnt_round_super, sfnt_validate_gs)
+ (sfnt_interpret_run, sfnt_interpret_font_program)
+ (test_interpreter_profile, test_cvt_values, test_interpreter_cvt)
+ (test_interpreter_head, sfnt_make_test_interpreter)
+ (struct sfnt_interpreter_test, sfnt_run_interpreter_test)
+ (struct sfnt_generic_test_args, sfnt_generic_check)
+ (sfnt_check_srp0, sfnt_check_szp0, sfnt_check_sloop)
+ (struct sfnt_rounding_test_args, sfnt_check_rounding)
+ (sfnt_check_smd, sfnt_check_scvtci, sfnt_check_sswci)
+ (sfnt_check_ssw, sfnt_check_flipon, sfnt_check_flipoff)
+ (npushb_test_args, npushw_test_args, pushb_test_args)
+ (pushw_test_args, stack_overflow_test_args)
+ (stack_underflow_test_args, rtg_test_args, rtg_symmetric_test_args)
+ (rtg_1_test_args, rtg_1_symmetric_test_args, rthg_test_args)
+ (rthg_1_test_args, rtdg_test_args, rtdg_1_test_args)
+ (rtdg_2_test_args, rtdg_3_test_args, else_test_args)
+ (jmpr_test_args, dup_test_args, pop_test_args, clear_test_args)
+ (swap_test_args, depth_test_args, cindex_test_args)
+ (mindex_test_args, raw_test_args, loopcall_test_args)
+ (call_test_args, fdef_test_args, fdef_1_test_args, endf_test_args)
+ (ws_test_args, rs_test_args, wcvtp_test_args, rcvt_test_args)
+ (mppem_test_args, mps_test_args, debug_test_args, lt_test_args)
+ (all_tests, main): Check in WIP hinting code.
+
+ * src/sfnt.h (enum sfnt_table): Add `cvt ' and `fpgm' tables.
+
+2023-01-29 Po Lu <luangruo@yahoo.com>
+
+ * .gitignore: Add missing Gnulib files.
+
+ * INSTALL.android (module_target): Clarify documentation.
+
+ * cross/ndk-build/ndk-build-shared-library.mk:
+ * cross/ndk-build/ndk-build-static-library.mk: Fix building Neon
+ objects.
+
+ * java/AndroidManifest.xml.in: Add a version code.
+
+2023-01-28 Po Lu <luangruo@yahoo.com>
+
+ * java/org/gnu/emacs/EmacsService.java (restartEmacs): New
+ function.
+
+ * src/android.c (struct android_emacs_service)
+ (android_init_emacs_service): Add new method.
+ (android_restart_emacs): New function.
+
+ * src/android.h: Update prototypes.
+
+ * src/emacs.c (Fkill_emacs): Call android_restart_emacs whenever
+ appropriate.
+
+ * INSTALL.android: Document how to build with libtiff.
+
+ * build-aux/ndk-build-helper-1.mk (NDK_SO_NAME):
+ * build-aux/ndk-build-helper-2.mk (NDK_A_NAME):
+ * build-aux/ndk-build-helper-4.mk: Decrease number of duplicate
+ dependencies found.
+
+ * configure.ac (ANDROID_SDK_18_OR_EARLIER, XCONFIGURE, PNG_CFLAGS)
+ (HAVE_TIFF): Allow using libtiff on Android.
+
+ * cross/ndk-build/ndk-clear-vars.mk: Undefine additional
+ variables.
+
+ * cross/ndk-build/ndk-resolve.mk: Split CFLAGS resolution from
+ a-name resolution, and do not recursively add archive or shared
+ object names for dependencies of shared libraries.
+
+ * src/Makefile.in (TIFF_CFLAGS): New variable.
+ (EMACS_CFLAGS): Use it.
+
+2023-01-28 Po Lu <luangruo@yahoo.com>
+
+ * src/image.c (syms_of_image): Fix typo.
+
+ * doc/emacs/android.texi (Android File System): Describe an easier
+ way to disable scoped storage.
+
+ * java/AndroidManifest.xml.in: Add new permission to allow that.
+
+ * java/README: Add more text describing Java.
+
+ * java/org/gnu/emacs/EmacsContextMenu.java (Item): New fields
+ `isCheckable' and `isChecked'.
+ (EmacsContextMenu, addItem): New arguments.
+ (inflateMenuItems): Set checked status as appropriate.
+
+ * java/org/gnu/emacs/EmacsCopyArea.java (perform): Disallow
+ operations where width and height are less than or equal to zero.
+
+ * lisp/menu-bar.el (menu-bar-edit-menu): Make
+ execute-extended-command available as a menu item.
+
+ * src/androidmenu.c (android_init_emacs_context_menu)
+ (android_menu_show): Implement menu check boxes.
+
+ * src/menu.c (have_boxes): Treat Android builds as providing menu
+ checkboxes.
+
+2023-01-28 Po Lu <luangruo@yahoo.com>
+
+ * lisp/term/android-win.el (window-system-initialization): Create
+ default fontset.
+
+ * src/sfntfont.c (sfntfont_read_cmap, sfntfont_open): Fix leaks of
+ file descriptors.
+
+ * m4, lib: Update from Gnulib.
+
+ * INSTALL.android: Document support for gnutls and libgmp.
+
+ * build-aux/ndk-build-helper-1.mk (NDK_SO_NAMES, NDK_INCLUDES)
+ (SYSTEM_LIBRARIES):
+ * build-aux/ndk-build-helper-2.mk: Recursively resolve and add
+ shared library dependencies; even those of static libraries.
+
+ * build-aux/ndk-module-extract.awk: Fix makefile_imports code.
+
+ * configure.ac (ANDROID_SDK_18_OR_EARLIER, XCONFIGURE)
+ (LIBGMP_CFLAGS): Enable GMP and gnutls on Android.
+
+ * cross/ndk-build/Makefile.in (LOCAL_EXPORT_C_INCLUDES):
+ * cross/ndk-build/ndk-build-shared-library.mk:
+ * cross/ndk-build/ndk-clear-vars.mk:
+ * cross/ndk-build/ndk-resolve.mk (NDK_SYSTEM_LIBRARIES):
+ (NDK_LOCAL_EXPORT_C_INCLUDES_$(LOCAL_MODULE)):
+ (NDK_SO_EXTRA_FLAGS_$(LOCAL_MODULE)): Implement ``LOCAL_ASM_RULE''
+ and ``LOCAL_C_ADDITIONAL_FLAGS'' extensions for libgmp.
+
+ * doc/emacs/input.texi (Touchscreens): Document how to
+ horizontally scroll.
+
+ * java/org/gnu/emacs/EmacsActivity.java (attachWindow): Give the
+ view focus again if necessary.
+ (onPause): Call right super function.
+
+ * java/org/gnu/emacs/EmacsPreferencesActivity.java (onClick):
+ Clear dumpFileName lest Emacs try to load a nonexistent dump file.
+
+ * java/org/gnu/emacs/EmacsView.java (onDetachedFromWindow)
+ (onAttachedToWindow): Call super functions.
+ (onCreateInputConnection): Make sure the IME never obscures Emacs.
+
+ * java/org/gnu/emacs/EmacsWindow.java (onKeyDown, onKeyUp):
+ Improve tracking of quit keys.
+
+ * lisp/isearch.el (isearch-mode): Bring up the onscreen keyboard.
+
+ * lisp/touch-screen.el (touch-screen-current-tool): Add three
+ fields.
+ (touch-screen-handle-scroll): Allow hscrolling as well.
+ (touch-screen-handle-touch): Add additional fields to
+ `touch-screen-current-tool'.
+
+ * src/Makefile.in (LIBGMP_CFLAGS, EMACS_CFLAGS): Add new variable.
+
+ * src/android.c (android_run_select_thread, android_write_event):
+ Use pthread_cond_broadcast because pthread_cond_signal does
+ nothing on some Android versions/devices?
+
+2023-01-26 Po Lu <luangruo@yahoo.com>
+
+ * doc/emacs/input.texi (On-Screen Keyboards): Fix typo.
+
+ * INSTALL.android: Mention that apksigner is also required.
+
+ * configure.ac: Correctly add cross/Makefile to SUBDIR_MAKEFILES.
+
+ * cross/Makefile.in (config.status): Depend on
+ $(top_srcdir)/config.status.
+
+ * doc/emacs/input.texi (On-Screen Keyboards): Document how to quit
+ without a physical keyboard.
+
+ * java/org/gnu/emacs/EmacsNative.java (quit): New function `quit'.
+
+ * java/org/gnu/emacs/EmacsWindow.java (EmacsWindow): New field
+ `lastVolumeButtonPress'.
+ (onKeyDown): Quit if necessary.
+
+ * m4/ndk-build.m4 (ndk_where_cc): Fix search if CC is not a single
+ word.
+
+ * src/android.c (android_open): Remove unused variable.
+ (quit): New function.
+
+ * src/androidmenu.c (android_process_events_for_menu): Allow
+ quitting the menu.
+
+ * src/xterm.c (handle_one_xevent, x_term_init, syms_of_xterm):
+ Implement features illustrated above, so they work on free
+ operating systems.
+
+ * src/xterm.h (struct x_display_info): New fields `quit_keysym',
+ `quit_keysym_time'.
+
+2023-01-26 Po Lu <luangruo@yahoo.com>
+
+ * INSTALL.android: Document how to install sqlite3.
+
+ * build-aux/ndk-build-helper-1.mk (SYSTEM_LIBRARIES):
+ * build-aux/ndk-build-helper-2.mk (SYSTEM_LIBRARIES): Add liblog
+ and libandroid.
+
+ * configure.ac (SQLITE3_LIBS, HAVE_SQLITE3)
+ (HAVE_SQLITE3_LOAD_EXTENSION): Support on Android.
+ (APKSIGNER): Look for this new required binary.
+
+ * cross/ndk-build/ndk-build-shared-library.mk (objname):
+ * cross/ndk-build/ndk-build-static-library.mk (objname): Avoid
+ duplicate rules by prefixing objects with module type.
+
+ * cross/ndk-build/ndk-build.mk.in (NDK_BUILD_SHARED): Fix
+ definition.
+
+ * cross/ndk-build/ndk-resolve.mk
+ (NDK_SO_EXTRA_FLAGS_$(LOCAL_MODULE)): Handle new system libraries.
+
+ * doc/emacs/android.texi (Android File System): Document Android
+ 10 system restriction.
+
+ * java/AndroidManifest.xml.in: Target Android API 33, not 28.
+
+ * java/Makefile.in (SIGN_EMACS_V2, APKSIGNER): New variables.
+ ($(APK_NAME)): Make sure to apply a ``version 2 signature'' to the
+ package as well.
+
+ * java/org/gnu/emacs/EmacsNative.java (EmacsNative): New
+ argument apiLevel.
+
+ * java/org/gnu/emacs/EmacsNoninteractive.java (main):
+ * java/org/gnu/emacs/EmacsThread.java (run): Pass API level.
+
+ * m4/ndk-build.m4 (ndk_package_mape): Add package mapping for
+ sqlite3.
+
+ * src/Makefile.in (SQLITE3_CFLAGS): New substitution.
+ (EMACS_CFLAGS): Add that variable.
+
+ * src/android.c (android_api_level): New variable.
+ (initEmacs): Set it.
+ (android_file_access_p): Make static.
+ (android_hack_asset_fd): Adjust for restrictions in Android 29 and
+ later.
+ (android_close_on_exec): New function.
+ (android_open): Adjust to not duplicate file descriptor even if
+ CLOEXEC.
+ (android_faccessat): Use fstatat at-func emulation.
+
+ * src/android.h: Update prototypes.
+
+ * src/dired.c (file_name_completion_dirp):
+ * src/fileio.c (file_access_p, Faccess_file): Now that
+ sys_faccessat takes care of everything, stop calling
+ android_file_access_p.
+
+2023-01-26 Po Lu <luangruo@yahoo.com>
+
+ * .gitignore: Ignore lib/math.h.
+
+ * INSTALL.android: Update accordingly.
+
+ * build-aux/ndk-build-helper-1.mk:
+ * build-aux/ndk-build-helper-2.mk:
+ * build-aux/ndk-build-helper.mk:
+ * build-aux/ndk-module-extract.awk: Handle C++ modules.
+ * configure.ac: Enable libxml2 on Android.
+
+ * cross/ndk-build/Makefile.in:
+ * cross/ndk-build/ndk-build-shared-library.mk:
+ * cross/ndk-build/ndk-build-static-library.mk:
+ * cross/ndk-build/ndk-build.mk.in:
+ * cross/ndk-build/ndk-resolve.mk: Fix dependency resolution of
+ includes.
+
+ * java/org/gnu/emacs/EmacsView.java (popupMenu): Fix minimum SDK
+ version for actual popup menus.
+ * lib/math.h: Delete file.
+
+ * m4/ndk-build.m4 (ndk_SEARCH_MODULE, ndk_CHECK_MODULES): Look for
+ nasm and C++ libraries.
+
+ * src/android.c (faccessat): Rename to `android_faccessat'.
+
+ * src/android.h: Update prototypes.
+
+ * src/dired.c (file_name_completion_dirp):
+ * src/fileio.c (file_access_p, Faccess_file, file_directory_p):
+ * src/lisp.h:
+ * src/lread.c (openp):
+ * src/process.c (allocate_pty): Use sys_faccessat.
+ * src/sysdep.c (sys_faccessat): New function.
+
+2023-01-26 Po Lu <luangruo@yahoo.com>
+
+ * cross/ndk-build/ndk-build.in: Delete unused file.
+
+2023-01-25 Po Lu <luangruo@yahoo.com>
+
+ * java/org/gnu/emacs/EmacsDrawLine.java: Fix this again.
+
+ * java/org/gnu/emacs/EmacsNoninteractive.java (main): Port to
+ Android 2.3.3.
+
+ * java/org/gnu/emacs/EmacsSdk11Clipboard.java: Port to Android
+ 4.0.3.
+
+ * java/org/gnu/emacs/EmacsService.java (getClipboardManager): New
+ function.
+
+ * src/alloc.c (find_string_data_in_pure): Fix Android alignment
+ issue.
+
+ * src/android-emacs.c (main): Port to Android 4.4.
+
+ * src/android.c (initEmacs): Align stack to 32 bytes, so it ends
+ up aligned to 16 even though gcc thinks the stack is already
+ aligned to 16 bytes.
+
+ * src/callproc.c (init_callproc): Use /system/bin/sh instead of
+ /bin/sh by default.
+
+ * cross/lib/math.h: Delete header.
+
+ * java/Makefile.in (emacs.apk-in): Don't call cp with empty args.
+
+ * java/org/gnu/emacs/EmacsDrawLine.java (perform): Fix for
+ PostScript filling semantics.
+
+ * src/Makefile.in (android-emacs): Build android-emacs directly.
+
+ * doc/emacs/android.texi (Android Startup, Android Environment):
+ Document that restrictions on starting Emacs have been lifted.
+
+ * java/README: Document Java for Emacs developers and how the
+ Android port works.
+
+ * java/org/gnu/emacs/EmacsApplication.java (EmacsApplication)
+ (findDumpFile): New function.
+ (onCreate): Factor out dump file finding functions to there.
+
+ * java/org/gnu/emacs/EmacsNative.java (EmacsNative): Update
+ function declarations.
+
+ * java/org/gnu/emacs/EmacsNoninteractive.java: New class.
+
+ * java/org/gnu/emacs/EmacsService.java (getApkFile)
+ (onCreate): Pass classpath to setEmacsParams.
+
+ * java/org/gnu/emacs/EmacsThread.java (run): Label as an
+ @Override.
+
+ * lisp/loadup.el: Don't dump on Android when noninteractive.
+
+ * lisp/shell.el (shell--command-completion-data): Handle
+ inaccessible directories.
+
+ * src/Makefile.in (android-emacs): Link with Gnulib.
+
+ * src/android-emacs.c (main): Implement to launch app-process and
+ then EmacsNoninteractive.
+
+ * src/android.c (setEmacsParams): New argument `class_path'.
+ Don't set stuff up when running noninteractive.
+
+ * src/android.h (initEmacs): Likewise.
+
+ * src/androidfont.c (init_androidfont):
+ * src/androidselect.c (init_androidselect): Don't initialize when
+ running noninteractive.
+
+ * src/emacs.c (load_pdump): New argument `dump_file'.
+ (android_emacs_init): Give new argument `dump_file' to
+ `load_pdump'.
+
+ * src/sfntfont-android.c (init_sfntfont_android): Don't initialize
+ when running noninteractive.
+
+ * admin/merge-gnulib (GNULIB_MODULES): Add printf-posix and
+ vasprintf-posix.
+
+ * m4, lib: Update from Gnulib.
+
+ * configure.ac (CFLAGS): Add -DHAVE_CONFIG_H.
+
+2023-01-24 Po Lu <luangruo@yahoo.com>
+
+ * doc/lispref/processes.texi (Subprocess Creation): Document
+ variables containing program names.
+
+ * etc/NEWS: Document new variables.
+
+ * java/Makefile.in (CROSS_BINS): Add missing etags binary.
+
+ * lisp/cedet/semantic/db-ebrowse.el
+ (semanticdb-create-ebrowse-database):
+ * lisp/gnus/mail-source.el (mail-source-movemail-program):
+ * lisp/hexl.el (hexl-program):
+ * lisp/htmlfontify.el (hfy-etags-bin):
+ * lisp/ielm.el (inferior-emacs-lisp-mode):
+ * lisp/mail/rmail.el (rmail-autodetect):
+ (rmail-insert-inbox-text):
+ * lisp/org/org-ctags.el (org-ctags-path-to-ctags):
+ * lisp/progmodes/cperl-mode.el (cperl-etags):
+ * lisp/speedbar.el (speedbar-fetch-etags-command):
+ * lisp/textmodes/reftex-global.el (reftex-create-tags-file): Use
+ new variables.
+
+ * src/callproc.c (syms_of_callproc): Introduce new variables
+ naming binaries redistributed with Emacs.
+
+ * INSTALL.android: Update documentation.
+
+ * build-aux/ndk-build-helper-1.mk: When building shared
+ libraries, do not link libemacs.so with dependent archive files.
+
+ * build-aux/ndk-build-helper-2.mk: Add whole archive dependencies
+ as well.
+
+ * configure.ac (HAVE_JPEG): Enable on Android.
+
+ * cross/ndk-build/ndk-build-shared-library.mk: Link the shared
+ object with archive file dependencies.
+
+ * cross/ndk-build/ndk-build-static-library.mk: Build all code
+ position-independently.
+
+ * cross/ndk-build/ndk-resolve.mk: Separately resolve a names of
+ archive and whole archive dependencies.
+
+ * src/Makefile.in (JPEG_CFLAGS): New variable.
+ (EMACS_CFLAGS): Add it.
+
+2023-01-24 Po Lu <luangruo@yahoo.com>
+
+ * INSTALL.android: Update.
+
+ * build-aux/ndk-build-helper-1.mk: Fix typo.
+
+ * configure.ac: Enable --with-json on Android.
+
+ * cross/ndk-build/ndk-build-shared-library.mk:
+ (NDK_CFLAGS_$(LOCAL_MODULE)):
+ (LOCAL_MODULE_FILENAME):
+ * cross/ndk-build/ndk-build-static-library.mk:
+ (ALL_OBJECT_FILES$(LOCAL_MODULE)):
+ (LOCAL_MODULE_FILENAME): Recursively resolve dependencies.
+ * cross/ndk-build/ndk-resolve.mk: New function.
+
+ * doc/emacs/android.texi (Android Startup): Document how Emacs is
+ dumped during initial startup.
+
+ * java/Makefile.in (filename): Fix build with multiple shared
+ libraries.
+
+ * java/README: Improve commentary.
+
+ * java/org/gnu/emacs/EmacsApplication.java (onCreate): Look and
+ set dump file.
+
+ * java/org/gnu/emacs/EmacsNative.java (getFingerprint): New
+ function getFingerprint.
+
+ * java/org/gnu/emacs/EmacsPreferencesActivity.java (onCreate):
+ Add option to erase the dump file.
+
+ * java/org/gnu/emacs/EmacsService.java (browseUrl): New function.
+
+ * java/org/gnu/emacs/EmacsThread.java (run): Specify dump file if
+ found.
+
+ * lisp/loadup.el: Always dump during loadup on Android.
+
+ * lisp/net/browse-url.el (browse-url--browser-defcustom-type)
+ (browse-url-default-browser, browse-url-default-android-browser):
+ New browse url type.
+
+ * m4/ndk-build.m4 (ndk_package_map): Map jansson to libjansson.
+
+ * src/android.c (struct android_emacs_service): New method
+ `browse_url'.
+ (getFingerprint): New function.
+ (android_init_emacs_service): Initialize new method.
+ (android_browse_url): New function.
+
+ * src/android.h: Update prototypes.
+
+ * src/androidselect.c (Fandroid_browse_url): New function.
+ (syms_of_androidselect): Define it.
+
+ * src/emacs.c (load_pdump): Eschew excessively elaborate dump file
+ location code on on Android.
+
+ * src/pdumper.c (Fdump_emacs_portable): Allow dumping while
+ interactive on Android.
+ (syms_of_pdumper): New variable `pdumper-fingerprint'.
+
+ * src/sfntfont-android.c (sfntfont_android_composite_bitmap): Fix
+ unused variables.
+
+2023-01-24 Po Lu <luangruo@yahoo.com>
+
+ * admin/merge-gnulib: Fix paths for rename.
+
+ * lib-src/Makefile.in (DONT_INSTALL, clean): Correctly define
+ asset-directory-tool.
+
+ * cross/Makefile.in (distclean bootstrap-clean): Remove Makefile.
+
+2023-01-24 Po Lu <luangruo@yahoo.com>
+
+ * .gitignore: Update with new files. Do not ignore std*.in.h.
+
+ * INSTALL.android: Explain how to build Emacs with external
+ dependencies.
+
+ * Makefile.in (xcompile, cross): Rename to `cross'.
+ (clean_dirs): Clean cross, not xcompile.
+
+ * README: Document new directories.
+
+ * build-aux/ndk-build-helper-1.mk:
+ * build-aux/ndk-build-helper-2.mk:
+ * build-aux/ndk-build-helper-3.mk:
+ * build-aux/ndk-build-helper-4.mk:
+ * build-aux/ndk-build-helper.mk (NDK_BUILD_DIR, my-dir):
+ * build-aux/ndk-module-extract.awk: New files.
+ * configure.ac: Set up libgif, libwebp, and libpng for ndk-build.
+
+ * cross/ndk-build/Makefile.in:
+ * cross/ndk-build/ndk-build-executable.mk:
+ * cross/ndk-build/ndk-build-shared-library.mk:
+ * cross/ndk-build/ndk-build-static-library.mk:
+ * cross/ndk-build/ndk-build.in:
+ * cross/ndk-build/ndk-build.mk.in:
+ * cross/ndk-build/ndk-clear-vars.mk:
+ * cross/ndk-build/ndk-prebuilt-shared-library.mk:
+ * cross/ndk-build/ndk-prebuilt-static-library.mk: New files.
+
+ * doc/emacs/android.texi (Android, Android Environment): Document
+ clipboard support on Android.
+
+ * doc/emacs/emacs.texi (Top): Update menus.
+
+ * etc/MACHINES: Document Android.
+
+ * java/AndroidManifest.xml.in: Respect new `--with-android-debug'
+ option.
+
+ * java/Makefile.in (CROSS_BINS, CROSS_LIBS): Adjust for rename.
+ Include ndk-build.mk.
+ (emacs.apk-in): Depend on shared libraries. Then, package shared
+ libraries.
+
+ * java/org/gnu/emacs/EmacsClipboard.java: New file.
+
+ * java/org/gnu/emacs/EmacsFontDriver.java: Update comment to say
+ this is unused.
+
+ * java/org/gnu/emacs/EmacsNative.java (sendExpose): New function
+ `sendExpose'.
+
+ * java/org/gnu/emacs/EmacsSdk11Clipboard.java:
+ * java/org/gnu/emacs/EmacsSdk8Clipboard.java: New files.
+
+ * java/org/gnu/emacs/EmacsView.java (handleDirtyBitmap)
+ (onDetachedFromWindow): When window is reattached, expose the
+ frame.
+
+ * lib/Makefile.in (VPATH, ALL_CFLAGS): Adjust for rename.
+
+ * lisp/term/android-win.el (android-clipboard-exists-p)
+ (android-get-clipboard, android-set-clipboard)
+ (android-clipboard-owner-p, android-primary-selection)
+ (android-get-clipboard-1, android-get-primary)
+ (android-selection-bounds, android-encode-select-string)
+ (gui-backend-get-selection, gui-backend-selection-exists-p)
+ (gui-backend-selection-owner-p, gui-backend-set-selection): New
+ functions.
+
+ * m4/ndk-build.m4: New file.
+
+ * src/Makefile.in (GIF_CFLAGS, ANDROID_LDFLAGS): New variables.
+ (EMACS_CFLAGS): Add GIF_CFLAGS. Include ndk-build.mk.
+ (libemacs.so): Depend on and link with required libraries.
+
+ * src/android.c (android_check_compressed_file): New function.
+ (android_open): Work around Android platform bug.
+ (sendExpose): New function.
+ (android_readdir): Set d_type if this is a directory.
+
+ * src/androidgui.h (enum android_event_type)
+ (struct android_expose_event, union android_event): Add expose
+ events.
+
+ * src/androidselect.c: New file.
+
+ * src/androidterm.c (handle_one_android_event) <ANDROID_EXPOSE>:
+ Handle exposures.
+
+ * src/androidterm.h: Update prototypes.
+
+ * src/emacs.c (android_emacs_init): Initialize androidselect.
+
+ * xcompile: Move to cross.
+ * cross: New directory.
+
+2023-01-21 Po Lu <luangruo@yahoo.com>
+
+ * doc/lispref/commands.texi (Touchscreen Events): Document
+ changes.
+
+ * lisp/touch-screen.el (touch-screen-current-tool): Update doc
+ string.
+ (touch-screen-precision-scroll): New user option.
+ (touch-screen-handle-scroll): Use traditional scrolling by
+ default.
+ (touch-screen-handle-touch): Adjust format of
+ touch-screen-current-tool.
+ (touch-screen-track-tap): Don't print waiting for events.
+ (touch-screen-track-drag): Likewise. Also, don't call UPDATE
+ until threshold is reached.
+ (touch-screen-drag-mode-line-1, touch-screen-drag-mode-line):
+ Improve window dragging.
+
+ * src/fileio.c (Fverify_visited_file_modtime): Fix fs check.
+
+2023-01-21 Po Lu <luangruo@yahoo.com>
+
+ * doc/emacs/android.texi (Android File System): Document that
+ ls-lisp is now used by default.
+
+ * java/org/gnu/emacs/EmacsThread.java (EmacsThread): Name the
+ thread something meaningful.
+
+ * lisp/loadup.el (featurep): Load ls-lisp on Android.
+
+ * lisp/ls-lisp.el (ls-lisp-use-insert-directory-program): Default
+ to off on Android.
+
+ * src/android.c (android_is_directory): New function.
+ (android_fstatat): Handle directories created by
+ `android_opendir'.
+ (android_open): Return meaningful file mode.
+ (struct android_dir): New fields `next', `asset_file' and `fd'.
+ (android_opendir): Populate those fields.
+ (android_dirfd): New function.
+ (android_closedir): Close file descriptor if set.
+ (android_lookup_asset_directory_fd): New function.
+
+ * src/android.h: Update prototypes.
+
+ * src/androidfont.c (androidfont_check_init): New function.
+ (androidfont_list, androidfont_match, androidfont_draw)
+ (androidfont_open_font, androidfont_close_font)
+ (androidfont_has_char, androidfont_encode_char)
+ (androidfont_text_extents, androidfont_list_family): Initialize
+ font driver if necessary.
+ (init_androidfont): Don't initialize Java font if necessary.
+
+ * src/dired.c (open_directory): Return android_dirfd if
+ appropriate.
+ (directory_files_internal, file_name_completion_dirp): Implement
+ correctly for Android.
+
+ * src/fileio.c (check_mutable_filename): New function.
+ (Fcopy_file, Fdelete_directory_internal, Fdelete_file)
+ (Frename_file, Fadd_name_to_file, Fmake_symbolic_link)
+ (Fset_file_modes, Fset_file_times, Ffile_newer_than_file_p)
+ (Fverify_visited_file_modtime, Fset_visited_file_modtime): Check
+ that files being written to do not lie in /assets.
+
+ * src/sfntfont-android.c (GET_SCANLINE_BUFFER)
+ (sfntfont_android_u255to256, sfntfont_android_over_8888_1)
+ (sfntfont_android_over_8888, sfntfont_android_composite_bitmap):
+ Optimize for 64-bit ARM devices.
+ (sfntfont_android_put_glyphs): Optimize away memset if background
+ need not be filled.
+
+2023-01-20 Po Lu <luangruo@yahoo.com>
+
+ * src/android.c (android_run_select_thread, android_select)
+ (android_ftruncate):
+ * src/android.h (ftruncate): Fix compilation on Android 16 and up.
+
+ * src/android.c (android_run_select_thread, android_init_events)
+ (android_select): Add alternative android_select implementation
+ for API 16 and lower.
+
+ * src/androidterm.c (handle_one_android_event): Fix
+ use-after-frees.
+
+ * xcompile/lib/gnulib.mk.in: Delete.
+
+2023-01-20 Po Lu <luangruo@yahoo.com>
+
+ * .gitignore: Don't ignore verbose.mk.android.
+
+ * doc/emacs/Makefile.in (EMACSSOURCES): Add android.texi and
+ input.texi.
+
+ * doc/emacs/android.texi (Android): Document support for the
+ on-screen keyboard.
+ (Android Startup): Document how to start Emacs with -Q on Android.
+ (Android Environment): Document how Emacs circumvents the system
+ ``task killer''. Document changes to frame deletion behavior.
+
+ * doc/emacs/emacs.texi (Top):
+ * doc/emacs/input.texi (Other Input Devices)
+ (On-Screen Keyboards): Document how to use Emacs with virtual
+ keyboards.
+
+ * doc/lispref/commands.texi (Touchscreen Events): Document changes
+ to `touch-screen-track-drag'.
+
+ * doc/lispref/frames.texi (Frames, On-Screen Keyboards): New node.
+
+ * java/AndroidManifest.xml.in: Add settings activity and
+ appropriate OSK adjustment mode.
+
+ * java/org/gnu/emacs/EmacsActivity.java (onCreate): Allow creating
+ Emacs with -Q.
+ (onDestroy): Don't remove if killed by the system.
+
+ * java/org/gnu/emacs/EmacsContextMenu.java (inflateMenuItems): Fix
+ context menus again.
+
+ * java/org/gnu/emacs/EmacsNative.java (EmacsNative): Make all
+ event sending functions return long.
+
+ * java/org/gnu/emacs/EmacsPreferencesActivity.java: New file.
+
+ * java/org/gnu/emacs/EmacsService.java (EmacsService)
+ (onStartCommand, onCreate, startEmacsService): Start as a
+ foreground service if necessary to bypass system restrictions.
+
+ * java/org/gnu/emacs/EmacsSurfaceView.java (EmacsSurfaceView):
+ * java/org/gnu/emacs/EmacsThread.java (run):
+ * java/org/gnu/emacs/EmacsView.java (onLayout)
+ (onDetachedFromWindow):
+ * java/org/gnu/emacs/EmacsWindow.java (viewLayout):
+ Implement frame resize synchronization.
+
+ * java/org/gnu/emacs/EmacsWindowAttachmentManager.java
+ (removeWindowConsumer): Adjust accordingly for changes to frame
+ deletion behavior.
+
+ * lisp/frame.el (android-toggle-on-screen-keyboard)
+ (frame-toggle-on-screen-keyboard): New functions.
+
+ * lisp/minibuffer.el (minibuffer-setup-on-screen-keyboard)
+ (minibuffer-exit-on-screen-keyboard): New functions.
+ (minibuffer-setup-hook, minibuffer-exit-hook): Add new functions
+ to hooks.
+
+ * lisp/touch-screen.el (touch-screen-relative-xy): Accept new
+ value of window `frame'. Return frame coordinates in that case.
+ (touch-screen-set-point-commands): New variable.
+ (touch-screen-handle-point-up): Respect that variable.
+ (touch-screen-track-drag): Return `no-drag' where appropriate.
+ (touch-screen-drag-mode-line-1, touch-screen-drag-mode-line):
+ Refactor to use `no-drag'.
+
+ * src/android.c (struct android_emacs_window): New methods. Make
+ all event sending functions return the event serial.
+ (android_toggle_on_screen_keyboard, android_window_updated): New
+ functions.
+
+ * src/android.h: Update prototypes.
+
+ * src/androidfns.c (Fandroid_toggle_on_screen_keyboard)
+ (syms_of_androidfns): New functions.
+
+ * src/androidgui.h (struct android_any_event)
+ (struct android_key_event, struct android_configure_event)
+ (struct android_focus_event, struct android_window_action_event)
+ (struct android_crossing_event, struct android_motion_event)
+ (struct android_button_event, struct android_touch_event)
+ (struct android_wheel_event, struct android_iconify_event)
+ (struct android_menu_event): Add `serial' fields.
+
+ * src/androidterm.c (handle_one_android_event)
+ (android_frame_up_to_date):
+
+ * src/androidterm.h (struct android_output): Implement frame
+ resize synchronization.
+
+ * xcompile/verbose.mk.android: New file.
+
+2023-01-19 Po Lu <luangruo@yahoo.com>
+
+ * .gitignore: Add new files.
+
+ * INSTALL.android: Explain how to build Emacs for ancient versions
+ of Android.
+
+ * admin/merge-gnulib (GNULIB_MODULES): Add getdelim.
+
+ * build-aux/config.guess (timestamp, version):
+ * build-aux/config.sub (timestamp, version): Autoupdate.
+
+ * configure.ac (BUILD_DETAILS, ANDROID_MIN_SDK):
+ (ANDROID_STUBIFY): Allow specifying CFLAGS via ANDROID_CFLAGS.
+ Add new configure tests for Android API version when not
+ explicitly specified.
+
+ * doc/emacs/android.texi (Android): Add reference to ``Other
+ Input Devices''.
+ (Android File System): Remove restrictions on directory-files on
+ the assets directory.
+
+ * doc/emacs/emacs.texi (Top): Add Other Input Devices to menu.
+
+ * doc/emacs/input.texi (Other Input Devices): New node.
+
+ * doc/lispref/commands.texi (Touchscreen Events): Document
+ changes to touchscreen input events.
+
+ * doc/lispref/frames.texi (Pop-Up Menus): Likewise.
+
+ * etc/NEWS: Announce changes.
+
+ * java/Makefile.in: Use lib-src/asset-directory-tool to generate
+ an `directory-tree' file placed in /assets.
+
+ * java/debug.sh: Large adjustments to support Android 2.2 and
+ later.
+
+ * java/org/gnu/emacs/EmacsContextMenu.java (inflateMenuItems):
+ * java/org/gnu/emacs/EmacsCopyArea.java (perform):
+ * java/org/gnu/emacs/EmacsDialog.java (toAlertDialog):
+ * java/org/gnu/emacs/EmacsDrawLine.java (perform):
+ * java/org/gnu/emacs/EmacsDrawRectangle.java (perform):
+ * java/org/gnu/emacs/EmacsDrawable.java (EmacsDrawable):
+ * java/org/gnu/emacs/EmacsFillPolygon.java (perform):
+ * java/org/gnu/emacs/EmacsFillRectangle.java (perform):
+ * java/org/gnu/emacs/EmacsGC.java:
+ * java/org/gnu/emacs/EmacsPixmap.java (destroyHandle):
+ * java/org/gnu/emacs/EmacsSdk7FontDriver.java (draw): Avoid
+ redundant canvas saves and restores.
+
+ * java/org/gnu/emacs/EmacsService.java (run):
+ * java/org/gnu/emacs/EmacsView.java (EmacsView):
+ (handleDirtyBitmap):
+ * java/org/gnu/emacs/EmacsWindow.java (changeWindowBackground)
+ (EmacsWindow): Make compatible with Android 2.2 and later.
+
+ * lib-src/Makefile.in (DONT_INSTALL): Add asset-directory-tool
+ on Android.
+ (asset-directory-tool${EXEEXT}): New target.
+
+ * lib-src/asset-directory-tool.c (struct directory_tree, xmalloc)
+ (main_1, main_2, main): New file.
+
+ * lib, m4: Merge from gnulib. This will be reverted before
+ merging to master.
+
+ * lisp/button.el (button-map, push-button):
+ * lisp/frame.el (display-popup-menus-p): Improve touchscreen
+ support.
+
+ * lisp/subr.el (event-start, event-end): Handle touchscreen
+ events.
+
+ * lisp/touch-screen.el (touch-screen-handle-timeout)
+ (touch-screen-handle-point-update, touch-screen-handle-point-up)
+ (touch-screen-track-tap, touch-screen-track-drag)
+ (touch-screen-drag-mode-line-1, touch-screen-drag-mode-line): New
+ function
+ ([mode-line touchscreen-begin])
+ ([bottom-divider touchscreen-begin]): Bind new events.
+
+ * lisp/wid-edit.el (widget-event-point, widget-keymap)
+ (widget-event-start, widget-button--check-and-call-button)
+ (widget-button-click): Improve touchscreen support.
+
+ * src/alloc.c (make_lisp_symbol): Avoid ICE on Android NDK GCC.
+ (mark_pinned_symbols): Likewise.
+
+ * src/android.c (struct android_emacs_window): New struct.
+ (window_class): New variable.
+ (android_run_select_thread): Add workaround for Android platform
+ bug.
+ (android_extract_long, android_scan_directory_tree): New
+ functions.
+ (android_file_access_p): Use those functions instead.
+ (android_init_emacs_window): New function.
+ (android_init_emacs_gc_class): Update signature of `markDirty'.
+ (android_change_gc, android_set_clip_rectangles): Tell the GC
+ whether or not clip rects were dirtied.
+ (android_swap_buffers): Do not look up method every time.
+ (struct android_dir): Adjust for new directory tree lookup.
+ (android_opendir, android_readdir, android_closedir): Likewise.
+ (android_four_corners_bilinear): Fix coding style.
+ (android_ftruncate): New function.
+
+ * src/android.h: Update prototypes. Replace ftruncate with
+ android_ftruncate when necessary.
+
+ * src/androidterm.c (handle_one_android_event): Pacify GCC. Fix
+ touch screen tool bar bug.
+
+ * src/emacs.c (using_utf8): Fix compilation error.
+
+ * src/fileio.c (Ffile_system_info): Return Qnil when fsusage.o
+ is not built.
+
+ * src/filelock.c (BOOT_TIME_FILE): Fix definition for Android.
+
+ * src/frame.c (Fx_parse_geometry): Fix uninitialized variable
+ uses.
+
+ * src/keyboard.c (lispy_function_keys): Fix `back'.
+
+ * src/menu.c (x_popup_menu_1): Handle touch screen events.
+ (Fx_popup_menu): Document changes.
+
+ * src/sfnt.c (main): Improve tests.
+
+ * src/sfntfont-android.c (sfntfont_android_put_glyphs): Fix
+ minor problem.
+ (init_sfntfont_android): Check for
+ HAVE_DECL_ANDROID_GET_DEVICE_API_LEVEL.
+
+ * src/sfntfont.c (struct sfnt_font_desc): New fields `adstyle' and
+ `languages'.
+ (sfnt_parse_style): Append tokens to adstyle.
+ (sfnt_parse_languages): New function.
+ (sfnt_enum_font_1): Parse supported languages and adstyle.
+ (sfntfont_list_1): Handle new fields.
+ (sfntfont_text_extents): Fix uninitialized variable use.
+ (syms_of_sfntfont, mark_sfntfont): Adjust accordingly.
+
+2023-01-17 Po Lu <luangruo@yahoo.com>
+
+ * doc/emacs/android.texi (Android Fonts): Document that TTC format
+ fonts are now supported.
+
+ * doc/emacs/emacs.texi (Top): Fix menus.
+
+ * doc/lispref/commands.texi (Touchscreen Events)
+ (Key Sequence Input): Document changes to touchscreen events.
+
+ * etc/DEBUG: Describe how to debug 64 bit binaries on Android.
+
+ * java/org/gnu/emacs/EmacsCopyArea.java (perform): Explicitly
+ recycle copy bitmap.
+
+ * java/org/gnu/emacs/EmacsDialog.java (EmacsDialog): New class.
+
+ * java/org/gnu/emacs/EmacsDrawRectangle.java (perform): Use 5
+ point PolyLine like X, because Android behaves like Postscript on
+ some devices and X elsewhere.
+
+ * java/org/gnu/emacs/EmacsFillRectangle.java (perform): Explicitly
+ recycle copy bitmap.
+
+ * java/org/gnu/emacs/EmacsPixmap.java (destroyHandle): Explicitly
+ recycle bitmap and GC if it is big.
+
+ * java/org/gnu/emacs/EmacsView.java (EmacsView): Make
+ `bitmapDirty' a boolean.
+ (handleDirtyBitmap): Reimplement in terms of that boolean.
+ Explicitly recycle old bitmap and GC.
+ (onLayout): Fix lock up.
+ (onDetachedFromWindow): Recycle bitmap and GC.
+
+ * java/org/gnu/emacs/EmacsWindow.java (requestViewLayout):
+ Update call to explicitlyDirtyBitmap.
+
+ * src/android.c (android_run_select_thread, android_select):
+ Really fix android_select.
+ (android_build_jstring): New function.
+
+ * src/android.h: Update prototypes.
+
+ * src/androidmenu.c (android_process_events_for_menu): Totally
+ unblock input before process_pending_signals.
+ (android_menu_show): Remove redundant unblock_input and debugging
+ code.
+ (struct android_emacs_dialog, android_init_emacs_dialog)
+ (android_dialog_show, android_popup_dialog, init_androidmenu):
+ Implement popup dialogs on Android.
+
+ * src/androidterm.c (android_update_tools)
+ (handle_one_android_event, android_frame_up_to_date): Allow
+ tapping tool bar items.
+ (android_create_terminal): Add dialog hook.
+ (android_wait_for_event): Adjust call to android_select.
+
+ * src/androidterm.h (struct android_touch_point): New field
+ `tool_bar_p'.
+
+ * src/keyboard.c (read_key_sequence, head_table)
+ (syms_of_keyboard): Prefix touchscreen events with posn.
+
+ * src/keyboard.h (EVENT_HEAD): Handle touchscreen events.
+
+ * src/process.c (wait_reading_process_output): Adjust call to
+ android_select.
+
+ * src/sfnt.c (sfnt_read_table_directory): If the first long turns
+ out to be ttcf, return -1.
+ (sfnt_read_ttc_header): New function.
+ (main): Test TTC support.
+
+ * src/sfnt.h (struct sfnt_ttc_header): New structure.
+ (enum sfnt_ttc_tag): New enum.
+
+ * src/sfntfont-android.c
+ (struct sfntfont_android_scanline_buffer): New structure.
+ (GET_SCANLINE_BUFFER): New macro. Try to avoid so much malloc
+ upon accessing the scanline buffer.
+ (sfntfont_android_put_glyphs): Do not use SAFE_ALLOCA to allocate
+ the scaline buffer.
+ (Fandroid_enumerate_fonts): Enumerate ttc fonts too.
+
+ * src/sfntfont.c (struct sfnt_font_desc): New field `offset'.
+ (sfnt_enum_font_1): Split out enumeration code from
+ sfnt_enum_font.
+ (sfnt_enum_font): Read TTC tables and enumerate each font therein.
+ (sfntfont_open): Seek to the offset specified.
+
+ * xcompile/Makefile.in (maintainer-clean): Fix depends here.
+
+2023-01-16 Po Lu <luangruo@yahoo.com>
+
+ * src/sfnt.c (sfnt_decompose_compound_glyph): Correct treatment of
+ the Y offset in components with ARG_1_AND_2_ARE_WORDS.
+ (main): Update debugging code.
+
+ * doc/emacs/android.texi (Android, Android Environment): Improve
+ documentation.
+
+ * doc/lispref/commands.texi (Touchscreen Events): Document changes
+ to touchscreen support.
+
+ * doc/lispref/display.texi (Defining Faces, Window Systems):
+ * doc/lispref/frames.texi (Frame Layout)
+ (Font and Color Parameters):
+ * doc/lispref/os.texi (System Environment): Document Android in
+ various places.
+
+ * java/org/gnu/emacs/EmacsWindow.java (figureChange): Fix crash.
+
+ * lisp/loadup.el ("touch-screen"): Load touch-screen.el.
+
+ * lisp/pixel-scroll.el: Autoload two functions.
+
+ * lisp/term/android-win.el: Add require 'touch-screen.
+
+ * lisp/touch-screen.el (touch-screen-current-tool)
+ (touch-screen-current-timer, touch-screen-delay)
+ (touch-screen-relative-xy, touch-screen-handle-scroll)
+ (touch-screen-handle-timeout, touch-screen-handle-point-update)
+ (touch-screen-handle-point-up, touch-screen-handle-touch)
+ (global-map, touch-screen): New file.
+
+ * src/android.c (android_run_debug_thread): Fix build on 64 bit
+ systems.
+ (JNICALL, android_put_pixel): Likewise.
+ (android_transform_coordinates, android_four_corners_bilinear)
+ (android_fetch_pixel_bilinear, android_project_image_bilinear)
+ (android_fetch_pixel_nearest_24, android_fetch_pixel_nearest_1)
+ (android_project_image_nearest): New functions.
+
+ * src/androidgui.h (struct android_transform): New structure.
+
+ * src/androidterm.c (android_note_mouse_movement): Remove obsolete
+ TODO.
+ (android_get_scale_factor): New function.
+ (android_draw_underwave): Scale underwave correctly.
+
+ * src/dispextern.h: Support native image transforms on Android.
+
+ * src/image.c (matrix_identity, matrix_rotate)
+ (matrix_mirror_horizontal, matrix_translate): New functions.
+ (image_set_transform): Implement native image transforms on
+ Android.
+ (Fimage_transforms_p): Implement on Android.
+
+ * src/keyboard.c (make_lispy_event, syms_of_keyboard): Handle
+ touch screen menu bar events.
+
+ * src/sfnt.c: Fix typo in comment.
+
+ * src/sfntfont-android.c (sfntfont_android_blend, U255TO256)
+ (sfntfont_android_put_glyphs): Prevent redundant swizzling.
+
+ * src/sfntfont.c (sfntfont_lookup_char): Fix build on 64 bit
+ systems.
+
+2023-01-15 Po Lu <luangruo@yahoo.com>
+
+ * java/org/gnu/emacs/EmacsActivity.java (onCreate): Set the
+ default theme to Theme.DeviceDefault.NoActionBar if possible.
+ (onContextMenuClosed): Add hack for Android bug.
+
+ * java/org/gnu/emacs/EmacsContextMenu.java (EmacsContextMenu)
+ (onMenuItemClick): Set flag upon submenu selection.
+ (inflateMenuItems): Set onClickListener for submenus as well.
+ (display1): Clear new flag.
+
+ * java/org/gnu/emacs/EmacsDrawRectangle.java (perform): Fix
+ rectangle bounds.
+
+ * java/org/gnu/emacs/EmacsNative.java (setEmacsParams): New
+ argument for the cache directory.
+
+ * java/org/gnu/emacs/EmacsService.java (onCreate): Pass cache
+ directory.
+ (sync): New function.
+
+ * src/android.c (struct android_emacs_service): New method `sync'.
+ (setEmacsParams, initEmacs): Handle cache directory.
+ (android_init_emacs_service): Initialize new method `sync'.
+ (android_sync): New function.
+
+ * src/androidfns.c (Fx_show_tip): Call both functions.
+
+ * src/androidgui.h: Update prototypes.
+
+ * src/androidmenu.c (struct android_menu_subprefix)
+ (android_free_subprefixes, android_menu_show): Handle submenu
+ prefixes correctly.
+
+ * src/androidterm.c (handle_one_android_event): Clear help echo
+ on MotionNotify like on X.
+
+ * src/menu.c (single_menu_item): Enable submenus on Android.
+
+2023-01-15 Po Lu <luangruo@yahoo.com>
+
+ * java/org/gnu/emacs/EmacsActivity.java (onContextMenuClosed):
+ New function.
+
+ * java/org/gnu/emacs/EmacsContextMenu.java (EmacsContextMenu): New
+ field `itemAlreadySelected'.
+ (onMenuItemClick): New function.
+ (inflateMenuItems): Attach onClickListener as appropriate.
+ (display1): Clear itemAlreadySelected.
+ (display): Fix runnable synchronization.
+
+ * java/org/gnu/emacs/EmacsNative.java (sendContextMenu): New
+ function.
+
+ * java/org/gnu/emacs/EmacsView.java (popupMenu):
+ (cancelPopupMenu): Set popupactive correctly.
+
+ * src/android.c (android_run_select_thread): Fix android_select
+ again.
+ (android_wait_event): New function.
+
+ * src/android.h: Update prototypes.
+ * src/androidgui.h (enum android_event_type): New
+ `ANDROID_CONTEXT_MENU' event.
+ (struct android_menu_event, union android_event): Add new event.
+
+ * src/androidmenu.c (struct android_emacs_context_menu): New
+ structure.
+ (android_init_emacs_context_menu): Add `dismiss' method.
+ (struct android_dismiss_menu_data): New structure.
+ (android_dismiss_menu, android_process_events_for_menu): New
+ functions.
+ (android_menu_show): Set an actual item ID.
+ (popup_activated): Define when stubify as well.
+ (Fmenu_or_popup_active_p): New function.
+ (syms_of_androidmenu): New function.
+
+ * src/androidterm.c (handle_one_android_event): Handle context
+ menu events.
+
+ * src/androidterm.h (struct android_display_info): New field for
+ menu item ID.
+
+ * src/emacs.c (android_emacs_init): Call syms_of_androidmenu.
+
+ * src/xdisp.c (note_mouse_highlight): Return if popup_activated on
+ Android as well.
+
+2023-01-14 Po Lu <luangruo@yahoo.com>
+
+ * src/android.c (android_run_select_thread, android_select):
+ Handle EINTR in sem_wait and fix sigsets.
+
+ * xcompile/lib/fpending.c (__fpending): Fix gnulib problem.
+
+ * xcompile/lib/fpending.c (__fpending):
+ * xcompile/lib/open.c:
+ * xcompile/lib/unistd.c (_GL_UNISTD_INLINE): Remove Android
+ patches.
+
+2023-01-14 Po Lu <luangruo@yahoo.com>
+
+ * java/Makefile.in (clean): Fix distclean and bootstrap-clean
+ rules.
+ * java/debug.sh (jdb_port, attach_existing, num_pids, line): Add
+ new options to upload a gdbserver binary to the device.
+
+ * java/org/gnu/emacs/EmacsActivity.java (EmacsActivity): Make
+ focusedActivities public.
+
+ * java/org/gnu/emacs/EmacsContextMenu.java: New file.
+
+ * java/org/gnu/emacs/EmacsDrawRectangle.java (perform): Fix
+ bounds computation.
+
+ * java/org/gnu/emacs/EmacsGC.java (markDirty): Expressly provide
+ stroke width.
+
+ * java/org/gnu/emacs/EmacsService.java (getLocationOnScreen)
+ (nameKeysym): New functions.
+
+ * java/org/gnu/emacs/EmacsView.java (<init>): Disable focus
+ highlight.
+ (onCreateContextMenu, popupMenu, cancelPopupMenu): New functions.
+
+ * java/org/gnu/emacs/EmacsWindow.java: Implement a kind of
+ ``override redirect'' window for tooltips.
+
+ * src/android.c (struct android_emacs_service): New method
+ `name_keysym'.
+ (android_run_select_thread, android_init_events):
+ (android_select): Release select thread on semaphores instead of
+ signals to avoid one nasty race on SIGUSR2 delivery.
+ (android_init_emacs_service): Initialize new method.
+ (android_create_window): Handle CW_OVERRIDE_REDIRECT.
+ (android_move_resize_window, android_map_raised)
+ (android_translate_coordinates, android_get_keysym_name)
+ (android_build_string, android_exception_check): New functions.
+
+ * src/android.h: Update prototypes.
+
+ * src/androidfns.c (android_set_parent_frame, Fx_create_frame)
+ (unwind_create_tip_frame, android_create_tip_frame)
+ (android_hide_tip, compute_tip_xy, Fx_show_tip, Fx_hide_tip)
+ (syms_of_androidfns): Implement tooltips and iconification
+ reporting.
+
+ * src/androidgui.h (enum android_window_value_mask): Add
+ CWOverrideRedirect.
+ (struct android_set_window_attributes): Add `override_redirect'.
+ (ANDROID_IS_MODIFIER_KEY): Recognize Caps Lock.
+
+ * src/androidmenu.c (struct android_emacs_context_menu): New
+ struct.
+ (android_init_emacs_context_menu, android_unwind_local_frame)
+ (android_push_local_frame, android_menu_show, init_androidmenu):
+ New functions.
+
+ * src/androidterm.c (handle_one_android_event): Fix NULL pointer
+ dereference.
+ (android_fullscreen_hook): Handle fullscreen correctly.
+ (android_draw_box_rect): Fix top line.
+ (get_keysym_name): Implement function.
+ (android_create_terminal): Remove scroll bar stubs and add menu
+ hook.
+
+ * src/androidterm.h: Update prototypes.
+ * src/emacs.c (android_emacs_init): Initialize androidmenu.c.
+ * xcompile/Makefile.in: Fix clean rules.
+
+2023-01-14 Po Lu <luangruo@yahoo.com>
+
+ * .gitignore: Add new files.
+
+ * INSTALL.android: New file.
+
+ * Makefile.in (clean_dirs): Clean xcompile as well.
+
+ * admin/merge-gnulib (avoided_flags): Import Gnulib into Android
+ directory as well.
+
+ * doc/emacs/android.texi (Android):
+ * doc/emacs/emacs.texi (Top): New node `Android'.
+
+ * java/org/gnu/emacs/EmacsThread.java (run): Use right executable
+ name.
+
+ * lib/Makefile.in (ANDROID_CFLAGS): Use better way to refer to
+ /src.
+ (vpath): Delete ugly block of vpath statements.
+ (mostlyclean): Remove Makefile.android.
+
+ * lib/fpending.c (__fpending):
+ * lib/open.c:
+ * lib/unistd.c (_GL_UNISTD_INLINE): Revert changes to gnulib in
+ lib/.
+
+ * src/android.h:
+ * src/androidterm.c: Fix build.
+ * xcompile/Makefile.in (LIB_SRCDIR, LIBSRC_BINARIES)
+ (src/verbose.mk, PRE_BUILD_DEPS, PHONY): Use gnulib in
+ xcompile/lib/ as opposed to lib/.
+
+ * xcompile/README: Adjust README.
+
+ * xcompile/lib: Check-in Gnulib with patches for Android.
+
+2023-01-13 Po Lu <luangruo@yahoo.com>
+
+ * java/org/gnu/emacs/EmacsService.java (queryTree): Fix NULL
+ pointer dereference.
+
+ * src/android.c (android_query_tree): Set *nchildren_return.
+
+ * .gitignore: Add AndroidManifest.xml.
+
+ * java/AndroidManifest.xml: Remove file that is now generated.
+
+ * src/frame.c (make_monitor_attribute_list): Allow source to be NULL.
+
+ * configure.ac (ANDROID_MIN_SDK): New variable.
+ (DX): Remove and replace with D8.
+ (XCONFIGURE): Check for the minimum version of Android the cross
+ compiler compiles for. Generate java/AndroidManifest.xml from
+ java/AndroidManifest.xml.in. Allow using Zlib on Android.
+
+ * java/AndroidManifest.xml.in: New file. Use the minimum SDK
+ detected by configure.
+
+ * java/Makefile.in (top_srcdir, version): New variables.
+ (DX, D8): Replace with D8.
+ (ANDROID_MIN_SDK, APK_NAME): New variables.
+ (.PHONY, .PRECIOUS, classes.dex, emacs.apk): Generate $(APK_NAME)
+ rather than `emacs.apk'.
+
+ * java/debug.sh: New option --attach-existing. Attach to an
+ existing Emacs instance when specified.
+
+ * java/org/gnu/emacs/EmacsActivity.java (EmacsActivity): New field
+ `isPaused'.
+ (invalidateFocus1): Fix infinite recursion.
+ (detachWindow): Deiconify window.
+ (attachWindow): Iconify the window if the activity is paused.
+ (onCreate): Use the ``no title bar'' theme.
+ (onPause, onResume): New functions.
+
+ * java/org/gnu/emacs/EmacsNative.java (sendTouchUp, sendTouchDown)
+ (sendTouchMove, sendWheel, sendIconified, sendDeiconified): New
+ functions.
+
+ * java/org/gnu/emacs/EmacsSdk7FontDriver.java (Sdk7Typeface):
+ (list): Remove logging for code that is mostly going to be unused.
+
+ * java/org/gnu/emacs/EmacsService.java (ringBell, queryTree)
+ (getScreenWidth, getScreenHeight, detectMouse): New functions.
+
+ * java/org/gnu/emacs/EmacsSurfaceView.java (EmacsSurfaceView)
+ (surfaceChanged, surfaceCreated, surfaceDestroyed): Add extra
+ debug logging. Avoid deadlock in surfaceCreated.
+
+ * java/org/gnu/emacs/EmacsView.java (EmacsView): Try very hard to
+ make the SurfaceView respect Z order. It didn't work.
+ (handleDirtyBitmap): Copy over the contents from the old bitmap.
+ (explicitlyDirtyBitmap): New function.
+ (onLayout): Don't dirty bitmap if unnecessary.
+ (damageRect, swapBuffers): Don't synchronize so hard.
+ (onTouchEvent): Call window.onTouchEvent instead.
+ (moveChildToBack, raise, lower): New functions.
+
+ * java/org/gnu/emacs/EmacsWindow.java (Coordinate): New
+ subclass.
+ (pointerMap, isMapped, isIconified, dontFocusOnMap)
+ (dontAcceptFocus): New fields.
+ (EmacsWindow): Don't immediately register unmapped window.
+ (viewLayout): Send configure event outside the lock.
+ (requestViewLayout): Explicitly dirty the bitmap.
+ (mapWindow): Register the window now. Respect dontFocusOnMap.
+ (unmapWindow): Unregister the window now.
+ (figureChange, onTouchEvent): New functions.
+ (onSomeKindOfMotionEvent): Handle scroll wheel events.
+ (reparentTo, makeInputFocus, raise, lower, getWindowGeometry)
+ (noticeIconified, noticeDeiconified, setDontAcceptFocus)
+ (setDontFocusOnMap, getDontFocusOnMap): New functions.
+
+ * java/org/gnu/emacs/EmacsWindowAttachmentManager.java
+ (registerWindow, detachWindow): Synchronize.
+ (noticeIconified, noticeDeiconified): New functions.
+ (copyWindows): New function.
+
+ * lisp/frame.el (frame-geometry, frame-edges)
+ (mouse-absolute-pixel-position, set-mouse-absolute-pixel-position)
+ (frame-list-z-order, frame-restack, display-mouse-p)
+ (display-monitor-attributes-list): Implement on Android.
+
+ * lisp/mwheel.el (mouse-wheel-down-event, mouse-wheel-up-event)
+ (mouse-wheel-left-event, mouse-wheel-right-event): Define on
+ Android.
+
+ * src/android.c (struct android_emacs_service): New methods
+ `ringBell', `queryTree', `getScreenWidth', `getScreenHeight',
+ and `detectMouse'.
+ (struct android_event_queue, android_init_events)
+ (android_next_event, android_write_event): Remove write limit.
+ (android_file_access_p): Handle directories correctly.
+ (android_close): Fix coding style.
+ (android_fclose): New function.
+ (android_init_emacs_service): Initialize new methods.
+ (android_reparent_window): Implement function.
+ (android_bell, android_set_input_focus, android_raise_window)
+ (android_lower_window, android_query_tree, android_get_geometry)
+ (android_get_screen_width, android_get_screen_height)
+ (android_get_mm_width, android_get_mm_height)
+ (android_detect_mouse)
+ (android_set_dont_focus_on_map, android_set_dont_accept_focus):
+ New functions.
+ (struct android_dir): New structure.
+ (android_opendir, android_readdir, android_closedir): New
+ functions.
+ (emacs_abort): Implement here on Android and poke debuggerd into
+ generating a tombstone.
+
+ * src/android.h: Update prototypes.
+
+ * src/androidfns.c (android_set_parent_frame): New function.
+ (android_default_font_parameter): Use sane font size by default.
+ (Fx_display_pixel_width, Fx_display_pixel_height)
+ (Fx_display_mm_width, Fx_display_mm_height)
+ (Fx_display_monitor_attributes_list): Rename to start with
+ `android-'. Implement. Fiddle with documentation to introduce
+ Android specific nuances.
+ (Fandroid_display_monitor_attributes_list): New function.
+ (Fx_frame_geometry, frame_geometry): New function.
+ (Fandroid_frame_geometry): Implement correctly.
+ (Fx_frame_list_z_order): Rename to start with `android-'.
+ (android_frame_list_z_order, Fandroid_frame_list_z_order):
+ Implement.
+ (Fx_frame_restack): Rename to start with `android-'.
+ (Fandroid_frame_restack): ``Implement''.
+ (Fx_mouse_absolute_pixel_position): Rename to start with
+ `android-'.
+ (Fandroid_mouse_absolute_pixel_position): ``Implement''.
+ (Fx_set_mouse_absolute_pixel_position): Rename to start with
+ `android-'.
+ (Fandroid_set_mouse_absolute_pixel_position): ``Implement''.
+ (Fandroid_detect_mouse): New function.
+ (android_set_menu_bar_lines): Use FRAME_ANDROID_DRAWABLE when
+ clearing area.
+ (android_set_no_focus_on_map, android_set_no_accept_focus): New
+ functions.
+ (android_frame_parm_handlers): Register new frame parameter
+ handlers.
+ (syms_of_androidfns): Update appropriately.
+
+ * src/androidfont.c (androidfont_draw): Use FRAME_ANDROID_DRAWABLE
+ instead of FRAME_ANDROID_WINDOW.
+
+ * src/androidgui.h (enum android_event_type): New events.
+ (struct android_touch_event, struct android_wheel_event)
+ (struct android_iconify_event): New structures.
+ (union android_event): Add new events.
+
+ * src/androidterm.c (android_clear_frame): Use
+ FRAME_ANDROID_DRAWABLE instead of FRAME_ANDROID_WINDOW.
+ (android_flash, android_ring_bell): Implement bell ringing.
+ (android_toggle_invisible_pointer): Don't TODO function that can't
+ be implemented.
+ (show_back_buffer, android_flush_dirty_back_buffer_on): Check if a
+ buffer flip is required before doing the flip.
+ (android_lower_frame, android_raise_frame): Implement functions.
+ (android_update_tools, android_find_tool): New functions.
+ (handle_one_android_event): Handle new iconification, wheel and
+ touch events.
+ (android_read_socket): Implement pending-autoraise-frames.
+ (android_frame_up_to_date): Implement bell ringing.
+ (android_buffer_flipping_unblocked_hook): Check if a buffer flip
+ is required before doing the flip.
+ (android_focus_frame, android_frame_highlight)
+ (android_frame_unhighlight): New function.
+ (android_frame_rehighlight): Implement functions.
+ (android_iconify_frame): Always display error.
+ (android_set_alpha): Update commentary.
+ (android_free_frame_resources): Free frame touch points.
+ (android_scroll_run, android_flip_and_flush)
+ (android_clear_rectangle, android_draw_fringe_bitmap)
+ (android_draw_glyph_string_background, android_fill_triangle)
+ (android_clear_point, android_draw_relief_rect)
+ (android_draw_box_rect, android_draw_glyph_string_bg_rect)
+ (android_draw_image_foreground, android_draw_stretch_glyph_string)
+ (android_draw_underwave, android_draw_glyph_string_foreground)
+ (android_draw_composite_glyph_string_foreground)
+ (android_draw_glyphless_glyph_string_foreground)
+ (android_draw_glyph_string, android_clear_frame_area)
+ (android_clear_under_internal_border, android_draw_hollow_cursor)
+ (android_draw_bar_cursor, android_draw_vertical_window_border)
+ (android_draw_window_divider): Use FRAME_ANDROID_DRAWABLE instead
+ of FRAME_ANDROID_WINDOW for drawing operations.
+
+ * src/androidterm.h (struct android_touch_point): New structure.
+ (struct android_output): New fields.
+ (FRAME_ANDROID_NEED_BUFFER_FLIP): New macro.
+
+ * src/dired.c (emacs_readdir, open_directory)
+ (directory_files_internal_unwind, read_dirent)
+ (directory_files_internal, file_name_completion): Add indirection
+ over readdir and opendir. Use android variants on Android.
+
+ * src/dispnew.c (Fopen_termscript):
+ * src/fileio.c (fclose_unwind): Use emacs_fclose.
+ (Faccess_file): Call android_file_access_p.
+ (file_accessible_directory_p): Append right suffix to Android
+ assets directory.
+ (do_auto_save_unwind): Use emacs_fclose.
+
+ * src/keyboard.c (lispy_function_keys): Use right function key for
+ page up and page down.
+ (Fopen_dribble_file): Use emacs_fclose.
+
+ * src/lisp.h: New prototype emacs_fclose.
+
+ * src/lread.c (close_infile_unwind): Use emacs_fclose.
+
+ * src/sfnt.c (sfnt_curve_is_flat): Fix area-squared computation.
+ (sfnt_prepare_raster): Compute raster width and height
+ consistently with outline building.
+ (sfnt_build_outline_edges): Use the same offsets used to set offy
+ and offx.
+ (main): Adjust debug code.
+
+ * src/sfntfont-android.c (sfntfont_android_saturate32): Delete
+ function.
+ (sfntfont_android_blend, sfntfont_android_blendrgb): Remove
+ unnecessary debug code.
+ (sfntfont_android_composite_bitmap): Prevent out of bounds write.
+ (sfntfont_android_put_glyphs): Use FRAME_ANDROID_DRAWABLE.
+ (init_sfntfont_android): Initialize Monospace Serif font to
+ something sensible.
+
+ * src/sfntfont.c (sfntfont_text_extents): Clear glyph metrics
+ before summing up pcm.
+ (sfntfont_draw): Use s->font instead of s->face->font.
+
+ * src/sysdep.c (emacs_fclose): Wrap around android_fclose on
+ Android.
+
+ * src/term.c (Fsuspend_tty, delete_tty): Use emacs_fclose.
+ * src/verbose.mk.in (AM_V_DX): Replace with D8 version.
+
+2023-01-11 Po Lu <luangruo@yahoo.com>
+
+ Bring up the sfnt-android font driver
+ * configure.ac (ANDROID_CFLAGS): Add sfnt-related font objects
+ to ANDROID_OBJ when not building stubs.
+ * lisp/startup.el (android-fonts-enumerated): New variable.
+ (normal-top-level): Set it. Also enumerate fonts as early as
+ possible upon startup.
+
+ * src/alloc.c (cleanup_vector): Only finalize Android font
+ entities.
+ (garbage_collect): Mark sfntfont.c.
+
+ * src/android.c (struct android_emacs_drawable): New field
+ `damage_rect'.
+ (android_init_emacs_drawable): Initialize
+ Lorg/gnu/emacs/EmacsDrawable;#damageRect(Landroid/graphics/rect;)V.
+ (android_create_gc): Initialize cached GC fields.
+ (android_free_gc): Free cached GC clip rectangles.
+ (android_change_gc): Cache fields as appropriate.
+ (android_set_clip_rectangles): Set cached clip rectangles for
+ easy access from C.
+ (android_get_gc_values): Use cached values.
+ (android_get_image): Remove obsolete comment.
+ (android_lock_bitmap, android_damage_window): New functions that
+ don't parallel anything on X.
+
+ * src/android.h: Update prototypes.
+
+ * src/androidfns.c (android_default_font_parameter): Set Droid
+ Sans Mono as the default monospace font.
+ (Fx_create_frame): Register the sfntfont driver.
+
+ * src/androidgui.h (struct android_gc): Add C side caches for
+ clip rectangles and the foreground and background colors.
+
+ * src/androidterm.h: Update prototypes.
+
+ * src/dispextern.h (struct gui_box): New struct.
+ (gui_union_rectangles): New function.
+
+ * src/emacs.c (android_emacs_init): Initialize Android font
+ stuff late.
+ * src/font.c (font_make_entity): Clear `is_android' field on
+ Android.
+ (font_make_entity_android): Set `is_android' field.
+ * src/font.h (struct font_entity): New field `is_android'.
+
+ * src/print.c (print_vectorlike): Don't print private data,
+ which could include Lisp_Misc.
+
+ * src/sfnt.c (sfnt_read_cmap_format_0, sfnt_read_cmap_format_2)
+ (sfnt_read_cmap_format_4, sfnt_read_cmap_format_6)
+ (sfnt_read_cmap_format_8, sfnt_read_cmap_format_12): Remove
+ buggy pragmas.
+ (sfnt_lookup_glyph_4_1): New function.
+ (sfnt_lookup_glyph_4): Handle malformed lookup tables found on
+ Android.
+ (sfnt_lookup_glyph): Fix overflow problems in glyph checks.
+ (sfnt_read_glyph): Handle empty glyphs. This implements some
+ behavior which everyone else seems to as well, but I can't find
+ documented in the TrueType Reference Manual.
+ (sfnt_free_glyph): Export correctly.
+ (sfnt_transform_coordinates): Make faster.
+ (sfnt_lerp_half): Fix lerping in some cases.
+ (sfnt_decompose_glyph): Handle empty glyphs correctly. Close
+ contours manually instead of waiting for the edge building
+ process to do that. This lets curves be handled correctly.
+ (struct sfnt_build_glyph_outline_context): Move internal struct
+ back to sfnt.c.
+ (sfnt_build_append): Fix detection of initial entry.
+ (sfnt_curve_to_and_build_1): Fix De Casteljau implementation.
+ (sfnt_curve_to_and_build): Use fixed point arithmetic to scale
+ outlines.
+ (sfnt_build_glyph_outline): Clear reference counts. Use fixed
+ point arithmetic.
+ (sfnt_prepare_raster): Align rasters to 4 bytes,
+ SFNT_POLY_ALIGNMENT. Fix calculation of offx and offy.
+ (sfnt_step_edge_by): Step edge by previously computed step_x.
+ (sfnt_build_outline_edges): Adjust for already closed contours.
+ Ignore edges abandoned after grid fit. Also precompute step_x
+ to avoid multiplication on each span rastered.
+ (sfnt_poly_edges): Improve alignment.
+ (sfnt_fill_span): Rewrite to avoid control flow in while loop.
+ (sfnt_poly_span): Remove unnecessary code.
+ (sfnt_raster_glyph_outline): Use raster stride instead of width.
+ (sfnt_test_edge, sfnt_test_raster, main): Improve debugging
+ code.
+
+ * src/sfnt.h (struct sfnt_glyph_outline): Add refcount field to
+ outline.
+ (struct sfnt_build_glyph_outline_context): Remove private
+ struct.
+ (struct sfnt_raster): Add refcount field to raster.
+ (struct sfnt_edge): Improve doc. Add `source_x' field used when
+ built with TEST.
+ (SFNT_CEIL_FIXED): New macro.
+
+ * src/sfntfont-android.c (sfntfont_android_saturate32)
+ (sfntfont_android_scale32, sfntfont_android_mul8x2)
+ (sfntfont_android_blend, U255TO256)
+ (sfntfont_android_composite_bitmap, sfntfont_android_union_boxes)
+ (sfntfont_android_put_glyphs, sfntfont_android_get_cache): New
+ functions.
+ (android_sfntfont_driver): New font driver.
+ (Fandroid_enumerate_fonts): New function.
+ (syms_of_sfntfont_android_for_pdumper, init_sfntfont_android)
+ (syms_of_sfntfont_android): Initialize default fonts, special
+ family mapping and font driver.
+ * src/sfntfont.c (struct sfnt_font_desc): New fields
+ `char_cache', `cmap_invalid' and `subtable'.
+ (sfnt_setup_coding_system): Improve commentary. Add default
+ branch. Fix return value.
+ (sfnt_safe_encode_coding_object_1)
+ (sfnt_safe_encode_coding_object_2):
+ (sfnt_safe_encode_coding_object): Use decode_coding_object
+ instead of encode_coding_object.
+ (sfnt_decode_font_string): Adjust for rename.
+ (sfnt_decode_foundry_name): New function.
+ (sfnt_weight_descriptions, sfnt_slant_descriptions)
+ (sfnt_width_descriptions): Fix definitions.
+ (sfnt_parse_style): Make function work.
+ (sfnt_enum_font): Initialize designer, char-cache and subtable
+ platform ID.
+ (sfntfont_charset_for_name, mark_sfntfont)
+ (sfntfont_charset_for_cmap): New functions.
+ (syms_of_sfntfont): New variable `sfnt-default-family-alist'.
+
+ * src/sfntfont.h (_SFNTFONT_H_): Update prototypes.
+
+ * src/xdisp.c (gui_union_rectangles): New function.
+
+2023-01-08 Po Lu <luangruo@yahoo.com>
+
+ * configure.ac (ANDROID_OBJS): Add sfntfont files.
+
+ * src/sfnt.h:
+ * src/sfntfont-android.c:
+ * src/sfntfont.c:
+ * src/sfntfont.h: New files.
+
+2023-01-08 Po Lu <luangruo@yahoo.com>
+
+ * src/android.c (android_change_gc): Fix situations where clip
+ rects are cleared.
+ (android_create_pixmap_from_bitmap_data): Fix bitmap data
+ iteration.
+
+ * src/androidfns.c (Fx_show_tip, Fx_hide_tip): Remove annoying
+ errors.
+
+ * src/androidgui.h (enum android_event_type)
+ (struct android_crossing_event)
+ (struct android_motion_event)
+ (struct android_button_event, union android_event): New crossing,
+ motion and button events.
+
+ * src/androidterm.c (android_note_mouse_movement)
+ (mouse_or_wdesc_frame, android_construct_mouse_click)
+ (handle_one_android_event, android_mouse_position)
+ (android_wait_for_event, android_set_window_size_1)
+ (android_bitmap_icon, android_free_frame_resources)
+ (syms_of_androidterm): New functions. Handle crossing, motion and
+ button events.
+
+ * src/androidterm.h (struct android_display_info): New field
+ `last_mouse_movement_time'.
+ (struct android_output): Remove unused `need_buffer_flip' field.
+
+ * src/emacs.c (android_emacs_init): Initialize sfntfont.
+
+ * src/frame.c (syms_of_frame): Set frame_inhibit_implied_resize
+ to some reasonable value.
+
+ * src/frame.h (GCALIGNED_STRUCT): Set wait_event_type on Android.
+
+ * src/sfnt.c (eassert, TEST_STATIC, available, enum sfnt_table)
+ (sfnt_table_names, SFNT_ENDOF, struct sfnt_table_directory)
+ (sfnt_scaler_type, sfnt_coerce_fixed, struct sfnt_hhea_table)
+ (struct sfnt_cmap_table, enum sfnt_platform_id)
+ (enum sfnt_unicode_platform_specific_id)
+ (enum sfnt_macintosh_platform_specific_id)
+ (enum sfnt_microsoft_platform_specific_id)
+ (struct sfnt_cmap_encoding_subtable)
+ (struct sfnt_cmap_encoding_subtable_data)
+ (struct sfnt_cmap_format_0)
+ (struct sfnt_cmap_format_2_subheader, struct sfnt_cmap_format_2)
+ (struct sfnt_cmap_format_4, struct sfnt_cmap_format_6)
+ (struct sfnt_cmap_format_8_or_12_group, struct sfnt_cmap_format_8)
+ (struct sfnt_cmap_format_12, struct sfnt_maxp_table)
+ (struct sfnt_loca_table_short, struct sfnt_loca_table_long)
+ (struct sfnt_glyf_table, struct sfnt_simple_glyph)
+ (struct sfnt_compound_glyph_component, struct sfnt_compound_glyph)
+ (struct sfnt_glyph, sfnt_read_table_directory, file)
+ (sfnt_read_cmap_table)
+ (sfnt_read_head_table, success, sfnt_read_hhea_table)
+ (sfnt_read_loca_table_short, sfnt_read_loca_table_long)
+ (sfnt_read_maxp_table, sfnt_read_glyf_table)
+ (sfnt_read_compound_glyph, sfnt_read_glyph, struct sfnt_point)
+ (sfnt_expand_compound_glyph_context)
+ (sfnt_decompose_compound_glyph, struct sfnt_glyph_outline)
+ (enum sfnt_glyph_outline_flags)
+ (struct sfnt_build_glyph_outline_context)
+ (sfnt_build_append, sfnt_build_glyph_outline, struct sfnt_raster)
+ (struct sfnt_edge, sfnt_prepare_raster, sfnt_build_outline_edges)
+ (sfnt_raster_glyph_outline): Move structures to sfnt.h.
+ (struct sfnt_long_hor_metric, sfnt_read_hmtx_table)
+ (sfnt_lookup_glyph_metrics, sfnt_read_name_table, sfnt_find_name)
+ (sfnt_read_meta_table, sfnt_find_metadata, sfnt_test_edge_ignore):
+ New functions.
+ (main): Add new tests.
+
+2023-01-08 Po Lu <luangruo@yahoo.com>
+
+ * java/org/gnu/emacs/EmacsPaintQueue.java
+ * java/org/gnu/emacs/EmacsPaintReq.java: Remove files.
+
+ * java/org/gnu/emacs/EmacsCopyArea.java (perform, paintTo):
+ * java/org/gnu/emacs/EmacsDrawLine.java:
+ * java/org/gnu/emacs/EmacsDrawPoint.java:
+ * java/org/gnu/emacs/EmacsDrawRectangle.java (paintTo):
+ * java/org/gnu/emacs/EmacsDrawable.java:
+ * java/org/gnu/emacs/EmacsFillPolygon.java:
+ * java/org/gnu/emacs/EmacsFillRectangle.java:
+ * java/org/gnu/emacs/EmacsFontDriver.java:
+ * java/org/gnu/emacs/EmacsGC.java:
+ * java/org/gnu/emacs/EmacsNative.java:
+ * java/org/gnu/emacs/EmacsPixmap.java:
+ * java/org/gnu/emacs/EmacsSdk23FontDriver.java:
+ * java/org/gnu/emacs/EmacsSdk7FontDriver.java (textExtents1)
+ (textExtents, draw):
+ * java/org/gnu/emacs/EmacsService.java (copyArea):
+ * java/org/gnu/emacs/EmacsSurfaceView.java:
+ * java/org/gnu/emacs/EmacsView.java (onLayout, onFocusChanged):
+ * java/org/gnu/emacs/EmacsWindow.java (run, resizeWindow)
+ (lockCanvas, getBitmap, onKeyDown, onKeyUp)
+ (onActivityDetached): Move rendering to main thread. Make
+ drawing operations completely static.
+
+ * src/androidmenu.c: New file.
+
+2023-01-07 Po Lu <luangruo@yahoo.com>
+
+ * src/sfnt.c (xmalloc, xrealloc, xfree, eassert, MIN)
+ (sfnt_table_names, SFNT_ENDOF, struct sfnt_table_directory)
+ (enum sfnt_scaler_type, sfnt_coerce_fixed, struct sfnt_hhea_table)
+ (struct sfnt_cmap_table, enum sfnt_platform_id)
+ (enum sfnt_unicode_platform_specific_id)
+ (enum sfnt_macintosh_platform_specific_id)
+ (enum sfnt_microsoft_platform_specific_id)
+ (struct sfnt_cmap_encoding_subtable)
+ (struct sfnt_cmap_encoding_subtable_data)
+ (struct sfnt_cmap_format_0, struct sfnt_cmap_format_2_subheader)
+ (struct sfnt_cmap_format_2, struct sfnt_cmap_format_4)
+ (struct sfnt_cmap_format_6, struct sfnt_cmap_format_8_or_12_group)
+ (struct sfnt_cmap_format_8, struct sfnt_cmap_format_12)
+ (struct sfnt_maxp_table, struct sfnt_loca_table_short)
+ (struct sfnt_loca_table_long, struct sfnt_glyf_table)
+ (struct sfnt_simple_glyph, struct sfnt_compound_glyph_component)
+ (struct sfnt_compound_glyph, struct sfnt_glyph, _sfnt_swap16)
+ (_sfnt_swap32, sfnt_swap16, sfnt_find_table)
+ (sfnt_read_cmap_format_0, sfnt_read_cmap_format_2)
+ (sfnt_read_cmap_format_4, sfnt_read_cmap_format_6)
+ (sfnt_read_cmap_format_8, sfnt_read_cmap_format_12)
+ (sfnt_read_cmap_table_1, sfnt_read_cmap_table)
+ (sfnt_lookup_glyph_0)
+ (sfnt_lookup_glyph_2, sfnt_bsearch_above, sfnt_compare_uint16)
+ (sfnt_lookup_glyph_4, sfnt_lookup_glyph_6, sfnt_lookup_glyph_8)
+ (sfnt_lookup_glyph_12, sfnt_lookup_glyph, sfnt_read_head_table)
+ (sfnt_read_hhea_table, sfnt_read_loca_table_short)
+ (sfnt_read_loca_table_long, sfnt_read_maxp_table)
+ (sfnt_read_glyf_table, sfnt_read_simple_glyph)
+ (sfnt_read_compound_glyph, sfnt_read_glyph, sfnt_free_glyph)
+ (struct sfnt_point, sfnt_transform_coordinates)
+ (struct sfnt_compound_glyph_context)
+ (sfnt_expand_compound_glyph_context, sfnt_round_fixed)
+ (sfnt_decompose_compound_glyph, sfnt_lerp_half)
+ (sfnt_decompose_glyph, struct sfnt_glyph_outline)
+ (enum sfnt_glyph_outline_flags)
+ (struct sfnt_build_glyph_outline_context, sfnt_build_append)
+ (sfnt_move_to_and_build, sfnt_line_to_and_build, sfnt_mul_fixed)
+ (sfnt_div_fixed, sfnt_ceil_fixed, sfnt_floor_fixed)
+ (sfnt_curve_is_flat, sfnt_curve_to_and_build_1)
+ (sfnt_curve_to_and_build, sfnt_build_glyph_outline)
+ (struct sfnt_raster, struct sfnt_edge, sfnt_poly_coverage)
+ (sfnt_poly_grid_ceil, sfnt_prepare_raster, sfnt_step_edge_by)
+ (sfnt_build_outline_edges, sfnt_compare_edges, sfnt_poly_edges)
+ (sfnt_saturate_short, sfnt_fill_span, sfnt_poly_span)
+ (sfnt_raster_span, sfnt_raster_edge, sfnt_raster_glyph_outline)
+ (struct sfnt_long_hor_metric, struct sfnt_hmtx_table)
+ (struct sfnt_glyph_metrics, sfnt_read_hmtx_table)
+ (sfnt_lookup_glyph_metrics, struct sfnt_test_dcontext)
+ (sfnt_test_move_to, sfnt_test_line_to, sfnt_test_curve_to)
+ (sfnt_test_get_glyph, sfnt_test_free_glyph, sfnt_test_span)
+ (sfnt_test_edge, sfnt_test_raster, main): New file, meant to read
+ TrueType fonts and OpenType fonts using TrueType outlines.
+
+2023-01-02 Po Lu <luangruo@yahoo.com>
+
+ * Makefile.in (java): Depend on info.
+ (MAKEFILE_NAME, config.status): Remove unneeded changes.
+
+ * configure.ac (BUILD_DETAILS, ANDROID_STUBIFY): Don't require a
+ C++ compiler on Android.
+
+ * java/AndroidManifest.xml <EmacsActivity>: Set launchMode
+ appropriately.
+ <EmacsMultitaskActivity>: New activity.
+
+ * java/Makefile.in (CROSS_BINS): Add Emacsclient to the list of
+ binaries that will be copied into the app package.
+
+ * java/org/gnu/emacs/EmacsActivity.java (onCreate): Use the window
+ attachment manager.
+
+ * java/org/gnu/emacs/EmacsCopyArea.java (paintTo): Implement clip
+ masks correctly.
+
+ * java/org/gnu/emacs/EmacsDrawRectangle.java (getRect, paintTo):
+ Fix damage tracking rectangles.
+
+ * java/org/gnu/emacs/EmacsFontDriver.java (toString): New
+ function.
+ (FontMetrics): Fix signature of textExtents.
+
+ * java/org/gnu/emacs/EmacsMultitaskActivity.java: New file.
+
+ * java/org/gnu/emacs/EmacsNative.java (sendFocusIn, sendFocusOut)
+ (sendWindowAction): New functions.
+
+ * java/org/gnu/emacs/EmacsPaintQueue.java (run): Correct treatment
+ of the clip rectangle list.
+
+ * java/org/gnu/emacs/EmacsPixmap.java: Add constructor for mutable
+ pixmaps.
+
+ * java/org/gnu/emacs/EmacsSdk23FontDriver.java: New file.
+
+ * java/org/gnu/emacs/EmacsSdk7FontDriver.java (Sdk7Typeface)
+ (Sdk7FontEntity, Sdk7FontObject, checkMatch, hasChar, encodeChar):
+ Implement text display and fix font metrics semantics.
+
+ * java/org/gnu/emacs/EmacsService.java (EmacsService): Remove
+ availableChildren.
+ (getLibraryDirectory, onCreate): Pass pixel density to Emacs.
+ (clearArea): Fix arguments. Switch to using the window attachment
+ manager.
+
+ * java/org/gnu/emacs/EmacsSurfaceView.java (surfaceChanged)
+ (surfaceCreated): Flip buffers on surface attachment.
+
+ * java/org/gnu/emacs/EmacsView.java (swapBuffers): New argument
+ FORCE. Always swap if it is true.
+ (onKeyMultiple, onFocusChanged): New functions.
+
+ * java/org/gnu/emacs/EmacsWindow.java (destroyHandle, run): Switch
+ to using the window attachment manager.
+
+ * java/org/gnu/emacs/EmacsWindowAttachmentManager.java: New file.
+
+ * lisp/cus-edit.el (custom-button, custom-button-mouse)
+ (custom-button-pressed):
+
+ * lisp/faces.el (tool-bar): Define faces correctly on Android.
+
+ * src/android.c (struct android_emacs_pixmap): Add mutable
+ constructor.
+ (struct android_emacs_drawable): New structure.
+ (android_write_event): Check if event queue hasn't yet been
+ initialized.
+ (android_select): Set errno to EINTR if pselect fails.
+ (android_close): Remove unused debugging code.
+ (android_get_home_directory): New function.
+ (Java_org_gnu_emacs_EmacsNative_setEmacsParams): Set pixel density
+ and compute game path.
+ (android_init_emacs_drawable): New function.
+ (Java_org_gnu_emacs_EmacsNative_sendKeyPress): New argument
+ `unicode_char'. Pass it in events.
+ (Java_org_gnu_emacs_EmacsNative_sendKeyRelease): Likewise.
+ (Java_org_gnu_emacs_EmacsNative_sendFocusIn)
+ (Java_org_gnu_emacs_EmacsNative_sendFocusOut)
+ (Java_org_gnu_emacs_EmacsNative_sendWindowAction): New functions.
+ (android_resolve_handle): Export function.
+ (android_change_gc): Clear clip rects under the right
+ circumstances. Set right clip mask field.
+ (android_create_pixmap_from_bitmap_data): Use correct alpha
+ channels.
+ (android_create_pixmap): Create mutable pixmap and avoid redundant
+ color array allocation.
+ (android_create_bitmap_from_data, android_create_image)
+ (android_destroy_image, android_put_pixel, android_get_pixel)
+ (android_get_image, android_put_image, faccessat): New functions.
+
+ * src/android.h: Update prototypes.
+
+ * src/androidfns.c (android_default_font_parameter): Prefer
+ monospace to Droid Sans Mono.
+
+ * src/androidfont.c (struct android_emacs_font_driver): New method
+ `draw'.
+ (struct android_emacs_font_spec): New field `dpi'.
+ (struct androidfont_info): Add font metrics cache.
+ (android_init_font_driver, android_init_font_spec): Adjust
+ accordingly.
+ (androidfont_from_lisp, androidfont_from_java): Handle new fields.
+ (androidfont_draw): Implement function.
+ (androidfont_open_font): Set pixel size correctly.
+ (androidfont_close_font): Free metrics cache.
+ (androidfont_cache_text_extents)
+ (androidfont_check_cached_extents): New functions.
+ (androidfont_text_extents): Cache glyph metrics somewhere for
+ future use.
+ (androidfont_list_family): Implement function.
+
+ * src/androidgui.h (enum android_event_type): New focus and window
+ action events.
+ (enum android_modifier_mask): New masks.
+ (struct android_key_event): New field `unicode_char'.
+ (ANDROID_IS_MODIFIER_KEY): Newmacro.
+ (struct android_focus_event, struct android_window_action_event):
+ New structs.
+ (union android_event): Add new fields.
+ (enum android_image_format, struct android_image): New enums and
+ structs.
+
+ * src/androidterm.c (android_android_to_emacs_modifiers)
+ (android_emacs_to_android_modifiers, android_lower_frame)
+ (android_raise_frame, android_new_focus_frame)
+ (android_focus_changed, android_detect_focus_change): New
+ functions.
+ (handle_one_android_event): Implement focus and key event
+ handling.
+ (android_frame_rehighlight): New function.
+ (android_frame_raise_lower): Implement accordingly.
+ (android_make_frame_invisible): Clear highlight_frame if required.
+ (android_free_frame_resources): Clear x_focus_event_frame if
+ required.
+ (android_draw_fringe_bitmap, android_draw_image_foreground)
+ (android_draw_image_foreground_1)
+ (android_draw_image_glyph_string): Remove unnecessary code.
+ (android_create_terminal, android_term_init): Set the baud rate to
+ something sensible.
+
+ * src/androidterm.h (struct android_bitmap_record): Make structure
+ the same as on X.
+ (struct android_display_info): New focus tracking fields.
+ (struct android_output): Likewise.
+
+ * src/dispextern.h (struct image): Add ximg and mask_img on
+ Android.
+
+ * src/emacs.c (android_emacs_init): Fix argc sorting iteration.
+
+ * src/fileio.c (user_homedir, get_homedir): Implement correctly on
+ Android.
+
+ * src/font.h (PT_PER_INCH): Define correctly on Android.
+
+ * src/fringe.c (X, swap_nibble, init_fringe_bitmap): Swap fringe
+ bitmaps correctly on Android.
+
+ * src/image.c (GET_PIXEL, image_create_bitmap_from_data)
+ (image_create_bitmap_from_file, free_bitmap_record)
+ (image_unget_x_image_or_dc, struct image_type)
+ (prepare_image_for_display, image_clear_image_1)
+ (image_size_in_bytes, x_check_image_size)
+ (x_create_x_image_and_pixmap, x_destroy_x_image)
+ (image_check_image_size, image_create_x_image_and_pixmap_1)
+ (image_destroy_x_image, gui_put_x_image, image_put_x_image)
+ (image_get_x_image, image_unget_x_image)
+ (Create_Pixmap_From_Bitmap_Data, image_pixmap_draw_cross)
+ (MaskForeground, image_types, syms_of_image): Implement all of the
+ above on Android in terms of an API very similar to X.
+
+ * src/keyboard.c (FUNCTION_KEY_OFFSET, lispy_function_keys):
+ Define to something sensible under Android.
+
+ * src/lread.c (build_load_history): Fix problem.
+
+2022-12-31 Po Lu <luangruo@yahoo.com>
+
+ * .dir-locals.el (c-mode): Add ANDROID_EXPORT noise macro.
+
+ * .gitignore: Add new files to ignore.
+
+ * Makefile.in: Adjust for Android.
+
+ * admin/merge-gnulib: Add new warning.
+
+ * configure.ac: Detect Android. Run cross-configuration for
+ Android when appropriate.
+
+ * etc/DEBUG: Document how to debug Emacs on Android.
+
+ * java/AndroidManifest.xml:
+ * java/Makefile.in:
+ * java/README:
+ * java/debug.sh:
+ * java/org/gnu/emacs/EmacsActivity.java:
+ * java/org/gnu/emacs/EmacsApplication.java:
+ * java/org/gnu/emacs/EmacsCopyArea.java:
+ * java/org/gnu/emacs/EmacsDrawLine.java:
+ * java/org/gnu/emacs/EmacsDrawPoint.java:
+ * java/org/gnu/emacs/EmacsDrawRectangle.java:
+ * java/org/gnu/emacs/EmacsDrawable.java:
+ * java/org/gnu/emacs/EmacsFillPolygon.java:
+ * java/org/gnu/emacs/EmacsFillRectangle.java:
+ * java/org/gnu/emacs/EmacsFontDriver.java:
+ * java/org/gnu/emacs/EmacsGC.java:
+ * java/org/gnu/emacs/EmacsHandleObject.java:
+ * java/org/gnu/emacs/EmacsNative.java:
+ * java/org/gnu/emacs/EmacsPaintQueue.java:
+ * java/org/gnu/emacs/EmacsPaintReq.java:
+ * java/org/gnu/emacs/EmacsPixmap.java:
+ * java/org/gnu/emacs/EmacsSdk7FontDriver.java:
+ * java/org/gnu/emacs/EmacsService.java:
+ * java/org/gnu/emacs/EmacsSurfaceView.java:
+ * java/org/gnu/emacs/EmacsThread.java:
+ * java/org/gnu/emacs/EmacsView.java:
+ * java/org/gnu/emacs/EmacsWindow.java: New files and classes.
+
+ * lib-src/Makefile.in (srcdir):
+
+ * lib/Makefile.in (VPATH, HAVE_NATIVE_COMP, libgnu_a_SOURCES):
+ (DEPFLAGS): Configure correctly for cross-compiling.
+
+ * lib/faccessat.c:
+
+ * lib/fpending.c (__fpending):
+
+ * lib/open.c:
+
+ * lib/unistd.c (_GL_UNISTD_INLINE): Temporary adjustments to
+ Gnulib.
+
+ * lisp/frame.el (display-graphic-p, display-screens)
+ (display-pixel-height, display-pixel-width, display-mm-height)
+ (display-mm-width, display-backing-store, display-save-under)
+ (display-planes, display-color-cells, display-visual-class):
+ Adjust for new window system `android'.
+
+ * lisp/image/wallpaper.el (x-open-connection): Add declaration.
+
+ * lisp/loadup.el (featurep): Load files for Android.
+
+ * lisp/net/eww.el (eww-form-submit, eww-form-file)
+ (eww-form-checkbox, eww-form-select): Adjust faces for android.
+
+ * lisp/term/android-win.el: New file.
+
+ * src/Makefile.in: Add new targets emacs.so and android-emacs,
+ then adjust for cross compilation.
+
+ * src/alloc.c (cleanup_vector): Clean up Android font entities
+ as well.
+ (garbage_collect): Mark androidterm.
+
+ * src/android-emacs.c (main):
+
+ * src/android.c (ANDROID_THROW, enum android_fd_table_entry_flags)
+ (struct android_emacs_service, struct android_emacs_pixmap)
+ (struct android_graphics_point, struct android_event_container)
+ (struct android_event_queue, android_run_select_thread)
+ (android_handle_sigusr1, android_init_events, android_pending)
+ (android_next_event, android_write_event, android_select)
+ (android_run_debug_thread, android_user_full_name)
+ (android_get_asset_name, android_fstat, android_fstatat)
+ (android_file_access_p, android_hack_asset_fd, android_open)
+ (android_close, JNICALL, android_init_emacs_service)
+ (android_init_emacs_pixmap, android_init_graphics_point)
+ (MAX_HANDLE, struct android_handle_entry, android_alloc_id)
+ (android_destroy_handle, android_resolve_handle)
+ (android_resolve_handle2, android_change_window_attributes)
+ (android_create_window, android_set_window_background)
+ (android_destroy_window, android_init_android_rect_class)
+ (android_init_emacs_gc_class, android_create_gc, android_free_gc)
+ (android_change_gc, android_set_clip_rectangles)
+ (android_reparent_window, android_lookup_method)
+ (android_clear_window, android_map_window, android_unmap_window)
+ (android_resize_window, android_move_window, android_swap_buffers)
+ (android_get_gc_values, android_set_foreground)
+ (android_fill_rectangle, android_create_pixmap_from_bitmap_data)
+ (android_set_clip_mask, android_set_fill_style, android_copy_area)
+ (android_free_pixmap, android_set_background)
+ (android_fill_polygon)
+ (android_draw_rectangle, android_draw_point, android_draw_line)
+ (android_create_pixmap, android_set_ts_origin)
+ (android_clear_area):
+
+ * src/android.h (ANDROID_EXPORT):
+
+ * src/androidfns.c (android_display_info_for_name)
+ (check_android_display_info, check_x_display_info, gamma_correct)
+ (android_defined_color, android_decode_color)
+ (android_implicitly_set_name, android_explicitly_set_name)
+ (android_set_tool_bar_lines, android_change_tool_bar_height)
+ (android_set_tab_bar_lines, android_change_tab_bar_height)
+ (android_set_scroll_bar_default_height)
+ (android_set_scroll_bar_default_width, android_icon_verify)
+ (android_icon, android_make_gc, android_free_gcs)
+ (unwind_create_frame, do_unwind_create_frame)
+ (android_default_font_parameter, android_create_frame_window)
+ (Fx_create_frame, Fxw_color_defined_p, Fxw_color_values)
+ (Fxw_display_color_p, Fx_display_grayscale_p)
+ (Fx_display_pixel_width, Fx_display_pixel_height)
+ (Fx_display_planes, Fx_display_color_cells, Fx_display_screens)
+ (Fx_display_mm_width, Fx_display_mm_height)
+ (Fx_display_backing_store, Fx_display_visual_class)
+ (Fx_display_monitor_attributes_list, Fx_frame_geometry)
+ (Fx_frame_list_z_order, Fx_frame_restack)
+ (Fx_mouse_absolute_pixel_position)
+ (Fx_set_mouse_absolute_pixel_position, Fandroid_get_connection)
+ (Fx_display_list, Fx_show_tip, Fx_hide_tip)
+ (android_set_background_color, android_set_border_color)
+ (android_set_cursor_color, android_set_cursor_type)
+ (android_set_foreground_color)
+ (android_set_child_frame_border_width)
+ (android_set_internal_border_width, android_set_menu_bar_lines)
+ (android_set_mouse_color, android_set_title, android_set_alpha)
+ (android_frame_parm_handlers, syms_of_androidfns):
+
+ * src/androidfont.c (struct android_emacs_font_driver)
+ (struct android_emacs_font_spec)
+ (struct android_emacs_font_metrics)
+ (struct android_emacs_font_object, struct android_integer)
+ (struct androidfont_info, struct androidfont_entity)
+ (android_init_font_driver, android_init_font_spec)
+ (android_init_font_metrics, android_init_integer)
+ (android_init_font_object, androidfont_get_cache)
+ (androidfont_from_lisp, androidfont_from_java, androidfont_list)
+ (androidfont_match, androidfont_draw, androidfont_open_font)
+ (androidfont_close_font, androidfont_has_char)
+ (androidfont_encode_char, androidfont_text_extents)
+ (androidfont_list_family, androidfont_driver)
+ (syms_of_androidfont_for_pdumper, syms_of_androidfont)
+ (init_androidfont, android_finalize_font_entity):
+
+ * src/androidgui.h (_ANDROID_GUI_H_, struct android_rectangle)
+ (struct android_point, enum android_gc_function)
+ (enum android_gc_value_mask, enum android_fill_style)
+ (enum android_window_value_mask)
+ (struct android_set_window_attributes, struct android_gc_values)
+ (struct android_gc, enum android_swap_action, enum android_shape)
+ (enum android_coord_mode, struct android_swap_info)
+ (NativeRectangle, struct android_any_event)
+ (struct android_key_event, struct android_configure_event)
+ (union android_event):
+
+ * src/androidterm.c (android_window_to_frame, android_clear_frame)
+ (android_ring_bell, android_toggle_invisible_pointer)
+ (android_update_begin, android_update_end, show_back_buffer)
+ (android_flush_dirty_back_buffer_on, handle_one_android_event)
+ (android_read_socket, android_frame_up_to_date)
+ (android_buffer_flipping_unblocked_hook)
+ (android_query_frame_background_color, android_parse_color)
+ (android_alloc_nearest_color, android_query_colors)
+ (android_mouse_position, android_get_focus_frame)
+ (android_focus_frame, android_frame_rehighlight)
+ (android_frame_raise_lower, android_make_frame_visible)
+ (android_make_frame_invisible)
+ (android_make_frame_visible_invisible, android_fullscreen_hook)
+ (android_iconify_frame, android_set_window_size_1)
+ (android_set_window_size, android_set_offset, android_set_alpha)
+ (android_new_font, android_bitmap_icon, android_free_pixmap_hook)
+ (android_free_frame_resources, android_delete_frame)
+ (android_delete_terminal, android_scroll_run)
+ (android_after_update_window_line, android_flip_and_flush)
+ (android_clear_rectangle, android_reset_clip_rectangles)
+ (android_clip_to_row, android_draw_fringe_bitmap)
+ (android_set_cursor_gc, android_set_mouse_face_gc)
+ (android_set_mode_line_face_gc, android_set_glyph_string_gc)
+ (android_set_glyph_string_clipping)
+ (android_set_glyph_string_clipping_exactly)
+ (android_compute_glyph_string_overhangs)
+ (android_clear_glyph_string_rect)
+ (android_draw_glyph_string_background, android_fill_triangle)
+ (android_make_point, android_inside_rect_p, android_clear_point)
+ (android_draw_relief_rect, android_draw_box_rect)
+ (HIGHLIGHT_COLOR_DARK_BOOST_LIMIT, android_setup_relief_color)
+ (android_setup_relief_colors, android_draw_glyph_string_box)
+ (android_draw_glyph_string_bg_rect, android_draw_image_relief)
+ (android_draw_image_foreground, android_draw_image_foreground_1)
+ (android_draw_image_glyph_string)
+ (android_draw_stretch_glyph_string, android_draw_underwave)
+ (android_draw_glyph_string_foreground)
+ (android_draw_composite_glyph_string_foreground)
+ (android_draw_glyphless_glyph_string_foreground)
+ (android_draw_glyph_string, android_define_frame_cursor)
+ (android_clear_frame_area, android_clear_under_internal_border)
+ (android_draw_hollow_cursor, android_draw_bar_cursor)
+ (android_draw_window_cursor, android_draw_vertical_window_border)
+ (android_draw_window_divider, android_redisplay_interface)
+ (frame_set_mouse_pixel_position, get_keysym_name)
+ (android_create_terminal, android_term_init, syms_of_androidterm)
+ (mark_androidterm):
+
+ * src/androidterm.h (_ANDROID_TERM_H_)
+ (struct android_display_info)
+ (struct android_output, FRAME_ANDROID_OUTPUT, XSCROLL_BAR): New
+ files.
+
+ * src/dired.c (file_attributes): Do not use openat on Android.
+
+ * src/dispextern.h (No_Cursor): Define appropriately on Android.
+ (struct glyph_string, struct face): Make gc field of type struct
+ android_gc on Android.
+
+ * src/dispnew.c (clear_current_matrices, clear_desired_matrices)
+ (adjust_frame_glyphs_for_window_redisplay, free_glyphs)
+ (update_frame, scrolling, char_ins_del_cost, update_frame_line)
+ (init_display_interactive): Disable text terminal support
+ completely on Android. Fix non-toolkit menus for non-X systems.
+
+ * src/editfns.c (Fuser_full_name): Call android_user_full_name.
+
+ * src/emacs.c (android_emacs_init): Make main this on Android.
+ Prohibit argv sorting from exceeding end of argv.
+
+ * src/epaths.in: Add path definitions for Android.
+
+ * src/fileio.c (file_access_p): Call android_file_access_p.
+ (file_name_directory): Avoid using openat on Android.
+ (Fcopy_file): Adjust to call sys_fstat instead.
+ (file_directory_p, Finsert_file_contents, write_region): Likewise.
+
+ * src/filelock.c:
+
+ * src/fns.c (Flocale_info): Pacify warning on Android.
+
+ * src/font.c (font_make_entity_android): New function.
+
+ * src/font.h:
+
+ * src/frame.c (Fframep, Fwindow_system): Handle new window system
+ `android'. Update doc strings.
+ (Fmake_terminal_frame): Disable on Android.
+ (gui_display_get_resource): Disable get_string_resource_hook on
+ Android.
+ (syms_of_frame): New defsym `android'.
+
+ * src/frame.h (GCALIGNED_STRUCT): Add new output data for Android.
+ (ENUM_BF): Expand enumerator size.
+ (FRAME_ANDROID_P, FRAME_WINDOW_P, MOUSE_HL_INFO): Add definitions
+ for Android.
+
+ * src/image.c (GET_PIXEL, image_create_bitmap_from_file)
+ (image_create_x_image_and_pixmap_1, image_get_x_image, slurp_file)
+ (lookup_rgb_color, image_to_emacs_colors, image_from_emacs_colors)
+ (image_pixmap_draw_cross, image_disable_image, MaskForeground)
+ (gif_load): Add stubs for Android.
+
+ * src/lisp.h:
+
+ * src/lread.c (safe_to_load_version, maybe_swap_for_eln1, openp):
+
+ * src/pdumper.c (pdumper_load): Call sys_fstat instead of fstat.
+
+ * src/process.c (wait_reading_process_output): Use android_select
+ instead of pselect.
+
+ * src/scroll.c: Disable on Android.
+
+ * src/sysdep.c (widen_foreground_group, reset_sys_modes)
+ (init_signals, emacs_fstatat, sys_fstat): New function.
+ (emacs_open, emacs_open_noquit, emacs_close): Implement
+ differently on Android.
+ (close_output_streams): Disable what is not required on Android.
+
+ * src/term.c (OUTPUT1_IF, encode_terminal_code, string_cost)
+ (string_cost_one_line, per_line_cost, calculate_costs)
+ (struct fkey_table, tty_append_glyph, produce_glyphs)
+ (tty_capable_p, Fsuspend_tty, Fresume_tty, device, init_tty)
+ (maybe_fatal, syms_of_term): Disable text terminal support on
+ Android.
+
+ * src/termhooks.h (enum output_method): Add android output method.
+ (GCALIGNED_STRUCT, TERMINAL_FONT_CACHE): Define for Android.
+
+ * src/terminal.c (Fterminal_live_p): Implement for Android.
+
+ * src/verbose.mk.in (AM_V_GLOBALS): Add JAVAC and DX.
+ * src/xdisp.c (redisplay_internal): Disable text terminals on
+ Android.
+ (display_menu_bar, display_tty_menu_item)
+ (draw_row_with_mouse_face, expose_frame): Make the non toolkit
+ menu bar work on Android.
+
+ * src/xfaces.c (GCGraphicsExposures, x_create_gc, x_free_gc)
+ (Fx_load_color_file): Define for Android.
+
+ * xcompile/Makefile.in:
+ * xcompile/README:
+ * xcompile/langinfo.h (nl_langinfo): New files.
+
+2022-12-29 Po Lu <luangruo@yahoo.com>
+
+ Development of the Android port starts...
+
+This ChangeLog only chronicles changes constituting the initial
+development of the Android port. Refer to other ChangeLog files for a
+narrative of unrelated modifications made to Emacs during that time,
+and those made after the Android port was installed.
+
+;; Local Variables:
+;; coding: utf-8
+;; End:
+
+ Copyright (C) 2023-2024 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 <https://www.gnu.org/licenses/>.
diff --git a/GNUmakefile b/GNUmakefile
index 16064672c65..58c0281e895 100644
--- a/GNUmakefile
+++ b/GNUmakefile
@@ -27,6 +27,8 @@
# newly-built Makefile. If the source tree is already configured,
# this file defers to the existing Makefile.
+. :=
+
# If you want non-default build options, or if you want to build in an
# out-of-source tree, you should run 'configure' before running 'make'.
# But run 'autogen.sh' first, if the source was checked out directly
@@ -36,30 +38,30 @@
ifeq (help,$(filter help,$(MAKECMDGOALS)))
help:
- $(info $ NOTE: This is a brief summary of some common make targets.)
- $(info $ For more detailed information, please read the files INSTALL,)
- $(info $ INSTALL.REPO, Makefile or visit this URL:)
- $(info $ https://www.gnu.org/prep/standards/html_node/Standard-Targets.html)
- $(info $ )
- $(info $ make all -- compile and build Emacs)
- $(info $ make install -- install Emacs)
- $(info $ make TAGS -- update tags tables)
- $(info $ make clean -- delete built files but preserve configuration)
- $(info $ make mostlyclean -- like 'make clean', but leave those files that)
- $(info $ usually do not need to be recompiled)
- $(info $ make distclean -- delete all build and configuration files,)
- $(info $ leave only files included in source distribution)
- $(info $ make maintainer-clean -- delete almost everything that can be regenerated)
- $(info $ make extraclean -- like maintainer-clean, and also delete)
- $(info $ backup and autosave files)
- $(info $ make bootstrap -- delete all compiled files to force a new bootstrap)
- $(info $ from a clean slate, then build in the normal way)
- $(info $ make uninstall -- remove files installed by 'make install')
- $(info $ make check -- run the Emacs test suite)
- $(info $ make docs -- generate Emacs documentation in info format)
- $(info $ make html -- generate documentation in html format)
- $(info $ make ps -- generate documentation in ps format)
- $(info $ make pdf -- generate documentation in pdf format )
+ $(info $.NOTE: This is a brief summary of some common make targets.)
+ $(info $.For more detailed information, please read the files INSTALL,)
+ $(info $.INSTALL.REPO, Makefile or visit this URL:)
+ $(info $.https://www.gnu.org/prep/standards/html_node/Standard-Targets.html)
+ $(info $.)
+ $(info $.make all -- compile and build Emacs)
+ $(info $.make install -- install Emacs)
+ $(info $.make TAGS -- update tags tables)
+ $(info $.make clean -- delete built files but preserve configuration)
+ $(info $.make mostlyclean -- like 'make clean', but leave those files that)
+ $(info $. usually do not need to be recompiled)
+ $(info $.make distclean -- delete all build and configuration files,)
+ $(info $. leave only files included in source distribution)
+ $(info $.make maintainer-clean -- delete almost everything that can be regenerated)
+ $(info $.make extraclean -- like maintainer-clean, and also delete)
+ $(info $. backup and autosave files)
+ $(info $.make bootstrap -- delete all compiled files to force a new bootstrap)
+ $(info $. from a clean slate, then build in the normal way)
+ $(info $.make uninstall -- remove files installed by 'make install')
+ $(info $.make check -- run the Emacs test suite)
+ $(info $.make docs -- generate Emacs documentation in info format)
+ $(info $.make html -- generate documentation in html format)
+ $(info $.make ps -- generate documentation in ps format)
+ $(info $.make pdf -- generate documentation in pdf format )
@:
.PHONY: help
diff --git a/INSTALL b/INSTALL
index 73fdc5a07ae..2aaa02f37d7 100644
--- a/INSTALL
+++ b/INSTALL
@@ -4,13 +4,16 @@ Inc.
See the end of the file for license conditions.
-This file contains general information on building GNU Emacs. For
-more information specific to the MS-Windows, GNUstep/macOS, and MS-DOS
-ports, also read the files nt/INSTALL, nextstep/INSTALL, and
-msdos/INSTALL.
-
-For information about building from a Git checkout (rather than an
-Emacs release), read the INSTALL.REPO file first.
+This file contains general information on building GNU Emacs. If you
+are building an Emacs release tarball on a Unix or a GNU system, the
+instructions in this file should be sufficient. For other
+configurations, we have additional specialized files:
+
+ . INSTALL.REPO if you build from a Git checkout
+ . nt/INSTALL if you build for MS-Windows
+ . nextstep/INSTALL if you build for GNUstep/macOS
+ . java/INSTALL if you build for Android
+ . msdos/INSTALL if you build for MS-DOS
BASIC INSTALLATION
diff --git a/INSTALL.REPO b/INSTALL.REPO
index dd05a9fc433..77d8153a5a8 100644
--- a/INSTALL.REPO
+++ b/INSTALL.REPO
@@ -4,7 +4,7 @@ The Emacs repository is hosted on Savannah. The following Git command
will clone the repository to the 'emacs' subdirectory of the current
directory on your local machine:
- git clone git://git.sv.gnu.org/emacs.git
+ git clone https://git.savannah.gnu.org/git/emacs.git
To build the repository code, simply run 'make' in the 'emacs'
directory. This should work if your files are freshly checked out
diff --git a/Makefile.in b/Makefile.in
index 996f7b8d8c7..20394cb333d 100644
--- a/Makefile.in
+++ b/Makefile.in
@@ -106,15 +106,15 @@ top_builddir = @top_builddir@
FIND_DELETE = @FIND_DELETE@
-HAVE_NATIVE_COMP = @HAVE_NATIVE_COMP@
-
USE_STARTUP_NOTIFICATION = @USE_STARTUP_NOTIFICATION@
+HAVE_NATIVE_COMP = @HAVE_NATIVE_COMP@
HAVE_BE_APP = @HAVE_BE_APP@
-
HAVE_PGTK = @HAVE_PGTK@
HAVE_GSETTINGS = @HAVE_GSETTINGS@
+ANDROID = @ANDROID@
+
# ==================== Where To Install Things ====================
# Location to install Emacs.app under GNUstep / macOS.
@@ -339,6 +339,10 @@ EMACS_PDMP = `./src/emacs${EXEEXT} --fingerprint`.pdmp
# Subdirectories to make recursively.
SUBDIR = $(NTDIR) lib lib-src src lisp
+ifeq ($(ANDROID),yes)
+SUBDIR := $(SUBDIR) java
+endif
+
# The subdir makefiles created by config.status.
SUBDIR_MAKEFILES_IN = @SUBDIR_MAKEFILES_IN@
SUBDIR_MAKEFILES = $(patsubst ${srcdir}/%,%,${SUBDIR_MAKEFILES_IN:.in=})
@@ -417,9 +421,9 @@ advice-on-failure:
sanity-check:
@[ -f .no-advice-on-failure ] && exit 0; true
- @v=$$(src/emacs${EXEEXT} --batch --eval \
+ @v=`src/emacs${EXEEXT} --batch -Q --eval \
'(progn (defun f (n) (if (= 0 n) 1 (* n (f (- n 1))))) (princ (f 10)))' \
- 2> /dev/null); \
+ 2> /dev/null`; \
[ "X$$v" = "X3628800" ] && exit 0; \
echo >&2 '***'; \
echo >&2 '*** '"\"make ${make-target}\" succeeded, but Emacs is not functional."; \
@@ -467,20 +471,20 @@ epaths-force:
esac; \
done
@(gamedir='${gamedir}'; \
- sed < ${srcdir}/src/epaths.in > epaths.h.$$$$ \
- -e 's;\(#.*PATH_LOADSEARCH\).*$$;\1 "${standardlisppath}";' \
- -e 's;\(#.*PATH_REL_LOADSEARCH\).*$$;\1 "${lispdirrel}";' \
- -e 's;\(#.*PATH_SITELOADSEARCH\).*$$;\1 "${locallisppath}";' \
- -e 's;\(#.*PATH_DUMPLOADSEARCH\).*$$;\1 "${buildlisppath}";' \
- -e '/^#define PATH_[^ ]*SEARCH /s/\([":]\):*/\1/g' \
- -e '/^#define PATH_[^ ]*SEARCH /s/:"/"/' \
- -e 's;\(#.*PATH_EXEC\).*$$;\1 "${archlibdir}";' \
- -e 's;\(#.*PATH_INFO\).*$$;\1 "${infodir}";' \
- -e 's;\(#.*PATH_DATA\).*$$;\1 "${etcdir}";' \
- -e 's;\(#.*PATH_BITMAPS\).*$$;\1 "${bitmapdir}";' \
- -e 's;\(#.*PATH_X_DEFAULTS\).*$$;\1 "${x_default_search_path}";' \
- -e 's;\(#.*PATH_GAME\).*$$;\1 $(PATH_GAME);' \
- -e 's;\(#.*PATH_DOC\).*$$;\1 "${etcdocdir}";') && \
+ sed < ${srcdir}/src/epaths.in > epaths.h.$$$$ \
+ -e 's;\(#define.*PATH_LOADSEARCH\).*$$;\1 "${standardlisppath}";' \
+ -e 's;\(#define.*PATH_REL_LOADSEARCH\).*$$;\1 "${lispdirrel}";' \
+ -e 's;\(#define.*PATH_SITELOADSEARCH\).*$$;\1 "${locallisppath}";' \
+ -e 's;\(#define.*PATH_DUMPLOADSEARCH\).*$$;\1 "${buildlisppath}";' \
+ -e '/^#define PATH_[^ ]*SEARCH /s/\([":]\):*/\1/g' \
+ -e '/^#define PATH_[^ ]*SEARCH /s/:"/"/' \
+ -e 's;\(#define.*PATH_EXEC\).*$$;\1 "${archlibdir}";' \
+ -e 's;\(#define.*PATH_INFO\).*$$;\1 "${infodir}";' \
+ -e 's;\(#define.*PATH_DATA\).*$$;\1 "${etcdir}";' \
+ -e 's;\(#define.*PATH_BITMAPS\).*$$;\1 "${bitmapdir}";' \
+ -e 's;\(#define.*PATH_X_DEFAULTS\).*$$;\1 "${x_default_search_path}";' \
+ -e 's;\(#define.*PATH_GAME\).*$$;\1 $(PATH_GAME);' \
+ -e 's;\(#define.*PATH_DOC\).*$$;\1 "${etcdocdir}";') && \
${srcdir}/build-aux/move-if-change epaths.h.$$$$ src/epaths.h
# The w32 build needs a slightly different editing, and it uses
@@ -532,6 +536,12 @@ lisp: src
lib lib-src lisp nt: Makefile
$(MAKE) -C $@ all
+java: lisp info
+ $(MAKE) -C $@ all
+
+cross: src
+ $(MAKE) -C $@ all
+
trampolines: src lisp
ifeq ($(HAVE_NATIVE_COMP),yes)
$(MAKE) -C lisp trampolines
@@ -569,10 +579,13 @@ $(MAKEFILE_NAME): config.status $(srcdir)/configure \
# Don't erase these files if make is interrupted while refreshing them.
.PRECIOUS: Makefile config.status
+# Note that calling config.status --recheck is insufficient on Android
+# due to the recursive calls to configure.
+
config.status: ${srcdir}/configure
- if [ -x ./config.status ]; then \
+ if [ -x ./config.status ]; then \
$(CFG) ./config.status --recheck; \
- else \
+ else \
$(CFG) $(srcdir)/configure $(CONFIGURE_FLAGS); \
fi
@@ -630,6 +643,7 @@ ifndef NO_BIN_LINK
cd "$(DESTDIR)${bindir}" && $(LN_S_FILEONLY) "$(EMACSFULL)" "$(EMACS)"
endif
else
+ ${INSTALL_DATA} src/emacs.pdmp "$(DESTDIR)${libexecdir}/Emacs.pdmp"
subdir=${ns_appresdir}/site-lisp && ${write_subdir}
rm -rf ${ns_appresdir}/share
endif
@@ -798,6 +812,7 @@ install-info: info
done; \
(cd "$${thisdir}"; \
${INSTALL_INFO} --info-dir="$(DESTDIR)${infodir}" "$(DESTDIR)${infodir}/$$elt"); \
+ cp elisp_type_hierarchy* $(DESTDIR)${infodir}/; \
done; \
fi
@@ -940,6 +955,7 @@ uninstall: uninstall-$(NTDIR) uninstall-doc uninstall-gsettings-schemas
ext=.gz; else ext=; fi; \
rm -f $$elt$$ext $$elt-[1-9]$$ext $$elt-[1-9][0-9]$$ext; \
done; \
+ rm -f elisp_type_hierarchy.jpg elisp_type_hierarchy.txt; \
fi)
(if [ -n "${GZIP_PROG}" ]; then \
ext=.gz; else ext=; fi; \
@@ -992,6 +1008,12 @@ endef
mostlyclean_dirs = src oldXMenu lwlib lib lib-src nt doc/emacs doc/misc \
doc/lispref doc/lispintro test
+### Add the libexec directory to mostlyclean_dirs if its Makefile has
+### been created.
+ifneq ($(wildcard exec/Makefile),)
+mostlyclean_dirs := $(mostlyclean_dirs) exec
+endif
+
$(foreach dir,$(mostlyclean_dirs),$(eval $(call submake_template,$(dir),mostlyclean)))
mostlyclean: $(mostlyclean_dirs:=_mostlyclean)
@@ -1004,7 +1026,8 @@ mostlyclean: $(mostlyclean_dirs:=_mostlyclean)
### with them.
###
### Delete '.dvi' files here if they are not part of the distribution.
-clean_dirs = $(mostlyclean_dirs) nextstep admin/charsets admin/unidata
+clean_dirs = $(mostlyclean_dirs) java cross nextstep admin/charsets \
+ admin/unidata
$(foreach dir,$(clean_dirs),$(eval $(call submake_template,$(dir),clean)))
@@ -1086,6 +1109,8 @@ extraclean: maintainer-clean
-[ "${srcdir}" = "." ] || \
find ${srcdir} '(' -name '*~' -o -name '#*' ')' ${FIND_DELETE}
-find . '(' -name '*~' -o -name '#*' ')' ${FIND_DELETE}
+ -rm -f ${srcdir}/exec/config-tmp-* ${srcdir}/exec/aclocal.m4 \
+ ${srcdir}/src/config.in ${srcdir}/exec/configure
# The src subdir knows how to do the right thing
# even when the build directory and source dir are different.
@@ -1099,7 +1124,7 @@ TAGS tags: lib lib-src # src
$(MAKE) -C doc/lispref tags
$(MAKE) -C doc/misc tags
-CHECK_TARGETS = check check-maybe check-expensive check-all
+CHECK_TARGETS = check check-maybe check-expensive check-all check-byte-compile
.PHONY: $(CHECK_TARGETS)
$(CHECK_TARGETS): all
$(MAKE) -C test $@
@@ -1278,7 +1303,7 @@ emacslog = build-aux/gitlog-to-emacslog
# The ChangeLog history files are called ChangeLog.1, ChangeLog.2, ...,
# ChangeLog.$(CHANGELOG_HISTORY_INDEX_MAX). $(CHANGELOG_N) stands for
# the newest (highest-numbered) ChangeLog history file.
-CHANGELOG_HISTORY_INDEX_MAX = 4
+CHANGELOG_HISTORY_INDEX_MAX = 3
CHANGELOG_N = ChangeLog.$(CHANGELOG_HISTORY_INDEX_MAX)
# Convert git commit log to ChangeLog file. make-dist uses this.
@@ -1288,11 +1313,11 @@ ChangeLog:
./$(emacslog) -o $(CHANGELOG) -n $(CHANGELOG_HISTORY_INDEX_MAX)
# Check that we are in a good state for changing history.
-PREFERRED_BRANCH = emacs-29
+PREFERRED_BRANCH = emacs-28
preferred-branch-is-current:
git branch | grep -q '^\* $(PREFERRED_BRANCH)$$'
unchanged-history-files:
- x=$$(git diff-files --name-only $(CHANGELOG_N) $(emacslog)) && \
+ x=`git diff-files --name-only $(CHANGELOG_N) $(emacslog)` && \
test -z "$$x"
# Regular expression that matches the newest commit covered by a ChangeLog.
diff --git a/README b/README
index b972a53e9f3..c0b4df650e1 100644
--- a/README
+++ b/README
@@ -2,7 +2,7 @@ Copyright (C) 2001-2024 Free Software Foundation, Inc.
See the end of the file for license conditions.
-This directory tree holds version 29.3.50 of GNU Emacs, the extensible,
+This directory tree holds version 30.0.50 of GNU Emacs, the extensible,
customizable, self-documenting real-time display editor.
The file INSTALL in this directory says how to build and install GNU
@@ -95,6 +95,11 @@ There are several subdirectories:
'admin' holds files used by Emacs developers, and Unicode data files.
'build-aux' holds auxiliary files used during the build.
'm4' holds Autoconf macros used for generating the configure script.
+'java' holds the Java code for the Emacs port to Android.
+'cross' holds Makefiles and an additional copy of gnulib used to build
+ Emacs for Android devices.
+'exec' holds the source code to several helper executables used to run
+ user-installed programs on Android.
Building Emacs on non-Posix platforms requires tools that aren't part
of the standard distribution of the OS. The platform-specific README
diff --git a/admin/CPP-DEFINES b/admin/CPP-DEFINES
index 06986ec8f48..c07fdc487ee 100644
--- a/admin/CPP-DEFINES
+++ b/admin/CPP-DEFINES
@@ -25,6 +25,9 @@ SOLARIS2
USG
USG5_4
HAIKU Compiling on Haiku.
+__ANDROID__ Compiling for the Android operating system.
+__ANDROID_API__ A numerical "API level" indicating the version of
+ Android being compiled for; see http://apilevels.com.
** Distinguishing GUIs **
@@ -35,10 +38,14 @@ 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_X_WINDOWS Compile support for X Window system. Equivalent to HAVE_X11.
+HAVE_ANDROID Compiling the Android GUI interface. Enough of this
+ code is compiled for the build machine cross-compiling
+ the Android port to produce an Emacs binary that can
+ run Lisp code in batch mode, for the purpose of running
+ the byte-compiler.
+ANDROID_STUBIFY The Android GUI interface is being compiled for the build
+ machine, as above.
** X Windows features **
HAVE_X11R6 Whether or not the system has X11R6. (Always defined.)
diff --git a/admin/MAINTAINERS b/admin/MAINTAINERS
index 98bbfa5bd7c..4fa65a8df24 100644
--- a/admin/MAINTAINERS
+++ b/admin/MAINTAINERS
@@ -124,10 +124,6 @@ Ulf Jasper
lisp/net/newsticker.el
test/lisp/net/newsticker-tests.el
- Icalendar
- lisp/calendar/icalendar.el
- test/lisp/calendar/icalendar-tests.el
-
Amin Bandali
ERC
lisp/erc/*
@@ -137,6 +133,8 @@ Andrea Corallo
Lisp native compiler
src/comp.c
lisp/emacs-lisp/comp.el
+ lisp/emacs-lisp/comp-common.el
+ lisp/emacs-lisp/comp-run.el
lisp/emacs-lisp/comp-cstr.el
test/src/comp-*.el
@@ -165,6 +163,75 @@ Po Lu
Haiku battery support in lisp/battery.el
+ The Android port:
+ src/android-asset.h
+ src/android.c
+ src/android-emacs.c
+ src/androidfns.c
+ src/androidfont.c
+ src/androidgui.h
+ src/android.h
+ src/androidmenu.c
+ src/androidselect.c
+ src/androidterm.c
+ src/androidterm.h
+ src/androidvfs.c
+ src/sfnt.c
+ src/sfntfont-android.c
+ src/sfntfont.c
+ src/sfntfont.h
+ src/sfnt.h
+ java/org/gnu/emacs/EmacsActivity.java
+ java/org/gnu/emacs/EmacsApplication.java
+ java/org/gnu/emacs/EmacsClipboard.java
+ java/org/gnu/emacs/EmacsContextMenu.java
+ java/org/gnu/emacs/EmacsCursor.java
+ java/org/gnu/emacs/EmacsDesktopNotification.java
+ java/org/gnu/emacs/EmacsDialogButtonLayout.java
+ java/org/gnu/emacs/EmacsDialog.java
+ java/org/gnu/emacs/EmacsDirectoryEntry.java
+ java/org/gnu/emacs/EmacsDocumentsProvider.java
+ java/org/gnu/emacs/EmacsDrawable.java
+ java/org/gnu/emacs/EmacsDrawLine.java
+ java/org/gnu/emacs/EmacsDrawPoint.java
+ java/org/gnu/emacs/EmacsDrawRectangle.java
+ java/org/gnu/emacs/EmacsFillPolygon.java
+ java/org/gnu/emacs/EmacsFillRectangle.java
+ java/org/gnu/emacs/EmacsFontDriver.java
+ java/org/gnu/emacs/EmacsGC.java
+ java/org/gnu/emacs/EmacsHandleObject.java
+ java/org/gnu/emacs/EmacsHolder.java
+ java/org/gnu/emacs/EmacsInputConnection.java
+ java/org/gnu/emacs/EmacsLauncherPreferencesActivity.java
+ java/org/gnu/emacs/EmacsMultitaskActivity.java
+ java/org/gnu/emacs/EmacsNative.java
+ java/org/gnu/emacs/EmacsNoninteractive.java
+ java/org/gnu/emacs/EmacsOpenActivity.java
+ java/org/gnu/emacs/EmacsPixmap.java
+ java/org/gnu/emacs/EmacsPreferencesActivity.java
+ java/org/gnu/emacs/EmacsSafThread.java
+ java/org/gnu/emacs/EmacsSdk11Clipboard.java
+ java/org/gnu/emacs/EmacsSdk23FontDriver.java
+ java/org/gnu/emacs/EmacsSdk7FontDriver.java
+ java/org/gnu/emacs/EmacsSdk8Clipboard.java
+ java/org/gnu/emacs/EmacsService.java
+ java/org/gnu/emacs/EmacsSurfaceView.java
+ java/org/gnu/emacs/EmacsThread.java
+ java/org/gnu/emacs/EmacsView.java
+ java/org/gnu/emacs/EmacsWindowAttachmentManager.java
+ java/org/gnu/emacs/EmacsWindow.java
+ java/org/gnu/emacs/R.java
+ m4/ndk-build.m4
+ cross
+
+ Android battery support in lisp/battery.el
+
+Jim Porter
+ Eshell
+ lisp/eshell/*
+ test/lisp/eshell/*
+ doc/misc/eshell.texi
+
==============================================================================
2. Areas that someone is willing to maintain, although he would not
necessarily mind if someone else was the official maintainer.
@@ -293,13 +360,16 @@ Po Lu
X11 and GTK xwidget support in src/xwidget.c
Precision pixel scrolling in lisp/pixel-scroll.el
+Daniel Pettersson
+ lisp/jsonrpc.el
+
==============================================================================
3. Externally maintained packages.
==============================================================================
Tramp
Maintainer: Michael Albinus
- Repository: git://git.savannah.gnu.org/tramp.git
+ Repository: https://git.savannah.gnu.org/git/tramp.git
Mailing List: tramp-devel@gnu.org
Bug Reports: M-x tramp-bug
Notes: For backward compatibility requirements, see
@@ -311,9 +381,7 @@ Tramp
Modus themes
Maintainer: Protesilaos Stavrou
- Repository: https://git.sr.ht/~protesilaos
- Mailing list: https://lists.sr.ht/~protesilaos/modus-themes
- Bug Reports: M-x modus-themes-report-bug
+ Repository: https://github.com/protesilaos/modus-themes
doc/misc/modus-themes.org
etc/themes/modus*.el
@@ -321,7 +389,7 @@ Modus themes
Org Mode
Home Page: https://orgmode.org/
Maintainer: Org Mode developers
- Repository: git://git.sv.gnu.org/emacs/org-mode.git
+ Repository: https://git.savannah.gnu.org/git/emacs/org-mode.git
Mailing list: emacs-orgmode@gnu.org
Bug Reports: M-x org-submit-bug-report
Notes: Org Mode is maintained as a separate project that is
diff --git a/admin/admin.el b/admin/admin.el
index 30bc147940c..7fa2727aeb7 100644
--- a/admin/admin.el
+++ b/admin/admin.el
@@ -110,7 +110,7 @@ Root must be the root of an Emacs source tree."
(submatch (1+ (in "0-9."))))))
(set-version-in-file root "configure.ac" version
(rx (and "AC_INIT" (1+ (not (in ?,)))
- ?, (0+ space) ?\[
+ ?, (0+ space)
(submatch (1+ (in "0-9."))))))
(set-version-in-file root "nt/README.W32" version
(rx (and "version" (1+ space)
@@ -843,8 +843,11 @@ $Date: %s $
(package-install pkg)
(require pkg nil t))))
+(declare-function org-html-export-as-html "ox-html.el")
(defvar org-html-postamble)
(defvar org-html-mathjax-template)
+(defvar htmlize-output-type)
+
(defun make-news-html-file (root version)
"Convert the NEWS file into an HTML file."
(interactive (let ((root
@@ -1035,8 +1038,7 @@ If optional argument OLD is non-nil, also scan for `defvar's."
(and grp
(setq grp (car (cdr-safe grp))) ; (quote foo) -> foo
(setq ver (assq grp glist))))
- (setq alist (cons (cons var ver) alist))))
- (if form (format-message "Malformed defcustom: `%s'" form)))))
+ (setq alist (cons (cons var ver) alist)))))))
(message "%sdone" m)
alist))
diff --git a/admin/authors.el b/admin/authors.el
index 88c01f14120..da9f4257153 100644
--- a/admin/authors.el
+++ b/admin/authors.el
@@ -48,9 +48,7 @@ files.")
("Alexander Gramiak" "Alex Gramiak")
("Alexandru Harsanyi" "Alex Harsanyi")
("Álvar Jesús Ibeas Martín" "Álvar Ibeas")
- (nil "ambihelical")
("Andrea Corallo" "AndreaCorallo")
- ("Andrii Kolomoiets" "andreyk\\.mad@gmail\\.com")
("Andrew Csillag" "Drew Csillag")
("Andrew G Cohen" "Andrew Cohen")
("Anna M. Bigatti" "Anna Bigatti")
@@ -58,26 +56,19 @@ files.")
("Barry A. Warsaw" "Barry A. Warsaw, Century Computing, Inc."
"Barry A. Warsaw, ITB" "Barry Warsaw")
("Bastien Guerry" "Bastien .*bzg")
- ("Benjamin Carlsson" "glacials" "ben@twos\\.dev")
- ("Benjamin Schwerdtner" "Benjamin\\.Schwerdtner@gmail\\.com" "Ben Schw")
("Bill Carpenter" "WJ Carpenter")
("Bill Mann" "William F. Mann")
("Bill Rozas" "Guillermo J. Rozas")
- ("Billy Zheng" "vil963@gmail\\.com")
- (nil "binjo\\.cn@gmail\\.com")
- (nil "bug-gnu-emacs@gnu\\.org") ; mistake
+ (nil "binjo.cn@gmail.com")
+ (nil "bug-gnu-emacs@gnu.org") ; mistake
("Björn Torkelsson" "Bjorn Torkelsson")
("Brian Fox" "Brian J. Fox")
("Brian P Templeton" "BT Templeton")
("Brian Sniffen" "Brian T. Sniffen")
- (nil "brotzeitmacher@gmail\\.com")
(nil "castor@my-dejanews")
- (nil "chengang31@gmail\\.com")
+ (nil "chengang31@gmail.com")
(nil "chuntaro")
("Clément Pit-Claudel" "Clément Pit--Claudel")
- (nil "Cristian" "crstml@libero\\.it")
- ("Le Trung Dan" "daanturo@gmail\\.com" "Daanturo")
- ("Daniel Freeman" "dannyfreeman")
("David Abrahams" "Dave Abrahams")
("David J. Biesack" "David Biesack")
("David De La Harpe Golden" "David Golden")
@@ -90,7 +81,7 @@ files.")
("Daniel Laurens Nicolai" "dalanicolai")
(nil "deech@deech")
("Deepak Goel" "D. Goel")
- ("Earl Hyatt" "Earl" "ej32u@protonmail\\.com")
+ ("Earl Hyatt" "Earl" "ej32u@protonmail.com")
("Ed L. Cashin" "Ed L Cashin")
("Edward M. Reingold" "Ed\\(ward\\( M\\)?\\)? Reingold" "Reingold Edward M")
("Emilio C. Lopes" "Emilio Lopes")
@@ -102,26 +93,19 @@ files.")
(nil "felix\\.dick@web\\.de")
("Felicián Németh" "Felician Nemeth")
(nil "foudfou")
- ("Feraidoon Mehri"
- "NightMachinary"
- "rudiwillalwaysloveyou@gmail\\.com" "fifymehry@gmail\\.com")
("Francis Litterio" "Fran Litterio")
("Francis J. Wright" "Dr Francis J. Wright" "Francis Wright")
("François Pinard" "Francois Pinard")
("Francesco Potortì" "Francesco Potorti" "Francesco Potorti`")
("Frederic Pierresteguy" "Fred Pierresteguy")
(nil "^FSF")
- (nil "galeo")
- ("Garid Zorigoo" "garid3000" "garidzorigoo@gmail\\.com")
("Gerd Möllmann" "Gerd Moellmann")
(nil "haqle314")
("Grégoire Jadi" "Gregoire Jadi")
("Hallvard B. Furuseth" "Hallvard B Furuseth" "Hallvard Furuseth")
- (nil "hokomo@airmail\\.cc" "hokomo")
("Hrvoje Nikšić" "Hrvoje Niksic")
("Ian Dunn" "^Ian D\\>")
;; lisp/org/ChangeLog.1 2010-11-11.
- ("Ignacio Casso" "ignacio\\.decasso@imdea\\.org" "ignaciocasso@hotmail\\.com")
(nil "immerrr")
(nil "aaa bbb")
(nil "Code Extracted") ; lisp/newcomment.el's "Author:" header
@@ -139,8 +123,6 @@ files.")
("Jérémie Courrèges-Anglas" "Jeremie Courreges-Anglas")
("Jeremy Bertram Maitin-Shepard" "Jeremy Maitin-Shepard")
("Jérémy Compostella" "Jeremy Compostella")
- (nil "jgarte@" "jgart")
- (nil "jicksaw@pm\\.me" "jicksaw")
("Jimmy Aguilar Mena" "Ergus")
("Jindřich Makovička" "Jindrich Makovicka")
("Johan Bockgård" "Johan Bockgard")
@@ -155,7 +137,6 @@ files.")
("Juan León Lahoz García" "Juan-Leon Lahoz Garcia")
("Jürgen Hötzel" "Juergen Hoetzel")
(nil "k3tu0isui")
- (nil "kby@tilde\\.team")
("K. Shane Hartman" "Shane Hartman")
("Kai Großjohann" "Kai Grossjohann")
("Karl Berry" "K. Berry")
@@ -171,9 +152,6 @@ files.")
("Koen van Greevenbroek" "realcomplex" "koenvg@posteo\\.net")
("Kyle Jones" "Kyle E. Jones")
("Lars Magne Ingebrigtsen" "Lars Ingebrigtsen")
- ("Laurence Warne" "lWarne" "laurencewarne@gmail\\.com")
- (nil "lensplaysgames@gmail\\.com")
- (nil "lorniu@gmail\\.com")
(nil "LynX@bk.ru")
(nil "lu4nx")
("Marcus G. Daniels" "Marcus Daniels")
@@ -195,7 +173,7 @@ files.")
("Michael R. Cook" "Michael Cook")
("Michael Sperber" "Mike Sperber" "Michael Sperber \\[Mr. Preprocessor\\]")
("Michalis V" "^mvar")
- ("Miha Rihtaršič" "Miha Rihtarsic" "miha@kamnitnik\\.top" "miha")
+ ("Miha Rihtaršič" "Miha Rihtarsic")
("Mikio Nakajima" "Nakajima Mikio")
(nil "montag451@laposte\\.net")
("Morgan Smith" "Morgan J\\. Smith")
@@ -206,12 +184,9 @@ files.")
("Noah Peart" "noah\\.v\\.peart@gmail\\.com")
("Noorul Islam" "Noorul Islam K M")
;;; ("Tetsurou Okazaki" "OKAZAKI Tetsurou") ; FIXME?
- (nil "odanoburu@")
- (nil "one\\.last\\.kiss@outlook\\.com")
- ("Cao ZhenXiang" "mail@ookami\\.one")
("Óscar Fuentes" "Oscar Fuentes")
(nil "pillule")
- (nil "psyberbits@gmail\\.com")
+ (nil "psyberbits@gmail.com")
("Paul Eggert" "Paul R\\. Eggert")
("Pavel Janík" "Pavel Janík Ml." "Pavel Janik Ml." "Pavel Janik")
("Pavel Kobiakov" "Pavel Kobyakov")
@@ -223,19 +198,15 @@ files.")
("Philip Kaludercic" "Philip K\\." "Philip K")
("Philipp Stephani" "Philipp .*phst@google")
("Piotr Zieliński" "Piotr Zielinski")
- ("Po Lu" "Po Lu Via") ; looks like a mistake
- ("Po Lu" "oldosfan" "luangruo@yahoo\\.com")
+ ("Po Lu" "Po Lu Via" "Your Name") ; looks like a mistake
("Przemysław Wojnowski" "Przemyslaw Wojnowski")
- ("Qifan Wang" "LdBeth" "andpuke@foxmail\\.com")
- ("R. Bernstein" "rb@dustyfeet\\.com")
+ ("R. Bernstein" "rb@dustyfeet.com")
("Rainer Schöpf" "Rainer Schoepf")
("Raja R. Harinath" "Raja R Harinath")
("Rasmus Pank Roulund" "Rasmus .*rasmus@gmx")
- (nil "rbrtb@")
("Richard G. Bielawski" "Richard G Bielawski" "Richard Bielawski")
("Richard King" "Dick King")
("Richard M. Stallman" "Richard Stallman" "rms@gnu.org")
- (nil "webmaster@robario\\.com")
("Robert J. Chassell" "Bob Chassell")
("Roberto Huelga Díaz" "Roberto Huelga")
("Rodney J. Whitby" "Rod Whitby")
@@ -243,21 +214,19 @@ files.")
("Ron Schnell" "Ronnie Schnell")
("Rui-Tao Dong" "Rui-Tao Dong ~{6-HpLN~}")
("Ryan Thompson" "Ryan .*rct@thompsonclan")
- (nil "rvs314")
(nil "rzl24ozi")
("Sacha Chua" "Sandra Jean Chua")
("Sam Steingold" "Sam Shteingold")
("Satyaki Das" "Indexed search by Satyaki Das")
("Sébastien Vauban" "Sebastien Vauban")
("Sergey Litvinov" "Litvinov Sergey")
- ("Simen Heggestøyl" "simenheg@gmail\\.com")
+ ("Simen Heggestøyl" "simenheg@gmail.com")
(nil "prime.wizard")
("Shun-ichi Goto" "Shun-ichi GOTO")
;; The trailing dash is a kludge, so this contributor is not ignored.
("skykanin-" "skykanin@users\\.noreply\\.github\\.com")
;; There are other Stefans.
;;; ("Stefan Monnier" "Stefan")
- (nil "ssnnoo")
("Steven L. Baur" "SL Baur" "Steven L Baur")
("Stewart M. Clamen" "Stewart Clamen")
("Stuart D. Herring" "Stuart Herring" "Davis Herring")
@@ -271,7 +240,6 @@ files.")
("Thomas Dye" "Tom Dye")
("Thomas Horsley" "Tom Horsley") ; FIXME ?
("Thomas Wurgler" "Tom Wurgler")
- (nil "thuna\\.cing@gmail\\.com")
("Toby Cubitt" "Toby S\\. Cubitt")
("Tomohiko Morioka" "MORIOKA Tomohiko")
("Torbjörn Axelsson" "Torbjvrn Axelsson")
@@ -280,29 +248,23 @@ files.")
("Tsugutomo Enami" "enami tsugutomo")
("Ulrich Müller" "Ulrich Mueller")
(nil "vividsnow")
- (nil "Valenoern" "valenoern@distributary\\.network")
("Vincent Del Vecchio" "Vince Del Vecchio")
- ("M Visuwesh" "visuweshm@gmail\\.com")
- (nil "vjoki@")
- (nil "whatacold@gmail\\.com")
("William M. Perry" "Bill Perry")
("Wlodzimierz Bzyl" "W.*dek Bzyl")
(nil "xyblor")
- ("Yilkal Argaw" "yilkalargaw" "yilkalargawworkneh@gmail\\.com")
("Yoni Rabkin" "Yoni Rabkin Katzenell")
("Yoshinori Koseki" "KOSEKI Yoshinori" "小関 吉則")
- ("Yuzhana Ego" "YugaEgo" "yet@ego\\.team")
("Yutaka NIIBE" "NIIBE Yutaka")
(nil "stardiviner")
- (nil "lin\\.sun")
+ (nil "lin.sun")
("Nitish Chinta" "nitishch")
("Carlos Pita" "memeplex")
("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")
+ ("Lin Zhou" "georgealbert@qq.com")
+ (nil "yan@metatem.net")
+ (nil "gnu_lists@halloleo.hailmail.net")
)
"Alist of author aliases.
@@ -976,30 +938,9 @@ Changes to files in this list are not listed.")
"emacsclient.c" "etags.c" "hexl.c" "make-docfile.c" "movemail.c"
"test-distrib.c" "testfile"
"tpu-edt.doc" ; see below
- ;; etc/images/gnus/
- "etc/images/gnus/important.pbm"
- "etc/images/gnus/receipt.pbm"
- "etc/images/gnus/unimportant.pbm"
"iso-swed.el"
- ;; lisp/obsolete/
"lisp/obsolete/vc-mcvs.el"
"obsolete/vc-mcvs.el"
- "lisp/obsolete/patcomp.el"
- "lisp/obsolete/abbrevlist.el"
- "lisp/obsolete/assoc.el"
- "obsolete/assoc.el"
- "lisp/obsolete/complete.el"
- "lisp/obsolete/cust-print.el"
- "lisp/obsolete/erc-hecomplete.el"
- "lisp/obsolete/mailpost.el"
- "obsolete/mailpost.el"
- "lisp/obsolete/mouse-sel.el"
- "lisp/obsolete/old-emacs-lock.el"
- "obsolete/old-emacs-lock.el"
- "lisp/obsolete/patcomp.el"
- "lisp/obsolete/pc-select.el"
- "lisp/obsolete/s-region.el"
- "obsolete/pc-select.el"
"nnwarchive.el"
"nnultimate.el"
"nnslashdot.el"
@@ -1035,41 +976,7 @@ Changes to files in this list are not listed.")
"flymake-ui.el"
"pinentry.el"
"ledit.el"
- "lmenu.el"
- "src/pgtkselect.h"
- "test/manual/noverlay/many-errors.h"
- "lisp/better-pixel-scroll.el"
- "test/infra/default-gitlab-ci.yml"
- "test/infra/test-jobs-generator.sh"
- "org-install.el"
- ;; use-package stuff removed after it was added
- "etc/USE-PACKAGE-NEWS"
- "lisp/use-package/bind-chord.el"
- "lisp/use-package/use-package-chords.el"
- "lisp/use-package/use-package-chords-tests.el"
- "test/lisp/use-package/use-package-chords-tests.el"
- ;; Eglot stuff removed after it was added
- "README.mdown"
- "README.md"
- ".travis.yml"
- ;; Tree-sitter stuff
- "admin/notes/tree-sitter/html-manual/Parser_002dbased-Font-Lock.html"
- "admin/notes/tree-sitter/html-manual/Parsing-Program-Source.html"
- "admin/notes/tree-sitter/html-manual/build-manual.sh"
- "admin/notes/tree-sitter/html-manual/Accessing-Node.html"
- "admin/notes/tree-sitter/html-manual/Language-Definitions.html"
- "admin/notes/tree-sitter/html-manual/Multiple-Languages.html"
- "admin/notes/tree-sitter/html-manual/Parser_002dbased-Indentation.html"
- "admin/notes/tree-sitter/html-manual/Pattern-Matching.html"
- "admin/notes/tree-sitter/html-manual/Retrieving-Node.html"
- "admin/notes/tree-sitter/html-manual/Tree_002dsitter-C-API.html"
- "admin/notes/tree-sitter/html-manual/Using-Parser.html"
- "admin/notes/tree-sitter/html-manual/manual.css"
- "admin/notes/tree-sitter/build-module/build.sh"
- "admin/notes/tree-sitter/build-module/batch.sh"
- "doc/misc/gnus-coding.texi"
- "gnus-coding.texi"
- )
+ "lmenu.el")
"File names which are valid, but no longer exist (or cannot be found)
in the repository.")
@@ -1448,153 +1355,6 @@ in the repository.")
("test/lisp/url/url-handlers-test.el" . "url-handlers-tests.el")
("test/src/dired-tests.el" . "dired-tests.el")
(".dir-locals.el" . ".dir-locals.el")
- ;; use-package files that were moved when use-package was added:
- ("use-package.texi" . "use-package.texi")
- ("use-package-core.el" . "use-package-core.el")
- ("bind-key.el" . "use-package-bind-key.el")
- ("use-package.el" . "use-package.el")
- ("use-package-tests.el" . "use-package-tests.el")
- ;; pgtk stuff which used incorrect file names
- ("pgtkmenu.c" . "pgtkmenu.c")
- ("pgtk-win.el" . "pgtk-win.el")
- ("pgtkfns.c" . "pgtkfns.c")
- ("pgtkterm.c" . "pgtkterm.c")
- ("pgtkterm.h" . "pgtkterm.h")
- ("../src/pgtkfns.c" . "pgtkfns.c")
- ("../src/pgtkterm.c" . "pgtkterm.c")
- ("../src/pgtkterm.h" . "pgtkterm.h")
- ("../src/atimer.c" . "atimer.c")
- ("../src/gtkutil.c" . "gtkutil.c")
- ("../src/image.c" . "image.c")
- ("../lisp/faces.el" . "faces.el")
- ("../src/pgkterm.h" . "pgkterm.h")
- ("pgkterm.c" . "pgkterm.c")
- ("../src/emacsgtkfixed.c" . "emacsgtkfixed.c")
- ("../src/xfaces.c" . "xfaces.c")
- ("../src/pgtkgui.h" . "pgtkgui.h")
- ("../src/dispextern.h" . "dispextern.h")
- ("../src/menu.c" . "menu.c")
- ("../lisp/net/browse-url.el" . "browse-url.el")
- ;; miscellany
- ("nsterm.m" . "nsterm.m")
- ("jsonrpc.el" . "jsonrpc.el")
- ("jsonrpc-tests.el" . "jsonrpc-tests.el")
- ("jrpc.el" . "jsonrpc.el")
- ("eldoc.el" . "eldoc.el")
- ("lisp/progmodes/ts-mode.el" . "typescript-ts-mode.el")
- ("icalendar-tests.el" . "icalendar-tests.el")
- ("lisp/progmodes/css-ts-mode.el" . "css-mode.el")
- ("lisp/erc/erc-tests.el" . "erc-tests.el")
- ("lisp/erc/erc-scenarios-base-reconnect.el" . "erc-scenarios-base-reconnect.el")
- ("test/lisp/erc-tests.el" . "erc-tests.el")
- ("eglot.el" . "eglot.el")
- ("eglot-tests.el" . "eglot-tests.el")
- ("NEWS.md" . "EGLOT-NEWS")
- ("test/lisp/comp-tests.el" . "comp-tests.el")
- ("package-vc.el" . "package-vc.el")
- ("package.el" . "package.el")
- ("lisp/net/tramp-docker.el" . "tramp-container.el")
- ("xterm.c" . "xterm.c")
- ("lisp/osc.el" . "ansi-osc.el")
- ("test/lisp/osc-tests.el" . "ansi-osc-tests.el")
- ("lisp/ansi-osc.el" . "ansi-osc-tests.el")
- ("test/lisp/thumbs-tests.el" . "thumbs-tests.el")
- ("rmail.el" . "rmail.el")
- ("window.el" . "window.el")
- ("nsmenu.m" . "nsmenu.m")
- ("nsfont.m" . "nsfont.m")
- ("nsfns.m" . "nsfns.m")
- ("src/nsterm.c" . "nsterm.m")
- ("subr.el" . "subr.el")
- ("test/lisp/image-dired-tests.el" . "image-dired-tests.el")
- ("modus-themes.org" . "modus-themes.org")
- ("emacs-authors-mode.el" . "emacs-authors-mode.el")
- ("lisp/textmodes/etc-authors-mode.el" . "emacs-authors-mode.el")
- ("bytecomp.el" . "bytecomp.el")
- ("test/lisp/makesum-tests.el" . "makesum-tests.el")
- ("rcirc.el" . "rcirc.el")
- ("haiku_support.cc" . "haiku_support.cc")
- ("gnus-art.el" . "gnus-art.el")
- ("mh-mime.el" . "mh-mime.el")
- ("terminal.c" . "terminal.c")
- ("eudc.texi" . "eudc.texi")
- ("gnus-search.el" . "gnus-search.el")
- ("lisp/gnus-search.el" . "gnus-search.el")
- ("ETAGS_good_1" . "ETAGS_good_1")
- ("ETAGS_good_2" . "ETAGS_good_2")
- ("ETAGS_good_3" . "ETAGS_good_3")
- ("ETAGS_good_4" . "ETAGS_good_4")
- ("ETAGS_good_5" . "ETAGS_good_5")
- ("ETAGS_good_6" . "ETAGS_good_6")
- ("test/lisp/eshell-em-script-tests.el" . "eshell-em-script-tests.el")
- ("test/lisp/eshell-em-glob-tests.el" . "eshell-em-glob-tests.el")
- ("lisp/eshell/esh-var-tests.el" . "esh-var-tests.el")
- ("test/lisp/eshell/esh-var-test.el" . "esh-var-tests.el")
- ("gnus-logic.el" . "gnus-logic.el")
- ("sh-script.el" . "sh-script.el")
- ("repeat.el" . "repeat.el")
- ("files.el" . "files.el")
- ("lisp/emacs-lisp/generate-file.el" . "generate-lisp-file.el")
- ("pp.el" . "pp.el")
- ("src/help-fns.el" . "help-fns.el")
- ("print.c" . "print.c")
- ("shell.el" . "shell.el")
- ("xdisp.c" . "xdisp.c")
- ("haikufns.c" . "haikufns.c")
- ("haikuterm.c" . "haikuterm.c")
- ("haikumenu.c" . "haikumenu.c")
- ("haikufont.c" . "haikufont.c")
- ("src/haiku_support.c" . "haiku_support.cc")
- ("src/haiku_draw_support.c" . "haiku_draw_support.cc")
- ("haiku-win.el" . "haiku-win.el")
- ("elisp-mode.el" . "elisp-mode.el")
- ("doc-view.el" . "doc-view.el")
- ("src/lisp/net/rcirc.el" . "rcirc.el")
- ("project.el" . "project.el")
- ("emacsbug.el" . "emacsbug.el")
- ("timefns.c" . "timefns.c")
- ("xwidget.c" . "xwidget.c")
- ("src/xwidget.el" . "xwidget.el")
- ("lisp/net/lisp/net/tramp-sshfs.el" . "tramp-sshfs.el")
- ("tramp-sudoedit.el" . "tramp-sudoedit.el")
- ("test/lisp/mail/undigest.el" . "undigest-tests.el")
- ("Activate.c" . "Activate.c")
- ("quail.el" . "quail.el")
- ("sed1v2.inp" . "sed1v2.inp")
- ("ruby-parenless-call-arguments-indent.rb" . "ruby-parenless-call-arguments-indent.rb")
- ("commands.texi" . "doc/lispref/commands.texi")
- ("message.el" . "message.el")
- ("lisp/debug-early.el" . "debug-early.el")
- ("tabulated-list.el" . "tabulated-list.el")
- ("mouse.el" . "mouse.el")
- ("hi-lock.el" . "hi-lock.el")
- ("man.el" . "man.el")
- ("doc/emacs/frames.tex" . "frames.texi")
- ("lisp/emacs-list/eieio-compat.el" . "eieio-compat.el")
- ("epa.el" . "epa.el")
- ("lisp/emacs-lisp/macroexpand.el" . "macroexp.el")
- ("src/pixel-scroll.el" . "pixel-scroll.el")
- ("test/lisp/mh-e/mh-utils.el" . "mh-utils-tests.el")
- ("compile.el" . "compile.el")
- ("compile-tests.el" . "compile-tests.el")
- ("Makefile.in" . "Makefile.in")
- ("Makefie.in" . "Makefile.in")
- ("test/lisp/net/netrc-tests.el" . "auth-source-tests.el")
- ("test/lisp/ert-x-tests.el" . "ert-x-tests.el")
- ("lisp/mh-e-mh-scan.el" . "mh-scan.el")
- ("lisp/progmodes/c-fonts.el" . "cc-fonts.el")
- ("lisp/emacs/lisp/cl-generic.el" . "cl-generic.el")
- ("doc/lisprefdisplay.texi" . "display.texi")
- ("erc.el" . "erc.el")
- ("erc-tests.el" . "erc-tests.el")
- ("vc/vc-mtn.el" . "vc-mtn.el")
- ("net/rlogin.el" . "rlogin.el")
- ("emacs-lisp/eieio-compat.el" . "eieio-compat.el")
- ("mh-compat.el" . "mh-compat.el")
- ("url-about.el" . "url-about.el")
- ("url-dired.el" . "url-dired.el")
- ("lisp/text-modes/tex-mode.el" . "tex-mode.el")
- ("editfns.c" . "editfns.c")
)
"Alist of files which have been renamed during their lifetime.
Elements are (OLDNAME . NEWNAME).")
diff --git a/admin/charsets/Makefile.in b/admin/charsets/Makefile.in
index 4026a9d90c1..0a3f334a978 100644
--- a/admin/charsets/Makefile.in
+++ b/admin/charsets/Makefile.in
@@ -181,7 +181,7 @@ ${charsetdir}/GB180304.map: ${charsetdir}/GB180302.map ${gb180304}
${AM_V_GEN}$(AWK) -f ${gb180304} < $< > $@
${charsetdir}/JISX0201.map: ${GLIBC_CHARMAPS}/JIS_X0201.gz ${mapconv} ${compact}
- ${AM_V_GEN}(${mapconv} $< '/^<.*[ ]\/x[0-9]/' GLIBC-1 ${compact} && \
+ ${AM_V_GEN}(${run_mapconv} $< '/^<.*[ ]\/x[0-9]/' GLIBC-1 ${compact} && \
echo "# Generated by hand" && \
echo "0xA1-0xDF 0xFF61" ) > $@
diff --git a/admin/charsets/mapconv b/admin/charsets/mapconv
index ba012ddf4b7..91d580e89d1 100755
--- a/admin/charsets/mapconv
+++ b/admin/charsets/mapconv
@@ -38,7 +38,8 @@
## So that eg [A-F] as used by KANJI-DATABASE branch below works as expected.
## Otherwise with LANG=en_US.utf8, CNS-6.map was generated with a
## bogus entry. By experiment, LC_COLLATE=C was not enough.
-export LC_ALL=C
+LC_ALL=C
+export LC_ALL
BASE=`expr "$1" : '.*/\(.*\)' '|' "$1"` # basename
FILE="admin/charsets/mapfiles/$BASE"
diff --git a/admin/coccinelle/alloc_cast.cocci b/admin/coccinelle/alloc_cast.cocci
new file mode 100644
index 00000000000..91810dbc7e4
--- /dev/null
+++ b/admin/coccinelle/alloc_cast.cocci
@@ -0,0 +1,6 @@
+// Remove redundant casts from memory allocation functions.
+@@
+type T;
+@@
+-(T *)
+ \(xmalloc\|xzalloc\|xrealloc\|xpalloc\|xnrealloc\)(...)
diff --git a/admin/coccinelle/build_string.cocci b/admin/coccinelle/build_string.cocci
index d47727018dd..9421a140658 100644
--- a/admin/coccinelle/build_string.cocci
+++ b/admin/coccinelle/build_string.cocci
@@ -4,3 +4,9 @@ identifier I;
@@
- make_string (I, strlen (I))
+ build_string (I)
+
+@@
+constant C;
+@@
+- make_string (C, strlen (C))
++ build_string (C)
diff --git a/admin/coccinelle/nilp.cocci b/admin/coccinelle/nilp.cocci
new file mode 100644
index 00000000000..ccebbbe1c80
--- /dev/null
+++ b/admin/coccinelle/nilp.cocci
@@ -0,0 +1,6 @@
+// Prefer NILP (x) to EQ (x, Qnil)
+@@
+expression X;
+@@
+- EQ (X, Qnil)
++ NILP (X)
diff --git a/admin/coccinelle/unibyte_string.cocci b/admin/coccinelle/unibyte_string.cocci
index 0ff8cafa15d..97f87e5a4ca 100644
--- a/admin/coccinelle/unibyte_string.cocci
+++ b/admin/coccinelle/unibyte_string.cocci
@@ -4,3 +4,9 @@ identifier I;
@@
- make_unibyte_string (I, strlen (I))
+ build_unibyte_string (I)
+
+@@
+constant C;
+@@
+- make_unibyte_string (C, strlen (C))
++ build_unibyte_string (C)
diff --git a/admin/coccinelle/xsave.cocci b/admin/coccinelle/xsave.cocci
deleted file mode 100644
index 5172bb55b33..00000000000
--- a/admin/coccinelle/xsave.cocci
+++ /dev/null
@@ -1,11 +0,0 @@
-// Adjust users of XSAVE_POINTER and XSAVE_INTEGER.
-@@
-expression E;
-@@
-(
-- XSAVE_POINTER (E)
-+ XSAVE_POINTER (E, 0)
-|
-- XSAVE_INTEGER (E)
-+ XSAVE_INTEGER (E, 1)
-)
diff --git a/admin/codespell/codespell.exclude b/admin/codespell/codespell.exclude
index 2503f4a9a16..6413a73701b 100644
--- a/admin/codespell/codespell.exclude
+++ b/admin/codespell/codespell.exclude
@@ -1,3 +1,54 @@
+ say "And this happens inbetween";
+ @ture)
+ ($sig,$na,@ture)
+($sig,$na,@ture)
+@ture)
+((squery 10 "SQUERY alis :help list")
+ (0.01 ":Alis@hub.uk NOTICE tester :See also: HELP EXAMPLES"))
+ (0.04 ":Alis@hub.uk NOTICE tester :[...]")
+ (0.01 ":Alis@hub.uk NOTICE tester :/SQUERY Alis LIST mask [-options]")
+ (0.08 ":Alis@hub.uk NOTICE tester :Searches for a channel")
+ (erc-scenarios-common-say "/SQUERY alis help list")
+ (should (equal '((regexp . "(string-match-p \"^[fo]+\" \"foobar\")\n => 0"))
+ (or "comm" "comma" "comman" "command" "commands"
+ (when (and (not (or skipp erc-timestamp-format))
+ (unless skipp
+ (skipp (or (and erc-stamp--skip-when-invisible invisible)
+;; if you type "foo", but typing just "fo" doesn't show the preview.
+ (Emacs main thre), pid 32619 (org.gnu.emacs)
+F DEBUG : pid: 32619, tid: 32644, name: Emacs main thre >>> org.gnu.emacs <<<
+ bnez $t2, .filld # start filling longs
+ j .filld # fill either doubleword or byte
+.filld:
+
+ (0.01 ":bob!~u@q2weir96jk3r2.irc PRIVMSG #chan :[06:08:40] alice: My sons would never so dishonour me.")
+ interger intger lits bool boolen constant filename
+ with typess = (sort (mapcar #'comp-supertypes
+ for types in typess
+;; FIXME: normalise `seq', both the construct and implicit sequences,
+;; `intersection', we may end up normalising subtrees multiple times
+;; One way to avoid this is to aggressively normalise the entire tree
+;; Such normalisation could normalise synonyms, eliminate `minimal-match'
+ ;; Normalise the constructor to `or' and the args recursively.
+ "Intersection of the normalised FORMS, as an interval set."
+FORM must be normalised (from `rx--normalise-char-pattern')."
+ "Optimise `or' arguments. Return a new rx form.
+Each element of ARGS should have been normalised using
+ (search-forward "retur") ; leaves point before the "n"
+with typess = (sort (mapcar #'comp-supertypes
+ (font-spec :registry "iso10646-1" :otf '(khmr nil (pres)))))
+(0.01 ":bob!~u@q2weir96jk3r2.irc PRIVMSG #chan :[06:08:40] alice: My sons would never so dishonour me.")
+ (0.05 ":bob!~u@q2weir96jk3r2.irc PRIVMSG #chan :alice: Pawn me to this your honour, she is his."))
+ (funcall expect 1 "Entirely honour"))
+ (0 ":bob!~u@rz2v467q4rwhy.irc PRIVMSG #chan :You have paid the heavens your function, and the prisoner the very debt of your calling. I have laboured for the poor gentleman to the extremest shore of my modesty; but my brother justice have I found so severe, that he hath forced me to tell him he is indeed Justice.")
+ (0.00 ":irc.example.net 501 tester x :is not a recognised user mode.")
+ (0.00 ":irc.example.net 501 dummy` x :is not a recognised user mode.")
+ (0.1 ":bob!~u@rz2v467q4rwhy.irc PRIVMSG #utf-8 :alice: Entirely honour; I would not be delay'd."))
+ integer integer list bool boolean constant filename
+ "def" "defi" "defin" "define"
+ "doc" "docu" "docum" "docume" "documen" "document"
+ case Aadd : overflow = ckd_add (&a, accum, next); break;
+ And this the second, again with the same distinction therefrom.
Bonus: Return a cons cell: (COMPILED . UPTODATE).
Bonus: Return a cons cell: (COMPILED . UPTODATE)."
(defun semantic-grammar-create-package (&optional force uptodate)
@@ -57,7 +108,6 @@ order but are now listed consecutively en bloc.
2003-06-11 Daniel Néri <done@mayonnaise.net>
2001-07-26 10:00:00 Steven E. Harris <seh@speakeasy.org>
2001-01-15 Jack Twilley <jmt@tbe.net>
-
matching LAMDA as a word. Noted by Stefan Monnier.
completion variant for every "LAMDA" name (bug#30513).
"foto"
@@ -195,7 +245,7 @@ mode setting. With the Inverse flag [@code{alog}], this command is
@r{ a b@: I B @: @: 2 @:alog@:(a,b) b^a}
@r{ a b@: I f I @: @: 2 @:alog@:(a,b) b^a}
Change comment about the iif hook to reflect the actual reason.
- "I + E (ln), L (exp), B (alog: B^X); f E (lnp1), f L (expm1)"
+ "\\`I' + \\`E' (ln), \\`L' (exp), \\`B' (alog: B^X); \\`f E' (lnp1), \\`f L' (expm1)"
(let (numer denom)
(setq numer (car (math-read-expr-list)))
(if (and (Math-num-integerp numer)
@@ -1177,9 +1227,6 @@ In CLOS, the argument list is (CLASS OBJECT SLOT-NAME), but
const char *cm_right; /* right (nd) */
(should (equal (ert-test-result-messages result) "a\nb\nc\nd\n")))))
(insert "a\nb\nc\nd\n")
- (insert "a\nb\nc\nd\n")
- (insert "a\nb\nc\nd\n")
- (insert "a\nb\nc\nd\n")
(insert "a\nb\nc\nd\n")
(should (string= (buffer-string) "Abc\nd efg\n(h ijk)."))))
(nd (read-directory-name "Create directory: "
@@ -1192,7 +1239,6 @@ DESCRIPTION:In this meeting\\, we will cover topics from product and enginee
;; RFC5546 refers to uninvited attendees as "party crashers".
That includes both spelling (e.g., "behavior", not "behaviour") and
* doc/lispref/control.texi (Signalling Errors)
- * doc/lispref/control.texi (Signalling Errors)
Re "behavior" vs "behaviour", etc.
+ [[https://protesilaos.com/codelog/2020-07-08-modus-themes-nuanced-colours/][Modus themes: major review of "nuanced" colours]] (2020-07-08)
+ [[https://protesilaos.com/codelog/2020-09-14-modus-themes-review-blues/][Modus themes: review of blue colours]] (2020-09-14)
@@ -1256,7 +1302,6 @@ Put dialogue in buffer."
"Given start brace BRA, and end brace KET, expand one line into many lines."
(regexp-quote ket)
(int-to-string (car vec)) ket sig-tail "\n"))
- "Given start brace BRA, and end brace KET, expand one line into many lines."
m | mo | mot | moti | motif ) val=motif ;;
i | in | ino | inot | inoti | inotif | inotify ) val=inotify ;;
2001-04-23 Kahlil Hodgson <kahlil@discus.anu.edu.au>
@@ -1270,14 +1315,11 @@ Put dialogue in buffer."
Rename from whitespace-skipping-for-quotes-not-ouside.
(whitespace-skipping-for-quotes-not-ouside)
Thread-Modell: posix
-Thread-Modell: posix
(ert-deftest indent-sexp-cant-go ()
(ert-deftest thunk-let-bound-vars-cant-be-set-test ()
(mml-secure-cust-fpr-lookup context 'encrypt "sub@example.org")))
(let ((p-e-fprs (mml-secure-cust-fpr-lookup
(p-s-fprs (mml-secure-cust-fpr-lookup
- (let ((p-e-fprs (mml-secure-cust-fpr-lookup
- (p-s-fprs (mml-secure-cust-fpr-lookup
(let ((s-e-fprs (mml-secure-cust-fpr-lookup
(s-s-fprs (mml-secure-cust-fpr-lookup
(ert-deftest doesnt-time-out ()
@@ -1308,7 +1350,6 @@ doc/emacs/docstyle.texi:14: fied ==> field
* follow.el (follow-inactive-menu): Rename from follow-deactive-menu.
* emacs-lisp/cconv.el (cconv-analyse-form): Warn use of ((λ ...) ...).
(feedmail-sendmail-f-doesnt-sell-me-out)
- (feedmail-sendmail-f-doesnt-sell-me-out)
Respect feedmail-sendmail-f-doesnt-sell-me-out.
* terminal.el (te-get-char, te-tic-sentinel):
from server-external-socket-initialised, since it should be
@@ -1401,7 +1442,6 @@ Paul Raines (raines at slac.stanford.edu),
(car secnd))) ; fetch_date
secnd (cdr secnd))
(car secnd))) ; Keep_flag
- secnd (cdr secnd))
(car secnd))) ; NOV_entry_position
@c LocalWords: DesBrisay Dcc devel dir dired docstring filll forw
Older versions of the themes provided options ~grayscale~ (or ~greyscale~)
@@ -1450,14 +1490,12 @@ DEFUN ("cond", Fcond, Scond, 0, UNEVALLED, 0,
2006-10-12 Magnus Henoch <mange@freemail.hu>
2006-10-11 Magnus Henoch <mange@freemail.hu>
2006-10-09 Magnus Henoch <mange@freemail.hu>
-2008-10-16 Magnus Henoch <mange@freemail.hu>
2007-12-31 Magnus Henoch <mange@freemail.hu>
2007-12-05 Magnus Henoch <mange@freemail.hu>
(ENUMABLE): Remove; no longer needed.
* lisp.h (ENUMABLE) [!_AIX]: Don't define to 0 merely because we're
* lisp.h (ENUMABLE, DEFINE_GDB_SYMBOL_ENUM): New macros.
* lisp.h (ENUMABLE, DEFINE_GDB_SYMBOL_ENUM): Delete macros.
- * lisp.h (ENUMABLE, DEFINE_GDB_SYMBOL_ENUM): New macros.
2023-06-29 Andrew G Cohen <cohen@andy.bu.edu>
2023-05-07 Andrew G Cohen <cohen@andy.bu.edu>
C-x b fo
@@ -1467,10 +1505,8 @@ DEFUN ("cond", Fcond, Scond, 0, UNEVALLED, 0,
2022-03-22 Andrew G Cohen <cohen@andy.bu.edu>
2022-03-20 Andrew G Cohen <cohen@andy.bu.edu>
2022-03-17 Andrew G Cohen <cohen@andy.bu.edu>
-2022-03-17 Andrew G Cohen <cohen@andy.bu.edu>
2022-03-04 Andrew G Cohen <cohen@andy.bu.edu>
2022-02-18 Andrew G Cohen <cohen@andy.bu.edu>
-2022-02-18 Andrew G Cohen <cohen@andy.bu.edu>
2022-02-11 Andrew G Cohen <cohen@andy.bu.edu>
2022-02-08 Andrew G Cohen <cohen@andy.bu.edu>
2022-02-03 Andrew G Cohen <cohen@andy.bu.edu>
@@ -1490,7 +1526,6 @@ extern struct servent *hes_getservbyname (/* char *, char * */);
servent = hes_getservbyname (service, "tcp");
if (servent)
servent = getservbyname (service, "tcp");
- if (servent)
struct servent *srv = getservbyname (service, protocol);
2003-04-10 Sebastian Tennant <seb@albert.vcisp.net> (tiny change)
Reported by Sebastian Tennant <sebyte@smolny.plus.com>.
@@ -1515,7 +1550,6 @@ extern struct servent *hes_getservbyname (/* char *, char * */);
(substring strin pos end-pos))))))
(defun dun-listify-string2 (strin)
(while (setq end-pos (string-search " " (substring strin pos)))
- (substring strin pos end-pos))))))
"any" "append" "as" "asc" "ascic" "async" "at_begin" "at_end" "audit"
"attribute" "(d)eclaration or (s)pecification?" t) ?s)
"quantity" "(f)ree, (b)ranch, or (s)ource quantity?" t)))
@@ -1549,3 +1583,5 @@ VERY VERY LONG STRIN | VERY VERY LONG STRIN
(ert-info ("Joined by bouncer to #chan@foonet, pal persent")
(ert-info ("Joined by bouncer to #chan@barnet, pal persent")
.UE .
+ (0.03 ":bob!~u@euegh6mj3y8r2.irc PRIVMSG #chan :alice: See, by good hap, yonder's my lord; I have sweat to see his honour.")
+ (0.05 ":bob!~u@euegh6mj3y8r2.irc PRIVMSG #chan :alice: But, in defence, by mercy, 'tis most just.")
diff --git a/admin/cus-test.el b/admin/cus-test.el
index 64c742ea855..10d6e34358d 100644
--- a/admin/cus-test.el
+++ b/admin/cus-test.el
@@ -146,7 +146,7 @@ Names should be as they appear in loaddefs.el.")
(defvar cus-test-errors nil
"List of problematic variables found by `cus-test-apropos'.
-Each element is (VARIABLE . PROBLEM); see `cus-test--format-errors'.")
+Each element is (VARIABLE . PROBLEM); see `cus-test--format-error'.")
(defvar cus-test-tested-variables nil
"List of options tested by last call of `cus-test-apropos'.")
@@ -221,8 +221,6 @@ The detected problematic options are stored in `cus-test-errors'."
;; Check the values
(mapc (lambda (value)
- ;; TODO for booleans, check for values that can be
- ;; evaluated and are not t or nil. Usually a bug.
(unless (widget-apply conv :match value)
(let ((err (list symbol :type-error value type)))
(unless (member err cus-test-errors)
@@ -426,7 +424,12 @@ in the Emacs source directory."
(mapatoms
;; This code is mainly from `custom-load-symbol'.
(lambda (symbol)
- (let ((custom-load-recursion t))
+ (let ((custom-load-recursion t)
+ (load-path
+ (cons
+ (expand-file-name
+ "quail" (file-name-directory (locate-library leim-list-file-name)))
+ load-path)))
(dolist (load (get symbol 'custom-loads))
(cond
((symbolp load)
diff --git a/admin/emake b/admin/emake
index 6e2f9e0e094..93958740dc2 100755
--- a/admin/emake
+++ b/admin/emake
@@ -19,13 +19,20 @@
# This script is meant to be used as ./admin/emake, and will compile
# the Emacs tree with virtually all of the informational messages
-# removed, and with errors/warnings highlighted in red. It'll give a
-# quick overview to confirm that nothing has broken, for instance
+# removed, and with errors/warnings highlighted in red. It will also
+# run the test files belonging to files that have changed. It'll give
+# a quick overview to confirm that nothing has broken, for instance
# after doing a "git pull". It's not meant to be used during actual
# development, because it removes so much information that commands
# like `next-error' won't be able to jump to the source code where
# errors are.
+# It has a few options:
+# with --no-color errors/warnings are not highlighted
+# with --no-check test files are not run
+# with --no-fast the FAST=true make variable is not set (see Makefile.in)
+# with --quieter only errors/warnings remain visible
+
cores=1
# Determine the number of cores.
@@ -96,6 +103,7 @@ GEN.*loaddefs|\
^.Read INSTALL.REPO for more|\
^Your system has the required tools.|\
^Building aclocal.m4|\
+^Building 'aclocal.m4'|\
^ Running 'autoreconf|\
^You can now run './configure'|\
^./configure|\
@@ -129,15 +137,21 @@ The GNU allocators don't work|\
" | \
while read
do
- C=""
- (($NOCOLOR == 0)) && [[ "X${REPLY:0:1}" != "X " ]] && C="\033[1;31m"
- (($NOCOLOR == 0)) && [[ "X${REPLY:0:3}" == "X " ]] && C="\033[1;31m"
- if (($QUIETER == 0))
- then
- [[ "X$C" == "X" ]] && printf "%s\n" "$REPLY" || printf "$C%s\033[0m\n" "$REPLY"
- else
- [[ "X$C" == "X" ]] && printf "%-80s\r" "$REPLY" || printf "$C%-80s\033[0m\n" "$REPLY"
- fi
+ C=""
+ E=0
+ [ ! -v L ] && L=80
+ [[ "X${REPLY:0:1}" != "X " ]] && E=1
+ [[ "X${REPLY:0:3}" == "X " ]] && E=1
+ (($NOCOLOR == 0)) && (($E == 1)) && C="\033[1;31m"
+ (($NOCOLOR == 0)) && (($E == 1)) && C="\033[1;31m"
+ if (($QUIETER == 0))
+ then
+ (($E == 0)) && printf "%s\n" "$REPLY" || printf "${C}%s\033[0m\n" "$REPLY"
+ else
+ (($E == 0)) && printf "%-${L}s\r" "$REPLY" || printf "${C}%-${L}s\033[0m\n" "$REPLY"
+ fi
+ L=${#REPLY}
+ (($L < 80)) && L=80
done
# If make failed, exit now with its error code.
@@ -149,4 +163,13 @@ done
# changed since last time.
make -j$cores check-maybe 2>&1 | \
sed -n '/contained unexpected results/,$p' | \
- grep -E --line-buffered -v "^make"
+ grep -E --line-buffered -v "^make" | \
+while read
+do
+ if (($NOCOLOR == 0))
+ then
+ printf "\033[1;31m%s\033[0m\n" "$REPLY"
+ else
+ printf "%s\n" "$REPLY"
+ fi
+done
diff --git a/admin/find-gc.el b/admin/find-gc.el
index 3f7336510e5..7c5672f4a46 100644
--- a/admin/find-gc.el
+++ b/admin/find-gc.el
@@ -100,7 +100,7 @@ Also store it in `find-gc-unsafe-list'."
-(defun trace-call-tree (&optional ignored)
+(defun trace-call-tree (&optional _ignored)
(message "Setting up directories...")
(setq find-gc-subrs-called nil)
(let ((case-fold-search nil)
diff --git a/admin/git-bisect-start b/admin/git-bisect-start
index 3951f291598..f9933b3ae4d 100755
--- a/admin/git-bisect-start
+++ b/admin/git-bisect-start
@@ -2,7 +2,9 @@
### Start a git bisection, ensuring that commits in branches that are
### the result of merging external trees into the Emacs repository, as
-### well as certain commits on which Emacs fails to build, are skipped.
+### well as certain commits on which Emacs fails to build (with the
+### default options, on a GNU/Linux computer and with GCC; see below),
+### are skipped.
## Copyright (C) 2022-2024 Free Software Foundation, Inc.
@@ -82,7 +84,7 @@ done
# SKIP-BRANCH 58cc931e92ece70c3e64131ee12a799d65409100
## The list below is the exhaustive list of all commits between Dec 1
-## 2016 and Aug 10 2023 on which building Emacs with the default
+## 2016 and Jan 13 2024 on which building Emacs with the default
## options, on a GNU/Linux computer and with GCC, fails. It is
## possible (though unlikely) that building Emacs with non-default
## options, with other compilers, or on other platforms, would succeed
@@ -1776,3 +1778,19 @@ $REAL_GIT bisect skip $(cat $0 | grep '^# SKIP-SINGLE ' | sed 's/^# SKIP-SINGLE
# SKIP-SINGLE 2752573dfb76873dbe783e89a1fbf01d157c54e3
# SKIP-SINGLE 62e990db7a2fad16756e019b331c28ad5a5a89fe
# SKIP-SINGLE 6253e7e74249c7cdfa86723f0b91a1d207cb143e
+# SKIP-SINGLE 1f7113e68988fa0bcbdeca5ae364cba8d6db3637
+# SKIP-SINGLE 6e44d6e18438ea2665ae6252a6ec090963dd7e42
+# SKIP-SINGLE 168cc0aff0bfbc1d67a7e8a72b88a1bf10ad019e
+# SKIP-SINGLE efb276fef1f580eafa8458fc262a4b35eb3abd5e
+# SKIP-SINGLE cc0d7d7a3867e4554f89262e4641c9845ee0d647
+# SKIP-SINGLE 012f9c28053d06b6d527d77530605aedbd55d5b4
+# SKIP-SINGLE e61a03984335b4ffb164280b2df80668b2a92c23
+# SKIP-SINGLE f7fd21b06865d20a16c11e20776e843db24d4b14
+# SKIP-SINGLE 35fbf6f15830f576fd1909f4a8d30e7ba1d777bd
+# SKIP-SINGLE 0e44ab5f061c81874dd8298a0f3318f14ef95a24
+# SKIP-SINGLE 4675aff76828b0747d1ac900d65d4a92a457ebf5
+# SKIP-SINGLE bf4d4ab4ddecffbee6d740f9c271dcca514d6a3d
+# SKIP-SINGLE 2a8e6c8c84ed33674e525625644d5ce84ee8c59a
+# SKIP-SINGLE fa5f06c1251ff717d661f05fcd240b4792054aae
+# SKIP-SINGLE d3cefd3e98354929d96c9396e5920e8a123784dc
+# SKIP-SINGLE 486094126ba77e45c50acb87f5ad3e4147608446
diff --git a/admin/gitmerge.el b/admin/gitmerge.el
index 63b11c68007..32d5c3c1bea 100644
--- a/admin/gitmerge.el
+++ b/admin/gitmerge.el
@@ -111,10 +111,10 @@ If nil, the function `gitmerge-default-branch' guesses.")
(defvar gitmerge-mode-font-lock-keywords
`((,gitmerge-log-regexp
- (1 font-lock-warning-face)
- (2 font-lock-constant-face)
- (3 font-lock-builtin-face)
- (4 font-lock-comment-face))))
+ (1 'font-lock-warning-face)
+ (2 'font-lock-constant-face)
+ (3 'font-lock-builtin-face)
+ (4 'font-lock-comment-face))))
(defvar gitmerge--commits nil)
(defvar gitmerge--from nil)
@@ -293,7 +293,7 @@ should not be skipped."
"Try to resolve conflicts in FILE with smerge.
Returns non-nil if conflicts remain."
(unless (file-exists-p file) (error "Gitmerge-resolve: Can't find %s" file))
- (with-demoted-errors
+ (with-demoted-errors "Error: %S"
(let ((exists (find-buffer-visiting file)))
(with-current-buffer (let ((enable-local-variables :safe)
(enable-local-eval nil))
diff --git a/admin/merge-gnulib b/admin/merge-gnulib
index fabc83c9d02..41531d573b0 100755
--- a/admin/merge-gnulib
+++ b/admin/merge-gnulib
@@ -23,40 +23,42 @@
# written by Paul Eggert
-GNULIB_URL=git://git.savannah.gnu.org/gnulib.git
+GNULIB_URL=https://git.savannah.gnu.org/git/gnulib.git
GNULIB_MODULES='
- alloca-opt binary-io byteswap c-ctype c-strcase
+ alignasof alloca-opt binary-io boot-time byteswap c-ctype c-strcase
canonicalize-lgpl
careadlinkat close-stream copy-file-range
count-leading-zeros count-one-bits count-trailing-zeros
crypto/md5 crypto/md5-buffer
crypto/sha1-buffer crypto/sha256-buffer crypto/sha512-buffer
d-type diffseq double-slash-root dtoastr dtotimespec dup2
- environ execinfo explicit_bzero faccessat
+ environ execinfo faccessat
fchmodat fcntl fcntl-h fdopendir file-has-acl
filemode filename filevercmp flexmember fpieee
free-posix fstatat fsusage fsync futimens
- getloadavg getopt-gnu getrandom gettime gettimeofday gitlog-to-changelog
+ getline getloadavg getopt-gnu getrandom gettime gettimeofday gitlog-to-changelog
ieee754-h ignore-value intprops largefile libgmp lstat
- manywarnings memmem-simple mempcpy memrchr minmax mkostemp mktime
+ manywarnings memmem-simple mempcpy memrchr memset_explicit
+ minmax mkostemp mktime
nanosleep nproc nstrftime
pathmax pipe2 pselect pthread_sigmask
qcopy-acl readlink readlinkat regex
- sig2str sigdescr_np socklen stat-time std-gnu11 stdalign stdbool stddef stdio
- stpcpy strnlen strtoimax symlink sys_stat sys_time
- tempname time time_r time_rz timegm timer-time timespec-add timespec-sub
+ sig2str sigdescr_np socklen stat-time std-gnu11 stdbool stdckdint stddef stdio
+ stpcpy strnlen strnlen strtoimax symlink sys_stat sys_time
+ tempname time-h time_r time_rz timegm timer-time timespec-add timespec-sub
update-copyright unlocked-io utimensat
- vla warnings
+ vla warnings year2038
'
AVOIDED_MODULES='
- btowc chmod close crypto/af_alg dup fchdir fstat langinfo lock
+ access btowc chmod close crypto/af_alg dup fchdir fstat
+ iswblank iswctype iswdigit iswxdigit langinfo localename-unsafe-limited lock
mbrtowc mbsinit memchr mkdir msvc-inval msvc-nothrow nl_langinfo
openat-die opendir pthread-h raise
save-cwd select setenv sigprocmask stat stdarg
threadlib tzset unsetenv utime utime-h
- wchar wcrtomb wctype-h
+ wchar wcrtomb wctype wctype-h
'
GNULIB_TOOL_FLAGS='
@@ -105,14 +107,16 @@ test -x "$gnulib_srcdir"/gnulib-tool || {
# gnulib-tool has problems with a bare checkout (Bug#32452#65).
test -f configure || ./autogen.sh || exit
-# Old caches can confuse autoconf when some Gnulib-related changes take effect.
-rm -fr autom4te.cache || exit
-
avoided_flags=
for module in $AVOIDED_MODULES; do
avoided_flags="$avoided_flags --avoid=$module"
done
+# Clean the lib directory as well.
+if [ -e "$src"/lib/Makefile ]; then
+ make -C "$src"/lib maintainer-clean
+fi
+
"$gnulib_srcdir"/gnulib-tool --dir="$src" $GNULIB_TOOL_FLAGS \
$avoided_flags $GNULIB_MODULES &&
rm -- "$src"lib/gl_openssl.h \
@@ -120,6 +124,7 @@ rm -- "$src"lib/gl_openssl.h \
"$src"m4/fcntl-o.m4 \
"$src"m4/gl-openssl.m4 \
"$src"m4/gnulib-cache.m4 "$src"m4/gnulib-tool.m4 \
+ "$src"m4/locale-fr.m4 \
"$src"m4/manywarnings-c++.m4 \
"$src"m4/warn-on-use.m4 "$src"m4/wint_t.m4 &&
cp -- "$gnulib_srcdir"/build-aux/texinfo.tex "$src"doc/misc &&
@@ -131,5 +136,7 @@ cp -- "$gnulib_srcdir"/build-aux/config.guess \
cp -- "$gnulib_srcdir"/lib/af_alg.h \
"$gnulib_srcdir"/lib/save-cwd.h \
"$src"lib &&
+cp -- "$gnulib_srcdir"/m4/codeset.m4 \
+ "$src"m4 &&
{ test -z "$src" || cd "$src"; } &&
./autogen.sh
diff --git a/admin/notes/copyright b/admin/notes/copyright
index fe94b5c68d9..55924157e9a 100644
--- a/admin/notes/copyright
+++ b/admin/notes/copyright
@@ -381,7 +381,7 @@ conclude it was written by me."
lisp/term/README
- had no copyright notice till Feb 2007. ChangeLog.3 suggests it was
- written by Eric Raymond. When asked by rms on 14 Feb 2007 he said:
+ written by Eric S. Raymond. When asked by rms on 14 Feb 2007 he said:
I don't remember writing it, but it reads like my prose and I believe
I wrote the feature(s) it's describing. So I would have been the
diff --git a/admin/notes/elpa b/admin/notes/elpa
index 1e9e7a9f52b..afcda71d1dd 100644
--- a/admin/notes/elpa
+++ b/admin/notes/elpa
@@ -3,7 +3,7 @@ NOTES ON THE EMACS PACKAGE ARCHIVE
The GNU Emacs package archive, at elpa.gnu.org, is managed using a Git
repository named "elpa", hosted on Savannah. To check it out:
- git clone git://git.sv.gnu.org/emacs/elpa
+ git clone https://git.savannah.gnu.org/git/emacs/elpa
cd elpa
make setup
diff --git a/admin/notes/emba b/admin/notes/emba
index 36eb98a1721..2e61ec49ae5 100644
--- a/admin/notes/emba
+++ b/admin/notes/emba
@@ -83,6 +83,46 @@ Lisp packages, Makefiles, scripts, and other software could determine
whether they run on emba by checking for the environment variable
EMACS_EMBA_CI.
+* Running Emba tests locally
+
+As usual in GitLab, the tests run in containers, which could be
+applied also locally. Unfortunately, the Emba container registry,
+emba.gnu.org:5050, is not accessible publicly. Instead, the container
+images must be build locally. Change the current directory to a
+recent Emacs branch, and apply the command
+
+ docker build --target emacs-inotify --tag emacs-inotify \
+ -f test/infra/Dockerfile.emba .
+
+This creates the Debian-based image emacs-inotify, based on the
+instructions in the file Dockerfile.emba. This image is good for the
+majority of tests. However, there are also other image build
+instructions like emacs-filenotify-gio, emacs-eglot,
+emacs-tree-sitter, emacs-gnustep and emacs-native-comp-speed{0,1,2}.
+Use the appropriate one.
+
+The image contains a directory "/checkout", which is a copy of your
+local Emacs git repository. Emacs has been built in this directory
+via "make bootstrap". In order to use the image, start a container
+like
+
+ docker run --interactive --tty --env EMACS_EMBA_CI=1 --name emacs-inotify \
+ emacs-inotify /bin/bash -i
+
+In this container, your working directory is "/checkout". Now you can
+apply all commands known for Emacs, like
+
+ make -C test files-tests.log
+
+While this container runs, you can also access its filesystem from
+your local Emacs via Tramp. For example, in order to see the result
+of the above test run, open the log file in your local Emacs with
+
+ C-x C-f /docker:emacs-inotify:/checkout/test/lisp/files-tests.log
+
+Note: On local Red Hat-based systems, use "podman" instead of "docker"
+in the shell commands and Tramp file names.
+
This file is part of GNU Emacs.
diff --git a/admin/notes/git-workflow b/admin/notes/git-workflow
index 717fc550776..d33f49a1aca 100644
--- a/admin/notes/git-workflow
+++ b/admin/notes/git-workflow
@@ -16,14 +16,14 @@ Initial setup
Then we want to clone the repository. We normally want to have both
the current master and (if there is one) the active release branch
-(eg emacs-28).
+(eg emacs-29).
mkdir ~/emacs
cd ~/emacs
git clone <membername>@git.sv.gnu.org:/srv/git/emacs.git master
cd master
git config push.default current
-git worktree add ../emacs-28 emacs-28
+git worktree add ../emacs-29 emacs-29
You now have both branches conveniently accessible, and you can do
"git pull" in them once in a while to keep updated.
@@ -67,10 +67,10 @@ which will look like
commit 958b768a6534ae6e77a8547a56fc31b46b63710b
-cd ~/emacs/emacs-28
+cd ~/emacs/emacs-29
git cherry-pick -xe 958b768a6534ae6e77a8547a56fc31b46b63710b
-and optionally add "Backport:" to the commit string. Then
+and add "Backport:" to the commit string. Then
git push
@@ -109,7 +109,7 @@ up-to-date by doing a pull. Then start Emacs with
emacs -l admin/gitmerge.el -f gitmerge
You'll be asked for the branch to merge, which will default to
-(eg) 'origin/emacs-28', which you should accept. Merging a local tracking
+(eg) 'origin/emacs-29', which you should accept. Merging a local tracking
branch is discouraged, since it might not be up-to-date, or worse,
contain commits from you which are not yet pushed upstream.
diff --git a/admin/notes/java b/admin/notes/java
new file mode 100644
index 00000000000..e10f09f780f
--- /dev/null
+++ b/admin/notes/java
@@ -0,0 +1,1097 @@
+Installation instructions for Android
+Copyright (C) 2023-2024 Free Software Foundation, Inc.
+See the end of the file for license conditions.
+
+
+
+OVERVIEW OF JAVA
+
+Emacs developers do not know Java, and there is no reason they should
+have to. Thus, the code in this directory is confined to what is
+strictly necessary to support Emacs, and only uses a subset of Java
+written in a way that is easily understandable to C programmers.
+
+Java is required because the entire Android runtime is based around
+Java, and there is no way to write an Android program which runs
+without Java.
+
+This text exists to prime other Emacs developers, already familiar with
+C, on the basic architecture of the Android port, and to teach them
+how to read and write the Java code found in this directory.
+
+Java is an object oriented language with automatic memory management
+compiled down to bytecode, which is then subject to interpretation by
+a Java virtual machine.
+
+What that means, is that:
+
+struct emacs_window
+{
+ int some_fields;
+ int of_emacs_window;
+};
+
+static void
+do_something_with_emacs_window (struct emacs_window *a, int n)
+{
+ a->some_fields = a->of_emacs_window + n;
+}
+
+would be written:
+
+public class EmacsWindow
+{
+ public int someFields;
+ public int ofEmacsWindow;
+
+ public void
+ doSomething (int n)
+ {
+ someFields = ofEmacsWindow + n;
+ }
+}
+
+and instead of doing:
+
+do_something_with_emacs_window (my_window, 1);
+
+you say:
+
+myWindow.doSomething (1);
+
+In addition to functions associated with an object of a given class
+(such as EmacsWindow), Java also has two other kinds of functions.
+
+The first are so-called ``static'' functions (the static means
+something entirely different from what it does in C.)
+
+A static function, while still having to be defined within a class,
+can be called without any object. Instead of the object, you write
+the name of the Java class within which it is defined. For example,
+the following C code:
+
+int
+multiply_a_with_b_and_then_add_c (int a, int b, int c)
+{
+ return a * b + c;
+}
+
+would be:
+
+public class EmacsSomething
+{
+ public static int
+ multiplyAWithBAndThenAddC (int a, int b, int c)
+ {
+ return a * b + c;
+ }
+};
+
+Then, instead of calling:
+
+int foo;
+
+foo = multiply_a_with_b_then_add_c (1, 2, 3);
+
+you say:
+
+int foo;
+
+foo = EmacsSomething.multiplyAWithBAndThenAddC (1, 2, 3);
+
+In Java, ``static'' does not mean that the function is only used
+within its compilation unit! Instead, the ``private'' qualifier is
+used to mean more or less the same thing:
+
+static void
+this_procedure_is_only_used_within_this_file (void)
+{
+ do_something ();
+}
+
+becomes
+
+public class EmacsSomething
+{
+ private static void
+ thisProcedureIsOnlyUsedWithinThisClass ()
+ {
+
+ }
+}
+
+the other kind are called ``constructors''. They are functions that
+must be called to allocate memory to hold a class:
+
+public class EmacsFoo
+{
+ int bar;
+
+ public
+ EmacsFoo (int tokenA, int tokenB)
+ {
+ bar = tokenA + tokenB;
+ }
+}
+
+now, the following statement:
+
+EmacsFoo foo;
+
+foo = new EmacsFoo (1, 2);
+
+becomes more or less equivalent to the following C code:
+
+struct emacs_foo
+{
+ int bar;
+};
+
+struct emacs_foo *
+make_emacs_foo (int token_a, int token_b)
+{
+ struct emacs_foo *foo;
+
+ foo = xmalloc (sizeof *foo);
+ foo->bar = token_a + token_b;
+
+ return foo;
+}
+
+/* ... */
+
+struct emacs_foo *foo;
+
+foo = make_emacs_foo (1, 2);
+
+A class may have any number of constructors, or no constructors at
+all, in which case the compiler inserts an empty constructor.
+
+
+
+Sometimes, you will see Java code that looks like this:
+
+ allFiles = filesDirectory.listFiles (new FileFilter () {
+ @Override
+ public boolean
+ accept (File file)
+ {
+ return (!file.isDirectory ()
+ && file.getName ().endsWith (".pdmp"));
+ }
+ });
+
+This is Java's version of GCC's nested function extension. The major
+difference is that the nested function may still be called even after
+it goes out of scope, and always retains a reference to the class and
+local variables around where it was called.
+
+Being an object-oriented language, Java also allows defining that a
+class ``extends'' another class. The following C code:
+
+struct a
+{
+ long thirty_two;
+};
+
+struct b
+{
+ struct a a;
+ long long sixty_four;
+};
+
+extern void do_something (struct a *);
+
+void
+my_function (struct b *b)
+{
+ do_something (&b->a);
+}
+
+is roughly equivalent to the following Java code, split into two
+files:
+
+ A.java
+
+public class A
+{
+ int thirtyTwo;
+
+ public void
+ doSomething ()
+ {
+ etcEtcEtc ();
+ }
+};
+
+ B.java
+
+public class B extends A
+{
+ long sixty_four;
+
+ public static void
+ myFunction (B b)
+ {
+ b.doSomething ();
+ }
+}
+
+the Java runtime has transformed the call to ``b.doSomething'' to
+``((A) b).doSomething''.
+
+However, Java also allows overriding this behavior, by specifying the
+@Override keyword:
+
+public class B extends A
+{
+ long sixty_four;
+
+ @Override
+ public void
+ doSomething ()
+ {
+ Something.doSomethingTwo ();
+ super.doSomething ();
+ }
+}
+
+now, any call to ``doSomething'' on a ``B'' created using ``new B ()''
+will end up calling ``Something.doSomethingTwo'', before calling back
+to ``A.doSomething''. This override also applies in reverse; that is
+to say, even if you write:
+
+ ((A) b).doSomething ();
+
+B's version of doSomething will still be called, if ``b'' was created
+using ``new B ()''.
+
+This mechanism is used extensively throughout the Java language and
+Android windowing APIs.
+
+Elsewhere, you will encounter Java code that defines arrays:
+
+public class EmacsFrobinicator
+{
+ public static void
+ emacsFrobinicate (int something)
+ {
+ int[] primesFromSomething;
+
+ primesFromSomething = new int[numberOfPrimes];
+ /* ... */
+ }
+}
+
+Java arrays are similar to C arrays in that they can not grow. But
+they are very much unlike C arrays in that they are always references
+(as opposed to decaying into pointers in only some situations), and
+contain information about their length.
+
+If another function named ``frobinicate1'' takes an array as an
+argument, then it need not take the length of the array.
+
+Instead, it may simply iterate over the array like so:
+
+int i, k;
+
+for (i = 0; i < array.length; ++i)
+ {
+ k = array[i];
+
+ Whatever.doSomethingWithK (k);
+ }
+
+The syntax used to define arrays is also slightly different. As
+arrays are always references, there is no way for you to tell the
+runtime to allocate an array of size N in a structure (class.)
+
+Instead, if you need an array of that size, you must declare a field
+with the type of the array, and allocate the array inside the class's
+constructor, like so:
+
+public class EmacsArrayContainer
+{
+ public int[] myArray;
+
+ public
+ EmacsArrayContainer ()
+ {
+ myArray = new array[10];
+ }
+}
+
+while in C, you could just have written:
+
+struct emacs_array_container
+{
+ int my_array[10];
+};
+
+or, possibly even better,
+
+typedef int emacs_array_container[10];
+
+Alas, Java has no equivalent of `typedef'.
+
+Like in C, Java string literals are delimited by double quotes.
+Unlike C, however, strings are not NULL-terminated arrays of
+characters, but a distinct type named ``String''. They store their
+own length, characters in Java's 16-bit ``char'' type, and are capable
+of holding NULL bytes.
+
+Instead of writing:
+
+wchar_t character;
+extern char *s;
+size_t s;
+
+ for (/* determine n, s in a loop. */)
+ s += mbstowc (&character, s, n);
+
+or:
+
+const char *byte;
+
+for (byte = my_string; *byte; ++byte)
+ /* do something with *byte. */;
+
+or perhaps even:
+
+size_t length, i;
+char foo;
+
+length = strlen (my_string);
+
+for (i = 0; i < length; ++i)
+ foo = my_string[i];
+
+you write:
+
+char foo;
+int i;
+
+for (i = 0; i < myString.length (); ++i)
+ foo = myString.charAt (0);
+
+Java also has stricter rules on what can be used as a truth value in a
+conditional. While in C, any non-zero value is true, Java requires
+that every truth value be of the boolean type ``boolean''.
+
+What this means is that instead of simply writing:
+
+ if (foo || bar)
+
+where foo can either be 1 or 0, and bar can either be NULL or a
+pointer to something, you must explicitly write:
+
+ if (foo != 0 || bar != null)
+
+in Java.
+
+JAVA NATIVE INTERFACE
+
+Java also provides an interface for C code to interface with Java.
+
+C functions exported from a shared library become static Java
+functions within a class, like so:
+
+public class EmacsNative
+{
+ /* Obtain the fingerprint of this build of Emacs. The fingerprint
+ can be used to determine the dump file name. */
+ public static native String getFingerprint ();
+
+ /* Set certain parameters before initializing Emacs.
+
+ assetManager must be the asset manager associated with the
+ context that is loading Emacs. It is saved and remains for the
+ remainder the lifetime of the Emacs process.
+
+ filesDir must be the package's data storage location for the
+ current Android user.
+
+ libDir must be the package's data storage location for native
+ libraries. It is used as PATH.
+
+ cacheDir must be the package's cache directory. It is used as
+ the `temporary-file-directory'.
+
+ pixelDensityX and pixelDensityY are the DPI values that will be
+ used by Emacs.
+
+ classPath must be the classpath of this app_process process, or
+ NULL.
+
+ emacsService must be the EmacsService singleton, or NULL. */
+ public static native void setEmacsParams (AssetManager assetManager,
+ String filesDir,
+ String libDir,
+ String cacheDir,
+ float pixelDensityX,
+ float pixelDensityY,
+ String classPath,
+ EmacsService emacsService);
+}
+
+Where the corresponding C functions are located in android.c, and
+loaded by the special invocation:
+
+ static
+ {
+ System.loadLibrary ("emacs");
+ };
+
+where ``static'' defines a section of code which will be run upon the
+object (containing class) being loaded. This is like:
+
+ __attribute__ ((constructor))
+
+on systems where shared object constructors are supported.
+
+See http://docs.oracle.com/en/java/javase/19/docs/specs/jni/intro.html
+for more details.
+
+
+
+OVERVIEW OF ANDROID
+
+When the Android system starts an application, it does not actually
+call the application's ``main'' function. It may not even start the
+application's process if one is already running.
+
+Instead, Android is organized around components. When the user opens
+the ``Emacs'' icon, the Android system looks up and starts the
+component associated with the ``Emacs'' icon. In this case, the
+component is called an activity, and is declared in
+the AndroidManifest.xml in this directory:
+
+ <activity android:name="org.gnu.emacs.EmacsActivity"
+ android:launchMode="singleTop"
+ android:windowSoftInputMode="adjustResize"
+ android:exported="true"
+ android:configChanges="orientation|screenSize|screenLayout|keyboardHidden">
+ <intent-filter>
+ <action android:name="android.intent.action.MAIN" />
+ <category android:name="android.intent.category.DEFAULT" />
+ <category android:name="android.intent.category.LAUNCHER" />
+ </intent-filter>
+ </activity>
+
+This tells Android to start the activity defined in ``EmacsActivity''
+(defined in org/gnu/emacs/EmacsActivity.java), a class extending the
+Android class ``Activity''.
+
+To do so, the Android system creates an instance of ``EmacsActivity''
+and the window system window associated with it, and eventually calls:
+
+ Activity activity;
+
+ activity.onCreate (...);
+
+But which ``onCreate'' is really called?
+It is actually the ``onCreate'' defined in EmacsActivity.java, as
+it overrides the ``onCreate'' defined in Android's own Activity class:
+
+ @Override
+ public void
+ onCreate (Bundle savedInstanceState)
+ {
+ FrameLayout.LayoutParams params;
+ Intent intent;
+
+Then, this is what happens step-by-step within the ``onCreate''
+function:
+
+ /* See if Emacs should be started with -Q. */
+ intent = getIntent ();
+ EmacsService.needDashQ
+ = intent.getBooleanExtra ("org.gnu.emacs.START_DASH_Q",
+ false);
+
+Here, Emacs obtains the intent (a request to start a component) which
+was used to start Emacs, and sets a special flag if it contains a
+request for Emacs to start with the ``-Q'' command-line argument.
+
+ /* Set the theme to one without a title bar. */
+
+ if (Build.VERSION.SDK_INT >= Build.VERSION_CODES.ICE_CREAM_SANDWICH)
+ setTheme (android.R.style.Theme_DeviceDefault_NoActionBar);
+ else
+ setTheme (android.R.style.Theme_NoTitleBar);
+
+Next, Emacs sets an appropriate theme for the activity's associated
+window decorations.
+
+ params = new FrameLayout.LayoutParams (LayoutParams.MATCH_PARENT,
+ LayoutParams.MATCH_PARENT);
+
+ /* Make the frame layout. */
+ layout = new FrameLayout (this);
+ layout.setLayoutParams (params);
+
+ /* Set it as the content view. */
+ setContentView (layout);
+
+Then, Emacs creates a ``FrameLayout'', a widget that holds a single
+other widget, and makes it the activity's ``content view''.
+
+The activity itself is a ``FrameLayout'', so the ``layout parameters''
+here apply to the FrameLayout itself, and not its children.
+
+ /* Maybe start the Emacs service if necessary. */
+ EmacsService.startEmacsService (this);
+
+And after that, Emacs calls the static function ``startEmacsService'',
+defined in the class ``EmacsService''. This starts the Emacs service
+component if necessary.
+
+ /* Add this activity to the list of available activities. */
+ EmacsWindowAttachmentManager.MANAGER.registerWindowConsumer (this);
+
+ super.onCreate (savedInstanceState);
+
+Finally, Emacs registers that this activity is now ready to receive
+top-level frames (windows) created from Lisp.
+
+Activities come and go, but Emacs has to stay running in the mean
+time. Thus, Emacs also defines a ``service'', which is a long-running
+component that the Android system allows to run in the background.
+
+Let us go back and review the definition of ``startEmacsService'':
+
+ public static void
+ startEmacsService (Context context)
+ {
+ if (EmacsService.SERVICE == null)
+ {
+ if (Build.VERSION.SDK_INT < Build.VERSION_CODES.O)
+ /* Start the Emacs service now. */
+ context.startService (new Intent (context,
+ EmacsService.class));
+ else
+ /* Display the permanent notification and start Emacs as a
+ foreground service. */
+ context.startForegroundService (new Intent (context,
+ EmacsService.class));
+ }
+ }
+
+If ``EmacsService.SERVICE'' does not yet exist, what this does is to
+tell the ``context'' (the equivalent of an Xlib Display *) to start a
+service defined by the class ``EmacsService''. Eventually, this
+results in ``EmacsService.onCreate'' being called:
+
+ @Override
+ public void
+ onCreate ()
+ {
+ AssetManager manager;
+ Context app_context;
+ String filesDir, libDir, cacheDir, classPath;
+ double pixelDensityX;
+ double pixelDensityY;
+
+Here is what this function does, step-by-step:
+
+ SERVICE = this;
+
+First, it sets the special static variable ``SERVICE'' to ``this'',
+which is a pointer to the ``EmacsService' object that was created.
+
+ handler = new Handler (Looper.getMainLooper ());
+
+Next, it creates a ``Handler'' object for the ``main looper''.
+This is a helper structure which allows executing code on the Android
+user interface thread.
+
+ manager = getAssets ();
+ app_context = getApplicationContext ();
+ metrics = getResources ().getDisplayMetrics ();
+ pixelDensityX = metrics.xdpi;
+ pixelDensityY = metrics.ydpi;
+
+Finally, it obtains:
+
+ - the asset manager, which is used to retrieve assets packaged
+ into the Emacs application package.
+
+ - the application context, used to obtain application specific
+ information.
+
+ - the display metrics, and from them, the X and Y densities in dots
+ per inch.
+
+Then, inside a ``try'' block:
+
+ try
+ {
+ /* Configure Emacs with the asset manager and other necessary
+ parameters. */
+ filesDir = app_context.getFilesDir ().getCanonicalPath ();
+ libDir = getLibraryDirectory ();
+ cacheDir = app_context.getCacheDir ().getCanonicalPath ();
+
+It obtains the names of the Emacs home, shared library, and temporary
+file directories.
+
+ /* Now provide this application's apk file, so a recursive
+ invocation of app_process (through android-emacs) can
+ find EmacsNoninteractive. */
+ classPath = getApkFile ();
+
+The name of the Emacs application package.
+
+ Log.d (TAG, "Initializing Emacs, where filesDir = " + filesDir
+ + ", libDir = " + libDir + ", and classPath = " + classPath);
+
+Prints a debug message to the Android system log with this
+information.
+
+ EmacsNative.setEmacsParams (manager, filesDir, libDir,
+ cacheDir, (float) pixelDensityX,
+ (float) pixelDensityY,
+ classPath, this);
+
+And calls the native function ``setEmacsParams'' (defined in
+android.c) to configure Emacs with this information.
+
+ /* Start the thread that runs Emacs. */
+ thread = new EmacsThread (this, needDashQ);
+ thread.start ();
+
+Then, it allocates an ``EmacsThread'' object, and starts that thread.
+Inside that thread is where Emacs's C code runs.
+
+ }
+ catch (IOException exception)
+ {
+ EmacsNative.emacsAbort ();
+ return;
+
+And here is the purpose of the ``try'' block. Functions related to
+file names in Java will signal errors of various types upon failure.
+
+This ``catch'' block means that the Java virtual machine will abort
+execution of the contents of the ``try'' block as soon as an error of
+type ``IOException'' is encountered, and begin executing the contents
+of the ``catch'' block.
+
+Any failure of that type here is a crash, and
+``EmacsNative.emacsAbort'' is called to quickly abort the process to
+get a useful backtrace.
+ }
+ }
+
+Now, let us look at the definition of the class ``EmacsThread'', found
+in org/gnu/emacs/EmacsThread.java:
+
+public class EmacsThread extends Thread
+{
+ /* Whether or not Emacs should be started -Q. */
+ private boolean startDashQ;
+
+ public
+ EmacsThread (EmacsService service, boolean startDashQ)
+ {
+ super ("Emacs main thread");
+ this.startDashQ = startDashQ;
+ }
+
+ @Override
+ public void
+ run ()
+ {
+ String args[];
+
+ if (!startDashQ)
+ args = new String[] { "libandroid-emacs.so", };
+ else
+ args = new String[] { "libandroid-emacs.so", "-Q", };
+
+ /* Run the native code now. */
+ EmacsNative.initEmacs (args, EmacsApplication.dumpFileName);
+ }
+};
+
+The class itself defines a single field, ``startDashQ'', a constructor
+with an unused argument of the type ``EmacsService'' (which is useful
+while debugging) and a flag ``startDashQ'', and a single function
+``run'', overriding the same function in the class ``Thread''.
+
+When ``thread.start'' is called, the Java virtual machine creates a
+new thread, and then calls the function ``run'' within that thread.
+
+This function then computes a suitable argument vector, and calls
+``EmacsNative.initEmacs'' (defined in android.c), which then calls a
+modified version of the regular Emacs ``main'' function.
+
+At that point, Emacs initialization proceeds as usual:
+Vinitial_window_system is set, loadup.el calls `normal-top-level',
+which calls `command-line', and finally
+`window-system-initialization', which initializes the `android'
+terminal interface as usual.
+
+What happens here is the same as on other platforms. Now, here is
+what happens when the initial frame is created: Fx_create_frame calls
+`android_create_frame_window' to create a top level window:
+
+static void
+android_create_frame_window (struct frame *f)
+{
+ struct android_set_window_attributes attributes;
+ enum android_window_value_mask attribute_mask;
+
+ attributes.background_pixel = FRAME_BACKGROUND_PIXEL (f);
+ attribute_mask = ANDROID_CW_BACK_PIXEL;
+
+ block_input ();
+ FRAME_ANDROID_WINDOW (f)
+ = android_create_window (FRAME_DISPLAY_INFO (f)->root_window,
+ f->left_pos,
+ f->top_pos,
+ FRAME_PIXEL_WIDTH (f),
+ FRAME_PIXEL_HEIGHT (f),
+ attribute_mask, &attributes);
+ unblock_input ();
+}
+
+This calls the function `android_create_window' with some arguments
+whose meanings are identical to the arguments to `XCreateWindow'.
+
+Here is the definition of `android_create_window', in android.c:
+
+android_window
+android_create_window (android_window parent, int x, int y,
+ int width, int height,
+ enum android_window_value_mask value_mask,
+ struct android_set_window_attributes *attrs)
+{
+ static jclass class;
+ static jmethodID constructor;
+ jobject object, parent_object, old;
+ android_window window;
+ android_handle prev_max_handle;
+ bool override_redirect;
+
+What does it do? First, some context:
+
+At any time, there can be at most 65535 Java objects referred to by
+the rest of Emacs through the Java native interface. Each such object
+is assigned a ``handle'' (similar to an XID on X) and given a unique
+type. The function `android_resolve_handle' returns the JNI `jobject'
+associated with a given handle.
+
+ parent_object = android_resolve_handle (parent, ANDROID_HANDLE_WINDOW);
+
+Here, it is being used to look up the `jobject' associated with the
+`parent' handle.
+
+ prev_max_handle = max_handle;
+ window = android_alloc_id ();
+
+Next, `max_handle' is saved, and a new handle is allocated for
+`window'.
+
+ if (!window)
+ error ("Out of window handles!");
+
+An error is signaled if Emacs runs out of available handles.
+
+ if (!class)
+ {
+ class = (*android_java_env)->FindClass (android_java_env,
+ "org/gnu/emacs/EmacsWindow");
+ assert (class != NULL);
+
+Then, if this initialization has not yet been completed, Emacs
+proceeds to find the Java class named ``EmacsWindow''.
+
+ constructor
+ = (*android_java_env)->GetMethodID (android_java_env, class, "<init>",
+ "(SLorg/gnu/emacs/EmacsWindow;"
+ "IIIIZ)V");
+ assert (constructor != NULL);
+
+And it tries to look up the constructor, which should take seven
+arguments:
+
+ S - a short. (the handle ID)
+ Lorg/gnu/Emacs/EmacsWindow; - an instance of the EmacsWindow
+ class. (the parent)
+ IIII - four ints. (the window geometry.)
+ Z - a boolean. (whether or not the
+ window is override-redirect; see
+ XChangeWindowAttributes.)
+
+ old = class;
+ class = (*android_java_env)->NewGlobalRef (android_java_env, class);
+ (*android_java_env)->ExceptionClear (android_java_env);
+ ANDROID_DELETE_LOCAL_REF (old);
+
+Next, it saves a global reference to the class and deletes the local
+reference. Global references will never be deallocated by the Java
+virtual machine as long as they still exist.
+
+ if (!class)
+ memory_full (0);
+ }
+
+ /* N.B. that ANDROID_CW_OVERRIDE_REDIRECT can only be set at window
+ creation time. */
+ override_redirect = ((value_mask
+ & ANDROID_CW_OVERRIDE_REDIRECT)
+ && attrs->override_redirect);
+
+ object = (*android_java_env)->NewObject (android_java_env, class,
+ constructor, (jshort) window,
+ parent_object, (jint) x, (jint) y,
+ (jint) width, (jint) height,
+ (jboolean) override_redirect);
+
+Then, it creates an instance of the ``EmacsWindow'' class with the
+appropriate arguments and previously determined constructor.
+
+ if (!object)
+ {
+ (*android_java_env)->ExceptionClear (android_java_env);
+
+ max_handle = prev_max_handle;
+ memory_full (0);
+
+If creating the object fails, Emacs clears the ``pending exception''
+and signals that it is out of memory.
+ }
+
+ android_handles[window].type = ANDROID_HANDLE_WINDOW;
+ android_handles[window].handle
+ = (*android_java_env)->NewGlobalRef (android_java_env,
+ object);
+ (*android_java_env)->ExceptionClear (android_java_env);
+ ANDROID_DELETE_LOCAL_REF (object);
+
+Otherwise, it associates a new global reference to the object with the
+handle, and deletes the local reference returned from the JNI
+NewObject function.
+
+ if (!android_handles[window].handle)
+ memory_full (0);
+
+If allocating the global reference fails, Emacs signals that it is out
+of memory.
+
+ android_change_window_attributes (window, value_mask, attrs);
+ return window;
+
+Otherwise, it applies the specified window attributes and returns the
+handle of the new window.
+}
+
+
+
+DRAWABLES, CURSORS AND HANDLES
+
+Each widget created by Emacs corresponds to a single ``window'', which
+has its own backing store. This arrangement is quite similar to X.
+
+C code does not directly refer to the EmacsView widgets that implement
+the UI logic behind windows. Instead, its handles refer to
+EmacsWindow structures, which contain the state necessary to interact
+with the widgets in an orderly and synchronized manner.
+
+Like X, both pixmaps and windows are drawable resources, and the same
+graphics operations can be applied to both. Thus, a separate
+EmacsPixmap structure is used to wrap around Android Bitmap resources,
+and the Java-level graphics operation functions are capable of
+operating on them both.
+
+Finally, graphics contexts are maintained on both the C and Java
+levels; the C state recorded in `struct android_gc' is kept in sync
+with the Java state in the GContext handle's corresponding EmacsGC
+structure, and cursors are used through handles that refer to
+EmacsCursor structures that hold system PointerIcons.
+
+In all cases, the interfaces provided are identical to X.
+
+
+
+EVENT LOOP
+
+In a typical Android application, the event loop is managed by the
+operating system, and callbacks (implemented through overriding
+separate functions in widgets) are run by the event loop wherever
+necessary. The thread which runs the event loop is also the only
+thread capable of creating and manipulating widgets and activities,
+and is referred to as the ``UI thread''.
+
+These callbacks are used by Emacs to write representations of X-like
+events to a separate event queue, which are then read from Emacs's own
+event loop running in a separate thread. This is accomplished through
+replacing `select' by a function which waits for the event queue to be
+occupied, in addition to any file descriptors that `select' would
+normally wait for.
+
+Conversely, Emacs's event loop sometimes needs to send events to the
+UI thread. These events are implemented as tiny fragments of code,
+which are run as they are received by the main thread.
+
+A typical example is `displayToast', which is implemented in
+EmacsService.java:
+
+ public void
+ displayToast (final String string)
+ {
+ runOnUiThread (new Runnable () {
+ @Override
+ public void
+ run ()
+ {
+ Toast toast;
+
+ toast = Toast.makeText (getApplicationContext (),
+ string, Toast.LENGTH_SHORT);
+ toast.show ();
+ }
+ });
+ }
+
+Here, the variable `string' is used by a nested function. This nested
+function contains a copy of that variable, and is run on the main
+thread using the function `runOnUiThread', in order to display a short
+status message on the display.
+
+When Emacs needs to wait for the nested function to finish, it uses a
+mechanism implemented in `syncRunnable'. This mechanism first calls a
+deadlock avoidance mechanism, then runs a nested function on the UI
+thread, which is expected to signal itself as a condition variable
+upon completion. It is typically used to allocate resources that can
+only be allocated from the UI thread, or to obtain non-thread-safe
+information. The following function is an example; it returns a new
+EmacsView widget corresponding to the provided window:
+
+ public EmacsView
+ getEmacsView (final EmacsWindow window, final int visibility,
+ final boolean isFocusedByDefault)
+ {
+ Runnable runnable;
+ final EmacsHolder<EmacsView> view;
+
+ view = new EmacsHolder<EmacsView> ();
+
+ runnable = new Runnable () {
+ public void
+ run ()
+ {
+ synchronized (this)
+ {
+ view.thing = new EmacsView (window);
+ view.thing.setVisibility (visibility);
+
+ /* The following function is only present on Android 26
+ or later. */
+ if (Build.VERSION.SDK_INT >= Build.VERSION_CODES.O)
+ view.thing.setFocusedByDefault (isFocusedByDefault);
+
+ notify ();
+ }
+ }
+ };
+
+ syncRunnable (runnable);
+ return view.thing;
+ }
+
+As no value can be directly returned from the nested function, a
+separate container object is used to hold the result after the
+function finishes execution. Note the type name inside the angle
+brackets: this type is substituted into the class definition as it is
+used; a definition such as:
+
+public class Foo<T>
+{
+ T bar;
+};
+
+can not be used alone:
+
+ Foo holder; /* Error! */
+
+but must have a type specified:
+
+ Foo<Object> holder;
+
+in which case the effective definition is:
+
+public class Foo
+{
+ Object bar;
+};
+
+
+
+COMPATIBILITY
+
+There are three variables set within every Android application that
+extert influence over the set of Android systems it supports, and the
+measures it must take to function faithfully on each of those systems:
+the minimum API level, compile SDK version and target API level.
+
+The minimum API level is the earliest version of Android that is
+permitted to install and run the application. For Emacs, this is
+established by detecting the __ANDROID_API__ preprocessor macro
+defined within the Android C compiler.
+
+Before Java code executes any Android API calls that are not present
+within Android 2.2 (API level 8), the lowest API level supported by
+Emacs as a whole, it must first check the value of the:
+
+ Build.VERSION.SDK_INT
+
+variable, which is always set to the API level of the system Emacs is
+presently installed within. For example, before calling
+`dispatchKeyEventFromInputMethod', a function absent from Android 6.0
+(API level 23) or earlier, check:
+
+ if (Build.VERSION.SDK_INT >= Build.VERSION_CODES.N)
+ view.imManager.dispatchKeyEventFromInputMethod (view, key);
+ else
+ {
+
+where `N' is a constant defined to 24.
+
+The compile SDK version is the version of the Android SDK headers Java
+code is compiled against. Because Java does not provide conditional
+compilation constructs, Emacs can't be compiled with any version of
+these headers other than the version mentioned in `java/INSTALL', but
+the headers used do not affect the set of supported systems provided
+that the version checks illustrated above are performed where
+necessary.
+
+The target API level is a number within java/AndroidManifest.xml.in
+the system refers to when deciding whether to enable
+backwards-incompatible modifications to the behavior of various system
+APIs. For any given Android version, backwards incompatible changes
+in that version will be disabled for applications whose target API
+levels don't exceed its own.
+
+The target API should nevertheless be updated to match every major
+Android update, as Google has stated their intentions to prohibit
+users from installing applications targeting ``out-of-date'' versions
+of Android, though this threat has hitherto been made good on.
+
+
+
+This file is part of GNU Emacs.
+
+GNU Emacs is free software: you can redistribute it and/or modify
+it under the terms of the GNU General Public License as published by
+the Free Software Foundation, either version 3 of the License, or
+(at your option) any later version.
+
+GNU Emacs is distributed in the hope that it will be useful,
+but WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+GNU General Public License for more details.
+
+You should have received a copy of the GNU General Public License
+along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>.
diff --git a/admin/notes/tree-sitter/build-module/batch.sh b/admin/notes/tree-sitter/build-module/batch.sh
new file mode 100755
index 00000000000..012b5882e83
--- /dev/null
+++ b/admin/notes/tree-sitter/build-module/batch.sh
@@ -0,0 +1,32 @@
+#!/bin/bash
+
+languages=(
+ 'bash'
+ 'c'
+ 'cmake'
+ 'cpp'
+ 'css'
+ 'c-sharp'
+ 'dockerfile'
+ 'elixir'
+ 'go'
+ 'go-mod'
+ 'heex'
+ 'html'
+ 'java'
+ 'javascript'
+ 'json'
+ 'lua'
+ 'python'
+ 'ruby'
+ 'rust'
+ 'toml'
+ 'tsx'
+ 'typescript'
+ 'yaml'
+)
+
+for language in "${languages[@]}"
+do
+ ./build.sh $language
+done
diff --git a/admin/notes/tree-sitter/build-module/build.sh b/admin/notes/tree-sitter/build-module/build.sh
new file mode 100755
index 00000000000..9a567bb094d
--- /dev/null
+++ b/admin/notes/tree-sitter/build-module/build.sh
@@ -0,0 +1,95 @@
+#!/bin/bash
+
+lang=$1
+topdir="$PWD"
+
+case $(uname) in
+ "Darwin")
+ soext="dylib"
+ ;;
+ *"MINGW"*)
+ soext="dll"
+ ;;
+ *)
+ soext="so"
+ ;;
+esac
+
+echo "Building ${lang}"
+
+### Retrieve sources
+
+org="tree-sitter"
+repo="tree-sitter-${lang}"
+sourcedir="tree-sitter-${lang}/src"
+grammardir="tree-sitter-${lang}"
+
+case "${lang}" in
+ "dockerfile")
+ org="camdencheek"
+ ;;
+ "cmake")
+ org="uyha"
+ ;;
+ "elixir")
+ org="elixir-lang"
+ ;;
+ "go-mod")
+ # The parser is called "gomod".
+ lang="gomod"
+ org="camdencheek"
+ ;;
+ "heex")
+ org="phoenixframework"
+ ;;
+ "lua")
+ org="tree-sitter-grammars"
+ ;;
+ "typescript")
+ sourcedir="tree-sitter-typescript/typescript/src"
+ grammardir="tree-sitter-typescript/typescript"
+ ;;
+ "tsx")
+ repo="tree-sitter-typescript"
+ sourcedir="tree-sitter-typescript/tsx/src"
+ grammardir="tree-sitter-typescript/tsx"
+ ;;
+ "yaml")
+ org="ikatyang"
+ ;;
+esac
+
+git clone "https://github.com/${org}/${repo}.git" \
+ --depth 1 --quiet
+cp "${grammardir}"/grammar.js "${sourcedir}"
+# We have to go into the source directory to compile, because some
+# C files refer to files like "../../common/scanner.h".
+cd "${sourcedir}"
+
+### Build
+
+cc -fPIC -c -I. parser.c
+# Compile scanner.c.
+if test -f scanner.c
+then
+ cc -fPIC -c -I. scanner.c
+fi
+# Compile scanner.cc.
+if test -f scanner.cc
+then
+ c++ -fPIC -I. -c scanner.cc
+fi
+# Link.
+if test -f scanner.cc
+then
+ c++ -fPIC -shared *.o -o "libtree-sitter-${lang}.${soext}"
+else
+ cc -fPIC -shared *.o -o "libtree-sitter-${lang}.${soext}"
+fi
+
+### Copy out
+
+mkdir -p "${topdir}/dist"
+cp "libtree-sitter-${lang}.${soext}" "${topdir}/dist"
+cd "${topdir}"
+rm -rf "${repo}"
diff --git a/admin/notes/tree-sitter/performance b/admin/notes/tree-sitter/performance
new file mode 100644
index 00000000000..23f84743ced
--- /dev/null
+++ b/admin/notes/tree-sitter/performance
@@ -0,0 +1,25 @@
+TREE-SITTER PERFORMANCE NOTES -*- org -*-
+
+* Facts
+
+Incremental parsing of a few characters worth of edit usually takes
+less than 0.1ms. If it takes longer than that, something is wrong.
+There’s one time where I found tree-sitter-c takes ~30ms to
+incremental parse. Updating to the latest version of tree-sitter-c
+solves it, so I didn’t investigate further.
+
+The ranges set for a parser doesn’t grow when you insert text into a
+range, so you have to update the ranges every time before
+parsing. Fortunately, changing ranges doesn’t invalidate incremental
+parsing, so there isn’t any performance lost in update ranges
+frequently.
+
+* Experiments
+
+Using regexp by default in treesit-simple-indent-rules seems wasteful,
+so I tried replacing all string-match-p to equal in
+treesit-simple-indent-presets, and indent xdisp.c for a comparison.
+Turns out using regexp by default is faster: regexp-based indent took
+45s and equal-based indent took 75s.
+
+I could be missing something, further experiments are welcome.
diff --git a/admin/notes/unicode b/admin/notes/unicode
index e11667d989e..4a25d8159cb 100644
--- a/admin/notes/unicode
+++ b/admin/notes/unicode
@@ -39,9 +39,9 @@ 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.
+UCD (search for "unassigned" and "@missing" 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
@@ -61,9 +61,10 @@ Next, review the changes in UnicodeData.txt vs the previous version
used by Emacs. Any changes, be it introduction of new scripts or
addition of codepoints to existing scripts, might need corresponding
changes in the data used for filling the category-table, case-table,
-and char-width-table. The additional scripts should cause automatic
-updates in charscript.el, but it is a good idea to look at the results
-and see if any changes in admin/unidata/blocks.awk are required.
+and char-width-table in characters.el. The additional scripts should
+cause automatic updates in charscript.el, but it is a good idea to
+look at the results and see if any changes in admin/unidata/blocks.awk
+are required.
The setting of char-width-table around line 1200 of characters.el
should be checked against the latest version of the Unicode file
@@ -72,7 +73,10 @@ characters are those marked with W or F in that file. Zero-width
characters are not taken from EastAsianWidth.txt, they are those whose
Unicode General Category property is one of Mn, Me, or Cf, and also
Hangul jungseong and jongseong characters (a.k.a. "Jamo medial vowels"
-and "Jamo final consonants").
+and "Jamo final consonants"). The list of "ambiguous-width
+characters" recorded in the ambiguous-width-chars table (around line
+1400 of characters.el) should also be checked against the latest
+Unicode data in EastAsianWidth.txt.
Any new scripts added by UnicodeData.txt will also need updates to
script-representative-chars defined in fontset.el, and also the list
@@ -307,6 +311,12 @@ nontrivial changes to the build process.
src/msdos.c
+ * iso-latin-1
+
+ This file is used to test Emacs encoding.
+
+ test/lisp/gnus/mm-decode-resources/win1252-multipart.bin
+
* iso-2022-cn-ext
This file is externally generated from leim/MISC-DIC/cangjie-table.b5
@@ -357,19 +367,27 @@ nontrivial changes to the build process.
Some of the entries in this list are patterns, and stand for any
files with the listed extension.
+ *.bmp
+ *.cur
+ *.gif
+ *.gpg
*.gz
*.icns
*.ico
+ *.jpg
+ *.kbx
+ *.key
*.pbm
*.pdf
+ *.pif
*.png
*.sig
+ *.tiff
+ *.webp
+ *.zip
etc/e/eterm-color
- etc/package-keyring.gpg
- msdos/emacs.pif
- nextstep/GNUstep/Emacs.base/Resources/emacs.tiff
- nt/icons/hand.cur
-
+ etc/e/eterm-direct
+ java/emacs.keystore
This file is part of GNU Emacs.
diff --git a/admin/notes/years b/admin/notes/years
index 113e6608d3f..0510cb24b81 100644
--- a/admin/notes/years
+++ b/admin/notes/years
@@ -24,6 +24,8 @@ A few known problems with the build-aux/update-copyright script:
. several README and XPM files under etc/images/, and also
etc/refcards/README, msdos/README, and nt/icons/README aren't
updated either
+ - the copyright notice for headers generated by exec/configure.ac is
+ not updated as the file already bears a notice above it
These files need to be updated by hand.
diff --git a/admin/syncdoc-type-hierarchy.el b/admin/syncdoc-type-hierarchy.el
new file mode 100644
index 00000000000..bfbbbc45aa4
--- /dev/null
+++ b/admin/syncdoc-type-hierarchy.el
@@ -0,0 +1,133 @@
+;;; syncdoc-type-hierarchy.el--- -*- lexical-binding: t -*-
+
+;; Copyright (C) 2023-2024 Free Software Foundation, Inc.
+
+;; Author: Andrea Corallo <acorallo@gnu.org>
+;; Keywords: documentation
+
+;; This file is part of GNU Emacs.
+
+;; GNU Emacs is free software: you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+
+;; GNU Emacs is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>.
+
+;;; Commentary:
+
+;; This file is used to keep the type hierarchy representation present
+;; in the elisp manual in sync with the current type hierarchy. This
+;; is specified in `cl--direct-supertypes-of-type' in cl-preloaded.el, so each
+;; time `cl--direct-supertypes-of-type' is modified
+;; `syncdoc-update-type-hierarchy' must be run before the
+;; documentation is regenerated.
+
+;; We do not call this directly from make docs in order not to add a
+;; dependency on the tool "dot".
+
+;;; Code:
+
+(require 'cl-lib)
+
+(defconst syncdoc-file (or (macroexp-file-name) buffer-file-name))
+
+(defconst syncdoc-emacs-repo-dir
+ (expand-file-name "../" (file-name-directory syncdoc-file)))
+
+(defconst syncdoc-lispref-dir
+ (expand-file-name "doc/lispref/" syncdoc-emacs-repo-dir))
+
+(defconst syncdoc-all-types
+ (let (res)
+ (mapatoms (lambda (type)
+ (when (cl-find-class type)
+ (push type res)))
+ obarray)
+ (nreverse
+ (merge-ordered-lists
+ (sort
+ (mapcar (lambda (type) (cl--class-allparents (cl-find-class type)))
+ res)
+ (lambda (ts1 ts2) (> (length ts1) (length ts2)))))))
+ "List of all types.")
+
+(defconst syncdoc-hierarchy
+ (progn
+ ;; Require it here so we don't load it before `syncdoc-all-types' is
+ ;; computed.
+ (cl-loop
+ with h = (make-hash-table :test #'eq)
+ for type in syncdoc-all-types
+ do (puthash type (mapcar #'cl--class-name
+ (cl--class-parents (cl-find-class type)))
+ h)
+ finally return h)))
+
+(defun syncdoc-insert-dot-content (rankdir)
+ (maphash (lambda (child parents)
+ (cl-loop for parent in parents
+ do (insert " \"" (symbol-name child) "\" -> \""
+ (symbol-name parent) "\";\n")))
+ syncdoc-hierarchy)
+ (sort-lines nil (point-min) (point-max))
+
+ (goto-char (point-min))
+ (insert "digraph {\n rankdir=\"" rankdir "\";\n")
+ (goto-char (point-max))
+ (insert "}\n"))
+
+(defun syncdoc-make-type-table (file)
+ (with-temp-file file
+ (insert "|Type| Derived Types|\n|-\n")
+ (let ((subtypes ()))
+ ;; First collect info from the "builtin" types.
+ (maphash (lambda (type parents)
+ (dolist (parent parents)
+ (push type (alist-get parent subtypes))))
+ syncdoc-hierarchy)
+ (sort subtypes
+ (lambda (x1 x2)
+ (< (length (memq (car x2) syncdoc-all-types))
+ (length (memq (car x1) syncdoc-all-types)))))
+ (cl-loop for (type . children) in subtypes
+ do (insert "|" (symbol-name type) " |")
+ do (cl-loop with x = 0
+ for child in children
+ for child-len = (length (symbol-name child))
+ when (> (+ x child-len 2) 60)
+ do (progn
+ (insert "|\n||")
+ (setq x 0))
+ do (insert (symbol-name child) " ")
+ do (cl-incf x (1+ child-len)) )
+ do (insert "\n")))
+ (require 'org-table)
+ (declare-function 'org-table-align "org")
+ (org-table-align)))
+
+(defun syncdoc-update-type-hierarchy0 ()
+ "Update the type hierarchy representation used by the elisp manual."
+ (with-temp-buffer
+ (syncdoc-insert-dot-content "LR")
+ (with-demoted-errors "%S" ;In case "dot" is not found!
+ (call-process-region nil nil "dot" t (current-buffer) nil "-Tjpg" "-o"
+ (expand-file-name "elisp_type_hierarchy.jpg"
+ syncdoc-lispref-dir))))
+ (syncdoc-make-type-table (expand-file-name "elisp_type_hierarchy.txt"
+ syncdoc-lispref-dir)))
+
+(defun syncdoc-update-type-hierarchy ()
+ "Update the type hierarchy representation used by the elisp manual."
+ (interactive)
+ (call-process (expand-file-name "src/emacs" syncdoc-emacs-repo-dir)
+ nil t t "-Q" "--batch" "-l" syncdoc-file
+ "-f" "syncdoc-update-type-hierarchy0"))
+
+;;; syncdoc-type-hierarchy.el ends here
diff --git a/admin/unidata/BidiBrackets.txt b/admin/unidata/BidiBrackets.txt
index e138e7f5bea..8cebea41544 100644
--- a/admin/unidata/BidiBrackets.txt
+++ b/admin/unidata/BidiBrackets.txt
@@ -1,6 +1,6 @@
-# BidiBrackets-15.0.0.txt
-# Date: 2022-05-03, 18:42:00 GMT [AG, LI, KW]
-# © 2022 Unicode®, Inc.
+# BidiBrackets-15.1.0.txt
+# Date: 2023-01-18
+# © 2023 Unicode®, Inc.
# Unicode and the Unicode Logo are registered trademarks of Unicode, Inc. in the U.S. and other countries.
# For terms of use, see https://www.unicode.org/terms_of_use.html
#
@@ -12,11 +12,11 @@
# This file is a normative contributory data file in the Unicode
# Character Database.
#
-# Bidi_Paired_Bracket is a normative property of type Miscellaneous,
+# Bidi_Paired_Bracket is a normative property
# which establishes a mapping between characters that are treated as
# bracket pairs by the Unicode Bidirectional Algorithm.
#
-# Bidi_Paired_Bracket_Type is a normative property of type Enumeration,
+# Bidi_Paired_Bracket_Type is a normative property
# which classifies characters into opening and closing paired brackets
# for the purposes of the Unicode Bidirectional Algorithm.
#
diff --git a/admin/unidata/BidiMirroring.txt b/admin/unidata/BidiMirroring.txt
index 5861d6e7f4b..7e58cc4d715 100644
--- a/admin/unidata/BidiMirroring.txt
+++ b/admin/unidata/BidiMirroring.txt
@@ -1,6 +1,6 @@
-# BidiMirroring-15.0.0.txt
-# Date: 2022-05-03, 18:47:00 GMT [KW, RP]
-# © 2022 Unicode®, Inc.
+# BidiMirroring-15.1.0.txt
+# Date: 2023-01-05
+# © 2023 Unicode®, Inc.
# For terms of use, see https://www.unicode.org/terms_of_use.html
#
# Unicode Character Database
@@ -15,7 +15,7 @@
# value, for which there is another Unicode character that typically has a glyph
# that is the mirror image of the original character's glyph.
#
-# The repertoire covered by the file is Unicode 15.0.0.
+# The repertoire covered by the file is Unicode 15.1.0.
#
# The file contains a list of lines with mappings from one code point
# to another one for character-based mirroring.
diff --git a/admin/unidata/Blocks.txt b/admin/unidata/Blocks.txt
index 12684594c9f..8fa3eaad04a 100644
--- a/admin/unidata/Blocks.txt
+++ b/admin/unidata/Blocks.txt
@@ -1,6 +1,6 @@
-# Blocks-15.0.0.txt
-# Date: 2022-01-28, 20:58:00 GMT [KW]
-# © 2022 Unicode®, Inc.
+# Blocks-15.1.0.txt
+# Date: 2023-07-28, 15:47:20 GMT
+# © 2023 Unicode®, Inc.
# For terms of use, see https://www.unicode.org/terms_of_use.html
#
# Unicode Character Database
@@ -352,6 +352,7 @@ FFF0..FFFF; Specials
2B740..2B81F; CJK Unified Ideographs Extension D
2B820..2CEAF; CJK Unified Ideographs Extension E
2CEB0..2EBEF; CJK Unified Ideographs Extension F
+2EBF0..2EE5F; CJK Unified Ideographs Extension I
2F800..2FA1F; CJK Compatibility Ideographs Supplement
30000..3134F; CJK Unified Ideographs Extension G
31350..323AF; CJK Unified Ideographs Extension H
diff --git a/admin/unidata/IdnaMappingTable.txt b/admin/unidata/IdnaMappingTable.txt
index e4c06117929..3bf6b2668a4 100644
--- a/admin/unidata/IdnaMappingTable.txt
+++ b/admin/unidata/IdnaMappingTable.txt
@@ -1,11 +1,11 @@
# IdnaMappingTable.txt
-# Date: 2022-05-02, 19:29:26 GMT
-# © 2022 Unicode®, Inc.
+# Date: 2023-08-10, 22:32:27 GMT
+# © 2023 Unicode®, Inc.
# Unicode and the Unicode Logo are registered trademarks of Unicode, Inc. in the U.S. and other countries.
# For terms of use, see https://www.unicode.org/terms_of_use.html
#
# Unicode IDNA Compatible Preprocessing for UTS #46
-# Version: 15.0.0
+# Version: 15.1.0
#
# For documentation and usage, see https://www.unicode.org/reports/tr46
#
@@ -2036,7 +2036,7 @@
1E9A ; mapped ; 0061 02BE # 1.1 LATIN SMALL LETTER A WITH RIGHT HALF RING
1E9B ; mapped ; 1E61 # 2.0 LATIN SMALL LETTER LONG S WITH DOT ABOVE
1E9C..1E9D ; valid # 5.1 LATIN SMALL LETTER LONG S WITH DIAGONAL STROKE..LATIN SMALL LETTER LONG S WITH HIGH STROKE
-1E9E ; mapped ; 0073 0073 # 5.1 LATIN CAPITAL LETTER SHARP S
+1E9E ; mapped ; 00DF # 5.1 LATIN CAPITAL LETTER SHARP S
1E9F ; valid # 5.1 LATIN SMALL LETTER DELTA
1EA0 ; mapped ; 1EA1 # 1.1 LATIN CAPITAL LETTER A WITH DOT BELOW
1EA1 ; valid # 1.1 LATIN SMALL LETTER A WITH DOT BELOW
@@ -2565,11 +2565,7 @@
222E ; valid ; ; NV8 # 1.1 CONTOUR INTEGRAL
222F ; mapped ; 222E 222E # 1.1 SURFACE INTEGRAL
2230 ; mapped ; 222E 222E 222E #1.1 VOLUME INTEGRAL
-2231..225F ; valid ; ; NV8 # 1.1 CLOCKWISE INTEGRAL..QUESTIONED EQUAL TO
-2260 ; disallowed_STD3_valid # 1.1 NOT EQUAL TO
-2261..226D ; valid ; ; NV8 # 1.1 IDENTICAL TO..NOT EQUIVALENT TO
-226E..226F ; disallowed_STD3_valid # 1.1 NOT LESS-THAN..NOT GREATER-THAN
-2270..22F1 ; valid ; ; NV8 # 1.1 NEITHER LESS-THAN NOR EQUAL TO..DOWN RIGHT DIAGONAL ELLIPSIS
+2231..22F1 ; valid ; ; NV8 # 1.1 CLOCKWISE INTEGRAL..DOWN RIGHT DIAGONAL ELLIPSIS
22F2..22FF ; valid ; ; NV8 # 3.2 ELEMENT OF WITH LONG HORIZONTAL STROKE..Z NOTATION BAG MEMBERSHIP
2300 ; valid ; ; NV8 # 1.1 DIAMETER SIGN
2301 ; valid ; ; NV8 # 3.0 ELECTRIC ARROW
@@ -3273,7 +3269,7 @@
2FD5 ; mapped ; 9FA0 # 3.0 KANGXI RADICAL FLUTE
2FD6..2FEF ; disallowed # NA <reserved-2FD6>..<reserved-2FEF>
2FF0..2FFB ; disallowed # 3.0 IDEOGRAPHIC DESCRIPTION CHARACTER LEFT TO RIGHT..IDEOGRAPHIC DESCRIPTION CHARACTER OVERLAID
-2FFC..2FFF ; disallowed # NA <reserved-2FFC>..<reserved-2FFF>
+2FFC..2FFF ; disallowed # 15.1 IDEOGRAPHIC DESCRIPTION CHARACTER SURROUND FROM RIGHT..IDEOGRAPHIC DESCRIPTION CHARACTER ROTATION
3000 ; disallowed_STD3_mapped ; 0020 # 1.1 IDEOGRAPHIC SPACE
3001 ; valid ; ; NV8 # 1.1 IDEOGRAPHIC COMMA
3002 ; mapped ; 002E # 1.1 IDEOGRAPHIC FULL STOP
@@ -3425,7 +3421,8 @@
31BB..31BF ; valid # 13.0 BOPOMOFO FINAL LETTER G..BOPOMOFO LETTER AH
31C0..31CF ; valid ; ; NV8 # 4.1 CJK STROKE T..CJK STROKE N
31D0..31E3 ; valid ; ; NV8 # 5.1 CJK STROKE H..CJK STROKE Q
-31E4..31EF ; disallowed # NA <reserved-31E4>..<reserved-31EF>
+31E4..31EE ; disallowed # NA <reserved-31E4>..<reserved-31EE>
+31EF ; disallowed # 15.1 IDEOGRAPHIC DESCRIPTION CHARACTER SUBTRACTION
31F0..31FF ; valid # 3.2 KATAKANA LETTER SMALL KU..KATAKANA LETTER SMALL RO
3200 ; disallowed_STD3_mapped ; 0028 1100 0029 #1.1 PARENTHESIZED HANGUL KIYEOK
3201 ; disallowed_STD3_mapped ; 0028 1102 0029 #1.1 PARENTHESIZED HANGUL NIEUN
@@ -8450,7 +8447,9 @@ FFFE..FFFF ; disallowed # 1.1 <noncharacter-FFFE
2B820..2CEA1 ; valid # 8.0 CJK UNIFIED IDEOGRAPH-2B820..CJK UNIFIED IDEOGRAPH-2CEA1
2CEA2..2CEAF ; disallowed # NA <reserved-2CEA2>..<reserved-2CEAF>
2CEB0..2EBE0 ; valid # 10.0 CJK UNIFIED IDEOGRAPH-2CEB0..CJK UNIFIED IDEOGRAPH-2EBE0
-2EBE1..2F7FF ; disallowed # NA <reserved-2EBE1>..<reserved-2F7FF>
+2EBE1..2EBEF ; disallowed # NA <reserved-2EBE1>..<reserved-2EBEF>
+2EBF0..2EE5D ; valid # 15.1 CJK UNIFIED IDEOGRAPH-2EBF0..CJK UNIFIED IDEOGRAPH-2EE5D
+2EE5E..2F7FF ; disallowed # NA <reserved-2EE5E>..<reserved-2F7FF>
2F800 ; mapped ; 4E3D # 3.1 CJK COMPATIBILITY IDEOGRAPH-2F800
2F801 ; mapped ; 4E38 # 3.1 CJK COMPATIBILITY IDEOGRAPH-2F801
2F802 ; mapped ; 4E41 # 3.1 CJK COMPATIBILITY IDEOGRAPH-2F802
diff --git a/admin/unidata/Makefile.in b/admin/unidata/Makefile.in
index 6768d610ee0..a5fd927f548 100644
--- a/admin/unidata/Makefile.in
+++ b/admin/unidata/Makefile.in
@@ -105,19 +105,23 @@ ${unidir}/idna-mapping.el: ${srcdir}/unidata-gen.el \
charscript.el: ${unidir}/charscript.el
blocks = ${srcdir}/blocks.awk
-
+blocks_sources = ${srcdir}/Blocks.txt ${srcdir}/emoji-data.txt
${unidir}/charscript.el: ${blocks}
-${unidir}/charscript.el: ${srcdir}/Blocks.txt ${srcdir}/emoji-data.txt
- $(AM_V_GEN)$(AWK) -f ${blocks} $^ > $@
+# Don't use $^, since that includes the awk script.
+${unidir}/charscript.el: ${blocks_sources}
+ $(AM_V_GEN)$(AWK) -f ${blocks} ${blocks_sources} > $@
.PHONY: emoji-zwj.el
emoji-zwj.el: ${unidir}/emoji-zwj.el
zwj = ${srcdir}/emoji-zwj.awk
+zwj_sources = ${srcdir}/emoji-zwj-sequences.txt $(srcdir)/emoji-sequences.txt
+${unidir}/emoji-zwj.el: ${zwj}
-${unidir}/emoji-zwj.el: ${srcdir}/emoji-zwj-sequences.txt $(srcdir)/emoji-sequences.txt ${zwj}
- $(AM_V_GEN)$(AWK) -f ${zwj} $^ > $@
+# Don't use $^, since that includes the awk script.
+${unidir}/emoji-zwj.el: ${zwj_sources}
+ $(AM_V_GEN)$(AWK) -f ${zwj} ${zwj_sources} > $@
.PHONY: clean bootstrap-clean distclean maintainer-clean gen-clean
diff --git a/admin/unidata/NormalizationTest.txt b/admin/unidata/NormalizationTest.txt
index e75b4801c9b..2e88574243d 100644
--- a/admin/unidata/NormalizationTest.txt
+++ b/admin/unidata/NormalizationTest.txt
@@ -1,6 +1,6 @@
-# NormalizationTest-15.0.0.txt
-# Date: 2022-04-02, 01:29:09 GMT
-# © 2022 Unicode®, Inc.
+# NormalizationTest-15.1.0.txt
+# Date: 2023-01-05, 20:34:44 GMT
+# © 2023 Unicode®, Inc.
# Unicode and the Unicode Logo are registered trademarks of Unicode, Inc. in the U.S. and other countries.
# For terms of use, see https://www.unicode.org/terms_of_use.html
#
diff --git a/admin/unidata/PropertyValueAliases.txt b/admin/unidata/PropertyValueAliases.txt
index 9346fcf03ee..6d308108818 100644
--- a/admin/unidata/PropertyValueAliases.txt
+++ b/admin/unidata/PropertyValueAliases.txt
@@ -1,6 +1,6 @@
-# PropertyValueAliases-15.0.0.txt
-# Date: 2022-08-05, 23:42:17 GMT
-# © 2022 Unicode®, Inc.
+# PropertyValueAliases-15.1.0.txt
+# Date: 2023-08-07, 15:21:34 GMT
+# © 2023 Unicode®, Inc.
# Unicode and the Unicode Logo are registered trademarks of Unicode, Inc. in the U.S. and other countries.
# For terms of use, see https://www.unicode.org/terms_of_use.html
#
@@ -91,6 +91,7 @@ age; 12.1 ; V12_1
age; 13.0 ; V13_0
age; 14.0 ; V14_0
age; 15.0 ; V15_0
+age; 15.1 ; V15_1
age; NA ; Unassigned
# Alphabetic (Alpha)
@@ -208,6 +209,7 @@ blk; CJK_Ext_E ; CJK_Unified_Ideographs_Extension_E
blk; CJK_Ext_F ; CJK_Unified_Ideographs_Extension_F
blk; CJK_Ext_G ; CJK_Unified_Ideographs_Extension_G
blk; CJK_Ext_H ; CJK_Unified_Ideographs_Extension_H
+blk; CJK_Ext_I ; CJK_Unified_Ideographs_Extension_I
blk; CJK_Radicals_Sup ; CJK_Radicals_Supplement
blk; CJK_Strokes ; CJK_Strokes
blk; CJK_Symbols ; CJK_Symbols_And_Punctuation
@@ -817,6 +819,21 @@ IDSB; Y ; Yes ; T
IDST; N ; No ; F ; False
IDST; Y ; Yes ; T ; True
+# IDS_Unary_Operator (IDSU)
+
+IDSU; N ; No ; F ; False
+IDSU; Y ; Yes ; T ; True
+
+# ID_Compat_Math_Continue (ID_Compat_Math_Continue)
+
+ID_Compat_Math_Continue; N ; No ; F ; False
+ID_Compat_Math_Continue; Y ; Yes ; T ; True
+
+# ID_Compat_Math_Start (ID_Compat_Math_Start)
+
+ID_Compat_Math_Start; N ; No ; F ; False
+ID_Compat_Math_Start; Y ; Yes ; T ; True
+
# ID_Continue (IDC)
IDC; N ; No ; F ; False
@@ -836,6 +853,13 @@ IDS; Y ; Yes ; T
Ideo; N ; No ; F ; False
Ideo; Y ; Yes ; T ; True
+# Indic_Conjunct_Break (InCB)
+
+InCB; Consonant ; Consonant
+InCB; Extend ; Extend
+InCB; Linker ; Linker
+InCB; None ; None
+
# Indic_Positional_Category (InPC)
InPC; Bottom ; Bottom
@@ -1074,7 +1098,10 @@ jt ; U ; Non_Joining
# Line_Break (lb)
lb ; AI ; Ambiguous
+lb ; AK ; Aksara
lb ; AL ; Alphabetic
+lb ; AP ; Aksara_Prebase
+lb ; AS ; Aksara_Start
lb ; B2 ; Break_Both
lb ; BA ; Break_After
lb ; BB ; Break_Before
@@ -1112,6 +1139,8 @@ lb ; SA ; Complex_Context
lb ; SG ; Surrogate
lb ; SP ; Space
lb ; SY ; Break_Symbols
+lb ; VF ; Virama_Final
+lb ; VI ; Virama
lb ; WJ ; Word_Joiner
lb ; XX ; Unknown
lb ; ZW ; ZWSpace
@@ -1156,6 +1185,9 @@ NFKC_QC; M ; Maybe
NFKC_QC; N ; No
NFKC_QC; Y ; Yes
+# NFKC_Simple_Casefold (NFKC_SCF)
+
+
# NFKD_Quick_Check (NFKD_QC)
NFKD_QC; N ; No
diff --git a/admin/unidata/ScriptExtensions.txt b/admin/unidata/ScriptExtensions.txt
index 2f5a1727e33..23141fb8241 100644
--- a/admin/unidata/ScriptExtensions.txt
+++ b/admin/unidata/ScriptExtensions.txt
@@ -1,6 +1,6 @@
-# ScriptExtensions-15.0.0.txt
-# Date: 2022-02-02, 00:57:11 GMT
-# © 2022 Unicode®, Inc.
+# ScriptExtensions-15.1.0.txt
+# Date: 2023-02-01, 23:02:24 GMT
+# © 2023 Unicode®, Inc.
# Unicode and the Unicode Logo are registered trademarks of Unicode, Inc. in the U.S. and other countries.
# For terms of use, see https://www.unicode.org/terms_of_use.html
#
@@ -136,20 +136,20 @@
# ================================================
-# Script_Extensions=Arab Rohg
+# Script_Extensions=Arab Nkoo
-06D4 ; Arab Rohg # Po ARABIC FULL STOP
+FD3E ; Arab Nkoo # Pe ORNATE LEFT PARENTHESIS
+FD3F ; Arab Nkoo # Ps ORNATE RIGHT PARENTHESIS
-# Total code points: 1
+# Total code points: 2
# ================================================
-# Script_Extensions=Arab Nkoo
+# Script_Extensions=Arab Rohg
-FD3E ; Arab Nkoo # Pe ORNATE LEFT PARENTHESIS
-FD3F ; Arab Nkoo # Ps ORNATE RIGHT PARENTHESIS
+06D4 ; Arab Rohg # Po ARABIC FULL STOP
-# Total code points: 2
+# Total code points: 1
# ================================================
@@ -553,17 +553,17 @@ FF64..FF65 ; Bopo Hang Hani Hira Kana Yiii # Po [2] HALFWIDTH IDEOGRAPHIC C
# ================================================
-# Script_Extensions=Beng Deva Gran Knda Nand Orya Telu Tirh
+# Script_Extensions=Adlm Arab Mand Mani Ougr Phlp Rohg Sogd Syrc
-1CF2 ; Beng Deva Gran Knda Nand Orya Telu Tirh # Lo VEDIC SIGN ARDHAVISARGA
+0640 ; Adlm Arab Mand Mani Ougr Phlp Rohg Sogd Syrc # Lm ARABIC TATWEEL
# Total code points: 1
# ================================================
-# Script_Extensions=Adlm Arab Mand Mani Ougr Phlp Rohg Sogd Syrc
+# Script_Extensions=Beng Deva Gran Knda Mlym Nand Orya Sinh Telu Tirh
-0640 ; Adlm Arab Mand Mani Ougr Phlp Rohg Sogd Syrc # Lm ARABIC TATWEEL
+1CF2 ; Beng Deva Gran Knda Mlym Nand Orya Sinh Telu Tirh # Lo VEDIC SIGN ARDHAVISARGA
# Total code points: 1
@@ -572,10 +572,9 @@ FF64..FF65 ; Bopo Hang Hani Hira Kana Yiii # Po [2] HALFWIDTH IDEOGRAPHIC C
# Script_Extensions=Deva Dogr Gujr Guru Khoj Kthi Mahj Modi Sind Takr Tirh
A836..A837 ; Deva Dogr Gujr Guru Khoj Kthi Mahj Modi Sind Takr Tirh # So [2] NORTH INDIC QUARTER MARK..NORTH INDIC PLACEHOLDER MARK
-A838 ; Deva Dogr Gujr Guru Khoj Kthi Mahj Modi Sind Takr Tirh # Sc NORTH INDIC RUPEE MARK
A839 ; Deva Dogr Gujr Guru Khoj Kthi Mahj Modi Sind Takr Tirh # So NORTH INDIC QUANTITY MARK
-# Total code points: 4
+# Total code points: 3
# ================================================
@@ -587,6 +586,14 @@ A839 ; Deva Dogr Gujr Guru Khoj Kthi Mahj Modi Sind Takr Tirh # So
# ================================================
+# Script_Extensions=Deva Dogr Gujr Guru Khoj Kthi Mahj Modi Shrd Sind Takr Tirh
+
+A838 ; Deva Dogr Gujr Guru Khoj Kthi Mahj Modi Shrd Sind Takr Tirh # Sc NORTH INDIC RUPEE MARK
+
+# Total code points: 1
+
+# ================================================
+
# Script_Extensions=Beng Deva Gran Gujr Guru Knda Latn Mlym Orya Shrd Taml Telu Tirh
0951 ; Beng Deva Gran Gujr Guru Knda Latn Mlym Orya Shrd Taml Telu Tirh # Mn DEVANAGARI STRESS SIGN UDATTA
@@ -595,17 +602,17 @@ A839 ; Deva Dogr Gujr Guru Khoj Kthi Mahj Modi Sind Takr Tirh # So
# ================================================
-# Script_Extensions=Deva Dogr Gujr Guru Khoj Knda Kthi Mahj Modi Nand Sind Takr Tirh
+# Script_Extensions=Deva Dogr Gujr Guru Khoj Knda Kthi Mahj Modi Nand Shrd Sind Takr Tirh
-A833..A835 ; Deva Dogr Gujr Guru Khoj Knda Kthi Mahj Modi Nand Sind Takr Tirh # No [3] NORTH INDIC FRACTION ONE SIXTEENTH..NORTH INDIC FRACTION THREE SIXTEENTHS
+A833..A835 ; Deva Dogr Gujr Guru Khoj Knda Kthi Mahj Modi Nand Shrd Sind Takr Tirh # No [3] NORTH INDIC FRACTION ONE SIXTEENTH..NORTH INDIC FRACTION THREE SIXTEENTHS
# Total code points: 3
# ================================================
-# Script_Extensions=Deva Dogr Gujr Guru Khoj Knda Kthi Mahj Mlym Modi Nand Sind Takr Tirh
+# Script_Extensions=Deva Dogr Gujr Guru Khoj Knda Kthi Mahj Mlym Modi Nand Shrd Sind Takr Tirh
-A830..A832 ; Deva Dogr Gujr Guru Khoj Knda Kthi Mahj Mlym Modi Nand Sind Takr Tirh # No [3] NORTH INDIC FRACTION ONE QUARTER..NORTH INDIC FRACTION THREE QUARTERS
+A830..A832 ; Deva Dogr Gujr Guru Khoj Knda Kthi Mahj Mlym Modi Nand Shrd Sind Takr Tirh # No [3] NORTH INDIC FRACTION ONE QUARTER..NORTH INDIC FRACTION THREE QUARTERS
# Total code points: 3
diff --git a/admin/unidata/Scripts.txt b/admin/unidata/Scripts.txt
index 2b138bffb88..0b3f717cb20 100644
--- a/admin/unidata/Scripts.txt
+++ b/admin/unidata/Scripts.txt
@@ -1,6 +1,6 @@
-# Scripts-15.0.0.txt
-# Date: 2022-04-26, 23:15:02 GMT
-# © 2022 Unicode®, Inc.
+# Scripts-15.1.0.txt
+# Date: 2023-07-28, 16:01:07 GMT
+# © 2023 Unicode®, Inc.
# Unicode and the Unicode Logo are registered trademarks of Unicode, Inc. in the U.S. and other countries.
# For terms of use, see https://www.unicode.org/terms_of_use.html
#
@@ -357,7 +357,7 @@
2E5B ; Common # Ps BOTTOM HALF LEFT PARENTHESIS
2E5C ; Common # Pe BOTTOM HALF RIGHT PARENTHESIS
2E5D ; Common # Pd OBLIQUE HYPHEN
-2FF0..2FFB ; Common # So [12] IDEOGRAPHIC DESCRIPTION CHARACTER LEFT TO RIGHT..IDEOGRAPHIC DESCRIPTION CHARACTER OVERLAID
+2FF0..2FFF ; Common # So [16] IDEOGRAPHIC DESCRIPTION CHARACTER LEFT TO RIGHT..IDEOGRAPHIC DESCRIPTION CHARACTER ROTATION
3000 ; Common # Zs IDEOGRAPHIC SPACE
3001..3003 ; Common # Po [3] IDEOGRAPHIC COMMA..DITTO MARK
3004 ; Common # So JAPANESE INDUSTRIAL STANDARD SYMBOL
@@ -399,6 +399,7 @@
3192..3195 ; Common # No [4] IDEOGRAPHIC ANNOTATION ONE MARK..IDEOGRAPHIC ANNOTATION FOUR MARK
3196..319F ; Common # So [10] IDEOGRAPHIC ANNOTATION TOP MARK..IDEOGRAPHIC ANNOTATION MAN MARK
31C0..31E3 ; Common # So [36] CJK STROKE T..CJK STROKE Q
+31EF ; Common # So IDEOGRAPHIC DESCRIPTION CHARACTER SUBTRACTION
3220..3229 ; Common # No [10] PARENTHESIZED IDEOGRAPH ONE..PARENTHESIZED IDEOGRAPH TEN
322A..3247 ; Common # So [30] PARENTHESIZED IDEOGRAPH MOON..CIRCLED IDEOGRAPH KOTO
3248..324F ; Common # No [8] CIRCLED NUMBER TEN ON BLACK SQUARE..CIRCLED NUMBER EIGHTY ON BLACK SQUARE
@@ -629,7 +630,7 @@ FFFC..FFFD ; Common # So [2] OBJECT REPLACEMENT CHARACTER..REPLACEMENT CHAR
E0001 ; Common # Cf LANGUAGE TAG
E0020..E007F ; Common # Cf [96] TAG SPACE..CANCEL TAG
-# Total code points: 8301
+# Total code points: 8306
# ================================================
@@ -1593,11 +1594,12 @@ FA70..FAD9 ; Han # Lo [106] CJK COMPATIBILITY IDEOGRAPH-FA70..CJK COMPATIBILI
2B740..2B81D ; Han # Lo [222] CJK UNIFIED IDEOGRAPH-2B740..CJK UNIFIED IDEOGRAPH-2B81D
2B820..2CEA1 ; Han # Lo [5762] CJK UNIFIED IDEOGRAPH-2B820..CJK UNIFIED IDEOGRAPH-2CEA1
2CEB0..2EBE0 ; Han # Lo [7473] CJK UNIFIED IDEOGRAPH-2CEB0..CJK UNIFIED IDEOGRAPH-2EBE0
+2EBF0..2EE5D ; Han # Lo [622] CJK UNIFIED IDEOGRAPH-2EBF0..CJK UNIFIED IDEOGRAPH-2EE5D
2F800..2FA1D ; Han # Lo [542] CJK COMPATIBILITY IDEOGRAPH-2F800..CJK COMPATIBILITY IDEOGRAPH-2FA1D
30000..3134A ; Han # Lo [4939] CJK UNIFIED IDEOGRAPH-30000..CJK UNIFIED IDEOGRAPH-3134A
31350..323AF ; Han # Lo [4192] CJK UNIFIED IDEOGRAPH-31350..CJK UNIFIED IDEOGRAPH-323AF
-# Total code points: 98408
+# Total code points: 99030
# ================================================
diff --git a/admin/unidata/SpecialCasing.txt b/admin/unidata/SpecialCasing.txt
index 08d04fa9421..de08450a6b9 100644
--- a/admin/unidata/SpecialCasing.txt
+++ b/admin/unidata/SpecialCasing.txt
@@ -1,6 +1,6 @@
-# SpecialCasing-15.0.0.txt
-# Date: 2022-02-02, 23:35:52 GMT
-# © 2022 Unicode®, Inc.
+# SpecialCasing-15.1.0.txt
+# Date: 2023-01-05, 20:35:03 GMT
+# © 2023 Unicode®, Inc.
# Unicode and the Unicode Logo are registered trademarks of Unicode, Inc. in the U.S. and other countries.
# For terms of use, see https://www.unicode.org/terms_of_use.html
#
diff --git a/admin/unidata/UnicodeData.txt b/admin/unidata/UnicodeData.txt
index ea963a7162c..bdcc41850d7 100644
--- a/admin/unidata/UnicodeData.txt
+++ b/admin/unidata/UnicodeData.txt
@@ -11231,6 +11231,10 @@
2FF9;IDEOGRAPHIC DESCRIPTION CHARACTER SURROUND FROM UPPER RIGHT;So;0;ON;;;;;N;;;;;
2FFA;IDEOGRAPHIC DESCRIPTION CHARACTER SURROUND FROM LOWER LEFT;So;0;ON;;;;;N;;;;;
2FFB;IDEOGRAPHIC DESCRIPTION CHARACTER OVERLAID;So;0;ON;;;;;N;;;;;
+2FFC;IDEOGRAPHIC DESCRIPTION CHARACTER SURROUND FROM RIGHT;So;0;ON;;;;;N;;;;;
+2FFD;IDEOGRAPHIC DESCRIPTION CHARACTER SURROUND FROM LOWER RIGHT;So;0;ON;;;;;N;;;;;
+2FFE;IDEOGRAPHIC DESCRIPTION CHARACTER HORIZONTAL REFLECTION;So;0;ON;;;;;N;;;;;
+2FFF;IDEOGRAPHIC DESCRIPTION CHARACTER ROTATION;So;0;ON;;;;;N;;;;;
3000;IDEOGRAPHIC SPACE;Zs;0;WS;<wide> 0020;;;;N;;;;;
3001;IDEOGRAPHIC COMMA;Po;0;ON;;;;;N;;;;;
3002;IDEOGRAPHIC FULL STOP;Po;0;ON;;;;;N;IDEOGRAPHIC PERIOD;;;;
@@ -11705,6 +11709,7 @@
31E1;CJK STROKE HZZZG;So;0;ON;;;;;N;;;;;
31E2;CJK STROKE PG;So;0;ON;;;;;N;;;;;
31E3;CJK STROKE Q;So;0;ON;;;;;N;;;;;
+31EF;IDEOGRAPHIC DESCRIPTION CHARACTER SUBTRACTION;So;0;ON;;;;;N;;;;;
31F0;KATAKANA LETTER SMALL KU;Lo;0;L;;;;;N;;;;;
31F1;KATAKANA LETTER SMALL SI;Lo;0;L;;;;;N;;;;;
31F2;KATAKANA LETTER SMALL SU;Lo;0;L;;;;;N;;;;;
@@ -34035,6 +34040,8 @@ FFFD;REPLACEMENT CHARACTER;So;0;ON;;;;;N;;;;;
2CEA1;<CJK Ideograph Extension E, Last>;Lo;0;L;;;;;N;;;;;
2CEB0;<CJK Ideograph Extension F, First>;Lo;0;L;;;;;N;;;;;
2EBE0;<CJK Ideograph Extension F, Last>;Lo;0;L;;;;;N;;;;;
+2EBF0;<CJK Ideograph Extension I, First>;Lo;0;L;;;;;N;;;;;
+2EE5D;<CJK Ideograph Extension I, Last>;Lo;0;L;;;;;N;;;;;
2F800;CJK COMPATIBILITY IDEOGRAPH-2F800;Lo;0;L;4E3D;;;;N;;;;;
2F801;CJK COMPATIBILITY IDEOGRAPH-2F801;Lo;0;L;4E38;;;;N;;;;;
2F802;CJK COMPATIBILITY IDEOGRAPH-2F802;Lo;0;L;4E41;;;;N;;;;;
diff --git a/admin/unidata/confusables.txt b/admin/unidata/confusables.txt
index 24b61d519af..5e056ed5a35 100644
--- a/admin/unidata/confusables.txt
+++ b/admin/unidata/confusables.txt
@@ -1,11 +1,11 @@
# confusables.txt
-# Date: 2022-08-26, 16:49:08 GMT
-# © 2022 Unicode®, Inc.
+# Date: 2023-08-11, 17:46:40 GMT
+# © 2023 Unicode®, Inc.
# Unicode and the Unicode Logo are registered trademarks of Unicode, Inc. in the U.S. and other countries.
# For terms of use, see https://www.unicode.org/terms_of_use.html
#
# Unicode Security Mechanisms for UTS #39
-# Version: 15.0.0
+# Version: 15.1.0
#
# For documentation and usage, see https://www.unicode.org/reports/tr39
#
@@ -349,8 +349,8 @@ A4FA ; 002E 002E ; MA # ( ꓺ → .. ) LISU LETTER TONE MYA CYA → FULL STOP, F
A6F4 ; A6F3 A6F3 ; MA #* ( ꛴ → ꛳꛳ ) BAMUM COLON → BAMUM FULL STOP, BAMUM FULL STOP #
-30FB ; 00B7 ; MA #* ( ・ → · ) KATAKANA MIDDLE DOT → MIDDLE DOT # →•→
-FF65 ; 00B7 ; MA #* ( ・ → · ) HALFWIDTH KATAKANA MIDDLE DOT → MIDDLE DOT # →•→
+30FB ; 00B7 ; MA # ( ・ → · ) KATAKANA MIDDLE DOT → MIDDLE DOT # →•→
+FF65 ; 00B7 ; MA # ( ・ → · ) HALFWIDTH KATAKANA MIDDLE DOT → MIDDLE DOT # →•→
16EB ; 00B7 ; MA #* ( ᛫ → · ) RUNIC SINGLE PUNCTUATION → MIDDLE DOT #
0387 ; 00B7 ; MA # ( · → · ) GREEK ANO TELEIA → MIDDLE DOT #
2E31 ; 00B7 ; MA #* ( ⸱ → · ) WORD SEPARATOR MIDDLE DOT → MIDDLE DOT #
diff --git a/admin/unidata/copyright.html b/admin/unidata/copyright.html
index 567c54e72ac..fe6dd16903e 100644
--- a/admin/unidata/copyright.html
+++ b/admin/unidata/copyright.html
@@ -13,7 +13,7 @@
<title>Unicode Terms of Use</title>
<link rel="stylesheet" type="text/css"
-href="https://www.unicode.org/webscripts/standard_styles.css">
+href="http://www.unicode.org/webscripts/standard_styles.css">
<style type="text/css">
pre {
@@ -32,8 +32,8 @@ pre {
<td colspan="2">
<table width="100%" border="0" cellpadding="0" cellspacing="0">
<tr>
- <td class="icon" style="width:38px; height:35px"><a href="https://www.unicode.org/"><img border="0"
- src="https://www.unicode.org/webscripts/logo60s2.gif" align="middle" alt="[Unicode]" width="34" height="33"></a></td>
+ <td class="icon" style="width:38px; height:35px"><a href="http://www.unicode.org/"><img border="0"
+ src="http://www.unicode.org/webscripts/logo60s2.gif" align="middle" alt="[Unicode]" width="34" height="33"></a></td>
<td class="icon" style="vertical-align:middle;"> &nbsp;<a class="bar"
href="https://www.unicode.org/copyright.html"><font size="3">Terms of Use</font></a></td>
<td class="bar"><a href="https://www.unicode.org/main.html" class="bar">Tech Site</a>
@@ -112,13 +112,13 @@ pre {
<p>For the general privacy policy governing access to this site, see
the&nbsp;
- <a href="https://www.unicode.org/policies/privacy_policy.html">
+ <a href="http://www.unicode.org/policies/privacy_policy.html">
Unicode Privacy Policy</a>.</p>
<ol type="A">
<li><u><a name="1"></a>Unicode Copyright</u>
<ol>
- <li>Copyright © 1991-2022 Unicode, Inc. All rights reserved.</li>
+ <li>Copyright © 1991-2023 Unicode, Inc. All rights reserved.</li>
</ol>
</li>
@@ -158,7 +158,7 @@ http://site.icu-project.org/download/
specifications of rights and restrictions of use. For the book
editions (Unicode 5.0 and earlier), these are found on the back
of the
- <a href="https://www.unicode.org/versions/Unicode5.0.0/Title.pdf">title page</a>.</li>
+ <a href="http://www.unicode.org/versions/Unicode5.0.0/Title.pdf">title page</a>.</li>
<li>
The Unicode PDF <a href="https://www.unicode.org/charts/">online code charts</a> carry specific restrictions. Those restrictions are incorporated as the
first page of each PDF code chart.</li>
@@ -224,7 +224,7 @@ http://site.icu-project.org/download/
<li><u><a name="5"></a>Trademarks &amp; Logos</u>
<ol>
<li>The Unicode Word Mark and the Unicode Logo are trademarks of Unicode, Inc. “The Unicode Consortium” and “Unicode, Inc.” are trade names of Unicode, Inc. Use of the information and materials found on this website indicates your acknowledgement of Unicode, Inc.’s exclusive worldwide rights in the Unicode Word Mark, the Unicode Logo, and the Unicode trade names.</li>
-<li><a href="https://www.unicode.org/policies/logo_policy.html">The Unicode Consortium Name and Trademark Usage Policy</a> (“Trademark Policy”) are incorporated herein by reference and you agree to abide by the provisions of the Trademark Policy, which may be changed from time to time in the sole discretion of Unicode, Inc.</li>
+<li><a href="http://www.unicode.org/policies/logo_policy.html">The Unicode Consortium Name and Trademark Usage Policy</a> (“Trademark Policy”) are incorporated herein by reference and you agree to abide by the provisions of the Trademark Policy, which may be changed from time to time in the sole discretion of Unicode, Inc.</li>
<li>All third party trademarks referenced herein are the property of their respective owners.</li>
</ol>
</li>
@@ -270,15 +270,15 @@ http://site.icu-project.org/download/
<center>
<table cellspacing="0" cellpadding="0" border="0" id="table2">
<tr>
- <td><a href="https://www.unicode.org/copyright.html">
- <img src="https://www.unicode.org/img/hb_notice.gif"
+ <td><a href="http://www.unicode.org/copyright.html">
+ <img src="http://www.unicode.org/img/hb_notice.gif"
border="0" alt="Access to Copyright and terms of use"
width="216" height="50"></a></td>
</tr>
</table>
<script language="Javascript" type="text/javascript"
- src="https://www.unicode.org/webscripts/lastModified.js">
+ src="http://www.unicode.org/webscripts/lastModified.js">
</script>
</center>
diff --git a/admin/unidata/emoji-data.txt b/admin/unidata/emoji-data.txt
index 7942fc89a35..ab9c04ff056 100644
--- a/admin/unidata/emoji-data.txt
+++ b/admin/unidata/emoji-data.txt
@@ -1,11 +1,11 @@
# emoji-data.txt
-# Date: 2022-08-02, 00:26:10 GMT
-# © 2022 Unicode®, Inc.
+# Date: 2023-02-01, 02:22:54 GMT
+# © 2023 Unicode®, Inc.
# Unicode and the Unicode Logo are registered trademarks of Unicode, Inc. in the U.S. and other countries.
# For terms of use, see https://www.unicode.org/terms_of_use.html
#
# Emoji Data for UTS #51
-# Used with Emoji Version 15.0 and subsequent minor revisions (if any)
+# Used with Emoji Version 15.1 and subsequent minor revisions (if any)
#
# For documentation and usage, see https://www.unicode.org/reports/tr51
#
diff --git a/admin/unidata/emoji-sequences.txt b/admin/unidata/emoji-sequences.txt
index ffd40668117..dfeae158edb 100644
--- a/admin/unidata/emoji-sequences.txt
+++ b/admin/unidata/emoji-sequences.txt
@@ -1,11 +1,11 @@
# emoji-sequences.txt
-# Date: 2022-08-15, 23:13:41 GMT
-# © 2022 Unicode®, Inc.
+# Date: 2023-06-05, 21:39:54 GMT
+# © 2023 Unicode®, Inc.
# Unicode and the Unicode Logo are registered trademarks of Unicode, Inc. in the U.S. and other countries.
# For terms of use, see https://www.unicode.org/terms_of_use.html
#
# Emoji Sequence Data for UTS #51
-# Version: 15.0
+# Version: 15.1
#
# For documentation and usage, see https://www.unicode.org/reports/tr51
#
@@ -38,7 +38,6 @@
# Basic_Emoji
-
231A..231B ; Basic_Emoji ; watch..hourglass done # E0.6 [2] (⌚..⌛)
23E9..23EC ; Basic_Emoji ; fast-forward button..fast down button # E0.6 [4] (⏩..⏬)
23F0 ; Basic_Emoji ; alarm clock # E0.6 [1] (⏰)
@@ -534,7 +533,6 @@
# Emoji_Keycap_Sequence
-
0023 FE0F 20E3; Emoji_Keycap_Sequence ; keycap: \x{23} # E0.6 [1] (#️⃣)
002A FE0F 20E3; Emoji_Keycap_Sequence ; keycap: * # E2.0 [1] (*️⃣)
0030 FE0F 20E3; Emoji_Keycap_Sequence ; keycap: 0 # E0.6 [1] (0️⃣)
@@ -553,8 +551,7 @@
# ================================================
# RGI_Emoji_Flag_Sequence: This list does not include deprecated or macroregion flags, except for UN and EU.
-# See Annex B of TR51 for more information.
-
+# See Annex B of UTS #51 for more information.
1F1E6 1F1E8 ; RGI_Emoji_Flag_Sequence ; flag: Ascension Island # E2.0 [1] (🇦🇨)
1F1E6 1F1E9 ; RGI_Emoji_Flag_Sequence ; flag: Andorra # E2.0 [1] (🇦🇩)
@@ -787,7 +784,7 @@
1F1F9 1F1F2 ; RGI_Emoji_Flag_Sequence ; flag: Turkmenistan # E2.0 [1] (🇹🇲)
1F1F9 1F1F3 ; RGI_Emoji_Flag_Sequence ; flag: Tunisia # E2.0 [1] (🇹🇳)
1F1F9 1F1F4 ; RGI_Emoji_Flag_Sequence ; flag: Tonga # E2.0 [1] (🇹🇴)
-1F1F9 1F1F7 ; RGI_Emoji_Flag_Sequence ; flag: Turkey # E2.0 [1] (🇹🇷)
+1F1F9 1F1F7 ; RGI_Emoji_Flag_Sequence ; flag: Türkiye # E2.0 [1] (🇹🇷)
1F1F9 1F1F9 ; RGI_Emoji_Flag_Sequence ; flag: Trinidad & Tobago # E2.0 [1] (🇹🇹)
1F1F9 1F1FB ; RGI_Emoji_Flag_Sequence ; flag: Tuvalu # E2.0 [1] (🇹🇻)
1F1F9 1F1FC ; RGI_Emoji_Flag_Sequence ; flag: Taiwan # E2.0 [1] (🇹🇼)
@@ -819,8 +816,7 @@
# ================================================
-# RGI_Emoji_Tag_Sequence: See Annex C of TR51 for more information.
-
+# RGI_Emoji_Tag_Sequence: See Annex C of UTS #51 for more information.
1F3F4 E0067 E0062 E0065 E006E E0067 E007F; RGI_Emoji_Tag_Sequence; flag: England # E5.0 [1] (🏴󠁧󠁢󠁥󠁮󠁧󠁿)
1F3F4 E0067 E0062 E0073 E0063 E0074 E007F; RGI_Emoji_Tag_Sequence; flag: Scotland # E5.0 [1] (🏴󠁧󠁢󠁳󠁣󠁴󠁿)
@@ -832,7 +828,6 @@
# RGI_Emoji_Modifier_Sequence
-
261D 1F3FB ; RGI_Emoji_Modifier_Sequence ; index pointing up: light skin tone # E1.0 [1] (☝🏻)
261D 1F3FC ; RGI_Emoji_Modifier_Sequence ; index pointing up: medium-light skin tone # E1.0 [1] (☝🏼)
261D 1F3FD ; RGI_Emoji_Modifier_Sequence ; index pointing up: medium skin tone # E1.0 [1] (☝🏽)
diff --git a/admin/unidata/emoji-test.txt b/admin/unidata/emoji-test.txt
index bc8b52c2fb4..1f50b23fa24 100644
--- a/admin/unidata/emoji-test.txt
+++ b/admin/unidata/emoji-test.txt
@@ -1,11 +1,11 @@
# emoji-test.txt
-# Date: 2022-08-12, 20:24:39 GMT
-# © 2022 Unicode®, Inc.
+# Date: 2023-06-05, 21:39:54 GMT
+# © 2023 Unicode®, Inc.
# Unicode and the Unicode Logo are registered trademarks of Unicode, Inc. in the U.S. and other countries.
# For terms of use, see https://www.unicode.org/terms_of_use.html
#
# Emoji Keyboard/Display Test Data for UTS #51
-# Version: 15.0
+# Version: 15.1
#
# For documentation and usage, see https://www.unicode.org/reports/tr51
#
@@ -93,6 +93,10 @@
1F62E 200D 1F4A8 ; fully-qualified # 😮‍💨 E13.1 face exhaling
1F925 ; fully-qualified # 🤥 E3.0 lying face
1FAE8 ; fully-qualified # 🫨 E15.0 shaking face
+1F642 200D 2194 FE0F ; fully-qualified # 🙂‍↔️ E15.1 head shaking horizontally
+1F642 200D 2194 ; minimally-qualified # 🙂‍↔ E15.1 head shaking horizontally
+1F642 200D 2195 FE0F ; fully-qualified # 🙂‍↕️ E15.1 head shaking vertically
+1F642 200D 2195 ; minimally-qualified # 🙂‍↕ E15.1 head shaking vertically
# subgroup: face-sleepy
1F60C ; fully-qualified # 😌 E0.6 relieved face
@@ -244,8 +248,8 @@
1F4AD ; fully-qualified # 💭 E1.0 thought balloon
1F4A4 ; fully-qualified # 💤 E0.6 ZZZ
-# Smileys & Emotion subtotal: 180
-# Smileys & Emotion subtotal: 180 w/o modifiers
+# Smileys & Emotion subtotal: 184
+# Smileys & Emotion subtotal: 184 w/o modifiers
# group: People & Body
@@ -2065,6 +2069,66 @@
1F6B6 1F3FE 200D 2640 ; minimally-qualified # 🚶🏾‍♀ E4.0 woman walking: medium-dark skin tone
1F6B6 1F3FF 200D 2640 FE0F ; fully-qualified # 🚶🏿‍♀️ E4.0 woman walking: dark skin tone
1F6B6 1F3FF 200D 2640 ; minimally-qualified # 🚶🏿‍♀ E4.0 woman walking: dark skin tone
+1F6B6 200D 27A1 FE0F ; fully-qualified # 🚶‍➡️ E15.1 person walking facing right
+1F6B6 200D 27A1 ; minimally-qualified # 🚶‍➡ E15.1 person walking facing right
+1F6B6 1F3FB 200D 27A1 FE0F ; fully-qualified # 🚶🏻‍➡️ E15.1 person walking facing right: light skin tone
+1F6B6 1F3FB 200D 27A1 ; minimally-qualified # 🚶🏻‍➡ E15.1 person walking facing right: light skin tone
+1F6B6 1F3FC 200D 27A1 FE0F ; fully-qualified # 🚶🏼‍➡️ E15.1 person walking facing right: medium-light skin tone
+1F6B6 1F3FC 200D 27A1 ; minimally-qualified # 🚶🏼‍➡ E15.1 person walking facing right: medium-light skin tone
+1F6B6 1F3FD 200D 27A1 FE0F ; fully-qualified # 🚶🏽‍➡️ E15.1 person walking facing right: medium skin tone
+1F6B6 1F3FD 200D 27A1 ; minimally-qualified # 🚶🏽‍➡ E15.1 person walking facing right: medium skin tone
+1F6B6 1F3FE 200D 27A1 FE0F ; fully-qualified # 🚶🏾‍➡️ E15.1 person walking facing right: medium-dark skin tone
+1F6B6 1F3FE 200D 27A1 ; minimally-qualified # 🚶🏾‍➡ E15.1 person walking facing right: medium-dark skin tone
+1F6B6 1F3FF 200D 27A1 FE0F ; fully-qualified # 🚶🏿‍➡️ E15.1 person walking facing right: dark skin tone
+1F6B6 1F3FF 200D 27A1 ; minimally-qualified # 🚶🏿‍➡ E15.1 person walking facing right: dark skin tone
+1F6B6 200D 2640 FE0F 200D 27A1 FE0F ; fully-qualified # 🚶‍♀️‍➡️ E15.1 woman walking facing right
+1F6B6 200D 2640 200D 27A1 FE0F ; minimally-qualified # 🚶‍♀‍➡️ E15.1 woman walking facing right
+1F6B6 200D 2640 FE0F 200D 27A1 ; minimally-qualified # 🚶‍♀️‍➡ E15.1 woman walking facing right
+1F6B6 200D 2640 200D 27A1 ; minimally-qualified # 🚶‍♀‍➡ E15.1 woman walking facing right
+1F6B6 1F3FB 200D 2640 FE0F 200D 27A1 FE0F ; fully-qualified # 🚶🏻‍♀️‍➡️ E15.1 woman walking facing right: light skin tone
+1F6B6 1F3FB 200D 2640 200D 27A1 FE0F ; minimally-qualified # 🚶🏻‍♀‍➡️ E15.1 woman walking facing right: light skin tone
+1F6B6 1F3FB 200D 2640 FE0F 200D 27A1 ; minimally-qualified # 🚶🏻‍♀️‍➡ E15.1 woman walking facing right: light skin tone
+1F6B6 1F3FB 200D 2640 200D 27A1 ; minimally-qualified # 🚶🏻‍♀‍➡ E15.1 woman walking facing right: light skin tone
+1F6B6 1F3FC 200D 2640 FE0F 200D 27A1 FE0F ; fully-qualified # 🚶🏼‍♀️‍➡️ E15.1 woman walking facing right: medium-light skin tone
+1F6B6 1F3FC 200D 2640 200D 27A1 FE0F ; minimally-qualified # 🚶🏼‍♀‍➡️ E15.1 woman walking facing right: medium-light skin tone
+1F6B6 1F3FC 200D 2640 FE0F 200D 27A1 ; minimally-qualified # 🚶🏼‍♀️‍➡ E15.1 woman walking facing right: medium-light skin tone
+1F6B6 1F3FC 200D 2640 200D 27A1 ; minimally-qualified # 🚶🏼‍♀‍➡ E15.1 woman walking facing right: medium-light skin tone
+1F6B6 1F3FD 200D 2640 FE0F 200D 27A1 FE0F ; fully-qualified # 🚶🏽‍♀️‍➡️ E15.1 woman walking facing right: medium skin tone
+1F6B6 1F3FD 200D 2640 200D 27A1 FE0F ; minimally-qualified # 🚶🏽‍♀‍➡️ E15.1 woman walking facing right: medium skin tone
+1F6B6 1F3FD 200D 2640 FE0F 200D 27A1 ; minimally-qualified # 🚶🏽‍♀️‍➡ E15.1 woman walking facing right: medium skin tone
+1F6B6 1F3FD 200D 2640 200D 27A1 ; minimally-qualified # 🚶🏽‍♀‍➡ E15.1 woman walking facing right: medium skin tone
+1F6B6 1F3FE 200D 2640 FE0F 200D 27A1 FE0F ; fully-qualified # 🚶🏾‍♀️‍➡️ E15.1 woman walking facing right: medium-dark skin tone
+1F6B6 1F3FE 200D 2640 200D 27A1 FE0F ; minimally-qualified # 🚶🏾‍♀‍➡️ E15.1 woman walking facing right: medium-dark skin tone
+1F6B6 1F3FE 200D 2640 FE0F 200D 27A1 ; minimally-qualified # 🚶🏾‍♀️‍➡ E15.1 woman walking facing right: medium-dark skin tone
+1F6B6 1F3FE 200D 2640 200D 27A1 ; minimally-qualified # 🚶🏾‍♀‍➡ E15.1 woman walking facing right: medium-dark skin tone
+1F6B6 1F3FF 200D 2640 FE0F 200D 27A1 FE0F ; fully-qualified # 🚶🏿‍♀️‍➡️ E15.1 woman walking facing right: dark skin tone
+1F6B6 1F3FF 200D 2640 200D 27A1 FE0F ; minimally-qualified # 🚶🏿‍♀‍➡️ E15.1 woman walking facing right: dark skin tone
+1F6B6 1F3FF 200D 2640 FE0F 200D 27A1 ; minimally-qualified # 🚶🏿‍♀️‍➡ E15.1 woman walking facing right: dark skin tone
+1F6B6 1F3FF 200D 2640 200D 27A1 ; minimally-qualified # 🚶🏿‍♀‍➡ E15.1 woman walking facing right: dark skin tone
+1F6B6 200D 2642 FE0F 200D 27A1 FE0F ; fully-qualified # 🚶‍♂️‍➡️ E15.1 man walking facing right
+1F6B6 200D 2642 200D 27A1 FE0F ; minimally-qualified # 🚶‍♂‍➡️ E15.1 man walking facing right
+1F6B6 200D 2642 FE0F 200D 27A1 ; minimally-qualified # 🚶‍♂️‍➡ E15.1 man walking facing right
+1F6B6 200D 2642 200D 27A1 ; minimally-qualified # 🚶‍♂‍➡ E15.1 man walking facing right
+1F6B6 1F3FB 200D 2642 FE0F 200D 27A1 FE0F ; fully-qualified # 🚶🏻‍♂️‍➡️ E15.1 man walking facing right: light skin tone
+1F6B6 1F3FB 200D 2642 200D 27A1 FE0F ; minimally-qualified # 🚶🏻‍♂‍➡️ E15.1 man walking facing right: light skin tone
+1F6B6 1F3FB 200D 2642 FE0F 200D 27A1 ; minimally-qualified # 🚶🏻‍♂️‍➡ E15.1 man walking facing right: light skin tone
+1F6B6 1F3FB 200D 2642 200D 27A1 ; minimally-qualified # 🚶🏻‍♂‍➡ E15.1 man walking facing right: light skin tone
+1F6B6 1F3FC 200D 2642 FE0F 200D 27A1 FE0F ; fully-qualified # 🚶🏼‍♂️‍➡️ E15.1 man walking facing right: medium-light skin tone
+1F6B6 1F3FC 200D 2642 200D 27A1 FE0F ; minimally-qualified # 🚶🏼‍♂‍➡️ E15.1 man walking facing right: medium-light skin tone
+1F6B6 1F3FC 200D 2642 FE0F 200D 27A1 ; minimally-qualified # 🚶🏼‍♂️‍➡ E15.1 man walking facing right: medium-light skin tone
+1F6B6 1F3FC 200D 2642 200D 27A1 ; minimally-qualified # 🚶🏼‍♂‍➡ E15.1 man walking facing right: medium-light skin tone
+1F6B6 1F3FD 200D 2642 FE0F 200D 27A1 FE0F ; fully-qualified # 🚶🏽‍♂️‍➡️ E15.1 man walking facing right: medium skin tone
+1F6B6 1F3FD 200D 2642 200D 27A1 FE0F ; minimally-qualified # 🚶🏽‍♂‍➡️ E15.1 man walking facing right: medium skin tone
+1F6B6 1F3FD 200D 2642 FE0F 200D 27A1 ; minimally-qualified # 🚶🏽‍♂️‍➡ E15.1 man walking facing right: medium skin tone
+1F6B6 1F3FD 200D 2642 200D 27A1 ; minimally-qualified # 🚶🏽‍♂‍➡ E15.1 man walking facing right: medium skin tone
+1F6B6 1F3FE 200D 2642 FE0F 200D 27A1 FE0F ; fully-qualified # 🚶🏾‍♂️‍➡️ E15.1 man walking facing right: medium-dark skin tone
+1F6B6 1F3FE 200D 2642 200D 27A1 FE0F ; minimally-qualified # 🚶🏾‍♂‍➡️ E15.1 man walking facing right: medium-dark skin tone
+1F6B6 1F3FE 200D 2642 FE0F 200D 27A1 ; minimally-qualified # 🚶🏾‍♂️‍➡ E15.1 man walking facing right: medium-dark skin tone
+1F6B6 1F3FE 200D 2642 200D 27A1 ; minimally-qualified # 🚶🏾‍♂‍➡ E15.1 man walking facing right: medium-dark skin tone
+1F6B6 1F3FF 200D 2642 FE0F 200D 27A1 FE0F ; fully-qualified # 🚶🏿‍♂️‍➡️ E15.1 man walking facing right: dark skin tone
+1F6B6 1F3FF 200D 2642 200D 27A1 FE0F ; minimally-qualified # 🚶🏿‍♂‍➡️ E15.1 man walking facing right: dark skin tone
+1F6B6 1F3FF 200D 2642 FE0F 200D 27A1 ; minimally-qualified # 🚶🏿‍♂️‍➡ E15.1 man walking facing right: dark skin tone
+1F6B6 1F3FF 200D 2642 200D 27A1 ; minimally-qualified # 🚶🏿‍♂‍➡ E15.1 man walking facing right: dark skin tone
1F9CD ; fully-qualified # 🧍 E12.0 person standing
1F9CD 1F3FB ; fully-qualified # 🧍🏻 E12.0 person standing: light skin tone
1F9CD 1F3FC ; fully-qualified # 🧍🏼 E12.0 person standing: medium-light skin tone
@@ -2125,60 +2189,228 @@
1F9CE 1F3FE 200D 2640 ; minimally-qualified # 🧎🏾‍♀ E12.0 woman kneeling: medium-dark skin tone
1F9CE 1F3FF 200D 2640 FE0F ; fully-qualified # 🧎🏿‍♀️ E12.0 woman kneeling: dark skin tone
1F9CE 1F3FF 200D 2640 ; minimally-qualified # 🧎🏿‍♀ E12.0 woman kneeling: dark skin tone
+1F9CE 200D 27A1 FE0F ; fully-qualified # 🧎‍➡️ E15.1 person kneeling facing right
+1F9CE 200D 27A1 ; minimally-qualified # 🧎‍➡ E15.1 person kneeling facing right
+1F9CE 1F3FB 200D 27A1 FE0F ; fully-qualified # 🧎🏻‍➡️ E15.1 person kneeling facing right: light skin tone
+1F9CE 1F3FB 200D 27A1 ; minimally-qualified # 🧎🏻‍➡ E15.1 person kneeling facing right: light skin tone
+1F9CE 1F3FC 200D 27A1 FE0F ; fully-qualified # 🧎🏼‍➡️ E15.1 person kneeling facing right: medium-light skin tone
+1F9CE 1F3FC 200D 27A1 ; minimally-qualified # 🧎🏼‍➡ E15.1 person kneeling facing right: medium-light skin tone
+1F9CE 1F3FD 200D 27A1 FE0F ; fully-qualified # 🧎🏽‍➡️ E15.1 person kneeling facing right: medium skin tone
+1F9CE 1F3FD 200D 27A1 ; minimally-qualified # 🧎🏽‍➡ E15.1 person kneeling facing right: medium skin tone
+1F9CE 1F3FE 200D 27A1 FE0F ; fully-qualified # 🧎🏾‍➡️ E15.1 person kneeling facing right: medium-dark skin tone
+1F9CE 1F3FE 200D 27A1 ; minimally-qualified # 🧎🏾‍➡ E15.1 person kneeling facing right: medium-dark skin tone
+1F9CE 1F3FF 200D 27A1 FE0F ; fully-qualified # 🧎🏿‍➡️ E15.1 person kneeling facing right: dark skin tone
+1F9CE 1F3FF 200D 27A1 ; minimally-qualified # 🧎🏿‍➡ E15.1 person kneeling facing right: dark skin tone
+1F9CE 200D 2640 FE0F 200D 27A1 FE0F ; fully-qualified # 🧎‍♀️‍➡️ E15.1 woman kneeling facing right
+1F9CE 200D 2640 200D 27A1 FE0F ; minimally-qualified # 🧎‍♀‍➡️ E15.1 woman kneeling facing right
+1F9CE 200D 2640 FE0F 200D 27A1 ; minimally-qualified # 🧎‍♀️‍➡ E15.1 woman kneeling facing right
+1F9CE 200D 2640 200D 27A1 ; minimally-qualified # 🧎‍♀‍➡ E15.1 woman kneeling facing right
+1F9CE 1F3FB 200D 2640 FE0F 200D 27A1 FE0F ; fully-qualified # 🧎🏻‍♀️‍➡️ E15.1 woman kneeling facing right: light skin tone
+1F9CE 1F3FB 200D 2640 200D 27A1 FE0F ; minimally-qualified # 🧎🏻‍♀‍➡️ E15.1 woman kneeling facing right: light skin tone
+1F9CE 1F3FB 200D 2640 FE0F 200D 27A1 ; minimally-qualified # 🧎🏻‍♀️‍➡ E15.1 woman kneeling facing right: light skin tone
+1F9CE 1F3FB 200D 2640 200D 27A1 ; minimally-qualified # 🧎🏻‍♀‍➡ E15.1 woman kneeling facing right: light skin tone
+1F9CE 1F3FC 200D 2640 FE0F 200D 27A1 FE0F ; fully-qualified # 🧎🏼‍♀️‍➡️ E15.1 woman kneeling facing right: medium-light skin tone
+1F9CE 1F3FC 200D 2640 200D 27A1 FE0F ; minimally-qualified # 🧎🏼‍♀‍➡️ E15.1 woman kneeling facing right: medium-light skin tone
+1F9CE 1F3FC 200D 2640 FE0F 200D 27A1 ; minimally-qualified # 🧎🏼‍♀️‍➡ E15.1 woman kneeling facing right: medium-light skin tone
+1F9CE 1F3FC 200D 2640 200D 27A1 ; minimally-qualified # 🧎🏼‍♀‍➡ E15.1 woman kneeling facing right: medium-light skin tone
+1F9CE 1F3FD 200D 2640 FE0F 200D 27A1 FE0F ; fully-qualified # 🧎🏽‍♀️‍➡️ E15.1 woman kneeling facing right: medium skin tone
+1F9CE 1F3FD 200D 2640 200D 27A1 FE0F ; minimally-qualified # 🧎🏽‍♀‍➡️ E15.1 woman kneeling facing right: medium skin tone
+1F9CE 1F3FD 200D 2640 FE0F 200D 27A1 ; minimally-qualified # 🧎🏽‍♀️‍➡ E15.1 woman kneeling facing right: medium skin tone
+1F9CE 1F3FD 200D 2640 200D 27A1 ; minimally-qualified # 🧎🏽‍♀‍➡ E15.1 woman kneeling facing right: medium skin tone
+1F9CE 1F3FE 200D 2640 FE0F 200D 27A1 FE0F ; fully-qualified # 🧎🏾‍♀️‍➡️ E15.1 woman kneeling facing right: medium-dark skin tone
+1F9CE 1F3FE 200D 2640 200D 27A1 FE0F ; minimally-qualified # 🧎🏾‍♀‍➡️ E15.1 woman kneeling facing right: medium-dark skin tone
+1F9CE 1F3FE 200D 2640 FE0F 200D 27A1 ; minimally-qualified # 🧎🏾‍♀️‍➡ E15.1 woman kneeling facing right: medium-dark skin tone
+1F9CE 1F3FE 200D 2640 200D 27A1 ; minimally-qualified # 🧎🏾‍♀‍➡ E15.1 woman kneeling facing right: medium-dark skin tone
+1F9CE 1F3FF 200D 2640 FE0F 200D 27A1 FE0F ; fully-qualified # 🧎🏿‍♀️‍➡️ E15.1 woman kneeling facing right: dark skin tone
+1F9CE 1F3FF 200D 2640 200D 27A1 FE0F ; minimally-qualified # 🧎🏿‍♀‍➡️ E15.1 woman kneeling facing right: dark skin tone
+1F9CE 1F3FF 200D 2640 FE0F 200D 27A1 ; minimally-qualified # 🧎🏿‍♀️‍➡ E15.1 woman kneeling facing right: dark skin tone
+1F9CE 1F3FF 200D 2640 200D 27A1 ; minimally-qualified # 🧎🏿‍♀‍➡ E15.1 woman kneeling facing right: dark skin tone
+1F9CE 200D 2642 FE0F 200D 27A1 FE0F ; fully-qualified # 🧎‍♂️‍➡️ E15.1 man kneeling facing right
+1F9CE 200D 2642 200D 27A1 FE0F ; minimally-qualified # 🧎‍♂‍➡️ E15.1 man kneeling facing right
+1F9CE 200D 2642 FE0F 200D 27A1 ; minimally-qualified # 🧎‍♂️‍➡ E15.1 man kneeling facing right
+1F9CE 200D 2642 200D 27A1 ; minimally-qualified # 🧎‍♂‍➡ E15.1 man kneeling facing right
+1F9CE 1F3FB 200D 2642 FE0F 200D 27A1 FE0F ; fully-qualified # 🧎🏻‍♂️‍➡️ E15.1 man kneeling facing right: light skin tone
+1F9CE 1F3FB 200D 2642 200D 27A1 FE0F ; minimally-qualified # 🧎🏻‍♂‍➡️ E15.1 man kneeling facing right: light skin tone
+1F9CE 1F3FB 200D 2642 FE0F 200D 27A1 ; minimally-qualified # 🧎🏻‍♂️‍➡ E15.1 man kneeling facing right: light skin tone
+1F9CE 1F3FB 200D 2642 200D 27A1 ; minimally-qualified # 🧎🏻‍♂‍➡ E15.1 man kneeling facing right: light skin tone
+1F9CE 1F3FC 200D 2642 FE0F 200D 27A1 FE0F ; fully-qualified # 🧎🏼‍♂️‍➡️ E15.1 man kneeling facing right: medium-light skin tone
+1F9CE 1F3FC 200D 2642 200D 27A1 FE0F ; minimally-qualified # 🧎🏼‍♂‍➡️ E15.1 man kneeling facing right: medium-light skin tone
+1F9CE 1F3FC 200D 2642 FE0F 200D 27A1 ; minimally-qualified # 🧎🏼‍♂️‍➡ E15.1 man kneeling facing right: medium-light skin tone
+1F9CE 1F3FC 200D 2642 200D 27A1 ; minimally-qualified # 🧎🏼‍♂‍➡ E15.1 man kneeling facing right: medium-light skin tone
+1F9CE 1F3FD 200D 2642 FE0F 200D 27A1 FE0F ; fully-qualified # 🧎🏽‍♂️‍➡️ E15.1 man kneeling facing right: medium skin tone
+1F9CE 1F3FD 200D 2642 200D 27A1 FE0F ; minimally-qualified # 🧎🏽‍♂‍➡️ E15.1 man kneeling facing right: medium skin tone
+1F9CE 1F3FD 200D 2642 FE0F 200D 27A1 ; minimally-qualified # 🧎🏽‍♂️‍➡ E15.1 man kneeling facing right: medium skin tone
+1F9CE 1F3FD 200D 2642 200D 27A1 ; minimally-qualified # 🧎🏽‍♂‍➡ E15.1 man kneeling facing right: medium skin tone
+1F9CE 1F3FE 200D 2642 FE0F 200D 27A1 FE0F ; fully-qualified # 🧎🏾‍♂️‍➡️ E15.1 man kneeling facing right: medium-dark skin tone
+1F9CE 1F3FE 200D 2642 200D 27A1 FE0F ; minimally-qualified # 🧎🏾‍♂‍➡️ E15.1 man kneeling facing right: medium-dark skin tone
+1F9CE 1F3FE 200D 2642 FE0F 200D 27A1 ; minimally-qualified # 🧎🏾‍♂️‍➡ E15.1 man kneeling facing right: medium-dark skin tone
+1F9CE 1F3FE 200D 2642 200D 27A1 ; minimally-qualified # 🧎🏾‍♂‍➡ E15.1 man kneeling facing right: medium-dark skin tone
+1F9CE 1F3FF 200D 2642 FE0F 200D 27A1 FE0F ; fully-qualified # 🧎🏿‍♂️‍➡️ E15.1 man kneeling facing right: dark skin tone
+1F9CE 1F3FF 200D 2642 200D 27A1 FE0F ; minimally-qualified # 🧎🏿‍♂‍➡️ E15.1 man kneeling facing right: dark skin tone
+1F9CE 1F3FF 200D 2642 FE0F 200D 27A1 ; minimally-qualified # 🧎🏿‍♂️‍➡ E15.1 man kneeling facing right: dark skin tone
+1F9CE 1F3FF 200D 2642 200D 27A1 ; minimally-qualified # 🧎🏿‍♂‍➡ E15.1 man kneeling facing right: dark skin tone
1F9D1 200D 1F9AF ; fully-qualified # 🧑‍🦯 E12.1 person with white cane
1F9D1 1F3FB 200D 1F9AF ; fully-qualified # 🧑🏻‍🦯 E12.1 person with white cane: light skin tone
1F9D1 1F3FC 200D 1F9AF ; fully-qualified # 🧑🏼‍🦯 E12.1 person with white cane: medium-light skin tone
1F9D1 1F3FD 200D 1F9AF ; fully-qualified # 🧑🏽‍🦯 E12.1 person with white cane: medium skin tone
1F9D1 1F3FE 200D 1F9AF ; fully-qualified # 🧑🏾‍🦯 E12.1 person with white cane: medium-dark skin tone
1F9D1 1F3FF 200D 1F9AF ; fully-qualified # 🧑🏿‍🦯 E12.1 person with white cane: dark skin tone
+1F9D1 200D 1F9AF 200D 27A1 FE0F ; fully-qualified # 🧑‍🦯‍➡️ E15.1 person with white cane facing right
+1F9D1 200D 1F9AF 200D 27A1 ; minimally-qualified # 🧑‍🦯‍➡ E15.1 person with white cane facing right
+1F9D1 1F3FB 200D 1F9AF 200D 27A1 FE0F ; fully-qualified # 🧑🏻‍🦯‍➡️ E15.1 person with white cane facing right: light skin tone
+1F9D1 1F3FB 200D 1F9AF 200D 27A1 ; minimally-qualified # 🧑🏻‍🦯‍➡ E15.1 person with white cane facing right: light skin tone
+1F9D1 1F3FC 200D 1F9AF 200D 27A1 FE0F ; fully-qualified # 🧑🏼‍🦯‍➡️ E15.1 person with white cane facing right: medium-light skin tone
+1F9D1 1F3FC 200D 1F9AF 200D 27A1 ; minimally-qualified # 🧑🏼‍🦯‍➡ E15.1 person with white cane facing right: medium-light skin tone
+1F9D1 1F3FD 200D 1F9AF 200D 27A1 FE0F ; fully-qualified # 🧑🏽‍🦯‍➡️ E15.1 person with white cane facing right: medium skin tone
+1F9D1 1F3FD 200D 1F9AF 200D 27A1 ; minimally-qualified # 🧑🏽‍🦯‍➡ E15.1 person with white cane facing right: medium skin tone
+1F9D1 1F3FE 200D 1F9AF 200D 27A1 FE0F ; fully-qualified # 🧑🏾‍🦯‍➡️ E15.1 person with white cane facing right: medium-dark skin tone
+1F9D1 1F3FE 200D 1F9AF 200D 27A1 ; minimally-qualified # 🧑🏾‍🦯‍➡ E15.1 person with white cane facing right: medium-dark skin tone
+1F9D1 1F3FF 200D 1F9AF 200D 27A1 FE0F ; fully-qualified # 🧑🏿‍🦯‍➡️ E15.1 person with white cane facing right: dark skin tone
+1F9D1 1F3FF 200D 1F9AF 200D 27A1 ; minimally-qualified # 🧑🏿‍🦯‍➡ E15.1 person with white cane facing right: dark skin tone
1F468 200D 1F9AF ; fully-qualified # 👨‍🦯 E12.0 man with white cane
1F468 1F3FB 200D 1F9AF ; fully-qualified # 👨🏻‍🦯 E12.0 man with white cane: light skin tone
1F468 1F3FC 200D 1F9AF ; fully-qualified # 👨🏼‍🦯 E12.0 man with white cane: medium-light skin tone
1F468 1F3FD 200D 1F9AF ; fully-qualified # 👨🏽‍🦯 E12.0 man with white cane: medium skin tone
1F468 1F3FE 200D 1F9AF ; fully-qualified # 👨🏾‍🦯 E12.0 man with white cane: medium-dark skin tone
1F468 1F3FF 200D 1F9AF ; fully-qualified # 👨🏿‍🦯 E12.0 man with white cane: dark skin tone
+1F468 200D 1F9AF 200D 27A1 FE0F ; fully-qualified # 👨‍🦯‍➡️ E15.1 man with white cane facing right
+1F468 200D 1F9AF 200D 27A1 ; minimally-qualified # 👨‍🦯‍➡ E15.1 man with white cane facing right
+1F468 1F3FB 200D 1F9AF 200D 27A1 FE0F ; fully-qualified # 👨🏻‍🦯‍➡️ E15.1 man with white cane facing right: light skin tone
+1F468 1F3FB 200D 1F9AF 200D 27A1 ; minimally-qualified # 👨🏻‍🦯‍➡ E15.1 man with white cane facing right: light skin tone
+1F468 1F3FC 200D 1F9AF 200D 27A1 FE0F ; fully-qualified # 👨🏼‍🦯‍➡️ E15.1 man with white cane facing right: medium-light skin tone
+1F468 1F3FC 200D 1F9AF 200D 27A1 ; minimally-qualified # 👨🏼‍🦯‍➡ E15.1 man with white cane facing right: medium-light skin tone
+1F468 1F3FD 200D 1F9AF 200D 27A1 FE0F ; fully-qualified # 👨🏽‍🦯‍➡️ E15.1 man with white cane facing right: medium skin tone
+1F468 1F3FD 200D 1F9AF 200D 27A1 ; minimally-qualified # 👨🏽‍🦯‍➡ E15.1 man with white cane facing right: medium skin tone
+1F468 1F3FE 200D 1F9AF 200D 27A1 FE0F ; fully-qualified # 👨🏾‍🦯‍➡️ E15.1 man with white cane facing right: medium-dark skin tone
+1F468 1F3FE 200D 1F9AF 200D 27A1 ; minimally-qualified # 👨🏾‍🦯‍➡ E15.1 man with white cane facing right: medium-dark skin tone
+1F468 1F3FF 200D 1F9AF 200D 27A1 FE0F ; fully-qualified # 👨🏿‍🦯‍➡️ E15.1 man with white cane facing right: dark skin tone
+1F468 1F3FF 200D 1F9AF 200D 27A1 ; minimally-qualified # 👨🏿‍🦯‍➡ E15.1 man with white cane facing right: dark skin tone
1F469 200D 1F9AF ; fully-qualified # 👩‍🦯 E12.0 woman with white cane
1F469 1F3FB 200D 1F9AF ; fully-qualified # 👩🏻‍🦯 E12.0 woman with white cane: light skin tone
1F469 1F3FC 200D 1F9AF ; fully-qualified # 👩🏼‍🦯 E12.0 woman with white cane: medium-light skin tone
1F469 1F3FD 200D 1F9AF ; fully-qualified # 👩🏽‍🦯 E12.0 woman with white cane: medium skin tone
1F469 1F3FE 200D 1F9AF ; fully-qualified # 👩🏾‍🦯 E12.0 woman with white cane: medium-dark skin tone
1F469 1F3FF 200D 1F9AF ; fully-qualified # 👩🏿‍🦯 E12.0 woman with white cane: dark skin tone
+1F469 200D 1F9AF 200D 27A1 FE0F ; fully-qualified # 👩‍🦯‍➡️ E15.1 woman with white cane facing right
+1F469 200D 1F9AF 200D 27A1 ; minimally-qualified # 👩‍🦯‍➡ E15.1 woman with white cane facing right
+1F469 1F3FB 200D 1F9AF 200D 27A1 FE0F ; fully-qualified # 👩🏻‍🦯‍➡️ E15.1 woman with white cane facing right: light skin tone
+1F469 1F3FB 200D 1F9AF 200D 27A1 ; minimally-qualified # 👩🏻‍🦯‍➡ E15.1 woman with white cane facing right: light skin tone
+1F469 1F3FC 200D 1F9AF 200D 27A1 FE0F ; fully-qualified # 👩🏼‍🦯‍➡️ E15.1 woman with white cane facing right: medium-light skin tone
+1F469 1F3FC 200D 1F9AF 200D 27A1 ; minimally-qualified # 👩🏼‍🦯‍➡ E15.1 woman with white cane facing right: medium-light skin tone
+1F469 1F3FD 200D 1F9AF 200D 27A1 FE0F ; fully-qualified # 👩🏽‍🦯‍➡️ E15.1 woman with white cane facing right: medium skin tone
+1F469 1F3FD 200D 1F9AF 200D 27A1 ; minimally-qualified # 👩🏽‍🦯‍➡ E15.1 woman with white cane facing right: medium skin tone
+1F469 1F3FE 200D 1F9AF 200D 27A1 FE0F ; fully-qualified # 👩🏾‍🦯‍➡️ E15.1 woman with white cane facing right: medium-dark skin tone
+1F469 1F3FE 200D 1F9AF 200D 27A1 ; minimally-qualified # 👩🏾‍🦯‍➡ E15.1 woman with white cane facing right: medium-dark skin tone
+1F469 1F3FF 200D 1F9AF 200D 27A1 FE0F ; fully-qualified # 👩🏿‍🦯‍➡️ E15.1 woman with white cane facing right: dark skin tone
+1F469 1F3FF 200D 1F9AF 200D 27A1 ; minimally-qualified # 👩🏿‍🦯‍➡ E15.1 woman with white cane facing right: dark skin tone
1F9D1 200D 1F9BC ; fully-qualified # 🧑‍🦼 E12.1 person in motorized wheelchair
1F9D1 1F3FB 200D 1F9BC ; fully-qualified # 🧑🏻‍🦼 E12.1 person in motorized wheelchair: light skin tone
1F9D1 1F3FC 200D 1F9BC ; fully-qualified # 🧑🏼‍🦼 E12.1 person in motorized wheelchair: medium-light skin tone
1F9D1 1F3FD 200D 1F9BC ; fully-qualified # 🧑🏽‍🦼 E12.1 person in motorized wheelchair: medium skin tone
1F9D1 1F3FE 200D 1F9BC ; fully-qualified # 🧑🏾‍🦼 E12.1 person in motorized wheelchair: medium-dark skin tone
1F9D1 1F3FF 200D 1F9BC ; fully-qualified # 🧑🏿‍🦼 E12.1 person in motorized wheelchair: dark skin tone
+1F9D1 200D 1F9BC 200D 27A1 FE0F ; fully-qualified # 🧑‍🦼‍➡️ E15.1 person in motorized wheelchair facing right
+1F9D1 200D 1F9BC 200D 27A1 ; minimally-qualified # 🧑‍🦼‍➡ E15.1 person in motorized wheelchair facing right
+1F9D1 1F3FB 200D 1F9BC 200D 27A1 FE0F ; fully-qualified # 🧑🏻‍🦼‍➡️ E15.1 person in motorized wheelchair facing right: light skin tone
+1F9D1 1F3FB 200D 1F9BC 200D 27A1 ; minimally-qualified # 🧑🏻‍🦼‍➡ E15.1 person in motorized wheelchair facing right: light skin tone
+1F9D1 1F3FC 200D 1F9BC 200D 27A1 FE0F ; fully-qualified # 🧑🏼‍🦼‍➡️ E15.1 person in motorized wheelchair facing right: medium-light skin tone
+1F9D1 1F3FC 200D 1F9BC 200D 27A1 ; minimally-qualified # 🧑🏼‍🦼‍➡ E15.1 person in motorized wheelchair facing right: medium-light skin tone
+1F9D1 1F3FD 200D 1F9BC 200D 27A1 FE0F ; fully-qualified # 🧑🏽‍🦼‍➡️ E15.1 person in motorized wheelchair facing right: medium skin tone
+1F9D1 1F3FD 200D 1F9BC 200D 27A1 ; minimally-qualified # 🧑🏽‍🦼‍➡ E15.1 person in motorized wheelchair facing right: medium skin tone
+1F9D1 1F3FE 200D 1F9BC 200D 27A1 FE0F ; fully-qualified # 🧑🏾‍🦼‍➡️ E15.1 person in motorized wheelchair facing right: medium-dark skin tone
+1F9D1 1F3FE 200D 1F9BC 200D 27A1 ; minimally-qualified # 🧑🏾‍🦼‍➡ E15.1 person in motorized wheelchair facing right: medium-dark skin tone
+1F9D1 1F3FF 200D 1F9BC 200D 27A1 FE0F ; fully-qualified # 🧑🏿‍🦼‍➡️ E15.1 person in motorized wheelchair facing right: dark skin tone
+1F9D1 1F3FF 200D 1F9BC 200D 27A1 ; minimally-qualified # 🧑🏿‍🦼‍➡ E15.1 person in motorized wheelchair facing right: dark skin tone
1F468 200D 1F9BC ; fully-qualified # 👨‍🦼 E12.0 man in motorized wheelchair
1F468 1F3FB 200D 1F9BC ; fully-qualified # 👨🏻‍🦼 E12.0 man in motorized wheelchair: light skin tone
1F468 1F3FC 200D 1F9BC ; fully-qualified # 👨🏼‍🦼 E12.0 man in motorized wheelchair: medium-light skin tone
1F468 1F3FD 200D 1F9BC ; fully-qualified # 👨🏽‍🦼 E12.0 man in motorized wheelchair: medium skin tone
1F468 1F3FE 200D 1F9BC ; fully-qualified # 👨🏾‍🦼 E12.0 man in motorized wheelchair: medium-dark skin tone
1F468 1F3FF 200D 1F9BC ; fully-qualified # 👨🏿‍🦼 E12.0 man in motorized wheelchair: dark skin tone
+1F468 200D 1F9BC 200D 27A1 FE0F ; fully-qualified # 👨‍🦼‍➡️ E15.1 man in motorized wheelchair facing right
+1F468 200D 1F9BC 200D 27A1 ; minimally-qualified # 👨‍🦼‍➡ E15.1 man in motorized wheelchair facing right
+1F468 1F3FB 200D 1F9BC 200D 27A1 FE0F ; fully-qualified # 👨🏻‍🦼‍➡️ E15.1 man in motorized wheelchair facing right: light skin tone
+1F468 1F3FB 200D 1F9BC 200D 27A1 ; minimally-qualified # 👨🏻‍🦼‍➡ E15.1 man in motorized wheelchair facing right: light skin tone
+1F468 1F3FC 200D 1F9BC 200D 27A1 FE0F ; fully-qualified # 👨🏼‍🦼‍➡️ E15.1 man in motorized wheelchair facing right: medium-light skin tone
+1F468 1F3FC 200D 1F9BC 200D 27A1 ; minimally-qualified # 👨🏼‍🦼‍➡ E15.1 man in motorized wheelchair facing right: medium-light skin tone
+1F468 1F3FD 200D 1F9BC 200D 27A1 FE0F ; fully-qualified # 👨🏽‍🦼‍➡️ E15.1 man in motorized wheelchair facing right: medium skin tone
+1F468 1F3FD 200D 1F9BC 200D 27A1 ; minimally-qualified # 👨🏽‍🦼‍➡ E15.1 man in motorized wheelchair facing right: medium skin tone
+1F468 1F3FE 200D 1F9BC 200D 27A1 FE0F ; fully-qualified # 👨🏾‍🦼‍➡️ E15.1 man in motorized wheelchair facing right: medium-dark skin tone
+1F468 1F3FE 200D 1F9BC 200D 27A1 ; minimally-qualified # 👨🏾‍🦼‍➡ E15.1 man in motorized wheelchair facing right: medium-dark skin tone
+1F468 1F3FF 200D 1F9BC 200D 27A1 FE0F ; fully-qualified # 👨🏿‍🦼‍➡️ E15.1 man in motorized wheelchair facing right: dark skin tone
+1F468 1F3FF 200D 1F9BC 200D 27A1 ; minimally-qualified # 👨🏿‍🦼‍➡ E15.1 man in motorized wheelchair facing right: dark skin tone
1F469 200D 1F9BC ; fully-qualified # 👩‍🦼 E12.0 woman in motorized wheelchair
1F469 1F3FB 200D 1F9BC ; fully-qualified # 👩🏻‍🦼 E12.0 woman in motorized wheelchair: light skin tone
1F469 1F3FC 200D 1F9BC ; fully-qualified # 👩🏼‍🦼 E12.0 woman in motorized wheelchair: medium-light skin tone
1F469 1F3FD 200D 1F9BC ; fully-qualified # 👩🏽‍🦼 E12.0 woman in motorized wheelchair: medium skin tone
1F469 1F3FE 200D 1F9BC ; fully-qualified # 👩🏾‍🦼 E12.0 woman in motorized wheelchair: medium-dark skin tone
1F469 1F3FF 200D 1F9BC ; fully-qualified # 👩🏿‍🦼 E12.0 woman in motorized wheelchair: dark skin tone
+1F469 200D 1F9BC 200D 27A1 FE0F ; fully-qualified # 👩‍🦼‍➡️ E15.1 woman in motorized wheelchair facing right
+1F469 200D 1F9BC 200D 27A1 ; minimally-qualified # 👩‍🦼‍➡ E15.1 woman in motorized wheelchair facing right
+1F469 1F3FB 200D 1F9BC 200D 27A1 FE0F ; fully-qualified # 👩🏻‍🦼‍➡️ E15.1 woman in motorized wheelchair facing right: light skin tone
+1F469 1F3FB 200D 1F9BC 200D 27A1 ; minimally-qualified # 👩🏻‍🦼‍➡ E15.1 woman in motorized wheelchair facing right: light skin tone
+1F469 1F3FC 200D 1F9BC 200D 27A1 FE0F ; fully-qualified # 👩🏼‍🦼‍➡️ E15.1 woman in motorized wheelchair facing right: medium-light skin tone
+1F469 1F3FC 200D 1F9BC 200D 27A1 ; minimally-qualified # 👩🏼‍🦼‍➡ E15.1 woman in motorized wheelchair facing right: medium-light skin tone
+1F469 1F3FD 200D 1F9BC 200D 27A1 FE0F ; fully-qualified # 👩🏽‍🦼‍➡️ E15.1 woman in motorized wheelchair facing right: medium skin tone
+1F469 1F3FD 200D 1F9BC 200D 27A1 ; minimally-qualified # 👩🏽‍🦼‍➡ E15.1 woman in motorized wheelchair facing right: medium skin tone
+1F469 1F3FE 200D 1F9BC 200D 27A1 FE0F ; fully-qualified # 👩🏾‍🦼‍➡️ E15.1 woman in motorized wheelchair facing right: medium-dark skin tone
+1F469 1F3FE 200D 1F9BC 200D 27A1 ; minimally-qualified # 👩🏾‍🦼‍➡ E15.1 woman in motorized wheelchair facing right: medium-dark skin tone
+1F469 1F3FF 200D 1F9BC 200D 27A1 FE0F ; fully-qualified # 👩🏿‍🦼‍➡️ E15.1 woman in motorized wheelchair facing right: dark skin tone
+1F469 1F3FF 200D 1F9BC 200D 27A1 ; minimally-qualified # 👩🏿‍🦼‍➡ E15.1 woman in motorized wheelchair facing right: dark skin tone
1F9D1 200D 1F9BD ; fully-qualified # 🧑‍🦽 E12.1 person in manual wheelchair
1F9D1 1F3FB 200D 1F9BD ; fully-qualified # 🧑🏻‍🦽 E12.1 person in manual wheelchair: light skin tone
1F9D1 1F3FC 200D 1F9BD ; fully-qualified # 🧑🏼‍🦽 E12.1 person in manual wheelchair: medium-light skin tone
1F9D1 1F3FD 200D 1F9BD ; fully-qualified # 🧑🏽‍🦽 E12.1 person in manual wheelchair: medium skin tone
1F9D1 1F3FE 200D 1F9BD ; fully-qualified # 🧑🏾‍🦽 E12.1 person in manual wheelchair: medium-dark skin tone
1F9D1 1F3FF 200D 1F9BD ; fully-qualified # 🧑🏿‍🦽 E12.1 person in manual wheelchair: dark skin tone
+1F9D1 200D 1F9BD 200D 27A1 FE0F ; fully-qualified # 🧑‍🦽‍➡️ E15.1 person in manual wheelchair facing right
+1F9D1 200D 1F9BD 200D 27A1 ; minimally-qualified # 🧑‍🦽‍➡ E15.1 person in manual wheelchair facing right
+1F9D1 1F3FB 200D 1F9BD 200D 27A1 FE0F ; fully-qualified # 🧑🏻‍🦽‍➡️ E15.1 person in manual wheelchair facing right: light skin tone
+1F9D1 1F3FB 200D 1F9BD 200D 27A1 ; minimally-qualified # 🧑🏻‍🦽‍➡ E15.1 person in manual wheelchair facing right: light skin tone
+1F9D1 1F3FC 200D 1F9BD 200D 27A1 FE0F ; fully-qualified # 🧑🏼‍🦽‍➡️ E15.1 person in manual wheelchair facing right: medium-light skin tone
+1F9D1 1F3FC 200D 1F9BD 200D 27A1 ; minimally-qualified # 🧑🏼‍🦽‍➡ E15.1 person in manual wheelchair facing right: medium-light skin tone
+1F9D1 1F3FD 200D 1F9BD 200D 27A1 FE0F ; fully-qualified # 🧑🏽‍🦽‍➡️ E15.1 person in manual wheelchair facing right: medium skin tone
+1F9D1 1F3FD 200D 1F9BD 200D 27A1 ; minimally-qualified # 🧑🏽‍🦽‍➡ E15.1 person in manual wheelchair facing right: medium skin tone
+1F9D1 1F3FE 200D 1F9BD 200D 27A1 FE0F ; fully-qualified # 🧑🏾‍🦽‍➡️ E15.1 person in manual wheelchair facing right: medium-dark skin tone
+1F9D1 1F3FE 200D 1F9BD 200D 27A1 ; minimally-qualified # 🧑🏾‍🦽‍➡ E15.1 person in manual wheelchair facing right: medium-dark skin tone
+1F9D1 1F3FF 200D 1F9BD 200D 27A1 FE0F ; fully-qualified # 🧑🏿‍🦽‍➡️ E15.1 person in manual wheelchair facing right: dark skin tone
+1F9D1 1F3FF 200D 1F9BD 200D 27A1 ; minimally-qualified # 🧑🏿‍🦽‍➡ E15.1 person in manual wheelchair facing right: dark skin tone
1F468 200D 1F9BD ; fully-qualified # 👨‍🦽 E12.0 man in manual wheelchair
1F468 1F3FB 200D 1F9BD ; fully-qualified # 👨🏻‍🦽 E12.0 man in manual wheelchair: light skin tone
1F468 1F3FC 200D 1F9BD ; fully-qualified # 👨🏼‍🦽 E12.0 man in manual wheelchair: medium-light skin tone
1F468 1F3FD 200D 1F9BD ; fully-qualified # 👨🏽‍🦽 E12.0 man in manual wheelchair: medium skin tone
1F468 1F3FE 200D 1F9BD ; fully-qualified # 👨🏾‍🦽 E12.0 man in manual wheelchair: medium-dark skin tone
1F468 1F3FF 200D 1F9BD ; fully-qualified # 👨🏿‍🦽 E12.0 man in manual wheelchair: dark skin tone
+1F468 200D 1F9BD 200D 27A1 FE0F ; fully-qualified # 👨‍🦽‍➡️ E15.1 man in manual wheelchair facing right
+1F468 200D 1F9BD 200D 27A1 ; minimally-qualified # 👨‍🦽‍➡ E15.1 man in manual wheelchair facing right
+1F468 1F3FB 200D 1F9BD 200D 27A1 FE0F ; fully-qualified # 👨🏻‍🦽‍➡️ E15.1 man in manual wheelchair facing right: light skin tone
+1F468 1F3FB 200D 1F9BD 200D 27A1 ; minimally-qualified # 👨🏻‍🦽‍➡ E15.1 man in manual wheelchair facing right: light skin tone
+1F468 1F3FC 200D 1F9BD 200D 27A1 FE0F ; fully-qualified # 👨🏼‍🦽‍➡️ E15.1 man in manual wheelchair facing right: medium-light skin tone
+1F468 1F3FC 200D 1F9BD 200D 27A1 ; minimally-qualified # 👨🏼‍🦽‍➡ E15.1 man in manual wheelchair facing right: medium-light skin tone
+1F468 1F3FD 200D 1F9BD 200D 27A1 FE0F ; fully-qualified # 👨🏽‍🦽‍➡️ E15.1 man in manual wheelchair facing right: medium skin tone
+1F468 1F3FD 200D 1F9BD 200D 27A1 ; minimally-qualified # 👨🏽‍🦽‍➡ E15.1 man in manual wheelchair facing right: medium skin tone
+1F468 1F3FE 200D 1F9BD 200D 27A1 FE0F ; fully-qualified # 👨🏾‍🦽‍➡️ E15.1 man in manual wheelchair facing right: medium-dark skin tone
+1F468 1F3FE 200D 1F9BD 200D 27A1 ; minimally-qualified # 👨🏾‍🦽‍➡ E15.1 man in manual wheelchair facing right: medium-dark skin tone
+1F468 1F3FF 200D 1F9BD 200D 27A1 FE0F ; fully-qualified # 👨🏿‍🦽‍➡️ E15.1 man in manual wheelchair facing right: dark skin tone
+1F468 1F3FF 200D 1F9BD 200D 27A1 ; minimally-qualified # 👨🏿‍🦽‍➡ E15.1 man in manual wheelchair facing right: dark skin tone
1F469 200D 1F9BD ; fully-qualified # 👩‍🦽 E12.0 woman in manual wheelchair
1F469 1F3FB 200D 1F9BD ; fully-qualified # 👩🏻‍🦽 E12.0 woman in manual wheelchair: light skin tone
1F469 1F3FC 200D 1F9BD ; fully-qualified # 👩🏼‍🦽 E12.0 woman in manual wheelchair: medium-light skin tone
1F469 1F3FD 200D 1F9BD ; fully-qualified # 👩🏽‍🦽 E12.0 woman in manual wheelchair: medium skin tone
1F469 1F3FE 200D 1F9BD ; fully-qualified # 👩🏾‍🦽 E12.0 woman in manual wheelchair: medium-dark skin tone
1F469 1F3FF 200D 1F9BD ; fully-qualified # 👩🏿‍🦽 E12.0 woman in manual wheelchair: dark skin tone
+1F469 200D 1F9BD 200D 27A1 FE0F ; fully-qualified # 👩‍🦽‍➡️ E15.1 woman in manual wheelchair facing right
+1F469 200D 1F9BD 200D 27A1 ; minimally-qualified # 👩‍🦽‍➡ E15.1 woman in manual wheelchair facing right
+1F469 1F3FB 200D 1F9BD 200D 27A1 FE0F ; fully-qualified # 👩🏻‍🦽‍➡️ E15.1 woman in manual wheelchair facing right: light skin tone
+1F469 1F3FB 200D 1F9BD 200D 27A1 ; minimally-qualified # 👩🏻‍🦽‍➡ E15.1 woman in manual wheelchair facing right: light skin tone
+1F469 1F3FC 200D 1F9BD 200D 27A1 FE0F ; fully-qualified # 👩🏼‍🦽‍➡️ E15.1 woman in manual wheelchair facing right: medium-light skin tone
+1F469 1F3FC 200D 1F9BD 200D 27A1 ; minimally-qualified # 👩🏼‍🦽‍➡ E15.1 woman in manual wheelchair facing right: medium-light skin tone
+1F469 1F3FD 200D 1F9BD 200D 27A1 FE0F ; fully-qualified # 👩🏽‍🦽‍➡️ E15.1 woman in manual wheelchair facing right: medium skin tone
+1F469 1F3FD 200D 1F9BD 200D 27A1 ; minimally-qualified # 👩🏽‍🦽‍➡ E15.1 woman in manual wheelchair facing right: medium skin tone
+1F469 1F3FE 200D 1F9BD 200D 27A1 FE0F ; fully-qualified # 👩🏾‍🦽‍➡️ E15.1 woman in manual wheelchair facing right: medium-dark skin tone
+1F469 1F3FE 200D 1F9BD 200D 27A1 ; minimally-qualified # 👩🏾‍🦽‍➡ E15.1 woman in manual wheelchair facing right: medium-dark skin tone
+1F469 1F3FF 200D 1F9BD 200D 27A1 FE0F ; fully-qualified # 👩🏿‍🦽‍➡️ E15.1 woman in manual wheelchair facing right: dark skin tone
+1F469 1F3FF 200D 1F9BD 200D 27A1 ; minimally-qualified # 👩🏿‍🦽‍➡ E15.1 woman in manual wheelchair facing right: dark skin tone
1F3C3 ; fully-qualified # 🏃 E0.6 person running
1F3C3 1F3FB ; fully-qualified # 🏃🏻 E1.0 person running: light skin tone
1F3C3 1F3FC ; fully-qualified # 🏃🏼 E1.0 person running: medium-light skin tone
@@ -2209,6 +2441,66 @@
1F3C3 1F3FE 200D 2640 ; minimally-qualified # 🏃🏾‍♀ E4.0 woman running: medium-dark skin tone
1F3C3 1F3FF 200D 2640 FE0F ; fully-qualified # 🏃🏿‍♀️ E4.0 woman running: dark skin tone
1F3C3 1F3FF 200D 2640 ; minimally-qualified # 🏃🏿‍♀ E4.0 woman running: dark skin tone
+1F3C3 200D 27A1 FE0F ; fully-qualified # 🏃‍➡️ E15.1 person running facing right
+1F3C3 200D 27A1 ; minimally-qualified # 🏃‍➡ E15.1 person running facing right
+1F3C3 1F3FB 200D 27A1 FE0F ; fully-qualified # 🏃🏻‍➡️ E15.1 person running facing right: light skin tone
+1F3C3 1F3FB 200D 27A1 ; minimally-qualified # 🏃🏻‍➡ E15.1 person running facing right: light skin tone
+1F3C3 1F3FC 200D 27A1 FE0F ; fully-qualified # 🏃🏼‍➡️ E15.1 person running facing right: medium-light skin tone
+1F3C3 1F3FC 200D 27A1 ; minimally-qualified # 🏃🏼‍➡ E15.1 person running facing right: medium-light skin tone
+1F3C3 1F3FD 200D 27A1 FE0F ; fully-qualified # 🏃🏽‍➡️ E15.1 person running facing right: medium skin tone
+1F3C3 1F3FD 200D 27A1 ; minimally-qualified # 🏃🏽‍➡ E15.1 person running facing right: medium skin tone
+1F3C3 1F3FE 200D 27A1 FE0F ; fully-qualified # 🏃🏾‍➡️ E15.1 person running facing right: medium-dark skin tone
+1F3C3 1F3FE 200D 27A1 ; minimally-qualified # 🏃🏾‍➡ E15.1 person running facing right: medium-dark skin tone
+1F3C3 1F3FF 200D 27A1 FE0F ; fully-qualified # 🏃🏿‍➡️ E15.1 person running facing right: dark skin tone
+1F3C3 1F3FF 200D 27A1 ; minimally-qualified # 🏃🏿‍➡ E15.1 person running facing right: dark skin tone
+1F3C3 200D 2640 FE0F 200D 27A1 FE0F ; fully-qualified # 🏃‍♀️‍➡️ E15.1 woman running facing right
+1F3C3 200D 2640 200D 27A1 FE0F ; minimally-qualified # 🏃‍♀‍➡️ E15.1 woman running facing right
+1F3C3 200D 2640 FE0F 200D 27A1 ; minimally-qualified # 🏃‍♀️‍➡ E15.1 woman running facing right
+1F3C3 200D 2640 200D 27A1 ; minimally-qualified # 🏃‍♀‍➡ E15.1 woman running facing right
+1F3C3 1F3FB 200D 2640 FE0F 200D 27A1 FE0F ; fully-qualified # 🏃🏻‍♀️‍➡️ E15.1 woman running facing right: light skin tone
+1F3C3 1F3FB 200D 2640 200D 27A1 FE0F ; minimally-qualified # 🏃🏻‍♀‍➡️ E15.1 woman running facing right: light skin tone
+1F3C3 1F3FB 200D 2640 FE0F 200D 27A1 ; minimally-qualified # 🏃🏻‍♀️‍➡ E15.1 woman running facing right: light skin tone
+1F3C3 1F3FB 200D 2640 200D 27A1 ; minimally-qualified # 🏃🏻‍♀‍➡ E15.1 woman running facing right: light skin tone
+1F3C3 1F3FC 200D 2640 FE0F 200D 27A1 FE0F ; fully-qualified # 🏃🏼‍♀️‍➡️ E15.1 woman running facing right: medium-light skin tone
+1F3C3 1F3FC 200D 2640 200D 27A1 FE0F ; minimally-qualified # 🏃🏼‍♀‍➡️ E15.1 woman running facing right: medium-light skin tone
+1F3C3 1F3FC 200D 2640 FE0F 200D 27A1 ; minimally-qualified # 🏃🏼‍♀️‍➡ E15.1 woman running facing right: medium-light skin tone
+1F3C3 1F3FC 200D 2640 200D 27A1 ; minimally-qualified # 🏃🏼‍♀‍➡ E15.1 woman running facing right: medium-light skin tone
+1F3C3 1F3FD 200D 2640 FE0F 200D 27A1 FE0F ; fully-qualified # 🏃🏽‍♀️‍➡️ E15.1 woman running facing right: medium skin tone
+1F3C3 1F3FD 200D 2640 200D 27A1 FE0F ; minimally-qualified # 🏃🏽‍♀‍➡️ E15.1 woman running facing right: medium skin tone
+1F3C3 1F3FD 200D 2640 FE0F 200D 27A1 ; minimally-qualified # 🏃🏽‍♀️‍➡ E15.1 woman running facing right: medium skin tone
+1F3C3 1F3FD 200D 2640 200D 27A1 ; minimally-qualified # 🏃🏽‍♀‍➡ E15.1 woman running facing right: medium skin tone
+1F3C3 1F3FE 200D 2640 FE0F 200D 27A1 FE0F ; fully-qualified # 🏃🏾‍♀️‍➡️ E15.1 woman running facing right: medium-dark skin tone
+1F3C3 1F3FE 200D 2640 200D 27A1 FE0F ; minimally-qualified # 🏃🏾‍♀‍➡️ E15.1 woman running facing right: medium-dark skin tone
+1F3C3 1F3FE 200D 2640 FE0F 200D 27A1 ; minimally-qualified # 🏃🏾‍♀️‍➡ E15.1 woman running facing right: medium-dark skin tone
+1F3C3 1F3FE 200D 2640 200D 27A1 ; minimally-qualified # 🏃🏾‍♀‍➡ E15.1 woman running facing right: medium-dark skin tone
+1F3C3 1F3FF 200D 2640 FE0F 200D 27A1 FE0F ; fully-qualified # 🏃🏿‍♀️‍➡️ E15.1 woman running facing right: dark skin tone
+1F3C3 1F3FF 200D 2640 200D 27A1 FE0F ; minimally-qualified # 🏃🏿‍♀‍➡️ E15.1 woman running facing right: dark skin tone
+1F3C3 1F3FF 200D 2640 FE0F 200D 27A1 ; minimally-qualified # 🏃🏿‍♀️‍➡ E15.1 woman running facing right: dark skin tone
+1F3C3 1F3FF 200D 2640 200D 27A1 ; minimally-qualified # 🏃🏿‍♀‍➡ E15.1 woman running facing right: dark skin tone
+1F3C3 200D 2642 FE0F 200D 27A1 FE0F ; fully-qualified # 🏃‍♂️‍➡️ E15.1 man running facing right
+1F3C3 200D 2642 200D 27A1 FE0F ; minimally-qualified # 🏃‍♂‍➡️ E15.1 man running facing right
+1F3C3 200D 2642 FE0F 200D 27A1 ; minimally-qualified # 🏃‍♂️‍➡ E15.1 man running facing right
+1F3C3 200D 2642 200D 27A1 ; minimally-qualified # 🏃‍♂‍➡ E15.1 man running facing right
+1F3C3 1F3FB 200D 2642 FE0F 200D 27A1 FE0F ; fully-qualified # 🏃🏻‍♂️‍➡️ E15.1 man running facing right: light skin tone
+1F3C3 1F3FB 200D 2642 200D 27A1 FE0F ; minimally-qualified # 🏃🏻‍♂‍➡️ E15.1 man running facing right: light skin tone
+1F3C3 1F3FB 200D 2642 FE0F 200D 27A1 ; minimally-qualified # 🏃🏻‍♂️‍➡ E15.1 man running facing right: light skin tone
+1F3C3 1F3FB 200D 2642 200D 27A1 ; minimally-qualified # 🏃🏻‍♂‍➡ E15.1 man running facing right: light skin tone
+1F3C3 1F3FC 200D 2642 FE0F 200D 27A1 FE0F ; fully-qualified # 🏃🏼‍♂️‍➡️ E15.1 man running facing right: medium-light skin tone
+1F3C3 1F3FC 200D 2642 200D 27A1 FE0F ; minimally-qualified # 🏃🏼‍♂‍➡️ E15.1 man running facing right: medium-light skin tone
+1F3C3 1F3FC 200D 2642 FE0F 200D 27A1 ; minimally-qualified # 🏃🏼‍♂️‍➡ E15.1 man running facing right: medium-light skin tone
+1F3C3 1F3FC 200D 2642 200D 27A1 ; minimally-qualified # 🏃🏼‍♂‍➡ E15.1 man running facing right: medium-light skin tone
+1F3C3 1F3FD 200D 2642 FE0F 200D 27A1 FE0F ; fully-qualified # 🏃🏽‍♂️‍➡️ E15.1 man running facing right: medium skin tone
+1F3C3 1F3FD 200D 2642 200D 27A1 FE0F ; minimally-qualified # 🏃🏽‍♂‍➡️ E15.1 man running facing right: medium skin tone
+1F3C3 1F3FD 200D 2642 FE0F 200D 27A1 ; minimally-qualified # 🏃🏽‍♂️‍➡ E15.1 man running facing right: medium skin tone
+1F3C3 1F3FD 200D 2642 200D 27A1 ; minimally-qualified # 🏃🏽‍♂‍➡ E15.1 man running facing right: medium skin tone
+1F3C3 1F3FE 200D 2642 FE0F 200D 27A1 FE0F ; fully-qualified # 🏃🏾‍♂️‍➡️ E15.1 man running facing right: medium-dark skin tone
+1F3C3 1F3FE 200D 2642 200D 27A1 FE0F ; minimally-qualified # 🏃🏾‍♂‍➡️ E15.1 man running facing right: medium-dark skin tone
+1F3C3 1F3FE 200D 2642 FE0F 200D 27A1 ; minimally-qualified # 🏃🏾‍♂️‍➡ E15.1 man running facing right: medium-dark skin tone
+1F3C3 1F3FE 200D 2642 200D 27A1 ; minimally-qualified # 🏃🏾‍♂‍➡ E15.1 man running facing right: medium-dark skin tone
+1F3C3 1F3FF 200D 2642 FE0F 200D 27A1 FE0F ; fully-qualified # 🏃🏿‍♂️‍➡️ E15.1 man running facing right: dark skin tone
+1F3C3 1F3FF 200D 2642 200D 27A1 FE0F ; minimally-qualified # 🏃🏿‍♂‍➡️ E15.1 man running facing right: dark skin tone
+1F3C3 1F3FF 200D 2642 FE0F 200D 27A1 ; minimally-qualified # 🏃🏿‍♂️‍➡ E15.1 man running facing right: dark skin tone
+1F3C3 1F3FF 200D 2642 200D 27A1 ; minimally-qualified # 🏃🏿‍♂‍➡ E15.1 man running facing right: dark skin tone
1F483 ; fully-qualified # 💃 E0.6 woman dancing
1F483 1F3FB ; fully-qualified # 💃🏻 E1.0 woman dancing: light skin tone
1F483 1F3FC ; fully-qualified # 💃🏼 E1.0 woman dancing: medium-light skin tone
@@ -3244,7 +3536,6 @@
1F469 1F3FF 200D 2764 200D 1F469 1F3FE ; minimally-qualified # 👩🏿‍❤‍👩🏾 E13.1 couple with heart: woman, woman, dark skin tone, medium-dark skin tone
1F469 1F3FF 200D 2764 FE0F 200D 1F469 1F3FF ; fully-qualified # 👩🏿‍❤️‍👩🏿 E13.1 couple with heart: woman, woman, dark skin tone
1F469 1F3FF 200D 2764 200D 1F469 1F3FF ; minimally-qualified # 👩🏿‍❤‍👩🏿 E13.1 couple with heart: woman, woman, dark skin tone
-1F46A ; fully-qualified # 👪 E0.6 family
1F468 200D 1F469 200D 1F466 ; fully-qualified # 👨‍👩‍👦 E2.0 family: man, woman, boy
1F468 200D 1F469 200D 1F467 ; fully-qualified # 👨‍👩‍👧 E2.0 family: man, woman, girl
1F468 200D 1F469 200D 1F467 200D 1F466 ; fully-qualified # 👨‍👩‍👧‍👦 E2.0 family: man, woman, girl, boy
@@ -3277,10 +3568,15 @@
1F464 ; fully-qualified # 👤 E0.6 bust in silhouette
1F465 ; fully-qualified # 👥 E1.0 busts in silhouette
1FAC2 ; fully-qualified # 🫂 E13.0 people hugging
+1F46A ; fully-qualified # 👪 E0.6 family
+1F9D1 200D 1F9D1 200D 1F9D2 ; fully-qualified # 🧑‍🧑‍🧒 E15.1 family: adult, adult, child
+1F9D1 200D 1F9D1 200D 1F9D2 200D 1F9D2 ; fully-qualified # 🧑‍🧑‍🧒‍🧒 E15.1 family: adult, adult, child, child
+1F9D1 200D 1F9D2 ; fully-qualified # 🧑‍🧒 E15.1 family: adult, child
+1F9D1 200D 1F9D2 200D 1F9D2 ; fully-qualified # 🧑‍🧒‍🧒 E15.1 family: adult, child, child
1F463 ; fully-qualified # 👣 E0.6 footprints
-# People & Body subtotal: 2998
-# People & Body subtotal: 508 w/o modifiers
+# People & Body subtotal: 3290
+# People & Body subtotal: 560 w/o modifiers
# group: Component
@@ -3395,6 +3691,7 @@
1FABD ; fully-qualified # 🪽 E15.0 wing
1F426 200D 2B1B ; fully-qualified # 🐦‍⬛ E15.0 black bird
1FABF ; fully-qualified # 🪿 E15.0 goose
+1F426 200D 1F525 ; fully-qualified # 🐦‍🔥 E15.1 phoenix
# subgroup: animal-amphibian
1F438 ; fully-qualified # 🐸 E0.6 frog
@@ -3477,8 +3774,8 @@
1FABA ; fully-qualified # 🪺 E14.0 nest with eggs
1F344 ; fully-qualified # 🍄 E0.6 mushroom
-# Animals & Nature subtotal: 159
-# Animals & Nature subtotal: 159 w/o modifiers
+# Animals & Nature subtotal: 160
+# Animals & Nature subtotal: 160 w/o modifiers
# group: Food & Drink
@@ -3488,6 +3785,7 @@
1F349 ; fully-qualified # 🍉 E0.6 watermelon
1F34A ; fully-qualified # 🍊 E0.6 tangerine
1F34B ; fully-qualified # 🍋 E1.0 lemon
+1F34B 200D 1F7E9 ; fully-qualified # 🍋‍🟩 E15.1 lime
1F34C ; fully-qualified # 🍌 E0.6 banana
1F34D ; fully-qualified # 🍍 E0.6 pineapple
1F96D ; fully-qualified # 🥭 E11.0 mango
@@ -3522,6 +3820,7 @@
1F330 ; fully-qualified # 🌰 E0.6 chestnut
1FADA ; fully-qualified # 🫚 E15.0 ginger root
1FADB ; fully-qualified # 🫛 E15.0 pea pod
+1F344 200D 1F7EB ; fully-qualified # 🍄‍🟫 E15.1 brown mushroom
# subgroup: food-prepared
1F35E ; fully-qualified # 🍞 E0.6 bread
@@ -3633,8 +3932,8 @@
1FAD9 ; fully-qualified # 🫙 E14.0 jar
1F3FA ; fully-qualified # 🏺 E1.0 amphora
-# Food & Drink subtotal: 135
-# Food & Drink subtotal: 135 w/o modifiers
+# Food & Drink subtotal: 137
+# Food & Drink subtotal: 137 w/o modifiers
# group: Travel & Places
@@ -4321,6 +4620,8 @@
2696 ; unqualified # ⚖ E1.0 balance scale
1F9AF ; fully-qualified # 🦯 E12.0 white cane
1F517 ; fully-qualified # 🔗 E0.6 link
+26D3 FE0F 200D 1F4A5 ; fully-qualified # ⛓️‍💥 E15.1 broken chain
+26D3 200D 1F4A5 ; unqualified # ⛓‍💥 E15.1 broken chain
26D3 FE0F ; fully-qualified # ⛓️ E0.7 chains
26D3 ; unqualified # ⛓ E0.7 chains
1FA9D ; fully-qualified # 🪝 E13.0 hook
@@ -4389,8 +4690,8 @@
1FAA7 ; fully-qualified # 🪧 E13.0 placard
1FAAA ; fully-qualified # 🪪 E14.0 identification card
-# Objects subtotal: 310
-# Objects subtotal: 310 w/o modifiers
+# Objects subtotal: 312
+# Objects subtotal: 312 w/o modifiers
# group: Symbols
@@ -4979,7 +5280,7 @@
1F1F9 1F1F2 ; fully-qualified # 🇹🇲 E2.0 flag: Turkmenistan
1F1F9 1F1F3 ; fully-qualified # 🇹🇳 E2.0 flag: Tunisia
1F1F9 1F1F4 ; fully-qualified # 🇹🇴 E2.0 flag: Tonga
-1F1F9 1F1F7 ; fully-qualified # 🇹🇷 E2.0 flag: Turkey
+1F1F9 1F1F7 ; fully-qualified # 🇹🇷 E2.0 flag: Türkiye
1F1F9 1F1F9 ; fully-qualified # 🇹🇹 E2.0 flag: Trinidad & Tobago
1F1F9 1F1FB ; fully-qualified # 🇹🇻 E2.0 flag: Tuvalu
1F1F9 1F1FC ; fully-qualified # 🇹🇼 E2.0 flag: Taiwan
@@ -5016,9 +5317,9 @@
# Flags subtotal: 275 w/o modifiers
# Status Counts
-# fully-qualified : 3655
-# minimally-qualified : 827
-# unqualified : 242
+# fully-qualified : 3773
+# minimally-qualified : 1009
+# unqualified : 243
# component : 9
#EOF
diff --git a/admin/unidata/emoji-variation-sequences.txt b/admin/unidata/emoji-variation-sequences.txt
index f3396ada19d..d8a3c9f431d 100644
--- a/admin/unidata/emoji-variation-sequences.txt
+++ b/admin/unidata/emoji-variation-sequences.txt
@@ -1,723 +1,757 @@
# emoji-variation-sequences.txt
-# Date: 2022-05-13, 21:54:24 GMT
-# © 2022 Unicode®, Inc.
+# Date: 2023-02-01, 02:22:54 GMT
+# © 2023 Unicode®, Inc.
# Unicode and the Unicode Logo are registered trademarks of Unicode, Inc. in the U.S. and other countries.
# For terms of use, see https://www.unicode.org/terms_of_use.html
#
# Emoji Variation Sequences for UTS #51
-# Used with Emoji Version 15.0 and subsequent minor revisions (if any)
+# Used with Emoji Version 15.1 and subsequent minor revisions (if any)
#
# For documentation and usage, see https://www.unicode.org/reports/tr51
#
-0023 FE0E ; text style; # (1.1 #︎ ) NUMBER SIGN
-0023 FE0F ; emoji style; # (1.1 #️ ) NUMBER SIGN
-002A FE0E ; text style; # (1.1 *︎ ) ASTERISK
-002A FE0F ; emoji style; # (1.1 *️ ) ASTERISK
-0030 FE0E ; text style; # (1.1 0︎ ) DIGIT ZERO
-0030 FE0F ; emoji style; # (1.1 0️ ) DIGIT ZERO
-0031 FE0E ; text style; # (1.1 1︎ ) DIGIT ONE
-0031 FE0F ; emoji style; # (1.1 1️ ) DIGIT ONE
-0032 FE0E ; text style; # (1.1 2︎ ) DIGIT TWO
-0032 FE0F ; emoji style; # (1.1 2️ ) DIGIT TWO
-0033 FE0E ; text style; # (1.1 3︎ ) DIGIT THREE
-0033 FE0F ; emoji style; # (1.1 3️ ) DIGIT THREE
-0034 FE0E ; text style; # (1.1 4︎ ) DIGIT FOUR
-0034 FE0F ; emoji style; # (1.1 4️ ) DIGIT FOUR
-0035 FE0E ; text style; # (1.1 5︎ ) DIGIT FIVE
-0035 FE0F ; emoji style; # (1.1 5️ ) DIGIT FIVE
-0036 FE0E ; text style; # (1.1 6︎ ) DIGIT SIX
-0036 FE0F ; emoji style; # (1.1 6️ ) DIGIT SIX
-0037 FE0E ; text style; # (1.1 7︎ ) DIGIT SEVEN
-0037 FE0F ; emoji style; # (1.1 7️ ) DIGIT SEVEN
-0038 FE0E ; text style; # (1.1 8︎ ) DIGIT EIGHT
-0038 FE0F ; emoji style; # (1.1 8️ ) DIGIT EIGHT
-0039 FE0E ; text style; # (1.1 9︎ ) DIGIT NINE
-0039 FE0F ; emoji style; # (1.1 9️ ) DIGIT NINE
-00A9 FE0E ; text style; # (1.1 ©︎ ) COPYRIGHT SIGN
-00A9 FE0F ; emoji style; # (1.1 ©️ ) COPYRIGHT SIGN
-00AE FE0E ; text style; # (1.1 ®︎ ) REGISTERED SIGN
-00AE FE0F ; emoji style; # (1.1 ®️ ) REGISTERED SIGN
-203C FE0E ; text style; # (1.1 ‼︎ ) DOUBLE EXCLAMATION MARK
-203C FE0F ; emoji style; # (1.1 ‼️ ) DOUBLE EXCLAMATION MARK
-2049 FE0E ; text style; # (3.0 ⁉︎ ) EXCLAMATION QUESTION MARK
-2049 FE0F ; emoji style; # (3.0 ⁉️ ) EXCLAMATION QUESTION MARK
-2122 FE0E ; text style; # (1.1 ™︎ ) TRADE MARK SIGN
-2122 FE0F ; emoji style; # (1.1 ™️ ) TRADE MARK SIGN
-2139 FE0E ; text style; # (3.0 ℹ︎ ) INFORMATION SOURCE
-2139 FE0F ; emoji style; # (3.0 ℹ️ ) INFORMATION SOURCE
-2194 FE0E ; text style; # (1.1 ↔︎ ) LEFT RIGHT ARROW
-2194 FE0F ; emoji style; # (1.1 ↔️ ) LEFT RIGHT ARROW
-2195 FE0E ; text style; # (1.1 ↕︎ ) UP DOWN ARROW
-2195 FE0F ; emoji style; # (1.1 ↕️ ) UP DOWN ARROW
-2196 FE0E ; text style; # (1.1 ↖︎ ) NORTH WEST ARROW
-2196 FE0F ; emoji style; # (1.1 ↖️ ) NORTH WEST ARROW
-2197 FE0E ; text style; # (1.1 ↗︎ ) NORTH EAST ARROW
-2197 FE0F ; emoji style; # (1.1 ↗️ ) NORTH EAST ARROW
-2198 FE0E ; text style; # (1.1 ↘︎ ) SOUTH EAST ARROW
-2198 FE0F ; emoji style; # (1.1 ↘️ ) SOUTH EAST ARROW
-2199 FE0E ; text style; # (1.1 ↙︎ ) SOUTH WEST ARROW
-2199 FE0F ; emoji style; # (1.1 ↙️ ) SOUTH WEST ARROW
-21A9 FE0E ; text style; # (1.1 ↩︎ ) LEFTWARDS ARROW WITH HOOK
-21A9 FE0F ; emoji style; # (1.1 ↩️ ) LEFTWARDS ARROW WITH HOOK
-21AA FE0E ; text style; # (1.1 ↪︎ ) RIGHTWARDS ARROW WITH HOOK
-21AA FE0F ; emoji style; # (1.1 ↪️ ) RIGHTWARDS ARROW WITH HOOK
-231A FE0E ; text style; # (1.1 ⌚︎ ) WATCH
-231A FE0F ; emoji style; # (1.1 ⌚️ ) WATCH
-231B FE0E ; text style; # (1.1 ⌛︎ ) HOURGLASS
-231B FE0F ; emoji style; # (1.1 ⌛️ ) HOURGLASS
-2328 FE0E ; text style; # (1.1 ⌨︎ ) KEYBOARD
-2328 FE0F ; emoji style; # (1.1 ⌨️ ) KEYBOARD
-23CF FE0E ; text style; # (4.0 ⏏︎ ) EJECT SYMBOL
-23CF FE0F ; emoji style; # (4.0 ⏏️ ) EJECT SYMBOL
-23E9 FE0E ; text style; # (6.0 ⏩︎ ) BLACK RIGHT-POINTING DOUBLE TRIANGLE
-23E9 FE0F ; emoji style; # (6.0 ⏩️ ) BLACK RIGHT-POINTING DOUBLE TRIANGLE
-23EA FE0E ; text style; # (6.0 ⏪︎ ) BLACK LEFT-POINTING DOUBLE TRIANGLE
-23EA FE0F ; emoji style; # (6.0 ⏪️ ) BLACK LEFT-POINTING DOUBLE TRIANGLE
-23ED FE0E ; text style; # (6.0 ⏭︎ ) BLACK RIGHT-POINTING DOUBLE TRIANGLE WITH VERTICAL BAR
-23ED FE0F ; emoji style; # (6.0 ⏭️ ) BLACK RIGHT-POINTING DOUBLE TRIANGLE WITH VERTICAL BAR
-23EE FE0E ; text style; # (6.0 ⏮︎ ) BLACK LEFT-POINTING DOUBLE TRIANGLE WITH VERTICAL BAR
-23EE FE0F ; emoji style; # (6.0 ⏮️ ) BLACK LEFT-POINTING DOUBLE TRIANGLE WITH VERTICAL BAR
-23EF FE0E ; text style; # (6.0 ⏯︎ ) BLACK RIGHT-POINTING TRIANGLE WITH DOUBLE VERTICAL BAR
-23EF FE0F ; emoji style; # (6.0 ⏯️ ) BLACK RIGHT-POINTING TRIANGLE WITH DOUBLE VERTICAL BAR
-23F1 FE0E ; text style; # (6.0 ⏱︎ ) STOPWATCH
-23F1 FE0F ; emoji style; # (6.0 ⏱️ ) STOPWATCH
-23F2 FE0E ; text style; # (6.0 ⏲︎ ) TIMER CLOCK
-23F2 FE0F ; emoji style; # (6.0 ⏲️ ) TIMER CLOCK
-23F3 FE0E ; text style; # (6.0 ⏳︎ ) HOURGLASS WITH FLOWING SAND
-23F3 FE0F ; emoji style; # (6.0 ⏳️ ) HOURGLASS WITH FLOWING SAND
-23F8 FE0E ; text style; # (7.0 ⏸︎ ) DOUBLE VERTICAL BAR
-23F8 FE0F ; emoji style; # (7.0 ⏸️ ) DOUBLE VERTICAL BAR
-23F9 FE0E ; text style; # (7.0 ⏹︎ ) BLACK SQUARE FOR STOP
-23F9 FE0F ; emoji style; # (7.0 ⏹️ ) BLACK SQUARE FOR STOP
-23FA FE0E ; text style; # (7.0 ⏺︎ ) BLACK CIRCLE FOR RECORD
-23FA FE0F ; emoji style; # (7.0 ⏺️ ) BLACK CIRCLE FOR RECORD
-24C2 FE0E ; text style; # (1.1 Ⓜ︎ ) CIRCLED LATIN CAPITAL LETTER M
-24C2 FE0F ; emoji style; # (1.1 Ⓜ️ ) CIRCLED LATIN CAPITAL LETTER M
-25AA FE0E ; text style; # (1.1 ▪︎ ) BLACK SMALL SQUARE
-25AA FE0F ; emoji style; # (1.1 ▪️ ) BLACK SMALL SQUARE
-25AB FE0E ; text style; # (1.1 ▫︎ ) WHITE SMALL SQUARE
-25AB FE0F ; emoji style; # (1.1 ▫️ ) WHITE SMALL SQUARE
-25B6 FE0E ; text style; # (1.1 ▶︎ ) BLACK RIGHT-POINTING TRIANGLE
-25B6 FE0F ; emoji style; # (1.1 ▶️ ) BLACK RIGHT-POINTING TRIANGLE
-25C0 FE0E ; text style; # (1.1 ◀︎ ) BLACK LEFT-POINTING TRIANGLE
-25C0 FE0F ; emoji style; # (1.1 ◀️ ) BLACK LEFT-POINTING TRIANGLE
-25FB FE0E ; text style; # (3.2 ◻︎ ) WHITE MEDIUM SQUARE
-25FB FE0F ; emoji style; # (3.2 ◻️ ) WHITE MEDIUM SQUARE
-25FC FE0E ; text style; # (3.2 ◼︎ ) BLACK MEDIUM SQUARE
-25FC FE0F ; emoji style; # (3.2 ◼️ ) BLACK MEDIUM SQUARE
-25FD FE0E ; text style; # (3.2 ◽︎ ) WHITE MEDIUM SMALL SQUARE
-25FD FE0F ; emoji style; # (3.2 ◽️ ) WHITE MEDIUM SMALL SQUARE
-25FE FE0E ; text style; # (3.2 ◾︎ ) BLACK MEDIUM SMALL SQUARE
-25FE FE0F ; emoji style; # (3.2 ◾️ ) BLACK MEDIUM SMALL SQUARE
-2600 FE0E ; text style; # (1.1 ☀︎ ) BLACK SUN WITH RAYS
-2600 FE0F ; emoji style; # (1.1 ☀️ ) BLACK SUN WITH RAYS
-2601 FE0E ; text style; # (1.1 ☁︎ ) CLOUD
-2601 FE0F ; emoji style; # (1.1 ☁️ ) CLOUD
-2602 FE0E ; text style; # (1.1 ☂︎ ) UMBRELLA
-2602 FE0F ; emoji style; # (1.1 ☂️ ) UMBRELLA
-2603 FE0E ; text style; # (1.1 ☃︎ ) SNOWMAN
-2603 FE0F ; emoji style; # (1.1 ☃️ ) SNOWMAN
-2604 FE0E ; text style; # (1.1 ☄︎ ) COMET
-2604 FE0F ; emoji style; # (1.1 ☄️ ) COMET
-260E FE0E ; text style; # (1.1 ☎︎ ) BLACK TELEPHONE
-260E FE0F ; emoji style; # (1.1 ☎️ ) BLACK TELEPHONE
-2611 FE0E ; text style; # (1.1 ☑︎ ) BALLOT BOX WITH CHECK
-2611 FE0F ; emoji style; # (1.1 ☑️ ) BALLOT BOX WITH CHECK
-2614 FE0E ; text style; # (4.0 ☔︎ ) UMBRELLA WITH RAIN DROPS
-2614 FE0F ; emoji style; # (4.0 ☔️ ) UMBRELLA WITH RAIN DROPS
-2615 FE0E ; text style; # (4.0 ☕︎ ) HOT BEVERAGE
-2615 FE0F ; emoji style; # (4.0 ☕️ ) HOT BEVERAGE
-2618 FE0E ; text style; # (4.1 ☘︎ ) SHAMROCK
-2618 FE0F ; emoji style; # (4.1 ☘️ ) SHAMROCK
-261D FE0E ; text style; # (1.1 ☝︎ ) WHITE UP POINTING INDEX
-261D FE0F ; emoji style; # (1.1 ☝️ ) WHITE UP POINTING INDEX
-2620 FE0E ; text style; # (1.1 ☠︎ ) SKULL AND CROSSBONES
-2620 FE0F ; emoji style; # (1.1 ☠️ ) SKULL AND CROSSBONES
-2622 FE0E ; text style; # (1.1 ☢︎ ) RADIOACTIVE SIGN
-2622 FE0F ; emoji style; # (1.1 ☢️ ) RADIOACTIVE SIGN
-2623 FE0E ; text style; # (1.1 ☣︎ ) BIOHAZARD SIGN
-2623 FE0F ; emoji style; # (1.1 ☣️ ) BIOHAZARD SIGN
-2626 FE0E ; text style; # (1.1 ☦︎ ) ORTHODOX CROSS
-2626 FE0F ; emoji style; # (1.1 ☦️ ) ORTHODOX CROSS
-262A FE0E ; text style; # (1.1 ☪︎ ) STAR AND CRESCENT
-262A FE0F ; emoji style; # (1.1 ☪️ ) STAR AND CRESCENT
-262E FE0E ; text style; # (1.1 ☮︎ ) PEACE SYMBOL
-262E FE0F ; emoji style; # (1.1 ☮️ ) PEACE SYMBOL
-262F FE0E ; text style; # (1.1 ☯︎ ) YIN YANG
-262F FE0F ; emoji style; # (1.1 ☯️ ) YIN YANG
-2638 FE0E ; text style; # (1.1 ☸︎ ) WHEEL OF DHARMA
-2638 FE0F ; emoji style; # (1.1 ☸️ ) WHEEL OF DHARMA
-2639 FE0E ; text style; # (1.1 ☹︎ ) WHITE FROWNING FACE
-2639 FE0F ; emoji style; # (1.1 ☹️ ) WHITE FROWNING FACE
-263A FE0E ; text style; # (1.1 ☺︎ ) WHITE SMILING FACE
-263A FE0F ; emoji style; # (1.1 ☺️ ) WHITE SMILING FACE
-2640 FE0E ; text style; # (1.1 ♀︎ ) FEMALE SIGN
-2640 FE0F ; emoji style; # (1.1 ♀️ ) FEMALE SIGN
-2642 FE0E ; text style; # (1.1 ♂︎ ) MALE SIGN
-2642 FE0F ; emoji style; # (1.1 ♂️ ) MALE SIGN
-2648 FE0E ; text style; # (1.1 ♈︎ ) ARIES
-2648 FE0F ; emoji style; # (1.1 ♈️ ) ARIES
-2649 FE0E ; text style; # (1.1 ♉︎ ) TAURUS
-2649 FE0F ; emoji style; # (1.1 ♉️ ) TAURUS
-264A FE0E ; text style; # (1.1 ♊︎ ) GEMINI
-264A FE0F ; emoji style; # (1.1 ♊️ ) GEMINI
-264B FE0E ; text style; # (1.1 ♋︎ ) CANCER
-264B FE0F ; emoji style; # (1.1 ♋️ ) CANCER
-264C FE0E ; text style; # (1.1 ♌︎ ) LEO
-264C FE0F ; emoji style; # (1.1 ♌️ ) LEO
-264D FE0E ; text style; # (1.1 ♍︎ ) VIRGO
-264D FE0F ; emoji style; # (1.1 ♍️ ) VIRGO
-264E FE0E ; text style; # (1.1 ♎︎ ) LIBRA
-264E FE0F ; emoji style; # (1.1 ♎️ ) LIBRA
-264F FE0E ; text style; # (1.1 ♏︎ ) SCORPIUS
-264F FE0F ; emoji style; # (1.1 ♏️ ) SCORPIUS
-2650 FE0E ; text style; # (1.1 ♐︎ ) SAGITTARIUS
-2650 FE0F ; emoji style; # (1.1 ♐️ ) SAGITTARIUS
-2651 FE0E ; text style; # (1.1 ♑︎ ) CAPRICORN
-2651 FE0F ; emoji style; # (1.1 ♑️ ) CAPRICORN
-2652 FE0E ; text style; # (1.1 ♒︎ ) AQUARIUS
-2652 FE0F ; emoji style; # (1.1 ♒️ ) AQUARIUS
-2653 FE0E ; text style; # (1.1 ♓︎ ) PISCES
-2653 FE0F ; emoji style; # (1.1 ♓️ ) PISCES
-265F FE0E ; text style; # (1.1 ♟︎ ) BLACK CHESS PAWN
-265F FE0F ; emoji style; # (1.1 ♟️ ) BLACK CHESS PAWN
-2660 FE0E ; text style; # (1.1 ♠︎ ) BLACK SPADE SUIT
-2660 FE0F ; emoji style; # (1.1 ♠️ ) BLACK SPADE SUIT
-2663 FE0E ; text style; # (1.1 ♣︎ ) BLACK CLUB SUIT
-2663 FE0F ; emoji style; # (1.1 ♣️ ) BLACK CLUB SUIT
-2665 FE0E ; text style; # (1.1 ♥︎ ) BLACK HEART SUIT
-2665 FE0F ; emoji style; # (1.1 ♥️ ) BLACK HEART SUIT
-2666 FE0E ; text style; # (1.1 ♦︎ ) BLACK DIAMOND SUIT
-2666 FE0F ; emoji style; # (1.1 ♦️ ) BLACK DIAMOND SUIT
-2668 FE0E ; text style; # (1.1 ♨︎ ) HOT SPRINGS
-2668 FE0F ; emoji style; # (1.1 ♨️ ) HOT SPRINGS
-267B FE0E ; text style; # (3.2 ♻︎ ) BLACK UNIVERSAL RECYCLING SYMBOL
-267B FE0F ; emoji style; # (3.2 ♻️ ) BLACK UNIVERSAL RECYCLING SYMBOL
-267E FE0E ; text style; # (4.1 ♾︎ ) PERMANENT PAPER SIGN
-267E FE0F ; emoji style; # (4.1 ♾️ ) PERMANENT PAPER SIGN
-267F FE0E ; text style; # (4.1 ♿︎ ) WHEELCHAIR SYMBOL
-267F FE0F ; emoji style; # (4.1 ♿️ ) WHEELCHAIR SYMBOL
-2692 FE0E ; text style; # (4.1 ⚒︎ ) HAMMER AND PICK
-2692 FE0F ; emoji style; # (4.1 ⚒️ ) HAMMER AND PICK
-2693 FE0E ; text style; # (4.1 ⚓︎ ) ANCHOR
-2693 FE0F ; emoji style; # (4.1 ⚓️ ) ANCHOR
-2694 FE0E ; text style; # (4.1 ⚔︎ ) CROSSED SWORDS
-2694 FE0F ; emoji style; # (4.1 ⚔️ ) CROSSED SWORDS
-2695 FE0E ; text style; # (4.1 ⚕︎ ) STAFF OF AESCULAPIUS
-2695 FE0F ; emoji style; # (4.1 ⚕️ ) STAFF OF AESCULAPIUS
-2696 FE0E ; text style; # (4.1 ⚖︎ ) SCALES
-2696 FE0F ; emoji style; # (4.1 ⚖️ ) SCALES
-2697 FE0E ; text style; # (4.1 ⚗︎ ) ALEMBIC
-2697 FE0F ; emoji style; # (4.1 ⚗️ ) ALEMBIC
-2699 FE0E ; text style; # (4.1 ⚙︎ ) GEAR
-2699 FE0F ; emoji style; # (4.1 ⚙️ ) GEAR
-269B FE0E ; text style; # (4.1 ⚛︎ ) ATOM SYMBOL
-269B FE0F ; emoji style; # (4.1 ⚛️ ) ATOM SYMBOL
-269C FE0E ; text style; # (4.1 ⚜︎ ) FLEUR-DE-LIS
-269C FE0F ; emoji style; # (4.1 ⚜️ ) FLEUR-DE-LIS
-26A0 FE0E ; text style; # (4.0 ⚠︎ ) WARNING SIGN
-26A0 FE0F ; emoji style; # (4.0 ⚠️ ) WARNING SIGN
-26A1 FE0E ; text style; # (4.0 ⚡︎ ) HIGH VOLTAGE SIGN
-26A1 FE0F ; emoji style; # (4.0 ⚡️ ) HIGH VOLTAGE SIGN
-26A7 FE0E ; text style; # (4.1 ⚧︎ ) MALE WITH STROKE AND MALE AND FEMALE SIGN
-26A7 FE0F ; emoji style; # (4.1 ⚧️ ) MALE WITH STROKE AND MALE AND FEMALE SIGN
-26AA FE0E ; text style; # (4.1 ⚪︎ ) MEDIUM WHITE CIRCLE
-26AA FE0F ; emoji style; # (4.1 ⚪️ ) MEDIUM WHITE CIRCLE
-26AB FE0E ; text style; # (4.1 ⚫︎ ) MEDIUM BLACK CIRCLE
-26AB FE0F ; emoji style; # (4.1 ⚫️ ) MEDIUM BLACK CIRCLE
-26B0 FE0E ; text style; # (4.1 ⚰︎ ) COFFIN
-26B0 FE0F ; emoji style; # (4.1 ⚰️ ) COFFIN
-26B1 FE0E ; text style; # (4.1 ⚱︎ ) FUNERAL URN
-26B1 FE0F ; emoji style; # (4.1 ⚱️ ) FUNERAL URN
-26BD FE0E ; text style; # (5.2 ⚽︎ ) SOCCER BALL
-26BD FE0F ; emoji style; # (5.2 ⚽️ ) SOCCER BALL
-26BE FE0E ; text style; # (5.2 ⚾︎ ) BASEBALL
-26BE FE0F ; emoji style; # (5.2 ⚾️ ) BASEBALL
-26C4 FE0E ; text style; # (5.2 ⛄︎ ) SNOWMAN WITHOUT SNOW
-26C4 FE0F ; emoji style; # (5.2 ⛄️ ) SNOWMAN WITHOUT SNOW
-26C5 FE0E ; text style; # (5.2 ⛅︎ ) SUN BEHIND CLOUD
-26C5 FE0F ; emoji style; # (5.2 ⛅️ ) SUN BEHIND CLOUD
-26C8 FE0E ; text style; # (5.2 ⛈︎ ) THUNDER CLOUD AND RAIN
-26C8 FE0F ; emoji style; # (5.2 ⛈️ ) THUNDER CLOUD AND RAIN
-26CF FE0E ; text style; # (5.2 ⛏︎ ) PICK
-26CF FE0F ; emoji style; # (5.2 ⛏️ ) PICK
-26D1 FE0E ; text style; # (5.2 ⛑︎ ) HELMET WITH WHITE CROSS
-26D1 FE0F ; emoji style; # (5.2 ⛑️ ) HELMET WITH WHITE CROSS
-26D3 FE0E ; text style; # (5.2 ⛓︎ ) CHAINS
-26D3 FE0F ; emoji style; # (5.2 ⛓️ ) CHAINS
-26D4 FE0E ; text style; # (5.2 ⛔︎ ) NO ENTRY
-26D4 FE0F ; emoji style; # (5.2 ⛔️ ) NO ENTRY
-26E9 FE0E ; text style; # (5.2 ⛩︎ ) SHINTO SHRINE
-26E9 FE0F ; emoji style; # (5.2 ⛩️ ) SHINTO SHRINE
-26EA FE0E ; text style; # (5.2 ⛪︎ ) CHURCH
-26EA FE0F ; emoji style; # (5.2 ⛪️ ) CHURCH
-26F0 FE0E ; text style; # (5.2 ⛰︎ ) MOUNTAIN
-26F0 FE0F ; emoji style; # (5.2 ⛰️ ) MOUNTAIN
-26F1 FE0E ; text style; # (5.2 ⛱︎ ) UMBRELLA ON GROUND
-26F1 FE0F ; emoji style; # (5.2 ⛱️ ) UMBRELLA ON GROUND
-26F2 FE0E ; text style; # (5.2 ⛲︎ ) FOUNTAIN
-26F2 FE0F ; emoji style; # (5.2 ⛲️ ) FOUNTAIN
-26F3 FE0E ; text style; # (5.2 ⛳︎ ) FLAG IN HOLE
-26F3 FE0F ; emoji style; # (5.2 ⛳️ ) FLAG IN HOLE
-26F4 FE0E ; text style; # (5.2 ⛴︎ ) FERRY
-26F4 FE0F ; emoji style; # (5.2 ⛴️ ) FERRY
-26F5 FE0E ; text style; # (5.2 ⛵︎ ) SAILBOAT
-26F5 FE0F ; emoji style; # (5.2 ⛵️ ) SAILBOAT
-26F7 FE0E ; text style; # (5.2 ⛷︎ ) SKIER
-26F7 FE0F ; emoji style; # (5.2 ⛷️ ) SKIER
-26F8 FE0E ; text style; # (5.2 ⛸︎ ) ICE SKATE
-26F8 FE0F ; emoji style; # (5.2 ⛸️ ) ICE SKATE
-26F9 FE0E ; text style; # (5.2 ⛹︎ ) PERSON WITH BALL
-26F9 FE0F ; emoji style; # (5.2 ⛹️ ) PERSON WITH BALL
-26FA FE0E ; text style; # (5.2 ⛺︎ ) TENT
-26FA FE0F ; emoji style; # (5.2 ⛺️ ) TENT
-26FD FE0E ; text style; # (5.2 ⛽︎ ) FUEL PUMP
-26FD FE0F ; emoji style; # (5.2 ⛽️ ) FUEL PUMP
-2702 FE0E ; text style; # (1.1 ✂︎ ) BLACK SCISSORS
-2702 FE0F ; emoji style; # (1.1 ✂️ ) BLACK SCISSORS
-2708 FE0E ; text style; # (1.1 ✈︎ ) AIRPLANE
-2708 FE0F ; emoji style; # (1.1 ✈️ ) AIRPLANE
-2709 FE0E ; text style; # (1.1 ✉︎ ) ENVELOPE
-2709 FE0F ; emoji style; # (1.1 ✉️ ) ENVELOPE
-270C FE0E ; text style; # (1.1 ✌︎ ) VICTORY HAND
-270C FE0F ; emoji style; # (1.1 ✌️ ) VICTORY HAND
-270D FE0E ; text style; # (1.1 ✍︎ ) WRITING HAND
-270D FE0F ; emoji style; # (1.1 ✍️ ) WRITING HAND
-270F FE0E ; text style; # (1.1 ✏︎ ) PENCIL
-270F FE0F ; emoji style; # (1.1 ✏️ ) PENCIL
-2712 FE0E ; text style; # (1.1 ✒︎ ) BLACK NIB
-2712 FE0F ; emoji style; # (1.1 ✒️ ) BLACK NIB
-2714 FE0E ; text style; # (1.1 ✔︎ ) HEAVY CHECK MARK
-2714 FE0F ; emoji style; # (1.1 ✔️ ) HEAVY CHECK MARK
-2716 FE0E ; text style; # (1.1 ✖︎ ) HEAVY MULTIPLICATION X
-2716 FE0F ; emoji style; # (1.1 ✖️ ) HEAVY MULTIPLICATION X
-271D FE0E ; text style; # (1.1 ✝︎ ) LATIN CROSS
-271D FE0F ; emoji style; # (1.1 ✝️ ) LATIN CROSS
-2721 FE0E ; text style; # (1.1 ✡︎ ) STAR OF DAVID
-2721 FE0F ; emoji style; # (1.1 ✡️ ) STAR OF DAVID
-2733 FE0E ; text style; # (1.1 ✳︎ ) EIGHT SPOKED ASTERISK
-2733 FE0F ; emoji style; # (1.1 ✳️ ) EIGHT SPOKED ASTERISK
-2734 FE0E ; text style; # (1.1 ✴︎ ) EIGHT POINTED BLACK STAR
-2734 FE0F ; emoji style; # (1.1 ✴️ ) EIGHT POINTED BLACK STAR
-2744 FE0E ; text style; # (1.1 ❄︎ ) SNOWFLAKE
-2744 FE0F ; emoji style; # (1.1 ❄️ ) SNOWFLAKE
-2747 FE0E ; text style; # (1.1 ❇︎ ) SPARKLE
-2747 FE0F ; emoji style; # (1.1 ❇️ ) SPARKLE
-2753 FE0E ; text style; # (6.0 ❓︎ ) BLACK QUESTION MARK ORNAMENT
-2753 FE0F ; emoji style; # (6.0 ❓️ ) BLACK QUESTION MARK ORNAMENT
-2757 FE0E ; text style; # (5.2 ❗︎ ) HEAVY EXCLAMATION MARK SYMBOL
-2757 FE0F ; emoji style; # (5.2 ❗️ ) HEAVY EXCLAMATION MARK SYMBOL
-2763 FE0E ; text style; # (1.1 ❣︎ ) HEAVY HEART EXCLAMATION MARK ORNAMENT
-2763 FE0F ; emoji style; # (1.1 ❣️ ) HEAVY HEART EXCLAMATION MARK ORNAMENT
-2764 FE0E ; text style; # (1.1 ❤︎ ) HEAVY BLACK HEART
-2764 FE0F ; emoji style; # (1.1 ❤️ ) HEAVY BLACK HEART
-27A1 FE0E ; text style; # (1.1 ➡︎ ) BLACK RIGHTWARDS ARROW
-27A1 FE0F ; emoji style; # (1.1 ➡️ ) BLACK RIGHTWARDS ARROW
-2934 FE0E ; text style; # (3.2 ⤴︎ ) ARROW POINTING RIGHTWARDS THEN CURVING UPWARDS
-2934 FE0F ; emoji style; # (3.2 ⤴️ ) ARROW POINTING RIGHTWARDS THEN CURVING UPWARDS
-2935 FE0E ; text style; # (3.2 ⤵︎ ) ARROW POINTING RIGHTWARDS THEN CURVING DOWNWARDS
-2935 FE0F ; emoji style; # (3.2 ⤵️ ) ARROW POINTING RIGHTWARDS THEN CURVING DOWNWARDS
-2B05 FE0E ; text style; # (4.0 ⬅︎ ) LEFTWARDS BLACK ARROW
-2B05 FE0F ; emoji style; # (4.0 ⬅️ ) LEFTWARDS BLACK ARROW
-2B06 FE0E ; text style; # (4.0 ⬆︎ ) UPWARDS BLACK ARROW
-2B06 FE0F ; emoji style; # (4.0 ⬆️ ) UPWARDS BLACK ARROW
-2B07 FE0E ; text style; # (4.0 ⬇︎ ) DOWNWARDS BLACK ARROW
-2B07 FE0F ; emoji style; # (4.0 ⬇️ ) DOWNWARDS BLACK ARROW
-2B1B FE0E ; text style; # (5.1 ⬛︎ ) BLACK LARGE SQUARE
-2B1B FE0F ; emoji style; # (5.1 ⬛️ ) BLACK LARGE SQUARE
-2B1C FE0E ; text style; # (5.1 ⬜︎ ) WHITE LARGE SQUARE
-2B1C FE0F ; emoji style; # (5.1 ⬜️ ) WHITE LARGE SQUARE
-2B50 FE0E ; text style; # (5.1 ⭐︎ ) WHITE MEDIUM STAR
-2B50 FE0F ; emoji style; # (5.1 ⭐️ ) WHITE MEDIUM STAR
-2B55 FE0E ; text style; # (5.2 ⭕︎ ) HEAVY LARGE CIRCLE
-2B55 FE0F ; emoji style; # (5.2 ⭕️ ) HEAVY LARGE CIRCLE
-3030 FE0E ; text style; # (1.1 〰︎ ) WAVY DASH
-3030 FE0F ; emoji style; # (1.1 〰️ ) WAVY DASH
-303D FE0E ; text style; # (3.2 〽︎ ) PART ALTERNATION MARK
-303D FE0F ; emoji style; # (3.2 〽️ ) PART ALTERNATION MARK
-3297 FE0E ; text style; # (1.1 ㊗︎ ) CIRCLED IDEOGRAPH CONGRATULATION
-3297 FE0F ; emoji style; # (1.1 ㊗️ ) CIRCLED IDEOGRAPH CONGRATULATION
-3299 FE0E ; text style; # (1.1 ㊙︎ ) CIRCLED IDEOGRAPH SECRET
-3299 FE0F ; emoji style; # (1.1 ㊙️ ) CIRCLED IDEOGRAPH SECRET
-1F004 FE0E ; text style; # (5.1 🀄︎ ) MAHJONG TILE RED DRAGON
-1F004 FE0F ; emoji style; # (5.1 🀄️ ) MAHJONG TILE RED DRAGON
-1F170 FE0E ; text style; # (6.0 🅰︎ ) NEGATIVE SQUARED LATIN CAPITAL LETTER A
-1F170 FE0F ; emoji style; # (6.0 🅰️ ) NEGATIVE SQUARED LATIN CAPITAL LETTER A
-1F171 FE0E ; text style; # (6.0 🅱︎ ) NEGATIVE SQUARED LATIN CAPITAL LETTER B
-1F171 FE0F ; emoji style; # (6.0 🅱️ ) NEGATIVE SQUARED LATIN CAPITAL LETTER B
-1F17E FE0E ; text style; # (6.0 🅾︎ ) NEGATIVE SQUARED LATIN CAPITAL LETTER O
-1F17E FE0F ; emoji style; # (6.0 🅾️ ) NEGATIVE SQUARED LATIN CAPITAL LETTER O
-1F17F FE0E ; text style; # (5.2 🅿︎ ) NEGATIVE SQUARED LATIN CAPITAL LETTER P
-1F17F FE0F ; emoji style; # (5.2 🅿️ ) NEGATIVE SQUARED LATIN CAPITAL LETTER P
-1F202 FE0E ; text style; # (6.0 🈂︎ ) SQUARED KATAKANA SA
-1F202 FE0F ; emoji style; # (6.0 🈂️ ) SQUARED KATAKANA SA
-1F21A FE0E ; text style; # (5.2 🈚︎ ) SQUARED CJK UNIFIED IDEOGRAPH-7121
-1F21A FE0F ; emoji style; # (5.2 🈚️ ) SQUARED CJK UNIFIED IDEOGRAPH-7121
-1F22F FE0E ; text style; # (5.2 🈯︎ ) SQUARED CJK UNIFIED IDEOGRAPH-6307
-1F22F FE0F ; emoji style; # (5.2 🈯️ ) SQUARED CJK UNIFIED IDEOGRAPH-6307
-1F237 FE0E ; text style; # (6.0 🈷︎ ) SQUARED CJK UNIFIED IDEOGRAPH-6708
-1F237 FE0F ; emoji style; # (6.0 🈷️ ) SQUARED CJK UNIFIED IDEOGRAPH-6708
-1F30D FE0E ; text style; # (6.0 🌍︎ ) EARTH GLOBE EUROPE-AFRICA
-1F30D FE0F ; emoji style; # (6.0 🌍️ ) EARTH GLOBE EUROPE-AFRICA
-1F30E FE0E ; text style; # (6.0 🌎︎ ) EARTH GLOBE AMERICAS
-1F30E FE0F ; emoji style; # (6.0 🌎️ ) EARTH GLOBE AMERICAS
-1F30F FE0E ; text style; # (6.0 🌏︎ ) EARTH GLOBE ASIA-AUSTRALIA
-1F30F FE0F ; emoji style; # (6.0 🌏️ ) EARTH GLOBE ASIA-AUSTRALIA
-1F315 FE0E ; text style; # (6.0 🌕︎ ) FULL MOON SYMBOL
-1F315 FE0F ; emoji style; # (6.0 🌕️ ) FULL MOON SYMBOL
-1F31C FE0E ; text style; # (6.0 🌜︎ ) LAST QUARTER MOON WITH FACE
-1F31C FE0F ; emoji style; # (6.0 🌜️ ) LAST QUARTER MOON WITH FACE
-1F321 FE0E ; text style; # (7.0 🌡︎ ) THERMOMETER
-1F321 FE0F ; emoji style; # (7.0 🌡️ ) THERMOMETER
-1F324 FE0E ; text style; # (7.0 🌤︎ ) WHITE SUN WITH SMALL CLOUD
-1F324 FE0F ; emoji style; # (7.0 🌤️ ) WHITE SUN WITH SMALL CLOUD
-1F325 FE0E ; text style; # (7.0 🌥︎ ) WHITE SUN BEHIND CLOUD
-1F325 FE0F ; emoji style; # (7.0 🌥️ ) WHITE SUN BEHIND CLOUD
-1F326 FE0E ; text style; # (7.0 🌦︎ ) WHITE SUN BEHIND CLOUD WITH RAIN
-1F326 FE0F ; emoji style; # (7.0 🌦️ ) WHITE SUN BEHIND CLOUD WITH RAIN
-1F327 FE0E ; text style; # (7.0 🌧︎ ) CLOUD WITH RAIN
-1F327 FE0F ; emoji style; # (7.0 🌧️ ) CLOUD WITH RAIN
-1F328 FE0E ; text style; # (7.0 🌨︎ ) CLOUD WITH SNOW
-1F328 FE0F ; emoji style; # (7.0 🌨️ ) CLOUD WITH SNOW
-1F329 FE0E ; text style; # (7.0 🌩︎ ) CLOUD WITH LIGHTNING
-1F329 FE0F ; emoji style; # (7.0 🌩️ ) CLOUD WITH LIGHTNING
-1F32A FE0E ; text style; # (7.0 🌪︎ ) CLOUD WITH TORNADO
-1F32A FE0F ; emoji style; # (7.0 🌪️ ) CLOUD WITH TORNADO
-1F32B FE0E ; text style; # (7.0 🌫︎ ) FOG
-1F32B FE0F ; emoji style; # (7.0 🌫️ ) FOG
-1F32C FE0E ; text style; # (7.0 🌬︎ ) WIND BLOWING FACE
-1F32C FE0F ; emoji style; # (7.0 🌬️ ) WIND BLOWING FACE
-1F336 FE0E ; text style; # (7.0 🌶︎ ) HOT PEPPER
-1F336 FE0F ; emoji style; # (7.0 🌶️ ) HOT PEPPER
-1F378 FE0E ; text style; # (6.0 🍸︎ ) COCKTAIL GLASS
-1F378 FE0F ; emoji style; # (6.0 🍸️ ) COCKTAIL GLASS
-1F37D FE0E ; text style; # (7.0 🍽︎ ) FORK AND KNIFE WITH PLATE
-1F37D FE0F ; emoji style; # (7.0 🍽️ ) FORK AND KNIFE WITH PLATE
-1F393 FE0E ; text style; # (6.0 🎓︎ ) GRADUATION CAP
-1F393 FE0F ; emoji style; # (6.0 🎓️ ) GRADUATION CAP
-1F396 FE0E ; text style; # (7.0 🎖︎ ) MILITARY MEDAL
-1F396 FE0F ; emoji style; # (7.0 🎖️ ) MILITARY MEDAL
-1F397 FE0E ; text style; # (7.0 🎗︎ ) REMINDER RIBBON
-1F397 FE0F ; emoji style; # (7.0 🎗️ ) REMINDER RIBBON
-1F399 FE0E ; text style; # (7.0 🎙︎ ) STUDIO MICROPHONE
-1F399 FE0F ; emoji style; # (7.0 🎙️ ) STUDIO MICROPHONE
-1F39A FE0E ; text style; # (7.0 🎚︎ ) LEVEL SLIDER
-1F39A FE0F ; emoji style; # (7.0 🎚️ ) LEVEL SLIDER
-1F39B FE0E ; text style; # (7.0 🎛︎ ) CONTROL KNOBS
-1F39B FE0F ; emoji style; # (7.0 🎛️ ) CONTROL KNOBS
-1F39E FE0E ; text style; # (7.0 🎞︎ ) FILM FRAMES
-1F39E FE0F ; emoji style; # (7.0 🎞️ ) FILM FRAMES
-1F39F FE0E ; text style; # (7.0 🎟︎ ) ADMISSION TICKETS
-1F39F FE0F ; emoji style; # (7.0 🎟️ ) ADMISSION TICKETS
-1F3A7 FE0E ; text style; # (6.0 🎧︎ ) HEADPHONE
-1F3A7 FE0F ; emoji style; # (6.0 🎧️ ) HEADPHONE
-1F3AC FE0E ; text style; # (6.0 🎬︎ ) CLAPPER BOARD
-1F3AC FE0F ; emoji style; # (6.0 🎬️ ) CLAPPER BOARD
-1F3AD FE0E ; text style; # (6.0 🎭︎ ) PERFORMING ARTS
-1F3AD FE0F ; emoji style; # (6.0 🎭️ ) PERFORMING ARTS
-1F3AE FE0E ; text style; # (6.0 🎮︎ ) VIDEO GAME
-1F3AE FE0F ; emoji style; # (6.0 🎮️ ) VIDEO GAME
-1F3C2 FE0E ; text style; # (6.0 🏂︎ ) SNOWBOARDER
-1F3C2 FE0F ; emoji style; # (6.0 🏂️ ) SNOWBOARDER
-1F3C4 FE0E ; text style; # (6.0 🏄︎ ) SURFER
-1F3C4 FE0F ; emoji style; # (6.0 🏄️ ) SURFER
-1F3C6 FE0E ; text style; # (6.0 🏆︎ ) TROPHY
-1F3C6 FE0F ; emoji style; # (6.0 🏆️ ) TROPHY
-1F3CA FE0E ; text style; # (6.0 🏊︎ ) SWIMMER
-1F3CA FE0F ; emoji style; # (6.0 🏊️ ) SWIMMER
-1F3CB FE0E ; text style; # (7.0 🏋︎ ) WEIGHT LIFTER
-1F3CB FE0F ; emoji style; # (7.0 🏋️ ) WEIGHT LIFTER
-1F3CC FE0E ; text style; # (7.0 🏌︎ ) GOLFER
-1F3CC FE0F ; emoji style; # (7.0 🏌️ ) GOLFER
-1F3CD FE0E ; text style; # (7.0 🏍︎ ) RACING MOTORCYCLE
-1F3CD FE0F ; emoji style; # (7.0 🏍️ ) RACING MOTORCYCLE
-1F3CE FE0E ; text style; # (7.0 🏎︎ ) RACING CAR
-1F3CE FE0F ; emoji style; # (7.0 🏎️ ) RACING CAR
-1F3D4 FE0E ; text style; # (7.0 🏔︎ ) SNOW CAPPED MOUNTAIN
-1F3D4 FE0F ; emoji style; # (7.0 🏔️ ) SNOW CAPPED MOUNTAIN
-1F3D5 FE0E ; text style; # (7.0 🏕︎ ) CAMPING
-1F3D5 FE0F ; emoji style; # (7.0 🏕️ ) CAMPING
-1F3D6 FE0E ; text style; # (7.0 🏖︎ ) BEACH WITH UMBRELLA
-1F3D6 FE0F ; emoji style; # (7.0 🏖️ ) BEACH WITH UMBRELLA
-1F3D7 FE0E ; text style; # (7.0 🏗︎ ) BUILDING CONSTRUCTION
-1F3D7 FE0F ; emoji style; # (7.0 🏗️ ) BUILDING CONSTRUCTION
-1F3D8 FE0E ; text style; # (7.0 🏘︎ ) HOUSE BUILDINGS
-1F3D8 FE0F ; emoji style; # (7.0 🏘️ ) HOUSE BUILDINGS
-1F3D9 FE0E ; text style; # (7.0 🏙︎ ) CITYSCAPE
-1F3D9 FE0F ; emoji style; # (7.0 🏙️ ) CITYSCAPE
-1F3DA FE0E ; text style; # (7.0 🏚︎ ) DERELICT HOUSE BUILDING
-1F3DA FE0F ; emoji style; # (7.0 🏚️ ) DERELICT HOUSE BUILDING
-1F3DB FE0E ; text style; # (7.0 🏛︎ ) CLASSICAL BUILDING
-1F3DB FE0F ; emoji style; # (7.0 🏛️ ) CLASSICAL BUILDING
-1F3DC FE0E ; text style; # (7.0 🏜︎ ) DESERT
-1F3DC FE0F ; emoji style; # (7.0 🏜️ ) DESERT
-1F3DD FE0E ; text style; # (7.0 🏝︎ ) DESERT ISLAND
-1F3DD FE0F ; emoji style; # (7.0 🏝️ ) DESERT ISLAND
-1F3DE FE0E ; text style; # (7.0 🏞︎ ) NATIONAL PARK
-1F3DE FE0F ; emoji style; # (7.0 🏞️ ) NATIONAL PARK
-1F3DF FE0E ; text style; # (7.0 🏟︎ ) STADIUM
-1F3DF FE0F ; emoji style; # (7.0 🏟️ ) STADIUM
-1F3E0 FE0E ; text style; # (6.0 🏠︎ ) HOUSE BUILDING
-1F3E0 FE0F ; emoji style; # (6.0 🏠️ ) HOUSE BUILDING
-1F3ED FE0E ; text style; # (6.0 🏭︎ ) FACTORY
-1F3ED FE0F ; emoji style; # (6.0 🏭️ ) FACTORY
-1F3F3 FE0E ; text style; # (7.0 🏳︎ ) WAVING WHITE FLAG
-1F3F3 FE0F ; emoji style; # (7.0 🏳️ ) WAVING WHITE FLAG
-1F3F5 FE0E ; text style; # (7.0 🏵︎ ) ROSETTE
-1F3F5 FE0F ; emoji style; # (7.0 🏵️ ) ROSETTE
-1F3F7 FE0E ; text style; # (7.0 🏷︎ ) LABEL
-1F3F7 FE0F ; emoji style; # (7.0 🏷️ ) LABEL
-1F408 FE0E ; text style; # (6.0 🐈︎ ) CAT
-1F408 FE0F ; emoji style; # (6.0 🐈️ ) CAT
-1F415 FE0E ; text style; # (6.0 🐕︎ ) DOG
-1F415 FE0F ; emoji style; # (6.0 🐕️ ) DOG
-1F41F FE0E ; text style; # (6.0 🐟︎ ) FISH
-1F41F FE0F ; emoji style; # (6.0 🐟️ ) FISH
-1F426 FE0E ; text style; # (6.0 🐦︎ ) BIRD
-1F426 FE0F ; emoji style; # (6.0 🐦️ ) BIRD
-1F43F FE0E ; text style; # (7.0 🐿︎ ) CHIPMUNK
-1F43F FE0F ; emoji style; # (7.0 🐿️ ) CHIPMUNK
-1F441 FE0E ; text style; # (7.0 👁︎ ) EYE
-1F441 FE0F ; emoji style; # (7.0 👁️ ) EYE
-1F442 FE0E ; text style; # (6.0 👂︎ ) EAR
-1F442 FE0F ; emoji style; # (6.0 👂️ ) EAR
-1F446 FE0E ; text style; # (6.0 👆︎ ) WHITE UP POINTING BACKHAND INDEX
-1F446 FE0F ; emoji style; # (6.0 👆️ ) WHITE UP POINTING BACKHAND INDEX
-1F447 FE0E ; text style; # (6.0 👇︎ ) WHITE DOWN POINTING BACKHAND INDEX
-1F447 FE0F ; emoji style; # (6.0 👇️ ) WHITE DOWN POINTING BACKHAND INDEX
-1F448 FE0E ; text style; # (6.0 👈︎ ) WHITE LEFT POINTING BACKHAND INDEX
-1F448 FE0F ; emoji style; # (6.0 👈️ ) WHITE LEFT POINTING BACKHAND INDEX
-1F449 FE0E ; text style; # (6.0 👉︎ ) WHITE RIGHT POINTING BACKHAND INDEX
-1F449 FE0F ; emoji style; # (6.0 👉️ ) WHITE RIGHT POINTING BACKHAND INDEX
-1F44D FE0E ; text style; # (6.0 👍︎ ) THUMBS UP SIGN
-1F44D FE0F ; emoji style; # (6.0 👍️ ) THUMBS UP SIGN
-1F44E FE0E ; text style; # (6.0 👎︎ ) THUMBS DOWN SIGN
-1F44E FE0F ; emoji style; # (6.0 👎️ ) THUMBS DOWN SIGN
-1F453 FE0E ; text style; # (6.0 👓︎ ) EYEGLASSES
-1F453 FE0F ; emoji style; # (6.0 👓️ ) EYEGLASSES
-1F46A FE0E ; text style; # (6.0 👪︎ ) FAMILY
-1F46A FE0F ; emoji style; # (6.0 👪️ ) FAMILY
-1F47D FE0E ; text style; # (6.0 👽︎ ) EXTRATERRESTRIAL ALIEN
-1F47D FE0F ; emoji style; # (6.0 👽️ ) EXTRATERRESTRIAL ALIEN
-1F4A3 FE0E ; text style; # (6.0 💣︎ ) BOMB
-1F4A3 FE0F ; emoji style; # (6.0 💣️ ) BOMB
-1F4B0 FE0E ; text style; # (6.0 💰︎ ) MONEY BAG
-1F4B0 FE0F ; emoji style; # (6.0 💰️ ) MONEY BAG
-1F4B3 FE0E ; text style; # (6.0 💳︎ ) CREDIT CARD
-1F4B3 FE0F ; emoji style; # (6.0 💳️ ) CREDIT CARD
-1F4BB FE0E ; text style; # (6.0 💻︎ ) PERSONAL COMPUTER
-1F4BB FE0F ; emoji style; # (6.0 💻️ ) PERSONAL COMPUTER
-1F4BF FE0E ; text style; # (6.0 💿︎ ) OPTICAL DISC
-1F4BF FE0F ; emoji style; # (6.0 💿️ ) OPTICAL DISC
-1F4CB FE0E ; text style; # (6.0 📋︎ ) CLIPBOARD
-1F4CB FE0F ; emoji style; # (6.0 📋️ ) CLIPBOARD
-1F4DA FE0E ; text style; # (6.0 📚︎ ) BOOKS
-1F4DA FE0F ; emoji style; # (6.0 📚️ ) BOOKS
-1F4DF FE0E ; text style; # (6.0 📟︎ ) PAGER
-1F4DF FE0F ; emoji style; # (6.0 📟️ ) PAGER
-1F4E4 FE0E ; text style; # (6.0 📤︎ ) OUTBOX TRAY
-1F4E4 FE0F ; emoji style; # (6.0 📤️ ) OUTBOX TRAY
-1F4E5 FE0E ; text style; # (6.0 📥︎ ) INBOX TRAY
-1F4E5 FE0F ; emoji style; # (6.0 📥️ ) INBOX TRAY
-1F4E6 FE0E ; text style; # (6.0 📦︎ ) PACKAGE
-1F4E6 FE0F ; emoji style; # (6.0 📦️ ) PACKAGE
-1F4EA FE0E ; text style; # (6.0 📪︎ ) CLOSED MAILBOX WITH LOWERED FLAG
-1F4EA FE0F ; emoji style; # (6.0 📪️ ) CLOSED MAILBOX WITH LOWERED FLAG
-1F4EB FE0E ; text style; # (6.0 📫︎ ) CLOSED MAILBOX WITH RAISED FLAG
-1F4EB FE0F ; emoji style; # (6.0 📫️ ) CLOSED MAILBOX WITH RAISED FLAG
-1F4EC FE0E ; text style; # (6.0 📬︎ ) OPEN MAILBOX WITH RAISED FLAG
-1F4EC FE0F ; emoji style; # (6.0 📬️ ) OPEN MAILBOX WITH RAISED FLAG
-1F4ED FE0E ; text style; # (6.0 📭︎ ) OPEN MAILBOX WITH LOWERED FLAG
-1F4ED FE0F ; emoji style; # (6.0 📭️ ) OPEN MAILBOX WITH LOWERED FLAG
-1F4F7 FE0E ; text style; # (6.0 📷︎ ) CAMERA
-1F4F7 FE0F ; emoji style; # (6.0 📷️ ) CAMERA
-1F4F9 FE0E ; text style; # (6.0 📹︎ ) VIDEO CAMERA
-1F4F9 FE0F ; emoji style; # (6.0 📹️ ) VIDEO CAMERA
-1F4FA FE0E ; text style; # (6.0 📺︎ ) TELEVISION
-1F4FA FE0F ; emoji style; # (6.0 📺️ ) TELEVISION
-1F4FB FE0E ; text style; # (6.0 📻︎ ) RADIO
-1F4FB FE0F ; emoji style; # (6.0 📻️ ) RADIO
-1F4FD FE0E ; text style; # (7.0 📽︎ ) FILM PROJECTOR
-1F4FD FE0F ; emoji style; # (7.0 📽️ ) FILM PROJECTOR
-1F508 FE0E ; text style; # (6.0 🔈︎ ) SPEAKER
-1F508 FE0F ; emoji style; # (6.0 🔈️ ) SPEAKER
-1F50D FE0E ; text style; # (6.0 🔍︎ ) LEFT-POINTING MAGNIFYING GLASS
-1F50D FE0F ; emoji style; # (6.0 🔍️ ) LEFT-POINTING MAGNIFYING GLASS
-1F512 FE0E ; text style; # (6.0 🔒︎ ) LOCK
-1F512 FE0F ; emoji style; # (6.0 🔒️ ) LOCK
-1F513 FE0E ; text style; # (6.0 🔓︎ ) OPEN LOCK
-1F513 FE0F ; emoji style; # (6.0 🔓️ ) OPEN LOCK
-1F549 FE0E ; text style; # (7.0 🕉︎ ) OM SYMBOL
-1F549 FE0F ; emoji style; # (7.0 🕉️ ) OM SYMBOL
-1F54A FE0E ; text style; # (7.0 🕊︎ ) DOVE OF PEACE
-1F54A FE0F ; emoji style; # (7.0 🕊️ ) DOVE OF PEACE
-1F550 FE0E ; text style; # (6.0 🕐︎ ) CLOCK FACE ONE OCLOCK
-1F550 FE0F ; emoji style; # (6.0 🕐️ ) CLOCK FACE ONE OCLOCK
-1F551 FE0E ; text style; # (6.0 🕑︎ ) CLOCK FACE TWO OCLOCK
-1F551 FE0F ; emoji style; # (6.0 🕑️ ) CLOCK FACE TWO OCLOCK
-1F552 FE0E ; text style; # (6.0 🕒︎ ) CLOCK FACE THREE OCLOCK
-1F552 FE0F ; emoji style; # (6.0 🕒️ ) CLOCK FACE THREE OCLOCK
-1F553 FE0E ; text style; # (6.0 🕓︎ ) CLOCK FACE FOUR OCLOCK
-1F553 FE0F ; emoji style; # (6.0 🕓️ ) CLOCK FACE FOUR OCLOCK
-1F554 FE0E ; text style; # (6.0 🕔︎ ) CLOCK FACE FIVE OCLOCK
-1F554 FE0F ; emoji style; # (6.0 🕔️ ) CLOCK FACE FIVE OCLOCK
-1F555 FE0E ; text style; # (6.0 🕕︎ ) CLOCK FACE SIX OCLOCK
-1F555 FE0F ; emoji style; # (6.0 🕕️ ) CLOCK FACE SIX OCLOCK
-1F556 FE0E ; text style; # (6.0 🕖︎ ) CLOCK FACE SEVEN OCLOCK
-1F556 FE0F ; emoji style; # (6.0 🕖️ ) CLOCK FACE SEVEN OCLOCK
-1F557 FE0E ; text style; # (6.0 🕗︎ ) CLOCK FACE EIGHT OCLOCK
-1F557 FE0F ; emoji style; # (6.0 🕗️ ) CLOCK FACE EIGHT OCLOCK
-1F558 FE0E ; text style; # (6.0 🕘︎ ) CLOCK FACE NINE OCLOCK
-1F558 FE0F ; emoji style; # (6.0 🕘️ ) CLOCK FACE NINE OCLOCK
-1F559 FE0E ; text style; # (6.0 🕙︎ ) CLOCK FACE TEN OCLOCK
-1F559 FE0F ; emoji style; # (6.0 🕙️ ) CLOCK FACE TEN OCLOCK
-1F55A FE0E ; text style; # (6.0 🕚︎ ) CLOCK FACE ELEVEN OCLOCK
-1F55A FE0F ; emoji style; # (6.0 🕚️ ) CLOCK FACE ELEVEN OCLOCK
-1F55B FE0E ; text style; # (6.0 🕛︎ ) CLOCK FACE TWELVE OCLOCK
-1F55B FE0F ; emoji style; # (6.0 🕛️ ) CLOCK FACE TWELVE OCLOCK
-1F55C FE0E ; text style; # (6.0 🕜︎ ) CLOCK FACE ONE-THIRTY
-1F55C FE0F ; emoji style; # (6.0 🕜️ ) CLOCK FACE ONE-THIRTY
-1F55D FE0E ; text style; # (6.0 🕝︎ ) CLOCK FACE TWO-THIRTY
-1F55D FE0F ; emoji style; # (6.0 🕝️ ) CLOCK FACE TWO-THIRTY
-1F55E FE0E ; text style; # (6.0 🕞︎ ) CLOCK FACE THREE-THIRTY
-1F55E FE0F ; emoji style; # (6.0 🕞️ ) CLOCK FACE THREE-THIRTY
-1F55F FE0E ; text style; # (6.0 🕟︎ ) CLOCK FACE FOUR-THIRTY
-1F55F FE0F ; emoji style; # (6.0 🕟️ ) CLOCK FACE FOUR-THIRTY
-1F560 FE0E ; text style; # (6.0 🕠︎ ) CLOCK FACE FIVE-THIRTY
-1F560 FE0F ; emoji style; # (6.0 🕠️ ) CLOCK FACE FIVE-THIRTY
-1F561 FE0E ; text style; # (6.0 🕡︎ ) CLOCK FACE SIX-THIRTY
-1F561 FE0F ; emoji style; # (6.0 🕡️ ) CLOCK FACE SIX-THIRTY
-1F562 FE0E ; text style; # (6.0 🕢︎ ) CLOCK FACE SEVEN-THIRTY
-1F562 FE0F ; emoji style; # (6.0 🕢️ ) CLOCK FACE SEVEN-THIRTY
-1F563 FE0E ; text style; # (6.0 🕣︎ ) CLOCK FACE EIGHT-THIRTY
-1F563 FE0F ; emoji style; # (6.0 🕣️ ) CLOCK FACE EIGHT-THIRTY
-1F564 FE0E ; text style; # (6.0 🕤︎ ) CLOCK FACE NINE-THIRTY
-1F564 FE0F ; emoji style; # (6.0 🕤️ ) CLOCK FACE NINE-THIRTY
-1F565 FE0E ; text style; # (6.0 🕥︎ ) CLOCK FACE TEN-THIRTY
-1F565 FE0F ; emoji style; # (6.0 🕥️ ) CLOCK FACE TEN-THIRTY
-1F566 FE0E ; text style; # (6.0 🕦︎ ) CLOCK FACE ELEVEN-THIRTY
-1F566 FE0F ; emoji style; # (6.0 🕦️ ) CLOCK FACE ELEVEN-THIRTY
-1F567 FE0E ; text style; # (6.0 🕧︎ ) CLOCK FACE TWELVE-THIRTY
-1F567 FE0F ; emoji style; # (6.0 🕧️ ) CLOCK FACE TWELVE-THIRTY
-1F56F FE0E ; text style; # (7.0 🕯︎ ) CANDLE
-1F56F FE0F ; emoji style; # (7.0 🕯️ ) CANDLE
-1F570 FE0E ; text style; # (7.0 🕰︎ ) MANTELPIECE CLOCK
-1F570 FE0F ; emoji style; # (7.0 🕰️ ) MANTELPIECE CLOCK
-1F573 FE0E ; text style; # (7.0 🕳︎ ) HOLE
-1F573 FE0F ; emoji style; # (7.0 🕳️ ) HOLE
-1F574 FE0E ; text style; # (7.0 🕴︎ ) MAN IN BUSINESS SUIT LEVITATING
-1F574 FE0F ; emoji style; # (7.0 🕴️ ) MAN IN BUSINESS SUIT LEVITATING
-1F575 FE0E ; text style; # (7.0 🕵︎ ) SLEUTH OR SPY
-1F575 FE0F ; emoji style; # (7.0 🕵️ ) SLEUTH OR SPY
-1F576 FE0E ; text style; # (7.0 🕶︎ ) DARK SUNGLASSES
-1F576 FE0F ; emoji style; # (7.0 🕶️ ) DARK SUNGLASSES
-1F577 FE0E ; text style; # (7.0 🕷︎ ) SPIDER
-1F577 FE0F ; emoji style; # (7.0 🕷️ ) SPIDER
-1F578 FE0E ; text style; # (7.0 🕸︎ ) SPIDER WEB
-1F578 FE0F ; emoji style; # (7.0 🕸️ ) SPIDER WEB
-1F579 FE0E ; text style; # (7.0 🕹︎ ) JOYSTICK
-1F579 FE0F ; emoji style; # (7.0 🕹️ ) JOYSTICK
-1F587 FE0E ; text style; # (7.0 🖇︎ ) LINKED PAPERCLIPS
-1F587 FE0F ; emoji style; # (7.0 🖇️ ) LINKED PAPERCLIPS
-1F58A FE0E ; text style; # (7.0 🖊︎ ) LOWER LEFT BALLPOINT PEN
-1F58A FE0F ; emoji style; # (7.0 🖊️ ) LOWER LEFT BALLPOINT PEN
-1F58B FE0E ; text style; # (7.0 🖋︎ ) LOWER LEFT FOUNTAIN PEN
-1F58B FE0F ; emoji style; # (7.0 🖋️ ) LOWER LEFT FOUNTAIN PEN
-1F58C FE0E ; text style; # (7.0 🖌︎ ) LOWER LEFT PAINTBRUSH
-1F58C FE0F ; emoji style; # (7.0 🖌️ ) LOWER LEFT PAINTBRUSH
-1F58D FE0E ; text style; # (7.0 🖍︎ ) LOWER LEFT CRAYON
-1F58D FE0F ; emoji style; # (7.0 🖍️ ) LOWER LEFT CRAYON
-1F590 FE0E ; text style; # (7.0 🖐︎ ) RAISED HAND WITH FINGERS SPLAYED
-1F590 FE0F ; emoji style; # (7.0 🖐️ ) RAISED HAND WITH FINGERS SPLAYED
-1F5A5 FE0E ; text style; # (7.0 🖥︎ ) DESKTOP COMPUTER
-1F5A5 FE0F ; emoji style; # (7.0 🖥️ ) DESKTOP COMPUTER
-1F5A8 FE0E ; text style; # (7.0 🖨︎ ) PRINTER
-1F5A8 FE0F ; emoji style; # (7.0 🖨️ ) PRINTER
-1F5B1 FE0E ; text style; # (7.0 🖱︎ ) THREE BUTTON MOUSE
-1F5B1 FE0F ; emoji style; # (7.0 🖱️ ) THREE BUTTON MOUSE
-1F5B2 FE0E ; text style; # (7.0 🖲︎ ) TRACKBALL
-1F5B2 FE0F ; emoji style; # (7.0 🖲️ ) TRACKBALL
-1F5BC FE0E ; text style; # (7.0 🖼︎ ) FRAME WITH PICTURE
-1F5BC FE0F ; emoji style; # (7.0 🖼️ ) FRAME WITH PICTURE
-1F5C2 FE0E ; text style; # (7.0 🗂︎ ) CARD INDEX DIVIDERS
-1F5C2 FE0F ; emoji style; # (7.0 🗂️ ) CARD INDEX DIVIDERS
-1F5C3 FE0E ; text style; # (7.0 🗃︎ ) CARD FILE BOX
-1F5C3 FE0F ; emoji style; # (7.0 🗃️ ) CARD FILE BOX
-1F5C4 FE0E ; text style; # (7.0 🗄︎ ) FILE CABINET
-1F5C4 FE0F ; emoji style; # (7.0 🗄️ ) FILE CABINET
-1F5D1 FE0E ; text style; # (7.0 🗑︎ ) WASTEBASKET
-1F5D1 FE0F ; emoji style; # (7.0 🗑️ ) WASTEBASKET
-1F5D2 FE0E ; text style; # (7.0 🗒︎ ) SPIRAL NOTE PAD
-1F5D2 FE0F ; emoji style; # (7.0 🗒️ ) SPIRAL NOTE PAD
-1F5D3 FE0E ; text style; # (7.0 🗓︎ ) SPIRAL CALENDAR PAD
-1F5D3 FE0F ; emoji style; # (7.0 🗓️ ) SPIRAL CALENDAR PAD
-1F5DC FE0E ; text style; # (7.0 🗜︎ ) COMPRESSION
-1F5DC FE0F ; emoji style; # (7.0 🗜️ ) COMPRESSION
-1F5DD FE0E ; text style; # (7.0 🗝︎ ) OLD KEY
-1F5DD FE0F ; emoji style; # (7.0 🗝️ ) OLD KEY
-1F5DE FE0E ; text style; # (7.0 🗞︎ ) ROLLED-UP NEWSPAPER
-1F5DE FE0F ; emoji style; # (7.0 🗞️ ) ROLLED-UP NEWSPAPER
-1F5E1 FE0E ; text style; # (7.0 🗡︎ ) DAGGER KNIFE
-1F5E1 FE0F ; emoji style; # (7.0 🗡️ ) DAGGER KNIFE
-1F5E3 FE0E ; text style; # (7.0 🗣︎ ) SPEAKING HEAD IN SILHOUETTE
-1F5E3 FE0F ; emoji style; # (7.0 🗣️ ) SPEAKING HEAD IN SILHOUETTE
-1F5E8 FE0E ; text style; # (7.0 🗨︎ ) LEFT SPEECH BUBBLE
-1F5E8 FE0F ; emoji style; # (7.0 🗨️ ) LEFT SPEECH BUBBLE
-1F5EF FE0E ; text style; # (7.0 🗯︎ ) RIGHT ANGER BUBBLE
-1F5EF FE0F ; emoji style; # (7.0 🗯️ ) RIGHT ANGER BUBBLE
-1F5F3 FE0E ; text style; # (7.0 🗳︎ ) BALLOT BOX WITH BALLOT
-1F5F3 FE0F ; emoji style; # (7.0 🗳️ ) BALLOT BOX WITH BALLOT
-1F5FA FE0E ; text style; # (7.0 🗺︎ ) WORLD MAP
-1F5FA FE0F ; emoji style; # (7.0 🗺️ ) WORLD MAP
-1F610 FE0E ; text style; # (6.0 😐︎ ) NEUTRAL FACE
-1F610 FE0F ; emoji style; # (6.0 😐️ ) NEUTRAL FACE
-1F687 FE0E ; text style; # (6.0 🚇︎ ) METRO
-1F687 FE0F ; emoji style; # (6.0 🚇️ ) METRO
-1F68D FE0E ; text style; # (6.0 🚍︎ ) ONCOMING BUS
-1F68D FE0F ; emoji style; # (6.0 🚍️ ) ONCOMING BUS
-1F691 FE0E ; text style; # (6.0 🚑︎ ) AMBULANCE
-1F691 FE0F ; emoji style; # (6.0 🚑️ ) AMBULANCE
-1F694 FE0E ; text style; # (6.0 🚔︎ ) ONCOMING POLICE CAR
-1F694 FE0F ; emoji style; # (6.0 🚔️ ) ONCOMING POLICE CAR
-1F698 FE0E ; text style; # (6.0 🚘︎ ) ONCOMING AUTOMOBILE
-1F698 FE0F ; emoji style; # (6.0 🚘️ ) ONCOMING AUTOMOBILE
-1F6AD FE0E ; text style; # (6.0 🚭︎ ) NO SMOKING SYMBOL
-1F6AD FE0F ; emoji style; # (6.0 🚭️ ) NO SMOKING SYMBOL
-1F6B2 FE0E ; text style; # (6.0 🚲︎ ) BICYCLE
-1F6B2 FE0F ; emoji style; # (6.0 🚲️ ) BICYCLE
-1F6B9 FE0E ; text style; # (6.0 🚹︎ ) MENS SYMBOL
-1F6B9 FE0F ; emoji style; # (6.0 🚹️ ) MENS SYMBOL
-1F6BA FE0E ; text style; # (6.0 🚺︎ ) WOMENS SYMBOL
-1F6BA FE0F ; emoji style; # (6.0 🚺️ ) WOMENS SYMBOL
-1F6BC FE0E ; text style; # (6.0 🚼︎ ) BABY SYMBOL
-1F6BC FE0F ; emoji style; # (6.0 🚼️ ) BABY SYMBOL
-1F6CB FE0E ; text style; # (7.0 🛋︎ ) COUCH AND LAMP
-1F6CB FE0F ; emoji style; # (7.0 🛋️ ) COUCH AND LAMP
-1F6CD FE0E ; text style; # (7.0 🛍︎ ) SHOPPING BAGS
-1F6CD FE0F ; emoji style; # (7.0 🛍️ ) SHOPPING BAGS
-1F6CE FE0E ; text style; # (7.0 🛎︎ ) BELLHOP BELL
-1F6CE FE0F ; emoji style; # (7.0 🛎️ ) BELLHOP BELL
-1F6CF FE0E ; text style; # (7.0 🛏︎ ) BED
-1F6CF FE0F ; emoji style; # (7.0 🛏️ ) BED
-1F6E0 FE0E ; text style; # (7.0 🛠︎ ) HAMMER AND WRENCH
-1F6E0 FE0F ; emoji style; # (7.0 🛠️ ) HAMMER AND WRENCH
-1F6E1 FE0E ; text style; # (7.0 🛡︎ ) SHIELD
-1F6E1 FE0F ; emoji style; # (7.0 🛡️ ) SHIELD
-1F6E2 FE0E ; text style; # (7.0 🛢︎ ) OIL DRUM
-1F6E2 FE0F ; emoji style; # (7.0 🛢️ ) OIL DRUM
-1F6E3 FE0E ; text style; # (7.0 🛣︎ ) MOTORWAY
-1F6E3 FE0F ; emoji style; # (7.0 🛣️ ) MOTORWAY
-1F6E4 FE0E ; text style; # (7.0 🛤︎ ) RAILWAY TRACK
-1F6E4 FE0F ; emoji style; # (7.0 🛤️ ) RAILWAY TRACK
-1F6E5 FE0E ; text style; # (7.0 🛥︎ ) MOTOR BOAT
-1F6E5 FE0F ; emoji style; # (7.0 🛥️ ) MOTOR BOAT
-1F6E9 FE0E ; text style; # (7.0 🛩︎ ) SMALL AIRPLANE
-1F6E9 FE0F ; emoji style; # (7.0 🛩️ ) SMALL AIRPLANE
-1F6F0 FE0E ; text style; # (7.0 🛰︎ ) SATELLITE
-1F6F0 FE0F ; emoji style; # (7.0 🛰️ ) SATELLITE
-1F6F3 FE0E ; text style; # (7.0 🛳︎ ) PASSENGER SHIP
-1F6F3 FE0F ; emoji style; # (7.0 🛳️ ) PASSENGER SHIP
+0023 FE0E ; text style; # (1.1) NUMBER SIGN
+0023 FE0F ; emoji style; # (1.1) NUMBER SIGN
+002A FE0E ; text style; # (1.1) ASTERISK
+002A FE0F ; emoji style; # (1.1) ASTERISK
+0030 FE0E ; text style; # (1.1) DIGIT ZERO
+0030 FE0F ; emoji style; # (1.1) DIGIT ZERO
+0031 FE0E ; text style; # (1.1) DIGIT ONE
+0031 FE0F ; emoji style; # (1.1) DIGIT ONE
+0032 FE0E ; text style; # (1.1) DIGIT TWO
+0032 FE0F ; emoji style; # (1.1) DIGIT TWO
+0033 FE0E ; text style; # (1.1) DIGIT THREE
+0033 FE0F ; emoji style; # (1.1) DIGIT THREE
+0034 FE0E ; text style; # (1.1) DIGIT FOUR
+0034 FE0F ; emoji style; # (1.1) DIGIT FOUR
+0035 FE0E ; text style; # (1.1) DIGIT FIVE
+0035 FE0F ; emoji style; # (1.1) DIGIT FIVE
+0036 FE0E ; text style; # (1.1) DIGIT SIX
+0036 FE0F ; emoji style; # (1.1) DIGIT SIX
+0037 FE0E ; text style; # (1.1) DIGIT SEVEN
+0037 FE0F ; emoji style; # (1.1) DIGIT SEVEN
+0038 FE0E ; text style; # (1.1) DIGIT EIGHT
+0038 FE0F ; emoji style; # (1.1) DIGIT EIGHT
+0039 FE0E ; text style; # (1.1) DIGIT NINE
+0039 FE0F ; emoji style; # (1.1) DIGIT NINE
+00A9 FE0E ; text style; # (1.1) COPYRIGHT SIGN
+00A9 FE0F ; emoji style; # (1.1) COPYRIGHT SIGN
+00AE FE0E ; text style; # (1.1) REGISTERED SIGN
+00AE FE0F ; emoji style; # (1.1) REGISTERED SIGN
+203C FE0E ; text style; # (1.1) DOUBLE EXCLAMATION MARK
+203C FE0F ; emoji style; # (1.1) DOUBLE EXCLAMATION MARK
+2049 FE0E ; text style; # (3.0) EXCLAMATION QUESTION MARK
+2049 FE0F ; emoji style; # (3.0) EXCLAMATION QUESTION MARK
+2122 FE0E ; text style; # (1.1) TRADE MARK SIGN
+2122 FE0F ; emoji style; # (1.1) TRADE MARK SIGN
+2139 FE0E ; text style; # (3.0) INFORMATION SOURCE
+2139 FE0F ; emoji style; # (3.0) INFORMATION SOURCE
+2194 FE0E ; text style; # (1.1) LEFT RIGHT ARROW
+2194 FE0F ; emoji style; # (1.1) LEFT RIGHT ARROW
+2195 FE0E ; text style; # (1.1) UP DOWN ARROW
+2195 FE0F ; emoji style; # (1.1) UP DOWN ARROW
+2196 FE0E ; text style; # (1.1) NORTH WEST ARROW
+2196 FE0F ; emoji style; # (1.1) NORTH WEST ARROW
+2197 FE0E ; text style; # (1.1) NORTH EAST ARROW
+2197 FE0F ; emoji style; # (1.1) NORTH EAST ARROW
+2198 FE0E ; text style; # (1.1) SOUTH EAST ARROW
+2198 FE0F ; emoji style; # (1.1) SOUTH EAST ARROW
+2199 FE0E ; text style; # (1.1) SOUTH WEST ARROW
+2199 FE0F ; emoji style; # (1.1) SOUTH WEST ARROW
+21A9 FE0E ; text style; # (1.1) LEFTWARDS ARROW WITH HOOK
+21A9 FE0F ; emoji style; # (1.1) LEFTWARDS ARROW WITH HOOK
+21AA FE0E ; text style; # (1.1) RIGHTWARDS ARROW WITH HOOK
+21AA FE0F ; emoji style; # (1.1) RIGHTWARDS ARROW WITH HOOK
+231A FE0E ; text style; # (1.1) WATCH
+231A FE0F ; emoji style; # (1.1) WATCH
+231B FE0E ; text style; # (1.1) HOURGLASS
+231B FE0F ; emoji style; # (1.1) HOURGLASS
+2328 FE0E ; text style; # (1.1) KEYBOARD
+2328 FE0F ; emoji style; # (1.1) KEYBOARD
+23CF FE0E ; text style; # (4.0) EJECT SYMBOL
+23CF FE0F ; emoji style; # (4.0) EJECT SYMBOL
+23E9 FE0E ; text style; # (6.0) BLACK RIGHT-POINTING DOUBLE TRIANGLE
+23E9 FE0F ; emoji style; # (6.0) BLACK RIGHT-POINTING DOUBLE TRIANGLE
+23EA FE0E ; text style; # (6.0) BLACK LEFT-POINTING DOUBLE TRIANGLE
+23EA FE0F ; emoji style; # (6.0) BLACK LEFT-POINTING DOUBLE TRIANGLE
+23EB FE0E ; text style; # (6.0) BLACK UP-POINTING DOUBLE TRIANGLE
+23EB FE0F ; emoji style; # (6.0) BLACK UP-POINTING DOUBLE TRIANGLE
+23EC FE0E ; text style; # (6.0) BLACK DOWN-POINTING DOUBLE TRIANGLE
+23EC FE0F ; emoji style; # (6.0) BLACK DOWN-POINTING DOUBLE TRIANGLE
+23ED FE0E ; text style; # (6.0) BLACK RIGHT-POINTING DOUBLE TRIANGLE WITH VERTICAL BAR
+23ED FE0F ; emoji style; # (6.0) BLACK RIGHT-POINTING DOUBLE TRIANGLE WITH VERTICAL BAR
+23EE FE0E ; text style; # (6.0) BLACK LEFT-POINTING DOUBLE TRIANGLE WITH VERTICAL BAR
+23EE FE0F ; emoji style; # (6.0) BLACK LEFT-POINTING DOUBLE TRIANGLE WITH VERTICAL BAR
+23EF FE0E ; text style; # (6.0) BLACK RIGHT-POINTING TRIANGLE WITH DOUBLE VERTICAL BAR
+23EF FE0F ; emoji style; # (6.0) BLACK RIGHT-POINTING TRIANGLE WITH DOUBLE VERTICAL BAR
+23F0 FE0E ; text style; # (6.0) ALARM CLOCK
+23F0 FE0F ; emoji style; # (6.0) ALARM CLOCK
+23F1 FE0E ; text style; # (6.0) STOPWATCH
+23F1 FE0F ; emoji style; # (6.0) STOPWATCH
+23F2 FE0E ; text style; # (6.0) TIMER CLOCK
+23F2 FE0F ; emoji style; # (6.0) TIMER CLOCK
+23F3 FE0E ; text style; # (6.0) HOURGLASS WITH FLOWING SAND
+23F3 FE0F ; emoji style; # (6.0) HOURGLASS WITH FLOWING SAND
+23F8 FE0E ; text style; # (7.0) DOUBLE VERTICAL BAR
+23F8 FE0F ; emoji style; # (7.0) DOUBLE VERTICAL BAR
+23F9 FE0E ; text style; # (7.0) BLACK SQUARE FOR STOP
+23F9 FE0F ; emoji style; # (7.0) BLACK SQUARE FOR STOP
+23FA FE0E ; text style; # (7.0) BLACK CIRCLE FOR RECORD
+23FA FE0F ; emoji style; # (7.0) BLACK CIRCLE FOR RECORD
+24C2 FE0E ; text style; # (1.1) CIRCLED LATIN CAPITAL LETTER M
+24C2 FE0F ; emoji style; # (1.1) CIRCLED LATIN CAPITAL LETTER M
+25AA FE0E ; text style; # (1.1) BLACK SMALL SQUARE
+25AA FE0F ; emoji style; # (1.1) BLACK SMALL SQUARE
+25AB FE0E ; text style; # (1.1) WHITE SMALL SQUARE
+25AB FE0F ; emoji style; # (1.1) WHITE SMALL SQUARE
+25B6 FE0E ; text style; # (1.1) BLACK RIGHT-POINTING TRIANGLE
+25B6 FE0F ; emoji style; # (1.1) BLACK RIGHT-POINTING TRIANGLE
+25C0 FE0E ; text style; # (1.1) BLACK LEFT-POINTING TRIANGLE
+25C0 FE0F ; emoji style; # (1.1) BLACK LEFT-POINTING TRIANGLE
+25FB FE0E ; text style; # (3.2) WHITE MEDIUM SQUARE
+25FB FE0F ; emoji style; # (3.2) WHITE MEDIUM SQUARE
+25FC FE0E ; text style; # (3.2) BLACK MEDIUM SQUARE
+25FC FE0F ; emoji style; # (3.2) BLACK MEDIUM SQUARE
+25FD FE0E ; text style; # (3.2) WHITE MEDIUM SMALL SQUARE
+25FD FE0F ; emoji style; # (3.2) WHITE MEDIUM SMALL SQUARE
+25FE FE0E ; text style; # (3.2) BLACK MEDIUM SMALL SQUARE
+25FE FE0F ; emoji style; # (3.2) BLACK MEDIUM SMALL SQUARE
+2600 FE0E ; text style; # (1.1) BLACK SUN WITH RAYS
+2600 FE0F ; emoji style; # (1.1) BLACK SUN WITH RAYS
+2601 FE0E ; text style; # (1.1) CLOUD
+2601 FE0F ; emoji style; # (1.1) CLOUD
+2602 FE0E ; text style; # (1.1) UMBRELLA
+2602 FE0F ; emoji style; # (1.1) UMBRELLA
+2603 FE0E ; text style; # (1.1) SNOWMAN
+2603 FE0F ; emoji style; # (1.1) SNOWMAN
+2604 FE0E ; text style; # (1.1) COMET
+2604 FE0F ; emoji style; # (1.1) COMET
+260E FE0E ; text style; # (1.1) BLACK TELEPHONE
+260E FE0F ; emoji style; # (1.1) BLACK TELEPHONE
+2611 FE0E ; text style; # (1.1) BALLOT BOX WITH CHECK
+2611 FE0F ; emoji style; # (1.1) BALLOT BOX WITH CHECK
+2614 FE0E ; text style; # (4.0) UMBRELLA WITH RAIN DROPS
+2614 FE0F ; emoji style; # (4.0) UMBRELLA WITH RAIN DROPS
+2615 FE0E ; text style; # (4.0) HOT BEVERAGE
+2615 FE0F ; emoji style; # (4.0) HOT BEVERAGE
+2618 FE0E ; text style; # (4.1) SHAMROCK
+2618 FE0F ; emoji style; # (4.1) SHAMROCK
+261D FE0E ; text style; # (1.1) WHITE UP POINTING INDEX
+261D FE0F ; emoji style; # (1.1) WHITE UP POINTING INDEX
+2620 FE0E ; text style; # (1.1) SKULL AND CROSSBONES
+2620 FE0F ; emoji style; # (1.1) SKULL AND CROSSBONES
+2622 FE0E ; text style; # (1.1) RADIOACTIVE SIGN
+2622 FE0F ; emoji style; # (1.1) RADIOACTIVE SIGN
+2623 FE0E ; text style; # (1.1) BIOHAZARD SIGN
+2623 FE0F ; emoji style; # (1.1) BIOHAZARD SIGN
+2626 FE0E ; text style; # (1.1) ORTHODOX CROSS
+2626 FE0F ; emoji style; # (1.1) ORTHODOX CROSS
+262A FE0E ; text style; # (1.1) STAR AND CRESCENT
+262A FE0F ; emoji style; # (1.1) STAR AND CRESCENT
+262E FE0E ; text style; # (1.1) PEACE SYMBOL
+262E FE0F ; emoji style; # (1.1) PEACE SYMBOL
+262F FE0E ; text style; # (1.1) YIN YANG
+262F FE0F ; emoji style; # (1.1) YIN YANG
+2638 FE0E ; text style; # (1.1) WHEEL OF DHARMA
+2638 FE0F ; emoji style; # (1.1) WHEEL OF DHARMA
+2639 FE0E ; text style; # (1.1) WHITE FROWNING FACE
+2639 FE0F ; emoji style; # (1.1) WHITE FROWNING FACE
+263A FE0E ; text style; # (1.1) WHITE SMILING FACE
+263A FE0F ; emoji style; # (1.1) WHITE SMILING FACE
+2640 FE0E ; text style; # (1.1) FEMALE SIGN
+2640 FE0F ; emoji style; # (1.1) FEMALE SIGN
+2642 FE0E ; text style; # (1.1) MALE SIGN
+2642 FE0F ; emoji style; # (1.1) MALE SIGN
+2648 FE0E ; text style; # (1.1) ARIES
+2648 FE0F ; emoji style; # (1.1) ARIES
+2649 FE0E ; text style; # (1.1) TAURUS
+2649 FE0F ; emoji style; # (1.1) TAURUS
+264A FE0E ; text style; # (1.1) GEMINI
+264A FE0F ; emoji style; # (1.1) GEMINI
+264B FE0E ; text style; # (1.1) CANCER
+264B FE0F ; emoji style; # (1.1) CANCER
+264C FE0E ; text style; # (1.1) LEO
+264C FE0F ; emoji style; # (1.1) LEO
+264D FE0E ; text style; # (1.1) VIRGO
+264D FE0F ; emoji style; # (1.1) VIRGO
+264E FE0E ; text style; # (1.1) LIBRA
+264E FE0F ; emoji style; # (1.1) LIBRA
+264F FE0E ; text style; # (1.1) SCORPIUS
+264F FE0F ; emoji style; # (1.1) SCORPIUS
+2650 FE0E ; text style; # (1.1) SAGITTARIUS
+2650 FE0F ; emoji style; # (1.1) SAGITTARIUS
+2651 FE0E ; text style; # (1.1) CAPRICORN
+2651 FE0F ; emoji style; # (1.1) CAPRICORN
+2652 FE0E ; text style; # (1.1) AQUARIUS
+2652 FE0F ; emoji style; # (1.1) AQUARIUS
+2653 FE0E ; text style; # (1.1) PISCES
+2653 FE0F ; emoji style; # (1.1) PISCES
+265F FE0E ; text style; # (1.1) BLACK CHESS PAWN
+265F FE0F ; emoji style; # (1.1) BLACK CHESS PAWN
+2660 FE0E ; text style; # (1.1) BLACK SPADE SUIT
+2660 FE0F ; emoji style; # (1.1) BLACK SPADE SUIT
+2663 FE0E ; text style; # (1.1) BLACK CLUB SUIT
+2663 FE0F ; emoji style; # (1.1) BLACK CLUB SUIT
+2665 FE0E ; text style; # (1.1) BLACK HEART SUIT
+2665 FE0F ; emoji style; # (1.1) BLACK HEART SUIT
+2666 FE0E ; text style; # (1.1) BLACK DIAMOND SUIT
+2666 FE0F ; emoji style; # (1.1) BLACK DIAMOND SUIT
+2668 FE0E ; text style; # (1.1) HOT SPRINGS
+2668 FE0F ; emoji style; # (1.1) HOT SPRINGS
+267B FE0E ; text style; # (3.2) BLACK UNIVERSAL RECYCLING SYMBOL
+267B FE0F ; emoji style; # (3.2) BLACK UNIVERSAL RECYCLING SYMBOL
+267E FE0E ; text style; # (4.1) PERMANENT PAPER SIGN
+267E FE0F ; emoji style; # (4.1) PERMANENT PAPER SIGN
+267F FE0E ; text style; # (4.1) WHEELCHAIR SYMBOL
+267F FE0F ; emoji style; # (4.1) WHEELCHAIR SYMBOL
+2692 FE0E ; text style; # (4.1) HAMMER AND PICK
+2692 FE0F ; emoji style; # (4.1) HAMMER AND PICK
+2693 FE0E ; text style; # (4.1) ANCHOR
+2693 FE0F ; emoji style; # (4.1) ANCHOR
+2694 FE0E ; text style; # (4.1) CROSSED SWORDS
+2694 FE0F ; emoji style; # (4.1) CROSSED SWORDS
+2695 FE0E ; text style; # (4.1) STAFF OF AESCULAPIUS
+2695 FE0F ; emoji style; # (4.1) STAFF OF AESCULAPIUS
+2696 FE0E ; text style; # (4.1) SCALES
+2696 FE0F ; emoji style; # (4.1) SCALES
+2697 FE0E ; text style; # (4.1) ALEMBIC
+2697 FE0F ; emoji style; # (4.1) ALEMBIC
+2699 FE0E ; text style; # (4.1) GEAR
+2699 FE0F ; emoji style; # (4.1) GEAR
+269B FE0E ; text style; # (4.1) ATOM SYMBOL
+269B FE0F ; emoji style; # (4.1) ATOM SYMBOL
+269C FE0E ; text style; # (4.1) FLEUR-DE-LIS
+269C FE0F ; emoji style; # (4.1) FLEUR-DE-LIS
+26A0 FE0E ; text style; # (4.0) WARNING SIGN
+26A0 FE0F ; emoji style; # (4.0) WARNING SIGN
+26A1 FE0E ; text style; # (4.0) HIGH VOLTAGE SIGN
+26A1 FE0F ; emoji style; # (4.0) HIGH VOLTAGE SIGN
+26A7 FE0E ; text style; # (4.1) MALE WITH STROKE AND MALE AND FEMALE SIGN
+26A7 FE0F ; emoji style; # (4.1) MALE WITH STROKE AND MALE AND FEMALE SIGN
+26AA FE0E ; text style; # (4.1) MEDIUM WHITE CIRCLE
+26AA FE0F ; emoji style; # (4.1) MEDIUM WHITE CIRCLE
+26AB FE0E ; text style; # (4.1) MEDIUM BLACK CIRCLE
+26AB FE0F ; emoji style; # (4.1) MEDIUM BLACK CIRCLE
+26B0 FE0E ; text style; # (4.1) COFFIN
+26B0 FE0F ; emoji style; # (4.1) COFFIN
+26B1 FE0E ; text style; # (4.1) FUNERAL URN
+26B1 FE0F ; emoji style; # (4.1) FUNERAL URN
+26BD FE0E ; text style; # (5.2) SOCCER BALL
+26BD FE0F ; emoji style; # (5.2) SOCCER BALL
+26BE FE0E ; text style; # (5.2) BASEBALL
+26BE FE0F ; emoji style; # (5.2) BASEBALL
+26C4 FE0E ; text style; # (5.2) SNOWMAN WITHOUT SNOW
+26C4 FE0F ; emoji style; # (5.2) SNOWMAN WITHOUT SNOW
+26C5 FE0E ; text style; # (5.2) SUN BEHIND CLOUD
+26C5 FE0F ; emoji style; # (5.2) SUN BEHIND CLOUD
+26C8 FE0E ; text style; # (5.2) THUNDER CLOUD AND RAIN
+26C8 FE0F ; emoji style; # (5.2) THUNDER CLOUD AND RAIN
+26CE FE0E ; text style; # (6.0) OPHIUCHUS
+26CE FE0F ; emoji style; # (6.0) OPHIUCHUS
+26CF FE0E ; text style; # (5.2) PICK
+26CF FE0F ; emoji style; # (5.2) PICK
+26D1 FE0E ; text style; # (5.2) HELMET WITH WHITE CROSS
+26D1 FE0F ; emoji style; # (5.2) HELMET WITH WHITE CROSS
+26D3 FE0E ; text style; # (5.2) CHAINS
+26D3 FE0F ; emoji style; # (5.2) CHAINS
+26D4 FE0E ; text style; # (5.2) NO ENTRY
+26D4 FE0F ; emoji style; # (5.2) NO ENTRY
+26E9 FE0E ; text style; # (5.2) SHINTO SHRINE
+26E9 FE0F ; emoji style; # (5.2) SHINTO SHRINE
+26EA FE0E ; text style; # (5.2) CHURCH
+26EA FE0F ; emoji style; # (5.2) CHURCH
+26F0 FE0E ; text style; # (5.2) MOUNTAIN
+26F0 FE0F ; emoji style; # (5.2) MOUNTAIN
+26F1 FE0E ; text style; # (5.2) UMBRELLA ON GROUND
+26F1 FE0F ; emoji style; # (5.2) UMBRELLA ON GROUND
+26F2 FE0E ; text style; # (5.2) FOUNTAIN
+26F2 FE0F ; emoji style; # (5.2) FOUNTAIN
+26F3 FE0E ; text style; # (5.2) FLAG IN HOLE
+26F3 FE0F ; emoji style; # (5.2) FLAG IN HOLE
+26F4 FE0E ; text style; # (5.2) FERRY
+26F4 FE0F ; emoji style; # (5.2) FERRY
+26F5 FE0E ; text style; # (5.2) SAILBOAT
+26F5 FE0F ; emoji style; # (5.2) SAILBOAT
+26F7 FE0E ; text style; # (5.2) SKIER
+26F7 FE0F ; emoji style; # (5.2) SKIER
+26F8 FE0E ; text style; # (5.2) ICE SKATE
+26F8 FE0F ; emoji style; # (5.2) ICE SKATE
+26F9 FE0E ; text style; # (5.2) PERSON WITH BALL
+26F9 FE0F ; emoji style; # (5.2) PERSON WITH BALL
+26FA FE0E ; text style; # (5.2) TENT
+26FA FE0F ; emoji style; # (5.2) TENT
+26FD FE0E ; text style; # (5.2) FUEL PUMP
+26FD FE0F ; emoji style; # (5.2) FUEL PUMP
+2702 FE0E ; text style; # (1.1) BLACK SCISSORS
+2702 FE0F ; emoji style; # (1.1) BLACK SCISSORS
+2705 FE0E ; text style; # (6.0) WHITE HEAVY CHECK MARK
+2705 FE0F ; emoji style; # (6.0) WHITE HEAVY CHECK MARK
+2708 FE0E ; text style; # (1.1) AIRPLANE
+2708 FE0F ; emoji style; # (1.1) AIRPLANE
+2709 FE0E ; text style; # (1.1) ENVELOPE
+2709 FE0F ; emoji style; # (1.1) ENVELOPE
+270A FE0E ; text style; # (6.0) RAISED FIST
+270A FE0F ; emoji style; # (6.0) RAISED FIST
+270B FE0E ; text style; # (6.0) RAISED HAND
+270B FE0F ; emoji style; # (6.0) RAISED HAND
+270C FE0E ; text style; # (1.1) VICTORY HAND
+270C FE0F ; emoji style; # (1.1) VICTORY HAND
+270D FE0E ; text style; # (1.1) WRITING HAND
+270D FE0F ; emoji style; # (1.1) WRITING HAND
+270F FE0E ; text style; # (1.1) PENCIL
+270F FE0F ; emoji style; # (1.1) PENCIL
+2712 FE0E ; text style; # (1.1) BLACK NIB
+2712 FE0F ; emoji style; # (1.1) BLACK NIB
+2714 FE0E ; text style; # (1.1) HEAVY CHECK MARK
+2714 FE0F ; emoji style; # (1.1) HEAVY CHECK MARK
+2716 FE0E ; text style; # (1.1) HEAVY MULTIPLICATION X
+2716 FE0F ; emoji style; # (1.1) HEAVY MULTIPLICATION X
+271D FE0E ; text style; # (1.1) LATIN CROSS
+271D FE0F ; emoji style; # (1.1) LATIN CROSS
+2721 FE0E ; text style; # (1.1) STAR OF DAVID
+2721 FE0F ; emoji style; # (1.1) STAR OF DAVID
+2728 FE0E ; text style; # (6.0) SPARKLES
+2728 FE0F ; emoji style; # (6.0) SPARKLES
+2733 FE0E ; text style; # (1.1) EIGHT SPOKED ASTERISK
+2733 FE0F ; emoji style; # (1.1) EIGHT SPOKED ASTERISK
+2734 FE0E ; text style; # (1.1) EIGHT POINTED BLACK STAR
+2734 FE0F ; emoji style; # (1.1) EIGHT POINTED BLACK STAR
+2744 FE0E ; text style; # (1.1) SNOWFLAKE
+2744 FE0F ; emoji style; # (1.1) SNOWFLAKE
+2747 FE0E ; text style; # (1.1) SPARKLE
+2747 FE0F ; emoji style; # (1.1) SPARKLE
+274C FE0E ; text style; # (6.0) CROSS MARK
+274C FE0F ; emoji style; # (6.0) CROSS MARK
+274E FE0E ; text style; # (6.0) NEGATIVE SQUARED CROSS MARK
+274E FE0F ; emoji style; # (6.0) NEGATIVE SQUARED CROSS MARK
+2753 FE0E ; text style; # (6.0) BLACK QUESTION MARK ORNAMENT
+2753 FE0F ; emoji style; # (6.0) BLACK QUESTION MARK ORNAMENT
+2754 FE0E ; text style; # (6.0) WHITE QUESTION MARK ORNAMENT
+2754 FE0F ; emoji style; # (6.0) WHITE QUESTION MARK ORNAMENT
+2755 FE0E ; text style; # (6.0) WHITE EXCLAMATION MARK ORNAMENT
+2755 FE0F ; emoji style; # (6.0) WHITE EXCLAMATION MARK ORNAMENT
+2757 FE0E ; text style; # (5.2) HEAVY EXCLAMATION MARK SYMBOL
+2757 FE0F ; emoji style; # (5.2) HEAVY EXCLAMATION MARK SYMBOL
+2763 FE0E ; text style; # (1.1) HEAVY HEART EXCLAMATION MARK ORNAMENT
+2763 FE0F ; emoji style; # (1.1) HEAVY HEART EXCLAMATION MARK ORNAMENT
+2764 FE0E ; text style; # (1.1) HEAVY BLACK HEART
+2764 FE0F ; emoji style; # (1.1) HEAVY BLACK HEART
+2795 FE0E ; text style; # (6.0) HEAVY PLUS SIGN
+2795 FE0F ; emoji style; # (6.0) HEAVY PLUS SIGN
+2796 FE0E ; text style; # (6.0) HEAVY MINUS SIGN
+2796 FE0F ; emoji style; # (6.0) HEAVY MINUS SIGN
+2797 FE0E ; text style; # (6.0) HEAVY DIVISION SIGN
+2797 FE0F ; emoji style; # (6.0) HEAVY DIVISION SIGN
+27A1 FE0E ; text style; # (1.1) BLACK RIGHTWARDS ARROW
+27A1 FE0F ; emoji style; # (1.1) BLACK RIGHTWARDS ARROW
+27B0 FE0E ; text style; # (6.0) CURLY LOOP
+27B0 FE0F ; emoji style; # (6.0) CURLY LOOP
+27BF FE0E ; text style; # (6.0) DOUBLE CURLY LOOP
+27BF FE0F ; emoji style; # (6.0) DOUBLE CURLY LOOP
+2934 FE0E ; text style; # (3.2) ARROW POINTING RIGHTWARDS THEN CURVING UPWARDS
+2934 FE0F ; emoji style; # (3.2) ARROW POINTING RIGHTWARDS THEN CURVING UPWARDS
+2935 FE0E ; text style; # (3.2) ARROW POINTING RIGHTWARDS THEN CURVING DOWNWARDS
+2935 FE0F ; emoji style; # (3.2) ARROW POINTING RIGHTWARDS THEN CURVING DOWNWARDS
+2B05 FE0E ; text style; # (4.0) LEFTWARDS BLACK ARROW
+2B05 FE0F ; emoji style; # (4.0) LEFTWARDS BLACK ARROW
+2B06 FE0E ; text style; # (4.0) UPWARDS BLACK ARROW
+2B06 FE0F ; emoji style; # (4.0) UPWARDS BLACK ARROW
+2B07 FE0E ; text style; # (4.0) DOWNWARDS BLACK ARROW
+2B07 FE0F ; emoji style; # (4.0) DOWNWARDS BLACK ARROW
+2B1B FE0E ; text style; # (5.1) BLACK LARGE SQUARE
+2B1B FE0F ; emoji style; # (5.1) BLACK LARGE SQUARE
+2B1C FE0E ; text style; # (5.1) WHITE LARGE SQUARE
+2B1C FE0F ; emoji style; # (5.1) WHITE LARGE SQUARE
+2B50 FE0E ; text style; # (5.1) WHITE MEDIUM STAR
+2B50 FE0F ; emoji style; # (5.1) WHITE MEDIUM STAR
+2B55 FE0E ; text style; # (5.2) HEAVY LARGE CIRCLE
+2B55 FE0F ; emoji style; # (5.2) HEAVY LARGE CIRCLE
+3030 FE0E ; text style; # (1.1) WAVY DASH
+3030 FE0F ; emoji style; # (1.1) WAVY DASH
+303D FE0E ; text style; # (3.2) PART ALTERNATION MARK
+303D FE0F ; emoji style; # (3.2) PART ALTERNATION MARK
+3297 FE0E ; text style; # (1.1) CIRCLED IDEOGRAPH CONGRATULATION
+3297 FE0F ; emoji style; # (1.1) CIRCLED IDEOGRAPH CONGRATULATION
+3299 FE0E ; text style; # (1.1) CIRCLED IDEOGRAPH SECRET
+3299 FE0F ; emoji style; # (1.1) CIRCLED IDEOGRAPH SECRET
+1F004 FE0E ; text style; # (5.1) MAHJONG TILE RED DRAGON
+1F004 FE0F ; emoji style; # (5.1) MAHJONG TILE RED DRAGON
+1F170 FE0E ; text style; # (6.0) NEGATIVE SQUARED LATIN CAPITAL LETTER A
+1F170 FE0F ; emoji style; # (6.0) NEGATIVE SQUARED LATIN CAPITAL LETTER A
+1F171 FE0E ; text style; # (6.0) NEGATIVE SQUARED LATIN CAPITAL LETTER B
+1F171 FE0F ; emoji style; # (6.0) NEGATIVE SQUARED LATIN CAPITAL LETTER B
+1F17E FE0E ; text style; # (6.0) NEGATIVE SQUARED LATIN CAPITAL LETTER O
+1F17E FE0F ; emoji style; # (6.0) NEGATIVE SQUARED LATIN CAPITAL LETTER O
+1F17F FE0E ; text style; # (5.2) NEGATIVE SQUARED LATIN CAPITAL LETTER P
+1F17F FE0F ; emoji style; # (5.2) NEGATIVE SQUARED LATIN CAPITAL LETTER P
+1F202 FE0E ; text style; # (6.0) SQUARED KATAKANA SA
+1F202 FE0F ; emoji style; # (6.0) SQUARED KATAKANA SA
+1F21A FE0E ; text style; # (5.2) SQUARED CJK UNIFIED IDEOGRAPH-7121
+1F21A FE0F ; emoji style; # (5.2) SQUARED CJK UNIFIED IDEOGRAPH-7121
+1F22F FE0E ; text style; # (5.2) SQUARED CJK UNIFIED IDEOGRAPH-6307
+1F22F FE0F ; emoji style; # (5.2) SQUARED CJK UNIFIED IDEOGRAPH-6307
+1F237 FE0E ; text style; # (6.0) SQUARED CJK UNIFIED IDEOGRAPH-6708
+1F237 FE0F ; emoji style; # (6.0) SQUARED CJK UNIFIED IDEOGRAPH-6708
+1F30D FE0E ; text style; # (6.0) EARTH GLOBE EUROPE-AFRICA
+1F30D FE0F ; emoji style; # (6.0) EARTH GLOBE EUROPE-AFRICA
+1F30E FE0E ; text style; # (6.0) EARTH GLOBE AMERICAS
+1F30E FE0F ; emoji style; # (6.0) EARTH GLOBE AMERICAS
+1F30F FE0E ; text style; # (6.0) EARTH GLOBE ASIA-AUSTRALIA
+1F30F FE0F ; emoji style; # (6.0) EARTH GLOBE ASIA-AUSTRALIA
+1F315 FE0E ; text style; # (6.0) FULL MOON SYMBOL
+1F315 FE0F ; emoji style; # (6.0) FULL MOON SYMBOL
+1F31C FE0E ; text style; # (6.0) LAST QUARTER MOON WITH FACE
+1F31C FE0F ; emoji style; # (6.0) LAST QUARTER MOON WITH FACE
+1F321 FE0E ; text style; # (7.0) THERMOMETER
+1F321 FE0F ; emoji style; # (7.0) THERMOMETER
+1F324 FE0E ; text style; # (7.0) WHITE SUN WITH SMALL CLOUD
+1F324 FE0F ; emoji style; # (7.0) WHITE SUN WITH SMALL CLOUD
+1F325 FE0E ; text style; # (7.0) WHITE SUN BEHIND CLOUD
+1F325 FE0F ; emoji style; # (7.0) WHITE SUN BEHIND CLOUD
+1F326 FE0E ; text style; # (7.0) WHITE SUN BEHIND CLOUD WITH RAIN
+1F326 FE0F ; emoji style; # (7.0) WHITE SUN BEHIND CLOUD WITH RAIN
+1F327 FE0E ; text style; # (7.0) CLOUD WITH RAIN
+1F327 FE0F ; emoji style; # (7.0) CLOUD WITH RAIN
+1F328 FE0E ; text style; # (7.0) CLOUD WITH SNOW
+1F328 FE0F ; emoji style; # (7.0) CLOUD WITH SNOW
+1F329 FE0E ; text style; # (7.0) CLOUD WITH LIGHTNING
+1F329 FE0F ; emoji style; # (7.0) CLOUD WITH LIGHTNING
+1F32A FE0E ; text style; # (7.0) CLOUD WITH TORNADO
+1F32A FE0F ; emoji style; # (7.0) CLOUD WITH TORNADO
+1F32B FE0E ; text style; # (7.0) FOG
+1F32B FE0F ; emoji style; # (7.0) FOG
+1F32C FE0E ; text style; # (7.0) WIND BLOWING FACE
+1F32C FE0F ; emoji style; # (7.0) WIND BLOWING FACE
+1F336 FE0E ; text style; # (7.0) HOT PEPPER
+1F336 FE0F ; emoji style; # (7.0) HOT PEPPER
+1F378 FE0E ; text style; # (6.0) COCKTAIL GLASS
+1F378 FE0F ; emoji style; # (6.0) COCKTAIL GLASS
+1F37D FE0E ; text style; # (7.0) FORK AND KNIFE WITH PLATE
+1F37D FE0F ; emoji style; # (7.0) FORK AND KNIFE WITH PLATE
+1F393 FE0E ; text style; # (6.0) GRADUATION CAP
+1F393 FE0F ; emoji style; # (6.0) GRADUATION CAP
+1F396 FE0E ; text style; # (7.0) MILITARY MEDAL
+1F396 FE0F ; emoji style; # (7.0) MILITARY MEDAL
+1F397 FE0E ; text style; # (7.0) REMINDER RIBBON
+1F397 FE0F ; emoji style; # (7.0) REMINDER RIBBON
+1F399 FE0E ; text style; # (7.0) STUDIO MICROPHONE
+1F399 FE0F ; emoji style; # (7.0) STUDIO MICROPHONE
+1F39A FE0E ; text style; # (7.0) LEVEL SLIDER
+1F39A FE0F ; emoji style; # (7.0) LEVEL SLIDER
+1F39B FE0E ; text style; # (7.0) CONTROL KNOBS
+1F39B FE0F ; emoji style; # (7.0) CONTROL KNOBS
+1F39E FE0E ; text style; # (7.0) FILM FRAMES
+1F39E FE0F ; emoji style; # (7.0) FILM FRAMES
+1F39F FE0E ; text style; # (7.0) ADMISSION TICKETS
+1F39F FE0F ; emoji style; # (7.0) ADMISSION TICKETS
+1F3A7 FE0E ; text style; # (6.0) HEADPHONE
+1F3A7 FE0F ; emoji style; # (6.0) HEADPHONE
+1F3AC FE0E ; text style; # (6.0) CLAPPER BOARD
+1F3AC FE0F ; emoji style; # (6.0) CLAPPER BOARD
+1F3AD FE0E ; text style; # (6.0) PERFORMING ARTS
+1F3AD FE0F ; emoji style; # (6.0) PERFORMING ARTS
+1F3AE FE0E ; text style; # (6.0) VIDEO GAME
+1F3AE FE0F ; emoji style; # (6.0) VIDEO GAME
+1F3C2 FE0E ; text style; # (6.0) SNOWBOARDER
+1F3C2 FE0F ; emoji style; # (6.0) SNOWBOARDER
+1F3C4 FE0E ; text style; # (6.0) SURFER
+1F3C4 FE0F ; emoji style; # (6.0) SURFER
+1F3C6 FE0E ; text style; # (6.0) TROPHY
+1F3C6 FE0F ; emoji style; # (6.0) TROPHY
+1F3CA FE0E ; text style; # (6.0) SWIMMER
+1F3CA FE0F ; emoji style; # (6.0) SWIMMER
+1F3CB FE0E ; text style; # (7.0) WEIGHT LIFTER
+1F3CB FE0F ; emoji style; # (7.0) WEIGHT LIFTER
+1F3CC FE0E ; text style; # (7.0) GOLFER
+1F3CC FE0F ; emoji style; # (7.0) GOLFER
+1F3CD FE0E ; text style; # (7.0) RACING MOTORCYCLE
+1F3CD FE0F ; emoji style; # (7.0) RACING MOTORCYCLE
+1F3CE FE0E ; text style; # (7.0) RACING CAR
+1F3CE FE0F ; emoji style; # (7.0) RACING CAR
+1F3D4 FE0E ; text style; # (7.0) SNOW CAPPED MOUNTAIN
+1F3D4 FE0F ; emoji style; # (7.0) SNOW CAPPED MOUNTAIN
+1F3D5 FE0E ; text style; # (7.0) CAMPING
+1F3D5 FE0F ; emoji style; # (7.0) CAMPING
+1F3D6 FE0E ; text style; # (7.0) BEACH WITH UMBRELLA
+1F3D6 FE0F ; emoji style; # (7.0) BEACH WITH UMBRELLA
+1F3D7 FE0E ; text style; # (7.0) BUILDING CONSTRUCTION
+1F3D7 FE0F ; emoji style; # (7.0) BUILDING CONSTRUCTION
+1F3D8 FE0E ; text style; # (7.0) HOUSE BUILDINGS
+1F3D8 FE0F ; emoji style; # (7.0) HOUSE BUILDINGS
+1F3D9 FE0E ; text style; # (7.0) CITYSCAPE
+1F3D9 FE0F ; emoji style; # (7.0) CITYSCAPE
+1F3DA FE0E ; text style; # (7.0) DERELICT HOUSE BUILDING
+1F3DA FE0F ; emoji style; # (7.0) DERELICT HOUSE BUILDING
+1F3DB FE0E ; text style; # (7.0) CLASSICAL BUILDING
+1F3DB FE0F ; emoji style; # (7.0) CLASSICAL BUILDING
+1F3DC FE0E ; text style; # (7.0) DESERT
+1F3DC FE0F ; emoji style; # (7.0) DESERT
+1F3DD FE0E ; text style; # (7.0) DESERT ISLAND
+1F3DD FE0F ; emoji style; # (7.0) DESERT ISLAND
+1F3DE FE0E ; text style; # (7.0) NATIONAL PARK
+1F3DE FE0F ; emoji style; # (7.0) NATIONAL PARK
+1F3DF FE0E ; text style; # (7.0) STADIUM
+1F3DF FE0F ; emoji style; # (7.0) STADIUM
+1F3E0 FE0E ; text style; # (6.0) HOUSE BUILDING
+1F3E0 FE0F ; emoji style; # (6.0) HOUSE BUILDING
+1F3ED FE0E ; text style; # (6.0) FACTORY
+1F3ED FE0F ; emoji style; # (6.0) FACTORY
+1F3F3 FE0E ; text style; # (7.0) WAVING WHITE FLAG
+1F3F3 FE0F ; emoji style; # (7.0) WAVING WHITE FLAG
+1F3F5 FE0E ; text style; # (7.0) ROSETTE
+1F3F5 FE0F ; emoji style; # (7.0) ROSETTE
+1F3F7 FE0E ; text style; # (7.0) LABEL
+1F3F7 FE0F ; emoji style; # (7.0) LABEL
+1F408 FE0E ; text style; # (6.0) CAT
+1F408 FE0F ; emoji style; # (6.0) CAT
+1F415 FE0E ; text style; # (6.0) DOG
+1F415 FE0F ; emoji style; # (6.0) DOG
+1F41F FE0E ; text style; # (6.0) FISH
+1F41F FE0F ; emoji style; # (6.0) FISH
+1F426 FE0E ; text style; # (6.0) BIRD
+1F426 FE0F ; emoji style; # (6.0) BIRD
+1F43F FE0E ; text style; # (7.0) CHIPMUNK
+1F43F FE0F ; emoji style; # (7.0) CHIPMUNK
+1F441 FE0E ; text style; # (7.0) EYE
+1F441 FE0F ; emoji style; # (7.0) EYE
+1F442 FE0E ; text style; # (6.0) EAR
+1F442 FE0F ; emoji style; # (6.0) EAR
+1F446 FE0E ; text style; # (6.0) WHITE UP POINTING BACKHAND INDEX
+1F446 FE0F ; emoji style; # (6.0) WHITE UP POINTING BACKHAND INDEX
+1F447 FE0E ; text style; # (6.0) WHITE DOWN POINTING BACKHAND INDEX
+1F447 FE0F ; emoji style; # (6.0) WHITE DOWN POINTING BACKHAND INDEX
+1F448 FE0E ; text style; # (6.0) WHITE LEFT POINTING BACKHAND INDEX
+1F448 FE0F ; emoji style; # (6.0) WHITE LEFT POINTING BACKHAND INDEX
+1F449 FE0E ; text style; # (6.0) WHITE RIGHT POINTING BACKHAND INDEX
+1F449 FE0F ; emoji style; # (6.0) WHITE RIGHT POINTING BACKHAND INDEX
+1F44D FE0E ; text style; # (6.0) THUMBS UP SIGN
+1F44D FE0F ; emoji style; # (6.0) THUMBS UP SIGN
+1F44E FE0E ; text style; # (6.0) THUMBS DOWN SIGN
+1F44E FE0F ; emoji style; # (6.0) THUMBS DOWN SIGN
+1F453 FE0E ; text style; # (6.0) EYEGLASSES
+1F453 FE0F ; emoji style; # (6.0) EYEGLASSES
+1F46A FE0E ; text style; # (6.0) FAMILY
+1F46A FE0F ; emoji style; # (6.0) FAMILY
+1F47D FE0E ; text style; # (6.0) EXTRATERRESTRIAL ALIEN
+1F47D FE0F ; emoji style; # (6.0) EXTRATERRESTRIAL ALIEN
+1F4A3 FE0E ; text style; # (6.0) BOMB
+1F4A3 FE0F ; emoji style; # (6.0) BOMB
+1F4B0 FE0E ; text style; # (6.0) MONEY BAG
+1F4B0 FE0F ; emoji style; # (6.0) MONEY BAG
+1F4B3 FE0E ; text style; # (6.0) CREDIT CARD
+1F4B3 FE0F ; emoji style; # (6.0) CREDIT CARD
+1F4BB FE0E ; text style; # (6.0) PERSONAL COMPUTER
+1F4BB FE0F ; emoji style; # (6.0) PERSONAL COMPUTER
+1F4BF FE0E ; text style; # (6.0) OPTICAL DISC
+1F4BF FE0F ; emoji style; # (6.0) OPTICAL DISC
+1F4CB FE0E ; text style; # (6.0) CLIPBOARD
+1F4CB FE0F ; emoji style; # (6.0) CLIPBOARD
+1F4DA FE0E ; text style; # (6.0) BOOKS
+1F4DA FE0F ; emoji style; # (6.0) BOOKS
+1F4DF FE0E ; text style; # (6.0) PAGER
+1F4DF FE0F ; emoji style; # (6.0) PAGER
+1F4E4 FE0E ; text style; # (6.0) OUTBOX TRAY
+1F4E4 FE0F ; emoji style; # (6.0) OUTBOX TRAY
+1F4E5 FE0E ; text style; # (6.0) INBOX TRAY
+1F4E5 FE0F ; emoji style; # (6.0) INBOX TRAY
+1F4E6 FE0E ; text style; # (6.0) PACKAGE
+1F4E6 FE0F ; emoji style; # (6.0) PACKAGE
+1F4EA FE0E ; text style; # (6.0) CLOSED MAILBOX WITH LOWERED FLAG
+1F4EA FE0F ; emoji style; # (6.0) CLOSED MAILBOX WITH LOWERED FLAG
+1F4EB FE0E ; text style; # (6.0) CLOSED MAILBOX WITH RAISED FLAG
+1F4EB FE0F ; emoji style; # (6.0) CLOSED MAILBOX WITH RAISED FLAG
+1F4EC FE0E ; text style; # (6.0) OPEN MAILBOX WITH RAISED FLAG
+1F4EC FE0F ; emoji style; # (6.0) OPEN MAILBOX WITH RAISED FLAG
+1F4ED FE0E ; text style; # (6.0) OPEN MAILBOX WITH LOWERED FLAG
+1F4ED FE0F ; emoji style; # (6.0) OPEN MAILBOX WITH LOWERED FLAG
+1F4F7 FE0E ; text style; # (6.0) CAMERA
+1F4F7 FE0F ; emoji style; # (6.0) CAMERA
+1F4F9 FE0E ; text style; # (6.0) VIDEO CAMERA
+1F4F9 FE0F ; emoji style; # (6.0) VIDEO CAMERA
+1F4FA FE0E ; text style; # (6.0) TELEVISION
+1F4FA FE0F ; emoji style; # (6.0) TELEVISION
+1F4FB FE0E ; text style; # (6.0) RADIO
+1F4FB FE0F ; emoji style; # (6.0) RADIO
+1F4FD FE0E ; text style; # (7.0) FILM PROJECTOR
+1F4FD FE0F ; emoji style; # (7.0) FILM PROJECTOR
+1F508 FE0E ; text style; # (6.0) SPEAKER
+1F508 FE0F ; emoji style; # (6.0) SPEAKER
+1F50D FE0E ; text style; # (6.0) LEFT-POINTING MAGNIFYING GLASS
+1F50D FE0F ; emoji style; # (6.0) LEFT-POINTING MAGNIFYING GLASS
+1F512 FE0E ; text style; # (6.0) LOCK
+1F512 FE0F ; emoji style; # (6.0) LOCK
+1F513 FE0E ; text style; # (6.0) OPEN LOCK
+1F513 FE0F ; emoji style; # (6.0) OPEN LOCK
+1F549 FE0E ; text style; # (7.0) OM SYMBOL
+1F549 FE0F ; emoji style; # (7.0) OM SYMBOL
+1F54A FE0E ; text style; # (7.0) DOVE OF PEACE
+1F54A FE0F ; emoji style; # (7.0) DOVE OF PEACE
+1F550 FE0E ; text style; # (6.0) CLOCK FACE ONE OCLOCK
+1F550 FE0F ; emoji style; # (6.0) CLOCK FACE ONE OCLOCK
+1F551 FE0E ; text style; # (6.0) CLOCK FACE TWO OCLOCK
+1F551 FE0F ; emoji style; # (6.0) CLOCK FACE TWO OCLOCK
+1F552 FE0E ; text style; # (6.0) CLOCK FACE THREE OCLOCK
+1F552 FE0F ; emoji style; # (6.0) CLOCK FACE THREE OCLOCK
+1F553 FE0E ; text style; # (6.0) CLOCK FACE FOUR OCLOCK
+1F553 FE0F ; emoji style; # (6.0) CLOCK FACE FOUR OCLOCK
+1F554 FE0E ; text style; # (6.0) CLOCK FACE FIVE OCLOCK
+1F554 FE0F ; emoji style; # (6.0) CLOCK FACE FIVE OCLOCK
+1F555 FE0E ; text style; # (6.0) CLOCK FACE SIX OCLOCK
+1F555 FE0F ; emoji style; # (6.0) CLOCK FACE SIX OCLOCK
+1F556 FE0E ; text style; # (6.0) CLOCK FACE SEVEN OCLOCK
+1F556 FE0F ; emoji style; # (6.0) CLOCK FACE SEVEN OCLOCK
+1F557 FE0E ; text style; # (6.0) CLOCK FACE EIGHT OCLOCK
+1F557 FE0F ; emoji style; # (6.0) CLOCK FACE EIGHT OCLOCK
+1F558 FE0E ; text style; # (6.0) CLOCK FACE NINE OCLOCK
+1F558 FE0F ; emoji style; # (6.0) CLOCK FACE NINE OCLOCK
+1F559 FE0E ; text style; # (6.0) CLOCK FACE TEN OCLOCK
+1F559 FE0F ; emoji style; # (6.0) CLOCK FACE TEN OCLOCK
+1F55A FE0E ; text style; # (6.0) CLOCK FACE ELEVEN OCLOCK
+1F55A FE0F ; emoji style; # (6.0) CLOCK FACE ELEVEN OCLOCK
+1F55B FE0E ; text style; # (6.0) CLOCK FACE TWELVE OCLOCK
+1F55B FE0F ; emoji style; # (6.0) CLOCK FACE TWELVE OCLOCK
+1F55C FE0E ; text style; # (6.0) CLOCK FACE ONE-THIRTY
+1F55C FE0F ; emoji style; # (6.0) CLOCK FACE ONE-THIRTY
+1F55D FE0E ; text style; # (6.0) CLOCK FACE TWO-THIRTY
+1F55D FE0F ; emoji style; # (6.0) CLOCK FACE TWO-THIRTY
+1F55E FE0E ; text style; # (6.0) CLOCK FACE THREE-THIRTY
+1F55E FE0F ; emoji style; # (6.0) CLOCK FACE THREE-THIRTY
+1F55F FE0E ; text style; # (6.0) CLOCK FACE FOUR-THIRTY
+1F55F FE0F ; emoji style; # (6.0) CLOCK FACE FOUR-THIRTY
+1F560 FE0E ; text style; # (6.0) CLOCK FACE FIVE-THIRTY
+1F560 FE0F ; emoji style; # (6.0) CLOCK FACE FIVE-THIRTY
+1F561 FE0E ; text style; # (6.0) CLOCK FACE SIX-THIRTY
+1F561 FE0F ; emoji style; # (6.0) CLOCK FACE SIX-THIRTY
+1F562 FE0E ; text style; # (6.0) CLOCK FACE SEVEN-THIRTY
+1F562 FE0F ; emoji style; # (6.0) CLOCK FACE SEVEN-THIRTY
+1F563 FE0E ; text style; # (6.0) CLOCK FACE EIGHT-THIRTY
+1F563 FE0F ; emoji style; # (6.0) CLOCK FACE EIGHT-THIRTY
+1F564 FE0E ; text style; # (6.0) CLOCK FACE NINE-THIRTY
+1F564 FE0F ; emoji style; # (6.0) CLOCK FACE NINE-THIRTY
+1F565 FE0E ; text style; # (6.0) CLOCK FACE TEN-THIRTY
+1F565 FE0F ; emoji style; # (6.0) CLOCK FACE TEN-THIRTY
+1F566 FE0E ; text style; # (6.0) CLOCK FACE ELEVEN-THIRTY
+1F566 FE0F ; emoji style; # (6.0) CLOCK FACE ELEVEN-THIRTY
+1F567 FE0E ; text style; # (6.0) CLOCK FACE TWELVE-THIRTY
+1F567 FE0F ; emoji style; # (6.0) CLOCK FACE TWELVE-THIRTY
+1F56F FE0E ; text style; # (7.0) CANDLE
+1F56F FE0F ; emoji style; # (7.0) CANDLE
+1F570 FE0E ; text style; # (7.0) MANTELPIECE CLOCK
+1F570 FE0F ; emoji style; # (7.0) MANTELPIECE CLOCK
+1F573 FE0E ; text style; # (7.0) HOLE
+1F573 FE0F ; emoji style; # (7.0) HOLE
+1F574 FE0E ; text style; # (7.0) MAN IN BUSINESS SUIT LEVITATING
+1F574 FE0F ; emoji style; # (7.0) MAN IN BUSINESS SUIT LEVITATING
+1F575 FE0E ; text style; # (7.0) SLEUTH OR SPY
+1F575 FE0F ; emoji style; # (7.0) SLEUTH OR SPY
+1F576 FE0E ; text style; # (7.0) DARK SUNGLASSES
+1F576 FE0F ; emoji style; # (7.0) DARK SUNGLASSES
+1F577 FE0E ; text style; # (7.0) SPIDER
+1F577 FE0F ; emoji style; # (7.0) SPIDER
+1F578 FE0E ; text style; # (7.0) SPIDER WEB
+1F578 FE0F ; emoji style; # (7.0) SPIDER WEB
+1F579 FE0E ; text style; # (7.0) JOYSTICK
+1F579 FE0F ; emoji style; # (7.0) JOYSTICK
+1F587 FE0E ; text style; # (7.0) LINKED PAPERCLIPS
+1F587 FE0F ; emoji style; # (7.0) LINKED PAPERCLIPS
+1F58A FE0E ; text style; # (7.0) LOWER LEFT BALLPOINT PEN
+1F58A FE0F ; emoji style; # (7.0) LOWER LEFT BALLPOINT PEN
+1F58B FE0E ; text style; # (7.0) LOWER LEFT FOUNTAIN PEN
+1F58B FE0F ; emoji style; # (7.0) LOWER LEFT FOUNTAIN PEN
+1F58C FE0E ; text style; # (7.0) LOWER LEFT PAINTBRUSH
+1F58C FE0F ; emoji style; # (7.0) LOWER LEFT PAINTBRUSH
+1F58D FE0E ; text style; # (7.0) LOWER LEFT CRAYON
+1F58D FE0F ; emoji style; # (7.0) LOWER LEFT CRAYON
+1F590 FE0E ; text style; # (7.0) RAISED HAND WITH FINGERS SPLAYED
+1F590 FE0F ; emoji style; # (7.0) RAISED HAND WITH FINGERS SPLAYED
+1F5A5 FE0E ; text style; # (7.0) DESKTOP COMPUTER
+1F5A5 FE0F ; emoji style; # (7.0) DESKTOP COMPUTER
+1F5A8 FE0E ; text style; # (7.0) PRINTER
+1F5A8 FE0F ; emoji style; # (7.0) PRINTER
+1F5B1 FE0E ; text style; # (7.0) THREE BUTTON MOUSE
+1F5B1 FE0F ; emoji style; # (7.0) THREE BUTTON MOUSE
+1F5B2 FE0E ; text style; # (7.0) TRACKBALL
+1F5B2 FE0F ; emoji style; # (7.0) TRACKBALL
+1F5BC FE0E ; text style; # (7.0) FRAME WITH PICTURE
+1F5BC FE0F ; emoji style; # (7.0) FRAME WITH PICTURE
+1F5C2 FE0E ; text style; # (7.0) CARD INDEX DIVIDERS
+1F5C2 FE0F ; emoji style; # (7.0) CARD INDEX DIVIDERS
+1F5C3 FE0E ; text style; # (7.0) CARD FILE BOX
+1F5C3 FE0F ; emoji style; # (7.0) CARD FILE BOX
+1F5C4 FE0E ; text style; # (7.0) FILE CABINET
+1F5C4 FE0F ; emoji style; # (7.0) FILE CABINET
+1F5D1 FE0E ; text style; # (7.0) WASTEBASKET
+1F5D1 FE0F ; emoji style; # (7.0) WASTEBASKET
+1F5D2 FE0E ; text style; # (7.0) SPIRAL NOTE PAD
+1F5D2 FE0F ; emoji style; # (7.0) SPIRAL NOTE PAD
+1F5D3 FE0E ; text style; # (7.0) SPIRAL CALENDAR PAD
+1F5D3 FE0F ; emoji style; # (7.0) SPIRAL CALENDAR PAD
+1F5DC FE0E ; text style; # (7.0) COMPRESSION
+1F5DC FE0F ; emoji style; # (7.0) COMPRESSION
+1F5DD FE0E ; text style; # (7.0) OLD KEY
+1F5DD FE0F ; emoji style; # (7.0) OLD KEY
+1F5DE FE0E ; text style; # (7.0) ROLLED-UP NEWSPAPER
+1F5DE FE0F ; emoji style; # (7.0) ROLLED-UP NEWSPAPER
+1F5E1 FE0E ; text style; # (7.0) DAGGER KNIFE
+1F5E1 FE0F ; emoji style; # (7.0) DAGGER KNIFE
+1F5E3 FE0E ; text style; # (7.0) SPEAKING HEAD IN SILHOUETTE
+1F5E3 FE0F ; emoji style; # (7.0) SPEAKING HEAD IN SILHOUETTE
+1F5E8 FE0E ; text style; # (7.0) LEFT SPEECH BUBBLE
+1F5E8 FE0F ; emoji style; # (7.0) LEFT SPEECH BUBBLE
+1F5EF FE0E ; text style; # (7.0) RIGHT ANGER BUBBLE
+1F5EF FE0F ; emoji style; # (7.0) RIGHT ANGER BUBBLE
+1F5F3 FE0E ; text style; # (7.0) BALLOT BOX WITH BALLOT
+1F5F3 FE0F ; emoji style; # (7.0) BALLOT BOX WITH BALLOT
+1F5FA FE0E ; text style; # (7.0) WORLD MAP
+1F5FA FE0F ; emoji style; # (7.0) WORLD MAP
+1F610 FE0E ; text style; # (6.0) NEUTRAL FACE
+1F610 FE0F ; emoji style; # (6.0) NEUTRAL FACE
+1F687 FE0E ; text style; # (6.0) METRO
+1F687 FE0F ; emoji style; # (6.0) METRO
+1F68D FE0E ; text style; # (6.0) ONCOMING BUS
+1F68D FE0F ; emoji style; # (6.0) ONCOMING BUS
+1F691 FE0E ; text style; # (6.0) AMBULANCE
+1F691 FE0F ; emoji style; # (6.0) AMBULANCE
+1F694 FE0E ; text style; # (6.0) ONCOMING POLICE CAR
+1F694 FE0F ; emoji style; # (6.0) ONCOMING POLICE CAR
+1F698 FE0E ; text style; # (6.0) ONCOMING AUTOMOBILE
+1F698 FE0F ; emoji style; # (6.0) ONCOMING AUTOMOBILE
+1F6AD FE0E ; text style; # (6.0) NO SMOKING SYMBOL
+1F6AD FE0F ; emoji style; # (6.0) NO SMOKING SYMBOL
+1F6B2 FE0E ; text style; # (6.0) BICYCLE
+1F6B2 FE0F ; emoji style; # (6.0) BICYCLE
+1F6B9 FE0E ; text style; # (6.0) MENS SYMBOL
+1F6B9 FE0F ; emoji style; # (6.0) MENS SYMBOL
+1F6BA FE0E ; text style; # (6.0) WOMENS SYMBOL
+1F6BA FE0F ; emoji style; # (6.0) WOMENS SYMBOL
+1F6BC FE0E ; text style; # (6.0) BABY SYMBOL
+1F6BC FE0F ; emoji style; # (6.0) BABY SYMBOL
+1F6CB FE0E ; text style; # (7.0) COUCH AND LAMP
+1F6CB FE0F ; emoji style; # (7.0) COUCH AND LAMP
+1F6CD FE0E ; text style; # (7.0) SHOPPING BAGS
+1F6CD FE0F ; emoji style; # (7.0) SHOPPING BAGS
+1F6CE FE0E ; text style; # (7.0) BELLHOP BELL
+1F6CE FE0F ; emoji style; # (7.0) BELLHOP BELL
+1F6CF FE0E ; text style; # (7.0) BED
+1F6CF FE0F ; emoji style; # (7.0) BED
+1F6E0 FE0E ; text style; # (7.0) HAMMER AND WRENCH
+1F6E0 FE0F ; emoji style; # (7.0) HAMMER AND WRENCH
+1F6E1 FE0E ; text style; # (7.0) SHIELD
+1F6E1 FE0F ; emoji style; # (7.0) SHIELD
+1F6E2 FE0E ; text style; # (7.0) OIL DRUM
+1F6E2 FE0F ; emoji style; # (7.0) OIL DRUM
+1F6E3 FE0E ; text style; # (7.0) MOTORWAY
+1F6E3 FE0F ; emoji style; # (7.0) MOTORWAY
+1F6E4 FE0E ; text style; # (7.0) RAILWAY TRACK
+1F6E4 FE0F ; emoji style; # (7.0) RAILWAY TRACK
+1F6E5 FE0E ; text style; # (7.0) MOTOR BOAT
+1F6E5 FE0F ; emoji style; # (7.0) MOTOR BOAT
+1F6E9 FE0E ; text style; # (7.0) SMALL AIRPLANE
+1F6E9 FE0F ; emoji style; # (7.0) SMALL AIRPLANE
+1F6F0 FE0E ; text style; # (7.0) SATELLITE
+1F6F0 FE0F ; emoji style; # (7.0) SATELLITE
+1F6F3 FE0E ; text style; # (7.0) PASSENGER SHIP
+1F6F3 FE0F ; emoji style; # (7.0) PASSENGER SHIP
-#Total sequences: 354
+#Total sequences: 371
#EOF
diff --git a/admin/unidata/emoji-zwj-sequences.txt b/admin/unidata/emoji-zwj-sequences.txt
index 4125bec62e2..25f8b6154b5 100644
--- a/admin/unidata/emoji-zwj-sequences.txt
+++ b/admin/unidata/emoji-zwj-sequences.txt
@@ -1,11 +1,11 @@
# emoji-zwj-sequences.txt
-# Date: 2022-05-06, 16:14:52 GMT
-# © 2022 Unicode®, Inc.
+# Date: 2023-06-05, 20:04:50 GMT
+# © 2023 Unicode®, Inc.
# Unicode and the Unicode Logo are registered trademarks of Unicode, Inc. in the U.S. and other countries.
# For terms of use, see https://www.unicode.org/terms_of_use.html
#
# Emoji ZWJ Sequences for UTS #51
-# Version: 15.0
+# Version: 15.1
#
# For documentation and usage, see https://www.unicode.org/reports/tr51
#
@@ -269,6 +269,10 @@
1F469 1F3FF 200D 1F91D 200D 1F469 1F3FD ; RGI_Emoji_ZWJ_Sequence ; women holding hands: dark skin tone, medium skin tone # E12.0 [1] (👩🏿‍🤝‍👩🏽)
1F469 1F3FF 200D 1F91D 200D 1F469 1F3FE ; RGI_Emoji_ZWJ_Sequence ; women holding hands: dark skin tone, medium-dark skin tone # E12.0 [1] (👩🏿‍🤝‍👩🏾)
1F9D1 200D 1F91D 200D 1F9D1 ; RGI_Emoji_ZWJ_Sequence ; people holding hands # E12.0 [1] (🧑‍🤝‍🧑)
+1F9D1 200D 1F9D1 200D 1F9D2 ; RGI_Emoji_ZWJ_Sequence ; family: adult, adult, child # E15.1 [1] (🧑‍🧑‍🧒)
+1F9D1 200D 1F9D1 200D 1F9D2 200D 1F9D2 ; RGI_Emoji_ZWJ_Sequence ; family: adult, adult, child, child # E15.1 [1] (🧑‍🧑‍🧒‍🧒)
+1F9D1 200D 1F9D2 ; RGI_Emoji_ZWJ_Sequence ; family: adult, child # E15.1 [1] (🧑‍🧒)
+1F9D1 200D 1F9D2 200D 1F9D2 ; RGI_Emoji_ZWJ_Sequence ; family: adult, child, child # E15.1 [1] (🧑‍🧒‍🧒)
1F9D1 1F3FB 200D 2764 FE0F 200D 1F48B 200D 1F9D1 1F3FC; RGI_Emoji_ZWJ_Sequence; kiss: person, person, light skin tone, medium-light skin tone #E13.1[1] (🧑🏻‍❤️‍💋‍🧑🏼)
1F9D1 1F3FB 200D 2764 FE0F 200D 1F48B 200D 1F9D1 1F3FD; RGI_Emoji_ZWJ_Sequence; kiss: person, person, light skin tone, medium skin tone #E13.1 [1] (🧑🏻‍❤️‍💋‍🧑🏽)
1F9D1 1F3FB 200D 2764 FE0F 200D 1F48B 200D 1F9D1 1F3FE; RGI_Emoji_ZWJ_Sequence; kiss: person, person, light skin tone, medium-dark skin tone #E13.1[1] (🧑🏻‍❤️‍💋‍🧑🏾)
@@ -277,7 +281,6 @@
1F9D1 1F3FB 200D 2764 FE0F 200D 1F9D1 1F3FD ; RGI_Emoji_ZWJ_Sequence ; couple with heart: person, person, light skin tone, medium skin tone #E13.1[1] (🧑🏻‍❤️‍🧑🏽)
1F9D1 1F3FB 200D 2764 FE0F 200D 1F9D1 1F3FE ; RGI_Emoji_ZWJ_Sequence ; couple with heart: person, person, light skin tone, medium-dark skin tone #E13.1[1] (🧑🏻‍❤️‍🧑🏾)
1F9D1 1F3FB 200D 2764 FE0F 200D 1F9D1 1F3FF ; RGI_Emoji_ZWJ_Sequence ; couple with heart: person, person, light skin tone, dark skin tone #E13.1[1] (🧑🏻‍❤️‍🧑🏿)
-1F9D1 1F3FB 200D 1F384 ; RGI_Emoji_ZWJ_Sequence ; mx claus: light skin tone # E13.0 [1] (🧑🏻‍🎄)
1F9D1 1F3FB 200D 1F91D 200D 1F9D1 1F3FB ; RGI_Emoji_ZWJ_Sequence ; people holding hands: light skin tone # E12.0 [1] (🧑🏻‍🤝‍🧑🏻)
1F9D1 1F3FB 200D 1F91D 200D 1F9D1 1F3FC ; RGI_Emoji_ZWJ_Sequence ; people holding hands: light skin tone, medium-light skin tone # E12.1 [1] (🧑🏻‍🤝‍🧑🏼)
1F9D1 1F3FB 200D 1F91D 200D 1F9D1 1F3FD ; RGI_Emoji_ZWJ_Sequence ; people holding hands: light skin tone, medium skin tone # E12.1 [1] (🧑🏻‍🤝‍🧑🏽)
@@ -291,7 +294,6 @@
1F9D1 1F3FC 200D 2764 FE0F 200D 1F9D1 1F3FD ; RGI_Emoji_ZWJ_Sequence ; couple with heart: person, person, medium-light skin tone, medium skin tone #E13.1[1] (🧑🏼‍❤️‍🧑🏽)
1F9D1 1F3FC 200D 2764 FE0F 200D 1F9D1 1F3FE ; RGI_Emoji_ZWJ_Sequence ; couple with heart: person, person, medium-light skin tone, medium-dark skin tone #E13.1[1] (🧑🏼‍❤️‍🧑🏾)
1F9D1 1F3FC 200D 2764 FE0F 200D 1F9D1 1F3FF ; RGI_Emoji_ZWJ_Sequence ; couple with heart: person, person, medium-light skin tone, dark skin tone #E13.1[1] (🧑🏼‍❤️‍🧑🏿)
-1F9D1 1F3FC 200D 1F384 ; RGI_Emoji_ZWJ_Sequence ; mx claus: medium-light skin tone # E13.0 [1] (🧑🏼‍🎄)
1F9D1 1F3FC 200D 1F91D 200D 1F9D1 1F3FB ; RGI_Emoji_ZWJ_Sequence ; people holding hands: medium-light skin tone, light skin tone # E12.0 [1] (🧑🏼‍🤝‍🧑🏻)
1F9D1 1F3FC 200D 1F91D 200D 1F9D1 1F3FC ; RGI_Emoji_ZWJ_Sequence ; people holding hands: medium-light skin tone # E12.0 [1] (🧑🏼‍🤝‍🧑🏼)
1F9D1 1F3FC 200D 1F91D 200D 1F9D1 1F3FD ; RGI_Emoji_ZWJ_Sequence ; people holding hands: medium-light skin tone, medium skin tone # E12.1 [1] (🧑🏼‍🤝‍🧑🏽)
@@ -305,7 +307,6 @@
1F9D1 1F3FD 200D 2764 FE0F 200D 1F9D1 1F3FC ; RGI_Emoji_ZWJ_Sequence ; couple with heart: person, person, medium skin tone, medium-light skin tone #E13.1[1] (🧑🏽‍❤️‍🧑🏼)
1F9D1 1F3FD 200D 2764 FE0F 200D 1F9D1 1F3FE ; RGI_Emoji_ZWJ_Sequence ; couple with heart: person, person, medium skin tone, medium-dark skin tone #E13.1[1] (🧑🏽‍❤️‍🧑🏾)
1F9D1 1F3FD 200D 2764 FE0F 200D 1F9D1 1F3FF ; RGI_Emoji_ZWJ_Sequence ; couple with heart: person, person, medium skin tone, dark skin tone #E13.1[1] (🧑🏽‍❤️‍🧑🏿)
-1F9D1 1F3FD 200D 1F384 ; RGI_Emoji_ZWJ_Sequence ; mx claus: medium skin tone # E13.0 [1] (🧑🏽‍🎄)
1F9D1 1F3FD 200D 1F91D 200D 1F9D1 1F3FB ; RGI_Emoji_ZWJ_Sequence ; people holding hands: medium skin tone, light skin tone # E12.0 [1] (🧑🏽‍🤝‍🧑🏻)
1F9D1 1F3FD 200D 1F91D 200D 1F9D1 1F3FC ; RGI_Emoji_ZWJ_Sequence ; people holding hands: medium skin tone, medium-light skin tone # E12.0 [1] (🧑🏽‍🤝‍🧑🏼)
1F9D1 1F3FD 200D 1F91D 200D 1F9D1 1F3FD ; RGI_Emoji_ZWJ_Sequence ; people holding hands: medium skin tone # E12.0 [1] (🧑🏽‍🤝‍🧑🏽)
@@ -319,7 +320,6 @@
1F9D1 1F3FE 200D 2764 FE0F 200D 1F9D1 1F3FC ; RGI_Emoji_ZWJ_Sequence ; couple with heart: person, person, medium-dark skin tone, medium-light skin tone #E13.1[1] (🧑🏾‍❤️‍🧑🏼)
1F9D1 1F3FE 200D 2764 FE0F 200D 1F9D1 1F3FD ; RGI_Emoji_ZWJ_Sequence ; couple with heart: person, person, medium-dark skin tone, medium skin tone #E13.1[1] (🧑🏾‍❤️‍🧑🏽)
1F9D1 1F3FE 200D 2764 FE0F 200D 1F9D1 1F3FF ; RGI_Emoji_ZWJ_Sequence ; couple with heart: person, person, medium-dark skin tone, dark skin tone #E13.1[1] (🧑🏾‍❤️‍🧑🏿)
-1F9D1 1F3FE 200D 1F384 ; RGI_Emoji_ZWJ_Sequence ; mx claus: medium-dark skin tone # E13.0 [1] (🧑🏾‍🎄)
1F9D1 1F3FE 200D 1F91D 200D 1F9D1 1F3FB ; RGI_Emoji_ZWJ_Sequence ; people holding hands: medium-dark skin tone, light skin tone # E12.0 [1] (🧑🏾‍🤝‍🧑🏻)
1F9D1 1F3FE 200D 1F91D 200D 1F9D1 1F3FC ; RGI_Emoji_ZWJ_Sequence ; people holding hands: medium-dark skin tone, medium-light skin tone #E12.0[1] (🧑🏾‍🤝‍🧑🏼)
1F9D1 1F3FE 200D 1F91D 200D 1F9D1 1F3FD ; RGI_Emoji_ZWJ_Sequence ; people holding hands: medium-dark skin tone, medium skin tone # E12.0 [1] (🧑🏾‍🤝‍🧑🏽)
@@ -333,7 +333,6 @@
1F9D1 1F3FF 200D 2764 FE0F 200D 1F9D1 1F3FC ; RGI_Emoji_ZWJ_Sequence ; couple with heart: person, person, dark skin tone, medium-light skin tone #E13.1[1] (🧑🏿‍❤️‍🧑🏼)
1F9D1 1F3FF 200D 2764 FE0F 200D 1F9D1 1F3FD ; RGI_Emoji_ZWJ_Sequence ; couple with heart: person, person, dark skin tone, medium skin tone #E13.1[1] (🧑🏿‍❤️‍🧑🏽)
1F9D1 1F3FF 200D 2764 FE0F 200D 1F9D1 1F3FE ; RGI_Emoji_ZWJ_Sequence ; couple with heart: person, person, dark skin tone, medium-dark skin tone #E13.1[1] (🧑🏿‍❤️‍🧑🏾)
-1F9D1 1F3FF 200D 1F384 ; RGI_Emoji_ZWJ_Sequence ; mx claus: dark skin tone # E13.0 [1] (🧑🏿‍🎄)
1F9D1 1F3FF 200D 1F91D 200D 1F9D1 1F3FB ; RGI_Emoji_ZWJ_Sequence ; people holding hands: dark skin tone, light skin tone # E12.0 [1] (🧑🏿‍🤝‍🧑🏻)
1F9D1 1F3FF 200D 1F91D 200D 1F9D1 1F3FC ; RGI_Emoji_ZWJ_Sequence ; people holding hands: dark skin tone, medium-light skin tone # E12.0 [1] (🧑🏿‍🤝‍🧑🏼)
1F9D1 1F3FF 200D 1F91D 200D 1F9D1 1F3FD ; RGI_Emoji_ZWJ_Sequence ; people holding hands: dark skin tone, medium skin tone # E12.0 [1] (🧑🏿‍🤝‍🧑🏽)
@@ -360,12 +359,18 @@
1FAF1 1F3FF 200D 1FAF2 1F3FD ; RGI_Emoji_ZWJ_Sequence ; handshake: dark skin tone, medium skin tone # E14.0 [1] (🫱🏿‍🫲🏽)
1FAF1 1F3FF 200D 1FAF2 1F3FE ; RGI_Emoji_ZWJ_Sequence ; handshake: dark skin tone, medium-dark skin tone # E14.0 [1] (🫱🏿‍🫲🏾)
-# Total elements: 332
+# Total elements: 331
# ================================================
# RGI_Emoji_ZWJ_Sequence: Role
+1F3C3 200D 27A1 FE0F ; RGI_Emoji_ZWJ_Sequence ; person running facing right # E15.1 [1] (🏃‍➡️)
+1F3C3 1F3FB 200D 27A1 FE0F ; RGI_Emoji_ZWJ_Sequence ; person running facing right: light skin tone # E15.1 [1] (🏃🏻‍➡️)
+1F3C3 1F3FC 200D 27A1 FE0F ; RGI_Emoji_ZWJ_Sequence ; person running facing right: medium-light skin tone # E15.1 [1] (🏃🏼‍➡️)
+1F3C3 1F3FD 200D 27A1 FE0F ; RGI_Emoji_ZWJ_Sequence ; person running facing right: medium skin tone # E15.1 [1] (🏃🏽‍➡️)
+1F3C3 1F3FE 200D 27A1 FE0F ; RGI_Emoji_ZWJ_Sequence ; person running facing right: medium-dark skin tone # E15.1 [1] (🏃🏾‍➡️)
+1F3C3 1F3FF 200D 27A1 FE0F ; RGI_Emoji_ZWJ_Sequence ; person running facing right: dark skin tone # E15.1 [1] (🏃🏿‍➡️)
1F468 200D 2695 FE0F ; RGI_Emoji_ZWJ_Sequence ; man health worker # E4.0 [1] (👨‍⚕️)
1F468 200D 2696 FE0F ; RGI_Emoji_ZWJ_Sequence ; man judge # E4.0 [1] (👨‍⚖️)
1F468 200D 2708 FE0F ; RGI_Emoji_ZWJ_Sequence ; man pilot # E4.0 [1] (👨‍✈️)
@@ -384,8 +389,11 @@
1F468 200D 1F680 ; RGI_Emoji_ZWJ_Sequence ; man astronaut # E4.0 [1] (👨‍🚀)
1F468 200D 1F692 ; RGI_Emoji_ZWJ_Sequence ; man firefighter # E4.0 [1] (👨‍🚒)
1F468 200D 1F9AF ; RGI_Emoji_ZWJ_Sequence ; man with white cane # E12.0 [1] (👨‍🦯)
+1F468 200D 1F9AF 200D 27A1 FE0F ; RGI_Emoji_ZWJ_Sequence ; man with white cane facing right # E15.1 [1] (👨‍🦯‍➡️)
1F468 200D 1F9BC ; RGI_Emoji_ZWJ_Sequence ; man in motorized wheelchair # E12.0 [1] (👨‍🦼)
+1F468 200D 1F9BC 200D 27A1 FE0F ; RGI_Emoji_ZWJ_Sequence ; man in motorized wheelchair facing right # E15.1 [1] (👨‍🦼‍➡️)
1F468 200D 1F9BD ; RGI_Emoji_ZWJ_Sequence ; man in manual wheelchair # E12.0 [1] (👨‍🦽)
+1F468 200D 1F9BD 200D 27A1 FE0F ; RGI_Emoji_ZWJ_Sequence ; man in manual wheelchair facing right # E15.1 [1] (👨‍🦽‍➡️)
1F468 1F3FB 200D 2695 FE0F ; RGI_Emoji_ZWJ_Sequence ; man health worker: light skin tone # E4.0 [1] (👨🏻‍⚕️)
1F468 1F3FB 200D 2696 FE0F ; RGI_Emoji_ZWJ_Sequence ; man judge: light skin tone # E4.0 [1] (👨🏻‍⚖️)
1F468 1F3FB 200D 2708 FE0F ; RGI_Emoji_ZWJ_Sequence ; man pilot: light skin tone # E4.0 [1] (👨🏻‍✈️)
@@ -404,8 +412,11 @@
1F468 1F3FB 200D 1F680 ; RGI_Emoji_ZWJ_Sequence ; man astronaut: light skin tone # E4.0 [1] (👨🏻‍🚀)
1F468 1F3FB 200D 1F692 ; RGI_Emoji_ZWJ_Sequence ; man firefighter: light skin tone # E4.0 [1] (👨🏻‍🚒)
1F468 1F3FB 200D 1F9AF ; RGI_Emoji_ZWJ_Sequence ; man with white cane: light skin tone # E12.0 [1] (👨🏻‍🦯)
+1F468 1F3FB 200D 1F9AF 200D 27A1 FE0F ; RGI_Emoji_ZWJ_Sequence ; man with white cane facing right: light skin tone # E15.1 [1] (👨🏻‍🦯‍➡️)
1F468 1F3FB 200D 1F9BC ; RGI_Emoji_ZWJ_Sequence ; man in motorized wheelchair: light skin tone # E12.0 [1] (👨🏻‍🦼)
+1F468 1F3FB 200D 1F9BC 200D 27A1 FE0F ; RGI_Emoji_ZWJ_Sequence ; man in motorized wheelchair facing right: light skin tone # E15.1 [1] (👨🏻‍🦼‍➡️)
1F468 1F3FB 200D 1F9BD ; RGI_Emoji_ZWJ_Sequence ; man in manual wheelchair: light skin tone # E12.0 [1] (👨🏻‍🦽)
+1F468 1F3FB 200D 1F9BD 200D 27A1 FE0F ; RGI_Emoji_ZWJ_Sequence ; man in manual wheelchair facing right: light skin tone # E15.1 [1] (👨🏻‍🦽‍➡️)
1F468 1F3FC 200D 2695 FE0F ; RGI_Emoji_ZWJ_Sequence ; man health worker: medium-light skin tone # E4.0 [1] (👨🏼‍⚕️)
1F468 1F3FC 200D 2696 FE0F ; RGI_Emoji_ZWJ_Sequence ; man judge: medium-light skin tone # E4.0 [1] (👨🏼‍⚖️)
1F468 1F3FC 200D 2708 FE0F ; RGI_Emoji_ZWJ_Sequence ; man pilot: medium-light skin tone # E4.0 [1] (👨🏼‍✈️)
@@ -424,8 +435,11 @@
1F468 1F3FC 200D 1F680 ; RGI_Emoji_ZWJ_Sequence ; man astronaut: medium-light skin tone # E4.0 [1] (👨🏼‍🚀)
1F468 1F3FC 200D 1F692 ; RGI_Emoji_ZWJ_Sequence ; man firefighter: medium-light skin tone # E4.0 [1] (👨🏼‍🚒)
1F468 1F3FC 200D 1F9AF ; RGI_Emoji_ZWJ_Sequence ; man with white cane: medium-light skin tone # E12.0 [1] (👨🏼‍🦯)
+1F468 1F3FC 200D 1F9AF 200D 27A1 FE0F ; RGI_Emoji_ZWJ_Sequence ; man with white cane facing right: medium-light skin tone # E15.1 [1] (👨🏼‍🦯‍➡️)
1F468 1F3FC 200D 1F9BC ; RGI_Emoji_ZWJ_Sequence ; man in motorized wheelchair: medium-light skin tone # E12.0 [1] (👨🏼‍🦼)
+1F468 1F3FC 200D 1F9BC 200D 27A1 FE0F ; RGI_Emoji_ZWJ_Sequence ; man in motorized wheelchair facing right: medium-light skin tone #E15.1 [1] (👨🏼‍🦼‍➡️)
1F468 1F3FC 200D 1F9BD ; RGI_Emoji_ZWJ_Sequence ; man in manual wheelchair: medium-light skin tone # E12.0 [1] (👨🏼‍🦽)
+1F468 1F3FC 200D 1F9BD 200D 27A1 FE0F ; RGI_Emoji_ZWJ_Sequence ; man in manual wheelchair facing right: medium-light skin tone # E15.1 [1] (👨🏼‍🦽‍➡️)
1F468 1F3FD 200D 2695 FE0F ; RGI_Emoji_ZWJ_Sequence ; man health worker: medium skin tone # E4.0 [1] (👨🏽‍⚕️)
1F468 1F3FD 200D 2696 FE0F ; RGI_Emoji_ZWJ_Sequence ; man judge: medium skin tone # E4.0 [1] (👨🏽‍⚖️)
1F468 1F3FD 200D 2708 FE0F ; RGI_Emoji_ZWJ_Sequence ; man pilot: medium skin tone # E4.0 [1] (👨🏽‍✈️)
@@ -444,8 +458,11 @@
1F468 1F3FD 200D 1F680 ; RGI_Emoji_ZWJ_Sequence ; man astronaut: medium skin tone # E4.0 [1] (👨🏽‍🚀)
1F468 1F3FD 200D 1F692 ; RGI_Emoji_ZWJ_Sequence ; man firefighter: medium skin tone # E4.0 [1] (👨🏽‍🚒)
1F468 1F3FD 200D 1F9AF ; RGI_Emoji_ZWJ_Sequence ; man with white cane: medium skin tone # E12.0 [1] (👨🏽‍🦯)
+1F468 1F3FD 200D 1F9AF 200D 27A1 FE0F ; RGI_Emoji_ZWJ_Sequence ; man with white cane facing right: medium skin tone # E15.1 [1] (👨🏽‍🦯‍➡️)
1F468 1F3FD 200D 1F9BC ; RGI_Emoji_ZWJ_Sequence ; man in motorized wheelchair: medium skin tone # E12.0 [1] (👨🏽‍🦼)
+1F468 1F3FD 200D 1F9BC 200D 27A1 FE0F ; RGI_Emoji_ZWJ_Sequence ; man in motorized wheelchair facing right: medium skin tone # E15.1 [1] (👨🏽‍🦼‍➡️)
1F468 1F3FD 200D 1F9BD ; RGI_Emoji_ZWJ_Sequence ; man in manual wheelchair: medium skin tone # E12.0 [1] (👨🏽‍🦽)
+1F468 1F3FD 200D 1F9BD 200D 27A1 FE0F ; RGI_Emoji_ZWJ_Sequence ; man in manual wheelchair facing right: medium skin tone # E15.1 [1] (👨🏽‍🦽‍➡️)
1F468 1F3FE 200D 2695 FE0F ; RGI_Emoji_ZWJ_Sequence ; man health worker: medium-dark skin tone # E4.0 [1] (👨🏾‍⚕️)
1F468 1F3FE 200D 2696 FE0F ; RGI_Emoji_ZWJ_Sequence ; man judge: medium-dark skin tone # E4.0 [1] (👨🏾‍⚖️)
1F468 1F3FE 200D 2708 FE0F ; RGI_Emoji_ZWJ_Sequence ; man pilot: medium-dark skin tone # E4.0 [1] (👨🏾‍✈️)
@@ -464,8 +481,11 @@
1F468 1F3FE 200D 1F680 ; RGI_Emoji_ZWJ_Sequence ; man astronaut: medium-dark skin tone # E4.0 [1] (👨🏾‍🚀)
1F468 1F3FE 200D 1F692 ; RGI_Emoji_ZWJ_Sequence ; man firefighter: medium-dark skin tone # E4.0 [1] (👨🏾‍🚒)
1F468 1F3FE 200D 1F9AF ; RGI_Emoji_ZWJ_Sequence ; man with white cane: medium-dark skin tone # E12.0 [1] (👨🏾‍🦯)
+1F468 1F3FE 200D 1F9AF 200D 27A1 FE0F ; RGI_Emoji_ZWJ_Sequence ; man with white cane facing right: medium-dark skin tone # E15.1 [1] (👨🏾‍🦯‍➡️)
1F468 1F3FE 200D 1F9BC ; RGI_Emoji_ZWJ_Sequence ; man in motorized wheelchair: medium-dark skin tone # E12.0 [1] (👨🏾‍🦼)
+1F468 1F3FE 200D 1F9BC 200D 27A1 FE0F ; RGI_Emoji_ZWJ_Sequence ; man in motorized wheelchair facing right: medium-dark skin tone #E15.1 [1] (👨🏾‍🦼‍➡️)
1F468 1F3FE 200D 1F9BD ; RGI_Emoji_ZWJ_Sequence ; man in manual wheelchair: medium-dark skin tone # E12.0 [1] (👨🏾‍🦽)
+1F468 1F3FE 200D 1F9BD 200D 27A1 FE0F ; RGI_Emoji_ZWJ_Sequence ; man in manual wheelchair facing right: medium-dark skin tone # E15.1 [1] (👨🏾‍🦽‍➡️)
1F468 1F3FF 200D 2695 FE0F ; RGI_Emoji_ZWJ_Sequence ; man health worker: dark skin tone # E4.0 [1] (👨🏿‍⚕️)
1F468 1F3FF 200D 2696 FE0F ; RGI_Emoji_ZWJ_Sequence ; man judge: dark skin tone # E4.0 [1] (👨🏿‍⚖️)
1F468 1F3FF 200D 2708 FE0F ; RGI_Emoji_ZWJ_Sequence ; man pilot: dark skin tone # E4.0 [1] (👨🏿‍✈️)
@@ -484,8 +504,11 @@
1F468 1F3FF 200D 1F680 ; RGI_Emoji_ZWJ_Sequence ; man astronaut: dark skin tone # E4.0 [1] (👨🏿‍🚀)
1F468 1F3FF 200D 1F692 ; RGI_Emoji_ZWJ_Sequence ; man firefighter: dark skin tone # E4.0 [1] (👨🏿‍🚒)
1F468 1F3FF 200D 1F9AF ; RGI_Emoji_ZWJ_Sequence ; man with white cane: dark skin tone # E12.0 [1] (👨🏿‍🦯)
+1F468 1F3FF 200D 1F9AF 200D 27A1 FE0F ; RGI_Emoji_ZWJ_Sequence ; man with white cane facing right: dark skin tone # E15.1 [1] (👨🏿‍🦯‍➡️)
1F468 1F3FF 200D 1F9BC ; RGI_Emoji_ZWJ_Sequence ; man in motorized wheelchair: dark skin tone # E12.0 [1] (👨🏿‍🦼)
+1F468 1F3FF 200D 1F9BC 200D 27A1 FE0F ; RGI_Emoji_ZWJ_Sequence ; man in motorized wheelchair facing right: dark skin tone # E15.1 [1] (👨🏿‍🦼‍➡️)
1F468 1F3FF 200D 1F9BD ; RGI_Emoji_ZWJ_Sequence ; man in manual wheelchair: dark skin tone # E12.0 [1] (👨🏿‍🦽)
+1F468 1F3FF 200D 1F9BD 200D 27A1 FE0F ; RGI_Emoji_ZWJ_Sequence ; man in manual wheelchair facing right: dark skin tone # E15.1 [1] (👨🏿‍🦽‍➡️)
1F469 200D 2695 FE0F ; RGI_Emoji_ZWJ_Sequence ; woman health worker # E4.0 [1] (👩‍⚕️)
1F469 200D 2696 FE0F ; RGI_Emoji_ZWJ_Sequence ; woman judge # E4.0 [1] (👩‍⚖️)
1F469 200D 2708 FE0F ; RGI_Emoji_ZWJ_Sequence ; woman pilot # E4.0 [1] (👩‍✈️)
@@ -504,8 +527,11 @@
1F469 200D 1F680 ; RGI_Emoji_ZWJ_Sequence ; woman astronaut # E4.0 [1] (👩‍🚀)
1F469 200D 1F692 ; RGI_Emoji_ZWJ_Sequence ; woman firefighter # E4.0 [1] (👩‍🚒)
1F469 200D 1F9AF ; RGI_Emoji_ZWJ_Sequence ; woman with white cane # E12.0 [1] (👩‍🦯)
+1F469 200D 1F9AF 200D 27A1 FE0F ; RGI_Emoji_ZWJ_Sequence ; woman with white cane facing right # E15.1 [1] (👩‍🦯‍➡️)
1F469 200D 1F9BC ; RGI_Emoji_ZWJ_Sequence ; woman in motorized wheelchair # E12.0 [1] (👩‍🦼)
+1F469 200D 1F9BC 200D 27A1 FE0F ; RGI_Emoji_ZWJ_Sequence ; woman in motorized wheelchair facing right # E15.1 [1] (👩‍🦼‍➡️)
1F469 200D 1F9BD ; RGI_Emoji_ZWJ_Sequence ; woman in manual wheelchair # E12.0 [1] (👩‍🦽)
+1F469 200D 1F9BD 200D 27A1 FE0F ; RGI_Emoji_ZWJ_Sequence ; woman in manual wheelchair facing right # E15.1 [1] (👩‍🦽‍➡️)
1F469 1F3FB 200D 2695 FE0F ; RGI_Emoji_ZWJ_Sequence ; woman health worker: light skin tone # E4.0 [1] (👩🏻‍⚕️)
1F469 1F3FB 200D 2696 FE0F ; RGI_Emoji_ZWJ_Sequence ; woman judge: light skin tone # E4.0 [1] (👩🏻‍⚖️)
1F469 1F3FB 200D 2708 FE0F ; RGI_Emoji_ZWJ_Sequence ; woman pilot: light skin tone # E4.0 [1] (👩🏻‍✈️)
@@ -524,8 +550,11 @@
1F469 1F3FB 200D 1F680 ; RGI_Emoji_ZWJ_Sequence ; woman astronaut: light skin tone # E4.0 [1] (👩🏻‍🚀)
1F469 1F3FB 200D 1F692 ; RGI_Emoji_ZWJ_Sequence ; woman firefighter: light skin tone # E4.0 [1] (👩🏻‍🚒)
1F469 1F3FB 200D 1F9AF ; RGI_Emoji_ZWJ_Sequence ; woman with white cane: light skin tone # E12.0 [1] (👩🏻‍🦯)
+1F469 1F3FB 200D 1F9AF 200D 27A1 FE0F ; RGI_Emoji_ZWJ_Sequence ; woman with white cane facing right: light skin tone # E15.1 [1] (👩🏻‍🦯‍➡️)
1F469 1F3FB 200D 1F9BC ; RGI_Emoji_ZWJ_Sequence ; woman in motorized wheelchair: light skin tone # E12.0 [1] (👩🏻‍🦼)
+1F469 1F3FB 200D 1F9BC 200D 27A1 FE0F ; RGI_Emoji_ZWJ_Sequence ; woman in motorized wheelchair facing right: light skin tone # E15.1 [1] (👩🏻‍🦼‍➡️)
1F469 1F3FB 200D 1F9BD ; RGI_Emoji_ZWJ_Sequence ; woman in manual wheelchair: light skin tone # E12.0 [1] (👩🏻‍🦽)
+1F469 1F3FB 200D 1F9BD 200D 27A1 FE0F ; RGI_Emoji_ZWJ_Sequence ; woman in manual wheelchair facing right: light skin tone # E15.1 [1] (👩🏻‍🦽‍➡️)
1F469 1F3FC 200D 2695 FE0F ; RGI_Emoji_ZWJ_Sequence ; woman health worker: medium-light skin tone # E4.0 [1] (👩🏼‍⚕️)
1F469 1F3FC 200D 2696 FE0F ; RGI_Emoji_ZWJ_Sequence ; woman judge: medium-light skin tone # E4.0 [1] (👩🏼‍⚖️)
1F469 1F3FC 200D 2708 FE0F ; RGI_Emoji_ZWJ_Sequence ; woman pilot: medium-light skin tone # E4.0 [1] (👩🏼‍✈️)
@@ -544,8 +573,11 @@
1F469 1F3FC 200D 1F680 ; RGI_Emoji_ZWJ_Sequence ; woman astronaut: medium-light skin tone # E4.0 [1] (👩🏼‍🚀)
1F469 1F3FC 200D 1F692 ; RGI_Emoji_ZWJ_Sequence ; woman firefighter: medium-light skin tone # E4.0 [1] (👩🏼‍🚒)
1F469 1F3FC 200D 1F9AF ; RGI_Emoji_ZWJ_Sequence ; woman with white cane: medium-light skin tone # E12.0 [1] (👩🏼‍🦯)
+1F469 1F3FC 200D 1F9AF 200D 27A1 FE0F ; RGI_Emoji_ZWJ_Sequence ; woman with white cane facing right: medium-light skin tone # E15.1 [1] (👩🏼‍🦯‍➡️)
1F469 1F3FC 200D 1F9BC ; RGI_Emoji_ZWJ_Sequence ; woman in motorized wheelchair: medium-light skin tone # E12.0 [1] (👩🏼‍🦼)
+1F469 1F3FC 200D 1F9BC 200D 27A1 FE0F ; RGI_Emoji_ZWJ_Sequence ; woman in motorized wheelchair facing right: medium-light skin tone #E15.1[1] (👩🏼‍🦼‍➡️)
1F469 1F3FC 200D 1F9BD ; RGI_Emoji_ZWJ_Sequence ; woman in manual wheelchair: medium-light skin tone # E12.0 [1] (👩🏼‍🦽)
+1F469 1F3FC 200D 1F9BD 200D 27A1 FE0F ; RGI_Emoji_ZWJ_Sequence ; woman in manual wheelchair facing right: medium-light skin tone #E15.1 [1] (👩🏼‍🦽‍➡️)
1F469 1F3FD 200D 2695 FE0F ; RGI_Emoji_ZWJ_Sequence ; woman health worker: medium skin tone # E4.0 [1] (👩🏽‍⚕️)
1F469 1F3FD 200D 2696 FE0F ; RGI_Emoji_ZWJ_Sequence ; woman judge: medium skin tone # E4.0 [1] (👩🏽‍⚖️)
1F469 1F3FD 200D 2708 FE0F ; RGI_Emoji_ZWJ_Sequence ; woman pilot: medium skin tone # E4.0 [1] (👩🏽‍✈️)
@@ -564,8 +596,11 @@
1F469 1F3FD 200D 1F680 ; RGI_Emoji_ZWJ_Sequence ; woman astronaut: medium skin tone # E4.0 [1] (👩🏽‍🚀)
1F469 1F3FD 200D 1F692 ; RGI_Emoji_ZWJ_Sequence ; woman firefighter: medium skin tone # E4.0 [1] (👩🏽‍🚒)
1F469 1F3FD 200D 1F9AF ; RGI_Emoji_ZWJ_Sequence ; woman with white cane: medium skin tone # E12.0 [1] (👩🏽‍🦯)
+1F469 1F3FD 200D 1F9AF 200D 27A1 FE0F ; RGI_Emoji_ZWJ_Sequence ; woman with white cane facing right: medium skin tone # E15.1 [1] (👩🏽‍🦯‍➡️)
1F469 1F3FD 200D 1F9BC ; RGI_Emoji_ZWJ_Sequence ; woman in motorized wheelchair: medium skin tone # E12.0 [1] (👩🏽‍🦼)
+1F469 1F3FD 200D 1F9BC 200D 27A1 FE0F ; RGI_Emoji_ZWJ_Sequence ; woman in motorized wheelchair facing right: medium skin tone # E15.1 [1] (👩🏽‍🦼‍➡️)
1F469 1F3FD 200D 1F9BD ; RGI_Emoji_ZWJ_Sequence ; woman in manual wheelchair: medium skin tone # E12.0 [1] (👩🏽‍🦽)
+1F469 1F3FD 200D 1F9BD 200D 27A1 FE0F ; RGI_Emoji_ZWJ_Sequence ; woman in manual wheelchair facing right: medium skin tone # E15.1 [1] (👩🏽‍🦽‍➡️)
1F469 1F3FE 200D 2695 FE0F ; RGI_Emoji_ZWJ_Sequence ; woman health worker: medium-dark skin tone # E4.0 [1] (👩🏾‍⚕️)
1F469 1F3FE 200D 2696 FE0F ; RGI_Emoji_ZWJ_Sequence ; woman judge: medium-dark skin tone # E4.0 [1] (👩🏾‍⚖️)
1F469 1F3FE 200D 2708 FE0F ; RGI_Emoji_ZWJ_Sequence ; woman pilot: medium-dark skin tone # E4.0 [1] (👩🏾‍✈️)
@@ -584,8 +619,11 @@
1F469 1F3FE 200D 1F680 ; RGI_Emoji_ZWJ_Sequence ; woman astronaut: medium-dark skin tone # E4.0 [1] (👩🏾‍🚀)
1F469 1F3FE 200D 1F692 ; RGI_Emoji_ZWJ_Sequence ; woman firefighter: medium-dark skin tone # E4.0 [1] (👩🏾‍🚒)
1F469 1F3FE 200D 1F9AF ; RGI_Emoji_ZWJ_Sequence ; woman with white cane: medium-dark skin tone # E12.0 [1] (👩🏾‍🦯)
+1F469 1F3FE 200D 1F9AF 200D 27A1 FE0F ; RGI_Emoji_ZWJ_Sequence ; woman with white cane facing right: medium-dark skin tone # E15.1 [1] (👩🏾‍🦯‍➡️)
1F469 1F3FE 200D 1F9BC ; RGI_Emoji_ZWJ_Sequence ; woman in motorized wheelchair: medium-dark skin tone # E12.0 [1] (👩🏾‍🦼)
+1F469 1F3FE 200D 1F9BC 200D 27A1 FE0F ; RGI_Emoji_ZWJ_Sequence ; woman in motorized wheelchair facing right: medium-dark skin tone #E15.1[1] (👩🏾‍🦼‍➡️)
1F469 1F3FE 200D 1F9BD ; RGI_Emoji_ZWJ_Sequence ; woman in manual wheelchair: medium-dark skin tone # E12.0 [1] (👩🏾‍🦽)
+1F469 1F3FE 200D 1F9BD 200D 27A1 FE0F ; RGI_Emoji_ZWJ_Sequence ; woman in manual wheelchair facing right: medium-dark skin tone # E15.1 [1] (👩🏾‍🦽‍➡️)
1F469 1F3FF 200D 2695 FE0F ; RGI_Emoji_ZWJ_Sequence ; woman health worker: dark skin tone # E4.0 [1] (👩🏿‍⚕️)
1F469 1F3FF 200D 2696 FE0F ; RGI_Emoji_ZWJ_Sequence ; woman judge: dark skin tone # E4.0 [1] (👩🏿‍⚖️)
1F469 1F3FF 200D 2708 FE0F ; RGI_Emoji_ZWJ_Sequence ; woman pilot: dark skin tone # E4.0 [1] (👩🏿‍✈️)
@@ -604,14 +642,30 @@
1F469 1F3FF 200D 1F680 ; RGI_Emoji_ZWJ_Sequence ; woman astronaut: dark skin tone # E4.0 [1] (👩🏿‍🚀)
1F469 1F3FF 200D 1F692 ; RGI_Emoji_ZWJ_Sequence ; woman firefighter: dark skin tone # E4.0 [1] (👩🏿‍🚒)
1F469 1F3FF 200D 1F9AF ; RGI_Emoji_ZWJ_Sequence ; woman with white cane: dark skin tone # E12.0 [1] (👩🏿‍🦯)
+1F469 1F3FF 200D 1F9AF 200D 27A1 FE0F ; RGI_Emoji_ZWJ_Sequence ; woman with white cane facing right: dark skin tone # E15.1 [1] (👩🏿‍🦯‍➡️)
1F469 1F3FF 200D 1F9BC ; RGI_Emoji_ZWJ_Sequence ; woman in motorized wheelchair: dark skin tone # E12.0 [1] (👩🏿‍🦼)
+1F469 1F3FF 200D 1F9BC 200D 27A1 FE0F ; RGI_Emoji_ZWJ_Sequence ; woman in motorized wheelchair facing right: dark skin tone # E15.1 [1] (👩🏿‍🦼‍➡️)
1F469 1F3FF 200D 1F9BD ; RGI_Emoji_ZWJ_Sequence ; woman in manual wheelchair: dark skin tone # E12.0 [1] (👩🏿‍🦽)
+1F469 1F3FF 200D 1F9BD 200D 27A1 FE0F ; RGI_Emoji_ZWJ_Sequence ; woman in manual wheelchair facing right: dark skin tone # E15.1 [1] (👩🏿‍🦽‍➡️)
+1F6B6 200D 27A1 FE0F ; RGI_Emoji_ZWJ_Sequence ; person walking facing right # E15.1 [1] (🚶‍➡️)
+1F6B6 1F3FB 200D 27A1 FE0F ; RGI_Emoji_ZWJ_Sequence ; person walking facing right: light skin tone # E15.1 [1] (🚶🏻‍➡️)
+1F6B6 1F3FC 200D 27A1 FE0F ; RGI_Emoji_ZWJ_Sequence ; person walking facing right: medium-light skin tone # E15.1 [1] (🚶🏼‍➡️)
+1F6B6 1F3FD 200D 27A1 FE0F ; RGI_Emoji_ZWJ_Sequence ; person walking facing right: medium skin tone # E15.1 [1] (🚶🏽‍➡️)
+1F6B6 1F3FE 200D 27A1 FE0F ; RGI_Emoji_ZWJ_Sequence ; person walking facing right: medium-dark skin tone # E15.1 [1] (🚶🏾‍➡️)
+1F6B6 1F3FF 200D 27A1 FE0F ; RGI_Emoji_ZWJ_Sequence ; person walking facing right: dark skin tone # E15.1 [1] (🚶🏿‍➡️)
+1F9CE 200D 27A1 FE0F ; RGI_Emoji_ZWJ_Sequence ; person kneeling facing right # E15.1 [1] (🧎‍➡️)
+1F9CE 1F3FB 200D 27A1 FE0F ; RGI_Emoji_ZWJ_Sequence ; person kneeling facing right: light skin tone # E15.1 [1] (🧎🏻‍➡️)
+1F9CE 1F3FC 200D 27A1 FE0F ; RGI_Emoji_ZWJ_Sequence ; person kneeling facing right: medium-light skin tone # E15.1 [1] (🧎🏼‍➡️)
+1F9CE 1F3FD 200D 27A1 FE0F ; RGI_Emoji_ZWJ_Sequence ; person kneeling facing right: medium skin tone # E15.1 [1] (🧎🏽‍➡️)
+1F9CE 1F3FE 200D 27A1 FE0F ; RGI_Emoji_ZWJ_Sequence ; person kneeling facing right: medium-dark skin tone # E15.1 [1] (🧎🏾‍➡️)
+1F9CE 1F3FF 200D 27A1 FE0F ; RGI_Emoji_ZWJ_Sequence ; person kneeling facing right: dark skin tone # E15.1 [1] (🧎🏿‍➡️)
1F9D1 200D 2695 FE0F ; RGI_Emoji_ZWJ_Sequence ; health worker # E12.1 [1] (🧑‍⚕️)
1F9D1 200D 2696 FE0F ; RGI_Emoji_ZWJ_Sequence ; judge # E12.1 [1] (🧑‍⚖️)
1F9D1 200D 2708 FE0F ; RGI_Emoji_ZWJ_Sequence ; pilot # E12.1 [1] (🧑‍✈️)
1F9D1 200D 1F33E ; RGI_Emoji_ZWJ_Sequence ; farmer # E12.1 [1] (🧑‍🌾)
1F9D1 200D 1F373 ; RGI_Emoji_ZWJ_Sequence ; cook # E12.1 [1] (🧑‍🍳)
1F9D1 200D 1F37C ; RGI_Emoji_ZWJ_Sequence ; person feeding baby # E13.0 [1] (🧑‍🍼)
+1F9D1 200D 1F384 ; RGI_Emoji_ZWJ_Sequence ; mx claus # E13.0 [1] (🧑‍🎄)
1F9D1 200D 1F393 ; RGI_Emoji_ZWJ_Sequence ; student # E12.1 [1] (🧑‍🎓)
1F9D1 200D 1F3A4 ; RGI_Emoji_ZWJ_Sequence ; singer # E12.1 [1] (🧑‍🎤)
1F9D1 200D 1F3A8 ; RGI_Emoji_ZWJ_Sequence ; artist # E12.1 [1] (🧑‍🎨)
@@ -624,14 +678,18 @@
1F9D1 200D 1F680 ; RGI_Emoji_ZWJ_Sequence ; astronaut # E12.1 [1] (🧑‍🚀)
1F9D1 200D 1F692 ; RGI_Emoji_ZWJ_Sequence ; firefighter # E12.1 [1] (🧑‍🚒)
1F9D1 200D 1F9AF ; RGI_Emoji_ZWJ_Sequence ; person with white cane # E12.1 [1] (🧑‍🦯)
+1F9D1 200D 1F9AF 200D 27A1 FE0F ; RGI_Emoji_ZWJ_Sequence ; person with white cane facing right # E15.1 [1] (🧑‍🦯‍➡️)
1F9D1 200D 1F9BC ; RGI_Emoji_ZWJ_Sequence ; person in motorized wheelchair # E12.1 [1] (🧑‍🦼)
+1F9D1 200D 1F9BC 200D 27A1 FE0F ; RGI_Emoji_ZWJ_Sequence ; person in motorized wheelchair facing right # E15.1 [1] (🧑‍🦼‍➡️)
1F9D1 200D 1F9BD ; RGI_Emoji_ZWJ_Sequence ; person in manual wheelchair # E12.1 [1] (🧑‍🦽)
+1F9D1 200D 1F9BD 200D 27A1 FE0F ; RGI_Emoji_ZWJ_Sequence ; person in manual wheelchair facing right # E15.1 [1] (🧑‍🦽‍➡️)
1F9D1 1F3FB 200D 2695 FE0F ; RGI_Emoji_ZWJ_Sequence ; health worker: light skin tone # E12.1 [1] (🧑🏻‍⚕️)
1F9D1 1F3FB 200D 2696 FE0F ; RGI_Emoji_ZWJ_Sequence ; judge: light skin tone # E12.1 [1] (🧑🏻‍⚖️)
1F9D1 1F3FB 200D 2708 FE0F ; RGI_Emoji_ZWJ_Sequence ; pilot: light skin tone # E12.1 [1] (🧑🏻‍✈️)
1F9D1 1F3FB 200D 1F33E ; RGI_Emoji_ZWJ_Sequence ; farmer: light skin tone # E12.1 [1] (🧑🏻‍🌾)
1F9D1 1F3FB 200D 1F373 ; RGI_Emoji_ZWJ_Sequence ; cook: light skin tone # E12.1 [1] (🧑🏻‍🍳)
1F9D1 1F3FB 200D 1F37C ; RGI_Emoji_ZWJ_Sequence ; person feeding baby: light skin tone # E13.0 [1] (🧑🏻‍🍼)
+1F9D1 1F3FB 200D 1F384 ; RGI_Emoji_ZWJ_Sequence ; mx claus: light skin tone # E13.0 [1] (🧑🏻‍🎄)
1F9D1 1F3FB 200D 1F393 ; RGI_Emoji_ZWJ_Sequence ; student: light skin tone # E12.1 [1] (🧑🏻‍🎓)
1F9D1 1F3FB 200D 1F3A4 ; RGI_Emoji_ZWJ_Sequence ; singer: light skin tone # E12.1 [1] (🧑🏻‍🎤)
1F9D1 1F3FB 200D 1F3A8 ; RGI_Emoji_ZWJ_Sequence ; artist: light skin tone # E12.1 [1] (🧑🏻‍🎨)
@@ -644,14 +702,18 @@
1F9D1 1F3FB 200D 1F680 ; RGI_Emoji_ZWJ_Sequence ; astronaut: light skin tone # E12.1 [1] (🧑🏻‍🚀)
1F9D1 1F3FB 200D 1F692 ; RGI_Emoji_ZWJ_Sequence ; firefighter: light skin tone # E12.1 [1] (🧑🏻‍🚒)
1F9D1 1F3FB 200D 1F9AF ; RGI_Emoji_ZWJ_Sequence ; person with white cane: light skin tone # E12.1 [1] (🧑🏻‍🦯)
+1F9D1 1F3FB 200D 1F9AF 200D 27A1 FE0F ; RGI_Emoji_ZWJ_Sequence ; person with white cane facing right: light skin tone # E15.1 [1] (🧑🏻‍🦯‍➡️)
1F9D1 1F3FB 200D 1F9BC ; RGI_Emoji_ZWJ_Sequence ; person in motorized wheelchair: light skin tone # E12.1 [1] (🧑🏻‍🦼)
+1F9D1 1F3FB 200D 1F9BC 200D 27A1 FE0F ; RGI_Emoji_ZWJ_Sequence ; person in motorized wheelchair facing right: light skin tone # E15.1 [1] (🧑🏻‍🦼‍➡️)
1F9D1 1F3FB 200D 1F9BD ; RGI_Emoji_ZWJ_Sequence ; person in manual wheelchair: light skin tone # E12.1 [1] (🧑🏻‍🦽)
+1F9D1 1F3FB 200D 1F9BD 200D 27A1 FE0F ; RGI_Emoji_ZWJ_Sequence ; person in manual wheelchair facing right: light skin tone # E15.1 [1] (🧑🏻‍🦽‍➡️)
1F9D1 1F3FC 200D 2695 FE0F ; RGI_Emoji_ZWJ_Sequence ; health worker: medium-light skin tone # E12.1 [1] (🧑🏼‍⚕️)
1F9D1 1F3FC 200D 2696 FE0F ; RGI_Emoji_ZWJ_Sequence ; judge: medium-light skin tone # E12.1 [1] (🧑🏼‍⚖️)
1F9D1 1F3FC 200D 2708 FE0F ; RGI_Emoji_ZWJ_Sequence ; pilot: medium-light skin tone # E12.1 [1] (🧑🏼‍✈️)
1F9D1 1F3FC 200D 1F33E ; RGI_Emoji_ZWJ_Sequence ; farmer: medium-light skin tone # E12.1 [1] (🧑🏼‍🌾)
1F9D1 1F3FC 200D 1F373 ; RGI_Emoji_ZWJ_Sequence ; cook: medium-light skin tone # E12.1 [1] (🧑🏼‍🍳)
1F9D1 1F3FC 200D 1F37C ; RGI_Emoji_ZWJ_Sequence ; person feeding baby: medium-light skin tone # E13.0 [1] (🧑🏼‍🍼)
+1F9D1 1F3FC 200D 1F384 ; RGI_Emoji_ZWJ_Sequence ; mx claus: medium-light skin tone # E13.0 [1] (🧑🏼‍🎄)
1F9D1 1F3FC 200D 1F393 ; RGI_Emoji_ZWJ_Sequence ; student: medium-light skin tone # E12.1 [1] (🧑🏼‍🎓)
1F9D1 1F3FC 200D 1F3A4 ; RGI_Emoji_ZWJ_Sequence ; singer: medium-light skin tone # E12.1 [1] (🧑🏼‍🎤)
1F9D1 1F3FC 200D 1F3A8 ; RGI_Emoji_ZWJ_Sequence ; artist: medium-light skin tone # E12.1 [1] (🧑🏼‍🎨)
@@ -664,14 +726,18 @@
1F9D1 1F3FC 200D 1F680 ; RGI_Emoji_ZWJ_Sequence ; astronaut: medium-light skin tone # E12.1 [1] (🧑🏼‍🚀)
1F9D1 1F3FC 200D 1F692 ; RGI_Emoji_ZWJ_Sequence ; firefighter: medium-light skin tone # E12.1 [1] (🧑🏼‍🚒)
1F9D1 1F3FC 200D 1F9AF ; RGI_Emoji_ZWJ_Sequence ; person with white cane: medium-light skin tone # E12.1 [1] (🧑🏼‍🦯)
+1F9D1 1F3FC 200D 1F9AF 200D 27A1 FE0F ; RGI_Emoji_ZWJ_Sequence ; person with white cane facing right: medium-light skin tone # E15.1 [1] (🧑🏼‍🦯‍➡️)
1F9D1 1F3FC 200D 1F9BC ; RGI_Emoji_ZWJ_Sequence ; person in motorized wheelchair: medium-light skin tone # E12.1 [1] (🧑🏼‍🦼)
+1F9D1 1F3FC 200D 1F9BC 200D 27A1 FE0F ; RGI_Emoji_ZWJ_Sequence ; person in motorized wheelchair facing right: medium-light skin tone #E15.1[1] (🧑🏼‍🦼‍➡️)
1F9D1 1F3FC 200D 1F9BD ; RGI_Emoji_ZWJ_Sequence ; person in manual wheelchair: medium-light skin tone # E12.1 [1] (🧑🏼‍🦽)
+1F9D1 1F3FC 200D 1F9BD 200D 27A1 FE0F ; RGI_Emoji_ZWJ_Sequence ; person in manual wheelchair facing right: medium-light skin tone #E15.1 [1] (🧑🏼‍🦽‍➡️)
1F9D1 1F3FD 200D 2695 FE0F ; RGI_Emoji_ZWJ_Sequence ; health worker: medium skin tone # E12.1 [1] (🧑🏽‍⚕️)
1F9D1 1F3FD 200D 2696 FE0F ; RGI_Emoji_ZWJ_Sequence ; judge: medium skin tone # E12.1 [1] (🧑🏽‍⚖️)
1F9D1 1F3FD 200D 2708 FE0F ; RGI_Emoji_ZWJ_Sequence ; pilot: medium skin tone # E12.1 [1] (🧑🏽‍✈️)
1F9D1 1F3FD 200D 1F33E ; RGI_Emoji_ZWJ_Sequence ; farmer: medium skin tone # E12.1 [1] (🧑🏽‍🌾)
1F9D1 1F3FD 200D 1F373 ; RGI_Emoji_ZWJ_Sequence ; cook: medium skin tone # E12.1 [1] (🧑🏽‍🍳)
1F9D1 1F3FD 200D 1F37C ; RGI_Emoji_ZWJ_Sequence ; person feeding baby: medium skin tone # E13.0 [1] (🧑🏽‍🍼)
+1F9D1 1F3FD 200D 1F384 ; RGI_Emoji_ZWJ_Sequence ; mx claus: medium skin tone # E13.0 [1] (🧑🏽‍🎄)
1F9D1 1F3FD 200D 1F393 ; RGI_Emoji_ZWJ_Sequence ; student: medium skin tone # E12.1 [1] (🧑🏽‍🎓)
1F9D1 1F3FD 200D 1F3A4 ; RGI_Emoji_ZWJ_Sequence ; singer: medium skin tone # E12.1 [1] (🧑🏽‍🎤)
1F9D1 1F3FD 200D 1F3A8 ; RGI_Emoji_ZWJ_Sequence ; artist: medium skin tone # E12.1 [1] (🧑🏽‍🎨)
@@ -684,14 +750,18 @@
1F9D1 1F3FD 200D 1F680 ; RGI_Emoji_ZWJ_Sequence ; astronaut: medium skin tone # E12.1 [1] (🧑🏽‍🚀)
1F9D1 1F3FD 200D 1F692 ; RGI_Emoji_ZWJ_Sequence ; firefighter: medium skin tone # E12.1 [1] (🧑🏽‍🚒)
1F9D1 1F3FD 200D 1F9AF ; RGI_Emoji_ZWJ_Sequence ; person with white cane: medium skin tone # E12.1 [1] (🧑🏽‍🦯)
+1F9D1 1F3FD 200D 1F9AF 200D 27A1 FE0F ; RGI_Emoji_ZWJ_Sequence ; person with white cane facing right: medium skin tone # E15.1 [1] (🧑🏽‍🦯‍➡️)
1F9D1 1F3FD 200D 1F9BC ; RGI_Emoji_ZWJ_Sequence ; person in motorized wheelchair: medium skin tone # E12.1 [1] (🧑🏽‍🦼)
+1F9D1 1F3FD 200D 1F9BC 200D 27A1 FE0F ; RGI_Emoji_ZWJ_Sequence ; person in motorized wheelchair facing right: medium skin tone # E15.1 [1] (🧑🏽‍🦼‍➡️)
1F9D1 1F3FD 200D 1F9BD ; RGI_Emoji_ZWJ_Sequence ; person in manual wheelchair: medium skin tone # E12.1 [1] (🧑🏽‍🦽)
+1F9D1 1F3FD 200D 1F9BD 200D 27A1 FE0F ; RGI_Emoji_ZWJ_Sequence ; person in manual wheelchair facing right: medium skin tone # E15.1 [1] (🧑🏽‍🦽‍➡️)
1F9D1 1F3FE 200D 2695 FE0F ; RGI_Emoji_ZWJ_Sequence ; health worker: medium-dark skin tone # E12.1 [1] (🧑🏾‍⚕️)
1F9D1 1F3FE 200D 2696 FE0F ; RGI_Emoji_ZWJ_Sequence ; judge: medium-dark skin tone # E12.1 [1] (🧑🏾‍⚖️)
1F9D1 1F3FE 200D 2708 FE0F ; RGI_Emoji_ZWJ_Sequence ; pilot: medium-dark skin tone # E12.1 [1] (🧑🏾‍✈️)
1F9D1 1F3FE 200D 1F33E ; RGI_Emoji_ZWJ_Sequence ; farmer: medium-dark skin tone # E12.1 [1] (🧑🏾‍🌾)
1F9D1 1F3FE 200D 1F373 ; RGI_Emoji_ZWJ_Sequence ; cook: medium-dark skin tone # E12.1 [1] (🧑🏾‍🍳)
1F9D1 1F3FE 200D 1F37C ; RGI_Emoji_ZWJ_Sequence ; person feeding baby: medium-dark skin tone # E13.0 [1] (🧑🏾‍🍼)
+1F9D1 1F3FE 200D 1F384 ; RGI_Emoji_ZWJ_Sequence ; mx claus: medium-dark skin tone # E13.0 [1] (🧑🏾‍🎄)
1F9D1 1F3FE 200D 1F393 ; RGI_Emoji_ZWJ_Sequence ; student: medium-dark skin tone # E12.1 [1] (🧑🏾‍🎓)
1F9D1 1F3FE 200D 1F3A4 ; RGI_Emoji_ZWJ_Sequence ; singer: medium-dark skin tone # E12.1 [1] (🧑🏾‍🎤)
1F9D1 1F3FE 200D 1F3A8 ; RGI_Emoji_ZWJ_Sequence ; artist: medium-dark skin tone # E12.1 [1] (🧑🏾‍🎨)
@@ -704,14 +774,18 @@
1F9D1 1F3FE 200D 1F680 ; RGI_Emoji_ZWJ_Sequence ; astronaut: medium-dark skin tone # E12.1 [1] (🧑🏾‍🚀)
1F9D1 1F3FE 200D 1F692 ; RGI_Emoji_ZWJ_Sequence ; firefighter: medium-dark skin tone # E12.1 [1] (🧑🏾‍🚒)
1F9D1 1F3FE 200D 1F9AF ; RGI_Emoji_ZWJ_Sequence ; person with white cane: medium-dark skin tone # E12.1 [1] (🧑🏾‍🦯)
+1F9D1 1F3FE 200D 1F9AF 200D 27A1 FE0F ; RGI_Emoji_ZWJ_Sequence ; person with white cane facing right: medium-dark skin tone # E15.1 [1] (🧑🏾‍🦯‍➡️)
1F9D1 1F3FE 200D 1F9BC ; RGI_Emoji_ZWJ_Sequence ; person in motorized wheelchair: medium-dark skin tone # E12.1 [1] (🧑🏾‍🦼)
+1F9D1 1F3FE 200D 1F9BC 200D 27A1 FE0F ; RGI_Emoji_ZWJ_Sequence ; person in motorized wheelchair facing right: medium-dark skin tone #E15.1[1] (🧑🏾‍🦼‍➡️)
1F9D1 1F3FE 200D 1F9BD ; RGI_Emoji_ZWJ_Sequence ; person in manual wheelchair: medium-dark skin tone # E12.1 [1] (🧑🏾‍🦽)
+1F9D1 1F3FE 200D 1F9BD 200D 27A1 FE0F ; RGI_Emoji_ZWJ_Sequence ; person in manual wheelchair facing right: medium-dark skin tone #E15.1 [1] (🧑🏾‍🦽‍➡️)
1F9D1 1F3FF 200D 2695 FE0F ; RGI_Emoji_ZWJ_Sequence ; health worker: dark skin tone # E12.1 [1] (🧑🏿‍⚕️)
1F9D1 1F3FF 200D 2696 FE0F ; RGI_Emoji_ZWJ_Sequence ; judge: dark skin tone # E12.1 [1] (🧑🏿‍⚖️)
1F9D1 1F3FF 200D 2708 FE0F ; RGI_Emoji_ZWJ_Sequence ; pilot: dark skin tone # E12.1 [1] (🧑🏿‍✈️)
1F9D1 1F3FF 200D 1F33E ; RGI_Emoji_ZWJ_Sequence ; farmer: dark skin tone # E12.1 [1] (🧑🏿‍🌾)
1F9D1 1F3FF 200D 1F373 ; RGI_Emoji_ZWJ_Sequence ; cook: dark skin tone # E12.1 [1] (🧑🏿‍🍳)
1F9D1 1F3FF 200D 1F37C ; RGI_Emoji_ZWJ_Sequence ; person feeding baby: dark skin tone # E13.0 [1] (🧑🏿‍🍼)
+1F9D1 1F3FF 200D 1F384 ; RGI_Emoji_ZWJ_Sequence ; mx claus: dark skin tone # E13.0 [1] (🧑🏿‍🎄)
1F9D1 1F3FF 200D 1F393 ; RGI_Emoji_ZWJ_Sequence ; student: dark skin tone # E12.1 [1] (🧑🏿‍🎓)
1F9D1 1F3FF 200D 1F3A4 ; RGI_Emoji_ZWJ_Sequence ; singer: dark skin tone # E12.1 [1] (🧑🏿‍🎤)
1F9D1 1F3FF 200D 1F3A8 ; RGI_Emoji_ZWJ_Sequence ; artist: dark skin tone # E12.1 [1] (🧑🏿‍🎨)
@@ -724,10 +798,13 @@
1F9D1 1F3FF 200D 1F680 ; RGI_Emoji_ZWJ_Sequence ; astronaut: dark skin tone # E12.1 [1] (🧑🏿‍🚀)
1F9D1 1F3FF 200D 1F692 ; RGI_Emoji_ZWJ_Sequence ; firefighter: dark skin tone # E12.1 [1] (🧑🏿‍🚒)
1F9D1 1F3FF 200D 1F9AF ; RGI_Emoji_ZWJ_Sequence ; person with white cane: dark skin tone # E12.1 [1] (🧑🏿‍🦯)
+1F9D1 1F3FF 200D 1F9AF 200D 27A1 FE0F ; RGI_Emoji_ZWJ_Sequence ; person with white cane facing right: dark skin tone # E15.1 [1] (🧑🏿‍🦯‍➡️)
1F9D1 1F3FF 200D 1F9BC ; RGI_Emoji_ZWJ_Sequence ; person in motorized wheelchair: dark skin tone # E12.1 [1] (🧑🏿‍🦼)
+1F9D1 1F3FF 200D 1F9BC 200D 27A1 FE0F ; RGI_Emoji_ZWJ_Sequence ; person in motorized wheelchair facing right: dark skin tone # E15.1 [1] (🧑🏿‍🦼‍➡️)
1F9D1 1F3FF 200D 1F9BD ; RGI_Emoji_ZWJ_Sequence ; person in manual wheelchair: dark skin tone # E12.1 [1] (🧑🏿‍🦽)
+1F9D1 1F3FF 200D 1F9BD 200D 27A1 FE0F ; RGI_Emoji_ZWJ_Sequence ; person in manual wheelchair facing right: dark skin tone # E15.1 [1] (🧑🏿‍🦽‍➡️)
-# Total elements: 360
+# Total elements: 438
# ================================================
@@ -746,17 +823,29 @@
26F9 FE0F 200D 2640 FE0F ; RGI_Emoji_ZWJ_Sequence ; woman bouncing ball # E4.0 [1] (⛹️‍♀️)
26F9 FE0F 200D 2642 FE0F ; RGI_Emoji_ZWJ_Sequence ; man bouncing ball # E4.0 [1] (⛹️‍♂️)
1F3C3 200D 2640 FE0F ; RGI_Emoji_ZWJ_Sequence ; woman running # E4.0 [1] (🏃‍♀️)
+1F3C3 200D 2640 FE0F 200D 27A1 FE0F ; RGI_Emoji_ZWJ_Sequence ; woman running facing right # E15.1 [1] (🏃‍♀️‍➡️)
1F3C3 200D 2642 FE0F ; RGI_Emoji_ZWJ_Sequence ; man running # E4.0 [1] (🏃‍♂️)
+1F3C3 200D 2642 FE0F 200D 27A1 FE0F ; RGI_Emoji_ZWJ_Sequence ; man running facing right # E15.1 [1] (🏃‍♂️‍➡️)
1F3C3 1F3FB 200D 2640 FE0F ; RGI_Emoji_ZWJ_Sequence ; woman running: light skin tone # E4.0 [1] (🏃🏻‍♀️)
+1F3C3 1F3FB 200D 2640 FE0F 200D 27A1 FE0F ; RGI_Emoji_ZWJ_Sequence ; woman running facing right: light skin tone # E15.1 [1] (🏃🏻‍♀️‍➡️)
1F3C3 1F3FB 200D 2642 FE0F ; RGI_Emoji_ZWJ_Sequence ; man running: light skin tone # E4.0 [1] (🏃🏻‍♂️)
+1F3C3 1F3FB 200D 2642 FE0F 200D 27A1 FE0F ; RGI_Emoji_ZWJ_Sequence ; man running facing right: light skin tone # E15.1 [1] (🏃🏻‍♂️‍➡️)
1F3C3 1F3FC 200D 2640 FE0F ; RGI_Emoji_ZWJ_Sequence ; woman running: medium-light skin tone # E4.0 [1] (🏃🏼‍♀️)
+1F3C3 1F3FC 200D 2640 FE0F 200D 27A1 FE0F ; RGI_Emoji_ZWJ_Sequence ; woman running facing right: medium-light skin tone # E15.1 [1] (🏃🏼‍♀️‍➡️)
1F3C3 1F3FC 200D 2642 FE0F ; RGI_Emoji_ZWJ_Sequence ; man running: medium-light skin tone # E4.0 [1] (🏃🏼‍♂️)
+1F3C3 1F3FC 200D 2642 FE0F 200D 27A1 FE0F ; RGI_Emoji_ZWJ_Sequence ; man running facing right: medium-light skin tone # E15.1 [1] (🏃🏼‍♂️‍➡️)
1F3C3 1F3FD 200D 2640 FE0F ; RGI_Emoji_ZWJ_Sequence ; woman running: medium skin tone # E4.0 [1] (🏃🏽‍♀️)
+1F3C3 1F3FD 200D 2640 FE0F 200D 27A1 FE0F ; RGI_Emoji_ZWJ_Sequence ; woman running facing right: medium skin tone # E15.1 [1] (🏃🏽‍♀️‍➡️)
1F3C3 1F3FD 200D 2642 FE0F ; RGI_Emoji_ZWJ_Sequence ; man running: medium skin tone # E4.0 [1] (🏃🏽‍♂️)
+1F3C3 1F3FD 200D 2642 FE0F 200D 27A1 FE0F ; RGI_Emoji_ZWJ_Sequence ; man running facing right: medium skin tone # E15.1 [1] (🏃🏽‍♂️‍➡️)
1F3C3 1F3FE 200D 2640 FE0F ; RGI_Emoji_ZWJ_Sequence ; woman running: medium-dark skin tone # E4.0 [1] (🏃🏾‍♀️)
+1F3C3 1F3FE 200D 2640 FE0F 200D 27A1 FE0F ; RGI_Emoji_ZWJ_Sequence ; woman running facing right: medium-dark skin tone # E15.1 [1] (🏃🏾‍♀️‍➡️)
1F3C3 1F3FE 200D 2642 FE0F ; RGI_Emoji_ZWJ_Sequence ; man running: medium-dark skin tone # E4.0 [1] (🏃🏾‍♂️)
+1F3C3 1F3FE 200D 2642 FE0F 200D 27A1 FE0F ; RGI_Emoji_ZWJ_Sequence ; man running facing right: medium-dark skin tone # E15.1 [1] (🏃🏾‍♂️‍➡️)
1F3C3 1F3FF 200D 2640 FE0F ; RGI_Emoji_ZWJ_Sequence ; woman running: dark skin tone # E4.0 [1] (🏃🏿‍♀️)
+1F3C3 1F3FF 200D 2640 FE0F 200D 27A1 FE0F ; RGI_Emoji_ZWJ_Sequence ; woman running facing right: dark skin tone # E15.1 [1] (🏃🏿‍♀️‍➡️)
1F3C3 1F3FF 200D 2642 FE0F ; RGI_Emoji_ZWJ_Sequence ; man running: dark skin tone # E4.0 [1] (🏃🏿‍♂️)
+1F3C3 1F3FF 200D 2642 FE0F 200D 27A1 FE0F ; RGI_Emoji_ZWJ_Sequence ; man running facing right: dark skin tone # E15.1 [1] (🏃🏿‍♂️‍➡️)
1F3C4 200D 2640 FE0F ; RGI_Emoji_ZWJ_Sequence ; woman surfing # E4.0 [1] (🏄‍♀️)
1F3C4 200D 2642 FE0F ; RGI_Emoji_ZWJ_Sequence ; man surfing # E4.0 [1] (🏄‍♂️)
1F3C4 1F3FB 200D 2640 FE0F ; RGI_Emoji_ZWJ_Sequence ; woman surfing: light skin tone # E4.0 [1] (🏄🏻‍♀️)
@@ -1036,17 +1125,29 @@
1F6B5 1F3FF 200D 2640 FE0F ; RGI_Emoji_ZWJ_Sequence ; woman mountain biking: dark skin tone # E4.0 [1] (🚵🏿‍♀️)
1F6B5 1F3FF 200D 2642 FE0F ; RGI_Emoji_ZWJ_Sequence ; man mountain biking: dark skin tone # E4.0 [1] (🚵🏿‍♂️)
1F6B6 200D 2640 FE0F ; RGI_Emoji_ZWJ_Sequence ; woman walking # E4.0 [1] (🚶‍♀️)
+1F6B6 200D 2640 FE0F 200D 27A1 FE0F ; RGI_Emoji_ZWJ_Sequence ; woman walking facing right # E15.1 [1] (🚶‍♀️‍➡️)
1F6B6 200D 2642 FE0F ; RGI_Emoji_ZWJ_Sequence ; man walking # E4.0 [1] (🚶‍♂️)
+1F6B6 200D 2642 FE0F 200D 27A1 FE0F ; RGI_Emoji_ZWJ_Sequence ; man walking facing right # E15.1 [1] (🚶‍♂️‍➡️)
1F6B6 1F3FB 200D 2640 FE0F ; RGI_Emoji_ZWJ_Sequence ; woman walking: light skin tone # E4.0 [1] (🚶🏻‍♀️)
+1F6B6 1F3FB 200D 2640 FE0F 200D 27A1 FE0F ; RGI_Emoji_ZWJ_Sequence ; woman walking facing right: light skin tone # E15.1 [1] (🚶🏻‍♀️‍➡️)
1F6B6 1F3FB 200D 2642 FE0F ; RGI_Emoji_ZWJ_Sequence ; man walking: light skin tone # E4.0 [1] (🚶🏻‍♂️)
+1F6B6 1F3FB 200D 2642 FE0F 200D 27A1 FE0F ; RGI_Emoji_ZWJ_Sequence ; man walking facing right: light skin tone # E15.1 [1] (🚶🏻‍♂️‍➡️)
1F6B6 1F3FC 200D 2640 FE0F ; RGI_Emoji_ZWJ_Sequence ; woman walking: medium-light skin tone # E4.0 [1] (🚶🏼‍♀️)
+1F6B6 1F3FC 200D 2640 FE0F 200D 27A1 FE0F ; RGI_Emoji_ZWJ_Sequence ; woman walking facing right: medium-light skin tone # E15.1 [1] (🚶🏼‍♀️‍➡️)
1F6B6 1F3FC 200D 2642 FE0F ; RGI_Emoji_ZWJ_Sequence ; man walking: medium-light skin tone # E4.0 [1] (🚶🏼‍♂️)
+1F6B6 1F3FC 200D 2642 FE0F 200D 27A1 FE0F ; RGI_Emoji_ZWJ_Sequence ; man walking facing right: medium-light skin tone # E15.1 [1] (🚶🏼‍♂️‍➡️)
1F6B6 1F3FD 200D 2640 FE0F ; RGI_Emoji_ZWJ_Sequence ; woman walking: medium skin tone # E4.0 [1] (🚶🏽‍♀️)
+1F6B6 1F3FD 200D 2640 FE0F 200D 27A1 FE0F ; RGI_Emoji_ZWJ_Sequence ; woman walking facing right: medium skin tone # E15.1 [1] (🚶🏽‍♀️‍➡️)
1F6B6 1F3FD 200D 2642 FE0F ; RGI_Emoji_ZWJ_Sequence ; man walking: medium skin tone # E4.0 [1] (🚶🏽‍♂️)
+1F6B6 1F3FD 200D 2642 FE0F 200D 27A1 FE0F ; RGI_Emoji_ZWJ_Sequence ; man walking facing right: medium skin tone # E15.1 [1] (🚶🏽‍♂️‍➡️)
1F6B6 1F3FE 200D 2640 FE0F ; RGI_Emoji_ZWJ_Sequence ; woman walking: medium-dark skin tone # E4.0 [1] (🚶🏾‍♀️)
+1F6B6 1F3FE 200D 2640 FE0F 200D 27A1 FE0F ; RGI_Emoji_ZWJ_Sequence ; woman walking facing right: medium-dark skin tone # E15.1 [1] (🚶🏾‍♀️‍➡️)
1F6B6 1F3FE 200D 2642 FE0F ; RGI_Emoji_ZWJ_Sequence ; man walking: medium-dark skin tone # E4.0 [1] (🚶🏾‍♂️)
+1F6B6 1F3FE 200D 2642 FE0F 200D 27A1 FE0F ; RGI_Emoji_ZWJ_Sequence ; man walking facing right: medium-dark skin tone # E15.1 [1] (🚶🏾‍♂️‍➡️)
1F6B6 1F3FF 200D 2640 FE0F ; RGI_Emoji_ZWJ_Sequence ; woman walking: dark skin tone # E4.0 [1] (🚶🏿‍♀️)
+1F6B6 1F3FF 200D 2640 FE0F 200D 27A1 FE0F ; RGI_Emoji_ZWJ_Sequence ; woman walking facing right: dark skin tone # E15.1 [1] (🚶🏿‍♀️‍➡️)
1F6B6 1F3FF 200D 2642 FE0F ; RGI_Emoji_ZWJ_Sequence ; man walking: dark skin tone # E4.0 [1] (🚶🏿‍♂️)
+1F6B6 1F3FF 200D 2642 FE0F 200D 27A1 FE0F ; RGI_Emoji_ZWJ_Sequence ; man walking facing right: dark skin tone # E15.1 [1] (🚶🏿‍♂️‍➡️)
1F926 200D 2640 FE0F ; RGI_Emoji_ZWJ_Sequence ; woman facepalming # E4.0 [1] (🤦‍♀️)
1F926 200D 2642 FE0F ; RGI_Emoji_ZWJ_Sequence ; man facepalming # E4.0 [1] (🤦‍♂️)
1F926 1F3FB 200D 2640 FE0F ; RGI_Emoji_ZWJ_Sequence ; woman facepalming: light skin tone # E4.0 [1] (🤦🏻‍♀️)
@@ -1170,17 +1271,29 @@
1F9CD 1F3FF 200D 2640 FE0F ; RGI_Emoji_ZWJ_Sequence ; woman standing: dark skin tone # E12.0 [1] (🧍🏿‍♀️)
1F9CD 1F3FF 200D 2642 FE0F ; RGI_Emoji_ZWJ_Sequence ; man standing: dark skin tone # E12.0 [1] (🧍🏿‍♂️)
1F9CE 200D 2640 FE0F ; RGI_Emoji_ZWJ_Sequence ; woman kneeling # E12.0 [1] (🧎‍♀️)
+1F9CE 200D 2640 FE0F 200D 27A1 FE0F ; RGI_Emoji_ZWJ_Sequence ; woman kneeling facing right # E15.1 [1] (🧎‍♀️‍➡️)
1F9CE 200D 2642 FE0F ; RGI_Emoji_ZWJ_Sequence ; man kneeling # E12.0 [1] (🧎‍♂️)
+1F9CE 200D 2642 FE0F 200D 27A1 FE0F ; RGI_Emoji_ZWJ_Sequence ; man kneeling facing right # E15.1 [1] (🧎‍♂️‍➡️)
1F9CE 1F3FB 200D 2640 FE0F ; RGI_Emoji_ZWJ_Sequence ; woman kneeling: light skin tone # E12.0 [1] (🧎🏻‍♀️)
+1F9CE 1F3FB 200D 2640 FE0F 200D 27A1 FE0F ; RGI_Emoji_ZWJ_Sequence ; woman kneeling facing right: light skin tone # E15.1 [1] (🧎🏻‍♀️‍➡️)
1F9CE 1F3FB 200D 2642 FE0F ; RGI_Emoji_ZWJ_Sequence ; man kneeling: light skin tone # E12.0 [1] (🧎🏻‍♂️)
+1F9CE 1F3FB 200D 2642 FE0F 200D 27A1 FE0F ; RGI_Emoji_ZWJ_Sequence ; man kneeling facing right: light skin tone # E15.1 [1] (🧎🏻‍♂️‍➡️)
1F9CE 1F3FC 200D 2640 FE0F ; RGI_Emoji_ZWJ_Sequence ; woman kneeling: medium-light skin tone # E12.0 [1] (🧎🏼‍♀️)
+1F9CE 1F3FC 200D 2640 FE0F 200D 27A1 FE0F ; RGI_Emoji_ZWJ_Sequence ; woman kneeling facing right: medium-light skin tone # E15.1 [1] (🧎🏼‍♀️‍➡️)
1F9CE 1F3FC 200D 2642 FE0F ; RGI_Emoji_ZWJ_Sequence ; man kneeling: medium-light skin tone # E12.0 [1] (🧎🏼‍♂️)
+1F9CE 1F3FC 200D 2642 FE0F 200D 27A1 FE0F ; RGI_Emoji_ZWJ_Sequence ; man kneeling facing right: medium-light skin tone # E15.1 [1] (🧎🏼‍♂️‍➡️)
1F9CE 1F3FD 200D 2640 FE0F ; RGI_Emoji_ZWJ_Sequence ; woman kneeling: medium skin tone # E12.0 [1] (🧎🏽‍♀️)
+1F9CE 1F3FD 200D 2640 FE0F 200D 27A1 FE0F ; RGI_Emoji_ZWJ_Sequence ; woman kneeling facing right: medium skin tone # E15.1 [1] (🧎🏽‍♀️‍➡️)
1F9CE 1F3FD 200D 2642 FE0F ; RGI_Emoji_ZWJ_Sequence ; man kneeling: medium skin tone # E12.0 [1] (🧎🏽‍♂️)
+1F9CE 1F3FD 200D 2642 FE0F 200D 27A1 FE0F ; RGI_Emoji_ZWJ_Sequence ; man kneeling facing right: medium skin tone # E15.1 [1] (🧎🏽‍♂️‍➡️)
1F9CE 1F3FE 200D 2640 FE0F ; RGI_Emoji_ZWJ_Sequence ; woman kneeling: medium-dark skin tone # E12.0 [1] (🧎🏾‍♀️)
+1F9CE 1F3FE 200D 2640 FE0F 200D 27A1 FE0F ; RGI_Emoji_ZWJ_Sequence ; woman kneeling facing right: medium-dark skin tone # E15.1 [1] (🧎🏾‍♀️‍➡️)
1F9CE 1F3FE 200D 2642 FE0F ; RGI_Emoji_ZWJ_Sequence ; man kneeling: medium-dark skin tone # E12.0 [1] (🧎🏾‍♂️)
+1F9CE 1F3FE 200D 2642 FE0F 200D 27A1 FE0F ; RGI_Emoji_ZWJ_Sequence ; man kneeling facing right: medium-dark skin tone # E15.1 [1] (🧎🏾‍♂️‍➡️)
1F9CE 1F3FF 200D 2640 FE0F ; RGI_Emoji_ZWJ_Sequence ; woman kneeling: dark skin tone # E12.0 [1] (🧎🏿‍♀️)
+1F9CE 1F3FF 200D 2640 FE0F 200D 27A1 FE0F ; RGI_Emoji_ZWJ_Sequence ; woman kneeling facing right: dark skin tone # E15.1 [1] (🧎🏿‍♀️‍➡️)
1F9CE 1F3FF 200D 2642 FE0F ; RGI_Emoji_ZWJ_Sequence ; man kneeling: dark skin tone # E12.0 [1] (🧎🏿‍♂️)
+1F9CE 1F3FF 200D 2642 FE0F 200D 27A1 FE0F ; RGI_Emoji_ZWJ_Sequence ; man kneeling facing right: dark skin tone # E15.1 [1] (🧎🏿‍♂️‍➡️)
1F9CF 200D 2640 FE0F ; RGI_Emoji_ZWJ_Sequence ; deaf woman # E12.0 [1] (🧏‍♀️)
1F9CF 200D 2642 FE0F ; RGI_Emoji_ZWJ_Sequence ; deaf man # E12.0 [1] (🧏‍♂️)
1F9CF 1F3FB 200D 2640 FE0F ; RGI_Emoji_ZWJ_Sequence ; deaf woman: light skin tone # E12.0 [1] (🧏🏻‍♀️)
@@ -1306,7 +1419,7 @@
1F9DF 200D 2640 FE0F ; RGI_Emoji_ZWJ_Sequence ; woman zombie # E5.0 [1] (🧟‍♀️)
1F9DF 200D 2642 FE0F ; RGI_Emoji_ZWJ_Sequence ; man zombie # E5.0 [1] (🧟‍♂️)
-# Total elements: 572
+# Total elements: 608
# ================================================
@@ -1391,21 +1504,26 @@
# RGI_Emoji_ZWJ_Sequence: Other
+26D3 FE0F 200D 1F4A5 ; RGI_Emoji_ZWJ_Sequence ; broken chain # E15.1 [1] (⛓️‍💥)
2764 FE0F 200D 1F525 ; RGI_Emoji_ZWJ_Sequence ; heart on fire # E13.1 [1] (❤️‍🔥)
2764 FE0F 200D 1FA79 ; RGI_Emoji_ZWJ_Sequence ; mending heart # E13.1 [1] (❤️‍🩹)
+1F344 200D 1F7EB ; RGI_Emoji_ZWJ_Sequence ; brown mushroom # E15.1 [1] (🍄‍🟫)
+1F34B 200D 1F7E9 ; RGI_Emoji_ZWJ_Sequence ; lime # E15.1 [1] (🍋‍🟩)
1F3F3 FE0F 200D 26A7 FE0F ; RGI_Emoji_ZWJ_Sequence ; transgender flag # E13.0 [1] (🏳️‍⚧️)
1F3F3 FE0F 200D 1F308 ; RGI_Emoji_ZWJ_Sequence ; rainbow flag # E4.0 [1] (🏳️‍🌈)
1F3F4 200D 2620 FE0F ; RGI_Emoji_ZWJ_Sequence ; pirate flag # E11.0 [1] (🏴‍☠️)
1F408 200D 2B1B ; RGI_Emoji_ZWJ_Sequence ; black cat # E13.0 [1] (🐈‍⬛)
1F415 200D 1F9BA ; RGI_Emoji_ZWJ_Sequence ; service dog # E12.0 [1] (🐕‍🦺)
1F426 200D 2B1B ; RGI_Emoji_ZWJ_Sequence ; black bird # E15.0 [1] (🐦‍⬛)
+1F426 200D 1F525 ; RGI_Emoji_ZWJ_Sequence ; phoenix # E15.1 [1] (🐦‍🔥)
1F43B 200D 2744 FE0F ; RGI_Emoji_ZWJ_Sequence ; polar bear # E13.0 [1] (🐻‍❄️)
1F441 FE0F 200D 1F5E8 FE0F ; RGI_Emoji_ZWJ_Sequence ; eye in speech bubble # E2.0 [1] (👁️‍🗨️)
1F62E 200D 1F4A8 ; RGI_Emoji_ZWJ_Sequence ; face exhaling # E13.1 [1] (😮‍💨)
1F635 200D 1F4AB ; RGI_Emoji_ZWJ_Sequence ; face with spiral eyes # E13.1 [1] (😵‍💫)
1F636 200D 1F32B FE0F ; RGI_Emoji_ZWJ_Sequence ; face in clouds # E13.1 [1] (😶‍🌫️)
-1F9D1 200D 1F384 ; RGI_Emoji_ZWJ_Sequence ; mx claus # E13.0 [1] (🧑‍🎄)
+1F642 200D 2194 FE0F ; RGI_Emoji_ZWJ_Sequence ; head shaking horizontally # E15.1 [1] (🙂‍↔️)
+1F642 200D 2195 FE0F ; RGI_Emoji_ZWJ_Sequence ; head shaking vertically # E15.1 [1] (🙂‍↕️)
-# Total elements: 14
+# Total elements: 19
#EOF
diff --git a/admin/unidata/emoji-zwj.awk b/admin/unidata/emoji-zwj.awk
index 94c1d8f0215..c69bc6822d0 100644
--- a/admin/unidata/emoji-zwj.awk
+++ b/admin/unidata/emoji-zwj.awk
@@ -83,33 +83,31 @@ END {
trigger_codepoints[12] = "1F575"
trigger_codepoints[13] = "1F590"
- printf "(setq auto-composition-emoji-eligible-codepoints\n"
- printf "'("
+ print "(setq auto-composition-emoji-eligible-codepoints"
+ print "'("
for (trig in trigger_codepoints)
{
- printf("\n?\\N{U+%s}", trigger_codepoints[trig])
+ print "?\\N{U+" trigger_codepoints[trig] "}"
}
- printf "\n))\n\n"
+ print "))"
# We add entries for 'codepoint U+FE0F' here to ensure that the
# code in font_range is triggered.
for (trig in trigger_codepoints)
{
- codepoint = trigger_codepoints[trig]
- c = sprintf("\\N{U+%s}", codepoint)
- vec[codepoint] = vec[codepoint] "\n\"" c "\\N{U+FE0F}\""
+ vec[codepoint] = vec[codepoint] "\n\"\\N{U+" trigger_codepoints[trig] "}\\N{U+FE0F}\""
}
- print "(dolist (elt `("
+ print "(dolist (elt (eval-when-compile `("
for (elt in ch)
{
- entries = vec[elt] sprintf("\n\"\\N{U+%s}\\N{U+FE0E}\"\n\"\\N{U+%s}\\N{U+FE0F}\"", elt, elt)
- printf("(#x%s .\n,(eval-when-compile (regexp-opt\n'(\n%s\n))))\n", elt, entries)
+ print "(#x" elt " .\n,(regexp-opt\n'(\n" vec[elt]
+ print "\"\\N{U+" elt "}\\N{U+FE0E}\"\n\"\\N{U+" elt "}\\N{U+FE0F}\"\n)))"
}
- print "))"
+ print ")))"
print " (set-char-table-range composition-function-table"
print " (car elt)"
print " (nconc (char-table-range composition-function-table (car elt))"
diff --git a/autogen.sh b/autogen.sh
index 7fb201088dd..f56966ae0d1 100755
--- a/autogen.sh
+++ b/autogen.sh
@@ -239,6 +239,16 @@ Please report any problems with this script to bug-gnu-emacs@gnu.org .'
fi # do_check
+ # Stale caches can confuse autoconf.
+ rm -fr autom4te.cache exec/autom4te.cache || exit
+
+ # In build-aux save config.guess, config.sub and install-sh
+ # in case autoreconf overwrites them, as we rely on the copies
+ # in Git, which are updated by admin/merge-gnulib.
+ for file in config.guess config.sub install-sh; do
+ cp -p build-aux/$file build-aux/$file.tmp || exit
+ done
+
# Build aclocal.m4 here so that autoreconf need not use aclocal.
# aclocal is part of Automake and might not be installed, and
# autoreconf skips aclocal if aclocal.m4 is already supplied.
@@ -256,6 +266,25 @@ Please report any problems with this script to bug-gnu-emacs@gnu.org .'
## Let autoreconf figure out what, if anything, needs doing.
## Use autoreconf's -f option in case autoreconf itself has changed.
autoreconf -fi -I m4 || exit
+
+ echo "Building 'aclocal.m4' in exec ..."
+
+ # Create a placeholder aclocal.m4 in exec, preventing autoreconf
+ # from running aclocal.
+
+ echo "" > exec/aclocal.m4
+
+ echo "Running 'autoreconf -fi' in exec ..."
+
+ # Now, run autoreconf inside the exec directory to generate its
+ # configure script.
+ autoreconf -fi exec || exit
+
+ # Restore config.guess etc. in build-aux, and copy them to exec.
+ for file in config.guess config.sub install-sh; do
+ cp build-aux/$file.tmp exec/$file &&
+ mv build-aux/$file.tmp build-aux/$file || exit
+ done
fi
@@ -340,7 +369,8 @@ git_config diff.texinfo.xfuncname \
tailored_hooks=
sample_hooks=
-for hook in commit-msg pre-commit prepare-commit-msg; do
+for hook in commit-msg pre-commit prepare-commit-msg post-commit \
+ pre-push commit-msg-files.awk; do
cmp -- build-aux/git-hooks/$hook "$hooks/$hook" >/dev/null 2>&1 ||
tailored_hooks="$tailored_hooks $hook"
done
diff --git a/build-aux/config.guess b/build-aux/config.guess
index 33a163c1170..f6d217a49f8 100755
--- a/build-aux/config.guess
+++ b/build-aux/config.guess
@@ -4,7 +4,7 @@
# shellcheck disable=SC2006,SC2268 # see below for rationale
-timestamp='2022-09-17'
+timestamp='2024-01-01'
# This file is free software; you can redistribute it and/or modify it
# under the terms of the GNU General Public License as published by
@@ -47,7 +47,7 @@ me=`echo "$0" | sed -e 's,.*/,,'`
usage="\
Usage: $0 [OPTION]
-Output the configuration name of the system \`$me' is run on.
+Output the configuration name of the system '$me' is run on.
Options:
-h, --help print this help, then exit
@@ -60,13 +60,13 @@ version="\
GNU config.guess ($timestamp)
Originally written by Per Bothner.
-Copyright 1992-2022 Free Software Foundation, Inc.
+Copyright 1992-2024 Free Software Foundation, Inc.
This is free software; see the source for copying conditions. There is NO
warranty; not even for MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE."
help="
-Try \`$me --help' for more information."
+Try '$me --help' for more information."
# Parse command line
while test $# -gt 0 ; do
@@ -102,8 +102,8 @@ GUESS=
# temporary files to be created and, as you can see below, it is a
# headache to deal with in a portable fashion.
-# Historically, `CC_FOR_BUILD' used to be named `HOST_CC'. We still
-# use `HOST_CC' if defined, but it is deprecated.
+# Historically, 'CC_FOR_BUILD' used to be named 'HOST_CC'. We still
+# use 'HOST_CC' if defined, but it is deprecated.
# Portable tmp directory creation inspired by the Autoconf team.
@@ -155,6 +155,9 @@ Linux|GNU|GNU/*)
set_cc_for_build
cat <<-EOF > "$dummy.c"
+ #if defined(__ANDROID__)
+ LIBC=android
+ #else
#include <features.h>
#if defined(__UCLIBC__)
LIBC=uclibc
@@ -162,6 +165,8 @@ Linux|GNU|GNU/*)
LIBC=dietlibc
#elif defined(__GLIBC__)
LIBC=gnu
+ #elif defined(__LLVM_LIBC__)
+ LIBC=llvm
#else
#include <stdarg.h>
/* First heuristic to detect musl libc. */
@@ -169,6 +174,7 @@ Linux|GNU|GNU/*)
LIBC=musl
#endif
#endif
+ #endif
EOF
cc_set_libc=`$CC_FOR_BUILD -E "$dummy.c" 2>/dev/null | grep '^LIBC' | sed 's, ,,g'`
eval "$cc_set_libc"
@@ -459,7 +465,7 @@ case $UNAME_MACHINE:$UNAME_SYSTEM:$UNAME_RELEASE:$UNAME_VERSION in
UNAME_RELEASE=`uname -v`
;;
esac
- # Japanese Language versions have a version number like `4.1.3-JL'.
+ # Japanese Language versions have a version number like '4.1.3-JL'.
SUN_REL=`echo "$UNAME_RELEASE" | sed -e 's/-/_/'`
GUESS=sparc-sun-sunos$SUN_REL
;;
@@ -904,7 +910,7 @@ EOF
fi
;;
*:FreeBSD:*:*)
- UNAME_PROCESSOR=`/usr/bin/uname -p`
+ UNAME_PROCESSOR=`uname -p`
case $UNAME_PROCESSOR in
amd64)
UNAME_PROCESSOR=x86_64 ;;
@@ -976,7 +982,27 @@ EOF
GUESS=$UNAME_MACHINE-unknown-minix
;;
aarch64:Linux:*:*)
- GUESS=$UNAME_MACHINE-unknown-linux-$LIBC
+ set_cc_for_build
+ CPU=$UNAME_MACHINE
+ LIBCABI=$LIBC
+ if test "$CC_FOR_BUILD" != no_compiler_found; then
+ ABI=64
+ sed 's/^ //' << EOF > "$dummy.c"
+ #ifdef __ARM_EABI__
+ #ifdef __ARM_PCS_VFP
+ ABI=eabihf
+ #else
+ ABI=eabi
+ #endif
+ #endif
+EOF
+ cc_set_abi=`$CC_FOR_BUILD -E "$dummy.c" 2>/dev/null | grep '^ABI' | sed 's, ,,g'`
+ eval "$cc_set_abi"
+ case $ABI in
+ eabi | eabihf) CPU=armv8l; LIBCABI=$LIBC$ABI ;;
+ esac
+ fi
+ GUESS=$CPU-unknown-linux-$LIBCABI
;;
aarch64_be:Linux:*:*)
UNAME_MACHINE=aarch64_be
@@ -1042,6 +1068,15 @@ EOF
k1om:Linux:*:*)
GUESS=$UNAME_MACHINE-unknown-linux-$LIBC
;;
+ kvx:Linux:*:*)
+ GUESS=$UNAME_MACHINE-unknown-linux-$LIBC
+ ;;
+ kvx:cos:*:*)
+ GUESS=$UNAME_MACHINE-unknown-cos
+ ;;
+ kvx:mbr:*:*)
+ GUESS=$UNAME_MACHINE-unknown-mbr
+ ;;
loongarch32:Linux:*:* | loongarch64:Linux:*:*)
GUESS=$UNAME_MACHINE-unknown-linux-$LIBC
;;
@@ -1197,7 +1232,7 @@ EOF
GUESS=$UNAME_MACHINE-pc-sysv4.2uw$UNAME_VERSION
;;
i*86:OS/2:*:*)
- # If we were able to find `uname', then EMX Unix compatibility
+ # If we were able to find 'uname', then EMX Unix compatibility
# is probably installed.
GUESS=$UNAME_MACHINE-pc-os2-emx
;;
@@ -1338,7 +1373,7 @@ EOF
GUESS=ns32k-sni-sysv
fi
;;
- PENTIUM:*:4.0*:*) # Unisys `ClearPath HMP IX 4000' SVR4/MP effort
+ PENTIUM:*:4.0*:*) # Unisys 'ClearPath HMP IX 4000' SVR4/MP effort
# says <Richard.M.Bartel@ccMail.Census.GOV>
GUESS=i586-unisys-sysv4
;;
@@ -1560,6 +1595,9 @@ EOF
*:Unleashed:*:*)
GUESS=$UNAME_MACHINE-unknown-unleashed$UNAME_RELEASE
;;
+ *:Ironclad:*:*)
+ GUESS=$UNAME_MACHINE-unknown-ironclad
+ ;;
esac
# Do we have a guess based on uname results?
diff --git a/build-aux/config.sub b/build-aux/config.sub
index 529a77a9c7c..2c6a07ab3c3 100755
--- a/build-aux/config.sub
+++ b/build-aux/config.sub
@@ -4,7 +4,7 @@
# shellcheck disable=SC2006,SC2268 # see below for rationale
-timestamp='2022-09-17'
+timestamp='2024-01-01'
# This file is free software; you can redistribute it and/or modify it
# under the terms of the GNU General Public License as published by
@@ -76,13 +76,13 @@ Report bugs and patches to <config-patches@gnu.org>."
version="\
GNU config.sub ($timestamp)
-Copyright 1992-2022 Free Software Foundation, Inc.
+Copyright 1992-2024 Free Software Foundation, Inc.
This is free software; see the source for copying conditions. There is NO
warranty; not even for MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE."
help="
-Try \`$me --help' for more information."
+Try '$me --help' for more information."
# Parse command line
while test $# -gt 0 ; do
@@ -130,7 +130,7 @@ IFS=$saved_IFS
# Separate into logical components for further validation
case $1 in
*-*-*-*-*)
- echo Invalid configuration \`"$1"\': more than four components >&2
+ echo "Invalid configuration '$1': more than four components" >&2
exit 1
;;
*-*-*-*)
@@ -145,7 +145,8 @@ case $1 in
nto-qnx* | linux-* | uclinux-uclibc* \
| uclinux-gnu* | kfreebsd*-gnu* | knetbsd*-gnu* | netbsd*-gnu* \
| netbsd*-eabi* | kopensolaris*-gnu* | cloudabi*-eabi* \
- | storm-chaos* | os2-emx* | rtmk-nova* | managarm-*)
+ | storm-chaos* | os2-emx* | rtmk-nova* | managarm-* \
+ | windows-* )
basic_machine=$field1
basic_os=$maybe_os
;;
@@ -943,7 +944,7 @@ $basic_machine
EOF
IFS=$saved_IFS
;;
- # We use `pc' rather than `unknown'
+ # We use 'pc' rather than 'unknown'
# because (1) that's what they normally are, and
# (2) the word "unknown" tends to confuse beginning users.
i*86 | x86_64)
@@ -1075,7 +1076,7 @@ case $cpu-$vendor in
pentium-* | p5-* | k5-* | k6-* | nexgen-* | viac3-*)
cpu=i586
;;
- pentiumpro-* | p6-* | 6x86-* | athlon-* | athalon_*-*)
+ pentiumpro-* | p6-* | 6x86-* | athlon-* | athlon_*-*)
cpu=i686
;;
pentiumii-* | pentium2-* | pentiumiii-* | pentium3-*)
@@ -1180,7 +1181,7 @@ case $cpu-$vendor in
case $cpu in
1750a | 580 \
| a29k \
- | aarch64 | aarch64_be \
+ | aarch64 | aarch64_be | aarch64c | arm64ec \
| abacus \
| alpha | alphaev[4-8] | alphaev56 | alphaev6[78] \
| alpha64 | alpha64ev[4-8] | alpha64ev56 | alpha64ev6[78] \
@@ -1199,12 +1200,14 @@ case $cpu-$vendor in
| d10v | d30v | dlx | dsp16xx \
| e2k | elxsi | epiphany \
| f30[01] | f700 | fido | fr30 | frv | ft32 | fx80 \
+ | javascript \
| h8300 | h8500 \
| hppa | hppa1.[01] | hppa2.0 | hppa2.0[nw] | hppa64 \
| hexagon \
| i370 | i*86 | i860 | i960 | ia16 | ia64 \
| ip2k | iq2000 \
| k1om \
+ | kvx \
| le32 | le64 \
| lm32 \
| loongarch32 | loongarch64 \
@@ -1213,36 +1216,13 @@ case $cpu-$vendor in
| m6811 | m68hc11 | m6812 | m68hc12 | m68hcs12x \
| m88110 | m88k | maxq | mb | mcore | mep | metag \
| microblaze | microblazeel \
- | mips | mipsbe | mipseb | mipsel | mipsle \
- | mips16 \
- | mips64 | mips64eb | mips64el \
- | mips64octeon | mips64octeonel \
- | mips64orion | mips64orionel \
- | mips64r5900 | mips64r5900el \
- | mips64vr | mips64vrel \
- | mips64vr4100 | mips64vr4100el \
- | mips64vr4300 | mips64vr4300el \
- | mips64vr5000 | mips64vr5000el \
- | mips64vr5900 | mips64vr5900el \
- | mipsisa32 | mipsisa32el \
- | mipsisa32r2 | mipsisa32r2el \
- | mipsisa32r3 | mipsisa32r3el \
- | mipsisa32r5 | mipsisa32r5el \
- | mipsisa32r6 | mipsisa32r6el \
- | mipsisa64 | mipsisa64el \
- | mipsisa64r2 | mipsisa64r2el \
- | mipsisa64r3 | mipsisa64r3el \
- | mipsisa64r5 | mipsisa64r5el \
- | mipsisa64r6 | mipsisa64r6el \
- | mipsisa64sb1 | mipsisa64sb1el \
- | mipsisa64sr71k | mipsisa64sr71kel \
- | mipsr5900 | mipsr5900el \
- | mipstx39 | mipstx39el \
+ | mips* \
| mmix \
| mn10200 | mn10300 \
| moxie \
| mt \
| msp430 \
+ | nanomips* \
| nds32 | nds32le | nds32be \
| nfp \
| nios | nios2 | nios2eb | nios2el \
@@ -1274,6 +1254,7 @@ case $cpu-$vendor in
| ubicom32 \
| v70 | v850 | v850e | v850e1 | v850es | v850e2 | v850e2v3 \
| vax \
+ | vc4 \
| visium \
| w65 \
| wasm32 | wasm64 \
@@ -1285,7 +1266,7 @@ case $cpu-$vendor in
;;
*)
- echo Invalid configuration \`"$1"\': machine \`"$cpu-$vendor"\' not recognized 1>&2
+ echo "Invalid configuration '$1': machine '$cpu-$vendor' not recognized" 1>&2
exit 1
;;
esac
@@ -1306,11 +1287,12 @@ esac
# Decode manufacturer-specific aliases for certain operating systems.
-if test x$basic_os != x
+if test x"$basic_os" != x
then
# First recognize some ad-hoc cases, or perhaps split kernel-os, or else just
# set os.
+obj=
case $basic_os in
gnu/linux*)
kernel=linux
@@ -1510,10 +1492,16 @@ case $os in
os=eabi
;;
*)
- os=elf
+ os=
+ obj=elf
;;
esac
;;
+ aout* | coff* | elf* | pe*)
+ # These are machine code file formats, not OSes
+ obj=$os
+ os=
+ ;;
*)
# No normalization, but not necessarily accepted, that comes below.
;;
@@ -1532,12 +1520,15 @@ else
# system, and we'll never get to this point.
kernel=
+obj=
case $cpu-$vendor in
score-*)
- os=elf
+ os=
+ obj=elf
;;
spu-*)
- os=elf
+ os=
+ obj=elf
;;
*-acorn)
os=riscix1.2
@@ -1547,28 +1538,35 @@ case $cpu-$vendor in
os=gnu
;;
arm*-semi)
- os=aout
+ os=
+ obj=aout
;;
c4x-* | tic4x-*)
- os=coff
+ os=
+ obj=coff
;;
c8051-*)
- os=elf
+ os=
+ obj=elf
;;
clipper-intergraph)
os=clix
;;
hexagon-*)
- os=elf
+ os=
+ obj=elf
;;
tic54x-*)
- os=coff
+ os=
+ obj=coff
;;
tic55x-*)
- os=coff
+ os=
+ obj=coff
;;
tic6x-*)
- os=coff
+ os=
+ obj=coff
;;
# This must come before the *-dec entry.
pdp10-*)
@@ -1590,19 +1588,24 @@ case $cpu-$vendor in
os=sunos3
;;
m68*-cisco)
- os=aout
+ os=
+ obj=aout
;;
mep-*)
- os=elf
+ os=
+ obj=elf
;;
mips*-cisco)
- os=elf
+ os=
+ obj=elf
;;
- mips*-*)
- os=elf
+ mips*-*|nanomips*-*)
+ os=
+ obj=elf
;;
or32-*)
- os=coff
+ os=
+ obj=coff
;;
*-tti) # must be before sparc entry or we get the wrong os.
os=sysv3
@@ -1611,7 +1614,8 @@ case $cpu-$vendor in
os=sunos4.1.1
;;
pru-*)
- os=elf
+ os=
+ obj=elf
;;
*-be)
os=beos
@@ -1692,10 +1696,12 @@ case $cpu-$vendor in
os=uxpv
;;
*-rom68k)
- os=coff
+ os=
+ obj=coff
;;
*-*bug)
- os=coff
+ os=
+ obj=coff
;;
*-apple)
os=macos
@@ -1713,10 +1719,11 @@ esac
fi
-# Now, validate our (potentially fixed-up) OS.
+# Now, validate our (potentially fixed-up) individual pieces (OS, OBJ).
+
case $os in
# Sometimes we do "kernel-libc", so those need to count as OSes.
- musl* | newlib* | relibc* | uclibc*)
+ llvm* | musl* | newlib* | relibc* | uclibc*)
;;
# Likewise for "kernel-abi"
eabi* | gnueabi*)
@@ -1724,6 +1731,9 @@ case $os in
# VxWorks passes extra cpu info in the 4th filed.
simlinux | simwindows | spe)
;;
+ # See `case $cpu-$os` validation below
+ ghcjs)
+ ;;
# Now accept the basic system types.
# The portable systems comes first.
# Each alternative MUST end in a * to match a version number.
@@ -1732,7 +1742,7 @@ case $os in
| hpux* | unos* | osf* | luna* | dgux* | auroraux* | solaris* \
| sym* | plan9* | psp* | sim* | xray* | os68k* | v88r* \
| hiux* | abug | nacl* | netware* | windows* \
- | os9* | macos* | osx* | ios* \
+ | os9* | macos* | osx* | ios* | tvos* | watchos* \
| mpw* | magic* | mmixware* | mon960* | lnews* \
| amigaos* | amigados* | msdos* | newsos* | unicos* | aof* \
| aos* | aros* | cloudabi* | sortix* | twizzler* \
@@ -1741,11 +1751,11 @@ case $os in
| mirbsd* | netbsd* | dicos* | openedition* | ose* \
| bitrig* | openbsd* | secbsd* | solidbsd* | libertybsd* | os108* \
| ekkobsd* | freebsd* | riscix* | lynxos* | os400* \
- | bosx* | nextstep* | cxux* | aout* | elf* | oabi* \
- | ptx* | coff* | ecoff* | winnt* | domain* | vsta* \
+ | bosx* | nextstep* | cxux* | oabi* \
+ | ptx* | ecoff* | winnt* | domain* | vsta* \
| udi* | lites* | ieee* | go32* | aux* | hcos* \
| chorusrdb* | cegcc* | glidix* | serenity* \
- | cygwin* | msys* | pe* | moss* | proelf* | rtems* \
+ | cygwin* | msys* | moss* | proelf* | rtems* \
| midipix* | mingw32* | mingw64* | mint* \
| uxpv* | beos* | mpeix* | udk* | moxiebox* \
| interix* | uwin* | mks* | rhapsody* | darwin* \
@@ -1758,62 +1768,116 @@ case $os in
| onefs* | tirtos* | phoenix* | fuchsia* | redox* | bme* \
| midnightbsd* | amdhsa* | unleashed* | emscripten* | wasi* \
| nsk* | powerunix* | genode* | zvmoe* | qnx* | emx* | zephyr* \
- | fiwix* | mlibc* )
+ | fiwix* | mlibc* | cos* | mbr* | ironclad* )
;;
# This one is extra strict with allowed versions
sco3.2v2 | sco3.2v[4-9]* | sco5v6*)
# Don't forget version if it is 3.2v4 or newer.
;;
+ # This refers to builds using the UEFI calling convention
+ # (which depends on the architecture) and PE file format.
+ # Note that this is both a different calling convention and
+ # different file format than that of GNU-EFI
+ # (x86_64-w64-mingw32).
+ uefi)
+ ;;
none)
;;
- kernel* )
+ kernel* | msvc* )
# Restricted further below
;;
+ '')
+ if test x"$obj" = x
+ then
+ echo "Invalid configuration '$1': Blank OS only allowed with explicit machine code file format" 1>&2
+ fi
+ ;;
*)
- echo Invalid configuration \`"$1"\': OS \`"$os"\' not recognized 1>&2
+ echo "Invalid configuration '$1': OS '$os' not recognized" 1>&2
+ exit 1
+ ;;
+esac
+
+case $obj in
+ aout* | coff* | elf* | pe*)
+ ;;
+ '')
+ # empty is fine
+ ;;
+ *)
+ echo "Invalid configuration '$1': Machine code format '$obj' not recognized" 1>&2
+ exit 1
+ ;;
+esac
+
+# Here we handle the constraint that a (synthetic) cpu and os are
+# valid only in combination with each other and nowhere else.
+case $cpu-$os in
+ # The "javascript-unknown-ghcjs" triple is used by GHC; we
+ # accept it here in order to tolerate that, but reject any
+ # variations.
+ javascript-ghcjs)
+ ;;
+ javascript-* | *-ghcjs)
+ echo "Invalid configuration '$1': cpu '$cpu' is not valid with os '$os$obj'" 1>&2
exit 1
;;
esac
# As a final step for OS-related things, validate the OS-kernel combination
# (given a valid OS), if there is a kernel.
-case $kernel-$os in
- linux-gnu* | linux-dietlibc* | linux-android* | linux-newlib* \
- | linux-musl* | linux-relibc* | linux-uclibc* | linux-mlibc* )
+case $kernel-$os-$obj in
+ linux-gnu*- | linux-android*- | linux-dietlibc*- | linux-llvm*- \
+ | linux-mlibc*- | linux-musl*- | linux-newlib*- \
+ | linux-relibc*- | linux-uclibc*- )
;;
- uclinux-uclibc* )
+ uclinux-uclibc*- )
;;
- managarm-mlibc* | managarm-kernel* )
+ managarm-mlibc*- | managarm-kernel*- )
;;
- -dietlibc* | -newlib* | -musl* | -relibc* | -uclibc* | -mlibc* )
+ windows*-msvc*-)
+ ;;
+ -dietlibc*- | -llvm*- | -mlibc*- | -musl*- | -newlib*- | -relibc*- \
+ | -uclibc*- )
# These are just libc implementations, not actual OSes, and thus
# require a kernel.
- echo "Invalid configuration \`$1': libc \`$os' needs explicit kernel." 1>&2
+ echo "Invalid configuration '$1': libc '$os' needs explicit kernel." 1>&2
exit 1
;;
- -kernel* )
- echo "Invalid configuration \`$1': \`$os' needs explicit kernel." 1>&2
+ -kernel*- )
+ echo "Invalid configuration '$1': '$os' needs explicit kernel." 1>&2
exit 1
;;
- *-kernel* )
- echo "Invalid configuration \`$1': \`$kernel' does not support \`$os'." 1>&2
+ *-kernel*- )
+ echo "Invalid configuration '$1': '$kernel' does not support '$os'." 1>&2
exit 1
;;
- kfreebsd*-gnu* | kopensolaris*-gnu*)
+ *-msvc*- )
+ echo "Invalid configuration '$1': '$os' needs 'windows'." 1>&2
+ exit 1
;;
- vxworks-simlinux | vxworks-simwindows | vxworks-spe)
+ kfreebsd*-gnu*- | kopensolaris*-gnu*-)
;;
- nto-qnx*)
+ vxworks-simlinux- | vxworks-simwindows- | vxworks-spe-)
;;
- os2-emx)
+ nto-qnx*-)
+ ;;
+ os2-emx-)
+ ;;
+ *-eabi*- | *-gnueabi*-)
;;
- *-eabi* | *-gnueabi*)
+ none--*)
+ # None (no kernel, i.e. freestanding / bare metal),
+ # can be paired with an machine code file format
;;
- -*)
+ -*-)
# Blank kernel with real OS is always fine.
;;
- *-*)
- echo "Invalid configuration \`$1': Kernel \`$kernel' not known to work with OS \`$os'." 1>&2
+ --*)
+ # Blank kernel and OS with real machine code file format is always fine.
+ ;;
+ *-*-*)
+ echo "Invalid configuration '$1': Kernel '$kernel' not known to work with OS '$os'." 1>&2
exit 1
;;
esac
@@ -1896,7 +1960,7 @@ case $vendor in
;;
esac
-echo "$cpu-$vendor-${kernel:+$kernel-}$os"
+echo "$cpu-$vendor${kernel:+-$kernel}${os:+-$os}${obj:+-$obj}"
exit
# Local variables:
diff --git a/build-aux/git-hooks/commit-msg-files.awk b/build-aux/git-hooks/commit-msg-files.awk
new file mode 100644
index 00000000000..2fbbd059500
--- /dev/null
+++ b/build-aux/git-hooks/commit-msg-files.awk
@@ -0,0 +1,128 @@
+# Check the file list of GNU Emacs change log entries for each commit SHA.
+
+# Copyright 2023-2024 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 <https://www.gnu.org/licenses/>.
+
+### Commentary:
+
+# This script accepts a list of (unabbreviated) Git commit SHAs, and
+# will then iterate over them to check that any files mentioned in the
+# commit message are actually present in the commit's diff. If not,
+# it will print out the incorrect file names and return 1.
+
+# You can also pass "-v reason=pre-push", which will add more-verbose
+# output, indicating the abbreviated commit SHA and first line of the
+# commit message for any improper commits.
+
+### Code:
+
+function get_commit_changes(commit_sha, changes, cmd, i, j, len, \
+ bits, filename) {
+ # Collect all the files touched in the specified commit.
+ cmd = ("git show --name-status --first-parent --format= " commit_sha)
+ while ((cmd | getline) > 0) {
+ for (i = 2; i <= NF; i++) {
+ len = split($i, bits, "/")
+ for (j = 1; j <= len; j++) {
+ if (j == 1)
+ filename = bits[j]
+ else
+ filename = filename "/" bits[j]
+ changes[filename] = 1
+ }
+ }
+ }
+ close(cmd)
+}
+
+function check_commit_msg_files(commit_sha, verbose, changes, good, \
+ cmd, msg, filenames_str, filenames, i) {
+ get_commit_changes(commit_sha, changes)
+ good = 1
+
+ cmd = ("git log -1 --format=%B " commit_sha)
+ while ((cmd | getline) > 0) {
+ if (verbose && ! msg)
+ msg = $0
+
+ # Find file entries in the commit message. We look at any line
+ # starting with "*" (possibly prefixed by "; ") followed by a ":",
+ # possibly on a different line. If we encounter a blank line
+ # without seeing a ":", then we don't treat that as a file entry.
+
+ # Accumulate the contents of a (possible) file entry.
+ if (/^[ \t]*$/)
+ filenames_str = ""
+ else if (/^(; )?\*[ \t]+[[:alnum:]]/)
+ filenames_str = $0
+ else if (filenames_str)
+ filenames_str = (filenames_str $0)
+
+ # We have a file entry; analyze it.
+ if (filenames_str && /:/) {
+ # Delete the leading "*" and any trailing information.
+ sub(/^(; )?\*[ \t]+/, "", filenames_str)
+ sub(/[ \t]*[[(<:].*$/, "", filenames_str)
+
+ # There might be multiple files listed in this entry, separated
+ # by spaces (and possibly a comma). Iterate over each of them.
+ split(filenames_str, filenames, ",[ \t]+")
+ for (i in filenames) {
+ # Remove trailing slashes from any directory entries.
+ sub(/\/$/, "", filenames[i])
+
+ if (length(filenames[i]) && ! (filenames[i] in changes)) {
+ if (good) {
+ # Print a header describing the error.
+ if (verbose)
+ printf("In commit %s \"%s\"...\n", substr(commit_sha, 1, 10), msg)
+ printf("Files listed in commit message, but not in diff:\n")
+ }
+ printf(" %s\n", filenames[i])
+ good = 0
+ }
+ }
+
+ filenames_str = ""
+ }
+ }
+ close(cmd)
+
+ return good
+}
+
+BEGIN {
+ if (reason == "pre-push")
+ verbose = 1
+}
+
+/^[a-z0-9]{40}$/ {
+ if (! check_commit_msg_files($0, verbose)) {
+ status = 1
+ }
+}
+
+END {
+ if (status != 0) {
+ if (reason == "pre-push")
+ error_msg = "Push aborted"
+ else
+ error_msg = "Bad commit message"
+ printf("%s; please see the file 'CONTRIBUTE'\n", error_msg)
+ }
+ exit status
+}
diff --git a/build-aux/git-hooks/post-commit b/build-aux/git-hooks/post-commit
new file mode 100755
index 00000000000..e6b5effc93a
--- /dev/null
+++ b/build-aux/git-hooks/post-commit
@@ -0,0 +1,47 @@
+#!/bin/sh
+# Check the file list of GNU Emacs change log entries after committing.
+
+# Copyright 2023-2024 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 <https://www.gnu.org/licenses/>.
+
+### Commentary:
+
+# This hook runs after a commit is finalized and checks that the files
+# mentioned in the commit message match the diff. We perform this in
+# the post-commit phase so that we can be sure we properly detect all
+# the files in the diff (this is difficult during the commit-msg hook,
+# since there's no cross-platform way to detect when a commit is being
+# amended).
+
+# However, since this is a post-commit hook, it's too late to error
+# out and abort the commit: it's already done! As a result, this hook
+# is purely advisory, and instead we error out when trying to push
+# (see "pre-push" in this directory).
+
+### Code:
+
+HOOKS_DIR=`dirname "$0"`
+
+# Prefer gawk if available, as it handles NUL bytes properly.
+if type gawk >/dev/null 2>&1; then
+ awk="gawk"
+else
+ awk="awk"
+fi
+
+git rev-parse HEAD | $awk -v reason=post-commit \
+ -f "$HOOKS_DIR"/commit-msg-files.awk
diff --git a/build-aux/git-hooks/pre-commit b/build-aux/git-hooks/pre-commit
index c07188bffd3..a86bbf642a5 100755
--- a/build-aux/git-hooks/pre-commit
+++ b/build-aux/git-hooks/pre-commit
@@ -21,6 +21,14 @@
LC_ALL=C
export LC_ALL
+# If this is a system where /bin/sh isn't sufficient to
+# run git-sh-setup, use a working shell as a recourse.
+if test -x "/usr/xpg4/bin/sh" && test -z "$POSIX_SHELL"; then
+ POSIX_SHELL=1
+ export POSIX_SHELL
+ exec "/usr/xpg4/bin/sh" `dirname $0`/pre-commit
+fi
+
exec >&2
. git-sh-setup
@@ -52,6 +60,9 @@ while IFS= read -r new_name; do
-* | */-*)
echo "$new_name: File name component begins with '-'."
exit 1;;
+ ChangeLog.android)
+ # This file is explicitly ok.
+ ;;
ChangeLog | */ChangeLog)
echo "$new_name: Please use git commit messages, not ChangeLog files."
exit 1;;
diff --git a/build-aux/git-hooks/pre-push b/build-aux/git-hooks/pre-push
new file mode 100755
index 00000000000..86c81e02d9a
--- /dev/null
+++ b/build-aux/git-hooks/pre-push
@@ -0,0 +1,88 @@
+#!/bin/sh
+# Check the file list of GNU Emacs change log entries before pushing.
+
+# Copyright 2023-2024 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 <https://www.gnu.org/licenses/>.
+
+### Commentary:
+
+# This hook runs before pushing a series of commits and checks that
+# the files mentioned in each commit message match the diffs. This
+# helps ensure that the resulting change logs are correct, which
+# should prevent errors when generating etc/AUTHORS.
+
+# These checks also happen in the "post-commit" hook (which see), but
+# that hook can't abort a commit; it just advises the committer to fix
+# the commit so that this hook runs without errors.
+
+### Code:
+
+HOOKS_DIR=`dirname "$0"`
+
+# Prefer gawk if available, as it handles NUL bytes properly.
+if type gawk >/dev/null 2>&1; then
+ awk="gawk"
+else
+ awk="awk"
+fi
+
+# Standard input receives lines of the form:
+# <local ref> SP <local sha> SP <remote ref> SP <remote sha> LF
+$awk -v origin_name="$1" '
+ # If the local SHA is all zeroes, ignore it.
+ $2 ~ /^0{40}$/ {
+ next
+ }
+
+ # Check any lines with a valid local SHA and whose remote ref is
+ # master or an emacs-NN release branch. (We want to avoid checking
+ # feature or scratch branches here.)
+ $2 ~ /^[a-z0-9]{40}$/ && $3 ~ /^refs\/heads\/(master|emacs-[0-9]+)$/ {
+ newref = $2
+ # If the remote SHA is all zeroes, this is a new object to be
+ # pushed (likely a branch)...
+ if ($4 ~ /^0{40}$/) {
+ back = 0
+ # ... Go backwards until we find a SHA on an origin branch.
+ # Stop trying after 1000 commits, just in case...
+ for (back = 0; back < 1000; back++) {
+ cmd = ("git branch -r -l '\''" origin_name "/*'\''" \
+ " --contains " newref "~" back)
+ rv = (cmd | getline)
+ close(cmd)
+ if (rv > 0)
+ break;
+ }
+
+ cmd = ("git rev-parse " newref "~" back)
+ cmd | getline oldref
+ if (!(oldref ~ /^[a-z0-9]{40}$/)) {
+ # The SHA is misformatted! Skip this line.
+ next
+ }
+ close(cmd)
+ } else if ($4 ~ /^[a-z0-9]{40}$/) {
+ oldref = $4
+ } else {
+ # The SHA is misformatted! Skip this line.
+ next
+ }
+
+ # Print every SHA after oldref, up to (and including) newref.
+ system("git rev-list --first-parent --reverse " oldref ".." newref)
+ }
+' | $awk -v reason=pre-push -f "$HOOKS_DIR"/commit-msg-files.awk
diff --git a/build-aux/git-hooks/prepare-commit-msg b/build-aux/git-hooks/prepare-commit-msg
index 082c9444365..0367858ea7e 100755
--- a/build-aux/git-hooks/prepare-commit-msg
+++ b/build-aux/git-hooks/prepare-commit-msg
@@ -25,6 +25,10 @@ SHA1=$3
# Prefer gawk if available, as it handles NUL bytes properly.
if type gawk >/dev/null 2>&1; then
awk="gawk"
+# Next use /usr/xpg4/bin/awk if available, since the script
+# doesn't support Unix awk.
+elif test -x /usr/xpg4/bin/awk; then
+ awk="/usr/xpg4/bin/awk"
else
awk="awk"
fi
diff --git a/build-aux/gitlog-to-changelog b/build-aux/gitlog-to-changelog
index 0cc2c04a4c4..16a9405a7cb 100755
--- a/build-aux/gitlog-to-changelog
+++ b/build-aux/gitlog-to-changelog
@@ -20,7 +20,7 @@
#
# Written by Jim Meyering
-# This is a prologue that allows to run a perl script as an executable
+# This is a prologue that allows running a perl script as an executable
# on systems that are compliant to a POSIX version before POSIX:2017.
# On such systems, the usual invocation of an executable through execlp()
# or execvp() fails with ENOEXEC if it is a script that does not start
@@ -35,7 +35,7 @@
eval 'exec perl -wSx "$0" "$@"'
if 0;
-my $VERSION = '2022-01-27 18:49'; # UTC
+my $VERSION = '2023-06-24 21:59'; # UTC
# The definition above must lie within the first 8 lines in order
# for the Emacs time-stamp write hook (at end) to update it.
# If you change this file with Emacs, please let the write hook
@@ -355,7 +355,7 @@ sub git_dir_option($)
. "(expected date/author/email):\n$author_line\n";
# Format 'Copyright-paperwork-exempt: Yes' as a standard ChangeLog
- # `(tiny change)' annotation.
+ # '(tiny change)' annotation.
my $tiny = (grep (/^(?:Copyright-paperwork-exempt|Tiny-change):\s+[Yy]es$/, @line)
? ' (tiny change)' : '');
diff --git a/build-aux/install-sh b/build-aux/install-sh
index ec298b53740..7c56c9c0151 100755
--- a/build-aux/install-sh
+++ b/build-aux/install-sh
@@ -1,7 +1,7 @@
#!/bin/sh
# install - install a program, script, or datafile
-scriptversion=2020-11-14.01; # UTC
+scriptversion=2023-11-23.18; # UTC
# This originates from X11R5 (mit/util/scripts/install.sh), which was
# later released in X11R6 (xc/config/util/install.sh) with the
@@ -124,9 +124,9 @@ it's up to you to specify -f if you want it.
If -S is not specified, no backups are attempted.
-Email bug reports to bug-automake@gnu.org.
-Automake home page: https://www.gnu.org/software/automake/
-"
+Report bugs to <bug-automake@gnu.org>.
+GNU Automake home page: <https://www.gnu.org/software/automake/>.
+General help using GNU software: <https://www.gnu.org/gethelp/>."
while test $# -ne 0; do
case $1 in
diff --git a/build-aux/make-info-dir b/build-aux/make-info-dir
index e5f4972902f..703abc7bd0a 100755
--- a/build-aux/make-info-dir
+++ b/build-aux/make-info-dir
@@ -38,7 +38,7 @@ shift
exec "${AWK-awk}" '
function detexinfo() {
- gsub(/@value{emacsname}/, "Emacs")
+ gsub(/@value\{emacsname\}/, "Emacs")
gsub(/@[^{]*\{/, "")
gsub(/}/, "")
}
diff --git a/build-aux/makecounter.sh b/build-aux/makecounter.sh
new file mode 100755
index 00000000000..a63fcbb7c61
--- /dev/null
+++ b/build-aux/makecounter.sh
@@ -0,0 +1,43 @@
+#!/bin/sh
+# Generate or update a C file containing an increasing counter
+# variable.
+#
+# Copyright (C) 2023-2024 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 <https://www.gnu.org/licenses/>.
+
+set -e
+
+curcount=
+if test -f "$1"; then
+ curcount=`cat "$1" | grep = | cut -d= -f2 \
+ | sed -e 's/;//' -e 's/ //'`
+fi
+
+curcount=`expr 1 + $curcount 2>/dev/null || echo 0`
+
+cat > $1 <<EOF
+/* Generated automatically by makecounter.sh. Do not edit! */
+
+#include <config.h>
+
+#ifdef HAVE_ANDROID
+#define EXPORT __attribute__ ((visibility ("default")))
+#endif /* HAVE_ANDROID */
+
+#ifdef EXPORT
+EXPORT
+#endif /* EXPORT */
+int emacs_shortlisp_counter = $curcount;
+EOF
diff --git a/build-aux/ndk-build-helper-1.mk b/build-aux/ndk-build-helper-1.mk
new file mode 100644
index 00000000000..490064b6e32
--- /dev/null
+++ b/build-aux/ndk-build-helper-1.mk
@@ -0,0 +1,112 @@
+# ndk-build-helper-1.mk -- Helper for ndk-build.m4.
+# Copyright (C) 2023-2024 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 <https://www.gnu.org/licenses/>.
+
+# Print out information now defined. Important details include:
+# - list of source files to compile.
+# - module export include directories.
+# - module export CFLAGS.
+# - module export LDFLAGS.
+# - module name.
+
+build_kind = shared
+NDK_SO_NAMES =
+NDK_A_NAMES =
+
+# Record this module's dependencies. This information is used later
+# on to recurse over libraries.
+NDK_$(LOCAL_MODULE)_STATIC_LIBRARIES := $(LOCAL_STATIC_LIBRARIES) $(LOCAL_WHOLE_STATIC_LIBRARIES)
+NDK_$(LOCAL_MODULE)_SHARED_LIBRARIES := $(LOCAL_SHARED_LIBRARIES)
+NDK_$(LOCAL_MODULE)_EXPORT_INCLUDES := $(LOCAL_EXPORT_C_INCLUDE_DIRS) $(LOCAL_EXPORT_C_INCLUDES)
+NDK_CXX_FLAG_$(LOCAL_MODULE) :=
+
+$(info Building $(build_kind))
+$(info $(LOCAL_MODULE))
+$(info $(addprefix $(LOCAL_PATH)/,$(LOCAL_SRC_FILES) $(LOCAL_SRC_FILES$(EMACS_ABI))))
+
+ifeq ($(findstring lib,$(LOCAL_MODULE)),lib)
+NDK_SO_NAMES = $(LOCAL_MODULE)_emacs.so
+else
+NDK_SO_NAMES = lib$(LOCAL_MODULE)_emacs.so
+endif
+
+define add-so-name-1
+# Now recurse over this module's dependencies.
+$$(foreach module,$$(filter-out $$(SYSTEM_LIBRARIES), $$(NDK_$(1)_SHARED_LIBRARIES)),$$(eval $$(call add-so-name,$$(module))))
+$$(foreach module,$$(filter-out $$(SYSTEM_LIBRARIES), $$(NDK_$(1)_STATIC_LIBRARIES)),$$(eval $$(call add-so-name-1,$$(module))))
+endef
+
+define add-so-name
+ifeq ($(findstring lib,$(1)),lib)
+NDK_SO_NAME = $(1)_emacs.so
+else
+NDK_SO_NAME = lib$(1)_emacs.so
+endif
+
+ifeq ($$(findstring $$(NDK_SO_NAME),$$(NDK_SO_NAMES)),)
+NDK_SO_NAMES := $$(NDK_SO_NAMES) $$(NDK_SO_NAME)
+
+# Now recurse over this module's dependencies.
+$$(foreach module,$$(filter-out $$(SYSTEM_LIBRARIES), $$(NDK_$(1)_SHARED_LIBRARIES)),$$(eval $$(call add-so-name,$$(module))))
+
+# Recurse over static library dependencies of this shared library.
+$$(foreach module,$$(filter-out $$(SYSTEM_LIBRARIES), $$(NDK_$(1)_STATIC_LIBRARIES) $$(NDK_$(1)_WHOLE_LIBRARIES)),$$(eval $$(call add-so-name-1,$$(module))))
+endif
+
+ifneq ($$(findstring stdc++,$$(NDK_$(1)_SHARED_LIBRARIES)),)
+NDK_CXX_FLAG_$(LOCAL_MODULE) := yes
+endif
+endef
+
+# Figure out includes from dependencies as well.
+NDK_INCLUDES := $(LOCAL_EXPORT_C_INCLUDE_DIRS) $(LOCAL_EXPORT_C_INCLUDES)
+
+define add-includes
+ifeq ($$(findstring $$(NDK_$(1)_EXPORT_INCLUDES),$$(NDK_INCLUDES)),)
+NDK_INCLUDES += $$(NDK_$(1)_EXPORT_INCLUDES)
+
+$$(foreach module,$$(filter-out $$(SYSTEM_LIBRARIES), $$(NDK_$(1)_SHARED_LIBRARIES)) $$(NDK_$(1)_STATIC_LIBRARIES),$$(eval $$(call add-includes,$$(module))))
+
+# Recurse over shared library dependencies of this static library.
+$$(foreach module,$$(filter-out $$(SYSTEM_LIBRARIES), $$(NDK_$(1)_SHARED_LIBRARIES)),$$(eval $$(call add-so-name,$$(module))))
+
+# Recurse over static or shared library dependencies of this static
+# library.
+$$(foreach module,$$(filter-out $$(SYSTEM_LIBRARIES), $$(NDK_$(1)_STATIC_LIBRARIES)),$$(eval $$(call add-so-name-1,$$(module))))
+endif
+endef
+
+# Resolve additional dependencies and their export includes based on
+# LOCAL_STATIC_LIBRARIES and LOCAL_SHARED_LIBRARIES. Static library
+# dependencies can be ignored while building a shared library, as they
+# will be linked in to the resulting shared object file later.
+
+SYSTEM_LIBRARIES = z libz libc c libdl dl stdc++ libstdc++ stlport libstlport gnustl libgnustl c++ libc++ log liblog android libandroid
+
+$(foreach module,$(filter-out $(SYSTEM_LIBRARIES), $(LOCAL_SHARED_LIBRARIES)),$(eval $(call add-so-name,$(module))))
+$(foreach module,$(filter-out $(SYSTEM_LIBRARIES), $(LOCAL_SHARED_LIBRARIES) $(LOCAL_STATIC_LIBRARIES) $(LOCAL_WHOLE_STATIC_LIBRARIES)),$(eval $(call add-includes,$(module))))
+
+ifneq ($(findstring stdc++,$(LOCAL_SHARED_LIBRARIES)),)
+NDK_CXX_FLAG_$(LOCAL_MODULE) := yes
+endif
+
+$(info $(foreach dir,$(NDK_INCLUDES),-I$(dir)))
+$(info $(LOCAL_EXPORT_CFLAGS))
+
+$(info $(LOCAL_EXPORT_LDFLAGS) $(abspath $(addprefix $(NDK_BUILD_DIR)/,$(NDK_A_NAMES))) -L$(abspath $(NDK_BUILD_DIR)) $(foreach soname,$(NDK_SO_NAMES),-l:$(soname)))
+$(info $(NDK_SO_NAMES))
+$(info $(NDK_CXX_FLAG_$(LOCAL_MODULE)))
+$(info End)
diff --git a/build-aux/ndk-build-helper-2.mk b/build-aux/ndk-build-helper-2.mk
new file mode 100644
index 00000000000..e696fcbdade
--- /dev/null
+++ b/build-aux/ndk-build-helper-2.mk
@@ -0,0 +1,105 @@
+# ndk-build-helper-2.mk -- Helper for ndk-build.m4.
+# Copyright (C) 2023-2024 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 <https://www.gnu.org/licenses/>.
+
+# Say a static library is being built
+build_kind = static
+NDK_SO_NAMES =
+NDK_A_NAMES =
+
+# Record this module's dependencies. This information is used later
+# on to recurse over libraries.
+NDK_$(LOCAL_MODULE)_STATIC_LIBRARIES := $(LOCAL_STATIC_LIBRARIES) $(LOCAL_WHOLE_STATIC_LIBRARIES)
+NDK_$(LOCAL_MODULE)_SHARED_LIBRARIES := $(LOCAL_SHARED_LIBRARIES)
+NDK_$(LOCAL_MODULE)_EXPORT_INCLUDES := $(LOCAL_EXPORT_C_INCLUDE_DIRS) $(LOCAL_EXPORT_C_INCLUDES)
+NDK_CXX_FLAG_$(LOCAL_MODULE) :=
+
+$(info Building $(build_kind))
+$(info $(LOCAL_MODULE))
+$(info $(addprefix $(LOCAL_PATH)/,$(LOCAL_SRC_FILES) $(LOCAL_SRC_FILES$(EMACS_ABI))))
+
+ifeq ($(findstring lib,$(LOCAL_MODULE)),lib)
+NDK_A_NAMES = $(LOCAL_MODULE).a
+else
+NDK_A_NAMES = lib$(LOCAL_MODULE).a
+endif
+
+define add-a-name
+ifeq ($(findstring lib,$(1)),lib)
+NDK_A_NAME = $(1).a
+else
+NDK_A_NAME = lib$(1).a
+endif
+
+ifeq ($$(findstring $$(NDK_A_NAME),$$(NDK_A_NAMES)),)
+NDK_A_NAMES := $$(NDK_A_NAMES) $$(NDK_A_NAME)
+
+# Now recurse over this module's dependencies.
+$$(foreach module,$$(filter-out $$(SYSTEM_LIBRARIES), $$(NDK_$(1)_STATIC_LIBRARIES)),$$(eval $$(call add-a-name,$$(module))))
+$$(foreach module,$$(filter-out $$(SYSTEM_LIBRARIES), $$(NDK_$(1)_SHARED_LIBRARIES)),$$(eval $$(call add-so-name,$$(module))))
+endif
+
+ifneq ($$(findstring stdc++,$$(NDK_$(1)_SHARED_LIBRARIES)),)
+NDK_CXX_FLAG_$(LOCAL_MODULE) := yes
+endif
+endef
+
+define add-so-name
+ifeq ($(findstring lib,$(1)),lib)
+NDK_SO_NAME = $(1)_emacs.so
+else
+NDK_SO_NAME = lib$(1)_emacs.so
+endif
+
+ifeq ($$(NDK_SO_NAMES:$$(NDK_SO_NAME)=),$$(NDK_SO_NAMES))
+NDK_SO_NAMES := $$(NDK_SO_NAMES) $$(NDK_SO_NAME)
+
+# Now recurse over this module's dependencies.
+$$(foreach module,$$(filter-out $$(SYSTEM_LIBRARIES), $$(NDK_$(1)_STATIC_LIBRARIES)),$$(eval $$(call add-a-name,$$(module))))
+$$(foreach module,$$(filter-out $$(SYSTEM_LIBRARIES), $$(NDK_$(1)_SHARED_LIBRARIES)),$$(eval $$(call add-so-name,$$(module))))
+endif
+endef
+
+# Figure out includes from dependencies as well.
+NDK_INCLUDES := $(LOCAL_EXPORT_C_INCLUDE_DIRS) $(LOCAL_EXPORT_C_INCLUDES)
+
+define add-includes
+ifeq ($$(findstring $$(NDK_$(1)_EXPORT_INCLUDES),$$(NDK_INCLUDES)),)
+NDK_INCLUDES += $$(NDK_$(1)_EXPORT_INCLUDES)
+
+$$(foreach module,$$(filter-out $$(SYSTEM_LIBRARIES), $$(NDK_$(1)_SHARED_LIBRARIES)) $$(NDK_$(1)_STATIC_LIBRARIES),$$(eval $$(call add-includes,$$(module))))
+endif
+endef
+
+# Resolve additional dependencies based on LOCAL_STATIC_LIBRARIES and
+# LOCAL_SHARED_LIBRARIES.
+
+SYSTEM_LIBRARIES = z libz libc c libdl dl libstdc++ stdc++ stlport libstlport gnustl libgnustl c++ libc++ log liblog android libandroid
+
+$(foreach module,$(filter-out $(SYSTEM_LIBRARIES), $(LOCAL_STATIC_LIBRARIES) $(LOCAL_WHOLE_STATIC_LIBRARIES)),$(eval $(call add-a-name,$(module))))
+$(foreach module,$(filter-out $(SYSTEM_LIBRARIES), $(LOCAL_SHARED_LIBRARIES)),$(eval $(call add-so-name,$(module))))
+$(foreach module,$(filter-out $(SYSTEM_LIBRARIES), $(LOCAL_SHARED_LIBRARIES) $(LOCAL_STATIC_LIBRARIES) $(LOCAL_WHOLE_LIBRARIES)),$(eval $(call add-includes,$(module))))
+
+ifneq ($(findstring stdc++,$(LOCAL_SHARED_LIBRARIES)),)
+NDK_CXX_FLAG_$(LOCAL_MODULE) := yes
+endif
+
+$(info $(foreach dir,$(NDK_INCLUDES),-I$(dir)))
+$(info $(LOCAL_EXPORT_CFLAGS))
+$(info $(LOCAL_EXPORT_LDFLAGS) $(abspath $(addprefix $(NDK_BUILD_DIR)/,$(NDK_A_NAMES))) $(and $(NDK_SO_NAMES), -L$(abspath $(NDK_BUILD_DIR)) $(foreach soname,$(NDK_SO_NAMES),-l:$(soname))))
+$(info $(NDK_A_NAMES) $(NDK_SO_NAMES))
+$(info $(NDK_CXX_FLAG_$(LOCAL_MODULE)))
+$(info End)
diff --git a/build-aux/ndk-build-helper-3.mk b/build-aux/ndk-build-helper-3.mk
new file mode 100644
index 00000000000..e360a347bb4
--- /dev/null
+++ b/build-aux/ndk-build-helper-3.mk
@@ -0,0 +1,28 @@
+# ndk-build-helper-3.mk -- Helper for ndk-build.m4.
+# Copyright (C) 2023-2024 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 <https://www.gnu.org/licenses/>.
+
+# Say a static library is being built
+build_kind = executable
+
+$(info Building $(build_kind))
+$(info $(LOCAL_MODULE))
+$(info $(addprefix $(ANDROID_MODULE_DIRECTORY),$(LOCAL_SRC_FILES) $(LOCAL_SRC_FILES$(EMACS_ABI))))
+
+$(info $(foreach dir,$(LOCAL_EXPORT_C_INCLUDE_DIRS) $(LOCAL_EXPORT_C_INCLUDES),-I$(dir)))
+$(info $(LOCAL_EXPORT_CFLAGS))
+$(info $(LOCAL_EXPORT_LDFLAGS))
+$(info End)
diff --git a/build-aux/ndk-build-helper-4.mk b/build-aux/ndk-build-helper-4.mk
new file mode 100644
index 00000000000..54f781bdbaa
--- /dev/null
+++ b/build-aux/ndk-build-helper-4.mk
@@ -0,0 +1,39 @@
+# Copyright (C) 2023-2024 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 <https://www.gnu.org/licenses/>.
+
+undefine LOCAL_MODULE
+undefine LOCAL_MODULE_FILENAME
+undefine LOCAL_SRC_FILES
+undefine LOCAL_CPP_EXTENSION
+undefine LOCAL_CPP_FEATURES
+undefine LOCAL_C_INCLUDES
+undefine LOCAL_CFLAGS
+undefine LOCAL_CPPFLAGS
+undefine LOCAL_STATIC_LIBRARIES
+undefine LOCAL_SHARED_LIBRARIES
+undefine LOCAL_WHOLE_STATIC_LIBRARIES
+undefine LOCAL_LDLIBS
+undefine LOCAL_LDFLAGS
+undefine LOCAL_ALLOW_UNDEFINED_SYMBOLS
+undefine LOCAL_ARM_MODE
+undefine LOCAL_ARM_NEON
+undefine LOCAL_DISABLE_FORMAT_STRING_CHECKS
+undefine LOCAL_EXPORT_CFLAGS
+undefine LOCAL_EXPORT_CPPFLAGS
+undefine LOCAL_EXPORT_C_INCLUDES
+undefine LOCAL_EXPORT_C_INCLUDE_DIRS
+undefine LOCAL_EXPORT_LDFLAGS
+undefine LOCAL_EXPORT_LDLIBS
diff --git a/build-aux/ndk-build-helper.mk b/build-aux/ndk-build-helper.mk
new file mode 100644
index 00000000000..521e1b24ce3
--- /dev/null
+++ b/build-aux/ndk-build-helper.mk
@@ -0,0 +1,81 @@
+# ndk-build-helper.mk -- Helper for ndk-build.m4.
+# Copyright (C) 2023-2024 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 <https://www.gnu.org/licenses/>.
+
+# This Makefile sets up enough to parse an Android-style Android.mk
+# file and return useful information about its contents.
+
+# See the text under ``NDK BUILD SYSTEM IMPLEMENTATION'' in
+# cross/ndk-build/README for more details.
+
+# TARGET_ARCH_ABI is the ABI that is being built for.
+TARGET_ARCH_ABI := $(EMACS_ABI)
+
+# TARGET_ARCH is the architecture that is being built for.
+TARGET_ARCH := $(NDK_BUILD_ARCH)
+
+# NDK_LAST_MAKEFILE is the last Makefile that was included.
+NDK_LAST_MAKEFILE = $(lastword $(filter %Android.mk,$(MAKEFILE_LIST)))
+
+# local-makefile is the current Makefile being loaded.
+local-makefile = $(NDK_LAST_MAKEFILE)
+
+# Make NDK_BUILD_DIR absolute.
+NDK_BUILD_DIR := $(absname $(NDK_BUILD_DIR))
+
+# Make EMACS_SRCDIR absolute. This must be absolute, or nested
+# Android.mk files will not be able to find CLEAR_VARS.
+EMACS_SRCDIR := $(absname $(EMACS_SRCDIR))
+
+# my-dir is a function that returns the Android module directory. If
+# no Android.mk has been loaded, use ANDROID_MODULE_DIRECTORY.
+my-dir = $(or $(and $(local-makefile),$(dir $(local-makefile))),$(ANDROID_MODULE_DIRECTORY))
+
+# Return all Android.mk files under the first arg.
+all-makefiles-under = $(wildcard $(1)/*/Android.mk)
+
+# Return all Android.mk files in subdirectories of this Makefile's
+# location.
+all-subdir-makefiles = $(call all-makefiles-under,$(call my-dir))
+
+# These functions are not implemented.
+parent-makefile =
+grand-parent-makefile =
+
+NDK_IMPORTS :=
+
+# Add the specified module (arg 1) to NDK_IMPORTS.
+import-module = $(eval NDK_IMPORTS += $(1))
+
+# Print out module information every time BUILD_SHARED_LIBRARY is
+# called.
+
+BUILD_SHARED_LIBRARY=$(BUILD_AUXDIR)ndk-build-helper-1.mk
+BUILD_STATIC_LIBRARY=$(BUILD_AUXDIR)ndk-build-helper-2.mk
+BUILD_EXECUTABLE=$(BUILD_AUXDIR)ndk-build-helper-3.mk
+CLEAR_VARS=$(BUILD_AUXDIR)ndk-build-helper-4.mk
+
+# Now include Android.mk.
+
+include $(ANDROID_MAKEFILE)
+
+# Finally, print out the imports.
+$(info Start Imports)
+$(info $(NDK_IMPORTS))
+$(info End Imports)
+
+# Dummy target.
+all:
diff --git a/build-aux/ndk-module-extract.awk b/build-aux/ndk-module-extract.awk
new file mode 100644
index 00000000000..6ff30973d67
--- /dev/null
+++ b/build-aux/ndk-module-extract.awk
@@ -0,0 +1,88 @@
+/^Building.+$/ {
+ kind = $2
+}
+
+/^Start Imports$/ {
+ imports = 1
+}
+
+// {
+ if (imports && ++imports > 2)
+ {
+ if (!match ($0, /^End Imports$/))
+ makefile_imports = makefile_imports " " $0
+ }
+ else if (!match ($0, /^End$/) && !match ($0, /^Building.+$/))
+ {
+ if (kind)
+ {
+ if (target_found)
+ cxx_deps = $0
+ else if (ldflags_found)
+ {
+ target = $0
+ target_found = 1
+ }
+ else if (cflags_found)
+ {
+ ldflags = $0
+ ldflags_found = 1
+ }
+ else if (includes_found)
+ {
+ cflags = $0
+ cflags_found = 1
+ }
+ else if (src_found)
+ {
+ includes = $0
+ includes_found = 1
+ }
+ else if (name_found)
+ {
+ src = $0
+ src_found = 1;
+ }
+ else
+ {
+ name = $0
+ name_found = 1
+ }
+ }
+ }
+}
+
+/^End$/ {
+ if (name == MODULE && (kind == "shared" || kind == "static"))
+ {
+ printf "module_name=%s\n", name
+ printf "module_kind=%s\n", kind
+ printf "module_src=\"%s\"\n", src
+ printf "module_includes=\"%s\"\n", includes
+ printf "module_cflags=\"%s\"\n", cflags
+ printf "module_ldflags=\"%s\"\n", ldflags
+ printf "module_target=\"%s\"\n", target
+ printf "module_cxx_deps=\"%s\"\n", cxx_deps
+ }
+
+ src = ""
+ name = ""
+ kind = ""
+ includes = ""
+ cflags = ""
+ ldflags = ""
+ name_found = ""
+ src_found = ""
+ includes_found = ""
+ cflags_found = ""
+ ldflags_found = ""
+ target_found = ""
+}
+
+/^End Imports$/ {
+ imports = ""
+ # Strip off leading whitespace.
+ gsub (/^[ \t]+/, "", makefile_imports)
+ printf "module_imports=\"%s\"\n", makefile_imports
+ makefile_imports = ""
+}
diff --git a/build-aux/update-copyright b/build-aux/update-copyright
index 6cf50d14e53..ea3e46fe60f 100755
--- a/build-aux/update-copyright
+++ b/build-aux/update-copyright
@@ -98,7 +98,8 @@
# 6. Blank lines, even if preceded by the prefix, do not appear
# within the FSF copyright statement.
# 7. Each copyright year is 2 or 4 digits, and years are separated by
-# commas, "-", or "--". Whitespace may appear after commas.
+# commas, "-", "--", or "\(en" (for troff). Whitespace may appear
+# after commas.
#
# Environment variables:
#
@@ -122,7 +123,7 @@
# 5. Set UPDATE_COPYRIGHT_HOLDER if the copyright holder is other
# than "Free Software Foundation, Inc.".
-# This is a prologue that allows to run a perl script as an executable
+# This is a prologue that allows running a perl script as an executable
# on systems that are compliant to a POSIX version before POSIX:2017.
# On such systems, the usual invocation of an executable through execlp()
# or execvp() fails with ENOEXEC if it is a script that does not start
@@ -137,7 +138,7 @@
eval 'exec perl -wSx -0777 -pi "$0" "$@"'
if 0;
-my $VERSION = '2020-04-04.15:07'; # UTC
+my $VERSION = '2024-01-15.18:30'; # UTC
# The definition above must lie within the first 8 lines in order
# for the Emacs time-stamp write hook (at end) to update it.
# If you change this file with Emacs, please let the write hook
@@ -145,9 +146,11 @@ my $VERSION = '2020-04-04.15:07'; # UTC
use strict;
use warnings;
+use re 'eval';
my $copyright_re = 'Copyright';
my $circle_c_re = '(?:\([cC]\)|@copyright\{}|\\\\\(co|&copy;|©)';
+my $ndash_re = '(?:--?|\\\\\(en)';
my $holder = $ENV{UPDATE_COPYRIGHT_HOLDER};
$holder ||= 'Free Software Foundation, Inc.';
my $prefix_max = 5;
@@ -167,14 +170,13 @@ if (!$this_year || $this_year !~ m/^\d{4}$/)
# Unless the file consistently uses "\r\n" as the EOL, use "\n" instead.
my $eol = /(?:^|[^\r])\n/ ? "\n" : "\r\n";
-my $leading;
-my $prefix;
-my $ws_re;
my $stmt_re;
-while (/(^|\n)(.{0,$prefix_max})$copyright_re/g)
+my $found;
+while (/(^|\n)(.{0,$prefix_max})$copyright_re/cg)
{
- $leading = "$1$2";
- $prefix = $2;
+ my $pos=pos();
+ my $leading = "$1$2";
+ my $prefix = $2;
if ($prefix =~ /^(\s*\/)\*(\s*)$/)
{
$prefix =~ s,/, ,;
@@ -185,105 +187,108 @@ while (/(^|\n)(.{0,$prefix_max})$copyright_re/g)
$prefix = $prefix_ws;
}
}
- $ws_re = '[ \t\r\f]'; # \s without \n
+ my $ws_re = '[ \t\r\f]'; # \s without \n
$ws_re =
"(?:$ws_re*(?:$ws_re|\\n" . quotemeta($prefix) . ")$ws_re*)";
my $holder_re = $holder;
$holder_re =~ s/\s/$ws_re/g;
my $stmt_remainder_re =
"(?:$ws_re$circle_c_re)?"
- . "$ws_re(?:(?:\\d\\d)?\\d\\d(?:,$ws_re?|--?))*"
+ . "$ws_re(?:(?:\\d\\d)?\\d\\d(?:,$ws_re?|$ndash_re))*"
. "((?:\\d\\d)?\\d\\d)$ws_re$holder_re";
if (/\G$stmt_remainder_re/)
{
+ $found = 1;
$stmt_re =
quotemeta($leading) . "($copyright_re$stmt_remainder_re)";
- last;
- }
- }
-if (defined $stmt_re)
- {
- /$stmt_re/ or die; # Should never die.
- my $stmt = $1;
- my $final_year_orig = $2;
- # Handle two-digit year numbers like "98" and "99".
- my $final_year = $final_year_orig;
- $final_year <= 99
- and $final_year += 1900;
+ /$stmt_re/ or die; # Should never die.
+ my $stmt = $1;
+ my $final_year_orig = $2;
- if ($final_year != $this_year)
- {
- # Update the year.
- $stmt =~ s/\b$final_year_orig\b/$final_year, $this_year/;
- }
- if ($final_year != $this_year || $ENV{'UPDATE_COPYRIGHT_FORCE'})
- {
- # Normalize all whitespace including newline-prefix sequences.
- $stmt =~ s/$ws_re/ /g;
+ # Handle two-digit year numbers like "98" and "99".
+ my $final_year = $final_year_orig;
+ $final_year <= 99
+ and $final_year += 1900;
- # Put spaces after commas.
- $stmt =~ s/, ?/, /g;
-
- # Convert 2-digit to 4-digit years.
- $stmt =~ s/(\b\d\d\b)/19$1/g;
-
- # Make the use of intervals consistent.
- if (!$ENV{UPDATE_COPYRIGHT_USE_INTERVALS})
+ if ($final_year != $this_year)
{
- $stmt =~ s/(\d{4})--?(\d{4})/join(', ', $1..$2)/eg;
+ # Update the year.
+ $stmt =~ s/(^|[^\d])$final_year_orig\b/$1$final_year, $this_year/;
}
- else
+ if ($final_year != $this_year || $ENV{'UPDATE_COPYRIGHT_FORCE'})
{
- my $ndash = $ARGV =~ /\.tex(i(nfo)?)?$/ ? "--" : "-";
+ # Normalize all whitespace including newline-prefix sequences.
+ $stmt =~ s/$ws_re/ /g;
- $stmt =~
- s/
- (\d{4})
- (?:
- (,\ |--?)
- ((??{
- if ($2 ne ', ') { '\d{4}'; }
- elsif (!$3) { $1 + 1; }
- else { $3 + 1; }
- }))
- )+
- /$1$ndash$3/gx;
+ # Put spaces after commas.
+ $stmt =~ s/, ?/, /g;
- # When it's 2, emit a single range encompassing all year numbers.
- $ENV{UPDATE_COPYRIGHT_USE_INTERVALS} == 2
- and $stmt =~ s/\b(\d{4})\b.*\b(\d{4})\b/$1$ndash$2/;
- }
+ # Convert 2-digit to 4-digit years.
+ $stmt =~ s/(\b\d\d\b)/19$1/g;
- # Format within margin.
- my $stmt_wrapped;
- my $text_margin = $margin - length($prefix);
- if ($prefix =~ /^(\t+)/)
- {
- $text_margin -= length($1) * ($tab_width - 1);
- }
- while (length $stmt)
- {
- if (($stmt =~ s/^(.{1,$text_margin})(?: |$)//)
- || ($stmt =~ s/^([\S]+)(?: |$)//))
+ # Make the use of intervals consistent.
+ if (!$ENV{UPDATE_COPYRIGHT_USE_INTERVALS})
{
- my $line = $1;
- $stmt_wrapped .= $stmt_wrapped ? "$eol$prefix" : $leading;
- $stmt_wrapped .= $line;
+ $stmt =~ s/(\d{4})$ndash_re(\d{4})/join(', ', $1..$2)/eg;
}
else
{
- # Should be unreachable, but we don't want an infinite
- # loop if it can be reached.
- die;
+ my $ndash = ($ARGV =~ /\.tex(i(nfo)?)?$/ ? "--"
+ : $ARGV =~ /\.(\d[a-z]*|man)$/ ? "\\(en"
+ : "-");
+
+ $stmt =~
+ s/
+ (\d{4})
+ (?:
+ (,\ |$ndash_re)
+ ((??{
+ if ($2 ne ', ') { '\d{4}'; }
+ elsif (!$3) { $1 + 1; }
+ else { $3 + 1; }
+ }))
+ )+
+ /$1$ndash$3/gx;
+
+ # When it's 2, emit a single range encompassing all year numbers.
+ $ENV{UPDATE_COPYRIGHT_USE_INTERVALS} == 2
+ and $stmt =~ s/(^|[^\d])(\d{4})\b.*(?:[^\d])(\d{4})\b/$1$2$ndash$3/;
}
- }
- # Replace the old copyright statement.
- s/$stmt_re/$stmt_wrapped/;
+ # Format within margin.
+ my $stmt_wrapped;
+ my $text_margin = $margin - length($prefix);
+ if ($prefix =~ /^(\t+)/)
+ {
+ $text_margin -= length($1) * ($tab_width - 1);
+ }
+ while (length $stmt)
+ {
+ if (($stmt =~ s/^(.{1,$text_margin})(?: |$)//)
+ || ($stmt =~ s/^([\S]+)(?: |$)//))
+ {
+ my $line = $1;
+ $stmt_wrapped .= $stmt_wrapped ? "$eol$prefix" : $leading;
+ $stmt_wrapped .= $line;
+ }
+ else
+ {
+ # Should be unreachable, but we don't want an infinite
+ # loop if it can be reached.
+ die;
+ }
+ }
+
+ # Replace the old copyright statement.
+ my $p = pos();
+ s/$stmt_re/$stmt_wrapped/g;
+ pos() = $p;
+ }
}
}
-else
+
+if (!$found)
{
print STDERR "$ARGV: warning: copyright statement not found\n";
}
diff --git a/configure.ac b/configure.ac
index f2a7463dfe8..bd678ea52a3 100644
--- a/configure.ac
+++ b/configure.ac
@@ -23,9 +23,28 @@ dnl along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>.
AC_PREREQ([2.65])
dnl Note this is parsed by (at least) make-dist and lisp/cedet/ede/emacs.el.
-AC_INIT([GNU Emacs], [29.3.50], [bug-gnu-emacs@gnu.org], [],
+AC_INIT([GNU Emacs], [30.0.50], [bug-gnu-emacs@gnu.org], [],
[https://www.gnu.org/software/emacs/])
+if test "$XCONFIGURE" = "android"; then
+ # configure is being called recursively to configure Emacs for
+ # Android!
+ AC_MSG_NOTICE([called to recursively configure Emacs for Android.])
+ # Set CC to ANDROID_CC and CFLAGS to ANDROID_CFLAGS.
+ CC=$ANDROID_CC
+ # Set -Wno-implicit-function-declaration. Building Emacs for older
+ # versions of Android requires configure tests to fail if the
+ # functions are not defined, as the Android library in the NDK
+ # defines subroutines that are not available in the headers being
+ # used.
+ CFLAGS="$ANDROID_CFLAGS -Werror=implicit-function-declaration"
+ # Don't explicitly enable support for large files unless Emacs is
+ # being built for API 21 or later. Otherwise, mmap does not work.
+ AS_IF([test "$ANDROID_SDK" -lt "21"], [
+ enable_largefile=no
+ enable_year2038=no])
+fi
+
dnl Set emacs_config_options to the options of 'configure', quoted for the shell,
dnl and then quoted again for a C string. Separate options with spaces.
dnl Add some environment variables, if they were passed via the environment
@@ -126,7 +145,63 @@ MAKE=$ac_cv_path_MAKE
export MAKE
dnl Canonicalize the configuration name.
+if test "$XCONFIGURE" = "android"; then
+ dnl Set host to whatever Android system Emacs is being configured
+ dnl for. Determine this by looking at the output of ANDROID_CC.
+
+ AC_MSG_CHECKING([the cross-compiler's target])
+ cc_target=`${CC} -v 2>&1 | sed -n 's/Target: //p'`
+ case "$cc_target" in
+ *android*) host_alias=$cc_target
+ ;;
+ *) AC_MSG_ERROR([The cross compiler does not compile for Android.
+Please verify that you specified the correct compiler in the ANDROID_CC
+variable when you ran configure.])
+ ;;
+ esac
+ AC_MSG_RESULT([$host_alias])
+fi
+
AC_CANONICAL_HOST
+AC_CANONICAL_BUILD
+
+AS_IF([test "$XCONFIGURE" = "android"],[
+ # Initialize the Android NDK build system. Make sure to use the
+ # passed through NDK path.
+ # Make sure to pass through the CFLAGS, as older versions of the
+ # NDK require them to be able to find system includes.
+ with_ndk_path="$android_ndk_path"
+ with_ndk_cxx="$android_ndk_cxx"
+ ndk_INIT([$android_abi], [$ANDROID_SDK], [cross/ndk-build],
+ [$ANDROID_CFLAGS])
+
+ # At the same time, configure libexec with the build directory
+ # set to `exec'.
+ AS_MKDIR_P([exec])
+
+ # Enter exec and configure it, using the C compiler as both the
+ # assembler and the linker. Determine the absolute name of the
+ # source directory.
+ # N.B. that the linker is actually cc, so pass -nostdlib, lest
+ # the crt be linked in. Likewise for as.
+
+ AS_CASE([$srcdir], [.], [emacs_srcdir=`pwd`],
+ [[[\\/]* | ?:[\\/]*]], [emacs_srcdir=$srcdir],
+ [*], [emacs_srcdir=`pwd`/$srcdir])
+
+ AC_MSG_NOTICE([configuring in `exec'])
+
+ OLDCWD=`pwd`
+ cd exec
+ $CONFIG_SHELL $emacs_srcdir/exec/configure \
+ --host=$host "CC=$CC" "LD=$CC" "AS=$CC" \
+ "AR=$AR" "CFLAGS=$CFLAGS"
+ emacs_val=$?
+ cd $OLDCWD
+
+ AS_IF([test "$emacs_val" != "0"],
+ [AC_MSG_ERROR([failed to configure in `exec'])])
+])
case $host in
*-mingw*)
@@ -207,6 +282,13 @@ AC_ARG_WITH([all],
[with_features=$withval],
[with_features=yes])
+dnl ARCH_INDEPENDENT_CONFIG_FILES(FILE...)
+dnl Like AC_CONFIG_FILES(FILE). However, do not generate this
+dnl if configure is being called recursively in preparation
+dnl for cross-compilation.
+AC_DEFUN([ARCH_INDEPENDENT_CONFIG_FILES], [
+ AS_IF([test "$XCONFIGURE" != "android"], [AC_CONFIG_FILES([$1])])])
+
dnl OPTION_DEFAULT_OFF(NAME, HELP-STRING)
dnl Create a new --with option that defaults to being disabled.
dnl NAME is the base name of the option. The shell variable with_NAME
@@ -222,7 +304,8 @@ AC_DEFUN([OPTION_DEFAULT_OFF], [dnl
])dnl
dnl OPTION_DEFAULT_IFAVAILABLE(NAME, HELP-STRING)
-dnl Create a new --with option that defaults to 'ifavailable'.
+dnl Create a new --with option that defaults to 'ifavailable',
+dnl unless it is overridden by $with_features being equal to 'no'.
dnl NAME is the base name of the option. The shell variable with_NAME
dnl will be set to either the user's value (if the option is
dnl specified; 'yes' for a plain --with-NAME) or to 'ifavailable' (if the
@@ -232,10 +315,12 @@ dnl characters with "_".
dnl HELP-STRING is the help text for the option.
AC_DEFUN([OPTION_DEFAULT_IFAVAILABLE], [dnl
AC_ARG_WITH([$1],[AS_HELP_STRING([--with-$1],[$2])],[],[dnl
- m4_bpatsubst([with_$1], [[^0-9a-z]], [_])=ifavailable])dnl
+ AS_IF([test "$with_features" != no],
+ [m4_bpatsubst([with_$1], [[^0-9a-z]], [_])=ifavailable],
+ [m4_bpatsubst([with_$1], [[^0-9a-z]], [_])=no])dnl
+ ])dnl
])dnl
-
dnl OPTION_DEFAULT_ON(NAME, HELP-STRING)
dnl Create a new --with option that defaults to $with_features.
dnl NAME is the base name of the option. The shell variable with_NAME
@@ -259,25 +344,25 @@ AC_ARG_WITH([mailutils],
options are irrelevant; this is the default if GNU Mailutils is
installed])],
[],
- [with_mailutils=$with_features
- if test "$with_mailutils" = yes; then
- (movemail --version) >/dev/null 2>&1 || with_mailutils=no
- fi])
-if test "$with_mailutils" = no; then
- with_mailutils=
-fi
-AC_SUBST([with_mailutils])
+ [AS_IF([test "$with_features" != "no"],
+ [with_mailutils=yes-unless-android
+ AS_IF([test "x$XCONFIGURE" != "xandroid"],
+ [(movemail --version) >/dev/null 2>&1 || with_mailutils=no],
+ [dnl Don't check for movemail if cross-compiling.
+ dnl instead, default to false.
+ with_mailutils=no])])])
AC_ARG_WITH([pop],
[AS_HELP_STRING([--with-pop],
[Support POP mail retrieval if Emacs movemail is used (not recommended,
as Emacs movemail POP is insecure). This is the default only on
- native MS-Windows.])],
+ native MS-Windows and Android.])],
[],
- [case $host in
- *-mingw*) with_pop=yes;;
- *) with_pop=no-by-default;;
- esac])
+ dnl Enable movemail POP support on Android as GNU Mailutils is
+ dnl normally unavailable on that platform.
+ [AS_CASE([$host],
+ [*-mingw*|*android*], [with_pop=yes],
+ [with_pop=no-by-default])])
if test "$with_pop" = yes; then
AC_DEFINE([MAIL_USE_POP])
fi
@@ -499,6 +584,31 @@ OPTION_DEFAULT_ON([threads],[don't compile with elisp threading support])
OPTION_DEFAULT_OFF([cygwin32-native-compilation],[use native compilation on 32-bit Cygwin])
OPTION_DEFAULT_ON([xinput2],[don't use version 2 of the X Input Extension for input])
OPTION_DEFAULT_OFF([small-ja-dic],[generate a smaller-size Japanese dictionary])
+OPTION_DEFAULT_OFF([android],[cross-compile Android application package])
+OPTION_DEFAULT_ON([android-debug],[don't build Emacs as a debug package on Android])
+
+# Find out of Android support is enabled and mailutils has defaulted
+# to `yes-unless-android'. Disable it if so.
+
+AS_IF([test "x$with_mailutils" = "xyes-unless-android"],
+ [AS_IF([test "x$with_android" != "xno"],
+ [with_mailutils=no],
+ [with_mailutils=yes])])
+
+# Clear with_mailutils if it's set to no.
+
+AS_IF([test "$with_mailutils" = no],
+ [with_mailutils=])
+
+AS_IF([test x"$with_mailutils" = xyes],
+ [AC_DEFINE([HAVE_MAILUTILS], [1],
+ [Define to 1 if Emacs was configured with mailutils])])
+
+AC_SUBST([with_mailutils])
+
+AC_ARG_WITH([shared-user-id],
+ [AS_HELP_STRING([--with-shared-user-id=ID],
+ [use the given shared user ID in Android builds])])
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)])],
@@ -615,37 +725,51 @@ do
done
IFS="$ac_save_IFS"
-if test x$ac_enable_checking != x ; then
- AC_DEFINE([ENABLE_CHECKING], [1],
-[Define to 1 if expensive run-time data type and consistency checks are enabled.])
-fi
-if $CHECK_STRUCTS; then
- AC_DEFINE([CHECK_STRUCTS], [1],
- [Define this to check whether someone updated the portable dumper
- code after changing the layout of a structure that it uses.
- If you change one of these structures, check that the pdumper.c
- code is still valid, and update the pertinent hash in pdumper.c
- by manually copying the hash from the newly-generated dmpstruct.h.])
-fi
-AC_SUBST([CHECK_STRUCTS])
-if test x$ac_gc_check_stringbytes != x ; then
- AC_DEFINE([GC_CHECK_STRING_BYTES], [1],
-[Define this temporarily to hunt a bug. If defined, the size of
- strings is redundantly recorded in sdata structures so that it can
- be compared to the sizes recorded in Lisp strings.])
-fi
-if test x$ac_gc_check_string_overrun != x ; then
- AC_DEFINE([GC_CHECK_STRING_OVERRUN], [1],
-[Define this to check for short string overrun.])
-fi
-if test x$ac_gc_check_string_free_list != x ; then
- AC_DEFINE([GC_CHECK_STRING_FREE_LIST], [1],
-[Define this to check the string free list.])
-fi
-if test x$ac_glyphs_debug != x ; then
- AC_DEFINE([GLYPH_DEBUG], [1],
-[Define this to enable glyphs debugging code.])
-fi
+# This environment variable is used to signal that checking should be
+# enabled on Android. When that happens, simply enable checking for
+# the cross-compiled Android binary.
+
+AS_IF([test "x$XCONFIGURE" = "xandroid" \
+ && test "x$android_enable_checking" = "xyes"],
+ [ac_enable_checking=yes])
+
+# There is little point in enabling checking in the build machine if
+# cross-compiling for Android.
+AS_IF([test "$with_android" = no || test -n "$XCONFIGURE"],[
+ if test x$ac_enable_checking != x ; then
+ AC_DEFINE([ENABLE_CHECKING], [1],
+ [Define to 1 if expensive run-time data type and consistency checks are enabled.])
+ fi
+ if $CHECK_STRUCTS; then
+ AC_DEFINE([CHECK_STRUCTS], [1],
+ [Define this to check whether someone updated the portable dumper
+ code after changing the layout of a structure that it uses.
+ If you change one of these structures, check that the pdumper.c
+ code is still valid, and update the pertinent hash in pdumper.c
+ by manually copying the hash from the newly-generated dmpstruct.h.])
+ fi
+ AC_SUBST([CHECK_STRUCTS])
+ if test x$ac_gc_check_stringbytes != x ; then
+ AC_DEFINE([GC_CHECK_STRING_BYTES], [1],
+ [Define this temporarily to hunt a bug. If defined, the size of
+ strings is redundantly recorded in sdata structures so that it can
+ be compared to the sizes recorded in Lisp strings.])
+ fi
+ if test x$ac_gc_check_string_overrun != x ; then
+ AC_DEFINE([GC_CHECK_STRING_OVERRUN], [1],
+ [Define this to check for short string overrun.])
+ fi
+ if test x$ac_gc_check_string_free_list != x ; then
+ AC_DEFINE([GC_CHECK_STRING_FREE_LIST], [1],
+ [Define this to check the string free list.])
+ fi
+ if test x$ac_glyphs_debug != x ; then
+ AC_DEFINE([GLYPH_DEBUG], [1],
+ [Define this to enable glyphs debugging code.])
+ fi
+],[AS_IF([test "x$ac_enable_checking" != x],
+ [android_enable_checking=yes
+ export android_enable_checking])])
dnl The name of this option is unfortunate. It predates, and has no
dnl relation to, the "sampling-based elisp profiler" added in 24.3.
@@ -683,6 +807,535 @@ AC_ARG_ENABLE([build-details],
[test "$enableval" = no && BUILD_DETAILS=--no-build-details])
AC_SUBST([BUILD_DETAILS])
+# JAVA_PUSH_LINT(OPT)
+# -------------------
+# Check if javac supports the diagnostic flag -Xlint:OPT.
+# If it does, add it to WARN_JAVAFLAGS.
+
+AC_DEFUN([JAVA_PUSH_LINT],
+[
+ AC_CACHE_CHECK([whether Java compiler accepts -Xlint:$1],
+ [emacs_cv_javac_knows_lint_$1],
+ AS_IF([rm -f conftest.class
+cat << EOF > conftest.java
+
+class conftest
+{
+
+}
+
+EOF
+("$JAVAC" -Xlint:$1 conftest.java 2>&AS_MESSAGE_LOG_FD) \
+ && rm -f conftest.class], [emacs_cv_javac_knows_lint_$1=yes],
+ [emacs_cv_javac_knows_lint_$1=no]))
+
+ AS_IF([test "$emacs_cv_javac_knows_lint_$1" = "yes"],
+ [WARN_JAVAFLAGS="$WARN_JAVAFLAGS -Xlint:$1"])
+])
+
+# Start Android configuration. This is done in three steps:
+
+# First, the SDK tools needed to build the Android package on the host
+# are found.
+
+# Then, configure is called inside itself with the NDK C and C++
+# compilers, and the Makefiles generated, along with config.h, are
+# renamed to end with .android.
+
+# Finally, configure continues to configure the Emacs binary that will
+# run on the host.
+
+ANDROID=
+JAVAC=
+AAPT=
+JARSIGNER=
+APKSIGNER=
+ZIPALIGN=
+DX=
+ANDROID_JAR=
+ANDROID_ABI=
+WARN_JAVAFLAGS=
+ANDROID_SHARED_USER_ID=
+ANDROID_SHARED_USER_NAME=
+
+# This is a list of Makefiles that have alternative versions for
+# Android.
+android_makefiles="lib/Makefile lib/gnulib.mk lib-src/Makefile src/Makefile"
+
+# This is whether or not to package mailutils into the executable.
+emacs_use_mailutils=
+
+AC_ARG_VAR([ANDROID_CC], [The Android C cross-compiler.])
+AC_ARG_VAR([SDK_BUILD_TOOLS], [Name of directory holding Android SDK build-tools.])
+AC_ARG_VAR([ANDROID_CFLAGS], [Flags given to the Android C cross-compiler.])
+AC_ARG_VAR([JAVAC], [Java compiler path. Used for Android.])
+AC_ARG_VAR([JARSIGNER], [Java package signer path. Used for Android.])
+AC_ARG_VAR([APKSIGNER], [Android package signer path. Used for Android.])
+AC_ARG_VAR([SDK_BUILD_TOOLS], [Path to the Android SDK build tools.])
+
+if test "$with_android" = "yes"; then
+ AC_MSG_ERROR([Please specify the path to the Android.jar file, like so:
+
+ ./configure --with-android=/path/to/android.jar
+
+along with the path to the SDK build-tools (this is the directory with
+tools such as aapt, dx, and aidl):
+
+ SDK_BUILD_TOOLS=/path/to/sdk-build-tools
+
+The cross-compiler should then be specified:
+
+ ANDROID_CC=/path/to/armv7a-linux-androideabi19-clang
+
+In addition, you may pass any special arguments to the cross-compiler
+via the ANDROID_CFLAGS environment variable.])
+elif test "$with_android" = "no" || test "$with_android" = ""; then
+ ANDROID=no
+else
+ AC_CHECK_PROGS([JAVAC], [javac])
+ if test "$JAVAC" = ""; then
+ AC_MSG_ERROR([The Java compiler required to build Emacs was not found.
+Please make sure `javac' can be found on your path, or alternatively specify
+the path to your Java compiler before configuring Emacs, like so:
+
+ JAVAC=/opt/jdk/bin/javac ./configure --with-android])
+ fi
+
+ AC_CHECK_PROGS([JARSIGNER], [jarsigner])
+ if test "$JARSIGNER" = ""; then
+ AC_MSG_ERROR([The Java package signing utility was not found.
+Please make sure `jarsigner' can be found on your path, or alternatively
+specify its location before configuring Emacs, like so:
+
+ JARSIGNER=/opt/jdk/bin/jarsigner ./configure --with-android])
+ fi
+
+ AC_CACHE_CHECK([whether the Java compiler works],
+ [emacs_cv_working_javac],
+ AS_IF([rm -f conftest.class
+cat << EOF > conftest.java
+
+import android.app.Activity;
+import android.os.Bundle;
+
+class conftest extends Activity
+{
+ @Override
+ public void
+ onCreate (Bundle savedInstanceState)
+ {
+ super.onCreate (savedInstanceState);
+ }
+}
+
+EOF
+("$JAVAC" -classpath "$with_android" -target 1.7 -source 1.7 conftest.java \
+ -d . >&AS_MESSAGE_LOG_FD 2>&1) && test -s conftest.class && rm -f conftest.class],
+ [emacs_cv_working_javac=yes],
+ [emacs_cv_working_javac=no]))
+
+ if test "$emacs_cv_working_javac" = "no"; then
+ AC_MSG_ERROR([The Java compiler does not work, or you did not specify
+a valid path to android.jar. See config.log for more details.])
+ fi
+
+ AC_CACHE_CHECK([whether android.jar is new enough],
+ [emacs_cv_android_u_or_later],
+ AS_IF([rm -f conftest.class
+cat << EOF > conftest.java
+
+import android.os.Build;
+
+class conftest
+{
+ private static int test = Build.VERSION_CODES.UPSIDE_DOWN_CAKE;
+}
+
+EOF
+("$JAVAC" -classpath "$with_android" -target 1.7 -source 1.7 conftest.java \
+ -d . >&AS_MESSAGE_LOG_FD 2>&1) && test -s conftest.class && rm -f conftest.class],
+ [emacs_cv_android_u_or_later=yes],
+ [emacs_cv_android_u_or_later=no]))
+
+ if test "$emacs_cv_android_u_or_later" = "no"; then
+ AC_MSG_ERROR([Emacs must be built with an android.jar file produced for \
+Android 14 (Upside Down Cake) or later.])
+ fi
+
+ dnl See if the Java compiler supports the `--release' option which
+ dnl makes it check for and prevent using features introduced after
+ dnl Java 1.7.
+
+ AC_CACHE_CHECK([whether javac accepts --release 7],
+ [emacs_cv_javac_release_7], AS_IF([rm -f conftest.class
+cat << EOF > conftest.java
+
+class conftest
+{
+
+}
+
+EOF
+("$JAVAC" --release 7 conftest.java 2>&AS_MESSAGE_LOG_FD) \
+ && rm -f conftest.class],
+ [emacs_cv_javac_release_7=yes],
+ [emacs_cv_javac_release_7=no]))
+
+ if test "$emacs_cv_javac_release_7" = "yes"; then
+ WARN_JAVAFLAGS="$WARN_JAVAFLAGS --release 7"
+ else
+ dnl If not, just make sure the generated bytecode is correct.
+ WARN_JAVAFLAGS="$WARN_JAVAFLAGS -target 1.7 -source 1.7"
+ fi
+
+ dnl Enable some useful Java linting options.
+ JAVA_PUSH_LINT([deprecation])
+ JAVA_PUSH_LINT([cast])
+ JAVA_PUSH_LINT([divzero])
+ JAVA_PUSH_LINT([nonempty])
+ JAVA_PUSH_LINT([empty])
+ JAVA_PUSH_LINT([finally])
+ JAVA_PUSH_LINT([overrides])
+ JAVA_PUSH_LINT([path])
+ JAVA_PUSH_LINT([serial])
+ JAVA_PUSH_LINT([unchecked])
+
+ # Get the name of the android.jar file.
+ ANDROID_JAR="$with_android"
+
+ # Substitute this into java/Makefile.
+ AC_SUBST([WARN_JAVAFLAGS])
+
+ AC_PATH_PROGS([AAPT], [aapt], [], "${SDK_BUILD_TOOLS}:$PATH")
+ if test "$AAPT" = ""; then
+ AC_MSG_ERROR([The Android asset packaging tool was not found.
+Please verify that the path to the SDK build tools you specified is correct])
+ fi
+
+ AC_PATH_PROGS([APKSIGNER], [apksigner], [], "${SDK_BUILD_TOOLS}:$PATH")
+ if test "$APKSIGNER" = ""; then
+ AC_MSG_ERROR([The Android package signing tool was not found.
+Please verify that the path to the SDK build tools you specified is correct])
+ fi
+
+ AC_PATH_PROGS([D8], [d8], [], "${SDK_BUILD_TOOLS}:$PATH")
+ if test "D8" = ""; then
+ AC_MSG_ERROR([The Android dexer was not found.
+Please verify that the path to the SDK build tools you specified is correct])
+ fi
+
+ AC_PATH_PROGS([ZIPALIGN], [zipalign], [], "${SDK_BUILD_TOOLS}:$PATH")
+ if test "ZIPALIGN" = ""; then
+ AC_MSG_ERROR([The Android ZIP archive alignment utility was not found.
+Please verify that the path to the SDK build tools you specified is correct]);
+ fi
+
+ dnl Now configure Emacs to generate binaries for Android. After the
+ dnl configuration completes, move the generated Makefiles.
+
+ if test "$ANDROID_CC" = ""; then
+ AC_MSG_ERROR([Please specify the path to the Android cross-compiler
+for your machine. For example:
+
+ ANDROID_CC=/path/to/armv7a-linux-androideabi19-clang \\
+ ./configure --with-android])
+ fi
+
+ dnl Obtain the cross compiler's target to find out where binaries go
+ dnl in the resulting package.
+
+ AC_MSG_CHECKING([for the kind of Android system Emacs is being built for])
+ cc_target=`${ANDROID_CC} -v 2>&1 | sed -n 's/Target: //p'`
+ case "$cc_target" in
+[
+ *i[3-6]86*) android_abi=x86
+ ;;
+ *x86_64*) android_abi=x86_64
+ ;;
+ *aarch64*) android_abi=arm64-v8a
+ ;;
+ *arm*v7a*) android_abi=armeabi-v7a
+ ;;
+ *mips64*) android_abi=mips64
+ ;;
+ *mips*) android_abi=mips
+ ;;
+ *arm*) android_abi=armeabi
+ ;;
+]
+ *) AC_MSG_ERROR([configure could not determine the type of Android \
+binary Emacs is being configured for. Please port this configure script \
+to your Android system, or verify that you specified the correct compiler \
+in the ANDROID_CC variable when you ran configure.
+
+The compiler target is: $cc_target])
+ ;;
+ esac
+ AC_MSG_RESULT([$android_abi])
+
+ ANDROID_ABI=$android_abi
+
+ dnl Obtain the minimum SDK version of the resulting Emacs binary
+ dnl built with this NDK.
+
+ ANDROID_MIN_SDK=8
+ AC_MSG_CHECKING([for the lowest Android version Emacs can run on])
+ [android_sdk=`echo "$cc_target" | grep -oE 'android([0-9][0-9]?)'`]
+
+ if test -n "$android_sdk"; then
+ android_sdk=`echo "$android_sdk" | sed -n 's/android//p'`
+ AC_MSG_RESULT([$android_sdk])
+ ANDROID_MIN_SDK=$android_sdk
+ else
+ # This is probably GCC.
+ [ cat << EOF > conftest.c
+#include <android/api-level.h>
+extern const char *foo;
+
+int
+main (void)
+{
+#if __ANDROID_API__ < 7
+ foo = "emacs_api_6";
+#elif __ANDROID_API__ < 8
+ foo = "emacs_api_7";
+#elif __ANDROID_API__ < 9
+ foo = "emacs_api_8";
+#elif __ANDROID_API__ < 10
+ foo = "emacs_api_9";
+#elif __ANDROID_API__ < 11
+ foo = "emacs_api_10";
+#elif __ANDROID_API__ < 12
+ foo = "emacs_api_11";
+#elif __ANDROID_API__ < 13
+ foo = "emacs_api_12";
+#elif __ANDROID_API__ < 14
+ foo = "emacs_api_13";
+#elif __ANDROID_API__ < 15
+ foo = "emacs_api_14";
+#elif __ANDROID_API__ < 16
+ foo = "emacs_api_15";
+#elif __ANDROID_API__ < 17
+ foo = "emacs_api_16";
+#elif __ANDROID_API__ < 18
+ foo = "emacs_api_17";
+#elif __ANDROID_API__ < 19
+ foo = "emacs_api_18";
+#elif __ANDROID_API__ < 20
+ foo = "emacs_api_19";
+#elif __ANDROID_API__ < 21
+ foo = "emacs_api_20";
+#elif __ANDROID_API__ < 22
+ foo = "emacs_api_21";
+#elif __ANDROID_API__ < 23
+ foo = "emacs_api_22";
+#elif __ANDROID_API__ < 24
+ foo = "emacs_api_23";
+#elif __ANDROID_API__ < 25
+ foo = "emacs_api_24";
+#elif __ANDROID_API__ < 26
+ foo = "emacs_api_25";
+#elif __ANDROID_API__ < 27
+ foo = "emacs_api_26";
+#elif __ANDROID_API__ < 28
+ foo = "emacs_api_27";
+#elif __ANDROID_API__ < 29
+ foo = "emacs_api_28";
+#elif __ANDROID_API__ < 30
+ foo = "emacs_api_29";
+#elif __ANDROID_API__ < 31
+ foo = "emacs_api_30";
+#elif __ANDROID_API__ < 32
+ foo = "emacs_api_31";
+#elif __ANDROID_API__ < 33
+ foo = "emacs_api_32";
+#elif __ANDROID_API__ < 34
+ foo = "emacs_api_33";
+#elif __ANDROID_API__ < 35
+ foo = "emacs_api_34";
+#else
+ foo = "emacs_api_future";
+#endif
+}
+EOF]
+
+ AC_CACHE_VAL([emacs_cv_android_api],
+ [$ANDROID_CC $ANDROID_CFLAGS -c conftest.c -o conftest.o \
+ && emacs_cv_android_api=`grep -ao -E \
+ "emacs_api_([[0-9][0-9]]?|future)" conftest.o`])
+ android_sdk="$emacs_cv_android_api"
+ rm -rf conftest.c conftest.o
+
+ # If this version of the NDK requires __ANDROID_API__ to be
+ # specified, then complain to the user.
+ if test "$android_sdk" = "emacs_api_future"; then
+ AC_MSG_ERROR([The version of Android to build for was not specified.
+You must tell the Android compiler what version of Android to build for,
+by defining the __ANDROID_API__ preprocessor macro in ANDROID_CC, like so:
+
+ ANDROID_CC="/path/to/ndk/arm-linux-android-gcc -D__ANDROID_API__=8"])
+ fi
+
+ if test -n "$android_sdk"; then
+ android_sdk=`echo $android_sdk | sed -n 's/emacs_api_//p'`
+ AC_MSG_RESULT([$android_sdk])
+ ANDROID_MIN_SDK=$android_sdk
+ else
+ AC_MSG_RESULT([unknown ($cc_target); assuming 8])
+ AC_MSG_ERROR([configure could not determine the versions of Android \
+a binary built with this compiler will run on. The generated application \
+package will likely install on older systems but crash on startup.])
+ android_sdk=8
+ fi
+ fi
+ AC_SUBST([ANDROID_MIN_SDK])
+
+ # Now tell java/Makefile if Emacs is being built for Android 4.3 or
+ # earlier.
+ ANDROID_SDK_18_OR_EARLIER=
+ if test "$android_sdk" -le "18"; then
+ ANDROID_SDK_18_OR_EARLIER=yes
+ fi
+ AC_SUBST([ANDROID_SDK_18_OR_EARLIER])
+
+ # Likewise for Android 2.2.
+ ANDROID_SDK_8_OR_EARLIER=
+ if test "$android_sdk" -le "8"; then
+ ANDROID_SDK_8_OR_EARLIER=yes
+ fi
+ AC_SUBST([ANDROID_SDK_8_OR_EARLIER])
+
+ # Save confdefs.h and config.log for now.
+ mv -f confdefs.h _confdefs.h
+ mv -f config.log _config.log
+
+ # Make sure these files are removed upon exit.
+ trap "rm -rf _confdefs.h _config.log" 0
+
+ # Figure out what --with-FOO options to pass through.
+ passthrough="$passthrough --with-png=$with_png"
+ passthrough="$passthrough --with-webp=$with_webp"
+ passthrough="$passthrough --with-gif=$with_gif"
+ passthrough="$passthrough --with-json=$with_json"
+ passthrough="$passthrough --with-jpeg=$with_jpeg"
+ passthrough="$passthrough --with-xml2=$with_xml2"
+ passthrough="$passthrough --with-sqlite3=$with_sqlite3"
+ passthrough="$passthrough --with-gnutls=$with_gnutls"
+ passthrough="$passthrough --with-tiff=$with_tiff"
+ passthrough="$passthrough --with-selinux=$with_selinux"
+ passthrough="$passthrough --with-modules=$with_modules"
+ passthrough="$passthrough --with-tree-sitter=$with_tree_sitter"
+ passthrough="$passthrough --with-imagemagick=$with_imagemagick"
+ passthrough="$passthrough --with-lcms2=$with_lcms2"
+ passthrough="$passthrough --with-mailutils=$with_mailutils"
+ passthrough="$passthrough --with-pop=$with_pop"
+ passthrough="$passthrough --with-harfbuzz=$with_harfbuzz"
+ passthrough="$passthrough --with-threads=$with_threads"
+
+ # Now pass through some checking-related options.
+ emacs_val="--enable-check-lisp-object-type=$enable_check_lisp_object_type"
+ passthrough="$passthrough $emacs_val"
+
+ AS_IF([test "x$with_mailutils" = "xyes"], [emacs_use_mailutils=yes])
+ AC_SUBST([emacs_use_mailutils])
+
+ AS_IF([XCONFIGURE=android ANDROID_CC="$ANDROID_CC" \
+ ANDROID_SDK="$android_sdk" android_abi=$android_abi \
+ android_ndk_path="$with_ndk_path" \
+ android_ndk_cxx="$android_ndk_cxx" \
+ $CONFIG_SHELL $0 $passthrough], [],
+ [AC_MSG_ERROR([Failed to cross-configure Emacs for android.])])
+
+ # Now set ANDROID to yes.
+ ANDROID=yes
+
+ for makefile in $android_makefiles; do
+ AC_MSG_NOTICE([Generating $makefile.android])
+ mv -f "$makefile" "$makefile.android"
+ done
+
+ AC_MSG_NOTICE([Generating src/config.h.android])
+ mv -f src/config.h src/config.h.android
+
+ # Tell AndroidManifest.xml whether or not Emacs should be built
+ # debug.
+ ANDROID_DEBUGGABLE=false
+ if test "$with_android_debug" = "yes"; then
+ ANDROID_DEBUGGABLE=true
+ fi
+ AC_SUBST([ANDROID_DEBUGGABLE])
+
+ # Move confdefs.h back now that the recursive call to configure is
+ # complete.
+ mv -f _confdefs.h confdefs.h
+
+ # Move the Android config.log to config.log.android. */
+ mv -f config.log config.log.android
+
+ # And _config.log back.
+ mv -f _config.log config.log
+fi
+
+AC_SUBST([ANDROID])
+AC_SUBST([JAVAC])
+AC_SUBST([AAPT])
+AC_SUBST([D8])
+AC_SUBST([ZIPALIGN])
+AC_SUBST([ANDROID_JAR])
+AC_SUBST([ANDROID_ABI])
+
+if test "$XCONFIGURE" = "android"; then
+ ANDROID=yes
+
+ # Enable cross compiling.
+ cross_compiling=yes
+fi
+
+AC_SUBST([XCONFIGURE])
+
+if test "$ANDROID" = "yes"; then
+ # When --with-android is specified, almost all build options must be
+ # disabled, both within the recursive invocation of configure and
+ # outside.
+ with_xpm=no
+
+ # Some of these dependencies are now supported within Android, so
+ # they can be enabled.
+ if test "$XCONFIGURE" != "android"; then
+ with_png=no
+ with_webp=no
+ with_gif=no
+ with_json=no
+ with_jpeg=no
+ with_xml2=no
+ with_sqlite3=no
+ with_gnutls=no
+ with_tiff=no
+ with_selinux=no
+ with_modules=no
+ with_tree_sitter=no
+ with_imagemagick=no
+ with_lcms2=no
+ with_mailutils=no
+ with_pop=no
+ with_harfbuzz=no
+ with_native_compilation=no
+ with_threads=no
+ fi
+
+ with_rsvg=no
+ with_libsystemd=no
+ with_cairo=no
+ with_xft=no
+ with_libotf=no
+ with_gpm=no
+ with_dbus=no
+ with_gsettings=no
+ with_ns=no
+
+ # zlib is available in android.
+fi
+
dnl This used to use changequote, but, apart from 'changequote is evil'
dnl per the autoconf manual, we can speed up autoconf somewhat by quoting
dnl the great gob of text. Thus it's not processed for possible expansion.
@@ -706,6 +1359,11 @@ dnl quotation begins
opsys='' unported=no
case "${canonical}" in
+ ## Android
+ *linux-android* )
+ opsys=android
+ ;;
+
## GNU/Linux and similar ports
*-*-linux* )
opsys=gnu-linux
@@ -872,6 +1530,7 @@ AC_DEFUN([_AC_PROG_CC_C89], [$2])
dnl Sets GCC=yes if using gcc.
AC_PROG_CC([gcc cc cl clang "$XCRUN gcc" "$XCRUN clang"])
+
if test -n "$XCRUN"; then
AC_CHECK_PROGS([AR], [ar "$XCRUN ar"])
test -n "$AR" && export AR
@@ -901,11 +1560,22 @@ ac_func_list=$funcs
AC_DEFUN([gt_TYPE_WINT_T],
[GNULIBHEADERS_OVERRIDE_WINT_T=0
AC_SUBST([GNULIBHEADERS_OVERRIDE_WINT_T])])
+# Emacs does not need precise checks for the Solaris 10 MB_CUR_MAX bug.
+AC_DEFUN_ONCE([gl_STDLIB_H],
+ [AC_REQUIRE([gl_STDLIB_H_DEFAULTS])
+ gl_NEXT_HEADERS([stdlib.h])])
# Initialize gnulib right after choosing the compiler.
dnl Amongst other things, this sets AR and ARFLAGS.
gl_EARLY
+# ndk_LATE must be enclosed in this conditional to prevent the
+# AC_PROG_CXX it indirectly requires from being expanded at top level.
+if test "$ndk_INITIALIZED" = "yes"; then
+ ndk_LATE_EARLY
+ ndk_LATE
+fi
+
if test "$ac_test_CFLAGS" != set; then
# It's helpful to have C macros available to GDB, so prefer -g3 to -g
# if -g3 works and the user does not specify CFLAGS.
@@ -1002,13 +1672,13 @@ AC_ARG_ENABLE([gcc-warnings],
# however, if there is also a .tarball-version file it is probably
# just a release imported into Git for patch management.
gl_gcc_warnings=no
- if test -e "$srcdir"/.git && test ! -f "$srcdir"/.tarball-version; then
- # 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])
+ AS_IF([test -d "$srcdir"/.git || test -f "$srcdir"/.git],
+ [AS_IF([test -f "$srcdir"/.tarball-version], [],
+ # 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])])])])])
NATIVE_COMPILATION_AOT=no
AC_ARG_WITH([native-compilation],
@@ -1029,7 +1699,7 @@ AC_ARG_WITH([native-compilation],
*) AC_MSG_ERROR([bad value $withval for native-compilation option]) ;;
esac
with_native_compilation=$withval],
- [with_native_compilation=no]
+ [with_native_compilation=default]
)
AC_SUBST([NATIVE_COMPILATION_AOT])
@@ -1051,7 +1721,6 @@ AS_IF([test $gl_gcc_warnings = no],
AS_IF([test "$emacs_cv_clang" = yes],
[
# Turn off some warnings if supported.
- gl_WARN_ADD([-Wno-switch])
gl_WARN_ADD([-Wno-pointer-sign])
gl_WARN_ADD([-Wno-string-plus-int])
gl_WARN_ADD([-Wno-unknown-attributes])
@@ -1081,7 +1750,7 @@ AS_IF([test $gl_gcc_warnings = no],
nw="$nw -Wcast-align=strict" # Emacs is tricky with pointers.
nw="$nw -Wduplicated-branches" # Too many false alarms
- nw="$nw -Wformat-overflow=2" # False alarms due to GCC bug 80776
+ nw="$nw -Wformat-overflow=2" # False alarms due to GCC bug 110333
nw="$nw -Wsystem-headers" # Don't let system headers trigger warnings
nw="$nw -Woverlength-strings" # Not a problem these days
nw="$nw -Wvla" # Emacs uses <vla.h>.
@@ -1124,6 +1793,13 @@ AS_IF([test $gl_gcc_warnings = no],
nw="$nw -Wsuggest-attribute=format"
fi
+ # If Emacs is being built for Android and many functions are
+ # currently stubbed out for operation on the build machine, disable
+ # -Wsuggest-attribute=noreturn.
+
+ AS_IF([test "$ANDROID" = "yes"],
+ [nw="$nw -Wsuggest-attribute=noreturn"])
+
gl_MANYWARN_ALL_GCC([ws])
gl_MANYWARN_COMPLEMENT([ws], [$ws], [$nw])
for w in $ws; do
@@ -1137,13 +1813,17 @@ AS_IF([test $gl_gcc_warnings = no],
gl_WARN_ADD([-Wno-unused-parameter]) # Too many warnings for now
gl_WARN_ADD([-Wno-format-nonliteral])
gl_WARN_ADD([-Wno-bidi-chars])
+ AS_IF([test $gl_gcc_warnings = yes],
+ [gl_WARN_ADD([-Wno-analyzer-fd-leak])]) # GCC bug 109839
# clang is unduly picky about some things.
if test "$emacs_cv_clang" = yes; then
+ gl_WARN_ADD([-Wno-bitwise-instead-of-logical])
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])
+ gl_WARN_ADD([-Wno-shift-overflow])
fi
# This causes too much noise in the MinGW build
@@ -1266,7 +1946,7 @@ else
AM_DEFAULT_VERBOSITY=0
fi
AC_SUBST([AM_DEFAULT_VERBOSITY])
-AC_CONFIG_FILES([src/verbose.mk])
+ARCH_INDEPENDENT_CONFIG_FILES([src/verbose.mk])
dnl Some other nice autoconf tests.
AC_PROG_INSTALL
@@ -1661,6 +2341,7 @@ fi
AC_DEFUN([AC_TYPE_SIZE_T])
# Likewise for obsolescent test for uid_t, gid_t; Emacs assumes them.
AC_DEFUN([AC_TYPE_UID_T])
+ac_cv_type_gid_t=yes # AC_TYPE_GETGROUPS needs this in Autoconf 2.72.
# Check for all math.h functions that Emacs uses; on some platforms,
# -lm is needed for some of these functions.
@@ -1691,7 +2372,6 @@ AC_CACHE_CHECK([for math library],
d = frexp (d, &i);
d = ldexp (d, i);
d = log (d);
- d = log2 (d);
d = log10 (d);
d = pow (d, d);
d = rint (d);
@@ -1760,11 +2440,18 @@ AC_DEFINE_UNQUOTED([SYSTEM_TYPE], ["$SYSTEM_TYPE"],
[The type of system you are compiling for; sets 'system-type'.])
AC_SUBST([SYSTEM_TYPE])
+# Check for pw_gecos in struct passwd; this is known to be missing on
+# Android.
+
+AC_CHECK_MEMBERS([struct passwd.pw_gecos], [], [], [#include <pwd.h>])
pre_PKG_CONFIG_CFLAGS=$CFLAGS
pre_PKG_CONFIG_LIBS=$LIBS
-PKG_PROG_PKG_CONFIG([0.9.0])
+dnl pkg-config does not work when cross-compiling for Android.
+if test "${ANDROID}" != "yes"; then
+ PKG_PROG_PKG_CONFIG([0.9.0])
+fi
dnl EMACS_CHECK_MODULES([GSTUFF], [gtk+-2.0 >= 1.3 glib = 1.3.4])
dnl acts like PKG_CHECK_MODULES([GSTUFF], [gtk+-2.0 >= 1.3 glib = 1.3.4],
@@ -1774,10 +2461,25 @@ dnl EMACS_CHECK_MODULES accepts optional 3rd and 4th arguments that
dnl can take the place of the default HAVE_GSTUFF=yes and HAVE_GSTUFF=no
dnl actions.
AC_DEFUN([EMACS_CHECK_MODULES],
- [PKG_CHECK_MODULES([$1], [$2],
- [$1_CFLAGS=`AS_ECHO(["$$1_CFLAGS"]) | sed -e "$edit_cflags"`
- m4_default([$3], [HAVE_$1=yes])],
- [m4_default([$4], [HAVE_$1=no])])])
+ [AS_IF([test -n "$ndk_INITIALIZED"],
+ [ndk_CHECK_MODULES([$1], [$2], m4_default([$3], [HAVE_$1=yes]),
+ m4_default([$4],[HAVE_$1=no]))],
+ [PKG_CHECK_MODULES([$1], [$2],
+ [$1_CFLAGS=`AS_ECHO(["$$1_CFLAGS"]) | sed -e "$edit_cflags"`
+ m4_default([$3], [HAVE_$1=yes])],
+ [m4_default([$4], [HAVE_$1=no])])])])
+
+dnl EMACS_CHECK_LIB(NAME, FUNCTION, ACTION-IF-FOUND, ACTION-IF-NOT-FOUND,
+dnl OTHER-LIBRARIES, INCLUDES)
+dnl ---------------------------------------------------------------------
+dnl This is like AC_CHECK_LIB; however, there is no default action, and
+dnl when cross-configuring for Android, AC_CHECK_DECLS is called with NAME
+dnl and INCLUDES instead, as the library being checked against will likely
+dnl be built together with Emacs.
+AC_DEFUN([EMACS_CHECK_LIB],
+ [AS_IF([test -n "$ndk_INITIALIZED"],
+ [AC_CHECK_DECL([$2], [$3], [$4], [$6])],
+ [AC_CHECK_LIB([$1], [$2], [$3], [$4], [$5])])])
HAVE_SOUND=no
if test "${with_sound}" != "no"; then
@@ -1793,12 +2495,15 @@ if test "${with_sound}" != "no"; then
AC_MSG_ERROR([OSS sound support requested but not found.])
if test "${with_sound}" = "bsd-ossaudio" || test "${with_sound}" = "yes"; then
- # Emulation library used on NetBSD.
+ # OSS emulation library used on NetBSD and OpenBSD.
AC_CHECK_LIB([ossaudio], [_oss_ioctl], [LIBSOUND=-lossaudio], [LIBSOUND=])
test "${with_sound}" = "bsd-ossaudio" && test -z "$LIBSOUND" && \
AC_MSG_ERROR([bsd-ossaudio sound support requested but not found.])
- dnl FIXME? If we did find ossaudio, should we set with_sound=bsd-ossaudio?
- dnl Traditionally, we go on to check for alsa too. Does that make sense?
+ # On {Net,Open}BSD use the system audio library instead of
+ # potentially switching to ALSA below, as ALSA on these appears to
+ # just wrap system libraries.
+ test "${with_sound}" = "yes" && test "$LIBSOUND" = "-lossaudio" && \
+ with_sound="bsd-ossaudio"
fi
AC_SUBST([LIBSOUND])
@@ -1842,8 +2547,10 @@ AC_CHECK_HEADERS_ONCE(
sys/sysinfo.h
coff.h pty.h
sys/resource.h
- sys/utsname.h pwd.h utmp.h util.h
- sanitizer/lsan_interface.h])
+ sys/utsname.h pwd.h util.h
+ sanitizer/lsan_interface.h
+ sanitizer/asan_interface.h
+ sanitizer/common_interface_defs.h])
AC_CACHE_CHECK([for ADDR_NO_RANDOMIZE],
[emacs_cv_personality_addr_no_randomize],
@@ -1945,14 +2652,93 @@ AC_SUBST([AUTO_DEPEND])
window_system=none
+ANDROID_OBJ=
+ANDROID_LIBS=
+# ANDROID_CFLAGS is a precious variable used to pass information to
+# the cross-compiler.
+ANDROID_BUILD_CFLAGS=
+REALLY_ANDROID=
+CM_OBJ="cm.o"
+
+AS_IF([test "$ANDROID" = "yes"],[
+ window_system=android
+ no_x=yes
+ ANDROID_OBJ="androidterm.o androidfns.o androidfont.o androidmenu.o"
+ ANDROID_OBJ="$ANDROID_OBJ android.o"
+ ANDROID_LIBS=
+ CM_OBJ=
+
+ AC_DEFINE([HAVE_ANDROID], [1], [Define to 1 if Emacs is being built
+with Android support])
+
+ AS_IF([test "$XCONFIGURE" != "android"], [
+ AC_DEFINE([ANDROID_STUBIFY], [1], [Define to 1 if Emacs is being built
+for Android, but all API calls need to be stubbed out])
+
+ # Now set any shared user ID that was specified.
+ AS_IF([test -n "$with_shared_user_id"],
+ [emacs_val=$with_shared_user_id
+ emacs_val=`AS_ECHO(["$with_shared_user_id"]) \
+ | sed -e 's/"/\\"/'`
+ emacs_val="\"$emacs_val\""
+ ANDROID_SHARED_USER_ID="android:sharedUserId=$emacs_val"
+ # `android:sharedUserName' is required for sharedUserID to work
+ # on recent Android releases. It does not otherwise affect the
+ # behavior of any code.
+ emacs_val="\"@string/shared_user_name\""
+ ANDROID_SHARED_USER_NAME="android:sharedUserLabel=$emacs_val"])],[
+ # Emacs will be built as a shared library, and a wrapper around it
+ # will also be built for the benefit of applications. This
+ # requires Emacs be built as a position independent executable.
+ ANDROID_BUILD_CFLAGS="-fPIC -fvisibility=hidden"
+
+ # Graphics code in sfntfont-android.c benefits heavily from
+ # vectorization.
+ ANDROID_BUILD_CFLAGS="$ANDROID_BUILD_CFLAGS -ftree-vectorize"
+
+ # Link with libraries required for Android support.
+ # API 9 and later require `-landroid' for the asset manager.
+ # API 8 uses an emulation via the JNI.
+ AS_IF([test "$ANDROID_SDK" -lt "9"],
+ [ANDROID_LIBS="-llog -ljnigraphics"],
+ [ANDROID_LIBS="-landroid -llog -ljnigraphics"])
+
+ # This is required to make the system load emacs.apk's libpng
+ # (among others) instead of the system's own. But it doesn't work
+ # on all Android versions yet, so for now just suffix shared
+ # libraries with _emacs.
+ # ANDROID_LDFLAGS="-Wl,-rpath,'\$\$ORIGIN'"
+
+ # Link with the sfnt font library and sfntfont.o, along with
+ # sfntfont-android.o.
+ ANDROID_OBJ="$ANDROID_OBJ sfnt.o sfntfont.o sfntfont-android.o"
+
+ # Build androidselect.o and androidvfs.o.
+ ANDROID_OBJ="$ANDROID_OBJ androidselect.o androidvfs.o"
+
+ # Check for some functions not always present in the NDK.
+ AC_CHECK_DECLS([android_get_device_api_level])
+
+ # Mention this build is really for Android.
+ REALLY_ANDROID=yes])])
+
+AC_SUBST([ANDROID])
+AC_SUBST([ANDROID_OBJ])
+AC_SUBST([ANDROID_LIBS])
+AC_SUBST([ANDROID_LDFLAGS])
+AC_SUBST([ANDROID_BUILD_CFLAGS])
+AC_SUBST([ANDROID_SHARED_USER_ID])
+AC_SUBST([ANDROID_SHARED_USER_NAME])
+
if test "${with_pgtk}" = "yes"; then
window_system=pgtk
fi
-
-AC_PATH_X
-if test "$no_x" != yes && test "${with_pgtk}" != "yes"; then
- window_system=x11
+if test "${ANDROID}" != "yes"; then
+ AC_PATH_X
+ if test "$no_x" != yes && test "${with_pgtk}" != "yes"; then
+ window_system=x11
+ fi
fi
LD_SWITCH_X_SITE_RPATH=
@@ -1994,16 +2780,16 @@ if test x"${x_includes}" = x; then
bitmapdir=/usr/include/X11/bitmaps
else
# accumulate include directories that have X11 bitmap subdirectories
- bmd_acc=
+ AS_UNSET([bmd_acc])
for bmd in `AS_ECHO(["$x_includes"]) | sed -e 's/:/ /g'`; do
if test -d "${bmd}/X11/bitmaps"; then
- bmd_acc="${bmd_acc}:${bmd}/X11/bitmaps"
+ bmd_acc="${bmd_acc+$bmd_acc:}${bmd}/X11/bitmaps"
fi
if test -d "${bmd}/bitmaps"; then
- bmd_acc="${bmd_acc}:${bmd}/bitmaps"
+ bmd_acc="${bmd_acc+$bmd_acc:}${bmd}/bitmaps"
fi
done
- bitmapdir=${bmd_acc#:}
+ bitmapdir=$bmd_acc
fi
NATIVE_IMAGE_API=no
@@ -2032,31 +2818,23 @@ if test "${with_ns}" != no; then
ns_appresdir=${ns_appdir}/Contents/Resources
ns_appsrc=Cocoa/Emacs.base
ns_fontfile=macfont.o
- elif flags=$( (gnustep-config --objc-flags) 2>/dev/null); then
+ elif flags=`(gnustep-config --objc-flags) 2>/dev/null`; then
NS_IMPL_GNUSTEP=yes
NS_GNUSTEP_CONFIG=yes
GNU_OBJC_CFLAGS="$flags"
- LIBS_GNUSTEP=$(gnustep-config --gui-libs) || exit
+ LIBS_GNUSTEP=`gnustep-config --gui-libs || exit`
elif test -f $GNUSTEP_CONFIG_FILE; then
NS_IMPL_GNUSTEP=yes
dnl FIXME sourcing this several times in subshells seems inefficient.
- GNUSTEP_SYSTEM_HEADERS=$(
- . $GNUSTEP_CONFIG_FILE
- AS_ECHO(["$GNUSTEP_SYSTEM_HEADERS"])
- )
- GNUSTEP_SYSTEM_LIBRARIES=$(
- . $GNUSTEP_CONFIG_FILE
- AS_ECHO(["$GNUSTEP_SYSTEM_LIBRARIES"])
- )
+ GNUSTEP_SYSTEM_HEADERS=`. $GNUSTEP_CONFIG_FILE \
+ && AS_ECHO(["$GNUSTEP_SYSTEM_HEADERS"])`
+ GNUSTEP_SYSTEM_LIBRARIES=` . $GNUSTEP_CONFIG_FILE \
+ && AS_ECHO(["$GNUSTEP_SYSTEM_LIBRARIES"])`
dnl I seemed to need these as well with GNUstep-startup 0.25.
- GNUSTEP_LOCAL_HEADERS=$(
- . $GNUSTEP_CONFIG_FILE
- AS_ECHO(["$GNUSTEP_LOCAL_HEADERS"])
- )
- GNUSTEP_LOCAL_LIBRARIES=$(
- . $GNUSTEP_CONFIG_FILE
- AS_ECHO(["$GNUSTEP_LOCAL_LIBRARIES"])
- )
+ GNUSTEP_LOCAL_HEADERS=`. $GNUSTEP_CONFIG_FILE \
+ && AS_ECHO(["$GNUSTEP_LOCAL_HEADERS"])`
+ GNUSTEP_LOCAL_LIBRARIES=`. $GNUSTEP_CONFIG_FILE \
+ && AS_ECHO(["$GNUSTEP_LOCAL_LIBRARIES"])`
test "x${GNUSTEP_LOCAL_HEADERS}" != "x" && \
GNUSTEP_LOCAL_HEADERS="-I${GNUSTEP_LOCAL_HEADERS}"
test "x${GNUSTEP_LOCAL_LIBRARIES}" != "x" && \
@@ -2276,7 +3054,6 @@ NTDIR=
LIBS_ECLIENT=
LIB_WSOCK32=
NTLIB=
-CM_OBJ="cm.o"
XARGS_LIMIT=
if test "${HAVE_W32}" = "yes"; then
AC_DEFINE([HAVE_NTGUI], [1], [Define to use native MS Windows GUI.])
@@ -2439,7 +3216,11 @@ dnl use the toolkit if we have gtk, or X11R5 or newer.
haiku )
term_header=haikuterm.h
;;
+ android )
+ term_header=androidterm.h
+ ;;
esac
+
AC_SUBST([HAVE_PGTK])
if test "$window_system" = none && test "X$with_x" != "Xno"; then
@@ -2695,39 +3476,6 @@ if test "${HAVE_X11}" = "yes"; then
export LD_RUN_PATH
fi
- if test "${opsys}" = "gnu-linux"; then
- AC_CACHE_CHECK([whether X on GNU/Linux needs -b to link], [emacs_cv_b_link],
- [AC_LINK_IFELSE([AC_LANG_PROGRAM([[#include <X11/Xlib.h>]],
- [[XOpenDisplay ("foo");]])],
- [xgnu_linux_first_failure=no],
- [xgnu_linux_first_failure=yes])
- if test "${xgnu_linux_first_failure}" = "yes"; then
- OLD_CPPFLAGS="$CPPFLAGS"
- OLD_LIBS="$LIBS"
- CPPFLAGS="$CPPFLAGS -b i486-linuxaout"
- LIBS="$LIBS -b i486-linuxaout"
- AC_LINK_IFELSE([AC_LANG_PROGRAM([[#include <X11/Xlib.h>]],
- [[XOpenDisplay ("foo");]])],
- [xgnu_linux_second_failure=no],
- [xgnu_linux_second_failure=yes])
- if test "${xgnu_linux_second_failure}" = "yes"; then
- # If we get the same failure with -b, there is no use adding -b.
- # So leave it out. This plays safe.
- emacs_cv_b_link=no
- else
- emacs_cv_b_link=yes
- fi
- CPPFLAGS=$OLD_CPPFLAGS
- LIBS=$OLD_LIBS
- else
- emacs_cv_b_link=no
- fi])
- if test "x$emacs_cv_b_link" = xyes ; then
- LD_SWITCH_X_SITE="$LD_SWITCH_X_SITE -b i486-linuxaout"
- C_SWITCH_X_SITE="$C_SWITCH_X_SITE -b i486-linuxaout"
- fi
- fi
-
# Reportedly, some broken Solaris systems have XKBlib.h but are missing
# header files included from there.
AC_CACHE_CHECK([for Xkb], [emacs_cv_xkb],
@@ -2773,7 +3521,6 @@ fail;
fi
fi
-
### Use -lrsvg-2 if available, unless '--with-rsvg=no' is specified.
HAVE_RSVG=no
if test "${HAVE_X11}" = "yes" || test "${HAVE_NS}" = "yes" \
@@ -2803,7 +3550,8 @@ HAVE_WEBP=no
if test "${with_webp}" != "no"; then
if test "${HAVE_X11}" = "yes" || test "${opsys}" = "mingw32" \
|| test "${HAVE_W32}" = "yes" || test "${HAVE_NS}" = "yes" \
- || test "${HAVE_BE_APP}" = "yes" || test "${HAVE_PGTK}" = "yes"; then
+ || test "${HAVE_BE_APP}" = "yes" || test "${HAVE_PGTK}" = "yes" \
+ || test "${REALLY_ANDROID}" = "yes"; then
WEBP_REQUIRED=0.6.0
WEBP_MODULE="libwebpdemux >= $WEBP_REQUIRED"
@@ -2817,12 +3565,13 @@ if test "${with_webp}" != "no"; then
CFLAGS="$CFLAGS $WEBP_CFLAGS"
LIBS="$LIBS $WEBP_LIBS"
- AC_CHECK_FUNC([WebPGetInfo], [],
- [WEBP_MODULE="$WEBP_MODULE libwebpdecoder >= $WEBP_REQUIRED"
- HAVE_WEBP=no
- AS_UNSET([WEBP_LIBS])
- AS_UNSET([WEBP_CFLAGS])
- EMACS_CHECK_MODULES([WEBP], [$WEBP_MODULE])])
+ AS_IF([test "$REALLY_ANDROID" != "yes"], [
+ AC_CHECK_FUNC([WebPGetInfo], [],
+ [WEBP_MODULE="$WEBP_MODULE libwebpdecoder >= $WEBP_REQUIRED"
+ HAVE_WEBP=no
+ AS_UNSET([WEBP_LIBS])
+ AS_UNSET([WEBP_CFLAGS])
+ EMACS_CHECK_MODULES([WEBP], [$WEBP_MODULE])])])
CFLAGS=$OLD_CFLAGS
LIBS=$OLD_LIBS
@@ -2832,7 +3581,6 @@ if test "${with_webp}" != "no"; then
fi
if test $HAVE_WEBP = yes; then
AC_DEFINE([HAVE_WEBP], [1], [Define to 1 if using libwebp.])
- CFLAGS="$CFLAGS $WEBP_CFLAGS"
# Windows loads libwebp dynamically
if test "${opsys}" = "mingw32"; then
WEBP_LIBS=
@@ -2842,33 +3590,53 @@ fi
### Use -lsqlite3 if available, unless '--with-sqlite3=no'
HAVE_SQLITE3=no
+SQLITE3_LIBS=
+SQLITE3_CFLAGS=
if test "${with_sqlite3}" != "no"; then
- AC_CHECK_LIB([sqlite3], [sqlite3_open_v2],
- [HAVE_SQLITE3=yes],
- [HAVE_SQLITE3=no])
- if test "$HAVE_SQLITE3" = "yes"; then
- SQLITE3_LIBS=-lsqlite3
- AC_SUBST([SQLITE3_LIBS])
- LIBS="$SQLITE3_LIBS $LIBS"
- AC_DEFINE([HAVE_SQLITE3], [1],
- [Define to 1 if you have the libsqlite3 library (-lsqlite).])
- # Windows loads libsqlite dynamically
- if test "${opsys}" = "mingw32"; then
- SQLITE3_LIBS=
+ if test "${REALLY_ANDROID}" = "yes"; then
+ ndk_SEARCH_MODULE([sqlite3], [SQLITE3], [HAVE_SQLITE3=yes])
+
+ if test "$HAVE_SQLITE3" = "yes"; then
+ SAVE_CFLAGS="$CFLAGS"
+ CFLAGS="$CFLAGS $SQLITE3_CFLAGS"
+ AC_CHECK_DECL([sqlite3_open_v2], [HAVE_SQLITE=yes],
+ [HAVE_SQLITE3=no], [#include <sqlite3.h>])
+ CFLAGS="$SAVE_CFLAGS"
fi
- AC_CHECK_LIB([sqlite3], [sqlite3_load_extension],
- [HAVE_SQLITE3_LOAD_EXTENSION=yes],
- [HAVE_SQLITE3_LOAD_EXTENSION=no])
- if test "$HAVE_SQLITE3_LOAD_EXTENSION" = "yes"; then
- AC_DEFINE([HAVE_SQLITE3_LOAD_EXTENSION], [1],
- [Define to 1 if sqlite3 supports loading extensions.])
+ else
+ AC_CHECK_LIB([sqlite3], [sqlite3_open_v2],
+ [HAVE_SQLITE3=yes],
+ [HAVE_SQLITE3=no])
+ if test "$HAVE_SQLITE3" = "yes"; then
+ SQLITE3_LIBS=-lsqlite3
+ LIBS="$SQLITE3_LIBS $LIBS"
+ # Windows loads libsqlite dynamically
+ if test "${opsys}" = "mingw32"; then
+ SQLITE3_LIBS=
+ fi
+ AC_CHECK_LIB([sqlite3], [sqlite3_load_extension],
+ [HAVE_SQLITE3_LOAD_EXTENSION=yes],
+ [HAVE_SQLITE3_LOAD_EXTENSION=no])
+ if test "$HAVE_SQLITE3_LOAD_EXTENSION" = "yes"; then
+ AC_DEFINE([HAVE_SQLITE3_LOAD_EXTENSION], [1],
+ [Define to 1 if sqlite3 supports loading extensions.])
+ fi
fi
- fi
+ fi
+
+ if test "$HAVE_SQLITE3" = "yes"; then
+ AC_DEFINE([HAVE_SQLITE3], [1],
+ [Define to 1 if you have the libsqlite3 library (-lsqlite).])
+ fi
fi
+AC_SUBST([SQLITE3_LIBS])
+AC_SUBST([SQLITE3_CFLAGS])
+
HAVE_IMAGEMAGICK=no
if test "${HAVE_X11}" = "yes" || test "${HAVE_NS}" = "yes" || test "${HAVE_W32}" = "yes" || \
- test "${HAVE_BE_APP}" = "yes" || test "${window_system}" = "pgtk"; then
+ test "${HAVE_BE_APP}" = "yes" || test "${window_system}" = "pgtk" || \
+ test "${REALLY_ANDROID}" = "yes"; then
if test "${with_imagemagick}" != "no"; then
if test -n "$BREW"; then
# Homebrew doesn't link ImageMagick 6 by default, so make sure
@@ -2891,14 +3659,23 @@ if test "${HAVE_X11}" = "yes" || test "${HAVE_NS}" = "yes" || test "${HAVE_W32}"
OLD_LIBS=$LIBS
CFLAGS="$CFLAGS $IMAGEMAGICK_CFLAGS"
LIBS="$IMAGEMAGICK_LIBS $LIBS"
- AC_CHECK_FUNCS([MagickRelinquishMemory MagickExportImagePixels \
- MagickMergeImageLayers MagickAutoOrientImage])
+ if test "$REALLY_ANDROID" != "yes"; then
+ AC_CHECK_FUNCS([MagickRelinquishMemory MagickExportImagePixels \
+ MagickMergeImageLayers MagickAutoOrientImage])
+ else
+ # AC_CHECK_FUNCS doesn't work for Android dependencies because
+ # they are built alongside Emacs.
+ AC_CHECK_DECLS([MagickRelinquishMemory,MagickExportImagePixels,
+MagickMergeImageLayers,MagickAutoOrientImage],
+ [], [], [#include <MagickWand/MagickWand.h>])
+ fi
CFLAGS=$OLD_CFLAGS
LIBS=$OLD_LIBS
# Check that ImageMagick links. It does not link on Fedora 25
# with './configure CC=clang', as pkg-config outputs flags like
# -lomp that work for GCC but not Clang.
- if test "$ac_cv_func_MagickRelinquishMemory" != yes; then
+ if test "$ac_cv_func_MagickRelinquishMemory" != yes \
+ && test "$REALLY_ANDROID" != "yes"; then
HAVE_IMAGEMAGICK=no
fi
fi
@@ -3172,19 +3949,29 @@ if test "${HAVE_GTK}" = "yes"; then
fi
AC_SUBST([USE_STARTUP_NOTIFICATION])
-dnl SELinux is available for GNU/Linux only.
+dnl SELinux is available for Linux kernel based systems only.
+dnl These include GNU/Linux and Android.
HAVE_LIBSELINUX=no
LIBSELINUX_LIBS=
+LIBSELINUX_CFLAGS=
if test "${with_selinux}" = "yes"; then
- AC_CHECK_LIB([selinux], [lgetfilecon],
- [HAVE_LIBSELINUX=yes],
- [HAVE_LIBSELINUX=no])
+ if test "$REALLY_ANDROID" = "yes"; then
+ ndk_SEARCH_MODULE([libselinux], [LIBSELINUX],
+ [HAVE_LIBSELINUX=yes])
+ else
+ AC_CHECK_LIB([selinux], [lgetfilecon],
+ [HAVE_LIBSELINUX=yes],
+ [HAVE_LIBSELINUX=no])
+ fi
if test "$HAVE_LIBSELINUX" = yes; then
AC_DEFINE([HAVE_LIBSELINUX], [1], [Define to 1 if using SELinux.])
- LIBSELINUX_LIBS=-lselinux
+ if test "$REALLY_ANDROID" != "yes"; then
+ LIBSELINUX_LIBS=-lselinux
+ fi
fi
fi
AC_SUBST([LIBSELINUX_LIBS])
+AC_SUBST([LIBSELINUX_CFLAGS])
HAVE_GNUTLS=no
if test "${with_gnutls}" != "no" ; then
@@ -3305,16 +4092,16 @@ case $with_file_notification,$opsys in
fi ;;
esac
-dnl inotify is available only on GNU/Linux.
+dnl inotify is available only on Linux-kernel based systems.
case $with_file_notification,$NOTIFY_OBJ in
inotify, | yes,)
AC_CHECK_HEADER([sys/inotify.h])
if test "$ac_cv_header_sys_inotify_h" = yes ; then
- AC_CHECK_FUNC([inotify_init1])
- if test "$ac_cv_func_inotify_init1" = yes; then
+ AC_CHECK_FUNCS([inotify_init inotify_init1])
+ if test "$ac_cv_func_inotify_init" = yes; then
AC_DEFINE([HAVE_INOTIFY], [1], [Define to 1 to use inotify.])
NOTIFY_OBJ=inotify.o
- NOTIFY_SUMMARY="yes -lglibc (inotify)"
+ NOTIFY_SUMMARY="yes (inotify)"
fi
fi ;;
esac
@@ -3813,7 +4600,7 @@ if test "${HAVE_X11}" = "yes"; then
AC_DEFINE([HAVE_OTF_GET_VARIATION_GLYPHS], [1],
[Define to 1 if libotf has OTF_get_variation_glyphs.])
fi
- if ! $PKG_CONFIG --atleast-version=0.9.16 libotf; then
+ if $PKG_CONFIG --atleast-version=0.9.16 libotf; then :; else
AC_DEFINE([HAVE_OTF_KANNADA_BUG], [1],
[Define to 1 if libotf is affected by https://debbugs.gnu.org/28110.])
fi
@@ -3873,17 +4660,23 @@ else
fi
if test "${HAVE_X11}" = "yes" && test "${HAVE_FREETYPE}" = "yes" \
|| test "$window_system" = "pgtk" \
- || test "${HAVE_W32}" = "yes"; then
+ || test "${HAVE_W32}" = "yes" \
+ || test "$REALLY_ANDROID" = "yes"; then
if test "${with_harfbuzz}" != "no"; then
EMACS_CHECK_MODULES([HARFBUZZ], [harfbuzz >= $harfbuzz_required_ver])
- if test "$HAVE_HARFBUZZ" = "yes"; then
+ AS_IF([test "$HAVE_HARFBUZZ" = "yes"],[
AC_DEFINE([HAVE_HARFBUZZ], [1], [Define to 1 if using HarfBuzz.])
### mingw32 and Cygwin-w32 don't use -lharfbuzz, since they load
### the library dynamically.
- if test "${HAVE_W32}" = "yes"; then
- HARFBUZZ_LIBS=
- fi
- fi
+ AS_IF([test "${HAVE_W32}" = "yes"], [HARFBUZZ_LIBS=])
+ ## Now check for `hb_font_set_var_named_instance'.
+ OLD_CFLAGS=$CFLAGS
+ CFLAGS="$HARFBUZZ_CFLAGS $CFLAGS"
+ EMACS_CHECK_LIB([harfbuzz], [hb_font_set_var_named_instance],
+ [AC_DEFINE([HAVE_HB_FONT_SET_VAR_NAMED_INSTANCE], [1],
+ [Define to 1 if `hb_font_set_var_named_instance' is present.])],
+ [], [$HARFBUZZ_LIBS], [#include <hb.h>])
+ CFLAGS=$OLD_CFLAGS])
fi
fi
@@ -3921,7 +4714,7 @@ if test "${HAVE_BE_APP}" = "yes"; then
AC_DEFINE([HAVE_OTF_GET_VARIATION_GLYPHS], [1],
[Define to 1 if libotf has OTF_get_variation_glyphs.])
fi
- if ! $PKG_CONFIG --atleast-version=0.9.16 libotf; then
+ if $PKG_CONFIG --atleast-version=0.9.16 libotf; then :; else
AC_DEFINE([HAVE_OTF_KANNADA_BUG], [1],
[Define to 1 if libotf is affected by https://debbugs.gnu.org/28110.])
fi
@@ -3961,21 +4754,10 @@ if test "${HAVE_X11}" = "yes"; then
if test "${HAVE_XCB}" = "yes"; then
AC_CHECK_LIB([X11-xcb], [XGetXCBConnection], [HAVE_X11_XCB=yes])
if test "${HAVE_X11_XCB}" = "yes"; then
- AC_CHECK_LIB([xcb-util], [xcb_aux_sync], [HAVE_XCB_UTIL=yes])
- if test "${HAVE_XCB_UTIL}" = "yes"; then
- AC_DEFINE([USE_XCB], [1],
+ 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-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
+X11/XCB programming.])
+ XCB_LIBS="-lX11-xcb -lxcb"
fi
fi
fi
@@ -4077,51 +4859,66 @@ AC_SUBST([LIBXPM])
### Use -ljpeg if available, unless '--with-jpeg=no'.
HAVE_JPEG=no
LIBJPEG=
+JPEG_CFLAGS=
if test "${HAVE_X11}" = "yes" || test "${HAVE_W32}" = "yes" \
|| test "${HAVE_NS}" = "yes" || test "${HAVE_BE_APP}" = "yes" \
- || test "$window_system" = "pgtk"; then
+ || test "$window_system" = "pgtk" \
+ || test "${REALLY_ANDROID}" = "yes"; then
if test "${with_jpeg}" != "no"; then
- AC_CACHE_CHECK([for jpeglib 6b or later],
- [emacs_cv_jpeglib],
- [OLD_LIBS=$LIBS
- for emacs_cv_jpeglib in yes -ljpeg no; do
- case $emacs_cv_jpeglib in
- yes) ;;
- no) break;;
- *) LIBS="$LIBS $emacs_cv_jpeglib";;
- esac
- AC_LINK_IFELSE(
- [AC_LANG_PROGRAM(
- [[#undef HAVE_STDLIB_H /* Avoid config.h/jpeglib.h collision. */
- #include <stdio.h> /* jpeglib.h needs FILE and size_t. */
- #include <jpeglib.h>
- #include <jerror.h>
- char verify[JPEG_LIB_VERSION < 62 ? -1 : 1];
- struct jpeg_decompress_struct cinfo;
- ]],
- [[
- jpeg_create_decompress (&cinfo);
- WARNMS (&cinfo, JWRN_JPEG_EOF);
- jpeg_destroy_decompress (&cinfo);
- ]])],
- [emacs_link_ok=yes],
- [emacs_link_ok=no])
- LIBS=$OLD_LIBS
- test $emacs_link_ok = yes && break
- done])
- if test "$emacs_cv_jpeglib" != no; then
- HAVE_JPEG=yes
- AC_DEFINE([HAVE_JPEG], [1],
- [Define to 1 if you have the jpeg library (typically -ljpeg).])
- ### mingw32 doesn't use -ljpeg, since it loads the library
- ### dynamically when needed, and doesn't want a run-time
- ### dependency on the jpeglib DLL.
- test "$emacs_cv_jpeglib" != yes && test "${opsys}" != "mingw32" \
- && LIBJPEG=$emacs_cv_jpeglib
+ if test "${REALLY_ANDROID}" = "yes"; then
+ # Look for libjpeg using the NDK.
+ ndk_SEARCH_MODULE([libjpeg], [JPEG], [HAVE_JPEG=yes])
+
+ if test "$HAVE_JPEG" = "yes"; then
+ LIBJPEG="$JPEG_LIBS"
+
+ AC_DEFINE([HAVE_JPEG], [1],
+ [Define to 1 if you have the jpeg library (typically -ljpeg).])
+ fi
+ else
+ AC_CACHE_CHECK([for jpeglib 6b or later],
+ [emacs_cv_jpeglib],
+ [OLD_LIBS=$LIBS
+ for emacs_cv_jpeglib in yes -ljpeg no; do
+ case $emacs_cv_jpeglib in
+ yes) ;;
+ no) break;;
+ *) LIBS="$LIBS $emacs_cv_jpeglib";;
+ esac
+ AC_LINK_IFELSE(
+ [AC_LANG_PROGRAM(
+ [[#undef HAVE_STDLIB_H /* Avoid config.h/jpeglib.h collision. */
+ #include <stdio.h> /* jpeglib.h needs FILE and size_t. */
+ #include <jpeglib.h>
+ #include <jerror.h>
+ char verify[JPEG_LIB_VERSION < 62 ? -1 : 1];
+ struct jpeg_decompress_struct cinfo;
+ ]],
+ [[
+ jpeg_create_decompress (&cinfo);
+ WARNMS (&cinfo, JWRN_JPEG_EOF);
+ jpeg_destroy_decompress (&cinfo);
+ ]])],
+ [emacs_link_ok=yes],
+ [emacs_link_ok=no])
+ LIBS=$OLD_LIBS
+ test $emacs_link_ok = yes && break
+ done])
+ if test "$emacs_cv_jpeglib" != no; then
+ HAVE_JPEG=yes
+ AC_DEFINE([HAVE_JPEG], [1],
+ [Define to 1 if you have the jpeg library (typically -ljpeg).])
+ ### mingw32 doesn't use -ljpeg, since it loads the library
+ ### dynamically when needed, and doesn't want a run-time
+ ### dependency on the jpeglib DLL.
+ test "$emacs_cv_jpeglib" != yes && test "${opsys}" != "mingw32" \
+ && LIBJPEG=$emacs_cv_jpeglib
+ fi
fi
fi
fi
AC_SUBST([LIBJPEG])
+AC_SUBST([JPEG_CFLAGS])
HAVE_LCMS2=no
LCMS2_CFLAGS=
@@ -4194,61 +4991,56 @@ if test $window_system = pgtk; then
esac
fi
-if test "${with_modules}" != "no"; then
- case $opsys in
- gnu|gnu-linux)
- LIBMODULES="-ldl"
- HAVE_MODULES=yes
- ;;
- cygwin|mingw32|darwin)
- HAVE_MODULES=yes
- ;;
- *)
- # BSD systems have dlopen in libc.
- AC_CHECK_FUNC([dlopen], [HAVE_MODULES=yes])
- ;;
- esac
-
- if test "${HAVE_MODULES}" = no; then
- AC_MSG_ERROR([Dynamic modules are not supported on your system])
- else
- SAVE_LIBS=$LIBS
- LIBS="$LIBS $LIBMODULES"
- AC_CHECK_FUNCS([dladdr dlfunc])
- LIBS=$SAVE_LIBS
- fi
-fi
+AS_IF([test "x$with_modules" != "xno"],
+ [AS_CASE(["$opsys"],
+ [gnu|gnu-linux],
+ [LIBMODULES="-ldl"
+ HAVE_MODULES=yes],
+ [cygwin|mingw32|darwin],
+ [HAVE_MODULES=yes],
+ # BSD systems have dlopen in libc.
+ [AC_CHECK_FUNC([dlopen], [HAVE_MODULES=yes])])
+
+ AS_IF([test "x$HAVE_MODULES" = "xno"],
+ [AS_IF([test "$with_modules" = "ifavailable"],
+ [AC_MSG_WARN([Dynamic modules are not supported on your system])],
+ [AC_MSG_ERROR([Dynamic modules are not supported on your system])])],
+ [SAVE_LIBS=$LIBS
+ LIBS="$LIBS $LIBMODULES"
+ AC_CHECK_FUNCS([dladdr dlfunc])
+ LIBS=$SAVE_LIBS])])
+
+AS_IF([test "x$HAVE_MODULES" = xyes],
+ [MODULES_OBJ="emacs-module.o"
+ NEED_DYNLIB=yes
+ AC_DEFINE([HAVE_MODULES], [1], [Define to 1 if dynamic modules are enabled])
+ AC_DEFINE_UNQUOTED([MODULES_SUFFIX], ["$MODULES_SUFFIX"],
+ [System extension for dynamic libraries])
+ AS_IF([test -n "$MODULES_SECONDARY_SUFFIX"],
+ [AC_DEFINE_UNQUOTED([MODULES_SECONDARY_SUFFIX],
+ ["$MODULES_SECONDARY_SUFFIX"],
+ [Alternative system extension for dynamic libraries.])])])
-if test "${HAVE_MODULES}" = yes; then
- MODULES_OBJ="emacs-module.o"
- NEED_DYNLIB=yes
- AC_DEFINE([HAVE_MODULES], [1], [Define to 1 if dynamic modules are enabled])
- AC_DEFINE_UNQUOTED([MODULES_SUFFIX], ["$MODULES_SUFFIX"],
- [System extension for dynamic libraries])
- if test -n "${MODULES_SECONDARY_SUFFIX}"; then
- AC_DEFINE_UNQUOTED([MODULES_SECONDARY_SUFFIX],
- ["$MODULES_SECONDARY_SUFFIX"],
- [Alternative system extension for dynamic libraries.])
- fi
-fi
AC_SUBST([MODULES_OBJ])
AC_SUBST([LIBMODULES])
AC_SUBST([HAVE_MODULES])
AC_SUBST([MODULES_SUFFIX])
AC_SUBST([MODULES_SECONDARY_SUFFIX])
-AC_CONFIG_FILES([src/emacs-module.h])
+ARCH_INDEPENDENT_CONFIG_FILES([src/emacs-module.h])
AC_SUBST_FILE([module_env_snippet_25])
AC_SUBST_FILE([module_env_snippet_26])
AC_SUBST_FILE([module_env_snippet_27])
AC_SUBST_FILE([module_env_snippet_28])
AC_SUBST_FILE([module_env_snippet_29])
+AC_SUBST_FILE([module_env_snippet_30])
module_env_snippet_25="$srcdir/src/module-env-25.h"
module_env_snippet_26="$srcdir/src/module-env-26.h"
module_env_snippet_27="$srcdir/src/module-env-27.h"
module_env_snippet_28="$srcdir/src/module-env-28.h"
module_env_snippet_29="$srcdir/src/module-env-29.h"
-emacs_major_version="${PACKAGE_VERSION%%.*}"
+module_env_snippet_30="$srcdir/src/module-env-30.h"
+emacs_major_version=`AS_ECHO([$PACKAGE_VERSION]) | sed 's/[[.]].*//'`
AC_SUBST([emacs_major_version])
### Emacs Lisp native compiler support
@@ -4292,20 +5084,20 @@ AC_DEFUN([libgccjit_smoke_test], [
return 0;
}]])])
-AC_DEFUN([libgccjit_not_found], [
+AC_DEFUN([libgccjit_not_found_err], [
AC_MSG_ERROR([ELisp native compiler was requested, but libgccjit was not found.
Please try installing libgccjit or a similar package.
If you are sure you want Emacs be compiled without ELisp native compiler,
pass the --without-native-compilation option to configure.])])
-AC_DEFUN([libgccjit_dev_not_found], [
+AC_DEFUN([libgccjit_dev_not_found_err], [
AC_MSG_ERROR([ELisp native compiler was requested, but libgccjit header files were
not found.
Please try installing libgccjit-dev or a similar package.
If you are sure you want Emacs be compiled without ELisp native compiler,
pass the --without-native-compilation option to configure.])])
-AC_DEFUN([libgccjit_broken], [
+AC_DEFUN([libgccjit_broken_err], [
AC_MSG_ERROR([The installed libgccjit failed to compile and run a test program using
the libgccjit library; see config.log for the details of the failure.
The test program can be found here:
@@ -4330,6 +5122,58 @@ If you really want to try it anyway, use the configure option
fi
fi
+AC_DEFUN([libgccjit_not_found], [
+ AC_MSG_WARN([Elisp native compiler can't be enabled as libgccjit was not
+found.
+Please try installing libgccjit or a similar package if you want to have it
+enabled.])
+
+ with_native_compilation=no
+])
+
+AC_DEFUN([libgccjit_dev_not_found], [
+ AC_MSG_WARN([Elisp native compiler can't be enabled as libgccjit header files
+were not found.
+Please try installing libgccjit-dev or a similar package if you want to have it
+enabled.])
+
+ with_native_compilation=no
+])
+
+AC_DEFUN([libgccjit_broken], [
+ AC_MSG_WARN([Elisp native compiler can't be enabled as the installed libgccjit
+failed to compile and run a test program using the libgccjit library; see
+config.log for the details of the failure.
+The test program can be found here:
+<https://gcc.gnu.org/onlinedocs/jit/intro/tutorial01.html>.
+You can try compiling it yourself to investigate the issues.
+Please report the issue to your distribution if libgccjit was installed
+through that.
+You can find the instructions on how to compile and install libgccjit from
+source on this site:
+<https://gcc.gnu.org/wiki/JIT>.])
+
+ with_native_compilation=no])
+
+if test "$with_features" = "no" \
+ && test "${with_native_compilation}" = "default"; then
+ with_native_compilation=no
+fi
+
+if test "${with_native_compilation}" = "default"; then
+ # Check if libgccjit is available.
+ AC_CHECK_LIB([gccjit], [gcc_jit_context_acquire],
+ [], [libgccjit_not_found])
+ AC_CHECK_HEADERS([libgccjit.h], [], [libgccjit_dev_not_found])
+ if test "${with_native_compilation}" != "no"; then
+ # Check if libgccjit really works.
+ AC_RUN_IFELSE([libgccjit_smoke_test], [], [libgccjit_broken])
+ fi
+ if test "$with_unexec" = yes; then
+ with_native_compilation=no
+ fi
+fi
+
if test "${with_native_compilation}" != "no"; then
if test "$with_unexec" = yes; then
AC_MSG_ERROR(['--with-native-compilation' is not compatible with unexec])
@@ -4358,14 +5202,16 @@ if test "${with_native_compilation}" != "no"; then
# available. (We filter out the gcc4 packages, because they
# don't support jit, and they have names like "gcc49" that
# sort later than "gcc11".)
- PORT_PACKAGE=$(port installed active | grep '^ *gcc@<:@0-9@:>@* ' | \
+ PORT_PACKAGE=`port installed active | grep '^ *gcc@<:@0-9@:>@* ' | \
awk '{ print $1; }' | grep -v 'gcc4@<:@0-9@:>@' | \
- sort -V | tail -n 1)
+ sort -V | tail -n 1`
if test -n "$PORT_PACKAGE"; then
- MAC_CFLAGS="-I$(dirname $(port contents $PORT_PACKAGE | \
- grep libgccjit.h))"
- MAC_LIBS="-L$(dirname $(port contents $PORT_PACKAGE | \
- grep libgccjit.dylib))"
+ emacs_val=`port contents $PORT_PACKAGE | grep libgccjit.h`
+ emacs_val=`dirname $emacs_val`
+ MAC_CFLAGS="-I$emacs_val"
+ emacs_val=`port contents $PORT_PACKAGE | grep libgccjit.dylib`
+ emacs_val=`dirname $emacs_val`
+ MAC_LIBS="-L$emacs_val"
fi
fi
@@ -4375,12 +5221,15 @@ if test "${with_native_compilation}" != "no"; then
fi
fi
- # Check if libgccjit is available.
- AC_CHECK_LIB([gccjit], [gcc_jit_context_acquire],
- [], [libgccjit_not_found])
- AC_CHECK_HEADERS([libgccjit.h], [], [libgccjit_dev_not_found])
- # Check if libgccjit really works.
- AC_RUN_IFELSE([libgccjit_smoke_test], [], [libgccjit_broken])
+ # In the default case we already checked
+ if test "${with_native_compilation}" != "default"; then
+ # Check if libgccjit is available.
+ AC_CHECK_LIB([gccjit], [gcc_jit_context_acquire],
+ [], [libgccjit_not_found_err])
+ AC_CHECK_HEADERS([libgccjit.h], [], [libgccjit_dev_not_found_err])
+ # Check if libgccjit really works.
+ AC_RUN_IFELSE([libgccjit_smoke_test], [], [libgccjit_broken_err])
+ fi
HAVE_NATIVE_COMP=yes
case "${opsys}" in
# mingw32 loads the library dynamically.
@@ -4424,7 +5273,8 @@ if test "${with_png}" != no; then
AC_CHECK_HEADER([png.h], [HAVE_PNG=yes])
elif test "${HAVE_X11}" = "yes" || test "${HAVE_W32}" = "yes" \
|| test "${HAVE_NS}" = "yes" || test "${HAVE_BE_APP}" = "yes" \
- || test "$window_system" = "pgtk"; then
+ || test "$window_system" = "pgtk" \
+ || test "${REALLY_ANDROID}" = "yes"; then
EMACS_CHECK_MODULES([PNG], [libpng >= 1.0.0])
if test $HAVE_PNG = yes; then
LIBPNG=$PNG_LIBS
@@ -4491,6 +5341,7 @@ AC_SUBST([PNG_CFLAGS])
### mingw32 doesn't use -ltiff, since it loads the library dynamically.
HAVE_TIFF=no
LIBTIFF=
+TIFF_CFLAGS=
if test "${opsys}" = "mingw32"; then
if test "${with_tiff}" != "no"; then
AC_CHECK_HEADER([tiffio.h], [HAVE_TIFF=yes], [HAVE_TIFF=no])
@@ -4501,28 +5352,42 @@ if test "${opsys}" = "mingw32"; then
fi
elif test "${HAVE_X11}" = "yes" || test "${HAVE_W32}" = "yes" \
|| test "${HAVE_NS}" = "yes" || test "${HAVE_BE_APP}" = "yes" \
- || test "$window_system" = "pgtk"; then
+ || test "$window_system" = "pgtk" \
+ || test "${REALLY_ANDROID}" = "yes"; then
if test "${with_tiff}" != "no"; then
- AC_CHECK_HEADER([tiffio.h],
- [tifflibs="-lz -lm"
- # At least one tiff package requires the jpeg library.
- if test "${HAVE_JPEG}" = yes; then tifflibs="-ljpeg $tifflibs"; fi
- AC_CHECK_LIB([tiff], [TIFFGetVersion], [HAVE_TIFF=yes], [],
- [$tifflibs])])
+ if test "${REALLY_ANDROID}" != "yes"; then
+ AC_CHECK_HEADER([tiffio.h],
+ [tifflibs="-lz -lm"
+ # At least one tiff package requires the jpeg library.
+ if test "${HAVE_JPEG}" = yes; then tifflibs="-ljpeg $tifflibs"; fi
+ AC_CHECK_LIB([tiff], [TIFFGetVersion], [HAVE_TIFF=yes], [],
+ [$tifflibs])])
+ else
+ ndk_SEARCH_MODULE([libtiff], [TIFF], [HAVE_TIFF=yes])
+
+ if test "$HAVE_TIFF" = "yes"; then
+ LIBTIFF="$TIFF_LIBS"
+ fi
+ fi
fi
if test "${HAVE_TIFF}" = "yes"; then
AC_DEFINE([HAVE_TIFF], [1],
[Define to 1 if you have the tiff library (-ltiff).])
- dnl FIXME -lz -lm, as per libpng?
- LIBTIFF=-ltiff
+
+ if test "$REALLY_ANDROID" != "yes"; then
+ dnl FIXME -lz -lm, as per libpng?
+ LIBTIFF=-ltiff
+ fi
fi
fi
AC_SUBST([LIBTIFF])
+AC_SUBST([TIFF_CFLAGS])
### Use -lgif or -lungif if available, unless '--with-gif=no'.
### mingw32 doesn't use -lgif/-lungif, since it loads the library dynamically.
HAVE_GIF=no
+GIF_CFLAGS=
LIBGIF=
if test "${opsys}" = "mingw32"; then
if test "${with_gif}" != "no"; then
@@ -4535,6 +5400,7 @@ if test "${opsys}" = "mingw32"; then
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" \
+ || test "${REALLY_ANDROID}" = "yes" \
&& test "${with_gif}" != "no"; then
AC_CHECK_HEADER([gif_lib.h],
# EGifPutExtensionLast only exists from version libungif-4.1.0b1.
@@ -4554,12 +5420,20 @@ elif test "${HAVE_X11}" = "yes" && test "${with_gif}" != "no" \
test "$HAVE_GIF" = yes && LIBGIF=-lungif
fi
+# Finally, try ndk-build on Android.
+ if test "$REALLY_ANDROID" = "yes"; then
+ ndk_SEARCH_MODULE([libgif], [GIF], [HAVE_GIF=yes],
+ [HAVE_GIF=no])
+ test "$HAVE_GIF" = yes && LIBGIF="$GIF_LIBS"
+ fi
+
if test "${HAVE_GIF}" = "yes"; then
AC_DEFINE([HAVE_GIF], [1],
[Define to 1 if you have a gif (or ungif) library.])
fi
fi
AC_SUBST([LIBGIF])
+AC_SUBST([GIF_CFLAGS])
dnl Check for required libraries.
MISSING=
@@ -4730,7 +5604,7 @@ AC_SUBST([XINERAMA_LIBS])
### Use Xfixes (-lXfixes) if available
HAVE_XFIXES=no
if test "${HAVE_X11}" = "yes"; then
- XFIXES_REQUIRED=4.0.0
+ XFIXES_REQUIRED=1.0.0
XFIXES_MODULES="xfixes >= $XFIXES_REQUIRED"
EMACS_CHECK_MODULES([XFIXES], [$XFIXES_MODULES])
if test $HAVE_XFIXES = no; then
@@ -4898,10 +5772,13 @@ if test "${with_xml2}" != "no"; then
fi
if test "${HAVE_LIBXML2}" = "yes"; then
if test "${opsys}" != "mingw32"; then
- AC_CHECK_LIB([xml2], [htmlReadMemory],
+ SAVE_CFLAGS=$CFLAGS
+ CFLAGS="$CFLAGS $LIBXML2_CFLAGS"
+ EMACS_CHECK_LIB([xml2], [htmlReadMemory],
[HAVE_LIBXML2=yes],
[HAVE_LIBXML2=no],
- [$LIBXML2_LIBS])
+ [$LIBXML2_LIBS], [#include <libxml/HTMLparser.h>])
+ CFLAGS="$SAVE_CFLAGS"
else
LIBXML2_LIBS=""
fi
@@ -5027,15 +5904,55 @@ OLD_LIBS=$LIBS
LIBS="$LIB_PTHREAD $LIB_MATH $LIBS"
AC_CHECK_FUNCS([accept4 fchdir gethostname \
getrusage get_current_dir_name \
-lrand48 random rint trunc \
+lrand48 random rint tcdrain trunc \
select getpagesize setlocale newlocale \
getrlimit setrlimit shutdown \
pthread_sigmask strsignal setitimer \
sendto recvfrom getsockname getifaddrs freeifaddrs \
gai_strerror sync \
-getpwent endpwent getgrent endgrent \
+endpwent getgrent endgrent \
cfmakeraw cfsetspeed __executable_start log2 pthread_setname_np \
pthread_set_name_np])
+
+# getpwent is not present in older versions of Android. (bug#65319)
+gl_CHECK_FUNCS_ANDROID([getpwent], [[#include <pwd.h>]])
+
+# renameat2 is not present in older versions of Android.
+gl_CHECK_FUNCS_ANDROID([renameat2], [[#include <stdio.h>]])
+
+if test "$ac_cv_func_cfmakeraw" != "yes"; then
+ # On some systems (Android), cfmakeraw is inline, so AC_CHECK_FUNCS
+ # cannot find it. Check if some code including termios.h and using
+ # cfmakeraw builds.
+ AC_CACHE_CHECK([whether cfmakeraw is inline],
+ [emacs_cv_func_cfmakeraw_inline],
+ [AC_COMPILE_IFELSE([AC_LANG_PROGRAM(
+ [[#include <termios.h>]],
+ [[&cfmakeraw;]])],
+ [emacs_cv_func_cfmakeraw_inline=yes],
+ [emacs_cv_func_cfmakeraw_inline=no])])
+
+ if test "$emacs_cv_func_cfmakeraw_inline" = "yes"; then
+ # Define HAVE_CFMAKERAW again.
+ AC_DEFINE([HAVE_CFMAKERAW], [1])
+ fi
+fi
+
+if test "$ac_cv_func_cfsetspeed" != "yes"; then
+ AC_CACHE_CHECK([whether cfsetspeed is inline],
+ [emacs_cv_func_cfsetspeed_inline],
+ [AC_COMPILE_IFELSE([AC_LANG_PROGRAM(
+ [[#include <termios.h>]],
+ [[&cfsetspeed;]])],
+ [emacs_cv_func_cfsetspeed_inline=yes],
+ [emacs_cv_func_cfsetspeed_inline=no])])
+
+ if test "$emacs_cv_func_cfsetspeed_inline" = "yes"; then
+ # Define HAVE_CFSETSPEED again.
+ AC_DEFINE([HAVE_CFSETSPEED], [1])
+ fi
+fi
+
LIBS=$OLD_LIBS
if test "$ac_cv_func_pthread_setname_np" = "yes"; then
@@ -5087,8 +6004,8 @@ if test "$with_unexec" = yes && test "$opsys" = "haiku"; then
Please use the portable dumper instead.])
fi
-# Dump loading
-AC_CHECK_FUNCS([posix_madvise])
+# Dump loading. Android lacks posix_madvise.
+AC_CHECK_FUNCS([posix_madvise madvise])
dnl Cannot use AC_CHECK_FUNCS
AC_CACHE_CHECK([for __builtin_frame_address],
@@ -5141,7 +6058,7 @@ AC_DEFUN([tputs_link_source], [
# than to expect to find it in ncurses.
# Also we need tputs and friends to be able to build at all.
AC_CACHE_CHECK([for library containing tputs], [emacs_cv_tputs_lib],
-[if test "${opsys}" = "mingw32"; then
+[if test "${opsys}" = "mingw32" || test x"$REALLY_ANDROID" = "xyes"; then
emacs_cv_tputs_lib='none required'
else
# curses precedes termcap because of AIX (Bug#9736#35) and OpenIndiana.
@@ -5179,7 +6096,7 @@ TERMINFO=yes
## LIBS_TERMCAP="-lncurses", this overrides LIBS_TERMCAP = -ltinfo,
## if that was found above to have tputs.
## Should we use the gnu* logic everywhere?
-case "$opsys" in
+case "$opsys$REALLY_ANDROID" in
## darwin: Prevents crashes when running Emacs in Terminal.app under 10.2.
## The ncurses library has been moved out of the System framework in
## Mac OS X 10.2. So if configure detects it, set the command-line
@@ -5208,7 +6125,10 @@ fail;
fi
;;
- mingw32)
+ # The case condition is a concatenation of both $opsys and
+ # $REALLY_ANDROID. Only disable termcap if building a GUI program.
+ # (bug#65340)
+ mingw32 | androidyes)
TERMINFO=no
LIBS_TERMCAP=
;;
@@ -5409,7 +6329,7 @@ AC_FUNC_FORK
dnl AC_CHECK_FUNCS_ONCE wouldn’t be right for snprintf, which needs
dnl the current CFLAGS etc.
-AC_CHECK_FUNCS([snprintf])
+AC_CHECK_FUNCS([snprintf open_memstream])
dnl posix_spawn. The chdir and setsid functionality is relatively
dnl recent, so we check for it specifically.
@@ -5460,29 +6380,21 @@ if test "${emacs_cv_links_glib}" = "yes"; then
fi
AC_SUBST([XGSELOBJ])
-dnl Adapted from Haible's version.
-AC_CACHE_CHECK([for nl_langinfo and CODESET], [emacs_cv_langinfo_codeset],
- [AC_LINK_IFELSE([AC_LANG_PROGRAM([[#include <langinfo.h>]],
- [[char *cs = nl_langinfo(CODESET);]])],
- [emacs_cv_langinfo_codeset=yes],
- [emacs_cv_langinfo_codeset=no])
- ])
-if test "$emacs_cv_langinfo_codeset" = yes; then
- AC_DEFINE([HAVE_LANGINFO_CODESET], [1],
- [Define if you have <langinfo.h> and nl_langinfo (CODESET).])
-
- AC_CACHE_CHECK([for nl_langinfo and _NL_PAPER_WIDTH],
- [emacs_cv_langinfo__nl_paper_width],
- [AC_LINK_IFELSE([AC_LANG_PROGRAM([[#include <langinfo.h>]],
- [[char *cs = nl_langinfo (_NL_PAPER_WIDTH);]])],
- [emacs_cv_langinfo__nl_paper_width=yes],
- [emacs_cv_langinfo__nl_paper_width=no])
- ])
- if test "$emacs_cv_langinfo__nl_paper_width" = yes; then
- AC_DEFINE([HAVE_LANGINFO__NL_PAPER_WIDTH], [1],
- [Define if you have <langinfo.h> and nl_langinfo (_NL_PAPER_WIDTH).])
- fi
-fi
+AC_DEFUN([EMACS_PAPER_WIDTH],
+ [AC_REQUIRE([AM_LANGINFO_CODESET])
+ AS_IF([test "$am_cv_langinfo_codeset" = yes],
+ [AC_CACHE_CHECK([for nl_langinfo and _NL_PAPER_WIDTH],
+ [emacs_cv_langinfo__nl_paper_width],
+ [AC_LINK_IFELSE([AC_LANG_PROGRAM([[#include <langinfo.h>]],
+ [[char *cs = nl_langinfo (_NL_PAPER_WIDTH);]])],
+ [emacs_cv_langinfo__nl_paper_width=yes],
+ [emacs_cv_langinfo__nl_paper_width=no])
+ ])
+ AS_IF([test "$emacs_cv_langinfo__nl_paper_width" = yes],
+ [AC_DEFINE([HAVE_LANGINFO__NL_PAPER_WIDTH], [1],
+ [Define if you have <langinfo.h>
+ and nl_langinfo (_NL_PAPER_WIDTH).])])])])
+EMACS_PAPER_WIDTH
AC_TYPE_MBSTATE_T
@@ -5667,7 +6579,7 @@ case $opsys in
esac
case $opsys in
- gnu-* | solaris )
+ gnu-* | android | solaris | cygwin )
dnl FIXME Can't we test if this exists (eg /proc/$$)?
AC_DEFINE([HAVE_PROCFS], [1], [Define if you have the /proc filesystem.])
;;
@@ -5767,6 +6679,25 @@ case $opsys in
AC_DEFINE([FIRST_PTY_LETTER], ['p'])
;;
+ android )
+ AC_DEFINE([PTY_ITERATION], [int i; for (i = 0; i < 1; ++i)])
+ dnl grantpt may be defined in libc but not declared. The same
+ dnl goes for posix_openpt. When that is the case, it means that
+ dnl grantpt or posix_openpt cannot actually be used.
+ AC_CHECK_DECLS([grantpt, posix_openpt])
+ AS_IF([test "x$ac_cv_have_decl_grantpt" = xyes],
+ [AC_DEFINE([PTY_TTY_NAME_SPRINTF],
+ [{ char *ptyname = 0; sigset_t blocked; sigemptyset (&blocked); sigaddset (&blocked, SIGCHLD); pthread_sigmask (SIG_BLOCK, &blocked, 0); if (grantpt (fd) != -1 && unlockpt (fd) != -1) ptyname = ptsname(fd); pthread_sigmask (SIG_UNBLOCK, &blocked, 0); if (!ptyname) { emacs_close (fd); return -1; } snprintf (pty_name, PTY_NAME_SIZE, "%s", ptyname); }])],
+ [AC_DEFINE([PTY_TTY_NAME_SPRINTF],
+ [{ char *ptyname = 0; sigset_t blocked; sigemptyset (&blocked); sigaddset (&blocked, SIGCHLD); pthread_sigmask (SIG_BLOCK, &blocked, 0); if (unlockpt (fd) != -1) ptyname = ptsname(fd); pthread_sigmask (SIG_UNBLOCK, &blocked, 0); if (!ptyname) { emacs_close (fd); return -1; } snprintf (pty_name, PTY_NAME_SIZE, "%s", ptyname); }])])
+ AS_IF([test "x$ac_cv_have_decl_posix_openpt" = xyes],
+ [AC_DEFINE([PTY_OPEN],
+ [do { fd = posix_openpt (O_RDWR | O_CLOEXEC | O_NOCTTY); if (fd < 0 && errno == EINVAL) fd = posix_openpt (O_RDWR | O_NOCTTY); } while (false)])
+ AC_DEFINE([PTY_NAME_SPRINTF], [])],
+ [AC_DEFINE([PTY_NAME_SPRINTF], [])
+ AC_DEFINE([PTY_OPEN], [fd = getpt ()])])
+ ;;
+
gnu-linux | gnu-kfreebsd | dragonfly | freebsd | openbsd | netbsd | darwin | nacl )
dnl if HAVE_GRANTPT
if test "x$ac_cv_func_grantpt" = xyes; then
@@ -6357,6 +7288,7 @@ if test "$emacs_cv_struct_alignment" = yes; then
structure to an N-byte boundary.])
fi
+AC_C_RESTRICT
AC_C_TYPEOF
AC_CACHE_CHECK([for statement expressions],
@@ -6431,7 +7363,7 @@ fi
# it temporarily reverts them to their pre-pkg-config values,
# because gnulib needs to work with both src (which uses the
# pkg-config stuff) and lib-src (which does not). For example, gnulib
-# may need to determine whether LIB_CLOCK_GETTIME should contain -lrt,
+# may need to determine whether CLOCK_TIME_LIB should contain -lrt,
# and it therefore needs to run in an environment where LIBS does not
# already contain -lrt merely because 'pkg-config --libs' printed '-lrt'
# for some package unrelated to lib-src.
@@ -6446,6 +7378,38 @@ gl_INIT
CFLAGS=$SAVE_CFLAGS
LIBS=$SAVE_LIBS
+# Set up libgmp on Android. Make sure to override what gnulib has
+# found.
+LIBGMP_CFLAGS=
+if test "$REALLY_ANDROID" = "yes" && test "$with_libgmp" != "no"; then
+ HAVE_LIBGMP=no
+ ndk_SEARCH_MODULE([libgmp], [LIBGMP], [HAVE_LIBGMP=yes])
+
+ if test "$HAVE_LIBGMP" = "yes"; then
+ SAVE_CFLAGS="$CFLAGS"
+ CFLAGS="$CFLAGS $LIBGMP_CFLAGS"
+ unset ac_cv_header_gmp_h
+ unset ac_cv_header_gmp_gmp_h
+ AC_CHECK_HEADERS([gmp.h gmp/gmp.h], [break])
+ CFLAGS="$SAVE_CFLAGS"
+ GL_GENERATE_GMP_H=
+ GL_GENERATE_GMP_H_CONDITION=
+ GL_GENERATE_GMP_GMP_H=
+ GL_GENERATE_GMP_GMP_H_CONDITION=
+ GL_GENERATE_MINI_GMP_H=
+ GL_GENERATE_MINI_GMP_H_CONDITION=
+
+ if test "$ac_cv_header_gmp_h" != "no" \
+ || test "$ac_cv_header_gmp_gmp_h" != "no"; then
+ HAVE_LIBGMP=yes
+ GL_GENERATE_GMP_H=false
+ LIBGMP="$LIBGMP_LIBS"
+ GMP_H=
+ fi
+ fi
+fi
+AC_SUBST([LIBGMP_CFLAGS])
+
# timer_getoverrun needs the same library as timer_settime
OLD_LIBS=$LIBS
LIBS="$LIB_TIMER_TIME $LIBS"
@@ -6507,6 +7471,8 @@ case "$opsys" in
mingw32)
## Is it any better under MinGW64 to relocate emacs into higher addresses?
+ ## If the values of -image-base are modified, the corresponding
+ ## values of DEFAULT_IMAGE_BASE in w32fns.c should be kept in sync.
case "$canonical" in
x86_64-*-*) LD_SWITCH_SYSTEM_TEMACS="-Wl,-stack,0x00800000 -Wl,-heap,0x00100000 -Wl,-image-base,0x400000000 -Wl,-entry,__start -Wl,-Map,./temacs.map" ;;
*) LD_SWITCH_SYSTEM_TEMACS="-Wl,-stack,0x00800000 -Wl,-heap,0x00100000 -Wl,-image-base,0x01000000 -Wl,-entry,__start -Wl,-Map,./temacs.map" ;;
@@ -6571,10 +7537,45 @@ if test "$window_system" != "none"; then
AC_DEFINE([POLL_FOR_INPUT], [1],
[Define if you poll periodically to detect C-g.])
WINDOW_SYSTEM_OBJ="fontset.o fringe.o image.o"
+
+ if test "$window_system" = "x11" || test "$REALLY_ANDROID" = "yes"; then
+ AC_DEFINE([HAVE_TEXT_CONVERSION], [1],
+ [Define if the window system has text conversion support.])
+ WINDOW_SYSTEM_OBJ="$WINDOW_SYSTEM_OBJ textconv.o"
+ fi
fi
AC_SUBST([WINDOW_SYSTEM_OBJ])
+# Some systems have MB_CUR_MAX defined to a call to
+# __ctype_get_mb_cur_max, but do not have __ctype_get_mb_cur_max in
+# libc. Check for that situation and define MB_CUR_MAX to something
+# sane.
+
+AC_CHECK_FUNC([__ctype_get_mb_cur_max])
+
+AC_CACHE_CHECK([whether MB_CUR_MAX is defined to function that won't link],
+ [emacs_cv_broken_mb_cur_max],
+ [AC_EGREP_CPP(__ctype_get_mb_cur_max, [
+#include <stdlib.h>
+#ifndef MB_CUR_MAX
+#define MB_CUR_MAX -1
+#endif
+static int foo = MB_CUR_MAX;
+], [AS_IF([test "$ac_cv_func___ctype_get_mb_cur_max" = "yes"],
+ [emacs_cv_broken_mb_cur_max=no],
+ [emacs_cv_broken_mb_cur_max=yes])],
+ [emacs_cv_broken_mb_cur_max=no])])
+
+AS_IF([test "$emacs_cv_broken_mb_cur_max" = "yes"],
+ # Define this to 4, which is right for Android.
+ [AS_CASE([$opsys], [android],
+ [AC_DEFINE([REPLACEMENT_MB_CUR_MAX], [4],
+ [Define to MB_CUR_MAX if stdlib.h is broken.])],
+ [AC_MSG_ERROR([MB_CUR_MAX does not work on your system.
+Please modify configure.ac to set an appropriate value, then
+send your change to bug-gnu-emacs@gnu.org])])])
+
AH_TOP([/* GNU Emacs site configuration template file.
Copyright (C) 1988, 1993-1994, 1999-2002, 2004-2021
@@ -6623,7 +7624,9 @@ if test "${HAVE_GTK}" = "yes"; then
fi
if test $USE_ACL -ne 0; then
- ACL_SUMMARY="yes $LIB_ACL"
+ ACL_SUMMARY="yes"
+ test "$LIB_ACL" && ACL_SUMMARY="$ACL_SUMMARY $LIB_ACL"
+ test "$LIB_XATTR" && ACL_SUMMARY="$ACL_SUMMARY $LIB_XATTR"
else
ACL_SUMMARY=no
fi
@@ -6693,7 +7696,13 @@ done
AC_DEFINE_UNQUOTED([EMACS_CONFIG_FEATURES], ["${emacs_config_features}"],
[Summary of some of the main features enabled by configure.])
+# This is just a printable representation of the shared user ID.
+android_shared_user=
+AS_IF([test -n "$with_shared_user_id"],[android_shared_user="($with_shared_user_id)"])
+
AS_ECHO([" Does Emacs use -lXaw3d? ${HAVE_XAW3D}
+ Is Emacs being built for Android? ${ANDROID} ${android_shared_user}
+ Does Emacs use the X Double Buffer Extension? ${HAVE_XDBE}
Does Emacs use -lXpm? ${HAVE_XPM}
Does Emacs use -ljpeg? ${HAVE_JPEG}
Does Emacs use -ltiff? ${HAVE_TIFF}
@@ -6797,12 +7806,15 @@ fi
AC_CONFIG_FILES([Makefile lib/gnulib.mk])
dnl config.status treats $srcdir specially, so I think this is ok...
-AC_CONFIG_FILES([$srcdir/doc/man/emacs.1])
+ARCH_INDEPENDENT_CONFIG_FILES([$srcdir/doc/man/emacs.1])
+
+AC_CONFIG_FILES([lib/Makefile lib-src/Makefile oldXMenu/Makefile src/Makefile
+ lwlib/Makefile nextstep/Makefile nt/Makefile])
+ARCH_INDEPENDENT_CONFIG_FILES([doc/emacs/Makefile doc/misc/Makefile
+ doc/lispintro/Makefile doc/lispref/Makefile
+ lisp/Makefile leim/Makefile])
-m4_define([subdir_makefiles],
- [lib/Makefile lib-src/Makefile oldXMenu/Makefile doc/emacs/Makefile doc/misc/Makefile doc/lispintro/Makefile doc/lispref/Makefile src/Makefile lwlib/Makefile lisp/Makefile leim/Makefile nextstep/Makefile nt/Makefile])
-SUBDIR_MAKEFILES="subdir_makefiles"
-AC_CONFIG_FILES(subdir_makefiles)
+SUBDIR_MAKEFILES="lib/Makefile lib-src/Makefile oldXMenu/Makefile src/Makefile lwlib/Makefile nextstep/Makefile nt/Makefile doc/emacs/Makefile doc/misc/Makefile doc/lispintro/Makefile doc/lispref/Makefile lisp/Makefile leim/Makefile"
dnl The test/ directory is missing if './make-dist --no-tests' was used.
opt_makefile=test/Makefile
@@ -6810,24 +7822,27 @@ if test -f "$srcdir/$opt_makefile.in"; then
SUBDIR_MAKEFILES="$SUBDIR_MAKEFILES $opt_makefile"
dnl Again, it's best not to use a variable. Though you can add
dnl ", [], [opt_makefile='$opt_makefile']" and it should work.
- AC_CONFIG_FILES([test/Makefile])
- AC_CONFIG_FILES([test/manual/noverlay/Makefile])
+ ARCH_INDEPENDENT_CONFIG_FILES([test/Makefile])
+ ARCH_INDEPENDENT_CONFIG_FILES([test/manual/noverlay/Makefile])
fi
opt_makefile=test/infra/Makefile
if test -f "$srcdir/$opt_makefile.in"; then
SUBDIR_MAKEFILES="$SUBDIR_MAKEFILES $opt_makefile"
dnl Again, it's best not to use a variable. Though you can add
dnl ", [], [opt_makefile='$opt_makefile']" and it should work.
- AC_CONFIG_FILES([test/infra/Makefile])
+ ARCH_INDEPENDENT_CONFIG_FILES([test/infra/Makefile])
fi
+if test "$ANDROID" = "yes"; then
+ SUBDIR_MAKEFILES="$SUBDIR_MAKEFILES java/Makefile cross/Makefile"
+fi
dnl The admin/ directory used to be excluded from tarfiles.
if test -d $srcdir/admin; then
SUBDIR_MAKEFILES="$SUBDIR_MAKEFILES admin/charsets/Makefile admin/unidata/Makefile admin/grammars/Makefile"
- AC_CONFIG_FILES([admin/charsets/Makefile])
- AC_CONFIG_FILES([admin/unidata/Makefile])
- AC_CONFIG_FILES([admin/grammars/Makefile])
+ ARCH_INDEPENDENT_CONFIG_FILES([admin/charsets/Makefile])
+ ARCH_INDEPENDENT_CONFIG_FILES([admin/unidata/Makefile])
+ ARCH_INDEPENDENT_CONFIG_FILES([admin/grammars/Makefile])
fi dnl -d admin
@@ -6838,64 +7853,112 @@ AC_SUBST([SUBDIR_MAKEFILES_IN])
SMALL_JA_DIC=$with_small_ja_dic
AC_SUBST([SMALL_JA_DIC])
-dnl You might wonder (I did) why epaths.h is generated by running make,
-dnl rather than just letting configure generate it from epaths.in.
-dnl One reason is that the various paths are not fully expanded (see above);
-dnl e.g., gamedir='${localstatedir}/games/emacs'.
-dnl Secondly, the GNU Coding standards require that one should be able
-dnl to run 'make prefix=/some/where/else' and override the values set
-dnl by configure. This also explains the 'move-if-change' test and
-dnl the use of force in the 'epaths-force' rule in Makefile.in.
-AC_CONFIG_COMMANDS([src/epaths.h], [
-if test "${opsys}" = "mingw32"; then
- ${MAKE-make} MAKEFILE_NAME=do-not-make-Makefile epaths-force-w32
-elif test "$HAVE_NS" = "yes" && test "$EN_NS_SELF_CONTAINED" = "yes"; then
- ${MAKE-make} MAKEFILE_NAME=do-not-make-Makefile epaths-force-ns-self-contained
-else
- ${MAKE-make} MAKEFILE_NAME=do-not-make-Makefile epaths-force
-fi || AC_MSG_ERROR(['src/epaths.h' could not be made.])
-], [GCC="$GCC" CPPFLAGS="$CPPFLAGS" opsys="$opsys" HAVE_NS="$HAVE_NS"
- EN_NS_SELF_CONTAINED="$EN_NS_SELF_CONTAINED"])
-
-dnl NB we have to cheat and use the ac_... version because abs_top_srcdir
-dnl is not yet set, sigh. Or we could use ../$srcdir/src/.gdbinit,
-dnl or a symlink?
-AC_CONFIG_COMMANDS([src/.gdbinit], [
-if test ! -f src/.gdbinit && test -f "$srcdir/src/.gdbinit"; then
- AS_ECHO(["source $ac_abs_top_srcdir/src/.gdbinit"]) > src/.gdbinit
-fi
-])
+dnl The following commands are run on the build system when building
+dnl Emacs.
+
+if test "$XCONFIGURE" != "android"; then
+ dnl You might wonder (I did) why epaths.h is generated by running
+ dnl make, rather than just letting configure generate it from
+ dnl epaths.in. One reason is that the various paths are not fully
+ dnl expanded (see above); e.g.,
+ dnl gamedir='${localstatedir}/games/emacs'. Secondly, the GNU
+ dnl Coding standards require that one should be able to run 'make
+ dnl prefix=/some/where/else' and override the values set by
+ dnl configure. This also explains the 'move-if-change' test and the
+ dnl use of force in the 'epaths-force' rule in Makefile.in.
+ AC_CONFIG_COMMANDS([src/epaths.h], [
+ if test "${opsys}" = "mingw32"; then
+ ${MAKE-make} MAKEFILE_NAME=do-not-make-Makefile epaths-force-w32
+ elif test "$HAVE_NS" = "yes" && test "$EN_NS_SELF_CONTAINED" = "yes"; then
+ ${MAKE-make} MAKEFILE_NAME=do-not-make-Makefile epaths-force-ns-self-contained
+ else
+ ${MAKE-make} MAKEFILE_NAME=do-not-make-Makefile epaths-force
+ fi || AC_MSG_ERROR(['src/epaths.h' could not be made.])
+ ], [GCC="$GCC" CPPFLAGS="$CPPFLAGS" opsys="$opsys" HAVE_NS="$HAVE_NS"
+ EN_NS_SELF_CONTAINED="$EN_NS_SELF_CONTAINED"])
+
+ dnl NB we have to cheat and use the ac_... version because abs_top_srcdir
+ dnl is not yet set, sigh. Or we could use ../$srcdir/src/.gdbinit,
+ dnl or a symlink?
+ AC_CONFIG_COMMANDS([src/.gdbinit], [
+ if test ! -f src/.gdbinit && test -f "$srcdir/src/.gdbinit"; then
+ AS_ECHO(["source $ac_abs_top_srcdir/src/.gdbinit"]) > src/.gdbinit
+ fi
+ ])
-dnl Perhaps this would be better named doc-emacs-emacsver.texi?
-dnl See comments for etc-refcards-emacsver.tex.
-dnl Since we get a doc/emacs directory generated anyway, for the Makefile,
-dnl it is not quite the same. But we are generating in $srcdir.
-AC_CONFIG_COMMANDS([doc/emacs/emacsver.texi], [
-${MAKE-make} -s --no-print-directory -C doc/emacs doc-emacsver || \
-AC_MSG_ERROR(['doc/emacs/emacsver.texi' could not be made.])
-])
+ dnl Perhaps this would be better named doc-emacs-emacsver.texi?
+ dnl See comments for etc-refcards-emacsver.tex.
+ dnl Since we get a doc/emacs directory generated anyway, for the Makefile,
+ dnl it is not quite the same. But we are generating in $srcdir.
+ AC_CONFIG_COMMANDS([doc/emacs/emacsver.texi], [
+ ${MAKE-make} -s --no-print-directory -C doc/emacs doc-emacsver || \
+ AC_MSG_ERROR(['doc/emacs/emacsver.texi' could not be made.])
+ ])
-dnl If we give this the more natural name, etc/refcards/emacsver.texi,
-dnl then a directory etc/refcards is created in the build directory,
-dnl which is probably harmless, but confusing (in out-of-tree builds).
-dnl (If we were to generate etc/refcards/Makefile, this might change.)
-dnl It is really $srcdir/etc/refcards/emacsver.tex that we generate.
-AC_CONFIG_COMMANDS([etc-refcards-emacsver.tex], [
-${MAKE-make} -s MAKEFILE_NAME=do-not-make-Makefile etc-emacsver || \
-AC_MSG_ERROR(['etc/refcards/emacsver.tex' could not be made.])
-])
+ dnl If we give this the more natural name, etc/refcards/emacsver.texi,
+ dnl then a directory etc/refcards is created in the build directory,
+ dnl which is probably harmless, but confusing (in out-of-tree builds).
+ dnl (If we were to generate etc/refcards/Makefile, this might change.)
+ dnl It is really $srcdir/etc/refcards/emacsver.tex that we generate.
+ AC_CONFIG_COMMANDS([etc-refcards-emacsver.tex], [
+ ${MAKE-make} -s MAKEFILE_NAME=do-not-make-Makefile etc-emacsver || \
+ AC_MSG_ERROR(['etc/refcards/emacsver.tex' could not be made.])
+ ])
-if test $AUTO_DEPEND = yes; then
- for dir in $AUTODEPEND_PARENTS; do
- AS_MKDIR_P([$dir/deps])
- done
-fi
-if $gl_gnulib_enabled_dynarray || $gl_gnulib_enabled_scratch_buffer; then
- AS_MKDIR_P([lib/malloc])
if test $AUTO_DEPEND = yes; then
- AS_MKDIR_P([lib/deps/malloc])
+ for dir in $AUTODEPEND_PARENTS; do
+ AS_MKDIR_P([$dir/deps])
+ AS_MKDIR_P([cross/$dir/deps])
+ done
fi
-fi
+ if $gl_gnulib_enabled_dynarray || $gl_gnulib_enabled_scratch_buffer; then
+ AS_MKDIR_P([lib/malloc])
+ AS_MKDIR_P([cross/lib/malloc])
+ if test $AUTO_DEPEND = yes; then
+ AS_MKDIR_P([lib/deps/malloc])
+ AS_MKDIR_P([cross/lib/deps/malloc])
+ fi
+ fi
+
+ dnl Make cross/lib, which various Makefiles in cross expect to
+ dnl always exist.
+ AS_MKDIR_P([cross/lib])
+ AS_MKDIR_P([cross/lib/malloc])
+ AS_MKDIR_P([cross/lib/sys])
+ AS_MKDIR_P([cross/lib-src])
+
+ dnl Make cross/etc; this directory will hold the documentation file
+ dnl holding doc strings for Android specific C files that aren't
+ dnl built during the initial compilation of Emacs for the build
+ dnl machine.
+ AS_MKDIR_P([cross/etc])
+
+ AS_IF([test "x$with_android" != "xno"], [
+ dnl Link gnulib files to cross/lib as well. af_alg.h and
+ dnl lib/save-cwd.h are copied manually from gnulib, and as such
+ dnl aren't specified in gl_FILE_LIST.
+ emacs_files='gl_FILE_LIST lib/af_alg.h lib/save-cwd.h'
+ dnl These files are specific to Emacs.
+ emacs_files="$emacs_files lib/fingerprint.c lib/fingerprint.h \
+ lib/save-cwd.c lib/openat-die.c lib/save-cwd.c \
+ lib/min-max.h"
+ for file in $emacs_files; do
+ AS_IF([expr "X${file}J" : "Xlib/.*[[ch]]J" >/dev/null],
+ [AS_IF([test -f "$srcdir/$file"],
+ [AC_CONFIG_LINKS([cross/$file:$file])])])
+ done])
+fi
+
+# Make java/Makefile
+ARCH_INDEPENDENT_CONFIG_FILES([java/Makefile])
+ARCH_INDEPENDENT_CONFIG_FILES([cross/Makefile])
+
+# Make java/AndroidManifest.xml
+ARCH_INDEPENDENT_CONFIG_FILES([java/AndroidManifest.xml])
+
+# Make ndk-build Makefiles. This is only done inside the recursive
+# configure.
+ndk_CONFIG_FILES
AC_OUTPUT
diff --git a/cross/Makefile.in b/cross/Makefile.in
new file mode 100644
index 00000000000..6f2250fe02f
--- /dev/null
+++ b/cross/Makefile.in
@@ -0,0 +1,194 @@
+### @configure_input@
+
+# Copyright (C) 2023-2024 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 <https://www.gnu.org/licenses/>.
+
+top_srcdir = @top_srcdir@
+srcdir = @srcdir@
+top_builddir = @top_builddir@
+builddir = @builddir@
+
+FIND_DELETE = @FIND_DELETE@
+
+-include $(top_builddir)/src/verbose.mk
+
+# Cross-compiling Emacs for Android.
+
+# The cross compiled binaries are built by having ``variant''
+# Makefiles generated at configure-time. First,
+# $(top_builddir)/src/Makefile.android,
+# $(top_builddir)/lib/Makefile.android,
+# $(top_builddir)/lib/gnulib.mk.android and
+# $(top_builddir)/lib-src/Makefile.android are copied to their usual
+# locations in this directory.
+
+# N.B. that LIB_SRCDIR is actually relative to builddir, because that
+# is where the gnulib files get linked.
+
+LIB_SRCDIR = $(realpath $(builddir)/lib)
+LIB_TOP_SRCDIR = $(realpath $(top_srcdir))
+
+SRC_SRCDIR = $(realpath $(top_srcdir)/src)
+SRC_TOP_SRCDIR = $(realpath $(top_srcdir))
+
+LIB_SRC_SRCDIR = $(realpath $(top_srcdir)/lib-src)
+LIB_SRC_TOP_SRCDIR = $(realpath $(top_src))
+
+# This is a list of binaries to build and install in lib-src.
+
+LIBSRC_BINARIES = lib-src/etags lib-src/ctags lib-src/emacsclient \
+ lib-src/ebrowse lib-src/hexl lib-src/movemail
+
+CLEAN_SUBDIRS = $(wildcard src lib-src lib etc)
+
+.PHONY: all
+all: lib/libgnu.a src/libemacs.so src/android-emacs $(LIBSRC_BINARIES)
+
+# This Makefile relies on builddir and top_builddir being relative
+# paths in *.android.
+
+# This file is used to tell lib/gnulib.mk when
+# $(top_builddir)/config.status changes.
+config.status: $(top_builddir)/config.status
+ $(AM_V_GEN) touch config.status
+
+src/verbose.mk: $(srcdir)/verbose.mk.android
+ $(AM_V_SILENT) cp -f $(srcdir)/verbose.mk.android \
+ src/verbose.mk
+
+# Gnulib, make-fingerprint and make-docfile must be built before
+# entering any of the rules below, or they will get the Android
+# versions of many headers.
+
+.PHONY: $(top_builddir)/lib/libgnu.a
+$(top_builddir)/lib/libgnu.a:
+ $(MAKE) -C $(top_builddir)/lib libgnu.a
+
+.PHONY: $(top_builddir)/lib-src/make-fingerprint
+$(top_builddir)/lib-src/make-fingerprint: $(top_builddir)/lib/libgnu.a
+ $(MAKE) -C $(top_builddir)/lib-src make-fingerprint
+
+.PHONY: $(top_builddir)/lib-src/make-docfile
+$(top_builddir)/lib-src/make-docfile: $(top_builddir)/lib/libgnu.a
+ $(MAKE) -C $(top_builddir)/lib-src make-docfile
+
+PRE_BUILD_DEPS=$(top_builddir)/lib/libgnu.a \
+ $(top_builddir)/lib-src/make-fingerprint \
+ $(top_builddir)/lib-src/make-docfile
+
+lib/config.h: $(top_builddir)/src/config.h.android
+ $(AM_V_GEN) cp -f -p $(top_builddir)/src/config.h.android \
+ lib/config.h
+
+lib-src/config.h: $(top_builddir)/src/config.h.android
+ $(AM_V_GEN) cp -f -p $(top_builddir)/src/config.h.android \
+ lib-src/config.h
+
+# Figure out where build-aux is.
+# Then, replace the build-aux directory with its actual location,
+# in case MKDIR_P points there.
+
+relative_buildaux_dir := $(subst /,\/,$(top_srcdir)/build-aux)
+
+lib/gnulib.mk: $(top_builddir)/lib/gnulib.mk.android
+ $(AM_V_GEN) \
+ sed -e 's/^srcdir =.*$$/srcdir = $(subst /,\/,$(LIB_SRCDIR))/g' \
+ -e 's/$(relative_buildaux_dir)/$(subst /,\/,../$(top_builddir))\/build-aux/g' \
+ < $(top_builddir)/lib/gnulib.mk.android > $@
+
+lib/Makefile: $(top_builddir)/lib/Makefile.android
+ $(AM_V_GEN) \
+ sed -e 's/^top_srcdir =.*$$/top_srcdir = $(subst /,\/,$(LIB_TOP_SRCDIR))/g' \
+ -e 's/^srcdir =.*$$/srcdir = $(subst /,\/,$(LIB_SRCDIR))/g' \
+ -e 's/^VPATH =.*$$/VPATH = $(subst /,\/,$(LIB_SRCDIR))/g' \
+ < $(top_builddir)/lib/Makefile.android > $@
+
+# What is needed to build gnulib.
+LIB_DEPS = lib/config.h lib/gnulib.mk lib/Makefile
+
+.PHONY: lib/libgnu.a
+lib/libgnu.a: src/verbose.mk config.status $(LIB_DEPS) $(PRE_BUILD_DEPS)
+ $(MAKE) -C lib libgnu.a
+
+# Edit srcdir and top_srcdir to the right locations.
+# Edit references to ../admin/unidata to read ../../admin/unidata.
+# Next, edit libsrc to the location at top_srcdir! It is important
+# that src/Makefile uses the binaries there, instead of any
+# cross-compiled binaries at ./lib-src.
+# Edit out anything saying -I($(top_srcdir)/lib) into
+# -I$../(srcdir)/lib; that should be covered by -I$(lib)
+
+src/Makefile: $(top_builddir)/src/Makefile.android
+ $(AM_V_GEN) \
+ sed -e 's/^srcdir =.*$$/srcdir = $(subst /,\/,$(SRC_SRCDIR))/g' \
+ -e 's/^top_srcdir =.*$$/top_srcdir = $(subst /,\/,$(LIB_TOP_SRCDIR))/g' \
+ -e 's/\.\.\/admin\/unidata/..\/..\/admin\/unidata/g' \
+ -e 's/\.\.\/admin\/charsets/..\/..\/admin\/charsets/g' \
+ -e 's/^libsrc =.*$$/libsrc = \.\.\/\.\.\/lib-src/g' \
+ -e 's/libsrc =.*$$/libsrc = \.\.\/\.\.\/lib-src/g' \
+ -e 's/-I\$$(top_srcdir)\/lib/-I..\/$(subst /,\/,$(srcdir))\/lib/g' \
+ < $(top_builddir)/src/Makefile.android > $@
+
+src/config.h: $(top_builddir)/src/config.h.android
+ $(AM_V_GEN) cp -f -p $< $@
+
+.PHONY: src/android-emacs src/libemacs.so
+
+src/libemacs.so: src/Makefile src/config.h src/verbose.mk \
+ lib/libgnu.a $(PRE_BUILD_DEPS)
+ $(MAKE) -C src libemacs.so
+
+src/android-emacs: src/Makefile src/config.h lib/libgnu.a \
+ $(PRE_BUILD_DEPS)
+ $(MAKE) -C src android-emacs
+
+# Edit out SCRIPTS, it interferes with the build.
+# Make BASE_CFLAGS also include cross/lib as well as ../lib.
+
+lib-src/Makefile: $(top_builddir)/lib-src/Makefile.android
+ $(AM_V_GEN) \
+ sed -e 's/-I\$${srcdir}\/\.\.\/lib//g' \
+ -e 's/^srcdir=.*$$/srcdir = $(subst /,\/,$(LIB_SRC_SRCDIR))/g' \
+ -e 's/^top_srcdir=.*$$/top_srcdir = $(subst /,\/,$(LIB_SRC_TOP_SRCDIR))/g' \
+ -e 's/^SCRIPTS=.*$$/SCRIPTS=/g' \
+ -e 's/-I\.\.\/lib/-I..\/lib -I..\/$(subst /,\/,$(srcdir))\/lib/g' \
+ < $(top_builddir)/lib-src/Makefile.android > $@
+
+.PHONY: $(LIBSRC_BINARIES)
+$(LIBSRC_BINARIES) &: src/verbose.mk $(top_builddir)/$@ lib/libgnu.a \
+ lib-src/config.h lib-src/Makefile $(PRE_BUILD_DEPS)
+# Finally, go into lib-src and make everything being built
+ $(MAKE) -C lib-src $(foreach bin,$(LIBSRC_BINARIES),$(notdir $(bin)))
+
+.PHONY: clean maintainer-clean distclean
+clean:
+ for dir in $(CLEAN_SUBDIRS); do \
+ find $$dir -type f $(FIND_DELETE); \
+ done
+ rm -rf lib/config.h lib-src/config.h
+# ndk-build won't have been generated in a non-Android build.
+ if test -f ndk-build/Makefile; then \
+ $(MAKE) -C ndk-build clean; \
+ fi
+
+maintainer-clean distclean bootstrap-clean: clean
+# Remove links created by configure.
+ for dir in $(CLEAN_SUBDIRS); do \
+ find $$dir -type l $(FIND_DELETE); \
+ done
+ rm -rf lib/Makefile lib/gnulib.mk ndk-build/Makefile
+ rm -rf ndk-build/ndk-build.mk Makefile
diff --git a/cross/README b/cross/README
new file mode 100644
index 00000000000..3ec6f2c0b3c
--- /dev/null
+++ b/cross/README
@@ -0,0 +1,5 @@
+This directory holds Makefiles and other required assets to build an
+Emacs binary independently for another toolchain.
+
+The directory ndk-build also contains an implementation of the Android
+`ndk-build' build system.
diff --git a/cross/langinfo.h b/cross/langinfo.h
new file mode 100644
index 00000000000..0edb0082bda
--- /dev/null
+++ b/cross/langinfo.h
@@ -0,0 +1,20 @@
+/* Replacement langinfo.h file for building GNU Emacs on Android.
+
+Copyright (C) 2023-2024 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 <https://www.gnu.org/licenses/>. */
+
+#define nl_langinfo(ignore) "ASCII"
diff --git a/cross/ndk-build/Makefile.in b/cross/ndk-build/Makefile.in
new file mode 100644
index 00000000000..0970a765b45
--- /dev/null
+++ b/cross/ndk-build/Makefile.in
@@ -0,0 +1,148 @@
+### @configure_input@
+
+# Copyright 2023-2024 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 <https://www.gnu.org/licenses/>.
+
+# ndk-build works by including a bunch of Makefiles which set
+# variables, and then having those Makefiles include another makefile
+# which actually builds targets.
+
+ srcdir = @srcdir@
+
+# This is a list of Android.mk files which provide targets.
+ NDK_BUILD_ANDROID_MK = @NDK_BUILD_ANDROID_MK@
+ NDK_BUILD_ARCH = @NDK_BUILD_ARCH@
+ NDK_BUILD_ABI = @NDK_BUILD_ABI@
+ NDK_BUILD_SDK = @NDK_BUILD_SDK@
+ NDK_BUILD_CC = @NDK_BUILD_CC@
+ NDK_BUILD_CXX = @NDK_BUILD_CXX@
+ NDK_BUILD_CXX_STL = @NDK_BUILD_CXX_STL@
+NDK_BUILD_CXX_LDFLAGS = @NDK_BUILD_CXX_LDFLAGS@
+ NDK_BUILD_AR = @NDK_BUILD_AR@
+ NDK_BUILD_NASM = @NDK_BUILD_NASM@
+ NDK_BUILD_CFLAGS = @NDK_BUILD_CFLAGS@
+
+# This is a list of targets to build.
+ NDK_BUILD_MODULES = @NDK_BUILD_MODULES@
+
+# This is set by the Android in tree build system and is used by some
+# libraries to look for the NDK. Its value is unimportant.
+ NDK_ROOT = /tmp/
+
+# Finally, here are rules common to Emacs.
+.PHONY: all
+all: $(NDK_BUILD_MODULES)
+
+define uniqify
+$(if $1,$(firstword $1) $(call uniqify,$(filter-out $(firstword $1),$1)))
+endef
+
+# Remove duplicate files.
+NDK_BUILD_ANDROID_MK := $(call uniqify,$(NDK_BUILD_ANDROID_MK))
+
+# Remove duplicate modules as well. These can occur when a single
+# module imports a module and also declares it in
+# LOCAL_SHARED_LIBRARIES.
+NDK_BUILD_MODULES := $(call uniqify,$(NDK_BUILD_MODULES))
+
+# Define CFLAGS for compiling C++ code; this involves removing all
+# -std=NNN options and inserting compilation options for the C++
+# library.
+NDK_BUILD_CFLAGS_CXX := $(filter-out -std=%,$(NDK_BUILD_CFLAGS)) \
+ $(NDK_BUILD_CXX_STL)
+
+define subr-1
+
+# Define ndk-build functions. Many of these are identical to those in
+# build-aux/ndk-build-helper.mk.
+
+# NDK_LAST_MAKEFILE is the last Makefile that was included.
+NDK_LAST_MAKEFILE = $$(lastword $$(filter %Android.mk,$$(MAKEFILE_LIST)))
+
+# local-makefile is the current Makefile being loaded.
+local-makefile = $$(NDK_LAST_MAKEFILE)
+
+# my-dir is a function that returns the Android module directory. If
+# no Android.mk has been loaded, use the directory of the Makefile
+# being included.
+my-dir = $$(or $$(and $$(local-makefile),$$(dir $$(local-makefile))),$(dir $(1)))
+
+# Return all Android.mk files under the first arg.
+all-makefiles-under = $$(wildcard $$(1)/*/Android.mk)
+
+# Return all Android.mk files in subdirectories of this Makefile's
+# location.
+all-subdir-makefiles = $$(call all-makefiles-under,$$(call my-dir))
+
+# NDK-defined include variables.
+
+CLEAR_VARS = $(srcdir)/ndk-clear-vars.mk
+BUILD_EXECUTABLE = $(srcdir)/ndk-build-executable.mk
+BUILD_SHARED_LIBRARY = $(srcdir)/ndk-build-shared-library.mk
+BUILD_STATIC_LIBRARY = $(srcdir)/ndk-build-static-library.mk
+PREBUILT_SHARED_LIBRARY = $(srcdir)/ndk-prebuilt-shared-library.mk
+PREBUILT_STATIC_LIBRARY = $(srcdir)/ndk-prebuilt-static-library.mk
+
+# Target information variables.
+
+TARGET_ARCH = $(NDK_BUILD_ARCH)
+TARGET_PLATFORM = android-$(NDK_BUILD_SDK)
+TARGET_ARCH_ABI = $(NDK_BUILD_ABI)
+TARGET_ABI = $(TARGET_PLATFORM)-$(TARGET_ABI)
+
+# Module description variables. These are defined by Android.mk.
+LOCAL_PATH :=
+LOCAL_MODULE :=
+LOCAL_MODULE_FILENAME :=
+LOCAL_SRC_FILES :=
+LOCAL_CPP_EXTENSION :=
+LOCAL_CPP_FEATURES :=
+LOCAL_C_INCLUDES :=
+LOCAL_CFLAGS :=
+LOCAL_CPPFLAGS :=
+LOCAL_STATIC_LIBRARIES :=
+LOCAL_SHARED_LIBRARIES :=
+LOCAL_WHOLE_STATIC_LIBRARIES :=
+LOCAL_LDLIBS :=
+LOCAL_LDFLAGS :=
+LOCAL_ALLOW_UNDEFINED_SYMBOLS :=
+LOCAL_ARM_MODE :=
+LOCAL_ARM_NEON :=
+LOCAL_DISABLE_FORMAT_STRING_CHECKS :=
+LOCAL_EXPORT_CFLAGS :=
+LOCAL_EXPORT_CPPFLAGS :=
+LOCAL_EXPORT_C_INCLUDES :=
+LOCAL_EXPORT_LDFLAGS :=
+LOCAL_EXPORT_LDLIBS :=
+LOCAL_ASM_RULE_DEFINED :=
+LOCAL_ASM_RULE :=
+
+# Now load Android.mk.
+include $(1)
+
+endef
+
+# Now define rules for each Android.mk file.
+$(foreach android_mk,$(NDK_BUILD_ANDROID_MK),$(eval $(call subr-1,$(android_mk))))
+
+.PHONY: clean mostlyclean
+clean mostlyclean:
+ rm -rf *.o *.so *.a
+
+.PHONY: extraclean dist-clean maintainer-clean
+extraclean dist-clean maintainer-clean:
+ rm -rf Makefile
diff --git a/cross/ndk-build/README b/cross/ndk-build/README
new file mode 100644
index 00000000000..84a131443c4
--- /dev/null
+++ b/cross/ndk-build/README
@@ -0,0 +1,353 @@
+NDK BUILD SYSTEM IMPLEMENTATION
+
+Copyright (C) 2023-2024 Free Software Foundation, Inc.
+See the end of the file for license conditions.
+
+Emacs implements ndk-build itself, because the version that comes with
+the Android NDK is not easy to use from another Makefile, and keeps
+accumulating incompatible changes.
+
+The Emacs implementation of ndk-build consists of one m4 file:
+
+ m4/ndk-build.m4
+
+four Makefiles in build-aux, run during configure:
+
+ build-aux/ndk-build-helper-1.mk
+ build-aux/ndk-build-helper-2.mk
+ build-aux/ndk-build-helper-3.mk
+ build-aux/ndk-build-helper.mk
+
+one awk script in build-awx, run during configure:
+
+ build-aux/ndk-module-extract.awk
+
+seven Makefiles in cross/ndk-build,
+
+ cross/ndk-build/ndk-build-shared-library.mk
+ cross/ndk-build/ndk-build-static-library.mk
+ cross/ndk-build/ndk-build-executable.mk
+ cross/ndk-build/ndk-clear-vars.mk
+ cross/ndk-build/ndk-prebuilt-shared-library.mk
+ cross/ndk-build/ndk-prebuilt-static-library.mk
+ cross/ndk-build/ndk-resolve.mk
+
+and finally, two more Makefiles in cross/ndk-build, generated by
+configure:
+
+ cross/ndk-build/Makefile (generated from cross/ndk-build/Makefile.in)
+ cross/ndk-build/ndk-build.mk (generated from cross/ndk-build/ndk-build.mk.in)
+
+m4/ndk-build.m4 is a collection of macros which are used by the
+configure script to set up the ndk-build system, look for modules, add
+the appropriate options to LIBS and CFLAGS, and generate the Makefiles
+necessary to build the rest of Emacs.
+
+Immediately after determining the list of directories in which to look
+for ``Android.mk'' files, the version and type of Android system being
+built for, configure calls:
+
+ ndk_INIT([$android_abi], [$ANDROID_SDK], [cross/ndk-build])
+
+This expands to a sequence of shell script that enumerates all of the
+Android.mk files specified in "$with_ndk_path", sets up some shell
+functions used by the rest of the ndk-build code run by the configure
+script, and teaches the ndk-build system that the Makefiles to be
+generated are found in the directory "cross/ndk-build/Makefile".
+
+When configure is cross-compiling for Android, the macro
+EMACS_CHECK_MODULES will expand to the macro ndk_CHECK_MODULES,
+instead of pkg-config.m4's PKG_CHECK_MODULES. Thus, the following
+code:
+
+ EMACS_CHECK_MODULES([PNG], [libpng >= 1.0.0])
+
+will actually expand to:
+
+ ndk_CHECK_MODULES([PNG], [libpng >= 1.0.0], [HAVE_PNG=yes],
+ [HAVE_PNG=no])
+
+which in turn expands to a sequence shell script that first invokes:
+
+ make -f build-aux/ndk-build-helper.mk
+
+for each ``Android.mk'' file found by ndk_INIT, with the following
+variables given to Make:
+
+ EMACS_SRCDIR=. # the source directory (in which configure is running)
+ BUILD_AUXDIR=$ndk_AUX_DIR # the build-aux directory
+ EMACS_ABI=$ndk_ABI # this is the $android_abi given to ndk_INIT
+ ANDROID_MAKEFILE="/opt/android/libpng/Android.mk"
+ ANDROID_MODULE_DIRECTORY="/opt/android/libpng"
+ NDK_BUILD_DIR="$ndk_DIR" # this is the directory given as to ndk_INIT
+
+build-aux/ndk-build-helper.mk will then evaluate the contents
+$(ANDROID_MAKEFILE), the ``Android.mk'' file, for the first time. The
+purpose of this evaluation is to establish a list of packages (or
+modules) provided by the ``Android.mk'' file, and the corresponding
+Makefile targets and compiler and linker flags required to build and
+link to those targets.
+
+Before doing so, build-aux/ndk-build-helper.mk will define several
+variables and functions required by all ``Android.mk'' files. The
+most important of these are:
+
+ my-dir # the directory containing the Android.mk file.
+ BUILD_SHARED_LIBRARY # build-aux/ndk-build-helper-1.mk
+ BUILD_STATIC_LIBRARY # build-aux/ndk-build-helper-2.mk
+ BUILD_EXECUTABLE # build-aux/ndk-build-helper-3.mk
+ CLEAR_VARS # build-aux/ndk-build-helper-4.mk
+
+Then, ``Android.mk'' will include $(CLEAN_VARS), possibly other
+``Android.mk'' files, (to clear variables previously set), set several
+variables describing each module to the ndk-build system, and include
+one of $(BUILD_SHARED_LIBRARY), $(BUILD_STATIC_LIBRARY) and
+$(BUILD_EXECUTABLE).
+
+Each one of those three scripts will then read from the variables set
+by ``Android.mk'', resolve dependencies, and print out some text
+describing the module to Emacs. For example, the shared library
+module "libpng" results in the following text being printed:
+
+Building shared
+libpng
+/opt/android/libpng/png.c /opt/android/libpng/pngerror.c /opt/android/libpng/pngget.c /opt/android/libpng/pngmem.c /opt/android/libpng/pngpread.c /opt/android/libpng/pngread.c /opt/android/libpng/pngrio.c /opt/android/libpng/pngrtran.c /opt/android/libpng/pngrutil.c /opt/android/libpng/pngset.c /opt/android/libpng/pngtrans.c /opt/android/libpng/pngwio.c /opt/android/libpng/pngwrite.c /opt/android/libpng/pngwtran.c /opt/android/libpng/pngwutil.c
+-I/opt/android/libpng
+
+ -L/opt/emacs/cross/ndk-build -l:libpng_emacs.so
+libpng_emacs.so
+End
+
+The output is arranged as follows:
+
+ - The first line consists of the word ``Building'', followed by
+ either ``shared'', ``static'', or ``executable'', depending on
+ what type of module being built.
+
+ - The second line consists of the name of the module currently being
+ built.
+
+ - The third line consists of all of the source code files comprising
+ the module.
+
+ - The fourth line consists of the text that has to be added to
+ CFLAGS in order to find the includes associated with the module.
+
+ - The fifth line consists of the text that has to be added to LIBS
+ in order to link with this module and all of its dependencies.
+
+ - The sixth line consists of the Make targets (more on this later)
+ that will build the final shared object or library archive of this
+ module, along with all of its dependencies.
+
+ - The seventh line is either empty, or the name of a dependency on
+ the C++ standard library. This is used to determine whether or
+ not Emacs will include the C++ standard library in the application
+ package.
+
+The output from Make is given to an awk script,
+build-aux/ndk-module-extract.awk. This is responsible for parsing the
+that output and filtering out modules other than what is being built:
+
+ awk -f build-aux/ndk-module-extract.awk MODULE=libpng
+
+eventually generating this section of shell script:
+
+module_name=libpng
+module_kind=shared
+module_src="/opt/android/libpng/png.c /opt/android/libpng/pngerror.c /opt/android/libpng/pngget.c /opt/android/libpng/pngmem.c /opt/android/libpng/pngpread.c /opt/android/libpng/pngread.c /opt/android/libpng/pngrio.c /opt/android/libpng/pngrtran.c /opt/android/libpng/pngrutil.c /opt/android/libpng/pngset.c /opt/android/libpng/pngtrans.c /opt/android/libpng/pngwio.c /opt/android/libpng/pngwrite.c /opt/android/libpng/pngwtran.c /opt/android/libpng/pngwutil.c"
+module_includes="-I/opt/android/libpng"
+module_cflags=""
+module_ldflags=" -L/opt/emacs/cross/ndk-build -l:libpng_emacs.so"
+module_target="libpng_emacs.so"
+module_cxx_deps=""
+module_imports=""
+
+which is then evaluated by `configure'. Once the variable
+`module_name' is set, configure appends the remaining
+$(module_includes), $(module_cflags) and $(module_ldflags) to the
+module's CFLAGS and LIBS variables, and appends the list of Makefile
+targets specified to the variable NDK_BUILD_MODULES.
+
+In some cases, an ``Android.mk'' file may chose to import a module
+defined in ``--with-ndk-path'', but not defined inside its own
+``Android.mk'' file. build-aux/ndk-build-helper.mk defines the
+`import-module' function to add the modules being imported to a
+variable, which is then printed out after ``ndk-build-helper.mk''
+completes. For example, libxml2 imports the ``libicucc'' module,
+which results in the following text being printed:
+
+Building shared
+libxml2
+/home/oldosfan/libxml2/SAX.c /home/oldosfan/libxml2/entities.c /home/oldosfan/libxml2/encoding.c /home/oldosfan/libxml2/error.c /home/oldosfan/libxml2/parserInternals.c /home/oldosfan/libxml2/parser.c /home/oldosfan/libxml2/tree.c /home/oldosfan/libxml2/hash.c /home/oldosfan/libxml2/list.c /home/oldosfan/libxml2/xmlIO.c /home/oldosfan/libxml2/xmlmemory.c /home/oldosfan/libxml2/uri.c /home/oldosfan/libxml2/valid.c /home/oldosfan/libxml2/xlink.c /home/oldosfan/libxml2/debugXML.c /home/oldosfan/libxml2/xpath.c /home/oldosfan/libxml2/xpointer.c /home/oldosfan/libxml2/xinclude.c /home/oldosfan/libxml2/DOCBparser.c /home/oldosfan/libxml2/catalog.c /home/oldosfan/libxml2/globals.c /home/oldosfan/libxml2/threads.c /home/oldosfan/libxml2/c14n.c /home/oldosfan/libxml2/xmlstring.c /home/oldosfan/libxml2/buf.c /home/oldosfan/libxml2/xmlregexp.c /home/oldosfan/libxml2/xmlschemas.c /home/oldosfan/libxml2/xmlschemastypes.c /home/oldosfan/libxml2/xmlunicode.c /home/oldosfan/libxml2/xmlreader.c /home/oldosfan/libxml2/relaxng.c /home/oldosfan/libxml2/dict.c /home/oldosfan/libxml2/SAX2.c /home/oldosfan/libxml2/xmlwriter.c /home/oldosfan/libxml2/legacy.c /home/oldosfan/libxml2/chvalid.c /home/oldosfan/libxml2/pattern.c /home/oldosfan/libxml2/xmlsave.c /home/oldosfan/libxml2/xmlmodule.c /home/oldosfan/libxml2/schematron.c /home/oldosfan/libxml2/SAX.c /home/oldosfan/libxml2/entities.c /home/oldosfan/libxml2/encoding.c /home/oldosfan/libxml2/error.c /home/oldosfan/libxml2/parserInternals.c /home/oldosfan/libxml2/parser.c /home/oldosfan/libxml2/tree.c /home/oldosfan/libxml2/hash.c /home/oldosfan/libxml2/list.c /home/oldosfan/libxml2/xmlIO.c /home/oldosfan/libxml2/xmlmemory.c /home/oldosfan/libxml2/uri.c /home/oldosfan/libxml2/valid.c /home/oldosfan/libxml2/xlink.c /home/oldosfan/libxml2/debugXML.c /home/oldosfan/libxml2/xpath.c /home/oldosfan/libxml2/xpointer.c /home/oldosfan/libxml2/xinclude.c /home/oldosfan/libxml2/DOCBparser.c /home/oldosfan/libxml2/catalog.c /home/oldosfan/libxml2/globals.c /home/oldosfan/libxml2/threads.c /home/oldosfan/libxml2/c14n.c /home/oldosfan/libxml2/xmlstring.c /home/oldosfan/libxml2/buf.c /home/oldosfan/libxml2/xmlregexp.c /home/oldosfan/libxml2/xmlschemas.c /home/oldosfan/libxml2/xmlschemastypes.c /home/oldosfan/libxml2/xmlunicode.c /home/oldosfan/libxml2/xmlreader.c /home/oldosfan/libxml2/relaxng.c /home/oldosfan/libxml2/dict.c /home/oldosfan/libxml2/SAX2.c /home/oldosfan/libxml2/xmlwriter.c /home/oldosfan/libxml2/legacy.c /home/oldosfan/libxml2/chvalid.c /home/oldosfan/libxml2/pattern.c /home/oldosfan/libxml2/xmlsave.c /home/oldosfan/libxml2/xmlmodule.c /home/oldosfan/libxml2/schematron.c
+
+
+ -L/home/oldosfan/emacs-dev/emacs-android/cross/ndk-build -l:libxml2_emacs.so -l:libicuuc_emacs.so
+libxml2_emacs.so libicuuc_emacs.so
+End
+Start Imports
+libicuuc
+End Imports
+
+Upon encountering the ``Start Imports'' section,
+build-aux/ndk-module-extract.awk collects all imports until it
+encounters the line ``End Imports'', at which point it prints:
+
+module_imports="libicuuc"
+
+Then, if the list of imports is not empty, ndk_CHECK_MODULES
+additionally calls itself for each import before appending the
+module's own ``Android.mk'', ensuring that the module's imported
+dependencies are included by $ndk_DIR/Makefile before itself.
+
+Finally, immediately before generating src/Makefile.android, configure
+expands:
+
+ ndk_CONFIG_FILES
+
+to generate $ndk_DIR/Makefile and $ndk_DIR/ndk-build.mk.
+
+Now, the $ndk_DIR directory is set up to build all modules upon which
+depends, and $ndk_DIR/ndk-build.mk includes a list of files required
+to link Emacs, along with the rules to chdir into $ndk_DIR in order to
+build them.
+
+$ndk_DIR/ndk-build.mk is included by cross/src/Makefile
+(Makefile.android) and java/Makefile. It defines three different
+variables:
+
+ NDK_BUILD_MODULES the file names of all modules to be built.
+ NDK_BUILD_STATIC absolute names of all library archives
+ to be built.
+ NDK_BUILD_SHARED absolute names of all shared libraries to
+ be built.
+
+and then proceeds to define rules to build each of the modules in
+$(NDK_BUILD_MODULES).
+
+cross/src/Makefile arranges to have all dependencies of Emacs not
+already built built before linking ``libemacs.so'' with them.
+
+java/Makefile additionally arranges to have all shared object
+dependencies built before the application package is built, which is
+normally redundant because they should have already been built before
+linking ``libemacs.so''.
+
+Building the modules is performed through $ndk_DIR/Makefile, which
+contains the actual implementation of the ``ndk-build'' build system.
+First, it defines certain variables constant within the ``ndk-build''
+build system, such as the files included by ``Android.mk'' to build
+shared or static libraries, and CLEAR_VARS. The most important of
+these are:
+
+ CLEAR_VARS cross/ndk-build/ndk-clear-vars.mk
+ BUILD_EXECUTABLE cross/ndk-build/ndk-build-executable.mk
+ BUILD_SHARED_LIBRARY cross/ndk-build/ndk-build-shared-library.mk
+ BUILD_STATIC_LIBRARY cross/ndk-build/ndk-build-static-library.mk
+ PREBUILT_SHARED_LIBRARY cross/ndk-build/ndk-prebuilt-shared-library.mk
+ PREBUILT_STATIC_LIBRARY cross/ndk-build/ndk-prebuilt-static-library.mk
+
+Then, it loads each Emacs dependency's ``Android.mk'' file. For each
+module defined there, ``Android.mk'' includes $(CLEAR_VARS) to unset
+all variables specific to each module, and then includes
+$(BUILD_SHARED_LIBRARY) or $(BUILD_STATIC_LIBRARY) for each shared or
+static library module.
+
+This results in cross/ndk-build/ndk-build-shared-library.mk or
+cross/ndk-build/ndk-build-static-library being included, just like the
+Makefiles in build-aux were inside the configure script.
+
+Each one of those two scripts then defines rules to build all of the
+object files associated with the module, and then link or archive
+them. The name under which the module is linked is the same as the
+Make target found on the sixth line of output from
+build-aux/ndk-build-helper.mk.
+
+In doing so, they both include the file ndk-resolve.mk.
+ndk-resolve.mk is expected to recursively add all of the exported
+CFLAGS and includes of any dependencies to the compiler and linker
+command lines for the module being built.
+
+When building a shared library module, ndk-resolve.mk is also expected
+to define the variables NDK_LOCAL_A_NAMES_$(LOCAL_MODULE) and
+NDK_WHOLE_A_NAMES_$(LOCAL_MODULE), containing all static library
+dependencies' archive files. They are to be linked in to the
+resulting shared object file.
+
+This is done by including cross/ndk-build/ndk-resolve.mk each time a
+shared or static library module is going to be built. How is this
+done?
+
+First, ndk-resolve.mk saves the LOCAL_PATH, LOCAL_STATIC_LIBRARIES,
+LOCAL_SHARED_LIBRARIES, LOCAL_EXPORT_CFLAGS and
+LOCAL_EXPORT_C_INCLUDES from the module.
+
+Next, ndk-resolve loops through the dependencies the module has
+specified, appending its CFLAGS and includes to the command line for
+the current module.
+
+Then, that process is repeated for each such dependency which has not
+already been resolved, until all dependencies have been resolved.
+
+libpng is a very simple module, providing only a single shared object
+module. This module is named libpng_emacs.so and is eventually built
+and packaged into the library directory of the Emacs application
+package. Now, let us look at a more complex module, libwebp:
+
+
+
+When built with libwebp, Emacs depends on a single library,
+libwebpdemux. This library is named ``libwebpdemux'' on Unix systems,
+and that is the name by which it is found with pkg-config.
+
+However, the library's module is only named ``webpdemux'' on Android.
+When ndk_CHECK_MODULES begins to look for a module, it first tries to
+see if its name is found in the variable `ndk_package_map', which was
+set inside ndk_INIT. In this case, it finds the following word:
+
+ libwebpdemux:webpdemux
+
+and immediately replaces ``libwebpdemux'' with ``webpdemux''.
+
+Then, it locates the ``Android.mk'' file containing a static library
+module named webpdemux and gives the output from
+build-aux/ndk-build-helper.mk to the awk script, resulting in:
+
+module_name=webpdemux
+module_kind=static
+module_src="/opt/android/webp/src/demux/anim_decode.c /opt/android/webp/src/demux/demux.c"
+module_includes="-I/opt/android/webp/src"
+module_cflags=""
+module_ldflags=" cross/ndk-build/libwebpdemux.a cross/ndk-build/libwebp.a cross/ndk-build/libwebpdecoder_static.a "
+module_target="libwebpdemux.a libwebp.a libwebpdecoder_static.a"
+
+The attentive reader will notice that in addition to the
+``libwebpdemux.a'' archive associated with the ``webpdemux'' library,
+Emacs has been made to link with two additional libraries. This is
+because the ``webpdemux'' module specifies a dependency on the
+``webp'' module (defined in the same Android.mk).
+build-aux/ndk-build-helper.mk resolved that dependency, noticing that
+it in turn specified another dependency on ``webpdecoder_static'',
+which in turn was added to the linker command line and list of targets
+to build.
+
+As a result, all three dependencies will be built and linked to Emacs,
+instead of just the single ``webpdemux'' dependency that was
+specified.
+
+
+
+This file is part of GNU Emacs.
+
+GNU Emacs is free software: you can redistribute it and/or modify
+it under the terms of the GNU General Public License as published by
+the Free Software Foundation, either version 3 of the License, or
+(at your option) any later version.
+
+GNU Emacs is distributed in the hope that it will be useful,
+but WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+GNU General Public License for more details.
+
+You should have received a copy of the GNU General Public License
+along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>.
diff --git a/cross/ndk-build/ndk-build-executable.mk b/cross/ndk-build/ndk-build-executable.mk
new file mode 100644
index 00000000000..4f520074c7f
--- /dev/null
+++ b/cross/ndk-build/ndk-build-executable.mk
@@ -0,0 +1,22 @@
+# Copyright 2023-2024 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 <https://www.gnu.org/licenses/>.
+
+# ndk-build works by including a bunch of Makefiles which set
+# variables, and then having those Makefiles include another makefile
+# which actually builds targets.
+
+# Building executables is not supported
diff --git a/cross/ndk-build/ndk-build-shared-library.mk b/cross/ndk-build/ndk-build-shared-library.mk
new file mode 100644
index 00000000000..74c6756a0c1
--- /dev/null
+++ b/cross/ndk-build/ndk-build-shared-library.mk
@@ -0,0 +1,171 @@
+# Copyright 2023-2024 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 <https://www.gnu.org/licenses/>.
+
+# ndk-build works by including a bunch of Makefiles which set
+# variables, and then having those Makefiles include another makefile
+# which actually builds targets.
+
+eq = $(and $(findstring $(1),$(2)),$(findstring $(2),$(1)))
+
+# Objects for shared libraries are prefixed with `-shared-' in
+# addition to the name of the module, because a common practice in
+# Android.mk files written by Google is to define two modules with the
+# same name but of different types.
+objname = $(1)-shared-$(subst /,_,$(2).o)
+
+# LOCAL_SRC_FILES sometimes contains absolute file names. Filter them
+# out with this function. If $(2), this is a file relative to the
+# build directory.
+maybe-absolute = $(or $(and $(2),$(1)),$(and $(wildcard $(1)),$(1)),$(LOCAL_PATH)/$(1))
+
+# Here are the default flags to link shared libraries with.
+NDK_SO_DEFAULT_LDFLAGS := -lc -lm
+
+define single-object-target
+
+ifeq (x$(suffix $(1)),x.c)
+
+$(call objname,$(LOCAL_MODULE),$(basename $(1))): $(call maybe-absolute,$(1),$(2))
+ $(NDK_BUILD_CC) -c $$< -o $$@ $(NDK_CFLAGS_$(LOCAL_MODULE)) $(NDK_BUILD_CFLAGS) $(call LOCAL_C_ADDITIONAL_FLAGS,$(1))
+
+else
+ifeq (x$(suffix $(1)),x.$(or $(LOCAL_CPP_EXTENSION),cpp))
+
+$(call objname,$(LOCAL_MODULE),$(basename $(1))): $(call maybe-absolute,$(1))
+ $(NDK_BUILD_CXX) -c $$< -o $$@ $(NDK_CFLAGS_$(LOCAL_MODULE)) $(NDK_BUILD_CFLAGS_CXX) $(NDK_CXXFLAGS_$(LOCAL_MODULE))
+
+else
+ifneq ($(or $(call eq,x$(suffix $(1)),x.s),$(call eq,x$(suffix $(1)),x.S)),)
+
+$(call objname,$(LOCAL_MODULE),$(basename $(1))): $(call maybe-absolute,$(1),$(2))
+ $(NDK_BUILD_CC) -c $$< -o $$@ $(NDK_ASFLAGS_$(LOCAL_MODULE))
+
+else
+ifneq (x$(suffix $(1)),x.asm)
+ifeq (x$(suffix $(1)),x.cc)
+
+$(call objname,$(LOCAL_MODULE),$(basename $(1))): $(call maybe-absolute,$(1),$(2))
+ $(NDK_BUILD_CXX) -c $$< -o $$@ $(NDK_CFLAGS_$(LOCAL_MODULE)) $(NDK_BUILD_CFLAGS_CXX) $(NDK_CXXFLAGS_$(LOCAL_MODULE))
+
+else
+$$(error Unsupported suffix: $(suffix $(1)))
+endif
+else
+ifneq (x$(LOCAL_ASM_RULE_DEFINED),x)
+# Call this function to define a rule that will generate $(1) from
+# $(2), a ``.asm'' file. This is an Emacs extension.
+
+$(call LOCAL_ASM_RULE,$(call objname,$(LOCAL_MODULE),$(basename $(1))),$(LOCAL_PATH)/$(strip $(1)))
+
+else
+ifeq ($(findstring x86,$(NDK_BUILD_ARCH)),)
+$$(error Trying to build nasm file on non-Intel platform!)
+else
+
+$(call objname,$(LOCAL_MODULE),$(basename $(1))): $(LOCAL_PATH)/$(1)
+ $(NDK_BUILD_NASM) -felf$(findstring 64,$(NDK_BUILD_ARCH)) -o $$@ -i $(LOCAL_PATH) -i $$(dir $$<) $(NDK_ASFLAGS_$(LOCAL_MODULE)) $$<
+
+endif
+endif
+endif
+endif
+endif
+endif
+
+ALL_OBJECT_FILES$(LOCAL_MODULE) += $(call objname,$(LOCAL_MODULE),$(basename $(1)))
+
+endef
+
+define single-neon-target
+
+# Define rules for the target.
+$$(eval $$(call single-object-target,$(patsubst %.neon,%,$(1)),))
+
+endef
+
+# Make sure to not add a prefix to local includes that already specify
+# $(LOCAL_PATH).
+NDK_CFLAGS_$(LOCAL_MODULE) := $(addprefix -I,$(LOCAL_C_INCLUDES))
+NDK_CFLAGS_$(LOCAL_MODULE) += -fPIC -iquote $(LOCAL_PATH) $(LOCAL_EXPORT_CFLAGS) $(LOCAL_CFLAGS) $(LOCAL_CFLAGS_$(NDK_BUILD_ARCH))
+NDK_ASFLAGS_$(LOCAL_MODULE) := $(LOCAL_ASFLAGS) $(LOCAL_ASFLAGS_$(NDK_BUILD_ARCH)) $(and $(findstring clang,$(NDK_BUILD_CC)),$(LOCAL_CLANG_ASFLAGS_$(NDK_BUILD_ARCH)))
+NDK_LDFLAGS_$(LOCAL_MODULE) := $(LOCAL_LDLIBS) $(LOCAL_LDFLAGS)
+NDK_CXXFLAGS_$(LOCAL_MODULE) := $(LOCAL_CPPFLAGS) $(LOCAL_RTTI_FLAG)
+
+# Now look for features in LOCAL_CPP_FEATURES and enable them.
+
+ifneq ($(findstring exceptions,$(LOCAL_CPPFLAGS)),)
+NDK_CXXFLAGS_$(LOCAL_MODULE) += -fexceptions
+endif
+
+ifneq ($(findstring rtti,$(LOCAL_CPPFLAGS)),)
+NDK_CXXFLAGS_$(LOCAL_MODULE) += -frtti
+endif
+
+ALL_OBJECT_FILES$(LOCAL_MODULE) :=
+
+ifeq ($(NDK_BUILD_ARCH)$(NDK_ARM_MODE),armarm)
+NDK_CFLAGS ::= -marm
+else
+ifeq ($(NDK_BUILD_ARCH),arm)
+NDK_CFLAGS ::= -mthumb
+endif
+endif
+
+ifeq ($(findstring lib,$(LOCAL_MODULE)),lib)
+LOCAL_MODULE_FILENAME := $(LOCAL_MODULE)_emacs
+else
+LOCAL_MODULE_FILENAME := lib$(LOCAL_MODULE)_emacs
+endif
+
+# Since a shared library is being built, suffix the library with
+# _emacs. Otherwise, libraries already on the system will be found
+# first, with potentially nasty consequences.
+
+LOCAL_MODULE_FILENAME := $(LOCAL_MODULE_FILENAME).so
+
+# Record this module's dependencies and exported includes and CFLAGS,
+# and then add that of its dependencies.
+
+include $(srcdir)/ndk-resolve.mk
+
+# Then define rules to build all objects.
+ALL_SOURCE_FILES := $(LOCAL_SRC_FILES) $(LOCAL_SRC_FILES_$(NDK_BUILD_ARCH))
+
+# This defines all dependencies.
+ALL_OBJECT_FILES$(LOCAL_MODULE) :=
+
+# Now filter out code that is built with neon. Define rules to build
+# those separately.
+NEON_SOURCE_FILES := $(filter %.neon,$(ALL_SOURCE_FILES))
+ALL_SOURCE_FILES := $(filter-out %.neon,$(ALL_SOURCE_FILES))
+
+$(foreach source,$(ALL_SOURCE_FILES),$(eval $(call single-object-target,$(source),)))
+$(foreach source,$(NEON_SOURCE_FILES),$(eval $(call single-neon-target,$(source))))
+
+# Now define the rule to build the shared library. Shared libraries
+# link with all of the archive files from the static libraries on
+# which they depend, and also any shared libraries they depend on.
+
+define define-module-rule
+$(LOCAL_MODULE_FILENAME): $(ALL_OBJECT_FILES$(LOCAL_MODULE)) $(NDK_LOCAL_A_NAMES_$(LOCAL_MODULE)) $(NDK_WHOLE_A_NAMES_$(LOCAL_MODULE)) $(NDK_LOCAL_SO_NAMES_$(LOCAL_MODULE))
+ $(NDK_BUILD_CC) $(1) $(2) -o $$@ -shared $(NDK_LDFLAGS_$(LOCAL_MODULE)) $(NDK_SO_EXTRA_FLAGS_$(LOCAL_MODULE)) $(NDK_SO_DEFAULT_LDFLAGS) $(foreach so,$(NDK_LOCAL_SO_NAMES_$(LOCAL_MODULE)),-L $(abspath $(CURDIR)) -l:$(so))
+endef
+
+NDK_WHOLE_ARCHIVE_PREFIX = -Wl,--whole-archive
+NDK_WHOLE_ARCHIVE_SUFFIX = -Wl,--no-whole-archive
+
+$(eval $(call define-module-rule,$(ALL_OBJECT_FILES$(LOCAL_MODULE)) $(NDK_LOCAL_A_NAMES_$(LOCAL_MODULE)),$(and $(strip $(NDK_WHOLE_A_NAMES_$(LOCAL_MODULE))),$(NDK_WHOLE_ARCHIVE_PREFIX) $(NDK_WHOLE_A_NAMES_$(LOCAL_MODULE)) $(NDK_WHOLE_ARCHIVE_SUFFIX))))
diff --git a/cross/ndk-build/ndk-build-static-library.mk b/cross/ndk-build/ndk-build-static-library.mk
new file mode 100644
index 00000000000..aba4539f6bb
--- /dev/null
+++ b/cross/ndk-build/ndk-build-static-library.mk
@@ -0,0 +1,142 @@
+# Copyright 2023-2024 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 <https://www.gnu.org/licenses/>.
+
+# ndk-build works by including a bunch of Makefiles which set
+# variables, and then having those Makefiles include another makefile
+# which actually builds targets.
+
+eq = $(and $(findstring $(1),$(2)),$(findstring $(2),$(1)))
+objname = $(1)-static-$(subst /,_,$(2).o)
+maybe-absolute = $(or $(and $(2),$(1)),$(and $(wildcard $(1)),$(1)),$(LOCAL_PATH)/$(1))
+
+define single-object-target
+
+ifeq (x$(suffix $(1)),x.c)
+
+$(call objname,$(LOCAL_MODULE),$(basename $(1))): $(call maybe-absolute,$(1),$(2))
+ $(NDK_BUILD_CC) -c $$< -o $$@ $(NDK_BUILD_CFLAGS) $(NDK_CFLAGS_$(LOCAL_MODULE)) $(call LOCAL_C_ADDITIONAL_FLAGS,$(1))
+
+else
+ifeq (x$(suffix $(1)),x.$(or $(LOCAL_CPP_EXTENSION),cpp))
+
+$(call objname,$(LOCAL_MODULE),$(basename $(1))): $(call maybe-absolute,$(1),$(2))
+ $(NDK_BUILD_CXX) -c $$< -o $$@ $(NDK_BUILD_CFLAGS_CXX) $(NDK_CFLAGS_$(LOCAL_MODULE)) $(NDK_CXXFLAGS_$(LOCAL_MODULE))
+
+else
+ifneq ($(or $(call eq,x$(suffix $(1)),x.s),$(call eq,x$(suffix $(1)),x.S)),)
+
+$(call objname,$(LOCAL_MODULE),$(basename $(1))): $(call maybe-absolute,$(1),$(2))
+ $(NDK_BUILD_CC) -c $$< -o $$@ $(NDK_ASFLAGS_$(LOCAL_MODULE))
+
+else
+ifneq (x$(suffix $(1)),x.asm)
+ifeq (x$(suffix $(1)),x.cc)
+
+$(call objname,$(LOCAL_MODULE),$(basename $(1))): $(call maybe-absolute,$(1),$(2))
+ $(NDK_BUILD_CXX) -c $$< -o $$@ $(NDK_BUILD_CFLAGS_CXX) $(NDK_CFLAGS_$(LOCAL_MODULE)) $(NDK_CXXFLAGS_$(LOCAL_MODULE))
+
+else
+$$(error Unsupported suffix: $(suffix $(1)))
+endif
+else
+ifneq (x$(LOCAL_ASM_RULE_DEFINED),x)
+# Call this function to define a rule that will generate $(1) from
+# $(2), a ``.asm'' file. This is an Emacs extension.
+
+$(call LOCAL_ASM_RULE,$(call objname,$(LOCAL_MODULE),$(basename $(1))),$(LOCAL_PATH)/$(strip $(1)))
+
+else
+ifeq ($(findstring x86,$(NDK_BUILD_ARCH)),)
+$$(error Trying to build nasm file on non-Intel platform!)
+else
+
+$(call objname,$(LOCAL_MODULE),$(basename $(1))): $(call maybe-absolute,$(1),$(2))
+ $(NDK_BUILD_NASM) -felf$(findstring 64,$(NDK_BUILD_ARCH)) -o $$@ -i $(LOCAL_PATH) -i $$(dir $$<) $(NDK_ASFLAGS_$(LOCAL_MODULE)) $$<
+
+endif
+endif
+endif
+endif
+endif
+endif
+
+ALL_OBJECT_FILES$(LOCAL_MODULE) += $(call objname,$(LOCAL_MODULE),$(basename $(1)))
+endef
+
+define single-neon-target
+
+# Define rules for the target.
+$$(eval $$(call single-object-target,$(patsubst %.neon,%,$(1)),))
+
+endef
+
+NDK_CFLAGS_$(LOCAL_MODULE) := $(addprefix -I,$(LOCAL_C_INCLUDES))
+NDK_CFLAGS_$(LOCAL_MODULE) += -fPIC -iquote $(LOCAL_PATH) $(LOCAL_EXPORT_CFLAGS) $(LOCAL_CFLAGS) $(LOCAL_CFLAGS_$(NDK_BUILD_ARCH))
+NDK_ASFLAGS_$(LOCAL_MODULE) := $(LOCAL_ASFLAGS) $(LOCAL_ASFLAGS_$(NDK_BUILD_ARCH)) $(and $(findstring clang,$(NDK_BUILD_CC)),$(LOCAL_CLANG_ASFLAGS_$(NDK_BUILD_ARCH)))
+NDK_LDFLAGS_$(LOCAL_MODULE) := $(LOCAL_LDLIBS) $(LOCAL_LDFLAGS)
+NDK_CXXFLAGS_$(LOCAL_MODULE) := $(LOCAL_CPPFLAGS) $(LOCAL_RTTI_FLAG)
+ALL_OBJECT_FILES$(LOCAL_MODULE) :=
+
+# Now look for features in LOCAL_CPP_FEATURES and enable them.
+
+ifneq ($(findstring exceptions,$(LOCAL_CPPFLAGS)),)
+NDK_CXXFLAGS_$(LOCAL_MODULE) += -fexceptions
+endif
+
+ifneq ($(findstring rtti,$(LOCAL_CPPFLAGS)),)
+NDK_CXXFLAGS_$(LOCAL_MODULE) += -frtti
+endif
+
+
+ifeq ($(NDK_BUILD_ARCH)$(NDK_ARM_MODE),armarm)
+NDK_CFLAGS ::= -marm
+else
+ifeq ($(NDK_BUILD_ARCH),arm)
+NDK_CFLAGS ::= -mthumb
+endif
+endif
+
+ifeq ($(findstring lib,$(LOCAL_MODULE)),lib)
+LOCAL_MODULE_FILENAME := $(LOCAL_MODULE)
+else
+LOCAL_MODULE_FILENAME := lib$(LOCAL_MODULE)
+endif
+
+LOCAL_MODULE_FILENAME := $(LOCAL_MODULE_FILENAME).a
+
+# Record this module's dependencies and exported includes and CFLAGS,
+# and then add that of its dependencies.
+
+include $(srcdir)/ndk-resolve.mk
+
+# Then define rules to build all objects.
+ALL_SOURCE_FILES := $(LOCAL_SRC_FILES) $(LOCAL_SRC_FILES_$(NDK_BUILD_ARCH))
+
+# Now filter out code that is built with neon. Define rules to build
+# those separately.
+NEON_SOURCE_FILES := $(filter %.neon,$(ALL_SOURCE_FILES))
+ALL_SOURCE_FILES := $(filter-out %.neon,$(ALL_SOURCE_FILES))
+
+# This defines all dependencies.
+ALL_OBJECT_FILES$(LOCAL_MODULE) =
+
+$(foreach source,$(ALL_SOURCE_FILES),$(eval $(call single-object-target,$(source),)))
+$(foreach source,$(NEON_SOURCE_FILES),$(eval $(call single-neon-target,$(source),)))
+
+# Now define the rule to build the library.
+$(LOCAL_MODULE_FILENAME): $(ALL_OBJECT_FILES$(LOCAL_MODULE))
+ $(NDK_BUILD_AR) r $@ $^
diff --git a/cross/ndk-build/ndk-build.mk.in b/cross/ndk-build/ndk-build.mk.in
new file mode 100644
index 00000000000..ea1be5af6f1
--- /dev/null
+++ b/cross/ndk-build/ndk-build.mk.in
@@ -0,0 +1,70 @@
+### @configure_input@
+
+# Copyright (C) 2023-2024 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 <https://www.gnu.org/licenses/>.
+
+# This file is included all over the place to get and build
+# prerequisites.
+
+NDK_BUILD_MODULES = @NDK_BUILD_MODULES@
+NDK_BUILD_CXX_SHARED = @NDK_BUILD_CXX_SHARED@
+NDK_BUILD_CXX_STL = @NDK_BUILD_CXX_STL@
+NDK_BUILD_CXX_LDFLAGS = @NDK_BUILD_CXX_LDFLAGS@
+NDK_BUILD_ANY_CXX_MODULE = @NDK_BUILD_ANY_CXX_MODULE@
+NDK_BUILD_SHARED =
+NDK_BUILD_STATIC =
+
+define uniqify
+$(if $1,$(firstword $1) $(call uniqify,$(filter-out $(firstword $1),$1)))
+endef
+
+# Remove duplicate modules. These can occur when a single module
+# imports a module and also declares it in LOCAL_SHARED_LIBRARIES.
+NDK_BUILD_MODULES := $(call uniqify,$(NDK_BUILD_MODULES))
+
+# Here are all of the files to build.
+NDK_BUILD_ALL_FILES := $(foreach file,$(NDK_BUILD_MODULES), \
+ $(top_builddir)/cross/ndk-build/$(file))
+
+# The C++ standard library must be extracted from the Android NDK
+# directories and included in the application package, if any module
+# requires the C++ standard library.
+
+ifneq ($(NDK_BUILD_ANY_CXX_MODULE),)
+NDK_BUILD_SHARED += $(NDK_BUILD_CXX_SHARED)
+endif
+
+define subr-1
+ifeq ($(suffix $(1)),.so)
+NDK_BUILD_SHARED += $(top_builddir)/cross/ndk-build/$(1)
+else
+ifeq ($(suffix $(1)),.a)
+NDK_BUILD_STATIC += $(top_builddir)/cross/ndk-build/$(1)
+endif
+endif
+endef
+
+# Generate rules for each module.
+
+$(foreach module,$(NDK_BUILD_MODULES),$(eval $(call subr-1,$(module))))
+
+# Generate rules to build everything now.
+# Make sure to use the top_builddir currently defined.
+
+NDK_TOP_BUILDDIR := $(top_builddir)
+$(NDK_BUILD_ALL_FILES) &:
+ $(MAKE) -C $(NDK_TOP_BUILDDIR)/cross/ndk-build $(NDK_BUILD_MODULES)
diff --git a/cross/ndk-build/ndk-clear-vars.mk b/cross/ndk-build/ndk-clear-vars.mk
new file mode 100644
index 00000000000..0803522f3d4
--- /dev/null
+++ b/cross/ndk-build/ndk-clear-vars.mk
@@ -0,0 +1,57 @@
+# Copyright 2023-2024 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 <https://www.gnu.org/licenses/>.
+
+# ndk-build works by including a bunch of Makefiles which set
+# variables, and then having those Makefiles include another makefile
+# which actually builds targets.
+
+LOCAL_MODULE :=
+LOCAL_MODULE_FILENAME :=
+LOCAL_SRC_FILES :=
+LOCAL_CPP_EXTENSION :=
+LOCAL_CPP_FEATURES :=
+LOCAL_C_INCLUDES :=
+LOCAL_CFLAGS :=
+LOCAL_CPPFLAGS :=
+LOCAL_STATIC_LIBRARIES :=
+LOCAL_SHARED_LIBRARIES :=
+LOCAL_WHOLE_STATIC_LIBRARIES :=
+LOCAL_LDLIBS :=
+LOCAL_LDFLAGS :=
+LOCAL_ALLOW_UNDEFINED_SYMBOLS :=
+LOCAL_ARM_MODE :=
+LOCAL_ARM_NEON :=
+LOCAL_DISABLE_FORMAT_STRING_CHECKS :=
+LOCAL_EXPORT_CFLAGS :=
+LOCAL_EXPORT_CPPFLAGS :=
+LOCAL_EXPORT_C_INCLUDES :=
+LOCAL_EXPORT_C_INCLUDE_DIRS :=
+LOCAL_EXPORT_LDFLAGS :=
+LOCAL_EXPORT_LDLIBS :=
+
+# AOSP extensions.
+LOCAL_SRC_FILES_$(NDK_BUILD_ARCH) :=
+LOCAL_ASFLAGS_$(NDK_BUILD_ARCH) :=
+LOCAL_CFLAGS_$(NDK_BUILD_ARCH) :=
+LOCAL_ADDITIONAL_DEPENDENCIES :=
+LOCAL_CLANG_ASFLAGS_$(NDK_BUILD_ARCH) :=
+LOCAL_IS_HOST_MODULE :=
+
+# Emacs extensions!
+LOCAL_ASM_RULE_DEFINED :=
+LOCAL_ASM_RULE :=
+LOCAL_C_ADDITIONAL_FLAGS :=
diff --git a/cross/ndk-build/ndk-prebuilt-shared-library.mk b/cross/ndk-build/ndk-prebuilt-shared-library.mk
new file mode 100644
index 00000000000..d63ca4a0c76
--- /dev/null
+++ b/cross/ndk-build/ndk-prebuilt-shared-library.mk
@@ -0,0 +1,24 @@
+### @configure_input@
+
+# Copyright 2023-2024 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 <https://www.gnu.org/licenses/>.
+
+# ndk-build works by including a bunch of Makefiles which set
+# variables, and then having those Makefiles include another makefile
+# which actually builds targets.
+
+$(warn Prebuilt shared libraries are not supported)
diff --git a/cross/ndk-build/ndk-prebuilt-static-library.mk b/cross/ndk-build/ndk-prebuilt-static-library.mk
new file mode 100644
index 00000000000..94c98435d5f
--- /dev/null
+++ b/cross/ndk-build/ndk-prebuilt-static-library.mk
@@ -0,0 +1,24 @@
+### @configure_input@
+
+# Copyright 2023-2024 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 <https://www.gnu.org/licenses/>.
+
+# ndk-build works by including a bunch of Makefiles which set
+# variables, and then having those Makefiles include another makefile
+# which actually builds targets.
+
+$(warn Prebuilt static libraries are not supported)
diff --git a/cross/ndk-build/ndk-resolve.mk b/cross/ndk-build/ndk-resolve.mk
new file mode 100644
index 00000000000..4d8ecf8667a
--- /dev/null
+++ b/cross/ndk-build/ndk-resolve.mk
@@ -0,0 +1,186 @@
+# Copyright 2023-2024 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 <https://www.gnu.org/licenses/>.
+
+# ndk-build works by including a bunch of Makefiles which set
+# variables, and then having those Makefiles include another makefile
+# which actually builds targets.
+
+# List of system libraries to ignore.
+NDK_SYSTEM_LIBRARIES = z libz libc c libdl dl stdc++ libstdc++ stlport libstlport gnustl libgnustl c++ libc++ log liblog android libandroid
+
+# Save information.
+NDK_LOCAL_PATH_$(LOCAL_MODULE) := $(LOCAL_PATH)
+NDK_LOCAL_STATIC_LIBRARIES_$(LOCAL_MODULE) := $(LOCAL_STATIC_LIBRARIES) $(LOCAL_WHOLE_STATIC_LIBRARIES)
+NDK_LOCAL_WHOLE_LIBRARIES_$(LOCAL_MODULE) := $(LOCAL_WHOLE_STATIC_LIBRARIES)
+NDK_LOCAL_SHARED_LIBRARIES_$(LOCAL_MODULE) := $(LOCAL_SHARED_LIBRARIES)
+NDK_LOCAL_EXPORT_CFLAGS_$(LOCAL_MODULE) := $(LOCAL_EXPORT_CFLAGS)
+NDK_LOCAL_EXPORT_C_INCLUDES_$(LOCAL_MODULE) := $(LOCAL_EXPORT_C_INCLUDES) $(LOCAL_EXPORT_C_INCLUDE_DIRS)
+NDK_LOCAL_A_NAMES_$(LOCAL_MODULE) :=
+NDK_WHOLE_A_NAMES_$(LOCAL_MODULE) :=
+NDK_LOCAL_SO_NAMES_$(LOCAL_MODULE) :=
+NDK_SO_EXTRA_FLAGS_$(LOCAL_MODULE) :=
+
+# List of all dependencies resolved for this module thus far.
+# Used to avoid infinite recursion.
+# Separate the variable which lists modules for which CFLAGS
+# have been resolved from the variable which lists modules
+# for which library dependencies have been resolved, in order
+# to catch the case where a library dependency is skipped
+# despite its CFLAGS being added.
+NDK_RESOLVED_$(LOCAL_MODULE) :=
+NDK_RESOLVED_CFLAGS_$(LOCAL_MODULE) :=
+
+define ndk-resolve
+
+ifeq ($$(filter $(1)$(and $(3),whole),$$(NDK_RESOLVED_CFLAGS_$(LOCAL_MODULE))),)
+# Always mark this module's cflags as having been resolved, even if
+# this is a whole library.
+NDK_RESOLVED_CFLAGS_$(LOCAL_MODULE) += $(1)
+
+NDK_CFLAGS_$(LOCAL_MODULE) += $(NDK_LOCAL_EXPORT_CFLAGS_$(1))
+NDK_CFLAGS_$(LOCAL_MODULE) += $(addprefix -I,$(NDK_LOCAL_EXPORT_C_INCLUDES_$(1)))
+endif
+
+ifeq ($$(filter $(1)$(and $(3),whole),$$(NDK_RESOLVED_$(LOCAL_MODULE))),)
+# Now append local libraries, as long as this library isn't a shared
+# library itself.
+ifeq ($(4),)
+
+# Mark this module's library dependencies as having been resolved.
+NDK_RESOLVED_$(LOCAL_MODULE) += $(1)
+
+# If this is a whole library, then mark this as resolved too, and
+# remove the library from the normal static library list.
+ifneq ($(3),)
+NDK_RESOLVED_$(LOCAL_MODULE) += $(1)whole
+endif
+
+# If the module happens to be zlib, then add -lz to the shared library
+# flags.
+ifeq ($(strip $(1)),libz)
+NDK_SO_EXTRA_FLAGS_$(LOCAL_MODULE) += -lz
+endif
+
+ifeq ($(strip $(1)),z)
+NDK_SO_EXTRA_FLAGS_$(LOCAL_MODULE) += -lz
+endif
+
+# Likewise for libdl.
+ifeq ($(strip $(1)),libdl)
+NDK_SO_EXTRA_FLAGS_$(LOCAL_MODULE) += -ldl
+endif
+
+ifeq ($(strip $(1)),dl)
+NDK_SO_EXTRA_FLAGS_$(LOCAL_MODULE) += -ldl
+endif
+
+# Likewise for libstdc++.
+ifeq ($(strip $(1)),libstdc++)
+NDK_SO_EXTRA_FLAGS_$(LOCAL_MODULE) += $(NDK_BUILD_CXX_LDFLAGS)
+endif
+
+ifeq ($(strip $(1)),stdc++)
+NDK_SO_EXTRA_FLAGS_$(LOCAL_MODULE) += $(NDK_BUILD_CXX_LDFLAGS)
+endif
+
+ifeq ($(strip $(1)),libstlport)
+NDK_SO_EXTRA_FLAGS_$(LOCAL_MODULE) += $(NDK_BUILD_CXX_LDFLAGS)
+endif
+
+ifeq ($(strip $(1)),stlport)
+NDK_SO_EXTRA_FLAGS_$(LOCAL_MODULE) += $(NDK_BUILD_CXX_LDFLAGS)
+endif
+
+ifeq ($(strip $(1)),libgnustl)
+NDK_SO_EXTRA_FLAGS_$(LOCAL_MODULE) += $(NDK_BUILD_CXX_LDFLAGS)
+endif
+
+ifeq ($(strip $(1)),gnustl)
+NDK_SO_EXTRA_FLAGS_$(LOCAL_MODULE) += $(NDK_BUILD_CXX_LDFLAGS)
+endif
+
+ifeq ($(strip $(1)),libc++)
+NDK_SO_EXTRA_FLAGS_$(LOCAL_MODULE) += $(NDK_BUILD_CXX_LDFLAGS)
+endif
+
+ifeq ($(strip $(1)),c++)
+NDK_SO_EXTRA_FLAGS_$(LOCAL_MODULE) += $(NDK_BUILD_CXX_LDFLAGS)
+endif
+
+# Likewise for liblog.
+ifeq ($(strip $(1)),liblog)
+NDK_SO_EXTRA_FLAGS_$(LOCAL_MODULE) += -llog
+endif
+
+ifeq ($(strip $(1)),log)
+NDK_SO_EXTRA_FLAGS_$(LOCAL_MODULE) += -llog
+endif
+
+# Likewise for libandroid.
+ifeq ($(strip $(1)),libandroid)
+NDK_SO_EXTRA_FLAGS_$(LOCAL_MODULE) += -landroid
+endif
+
+ifeq ($(strip $(1)),android)
+NDK_SO_EXTRA_FLAGS_$(LOCAL_MODULE) += -landroid
+endif
+
+ifeq ($(findstring $(1),$(NDK_SYSTEM_LIBRARIES))$(2)$(3),)
+ifneq ($(findstring lib,$(1)),)
+NDK_LOCAL_SO_NAMES_$(LOCAL_MODULE) += $(1)_emacs.so
+else
+NDK_LOCAL_SO_NAMES_$(LOCAL_MODULE) += lib$(1)_emacs.so
+endif
+endif
+
+ifneq ($(2),)
+ifneq ($(findstring lib,$(1)),)
+NDK_LOCAL_A_NAMES_$(LOCAL_MODULE) += $(1).a
+else
+NDK_LOCAL_A_NAMES_$(LOCAL_MODULE) += lib$(1).a
+endif
+endif
+
+ifneq ($(3),)
+ifneq ($(findstring lib,$(1)),)
+NDK_WHOLE_A_NAMES_$(LOCAL_MODULE) += $(1).a
+else
+NDK_WHOLE_A_NAMES_$(LOCAL_MODULE) += lib$(1).a
+endif
+
+# Remove this archive from the regular archive list, should it already
+# exists. Any given archive should only appear once, and if an
+# archive has been specified as whole it should always be whole.
+NDK_LOCAL_A_NAMES_$(LOCAL_MODULE) := $$(filter-out lib$(1).a,$$(NDK_LOCAL_A_NAMES_$(LOCAL_MODULE)))
+NDK_LOCAL_A_NAMES_$(LOCAL_MODULE) := $$(filter-out $(1).a,$$(NDK_LOCAL_A_NAMES_$(LOCAL_MODULE)))
+endif
+endif
+
+$$(foreach module,$$(NDK_LOCAL_STATIC_LIBRARIES_$(1)),$$(eval $$(call ndk-resolve,$$(module),1,,$(or $(4),$(if $(2)$(3),,1)))))
+$$(foreach module,$$(NDK_LOCAL_SHARED_LIBRARIES_$(1)),$$(eval $$(call ndk-resolve,$$(module),,,$(or $(4),$(if $(2)$(3),,1)))))
+$$(foreach module,$$(NDK_LOCAL_WHOLE_LIBRARIES_$(1)),$$(eval $$(call ndk-resolve,$$(module),,1,$(or $(4),$(if $(2)$(3),,1)))))
+endif
+
+endef
+
+# Add shared libraries to the shared object names when they appear as
+# a top level dependency. However, do not recursively add the names
+# of this module's shared library dependencies, if it is just a shared
+# library, since it will link to those shared libraries itself.
+$(foreach module,$(LOCAL_SHARED_LIBRARIES),$(eval $(call ndk-resolve,$(module),,,)))
+$(foreach module,$(LOCAL_STATIC_LIBRARIES),$(eval $(call ndk-resolve,$(module),1,,)))
+$(foreach module,$(LOCAL_WHOLE_STATIC_LIBRARIES), $(eval $(call ndk-resolve,$(module),,1,)))
diff --git a/cross/verbose.mk.android b/cross/verbose.mk.android
new file mode 100644
index 00000000000..7b9af76404b
--- /dev/null
+++ b/cross/verbose.mk.android
@@ -0,0 +1,56 @@
+### verbose.mk --- Makefile fragment for GNU Emacs during
+### cross-compilation.
+
+## Copyright (C) 2023-2024 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 <https://www.gnu.org/licenses/>.
+
+# 'make' verbosity.
+V = 0
+ifeq (${V},1)
+AM_V_AR =
+AM_V_at =
+AM_V_CC =
+AM_V_CXX =
+AM_V_CCLD =
+AM_V_CXXLD =
+AM_V_GEN =
+else
+
+# Whether $(info ...) works. This is to work around a bug in GNU Make
+# 4.3 and earlier, which implements $(info MSG) via two system calls
+# { write (..., "MSG", 3); write (..., "\n", 1); }
+# which looks bad when make -j interleaves two of these at about the same time.
+#
+# Later versions of GNU Make have the 'notintermediate' feature,
+# so assume that $(info ...) works if this feature is present.
+#
+have_working_info = $(filter notintermediate,$(value .FEATURES))
+#
+# The workaround is to use the shell and 'echo' rather than $(info ...).
+# The workaround is done only for AM_V_ELC and AM_V_ELN,
+# since the bug is not annoying elsewhere.
+
+. :=
+AM_V_AR = @$(info $. AR $@)
+AM_V_at = @
+AM_V_CC = @$(info $. CC $@)
+AM_V_CXX = @$(info $. CXX $@)
+AM_V_CCLD = @$(info $. CCLD $@)
+AM_V_CXXLD = @$(info $. CXXLD $@)
+AM_V_GEN = @$(info $. GEN $@)
+AM_V_NO_PD = --no-print-directory
+endif
diff --git a/doc/emacs/ChangeLog.1 b/doc/emacs/ChangeLog.1
index 4dfb14ac783..e1de11c5540 100644
--- a/doc/emacs/ChangeLog.1
+++ b/doc/emacs/ChangeLog.1
@@ -81,7 +81,7 @@
* misc.texi (Network Security): Mention the new protocol-level
`high' NSM checks.
-2014-12-08 Eric S. Raymond <esr@snark.thyrsus.com>
+2014-12-08 Eric S. Raymond <esr@thyrsus.com>
* maintaining.texi: Support for Arch has been moved to obsolete,
remove references that imply otherwise.
@@ -128,7 +128,7 @@
* maintaining.texi (Version Control Systems): Fix a typo.
-2014-11-20 Eric S. Raymond <esr@snark.thyrsus.com>
+2014-11-20 Eric S. Raymond <esr@thyrsus.com>
* maintaining.texi: Document SRC support.
@@ -5616,11 +5616,11 @@
* custom.texi (Variables): Add Directory Variables to menu.
(Directory Variables): New node.
-2008-05-16 Eric S. Raymond <esr@snark.thyrsus.com>
+2008-05-16 Eric S. Raymond <esr@thyrsus.com>
* vc2-xtra.texi: Modify an example so it reflects what vc.el now does.
-2008-05-15 Eric S. Raymond <esr@snark.thyrsus.com>
+2008-05-15 Eric S. Raymond <esr@thyrsus.com>
* vc2-xtra.texi, emacs.texi, files.texi: Snapshots node renamed to
Revision Tags and rewritten. Section now uses modern terminology,
@@ -5632,7 +5632,7 @@
* msdog.texi (Windows Files): Update documentation of
w32-get-true-file-attributes.
-2008-05-09 Eric S. Raymond <esr@snark.thyrsus.com>
+2008-05-09 Eric S. Raymond <esr@thyrsus.com>
* files.texi, vc-xtra.texi, vc1-xtra.texi: Document the new VC
directory mode.
@@ -5642,11 +5642,11 @@
* killing.texi (Appending Kills): Remove a strangely off-topic index
entry "television".
-2008-05-07 Eric S. Raymond <esr@snark.thyrsus.com>
+2008-05-07 Eric S. Raymond <esr@thyrsus.com>
* ack.texi, files.texi, vc2-xtra.texi: Meta-CVS is no longer supported.
-2008-05-02 Eric S. Raymond <esr@snark.thyrsus.com>
+2008-05-02 Eric S. Raymond <esr@thyrsus.com>
* buffers.texi, files.texi (Version-control):
vc-toggle-read-only is no longer a good idea...
@@ -5771,7 +5771,7 @@
Add view-external-packages on C-h C-e.
Add view-order-manuals on C-h C-m.
-2008-02-17 Ulrich Mueller <ulm@kph.uni-mainz.de>
+2008-02-17 Ulrich Müller <ulm@kph.uni-mainz.de>
* msdog-xtra.texi (MS-DOS): Docstring fix.
@@ -5923,7 +5923,7 @@
* mini.texi (Minibuffer History): Add text about a list of minibuffer
default values.
-2007-10-20 Eric S. Raymond <esr@snark.thyrsus.com>
+2007-10-20 Eric S. Raymond <esr@thyrsus.com>
* files.texi: Disambiguate two slightly different uses of the term
'filesets'.
@@ -5963,7 +5963,7 @@
* calendar.texi (Diary): Clarify text about diary file example.
-2007-10-13 Eric S. Raymond <esr@snark.thyrsus.com>
+2007-10-13 Eric S. Raymond <esr@thyrsus.com>
* files.texi: Capitalize node names according to convention.
@@ -5971,13 +5971,13 @@
* misc.texi (Interactive Shell): Correct INSIDE_EMACS reference.
-2007-10-11 Eric S. Raymond <esr@snark.thyrsus.com>
+2007-10-11 Eric S. Raymond <esr@thyrsus.com>
* emacs.texi:
* files.texi (Version Systems): Minor fixes to version-control material
suggested by RMS and Robert J. Chassell.
-2007-10-10 Eric S. Raymond <esr@snark.thyrsus.com>
+2007-10-10 Eric S. Raymond <esr@thyrsus.com>
* files.texi (Version Systems):
* vc-xtra.texi:
@@ -5987,7 +5987,7 @@
Revise text for adequate description of VCSes with monotonic IDs.
* emacs.texi: Change of terminology from `version' to `revision'.
-2007-10-09 Eric S. Raymond <esr@snark.thyrsus.com>
+2007-10-09 Eric S. Raymond <esr@thyrsus.com>
* files.texi (Version Systems): Describe newer VCses.
Reorder the descriptions to be chronological.
@@ -6015,7 +6015,7 @@
* basic.texi (Arguments): Replace fill-paragraph with
fill-paragraph-or-region.
-2007-10-06 Eric S. Raymond <esr@snark.thyrsus.com>
+2007-10-06 Eric S. Raymond <esr@thyrsus.com>
* files.texi: Update the section on version control for 2007
conditions. None of these changes are new-VC-specific; that
@@ -6128,7 +6128,7 @@
* files.texi (Why Version Control?): Improve previous change.
-2007-07-18 Eric S. Raymond <esr@snark.thyrsus.com>
+2007-07-18 Eric S. Raymond <esr@thyrsus.com>
* files.texi (Why Version Control?): New node.
@@ -10860,7 +10860,7 @@
* emacs.texi: Add a sentence to the top menu mentioning the
specific version of Emacs this manual applies to.
-1993-04-25 Eric S. Raymond (eric@mole.gnu.ai.mit.edu)
+1993-04-25 Eric S. Raymond (esr@thyrsus.com)
* basic.texi: Document next-line-add-lines variable used to
implement down-arrow.
@@ -10871,17 +10871,17 @@
* text.texi: Update unix TeX ordering information.
-1993-03-26 Eric S. Raymond (eric@geech.gnu.ai.mit.edu)
+1993-03-26 Eric S. Raymond (esr@thyrsus.com)
* news.texi: Mention fill-rectangle in keybinding list.
* killing.texi: Document fill-rectangle.
-1993-03-17 Eric S. Raymond (eric@mole.gnu.ai.mit.edu)
+1993-03-17 Eric S. Raymond (esr@thyrsus.com)
* vc.texi: Bring the docs up to date with VC 5.2.
-1992-01-10 Eric S. Raymond (eric@mole.gnu.ai.mit.edu)
+1992-01-10 Eric S. Raymond (esr@thyrsus.com)
* emacs.tex: Mention blackbox and gomoku under Amusements.
Assembler mode is now mentioned and appropriately indexed
diff --git a/doc/emacs/Makefile.in b/doc/emacs/Makefile.in
index eb89e5675b7..4c51e2277ae 100644
--- a/doc/emacs/Makefile.in
+++ b/doc/emacs/Makefile.in
@@ -146,6 +146,8 @@ EMACSSOURCES= \
${srcdir}/glossary.texi \
${srcdir}/ack.texi \
${srcdir}/kmacro.texi \
+ ${srcdir}/android.texi \
+ ${srcdir}/input.texi \
$(EMACS_XTRA)
## Disable implicit rules.
diff --git a/doc/emacs/ack.texi b/doc/emacs/ack.texi
index b5435442459..62f6382113e 100644
--- a/doc/emacs/ack.texi
+++ b/doc/emacs/ack.texi
@@ -902,7 +902,7 @@ Takahashi Naoto co-wrote @file{quail.el} (q.v.), and wrote
@file{robin.el}, another input method.
@item
-Thomas Neumann and Eric Raymond wrote @file{make-mode.el},
+Thomas Neumann and Eric S. Raymond wrote @file{make-mode.el},
a mode for editing makefiles.
@item
diff --git a/doc/emacs/android.texi b/doc/emacs/android.texi
new file mode 100644
index 00000000000..01732961998
--- /dev/null
+++ b/doc/emacs/android.texi
@@ -0,0 +1,1140 @@
+@c This is part of the Emacs manual.
+@c Copyright (C) 2023--2024 Free Software Foundation, Inc.
+@c See file emacs.texi for copying conditions.
+@node Android
+@appendix Emacs and Android
+@cindex Android
+
+ Android is a mobile operating system developed by the Open Handset
+Alliance. This section describes the peculiarities of using Emacs on
+an Android device running Android 2.2 or later.
+
+ Android devices commonly rely a touch screen or digitizer device and
+virtual keyboard for user input. For more information about using
+such devices with Emacs, @pxref{Other Input}.
+
+@menu
+* What is Android?:: Preamble.
+* Android Startup:: Starting up Emacs on Android.
+* Android File System:: The Android file system.
+* Android Document Providers:: Accessing files from other programs.
+* Android Environment:: Running Emacs under Android.
+* Android Windowing:: The Android window system.
+* Android Fonts:: Font selection under Android.
+* Android Troubleshooting:: Dealing with problems.
+* Android Software:: Getting extra software.
+@end menu
+
+@node What is Android?
+@section Android History
+
+ Android is an operating system for mobile devices developed by the
+Open Handset Alliance, a group of companies interested in developing
+handsets that can run a common set of software. It is supposedly free
+software.
+
+ Like the X Consortium of times past, the Open Handset Alliance
+believes that ``openness'' (namely, the regular release of the Android
+source code) is simply a tool to increase the popularity of the
+Android platform. Computer companies normally produce proprietary
+software. The companies in the Open Handset Alliance are no different
+-- most versions of Android installed on devices are proprietary, by
+virtue of containing proprietary components, that often cannot even be
+replaced by the user.
+
+ Android is not designed to respect users' freedom. Almost all
+versions of Android (including some which are supposedly free
+software) include support for Digital Restrictions Management,
+technology that is designed to limit users' ability to copy media to
+and from their own devices. Most Android devices also come with
+proprietary Google applications which are required to run the system,
+and many other Android applications.
+
+ Thus, it must be necessary to consider Android proprietary software
+from a practical standpoint. That is an injustice. If you use
+Android, we urge you to switch to a free operating system, if only for
+your freedom's sake.
+
+ We support GNU Emacs on proprietary operating systems because we
+hope this taste of freedom will inspire users to escape from them.
+
+@node Android Startup
+@section Starting Emacs on Android
+
+ Emacs is not installed on Android devices from source code or
+through a package manager. Instead, Emacs is compiled for Android on
+a different operating system, with the resulting binaries packaged
+into an archive, that is then transferred to the system and installed.
+
+ After being installed, the system places an application icon on the
+desktop (a.k.a@: ``home screen''.) Emacs then starts up once the
+application icon is clicked.
+
+@cindex ``adb logcat''
+
+ During startup, Emacs will display messages in the system log
+buffer; reading that buffer during start-up requires the Android Debug
+Bridge (@command{adb}) utility to be installed on another computer.
+
+ After enabling the ``USB Debugging'' feature on the Android system,
+and connecting it via USB to another system with the @command{adb}
+utility installed, the log can be viewed by running the following
+command on that other system:
+
+@example
+$ adb logcat | grep -E "(android_run_debug_thread|[Ee]macs)"
+@end example
+
+ Assuming that the @command{adb} utility is installed on a GNU/Linux
+or Unix system, follow the steps below to connect to your device.
+
+@enumerate
+@item
+Enable ``developer options'' on your device, by going to the ``About''
+page in the system settings application and clicking on the ``build
+version'' or ``kernel version'' items five to seven times.
+
+@item
+Open the ``developer options'' settings page, which should be under
+the ``system'' page in the settings application.
+
+@item
+Turn on the switch ``USB debugging''.
+
+@item
+Connect one end of a USB cable to your device, and the other end to
+your computer's USB port.
+
+@item
+Run the command @command{adb shell} on your computer. This will fail
+or hang because you have not yet granted your computer permission to
+access the connected device.
+
+@item
+Confirm the pop-up displayed on your device asking whether or not it
+should allow access from your computer.
+@end enumerate
+
+ Depending on the versions of Android and @command{adb} installed,
+there may be other ways to establish a connection. See the official
+documentation at
+@url{https://developer.android.com/studio/command-line/adb} for more
+details.
+
+ Once Emacs starts up, simply running the command @command{logcat} as
+an asynchronous shell command (@pxref{Shell}) will display the log
+buffer.
+
+@cindex emacsclient wrapper, android
+ Since there is no other way to start the @command{emacsclient}
+program (@pxref{Emacs Server}) from another Android program, Emacs
+provides a wrapper around the @command{emacsclient} program, which is
+registered with the system as an application that can open any file.
+
+ When that wrapper is selected as the program with which to open a
+file, it invokes @command{emacsclient} with the options
+@command{--reuse-frame}, @command{--timeout=10}, @command{--no-wait},
+and the name of the file being opened. Then, upon success, the focus
+is transferred to any open Emacs frame.
+
+ However, if Emacs is not running at the time the wrapper is opened,
+it starts Emacs and gives it the file to open as an argument. Note
+that if that Emacs in turn does not start the Emacs server, subsequent
+attempts to open the file with the wrapper will fail.
+
+@cindex /content/by-authority directory, android
+@cindex /content/by-authority-named directory, android
+ Some files are given to Emacs as ``content identifiers'' that the
+system provides access to outside the normal filesystem APIs. Emacs
+uses pseudo-directories named @file{/content/by-authority} and
+@file{/content/by-authority-named} to access those files. Do not make
+any assumptions about the contents of this directory, or try to open
+files in it yourself.
+
+ This feature is not provided on Android 4.3 and earlier, in which
+case such files are copied to a temporary directory before being
+opened.
+
+@cindex ``org-protocol'' links, android
+ In addition to opening ordinary text files, Emacs also registers its
+@command{emacsclient} wrapper as a program capable of opening
+``org-protocol'' links (@pxref{Protocols,,,org, The Org Manual}).
+
+@cindex ``mailto'' links, android
+ Furthermore, the wrapper is also registered as a program capable of
+sending mail to @code{mailto} URIs; when it is invoked to open such a
+URL, it calls the function @code{message-mailto} with that URI as its
+first argument. This feature does not function when the Emacs server
+is not already running.
+
+@node Android File System
+@section What Files Emacs Can Access on Android
+@cindex /assets directory, android
+
+ Emacs exposes a special directory on Android systems: the name of
+the directory is @file{/assets}, and it contains the @file{etc},
+@file{lisp} and @file{info} directories which are normally installed
+in @file{/usr/share/emacs} directory on GNU and Unix systems. On
+Android systems, the Lisp emulation of @command{ls} (@pxref{ls in
+Lisp}) is also enabled by default, as the @command{ls} binary which
+comes with the system varies by manufacturer and usually does not
+support all of the features required by Emacs. One copy of
+@command{ls} distributed with some Android systems is even known to
+lack support for the @code{-l} flag.
+
+@cindex limitations of the /assets directory
+
+ This directory exists because Android does not extract the contents
+of application packages on to the file system while unpacking them,
+but instead requires programs like Emacs to access its contents using
+a special ``asset manager'' interface. Here are the peculiarities
+that result from such an implementation:
+
+@itemize @bullet
+@item
+Subprocesses (such as @command{ls}) can not run from the
+@file{/assets} directory; if you try to run a subprocess with
+@code{current-directory} set to @file{/assets},
+@file{/content/storage} or a subdirectory thereof, it will run from
+the home directory instead.
+
+@item
+There are no @file{.} and @file{..} directories inside the
+@file{/assets} or @file{/content} directory.
+
+@item
+Files in the @file{/assets} directory are always read only, and may be
+read in to memory more than once each time they are opened.
+@end itemize
+
+ Aside from the @file{/assets} directory, Android programs normally
+have access to four other directories. They are:
+
+@itemize @bullet
+@item
+The @dfn{app data} directory. This also serves as the home directory
+for Emacs, and is always accessible read-write.
+
+@item
+The @dfn{app library} directory. This is automatically appended to
+@code{exec-path} and made @code{exec-directory} upon startup, and
+contains utility executables alongside Emacs itself.
+
+@item
+The @dfn{external storage} directory. This is accessible to Emacs
+when the user grants the ``Files and Media'' permission to Emacs via
+system settings.
+
+@item
+Directories provided by @dfn{document providers} on Android 5.0 and
+later. These directories exist outside the normal Unix filesystem,
+containing files provided by external programs (@pxref{Android
+Document Providers}.)
+@end itemize
+
+ Despite ordinary installations of Android not having files within
+the (normally read-only) root directory named @file{content} or
+@file{assets}, you may want to access real files by these names if the
+Android installation in use has been customized. These files will
+conflict with the aforementioned special directories, but can
+nevertheless be accessed by writing their names relative to the
+``parent'' directory of the root directory, as so illustrated:
+@file{/../content}, @file{/../assets}.
+
+ The external storage directory is found at @file{/sdcard}. The
+other directories are not found at any fixed location (but see below),
+although the app data directory is typically symlinked to
+@file{/data/data/org.gnu.emacs/files}.
+
+@cindex app library directory, android
+@cindex where is emacsclient under android
+ Older versions of Android used to place the app library directory
+under the name @file{lib} in the parent of the app data directory.
+Today, this directory is often placed in a directory with a randomly
+generated name under @file{/data/app}.
+
+ For the convenience of scripts running within applications sharing
+the same user ID as Emacs (which have no access to the
+@code{exec-directory} variable), a fairly considerable effort is made
+at startup to symlink the application library directory to its
+traditional location within the parent of the app data directory.
+
+ If Emacs is reinstalled and the location of the app library
+directory consequently changes, that symlink will also be updated
+to point to its new location the next time Emacs is started by the
+system.
+
+@cindex temp~unlinked.NNNN files, Android
+ On Android devices running very old (2.6.29) versions of the Linux
+kernel, Emacs needs to create files named starting with
+@file{temp~unlinked} in the the temporary file directory in order to
+read from asset files. Do not create files with such names yourself,
+or they may be overwritten or removed.
+
+@cindex file system limitations, Android 11
+ On Android 11 and later, the Android system restricts applications
+from accessing files in the @file{/sdcard} directory using
+file-related system calls such as @code{open} and @code{readdir}.
+
+ This restriction is known as ``Scoped Storage'', and supposedly
+makes the system more secure. Unfortunately, it also means that Emacs
+cannot access files in those directories, despite holding the
+necessary permissions. Thankfully, the Open Handset Alliance's
+version of Android allows this restriction to be disabled on a
+per-program basis; the corresponding option in the system settings
+panel is:
+
+@example
+System -> Apps -> Special App Access -> All files access -> Emacs
+@end example
+
+ After you disable or enable this setting as appropriate and grant
+Emacs the ``Files and Media'' permission, it will be able to access
+files under @file{/sdcard} as usual. These settings are not present
+on some proprietary versions of Android.
+
+@node Android Document Providers
+@section Accessing Files from Other Programs on Android
+@cindex document providers, Android
+@cindex /content/storage directory, Android
+
+ Android 5.0 introduces a new sort of program, the ``document
+provider'': these programs are small programs that provide access to
+their own files outside both the asset manager and the Unix
+filesystem. Emacs supports accessing files and directories they
+provide, placing their files within the directory
+@file{/content/storage}.
+
+@findex android-request-directory-access
+ Before Emacs is granted access to one of these directories, it must
+first request the right to access it. This is done by running the
+command (@pxref{M-x}) @code{android-request-directory-access}, which
+displays a file selection dialog.
+
+ If a directory is selected within this dialog, its contents are
+subsequently made available within a new directory named
+@file{/content/storage/@var{authority}/@var{id}}, where
+@var{authority} is the name of the document provider, and @var{id} is
+a unique identifier assigned to the directory by the document
+provider.
+
+ The same limitations applied to the @file{/assets} directory
+(@pxref{Android File System}) are applied when creating sub-processes
+within those directories, because they do not exist within the Unix
+file-system. In addition, although Emacs can normally write and
+create files inside these directories, it cannot create symlinks or
+hard links.
+
+ Since document providers are allowed to perform expensive network
+operations to obtain file contents, a file access operation within one
+of these directories has the potential to take a significant amount of
+time.
+
+@node Android Environment
+@section Running Emacs under Android
+
+ From the perspective of users, Android is mostly a single user
+operating system; however, from the perspective of applications and
+Emacs, the system is host to an overwhelming number of users.
+
+ Each application runs in its own user, with its home directory set
+to its app data directory (@pxref{Android File
+System}.)@footnote{Except in cases where a ``shared user ID'' is
+specified and other applications signed using the same ``package
+signing key'' are installed, in which case Emacs runs as the same user
+and has access to the same files as each of the aforementioned
+applications.}
+
+ Each application is also prohibited from accessing many system
+directories and the app data directories of other applications.
+
+ The Emacs distribution also incorporates several binaries. While
+being executable files, they are packaged as libraries in the library
+directory, because otherwise the system will not unpack them while
+Emacs is being installed. This means that instead of @code{ctags} or
+@code{emacsclient}, Lisp code must specify @code{libctags.so} or
+@code{libemacsclient.so} on the command line when starting either of
+those programs in a subprocess; to determine which names to use,
+consult the values of the variables @code{ctags-program-name},
+@code{etags-program-name}, @code{hexl-program-name},
+@code{emacsclient-program-name}, @code{movemail-program-name},
+@code{ebrowse-program-name}, and @code{rcs2log-program-name}.
+@xref{Subprocess Creation,,, elisp, the Emacs Lisp Reference Manual}.
+
+ The @file{/assets} directory containing Emacs start-up files is
+meant to be inaccessible to processes not directly created by
+@code{zygote}, the system service responsible for starting
+applications. Since required Lisp is found in the @file{/assets}
+directory, it would thus follow that it is not possible for Emacs to
+start itself as a subprocess. A special binary named
+@command{libandroid-emacs.so} is provided with Emacs, which tries its
+best to start Emacs for the purpose of running Lisp in batch mode.
+However, the approach it takes was devised by reading Android source
+code, and is not sanctioned by the Android compatibility definition
+documents, so your mileage may vary.
+
+@cindex call-process, Android
+@vindex android-use-exec-loader
+ Android 10 and later also prohibit Emacs itself from running
+executables inside the app data directory, ostensibly out of security
+concerns. On these systems, Emacs normally applies a workaround;
+however, this workaround requires running all sub-processes through
+another subprocess which implements an executable loader and applies
+process tracing to all its children, which may prove problematic for a
+variety of reasons. In that case, the workaround can be disabled by
+changing the variable @code{android-use-exec-loader} to @code{nil}.
+
+ When this workaround is in effect, process IDs retrieved through the
+@code{process-id} function will be that of the executable loader
+process; its child will belong to the same process group as the
+loader. Consequently, @code{interrupt-process}, and other related
+functions will work correctly, but using the process ID returned by
+@code{process-id} for other purposes will not.
+
+ One ramification of the mechanism by which process tracing is
+carried out is that job control facilities inside inferior shells
+(@pxref{Interactive Shell}) will not be able to stop processes, and
+@code{SIGSTOP} signals to subprocesses created by Emacs will not take
+effect.
+
+ In addition, Android 12 also terminates subprocesses which are
+consuming CPU while Emacs itself is in the background. The system
+judges which processes are consuming too much CPU at intervals of five
+minutes, and terminates the process that has consumed the most CPU
+time.
+
+ Android 12.1 and Android 13 provide an option to disable this
+behavior; to use it, enable ``USB debugging'' (@pxref{Android
+Startup}) connect the Android system to another computer, and run:
+
+@example
+$ adb shell "settings put global settings_enable_monitor_phantom_procs false"
+@end example
+
+@cindex system language settings, Android
+ The ``Languages & Input'' preferences which apply to the operating
+system do not influence the C locale set for programs, but are taken
+into account by Emacs during startup: a locale name is generated from
+the selected language and regional variant and a language environment
+(@pxref{Language Environments}) is selected on that basis, which does
+not overwrite @code{LANG} or other locale-related environment
+variables. The coding system for language environments set in this
+fashion is @code{utf-8-unix} without exception.
+
+@cindex C locale settings, Android
+ Instead, the @code{LANG} environment variable (@pxref{General
+Variables}) is set to @code{en_US.utf8} when Emacs starts on Android
+5.0 or newer, which induces subprocesses linked against the Android C
+library to print output sensibly. Earlier versions of Android do not
+implement locales at all, and on that account, the variable is set to
+@code{C}.
+
+@cindex running emacs in the background, android
+@cindex emacs killed, android
+@cindex emacs in the background, android
+
+ Application processes are treated as disposable entities by the
+system. When all Emacs frames move to the background, Emacs might be
+terminated by the system at any time, for the purpose of saving system
+resources.
+
+ On Android 7.1 and earlier, Emacs designates itself a ``background
+service'', which impels the system to avoid killing Emacs unless it is
+stressed for memory.
+
+ Android 8.0 removed the ability for background services to receive
+such special treatment. However, Emacs applies a workaround: the
+system considers applications that create a permanent notification to
+be performing active work, and will avoid killing such applications.
+Thus, on those systems, Emacs displays a permanent notification for as
+long as it is running.
+
+ Before Android 13, Emacs does not require rights to display
+notifications. Under Android 13 or later, the notification is hidden
+until the user accords Emacs such rights. In spite of that, merely
+attempting to display the notification suffices to avert sudden death;
+whether the notification is displayed has no bearing on Emacs's
+capacity to execute in the background, and it may be disabled without
+any adverse consequences.
+
+ However, it is not guaranteed that the system will not kill Emacs.
+Although the Open Handset Alliance's sample implementation of Android
+behaves correctly, many manufacturers institute additional
+restrictions on program execution in the background in their
+proprietary versions of Android. There is a list of such troublesome
+manufacturers and sometimes workarounds at
+@url{https://dontkillmyapp.com/}.
+
+@cindex permissions under android
+@cindex external storage, android
+
+ Android also defines a permissions system that determines what
+system services Emacs is allowed to access. Programs must specify
+what permissions they want; what then happens is then subject to the
+version of Android being used:
+
+@itemize @bullet
+@item
+Under more or less recent releases of Android, such as Android 6.0 and
+later, Emacs only receives the following permissions upon installation,
+subject to the presence or absence of individual permissions in the
+version of Android installed:
+
+@itemize @minus
+@item
+@code{android.permission.ACCESS_ADSERVICES_AD_ID}
+@item
+@code{android.permission.ACCESS_ADSERVICES_ATTRIBUTION}
+@item
+@code{android.permission.ACCESS_ADSERVICES_CUSTOM_AUDIENCE}
+@item
+@code{android.permission.ACCESS_ADSERVICES_TOPICS}
+@item
+@code{android.permission.ACCESS_LOCATION_EXTRA_COMMANDS}
+@item
+@code{android.permission.ACCESS_NETWORK_STATE}
+@item
+@code{android.permission.ACCESS_NOTIFICATION_POLICY}
+@item
+@code{android.permission.ACCESS_WIFI_STATE}
+@item
+@code{android.permission.AUTHENTICATE_ACCOUNTS}
+@item
+@code{android.permission.BLUETOOTH}
+@item
+@code{android.permission.BLUETOOTH_ADMIN}
+@item
+@code{android.permission.BROADCAST_STICKY}
+@item
+@code{android.permission.CALL_COMPANION_APP}
+@item
+@code{android.permission.CHANGE_NETWORK_STATE}
+@item
+@code{android.permission.CHANGE_WIFI_MULTICAST_STATE}
+@item
+@code{android.permission.CHANGE_WIFI_STATE}
+@item
+@code{android.permission.CREDENTIAL_MANAGER_QUERY_CANDIDATE_CREDENTIALS}
+@item
+@code{android.permission.CREDENTIAL_MANAGER_SET_ALLOWED_PROVIDERS}
+@item
+@code{android.permission.CREDENTIAL_MANAGER_SET_ORIGIN}
+@item
+@code{android.permission.DELIVER_COMPANION_MESSAGES}
+@item
+@code{android.permission.DETECT_SCREEN_CAPTURE}
+@item
+@code{android.permission.DISABLE_KEYGUARD}
+@item
+@code{android.permission.ENFORCE_UPDATE_OWNERSHIP}
+@item
+@code{android.permission.EXPAND_STATUS_BAR}
+@item
+@code{android.permission.FLASHLIGHT}
+@item
+@code{android.permission.FOREGROUND_SERVICE}
+@item
+@code{android.permission.FOREGROUND_SERVICE_CAMERA}
+@item
+@code{android.permission.FOREGROUND_SERVICE_CONNECTED_DEVICE}
+@item
+@code{android.permission.FOREGROUND_SERVICE_DATA_SYNC}
+@item
+@code{android.permission.FOREGROUND_SERVICE_FILE_MANAGEMENT}
+@item
+@code{android.permission.FOREGROUND_SERVICE_HEALTH}
+@item
+@code{android.permission.FOREGROUND_SERVICE_LOCATION}
+@item
+@code{android.permission.FOREGROUND_SERVICE_MEDIA_PLAYBACK}
+@item
+@code{android.permission.FOREGROUND_SERVICE_MEDIA_PROJECTION}
+@item
+@code{android.permission.FOREGROUND_SERVICE_MICROPHONE}
+@item
+@code{android.permission.FOREGROUND_SERVICE_PHONE_CALL}
+@item
+@code{android.permission.FOREGROUND_SERVICE_REMOTE_MESSAGING}
+@item
+@code{android.permission.FOREGROUND_SERVICE_SPECIAL_USE}
+@item
+@code{android.permission.FOREGROUND_SERVICE_SYSTEM_EXEMPTED}
+@item
+@code{android.permission.GET_PACKAGE_SIZE}
+@item
+@code{android.permission.GET_TASKS}
+@item
+@code{android.permission.HIDE_OVERLAY_WINDOWS}
+@item
+@code{android.permission.HIGH_SAMPLING_RATE_SENSORS}
+@item
+@code{android.permission.INTERNET}
+@item
+@code{android.permission.KILL_BACKGROUND_PROCESSES}
+@item
+@code{android.permission.MANAGE_ACCOUNTS}
+@item
+@code{android.permission.MANAGE_OWN_CALLS}
+@item
+@code{android.permission.MODIFY_AUDIO_SETTINGS}
+@item
+@code{android.permission.NFC}
+@item
+@code{android.permission.NFC_PREFERRED_PAYMENT_INFO}
+@item
+@code{android.permission.NFC_TRANSACTION_EVENT}
+@item
+@code{android.permission.PERSISTENT_ACTIVITY}
+@item
+@code{android.permission.QUERY_ALL_PACKAGES}
+@item
+@code{android.permission.READ_BASIC_PHONE_STATE}
+@item
+@code{android.permission.READ_INSTALL_SESSIONS}
+@item
+@code{android.permission.READ_NEARBY_STREAMING_POLICY}
+@item
+@code{android.permission.READ_PROFILE}
+@item
+@code{android.permission.READ_SOCIAL_STREAM}
+@item
+@code{android.permission.READ_SYNC_SETTINGS}
+@item
+@code{android.permission.READ_SYNC_STATS}
+@item
+@code{android.permission.READ_USER_DICTIONARY}
+@item
+@code{android.permission.RECEIVE_BOOT_COMPLETED}
+@item
+@code{android.permission.REORDER_TASKS}
+@item
+@code{android.permission.REQUEST_COMPANION_PROFILE_GLASSES}
+@item
+@code{android.permission.REQUEST_COMPANION_PROFILE_WATCH}
+@item
+@code{android.permission.REQUEST_COMPANION_RUN_IN_BACKGROUND}
+@item
+@code{android.permission.REQUEST_COMPANION_START_FOREGROUND_SERVICES_FROM_BACKGROUND}
+@item
+@code{android.permission.REQUEST_COMPANION_USE_DATA_IN_BACKGROUND}
+@item
+@code{android.permission.REQUEST_DELETE_PACKAGES}
+@item
+@code{android.permission.REQUEST_IGNORE_BATTERY_OPTIMIZATIONS}
+@item
+@code{android.permission.REQUEST_OBSERVE_COMPANION_DEVICE_PRESENCE}
+@item
+@code{android.permission.REQUEST_PASSWORD_COMPLEXITY}
+@item
+@code{android.permission.RESTART_PACKAGES}
+@item
+@code{android.permission.RUN_USER_INITIATED_JOBS}
+@item
+@code{android.permission.SET_WALLPAPER}
+@item
+@code{android.permission.SET_WALLPAPER_HINTS}
+@item
+@code{android.permission.SUBSCRIBED_FEEDS_READ}
+@item
+@code{android.permission.SUBSCRIBED_FEEDS_WRITE}
+@item
+@code{android.permission.TRANSMIT_IR}
+@item
+@code{android.permission.UPDATE_PACKAGES_WITHOUT_USER_ACTION}
+@item
+@code{android.permission.USE_BIOMETRIC}
+@item
+@code{android.permission.USE_CREDENTIALS}
+@item
+@code{android.permission.USE_EXACT_ALARM}
+@item
+@code{android.permission.USE_FINGERPRINT}
+@item
+@code{android.permission.USE_FULL_SCREEN_INTENT}
+@item
+@code{android.permission.VIBRATE}
+@item
+@code{android.permission.WAKE_LOCK}
+@item
+@code{android.permission.WRITE_PROFILE}
+@item
+@code{android.permission.WRITE_SMS}
+@item
+@code{android.permission.WRITE_SOCIAL_STREAM}
+@item
+@code{android.permission.WRITE_SYNC_SETTINGS}
+@item
+@code{android.permission.WRITE_USER_DICTIONARY}
+@end itemize
+
+Other permissions must be granted by the user from the system settings
+application. Consult the manufacturer of your device for more details,
+as how to do this varies by device.
+
+@item
+On Android 5.1 and earlier, Emacs automatically receives the following
+permissions it has requested upon being installed:
+
+@itemize @minus
+@item
+@code{android.permission.ACCESS_COARSE_LOCATION}
+@item
+@code{android.permission.ACCESS_FINE_LOCATION}
+@item
+@code{android.permission.BODY_SENSORS}
+@item
+@code{android.permission.CALL_PHONE}
+@item
+@code{android.permission.CAMERA}
+@item
+@code{android.permission.CAPTURE_CONSENTLESS_BUGREPORT_ON_USERDEBUG_BUILD}
+@item
+@code{android.permission.GET_ACCOUNTS}
+@item
+@code{android.permission.POST_NOTIFICATIONS}
+@item
+@code{android.permission.PROCESS_OUTGOING_CALLS}
+@item
+@code{android.permission.READ_CALENDAR}
+@item
+@code{android.permission.READ_CALL_LOG}
+@item
+@code{android.permission.READ_CELL_BROADCASTS}
+@item
+@code{android.permission.READ_CONTACTS}
+@item
+@code{android.permission.READ_EXTERNAL_STORAGE}
+@item
+@code{android.permission.READ_PHONE_NUMBERS}
+@item
+@code{android.permission.READ_PHONE_STATE}
+@item
+@code{android.permission.READ_SMS}
+@item
+@code{android.permission.RECEIVE_MMS}
+@item
+@code{android.permission.RECEIVE_SMS}
+@item
+@code{android.permission.RECEIVE_WAP_PUSH}
+@item
+@code{android.permission.RECORD_AUDIO}
+@item
+@code{android.permission.REQUEST_INSTALL_PACKAGES}
+@item
+@code{android.permission.SEND_SMS}
+@item
+@code{android.permission.SMS_FINANCIAL_TRANSACTIONS}
+@item
+@code{android.permission.SYSTEM_ALERT_WINDOW}
+@item
+@code{android.permission.WRITE_CALENDAR}
+@item
+@code{android.permission.WRITE_CALL_LOG}
+@item
+@code{android.permission.WRITE_CONTACTS}
+@item
+@code{android.permission.WRITE_EXTERNAL_STORAGE}
+@item
+@code{android.permission.WRITE_SETTINGS}
+@item
+@code{android.permission.ACCESS_LOCATION_EXTRA_COMMANDS}
+@item
+@code{android.permission.ACCESS_NETWORK_STATE}
+@item
+@code{android.permission.ACCESS_WIFI_STATE}
+@item
+@code{android.permission.BLUETOOTH}
+@item
+@code{android.permission.BLUETOOTH_ADMIN}
+@item
+@code{android.permission.BROADCAST_STICKY}
+@item
+@code{android.permission.CHANGE_NETWORK_STATE}
+@item
+@code{android.permission.CHANGE_WIFI_MULTICAST_STATE}
+@item
+@code{android.permission.CHANGE_WIFI_STATE}
+@item
+@code{android.permission.DISABLE_KEYGUARD}
+@item
+@code{android.permission.EXPAND_STATUS_BAR}
+@item
+@code{android.permission.FLASHLIGHT}
+@item
+@code{android.permission.GET_PACKAGE_SIZE}
+@item
+@code{android.permission.GET_TASKS}
+@item
+@code{android.permission.INTERNET}
+@item
+@code{android.permission.KILL_BACKGROUND_PROCESSES}
+@item
+@code{android.permission.MODIFY_AUDIO_SETTINGS}
+@item
+@code{android.permission.NFC}
+@item
+@code{android.permission.PERSISTENT_ACTIVITY}
+@item
+@code{android.permission.QUERY_ALL_PACKAGES}
+@item
+@code{android.permission.READ_BASIC_PHONE_STATE}
+@item
+@code{android.permission.READ_SYNC_SETTINGS}
+@item
+@code{android.permission.READ_SYNC_STATS}
+@item
+@code{android.permission.READ_USER_DICTIONARY}
+@item
+@code{android.permission.RECEIVE_BOOT_COMPLETED}
+@item
+@code{android.permission.REORDER_TASKS}
+@item
+@code{android.permission.REQUEST_DELETE_PACKAGES}
+@item
+@code{android.permission.REQUEST_IGNORE_BATTERY_OPTIMIZATIONS}
+@item
+@code{android.permission.REQUEST_OBSERVE_COMPANION_DEVICE_PRESENCE}
+@item
+@code{android.permission.RESTART_PACKAGES}
+@item
+@code{android.permission.SET_WALLPAPER}
+@item
+@code{android.permission.SET_WALLPAPER_HINTS}
+@item
+@code{android.permission.TRANSMIT_IR}
+@item
+@code{android.permission.VIBRATE}
+@item
+@code{android.permission.WAKE_LOCK}
+@item
+@code{android.permission.WRITE_SYNC_SETTINGS}
+@item
+@code{android.permission.WRITE_USER_DICTIONARY}
+@end itemize
+
+While most of these permissions are left unused by Emacs itself, they
+are declared by Emacs as they could be useful for other programs; for
+example, the permission to access contacts may be useful for EUDC.
+@end itemize
+
+@node Android Windowing
+@section The Android Window System
+
+ Android's window system is unusual, in that all windows are
+maximized or full-screen, and only one window can be displayed at a
+time. On larger devices, the system permits simultaneously tiling up
+to four windows on the screen.
+
+ Windows on Android do not exist indefinitely after they are created.
+Instead, the system may choose to close windows that are not on screen
+in order to conserve memory, with the assumption that the program will
+save its contents to disk and restore them later, when the user asks
+for it to be opened again. As this is obviously not possible with
+Emacs, Emacs separates the resources associated with a frame from its
+system window.
+
+ Each system window created (including the initial window created
+during Emacs startup) is appended to a list of windows that do not
+have associated frames. When a frame is created, Emacs looks up any
+window within that list, and displays the contents of the frame
+within; if there is no window at all, then one is created. Likewise,
+when a new window is created by the system, Emacs places the contents
+of any frame that is not already displayed within a window inside.
+When a frame is closed, the corresponding system window is also
+closed. Upon startup, the system creates a window itself (within
+which Emacs displays the first window system frame shortly
+thereafter.) Emacs differentiates between that window and windows
+created on behalf of other frames to determine what to do when the
+system window associated with a frame is closed:
+
+@itemize @bullet
+@item
+When the system closes the window created during application startup
+in order to save memory, Emacs retains the frame for when that window
+is created later.
+
+@item
+When the user closes the window created during application startup,
+and the window was not previously closed by the system in order to
+save resources, Emacs deletes any frame displayed within that window.
+
+However, on Android 7.0 and later, such frames are not deleted if the
+window is closed four or more hours after the window moves into the
+background, as the system automatically removes open windows once a
+certain period of inactivity elapses when the number of windows retained
+by the window manager surpasses a specific threshold, and window
+deletion by this mechanism is indistinguishable from window deletion by
+the user. Emacs begins to ignore window deletion after two hours less
+than the default value of this threshold both to err on the side of
+caution, in case the system's record of inactivity and Emacs's differ,
+and for the reason that this threshold is open to customization by OS
+distributors.
+
+@item
+When the user or the system closes any window created by Emacs on
+behalf of a specific frame, Emacs deletes the frame displayed within
+that window.
+@end itemize
+
+ When the system predates Android 5.0, the window manager will not
+accept more than one user-created Emacs window. If frame creation gives
+rise to windows in excess of this limit, the window manager will
+arbitrarily select one of their number to display, with the rest
+remaining invisible until that window is destroyed with its frame.
+
+@cindex windowing limitations, android
+@cindex frame parameters, android
+Emacs only supports a limited subset of GUI features on Android; the
+limitations are as follows:
+
+@itemize @bullet
+@item
+Scroll bars are not supported, as they are close to useless on Android
+devices.
+
+@item
+The @code{alpha}, @code{alpha-background}, @code{z-group},
+@code{override-redirect}, @code{mouse-color}, @code{title},
+@code{wait-for-wm}, @code{sticky}, @code{undecorated} and
+@code{tool-bar-position} frame parameters (@pxref{Frame Parameters,,,
+elisp, the Emacs Lisp Reference Manual}) are unsupported.
+
+@item
+On Android 4.0 and earlier, the @code{fullscreen} frame parameter is
+always @code{maximized} for top-level frames; on later versions of
+Android, it can also be @code{fullscreen}.
+@end itemize
+
+@cindex selections, android
+@cindex android clipboard
+ Emacs does not implement all selection related features supported
+under the X Window System on Android. For example, only the
+@code{CLIPBOARD} and @code{PRIMARY} selections (@pxref{Cut and Paste})
+are supported, and Emacs is only able to set selections to plain text.
+
+ In addition, the Android system itself places certain restrictions
+on what selection data Emacs can access:
+
+@itemize @bullet
+@item
+On Android 2.3 and earlier, the function @code{gui-selection-owner-p}
+always returns @code{nil} for the clipboard selection.
+
+@item
+Between Android 3.0 and Android 9.0, Emacs is able to access the
+clipboard whenever it wants, and @code{gui-selection-owner-p} always
+returns accurate results.
+
+@item
+Under Android 10.0 and later, Emacs can only access clipboard data
+when one of its frames has the input focus, and
+@code{gui-selection-owner-p} always returns @code{nil} for the
+clipboard selection.
+@end itemize
+
+ Since the Android system itself has no concept of a primary
+selection, Emacs provides an emulation instead. This means there is
+no way to transfer the contents of the primary selection to another
+application via cut-and-paste.
+
+@vindex android-pass-multimedia-buttons-to-system
+@cindex volume/multimedia buttons, Android
+ The volume keys are normally reserved by Emacs and used to provide
+the ability to quit Emacs without a physical keyboard
+(@pxref{On-Screen Keyboards}.) However, if you want them to adjust
+the volume instead, you can set the variable
+@code{android-pass-multimedia-buttons-to-system} to a non-@code{nil}
+value; note that you will no longer be able to quit Emacs using the
+volume buttons in that case.
+
+@cindex dialog boxes, android
+ Emacs is unable to display dialog boxes (@pxref{Dialog Boxes}) while
+it does not have the input focus on Android 6.0 or later. If this is
+important to you, this capability can be restored by granting Emacs
+permission to display over other programs. On most systems, this can
+be done from the following Settings menu:
+
+@example
+System -> Apps -> Emacs -> More -> Display over other apps
+@end example
+
+@cindex keyboard modifiers, android
+ There is a direct relation between physical modifier keys and Emacs
+modifiers (@pxref{Modifier Keys}) reported within key events, subject
+to a single exception: if @key{Alt} on your keyboard is depressed,
+then the @key{Meta} modifier will be reported by Emacs in its place,
+and vice versa. This irregularity is since most keyboards possess no
+special @key{Meta} key, and the @key{Alt} modifier is seldom employed
+in Emacs.
+
+ Bear in mind that Android uses a different name for the @key{Super}
+modifier: it is referred to as @key{SYM} on Android keyboards and
+within the Settings keymap menu.
+
+@vindex android-intercept-control-space
+@cindex @kbd{C-SPC} interception, android
+ Android input methods have a penchant for irritating users by
+silently discarding key sequences containing @kbd{C-SPC} during the
+event filtering process, that they normally have no real application
+for such key sequences notwithstanding. By default, Emacs intercepts
+these key sequences before they can be filtered by the input method.
+
+ If this proves unwanted (for instance, if the input method treats
+@kbd{C-SPC} as a shortcut key for switching languages), it can be
+disabled by setting the variable
+@code{android-intercept-control-space} to @code{nil}.
+
+@vindex android-keyboard-bell-duration
+@cindex keyboard bell, android
+ The keyboard bell installed within Android systems takes the form of
+a vibrating element that is activated for a number of milliseconds
+whenever the bell is rung. The duration of this vibration can be
+customized through altering the variable
+@code{android-keyboard-bell-duration} to any value between @code{10}
+and @code{1000}.
+
+@node Android Fonts
+@section Font Backends and Selection under Android
+@cindex fonts, android
+
+ Emacs supports two font backends under Android: they are
+respectively named @code{sfnt-android} and @code{android}.
+
+ Upon startup, Emacs enumerates all the TrueType format fonts in the
+directories @file{/system/fonts} and @file{/product/fonts}, and the
+@file{fonts} directory (@dfn{user fonts directory}) inside the Emacs
+home directory. Emacs assumes there will always be a font named
+``Droid Sans Mono'', and then defaults to using this font. These
+fonts are then displayed by the @code{sfnt-android} font driver.
+
+ This font driver is presently without support for OpenType fonts;
+hence, only a subset of the fonts installed on any given system are
+available to Emacs. If you are interested in lifting this limitation,
+please contact @email{emacs-devel@@gnu.org}.
+
+ If the @code{sfnt-android} font driver fails to find any fonts at
+all, Emacs falls back to the @code{android} font driver. This is a
+very poor font driver, consequent upon limitations and inaccuracies in
+the font metrics provided by the Android platform. In that case,
+Emacs uses the ``Monospace'' typeface configured on your system; this
+should always be Droid Sans Mono.
+
+@cindex TrueType GX fonts, android
+@cindex distortable fonts, android
+
+ As on X systems, Emacs supports distortable fonts under Android.
+These fonts (also termed ``TrueType GX fonts'', ``variable fonts'',
+and ``multiple master fonts'') provide multiple different styles
+(``Bold'', ``Italic'', and the like) using a single font file.
+
+ When a user-installed distortable font is found, each style that a
+previously discovered font provided will no longer be used. In
+addition, any previously installed distortable fonts with the same
+family name are also disregarded, provided that the new distortable
+font supplies a superset of the styles furnished by the previously
+installed font. When a conventional font is found, any previous
+conventional font with the same style and family will be removed;
+distortable fonts with the same family will no longer be used to
+provide that style.
+
+@cindex default font families, Android
+@vindex sfnt-default-family-alist
+
+ Emacs generally assumes the presence of font families named
+@samp{Monospace}, @samp{Monospace Serif}, @samp{Sans Serif}, and
+@samp{DejaVu Serif}. Since Android does not provide any fonts by
+these names, Emacs modifies requests for them to request one of a
+corresponding set of font families distributed with Android.
+
+ To change either the set of font families subject to replacement, or
+that by which they are replaced, modify the variable
+@code{sfnt-default-family-alist}; then, restart Emacs. Bear in mind
+that this is usually unwarranted, with customizations to the default
+or @code{variable-pitch} faces better made through modifying their
+definitions (@pxref{Face Customization}).
+
+@node Android Troubleshooting
+@section Troubleshooting Startup Problems on Android
+@cindex troubleshooting, android
+
+@cindex emacs -Q, android
+@cindex emacs --debug-init, android
+ Since Android has no command line, there is normally no way to
+specify command-line arguments when starting Emacs. This is very
+nasty when you make a mistake in your Emacs initialization files that
+prevents Emacs from starting up at all, as the system generally
+prohibits other programs from accessing Emacs's home directory.
+@xref{Initial Options}.
+
+ However, Emacs can be started with the equivalent of either the
+option @code{--quick}, or @code{--debug-init} through a special
+preferences screen. Under Android 7.0 and later, this can be accessed
+through the Emacs ``app info'' page in the system settings program; on
+older systems, this is displayed as a separate icon on the desktop
+labeled ``Emacs options''.
+
+ Consult the manufacturer of your device for more details, as how to
+do this varies by device.
+
+@cindex dumping, android
+ The first time any given copy of Emacs starts on a device, it spends
+a while loading the preloaded Lisp files which normally come with
+Emacs. This produces a ``dump file'' (@pxref{Initial Options}) in the
+files directory, containing an identifier unique to that copy of
+Emacs.
+
+ The next time that same copy of Emacs starts up, it simply loads the
+data contained in that dump file, greatly reducing start up time.
+
+ If by some unforeseen circumstance the dump file is corrupted, Emacs
+can crash. If that happens, the dump file stored in the Emacs files
+directory can be erased through the preferences screen described
+above.
+
+@cindex accessing Emacs directories, Android
+ Emacs supports an alternative method of rescuing broken Emacs
+installations on Android 4.4 and later: Emacs exports a ``documents
+provider'' which accesses the contents of Emacs's home directory, that
+can then be accessed by any file manager program.
+
+ If you can find out how to open that documents provider in the file
+manager that comes with your device, you can rename, delete, or edit
+your initialization or dump files from there instead.
+
+@node Android Software
+@section Installing Extra Software on Android
+@cindex installing extra software on Android
+@cindex installing Unix software on Android
+
+ An exceptionally limited set of Unix-like command line tools is
+distributed alongside default installations of Android. Several
+projects exist to augment this selection, providing options that range
+from improved reproductions of Unix command-line utilities to package
+repositories providing extensive collections of free GNU and Unix
+software.
+
+ @uref{http://busybox.net, Busybox} provides Unix utilities and
+limited replicas of certain popular GNU programs such as
+@command{wget} in a single statically-linked Linux binary, which is
+capable of running under Android.
+
+ @uref{https://termux.dev, Termux} provides a package manager based
+on the Debian project's @command{dpkg} system and a set of package
+repositories containing substantial amounts of free software for Unix
+systems, including compilers, debuggers, and runtimes for languages
+such as C, C++, Java, Python and Common Lisp. These packages are
+customarily installed from within a purpose-built terminal emulator
+application, but access is also granted to Emacs when it is built with
+the same application signing key, and its ``shared user ID'' is set to
+the same package name, as that of the terminal emulator program. The
+file @file{java/INSTALL} within the Emacs distribution illustrates how
+to build Emacs in this fashion.
+
+ @uref{https://github.com/termux/termux-packages, termux-packages}
+provides the package definitions used by Termux to generate their
+package repositories, which may also be independently compiled for
+installation within Emacs's home directory.
+
+ In addition to the projects mentioned above, statically linked
+binaries for most Linux kernel-based systems can also be run on
+Android.
diff --git a/doc/emacs/basic.texi b/doc/emacs/basic.texi
index f64b3995d25..b1b1573729a 100644
--- a/doc/emacs/basic.texi
+++ b/doc/emacs/basic.texi
@@ -630,6 +630,21 @@ before they get too long, by inserting newlines. If you prefer, you
can make Emacs insert a newline automatically when a line gets too
long, by using Auto Fill mode. @xref{Filling}.
+@cindex continuation lines, visual wrap prefix
+@findex visual-wrap-prefix-mode
+@findex global-visual-wrap-prefix-mode
+ Normally, the first character of each continuation line is
+positioned at the beginning of the screen line where it is displayed.
+The minor mode @code{visual-wrap-prefix-mode} and its global
+(@pxref{Minor Modes}) counterpart
+@code{global-visual-wrap-prefix-mode} arranges that continuation lines
+be prefixed by slightly adjusted versions of the fill prefixes
+(@pxref{Fill Prefix}) of their respective logical lines, so that
+indentation characters or the prefixes of source code comments are
+replicated across every continuation line, and the appearance of such
+comments or indentation is not broken. These prefixes are only shown
+on display, and does not change the buffer text in any way.
+
Sometimes, you may need to edit files containing many long logical
lines, and it may not be practical to break them all up by adding
newlines. In that case, you can use Visual Line mode, which enables
diff --git a/doc/emacs/buffers.texi b/doc/emacs/buffers.texi
index 8542243dadf..2786ff6ad65 100644
--- a/doc/emacs/buffers.texi
+++ b/doc/emacs/buffers.texi
@@ -205,7 +205,7 @@ Here is an example of a buffer list:
@smallexample
CRM Buffer Size Mode File
-. * .emacs 3294 Emacs-Lisp ~/.emacs
+. * .emacs 3294 ELisp/l ~/.emacs
% *Help* 101 Help
search.c 86055 C ~/cvs/emacs/src/search.c
% src 20959 Dired by name ~/cvs/emacs/src/
@@ -223,8 +223,10 @@ the directory @file{~/cvs/emacs/src/}. You can list only buffers that
are visiting files by giving the command a prefix argument, as in
@kbd{C-u C-x C-b}.
- @code{list-buffers} omits buffers whose names begin with a space,
-unless they visit files: such buffers are used internally by Emacs.
+ By default, @code{list-buffers} omits buffers whose names begin with a
+space, unless they visit files: such buffers are used internally by
+Emacs (but the @kbd{I} command countermands that, @pxref{Several
+Buffers}).
@node Misc Buffer
@section Miscellaneous Buffer Operations
@@ -401,57 +403,57 @@ cursor motion commands can be used in this buffer. The following
commands apply to the buffer described on the current line:
@table @kbd
-@item d
@findex Buffer-menu-delete
@kindex d @r{(Buffer Menu)}
+@item d
Flag the buffer for deletion (killing), then move point to the next
line (@code{Buffer-menu-delete}). The deletion flag is indicated by
the character @samp{D} on the line, before the buffer name. The
deletion occurs only when you type the @kbd{x} command (see below).
-@item C-d
@findex Buffer-menu-delete-backwards
@kindex C-d @r{(Buffer Menu)}
+@item C-d
Like @kbd{d}, but move point up instead of down
(@code{Buffer-menu-delete-backwards}).
-@item s
@findex Buffer-menu-save
@kindex s @r{(Buffer Menu)}
+@item s
Flag the buffer for saving (@code{Buffer-menu-save}). The save flag
is indicated by the character @samp{S} on the line, before the buffer
name. The saving occurs only when you type @kbd{x}. You may request
both saving and deletion for the same buffer.
-@item x
@findex Buffer-menu-execute
@kindex x @r{(Buffer Menu)}
+@item x
Perform all flagged deletions and saves (@code{Buffer-menu-execute}).
-@item u
@findex Buffer-menu-unmark
@kindex u @r{(Buffer Menu)}
+@item u
Remove all flags from the current line, and move down
(@code{Buffer-menu-unmark}). With a prefix argument, moves up after
removing the flags.
-@item @key{DEL}
@findex Buffer-menu-backup-unmark
@kindex DEL @r{(Buffer Menu)}
+@item @key{DEL}
Move to the previous line and remove all flags on that line
(@code{Buffer-menu-backup-unmark}).
-@item M-@key{DEL}
@findex Buffer-menu-unmark-all-buffers
@kindex M-DEL @r{(Buffer Menu)}
+@item M-@key{DEL}
Remove a particular flag from all lines
(@code{Buffer-menu-unmark-all-buffers}). This asks for a single
character, and unmarks buffers marked with that character; typing
@key{RET} removes all marks.
-@item U
@findex Buffer-menu-unmark-all
@kindex U @r{(Buffer Menu)}
+@item U
Remove all flags from all the lines
(@code{Buffer-menu-unmark-all}).
@end table
@@ -465,21 +467,21 @@ the current line. They also accept a numeric argument as a repeat
count.
@table @kbd
-@item ~
@findex Buffer-menu-not-modified
@kindex ~ @r{(Buffer Menu)}
+@item ~
Mark the buffer as unmodified (@code{Buffer-menu-not-modified}).
@xref{Save Commands}.
-@item %
@findex Buffer-menu-toggle-read-only
@kindex % @r{(Buffer Menu)}
+@item %
Toggle the buffer's read-only status
(@code{Buffer-menu-toggle-read-only}). @xref{Misc Buffer}.
-@item t
@findex Buffer-menu-visit-tags-table
@kindex t @r{(Buffer Menu)}
+@item t
Visit the buffer as a tags table
(@code{Buffer-menu-visit-tags-table}). @xref{Select Tags Table}.
@end table
@@ -487,63 +489,63 @@ Visit the buffer as a tags table
The following commands are used to select another buffer or buffers:
@table @kbd
-@item q
@findex quit-window
@kindex q @r{(Buffer Menu)}
+@item q
Quit the Buffer Menu (@code{quit-window}). The most recent formerly
visible buffer is displayed in its place.
-@item @key{RET}
-@itemx f
@findex Buffer-menu-this-window
@kindex f @r{(Buffer Menu)}
@kindex RET @r{(Buffer Menu)}
+@item @key{RET}
+@itemx f
Select this line's buffer, replacing the @file{*Buffer List*} buffer
in its window (@code{Buffer-menu-this-window}).
-@item o
@findex Buffer-menu-other-window
@kindex o @r{(Buffer Menu)}
+@item o
Select this line's buffer in another window, as if by @kbd{C-x 4 b},
leaving @file{*Buffer List*} visible
(@code{Buffer-menu-other-window}).
-@item C-o
@findex Buffer-menu-switch-other-window
@kindex C-o @r{(Buffer Menu)}
+@item C-o
Display this line's buffer in another window, without selecting it
(@code{Buffer-menu-switch-other-window}).
-@item 1
@findex Buffer-menu-1-window
@kindex 1 @r{(Buffer Menu)}
+@item 1
Select this line's buffer in a full-frame window
(@code{Buffer-menu-1-window}).
-@item 2
@findex Buffer-menu-2-window
@kindex 2 @r{(Buffer Menu)}
+@item 2
Set up two windows on the current frame, with this line's buffer
selected in one, and a previously current buffer (aside from
@file{*Buffer List*}) in the other (@code{Buffer-menu-2-window}).
-@item b
@findex Buffer-menu-bury
@kindex b @r{(Buffer Menu)}
+@item b
Bury this line's buffer (@code{Buffer-menu-bury}) (i.e., move it to
the end of the buffer list).
-@item m
@findex Buffer-menu-mark
@kindex m @r{(Buffer Menu)}
+@item m
Mark this line's buffer to be displayed in another window if you exit
with the @kbd{v} command (@code{Buffer-menu-mark}). The display flag
is indicated by the character @samp{>} at the beginning of the line.
(A single buffer may not have both deletion and display flags.)
-@item v
@findex Buffer-menu-select
@kindex v @r{(Buffer Menu)}
+@item v
Select this line's buffer, and also display in other windows any
buffers flagged with the @kbd{m} command (@code{Buffer-menu-select}).
If you have not flagged any buffers, this command is equivalent to
@@ -553,31 +555,37 @@ If you have not flagged any buffers, this command is equivalent to
The following commands affect the entire buffer list:
@table @kbd
-@item S
@findex tabulated-list-sort
@kindex S @r{(Buffer Menu)}
+@item S
Sort the Buffer Menu entries according to their values in the column
at point. With a numeric prefix argument @var{n}, sort according to
the @var{n}-th column (@code{tabulated-list-sort}).
-@item @}
@kindex @} @r{(Buffer Menu)}
@findex tabulated-list-widen-current-column
+@item @}
Widen the current column width by @var{n} (the prefix numeric
argument) characters.
-@item @{
@kindex @{ @r{(Buffer Menu)}
@findex tabulated-list-narrow-current-column
+@item @{
Narrow the current column width by @var{n} (the prefix numeric
argument) characters.
-@item T
@findex Buffer-menu-toggle-files-only
@kindex T @r{(Buffer Menu)}
+@item T
Delete, or reinsert, lines for non-file buffers
(@code{Buffer-menu-toggle-files-only}). This command toggles the
inclusion of such buffers in the buffer list.
+
+@findex Buffer-menu-toggle-internal
+@kindex I @r{(Buffer Menu)}
+@item I
+Toggle display of internal buffers, those whose names begin with a
+space.
@end table
Normally, the buffer @file{*Buffer List*} is not updated
@@ -731,7 +739,7 @@ rule or another is easier for you to remember and apply quickly.
@findex icomplete-mode
@cindex Icomplete mode
- Icomplete global minor mode provides a convenient way to quickly select an
+ Icomplete mode provides a convenient way to quickly select an
element among the possible completions in a minibuffer. When enabled, typing
in the minibuffer continuously displays a list of possible completions that
match the string you have typed.
@@ -749,9 +757,28 @@ further. This is typically used when entering a file name, where
@kbd{M-@key{TAB}} can be used a few times to descend in the hierarchy
of directories.
- To enable Icomplete mode, type @kbd{M-x icomplete-mode}, or customize
-the variable @code{icomplete-mode} to @code{t} (@pxref{Easy
-Customization}).
+ To enable Icomplete mode for the minibuffer, type @kbd{M-x
+icomplete-mode}, or customize the variable @code{icomplete-mode} to
+@code{t} (@pxref{Easy Customization}).
+
+ You can also additionally enable Icomplete mode for @kbd{C-M-i} (the
+command @code{completion-at-point}) by customizing the variable
+@code{icomplete-in-buffer} to @code{t}. For in-buffer completion, the
+@code{completion-auto-help} variable controls when Icomplete mode's
+display of possible completions appears. The default value of
+@code{t} means that the display of possible completions appears when
+you first type @kbd{C-M-i}.
+
+ By default, when you press @kbd{C-M-i}, both Icomplete mode's
+in-buffer display of possible completions and the @file{*Completions*}
+buffer appear. If you are using @code{icomplete-in-buffer}, then you
+may wish to suppress this appearance of the @file{*Completions*}
+buffer. To do that, add the following to your initialization file
+(@pxref{Init File}):
+
+@example
+(advice-add 'completion-at-point :after #'minibuffer-hide-completions)
+@end example
@findex fido-mode
@cindex fido mode
diff --git a/doc/emacs/building.texi b/doc/emacs/building.texi
index c2c63ec5b36..38cc0bb67af 100644
--- a/doc/emacs/building.texi
+++ b/doc/emacs/building.texi
@@ -567,7 +567,7 @@ see the Flymake Info manual, which is distributed with Emacs.
The GUD (Grand Unified Debugger) library provides an Emacs interface
to a wide variety of symbolic debuggers. It can run the GNU Debugger
-(GDB), as well as DBX, SDB, XDB, Guile REPL debug commands, Perl's
+(GDB), as well as LLDB, DBX, SDB, XDB, Guile REPL debug commands, Perl's
debugging mode, the Python debugger PDB, and the Java Debugger JDB.
Emacs provides a special interface to GDB, which uses extra Emacs
@@ -609,6 +609,10 @@ exists, switch to it; otherwise, create the buffer and switch to it.
The other commands in this list do the same, for other debugger
programs.
+@item M-x lldb
+@findex lldb
+Run the LLDB debugger.
+
@item M-x perldb
@findex perldb
Run the Perl interpreter in debug mode.
@@ -698,6 +702,20 @@ which edited source line corresponds to the line reported by the
debugger subprocess. To update this information, you typically have
to recompile and restart the program.
+@cindex GUD and hl-line-mode
+@cindex highlighting execution lines in GUD
+@vindex gud-highlight-current-line
+ Moreover, GUD is capable of visually demarcating the current
+execution line within the window text itself in one of two fashions:
+the first takes effect when the user option
+@code{gud-highlight-current-line} is enabled, and displays that line
+in an overlay whose appearance is provided by the face
+@code{gud-highlight-current-line-face}. The other takes effect when
+HL Line Mode (@pxref{Cursor Display}) is enabled, and moves the
+overlay introduced by HL Line Mode briefly to the execution line,
+until a subsequent editing command repositions it back beneath the
+cursor.
+
@cindex GUD Tooltip mode
@cindex mode, GUD Tooltip
@findex gud-tooltip-mode
diff --git a/doc/emacs/cmdargs.texi b/doc/emacs/cmdargs.texi
index 7ce9c9618f9..49810ee7693 100644
--- a/doc/emacs/cmdargs.texi
+++ b/doc/emacs/cmdargs.texi
@@ -640,6 +640,11 @@ set this in the ``Regional Settings'' Control Panel on some versions
of MS-Windows, and in the ``Language and Region'' System Preference on
macOS.
+When running a GUI session on Android, @env{LANG} is set to a fixed
+value, but the language and locale environment is derived from the
+system's ``Languages & Input'' preferences. @xref{Android
+Environment}.
+
The value of the @env{LC_CTYPE} category is
matched against entries in @code{locale-language-names},
@code{locale-charset-language-names}, and
diff --git a/doc/emacs/commands.texi b/doc/emacs/commands.texi
index 60e385d9f2e..a8f89feed62 100644
--- a/doc/emacs/commands.texi
+++ b/doc/emacs/commands.texi
@@ -227,6 +227,8 @@ until you are interested in customizing them. Then read the basic
information on variables (@pxref{Variables}) and the information about
specific variables will make sense.
+@include input.texi
+
@ifnottex
@lowersections
@end ifnottex
diff --git a/doc/emacs/custom.texi b/doc/emacs/custom.texi
index 4bd78f3ce83..4725af0ee5f 100644
--- a/doc/emacs/custom.texi
+++ b/doc/emacs/custom.texi
@@ -1329,6 +1329,15 @@ pairs in the file, by typing @kbd{i} at the confirmation prompt --
these pairs will thereafter be ignored in this file and in all other
files.
+ When Emacs asks for confirmation for setting directory-local
+variables (@pxref{Directory Variables}), typing @kbd{+} at the
+confirmation prompt will set all the variables, and also add the
+directory to the list in @code{safe-local-variable-directories}
+(described below), which will cause Emacs to consider this directory
+as safe for loading any directory-local variables in the future. The
+@kbd{+} response should only be used for directories whose contents
+you trust.
+
@vindex safe-local-variable-values
@vindex ignored-local-variable-values
@cindex risky variable
@@ -1345,6 +1354,16 @@ record safe values for risky variables, do it directly by customizing
Similarly, if you want to record values of risky variables that should
be permanently ignored, customize @code{ignored-local-variable-values}.
+@vindex safe-local-variable-directories
+ Sometimes it is helpful to always trust directory-variables in
+certain directories, and skip the confirmation prompt when local
+variables are loaded from those directories, even if the variables are
+risky. The variable @code{safe-local-variable-directories} holds the
+list of such directories. The names of the directories in this list
+must be full absolute file names. If the variable
+@code{enable-remote-dir-locals} has a non-@code{nil} value, the list
+can include remote directories as well (@pxref{Remote Files}).
+
@vindex enable-local-variables
The variable @code{enable-local-variables} allows you to change the
way Emacs processes local variables. Its default value is @code{t},
@@ -1489,7 +1508,18 @@ mode or subdirectory, and for variable and value, and adds the
entry defining the directory-local variable. @kbd{M-x
delete-dir-local-variable} deletes an entry. @kbd{M-x
copy-file-locals-to-dir-locals} copies the file-local variables in the
-current file into @file{.dir-locals.el}.
+current file into @file{.dir-locals.el}, or @file{.dir-locals-2.el} if
+that file is also present.
+
+With a prefix argument, all three commands prompt for the file you
+want to modify. Although it doesn't have to exist, you must enter a
+valid filename, either @file{.dir-locals.el} or
+@file{.dir-locals-2.el}.
+
+@findex customize-dirlocals
+There's also a command to pop up an Easy Customization buffer
+(@pxref{Easy Customization}) to edit directory local variables,
+@code{customize-dirlocals}.
@findex dir-locals-set-class-variables
@findex dir-locals-set-directory-class
diff --git a/doc/emacs/dired.texi b/doc/emacs/dired.texi
index 56a46398ec6..a3a740f9727 100644
--- a/doc/emacs/dired.texi
+++ b/doc/emacs/dired.texi
@@ -142,6 +142,10 @@ characters well. If you have many such files, you may consider adding
special characters and allow Dired to handle them better. (You can
also use the @kbd{C-u C-x d} command to add @samp{-b} temporarily.)
+@code{dired-listing-switches} can be declared as connection-local
+variable to adjust it to match what a remote system expects
+(@pxref{Connection Variables}).
+
@vindex dired-switches-in-mode-line
Dired displays in the mode line an indication of what were the
switches used to invoke @command{ls}. By default, Dired will try to
@@ -684,6 +688,19 @@ cause trouble. For example, after renaming one or more files,
@code{dired-undo} restores the original names in the Dired buffer,
which gets the Dired buffer out of sync with the actual contents of
the directory.
+
+@item touchscreen-hold
+@kindex touchscreen-hold @r{(Dired)}
+@findex dired-click-to-select-mode
+@findex dired-enable-click-to-select-mode
+Enter a ``click to select'' mode, where using the mouse button
+@kbd{mouse-2} on a file name will cause its mark to be toggled. This
+mode is useful when performing file management using a touch screen
+device.
+
+It is enabled when a ``hold'' gesture (@pxref{Touchscreens}) is
+detected over a file name, and is automatically disabled once a Dired
+command operates on the marked files.
@end table
@node Operating on Files
diff --git a/doc/emacs/display.texi b/doc/emacs/display.texi
index 6db9e8344c6..bda57d2b30e 100644
--- a/doc/emacs/display.texi
+++ b/doc/emacs/display.texi
@@ -2210,6 +2210,14 @@ keys; its value is the number of seconds of pause required to cause echoing
to start, or zero, meaning don't echo at all. The value takes effect when
there is something to echo. @xref{Echo Area}.
+@vindex echo-keystrokes-help
+ If the variable @code{echo-keystrokes-help} is non-@code{nil} (the
+default), the multi-character key sequence echo shown according to
+@code{echo-keystrokes} will include a short help text about keys which
+will invoke @code{describe-prefix-bindings} (@pxref{Misc Help}) to show
+the list of commands for the prefix you already typed. For a related
+help facility, see @ref{which-key}.
+
@cindex mouse pointer
@cindex hourglass pointer display
@vindex display-hourglass
diff --git a/doc/emacs/emacs.texi b/doc/emacs/emacs.texi
index 3e1eb6f4236..7d77f13ab21 100644
--- a/doc/emacs/emacs.texi
+++ b/doc/emacs/emacs.texi
@@ -149,6 +149,7 @@ Important General Concepts
editing action.
* Mouse Input:: Using the mouse and keypads.
* Commands:: Named functions run by key sequences to do editing.
+* Other Input:: Input besides the mouse, keyboard and keypads.
* Entering Emacs:: Starting Emacs from the shell.
* Exiting:: Stopping or killing Emacs.
@@ -222,6 +223,7 @@ Appendices
* Antinews:: Information about Emacs version 28.
* Mac OS / GNUstep:: Using Emacs under macOS and GNUstep.
* Haiku:: Using Emacs on Haiku.
+* Android:: Using Emacs on Android.
* Microsoft Windows:: Using Emacs on Microsoft Windows and MS-DOS.
* Manifesto:: What's GNU? Gnu's Not Unix!
@@ -256,6 +258,10 @@ The Organization of the Screen
* Mode Line:: Interpreting the mode line.
* Menu Bar:: How to use the menu bar.
+Touchscreen Input and Virtual Keyboards
+* Touchscreens:: Interacting with Emacs from touchscreens.
+* On-Screen Keyboards:: Text input with virtual keyboards.
+
Basic Editing Commands
* Inserting Text:: Inserting text by simply typing it.
@@ -1260,6 +1266,18 @@ Emacs and Haiku
* Haiku Basics:: Basic Emacs usage and installation under Haiku.
* Haiku Fonts:: The various options for displaying fonts on Haiku.
+Emacs and Android
+
+* What is Android?:: Preamble.
+* Android Startup:: Starting up Emacs on Android.
+* Android File System:: The Android file system.
+* Android Document Providers:: Accessing files from other programs.
+* Android Environment:: Running Emacs under Android.
+* Android Windowing:: The Android window system.
+* Android Fonts:: Font selection under Android.
+* Android Troubleshooting:: Dealing with problems.
+* Android Software:: Getting extra software.
+
Emacs and Microsoft Windows/MS-DOS
* Windows Startup:: How to start Emacs on Windows.
@@ -1630,6 +1648,7 @@ Lisp programming.
@include anti.texi
@include macos.texi
@include haiku.texi
+@include android.texi
@c Includes msdos-xtra.
@include msdos.texi
@include gnu.texi
diff --git a/doc/emacs/files.texi b/doc/emacs/files.texi
index d074a55b762..ccdeef414e2 100644
--- a/doc/emacs/files.texi
+++ b/doc/emacs/files.texi
@@ -372,12 +372,12 @@ you could say:
'(("src/emacs/[^/]+/\\(.*\\)\\'" "src/emacs/.*/\\1")))
@end lisp
-As you can see, this is a list of @var{(MATCH EXPANSION...)} elements.
-The @var{match} is a regular expression that matches the visited file
-name, and each @var{expansion} may refer to match groups by using
-@samp{\\1} and so on. The resulting expansion string is then applied
-to the file system to see if any files match this expansion
-(interpreted as a regexp).
+As you can see, this is a list of @w{@code{(@var{MATCH}
+@var{EXPANSION}...)}} elements. The @var{match} is a regular
+expression that matches the visited file name, and each
+@var{expansion} may refer to match groups by using @samp{\\1} and so
+on. The resulting expansion string is then applied to the file system
+to see if any files match this expansion (interpreted as a regexp).
@vindex find-file-hook
@vindex find-file-not-found-functions
@@ -822,22 +822,21 @@ in these cases, customize the variable
@vindex write-region-inhibit-fsync
Normally, when a program writes a file, the operating system briefly
caches the file's data in main memory before committing the data to
-disk. This can greatly improve performance; for example, when running
-on laptops, it can avoid a disk spin-up each time a file is written.
-However, it risks data loss if the operating system crashes before
-committing the cache to disk.
+secondary storage. Although this can greatly improve performance, it
+risks data loss if the system loses power before committing the cache,
+and on some platforms other processes might not immediately notice the
+file's change.
To lessen this risk, Emacs can invoke the @code{fsync} system call
after saving a file. Using @code{fsync} does not eliminate the risk
-of data loss, partly because many systems do not implement
+of data loss or slow notification, partly because many systems do not support
@code{fsync} properly, and partly because Emacs's file-saving
procedure typically relies also on directory updates that might not
survive a crash even if @code{fsync} works properly.
The @code{write-region-inhibit-fsync} variable controls whether
Emacs invokes @code{fsync} after saving a file. The variable's
-default value is @code{nil} when Emacs is interactive, and @code{t}
-when Emacs runs in batch mode (@pxref{Initial Options, Batch Mode}).
+default value is @code{t}.
Emacs never uses @code{fsync} when writing auto-save files, as these
files might lose data anyway.
@@ -1337,6 +1336,10 @@ directory listing describing the specified file and the auto-save file,
so you can compare their sizes and dates. If the auto-save file
is older, @kbd{M-x recover-file} does not offer to read it.
+When @kbd{M-x recover-file} asks for confirmation, if you answer with
+@kbd{diff} or @kbd{=}, it shows the diffs between @var{file} and its
+auto-save file @file{#@var{file}#} and reprompts you for confirmation.
+
@findex recover-session
If Emacs or the computer crashes, you can recover all the files you
were editing from their auto save files with the command @kbd{M-x
@@ -1749,9 +1752,13 @@ only the hunks within the region.
Re-generate the current hunk (@code{diff-refresh-hunk}).
@item C-c C-w
+@vindex diff-ignore-whitespace-switches
@findex diff-ignore-whitespace-hunk
-Re-generate the current hunk, disregarding changes in whitespace
-(@code{diff-ignore-whitespace-hunk}).
+Re-generate the current hunk, disregarding changes in whitespace.
+With a non-@code{nil} prefix arg, re-generate all the hunks
+(@code{diff-ignore-whitespace-hunk}). This calls @code{diff-command}
+with @code{diff-ignore-whitespace-switches}, which defaults to
+@samp{-b}, meaning ignore changes in whitespace only.
@item C-x 4 A
@findex diff-add-change-log-entries-other-window
@@ -1911,6 +1918,11 @@ following in the Trash directory:
liable to also delete this @code{.dir-locals.el} file, so this should
only be done if you delete files from the Trash directory manually.
+@vindex remote-file-name-inhibit-delete-by-moving-to-trash
+ If the variable @code{remote-file-name-inhibit-delete-by-moving-to-trash}
+is non-@code{nil}, remote files are never moved to the Trash. They
+are deleted instead.
+
@ifnottex
If a file is under version control (@pxref{Version Control}), you
should delete it using @kbd{M-x vc-delete-file} instead of @kbd{M-x
@@ -2096,10 +2108,11 @@ Otherwise, Emacs uses @command{ssh}.
@end enumerate
@cindex disabling remote files
+@cindex inhibit-remote-files
@noindent
-You can entirely turn off the remote file name feature by setting the
-variable @code{tramp-mode} to @code{nil}. You can turn off the
-feature in individual cases by quoting the file name with @samp{/:}
+You can entirely turn off the remote file name feature by running
+@kbd{M-x inhibit-remote-files}. You can turn off the feature in
+individual cases by quoting the file name with @samp{/:}
(@pxref{Quoted File Names}).
@cindex @code{ange-ftp}
@@ -2258,6 +2271,12 @@ to visit one of these files. @kbd{M-x recentf-save-list} saves the
current @code{recentf-list} to a file, and @kbd{M-x recentf-edit-list}
edits it.
+@vindex remote-file-name-access-timeout
+ If you use remote files, you might also consider customizing
+@code{remote-file-name-access-timeout}, which is the number of
+seconds after which the check whether a remote file shall be used
+in Recentf is stopped. This prevents Emacs being blocked.
+
@c FIXME partial-completion-mode (complete.el) is obsolete.
The @kbd{M-x ffap} command generalizes @code{find-file} with more
powerful heuristic defaults (@pxref{FFAP}), often based on the text at
diff --git a/doc/emacs/fixit.texi b/doc/emacs/fixit.texi
index 6fa707ba2cc..f3c876cf3f7 100644
--- a/doc/emacs/fixit.texi
+++ b/doc/emacs/fixit.texi
@@ -298,8 +298,8 @@ Kill the spell-checker subprocess.
@item M-@key{TAB}
@itemx @key{ESC} @key{TAB}
@itemx C-M-i
-Complete the word before point based on the spelling dictionary
-(@code{ispell-complete-word}).
+Complete the word before point based on the spelling dictionary and
+other completion sources (@code{completion-at-point}).
@item M-x flyspell-mode
Enable Flyspell mode, which highlights all misspelled words.
@item M-x flyspell-prog-mode
@@ -418,14 +418,11 @@ Suspend Emacs or iconify the selected frame.
Show the list of options.
@end table
-@findex ispell-complete-word
- In Text mode and related modes, @kbd{M-@key{TAB}}
-(@code{ispell-complete-word}) performs in-buffer completion based on
-spelling correction. Insert the beginning of a word, and then type
-@kbd{M-@key{TAB}}; this shows a list of completions. (If your
+ Use the command @kbd{M-@key{TAB}} (@code{completion-at-point}) to
+complete the word at point. Insert the beginning of a word, and then
+type @kbd{M-@key{TAB}} to select from a list of completions. (If your
window manager intercepts @kbd{M-@key{TAB}}, type @w{@kbd{@key{ESC}
-@key{TAB}}} or @kbd{C-M-i}.) Each completion is listed with a digit or
-character; type that digit or character to choose it.
+@key{TAB}}} or @kbd{C-M-i}.)
@cindex @code{ispell} program
@findex ispell-kill-ispell
diff --git a/doc/emacs/frames.texi b/doc/emacs/frames.texi
index 9471e99c8e5..8e6cbeed70b 100644
--- a/doc/emacs/frames.texi
+++ b/doc/emacs/frames.texi
@@ -1332,6 +1332,21 @@ Parameters,,, elisp, The Emacs Lisp Reference Manual}. On macOS the
tool bar is hidden when the frame is put into fullscreen, but can be
displayed by moving the mouse pointer to the top of the screen.
+@vindex modifier-bar-mode
+@findex modifier-bar-mode
+@cindex displaying modifier keys in the tool bar
+@cindex mode, Modifier Bar
+@cindex Modifier Bar
+ Keyboards often lack one or more of the modifier keys that Emacs
+might want to use, making it difficult or impossible to input key
+sequences that contain them. Emacs can optionally display a list of
+buttons that act as substitutes for modifier keys within the tool bar;
+these buttons are also referred to as the ``modifier bar''. Clicking
+an icon within the modifier bar will cause a modifier key to be
+applied to the next keyboard event that is read. The modifier bar is
+displayed when the global minor mode @code{modifier-bar-mode} is
+enabled; to do so, type @kbd{M-x modifier-bar-mode}.
+
@node Tab Bars
@section Tab Bars
@cindex tab bar mode
@@ -1392,9 +1407,10 @@ the number of tabs created on each frame.
@findex toggle-frame-tab-bar
To toggle the use of the Tab Bar only on the selected frame, type
-@kbd{M-x toggle-frame-tab-bar}. This command allows to enable the
-display of the Tab Bar on some frames and disable it on others,
-regardless of the values of @code{tab-bar-mode} and @code{tab-bar-show}.
+@kbd{M-x toggle-frame-tab-bar}. This command facilitates selectively
+enabling the Tab Bar on some frames while keeping it disabled on
+others, irrespective of the values of @code{tab-bar-mode} and
+@code{tab-bar-show}.
@kindex C-x t
The prefix key @kbd{C-x t} is analogous to @kbd{C-x 5}.
@@ -1570,6 +1586,14 @@ the items that operate on the clicked tab. Dragging the tab with
wheel scrolling switches to the next or previous tab. Holding down
the @key{SHIFT} key during scrolling moves the tab to the left or right.
+ Touch screen input (@pxref{Other Input}) can also be used to operate
+on tabs. Long-pressing (@pxref{Touchscreens}) a tab will display a
+context menu with items that operate on the tab that was pressed, and
+long-pressing the tab bar itself will display a context menu which
+lets you create and remove tabs; tapping a tab itself will result in
+that tab's window configuration being selected, and tapping a button
+on the tab bar will behave as if it was clicked with @kbd{mouse-1}.
+
@findex tab-bar-history-mode
You can enable @code{tab-bar-history-mode} to remember window
configurations used in every tab, and later restore them.
diff --git a/doc/emacs/haiku.texi b/doc/emacs/haiku.texi
index f9a3e53e78f..8b2a12b8223 100644
--- a/doc/emacs/haiku.texi
+++ b/doc/emacs/haiku.texi
@@ -8,52 +8,55 @@
Haiku is a Unix-like operating system that originated as a
re-implementation of the operating system BeOS.
- This section describes the peculiarities of using Emacs built with
-the Application Kit, the windowing system native to Haiku. The
-oddities described here do not apply to using Emacs on Haiku built
-without windowing support, or built with X11.
+ This appendix describes the peculiarities of using Emacs built with
+the Application Kit, the windowing system indigenous to Haiku. The
+idiosyncrasies illustrated here do not apply to Emacs on Haiku built
+without windowing support, or configured with X11.
@menu
* Haiku Basics:: Basic Emacs usage and installation under Haiku.
-* Haiku Fonts:: The various options for displaying fonts on Haiku.
+* Haiku Fonts:: Various options for displaying fonts on Haiku.
@end menu
@node Haiku Basics
-@section Installation and usage peculiarities under Haiku
+@section Haiku Installation and Startup
@cindex haiku application
@cindex haiku installation
- Emacs installs two separate executables under Haiku; it is up to the
-user to decide which one suits him best: A regular executable, with
-the lowercase name @code{emacs}, and a binary containing
-Haiku-specific application metadata, with the name @code{Emacs}.
-
-@cindex launching Emacs from the tracker
-@cindex tty Emacs in haiku
- If you are launching Emacs from the Tracker, or want to make the
-Tracker open files using Emacs, you should use the binary named
-@code{Emacs}; if you are going to use Emacs in the terminal, or wish
-to launch separate instances of Emacs, or do not care for the
-aforementioned system integration features, use the binary named
-@code{emacs} instead.
+ When Emacs is installed under Haiku, two executables are copied to
+the binaries directory, which are identical save for some identifying
+file-system metadata. The first is a normal Emacs executable,
+@file{emacs}, whereas the second, @file{Emacs}, incorporates an icon
+and an application ``signature'' that abets the system in attributing
+both file types and open frames to it, thereby enabling it to receive
+file type assignments, and thus to open files directly from the
+Tracker.
+
+ Several file attributes are set within @file{Emacs} that prompt the
+system to permit only a single copy to run at any given time. This
+invariant is verified upon the establishment of a display connection,
+and is enforced by terminating any Emacs process that attempts to
+create a display connection when one is already present.
+
+ For this and other reasons, @file{Emacs} is appropriate for starting
+a GUI session of Emacs, while @file{emacs} should be used for other
+types of Emacs sessions.
@cindex modifier keys and system keymap (Haiku)
-@cindex haiku keymap
- On Haiku, unusual modifier keys such as the Hyper key are
-unsupported. By default, the super key corresponds with the option
-key defined by the operating system, the meta key with the command
-key, the control key with the system control key, and the shift key
-with the system shift key. On a standard PC keyboard, Haiku should
-map these keys to positions familiar to those using a GNU system, but
-this may require some adjustment to your system's configuration to
-work.
-
- It is impossible to type accented characters using the system super
-key map.
-
- You can customize the correspondence between modifier keys known to
-the system, and those known to Emacs. The variables that allow for
-that are described below.
+ Emacs is incapable of receiving unusual modifier keys such as
+@kbd{Hyper} under Haiku, or to receive accented characters produced
+from the system Super key map.
+
+ By default, the @key{Super} modifier is reported when the Option key
+defined by the operating system is depressed. Analogously, the
+@key{Meta} modifier is assigned to the Command key, and of course
+@key{Control} to the system Control key and @key{Shift} to the system
+Shift key. On a standard PC keyboard, Haiku should map these keys to
+positions familiar to those using a GNU system, but this may require
+some adjustment to your system's configuration to work.
+
+ You can customize the relation between modifier keys known to the
+system and those known to Emacs by means of the variables below.
@cindex modifier key customization (Haiku)
@table @code
@@ -86,25 +89,22 @@ instead.
@cindex tooltips (haiku)
@cindex haiku tooltips
On Haiku, Emacs defaults to using the system tooltip mechanism.
-This usually leads to more responsive tooltips, but the tooltips will
-not be able to display text properties or faces. If you need those
-features, customize the variable @code{use-system-tooltips} to the
-@code{nil} value, and Emacs will use its own implementation of
-tooltips.
+Tooltips thus generated are sometimes more responsive, but will not be
+able to display text properties or faces. If you need those features,
+customize the variable @code{use-system-tooltips} to @code{nil} value,
+whereupon Emacs will use its own implementation of tooltips instead.
@cindex X resources on Haiku
- Unlike the X window system, Haiku does not have a system-wide
-resource database. Since many important options are specified via
-X resources (@pxref{X Resources}), an emulation is provided: upon
+ Unlike the X window system, Haiku does not provide a system-wide
+resource database. Since many important options are specified via X
+resources (@pxref{X Resources}), an emulation is provided: upon
startup, Emacs will load a file named @file{GNU Emacs} inside the user
configuration directory (normally @file{/boot/home/config/settings}),
which should be a flattened system message where keys and values are
both strings, and correspond to attributes and their values
-respectively.
-
-You can create such a file with the @command{xmlbmessage} tool.
+respectively. Such a file may be created with the
+@command{xmlbmessage} tool.
-@subsection What to do when Emacs crashes
@cindex crashes, Haiku
@cindex haiku debugger
@vindex haiku-debug-on-fatal-error
@@ -115,18 +115,18 @@ attach the report generated by the system debugger when reporting a
bug.
@node Haiku Fonts
-@section Font and font backend selection on Haiku
+@section Font Backends and Selection under Haiku
@cindex font backend selection (Haiku)
- Emacs, when built with Haiku windowing support, can be built with
-several different font backends. You can specify font backends by
-specifying @kbd{-xrm Emacs.fontBackend:BACKEND} on the command line
-used to invoke Emacs, where @kbd{BACKEND} is one of the backends
-specified below, or on a per-frame basis by changing the
-@code{font-backend} frame parameter.
+ Emacs supports several different font backends when built with Haiku
+windowing support, though the subset supported is subject to the list
+of dependencies present and enabled when Emacs was configured. You
+can specify which font backends to utilize by providing @w{@code{-xrm
+Emacs.fontBackend:@var{backend}}} on the command line used to invoke
+Emacs, where @var{backend} is one of the backends listed below, or on
+a per-frame basis by changing the @code{font-backend} frame parameter.
Two of these backends, @code{ftcr} and @code{ftcrhb} are identical
to their counterparts on the X Window System. There is also a
Haiku-specific backend named @code{haiku}, that uses the App Server to
-draw fonts, but does not at present support display of color font and
-emoji.
+draw fonts, but presently cannot display color fonts or Emoji.
diff --git a/doc/emacs/help.texi b/doc/emacs/help.texi
index 1330717b758..d60310456ff 100644
--- a/doc/emacs/help.texi
+++ b/doc/emacs/help.texi
@@ -260,6 +260,11 @@ by these buttons, Emacs provides the @code{button-describe} and
@code{widget-describe} commands, that should be run with point over
the button.
+@anchor{which-key}
+@kbd{M-x which-key} is a global minor mode which helps in discovering
+ keymaps. It displays keybindings following your currently entered
+ incomplete command (prefix), in a popup.
+
@node Name Help
@section Help by Command or Variable Name
@@ -305,6 +310,13 @@ name is defined as a Lisp function. Type @kbd{C-g} to cancel the
@kbd{C-h f} command if you don't really want to view the
documentation.
+ The function's documentation displayed by @code{describe-function}
+includes more than just the documentation string and the signature of
+the function. It also shows auxiliary information such as its type, the
+file where it was defined, whether it has been declared obsolete, and
+yet further information is often reachable by clicking or typing
+@key{RET} on emphasized parts of the text.
+
@vindex help-enable-symbol-autoload
If you request help for an autoloaded function whose @code{autoload}
form (@pxref{Autoload,,, elisp, The Emacs Lisp Reference Manual})
@@ -320,6 +332,16 @@ by using the @kbd{M-x shortdoc} command. This will prompt you for an
area of interest, e.g., @code{string}, and pop you to a buffer where
many of the functions relevant for handling strings are listed.
+You can also request that documentation of functions and commands
+shown in @file{*Help*} buffers popped by @kbd{C-h f} includes examples
+of their use. To that end, add the following to your initialization
+file (@pxref{Init File}):
+
+@example
+(add-hook 'help-fns-describe-function-functions
+ #'shortdoc-help-fns-examples-function)
+@end example
+
@kindex C-h v
@findex describe-variable
@kbd{C-h v} (@code{describe-variable}) is like @kbd{C-h f} but
diff --git a/doc/emacs/input.texi b/doc/emacs/input.texi
new file mode 100644
index 00000000000..67679b00e89
--- /dev/null
+++ b/doc/emacs/input.texi
@@ -0,0 +1,192 @@
+@c This is part of the Emacs manual.
+@c Copyright (C) 2023--2024 Free Software Foundation, Inc.
+@c See file emacs.texi for copying conditions.
+@node Other Input
+@section Touchscreen Input and Virtual Keyboards
+@cindex other input devices
+
+ Emacs was first written assuming that its users were to use it from
+a desktop computer or computer terminal, equipped with a keyboard and
+perhaps a suitable pointing device such as a mouse (@pxref{Mouse
+Input}).
+
+ Emacs is also capable of receiving input from alternative sources of
+input, enabling users to interact with it even if it is installed on a
+computer that substitutes such input sources for the customary
+combination of keyboard and mouse.
+
+@menu
+* Touchscreens:: Interacting with Emacs from touchscreens.
+* On-Screen Keyboards:: Text input with virtual keyboards.
+@end menu
+
+@node Touchscreens
+@subsection Using Emacs on Touchscreens
+@cindex touchscreen input
+
+ Touchscreen input is the manipulation of a frame's contents by the
+placement and motion of tools (instanced by fingers and such pointing
+devices as styluses) on a monitor or computer terminal where it is
+displayed.
+
+ Two factors, the order and position on which such tools are placed,
+are compared against predefined patterns dubbed @dfn{gestures}, after
+which any gesture those factors align with designates a series of
+actions to be taken on the text beneath the tools; the gestures
+presently recognized are:
+
+@itemize @bullet
+@item
+@cindex tapping, touchscreens
+ @dfn{Tapping}, briefly placing and lifting a tool from the display,
+will select the window that was tapped, and execute any command bound
+to @code{mouse-1} at that location in the window. If a link
+(@pxref{Mouse References}) exists there, then Emacs will follow that
+link instead (insofar as such action differs from that taken upon the
+simulation of a @code{mouse-1} event).
+
+@item
+@cindex scrolling, touchscreens
+@vindex touch-screen-enable-hscroll
+ @dfn{Scrolling}, which is continuous vertical or horizontal motion
+on the screen, will scroll the contents of the window beneath the
+tool's initial location in the direction of movement. The user option
+@code{touch-screen-enable-hscroll} governs whether horizontal
+scrolling (@pxref{Horizontal Scrolling}) is performed in reaction to
+this gesture.
+
+@item
+@cindex dragging, touchscreens
+@cindex long-press, touchscreens
+ @dfn{Dragging}, which is performing a @dfn{long-press} by placing a
+tool on the display and leaving it there awhile before moving it to
+another position, will move point to the tool's initial position, and
+commence selecting text under the tool as it continues its motion, as
+if @code{mouse-1} were to be held down and a mouse moved analogously.
+@xref{Mouse Commands}.
+
+@vindex touch-screen-word-select
+@cindex word selection mode, touchscreens
+ To the detriment of text selection, it can prove challenging to
+position a tool accurately on a touch screen display. The user option
+@code{touch-screen-word-select}, which when enabled, prompts dragging
+to select the complete word under the tool. (Normally, the selection
+is only extended to encompass the character beneath the tool.)
+
+@vindex touch-screen-extend-selection
+@cindex extending the selection, touchscreens
+ In the same vein, it may be difficult to select all of the text
+intended within a single gesture. If the user option
+@code{touch-screen-extend-selection} is enabled, taps on the locations
+of the point or the mark within a window will begin a new ``drag''
+gesture, where the region will be extended in the direction of any
+subsequent movement.
+
+@vindex touch-screen-preview-select
+@cindex previewing the region during selection, touchscreens
+ Difficulties in making accurate adjustments to the region from the
+cursor being physically obscured by the tool can be mitigated by
+indicating the position of the point within the echo area. If
+@code{touch-screen-preview-select} is non-@code{nil}, the line
+surrounding point is displayed in the echo area (@pxref{Echo Area})
+during the motion of the tool, below which is another line indicating
+the position of point relative to the first.
+
+@item
+@cindex pinching, touchscreens
+ @dfn{Pinching}, the placement of two tools apart on the screen
+followed by adjustments to their position such as to increase or
+decrease the distance between them will modify the text scale
+(@pxref{Text Scale}) in proportion to the change in that distance.
+@end itemize
+
+@vindex touch-screen-delay
+ Emacs registers a long-press after the time a tool has been placed
+upon the screen exceeds 0.7 seconds. This delay can be adjusted
+through customizing the variable @code{touch-screen-delay}.
+
+@node On-Screen Keyboards
+@subsection Using Emacs with Virtual Keyboards
+@cindex virtual keyboards
+@cindex on-screen keyboards
+
+ When there is no physical keyboard attached to a system, its
+windowing system might provide an on-screen keyboard, widely known as
+a ``virtual keyboard'', containing rows of clickable buttons that send
+keyboard input to the application, much as a real keyboard would.
+
+ This virtual keyboard is hidden when the focused program is not
+requesting text input as it occupies scarce space on display, and
+programs are therefore enjoined to display it once they are ready to
+accept keyboard input. Systems running X detect when the presence of
+the virtual keyboard is warranted, but on others such as Android Emacs
+is responsible for displaying it when need be, generally in reaction
+to a touch screen ``tap'' gesture (@pxref{Touchscreens}) or the
+minibuffer being brought into use (@pxref{Minibuffer}).
+
+@vindex touch-screen-set-point-commands
+ When a ``tap'' gesture results in a command being executed, Emacs
+checks whether the command is meant to set the point by searching for
+it in the list @code{touch-screen-set-point-commands}. If it is and
+the text beneath the new point is not read-only, it activates the
+virtual keyboard, in anticipation that the user is about to enter text
+there.
+
+ The default value of @code{touch-screen-set-point-commands} holds
+only the command @code{mouse-set-point} (@pxref{Mouse Commands}),
+which is the default binding of @code{mouse-1}, and thus of
+touchscreen tap gestures as well.
+
+@vindex touch-screen-display-keyboard
+ The user option @code{touch-screen-display-keyboard} compels Emacs
+to display the virtual keyboard on such taps even if the text is read
+only; it may also be set buffer locally, in which case Emacs will
+always display the keyboard in response to a tap on a window
+displaying the buffer it is set in.
+
+ There are moreover several functions to show or hide the on-screen
+keyboard. For more details, @xref{On-Screen Keyboards,,, elisp, The
+Emacs Lisp Reference Manual}.
+
+@cindex quitting, without a keyboard
+ Since it may not be possible for Emacs to display the virtual
+keyboard while it is executing a command, Emacs implements a feature
+on window systems frequently equipped with no physical keyboard, by
+which two rapid clicks of a hardware button that is always present on
+the device induces a quit. @xref{Quitting}.
+
+@vindex x-quit-keysym
+ No such button is enabled on X, but one can be configured through
+the variable @code{x-quit-keysym}. On Android this button is always
+the volume down button.
+
+@cindex text conversion, keyboards
+ Most input methods designed to work with virtual keyboards edit text
+differently from desktop input methods.
+
+ On a conventional desktop windowing system, an input method will
+simply display the contents of any ongoing character composition on
+screen, and send key events reflecting its contents to Emacs after it
+is confirmed by the user.
+
+ By contrast, virtual keyboard input methods directly perform edits
+to the selected window of each frame; this is known as ``text
+conversion'', or ``string conversion'' under the X Window System.
+
+ Emacs enables these input methods whenever the buffer local value of
+@code{text-conversion-style} is non-@code{nil}, that is to say,
+generally inside derivatives of @code{text-mode} and @code{prog-mode}.
+
+ Text conversion is performed asynchronously whenever Emacs receives
+a request to perform the conversion from the input method, and Emacs
+is not currently reading a key sequence for which one prefix key has
+already been read (@pxref{Keys}). After the conversion completes, a
+@code{text-conversion} event is sent. @xref{Misc Events,,, elisp, the
+Emacs Reference Manual}.
+
+@vindex text-conversion-face
+ If the input method needs to work on a region of the buffer, then
+the region is designated the ``composing region'' (or ``preconversion
+region''). The variable @code{text-conversion-face} controls whether
+to display the composing region in a distinctive face, and if so,
+which face to employ.
diff --git a/doc/emacs/killing.texi b/doc/emacs/killing.texi
index c6633eb1892..57adc037cb7 100644
--- a/doc/emacs/killing.texi
+++ b/doc/emacs/killing.texi
@@ -318,7 +318,7 @@ way to move or copy text is to kill it and then yank it elsewhere.
Yank the last kill into the buffer, at point (@code{yank}).
@item M-y
Either replace the text just yanked with an earlier batch of killed
-text (@code{yank-pop}), or allow to select from the list of
+text (@code{yank-pop}), or allow selecting from the list of
previously-killed batches of text. @xref{Earlier Kills}.
@item C-M-w
Cause the following command, if it is a kill command, to append to the
diff --git a/doc/emacs/kmacro.texi b/doc/emacs/kmacro.texi
index 316569302de..e30def34475 100644
--- a/doc/emacs/kmacro.texi
+++ b/doc/emacs/kmacro.texi
@@ -515,6 +515,19 @@ editing it. Type @kbd{C-h m} once in that buffer to display details
of how to edit the macro. When you are finished editing, type
@kbd{C-c C-c}.
+@findex edmacro-insert-key
+@findex edmacro-set-macro-to-region-lines
+ @code{edmacro-mode}, the major mode used by
+@code{kmacro-edit-macro}, provides commands for more easily editing
+the formatted macro. Use @kbd{C-c C-q} (@code{edmacro-insert-key}) to
+insert the next key sequence that you type into the buffer using the
+correct format, similar to @kbd{C-q} (@code{quoted-insert}). Use
+@kbd{C-c C-r} (@code{edmacro-set-macro-to-region-lines}) to replace
+the macro's text with the text in the region. If the region does not
+begin at the start of a line or if it does not end at the end of a
+line, the region is extended to include complete lines. If the region
+ends at the beginning of a line, that final line is excluded.
+
@findex edit-kbd-macro
@kindex C-x C-k e
You can edit a named keyboard macro or a macro bound to a key by typing
@@ -523,9 +536,13 @@ keyboard input that you would use to invoke the macro---@kbd{C-x e} or
@kbd{M-x @var{name}} or some other key sequence.
@findex kmacro-edit-lossage
+@vindex edmacro-reverse-macro-lines
@kindex C-x C-k l
You can edit the last 300 keystrokes as a macro by typing
-@kbd{C-x C-k l} (@code{kmacro-edit-lossage}).
+@kbd{C-x C-k l} (@code{kmacro-edit-lossage}). By default,
+your most recent keystrokes are listed at the bottom of the buffer.
+To list a macro's key sequences in reverse order, set
+@code{edmacro-reverse-macro-lines} to @code{t}.
@node Keyboard Macro Step-Edit
@section Stepwise Editing a Keyboard Macro
diff --git a/doc/emacs/maintaining.texi b/doc/emacs/maintaining.texi
index 14bdbc57f14..d3e06fa697b 100644
--- a/doc/emacs/maintaining.texi
+++ b/doc/emacs/maintaining.texi
@@ -447,9 +447,10 @@ merge-based version control system, a @samp{-} character indicates
that the work file is unmodified, and @samp{:} indicates that it has
been modified. @samp{!} indicates that the file contains conflicts as
result of a recent merge operation (@pxref{Merging}), or that the file
-was removed from the version control. Finally, @samp{?} means that
-the file is under version control, but is missing from the working
-tree.
+was removed from the version control, or that it is versioned but also
+@dfn{ignored}, something that usually should not happen (@pxref{VC
+Ignore}). Finally, @samp{?} means that the file is under version
+control, but is missing from the working tree.
In a lock-based system, @samp{-} indicates an unlocked file, and
@samp{:} a locked file; if the file is locked by another user (for
@@ -1792,6 +1793,14 @@ project. Also, the VC-aware Project back-end considers ``untracked''
files by default. That behavior is controllable with the variable
@code{project-vc-include-untracked}.
+@cindex current project name on mode line
+@defopt project-mode-line
+If this user option is non-@code{nil}, Emacs displays the name of the
+current project (if any) on the mode line; clicking @kbd{mouse-1} on
+the project name pops up the menu with the project-related commands.
+The default value is @code{nil}.
+@end defopt
+
@menu
* Project File Commands:: Commands for handling project files.
* Project Buffer Commands:: Commands for handling project buffers.
@@ -1853,7 +1862,7 @@ prompt you for the project directory.
@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
+project. Unlike @kbd{C-x C-f}, this command doesn't require typing
the full file name of the file to visit, you can type only the file's
base name (i.e., omit the leading directories). In addition, the
completion candidates considered by the command include only the files
@@ -2674,7 +2683,7 @@ use tags, separate from the @command{etags} facility.
@menu
* Tag Syntax:: Tag syntax for various types of code and text files.
-* Create Tags Table:: Creating a tags table with @command{etags}.
+* Create Tags Table:: Creating and updating tags tables with @command{etags}.
* Etags Regexps:: Create arbitrary tags using regular expressions.
@end menu
@@ -2707,8 +2716,8 @@ definitions have tag names like @samp{operator+}. If you specify the
@samp{--class-qualify} option, tags for variables and functions in
classes are named @samp{@var{class}::@var{variable}} and
@samp{@var{class}::@var{function}}. By default, class methods and
-members are not class-qualified, which allows to identify their names in
-the sources more accurately.
+members are not class-qualified, which facilitates identifying their
+names in the sources more accurately.
@item
In Java code, tags include all the constructs recognized in C++, plus
@@ -2990,6 +2999,38 @@ explanation. If followed by one or more @samp{--language=@var{lang}}
options, it outputs detailed information about how tags are generated for
@var{lang}.
+@findex etags-regen-mode
+ Instead of creating and updating the tags table by manually invoking
+@command{etags}, you can ask Emacs to do it for you automatically.
+The global minor mode @code{etags-regen-mode}, if enabled, generates
+tags tables automatically as needed, and takes care of updating them
+when you edit any of the source files that contribute tags. This mode
+uses the current project configuration (@pxref{Projects}) to determine
+which files to submit to @command{etags} for regenerating the tags
+table for the project. You can customize how this minor mode works
+using the following user options:
+
+@vtable @code
+@item etags-regen-program
+The program to regenerate tags table; defaults to @command{etags}.
+
+@item etags-regen-program-options
+Command-line options to pass to the program which regenerates tags
+tables.
+
+@item etags-regen-ignores
+List of glob patterns which specify files to ignore when regenerating
+tags tables.
+@end vtable
+
+@cindex tags-reset-tags-tables
+ If you select a tags table manually, with @kbd{M-x visit-tags-table}
+(@pxref{Select Tags Table}), @code{etags-regen-mode} effectively
+disables itself: it will no longer automatically create and update
+tags tables, assuming that you prefer managing your tags tables
+manually. You can cancel this effect of using @code{visit-tags-table}
+by invoking the command @code{tags-reset-tags-tables}.
+
@node Etags Regexps
@subsubsection Etags Regexps
diff --git a/doc/emacs/mini.texi b/doc/emacs/mini.texi
index 9e4d1ec3581..aa7144610a6 100644
--- a/doc/emacs/mini.texi
+++ b/doc/emacs/mini.texi
@@ -391,7 +391,7 @@ used with the completion list:
@findex minibuffer-choose-completion
@item M-@key{DOWN}
@itemx M-@key{UP}
-While in the minibuffer, @kbd{M-@key{DOWN}}
+While in the minibuffer or in the completion list buffer, @kbd{M-@key{DOWN}}
(@code{minibuffer-next-completion} and @kbd{M-@key{UP}}
(@code{minibuffer-previous-completion}) navigate through the
completions and displayed in the completions buffer. When
@@ -709,7 +709,9 @@ will use just one column.
The @code{completions-sort} user option controls the order in which
the completions are sorted in the @samp{*Completions*} buffer. The
default is @code{alphabetical}, which sorts in alphabetical order.
-The value @code{nil} disables sorting. The value can also be a
+The value @code{nil} disables sorting; the value @code{historical}
+sorts alphabetically first, and then rearranges according to the order
+of the candidates in the minibuffer history. The value can also be a
function, which will be called with the list of completions, and
should return the list in the desired order.
@@ -970,12 +972,14 @@ File ‘foo.el’ exists; overwrite? (y or n)
@end smallexample
@cindex yes or no prompt
+@vindex yes-or-no-prompt
The second type of yes-or-no query is typically employed if giving
the wrong answer would have serious consequences; it thus features a
-longer prompt ending with @samp{(yes or no)}. For example, if you
-invoke @kbd{C-x k} (@code{kill-buffer}) on a file-visiting buffer with
-unsaved changes, Emacs activates the minibuffer with a prompt like
-this:
+longer prompt ending with @samp{(yes or no)} (or the value of
+@code{yes-or-no-prompt} if you've customized that). For example, if
+you invoke @kbd{C-x k} (@code{kill-buffer}) on a file-visiting buffer
+with unsaved changes, Emacs activates the minibuffer with a prompt
+like this:
@smallexample
Buffer foo.el modified; kill anyway? (yes or no)
diff --git a/doc/emacs/misc.texi b/doc/emacs/misc.texi
index 48bc69456ad..8f9ee317080 100644
--- a/doc/emacs/misc.texi
+++ b/doc/emacs/misc.texi
@@ -399,18 +399,18 @@ vulnerable to a variety of attacks, and you may want to avoid using
these if what you're doing requires higher security. (This is the
@code{ssl} check in @code{network-security-protocol-checks}).
+@item Triple DES (or @acronym{3DES}) cipher
+The @acronym{3DES} stream cipher provides at most 112 bits of
+effective security, and a major security vulnerability in it was
+disclosed in 2016 (CVE-2016-2183). It has been deprecated by NIST in
+all applications from late 2023 onwards. (This is the
+@code{3des-cipher} check in @code{network-security-protocol-checks}).
@end table
If @code{network-security-level} is @code{high}, the following checks
will be made, in addition to the above:
@table @asis
-@item @acronym{3DES} cipher
-The @acronym{3DES} stream cipher provides at most 112 bits of
-effective security, which is considered to be towards the low end.
-(This is the @code{3des} check in
-@code{network-security-protocol-checks}).
-
@item a validated certificate changes the public key
Servers change their keys occasionally, and that is normally nothing
to be concerned about. However, if you are worried that your network
@@ -1810,31 +1810,28 @@ you can give each daemon its own server name like this:
emacs --daemon=foo
@end example
-@findex server-stop-automatically
+@vindex server-stop-automatically
The Emacs server can optionally be stopped automatically when
-certain conditions are met. To do this, call the function
-@code{server-stop-automatically} in your init file (@pxref{Init
-File}), with one of the following arguments:
-
-@itemize
-@item
-With the argument @code{empty}, the server is stopped when it has no
-clients, no unsaved file-visiting buffers and no running processes
-anymore.
-
-@item
-With the argument @code{delete-frame}, when the last client frame is
-being closed, you are asked whether each unsaved file-visiting buffer
-must be saved and each unfinished process can be stopped, and if so,
-the server is stopped.
+certain conditions are met. To do this, set the option
+@code{server-stop-automatically} to one of the following values:
-@item
-With the argument @code{kill-terminal}, when the last client frame is
-being closed with @kbd{C-x C-c} (@code{save-buffers-kill-terminal}),
-you are asked whether each unsaved file-visiting buffer must be saved
-and each unfinished process can be stopped, and if so, the server is
+@table @code
+@item empty
+This value causes the server to be stopped when it has no clients, no
+unsaved file-visiting buffers and no running processes anymore.
+
+@item delete-frame
+This value means that when the last client frame is being closed, you
+are asked whether each unsaved file-visiting buffer must be saved and
+each unfinished process can be stopped, and if so, the server is
stopped.
-@end itemize
+
+@item kill-terminal
+This value means that when the last client frame is being closed with
+@kbd{C-x C-c} (@code{save-buffers-kill-terminal}), you are asked
+whether each unsaved file-visiting buffer must be saved and each
+unfinished process can be stopped, and if so, the server is stopped.
+@end table
@findex server-eval-at
If you have defined a server by a unique server name, it is possible
@@ -2081,6 +2078,18 @@ files. When this option is given, the arguments to
@command{emacsclient} are interpreted as a list of expressions to
evaluate, @emph{not} as a list of files to visit.
+@vindex server-eval-args-left
+Passing complex Lisp expression via the @option{--eval} command-line
+option sometimes requires elaborate escaping of characters special to
+the shell. To avoid this, you can pass arguments to Lisp functions in
+your expression as additional separate arguments to
+@command{emacsclient}, and use @var{server-eval-args-left} in the
+expression to access those arguments. Be careful to have your
+expression remove the processed arguments from
+@var{server-eval-args-left} regardless of whether your code succeeds,
+for example by using @code{pop}, otherwise Emacs will attempt to
+evaluate those arguments as separate Lisp expressions.
+
@item -f @var{server-file}
@itemx --server-file=@var{server-file}
Specify a server file (@pxref{TCP Emacs server}) for connecting to an
@@ -2815,9 +2824,13 @@ frame parameters you don't want to be restored; they will then be set
according to your customizations in the init file.
@vindex desktop-files-not-to-save
+@vindex remote-file-name-access-timeout
Information about buffers visiting remote files is not saved by
default. Customize the variable @code{desktop-files-not-to-save} to
-change this.
+change this. In this case, you might also consider customizing
+@code{remote-file-name-access-timeout}, which is the number of
+seconds after which buffer restoration of a remote file is
+stopped. This prevents Emacs being blocked.
@vindex desktop-restore-eager
By default, all the buffers in the desktop are restored in one go.
@@ -2996,6 +3009,15 @@ buffer, and lets you navigate to those pages by hitting @kbd{RET}.
It is bound to @kbd{H}.
+@vindex xwidget-webkit-disable-javascript
+@cindex disabling javascript in webkit buffers
+ JavaScript is enabled by default inside WebKit buffers, which could be
+undesirable, as Web sites often use it to track your online activity.
+You can disable JavaScript in WebKit buffers by customizing the variable
+@code{xwidget-webkit-disable-javascript} to a non-@code{nil} value.
+You must kill all WebKit buffers for this setting to take effect, after
+it is changed.
+
@node Browse-URL
@subsection Following URLs
@cindex World Wide Web
diff --git a/doc/emacs/msdos.texi b/doc/emacs/msdos.texi
index 9d778600944..861c0d90dc6 100644
--- a/doc/emacs/msdos.texi
+++ b/doc/emacs/msdos.texi
@@ -412,10 +412,10 @@ this option can be one of the following symbols:
@itemx nil
Emulate @sc{gnu} systems; this is the default. This sets
@code{ls-lisp-ignore-case} and @code{ls-lisp-dirs-first} to
-@code{nil}, and @code{ls-lisp-verbosity} to @code{(links uid gid)}.
+@code{nil}, and @code{ls-lisp-verbosity} to @code{(links uid gid modes)}.
@item UNIX
Emulate Unix systems. Like @code{GNU}, but sets
-@code{ls-lisp-verbosity} to @code{(links uid)}.
+@code{ls-lisp-verbosity} to @code{(links uid modes)}.
@item MacOS
Emulate macOS@. Sets @code{ls-lisp-ignore-case} to @code{t}, and
@code{ls-lisp-dirs-first} and @code{ls-lisp-verbosity} to @code{nil}.
@@ -1182,12 +1182,23 @@ click-to-focus policy.
@end ifnottex
On Windows 10 (version 1809 and higher) and Windows 11, Emacs title
-bars and scroll bars will follow the system's Light or Dark mode,
-similar to other programs such as Explorer and Command Prompt. To
-change the color mode, select @code{Personalization} from
-@w{@code{Windows Settings}}, then
-@w{@code{Colors->Choose your color}} (or @w{@code{Choose your default
-app mode}}); then restart Emacs.
+bars and scroll bars by default follow the system's Light or Dark
+mode, similar to other programs such as Explorer and Command Prompt.
+To change the color mode, select @code{Personalization} from
+@w{@code{Windows Settings}}, then @w{@code{Colors->Choose your color}}
+(or @w{@code{Choose your default app mode}} or @w{@code{Choose your
+mode}}); then restart Emacs. On Windows 11, you can select separate
+default modes for Windows and for applications.
+
+@vindex w32-follow-system-dark-mode
+ If you don't want Emacs to follow the system's Dark mode setting,
+customize the variable @code{w32-follow-system-dark-mode} to a
+@code{nil} value; then Emacs will use the default Light mode
+regardless of system-wide settings. Changing the value of this
+variable affects only the Emacs frames created after the change, so
+you should set its value in your init file (@pxref{Init File}), either
+directly or via @kbd{M-x customize-variable}, which lets you save the
+customized value, see @ref{Saving Customizations}.
@ifnottex
@include msdos-xtra.texi
diff --git a/doc/emacs/package.texi b/doc/emacs/package.texi
index 4247893fbbd..c8f790bab47 100644
--- a/doc/emacs/package.texi
+++ b/doc/emacs/package.texi
@@ -687,6 +687,17 @@ A string providing the repository-relative name of the documentation
file from which to build an Info file. This can be a Texinfo file or
an Org file.
+@item :make
+A string or list of strings providing the target or targets defined in
+the repository Makefile which should run before building the Info
+file. Only takes effect when @code{package-vc-allow-build-commands}
+is non-nil.
+
+@item :shell-command
+A string providing the shell command to run before building the Info
+file. Only takes effect when @code{package-vc-allow-build-commands}
+is non-@code{nil}.
+
@item :vc-backend
A symbol naming the VC backend to use for downloading a copy of the
package's repository (@pxref{Version Control Systems,,,emacs, The GNU
diff --git a/doc/emacs/programs.texi b/doc/emacs/programs.texi
index 02bc0d06e56..1627e7e6cb7 100644
--- a/doc/emacs/programs.texi
+++ b/doc/emacs/programs.texi
@@ -163,6 +163,7 @@ Emacs we use it for all languages.
* Left Margin Paren:: An open-paren or similar opening delimiter
starts a defun if it is at the left margin.
* Moving by Defuns:: Commands to move over or mark a major definition.
+* Moving by Sentences:: Commands to move over certain code units.
* Imenu:: Making buffer indexes as menus.
* Which Function:: Which Function mode shows which function you are in.
@end menu
@@ -265,6 +266,66 @@ tree-sitter library provide control of this behavior: if the variable
@code{treesit-defun-tactic} is set to the value @code{top-level}, the
defun commands will find the @emph{outermost} defuns instead.
+@node Moving by Sentences
+@subsection Moving by Sentences
+@cindex sentences, in programming languages
+
+ These commands move point or set up the region based on units of
+code, also called @dfn{sentences}. Even though sentences are usually
+considered when writing human languages, Emacs can use the same
+commands to move over certain constructs in programming languages
+(@pxref{Sentences}, @pxref{Moving by Defuns}). In a programming
+language a sentence is usually a complete language construct smaller
+than defuns, but larger than sexps (@pxref{List Motion,,, elisp, The
+Emacs Lisp Reference Manual}). What exactly is a sentence in this
+case depends on the programming language, but usually it is a complete
+statement, such as a variable definition and initialization, or a
+conditional statement. An example of a sentence in the C language
+could be
+
+@example
+int x = 5;
+@end example
+
+@noindent
+or in the JavaScript language it could look like
+
+@example
+@group
+const thing = () => console.log("Hi");
+@end group
+@group
+const foo = [1] == '1'
+ ? "No way"
+ : "...";
+@end group
+
+@end example
+
+@table @kbd
+@item M-a
+Move to beginning of current or preceding sentence
+(@code{backward-sentence}).
+@item M-e
+Move to end of current or following sentence (@code{forward-sentence}).
+@end table
+
+@cindex move to beginning or end of sentence
+@cindex sentence, move to beginning or end
+@kindex M-a @r{(programming modes)}
+@kindex M-e @r{(programming modes)}
+@findex backward-sentence @r{(programming modes)}
+@findex forward-sentence @r{(programming modes)}
+ The commands to move to the beginning and end of the current
+sentence are @kbd{M-a} (@code{backward-sentence}) and @kbd{M-e}
+(@code{forward-sentence}). If you repeat one of these commands, or
+use a positive numeric argument, each repetition moves to the next
+sentence in the direction of motion.
+
+ @kbd{M-a} with a negative argument @minus{}@var{n} moves forward
+@var{n} times to the next end of a sentence. Likewise, @kbd{M-e} with
+a negative argument moves back to the start of a sentence.
+
@node Imenu
@subsection Imenu
@cindex index of buffer definitions
@@ -335,8 +396,8 @@ The Speedbar can also use it (@pxref{Speedbar}).
@cindex current function name in mode line
Which Function mode is a global minor mode (@pxref{Minor Modes})
-which displays the current function name in the mode line, updating it
-as you move around in a buffer.
+which displays the current function name in the mode line or header
+line, updating it as you move around in a buffer.
@findex which-function-mode
@vindex which-func-modes
@@ -349,6 +410,12 @@ changing the value of the variable @code{which-func-modes} from
@code{t} (which means to support all available major modes) to a list
of major mode names.
+@vindex which-func-display
+ By default, Which Function mode displays the current function name
+using the mode line. Customize @code{which-func-display} to
+@code{header}, @code{mode}, or @code{mode-and-header} to use the
+header line, mode line, or both, respectively.
+
@node Program Indent
@section Indentation for Programs
@cindex indentation for programs
@@ -431,6 +498,9 @@ large chunks of code:
@table @kbd
@item C-M-q
Reindent all the lines within one parenthetical grouping.
+@item M-q
+Fill a single paragraph in a defun, or reindent all the lines within
+that defun.
@item C-u @key{TAB}
Shift an entire parenthetical grouping rigidly sideways so that its
first line is properly indented.
@@ -451,6 +521,21 @@ indentation of the line where the grouping starts). The function that
etc. To correct the overall indentation as well, type @kbd{@key{TAB}}
first.
+@kindex M-q
+@findex prog-fill-reindent-defun
+@vindex beginning-of-defun-function
+@vindex end-of-defun-function
+@vindex fill-paragraph-function
+ To reindent the entire defun around point, type @kbd{M-q}
+(@code{prog-fill-reindent-defun}). If point is in a comment or a
+string, this command fills and indents the comment or string instead.
+What exactly constitutes a comment, a string, or a defun depends on
+the major mode: the bounds of a defun are decided by the variables
+@code{beginning-of-defun-function} and @code{end-of-defun-function}
+(@pxref{List Motion,,, elisp, The Emacs Lisp Reference Manual}),
+and the filling mechanism is decided by @code{fill-paragraph-function}
+(@pxref{Filling,,, elisp, The Emacs Lisp Reference Manual}).
+
@kindex C-u TAB
If you like the relative indentation within a grouping but not the
indentation of its first line, move point to that first line and type
@@ -1311,6 +1396,19 @@ this, change the value of the variable @code{Man-switches} to
@kbd{M-p} to switch between man pages in different sections. The mode
line shows how many manual pages are available.
+@vindex Man-prefer-synchronous-call
+ By default, @kbd{M-x man} calls the @code{man} program
+asynchronously. You can force the invocation to be synchronous by
+customizing @code{Man-prefer-synchronous-calls} to a non-@code{nil}
+value.
+
+@vindex Man-support-remote-systems
+ If the user option @code{Man-support-remote-systems} is
+non-@code{nil}, and @code{default-directory} indicates a remote system
+(@pxref{Remote Files}), the man page is taken from the remote system.
+Calling the @code{man} command with a prefix like @kbd{C-u M-x man}
+reverts the value of @code{Man-support-remote-systems} for that call.
+
@findex woman
@cindex manual pages, on MS-DOS/MS-Windows
An alternative way of reading manual pages is the @kbd{M-x woman}
@@ -1603,6 +1701,17 @@ completion to the buffer. @xref{Completion}.
In Text mode and related modes, @kbd{M-@key{TAB}} completes words
based on the spell-checker's dictionary. @xref{Spelling}.
+@cindex completion preview
+@cindex preview completion
+@cindex suggestion preview
+@cindex Completion Preview mode
+@findex completion-preview-mode
+ Completion Preview mode is a minor mode that shows completion
+suggestions as you type. When you enable this mode (with @kbd{M-x
+completion-preview-mode}), Emacs automatically displays the
+suggested completion for text around point as an in-line preview
+right after point; type @key{TAB} to accept the suggestion.
+
@node MixedCase Words
@section MixedCase Words
@cindex camel case
diff --git a/doc/emacs/regs.texi b/doc/emacs/regs.texi
index 4302a4caa49..cac5b32c566 100644
--- a/doc/emacs/regs.texi
+++ b/doc/emacs/regs.texi
@@ -16,9 +16,8 @@ jump back to that position once or many times.
we will denote by @var{r}; @var{r} can be a letter (such as @samp{a})
or a number (such as @samp{1}); case matters, so register @samp{a} is
not the same as register @samp{A}. You can also set a register in
-non-alphanumeric characters, for instance @samp{*} or @samp{C-d}.
-Note, it's not possible to set a register in @samp{C-g} or @samp{ESC},
-because these keys are reserved for quitting (@pxref{Quitting}).
+non-alphanumeric characters, for instance @samp{C-d} by using for
+example @key{C-q} @samp{C-d}.
@findex view-register
A register can store a position, a piece of text, a rectangle, a
@@ -33,14 +32,58 @@ view-register}:
Display a description of what register @var{r} contains.
@end table
-@vindex register-preview-delay
+
@cindex preview of registers
- All of the commands that prompt for a register will display a
-preview window that lists the existing registers (if there are
-any) after a short delay. To change the length of the delay,
-customize @code{register-preview-delay}. To prevent this display, set
-that option to @code{nil}. You can explicitly request a preview
-window by pressing @kbd{C-h} or @key{F1}.
+@vindex register-use-preview
+ All of the commands that prompt for a register will by default
+display a preview window that lists the existing registers (if there
+are any) and their current values, after a short delay. This and
+other aspects of prompting for a register can be customized by setting
+the value of @code{register-use-preview}, which can have the following
+values:
+
+@table @code
+@vindex register-preview-delay
+@item traditional
+With this value, which is the default, Emacs behaves like it did in
+all the versions before Emacs 29: it shows a preview of existing registers
+after a delay, and lets you overwrite the values of existing registers
+by typing a single character, the name of the register. The preview
+appears after the delay determined by the customizable variable
+@code{register-preview-delay}, which specifies the delay in seconds;
+setting it to @code{nil} disables the preview (but you can still
+explicitly request a preview window by pressing @kbd{C-h} or
+@key{F1} when Emacs prompts for a register).
+
+@item t
+This value requests a more flexible preview of existing registers.
+The preview appears immediately when Emacs prompts for a register
+(thus @code{register-preview-delay} has no effect), and the preview
+window provides navigation: by using @kbd{C-n} and @kbd{C-p} (or the
+@kbd{@key{UP}} and @kbd{@key{DOWN}} arrow keys), you can move between
+the registers in the preview window. To overwrite the value of an
+existing registers in this mode, you need to type @key{RET} after
+selecting the register by navigation or typing its name.
+
+In addition, the registers shown by the preview are filtered according
+to the command that popped the preview: for example, the preview shown
+by @code{insert-register} will only show registers whose values can be
+inserted into the buffer, omitting registers which hold window
+configurations, positions, and other un-insertable values.
+
+@item insist
+This value is like @code{t}, but in addition you can press the same
+key as the name of register one more time to exit the minibuffer,
+instead of pressing @key{RET}.
+
+@item nil
+This value requests behavior similar to @code{traditional}, but the
+preview is shown without delay, and is filtered according to the
+command.
+
+@item never
+This value is like @code{nil}, but it disables the preview.
+@end table
@dfn{Bookmarks} record files and positions in them, so you can
return to those positions when you look at the file again. Bookmarks
diff --git a/doc/emacs/screen.texi b/doc/emacs/screen.texi
index 20142d8ccc6..6b09dcb8e0a 100644
--- a/doc/emacs/screen.texi
+++ b/doc/emacs/screen.texi
@@ -173,7 +173,7 @@ unselected windows, in order to make it stand out.
The text displayed in the mode line has the following format:
@example
- @var{cs}:@var{ch}-@var{fr} @var{buf} @var{pos} @var{line} (@var{major} @var{minor})
+ @var{cs}:@var{ch}-@var{d}@var{fr} @var{buf} @var{pos} @var{line} (@var{major} @var{minor})
@end example
@noindent
@@ -231,6 +231,12 @@ shows @samp{%*} if the buffer is modified, and @samp{%%} otherwise.
However, if @code{default-directory} (@pxref{File Names}) for the
current buffer is on a remote machine, @samp{@@} is displayed instead.
+ @var{d} appears if the window is dedicated to its current buffer.
+It appears as @samp{D} for strong dedication and @samp{d} for other
+forms of dedication. If the window is not dedicated, @var{d} does not
+appear. @xref{Dedicated Windows,, elisp, The Emacs Lisp Reference
+Manual}.
+
@var{fr} gives the selected frame name (@pxref{Frames}). It appears
only on text terminals. The initial frame's name is @samp{F1}.
diff --git a/doc/emacs/search.texi b/doc/emacs/search.texi
index e997e1b2fe4..9ba425f2d21 100644
--- a/doc/emacs/search.texi
+++ b/doc/emacs/search.texi
@@ -953,8 +953,8 @@ features used mainly in Lisp programs.
@dfn{special constructs} and the rest are @dfn{ordinary}. An ordinary
character matches that same character and nothing else. The special
characters are @samp{$^.*+?[\}. The character @samp{]} is special if
-it ends a character alternative (see below). The character @samp{-}
-is special inside a character alternative. Any other character
+it ends a bracket expression (see below). The character @samp{-}
+is special inside a bracket expression. Any other character
appearing in a regular expression is ordinary, unless a @samp{\}
precedes it. (When you use regular expressions in a Lisp program,
each @samp{\} must be doubled, see the example near the end of this
@@ -1036,11 +1036,12 @@ you search for @samp{a.*?$} against the text @samp{abbab} followed by
a newline, it matches the whole string. Since it @emph{can} match
starting at the first @samp{a}, it does.
+@cindex bracket expression
@cindex set of alternative characters, in regular expressions
@cindex character set, in regular expressions
@item @kbd{[ @dots{} ]}
-is a @dfn{set of alternative characters}, or a @dfn{character set},
-beginning with @samp{[} and terminated by @samp{]}.
+is a @dfn{bracket expression} (a.k.a.@: @dfn{set of alternative
+characters}), which matches one of a set of characters.
In the simplest case, the characters between the two brackets are what
this set can match. Thus, @samp{[ad]} matches either one @samp{a} or
@@ -1060,7 +1061,7 @@ Greek letters.
@cindex character classes, in regular expressions
You can also include certain special @dfn{character classes} in a
character set. A @samp{[:} and balancing @samp{:]} enclose a
-character class inside a set of alternative characters. For instance,
+character class inside a bracket expression. For instance,
@samp{[[:alnum:]]} matches any letter or digit. @xref{Char Classes,,,
elisp, The Emacs Lisp Reference Manual}, for a list of character
classes.
@@ -1128,7 +1129,7 @@ no preceding expression on which the @samp{*} can act. It is poor practice
to depend on this behavior; it is better to quote the special character anyway,
regardless of where it appears.
-As a @samp{\} is not special inside a set of alternative characters, it can
+As a @samp{\} is not special inside a bracket expression, it can
never remove the special meaning of @samp{-}, @samp{^} or @samp{]}.
You should not quote these characters when they have no special
meaning. This would not clarify anything, since backslashes
diff --git a/doc/emacs/text.texi b/doc/emacs/text.texi
index 2db31c66f3b..cb347d59948 100644
--- a/doc/emacs/text.texi
+++ b/doc/emacs/text.texi
@@ -253,6 +253,10 @@ value of @code{sentence-end-double-space}.
of a sentence. Set the variable @code{sentence-end-without-period} to
@code{t} in such cases.
+ Even though the above mentioned sentence movement commands are based
+on human languages, other Emacs modes can set these command to get
+similar functionality (@pxref{Moving by Sentences}).
+
@node Paragraphs
@section Paragraphs
@cindex paragraphs
@@ -939,12 +943,12 @@ situations where you shouldn't change the major mode---in mail
composition, for instance.
@kindex M-TAB @r{(Text mode)}
- Text mode binds @kbd{M-@key{TAB}} to @code{ispell-complete-word}.
-This command performs completion of the partial word in the buffer
-before point, using the spelling dictionary as the space of possible
-words. @xref{Spelling}. If your window manager defines
-@kbd{M-@key{TAB}} to switch windows, you can type @kbd{@key{ESC}
-@key{TAB}} or @kbd{C-M-i} instead.
+ The command @kbd{M-@key{TAB}} (@code{completion-at-point}) performs
+completion of the partial word in the buffer before point, using the
+spelling dictionary as the space of possible words by default.
+@xref{Spelling}. If your window manager defines @kbd{M-@key{TAB}} to
+switch windows, you can type @kbd{@key{ESC} @key{TAB}} or @kbd{C-M-i}
+instead.
@vindex text-mode-hook
Entering Text mode runs the mode hook @code{text-mode-hook}
@@ -1093,6 +1097,12 @@ so that Outline mode will know that sections are contained in
chapters. This works as long as no other command starts with
@samp{@@chap}.
+@vindex outline-search-function
+ Instead of setting the variable @code{outline-regexp}, you can set
+the variable @code{outline-search-function} to a function that
+matches the current heading and searches for the next one
+(@pxref{Outline Minor Mode,,,elisp, the Emacs Lisp Reference Manual}).
+
@vindex outline-level
You can explicitly specify a rule for calculating the level of a
heading line by setting the variable @code{outline-level}. The value
diff --git a/doc/emacs/trouble.texi b/doc/emacs/trouble.texi
index 0f8ad3e061b..22042b4c92c 100644
--- a/doc/emacs/trouble.texi
+++ b/doc/emacs/trouble.texi
@@ -1514,7 +1514,7 @@ Appendix, elisp, Emacs Lisp Reference}.
@end ifclear
@item
-Avoid using @code{defadvice} or @code{with-eval-after-load} for Lisp code
+Avoid using @code{advice-add} or @code{with-eval-after-load} for Lisp code
to be included in Emacs.
@item
diff --git a/doc/emacs/windows.texi b/doc/emacs/windows.texi
index 302d3dcbf8c..ad2225b5922 100644
--- a/doc/emacs/windows.texi
+++ b/doc/emacs/windows.texi
@@ -411,6 +411,28 @@ selected window and (ii) prefer to either create a new frame or use a
window on some other frame to display the desired buffer. Several of
these commands are bound in the @kbd{C-x 5} prefix key.
+@cindex dedicated window
+ Sometimes, a window is ``dedicated'' to its current buffer.
+@xref{Dedicated Windows,, elisp, The Emacs Lisp Reference Manual}.
+@code{display-buffer} will avoid reusing dedicated windows most of the
+time. This is indicated by a @samp{d} in the mode line (@pxref{Mode
+Line}). A window can also be strongly dedicated, which prevents any
+changes to the buffer displayed in the window. This is indicated by a
+@samp{D} in the mode line.
+
+Usually, dedicated windows are used to display specialized buffers,
+but dedication can sometimes be useful interactively. For example,
+when viewing errors with @kbd{M-g M-n} @code{next-error}, newly
+displayed source code may replace a buffer you want to refer to. If
+you dedicate a window to that buffer, the command (through
+@code{display-buffer}) will prefer to use a different window instead.
+
+@kindex C-x w d
+@findex toggle-window-dedicated
+ Toggle whether the selected window is dedicated to the current
+buffer. With a prefix argument, make the window strongly dedicated
+instead.
+
@menu
* Window Choice:: How @code{display-buffer} works.
* Temporary Displays:: Displaying non-editable buffers.
@@ -642,6 +664,13 @@ to the window-local tab line of buffers, and clicking on the @kbd{x}
icon of a tab deletes it. The mouse wheel on the tab line scrolls
the tabs horizontally.
+ Touch screen input (@pxref{Other Input}) can also be used to
+interact with the ``tab line''. Long-pressing (@pxref{Touchscreens})
+a tab will display a context menu with items that operate on the tab
+that was pressed; tapping a tab itself will result in switching to
+that tab's buffer, and tapping a button on the tab line will behave as
+if it was clicked with @kbd{mouse-1}.
+
Selecting the previous window-local tab is the same as typing @kbd{C-x
@key{LEFT}} (@code{previous-buffer}), selecting the next tab is the
same as @kbd{C-x @key{RIGHT}} (@code{next-buffer}). Both commands
diff --git a/doc/lispref/ChangeLog.1 b/doc/lispref/ChangeLog.1
index 99452e2f3bd..ee8f418414c 100644
--- a/doc/lispref/ChangeLog.1
+++ b/doc/lispref/ChangeLog.1
@@ -5792,7 +5792,7 @@
* display.texi (Face Functions): Mention define-obsolete-face-alias.
-2009-08-26 Ulrich Mueller <ulm@gentoo.org>
+2009-08-26 Ulrich Müller <ulm@gentoo.org>
* nonascii.texi (Character Codes): Fix typos.
@@ -7394,7 +7394,7 @@
* tips.texi (Coding Conventions): Do not encourage the use of "-flag"
variable names.
-2008-05-03 Eric S. Raymond <esr@golux>
+2008-05-03 Eric S. Raymond <esr@thyrsus.com>
* keymaps.texi: Clarify that (current-local-map) and
(current-global-map) return references, not copies.
@@ -13889,17 +13889,17 @@
* Makefile (dist): Change to use Gzip instead of compress.
-1993-04-23 Eric S. Raymond (eric@mole.gnu.ai.mit.edu)
+1993-04-23 Eric S. Raymond (esr@thyrsus.com)
* loading.texi (Unloading): define-function changed back to
defalias. It may not stay this way, but at least it's
consistent with the known-good version of the code patch.
-1993-03-26 Eric S. Raymond (eric@geech.gnu.ai.mit.edu)
+1993-03-26 Eric S. Raymond (esr@thyrsus.com)
* modes.texi (Hooks): Document new optional arg of add-hook.
-1993-03-17 Eric S. Raymond (eric@mole.gnu.ai.mit.edu)
+1993-03-17 Eric S. Raymond (esr@thyrsus.com)
* variables.texi: Document nil initial value of buffer-local variables.
diff --git a/doc/lispref/Makefile.in b/doc/lispref/Makefile.in
index 476b8cf8fe6..0a228271be3 100644
--- a/doc/lispref/Makefile.in
+++ b/doc/lispref/Makefile.in
@@ -144,7 +144,15 @@ ps: $(PS_TARGETS)
${buildinfodir}:
${MKDIR_P} $@
-$(buildinfodir)/elisp.info: $(srcs) | ${buildinfodir}
+auxfiles = $(buildinfodir)/elisp_type_hierarchy.txt $(buildinfodir)/elisp_type_hierarchy.jpg
+
+$(buildinfodir)/elisp_type_hierarchy.txt: $(srcdir)/elisp_type_hierarchy.txt | ${buildinfodir}
+ cp $< $@
+
+$(buildinfodir)/elisp_type_hierarchy.jpg: $(srcdir)/elisp_type_hierarchy.jpg | ${buildinfodir}
+ cp $< $@
+
+$(buildinfodir)/elisp.info: $(srcs) $(auxfiles) | ${buildinfodir}
$(AM_V_GEN)$(MAKEINFO) $(MAKEINFO_OPTS) $(INFO_OPTS) -o $@ $<
elisp.dvi: $(srcs)
@@ -179,6 +187,7 @@ infoclean:
$(buildinfodir)/elisp.info \
$(buildinfodir)/elisp.info-[1-9] \
$(buildinfodir)/elisp.info-[1-9][0-9]
+ rm -f $(auxfiles)
bootstrap-clean maintainer-clean: distclean infoclean
rm -f TAGS
diff --git a/doc/lispref/abbrevs.texi b/doc/lispref/abbrevs.texi
index 9b719145584..d89cec4bc2b 100644
--- a/doc/lispref/abbrevs.texi
+++ b/doc/lispref/abbrevs.texi
@@ -65,7 +65,7 @@ expanded in the buffer. For the user-level commands for abbrevs, see
@defun make-abbrev-table &optional props
This function creates and returns a new, empty abbrev table---an
-obarray containing no symbols. It is a vector filled with zeros.
+obarray containing no symbols.
@var{props} is a property list that is applied to the new table
(@pxref{Abbrev Table Properties}).
@end defun
diff --git a/doc/lispref/buffers.texi b/doc/lispref/buffers.texi
index f67a954edc5..5375eb64155 100644
--- a/doc/lispref/buffers.texi
+++ b/doc/lispref/buffers.texi
@@ -371,6 +371,12 @@ See the related function @code{generate-new-buffer} in @ref{Creating
Buffers}.
@end defun
+@defun buffer-last-name &optional buffer
+This function returns the previous name of @var{buffer}, before it was
+killed or before the last time it was renamed. If nil or omitted,
+@var{buffer} defaults to the current buffer.
+@end defun
+
@node Buffer File Name
@section Buffer File Name
@cindex visited file
@@ -957,10 +963,10 @@ 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
+@defun buffer-match-p condition buffer-or-name &rest args
This function checks if a buffer designated by @code{buffer-or-name}
-satisfies the specified @var{condition}. Optional third argument
-@var{arg} is passed to the predicate function in @var{condition}. A
+satisfies the specified @var{condition}. Optional arguments
+@var{args} are passed to the predicate function in @var{condition}. A
valid @var{condition} can be one of the following:
@itemize @bullet{}
@item
@@ -969,23 +975,21 @@ 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).
+matches. It is called with
+@var{buffer-or-name} as the first argument followed by @var{args}.
@item
A cons-cell @code{(@var{oper} . @var{expr})} where @var{oper} is one
of
@table @code
@item (not @var{cond})
Satisfied if @var{cond} doesn't satisfy @code{buffer-match-p} with
-the same buffer and @code{arg}.
+the same buffer and @code{args}.
@item (or @var{conds}@dots{})
Satisfied if @emph{any} condition in @var{conds} satisfies
-@code{buffer-match-p}, with the same buffer and @code{arg}.
+@code{buffer-match-p}, with the same buffer and @code{args}.
@item (and @var{conds}@dots{})
Satisfied if @emph{all} the conditions in @var{conds} satisfy
-@code{buffer-match-p}, with the same buffer and @code{arg}.
+@code{buffer-match-p}, with the same buffer and @code{args}.
@item derived-mode
Satisfied if the buffer's major mode derives from @var{expr}. Note
that this condition might fail to report a match if
@@ -1003,14 +1007,14 @@ string) or @code{(and)} (empty conjunction).
@end itemize
@end defun
-@defun match-buffers condition &optional buffer-list arg
+@defun match-buffers condition &optional buffer-list &rest args
This function returns a list of all buffers that satisfy the
@var{condition}. If no buffers match, the function returns
@code{nil}. The argument @var{condition} is as defined in
@code{buffer-match-p} above. By default, all the buffers are
considered, but this can be restricted via the optional argument
@code{buffer-list}, which should be a list of buffers to consider.
-Optional third argument @var{arg} will be passed to @var{condition} in
+Remaining arguments @var{args} will be passed to @var{condition} in
the same way as @code{buffer-match-p} does.
@end defun
diff --git a/doc/lispref/commands.texi b/doc/lispref/commands.texi
index dfb20cd807b..4fe4969c0db 100644
--- a/doc/lispref/commands.texi
+++ b/doc/lispref/commands.texi
@@ -1303,12 +1303,19 @@ A device used by the XTEST extension to report input.
@cindex @code{display} property, and point display
@cindex @code{composition} property, and point display
- Emacs cannot display the cursor when point is in the middle of a
-sequence of text that has the @code{display} or @code{composition}
-property, or is invisible. Therefore, after a command finishes and
-returns to the command loop, if point is within such a sequence, the
-command loop normally moves point to the edge of the sequence, making this
-sequence effectively intangible.
+ When a sequence of text has the @code{display} or @code{composition}
+property, or is invisible, there can be several buffer positions that
+result in the cursor being displayed at same place on the screen.
+Therefore, after a command finishes and returns to the command loop,
+if point is in such a sequence, the command loop normally moves point
+to try and make this sequence effectively intangible.
+
+This @emph{point adjustment} follows the following general rules: first, the
+adjustment should not change the overall direction of the command;
+second if the command moved point, the adjustment tries to ensure the
+cursor is also moved; third, Emacs prefers the edges of an intangible
+sequence and among those edges it prefers the non sticky ones, such
+that newly inserted text is visible.
A command can inhibit this feature by setting the variable
@code{disable-point-adjustment}:
@@ -1847,20 +1854,19 @@ represented in Lisp as lists. The lists record both the starting mouse
position and the final position, like this:
@example
-(@var{event-type}
- (@var{window1} START-POSITION)
- (@var{window2} END-POSITION))
+(@var{event-type} @var{start-position} @var{end-position})
@end example
For a drag event, the name of the symbol @var{event-type} contains the
prefix @samp{drag-}. For example, dragging the mouse with button 2
held down generates a @code{drag-mouse-2} event. The second and third
-elements of the event give the starting and ending position of the
-drag, as mouse position lists (@pxref{Click Events}). You can access
-the second element of any mouse event in the same way. However, the
-drag event may end outside the boundaries of the frame that was
-initially selected. In that case, the third element's position list
-contains that frame in place of a window.
+elements of the event, @var{start-position} and @var{end-position} in
+the foregoing illustration, are set to the start and end positions of
+the drag as mouse position lists (@pxref{Click Events}). You can
+access the second element of any mouse event in the same way.
+However, the drag event may end outside the boundaries of the frame
+that was initially selected. In that case, the third element's
+position list contains that frame in place of a window.
The @samp{drag-} prefix follows the modifier key prefixes such as
@samp{C-} and @samp{M-}.
@@ -2061,6 +2067,10 @@ the position of the finger when the event occurred.
This event is sent when @var{point} is created by the user pressing a
finger against the touchscreen.
+Imaginary prefix keys are also affixed to these events
+@code{read-key-sequence} when they originate on top of a special part
+of a frame or window. @xref{Key Sequence Input}.
+
@cindex @code{touchscreen-update} event
@item (touchscreen-update @var{points})
This event is sent when a point on the touchscreen has changed
@@ -2068,12 +2078,227 @@ position. @var{points} is a list of touch points containing the
up-to-date positions of each touch point currently on the touchscreen.
@cindex @code{touchscreen-end} event
-@item (touchscreen-end @var{point})
+@item (touchscreen-end @var{point} @var{canceled})
This event is sent when @var{point} is no longer present on the
display, because another program took the grab, or because the user
raised the finger from the touchscreen.
+
+@var{canceled} is non-@code{nil} if the touch sequence has been
+intercepted by another program (such as the window manager), and Emacs
+should undo or avoid any editing commands that would otherwise result
+from the touch sequence.
+
+Imaginary prefix keys are also affixed to these events
+@code{read-key-sequence} when they originate on top of a special part
+of a frame or window.
@end table
+If a touchpoint is pressed against the menu bar, then Emacs will not
+generate any corresponding @code{touchscreen-begin} or
+@code{touchscreen-end} events; instead, the menu bar may be displayed
+after @code{touchscreen-end} would have been delivered under other
+circumstances.
+
+@cindex mouse emulation from touch screen events
+When no command is bound to @code{touchscreen-begin},
+@code{touchscreen-end} or @code{touchscreen-update}, Emacs calls a
+``key translation function'' (@pxref{Translation Keymaps}) to
+translate key sequences containing touch screen events into ordinary
+mouse events (@pxref{Mouse Events}.) Since Emacs doesn't support
+distinguishing events originating from separate mouse devices, it
+assumes that a maximum of two touchpoints are active while translation
+takes place, and does not place any guarantees on the results of event
+translation when that restriction is overstepped.
+
+Emacs applies two different strategies for translating touch events
+into mouse events, contingent on factors such as the commands bound to
+keymaps that are active at the location of the
+@code{touchscreen-begin} event. If a command is bound to
+@code{down-mouse-1} at that location, the initial translation consists
+of a single @code{down-mouse-1} event, with subsequent
+@code{touchscreen-update} events translated to mouse motion events
+(@pxref{Motion Events}), and a final @code{touchscreen-end} event
+translated to a @code{mouse-1} or @code{drag-mouse-1} event (unless
+the @code{touchscreen-end} event indicates that the touch sequence has
+been intercepted by another program.) This is dubbed ``simple
+translation'', and produces a simple correspondence between touchpoint
+motion and mouse motion.
+
+@cindex @code{ignored-mouse-command}, a symbol property
+However, some commands bound to
+@code{down-mouse-1}--@code{mouse-drag-region}, for example--either
+conflict with defined touch screen gestures (such as ``long-press to
+drag''), or with user expectations for touch input, and shouldn't
+subject the touch sequence to simple translation. If a command whose
+name contains the property (@pxref{Symbol Properties})
+@code{ignored-mouse-command} is encountered or there is no command
+bound to @code{down-mouse-1}, a more irregular form of translation
+takes place: here, Emacs processes touch screen gestures
+(@pxref{Touchscreens,,, emacs, The GNU Emacs Manual}) first, and
+finally attempts to translate touch screen events into mouse events if
+no gesture was detected prior to a closing @code{touchscreen-end}
+event (with its @var{canceled} parameter @code{nil}, as with simple
+translation) and a command is bound to @code{mouse-1} at the location
+of that event. Before generating the @code{mouse-1} event, point is
+also set to the location of the @code{touchscreen-end} event, and the
+window containing the position of that event is selected, as a
+compromise for packages which assume @code{mouse-drag-region} has
+already set point to the location of any mouse click and selected the
+window where it took place.
+
+To prevent unwanted @code{mouse-1} events arriving after a mouse menu
+is dismissed (@pxref{Mouse Menus}), Emacs also avoids simple
+translation if @code{down-mouse-1} is bound to a keymap, making it a
+prefix key. In lieu of simple translation, it translates the closing
+@code{touchscreen-end} to a @code{down-mouse-1} event with the
+starting position of the touch sequence, consequently displaying
+the mouse menu.
+
+@cindex @code{mouse-1-menu-command}, a symbol property
+Since certain commands are also bound to @code{down-mouse-1} for the
+purpose of displaying pop-up menus, Emacs additionally behaves as
+illustrated in the last paragraph if @code{down-mouse-1} is bound to a
+command whose name has the property @code{mouse-1-menu-command}.
+
+@cindex pinch-to-zoom touchscreen gesture translation
+When a second touch point is registered as a touch point is already
+being translated, gesture translation is terminated, and the distance
+from the second touch point (the @dfn{ancillary tool}) to the first is
+measured. Subsequent motion from either of those touch points will
+yield @code{touchscreen-pinch} events incorporating the ratio formed
+by the distance between their new positions and the distance measured
+at the outset, as illustrated in the following table.
+
+@cindex touchscreen gesture events
+If touch gestures are detected during translation, one of the
+following input events may be generated:
+
+@table @code
+@cindex @code{touchscreen-scroll} event
+@item (touchscreen-scroll @var{window} @var{dx} @var{dy})
+If a ``scrolling'' gesture is detected during the translation process,
+each subsequent @code{touchscreen-update} event is translated to a
+@code{touchscreen-scroll} event, where @var{dx} and @var{dy} specify,
+in pixels, the relative motion of the touchpoint from the position of
+the @code{touchscreen-begin} event that started the sequence or the
+last @code{touchscreen-scroll} event, whichever came later.
+
+@cindex @code{touchscreen-hold} event
+@item (touchscreen-hold @var{posn})
+If the single active touchpoint remains stationary for more than
+@code{touch-screen-delay} seconds after a @code{touchscreen-begin} is
+generated, a ``long-press'' gesture is detected during the translation
+process, and a @code{touchscreen-hold} event is sent, with @var{posn}
+set to a mouse position list containing the position of the
+@code{touchscreen-begin} event.
+
+@cindex @code{touchscreen-drag} event
+@item (touchscreen-drag @var{posn})
+If a ``long-press'' gesture is detected while translating the current
+touch sequence or ``drag-to-select'' is being resumed as a result of
+the @code{touch-screen-extend-selection} user option, a
+@code{touchscreen-drag} event is sent upon each subsequent
+@code{touchscreen-update} event with @var{posn} set to the new
+position of the touchpoint.
+
+@cindex @code{touchscreen-restart-drag} event
+@item (touchscreen-restart-drag @var{posn})
+This event is sent upon the start of a touch sequence resulting in the
+continuation of a ``drag-to-select'' gesture (subject to the
+aforementioned user option) with @var{posn} set to the position list of
+the initial @code{touchscreen-begin} event within that touch sequence.
+
+@cindex @code{touchscreen-pinch} event
+@item (touchscreen-pinch @var{posn} @var{ratio} @var{pan-x} @var{pan-y} @var{ratio-diff})
+This event is delivered upon significant changes to the positions of
+either active touch point when an ancillary tool is active.
+
+@var{posn} is a mouse position list for the midpoint of a line drawn
+from the ancillary tool to the other touch point being observed.
+
+@var{ratio} is the distance between both touch points being observed
+divided by that distance when the ancillary point was first
+registered; which is to say, the scale of the ``pinch'' gesture.
+
+@var{pan-x} and @var{pan-y} are the difference between the pixel
+position of @var{posn} and this position within the last event
+delivered appertaining to this series of touch events, or in the case
+that no such event exists, the centerpoint between both touch points
+when the ancillary tool was first registered.
+
+@var{ratio-diff} is the difference between this event's ratio and
+@var{ratio} in the last event delivered; it is @var{ratio} if no such
+event exists.
+
+Such events are sent when the magnitude of the changes they represent
+will yield a @var{ratio} which differs by more than @code{0.2} from
+that in the previous event, or the sum of @var{pan-x} and @var{pan-y}
+will surpass half the frame's character width in pixels (@pxref{Frame
+Font}).
+@end table
+
+@cindex handling touch screen events
+@cindex tap and drag, touch screen gestures
+Several functions are provided for Lisp programs that handle touch
+screen events. The intended use of the first two functions described
+below is from commands bound directly to @code{touchscreen-begin}
+events; they allow responding to commonly used touch screen gestures
+separately from mouse event translation.
+
+@defun touch-screen-track-tap event &optional update data threshold
+This function is used to track a single ``tap'' gesture originating
+from the @code{touchscreen-begin} event @var{event}, often used to
+set the point or to activate a button. It waits for a
+@code{touchscreen-end} event with the same touch identifier to arrive,
+at which point it returns @code{t}, signifying the end of the gesture.
+
+If a @code{touchscreen-update} event arrives in the mean time and
+contains at least one touchpoint with the same identifier as in
+@var{event}, the function @var{update} is called with two arguments,
+the list of touchpoints in that @code{touchscreen-update} event, and
+@var{data}.
+
+If @var{threshold} is non-@code{nil} and such an event indicates that
+the touchpoint represented by @var{event} has moved beyond a threshold
+of either @var{threshold} or 10 pixels if it is not a number from the
+position of @var{event}, @code{nil} is returned and mouse event
+translation is resumed for that touchpoint, so as not to impede the
+recognition of any subsequent touchscreen gesture arising from its
+sequence.
+
+If any other event arrives in the mean time, @code{nil} is returned.
+The caller should not perform any action in that case.
+@end defun
+
+@defun touch-screen-track-drag event update &optional data
+This function is used to track a single ``drag'' gesture originating
+from the @code{touchscreen-begin} event @code{event}.
+
+It behaves like @code{touch-screen-track-tap}, except that it returns
+@code{no-drag} and refrains from calling @var{update} if the
+touchpoint in @code{event} did not move far enough (by default, 5
+pixels from its position in @code{event}) to qualify as an actual
+drag.
+@end defun
+
+In addition to those two functions, a function is provided for
+commands bound to some types of events generated through mouse event
+translation to prevent unwanted events from being generated after it
+is called.
+
+@defun touch-screen-inhibit-drag
+This function inhibits the generation of @code{touchscreen-drag}
+events during mouse event translation for the duration of the touch
+sequence being translated after it is called. It must be called from
+a command which is bound to a @code{touchscreen-hold} or
+@code{touchscreen-drag} event, and signals an error otherwise.
+
+Since this function can only be called after a gesture is already
+recognized during mouse event translation, no mouse events will be
+generated from touch events constituting the previously mentioned
+touch sequence after it is called.
+@end defun
+
@node Focus Events
@subsection Focus Events
@cindex focus event
@@ -2210,6 +2435,72 @@ the buffer in which the xwidget will be displayed, using
A few other event types represent occurrences within the system.
@table @code
+@cindex @code{text-conversion} event
+@item text-conversion
+This kind of event is sent @strong{after} a system-wide input method
+performs an edit to one or more buffers.
+
+@vindex text-conversion-edits
+Once the event is sent, the input method may already have made changes
+to multiple buffers inside many different frames. To determine which
+buffers have been changed, and what edits have been made to them, use
+the variable @code{text-conversion-edits}, which is set prior to each
+@code{text-conversion} event being sent; it is a list of the form:
+
+@example
+@w{@code{((@var{buffer} @var{beg} @var{end} @var{ephemeral}) ...)}}
+@end example
+
+Where @var{ephemeral} is the buffer which was modified, @var{beg} and
+@var{end} are markers set to the positions of the edit at the time it
+was completed, and @var{ephemeral} is either a string, containing any
+text which was inserted (or any text before point which was deleted),
+@code{t}, meaning that the edit is a temporary edit made by the input
+method, or @code{nil}, meaning that some text was deleted after point.
+
+@vindex text-conversion-style
+Whether or not this event is sent depends on the value of the
+buffer-local variable @code{text-conversion-style}, which determines
+how an input method that wishes to make edits to buffer contents will
+behave.
+
+This variable can have one of four values:
+
+@table @code
+@item nil
+This means that the input method will be disabled entirely, and key
+events will be sent instead of text conversion events.
+
+@item action
+This means that the input method will be enabled, but @key{RET} will
+be sent whenever the input method wants to insert a new line.
+
+@item password
+This is largely identical to @code{action}, but also requests an input
+method capable of inserting ASCII characters, and instructs it not to
+save input in locations from which it might be subsequently retrieved
+by features of the input method that cannot handle sensitive
+information, such as text suggestions.
+
+@item t
+This, or any other value, means that the input method will be enabled
+and make edits followed by @code{text-conversion} events.
+@end table
+
+@findex set-text-conversion-style
+Changes to the value of this variable will only take effect upon the
+next redisplay after the buffer becomes the selected buffer of a
+frame. If you need to disable text conversion in a way that takes
+immediate effect, call the function @code{set-text-conversion-style}
+instead. This has the potential to lock up the input method for a
+significant amount of time, and should be used with care.
+
+@vindex disable-inhibit-text-conversion
+In addition, text conversion is automatically disabled after a prefix
+key is read by the command loop or @code{read-key-sequence}. This can
+be disabled by setting or binding the variable
+@code{disable-inhibit-text-conversion} to a non-@code{nil} value.
+
@cindex @code{delete-frame} event
@item (delete-frame (@var{frame}))
This kind of event indicates that the user gave the window manager
@@ -2278,23 +2569,27 @@ non-@code{nil}.
@vindex mouse-wheel-up-event
@vindex mouse-wheel-down-event
The @code{wheel-up} and @code{wheel-down} events are generated only on
-some kinds of systems. On other systems, @code{mouse-4} and
-@code{mouse-5} are used instead. For portable code, use the variables
-@code{mouse-wheel-up-event}, @code{mouse-wheel-up-alternate-event},
-@code{mouse-wheel-down-event} and
-@code{mouse-wheel-down-alternate-event} defined in @file{mwheel.el} to
-determine what event types to expect from the mouse wheel.
+some kinds of systems. On other systems, other events like @code{mouse-4} and
+@code{mouse-5} are used instead. Portable code should handle both
+@code{wheel-up} and @code{wheel-down} events as well as the events
+specified in the variables @code{mouse-wheel-up-event} and
+@code{mouse-wheel-down-event}, defined in @file{mwheel.el}.
+Beware that for historical reasons the @code{mouse-wheel-@emph{up}-event}
+is the variable that holds an event that should be handled similarly to
+@code{wheel-@emph{down}} and vice versa.
@vindex mouse-wheel-left-event
@vindex mouse-wheel-right-event
-Similarly, some mice can generate @code{mouse-wheel-left-event} and
-@code{mouse-wheel-right-event} and can be used to scroll if
-@code{mouse-wheel-tilt-scroll} is non-@code{nil}. However, some mice
-also generate other events at the same time as they're generating
-these scroll events which may get in the way. The way to fix this is
-generally to unbind these events (for instance, @code{mouse-6} or
-@code{mouse-7}, but this is very hardware and operating system
-dependent).
+The same holds for the horizontal wheel movements which are usually
+represented by @code{wheel-left} and @code{wheel-right} events, but
+for which portable code should also obey the variables
+@code{mouse-wheel-left-event} and @code{mouse-wheel-right-event},
+defined in @file{mwheel.el}.
+However, some mice also generate other events at the same time as
+they're generating these scroll events which may get in the way.
+The way to fix this is generally to unbind these events (for instance,
+@code{mouse-6} or @code{mouse-7}, but this is very hardware and
+operating system dependent).
@cindex @code{pinch} event
@item (pinch @var{position} @var{dx} @var{dy} @var{scale} @var{angle})
@@ -2804,6 +3099,17 @@ If @var{whole} is non-@code{nil}, the @var{x} coordinate is relative
to the entire window area including scroll bars, margins and fringes.
@end defun
+@defopt mouse-prefer-closest-glyph
+If this variable is non-@code{nil}, the @code{posn-point} of a mouse
+position list will be set to the position of the glyph whose leftmost
+edge is the closest to the mouse click, as opposed to the position of
+the glyph underneath the mouse pointer itself. For example, if
+@code{posn-at-x-y} is called with @var{x} set to @code{9}, which is
+contained within a character of width 10 displayed at column 0, the
+point saved within the mouse position list will be @emph{after} that
+character, not @emph{before} it.
+@end defopt
+
@node Accessing Scroll
@subsection Accessing Scroll Bar Events
@cindex scroll bar events, data in
@@ -2981,7 +3287,7 @@ debugging terminal input.
@code{read-key-sequence}. Lisp programs can also call this function;
for example, @code{describe-key} uses it to read the key to describe.
-@defun read-key-sequence prompt &optional continue-echo dont-downcase-last switch-frame-ok command-loop
+@defun read-key-sequence prompt &optional continue-echo dont-downcase-last switch-frame-ok command-loop disable-text-conversion
This function reads a key sequence and returns it as a string or
vector. It keeps reading events until it has accumulated a complete key
sequence; that is, enough to specify a non-prefix command using the
@@ -3021,6 +3327,12 @@ key sequence is being read by something that will read commands one
after another. It should be @code{nil} if the caller will read just
one key sequence.
+The argument @var{disable-text-conversion}, if non-@code{nil}, means
+that system input methods will not directly perform edits to buffer
+text while this key sequence is being read; user input will always
+generated individual key events instead. @xref{Misc Events}, for more
+about text conversion.
+
In the following example, Emacs displays the prompt @samp{?} in the
echo area, and then the user types @kbd{C-x C-f}.
@@ -3041,7 +3353,7 @@ typed while reading with this function works like any other character,
and does not set @code{quit-flag}. @xref{Quitting}.
@end defun
-@defun read-key-sequence-vector prompt &optional continue-echo dont-downcase-last switch-frame-ok command-loop
+@defun read-key-sequence-vector prompt &optional continue-echo dont-downcase-last switch-frame-ok command-loop disable-text-conversion
This is like @code{read-key-sequence} except that it always
returns the key sequence as a vector, never as a string.
@xref{Strings of Events}.
@@ -3089,19 +3401,22 @@ with any other events.
@cindex @code{right-divider}, prefix key
@cindex @code{bottom-divider}, prefix key
@cindex mouse events, in special parts of window or frame
-When mouse events occur in special parts of a window or frame, such as a mode
+@cindex touch screen events, in special parts of window or frame
+When mouse or @code{touchscreen-begin} and @code{touchscreen-end}
+events occur in special parts of a window or frame, such as a mode
line or a scroll bar, the event type shows nothing special---it is the
same symbol that would normally represent that combination of mouse
-button and modifier keys. The information about the window part is kept
-elsewhere in the event---in the coordinates. But
+button and modifier keys. The information about the window part is
+kept elsewhere in the event---in the coordinates. But
@code{read-key-sequence} translates this information into imaginary
-prefix keys, all of which are symbols: @code{tab-line}, @code{header-line},
-@code{horizontal-scroll-bar}, @code{menu-bar}, @code{tab-bar}, @code{mode-line},
-@code{vertical-line}, @code{vertical-scroll-bar}, @code{left-margin},
-@code{right-margin}, @code{left-fringe}, @code{right-fringe},
-@code{right-divider}, and @code{bottom-divider}. You can define meanings for
-mouse clicks in special window parts by defining key sequences using these
-imaginary prefix keys.
+prefix keys, all of which are symbols: @code{tab-line},
+@code{header-line}, @code{horizontal-scroll-bar}, @code{menu-bar},
+@code{tab-bar}, @code{mode-line}, @code{vertical-line},
+@code{vertical-scroll-bar}, @code{left-margin}, @code{right-margin},
+@code{left-fringe}, @code{right-fringe}, @code{right-divider}, and
+@code{bottom-divider}. You can define meanings for mouse clicks in
+special window parts by defining key sequences using these imaginary
+prefix keys.
For example, if you call @code{read-key-sequence} and then click the
mouse on the window's mode line, you get two events, like this:
@@ -3709,26 +4024,19 @@ the timeout elapses).
In batch mode (@pxref{Batch Mode}), @code{sit-for} cannot be
interrupted, even by input from the standard input descriptor. It is
thus equivalent to @code{sleep-for}, which is described below.
-
-It is also possible to call @code{sit-for} with three arguments,
-as @code{(sit-for @var{seconds} @var{millisec} @var{nodisp})},
-but that is considered obsolete.
@end defun
-@defun sleep-for seconds &optional millisec
+@defun sleep-for seconds
This function simply pauses for @var{seconds} seconds without updating
the display. It pays no attention to available input. It returns
@code{nil}.
The argument @var{seconds} need not be an integer. If it is floating
point, @code{sleep-for} waits for a fractional number of seconds.
-Some systems support only a whole number of seconds; on these systems,
-@var{seconds} is rounded down.
-The optional argument @var{millisec} specifies an additional waiting
-period measured in milliseconds. This adds to the period specified by
-@var{seconds}. If the system doesn't support waiting fractions of a
-second, you get an error if you specify nonzero @var{millisec}.
+It is also possible to call @code{sleep-for} with two arguments,
+as @code{(sleep-for @var{seconds} @var{millisec})},
+but that is considered obsolete and will be removed in the future.
Use @code{sleep-for} when you wish to guarantee a delay.
@end defun
diff --git a/doc/lispref/compile.texi b/doc/lispref/compile.texi
index 0c86c02c90f..00602198da5 100644
--- a/doc/lispref/compile.texi
+++ b/doc/lispref/compile.texi
@@ -35,7 +35,6 @@ variable binding for @code{no-byte-compile} into it, like this:
* Speed of Byte-Code:: An example of speedup from byte compilation.
* Compilation Functions:: Byte compilation functions.
* Docs and Compilation:: Dynamic loading of documentation strings.
-* Dynamic Loading:: Dynamic loading of individual functions.
* Eval During Compile:: Code to be evaluated when you compile.
* Compiler Errors:: Handling compiler error messages.
* Byte-Code Objects:: The data type used for byte-compiled functions.
@@ -289,71 +288,6 @@ stands for the name of this file, as a string. Do not use these
constructs in Lisp source files; they are not designed to be clear to
humans reading the file.
-@node Dynamic Loading
-@section Dynamic Loading of Individual Functions
-
-@cindex dynamic loading of functions
-@cindex lazy loading
- When you compile a file, you can optionally enable the @dfn{dynamic
-function loading} feature (also known as @dfn{lazy loading}). With
-dynamic function loading, loading the file doesn't fully read the
-function definitions in the file. Instead, each function definition
-contains a place-holder which refers to the file. The first time each
-function is called, it reads the full definition from the file, to
-replace the place-holder.
-
- The advantage of dynamic function loading is that loading the file
-should become faster. This is a good thing for a file which contains
-many separate user-callable functions, if using one of them does not
-imply you will probably also use the rest. A specialized mode which
-provides many keyboard commands often has that usage pattern: a user may
-invoke the mode, but use only a few of the commands it provides.
-
- The dynamic loading feature has certain disadvantages:
-
-@itemize @bullet
-@item
-If you delete or move the compiled file after loading it, Emacs can no
-longer load the remaining function definitions not already loaded.
-
-@item
-If you alter the compiled file (such as by compiling a new version),
-then trying to load any function not already loaded will usually yield
-nonsense results.
-@end itemize
-
- These problems will never happen in normal circumstances with
-installed Emacs files. But they are quite likely to happen with Lisp
-files that you are changing. The easiest way to prevent these problems
-is to reload the new compiled file immediately after each recompilation.
-
- @emph{Experience shows that using dynamic function loading provides
-benefits that are hardly measurable, so this feature is deprecated
-since Emacs 27.1.}
-
- The byte compiler uses the dynamic function loading feature if the
-variable @code{byte-compile-dynamic} is non-@code{nil} at compilation
-time. Do not set this variable globally, since dynamic loading is
-desirable only for certain files. Instead, enable the feature for
-specific source files with file-local variable bindings. For example,
-you could do it by writing this text in the source file's first line:
-
-@example
--*-byte-compile-dynamic: t;-*-
-@end example
-
-@defvar byte-compile-dynamic
-If this is non-@code{nil}, the byte compiler generates compiled files
-that are set up for dynamic function loading.
-@end defvar
-
-@defun fetch-bytecode function
-If @var{function} is a byte-code function object, this immediately
-finishes loading the byte code of @var{function} from its
-byte-compiled file, if it is not fully loaded already. Otherwise,
-it does nothing. It always returns @var{function}.
-@end defun
-
@node Eval During Compile
@section Evaluation During Compilation
@cindex eval during compilation
@@ -801,9 +735,9 @@ Compilation, the previous chapter}, Emacs can also optionally compile
Lisp function definitions into a true compiled code, known as
@dfn{native code}. This feature uses the @file{libgccjit} library,
which is part of the GCC distribution, and requires that Emacs be
-built with support for using that library. It also requires to have
-GCC and Binutils (the assembler and linker) available on your system
-for you to be able to native-compile Lisp code.
+built with support for using that library. It also requires GCC and
+Binutils (the assembler and linker) to be available on your system for
+you to be able to native-compile Lisp code.
@vindex native-compile@r{, a Lisp feature}
To determine whether the current Emacs process can produce and load
@@ -831,9 +765,9 @@ produced by earlier or later Emacs versions; native compilation of the
same Lisp code by a different Emacs version will usually produce a
natively-compiled library under a unique file name that only that
version of Emacs will be able to load. However, the use of unique
-file names allows to have in the same directory several versions of
-the same Lisp library natively-compiled by several different versions
-of Emacs.
+file names enables several versions of the same Lisp library
+natively-compiled by several different versions of Emacs to be placed
+within the same directory.
@vindex no-native-compile
A non-@code{nil} file-local variable binding of
diff --git a/doc/lispref/control.texi b/doc/lispref/control.texi
index 292086ee4e0..f9f3389c398 100644
--- a/doc/lispref/control.texi
+++ b/doc/lispref/control.texi
@@ -1,6 +1,6 @@
@c -*- mode: texinfo; coding: utf-8 -*-
@c This is part of the GNU Emacs Lisp Reference Manual.
-@c Copyright (C) 1990--1995, 1998--1999, 2001--2024 Free Software
+@c Copyright (C) 1990--2024 Free Software
@c Foundation, Inc.
@c See the file elisp.texi for copying conditions.
@node Control Structures
@@ -36,13 +36,14 @@ evaluated sequentially. You can use macros to define your own control
structure constructs (@pxref{Macros}).
@menu
-* Sequencing:: Evaluation in textual order.
-* Conditionals:: @code{if}, @code{cond}, @code{when}, @code{unless}.
-* Combining Conditions:: @code{and}, @code{or}, @code{not}, and friends.
+* Sequencing:: Evaluation in textual order.
+* Conditionals:: @code{if}, @code{cond}, @code{when}, @code{unless}.
+* Combining Conditions:: @code{and}, @code{or}, @code{not}, and friends.
* Pattern-Matching Conditional:: How to use @code{pcase} and friends.
-* Iteration:: @code{while} loops.
-* Generators:: Generic sequences and coroutines.
-* Nonlocal Exits:: Jumping out of a sequence.
+* Iteration:: @code{while} loops.
+* Generators:: Generic sequences and coroutines.
+* Nonlocal Exits:: Jumping out of a sequence.
+* Conditional Compilation:: A facility like C's #if.
@end menu
@node Sequencing
@@ -637,6 +638,16 @@ with @var{n} arguments (the other elements) and an additional
Example: @code{(= 42)}@*
In this example, the function is @code{=}, @var{n} is one, and
the actual function call becomes: @w{@code{(= 42 @var{expval})}}.
+
+@item function call with an @code{_} arg
+Call the function (the first element of the function call)
+with the specified arguments (the other elements) and replacing
+@code{_} with @var{expval}.
+
+Example: @code{(gethash _ memo-table)}
+In this example, the function is @code{gethash}, and
+the actual function call becomes: @w{@code{(gethash @var{expval}
+memo-table)}}.
@end table
@item (app @var{function} @var{pattern})
@@ -1285,11 +1296,11 @@ fail, @code{pcase} will immediately return @code{nil} without calling
@code{message}.
Extraction of multiple values stored in an object is known as
-@dfn{destructuring}. Using @code{pcase} patterns allows to perform
-@dfn{destructuring binding}, which is similar to a local binding
-(@pxref{Local Variables}), but gives values to multiple elements of
-a variable by extracting those values from an object of compatible
-structure.
+@dfn{destructuring}. Using @code{pcase} patterns allows you to
+perform @dfn{destructuring binding}, which is similar to a local
+binding (@pxref{Local Variables}), but gives values to multiple
+elements of a variable by extracting those values from an object of
+compatible structure.
The macros described in this section use @code{pcase} patterns to
perform destructuring binding. The condition of the object to be of
@@ -2292,6 +2303,123 @@ should be robust if one does occur. Note that this macro uses
@code{condition-case-unless-debug} rather than @code{condition-case}.
@end defmac
+Occasionally, we want to catch some errors and record some information
+about the conditions in which they occurred, such as the full
+backtrace, or the current buffer. This kinds of information is sadly
+not available in the handlers of a @code{condition-case} because the
+stack is unwound before running that handler, so the handler is run in
+the dynamic context of the @code{condition-case} rather than that of
+the place where the error was signaled. For those circumstances, you
+can use the following form:
+
+@defmac handler-bind handlers body@dots{}
+This special form runs @var{body} and if it executes without error,
+the value it returns becomes the value of the @code{handler-bind}
+form. In this case, the @code{handler-bind} has no effect.
+
+@var{handlers} should be a list of elements of the form
+@code{(@var{conditions} @var{handler})} where @var{conditions} is an
+error condition name to be handled, or a list of condition names, and
+@var{handler} should be a form whose evaluation should return a function.
+As with @code{condition-case}, condition names are symbols.
+
+Before running @var{body}, @code{handler-bind} evaluates all the
+@var{handler} forms and installs those handlers to be active during
+the evaluation of @var{body}. When an error is signaled,
+Emacs searches all the active @code{condition-case} and
+@code{handler-bind} forms for a handler that
+specifies one or more of these condition names. When the innermost
+matching handler is one installed by @code{handler-bind}, the
+@var{handler} function is called with a single argument holding the
+error description.
+
+Contrary to what happens with @code{condition-case}, @var{handler} is
+called in the dynamic context where the error happened. This means it
+is executed without unbinding any variable bindings or running any
+cleanups of @code{unwind-protect}, so that all those dynamic bindings
+are still in effect. There is one exception: while running the
+@var{handler} function, all the error handlers between the code that
+signaled the error and the @code{handler-bind} are temporarily
+suspended, meaning that when an error is signaled, Emacs will only
+search the active @code{condition-case} and @code{handler-bind} forms
+that are inside the @var{handler} function or outside of the current
+@code{handler-bind}. Note also that lexically-bound variables
+(@pxref{Lexical Binding}) are not affected, since they do not have
+dynamic extent.
+
+Like any normal function, @var{handler} can exit non-locally,
+typically via @code{throw}, or it can return normally.
+If @var{handler} returns normally, it means the handler
+@emph{declined} to handle the error and the search for an error
+handler is continued where it left off.
+
+For example, if we wanted to keep a log of all the errors that occur
+during the execution of a particular piece of code together with the
+buffer that's current when the error is signaled, but without
+otherwise affecting the behavior of that code, we can do it with:
+
+@example
+@group
+(handler-bind
+ ((error
+ (lambda (err)
+ (push (cons err (current-buffer)) my-log-of-errors))))
+ @var{body-forms}@dots{})
+@end group
+@end example
+
+This will log only those errors that are not caught internally to
+@var{body-forms}@dots{}, in other words errors that ``escape'' from
+@var{body-forms}@dots{}, and it will not prevent those errors from
+being passed on to surrounding @code{condition-case} handlers (or
+@code{handler-bind} handlers for that matter) since the above handler
+returns normally.
+
+We can also use @code{handler-bind} to replace an error with another,
+as in the code below which turns all errors of type @code{user-error}
+that occur during the execution of @var{body-forms}@dots{} into plain
+@code{error}:
+
+@example
+@group
+(handler-bind
+ ((user-error
+ (lambda (err)
+ (signal 'error (cdr err)))))
+ @var{body-forms}@dots{})
+@end group
+@end example
+
+We can get almost the same result with @code{condition-case}:
+
+@example
+@group
+(condition-case err
+ (progn @var{body-forms}@dots{})
+ (user-error (signal 'error (cdr err))))
+@end group
+@end example
+
+@noindent
+but with the difference that when we (re)signal the new error in
+@code{handler-bind}, the dynamic environment from the original error
+is still active, which means for example that if we enter the debugger
+at this point, it will show us a complete backtrace including the
+point where we signaled the original error:
+
+@example
+@group
+Debugger entered--Lisp error: (error "Oops")
+ signal(error ("Oops"))
+ (closure (t) (err) (signal 'error (cdr err)))((user-error "Oops"))
+ user-error("Oops")
+ @dots{}
+ eval((handler-bind ((user-error (lambda (err) @dots{}
+@end group
+@end example
+
+@end defmac
+
@node Error Symbols
@subsubsection Error Symbols and Condition Names
@cindex error symbol
@@ -2481,3 +2609,47 @@ quit, and the quit happens immediately after the function
@code{ftp-setup-buffer} returns but before the variable @code{process} is
set, the process will not be killed. There is no easy way to fix this bug,
but at least it is very unlikely.
+
+@node Conditional Compilation
+@section Conditional Compilation
+
+ There will be times when you want certain code to be compiled only
+when a certain condition holds. This is particularly the case when
+maintaining Emacs packages; to keep the package compatible with older
+versions of Emacs you may need to use a function or variable which has
+become obsolete in the current version of Emacs.
+
+ You could just use a conditional form to select the old or new form
+at run time, but this tends to output annoying warning messages about
+the obsolete function/variable. For such situations, the macro
+@code{static-if} comes in handy. It is patterned after the special
+form @code{if} (@pxref{Conditionals}).
+
+ To use this facility for an older version of Emacs, copy the source
+for @code{static-if} from the Emacs source file @file{lisp/subr.el}
+into your package.
+
+@defmac static-if condition then-form else-forms...
+Test @var{condition} at macro-expansion time. If its value is
+non-@code{nil}, expand the macro to @var{then-form}, otherwise expand
+it to @var{else-forms} enclosed in a @code{progn}. @var{else-forms}
+may be empty.
+
+Here is an example of its use from CC Mode, which prevents a
+@code{defadvice} form being compiled in newer versions of Emacs:
+@example
+@group
+(static-if (boundp 'comment-line-break-function)
+ (progn)
+ (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))))))
+@end group
+@end example
+@end defmac
diff --git a/doc/lispref/display.texi b/doc/lispref/display.texi
index c6b29e87b3a..b497967c445 100644
--- a/doc/lispref/display.texi
+++ b/doc/lispref/display.texi
@@ -1821,8 +1821,8 @@ where the @var{primary} value is used as described above, and
@var{secondary} is the fallback value used when @var{primary} and the
nesting considerations fail to resolve the precedence between
overlays. In particular, priority value @w{@code{(nil . @var{n})}},
-with @var{n} a positive integer, allows to have the overlays ordered
-by priority when necessary without completely overriding other
+with @var{n} a positive integer, enables you to have the overlays
+ordered by priority when necessary without completely overriding other
overlays.
Currently, all overlays take priority over text properties.
@@ -2942,8 +2942,9 @@ apply to. Here are the possible values of @var{characteristic}:
The kind of window system the terminal uses---either @code{graphic}
(any graphics-capable display), @code{x}, @code{pc} (for the MS-DOS
console), @code{w32} (for MS Windows 9X/NT/2K/XP), @code{haiku} (for
-Haiku), @code{pgtk} (for pure GTK), or @code{tty} (a non-graphics-capable
-display). @xref{Window Systems, window-system}.
+Haiku), @code{pgtk} (for pure GTK), @code{android} (for Android), or
+@code{tty} (a non-graphics-capable display). @xref{Window Systems,
+window-system}.
@item class
What kinds of colors the terminal supports---either @code{color},
@@ -4253,14 +4254,20 @@ key-attribute pairs may be omitted from the list if they are not
specified by @var{font}.
@end defun
-@defun font-xlfd-name font &optional fold-wildcards
+@defun font-xlfd-name font &optional fold-wildcards long-xlfds
This function returns the XLFD (X Logical Font Descriptor), a string,
matching @var{font}. @xref{Fonts,,, emacs, The GNU Emacs Manual}, for
-information about XLFDs. If the name is too long for an XLFD (which
-can contain at most 255 characters), the function returns @code{nil}.
+information about XLFDs.
If the optional argument @var{fold-wildcards} is non-@code{nil},
consecutive wildcards in the XLFD are folded into one.
+
+If the optional argument @var{long-xlfds} is omitted or @code{nil},
+then the function returns @code{nil} if the XLFD would exceed 255
+characters in length; this is for compatibility with the X protocol,
+which mandates that XLFDs are restricted to that length. If
+@var{long-xlfds} is non-@code{nil}, this restriction is lifted, and
+the function can return XLFDs of any length.
@end defun
The following two functions return important information about a font.
@@ -6049,6 +6056,30 @@ to make things match up, you should either specify @code{:scale 1.0}
when creating the image, or use the result of
@code{image-compute-scaling-factor} to compute the elements of the
map.
+
+When an image's @code{:scale}, @code{:rotation}, or @code{:flip} is
+changed, @code{:map} will be recomputed based on the value of
+@code{:original-map} and the values of those transformation.
+
+@item :original-map @var{original-map}
+@cindex original image map
+This specifies the untransformed image map which will be used to
+recompute @code{:map} after the image's @code{:scale}, @code{:rotation},
+or @code{:flip} is changed.
+
+If @code{:original-map} is not specified when creating an image with
+@code{create-image}, it will be computed based on the supplied
+@code{:map}, as well as any of @code{:scale}, @code{:rotation}, or
+@code{:flip} which are non-nil.
+
+Conversely, if @code{:original-map} is specified but @code{:map} is not,
+@code{:map} will be computed based on @code{:original-map},
+@code{:scale}, @code{:rotation}, and @code{:flip}.
+
+@defopt image-recompute-map-p
+Set this user option to nil to prevent Emacs from automatically
+recomputing an image @code{:map} based on its @code{:original-map}.
+@end defopt
@end table
@defun image-mask-p spec &optional frame
@@ -8729,8 +8760,8 @@ hexadecimal notation.
Display a box containing that string. The string should contain at
most 6 @acronym{ASCII} characters. As an exception, if the string
includes just one character, on text-mode terminals that character
-will be displayed without a box; this allows to handle such
-``acronyms'' as a replacement character for characters that cannot be
+will be displayed without a box; this enables treating such
+``acronyms'' as replacement characters for characters that cannot be
displayed by the terminal.
@item a cons cell @code{(@var{graphical} . @var{text})}
@@ -8879,6 +8910,8 @@ Emacs is displaying the frame using MS-DOS direct screen writes.
Emacs is displaying the frame using the Application Kit on Haiku.
@item pgtk
Emacs is displaying the frame using pure GTK facilities.
+@item android
+Emacs is displaying the frame on Android.
@item nil
Emacs is displaying the frame on a character-based terminal.
@end table
@@ -9024,7 +9057,7 @@ Bidirectionality'' class implementation of the @acronym{UBA},
consistent with the requirements of the Unicode Standard v9.0. Note,
however, that the way Emacs displays continuation lines when text
direction is opposite to the base paragraph direction deviates from
-the UBA, which requires to perform line wrapping before reordering
+the UBA, which requires performing line wrapping before reordering
text for display.
@defvar bidi-display-reordering
diff --git a/doc/lispref/edebug.texi b/doc/lispref/edebug.texi
index 40bf024d0f5..03fae67e528 100644
--- a/doc/lispref/edebug.texi
+++ b/doc/lispref/edebug.texi
@@ -1289,6 +1289,8 @@ examples):
@item sexp
A single unevaluated Lisp object, which is not instrumented.
@c an "expression" is not necessarily intended for evaluation.
+If the macro evaluates an argument at macro-expansion time, you should
+use @code{sexp} for it rather than @code{form}.
@item form
A single evaluated expression, which is instrumented. If your macro
diff --git a/doc/lispref/elisp.texi b/doc/lispref/elisp.texi
index dbff2080aa9..71139db4359 100644
--- a/doc/lispref/elisp.texi
+++ b/doc/lispref/elisp.texi
@@ -300,6 +300,7 @@ Lisp Data Types
* Type Predicates:: Tests related to types.
* Equality Predicates:: Tests of equality between any two objects.
* Mutability:: Some objects should not be modified.
+* Type Hierarchy:: Type Hierarchy of Emacs Lisp objects.
Programming Types
@@ -534,10 +535,10 @@ Variables
Scoping Rules for Variable Bindings
-* Dynamic Binding:: The default for binding local variables in Emacs.
+* Lexical Binding:: The standard type of local variable binding.
+* Dynamic Binding:: A different type of local variable binding.
* Dynamic Binding Tips:: Avoiding problems with dynamic binding.
-* Lexical Binding:: A different type of local variable binding.
-* Using Lexical Binding:: How to enable lexical binding.
+* Selecting Lisp Dialect:: How to select the Emacs Lisp dialect to use.
* Converting to Lexical Binding:: Convert existing code to lexical binding.
Buffer-Local Variables
@@ -653,7 +654,6 @@ Byte Compilation
* Speed of Byte-Code:: An example of speedup from byte compilation.
* Compilation Functions:: Byte compilation functions.
* Docs and Compilation:: Dynamic loading of documentation strings.
-* Dynamic Loading:: Dynamic loading of individual functions.
* Eval During Compile:: Code to be evaluated when you compile.
* Compiler Errors:: Handling compiler error messages.
* Byte-Code Objects:: The data type used for byte-compiled functions.
@@ -884,6 +884,7 @@ Major and Minor Modes
* Minor Modes:: Defining minor modes.
* Mode Line Format:: Customizing the text that appears in the mode line.
* Imenu:: Providing a menu of definitions made in a buffer.
+* Outline Minor Mode:: Outline mode to use with other major modes.
* Font Lock Mode:: How modes can highlight text according to syntax.
* Auto-Indentation:: How to teach Emacs to indent for a major mode.
* Desktop Save Mode:: How modes can have buffer state saved between
@@ -1139,6 +1140,7 @@ Frames
* Dialog Boxes:: Displaying a box to ask yes or no.
* Pointer Shape:: Specifying the shape of the mouse pointer.
* Window System Selections::Transferring text to and from other X clients.
+* Accessing Selections:: The multiple different kinds of selections.
* Yanking Media:: Yanking things that aren't plain text.
* Drag and Drop:: Internals of Drag-and-Drop implementation.
* Color Names:: Getting the definitions of color names.
diff --git a/doc/lispref/elisp_type_hierarchy.jpg b/doc/lispref/elisp_type_hierarchy.jpg
new file mode 100644
index 00000000000..386954e1007
--- /dev/null
+++ b/doc/lispref/elisp_type_hierarchy.jpg
Binary files differ
diff --git a/doc/lispref/elisp_type_hierarchy.txt b/doc/lispref/elisp_type_hierarchy.txt
new file mode 100644
index 00000000000..bb93cd831b9
--- /dev/null
+++ b/doc/lispref/elisp_type_hierarchy.txt
@@ -0,0 +1,33 @@
+| Type | Derived Types |
+|---------------------+-----------------------------------------------------------|
+| t | sequence atom |
+| atom | number-or-marker array record symbol function |
+| | window-configuration font-object font-entity mutex |
+| | tree-sitter-node buffer overlay tree-sitter-parser thread |
+| | font-spec native-comp-unit tree-sitter-compiled-query |
+| | terminal window frame hash-table user-ptr obarray condvar |
+| | process |
+| sequence | array list |
+| list | null cons |
+| function | oclosure compiled-function module-function |
+| | interpreted-function |
+| symbol | boolean symbol-with-pos keyword |
+| compiled-function | subr byte-code-function |
+| oclosure | accessor advice--forward cconv--interactive-helper |
+| | cl--generic-nnm advice save-some-buffers-function |
+| record | cl-structure-object |
+| cl-structure-object | cl--class lisp-indent-state cl--random-state registerv |
+| | xref-elisp-location isearch--state cl-slot-descriptor |
+| | cl--generic-generalizer uniquify-item cl--generic-method |
+| | register-preview-info cl--generic |
+| cons | ppss decoded-time |
+| array | vector string char-table bool-vector |
+| number-or-marker | number integer-or-marker |
+| integer-or-marker | integer marker |
+| number | integer float |
+| cl--class | built-in-class cl-structure-class oclosure--class |
+| subr | subr-native-elisp subr-primitive |
+| accessor | oclosure-accessor |
+| vector | timer |
+| boolean | null |
+| integer | fixnum bignum |
diff --git a/doc/lispref/eval.texi b/doc/lispref/eval.texi
index a65b2346300..b42020f43af 100644
--- a/doc/lispref/eval.texi
+++ b/doc/lispref/eval.texi
@@ -252,11 +252,8 @@ the original symbol. If the contents are another symbol, this
process, called @dfn{symbol function indirection}, is repeated until
it obtains a non-symbol. @xref{Function Names}, for more information
about symbol function indirection.
-
- One possible consequence of this process is an infinite loop, in the
-event that a symbol's function cell refers to the same symbol.
-Otherwise, we eventually obtain a non-symbol, which ought to be a
-function or other suitable object.
+We eventually obtain a non-symbol, which ought to be a function or
+other suitable object.
@kindex invalid-function
More precisely, we should now have a Lisp function (a lambda
@@ -332,19 +329,17 @@ or just
The built-in function @code{indirect-function} provides an easy way to
perform symbol function indirection explicitly.
-@defun indirect-function function &optional noerror
+@defun indirect-function function
@anchor{Definition of indirect-function}
This function returns the meaning of @var{function} as a function. If
@var{function} is a symbol, then it finds @var{function}'s function
definition and starts over with that value. If @var{function} is not a
symbol, then it returns @var{function} itself.
-This function returns @code{nil} if the final symbol is unbound. It
-signals a @code{cyclic-function-indirection} error if there is a loop
-in the chain of symbols.
+This function returns @code{nil} if the final symbol is unbound.
-The optional argument @var{noerror} is obsolete, kept for backward
-compatibility, and has no effect.
+There is also a second, optional argument that is obsolete and has no
+effect.
Here is how you could define @code{indirect-function} in Lisp:
@@ -745,13 +740,17 @@ type of the @var{form} object determines how it is evaluated.
@xref{Forms}.
The argument @var{lexical} specifies the scoping rule for local
-variables (@pxref{Variable Scoping}). If it is omitted or @code{nil},
-that means to evaluate @var{form} using the default dynamic scoping
-rule. If it is @code{t}, that means to use the lexical scoping rule.
-The value of @var{lexical} can also be a non-empty alist specifying a
+variables (@pxref{Variable Scoping}). If it is @code{t}, that means
+to evaluate @var{form} using lexical scoping; this is the recommended
+value. If it is omitted or @code{nil}, that means to use the old
+dynamic-only variable scoping rule.
+
+The value of @var{lexical} can also be a non-empty list specifying a
particular @dfn{lexical environment} for lexical bindings; however,
this feature is only useful for specialized purposes, such as in Emacs
-Lisp debuggers. @xref{Lexical Binding}.
+Lisp debuggers. Each member of the list is either a cons cell which
+represents a lexical symbol-value pair, or a symbol representing a
+(special) variable that would use dynamic scoping if bound.
Since @code{eval} is a function, the argument expression that appears
in a call to @code{eval} is evaluated twice: once as preparation before
@@ -845,11 +844,24 @@ function body forms, as well as explicit calls in Lisp code.
The default value of this variable is 1600. If you set it to a value
less than 100, Lisp will reset it to 100 if the given value is
-reached. Entry to the Lisp debugger increases the value, if there is
-little room left, to make sure the debugger itself has room to
-execute.
+reached.
@end defopt
+@defopt lisp-eval-depth-reserve
+In order to be able to debug infinite recursion errors, when invoking the
+Lisp debugger, Emacs increases temporarily the value of
+@code{max-lisp-eval-depth}, if there is little room left, to make sure
+the debugger itself has room to execute. The same happens when
+running the handler of a @code{handler-bind}. @xref{Handling Errors}.
+
+The variable @code{lisp-eval-depth-reserve} bounds the extra depth
+that Emacs can add to @code{max-lisp-eval-depth} for those
+exceptional circumstances.
+
+The default value of this variable is 200.
+@end defopt
+
+
@defvar values
The value of this variable is a list of the values returned by all the
expressions that were read, evaluated, and printed from buffers
diff --git a/doc/lispref/files.texi b/doc/lispref/files.texi
index fd4b9a7bc5f..9e7aeeecec8 100644
--- a/doc/lispref/files.texi
+++ b/doc/lispref/files.texi
@@ -582,11 +582,12 @@ contents and inserting the whole file, because (1) it preserves some
marker positions and (2) it puts less data in the undo list.
It is possible to read a special file (such as a FIFO or an I/O
-device) with @code{insert-file-contents}, as long as @var{replace},
-and @var{visit} and @var{beg} are @code{nil}. However, you should
-normally use an @var{end} argument for these files to avoid inserting
-(potentially) unlimited data into the buffer (for instance, when
-inserting data from @file{/dev/urandom}).
+device) with @code{insert-file-contents}, as long as @var{replace} is
+@code{nil} or @code{if-regular}, and @var{visit} and @var{beg} are
+@code{nil}. However, you should normally use an @var{end} argument
+for these files to avoid inserting (potentially) unlimited data into
+the buffer (for instance, when inserting data from
+@file{/dev/urandom}).
@end defun
@defun insert-file-contents-literally filename &optional visit beg end replace
@@ -692,11 +693,9 @@ files that the user does not need to know about.
@defvar write-region-inhibit-fsync
If this variable's value is @code{nil}, @code{write-region} uses the
-@code{fsync} system call after writing a file. Although this slows
-Emacs down, it lessens the risk of data loss after power failure. If
-the value is @code{t}, Emacs does not use @code{fsync}. The default
-value is @code{nil} when Emacs is interactive, and @code{t} when Emacs
-runs in batch mode. @xref{Files and Storage}.
+@code{fsync} system call after writing a file. If the value is
+@code{t}, Emacs does not use @code{fsync}. The default value is
+@code{t}. @xref{Files and Storage}.
@end defvar
@defmac with-temp-file file body@dots{}
@@ -971,9 +970,16 @@ guaranteed to be writable.
@end defmac
@defun access-file filename string
+@vindex remote-file-name-access-timeout
If you can read @var{filename} this function returns @code{nil};
otherwise it signals an error
using @var{string} as the error message text.
+
+If the user option @code{remote-file-name-access-timeout} is a
+positive number, the function signals an error when it doesn't finish
+after that time (in seconds). This applies only to remote files, and
+only when there is no additional time spent while reading passwords or
+alike.
@end defun
@defun file-ownership-preserved-p filename &optional group
@@ -1880,6 +1886,11 @@ no prefix argument is given, and @code{nil} otherwise.
See also @code{delete-directory} in @ref{Create/Delete Dirs}.
@end deffn
+@defopt remote-file-name-inhibit-delete-by-moving-to-trash
+If this variable is non-@code{nil}, remote files are never moved to
+the Trash. They are deleted instead.
+@end defopt
+
@cindex file permissions, setting
@cindex permissions, file
@cindex file modes, setting
@@ -2049,17 +2060,28 @@ data already stored elsewhere on secondary storage until one file or
the other is later modified; this will lose both files if the only
copy on secondary storage is lost due to media failure. Second, the
operating system might not write data to secondary storage
-immediately, which will lose the data if power is lost.
+immediately, which will lose the data if power is lost
+or if there is a media failure.
@findex write-region
Although both sorts of failures can largely be avoided by a suitably
-configured file system, such systems are typically more expensive or
-less efficient. In more-typical systems, to survive media failure you
+configured system, such systems are typically more expensive or
+less efficient. In lower-end systems, to survive media failure you
can copy the file to a different device, and to survive a power
-failure you can use the @code{write-region} function with the
+failure (or be immediately notified of a media failure) you can use
+the @code{write-region} function with the
@code{write-region-inhibit-fsync} variable set to @code{nil}.
+Although this variable is ordinarily @code{t} because that can
+significantly improve performance, it may make sense to temporarily
+bind it to @code{nil} if using Emacs to implement database-like
+transactions that survive power failure on lower-end systems.
@xref{Writing to Files}.
+On some platforms when Emacs changes a file other processes might not
+be notified of the change immediately. Setting
+@code{write-region-inhibit-fsync} to @code{nil} may improve
+notification speed in this case, though there are no guarantees.
+
@node File Names
@section File Names
@cindex file names
@@ -3377,7 +3399,7 @@ first, before handlers for jobs such as remote file access.
@code{file-directory-p},
@code{file-equal-p},
@code{file-executable-p}, @code{file-exists-p},
-@code{file-in-directory-p},
+@code{file-group-gid}, @code{file-in-directory-p},
@code{file-local-copy}, @code{file-locked-p},
@code{file-modes}, @code{file-name-all-completions},
@code{file-name-as-directory},
@@ -3392,7 +3414,8 @@ first, before handlers for jobs such as remote file access.
@code{file-readable-p}, @code{file-regular-p},
@code{file-remote-p}, @code{file-selinux-context},
@code{file-symlink-p}, @code{file-system-info},
-@code{file-truename}, @code{file-writable-p},
+@code{file-truename}, @code{file-user-uid},
+@code{file-writable-p},
@code{find-backup-file-name},@*
@code{get-file-buffer},
@code{insert-directory},
@@ -3438,7 +3461,7 @@ first, before handlers for jobs such as remote file access.
@code{file-direc@discretionary{}{}{}tory-p},
@code{file-equal-p},
@code{file-executable-p}, @code{file-exists-p},
-@code{file-in-directory-p},
+@code{file-group-gid}, @code{file-in-directory-p},
@code{file-local-copy}, @code{file-locked-p},
@code{file-modes}, @code{file-name-all-completions},
@code{file-name-as-directory},
@@ -3453,7 +3476,8 @@ first, before handlers for jobs such as remote file access.
@code{file-readable-p}, @code{file-regular-p},
@code{file-remote-p}, @code{file-selinux-context},
@code{file-symlink-p}, @code{file-system-info},
-@code{file-truename}, @code{file-writable-p},
+@code{file-truename}, @code{file-user-uid},
+@code{file-writable-p},
@code{find-backup-file-name},
@code{get-file-buffer},
@code{insert-directory},
@@ -3608,7 +3632,11 @@ be @code{root}.
If @var{connected} is non-@code{nil}, this function returns @code{nil}
even if @var{filename} is remote, if Emacs has no network connection
to its host. This is useful when you want to avoid the delay of
-making connections when they don't exist.
+making connections when they don't exist. If @var{connected} is
+@code{never}, @emph{never} use an existing connection to return the
+identification, even if one is already present (this is otherwise like
+a value of @code{nil}). This lets you prevent any connection-specific
+logic, such as expanding the local part of the file name.
@end defun
@defun unhandled-file-name-directory filename
@@ -3672,6 +3700,17 @@ between consecutive checks. For example:
@end example
@end defopt
+@defmac without-remote-files body@dots{}
+The @code{without-remote-files} macro evaluates the @var{body} forms
+with deactivated file name handlers for remote files. Those file
+names would be handled literally.
+
+The macro should be used only in forms where it is obvious, that
+remote files cannot appear or where it is intended not to handle
+remote file names. It also reduces checks with
+@code{file-name-handler-alist}, resulting in more performant code.
+@end defmac
+
@node Format Conversion
@section File Format Conversion
diff --git a/doc/lispref/frames.texi b/doc/lispref/frames.texi
index dc38f90ed74..cf7fc7721c5 100644
--- a/doc/lispref/frames.texi
+++ b/doc/lispref/frames.texi
@@ -60,8 +60,12 @@ The frame is displayed on a GNUstep or Macintosh Cocoa graphical
terminal.
@item pc
The frame is displayed on an MS-DOS terminal.
+@item haiku
+The frame is displayed using the Haiku Application Kit.
@item pgtk
The frame is displayed using pure GTK facilities.
+@item android
+The frame is displayed on an Android device.
@end table
@end defun
@@ -104,9 +108,11 @@ window of another Emacs frame. @xref{Child Frames}.
* Mouse Tracking:: Getting events that say when the mouse moves.
* Mouse Position:: Asking where the mouse is, or moving it.
* Pop-Up Menus:: Displaying a menu for the user to select from.
+* On-Screen Keyboards:: Displaying the virtual keyboard.
* Dialog Boxes:: Displaying a box to ask yes or no.
* Pointer Shape:: Specifying the shape of the mouse pointer.
* Window System Selections:: Transferring text to and from other X clients.
+* Accessing Selections:: The multiple different kinds of selections.
* Yanking Media:: Yanking things that aren't plain text.
* Drag and Drop:: Internals of Drag-and-Drop implementation.
* Color Names:: Getting the definitions of color names.
@@ -222,8 +228,8 @@ The terminal and keyboard coding systems used on the terminal.
@item
The kind of display associated with the terminal. This is the symbol
returned by the function @code{terminal-live-p} (i.e., @code{x},
-@code{t}, @code{w32}, @code{ns}, @code{pc}, @code{haiku}, or @code{pgtk}).
-@xref{Frames}.
+@code{t}, @code{w32}, @code{ns}, @code{pc}, @code{haiku}, @code{pgtk},
+or @code{android}). @xref{Frames}.
@item
A list of terminal parameters. @xref{Terminal Parameters}.
@@ -527,7 +533,8 @@ Height | | | Height | | | Height
| | | |<--+--- Inner Frame Width ------->| | | |
| | | | | | | | |
| | | |___v______________________________| | | |
- | | |___________ Internal Border __________| | v
+ | | |___________ Internal Border __________| | |
+ | | (4)__________ Bottom Tool Bar __________| | v
v |___________ External/Outer Border __________|
<-------- Native Frame Width -------->
@@ -603,7 +610,7 @@ frames (@pxref{Child Frames}) and @code{undecorated} or
Outer borders are never shown on text terminal frames and on frames
generated by GTK+ routines. On MS-Windows, the outer border is emulated
with the help of a one pixel wide external border. Non-toolkit builds
-on X allow to change the color of the outer border by setting the
+on X allow changing the color of the outer border by setting the
@code{border-color} frame parameter (@pxref{Layout Parameters}).
@item Title Bar
@@ -699,7 +706,7 @@ The position of the top left corner of the native frame specifies the
indicate that position for the various builds:
@itemize @w{}
-@item (1) non-toolkit, Haiku, and terminal frames
+@item (1) non-toolkit, Android, Haiku, and terminal frames
@item (2) Lucid, Motif, and MS-Windows frames
@@ -711,6 +718,10 @@ tool bar but not that of the menu bar (Lucid, Motif, MS-Windows) or
those of the menu bar and the tool bar (non-toolkit and text terminal
frames).
+If the native position would otherwise be (2), but the tool bar is
+placed at the bottom of the frame as depicted in (4), the native
+position of the frame becomes that of the tab bar.
+
The native position of a frame is the reference position for functions
that set or return the current position of the mouse (@pxref{Mouse
Position}) and for functions dealing with the position of windows like
@@ -848,8 +859,11 @@ native frame of @var{frame}).
@item tool-bar-position
This tells on which side the tool bar on @var{frame} is and can be one
-of @code{left}, @code{top}, @code{right} or @code{bottom}. The only
-toolkit that currently supports a value other than @code{top} is GTK+.
+of @code{left}, @code{top}, @code{right} or @code{bottom}.
+
+The values @code{left} and @code{right} are only supported on builds
+using the GTK+ toolkit; @code{bottom} is supported on all builds other
+than NS, and @code{top} is supported everywhere.
@item tool-bar-size
A cons of the width and height of the tool bar of @var{frame}.
@@ -990,12 +1004,12 @@ Negative parameter values position the right edge of the outer frame by
frame's native rectangle) and the bottom edge by @var{-y} pixels up from
the bottom edge of the screen (or the parent frame's native rectangle).
-Note that negative values do not permit to align the right or bottom
+Note that negative values do not permit aligning the right or bottom
edge of @var{frame} exactly at the right or bottom edge of its display
-or parent frame. Neither do they allow to specify a position that does
+or parent frame. Neither do they allow specifying a position that does
not lie within the edges of the display or parent frame. The frame
parameters @code{left} and @code{top} (@pxref{Position Parameters})
-allow to do that, but may still fail to provide good results for the
+allow doing that, but may still fail to provide good results for the
initial or a new frame.
This function has no effect on text terminal frames.
@@ -1732,7 +1746,7 @@ Geometry}) of the frame, in characters. Normally, the functions that
establish a frame's initial width or resize a frame horizontally make
sure that all the frame's windows, vertical scroll bars, fringes,
margins and vertical dividers can be displayed. This parameter, if
-non-@code{nil} allows to make a frame narrower than that with the
+non-@code{nil} enables making a frame narrower than that with the
consequence that any components that do not fit will be clipped by the
window manager.
@@ -1743,7 +1757,7 @@ Geometry}) of the frame, in characters. Normally, the functions that
establish a frame's initial size or resize a frame make sure that all
the frame's windows, horizontal scroll bars and dividers, mode and
header lines, the echo area and the internal menu and tool bar can be
-displayed. This parameter, if non-@code{nil} allows to make a frame
+displayed. This parameter, if non-@code{nil} enables making a frame
smaller than that with the consequence that any components that do not
fit will be clipped by the window manager.
@@ -1804,14 +1818,14 @@ the first time.
@vindex fit-frame-to-buffer-margins@r{, a frame parameter}
@item fit-frame-to-buffer-margins
-This parameter allows to override the value of the option
-@code{fit-frame-to-buffer-margins} when fitting this frame to the buffer
-of its root window with @code{fit-frame-to-buffer} (@pxref{Resizing
-Windows}).
+This parameter enables overriding the value of the option
+@code{fit-frame-to-buffer-margins} when fitting this frame to the
+buffer of its root window with @code{fit-frame-to-buffer}
+(@pxref{Resizing Windows}).
@vindex fit-frame-to-buffer-sizes@r{, a frame parameter}
@item fit-frame-to-buffer-sizes
-This parameter allows to override the value of the option
+This parameter enables overriding the value of the option
@code{fit-frame-to-buffer-sizes} when fitting this frame to the buffer
of its root window with @code{fit-frame-to-buffer} (@pxref{Resizing
Windows}).
@@ -1892,13 +1906,13 @@ to not draw bottom dividers.
@vindex menu-bar-lines@r{, a frame parameter}
@item menu-bar-lines
The number of lines to allocate at the top of the frame for a menu bar
-(@pxref{Menu Bar}). The default is one if Menu Bar mode is enabled and
-zero otherwise. @xref{Menu Bars,,,emacs, The GNU Emacs Manual}. For an
-external menu bar (@pxref{Frame Layout}), this value remains unchanged
-even when the menu bar wraps to two or more lines. In that case, the
-@code{menu-bar-size} value returned by @code{frame-geometry}
-(@pxref{Frame Geometry}) allows to derive whether the menu bar actually
-occupies one or more lines.
+(@pxref{Menu Bar}). The default is one if Menu Bar mode is enabled
+and zero otherwise. @xref{Menu Bars,,,emacs, The GNU Emacs Manual}.
+For an external menu bar (@pxref{Frame Layout}), this value remains
+unchanged even when the menu bar wraps to two or more lines. In that
+case, the @code{menu-bar-size} value returned by @code{frame-geometry}
+(@pxref{Frame Geometry}) enables you to establish whether the menu bar
+actually occupies one or more lines.
@vindex tool-bar-lines@r{, a frame parameter}
@item tool-bar-lines
@@ -1909,9 +1923,11 @@ whenever the tool bar wraps (@pxref{Frame Layout}).
@vindex tool-bar-position@r{, a frame parameter}
@item tool-bar-position
-The position of the tool bar when Emacs was built with GTK+. Its value
-can be one of @code{top}, @code{bottom} @code{left}, @code{right}. The
-default is @code{top}.
+The position of the tool bar. Its value can be one of @code{top},
+@code{bottom} @code{left}, @code{right}. The default is @code{top}.
+
+It can be set to @code{bottom} on Emacs built with any toolkit other
+than Nextstep, and @code{left} or @code{right} on builds using GTK+.
@vindex tab-bar-lines@r{, a frame parameter}
@item tab-bar-lines
@@ -2207,8 +2223,10 @@ resource must also be set to the string @code{"extended"}.
@item inhibit-double-buffering
If non-@code{nil}, the frame is drawn to the screen without double
buffering. Emacs normally attempts to use double buffering, where
-available, to reduce flicker. Set this property if you experience
-display bugs or pine for that retro, flicker-y feeling.
+available, to reduce flicker; nevertheless, this parameter is provided
+for circumstances where double-buffering induces display corruption,
+and for those eccentrics wistful for the immemorial flicker that once
+beset Emacs.
@vindex skip-taskbar@r{, a frame parameter}
@item skip-taskbar
@@ -2398,6 +2416,7 @@ engine), and @code{harfbuzz} (font driver for OTF and TTF fonts with
HarfBuzz text shaping) (@pxref{Windows Fonts,,, emacs, The GNU Emacs
Manual}). The @code{harfbuzz} driver is similarly recommended. On
Haiku, there can be several font drivers (@pxref{Haiku Fonts,,, emacs,
+The GNU Emacs Manual}), as on Android (@pxref{Android Fonts,,, emacs,
The GNU Emacs Manual}).
On other systems, there is only one available font backend, so it does
@@ -3420,15 +3439,15 @@ parameter indicates the number of pixels where the frame @dfn{snaps} at
the respective edge or corner of its parent frame.
There are two ways to drag an entire child frame with the mouse: The
-@code{drag-with-mode-line} parameter, if non-@code{nil}, allows to drag
-a frame without minibuffer window (@pxref{Minibuffer Windows}) via the
-mode line area of its bottommost window. The
-@code{drag-with-header-line} parameter, if non-@code{nil}, allows to
-drag the frame via the header line area of its topmost window.
+@code{drag-with-mode-line} parameter, if non-@code{nil}, enables
+dragging a frame without minibuffer window (@pxref{Minibuffer
+Windows}) via the mode line area of its bottommost window. The
+@code{drag-with-header-line} parameter, if non-@code{nil}, enables
+dragging the frame via the header line area of its topmost window.
In order to give a child frame a draggable header or mode line, the
window parameters @code{mode-line-format} and @code{header-line-format}
-are handy (@pxref{Window Parameters}). These allow to remove an
+are handy (@pxref{Window Parameters}). These allow removing an
unwanted mode line (when @code{drag-with-header-line} is chosen) and to
remove mouse-sensitive areas which might interfere with frame dragging.
@@ -3743,9 +3762,9 @@ This function displays a pop-up menu and returns an indication of
what selection the user makes.
The argument @var{position} specifies where on the screen to put the
-top left corner of the menu. It can be either a mouse button event
-(which says to put the menu where the user actuated the button) or a
-list of this form:
+top left corner of the menu. It can be either a mouse button or
+@code{touchscreen-begin} event (which says to put the menu where the
+user actuated the button) or a list of this form:
@example
((@var{xoffset} @var{yoffset}) @var{window})
@@ -3830,6 +3849,30 @@ keymap. It won't be called if @code{x-popup-menu} returns for some
other reason without displaying a pop-up menu.
@end defvar
+@node On-Screen Keyboards
+@section On-Screen Keyboards
+
+ An on-screen keyboard is a special kind of pop up provided by the
+system, with rows of clickable buttons that act as a real keyboard.
+
+ On certain systems (@pxref{On-Screen Keyboards,,,emacs, The Emacs
+Manual}), Emacs is supposed to display and hide the on screen keyboard
+depending on whether or not the user is about to type something.
+
+@defun frame-toggle-on-screen-keyboard frame hide
+This function displays or hides the on-screen keyboard on behalf of
+the frame @var{frame}. If @var{hide} is non-@code{nil}, then the
+on-screen keyboard is hidden; otherwise, it is displayed.
+
+It returns whether or not the on screen keyboard @strong{may} have
+been displayed, which should be used to determine whether or not to
+hide the on-screen keyboard later.
+
+This has no effect if the system automatically detects when to display
+the on-screen keyboard, or when it does not provide any on-screen
+keyboard.
+@end defun
+
@node Dialog Boxes
@section Dialog Boxes
@cindex dialog boxes
@@ -3964,22 +4007,24 @@ defined in the file @file{lisp/term/x-win.el}. Use @kbd{M-x apropos
@cindex secondary selection
In window systems, such as X, data can be transferred between
-different applications by means of @dfn{selections}. X defines an
-arbitrary number of @dfn{selection types}, each of which can store its
-own data; however, only three are commonly used: the @dfn{clipboard},
-@dfn{primary selection}, and @dfn{secondary selection}. Other window
-systems support only the clipboard. @xref{Cut and Paste,, Cut and
-Paste, emacs, The GNU Emacs Manual}, for Emacs commands that make use
-of these selections. This section documents the low-level functions
-for reading and setting window-system selections.
+different applications by means of @dfn{selections}. Each window
+system defines an arbitrary number of @dfn{selection types}, all
+storing their own data; however, only three are commonly used: the
+@dfn{clipboard}, @dfn{primary selection}, and @dfn{secondary
+selection}. @xref{Cut and Paste,, Cut and Paste, emacs, The GNU Emacs
+Manual}, for Emacs commands that make use of these selections. This
+section documents the low-level functions for reading and setting
+window-system selections; @xref{Accessing Selections}, for
+documentation concerning selection types and data formats under
+particular window systems.
@deffn Command gui-set-selection type data
This function sets a window-system selection. It takes two arguments:
a selection type @var{type}, and the value to assign to it, @var{data}.
@var{type} should be a symbol; it is usually one of @code{PRIMARY},
-@code{SECONDARY} or @code{CLIPBOARD}. These are symbols with
-upper-case names, in accord with X Window System conventions. If
+@code{SECONDARY} or @code{CLIPBOARD}. These are generally symbols
+with 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.
@@ -4007,157 +4052,823 @@ programs. It takes two optional arguments, @var{type} and
The @var{data-type} argument specifies the form of data conversion to
use, to convert the raw data obtained from another program into Lisp
-data. Meaningful values include @code{TEXT}, @code{STRING},
-@code{UTF8_STRING}, @code{TARGETS}, @code{LENGTH}, @code{DELETE},
-@code{FILE_NAME}, @code{CHARACTER_POSITION}, @code{NAME},
-@code{LINE_NUMBER}, @code{COLUMN_NUMBER}, @code{OWNER_OS},
-@code{HOST_NAME}, @code{USER}, @code{CLASS}, @code{ATOM}, and
-@code{INTEGER}. (These are symbols with upper-case names in accord
-with X conventions.) The default for @var{data-type} is
-@code{STRING}. Window systems other than X usually support only a
-small subset of these types, in addition to @code{STRING}.
+data. @xref{X Selections}, for an enumeration of data types valid under
+X, and @pxref{Other Selections} for those elsewhere.
@end defun
@defopt selection-coding-system
-This variable specifies the coding system to use when reading and
-writing selections or the clipboard. @xref{Coding
-Systems}. The default is @code{compound-text-with-extensions}, which
-converts to the text representation that X11 normally uses.
+This variable provides a coding system (@pxref{Coding Systems}) which
+is used to encode selection data, and takes effect on MS-Windows and
+X@. It is also used in the MS-DOS port when it runs on MS-Windows and
+can access the Windows clipboard text.
+
+On X, the value of this variable provides the coding system which
+@code{gui-get-selection} will use to decode selection data for a
+subset of text data types, and also forces replies to selection
+requests for the polymorphic @code{TEXT} data type to be encoded by
+the @code{compound-text-with-extensions} coding system rather than
+Unicode.
+
+On MS-Windows, this variable is generally ignored, as the MS-Windows
+clipboard provides the information about decoding as part of the
+clipboard data, and uses either UTF-16 or locale-specific encoding
+automatically as appropriate. We recommend to set the value of this
+variable only on the older Windows 9X, as it is otherwise used only in
+the very rare cases when the information provided by the clipboard
+data is unusable for some reason.
+
+The default value of this variable is the system code page under
+MS-Windows 95, 98 or Me, @code{utf-16le-dos} on Windows
+NT/W2K/XP/Vista/7/8/10/11, @code{iso-latin-1-dos} on MS-DOS, and
+@code{nil} elsewhere.
@end defopt
-@cindex clipboard support (for MS-Windows)
-When Emacs runs on MS-Windows, it does not implement X selections in
-general, but it does support the clipboard. @code{gui-get-selection}
-and @code{gui-set-selection} on MS-Windows support the text data type
-only; if the clipboard holds other types of data, Emacs treats the
-clipboard as empty. The supported data type is @code{STRING}.
-
For backward compatibility, there are obsolete aliases
@code{x-get-selection} and @code{x-set-selection}, which were the
names of @code{gui-get-selection} and @code{gui-set-selection} before
Emacs 25.1.
+@node Accessing Selections
+@section Accessing Selections
+
+ The data types and selections that @code{gui-get-selection} and
+@code{gui-set-selection} understand are not precisely specified and
+differ subject to the window system on which Emacs is running.
+
+ At the same time, @code{gui-set-selection} abstracts over plenty of
+complexity: its @var{data} argument is given verbatim to
+system-specific code to be rendered suitable for transfer to the
+window system or requesting clients.
+
+ The most comprehensive implementation of selections exists under the
+X Window System. This is both an artifact of history (X was the first
+window system supported by Emacs) and one occasioned by technical
+considerations: X selections are not merely an expedient for the
+transfer of text and multimedia content between clients, but a general
+inter-client communication system, a design that has yielded a
+proliferation of selection and data types.
+
+ Compounding this confusion, there is another inter-client
+communication mechanism under X: the Inter-Client Exchange. ICE is
+only used by Emacs to communicate with session managers, and is a
+separate topic.
+
+@menu
+* X Selections:: Selection data types (and more) on X@.
+* Other Selections:: How they work on other window systems.
+@end menu
+
+@node X Selections
+@subsection X Selections
+
+ X refrains from defining fixed data types for selection data or a
+fixed number of selections. Selections are identified by X ``atoms'',
+which are unique 29-bit identifiers issued by the X server for string
+names. This complexity is hidden by Emacs: when Lisp provides a
+symbol whose name is that of the atom, Emacs will request these
+identifiers without further intervention.
+
+ When a program ``sets'' a selection under X, it actually makes
+itself the ``owner'' of the selection---the X server will then deliver
+selection requests to the program, which is obliged to respond to the
+requesting client with the selection data.
+
+ Similarly, a program does not ``get'' selection data from the X
+server. Instead, its selection requests are sent to the client with
+the window which last asserted ownership over the selection, which is
+expected to respond with the requested data.
+
+ Each selection request incorporates three parameters:
+
+@itemize @bullet
+@item
+The window which requested the selection, which identifies the
+@c Not a typo: X spells ``requestor'' with an o.
+requesting program, otherwise known as the @dfn{requestor}.
+
+@item
+An atom identifying the @dfn{target} to which the owner should convert
+the selection. It is easiest to think of the conversion target as the
+kind of data that the requestor wants: in selection requests made by
+Emacs, the target is determined by the @var{type} argument to
+@code{gui-get-selection}.
+
+@item
+A 32-bit timestamp representing the X server time at which the
+requestor last received input; this parameter is not relevant to Lisp
+code, for it's only meant to abet synchronization between the X
+server, owner and requestor.
+@end itemize
+
+ The selection owner responds by transferring to the requestor a
+series of bytes, 16 bit words, or 32 bit words, along with another
+atom identifying the type of those words. After requesting a
+selection, Emacs then applies its own interpretation of the data
+format and data type to convert the data transferred by the selection
+owner to a Lisp representation, which @code{gui-get-selection}
+returns.
+
+ Emacs converts selection data consisting of any series of bytes to a
+unibyte string holding those bytes, that consisting of a single 16-bit
+or 32-bit word as an unsigned number, and that consisting of multiple
+such words as a vector of unsigned numbers. The exceptions to this
+general pattern are that Emacs applies special treatment for data from
+the following conversion targets:
+
+@table @code
+@item INTEGER
+16-bit or 32-bit words of this type are treated as signed rather than
+unsigned integers. If there are multiple words in the selection data,
+a vector is returned; otherwise, the integer is returned by itself.
+
+@item ATOM
+32-bit words of this type are treated as X atoms, and returned (either
+alone or as vectors) as Lisp symbols by the names they identify.
+Invalid atoms are replaced by @code{nil}.
+
+@item COMPOUND_TEXT
+@item UTF8_STRING
+@item STRING
+A single @code{foreign-selection} text property set to the type of the
+selection data will be placed in unibyte strings derived from a
+request for these data types.
+@end table
+
+ Each selection owner must return at least two selection targets:
+@code{TARGETS}, which returns a number of atoms describing the
+selection targets that the owner supports, and @code{MULTIPLE}, used
+for internal purposes by X clients. A selection owner may support any
+number of other targets, some of which may be standardized by the X
+Consortium's
+@url{http://x.org/releases/X11R7.6/doc/xorg-docs/specs/ICCCM/icccm.html,
+Inter-Client Communication Conventions Manual}, while others, such as
+@code{UTF8_STRING}, were meant to be standardized by the XFree86
+Project, but their standardization was never completed.
+
+ Requests for a given selection target may, by convention, return
+data in a specific type, or it may return data in one of several
+types, whichever is most convenient for the selection owner; the
+latter type of selection target is dubbed a @dfn{polymorphic target}.
+In response to a request, a selection target may also return no data
+at all, whereafter the selection owner executes some action as a side
+effect. Targets that are thus replied to are termed @dfn{side-effect
+targets}.
+
+ Here are some selection targets whose behavior is generally
+consistent with a standard when requested from the @code{CLIPBOARD},
+@code{PRIMARY}, or @code{SECONDARY} selections.
+
+@table @code
+@item ADOBE_PORTABLE_DOCUMENT_FORMAT
+This target returns data in Adobe System's ``Portable Document
+Format'' format, as a string.
+
+@item APPLE_PICT
+This target returns data in the ``PICT'' image format used on
+Macintosh computers, as a string.
+
+@item BACKGROUND
+@item BITMAP
+@item COLORMAP
+@item FOREGROUND
+Together, these four targets return integer data necessary to make use
+of a bitmap image stored on the X server: the pixel value of the
+bitmap's background color, the X identifier of the bitmap, the
+colormap inside which the background and foreground are allocated, and
+the pixel value of the bitmap's foreground color.
+
+@item CHARACTER_POSITION
+This target returns two unsigned 32-bit integers of type @code{SPAN}
+describing the start and end positions of the selection data in the
+text field containing it, in bytes.
+
+@item COMPOUND_TEXT
+This target returns a string of type @code{COMPOUND_TEXT} in the X
+Consortium's multi-byte text encoding system.
+
+@item DELETE
+This target returns nothing, but as a side-effect deletes the
+selection contents from any text field containing them.
+
+@item DRAWABLE
+@item PIXMAP
+This target returns a list of unsigned 32-bit integers, each of which
+corresponds to an X server drawable or pixmap.
+
+@item ENCAPSULATED_POSTSCRIPT
+@item _ADOBE_EPS
+This target returns a string containing encapsulated Postscript code.
+
+@item FILE_NAME
+This target returns a string containing one or more file names,
+separated by NULL characters.
+
+@item HOST_NAME
+This target returns a string containing the fully-qualified domain
+name of the machine on which the selection owner is running.
+
+@item USER
+This target returns a string containing the user name of the machine
+on which the selection owner is running.
+
+@item LENGTH
+This target returns an unsigned 32-bit or 16-bit integer containing
+the length of the selection data.
+
+@item LINE_NUMBER
+This target returns two unsigned 32-bit integers of type @code{SPAN}
+describing the line numbers corresponding to the start and end
+positions of the selection data in the text field containing it.
+
+@item MODULE
+This target returns the name of any function containing the selection
+data. It is principally requested by text editors.
+
+@item STRING
+This target returns the selection data as a string of type
+@code{STRING}, encoded in ISO Latin-1 format, with Unix newline
+characters.
+
+@item C_STRING
+This target returns the selection data as a ``C string''. This has
+been interpreted as meaning the raw selection data in whatever
+encoding used by the owner, either terminated with a NULL byte or not
+at all, or an ASCII string which may or may not be terminated.
+
+@item UTF8_STRING
+This returns the selection data as a string of type
+@code{UTF8_STRING}, encoded in UTF-8, with unspecified EOL format.
+
+@item TIMESTAMP
+This target returns the X server time at which the selection owner
+took ownership over the selection as a 16-bit or 32-bit word of type
+@code{CARDINAL}.
+
+@item TEXT
+This polymorphic target returns selection data as a string, either
+@code{COMPOUND_TEXT}, @code{STRING}, @code{C_STRING}, or
+@code{UTF8_STRING}, whichever data type is convenient for the
+selection owner.
+@end table
+
+ When a request for the targets @code{STRING}, @code{COMPOUND_TEXT},
+or @code{UTF8_STRING} is made using the function
+@code{gui-get-selection}, and neither @code{selection-coding-system}
+nor @code{next-selection-coding-system} is set, the resultant strings
+are decoded by the proper coding systems for those targets:
+@code{iso-8859-1}, @code{compound-text-with-extensions} and
+@code{utf-8} respectively.
+
+ In addition to the targets specified above (and the many targets
+used by various programs for their own purposes), several popular
+programs and toolkits have defined selection data types of their own,
+without consulting the appropriate X standards bodies. These targets
+are generally named after such MIME types as @code{text/html} or
+@code{image/jpeg}; they have been witnessed returning the following
+forms of data:
+
+@itemize @bullet
+@item
+Unterminated, newline terminated, or NULL character terminated file
+names of an image or text file.
+
+@item
+Image or text data in the appropriate format.
+
+@item
+@code{file://} URIs (or conceivably newline or NUL terminated lists of
+URIs) identifying files in the appropriate format.
+@end itemize
+
+ These selection targets were first used by Netscape, but are now
+proffered by all kinds of programs, especially those based on recent
+versions of the GTK+ or Qt toolkits.
+
+ Emacs is also capable of serving as a selection owner. When
+@code{gui-set-selection} is called, the selection data provided is
+recorded internally and Emacs obtains ownership of the selection being
+set.
+
+@defvar selection-converter-alist
+Alist of selection targets to ``selection converter'' functions. When
+a selection request is received, Emacs looks up the selection
+converter pertaining to the requested selection target.
+
+Selection converters are called with three arguments: the symbol
+corresponding to the atom identifying the selection being requested,
+the selection target that is being requested, and the value set with
+@code{gui-set-selection}. The values which they must return are
+either conses of symbols designating the data type and numbers,
+symbols, vectors of numbers or symbols, or the cdrs of such conses by
+themselves.
+
+If a selection converter's value is the special symbol @code{NULL},
+the data type returned to its requestor is set to @code{NULL}, and no
+data is sent in response.
+
+If such a value is a string, it must be a unibyte string; should no
+data type be explicitly specified, the data is transferred to its
+requestor with the type @code{STRING}.
+
+If it is a symbol, its ``atom'' is retrieved, and it is transferred to
+its requestor as a 32-bit value---if no data type is specified, its
+type is @code{ATOM}.
+
+If it is a number between @code{-32769} and @code{32768}, it is
+transferred to its requestor as a 16 bit value---if no data type is
+specified, its type is @code{INTEGER}.
+
+If it is any other number, it is accounted a 32 bit value. Even if
+the number returned is unsigned, its requestor will treat words of
+type @code{INTEGER} as signed. To return an unsigned value, specify
+the type @code{CARDINAL} in its place.
+
+If it is a vector of symbols or numbers, the response to its requestor
+will be a list of multiple atoms or numbers. The data type returned
+when not expressly set is that of the list's first element.
+@end defvar
+
+ By default, Emacs is configured with selection converters for the
+following selection targets:
+
+@table @code
+@item TEXT
+This selection converter returns selection data as:
+
+@itemize @bullet
+@item
+A string of type @code{C_STRING}, if the selection contents contain no
+multibyte characters, or contain ``raw 8-bit bytes'' (@pxref{Text
+Representations}).
+
+@item
+A string of type @code{STRING}, if the selection contents can be
+represented as ISO-Latin-1 text.
+
+@item
+A string of type @code{COMPOUND_TEXT}, if the selection contents can
+be encoded in the X Consortium's Compound Text Encoding, and
+@code{selection-coding-system} or @code{next-selection-coding-system}
+is set to a coding system whose @code{:mime-charset} property is
+@code{x-ctext}.
+
+@item
+A string of type @code{UTF8_STRING} otherwise.
+@end itemize
+
+@item COMPOUND_TEXT
+This selection converter returns selection data as a string of type
+@code{COMPOUND_TEXT}.
+
+@item STRING
+This selection converter returns selection data as a string of type
+@code{STRING}, encoded in ISO-Latin-1 format.
+
+@item UTF8_STRING
+This selection converter returns selection data in UTF-8 format.
+
+@item text/plain
+@item text/plain;charset=utf-8
+@item text/uri-list
+@item text/x-xdnd-username
+@item XmTRANSFER_SUCCESS
+@item XmTRANSFER_FAILURE
+@item FILE
+@item _DT_NETFILE
+These selection converters are used for internal purposes during
+drag-and-drop operations and are not available for selections other
+than @code{XdndSelection}.
+
+@item TARGETS
+This selection converter returns a list of atoms, one for each
+selection target understood by Emacs.
+
+@item MULTIPLE
+This selection converter is implemented in C code and is used to
+implement efficient transfer of selection requests which specify
+multiple selection targets at the same time.
+
+@item LENGTH
+This selection converter returns the length of the selection data, in
+bytes.
+
+@item DELETE
+This selection converter is used for internal purposes during
+drag-and-drop operations.
+
+@item FILE_NAME
+This selection converter returns the file name of the buffer
+containing the selection data.
+
+@item CHARACTER_POSITION
+This selection converter returns the character positions of each end
+of the selection in the buffer containing the selection data.
+
+@item LINE_NUMBER
+@item COLUMN_NUMBER
+This selection converter returns the line and column numbers of each
+end of the selection in the buffer containing the selection data.
+
+@item OWNER_OS
+This selection converter returns the name of the operating system on
+which Emacs is running.
+
+@item HOST_NAME
+This selection converter returns the fully-qualified domain name of
+the machine on which Emacs is running.
+
+@item USER
+This selection converter returns the username of the user account
+under which Emacs is running.
+
+@item CLASS
+@item NAME
+These selection converters return the resource class and name used by
+Emacs.
+
+@item INTEGER
+This selection converter returns an integer value verbatim.
+
+@item SAVE_TARGETS
+@item _EMACS_INTERNAL
+These selection converters are used for internal purposes.
+@end table
+
+ With the exception of @code{INTEGER}, all selection converters
+expect the data provided to @code{gui-set-selection} to be one of the
+following:
+
+@itemize @bullet
+@item
+A string.
+
+@item
+A list of the form @w{@code{(@var{beg} @var{end} @var{buf})}}, where
+@var{beg} and @var{end} are two markers or overlays describing the
+bounds of the selection data in the buffer @var{buf}.
+@end itemize
+
+@node Other Selections
+@subsection Other Selections
+
+ Selections under such window systems as MS-Windows, Nextstep, Haiku
+and Android are not aligned with those under X@. Each of these window
+system improvises its own selection mechanism without employing the
+``selection converter'' mechanism illustrated in the preceding node.
+Only the @code{PRIMARY}, @code{CLIPBOARD}, and @code{SECONDARY}
+selections are generally supported, with the @code{XdndSelection}
+selection that records drag-and-drop data also available under
+Nextstep and Haiku.
+
+@cindex PGTK selections
+ GTK seeks to emulate the X selection system, but its emulations are
+not altogether dependable, with the overall quality of each subject to
+the GDK backend being used. Therefore, Emacs built with PGTK will
+supply the same selection interface as Emacs built with X, but many
+selection targets will not be useful.
+
+@cindex MS-Windows selection emulation
+@cindex MS-Windows primary and secondary selection
+ Although a clipboard exists, there is no concept of primary or
+secondary selections within the MS-Windows operating system. On this
+system, Emacs simulates the presence of a primary and secondary
+selection, while saving to and retrieving from the clipboard when so
+requested.
+
+ The simulation of the primary and secondary selections is conducted
+by saving values supplied to @code{gui-set-selection} within the
+@code{x-selections} property of the symbol designating the pertinent
+selection, namely the @var{type} argument to @code{gui-get-selection}.
+Each subsequent call to @code{gui-get-selection} in turn returns its
+value, which is not subject to further examination (such as type
+checks and the like). Under such circumstances, @var{data-type}
+argument is generally disregarded. (But see below for the
+qualification regarding @code{TARGETS}.)
+
+@cindex MS-Windows clipboard
+ Where the clipboard selection is concerned (whenever @var{type} is
+@code{CLIPBOARD}), @code{gui-set-selection} verifies that the value
+provided is a string and saves it within the system clipboard once it
+is encoded by the coding system configured in
+@code{selection-coding-system}. Callers of @code{gui-get-selection}
+are required to set @var{data-type} to either @code{STRING} or
+@code{TARGETS}.
+
+ When @var{data-type} is set to @code{TARGETS} in a call to
+@code{gui-get-selection}, a vector of symbols is returned when
+selection data exists, much as it is under X@. It is impossible to
+request clipboard data in any format besides @code{STRING}, for the
+prerequisite data conversion routines are absent. Just as strings
+saved into the clipboard are encoded by the
+@code{selection-coding-system}, so those read from the clipboard are
+decoded by that same coding system; this variable and its cousin
+@code{next-selection-coding-system} merit particular scrutiny when
+difficulties are encountered with saving selection text into the
+clipboard.
+
+@cindex Nextstep selections
+ All three selections standard in X exist in Nextstep as well, but
+Emacs is only capable of saving strings to such selections.
+Restrictions imposed upon calls to @code{gui-set-selection} there are
+much the same as those on MS-Windows, though text is uniformly encoded
+as @code{utf-8-unix} without regard to the value of
+@code{selection-coding-system}. @code{gui-get-selection} is more
+charitable, and accepts requests for the following selection targets:
+
+@c FIXME: how is the text coding system determined, and do image/* or
+@c application/* return image data or file names?
+@itemize @bullet
+@item text/plain
+@item image/png
+@item text/html
+@item application/pdf
+@item application/rtf
+@item application/rtfd
+@item STRING
+@item text/plain
+@item image/tiff
+@end itemize
+
+ The @code{XdndSelection} selection is also present under Nextstep,
+in the form of a repository that records values supplied to
+@code{gui-set-selection}. Its sole purpose is to save such values for
+the fundamental drag-and-drop function @code{x-begin-drag}
+(@pxref{Drag and Drop}); no guarantees exist concerning its value when
+read by anything else.
+
+@cindex Haiku selections
+ Selections on Haiku systems comprise all three selections customary
+under X and the @code{XdndSelection} that records drag-and-drop data.
+
+ When @code{gui-set-selection} is called for the former three
+selections, the data supplied is converted into a window server
+``message'' by a list of @dfn{selection encoder} functions, which is
+sent to the window server.
+
+@defvar haiku-normal-selection-encoders
+List of selection encoder functions. When @code{gui-set-selection} is
+called, each function in this list is successively called with its
+@var{selection} and @var{value} arguments. If such a function returns
+non-@code{nil}, its return value must be a list of the form
+@w{@code{(@var{key} @var{type} @var{value})}}. In this list,
+@var{key} must be the name of the data being transferred, generally
+that of a MIME type, for example @samp{"text/plain"}, and @var{type}
+is a symbol or a number designating the type of the data; thus also
+governing the interpretation of @var{value}; following is a list of
+valid data types and how each of them will cause @var{value} to be
+interpreted.
+
+@table @code
+@item string
+A unibyte string. The string is NULL-terminated after being placed in
+the message.
+
+@item ref
+A file name. The file is located and the inode identifying the file
+is placed in the message.
+
+@item short
+A 16-bit integer value.
+
+@item long
+A 32-bit integer value.
+
+@item llong
+A 64-bit integer value.
+
+@item byte
+@item char
+An unsigned byte between 0 and 255.
+
+@item size_t
+A number between 0 and 1 minus two to the power of the word size of
+the computer Emacs is running on.
+
+@item ssize_t
+A number which fits in the C type @code{ssize_t}.
+
+@item point
+A cons of two floats, specifying a coordinate on-screen.
+
+@item float
+@item double
+A single or double-precision floating point number in an unspecified
+format.
+
+@item (haiku-numeric-enum MIME)
+A unibyte string containing data in a certain MIME type.
+@end table
+@end defvar
+
+ A call to @code{gui-get-selection} generally returns the the data
+named @var{data-type} within the selection message, albeit with
+@var{data-type} replaced by an alternative name should it be one of
+the following X selection targets:
+
+@table @code
+@item STRING
+This represents Latin-1 text under X: ``text/plain;charset=iso-8859-1''
+
+@item UTF8_STRING
+This represents UTF-8 text: ``text/plain''
+@end table
+
+ If @var{data-type} is a text type such as @code{STRING} or a MIME
+type matching the pattern @samp{`text/*}, the string data is decoded
+with the coding system apposite for it before being returned.
+
+ Furthermore, the two data types @var{TIMESTAMP} and @code{TARGETS}
+are afforded special treatment; the value returned for the first is
+the number of times the selection has been modified since system
+startup (@emph{not} a timestamp), and that for the other is a vector
+of available selection data types, as elsewhere.
+
+@cindex Android selections
+ Much like MS-Windows, Android provides a clipboard but no primary or
+secondary selection; @code{gui-set-selection} simulates the primary
+and secondary selections by saving the value supplied into a variable
+subsequent calls to @code{gui-get-selection} return.
+
+ From the clipboard, @code{gui-get-selection} is capable of returning
+UTF-8 string data of the type @code{STRING}, the @code{TAREGTS} data
+type, or image and application data of any MIME type.
+@code{gui-set-selection} sets only string data, much as under
+MS-Windows, although this data is not affected by the value of
+@code{selection-coding-system}. By contrast, only string data can be
+saved to and from the primary and secondary selections; but since this
+data is not communicated to programs besides Emacs, it is not subject
+to encoding or decoding by any coding system.
+
@node Yanking Media
@section Yanking Media
- If you choose, for instance, ``Copy Image'' in a web browser, that
-image is put onto the clipboard, and Emacs can access it via
-@code{gui-get-selection}. But in general, inserting image data into
-an arbitrary buffer isn't very useful---you can't really do much with
-it by default.
-
- So Emacs has a system to let modes register handlers for these
-``complicated'' selections.
+ Data saved within window system selections is not restricted to
+plain text. It is possible for selection data to encompass images or
+other binary data of the like, as well as rich text content instanced
+by HTML, and also PostScript. Since the selection data types incident
+to this data are at variance with those for plain text, the insertion
+of such data is facilitated by a set of functions dubbed
+@dfn{yank-media handlers}, which are registered by each major mode
+undertaking its insertion and called where warranted upon the
+execution of the @code{yank-media} command.
@defun yank-media-handler types handler
-@var{types} can be a @acronym{MIME} media type symbol, a regexp to
-match these, or a list of these symbols and regexps. For instance:
+Register a yank-media handler which applies to the current buffer.
+
+@var{types} can be a symbol designating a selection data type
+(@pxref{Accessing Selections}), a regexp against which such types are
+matched, or a list of these symbols and regexps. For instance:
@example
(yank-media-handler 'text/html #'my-html-handler)
(yank-media-handler "image/.*" #'my-image-handler)
@end example
-A mode can register as many handlers as required.
-
- The @var{handler} function is called with two parameters: The
-@acronym{MIME} media type symbol and the data (as a string). The
-handler should then insert the object into the buffer, or save it, or
-do whatever is appropriate for the mode.
+When a selection offers a data type matching @var{types}, the function
+@var{handler} is called to insert its data, with the symbol
+designating the matching selection data type, and the data returned by
+@code{gui-get-selection}.
@end defun
- The @code{yank-media} command will consult the registered handlers in
-the current buffer, compare that with the available media types on the
-clipboard, and then pass on the matching selection to the handler (if
-any). If there's more than one matching selection, the user is
-queried first.
-
- The @code{yank-media-types} command can be used to explore the
-clipboard/primary selection. It lists all the media types that are
-currently available, and can be handy when creating handlers---to see
-what data is actually available. Some applications put a surprising
-amount of different data types on the clipboard.
+The @code{yank-media-types} command presents a list of selection data
+types that are currently available, which is useful when implementing
+yank-media handlers; for programs generally offer an eclectic and
+seldom consistent medley of data types.
@node Drag and Drop
@section Drag and Drop
@cindex drag and drop
- When the user drops something from another application over Emacs,
-Emacs will try to insert any text and open any URL that was dropped.
-If text was dropped, then it will always be inserted at the location
-of the mouse pointer where the drop happened, or saved in the kill
-ring if insertion failed, which could happen if the buffer was
-read-only. If a URL was dropped instead, then Emacs will first try to
-call an appropriate handler function by matching the URL against
-regexps defined in the variable @code{dnd-protocol-alist}, and then
-against those defined in the variables @code{browse-url-handlers} and
-@code{browse-url-default-handlers}. Should no suitable handler be
-located, Emacs will fall back to inserting the URL as plain text.
+ Data transferred by drag and drop is generally either plain text or
+a list of URLs designating files or other resources. When text is
+dropped, it is inserted at the location of the drop, with recourse to
+saving it into the kill ring if that is not possible.
+
+ URLs dropped are supplied to pertinent @dfn{DND handler functions}
+in the variable @code{dnd-protocol-alist}, or alternatively ``URL
+handlers'' as set forth by the variables @code{browse-url-handlers}
+and @code{browse-url-default-handlers}; absent matching handlers of
+either type, they are treated as plain text and inserted in the
+buffer.
@defvar dnd-protocol-alist
- This variable is a list of cons cells of the form
-@w{@code{(@var{pattern} . @var{action})}}. @var{pattern} is a regexp
-that URLs are matched against after being dropped. @var{action} is a
-function that is called with two arguments, should a URL being dropped
-match @var{pattern}: the URL being dropped, and the action being
-performed for the drop, which is one of the symbols @code{copy},
-@code{move}, @code{link}, @code{private} or @code{ask}.
-
-If @var{action} is @var{private}, then it means the program that
-initiated the drop wants Emacs to perform an unspecified action with
-the URL; a reasonable action to perform in that case is to open the URL
-or copy its contents into the current buffer. Otherwise, @var{action}
-has the same meaning as the @var{action} argument to
+This variable is an alist between regexps against which URLs are
+matched and DND handler functions called on the dropping of matching
+URLs.
+
+@cindex dnd-multiple-handler, a symbol property
+If a handler function is a symbol whose @code{dnd-multiple-handler}
+property (@pxref{Symbol Properties}) is set, then upon a drop it is
+given a list of every URL that matches its regexp; absent this
+property, it is called once for each of those URLs. Following this
+first argument is one of the symbols @code{copy}, @code{move},
+@code{link}, @code{private} or @code{ask} identifying the action to be
+taken.
+
+If @var{action} is @code{private}, the program that initiated the drop
+does not insist on any particular behavior on the part of its
+recipient; a reasonable action to take in that case is to open the URL
+or copy its contents into the current buffer. The other values of
+@var{action} imply much the same as in the @var{action} argument to
@code{dnd-begin-file-drag}.
+
+Once its work completes, a handler function must return a symbol
+designating the action it took: either the action it was provided, or
+the symbol @code{private}, which communicates to the source of the
+drop that the action it prescribed has not been executed.
+
+When multiple handlers match an overlapping subset of items within a
+drop, the handler matched against by the greatest number of items is
+called to open that subset. The items it is supplied are subsequently
+withheld from other handlers, even those they also match.
@end defvar
@cindex drag and drop, X
@cindex drag and drop, other formats
- Emacs implements receiving text and URLs individually for each
-window system, and does not by default support receiving other kinds
-of data as drops. To support receiving other kinds of data, use the
-X-specific interface described below.
-
-@vindex x-dnd-test-function
-@vindex x-dnd-known-types
- When a user drags something from another application over Emacs
-under the X Window System, that other application expects Emacs to
-tell it if Emacs understands the data being dragged. The function in
-the variable @code{x-dnd-test-function} is called by Emacs to
-determine what to reply to any such inquiry. The default value is
-@code{x-dnd-default-test-function}, which accepts drops if the type of
-the data to be dropped is present in @code{x-dnd-known-types}.
-Changing the variables @code{x-dnd-test-function} and
-@code{x-dnd-known-types} can make Emacs accept or reject drops based
-on some other criteria.
-
-@vindex x-dnd-types-alist
- If you want to change the way Emacs receives drops of different data
-types, or you want to enable it to understand a new type, change the variable
-@code{x-dnd-types-alist}. Doing so correctly requires detailed
-knowledge of what data types other applications use for drag and drop.
-
- These data types are typically implemented as special data types
-that can be obtained from an X selection provided by the other
-application. In most cases, they are either the same data types that
-are typically accepted by @code{gui-set-selection}, or MIME types,
-depending on the specific drag-and-drop protocol being used. For
-example, the data type used for plain text may be either
-@code{"STRING"} or @code{"text/plain"}.
+ Emacs does not take measures to accept data besides text and URLs,
+for the window system interfaces which enable this are too far removed
+from each other to abstract over consistently. Nor are DND handlers
+accorded influence over the actions they are meant to take, as
+particular drag-and-drop protocols deny recipients such control. The
+X11 drag-and-drop implementation rests on several underlying protocols
+that make use of selection transfer and share much in common, to which
+low level access is provided through the following functions and
+variables:
+
+@defvar x-dnd-test-function
+This function is called to ascertain whether Emacs should accept a
+drop. It is called with three arguments:
+
+@itemize @bullet
+@item
+The window under the item being dragged, which is to say the window
+whose buffer is to receive the drop. If the item is situated over a
+non-window component of a frame (such as scroll bars, tool bars and
+things to that effect), the frame itself is provided in its place.
+
+@item
+One of the symbols @code{move}, @code{copy}, @code{link} or
+@code{ask}, representing an action to take on the item data suggested
+by the drop source. These symbols carry the same implications as in
+@code{x-begin-drag}.
+
+@item
+A vector of selection data types (@pxref{X Selections}) the item
+provides.
+@end itemize
+
+This function must return @code{nil} to reject the drop or a cons of
+the action that will be taken (such as through transfer to a DND
+handler function) and the selection data type to be requested. The
+action returned in that cons may also be the symbol @code{private},
+which intimates that the action taken is as yet indeterminate.
+@end defvar
+
+@defvar x-dnd-known-types
+Modifying @code{x-dnd-test-function} is generally unwarranted, for its
+default set of criteria for accepting a drop can be adjusted by
+changing this list of selection data types. Each element is a string,
+which if found as the symbol name of an element within the list of
+data types by the default ``test function'', will induce that function
+to accept the drop.
+
+Introducing a new entry into this list is not useful unless a
+counterpart handler function is appended to @code{x-dnd-types-alist}.
+@end defvar
+
+@defvar x-dnd-types-alist
+This variable is an alist between strings designating selection data
+types and functions which are called when things of such types are
+dropped.
+
+Each such function is supplied three arguments; the first is the
+window or frame below the location of the drop, as in
+@code{x-dnd-test-function}; the second is the action to be taken,
+which may be any of the actions returned by test functions, and third
+is the selection data itself (@pxref{Accessing Selections}).
+@end defvar
+
+ Selection data types as provided by X11 drag-and-drop protocols are
+sometimes distinct from those provided by the ICCCM and conforming
+clipboard or primary selection owners. Frequently, the name of a MIME
+type, such as @code{"text/plain;charset=utf-8"} (with discrepant
+capitalization of the ``utf-8''), is substituted for a standard X
+selection name such as @code{UTF8_STRING}.
@cindex XDS
@cindex direct save protocol
@vindex x-dnd-direct-save-function
- When Emacs runs on X window system, it supports the X Direct Save
-(@acronym{XDS}) protocol, which allows users to save a file by
-dragging and dropping it onto an Emacs window, such as a Dired window.
-To comply with the unique requirements of @acronym{XDS}, these
-drag-and-drop requests are processed specially: instead of being
-handled according to @code{x-dnd-types-alist}, they are handled by the
-@dfn{direct-save function} that is the value of the variable
-@code{x-dnd-direct-save-function}. The value should be a function of
-two arguments, @var{need-name} and @var{filename}. The @acronym{XDS}
-protocol uses a two-step procedure for dragging files:
+ The X Direct Save (@acronym{XDS}) protocol enables programs to
+devolve responsibility for naming a dropped file upon the recipient.
+When such a drop transpires, DND handlers and the foregoing X-specific
+interface are largely circumvented, tasking a different function with
+responding to the drop.
+
+@defvar x-dnd-direct-save-function
+This variable should be set to a function that registers and names
+files dropped using the @acronym{XDS} protocol in a two-step
+procedure. It is provided two arguments, @var{need-name} and
+@var{filename}.
@enumerate 1
@item
@@ -4185,8 +4896,9 @@ Dired should update the directory on display by showing the new file
there.
@end enumerate
-The default value of @code{x-dnd-direct-save-function} is
+Its default @code{x-dnd-direct-save-function} is
@code{x-dnd-save-direct}.
+@end defvar
@defun x-dnd-save-direct need-name filename
When called with the @var{need-name} argument non-@code{nil}, this
@@ -4212,48 +4924,47 @@ default directory.)
@end defun
@cindex initiating drag-and-drop
- On capable window systems, Emacs also supports dragging contents
-from its frames to windows of other applications.
+ It is also possible to drag content from Emacs to other programs
+when this is supported by the current window-system. The functions
+which provide for this are as follows:
@cindex drop target, in drag-and-drop operations
@defun dnd-begin-text-drag text &optional frame action allow-same-frame
-This function begins dragging text from @var{frame} to another program
-(known as the @dfn{drop target}), and returns the result of
-drag-and-drop operation when the text is dropped or the drag-and-drop
-operation is canceled. @var{text} is the text that will be inserted
-by the drop target.
+This function starts a drag-and-drop operation from @var{frame} to
+another program (dubbed the @dfn{drop target}), and returns when
+@var{text} is dropped or the operation is canceled.
@var{action} must be one of the symbols @code{copy} or @code{move},
where @code{copy} means that @var{text} should be inserted by the drop
-target, and @code{move} means the same as @code{copy}, but in addition
-the caller may have to delete @var{text} from its source as explained
+target, and @code{move} means the same as @code{copy}, but the caller
+must also delete @var{text} from its source as explained in the list
below.
@var{frame} is the frame where the mouse is currently held down, or
-@code{nil}, which means to use the selected frame. This function may
-return immediately if no mouse buttons are held down, so it should be
-only called immediately after a @code{down-mouse-1} or similar event
-(@pxref{Mouse Events}), with @var{frame} set to the frame where that
-event was generated (@pxref{Click Events}).
+@code{nil}, which means to use the selected frame. Since this
+function might return promptly if no mouse buttons are held down, it
+should be only called in response to a @code{down-mouse-1} or
+analogous event (@pxref{Mouse Events}), with @var{frame} set to the
+frame where that event was generated (@pxref{Click Events}).
-@var{allow-same-frame} specifies whether or not drops on top of
-@var{frame} itself are to be ignored.
+If @var{allow-same-frame} is @code{nil}, drops on top of @var{frame}
+will be ignored.
-The return value specifies the action that the drop target actually
-performed, and optionally what the caller should do. It can be one of
-the following symbols:
+The return value reflects the action that the drop target actually
+performed, and thus also what action, if any, the caller should in
+turn take. It is one of the following symbols:
@table @code
@item copy
The drop target inserted the dropped text.
@item move
-The drop target inserted the dropped text, but in addition the caller
-should delete @var{text} from wherever it originated, such as its
-buffer.
+The drop target inserted the dropped text, and the caller should
+delete @var{text} from the buffer where it was extracted from, if
+applicable.
@item private
-The drop target performed some other unspecified action.
+The drop target took some other unspecified action.
@item nil
The drag-and-drop operation was canceled.
@@ -4262,11 +4973,12 @@ The drag-and-drop operation was canceled.
@end defun
@defun dnd-begin-file-drag file &optional frame action allow-same-frame
-This function begins dragging @var{file} from @var{frame} to another
-program, and returns the result of the drag-and-drop operation when
-the file is dropped or the drag-and-drop operation is canceled.
+This function starts a drag-and-drop operation from @var{frame} to
+another program (dubbed the @dfn{drop target}), and returns when
+@var{file} is dropped or the operation is canceled.
-If @var{file} is a remote file, then a temporary copy will be made.
+If @var{file} is a remote file, then a temporary local copy will be
+made.
@var{action} must be one of the symbols @code{copy}, @code{move} or
@code{link}, where @code{copy} means that @var{file} should be opened
@@ -4275,11 +4987,11 @@ move the file to another location, and @code{link} means the drop
target should create a symbolic link to @var{file}. It is an error to
specify @code{link} as the action if @var{file} is a remote file.
-@var{frame} and @var{allow-same-frame} have the same meaning as in
-@code{dnd-begin-text-drag}.
+@var{frame} and @var{allow-same-frame} mean the same as they do in
+calls to @code{dnd-begin-text-drag}.
The return value is the action that the drop target actually
-performed, which can be one of the following symbols:
+performed, which is one of the following symbols:
@table @code
@item copy
@@ -4308,19 +5020,18 @@ dropping multiple files, then the first file will be used instead.
@end defun
@defun dnd-direct-save file name &optional frame allow-same-frame
-This function is similar to @code{dnd-begin-file-drag} (with the
-default action of copy), but instead of specifying the action you
-specify the name of the copy created by the target program in
-@code{name}.
+The behavior of this function is akin to that of
+@code{dnd-begin-file-drag} (when the default action @code{copy} is
+used), except that it accepts a name under which the copy is meant to
+be filed.
@end defun
@cindex initiating drag-and-drop, low-level
The high-level interfaces described above are implemented on top of
-a lower-level primitive. If you need to drag content other than files
-or text, use the low-level interface @code{x-begin-drag}
-instead. However, using it will require detailed knowledge of the
-data types and actions used by the programs to transfer content via
-drag-and-drop on each platform you want to support.
+a lower-level primitive. The low-level interface @code{x-begin-drag}
+is also available for dragging content besides text and files. It
+demands detailed knowledge of the data types and actions understood by
+programs on each platform its callers wish to support.
@defun x-begin-drag targets &optional action frame return-frame allow-current-frame follow-tooltip
This function begins a drag from @var{frame}, and returns when the
@@ -4332,60 +5043,59 @@ non-@code{nil}. If no mouse buttons are held down when the
drag-and-drop operation begins, this function may immediately return
@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
+@var{targets} is a list of strings representing 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} is a symbol designating the action recommended to the
+target. It can either be @code{XdndActionCopy} or
+@code{XdndActionMove}; both imply copying the contents of the
+selection @code{XdndSelection} to the drop target, but the latter
+moreover conveys a promise to delete the contents of the selection
+after the copying.
@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.
+representing available actions, and strings that the drop target
+presents to the user for him to select between those 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
+@var{return-frame} is the symbol @code{now}, then any frame beneath
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.
+while also dragging content to other programs, but it is not
+guaranteed to function on all systems and with all window managers.
If @var{follow-tooltip} is non-@code{nil}, the position of any tooltip
-(such as one shown by @code{tooltip-show}) will follow the location of
-the mouse pointer whenever it moves during the drag-and-drop
+(such as one displayed by @code{tooltip-show}) will follow the
+location of the mouse pointer as it moves during the drag-and-drop
operation. The tooltip will be hidden once all mouse buttons are
released.
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.
-
-The caller must cooperate with the target to fully perform the action
-chosen by the target. For example, callers should delete the buffer
-text that was dragged if this function returns @code{XdndActionMove}.
+returns @code{nil}. Otherwise, it returns a symbol representing the
+action the target opted to take, 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 suggests that the drop target opted for an
+indeterminate action, and no further action is required of the caller.
+
+The caller must cooperate with the target to complete the action
+selected by the target. For example, callers should delete any buffer
+text that was dragged if this function returns @code{XdndActionMove},
+and likewise for other drag data where comparable criteria apply.
@end defun
@cindex drag and drop protocols, X
- On X Windows, several different drag-and-drop protocols are
-supported by @code{x-begin-drag}. When dragging content that is known
-to not be supported by a specific drag-and-drop protocol, it might be
-desirable to turn that protocol off, by changing the values of the
-following variables:
+ The function @code{x-begin-drag} leverages several drag-and-drop
+protocols ``behind the scenes''. When dragging content that is known
+to not be supported by a specific drag-and-drop protocol, that
+protocol can be disabled by changing the values of the following
+variables:
@defvar x-dnd-disable-motif-protocol
When this is non-@code{nil}, the Motif drag and drop protocols are
@@ -4409,8 +5119,8 @@ events and the primary selection to insert the text if the drop target
doesn't support any drag-and-drop protocol at all.
A side effect is that Emacs will become the owner of the primary
-selection upon such a drop. If that is not desired, then the drop
-emulation can be disabled by setting this variable to @code{nil}.
+selection upon such a drop. Such emulation can be disabled by setting
+this variable to @code{nil}.
@end defvar
@node Color Names
@@ -4451,20 +5161,12 @@ really supports that color. When using X, you can ask for any defined
color on any kind of display, and you will get some result---typically,
the closest it can do. To determine whether a frame can really display
a certain color, use @code{color-supported-p} (see below).
-
-@findex x-color-defined-p
-This function used to be called @code{x-color-defined-p},
-and that name is still supported as an alias.
@end defun
@defun defined-colors &optional frame
This function returns a list of the color names that are defined
and supported on frame @var{frame} (default, the selected frame).
If @var{frame} does not support colors, the value is @code{nil}.
-
-@findex x-defined-colors
-This function used to be called @code{x-defined-colors},
-and that name is still supported as an alias.
@end defun
@defun color-supported-p color &optional frame background-p
@@ -4516,10 +5218,6 @@ The color values are returned for @var{frame}'s display. If
@var{frame} is omitted or @code{nil}, the information is returned for
the selected frame's display. If the frame cannot display colors, the
value is @code{nil}.
-
-@findex x-color-values
-This function used to be called @code{x-color-values},
-and that name is still supported as an alias.
@end defun
@defun color-name-to-rgb color &optional frame
@@ -4704,10 +5402,7 @@ This function returns @code{t} if @var{display} has a mouse available,
@end defun
@defun display-color-p &optional display
-@findex x-display-color-p
This function returns @code{t} if the screen is a color screen.
-It used to be called @code{x-display-color-p}, and that name
-is still supported as an alias.
@end defun
@defun display-grayscale-p &optional display
diff --git a/doc/lispref/functions.texi b/doc/lispref/functions.texi
index eac5b91e76a..ff635fc54b2 100644
--- a/doc/lispref/functions.texi
+++ b/doc/lispref/functions.texi
@@ -498,13 +498,12 @@ indentation of the following lines is inside the string; what looks
nice in the source code will look ugly when displayed by the help
commands.
- You may wonder how the documentation string could be optional, since
-there are required components of the function that follow it (the body).
-Since evaluation of a string returns that string, without any side effects,
-it has no effect if it is not the last form in the body. Thus, in
-practice, there is no confusion between the first form of the body and the
-documentation string; if the only body form is a string then it serves both
-as the return value and as the documentation.
+ A documentation string must always be followed by at least one Lisp
+expression; otherwise, it is not a documentation string at all but the
+single expression of the body and used as the return value.
+When there is no meaningful value to return from a function, it is
+standard practice to return @code{nil} by adding it after the
+documentation string.
The last line of the documentation string can specify calling
conventions different from the actual function arguments. Write
@@ -771,9 +770,12 @@ explicitly in the source file being loaded. This is because
By contrast, in programs that manipulate function definitions for other
purposes, it is better to use @code{fset}, which does not keep such
records. @xref{Function Cells}.
+
+If the resulting function definition chain would be circular, then
+Emacs will signal a @code{cyclic-function-indirection} error.
@end defun
-@defun function-alias-p object &optional noerror
+@defun function-alias-p object
Checks whether @var{object} is a function alias. If it is, it returns
a list of symbols representing the function alias chain, else
@code{nil}. For instance, if @code{a} is an alias for @code{b}, and
@@ -784,9 +786,8 @@ a list of symbols representing the function alias chain, else
@result{} (b c)
@end example
-If there's a loop in the definitions, an error will be signaled. If
-@var{noerror} is non-@code{nil}, the non-looping parts of the chain is
-returned instead.
+There is also a second, optional argument that is obsolete and has no
+effect.
@end defun
You cannot create a new primitive function with @code{defun} or
@@ -1573,6 +1574,9 @@ is not a function, e.g., a keyboard macro (@pxref{Keyboard Macros}):
If you wish to use @code{fset} to make an alternate name for a
function, consider using @code{defalias} instead. @xref{Definition of
defalias}.
+
+If the resulting function definition chain would be circular, then
+Emacs will signal a @code{cyclic-function-indirection} error.
@end defun
@node Closures
@@ -2023,9 +2027,16 @@ advice. Advice can also cause confusion in debugging, if the person doing the
debugging does not notice or remember that the function has been modified
by advice.
- For these reasons, advice should be reserved for the cases where you
-cannot modify a function's behavior in any other way. If it is
-possible to do the same thing via a hook, that is preferable
+ Note that the problems are not due to advice per se, but to the act
+of modifying a named function. It is even more problematic to modify
+a named function via lower-level primitives like @code{fset},
+@code{defalias}, or @code{cl-letf}. From that point of view, advice
+is the better way to modify a named function because it keeps track of
+the modifications, so they can be listed and undone.
+
+ Modifying a named function should be reserved for
+the cases where you cannot modify Emacs' behavior in any other way.
+If it is possible to do the same thing via a hook, that is preferable
(@pxref{Hooks}). If you simply want to change what a particular key
does, it may be better to write a new command, and remap the old
command's key bindings to the new one (@pxref{Remapping Commands}).
@@ -2054,9 +2065,10 @@ code) obey the advice and other calls (from C code) do not.
@defmac define-advice symbol (where lambda-list &optional name depth) &rest body
This macro defines a piece of advice and adds it to the function named
-@var{symbol}. The advice is an anonymous function if @var{name} is
-@code{nil} or a function named @code{symbol@@name}. See
-@code{advice-add} for explanation of other arguments.
+@var{symbol}. If @var{name} is non-nil, the advice is named
+@code{@var{symbol}@@@var{name}} and installed with the name @var{name}; otherwise,
+the advice is anonymous. See @code{advice-add} for explanation of
+other arguments.
@end defmac
@defun advice-add symbol where function &optional props
@@ -2065,10 +2077,12 @@ Add the advice @var{function} to the named function @var{symbol}.
(@pxref{Core Advising Primitives}).
@end defun
-@defun advice-remove symbol function
+@deffn Command advice-remove symbol function
Remove the advice @var{function} from the named function @var{symbol}.
-@var{function} can also be the @code{name} of a piece of advice.
-@end defun
+@var{function} can also be the @code{name} of a piece of advice. When
+called interactively, prompt for both an advised @var{function} and
+the advice to remove.
+@end deffn
@defun advice-member-p function symbol
Return non-@code{nil} if the advice @var{function} is already in the named
@@ -2206,7 +2220,7 @@ More specifically, the composition of the two functions behaves like:
@findex defadvice
@findex ad-activate
-A lot of code uses the old @code{defadvice} mechanism, which is largely made
+A lot of code uses the old @code{defadvice} mechanism, which has been made
obsolete by the new @code{advice-add}, whose implementation and semantics is
significantly simpler.
@@ -2386,8 +2400,8 @@ accepted three arguments, like this
(sit-for seconds milliseconds nodisp)
@end example
-However, calling @code{sit-for} this way is considered obsolete
-(@pxref{Waiting}). The old calling convention is deprecated like
+During a transition period, the function accepted those three
+arguments, but declared this old calling convention as deprecated like
this:
@example
@@ -2671,6 +2685,12 @@ so the byte compiler can ignore calls whose value is ignored. This is
the same as the @code{side-effect-free} property of the function's
symbol, @pxref{Standard Properties}.
+@item (important-return-value @var{val})
+If @var{val} is non-@code{nil}, the byte compiler will warn about
+calls to this function that do not use the returned value. This is the
+same as the @code{important-return-value} property of the function's
+symbol, @pxref{Standard Properties}.
+
@item (speed @var{n})
Specify the value of @code{native-comp-speed} in effect for native
compilation of this function (@pxref{Native-Compilation Variables}).
diff --git a/doc/lispref/hash.texi b/doc/lispref/hash.texi
index ff9d1799a60..4270de664f1 100644
--- a/doc/lispref/hash.texi
+++ b/doc/lispref/hash.texi
@@ -121,32 +121,10 @@ referenced in the hash table are preserved from garbage collection.
@item :size @var{size}
This specifies a hint for how many associations you plan to store in the
hash table. If you know the approximate number, you can make things a
-little more efficient by specifying it this way. If you specify too
-small a size, the hash table will grow automatically when necessary, but
-doing that takes some extra time.
-
-The default size is 65.
-
-@item :rehash-size @var{rehash-size}
-When you add an association to a hash table and the table is full,
-it grows automatically. This value specifies how to make the hash table
-larger, at that time.
-
-If @var{rehash-size} is an integer, it should be positive, and the hash
-table grows by adding approximately that much to the nominal size. If
-@var{rehash-size} is floating point, it had better be greater
-than 1, and the hash table grows by multiplying the old size by
-approximately that number.
-
-The default value is 1.5.
-
-@item :rehash-threshold @var{threshold}
-This specifies the criterion for when the hash table is full (so
-it should be made larger). The value, @var{threshold}, should be a
-positive floating-point number, no greater than 1. The hash table is
-full whenever the actual number of entries exceeds the nominal size
-multiplied by an approximation to this value. The default for
-@var{threshold} is 0.8125.
+little more efficient by specifying it this way but since the hash
+table memory is managed automatically, the gain in speed is rarely
+significant.
+
@end table
@end defun
@@ -159,7 +137,7 @@ the following specifies a hash table containing the keys
(a symbol) and @code{300} (a number) respectively.
@example
-#s(hash-table size 30 data (key1 val1 key2 300))
+#s(hash-table data (key1 val1 key2 300))
@end example
Note, however, that when using this in Emacs Lisp code, it's
@@ -172,12 +150,11 @@ The printed representation for a hash table consists of @samp{#s}
followed by a list beginning with @samp{hash-table}. The rest of the
list should consist of zero or more property-value pairs specifying
the hash table's properties and initial contents. The properties and
-values are read literally. Valid property names are @code{size},
-@code{test}, @code{weakness}, @code{rehash-size},
-@code{rehash-threshold}, and @code{data}. The @code{data} property
+values are read literally. Valid property names are @code{test},
+@code{weakness} and @code{data}. The @code{data} property
should be a list of key-value pairs for the initial contents; the
other properties have the same meanings as the matching
-@code{make-hash-table} keywords (@code{:size}, @code{:test}, etc.),
+@code{make-hash-table} keywords (@code{:test} and @code{:weakness}),
described above.
Note that you cannot specify a hash table whose initial contents
@@ -229,6 +206,10 @@ This function calls @var{function} once for each of the associations in
@var{table}. The function @var{function} should accept two
arguments---a @var{key} listed in @var{table}, and its associated
@var{value}. @code{maphash} returns @code{nil}.
+
+@var{function} is allowed to call @code{puthash} to set a new value
+for @var{key} and @code{remhash} to remove @var{key}, but should not
+add, remove or modify other associations in @var{table}.
@end defun
@node Defining Hash
@@ -377,14 +358,7 @@ This function returns the @var{weak} value that was specified for hash
table @var{table}.
@end defun
-@defun hash-table-rehash-size table
-This returns the rehash size of @var{table}.
-@end defun
-
-@defun hash-table-rehash-threshold table
-This returns the rehash threshold of @var{table}.
-@end defun
-
@defun hash-table-size table
-This returns the current nominal size of @var{table}.
+This returns the current allocation size of @var{table}. Since hash table
+allocation is managed automatically, this is rarely of interest.
@end defun
diff --git a/doc/lispref/help.texi b/doc/lispref/help.texi
index f3c916a9ecc..4236fa75bf0 100644
--- a/doc/lispref/help.texi
+++ b/doc/lispref/help.texi
@@ -231,7 +231,7 @@ in the *Help* buffer."
(help-setup-xref (list 'describe-symbols pattern)
(called-interactively-p 'interactive))
(with-help-window (help-buffer)
- (mapcar describe-func (sort sym-list 'string<)))))
+ (mapcar describe-func (sort sym-list)))))
@end group
@end smallexample
@@ -989,3 +989,29 @@ in the function group to insert the function into.
If @var{group} doesn't exist, it will be created. If @var{section}
doesn't exist, it will be added to the end of the function group.
@end defun
+
+You can also query the examples of use of functions defined in
+shortdoc groups.
+
+@defun shortdoc-function-examples function
+This function returns all shortdoc examples for @var{function}. The
+return value is an alist with items of the form
+@w{@code{(@var{group} . @var{examples})}}, where @var{group} is a
+documentation group where @var{function} appears, and @var{examples}
+is a string with the examples of @var{function}s use as defined in
+@var{group}.
+
+@code{shortdoc-function-examples} returns @code{nil} if @var{function}
+is not a function or if it doesn't have any shortdoc examples.
+@end defun
+
+@vindex help-fns-describe-function-functions
+@defun shortdoc-help-fns-examples-function function
+This function queries the registered shortdoc groups and inserts
+examples of use of a given Emacs Lisp @var{function} into the current
+buffer. It is suitable for addition to the
+@code{help-fns-describe-function-functions} hook, in which case
+examples from shortdoc of using a function will be displayed in the
+@file{*Help*} buffer when the documentation of the function is
+requested.
+@end defun
diff --git a/doc/lispref/internals.texi b/doc/lispref/internals.texi
index 333a5897837..a5480a9bf8a 100644
--- a/doc/lispref/internals.texi
+++ b/doc/lispref/internals.texi
@@ -735,14 +735,15 @@ Emacs session.
@section C Dialect
@cindex C programming language
-The C part of Emacs is portable to C99 or later: C11-specific features such
-as @samp{<stdalign.h>} and @samp{_Noreturn} are not used without a check,
+The C part of Emacs is portable to C99 or later: later C features such
+as @samp{<stdckdint.h>} and @samp{[[noreturn]]} are not used without a check,
typically at configuration time, and the Emacs build procedure
-provides a substitute implementation if necessary. Some C11 features,
+provides a substitute implementation if necessary. Some later features,
such as anonymous structures and unions, are too difficult to emulate,
so they are avoided entirely.
-At some point in the future the base C dialect will no doubt change to C11.
+At some point in the future the base C dialect will no doubt change to
+something later than C99.
@node Writing Emacs Primitives
@section Writing Emacs Primitives
@@ -897,15 +898,17 @@ Currently, only the following attributes are recognized:
@table @code
@item noreturn
Declares the C function as one that never returns. This corresponds
-to the C11 keyword @code{_Noreturn} and to @w{@code{__attribute__
-((__noreturn__))}} attribute of GCC (@pxref{Function Attributes,,,
-gcc, Using the GNU Compiler Collection}).
+to C23's @code{[[noreturn]]}, to C11's @code{_Noreturn}, and to GCC's
+@w{@code{__attribute__ ((__noreturn__))}} (@pxref{Function
+Attributes,,, gcc, Using the GNU Compiler Collection}). (Internally,
+Emacs's own C code uses @code{_Noreturn} as it can be defined as a
+macro on C platforms that do not support it.)
@item const
Declares that the function does not examine any values except its
arguments, and has no effects except the return value. This
-corresponds to @w{@code{__attribute__ ((__const__))}} attribute of
-GCC.
+corresponds to C23's @code{[[unsequenced]]} and to GCC's
+@w{@code{__attribute__ ((__const__))}}.
@item noinline
This corresponds to @w{@code{__attribute__ ((__noinline__))}}
@@ -1573,7 +1576,7 @@ return values from module functions. For this purpose, the module
Emacs Lisp objects communicated via the @acronym{API}; it is the
functional equivalent of the @code{Lisp_Object} type used in Emacs C
primitives (@pxref{Writing Emacs Primitives}). This section describes
-the parts of the module @acronym{API} that allow to create
+the parts of the module @acronym{API} that allow creating
@code{emacs_value} objects corresponding to basic Lisp data types, and
how to access from C data in @code{emacs_value} objects that
correspond to Lisp objects.
@@ -2525,7 +2528,6 @@ when the buffer is not current.
@item mode_line_format
@itemx header_line_format
-@itemx case_fold_search
@itemx tab_width
@itemx fill_column
@itemx left_margin
diff --git a/doc/lispref/keymaps.texi b/doc/lispref/keymaps.texi
index 65531cbf53a..1521b3815f4 100644
--- a/doc/lispref/keymaps.texi
+++ b/doc/lispref/keymaps.texi
@@ -2044,6 +2044,15 @@ to turn the character that follows into a Hyper character:
@end group
@end example
+@cindex accessing events within a key translation function
+@vindex current-key-remap-sequence
+A key translation function might want to adjust its behavior based on
+parameters to events within a key sequence containing non-key events
+(@pxref{Input Events}.) This information is available from the
+variable @code{current-key-remap-sequence}, which is bound to the key
+sub-sequence being translated around calls to key translation
+functions.
+
@subsection Interaction with normal keymaps
The end of a key sequence is detected when that key sequence either is bound
@@ -2588,6 +2597,12 @@ function should return the binding to use instead.
Emacs can call this function at any time that it does redisplay or
operates on menu data structures, so you should write it so it can
safely be called at any time.
+
+@item :wrap @var{wrap-p}
+If @var{wrap-p} is non-nil inside a tool bar, the menu item is not
+displayed, but instead causes subsequent items to be displayed on a
+new line. This is not supported when Emacs uses the GTK+ or Nextstep
+toolkits.
@end table
@node Menu Separators
@@ -3094,6 +3109,16 @@ specifies the local map to make the definition in. The argument
@code{tool-bar-add-item-from-menu}.
@end defun
+@vindex secondary-tool-bar-map
+In addition to the tool bar items defined in @code{tool-bar-map},
+Emacs also supports displaying an additional row of ``secondary'' tool
+bar items specified in the keymap @code{secondary-tool-bar-map}.
+These items are normally displayed below those defined within
+@code{tool-bar-map} if the tool bar is positioned at the top of its
+frame, but are displayed above them if the tool bar is positioned at
+the bottom (@pxref{Layout Parameters}.) They are not displayed if the
+tool bar is positioned at the left or right of a frame.
+
@defvar auto-resize-tool-bars
If this variable is non-@code{nil}, the tool bar automatically resizes to
show all defined tool bar items---but not larger than a quarter of the
diff --git a/doc/lispref/lists.texi b/doc/lispref/lists.texi
index 6ad6c487d0b..1409e51c0d4 100644
--- a/doc/lispref/lists.texi
+++ b/doc/lispref/lists.texi
@@ -696,16 +696,17 @@ not a list, the sequence's elements do not become elements of the
resulting list. Instead, the sequence becomes the final @sc{cdr}, like
any other non-list final argument.
-@defun copy-tree tree &optional vecp
+@defun copy-tree tree &optional vectors-and-records
This function returns a copy of the tree @var{tree}. If @var{tree} is a
cons cell, this makes a new cons cell with the same @sc{car} and
@sc{cdr}, then recursively copies the @sc{car} and @sc{cdr} in the
same way.
Normally, when @var{tree} is anything other than a cons cell,
-@code{copy-tree} simply returns @var{tree}. However, if @var{vecp} is
-non-@code{nil}, it copies vectors too (and operates recursively on
-their elements).
+@code{copy-tree} simply returns @var{tree}. However, if
+@var{vectors-and-records} is non-@code{nil}, it copies vectors and records
+too (and operates recursively on their elements). The @var{tree}
+argument must not contain cycles.
@end defun
@defun flatten-tree tree
@@ -1224,7 +1225,15 @@ x
@end example
However, the other arguments (all but the last) should be mutable
-lists.
+lists. They can be dotted lists, whose last @sc{cdr}s are then
+replaced with the next argument:
+
+@example
+@group
+(nconc (cons 1 2) (cons 3 (cons 4 5)) 'z)
+ @result{} (1 3 4 . z)
+@end group
+@end example
A common pitfall is to use a constant list as a non-last argument to
@code{nconc}. If you do this, the resulting behavior is undefined
diff --git a/doc/lispref/loading.texi b/doc/lispref/loading.texi
index 3bacb1db996..75b9d11028a 100644
--- a/doc/lispref/loading.texi
+++ b/doc/lispref/loading.texi
@@ -660,9 +660,7 @@ and @code{define-overloadable-function} (see the commentary in
@item Definitions for major or minor modes:
@code{define-minor-mode}, @code{define-globalized-minor-mode},
@code{define-generic-mode}, @code{define-derived-mode},
-@code{easy-mmode-define-minor-mode},
-@code{easy-mmode-define-global-mode}, @code{define-compilation-mode},
-and @code{define-global-minor-mode}.
+@code{define-compilation-mode}, and @code{define-global-minor-mode}.
@item Other definition types:
@code{defcustom}, @code{defgroup}, @code{deftheme}, @code{defclass}
@@ -1013,6 +1011,19 @@ If loading the file succeeds but does not provide @var{feature},
@code{require} signals an error about the missing feature.
@end defun
+@defun require-with-check feature &optional filename noerror
+This function works like @code{require}, except if @var{feature} is
+already loaded (i.e.@: is already a member of the list in
+@code{features}, see below). If @var{feature} is already loaded, this
+function checks if @var{feature} was provided by a file different from
+@var{filename}, and if so, it by default signals an error. If the
+value of the optional argument @var{noerror} is @code{reload}, the
+function doesn't signal an error, but instead forcibly reloads
+@var{filename}; if @var{noerror} is some other non-@code{nil} value,
+the function emits a warning about @var{feature} being already
+provided by another file.
+@end defun
+
@defun featurep feature &optional subfeature
This function returns @code{t} if @var{feature} has been provided in
the current Emacs session (i.e., if @var{feature} is a member of
diff --git a/doc/lispref/markers.texi b/doc/lispref/markers.texi
index 3037790692c..a13edb02ae6 100644
--- a/doc/lispref/markers.texi
+++ b/doc/lispref/markers.texi
@@ -283,6 +283,14 @@ This function returns the position that @var{marker} points to, or
@code{nil} if it points nowhere.
@end defun
+@defun marker-last-position marker
+This function returns the last known position of @var{marker} in its
+buffer. It behaves like @code{marker-position} with one exception: if
+the buffer of @var{marker} has been killed, it returns the last position
+of @var{marker} in that buffer before the buffer was killed, instead of
+returning @code{nil}.
+@end defun
+
@defun marker-buffer marker
This function returns the buffer that @var{marker} points into, or
@code{nil} if it points nowhere.
diff --git a/doc/lispref/minibuf.texi b/doc/lispref/minibuf.texi
index 65a9dca52f4..8f2d0d702f9 100644
--- a/doc/lispref/minibuf.texi
+++ b/doc/lispref/minibuf.texi
@@ -1543,7 +1543,8 @@ that it uses the predicate @code{custom-variable-p} instead of
@code{commandp}.
@end defun
-@deffn Command read-color &optional prompt convert allow-empty display
+@deffn Command read-color &optional prompt convert allow-empty @
+ display foreground face
This function reads a string that is a color specification, either the
color's name or an RGB hex value such as @code{#RRRGGGBBB}. It
prompts with @var{prompt} (default: @code{"Color (name or #RGB triplet):"})
@@ -1563,6 +1564,13 @@ non-@code{nil} and the user enters null input.
Interactively, or when @var{display} is non-@code{nil}, the return
value is also displayed in the echo area.
+
+The optional arguments @var{foreground} and @var{face} control the
+appearance of the completion candidates in the @file{*Completions*}
+buffer. The candidates are displayed in the specified @var{face} but
+with different colors: if @var{foreground} is non-@code{nil}, the
+foreground color is changed to be the color of the candidate,
+otherwise the background is changed to the candidate's color.
@end deffn
See also the functions @code{read-coding-system} and
@@ -1872,10 +1880,31 @@ The value should be a list of completion styles (symbols).
The value should be a value for @code{completion-cycle-threshold}
(@pxref{Completion Options,,, emacs, The GNU Emacs Manual}) for this
category.
+
+@item cycle-sort-function
+The function to sort entries when cycling.
+
+@item display-sort-function
+The function to sort entries in the @file{*Completions*} buffer.
+The possible values are: @code{nil}, which means to use either the
+sorting function from metadata or if that is @code{nil}, fall back to
+@code{completions-sort}; @code{identity}, which means not to sort at
+all, leaving the original order; or any other value out of those used
+in @code{completions-sort} (@pxref{Completion Options,,, emacs, The
+GNU Emacs Manual}).
+
+@item group-function
+The function to group completions.
+
+@item annotation-function
+The function to add annotations to completions.
+
+@item affixation-function
+The function to add prefixes and suffixes to completions.
@end table
@noindent
-Additional alist entries may be defined in the future.
+See @ref{Programmed Completion}, for a complete list of metadata entries.
@end defopt
@defvar completion-extra-properties
@@ -1885,6 +1914,12 @@ completion commands. Its value should be a list of property and value
pairs. The following properties are supported:
@table @code
+@item :category
+The value should be a symbol describing what kind of text the
+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}.
+
@item :annotation-function
The value should be a function to add annotations in the completions
buffer. This function must accept one argument, a completion, and
@@ -1901,6 +1936,15 @@ element of the returned list must be a three-element list, the
completion, a prefix string, and a suffix string. This function takes
priority over @code{:annotation-function}.
+@item :group-function
+The function to group completions.
+
+@item :display-sort-function
+The function to sort entries in the @file{*Completions*} buffer.
+
+@item :cycle-sort-function
+The function to sort entries when cycling.
+
@item :exit-function
The value should be a function to run after performing completion.
The function should accept two arguments, @var{string} and
@@ -2238,6 +2282,9 @@ the expected answers (@kbd{y}, @kbd{n}, @kbd{@key{SPC}},
@kbd{@key{DEL}}, or something that quits), the function responds
@samp{Please answer y or n.}, and repeats the request.
+If @var{prompt} is a non-empty string, and it ends with a non-space
+character, a @samp{SPC} character will be appended to it.
+
This function actually uses the minibuffer, but does not allow editing
of the answer. The cursor moves to the minibuffer while the question
is being asked.
@@ -2271,10 +2318,15 @@ minibuffer. It returns @code{t} if the user enters @samp{yes},
@code{nil} if the user types @samp{no}. The user must type @key{RET} to
finalize the response. Upper and lower case are equivalent.
-@code{yes-or-no-p} starts by displaying @var{prompt} in the minibuffer,
-followed by @w{@samp{(yes or no) }}. The user must type one of the
-expected responses; otherwise, the function responds @samp{Please answer
-yes or no.}, waits about two seconds and repeats the request.
+@vindex yes-or-no-prompt
+@code{yes-or-no-p} starts by displaying @var{prompt} in the
+minibuffer, followed by the value of @code{yes-or-no-prompt} @w{(default
+@samp{(yes or no) })}. The user must type one of the expected
+responses; otherwise, the function responds @w{@samp{Please answer yes or
+no.}}, waits about two seconds and repeats the request.
+
+If @var{prompt} is a non-empty string, and it ends with a non-space
+character, a @samp{SPC} character will be appended to it.
@code{yes-or-no-p} requires more work from the user than
@code{y-or-n-p} and is appropriate for more crucial decisions.
@@ -2512,6 +2564,14 @@ times match.
The optional argument @var{default} specifies the default password to
return if the user enters empty input. If @var{default} is @code{nil},
then @code{read-passwd} returns the null string in that case.
+
+This function uses @code{read-passwd-mode}, a minor mode. It binds two
+keys in the minbuffer: @kbd{C-u} (@code{delete-minibuffer-contents})
+deletes the password, and @kbd{TAB}
+(@code{read-passwd--toggle-visibility}) toggles the visibility of the
+password. There is also an additional icon in the mode-line. Clicking
+on this icon with @key{mouse-1} toggles the visibility of the password
+as well.
@end defun
@node Minibuffer Commands
@@ -2662,7 +2722,7 @@ variable instead (@pxref{Echo Area Customization}).
The option @code{resize-mini-windows} does not affect the behavior of
minibuffer-only frames (@pxref{Frame Layout}). The following option
-allows to automatically resize such frames as well.
+enables automatically resizing such frames as well.
@defopt resize-mini-frames
If this is @code{nil}, minibuffer-only frames are never resized
@@ -2870,3 +2930,22 @@ This is the major mode used in inactive minibuffers. It uses
keymap @code{minibuffer-inactive-mode-map}. This can be useful
if the minibuffer is in a separate frame. @xref{Minibuffers and Frames}.
@end deffn
+
+@deffn Command minibuffer-regexp-mode
+This minor mode makes editing regular expressions in the minibuffer
+more convenient. It highlight parens via @code{show-paren-mode} and
+@code{blink-matching-paren} in a user-friendly way, avoids reporting
+false paren mismatches, and makes sexp navigation more intuitive.
+@end deffn
+
+By default, only certain minibuffer prompts automatically activate the
+convenience features of @code{minibuffer-regexp-mode} when the
+minibuffer becomes active. This list of prompts can be customized via
+@code{minibuffer-regexp-prompts}.
+
+@defopt minibuffer-regexp-prompts
+This variable holds the list of regular expressions for activating the
+features of @code{minibuffer-regexp-mode} in the minibuffer. The
+mode's features will be activated only if the minibuffer prompt
+matches one of the regular expressions in the list.
+@end defopt
diff --git a/doc/lispref/modes.texi b/doc/lispref/modes.texi
index 9fe4d332a21..b034fecd77b 100644
--- a/doc/lispref/modes.texi
+++ b/doc/lispref/modes.texi
@@ -25,6 +25,7 @@ user. For related topics such as keymaps and syntax tables, see
* Minor Modes:: Defining minor modes.
* Mode Line Format:: Customizing the text that appears in the mode line.
* Imenu:: Providing a menu of definitions made in a buffer.
+* Outline Minor Mode:: Outline mode to use with other major modes.
* Font Lock Mode:: How modes can highlight text according to syntax.
* Auto-Indentation:: How to teach Emacs to indent for a major mode.
* Desktop Save Mode:: How modes can have buffer state saved between
@@ -508,6 +509,12 @@ variable @code{imenu-generic-expression}, for the two variables
@code{imenu-create-index-function} (@pxref{Imenu}).
@item
+The mode should specify how Outline minor mode should find the
+heading lines, by setting up a buffer-local value for the variables
+@code{outline-regexp} or @code{outline-search-function}, and also
+for the variable @code{outline-level} (@pxref{Outline Minor Mode}).
+
+@item
The mode can tell ElDoc mode how to retrieve different types of
documentation for whatever is at point, by adding one or more
buffer-local entries to the special hook
@@ -784,6 +791,39 @@ init file.)
@end smallexample
@end defvar
+@defvar major-mode-remap-defaults
+This variable contains an association list indicating which function
+to call to activate a given major mode. This is used for file formats
+that can be supported by various major modes, where this variable can be
+used to indicate which alternative should be used by default.
+
+For example, a third-party package providing a much improved Pascal
+major mode, can use the following to tell @code{normal-mode} to use
+@code{spiffy-pascal-mode} for all the files that would normally use @code{pascal-mode}:
+
+@smallexample
+@group
+(add-to-list 'major-mode-remap-defaults '(pascal-mode . spiffy-pascal-mode))
+@end group
+@end smallexample
+
+This variable has the same format as @code{major-mode-remap-alist}.
+If both lists match a major mode, the entry in
+@code{major-mode-remap-alist} takes precedence.
+@end defvar
+
+@defun major-mode-remap mode
+This function returns the major mode to use instead of @var{mode}
+according to @code{major-mode-remap-alist} and
+@code{major-mode-remap-defaults}. It returns @var{mode} if the mode
+is not remapped by those variables.
+
+When a package wants to activate a major mode for a particular file
+format, it should use this function, passing as @code{mode} argument the
+canonical major mode for that file format, to find which specific major
+mode to activate, so as to take into account the user's preferences.
+@end defun
+
@node Mode Help
@subsection Getting Help about a Major Mode
@cindex mode help
@@ -809,6 +849,7 @@ modes, rather than those of the current buffer.
@node Derived Modes
@subsection Defining Derived Modes
@cindex derived mode
+@cindex parent mode
The recommended way to define a new major mode is to derive it from an
existing one using @code{define-derived-mode}. If there is no closely
@@ -866,6 +907,9 @@ also a special mode (@pxref{Major Mode Conventions}).
You can also specify @code{nil} for @var{parent}. This gives the new
mode no parent. Then @code{define-derived-mode} behaves as described
above, but, of course, omits all actions connected with @var{parent}.
+Conversely, you can use @code{derived-mode-set-parent} and
+@code{derived-mode-add-parents}, described below, to explicitly set
+the ancestry of the new mode.
The argument @var{docstring} specifies the documentation string for the
new mode. @code{define-derived-mode} adds some general information
@@ -932,11 +976,65 @@ Do not write an @code{interactive} spec in the definition;
@code{define-derived-mode} does that automatically.
@end defmac
-@defun derived-mode-p &rest modes
+@cindex ancestry, of major modes
+@defun derived-mode-p modes
This function returns non-@code{nil} if the current major mode is
-derived from any of the major modes given by the symbols @var{modes}.
+derived from any of the major modes given by the list of symbols
+in @var{modes}.
+Instead of a list, @var{modes} can also be a single mode symbol.
+
+Furthermore, we still support a deprecated calling convention where the
+@var{modes} were passed as separate arguments.
+
+When examining the parent modes of the current major mode, this
+function takes into consideration the current mode's parents set by
+@code{define-derived-mode}, and also its additional parents set by
+@code{derived-mode-add-parents}, described below.
+@end defun
+
+@defun provided-mode-derived-p mode modes
+This function returns non-@code{nil} if @var{mode} is derived from any
+of the major modes given by the list of symbols in @var{modes}. Like
+with @code{derived-mode-p}, @var{modes} can also be a single symbol,
+and this function also supports a deprecated calling convention where
+the @var{modes} were passed as separate symbol arguments.
+
+When examining the parent modes of @var{mode}, this function takes
+into consideration the parents of @var{mode} set by
+@code{define-derived-mode}, and also its additional parents set by
+@code{derived-mode-add-parents}, described below.
@end defun
+The graph of a major mode's ancestry can be accessed and modified with
+the following lower-level functions:
+
+@defun derived-mode-set-parent mode parent
+This function declares that @var{mode} inherits from @code{parent}.
+This is the function that @code{define-derived-mode} calls after
+defining @var{mode} to register the fact that @var{mode} was defined
+by reusing @code{parent}.
+@end defun
+
+@defun derived-mode-add-parents mode extra-parents
+This function makes it possible to register additional parents beside
+the one that was used when defining @var{mode}. This can be used when
+the similarity between @var{mode} and the modes in @var{extra-parents}
+is such that it makes sense to treat @var{mode} as a child of those
+modes for purposes like applying directory-local variables and other
+mode-specific settings. The additional parent modes are specified as
+a list of symbols in @var{extra-parents}. Those additional parent
+modes will be considered as one of the @var{mode}s parents by
+@code{derived-mode-p} and @code{provided-mode-derived-p}.
+@end defun
+
+@defun derived-mode-all-parents mode
+This function returns the list of all the modes in the ancestry of
+@var{mode}, ordered from the most specific to the least specific, and
+starting with @var{mode} itself. This includes the additional parent
+modes, if any, added by calling @code{derived-mode-add-parents}.
+@end defun
+
+
@node Basic Major Modes
@subsection Basic Major Modes
@@ -956,9 +1054,9 @@ allows users to customize a single mode hook
@deffn Command text-mode
Text mode is a major mode for editing human languages. It defines the
@samp{"} and @samp{\} characters as having punctuation syntax
-(@pxref{Syntax Class Table}), and binds @kbd{M-@key{TAB}} to
-@code{ispell-complete-word} (@pxref{Spelling,,, emacs, The GNU Emacs
-Manual}).
+(@pxref{Syntax Class Table}), and arranges for
+@code{completion-at-point} to complete words based on the spelling
+dictionary (@pxref{Completion in Buffers}).
An example of a major mode derived from Text mode is HTML mode.
@xref{HTML Mode,,SGML and HTML Modes, emacs, The GNU Emacs Manual}.
@@ -1181,6 +1279,42 @@ Otherwise, the value should be a function which returns a list of the
above form when called with no arguments.
@end defvar
+@defvar tabulated-list-groups
+This buffer-local variable specifies the groups of entries displayed in
+the Tabulated List buffer. Its value should be either a list or a
+function.
+
+If the value is a list, each list element corresponds to one group, and
+should have the form @w{@code{(@var{group-name} @var{entries})}}, where
+@var{group-name} is a string inserted before all group entries, and
+@var{entries} have the same format as @code{tabulated-list-entries}
+(see above).
+
+Otherwise, the value should be a function which returns a list of the
+above form when called with no arguments.
+
+You can use @code{seq-group-by} to create @code{tabulated-list-groups}
+from @code{tabulated-list-entries}. For example:
+
+@smallexample
+@group
+(setq tabulated-list-groups
+ (seq-group-by 'Buffer-menu-group-by-mode
+ tabulated-list-entries))
+@end group
+@end smallexample
+
+@noindent
+where you can define @code{Buffer-menu-group-by-mode} like this:
+
+@smallexample
+@group
+(defun Buffer-menu-group-by-mode (entry)
+ (concat "* " (aref (cadr entry) 5)))
+@end group
+@end smallexample
+@end defvar
+
@defvar tabulated-list-revert-hook
This normal hook is run prior to reverting a Tabulated List buffer. A
derived mode can add a function to this hook to recompute
@@ -1359,15 +1493,6 @@ the conventions listed above:
st)
"Syntax table used while in `text-mode'.")
@end group
-
-;; @r{Create the keymap for this mode.}
-@group
-(defvar-keymap text-mode-map
- :doc "Keymap for `text-mode'.
-Many other modes, such as `mail-mode' and `outline-mode', inherit all
-the commands defined in this map."
- "C-M-i" #'ispell-complete-word)
-@end group
@end smallexample
Here is how the actual mode command is defined now:
@@ -1801,10 +1926,6 @@ and will always be loaded by that time, enabling it by default is
harmless. But these are unusual circumstances. Normally, the
initial value must be @code{nil}.
-@findex easy-mmode-define-minor-mode
- The name @code{easy-mmode-define-minor-mode} is an alias
-for this macro.
-
Here is an example of using @code{define-minor-mode}:
@smallexample
@@ -2284,6 +2405,16 @@ current buffer is remote.
This variable is used to identify @code{emacsclient} frames.
@end defvar
+@defvar mode-line-format-right-align
+Anything following this symbol in @code{mode-line-format} will be
+right-aligned.
+@end defvar
+
+@defvar mode-line-right-align-edge
+This variable controls exactly @code{mode-line-format-right-align}
+aligns content to.
+@end defvar
+
The following three variables are used in @code{mode-line-modes}:
@defvar mode-name
@@ -2408,6 +2539,7 @@ specifies addition of text properties.
@node %-Constructs
@subsection @code{%}-Constructs in the Mode Line
+@cindex @code{%}-constructs in the mode line
Strings used as mode line constructs can use certain
@code{%}-constructs to substitute various kinds of data. The
@@ -2498,6 +2630,9 @@ The mnemonics of keyboard, terminal, and buffer coding systems.
@item %Z
Like @samp{%z}, but including the end-of-line format.
+@item %&
+@samp{*} if the buffer is modified, and @samp{-} otherwise.
+
@item %*
@samp{%} if the buffer is read only (see @code{buffer-read-only}); @*
@samp{*} if the buffer is modified (see @code{buffer-modified-p}); @*
@@ -2509,9 +2644,6 @@ Like @samp{%z}, but including the end-of-line format.
@samp{-} otherwise. This differs from @samp{%*} only for a modified
read-only buffer. @xref{Buffer Modification}.
-@item %&
-@samp{*} if the buffer is modified, and @samp{-} otherwise.
-
@item %@@
@samp{@@} if the buffer's @code{default-directory} (@pxref{File Name
Expansion}) is on a remote machine, and @samp{-} otherwise.
@@ -2945,6 +3077,61 @@ instead.
automatically sets up Imenu if this variable is non-@code{nil}.
@end defvar
+@node Outline Minor Mode
+@section Outline Minor Mode
+
+@cindex Outline minor mode
+ @dfn{Outline minor mode} is a buffer-local minor mode that hides
+parts of the buffer and leaves only heading lines visible.
+This minor mode can be used in conjunction with other major modes
+(@pxref{Outline Minor Mode,, Outline Minor Mode, emacs, the Emacs Manual}).
+
+ There are two ways to define which lines are headings: with the
+variable @code{outline-regexp} or @code{outline-search-function}.
+
+@defvar outline-regexp
+This variable is a regular expression.
+Any line whose beginning has a match for this regexp is considered a
+heading line. Matches that start within a line (not at the left
+margin) do not count.
+@end defvar
+
+@defvar outline-search-function
+Alternatively, when it's impossible to create a regexp that
+matches heading lines, you can define a function that helps
+Outline minor mode to find heading lines.
+
+The variable @code{outline-search-function} specifies the function with
+four arguments: @var{bound}, @var{move}, @var{backward}, and
+@var{looking-at}. The function completes two tasks: to match the
+current heading line, and to find the next or the previous heading line.
+If the argument @var{looking-at} is non-@code{nil}, it should return
+non-@code{nil} when point is at the beginning of the outline header line.
+If the argument @var{looking-at} is @code{nil}, the first three arguments
+are used. The argument @var{bound} is a buffer position that bounds
+the search. The match found must not end after that position. A
+value of nil means search to the end of the accessible portion of
+the buffer. If the argument @var{move} is non-@code{nil}, the
+failed search should move to the limit of search and return nil.
+If the argument @var{backward} is non-@code{nil}, this function
+should search for the previous heading backward.
+@end defvar
+
+@defvar outline-level
+This variable is a function that takes no arguments
+and should return the level of the current heading.
+It's required in both cases: whether you define
+@code{outline-regexp} or @code{outline-search-function}.
+@end defvar
+
+If built with tree-sitter, Emacs can automatically use
+Outline minor mode if the major mode sets the following variable.
+
+@defvar treesit-outline-predicate
+This variable instructs Emacs how to find lines with outline headings.
+It should be a predicate that matches the node on the heading line.
+@end defvar
+
@node Font Lock Mode
@section Font Lock Mode
@cindex Font Lock mode
@@ -4151,7 +4338,7 @@ it add meta information to it. The @code{:language} keyword declares
name of @var{query}. Users can control which features are enabled
with @code{treesit-font-lock-level} and
@code{treesit-font-lock-feature-list} (described below). These two
-keywords are mandatory.
+keywords are mandatory (with exceptions).
Other keywords are optional:
@@ -4163,6 +4350,9 @@ Other keywords are optional:
@item @tab @code{append} @tab Append the new face to existing ones
@item @tab @code{prepend} @tab Prepend the new face to existing ones
@item @tab @code{keep} @tab Fill-in regions without an existing face
+@item @code{:default-language} @tab @var{language}
+@tab Every @var{query} after this keyword will use @var{language}
+by default.
@end multitable
Lisp programs mark patterns in @var{query} with capture names (names
diff --git a/doc/lispref/nonascii.texi b/doc/lispref/nonascii.texi
index c0bcddb5b9b..b33082e2b24 100644
--- a/doc/lispref/nonascii.texi
+++ b/doc/lispref/nonascii.texi
@@ -133,7 +133,7 @@ This function is similar to @code{position-bytes}, but instead of byte
position in the current buffer it returns the offset from the
beginning of the current buffer's file of the byte that corresponds to
the given character @var{position} in the buffer. The conversion
-requires to know how the text is encoded in the buffer's file; this is
+requires knowing how the text is encoded in the buffer's file; this is
what the @var{coding-system} argument is for, defaulting to the value
of @code{buffer-file-coding-system}. The optional argument
@var{quality} specifies how accurate the result should be; it should
@@ -1181,7 +1181,7 @@ the text to be written cannot be safely encoded using the coding system
specified by this variable, these operations select an alternative
encoding by calling the function @code{select-safe-coding-system}
(@pxref{User-Chosen Coding Systems}). If selecting a different encoding
-requires to ask the user to specify a coding system,
+requires asking the user to specify a coding system,
@code{buffer-file-coding-system} is updated to the newly selected coding
system.
diff --git a/doc/lispref/numbers.texi b/doc/lispref/numbers.texi
index 791ce1b9a6b..2c093ccd6bd 100644
--- a/doc/lispref/numbers.texi
+++ b/doc/lispref/numbers.texi
@@ -270,10 +270,6 @@ two NaNs as equal when their
signs and significands agree. Significands of NaNs are
machine-dependent, as are the digits in their string representation.
- NaNs are not available on systems which do not use IEEE
-floating-point arithmetic; if the read syntax for a NaN is used on a
-VAX, for example, the reader signals an error.
-
When NaNs and signed zeros are involved, non-numeric functions like
@code{eql}, @code{equal}, @code{sxhash-eql}, @code{sxhash-equal} and
@code{gethash} determine whether values are indistinguishable, not
@@ -292,6 +288,12 @@ Here are read syntaxes for these special floating-point values:
@samp{0.0e+NaN} and @samp{-0.0e+NaN}
@end table
+ Infinities and NaNs are not available on legacy systems that lack
+IEEE floating-point arithmetic. On a circa 1980 VAX, for example,
+Lisp reads @samp{1.0e+INF} as a large but finite floating-point number,
+and @samp{0.0e+NaN} as some other non-numeric Lisp object that provokes an
+error if used numerically.
+
The following functions are specialized for handling floating-point
numbers:
@@ -474,6 +476,7 @@ This function tests whether its arguments are numerically equal, and
returns @code{t} if they are not, and @code{nil} if they are.
@end defun
+@anchor{definition of <}
@defun < number-or-marker &rest number-or-markers
This function tests whether each argument is strictly less than the
following argument. It returns @code{t} if so, @code{nil} otherwise.
diff --git a/doc/lispref/objects.texi b/doc/lispref/objects.texi
index 7b2a4af303f..aa1e073042f 100644
--- a/doc/lispref/objects.texi
+++ b/doc/lispref/objects.texi
@@ -60,6 +60,7 @@ to use these types can be found in later chapters.
* Type Predicates:: Tests related to types.
* Equality Predicates:: Tests of equality between any two objects.
* Mutability:: Some objects should not be modified.
+* Type Hierarchy:: Type Hierarchy of Emacs Lisp objects.
@end menu
@node Printed Representation
@@ -1374,8 +1375,7 @@ and contents, like this:
@example
(make-hash-table)
- @result{} #s(hash-table size 65 test eql rehash-size 1.5
- rehash-threshold 0.8125 data ())
+ @result{} #s(hash-table)
@end example
@noindent
@@ -1485,8 +1485,8 @@ types that are not built into Emacs.
@subsection Type Descriptors
A @dfn{type descriptor} is a @code{record} which holds information
-about a type. Slot 1 in the record must be a symbol naming the type, and
-@code{type-of} relies on this to return the type of @code{record}
+about a type. The first slot in the record must be a symbol naming the type,
+and @code{type-of} relies on this to return the type of @code{record}
objects. No other type descriptor slot is used by Emacs; they are
free for use by Lisp extensions.
@@ -2122,6 +2122,9 @@ with references to further information.
@item numberp
@xref{Predicates on Numbers, numberp}.
+@item obarrayp
+@xref{Creating Symbols, obarrayp}.
+
@item overlayp
@xref{Overlays, overlayp}.
@@ -2172,7 +2175,7 @@ with references to further information.
function @code{type-of}. Recall that each object belongs to one and
only one primitive type; @code{type-of} tells you which one (@pxref{Lisp
Data Types}). But @code{type-of} knows nothing about non-primitive
-types. In most cases, it is more convenient to use type predicates than
+types. In most cases, it is preferable to use type predicates than
@code{type-of}.
@defun type-of object
@@ -2182,7 +2185,7 @@ This function returns a symbol naming the primitive type of
@code{condition-variable}, @code{cons}, @code{finalizer},
@code{float}, @code{font-entity}, @code{font-object},
@code{font-spec}, @code{frame}, @code{hash-table}, @code{integer},
-@code{marker}, @code{mutex}, @code{overlay}, @code{process},
+@code{marker}, @code{mutex}, @code{obarray}, @code{overlay}, @code{process},
@code{string}, @code{subr}, @code{symbol}, @code{thread},
@code{vector}, @code{window}, or @code{window-configuration}.
However, if @var{object} is a record, the type specified by its first
@@ -2204,6 +2207,27 @@ slot is returned; @ref{Records}.
@end example
@end defun
+@defun cl-type-of object
+This function returns a symbol naming @emph{the} type of
+@var{object}. It usually behaves like @code{type-of}, except
+that it guarantees to return the most precise type possible, which also
+implies that the specific type it returns may change depending on the
+Emacs version. For this reason, as a rule you should never compare its
+return value against some fixed set of types.
+
+@example
+(cl-type-of 1)
+ @result{} fixnum
+@group
+(cl-type-of 'nil)
+ @result{} null
+(cl-type-of (record 'foo))
+ @result{} foo
+@end group
+@end example
+@end defun
+
+
@node Equality Predicates
@section Equality Predicates
@cindex equality
@@ -2234,6 +2258,10 @@ and the same non-fixnum numeric type, then they might or might not be
the same object, and @code{eq} returns @code{t} or @code{nil}
depending on whether the Lisp interpreter created one object or two.
+If @var{object1} or @var{object2} is a symbol with position, @code{eq}
+regards it as its bare symbol when @code{symbols-with-pos-enabled} is
+non-@code{nil} (@pxref{Symbols with Position}).
+
@example
@group
(eq 'foo 'foo)
@@ -2391,6 +2419,13 @@ same sequence of character codes and all these codes are in the range
The @code{equal} function recursively compares the contents of objects
if they are integers, strings, markers, vectors, bool-vectors,
byte-code function objects, char-tables, records, or font objects.
+
+If @var{object1} or @var{object2} contains symbols with position,
+@code{equal} treats them as if they were their bare symbols when
+@code{symbols-with-pos-enabled} is non-@code{nil}. Otherwise
+@code{equal} compares two symbols with position by
+comparing their components. @xref{Symbols with Position}.
+
Other objects are considered @code{equal} only if they are @code{eq}.
For example, two distinct buffers are never considered @code{equal},
even if their textual contents are the same.
@@ -2483,3 +2518,26 @@ their components. For example, @code{(eq "abc" "abc")} returns
literal @code{"abc"}, and returns @code{nil} if it creates two
instances. Lisp programs should be written so that they work
regardless of whether this optimization is in use.
+
+@node Type Hierarchy
+@section Type Hierarchy of Emacs Lisp Objects
+
+Lisp object types are organized in a hierarchy, which means that types
+can derive from other types. Objects of type B (which derives from type
+A) inherit all the characteristics of type A@. This also means that
+every object of type B is at the same time an object of type A from
+which it derives.
+
+Every type derives from type @code{t}.
+
+New types can be defined by the user through @code{defclass} or
+@code{cl-defstruct}.
+
+The Lisp Type Hierarchy for primitive types can be represented as
+follows:
+
+@noindent
+@image{elisp_type_hierarchy,,,,.jpg}
+
+For example type @code{list} derives from (is a special kind of) type
+@code{sequence} which itself derives from @code{t}.
diff --git a/doc/lispref/os.texi b/doc/lispref/os.texi
index c8c64ddde89..3ba3da459bf 100644
--- a/doc/lispref/os.texi
+++ b/doc/lispref/os.texi
@@ -972,6 +972,9 @@ Hewlett-Packard HPUX operating system.
@item nacl
Google Native Client (@acronym{NaCl}) sandboxing system.
+@item android
+The Open Handset Alliance's Android operating system.
+
@item ms-dos
Microsoft's DOS@. Emacs compiled with DJGPP for MS-DOS binds
@code{system-type} to @code{ms-dos} even when you run it on MS-Windows.
@@ -1279,13 +1282,33 @@ This function returns the real @acronym{UID} of the user.
This function returns the effective @acronym{UID} of the user.
@end defun
+@defun file-user-uid
+This function returns the connection-local value for the user's
+effective @acronym{UID}. If @code{default-directory} is local, this
+is equivalent to @code{user-uid}, but for remote files (@pxref{Remote
+Files, , , emacs, The GNU Emacs Manual}), it will return the
+@acronym{UID} for the user associated with that remote connection; if
+the remote connection has no associated user, it will instead return
+-1.
+@end defun
+
@cindex GID
+@defun group-real-gid
+This function returns the real @acronym{GID} of the Emacs process.
+@end defun
+
@defun group-gid
This function returns the effective @acronym{GID} of the Emacs process.
@end defun
-@defun group-real-gid
-This function returns the real @acronym{GID} of the Emacs process.
+@defun file-group-gid
+This function returns the connection-local value for the user's
+effective @acronym{GID}. Similar to @code{file-user-uid}, if
+@code{default-directory} is local, this is equivalent to
+@code{group-gid}, but for remote files (@pxref{Remote Files, , ,
+emacs, The GNU Emacs Manual}), it will return the @acronym{GID} for
+the user associated with that remote connection; if the remote
+connection has no associated user, it will instead return -1.
@end defun
@defun system-users
@@ -2852,7 +2875,9 @@ Emacs is restarted by the session manager.
@cindex notifications, on desktop
Emacs is able to send @dfn{notifications} on systems that support the
-freedesktop.org Desktop Notifications Specification and on MS-Windows.
+freedesktop.org Desktop Notifications Specification, MS-Windows,
+Haiku, and Android.
+
In order to use this functionality on POSIX hosts, Emacs must have
been compiled with D-Bus support, and the @code{notifications} library
must be loaded. @xref{Top, , D-Bus,dbus,D-Bus integration in Emacs}.
@@ -2890,6 +2915,13 @@ must be the result of a previous @code{notifications-notify} call.
@item :app-icon @var{icon-file}
The file name of the notification icon. If set to @code{nil}, no icon
is displayed. The default is @code{notifications-application-icon}.
+If the value is a string, the function interprets it as a file name
+and converts to absolute by using @code{expand-file-name}; if it is a
+symbol, the function will use its name (which is useful when using the
+Icon Naming Specification @footnote{For more information about icon
+naming convention see
+@uref{https://specifications.freedesktop.org/icon-naming-spec/icon-naming-spec-latest.html,
+Icon Naming Specification}}).
@item :actions (@var{key} @var{title} @var{key} @var{title} ...)
A list of actions to be applied. @var{key} and @var{title} are both
@@ -3162,6 +3194,103 @@ This function removes the tray notification given by its unique
@var{id}.
@end defun
+@cindex desktop notifications, Haiku
+When Emacs runs under Haiku as a GUI program, it is also provides a
+restricted pastiche of the D-Bus desktop notifications interface
+previously addressed. The principle capabilities absent from the
+function detailed below are call-back functions such as
+@code{:actions}, @code{:on-action} and @code{:on-close}.
+
+@defun haiku-notifications-notify &rest params
+This function sends a notification to the desktop notification server,
+incorporating a number of parameters that are akin to some of those
+accepted by @code{notifications-notify}. The parameters are:
+
+@table @code
+@item :title @var{title}
+@item :body @var{body}
+@item :replaces-id @var{replaces-id}
+@item :urgency @var{urgency}
+These have the same meaning as they do when used in calls to
+@code{notifications-notify}.
+
+@item :app-icon @var{app-icon}
+This should be the file name designating an image file to use as the
+icon for the notification displayed. If @code{nil}, the icon
+presented will instead be Emacs's app icon.
+@end table
+
+Its return value is a number identifying the notification, which can
+be exploited as the @code{:replaces-id} parameter to a subsequent call
+to this function.
+@end defun
+
+@cindex desktop notifications, Android
+When Emacs is built as an Android application package, displaying
+notifications is facilitated by the function
+@code{android-notifications-notify}. This function does not feature
+call-backs, and has several idiosyncrasies, when compared to
+@code{notifications-notify}.
+
+@defun android-notifications-notify &rest params
+This function displays a desktop notification. @var{params} is a list
+of parameters analogous to its namesake in
+@code{notifications-notify}. The parameters are:
+
+@table @code
+@item :title @var{title}
+@item :body @var{body}
+@item :replaces-id @var{replaces-id}
+@item :on-action @var{on-action}
+@item :on-cancel @var{on-close}
+@item :actions @var{actions}
+@item :timeout @var{timeout}
+@item :resident @var{resident}
+These have the same meaning as they do when used in calls to
+@code{notifications-notify}, except that no more than three non-default
+actions will be displayed.
+
+@item :urgency @var{urgency}
+The set of accepted values for @var{urgency} is the same as with
+@code{notifications-notify}, but the urgency applies to all
+notifications displayed with the defined @var{group}, except under
+Android 7.1 and earlier.
+
+@item :group @var{group}
+@var{group} is a string that designates a category to which the
+notification sent will belong. This category is reproduced within the
+system's notification settings menus, but is ignored under Android 7.1
+and earlier.
+
+If @var{group} is nil or not present within @var{params}, it is
+replaced by the string @samp{"Desktop Notifications"}.
+
+Callers should provide one stable combination of @var{urgency} and
+@var{group} for each kind of notification they send, given that the
+system may elect to disregard @var{urgency} if it does not match that
+of any notification previously delivered to @var{group}.
+
+@item :icon @var{icon}
+This parameter controls the symbolic icon the notification will be
+displayed with. Its value is a string designating an icon within the
+@code{android.R.drawable} system package. See
+@uref{https://developer.android.com/reference/android/R.drawable,R.drawable
+| Android Developers} for a list of such icons.
+
+If it is not provided within @var{params} or @var{icon} does not
+exist, it defaults to @samp{"ic_dialog_alert"}.
+@end table
+
+It returns a number identifying the notification, which may be
+supplied as the @code{:replaces-id} parameter to a later call to this
+function.
+
+If Emacs is not afforded the permission to display notifications
+(@pxref{Android Environment,,, emacs, The GNU Emacs Manual}) under
+Android 13 and later, any notifications sent will be silently
+disregarded.
+@end defun
+
@node File Notifications
@section Notifications on File Changes
@cindex file notifications
@@ -3257,7 +3386,8 @@ reliably report file attribute changes when watching a directory.
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
+because the filesystem of the file being watched was unmounted, 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
diff --git a/doc/lispref/package.texi b/doc/lispref/package.texi
index f75023d4039..421e64dd5d1 100644
--- a/doc/lispref/package.texi
+++ b/doc/lispref/package.texi
@@ -28,6 +28,7 @@ these archives).
* Multi-file Packages:: How to package multiple files.
* Package Archives:: Maintaining package archives.
* Archive Web Server:: Interfacing to an archive web server.
+* Forwards-Compatibility:: Supporting older versions of Emacs.
@end menu
@node Packaging Basics
@@ -399,3 +400,50 @@ Return the file. This will be the tarball for a multi-file
package, or the single file for a simple package.
@end table
+
+@node Forwards-Compatibility
+@section Supporting older versions of Emacs
+@cindex compatibility compat
+
+Packages that wish to support older releases of Emacs, without giving
+up on newer functionality from recent Emacs releases, one can make use
+of the Compat package on GNU ELPA. By depending on the package, Emacs
+can provide compatibility definitions for missing functionality.
+
+The versioning of Compat follows that of Emacs, so next to the oldest
+version that a package relies on (via the @code{emacs}-package), one
+can also indicate what the newest version of Emacs is, that a package
+wishes to use definitions from:
+
+@example
+;; Package-Requires: ((emacs "27.2") (compat "29.1"))
+@end example
+
+Note that Compat provides replacement functions with extended
+functionality for functions that are already defined (@code{sort},
+@code{assoc}, @dots{}). These functions may have changed their
+calling convention (additional optional arguments) or may have changed
+their behavior. These functions must be looked up explicitly with
+@code{compat-function} or called explicitly with @code{compat-call}.
+We call them @dfn{Extended Definitions}. In contrast, newly @dfn{Added
+Definitions} can be called as usual.
+
+@defmac compat-call fun &rest args
+This macro calls the compatibility function @var{fun} with @var{args}.
+Many functions provided by Compat can be called directly without this
+macro. However in the case where Compat provides an alternative
+version of an existing function, the function call has to go through
+@code{compat-call}.
+@end defmac
+
+@defmac compat-function fun
+This macro returns the compatibility function symbol for @var{fun}.
+See @code{compat-call} for a more convenient macro to directly call
+compatibility functions.
+@end defmac
+
+For further details on how to make use of the package, see
+@ref{Usage,, Usage, compat, "Compat" Manual}. In case you don't have
+the manual installed, you can also read the
+@url{https://elpa.gnu.org/packages/doc/compat.html#Usage, Online
+Compat manual}.
diff --git a/doc/lispref/parsing.texi b/doc/lispref/parsing.texi
index fbd739b76d5..3d2192ace64 100644
--- a/doc/lispref/parsing.texi
+++ b/doc/lispref/parsing.texi
@@ -400,14 +400,17 @@ when deciding whether to enable tree-sitter features.
@cindex creating tree-sitter parsers
@cindex tree-sitter parser, creating
-@defun treesit-parser-create language &optional buffer no-reuse
+@defun treesit-parser-create language &optional buffer no-reuse tag
Create a parser for the specified @var{buffer} and @var{language}
-(@pxref{Language Grammar}). If @var{buffer} is omitted or
-@code{nil}, it stands for the current buffer.
+(@pxref{Language Grammar}), with @var{tag}. If @var{buffer} is
+omitted or @code{nil}, it stands for the current buffer.
By default, this function reuses a parser if one already exists for
-@var{language} in @var{buffer}, but if @var{no-reuse} is
-non-@code{nil}, this function always creates a new parser.
+@var{language} with @var{tag} in @var{buffer}, but if @var{no-reuse}
+is non-@code{nil}, this function always creates a new parser.
+
+@var{tag} can be any symbol except @code{t}, and defaults to
+@code{nil}. Different parsers can have the same tag.
If that buffer is an indirect buffer, its base buffer is used instead.
That is, indirect buffers use their base buffer's parsers. If the
@@ -450,11 +453,17 @@ internal parser list. Every time a change is made to the buffer,
Emacs updates parsers in this list so they can update their syntax
tree incrementally.
-@defun treesit-parser-list &optional buffer
-This function returns the parser list of @var{buffer}. If
-@var{buffer} is @code{nil} or omitted, it defaults to the current
-buffer. If that buffer is an indirect buffer, its base buffer is used
-instead. That is, indirect buffers use their base buffer's parsers.
+@defun treesit-parser-list &optional buffer language tag
+This function returns the parser list of @var{buffer}, filtered by
+@var{language} and @var{tag}. If @var{buffer} is @code{nil} or
+omitted, it defaults to the current buffer. If that buffer is an
+indirect buffer, its base buffer is used instead. That is, indirect
+buffers use their base buffer's parsers.
+
+If @var{language} is non-@var{nil}, only include parsers for that
+language, and only include parsers with @var{tag}. @var{tag} defaults
+to @code{nil}. If @var{tag} is @code{t}, include parsers in the
+returned list regardless of their tag.
@end defun
@defun treesit-parser-delete parser
@@ -696,7 +705,7 @@ This function finds the previous sibling of @var{node}. If
To make the syntax tree easier to analyze, many language grammars
assign @dfn{field names} to child nodes (@pxref{tree-sitter node field
name, field name}). For example, a @code{function_definition} node
-could have a @code{declarator} node and a @code{body} node.
+could have a @code{declarator} child and a @code{body} child.
@defun treesit-node-child-by-field-name node field-name
This function finds the child of @var{node} whose field name is
@@ -848,6 +857,53 @@ Each node in the returned tree looks like
@heading More convenience functions
+@defun treesit-node-get node instructions
+This is a convenience function that chains together multiple node
+accessor functions together. For example, to get @var{node}'s
+parent's next sibling's second child's text:
+
+@example
+@group
+(treesit-node-get node
+ '((parent 1)
+ (sibling 1 nil)
+ (child 1 nil)
+ (text nil)))
+@end group
+@end example
+
+@var{instruction} is a list of INSTRUCTIONs of the form
+@w{@code{(@var{fn} @var{arg}...)}}. The following @var{fn}'s are
+supported:
+
+@table @code
+@item (child @var{idx} @var{named})
+Get the @var{idx}'th child.
+
+@item (parent @var{n})
+Go to parent @var{n} times.
+
+@item (field-name)
+Get the field name of the current node.
+
+@item (type)
+Get the type of the current node.
+
+@item (text @var{no-property})
+Get the text of the current node.
+
+@item (children @var{named})
+Get a list of children.
+
+@item (sibling @var{step} @var{named})
+Get the nth prev/next sibling, negative @var{step} means prev sibling,
+positive means next sibling.
+@end table
+
+Note that arguments like @var{named} and @var{no-property} can't be
+omitted, unlike in their original functions.
+@end defun
+
@defun treesit-filter-child node predicate &optional named
This function finds immediate children of @var{node} that satisfy
@var{predicate}.
@@ -860,9 +916,11 @@ nodes.
@defun treesit-parent-until node predicate &optional include-node
This function repeatedly finds the parents of @var{node}, and returns
-the parent that satisfies @var{predicate}, a function that takes a node as
-argument and returns a boolean that indicates a match. If no parent
-satisfies @var{predicate}, this function returns @code{nil}.
+the parent that satisfies @var{predicate}. @var{predicate} can be
+either a function that takes a node as argument and returns @code{t}
+or @code{nil}, or a regexp matching node type names, or other valid
+predicates described in @var{treesit-thing-settings}. If no parent
+satisfies @var{predicates}, this function returns @code{nil}.
Normally this function only looks at the parents of @var{node} but not
@var{node} itself. But if @var{include-node} is non-@code{nil}, this
@@ -1028,6 +1086,22 @@ This function returns the number of children of @var{node}. If
(@pxref{tree-sitter named node, named node}).
@end defun
+@heading Convenience functions
+
+@defun treesit-node-enclosed-p smaller larger &optional strict
+This function returns non-@code{nil} if @var{smaller} is enclosed in
+@var{larger}. @var{smaller} and @var{larger} can be either a cons
+@code{(@var{beg} . @var{end})} or a node.
+
+Return non-@code{nil} if @var{larger}'s start <= @var{smaller}'s start
+and @var{larger}'s end <= @var{smaller}'s end.
+
+If @var{strict} is @code{t}, compare with < rather than <=.
+
+If @var{strict} is @code{partial}, consider @var{larger} encloses
+@var{smaller} when at least one side is strictly enclosing.
+@end defun
+
@node Pattern Matching
@section Pattern Matching Tree-sitter Nodes
@cindex pattern matching with tree-sitter nodes
@@ -1313,7 +1387,8 @@ Matching is case-sensitive.
@deffn Predicate :pred fn &rest nodes
Matches if function @var{fn} returns non-@code{nil} when passed each
-node in @var{nodes} as arguments.
+node in @var{nodes} as arguments. The function runs with the current
+buffer set to the buffer of node being queried.
@end deffn
Note that a predicate can only refer to capture names that appear in
@@ -1661,6 +1736,20 @@ If @var{query} is a tree-sitter query, it should be preceded by two
specifies the embedded language, and the @code{:host} keyword
specifies the host language.
+@cindex local parser
+If the query is given the @code{:local} keyword whose value is
+@code{t}, the range set by this query has a dedicated local parser;
+otherwise the range shares a parser with other ranges for the same
+language.
+
+By default, a parser sees its ranges as a continuum, rather than
+treating them as separate independent segments. Therefore, if the
+embedded ranges are semantically independent segments, they should be
+processed by local parsers, described below.
+
+Local parser set to a range can be retrieved by
+@code{treesit-local-parsers-at} and @code{treesit-local-parsers-on}.
+
@code{treesit-update-ranges} uses @var{query} to figure out how to set
the ranges for parsers for the embedded language. It queries
@var{query} in a host language parser, computes the ranges which the
@@ -1696,6 +1785,25 @@ language of the buffer text at @var{pos}. This variable is used by
@code{treesit-language-at}.
@end defvar
+@defun treesit-local-parsers-at &optional pos language
+This function returns all the local parsers at @var{pos} in the
+current buffer. @var{pos} defaults to point.
+
+Local parsers are those which only parse a limited region marked by an
+overlay with a non-@code{nil} @code{treesit-parser} property. If
+@var{language} is non-@code{nil}, only return parsers for that
+language.
+@end defun
+
+@defun treesit-local-parsers-on &optional beg end language
+This function is the same as @code{treesit-local-parsers-at}, but it
+returns the local parsers in the range between @var{beg} and @var{end}
+instead of at point.
+
+@var{beg} and @var{end} default to the entire accessible portion of
+the buffer.
+@end defun
+
@node Tree-sitter Major Modes
@section Developing major modes with tree-sitter
@cindex major mode, developing with tree-sitter
@@ -1789,7 +1897,13 @@ add-log functions used by @code{add-log-current-defun}.
@item
If @code{treesit-simple-imenu-settings} (@pxref{Imenu}) is
non-@code{nil}, it sets up Imenu.
+
+@item
+If @code{treesit-outline-predicate} (@pxref{Outline Minor Mode}) is
+non-@code{nil}, it sets up Outline minor mode.
@end itemize
+
+@c TODO: Add treesit-thing-settings stuff once we finalize it.
@end defun
For more information on these built-in tree-sitter features,
diff --git a/doc/lispref/positions.texi b/doc/lispref/positions.texi
index de2a37cd308..5e0143c7131 100644
--- a/doc/lispref/positions.texi
+++ b/doc/lispref/positions.texi
@@ -872,6 +872,29 @@ defuns. If the value is @code{nested}, navigation functions recognize
nested defuns.
@end defvar
+@findex treesit-forward-sentence
+@findex forward-sentence
+@findex backward-sentence
+If Emacs is compiled with tree-sitter, it can use the tree-sitter
+parser information to move across syntax constructs. Since what
+exactly is considered a sentence varies between languages, a major
+mode should set @code{treesit-thing-settings} to determine that.
+Then the mode can get navigation-by-sentence functionality for free,
+by using @code{forward-sentence} and
+@code{backward-sentence}(@pxref{Moving by Sentences,,, emacs, The
+extensible self-documenting text editor}).
+
+@findex treesit-forward-sexp
+@findex forward-sexp@r{, and tree-sitter}
+@findex backward-sexp@r{, and tree-sitter}
+If Emacs is compiled with tree-sitter, it can use the tree-sitter
+parser information to move across syntax constructs. Since what
+exactly is considered a sexp varies between languages, a major mode
+should set @code{treesit-thing-settings} to determine that. Then
+the mode can get navigation-by-sexp functionality for free, by using
+@code{forward-sexp} and @code{backward-sexp}(@pxref{Moving by
+Sentences,,, emacs, The extensible self-documenting text editor}).
+
@node Skipping Characters
@subsection Skipping Characters
@cindex skipping characters
diff --git a/doc/lispref/processes.texi b/doc/lispref/processes.texi
index e3eee3d0719..ea3fe738f69 100644
--- a/doc/lispref/processes.texi
+++ b/doc/lispref/processes.texi
@@ -134,7 +134,7 @@ but all the 3 primitives allow optionally to direct the standard error
stream to a different destination.
@cindex program arguments
- All three of the subprocess-creating functions allow to specify
+ All three of the subprocess-creating functions allow specifying
command-line arguments for the process to run. For @code{call-process}
and @code{call-process-region}, these come in the form of a
@code{&rest} argument, @var{args}. For @code{make-process}, both the
@@ -185,6 +185,25 @@ respective remote host. In case of a local @code{default-directory},
the function returns just the value of the variable @code{exec-path}.
@end defun
+@cindex programs distributed with Emacs, starting
+@vindex ctags-program-name
+@vindex etags-program-name
+@vindex hexl-program-name
+@vindex emacsclient-program-name
+@vindex movemail-program-name
+@vindex ebrowse-program-name
+@vindex rcs2log-program-name
+ When starting a program that is part of the Emacs distribution, you
+must take into account that the program may have been renamed in order
+to comply with executable naming restrictions present on the system.
+
+ Instead of starting @command{ctags}, for example, you should specify
+the value of @code{ctags-program-name} instead. Likewise, instead of
+starting @command{movemail}, you must start
+@code{movemail-program-name}, and the same goes for @command{etags},
+@command{hexl}, @command{emacsclient}, @code{rcs2log}, and
+@command{ebrowse}.
+
@node Shell Arguments
@section Shell Arguments
@cindex arguments for shell commands
@@ -501,7 +520,7 @@ This user option indicates whether a call of @code{process-file}
returns a string describing the signal interrupting a remote process.
When a process returns an exit code greater than 128, it is
-interpreted as a signal. @code{process-file} requires to return a
+interpreted as a signal. @code{process-file} requires returning a
string describing this signal.
Since there are processes violating this rule, returning exit codes
@@ -662,7 +681,7 @@ This function is the basic low-level primitive for starting
asynchronous subprocesses. It returns a process object representing
the subprocess. Compared to the more high-level @code{start-process},
described below, it takes keyword arguments, is more flexible, and
-allows to specify process filters and sentinels in a single call.
+enables you to specify process filters and sentinels in a single call.
The arguments @var{args} are a list of keyword/argument pairs.
Omitting a keyword is always equivalent to specifying it with value
@@ -1762,7 +1781,7 @@ program was running when the filter function was started. However, if
This makes it possible to use the Lisp debugger to debug filter
functions. @xref{Debugger}. If an error is caught, Emacs pauses for
@code{process-error-pause-time} seconds so that the user sees the
-error. @xref{Asynchronous Processes}
+error. @xref{Asynchronous Processes}.
Many filter functions sometimes (or always) insert the output in the
process's buffer, mimicking the actions of the default filter.
@@ -2168,7 +2187,7 @@ programs was running when the sentinel was started. However, if
This makes it possible to use the Lisp debugger to debug the
sentinel. @xref{Debugger}. If an error is caught, Emacs pauses for
@code{process-error-pause-time} seconds so that the user sees the
-error. @xref{Asynchronous Processes}
+error. @xref{Asynchronous Processes}.
While a sentinel is running, the process sentinel is temporarily
set to @code{nil} so that the sentinel won't run recursively.
diff --git a/doc/lispref/records.texi b/doc/lispref/records.texi
index 855157ca573..34a632a23f3 100644
--- a/doc/lispref/records.texi
+++ b/doc/lispref/records.texi
@@ -81,6 +81,10 @@ This function returns a new record with type @var{type} and
@end example
@end defun
+To copy trees consisting of records, vectors and conses (lists), use
+@code{copy-tree} with its optional second argument non-@code{nil}.
+@xref{Building Lists, copy-tree}.
+
@node Backward Compatibility
@section Backward Compatibility
diff --git a/doc/lispref/searching.texi b/doc/lispref/searching.texi
index c697c929b6a..2fa7ebc903d 100644
--- a/doc/lispref/searching.texi
+++ b/doc/lispref/searching.texi
@@ -18,11 +18,12 @@ portions of it.
* Searching and Case:: Case-independent or case-significant searching.
* Regular Expressions:: Describing classes of strings.
* Regexp Search:: Searching for a match for a regexp.
-* POSIX Regexps:: Searching POSIX-style for the longest match.
+* Longest Match:: Searching for the longest match.
* Match Data:: Finding out which part of the text matched,
after a string or regexp search.
* Search and Replace:: Commands that loop, searching and replacing.
* Standard Regexps:: Useful regexps for finding sentences, pages,...
+* POSIX Regexps:: Emacs regexps vs POSIX regexps.
@end menu
The @samp{skip-chars@dots{}} functions also perform a kind of searching.
@@ -277,10 +278,10 @@ character is a simple regular expression that matches that character
and nothing else. The special characters are @samp{.}, @samp{*},
@samp{+}, @samp{?}, @samp{[}, @samp{^}, @samp{$}, and @samp{\}; no new
special characters will be defined in the future. The character
-@samp{]} is special if it ends a character alternative (see later).
-The character @samp{-} is special inside a character alternative. A
+@samp{]} is special if it ends a bracket expression (see later).
+The character @samp{-} is special inside a bracket expression. A
@samp{[:} and balancing @samp{:]} enclose a character class inside a
-character alternative. Any other character appearing in a regular
+bracket expression. Any other character appearing in a regular
expression is ordinary, unless a @samp{\} precedes it.
For example, @samp{f} is not a special character, so it is ordinary, and
@@ -373,19 +374,21 @@ expression @samp{c[ad]*?a}, applied to that same string, matches just
permits the whole expression to match is @samp{d}.)
@item @samp{[ @dots{} ]}
+@cindex bracket expression (in regexp)
@cindex character alternative (in regexp)
@cindex @samp{[} in regexp
@cindex @samp{]} in regexp
-is a @dfn{character alternative}, which begins with @samp{[} and is
-terminated by @samp{]}. In the simplest case, the characters between
-the two brackets are what this character alternative can match.
+is a @dfn{bracket expression} (a.k.a.@: @dfn{character alternative}),
+which begins with @samp{[} and is terminated by @samp{]}. In the
+simplest case, the characters between the two brackets are what this
+bracket expression can match.
Thus, @samp{[ad]} matches either one @samp{a} or one @samp{d}, and
@samp{[ad]*} matches any string composed of just @samp{a}s and @samp{d}s
(including the empty string). It follows that @samp{c[ad]*r}
matches @samp{cr}, @samp{car}, @samp{cdr}, @samp{caddaar}, etc.
-You can also include character ranges in a character alternative, by
+You can also include character ranges in a bracket expression, by
writing the starting and ending characters with a @samp{-} between them.
Thus, @samp{[a-z]} matches any lower-case @acronym{ASCII} letter.
Ranges may be intermixed freely with individual characters, as in
@@ -394,7 +397,7 @@ or @samp{$}, @samp{%} or period. However, the ending character of one
range should not be the starting point of another one; for example,
@samp{[a-m-z]} should be avoided.
-A character alternative can also specify named character classes
+A bracket expression can also specify named character classes
(@pxref{Char Classes}). For example, @samp{[[:ascii:]]} matches any
@acronym{ASCII} character. Using a character class is equivalent to
mentioning each of the characters in that class; but the latter is not
@@ -403,9 +406,9 @@ different characters. A character class should not appear as the
lower or upper bound of a range.
The usual regexp special characters are not special inside a
-character alternative. A completely different set of characters is
+bracket expression. A completely different set of characters is
special: @samp{]}, @samp{-} and @samp{^}.
-To include @samp{]} in a character alternative, put it at the
+To include @samp{]} in a bracket expression, put it at the
beginning. To include @samp{^}, put it anywhere but at the beginning.
To include @samp{-}, put it at the end. Thus, @samp{[]^-]} matches
all three of these special characters. You cannot use @samp{\} to
@@ -443,7 +446,7 @@ characters and raw 8-bit bytes, but not non-ASCII characters. This
feature is intended for searching text in unibyte buffers and strings.
@end enumerate
-Some kinds of character alternatives are not the best style even
+Some kinds of bracket expressions are not the best style even
though they have a well-defined meaning in Emacs. They include:
@enumerate
@@ -457,7 +460,7 @@ Unicode character escapes can help here; for example, for most programmers
@samp{[ก-ฺ฿-๛]} is less clear than @samp{[\u0E01-\u0E3A\u0E3F-\u0E5B]}.
@item
-Although a character alternative can include duplicates, it is better
+Although a bracket expression can include duplicates, it is better
style to avoid them. For example, @samp{[XYa-yYb-zX]} is less clear
than @samp{[XYa-z]}.
@@ -468,30 +471,30 @@ is simpler to list the characters. For example,
than @samp{[ij]}, and @samp{[i-k]} is less clear than @samp{[ijk]}.
@item
-Although a @samp{-} can appear at the beginning of a character
-alternative or as the upper bound of a range, it is better style to
-put @samp{-} by itself at the end of a character alternative. For
+Although a @samp{-} can appear at the beginning of a bracket
+expression or as the upper bound of a range, it is better style to
+put @samp{-} by itself at the end of a bracket expression. For
example, although @samp{[-a-z]} is valid, @samp{[a-z-]} is better
style; and although @samp{[*--]} is valid, @samp{[*+,-]} is clearer.
@end enumerate
@item @samp{[^ @dots{} ]}
@cindex @samp{^} in regexp
-@samp{[^} begins a @dfn{complemented character alternative}. This
-matches any character except the ones specified. Thus,
-@samp{[^a-z0-9A-Z]} matches all characters @emph{except} ASCII letters and
-digits.
+@samp{[^} begins a @dfn{complemented bracket expression}, or
+@dfn{complemented character alternative}. This matches any character
+except the ones specified. Thus, @samp{[^a-z0-9A-Z]} matches all
+characters @emph{except} ASCII letters and digits.
-@samp{^} is not special in a character alternative unless it is the first
+@samp{^} is not special in a bracket expression unless it is the first
character. The character following the @samp{^} is treated as if it
were first (in other words, @samp{-} and @samp{]} are not special there).
-A complemented character alternative can match a newline, unless newline is
+A complemented bracket expression can match a newline, unless newline is
mentioned as one of the characters not to match. This is in contrast to
the handling of regexps in programs such as @code{grep}.
-You can specify named character classes, just like in character
-alternatives. For instance, @samp{[^[:ascii:]]} matches any
+You can specify named character classes, just like in bracket
+expressions. For instance, @samp{[^[:ascii:]]} matches any
non-@acronym{ASCII} character. @xref{Char Classes}.
@item @samp{^}
@@ -505,9 +508,10 @@ beginning of a line.
When matching a string instead of a buffer, @samp{^} matches at the
beginning of the string or after a newline character.
-For historical compatibility reasons, @samp{^} can be used only at the
-beginning of the regular expression, or after @samp{\(}, @samp{\(?:}
-or @samp{\|}.
+For historical compatibility, @samp{^} is special only at the beginning
+of the regular expression, or after @samp{\(}, @samp{\(?:} or @samp{\|}.
+Although @samp{^} is an ordinary character in other contexts,
+it is good practice to use @samp{\^} even then.
@item @samp{$}
@cindex @samp{$} in regexp
@@ -519,8 +523,10 @@ matches a string of one @samp{x} or more at the end of a line.
When matching a string instead of a buffer, @samp{$} matches at the end
of the string or before a newline character.
-For historical compatibility reasons, @samp{$} can be used only at the
+For historical compatibility, @samp{$} is special only at the
end of the regular expression, or before @samp{\)} or @samp{\|}.
+Although @samp{$} is an ordinary character in other contexts,
+it is good practice to use @samp{\$} even then.
@item @samp{\}
@cindex @samp{\} in regexp
@@ -540,14 +546,15 @@ example, the regular expression that matches the @samp{\} character is
@samp{\} is @code{"\\\\"}.
@end table
-@strong{Please note:} For historical compatibility, special characters
-are treated as ordinary ones if they are in contexts where their special
-meanings make no sense. For example, @samp{*foo} treats @samp{*} as
-ordinary since there is no preceding expression on which the @samp{*}
-can act. It is poor practice to depend on this behavior; quote the
-special character anyway, regardless of where it appears.
+For historical compatibility, a repetition operator is treated as ordinary
+if it appears at the start of a regular expression
+or after @samp{^}, @samp{\`}, @samp{\(}, @samp{\(?:} or @samp{\|}.
+For example, @samp{*foo} is treated as @samp{\*foo}, and
+@samp{two\|^\@{2\@}} is treated as @samp{two\|^@{2@}}.
+It is poor practice to depend on this behavior; use proper backslash
+escaping anyway, regardless of where the repetition operator appears.
-As a @samp{\} is not special inside a character alternative, it can
+As a @samp{\} is not special inside a bracket expression, it can
never remove the special meaning of @samp{-}, @samp{^} or @samp{]}.
You should not quote these characters when they have no special
meaning. This would not clarify anything, since backslashes
@@ -556,23 +563,23 @@ special meaning, as in @samp{[^\]} (@code{"[^\\]"} for Lisp string
syntax), which matches any single character except a backslash.
In practice, most @samp{]} that occur in regular expressions close a
-character alternative and hence are special. However, occasionally a
+bracket expression and hence are special. However, occasionally a
regular expression may try to match a complex pattern of literal
@samp{[} and @samp{]}. In such situations, it sometimes may be
necessary to carefully parse the regexp from the start to determine
-which square brackets enclose a character alternative. For example,
-@samp{[^][]]} consists of the complemented character alternative
+which square brackets enclose a bracket expression. For example,
+@samp{[^][]]} consists of the complemented bracket expression
@samp{[^][]} (which matches any single character that is not a square
bracket), followed by a literal @samp{]}.
The exact rules are that at the beginning of a regexp, @samp{[} is
special and @samp{]} not. This lasts until the first unquoted
-@samp{[}, after which we are in a character alternative; @samp{[} is
+@samp{[}, after which we are in a bracket expression; @samp{[} is
no longer special (except when it starts a character class) but @samp{]}
is special, unless it immediately follows the special @samp{[} or that
@samp{[} followed by a @samp{^}. This lasts until the next special
-@samp{]} that does not end a character class. This ends the character
-alternative and restores the ordinary syntax of regular expressions;
+@samp{]} that does not end a character class. This ends the bracket
+expression and restores the ordinary syntax of regular expressions;
an unquoted @samp{[} is special again and a @samp{]} not.
@node Char Classes
@@ -583,13 +590,13 @@ an unquoted @samp{[} is special again and a @samp{]} not.
@cindex alpha character class, regexp
@cindex xdigit character class, regexp
- Below is a table of the classes you can use in a character
-alternative, and what they mean. Note that the @samp{[} and @samp{]}
-characters that enclose the class name are part of the name, so a
-regular expression using these classes needs one more pair of
-brackets. For example, a regular expression matching a sequence of
-one or more letters and digits would be @samp{[[:alnum:]]+}, not
-@samp{[:alnum:]+}.
+ Below is a table of the classes you can use in a bracket expression
+(@pxref{Regexp Special, bracket expression}), and what they mean.
+Note that the @samp{[} and @samp{]} characters that enclose the class
+name are part of the name, so a regular expression using these classes
+needs one more pair of brackets. For example, a regular expression
+matching a sequence of one or more letters and digits would be
+@samp{[[:alnum:]]+}, not @samp{[:alnum:]+}.
@table @samp
@item [:ascii:]
@@ -662,6 +669,10 @@ This matches the hexadecimal digits: @samp{0} through @samp{9}, @samp{a}
through @samp{f} and @samp{A} through @samp{F}.
@end table
+The classes @samp{[:space:]}, @samp{[:word:]} and @samp{[:punct:]} use
+the syntax-table of the current buffer but not any overriding syntax
+text properties (@pxref{Syntax Properties}).
+
@node Regexp Backslash
@subsubsection Backslash Constructs in Regular Expressions
@cindex backslash in regular expressions
@@ -911,7 +922,7 @@ with a symbol-constituent character.
@kindex invalid-regexp
Not every string is a valid regular expression. For example, a string
-that ends inside a character alternative without a terminating @samp{]}
+that ends inside a bracket expression without a terminating @samp{]}
is invalid, and so is a string that ends with a single @samp{\}. If
an invalid regular expression is passed to any of the search functions,
an @code{invalid-regexp} error is signaled.
@@ -948,7 +959,7 @@ deciphered as follows:
@table @code
@item [.?!]
-The first part of the pattern is a character alternative that matches
+The first part of the pattern is a bracket expression that matches
any one of three characters: period, question mark, and exclamation
mark. The match must begin with one of these three characters. (This
is one point where the new default regexp used by Emacs differs from
@@ -960,7 +971,7 @@ The second part of the pattern matches any closing braces and quotation
marks, zero or more of them, that may follow the period, question mark
or exclamation mark. The @code{\"} is Lisp syntax for a double-quote in
a string. The @samp{*} at the end indicates that the immediately
-preceding regular expression (a character alternative, in this case) may be
+preceding regular expression (a bracket expression, in this case) may be
repeated zero or more times.
@item \\($\\|@ $\\|\t\\|@ @ \\)
@@ -1334,6 +1345,9 @@ Match any @acronym{ASCII} character (codes 0--127).
Match any non-@acronym{ASCII} character (but not raw bytes).
@end table
+The classes @code{space}, @code{word} and @code{punct} use the
+syntax-table of the current buffer but not any overriding syntax text
+properties (@pxref{Syntax Properties}).@*
Corresponding string regexp: @samp{[[:@var{class}:]]}
@item @code{(syntax @var{syntax})}
@@ -1911,9 +1925,10 @@ attempts. Other zero-width assertions may also bring benefits by
causing a match to fail early.
@item
-Avoid or-patterns in favor of character alternatives: write
+Avoid or-patterns in favor of bracket expressions: write
@samp{[ab]} instead of @samp{a\|b}. Recall that @samp{\s-} and @samp{\sw}
-are equivalent to @samp{[[:space:]]} and @samp{[[:word:]]}, respectively.
+are equivalent to @samp{[[:space:]]} and @samp{[[:word:]]}, respectively,
+most of the time.
@item
Since the last branch of an or-pattern does not add a backtrack point
@@ -1957,6 +1972,17 @@ advice, don't be afraid of performing the matching in multiple
function calls, each using a simpler regexp where backtracking can
more easily be contained.
+@defun re--describe-compiled regexp &optional raw
+To help diagnose problems in your regexps or in the regexp engine
+itself, this function returns a string describing the compiled
+form of @var{regexp}. To make sense of it, it can be necessary
+to read at least the description of the @code{re_opcode_t} type in the
+@code{src/regex-emacs.c} file in Emacs' source code.
+
+It is currently able to give a meaningful description only if Emacs
+was compiled with @code{--enable-checking}.
+@end defun
+
@node Regexp Search
@section Regular Expression Searching
@cindex regular expression searching
@@ -2193,8 +2219,8 @@ constructs, you should bind it temporarily for as small as possible
a part of the code.
@end defvar
-@node POSIX Regexps
-@section POSIX Regular Expression Searching
+@node Longest Match
+@section Longest-match searching for regular expression matches
@cindex backtracking and POSIX regular expressions
The usual regular expression functions do backtracking when necessary
@@ -2209,7 +2235,9 @@ possibilities and found all matches, so they can report the longest
match, as required by POSIX@. This is much slower, so use these
functions only when you really need the longest match.
- The POSIX search and match functions do not properly support the
+ Despite their names, the POSIX search and match functions
+use Emacs regular expressions, not POSIX regular expressions.
+@xref{POSIX Regexps}. Also, they do not properly support the
non-greedy repetition operators (@pxref{Regexp Special, non-greedy}).
This is because POSIX backtracking conflicts with the semantics of
non-greedy repetition.
@@ -2957,3 +2985,98 @@ values of the variables @code{sentence-end-double-space}
@code{sentence-end-without-period}, and
@code{sentence-end-without-space}.
@end defun
+
+@node POSIX Regexps
+@section Emacs versus POSIX Regular Expressions
+@cindex POSIX regular expressions
+
+Regular expression syntax varies significantly among computer programs.
+When writing Elisp code that generates regular expressions for use by other
+programs, it is helpful to know how syntax variants differ.
+To give a feel for the variation, this section discusses how
+Emacs regular expressions differ from two syntax variants standarded by POSIX:
+basic regular expressions (BREs) and extended regular expressions (EREs).
+Plain @command{grep} uses BREs, and @samp{grep -E} uses EREs.
+
+Emacs regular expressions have a syntax closer to EREs than to BREs,
+with some extensions. Here is a summary of how POSIX BREs and EREs
+differ from Emacs regular expressions.
+
+@itemize @bullet
+@item
+In POSIX BREs @samp{+} and @samp{?} are not special.
+The only backslash escape sequences are @samp{\(@dots{}\)},
+@samp{\@{@dots{}\@}}, @samp{\1} through @samp{\9}, along with the
+escaped special characters @samp{\$}, @samp{\*}, @samp{\.}, @samp{\[},
+@samp{\\}, and @samp{\^}.
+Therefore @samp{\(?:} acts like @samp{\([?]:}.
+POSIX does not define how other BRE escapes behave;
+for example, GNU @command{grep} treats @samp{\|} like Emacs does,
+but does not support all the Emacs escapes.
+
+@item
+In POSIX BREs, it is an implementation option whether @samp{^} is special
+after @samp{\(}; GNU @command{grep} treats it like Emacs does.
+In POSIX EREs, @samp{^} is always special outside of bracket expressions,
+which means the ERE @samp{x^} never matches.
+In Emacs regular expressions, @samp{^} is special only at the
+beginning of the regular expression, or after @samp{\(}, @samp{\(?:}
+or @samp{\|}.
+
+@item
+In POSIX BREs, it is an implementation option whether @samp{$} is
+special before @samp{\)}; GNU @command{grep} treats it like Emacs
+does. In POSIX EREs, @samp{$} is always special outside of bracket
+expressions (@pxref{Regexp Special, bracket expressions}), which means
+the ERE @samp{$x} never matches. In Emacs regular expressions,
+@samp{$} is special only at the end of the regular expression, or
+before @samp{\)} or @samp{\|}.
+
+@item
+In POSIX EREs @samp{@{}, @samp{(} and @samp{|} are special,
+and @samp{)} is special when matched with a preceding @samp{(}.
+These special characters do not use preceding backslashes;
+@samp{(?} produces undefined results.
+The only backslash escape sequences are the escaped special characters
+@samp{\$}, @samp{\(}, @samp{\)}, @samp{\*}, @samp{\+}, @samp{\.},
+@samp{\?}, @samp{\[}, @samp{\\}, @samp{\^}, @samp{\@{} and @samp{\|}.
+POSIX does not define how other ERE escapes behave;
+for example, GNU @samp{grep -E} treats @samp{\1} like Emacs does,
+but does not support all the Emacs escapes.
+
+@item
+In POSIX BREs and EREs, undefined results are produced by repetition
+operators at the start of a regular expression or subexpression
+(possibly preceded by @samp{^}), except that the repetition operator
+@samp{*} has the same behavior in BREs as in Emacs.
+In Emacs, these operators are treated as ordinary.
+
+@item
+In BREs and EREs, undefined results are produced by two repetition
+operators in sequence. In Emacs, these have well-defined behavior,
+e.g., @samp{a**} is equivalent to @samp{a*}.
+
+@item
+In BREs and EREs, undefined results are produced by empty regular
+expressions or subexpressions. In Emacs these have well-defined
+behavior, e.g., @samp{\(\)*} matches the empty string,
+
+@item
+In BREs and EREs, undefined results are produced for the named
+character classes @samp{[:ascii:]}, @samp{[:multibyte:]},
+@samp{[:nonascii:]}, @samp{[:unibyte:]}, and @samp{[:word:]}.
+
+@item
+BREs and EREs can contain collating symbols and equivalence
+class expressions within bracket expressions, e.g., @samp{[[.ch.]d[=a=]]}.
+Emacs regular expressions do not support this.
+
+@item
+BREs, EREs, and the strings they match cannot contain encoding errors
+or NUL bytes. In Emacs these constructs simply match themselves.
+
+@item
+BRE and ERE searching always finds the longest match.
+Emacs searching by default does not necessarily do so.
+@xref{Longest Match}.
+@end itemize
diff --git a/doc/lispref/sequences.texi b/doc/lispref/sequences.texi
index f1f23f007a4..c9e47624878 100644
--- a/doc/lispref/sequences.texi
+++ b/doc/lispref/sequences.texi
@@ -350,94 +350,165 @@ encouraged to treat strings as immutable even when they are mutable.
@end defun
-@defun sort sequence predicate
+@defun sort sequence &rest keyword-args
@cindex stable sort
@cindex sorting lists
@cindex sorting vectors
-This function sorts @var{sequence} stably. Note that this function doesn't work
-for all sequences; it may be used only for lists and vectors. If @var{sequence}
-is a list, it is modified destructively. This functions returns the sorted
-@var{sequence} and compares elements using @var{predicate}. A stable sort is
-one in which elements with equal sort keys maintain their relative order before
-and after the sort. Stability is important when successive sorts are used to
-order elements according to different criteria.
+This function sorts @var{sequence}, which must be a list or vector, and
+returns a sorted sequence of the same type.
+The sort is stable, which means that elements with equal sort keys maintain
+their relative order. It takes the following optional keyword arguments:
+
+@table @code
+@item :key @var{keyfunc}
+Use @var{keyfunc}, a function that takes a single element from
+@var{sequence} and returns its key value, to generate the keys used in
+comparison. If this argument is absent or if @var{keyfunc} is
+@code{nil} then @code{identity} is assumed; that is, the elements
+themselves are used as sorting keys.
+
+@item :lessp @var{predicate}
+Use @var{predicate} to order the keys. @var{predicate} is a function
+that takes two sort keys as arguments and returns non-@code{nil} if the
+first should come before the second. If this argument is absent or
+@var{predicate} is @code{nil}, then @code{value<} is used, which
+is applicable to many different Lisp types and generally sorts in
+ascending order (@pxref{definition of value<}, below).
+
+For consistency, any predicate must obey the following rules:
+@itemize @bullet
+@item
+It must be @dfn{antisymmetric}: it cannot both order @var{a} before
+@var{b} and @var{b} before @var{a}.
+@item
+It must be @dfn{transitive}: if it orders @var{a} before @var{b} and
+@var{b} before @var{c}, then it must also order @var{a} before @var{c}.
+@end itemize
-The argument @var{predicate} must be a function that accepts two
-arguments. It is called with two elements of @var{sequence}. To get an
-increasing order sort, the @var{predicate} should return non-@code{nil} if the
-first element is ``less'' than the second, or @code{nil} if not.
+@item :reverse @var{flag}
+If @var{flag} is non-@code{nil}, the sorting order is reversed. With
+the default @code{:lessp} predicate this means sorting in descending order.
-The comparison function @var{predicate} must give reliable results for
-any given pair of arguments, at least within a single call to
-@code{sort}. It must be @dfn{antisymmetric}; that is, if @var{a} is
-less than @var{b}, @var{b} must not be less than @var{a}. It must be
-@dfn{transitive}---that is, if @var{a} is less than @var{b}, and @var{b}
-is less than @var{c}, then @var{a} must be less than @var{c}. If you
-use a comparison function which does not meet these requirements, the
-result of @code{sort} is unpredictable.
+@item :in-place @var{flag}
+If @var{flag} is non-@code{nil}, then @var{sequence} is sorted in-place
+(destructively) and returned. If @code{nil}, or if this argument is not
+given, a sorted copy of the input is returned and @var{sequence} itself
+remains unmodified. In-place sorting is slightly faster, but the
+original sequence is lost.
+@end table
-The destructive aspect of @code{sort} for lists is that it reuses the
-cons cells forming @var{sequence} by changing their contents, possibly
-rearranging them in a different order. This means that the value of
-the input list is undefined after sorting; only the list returned by
-@code{sort} has a well-defined value. Example:
+If the default behaviour is not suitable for your needs, it is usually
+easier and faster to supply a new @code{:key} function than a different
+@code{:lessp} predicate. For example, consider sorting these strings:
@example
@group
-(setq nums (list 2 1 4 3 0))
-(sort nums #'<)
- @result{} (0 1 2 3 4)
- ; nums is unpredictable at this point
+(setq numbers '("one" "two" "three" "four" "five" "six"))
+(sort numbers)
+ @result{} ("five" "four" "one" "six" "three" "two")
@end group
@end example
-Most often we store the result back into the variable that held the
-original list:
+You can sort the strings by length instead by supplying a different key
+function:
@example
-(setq nums (sort nums #'<))
+@group
+(sort numbers :key #'length)
+ @result{} ("one" "two" "six" "four" "five" "three")
+@end group
@end example
-If you wish to make a sorted copy without destroying the original,
-copy it first and then sort:
+@noindent
+Note how strings of the same length keep their original order, thanks to
+the sorting stability. Now suppose you want to sort by length, but use
+the string contents to break ties. The easiest way is to specify a key
+function that transforms an element to a value that is sorted this way.
+Since @code{value<} orders compound objects (conses, lists,
+vectors and records) lexicographically, you could do:
@example
@group
-(setq nums (list 2 1 4 3 0))
-(sort (copy-sequence nums) #'<)
- @result{} (0 1 2 3 4)
-@end group
-@group
-nums
- @result{} (2 1 4 3 0)
+(sort numbers :key (lambda (x) (cons (length x) x)))
+ @result{} ("one" "six" "two" "five" "four" "three")
@end group
@end example
-For the better understanding of what stable sort is, consider the following
-vector example. After sorting, all items whose @code{car} is 8 are grouped
-at the beginning of @code{vector}, but their relative order is preserved.
-All items whose @code{car} is 9 are grouped at the end of @code{vector},
-but their relative order is also preserved:
+@noindent
+because @code{(3 . "six")} is ordered before @code{(3 . "two")} and so on.
+
+For compatibility with previous versions of Emacs, the @code{sort}
+function can also be called using the fixed two-argument form:
@example
-@group
-(setq
- vector
- (vector '(8 . "xxx") '(9 . "aaa") '(8 . "bbb") '(9 . "zzz")
- '(9 . "ppp") '(8 . "ttt") '(8 . "eee") '(9 . "fff")))
- @result{} [(8 . "xxx") (9 . "aaa") (8 . "bbb") (9 . "zzz")
- (9 . "ppp") (8 . "ttt") (8 . "eee") (9 . "fff")]
-@end group
-@group
-(sort vector (lambda (x y) (< (car x) (car y))))
- @result{} [(8 . "xxx") (8 . "bbb") (8 . "ttt") (8 . "eee")
- (9 . "aaa") (9 . "zzz") (9 . "ppp") (9 . "fff")]
-@end group
+(@code{sort} @var{sequence} @var{predicate})
+@end example
+
+@noindent
+where @var{predicate} is the @code{:lessp} argument. When using this
+form, sorting is always done in-place.
+@end defun
+
+@xref{Sorting}, for more functions that perform sorting. See
+@code{documentation} in @ref{Accessing Documentation}, for a useful
+example of @code{sort}.
+
+@cindex comparing values
+@cindex standard sorting order
+@anchor{definition of value<}
+@defun value< a b
+This function returns non-@code{nil} if @var{a} comes before @var{b} in
+the standard sorting order; this means that it returns @code{nil} when
+@var{b} comes before @var{a}, or if they are equal or unordered.
+
+The arguments @var{a} and @var{b} must have the same type.
+Specifically:
+
+@itemize @bullet
+@item
+Numbers are compared using @code{<} (@pxref{definition of <}).
+@item
+Strings are compared using @code{string<} (@pxref{definition of
+string<}) and symbols are compared by comparing their names as strings.
+@item
+Conses, lists, vectors and records are compared lexicographically. This
+means that the two sequences are compared element-wise from left to
+right until they differ, and the result is then that of @code{value<} on
+the first pair of differing elements. If one sequence runs out of
+elements before the other, the shorter sequence comes before the longer.
+@item
+Markers are compared first by buffer, then by position.
+@item
+Buffers and processes are compared by comparing their names as strings.
+Dead buffers (whose name is @code{nil}) will compare before any live
+buffer.
+@item
+Other types are considered unordered and the return value will be
+@code{nil}.
+@end itemize
+
+Examples:
+@example
+(value< -4 3.5) @result{} t
+(value< "dog" "cat") @result{} nil
+(value< 'yip 'yip) @result{} nil
+(value< '(3 2) '(3 2 0)) @result{} t
+(value< [3 2 "a"] [3 2 "b"]) @result{} t
+@end example
+
+@noindent
+Note that @code{nil} is treated as either a symbol or an empty list,
+depending on what it is compared against:
+
+@example
+(value< nil '(0)) @result{} t
+(value< 'nib nil) @result{} t
@end example
-@xref{Sorting}, for more functions that perform sorting.
-See @code{documentation} in @ref{Accessing Documentation}, for a
-useful example of @code{sort}.
+@noindent
+There is no limit to the length of sequences (lists, vectors and so on)
+that can be compared, but @code{value<} may fail with an error if used
+to compare circular or deeply nested data structures.
@end defun
@cindex sequence functions in seq
diff --git a/doc/lispref/streams.texi b/doc/lispref/streams.texi
index 9fd2d074efe..86ec82b66a1 100644
--- a/doc/lispref/streams.texi
+++ b/doc/lispref/streams.texi
@@ -981,6 +981,15 @@ Letter, Number, Punctuation, Symbol and Private-use
having their own escape syntax such as newline.
@end defvar
+@defopt pp-default-function
+This user variable specifies the function used by @code{pp} to prettify
+its output. By default it uses @code{pp-fill} which attempts to
+strike a good balance between speed and generating natural looking output
+that fits within @code{fill-column}. The previous default was
+@code{pp-28}, which tends to be faster but generate output that looks
+less natural and is less compact.
+@end defopt
+
@node Output Overrides
@section Overriding Output Variables
@cindex overrides, in output functions
diff --git a/doc/lispref/strings.texi b/doc/lispref/strings.texi
index eca69002779..7f640255a7a 100644
--- a/doc/lispref/strings.texi
+++ b/doc/lispref/strings.texi
@@ -612,6 +612,7 @@ that collation implements.
@end defun
@cindex lexical comparison of strings
+@anchor{definition of string<}
@defun string< string1 string2
@c (findex string< causes problems for permuted index!!)
This function compares two strings a character at a time. It
@@ -691,7 +692,8 @@ for sorting (@pxref{Sequence Functions}):
@example
@group
-(sort (list "11" "12" "1 1" "1 2" "1.1" "1.2") 'string-collate-lessp)
+(sort '("11" "12" "1 1" "1 2" "1.1" "1.2")
+ :lessp #'string-collate-lessp)
@result{} ("11" "1 1" "1.1" "12" "1 2" "1.2")
@end group
@end example
@@ -708,8 +710,8 @@ systems. The @var{locale} value of @code{"POSIX"} or @code{"C"} lets
@example
@group
-(sort (list "11" "12" "1 1" "1 2" "1.1" "1.2")
- (lambda (s1 s2) (string-collate-lessp s1 s2 "POSIX")))
+(sort '("11" "12" "1 1" "1 2" "1.1" "1.2")
+ :lessp (lambda (s1 s2) (string-collate-lessp s1 s2 "POSIX")))
@result{} ("1 1" "1 2" "1.1" "1.2" "11" "12")
@end group
@end example
@@ -1508,9 +1510,12 @@ has been capitalized. This means that the first character of each
word is converted to upper case, and the rest are converted to lower
case.
+@vindex case-symbols-as-words
The definition of a word is any sequence of consecutive characters that
are assigned to the word constituent syntax class in the current syntax
-table (@pxref{Syntax Class Table}).
+table (@pxref{Syntax Class Table}); if @code{case-symbols-as-words}
+is non-nil, characters assigned to the symbol constituent syntax
+class are also considered as word constituent.
When @var{string-or-char} is a character, this function does the same
thing as @code{upcase}.
@@ -1540,9 +1545,9 @@ letters other than the initials. It returns a new string whose
contents are a copy of @var{string-or-char}, in which each word has
had its initial letter converted to upper case.
-The definition of a word is any sequence of consecutive characters that
-are assigned to the word constituent syntax class in the current syntax
-table (@pxref{Syntax Class Table}).
+The definition of a word for this function is the same as described
+for @code{capitalize} above, and @code{case-symbols-as-words} has the
+same effect on word constituent characters.
When the argument to @code{upcase-initials} is a character,
@code{upcase-initials} has the same result as @code{upcase}.
diff --git a/doc/lispref/symbols.texi b/doc/lispref/symbols.texi
index dfbcf903e7d..c76bf3d3820 100644
--- a/doc/lispref/symbols.texi
+++ b/doc/lispref/symbols.texi
@@ -177,34 +177,16 @@ know how Lisp reads them. Lisp must ensure that it finds the same
symbol every time it reads the same sequence of characters in the same
context. Failure to do so would cause complete confusion.
-@cindex symbol name hashing
-@cindex hashing
@cindex obarray
-@cindex bucket (in obarray)
When the Lisp reader encounters a name that references a symbol in
-the source code, it reads all the characters of that name. Then it
-looks up that name in a table called an @dfn{obarray} to find the
-symbol that the programmer meant. The technique used in this lookup
-is called ``hashing'', an efficient method of looking something up by
-converting a sequence of characters to a number, known as a ``hash
-code''. For example, instead of searching a telephone book cover to
-cover when looking up Jan Jones, you start with the J's and go from
-there. That is a simple version of hashing. Each element of the
-obarray is a @dfn{bucket} which holds all the symbols with a given
-hash code; to look for a given name, it is sufficient to look through
-all the symbols in the bucket for that name's hash code. (The same
-idea is used for general Emacs hash tables, but they are a different
-data type; see @ref{Hash Tables}.)
-
-When looking up names, the Lisp reader also considers ``shorthands''.
+the source code, it looks up that name in a table called an @dfn{obarray}
+to find the symbol that the programmer meant. An obarray is an unordered
+container of symbols, indexed by name.
+
+The Lisp reader also considers ``shorthands''.
If the programmer supplied them, this allows the reader to find a
symbol even if its name isn't present in its full form in the source
-code. Of course, the reader needs to be aware of some pre-established
-context about such shorthands, much as one needs context to be to able
-to refer uniquely to Jan Jones by just the name ``Jan'': it's probably
-fine when amongst the Joneses, or when Jan has been mentioned
-recently, but very ambiguous in any other situation.
-@xref{Shorthands}.
+code. @xref{Shorthands}.
@cindex interning
If a symbol with the desired name is found, the reader uses that
@@ -236,23 +218,6 @@ to gain access to it is by finding it in some other object or as the
value of a variable. Uninterned symbols are sometimes useful in
generating Lisp code, see below.
- In Emacs Lisp, an obarray is actually a vector. Each element of the
-vector is a bucket; its value is either an interned symbol whose name
-hashes to that bucket, or 0 if the bucket is empty. Each interned
-symbol has an internal link (invisible to the user) to the next symbol
-in the bucket. Because these links are invisible, there is no way to
-find all the symbols in an obarray except using @code{mapatoms} (below).
-The order of symbols in a bucket is not significant.
-
- In an empty obarray, every element is 0, so you can create an obarray
-with @code{(make-vector @var{length} 0)}. @strong{This is the only
-valid way to create an obarray.} Prime numbers as lengths tend
-to result in good hashing; lengths one less than a power of two are also
-good.
-
- @strong{Do not try to put symbols in an obarray yourself.} This does
-not work---only @code{intern} can enter a symbol in an obarray properly.
-
@cindex CL note---symbol in obarrays
@quotation
@b{Common Lisp note:} Unlike Common Lisp, Emacs Lisp does not provide
@@ -262,9 +227,21 @@ Emacs Lisp provides a different namespacing system called
``shorthands'' (@pxref{Shorthands}).
@end quotation
+@defun obarray-make &optional size
+This function creates and returns a new obarray.
+The optional @var{size} may be used to specify the number of symbols
+that it is expected to hold, but since obarrays grow automatically
+as needed, this rarely provides any benefit.
+@end defun
+
+@defun obarrayp object
+This function returns @code{t} if @var{object} is an obarray,
+@code{nil} otherwise.
+@end defun
+
Most of the functions below take a name and sometimes an obarray as
arguments. A @code{wrong-type-argument} error is signaled if the name
-is not a string, or if the obarray is not a vector.
+is not a string, or if the obarray is not an obarray object.
@defun symbol-name symbol
This function returns the string that is @var{symbol}'s name. For example:
@@ -416,6 +393,10 @@ If @code{unintern} does delete a symbol, it returns @code{t}. Otherwise
it returns @code{nil}.
@end defun
+@defun obarray-clear obarray
+This function removes all symbols from @var{obarray}.
+@end defun
+
@node Symbol Properties
@section Symbol Properties
@cindex symbol property
@@ -643,6 +624,12 @@ ignore a call whose value is unused. If the property's value is
calls. In addition to byte compiler optimizations, this property is
also used for determining function safety (@pxref{Function Safety}).
+@item important-return-value
+@cindex @code{important-return-value} property
+A non-@code{nil} value makes the byte compiler warn about code that
+calls the named function without using its returned value. This is
+useful for functions where doing so is likely to be a mistake.
+
@item undo-inhibit-region
If non-@code{nil}, the named function prevents the @code{undo} operation
from being restricted to the active region, if @code{undo} is invoked
@@ -755,6 +742,23 @@ instead of @code{snu-}.
;; End:
@end example
+Note that if you have two shorthands in the same file where one is the
+prefix of the other, the longer shorthand will be attempted first.
+This happens regardless of the order you specify shorthands in the
+local variables section of your file.
+
+@example
+'(
+ t//foo ; reads to 'my-tricks--foo', not 'my-tricks-/foo'
+ t/foo ; reads to 'my-tricks-foo'
+ )
+
+;; Local Variables:
+;; read-symbol-shorthands: (("t/" . "my-tricks-")
+;; ("t//" . "my-tricks--")
+;; End:
+@end example
+
@subsection Exceptions
There are two exceptions to rules governing Shorthand transformations:
@@ -776,11 +780,19 @@ Symbol forms whose names start with @samp{#_} are not transformed.
@cindex symbol with position
@cindex bare symbol
-A @dfn{symbol with position} is a symbol, the @dfn{bare symbol},
-together with an unsigned integer called the @dfn{position}. These
-objects are intended for use by the byte compiler, which records in
-them the position of each symbol occurrence and uses those positions
-in warning and error messages.
+A @dfn{symbol with position} is a symbol, called the @dfn{bare symbol},
+together with a nonnegative fixnum called the @dfn{position}.
+Even though a symbol with position often acts like its bare symbol,
+it is not a symbol: instead, it is an object that has both a bare symbol
+and a position. Because symbols with position are not symbols,
+they don't have entries in the obarray, though their bare symbols
+typically do (@pxref{Creating Symbols}).
+
+The byte compiler uses symbols with position,
+records in them the position of each symbol occurrence, and uses those
+positions in warning and error messages. They shouldn't normally be
+used otherwise. Doing so can cause unexpected results with basic
+Emacs functions such as @code{eq} and @code{equal}.
The printed representation of a symbol with position uses the hash
notation outlined in @ref{Printed Representation}. It looks like
@@ -790,13 +802,19 @@ just the bare symbol to be printed by binding the variable
operation. The byte compiler does this before writing its output to
the compiled Lisp file.
-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
-#<symbol foo at 12345> foo)} has a value @code{t} when that variable
-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.
+When the flag variable @code{symbols-with-pos-enabled} is non-@code{nil},
+a symbol with position ordinarily behaves like its bare symbol.
+For example, @samp{(eq (position-symbol 'foo 12345) 'foo)} yields @code{t},
+and @code{equal} likewise treats a symbol with position as its bare symbol.
+
+When @code{symbols-with-pos-enabled} is @code{nil}, symbols with
+position behave as themselves, not as symbols. For example, @samp{(eq
+(position-symbol 'foo 12345) 'foo)} yields @code{nil}, and @code{equal}
+likewise treats a symbol with position as not equal to its bare symbol.
+
+Most of the time in Emacs @code{symbols-with-pos-enabled} is
+@code{nil}, but the byte compiler and the native compiler bind it to
+@code{t} when they run and Emacs runs a little more slowly in this case.
Typically, symbols with position are created by the byte compiler
calling the reader function @code{read-positioning-symbols}
@@ -804,36 +822,44 @@ calling the reader function @code{read-positioning-symbols}
@code{position-symbol}.
@defvar symbols-with-pos-enabled
-When this variable is non-@code{nil}, symbols with position behave
-like the contained bare symbol. Emacs runs a little more slowly in
-this case.
+This variable affects the behavior of symbols with position when they
+are not being printed and are not arguments to one of the functions
+defined later in this section. When this variable is non-@code{nil},
+such a symbol with position behaves like its bare symbol; otherwise it
+behaves as itself, not as a symbol.
@end defvar
@defvar print-symbols-bare
-When bound to non-@code{nil}, the Lisp printer prints only the bare symbol of
-a symbol with position, ignoring the position.
+When bound to non-@code{nil}, the Lisp printer prints only the bare
+symbol of a symbol with position, ignoring the position.
+Otherwise a symbol with position prints as itself, not as a symbol.
@end defvar
-@defun symbol-with-pos-p symbol.
-This function returns @code{t} if @var{symbol} is a symbol with
+@defun symbol-with-pos-p object
+This function returns @code{t} if @var{object} is a symbol with
position, @code{nil} otherwise.
+Unlike @code{symbolp}, this function ignores @code{symbols-with-pos-enabled}.
@end defun
-@defun bare-symbol symbol
-This function returns the bare symbol contained in @var{symbol}, or
-@var{symbol} itself if it is already a bare symbol. For any other
-type of object, it signals an error.
+@defun bare-symbol sym
+This function returns the bare symbol of the symbol with
+position @var{sym}, or @var{sym} itself if it is already a symbol.
+For any other type of object, it signals an error.
+This function ignores @code{symbols-with-pos-enabled}.
@end defun
-@defun symbol-with-pos-pos symbol
-This function returns the position, a number, from a symbol with
-position. For any other type of object, it signals an error.
+@defun symbol-with-pos-pos sympos
+This function returns the position, a nonnegative fixnum, from the symbol with
+position @var{sympos}. For any other type of object, it signals an error.
+This function ignores @code{symbols-with-pos-enabled}.
@end defun
@defun position-symbol sym pos
-Make a new symbol with position. @var{sym} is either a bare symbol or
-a symbol with position, and supplies the symbol part of the new
-object. @var{pos} is either an integer which becomes the number part
-of the new object, or a symbol with position whose position is used.
+Make a new symbol with position. The new object's bare symbol is taken
+from @var{sym}, which is either a symbol, or a symbol with position
+whose bare symbol is used. The new object's position is taken from
+@var{pos}, which is either a nonnegative fixnum, or a symbol with
+position whose position is used.
Emacs signals an error if either argument is invalid.
+This function ignores @code{symbols-with-pos-enabled}.
@end defun
diff --git a/doc/lispref/text.texi b/doc/lispref/text.texi
index 078b2d55a60..3d14a5ad8be 100644
--- a/doc/lispref/text.texi
+++ b/doc/lispref/text.texi
@@ -5922,74 +5922,109 @@ Nevertheless, we can define two distinct APIs around the
@cindex JSONRPC application interfaces
@enumerate
-@item A user interface for building JSONRPC applications
+@item An API for building JSONRPC applications
@findex :request-dispatcher
@findex :notification-dispatcher
@findex jsonrpc-notify
@findex jsonrpc-request
@findex jsonrpc-async-request
-In this scenario, the JSONRPC application selects a concrete subclass
-of @code{jsonrpc-connection}, and proceeds to create objects of that
-subclass using @code{make-instance}. To initiate a contact to the
-remote endpoint, the JSONRPC application passes this object to the
-functions @code{jsonrpc-notify}, @code{jsonrpc-request}, and/or
-@code{jsonrpc-async-request}. For handling remotely initiated
-contacts, which generally come in asynchronously, the instantiation
-should include @code{:request-dispatcher} and
-@code{:notification-dispatcher} initargs, which are both functions of
-3 arguments: the connection object; a symbol naming the JSONRPC method
-invoked remotely; and a JSONRPC @code{params} object.
+In this scenario, a new aspiring JSONRPC-based application selects a
+concrete subclass of @code{jsonrpc-connection} that provides the
+transport for the JSONRPC messages to be exchanged between endpoints.
+
+The application creates objects of that subclass using
+@code{make-instance}. To initiate a contact to a remote endpoint, the
+application passes this object to the functions such as
+@code{jsonrpc-notify}, @code{jsonrpc-request}, or
+@code{jsonrpc-async-request}.
+
+For handling remotely initiated contacts, which generally come in
+asynchronously, the @code{make-instance} instantiation should
+initialize it the @code{:request-dispatcher} and
+@code{:notification-dispatcher} EIEIO keyword arguments. These are
+both functions of 3 arguments: the connection object; a symbol naming
+the JSONRPC method invoked remotely; and a JSONRPC @code{params}
+object.
@findex jsonrpc-error
The function passed as @code{:request-dispatcher} is responsible for
handling the remote endpoint's requests, which expect a reply from the
-local endpoint (in this case, the program you're building). Inside
-that function, you may either return locally (a normal return) or
-non-locally (an error return). A local return value must be a Lisp
-object that can be serialized as JSON (@pxref{Parsing JSON}). This
-determines a success response, and the object is forwarded to the
-server as the JSONRPC @code{result} object. A non-local return,
-achieved by calling the function @code{jsonrpc-error}, causes an error
-response to be sent to the server. The details of the accompanying
-JSONRPC @code{error} are filled out with whatever was passed to
+local endpoint (in this case, the application you're building).
+Inside that function, you may either return locally (a regular return)
+or non-locally (throw an error). Both exits from the request
+dispatcher cause a reply to the remote endpoint's request to be sent
+through the transport.
+
+A regular return determines a success response, and the return value
+must be a Lisp object that can be serialized as JSON (@pxref{Parsing
+JSON}). The result is forwarded to the server as the JSONRPC
+@code{result} object. A non-local return, achieved by calling the
+function @code{jsonrpc-error}, causes an error response to be sent to
+the server. The details of the accompanying JSONRPC @code{error}
+object are filled out with whatever was passed to
@code{jsonrpc-error}. A non-local return triggered by an unexpected
error of any other type also causes an error response to be sent
(unless you have set @code{debug-on-error}, in which case this calls
the Lisp debugger, @pxref{Error Debugging}).
-@item A inheritance interface for building JSONRPC transport implementations
-
-In this scenario, @code{jsonrpc-connection} is subclassed to implement
+@findex jsonrpc-convert-to-endpoint
+@findex jsonrpc-convert-from-endpoint
+It's possible to use the @code{jsonrpc} library to build applications
+based on transport protocols that can be described as
+``quasi-JSONRPC''. These are similar, but not quite identical to
+JSONRPC, such as the @uref{https://www.jsonrpc.org/, DAP (Debug
+Adapter Protocol)}. These protocols also define request, response and
+notification messages but the format is not quite the same as JSONRPC.
+The generic functions @code{jsonrpc-convert-to-endpoint} and
+@code{jsonrpc-convert-from-endpoint} can be customized for converting
+between the internal representation of JSONRPC and whatever the
+endpoint accepts (@pxref{Generic Functions}).
+
+@item An API for building JSONRPC transports
+
+In this scenario, @code{jsonrpc-connection} is sub-classed to implement
a different underlying transport strategy (for details on how to
subclass, see @ref{Inheritance,Inheritance,,eieio}.). Users of the
application-building interface can then instantiate objects of this
concrete class (using the @code{make-instance} function) and connect
-to JSONRPC endpoints using that strategy.
+to JSONRPC endpoints using that strategy. See @ref{Process-based
+JSONRPC connections} for a built-in transport implementation.
This API has mandatory and optional parts.
@findex jsonrpc-connection-send
To allow its users to initiate JSONRPC contacts (notifications or
-requests) or reply to endpoint requests, the subclass must have an
-implementation of the @code{jsonrpc-connection-send} method.
+requests) or reply to endpoint requests, the new transport
+implementation must equip the @code{jsonrpc-connection-send} generic
+function with a specialization for the the new subclass
+(@pxref{Generic Functions}). This generic function is called
+automatically by primitives such as @code{jsonrpc-request} and
+@code{jsonrpc-notify}. The specialization should ensure that the
+message described in the argument list is sent through whatever
+underlying communication mechanism (a.k.a.@: ``wire'') is used by the
+new transport to talk to endpoints. This ``wire'' may be a network
+socket, a serial interface, an HTTP connection, etc.
@findex jsonrpc-connection-receive
Likewise, for handling the three types of remote contacts (requests,
notifications, and responses to local requests), the transport
implementation must arrange for the function
-@code{jsonrpc-connection-receive} to be called after noticing a new
-JSONRPC message on the wire (whatever that "wire" may be).
+@code{jsonrpc-connection-receive} to be called from Elisp after
+noticing some data on the ``wire'' that can be used to craft a JSONRPC
+(or quasi-JSONRPC) message.
@findex jsonrpc-shutdown
@findex jsonrpc-running-p
Finally, and optionally, the @code{jsonrpc-connection} subclass should
-implement the @code{jsonrpc-shutdown} and @code{jsonrpc-running-p}
-methods if these concepts apply to the transport. If they do, then
-any system resources (e.g.@: processes, timers, etc.) used to listen for
-messages on the wire should be released in @code{jsonrpc-shutdown},
-i.e.@: they should only be needed while @code{jsonrpc-running-p} is
-non-@code{nil}.
+add specializations to the @code{jsonrpc-shutdown} and
+@code{jsonrpc-running-p} generic functions if these concepts apply to
+the transport. The specialization of @code{jsonrpc-shutdown} should
+ensure the release of any system resources (e.g.@: processes, timers,
+etc.) used to listen for messages on the wire. The specialization of
+@code{jsonrpc-running-p} should tell if these resources are still
+active or have already been released (via @code{jsonrpc-shutdown} or
+otherwise).
@end enumerate
@@ -6202,6 +6237,17 @@ would expect. Non-nested use of change groups for the same buffer
will get Emacs confused, so don't let it happen; the first change
group you start for any given buffer should be the last one finished.
+ Emacs keeps track of change groups by assuming that by following
+each cdr in @code{buffer-undo-list}, it will eventually arrive at the
+cons it was set to at the time @code{prepare-change-group} was called.
+
+ If @code{buffer-undo-list} no longer contains that cons, Emacs will
+lose track of any change groups, resulting in an error when the change
+group is canceled. To avoid this, do not call any functions which
+may edit the undo list in such a manner, when a change group is
+active: notably, ``amalgamating'' commands such as @code{delete-char},
+which call @code{undo-auto-amalgamate}.
+
@node Change Hooks
@section Change Hooks
@cindex change hooks
diff --git a/doc/lispref/tips.texi b/doc/lispref/tips.texi
index d538f416740..0db9a35ac6f 100644
--- a/doc/lispref/tips.texi
+++ b/doc/lispref/tips.texi
@@ -98,7 +98,7 @@ alternative common prefixes, so long as they make sense.
@item
We recommend enabling @code{lexical-binding} in new code, and
converting existing Emacs Lisp code to enable @code{lexical-binding}
-if it doesn't already. @xref{Using Lexical Binding}.
+if it doesn't already. @xref{Selecting Lisp Dialect}.
@item
Put a call to @code{provide} at the end of each separate Lisp file.
diff --git a/doc/lispref/variables.texi b/doc/lispref/variables.texi
index 0e8c127433b..4d61d461deb 100644
--- a/doc/lispref/variables.texi
+++ b/doc/lispref/variables.texi
@@ -1,6 +1,6 @@
@c -*-texinfo-*-
@c This is part of the GNU Emacs Lisp Reference Manual.
-@c Copyright (C) 1990--1995, 1998--2024 Free Software Foundation, Inc.
+@c Copyright (C) 1990--2024 Free Software Foundation, Inc.
@c See the file elisp.texi for copying conditions.
@node Variables
@chapter Variables
@@ -351,8 +351,8 @@ A function call is in the tail position if it's the very last thing
done so that the value returned by the call is the value of @var{body}
itself, as is the case in the recursive call to @code{sum} above.
-@strong{Warning:} @code{named-let} works as expected only when
-lexical-binding is enabled. @xref{Lexical Binding}.
+@code{named-let} can only be used when lexical-binding is enabled.
+@xref{Lexical Binding}.
@end defspec
Here is a complete list of the other facilities that create local
@@ -976,184 +976,59 @@ Variables}). This section describes exactly what this means.
binding can be accessed. @dfn{Extent} refers to @emph{when}, as the
program is executing, the binding exists.
-@cindex dynamic binding
-@cindex dynamic scope
-@cindex dynamic extent
- By default, the local bindings that Emacs creates are @dfn{dynamic
-bindings}. Such a binding has @dfn{dynamic scope}, meaning that any
-part of the program can potentially access the variable binding. It
-also has @dfn{dynamic extent}, meaning that the binding lasts only
-while the binding construct (such as the body of a @code{let} form) is
-being executed.
-
@cindex lexical binding
@cindex lexical scope
+@cindex static scope
@cindex indefinite extent
- Emacs can optionally create @dfn{lexical bindings}. A lexical
-binding has @dfn{lexical scope}, meaning that any reference to the
-variable must be located textually within the binding
+ For historical reasons, there are two dialects of Emacs Lisp,
+selected via the @code{lexical-binding} buffer-local variable.
+In the modern Emacs Lisp dialect, local bindings are lexical by default.
+A @dfn{lexical binding} has @dfn{lexical scope}, meaning that any
+reference to the variable must be located textually within the binding
construct@footnote{With some exceptions; for instance, a lexical
binding can also be accessed from the Lisp debugger.}. It also has
@dfn{indefinite extent}, meaning that under some circumstances the
binding can live on even after the binding construct has finished
-executing, by means of special objects called @dfn{closures}.
+executing, by means of objects called @dfn{closures}.
+Lexical scoping is also commonly called @dfn{static scoping}.
- The dynamic binding was (and still is) the default in Emacs for many
-years, but lately Emacs is moving towards using lexical binding in
-more and more places, with the goal of eventually making that the
-default.
+@cindex dynamic binding
+@cindex dynamic scope
+@cindex dynamic extent
+ Local bindings can also be dynamic, which they always are in the
+old Emacs Lisp dialect and optionally in the modern dialect.
+A @dfn{dynamic binding} has @dfn{dynamic scope}, meaning that any
+part of the program can potentially access the variable binding. It
+also has @dfn{dynamic extent}, meaning that the binding lasts only
+while the binding construct (such as the body of a @code{let} form) is
+being executed.
- The following subsections describe dynamic binding and lexical
+ The old dynamic-only Emacs Lisp dialect is still the default in code
+loaded or evaluated from Lisp files that lack a dialect declaration.
+Eventually the modern dialect will be made the default.
+All Lisp files should declare the dialect used to ensure that they
+keep working correctly in the future.
+
+ The following subsections describe lexical binding and dynamic
binding in greater detail, and how to enable lexical binding in Emacs
Lisp programs.
@menu
-* Dynamic Binding:: The default for binding local variables in Emacs.
+* Lexical Binding:: The standard type of local variable binding.
+* Dynamic Binding:: A different type of local variable binding.
* Dynamic Binding Tips:: Avoiding problems with dynamic binding.
-* Lexical Binding:: A different type of local variable binding.
-* Using Lexical Binding:: How to enable lexical binding.
+* Selecting Lisp Dialect:: How to select the Emacs Lisp dialect to use.
* Converting to Lexical Binding:: Convert existing code to lexical binding.
@end menu
-@node Dynamic Binding
-@subsection Dynamic Binding
-
- By default, the local variable bindings made by Emacs are dynamic
-bindings. When a variable is dynamically bound, its current binding
-at any point in the execution of the Lisp program is simply the most
-recently-created dynamic local binding for that symbol, or the global
-binding if there is no such local binding.
-
- Dynamic bindings have dynamic scope and extent, as shown by the
-following example:
-
-@example
-@group
-(defvar x -99) ; @r{@code{x} receives an initial value of @minus{}99.}
-
-(defun getx ()
- x) ; @r{@code{x} is used free in this function.}
-
-(let ((x 1)) ; @r{@code{x} is dynamically bound.}
- (getx))
- @result{} 1
-
-;; @r{After the @code{let} form finishes, @code{x} reverts to its}
-;; @r{previous value, which is @minus{}99.}
-
-(getx)
- @result{} -99
-@end group
-@end example
-
-@noindent
-The function @code{getx} refers to @code{x}. This is a @dfn{free}
-reference, in the sense that there is no binding for @code{x} within
-that @code{defun} construct itself. When we call @code{getx} from
-within a @code{let} form in which @code{x} is (dynamically) bound, it
-retrieves the local value (i.e., 1). But when we call @code{getx}
-outside the @code{let} form, it retrieves the global value (i.e.,
-@minus{}99).
-
- Here is another example, which illustrates setting a dynamically
-bound variable using @code{setq}:
-
-@example
-@group
-(defvar x -99) ; @r{@code{x} receives an initial value of @minus{}99.}
-
-(defun addx ()
- (setq x (1+ x))) ; @r{Add 1 to @code{x} and return its new value.}
-
-(let ((x 1))
- (addx)
- (addx))
- @result{} 3 ; @r{The two @code{addx} calls add to @code{x} twice.}
-
-;; @r{After the @code{let} form finishes, @code{x} reverts to its}
-;; @r{previous value, which is @minus{}99.}
-
-(addx)
- @result{} -98
-@end group
-@end example
-
- Dynamic binding is implemented in Emacs Lisp in a simple way. Each
-symbol has a value cell, which specifies its current dynamic value (or
-absence of value). @xref{Symbol Components}. When a symbol is given
-a dynamic local binding, Emacs records the contents of the value cell
-(or absence thereof) in a stack, and stores the new local value in the
-value cell. When the binding construct finishes executing, Emacs pops
-the old value off the stack, and puts it in the value cell.
-
- Note that when code using Dynamic Binding is native compiled the
-native compiler will not perform any Lisp specific optimization.
-
-@node Dynamic Binding Tips
-@subsection Proper Use of Dynamic Binding
-
- Dynamic binding is a powerful feature, as it allows programs to
-refer to variables that are not defined within their local textual
-scope. However, if used without restraint, this can also make
-programs hard to understand. There are two clean ways to use this
-technique:
-
-@itemize @bullet
-@item
-If a variable has no global definition, use it as a local variable
-only within a binding construct, such as the body of the @code{let}
-form where the variable was bound. If this convention is followed
-consistently throughout a program, the value of the variable will not
-affect, nor be affected by, any uses of the same variable symbol
-elsewhere in the program.
-
-@item
-Otherwise, define the variable with @code{defvar}, @code{defconst}
-(@pxref{Defining Variables}), or @code{defcustom} (@pxref{Variable
-Definitions}). Usually, the definition should be at top-level in an
-Emacs Lisp file. As far as possible, it should include a
-documentation string which explains the meaning and purpose of the
-variable. You should also choose the variable's name to avoid name
-conflicts (@pxref{Coding Conventions}).
-
-Then you can bind the variable anywhere in a program, knowing reliably
-what the effect will be. Wherever you encounter the variable, it will
-be easy to refer back to the definition, e.g., via the @kbd{C-h v}
-command (provided the variable definition has been loaded into Emacs).
-@xref{Name Help,,, emacs, The GNU Emacs Manual}.
-
-For example, it is common to use local bindings for customizable
-variables like @code{case-fold-search}:
-
-@example
-@group
-(defun search-for-abc ()
- "Search for the string \"abc\", ignoring case differences."
- (let ((case-fold-search t))
- (re-search-forward "abc")))
-@end group
-@end example
-@end itemize
-
@node Lexical Binding
@subsection Lexical Binding
- Lexical binding was introduced to Emacs, as an optional feature, in
-version 24.1. We expect its importance to increase with time.
-Lexical binding opens up many more opportunities for optimization, so
-programs using it are likely to run faster in future Emacs versions.
-Lexical binding is also more compatible with concurrency, which was
-added to Emacs in version 26.1.
-
- A lexically-bound variable has @dfn{lexical scope}, meaning that any
+Lexical binding is only available in the modern Emacs Lisp dialect.
+(@xref{Selecting Lisp Dialect}.)
+A lexically-bound variable has @dfn{lexical scope}, meaning that any
reference to the variable must be located textually within the binding
construct. Here is an example
-@iftex
-(see the next subsection, for how to actually enable lexical binding):
-@end iftex
-@ifnottex
-(@pxref{Using Lexical Binding}, for how to actually enable lexical binding):
-@end ifnottex
@example
@group
@@ -1186,17 +1061,6 @@ wants the current value of a variable, it looks first in the lexical
environment; if the variable is not specified in there, it looks in
the symbol's value cell, where the dynamic value is stored.
- (Internally, the lexical environment is a list whose members are
-usually cons cells that are symbol-value pairs, but some of its
-members can be symbols rather than cons cells. A symbol in the list
-means the lexical environment declared that symbol's variable as
-locally considered to be dynamically bound. This list can be passed
-as the second argument to the @code{eval} function, in order to
-specify a lexical environment in which to evaluate a form.
-@xref{Eval}. Most Emacs Lisp programs, however, should not interact
-directly with lexical environments in this way; only specialized
-programs like debuggers.)
-
@cindex closures, example of using
Lexical bindings have indefinite extent. Even after a binding
construct has finished executing, its lexical environment can be
@@ -1249,37 +1113,74 @@ functions which take a symbol argument (like @code{symbol-value},
variable's dynamic binding (i.e., the contents of its symbol's value
cell).
-@node Using Lexical Binding
-@subsection Using Lexical Binding
+@node Dynamic Binding
+@subsection Dynamic Binding
- When loading an Emacs Lisp file or evaluating a Lisp buffer, lexical
-binding is enabled if the buffer-local variable @code{lexical-binding}
-is non-@code{nil}:
+ Local variable bindings are dynamic in the modern Lisp dialect for
+special variables (see below), and for all variables in the old Lisp
+dialect. (@xref{Selecting Lisp Dialect}.)
+Dynamic variable bindings have their uses but are in general more
+error-prone and less efficient than lexical bindings, and the compiler
+is less able to find mistakes in code using dynamic bindings.
-@defvar lexical-binding
-If this buffer-local variable is non-@code{nil}, Emacs Lisp files and
-buffers are evaluated using lexical binding instead of dynamic
-binding. (However, special variables are still dynamically bound; see
-below.) If @code{nil}, dynamic binding is used for all local
-variables. This variable is typically set for a whole Emacs Lisp
-file, as a file local variable (@pxref{File Local Variables}).
-Note that unlike other such variables, this one must be set in the
-first line of a file.
-@end defvar
+ When a variable is dynamically bound, its current binding
+at any point in the execution of the Lisp program is simply the most
+recently-created dynamic local binding for that symbol, or the global
+binding if there is no such local binding.
+
+ Dynamic bindings have dynamic scope and extent, as shown by the
+following example:
+
+@example
+@group
+(defvar x -99) ; @r{@code{x} receives an initial value of @minus{}99.}
+
+(defun getx ()
+ x) ; @r{@code{x} is used free in this function.}
+
+(let ((x 1)) ; @r{@code{x} is dynamically bound.}
+ (getx))
+ @result{} 1
+
+;; @r{After the @code{let} form finishes, @code{x} reverts to its}
+;; @r{previous value, which is @minus{}99.}
+
+(getx)
+ @result{} -99
+@end group
+@end example
@noindent
-When evaluating Emacs Lisp code directly using an @code{eval} call,
-lexical binding is enabled if the @var{lexical} argument to
-@code{eval} is non-@code{nil}. @xref{Eval}.
+The function @code{getx} refers to @code{x}. This is a @dfn{free}
+reference, in the sense that there is no binding for @code{x} within
+that @code{defun} construct itself. When we call @code{getx} from
+within a @code{let} form in which @code{x} is (dynamically) bound, it
+retrieves the local value (i.e., 1). But when we call @code{getx}
+outside the @code{let} form, it retrieves the global value (i.e.,
+@minus{}99).
-@findex eval-expression@r{, and }lexical-binding
-Lexical binding is also enabled in Lisp Interaction and IELM mode,
-used in the @file{*scratch*} and @file{*ielm*} buffers, and also when
-evaluating expressions via @kbd{M-:} (@code{eval-expression}) and when
-processing the @option{--eval} command-line options of Emacs
-(@pxref{Action Arguments,,, emacs, The GNU Emacs Manual}) and
-@command{emacsclient} (@pxref{emacsclient Options,,, emacs, The GNU
-Emacs Manual}).
+ Here is another example, which illustrates setting a dynamically
+bound variable using @code{setq}:
+
+@example
+@group
+(defvar x -99) ; @r{@code{x} receives an initial value of @minus{}99.}
+
+(defun addx ()
+ (setq x (1+ x))) ; @r{Add 1 to @code{x} and return its new value.}
+
+(let ((x 1))
+ (addx)
+ (addx))
+ @result{} 3 ; @r{The two @code{addx} calls add to @code{x} twice.}
+
+;; @r{After the @code{let} form finishes, @code{x} reverts to its}
+;; @r{previous value, which is @minus{}99.}
+
+(addx)
+ @result{} -98
+@end group
+@end example
@cindex special variables
Even when lexical binding is enabled, certain variables will
@@ -1329,6 +1230,111 @@ for those that are only special in the current lexical scope.
The use of a special variable as a formal argument in a function is
not supported.
+ Dynamic binding is implemented in Emacs Lisp in a simple way. Each
+symbol has a value cell, which specifies its current dynamic value (or
+absence of value). @xref{Symbol Components}. When a symbol is given
+a dynamic local binding, Emacs records the contents of the value cell
+(or absence thereof) in a stack, and stores the new local value in the
+value cell. When the binding construct finishes executing, Emacs pops
+the old value off the stack, and puts it in the value cell.
+
+@node Dynamic Binding Tips
+@subsection Proper Use of Dynamic Binding
+
+ Dynamic binding is a powerful feature, as it allows programs to
+refer to variables that are not defined within their local textual
+scope. However, if used without restraint, this can also make
+programs hard to understand.
+
+First, choose the variable's name to avoid name conflicts
+(@pxref{Coding Conventions}).
+
+@itemize @bullet
+@item
+If the variable is only used when locally bound to a value, declare it
+special using a @code{defvar} form without an initial value, and never
+assign to it unless it is already bound. This way, any attempt to
+refer to the variable when unbound will result in a
+@code{void-variable} error.
+
+@item
+Otherwise, define the variable with @code{defvar}, @code{defconst}
+(@pxref{Defining Variables}), or @code{defcustom} (@pxref{Variable
+Definitions}). Usually, the definition should be at top-level in an
+Emacs Lisp file. As far as possible, it should include a
+documentation string which explains the meaning and purpose of the
+variable.
+
+Then you can bind the variable anywhere in a program, knowing reliably
+what the effect will be. Wherever you encounter the variable, it will
+be easy to refer back to the definition, e.g., via the @kbd{C-h v}
+command (provided the variable definition has been loaded into Emacs).
+@xref{Name Help,,, emacs, The GNU Emacs Manual}.
+
+For example, it is common to use local bindings for customizable
+variables like @code{case-fold-search}:
+
+@example
+@group
+(defun search-for-abc ()
+ "Search for the string \"abc\", ignoring case differences."
+ (let ((case-fold-search t))
+ (re-search-forward "abc")))
+@end group
+@end example
+@end itemize
+
+@node Selecting Lisp Dialect
+@subsection Selecting Lisp Dialect
+
+ When loading an Emacs Lisp file or evaluating a Lisp buffer, the
+Lisp dialect is selected using the buffer-local variable
+@code{lexical-binding}.
+
+@defvar lexical-binding
+If this buffer-local variable is non-@code{nil}, Emacs Lisp files and
+buffers are evaluated using the modern Lisp dialect that by default
+uses lexical binding instead of dynamic binding. If @code{nil}, the
+old dialect is used that uses dynamic binding for all local variables.
+This variable is typically set for a whole Emacs Lisp file, as a
+file-local variable (@pxref{File Local Variables}). Note that unlike
+other such variables, this one must be set in the first line of a
+file.
+@end defvar
+
+@noindent
+In practice, dialect selection means that the first line in an Emacs
+Lisp file looks like:
+
+@example
+;;; ... -*- lexical-binding: t -*-
+@end example
+
+@noindent
+for the modern lexical-binding dialect, and
+
+@example
+;;; ... -*- lexical-binding: nil -*-
+@end example
+
+@noindent
+for the old dynamic-only dialect. When no declaration is present the
+old dialect is used, but this may change in a future release.
+The compiler will warn if no declaration is present.
+
+When evaluating Emacs Lisp code directly using an @code{eval} call,
+lexical binding is enabled if the @var{lexical} argument to
+@code{eval} is non-@code{nil}. @xref{Eval}.
+
+@findex eval-expression@r{, and }lexical-binding
+Lexical binding is also enabled in Lisp Interaction and IELM mode,
+used in the @file{*scratch*} and @file{*ielm*} buffers, and also when
+evaluating expressions via @kbd{M-:} (@code{eval-expression}) and when
+processing the @option{--eval} command-line options of Emacs
+(@pxref{Action Arguments,,, emacs, The GNU Emacs Manual}) and
+@command{emacsclient} (@pxref{emacsclient Options,,, emacs, The GNU
+Emacs Manual}).
+
@node Converting to Lexical Binding
@subsection Converting to Lexical Binding
@@ -1891,7 +1897,7 @@ This makes its global value shadowed by the binding;
@code{default-value} will then return the value from that binding, not
the global value, and @code{set-default} will be prevented from
setting the global value (it will change the let-bound value instead).
-The following two functions allow to reference the global value even
+The following two functions allow referencing the global value even
if it's shadowed by a let-binding.
@cindex top-level default value
@@ -1980,6 +1986,16 @@ this can be controlled by using this variable, which is a list of
symbols.
@end defvar
+@defvar safe-local-variable-directories
+This is a list of directories where local variables are always
+enabled. Directory-local variables loaded from these directories,
+such as the variables in @file{.dir-locals.el}, will be enabled even
+if they are risky. The directories in this list must be
+fully-expanded absolute file names. They may also be remote
+directories if the variable @code{enable-remote-dir-locals} is set
+non-@code{nil}.
+@end defvar
+
@defun hack-local-variables &optional handle-mode
This function parses, and binds or evaluates as appropriate, any local
variables specified by the contents of the current buffer. The variable
@@ -2473,9 +2489,10 @@ are unwound. Example:
@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 you can let-bind it to change the application temporarily
-(@pxref{Local Variables}).
+@code{with-connection-local-variables}, @code{connection-local-p} and
+@code{connection-local-value}. It defaults to @code{tramp}, but you
+can let-bind it to change the application temporarily (@pxref{Local
+Variables}).
This variable must not be changed globally.
@end defvar
@@ -2531,6 +2548,22 @@ profile.
This variable must not be changed globally.
@end defvar
+@defmac connection-local-p symbol &optional application
+This macro returns non-@code{nil} if @var{symbol} has a
+connection-local binding for @var{application}. If @var{application}
+is @code{nil}, the value of
+@code{connection-local-default-application} is used.
+@end defmac
+
+@defmac connection-local-value symbol &optional application
+This macro returns the connection-local value of @var{symbol} for
+@var{application}. If @var{application} is @code{nil}, the value of
+@code{connection-local-default-application} is used.
+
+If @var{symbol} does not have a connection-local
+binding, the value is the default binding of the variable.
+@end defmac
+
@defvar enable-connection-local-variables
If @code{nil}, connection-local variables are ignored. This variable
shall be changed temporarily only in special modes.
@@ -2564,6 +2597,9 @@ documentation as @var{base-variable} has, if any, unless
the documentation of the variable at the end of the chain of aliases.
This function returns @var{base-variable}.
+
+If the resulting variable definition chain would be circular, then
+Emacs will signal a @code{cyclic-variable-indirection} error.
@end defun
Variable aliases are convenient for replacing an old name for a
@@ -2612,9 +2648,6 @@ look like:
This function returns the variable at the end of the chain of aliases
of @var{variable}. If @var{variable} is not a symbol, or if @var{variable} is
not defined as an alias, the function returns @var{variable}.
-
-This function signals a @code{cyclic-variable-indirection} error if
-there is a loop in the chain of symbols.
@end defun
@example
diff --git a/doc/lispref/windows.texi b/doc/lispref/windows.texi
index d72da704f13..eef05d94fdb 100644
--- a/doc/lispref/windows.texi
+++ b/doc/lispref/windows.texi
@@ -2851,8 +2851,8 @@ the left edge coordinate of the reference window. Its left edge
coordinate would equal the left edge coordinate of the frame's new
root window.
-Four special values for @code{direction} entries allow to implicitly
-specify the selected frame's main window as the reference window:
+Four special values for @code{direction} entries allow implicitly
+specifying the selected frame's main window as the reference window:
@code{leftmost}, @code{top}, @code{rightmost} and @code{bottom}. This
means that instead of, for example, @w{@code{(direction . left)
(window . main)}} one can just specify @w{@code{(direction
@@ -3272,6 +3272,15 @@ The value specifies an alist of frame parameters to give a new frame,
if one is created. @code{display-buffer-pop-up-frame} is its one and
only addressee.
+@vindex pop-up-frames@r{, a buffer display action alist entry}
+@item pop-up-frames
+The value controls whether @code{display-buffer} may display buffers
+by making new frames. It has the same meaning as the
+@code{pop-up-frames} variable and takes precedence over it when present.
+Its main intended purpose is to override a non-nil value of the
+variable for particular buffers which the user prefers to keep
+in the selected frame.
+
@vindex parent-frame@r{, a buffer display action alist entry}
@item parent-frame
The value specifies the parent frame to be used when the buffer is
@@ -3335,6 +3344,16 @@ It is called @emph{after} the buffer is displayed, and @emph{before}
the entries @code{window-height}, @code{window-width} and
@code{preserve-size} are applied that could resize the window to fit
it to the inserted contents.
+
+@vindex post-command-select-window@r{, a buffer display action alist entry}
+@item post-command-select-window
+If the value is non-@code{nil}, the buffer displayed by @code{display-buffer}
+is selected after the current command is executed by running the hook
+@code{post-command-hook} (@pxref{Command Overview}).
+If the value is @code{nil}, the buffer selected by such functions as
+@code{pop-to-buffer} is deselected, and the window that was selected
+before calling this function will remain selected regardless of which
+windows were selected afterwards within this command.
@end table
By convention, the entries @code{window-height}, @code{window-width}
@@ -3445,6 +3464,9 @@ A non-@code{nil} value also means that when @code{display-buffer} is
looking for a window already displaying @var{buffer-or-name}, it can
search any visible or iconified frame, not just the selected frame.
+An entry by the same name in @code{display-buffer}'s @var{alist}
+takes precedence over the variable.
+
This variable is provided mainly for backward compatibility. It is
obeyed by @code{display-buffer} via a special mechanism in
@code{display-buffer-fallback-action}, which calls the action function
@@ -3516,15 +3538,12 @@ functions it should try instead as, for example:
@item pop-up-frames
@vindex pop-up-frames@r{, replacement for}
-Instead of customizing this variable to @code{t}, customize
+Instead of customizing this variable to @code{t}, you can customize
@code{display-buffer-base-action}, for example, as follows:
@example
@group
-(setopt
- display-buffer-base-action
- '((display-buffer-reuse-window display-buffer-pop-up-frame)
- (reusable-frames . 0)))
+(setopt display-buffer-base-action '(nil (pop-up-frames . t)))
@end group
@end example
@@ -3763,7 +3782,7 @@ preferred way regardless of whether the display is also guided by an
@code{display-buffer-alist} differs from customizing
@code{display-buffer-base-action} in two major aspects: it is stronger
because it overrides the @var{action} argument of
-@code{display-buffer}, and it allows to explicitly specify the
+@code{display-buffer}, and it enables you to explicitly specify the
affected buffers. In fact, displaying other buffers is not affected
in any way by a customization for @file{*foo*}. For example,
@@ -4600,7 +4619,7 @@ window and a number of side windows surrounding that main window. The
main window is either a ``normal'' live window or specifies the area
containing all the normal windows.
- In their most simple form of use, side windows allow to display
+ In their most simple form of use, side windows allow displaying
specific buffers always in the same area of a frame. Hence they can
be regarded as a generalization of the concept provided by
@code{display-buffer-at-bottom} (@pxref{Buffer Display Action
@@ -6154,11 +6173,11 @@ up-to-date.
@section Mouse Window Auto-selection
@cindex window auto-selection
@cindex auto-selection of window
-The following option allows to automatically select the window under the
-mouse pointer. This accomplishes a policy similar to that of window
-managers that give focus to a frame (and thus trigger its subsequent
-selection) whenever the mouse pointer enters its window-system window
-(@pxref{Input Focus}).
+The following option enables automatically selecting the window under
+the mouse pointer. This accomplishes a policy similar to that of
+window managers that give focus to a frame (and thus trigger its
+subsequent selection) whenever the mouse pointer enters its
+window-system window (@pxref{Input Focus}).
@defopt mouse-autoselect-window
If this variable is non-@code{nil}, Emacs will try to automatically
@@ -6192,7 +6211,7 @@ and never deselects the active minibuffer window.
Mouse auto-selection can be used to emulate a focus follows mouse policy
for child frames (@pxref{Child Frames}) which usually are not tracked by
-the window manager. This requires to set the value of
+the window manager. This requires setting the value of
@code{focus-follows-mouse} (@pxref{Input Focus}) to a non-@code{nil}
value. If the value of @code{focus-follows-mouse} is @code{auto-raise},
entering a child frame with the mouse will raise it automatically above
@@ -6245,11 +6264,10 @@ this function does is to restore the value of the variable
@code{minibuffer-selected-window}. In this case, the function returns
@code{nil}. Otherwise, it returns @code{t}.
-If the buffer of a window of @var{configuration} has been killed since
-@var{configuration} was made, that window is, as a rule, removed from
-the restored configuration. However, if that window is the last
-window remaining in the restored configuration, another live buffer is
-shown in it.
+This function consults the variable
+@code{window-restore-killed-buffer-windows} (see below) when it tries to
+restore a window whose buffer was killed after @var{configuration} was
+recorded.
Here is a way of using this function to get the same effect as
@code{save-window-excursion}:
@@ -6338,14 +6356,90 @@ a live window, it is replaced by a new live window created on the same
frame before putting @var{state} into it. If @var{window} is @code{nil},
it puts the window state into a new window.
+This function consults the variable
+@code{window-restore-killed-buffer-windows} (see below) when it tries to
+restore a window whose buffer was killed after @var{state} was recorded.
+
If the optional argument @var{ignore} is non-@code{nil}, it means to ignore
minimum window sizes and fixed-size restrictions. If @var{ignore}
is @code{safe}, this means windows can get as small as one line
and/or two columns.
@end defun
+By default, @code{set-window-configuration} and @code{window-state-put}
+may delete a window from the restored configuration when they find out
+that its buffer was killed since the corresponding configuration or
+state has been recorded. The variable described next can be used to
+fine-tune that behavior.
+
+@cindex restoring windows whose buffers have been killed
+@defvar window-restore-killed-buffer-windows
+This variable specifies how @code{set-window-configuration} and
+@code{window-state-put} shall handle a window whose buffer has been
+killed since the corresponding configuration or state was recorded. Any
+such window may be live---in which case it shows some other buffer---or
+dead at the time one of these functions is called. Usually,
+@code{set-window-configuration} leaves the window alone if it is live
+while @code{window-state-put} deletes it.
+
+The following values can be used to override the default behavior for
+dead windows in the case of @code{set-window-configuration} and for dead
+and live windows in the case of @code{window-state-put}.
+
+@table @asis
+@item @code{t}
+This value means to unconditionally restore the window and show some
+other buffer in it.
+
+@item @code{delete}
+This means to unconditionally try to delete the window.
+
+@item @code{dedicated}
+This means to try to delete the window if and only if it is dedicated to
+its buffer.
+
+@item @code{nil}
+This is the default, and it means that @code{set-window-configuration}
+will try to delete the window if and only if it is dedicated to its
+buffer, and @code{window-state-put} will unconditionally try to delete
+it.
+
+@item a function
+This means to restore the window and show some other buffer in it, like
+if the value is @code{t}, and also add an entry for that window to a
+list that will be later passed as the second argument to that function.
+@end table
+
+If a window cannot be deleted (typically, because it is the last window
+on its frame), @code{set-window-configuration} and
+@code{window-state-put} will show another buffer in it.
+
+If the value of this variable is a function, that function should take
+three arguments. The first argument specifies the frame whose windows
+have been restored. The third argument is either the symbol
+@code{configuration} if the windows are restored by
+@code{set-window-configuration}, or the symbol @code{state} if the
+windows are restored by @code{window-state-put}.
+
+The second argument specifies a list of entries for @emph{all} windows
+whose previous buffers have been found dead at the time
+@code{set-window-configuration} or @code{window-state-put} tried to
+restore them (minibuffer windows are excluded). This means that the
+function may also delete windows which were found live by
+@code{set-window-configuration}.
+
+Each entry in the list that is passed as the second argument to the
+function is itself a list of six values: the window whose buffer was
+found dead, the dead buffer or its name, the positions of window-start
+(@pxref{Window Start and End}) and window-point (@pxref{Window Point})
+of the buffer in that window, the dedicated state of the window as
+previously reported by @code{window-dedicated-p} and a flag that is
+@code{t} if the window has been found to be alive by
+@code{set-window-configuration} and @code{nil} otherwise.
+@end defvar
+
The functions @code{window-state-get} and @code{window-state-put} also
-allow to exchange the contents of two live windows. The following
+allow exchanging the contents of two live windows. The following
function does precisely that:
@deffn Command window-swap-states &optional window-1 window-2 size
diff --git a/doc/man/ChangeLog.1 b/doc/man/ChangeLog.1
index 6b29bc5598c..b34480a98e9 100644
--- a/doc/man/ChangeLog.1
+++ b/doc/man/ChangeLog.1
@@ -74,7 +74,7 @@
* emacs.1: Small fixes.
-2010-10-12 Ulrich Mueller <ulm@gentoo.org>
+2010-10-12 Ulrich Müller <ulm@gentoo.org>
* emacs.1: Update license description.
@@ -82,7 +82,7 @@
* b2m.1: Remove file.
-2010-09-25 Ulrich Mueller <ulm@gentoo.org>
+2010-09-25 Ulrich Müller <ulm@gentoo.org>
* etags.1: xz compression is now supported.
diff --git a/doc/misc/ChangeLog.1 b/doc/misc/ChangeLog.1
index 6b204b45b9c..03b5037229e 100644
--- a/doc/misc/ChangeLog.1
+++ b/doc/misc/ChangeLog.1
@@ -4374,7 +4374,7 @@
* sc.texi (Getting Connected): Remove old index entries.
-2011-02-12 Ulrich Mueller <ulm@gentoo.org>
+2011-02-12 Ulrich Müller <ulm@gentoo.org>
* url.texi: Remove duplicate @dircategory (Bug#7942).
@@ -5126,7 +5126,7 @@
* gnus.texi (NoCeM): Remove.
(Startup Variables): No jingle.
-2010-09-25 Ulrich Mueller <ulm@gentoo.org>
+2010-09-25 Ulrich Müller <ulm@gentoo.org>
* woman.texi (Interface Options): xz compression is now supported.
diff --git a/doc/misc/autotype.texi b/doc/misc/autotype.texi
index 4c088593d9d..d927816c492 100644
--- a/doc/misc/autotype.texi
+++ b/doc/misc/autotype.texi
@@ -276,10 +276,10 @@ empty file is visited. This is accomplished by putting
@code{auto-insert-alist}. The @sc{car} of each element of this list
is either a mode name, making the element applicable when a buffer is
in that mode, or a string, which is a regexp matched against a
-buffer's file name (the latter allows to distinguish between different
-kinds of files that have the same mode in Emacs). The @sc{car} of an
-element may also be a cons cell, consisting of mode name or regexp, as
-above, and an additional descriptive string.
+buffer's file name (the latter enables you to distinguish between
+different kinds of files that have the same mode in Emacs). The
+@sc{car} of an element may also be a cons cell, consisting of mode
+name or regexp, as above, and an additional descriptive string.
When a matching element is found, the @sc{cdr} says what to do. It may
be a string, which is a file name, whose contents are to be inserted, if
diff --git a/doc/misc/calc.texi b/doc/misc/calc.texi
index ccc7b95ceec..ac2ac5a0f91 100644
--- a/doc/misc/calc.texi
+++ b/doc/misc/calc.texi
@@ -6,6 +6,7 @@
@settitle GNU Emacs Calc Manual
@include docstyle.texi
@setchapternewpage odd
+@documentencoding UTF-8
@comment %**end of header (This is for running Texinfo on a region.)
@include emacsver.texi
@@ -1196,7 +1197,7 @@ bent, contributed ideas and algorithms for a number of Calc features
including modulo forms, primality testing, and float-to-fraction conversion.
Units were added at the eager insistence of Mass Sivilotti. Later,
-Ulrich Mueller at CERN and Przemek Klosowski at NIST provided invaluable
+Ulrich Müller at CERN and Przemek Klosowski at NIST provided invaluable
expert assistance with the units table. As far as I can remember, the
idea of using algebraic formulas and variables to represent units dates
back to an ancient article in Byte magazine about muMath, an early
@@ -10571,6 +10572,21 @@ Non-decimal fractions are entered and displayed as
@samp{@var{radix}#@var{num}:@var{denom}} (or in the analogous three-part
form). The numerator and denominator always use the same radix.
+@ifnottex
+Fractions may also be entered with @kbd{⁄} (U+2044 FRACTION SLASH) in
+place of any @kbd{:}. Precomposed fraction characters from @kbd{½}
+(U+00BD VULGAR FRACTION ONE HALF) through @kbd{⅞} (U+215E VULGAR
+FRACTION SEVEN EIGHTHS) are supported as well. Thus, @samp{2:3},
+@samp{2⁄3}, and @samp{⅞} are all equivalent.
+@end ifnottex
+@iftex
+Fractions may also be entered with U+2044 FRACTION SLASH in place of
+any @kbd{:}. Precomposed fraction characters from U+00BD VULGAR
+FRACTION ONE HALF through U+215E VULGAR FRACTION SEVEN EIGHTHS are
+supported as well.
+@end iftex
+
+
@node Floats
@section Floats
@@ -11042,7 +11058,8 @@ the year even for older dates. The customizable variable
have Calc's date forms switch from the Julian to Gregorian calendar at
any specified date.
-Today's timekeepers introduce an occasional ``leap second''.
+A few platforms support leap seconds, such as the time stamp
+1972-06-30 23:59:60 UTC, an extra second appended to June 1972.
These do not occur regularly and Calc does not take these minor
effects into account. (If it did, it would have to report a
non-integer number of days between, say,
@@ -17342,8 +17359,12 @@ it can be a variable which is a time zone name in upper- or lower-case.
For example @samp{tzone(PST) = tzone(8)} and @samp{tzone(pdt) = tzone(7)}
(for Pacific standard and daylight saving times, respectively).
-North American and European time zone names are defined as follows;
-note that for each time zone there is one name for standard time,
+North American and European time zone names are defined as follows.
+These names are obsolescent and new code should not rely on them:
+the @samp{YST}-related names have disagreed with time in Yukon since 1973,
+and other names could well become confusing or wrong in the future
+as countries change their time zone rules.
+For each time zone there is one name for standard time,
another for daylight saving time, and a third for ``generalized'' time
in which the daylight saving adjustment is computed from context.
@@ -17365,7 +17386,7 @@ To define time zone names that do not appear in the above table,
you must modify the Lisp variable @code{math-tzone-names}. This
is a list of lists describing the different time zone names; its
structure is best explained by an example. The three entries for
-Pacific Time look like this:
+circa-2022 US Pacific Time look like this:
@smallexample
@group
@@ -28027,7 +28048,7 @@ unit name on the stack and then reduce it to base units with @kbd{u b}.
The @kbd{u e} (@code{calc-explain-units}) command displays an English
description of the units of the expression on the stack. For example,
for the expression @samp{62 km^2 g / s^2 mol K}, the description is
-``Square-Kilometer Gram per (Second-squared Mole Degree-Kelvin).'' This
+``Square-Kilometer Gram per (Second-squared Mole Kelvin).'' This
command uses the English descriptions that appear in the righthand
column of the Units Table.
@@ -28061,8 +28082,8 @@ Canadian (@code{galC}), and British (@code{galUK}) definitions. Also,
note that @code{oz} is a standard ounce of mass, @code{ozt} is a Troy
ounce, and @code{ozfl} is a fluid ounce.
-The temperature units corresponding to degrees Kelvin and Centigrade
-(Celsius) are the same in this table, since most units commands treat
+The temperature units corresponding to Kelvin and degree Celsius
+are the same in this table, since most units commands treat
temperatures as being relative. The @code{calc-convert-temperature}
command has special rules for handling the different absolute magnitudes
of the various temperature scales.
@@ -28471,12 +28492,12 @@ B and
the octave numbered 0 was chosen to correspond to the lowest
audible frequency. Using this system, middle C (about 261.625 Hz)
corresponds to the note @slanted{C} in octave 4 and is denoted
-@slanted{C@sub{4}}. Any frequency can be described by giving a note plus an
+@slanted{C4}. Any frequency can be described by giving a note plus an
offset in cents (where a cent is a ratio of frequencies so that a
semitone consists of 100 cents).
The midi note number system assigns numbers to notes so that
-@slanted{C@sub{-1}} corresponds to the midi note number 0 and @slanted{G@sub{9}}
+@slanted{C-1} corresponds to the midi note number 0 and @slanted{G9}
corresponds to the midi note number 127. A midi controller can have
up to 128 keys and each midi note number from 0 to 127 corresponds to
a possible key.
diff --git a/doc/misc/cc-mode.texi b/doc/misc/cc-mode.texi
index a727568148a..7f299180fc6 100644
--- a/doc/misc/cc-mode.texi
+++ b/doc/misc/cc-mode.texi
@@ -330,6 +330,7 @@ Syntactic Symbols
* Multiline Macro Symbols::
* Objective-C Method Symbols::
* Java Symbols::
+* Constraint Symbols::
* Statement Block Symbols::
* K&R Symbols::
@@ -2168,6 +2169,23 @@ which aren't of the default style will be fontified with
@section Miscellaneous Font Locking
@comment !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+Some compilers, notably GCC, allow the character @samp{$} to be a
+constituent of identifiers in the languages C, C++, and Objective C.
+CC Mode defaults to accepting these @samp{$} characters and fontifying
+the identifiers in which they appear like any others.
+
+However, the compiler you're using, or your project coding standards
+may disallow such use. In such cases, you can set
+@code{c-warn-ids-with-dollar} to non-@code{nil}. This causes these
+invalid identifiers to be fontified distinctively.
+
+@defvar c-warn-ids-with-dollar
+@vindex warn-ids-with-dollar (c-)
+When this customization option is non-@code{nil}, identifiers
+containing the @samp{$} character are fontified with
+@code{font-lock-warning-face}.
+@end defvar
+
In some languages, particularly in C++, there are constructs which are
syntactically ambiguous---they could be either declarations or
expressions, and @ccmode{} cannot tell for sure which. Often such a
@@ -4234,6 +4252,9 @@ The first line in a ``topmost'' definition. @ref{Function Symbols}.
Topmost definition continuation lines. This is only used in the parts
that aren't covered by other symbols such as @code{func-decl-cont} and
@code{knr-argdecl}. @ref{Function Symbols}.
+@item constraint-cont
+Continuation line of a topmost C++20 concept or requires clause.
+@ref{Constraint Symbols}.
@item annotation-top-cont
Topmost definition continuation lines where all previous items are
annotations. @ref{Java Symbols}.
@@ -4397,6 +4418,7 @@ Java. @ref{Java Symbols}.
* Multiline Macro Symbols::
* Objective-C Method Symbols::
* Java Symbols::
+* Constraint Symbols::
* Statement Block Symbols::
* K&R Symbols::
@end menu
@@ -4485,6 +4507,13 @@ languages are syntactically equivalent to classes. Note however that
the keyword @code{class} is meaningless in C and Objective-C.}.
Similarly, line 18 is assigned @code{class-close} syntax.
+Note that @code{class-open} and @code{class-close} syntactic elements
+have two anchor points. The first is the position of the beginning of
+the statement, the second is the position of the keyword which defines
+the construct (e.g. @code{class}). These are usually the same
+position, but differ when the statement starts off with
+@code{template} (C++ Mode) or @code{generic} (Java Mode) or similar.
+
@ssindex inher-intro
@ssindex inher-cont
Line 2 introduces the inheritance list for the class so it is assigned
@@ -5071,6 +5100,39 @@ syntax due to it being a continuation of a variable declaration where preceding
the declaration is an annotation.
@comment !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+@node Constraint Symbols
+@subsection C++ Constraint Symbols
+@comment !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+The C++20 standard introduced the notion of @dfn{concepts} and
+@dfn{requirements}, a typical instance of which looks something like
+this:
+
+@example
+ 1: template <typename T>
+ 2: requires
+ 3: requires (T t) @{
+ 4: @{ ++t; @}
+ 5: @}
+ 6: && std::is_integral<T>
+ 7: int foo();
+@end example
+
+@ssindex constraint-cont
+Line 1 is assigned the familiar @code{topmost-intro}. Line 2 gets
+@code{topmost-intro-cont}, being the keyword which introduces a
+@dfn{requires clause}. Lines 3, 6, and 7 are assigned the syntax
+@code{constraint-cont}, being continuations of the requires clause
+started on line 2. Lines 4 and 5 get the syntaxes
+@code{defun-block-intro} and @code{defun-close}, being analyzed as
+though part of a function.
+
+Note that the @code{requires} on Line 3 begins a @dfn{requires
+expression}, not a a requires clause, hence its components are not
+assigned @code{constraint-cont}. See
+@url{https://en.cppreference.com/w/cpp/language/requires}.
+
+@comment !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
@node Statement Block Symbols
@subsection Statement Block Symbols
@comment !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
@@ -6214,6 +6276,16 @@ returned if there's no template argument on the first line.
@comment ------------------------------------------------------------
+@defun c-lineup-template-args-indented-from-margin
+@findex lineup-template-args-indented-from-margin (c-)
+Indent a template argument line `c-basic-offset' from the left-hand
+margin of the line with the containing <.
+
+@workswith @code{template-args-cont}.
+@end defun
+
+@comment ------------------------------------------------------------
+
@defun c-lineup-ObjC-method-call
@findex lineup-ObjC-method-call @r{(c-)}
For Objective-C code, line up selector args as Emacs Lisp mode does
diff --git a/doc/misc/cl.texi b/doc/misc/cl.texi
index 7b07789cf37..65a29d955bc 100644
--- a/doc/misc/cl.texi
+++ b/doc/misc/cl.texi
@@ -55,6 +55,7 @@ modify this GNU manual.''
@menu
* Overview:: Basics, usage, organization, naming conventions.
+* Printing:: Human friendly printing with @code{cl-prin1}.
* Program Structure:: Arglists, @code{cl-eval-when}.
* Predicates:: Type predicates and equality predicates.
* Control Structure:: Assignment, conditionals, blocks, looping.
@@ -258,6 +259,160 @@ and @code{:key} is not used.
@noindent
[3] Only for one sequence argument or two list arguments.
+@node Printing
+@chapter Printing
+
+@noindent
+This chapter describes some enhancements to Emacs Lisp's
+@dfn{printing}, the action of representing Lisp objects in text form.
+The functions documented here are intended to produce output more for
+human readers than the standard printing functions such as
+@code{prin1} and @code{princ} (@pxref{Output Functions,,,elisp,GNU
+Emacs Lisp Reference Manual}).
+
+Several of these functions have a parameter @var{stream}; this
+specifies what to do with the characters printing produces. For
+example, it might be a buffer, a marker, @code{nil} (meaning use
+standard output), or @code{t} (use the echo area). @xref{Output
+Streams,,,elisp,GNU Emacs Lisp Reference Manual}, for a full
+description.
+
+@defvar cl-print-readably
+When this variable is non-@code{nil}, @code{cl-prin1} and other
+functions described here try to produce output which can later be read
+by the Lisp reader (@pxref{Input Functions,,,elisp,GNU Emacs Lisp
+Reference Manual}).
+@end defvar
+
+@defvar cl-print-compiled
+This variable controls how to print byte-compiled functions. Valid
+values are:
+@table @code
+@item nil
+The default: Just an internal hex identifier is printed.
+@item static
+The internal hex identifier together with the function's constant
+vector are printed.
+@item disassemble
+The byte code gets disassembled.
+@item raw
+The raw form of the function is printed by @code{prin1}.
+@end table
+
+Sometimes, a button is set on the output to allow you to disassemble
+the function. See @code{cl-print-compile-button}.
+@end defvar
+
+@defvar cl-print-compile-button
+When this variable is non-@code{nil} and a byte-compiled function has
+been printed to a buffer, you can click with the mouse or type
+@key{RET} on that output to disassemble the code. This doesn't apply
+when @code{cl-print-compiled} is set to @code{disassemble}.
+@end defvar
+
+@defvar cl-print-string-length
+The maximum length of a string to print before abbreviating it. A
+value of @code{nil}, the default, means no limit.
+
+When the CL printing functions abbreviate a string, they print the
+first @code{cl-print-string-length} characters of the string, followed
+by ``@enddots{}''. When the printing is to a buffer, you can click
+with the mouse or type @key{RET} on this ellipsis to expand the
+string.
+
+This variable has effect only in the @code{cl-prin*} functions, not in
+primitives such as @code{prin1}.
+@end defvar
+
+@defun cl-prin1 object &option stream
+@code{cl-print1} prints @var{object} on @var{stream} (see above)
+according to its type and the settings described above. The variables
+@code{print-length} and @code{print-level} and the other standard
+Emacs settings also affect the printing (@pxref{Output
+Variables,,,elisp,GNU Emacs Lisp Reference Manual}).
+@end defun
+
+@defun cl-prin1-to-string object
+This function is like @code{cl-prin1}, except the output characters
+are returned as a string from this function rather than being passed
+to a stream.
+@end defun
+
+@defun cl-print-to-string-with-limit print-function value limit
+This function returns a string containing a printed representation of
+@var{value}. It attempts to get the length of the returned string
+under @var{limit} characters with successively more restrictive
+settings of @code{print-level}, @code{print-length}, and
+@code{cl-print-string-length}. It uses @var{print-function} to print,
+a function which should take the arguments @var{value} and a stream
+(see above), and which should respect @code{print-length},
+@code{print-level}, and @code{cl-print-string-length}. @var{limit}
+may be @code{nil} or zero, in which case @var{print-function} will be
+called with these settings bound to @code{nil}; it can also be
+@code{t}, in which case @var{print-function} will be called with their
+current values.
+
+Use this function with @code{cl-prin1} to print an object, possibly
+abbreviating it with one or more ellipses to fit within the size
+limit.
+@end defun
+
+@defun cl-print-object object stream
+This function prints @var{object} on @var{stream} (see above). It is
+actually a @code{cl-defgeneric} (@pxref{Generic Functions,,,elisp,GNU
+Emacs Lisp Reference Manual}), which is defined for several types of
+@var{object}. Normally, you just call @code{cl-prin1} to print an
+@var{object} rather than calling this function directly.
+
+You can write @code{cl-print-object} @code{cl-defmethod}s for other
+types of @var{object}, thus extending @code{cl-prin1}. If such a
+method uses ellipses, you should also write a
+@code{cl-print-object-contents} method for the same type. For
+examples of these methods, see @file{emacs-lisp/cl-print.el} in the
+Emacs source directory.
+@end defun
+
+@defun cl-print-object-contents object start stream
+This function replaces an ellipsis in @var{stream} beginning at
+@var{start} with the text from the partially printed @var{object} it
+represents. It is also a @code{cl-defgeneric} defined for several
+types of @var{object}. @var{stream} is a buffer containing the text
+with the ellipsis. @var{start} specifies the starting position of the
+ellipsis in a manner dependent on the type; it will have been obtained
+from a text property on the ellipsis, having been put there by
+@code{cl-print-insert-ellipsis}.
+@end defun
+
+@defun cl-print-insert-ellipsis object start stream
+This function prints an ellipsis (``@dots{}'') to @var{stream} (see
+above). When @var{stream} is a buffer, the ellipsis will be given the
+@code{cl-print-ellipsis} text property. The value of the text
+property will contain state (including @var{start}) in order to print
+the elided part of @var{object} later. @var{start} should be nil if
+the whole @var{object} is being elided, otherwise it should be an
+index or other pointer into the internals of @var{object} which can be
+passed to `cl-print-object-contents' at a later time.
+@end defun
+
+@defvar cl-print-expand-ellipsis-function
+This variable holds a function which expands an ellipsis in the
+current buffer. The function takes four arguments: @var{begin} and
+@var{end}, which are the bounds of the ellipsis; @var{value}, which is
+the value of the @code{cl-print-ellipsis} text property on the
+ellipsis (typically set earlier by @code{cl-prin1}); and
+@var{line-length}, the desired maximum length of the output. Its
+return value is the buffer position after the expanded text.
+@end defvar
+
+@deffn Command cl-print-expand-ellipsis &optional button
+This command expands the ellipsis at point. Non-interactively, if
+@var{button} is non-@code{nil}, it should be either a buffer position
+or a button made by @code{cl-print-insert-ellipsis}
+(@pxref{Buttons,,,elisp,GNU Emacs Lisp Reference Manual}), which
+indicates the position of the ellipsis. The return value is the
+buffer position after the expanded text.
+@end deffn
+
@node Program Structure
@chapter Program Structure
diff --git a/doc/misc/dired-x.texi b/doc/misc/dired-x.texi
index 4cad016a0f6..e23ce3792e0 100644
--- a/doc/misc/dired-x.texi
+++ b/doc/misc/dired-x.texi
@@ -346,6 +346,16 @@ only match against the non-directory part of the file name. Set it to
match the file name relative to the buffer's top-level directory.
@end defvar
+@defvar dired-omit-size-limit
+If non-@code{nil}, @code{dired-omit-mode} will be effectively disabled
+in directories whose listing has size (in bytes) larger than the value
+of this option. Since omitting can be slow for very large directories,
+this avoids having to wait before seeing the directory. This variable
+is ignored when @code{dired-omit-mode} is called interactively, such as
+by @kbd{C-x M-o}, so you can still enable omitting in the directory
+after the initial display.
+@end defvar
+
@cindex omitting additional files
@defvar dired-omit-marker-char
Temporary marker used by Dired to implement omitting. Should never be used
diff --git a/doc/misc/efaq.texi b/doc/misc/efaq.texi
index c687f723e09..5b722f9fd77 100644
--- a/doc/misc/efaq.texi
+++ b/doc/misc/efaq.texi
@@ -1121,8 +1121,8 @@ feature, when you need to insert a single special character.
allows selection of one of the previous kills.
@item
-New minor mode @code{repeat-mode} allows to repeat commands with fewer
-keystrokes.
+New minor mode @code{repeat-mode} enables repeating commands with
+fewer keystrokes.
@item
Among the many internal changes in this release, we would like to
@@ -1721,7 +1721,7 @@ is better to write ``Emacs and XEmacs.''
* Editing MS-DOS files::
* Filling paragraphs with a single space::
* Escape sequences in shell output::
-* Fullscreen mode on MS-Windows::
+* Start Emacs maximized::
* Emacs in a Linux console::
@end menu
@@ -3113,45 +3113,24 @@ prints using ANSI color escape sequences. Emacs includes the
@code{ansi-color} package, which lets Shell mode recognize these
escape sequences. It is enabled by default.
-@node Fullscreen mode on MS-Windows
-@section How can I start Emacs in fullscreen mode on MS-Windows?
+@node Start Emacs maximized
+@section How can I start Emacs in full screen?
@cindex Maximize frame
@cindex Fullscreen mode
-Beginning with Emacs 24.4 either run Emacs with the @samp{--maximized}
-command-line option or put the following form in your init file
-(@pxref{Setting up a customization file}):
-
-@lisp
-(add-hook 'emacs-startup-hook 'toggle-frame-maximized)
-@end lisp
-
-With older versions use the function @code{w32-send-sys-command}. For
-example, you can put the following in your init file:
-
-@lisp
-(add-hook 'emacs-startup-hook
- (lambda () (w32-send-sys-command ?\xF030)))
-@end lisp
-
-To avoid the slightly distracting visual effect of Emacs starting with
-its default frame size and then growing to fullscreen, you can add an
-@samp{Emacs.Geometry} entry to the Windows Registry settings. @xref{X
-Resources,,, emacs, The GNU Emacs Manual}. To compute the correct
-values for width and height you use in the Registry settings, first
-maximize the Emacs frame and then evaluate @code{(frame-height)} and
-@code{(frame-width)} with @kbd{M-:}.
-
-Alternatively, you can avoid the visual effect of Emacs changing its
-frame size entirely in your init file (i.e., without using the
-Registry), like this:
+Run Emacs with the @samp{--maximized} command-line option or put the
+following form at the top of your early init file (@pxref{Early Init
+File,,, emacs, The GNU Emacs Manual}).
@lisp
-(setq frame-resize-pixelwise t)
-(set-frame-position nil 0 0)
-(set-frame-size nil (display-pixel-width) (display-pixel-height) t)
+(push '(fullscreen . maximized) default-frame-alist)
@end lisp
+Note that while some customizations of @code{default-frame-alist}
+could have undesirable effects when modified in the early init file,
+it is okay to do it in this particular case. Adding it to the top of
+your normal init file will also work, but leads to a visible resizing
+of the window that some find distracting.
@node Emacs in a Linux console
@section How can I alleviate the limitations of the Linux console?
@@ -3159,9 +3138,9 @@ Registry), like this:
If possible, we recommend running Emacs inside @command{fbterm}, when
in a Linux console. This brings the Linux console on par with most
-terminal emulators under X. To do this, install @command{fbterm}, for
-example with the package manager of your GNU/Linux distribution, and
-execute the command
+terminal emulators under X@. To do this, install @command{fbterm},
+for example with the package manager of your GNU/Linux distribution,
+and execute the command
@example
$ fbterm
@@ -3304,12 +3283,12 @@ Emacs has an inherent fixed limitation on the size of buffers. This
limit is stricter than the maximum size of objects supported by other
programs on the same architecture.
-The maximum buffer size on 32-bit machines is 512 MBytes. If Emacs
-was built using the @code{--with-wide-int} flag, the maximum buffer
-size on 32-bit machines is 2 GB.
+The maximum buffer size on 64-bit machines is 2.3 exabytes
+(@code{most-positive-fixnum}).
-Emacs compiled on a 64-bit machine can handle much larger buffers; up
-to @code{most-positive-fixnum} (2.3 exabytes).
+Emacs compiled on a 32-bit machine can handle buffers up to 512
+MBytes. If Emacs was built using the @code{--with-wide-int} flag, the
+maximum buffer size on 32-bit machines is 2 GB.
Due to things like decoding of multibyte characters, you can only
visit files with a size that is roughly half the buffer size limit.
diff --git a/doc/misc/eglot.texi b/doc/misc/eglot.texi
index 94cb00064bb..85fef6be553 100644
--- a/doc/misc/eglot.texi
+++ b/doc/misc/eglot.texi
@@ -99,6 +99,7 @@ This manual documents how to configure, use, and customize Eglot.
* Using Eglot:: Important Eglot commands and variables.
* Customizing Eglot:: Eglot customization and advanced features.
* Advanced server configuration:: Fine-tune a specific language server
+* Extending Eglot:: Writing Eglot extensions in Elisp
* Troubleshooting Eglot:: Troubleshooting and reporting bugs.
* GNU Free Documentation License:: The license for this manual.
* Index::
@@ -137,17 +138,19 @@ Turn on Eglot for your project.
To start using Eglot for a project, type @kbd{M-x eglot @key{RET}} in
a buffer visiting any file that belongs to the project. This starts
the language server configured for the programming language of that
-buffer, and causes Eglot to start managing all the files of the
-project which use the same programming language. The notion of a
-``project'' used by Eglot is the same Emacs uses (@pxref{Projects,,,
-emacs, GNU Emacs Manual}): in the simplest case, the ``project'' is
-the single file you are editing, but it can also be all the files in a
-single directory or a directory tree under some version control
-system, such as Git.
-
-Alternatively, you can start Eglot automatically from the major-mode
-hook of the mode used for the programming language; see @ref{Starting
-Eglot}.
+buffer, and causes Eglot to start @dfn{managing} file-visiting buffers
+related to that programming language. This includes files that are
+already visited at the time the @code{eglot} command is invoked, as
+well as any files visited after this invocation.
+
+The notion of a ``project'' used by Eglot is the same Emacs uses
+(@pxref{Projects,,, emacs, GNU Emacs Manual}): in the simplest case,
+the ``project'' is the single file you are editing, but it can also be
+all the files in a single directory or a directory tree under some
+version control system, such as Git.
+
+There are alternate ways of starting Eglot; see @ref{Starting Eglot}
+for details.
@item
Use Eglot.
@@ -343,6 +346,12 @@ starting an Eglot session is non-interactive, so it should be used
only when you are confident that Eglot can be started reliably for any
file which may be visited with the major-mode in question.
+Note that it's often difficult to establish this confidence fully, so
+it may be wise to use the interactive command @code{eglot} instead.
+You only need to invoke it once per project, as all other files
+visited within the same project will automatically be managed with no
+further user intervention needed.
+
When Eglot connects to a language server for the first time in an
Emacs session, it runs the hook @code{eglot-connect-hook}
(@pxref{Eglot Variables}).
@@ -395,11 +404,13 @@ commands and variables.
@section Eglot Features
@cindex features in buffers supported by Eglot
-Once Eglot is enabled in a buffer, it uses LSP and the language-server
-capabilities to activate, enable, and enhance modern IDE features in
-Emacs. The features themselves are usually provided via other Emacs
-packages. Here's the list of the main features that Eglot enables and
-provides:
+While Eglot is enabled in a buffer, it is said to be @dfn{managing}
+it, using LSP and the specific capabilities of the language server to
+activate and enhance modern IDE features in Emacs. Some of these
+features are provided via other Emacs packages, and some via Eglot
+directly (@pxref{Eglot Commands}).
+
+Here's an overview of the main features that Eglot provides:
@itemize @bullet
@item
@@ -412,10 +423,11 @@ allows major modes to provide extensive help and documentation about
the program identifiers.
@item
-On-the-fly diagnostic annotations with server-suggested fixes, via the
-Flymake package (@pxref{Top,,, flymake, GNU Flymake manual}). This
-improves and enhances the Flymake diagnostics, replacing the other
-Flymake backends.
+On-the-fly diagnostic annotations, via the Flymake package
+(@pxref{Top,,, flymake, GNU Flymake manual}). Eglot's Flymake backend
+replaces other Flymake backends while it is managing a buffer, and
+enhances diagnostics with interactive server-suggested fixes
+(so-called @dfn{code actions}, @pxref{Eglot Commands})
@item
Finding definitions and uses of identifiers, via Xref (@pxref{Xref,,,
@@ -474,9 +486,17 @@ with @kbd{eglot-code-actions}. @xref{Eglot Commands}.
Not all servers support the full set of LSP capabilities, but most of
them support enough to enable the basic set of features mentioned
-above. Conversely, some servers offer capabilities for which no
-equivalent Emacs package exists yet, and so Eglot cannot (yet) expose
-these capabilities to Emacs users.
+above.
+
+Conversely, some servers offer capabilities for which no equivalent
+Emacs package exists yet, and so Eglot cannot (yet) expose these
+capabilities to Emacs users. However, @xref{Extending Eglot}.
+
+Finally, it's worth noting that, by default, Eglot generally turns on
+all features that it @emph{can} turn on. It's possible to opt out of
+some features via user options (@pxref{Customizing Eglot}) and a hook
+that runs after Eglot starts managing a buffer (@pxref{Eglot and
+Buffers}).
@node Eglot and Buffers
@section Buffers, Projects, and Eglot
@@ -684,7 +704,7 @@ requests for the language server to provide editing commands for
correcting, refactoring or beautifying your code. These commands may
affect more than one visited file belonging to the project.
-The command @code{eglot-code-actions} asks the server if there any
+The command @code{eglot-code-actions} asks the server if there are any
code actions for any point in the buffer or contained in the active
region. If there are, you have the choice to execute one of them via
the minibuffer.
@@ -816,13 +836,13 @@ in the background. The value of @code{t} means block during the whole
waiting period. The value of @code{nil} or @code{0} means don't block at
all during the waiting period.
-@item eglot-events-buffer-size
-This determines the size of the Eglot events buffer. @xref{Eglot
-Commands, eglot-events-buffer}, for how to display that buffer. If
-the value is changed, for it to take effect the connection should be
-restarted using @kbd{M-x eglot-reconnect}.
+@item eglot-events-buffer-config
+This configures the size and format of the Eglot events buffer.
+@xref{Eglot Commands, eglot-events-buffer}, for how to access that
+buffer. If the value is changed, the connection should be restarted
+using @kbd{M-x eglot-reconnect} for the new value to take effect.
@c FIXME: Shouldn't the defcustom do this by itself using the :set
-@c attribute?
+@c attribute? Maybe not because reconnecting is a complex task.
@xref{Troubleshooting Eglot}, for when this could be useful.
@item eglot-autoshutdown
@@ -831,12 +851,14 @@ last buffer managed by it is killed. @xref{Shutting Down LSP Servers}.
The default is @code{nil}; if you want to shut down a server, use
@kbd{M-x eglot-shutdown} (@pxref{Eglot Commands}).
-@item eglot-confirm-server-initiated-edits
+@item eglot-confirm-server-edits
Various Eglot commands and code actions result in the language server
sending editing commands to Emacs. If this option's value is
-non-@code{nil} (the default), Eglot will ask for confirmation before
-performing edits initiated by the server or edits whose scope affects
-buffers other than the one where the user initiated the request.
+non-@code{nil}, Eglot will ask for confirmation before performing
+edits proposed by the language server. This option's value can be
+crafted to require this confirmation for specific commands or only
+when the edit affects files not yet visited by the user. Consult this
+option's docstring for more information.
@item eglot-ignored-server-capabilities
This variable's value is a list of language server capabilities that
@@ -1262,6 +1284,152 @@ is serialized by Eglot to the following JSON text:
@}
@end example
+@node Extending Eglot
+@chapter Extending Eglot
+
+Sometimes it may be useful to extend existing Eglot functionality
+using Elisp its public methods. A good example of when this need may
+arise is adding support for a custom LSP protocol extension only
+implemented by a specific server.
+
+The best source of documentation for this is probably Eglot source
+code itself, particularly the section marked ``API''.
+
+Most of the functionality is implemented with Common-Lisp style
+generic functions (@pxref{Generics,,,eieio,EIEIO}) that can be easily
+extended or overridden. The Eglot code itself is an example on how to
+do this.
+
+The following is a relatively simple example that adds support for the
+@code{inactiveRegions} experimental feature introduced in version 17
+of the @command{clangd} C/C++ language server++.
+
+Summarily, the feature works by first having the server detect the
+Eglot's advertisement of the @code{inactiveRegions} client capability
+during startup, whereupon the language server will report a list of
+regions of inactive code for each buffer. This is usually code
+surrounded by C/C++ @code{#ifdef} macros that the preprocessor removes
+based on compile-time information.
+
+The language server reports the regions by periodically sending a
+@code{textDocument/inactiveRegions} notification for each managed
+buffer (@pxref{Eglot and Buffers}). Normally, unknown server
+notifications are ignored by Eglot, but we're going change that.
+
+Both the announcement of the client capability and the handling of the
+new notification is done by adding methods to generic functions.
+
+@itemize @bullet
+@item
+The first method extends @code{eglot-client-capabilities} using a
+simple heuristic to detect if current server is @command{clangd} and
+enables the @code{inactiveRegion} capability.
+
+@lisp
+(cl-defmethod eglot-client-capabilities :around (server)
+ (let ((base (cl-call-next-method)))
+ (when (cl-find "clangd" (process-command
+ (jsonrpc--process server))
+ :test #'string-match)
+ (setf (cl-getf (cl-getf base :textDocument)
+ :inactiveRegionsCapabilities)
+ '(:inactiveRegions t)))
+ base))
+@end lisp
+
+Notice we use an internal function of the @code{jsonrpc.el} library,
+and a regexp search to detect @command{clangd}. An alternative would
+be to define a new EIEIO subclass of @code{eglot-lsp-server}, maybe
+called @code{eglot-clangd}, so that the method would be simplified:
+
+@lisp
+(cl-defmethod eglot-client-capabilities :around ((_s eglot-clangd))
+ (let ((base (cl-call-next-method)))
+ (setf (cl-getf (cl-getf base :textDocument)
+ :inactiveRegionsCapabilities)
+ '(:inactiveRegions t))))
+@end lisp
+
+However, this would require that users tweak
+@code{eglot-server-program} to tell Eglot instantiate such sub-classes
+instead of the generic @code{eglot-lsp-server} (@pxref{Setting Up LSP
+Servers}). For the purposes of this particular demonstration, we're
+going to use the more hacky regexp route which doesn't require that.
+
+Note, however, that detecting server versions before announcing new
+capabilities is generally not needed, as both server and client are
+required by LSP to ignore unknown capabilities advertised by their
+counterparts.
+
+@item
+The second method implements @code{eglot-handle-notification} to
+process the server notification for the LSP method
+@code{textDocument/inactiveRegions}. For each region received it
+creates an overlay applying the @code{shadow} face to the region.
+Overlays are recreated every time a new notification of this kind is
+received.
+
+To learn about how @command{clangd}'s special JSONRPC notification
+message is structured in detail you could consult that server's
+documentation. Another possibility is to evaluate the first
+capability-announcing method, reconnect to the server and peek in the
+events buffer (@pxref{Eglot Commands, eglot-events-buffer}). You
+could find something like:
+
+@lisp
+[server-notification] Mon Sep 4 01:10:04 2023:
+(:jsonrpc "2.0" :method "textDocument/inactiveRegions" :params
+ (:textDocument
+ (:uri "file:///path/to/file.cpp")
+ :regions
+ [(:start (:character 0 :line 18)
+ :end (:character 58 :line 19))
+ (:start (:character 0 :line 36)
+ :end (:character 1 :line 38))]))
+@end lisp
+
+This reveals that the @code{textDocument/inactiveRegions} notification
+contains a @code{:textDocument} property to designate the managed
+buffer and an array of LSP regions under the @code{:regions} property.
+Notice how the message (originally in JSON format), is represented as
+Elisp plists (@pxref{JSONRPC objects in Elisp}).
+
+The Eglot generic function machinery will automatically destructure
+the incoming message, so these two properties can simply be added to
+the new method's lambda list as @code{&key} arguments. Also, the
+@code{eglot-uri-to-path} and @code{eglot-range-region} may be used to
+easily parse the LSP @code{:uri} and @code{:start ... :end ...}
+objects to obtain Emacs objects for file names and positions.
+
+The remainder of the implementation consists of standard Elisp
+techniques to loop over arrays, manage buffers and overlays.
+
+@lisp
+(cl-defmethod eglot-handle-notification
+ (_server (_method (eql textDocument/inactiveRegions))
+ &key regions textDocument &allow-other-keys)
+ (if-let* ((path (expand-file-name (eglot-uri-to-path
+ (cl-getf textDocument :uri))))
+ (buffer (find-buffer-visiting path)))
+ (with-current-buffer buffer
+ (remove-overlays nil nil 'inactive-code t)
+ (cl-loop
+ for r across regions
+ for (beg . end) = (eglot-range-region r)
+ for ov = (make-overlay beg end)
+ do
+ (overlay-put ov 'face 'shadow)
+ (overlay-put ov 'inactive-code t)))))
+@end lisp
+
+@end itemize
+
+After evaluating these two additions and reconnecting to the
+@command{clangd} language server (version 17), the result will be that
+all the inactive code in the buffer will be nicely grayed out using
+the LSP server knowledge about current compile time preprocessor
+defines.
+
@node Troubleshooting Eglot
@chapter Troubleshooting Eglot
@cindex troubleshooting Eglot
@@ -1285,12 +1453,14 @@ indicate the problems or at least provide a hint.
@node Performance
@section Performance
@cindex performance problems, with Eglot
-A common and easy-to-fix cause of performance problems is the length
-of the Eglot events buffer because it represent additional work that
-Eglot must do. After verifying Eglot is operating correctly but
-slowly, try to customize the variable @code{eglot-events-buffer-size}
-(@pxref{Eglot Variables}) to 0. This will disable any debug logging
-and may speed things up.
+A common and easy-to-fix cause of performance problems in Eglot
+(especially in older versions) is its events buffer, since it
+represents additional work that Eglot must do (@pxref{Eglot Commands,
+eglot-events-buffer}). If you find Eglot is operating correctly but
+slowly, try to customize the variable
+@code{eglot-events-buffer-config} (@pxref{Eglot Variables}) and set
+its @code{:size} property to 0. This will disable recording any
+events and may speed things up.
In other situations, the cause of poor performance lies in the
language server itself. Servers use aggressive caching and other
diff --git a/doc/misc/epa.texi b/doc/misc/epa.texi
index 78a13ef76f5..f450b9cbdd9 100644
--- a/doc/misc/epa.texi
+++ b/doc/misc/epa.texi
@@ -289,6 +289,15 @@ also ask you whether or not to sign the text before encryption and if
you answered yes, it will let you select the signing keys.
@end deffn
+@defvar epa-keys-select-method
+This variable controls the method used for key selection in
+@code{epa-select-keys}. The default value @code{buffer} pops up a
+special buffer where you can select the keys. If the value is
+@code{minibuffer}, @code{epa-select-keys} will instead prompt for the
+keys in the minibuffer, where you should type the keys separated by
+commas.
+@end defvar
+
@node Cryptographic operations on files
@section Cryptographic Operations on Files
@cindex cryptographic operations on files
@@ -640,6 +649,9 @@ Customize variable @code{epg-pinentry-mode} to @code{loopback} in
Emacs.
@end enumerate
+Note that loopback Pinentry does not work with @command{gpgsm},
+therefore EasyPG will ignore this setting for it.
+
There are other options available to use Emacs as Pinentry, you might
come across a Pinentry called @command{pinentry-emacs} or
@command{gpg-agent} option @code{allow-emacs-pinentry}. However,
diff --git a/doc/misc/erc.texi b/doc/misc/erc.texi
index 653e589c8fe..c7ab7e7bf21 100644
--- a/doc/misc/erc.texi
+++ b/doc/misc/erc.texi
@@ -2,7 +2,7 @@
@c %**start of header
@setfilename ../../info/erc.info
@settitle ERC Manual
-@set ERCVER 5.5.0.29.1
+@set ERCVER 5.6
@set ERCDIST as distributed with Emacs @value{EMACSVER}
@include docstyle.texi
@syncodeindex fn cp
@@ -144,11 +144,11 @@ the @samp{#emacs} channels where you can chat with other Emacs users,
and if you're having trouble with ERC, you can join the @samp{#erc}
channel and ask for help there.
-If you want to place ERC settings in their own file, you can place them
-in @file{~/.emacs.d/.ercrc.el}, creating it if necessary.
-
-If you would rather use the Customize interface to change how ERC
-works, do @kbd{M-x customize-group @key{RET} erc @key{RET}}. In
+At some point in your ERC journey, you'll inevitably want to change
+how the client looks and behaves. As with other Emacs applications,
+the typical place to store your settings is your @file{init.el}. If
+you would rather use the Customize interface, a good place to start is
+by running @kbd{M-x customize-group @key{RET} erc @key{RET}}. In
particular, ERC comes with lots of modules that may be enabled or
disabled; to select which ones you want, do @kbd{M-x
customize-variable @key{RET} erc-modules @key{RET}}.
@@ -161,69 +161,90 @@ customize-variable @key{RET} erc-modules @key{RET}}.
@node Sample Session
@section Sample Session
-This is an example ERC session which shows how to connect to the
-@samp{#emacs} channel on Libera.Chat. Another IRC channel on
-Libera.Chat that may be of interest is @samp{#erc}, which is a channel
-where ERC users and developers hang out. These channels used to live
-on the Freenode IRC network until June 2021, when they---along with
-the official IRC channels of the GNU Project, the Free Software
-Foundation, and many other free software communities---relocated to
-the Libera.Chat network in the aftermath of changes in governance and
-policies of Freenode in May and June 2021. GNU and FSF's
-announcements about this are at
-@uref{https://lists.gnu.org/archive/html/info-gnu/2021-06/msg00005.html},
-@uref{https://lists.gnu.org/archive/html/info-gnu/2021-06/msg00007.html},
-and
-@uref{https://lists.gnu.org/archive/html/info-gnu-emacs/2021-06/msg00000.html}.
+This example ERC session describes how to connect to the @samp{#emacs}
+channel on Libera.Chat. Also worth checking out is Libera's own
+introductory guide to IRC, @uref{https://libera.chat/guides/basics},
+which presents a more comprehensive overview without instructions
+specific to ERC.
@itemize @bullet
@item Connect to Libera.Chat
-Run @kbd{M-x erc}. Use ``irc.libera.chat'' as the IRC server, ``6667''
-as the port, and choose a nickname.
+Run @kbd{M-x erc @key{RET}}. Use @samp{irc.libera.chat} for the
+server and @samp{6667} for the port. Choose a nickname, and hit
+@key{y} when asked if you'd prefer to connect over @acronym{TLS}.
@item Get used to the interface
-Switch to the ``irc.libera.chat:6667'' buffer, if you're not already
-there. You will see first some messages about checking for ident, and
-then a bunch of other messages that describe the current IRC server.
+Switch to the @file{Libera.Chat} buffer if you're not already there.
+ERC calls this a @dfn{server buffer}, and it must exist for the
+duration of the session. You will likely see some messages about
+``ident'', authentication, and the like, followed by information
+describing the current server and the network.
@item Join the #emacs channel
-In that buffer, type ``/join @key{SPC} #emacs'' and hit @kbd{RET}. Depending
-on how you've set up ERC, either a new buffer for ``#emacs'' will be
-displayed, or a new buffer called ``#emacs'' will be created in the
-background. If the latter, switch to the ``#emacs'' buffer. You will
-see the channel topic and a list of the people who are currently on the
-channel.
+In the server buffer, type @kbd{/join #emacs @key{RET}} at the prompt.
+ERC will create a new buffer called @file{#emacs}. If you've already
+configured ERC, you may need to switch to it manually. Once there,
+you will see the channel's ``topic'' in the buffer's header line
+(@pxref{Header Lines,,,elisp,}) and a list of people currently in the
+channel. If you can't see the full topic, mouse over it or type
+@kbd{/topic @key{RET}} at the prompt.
@item Register your nickname with Libera.Chat
-If you would like to be able to talk with people privately on the
-Libera.Chat network, you will have to ``register'' your nickname.
-To do so, switch to the ``irc.libera.chat:6667'' buffer and type
-``/msg NickServ register <password>'', replacing ``<password>'' with
-your desired password. It should tell you that the operation was
-successful.
+In order to access essential network features, like speaking in
+certain channels and participating in private conversations, you'll
+likely have to ``register'' your nickname. To do so, switch to the
+@file{Libera.Chat} buffer and type @kbd{/msg NickServ register
+@samp{<password>} @samp{<email>} @key{RET}}, replacing
+@samp{<password>} and @samp{<email>} with your desired account
+password and contact email (both sans quotes). The server should tell
+you that the operation was successful. See the official Libera.Chat
+docs if you encounter problems.
+
+In addition to creating an account, this process also
+``authenticates'' you to the network's ``account services'' system for
+the duration of the session. In other words, you're now logged in.
+However, when you connect in the future, you'll need to authenticate
+again by providing the same credentials somehow. When you're finished
+with this walk through, see ``Next Steps'', below, to learn some ways
+to do that.
@item Talk to people in the channel
-If you switch back to the ``#emacs'' buffer, you can type a message, and
-everyone on the channel will see it.
+Switch back to the @file{#emacs} buffer and type a message at the
+prompt, hitting @kbd{RET} once satisfied. Everyone in the channel
+will now see your message.
@item Open a query buffer to talk to someone
-If you want to talk with someone in private (this should usually not be
-done for technical help, only for personal questions), type ``/query
-<nick>'', replacing ``<nick>'' with the nickname of the person you would
-like to talk to. Depending on how ERC is set up, you will either see a
-new buffer with the name of the person, or such a buffer will be created
-in the background and you will have to switch to it. Begin typing
-messages, and you will be able to have a conversation.
-
-Note that if the other person is not registered, you will not be able to
-talk with them.
+If you want to talk with someone in private, type @kbd{/query
+@samp{<nick>} @key{RET}}, replacing @samp{<nick>} with the their
+nickname. As before, with the server buffer, if this new @dfn{query
+buffer} doesn't appear in the current window, you may have to switch
+to it. Regardless, its name should match @samp{<nick>}. Once there,
+type something at the prompt and hit @kbd{RET}, and the other party
+will see it.
+
+Keep in mind that if either party isn't authenticated, you may not be
+able to converse at all. Also, depending on the network, certain
+social conventions may apply to the practice of direct messaging. As
+a general rule, queries should usually be reserved for personal
+matters rather than technical help, which can often benefit (and
+benefit @emph{from}) a larger audience.
+
+@item Next steps
+
+Try joining another channel, such as @samp{#erc}, where ERC users and
+developers hang out (@pxref{Official IRC channels} for more on the
+history of @samp{#emacs}). For ideas on various options to customize,
+@pxref{Sample Configuration}. To learn how ERC can authenticate you
+to the network automatically whenever you connect, @pxref{SASL}. As
+always, if you encounter problems, @pxref{Getting Help and Reporting
+Bugs}.
@end itemize
@@ -391,16 +412,18 @@ One way to add functionality to ERC is to customize which of its many
modules are loaded.
There is a spiffy customize interface, which may be reached by typing
-@kbd{M-x customize-option @key{RET} erc-modules @key{RET}}.
-When removing a module outside of the Custom ecosystem, you may wish
-to ensure it's disabled by invoking its associated minor-mode toggle
-with a nonpositive prefix argument, for example, @kbd{C-u - M-x
+@kbd{M-x customize-option @key{RET} erc-modules @key{RET}}. When
+removing a module outside of Customize, you may wish to ensure it's
+disabled by invoking its associated minor-mode toggle with a
+nonpositive prefix argument, for example, @kbd{C-u - M-x
erc-spelling-mode @key{RET}}. Additionally, if you plan on loading
third-party modules that perform atypical setup on activation, you may
need to arrange for calling @code{erc-update-modules} in your init
file. Examples of such setup might include registering an
@code{erc-before-connect} hook, advising @code{erc-open}, and
-modifying @code{erc-modules} itself.
+modifying @code{erc-modules} itself. On Emacs 29 and greater, you can
+also run @code{erc-update-modules} indirectly, via @code{(setopt
+erc-modules erc-modules)}.
The following is a list of available modules.
@@ -414,9 +437,10 @@ Set away status automatically
@item autojoin
Join channels automatically
-@cindex modules, bbdb
-@item bbdb
-Integrate with the Big Brother Database
+@cindex modules, bufbar
+@item bufbar
+List buffers belonging to a connection in a side window; part of
+Custom group @code{erc-status-sidebar}
@cindex modules, button
@item button
@@ -426,6 +450,11 @@ Buttonize URLs, nicknames, and other text
@item capab-identify
Mark unidentified users on freenode and other servers supporting CAPAB.
+@cindex modules, command-indicator
+@item command-indicator
+Echo command lines for ``slash commands'', like @kbd{/JOIN #erc} and
+@kbd{/HELP join}
+
@cindex modules, completion
@cindex modules, pcomplete
@item completion (aka pcomplete)
@@ -443,6 +472,10 @@ Launch an identd server on port 8113
@item irccontrols
Highlight or remove IRC control characters
+@cindex modules, keep-place
+@item keep-place
+Remember your position in buffers
+
@cindex modules, log
@item log
Save buffers in logs
@@ -459,6 +492,15 @@ Display a menu in ERC buffers
@item netsplit
Detect netsplits
+@cindex modules, nicks
+@item nicks
+Automatically colorize nicks
+
+@cindex modules, nickbar
+@item nickbar
+List participating nicks for the current target buffer in a side
+window; part of Custom group @code{erc-speedbar}
+
@cindex modules, noncommands
@item noncommands
Don't display non-IRC commands after evaluation
@@ -530,6 +572,33 @@ Translate morse code in messages
@end table
+@anchor{Auxiliary Modules}
+@subheading Auxiliary Modules
+@cindex auxiliary modules
+
+For various reasons, the following modules aren't currently listed in
+the Custom interface for @code{erc-modules}, but feel free to add them
+explicitly. They may be managed by another module or considered more
+useful when toggled interactively or just deemed experimental.
+
+@table @code
+
+@cindex modules, fill-wrap
+@item fill-wrap
+Wrap long lines using @code{visual-line-mode}
+
+@cindex modules, keep-place-indicator
+@item keep-place-indicator
+Remember your place in buffers with a visible reminder; activated
+interactively or via something like @code{erc-join-hook}
+
+@cindex modules, services-regain
+@item services-regain
+Automatically ask NickServ to reclaim your nick when reconnecting;
+experimental as of ERC 5.6
+
+@end table
+
@anchor{Required Modules}
@subheading Required Modules
@cindex required modules
@@ -590,6 +659,62 @@ buffers belonging to their connection (when called interactively).
And unlike global toggles, none of these ever mutates
@code{erc-modules}.
+@c FIXME add section to Advanced chapter for creating modules, and
+@c move this there.
+@anchor{Module Loading}
+@subheading Loading
+@cindex module loading
+
+ERC loads internal modules in alphabetical order and third-party
+modules as they appear in @code{erc-modules}. When defining your own
+module, take care to ensure ERC can find it. An easy way to do that
+is by mimicking the example in the doc string for
+@code{define-erc-module} (also shown below). For historical reasons,
+ERC falls back to @code{require}ing features. For example, if some
+module @code{my-module} in @code{erc-modules} lacks a corresponding
+@code{erc-my-module-mode} command, ERC will attempt to load the
+library @code{erc-my-module} prior to connecting. If this fails, ERC
+signals an error. Users defining personal modules in an init file
+should @code{(provide 'erc-my-module)} somewhere to placate ERC.
+Dynamically generating modules on the fly is not supported.
+
+Some older built-in modules have a second name along with a second
+minor-mode toggle, which is just a function alias for its primary
+counterpart. For practical reasons, ERC does not define a
+corresponding variable alias because contending with indirect
+variables complicates bookkeeping tasks, such as persisting module
+state across IRC sessions. New modules should definitely avoid
+defining aliases without a good reason.
+
+Some packages have been known to autoload a module's definition
+instead of its minor-mode command, which severs the link between the
+library and the module. This means that enabling the mode by invoking
+its command toggle isn't enough to load its defining library. As
+such, packages should only supply module-related autoload cookies with
+an actual @code{autoload} form for their module's minor-mode command,
+like so:
+
+@lisp
+;;;###autoload(autoload 'erc-my-module-mode "erc-my-module" nil t)
+(define-erc-module my-module nil
+ "My doc string."
+ ((add-hook 'erc-insert-post-hook #'erc-my-module-on-insert-post))
+ ((remove-hook 'erc-insert-post-hook #'erc-my-module-on-insert-post)))
+@end lisp
+
+@noindent
+As implied earlier, packages can usually omit such cookies entirely so
+long as their module's prefixed name matches that of its defining
+library and the library's provided feature.
+
+Finally, packages have also been observed to run
+@code{erc-update-modules} in top-level forms, forcing ERC to take
+special precautions to avoid recursive invocations. Another
+unfortunate practice is mutating @code{erc-modules} itself upon
+loading @code{erc}, possibly by way of an autoload. Doing this tricks
+Customize into displaying the widget for @code{erc-modules}
+incorrectly, with built-in modules moved from the predefined checklist
+to the user-provided free-form area.
@c PRE5_4: Document every option of every module in its own subnode
@@ -611,7 +736,9 @@ And unlike global toggles, none of these ever mutates
Integrations
* URL:: Opening IRC URLs in ERC.
+* SOCKS:: Connecting to IRC with a SOCKS proxy.
* auth-source:: Retrieving auth-source entries with ERC.
+* display-buffer:: Controlling how ERC displays buffers.
@end detailmenu
@end menu
@@ -799,16 +926,11 @@ In the latter case, if the first nick in the list is already in use,
other nicks are tried in the list order.
@end defopt
-@defopt erc-format-nick-function
-A function to format a nickname for message display
-
-You can set this to @code{erc-format-@@nick} to display user mode prefix
+@defopt erc-show-speaker-membership-status
+A boolean for including a channel member's @dfn{status prefix} in
+their display name when they speak.
@end defopt
-@example
-(setq erc-format-nick-function 'erc-format-@@nick)
-@end example
-
@defopt erc-nick-uniquifier
The string to append to the nick if it is already in use.
@end defopt
@@ -934,27 +1056,33 @@ acceptable.
@section Authenticating via SASL
@cindex SASL
-Regardless of the mechanism or the network, you'll likely have to be
-registered before first use. Please refer to the network's own
+If you've used @acronym{SASL} elsewhere, you can probably skip to the
+examples below. Otherwise, if you haven't already registered with
+your network, please do so now, referring to the network's own
instructions for details. If you're new to IRC and using a bouncer,
-know that you probably won't be needing SASL for the client-to-bouncer
-connection. To get started, just add @code{sasl} to
-@code{erc-modules} like any other module. But before that, please
-explore all custom options pertaining to your chosen mechanism.
+know that you probably won't be needing this for the client-to-bouncer
+connection.
+
+When you're ready to get started, add @code{sasl} to
+@code{erc-modules}, like you would any other module. If unsure which
+@dfn{mechanism} to choose, stick with the default of @samp{PLAIN}.
+Then try @kbd{C-u M-x erc-tls @key{RET}}, and give your account name
+for the @samp{user} parameter and your account password for the
+@samp{server password}.
@defopt erc-sasl-mechanism
The name of an SASL subprotocol type as a @emph{lowercase} symbol.
The value can be one of the following:
@table @asis
-@item @code{plain} and @code{scram} (``password-based'')
+@item @code{plain} or @code{scram} (``password-based'')
Here, ``password'' refers to your account password, which is usually
your @samp{NickServ} password. To make this work, customize
@code{erc-sasl-user} and @code{erc-sasl-password} or specify the
@code{:user} and @code{:password} keyword arguments when invoking
-@code{erc-tls}. Note that @code{:user} cannot be given interactively.
+@code{erc-tls}.
-@item @code{external} (via Client TLS Certificate)
+@item @code{external} (via client @acronym{TLS} certificate)
This works in conjunction with the @code{:client-certificate} keyword
offered by @code{erc-tls}. Just ensure you've registered your
fingerprint with the network beforehand. The fingerprint is usually a
@@ -1102,25 +1230,30 @@ machine Example.Net login aph-bot password sesame
(defun my-erc-up (network)
(interactive "Snetwork: ")
-
- (pcase network
- ('libera
- (let ((erc-sasl-mechanism 'external))
- (erc-tls :server "irc.libera.chat" :port 6697
- :client-certificate t)))
- ('example
- (let ((erc-sasl-auth-source-function
- #'erc-sasl-auth-source-password-as-host))
- (erc-tls :server "irc.example.net" :port 6697
- :user "alyssa"
- :password "Example.Net")))))
+ (require 'erc-sasl)
+ (or (let ((erc-modules (cons 'sasl erc-modules)))
+ (pcase network
+ ('libera
+ (let ((erc-sasl-mechanism 'external))
+ (erc-tls :server "irc.libera.chat"
+ :client-certificate t)))
+ ('example
+ (let ((erc-sasl-auth-source-function
+ #'erc-sasl-auth-source-password-as-host))
+ (erc-tls :server "irc.example.net"
+ :user "alyssa"
+ :password "Example.Net")))))
+ ;; Non-SASL
+ (call-interactively #'erc-tls)))
@end lisp
You've started storing your credentials with auth-source and have
decided to try SASL on another network as well. But there's a catch:
this network doesn't support @samp{EXTERNAL}. You use
-@code{let}-binding to get around this and successfully authenticate to
-both networks.
+@code{let}-binding to work around this and successfully authenticate
+to both networks. (Note that this example assumes you've removed
+@code{sasl} from @code{erc-modules} globally and have instead opted to
+add it locally when connecting to preconfigured networks.)
@end itemize
@@ -1149,82 +1282,311 @@ case, you'll probably want to temporarily disable
@section Sample Configuration
@cindex configuration, sample
-Here is an example of configuration settings for ERC@. This can go into
-your Emacs configuration file. Everything after the @code{(require
-'erc)} command can optionally go into @file{~/.emacs.d/.ercrc.el}.
+Here is an example configuration for ERC@. @strong{Don't panic} if
+you aren't familiar with @samp{use-package} or have no interest in
+learning it. For our purposes, it's just a means of presenting
+configuration details in a tidy, standardized format. If it helps,
+just pretend it's some make-believe, pseudo configuration language.
+And while the syntax below is easy enough to intuit and adapt to your
+setup, you may wish to keep the following in mind:
+
+@itemize @bullet
+@item
+Each @code{use-package} ``declaration'' focuses on a library
+``feature'', which is just a symbol you'd normally @code{require} in
+your config.
+
+@item
+Emacs loads anything in a @code{:config} section @emph{after} loading
+whatever library @code{provide}s the declaration's feature.
+
+@item
+Everything in a @code{:custom} or @code{:custom-face} section is
+basically something you'd find in your @code{custom-file}.
+
+@item
+For more info, @pxref{Named Features,,, elisp,}, or @pxref{Top,,,
+use-package,}.
+@end itemize
+
+@noindent
+The following would typically go in your init file. Experienced users
+may opt to keep any non-settings, like commands and functions, in a
+dedicated @file{~/.emacs.d/.ercrc.el}. Whatever the case, please keep
+in mind that you can replace nearly all of the following with Custom
+settings (@pxref{Sample configuration via Customize}).
+
+@lisp
+;;; My ERC configuration -*- lexical-binding: t -*-
+
+(use-package erc
+ :config
+ ;; Prefer SASL to NickServ, colorize nicknames, and show side panels
+ ;; with joined channels and members
+ (setopt erc-modules
+ (seq-union '(sasl nicks bufbar nickbar scrolltobottom)
+ erc-modules))
+
+ :custom
+ ;; Protect me from accidentally sending excess lines.
+ (erc-inhibit-multiline-input t)
+ (erc-send-whitespace-lines t)
+ (erc-ask-about-multiline-input t)
+ ;; Scroll all windows to prompt when submitting input.
+ (erc-scrolltobottom-all t)
+
+ ;; Reconnect automatically using a fancy strategy.
+ (erc-server-reconnect-function #'erc-server-delayed-check-reconnect)
+ (erc-server-reconnect-timeout 30)
+
+ ;; Show new buffers in the current window instead of a split.
+ (erc-interactive-display 'buffer)
+
+ ;; Insert a newline when I hit <RET> at the prompt, and prefer
+ ;; something more deliberate for actually sending messages.
+ :bind (:map erc-mode-map
+ ("RET" . nil)
+ ("C-c C-c" . #'erc-send-current-line))
+
+ ;; Emphasize buttonized text in notices.
+ :custom-face (erc-notice-face ((t (:slant italic :weight unspecified)))))
+
+(use-package erc-sasl
+ ;; Since my account name is the same as my nick, free me from having
+ ;; to hit C-u before M-x erc to trigger a username prompt.
+ :custom (erc-sasl-user :nick))
+
+(use-package erc-join
+ ;; Join #emacs and #erc whenever I connect to Libera.Chat.
+ :custom (erc-autojoin-channels-alist '((Libera.Chat "#emacs" "#erc"))))
+
+(use-package erc-fill
+ :custom
+ ;; Prefer one message per line without continuation indicators.
+ (erc-fill-function #'erc-fill-wrap)
+ (erc-fill-static-center 18)
+
+ :bind (:map erc-fill-wrap-mode-map ("C-c =" . #'erc-fill-wrap-nudge)))
+
+(use-package erc-track
+ ;; Prevent JOINs and PARTs from lighting up the mode-line.
+ :config (setopt erc-track-faces-priority-list
+ (remq 'erc-notice-face erc-track-faces-priority-list))
+
+ :custom (erc-track-priority-faces-only 'all))
+
+(use-package erc-goodies
+ ;; Turn on read indicators when joining channels.
+ :hook (erc-join . my-erc-enable-keep-place-indicator-on-join))
+
+(defvar my-erc-read-indicator-channels '("#emacs")
+ "Channels in which to show a `keep-place-indicator'.")
+
+(defun my-erc-enable-keep-place-indicator-on-join ()
+ "Enable read indicators for certain queries or channels."
+ (when (member (erc-default-target) my-erc-read-indicator-channels)
+ (erc-keep-place-indicator-mode +1)))
+
+;; Handy commands from the Emacs Wiki.
+(defun erc-cmd-TRACK (&optional target)
+ "Start tracking TARGET or that of current buffer."
+ (setq erc-track-exclude
+ (delete (or target (erc-default-target) (current-buffer))
+ erc-track-exclude)))
+
+(defun erc-cmd-UNTRACK (&optional target)
+ "Stop tracking TARGET or that of current buffer."
+ (setq erc-track-exclude
+ (cl-pushnew (or target (erc-default-target) (current-buffer))
+ erc-track-exclude
+ :test #'equal)))
+
+@end lisp
+
+@noindent
+Those familiar with @code{use-package} may have noticed the lack of
+@code{:defer} keyword args. This was done to conserve space, but you
+can just pretend that this user has enabled
+@code{use-package-always-defer} elsewhere.
+
+@anchor{Sample configuration via Customize}
+@subheading Via Customize
+@cindex configuration, via customize
+
+As mentioned, Customize users can accomplish nearly all of the above
+via the Customize interface. Start by running @kbd{M-x
+customize-group @key{RET} erc @key{RET}}, and search for ``Modules''
+with @kbd{C-s modules @key{RET}}. Toggle open the flyout menu to
+reveal the full @dfn{widget} panel, a web-form-like interface for
+``Erc Modules''. Tick the boxes for @samp{bufbar}, @samp{nickbar},
+@samp{nicks}, @samp{sasl}, and @samp{scrolltobottom}.
+
+Next, search for the phrases ``Erc Ask About Multiline Input'', ``Erc
+Inhibit Multiline Input'', and ``Erc Send Whitespace Lines''. These
+are the print names of three boolean options that control how ERC
+treats prompt input containing line breaks. When visiting each
+option's section, twirl open its triangle icon to reveal its widget
+UI, and click its @samp{[Toggle]} button to set its value to @code{t}.
+While going about this, you may find it helpful to glance at the
+descriptions just in case you want to disable them later. When
+finished, hit @kbd{C-x C-s} or click @samp{[Apply and Save]} atop the
+buffer.
+
+Now do the same for another couple options, this time having to do
+with automatic reconnection. But instead of searching for their print
+names, try running @kbd{M-x customize-option @key{RET} @samp{<option>}
+@key{RET}}, replacing @samp{<option>} with:
+
+@itemize @bullet
+@item @code{erc-server-reconnect-function}, a function
+@item @code{erc-server-reconnect-timeout}, a number
+@end itemize
+
+@noindent
+(If it helps, hit @key{TAB} for completion.) As you may have noticed,
+when customizing options individually, each buffer displays but a
+single option's widget. When you get to the buffer for ``Erc Server
+Reconnect Function'', you'll see that @samp{[Toggle]} has been
+replaced with @samp{[Value Menu]} and that clicking it reveals three
+choices in a pop-up window. Enter @kbd{1} to select
+@code{erc-server-delayed-check-reconnect} before @key{TAB}'ing over to
+@samp{[State]} and hitting @key{RET}. Enter @kbd{1} again, this time
+to persists your changes.
+
+For the final option, @code{erc-server-reconnect-timeout}, you'll
+encounter a text field (instead of a button), which works like those
+in a typical web form. Enter @samp{30} and hit @kbd{C-x C-s} to save.
+Just for fun, click the group link for @samp{Erc Server} at the bottom
+of the buffer. You could just as well have set the last two options
+from this ``custom group'' buffer alone, which very much resembles the
+one for the @samp{Erc} group, which is actually the ``parent'' of this
+group (note the ``breadcrumb'' for group @samp{Erc} atop the buffer).
+Indeed, you can always get back here by running @kbd{M-x
+customize-group @key{RET} erc-server @key{RET}} from almost anywhere
+in Emacs.
+
+To make sure you've got this, try quickly customizing the option
+@code{erc-interactive-display}, which lives in the @samp{Erc Buffers}
+group (@kbd{M-x customize-group @key{RET} erc-buffers @key{RET}}). As
+its doc string explains, the option controls where new buffers show up
+when you do @kbd{M-x erc-tls @key{RET}} or issue certain @dfn{slash
+commands}, like @kbd{/JOIN #emacs-beginners @key{RET}}, at ERC's
+prompt. Change its value to the symbol @code{buffer} by choosing
+@samp{Use current window} (item @kbd{5}) from the option's
+@samp{[Value Menu]}. Don't forget to save.
+
+If you need more practice, try enabling the boolean option
+@code{erc-scrolltobottom-all}, which lives in the @samp{Erc Display}
+group (@kbd{M-x customize-group @key{RET} erc-display @key{RET}}).
+When enabled, this option tells the @samp{scrolltobottom} module to
+adjust all ERC windows instead of just the one you're currently typing
+in.
+
+Now it's time to set some key bindings for @code{erc-mode-map}, a
+major-mode keymap active in all ERC buffers. In general, it's best to
+do this part either entirely or in conjunction with some lisp code in
+you init file. However, to keep things ``simple'', we'll do it all in
+customization buffers. To get started, hit @kbd{M-x customize-group
+@key{RET} erc-hooks @key{RET}} and search for ``Erc Mode Hook''. In
+the widget form, click @samp{[INS]}, and paste the following into the
+value field in place of the default text.
@lisp
-;;; Sample ERC configuration
-
-;; Load authentication info from an external source. Put sensitive
-;; passwords and the like in here.
-(load "~/.emacs.d/.erc-auth")
-
-;; This is an example of how to make a new command. Type "/uptime" to
-;; use it.
-(defun erc-cmd-UPTIME (&rest ignore)
- "Display the uptime of the system, as well as some load-related
-stuff, to the current ERC buffer."
- (let ((uname-output
- (replace-regexp-in-string
- ", load average: " "] @{Load average@} ["
- ;; Collapse spaces, remove
- (replace-regexp-in-string
- " +" " "
- ;; Remove beginning and trailing whitespace
- (replace-regexp-in-string
- "^ +\\|[ \n]+$" ""
- (shell-command-to-string "uptime"))))))
- (erc-send-message
- (concat "@{Uptime@} [" uname-output "]"))))
-
-;; This causes ERC to connect to the Libera.Chat network upon hitting
-;; C-c e f. Replace MYNICK with your IRC nick.
-(global-set-key "\C-cef" (lambda () (interactive)
- (erc :server "irc.libera.chat" :port "6667"
- :nick "MYNICK")))
-
-;; This causes ERC to connect to the IRC server on your own machine (if
-;; you have one) upon hitting C-c e b. Replace MYNICK with your IRC
-;; nick. Often, people like to run bitlbee (https://bitlbee.org/) as an
-;; AIM/Jabber/MSN to IRC gateway, so that they can use ERC to chat with
-;; people on those networks.
-(global-set-key "\C-ceb" (lambda () (interactive)
- (erc :server "localhost" :port "6667"
- :nick "MYNICK")))
-
-;; Make C-c RET (or C-c C-RET) send messages instead of RET. This has
-;; been commented out to avoid confusing new users.
-;; (define-key erc-mode-map (kbd "RET") nil)
-;; (define-key erc-mode-map (kbd "C-c RET") 'erc-send-current-line)
-;; (define-key erc-mode-map (kbd "C-c C-RET") 'erc-send-current-line)
-
-;;; Options
-
-;; Join the #emacs and #erc channels whenever connecting to
-;; Libera.Chat.
-(setq erc-autojoin-channels-alist
- '(("Libera.Chat" "#emacs" "#erc")))
-
-;; Interpret mIRC-style color commands in IRC chats
-(setq erc-interpret-mirc-color t)
-
-;; The following are commented out by default, but users of other
-;; non-Emacs IRC clients might find them useful.
-;; Kill buffers for channels after /part
-;; (setq erc-kill-buffer-on-part t)
-;; Kill buffers for private queries after quitting the server
-;; (setq erc-kill-queries-on-quit t)
-;; Kill buffers for server messages after quitting the server
-;; (setq erc-kill-server-buffer-on-quit t)
+(lambda ()
+ (keymap-set erc-mode-map "RET" nil)
+ (keymap-set erc-mode-map "C-c C-c" 'erc-send-current-line))
@end lisp
+@noindent
+Don't worry about the line breaks. Emacs is smart enough to handle
+those. When you're ready, click @samp{[Apply and Save]}.
+
+Next, try tweaking the face ERC uses to stylize server messages that
+say things like ``SoAndSo has joined channel #chan''. Type @kbd{M-x
+customize-face @key{RET} erc-notice-face @key{RET}}. Click the
+``link''-looking button at the very bottom that says something like
+``Show All Attributes''. Untick @samp{Weight} and tick @samp{Slant}.
+Then, in the latter's @samp{[Value Menu]}, enter @samp{0} for
+@samp{italic}. Hit @kbd{C-x C-s} to save.
+
+Time for some more involved configuring. From now on, if something
+isn't applicable to your setup, just skip ahead. Also, note that if
+you've installed ERC from GNU ELPA, you may need to load libraries for
+groups and options you'd like to customize before Emacs can create a
+customization buffer. For example, to do this for the group
+@code{erc-sasl}, run @kbd{M-: (require 'erc-sasl) @key{RET}}.
+
+Speaking of @acronym{SASL}, those already authenticating with it may
+have noticed that connecting interactively requires running @kbd{C-u
+M-x erc-tls @key{RET}} in order to receive a ``User'' prompt for your
+account name. However, if your nickname happens to be the same as
+your account name, you can avoid the leading @kbd{C-u} by customizing
+the option @code{erc-sasl-user} to the keyword symbol @code{:nick}.
+At the time of writing, you'd hit @kbd{2} when prompted by the
+option's @samp{[Value menu]}. Hit @kbd{C-x C-s} to save your changes.
+
+One of ERC's most configured options lives in @file{erc-join}, and it
+determines the channels you join upon connecting. To make it work for
+you, customize the option @code{erc-autojoin-channels-alist}. In the
+customization widget, hit @samp{[INS]} to create a new entry. In the
+@samp{Network:} field, type @samp{Libera.Chat}. Under
+@samp{Channels:}, hit @samp{[INS]} again, this time to create a field
+to enter a channel name, and enter @samp{#emacs}. Now, find and click
+on the lowermost @samp{[INS]}, and this time enter @samp{#erc} in the
+@samp{Name:} field. Save your changes.
+
+If you're new to ERC, you may not be familiar with the various ways it
+can ``fill'' message text by inserting line breaks. The most modern
+fill style is called @code{fill-wrap}, and it's available by
+customizing @code{erc-fill-function} to @code{erc-fill-wrap}, which
+appears as @samp{Dynamic word-wrap} in the option's @samp{[Value
+Menu]}. After setting this, change the related option
+@code{erc-fill-static-center} to the integer @samp{18}. Save your
+changes. As a bonus exercise, try binding the key @kbd{C-c =} to the
+function @code{erc-fill-wrap-nudge} in the minor-mode keymap
+@code{erc-fill-wrap-mode-map} (hint: the minor mode's hook is called
+@code{erc-fill-wrap-mode-hook}, and it's not a member of any
+customization group).
+
+ERC users tend to be picky about the mode line. If you find that
+you'd rather not see changes when people join and leave channels,
+customize the option @code{erc-track-faces-priority-list}. When
+visiting its customization buffer, you'll notice it's quite busy.
+Ignore everything and type @kbd{C-s erc-notice-face @key{RET}}. Click
+the @samp{[DEL]} button at the beginning of the line you end up on,
+and save your changes. Next, customize the related option
+@code{erc-track-priority-faces-only} to the @samp{[Value Menu]} choice
+@samp{all}. Once again, save your changes.
+
+Let's say you'd like to enable a @dfn{local module} (ERC's version of
+a local minor mode) in a specific channel. One way to do that is by
+running some code to activate the module if the channel's name
+matches. Try that now by customizing the option @code{erc-join-hook}.
+Add the following in the value field before saving your changes:
+
+@lisp
+(lambda ()
+ (require 'erc-goodies)
+ (when (equal (erc-default-target) "#emacs")
+ (erc-keep-place-indicator-mode +1)))
+@end lisp
+
+Lastly, if you really want the two @dfn{slash commands} defined at the
+end of the previous section, you can put them in any file listed in
+@code{erc-startup-file-list}, such as @file{~/.emacs.d/.ercrc.el}.
+Make sure to put @code{(require 'erc-track)} near the top of the file.
+These will allow you to type @kbd{/TRACK @key{RET}} and @kbd{/UNTRACK
+@key{RET}} in channels and query buffers to tell ERC whether to show
+activity from these buffers in the mode line.
+
+
@node Integrations
@section Integrations
@cindex integrations
@menu
* auth-source:: Retrieving auth-source entries with ERC.
+* display-buffer:: Controlling how ERC displays buffers.
@end menu
@anchor{URL}
@@ -1252,6 +1614,68 @@ need a function as well:
@noindent
Users on Emacs 28 and below may need to use @code{browse-url} instead.
+@anchor{SOCKS}
+@subsection SOCKS
+@cindex SOCKS
+
+People wanting to connect to IRC through a @acronym{SOCKS} proxy are
+most likely interested in doing so over @acronym{TOR} (The Onion
+Router). If that's @emph{not} you, please adapt these instructions
+accordingly. Otherwise, keep in mind that support for Tor is
+experimental and thus insufficient for safeguarding a user's identity
+and location, especially in the case of targeted individuals.
+
+ERC's preferred Tor setup works by accessing a local Tor service
+through the built-in @file{socks.el} library that ships with Emacs.
+Other means of accessing Tor, such as via @command{torsocks}, are not
+supported. Before getting started, check that your Tor service is up
+and running. You can do that with the following command:
+
+@example
+curl --proxy socks5h://localhost:9050 https://check.torproject.org | \
+ grep 'Congratulations'
+@end example
+
+Networks and servers differ in how they expose Tor endpoints. In all
+cases, you'll want to first set the option @code{socks-server} to
+something appropriate, like @code{("tor" "127.0.0.1" 9050 5)}. For
+some networks, setting @code{erc-server-connect-function} to
+@code{socks-open-network-stream} might be enough. Others, like
+@samp{Libera.Chat}, involve additional setup. At the time of writing,
+connecting to that network requires both @acronym{TLS} and a permitted
+@acronym{SASL} mechanism, like @samp{EXTERNAL} (@pxref{SASL}), as
+shown in the following example:
+
+@lisp
+(require 'erc)
+(require 'socks)
+
+(defun my-erc-open-socks-tls-stream (&rest args)
+ (let ((socks-username "")
+ (socks-password "")
+ (socks-server '("tor" "localhost" 9050 5)))
+ (apply #'erc-open-socks-tls-stream args)))
+
+(let* ((erc-modules (cons 'sasl erc-modules))
+ (erc-sasl-mechanism 'external)
+ (erc-server-connect-function #'my-erc-open-socks-tls-stream))
+ (erc-tls
+ :server "libera75jm6of4wxpxt4aynol3xjmbtxgfyjpu34ss4d7r7q2v5zrpyd.onion"
+ :port 6697
+ :nick "jrh"
+ :user "jrandomhacker"
+ :full-name "J. Random Hacker"
+ :client-certificate (list "/home/jrh/key.pem" "/home/jrh/cert.pem")))
+@end lisp
+
+@noindent
+Here, the user-provided @code{my-erc-open-socks-tls-stream} ensures
+that the preferred values for @code{socks-server} and friends will be
+available when reconnecting. If you plan on using @acronym{SOCKS}
+with ERC exclusively, you can just set those options and variables
+globally and bind @code{erc-server-connect-function} to
+@code{erc-open-socks-tls-stream} instead.
+
@node auth-source
@subsection auth-source
@cindex auth-source
@@ -1269,6 +1693,7 @@ with the default backend, netrc, put a line like the following in your
machine irc.example.net login mynick password sEcReT
@end example
+@anchor{auth-source Server Password}
@subsubheading Server Passwords
When retrieving passwords to accompany the IRC @samp{PASS} command
(@pxref{password parameter}), ERC asks auth-source to match the
@@ -1318,10 +1743,7 @@ auth-source experience. (@xref{SASL}.)
@subsubheading Default query behavior
When preparing entries for your backend, it may help to get a feel for
how ERC and its modules conduct searches, especially when exploring a
-new context, such as channel keys. (Hint: in such situations, try
-temporarily setting the variable @code{auth-source-debug} to @code{t}
-and checking @file{*Messages*} periodically for insights into how
-auth-source is operating.) Overall, though, ERC tries to be
+new context, such as channel keys. Overall, though, ERC tries to be
consistent in performing queries across various authentication
contexts. Here's what to expect with respect to the @samp{host}
field, which, by default, most heavily influences the fate of a query:
@@ -1405,6 +1827,213 @@ required by certain channels you join. When modifying a traditional
@samp{user} field (for example, @samp{login "#fsf"}, in netrc's case).
The actual key goes in the @samp{password} (or @samp{secret}) field.
+@anchor{auth-source Troubleshooting}
+@subheading Troubleshooting
+By default, ERC queries @code{auth-source} for channel keys and server
+passwords (@pxref{auth-source Server Password}), as well as other,
+module-specific credentials. In general, if you're having trouble
+calling @code{auth-source-search} in a custom query function, like
+@code{erc-auth-source-server-function}, try temporarily setting the
+variable @code{auth-source-debug} to @code{t} and checking
+@file{*Messages*} periodically for insights into how
+@code{auth-source} is operating.
+
+If you're using a @acronym{GPG}-encrypted file and find that
+customizing one of the function-valued query options doesn't solve
+your problem, explore options @code{epg-pinentry-mode} and
+@code{epg-debug} in the @code{epg} Custom group (@pxref{GnuPG
+Pinentry,,, epa, EasyPG Assistant}). Additionally, keep an eye out
+for an @file{*Error*} buffer, which may contain more specific clues
+about your situation. If you use the libsecrets integration
+(@pxref{Secret Service API,,, auth, Emacs auth-source}) with something
+like GNOME Keyring, you may need to check the ``remember'' box in the
+passphrase popup dialog to avoid being prompted for confirmation every
+time you run ERC. If it doesn't work at first, try logging out. And
+when in doubt, try using the Emacs command @code{secrets-show-secrets}
+to browse the @samp{Login} keyring. There should be a
+@samp{GnuPG/stored-by} entry with a value of @samp{GnuPG Pinentry} or
+similar.
+
+@node display-buffer
+@subsection display-buffer
+@cindex display-buffer
+
+ERC supports the ``action'' interface used by @code{display-buffer}
+and friends from @file{window.el}. @xref{Displaying Buffers,,, elisp,
+Emacs Lisp}, for specifics. When ERC displays a new or
+``reassociated'' buffer, it consults its various buffer-display
+options, such as @code{erc-buffer-display}, to decide whether and how
+the buffer ought to appear in a window. Exactly which one it consults
+depends on the context in which the buffer is being manifested.
+
+For some buffer-display options, the context is pretty cut and dry.
+For instance, in the case of @code{erc-receive-query-display}, you're
+receiving a query from someone you haven't yet chatted with in the
+current session. For other options, like
+@code{erc-interactive-display}, the precise context varies. For
+example, you might be opening a query buffer with the command
+@kbd{/QUERY bob @key{RET}} or joining a new channel with @kbd{/JOIN
+#chan @key{RET}}. Power users wishing to distinguish between such
+nuanced contexts or just exercise more control over buffer-display
+behavior generally can elect to override these options by setting one
+or more to a ``@code{display-buffer}-like'' function that accepts a
+@var{buffer} and an @var{action} argument.
+
+@subsubheading Examples
+
+In this first example, a user-provided buffer-display function
+displays new server buffers in the current window when issuing an
+@kbd{M-x erc-tls @key{RET}} and in a split window for all other
+interactve contexts covered by the option
+@code{erc-interactive-display}, like clicking an @samp{irc://}-style
+@acronym{URL} (@pxref{URL}).
+
+@lisp
+(defun my-erc-interactive-display-buffer (buffer action)
+ "Pop to BUFFER when running \\[erc-tls], clicking a link, etc."
+ (when-let ((alist (cdr action))
+ (found (alist-get 'erc-interactive-display alist)))
+ (if (eq found 'erc-tls)
+ (pop-to-buffer-same-window buffer action)
+ (pop-to-buffer buffer action))))
+
+(setopt erc-interactive-display #'my-erc-interactive-display-buffer)
+@end lisp
+
+@noindent
+Observe that ERC supplies the names of buffer-display options as
+@var{action} alist keys and pairs them with contextual constants, like
+the symbols @samp{erc-tls} or @samp{url}, the full lineup of which are
+listed below.
+
+In this second example, for Emacs 29 and above, the user writes three
+predicates that somewhat resemble the ``@code{display-buffer}-like''
+function above. These too look for @var{action} alist keys sharing
+the names of ERC's buffer-display options (and, in one case, a
+module's minor mode).
+
+@lisp
+(defun my-erc-disp-entry-p (_ action)
+ (memq (cdr (or (assq 'erc-buffer-display action)
+ (assq 'erc-interactive-display action)))
+ '(erc-tls url)))
+
+(defun my-erc-disp-query-p (_ action)
+ (or (eq (cdr (assq 'erc-interactive-display action)) '/QUERY)
+ (and (eq (cdr (assq 'erc-receive-query-display action)) 'PRIVMSG)
+ (member (erc-default-target) '("bob" "alice")))))
+
+(defun my-erc-disp-chan-p (_ action)
+ (or (assq 'erc-autojoin-mode action)
+ (and (eq (cdr (assq 'erc-buffer-display action)) 'JOIN)
+ (member (erc-default-target) '("#emacs" "#fsf")))))
+@end lisp
+
+@noindent
+You'll notice we ignore the @var{buffer} parameter of these predicates
+because ERC ensures that @var{buffer} is already current (which is why
+we can freely call @code{erc-default-target}). Note also that we
+cheat a little by treating the @var{action} parameter like an alist
+when it's really a cons of one or more functions and an alist.
+
+@noindent
+To complement our predicates, we set all three buffer-display options
+referenced in their @var{action}-alist lookups to
+@code{display-buffer}. This tells ERC to defer to that function in
+the display contexts covered by these options.
+
+@lisp
+(setopt erc-buffer-display #'display-buffer
+ erc-interactive-display #'display-buffer
+ erc-receive-query-display #'display-buffer
+ ;;
+ erc-auto-reconnect-display 'bury)
+@end lisp
+
+@noindent
+The last option above just tells ERC to avoid any buffer-display
+machinery when auto-reconnecting. (For historical reasons, ERC's
+buffer-display options use the term ``bury'' to mean ``ignore'' rather
+than @code{bury-buffer}.)
+
+Finally, we compose our predicates into @code{buffer-match-p}
+conditions and pair them with various well known @code{display-buffer}
+action functions and action-alist members.
+
+@lisp
+(setopt display-buffer-alist
+
+ ;; Create new frame with M-x erc-tls RET or (erc-tls ...)
+ '(((and (major-mode . erc-mode) my-erc-disp-entry-p)
+ display-buffer-pop-up-frame
+ (reusable-frames . visible))
+
+ ;; Show important chans and queries in a split.
+ ((and (major-mode . erc-mode)
+ (or my-erc-disp-chan-p my-erc-disp-query-p))
+ display-buffer-pop-up-window)
+
+ ;; Ignore everything else.
+ ((major-mode . erc-mode)
+ display-buffer-no-window
+ (allow-no-window . t))))
+@end lisp
+
+@noindent
+Of course, we could just as well set our buffer-display options to one
+or more homespun functions instead of bothering with
+@code{display-buffer-alist} at all (in what would make for a more
+complicated version of our first example). But perhaps we already
+have a growing menagerie of similar predicates and like to keep
+everything in one place in our @file{init.el}.
+
+@subsubheading Action alist items
+
+@table @asis
+@item Option-based keys:
+All keys are symbols, as are values, unless otherwise noted.
+
+@itemize @bullet
+@item @code{erc-buffer-display}
+@itemize @minus
+@item @samp{JOIN}
+@item @samp{NOTICE}
+@item @samp{PRIVMSG}
+@item @samp{erc} (entry point called non-interactively)
+@item @samp{erc-tls}
+@end itemize
+
+@item @code{erc-interactive-display}
+@itemize @minus
+@item @samp{/QUERY}
+@item @samp{/JOIN}
+@item @samp{/RECONNECT}
+@item @samp{url} (hyperlink clicked)
+@item @samp{erc} (entry point called interactively)
+@item @samp{erc-tls}
+@end itemize
+
+@item @code{erc-receive-query-display}
+@itemize @minus
+@item @samp{NOTICE}
+@item @samp{PRIVMSG}
+@end itemize
+
+@item @code{erc-auto-reconnect-display}
+@itemize @minus
+@item something non-@code{nil}
+@end itemize
+@end itemize
+
+@item Module-based (minor-mode) keys:
+
+@itemize @bullet
+@item @code{erc-autojoin-mode}
+@itemize @minus
+@item channel name as a string, e.g., @code{"#chan"}
+@end itemize
+@end itemize
+@end table
@node Options
@section Options
@@ -1468,7 +2097,9 @@ If you do so, please help keep it up to date.
@item
You can ask questions about using ERC on the Emacs mailing list,
-@uref{https://lists.gnu.org/mailman/listinfo/help-gnu-emacs}.
+@uref{https://lists.gnu.org/mailman/listinfo/help-gnu-emacs}, as well
+as on ERC's own low-volume list,
+@uref{https://lists.gnu.org/mailman/listinfo/emacs-erc}.
@item
You can visit the IRC Libera.Chat channel @samp{#emacs}. Many of the
@@ -1490,7 +2121,7 @@ In the resulting @code{help-mode} buffer, confirm the version and
click @samp{Install}. Make sure to restart Emacs before reconnecting
to IRC, and don't forget that you can roll back to the previous
version by running @kbd{M-x package-delete @key{RET}}.
-@xref{Packages,,,emacs, the Emacs manual} for more information.
+@xref{Packages,,,emacs, The Emacs Editor}, for more information.
In the rare instance you need an emergency fix or have volunteered to
test an edge feature between ERC releases, you can try adding
@@ -1579,6 +2210,21 @@ is maintained as part of Emacs.
@end itemize
+@anchor{Official IRC channels}
+@subheading Official IRC channels
+@cindex official IRC channels
+
+The official channels for GNU Emacs and ERC lived on the Freenode IRC
+network until June 2021, when they---along with the official IRC
+channels of the GNU Project, the Free Software Foundation, and many
+other free software communities---relocated to the Libera.Chat network
+in the aftermath of changes in governance and policies of Freenode in
+May and June 2021. GNU and FSF's announcements about this are at
+@uref{https://lists.gnu.org/archive/html/info-gnu/2021-06/msg00005.html},
+@uref{https://lists.gnu.org/archive/html/info-gnu/2021-06/msg00007.html},
+and
+@uref{https://lists.gnu.org/archive/html/info-gnu-emacs/2021-06/msg00000.html}.
+
@node GNU Free Documentation License
@appendix GNU Free Documentation License
@include doclicense.texi
diff --git a/doc/misc/ert.texi b/doc/misc/ert.texi
index e10b8e3a7b4..8767de71496 100644
--- a/doc/misc/ert.texi
+++ b/doc/misc/ert.texi
@@ -526,6 +526,7 @@ to find where a test was defined if the test was loaded from a file.
* Tests and Their Environment:: Don't depend on customizations; no side effects.
* Useful Techniques:: Some examples.
* erts files:: Files containing many buffer tests.
+* Syntax Highlighting Tests:: Tests for face assignment.
@end menu
@@ -658,11 +659,30 @@ versions, specific architectures, etc.:
@cindex skipping tests
@cindex test preconditions
@cindex preconditions of a test
+@findex skip-when
+@findex skip-unless
Sometimes, it doesn't make sense to run a test due to missing
preconditions. A required Emacs feature might not be compiled in, the
function to be tested could call an external binary which might not be
-available on the test machine, you name it. In this case, the macro
-@code{skip-unless} could be used to skip the test:
+available on the test machine, you name it. In this case, the macros
+@code{skip-when} or @code{skip-unless} could be used to skip the
+test.@footnote{The @code{skip-when} macro was added in Emacs 30.1. If
+you need your tests to be compatible with older versions of Emacs, use
+@code{skip-unless} instead.}
+
+@noindent
+For example, this test is skipped on MS-Windows and macOS:
+
+@lisp
+(ert-deftest test-gnu-linux ()
+ "A test that is not relevant on MS-Windows and macOS."
+ (skip-when (memq system-type '(windows-nt ns))
+ ...))
+@end lisp
+
+@noindent
+This test is skipped if the feature @samp{dbusbind} is not present in
+the running Emacs:
@lisp
(ert-deftest test-dbus ()
@@ -923,6 +943,137 @@ non-@code{nil} value, the test will be skipped.
If you need to use the literal line single line @samp{=-=} in a test
section, you can quote it with a @samp{\} character.
+@node Syntax Highlighting Tests
+@section Syntax Highlighting Tests
+
+Syntax highlighting is normally provided by the Font Lock minor mode
+that assigns face properties to parts of the buffer. The
+@code{ert-font-lock} package makes it possible to introduce unit tests
+checking face assignment. Test assertions are included in code-level
+comments directly and can be read either from inline strings or files.
+The parser expects the input string to contain at least one assertion.
+
+Test assertion parser extracts tests from comment-only lines. Every
+comment assertion line starts either with a caret (@samp{^}) or an arrow
+(@samp{<-}). A single caret/arrow or carets should be followed
+immediately by the name of a face or a list of faces to be checked
+against the @code{:face} property at point.
+
+The test then checks if the first non-assertion column above the caret
+contains a face expected by the assertion:
+
+@example
+var variable = 11;
+// ^ font-lock-variable-name-face
+// ^ font-lock-literal-face
+// ^ font-lock-punctuation-face
+// this is not an assertion, it's just a comment
+// ^ font-lock-comment-face
+
+// multiple carets per line
+// ^^^^ ^ ^ font-lock-comment-face
+@end example
+
+Both symbol-only @code{:face} property values and assertion face values
+are normalized to single element lists so assertions below are
+equivalent:
+
+@example
+// single
+// ^ font-lock-comment-face
+// single
+// ^ (font-lock-comment-face)
+@end example
+
+Assertions can be negated:
+
+@example
+var variable = 11;
+// ^ !font-lock-comment-face
+@end example
+
+It is possible to specify face lists in assertions:
+
+@example
+// TODO
+// ^^^^ (font-lock-comment-face hl-todo)
+ var test = 1;
+// ^ ()
+// ^ nil
+// negation works as expected
+// ^ !nil
+@end example
+
+The arrow (@samp{<-}) means that the first non-empty column of the
+assertion line will be used for the check:
+
+@example
+var variable = 1;
+// <- font-lock-keyword-face
+ 11;
+ // <- font-lock-literal-face
+@end example
+
+@findex ert-font-lock-test-string
+
+The @code{ert-font-lock-test-string} function extracts ERT assertions
+from an inline string. The @code{javascript-mode} symbol below
+specifies the major mode used for comments and font locking:
+
+@lisp
+(ert-deftest test-font-lock-test-string--correct ()
+ (ert-font-lock-test-string
+ "
+var abc = function(d) @{
+// <- font-lock-keyword-face
+// ^ font-lock-variable-name-face
+ // ^ font-lock-keyword-face
+ // ^ font-lock-variable-name-face
+@};
+"
+ 'javascript-mode))
+@end lisp
+
+@findex ert-font-lock-test-file
+
+It is also possible to extract test assertions from a file:
+
+@lisp
+(ert-deftest test-font-lock-test-file--correct ()
+ (ert-font-lock-test-file
+ (ert-resource-file "correct.js")
+ 'javascript-mode))
+@end lisp
+
+@findex ert-font-lock-deftest
+
+The @code{ert-font-lock-deftest} macro simplifies inline test
+definition:
+
+@lisp
+(ert-font-lock-deftest test-macro-test--inline
+ emacs-lisp-mode
+ "
+(defun fun ())
+;; ^ font-lock-keyword-face
+;; ^ font-lock-function-name-face")
+@end lisp
+
+@findex ert-font-lock-deftest-file
+
+The @code{ert-font-lock-deftest-file} macro reads assertions from a
+file:
+
+@lisp
+(ert-font-lock-deftest-file test-macro-test--file
+ "Test reading correct assertions from a file"
+ javascript-mode
+ "correct.js")
+@end lisp
+
+The @code{ert-font-lock-deftest} and @code{ert-font-lock-deftest-file}
+macros accept the same keyword parameters as @code{ert-deftest} i.e.,
+@code{:tag} and @code{:expected-result}.
@node How to Debug Tests
@chapter How to Debug Tests
diff --git a/doc/misc/eshell.texi b/doc/misc/eshell.texi
index 73607ab5a99..30c85da795b 100644
--- a/doc/misc/eshell.texi
+++ b/doc/misc/eshell.texi
@@ -3,7 +3,7 @@
@setfilename ../../info/eshell.info
@settitle Eshell: The Emacs Shell
@include docstyle.texi
-@defindex cm
+@defcodeindex cm
@syncodeindex vr fn
@c %**end of header
@@ -234,6 +234,9 @@ the foreground. That said, background processes invoked from Eshell
can be controlled the same way as any other background process in
Emacs.
+If a command exits abnormally, Eshell will display its exit code
+in the next prompt.
+
@subsection Command form
Command form looks much the same as in other shells. A command
consists of arguments separated by spaces; the first argument is the
@@ -317,9 +320,10 @@ specify an argument of some other data type, you can use a Lisp form
(1 2 3)
@end example
-Additionally, many built-in Eshell commands (@pxref{Built-ins}) will
-flatten the arguments they receive, so passing a list as an argument
-will ``spread'' the elements into multiple arguments:
+When calling external commands (and many built-in Eshell commands,
+too) Eshell will flatten the arguments the command receives, so
+passing a list as an argument will ``spread'' the elements into
+multiple arguments:
@example
~ $ printnl (list 1 2) 3
@@ -396,6 +400,14 @@ Return the buffer named @var{name}. This is equivalent to
@samp{$(get-buffer-create "@var{name}")} (@pxref{Creating Buffers, , ,
elisp, The Emacs Lisp Reference Manual}).
+@item #<marker @var{position} @var{buffer-or-name}>
+Return a marker at @var{position} in the buffer @var{buffer-or-name}.
+@var{buffer-or-name} can either be a string naming a buffer or an
+actual buffer object. This is roughly equivalent to creating a new
+marker and calling @samp{$(set-marker marker @var{position}
+@var{buffer-or-name})} (@pxref{Moving Markers, , , elisp, The Emacs
+Lisp Reference Manual}).
+
@item #<process @var{name}>
Return the process named @var{name}. This is equivalent to
@samp{$(get-process "@var{name}")} (@pxref{Process Information, , ,
@@ -404,14 +416,24 @@ elisp, The Emacs Lisp Reference Manual}).
@end table
@node Built-ins
-@section Built-in commands
+@section Built-in Commands
Eshell provides a number of built-in commands, many of them
implementing common command-line utilities, but enhanced for Eshell.
(These built-in commands are just ordinary Lisp functions whose names
begin with @code{eshell/}.) In order to call the external variant of
a built-in command @code{foo}, you could call @code{*foo}. Usually,
-this should not be necessary. You can check what will be applied by
-the @code{which} command:
+this should not be necessary; if the Eshell version of a command
+doesn't support a particular option, it will automatically invoke the
+external command for you.
+
+Some built-in Eshell commands provide enhanced versions of regular
+Emacs Lisp functions. If you want to call the regular Emacs Lisp
+version, you can write your command in Lisp form (@pxref{Invocation}).
+To call the regular version in command form, you can use
+@code{funcall} or @code{apply}, e.g.@: @samp{funcall #'compile "make all"}
+(@pxref{Calling Functions,,, elisp, GNU Emacs Lisp Reference Manual}).
+
+You can check what will be applied by the @code{which} command:
@example
~ $ which ls
@@ -421,14 +443,19 @@ eshell/ls is a compiled Lisp function in `em-ls.el'
@end example
If you want to discard a given built-in command, you could declare an
-alias (@pxref{Aliases}). Example:
+alias (@pxref{Aliases}). For example:
@example
-~ $ which sudo
-eshell/sudo is a compiled Lisp function in `em-tramp.el'.
-~ $ alias sudo '*sudo $*'
-~ $ which sudo
-sudo is an alias, defined as "*sudo $*"
+@group
+~ $ alias ls '*ls $@@*'
+~ $ which ls
+ls is an alias, defined as "*ls $@@*"
+@end group
+@group
+~ $ alias compile 'apply #''compile $*'
+~ $ which compile
+ls is an alias, defined as "apply #'compile $*"
+@end group
@end example
Some of the built-in commands have different behavior from their
@@ -450,87 +477,133 @@ default target for the commands @command{cp}, @command{mv}, and
@command{ln} is the current directory.
A few commands are wrappers for more niche Emacs features, and can be
-loaded as part of the eshell-xtra module. @xref{Extension modules}.
+loaded as part of the @code{eshell-xtra} module. @xref{Extra built-in
+commands}.
+
+@menu
+* List of Built-ins::
+* Defining New Built-ins::
+@end menu
+
+@node List of Built-ins
+@subsection List of Built-in Commands
@table @code
-@item .
@cmindex .
-Source an Eshell file in the current environment. This is not to be
-confused with the command @command{source}, which sources a file in a
-subshell environment.
+@item . @var{file} [@var{argument}]@dots{}
+Source an Eshell script named @var{file} in the current environment,
+passing any @var{arguments} to the script (@pxref{Scripts}). This is
+not to be confused with the command @command{source}, which sources a
+file in a subshell environment.
-@item addpath
@cmindex addpath
-Adds a given path or set of paths to the PATH environment variable, or,
-with no arguments, prints the current paths in this variable.
+@item addpath
+@itemx addpath [-b] @var{directory}@dots{}
+Adds each specified @var{directory} to the @code{$PATH} environment
+variable. By default, this adds the directories to the end of
+@code{$PATH}, in the order they were passed on the command line; by
+passing @code{-b} or @code{--begin}, Eshell will instead add the
+directories to the beginning.
+
+With no directories, print the list of directories currently stored in
+@code{$PATH}.
-@item alias
@cmindex alias
-Define an alias (@pxref{Aliases}). This adds it to the aliases file.
+@item alias
+@itemx alias @var{name} [@var{command}]
+Define an alias named @var{name} and expanding to @var{command},
+adding it to the aliases file (@pxref{Aliases}). If @var{command} is
+omitted, delete the alias named @var{name}. With no arguments at all,
+list all the currently-defined aliases.
-@item basename
@cmindex basename
-Return a file name without its directory.
+@item basename @var{filename}
+Return @var{filename} without its directory.
-@item cat
@cmindex cat
-Concatenate file contents into standard output. If in a pipeline, or
-if the file is not a regular file, directory, or symlink, then this
-command reverts to the system's definition of @command{cat}.
+@item cat @var{file}@dots{}
+Concatenate the contents of @var{file}s to standard output. If in a
+pipeline, or if any of the files is not a regular file, directory, or
+symlink, then this command reverts to the system's definition of
+@command{cat}.
-@item cd
@cmindex cd
-This command changes the current working directory. Usually, it is
-invoked as @kbd{cd @var{dir}} where @file{@var{dir}} is the new
-working directory. But @command{cd} knows about a few special
-arguments:
+@cindex directories, changing
+@item cd
+@itemx cd @var{directory}
+@itemx cd -[@var{n}]
+@itemx cd =[@var{regexp}]
+Change the current working directory. This command can take several
+forms:
-@itemize @minus{}
-@item
-When it receives no argument at all, it changes to the home directory.
+@table @code
-@item
-Giving the command @kbd{cd -} changes back to the previous working
-directory (this is the same as @kbd{cd $-}).
+@item cd
+Change to the user's home directory.
-@item
-The command @kbd{cd =} shows the directory ring. Each line is
-numbered.
+@item cd @var{directory}
+Change to the specified @var{directory}.
-@item
-With @kbd{cd =foo}, Eshell searches the directory ring for a directory
-matching the regular expression @samp{foo}, and changes to that
-directory.
+@item cd -
+Change back to the previous working directory (this is the same as
+@kbd{cd $-}).
-@item
-With @kbd{cd -42}, you can access the directory stack slots by number.
+@item cd -@var{n}
+Change to the directory in the @var{nth} slot of the directory stack.
+
+@item cd =
+Show the directory ring. Each line is numbered.
+
+@item cd =@var{regexp}
+Search the directory ring for a directory matching the regular
+expression @var{regexp} and change to that directory.
+
+@end table
-@item
@vindex eshell-cd-shows-directory
@vindex eshell-list-files-after-cd
If @code{eshell-cd-shows-directory} is non-@code{nil}, @command{cd}
will report the directory it changes to. If
@code{eshell-list-files-after-cd} is non-@code{nil}, then @command{ls}
is called with any remaining arguments after changing directories.
-@end itemize
-@item clear
@cmindex clear
+@item clear [@var{scrollback}]
Scrolls the contents of the Eshell window out of sight, leaving a
-blank window. If provided with an optional non-@code{nil} argument,
-the scrollback contents are cleared instead.
+blank window. If @var{scrollback} is non-@code{nil}, the scrollback
+contents are cleared instead, as with @command{clear-scrollback}.
-@item clear-scrollback
@cmindex clear-scrollback
+@item clear-scrollback
Clear the scrollback contents of the Eshell window. Unlike the
command @command{clear}, this command deletes content in the Eshell
buffer.
-@item cp
+@cmindex compile
+@item compile [-p | -i] [-m @var{mode-name}] @var{command}@dots{}
+Run an external command, sending its output to a compilation buffer if
+the command would output to the screen and is not part of a pipeline
+or subcommand.
+
+With the @code{-p} or @code{--plain} options, always send the output
+to the Eshell buffer; similarly, with @code{-i} or
+@code{--interactive}, always send the output to a compilation buffer.
+You can also set the mode of the compilation buffer with @code{-m
+@var{mode-name}} or @code{--mode @var{mode-name}}.
+
+@command{compile} is particularly useful when defining aliases, so
+that interactively, the output shows up in a compilation buffer, but
+you can still pipe the output elsewhere if desired. For example, if
+you have a grep-like command on your system, you might define an alias
+for it like so: @samp{alias mygrep 'compile --mode=grep-mode -- mygrep
+$*'}.
+
@cmindex cp
-Copy a file to a new location or copy multiple files to the same
-directory.
+@item cp [@var{option}@dots{}] @var{source} @var{dest}
+@item cp [@var{option}@dots{}] @var{source}@dots{} @var{directory}
+Copy the file @var{source} to @var{dest} or @var{source} into
+@var{directory}.
@vindex eshell-cp-overwrite-files
@vindex eshell-cp-interactive-query
@@ -539,129 +612,253 @@ If @code{eshell-cp-overwrite-files} is non-@code{nil}, then
@code{eshell-cp-interactive-query} is non-@code{nil}, then
@command{cp} will ask before overwriting anything.
-@item date
+@command{cp} accepts the following options:
+
+@table @asis
+
+@item @code{-a}, @code{--archive}
+Equivalent to @code{--no-dereference --preserve --recursive}.
+
+@item @code{-d}, @code{--no-dereference}
+Don't dereference symbolic links when copying; instead, copy the link
+itself.
+
+@item @code{-f}, @code{--force}
+Never prompt for confirmation before copying a file.
+
+@item @code{-i}, @code{--interactive}
+Prompt for confirmation before copying a file if the target already
+exists.
+
+@item @code{-n}, @code{--preview}
+Run the command, but don't copy anything. This is useful if you
+want to preview what would be removed when calling @command{cp}.
+
+@item @code{-p}, @code{--preserve}
+Attempt to preserve file attributes when copying.
+
+@item @code{-r}, @code{-R}, @code{--recursive}
+Copy any specified directories and their contents recursively.
+
+@item @code{-v}, @code{--verbose}
+Print the name of each file before copying it.
+
+@end table
+
@cmindex date
+@item date [@var{specified-time} [@var{zone}]]
Print the current local time as a human-readable string. This command
-is similar to, but slightly different from, the GNU Coreutils
-@command{date} command.
+is an alias to the Emacs Lisp function @code{current-time-string}
+(@pxref{Time of Day,,, elisp, GNU Emacs Lisp Reference Manual}).
-@item diff
@cmindex diff
-Compare files using Emacs's internal @code{diff} (not to be confused
-with @code{ediff}). @xref{Comparing Files, , , emacs, The GNU Emacs
-Manual}.
+@item diff [@var{option}]@dots{} @var{old} @var{new}
+Compare the files @var{old} and @var{new} using Emacs's internal
+@code{diff} (not to be confused with @code{ediff}). @xref{Comparing
+Files, , , emacs, The GNU Emacs Manual}.
@vindex eshell-plain-diff-behavior
If @code{eshell-plain-diff-behavior} is non-@code{nil}, then this
command does not use Emacs's internal @code{diff}. This is the same
-as using @samp{alias diff '*diff $*'}.
+as using @samp{alias diff '*diff $@@*'}.
-@item dirname
@cmindex dirname
-Return the directory component of a file name.
+@item dirname @var{filename}
+Return the directory component of @var{filename}.
-@item dirs
@cmindex dirs
+@cindex directory stack, listing
+@item dirs
Prints the directory stack. Directories can be added or removed from
the stack using the commands @command{pushd} and @command{popd},
respectively.
-@item du
@cmindex du
-Summarize disk usage for each file.
+@item du [@var{option}]@dots{} @var{file}@dots{}
+Summarize disk usage for each file, recursing into directories.
+
+@command{du} accepts the following options:
+
+@table @asis
+
+@item @code{-a}, @code{--all}
+Print sizes for files, not just directories.
+
+@item @code{--block-size=@var{size}}
+Print sizes as number of blocks of size @var{size}.
+
+@item @code{-b}, @code{--bytes}
+Print file sizes in bytes.
+
+@item @code{-c}, @code{--total}
+Print a grand total of the sizes at the end.
+
+@item @code{-d}, @code{--max-depth=@var{depth}}
+Only print sizes for directories (or files with @code{--all}) that are
+@var{depth} or fewer levels below the command line arguments.
+
+@item @code{-h}, @code{--human-readable}
+Print sizes in human-readable format, with binary prefixes (so 1 KB is
+1024 bytes).
+
+@item @code{-H}, @code{--si}
+Print sizes in human-readable format, with decimal prefixes (so 1 KB
+is 1000 bytes).
+
+@item @code{-k}, @code{--kilobytes}
+Print file sizes in kilobytes (like @code{--block-size=1024}).
+
+@item @code{-L}, @code{--dereference}
+Follow symbolic links when traversing files.
+
+@item @code{-m}, @code{--megabytes}
+Print file sizes in megabytes (like @code{--block-size=1048576}).
+
+@item @code{-s}, @code{--summarize}
+Don't recurse into subdirectories (like @code{--max-depth=0}).
+
+@item @code{-x}, @code{--one-file-system}
+Skip any directories that reside on different filesystems.
+
+@end table
-@item echo
@cmindex echo
-Echoes its input. By default, this prints in a Lisp-friendly fashion
-(so that the value is useful to a Lisp command using the result of
-@command{echo} as an argument). If a single argument is passed,
-@command{echo} prints that; if multiple arguments are passed, it
-prints a list of all the arguments; otherwise, it prints the empty
-string.
+@item echo [-n | -N] [@var{arg}]@dots{}
+Prints the value of each @var{arg}. By default, this prints in a
+Lisp-friendly fashion (so that the value is useful to a Lisp command
+using the result of @command{echo} as an argument). If a single
+argument is passed, @command{echo} prints that; if multiple arguments
+are passed, it prints a list of all the arguments; otherwise, it
+prints the empty string.
@vindex eshell-plain-echo-behavior
If @code{eshell-plain-echo-behavior} is non-@code{nil}, @command{echo}
will try to behave more like a plain shell's @command{echo}, printing
each argument as a string, separated by a space.
-@item env
+You can control whether @command{echo} outputs a trailing newline
+using @code{-n} to disable the trailing newline (the default behavior)
+or @code{-N} to enable it (the default when
+@code{eshell-plain-echo-behavior} is non-@code{nil}).
+
@cmindex env
-Prints the current environment variables. Unlike in Bash, this
-command does not yet support running commands with a modified
-environment.
+@item env [@var{var}=@var{value}]@dots{} [@var{command}]@dots{}
+With no arguments, print the current environment variables. If you
+pass arguments to this command, then @command{env} will execute the
+arguments as a command. If you pass any initial arguments of the form
+@samp{@var{var}=@var{value}}, @command{env} will first set @var{var}
+to @var{value} before running the command.
-@item eshell-debug
@cmindex eshell-debug
+@item eshell-debug [error | form | process]@dots{}
Toggle debugging information for Eshell itself. You can pass this
-command the argument @code{errors} to enable/disable Eshell trapping
-errors when evaluating commands, or the argument @code{commands} to
-show/hide command execution progress in the buffer @code{*eshell last
-cmd*}.
+command one or more of the following arguments:
+
+@itemize @bullet
+
+@item
+@code{error}, to enable/disable Eshell trapping errors when
+evaluating commands;
+
+@item
+@code{form}, to show/hide Eshell command form manipulation in the
+buffer @code{*eshell last cmd*}; or
+
+@item
+@code{process}, to show/hide external process events in the buffer
+@code{*eshell last cmd*}.
+
+@end itemize
-@item exit
@cmindex exit
+@item exit
@vindex eshell-kill-on-exit
Exit Eshell and save the history. By default, this command kills the
Eshell buffer, but if @code{eshell-kill-on-exit} is @code{nil}, then
the buffer is merely buried instead.
-@item export
@cmindex export
+@item export [@var{name}=@var{value}]@dots{}
Set environment variables using input like Bash's @command{export}, as
in @samp{export @var{var1}=@var{val1} @var{var2}=@var{val2} @dots{}}.
-@item grep
@cmindex grep
-@itemx agrep
+@item grep [@var{arg}]@dots{}
@cmindex agrep
-@itemx egrep
+@itemx agrep [@var{arg}]@dots{}
@cmindex egrep
-@itemx fgrep
+@itemx egrep [@var{arg}]@dots{}
@cmindex fgrep
-@itemx glimpse
+@itemx fgrep [@var{arg}]@dots{}
+@cmindex rgrep
+@itemx rgrep [@var{arg}]@dots{}
@cmindex glimpse
+@itemx glimpse [@var{arg}]@dots{}
The @command{grep} commands are compatible with GNU @command{grep},
-but use Emacs's internal @code{grep} instead.
+but open a compilation buffer in @code{grep-mode} instead.
@xref{Grep Searching, , , emacs, The GNU Emacs Manual}.
@vindex eshell-plain-grep-behavior
If @code{eshell-plain-grep-behavior} is non-@code{nil}, then these
-commands do not use Emacs's internal @code{grep}. This is the same as
-using @samp{alias grep '*grep $*'}, though this setting applies to all
-of the built-in commands for which you would need to create a separate
-alias.
+commands do not use open a compilation buffer, instead printing output
+to Eshell's buffer. This is the same as using @samp{alias grep '*grep
+$@@*'}, though this setting applies to all of the built-in commands
+for which you would need to create a separate alias.
-@item history
@cmindex history
-Prints Eshell's input history. With a numeric argument @var{N}, this
-command prints the @var{N} most recent items in the history.
+@item history [@var{n}]
+@itemx history [-arw] [@var{filename}]
+Prints Eshell's input history. With a numeric argument @var{n}, this
+command prints the @var{n} most recent items in the history.
+Alternately, you can specify the following options:
+
+@table @asis
+
+@item @code{-a}, @code{--append}
+Append new history items to the history file.
+
+@item @code{-r}, @code{--read}
+Read history items from the history file and append them to the
+current shell's history.
+
+@item @code{-w}, @code{--write}
+Write the current history list to the history file.
+
+@end table
-@item info
@cmindex info
-Browse the available Info documentation. This command is the same as
-the external @command{info} command, but uses Emacs's internal Info
-reader.
-@xref{Misc Help, , , emacs, The GNU Emacs Manual}.
+@item info [@var{manual} [@var{item}]@dots{}]
+Browse the available Info documentation. With no arguments, browse
+the top-level menu. Otherwise, show the manual for @var{manual},
+selecting the menu entry for @var{item}.
+
+This command is the same as the external @command{info} command, but
+uses Emacs's internal Info reader. @xref{Misc Help, , , emacs, The
+GNU Emacs Manual}.
-@item jobs
@cmindex jobs
+@cindex processes, listing
+@item jobs
List subprocesses of the Emacs process, if any, using the function
@code{list-processes}.
-@item kill
@cmindex kill
+@cindex processes, signaling
+@item kill [-@var{signal}] [@var{pid} | @var{process}]
Kill processes. Takes a PID or a process object and an optional
-signal specifier which can either be a number or a signal name.
+@var{signal} specifier which can either be a number or a signal name.
-@item listify
@cmindex listify
-Eshell version of @code{list}. Allows you to create a list using Eshell
-syntax, rather than Elisp syntax. For example, @samp{listify foo bar}
-and @code{("foo" "bar")} both evaluate to @code{("foo" "bar")}.
+@item listify [@var{arg}]@dots{}
+Return the arguments as a single list. With a single argument, return
+it as-is if it's already a list, or otherwise wrap it in a list. With
+multiple arguments, return a list of all of them.
-@item ln
@cmindex ln
-Create links to files.
+@item ln [@var{option}]@dots{} @var{target} [@var{link-name}]
+@itemx ln [@var{option}]@dots{} @var{target}@dots{} @var{directory}
+Create a link to the specified @var{target} named @var{link-name} or
+create links to multiple @var{targets} in @var{directory}.
@vindex eshell-ln-overwrite-files
@vindex eshell-ln-interactive-query
@@ -670,8 +867,31 @@ will overwrite files without warning. If
@code{eshell-ln-interactive-query} is non-@code{nil}, then
@command{ln} will ask before overwriting files.
-@item locate
+@command{ln} accepts the following options:
+
+@table @asis
+
+@item @code{-f}, @code{--force}
+Never prompt for confirmation before linking a target.
+
+@item @code{-i}, @code{--interactive}
+Prompt for confirmation before linking to an item if the source
+already exists.
+
+@item @code{-n}, @code{--preview}
+Run the command, but don't move anything. This is useful if you
+want to preview what would be linked when calling @command{ln}.
+
+@item @code{-s}, @code{--symbolic}
+Make symbolic links instead of hard links.
+
+@item @code{-v}, @code{--verbose}
+Print the name of each file before linking it.
+
+@end table
+
@cmindex locate
+@item locate @var{arg}@dots{}
Alias to Emacs's @code{locate} function, which simply runs the external
@command{locate} command and parses the results.
@xref{Dired and Find, , , emacs, The GNU Emacs Manual}.
@@ -679,53 +899,131 @@ Alias to Emacs's @code{locate} function, which simply runs the external
@vindex eshell-plain-locate-behavior
If @code{eshell-plain-locate-behavior} is non-@code{nil}, then Emacs's
internal @code{locate} is not used. This is the same as using
-@samp{alias locate '*locate $*'}.
+@samp{alias locate '*locate $@@*'}.
-@item ls
@cmindex ls
-Lists the contents of directories.
+@item ls [@var{option}]@dots{} [@var{file}]@dots{}
+List information about each @var{file}, including the contents of any
+specified directories. If @var{file} is unspecified, list the
+contents of the current directory.
+
+@vindex eshell-ls-initial-args
+The user option @code{eshell-ls-initial-args} contains a list of
+arguments to include with any call to @command{ls}. For example, you
+can include the option @option{-h} to always use a more human-readable
+format.
@vindex eshell-ls-use-colors
If @code{eshell-ls-use-colors} is non-@code{nil}, the contents of a
directory is color-coded according to file type and status. These
colors and the regexps used to identify their corresponding files can
-be customized via @w{@kbd{M-x customize-group @key{RET} eshell-ls @key{RET}}}.
+be customized via @w{@kbd{M-x customize-group @key{RET} eshell-ls
+@key{RET}}}.
+
+@command{ls} supports the following options:
+
+@table @asis
+
+@item @code{-a}, @code{--all}
+List all files, including ones starting with @samp{.}.
+
+@item @code{-A}, @code{--almost-all}
+Like @code{--all}, but don't list the current directory (@file{.}) or
+the parent directory (@file{..}).
+
+@item @code{-c}, @code{--by-ctime}
+Sort files by last status change time, with newest files first.
+
+@item @code{-C}
+List entries by columns.
+
+@item @code{-d}, @code{--directory}
+List directory entries instead of their contents.
+
+@item @code{-h}, @code{--human-readable}
+Print sizes in human-readable format, with binary prefixes (so 1 KB is
+1024 bytes).
+
+@item @code{-H}, @code{--si}
+Print sizes in human-readable format, with decimal prefixes (so 1 KB
+is 1000 bytes).
+
+@item @code{-I@var{pattern}}, @code{--ignore=@var{pattern}}
+Don't list directory entries matching @var{pattern}.
+
+@item @code{-k}, @code{--kilobytes}
+Print sizes as 1024-byte kilobytes.
@vindex eshell-ls-date-format
-The user option @code{eshell-ls-date-format} determines how the date
-is displayed when using the @option{-l} option. The date is produced
-using the function @code{format-time-string} (@pxref{Time Parsing,,,
-elisp, GNU Emacs Lisp Reference Manual}).
+@item @code{-l}
+Use a long listing format showing details for each file. The user
+option @code{eshell-ls-date-format} determines how the date is
+displayed when using this option. The date is produced using the
+function @code{format-time-string} (@pxref{Time Parsing,,, elisp, GNU
+Emacs Lisp Reference Manual}).
-@vindex eshell-ls-initial-args
-The user option @code{eshell-ls-initial-args} contains a list of
-arguments to include with any call to @command{ls}. For example, you
-can include the option @option{-h} to always use a more human-readable
-format.
+@item @code{-L}, @code{--dereference}
+Follow symbolic links when listing entries.
+
+@item @code{-n}, @code{--numeric-uid-gid}
+Show UIDs and GIDs numerically, instead of using their names.
+
+@item @code{-r}, @code{--reverse}
+Reverse order when sorting.
+
+@item @code{-R}, @code{--recursive}
+List subdirectories recursively.
+
+@item @code{-s}, @code{--size}
+Show the size of each file in blocks.
@vindex eshell-ls-default-blocksize
-The user option @code{eshell-ls-default-blocksize} determines the
-default blocksize used when displaying file sizes with the option
-@option{-s}.
+@item @code{-S}
+Sort by file size, with largest files first. The user option
+@code{eshell-ls-default-blocksize} determines the default blocksize
+used when displaying file sizes with this option.
+
+@item @code{-t}
+Sort by modification time, with newest files first.
+
+@item @code{-u}
+Sort by last access time, with newest files first.
+
+@item @code{-U}
+Do not sort results. Instead, list entries in their directory order.
+
+@item @code{-x}
+List entries by lines instead of by columns.
+
+@item @code{-X}
+Sort alphabetically by file extension.
+
+@item @code{-1}
+List one file per line.
+
+@end table
-@item make
@cmindex make
+@item make [@var{arg}]@dots{}
Run @command{make} through @code{compile} when run asynchronously
(e.g., @samp{make &}). @xref{Compilation, , , emacs, The GNU Emacs
Manual}. Otherwise call the external @command{make} command.
-@item man
@cmindex man
+@item man [@var{arg}]@dots{}
Display Man pages using the Emacs @code{man} command.
@xref{Man Page, , , emacs, The GNU Emacs Manual}.
-@item mkdir
@cmindex mkdir
-Make new directories.
+@item mkdir [-p] @var{directory}@dots{}
+Make new directories. With @code{-p} or @code{--parents},
+automatically make any necessary parent directories as well.
-@item mv
@cmindex mv
-Move or rename files.
+@item mv [@var{option}]@dots{} @var{source} @var{dest}
+@itemx mv [@var{option}]@dots{} @var{source}@dots{} @var{directory}
+Rename the file @var{source} to @var{dest} or move @var{source} into
+@var{directory}.
@vindex eshell-mv-overwrite-files
@vindex eshell-mv-interactive-query
@@ -734,40 +1032,95 @@ will overwrite files without warning. If
@code{eshell-mv-interactive-query} is non-@code{nil}, @command{mv}
will prompt before overwriting anything.
-@item occur
+@command{mv} accepts the following options:
+
+@table @asis
+
+@item @code{-f}, @code{--force}
+Never prompt for confirmation before moving an item.
+
+@item @code{-i}, @code{--interactive}
+Prompt for confirmation before moving an item if the target already
+exists.
+
+@item @code{-n}, @code{--preview}
+Run the command, but don't move anything. This is useful if you
+want to preview what would be moved when calling @command{mv}.
+
+@item @code{-v}, @code{--verbose}
+Print the name of each item before moving it.
+
+@end table
+
@cmindex occur
+@item occur @var{regexp} [@var{nlines}]
Alias to Emacs's @code{occur}.
@xref{Other Repeating Search, , , emacs, The GNU Emacs Manual}.
-@item popd
@cmindex popd
+@cindex directory stack, removing from
+@item popd
+@item popd +@var{n}
Pop a directory from the directory stack and switch to a another place
-in the stack.
+in the stack. This command can take the following forms:
+
+@table @code
+
+@item popd
+Remove the current directory from the directory stack and change to
+the directory beneath it.
+
+@item popd +@var{n}
+Remove the current directory from the directory stack and change to
+the @var{nth} directory in the stack (counting from zero).
+
+@end table
-@item printnl
@cmindex printnl
-Print the arguments separated by newlines.
+@item printnl [@var{arg}]@dots{}
+Print all the @var{arg}s separated by newlines.
-@item pushd
@cmindex pushd
+@cindex directory stack, adding to
+@item pushd
+@itemx pushd @var{directory}
+@itemx pushd +@var{n}
Push the current directory onto the directory stack, then change to
-another directory.
+another directory. This command can take the following forms:
+
+@table @code
+
+@vindex eshell-pushd-tohome
+@item pushd
+Swap the current directory with the directory on the top of the stack.
+If @code{eshell-pushd-tohome} is non-@code{nil}, push the current
+directory onto the stack and change to the user's home directory (like
+@samp{pushd ~}).
@vindex eshell-pushd-dunique
+@item pushd @var{directory}
+Push the current directory onto the stack and change to
+@var{directory}. If @code{eshell-pushd-dunique} is non-@code{nil},
+then only unique directories will be added to the stack.
+
@vindex eshell-pushd-dextract
-If @code{eshell-pushd-dunique} is non-@code{nil}, then only unique
-directories will be added to the stack. If
-@code{eshell-pushd-dextract} is non-@code{nil}, then @samp{pushd
-+@var{n}} will pop the @var{n}th directory to the top of the stack.
+@item pushd +@var{n}
+Change to the @var{nth} directory in the directory stack (counting
+from zero), and ``rotate'' the stack by moving any elements before the
+@var{nth} to the bottom. If @code{eshell-pushd-dextract} is
+non-@code{nil}, then @samp{pushd +@var{n}} will instead pop the
+@var{n}th directory to the top of the stack.
+
+@end table
-@item pwd
@cmindex pwd
+@item pwd
Prints the current working directory.
-@item rm
@cmindex rm
+@item rm [@var{option}]@dots{} @var{item}@dots{}
Removes files, buffers, processes, or Emacs Lisp symbols, depending on
-the argument.
+the type of each @var{item}.
@vindex eshell-rm-interactive-query
@vindex eshell-rm-removes-directories
@@ -777,59 +1130,89 @@ will prompt before removing anything. If
@command{rm} can also remove directories. Otherwise, @command{rmdir}
is required.
-@item rmdir
+@command{rm} accepts the following options:
+
+@table @asis
+
+@item @code{-f}, @code{--force}
+Never prompt for confirmation before removing an item.
+
+@item @code{-i}, @code{--interactive}
+Prompt for confirmation before removing each item.
+
+@item @code{-n}, @code{--preview}
+Run the command, but don't remove anything. This is useful if you
+want to preview what would be removed when calling @command{rm}.
+
+@item @code{-r}, @code{-R}, @code{--recursive}
+Remove any specified directories and their contents recursively.
+
+@item @code{-v}, @code{--verbose}
+Print the name of each item before removing it.
+
+@end table
+
@cmindex rmdir
+@item rmdir @var{directory}@dots{}
Removes directories if they are empty.
-@item set
@cmindex set
+@item set [@var{var} @var{value}]@dots{}
Set variable values, using the function @code{set} like a command
(@pxref{Setting Variables,,, elisp, GNU Emacs Lisp Reference Manual}).
-A variable name can be a symbol, in which case it refers to a Lisp
-variable, or a string, referring to an environment variable
+The value of @var{var} can be a symbol, in which case it refers to a
+Lisp variable, or a string, referring to an environment variable
(@pxref{Arguments}).
-@item setq
@cmindex setq
+@item setq [@var{symbol} @var{value}]@dots{}
Set variable values, using the function @code{setq} like a command
(@pxref{Setting Variables,,, elisp, GNU Emacs Lisp Reference Manual}).
-@item source
@cmindex source
-Source an Eshell file in a subshell environment. This is not to be
-confused with the command @command{.}, which sources a file in the
-current environment.
+@item source @var{file} [@var{argument}]@dots{}
+Source an Eshell script named @var{file} in a subshell environment,
+passing any @var{argument}s to the script (@pxref{Scripts}). This is
+not to be confused with the command @command{.}, which sources a file
+in the current environment.
-@item time
@cmindex time
-Show the time elapsed during a command's execution.
+@item time @var{command}@dots{}
+Show the time elapsed during the execution of @var{command}.
-@item umask
@cmindex umask
-Set or view the default file permissions for newly created files and
-directories.
+@item umask [-S]
+@itemx umask @var{mode}
+View the default file permissions for newly created files and
+directories. If you pass @code{-S} or @code{--symbolic}, view the
+mode symbolically. With @var{mode}, set the default permissions to
+this value.
-@item unset
@cmindex unset
-Unset one or more variables. As with @command{set}, a variable name
-can be a symbol, in which case it refers to a Lisp variable, or a
-string, referring to an environment variable.
+@item unset [@var{var}]@dots{}
+Unset one or more variables. As with @command{set}, the value of
+@var{var} can be a symbol, in which case it refers to a Lisp variable,
+or a string, referring to an environment variable.
-@item wait
@cmindex wait
-Wait until a process has successfully completed.
+@cindex processes, waiting for
+@item wait [@var{process}]@dots{}
+Wait until each specified @var{process} has exited.
-@item which
@cmindex which
-Identify a command and its location.
+@item which @var{command}@dots{}
+For each @var{command}, identify what kind of command it is and its
+location.
-@item whoami
@cmindex whoami
-Print the current user. This Eshell version of @command{whoami}
-supports Tramp.
+@item whoami
+Print the current user. This Eshell version of @command{whoami} is
+connection-aware, so for remote directories, it will print the user
+associated with that connection.
@end table
-@subsection Defining new built-in commands
+@node Defining New Built-ins
+@subsection Defining New Built-in Commands
While Eshell can run Lisp functions directly as commands, it may be
more convenient to provide a special built-in command for
Eshell. Built-in commands are just ordinary Lisp functions designed
@@ -1011,12 +1394,28 @@ whenever you change the current directory to a different host
the value will automatically update to reflect the search path on that
host.
+@vindex $UID
+@item $UID
+This returns the effective @acronym{UID} for the current user. This
+variable is connection-aware, so when the current directory is remote,
+its value will be @acronym{UID} for the user associated with that
+remote connection.
+
+@vindex $GID
+@item $GID
+This returns the effective @acronym{GID} for the current user. Like
+@code{$UID}, this variable is connection-aware, so when the current
+directory is remote, its value will be @acronym{GID} for the user
+associated with that remote connection.
+
@vindex $_
@item $_
This refers to the last argument of the last command. With a
subscript, you can access any argument of the last command. For
example, @samp{$_[1]} refers to the second argument of the last
-command (excluding the command name itself).
+command (excluding the command name itself). To get all arguments of
+the last command, you can use an index range like @samp{$_[..]}
+(@pxref{Dollars Expansion}).
@vindex $$
@item $$
@@ -1050,6 +1449,13 @@ necessary. By default, its value is
@code{@var{emacs-version},eshell}. Other parts of Emacs, such as
Tramp, may add extra information to this value.
+@vindex $PAGER
+@item $PAGER
+This variable indicates the pager that commands should use when they
+wish to paginate long output. Its value is that of
+@code{comint-pager} if non-@code{nil}; otherwise, it uses the value of
+@code{$PAGER} from the @code{process-environment}.
+
@end table
@xref{Aliases}, for the built-in variables @samp{$*}, @samp{$1},
@@ -1058,28 +1464,51 @@ Tramp, may add extra information to this value.
@node Aliases
@section Aliases
-@vindex $*
+@findex eshell-read-aliases-list
@vindex eshell-aliases-file
Aliases are commands that expand to a longer input line. For example,
-@command{ll} is a common alias for @code{ls -l}, and would be defined
-with the command invocation @kbd{alias ll 'ls -l $*'}; with this defined,
-running @samp{ll foo} in Eshell will actually run @samp{ls -l foo}.
-Aliases defined (or deleted) by the @command{alias} command are
-automatically written to the file named by @code{eshell-aliases-file},
-which you can also edit directly (although you will have to manually
-reload it).
-
-@vindex $1, $2, @dots{}
+@command{ll} is a common alias for @code{ls -l}. To define this alias
+in Eshell, you can use the command invocation @kbd{alias ll 'ls -l
+$@@*'}; with this defined, running @samp{ll foo} in Eshell will
+actually run @samp{ls -l foo}. Aliases defined (or deleted) by the
+@command{alias} command are automatically written to the file named by
+@code{eshell-aliases-file}, which you can also edit directly. After
+doing so, use @w{@kbd{M-x eshell-read-aliases-list}} to load the
+edited aliases.
+
Note that unlike aliases in Bash, arguments must be handled
-explicitly. Typically the alias definition would end in @samp{$*} to
-pass all arguments along. More selective use of arguments via
-@samp{$1}, @samp{$2}, etc., is also possible. For example,
+explicitly. Within aliases, you can use the special variables
+@samp{$*}, @samp{$0}, @samp{$1}, @samp{$2}, etc. to refer to the
+arguments passed to the alias.
+
+@table @code
+
+@vindex $*
+@item $*
+This expands to the list of arguments passed to the alias. For
+example, if you run @code{my-alias 1 2 3}, then @samp{$*} would be the
+list @code{(1 2 3)}. Note that since this variable is a list, using
+@samp{$*} in an alias will pass this list as a single argument to the
+aliased command. Therefore, when defining an alias, you should
+usually use @samp{$@@*} to pass all arguments along, splicing them
+into your argument list (@pxref{Dollars Expansion}).
+
+@vindex $0
+@item $0
+This expands to the name of the alias currently being executed.
+
+@vindex $1, $2, @dots{}, $9
+@item $1, $2, @dots{}, $9
+These variables expand to the nth argument (starting at 1) passed to
+the alias. This lets you selectively use an alias's arguments, so
@kbd{alias mcd 'mkdir $1 && cd $1'} would cause @kbd{mcd foo} to
create and switch to a directory called @samp{foo}.
+@end table
+
@node Remote Access
@section Remote Access
-@cmindex remote access
+@cindex remote access
Since Eshell uses Emacs facilities for most of its functionality, you
can access remote hosts transparently. To connect to a remote host,
@@ -1102,6 +1531,18 @@ be careful about specifying absolute file names: @samp{cat
this behavior annoying, you can enable the optional electric forward
slash module (@pxref{Electric forward slash}).
+@vindex eshell-explicit-remote-commands
+When running commands, you can also make them explicitly remote by
+prefixing the command name with a remote identifier, e.g.@:
+@samp{/ssh:user@@remote:whoami}. This runs the command @code{whoami}
+over the SSH connection for @code{user@@remote}, no matter your
+current directory. If you want to explicitly run a @emph{local}
+command even when in a remote directory, you can prefix the command
+name with @kbd{/:}, like @samp{/:whoami}. In either case, you can
+also specify the absolute path to the program, e.g.@:
+@samp{/ssh:user@@remote:/usr/bin/whoami}. To disable this syntax, set
+the option @code{eshell-explicit-remote-commands} to @code{nil}.
+
@node History
@section History
@cmindex history
@@ -1126,11 +1567,20 @@ command containing @code{foo}. The n-th argument of the last command
beginning with @code{foo} is accessible by @code{!foo:n}.
@vindex eshell-history-file-name
-The history ring is loaded from a file at the start of every session,
-and written back to the file at the end of every session. The file path
-is specified in @code{eshell-history-file-name}. Unlike other shells,
-such as Bash, Eshell can not be configured to keep a history ring of a
-different size than that of the history file.
+@vindex eshell-history-append
+The history is loaded to the history ring from the file
+@code{eshell-history-file-name} at the start of every session, and
+saved to that file at the end of every session. The default history
+saving behavior is to overwrite the history file with the whole
+history ring of the session. If @code{eshell-history-append} is
+non-@code{nil}, the history will instead be saved by appending new
+entries from the session to the history file, which could prevent
+potential history loss with multiple Eshell sessions. Unlike other
+shells, such as Bash, Eshell cannot currently be configured to control
+the size of the history file. In particular, when
+@code{eshell-history-append} is non-@code{nil}, the size of the file
+will keep increasing, and the recommended way to truncate the file is
+to run the @samp{history -w} command in an Eshell session.
Since the default buffer navigation and searching key-bindings are
still present in the Eshell buffer, the commands for history
@@ -1231,6 +1681,11 @@ sequence of commands, as with almost any other shell script. Scripts
are invoked from Eshell with @command{source}, or from anywhere in Emacs
with @code{eshell-source-file}.
+Like with aliases (@pxref{Aliases}), Eshell scripts can accept any
+number of arguments. Within the script, you can refer to these with
+the special variables @code{$0}, @code{$1}, @dots{}, @code{$9}, and
+@code{$*}.
+
@cmindex .
If you wish to load a script into your @emph{current} environment,
rather than in a subshell, use the @code{.} command.
@@ -1282,9 +1737,15 @@ Concatenate the string representation of each value.
@node Dollars Expansion
@section Dollars Expansion
-Eshell has different @code{$} expansion syntax from other shells. There
-are some similarities, but don't let these lull you into a false sense
-of familiarity.
+Like in many other shells, you can use @code{$} expansions to insert
+various values into your Eshell invocations. While Eshell's @code{$}
+expansion syntax has some similarities to the syntax from other
+shells, there are also many differences. Don't let these similarities
+lull you into a false sense of familiarity.
+
+When using command form (@pxref{Invocation}), Eshell will ignore any
+leading nil values, so if @var{foo} is @code{nil}, @samp{$@var{foo}
+echo hello} is equivalent to @samp{echo hello}.
@table @code
@@ -1324,7 +1785,7 @@ As with @samp{$@{@var{command}@}}, evaluates the Eshell command invocation
@command{@var{command}}, but writes the output to a temporary file and
returns the file name.
-@item $@var{expr}[@var{i...}]
+@item $@var{expr}[@var{i@dots{}}]
Expands to the @var{i}th element of the result of @var{expr}, an
expression in one of the above forms listed here. If multiple indices
are supplied, this will return a list containing the elements for each
@@ -1335,11 +1796,24 @@ index. The exact behavior depends on the type of @var{expr}'s value:
@item a sequence
Expands to the element at the (zero-based) index @var{i} of the
sequence (@pxref{Sequences Arrays Vectors, , , elisp, The Emacs Lisp
-Reference Manual}).
+Reference Manual}). If @var{i} is negative, @var{i} counts from the
+end, so -1 refers to the last element of the sequence.
+
+If @var{i} is a range like @code{@var{start}..@var{end}}, this expands
+to a subsequence from the indices @var{start} to @var{end}, where
+@var{end} is excluded@footnote{This behavior is different from ranges
+in Bash (where both the start and end are included in the range), but
+matches the behavior of similar Emacs Lisp functions, like
+@code{substring} (@pxref{Creating Strings, , , elisp, The Emacs Lisp
+Reference Manual}).}. @var{start} and/or @var{end} can also be
+omitted, which is equivalent to the start and/or end of the entire
+list. For example, @samp{$@var{expr}[-2..]} expands to the last two
+values of @var{expr}.
@item a string
Split the string at whitespace, and then expand to the @var{i}th
-element of the resulting sequence.
+element of the resulting sequence. As above, @var{i} can be a range
+like @code{@var{start}..@var{end}}.
@item an alist
If @var{i} is a non-numeric value, expand to the value associated with
@@ -1360,18 +1834,42 @@ Multiple sets of indices can also be specified. For example, if
expand to @code{2}, i.e.@: the second element of the first list member
(all indices are zero-based).
-@item $@var{expr}[@var{regexp} @var{i...}]
+@item $@var{expr}[@var{regexp} @var{i@dots{}}]
As above (when @var{expr} expands to a string), but use @var{regexp}
to split the string. @var{regexp} can be any form other than a
number. For example, @samp{$@var{var}[: 0]} will return the first
element of a colon-delimited string.
+@cindex length operator, in variable expansion
@item $#@var{expr}
-Expands to the length of the result of @var{expr}, an expression in
-one of the above forms. For example, @samp{$#@var{var}} returns the
-length of the variable @var{var} and @samp{$#@var{var}[0]} returns the
-length of the first element of @var{var}. Again, signals an error if
-the result of @var{expr} is not a string or a sequence.
+This is the @dfn{length operator}. It expands to the length of the
+result of @var{expr}, an expression in one of the above forms. For
+example, @samp{$#@var{var}} returns the length of the variable
+@var{var} and @samp{$#@var{var}[0]} returns the length of the first
+element of @var{var}. Again, signals an error if the result of
+@var{expr} is not a string or a sequence.
+
+@cindex splice operator, in variable expansion
+@item $@@@var{expr}
+This is the @dfn{splice operator}. It ``splices'' the elements of
+@var{expr} (an expression of one of the above forms) into the
+resulting list of arguments, much like the @samp{,@@} marker in Emacs
+Lisp (@pxref{Backquote, , , elisp, The Emacs Lisp Reference Manual}).
+The elements of @var{expr} become arguments at the same level as the
+other arguments around it. For example, if @var{numbers} is the list
+@code{(1 2 3)}, then:
+
+@example
+@group
+~ $ echo 0 $numbers
+(0
+ (1 2 3))
+@end group
+@group
+~ $ echo 0 $@@numbers
+(0 1 2 3)
+@end group
+@end example
@end table
@@ -1383,12 +1881,22 @@ coming from Bash can still use Bash-style globbing, as there are no
incompatibilities.
@vindex eshell-glob-case-insensitive
-By default, globs are case sensitive, except on MS-DOS/MS-Windows
+Globs are case sensitive by default, 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
-@code{eshell-glob} (@pxref{Easy Customization, , , emacs, The GNU
-Emacs Manual}).
+@code{eshell-glob-case-insensitive} option.
+
+@vindex eshell-glob-splice-results
+By default, Eshell expands the results of a glob as a sublist into the
+list of arguments. You can change this to splice the results in-place
+by setting @code{eshell-glob-splice-results} to a non-@code{nil}
+value. If you want to splice a glob in-place for just one use, you
+can use a subcommand form like @samp{$@@@{listify @var{my-glob}@}}.
+(Conversely, you can explicitly expand a glob as a sublist via
+@samp{$@{listify @var{my-glob}@}}.)
+
+You can further customize the syntax and behavior of globbing in
+Eshell via the Customize group @code{eshell-glob} (@pxref{Easy
+Customization, , , emacs, The GNU Emacs Manual}).
@table @samp
@@ -1979,10 +2487,10 @@ mimic the bindings used in other shells when the user is editing new
input text. To enable this module, add @code{eshell-rebind} to
@code{eshell-modules-list}.
-For example, it binds @kbd{C-a} to move to the beginning of the input
-text, @kbd{C-u} to kill the current input text, and @kbd{C-w} to
-@code{backward-kill-word}. If the history module is enabled, it also
-binds @kbd{C-p} and @kbd{C-n} to move through the input history.
+For example, it binds @kbd{C-u} to kill the current input text and
+@kbd{C-w} to @code{backward-kill-word}. If the history module is
+enabled, it also binds @kbd{C-p} and @kbd{C-n} to move through the
+input history.
@vindex eshell-confine-point-to-input
If @code{eshell-confine-point-to-input} is non-@code{nil}, this module
@@ -2100,15 +2608,23 @@ external commands. To enable it, add @code{eshell-tramp} to
@table @code
-@item su
@cmindex su
-@itemx sudo
+@item su [- | -l] [@var{user}]
+Uses TRAMP's @command{su} method (@pxref{Inline methods, , , tramp,
+The Tramp Manual}) to change the current user to @var{user} (or root
+if unspecified). With @code{-}, @code{-l}, or @code{--login}, provide
+a login environment.
+
@cmindex sudo
-@itemx doas
+@item sudo [-u @var{user}] [-s | @var{command}@dots{}]
@cmindex doas
-Uses TRAMP's @command{su}, @command{sudo}, or @command{doas} method
-(@pxref{Inline methods, , , tramp, The Tramp Manual}) to run a command
-via @command{su}, @command{sudo}, or @command{doas}.
+@itemx doas [-u @var{user}] [-s | @var{command}@dots{}]
+Uses TRAMP's @command{sudo} or @command{doas} method (@pxref{Inline
+methods, , , tramp, The Tramp Manual}) to run @var{command} as root
+via @command{sudo} or @command{doas}. When specifying @code{-u
+@var{user}} or @code{--user @var{user}}, run the command as @var{user}
+instead. With @code{-s} or @code{--shell}, start a shell instead of
+running @var{command}.
@end table
@@ -2121,59 +2637,59 @@ add @code{eshell-xtra} to @code{eshell-modules-list}.
@table @code
-@item count
@cmindex count
+@item count @var{item} @var{seq} [@var{option}]@dots{}
A wrapper around the function @code{cl-count} (@pxref{Searching
Sequences,,, cl, GNU Emacs Common Lisp Emulation}). This command can
be used for comparing lists of strings.
-@item expr
@cmindex expr
+@item expr @var{str} [@var{separator}] [@var{arg}]@dots{}
An implementation of @command{expr} using the Calc package.
@xref{Top,,, calc, The GNU Emacs Calculator}.
-@item ff
@cmindex ff
+@item ff @var{directory} @var{pattern}
Shorthand for the the function @code{find-name-dired} (@pxref{Dired
and Find, , , emacs, The Emacs Editor}).
-@item gf
@cmindex gf
+@item gf @var{directory} @var{regexp}
Shorthand for the the function @code{find-grep-dired} (@pxref{Dired
and Find, , , emacs, The Emacs Editor}).
-@item intersection
@cmindex intersection
+@item intersection @var{list1} @var{list2} [@var{option}]@dots{}
A wrapper around the function @code{cl-intersection} (@pxref{Lists as
Sets,,, cl, GNU Emacs Common Lisp Emulation}). This command
can be used for comparing lists of strings.
-@item mismatch
@cmindex mismatch
+@item mismatch @var{seq1} @var{seq2} [@var{option}]@dots{}
A wrapper around the function @code{cl-mismatch} (@pxref{Searching
Sequences,,, cl, GNU Emacs Common Lisp Emulation}). This command can
be used for comparing lists of strings.
-@item set-difference
@cmindex set-difference
+@item set-difference @var{list1} @var{list2} [@var{option}]@dots{}
A wrapper around the function @code{cl-set-difference} (@pxref{Lists
as Sets,,, cl, GNU Emacs Common Lisp Emulation}). This command can be
used for comparing lists of strings.
-@item set-exclusive-or
@cmindex set-exclusive-or
+@item set-exclusive-or @var{list1} @var{list2} [@var{option}]@dots{}
A wrapper around the function @code{cl-set-exclusive-or} (@pxref{Lists
as Sets,,, cl, GNU Emacs Common Lisp Emulation}). This command can be
used for comparing lists of strings.
-@item substitute
@cmindex substitute
+@item substitute @var{new} @var{old} @var{seq} [@var{option}]@dots{}
A wrapper around the function @code{cl-substitute} (@pxref{Sequence
Functions,,, cl, GNU Emacs Common Lisp Emulation}). This command can
be used for comparing lists of strings.
-@item union
@cmindex union
+@item union @var{list1} @var{list2} [@var{option}]@dots{}
A wrapper around the function @code{cl-union} (@pxref{Lists as Sets,,,
cl, GNU Emacs Common Lisp Emulation}). This command can be used for
comparing lists of strings.
@@ -2236,7 +2752,7 @@ Allow for a Bash-compatible syntax, such as:
@example
alias arg=blah
-function arg () @{ blah $* @}
+function arg () @{ blah $@@* @}
@end example
@item Pcomplete sometimes gets stuck
@@ -2250,19 +2766,12 @@ This happens because the @code{grep} Lisp function returns immediately,
and then the asynchronous @command{grep} process expects to examine the
temporary file, which has since been deleted.
-@item Problem with C-r repeating text
-
-If the text @emph{before point} reads "./run", and you type @kbd{C-r r u
-n}, it will repeat the line for every character typed.
-
@item Backspace doesn't scroll back after continuing (in smart mode)
Hitting space during a process invocation, such as @command{make}, will
cause it to track the bottom of the output; but backspace no longer
scrolls back.
-@item It's not possible to fully @code{unload-feature} Eshell
-
@item Menu support was removed, but never put back
@item If an interactive process is currently running, @kbd{M-!} doesn't work
@@ -2309,21 +2818,12 @@ be Eshell's job?
This would be so that if a Lisp function calls @code{print}, everything
will happen as it should (albeit slowly).
-@item When an extension module fails to load, @samp{cd /} gives a Lisp error
-
-@item If a globbing pattern returns one match, should it be a list?
-
@item Make sure syntax table is correct in Eshell mode
So that @kbd{M-@key{DEL}} acts in a predictable manner, etc.
@item Allow all Eshell buffers to share the same history and list-dir
-@item There is a problem with script commands that output to @file{/dev/null}
-
-If a script file, somewhere in the middle, uses @samp{> /dev/null},
-output from all subsequent commands is swallowed.
-
@item Split up parsing of text after @samp{$} in @file{esh-var.el}
Make it similar to the way that @file{esh-arg.el} is structured.
@@ -2428,8 +2928,6 @@ A special associate array, which can take references of the form
@samp{$=[REGEXP]}. It indexes into the directory ring.
@end table
-@item Eshell scripts can't execute in the background
-
@item Support zsh's ``Parameter Expansion'' syntax, i.e., @samp{$@{@var{name}:-@var{val}@}}
@item Create a mode @code{eshell-browse}
@@ -2452,11 +2950,6 @@ If it's a Lisp function, input redirection implies @command{xargs} (in a
way@dots{}). If input redirection is added, also update the
@code{file-name-quote-list}, and the delimiter list.
-@item Allow @samp{#<@var{word} @var{arg}>} as a generic syntax
-
-With the handling of @emph{word} specified by an
-@code{eshell-special-alist}.
-
@item In @code{eshell-eval-using-options}, allow a @code{:complete} tag
It would be used to provide completion rules for that command. Then the
@@ -2528,13 +3021,6 @@ current being used.
This way, the user could change it to use rc syntax: @samp{>[2=1]}.
-@item Allow @samp{$_[-1]}, which would indicate the last element of the array
-
-@item Make @samp{$x[*]} equal to listing out the full contents of @samp{x}
-
-Return them as a list, so that @samp{$_[*]} is all the arguments of the
-last command.
-
@item Copy ANSI code handling from @file{term.el} into @file{em-term.el}
Make it possible for the user to send char-by-char to the underlying
@@ -2626,12 +3112,6 @@ Everywhere in Emacs where @code{shell-mode} is specially noticed, add
@item Permit the umask to be selectively set on a @command{cp} target
-@item Problem using @kbd{M-x eshell} after using @code{eshell-command}
-
-If the first thing that I do after entering Emacs is to run
-@code{eshell-command} and invoke @command{ls}, and then use @kbd{M-x
-eshell}, it doesn't display anything.
-
@item @kbd{M-@key{RET}} during a long command (using smart display) doesn't work
Since it keeps the cursor up where the command was invoked.
diff --git a/doc/misc/eww.texi b/doc/misc/eww.texi
index 564c320aafd..eec6b3c3299 100644
--- a/doc/misc/eww.texi
+++ b/doc/misc/eww.texi
@@ -92,9 +92,10 @@ searched via @code{eww-search-prefix}. The default search engine is
either prefix the file name with @code{file://} or use the command
@kbd{M-x eww-open-file}.
- If you invoke @code{eww} with a prefix argument, as in @w{@kbd{C-u
-M-x eww}}, it will create a new EWW buffer instead of reusing the
-default one, which is normally called @file{*eww*}.
+ If you invoke @code{eww} or @code{eww-open-file} with a prefix
+argument, as in @w{@kbd{C-u M-x eww}}, they will create a new EWW
+buffer instead of reusing the default one, which is normally called
+@file{*eww*}.
@findex eww-quit
@findex eww-reload
@@ -114,14 +115,30 @@ web page hit @kbd{g} (@code{eww-reload}).
@kbd{w} calls @code{eww-copy-page-url}, which will copy the current
page's URL to the kill ring instead.
+@findex eww-copy-alternate-url
+@kindex A
+ The @kbd{A} command (@code{eww-copy-alternate-url}) copies the URL
+of an alternate link on the current page into the kill ring. If the
+page specifies multiple alternate links, this command prompts for one
+of them in the minibuffer, with completion. Alternate links are
+references that an @acronym{HTML} page may include to point to other
+documents that act as its alternative representations. Notably,
+@acronym{HTML} pages can use alternate links to point to their
+translated versions and to @acronym{RSS} feeds. Alternate links
+appear in the @samp{<head>} section of @acronym{HTML} pages as
+@samp{<link>} elements with @samp{rel} attribute equal to
+@samp{``alternate''}; they are part of the page's metadata and are not
+visible in its rendered content.
+
@findex eww-open-in-new-buffer
@kindex M-RET
- The @kbd{M-@key{RET}} command (@code{eww-open-in-new-buffer}) opens the
-URL at point in a new EWW buffer, akin to opening a link in a new
-``tab'' in other browsers. When @code{global-tab-line-mode} is
-enabled, this buffer is displayed in the tab on the window tab line.
-When @code{tab-bar-mode} is enabled, a new tab is created on the frame
-tab bar.
+ The @kbd{M-@key{RET}} command (@code{eww-open-in-new-buffer}) opens
+the URL at point in a new EWW buffer, akin to opening a link in a new
+``tab'' in other browsers. If invoked with prefix argument, the
+command will not make the new buffer the current one. When
+@code{global-tab-line-mode} is enabled, this buffer is displayed in
+the tab on the window tab line. When @code{tab-bar-mode} is enabled,
+a new tab is created on the frame tab bar.
@findex eww-readable
@kindex R
@@ -129,6 +146,27 @@ tab bar.
which part of the document contains the ``readable'' text, and will
only display this part. This usually gets rid of menus and the like.
+ When called interactively, this command toggles the display of the
+readable parts. With a positive prefix argument, this command always
+displays the readable parts, and with a zero or negative prefix, it
+always displays the full page.
+
+@vindex eww-readable-urls
+ If you want EWW to render a certain page in ``readable'' mode by
+default, you can add a regular expression matching its URL to
+@code{eww-readable-urls}. Each entry can either be a regular expression
+in string form or a cons cell of the form
+@w{@code{(@var{regexp} . @var{readability})}}. If @var{readability} is
+non-@code{nil}, this behaves the same as the string form; otherwise,
+URLs matching @var{regexp} will never be displayed in readable mode by
+default. For example, you can use this to make all pages default to
+readable mode, except for a few outliers:
+
+@example
+(setq eww-readable-urls '(("https://example\\.com/" . nil)
+ ".*"))
+@end example
+
@findex eww-toggle-fonts
@vindex shr-use-fonts
@kindex F
@@ -175,6 +213,15 @@ history press @kbd{H} (@code{eww-list-histories}) to open the history
buffer @file{*eww history*}. The history is lost when EWW is quit.
If you want to remember websites you can use bookmarks.
+@vindex eww-before-browse-history-function
+ By default, when browsing to a new page from a ``historical'' one
+(i.e.@: a page loaded by navigating back via @code{eww-back-url}), EWW
+will first delete any history entries newer than the current page. This
+is the same behavior as most other web browsers. You can change this by
+customizing @code{eww-before-browse-history-function} to another value.
+For example, setting it to @code{ignore} will preserve the existing
+history entries and simply prepend the new page to the history list.
+
@vindex eww-history-limit
Along with the URLs visited, EWW also remembers both the rendered
page (as it appears in the buffer) and its source. This can take a
diff --git a/doc/misc/flymake.texi b/doc/misc/flymake.texi
index 124b5fde69e..84a74a9d6ab 100644
--- a/doc/misc/flymake.texi
+++ b/doc/misc/flymake.texi
@@ -1,8 +1,8 @@
\input texinfo @c -*- mode: texinfo; coding: utf-8 -*-
@comment %**start of header
@setfilename ../../info/flymake.info
-@set VERSION 1.2.2
-@set UPDATED November 2021
+@set VERSION 1.3.4
+@set UPDATED April 2023
@settitle GNU Flymake @value{VERSION}
@include docstyle.texi
@syncodeindex pg cp
@@ -65,10 +65,6 @@ The Emacs LSP Client} Flymake is also designed to be easily extended
to support new backends via an Elisp interface. @xref{Extending
Flymake}.
-Historically, Flymake used to accept diagnostics from a single
-backend. Although obsolete, it is still functional. To learn how to
-use and customize it, @pxref{The legacy Proc backend}.
-
@ifnottex
@insertcopying
@end ifnottex
@@ -149,6 +145,12 @@ highlighted regions to learn what the specific problem
is. Alternatively, place point on the highlighted regions and use the
commands @code{eldoc} or @code{display-local-help}.
+Another easy way to get instant access to the diagnostic text is to
+set @code{flymake-show-diagnostics-at-end-of-line} to a non-@code{nil}
+value. This makes the diagnostic messages appear at the end of the
+line where the regular annotation is located (@pxref{Customizable
+variables})
+
@cindex next and previous diagnostic
If the diagnostics are outside the visible region of the buffer,
@code{flymake-goto-next-error} and @code{flymake-goto-prev-error} are
@@ -321,6 +323,22 @@ Which fringe (if any) should show the warning/error bitmaps.
@item flymake-wrap-around
If non-@code{nil}, moving to errors with @code{flymake-goto-next-error} and
@code{flymake-goto-prev-error} wraps around buffer boundaries.
+
+@item flymake-show-diagnostics-at-end-of-line
+If non-@code{nil}, show summarized descriptions of diagnostics at the
+end of the line. Depending on your preference, this can either be
+distracting and easily confused with actual code, or a significant
+early aid that relieves you from moving around or reaching for the
+mouse to consult an error message.
+
+@item flymake-error-eol
+A custom face for summarizing diagnostic error messages.
+
+@item flymake-warning-eol
+A custom face for summarizing diagnostic warning messages.
+
+@item flymake-note-eol
+A custom face for summarizing diagnostic notes.
@end vtable
@node Extending Flymake
@@ -401,7 +419,7 @@ its @code{flymake-overlay-control} property:
@item
@cindex severity of diagnostic
-@code{flymake-severity} is a non-negative integer specifying the
+@code{severity} is a non-negative integer specifying the
diagnostic's severity. The higher the value, the more serious is the
error. If the overlay property @code{priority} is not specified in
@code{flymake-overlay-control}, @code{flymake-severity} is used to set
@@ -416,6 +434,17 @@ type, in case the name of the symbol associated with it is very long.
@vindex flymake-category
@code{flymake-category} is a symbol whose property list is considered
the default for missing values of any other properties.
+
+@item
+@cindex mode-line appearance of a diagnostic
+@code{mode-line-face} is a face specifier controlling the appearance
+of the indicator of this type of diagnostic in the mode line.
+
+@item
+@cindex summarized appearance of a diagnostic
+@code{echo-face} is a face specifier controlling the appearance of the
+summarized description of this diagnostic when reading diagnostic
+messages (@pxref{Finding diagnostics}).
@end itemize
@cindex predefined diagnostic types
diff --git a/doc/misc/gnus.texi b/doc/misc/gnus.texi
index 232bb9ded3b..419a5390374 100644
--- a/doc/misc/gnus.texi
+++ b/doc/misc/gnus.texi
@@ -5832,10 +5832,11 @@ message to the mailing list, and include the original message
@kindex S v @r{(Summary)}
@findex gnus-summary-very-wide-reply
Mail a very wide reply to the author of the current article
-(@code{gnus-summary-very-wide-reply}). A @dfn{very wide reply} is a reply
-that goes out to all people listed in the @code{To}, @code{From} (or
-@code{Reply-To}) and @code{Cc} headers in all the process/prefixed
-articles. This command uses the process/prefix convention.
+(@code{gnus-summary-very-wide-reply}). A @dfn{very wide reply} is a
+reply that goes out to all people listed in the @code{To}, @code{From}
+(or @code{Reply-To}) and @code{Cc} headers in all the process/prefixed
+articles. This command uses the process/prefix convention. If given a
+prefix argument, the body of the current article will also be yanked.
@item S V
@kindex S V @r{(Summary)}
@@ -5868,15 +5869,23 @@ original message but ignore the @code{Reply-To} field
@findex gnus-summary-mail-forward
@c @icon{gnus-summary-mail-forward}
Forward the current article to some other person
-(@code{gnus-summary-mail-forward}). If no prefix is given, the message
-is forwarded according to the value of (@code{message-forward-as-mime})
-and (@code{message-forward-show-mml}); if the prefix is 1, decode the
-message and forward directly inline; if the prefix is 2, forward message
-as an rfc822 @acronym{MIME} section; if the prefix is 3, decode message and
-forward as an rfc822 @acronym{MIME} section; if the prefix is 4, forward message
-directly inline; otherwise, the message is forwarded as no prefix given
-but use the flipped value of (@code{message-forward-as-mime}). By
-default, the forwarded message is inlined into the mail.
+(@code{gnus-summary-mail-forward}). If no prefix is given, the
+message is forwarded according to the value of
+(@code{message-forward-as-mime}) and
+(@code{message-forward-show-mml}); if the prefix is 1, decode the
+message and forward directly inline; if the prefix is 2, forward
+message as an rfc822 @acronym{MIME} section; if the prefix is 3,
+decode message and forward as an rfc822 @acronym{MIME} section; if the
+prefix is 4, forward message directly inline; otherwise, the message
+is forwarded as no prefix given but use the negated value of
+(@code{message-forward-as-mime}). By default, the forwarded message
+is inlined into the mail.
+
+Which headers from the original message are included in the forwarded
+message is determined by options specific to @code{message-mode},
+@pxref{Forwarding,,, message}. In addition, this command can be given
+the symbolic prefix @samp{a}, using @kbd{M-i a}, to include most original
+headers.
@item S m
@itemx m
@@ -6235,13 +6244,6 @@ Presumably, you want to use the demon for sending due delayed articles.
Just don't forget to set that up :-)
@end table
-When delaying an article with @kbd{C-c C-j}, Message mode will
-automatically add a @code{"Date"} header with the current time. In
-many cases you probably want the @code{"Date"} header to reflect the
-time the message is sent instead. To do this, you have to delete
-@code{Date} from @code{message-draft-headers}.
-
-
@node Marking Articles
@section Marking Articles
@cindex article marking
@@ -10527,9 +10529,9 @@ article (@code{gnus-summary-refer-references}).
@kindex A T @r{(Summary)}
Display the full thread where the current article appears
(@code{gnus-summary-refer-thread}). By default this command looks for
-articles only in the current group. Some backends (currently only
-@code{nnimap}) know how to find articles in the thread directly. In
-other cases each header in the current group must be fetched and
+articles only in the current group. If the group belongs to a backend
+that has an associated search engine, articles are found by searching.
+In other cases each header in the current group must be fetched and
examined, so it usually takes a while. If you do it often, you may
consider setting @code{gnus-fetch-old-headers} to @code{invisible}
(@pxref{Filling In Threads}). This won't have any visible effects
@@ -10537,19 +10539,22 @@ normally, but it'll make this command work a whole lot faster. Of
course, it'll make group entry somewhat slow.
@vindex gnus-refer-thread-use-search
-If @code{gnus-refer-thread-use-search} is non-@code{nil} then those backends
-that know how to find threads directly will search not just in the
-current group but all groups on the same server.
+If @code{gnus-refer-thread-use-search} is @code{nil} (the default)
+then thread-referral only looks for articles in the current group. If
+this variable is @code{t} the server to which the current group
+belongs is searched (provided that searching is available for the
+server's backend). If this variable is a list of servers, each server
+in the list is searched.
@vindex gnus-refer-thread-limit
The @code{gnus-refer-thread-limit} variable says how many old (i.e.,
articles before the first displayed in the current group) headers to
-fetch when doing this command. The default is 200. If @code{t}, all
-the available headers will be fetched. This variable can be overridden
-by giving the @kbd{A T} command a numerical prefix.
+fetch when referring a thread. The default is 500. If @code{t}, all
+the available headers will be fetched. This variable can be
+overridden by giving the @kbd{A T} command a numerical prefix.
@vindex gnus-refer-thread-limit-to-thread
-In most cases @code{gnus-refer-thread} adds any articles it finds to
+@code{gnus-summary-refer-thread} tries to add any articles it finds to
the current summary buffer. (When @code{gnus-refer-thread-use-search}
is true and the initial referral starts from a summary buffer for a
non-virtual group this may not be possible. In this case a new
@@ -25473,7 +25478,7 @@ There is no specific spam or ham processor for regular expressions.
@defvar spam-use-bogofilter
-Set this variable if you want @code{spam-split} to use Eric Raymond's
+Set this variable if you want @code{spam-split} to use Eric S. Raymond's
speedy Bogofilter.
With a minimum of care for associating the @samp{$} mark for spam
@@ -25505,7 +25510,7 @@ Get the Bogofilter spamicity score (@code{spam-bogofilter-score}).
@defvar spam-use-bogofilter-headers
-Set this variable if you want @code{spam-split} to use Eric Raymond's
+Set this variable if you want @code{spam-split} to use Eric S. Raymond's
speedy Bogofilter, looking only at the message headers. It works
similarly to @code{spam-use-bogofilter}, but the @code{X-Bogosity} header
must be in the message already. Normally you would do this with a
@@ -26431,12 +26436,12 @@ lines:
(setq gnus-refer-article-method
'(current
(nnregistry)
- (nnweb "gmane" (nnweb-type gmane))))
+ (nnweb "google" (nnweb-type google))))
@end example
The example above instructs Gnus to first look up the article in the
current group, or, alternatively, using the registry, and finally, if
-all else fails, using Gmane.
+all else fails, using Google.
@node Fancy splitting to parent
@subsection Fancy splitting to parent
@@ -26690,9 +26695,12 @@ buffers. It is enabled with
@table @kbd
@item C-c C-m C-a
@findex gnus-dired-attach
+@vindex gnus-dired-attach-at-end
@cindex attachments, selection via dired
Send dired's marked files as an attachment (@code{gnus-dired-attach}).
-You will be prompted for a message buffer.
+The function prompts for a message buffer, and by default attaches files
+to the end of that buffer; customize @code{gnus-dired-attach-at-end} to
+place the attachments at point instead.
@item C-c C-m C-l
@findex gnus-dired-find-file-mailcap
diff --git a/doc/misc/idlwave.texi b/doc/misc/idlwave.texi
index 46610678bda..782812169ca 100644
--- a/doc/misc/idlwave.texi
+++ b/doc/misc/idlwave.texi
@@ -3186,7 +3186,7 @@ the expression printed by IDL.
@defopt idlwave-shell-output-face
The face for @code{idlwave-shell-output-overlay}.
-Allows to choose the font, color and other properties for the most
+Allows you to choose the font, color and other properties for the most
recent output of IDL when examining an expression."
@end defopt
diff --git a/doc/misc/message.texi b/doc/misc/message.texi
index fefa6a769a1..d881244c735 100644
--- a/doc/misc/message.texi
+++ b/doc/misc/message.texi
@@ -1948,11 +1948,9 @@ requires the @acronym{POP}-before-@acronym{SMTP} authentication.
@cindex X-Message-SMTP-Method
If you have a complex @acronym{SMTP} setup, and want some messages to
go via one mail server, and other messages to go through another, you
-can use the @samp{X-Message-SMTP-Method} header. These are the
-supported values:
-
-@table @samp
-@item smtpmail
+can use the @samp{X-Message-SMTP-Method} header to override the
+default by using the keyword @samp{smtp} followed by the server
+information:
@example
X-Message-SMTP-Method: smtp smtp.fsf.org 587
@@ -1968,16 +1966,19 @@ This is the same as the above, but uses @samp{other-user} as the user
name when authenticating. This is handy if you have several
@acronym{SMTP} accounts on the same server.
-@item sendmail
+This header may also be used to specify an alternative MTA by using a
+@samp{mailer} keyword, where @samp{mailer} is the name of an MTA with
+a corresponding @code{message-send-mail-with-'mailer'} function. For
+example:
@example
X-Message-SMTP-Method: sendmail
@end example
-This will send the message via the locally installed sendmail/exim/etc
-installation.
+will send the message via the locally installed sendmail program. The
+recognized values of @samp{mailer} are sendmail, qmail, mh, and
+mailclient.
-@end table
@item message-mh-deletable-headers
@vindex message-mh-deletable-headers
diff --git a/doc/misc/mh-e.texi b/doc/misc/mh-e.texi
index 6b60db93f3b..3e98a14ecfc 100644
--- a/doc/misc/mh-e.texi
+++ b/doc/misc/mh-e.texi
@@ -793,7 +793,7 @@ You should see the scan line for your message, and perhaps others. Use
@cartouche
@smallexample
- 3 t08/24 root received fax files on Wed Aug 24 11:00:13 PDT 1
+ 3 t08/24 root received fax files on Wed Aug 24 11:00:13 -0700 1
# 4+t08/24 To:wohler Test<<This is a test message to get the wheels
-:%% @{+inbox/select@} 4 msgs (1-4) Bot L4 (MH-Folder Show)---------
@@ -1479,7 +1479,6 @@ Binding} of @samp{m}.
@cindex @command{emacsclient}
@cindex @command{xbuffy}
-@cindex @samp{gnuserv}
@cindex Unix commands, @command{emacsclient}
@cindex Unix commands, @command{xbuffy}
@@ -8920,7 +8919,7 @@ Bill Wohler, August 2008
@c LocalWords: Baushke Bcc BBN Beranek bogofilter bogofilter's
@c LocalWords: cmd CMU contrib cron
@c LocalWords: DesBrisay Dcc devel dir dired docstring filll forw
-@c LocalWords: GECOS Gildea Gildea's Ginnean GnuCash goto gnuserv htm
+@c LocalWords: GECOS Gildea Gildea's Ginnean GnuCash goto htm
@c LocalWords: ImageMagick inbox ispell keychain
@c LocalWords: Larus licensor LocalWords lookup lpr
@c LocalWords: makeinfo mairix mbox mh mhbuild mhl mhpath mlisp
diff --git a/doc/misc/modus-themes.org b/doc/misc/modus-themes.org
index 72a4413e8df..c3de15c35ad 100644
--- a/doc/misc/modus-themes.org
+++ b/doc/misc/modus-themes.org
@@ -4,9 +4,9 @@
#+language: en
#+options: ':t toc:nil author:t email:t num:t
#+startup: content
-#+macro: stable-version 3.0.0
-#+macro: release-date 2022-10-28
-#+macro: development-version 3.1.0-dev
+#+macro: stable-version 4.4.0
+#+macro: release-date 2024-03-17
+#+macro: development-version 4.5.0-dev
#+macro: file @@texinfo:@file{@@$1@@texinfo:}@@
#+macro: space @@texinfo:@: @@
#+macro: kbd @@texinfo:@kbd{@@$1@@texinfo:}@@
@@ -21,21 +21,26 @@
#+texinfo: @insertcopying
-This manual, written by Protesilaos Stavrou, describes the customization
-options for the ~modus-operandi~ and ~modus-vivendi~ themes, and provides
-every other piece of information pertinent to them.
+This manual, written by Protesilaos Stavrou, describes the
+customization options for the Modus themes, and provides every other
+piece of information pertinent to them.
The documentation furnished herein corresponds to stable version
-{{{stable-version}}}, released on {{{release-date}}}. Any reference to a newer
-feature which does not yet form part of the latest tagged commit, is
-explicitly marked as such.
+{{{stable-version}}}, released on {{{release-date}}}. Any reference
+to a newer feature which does not yet form part of the latest tagged
+commit, is explicitly marked as such.
Current development target is {{{development-version}}}.
-+ Homepage: https://protesilaos.com/emacs/modus-themes.
-+ Git repository: https://git.sr.ht/~protesilaos/modus-themes.
-+ Mailing list: https://lists.sr.ht/~protesilaos/modus-themes.
-+ Backronym: My Old Display Unexpectedly Sharpened ... themes
++ Package name (GNU ELPA): ~modus-themes~
++ Official manual: <https://protesilaos.com/emacs/modus-themes>
++ Change log: <https://protesilaos.com/emacs/modus-themes-changelog>
++ Color palette: <https://protesilaos.com/emacs/modus-themes-colors>
++ Sample pictures: <https://protesilaos.com/emacs/modus-themes-pictures>
++ Git repositories:
+ + GitHub: <https://github.com/protesilaos/modus-themes>
+ + GitLab: <https://gitlab.com/protesilaos/modus-themes>
++ Backronym: My Old Display Unexpectedly Sharpened ... themes.
#+toc: headlines 8 insert TOC here, with eight headline levels
@@ -64,43 +69,53 @@ modify this GNU manual.”
:custom_id: h:f0f3dbcb-602d-40cf-b918-8f929c441baf
:end:
-The Modus themes are designed for accessible readability. They conform
-with the highest standard for color contrast between any given
-combination of background and foreground values. This corresponds to
-the WCAG AAA standard, which specifies a minimum rate of distance in
-relative luminance of 7:1.
-
-Modus Operandi (~modus-operandi~) is a light theme, while Modus Vivendi
-(~modus-vivendi~) is dark. Each theme's color palette is designed to meet
-the needs of the numerous interfaces that are possible in the Emacs
-computing environment.
-
-The overarching objective of this project is to always offer accessible
-color combinations. There shall never be a compromise on this
-principle. If there arises an inescapable trade-off between readability
-and stylistic considerations, we will always opt for the former.
+The Modus themes are designed for accessible readability. They
+conform with the highest standard for color contrast between
+combinations of background and foreground values. For small sized
+text, this corresponds to the WCAG AAA standard, which specifies a
+minimum rate of distance in relative luminance of 7:1.
+
+The Modus themes consist of eight themes, divided into four subgroups.
+
+- Main themes :: ~modus-operandi~ is the project's main light theme,
+ while ~modus-vivendi~ is its dark counterpart. These two themes are
+ part of the project since its inception. They are designed to cover
+ a broad range of needs and are, in the opinion of the author, the
+ reference for what a highly legible "default" theme should look
+ like.
+
+- Tinted themes :: ~modus-operandi-tinted~ and ~modus-vivendi-tinted~
+ are variants of the two main themes. They slightly tone down the
+ intensity of the background and provide a bit more color variety.
+ ~modus-operandi-tinted~ has a set of base tones that are shades of
+ light ochre (earthly colors), while ~modus-vivendi-tinted~ gives a
+ night sky impression.
+
+- Deuteranopia themes :: ~modus-operandi-deuteranopia~ and its
+ companion ~modus-vivendi-deuteranopia~ are optimized for users with
+ red-green color deficiency. This means that they do not use red and
+ green hues for color-coding purposes, such as for diff removed and
+ added lines. Instead, they implement colors that are discernible by
+ users with deueteranopia or deuteranomaly (mostly yellow and blue
+ hues).
+
+- Tritanopia themes :: ~modus-operandi-tritanopia~ and its counterpart
+ ~modus-vivendi-tritanopia~ are optimized for users with blue-yellow
+ color deficiency. The idea is the same as with the deuteranopia
+ variants: color coding relies only on hues that are accessible to
+ people with tritanopia or tritanomaly, namely, shades of red and
+ cyan.
To ensure that users have a consistently accessible experience, the
-themes strive to achieve as close to full face coverage as possible
+themes strive to achieve as close to full face coverage as possible,
+while still targeting a curated list of well-maintained packages
([[#h:a9c8f29d-7f72-4b54-b74b-ddefe15d6a19][Face coverage]]).
-Furthermore, the themes are designed to empower users with red-green
-color deficiency (deuteranopia). This is achieved in three ways:
-
-1. The conformance with the highest legibility standard means that text
- is always readable no matter the perception of its hue.
-
-2. Most contexts use colors on the blue-cyan-magenta-purple side of the
- spectrum. Put differently, green and/or red are seldom used, thus
- minimizing the potential for confusion.
-
- [[#h:0b26cb47-9733-4cb1-87d9-50850cb0386e][Why are colors mostly variants of blue, magenta, cyan?]].
-
-3. In contexts where a red/green color-coding is unavoidable, we provide
- a universal toggle to customize the themes so that a red/blue scheme
- is used instead.
-
- [[#h:3ed03a48-20d8-4ce7-b214-0eb7e4c79abe][Option for red-green color deficiency or deuteranopia]].
+The overarching objective of this project is to always offer
+accessible color combinations. There shall never be a compromise on
+this principle. If there arises an inescapable trade-off between
+usability and stylistic considerations, we will always opt for the
+former.
Starting with version 0.12.0 and onwards, the themes are built into GNU
Emacs.
@@ -111,12 +126,8 @@ Emacs.
:end:
#+cindex: Screenshots
-Check the web page with [[https://protesilaos.com/emacs/modus-themes-pictures/][the screen shots]]. There are lots of scenarios
-on display that draw attention to details and important aspects in the
-design of the themes. They also showcase the numerous customization
-options.
-
-[[#h:bf1c82f2-46c7-4eb2-ad00-dd11fdd8b53f][Customization options]].
+Check the web page with [[https://protesilaos.com/emacs/modus-themes-pictures/][the screen shots]]. Note that the themes are
+highly customizable ([[#h:bf1c82f2-46c7-4eb2-ad00-dd11fdd8b53f][Customization options]]).
** Learn about the latest changes
:properties:
@@ -137,14 +148,21 @@ On older versions of Emacs, they can be installed using Emacs' package
manager or manually from their code repository. There also exist
packages for distributions of GNU/Linux.
+Emacs 28 ships with ~modus-themes~ version =1.6.0=. Emacs 29 includes
+version =3.0.0=. Emacs 30 provides a newer, refactored version that
+thoroughly refashions how the themes are implemented and customized.
+Such major versions are not backward-compatible due to the limited
+resources at the maintainer's disposal to support multiple versions of
+Emacs and of the themes across the years.
+
** Install manually from source
:properties:
:custom_id: h:da3414b7-1426-46b8-8e76-47b845b76fd0
:end:
In the following example, we are assuming that your Emacs files are
-stored in =~/.emacs.d= and that you want to place the Modus themes in
-=~/.emacs.d/modus-themes=.
+stored in {{{file(~/.emacs.d)}}} and that you want to place the Modus
+themes in {{{file(~/.emacs.d/modus-themes)}}}.
1. Get the source and store it in the desired path by running the
following in the command line shell:
@@ -218,17 +236,17 @@ They are now ready to be used: [[#h:3f3c3728-1b34-437d-9d0c-b110f5b161a9][Enable
:custom_id: h:e6268471-e847-4c9d-998f-49a83257b7f1
:end:
-From time to time, we receive bug reports pertaining to errors with byte
-compilation. These seldom have to do with faulty code in the themes: it
-might be a shortcoming of =package.el=, some regression in the current
-development target of Emacs, a misconfiguration in an otherwise exotic
-setup, and the like.
+From time to time, we receive bug reports pertaining to errors with
+byte compilation. These seldom have to do with faulty code in the
+themes: it might be a shortcoming of {{{file(package.el)}}}, some
+regression in the current development target of Emacs, a
+misconfiguration in an otherwise exotic setup, and the like.
The common solution with a stable version of Emacs is to:
-1. Delete the =modus-themes= package.
+1. Delete the ~modus-themes~ package.
2. Close the current Emacs session.
-3. Install the =modus-themes= again.
+3. Install the ~modus-themes~ again.
For those building Emacs directly from source, the solution may involve
reverting to an earlier commit in emacs.git.
@@ -245,101 +263,139 @@ wrong.
:properties:
:custom_id: h:3f3c3728-1b34-437d-9d0c-b110f5b161a9
:end:
-#+findex: modus-themes-load-themes
-#+findex: modus-themes-toggle
-#+findex: modus-themes-load-operandi
-#+findex: modus-themes-load-vivendi
#+cindex: Essential configuration
-#+vindex: modus-themes-after-load-theme-hook
+
+NOTE that Emacs can load multiple themes, which typically produces
+undesirable results and undoes the work of the designer. Use the
+~disable-theme~ command if you are trying other themes beside the
+Modus collection ([[#h:adb0c49a-f1f9-4690-868b-013a080eed68][Option for disabling other themes while loading Modus]]).
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:
+because there is no package to speak of. Instead, things are simpler
+as built-in themes are considered safe. 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
+Remember that there are multiple Modus themes ([[#h:f0f3dbcb-602d-40cf-b918-8f929c441baf][Overview]]). Adapt the
+above snippet accordingly.
+
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:
+main library before loading one of the themes:
#+begin_src emacs-lisp
(require 'modus-themes)
#+end_src
-Then it is recommended to load the individual theme files with the
-helper function ~modus-themes-load-themes~:
+One can activate a theme with something like the following expression,
+replacing ~modus-operandi~ with their preferred Modus theme:
#+begin_src emacs-lisp
-;; Load the theme files before enabling a theme (else you get an error).
-(modus-themes-load-themes)
-#+end_src
-
-Once the libraries that define the themes are enabled, one can activate
-a theme with either of the following expressions:
-
-#+begin_src emacs-lisp
-(modus-themes-load-operandi) ; Light theme
-;; OR
-(modus-themes-load-vivendi) ; Dark theme
+(load-theme 'modus-operandi :no-confirm)
#+end_src
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 optionally
-automatically reload the theme ([[#h:9001527a-4e2c-43e0-98e8-3ef72d770639][Option for inhibiting theme reload]]).
+before loading a theme ([[#h:bf1c82f2-46c7-4eb2-ad00-dd11fdd8b53f][Customization Options]]). Reload a theme for
+new changes to take effect.
-This is how a basic setup could look like:
+This is how a basic setup could look like ([[#h:b66b128d-54a4-4265-b59f-4d1ea2feb073][The require-theme for built-in Emacs themes]]):
#+begin_src emacs-lisp
-;;; For the built-in themes which cannot use `require':
-;; Add all your customizations prior to loading the themes
+;;; For the built-in themes which cannot use `require'.
+(require-theme 'modus-themes)
+
+;; 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))
+ modus-themes-bold-constructs nil)
-;; Load the theme of your choice:
-(load-theme 'modus-operandi) ;; OR (load-theme 'modus-vivendi)
+;; Load the theme of your choice.
+(load-theme 'modus-operandi)
+;; Optionally define a key to switch between Modus themes. Also check
+;; the user option `modus-themes-to-toggle'.
(define-key global-map (kbd "<f5>") #'modus-themes-toggle)
-;;; For packaged versions which must use `require':
+;;; For packaged versions which must use `require'.
+
(require 'modus-themes)
;; 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
-(modus-themes-load-themes)
+ modus-themes-bold-constructs nil)
-;; Load the theme of your choice:
-(modus-themes-load-operandi) ;; OR (modus-themes-load-vivendi)
+;; Load the theme of your choice.
+(load-theme 'modus-operandi :no-confirm)
(define-key global-map (kbd "<f5>") #'modus-themes-toggle)
#+end_src
[[#h:e979734c-a9e1-4373-9365-0f2cd36107b8][Sample configuration with and without use-package]].
-With those granted, bear in mind a couple of technical points on
-~modus-themes-load-operandi~ and ~modus-themes-load-vivendi~, as well as
-~modus-themes-toggle~ which relies on them:
+To disable other themes before loading a Modus theme, use something
+like this:
+
+#+begin_src emacs-lisp
+(mapc #'disable-theme custom-enabled-themes)
+(load-theme 'modus-operandi :no-confirm)
+#+end_src
+
+#+findex: modus-themes-load-theme
+Instead of using the basic ~load-theme~ function, users can rely on
+the ~modus-themes-load-theme~. It accepts a single argument, which is
+a symbol representing the Modus theme of choice, such as:
-1. Those functions call ~load-theme~. Some users prefer to opt for
- ~enable-theme~ instead ([[#h:e68560b3-7fb0-42bc-a151-e015948f8a35][Differences between loading and enabling]]).
+#+begin_src emacs-lisp
+(modus-themes-load-theme 'modus-operandi)
+#+end_src
+
+#+vindex: modus-themes-after-load-theme-hook
+#+vindex: modus-themes-post-load-hook
+The ~modus-themes-load-theme~ takes care to disable other themes, if
+the user opts in ([[#h:adb0c49a-f1f9-4690-868b-013a080eed68][Option for disabling other themes while loading Modus]]).
+After loading the theme of choice, this function calls the
+hook ~modus-themes-after-load-theme-hook~ (alias ~modus-themes-post-load-hook~).
+Users can add their own functions to this hook to make further
+customizations ([[#h:f4651d55-8c07-46aa-b52b-bed1e53463bb][Advanced customization]]).
+
+#+findex: modus-themes-toggle
+#+findex: modus-themes-select
+The commands ~modus-themes-toggle~ and ~modus-themes-select~ use
+~modus-themes-load-theme~ internally ([[#h:4fbfed66-5a89-447a-a07d-a03f6819c5bd][Option for which themes to toggle]]).
+The aforementioned hold true for them as well.
+
+** The ~require-theme~ for built-in Emacs themes
+:PROPERTIES:
+:CUSTOM_ID: h:b66b128d-54a4-4265-b59f-4d1ea2feb073
+:END:
+
+The version of the Modus themes that is included in Emacs CANNOT use
+the standard ~require~. This is because the built-in themes are not
+included in the ~load-path~ (not my decision). The ~require-theme~
+function must be used in this case as a replacement. For example:
+
+#+begin_src emacs-lisp
+(require-theme 'modus-themes)
-2. The functions will run the ~modus-themes-after-load-theme-hook~ as
- their final step. This can be employed for bespoke configurations
- ([[#h:f4651d55-8c07-46aa-b52b-bed1e53463bb][Advanced customization]]). Experienced users may not wish to rely on
- such a hook and the functions that run it: they may prefer a custom
- solution ([[#h:86f6906b-f090-46cc-9816-1fe8aeb38776][A theme-agnostic hook for theme loading]]).
+;; All customizations here
+(setq modus-themes-bold-constructs t
+ modus-themes-italic-constructs t)
+
+;; Maybe define some palette overrides, such as by using our presets
+(setq modus-themes-common-palette-overrides
+ modus-themes-preset-overrides-intense)
+
+;; Load the theme of choice (built-in themes are always "safe" so they
+;; do not need the `no-require' argument of `load-theme').
+(load-theme 'modus-operandi)
+
+(define-key global-map (kbd "<f5>") #'modus-themes-toggle)
+#+end_src
** Sample configuration with and without use-package
:properties:
@@ -348,70 +404,66 @@ With those granted, bear in mind a couple of technical points on
#+cindex: use-package configuration
#+cindex: sample configuration
+What follows is a variant of what we demonstrate in the previous
+section ([[#h:3f3c3728-1b34-437d-9d0c-b110f5b161a9][Enable and load]]).
+
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':
+;;; For the built-in themes which cannot use `require'.
(use-package emacs
- :init
+ :config
+ (require-theme 'modus-themes) ; `require-theme' is ONLY for the built-in Modus themes
+
;; 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 ("<f5>" . modus-themes-toggle))
+ modus-themes-bold-constructs nil)
+
+ ;; Maybe define some palette overrides, such as by using our presets
+ (setq modus-themes-common-palette-overrides
+ modus-themes-preset-overrides-intense)
+
+ ;; Load the theme of your choice.
+ (load-theme 'modus-operandi)
+
+ (define-key global-map (kbd "<f5>") #'modus-themes-toggle))
-;;; For packaged versions which must use `require':
+;;; For packaged versions which must use `require'.
(use-package modus-themes
- :ensure
- :init
+ :ensure t
+ :config
;; 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))
+ modus-themes-bold-constructs nil)
- ;; Load the theme files before enabling a theme
- (modus-themes-load-themes)
- :config
- ;; Load the theme of your choice:
- (modus-themes-load-operandi) ;; OR (modus-themes-load-vivendi)
- :bind ("<f5>" . modus-themes-toggle))
+ ;; Maybe define some palette overrides, such as by using our presets
+ (setq modus-themes-common-palette-overrides
+ modus-themes-preset-overrides-intense)
+
+ ;; Load the theme of your choice.
+ (load-theme 'modus-operandi)
+
+ (define-key global-map (kbd "<f5>") #'modus-themes-toggle))
#+end_src
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 "<f5>") #'modus-themes-toggle)
-
-
-
-;;; For packaged versions which must use `require':
-(require 'modus-themes)
+(require 'modus-themes) ; OR for the built-in themes: (require-theme 'modus-themes)
;; 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))
+ modus-themes-bold-constructs nil)
-;; Load the theme files before enabling a theme
-(modus-themes-load-themes)
+;; Maybe define some palette overrides, such as by using our presets
+(setq modus-themes-common-palette-overrides
+ modus-themes-preset-overrides-intense)
;; Load the theme of your choice:
-(modus-themes-load-operandi) ;; OR (modus-themes-load-vivendi)
+(load-theme 'modus-operandi :no-confirm)
(define-key global-map (kbd "<f5>") #'modus-themes-toggle)
#+end_src
@@ -433,8 +485,8 @@ package declaration of the themes.
The reason we recommend ~load-theme~ instead of the other option of
~enable-theme~ is that the former does a kind of "reset" on the face
specs. It quite literally loads (or reloads) the theme. Whereas the
-latter simply puts an already loaded theme at the top of the list of
-enabled items, re-using whatever state was last loaded.
+~enable-theme~ function simply puts an already loaded theme to the top
+of the list of enabled items, re-using whatever state was last loaded.
As such, ~load-theme~ reads all customizations that may happen during
any given Emacs session: even after the initial setup of a theme.
@@ -453,10 +505,13 @@ session, are better off using something like this:
#+begin_src emacs-lisp
(require 'modus-themes)
+
+;; Activate your desired themes here
(load-theme 'modus-operandi t t)
(load-theme 'modus-vivendi t t)
-(enable-theme 'modus-operandi) ;; OR (enable-theme 'modus-vivendi)
+;; Enable the preferred one
+(enable-theme 'modus-operandi)
#+end_src
[[#h:b40aca50-a3b2-4c43-be58-2c26fcd14237][Toggle themes without reloading them]].
@@ -467,198 +522,128 @@ With the above granted, other sections of the manual discuss how to
configure custom faces, where ~load-theme~ is expected, though
~enable-theme~ could still apply in stable setups:
-[[#h:1487c631-f4fe-490d-8d58-d72ffa3bd474][Case-by-case face specs using the themes' palette]].
+[[#h:51ba3547-b8c8-40d6-ba5a-4586477fd4ae][Use theme colors in code with modus-themes-with-colors]].
-[[#h:51ba3547-b8c8-40d6-ba5a-4586477fd4ae][Face specs at scale using the themes' palette]].
-
-* Customization Options
+* Customization options
:properties:
:custom_id: h:bf1c82f2-46c7-4eb2-ad00-dd11fdd8b53f
:end:
The Modus themes are highly configurable, though they should work well
-without any further tweaks. By default, all customization options are
-set to nil, unless otherwise noted in this manual.
+without any further tweaks. We provide a variety of user options.
+The following code block provides an overview. In addition to those
+variables, the themes support a comprehensive system of overrides: it
+can be used to make thoroughgoing changes to the looks of the themes
+([[#h:34c7a691-19bb-4037-8d2f-67a07edab150][Option for palette overrides]]). We document everything at length in
+the pages of this manual and also provide ready-to-use code samples.
Remember that all customization options must be evaluated before loading
a theme ([[#h:3f3c3728-1b34-437d-9d0c-b110f5b161a9][Enable and load]]). If the theme is already active, it must be
-reloaded for changes in user options to come into force.
-
-Below is a summary of what you will learn in the subsequent sections of
-this manual.
+reloaded for changes to take effect.
#+begin_src emacs-lisp
+;; In all of the following, WEIGHT is a symbol such as `semibold',
+;; `light', `bold', or anything mentioned in `modus-themes-weights'.
(setq modus-themes-italic-constructs t
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-mixed-fonts t
modus-themes-variable-pitch-ui nil
- modus-themes-inhibit-reload t ; only applies to `customize-set-variable' and related
-
- modus-themes-fringes nil ; {nil,'subtle,'intense}
-
- ;; Options for `modus-themes-lang-checkers' are either nil (the
- ;; default), or a list of properties that may include any of those
- ;; symbols: `straight-underline', `text-also', `background',
- ;; `intense' OR `faint'.
- modus-themes-lang-checkers nil
-
- ;; Options for `modus-themes-mode-line' are either nil, or a list
- ;; that can combine any of `3d' OR `moody', `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',
- ;; `intense'.
- modus-themes-markup '(background italic)
-
- ;; Options for `modus-themes-syntax' are either nil (the default),
- ;; or a list of properties that may include any of those symbols:
- ;; `faint', `yellow-comments', `green-strings', `alt-syntax'
- modus-themes-syntax nil
-
- ;; Options for `modus-themes-hl-line' are either nil (the default),
- ;; or a list of properties that may include any of those symbols:
- ;; `accented', `underline', `intense'
- modus-themes-hl-line '(underline accented)
-
- ;; Options for `modus-themes-paren-match' are either nil (the
- ;; default), or a list of properties that may include any of those
- ;; symbols: `bold', `intense', `underline'
- modus-themes-paren-match '(bold intense)
-
- ;; Options for `modus-themes-links' are either nil (the default),
- ;; or a list of properties that may include any of those symbols:
- ;; `neutral-underline' OR `no-underline', `faint' OR `no-color',
- ;; `bold', `italic', `background'
- modus-themes-links '(neutral-underline background)
-
- ;; 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', `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)
+ modus-themes-custom-auto-reload t
+ modus-themes-disable-other-themes t
;; Options for `modus-themes-prompts' are either nil (the
;; default), or a list of properties that may include any of those
- ;; symbols: `background', `bold', `gray', `intense', `italic'
- modus-themes-prompts '(intense bold)
+ ;; symbols: `italic', `WEIGHT'
+ modus-themes-prompts '(italic bold)
- ;; The `modus-themes-completions' is an alist that reads three
- ;; keys: `matches', `selection', `popup'. Each accepts a nil
- ;; value (or empty list) or a list of properties that can include
- ;; any of the following (for WEIGHT read further below):
+ ;; The `modus-themes-completions' is an alist that reads two
+ ;; keys: `matches', `selection'. Each accepts a nil value (or
+ ;; empty list) or a list of properties that can include any of
+ ;; the following (for WEIGHT read further below):
;;
- ;; `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)
- ;;
- ;; WEIGHT is a symbol such as `semibold', `light', or anything
- ;; covered in `modus-themes-weights'. Bold is used in the absence
- ;; of an explicit WEIGHT.
- modus-themes-completions '((matches . (extrabold))
- (selection . (semibold accented))
- (popup . (accented intense)))
-
- modus-themes-mail-citations nil ; {nil,'intense,'faint,'monochrome}
-
- ;; Options for `modus-themes-region' are either nil (the default),
- ;; or a list of properties that may include any of those symbols:
- ;; `no-extend', `bg-only', `accented'
- modus-themes-region '(bg-only no-extend)
-
- ;; Options for `modus-themes-diffs': nil, 'desaturated, 'bg-only
- modus-themes-diffs 'desaturated
+ ;; `matches' :: `underline', `italic', `WEIGHT'
+ ;; `selection' :: `underline', `italic', `WEIGHT'
+ modus-themes-completions
+ '((matches . (extrabold))
+ (selection . (semibold italic text-also)))
modus-themes-org-blocks 'gray-background ; {nil,'gray-background,'tinted-background}
- modus-themes-org-agenda ; this is an alist: read the manual or its doc string
- '((header-block . (variable-pitch 1.3))
- (header-date . (grayscale workaholic bold-today 1.1))
- (event . (accented varied))
- (scheduled . uniform)
- (habit . traffic-light))
+ ;; The `modus-themes-headings' is an alist: read the manual's
+ ;; node about it or its doc string. Basically, it supports
+ ;; per-level configurations for the optional use of
+ ;; `variable-pitch' typography, a height value as a multiple of
+ ;; the base font size (e.g. 1.5), and a `WEIGHT'.
+ modus-themes-headings
+ '((1 . (variable-pitch 1.5))
+ (2 . (1.3))
+ (agenda-date . (1.3))
+ (agenda-structure . (variable-pitch light 1.8))
+ (t . (1.1))))
- modus-themes-headings ; this is an alist: read the manual or its doc string
- '((1 . (overline background variable-pitch 1.3))
- (2 . (rainbow overline 1.1))
- (t . (semibold))))
+;; Remember that more (MUCH MORE) can be done with overrides, which we
+;; document extensively in this manual.
#+end_src
-** Option for inhibiting theme reload
+** Option for reloading the theme on custom change
:properties:
:alt_title: Custom reload theme
:description: Toggle auto-reload of the theme when setting custom variables
:custom_id: h:9001527a-4e2c-43e0-98e8-3ef72d770639
:end:
-#+vindex: modus-themes-inhibit-reload
+#+vindex: modus-themes-custom-auto-reload
Brief: Toggle reloading of the active theme when an option is changed
-through the Customize UI.
+through the Custom UI.
-Symbol: ~modus-themes-inhibit-reload~ (=boolean= type)
+Symbol: ~modus-themes-custom-auto-reload~ (=boolean= type)
Possible values:
1. ~nil~
2. ~t~ (default)
-By default, customizing a theme-related user option through the Custom
-interfaces or with {{{kbd(M-x customize-set-variable)}}} will not reload the
-currently active Modus theme.
+All theme user options take effect when a theme is loaded. Any
+subsequent changes require the theme to be reloaded.
-Enable this behavior by setting this variable to ~nil~.
+When this variable has a non-~nil~ value, any change made via the Custom
+UI or related functions such as ~customize-set-variable~ and ~setopt~
+(Emacs 29), will trigger a reload automatically.
-Regardless of this option, the active theme must be reloaded for changes
-to user options to take effect ([[#h:3f3c3728-1b34-437d-9d0c-b110f5b161a9][Enable and load]]).
+With a ~nil~ value, changes to user options have no further consequences:
+the user must manually reload the theme ([[#h:3f3c3728-1b34-437d-9d0c-b110f5b161a9][Enable and load]]).
-** Option for red-green color deficiency or deuteranopia
+** Option for disabling other themes while loading Modus
:properties:
-:alt_title: Deuteranopia style
-:description: Toggle red/blue color-coding instead of red/green
-:custom_id: h:3ed03a48-20d8-4ce7-b214-0eb7e4c79abe
+:alt_title: Disable other themes
+:description: Determine whether loading a Modus themes disables all others
+:custom_id: h:adb0c49a-f1f9-4690-868b-013a080eed68
:end:
-#+vindex: modus-themes-deuteranopia
+#+vindex: modus-themes-disable-other-themes
-Brief: When non-~nil~ use red/blue color-coding instead of red/green,
-where appropriate.
+Brief: Disable all other themes when loading a Modus theme.
-Symbol: ~modus-themes-deuteranopia~ (=boolean= type)
+Symbol: ~modus-themes-disable-other-themes~ (=boolean= type)
Possible values:
-1. ~nil~ (default)
-2. ~t~
+1. ~nil~
+2. ~t~ (default)
-This is to account for red-green color deficiency, also know as
-deuteranopia and variants. It applies to all contexts where there can
-be a color-coded distinction between failure or success, a to-do or done
-state, a mark for deletion versus a mark for selection (e.g. in Dired),
-current and lazily highlighted search matches, removed lines in diffs as
-opposed to added ones, and so on.
+When the value is non-~nil~, the commands ~modus-themes-toggle~ and
+~modus-themes-select~, as well as the ~modus-themes-load-theme~
+function, will disable all other themes while loading the specified
+Modus theme ([[#h:4fbfed66-5a89-447a-a07d-a03f6819c5bd][Option for which themes to toggle]]). This is done to
+ensure that Emacs does not blend two or more themes: such blends lead
+to awkward results that undermine the work of the designer.
-Note that this does not change all colors throughout the active theme,
-but only applies to cases that have color-coding significance. For
-example, regular code syntax highlighting is not affected. There is no
-such need because of the themes' overarching commitment to the highest
-legibility standard, which ensures that text is readable regardless of
-hue, as well as the predominance of colors on the
-blue-cyan-magenta-purple side of the spectrum.
+When the value is ~nil~, the aforementioned commands and function will
+only disable other themes within the Modus collection.
-[[#h:0b26cb47-9733-4cb1-87d9-50850cb0386e][Why are colors mostly variants of blue, magenta, cyan?]].
+This option is provided because Emacs themes are not necessarily
+limited to colors/faces: they can consist of an arbitrary set of
+customizations. Users who use such customization bundles must set
+this variable to a ~nil~ value.
** Option for more bold constructs
:properties:
@@ -680,9 +665,9 @@ Possible values:
The default is to use a bold typographic weight only when it is
required.
-With a non-~nil~ value (~t~) display several syntactic constructs in bold
-weight. This concerns keywords and other important aspects of code
-syntax. It also affects certain mode line indicators and command-line
+With a non-~nil~ value (~t~) display several syntactic constructs in
+bold weight. This concerns keywords and other important aspects of
+code syntax. It also affects certain mode line indicators and command
prompts.
Advanced users may also want to configure the exact attributes of the
@@ -718,69 +703,31 @@ Advanced users may also want to configure the exact attributes of the
[[#h:2793a224-2109-4f61-a106-721c57c01375][Configure bold and italic faces]].
-** Option for syntax highlighting
-:properties:
-:alt_title: Syntax styles
-:description: Choose the overall aesthetic of code syntax
-:custom_id: h:c119d7b2-fcd4-4e44-890e-5e25733d5e52
-:end:
-#+vindex: modus-themes-syntax
-
-Brief: Set the overall style of code syntax highlighting.
-
-Symbol: ~modus-themes-syntax~ (=choice= type, list of properties)
-
-Possible values are expressed as a list of properties (default is ~nil~ or
-an empty list). The list can include any of the following symbols:
-
-+ ~faint~
-+ ~yellow-comments~
-+ ~green-strings~
-+ ~alt-syntax~
-
-The default (a ~nil~ value or an empty list) is to use a balanced
-combination of colors on the cyan-blue-magenta side of the spectrum.
-There is little to no use of greens, yellows, and reds. Comments are
-gray, strings are blue colored, doc strings are a shade of cyan, while
-color combinations are designed to avoid exaggerations.
-
-The property ~faint~ fades the saturation of all applicable colors, where
-that is possible or appropriate.
-
-The property ~yellow-comments~ applies a yellow color to comments.
-
-The property ~green-strings~ applies a green color to strings and a green
-tint to doc strings.
-
-The property ~alt-syntax~ changes the combination of colors beyond strings
-and comments, so that the effective palette is broadened to provide
-greater variety relative to the default.
-
-Combinations of any of those properties are expressed as a list, like in
-these examples:
+** Option for which themes to toggle
+:PROPERTIES:
+:CUSTOM_ID: h:4fbfed66-5a89-447a-a07d-a03f6819c5bd
+:END:
+#+vindex: modus-themes-to-toggle
-#+begin_src emacs-lisp
-(faint)
-(green-strings yellow-comments)
-(alt-syntax green-strings yellow-comments)
-(faint alt-syntax green-strings yellow-comments)
-#+end_src
+Brief: Choose to Modus themes to toggle between
-The order in which the properties are set is not significant.
+Symbol: ~modus-themes-to-toggle~ (=list= type)
-In user configuration files the form may look like this:
+Default value: ='(modus-operandi modus-vivendi)=
-#+begin_src emacs-lisp
-(setq modus-themes-syntax '(faint alt-syntax))
-#+end_src
-
-Independent of this variable, users may also control the use of a bold
-weight or italic text: ~modus-themes-bold-constructs~ and
-~modus-themes-italic-constructs~.
+Possible values:
-[[#h:b25714f6-0fbe-41f6-89b5-6912d304091e][Option for more bold constructs]].
+- ~modus-operandi~
+- ~modus-vivendi~
+- ~modus-operandi-tinted~
+- ~modus-vivendi-tinted~
+- ~modus-operandi-deuteranopia~
+- ~modus-vivendi-deuteranopia~
+- ~modus-operandi-tritanopia~
+- ~modus-vivendi-tritanopia~
-[[#h:977c900d-0d6d-4dbb-82d9-c2aae69543d6][Option for more italic constructs]].
+Specify two themes to toggle between using the command
+~modus-themes-toggle~.
** Option for font mixing
:properties:
@@ -805,76 +752,62 @@ tables and code blocks to always inherit from the ~fixed-pitch~ face.
This is to ensure that certain constructs like code blocks and tables
remain monospaced even when users opt for a mode that remaps typeface
families, such as the built-in {{{kbd(M-x variable-pitch-mode)}}}. Otherwise
-the layout would appear broken, due to how spacing is done.
+the layout can appear broken, due to how spacing is done.
For a consistent experience, user may need to specify the font family of
the ~fixed-pitch~ face.
[[#h:defcf4fc-8fa8-4c29-b12e-7119582cc929][Font configurations for Org and others]].
-Furthermore, users may prefer to use another package for handling mixed
-typeface configurations, rather than letting the theme do it, perhaps
-because a purpose-specific package has extra functionality. Two
-possible options are ~org-variable-pitch~ and ~mixed-pitch~.
-
-** Option for links
+** Option for command prompt styles
:properties:
-:alt_title: Link styles
-:description: Choose among several styles, with or without underline
-:custom_id: h:5808be52-361a-4d18-88fd-90129d206f9b
+:alt_title: Command prompts
+:description: Control the style of command prompts
+:custom_id: h:db5a9a7c-2928-4a28-b0f0-6f2b9bd52ba1
:end:
-#+vindex: modus-themes-links
+#+vindex: modus-themes-prompts
-Brief: Control the style of links to web pages, files, buffers...
+Brief: Control the style of command prompts (e.g. minibuffer, shell, IRC
+clients).
-Symbol: ~modus-themes-links~ (=choice= type, list of properties)
+Symbol: ~modus-themes-prompts~ (=choice= type, list of properties)
Possible values are expressed as a list of properties (default is ~nil~ or
an empty list). The list can include any of the following symbols:
-+ Underline style:
- - ~neutral-underline~
- - ~no-underline~
-+ Text coloration:
- - ~faint~
- - ~no-color~
-+ ~bold~
+ ~italic~
-+ ~background~
-
-The default (a ~nil~ value or an empty list) is a prominent text color,
-typically blue, with an underline of the same color.
-
-For the style of the underline, a ~neutral-underline~ property turns the
-color of the line into a subtle gray, while the ~no-underline~ property
-removes the line altogether. If both of those are set, the latter takes
-precedence.
-
-For text coloration, a ~faint~ property desaturates the color of the text
-and the underline, unless the underline is affected by the
-aforementioned properties. While a ~no-color~ property removes the color
-from the text. If both of those are set, the latter takes precedence.
-
-A ~bold~ property applies a heavy typographic weight to the text of the
-link.
++ ~italic~
++ A font weight, which must be supported by the underlying typeface:
+ - ~thin~
+ - ~ultralight~
+ - ~extralight~
+ - ~light~
+ - ~semilight~
+ - ~regular~
+ - ~medium~
+ - ~semibold~
+ - ~bold~
+ - ~heavy~
+ - ~extrabold~
+ - ~ultrabold~
-An ~italic~ property adds a slant to the link's text (italic or oblique
-forms, depending on the typeface).
+The default (a ~nil~ value or an empty list) means to only use a subtle
+colored foreground color.
-A ~background~ property applies a subtle tinted background color.
+The ~italic~ property adds a slant to the font's forms (italic or
+oblique forms, depending on the typeface).
-In case both ~no-underline~ and ~no-color~ are set, then a subtle gray
-background is applied to all links. This can still be combined with the
-~bold~ and ~italic~ properties.
+The symbol of a font weight attribute such as ~light~, ~semibold~, et
+cetera, adds the given weight to links. Valid symbols are defined in
+the variable ~modus-themes-weights~. The absence of a weight means
+that the one of the underlying text will be used.
-Combinations of any of those properties are expressed as a list,
-like in these examples:
+Combinations of any of those properties are expressed as a list, like in
+these examples:
#+begin_src emacs-lisp
-(faint)
-(no-underline faint)
-(no-color no-underline bold)
-(italic bold background no-color no-underline)
+(bold italic)
+(italic semibold)
#+end_src
The order in which the properties are set is not significant.
@@ -882,158 +815,181 @@ The order in which the properties are set is not significant.
In user configuration files the form may look like this:
#+begin_src emacs-lisp
-(setq modus-themes-links '(neutral-underline background))
+(setq modus-themes-prompts '(extrabold italic))
#+end_src
-The placement of the underline, meaning its proximity to the text, is
-controlled by ~x-use-underline-position-properties~,
-~x-underline-at-descent-line~, ~underline-minimum-offset~. Please refer to
-their documentation strings.
+[[#h:bd75b43a-0bf1-45e7-b8b4-20944ca8b7f8][Make prompts more or less colorful]].
-** Option for box buttons
+** Option for completion framework aesthetics
:properties:
-:alt_title: Box buttons
-:description: Choose among several styles for buttons
-:custom_id: h:8b85f711-ff40-45b0-b7fc-4727503cd2ec
+:alt_title: Completion UIs
+:description: Choose among several styles for completion UIs
+:custom_id: h:f1c20c02-7b34-4c35-9c65-99170efb2882
:end:
-#+vindex: modus-themes-box-buttons
-
-Brief: Control the style of buttons in the Custom UI and related.
+#+vindex: modus-themes-completions
-Symbol: ~modus-themes-box-buttons~ (=choice= type, list of properties)
+Brief: Set the overall style of completion framework interfaces.
-Possible values are expressed as a list of properties (default is ~nil~ or
-an empty list). The list can include any of the following symbols:
+Symbol: ~modus-themes-completions~ (=alist= type properties)
-+ ~flat~
-+ ~accented~
-+ ~faint~
-+ ~variable-pitch~
-+ ~underline~
-+ A font weight, which must be supported by the underlying typeface:
- - ~thin~
- - ~ultralight~
- - ~extralight~
- - ~light~
- - ~semilight~
- - ~regular~
- - ~medium~
- - ~semibold~
- - ~bold~
- - ~heavy~
- - ~extrabold~
- - ~ultrabold~
-+ A floating point as a height multiple of the default or a cons cell in
- the form of =(height . FLOAT)=
-+ ~all-buttons~
+This affects Company, Corfu, Flx, Icomplete/Fido, Ido, Ivy, Orderless,
+Vertico, and the standard =*Completions*= buffer. The value is an
+alist of expressions, each of which takes the form of =(KEY . LIST-OF-PROPERTIES)=.
+=KEY= is a symbol, while =PROPERTIES= is a list. Here is a sample,
+followed by a description of the particularities:
-The default (a ~nil~ value or an empty list) is a gray background
-combined with a pseudo three-dimensional effect.
+#+begin_src emacs-lisp
+(setq modus-themes-completions
+ '((matches . (extrabold underline))
+ (selection . (semibold italic))))
+#+end_src
-The ~flat~ property makes the button two dimensional.
+The ~matches~ key refers to the highlighted characters that correspond
+to the user's input. When its properties are ~nil~ or an empty list,
+matching characters in the user interface will have a bold weight and
+a colored foreground. The list of properties may include any of the
+following symbols regardless of the order they may appear in:
-The ~accented~ property changes the background from gray to an accent
-color.
+- ~underline~ to draw a line below the characters;
-The ~faint~ property reduces the overall coloration.
+- ~italic~ to use a slanted font (italic or oblique forms);
-The ~variable-pitch~ property applies a proportionately spaced typeface
-to the button~s text.
+- The symbol of a font weight attribute such as ~light~,
+ ~semibold~, et cetera. Valid symbols are defined in the
+ variable ~modus-themes-weights~. The absence of a weight means
+ that bold will be used.
-[[#h:defcf4fc-8fa8-4c29-b12e-7119582cc929][Font configurations for Org and others]].
+The ~selection~ key applies to the current line or currently matched
+candidate, depending on the specifics of the user interface. When its
+properties are ~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):
-The ~underline~ property draws a line below the affected text and
-removes whatever box effect. This is optimal when Emacs runs inside a
-terminal emulator ([[#h:fbb5e254-afd6-4313-bb05-93b3b4f67358][More accurate colors in terminal emulators]]). If
-~flat~ and ~underline~ are defined together, the latter takes
-precedence.
+- ~underline~ to draw a line below the characters;
-The symbol of a weight attribute adjusts the font of the button
-accordingly, such as ~light~, ~semibold~, etc. Valid symbols are
-defined in the variable ~modus-themes-weights~.
+- ~italic~ to use a slanted font (italic or oblique forms);
-[[#h:2793a224-2109-4f61-a106-721c57c01375][Configure bold and italic faces]].
+- The symbol of a font weight attribute such as ~light~,
+ ~semibold~, et cetera. Valid symbols are defined in the
+ variable ~modus-themes-weights~. The absence of a weight means
+ that bold will be used.
-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.
+Apart from specifying each key separately, a catch-all list is
+accepted. This is only useful when the desired aesthetic is the same
+across all keys that are not explicitly referenced. For example,
+this:
-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.
+#+begin_src emacs-lisp
+(setq modus-themes-completions
+ '((t . (extrabold underline))))
+#+end_src
-Combinations of any of those properties are expressed as a list,
-like in these examples:
+Is the same as:
#+begin_src emacs-lisp
-(flat)
-(variable-pitch flat)
-(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
+(setq modus-themes-completions
+ '((matches . (extrabold underline))
+ (selection . (extrabold underline))))
#+end_src
-The order in which the properties are set is not significant.
+[[#h:d959f789-0517-4636-8780-18123f936f91][Make completion matches more or less colorful]].
-In user configuration files the form may look like this:
+** Option for org-mode block styles
+:properties:
+:alt_title: Org mode blocks
+:description: Choose among plain, gray, or tinted backgrounds
+:custom_id: h:b7e328c0-3034-4db7-9cdf-d5ba12081ca2
+:end:
+#+vindex: modus-themes-org-blocks
-#+begin_src emacs-lisp
-(setq modus-themes-box-buttons '(variable-pitch flat 0.9))
-#+end_src
+As part of version =4.4.0=, the ~modus-themes-org-blocks~ is no more.
+Users can apply palette overrides to set a style that fits their
+preference (purple, blue, yellow, green, etc.). It is more flexible
+and more powerful ([[#h:f44cc6e3-b0f1-4a5e-8a90-9e48fa557b50][DIY Make Org block colors more or less colorful]])
-** Option for command prompt styles
+For the option to change the background of Org source blocks, we
+provide the relevant setup ([[#h:8c842804-43b7-4287-b4e9-8c07d04d1f89][DIY Use colored Org source blocks per language]]).
+
+** Option for the headings' overall style
:properties:
-:alt_title: Command prompts
-:description: Choose among plain, subtle, or intense prompts
-:custom_id: h:db5a9a7c-2928-4a28-b0f0-6f2b9bd52ba1
+:alt_title: Heading styles
+:description: Choose among several styles, also per heading level
+:custom_id: h:271eff19-97aa-4090-9415-a6463c2f9ae1
:end:
-#+vindex: modus-themes-prompts
+#+vindex: modus-themes-headings
-Brief: Control the style of command prompts (e.g. minibuffer, shell, IRC
-clients).
+Brief: Heading styles with optional list of values per heading level.
-Symbol: ~modus-themes-prompts~ (=choice= type, list of properties)
+Symbol: ~modus-themes-headings~ (=alist= type, multiple properties)
-Possible values are expressed as a list of properties (default is ~nil~ or
-an empty list). The list can include any of the following symbols:
+This is an alist that accepts a =(KEY . LIST-OF-VALUES)= combination.
+The =KEY= is either a number, representing the heading's level (0
+through 8) or ~t~, which pertains to the fallback style. The named
+keys =agenda-date= and =agenda-structure= apply to the Org agenda.
-+ ~background~
-+ ~bold~
-+ ~gray~
-+ ~intense~
-+ ~italic~
+Level 0 is a special heading: it is used for what counts as a document
+title or equivalent, such as the =#+title= construct we find in Org
+files. Levels 1-8 are regular headings.
-The default (a ~nil~ value or an empty list) means to only use a subtle
-accented foreground color.
+The =LIST-OF-VALUES= covers symbols that refer to properties, as
+described below. Here is a complete sample with various stylistic
+combinations, followed by a presentation of all available properties:
+
+#+begin_src emacs-lisp
+(setq modus-themes-headings
+ '((1 . (variable-pitch 1.5))
+ (2 . (1.3))
+ (agenda-date . (1.3))
+ (agenda-structure . (variable-pitch light 1.8))
+ (t . (1.1))))
+#+end_src
+
+Properties:
+
++ A font weight, which must be supported by the underlying typeface:
+ - ~thin~
+ - ~ultralight~
+ - ~extralight~
+ - ~light~
+ - ~semilight~
+ - ~regular~
+ - ~medium~
+ - ~semibold~
+ - ~bold~ (default)
+ - ~heavy~
+ - ~extrabold~
+ - ~ultrabold~
++ A floating point as a height multiple of the default or a cons cell in
+ the form of =(height . FLOAT)=.
-The property ~background~ applies a background color to the prompt's text.
-By default, this is a subtle accented value.
+By default (a ~nil~ value for this variable), all headings have a bold
+typographic weight and use a desaturated text color.
-The property ~intense~ makes the foreground color more prominent. If the
-~background~ property is also set, it amplifies the value of the
-background as well.
+A ~variable-pitch~ property changes the font family of the heading to that
+of the ~variable-pitch~ face (normally a proportionately spaced typeface).
-The property ~gray~ changes the prompt's colors to grayscale. This
-affects the foreground and, if the ~background~ property is also set, the
-background. Its effect is subtle, unless it is combined with the
-~intense~ property.
+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 weight
+means that bold will be used by virtue of inheriting the ~bold~ face.
-The property ~bold~ makes the text use a bold typographic weight.
-Similarly, ~italic~ adds a slant to the font's forms (italic or oblique
-forms, depending on the typeface).
+[[#h:2793a224-2109-4f61-a106-721c57c01375][Configure bold and italic faces]].
+
+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:
#+begin_src emacs-lisp
-(intense)
-(bold intense)
-(intense bold gray)
-(intense background gray bold)
+(semibold)
+(variable-pitch semibold 1.3)
+(variable-pitch semibold (height 1.3)) ; same as above
+(variable-pitch semibold (height . 1.3)) ; same as above
#+end_src
The order in which the properties are set is not significant.
@@ -1041,1134 +997,1604 @@ The order in which the properties are set is not significant.
In user configuration files the form may look like this:
#+begin_src emacs-lisp
-(setq modus-themes-prompts '(background gray))
+(setq modus-themes-headings
+ '((1 . (variable-pitch 1.5))
+ (2 . (1.3))
+ (agenda-date . (1.3))
+ (agenda-structure . (variable-pitch light 1.8))
+ (t . (1.1))))
#+end_src
-** Option for mode line presentation
-:properties:
-:alt_title: Mode line
-:description: Choose among several styles, with or without borders
-:custom_id: h:27943af6-d950-42d0-bc23-106e43f50a24
-:end:
-#+vindex: modus-themes-mode-line
-
-Brief: Control the style of the mode lines.
-
-Symbol: ~modus-themes-mode-line~ (=choice= type, list of properties)
-
-Possible values, which can be expressed as a list of combinations of box
-effect, color, and border visibility:
-
-+ Overall style:
- - ~3d~
- - ~moody~
-+ ~accented~
-+ ~borderless~
-+ 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
-lines use different shades of grayscale values for the background,
-foreground, border.
-
-The ~3d~ property applies a three-dimensional effect to the active mode
-line. The inactive mode lines remain two-dimensional and are toned down
-a bit, relative to the default style.
-
-The ~moody~ property optimizes the mode line for use with the library of
-the same name (hereinafter referred to as 'Moody'). In practice, it
-removes the box effect and replaces it with underline and overline
-properties. It also tones down the inactive mode lines. Despite its
-intended purpose, this option can also be used without the Moody library
-(please consult the themes' manual on this point for more details). If
-both ~3d~ and ~moody~ properties are set, the latter takes precedence.
-
-The ~borderless~ property removes the color of the borders. It does not
-actually remove the borders, but only makes their color the same as the
-background, effectively creating some padding.
-
-The ~accented~ property ensures that the active mode line uses a colored
-background instead of the standard shade of gray.
-
-A positive integer (natural number or natnum) applies a padding effect
-of NATNUM pixels at the boundaries of the mode lines. The default value
-is 1 and does not need to be specified explicitly. The padding has no
-effect when the ~moody~ property is also used, because Moody already
-applies its own tweaks. To ensure that the underline is placed at the
-bottom of the mode line, set ~x-underline-at-descent-line~ to non-~nil~
-(this is not needed when 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 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:
+When defining the styles per heading level, it is possible to pass a
+non-~nil~ value (~t~) instead of a list of properties. This will retain the
+original aesthetic for that level. For example:
#+begin_src emacs-lisp
-(accented)
-(borderless 3d)
-(moody accented borderless)
-#+end_src
-
-Same as above, using the padding and height as an example (these
-all yield the same result):
+(setq modus-themes-headings
+ '((1 . t) ; keep the default style
+ (2 . (semibold 1.2))
+ (t . (rainbow)))) ; style for all other headings
-#+begin_src emacs-lisp
-(accented borderless 4 0.9)
-(accented borderless (padding . 4) (height . 0.9))
-(accented borderless (padding 4) (height 0.9))
+(setq modus-themes-headings
+ '((1 . (variable-pitch 1.5))
+ (2 . (semibold))
+ (t . t))) ; default style for all other levels
#+end_src
-The order in which the properties are set is not significant.
+Note that the text color of headings, of their background, and
+overline can all be set via the overrides. It is possible to have any
+color combination for any heading level (something that could not be
+done in older versions of the themes).
-In user configuration files the form may look like this:
+[[#h:34c7a691-19bb-4037-8d2f-67a07edab150][Option for palette overrides]].
-#+begin_src emacs-lisp
-(setq modus-themes-mode-line '(borderless accented))
-#+end_src
-
-Note that Moody does not expose any faces that the themes could style
-directly. Instead it re-purposes existing ones to render its tabs and
-ribbons. As such, there may be cases where the contrast ratio falls
-below the 7:1 target that the themes conform with (WCAG AAA). To hedge
-against this, we configure a fallback foreground for the ~moody~ property,
-which will come into effect when the background of the mode line changes
-to something less accessible, such as Moody ribbons (read the doc string
-of ~set-face-attribute~, specifically ~:distant-foreground~). This fallback
-is activated when Emacs determines that the background and foreground of
-the given construct are too close to each other in terms of color
-distance. In practice, users will need to experiment with the variable
-~face-near-same-color-threshold~ to trigger the effect. We find that a
-value of =45000= shall suffice, contrary to the default =30000=. Though for
-the combinations that involve the ~accented~ and ~moody~ properties, as
-mentioned above, that should be raised up to =70000=. Do not set it too
-high, because it has the adverse effect of always overriding the default
-colors (which have been carefully designed to be highly accessible).
-
-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.
-
-Finally, note that various packages which heavily modify the mode line,
-such as =doom-modeline=, =nano-modeline=, =powerline=, =spaceline= may not look
-as intended with all possible combinations of this user option.
-
-** Option for accented background in tab interfaces
+[[#h:11297984-85ea-4678-abe9-a73aeab4676a][Make headings more or less colorful]].
+
+** Option for variable-pitch font in UI elements
:properties:
-:alt_title: Tab style
-:description: Toggle accented background for tabs
-:custom_id: h:27cef8f5-dc4e-4c93-ba41-b899e650d936
+:alt_title: UI typeface
+:description: Toggle the use of variable-pitch across the User Interface
+:custom_id: h:16cf666c-5e65-424c-a855-7ea8a4a1fcac
:end:
-#+vindex: modus-themes-tabs-accented
+#+vindex: modus-themes-variable-pitch-ui
-Brief: Toggle accent colors for tabbed interfaces.
+Brief: Toggle the use of proportionately spaced (~variable-pitch~) fonts
+in the User Interface.
-Symbol: ~modus-themes-tabs-accented~ (=boolean= type)
+Symbol: ~modus-themes-variable-pitch-ui~ (=boolean= type)
Possible values:
-+ ~nil~ (default)
-+ ~t~
+1. ~nil~ (default)
+2. ~t~
-By default, all tab interfaces use backgrounds which are shades of gray.
-When this option is set to non-~nil~, the backgrounds become colorful.
+This option concerns User Interface elements that are under the direct
+control of Emacs. In particular: the mode line, header line, tab bar,
+and tab line.
-This affects the built-in ~tab-bar-mode~ and ~tab-line-mode~, as well as the
-Centaur tabs package.
+The default is to use the same font as the rest of Emacs, which usually
+is a monospaced family.
-** Option for completion framework aesthetics
+With a non-~nil~ value (~t~) apply a proportionately spaced typeface. This
+is done by assigning the ~variable-pitch~ face to the relevant items.
+
+[[#h:defcf4fc-8fa8-4c29-b12e-7119582cc929][Font configurations for Org and others]].
+
+** Option for palette overrides
:properties:
-:alt_title: Completion UIs
-:description: Choose among several styles for completion UIs
-:custom_id: h:f1c20c02-7b34-4c35-9c65-99170efb2882
+:alt_title: Palette overrides
+:description: Refashion color values and/or semantic color mappings
+:custom_id: h:34c7a691-19bb-4037-8d2f-67a07edab150
:end:
-#+vindex: modus-themes-completions
-Brief: Set the overall style of completion framework interfaces.
+This section describes palette overrides in detail. For a simpler
+alternative, use the presets we provide ([[#h:b0bc811c-227e-42ec-bf67-15e1f41eb7bc][Palette override presets]]).
-Symbol: ~modus-themes-completions~ (=alist= type properties)
+Each Modus theme specifies a color palette that declares named color
+values and semantic color mappings:
-This affects Company, Corfu, Flx, Helm, Icomplete/Fido, Ido, Ivy,
-Orderless, Selectrum, Vertico. The value is an alist that takes the
-form of a =(KEY . PROPERTIES)= combination. =KEY= is a symbol, while
-=PROPERTIES= is a list. Here is a sample, followed by a description
-of the particularities:
++ Named colors consist of a symbol and a string that specifies a
+ hexadecimal RGB value. For example: =(blue-warmer "#354fcf")=.
-#+begin_src emacs-lisp
-(setq modus-themes-completions
- '((matches . (extrabold background intense))
- (selection . (semibold accented intense))
- (popup . (accented))))
-#+end_src
++ The semantic color mappings associate an abstract construct with a
+ given named color from the palette, like =(heading-2 yellow-faint)=.
+ Both elements of the list are symbols, though the ~cadr~ (value) can
+ be a string that specifies a color, such as =(heading-2 "#354fcf")=.
-The ~matches~ key refers to the highlighted characters that correspond
-to the user's input. When its properties are ~nil~ or an empty list,
-matching characters in the user interface will have a bold weight and
-a colored foreground. The list of properties may include any of the
-following symbols regardless of the order they may appear in:
+#+vindex: modus-themes-common-palette-overrides
+Both of those subsets can be overridden, thus refashioning the theme.
+Overrides are either shared, by being stored in the user option
+~modus-themes-common-palette-overrides~, or they are specific to the
+theme they name. In the latter case, the naming scheme of each
+palette variable is =THEME-NAME-palette-overrides=, thus yielding:
-- ~background~ to add a background color;
+#+vindex: modus-operandi-palette-overrides
++ ~modus-operandi-palette-overrides~
-- ~intense~ to increase the overall coloration (also amplifies
- the ~background~, if present);
+#+vindex: modus-operandi-deuteranopia-palette-overrides
++ ~modus-operandi-deuteranopia-palette-overrides~
-- ~underline~ to draw a line below the characters;
+#+vindex: modus-operandi-tinted-palette-overrides
++ ~modus-operandi-tinted-palette-overrides~
-- ~italic~ to use a slanted font (italic or oblique forms);
+#+vindex: modus-operandi-tritanopia-palette-overrides
++ ~modus-operandi-tritanopia-palette-overrides~
-- The symbol of a font weight attribute such as ~light~, ~semibold~, et
- cetera. Valid symbols are defined in the ~modus-themes-weights~
- variable. The absence of a weight means that bold will be used.
+#+vindex: modus-vivendi-palette-overrides
++ ~modus-vivendi-palette-overrides~
-The ~selection~ key applies to the current line or currently matched
-candidate, depending on the specifics of the user interface. When its
-properties are ~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):
+#+vindex: modus-vivendi-deuteranopia-palette-overrides
++ ~modus-vivendi-deuteranopia-palette-overrides~
-- ~accented~ to make the background colorful instead of gray;
+#+vindex: modus-vivendi-tinted-palette-overrides
++ ~modus-vivendi-tinted-palette-overrides~
-- ~text-also~ to apply extra color to the text of the selected line;
+#+vindex: modus-vivendi-tritanopia-palette-overrides
++ ~modus-vivendi-tritanopia-palette-overrides~
-- ~intense~ to increase the overall coloration;
+Theme-specific overrides take precedence over the shared ones. It is
+strongly advised that shared overrides do NOT alter color values, as
+those will not be appropriate for both dark and light themes. Common
+overrides are best limited to the semantic color mappings as those use
+the color value that corresponds to the active theme (e.g. make the
+cursor =blue-warmer= in all themes, whatever the value of
+=blue-warmer= is in each theme).
-- ~underline~ to draw a line below the characters;
+The value of any overrides' variable must mirror a theme's palette.
+Palette variables are named after their theme as =THEME-NAME-palette=.
+For example, the ~modus-operandi-palette~ is like this:
-- ~italic~ to use a slanted font (italic or oblique forms);
+#+begin_src emacs-lisp
+(defconst modus-operandi-palette
+ '(
+;;; Basic values
-- The symbol of a font weight attribute such as ~light~, ~semibold~, et
- cetera. Valid symbols are defined in the ~modus-themes-weights~
- variable. The absence of a weight means that bold will be used.
+ (bg-main "#ffffff")
+ (bg-dim "#f0f0f0")
+ (fg-main "#000000")
-The ~popup~ key takes the same values as ~selection~. The only
-difference is that it applies specifically to user interfaces that
-display an inline popup and thus have slightly different styling
-requirements than the minibuffer. The two prominent packages are
-=company= and =corfu=.
+ ;; ...
-Apart from specifying each key separately, a fallback list is accepted.
-This is only useful when the desired aesthetic is the same across all
-keys that are not explicitly referenced. For example, this:
+ (red "#a60000")
+ (red-warmer "#972500")
+ (red-cooler "#a0132f")
+ (red-faint "#7f0000")
+ (red-intense "#d00000")
-#+begin_src emacs-lisp
-(setq modus-themes-completions
- '((t . (extrabold intense))))
-#+end_src
+ ;; ...
-Is the same as:
+;;;; Mappings
-#+begin_src emacs-lisp
-(setq modus-themes-completions
- '((matches . (extrabold intense))
- (selection . (extrabold intense))
- (popup . (extrabold intense))))
-#+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~
-and ~text-also~, while ~selection~ and ~popup~ do not have
-~background~).
+ (cursor fg-main)
+ (builtin magenta-warmer)
+ (comment fg-dim)
+ (constant blue-cooler)
+ (docstring green-faint)
+ (fnname magenta)
+ (keyword magenta-cooler)
-[[#h:2793a224-2109-4f61-a106-721c57c01375][Configure bold and italic faces]].
+ ;; ...
+ ))
+#+end_src
-Also refer to the documentation of the ~orderless~ package for its
-intersection with ~company~ (if you choose to use those in tandem).
+The ~modus-operandi-palette-overrides~ targets the entries that need
+to be changed. For example, to make the main foreground color a dark
+gray instead of pure black, use a shade of red for comments, and apply
+a cyan hue to keywords:
-** Option for mail citations
-:properties:
-:alt_title: Mail citations
-:description: Choose among colorful, desaturated, monochrome citations
-:custom_id: h:5a12765d-0ba0-4a75-ab11-e35d3bbb317d
-:end:
-#+vindex: modus-themes-mail-citations
+#+begin_src emacs-lisp
+(setq modus-operandi-palette-overrides
+ '((fg-main "#333333")
+ (comment red-faint)
+ (keyword cyan-cooler)))
+#+end_src
-Brief: Set the overall style of citations/quotes when composing
-emails.
+Changes take effect upon theme reload ([[#h:9001527a-4e2c-43e0-98e8-3ef72d770639][Custom reload theme]]).
+Overrides are removed by setting their variable to a ~nil~ value.
-Symbol: ~modus-themes-mail-citations~ (=choice= type)
+The common accented foregrounds in each palette follow a predictable
+naming scheme: =HUE{,-warmer,-cooler,-faint,-intense}=. =HUE= is one
+of the six basic colors: red, green, blue, yellow, magenta, cyan.
-Possible values:
+Named colors that are meant to be used as backgrounds contain =bg= in
+their name, such as =bg-red-intense=. While special purpose
+foregrounds that are meant to be combined with such backgrounds,
+contain =fg= in their name, such as =fg-removed= which complements
+=bg-removed=.
-1. ~nil~ (default)
-2. ~intense~
-3. ~faint~
-4. ~monochrome~
+Named colors can be previewed, such as with the command
+~modus-themes-list-colors~ ([[#h:f4d4b71b-2ca5-4c3d-b0b4-9bfd7aa7fb4d][Preview theme colors]]).
-By default (a ~nil~ value) citations are styled with contrasting hues to
-denote their depth. Colors are easy to tell apart because they
-complement each other, but they otherwise are not very prominent.
+For a video tutorial that users of all skill levels can approach,
+watch: https://protesilaos.com/codelog/2022-12-17-modus-themes-v4-demo/.
-Option ~intense~ is similar to the default in terms of using contrasting
-and complementary hues, but applies more saturated colors.
+* Preview theme colors
+:properties:
+:custom_id: h:f4d4b71b-2ca5-4c3d-b0b4-9bfd7aa7fb4d
+:end:
+#+cindex: Preview named colors or semantic color mappings
-Option ~faint~ maintains the same color-based distinction between citation
-levels though the colors it uses have subtle differences between them.
+#+findex: modus-themes-list-colors
+The command ~modus-themes-list-colors~ uses minibuffer completion to
+select an item from the Modus themes and then produces a buffer with
+previews of its color palette entries. The buffer has a naming scheme
+that reflects the given choice, like =modus-operandi-list-colors= for
+the ~modus-operandi~ theme.
-Option ~monochrome~ turns all quotes into a shade of gray.
+#+findex: modus-themes-list-colors-current
+The command ~modus-themes-list-colors-current~ skips the minibuffer
+selection process and just produces a preview for the current Modus
+theme.
-Whatever the value assigned to this variable, citations in emails are
-controlled by typographic elements or indentation, which the themes do
-not touch.
+When called with a prefix argument (=C-u= with the default key
+bindings), these commands will show a preview of the palette's
+semantic color mappings instead of the named colors. In this context,
+"named colors" are entries that associate a symbol to a string color
+value, such as =(blue-warmer "#354fcf")=. Whereas "semantic color
+mappings" associate a named color to a symbol, like =(string
+blue-warmer)=, thus making the theme render all string constructs in
+the =blue-warmer= color value ([[#h:34c7a691-19bb-4037-8d2f-67a07edab150][Option for palette overrides]]).
-** Option for fringe visibility
-:properties:
-:alt_title: Fringes
-:description: Choose among invisible, subtle, or intense fringe styles
-:custom_id: h:1983c3fc-74f6-44f3-b917-967c403bebae
-:end:
-#+vindex: modus-themes-fringes
+#+findex: modus-themes-preview-colors
+#+findex: modus-themes-preview-colors-current
+Aliases for those commands are ~modus-themes-preview-colors~ and
+~modus-themes-preview-colors-current~.
-Brief: Control the overall coloration of the fringes.
+Each row shows a foreground and background coloration using the
+underlying value it references. For example a line with =#a60000= (a
+shade of red) will show red text followed by a stripe with that same
+color as a backdrop.
-Symbol: ~modus-themes-fringes~ (=choice= type)
+The name of the buffer describes the given Modus theme and what the
+contents are, such as =*modus-operandi-list-colors*= for named colors
+and ==*modus-operandi-list-mappings*= for the semantic color mappings.
-Possible values:
+* Use colors from the Modus themes palette
+:PROPERTIES:
+:CUSTOM_ID: h:33460ae8-984b-40fd-8baa-383cc5fc2698
+:END:
-1. ~nil~
-2. ~subtle~
-3. ~intense~
+The Modus themes provide the means to access the palette of (i) the
+active theme or (ii) any theme in the Modus collection. These are
+useful for Do-It-Yourself customizations ([[#h:f4651d55-8c07-46aa-b52b-bed1e53463bb][Advanced customization]]),
+though it can also be helpful in other cases, such as to reuse a color
+value in some other application.
-When the value is nil, do not apply a distinct background color.
+- Function :: [[#h:1cc552c1-5f5f-4a56-ae78-7b69e8512c4e][Get a single color from the palette with ~modus-themes-get-color-value~]]
+- Macro :: [[#h:51ba3547-b8c8-40d6-ba5a-4586477fd4ae][Use theme colors in code with ~modus-themes-with-colors~]].
-With a value of ~subtle~ use a gray background color that is
-visible yet close to the main background color.
+** Get a single color from the palette with ~modus-themes-get-color-value~
+:PROPERTIES:
+:CUSTOM_ID: h:1cc552c1-5f5f-4a56-ae78-7b69e8512c4e
+:END:
-With ~intense~ use a more pronounced gray background color.
+#+findex: modus-themes-get-color-value
+The fuction ~modus-themes-get-color-value~ can be called from Lisp to
+return the value of a color from the active Modus theme palette. It
+takea a =COLOR= argument and an optional =OVERRIDES=. It also accepts
+a third =THEME= argument, to get the color from the given theme.
-** Option for language checkers
-:properties:
-:alt_title: Language checkers
-:description: Control the style of language checkers/linters
-:custom_id: h:4b13743a-8ebf-4d2c-a043-cceba10b1eb4
-:end:
-#+vindex: modus-themes-lang-checkers
+=COLOR= is a symbol that represents a named color entry in the
+palette ([[#h:f4d4b71b-2ca5-4c3d-b0b4-9bfd7aa7fb4d][Preview theme colors]]).
-Brief: Control the style of in-buffer warnings and errors produced by
-spell checkers, code linters, and the like.
+If the value is the name of another color entry in the palette (so a
+mapping), this function recurs until it finds the underlying color
+value.
-Symbol: ~modus-themes-lang-checkers~ (=choice= type, list of properties)
+With an optional =OVERRIDES= argument as a non-~nil~ value, it
+accounts for palette overrides. Else it reads only the default palette
+([[#h:34c7a691-19bb-4037-8d2f-67a07edab150][Option for palette overrides]])
-Possible values are expressed as a list of properties (default is ~nil~ or
-an empty list). The list can include any of the following symbols:
+With an optional =THEME= as a symbol among the ~modus-themes-items~
+(alias ~modus-themes-collection~), it uses the palette of that theme.
+Else it uses the current Modus theme.
-+ ~straight-underline~
-+ ~text-also~
-+ ~background~
-+ Overall coloration:
- - ~intense~
- - ~faint~
+If =COLOR= is not present in the palette, this function returns the
+~unspecified~ symbol, which is safe when used as a face attribute's
+value.
-The default (a ~nil~ value or an empty list) applies a color-coded
-underline to the affected text, while it leaves the original foreground
-intact. If the display spec of Emacs has support for it, the
-underline's style is that of a wave, otherwise it is a straight line.
+An example with ~modus-operandi~ to show how this function behaves
+with/without overrides and when recursive mappings are introduced.
-The property ~straight-underline~ ensures that the underline under the
-affected text is always drawn as a straight line.
+#+begin_src emacs-lisp
+;; Here we show the recursion of palette mappings. In general, it is
+;; better for the user to specify named colors to avoid possible
+;; confusion with their configuration, though those still work as
+;; expected.
+(setq modus-themes-common-palette-overrides
+ '((cursor red)
+ (fg-mode-line-active cursor)
+ (border-mode-line-active fg-mode-line-active)))
-The property ~text-also~ applies the same color of the underline to the
-affected text.
+;; Ignore the overrides and get the original value.
+(modus-themes-get-color-value 'border-mode-line-active)
+;; => "#5a5a5a"
-The property ~background~ adds a color-coded background.
+;; Read from the overrides and deal with any recursion to find the
+;; underlying value.
+(modus-themes-get-color-value 'border-mode-line-active :overrides)
+;; => "#a60000"
+#+end_src
-The property ~intense~ amplifies the applicable colors if ~background~
-and/or ~text-also~ are set. If ~intense~ is set on its own, then it implies
-~text-also~.
+** Use theme colors in code with ~modus-themes-with-colors~
+:properties:
+:custom_id: h:51ba3547-b8c8-40d6-ba5a-4586477fd4ae
+:end:
+#+cindex: Use colors from the palette anywhere
-The property ~faint~ uses nuanced colors for the underline and for the
-foreground when ~text-also~ is included. If both ~faint~ and ~intense~ are
-specified, the former takes precedence.
+[ Note that for common cases the following is not not needed. Just rely on
+ the comprehensive overrides we provide ([[#h:34c7a691-19bb-4037-8d2f-67a07edab150][Option for palette overrides]]). ]
-Combinations of any of those properties can be expressed in a list, as
-in those examples:
+#+findex: modus-themes-with-colors
+Advanced users may want to apply many colors from the palette of the
+active Modus theme in their custom code. In such a case, retrieving
+each value with the function ~modus-themes-get-color-value~ is
+inefficient ([[#h:1cc552c1-5f5f-4a56-ae78-7b69e8512c4e][Get a single color from the palette]]). The Lisp macro
+~modus-themes-with-colors~ provides the requisite functionality. It
+supplies the current theme's palette to the code called from inside of
+it. For example:
#+begin_src emacs-lisp
-(background)
-(straight-underline intense)
-(background text-also straight-underline)
+(modus-themes-with-colors
+ (list blue-warmer magenta-cooler fg-added warning variable fg-heading-4))
+;; => ("#354fcf" "#531ab6" "#005000" "#884900" "#005e8b" "#721045")
#+end_src
-The order in which the properties are set is not significant.
-
-In user configuration files the form may look like this:
+The above return value is for ~modus-operandi~ when that is the active
+theme. Switching to another theme and evaluating this code anew will
+return the relevant results for that theme (remember that since
+version 4, the Modus themes consist of many items ([[#h:f0f3dbcb-602d-40cf-b918-8f929c441baf][Overview]])). The
+same with ~modus-vivendi~ as the active theme:
#+begin_src emacs-lisp
-(setq modus-themes-lang-checkers '(text-also background))
+(modus-themes-with-colors
+ (list blue-warmer magenta-cooler fg-added warning variable fg-heading-4))
+;; => ("#79a8ff" "#b6a0ff" "#a0e0a0" "#fec43f" "#00d3d0" "#feacd0")
#+end_src
-NOTE: The placement of the straight underline, though not the wave
-style, is controlled by the built-in variables ~underline-minimum-offset~,
-~x-underline-at-descent-line~, ~x-use-underline-position-properties~.
+The ~modus-themes-with-colors~ has access to the whole palette of the
+active theme, meaning that it can instantiate both (i) named colors
+like =blue-warmer= and (ii) semantic color mappings like =warning=.
+We provide commands to inspect those ([[#h:f4d4b71b-2ca5-4c3d-b0b4-9bfd7aa7fb4d][Preview theme colors]]).
-To disable fringe indicators for Flymake or Flycheck, refer to variables
-~flymake-fringe-indicator-position~ and ~flycheck-indication-mode~,
-respectively.
+Others sections in this manual show how to use the aforementioned
+macro ([[#h:f4651d55-8c07-46aa-b52b-bed1e53463bb][Advanced customization]]). In practice, the use of a hook will
+also be needed ([[#h:d87673fe-2ce1-4c80-a4b8-be36ca9f2d24][DIY Use a hook at the post-load-theme phase]]).
-** Option for line highlighting
+* Advanced customization
:properties:
-:alt_title: Line highlighting
-:description: Choose style of current line (hl-line-mode)
-:custom_id: h:1dba1cfe-d079-4c13-a810-f768e8789177
+:custom_id: h:f4651d55-8c07-46aa-b52b-bed1e53463bb
:end:
-#+vindex: modus-themes-hl-line
-
-Brief: Control the style of the current line of ~hl-line-mode~.
-Symbol: ~modus-themes-hl-line~ (=choice= type, list of properties)
+Unlike the predefined customization options which follow a clear
+pattern of allowing the user to quickly specify their preference, the
+themes also provide a more flexible, albeit a bit more difficult,
+mechanism to control things with precision ([[#h:bf1c82f2-46c7-4eb2-ad00-dd11fdd8b53f][Customization Options]]).
-The value is a list of properties, each designated by a symbol. With
-a ~nil~ value, or an empty list, the style is a subtle gray background
-color.
+This section is of interest only to users who are prepared to maintain
+their own local tweaks and who are willing to deal with any possible
+incompatibilities between versioned releases of the themes. As such,
+they are labeled as "do-it-yourself" or "DIY".
-Possible properties are the following symbols:
+** DIY Palette override presets
+:PROPERTIES:
+:CUSTOM_ID: h:b0bc811c-227e-42ec-bf67-15e1f41eb7bc
+:END:
-+ ~accented~
-+ ~intense~
-+ ~underline~
+This section shows how to refashion the themes by opting in to the
+stylistic presets we provide. Those presets override the default
+color mappings to amplify, tone down, or refashion the overall
+coloration of the themes.
-The property ~accented~ changes the background to a colored variant.
+To make almost all aspects of the themes less intense, use this:
-An ~underline~ property draws a line below the highlighted area. Its
-color is similar to the background, so gray by default or an accent
-color when ~accented~ is also set.
+#+begin_src emacs-lisp
+;; Always remember to reload the theme for changes to take effect!
+(setq modus-themes-common-palette-overrides modus-themes-preset-overrides-faint)
+#+end_src
-An ~intense~ property amplifies the colors in use, which may be both the
-background and the underline.
+#+vindex: modus-themes-preset-overrides-faint
+With ~modus-themes-preset-overrides-faint~ the grays are toned down,
+gray backgrounds are removed from some contexts, and almost all accent
+colors are desaturated. It makes the themes less attention-grabbing.
-Combinations of any of those properties are expressed as a list, like in
-these examples:
+On the opposite end of the stylistic spectrum, we have this
#+begin_src emacs-lisp
-(intense)
-(underline intense)
-(accented intense underline)
+;; Always remember to reload the theme for changes to take effect!
+(setq modus-themes-common-palette-overrides modus-themes-preset-overrides-intense)
#+end_src
-The order in which the properties are set is not significant.
+#+vindex: modus-themes-preset-overrides-intense
+The ~modus-themes-preset-overrides-intense~ makes many background
+colors accented instead of gray and increases coloration in a number
+of places. Colors stand out more and are made easier to spot.
-In user configuration files the form may look like this:
+#+vindex: modus-themes-preset-overrides-cooler
+#+vindex: modus-themes-preset-overrides-warmer
+For some stylistic variation try the "cooler" and "warmer" presets:
#+begin_src emacs-lisp
-(setq modus-themes-hl-line '(underline accented))
+;; This:
+(setq modus-themes-common-palette-overrides modus-themes-preset-overrides-cooler)
+
+;; Or:
+(setq modus-themes-common-palette-overrides modus-themes-preset-overrides-warmer)
#+end_src
-Set ~x-underline-at-descent-line~ to a non-~nil~ value so that the
-placement of the underline coincides with the lower boundary of the
-colored background.
+Note that the user is not limited to those presets. The system of
+overrides we provide makes it possible to tweak the value of each
+individual named color and to change how values are assigned to
+semantic color mappings ([[#h:34c7a691-19bb-4037-8d2f-67a07edab150][Option for palette overrides]]). Subsequent
+sections provide examples ([[#h:df1199d8-eaba-47db-805d-6b568a577bf3][Stylistic variants using palette overrides]]).
-This style affects several packages that enable ~hl-line-mode~, such as
-=elfeed=, =notmuch=, and =mu4e=.
+It is also possible to use those presets as a basis and, for example,
+add to them code from the subsequent sections of this manual. This is
+the general idea (extra space for didactic purposes):
-[ Also check the =lin= package on GNU ELPA (by the author of the
- modus-themes) for a stylistic enhancement to ~hl-line-mode~. ]
+#+begin_src emacs-lisp
+(setq modus-themes-common-palette-overrides
+ `(
+ ;; From the section "Make the mode line borderless"
+ (border-mode-line-active unspecified)
+ (border-mode-line-inactive unspecified)
-** Option for line numbers
-:properties:
-:alt_title: Line numbers
-:description: Toggle subtle style for line numbers
-:custom_id: h:8c4a6230-2e43-4aa2-a631-3b7179392e09
-:end:
-#+vindex: modus-themes-subtle-line-numbers
+ ;; From the section "Make matching parenthesis more or less intense"
+ (bg-paren-match bg-magenta-intense)
+ (underline-paren-match fg-main)
-Brief: Toggle subtle line numbers.
+ ;; And expand the preset here. Note that the ,@ works because
+ ;; we use the backtick for this list, instead of a straight
+ ;; quote.
+ ,@modus-themes-preset-overrides-intense))
+#+end_src
+
+** DIY Stylistic variants using palette overrides
+:PROPERTIES:
+:CUSTOM_ID: h:df1199d8-eaba-47db-805d-6b568a577bf3
+:END:
-Symbol: ~modus-themes-subtle-line-numbers~ (=boolean= type)
+This section contains practical examples of overriding the palette of
+the themes ([[#h:34c7a691-19bb-4037-8d2f-67a07edab150][Option for palette overrides]]). Users can copy the code to
+their init file, evaluate it, and then re-load the theme for changes
+to take effect. To apply overrides at startup simply define them
+before the call that loads the theme. Remember that we also provide
+presets that are easier to apply ([[#h:b0bc811c-227e-42ec-bf67-15e1f41eb7bc][Palette override presets]]).
-Possible value:
+*** DIY Make the mode line borderless
+:PROPERTIES:
+:CUSTOM_ID: h:80ddba52-e188-411f-8cc0-480ebd75befe
+:END:
-1. ~nil~ (default)
-2. ~t~
+This is one of our practical examples to override the semantic colors
+of the Modus themes ([[#h:df1199d8-eaba-47db-805d-6b568a577bf3][Stylistic variants using palette overrides]]). To
+hide the border around the active and inactive mode lines, we need to
+set their color to that of the underlying background.
-The default style for ~display-line-numbers-mode~ and its global variant
-is to apply a subtle gray background to the line numbers. The current
-line has a more pronounced background and foreground combination to
-bring more attention to itself.
+[[#h:e8d781be-eefc-4a81-ac4e-5ed156190df7][Make the active mode line colorful]].
-Similarly, the faces for ~display-line-numbers-major-tick~ and its
-counterpart ~display-line-numbers-minor-tick~ use appropriate styles that
-involve a bespoke background and foreground combination.
+[[#h:5a0c58cc-f97f-429c-be08-927b9fbb0a9c][Add padding to mode line]].
-With a non-~nil~ value (~t~), line numbers have no background of their own.
-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.
+#+begin_src emacs-lisp
+;; Remove the border
+(setq modus-themes-common-palette-overrides
+ '((border-mode-line-active unspecified)
+ (border-mode-line-inactive unspecified)))
-** 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
+;; Keep the border but make it the same color as the background of the
+;; mode line (thus appearing borderless). The difference with the
+;; above is that this version is a bit thicker because the border are
+;; still there.
+(setq modus-themes-common-palette-overrides
+ '((border-mode-line-active bg-mode-line-active)
+ (border-mode-line-inactive bg-mode-line-inactive)))
+#+end_src
-Brief: Toggle intense mouse hover effects.
+Reload the theme for changes to take effect.
-Symbol: ~modus-themes-intense-mouseovers~ (=boolean= type)
+*** DIY Make the active mode line colorful
+:PROPERTIES:
+:CUSTOM_ID: h:e8d781be-eefc-4a81-ac4e-5ed156190df7
+:END:
-Possible value:
+This is one of our practical examples to override the semantic colors
+of the Modus themes ([[#h:df1199d8-eaba-47db-805d-6b568a577bf3][Stylistic variants using palette overrides]]).
+Here we show some snippets that apply different stylistic variants.
+Of course, it is possible to use theme-specific overrides to, say,
+have a blue mode line for ~modus-operandi~ and a red one for
+~modus-vivendi~.
-1. ~nil~ (default)
-2. ~t~
+[[#h:80ddba52-e188-411f-8cc0-480ebd75befe][Make the mode line borderless]].
-By default all mouseover effects apply a highlight with a subtle colored
-background. When non-~nil~, these have a more pronounced effect.
+[[#h:5a0c58cc-f97f-429c-be08-927b9fbb0a9c][Add padding to mode line]].
-Note that this affects the generic ~highlight~ which, strictly speaking,
-is not limited to mouse usage.
+#+begin_src emacs-lisp
+;; Blue background, neutral foreground, intense blue border
+(setq modus-themes-common-palette-overrides
+ '((bg-mode-line-active bg-blue-intense)
+ (fg-mode-line-active fg-main)
+ (border-mode-line-active blue-intense)))
-** Option for markup style in Org and others
-:properties:
-:alt_title: Markup
-:description: Choose style for markup in Org and others
-:custom_id: h:9d9a4e64-99ac-4018-8f66-3051b9c43fd7
-:end:
-#+vindex: modus-themes-markup
+;; Subtle blue background, neutral foreground, intense blue border
+(setq modus-themes-common-palette-overrides
+ '((bg-mode-line-active bg-blue-subtle)
+ (fg-mode-line-active fg-main)
+ (border-mode-line-active blue-intense)))
-Brief: Choose style of markup in Org, Markdown, and others (affects
-constructs such as Org's ==verbatim== and =~code~=).
+;; Sage (green/cyan) background, neutral foreground, slightly distinct green border
+(setq modus-themes-common-palette-overrides
+ '((bg-mode-line-active bg-sage)
+ (fg-mode-line-active fg-main)
+ (border-mode-line-active bg-green-intense)))
-Symbol: ~modus-themes-markup~ (=boolean= type)
+;; As above, but with a purple style
+(setq modus-themes-common-palette-overrides
+ '((bg-mode-line-active bg-lavender)
+ (fg-mode-line-active fg-main)
+ (border-mode-line-active bg-magenta-intense)))
-Possible values are expressed as a list of properties (default is ~nil~ or
-an empty list). The list can include any of the following symbols:
+;; As above, but with an earthly style
+(setq modus-themes-common-palette-overrides
+ '((bg-mode-line-active bg-ochre)
+ (fg-mode-line-active fg-main)
+ (border-mode-line-active bg-yellow-intense)))
+#+end_src
-1. ~bold~
-2. ~italic~
-3. ~background~
-4. ~intense~
+Reload the theme for changes to take effect.
-The ~italic~ property applies a typographic slant (italics).
+*** DIY Make the tab bar more or less colorful
+:PROPERTIES:
+:CUSTOM_ID: h:096658d7-a0bd-4a99-b6dc-9b20a20cda37
+:END:
-The ~bold~ property applies a heavier typographic weight.
+This is one of our practical examples to override the semantic colors
+of the Modus themes ([[#h:df1199d8-eaba-47db-805d-6b568a577bf3][Stylistic variants using palette overrides]]).
+Here we show how to affect the colors of the built-in ~tab-bar-mode~
+and ~tab-line-mode~.
-[[#h:2793a224-2109-4f61-a106-721c57c01375][Configure bold and italic faces]].
+For consistent theme-wide results, consider changing the mode line,
+fringes, and line numbers. These are shown in other sections of this
+manual.
-The ~background~ property adds a background color. The background is a
-shade of gray, unless the ~intense~ property is also set.
+#+begin_src emacs-lisp
+;; Make the `tab-bar-mode' mode subtle while keepings its original
+;; gray aesthetic.
+(setq modus-themes-common-palette-overrides
+ '((bg-tab-bar bg-main)
+ (bg-tab-current bg-active)
+ (bg-tab-other bg-dim)))
-The ~intense~ property amplifies the existing coloration. When
-~background~ is used, the background color is enhanced as well and
-becomes tinted instead of being gray.
+;; Like the above, but the current tab has a colorful background and
+;; the inactive tabs have a slightly more noticeable gray background.
+(setq modus-themes-common-palette-overrides
+ '((bg-tab-bar bg-main)
+ (bg-tab-current bg-cyan-intense)
+ (bg-tab-other bg-inactive)))
-Combinations of any of those properties are expressed as a list,
-like in these examples:
+;; Make the tabs colorful, using a monochromatic pattern (e.g. shades
+;; of cyan).
+(setq modus-themes-common-palette-overrides
+ '((bg-tab-bar bg-cyan-nuanced)
+ (bg-tab-current bg-cyan-intense)
+ (bg-tab-other bg-cyan-subtle)))
-#+begin_src emacs-lisp
-(bold)
-(bold italic)
-(bold italic intense)
-(bold italic intense background)
+;; Like the above, but with a dichromatic pattern (cyan and magenta).
+(setq modus-themes-common-palette-overrides
+ '((bg-tab-bar bg-cyan-nuanced)
+ (bg-tab-current bg-magenta-intense)
+ (bg-tab-other bg-cyan-subtle)))
#+end_src
-The order in which the properties are set is not significant.
+Reload the theme for changes to take effect.
-In user configuration files the form may look like this:
+*** DIY Make the fringe invisible or another color
+:PROPERTIES:
+:CUSTOM_ID: h:c312dcac-36b6-4a1f-b1f5-ab1c9abe27b0
+:END:
+
+This is one of our practical examples to override the semantic colors
+of the Modus themes ([[#h:df1199d8-eaba-47db-805d-6b568a577bf3][Stylistic variants using palette overrides]]).
+Here we show how to make the fringe invisible or how to assign to it a
+different color. The "fringe" is a small area to the right and left
+side of the Emacs window which shows indicators such as for truncation
+or continuation lines.
#+begin_src emacs-lisp
-(setq modus-themes-markup '(bold italic))
-#+end_src
+;; Make the fringe invisible
+(setq modus-themes-common-palette-overrides
+ '((fringe unspecified)))
-Also check the variables ~org-hide-emphasis-markers~,
-~org-hide-macro-markers~.
+;; Make the fringe more intense
+(setq modus-themes-common-palette-overrides
+ '((fringe bg-active)))
-** Option for parenthesis matching
-:properties:
-:alt_title: Matching parentheses
-:description: Choose between various styles for matching delimiters/parentheses
-:custom_id: h:e66a7e4d-a512-4bc7-9f86-fbbb5923bf37
-:end:
-#+vindex: modus-themes-paren-match
+;; Make the fringe colorful, but nuanced
+(setq modus-themes-common-palette-overrides
+ '((fringe bg-blue-nuanced)))
+#+end_src
-Brief: Control the style of matching delimiters produced by
-~show-paren-mode~.
+Reload the theme for changes to take effect.
-Symbol: ~modus-themes-paren-match~ (=choice= type, list of properties)
+*** DIY Make links use subtle or no underlines
+:PROPERTIES:
+:CUSTOM_ID: h:6c1d1dea-5cbf-4d92-b7bb-570a7a23ffe9
+:END:
-Possible values are expressed as a list of properties (default is ~nil~ or
-an empty list). The list can include any of the following symbols:
+This is one of our practical examples to override the semantic colors
+of the Modus themes ([[#h:df1199d8-eaba-47db-805d-6b568a577bf3][Stylistic variants using palette overrides]]). In
+this example, we showcase the special use of the ~unspecified~ symbol
+that underline mappings can read correctly.
-+ ~bold~
-+ ~intense~
-+ ~underline~
+#+begin_src emacs-lisp
+;; Subtle underlines
+(setq modus-themes-common-palette-overrides
+ '((underline-link border)
+ (underline-link-visited border)
+ (underline-link-symbolic border)))
-The default (a ~nil~ value or an empty list) is a subtle background color.
+;; No underlines
+(setq modus-themes-common-palette-overrides
+ '((underline-link unspecified)
+ (underline-link-visited unspecified)
+ (underline-link-symbolic unspecified)))
+#+end_src
-The ~bold~ property adds a bold weight to the characters of the matching
-delimiters.
+Reload the theme for changes to take effect.
-The ~intense~ property applies a more prominent background color to the
-delimiters.
+*** DIY Make prompts more or less colorful
+:PROPERTIES:
+:CUSTOM_ID: h:bd75b43a-0bf1-45e7-b8b4-20944ca8b7f8
+:END:
-The ~underline~ property draws a straight line under the affected text.
+This section contains practical examples of overriding the palette of
+the themes ([[#h:34c7a691-19bb-4037-8d2f-67a07edab150][Option for palette overrides]]). In the following code
+block we show how to add or remove color from prompts.
-Combinations of any of those properties are expressed as a list, like in
-these examples:
+[[#h:db5a9a7c-2928-4a28-b0f0-6f2b9bd52ba1][Option for command prompt styles]].
#+begin_src emacs-lisp
-(bold)
-(underline intense)
-(bold intense underline)
+;; Keep the background unspecified (like the default), but use a faint
+;; foreground color.
+(setq modus-themes-common-palette-overrides
+ '((fg-prompt cyan-faint)
+ (bg-prompt unspecified)))
+
+;; Add a nuanced background to prompts that complements their foreground.
+(setq modus-themes-common-palette-overrides
+ '((fg-prompt cyan)
+ (bg-prompt bg-cyan-nuanced)))
+
+;; Add a yellow background and adjust the foreground accordingly.
+(setq modus-themes-common-palette-overrides
+ '((fg-prompt fg-main)
+ (bg-prompt bg-yellow-subtle))) ; try to replace "subtle" with "intense"
#+end_src
-The order in which the properties are set is not significant.
+Reload the theme for changes to take effect.
-In user configuration files the form may look like this:
+*** DIY Make completion matches more or less colorful
+:PROPERTIES:
+:CUSTOM_ID: h:d959f789-0517-4636-8780-18123f936f91
+:END:
-#+begin_src emacs-lisp
-(setq modus-themes-paren-match '(bold intense))
-#+end_src
+This section contains practical examples of overriding the palette of
+the themes ([[#h:34c7a691-19bb-4037-8d2f-67a07edab150][Option for palette overrides]]). Here we demonstrate how
+to activate background coloration for completion matches. We show
+three different degrees of intensity.
+
+[[#h:f1c20c02-7b34-4c35-9c65-99170efb2882][Option for completion framework aesthetics]].
+
+#+begin_src emacs-lisp
+;; Add a nuanced background color to completion matches, while keeping
+;; their foreground intact (foregrounds do not need to be specified in
+;; this case, but we do it for didactic purposes).
+(setq modus-themes-common-palette-overrides
+ '((fg-completion-match-0 blue)
+ (fg-completion-match-1 magenta-warmer)
+ (fg-completion-match-2 cyan)
+ (fg-completion-match-3 red)
+ (bg-completion-match-0 bg-blue-nuanced)
+ (bg-completion-match-1 bg-magenta-nuanced)
+ (bg-completion-match-2 bg-cyan-nuanced)
+ (bg-completion-match-3 bg-red-nuanced)))
+
+;; Add intense background colors to completion matches and adjust the
+;; foregrounds accordingly.
+(setq modus-themes-common-palette-overrides
+ '((fg-completion-match-0 fg-main)
+ (fg-completion-match-1 fg-main)
+ (fg-completion-match-2 fg-main)
+ (fg-completion-match-3 fg-main)
+ (bg-completion-match-0 bg-blue-intense)
+ (bg-completion-match-1 bg-yellow-intense)
+ (bg-completion-match-2 bg-cyan-intense)
+ (bg-completion-match-3 bg-red-intense)))
+
+;; Like the above, but with subtle backgrounds.
+(setq modus-themes-common-palette-overrides
+ '((fg-completion-match-0 fg-main)
+ (fg-completion-match-1 fg-main)
+ (fg-completion-match-2 fg-main)
+ (fg-completion-match-3 fg-main)
+ (bg-completion-match-0 bg-blue-subtle)
+ (bg-completion-match-1 bg-yellow-subtle)
+ (bg-completion-match-2 bg-cyan-subtle)
+ (bg-completion-match-3 bg-red-subtle)))
+#+end_src
+
+Adding to the above, it is possible to, say, reduce the number of
+colors to two:
+
+#+begin_src emacs-lisp
+;; No backgrounds (like the default) and just use two colors.
+(setq modus-themes-common-palette-overrides
+ '((fg-completion-match-0 blue)
+ (fg-completion-match-1 yellow)
+ (fg-completion-match-2 blue)
+ (fg-completion-match-3 yellow)
+ (bg-completion-match-0 unspecified)
+ (bg-completion-match-1 unspecified)
+ (bg-completion-match-2 unspecified)
+ (bg-completion-match-3 unspecified)))
+
+;; Again, a two-color style but this time with backgrounds
+(setq modus-themes-common-palette-overrides
+ '((fg-completion-match-0 blue)
+ (fg-completion-match-1 yellow)
+ (fg-completion-match-2 blue)
+ (fg-completion-match-3 yellow)
+ (bg-completion-match-0 bg-blue-nuanced)
+ (bg-completion-match-1 bg-yellow-nuanced)
+ (bg-completion-match-2 bg-blue-nuanced)
+ (bg-completion-match-3 bg-yellow-nuanced)))
+#+end_src
+
+The user can mix and match to their liking.
+
+Reload the theme for changes to take effect.
+
+*** DIY Make comments yellow and strings green
+:PROPERTIES:
+:CUSTOM_ID: h:26f53daa-0065-48dc-88ab-6a718d16cd95
+:END:
-This customization variable affects the built-in ~show-paren-mode~ and the
-=smartparens= package.
+This is one of our practical examples to override the semantic colors
+of the Modus themes ([[#h:df1199d8-eaba-47db-805d-6b568a577bf3][Stylistic variants using palette overrides]]). In
+previous versions of the themes, we provided an option for yellow-ish
+comments and green-ish strings. For some users, those were still not
+good enough, as the exact values were hardcoded. Here we show how to
+reproduce the effect, but also how to tweak it to one's liking.
-** Option for active region
-:properties:
-:alt_title: Active region
-:description: Choose between various styles for the active region
-:custom_id: h:60798063-b4ad-45ea-b9a7-ff7b5c0ab74c
-:end:
-#+vindex: modus-themes-region
+[[#h:c8767172-bf11-4c96-81dc-e736c464fc9c][Make code syntax use the old alt-syntax style]].
-Brief: Control the style of the region.
+[[#h:943063da-7b27-4ba4-9afe-f8fe77652fd1][Make use of alternative styles for code syntax]].
-Symbol: ~modus-themes-region~ (=choice= type, list of properties)
+#+begin_src emacs-lisp
+;; Yellow comments and green strings like older versions of the Modus
+;; themes
+(setq modus-themes-common-palette-overrides
+ '((comment yellow-cooler)
+ (string green-cooler)))
-Possible values are expressed as a list of properties (default is ~nil~ or
-an empty list). The list can include any of the following symbols:
+;; Faint yellow comments and a different shade of green for strings
+(setq modus-themes-common-palette-overrides
+ '((comment yellow-faint)
+ (string green-warmer)))
-+ ~no-extend~
-+ ~bg-only~
-+ ~accented~
+;; Green comments and yellow strings, because now the user has the
+;; freedom to do it
+(setq modus-themes-common-palette-overrides
+ '((comment green)
+ (string yellow-cooler)))
+#+end_src
-The default (a ~nil~ value or an empty list) is a prominent gray
-background that overrides all foreground colors in the area it
-encompasses. Its reach extends to the edge of the window.
+Reload the theme for changes to take effect.
-The ~no-extend~ property limits the region to the end of the line, so that
-it does not reach the edge of the window.
+*** DIY Make code syntax use the old alt-syntax style
+:PROPERTIES:
+:CUSTOM_ID: h:c8767172-bf11-4c96-81dc-e736c464fc9c
+:END:
-The ~bg-only~ property makes the region's background color more subtle to
-allow the underlying text to retain its foreground colors.
+This is one of our practical examples to override the semantic colors
+of the Modus themes ([[#h:df1199d8-eaba-47db-805d-6b568a577bf3][Stylistic variants using palette overrides]]). In
+this section we show how to reproduce what previous versions of the
+Modus themes provided as a stylistic alternative for code syntax. The
+upside of using overrides for this purpose is that we can tweak the
+style to our liking, but first let's start with its recreation:
+
+#+begin_src emacs-lisp
+;; The old "alt-syntax" (before version 4.0.0 of the Modus themes)
+(setq modus-themes-common-palette-overrides
+ '((builtin magenta)
+ (comment fg-dim)
+ (constant magenta-cooler)
+ (docstring magenta-faint)
+ (docmarkup green-faint)
+ (fnname magenta-warmer)
+ (keyword cyan)
+ (preprocessor cyan-cooler)
+ (string red-cooler)
+ (type magenta-cooler)
+ (variable blue-warmer)
+ (rx-construct magenta-warmer)
+ (rx-backslash blue-cooler)))
+#+end_src
+
+The "alt-syntax" could optionally use green strings and yellow
+comments ([[#h:26f53daa-0065-48dc-88ab-6a718d16cd95][Make comments yellow and strings green]]):
+
+#+begin_src emacs-lisp
+;; Same as above, but with yellow comments and green strings
+(setq modus-themes-common-palette-overrides
+ '((builtin magenta)
+ (comment yellow-faint)
+ (constant magenta-cooler)
+ (docstring green-faint)
+ (docmarkup magenta-faint)
+ (fnname magenta-warmer)
+ (keyword cyan)
+ (preprocessor cyan-cooler)
+ (string green-cooler)
+ (type magenta-cooler)
+ (variable blue-warmer)
+ (rx-construct magenta-warmer)
+ (rx-backslash blue-cooler)))
+#+end_src
+
+The standard "alt-syntax" has red strings. As such, it is interesting
+to experiment with faintly red colored comments:
+
+#+begin_src emacs-lisp
+;; Like the old "alt-syntax" but with faint red comments
+(setq modus-themes-common-palette-overrides
+ '((builtin magenta)
+ (comment red-faint)
+ (constant magenta-cooler)
+ (docstring magenta-faint)
+ (docmarkup green-faint)
+ (fnname magenta-warmer)
+ (keyword cyan)
+ (preprocessor cyan-cooler)
+ (string red-cooler)
+ (type magenta-cooler)
+ (variable blue-warmer)
+ (rx-construct magenta-warmer)
+ (rx-backslash blue-cooler)))
+#+end_src
+
+The user can always mix and match styles to their liking.
+
+[[#h:943063da-7b27-4ba4-9afe-f8fe77652fd1][Make use of alternative styles for code syntax]].
+
+Reload the theme for changes to take effect.
+
+*** DIY Make use of alternative styles for code syntax
+:PROPERTIES:
+:CUSTOM_ID: h:943063da-7b27-4ba4-9afe-f8fe77652fd1
+:END:
-The ~accented~ property applies a more colorful background to the region.
+This is one of our practical examples to override the semantic colors
+of the Modus themes ([[#h:df1199d8-eaba-47db-805d-6b568a577bf3][Stylistic variants using palette overrides]]). The
+idea here is to change how named colors are mapped to code syntax.
+Each of the following snippets give the ~modus-themes~ a different
+feel while editing code.
+
+Note that my ~modus-themes~ and ~ef-themes~ do not use the same
+palettes, so some things are different. If you copy from the latter
+to the former, double-check that the entries exist in the given Modus
+theme palette.
+
+[[#h:26f53daa-0065-48dc-88ab-6a718d16cd95][Make comments yellow and strings green]].
+
+[[#h:c8767172-bf11-4c96-81dc-e736c464fc9c][Make code syntax use the old alt-syntax style]].
+
+#+begin_src emacs-lisp
+;; Mimic `ef-night' theme (from my `ef-themes') for code syntax
+;; highlighting, while still using the Modus colors (and other
+;; mappings).
+(setq modus-themes-common-palette-overrides
+ '((builtin green-cooler)
+ (comment yellow-faint)
+ (constant magenta-cooler)
+ (fnname cyan-cooler)
+ (keyword blue-warmer)
+ (preprocessor red-warmer)
+ (docstring cyan-faint)
+ (string blue-cooler)
+ (type magenta-cooler)
+ (variable cyan)))
+
+;; Mimic `ef-summer' theme (from my `ef-themes') for code syntax
+;; highlighting, while still using the Modus colors (and other
+;; mappings).
+(setq modus-themes-common-palette-overrides
+ '((builtin magenta)
+ (comment yellow-faint)
+ (constant red-cooler)
+ (fnname magenta-warmer)
+ (keyword magenta-cooler)
+ (preprocessor green-warmer)
+ (docstring cyan-faint)
+ (string yellow-warmer)
+ (type cyan-warmer)
+ (variable blue-warmer)))
+
+;; Mimic `ef-bio' theme (from my `ef-themes') for code syntax
+;; highlighting, while still using the Modus colors (and other
+;; mappings).
+(setq modus-themes-common-palette-overrides
+ '((builtin green)
+ (comment yellow-faint)
+ (constant blue)
+ (fnname green-warmer)
+ (keyword green-cooler)
+ (preprocessor green)
+ (docstring green-faint)
+ (string magenta-cooler)
+ (type cyan-warmer)
+ (variable blue-warmer)))
+
+;; Mimic `ef-trio-light' theme (from my `ef-themes') for code syntax
+;; highlighting, while still using the Modus colors (and other
+;; mappings).
+(setq modus-themes-common-palette-overrides
+ '((builtin magenta-cooler)
+ (comment yellow-faint)
+ (constant magenta-warmer)
+ (fnname blue-warmer)
+ (keyword magenta)
+ (preprocessor red-cooler)
+ (docstring magenta-faint)
+ (string green-cooler)
+ (type cyan-cooler)
+ (variable cyan-warmer)))
+#+end_src
+
+Reload the theme for changes to take effect.
+
+*** DIY Make matching parenthesis more or less intense
+:PROPERTIES:
+:CUSTOM_ID: h:259cf8f5-48ec-4b13-8a69-5d6387094468
+:END:
-Combinations of any of those properties are expressed as a list, like in
-these examples:
+This is one of our practical examples to override the semantic colors
+of the Modus themes ([[#h:df1199d8-eaba-47db-805d-6b568a577bf3][Stylistic variants using palette overrides]]). In
+this code block we show how to change the background of matching
+delimiters when ~show-paren-mode~ is enabled. We also demonstrate how
+to enable underlines for those highlights.
#+begin_src emacs-lisp
-(no-extend)
-(bg-only accented)
-(accented bg-only no-extend)
+;; Change the background to a shade of magenta
+(setq modus-themes-common-palette-overrides
+ '((bg-paren-match bg-magenta-intense)))
+
+;; Enable underlines by applying a color to them
+(setq modus-themes-common-palette-overrides
+ '((bg-paren-match bg-magenta-intense)
+ (underline-paren-match fg-main)))
+
+;; Do not use any background color and instead apply an intense red
+;; foreground.
+(setq modus-themes-common-palette-overrides
+ '((bg-paren-match unspecified)
+ (fg-paren-match red-intense)))
#+end_src
-The order in which the properties are set is not significant.
+Reload the theme for changes to take effect.
-In user configuration files the form may look like this:
+*** DIY Make box buttons more or less gray
+:PROPERTIES:
+:CUSTOM_ID: h:4f6b6ca3-f5bb-4830-8312-baa232305360
+:END:
+
+This is one of our practical examples to override the semantic colors
+of the Modus themes ([[#h:df1199d8-eaba-47db-805d-6b568a577bf3][Stylistic variants using palette overrides]]). By
+default, the boxed buttons that appear in {{{kbd(M-x customize)}}} and
+related are distinct shades of gray. The following set of overrides
+removes the gray from the active buttons and amplifies it for the
+inactive ones.
#+begin_src emacs-lisp
-(setq modus-themes-region '(bg-only no-extend))
+(setq modus-themes-common-palette-overrides
+ '((bg-button-active bg-main)
+ (fg-button-active fg-main)
+ (bg-button-inactive bg-inactive)
+ (fg-button-inactive "gray50")))
#+end_src
-** Option for diff buffer looks
-:properties:
-:alt_title: Diffs
-:description: Choose among intense, desaturated, or background-only diffs
-:custom_id: h:ea7ac54f-5827-49bd-b09f-62424b3b6427
-:end:
-#+vindex: modus-themes-diffs
+Reload the theme for changes to take effect.
-Brief: Set the overall style of diffs.
+*** DIY Make TODO and DONE more or less intense
+:PROPERTIES:
+:CUSTOM_ID: h:b57bb50b-a863-4ea8-bb38-6de2275fa868
+:END:
-Symbol: ~modus-themes-diffs~ (=choice= type)
+This is one of our practical examples to override the semantic colors
+of the Modus themes ([[#h:df1199d8-eaba-47db-805d-6b568a577bf3][Stylistic variants using palette overrides]]).
+Here we show how to affect just the =TODO= and =DONE= keywords that we
+encounter in Org buffers. The idea is to make those pop out more or
+to subdue them.
-Possible values:
+[[#h:11297984-85ea-4678-abe9-a73aeab4676a][Make headings more or less colorful]].
-1. ~nil~ (default)
-2. ~desaturated~
-3. ~bg-only~
+[[#h:bb5b396f-5532-4d52-ab13-149ca24854f1][Make inline code in prose use alternative styles]].
-The default (~nil~) uses fairly intense color combinations for diffs, by
-applying prominently colored backgrounds, with appropriately tinted
-foregrounds.
+#+begin_src emacs-lisp
+;; Increase intensity
+(setq modus-themes-common-palette-overrides
+ '((prose-done green-intense)
+ (prose-todo red-intense)))
-Option ~desaturated~ follows the same principles as with the default
-(~nil~), though it tones down all relevant colors.
+;; Tone down intensity
+(setq modus-themes-common-palette-overrides
+ '((prose-done green-faint) ; OR replace `green-faint' with `olive'
+ (prose-todo red-faint))) ; OR replace `red-faint' with `rust'
-Option ~bg-only~ applies a background but does not override the text's
-foreground. This makes it suitable for a non-~nil~ value passed to
-~diff-font-lock-syntax~ (note: Magit does not support syntax highlighting
-in diffs---last checked on 2021-12-02).
+;; Keep TODO at its default (so no override for it), but make DONE
+;; gray.
+(setq modus-themes-common-palette-overrides
+ '((prose-done fg-dim)))
+#+end_src
-When the user option ~modus-themes-deuteranopia~ is non-~nil~, all diffs
-will use a red/blue color-coding system instead of the standard
-red/green. Other stylistic changes are made in the interest of
-optimizing for such a use-case.
+Reload the theme for changes to take effect.
-[[#h:3ed03a48-20d8-4ce7-b214-0eb7e4c79abe][Option for red-green color deficiency or deuteranopia]].
+*** DIY Make headings more or less colorful
+:PROPERTIES:
+:CUSTOM_ID: h:11297984-85ea-4678-abe9-a73aeab4676a
+:END:
-In versions before =2.0.0= there was an option for foreground-only diffs.
-This is no longer supported at the theme level because there are cases
-where the perceived contrast and overall contextuality were not good
-enough although the applied colors were technically above the 7:1
-contrast threshold.
+This is one of our practical examples to override the semantic colors
+of the Modus themes ([[#h:df1199d8-eaba-47db-805d-6b568a577bf3][Stylistic variants using palette overrides]]).
+Here we show how to alter the looks of headings, such as in Org mode.
+Using overrides here offers far more flexibility than what we could
+achieve with previous versions of the themes: the user can mix and
+match styles at will.
-[[#h:e2aed9eb-5e1e-45ec-bbd7-bc4faeab3236][Diffs with only the foreground]].
+[[#h:b57bb50b-a863-4ea8-bb38-6de2275fa868][Make TODO and DONE more intense]].
-[[#h:b0b31802-0216-427e-b071-1a47adcfe608][Ediff without diff color-coding]].
+#+begin_src emacs-lisp
+;; Apply more colorful foreground to some headings (headings 0-8).
+;; Level 0 is for Org #+title and related.
+(setq modus-themes-common-palette-overrides
+ '((fg-heading-1 blue-warmer)
+ (fg-heading-2 yellow-cooler)
+ (fg-heading-3 cyan-cooler)))
-** Option for org-mode block styles
-:properties:
-:alt_title: Org mode blocks
-:description: Choose among plain, gray, or tinted backgrounds
-:custom_id: h:b7e328c0-3034-4db7-9cdf-d5ba12081ca2
-:end:
-#+vindex: modus-themes-org-blocks
+;; Like the above, but with gradient colors
+(setq modus-themes-common-palette-overrides
+ '((fg-heading-1 blue)
+ (fg-heading-2 cyan)
+ (fg-heading-3 green)))
-Brief: Set the overall style of Org code blocks, quotes, and the like.
+;; Add color to level 1 heading, but use the main foreground for
+;; others
+(setq modus-themes-common-palette-overrides
+ '((fg-heading-1 blue)
+ (fg-heading-2 fg-main)
+ (fg-heading-3 fg-main)))
-Symbol: ~modus-themes-org-blocks~ (=choice= type)
+;; Apply colorful foreground, background, and overline (headings 0-8)
+(setq modus-themes-common-palette-overrides
+ '((fg-heading-1 blue-warmer)
+ (bg-heading-1 bg-blue-nuanced)
+ (overline-heading-1 blue)))
-Possible values:
+;; Apply gray scale foreground, background, and overline (headings 0-8)
+(setq modus-themes-common-palette-overrides
+ '((fg-heading-1 fg-main)
+ (bg-heading-1 bg-dim)
+ (overline-heading-1 border)))
+#+end_src
-1. ~nil~ (default)
-2. ~gray-background~ (value ~grayscale~ exists for backward compatibility)
-3. ~tinted-background~ (value ~rainbow~ exists for backward compatibility)
-
-Nil (the default) means that the block has no background of its own: it
-uses the one that applies to the rest of the buffer. In this case, the
-delimiter lines have a gray color for their text, making them look
-exactly like all other Org properties.
-
-Option ~gray-background~ applies a subtle gray background to the block's
-contents. It also affects the begin and end lines of the block as they
-get another shade of gray as their background, which differentiates them
-from the contents of the block. All background colors extend to the
-edge of the window, giving the area a rectangular, "blocky"
-presentation.
-
-Option ~tinted-background~ uses a slightly colored background for the
-contents of the block. The exact color will depend on the programming
-language and is controlled by the variable ~org-src-block-faces~ (refer to
-the theme's source code for the current association list). For this to
-take effect, the Org buffer needs to be restarted with ~org-mode-restart~.
-In this scenario, it may be better to inhibit the extension of the
-delimiter lines' background to the edge of the window because Org does
-not provide a mechanism to update their colors depending on the contents
-of the block. Disable the extension of such backgrounds by setting
-~org-fontify-whole-block-delimiter-line~ to nil.
-
-Code blocks use their major mode's colors only when the variable
-~org-src-fontify-natively~ is non-~nil~. While quote/verse blocks require
-setting ~org-fontify-quote-and-verse-blocks~ to a non-~nil~ value.
-
-[[#h:f44cc6e3-b0f1-4a5e-8a90-9e48fa557b50][Update Org block delimiter fontification]].
-
-Older versions of the themes provided options ~grayscale~ (or ~greyscale~)
-and ~rainbow~. Those will continue to work as they are aliases for
-~gray-background~ and ~tinted-background~, respectively.
-
-** Option for Org agenda constructs
+Reload the theme for changes to take effect.
+
+*** DIY Make Org block colors more or less colorful
:properties:
-:alt_title: Org agenda
-:description: Control each element in the presentation of the agenda
-:custom_id: h:68f481bc-5904-4725-a3e6-d7ecfa7c3dbc
+:custom_id: h:f44cc6e3-b0f1-4a5e-8a90-9e48fa557b50
:end:
-#+vindex: modus-themes-org-agenda
-Brief: Control the style of the Org agenda. Multiple parameters are
-available, each with its own options.
+This is one of our practical examples to override the semantic colors
+of the Modus themes ([[#h:df1199d8-eaba-47db-805d-6b568a577bf3][Stylistic variants using palette overrides]]). Here
+we show how to change the presentation of Org blocks (and other such
+blocks like Markdown fenced code sections, though the exact
+presentation depends on each major mode).
-Symbol: ~modus-themes-org-agenda~ (=alist= type, multiple styles)
+The default style of Org blocks is a subtle gray background for the
+contents and for the delimiter lines (the =#+begin_= and =#+end_=
+parts). The text of the delimiter lines is a subtle gray foreground
+color.
-This is an alist that accepts a =(key . value)= combination. Some values
-are specified as a list. Here is a sample, followed by a description of
-all possible combinations:
+[[#h:bb5b396f-5532-4d52-ab13-149ca24854f1][Make inline code in prose use alternative styles]].
#+begin_src emacs-lisp
-(setq modus-themes-org-agenda
- '((header-block . (variable-pitch 1.5))
- (header-date . (grayscale workaholic bold-today 1.2))
- (event . (accented italic varied))
- (scheduled . uniform)
- (habit . traffic-light)))
-#+end_src
+;; Make code blocks (in Org, for example) use a more colorful style
+;; for their delimiter lines as well as their contents. Give this a
+;; purple feel. Make the delimiter lines distinct from the contents.
+(setq modus-themes-common-palette-overrides
+ '((bg-prose-block-contents bg-magenta-nuanced)
+ (bg-prose-block-delimiter bg-lavender)
+ (fg-prose-block-delimiter fg-main)))
-A ~header-block~ key applies to elements that concern the headings which
-demarcate blocks in the structure of the agenda. By default (a ~nil~
-value) those are rendered in a bold typographic weight, plus a height
-that is slightly taller than the default font size. Acceptable values
-come in the form of a list that can include either or both of those
-properties:
+;; As above, but with a more blue feel.
+(setq modus-themes-common-palette-overrides
+ '((bg-prose-block-contents bg-blue-nuanced)
+ (bg-prose-block-delimiter bg-lavender)
+ (fg-prose-block-delimiter fg-main)))
-- ~variable-pitch~ to use a proportionately spaced typeface;
+;; As above, but with a green feel.
+(setq modus-themes-common-palette-overrides
+ '((bg-prose-block-contents bg-green-nuanced)
+ (bg-prose-block-delimiter bg-sage)
+ (fg-prose-block-delimiter fg-main)))
-- 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 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).
+;; As above, but with a yellow/gold feel.
+(setq modus-themes-common-palette-overrides
+ '((bg-prose-block-contents bg-yellow-nuanced)
+ (bg-prose-block-delimiter bg-ochre)
+ (fg-prose-block-delimiter fg-main)))
- 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
- weight means that bold will be used by virtue of inheriting the ~bold~
- face.
-
-[[#h:2793a224-2109-4f61-a106-721c57c01375][Configure bold and italic faces]].
-
-In case both a number and ~no-scale~ are in the list, the latter takes
-precedence. If two numbers are specified, the first one is applied.
+;; As above, but with a slightly more red feel.
+(setq modus-themes-common-palette-overrides
+ '((bg-prose-block-contents bg-red-nuanced)
+ (bg-prose-block-delimiter bg-ochre)
+ (fg-prose-block-delimiter fg-main)))
+#+end_src
-Example usage:
+The previous examples differentiate the delimiter lines from the
+block's contents. Though we can mimic the default aesthetic of a
+uniform background, while changing the applicable colors. Here are
+some nice combinations:
#+begin_src emacs-lisp
-(header-block . nil)
-(header-block . (1.5))
-(header-block . (no-scale))
-(header-block . (variable-pitch 1.5))
-(header-block . (variable-pitch 1.5 semibold))
-#+end_src
+;; Solid green style.
+(setq modus-themes-common-palette-overrides
+ '((bg-prose-block-contents bg-green-nuanced)
+ (bg-prose-block-delimiter bg-green-nuanced)
+ (fg-prose-block-delimiter green-warmer)))
-A ~header-date~ key covers date headings. Dates use only a foreground
-color by default (a ~nil~ value), with weekdays and weekends having a
-slight difference in hueness. The current date has an added gray
-background. This key accepts a list of values that can include any of
-the following properties:
+;; Solid yellow style.
+(setq modus-themes-common-palette-overrides
+ '((bg-prose-block-contents bg-yellow-nuanced)
+ (bg-prose-block-delimiter bg-yellow-nuanced)
+ (fg-prose-block-delimiter yellow-cooler)))
-- ~grayscale~ to make weekdays use the main foreground color and
- weekends a more subtle gray;
+;; Solid cyan style.
+(setq modus-themes-common-palette-overrides
+ '((bg-prose-block-contents bg-cyan-nuanced)
+ (bg-prose-block-delimiter bg-cyan-nuanced)
+ (fg-prose-block-delimiter cyan-cooler)))
+#+end_src
-- ~workaholic~ to make weekdays and weekends look the same in
- terms of color;
+[ Combine the above with a suitable mode line style for maximum effect
+ ([[#h:e8d781be-eefc-4a81-ac4e-5ed156190df7][DIY Make the active mode line colorful]]). ]
-- ~bold-today~ to apply a bold typographic weight to the current
- date;
+Finally, the following makes code blocks have no distinct background.
+The minimal styles are applied to the delimiter lines, which only use
+a subtle gray foreground. This was the default for the Modus themes up
+until version 4.3.0.
-- ~bold-all~ to render all date headings in a bold weight;
+#+begin_src emacs-lisp
+;; Make code blocks more minimal, so that (i) the delimiter lines have
+;; no background, (ii) the delimiter foreground is a subtle gray, and
+;; (iii) the block contents have no distinct background either. This
+;; was the default in versions of the Modus themes before 4.4.0
+(setq modus-themes-common-palette-overrides
+ '((bg-prose-block-contents unspecified)
+ (bg-prose-block-delimiter unspeficied)
+ (fg-prose-block-delimiter fg-dim)))
+#+end_src
-- ~underline-today~ applies an underline to the current date while
- removing the background it has by default;
+[[#h:8c842804-43b7-4287-b4e9-8c07d04d1f89][DIY Use colored Org source blocks per language]].
-- 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). 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.
+*** DIY Make Org agenda more or less colorful
+:PROPERTIES:
+:CUSTOM_ID: h:a5af0452-a50f-481d-bf60-d8143f98105f
+:END:
-For example:
+This is one of our practical examples to override the semantic colors
+of the Modus themes ([[#h:df1199d8-eaba-47db-805d-6b568a577bf3][Stylistic variants using palette overrides]]).
+Here we provide three distinct code blocks. The first adds
+alternative and more varied colors to the Org agenda (and related).
+The second uses faint coloration. The third makes the agenda use
+various shades of blue. Mix and match at will, while also combining
+these styles with what we show in the other chapters with practical
+stylistic variants.
#+begin_src emacs-lisp
-(header-date . nil)
-(header-date . (workaholic))
-(header-date . (grayscale bold-all))
-(header-date . (grayscale workaholic))
-(header-date . (grayscale workaholic bold-today))
-(header-date . (grayscale workaholic bold-today scale-heading))
-#+end_src
-
-An ~event~ key covers (i) headings with a plain time stamp that are
-shown on the agenda, also known as events, (ii) entries imported from
-the diary, and (iii) other items that derive from a symbolic expression
-or sexp (phases of the moon, holidays, etc.). By default all those look
-the same and have a subtle foreground color (the default is a ~nil~ value
-or an empty list). This key accepts a list of properties. Those are:
-
-- ~accented~ applies an accent value to the event's foreground,
- replacing the original gray. It makes all entries stand out more.
-- ~italic~ adds a slant to the font's forms (italic or oblique forms,
- depending on the typeface).
-- ~varied~ differentiates between events with a plain time stamp and
- entries that are generated from either the diary or a symbolic
- expression. It generally puts more emphasis on events. When ~varied~
- is combined with ~accented~, it makes only events use an accent color,
- while diary/sexp entries retain their original subtle foreground.
- When ~varied~ is used in tandem with ~italic~, it applies a slant only
- to diary and sexp entries, not events. And when ~varied~ is the sole
- property passed to the ~event~ key, it has the same meaning as the
- list (italic varied). The combination of ~varied~, ~accented~,
- ~italic~ covers all of the aforementioned cases.
+;; Make the Org agenda use alternative and varied colors.
+(setq modus-themes-common-palette-overrides
+ '((date-common cyan) ; default value (for timestamps and more)
+ (date-deadline red-warmer)
+ (date-event magenta-warmer)
+ (date-holiday blue) ; for M-x calendar
+ (date-now yellow-warmer)
+ (date-scheduled magenta-cooler)
+ (date-weekday cyan-cooler)
+ (date-weekend blue-faint)))
+#+end_src
-For example:
+An example with faint coloration:
#+begin_src emacs-lisp
-(event . nil)
-(event . (italic))
-(event . (accented italic))
-(event . (accented italic varied))
+;; Make the Org agenda use faint colors.
+(setq modus-themes-common-palette-overrides
+ '((date-common cyan-faint) ; for timestamps and more
+ (date-deadline red-faint)
+ (date-event fg-alt) ; default
+ (date-holiday magenta) ; default (for M-x calendar)
+ (date-now fg-main) ; default
+ (date-scheduled yellow-faint)
+ (date-weekday fg-alt)
+ (date-weekend fg-dim)))
#+end_src
-A ~scheduled~ key applies to tasks with a scheduled date. By default (a
-~nil~ value), those use varying shades of yellow to denote (i) a past or
-current date and (ii) a future date. Valid values are symbols:
-
-- ~nil~ (default);
-- ~uniform~ to make all scheduled dates the same color;
-- ~rainbow~ to use contrasting colors for past, present, future
- scheduled dates.
-
-For example:
+A third example that makes the agenda more blue:
#+begin_src emacs-lisp
-(scheduled . nil)
-(scheduled . uniform)
-(scheduled . rainbow)
-#+end_src
-
-A ~habit~ key applies to the ~org-habit~ graph. All possible value are
-passed as a symbol. Those are:
-
-- The default (~nil~) is meant to conform with the original aesthetic of
- ~org-habit~. It employs all four color codes that correspond to the
- org-habit states---clear, ready, alert, and overdue---while
- distinguishing between their present and future variants. This
- results in a total of eight colors in use: red, yellow, green, blue,
- in tinted and shaded versions. They cover the full set of information
- provided by the ~org-habit~ consistency graph.
-- ~simplified~ is like the default except that it removes the dichotomy
- between current and future variants by applying uniform color-coded
- values. It applies a total of four colors: red, yellow, green, blue.
- They produce a simplified consistency graph that is more legible (or
- less busy) than the default. The intent is to shift focus towards the
- distinction between the four states of a habit task, rather than each
- state's present/future outlook.
-- ~traffic-light~ further reduces the available colors to red, yellow, and
- green. As in ~simplified~, present and future variants appear
- uniformly, but differently from it, the ~clear~ state is rendered in a
- green hue, instead of the original blue. This is meant to capture the
- use-case where a habit task being too early is less important than it
- being too late. The difference between ready and clear states is
- 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 color deficiency by
- substituting every instance of green with blue or cyan (depending on
- the specifics).
-
-[[#h:3ed03a48-20d8-4ce7-b214-0eb7e4c79abe][Option for red-green color deficiency or deuteranopia]].
+;; Make the Org agenda use more blue instead of yellow and red.
+(setq modus-themes-common-palette-overrides
+ '((date-common cyan) ; default value (for timestamps and more)
+ (date-deadline blue-cooler)
+ (date-event blue-faint)
+ (date-holiday blue) ; for M-x calendar
+ (date-now blue-faint)
+ (date-scheduled blue)
+ (date-weekday fg-main)
+ (date-weekend fg-dim)))
+#+end_src
-For example:
+Yet another example that also affects =DONE= and =TODO= keywords:
#+begin_src emacs-lisp
-(habit . nil)
-(habit . simplified)
-(habit . traffic-light)
+;; Change dates to a set of more subtle combinations. Deadlines are a
+;; shade of magenta, scheduled dates are a shade of green that
+;; complements that of the deadlines, weekday headings use the main
+;; foreground color while weekends are a shade of gray. The DONE
+;; keyword is a faint blue-gray while TODO is yellow.
+(setq modus-themes-common-palette-overrides
+ '((date-deadline magenta-warmer)
+ (date-scheduled green-cooler)
+ (date-weekday fg-main)
+ (date-event fg-dim)
+ (date-now blue)
+ (prose-done fg-alt)
+ (prose-todo yellow)))
#+end_src
-Putting it all together, the alist can look like this:
+Reload the theme for changes to take effect.
+
+*** DIY Make inline code in prose use alternative styles
+:PROPERTIES:
+:CUSTOM_ID: h:bb5b396f-5532-4d52-ab13-149ca24854f1
+:END:
+
+This is one of our practical examples to override the semantic colors
+of the Modus themes ([[#h:df1199d8-eaba-47db-805d-6b568a577bf3][Stylistic variants using palette overrides]]). In
+the following code block we show how to affect constructs such as
+Org's verbatim, code, and macro entries. We also provide mappings for
+tables, property drawers, tags, and code block delimiters, though we
+do not show every possible permutation.
+
+- [[#h:b57bb50b-a863-4ea8-bb38-6de2275fa868][Make TODO and DONE more or less intense]].
+- [[#h:f44cc6e3-b0f1-4a5e-8a90-9e48fa557b50][DIY Make Org block colors more or less colorful]].
#+begin_src emacs-lisp
-'((header-block . (1.5 variable-pitch))
- (header-date . (grayscale workaholic bold-today))
- (event . (accented varied))
- (scheduled . uniform)
- (habit . traffic-light))
+;; A nuanced accented background, combined with a suitable foreground.
+(setq modus-themes-common-palette-overrides
+ '((bg-prose-code bg-green-nuanced)
+ (fg-prose-code green-cooler)
-;; Or else:
-(setq modus-themes-org-agenda
- '((header-block . (1.5 variable-pitch))
- (header-date . (grayscale workaholic bold-today))
- (event . (accented varied))
- (scheduled . uniform)
- (habit . traffic-light)))
-#+end_src
+ (bg-prose-verbatim bg-magenta-nuanced)
+ (fg-prose-verbatim magenta-warmer)
-** Option for the headings' overall style
-:properties:
-:alt_title: Heading styles
-:description: Choose among several styles, also per heading level
-:custom_id: h:271eff19-97aa-4090-9415-a6463c2f9ae1
-:end:
-#+vindex: modus-themes-headings
+ (bg-prose-macro bg-blue-nuanced)
+ (fg-prose-macro magenta-cooler)))
-Brief: Heading styles with optional list of values for levels 0-8.
+;; A more noticeable accented background, combined with a suitable foreground.
+(setq modus-themes-common-palette-overrides
+ '((bg-prose-code bg-sage)
+ (fg-prose-code green-faint)
-Symbol: ~modus-themes-headings~ (=alist= type, multiple properties)
+ (bg-prose-verbatim bg-ochre)
+ (fg-prose-verbatim red-faint)
-This is an alist that accepts a =(key . list-of-values)= combination.
-The key is either a number, representing the heading's level (0-8) or t,
-which pertains to the fallback style.
+ (bg-prose-macro bg-lavender)
+ (fg-prose-macro blue-faint)))
-Level 0 is a special heading: it is used for what counts as a document
-title or equivalent, such as the =#+title= construct we find in Org
-files. Levels 1-8 are regular headings.
+;; Leave the backgrounds without a color and simply make the foregrounds more intense.
+(setq modus-themes-common-palette-overrides
+ '((bg-prose-code unspecified)
+ (fg-prose-code green-intense)
-The list of values covers symbols that refer to properties, as described
-below. Here is a complete sample, followed by a presentation of all
-available properties:
+ (bg-prose-verbatim unspecified)
+ (fg-prose-verbatim magenta-intense)
-#+begin_src emacs-lisp
-(setq modus-themes-headings
- '((1 . (background overline variable-pitch 1.5))
- (2 . (overline rainbow 1.3))
- (3 . (overline 1.1))
- (t . (monochrome))))
+ (bg-prose-macro unspecified)
+ (fg-prose-macro cyan-intense)))
#+end_src
-Properties:
+Reload the theme for changes to take effect.
-+ ~rainbow~
-+ ~overline~
-+ ~background~
-+ ~monochrome~
-+ A font weight, which must be supported by the underlying typeface:
- - ~thin~
- - ~ultralight~
- - ~extralight~
- - ~light~
- - ~semilight~
- - ~regular~
- - ~medium~
- - ~semibold~
- - ~bold~
- - ~heavy~
- - ~extrabold~
- - ~ultrabold~
-+ ~no-bold~ (deprecated alias of a ~regular~ weight)
-+ A floating point as a height multiple of the default or a cons cell in
- the form of =(height . FLOAT)=.
+*** DIY Make mail citations and headers more or less colorful
+:PROPERTIES:
+:CUSTOM_ID: h:7da7a4ad-5d3a-4f11-9796-5a1abed0f0c4
+:END:
-By default (a ~nil~ value for this variable), all headings have a bold
-typographic weight and use a desaturated text color.
+This is one of our practical examples to override the semantic colors
+of the Modus themes ([[#h:df1199d8-eaba-47db-805d-6b568a577bf3][Stylistic variants using palette overrides]]). In
+this section we show how to change the coloration of email message
+headers and citations. Before we show the code, this is the anatomy
+of a message:
+
+#+begin_example message
+From: Protesilaos <info@protesilaos.com>
+To: Modus-Themes Development <~protesilaos/modus-themes@lists.sr.ht>
+Subject: Test subject
+--- Headers above this line; message and citations below ---
+This is some sample text
+
+> > Older quote
+> Newer quote
+#+end_example
-A ~rainbow~ property makes the text color more saturated.
+We thus have the following:
+
+#+begin_src emacs-lisp
+;; Reduce the intensity of mail citations and headers
+(setq modus-themes-common-palette-overrides
+ '((mail-cite-0 cyan-faint)
+ (mail-cite-1 yellow-faint)
+ (mail-cite-2 green-faint)
+ (mail-cite-3 red-faint)
+ (mail-part olive)
+ (mail-recipient indigo)
+ (mail-subject maroon)
+ (mail-other slate)))
+
+;; Make mail citations more intense; adjust the headers accordingly
+(setq modus-themes-common-palette-overrides
+ '((mail-cite-0 blue)
+ (mail-cite-1 yellow)
+ (mail-cite-2 green)
+ (mail-cite-3 magenta)
+ (mail-part magenta-cooler)
+ (mail-recipient cyan)
+ (mail-subject red-warmer)
+ (mail-other cyan-cooler)))
+
+;; Make all citations faint and neutral; make most headers green but
+;; use red for the subject lie so that it stands out
+(setq modus-themes-common-palette-overrides
+ '((mail-cite-0 fg-dim)
+ (mail-cite-1 fg-alt)
+ (mail-cite-2 fg-dim)
+ (mail-cite-3 fg-alt)
+ (mail-part yellow-cooler)
+ (mail-recipient green-cooler)
+ (mail-subject red-cooler)
+ (mail-other green)))
+#+end_src
+
+Reload the theme for changes to take effect.
+
+*** DIY Make the region preserve text colors, plus other styles
+:PROPERTIES:
+:CUSTOM_ID: h:c8605d37-66e1-42aa-986e-d7514c3af6fe
+:END:
-An ~overline~ property draws a line above the area of the heading.
+This is one of our practical examples to override the semantic colors
+of the Modus themes ([[#h:df1199d8-eaba-47db-805d-6b568a577bf3][Stylistic variants using palette overrides]]).
+Here we show how to make the region respect the underlying text colors
+or how to make the background more/less intense while combining it
+with an appropriate foreground value.
-A ~background~ property adds a subtle tinted color to the background of
-the heading.
+[[#h:a5140c9c-18b2-45db-8021-38d0b5074116][Do not extend the region background]].
-A ~monochrome~ property makes the heading the same as the base color,
-which is that of the ~default~ face's foreground. When ~background~ is also
-set, ~monochrome~ changes its color to gray. If both ~monochrome~ and
-~rainbow~ are set, the former takes precedence.
+#+begin_src emacs-lisp
+;; A background with no specific foreground (use foreground of
+;; underlying text)
+(setq modus-themes-common-palette-overrides
+ '((bg-region bg-ochre) ; try to replace `bg-ochre' with `bg-lavender', `bg-sage'
+ (fg-region unspecified)))
-A ~variable-pitch~ property changes the font family of the heading to that
-of the ~variable-pitch~ face (normally a proportionately spaced typeface).
+;; Subtle gray with a prominent blue foreground
+(setq modus-themes-common-palette-overrides
+ '((bg-region bg-dim)
+ (fg-region blue-cooler)))
-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 weight
-means that bold will be used by virtue of inheriting the ~bold~ face.
-For backward compatibility, the ~no-bold~ value is accepted, though
-users are encouraged to specify a ~regular~ weight instead.
+;; Intense magenta background combined with the main foreground
+(setq modus-themes-common-palette-overrides
+ '((bg-region bg-magenta-intense)
+ (fg-region fg-main)))
+#+end_src
-[[#h:2793a224-2109-4f61-a106-721c57c01375][Configure bold and italic faces]].
+Reload the theme for changes to take effect.
-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.
+*** DIY Make mouse highlights more or less colorful
+:PROPERTIES:
+:CUSTOM_ID: h:b5cab69d-d7cb-451c-8ff9-1f545ceb6caf
+:END:
-Combinations of any of those properties are expressed as a list, like in
-these examples:
+This is one of our practical examples to override the semantic colors
+of the Modus themes ([[#h:df1199d8-eaba-47db-805d-6b568a577bf3][Stylistic variants using palette overrides]]). In
+the following code block we show how to affect the semantic color
+mapping that covers mouse hover effects and related highlights:
#+begin_src emacs-lisp
-(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
+;; Make the background an intense yellow
+(setq modus-themes-common-palette-overrides
+ '((bg-hover bg-yellow-intense)))
+
+;; Make the background subtle green
+(setq modus-themes-common-palette-overrides
+ '((bg-hover bg-green-subtle)))
#+end_src
-The order in which the properties are set is not significant.
+Reload the theme for changes to take effect.
-In user configuration files the form may look like this:
+*** DIY Make language underlines less colorful
+:PROPERTIES:
+:CUSTOM_ID: h:03dbd5af-6bae-475e-85a2-cec189f69598
+:END:
+
+This is one of our practical examples to override the semantic colors
+of the Modus themes ([[#h:df1199d8-eaba-47db-805d-6b568a577bf3][Stylistic variants using palette overrides]]).
+Here we show how to affect the color of the underlines that are used
+by code linters and prose spell checkers.
#+begin_src emacs-lisp
-(setq modus-themes-headings
- '((1 . (background overline rainbow 1.5))
- (2 . (background overline 1.3))
- (t . (overline semibold))))
+;; Make the underlines less intense
+(setq modus-themes-common-palette-overrides
+ '((underline-err red-faint)
+ (underline-warning yellow-faint)
+ (underline-note cyan-faint)))
+
+;; Change the color-coding of the underlines
+(setq modus-themes-common-palette-overrides
+ '((underline-err yellow-intense)
+ (underline-warning magenta-intense)
+ (underline-note green-intense)))
#+end_src
-When defining the styles per heading level, it is possible to pass a
-non-~nil~ value (~t~) instead of a list of properties. This will retain the
-original aesthetic for that level. For example:
+Reload the theme for changes to take effect.
+
+*** DIY Make line numbers use alternative styles
+:PROPERTIES:
+:CUSTOM_ID: h:b6466f51-cb58-4007-9ebe-53a27af655c7
+:END:
+
+This is one of our practical examples to override the semantic colors
+of the Modus themes ([[#h:df1199d8-eaba-47db-805d-6b568a577bf3][Stylistic variants using palette overrides]]). In
+this section we show how to affect the ~display-line-numbers-mode~.
#+begin_src emacs-lisp
-(setq modus-themes-headings
- '((1 . t) ; keep the default style
- (2 . (background overline))
- (t . (rainbow)))) ; style for all other headings
+;; Make line numbers less intense
+(setq modus-themes-common-palette-overrides
+ '((fg-line-number-inactive "gray50")
+ (fg-line-number-active fg-main)
+ (bg-line-number-inactive unspecified)
+ (bg-line-number-active unspecified)))
-(setq modus-themes-headings
- '((1 . (background overline))
- (2 . (rainbow semibold))
- (t . t))) ; default style for all other levels
+;; Like the above, but use a shade of red for the current line number
+(setq modus-themes-common-palette-overrides
+ '((fg-line-number-inactive "gray50")
+ (fg-line-number-active red-cooler)
+ (bg-line-number-inactive unspecified)
+ (bg-line-number-active unspecified)))
+
+;; Make all numbers more intense, use a more pronounce gray
+;; background, and make the current line have a colored background
+(setq modus-themes-common-palette-overrides
+ '((fg-line-number-inactive fg-main)
+ (fg-line-number-active fg-main)
+ (bg-line-number-inactive bg-inactive)
+ (bg-line-number-active bg-cyan-intense)))
#+end_src
-For Org users, the extent of the heading depends on the variable
-~org-fontify-whole-heading-line~. This affects the ~overline~ and
-~background~ properties. Depending on the version of Org, there may be
-others, such as ~org-fontify-done-headline~.
+Reload the theme for changes to take effect.
-** Option for variable-pitch font in UI elements
-:properties:
-:alt_title: UI typeface
-:description: Toggle the use of variable-pitch across the User Interface
-:custom_id: h:16cf666c-5e65-424c-a855-7ea8a4a1fcac
-:end:
-#+vindex: modus-themes-variable-pitch-ui
+*** DIY Make diffs use only a foreground
+:PROPERTIES:
+:CUSTOM_ID: h:b3761482-bcbf-4990-a41e-4866fb9dad15
+:END:
-Brief: Toggle the use of proportionately spaced (~variable-pitch~) fonts
-in the User Interface.
+This is one of our practical examples to override the semantic colors
+of the Modus themes ([[#h:df1199d8-eaba-47db-805d-6b568a577bf3][Stylistic variants using palette overrides]]). In
+this section we show how to change diff buffers (e.g. in ~magit~) to
+only use color-coded text without any added background. What we
+basically do is to disable the applicable backgrounds and then
+intensify the foregrounds. Since the deuteranopia-optimized themes do
+not use the red-green color coding, we make an extra set of
+adjustments for them by overriding their palettes directly instead of
+just using the "common" overrides.
-Symbol: ~modus-themes-variable-pitch-ui~ (=boolean= type)
+#+begin_src emacs-lisp
+;; Diffs with only foreground colors. Word-wise ("refined") diffs
+;; have a gray background to draw attention to themselves.
+(setq modus-themes-common-palette-overrides
+ '((bg-added unspecified)
+ (bg-added-faint unspecified)
+ (bg-added-refine bg-inactive)
+ (fg-added green)
+ (fg-added-intense green-intense)
-Possible values:
+ (bg-changed unspecified)
+ (bg-changed-faint unspecified)
+ (bg-changed-refine bg-inactive)
+ (fg-changed yellow)
+ (fg-changed-intense yellow-intense)
-1. ~nil~ (default)
-2. ~t~
+ (bg-removed unspecified)
+ (bg-removed-faint unspecified)
+ (bg-removed-refine bg-inactive)
+ (fg-removed red)
+ (fg-removed-intense red-intense)
-This option concerns User Interface elements that are under the direct
-control of Emacs. In particular: the mode line, header line, tab bar,
-and tab line.
+ (bg-diff-context unspecified)))
-The default is to use the same font as the rest of Emacs, which usually
-is a monospaced family.
+;; Because deuteranopia cannot use the typical red-yellow-green
+;; combination, we need to arrange for a yellow-purple-blue sequence.
+;; Notice that the above covers the "common" overrides, so we do not
+;; need to reproduce the whole list of them.
+(setq modus-operandi-deuteranopia-palette-overrides
+ '((fg-added blue)
+ (fg-added-intense blue-intense)
-With a non-~nil~ value (~t~) apply a proportionately spaced typeface. This
-is done by assigning the ~variable-pitch~ face to the relevant items.
+ (fg-changed magenta-cooler)
+ (fg-changed-intense magenta-intense)
-[[#h:defcf4fc-8fa8-4c29-b12e-7119582cc929][Font configurations for Org and others]].
+ (fg-removed yellow-warmer)
+ (fg-removed-intense yellow-intense)))
-* Advanced customization
-:properties:
-:custom_id: h:f4651d55-8c07-46aa-b52b-bed1e53463bb
-:end:
+(setq modus-vivendi-deuteranopia-palette-overrides
+ '((fg-added blue)
+ (fg-added-intense blue-intense)
-Unlike the predefined customization options which follow a clear pattern
-of allowing the user to quickly specify their preference, the themes
-also provide a more flexible, albeit difficult, mechanism to control
-things with precision ([[#h:bf1c82f2-46c7-4eb2-ad00-dd11fdd8b53f][Customization Options]]).
+ (fg-changed magenta-cooler)
+ (fg-changed-intense magenta-intense)
-This section is of interest only to users who are prepared to maintain
-their own local tweaks and who are willing to deal with any possible
-incompatibilities between versioned releases of the themes. As such,
-they are labeled as "do-it-yourself" or "DIY".
+ (fg-removed yellow)
+ (fg-removed-intense yellow-intense)))
+#+end_src
+
+Reload the theme for changes to take effect.
+
+*** DIY Make deuteranopia diffs red and blue instead of yellow and blue
+:PROPERTIES:
+:CUSTOM_ID: h:16389ea1-4cb6-4b18-9409-384324113541
+:END:
-** More accurate colors in terminal emulators
+This is one of our practical examples to override the semantic colors
+of the Modus themes ([[#h:df1199d8-eaba-47db-805d-6b568a577bf3][Stylistic variants using palette overrides]]). In
+this section we show how to implement a red+blue color coding for
+diffs in the themes ~modus-operandi-deuteranopia~ and
+~modus-vivendi-deuteranopia~. As those themes are optimized for users
+with red-green color deficiency, they do not use the typical red+green
+color coding for diffs, defaulting instead to yellow+blue which are
+discernible. Users with deuteranomaly or, generally, those who like a
+different aesthetic, can use the following to make diffs use the
+red+yellow+blue color coding for removed, changed, and added lines
+respectively. This is achieved by overriding the "changed" and
+"removed" entries to use the colors of regular ~modus-operandi~ and
+~modus-vivendi~.
+
+#+begin_src emacs-lisp
+(setq modus-operandi-deuteranopia-palette-overrides
+ '((bg-changed "#ffdfa9")
+ (bg-changed-faint "#ffefbf")
+ (bg-changed-refine "#fac090")
+ (bg-changed-fringe "#d7c20a")
+ (fg-changed "#553d00")
+ (fg-changed-intense "#655000")
+
+ (bg-removed "#ffd8d5")
+ (bg-removed-faint "#ffe9e9")
+ (bg-removed-refine "#f3b5af")
+ (bg-removed-fringe "#d84a4f")
+ (fg-removed "#8f1313")
+ (fg-removed-intense "#aa2222")))
+
+(setq modus-vivendi-deuteranopia-palette-overrides
+ '((bg-changed "#363300")
+ (bg-changed-faint "#2a1f00")
+ (bg-changed-refine "#4a4a00")
+ (bg-changed-fringe "#8a7a00")
+ (fg-changed "#efef80")
+ (fg-changed-intense "#c0b05f")
+
+ (bg-removed "#4f1119")
+ (bg-removed-faint "#380a0f")
+ (bg-removed-refine "#781a1f")
+ (bg-removed-fringe "#b81a1f")
+ (fg-removed "#ffbfbf")
+ (fg-removed-intense "#ff9095")))
+#+end_src
+
+Reload the theme for changes to take effect.
+
+** DIY More accurate colors in terminal emulators
:PROPERTIES:
:CUSTOM_ID: h:fbb5e254-afd6-4313-bb05-93b3b4f67358
:END:
@@ -2197,7 +2623,7 @@ Another example that can be bound to a key:
: TERM=xterm-direct uxterm -e emacsclient -nw
-** Range of color with terminal emulators
+** DIY Range of color with terminal emulators
:PROPERTIES:
:CUSTOM_ID: h:6b8211b0-d11b-4c00-9543-4685ec3b742f
:END:
@@ -2220,7 +2646,7 @@ 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:
+palette such as by adapting these resources ([[#h:f4d4b71b-2ca5-4c3d-b0b4-9bfd7aa7fb4d][Preview theme colors]]):
#+begin_src emacs-lisp
! Theme: modus-operandi
@@ -2268,29 +2694,7 @@ xterm*color14: #6ae4b9
xterm*color15: #ffffff
#+end_src
-** Visualize the active Modus theme's palette
-:properties:
-:custom_id: h:f4d4b71b-2ca5-4c3d-b0b4-9bfd7aa7fb4d
-:end:
-#+findex: modus-themes-list-colors
-#+findex: modus-themes-list-colors-current
-#+cindex: Preview color values
-
-The command ~modus-themes-list-colors~ prompts for a choice between
-=modus-operandi= and =modus-vivendi= to produce a help buffer that shows a
-preview of each variable in the given theme's color palette. The
-command ~modus-themes-list-colors-current~ skips the prompt, using the
-current Modus theme.
-
-Each row shows a foreground and background coloration using the
-underlying value it references. For example a line with =#a60000= (a
-shade of red) will show red text followed by a stripe with that same
-color as a backdrop.
-
-The name of the buffer describes the given Modus theme. It is thus
-called =*modus-operandi-list-colors*= or =*modus-vivendi-list-colors*=.
-
-** Per-theme customization settings
+** DIY Per-theme customization settings
:properties:
:custom_id: h:a897b302-8e10-4a26-beab-3caaee1e1193
:end:
@@ -2306,12 +2710,12 @@ other).
(defun my-demo-modus-operandi ()
(interactive)
(setq modus-themes-bold-constructs t) ; ENABLE bold
- (modus-themes-load-operandi))
+ (modus-themes-load-theme 'modus-operandi))
(defun my-demo-modus-vivendi ()
(interactive)
(setq modus-themes-bold-constructs nil) ; DISABLE bold
- (modus-themes-load-vivendi))
+ (modus-themes-load-theme 'modus-vivendi))
(defun my-demo-modus-themes-toggle ()
(if (eq (car custom-enabled-themes) 'modus-operandi)
@@ -2325,233 +2729,92 @@ equivalent the themes provide.
For a more elaborate design, it is better to inspect the source code of
~modus-themes-toggle~ and relevant functions.
-** Case-by-case face specs using the themes' palette
-:properties:
-:custom_id: h:1487c631-f4fe-490d-8d58-d72ffa3bd474
-:end:
-#+findex: modus-themes-color
-#+findex: modus-themes-color-alts
-#+cindex: Extracting individual colors
-
-This section is about tweaking individual faces. If you plan to do
-things at scale, consult the next section: [[#h:51ba3547-b8c8-40d6-ba5a-4586477fd4ae][Set multiple faces]].
-
-We already covered in previous sections how to toggle between the themes
-and how to configure options prior to loading. We also explained that
-some of the functions made available to users will fire up a hook that
-can be used to pass tweaks in the post-theme-load phase.
+Reload the theme for changes to take effect.
-Now assume you wish to change a single face, say, the ~cursor~. And you
-would like to get the standard "blue" color value of the active Modus
-theme, whether it is Modus Operandi or Modus Vivendi. To do that, you
-can use the ~modus-themes-color~ function. It accepts a symbol that is
-associated with a color in ~modus-themes-operandi-colors~ and
-~modus-themes-vivendi-colors~. Like this:
-
-#+begin_src emacs-lisp
-(modus-themes-color 'blue)
-#+end_src
+** DIY Do not extend the region background
+:PROPERTIES:
+:CUSTOM_ID: h:a5140c9c-18b2-45db-8021-38d0b5074116
+:END:
-The function always extracts the color value of the active Modus theme.
+By the default, the background of the ~region~ face extends from the
+end of the line to the edge of the window. To limit it to the end of
+the line, we need to override the face's =:extend= attribute. Adding
+this to the Emacs configuration file will suffice:
#+begin_src emacs-lisp
-(progn
- (load-theme 'modus-operandi t)
- (modus-themes-color 'blue)) ; "#0031a9" for `modus-operandi'
-
-(progn
- (load-theme 'modus-vivendi t)
- (modus-themes-color 'blue)) ; "#2fafff" for `modus-vivendi'
+;; Do not extend `region' background past the end of the line.
+(custom-set-faces
+ '(region ((t :extend nil))))
#+end_src
-Do {{{kbd(C-h v)}}} on the aforementioned variables to check all the available
-symbols that can be passed to this function. Or simply invoke the
-command ~modus-themes-list-colors~ to produce a buffer with a preview of
-each entry in the palette.
-
-[[#h:f4d4b71b-2ca5-4c3d-b0b4-9bfd7aa7fb4d][Visualize the active Modus theme's palette]].
+[[#h:c8605d37-66e1-42aa-986e-d7514c3af6fe][Make the region preserve text colors, plus other styles]].
-With that granted, let us expand the example to actually change the
-~cursor~ face's background property. We employ the built-in function of
-~set-face-attribute~:
+** DIY Add padding to the mode line
+:PROPERTIES:
+:CUSTOM_ID: h:5a0c58cc-f97f-429c-be08-927b9fbb0a9c
+:END:
-#+begin_src emacs-lisp
-(set-face-attribute 'cursor nil :background (modus-themes-color 'blue))
-#+end_src
+[ Consider using the ~spacious-padding~ package from GNU ELPA (by
+ Protesilaos) for more than just the mode line. ]
-If you evaluate this form, your cursor will become blue. But if you
-change themes, such as with ~modus-themes-toggle~, your edits will be
-lost, because the newly loaded theme will override the ~:background~
-attribute you had assigned to that face.
+Emacs faces do not have a concept of "padding" for the space between
+the text and its box boundaries. We can approximate the effect by
+adding a =:box= attribute, making its border several pixels thick, and
+using the mode line's background color for it. This way the thick
+border will not stand out and will appear as a continuation of the
+mode line.
-For such changes to persist, we need to make them after loading the
-theme. So we rely on ~modus-themes-after-load-theme-hook~, which gets
-called from ~modus-themes-load-operandi~, ~modus-themes-load-vivendi~, as
-well as the command ~modus-themes-toggle~. Here is a sample function that
-tweaks two faces and then gets added to the hook:
+[[#h:51ba3547-b8c8-40d6-ba5a-4586477fd4ae][Use theme colors in code with modus-themes-with-colors]].
#+begin_src emacs-lisp
-(defun my-modus-themes-custom-faces ()
- (set-face-attribute 'cursor nil :background (modus-themes-color 'blue))
- (set-face-attribute 'font-lock-type-face nil :foreground (modus-themes-color 'magenta-alt)))
+(defun my-modus-themes-custom-faces (&rest _)
+ (modus-themes-with-colors
+ (custom-set-faces
+ ;; Add "padding" to the mode lines
+ `(mode-line ((,c :box (:line-width 10 :color ,bg-mode-line-active))))
+ `(mode-line-inactive ((,c :box (:line-width 10 :color ,bg-mode-line-inactive)))))))
(add-hook 'modus-themes-after-load-theme-hook #'my-modus-themes-custom-faces)
#+end_src
-[[#h:86f6906b-f090-46cc-9816-1fe8aeb38776][A theme-agnostic hook for theme loading]].
-
-Using this principle, it is possible to override the styles of faces
-without having to find color values for each case.
-
-Another application is to control the precise weight for bold
-constructs. This is particularly useful if your typeface has several
-variants such as "heavy", "extrabold", "semibold". All you have to do
-is edit the ~bold~ face. For example:
-
-#+begin_src emacs-lisp
-(set-face-attribute 'bold nil :weight 'semibold)
-#+end_src
-
-Remember to use the custom function and hook combo we demonstrated
-above. Because the themes do not hard-wire a specific weight, this
-simple form is enough to change the weight of all bold constructs
-throughout the interface.
-
-Finally, there are cases where you want to tweak colors though wish to
-apply different ones to each theme, say, a blue hue for Modus Operandi
-and a shade of red for Modus Vivendi. To this end, we provide
-~modus-themes-color-alts~ as a convenience function to save you from the
-trouble of writing separate wrappers for each theme. It still returns a
-single value by querying either of ~modus-themes-operandi-colors~ and
-~modus-themes-vivendi-colors~, only here you pass the two keys you want,
-first for ~modus-operandi~ then ~modus-vivendi~.
+[[#h:d87673fe-2ce1-4c80-a4b8-be36ca9f2d24][Using a hook at the post-load-theme phase]].
-Take the previous example with the ~cursor~ face:
+The above has the effect of removing the border around the mode lines.
+In older versions of the themes, we provided the option for a padded
+mode line which could also have borders around it. Those were not
+real border, however, but an underline and an overline. Adjusting the
+above:
#+begin_src emacs-lisp
-;; Blue for `modus-operandi' and red for `modus-vivendi'
-(set-face-attribute 'cursor nil :background (modus-themes-color-alts 'blue 'red))
-#+end_src
-
-** Face specs at scale using the themes' palette
-:properties:
-:custom_id: h:51ba3547-b8c8-40d6-ba5a-4586477fd4ae
-:end:
-#+findex: modus-themes-with-colors
-#+cindex: Extracting colors en masse
-
-The examples here are for large scale operations. For simple, one-off
-tweaks, you may prefer the approach documented in the previous section
-([[#h:1487c631-f4fe-490d-8d58-d72ffa3bd474][Case-by-case face specs using the themes' palette]]).
-
-The ~modus-themes-with-colors~ macro lets you retrieve multiple color
-values by employing the backquote/backtick and comma notation. The
-values are stored in the alists ~modus-themes-operandi-colors~ and
-~modus-themes-vivendi-colors~, while the macro always queries that of the
-active Modus theme (preview the current palette with the command
-~modus-themes-list-colors~).
-
-[[#h:f4d4b71b-2ca5-4c3d-b0b4-9bfd7aa7fb4d][Visualize the active Modus theme's palette]].
-
-Here is an abstract example that just returns a list of color values
-while ~modus-operandi~ is enabled:
-
-#+begin_src emacs-lisp
-(modus-themes-with-colors
- (list fg-main
- blue-faint
- magenta
- magenta-alt-other
- cyan-alt-other
- fg-special-cold
- blue-alt
- magenta-faint
- cyan
- fg-main
- green-faint
- red-alt-faint
- blue-alt-faint
- fg-special-warm
- cyan-alt
- blue))
-;; =>
-;; ("#000000" "#002f88" "#721045" "#5317ac"
-;; "#005a5f" "#093060" "#2544bb" "#752f50"
-;; "#00538b" "#000000" "#104410" "#702f00"
-;; "#003f78" "#5d3026" "#30517f" "#0031a9")
-#+end_src
-
-Getting a list of colors may have its applications, though what you are
-most likely interested in is how to use those variables to configure
-several faces at once. To do so we can rely on the built-in
-~custom-set-faces~ function, which sets face specifications for the
-special ~user~ theme. That "theme" gets applied on top of regular themes
-like ~modus-operandi~ and ~modus-vivendi~.
-
-This is how it works:
-
-#+begin_src emacs-lisp
-(modus-themes-with-colors
- (custom-set-faces
- `(cursor ((,class :background ,blue)))
- `(mode-line ((,class :background ,yellow-nuanced-bg
- :foreground ,yellow-nuanced-fg)))
- `(mode-line-inactive ((,class :background ,blue-nuanced-bg
- :foreground ,blue-nuanced-fg)))))
-#+end_src
-
-The above snippet will immediately refashion the faces it names once it
-is evaluated. However, if you switch between the Modus themes, say,
-from ~modus-operandi~ to ~modus-vivendi~, the colors will not get updated to
-match those of the new theme. To make things work across the themes, we
-need to employ the same technique we discussed in the previous section,
-namely, to pass our changes at the post-theme-load phase via a hook.
-
-The themes provide the ~modus-themes-after-load-theme-hook~, which gets
-called from ~modus-themes-load-operandi~, ~modus-themes-load-vivendi~, as
-well as the command ~modus-themes-toggle~. With this knowledge, you can
-wrap the macro in a function and then assign that function to the hook.
-Thus:
-
-#+begin_src emacs-lisp
-(defun my-modus-themes-custom-faces ()
+(defun my-modus-themes-custom-faces (&rest _)
(modus-themes-with-colors
(custom-set-faces
- `(cursor ((,class :background ,blue)))
- `(mode-line ((,class :background ,yellow-nuanced-bg
- :foreground ,yellow-nuanced-fg)))
- `(mode-line-inactive ((,class :background ,blue-nuanced-bg
- :foreground ,blue-nuanced-fg))))))
+ ;; Add "padding" to the mode lines
+ `(mode-line ((,c :underline ,border-mode-line-active
+ :overline ,border-mode-line-active
+ :box (:line-width 10 :color ,bg-mode-line-active))))
+ `(mode-line-inactive ((,c :underline ,border-mode-line-inactive
+ :overline ,border-mode-line-inactive
+ :box (:line-width 10 :color ,bg-mode-line-inactive)))))))
+
+;; ESSENTIAL to make the underline move to the bottom of the box:
+(setq x-underline-at-descent-line t)
(add-hook 'modus-themes-after-load-theme-hook #'my-modus-themes-custom-faces)
#+end_src
-[[#h:86f6906b-f090-46cc-9816-1fe8aeb38776][A theme-agnostic hook for theme loading]].
-
-To discover the faces defined by all loaded libraries, you may do
-{{{kbd(M-x list-faces-display)}}}. Be warned that when you ~:inherit~ a face
-you are introducing an implicit dependency, so try to avoid doing so for
-libraries other than the built-in {{{file(faces.el)}}} (or at least understand
-that things may break if you inherit from a yet-to-be-loaded face).
+The reason we no longer provide this option is because it depends on a
+non-~nil~ value for ~x-underline-at-descent-line~. That variable
+affects ALL underlines, including those of links. The effect is
+intrusive and looks awkard in prose.
-Also bear in mind that these examples are meant to work with the Modus
-themes. If you are cycling between multiple themes you may encounter
-unforeseen issues, such as the colors of the Modus themes being applied
-to a non-Modus item.
+As such, the Modus themes no longer provide that option but instead
+offer this piece of documentation to make the user fully aware of the
+state of affairs.
-Finally, note that you can still use other functions where those make
-sense. For example, the ~modus-themes-color-alts~ that was discussed in
-the previous section. Adapt the above example like this:
-
-#+begin_src emacs-lisp
-...
-(modus-themes-with-colors
- (custom-set-faces
- `(cursor ((,class :background ,(modus-themes-color-alts 'blue 'green))))
- ...))
-#+end_src
+Reload the theme for changes to take effect.
-** Remap face with local value
+** DIY Remap face with local value
:properties:
:custom_id: h:7a93cb6f-4eca-4d56-a85c-9dcd813d6b0f
:end:
@@ -2564,7 +2827,7 @@ activates ~hl-line-mode~, but we wish to keep it distinct from other
buffers. This is where ~face-remap-add-relative~ can be applied and may
be combined with ~modus-themes-with-colors~ to deliver consistent results.
-[[#h:51ba3547-b8c8-40d6-ba5a-4586477fd4ae][Face specs at scale using the themes' palette]].
+[[#h:51ba3547-b8c8-40d6-ba5a-4586477fd4ae][Use theme colors in code with modus-themes-with-colors]].
In this example we will write a simple interactive function that adjusts
the background color of the ~region~ face. This is the sample code:
@@ -2572,12 +2835,12 @@ the background color of the ~region~ face. This is the sample code:
#+begin_src emacs-lisp
(defvar my-rainbow-region-colors
(modus-themes-with-colors
- `((red . ,red-subtle-bg)
- (green . ,green-subtle-bg)
- (yellow . ,yellow-subtle-bg)
- (blue . ,blue-subtle-bg)
- (magenta . ,magenta-subtle-bg)
- (cyan . ,cyan-subtle-bg)))
+ `((red . ,bg-red-subtle)
+ (green . ,bg-green-subtle)
+ (yellow . ,bg-yellow-subtle)
+ (blue . ,bg-blue-subtle)
+ (magenta . ,bg-magenta-subtle)
+ (cyan . ,bg-cyan-subtle)))
"Sample list of color values for `my-rainbow-region'.")
(defun my-rainbow-region (color)
@@ -2613,774 +2876,17 @@ Perhaps you may wish to generalize those findings in to a set of
functions that also accept an arbitrary face. We shall leave the
experimentation up to you.
-** Cycle through arbitrary colors
-:properties:
-:custom_id: h:77dc4a30-b96a-4849-85a8-fee3c2995305
-:end:
-#+cindex: Cycle colors
-
-Users may opt to customize individual faces of the themes to accommodate
-their particular needs. One such case is with the color intensity of
-comments, specifically the foreground of ~font-lock-comment-face~. The
-Modus themes set that to a readable value, in accordance with their
-accessibility objective, though users may prefer to lower the overall
-contrast on an on-demand basis.
-
-One way to achieve this is to design a command that cycles through three
-distinct levels of intensity, though the following can be adapted to any
-kind of cyclic behavior, such as to switch between red, green, and blue.
-
-In the following example, we employ the ~modus-themes-color~ function
-which reads a symbol that represents an entry in the active theme's
-color palette ([[#h:1487c631-f4fe-490d-8d58-d72ffa3bd474][Case-by-case face specs using the themes' palette]]).
-Those are stored in ~my-modus-themes-comment-colors~.
-
-#+begin_src emacs-lisp
-(defvar my-modus-themes-comment-colors
- ;; We are abusing the palette here, as those colors have their own
- ;; purpose in the palette, so please ignore the semantics of their
- ;; names.
- '((low . bg-region)
- (medium . bg-tab-inactive-alt)
- (high . fg-alt))
- "Alist of levels of intensity mapped to color palette entries.
-The entries are found in `modus-themes-operandi-colors' or
-`modus-themes-vivendi-colors'.")
-
-(defvar my-modus-themes--adjust-comment-color-state nil
- "The cyclic state of `my-modus-themes-adjust-comment-color'.
-For internal use.")
-
-(defun my-modus-themes--comment-foreground (degree state)
- "Set `font-lock-comment-face' foreground.
-Use `my-modus-themes-comment-colors' to extract the color value
-for each level of intensity.
-
-This is complementary to `my-modus-themes-adjust-comment-color'."
- (let ((palette-colors my-modus-themes-comment-colors))
- (set-face-foreground
- 'font-lock-comment-face
- (modus-themes-color (alist-get degree palette-colors)))
- (setq my-modus-themes--adjust-comment-color-state state)
- (message "Comments are set to %s contrast" degree)))
-
-(defun my-modus-themes-adjust-comment-color ()
- "Cycle through levels of intensity for comments.
-The levels are determined by `my-modus-themes-comment-colors'."
- (interactive)
- (pcase my-modus-themes--adjust-comment-color-state
- ('nil
- (my-modus-themes--comment-foreground 'low 1))
- (1
- (my-modus-themes--comment-foreground 'medium 2))
- (_
- (my-modus-themes--comment-foreground 'high nil))))
-#+end_src
-
-With the above, {{{kbd(M-x my-modus-themes-adjust-comment-color)}}} will cycle
-through the three levels of intensity that have been specified.
-
-Another approach is to not read from the active theme's color palette
-and instead provide explicit color values, either in hexadecimal RGB
-notation (like =#123456=) or as the names that are displayed in the output
-of {{{kbd(M-x list-colors-display)}}}. In this case, the alist with the
-colors will have to account for the active theme, so as to set the
-appropriate colors. While this introduces a bit more complexity, it
-ultimately offers greater flexibility on the choice of colors for such a
-niche functionality (so there is no need to abuse the palette of the
-active Modus theme):
-
-#+begin_src emacs-lisp
-(defvar my-modus-themes-comment-colors
- '((light . ((low . "gray75")
- (medium . "gray50")
- (high . "#505050"))) ; the default for `modus-operandi'
-
- (dark . ((low . "gray25")
- (medium . "gray50")
- (high . "#a8a8a8")))) ; the default for `modus-vivendi'
- "Alist of levels of intensity mapped to color values.
-For such colors, consult the command `list-colors-display'. Pass
-the name of a color or its hex value.")
-
-(defvar my-modus-themes--adjust-comment-color-state nil
- "The cyclic state of `my-modus-themes-adjust-comment-color'.
-For internal use.")
-
-(defun my-modus-themes--comment-foreground (degree state)
- "Set `font-lock-comment-face' foreground.
-Use `my-modus-themes-comment-colors' to extract the color value
-for each level of intensity.
-
-This is complementary to `my-modus-themes-adjust-comment-color'."
- (let* ((colors my-modus-themes-comment-colors)
- (levels (pcase (car custom-enabled-themes)
- ('modus-operandi (alist-get 'light colors))
- ('modus-vivendi (alist-get 'dark colors)))))
- (set-face-foreground
- 'font-lock-comment-face
- (alist-get degree levels))
- (setq my-modus-themes--adjust-comment-color-state state)
- (message "Comments are set to %s contrast" degree)))
-
-(defun my-modus-themes-adjust-comment-color ()
- "Cycle through levels of intensity for comments.
-The levels are determined by `my-modus-themes-comment-colors'."
- (interactive)
- (pcase my-modus-themes--adjust-comment-color-state
- ('nil
- (my-modus-themes--comment-foreground 'low 1))
- (1
- (my-modus-themes--comment-foreground 'medium 2))
- (_
- (my-modus-themes--comment-foreground 'high nil))))
-#+end_src
-
-The effect of the above configurations on ~font-lock-comment-face~ is
-global. To make it buffer-local, one must tweak the code to employ the
-function ~face-remap-add-relative~ ([[#h:7a93cb6f-4eca-4d56-a85c-9dcd813d6b0f][Remap face with local value]]).
-
-So this form in ~my-modus-themes--comment-foreground~:
-
-#+begin_src emacs-lisp
-;; example 1
-(...
- (set-face-foreground
- 'font-lock-comment-face
- (modus-themes-color (alist-get degree palette-colors)))
- ...)
-
-;; example 2
-(...
- (set-face-foreground
- 'font-lock-comment-face
- (alist-get degree levels))
- ...)
-#+end_src
-
-Must become this:
-
-#+begin_src emacs-lisp
-;; example 1
-(...
- (face-remap-add-relative
- 'font-lock-comment-face
- `(:foreground ,(modus-themes-color (alist-get degree palette-colors))))
- ...)
-
-;; example 2
-(...
- (face-remap-add-relative
- 'font-lock-comment-face
- `(:foreground ,(alist-get degree levels)))
- ...)
-#+end_src
-
-** Override colors
-:properties:
-:custom_id: h:307d95dd-8dbd-4ece-a543-10ae86f155a6
-:end:
-#+vindex: modus-themes-operandi-color-overrides
-#+vindex: modus-themes-vivendi-color-overrides
-#+cindex: Change a theme's colors
-
-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 customizations,
-overriding must be done before loading the affected theme.
-
-[[#h:f4d4b71b-2ca5-4c3d-b0b4-9bfd7aa7fb4d][Visualize the active Modus theme's palette]].
-
-Let us approach the present topic one step at a time. Here is a
-simplified excerpt of the default palette for Modus Operandi with some
-basic background values that apply to buffers and the mode line
-(remember to inspect the actual value to find out all the associations
-that can be overridden):
-
-#+begin_src emacs-lisp
-(defconst modus-themes-operandi-colors
- '((bg-main . "#ffffff")
- (bg-dim . "#f8f8f8")
- (bg-alt . "#f0f0f0")
- (bg-active . "#d7d7d7")
- (bg-inactive . "#efefef")))
-#+end_src
-
-As one can tell, we bind a key to a hexadecimal RGB color value. Now
-say we wish to override those specific values and have our changes
-propagate to all faces that use those keys. We could write something
-like this, which adds a subtle ocher tint:
-
-#+begin_src emacs-lisp
-(setq modus-themes-operandi-color-overrides
- '((bg-main . "#fefcf4")
- (bg-dim . "#faf6ef")
- (bg-alt . "#f7efe5")
- (bg-active . "#e8dfd1")
- (bg-inactive . "#f6ece5")))
-#+end_src
-
-Once this is evaluated, any subsequent loading of ~modus-operandi~ will
-use those values instead of the defaults. No further intervention is
-required.
-
-To reset the changes, we apply this and reload the theme:
-
-#+begin_src emacs-lisp
-(setq modus-themes-operandi-color-overrides nil)
-#+end_src
-
-Users who wish to leverage such a mechanism can opt to implement it
-on-demand by means of a global minor mode. The following snippet covers
-both themes and expands to some more associations in the palette:
-
-#+begin_src emacs-lisp
-(define-minor-mode my-modus-themes-tinted
- "Tweak some Modus themes colors."
- :init-value nil
- :global t
- (if my-modus-themes-tinted
- (setq modus-themes-operandi-color-overrides
- '((bg-main . "#fefcf4")
- (bg-dim . "#faf6ef")
- (bg-alt . "#f7efe5")
- (bg-hl-line . "#f4f0e3")
- (bg-active . "#e8dfd1")
- (bg-inactive . "#f6ece5")
- (bg-region . "#c6bab1")
- (bg-header . "#ede3e0")
- (bg-tab-active . "#fdf6eb")
- (bg-tab-inactive . "#c8bab8"))
- modus-themes-vivendi-color-overrides
- '((bg-main . "#100b17")
- (bg-dim . "#161129")
- (bg-alt . "#181732")
- (bg-hl-line . "#191628")
- (bg-active . "#282e46")
- (bg-inactive . "#1a1e39")
- (bg-region . "#393a53")
- (bg-header . "#202037")
- (bg-tab-active . "#120f18")
- (bg-tab-inactive . "#3a3a5a")))
- (setq modus-themes-operandi-color-overrides nil
- modus-themes-vivendi-color-overrides nil)))
-#+end_src
-
-A more neutral style for ~modus-themes-operandi-color-overrides~ can
-look like this:
-
-#+begin_src emacs-lisp
-'((bg-main . "#f7f7f7")
- (bg-dim . "#f2f2f2")
- (bg-alt . "#e8e8e8")
- (bg-hl-line . "#eaeaef")
- (bg-active . "#e0e0e0")
- (bg-inactive . "#e6e6e6")
- (bg-region . "#b5b5b5")
- (bg-header . "#e4e4e4")
- (bg-tab-active . "#f5f5f5")
- (bg-tab-inactive . "#c0c0c0"))
-#+end_src
-
-With those in place, one can use {{{kbd(M-x my-modus-themes-tinted)}}}
-and then load the Modus theme of their choice. The new palette subset
-will come into effect: subtle ocher tints (or shades of gray) for Modus
-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 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
-be done programmatically ([[#h:4589acdc-2505-41fc-9f5e-699cfc45ab00][Override color saturation]]).
-
-The above are expanded into a fully fledged derivative elsewhere in this
-document ([[#h:736c0ff5-8c9c-4565-82cf-989e57d07d4a][Override colors completely]]).
-
-For manual interventions it is advised to inspect the source code of
-~modus-themes-operandi-colors~ and ~modus-themes-vivendi-colors~ for the
-inline commentary: it explains what the intended use of each palette
-subset is.
-
-Furthermore, users may benefit from the ~modus-themes-contrast~ function
-that we provide: [[#h:02e25930-e71a-493d-828a-8907fc80f874][test color combinations]]. It measures the contrast
-ratio between two color values, so it can help in overriding the palette
-(or a subset thereof) without making the end result inaccessible.
-
-** Override color saturation
-:properties:
-:custom_id: h:4589acdc-2505-41fc-9f5e-699cfc45ab00
-:end:
-#+cindex: Change a theme's color saturation
-
-In the previous section we documented how one can override color values
-manually ([[#h:307d95dd-8dbd-4ece-a543-10ae86f155a6][Override colors]]). Here we use a programmatic approach which
-leverages the built-in ~color-saturate-name~ function to adjust the
-saturation of all color values used by the active Modus theme. Our goal
-is to prepare a counterpart of the active theme's palette that holds
-modified color values, adjusted for a percent change in saturation. A
-positive number amplifies the effect, while a negative one will move
-towards a grayscale spectrum.
-
-We start with a function that can be either called from Lisp or invoked
-interactively. In the former scenario, we pass to it the rate of change
-we want. While in the latter, a minibuffer prompt asks for a number to
-apply the desired effect. In either case, we intend to assign anew the
-value of ~modus-themes-operandi-color-overrides~ (light theme) and the
-same for ~modus-themes-vivendi-color-overrides~ (dark theme).
-
-#+begin_src emacs-lisp
-(defun my-modus-themes-saturate (percent)
- "Saturate current Modus theme palette overrides by PERCENT."
- (interactive
- (list (read-number "Saturation by percent: ")))
- (let* ((theme (modus-themes--current-theme))
- (palette (pcase theme
- ('modus-operandi modus-themes-operandi-colors)
- ('modus-vivendi modus-themes-vivendi-colors)
- (_ (error "No Modus theme is active"))))
- (overrides (pcase theme
- ('modus-operandi 'modus-themes-operandi-color-overrides)
- ('modus-vivendi 'modus-themes-vivendi-color-overrides)
- (_ (error "No Modus theme is active")))))
- (let (name cons colors)
- (dolist (cons palette)
- (setq name (color-saturate-name (cdr cons) percent))
- (setq name (format "%s" name))
- (setq cons `(,(car cons) . ,name))
- (push cons colors))
- (set overrides colors))
- (pcase theme
- ('modus-operandi (modus-themes-load-operandi))
- ('modus-vivendi (modus-themes-load-vivendi)))))
-
-;; sample Elisp calls (or call `my-modus-themes-saturate' interactively)
-(my-modus-themes-saturate 50)
-(my-modus-themes-saturate -75)
-#+end_src
-
-Using the above has an immediate effect, as it reloads the active Modus
-theme.
-
-The =my-modus-themes-saturate= function stores new color values in the
-variables ~modus-themes-operandi-color-overrides~ and
-~modus-themes-vivendi-color-overrides~, meaning that it undoes changes
-implemented by the user on individual colors. To have both automatic
-saturation adjustment across the board and retain per-case edits to the
-palette, some tweaks to the above function are required. For example:
-
-#+begin_src emacs-lisp
-(defvar my-modus-themes-vivendi-extra-color-overrides
- '((fg-main . "#ead0c0")
- (bg-main . "#050515"))
- "My bespoke colors for `modus-vivendi'.")
-
-(defvar my-modus-themes-operandi-extra-color-overrides
- '((fg-main . "#1a1a1a")
- (bg-main . "#fefcf4"))
- "My bespoke colors for `modus-operandi'.")
-
-(defun my-modus-themes-saturate (percent)
- "Saturate current Modus theme palette overrides by PERCENT.
-Preserve the color values stored in
-`my-modus-themes-operandi-extra-color-overrides',
-`my-modus-themes-vivendi-extra-color-overrides'."
- (interactive
- (list (read-number "Saturation by percent: ")))
- (let* ((theme (modus-themes--current-theme))
- (palette (pcase theme
- ('modus-operandi modus-themes-operandi-colors)
- ('modus-vivendi modus-themes-vivendi-colors)
- (_ (error "No Modus theme is active"))))
- (overrides (pcase theme
- ('modus-operandi 'modus-themes-operandi-color-overrides)
- ('modus-vivendi 'modus-themes-vivendi-color-overrides)
- (_ (error "No Modus theme is active"))))
- (extra-overrides (pcase theme
- ('modus-operandi my-modus-themes-operandi-extra-color-overrides)
- ('modus-vivendi my-modus-themes-vivendi-extra-color-overrides)
- (_ (error "No Modus theme is active")))))
- (let (name cons colors)
- (dolist (cons palette)
- (setq name (color-saturate-name (cdr cons) percent))
- (setq name (format "%s" name))
- (setq cons `(,(car cons) . ,name))
- (push cons colors))
- (set overrides (append extra-overrides colors)))
- (pcase theme
- ('modus-operandi (modus-themes-load-operandi))
- ('modus-vivendi (modus-themes-load-vivendi)))))
-#+end_src
-
-To disable the effect, one must reset the aforementioned variables of
-the themes to ~nil~. Or specify a command for it, such as by taking
-inspiration from the ~modus-themes-toggle~ we already provide:
-
-#+begin_src emacs-lisp
-(defun my-modus-themes-revert-overrides ()
- "Reset palette overrides and reload active Modus theme."
- (interactive)
- (setq modus-themes-operandi-color-overrides nil
- modus-themes-vivendi-color-overrides nil)
- (pcase (modus-themes--current-theme)
- ('modus-operandi (modus-themes-load-operandi))
- ('modus-vivendi (modus-themes-load-vivendi))))
-#+end_src
+Reload the theme for changes to take effect.
-** Override colors through blending
-:properties:
-:custom_id: h:80c326bf-fe32-47b2-8c59-58022256fd6e
-:end:
-#+cindex: Change theme colors through blending
-
-This is yet another method of overriding color values.
-
-[[#h:307d95dd-8dbd-4ece-a543-10ae86f155a6][Override colors]].
-
-[[#h:4589acdc-2505-41fc-9f5e-699cfc45ab00][Override color saturation]].
-
-Building on ideas and concepts from the previous sections, this method
-blends the entire palette at once with the chosen colors. The function
-~my-modus-themes-interpolate~ blends two colors, taking a value from the
-themes and mixing it with a user-defined color to arrive at a midpoint.
-This scales to all background and foreground colors with the help of the
-~my-modus-themes-tint-palette~ function.
-
-#+begin_src emacs-lisp
-(setq my-modus-operandi-bg-blend "#fbf1c7"
- my-modus-operandi-fg-blend "#3a6084"
- my-modus-vivendi-bg-blend "#3a4042"
- my-modus-vivendi-fg-blend "#d7b765")
-
-;; Adapted from the `kurecolor-interpolate' function of kurecolor.el
-(defun my-modus-themes-interpolate (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)))
-
-(defun my-modus-themes-tint-palette (palette bg-blend fg-blend)
- "Modify Modus PALETTE programmatically and return a new palette.
-Blend background colors with BG-BLEND and foreground colors with FG-BLEND."
- (let (name cons colors)
- (dolist (cons palette)
- (let ((blend (if (string-match "bg" (symbol-name (car cons)))
- bg-blend
- fg-blend)))
- (setq name (my-modus-themes-interpolate (cdr cons) blend)))
- (setq name (format "%s" name))
- (setq cons `(,(car cons) . ,name))
- (push cons colors))
- colors))
-
-(define-minor-mode modus-themes-tinted-mode
- "Tweak some Modus themes colors."
- :init-value nil
- :global t
- (if modus-themes-tinted-mode
- (setq modus-themes-operandi-color-overrides
- (my-modus-themes-tint-palette modus-themes-operandi-colors
- my-modus-operandi-bg-blend
- my-modus-operandi-fg-blend)
- modus-themes-vivendi-color-overrides
- (my-modus-themes-tint-palette modus-themes-vivendi-colors
- my-modus-vivendi-bg-blend
- my-modus-vivendi-fg-blend))
- (setq modus-themes-operandi-color-overrides nil
- modus-themes-vivendi-color-overrides nil)))
-
-(modus-themes-tinted-mode 1)
-#+end_src
-
-** Override colors completely
-:PROPERTIES:
-:CUSTOM_ID: h:736c0ff5-8c9c-4565-82cf-989e57d07d4a
-:END:
-
-Based on the ideas we have already covered in these sections, the
-following code block provides a complete, bespoke pair of color palettes
-which override the defaults. They are implemented as a minor mode, as
-explained before ([[#h:307d95dd-8dbd-4ece-a543-10ae86f155a6][Override colors]]). We call them "Summertime" for
-convenience.
-
-#+begin_src emacs-lisp
-;; Read the relevant blog post:
-;; <https://protesilaos.com/codelog/2022-07-26-modus-themes-color-override-demo/>
-(define-minor-mode modus-themes-summertime
- "Refashion the Modus themes by overriding their colors.
-
-This is a complete technology demonstration to show how to
-manually override the colors of the Modus themes. I have taken
-good care of those overrides to make them work as a fully fledged
-color scheme that is compatible with all user options of the
-Modus themes.
-
-These overrides are usable by those who (i) like something more
-fancy than the comparatively austere looks of the Modus themes,
-and (ii) can cope with a lower contrast ratio.
-
-The overrides are set up as a minor mode, so that the user can
-activate the effect on demand. Those who want to load the
-overrides at all times can either add them directly to their
-configuration or enable `modus-themes-summertime' BEFORE loading
-either of the Modus themes (if the overrides are evaluated after
-the theme, the theme must be reloaded).
-
-Remember that all changes to theme-related variables require a
-reload of the theme to take effect (the Modus themes have lots of
-user options, apart from those overrides).
-
-The `modus-themes-summertime' IS NOT an official extension to the
-Modus themes and DOES NOT comply with its lofty accessibility
-standards. It is included in the official manual as guidance for
-those who want to make use of the color overriding facility we
-provide."
- :init-value nil
- :global t
- (if modus-themes-summertime
- (setq modus-themes-operandi-color-overrides
- '((bg-main . "#fff0f2")
- (bg-dim . "#fbe6ef")
- (bg-alt . "#f5dae6")
- (bg-hl-line . "#fad8e3")
- (bg-active . "#efcadf")
- (bg-inactive . "#f3ddef")
- (bg-active-accent . "#ffbbef")
- (bg-region . "#dfc5d1")
- (bg-region-accent . "#efbfef")
- (bg-region-accent-subtle . "#ffd6ef")
- (bg-header . "#edd3e0")
- (bg-tab-active . "#ffeff2")
- (bg-tab-inactive . "#f8d3ef")
- (bg-tab-inactive-accent . "#ffd9f5")
- (bg-tab-inactive-alt . "#e5c0d5")
- (bg-tab-inactive-alt-accent . "#f3cce0")
- (fg-main . "#543f78")
- (fg-dim . "#5f476f")
- (fg-alt . "#7f6f99")
- (fg-unfocused . "#8f6f9f")
- (fg-active . "#563068")
- (fg-inactive . "#8a5698")
- (fg-docstring . "#5f5fa7")
- (fg-comment-yellow . "#a9534f")
- (fg-escape-char-construct . "#8b207f")
- (fg-escape-char-backslash . "#a06d00")
- (bg-special-cold . "#d3e0f4")
- (bg-special-faint-cold . "#e0efff")
- (bg-special-mild . "#c4ede0")
- (bg-special-faint-mild . "#e0f0ea")
- (bg-special-warm . "#efd0c4")
- (bg-special-faint-warm . "#ffe4da")
- (bg-special-calm . "#f0d3ea")
- (bg-special-faint-calm . "#fadff9")
- (fg-special-cold . "#405fb8")
- (fg-special-mild . "#407f74")
- (fg-special-warm . "#9d6f4f")
- (fg-special-calm . "#af509f")
- (bg-completion . "#ffc5e5")
- (bg-completion-subtle . "#f7cfef")
- (red . "#ed2f44")
- (red-alt . "#e0403d")
- (red-alt-other . "#e04059")
- (red-faint . "#ed4f44")
- (red-alt-faint . "#e0603d")
- (red-alt-other-faint . "#e06059")
- (green . "#217a3c")
- (green-alt . "#417a1c")
- (green-alt-other . "#006f3c")
- (green-faint . "#318a4c")
- (green-alt-faint . "#518a2c")
- (green-alt-other-faint . "#20885c")
- (yellow . "#b06202")
- (yellow-alt . "#a95642")
- (yellow-alt-other . "#a06f42")
- (yellow-faint . "#b07232")
- (yellow-alt-faint . "#a96642")
- (yellow-alt-other-faint . "#a08042")
- (blue . "#275ccf")
- (blue-alt . "#475cc0")
- (blue-alt-other . "#3340ef")
- (blue-faint . "#476ce0")
- (blue-alt-faint . "#575ccf")
- (blue-alt-other-faint . "#3f60d7")
- (magenta . "#bf317f")
- (magenta-alt . "#d033c0")
- (magenta-alt-other . "#844fe4")
- (magenta-faint . "#bf517f")
- (magenta-alt-faint . "#d053c0")
- (magenta-alt-other-faint . "#846fe4")
- (cyan . "#007a9f")
- (cyan-alt . "#3f709f")
- (cyan-alt-other . "#107f7f")
- (cyan-faint . "#108aaf")
- (cyan-alt-faint . "#3f80af")
- (cyan-alt-other-faint . "#3088af")
- (red-active . "#cd2f44")
- (green-active . "#116a6c")
- (yellow-active . "#993602")
- (blue-active . "#475ccf")
- (magenta-active . "#7f2ccf")
- (cyan-active . "#007a8f")
- (red-nuanced-bg . "#ffdbd0")
- (red-nuanced-fg . "#ed6f74")
- (green-nuanced-bg . "#dcf0dd")
- (green-nuanced-fg . "#3f9a4c")
- (yellow-nuanced-bg . "#fff3aa")
- (yellow-nuanced-fg . "#b47232")
- (blue-nuanced-bg . "#e3e3ff")
- (blue-nuanced-fg . "#201f6f")
- (magenta-nuanced-bg . "#fdd0ff")
- (magenta-nuanced-fg . "#c0527f")
- (cyan-nuanced-bg . "#dbefff")
- (cyan-nuanced-fg . "#0f3f60")
- (bg-diff-heading . "#b7cfe0")
- (fg-diff-heading . "#041645")
- (bg-diff-added . "#d6f0d6")
- (fg-diff-added . "#004520")
- (bg-diff-changed . "#fcefcf")
- (fg-diff-changed . "#524200")
- (bg-diff-removed . "#ffe0ef")
- (fg-diff-removed . "#891626")
- (bg-diff-refine-added . "#84cfa4")
- (fg-diff-refine-added . "#002a00")
- (bg-diff-refine-changed . "#cccf8f")
- (fg-diff-refine-changed . "#302010")
- (bg-diff-refine-removed . "#da92b0")
- (fg-diff-refine-removed . "#500010")
- (bg-diff-focus-added . "#a6e5c6")
- (fg-diff-focus-added . "#002c00")
- (bg-diff-focus-changed . "#ecdfbf")
- (fg-diff-focus-changed . "#392900")
- (bg-diff-focus-removed . "#efbbcf")
- (fg-diff-focus-removed . "#5a0010"))
- modus-themes-vivendi-color-overrides
- '((bg-main . "#25152a")
- (bg-dim . "#2a1930")
- (bg-alt . "#382443")
- (bg-hl-line . "#332650")
- (bg-active . "#463358")
- (bg-inactive . "#2d1f3a")
- (bg-active-accent . "#50308f")
- (bg-region . "#5d4a67")
- (bg-region-accent . "#60509f")
- (bg-region-accent-subtle . "#3f285f")
- (bg-header . "#3a2543")
- (bg-tab-active . "#26162f")
- (bg-tab-inactive . "#362647")
- (bg-tab-inactive-accent . "#36265a")
- (bg-tab-inactive-alt . "#3e2f5a")
- (bg-tab-inactive-alt-accent . "#3e2f6f")
- (fg-main . "#debfe0")
- (fg-dim . "#d0b0da")
- (fg-alt . "#ae85af")
- (fg-unfocused . "#8e7f9f")
- (fg-active . "#cfbfef")
- (fg-inactive . "#b0a0c0")
- (fg-docstring . "#c8d9f7")
- (fg-comment-yellow . "#cf9a70")
- (fg-escape-char-construct . "#ff75aa")
- (fg-escape-char-backslash . "#dbab40")
- (bg-special-cold . "#2a3f58")
- (bg-special-faint-cold . "#1e283f")
- (bg-special-mild . "#0f3f31")
- (bg-special-faint-mild . "#0f281f")
- (bg-special-warm . "#44331f")
- (bg-special-faint-warm . "#372213")
- (bg-special-calm . "#4a314f")
- (bg-special-faint-calm . "#3a223f")
- (fg-special-cold . "#c0b0ff")
- (fg-special-mild . "#bfe0cf")
- (fg-special-warm . "#edc0a6")
- (fg-special-calm . "#ff9fdf")
- (bg-completion . "#502d70")
- (bg-completion-subtle . "#451d65")
- (red . "#ff5f6f")
- (red-alt . "#ff8f6d")
- (red-alt-other . "#ff6f9d")
- (red-faint . "#ffa0a0")
- (red-alt-faint . "#f5aa80")
- (red-alt-other-faint . "#ff9fbf")
- (green . "#51ca5c")
- (green-alt . "#71ca3c")
- (green-alt-other . "#51ca9c")
- (green-faint . "#78bf78")
- (green-alt-faint . "#99b56f")
- (green-alt-other-faint . "#88bf99")
- (yellow . "#f0b262")
- (yellow-alt . "#f0e242")
- (yellow-alt-other . "#d0a272")
- (yellow-faint . "#d2b580")
- (yellow-alt-faint . "#cabf77")
- (yellow-alt-other-faint . "#d0ba95")
- (blue . "#778cff")
- (blue-alt . "#8f90ff")
- (blue-alt-other . "#8380ff")
- (blue-faint . "#82b0ec")
- (blue-alt-faint . "#a0acef")
- (blue-alt-other-faint . "#80b2f0")
- (magenta . "#ff70cf")
- (magenta-alt . "#ff77f0")
- (magenta-alt-other . "#ca7fff")
- (magenta-faint . "#e0b2d6")
- (magenta-alt-faint . "#ef9fe4")
- (magenta-alt-other-faint . "#cfa6ff")
- (cyan . "#30cacf")
- (cyan-alt . "#60caff")
- (cyan-alt-other . "#40b79f")
- (cyan-faint . "#90c4ed")
- (cyan-alt-faint . "#a0bfdf")
- (cyan-alt-other-faint . "#a4d0bb")
- (red-active . "#ff6059")
- (green-active . "#64dc64")
- (yellow-active . "#ffac80")
- (blue-active . "#4fafff")
- (magenta-active . "#cf88ff")
- (cyan-active . "#50d3d0")
- (red-nuanced-bg . "#440a1f")
- (red-nuanced-fg . "#ffcccc")
- (green-nuanced-bg . "#002904")
- (green-nuanced-fg . "#b8e2b8")
- (yellow-nuanced-bg . "#422000")
- (yellow-nuanced-fg . "#dfdfb0")
- (blue-nuanced-bg . "#1f1f5f")
- (blue-nuanced-fg . "#bfd9ff")
- (magenta-nuanced-bg . "#431641")
- (magenta-nuanced-fg . "#e5cfef")
- (cyan-nuanced-bg . "#042f49")
- (cyan-nuanced-fg . "#a8e5e5")
- (bg-diff-heading . "#304466")
- (fg-diff-heading . "#dae7ff")
- (bg-diff-added . "#0a383a")
- (fg-diff-added . "#94ba94")
- (bg-diff-changed . "#2a2000")
- (fg-diff-changed . "#b0ba9f")
- (bg-diff-removed . "#50163f")
- (fg-diff-removed . "#c6adaa")
- (bg-diff-refine-added . "#006a46")
- (fg-diff-refine-added . "#e0f6e0")
- (bg-diff-refine-changed . "#585800")
- (fg-diff-refine-changed . "#ffffcc")
- (bg-diff-refine-removed . "#952838")
- (fg-diff-refine-removed . "#ffd9eb")
- (bg-diff-focus-added . "#1d4c3f")
- (fg-diff-focus-added . "#b4dfb4")
- (bg-diff-focus-changed . "#424200")
- (fg-diff-focus-changed . "#d0daaf")
- (bg-diff-focus-removed . "#6f0f39")
- (fg-diff-focus-removed . "#eebdba")))
- (setq modus-themes-operandi-color-overrides nil
- modus-themes-vivendi-color-overrides nil)))
-#+end_src
-
-** Font configurations for Org and others
+** DIY Font configurations for Org and others
:properties:
:custom_id: h:defcf4fc-8fa8-4c29-b12e-7119582cc929
:end:
#+cindex: Font configurations
+[ Consider using the ~fontaine~ package from GNU ELPA (by Protesilaos)
+ for all font-related configurations. ]
+
The themes are designed to optionally cope well with mixed font
configurations. This mostly concerns ~org-mode~ and ~markdown-mode~, though
expect to find it elsewhere like in ~Info-mode~.
@@ -3400,9 +2906,6 @@ the ~variable-pitch~ (proportional spacing) and ~fixed-pitch~ (monospaced)
faces respectively. It may also be convenient to set your main typeface
by configuring the ~default~ face the same way.
-[ The =fontaine= package on GNU ELPA (by the author of the modus-themes)
- is designed to handle this case. ]
-
Put something like this in your initialization file (also consider
reading the doc string of ~set-face-attribute~):
@@ -3444,12 +2947,15 @@ absolute height).
[[#h:e6c5451f-6763-4be7-8fdb-b4706a422a4c][Note for EWW and Elfeed fonts]].
-** Configure bold and italic faces
+** DIY Configure bold and italic faces
:properties:
:custom_id: h:2793a224-2109-4f61-a106-721c57c01375
:end:
#+cindex: Bold and italic fonts
+[ Consider using the ~fontaine~ package from GNU ELPA (by Protesilaos)
+ for all font-related configurations. ]
+
The Modus themes do not hardcode a ~:weight~ or ~:slant~ attribute in the
thousands of faces they cover. Instead, they configure the generic
faces called ~bold~ and ~italic~ to use the appropriate styles and then
@@ -3503,12 +3009,12 @@ To reset the font family, one can use this:
#+end_src
To ensure that the effects persist after switching between the Modus
-themes (such as with {{{kbd(M-x modus-themes-toggle)}}}), the user needs to
-write their configurations to a function and pass it to the
-~modus-themes-after-load-theme-hook~. This is necessary because themes
-set the styles of faces upon activation, overriding prior values where
-conflicts occur between the previous and the current states (otherwise
-changing themes would not be possible).
+themes (such as with {{{kbd(M-x modus-themes-toggle)}}}), the user
+needs to write their configurations to a function and pass it to the
+~modus-themes-after-load-theme-hook~ ([[#h:3f3c3728-1b34-437d-9d0c-b110f5b161a9][Enable and load]]). This is
+necessary because themes set the styles of faces upon activation,
+overriding prior values where conflicts occur between the previous and
+the current states (otherwise changing themes would not be possible).
[[#h:86f6906b-f090-46cc-9816-1fe8aeb38776][A theme-agnostic hook for theme loading]].
@@ -3521,14 +3027,14 @@ of the themes, which can make it easier to redefine faces in bulk).
#+begin_src emacs-lisp
;; our generic function
-(defun my-modes-themes-bold-italic-faces ()
+(defun my-modes-themes-bold-italic-faces (&rest _)
(set-face-attribute 'default nil :family "Source Code Pro" :height 110)
(set-face-attribute 'bold nil :weight 'semibold))
;; or use this if you configure a lot of face and attributes and
;; especially if you plan to use `modus-themes-with-colors', as shown
;; elsewhere in the manual
-(defun my-modes-themes-bold-italic-faces ()
+(defun my-modes-themes-bold-italic-faces (&rest _)
(custom-set-faces
'(default ((t :family "Source Code Pro" :height 110)))
'(bold ((t :weight semibold)))))
@@ -3537,9 +3043,13 @@ of the themes, which can make it easier to redefine faces in bulk).
(add-hook 'modus-themes-after-load-theme-hook #'my-modes-themes-bold-italic-faces)
#+end_src
-[[#h:51ba3547-b8c8-40d6-ba5a-4586477fd4ae][Face specs at scale using the themes' palette]].
+[[#h:51ba3547-b8c8-40d6-ba5a-4586477fd4ae][Use theme colors in code with modus-themes-with-colors]].
-** Custom Org todo keyword and priority faces
+[[#h:d87673fe-2ce1-4c80-a4b8-be36ca9f2d24][Using a hook at the post-load-theme phase]].
+
+Reload the theme for changes to take effect.
+
+** DIY Custom Org todo keyword and priority faces
:properties:
:custom_id: h:89f0678d-c5c3-4a57-a526-668b2bb2d7ad
:end:
@@ -3571,20 +3081,20 @@ have something like this:
#+end_src
You could then use a variant of the following to inherit from a face
-that uses the styles you want and also to preserve the properties
-applied by the ~org-todo~ face (in case there is a difference between the
-two):
+that uses the styles you want and also to preserve the attributes
+applied by the ~org-todo~ face (in case there is a difference between
+the two):
#+begin_src emacs-lisp
(setq org-todo-keyword-faces
- '(("MEET" . '(bold org-todo))
- ("STUDY" . '(warning org-todo))
- ("WRITE" . '(shadow org-todo))))
+ '(("MEET" . (:inherit (bold org-todo)))
+ ("STUDY" . (:inherit (warning org-todo)))
+ ("WRITE" . (:inherit (shadow org-todo)))))
#+end_src
This will refashion the keywords you specify, while letting the other
-items in ~org-todo-keywords~ use their original styles (which are defined
-in the ~org-todo~ and ~org-done~ faces).
+items in ~org-todo-keywords~ use their original styles, which are
+defined in the ~org-todo~ and ~org-done~ faces.
If you want back the defaults, try specifying just the ~org-todo~ face:
@@ -3595,24 +3105,27 @@ If you want back the defaults, try specifying just the ~org-todo~ face:
("WRITE" . org-todo)))
#+end_src
-When you inherit from multiple faces, you need to quote the list as
+Or set ~org-todo-keyword-faces~ to ~nil~.
+
+When you inherit from multiple faces, you need to do it the way it is
shown further above. The order is significant: the first entry is
-applied on top of the second, overriding any properties that are
-explicitly set for both of them: any property that is not specified is
-not overridden, so, for example, if ~org-todo~ has a background and a
-foreground, while ~font-lock-type-face~ only has a foreground, the merged
-face will include the background of the former and the foreground of the
-latter. If you do not want to blend multiple faces, you do not need a
-quoted list. A pattern of =keyword . face= will suffice.
+applied on top of the second, overriding any attributes that are
+explicitly set for both of them: any attribute that is not specified
+is not overridden, so, for example, if ~org-todo~ has a background and
+a foreground, while ~font-lock-type-face~ only has a foreground, the
+merged face will include the background of the former and the
+foreground of the latter. If you do not want to blend multiple faces,
+you only specify one by name without parentheses or an =:inherit=
+keyword. A pattern of =keyword . face= will suffice.
Both approaches can be used simultaneously, as illustrated in this
configuration of the priority cookies:
#+begin_src emacs-lisp
(setq org-priority-faces
- '((?A . '(bold org-priority))
+ '((?A . (:inherit (bold org-priority)))
(?B . org-priority)
- (?C . '(shadow org-priority))))
+ (?C . (:inherit (shadow org-priority)))))
#+end_src
To find all the faces that are loaded in your current Emacs session, use
@@ -3623,11 +3136,9 @@ Their documentation strings will offer you further guidance.
Recall that the themes let you retrieve a color from their palette. Do
it if you plan to control face attributes.
-[[#h:1487c631-f4fe-490d-8d58-d72ffa3bd474][Custom face specs using the themes' palette]].
-
[[#h:02e25930-e71a-493d-828a-8907fc80f874][Check color combinations]].
-** Custom Org emphasis faces
+** DIY Custom Org emphasis faces
:properties:
:custom_id: h:26026302-47f4-4471-9004-9665470e7029
:end:
@@ -3649,7 +3160,7 @@ specification of that variable looks like this:
With the exception of ~org-verbatim~ and ~org-code~ faces, everything else
uses the corresponding type of emphasis: a bold typographic weight, or
-italicized, underlined, and struck through text.
+italicised, underlined, and struck through text.
The best way for users to add some extra attributes, such as a
foreground color, is to define their own faces and assign them to the
@@ -3760,49 +3271,97 @@ styled by the themes, it probably is best not to edit them:
That's it! For changes to take effect in already visited Org files,
invoke {{{kbd(M-x org-mode-restart)}}}.
-** Update Org block delimiter fontification
-:properties:
-:custom_id: h:f44cc6e3-b0f1-4a5e-8a90-9e48fa557b50
-:end:
-
-As noted in the section about ~modus-themes-org-blocks~, Org contains a
-variable that determines whether the block's begin and end lines are
-extended to the edge of the window ([[#h:b7e328c0-3034-4db7-9cdf-d5ba12081ca2][Option for org-mode block styles]]).
-The variable is ~org-fontify-whole-block-delimiter-line~.
+** DIY Use colored Org source blocks per language
+:PROPERTIES:
+:CUSTOM_ID: h:8c842804-43b7-4287-b4e9-8c07d04d1f89
+:END:
-Users who change the style of Org blocks from time to time may prefer to
-automatically update delimiter line fontification, such as with the
-following setup:
+[[#h:f44cc6e3-b0f1-4a5e-8a90-9e48fa557b50][DIY Make Org block colors more or less colorful]].
-#+begin_src emacs-lisp
-(defun my-modus-themes-org-fontify-block-delimiter-lines ()
- "Match `org-fontify-whole-block-delimiter-line' to theme style.
-Run this function at the post theme load phase, such as with the
-`modus-themes-after-load-theme-hook'."
- (if (eq modus-themes-org-blocks 'gray-background)
- (setq org-fontify-whole-block-delimiter-line t)
- (setq org-fontify-whole-block-delimiter-line nil)))
+In versions of the Modus themes before =4.4.0= there was an option to
+change the coloration of Org source blocks so that certain languages
+would have a distinctly colored background. This was not flexible
+enough, because (i) we cannot cover all languages effectively and (ii)
+the user had no choice over the =language --> color= mapping.
-(add-hook 'modus-themes-after-load-theme-hook
- #'my-modus-themes-org-fontify-block-delimiter-lines)
-#+end_src
+As such, the old user option is no more. Users can use the following
+to achieve what they want:
-Then {{{kbd(M-x org-mode-restart)}}} for changes to take effect, though manual
-intervention can be circumvented by tweaking the function thus:
+[ All this is done by setting the Org user option ~org-src-block-faces~,
+ so it is not related to the palette overrides mechanism provided by
+ the Modus themes. ]
#+begin_src emacs-lisp
-(defun my-modus-themes-org-fontify-block-delimiter-lines ()
- "Match `org-fontify-whole-block-delimiter-line' to theme style.
-Run this function at the post theme load phase, such as with the
-`modus-themes-after-load-theme-hook'."
- (if (eq modus-themes-org-blocks 'gray-background)
- (setq org-fontify-whole-block-delimiter-line t)
- (setq org-fontify-whole-block-delimiter-line nil))
- (when (derived-mode-p 'org-mode)
- (font-lock-flush)))
-#+end_src
-
-** Measure color contrast
+(defun my-modus-themes-org-block-faces (&rest _)
+ (modus-themes-with-colors
+ ;; The `org-src-block-faces' does not get re-applied in existing
+ ;; Org buffers. Do M-x org-mode-restart for changes to take
+ ;; effect.
+ (setq org-src-block-faces
+ `(("emacs-lisp" modus-themes-nuanced-magenta)
+ ("elisp" modus-themes-nuanced-magenta)
+ ("clojure" modus-themes-nuanced-magenta)
+ ("clojurescript" modus-themes-nuanced-magenta)
+ ("c" modus-themes-nuanced-blue)
+ ("c++" modus-themes-nuanced-blue)
+ ("sh" modus-themes-nuanced-yellow)
+ ("shell" modus-themes-nuanced-yellow)
+ ("python" modus-themes-nuanced-yellow)
+ ("ipython" modus-themes-nuanced-yellow)
+ ("r" modus-themes-nuanced-yellow)
+ ("html" modus-themes-nuanced-green)
+ ("xml" modus-themes-nuanced-green)
+ ("css" modus-themes-nuanced-red)
+ ("scss" modus-themes-nuanced-red)
+ ("yaml" modus-themes-nuanced-cyan)
+ ("conf" modus-themes-nuanced-cyan)
+ ("docker" modus-themes-nuanced-cyan)))))
+
+(add-hook 'modus-themes-after-load-theme-hook #'my-modus-themes-org-block-faces)
+#+end_src
+
+[[#h:d87673fe-2ce1-4c80-a4b8-be36ca9f2d24][DIY Use a hook at the post-load-theme phase]].
+
+Note that the ~org-src-block-faces~ accepts a named face, as shown
+above, as well as a list of face attributes. The latter approach is
+not good enough because it hardcodes values in such a way that an
+~org-mode-restart~ is necessary. Whereas the indirection of the named
+face lets the theme change the values while Org buffers continue to
+show the right colors.
+
+Still, if a user prefers to hardcode face attributes, here is the
+idea:
+
+#+begin_src emacs-lisp
+;; This is for the sake of completeness. I DO NOT RECOMMEND THIS
+;; method because it hardcodes values and thus requires
+;; `org-mode-restart' every time you change a theme.
+(defun my-modus-themes-org-block-faces (&rest _)
+ (modus-themes-with-colors
+ (setq org-src-block-faces
+ `(("emacs-lisp" (:inherit org-block :background ,bg-magenta-nuanced))
+ ("elisp" (:inherit org-block :background ,bg-magenta-nuanced))
+ ("clojure" (:inherit org-block :background ,bg-magenta-nuanced))
+ ("clojurescript" (:inherit org-block :background ,bg-magenta-nuanced))
+ ("c" (:inherit org-block :background ,bg-blue-nuanced))
+ ("c++" (:inherit org-block :background ,bg-blue-nuanced))
+ ("sh" (:inherit org-block :background ,bg-yellow-nuanced))
+ ("shell" (:inherit org-block :background ,bg-yellow-nuanced))
+ ("python" (:inherit org-block :background ,bg-yellow-nuanced))
+ ("ipython" (:inherit org-block :background ,bg-yellow-nuanced))
+ ("r" (:inherit org-block :background ,bg-yellow-nuanced))
+ ("html" (:inherit org-block :background ,bg-green-nuanced))
+ ("xml" (:inherit org-block :background ,bg-green-nuanced))
+ ("css" (:inherit org-block :background ,bg-red-nuanced))
+ ("scss" (:inherit org-block :background ,bg-red-nuanced))
+ ("yaml" (:inherit org-block :background ,bg-cyan-nuanced))
+ ("conf" (:inherit org-block :background ,bg-cyan-nuanced))
+ ("docker" (:inherit org-block :background ,bg-cyan-nuanced))))))
+
+(add-hook 'modus-themes-after-load-theme-hook #'my-modus-themes-org-block-faces)
+#+end_src
+
+** DIY Measure color contrast
:properties:
:custom_id: h:02e25930-e71a-493d-828a-8907fc80f874
:end:
@@ -3872,10 +3431,10 @@ palette in large part because certain colors are only meant to be used
in combination with some others. Consult the source code for the
minutia and relevant commentary.
-Such knowledge may prove valuable while attempting to override some of
-the themes' colors: [[#h:307d95dd-8dbd-4ece-a543-10ae86f155a6][Override colors]].
+Such knowledge may prove valuable while attempting to customize the
+theme's color palette.
-** Load theme depending on time of day
+** DIY Load theme depending on time of day
:properties:
:custom_id: h:1d1ef4b4-8600-4a09-993c-6de3af0ddd26
:end:
@@ -3884,9 +3443,9 @@ While we do provide ~modus-themes-toggle~ to manually switch between the
themes, users may also set up their system to perform such a task
automatically at sunrise and sunset.
-This can be accomplished by specifying the coordinates of one's location
-using the built-in {{{file(solar.el)}}} and then configuring the =circadian=
-package:
+This can be accomplished by specifying the coordinates of one's
+location using the built-in {{{file(solar.el)}}} and then configuring
+the ~circadian~ package:
#+begin_src emacs-lisp
(use-package solar ; built-in
@@ -3895,7 +3454,7 @@ package:
calendar-longitude 33.36))
(use-package circadian ; you need to install this
- :ensure
+ :ensure t
:after solar
:config
(setq circadian-themes '((:sunrise . modus-operandi)
@@ -3903,7 +3462,7 @@ package:
(circadian-setup))
#+end_src
-** Backdrop for pdf-tools
+** DIY Backdrop for pdf-tools
:properties:
:custom_id: h:ff69dfe1-29c0-447a-915c-b5ff7c5509cd
:end:
@@ -3924,10 +3483,11 @@ buffer-local value of the ~default~ face.
To remap the buffer's backdrop, we start with a function like this one:
#+begin_src emacs-lisp
-(defun my-pdf-tools-backdrop ()
- (face-remap-add-relative
- 'default
- `(:background ,(modus-themes-color 'bg-alt))))
+(defun my-pdf-tools-backdrop (&rest _)
+ (modus-themes-with-colors
+ (face-remap-add-relative
+ 'default
+ `(:background ,bg-dim))))
(add-hook 'pdf-tools-enabled-hook #'my-pdf-tools-backdrop)
#+end_src
@@ -3937,7 +3497,8 @@ The idea is to assign that function to a hook that gets called when
when you only use one theme. However it has the downside of setting the
background color value only at render time. In other words, the face
remapping function does not get evaluated anew whenever the theme
-changes, such as upon invoking {{{kbd(M-x modus-themes-toggle)}}}.
+changes, such as upon invoking {{{kbd(M-x modus-themes-toggle)}}}
+([[#h:4fbfed66-5a89-447a-a07d-a03f6819c5bd][Option for which themes to toggle]]).
To have our face remapping adapt gracefully while switching between the
Modus themes, we need to also account for the current theme and control
@@ -3945,19 +3506,20 @@ the activation of ~pdf-view-midnight-minor-mode~. To which end we arrive
at something like the following, which builds on the above example:
#+begin_src emacs-lisp
-(defun my-pdf-tools-backdrop ()
- (face-remap-add-relative
- 'default
- `(:background ,(modus-themes-color 'bg-alt))))
+(defun my-pdf-tools-backdrop (&rest _)
+ (modus-themes-with-colors
+ (face-remap-add-relative
+ 'default
+ `(:background ,bg-dim))))
-(defun my-pdf-tools-midnight-mode-toggle ()
+(defun my-pdf-tools-midnight-mode-toggle (&rest _)
(when (derived-mode-p 'pdf-view-mode)
(if (eq (car custom-enabled-themes) 'modus-vivendi)
(pdf-view-midnight-minor-mode 1)
(pdf-view-midnight-minor-mode -1))
(my-pdf-tools-backdrop)))
-(defun my-pdf-tools-themes-toggle ()
+(defun my-pdf-tools-themes-toggle (&rest _)
(mapc
(lambda (buf)
(with-current-buffer buf
@@ -3968,106 +3530,15 @@ at something like the following, which builds on the above example:
(add-hook 'modus-themes-after-load-theme-hook #'my-pdf-tools-themes-toggle)
#+end_src
+[[#h:d87673fe-2ce1-4c80-a4b8-be36ca9f2d24][Using a hook at the post-load-theme phase]].
+
With those in place, PDFs have a distinct backdrop for their page, while
buffers with major-mode as ~pdf-view-mode~ automatically switches to dark
mode when ~modus-themes-toggle~ is called.
-** Decrease mode line height
-:properties:
-:custom_id: h:03be4438-dae1-4961-9596-60a307c070b5
-:end:
-#+cindex: Decrease mode line height
-
-By default, the mode line of the Modus themes is set to 1 pixel width
-for its =:box= attribute. In contrast, the mode line of stock Emacs is -1
-pixel. This small difference is considered necessary for the purposes
-of accessibility as our out-of-the-box design has a prominent color
-around the mode line (a border) to make its boundaries clear. With a
-negative width the border and the text on the mode line can feel a bit
-more difficult to read under certain scenaria.
-
-Furthermore, the user option ~modus-themes-mode-line~ ([[#h:27943af6-d950-42d0-bc23-106e43f50a24][Mode line]]) does not
-allow for such a negative value because there are many edge cases that
-simply make for a counter-intuitive set of possibilities, such as a =0=
-value not being acceptable by the underlying face infrastructure, and
-negative values greater than =-2= not being particularly usable.
-
-For these reasons, users who wish to decrease the overall height of the
-mode line must handle things on their own by implementing the methods
-for face customization documented herein.
-
-[[#h:1487c631-f4fe-490d-8d58-d72ffa3bd474][Basic face customization]].
-
-One such method is to create a function that configures the desired
-faces and hook it to ~modus-themes-after-load-theme-hook~ so that it
-persists while switching between the Modus themes with the command
-~modus-themes-toggle~.
-
-This one simply disables the box altogether, which will reduce the
-height of the mode lines, but also remove their border:
-
-#+begin_src emacs-lisp
-(defun my-modus-themes-custom-faces ()
- (set-face-attribute 'mode-line nil :box nil)
- (set-face-attribute 'mode-line-inactive nil :box nil))
-
-(add-hook 'modus-themes-after-load-theme-hook #'my-modus-themes-custom-faces)
-#+end_src
-
-The above relies on the ~set-face-attribute~ function, though users who
-plan to reuse colors from the theme and do so at scale are better off
-with the more streamlined combination of the ~modus-themes-with-colors~
-macro and ~custom-set-faces~.
-
-[[#h:51ba3547-b8c8-40d6-ba5a-4586477fd4ae][Face customization at scale]].
-
-As explained before in this document, this approach has a syntax that is
-consistent with the source code of the themes, so it probably is easier
-to reuse parts of the design.
-
-The following emulates the stock Emacs style, while still using the
-colors of the Modus themes (whichever attribute is not explicitly stated
-is inherited from the underlying theme):
-
-#+begin_src emacs-lisp
-(defun my-modus-themes-custom-faces ()
- (modus-themes-with-colors
- (custom-set-faces
- `(mode-line ((,class :box (:line-width -1 :style released-button))))
- `(mode-line-inactive ((,class :box (:line-width -1 :color ,bg-region)))))))
-
-(add-hook 'modus-themes-after-load-theme-hook #'my-modus-themes-custom-faces)
-#+end_src
-
-And this one is like the out-of-the-box style of the Modus themes, but
-with the -1 height instead of 1:
+Reload the theme for changes to take effect.
-#+begin_src emacs-lisp
-(defun my-modus-themes-custom-faces ()
- (modus-themes-with-colors
- (custom-set-faces
- `(mode-line ((,class :box (:line-width -1 :color ,fg-alt))))
- `(mode-line-inactive ((,class :box (:line-width -1 :color ,bg-region)))))))
-
-(add-hook 'modus-themes-after-load-theme-hook #'my-modus-themes-custom-faces)
-#+end_src
-
-Finally, to also change the background color of the active mode line,
-such as that it looks like the "accented" variant which is possible via
-the user option ~modus-themes-mode-line~, the =:background= attribute needs
-to be specified as well:
-
-#+begin_src emacs-lisp
-(defun my-modus-themes-custom-faces ()
- (modus-themes-with-colors
- (custom-set-faces
- `(mode-line ((,class :box (:line-width -1 :color ,fg-alt) :background ,bg-active-accent)))
- `(mode-line-inactive ((,class :box (:line-width -1 :color ,bg-region)))))))
-
-(add-hook 'modus-themes-after-load-theme-hook #'my-modus-themes-custom-faces)
-#+end_src
-
-** Toggle themes without reloading them
+** DIY Toggle themes without reloading them
:properties:
:custom_id: h:b40aca50-a3b2-4c43-be58-2c26fcd14237
:end:
@@ -4096,291 +3567,110 @@ manual."
Recall that ~modus-themes-toggle~ uses ~load-theme~.
-** A theme-agnostic hook for theme loading
-:properties:
-:custom_id: h:86f6906b-f090-46cc-9816-1fe8aeb38776
-:end:
-
-The themes are designed with the intent to be useful to Emacs users of
-varying skill levels, from beginners to experts. This means that we try
-to make things easier by not expecting anyone reading this document to
-be proficient in Emacs Lisp or programming in general.
-
-Such a case is with the use of the ~modus-themes-after-load-theme-hook~,
-which runs after ~modus-themes-toggle~, ~modus-themes-load-operandi~, or
-~modus-themes-load-vivendi~ is evaluated. We recommend using that hook
-for advanced customizations, because (1) we know for sure that it is
-available once the themes are loaded, and (2) anyone consulting this
-manual, especially the sections on enabling and loading the themes, will
-be in a good position to benefit from that hook.
-
-Advanced users who have a need to switch between the Modus themes and
-other items will find that such a hook does not meet their requirements:
-it only works with the Modus themes and only with the aforementioned
-functions.
+** DIY Use more spacious margins or padding in Emacs frames
+:PROPERTIES:
+:CUSTOM_ID: h:43bcb5d0-e25f-470f-828c-662cee9e21f1
+:END:
-A theme-agnostic setup can be configured thus:
+[ UPDATE 2023-06-25: Instead of following these instructions, you can
+ simply install my ~spacious-padding~ package from GNU ELPA. It
+ implements the padding and provides relevant user options. ]
-#+begin_src emacs-lisp
-(defvar after-enable-theme-hook nil
- "Normal hook run after enabling a theme.")
+By default, Emacs frames try to maximize the number of characters that
+fit in the current visible portion of the buffer. Users may prefer to
+have some extra padding instead. This can make Emacs frames look more
+pleasant, but also make it easier to identify the currently active
+window.
-(defun run-after-enable-theme-hook (&rest _args)
- "Run `after-enable-theme-hook'."
- (run-hooks 'after-enable-theme-hook))
+The way to implement such padding is two-fold:
-(advice-add 'enable-theme :after #'run-after-enable-theme-hook)
-#+end_src
+1. In the =early-init.el= file instruct Emacs to use a higher value
+ for the ~internal-border-width~ of all frames, as well as for the
+ ~right-divider-width~. The former concerns the outer boundaries of
+ Emacs frames, while the latter pertains to dividers between Emacs
+ windows.
-This creates the ~after-enable-theme-hook~ and makes it run after each
-call to ~enable-theme~, which means that it will work for all themes and
-also has the benefit that it does not depend on functions such as
-~modus-themes-toggle~ and the others mentioned above. ~enable-theme~ is
-called internally by ~load-theme~, so the hook works everywhere.
+2. Make the relevant faces invisible by changing the value of their
+ relevant attributes to that of the current theme's main background.
-Now this specific piece of Elisp may be simple for experienced users,
-but it is not easy to read for newcomers, including the author of the
-Modus themes for the first several months of their time as an Emacs
-user. Hence our hesitation to recommend it as part of the standard
-setup of the Modus themes (it is generally a good idea to understand
-what the implications are of advising a function).
+The parameters of Emacs frames are specified in the variables
+~initial-frame-alist~ and ~default-frame-alist~. The "initial frame"
+refers to the first frame that appears on Emacs startup. The
+"default" refers to the fallback values that apply to all other frames
+that Emacs creates (unless those are explicitly overridden by a
+bespoke ~make-frame~ call).
-** Diffs with only the foreground
-:properties:
-:custom_id: h:e2aed9eb-5e1e-45ec-bbd7-bc4faeab3236
-:end:
-#+cindex: Foreground-only diffs
+In detail, first we use the same values for the two frame alist variables:
-Buffers that show differences between versions of a file or buffer, such
-as in ~diff-mode~ and ~ediff~ always use color-coded background and
-foreground combinations.
+#+begin_src emacs-lisp
+;; This must go in the early-init.el so that it applies to the initial
+;; frame.
+(dolist (var '(default-frame-alist initial-frame-alist))
+ (add-to-list var '(right-divider-width . 20))
+ (add-to-list var '(internal-border-width . 20)))
+#+end_src
-[[#h:ea7ac54f-5827-49bd-b09f-62424b3b6427][Option for diff buffer looks]].
+What the ~dolist~ does is to call ~add-to-list~ for the two variables
+we specify there. This economizes on typing.
-User may, however, prefer a style that removes the color-coded
-backgrounds from regular changes while keeping them for word-wise (aka
-"refined") changes---backgrounds for word-wise diffs are helpful in
-context. To make this happen, one can use the ~modus-themes-with-colors~
-macro ([[#h:51ba3547-b8c8-40d6-ba5a-4586477fd4ae][Face specs at scale using the themes' palette]]):
+Then we define a function that makes the relevant faces invisible.
+The reason we do this with a function is so we can hook it to the
+"post load" phase of a theme, thus applying the new background value
+(otherwise you keep the old background, which likely means that the
+faces will no longer be invisible).
#+begin_src emacs-lisp
-(defun my-modus-themes-custom-faces ()
- (modus-themes-with-colors
+(defun my-modus-themes-invisible-dividers (&rest _)
+ "Make window dividers invisible.
+Add this to the `modus-themes-post-load-hook'."
+ (let ((bg (face-background 'default)))
(custom-set-faces
- `(modus-themes-diff-added ((,class :background unspecified :foreground ,green))) ; OR ,blue for deuteranopia
- `(modus-themes-diff-changed ((,class :background unspecified :foreground ,yellow)))
- `(modus-themes-diff-removed ((,class :background unspecified :foreground ,red)))
-
- `(modus-themes-diff-refine-added ((,class :background ,bg-diff-added :foreground ,fg-diff-added)))
- ;; `(modus-themes-diff-refine-added ((,class :background ,bg-diff-added-deuteran :foreground ,fg-diff-added-deuteran)))
- `(modus-themes-diff-refine-changed ((,class :background ,bg-diff-changed :foreground ,fg-diff-changed)))
- `(modus-themes-diff-refine-removed ((,class :background ,bg-diff-removed :foreground ,fg-diff-removed)))
-
- `(modus-themes-diff-focus-added ((,class :background ,bg-dim :foreground ,green))) ; OR ,blue for deuteranopia
- `(modus-themes-diff-focus-changed ((,class :background ,bg-dim :foreground ,yellow)))
- `(modus-themes-diff-focus-removed ((,class :background ,bg-dim :foreground ,red)))
-
- `(modus-themes-diff-heading ((,class :background ,bg-alt :foreground ,fg-main)))
-
- `(diff-indicator-added ((,class :foreground ,green))) ; OR ,blue for deuteranopia
- `(diff-indicator-changed ((,class :foreground ,yellow)))
- `(diff-indicator-removed ((,class :foreground ,red)))
+ `(fringe ((t :background ,bg :foreground ,bg)))
+ `(window-divider ((t :background ,bg :foreground ,bg)))
+ `(window-divider-first-pixel ((t :background ,bg :foreground ,bg)))
+ `(window-divider-last-pixel ((t :background ,bg :foreground ,bg))))))
- `(magit-diff-added ((,class :background unspecified :foreground ,green-faint)))
- `(magit-diff-changed ((,class :background unspecified :foreground ,yellow-faint)))
- `(magit-diff-removed ((,class :background unspecified :foreground ,red-faint)))
- `(magit-diff-context-highlight ((,class :background ,bg-dim :foreground ,fg-dim))))))
-
-;; This is so that the changes persist when switching between
-;; `modus-operandi' and `modus-vivendi'.
-(add-hook 'modus-themes-after-load-theme-hook #'my-modus-themes-custom-faces)
+(add-hook 'modus-themes-post-load-hook #'my-modus-themes-invisible-dividers)
#+end_src
-This used to be an optional style of ~modus-themes-diffs~, but has been
-removed since version =2.0.0= to ensure that the accessibility standard
-and aesthetic quality of the themes is not compromised.
-
-** Ediff without diff color-coding
-:properties:
-:custom_id: h:b0b31802-0216-427e-b071-1a47adcfe608
-:end:
-
-Ediff uses the same color-coding as ordinary diffs in ~diff-mode~, Magit,
-etc. ([[#h:ea7ac54f-5827-49bd-b09f-62424b3b6427][Option for diff buffer looks]]). This is consistent with the
-principle of least surprise.
-
-Users may, however, prefer to treat Ediff differently on the premise
-that it does not need any particular color-coding to show added or
-removed lines/words: it does not use the =+= or =-= markers, after all.
+[[#h:d87673fe-2ce1-4c80-a4b8-be36ca9f2d24][Using a hook at the post-load-theme phase]].
-This can be achieved by customizing the Ediff faces with color
-combinations that do not carry the same connotations as those of diffs.
-Consider this example, which leverages the ~modus-themes-with-colors~
-macro ([[#h:51ba3547-b8c8-40d6-ba5a-4586477fd4ae][Face specs at scale using the themes' palette]]):
+The above will work only for themes that belong to the Modus family.
+For users of Emacs version 29 or higher, there exists a theme-agnostic
+hook that takes a function with one argument---that of the theme---and
+calls in the the "post enable" phase of theme loading. Here is the
+above snippet, with the necessary tweaks:
#+begin_src emacs-lisp
-(defun my-modus-themes-custom-faces ()
- (modus-themes-with-colors
+(defun my-modus-themes-invisible-dividers (&rest _)
+ "Make window dividers for THEME invisible."
+ (let ((bg (face-background 'default)))
(custom-set-faces
- `(ediff-current-diff-A ((,class :inherit unspecified :background ,bg-special-faint-cold :foreground ,fg-special-cold)))
- `(ediff-current-diff-B ((,class :inherit unspecified :background ,bg-special-faint-warm :foreground ,fg-special-warm)))
- `(ediff-current-diff-C ((,class :inherit unspecified :background ,bg-special-faint-calm :foreground ,fg-special-calm)))
- `(ediff-fine-diff-A ((,class :inherit unspecified :background ,bg-special-cold :foreground ,fg-special-cold)))
- `(ediff-fine-diff-B ((,class :inherit unspecified :background ,bg-special-warm :foreground ,fg-special-warm)))
- `(ediff-fine-diff-C ((,class :inherit unspecified :background ,bg-special-calm :foreground ,fg-special-calm))))))
-
-;; This is so that the changes persist when switching between
-;; `modus-operandi' and `modus-vivendi'.
-(add-hook 'modus-themes-after-load-theme-hook #'my-modus-themes-custom-faces)
-#+end_src
+ `(fringe ((t :background ,bg :foreground ,bg)))
+ `(window-divider ((t :background ,bg :foreground ,bg)))
+ `(window-divider-first-pixel ((t :background ,bg :foreground ,bg)))
+ `(window-divider-last-pixel ((t :background ,bg :foreground ,bg))))))
-Remove the =:foreground= and its value to preserve the underlying
-coloration.
+(add-hook 'enable-theme-functions #'my-modus-themes-invisible-dividers)
+#+end_src
-[[#h:f4d4b71b-2ca5-4c3d-b0b4-9bfd7aa7fb4d][Visualize the active Modus theme's palette]].
+Users of older versions of Emacs can read the entry herein about
+defining their own theme-agnostic hook ([[#h:86f6906b-f090-46cc-9816-1fe8aeb38776][A theme-agnostic hook for theme loading]]).
-** 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
-
-** Custom hl-todo colors
+** DIY Custom hl-todo colors
:PROPERTIES:
:CUSTOM_ID: h:2ef83a21-2f0a-441e-9634-473feb940743
:END:
-The =hl-todo= package provides the user option ~hl-todo-keyword-faces~:
-it specifies a pair of keyword and corresponding color value. The Modus
-themes configure that option in the interest of legibility. While this
-works for our purposes, users may still prefer to apply their custom
-values, in which case the following approach is necessary:
+The ~hl-todo~ package provides the user option
+~hl-todo-keyword-faces~: it specifies a pair of keyword and
+corresponding color value. The Modus themes configure that option in
+the interest of legibility. While this works for our purposes, users
+may still prefer to apply their custom values, in which case the
+following approach is necessary:
#+begin_src emacs-lisp
-(defun my-modus-themes-hl-todo-faces ()
+(defun my-modus-themes-hl-todo-faces (&rest _)
(setq hl-todo-keyword-faces '(("TODO" . "#ff0000")
("HACK" . "#ffff00")
("XXX" . "#00ffff")
@@ -4389,10 +3679,12 @@ values, in which case the following approach is necessary:
(add-hook 'modus-themes-after-load-theme-hook #'my-modus-themes-hl-todo-faces)
#+end_src
+[[#h:d87673fe-2ce1-4c80-a4b8-be36ca9f2d24][Using a hook at the post-load-theme phase]].
+
Or include a ~let~ form, if needed:
#+begin_src emacs-lisp
-(defun my-modus-themes-hl-todo-faces ()
+(defun my-modus-themes-hl-todo-faces (&rest _)
(let ((red "#ff0000")
(blue "#0000ff"))
(setq hl-todo-keyword-faces `(("TODO" . ,blue)
@@ -4403,15 +3695,19 @@ Or include a ~let~ form, if needed:
(add-hook 'modus-themes-after-load-theme-hook #'my-modus-themes-hl-todo-faces)
#+end_src
+[[#h:d87673fe-2ce1-4c80-a4b8-be36ca9f2d24][Using a hook at the post-load-theme phase]].
+
Normally, we do not touch user options, though this is an exception:
otherwise the defaults are not always legible.
-** Add support for solaire-mode
+Reload the theme for changes to take effect.
+
+** DIY Add support for solaire-mode
:PROPERTIES:
:CUSTOM_ID: h:439c9e46-52e2-46be-b1dc-85841dd99671
:END:
-The =solaire-mode= package dims the background of what it considers
+The ~solaire-mode~ package dims the background of what it considers
ancillary "UI" buffers, such as the minibuffer and Dired buffers. The
Modus themes used to support Solaire on the premise that the user was
(i) opting in to it, (ii) understood why certain buffers were more gray,
@@ -4441,28 +3737,127 @@ arrangement that compromises on our accessibility standards and/or
hinders our efforts to provide the best possible experience while using
the Modus themes.
-As such, =solaire-mode= is not---and will not be---supported by the
+As such, ~solaire-mode~ is not---and will not be---supported by the
Modus themes (or any other of my themes, for that matter). Users who
want it must style the faces manually. Below is some sample code, based
on what we cover at length elsewhere in this manual:
[[#h:f4651d55-8c07-46aa-b52b-bed1e53463bb][Advanced customization]].
-[[#h:51ba3547-b8c8-40d6-ba5a-4586477fd4ae][Face specs at scale using the themes' palette]].
+[[#h:51ba3547-b8c8-40d6-ba5a-4586477fd4ae][Use theme colors in code with modus-themes-with-colors]].
#+begin_src emacs-lisp
-(defun my-modus-themes-custom-faces ()
+(defun my-modus-themes-custom-faces (&rest _)
(modus-themes-with-colors
(custom-set-faces
- `(solaire-default-face ((,class :inherit default :background ,bg-alt :foreground ,fg-dim)))
- `(solaire-line-number-face ((,class :inherit solaire-default-face :foreground ,fg-unfocused)))
- `(solaire-hl-line-face ((,class :background ,bg-active)))
- `(solaire-org-hide-face ((,class :background ,bg-alt :foreground ,bg-alt))))))
+ `(solaire-default-face ((,c :inherit default :background ,bg-dim :foreground ,fg-dim)))
+ `(solaire-line-number-face ((,c :inherit solaire-default-face :foreground ,fg-unfocused)))
+ `(solaire-hl-line-face ((,c :background ,bg-active)))
+ `(solaire-org-hide-face ((,c :background ,bg-dim :foreground ,bg-dim))))))
(add-hook 'modus-themes-after-load-theme-hook #'my-modus-themes-custom-faces)
#+end_src
-As always, re-load the theme for changes to take effect.
+[[#h:d87673fe-2ce1-4c80-a4b8-be36ca9f2d24][Using a hook at the post-load-theme phase]].
+
+Reload the theme for changes to take effect.
+
+** DIY Use a hook at the post-load-theme phase
+:PROPERTIES:
+:CUSTOM_ID: h:d87673fe-2ce1-4c80-a4b8-be36ca9f2d24
+:END:
+
+Many of the Do-It-Yourself (DIY) snippets provided herein make use of
+a hook to apply the desired changes. In most examples, this hook is
+the ~modus-themes-after-load-theme-hook~ (alias ~modus-themes-post-load-hook~).
+This hook is provided by the Modus themes and is called at the end of
+one the following:
+
+- Command ~modus-themes-toggle~ :: [[#h:4fbfed66-5a89-447a-a07d-a03f6819c5bd][Option for which themes to toggle]].
+
+- Command ~modus-themes-select~ :: Select a Modus theme using minibuffer
+ completion and then load it.
+
+- Function ~modus-themes-load-theme~ :: Called only from Lisp, such as
+ in the user's init file, with the quoted symbol of a Modus theme as
+ an argument ([[#h:adb0c49a-f1f9-4690-868b-013a080eed68][Option for disabling other themes while loading Modus]]).
+ This function is used internally by ~modus-themes-toggle~ and
+ ~modus-themes-select~.
+
+Users who switch between themes that are not limited to the Modus
+collection cannot benefit from the aforementioned hook: it only works
+with the Modus themes. A theme-agnostic hook is needed in such a case.
+Before Emacs 29, this had to be set up manually ([[#h:86f6906b-f090-46cc-9816-1fe8aeb38776][DIY A theme-agnostic hook for theme loading]]).
+Starting with Emacs 29, the special hook ~enable-theme-functions~
+works with anything that uses the basic ~enable-theme~ function.
+
+To use the ~enable-theme-functions~ just add the given function to it
+the way it is done with every hook:
+
+#+begin_src emacs-lisp
+(add-hook 'enable-theme-functions 'MY-FUNCTION-HERE)
+#+end_src
+
+Functions added to ~enable-theme-functions~ accept a single =THEME=
+argument. The examples shown in this manual use the pattern =(&rest
+_)=, which is how a function accepts one or more arguments but
+declares it will not use them (in plain terms, the code works with or
+without ~enable-theme-functions~).
+
+*** DIY A theme-agnostic hook for theme loading
+:properties:
+:custom_id: h:86f6906b-f090-46cc-9816-1fe8aeb38776
+:end:
+
+[ NOTE: The following is for versions of Emacs before 29. For Emacs 29
+ or higher, users can rely on the built-in ~enable-theme-functions~
+ ([[#h:d87673fe-2ce1-4c80-a4b8-be36ca9f2d24][Using a hook at the post-load-theme phase]]). ]
+
+The themes are designed with the intent to be useful to Emacs users of
+varying skill levels, from beginners to experts. This means that we try
+to make things easier by not expecting anyone reading this document to
+be proficient in Emacs Lisp or programming in general.
+
+Such a case is with the use of ~modus-themes-after-load-theme-hook~,
+which runs after the ~modus-themes-load-theme~ function (used by the
+command ~modus-themes-toggle~). We recommend using that hook for
+advanced customizations, because (1) we know for sure that it is
+available once the themes are loaded, and (2) anyone consulting this
+manual, especially the sections on enabling and loading the themes,
+will be in a good position to benefit from that hook.
+
+Advanced users who have a need to switch between the Modus themes and
+other items will find that such a hook does not meet their requirements:
+it only works with the Modus themes and only with the aforementioned
+functions.
+
+A theme-agnostic setup can be configured thus:
+
+#+begin_src emacs-lisp
+(defvar after-enable-theme-hook nil
+ "Normal hook run after enabling a theme.")
+
+(defun run-after-enable-theme-hook (&rest _args)
+ "Run `after-enable-theme-hook'."
+ (run-hooks 'after-enable-theme-hook))
+
+(advice-add 'enable-theme :after #'run-after-enable-theme-hook)
+#+end_src
+
+This creates the ~after-enable-theme-hook~ and makes it run after each
+call to ~enable-theme~, which means that it will work for all themes and
+also has the benefit that it does not depend on functions such as
+~modus-themes-toggle~ and the others mentioned above. ~enable-theme~ is
+called internally by ~load-theme~, so the hook works everywhere.
+
+The downside of the theme-agnostic hook is that any functions added to
+it will likely not be able to benefit from macro calls that read the
+active theme, such as ~modus-themes-with-colors~. Not all Emacs
+themes have the same capabilities.
+
+In this document, we cover ~modus-themes-after-load-theme-hook~ though
+the user can replace it with ~after-enable-theme-hook~ should they
+need to (provided they understand the implications).
* Face coverage
:properties:
@@ -4487,55 +3882,45 @@ affected face groups. The items with an appended asterisk =*= tend to
have lots of extensions, so the "full support" may not be 100% true…
+ ace-window
-+ alert
++ agda2-mode
+ all-the-icons
+ all-the-icons-dired
+ all-the-icons-ibuffer
+ annotate
+ ansi-color
+ anzu
-+ apropos
-+ artbollocks-mode
+ auctex and TeX
+ auto-dim-other-buffers
+ avy
-+ awesome-tray
+ bbdb
+ binder
-+ bm
++ breadcrumb
+ bongo
+ boon
+ bookmark
-+ breakpoint (provided by the built-in {{{file(gdb-mi.el)}}} library)
+ calendar and diary
-+ calfw
-+ calibredb
+ centaur-tabs
-+ cfrs
+ change-log and log-view (such as ~vc-print-log~, ~vc-print-root-log~)
+ chart
+ cider
+ circe
+ citar
-+ color-rg
++ clojure-mode
+ column-enforce-mode
+ company-mode*
-+ company-posframe
+ compilation-mode
+ completions
+ consult
+ corfu
++ corfu-candidate-overlay
+ corfu-quick
+ counsel*
-+ counsel-css
-+ cov
+ cperl-mode
+ crontab-mode
-+ css-mode
+ csv-mode
+ ctrlf
+ custom (what you get with {{{kbd(M-x customize)}}})
-+ dap-mode
++ dashboard
+ deadgrep
+ debbugs
+ deft
@@ -4545,7 +3930,6 @@ have lots of extensions, so the "full support" may not be 100% true…
+ diff-hl
+ diff-mode
+ dim-autoload
-+ dir-treeview
+ dired
+ dired-async
+ dired-git
@@ -4553,11 +3937,9 @@ have lots of extensions, so the "full support" may not be 100% true…
+ dired-narrow
+ dired-subtree
+ diredfl
-+ diredp (dired+)
++ disk-usage
+ display-fill-column-indicator-mode
+ doom-modeline
-+ easy-jekyll
-+ ebdb
+ ediff
+ ein (Emacs IPython Notebook)
+ eglot
@@ -4571,36 +3953,24 @@ have lots of extensions, so the "full support" may not be 100% true…
+ emms
+ enh-ruby-mode (enhanced-ruby-mode)
+ epa
-+ equake
+ erc
-+ eros
+ ert
++ erts-mode
+ eshell
+ eshell-fringe-status
-+ eshell-git-prompt
-+ eshell-prompt-extras (epe)
-+ eshell-syntax-highlighting
+ evil* (evil-mode)
-+ evil-goggles
-+ evil-snipe
-+ evil-visual-mark-mode
+ eww
+ exwm
+ eyebrowse
-+ fancy-dabbrev
+ flycheck
+ flycheck-color-mode-line
+ flycheck-indicator
-+ flycheck-posframe
+ flymake
+ flyspell
+ flx
-+ freeze-it
+ focus
+ fold-this
+ font-lock (generic syntax highlighting)
-+ forge
-+ fountain (fountain-mode)
+ geiser
+ git-commit
+ git-gutter (and variants)
@@ -4609,23 +3979,16 @@ have lots of extensions, so the "full support" may not be 100% true…
+ gnus
+ gotest
+ golden-ratio-scroll-screen
-+ helm*
-+ helm-ls-git
-+ helm-switch-shell
-+ helm-xref
+ helpful
-+ highlight-indentation
+ highlight-numbers
+ highlight-parentheses ([[#h:24bab397-dcb2-421d-aa6e-ec5bd622b913][Note on highlight-parentheses.el]])
+ highlight-thing
-+ hl-defined
+ hl-fill-column
+ hl-line-mode
+ hl-todo
+ hydra
+ ibuffer
+ icomplete
-+ icomplete-vertical
+ ido-mode
+ iedit
+ iflipb
@@ -4635,43 +3998,40 @@ have lots of extensions, so the "full support" may not be 100% true…
+ info
+ info+ (info-plus)
+ info-colors
-+ interaction-log
+ ioccur
+ isearch, occur, etc.
+ ivy*
+ ivy-posframe
++ japanese-holidays
+ jira (org-jira)
++ jit-spell
++ jinx
+ journalctl-mode
+ js2-mode
+ julia
-+ jupyter
+ kaocha-runner
+ keycast
+ ledger-mode
+ leerzeichen
+ line numbers (~display-line-numbers-mode~ and global variant)
-+ lsp-mode
-+ lsp-ui
-+ macrostep
+ magit
-+ magit-imerge
+ make-mode
+ man
+ marginalia
+ markdown-mode
+ markup-faces (~adoc-mode~)
-+ mentor
++ mct
+ messages
-+ mini-modeline
+ minimap
-+ mmm-mode
+ mode-line
+ mood-line
-+ moody
+ mpdel
+ mu4e
+ multiple-cursors
-+ nano-modeline
++ nerd-icons
++ nerd-icons-completion
++ nerd-icons-dired
++ nerd-icons-ibuffer
+ neotree
+ notmuch
+ num3-mode
@@ -4698,11 +4058,8 @@ have lots of extensions, so the "full support" may not be 100% true…
+ pdf-tools
+ persp-mode
+ perspective
-+ phi-grep
-+ pomidor
+ popup
+ powerline
-+ powerline-evil
+ prism ([[#h:a94272e0-99da-4149-9e80-11a7e67a2cf2][Note for prism.el]])
+ prescient
+ proced
@@ -4710,19 +4067,16 @@ have lots of extensions, so the "full support" may not be 100% true…
+ pulse
+ pyim
+ quick-peek
-+ racket-mode
-+ rainbow-blocks
+ rainbow-delimiters
+ rcirc
++ rcirc-color
+ recursion-indicator
+ regexp-builder (also known as ~re-builder~)
+ rg (rg.el)
+ ripgrep
+ rmail
++ rst-mode
+ ruler-mode
-+ selectrum
-+ selectrum-prescient
-+ semantic
+ sesman
+ shell-script-mode
+ shortdoc
@@ -4734,32 +4088,25 @@ have lots of extensions, so the "full support" may not be 100% true…
+ slime (slbd)
+ sly
+ smart-mode-line
-+ smartparens
+ smerge
-+ spaceline
+ speedbar
+ spell-fu
+ stripes
+ suggest
+ switch-window
+ swiper
-+ sx
+ symbol-overlay
+ syslog-mode
-+ tab-bar-groups
+ tab-bar-mode
+ tab-line-mode
+ table (built-in {{{file(table.el)}}})
+ telega
-+ telephone-line
+ terraform-mode
+ term
+ textsec
-+ tomatinho
+ transient (pop-up windows such as Magit's)
+ trashed
+ tree-sitter
-+ treemacs
+ tty-menu
+ tuareg
+ typescript
@@ -4779,11 +4126,9 @@ have lots of extensions, so the "full support" may not be 100% true…
+ which-key
+ whitespace-mode
+ window-divider-mode
-+ winum
+ writegood-mode
+ woman
+ xah-elisp-mode
-+ xref
+ xterm-color (and ansi-colors)
+ yaml-mode
+ yasnippet
@@ -4802,34 +4147,46 @@ inherit from some basic faces or their dependencies which are directly
supported by the themes.
+ ag
++ apropos
+ apt-sources-list
++ bbdb
++ bm
++ breakpoint (provided by the built-in {{{file(gdb-mi.el)}}} library)
+ buffer-expose
+ bufler
+ counsel-notmuch
+ counsel-org-capture-string
++ css-mode
+ dashboard (emacs-dashboard)
+ define-word
++ denote
+ disk-usage
+ dtache
+ dynamic-ruler
+ easy-kill
++ ebdb
+ edit-indirect
+ egerrit
+ elfeed-summary
+ evil-owl
+ flyspell-correct
+ fortran-mode
++ freeze-it
++ forge
+ git-walktree
+ goggles
+ highlight-defined
+ highlight-escape-sequences (~hes-mode~)
++ icomplete-vertical
+ i3wm-config-mode
++ lin
+ minibuffer-line
+ no-emoji
+ org-remark
+ parrot
+ perl-mode
+ php-mode
++ pulsar
+ rjsx-mode
+ side-hustle
+ spell-fu
@@ -4840,6 +4197,7 @@ supported by the themes.
+ vdiff
+ vertico-indexed
+ vertico-mouse
++ xref
* Notes on individual packages
:properties:
@@ -4883,11 +4241,12 @@ anew.
:CUSTOM_ID: h:a195e37c-e58c-4148-b254-8ba1ed8a731a
:END:
-The =git-gutter= and =git-gutter-fr= packages default to drawing bitmaps
-for the indicators they display (e.g. bitmap of a plus sign for added
-lines). In Doom Emacs, these bitmaps are replaced with contiguous lines
-which may look nicer, but require a change to the foreground of the
-relevant faces to yield the desired color combinations.
+The ~git-gutter~ and ~git-gutter-fr~ packages default to drawing
+bitmaps for the indicators they display (e.g. bitmap of a plus sign
+for added lines). In Doom Emacs, these bitmaps are replaced with
+contiguous lines which may look nicer, but require a change to the
+foreground of the relevant faces to yield the desired color
+combinations.
Since this is Doom-specific, we urge users to apply changes in their
local setup. Below is some sample code, based on what we cover at
@@ -4895,20 +4254,27 @@ length elsewhere in this manual:
[[#h:f4651d55-8c07-46aa-b52b-bed1e53463bb][Advanced customization]].
-[[#h:51ba3547-b8c8-40d6-ba5a-4586477fd4ae][Face specs at scale using the themes' palette]].
+[[#h:51ba3547-b8c8-40d6-ba5a-4586477fd4ae][Use theme colors in code with modus-themes-with-colors]].
#+begin_src emacs-lisp
-(defun my-modus-themes-custom-faces ()
+(defun my-modus-themes-custom-faces (&rest _)
(modus-themes-with-colors
(custom-set-faces
- ;; Replace green with blue if you use `modus-themes-deuteranopia'.
- `(git-gutter-fr:added ((,class :foreground ,green-fringe-bg)))
- `(git-gutter-fr:deleted ((,class :foreground ,red-fringe-bg)))
- `(git-gutter-fr:modified ((,class :foreground ,yellow-fringe-bg))))))
+ ;; Make foreground the same as background for a uniform bar on
+ ;; Doom Emacs.
+ ;;
+ ;; Doom should not be implementing such hacks because themes
+ ;; cannot support them:
+ ;; <https://protesilaos.com/codelog/2022-08-04-doom-git-gutter-modus-themes/>.
+ `(git-gutter-fr:added ((,c :foreground ,bg-added-fringe)))
+ `(git-gutter-fr:deleted ((,c :foreground ,bg-removed-fringe)))
+ `(git-gutter-fr:modified ((,c :foreground ,bg-changed-fringe))))))
(add-hook 'modus-themes-after-load-theme-hook #'my-modus-themes-custom-faces)
#+end_src
+[[#h:d87673fe-2ce1-4c80-a4b8-be36ca9f2d24][Using a hook at the post-load-theme phase]].
+
As always, re-load the theme for changes to take effect.
If the above does not work, try this instead:
@@ -4917,30 +4283,30 @@ If the above does not work, try this instead:
(after! modus-themes
(modus-themes-with-colors
(custom-set-faces
- ;; Replace green with blue if you use `modus-themes-deuteranopia'.
- `(git-gutter-fr:added ((,class :foreground ,green-fringe-bg)))
- `(git-gutter-fr:deleted ((,class :foreground ,red-fringe-bg)))
- `(git-gutter-fr:modified ((,class :foreground ,yellow-fringe-bg))))))
+ ;; Make foreground the same as background for a uniform bar on
+ ;; Doom Emacs.
+ ;;
+ ;; Doom should not be implementing such hacks because themes
+ ;; cannot support them:
+ ;; <https://protesilaos.com/codelog/2022-08-04-doom-git-gutter-modus-themes/>.
+ `(git-gutter-fr:added ((,c :foreground ,bg-added-intense)))
+ `(git-gutter-fr:deleted ((,c :foreground ,bg-removed-intense)))
+ `(git-gutter-fr:modified ((,c :foreground ,bg-changed-intense))))))
#+end_src
-Replace ~green-fringe-bg~ with ~blue-fringe-bg~ if you want to optimize
-for red-green color deficiency.
-
-[[#h:3ed03a48-20d8-4ce7-b214-0eb7e4c79abe][Option for red-green color deficiency or deuteranopia]].
-
** Note on php-mode multiline comments
:PROPERTIES:
:CUSTOM_ID: h:d0a3157b-9c04-46e8-8742-5fb2a7ae8798
:END:
Depending on your build of Emacs and/or the environment it runs in,
-multiline comments in PHP with the =php-mode= package use the
+multiline comments in PHP with the ~php-mode~ package use the
~font-lock-doc-face~ instead of ~font-lock-comment-face~.
This seems to make all comments use the appropriate face:
#+begin_src emacs-lisp
-(defun my-multine-comments ()
+(defun my-multine-comments (&rest _)
(setq-local c-doc-face-name 'font-lock-comment-face))
(add-hook 'php-mode-hook #'my-multine-comments)
@@ -5042,10 +4408,10 @@ elsewhere in this document. For example:
#+begin_src emacs-lisp
(modus-themes-with-colors
(custom-set-faces
- `(fill-column-indicator ((,class :foreground ,bg-active)))))
+ `(fill-column-indicator ((,c :foreground ,bg-active)))))
#+end_src
-[[#h:51ba3547-b8c8-40d6-ba5a-4586477fd4ae][Face specs at scale using the themes' palette]].
+[[#h:51ba3547-b8c8-40d6-ba5a-4586477fd4ae][Use theme colors in code with modus-themes-with-colors]].
To make the line thicker, set the height to be equal to the base font
size instead of the one pixel we use. This is done by specifying a rate
@@ -5055,7 +4421,7 @@ For example:
#+begin_src emacs-lisp
(modus-themes-with-colors
(custom-set-faces
- `(fill-column-indicator ((,class :height 1.0 :background ,bg-inactive :foreground ,bg-inactive)))))
+ `(fill-column-indicator ((,c :height 1.0 :background ,bg-inactive :foreground ,bg-inactive)))))
#+end_src
** Note on highlight-parentheses.el
@@ -5063,10 +4429,10 @@ For example:
:CUSTOM_ID: h:24bab397-dcb2-421d-aa6e-ec5bd622b913
:END:
-The =highlight-parentheses= package provides contextual coloration of
+The ~highlight-parentheses~ package provides contextual coloration of
surrounding parentheses, highlighting only those which are around the
-point. The package expects users to customize the applicable colors on
-their own by configuring certain variables.
+point. The package expects users to customize the applicable colors
+on their own by configuring certain variables.
To make the Modus themes work as expected with this, we need to use some
of the techniques that are discussed at length in the various
@@ -5076,7 +4442,7 @@ advanced customization options of the themes.
[[#h:f4651d55-8c07-46aa-b52b-bed1e53463bb][Advanced customization]].
In the following example, we are assuming that the user wants to (i)
-reuse color variables provided by the themes, (ii) be able to retain
+re-use color variables provided by the themes, (ii) be able to retain
their tweaks while switching between ~modus-operandi~ and ~modus-vivendi~,
and (iii) have the option to highlight either the foreground of the
parentheses or the background as well.
@@ -5096,7 +4462,7 @@ Then we can update our preference with this:
(setq my-highlight-parentheses-use-background nil)
#+end_src
-To reuse colors from the themes, we must wrap our code in the
+To re-use colors from the themes, we must wrap our code in the
~modus-themes-with-colors~ macro. Our implementation must interface with
the variables ~highlight-parentheses-background-colors~ and/or
~highlight-parentheses-colors~.
@@ -5113,14 +4479,14 @@ found):
;; Here we set color combinations that involve both a background
;; and a foreground value.
- (setq highlight-parentheses-background-colors (list cyan-refine-bg
- magenta-refine-bg
- green-refine-bg
- yellow-refine-bg)
- highlight-parentheses-colors (list cyan-refine-fg
- magenta-refine-fg
- green-refine-fg
- yellow-refine-fg))
+ (setq highlight-parentheses-background-colors (list bg-cyan-intense
+ bg-magenta-intense
+ bg-green-intense
+ bg-yellow-intense)
+ highlight-parentheses-colors (list cyan
+ magenta
+ green
+ yellow))
;; And here we pass only foreground colors while disabling any
;; backgrounds.
@@ -5152,7 +4518,7 @@ implementation:
(setq my-highlight-parentheses-use-background nil) ; Set to nil to disable backgrounds
-(defun my-modus-themes-highlight-parentheses ()
+(defun my-modus-themes-highlight-parentheses (&rest _)
(modus-themes-with-colors
;; Our preference for setting either background or foreground
;; styles, depending on `my-highlight-parentheses-use-background'.
@@ -5160,14 +4526,14 @@ implementation:
;; Here we set color combinations that involve both a background
;; and a foreground value.
- (setq highlight-parentheses-background-colors (list cyan-refine-bg
- magenta-refine-bg
- green-refine-bg
- yellow-refine-bg)
- highlight-parentheses-colors (list cyan-refine-fg
- magenta-refine-fg
- green-refine-fg
- yellow-refine-fg))
+ (setq highlight-parentheses-background-colors (list bg-cyan-intense
+ bg-magenta-intense
+ bg-green-intense
+ bg-yellow-intense)
+ highlight-parentheses-colors (list cyan
+ magenta
+ green
+ yellow))
;; And here we pass only foreground colors while disabling any
;; backgrounds.
@@ -5187,6 +4553,8 @@ implementation:
(add-hook 'modus-themes-after-load-theme-hook #'my-modus-themes-highlight-parentheses)
#+end_src
+[[#h:d87673fe-2ce1-4c80-a4b8-be36ca9f2d24][Using a hook at the post-load-theme phase]].
+
As always, re-load the theme for changes to take effect.
** Note on mmm-mode.el background colors
@@ -5221,7 +4589,7 @@ Users who might prefer to fall below the minimum 7:1 contrast ratio in
relative luminance (the accessibility target we conform with), can opt
to configure the relevant faces on their own.
-[[#h:51ba3547-b8c8-40d6-ba5a-4586477fd4ae][Face specs at scale using the themes' palette]].
+[[#h:51ba3547-b8c8-40d6-ba5a-4586477fd4ae][Use theme colors in code with modus-themes-with-colors]].
This example uses more vivid background colors, though it comes at the
very high cost of degraded legibility.
@@ -5229,14 +4597,14 @@ very high cost of degraded legibility.
#+begin_src emacs-lisp
(modus-themes-with-colors
(custom-set-faces
- `(mmm-cleanup-submode-face ((,class :background ,yellow-refine-bg)))
- `(mmm-code-submode-face ((,class :background ,bg-active)))
- `(mmm-comment-submode-face ((,class :background ,blue-refine-bg)))
- `(mmm-declaration-submode-face ((,class :background ,cyan-refine-bg)))
- `(mmm-default-submode-face ((,class :background ,bg-alt)))
- `(mmm-init-submode-face ((,class :background ,magenta-refine-bg)))
- `(mmm-output-submode-face ((,class :background ,red-refine-bg)))
- `(mmm-special-submode-face ((,class :background ,green-refine-bg)))))
+ `(mmm-cleanup-submode-face ((,c :background ,bg-yellow-intense)))
+ `(mmm-code-submode-face ((,c :background ,bg-inactive)))
+ `(mmm-comment-submode-face ((,c :background ,bg-blue-intense)))
+ `(mmm-declaration-submode-face ((,c :background ,bg-cyan-intense)))
+ `(mmm-default-submode-face ((,c :background ,bg-dim)))
+ `(mmm-init-submode-face ((,c :background ,bg-magenta-intense)))
+ `(mmm-output-submode-face ((,c :background ,bg-red-intense)))
+ `(mmm-special-submode-face ((,c :background ,bg-green-intense)))))
#+end_src
** Note on prism.el
@@ -5250,13 +4618,14 @@ 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 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.
+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.
In the following code snippets, we employ the ~modus-themes-with-colors~
-macro: [[#h:51ba3547-b8c8-40d6-ba5a-4586477fd4ae][Face specs at scale using the themes' palette]].
+macro: [[#h:51ba3547-b8c8-40d6-ba5a-4586477fd4ae][Use theme colors in code with modus-themes-with-colors]].
These are the minimum recommended settings with 16 colors:
@@ -5269,20 +4638,20 @@ These are the minimum recommended settings with 16 colors:
:colors (modus-themes-with-colors
(list fg-main
magenta
- cyan-alt-other
- magenta-alt-other
+ cyan-cooler
+ magenta-cooler
blue
- magenta-alt
- cyan-alt
- red-alt-other
+ magenta-warmer
+ cyan-warmer
+ red-cooler
green
fg-main
cyan
yellow
- blue-alt
- red-alt
- green-alt-other
- fg-special-warm)))
+ blue-warmer
+ red-warmer
+ green-cooler
+ yellow-faint)))
#+end_src
With 8 colors:
@@ -5296,11 +4665,11 @@ With 8 colors:
:colors (modus-themes-with-colors
(list blue
magenta
- magenta-alt-other
- cyan-alt-other
+ magenta-cooler
+ cyan-cooler
fg-main
- blue-alt
- red-alt-other
+ blue-warmer
+ red-cooler
cyan)))
#+end_src
@@ -5316,8 +4685,8 @@ to the themes' default aesthetic:
:colors (modus-themes-with-colors
(list blue
magenta
- magenta-alt-other
- green-alt)))
+ magenta-cooler
+ green-warmer)))
#+end_src
If you need to apply desaturation and lightening, you can use what the
@@ -5330,47 +4699,11 @@ examples with the 4, 8, 16 colors):
:lightens (cl-loop for i from 0 below 16 collect (* i 2.5))
:colors (modus-themes-with-colors
(list fg-main
- cyan-alt-other
- magenta-alt-other
+ cyan-cooler
+ magenta-cooler
magenta)))
#+end_src
-** Note on god-mode.el
-:properties:
-:alt_title: Note for god-mode
-:custom_id: h:4da1d515-3e05-47ef-9e45-8251fc7e986a
-:end:
-
-The ~god-mode~ library does not provide faces that could be configured by
-the Modus themes. Users who would like to get some visual feedback on
-the status of {{{kbd(M-x god-mode)}}} are instead encouraged by upstream to
-set up their own configurations, such as by changing the ~mode-line~ face
-([[#h:f4651d55-8c07-46aa-b52b-bed1e53463bb][Advanced customization]]). This is an adaptation of the approach
-followed in the upstream README:
-
-#+begin_src emacs-lisp
-(defun my-god-mode-update-mode-line ()
- "Make `mode-line' blue if God local mode is active."
- (modus-themes-with-colors
- (if god-local-mode
- (set-face-attribute 'mode-line nil
- :foreground blue-active
- :background bg-active-accent
- :box blue)
- (set-face-attribute 'mode-line nil
- :foreground fg-active
- :background bg-active
- :box fg-alt))))
-
-(add-hook 'post-command-hook 'my-god-mode-update-mode-line)
-#+end_src
-
-We employ the ~modus-themes-with-colors~ which provides access to color
-variables defined by the active theme. Its use is covered elsewhere in
-this manual ([[#h:51ba3547-b8c8-40d6-ba5a-4586477fd4ae][Face specs at scale using the themes' palette]]). As for the
-attributes that can be passed to each face, start by consulting the
-documentation string of ~set-face-attribute~.
-
** Note on company-mode overlay pop-up
:properties:
:custom_id: h:20cef8c4-d11f-4053-8b2c-2872925780b1
@@ -5387,6 +4720,8 @@ instead of overlays.[fn::
https://github.com/company-mode/company-mode/issues/1010][fn::
https://github.com/tumashu/company-posframe/]
+Also consider the ~corfu~ package.
+
** Note on ERC escaped color sequences
:properties:
:custom_id: h:98bdf319-1e32-4469-8a01-771200fba65c
@@ -5446,10 +4781,10 @@ Consult the doc string of ~shr-use-colors~.
:end:
#+cindex: Fonts in EWW, Elfeed, Ement, and SHR
-By default, packages that build on top of the Simple HTML Remember (=shr=)
-use proportionately spaced fonts. This is controlled by the user option
-~shr-use-fonts~, which is set to non-~nil~ by default. To use the standard
-font instead, set that variable to nil.
+By default, packages that build on top of the Simple HTML Remember
+(~shr~) use proportionately spaced fonts. This is controlled by the
+user option ~shr-use-fonts~, which is set to non-~nil~ by default. To
+use the standard font instead, set that variable to ~nil~.
[[#h:defcf4fc-8fa8-4c29-b12e-7119582cc929][Font configurations for Org and others]].
@@ -5466,9 +4801,10 @@ This is a non-exhaustive list.
:custom_id: h:8e636056-356c-4ca7-bc78-ebe61031f585
:end:
-The =ement.el= library by Adam Porter (also known as "alphapapa") defaults
-to a method of colorizing usernames in a rainbow style. This is
-controlled by the user option ~ement-room-prism~ and can be disabled with:
+The {{{file(ement.el)}}} library by Adam Porter (also known as
+"alphapapa") defaults to a method of colorizing usernames in a rainbow
+style. This is controlled by the user option ~ement-room-prism~ and
+can be disabled with:
#+begin_src emacs-lisp
(setq ement-room-prism nil)
@@ -5482,7 +4818,7 @@ slightly below our nominal target. Try this instead:
(setq ement-room-prism-minimum-contrast 7)
#+end_src
-With regard to fonts, Ement depends on =shr= ([[#h:e6c5451f-6763-4be7-8fdb-b4706a422a4c][Note on SHR fonts]]).
+With regard to fonts, Ement depends on ~shr~ ([[#h:e6c5451f-6763-4be7-8fdb-b4706a422a4c][Note on SHR fonts]]).
Since we are here, here is an excerpt from Ement's source code:
@@ -5500,38 +4836,6 @@ would be a good baseline for many themes and/or user configurations.
Our target is the highest of the sort, though we do not demand that
everyone conforms with it.
-** Note on Helm grep
-:properties:
-:custom_id: h:d28879a2-8e4b-4525-986e-14c0f873d229
-:end:
-
-There is one face from the Helm package that is meant to highlight the
-matches of a grep or grep-like command (=ag= or =ripgrep=). It is
-~helm-grep-match~. However, this face can only apply when the user does
-not pass =--color=always= as a command-line option for their command.
-
-Here is the docstring for that face, which is defined in the
-{{{file(helm-grep.el)}}} library (you can always visit the source code with
-{{{kbd(M-x find-library)}}}).
-
-#+begin_quote
-Face used to highlight grep matches. Have no effect when grep backend
-use "--color="
-#+end_quote
-
-The user must either remove =--color= from the flags passed to the grep
-function, or explicitly use =--color=never= (or equivalent). Helm
-provides user-facing customization options for controlling the grep
-function's parameters, such as ~helm-grep-default-command~ and
-~helm-grep-git-grep-command~.
-
-When =--color=always= is in effect, the grep output will use red text in
-bold letter forms to present the matching part in the list of
-candidates. That style still meets the contrast ratio target of >= 7:1
-(accessibility standard WCAG AAA), because it draws the reference to
-ANSI color number 1 (red) from the already-supported array of
-~ansi-color-names-vector~.
-
** Note on pdf-tools link hints
:properties:
:custom_id: h:2659d13e-b1a5-416c-9a89-7c3ce3a76574
@@ -5603,7 +4907,7 @@ those buttons. Disabling the logo fixes the problem:
The built-in ~goto-address-mode~ uses heuristics to identify URLs and
email addresses in the current buffer. It then applies a face to them
-to change their style. Some packages, such as =notmuch=, use this
+to change their style. Some packages, such as ~notmuch~, use this
minor-mode automatically.
The faces are not declared with ~defface~, meaning that it is better
@@ -5617,7 +4921,7 @@ consider including (or equivalent) this in their setup:
goto-address-mail-mouse-face 'highlight)
#+end_src
-My personal preference is to set ~goto-address-mail-face~ to nil, as
+My personal preference is to set ~goto-address-mail-face~ to ~nil~, as
it otherwise adds too much visual noise to the buffer (email addresses
stand out more, due to the use of the uncommon =@= character but also
because they are often enclosed in angled brackets).
@@ -5770,7 +5074,7 @@ more effective than trying to do the same with either red or blue (the
latter is the least effective in that regard).
When we need to work with several colors, it is always better to have
-sufficient maneuvering space, especially since we cannot pick arbitrary
+sufficient manoeuvring space, especially since we cannot pick arbitrary
colors but only those that satisfy the accessibility objectives of the
themes.
@@ -5824,7 +5128,7 @@ each of the three channels of light (red, green, blue). For example:
: xrandr --output LVDS1 --brightness 1.0 --gamma 0.76:0.75:0.68
Typography is another variable. Some font families are blurry at small
-point sizes. Others may have a regular weight that is lighter (thinner)
+point sizes. Others may have a regular weight that is lighter (thiner)
than that of their peers which may, under certain circumstances, cause a
halo effect around each glyph.
@@ -5849,15 +5153,15 @@ A good theme is one that does so with consistency, though not
uniformity.
In practical terms, a color scheme is what one uses when, for example,
-they edit the first sixteen escape sequences of a terminal emulator to
-the hues of their preference. The terminal offers the option to choose,
-say, the exact value of what counts as "red", but does not provide the
-means to control where that is mapped to and whether it should also have
-other qualities such as a bold weight for the underlying text or an
-added background color. In contradistinction, Emacs uses constructs
-known as "faces" which allow the user/developer to specify where a given
-color will be used and whether it should be accompanied by other
-typographic or stylistic attributes.
+they replace the first sixteen escape sequences of a terminal emulator
+with color values of their preference. The terminal offers the option
+to choose, say, the exact value of what counts as "red", but does not
+provide the means to control where that is mapped to and whether it
+should also have other qualities such as a bold weight for the
+underlying text or an added background color. In contradistinction,
+Emacs uses constructs known as "faces" which allow the user/developer
+to specify where a given color will be used and whether it should be
+accompanied by other typographic or stylistic attributes.
By configuring the multitude of faces on offer we thus control both
which colors are applied and how they appear in their context. When a
@@ -5876,9 +5180,7 @@ it is already understood that one must follow the indicator or headline
to view its contents and (ii) underlining everything would make the
interface virtually unusable.
-[[#h:5808be52-361a-4d18-88fd-90129d206f9b][Option for links]].
-
-Again, one must exercise judgment in order to avoid discrimination,
+Again, one must exercise judgement in order to avoid discrimination,
where "discrimination" refers to:
+ The treatment of substantially different magnitudes as if they were of
@@ -5888,9 +5190,9 @@ where "discrimination" refers to:
(To treat similar things differently; to treat dissimilar things alike.)
-If, in other words, one was to enforce uniformity without accounting for
-the particular requirements of each case---the contextual demands for
-usability beyond matters of color---they would be making a
+If, in other words, one is to enforce uniformity without accounting
+for the particular requirements of each case---the contextual demands
+for usability beyond matters of color---they are making a
not-so-obvious error of treating different cases as if they were the
same.
@@ -5923,13 +5225,13 @@ doing so would run contrary to how this project is maintained where
details matter greatly.
Each program has its own requirements so it won't always be
-possible---or indeed desirable---to have 1:1 correspondence between what
-applies to Emacs and what should be done elsewhere. No port should ever
-strive to be a faithful copy of the Emacs implementation, as no other
-program is an Emacs equivalent, but instead try to follow the spirit of
-the design. For example, some of the customization options accept a
-list as their value, or an alist, which may not be possible to reproduce
-on other platforms.
+possible---or indeed desirable---to have 1:1 correspondence between
+what applies to Emacs and what should be done elsewhere. No port
+should ever strive to be a copy of the Emacs implementation, as no
+other program is an Emacs equivalent, but instead try to follow the
+spirit of the design. For example, some of the customization options
+accept a list as their value, or an alist, which may not be possible
+to reproduce on other platforms.
[[#h:bf1c82f2-46c7-4eb2-ad00-dd11fdd8b53f][Customization options]].
@@ -5939,10 +5241,11 @@ standards are not compromised and (ii) the overall character of the
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 color deficiency (deuteranopia) by
-avoiding red+green color coding paradigms and/or by providing red+blue
-variants.
+scientific foundations of the themes: high legibility and taking care
+of the needs of users with red-green/blue-yellow color deficiency
+(deuteranopia and tritanopia) by avoiding red+green color coding
+paradigms and/or by providing yellow+blue variants for deuteranopia
+and red+cyan for tritanopia ([[#h:f0f3dbcb-602d-40cf-b918-8f929c441baf][Overview]]).
The latter criterion is the "je ne sais quoi" of the artistic aspect of
the themes, which is partially fleshed out in this manual.
@@ -5951,7 +5254,7 @@ the themes, which is partially fleshed out in this manual.
With regard to the artistic aspect (where "art" qua skill may amount to
an imprecise science), there is no hard-and-fast rule in effect as it
-requires one to exercise discretion and make decisions based on
+requires one to exercize discretion and make decisions based on
context-dependent information or constraints. As is true with most
things in life, when in doubt, do not cling on to the letter of the law
but try to understand its spirit.
@@ -5980,13 +5283,17 @@ in which you can contribute to their ongoing development.
:end:
#+cindex: Sources of the themes
-The ~modus-operandi~ and ~modus-vivendi~ themes are built into Emacs 28.
-
-The source code of the themes is [[https://git.sr.ht/~protesilaos/modus-themes][available on SourceHut]]. Or check the
-[[https://gitlab.com/protesilaos/modus-themes/][GitLab mirror (former main source)]] and the [[https://github.com/protesilaos/modus-themes/][GitHub mirror]].
-
-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).
++ Package name (GNU ELPA): ~modus-themes~
++ Official manual: <https://protesilaos.com/emacs/modus-themes>
++ Change log: <https://protesilaos.com/emacs/modus-themes-changelog>
++ Color palette: <https://protesilaos.com/emacs/modus-themes-colors>
++ Sample pictures: <https://protesilaos.com/emacs/modus-themes-pictures>
++ Git repo on SourceHut: <https://git.sr.ht/~protesilaos/modus-themes>
+ - Mirrors:
+ + GitHub: <https://github.com/protesilaos/modus-themes>
+ + GitLab: <https://gitlab.com/protesilaos/modus-themes>
++ Mailing list: <https://lists.sr.ht/~protesilaos/modus-themes>
++ Backronym: My Old Display Unexpectedly Sharpened ... themes
** Issues you can help with
:properties:
@@ -5994,10 +5301,8 @@ An HTML version of this manual is provided as an extension of the
:end:
#+cindex: Contributing
-#+findex: modus-themes-report-bug
A few tasks you can help with by sending an email to the general
-[[https://lists.sr.ht/~protesilaos/modus-themes][modus-themes public mailing list]] (or use the command
-~modus-themes-report-bug~).
+[[https://lists.sr.ht/~protesilaos/modus-themes][modus-themes public mailing list]].
+ Suggest refinements to packages that are covered.
+ Report packages not covered thus far.
@@ -6014,10 +5319,6 @@ It is preferable that your feedback includes some screenshots, GIFs, or
short videos, as well as further instructions to reproduce a given
setup. Though this is not a requirement.
-#+findex: modus-themes-version
-Also consider mentioning the version of the themes you are using, such
-as by invoking the command ~modus-themes-version~.
-
Whatever you do, bear in mind the overarching objective of the Modus
themes: to keep a contrast ratio that is greater or equal to 7:1 between
background and foreground colors. If a compromise is ever necessary
@@ -6097,45 +5398,54 @@ 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, Antonio Ruiz, Basil L.{{{space()}}} Contovounesios, Björn
- Lindström, Carlo Zancanaro, Christian Tietze, Daniel Mendler, Eli
- Zaretskii, Fritz Grabo, Illia Ostapyshyn, Kévin Le Gouguec, Koen van
- Greevenbroek, Kostadin Ninev, Madhavan Krishnan, Manuel Giraud,
- Markus Beppler, Matthew Stevenson, Mauro Aranda, Nicolas De
- Jaeghere, Paul David, Philip Kaludercic, Pierre Téchoueyres, Rudolf
- Adamkovič, Stephen Gildea, Shreyas Ragavan, Stefan Kangas, Utkarsh
- Singh, Vincent Murphy, Xinglu Chen, Yuanchen Xie, okamsn.
++ Contributions to code or documentation :: Aleksei Gusev, Alex
+ Griffin, Anders Johansson, Antonio Ruiz, Basil L.{{{space()}}}
+ Contovounesios, Björn Lindström, Carlo Zancanaro, Christian Tietze,
+ Daniel Mendler, David Edmondson, Eli Zaretskii, Fritz Grabo, Gautier
+ Ponsinet, Illia Ostapyshyn, Kévin Le Gouguec, Koen van Greevenbroek,
+ Kostadin Ninev, Madhavan Krishnan, Manuel Giraud, Markus Beppler,
+ Matthew Stevenson, Mauro Aranda, Nacho Barrientos, Niall Dooley,
+ Nicolas De Jaeghere, Paul David, Philip Kaludercic, Pierre
+ Téchoueyres, Rudolf Adamkovič, Sergey Nichiporchik, Shreyas Ragavan,
+ Stefan Kangas, Stephen Berman, Stephen Gildea, Steve Downey, Tomasz
+ Hołubowicz, Utkarsh Singh, Vincent Murphy, Xinglu Chen, Yuanchen
+ Xie, fluentpwn, okamsn.
+ 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, Andrew
- Tropin, Antonio Hernández Blas, Arif Rezai, Augusto Stoffel, Basil
- L.{{{space()}}} Contovounesios, Burgess Chang, Christian Tietze,
+ Adrian Manea, Aleksei Pirogov, Alex Griffin, Alex Koen, Alex
+ Peitsinis, Alexey Shmalko, Alok Singh, Anders Johansson, André
+ Alexandre Gomes, Andrew Tropin, Antonio Hernández Blas, Arif Rezai,
+ Augusto Stoffel, Basil L.{{{space()}}} Contovounesios, Bernd
+ Rellermeyer, Burgess Chang, Charlotte Van Petegem, Christian Tietze,
Christopher Dimech, Christopher League, 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,
Gonçalo Marrafa, Guilherme Semente, Gustavo Barros, Hörmetjan
- Yiltiz, Ilja Kocken, Iris Garcia, Ivan Popovych, Jeremy Friesen,
- Jerry Zhang, Johannes Grødem, John Haman, Jonas Collberg, Jorge
- Morais, Joshua O'Connor, Julio C. Villasante, Kenta Usami, Kevin
- Fleming, Kévin Le Gouguec, Kevin Kainan Li, Kostadin Ninev, Len
- Trigg, Lennart C. Karssen, Luis Miguel Castañeda, Magne Hov, Manuel
- Uberti, Mark Bestley, Mark Burton, Mark Simpson, Markus Beppler,
- Matt Armstrong, Matthias Fuchs, Mauro Aranda, Maxime Tréca, Michael
- Goldenberg, Morgan Smith, Morgan Willcock, Murilo Pereira, Nicky van
- Foreest, Nicolas De Jaeghere, Pablo Stafforini, Paul Poloskov,
- Pengji Zhang, Pete Kazmier, Peter Wu, Philip Kaludercic, Pierre
- Téchoueyres, Przemysław Kryger, 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, Summer Emacs,
- TheBlob42, Trey, bepolymathe, bit9tream, derek-upham, doolio,
- fleimgruber, gitrj95, iSeeU, jixiuf, okamsn, pRot0ta1p.
+ Yiltiz, Ilja Kocken, Imran Khan, Iris Garcia, Ivan Popovych, James
+ Ferguson, Jeremy Friesen, Jerry Zhang, Johannes Grødem, John Haman,
+ John Wick, Jonas Collberg, Jorge Morais, Joshua O'Connor, Julio C.
+ Villasante, Kenta Usami, Kevin Fleming, Kévin Le Gouguec, Kevin
+ Kainan Li, Kostadin Ninev, Laith Bahodi, Lasse Lindner, Len Trigg,
+ Lennart C.{{{space()}}} Karssen, Luis Miguel Castañeda, Magne Hov, Manuel Giraud,
+ Manuel Uberti, Mark Bestley, Mark Burton, Mark Simpson, Marko Kocic,
+ Markus Beppler, Matt Armstrong, Matthias Fuchs, Mattias Engdegård,
+ Mauro Aranda, Maxime Tréca, Michael Goldenberg, Morgan Smith, Morgan
+ Willcock, Murilo Pereira, Nicky van Foreest, Nicolas De Jaeghere,
+ Nicolas Semrau, Olaf Meeuwissen, Oliver Epper, Pablo Stafforini,
+ Paul Poloskov, Pengji Zhang, Pete Kazmier, Peter Wu, Philip
+ Kaludercic, Pierre Téchoueyres, Przemysław Kryger, Robert Hepple,
+ Roman Rudakov, Russell Sim, Ryan Phillips, Rytis Paškauskas, Rudolf
+ Adamkovič, Sam Kleinman, Samuel Culpepper, Saša Janiška, Shreyas
+ Ragavan, Simon Pugnet, Steve Downey, Tassilo Horn, Thanos Apollo,
+ Thibaut Verron, Thomas Heartman, Togan Muftuoglu, Tony Zorman, Trey
+ Merkley, Tomasz Hołubowicz, Toon Claes, Uri Sharf, Utkarsh Singh,
+ Vincent Foley, Zoltan Kiraly. As well as users: Ben, CsBigDataHub1,
+ Emacs Contrib, Eugene, Fourchaux, Fredrik, Moesasji, Nick, Summer
+ Emacs, TheBlob42, TitusMu, Trey, bepolymathe, bit9tream,
+ bangedorrunt, derek-upham, doolio, fleimgruber, gitrj95, iSeeU,
+ jixiuf, ltmsyvag, okamsn, pRot0ta1p, soaringbird, tumashu,
+ wakamenod.
+ Packaging :: Basil L.{{{space()}}} Contovounesios, Eli Zaretskii,
Glenn Morris, Mauro Aranda, Richard Stallman, Stefan Kangas (core
@@ -6153,42 +5463,6 @@ themes' design and/or aspects of their functionality.
All errors are my own.
-* Other notes about the project
-:properties:
-:custom_id: h:13752581-4378-478c-af17-165b6e76bc1b
-:end:
-#+cindex: Development notes
-
-If you are curious about the principles that govern the development of
-this project read the essay [[https://protesilaos.com/codelog/2020-03-17-design-modus-themes-emacs/][On the design of the Modus themes]]
-(2020-03-17).
-
-Here are some more publications for those interested in the kind of work
-that goes into this project (sometimes the commits also include details
-of this sort):
-
-+ [[https://protesilaos.com/codelog/2020-05-10-modus-operandi-palette-review/][Modus Operandi theme subtle palette review]] (2020-05-10)
-+ [[https://protesilaos.com/codelog/2020-06-13-modus-vivendi-palette-review/][Modus Vivendi theme subtle palette review]] (2020-06-13)
-+ [[https://protesilaos.com/codelog/2020-07-04-modus-themes-faint-colours/][Modus themes: new "faint syntax" option]] (2020-07-04)
-+ [[https://protesilaos.com/codelog/2020-07-08-modus-themes-nuanced-colours/][Modus themes: major review of "nuanced" colours]] (2020-07-08)
-+ [[https://protesilaos.com/codelog/2020-09-14-modus-themes-review-blues/][Modus themes: review of blue colours]] (2020-09-14)
-+ [[https://protesilaos.com/codelog/2020-12-27-modus-themes-review-rainbow-delimiters/][Modus themes: review rainbow-delimiters faces]] (2020-12-27)
-+ [[https://protesilaos.com/codelog/2021-01-11-modus-themes-review-select-faint-colours/][Modus themes: review of select "faint" colours]] (2021-01-11)
-+ [[https://protesilaos.com/codelog/2021-02-25-modus-themes-diffs-deuteranopia/][The Modus themes now cover deuteranopia in diffs]] (2021-02-25)
-+ [[https://protesilaos.com/codelog/2021-06-02-modus-themes-org-agenda/][Introducing the variable modus-themes-org-agenda]] (2021-06-02)
-+ [[https://protesilaos.com/codelog/2022-01-02-review-modus-themes-org-habit-colours/][Modus themes: review of the org-habit graph colours]] (2022-01-02)
-+ [[https://protesilaos.com/codelog/2022-01-03-modus-themes-port-faq/][Re: VSCode or Vim ports of the Emacs modus-themes?]] (2022-01-03)
-+ [[https://protesilaos.com/codelog/2022-04-20-modus-themes-case-study-avy/][Modus themes: case study on Avy faces and colour combinations]] (2022-04-20)
-+ [[https://protesilaos.com/codelog/2022-04-21-modus-themes-colour-theory/][Emacs: colour theory and techniques used in the Modus themes]] (2022-04-21)
-
-And here are the canonical sources of this project:
-
-+ Manual :: <https://protesilaos.com/emacs/modus-themes>
-+ Change Log :: <https://protesilaos.com/emacs/modus-themes-changelog>
-+ Screenshots :: <https://protesilaos.com/emacs/modus-themes-pictures>
-+ Git repository :: https://git.sr.ht/~protesilaos/modus-themes
-+ Mailing list :: https://lists.sr.ht/~protesilaos/modus-themes
-
* GNU Free Documentation License
:properties:
:appendix: t
diff --git a/doc/misc/newsticker.texi b/doc/misc/newsticker.texi
index ab031fd4059..a2ceedf7399 100644
--- a/doc/misc/newsticker.texi
+++ b/doc/misc/newsticker.texi
@@ -307,11 +307,16 @@ news ticker.
@findex newsticker-start-ticker
@findex newsticker-stop-ticker
+@vindex newsticker-ticker-period
Headlines can be displayed in the echo area, either scrolling like
messages in a stock-quote ticker, or just changing. This can be
started with the command @code{newsticker-start-ticker}. It can be
stopped with @code{newsticker-stop-ticker}.
+The ticker by default runs continuously. To only run it once, at a
+specific time interval, set the @code{newsticker-ticker-period}
+variable.
+
@node Navigation
@section Navigation
@@ -542,8 +547,10 @@ are shown in the echo area, i.e., the ``ticker''.
@itemize
@item
@vindex newsticker-display-interval
+@vindex newsticker-ticker-period
@vindex newsticker-scroll-smoothly
-@code{newsticker-ticker-interval} and
+@code{newsticker-ticker-interval},
+@code{newsticker-ticker-period}, and
@code{newsticker-scroll-smoothly} define how headlines are shown in
the echo area.
@end itemize
diff --git a/doc/misc/octave-mode.texi b/doc/misc/octave-mode.texi
index 8b3b9b41f06..437aac35292 100644
--- a/doc/misc/octave-mode.texi
+++ b/doc/misc/octave-mode.texi
@@ -419,7 +419,7 @@ when Octave is waiting for input, or done sending output.
@bye
-@c TODO Update
+@c TODO Update (and change gnuserv to emacsclient)
@c @node Using the Emacs Info Reader for Octave
@c @chapter Using the Emacs Info Reader for Octave
diff --git a/doc/misc/org.org b/doc/misc/org.org
index 9535eccc1e6..05ab5b36ca0 100644
--- a/doc/misc/org.org
+++ b/doc/misc/org.org
@@ -3619,7 +3619,7 @@ replacement text. Here is an example:
#+begin_src emacs-lisp
(setq org-link-abbrev-alist
- '(("bugzilla" . "http://10.1.2.9/bugzilla/show_bug.cgi?id=")
+ '(("bugzilla" . "https://10.1.2.9/bugzilla/show_bug.cgi?id=")
("Nu Html Checker" . "https://validator.w3.org/nu/?doc=%h")
("duckduckgo" . "https://duckduckgo.com/?q=%s")
("omap" . "https://nominatim.openstreetmap.org/search?q=%s&polygon=1")
@@ -9431,7 +9431,7 @@ the estimated effort of an entry (see [[*Effort Estimates]]).
#+vindex: org-agenda-effort-filter-preset
#+vindex: org-agenda-regexp-filter-preset
Agenda built-in or custom commands are statically defined. Agenda
-filters and limits allow to flexibly narrow down the list of agenda
+filters and limits allow flexibly narrowing down the list of agenda
entries.
/Filters/ only change the visibility of items, are very fast and are
@@ -20693,8 +20693,8 @@ adding ~:rewrites~ rules like this:
#+texinfo: @noindent
Since =example.com/$= is used as a regular expression, it maps
-=http://example.com/=, =https://example.com=,
-=http://www.example.com/= and similar to
+=https://example.com/=, =https://example.com=,
+=https://www.example.com/= and similar to
=/home/user/example/index.php=.
The ~:rewrites~ rules are searched as a last resort if and only if no
diff --git a/doc/misc/rcirc.texi b/doc/misc/rcirc.texi
index 1d1016a4d9a..9ae4bb4a17c 100644
--- a/doc/misc/rcirc.texi
+++ b/doc/misc/rcirc.texi
@@ -691,11 +691,11 @@ window is showing them), the mode line will now show you the abbreviated
channel or nick name. Use @kbd{C-c C-@key{SPC}} to switch to these
buffers.
-@cindex rcirc-track-abbrevate-flag
+@cindex rcirc-track-abbreviate-flag
By default the channel names are abbreviated, set
-@code{rcirc-track-abbrevate-flag} to a non-@code{nil} value. This might be
-interesting if the IRC activities are not tracked in the mode line,
-but somewhere else.
+@code{rcirc-track-abbreviate-flag} to a non-@code{nil} value. This
+might be interesting if the IRC activities are not tracked in the mode
+line, but somewhere else.
@vindex rcirc-mode-hook
If you prefer not to load @code{rcirc} immediately, you can delay the
@@ -929,6 +929,7 @@ Manual}, for details.
@cindex date time
@cindex format time stamp
@vindex rcirc-time-format
+@vindex rcirc-log-time-format
@code{rcirc-time-format} is the format used for the time stamp. Here's
how to include the date in the time stamp:
@@ -937,6 +938,9 @@ how to include the date in the time stamp:
(setopt rcirc-time-format "%Y-%m-%d %H:%M ")
@end example
+For log files, a different time format can be specified using the
+@code{rcirc-log-time-format} user option.
+
@findex rcirc-when
If you don't wish to use verbose time formatting all the time, you can
use the @code{rcirc-when} command to display a complete timestamp for
diff --git a/doc/misc/sc.texi b/doc/misc/sc.texi
index 7f46ef9a195..5176797cde8 100644
--- a/doc/misc/sc.texi
+++ b/doc/misc/sc.texi
@@ -404,7 +404,7 @@ from the alist with the @code{sc-mail-field} function. Thus, if the
following fields were present in the original article:
@example
-Date:@: 08 April 1991, 17:32:09 EST
+Date:@: 08 Apr 1991 17:32:09 -0500
Subject:@: Better get out your asbestos suit
@end example
@@ -415,7 +415,7 @@ then, the following lisp constructs return:
@example
(sc-mail-field "date")
-==> "08 April 1991, 17:32:09 EST"
+==> "08 Apr 1991 17:32:09 -0500"
(sc-mail-field "subject")
==> "Better get out your asbestos suit"
diff --git a/doc/misc/ses.texi b/doc/misc/ses.texi
index a3aa68cdd0e..8500a0f08c4 100644
--- a/doc/misc/ses.texi
+++ b/doc/misc/ses.texi
@@ -91,8 +91,8 @@ To report bugs, use @kbd{M-x report-emacs-bug}.
@item Printer functions for control of cell appearance.
@item Intuitive keystroke commands: C-o = insert row, M-o = insert column, etc.
@item ``Spillover'' of lengthy cell values into following blank cells.
-@item Header line shows column letters or a selected row.
-@item Completing-read for entering symbols as cell values.
+@item Header line shows column letters.
+@item Completing-read for entering symbols of named cells when editing formulas.
@item Cut, copy, and paste can transfer formulas and printer functions.
@item Import and export of tab-separated values or tab-separated formulas.
@item Plaintext, easily-hacked file format.
@@ -109,12 +109,12 @@ If you want to get started quickly and think that you know what to
expect from a simple spreadsheet, this chapter may be all that you
need.
-First, visit a new file with the @file{.ses} extension.
+First, visit a new file with the @file{.ses} file name extension.
Emacs presents you with an empty spreadsheet containing a single cell.
-Begin by inserting a headline: @kbd{"Income"@key{RET}}. The double
-quotes indicate that this is a text cell. (Notice that Emacs
-automatically inserts the closing quotation mark.)
+Begin by inserting a headline: @kbd{"Income@key{RET}}. The double
+quotes indicate that you are editing a text cell, it is not part of
+the cell value, and no closing quotation mark is needed.
To insert your first income value, you must first resize the
spreadsheet. Press @key{TAB} to add a new cell and navigate back up
@@ -138,9 +138,10 @@ To add up the values, enter a Lisp expression:
(+ A2 A3 A4 A5)
@end example
-Perhaps you want to add a cell to the right of cell A4 to explain
-why you have a negative entry. Pressing @kbd{TAB} in that cell
-adds an entire new column @samp{B}, where you can add such a note.
+Perhaps you want to add a cell to the right of cell @samp{A4} to
+explain why you have a negative entry. Pressing @kbd{TAB} in that
+cell adds an entire new column @samp{B}, where you can add such a
+note.
The column is fairly narrow by default, but pressing @kbd{w} allows
you to resize it as needed. Make it 20 characters wide. You can
@@ -158,19 +159,24 @@ A B
@end group
@end example
-By default, the labels in column B are right-justified. To change
-that, you can enter a printer function for the whole column, using
-e.g., @kbd{M-p ("%s")}. You can override a column's printer function
-in any individual cell using @kbd{p}.
+By default, the cell value print-out is right aligned, that is the
+reason for such an alignment for the notes in column @samp{B}. To
+change that, you can enter a printer function for the whole column,
+using e.g., @kbd{M-p ("%s")}. Enclosing @code{"%s"} into a list tells
+@acronym{SES} to align left. You can override a column's printer
+function in any individual cell using @kbd{p}.
+
+@c TODO : propagate extra explanation from the French version.
If Joe pays back his loan, you might blank that entry; e.g., by
-positioning the cursor in cell A5 and pressing @kbd{C-d} twice.
-If you do that, the total cell will display @samp{######}. That is
-because the regular @code{+} operator does not handle a range that
-contains some empty cells. Instead of emptying the cell, you could
-enter a literal @samp{0}, or delete the entire row using @kbd{C-k}.
-An alternative is to use the special function @code{ses+} instead of
-the regular @code{+}:
+positioning the cursor in cell A5 and pressing @kbd{C-d}. If you do
+that, the total printed out in cell A6 will display @samp{######}.
+That is because the value in an empty cell is typically @code{nil},
+and the regular @code{+} operator fails to handle a range that
+contains that value. Instead of emptying the cell, you could enter a
+literal @samp{0}, or delete the entire row using @kbd{C-k}. An
+alternative is to use the special function @code{ses+} instead of the
+regular @code{+}:
@example
(ses+ A2 A3 A4 A5)
@@ -188,13 +194,18 @@ the end-points, e.g.:
@emph{list} of values. This allows for more complex possibilities.)
Alternatively you can use the @code{!} modifier of @code{ses-range} to
-remove blank cells from the returned list, which allows to use
+remove blank cells from the returned list, which enables using
@code{+} instead of @code{ses+}:
@lisp
(apply '+ (ses-range A2 A5 !))
@end lisp
+Actually, both options are not exactly equivalent as the former makes
+the summing in reversed order of argument, and the latter in the same
+order. You can also reverse the order of arguments returned by
+@code{ses-range} with the @code{<} modifier.
+
@c ===================================================================
@node The Basics
@@ -209,7 +220,7 @@ remove blank cells from the returned list, which allows to use
@findex keyboard-quit
To create a new spreadsheet, visit a nonexistent file whose name ends
-with ".ses". For example, @kbd{C-x C-f test.ses @key{RET}}.
+with @file{.ses}. For example, @kbd{C-x C-f test.ses @key{RET}}.
A @dfn{cell identifier} is a symbol with a column letter and a row
@@ -224,18 +235,18 @@ 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
+@samp{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.
When mark is inactive, the current cell is underlined. When mark is
-active, the range is the highlighted rectangle of cells (@acronym{SES} always
-uses transient mark mode). Drag the mouse from A1 to A3 to create the
-range A1-A2. Many @acronym{SES} commands operate only on single cells, not
-ranges.
+active, the range is the highlighted rectangle of cells (@acronym{SES}
+always uses transient mark mode). Drag the mouse from @samp{A1} to
+@samp{A3} to create the range @samp{A1-A2}. Many @acronym{SES}
+commands operate only on single cells, not ranges.
@table @kbd
@item C-@key{SPC}
@@ -288,11 +299,11 @@ Self-insert a digit (@code{ses-read-cell}).
Self-insert a negative number (@code{ses-read-cell}).
@item .
-Self-insert a fractional number (@code{ses-read-cell}).
+Self-insert a decimal number (@code{ses-read-cell}).
@item "
-Self-insert a quoted string. The ending double-quote
-is inserted for you (@code{ses-read-cell}).
+Self-insert a string. The ending double-quote is inserted for you
+(@code{ses-read-cell}).
@item (
Self-insert an expression. The right-parenthesis is inserted for you
@@ -308,9 +319,10 @@ to list the named cells symbols in a help buffer.
@end table
@item ' @r{(apostrophe)}
-Enter a symbol (ses-read-symbol). @acronym{SES} remembers all symbols that have
-been used as formulas, so you can type just the beginning of a symbol
-and use @kbd{@key{SPC}}, @kbd{@key{TAB}}, and @kbd{?} to complete it.
+Enter a symbol (@code{ses-read-symbol}). @acronym{SES} remembers all
+symbols that have been used as formulas, so you can type just the
+beginning of a symbol and use @kbd{@key{SPC}}, @kbd{@key{TAB}}, and
+@kbd{?} to complete it.
@end table
To enter something else (e.g., a vector), begin with a digit, then
@@ -421,8 +433,8 @@ string is right-aligned within the print cell. To get left-alignment,
use parentheses: @samp{("$%.2f")}.
@item
A printer can also be a one-argument function, the result of which is
-a string (right-aligned) or list of one string (left-aligned). Such a
-function can be in turn configured as:
+a string (to get right alignment) or list of one string (to get left
+alignment). Such a function can be in turn configured as:
@itemize
@item
A lambda expression, for instance:
@@ -495,7 +507,7 @@ To list the local printers in a help buffer.
Except for @code{ses-prin1}, the other standard printers are suitable
only for cells, not columns or default, because they format the value
using the column-printer (or default-printer if @code{nil}) and then
-center the result:
+post-process the result, eg.@: center it:
@ftable @code
@item ses-center
@@ -505,13 +517,13 @@ Just centering.
Centering with spill-over to following blank cells.
@item ses-dashfill
-Centering using dashes (-) instead of spaces.
+Centering using dashes (@samp{-}) instead of spaces.
@item ses-dashfill-span
Centering with dashes and spill-over.
@item ses-tildefill-span
-Centering with tildes (~) and spill-over.
+Centering with tildes (@samp{~}) and spill-over.
@item ses-prin1
This is the fallback printer, used when calling the configured printer
@@ -545,9 +557,9 @@ you can add some code like this to your @file{.emacs} init file:
'euro
(lambda (x)
(cond
- ((null x) "")
- ((numberp x) (format "%.2f€" x))
- (t (ses-center-span x ?# 'ses-prin1)))))))
+ ((null x) "")
+ ((numberp x) (format "%.2f€" x))
+ (t (ses-center-span x ?# 'ses-prin1)))))))
(add-hook 'ses-mode-hook 'my-ses-mode-hook)
@end lisp
@@ -599,29 +611,31 @@ s-expression (using @code{ses-prin1}), centered and surrounded by
@code{#} filling.
@end itemize
-Another precaution to take is to avoid stack overflow due to a
-printer function calling itself indefinitely. This mistake can
-happen when you use a local printer as a column printer,
-and this local printer implicitly calls the current column printer, so it
-will call itself recursively. Imagine for instance that you want to
-create some local printer @code{=fill} that would center the content
-of a cell and surround it by equal signs @code{=}, and you do it this
+Another precaution to take is to avoid stack overflow due to a printer
+function calling itself indefinitely. This mistake can happen when
+you use a local printer as a column printer, and this local printer
+implicitly calls the current column printer, so it will call itself
+recursively. Imagine for instance that you want to create some local
+printer @code{=fill} that would center the content of a cell and
+surround it by equal signs @code{=}, and you do it (errounously) this
way:
@lisp
+;; ERRONEOUS CODE
(lambda (x)
(cond
((null x) "")
(t (ses-center x 0 ?=))))
@end lisp
-Because @code{=fill} uses the standard printer @code{ses-center} without
-explicitly passing any printer to it, @code{ses-center} will call the
-current column printer if any, or the spreadsheet default printer
-otherwise. So using @code{=fill} as a column printer will result in a
-stack overflow in this column. SES does not check for that;
-you just have to be careful. For instance, re-write @code{=fill} like
-this:
+Because @code{=fill} uses the standard printer @code{ses-center}
+without explicitly passing any printer to it, @code{ses-center} will
+call the current column printer if any, or the spreadsheet default
+printer otherwise. So using @code{=fill} as a column printer will
+result in a stack overflow in this column on any non empty cell as
+@code{ses-center} will recursively recall the function that has called
+it. @acronym{SES} does not check for that; you just have to be
+careful. For instance, re-write @code{=fill} like this:
@lisp
(lambda (x)
@@ -631,11 +645,17 @@ this:
(t (ses-center-span x ?# 'ses-prin1))))
@end lisp
+The code above is fixed as @code{ses-center} and
+@code{ses-center-span} are both called with an explicit last
+@var{printer} argument, respectively @code{" %s "} and
+@code{'ses-prin1}.
+
The code above applies the @code{=} filling only to strings; it also
surrounds the string by one space on each side before filling with
-@code{=} signs. So the string @samp{Foo} will be displayed like @samp{@w{===
-Foo ===}} in an 11 character wide column. Anything other than an empty cell
-or a non-string is displayed as an error by using @code{#} filling.
+@code{=} signs. So the string @samp{Foo} will be displayed like
+@samp{@w{=== Foo ===}} in an 11 character wide column. Any value that
+is neither @code{nil} (ie.@: an empty cell) nor a string is displayed
+as an error by using @code{#} filling.
@node Clearing cells
@section Clearing cells
@@ -647,7 +667,7 @@ These commands set both formula and printer to @code{nil}:
@table @kbd
@item @key{DEL}
-Clear cell and move left (@code{ses-clear-cell-backward}).
+Move left and clear cell (@code{ses-clear-cell-backward}).
@item C-d
Clear cell and move right (@code{ses-clear-cell-forward}).
@@ -699,9 +719,10 @@ Paste from kill ring (@code{yank}). The paste functions behave
differently depending on the format of the text being inserted:
@itemize @bullet
@item
-When pasting cells that were cut from a @acronym{SES} buffer, the print text is
-ignored and only the attached formula and printer are inserted; cell
-references in the formula are relocated unless you use @kbd{C-u}.
+When pasting cells that were cut or copied from a @acronym{SES}
+buffer, the print text is ignored and only the attached formula and
+printer are inserted; cell references in the formula are relocated
+unless you use @kbd{C-u}.
@item
The pasted text overwrites a rectangle of cells whose top left corner
is the current cell. If part of the rectangle is beyond the edges of
@@ -738,8 +759,11 @@ 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
can be customized. Look in group ``ses''.
-After entering a cell value, point normally moves right to the next
-cell. You can customize @code{ses-after-entry-functions} to move left or
+After entering a cell value, normally, @code{forward-char} is called,
+which moves point right to the next cell@c TODO propagate extra
+ @c explanation from the French
+ @c version.
+. You can customize @code{ses-after-entry-functions} to move left or
up or down. For diagonal movement, select two functions from the
list.
@@ -747,6 +771,7 @@ list.
@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}),
+@c TODO : propagate extra explanation from the French version.
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
@@ -763,8 +788,9 @@ when you give a prefix argument to the @command{ses-jump} command
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.
+down, so assuming a 4x3 spreadsheet prefix argument @samp{0} jumps to
+cell @samp{A1}, prefix argument @samp{2} jumps to @samp{C1}, prefix
+argument @samp{3} jumps to @samp{A2}, etc.
@vindex ses-mode-hook
@code{ses-mode-hook} is a normal mode hook (list of functions to
@@ -813,7 +839,7 @@ Rename a cell from a standard A1-like name to any string that can be a
valid local variable name (See also @ref{Nonrelocatable references}).
@item M-x ses-repair-cell-reference-all
@findex ses-repair-cell-reference-all
-When you interrupt a cell formula update by clicking @kbd{C-g}, then
+When you interrupt a cell formula update by typing @kbd{C-g}, then
the cell reference link may be broken, which will jeopardize automatic
cell update when any other cell on which it depends is changed. To
repair that use function @code{ses-repair-cell-reference-all}
@@ -891,17 +917,17 @@ and the new row is included in the sum.
While entering or editing a formula in the minibuffer, you can select
a range in the spreadsheet (using mouse or keyboard), then paste a
representation of that range into your formula. Suppose you select
-A1-C1:
+@samp{A1-C1}:
@table @kbd
@item [S-mouse-3]
-Inserts "A1 B1 C1" @code{(ses-insert-range-click})
+Inserts @samp{A1 B1 C1} (@code{ses-insert-range-click})
@item C-c C-r
Keyboard version (@code{ses-insert-range}).
@item [C-S-mouse-3]
-Inserts "(ses-range A1 C1)" (@code{ses-insert-ses-range-click}).
+Inserts @samp{(ses-range A1 C1)} (@code{ses-insert-ses-range-click}).
@item C-c C-s
Keyboard version (@code{ses-insert-ses-range}).
@@ -909,7 +935,8 @@ Keyboard version (@code{ses-insert-ses-range}).
If you delete the @var{from} or @var{to} cell for a range, the nearest
still-existing cell is used instead. If you delete the entire range,
-the formula relocator will delete the ses-range from the formula.
+the formula relocator will delete the @samp{ses-range} from the
+formula.
If you insert a new row just beyond the end of a one-column range, or
a new column just beyond a one-row range, the new cell is included in
@@ -1007,7 +1034,7 @@ are some useful functions to call from your formulas:
@item (ses-delete-blanks &rest @var{args})
Returns a list from which all blank cells (value is either @code{nil}
or '*skip*) have been deleted. Order of args is reverted. Please note
-that @code{ses-range} has a @code{!} modifier that allows to remove
+that @code{ses-range} has a @code{!} modifier that enables removing
blanks, so it is possible to write:
@lisp
(ses-range A1 A5 !)
@@ -1018,7 +1045,7 @@ instead of
@end lisp
@item (ses+ &rest @var{args})
-Sum of non-blank arguments.
+Sum of non-blank arguments taken in reverse order.
@item (ses-average @var{list})
Average of non-blank elements in @var{list}. Here the list is passed
@@ -1033,13 +1060,15 @@ as a single argument, since you'll probably use it with @code{ses-range}.
Special cell values:
@itemize
-@item nil prints the same as "", but allows previous cell to spill over.
+@item nil prints typically the same as "", but allows previous cell to spill over.
@item '*skip* replaces nil when the previous cell actually does spill over;
nothing is printed for it.
@item '*error* indicates that the formula signaled an error instead of
producing a value: the print cell is filled with hash marks (#).
@end itemize
+@c TODO propagate extra explanation from the French version.
+
If the result from the printer function is too wide for the cell and
the following cell is @code{nil}, the result will spill over into the
following cell. Very wide results can spill over several cells. If
@@ -1066,12 +1095,14 @@ this to undo the effect of @kbd{t}.
When a printer function signals an error, the fallback printer
@findex ses-prin1
-@code{ses-prin1} is substituted. This is useful when your column printer
-is numeric-only and you use a string as a cell value. Note that the
-standard default printer is @samp{"%.7g"} which is numeric-only, so cells
-that are empty of contain strings will use the fallback printer.
-@kbd{c} on such cells will display ``Format specifier doesn't match
-argument type''.
+@code{ses-prin1} is substituted. This is useful when your printer is
+numeric-only and you use a string as a cell value. Note that the
+standard default printer is @samp{"%.7g"} which is numeric-only, so
+cells for which the standard default printer applies, and that are not
+empty and do not contain a number will use the fallback printer
+@code{ses-prin1}, for instance cells that contain strings will do
+that. @kbd{c} on such cells will display ``Format specifier doesn't
+match argument type''.
@node Import and export
@@ -1103,11 +1134,11 @@ the spreadsheet, it receives a ``needs safety check'' marking. Later,
when the formula or printer is evaluated for the first time, it is
checked for safety using the @code{unsafep} predicate; if found to be
``possibly unsafe'', the questionable formula or printer is displayed
-and you must press Y to approve it or N to use a substitute. The
-substitute always signals an error.
+and you must press @kbd{Y} to approve it or @kbd{N} to use a
+substitute. The substitute always signals an error.
Formulas or printers that you type in are checked immediately for
-safety. If found to be possibly unsafe and you press N to disapprove,
+safety. If found to be possibly unsafe and you press @kbd{N} to disapprove,
the action is canceled and the old formula or printer will remain.
Besides viruses (which try to copy themselves to other files),
@@ -1143,13 +1174,15 @@ Example of use:
@lisp
(ses-average (ses-select (ses-range A1 A5) 'Smith (ses-range B1 B5)))
@end lisp
-This computes the average of the B column values for those rows whose
-A column value is the symbol 'Smith.
+This computes the average of the @samp{B} column values for those rows
+whose @samp{A} column value is the symbol @samp{'Smith}.
Arguably one could specify only @var{fromrange} plus
@var{to-row-offset} and @var{to-column-offset}. The @var{torange} is
stated explicitly to ensure that the formula will be recalculated if
any cell in either range is changed.
+@c TODO reword this paragraph more clearly as in the French version
+
File @file{etc/ses-example.el} in the Emacs distribution is an example of a
details-and-summary spreadsheet.
@@ -1166,7 +1199,7 @@ details-and-summary spreadsheet.
* Nonrelocatable references::
* The data area::
* Buffer-local variables in spreadsheets::
-* Uses of defadvice in @acronym{SES}::
+* Uses of advice-add in @acronym{SES}::
@end menu
@node Deferred updates
@@ -1179,12 +1212,13 @@ To save time by avoiding redundant computations, cells that need
recalculation due to changes in other cells are added to a set. At
the end of the command, each cell in the set is recalculated once.
This can create a new set of cells that need recalculation. The
-process is repeated until either the set is empty or it stops changing
-(due to circular references among the cells). In extreme cases, you
-might see progress messages of the form ``Recalculating... (@var{nnn}
-cells left)''. If you interrupt the calculation using @kbd{C-g}, the
-spreadsheet will be left in an inconsistent state, so use @kbd{C-_} or
-@kbd{C-c C-l} to fix it.
+process is repeated until either the set is empty or a circular
+references are detected. In extreme cases, and notably if a circular
+cell reference is under detection, you might see progress messages of
+the form ``Recalculating... (@var{nnn} cells left)''. If you
+interrupt the calculation using @kbd{C-g}, the spreadsheet will be
+left in an inconsistent state, so use @kbd{C-_} or @kbd{C-c C-l} to
+fix it.
To save even more time by avoiding redundant writes, cells that have
changes are added to a set instead of being written immediately to the
@@ -1194,11 +1228,12 @@ progress message of the form ``Writing... (@var{nnn} cells left)''.
These deferred cell-writes cannot be interrupted by @kbd{C-g}, so
you'll just have to wait.
-@acronym{SES} uses @code{run-with-idle-timer} to move the cell underline when
-Emacs will be scrolling the buffer after the end of a command, and
-also to narrow and underline after @kbd{C-x C-v}. This is visible as
-a momentary glitch after C-x C-v and certain scrolling commands. You
-can type ahead without worrying about the glitch.
+@acronym{SES} uses @code{run-with-idle-timer} to move the cell
+underline when Emacs will be scrolling the buffer after the end of a
+command, and also to narrow and underline after visiting a file. This
+may be visible as a momentary glitch after visiting and certain
+scrolling commands. You can type ahead without worrying about the
+glitch.
@node Nonrelocatable references
@@ -1210,8 +1245,8 @@ can type ahead without worrying about the glitch.
@kbd{C-u C-y} relocates none of the cell-references. What about mixed
cases?
-The best way is to rename cells that you do not want to be relocatable
-by using @code{ses-rename-cell}.
+The best way is to rename cells that you do @emph{not} want to be
+relocatable by using @code{ses-rename-cell}.
@findex ses-rename-cell
Cells that do not have an A1-like name style are not relocated on
yank. Using this method, the concerned cells won't be relocated
@@ -1219,7 +1254,7 @@ whatever formula they appear in. Please note however that when a
formula contains some range @code{(ses-range @var{cell1} @var{cell2})}
then in the yanked formula each range bound @var{cell1} and
@var{cell2} are relocated, or not, independently, depending on whether
-they are A1-like or renamed.
+they are @samp{A1}-like or renamed.
An alternative method is to use
@lisp
@@ -1227,9 +1262,9 @@ An alternative method is to use
@end lisp
to make an @dfn{absolute reference}. The formula relocator skips over
quoted things, so this will not be relocated when pasted or when
-rows/columns are inserted/deleted. However, B3 will not be recorded
-as a dependency of this cell, so this cell will not be updated
-automatically when B3 is changed, this is why using
+rows/columns are inserted/deleted. However, @samp{B3} will not be
+recorded as a dependency of this cell, so this cell will not be
+updated automatically when @samp{B3} is changed, this is why using
@code{ses-rename-cell} is most of the time preferable.
The variables @code{row} and @code{col} are dynamically bound while a
@@ -1246,12 +1281,13 @@ kind of dependency is also not recorded.
@cindex data area
@findex ses-reconstruct-all
-Begins with an 014 character, followed by sets of cell-definition
-macros for each row, followed by the set of local printer
-definitions, followed by column-widths, column-printers,
-default-printer, and header-row. Then there's the global parameters
-(file-format ID, row count, column count, local printer count) and the
-local variables (specifying @acronym{SES} mode for the buffer, etc.).
+Begins with an form feed character (whose ASCII code is 014 in octal
+notation), followed by sets of cell-definition macros for each row,
+followed by the set of local printer definitions, followed by
+column-widths, column-printers, default-printer, and header-row. Then
+there's the global parameters (file-format ID, row count, column
+count, local printer count) and the local variables (specifying
+@acronym{SES} mode for the buffer, etc.).
When a @acronym{SES} file is loaded, first the global parameters are
loaded, then the entire data area is @code{eval}ed, and finally the local
@@ -1263,10 +1299,10 @@ counting newlines. Use @kbd{C-x C-e} at the end of a line to install
your edits into the spreadsheet data structures (this does not update
the print area, use, e.g., @kbd{C-c C-l} for that).
-The data area is maintained as an image of spreadsheet data
-structures that area stored in buffer-local variables. If the data
-area gets messed up, you can try reconstructing the data area from the
-data structures:
+The data area is maintained as an image of spreadsheet data structures
+as stored in buffer-local variables from initially loading the area.
+If the data area gets messed up in the sequel, you can try
+reconstructing the data area from the data structures:
@table @kbd
@item C-c M-C-l
@@ -1283,7 +1319,7 @@ You can add additional local variables to the list at the bottom of
the data area, such as hidden constants you want to refer to in your
formulas.
-You can override the variable @code{ses--symbolic-formulas} to be a list of
+You can initialize the variable @code{ses--symbolic-formulas} to be a list of
symbols (as parenthesized strings) to show as completions for the @kbd{'}
command. This initial completions list is used instead of the actual
set of symbols-as-formulas in the spreadsheet.
@@ -1308,30 +1344,23 @@ avoid virus warnings, each function used in a formula needs
(put 'your-function-name 'safe-function t)
@end lisp
-@node Uses of defadvice in @acronym{SES}
-@section Uses of defadvice in @acronym{SES}
-@findex defadvice
-@findex undo-more
+@node Uses of advice-add in @acronym{SES}
+@section Uses of advice-add in @acronym{SES}
+@findex advice-add
@findex copy-region-as-kill
@findex yank
@table @code
-@item undo-more
-Defines a new undo element format (@var{fun} . @var{args}), which
-means ``undo by applying @var{fun} to @var{args}''. For spreadsheet
-buffers, it allows undos in the data area even though that's outside
-the narrowing.
-
@item copy-region-as-kill
When copying from the print area of a spreadsheet, treat the region as
-a rectangle and attach each cell's formula and printer as 'ses
+a rectangle and attach each cell's formula and printer as @code{'ses}
properties.
@item yank
When yanking into the print area of a spreadsheet, first try to yank
-as cells (if the yank text has 'ses properties), then as tab-separated
-formulas, then (if all else fails) as a single formula for the current
-cell.
+as cells (if the yank text has @code{'ses} properties), then as
+tab-separated formulas, then (if all else fails) as a single formula
+for the current cell.
@end table
@c ===================================================================
@@ -1352,7 +1381,9 @@ Jonathan Yavner,
@c monnier@@gnu.org
Stefan Monnier,
@c shigeru.fukaya@@gmail.com
-Shigeru Fukaya
+Shigeru Fukaya,
+@c vincent.belaiche@@sourceforge.net
+Vincent Belaïche
@end quotation
@noindent
@@ -1361,7 +1392,9 @@ Texinfo manual by:
@c jyavner@@member.fsf.org
Jonathan Yavner,
@c brad@@chenla.org
-Brad Collins
+Brad Collins,
+@c vincent.belaiche@@sourceforge.net
+Vincent Belaïche
@end quotation
@noindent
@@ -1402,7 +1435,9 @@ Luc Teirlinck,
@c jotto@@pobox.com
J. Otto Tennant,
@c jphil@@acs.pagesjaunes.fr
-Jean-Philippe Theberge
+Jean-Philippe Theberge,
+@c rrandresf@@hotmail.com
+Andrés Ramírez
@end quotation
@c ===================================================================
diff --git a/doc/misc/texinfo.tex b/doc/misc/texinfo.tex
index 19d675be857..93d592193a0 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-11-12.22}
+\def\texinfoversion{2024-02-10.22}
%
-% Copyright 1985--1986, 1988, 1990--2024 Free Software Foundation, Inc.
+% Copyright 1985, 1986, 1988, 1990-2024 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
@@ -58,12 +58,6 @@
\message{Loading texinfo [version \texinfoversion]:}
-% If in a .fmt file, print the version number
-% and turn on active characters that we couldn't do earlier because
-% they might have appeared in the input file name.
-\everyjob{\message{[Texinfo version \texinfoversion]}%
- \catcode`+=\active \catcode`\_=\active}
-
% LaTeX's \typeout. This ensures that the messages it is used for
% are identical in format to the corresponding ones from latex/pdflatex.
\def\typeout{\immediate\write17}%
@@ -281,8 +275,7 @@
% \topmark doesn't work for the very first chapter (after the title
% page or the contents), so we use \firstmark there -- this gets us
% the mark with the chapter defs, unless the user sneaks in, e.g.,
-% @setcolor (or @url, or @link, etc.) between @contents and the very
-% first @chapter.
+% @setcolor (or @url etc.) between @contents and the very first @chapter.
\def\gettopheadingmarks{%
\ifcase0\the\savedtopmark\fi
\ifx\thischapter\empty \ifcase0\firstmark\fi \fi
@@ -433,42 +426,21 @@
}
% First remove any @comment, then any @c comment. Pass the result on to
-% \argcheckspaces.
+% \argremovespace.
\def\argremovecomment#1\comment#2\ArgTerm{\argremovec #1\c\ArgTerm}
-\def\argremovec#1\c#2\ArgTerm{\argcheckspaces#1\^^M\ArgTerm}
-
-% Each occurrence of `\^^M' or `<space>\^^M' is replaced by a single space.
-%
-% \argremovec might leave us with trailing space, e.g.,
+\def\argremovec#1\c#2\ArgTerm{\argremovespace#1$ $\ArgTerm}
+% \argremovec might leave us with trailing space, though; e.g.,
% @end itemize @c foo
-% This space token undergoes the same procedure and is eventually removed
-% by \finishparsearg.
-%
-\def\argcheckspaces#1\^^M{\argcheckspacesX#1\^^M \^^M}
-\def\argcheckspacesX#1 \^^M{\argcheckspacesY#1\^^M}
-\def\argcheckspacesY#1\^^M#2\^^M#3\ArgTerm{%
- \def\temp{#3}%
- \ifx\temp\empty
- % Do not use \next, perhaps the caller of \parsearg uses it; reuse \temp:
- \let\temp\finishparsearg
- \else
- \let\temp\argcheckspaces
- \fi
- % Put the space token in:
- \temp#1 #3\ArgTerm
-}
+% Note that the argument cannot contain the TeX $, as its catcode is
+% changed to \other when Texinfo source is read.
+\def\argremovespace#1 $#2\ArgTerm{\finishparsearg#1$\ArgTerm}
% If a _delimited_ argument is enclosed in braces, they get stripped; so
% to get _exactly_ the rest of the line, we had to prevent such situation.
-% We prepended an \empty token at the very beginning and we expand it now,
-% just before passing the control to \argtorun.
-% (Similarly, we have to think about #3 of \argcheckspacesY above: it is
-% either the null string, or it ends with \^^M---thus there is no danger
-% that a pair of braces would be stripped.
-%
-% But first, we have to remove the trailing space token.
-%
-\def\finishparsearg#1 \ArgTerm{\expandafter\argtorun\expandafter{#1}}
+% We prepended an \empty token at the very beginning and we expand it
+% just before passing the control to \next.
+% (But first, we have to remove the remaining $ or two.)
+\def\finishparsearg#1$#2\ArgTerm{\expandafter\argtorun\expandafter{#1}}
% \parseargdef - define a command taking an argument on the line
@@ -530,7 +502,7 @@
% ... but they get defined via ``\envdef\foo{...}'':
\long\def\envdef#1#2{\def#1{\startenvironment#1#2}}
-\def\envparseargdef#1#2{\parseargdef#1{\startenvironment#1#2}}
+\long\def\envparseargdef#1#2{\parseargdef#1{\startenvironment#1#2}}
% Check whether we're in the right environment:
\def\checkenv#1{%
@@ -591,6 +563,9 @@
% @/ allows a line break.
\let\/=\allowbreak
+% @- allows explicit insertion of hyphenation points
+\def\-{\discretionary{\normaldash}{}{}}%
+
% @. is an end-of-sentence period.
\def\.{.\spacefactor=\endofsentencespacefactor\space}
@@ -1105,27 +1080,33 @@ where each line of input produces a line of output.}
% Output page labels information.
% See PDF reference v.1.7 p.594, section 8.3.1.
+% Page label ranges must be increasing.
\ifpdf
\def\pagelabels{%
\def\title{0 << /P (T-) /S /D >>}%
- \edef\roman{\the\romancount << /S /r >>}%
- \edef\arabic{\the\arabiccount << /S /D >>}%
%
- % Page label ranges must be increasing. Remove any duplicates.
- % (There is a slight chance of this being wrong if e.g. there is
- % a @contents but no @titlepage, etc.)
- %
- \ifnum\romancount=0 \def\roman{}\fi
- \ifnum\arabiccount=0 \def\title{}%
- \else
- \ifnum\romancount=\arabiccount \def\roman{}\fi
- \fi
- %
- \ifnum\romancount<\arabiccount
- \pdfcatalog{/PageLabels << /Nums [\title \roman \arabic ] >> }\relax
+ % support @contents at very end of document
+ \ifnum\contentsendcount=\pagecount
+ \ifnum\arabiccount<\romancount
+ \pdfcatalog{/PageLabels << /Nums
+ [\title
+ \the\arabiccount << /S /D >>
+ \the\romancount << /S /r >>
+ ] >> }\relax
+ \fi
+ % no contents in document
+ \else\ifnum\contentsendcount=0
+ \pdfcatalog{/PageLabels << /Nums
+ [\title
+ \the\arabiccount << /S /D >>
+ ] >> }\relax
\else
- \pdfcatalog{/PageLabels << /Nums [\title \arabic \roman ] >> }\relax
- \fi
+ \pdfcatalog{/PageLabels << /Nums
+ [\title
+ \the\romancount << /S /r >>
+ \the\contentsendcount << /S /D >>
+ ] >> }\relax
+ \fi\fi
}
\else
\let\pagelabels\relax
@@ -1134,6 +1115,8 @@ where each line of input produces a line of output.}
\newcount\pagecount \pagecount=0
\newcount\romancount \romancount=0
\newcount\arabiccount \arabiccount=0
+\newcount\contentsendcount \contentsendcount=0
+
\ifpdf
\let\ptxadvancepageno\advancepageno
\def\advancepageno{%
@@ -1197,13 +1180,17 @@ output) for that.)}
%
% Set color, and create a mark which defines \thiscolor accordingly,
% so that \makeheadline knows which color to restore.
+ \def\curcolor{0 0 0}%
\def\setcolor#1{%
- \xdef\currentcolordefs{\gdef\noexpand\thiscolor{#1}}%
- \domark
- \pdfsetcolor{#1}%
+ \ifx#1\curcolor\else
+ \xdef\currentcolordefs{\gdef\noexpand\thiscolor{#1}}%
+ \domark
+ \pdfsetcolor{#1}%
+ \xdef\curcolor{#1}%
+ \fi
}
%
- \def\maincolor{\rgbBlack}
+ \let\maincolor\rgbBlack
\pdfsetcolor{\maincolor}
\edef\thiscolor{\maincolor}
\def\currentcolordefs{}
@@ -1359,7 +1346,7 @@ output) for that.)}
%
% by default, use black for everything.
\def\urlcolor{\rgbBlack}
- \def\linkcolor{\rgbBlack}
+ \let\linkcolor\rgbBlack
\def\endlink{\setcolor{\maincolor}\pdfendlink}
%
% Adding outlines to PDF; macros for calculating structure of outlines
@@ -1537,9 +1524,10 @@ output) for that.)}
\next}
\def\makelink{\addtokens{\toksB}%
{\noexpand\pdflink{\the\toksC}}\toksC={}\global\countA=0}
- \def\pdflink#1{%
+ \def\pdflink#1{\pdflinkpage{#1}{#1}}%
+ \def\pdflinkpage#1#2{%
\startlink attr{/Border [0 0 0]} goto name{\pdfmkpgn{#1}}
- \setcolor{\linkcolor}#1\endlink}
+ \setcolor{\linkcolor}#2\endlink}
\def\done{\edef\st{\global\noexpand\toksA={\the\toksB}}\st}
\else
% non-pdf mode
@@ -1786,10 +1774,11 @@ output) for that.)}
\next}
\def\makelink{\addtokens{\toksB}%
{\noexpand\pdflink{\the\toksC}}\toksC={}\global\countA=0}
- \def\pdflink#1{%
+ \def\pdflink#1{\pdflinkpage{#1}{#1}}%
+ \def\pdflinkpage#1#2{%
\special{pdf:bann << /Border [0 0 0]
/Type /Annot /Subtype /Link /A << /S /GoTo /D (#1) >> >>}%
- \setcolor{\linkcolor}#1\endlink}
+ \setcolor{\linkcolor}#2\endlink}
\def\done{\edef\st{\global\noexpand\toksA={\the\toksB}}\st}
%
%
@@ -2134,6 +2123,11 @@ end
\pdffontattr#1{/ToUnicode \the\pdflastobj\space 0 R}%
}%
\fi\fi
+%
+% This is what gets called when #5 of \setfont is empty.
+\let\cmap\gobble
+%
+% (end of cmaps)
% Set the font macro #1 to the font named \fontprefix#2.
@@ -2149,11 +2143,10 @@ end
\def\setfont#1#2#3#4#5{%
\font#1=\fontprefix#2#3 scaled #4
\csname cmap#5\endcsname#1%
+ \ifx#2\ttshape\hyphenchar#1=-1 \fi
+ \ifx#2\ttbshape\hyphenchar#1=-1 \fi
+ \ifx#2\ttslshape\hyphenchar#1=-1 \fi
}
-% This is what gets called when #5 of \setfont is empty.
-\let\cmap\gobble
-%
-% (end of cmaps)
% Use cm as the default font prefix.
% To specify the font prefix, you must define \fontprefix
@@ -2674,26 +2667,23 @@ end
\gdef\setcodequotes{\let`\codequoteleft \let'\codequoteright}
\gdef\setregularquotes{\let`\lq \let'\rq}
}
+\setregularquotes
-% Allow an option to not use regular directed right quote/apostrophe
-% (char 0x27), but instead the undirected quote from cmtt (char 0x0d).
-% The undirected quote is ugly, so don't make it the default, but it
-% works for pasting with more pdf viewers (at least evince), the
-% lilypond developers report. xpdf does work with the regular 0x27.
+% output for ' in @code
+% in tt font hex 0D (undirected) or 27 (curly right quote)
%
\def\codequoteright{%
\ifusingtt
{\ifflagclear{txicodequoteundirected}%
{\ifflagclear{codequoteundirected}%
{'}%
- {\char'15 }}%
- {\char'15 }}%
+ {\char"0D }}%
+ {\char"0D }}%
{'}%
}
-% and a similar option for the left quote char vs. a grave accent.
-% Modern fonts display ASCII 0x60 as a grave accent, so some people like
-% the code environments to do likewise.
+% output for ` in @code
+% in tt font hex 12 (grave accent) or 60 (curly left quote)
% \relax disables Spanish ligatures ?` and !` of \tt font.
%
\def\codequoteleft{%
@@ -2701,8 +2691,8 @@ end
{\ifflagclear{txicodequotebacktick}%
{\ifflagclear{codequotebacktick}%
{\relax`}%
- {\char'22 }}%
- {\char'22 }}%
+ {\char"12 }}%
+ {\char"12 }}%
{\relax`}%
}
@@ -2721,7 +2711,7 @@ end
\errmessage{Unknown @codequoteundirected value `\temp', must be on|off}%
\fi\fi
}
-%
+
\parseargdef\codequotebacktick{%
\def\temp{#1}%
\ifx\temp\onword
@@ -2736,6 +2726,11 @@ end
\fi\fi
}
+% Turn them on by default
+\let\SETtxicodequoteundirected = t
+\let\SETtxicodequotebacktick = t
+
+
% [Knuth] pp. 380,381,391, disable Spanish ligatures ?` and !` of \tt font.
\def\noligaturesquoteleft{\relax\lq}
@@ -2815,13 +2810,6 @@ end
% @sansserif, explicit sans.
\def\sansserif#1{{\sf #1}}
-% We can't just use \exhyphenpenalty, because that only has effect at
-% the end of a paragraph. Restore normal hyphenation at the end of the
-% group within which \nohyphenation is presumably called.
-%
-\def\nohyphenation{\hyphenchar\font = -1 \aftergroup\restorehyphenation}
-\def\restorehyphenation{\hyphenchar\font = `- }
-
\newif\iffrenchspacing
\frenchspacingfalse
@@ -2890,27 +2878,29 @@ end
% Switch to typewriter.
\tt
%
- % But `\ ' produces the large typewriter interword space.
+ % `\ ' produces the large typewriter interword space.
\def\ {{\spaceskip = 0pt{} }}%
%
- % Turn off hyphenation.
- \nohyphenation
- %
\plainfrenchspacing
#1%
}%
\null % reset spacefactor to 1000
}
-% We *must* turn on hyphenation at `-' and `_' in @code.
-% (But see \codedashfinish below.)
+% This is for LuaTeX: It is not sufficient to disable hyphenation at
+% explicit dashes by setting `\hyphenchar` to -1.
+\def\dashnobreak{%
+ \normaldash
+ \penalty 10000 }
+
+% We must turn on hyphenation at `-' and `_' in @code.
% Otherwise, it is too hard to avoid overfull hboxes
% in the Emacs manual, the Library manual, etc.
+% We explicitly allow hyphenation at these characters
+% using \discretionary.
%
-% Unfortunately, TeX uses one parameter (\hyphenchar) to control
-% both hyphenation at - and hyphenation within words.
-% We must therefore turn them both off (\tclose does that)
-% and arrange explicitly to hyphenate at a dash. -- rms.
+% Hyphenation at - and hyphenation within words was turned off
+% by default for the tt fonts using the \hyphenchar parameter of TeX.
{
\catcode`\-=\active \catcode`\_=\active
\catcode`\'=\active \catcode`\`=\active
@@ -2923,13 +2913,9 @@ end
\let-\codedash
\let_\codeunder
\else
- \let-\normaldash
+ \let-\dashnobreak
\let_\realunder
\fi
- % Given -foo (with a single dash), we do not want to allow a break
- % after the hyphen.
- \global\let\codedashprev=\codedash
- %
\codex
}
%
@@ -2939,21 +2925,30 @@ end
%
% Now, output a discretionary to allow a line break, unless
% (a) the next character is a -, or
- % (b) the preceding character is a -.
+ % (b) the preceding character is a -, or
+ % (c) we are at the start of the string.
+ % In both cases (b) and (c), \codedashnobreak should be set to \codedash.
+ %
% E.g., given --posix, we do not want to allow a break after either -.
% Given --foo-bar, we do want to allow a break between the - and the b.
\ifx\next\codedash \else
- \ifx\codedashprev\codedash
+ \ifx\codedashnobreak\codedash
\else \discretionary{}{}{}\fi
\fi
% we need the space after the = for the case when \next itself is a
% space token; it would get swallowed otherwise. As in @code{- a}.
- \global\let\codedashprev= \next
+ \global\let\codedashnobreak= \next
}
}
\def\normaldash{-}
%
-\def\codex #1{\tclose{#1}\endgroup}
+\def\codex #1{\tclose{%
+ % Given -foo (with a single dash), we do not want to allow a break
+ % after the -. \codedashnobreak is set to the first character in
+ % @code.
+ \futurelet\codedashnobreak\relax
+ #1%
+}\endgroup}
\def\codeunder{%
% this is all so @math{@code{var_name}+1} can work. In math mode, _
@@ -3200,7 +3195,7 @@ end
% definition of @key with no lozenge.
%
-\def\key#1{{\setregularquotes \nohyphenation \tt #1}\null}
+\def\key#1{{\setregularquotes \tt #1}\null}
% @clicksequence{File @click{} Open ...}
\def\clicksequence#1{\begingroup #1\endgroup}
@@ -3740,13 +3735,14 @@ $$%
want the contents after the title page.}}%
\parseargdef\shorttitlepage{%
- \begingroup \hbox{}\vskip 1.5in \chaprm \centerline{#1}%
- \endgroup\page\hbox{}\page}
+ {\headingsoff \begingroup \hbox{}\vskip 1.5in \chaprm \centerline{#1}%
+ \endgroup\page\hbox{}\page}\pageone}
\envdef\titlepage{%
% Open one extra group, as we want to close it in the middle of \Etitlepage.
\begingroup
\parindent=0pt \textfonts
+ \headingsoff
% Leave some space at the very top of the page.
\vglue\titlepagetopglue
% No rule at page bottom unless we print one at the top with @title.
@@ -3774,11 +3770,9 @@ $$%
% If we use the new definition of \page, we always get a blank page
% after the title page, which we certainly don't want.
\oldpage
+ \pageone
\endgroup
%
- % Need this before the \...aftertitlepage checks so that if they are
- % in effect the toc pages will come out with page numbers.
- \HEADINGSon
}
\def\finishtitlepage{%
@@ -3947,35 +3941,24 @@ $$%
}
\def\HEADINGSoff{{\globaldefs=1 \headingsoff}} % global setting
-\HEADINGSoff % it's the default
-% When we turn headings on, set the page number to 1.
+% Set the page number to 1.
\def\pageone{
\global\pageno=1
\global\arabiccount = \pagecount
}
+\let\contentsalignmacro = \chappager
+
+% \def\HEADINGSon{\HEADINGSdouble} % defined by \CHAPPAGon
+
% For double-sided printing, put current file name in lower left corner,
% chapter name on inside top of right hand pages, document
% title on inside top of left hand pages, and page numbers on outside top
% edge of all pages.
-\def\HEADINGSdouble{%
-\pageone
-\HEADINGSdoublex
-}
-\let\contentsalignmacro = \chappager
-
-% For single-sided printing, chapter title goes across top left of page,
-% page number on top right.
-\def\HEADINGSsingle{%
-\pageone
-\HEADINGSsinglex
-}
-\def\HEADINGSon{\HEADINGSdouble}
-
-\def\HEADINGSafter{\let\HEADINGShook=\HEADINGSdoublex}
+\def\HEADINGSafter{\let\HEADINGShook=\HEADINGSdouble}
\let\HEADINGSdoubleafter=\HEADINGSafter
-\def\HEADINGSdoublex{%
+\def\HEADINGSdouble{%
\global\evenfootline={\hfil}
\global\oddfootline={\hfil}
\global\evenheadline={\line{\folio\hfil\thistitle}}
@@ -3985,8 +3968,10 @@ $$%
\global\let\contentsalignmacro = \chapoddpage
}
-\def\HEADINGSsingleafter{\let\HEADINGShook=\HEADINGSsinglex}
-\def\HEADINGSsinglex{%
+% For single-sided printing, chapter title goes across top left of page,
+% page number on top right.
+\def\HEADINGSsingleafter{\let\HEADINGShook=\HEADINGSsingle}
+\def\HEADINGSsingle{%
\global\evenfootline={\hfil}
\global\oddfootline={\hfil}
\global\evenheadline={\line{\thischapter\hfil\folio}}
@@ -3998,7 +3983,6 @@ $$%
% for @setchapternewpage off
\def\HEADINGSsinglechapoff{%
-\pageone
\global\evenfootline={\hfil}
\global\oddfootline={\hfil}
\global\evenheadline={\line{\thischapter\hfil\folio}}
@@ -4724,13 +4708,11 @@ $$%
% except not \outer, so it can be used within macros and \if's.
\edef\newwrite{\makecsname{ptexnewwrite}}
-% \newindex {foo} defines an index named IX.
+% \newindex {IX} defines an index named IX.
% It automatically defines \IXindex such that
% \IXindex ...rest of line... puts an entry in the index IX.
% It also defines \IXindfile to be the number of the output channel for
% the file that accumulates this index. The file's extension is IX.
-% The name of an index should be no more than 2 characters long
-% for the sake of vms.
%
\def\newindex#1{%
\expandafter\chardef\csname#1indfile\endcsname=0
@@ -4793,21 +4775,6 @@ $$%
\def\docodeindexxxx #1{\docind{\indexname}{#1}}
-% Used for the aux, toc and index files to prevent expansion of Texinfo
-% commands.
-%
-\def\atdummies{%
- \definedummyletter\@%
- \definedummyletter\ %
- \definedummyletter\{%
- \definedummyletter\}%
- \definedummyletter\&%
- %
- % Do the redefinitions.
- \definedummies
- \otherbackslash
-}
-
% \definedummyword defines \#1 as \string\#1\space, thus effectively
% preventing its expansion. This is used only for control words,
% not control letters, because the \space would be incorrect for
@@ -4823,110 +4790,91 @@ $$%
%
\def\definedummyword #1{\def#1{\string#1\space}}%
\def\definedummyletter#1{\def#1{\string#1}}%
-\let\definedummyaccent\definedummyletter
-% Called from \atdummies to prevent the expansion of commands.
+% Used for the aux, toc and index files to prevent expansion of Texinfo
+% commands. Most of the commands are controlled through the
+% \ifdummies conditional.
%
-\def\definedummies{%
+\def\atdummies{%
+ \dummiestrue
%
- \let\commondummyword\definedummyword
- \let\commondummyletter\definedummyletter
- \let\commondummyaccent\definedummyaccent
- \commondummiesnofonts
+ \definedummyletter\@%
+ \definedummyletter\ %
+ \definedummyletter\{%
+ \definedummyletter\}%
+ \definedummyletter\&%
%
\definedummyletter\_%
\definedummyletter\-%
%
- % Non-English letters.
- \definedummyword\AA
- \definedummyword\AE
- \definedummyword\DH
- \definedummyword\L
- \definedummyword\O
- \definedummyword\OE
- \definedummyword\TH
- \definedummyword\aa
- \definedummyword\ae
- \definedummyword\dh
- \definedummyword\exclamdown
- \definedummyword\l
- \definedummyword\o
- \definedummyword\oe
- \definedummyword\ordf
- \definedummyword\ordm
- \definedummyword\questiondown
- \definedummyword\ss
- \definedummyword\th
- %
- % Although these internal commands shouldn't show up, sometimes they do.
- \definedummyword\bf
- \definedummyword\gtr
- \definedummyword\hat
- \definedummyword\less
- \definedummyword\sf
- \definedummyword\sl
- \definedummyword\tclose
- \definedummyword\tt
- %
- \definedummyword\LaTeX
- \definedummyword\TeX
- %
- % Assorted special characters.
- \definedummyword\ampchar
- \definedummyword\atchar
- \definedummyword\arrow
- \definedummyword\backslashchar
- \definedummyword\bullet
- \definedummyword\comma
- \definedummyword\copyright
- \definedummyword\registeredsymbol
- \definedummyword\dots
- \definedummyword\enddots
- \definedummyword\entrybreak
- \definedummyword\equiv
- \definedummyword\error
- \definedummyword\euro
- \definedummyword\expansion
- \definedummyword\geq
- \definedummyword\guillemetleft
- \definedummyword\guillemetright
- \definedummyword\guilsinglleft
- \definedummyword\guilsinglright
- \definedummyword\lbracechar
- \definedummyword\leq
- \definedummyword\mathopsup
- \definedummyword\minus
- \definedummyword\ogonek
- \definedummyword\pounds
- \definedummyword\point
- \definedummyword\print
- \definedummyword\quotedblbase
- \definedummyword\quotedblleft
- \definedummyword\quotedblright
- \definedummyword\quoteleft
- \definedummyword\quoteright
- \definedummyword\quotesinglbase
- \definedummyword\rbracechar
- \definedummyword\result
- \definedummyword\sub
- \definedummyword\sup
- \definedummyword\textdegree
- %
\definedummyword\subentry
%
% We want to disable all macros so that they are not expanded by \write.
+ \let\commondummyword\definedummyword
\macrolist
\let\value\dummyvalue
%
- \normalturnoffactive
-}
-
-% \commondummiesnofonts: common to \definedummies and \indexnofonts.
-% Define \commondummyletter, \commondummyaccent and \commondummyword before
-% using. Used for accents, font commands, and various control letters.
-%
-\def\commondummiesnofonts{%
- % Control letters and accents.
+ \turnoffactive
+}
+
+\newif\ifdummies
+\newif\ifindexnofonts
+
+\def\commondummyletter#1{%
+ \expandafter\let\csname\string#1:impl\endcsname#1%
+ \edef#1{%
+ \noexpand\ifindexnofonts
+ % empty expansion
+ \noexpand\else
+ \noexpand\ifdummies\string#1%
+ \noexpand\else
+ \noexpand\jumptwofi % dispose of the \fi
+ \expandafter\noexpand\csname\string#1:impl\endcsname
+ \noexpand\fi
+ \noexpand\fi}%
+}
+
+\def\commondummyaccent#1{%
+ \expandafter\let\csname\string#1:impl\endcsname#1%
+ \edef#1{%
+ \noexpand\ifindexnofonts
+ \noexpand\expandafter % dispose of \else ... \fi
+ \noexpand\asis
+ \noexpand\else
+ \noexpand\ifdummies\string#1%
+ \noexpand\else
+ \noexpand\jumptwofi % dispose of the \fi
+ \expandafter\noexpand\csname\string#1:impl\endcsname
+ \noexpand\fi
+ \noexpand\fi}%
+}
+
+% Like \commondummyaccent but add a \space at the end of the dummy expansion
+% #2 is the expansion used for \indexnofonts. #2 is always followed by
+% \asis to remove a pair of following braces.
+\def\commondummyword#1#2{%
+ \expandafter\let\csname\string#1:impl\endcsname#1%
+ \expandafter\def\csname\string#1:ixnf\endcsname{#2\asis}%
+ \edef#1{%
+ \noexpand\ifindexnofonts
+ \noexpand\expandafter % dispose of \else ... \fi
+ \expandafter\noexpand\csname\string#1:ixnf\endcsname
+ \noexpand\else
+ \noexpand\ifdummies\string#1\space
+ \noexpand\else
+ \noexpand\jumptwofi % dispose of the \fi \fi
+ \expandafter\noexpand\csname\string#1:impl\endcsname
+ \noexpand\fi
+ \noexpand\fi}%
+}
+\def\jumptwofi#1\fi\fi{\fi\fi#1}
+
+% For \atdummies and \indexnofonts. \atdummies sets
+% \dummiestrue and \indexnofonts sets \indexnofontstrue.
+\def\definedummies{
+ % @-sign is always an escape character when reading auxiliary files
+ \escapechar = `\@
+ %
\commondummyletter\!%
\commondummyaccent\"%
\commondummyaccent\'%
@@ -4940,58 +4888,124 @@ $$%
\commondummyaccent\^%
\commondummyaccent\`%
\commondummyaccent\~%
- \commondummyword\u
- \commondummyword\v
- \commondummyword\H
- \commondummyword\dotaccent
- \commondummyword\ogonek
- \commondummyword\ringaccent
- \commondummyword\tieaccent
- \commondummyword\ubaraccent
- \commondummyword\udotaccent
- \commondummyword\dotless
+ %
+ % Control letters and accents.
+ \commondummyword\u {}%
+ \commondummyword\v {}%
+ \commondummyword\H {}%
+ \commondummyword\dotaccent {}%
+ \commondummyword\ogonek {}%
+ \commondummyword\ringaccent {}%
+ \commondummyword\tieaccent {}%
+ \commondummyword\ubaraccent {}%
+ \commondummyword\udotaccent {}%
+ \commondummyword\dotless {}%
%
% Texinfo font commands.
- \commondummyword\b
- \commondummyword\i
- \commondummyword\r
- \commondummyword\sansserif
- \commondummyword\sc
- \commondummyword\slanted
- \commondummyword\t
+ \commondummyword\b {}%
+ \commondummyword\i {}%
+ \commondummyword\r {}%
+ \commondummyword\sansserif {}%
+ \commondummyword\sc {}%
+ \commondummyword\slanted {}%
+ \commondummyword\t {}%
%
% Commands that take arguments.
- \commondummyword\abbr
- \commondummyword\acronym
- \commondummyword\anchor
- \commondummyword\cite
- \commondummyword\code
- \commondummyword\command
- \commondummyword\dfn
- \commondummyword\dmn
- \commondummyword\email
- \commondummyword\emph
- \commondummyword\env
- \commondummyword\file
- \commondummyword\image
- \commondummyword\indicateurl
- \commondummyword\inforef
- \commondummyword\kbd
- \commondummyword\key
- \commondummyword\math
- \commondummyword\option
- \commondummyword\pxref
- \commondummyword\ref
- \commondummyword\samp
- \commondummyword\strong
- \commondummyword\tie
- \commondummyword\U
- \commondummyword\uref
- \commondummyword\url
- \commondummyword\var
- \commondummyword\verb
- \commondummyword\w
- \commondummyword\xref
+ \commondummyword\abbr {}%
+ \commondummyword\acronym {}%
+ \commondummyword\anchor {}%
+ \commondummyword\cite {}%
+ \commondummyword\code {}%
+ \commondummyword\command {}%
+ \commondummyword\dfn {}%
+ \commondummyword\dmn {}%
+ \commondummyword\email {}%
+ \commondummyword\emph {}%
+ \commondummyword\env {}%
+ \commondummyword\file {}%
+ \commondummyword\image {}%
+ \commondummyword\indicateurl{}%
+ \commondummyword\inforef {}%
+ \commondummyword\kbd {}%
+ \commondummyword\key {}%
+ \commondummyword\link {}%
+ \commondummyword\math {}%
+ \commondummyword\option {}%
+ \commondummyword\pxref {}%
+ \commondummyword\ref {}%
+ \commondummyword\samp {}%
+ \commondummyword\strong {}%
+ \commondummyword\tie {}%
+ \commondummyword\U {}%
+ \commondummyword\uref {}%
+ \commondummyword\url {}%
+ \commondummyword\var {}%
+ \commondummyword\verb {}%
+ \commondummyword\w {}%
+ \commondummyword\xref {}%
+ %
+ \commondummyword\AA {AA}%
+ \commondummyword\AE {AE}%
+ \commondummyword\DH {DZZ}%
+ \commondummyword\L {L}%
+ \commondummyword\O {O}%
+ \commondummyword\OE {OE}%
+ \commondummyword\TH {TH}%
+ \commondummyword\aa {aa}%
+ \commondummyword\ae {ae}%
+ \commondummyword\dh {dzz}%
+ \commondummyword\exclamdown {!}%
+ \commondummyword\l {l}%
+ \commondummyword\o {o}%
+ \commondummyword\oe {oe}%
+ \commondummyword\ordf {a}%
+ \commondummyword\ordm {o}%
+ \commondummyword\questiondown {?}%
+ \commondummyword\ss {ss}%
+ \commondummyword\th {th}%
+ %
+ \commondummyword\LaTeX {LaTeX}%
+ \commondummyword\TeX {TeX}%
+ %
+ % Assorted special characters.
+ \commondummyword\ampchar {\normalamp}%
+ \commondummyword\atchar {\@}%
+ \commondummyword\arrow {->}%
+ \commondummyword\backslashchar {\realbackslash}%
+ \commondummyword\bullet {bullet}%
+ \commondummyword\comma {,}%
+ \commondummyword\copyright {copyright}%
+ \commondummyword\dots {...}%
+ \commondummyword\enddots {...}%
+ \commondummyword\entrybreak {}%
+ \commondummyword\equiv {===}%
+ \commondummyword\error {error}%
+ \commondummyword\euro {euro}%
+ \commondummyword\expansion {==>}%
+ \commondummyword\geq {>=}%
+ \commondummyword\guillemetleft {<<}%
+ \commondummyword\guillemetright {>>}%
+ \commondummyword\guilsinglleft {<}%
+ \commondummyword\guilsinglright {>}%
+ \commondummyword\lbracechar {\{}%
+ \commondummyword\leq {<=}%
+ \commondummyword\mathopsup {sup}%
+ \commondummyword\minus {-}%
+ \commondummyword\pounds {pounds}%
+ \commondummyword\point {.}%
+ \commondummyword\print {-|}%
+ \commondummyword\quotedblbase {"}%
+ \commondummyword\quotedblleft {"}%
+ \commondummyword\quotedblright {"}%
+ \commondummyword\quoteleft {`}%
+ \commondummyword\quoteright {'}%
+ \commondummyword\quotesinglbase {,}%
+ \commondummyword\rbracechar {\}}%
+ \commondummyword\registeredsymbol {R}%
+ \commondummyword\result {=>}%
+ \commondummyword\sub {}%
+ \commondummyword\sup {}%
+ \commondummyword\textdegree {o}%
}
\let\indexlbrace\relax
@@ -5042,18 +5056,7 @@ $$%
% would be for a given command (usually its argument).
%
\def\indexnofonts{%
- % Accent commands should become @asis.
- \def\commondummyaccent##1{\let##1\asis}%
- % We can just ignore other control letters.
- \def\commondummyletter##1{\let##1\empty}%
- % All control words become @asis by default; overrides below.
- \let\commondummyword\commondummyaccent
- \commondummiesnofonts
- %
- % Don't no-op \tt, since it isn't a user-level command
- % and is used in the definitions of the active chars like <, >, |, etc.
- % Likewise with the other plain tex font commands.
- %\let\tt=\asis
+ \indexnofontstrue
%
\def\ { }%
\def\@{@}%
@@ -5065,84 +5068,19 @@ $$%
\let\lbracechar\{%
\let\rbracechar\}%
%
- % Non-English letters.
- \def\AA{AA}%
- \def\AE{AE}%
- \def\DH{DZZ}%
- \def\L{L}%
- \def\OE{OE}%
- \def\O{O}%
- \def\TH{TH}%
- \def\aa{aa}%
- \def\ae{ae}%
- \def\dh{dzz}%
- \def\exclamdown{!}%
- \def\l{l}%
- \def\oe{oe}%
- \def\ordf{a}%
- \def\ordm{o}%
- \def\o{o}%
- \def\questiondown{?}%
- \def\ss{ss}%
- \def\th{th}%
- %
- \let\do\indexnofontsdef
- %
- \do\LaTeX{LaTeX}%
- \do\TeX{TeX}%
- %
- % Assorted special characters.
- \do\atchar{@}%
- \do\arrow{->}%
- \do\bullet{bullet}%
- \do\comma{,}%
- \do\copyright{copyright}%
- \do\dots{...}%
- \do\enddots{...}%
- \do\equiv{==}%
- \do\error{error}%
- \do\euro{euro}%
- \do\expansion{==>}%
- \do\geq{>=}%
- \do\guillemetleft{<<}%
- \do\guillemetright{>>}%
- \do\guilsinglleft{<}%
- \do\guilsinglright{>}%
- \do\leq{<=}%
- \do\lbracechar{\{}%
- \do\minus{-}%
- \do\point{.}%
- \do\pounds{pounds}%
- \do\print{-|}%
- \do\quotedblbase{"}%
- \do\quotedblleft{"}%
- \do\quotedblright{"}%
- \do\quoteleft{`}%
- \do\quoteright{'}%
- \do\quotesinglbase{,}%
- \do\rbracechar{\}}%
- \do\registeredsymbol{R}%
- \do\result{=>}%
- \do\textdegree{o}%
%
% We need to get rid of all macros, leaving only the arguments (if present).
% Of course this is not nearly correct, but it is the best we can do for now.
- % makeinfo does not expand macros in the argument to @deffn, which ends up
- % writing an index entry, and texindex isn't prepared for an index sort entry
- % that starts with \.
%
% Since macro invocations are followed by braces, we can just redefine them
% to take a single TeX argument. The case of a macro invocation that
% goes to end-of-line is not handled.
%
+ \def\commondummyword##1{\let##1\asis}%
\macrolist
\let\value\indexnofontsvalue
}
-% Give the control sequence a definition that removes the {} that follows
-% its use, e.g. @AA{} -> AA
-\def\indexnofontsdef#1#2{\def#1##1{#2}}%
-
@@ -5300,14 +5238,14 @@ $$%
% the current value of \escapechar.
\def\escapeisbackslash{\escapechar=`\\}
-% Use \ in index files by default. texi2dvi didn't support @ as the escape
-% character (as it checked for "\entry" in the files, and not "@entry"). When
-% the new version of texi2dvi has had a chance to become more prevalent, then
-% the escape character can change back to @ again. This should be an easy
-% change to make now because both @ and \ are only used as escape characters in
-% index files, never standing for themselves.
+% Uncomment to use \ in index files by default. Old texi2dvi (before 2019)
+% didn't support @ as the escape character (as it checked for "\entry" in
+% the files, and not "@entry").
+% In the future we can remove this flag and simplify the code for
+% index files and backslashes, once the support is no longer likely to be
+% useful.
%
-\set txiindexescapeisbackslash
+% \set txiindexescapeisbackslash
% Write the entry in \indextext to the index file.
%
@@ -5616,6 +5554,16 @@ might help (with 'rm \jobname.?? \jobname.??s')%
\newdimen\entryrightmargin
\entryrightmargin=0pt
+% amount to indent subsequent lines in an entry when it spans more than
+% one line.
+\newdimen\entrycontskip
+\entrycontskip=1em
+
+% for PDF output, whether to make the text of the entry a link to the page
+% number. set for @contents and @shortcontents where there is only one
+% page number.
+\newif\iflinkentrytext
+
% \entry typesets a paragraph consisting of the text (#1), dot leaders, and
% then page number (#2) flushed to the right margin. It is used for index
% and table of contents entries. The paragraph is indented by \leftskip.
@@ -5642,7 +5590,7 @@ might help (with 'rm \jobname.?? \jobname.??s')%
}
\def\entrybreak{\unskip\space\ignorespaces}%
\def\doentry{%
- % Save the text of the entry
+ % Save the text of the entry in \boxA
\global\setbox\boxA=\hbox\bgroup
\bgroup % Instead of the swallowed brace.
\noindent
@@ -5652,12 +5600,21 @@ might help (with 'rm \jobname.?? \jobname.??s')%
% with catcodes occurring.
}
{\catcode`\@=11
+% #1 is the page number
\gdef\finishentry#1{%
- \egroup % end box A
+ \egroup % end \boxA
\dimen@ = \wd\boxA % Length of text of entry
+ % add any leaders and page number to \boxA.
\global\setbox\boxA=\hbox\bgroup
- \unhbox\boxA
- % #1 is the page number.
+ \ifpdforxetex
+ \iflinkentrytext
+ \pdflinkpage{#1}{\unhbox\boxA}%
+ \else
+ \unhbox\boxA
+ \fi
+ \else
+ \unhbox\boxA
+ \fi
%
% Get the width of the page numbers, and only use
% leaders if they are present.
@@ -5676,6 +5633,8 @@ might help (with 'rm \jobname.?? \jobname.??s')%
\fi
\fi
\egroup % end \boxA
+ %
+ % now output
\ifdim\wd\boxB = 0pt
\noindent\unhbox\boxA\par
\nobreak
@@ -5693,41 +5652,17 @@ might help (with 'rm \jobname.?? \jobname.??s')%
\parfillskip=0pt plus -1fill
%
\advance\rightskip by \entryrightmargin
- % Determine how far we can stretch into the margin.
- % This allows, e.g., "Appendix H GNU Free Documentation License" to
- % fit on one line in @letterpaper format.
- \ifdim\entryrightmargin>2.1em
- \dimen@i=2.1em
- \else
- \dimen@i=0em
- \fi
- \advance \parfillskip by 0pt minus 1\dimen@i
%
\dimen@ii = \hsize
\advance\dimen@ii by -1\leftskip
\advance\dimen@ii by -1\entryrightmargin
- \advance\dimen@ii by 1\dimen@i
\ifdim\wd\boxA > \dimen@ii % If the entry doesn't fit in one line
\ifdim\dimen@ > 0.8\dimen@ii % due to long index text
- % Try to split the text roughly evenly. \dimen@ will be the length of
- % the first line.
- \dimen@ = 0.7\dimen@
- \dimen@ii = \hsize
- \ifnum\dimen@>\dimen@ii
- % If the entry is too long (for example, if it needs more than
- % two lines), use all the space in the first line.
- \dimen@ = \dimen@ii
- \fi
\advance\leftskip by 0pt plus 1fill % ragged right
- \advance \dimen@ by 1\rightskip
- \parshape = 2 0pt \dimen@ 0em \dimen@ii
- % Ideally we'd add a finite glue at the end of the first line only,
- % instead of using \parshape with explicit line lengths, but TeX
- % doesn't seem to provide a way to do such a thing.
%
% Indent all lines but the first one.
- \advance\leftskip by 1em
- \advance\parindent by -1em
+ \advance\leftskip by \entrycontskip
+ \advance\parindent by -\entrycontskip
\fi\fi
\indent % start paragraph
\unhbox\boxA
@@ -5750,12 +5685,11 @@ might help (with 'rm \jobname.?? \jobname.??s')%
\newskip\thinshrinkable
\skip\thinshrinkable=.15em minus .15em
-% Like plain.tex's \dotfill, except uses up at least 1 em.
+% Like plain.tex's \dotfill, except uses up at least 0.5 em.
% The filll stretch here overpowers both the fil and fill stretch to push
% the page number to the right.
\def\indexdotfill{\cleaders
- \hbox{$\mathsurround=0pt \mkern1.5mu.\mkern1.5mu$}\hskip 1em plus 1filll}
-
+ \hbox{$\mathsurround=0pt \mkern1.5mu.\mkern1.5mu$}\hskip 0.5em plus 1filll}
\def\primary #1{\line{#1\hfil}}
@@ -5808,7 +5742,7 @@ might help (with 'rm \jobname.?? \jobname.??s')%
% below is chosen so that the gutter has the same value (well, +-<1pt)
% as it did when we hard-coded it.
%
- % We put the result in a separate register, \doublecolumhsize, so we
+ % We put the result in a separate register, \doublecolumnhsize, so we
% can restore it in \pagesofar, after \hsize itself has (potentially)
% been clobbered.
%
@@ -6203,8 +6137,7 @@ might help (with 'rm \jobname.?? \jobname.??s')%
% normally unnmhead0 calls unnumberedzzz:
\outer\parseargdef\unnumbered{\unnmhead0{#1}}
\def\unnumberedzzz#1{%
- \global\secno=0 \global\subsecno=0 \global\subsubsecno=0
- \global\advance\unnumberedno by 1
+ \global\advance\unnumberedno by 1
%
% Since an unnumbered has no number, no prefix for figures.
\global\let\chaplevelprefix = \empty
@@ -6260,8 +6193,8 @@ might help (with 'rm \jobname.?? \jobname.??s')%
% normally calls unnumberedseczzz:
\outer\parseargdef\unnumberedsec{\unnmhead1{#1}}
\def\unnumberedseczzz#1{%
- \global\subsecno=0 \global\subsubsecno=0 \global\advance\secno by 1
- \sectionheading{#1}{sec}{Ynothing}{\the\unnumberedno.\the\secno}%
+ \global\advance\unnumberedno by 1
+ \sectionheading{#1}{sec}{Ynothing}{\the\unnumberedno}%
}
% Subsections.
@@ -6284,9 +6217,8 @@ might help (with 'rm \jobname.?? \jobname.??s')%
% normally calls unnumberedsubseczzz:
\outer\parseargdef\unnumberedsubsec{\unnmhead2{#1}}
\def\unnumberedsubseczzz#1{%
- \global\subsubsecno=0 \global\advance\subsecno by 1
- \sectionheading{#1}{subsec}{Ynothing}%
- {\the\unnumberedno.\the\secno.\the\subsecno}%
+ \global\advance\unnumberedno by 1
+ \sectionheading{#1}{subsec}{Ynothing}{\the\unnumberedno}%
}
% Subsubsections.
@@ -6310,9 +6242,8 @@ might help (with 'rm \jobname.?? \jobname.??s')%
% normally unnumberedsubsubseczzz:
\outer\parseargdef\unnumberedsubsubsec{\unnmhead3{#1}}
\def\unnumberedsubsubseczzz#1{%
- \global\advance\subsubsecno by 1
- \sectionheading{#1}{subsubsec}{Ynothing}%
- {\the\unnumberedno.\the\secno.\the\subsecno.\the\subsubsecno}%
+ \global\advance\unnumberedno by 1
+ \sectionheading{#1}{subsubsec}{Ynothing}{\the\unnumberedno}%
}
% These macros control what the section commands do, according
@@ -6375,7 +6306,7 @@ might help (with 'rm \jobname.?? \jobname.??s')%
\fi
}
-\parseargdef\setchapternewpage{\csname CHAPPAG#1\endcsname}
+\parseargdef\setchapternewpage{\csname CHAPPAG#1\endcsname\HEADINGSon}
\def\CHAPPAGoff{%
\global\let\contentsalignmacro = \chappager
@@ -6392,7 +6323,7 @@ might help (with 'rm \jobname.?? \jobname.??s')%
\global\let\pchapsepmacro=\chapoddpage
\global\def\HEADINGSon{\HEADINGSdouble}}
-\CHAPPAGon
+\setchapternewpage on
% \chapmacro - Chapter opening.
%
@@ -6746,6 +6677,82 @@ might help (with 'rm \jobname.?? \jobname.??s')%
\input \tocreadfilename
}
+% process toc file to find the maximum width of the section numbers for
+% each chapter
+\def\findsecnowidths{%
+ \begingroup
+ \setupdatafile
+ \activecatcodes
+ \secentryfonts
+ % Redefinitions
+ \def\numchapentry##1##2##3##4{%
+ \def\curchapname{secnowidth-##2}%
+ \curchapmax=0pt
+ }%
+ \let\appentry\numchapentry
+ %
+ \def\numsecentry##1##2##3##4{%
+ \def\cursecname{secnowidth-##2}%
+ \cursecmax=0pt
+ %
+ \setbox0=\hbox{##2}%
+ \ifdim\wd0>\curchapmax
+ \curchapmax=\wd0
+ \expandafter\xdef\csname\curchapname\endcsname{\the\wd0}%
+ \fi
+ }%
+ \let\appsecentry\numsecentry
+ %
+ \def\numsubsecentry##1##2##3##4{%
+ \def\curssecname{secnowidth-##2}%
+ \curssecmax=0pt
+ %
+ \setbox0=\hbox{##2}%
+ \ifdim\wd0>\cursecmax
+ \cursecmax=\wd0
+ \expandafter\xdef\csname\cursecname\endcsname{\the\wd0}%
+ \fi
+ }%
+ \let\appsubsecentry\numsubsecentry
+ %
+ \def\numsubsubsecentry##1##2##3##4{%
+ \setbox0=\hbox{##2}%
+ \ifdim\wd0>\curssecmax
+ \curssecmax=\wd0
+ \expandafter\xdef\csname\curssecname\endcsname{\the\wd0}%
+ \fi
+ }%
+ \let\appsubsubsecentry\numsubsubsecentry
+ %
+ % Discard any output by outputting to dummy vbox, in case the toc file
+ % contains macros that we have not redefined above.
+ \setbox\dummybox\vbox\bgroup
+ \input \tocreadfilename\relax
+ \egroup
+ \endgroup
+}
+\newdimen\curchapmax
+\newdimen\cursecmax
+\newdimen\curssecmax
+
+
+% set #1 to the maximum section width for #2
+\def\retrievesecnowidth#1#2{%
+ \expandafter\let\expandafter\savedsecnowidth \csname secnowidth-#2\endcsname
+ \ifx\savedsecnowidth\relax
+ #1=0pt
+ \else
+ #1=\savedsecnowidth
+ \fi
+}
+\newdimen\secnowidthchap
+\secnowidthchap=0pt
+\newdimen\secnowidthsec
+\secnowidthsec=0pt
+\newdimen\secnowidthssec
+\secnowidthssec=0pt
+
+
\newskip\contentsrightmargin \contentsrightmargin=1in
\newcount\savepageno
\newcount\lastnegativepageno \lastnegativepageno = -1
@@ -6772,6 +6779,7 @@ might help (with 'rm \jobname.?? \jobname.??s')%
\def\thistitle{}% no title in double-sided headings
% Record where the Roman numerals started.
\ifnum\romancount=0 \global\romancount=\pagecount \fi
+ \linkentrytexttrue
}
% \raggedbottom in plain.tex hardcodes \topskip so override it
@@ -6790,6 +6798,7 @@ might help (with 'rm \jobname.?? \jobname.??s')%
\startcontents{\putwordTOC}%
\openin 1 \tocreadfilename\space
\ifeof 1 \else
+ \findsecnowidths
\readtocfile
\fi
\vfill \eject
@@ -6817,6 +6826,7 @@ might help (with 'rm \jobname.?? \jobname.??s')%
\rm
\hyphenpenalty = 10000
\advance\baselineskip by 1pt % Open it up a little.
+ \extrasecnoskip=0.4pt
\def\numsecentry##1##2##3##4{}
\let\appsecentry = \numsecentry
\let\unnsecentry = \numsecentry
@@ -6841,12 +6851,8 @@ might help (with 'rm \jobname.?? \jobname.??s')%
% Get ready to use Arabic numerals again
\def\contentsendroman{%
\lastnegativepageno = \pageno
- \global\pageno = \savepageno
- %
- % If \romancount > \arabiccount, the contents are at the end of the
- % document. Otherwise, advance where the Arabic numerals start for
- % the page numbers.
- \ifnum\romancount>\arabiccount\else\global\arabiccount=\pagecount\fi
+ \global\pageno=1
+ \contentsendcount = \pagecount
}
% Typeset the label for a chapter or appendix for the short contents.
@@ -6856,8 +6862,6 @@ might help (with 'rm \jobname.?? \jobname.??s')%
% This space should be enough, since a single number is .5em, and the
% widest letter (M) is 1em, at least in the Computer Modern fonts.
% But use \hss just in case.
- % (This space doesn't include the extra space that gets added after
- % the label; that gets put in by \shortchapentry above.)
%
% We'd like to right-justify chapter numbers, but that looks strange
% with appendix letters. And right-justifying numbers and
@@ -6867,10 +6871,15 @@ might help (with 'rm \jobname.?? \jobname.??s')%
\hbox to 1em{#1\hss}%
}
-% These macros generate individual entries in the table of contents.
-% The first argument is the chapter or section name.
-% The last argument is the page number.
-% The arguments in between are the chapter number, section number, ...
+% These macros generate individual entries in the table of contents,
+% and are read in from the *.toc file.
+%
+% The arguments are like:
+% \def\numchapentry#1#2#3#4
+% #1 - the chapter or section name.
+% #2 - section number
+% #3 - level of section (e.g "chap", "sec")
+% #4 - page number
% Parts, in the main contents. Replace the part number, which doesn't
% exist, with an empty box. Let's hope all the numbers have the same width.
@@ -6883,7 +6892,7 @@ might help (with 'rm \jobname.?? \jobname.??s')%
\vskip 0pt plus 5\baselineskip
\penalty-300
\vskip 0pt plus -5\baselineskip
- \dochapentry{\numeralbox\labelspace#1}{}%
+ \dochapentry{#1}{\numeralbox}{}%
}
%
% Parts, in the short toc.
@@ -6894,12 +6903,14 @@ might help (with 'rm \jobname.?? \jobname.??s')%
}
% Chapters, in the main contents.
-\def\numchapentry#1#2#3#4{\dochapentry{#2\labelspace#1}{#4}}
+\def\numchapentry#1#2#3#4{%
+ \retrievesecnowidth\secnowidthchap{#2}%
+ \dochapentry{#1}{#2}{#4}%
+}
% Chapters, in the short toc.
-% See comments in \dochapentry re vbox and related settings.
\def\shortchapentry#1#2#3#4{%
- \tocentry{\shortchaplabel{#2}\labelspace #1}{\doshortpageno\bgroup#4\egroup}%
+ \tocentry{#1}{\shortchaplabel{#2}}{#4}%
}
% Appendices, in the main contents.
@@ -6910,70 +6921,111 @@ might help (with 'rm \jobname.?? \jobname.??s')%
\setbox0 = \hbox{\putwordAppendix{} M}%
\hbox to \wd0{\putwordAppendix{} #1\hss}}
%
-\def\appentry#1#2#3#4{\dochapentry{\appendixbox{#2}\hskip.7em#1}{#4}}
+\def\appentry#1#2#3#4{%
+ \retrievesecnowidth\secnowidthchap{#2}%
+ \dochapentry{\appendixbox{#2}\hskip.7em#1}{}{#4}%
+}
% Unnumbered chapters.
-\def\unnchapentry#1#2#3#4{\dochapentry{#1}{#4}}
-\def\shortunnchapentry#1#2#3#4{\tocentry{#1}{\doshortpageno\bgroup#4\egroup}}
+\def\unnchapentry#1#2#3#4{\dochapentry{#1}{}{#4}}
+\def\shortunnchapentry#1#2#3#4{\tocentry{#1}{}{#4}}
% Sections.
-\def\numsecentry#1#2#3#4{\dosecentry{#2\labelspace#1}{#4}}
+\def\numsecentry#1#2#3#4{\dosecentry{#1}{#2}{#4}}
+
+\def\numsecentry#1#2#3#4{%
+ \retrievesecnowidth\secnowidthsec{#2}%
+ \dosecentry{#1}{#2}{#4}%
+}
\let\appsecentry=\numsecentry
-\def\unnsecentry#1#2#3#4{\dosecentry{#1}{#4}}
+\def\unnsecentry#1#2#3#4{%
+ \retrievesecnowidth\secnowidthsec{#2}%
+ \dosecentry{#1}{}{#4}%
+}
% Subsections.
-\def\numsubsecentry#1#2#3#4{\dosubsecentry{#2\labelspace#1}{#4}}
+\def\numsubsecentry#1#2#3#4{%
+ \retrievesecnowidth\secnowidthssec{#2}%
+ \dosubsecentry{#1}{#2}{#4}%
+}
\let\appsubsecentry=\numsubsecentry
-\def\unnsubsecentry#1#2#3#4{\dosubsecentry{#1}{#4}}
+\def\unnsubsecentry#1#2#3#4{%
+ \retrievesecnowidth\secnowidthssec{#2}%
+ \dosubsecentry{#1}{}{#4}%
+}
% And subsubsections.
-\def\numsubsubsecentry#1#2#3#4{\dosubsubsecentry{#2\labelspace#1}{#4}}
+\def\numsubsubsecentry#1#2#3#4{\dosubsubsecentry{#1}{#2}{#4}}
\let\appsubsubsecentry=\numsubsubsecentry
-\def\unnsubsubsecentry#1#2#3#4{\dosubsubsecentry{#1}{#4}}
+\def\unnsubsubsecentry#1#2#3#4{\dosubsubsecentry{#1}{}{#4}}
% This parameter controls the indentation of the various levels.
% Same as \defaultparindent.
\newdimen\tocindent \tocindent = 15pt
-% Now for the actual typesetting. In all these, #1 is the text and #2 is the
-% page number.
+% Now for the actual typesetting. In all these, #1 is the text, #2 is
+% a section number if present, and #3 is the page number.
%
% If the toc has to be broken over pages, we want it to be at chapters
% if at all possible; hence the \penalty.
-\def\dochapentry#1#2{%
+\def\dochapentry#1#2#3{%
\penalty-300 \vskip1\baselineskip plus.33\baselineskip minus.25\baselineskip
\begingroup
% Move the page numbers slightly to the right
\advance\entryrightmargin by -0.05em
\chapentryfonts
- \tocentry{#1}{\dopageno\bgroup#2\egroup}%
+ \extrasecnoskip=0.4em % separate chapter number more
+ \tocentry{#1}{#2}{#3}%
\endgroup
\nobreak\vskip .25\baselineskip plus.1\baselineskip
}
-\def\dosecentry#1#2{\begingroup
+\def\dosecentry#1#2#3{\begingroup
+ \secnowidth=\secnowidthchap
\secentryfonts \leftskip=\tocindent
- \tocentry{#1}{\dopageno\bgroup#2\egroup}%
+ \tocentry{#1}{#2}{#3}%
\endgroup}
-\def\dosubsecentry#1#2{\begingroup
+\def\dosubsecentry#1#2#3{\begingroup
+ \secnowidth=\secnowidthsec
\subsecentryfonts \leftskip=2\tocindent
- \tocentry{#1}{\dopageno\bgroup#2\egroup}%
+ \tocentry{#1}{#2}{#3}%
\endgroup}
-\def\dosubsubsecentry#1#2{\begingroup
+\def\dosubsubsecentry#1#2#3{\begingroup
+ \secnowidth=\secnowidthssec
\subsubsecentryfonts \leftskip=3\tocindent
- \tocentry{#1}{\dopageno\bgroup#2\egroup}%
+ \tocentry{#1}{#2}{#3}%
\endgroup}
-% We use the same \entry macro as for the index entries.
-\let\tocentry = \entry
-
-% Space between chapter (or whatever) number and the title.
-\def\labelspace{\hskip1em \relax}
+% Used for the maximum width of a section number so we can align
+% section titles.
+\newdimen\secnowidth
+\secnowidth=0pt
+\newdimen\extrasecnoskip
+\extrasecnoskip=0pt
-\def\dopageno#1{{\rm #1}}
-\def\doshortpageno#1{{\rm #1}}
+% \tocentry{TITLE}{SEC NO}{PAGE}
+%
+\def\tocentry#1#2#3{%
+ \def\secno{#2}%
+ \ifx\empty\secno
+ \entry{#1}{#3}%
+ \else
+ \ifdim 0pt=\secnowidth
+ \setbox0=\hbox{#2\hskip\labelspace\hskip\extrasecnoskip}%
+ \else
+ \advance\secnowidth by \labelspace
+ \advance\secnowidth by \extrasecnoskip
+ \setbox0=\hbox to \secnowidth{%
+ #2\hskip\labelspace\hskip\extrasecnoskip\hfill}%
+ \fi
+ \entrycontskip=\wd0
+ \entry{\box0 #1}{#3}%
+ \fi
+}
+\newdimen\labelspace
+\labelspace=0.6em
\def\chapentryfonts{\secfonts \rm}
\def\secentryfonts{\textfonts}
@@ -7119,8 +7171,7 @@ might help (with 'rm \jobname.?? \jobname.??s')%
\newdimen\cartouter\newdimen\cartinner
\newskip\normbskip\newskip\normpskip\newskip\normlskip
-
-\envdef\cartouche{%
+\envparseargdef\cartouche{%
\cartouchefontdefs
\ifhmode\par\fi % can't be in the midst of a paragraph.
\startsavinginserts
@@ -7150,16 +7201,19 @@ might help (with 'rm \jobname.?? \jobname.??s')%
\baselineskip=0pt\parskip=0pt\lineskip=0pt
\carttop
\hbox\bgroup
- \hskip\lskip
- \vrule\kern3pt
- \vbox\bgroup
- \kern3pt
- \hsize=\cartinner
- \baselineskip=\normbskip
- \lineskip=\normlskip
- \parskip=\normpskip
- \vskip -\parskip
- \comment % For explanation, see the end of def\group.
+ \hskip\lskip
+ \vrule\kern3pt
+ \vbox\bgroup
+ \hsize=\cartinner
+ \baselineskip=\normbskip
+ \lineskip=\normlskip
+ \parskip=\normpskip
+ \def\arg{#1}%
+ \ifx\arg\empty\else
+ \centerV{\hfil \bf #1 \hfil}%
+ \fi
+ \kern3pt
+ \vskip -\parskip
}
\def\Ecartouche{%
\ifhmode\par\fi
@@ -7410,8 +7464,9 @@ might help (with 'rm \jobname.?? \jobname.??s')%
\endgroup
%
\def\setupverb{%
- \tt % easiest (and conventionally used) font for verbatim
+ \tt
\def\par{\leavevmode\endgraf}%
+ \parindent = 0pt
\setcodequotes
\tabeightspaces
% Respect line breaks,
@@ -7587,32 +7642,19 @@ might help (with 'rm \jobname.?? \jobname.??s')%
\exdentamount=\defbodyindent
}
-\def\dodefunx#1{%
- % First, check whether we are in the right environment:
- \checkenv#1%
- %
- % As above, allow line break if we have multiple x headers in a row.
- % It's not a great place, though.
- \ifnum\lastpenalty=10002 \penalty3000 \else \defunpenalty=10002 \fi
- %
- % And now, it's time to reuse the body of the original defun:
- \expandafter\gobbledefun#1%
-}
-\def\gobbledefun#1\startdefun{}
-
-% \printdefunline \deffnheader{text}
+% Called as \printdefunline \deffooheader{text}
%
\def\printdefunline#1#2{%
\begingroup
\plainfrenchspacing
- % call \deffnheader:
+ % call \deffooheader:
#1#2 \endheader
% common ending:
\interlinepenalty = 10000
\advance\rightskip by 0pt plus 1fil\relax
\endgraf
\nobreak\vskip -\parskip
- \penalty\defunpenalty % signal to \startdefun and \dodefunx
+ \penalty\defunpenalty % signal to \startdefun and \deffoox
% Some of the @defun-type tags do not enable magic parentheses,
% rendering the following check redundant. But we don't optimize.
\checkparencounts
@@ -7621,7 +7663,29 @@ might help (with 'rm \jobname.?? \jobname.??s')%
\def\Edefun{\endgraf\medbreak}
-% \makedefun{deffoo}{ (definition of \deffooheader) }
+% @defblock, @defline do not automatically create index entries
+\envdef\defblock{%
+ \startdefun
+}
+\let\Edefblock\Edefun
+
+\def\defline{%
+ \doingtypefnfalse
+ \parseargusing\activeparens{\printdefunline\deflineheader}%
+}
+\def\deflineheader#1 #2 #3\endheader{%
+ \printdefname{#1}{}{#2}\magicamp\defunargs{#3\unskip}%
+}
+
+\def\deftypeline{%
+ \doingtypefntrue
+ \parseargusing\activeparens{\printdefunline\deftypelineheader}%
+}
+\def\deftypelineheader#1 #2 #3 #4\endheader{%
+ \printdefname{#1}{#2}{#3}\magicamp\defunargs{#4\unskip}%
+}
+
+% \makedefun{deffoo} (\deffooheader parameters) { (\deffooheader expansion) }
%
% Define \deffoo, \deffoox \Edeffoo and \deffooheader.
\def\makedefun#1{%
@@ -7636,8 +7700,18 @@ might help (with 'rm \jobname.?? \jobname.??s')%
\doingtypefnfalse % distinguish typed functions from all else
\parseargusing\activeparens{\printdefunline#3}%
}%
- \def#2{\dodefunx#1}%
- \def#3%
+ \def#2{%
+ % First, check whether we are in the right environment:
+ \checkenv#1%
+ %
+ % As in \startdefun, allow line break if we have multiple x headers
+ % in a row. It's not a great place, though.
+ \ifnum\lastpenalty=10002 \penalty3000 \else \defunpenalty=10002 \fi
+ %
+ \doingtypefnfalse % distinguish typed functions from all else
+ \parseargusing\activeparens{\printdefunline#3}%
+ }%
+ \def#3% definition of \deffooheader follows
}
\newif\ifdoingtypefn % doing typed function?
@@ -7667,14 +7741,14 @@ might help (with 'rm \jobname.?? \jobname.??s')%
% @deffn category name args
\makedefun{deffn}#1 #2 #3\endheader{%
\doind{fn}{\code{#2}}%
- \defname{#1}{}{#2}\magicamp\defunargs{#3\unskip}%
+ \printdefname{#1}{}{#2}\magicamp\defunargs{#3\unskip}%
}
% @defop category class name args
\makedefun{defop}#1 {\defopheaderx{#1\ \putwordon}}
\def\defopheaderx#1#2 #3 #4\endheader{%
\doind{fn}{\code{#3}\space\putwordon\ \code{#2}}%
- \defname{#1\ \code{#2}}{}{#3}\magicamp\defunargs{#4\unskip}%
+ \printdefname{#1\ \code{#2}}{}{#3}\magicamp\defunargs{#4\unskip}%
}
% Typed functions:
@@ -7683,7 +7757,7 @@ might help (with 'rm \jobname.?? \jobname.??s')%
\makedefun{deftypefn}#1 #2 #3 #4\endheader{%
\doind{fn}{\code{#3}}%
\doingtypefntrue
- \defname{#1}{#2}{#3}\defunargs{#4\unskip}%
+ \printdefname{#1}{#2}{#3}\defunargs{#4\unskip}%
}
% @deftypeop category class type name args
@@ -7691,7 +7765,7 @@ might help (with 'rm \jobname.?? \jobname.??s')%
\def\deftypeopheaderx#1#2 #3 #4 #5\endheader{%
\doind{fn}{\code{#4}\space\putwordon\ \code{#1\ \code{#2}}}%
\doingtypefntrue
- \defname{#1\ \code{#2}}{#3}{#4}\defunargs{#5\unskip}%
+ \printdefname{#1\ \code{#2}}{#3}{#4}\defunargs{#5\unskip}%
}
% Typed variables:
@@ -7699,14 +7773,14 @@ might help (with 'rm \jobname.?? \jobname.??s')%
% @deftypevr category type var args
\makedefun{deftypevr}#1 #2 #3 #4\endheader{%
\doind{vr}{\code{#3}}%
- \defname{#1}{#2}{#3}\defunargs{#4\unskip}%
+ \printdefname{#1}{#2}{#3}\defunargs{#4\unskip}%
}
% @deftypecv category class type var args
\makedefun{deftypecv}#1 {\deftypecvheaderx{#1\ \putwordof}}
\def\deftypecvheaderx#1#2 #3 #4 #5\endheader{%
\doind{vr}{\code{#4}\space\putwordof\ \code{#2}}%
- \defname{#1\ \code{#2}}{#3}{#4}\defunargs{#5\unskip}%
+ \printdefname{#1\ \code{#2}}{#3}{#4}\defunargs{#5\unskip}%
}
% Untyped variables:
@@ -7723,7 +7797,7 @@ might help (with 'rm \jobname.?? \jobname.??s')%
% @deftp category name args
\makedefun{deftp}#1 #2 #3\endheader{%
\doind{tp}{\code{#2}}%
- \defname{#1}{}{#2}\defunargs{#3\unskip}%
+ \printdefname{#1}{}{#2}\defunargs{#3\unskip}%
}
% Remaining @defun-like shortcuts:
@@ -7739,14 +7813,14 @@ might help (with 'rm \jobname.?? \jobname.??s')%
\makedefun{defivar}{\defcvheaderx\putwordInstanceVariableof}
\makedefun{deftypeivar}{\deftypecvheaderx\putwordInstanceVariableof}
-% \defname, which formats the name of the @def (not the args).
+% \printdefname, which formats the name of the @def (not the args).
% #1 is the category, such as "Function".
% #2 is the return type, if any.
% #3 is the function name.
%
% We are followed by (but not passed) the arguments, if any.
%
-\def\defname#1#2#3{%
+\def\printdefname#1#2#3{%
\par
% Get the values of \leftskip and \rightskip as they were outside the @def...
\advance\leftskip by -\defbodyindent
@@ -7800,6 +7874,8 @@ might help (with 'rm \jobname.?? \jobname.??s')%
\tolerance=10000 \hbadness=10000
\exdentamount=\defbodyindent
{%
+ \def\^^M{}% for line continuation
+ %
% defun fonts. We use typewriter by default (used to be bold) because:
% . we're printing identifiers, they should be in tt in principle.
% . in languages with many accents, such as Czech or French, it's
@@ -7831,10 +7907,13 @@ might help (with 'rm \jobname.?? \jobname.??s')%
% Print arguments. Use slanted for @def*, typewriter for @deftype*.
\def\defunargs#1{%
- \df \ifdoingtypefn \tt \else \sl \fi
- \ifflagclear{txicodevaristt}{}%
- {\def\var##1{{\setregularquotes \ttsl ##1}}}%
- #1%
+ \bgroup
+ \def\^^M{}% for line continuation
+ \df \ifdoingtypefn \tt \else \sl \fi
+ \ifflagclear{txicodevaristt}{}%
+ {\def\var##1{{\setregularquotes \ttsl ##1}}}%
+ #1%
+ \egroup
}
% We want ()&[] to print specially on the defun line.
@@ -7869,7 +7948,7 @@ might help (with 'rm \jobname.?? \jobname.??s')%
% If we encounter &foo, then turn on ()-hacking afterwards
\newif\ifampseen
-\def\amprm#1 {\ampseentrue{\bf\&#1 }}
+\def\amprm#1 {\ampseentrue{\rm\&#1 }}
\def\parenfont{%
\ifampseen
@@ -8123,8 +8202,6 @@ might help (with 'rm \jobname.?? \jobname.??s')%
\let\commondummyword\unmacrodo
\xdef\macrolist{\macrolist}%
\endgroup
- \else
- \errmessage{Macro #1 not defined}%
\fi
}
@@ -8191,14 +8268,14 @@ might help (with 'rm \jobname.?? \jobname.??s')%
% Read recursive and nonrecursive macro bodies. (They're different since
% rec and nonrec macros end differently.)
%
-% We are in \macrobodyctxt, and the \xdef causes backslashshes in the macro
+% We are in \macrobodyctxt, and the \xdef causes backslashes in the macro
% body to be transformed.
-% Set \macrobody to the body of the macro, and call \defmacro.
+% Set \macrobody to the body of the macro, and call \macrodef.
%
{\catcode`\ =\other\long\gdef\parsemacbody#1@end macro{%
-\xdef\macrobody{\eatcr{#1}}\endgroup\defmacro}}%
+\xdef\macrobody{\eatcr{#1}}\endgroup\macrodef}}%
{\catcode`\ =\other\long\gdef\parsermacbody#1@end rmacro{%
-\xdef\macrobody{\eatcr{#1}}\endgroup\defmacro}}%
+\xdef\macrobody{\eatcr{#1}}\endgroup\macrodef}}%
% Make @ a letter, so that we can make private-to-Texinfo macro names.
\edef\texiatcatcode{\the\catcode`\@}
@@ -8417,16 +8494,17 @@ might help (with 'rm \jobname.?? \jobname.??s')%
% \xdef is used so that macro definitions will survive the file
% they're defined in: @include reads the file inside a group.
%
-\def\defmacro{%
+\def\macrodef{%
\let\hash=##% convert placeholders to macro parameter chars
\ifnum\paramno=1
- \def\xeatspaces##1{##1}%
- % This removes the pair of braces around the argument. We don't
- % use \eatspaces, because this can cause ends of lines to be lost
- % when the argument to \eatspaces is read, leading to line-based
- % commands like "@itemize" not being read correctly.
+ \long\def\xeatspaces##1{##1}%
+ % We don't use \xeatspaces for single-argument macros, because we
+ % want to keep ends of lines. This definition removes \xeatspaces
+ % when \macrobody is expanded below.
\else
- \let\xeatspaces\relax % suppress expansion
+ \def\xeatspaces{\string\xeatspaces}%
+ % This expands \xeatspaces as a sequence of character tokens, which
+ % stops \scantokens inserting an extra space after the control sequence.
\fi
\ifcase\paramno
% 0
@@ -8592,6 +8670,75 @@ might help (with 'rm \jobname.?? \jobname.??s')%
\fi \macnamexxx}
+% @linemacro
+
+\parseargdef\linemacro{%
+ \getargs{#1}% now \macname is the macname and \argl the arglist
+ \ifx\argl\empty
+ \paramno=0
+ \let\hash\relax
+ \def\paramlist{\hash 1\endlinemacro}%
+ \else
+ \expandafter\linegetparamlist\argl;%
+ \fi
+ \begingroup \macrobodyctxt \usembodybackslash
+ \parselinemacrobody
+}
+
+% Build up \paramlist which will be used as the parameter text for the macro.
+% At the end it will be like "#1 #2 #3\endlinemacro".
+\def\linegetparamlist#1;{%
+ \paramno=0\def\paramlist{}%
+ \let\hash\relax
+ \linegetparamlistxxx#1,;,%
+}
+\def\linegetparamlistxxx#1,{%
+ \if#1;\let\next=\linegetparamlistxxxx
+ \else \let\next=\linegetparamlistxxx
+ \advance\paramno by 1
+ \expandafter\edef\csname macarg.\eatspaces{#1}\endcsname
+ {\hash\the\paramno}%
+ \edef\paramlist{\paramlist\hash\the\paramno\space}%
+ \fi\next}
+\def\linegetparamlistxxxx{%
+ \expandafter\fixparamlist\paramlist\fixparamlist
+}
+% Replace final space token
+\def\fixparamlist#1 \fixparamlist{%
+ \def\paramlist{#1\endlinemacro}%
+}
+
+% Read the body of the macro, replacing backslash-surrounded variables
+%
+{\catcode`\ =\other\long\gdef\parselinemacrobody#1@end linemacro{%
+\xdef\macrobody{#1}%
+\endgroup
+\linemacrodef
+}}
+
+% Make the definition
+\def\linemacrodef{%
+ \let\hash=##%
+ \expandafter\xdef\csname\the\macname\endcsname{%
+ \bgroup
+ \noexpand\parsearg
+ \expandafter\noexpand\csname\the\macname @@\endcsname
+ }
+ \expandafter\xdef\csname\the\macname @@\endcsname##1{%
+ \egroup
+ \expandafter\noexpand
+ \csname\the\macname @@@\endcsname##1\noexpand\endlinemacro
+ }
+ \expandafter\expandafter
+ \expandafter\xdef
+ \expandafter\expandafter\csname\the\macname @@@\endcsname\paramlist{%
+ \newlinechar=13 % split \macrobody into lines
+ \noexpand\scantokens{\macrobody}%
+ }
+}
+
+
+
% @alias.
% We need some trickery to remove the optional spaces around the equal
% sign. Make them active and then expand them all to nothing.
@@ -8668,6 +8815,11 @@ might help (with 'rm \jobname.?? \jobname.??s')%
\fi
}
+% @nodedescription, @nodedescriptionblock - do nothing for TeX
+\parseargdef\nodedescription{}
+\def\nodedescriptionblock{\doignore{nodedescriptionblock}}
+
+
% @anchor{NAME} -- define xref target at arbitrary point.
%
\newcount\savesfregister
@@ -8749,109 +8901,11 @@ might help (with 'rm \jobname.?? \jobname.??s')%
\def\xrefX[#1,#2,#3,#4,#5,#6]{\begingroup
\unsepspaces
%
- % Get args without leading/trailing spaces.
- \def\printedrefname{\ignorespaces #3}%
- \setbox\printedrefnamebox = \hbox{\printedrefname\unskip}%
- %
+ \getprintedrefname{#1}{#3}{#5}%
\def\infofilename{\ignorespaces #4}%
\setbox\infofilenamebox = \hbox{\infofilename\unskip}%
%
- \def\printedmanual{\ignorespaces #5}%
- \setbox\printedmanualbox = \hbox{\printedmanual\unskip}%
- %
- % If the printed reference name (arg #3) was not explicitly given in
- % the @xref, figure out what we want to use.
- \ifdim \wd\printedrefnamebox = 0pt
- % No printed node name was explicitly given.
- \expandafter\ifx\csname SETxref-automatic-section-title\endcsname \relax
- % Not auto section-title: use node name inside the square brackets.
- \def\printedrefname{\ignorespaces #1}%
- \else
- % Auto section-title: use chapter/section title inside
- % the square brackets if we have it.
- \ifdim \wd\printedmanualbox > 0pt
- % It is in another manual, so we don't have it; use node name.
- \def\printedrefname{\ignorespaces #1}%
- \else
- \ifhavexrefs
- % We (should) know the real title if we have the xref values.
- \def\printedrefname{\refx{#1-title}}%
- \else
- % Otherwise just copy the Info node name.
- \def\printedrefname{\ignorespaces #1}%
- \fi%
- \fi
- \fi
- \fi
- %
- % Make link in pdf output.
- \ifpdf
- % For pdfTeX and LuaTeX
- {\indexnofonts
- \makevalueexpandable
- \turnoffactive
- % This expands tokens, so do it after making catcode changes, so _
- % etc. don't get their TeX definitions. This ignores all spaces in
- % #4, including (wrongly) those in the middle of the filename.
- \getfilename{#4}%
- %
- % This (wrongly) does not take account of leading or trailing
- % spaces in #1, which should be ignored.
- \setpdfdestname{#1}%
- %
- \ifx\pdfdestname\empty
- \def\pdfdestname{Top}% no empty targets
- \fi
- %
- \leavevmode
- \startlink attr{/Border [0 0 0]}%
- \ifnum\filenamelength>0
- goto file{\the\filename.pdf} name{\pdfdestname}%
- \else
- goto name{\pdfmkpgn{\pdfdestname}}%
- \fi
- }%
- \setcolor{\linkcolor}%
- \else
- \ifx\XeTeXrevision\thisisundefined
- \else
- % For XeTeX
- {\indexnofonts
- \makevalueexpandable
- \turnoffactive
- % This expands tokens, so do it after making catcode changes, so _
- % etc. don't get their TeX definitions. This ignores all spaces in
- % #4, including (wrongly) those in the middle of the filename.
- \getfilename{#4}%
- %
- % This (wrongly) does not take account of leading or trailing
- % spaces in #1, which should be ignored.
- \setpdfdestname{#1}%
- %
- \ifx\pdfdestname\empty
- \def\pdfdestname{Top}% no empty targets
- \fi
- %
- \leavevmode
- \ifnum\filenamelength>0
- % With default settings,
- % XeTeX (xdvipdfmx) replaces link destination names with integers.
- % In this case, the replaced destination names of
- % remote PDFs are no longer known. In order to avoid a replacement,
- % you can use xdvipdfmx's command line option `-C 0x0010'.
- % If you use XeTeX 0.99996+ (TeX Live 2016+),
- % this command line option is no longer necessary
- % because we can use the `dvipdfmx:config' special.
- \special{pdf:bann << /Border [0 0 0] /Type /Annot /Subtype /Link /A
- << /S /GoToR /F (\the\filename.pdf) /D (\pdfdestname) >> >>}%
- \else
- \special{pdf:bann << /Border [0 0 0] /Type /Annot /Subtype /Link /A
- << /S /GoTo /D (\pdfdestname) >> >>}%
- \fi
- }%
- \setcolor{\linkcolor}%
- \fi
- \fi
+ \startxreflink{#1}{#4}%
{%
% Have to otherify everything special to allow the \csname to
% include an _ in the xref name, etc.
@@ -8932,6 +8986,93 @@ might help (with 'rm \jobname.?? \jobname.??s')%
\endlink
\endgroup}
+% \getprintedrefname{NODE}{LABEL}{MANUAL}
+% - set \printedrefname and \printedmanual
+%
+\def\getprintedrefname#1#2#3{%
+ % Get args without leading/trailing spaces.
+ \def\printedrefname{\ignorespaces #2}%
+ \setbox\printedrefnamebox = \hbox{\printedrefname\unskip}%
+ %
+ \def\printedmanual{\ignorespaces #3}%
+ \setbox\printedmanualbox = \hbox{\printedmanual\unskip}%
+ %
+ % If the printed reference name (arg #2) was not explicitly given in
+ % the @xref, figure out what we want to use.
+ \ifdim \wd\printedrefnamebox = 0pt
+ % No printed node name was explicitly given.
+ \expandafter\ifx\csname SETxref-automatic-section-title\endcsname \relax
+ % Not auto section-title: use node name inside the square brackets.
+ \def\printedrefname{\ignorespaces #1}%
+ \else
+ % Auto section-title: use chapter/section title inside
+ % the square brackets if we have it.
+ \ifdim \wd\printedmanualbox > 0pt
+ % It is in another manual, so we don't have it; use node name.
+ \def\printedrefname{\ignorespaces #1}%
+ \else
+ \ifhavexrefs
+ % We (should) know the real title if we have the xref values.
+ \def\printedrefname{\refx{#1-title}}%
+ \else
+ % Otherwise just copy the Info node name.
+ \def\printedrefname{\ignorespaces #1}%
+ \fi%
+ \fi
+ \fi
+ \fi
+}
+
+% \startxreflink{NODE}{FILE} - start link in pdf output.
+\def\startxreflink#1#2{%
+ \ifpdforxetex
+ % For pdfTeX and LuaTeX
+ {\indexnofonts
+ \makevalueexpandable
+ \turnoffactive
+ % This expands tokens, so do it after making catcode changes, so _
+ % etc. don't get their TeX definitions. This ignores all spaces in
+ % #2, including (wrongly) those in the middle of the filename.
+ \getfilename{#2}%
+ %
+ % This (wrongly) does not take account of leading or trailing
+ % spaces in #1, which should be ignored.
+ \setpdfdestname{#1}%
+ %
+ \ifx\pdfdestname\empty
+ \def\pdfdestname{Top}% no empty targets
+ \fi
+ %
+ \leavevmode
+ \ifpdf
+ \startlink attr{/Border [0 0 0]}%
+ \ifnum\filenamelength>0
+ goto file{\the\filename.pdf} name{\pdfdestname}%
+ \else
+ goto name{\pdfmkpgn{\pdfdestname}}%
+ \fi
+ \else % XeTeX
+ \ifnum\filenamelength>0
+ % With default settings,
+ % XeTeX (xdvipdfmx) replaces link destination names with integers.
+ % In this case, the replaced destination names of
+ % remote PDFs are no longer known. In order to avoid a replacement,
+ % you can use xdvipdfmx's command line option `-C 0x0010'.
+ % If you use XeTeX 0.99996+ (TeX Live 2016+),
+ % this command line option is no longer necessary
+ % because we can use the `dvipdfmx:config' special.
+ \special{pdf:bann << /Border [0 0 0] /Type /Annot /Subtype /Link /A
+ << /S /GoToR /F (\the\filename.pdf) /D (\pdfdestname) >> >>}%
+ \else
+ \special{pdf:bann << /Border [0 0 0] /Type /Annot /Subtype /Link /A
+ << /S /GoTo /D (\pdfdestname) >> >>}%
+ \fi
+ \fi
+ }%
+ \setcolor{\linkcolor}%
+ \fi
+}
+
% can be overridden in translation files
\def\putpageref#1{%
\space\putwordpage\tie\refx{#1-pg}}
@@ -8969,6 +9110,21 @@ might help (with 'rm \jobname.?? \jobname.??s')%
%
\def\xrefprintnodename#1{[#1]}
+% @link{NODENAME, LABEL, MANUAL} - create a "plain" link, with no
+% page number. Not useful if printed on paper.
+%
+\def\link#1{\linkX[#1,,,]}
+\def\linkX[#1,#2,#3,#4]{%
+ \begingroup
+ \unsepspaces
+ \getprintedrefname{#1}{#2}{#3}%
+ \startxreflink{#1}{#3}%
+ \printedrefname
+ \endlink
+ \endgroup
+}
+
+
% Things referred to by \setref.
%
\def\Ynothing{}
@@ -9583,8 +9739,8 @@ might help (with 'rm \jobname.?? \jobname.??s')%
%
\def\caption{\docaption\thiscaption}
\def\shortcaption{\docaption\thisshortcaption}
-\def\docaption{\checkenv\float \bgroup\scanctxt\defcaption}
-\def\defcaption#1#2{\egroup \def#1{#2}}
+\def\docaption{\checkenv\float \bgroup\scanctxt\docaptionz}
+\def\docaptionz#1#2{\egroup \def#1{#2}}
% The parameter is the control sequence identifying the counter we are
% going to use. Create it if it doesn't exist and assign it to \floatno.
@@ -9873,12 +10029,10 @@ directory should work if nowhere else does.}
% For native Unicode handling (XeTeX and LuaTeX)
\nativeunicodechardefs
\else
- % For treating UTF-8 as byte sequences (TeX, eTeX and pdfTeX)
+ % For treating UTF-8 as byte sequences (TeX, eTeX and pdfTeX).
+ % Since we already invoke \utfeightchardefs at the top level,
+ % making non-ascii chars active is sufficient.
\setnonasciicharscatcode\active
- % since we already invoked \utfeightchardefs at the top level
- % (below), do not re-invoke it, otherwise our check for duplicated
- % definitions gets triggered. Making non-ascii chars active is
- % sufficient.
\fi
%
\else
@@ -9903,7 +10057,6 @@ directory should work if nowhere else does.}
\fi
}
-% emacs-page
% A message to be logged when using a character that isn't available
% the default font encoding (OT1).
%
@@ -9912,12 +10065,6 @@ directory should work if nowhere else does.}
% Take account of \c (plain) vs. \, (Texinfo) difference.
\def\cedilla#1{\ifx\c\ptexc\c{#1}\else\,{#1}\fi}
-% First, make active non-ASCII characters in order for them to be
-% correctly categorized when TeX reads the replacement text of
-% macros containing the character definitions.
-\setnonasciicharscatcode\active
-%
-
\def\gdefchar#1#2{%
\gdef#1{%
\ifpassthroughchars
@@ -9927,8 +10074,14 @@ directory should work if nowhere else does.}
\fi
}}
+\begingroup
+
+% Make non-ASCII characters active for defining the character definition
+% macros.
+\setnonasciicharscatcode\active
+
% Latin1 (ISO-8859-1) character definitions.
-\def\latonechardefs{%
+\gdef\latonechardefs{%
\gdefchar^^a0{\tie}
\gdefchar^^a1{\exclamdown}
\gdefchar^^a2{{\tcfont \char162}} % cent
@@ -10033,7 +10186,7 @@ directory should work if nowhere else does.}
}
% Latin9 (ISO-8859-15) encoding character definitions.
-\def\latninechardefs{%
+\gdef\latninechardefs{%
% Encoding is almost identical to Latin1.
\latonechardefs
%
@@ -10048,7 +10201,7 @@ directory should work if nowhere else does.}
}
% Latin2 (ISO-8859-2) character definitions.
-\def\lattwochardefs{%
+\gdef\lattwochardefs{%
\gdefchar^^a0{\tie}
\gdefchar^^a1{\ogonek{A}}
\gdefchar^^a2{\u{}}
@@ -10152,6 +10305,8 @@ directory should work if nowhere else does.}
\gdefchar^^ff{\dotaccent{}}
}
+\endgroup % active chars
+
% UTF-8 character definitions.
%
% This code to support UTF-8 is based on LaTeX's utf8.def, with some
@@ -10489,7 +10644,7 @@ directory should work if nowhere else does.}
\DeclareUnicodeCharacter{00AE}{\registeredsymbol{}}%
\DeclareUnicodeCharacter{00AF}{\={ }}%
%
- \DeclareUnicodeCharacter{00B0}{\textdegree}
+ \DeclareUnicodeCharacter{00B0}{\textdegree}%
\DeclareUnicodeCharacter{00B1}{\ensuremath\pm}%
\DeclareUnicodeCharacter{00B2}{$^2$}%
\DeclareUnicodeCharacter{00B3}{$^3$}%
@@ -11204,14 +11359,14 @@ directory should work if nowhere else does.}
\relax
}
-% Define all Unicode characters we know about. This makes UTF-8 the default
-% input encoding and allows @U to work.
+% Define all Unicode characters we know about
\iftxinativeunicodecapable
\nativeunicodechardefsatu
\else
\utfeightchardefs
\fi
+
\message{formatting,}
\newdimen\defaultparindent \defaultparindent = 15pt
@@ -11539,7 +11694,7 @@ directory should work if nowhere else does.}
\fi
}
-\microtypeON
+\microtypeOFF
\parseargdef\microtype{%
\def\txiarg{#1}%
@@ -11556,6 +11711,9 @@ directory should work if nowhere else does.}
\message{and turning on texinfo input format.}
+% Make UTF-8 the default encoding.
+\documentencodingzzz{UTF-8}
+
\def^^L{\par} % remove \outer, so ^L can appear in an @comment
\catcode`\^^K = 10 % treat vertical tab as whitespace
@@ -11618,23 +11776,32 @@ directory should work if nowhere else does.}
% Used sometimes to turn off (effectively) the active characters even after
% parsing them.
\def\turnoffactive{%
- \normalturnoffactive
+ \passthroughcharstrue
+ \let-=\normaldash
+ \let"=\normaldoublequote
+ \let$=\normaldollar %$ font-lock fix
+ \let+=\normalplus
+ \let<=\normalless
+ \let>=\normalgreater
+ \let^=\normalcaret
+ \let_=\normalunderscore
+ \let|=\normalverticalbar
+ \let~=\normaltilde
\otherbackslash
+ \setregularquotes
+ \unsepspaces
}
-\catcode`\@=0
+% If a .fmt file is being used, characters that might appear in a file
+% name cannot be active until we have parsed the command line.
+% So turn them off again, and have \loadconf turn them back on.
+\catcode`+=\other \catcode`\_=\other
+
% \backslashcurfont outputs one backslash character in current font,
% as in \char`\\.
\global\chardef\backslashcurfont=`\\
-% \realbackslash is an actual character `\' with catcode other.
-{\catcode`\\=\other @gdef@realbackslash{\}}
-
-% In Texinfo, backslash is an active character; it prints the backslash
-% in fixed width font.
-\catcode`\\=\active % @ for escape char from now on.
-
% Print a typewriter backslash. For math mode, we can't simply use
% \backslashcurfont: the story here is that in math mode, the \char
% of \backslashcurfont ends up printing the roman \ from the math symbol
@@ -11644,109 +11811,125 @@ directory should work if nowhere else does.}
% ignored family value; char position "5C). We can't use " for the
% usual hex value because it has already been made active.
-@def@ttbackslash{{@tt @ifmmode @mathchar29020 @else @backslashcurfont @fi}}
-@let@backslashchar = @ttbackslash % @backslashchar{} is for user documents.
-
-% \otherbackslash defines an active \ to be a literal `\' character with
-% catcode other.
-@gdef@otherbackslash{@let\=@realbackslash}
+\def\ttbackslash{{\tt \ifmmode \mathchar29020 \else \backslashcurfont \fi}}
+\let\backslashchar = \ttbackslash % \backslashchar{} is for user documents.
-% Same as @turnoffactive except outputs \ as {\tt\char`\\} instead of
-% the literal character `\'.
-%
-{@catcode`- = @active
- @gdef@normalturnoffactive{%
- @passthroughcharstrue
- @let-=@normaldash
- @let"=@normaldoublequote
- @let$=@normaldollar %$ font-lock fix
- @let+=@normalplus
- @let<=@normalless
- @let>=@normalgreater
- @let^=@normalcaret
- @let_=@normalunderscore
- @let|=@normalverticalbar
- @let~=@normaltilde
- @let\=@ttbackslash
- @setregularquotes
- @unsepspaces
- }
-}
-
-% If a .fmt file is being used, characters that might appear in a file
-% name cannot be active until we have parsed the command line.
-% So turn them off again, and have @fixbackslash turn them back on.
-@catcode`+=@other @catcode`@_=@other
-
-% \enablebackslashhack - allow file to begin `\input texinfo'
-%
-% If a .fmt file is being used, we don't want the `\input texinfo' to show up.
-% That is what \eatinput is for; after that, the `\' should revert to printing
-% a backslash.
-% If the file did not have a `\input texinfo', then it is turned off after
-% the first line; otherwise the first `\' in the file would cause an error.
-% This is used on the very last line of this file, texinfo.tex.
-% We also use @c to call @fixbackslash, in case ends of lines are hidden.
-{
-@catcode`@^=7
-@catcode`@^^M=13@gdef@enablebackslashhack{%
- @global@let\ = @eatinput%
- @catcode`@^^M=13%
- @def@c{@fixbackslash@c}%
- % Definition for the newline at the end of this file.
- @def ^^M{@let^^M@secondlinenl}%
- % Definition for a newline in the main Texinfo file.
- @gdef @secondlinenl{@fixbackslash}%
- % In case the first line has a whole-line command on it
- @let@originalparsearg@parsearg
- @def@parsearg{@fixbackslash@originalparsearg}
+% These are made active for url-breaking, so need
+% active definitions as the normal characters.
+\def\normaldot{.}
+\def\normalquest{?}
+\def\normalslash{/}
+
+% \newlinesloadsconf - call \loadconf as soon as possible in the
+% file, e.g. at the first newline.
+%
+{\catcode`\^=7
+\catcode`\^^M=13
+\gdef\newlineloadsconf{%
+ \catcode`\^^M=13 %
+ \newlineloadsconfzz%
+}
+\gdef\newlineloadsconfzz#1^^M{%
+ \def\c{\loadconf\c}%
+ % Definition for the first newline read in the file
+ \def ^^M{\loadconf}%
+ % In case the first line has a whole-line or environment command on it
+ \let\originalparsearg\parsearg%
+ \def\parsearg{\loadconf\originalparsearg}%
+ %
+ % \startenvironment is in the expansion of commands defined with \envdef
+ \let\originalstartenvironment\startenvironment%
+ \def\startenvironment{\loadconf\startenvironment}%
}}
-{@catcode`@^=7 @catcode`@^^M=13%
-@gdef@eatinput input texinfo#1^^M{@fixbackslash}}
% Emergency active definition of newline, in case an active newline token
% appears by mistake.
-{@catcode`@^=7 @catcode13=13%
-@gdef@enableemergencynewline{%
- @gdef^^M{%
- @par%
- %<warning: active newline>@par%
+{\catcode`\^=7 \catcode13=13%
+\gdef\enableemergencynewline{%
+ \gdef^^M{%
+ \par%
+ %<warning: active newline>\par%
}}}
-@gdef@fixbackslash{%
- @ifx\@eatinput @let\ = @ttbackslash @fi
- @catcode13=5 % regular end of line
- @enableemergencynewline
- @let@c=@comment
- @let@parsearg@originalparsearg
+% \loadconf gets called at the beginning of every Texinfo file.
+% If texinfo.cnf is present on the system, read it. Useful for site-wide
+% @afourpaper, etc. Not opening texinfo.cnf directly in texinfo.tex
+% makes it possible to make a format file for Texinfo.
+%
+\gdef\loadconf{%
+ \relax % Terminate the filename if running as "tex '&texinfo' FILE.texi".
+ %
+ % Turn off the definitions that trigger \loadconf
+ \everyjobreset
+ \catcode13=5 % regular end of line
+ \enableemergencynewline
+ \let\c=\comment
+ \let\parsearg\originalparsearg
+ \let\startenvironment\originalstartenvironment
+ %
% Also turn back on active characters that might appear in the input
% file name, in case not using a pre-dumped format.
- @catcode`+=@active
- @catcode`@_=@active
- %
- % If texinfo.cnf is present on the system, read it.
- % Useful for site-wide @afourpaper, etc. This macro, @fixbackslash, gets
- % called at the beginning of every Texinfo file. Not opening texinfo.cnf
- % directly in this file, texinfo.tex, makes it possible to make a format
- % file for Texinfo.
+ \catcode`+=\active
+ \catcode`\_=\active
%
- @openin 1 texinfo.cnf
- @ifeof 1 @else @input texinfo.cnf @fi
- @closein 1
+ \openin 1 texinfo.cnf
+ \ifeof 1 \else \input texinfo.cnf \fi
+ \closein 1
}
+% Redefine some control sequences to be controlled by the \ifdummies
+% and \ifindexnofonts switches. Do this at the end so that the control
+% sequences are all defined.
+\definedummies
+
+
+
+
+\catcode`\@=0
+
+% \realbackslash is an actual character `\' with catcode other.
+{\catcode`\\=\other @gdef@realbackslash{\}}
+
+% In Texinfo, backslash is an active character; it prints the backslash
+% in fixed width font.
+\catcode`\\=\active % @ for escape char from now on.
+
+@let\ = @ttbackslash
+
+% If in a .fmt file, print the version number.
+% \eatinput stops the `\input texinfo' from showing up.
+% After that, `\' should revert to printing a backslash.
+% Turn on active characters that we couldn't do earlier because
+% they might have appeared in the input file name.
+%
+@everyjob{@message{[Texinfo version @texinfoversion]}%
+ @global@let\ = @eatinput
+ @catcode`+=@active @catcode`@_=@active}
+
+{@catcode`@^=7 @catcode`@^^M=13%
+@gdef@eatinput input texinfo#1^^M{@loadconf}}
+
+@def@everyjobreset{@ifx\@eatinput @let\ = @ttbackslash @fi}
+
+% \otherbackslash defines an active \ to be a literal `\' character with
+% catcode other.
+@gdef@otherbackslash{@let\=@realbackslash}
+
+% Same as @turnoffactive except outputs \ as {\tt\char`\\} instead of
+% the literal character `\'.
+%
+{@catcode`- = @active
+ @gdef@normalturnoffactive{%
+ @turnoffactive
+ @let\=@ttbackslash
+ }
+}
% Say @foo, not \foo, in error messages.
@escapechar = `@@
-% These (along with & and #) are made active for url-breaking, so need
-% active definitions as the normal characters.
-@def@normaldot{.}
-@def@normalquest{?}
-@def@normalslash{/}
-
% These look ok in all fonts, so just make them not special.
% @hashchar{} gets its own user-level command, because of #line.
@catcode`@& = @other @def@normalamp{&}
@@ -11761,15 +11944,11 @@ directory should work if nowhere else does.}
@c Do this last of all since we use ` in the previous @catcode assignments.
@catcode`@'=@active
@catcode`@`=@active
-@setregularquotes
@c Local variables:
@c eval: (add-hook 'before-save-hook 'time-stamp nil t)
@c time-stamp-pattern: "texinfoversion{%Y-%02m-%02d.%02H}"
-@c page-delimiter: "^\\\\message\\|emacs-page"
+@c page-delimiter: "^\\\\message"
@c End:
-@c vim:sw=2:
-
-@enablebackslashhack
-
+@newlineloadsconf
diff --git a/doc/misc/todo-mode.texi b/doc/misc/todo-mode.texi
index 28cffefa090..9f259b0e65b 100644
--- a/doc/misc/todo-mode.texi
+++ b/doc/misc/todo-mode.texi
@@ -580,7 +580,14 @@ on every invocation of @code{todo-insert-item}.
the highest or lowest priority in the category, if you do not
explicitly assign it a priority on invoking @code{todo-insert-item}.
By default, such new items are given highest priority, i.e., inserted
-at the top of the list.
+at the top of the list. In addition, when setting an item's priority
+you can use the minibuffer history to quickly call up the lowest or
+highest priority number in the minibuffer by typing @kbd{M-p} or
+@kbd{M-n}, and you can scroll through all priority numbers for the
+current category with these keys. For example, with the default
+setting of @code{todo-default-priority}, you can insert a new item as
+second to last in the category by typing @kbd{M-p M-p} at the prompt
+for setting the priority.
@item
@code{todo-always-add-time-string} is for including or omitting the
@@ -983,7 +990,10 @@ category, i.e., gives it third highest priority; all lower priority
items are pushed down by one. You can also pass the desired priority
as a numeric prefix argument, e.g., @kbd{3 #} gives the item third
highest priority without prompting. (Prefix arguments have no effect
-with @kbd{r} or @kbd{l}.)
+with @kbd{r} or @kbd{l}.) And you can type @kbd{M-p} and @kbd{M-n} in
+the minibuffer to scroll through all priority numbers for the current
+category. If you mistakenly choose the item's current priority, you
+will be prompted to choose a different priority.
@end table
@node Moving and Deleting Items
diff --git a/doc/misc/tramp.texi b/doc/misc/tramp.texi
index 0bed7dbe215..131a23b7423 100644
--- a/doc/misc/tramp.texi
+++ b/doc/misc/tramp.texi
@@ -142,6 +142,7 @@ on the remote host.
* Ssh setup:: Ssh setup hints.
* FUSE setup:: @acronym{FUSE} setup hints.
* Android shell setup:: Android shell setup hints.
+* Kubernetes setup:: Kubernetes setup hints.
* Auto-save File Lock and Backup::
Auto-save, File Lock and Backup.
* Keeping files encrypted:: Protect remote files by encryption.
@@ -162,6 +163,7 @@ Using @value{tramp}
How file names, directories and localnames are mangled and managed
+* Temporary directory:: Where temporary files are kept.
* Localname deconstruction:: Breaking a localname into its components.
* External packages:: Integration with external Lisp packages.
@@ -291,11 +293,12 @@ file's contents.
For external transfers, @value{tramp} sends a command as follows:
@example
-$ scp user@@host:/path/to/remote/file /tmp/tramp.4711
+$ scp user@@host:/path/to/remote/file <TMP>/tramp.4711
@end example
-@value{tramp} reads the local temporary file @file{/tmp/tramp.4711}
-into a buffer, and then deletes the temporary file.
+@value{tramp} reads the local temporary file @file{<TMP>/tramp.4711}
+into a buffer, and then deletes the temporary
+file.@footnote{@ref{Temporary directory}}
@item
Edit, modify, change the buffer contents as normal, and then save the
@@ -374,7 +377,7 @@ From behind a proxy:
@example
@group
-$ git config --global http.proxy http://user:pwd@@proxy.server.com:8080
+$ git config --global http.proxy https://user:pwd@@proxy.server.com:8080
$ git clone https://git.savannah.gnu.org/r/tramp.git
@end group
@end example
@@ -485,24 +488,28 @@ an @command{ssh} server:
@file{@trampfn{plink,user@@host,/path/to/file}}.
-@anchor{Quick Start Guide su, sudo, doas and sg methods}
-@section Using @option{su}, @option{sudo}, @option{doas} and @option{sg}
+@anchor{Quick Start Guide su, sudo, doas, androidsu and sg methods}
+@section Using @option{su}, @option{sudo}, @option{doas}, @option{androidsu} and @option{sg}
@cindex method @option{su}
@cindex @option{su} method
@cindex method @option{sudo}
@cindex @option{sudo} method
@cindex method @option{doas}
@cindex @option{doas} method
+@cindex method @option{androidsu}
+@cindex @option{androidsu} method
@cindex method @option{sg}
@cindex @option{sg} method
Sometimes, it is necessary to work on your local host under different
permissions. For this, you can use the @option{su} or @option{sudo}
connection method. On OpenBSD systems, the @option{doas} connection
-method offers the same functionality. These methods use @samp{root}
-as default user name and the return value of @code{(system-name)} as
-default host name. Therefore, it is convenient to open a file as
-@file{@trampfn{sudo,,/path/to/file}}.
+method offers the same functionality. If your local system is
+Android, use the method @option{androidsu} instead of @option{su}.
+
+These methods use @samp{root} as default user name and the return
+value of @code{(system-name)} as default host name. Therefore, it is
+convenient to open a file as @file{@trampfn{sudo,,/path/to/file}}.
The method @option{sg} stands for ``switch group''; here the user name
is used as the group to change to. The default host name is the same.
@@ -704,6 +711,7 @@ on the remote host.
* Ssh setup:: Ssh setup hints.
* FUSE setup:: @acronym{FUSE} setup hints.
* Android shell setup:: Android shell setup hints.
+* Kubernetes setup:: Kubernetes setup hints.
* Auto-save File Lock and Backup::
Auto-save, File Lock and Backup.
* Keeping files encrypted:: Protect remote files by encryption.
@@ -815,6 +823,17 @@ editing as another user. The host can be either @samp{localhost} or
the host returned by the function @command{(system-name)}. See
@ref{Multi-hops} for an exception to this behavior.
+@item @option{androidsu}
+@cindex method @option{androidsu}
+@cindex @option{androidsu} method
+Because the default implementation of the @option{su} method and other
+shell-based methods conflict with non-standard @command{su}
+implementations popular among Android users and the restricted
+command-line utilities distributed with that system, a largely
+equivalent @option{androidsu} method is provided for that system with
+workarounds for its many idiosyncrasies, with the exception that
+multi-hops are unsupported.
+
@item @option{sudo}
@cindex method @option{sudo}
@cindex @option{sudo} method
@@ -925,9 +944,31 @@ if desired.
@cindex method @option{kubernetes}
@cindex @option{kubernetes} method
-Integration for containers in Kubernetes pods. The host name is a pod
-name returned by @samp{kubectl get pods}. The first container in a
-pod is used.
+Integration for containers in Kubernetes pods. The host name is
+@samp{@var{pod}}, or @samp{@var{container}.@var{pod}} if an
+explicit container name shall be used. Otherwise, the first container
+in a pod is used.
+
+This method does not support user names.
+
+@item @option{toolbox}
+@cindex method @option{toolbox}
+@cindex @option{toolbox} method
+
+Integration of Toolbox system containers. The host name may be either
+a container's name or ID, as returned by @samp{toolbox list -c}.
+Without a host name, the default Toolbox container for the host will
+be used.
+
+This method does not support user names.
+
+@item @option{flatpak}
+@cindex method @option{flatpak}
+@cindex @option{flatpak} method
+
+Integration of Flatpak sandboxes. The host name may be either an
+application ID, a sandbox instance ID, or a PID, as returned by
+@samp{flatpak ps}.
This method does not support user names.
@@ -1033,6 +1074,20 @@ session.
These methods support the @samp{-P} argument.
+@item @option{dockercp}
+@item @option{podmancp}
+@cindex method @option{dockercp}
+@cindex @option{dockercp} method
+@cindex method @option{podmancp}
+@cindex @option{podmancp} method
+
+These methods are similar to @option{docker} or @option{podman}, but
+they use the command @command{docker cp} or @command{podman cp} for
+transferring large files.
+
+These copy commands do not support file globs, and they ignore a user
+name.
+
@item @option{fcp}
@cindex method @option{fcp}
@cindex @option{fcp} method
@@ -1070,11 +1125,11 @@ decode programs.
@cindex method @option{sudoedit}
@cindex @option{sudoedit} method
-The @option{sudoedit} method allows to edit a file as a different user
-on the local host. You could regard this as @value{tramp}'s
+The @option{sudoedit} method facilitates editing a file as a different
+user on the local host. You could regard this as @value{tramp}'s
implementation of the @command{sudoedit}. Contrary to the
@option{sudo} method, all magic file name functions are implemented by
-single @command{sudo @dots{}} commands. The purpose is to make
+single @command{sudo @dots{}} commands. The purpose is to make
editing such a file as secure as possible; there must be no session
running in the Emacs background which could be attacked from inside
Emacs.
@@ -1359,7 +1414,7 @@ possible, @value{tramp} emulates those operations otherwise.
@cindex @option{rclone} method
@vindex tramp-rclone-program
-The program @command{rclone} allows to access different system
+The program @command{rclone} enables accessing different system
storages in the cloud, see @uref{https://rclone.org/} for a list of
supported systems. If the @command{rclone} program isn't found in
your @env{PATH} environment variable, you can tell @value{tramp} its
@@ -1378,14 +1433,6 @@ User names are part of the @command{rclone} configuration, and not
needed in the remote file name. If a user name is contained in the
remote file name, it is ignored.
-Internally, @value{tramp} mounts the remote system storage at location
-@file{/tmp/tramp.rclone.storage}, with @file{storage} being the name
-of the configured system storage.
-
-The mount point and optional flags to the different @option{rclone}
-operations could be passed as connection properties, @xref{Setup of
-rclone method}.
-
Access via @option{rclone} is slow. If you have an alternative method
for accessing the system storage, you should use it.
@ref{GVFS-based methods} for example, methods @option{gdrive} and
@@ -2018,7 +2065,7 @@ machine @var{host} port sudo login @var{user} password secret
@var{user} and @var{host} are the strings returned by
@code{(user-login-name)} and @code{(system-name)}. If one of these
-methods is connected via a multi hop (@pxref{Multi-hops}), the
+methods is connected via a multi-hop (@pxref{Multi-hops}), the
credentials of the previous hop are used.
@vindex auth-source-save-behavior
@@ -2199,6 +2246,7 @@ to a remote home directory, like @option{adb}, @option{rclone} and
The temporary directory on the remote host. If not specified, the
default value is @t{"/data/local/tmp"} for the @option{adb} method,
@t{"/C$/Temp"} for the @option{smb} method, and @t{"/tmp"} otherwise.
+@ref{Temporary directory}.
@item @t{"direct-async-process"}
@@ -2226,8 +2274,8 @@ this property has no effect.
The directory file name an @acronym{FUSE}-based file system is mounted
on. The default value of this property is
-@t{"/tmp/tramp.method.user@@host#port"} (not specified in
-@code{tramp-methods}).
+@t{"<TMP>/tramp.method.user@@host#port"} (not specified in
+@code{tramp-methods}). @ref{Temporary directory}.
@item @t{"mount-args"}@*
@t{"copyto-args"}@*
@@ -2349,7 +2397,7 @@ connection information}. If you want, for example, use
@end group
@end lisp
-This works only for connection methods which allow to override the
+This works only for connection methods which allow overriding the
remote login shell, like @option{sshx} or @option{plink}. See
@ref{Inline methods} and @ref{External methods} for connection methods
which support this.
@@ -2761,32 +2809,32 @@ allows you to set the @option{ControlPath} provided the variable
Note how @samp{%r}, @samp{%h} and @samp{%p} must be encoded as
@samp{%%r}, @samp{%%h} and @samp{%%p}.
-@vindex tramp-use-ssh-controlmaster-options
+@vindex tramp-use-connection-share
Using a predefined string in @code{tramp-ssh-controlmaster-options},
or puzzling an own string, happens only when user option
-@code{tramp-use-ssh-controlmaster-options} is set to @code{t}. If the
+@code{tramp-use-connection-share} is set to @code{t}. If the
@file{~/.ssh/config} file is configured appropriately for the above
behavior, then any changes to @command{ssh} can be suppressed with
this @code{nil} setting:
@lisp
-(customize-set-variable 'tramp-use-ssh-controlmaster-options nil)
+(customize-set-variable 'tramp-use-connection-share nil)
@end lisp
Sometimes, it is not possible to use OpenSSH's @option{ControlMaster}
option for remote processes. This could result in concurrent access
to the OpenSSH socket when reading data by different processes, which
could block Emacs. In this case, setting
-@code{tramp-use-ssh-controlmaster-options} to @code{suppress} disables
-shared access. It is not needed to set this user option permanently
-to @code{suppress}, binding the user option prior calling
+@code{tramp-use-connection-share} to @code{suppress} disables shared
+access. It is not needed to set this user option permanently to
+@code{suppress}, binding the user option prior calling
@code{make-process} is sufficient. @value{tramp} does this for
esxample for compilation processes on its own.
@vindex ProxyCommand@r{, ssh option}
@vindex ProxyJump@r{, ssh option}
-@code{tramp-use-ssh-controlmaster-options} should also be set to
-@code{nil} or @code{suppress} if you use the @option{ProxyCommand} or
+@code{tramp-use-connection-share} should also be set to @code{nil} or
+@code{suppress} if you use the @option{ProxyCommand} or
@option{ProxyJump} options in your @command{ssh} configuration.
In order to use the @option{ControlMaster} option, @value{tramp} must
@@ -2809,12 +2857,16 @@ Host *
Check the @samp{ssh_config(5)} man page whether these options are
supported on your proxy host.
-On MS Windows, @code{tramp-use-ssh-controlmaster-options} is set to
-@code{nil} by default, because the MS Windows and MSYS2
-implementations of @command{OpenSSH} do not support this option properly.
+On MS Windows, @code{tramp-use-connection-share} is set to @code{nil}
+by default, because the MS Windows and MSYS2 implementations of
+@command{OpenSSH} do not support this option properly.
-In PuTTY, you can achieve connection sharing in the @option{Connection/SSH}
-entry, enabling the @option{Share SSH connections if possible} option.
+In PuTTY, you can achieve connection sharing in the
+@option{Connection/SSH} entry, enabling the @option{Share SSH
+connections if possible} option. @code{tramp-use-connection-share}
+must be set to @code{nil}. If @code{tramp-use-connection-share} is
+set to @code{t} or @code{suppress}, @command{plink} is called with the
+option @option{-share} or @option{-noshare}, respectively.
@subsection Configure direct copying between two remote servers
@@ -2933,10 +2985,11 @@ The fallback is to start Emacs from a shell.
@section @acronym{FUSE} setup hints
The @acronym{FUSE} file systems are mounted by default at
-@file{/tmp/tramp.method.user@@host#port}. The user name and port
-number are optional. If the file system is already mounted, it will
-be used as it is. If the mount point does not exist yet,
-@value{tramp} creates this directory.
+@t{"<TMP>/tramp.method.user@@host#port"}.@footnote{@ref{Temporary
+directory}} Method is either @t{"rclone"} or @t{"sshfs"}. The user
+name and port number are optional. If the file system is already
+mounted, it will be used as it is. If the mount point does not exist
+yet, @value{tramp} creates this directory.
The mount point can be overwritten by the connection property
@t{"mount-point"}, @ref{Predefined connection information}.
@@ -3100,6 +3153,29 @@ Open a remote connection with the more concise command @kbd{C-x C-f
@end itemize
+@node Kubernetes setup
+@section Kubernetes setup hints
+
+With the @option{kubernetes} method, containers in Kubernetes pods can
+be accessed. The host name is a pod name returned by @samp{kubectl
+get pods}, or @samp{@var{container}.@var{pod}} if an explicit
+container name shall be used. Otherwise, the first container in a pod
+is used.
+
+Sometimes, asynchronous processes for a host without a dedicated
+container name show a warning like @samp{Defaulted container
+"container1" out of: container1, container2}. This can be mitigated
+by setting the pod annotation
+@samp{kubectl.kubernetes.io/default-container} to a proper value
+(@samp{container1} in this example).
+
+@vindex tramp-kubernetes-context
+@vindex tramp-kubernetes-namespace
+@value{tramp} uses the default Kubernetes context and namespace. If
+another context or namespace shall be used, configure the user options
+@code{tramp-kubernetes-context} and @code{tramp-kubernetes-namespace}.
+
+
@node Auto-save File Lock and Backup
@section Auto-save, File Lock and Backup configuration
@cindex auto-save
@@ -3198,6 +3274,11 @@ auto-saved files to the same directory as the original file.
Alternatively, set the user option @code{tramp-auto-save-directory}
to direct all auto saves to that location.
+@c Since Emacs 30.
+@vindex remote-file-name-inhibit-auto-save
+If you want to suppress auto-saving of remote files at all, set user
+option @code{remote-file-name-inhibit-auto-save} to non-@code{nil}.
+
@c Since Emacs 29.
@vindex remote-file-name-inhibit-auto-save-visited
An alternative to @code{auto-save-mode} is
@@ -3660,6 +3741,47 @@ host name of the previous hop is reused. Therefore, the following
file name is equivalent to the previous example:
@samp{@trampfn{ssh@value{postfixhop}remotehost|su,,}}.
+@defopt tramp-completion-multi-hop-methods
+When this list includes the last method in a multi-hop connection, the
+remote host will be queried for a list of completion candidates. This
+can, for example, provide a list of running docker or podman
+containers on the remote host.
+
+@lisp
+(customize-set-variable 'tramp-completion-multi-hop-methods
+ `(,tramp-docker-method ,tramp-podman-method))
+@end lisp
+@end defopt
+
+A common use case for ad-hoc specifications is to visit a file or a
+directory with proper permissions, for example with the @option{sudo}
+method. The command @code{tramp-revert-buffer-with-sudo} supports
+this.
+
+@deffn Command tramp-revert-buffer-with-sudo
+This command shows the current buffer with @option{sudo} permissions.
+The buffer must either visit a file, or a directory
+(@code{dired-mode}).
+@end deffn
+
+@defopt tramp-file-name-with-method
+The method @code{tramp-revert-buffer-with-sudo} shows an alternate
+buffer. It defaults to @code{sudo}, other valid methods are
+@code{su}, @code{doas}, and @code{ksu}.
+
+@lisp
+(customize-set-variable 'tramp-file-name-with-method "doas")
+@end lisp
+@end defopt
+
+These methods apply the user @samp{root} as default. If another user
+shall be taken, add a proper rule to the user option
+@code{tramp-default-user-alist} (@pxref{Default User}):
+
+@lisp
+(add-to-list 'tramp-default-user-alist '("sudo" "remotehost" "admin"))
+@end lisp
+
@node Home directories
@section Expanding @file{~} to home directory
@@ -3968,12 +4090,12 @@ connection-local variables.
@vindex async-shell-command-width
@vindex COLUMNS@r{, environment variable}
-If Emacs supports the user option @code{async-shell-command-width}
-(since @w{Emacs 27}), @value{tramp} cares about its value for
-asynchronous shell commands. It specifies the number of display
-columns for command output. For synchronous shell commands, a similar
-effect can be achieved by adding the environment variable
-@env{COLUMNS} to @code{tramp-remote-process-environment}.
+@value{tramp} cares about the user option
+@code{async-shell-command-width} for asynchronous shell commands. It
+specifies the number of display columns for command output. For
+synchronous shell commands, a similar effect can be achieved by adding
+the environment variable @env{COLUMNS} to
+@code{tramp-remote-process-environment}.
@subsection Running @code{eshell} on a remote host
@@ -4315,17 +4437,14 @@ It does not report the remote terminal name via @code{process-tty-name}.
@item
It does not set process property @code{remote-pid}.
-
-@item
-It does not use @code{tramp-remote-path}.
@end itemize
In order to gain even more performance, it is recommended to bind
@code{tramp-verbose} to 0 when running @code{make-process} or
@code{start-file-process}. Furthermore, you might set
-@code{tramp-use-ssh-controlmaster-options} to @code{nil} in order to
-bypass @value{tramp}'s handling of the @option{ControlMaster} options,
-and use your own settings in @file{~/.ssh/config}, @ref{Using ssh
+@code{tramp-use-connection-share} to @code{nil} in order to bypass
+@value{tramp}'s handling of the @option{ControlMaster} options, and
+use your own settings in @file{~/.ssh/config}, @ref{Using ssh
connection sharing}.
@@ -4367,7 +4486,6 @@ Flushes the current buffer's remote connection objects, the same as in
Flushes all active remote connection objects, the same as in
@code{tramp-cleanup-connection}. This command removes also ad-hoc
proxy definitions (@pxref{Ad-hoc multi-hops}).
-
@end deffn
@deffn Command tramp-cleanup-all-buffers
@@ -4376,6 +4494,20 @@ connections and ad-hoc proxy definition are cleaned up in addition to
killing all buffers related to remote connections.
@end deffn
+@deffn Command tramp-cleanup-some-buffers
+Similar to @code{tramp-cleanup-all-buffers}, where all remote
+connections and ad-hoc proxy definition are cleaned up. However,
+additional buffers are killed only if one of the functions in
+@code{tramp-cleanup-some-buffers-hook} returns @code{t}.
+@end deffn
+
+@defopt tramp-cleanup-some-buffers-hook
+The functions in this hook determine, whether a remote buffer is
+killed when @code{tramp-cleanup-some-buffers} is called. Per default,
+remote buffers which are linked to a remote file, remote @code{dired}
+buffers, and buffers related to a remote process are cleaned up.
+@end defopt
+
@node Renaming remote files
@section Renaming remote files
@@ -4865,8 +4997,8 @@ Where is the latest @value{tramp}?
@item
Which systems does it work on?
-The package works successfully on @w{Emacs 26}, @w{Emacs 27}, @w{Emacs
-28}, and @w{Emacs 29}.
+The package works successfully on @w{Emacs 27}, @w{Emacs 28}, @w{Emacs
+29}, and @w{Emacs 30}.
While Unix and Unix-like systems are the primary remote targets,
@value{tramp} has equal success connecting to other platforms, such as
@@ -4925,6 +5057,36 @@ Disable file locks. Set @code{remote-file-name-inhibit-locks} to
the same remote file.
@item
+@vindex remote-file-name-inhibit-auto-save
+Keep auto-save files local. This is already the default configuration
+in Emacs, don't change it. If you want to disable auto-saving for
+remote files at all, set @code{remote-file-name-inhibit-auto-save} to
+@code{t}, but think about the consequences!
+
+If you want to disable auto-saving just for selected connections, for
+example due to security considerations, use connection-local variables
+in order to set @code{buffer-auto-save-file-name}. If you, for
+example, want to disable auto-saving for all @option{sudo}
+connections, apply the following code.
+@ifinfo
+@xref{Connection Variables, , , emacs}.
+@end ifinfo
+
+@lisp
+@group
+(connection-local-set-profile-variables
+ 'my-auto-save-profile
+ '((buffer-auto-save-file-name . nil)))
+@end group
+
+@group
+(connection-local-set-profiles
+ '(:application tramp :protocol "sudo")
+ 'my-auto-save-profile)
+@end group
+@end lisp
+
+@item
Disable excessive traces. Set @code{tramp-verbose} to 3 or lower,
default being 3. Increase trace levels temporarily when hunting for
bugs.
@@ -5065,6 +5227,41 @@ In order to disable those optimizations, set user option
@item
+@value{tramp} blocks Emacs at startup
+
+@vindex remote-file-name-access-timeout
+Some packages, like @file{desktop.el} or @file{recentf.el}, access
+remote files when loaded. If the requested file is not accessible,
+@value{tramp} could block. In order to check whether this could
+happen, add a test via @code{access-file} with a proper timeout prior
+to loading these packages:
+
+@lisp
+@group
+(let ((remote-file-name-access-timeout 10))
+ (access-file "@file{@trampfn{method,user@@host,/path/to/file}}" "error"))
+@result{} nil
+@end group
+@end lisp
+
+The result @code{nil} means success. If the file is not accessible,
+or if the underlying operations last too long, @code{access-file}
+returns with an error.
+
+The value of the timeout (10 seconds in the example) depends on your
+preference and on the quality of the connection to the remote host.
+If the connection to the remote host isn't established yet, and if
+this requires an interactive password, the timeout check doesn't work
+properly.
+
+@c Since Emacs 30.
+@strong{Note}: In recent versions of Emacs, both packages already
+apply this check. You just need to customize
+@code{remote-file-name-access-timeout} to the desired timeout (in
+seconds).
+
+
+@item
Does @value{tramp} support @acronym{SSH} security keys?
Yes. @command{OpenSSH} has added support for @acronym{FIDO} hardware
@@ -5158,17 +5355,39 @@ customization is explained in user option
@item
Remote host does not understand default options for directory listing
-Emacs computes the @command{dired} options based on the local host but
-if the remote host cannot understand the same @command{ls} command,
-then set them with a hook as follows:
+@vindex dired-listing-switches
+Emacs computes the @command{dired} options based on the local host.
+Since @w{Emacs 30}, these options can be set connection-local.
+@ifinfo
+@xref{Connection Variables, , , emacs}.
+@end ifinfo
+
+@lisp
+@group
+(connection-local-set-profile-variables
+ 'my-dired-profile
+ '((dired-listing-switches . "-ahl")))
+@end group
+
+@group
+(connection-local-set-profiles
+ '(:application tramp :machine "remotehost")
+ 'my-dired-profile)
+@end group
+@end lisp
+
+@vindex dired-actual-switches
+In older Emacsen, you can set the @command{dired} options with a hook
+as follows:
@lisp
@group
(add-hook
'dired-before-readin-hook
(lambda ()
- (when (file-remote-p default-directory)
- (setq dired-actual-switches "-al"))))
+ (when (string-equal
+ (file-remote-p default-directory 'host) "remotehost")
+ (setq dired-actual-switches "-ahl"))))
@end group
@end lisp
@@ -5224,6 +5443,7 @@ HISTFILE=/dev/null
@item
Where are remote files trashed to?
+@vindex remote-file-name-inhibit-delete-by-moving-to-trash
Emacs can trash file instead of deleting
@ifinfo
them, @ref{Misc File Ops, Trashing , , emacs}.
@@ -5231,9 +5451,10 @@ them, @ref{Misc File Ops, Trashing , , emacs}.
@ifnotinfo
them.
@end ifnotinfo
-Remote files are always trashed to the local trash, except remote
-encrypted files (@pxref{Keeping files encrypted}), which are deleted
-anyway.
+Remote files are always trashed to the local trash, except the user
+option @code{remote-file-name-inhibit-delete-by-moving-to-trash} is
+non-@code{nil}, or it is a remote encrypted file (@pxref{Keeping files
+encrypted}), which are deleted anyway.
If Emacs is configured to use the XDG conventions for the trash
directory, remote files cannot be restored with the respective tools,
@@ -5243,26 +5464,6 @@ be restored by moving them manually from
@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}?
Adapt several of these approaches to reduce typing. If the full name
@@ -5735,16 +5936,6 @@ If you want to enable Ange FTP's syntax, add the following form:
@end lisp
@item
-@vindex tramp-mode
-To disable both @value{tramp} (and Ange FTP), set @code{tramp-mode} to
-@code{nil} in @file{.emacs}. @strong{Note}, that we don't use
-@code{customize-set-variable}, in order to avoid loading @value{tramp}.
-
-@lisp
-(setq tramp-mode nil)
-@end lisp
-
-@item
@vindex tramp-ignored-file-name-regexp
To deactivate @value{tramp} for some look-alike remote file names, set
@code{tramp-ignored-file-name-regexp} to a proper regexp in
@@ -5760,6 +5951,29 @@ This is needed, if you mount for example a virtual file system on your
local host's root directory as @file{/ssh:example.com:}.
@item
+@findex inhibit-remote-files
+To disable both @value{tramp} (and Ange FTP), type @kbd{M-x
+inhibit-remote-files @key{RET}}. You can also add this to your
+@file{.emacs}.
+
+@lisp
+(inhibit-remote-files)
+@end lisp
+
+@item
+@findex without-remote-files
+If you write code, which is intended to run only for local files, you
+can use the @code{without-remote-files} macro.
+
+@lisp
+(without-remote-files @dots{})
+@end lisp
+
+This improves performance, because many primitive file name operations
+don't check any longer for Tramp file name regexps then.
+
+@item
+@findex tramp-unload-tramp
To unload @value{tramp}, type @kbd{M-x tramp-unload-tramp @key{RET}}.
Unloading @value{tramp} resets Ange FTP plugins also.
@end itemize
@@ -5780,11 +5994,45 @@ programs.
@chapter How file names, directories and localnames are mangled and managed
@menu
+* Temporary directory:: Where temporary files are kept.
* Localname deconstruction:: Splitting a localname into its component parts.
* External packages:: Integrating with external Lisp packages.
@end menu
+@node Temporary directory
+@section Where temporary files are kept
+
+@vindex temporary-file-directory
+Internally, @value{tramp} uses @t{"~/.cache/emacs"}
+as local temporary directory if it exists. Otherwise, the value of
+@code{temporary-file-directory} is used, which is often @t{"/tmp"}.
+
+@vindex tramp-compat-temporary-file-directory
+@vindex <TMP>
+This local temporary directory is kept in the constant
+@code{tramp-compat-temporary-file-directory}. In this manual, we use
+@t{"<TMP>"} for its value.
+
+The temporary directory on a remote host is @t{"/data/local/tmp"} for
+the @option{adb} method, @t{"/C$/Temp"} for the @option{smb} method,
+and @t{"/tmp"} otherwise. For some methods, this can be customized.
+
+@vindex tramp-temp-name-prefix
+Temporary files 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
+
+
@node Localname deconstruction
@section Splitting a localname into its component parts
@@ -5890,6 +6138,7 @@ wrapping the timer function body as follows:
@chapter How to Customize Traces
@vindex tramp-verbose
@vindex tramp-debug-to-file
+@vindex tramp-debug-command-messages
@value{tramp} messages are raised with verbosity levels ranging from 0
to 10. @value{tramp} does not display all messages; only those with a
@@ -5914,9 +6163,10 @@ The verbosity levels are
@end itemize
With @code{tramp-verbose} greater than or equal to 4, messages are
-also written to a @value{tramp} debug buffer. Such debug buffers are
-essential to bug and problem analyzes. For @value{tramp} bug reports,
-set the @code{tramp-verbose} level to 6 (@pxref{Bug Reports}).
+also written to the @value{tramp} debug buffer @file{*debug
+tramp/foo*}. Such debug buffers are essential to bug and problem
+analyzes. For @value{tramp} bug reports, set the @code{tramp-verbose}
+level to 6 (@pxref{Bug Reports}).
The debug buffer is in
@ifinfo
@@ -5955,13 +6205,18 @@ a file:
(customize-set-variable 'tramp-debug-to-file t)
@end lisp
-The debug buffer is written as a file in your
-@code{temporary-file-directory}, which is usually @file{/tmp/}. Use
-this option with care, because it could decrease the performance of
-@value{tramp} actions.
+The debug buffer is written as a file in your @ref{Temporary
+directory}. Use this option with care, because it could decrease the
+performance of @value{tramp} actions.
If @code{tramp-verbose} is greater than or equal to 11, @value{tramp}
-function call traces are written to a @value{tramp} trace buffer.
+function call traces are written to the buffer @file{*trace tramp/foo*}.
+
+When @code{tramp-debug-command-messages} is non-@code{nil}, the debug
+buffer contains all messages with verbosity level 6 (sent and received
+strings), and the entry and exit messages for the function
+@code{tramp-file-name-handler}. This is intended for @value{tramp}
+maintainers, analyzing the remote commands for performance analysis.
@node GNU Free Documentation License
diff --git a/doc/misc/trampver.texi b/doc/misc/trampver.texi
index 956d055fdaf..bf5c90ee8a9 100644
--- a/doc/misc/trampver.texi
+++ b/doc/misc/trampver.texi
@@ -7,10 +7,10 @@
@c In the Tramp GIT, the version number and the bug report address
@c are auto-frobbed from configure.ac.
-@set trampver 2.6.3-pre
+@set trampver 2.7.1-pre
@set trampurl https://www.gnu.org/software/tramp/
@set tramp-bug-report-address tramp-devel@@gnu.org
-@set emacsver 26.1
+@set emacsver 27.1
@c Other flags from configuration.
@set instprefix /usr/local
diff --git a/doc/misc/transient.texi b/doc/misc/transient.texi
index 33cc48675b2..3a6486903bf 100644
--- a/doc/misc/transient.texi
+++ b/doc/misc/transient.texi
@@ -31,7 +31,7 @@ General Public License for more details.
@finalout
@titlepage
@title Transient User and Developer Manual
-@subtitle for version 0.4.3
+@subtitle for version 0.6.0
@author Jonas Bernoulli
@page
@vskip 0pt plus 1filll
@@ -44,37 +44,16 @@ General Public License for more details.
@node Top
@top Transient User and Developer Manual
-Taking inspiration from prefix keys and prefix arguments, Transient
-implements a similar abstraction involving a prefix command, infix
-arguments and suffix commands. We could call this abstraction a
-“transient command”, but because it always involves at least two
-commands (a prefix and a suffix) we prefer to call it just a
-“transient”.
-
-When the user calls a transient prefix command, a transient
-(temporary) keymap is activated, which binds the transient's infix
-and suffix commands, and functions that control the transient state
-are added to @code{pre-command-hook} and @code{post-command-hook}. The available
-suffix and infix commands and their state are shown in a popup buffer
-until the transient is exited by invoking a suffix command.
-
-Calling an infix command causes its value to be changed, possibly by
-reading a new value in the minibuffer.
+Transient is the library used to implement the keyboard-driven ``menus''
+in Magit. It is distributed as a separate package, so that it can be
+used to implement similar menus in other packages.
-Calling a suffix command usually causes the transient to be exited
-but suffix commands can also be configured to not exit the transient.
-
-@quotation
-The second part of this manual, which describes how to modify existing
-transients and create new transients from scratch, can be hard to
-digest if you are just getting started. A useful resource to get over
-that hurdle is Psionic K's interactive tutorial, available at
-@uref{https://github.com/positron-solutions/transient-showcase}.
-
-@end quotation
+This manual can be bit hard to digest when getting started. A useful
+resource to get over that hurdle is Psionic K's interactive tutorial,
+available at @uref{https://github.com/positron-solutions/transient-showcase}.
@noindent
-This manual is for Transient version 0.4.3.
+This manual is for Transient version 0.6.0.
@insertcopying
@end ifnottex
@@ -85,7 +64,6 @@ This manual is for Transient version 0.4.3.
* Modifying Existing Transients::
* Defining New Commands::
* Classes and Methods::
-* Related Abstractions and Packages::
* FAQ::
* Keystroke Index::
* Command and Function Index::
@@ -110,6 +88,7 @@ Usage
Defining New Commands
+* Technical Introduction::
* Defining Transients::
* Binding Suffix and Infix Commands::
* Defining Suffix and Infix Commands::
@@ -139,157 +118,103 @@ Suffix Methods
* Suffix Format Methods::
-Related Abstractions and Packages
-
-* Comparison With Prefix Keys and Prefix Arguments::
-* Comparison With Other Packages::
-
@end detailmenu
@end menu
@node Introduction
@chapter Introduction
-Taking inspiration from prefix keys and prefix arguments, Transient
-implements a similar abstraction involving a prefix command, infix
-arguments and suffix commands. We could call this abstraction a
-“transient command”, but because it always involves at least two
-commands (a prefix and a suffix) we prefer to call it just a
-“transient”.
-
-@cindex transient prefix command
-@quotation
-Transient keymaps are a feature provided by Emacs. Transients as
-implemented by this package involve the use of transient keymaps.
-
-Emacs provides a feature that it calls @dfn{prefix commands}. When we
-talk about “prefix commands” in this manual, then we mean our own kind
-of “prefix commands”, unless specified otherwise. To avoid ambiguity
-we sometimes use the terms @dfn{transient prefix command} for our kind and
-“regular prefix command” for Emacs' kind.
+Transient is the library used to implement the keyboard-driven @dfn{menus}
+in Magit. It is distributed as a separate package, so that it can be
+used to implement similar menus in other packages.
-@end quotation
+This manual can be bit hard to digest when getting started. A useful
+resource to get over that hurdle is Psionic K's interactive tutorial,
+available at @uref{https://github.com/positron-solutions/transient-showcase}.
-When the user calls a transient prefix command, a transient
-(temporary) keymap is activated, which binds the transient's infix and
-suffix commands, and functions that control the transient state are
-added to @code{pre-command-hook} and @code{post-command-hook}. The available suffix
-and infix commands and their state are shown in a popup buffer until
-the transient state is exited by invoking a suffix command.
-
-Calling an infix command causes its value to be changed. How that is
-done depends on the type of the infix command. The simplest case is
-an infix command that represents a command-line argument that does not
-take a value. Invoking such an infix command causes the switch to be
-toggled on or off. More complex infix commands may read a value from
-the user, using the minibuffer.
-
-Calling a suffix command usually causes the transient to be exited;
-the transient keymaps and hook functions are removed, the popup buffer
-no longer shows information about the (no longer bound) suffix
-commands, the values of some public global variables are set, while
-some internal global variables are unset, and finally the command is
-actually called. Suffix commands can also be configured to not exit
-the transient.
-
-A suffix command can, but does not have to, use the infix arguments in
-much the same way any command can choose to use or ignore the prefix
-arguments. For a suffix command that was invoked from a transient, the
-variable @code{transient-current-suffixes} and the function @code{transient-args}
-serve about the same purpose as the variables @code{prefix-arg} and
-@code{current-prefix-arg} do for any command that was called after the prefix
-arguments have been set using a command such as @code{universal-argument}.
-
-The information shown in the popup buffer while a transient is active
-looks a bit like this:
-
-@example
-,-----------------------------------------
-|Arguments
-| -f Force (--force)
-| -a Annotate (--annotate)
-|
-|Create
-| t tag
-| r release
-`-----------------------------------------
-@end example
-
-@quotation
-This is a simplified version of @code{magit-tag}. Info manuals do not
-support images or colored text, so the above “screenshot” lacks some
-information; in practice you would be able to tell whether the
-arguments @code{--force} and @code{--annotate} are enabled or not based on their
-color.
-
-@end quotation
-
-@cindex command dispatchers
-Transient can be used to implement simple “command dispatchers”. The
-main benefit then is that the user can see all the available commands
-in a popup buffer. That is useful by itself because it frees the user
-from having to remember all the keys that are valid after a certain
-prefix key or command. Magit's @code{magit-dispatch} (on @kbd{C-x M-g}) command is
-an example of using Transient to merely implement a command
-dispatcher.
-
-In addition to that, Transient also allows users to interactively pass
-arguments to commands. These arguments can be much more complex than
-what is reasonable when using prefix arguments. There is a limit to
-how many aspects of a command can be controlled using prefix
-arguments. Furthermore, what a certain prefix argument means for
-different commands can be completely different, and users have to read
-documentation to learn and then commit to memory what a certain prefix
-argument means to a certain command.
-
-Transient suffix commands, on the other hand, can accept dozens of
-different arguments without the user having to remember anything.
-When using Transient, one can call a command with arguments that are
-just as complex as when calling the same function non-interactively
-from Lisp.
-
-Invoking a transient suffix command with arguments is similar to
-invoking a command in a shell with command-line completion and history
-enabled. One benefit of the Transient interface is that it remembers
-history not only on a global level (“this command was invoked using
-these arguments, and previously it was invoked using those other
-arguments”), but also remembers the values of individual arguments
-independently. See @xref{Using History}.
-
-After a transient prefix command is invoked, @kbd{C-h @var{KEY}} can be used to
-show the documentation for the infix or suffix command that @kbd{@var{KEY}} is
-bound to (see @ref{Getting Help for Suffix Commands}), and infixes and
-suffixes can be removed from the transient using @kbd{C-x l @var{KEY}}. Infixes
-and suffixes that are disabled by default can be enabled the same way.
-@xref{Enabling and Disabling Suffixes}.
+@anchor{Some things that Transient can do}
+@heading Some things that Transient can do
-Transient ships with support for a few different types of specialized
-infix commands. A command that sets a command line option, for example,
-has different needs than a command that merely toggles a boolean flag.
-Additionally, Transient provides abstractions for defining new types,
-which the author of Transient did not anticipate (or didn't get around
-to implementing yet).
+@itemize
+@item
+Display current state of arguments
+@item
+Display and manage lifecycle of modal bindings
+@item
+Contextual user interface
+@item
+Flow control for wizard-like composition of interactive forms
+@item
+History & persistence
+@item
+Rendering arguments for controlling CLI programs
+@end itemize
-Note that suffix commands also support regular prefix arguments. A
-suffix command may even be called with both infix and prefix arguments
-at the same time. If you invoke a command as a suffix of a transient
-prefix command, but also want to pass prefix arguments to it, then
-first invoke the prefix command, and only after doing that invoke the
-prefix arguments, before finally invoking the suffix command. If you
-instead began by providing the prefix arguments, then those would
-apply to the prefix command, not the suffix command. Likewise, if you
-want to change infix arguments before invoking a suffix command with
-prefix arguments, then change the infix arguments before invoking the
-prefix arguments. In other words, regular prefix arguments always
-apply to the next command, and since transient prefix, infix and
-suffix commands are just regular commands, the same applies to them.
-(Regular prefix keys behave differently because they are not commands
-at all, instead they are just incomplete key sequences, and those
-cannot be interrupted with prefix commands.)
+@anchor{Complexity in CLI programs}
+@heading Complexity in CLI programs
+
+Complexity tends to grow with time. How do you manage the complexity
+of commands? Consider the humble shell command @samp{ls}. It now has over
+@emph{fifty} command line options. Some of these are boolean flags (@samp{ls -l}).
+Some take arguments (@samp{ls --sort=s}). Some have no effect unless paired
+with other flags (@samp{ls -lh}). Some are mutually exclusive. Some shell
+commands even have so many options that they introduce @emph{subcommands}
+(@samp{git branch}, @samp{git commit}), each with their own rich set of options
+(@samp{git branch -f}).
+
+@anchor{Using Transient for composing interactive commands}
+@heading Using Transient for composing interactive commands
+
+What about Emacs commands used interactively? How do these handle
+options? One solution is to make many versions of the same command,
+so you don't need to! Consider: @samp{delete-other-windows} vs.
+@samp{delete-other-windows-vertically} (among many similar examples).
+
+Some Emacs commands will simply prompt you for the next "argument"
+(@samp{M-x switch-to-buffer}). Another common solution is to use prefix
+arguments which usually start with @samp{C-u}. Sometimes these are sensibly
+numerical in nature (@samp{C-u 4 M-x forward-paragraph} to move forward 4
+paragraphs). But sometimes they function instead as boolean
+"switches" (@samp{C-u C-SPACE} to jump to the last mark instead of just
+setting it, @samp{C-u C-u C-SPACE} to unconditionally set the mark). Since
+there aren't many standards for the use of prefix options, you have to
+read the command's documentation to find out what the possibilities
+are.
+
+But when an Emacs command grows to have a truly large set of options
+and arguments, with dependencies between them, lots of option values,
+etc., these simple approaches just don't scale. Transient is designed
+to solve this issue. Think of it as the humble prefix argument @samp{C-u},
+@emph{raised to the power of 10}. Like @samp{C-u}, it is key driven. Like the
+shell, it supports boolean "flag" options, options that take
+arguments, and even "sub-commands", with their own options. But
+instead of searching through a man page or command documentation,
+well-designed transients @emph{guide} their users to the relevant set of
+options (and even their possible values!) directly, taking into
+account any important pre-existing Emacs settings. And while for
+shell commands like @samp{ls}, there is only one way to "execute" (hit
+@samp{Return}!), transients can "execute" using multiple different keys tied
+to one of many self-documenting @emph{actions} (imagine having 5 different
+colored return keys on your keyboard!). Transients make navigating
+and setting large, complex groups of command options and arguments
+easy. Fun even. Once you've tried it, it's hard to go back to the
+@samp{C-u what can I do here again?} way.
@node Usage
@chapter Usage
+@menu
+* Invoking Transients::
+* Aborting and Resuming Transients::
+* Common Suffix Commands::
+* Saving Values::
+* Using History::
+* Getting Help for Suffix Commands::
+* Enabling and Disabling Suffixes::
+* Other Commands::
+* Configuration::
+@end menu
+
@node Invoking Transients
@section Invoking Transients
@@ -354,7 +279,7 @@ it returns to the previous transient, if any.
Transient's predecessor bound @kbd{q} instead of @kbd{C-g} to the quit command.
To learn how to get that binding back see @code{transient-bind-q-to-quit}'s
-doc string.
+documentation string.
@table @asis
@item @kbd{C-q} (@code{transient-quit-all})
@@ -370,7 +295,7 @@ suspended transients, if any.
Like @code{transient-quit-all}, this command quits an incomplete key
sequence, if any, and all transients. Additionally, it saves the
stack of transients so that it can easily be resumed (which is
-particularly useful if you quickly need to do “something else” and
+particularly useful if you quickly need to do ``something else'' and
the stack is deeper than a single transient, and/or you have already
changed the values of some infix arguments).
@@ -397,7 +322,7 @@ as well as some other commands that are all bound to @kbd{C-x @var{KEY}}. After
@kbd{C-x} is pressed, a section featuring all these common commands is
temporarily shown in the popup buffer. After invoking one of them,
the section disappears again. Note, however, that one of these
-commands is described as “Show common permanently”; invoke that if you
+commands is described as ``Show common permanently''; invoke that if you
want the common commands to always be shown for all transients.
@table @asis
@@ -550,8 +475,8 @@ What sort of documentation is shown depends on how the transient was
defined. For infix commands that represent command-line arguments
this ideally shows the appropriate manpage. @code{transient-help} then tries
to jump to the correct location within that. Info manuals are also
-supported. The fallback is to show the command's doc string, for
-non-infix suffixes this is usually appropriate.
+supported. The fallback is to show the command's documentation
+string, for non-infix suffixes this is usually appropriate.
@node Enabling and Disabling Suffixes
@section Enabling and Disabling Suffixes
@@ -577,7 +502,7 @@ displayed at any level.
The levels of individual transients and/or their individual suffixes
can be changed interactively, by invoking the transient and then
-pressing @kbd{C-x l} to enter the “edit” mode, see below.
+pressing @kbd{C-x l} to enter the ``edit'' mode, see below.
The default level for both transients and their suffixes is 4. The
@code{transient-default-level} option only controls the default for
@@ -625,6 +550,13 @@ not. The predicates also apply in edit mode.
Therefore, to control which suffixes are available given a certain
state, you have to make sure that that state is currently active.
+
+@item @kbd{C-x a} (@code{transient-toggle-level-limit})
+@kindex C-x a
+@findex transient-toggle-level-limit
+This command toggle whether suffixes that are on levels higher than
+the level specified by @code{transient-default-level} are temporarily
+available anyway.
@end table
@node Other Commands
@@ -770,27 +702,31 @@ If @code{nil}, then the buffer has no mode-line. If the buffer is not
displayed right above the echo area, then this probably is not a
good value.
-If @code{line} (the default), then the buffer also has no mode-line, but a
-thin line is drawn instead, using the background color of the face
-@code{transient-separator}. Text-mode frames cannot display thin lines,
-and therefore fall back to treating @code{line} like @code{nil}.
+If @code{line} (the default) or a natural number, then the buffer
+has no mode-line, but a line is drawn is drawn in its place.
+If a number is used, that specifies the thickness of the line.
+On termcap frames we cannot draw lines, so there @code{line} and
+numbers are synonyms for @code{nil}.
+
+The color of the line is used to indicate if non-suffixes are
+allowed and whether they exit the transient. The foreground
+color of @code{transient-key-noop} (if non-suffix are disallowed),
+@code{transient-key-stay} (if allowed and transient stays active), or
+@code{transient-key-exit} (if allowed and they exit the transient) is
+used to draw the line.
Otherwise this can be any mode-line format. @xref{Mode Line
Format,,,elisp,}, for details.
@end defopt
@defopt transient-semantic-coloring
-This option controls whether prefixes and suffixes are colored in
-a Hydra-like fashion.
+This option controls whether colors are used to indicate the
+transient behavior of commands.
If non-@code{nil}, then the key binding of each suffix is colorized to
indicate whether it exits the transient state or not. The color of
the prefix is indicated using the line that is drawn when the value
of @code{transient-mode-line-format} is @code{line}.
-
-For more information about how Hydra uses colors see
-@uref{https://github.com/abo-abo/hydra#color} and
-@uref{https://oremacs.com/2015/02/19/hydra-colors-reloaded}.
@end defopt
@defopt transient-highlight-mismatched-keys
@@ -927,8 +863,8 @@ The following functions share a few arguments:
@item
@var{SUFFIX} is a transient infix or suffix specification in the same form
as expected by @code{transient-define-prefix}. Note that an infix is a
-special kind of suffix. Depending on context “suffixes” means
-“suffixes (including infixes)” or “non-infix suffixes”. Here it
+special kind of suffix. Depending on context ``suffixes'' means
+``suffixes (including infixes)'' or ``non-infix suffixes''. Here it
means the former. @xref{Suffix Specifications}.
@var{SUFFIX} may also be a group in the same form as expected by
@@ -1002,6 +938,115 @@ signal an error.
@node Defining New Commands
@chapter Defining New Commands
+@menu
+* Technical Introduction::
+* Defining Transients::
+* Binding Suffix and Infix Commands::
+* Defining Suffix and Infix Commands::
+* Using Infix Arguments::
+* Transient State::
+@end menu
+
+@node Technical Introduction
+@section Technical Introduction
+
+Taking inspiration from prefix keys and prefix arguments, Transient
+implements a similar abstraction involving a prefix command, infix
+arguments and suffix commands.
+
+When the user calls a transient prefix command, a transient
+(temporary) keymap is activated, which binds the transient's infix and
+suffix commands, and functions that control the transient state are
+added to @code{pre-command-hook} and @code{post-command-hook}. The available suffix
+and infix commands and their state are shown in a popup buffer until
+the transient state is exited by invoking a suffix command.
+
+Calling an infix command causes its value to be changed. How that is
+done depends on the type of the infix command. The simplest case is
+an infix command that represents a command-line argument that does not
+take a value. Invoking such an infix command causes the switch to be
+toggled on or off. More complex infix commands may read a value from
+the user, using the minibuffer.
+
+Calling a suffix command usually causes the transient to be exited;
+the transient keymaps and hook functions are removed, the popup buffer
+no longer shows information about the (no longer bound) suffix
+commands, the values of some public global variables are set, while
+some internal global variables are unset, and finally the command is
+actually called. Suffix commands can also be configured to not exit
+the transient.
+
+A suffix command can, but does not have to, use the infix arguments in
+much the same way any command can choose to use or ignore the prefix
+arguments. For a suffix command that was invoked from a transient, the
+variable @code{transient-current-suffixes} and the function @code{transient-args}
+serve about the same purpose as the variables @code{prefix-arg} and
+@code{current-prefix-arg} do for any command that was called after the prefix
+arguments have been set using a command such as @code{universal-argument}.
+
+@cindex command dispatchers
+Transient can be used to implement simple ``command dispatchers''. The
+main benefit then is that the user can see all the available commands
+in a popup buffer, which can be thought of as a ``menus''. That is
+useful by itself because it frees the user from having to remember all
+the keys that are valid after a certain prefix key or command.
+Magit's @code{magit-dispatch} (on @kbd{C-x M-g}) command is an example of using
+Transient to merely implement a command dispatcher.
+
+In addition to that, Transient also allows users to interactively pass
+arguments to commands. These arguments can be much more complex than
+what is reasonable when using prefix arguments. There is a limit to
+how many aspects of a command can be controlled using prefix
+arguments. Furthermore, what a certain prefix argument means for
+different commands can be completely different, and users have to read
+documentation to learn and then commit to memory what a certain prefix
+argument means to a certain command.
+
+Transient suffix commands, on the other hand, can accept dozens of
+different arguments without the user having to remember anything.
+When using Transient, one can call a command with arguments that are
+just as complex as when calling the same function non-interactively
+from Lisp.
+
+Invoking a transient suffix command with arguments is similar to
+invoking a command in a shell with command-line completion and history
+enabled. One benefit of the Transient interface is that it remembers
+history not only on a global level (``this command was invoked using
+these arguments, and previously it was invoked using those other
+arguments''), but also remembers the values of individual arguments
+independently. See @ref{Using History}.
+
+After a transient prefix command is invoked, @kbd{C-h @var{KEY}} can be used to
+show the documentation for the infix or suffix command that @kbd{@var{KEY}} is
+bound to (see @ref{Getting Help for Suffix Commands}), and infixes and
+suffixes can be removed from the transient using @kbd{C-x l @var{KEY}}. Infixes
+and suffixes that are disabled by default can be enabled the same way.
+See @ref{Enabling and Disabling Suffixes}.
+
+Transient ships with support for a few different types of specialized
+infix commands. A command that sets a command line option, for example,
+has different needs than a command that merely toggles a boolean flag.
+Additionally, Transient provides abstractions for defining new types,
+which the author of Transient did not anticipate (or didn't get around
+to implementing yet).
+
+Note that suffix commands also support regular prefix arguments. A
+suffix command may even be called with both infix and prefix arguments
+at the same time. If you invoke a command as a suffix of a transient
+prefix command, but also want to pass prefix arguments to it, then
+first invoke the prefix command, and only after doing that invoke the
+prefix arguments, before finally invoking the suffix command. If you
+instead began by providing the prefix arguments, then those would
+apply to the prefix command, not the suffix command. Likewise, if you
+want to change infix arguments before invoking a suffix command with
+prefix arguments, then change the infix arguments before invoking the
+prefix arguments. In other words, regular prefix arguments always
+apply to the next command, and since transient prefix, infix and
+suffix commands are just regular commands, the same applies to them.
+(Regular prefix keys behave differently because they are not commands
+at all, instead they are just incomplete key sequences, and those
+cannot be interrupted with prefix commands.)
+
@node Defining Transients
@section Defining Transients
@@ -1046,7 +1091,7 @@ however, call that function only when some condition is satisfied.
All transients have a (possibly @code{nil}) value, which is exported when
suffix commands are called, so that they can consume that value.
For some transients it might be necessary to have a sort of
-secondary value, called a “scope”. Such a scope would usually be
+secondary value, called a ``scope''. Such a scope would usually be
set in the command's @code{interactive} form and has to be passed to the
setup function:
@@ -1067,10 +1112,9 @@ Transients}) and adds the transient's infix and suffix bindings, as
described below.
Users and third-party packages can add additional bindings using
-functions such as @code{transient-insert-suffix} (@pxref{Modifying
-Existing Transients}). These functions take a “suffix
-specification” as one of their arguments, which has the same form as
-the specifications used in @code{transient-define-prefix}.
+functions such as @code{transient-insert-suffix} (@pxref{Modifying Existing Transients}). These functions take a ``suffix specification'' as one of
+their arguments, which has the same form as the specifications used in
+@code{transient-define-prefix}.
@menu
* Group Specifications::
@@ -1162,9 +1206,19 @@ The returned children must have the same form as stored in the
prefix's @code{transient--layout} property, but it is often more convenient
to use the same form as understood by @code{transient-define-prefix},
described below. If you use the latter approach, you can use the
-@code{transient-parse-child} and @code{transient-parse-children} functions to
+@code{transient-parse-suffixes} and @code{transient-parse-suffix} functions to
transform them from the convenient to the expected form.
+If you explicitly specify children and then transform them using
+@code{:setup-chilren}, then the class of the group is determined as usual,
+based on explicitly specified children.
+
+If you do not explicitly specify children and thus rely solely on
+@code{:setup-children}, then you must specify the class using @code{:class}.
+For backward compatibility, if you fail to do so, @code{transient-column}
+is used and a warning is displayed. This warning will eventually
+be replaced with an error.
+
@item
The boolean @code{:pad-keys} argument controls whether keys of all suffixes
contained in a group are right padded, effectively aligning the
@@ -1176,11 +1230,11 @@ The @var{ELEMENT}s are either all subgroups, or all suffixes and strings.
subgroups with commands at the same level, though in principle there
is nothing that prevents that.)
-If the @var{ELEMENT}s are not subgroups, then they can be a mixture of lists
-that specify commands and strings. Strings are inserted verbatim into
-the buffer. The empty string can be used to insert gaps between
-suffixes, which is particularly useful if the suffixes are outlined as
-a table.
+If the @var{ELEMENT}s are not subgroups, then they can be a mixture of
+lists, which specify commands, and strings. Strings are inserted
+verbatim into the buffer. The empty string can be used to insert gaps
+between suffixes, which is particularly useful if the suffixes are
+outlined as a table.
Inside group specifications, including inside contained suffix
specifications, nothing has to be quoted and quoting anyway is
@@ -1204,8 +1258,8 @@ The same form is also used when later binding additional commands
using functions such as @code{transient-insert-suffix}, see @ref{Modifying Existing Transients}.
Note that an infix is a special kind of suffix. Depending on context
-“suffixes” means “suffixes (including infixes)” or “non-infix
-suffixes”. Here it means the former.
+``suffixes'' means ``suffixes (including infixes)'' or ``non-infix
+suffixes''. Here it means the former.
Suffix specifications have this form:
@@ -1231,10 +1285,10 @@ the object's values just for the binding inside this transient.
@item
@var{DESCRIPTION} is the description, either a string or a function that
-returns a string. The function should be a lambda expression to
-avoid ambiguity. In some cases a symbol that is bound as a function
-would also work but to be safe you should use @code{:description} in that
-case.
+takes zero or one arguments (the suffix object) and returns a string.
+The function should be a lambda expression to avoid ambiguity. In
+some cases a symbol that is bound as a function would also work but
+to be safe you should use @code{:description} in that case.
@end itemize
The next element is either a command or an argument. This is the only
@@ -1299,8 +1353,8 @@ argument supported by the constructor of that class. See @ref{Suffix Slots}.
@cindex defining infix commands
Note that an infix is a special kind of suffix. Depending on context
-“suffixes” means “suffixes (including infixes)” or “non-infix
-suffixes”.
+``suffixes'' means ``suffixes (including infixes)'' or ``non-infix
+suffixes''.
@defmac transient-define-suffix name arglist [docstring] [keyword value]@dots{} body@dots{}
This macro defines @var{NAME} as a transient suffix command.
@@ -1433,7 +1487,7 @@ returned value is a symbol, the transient prefix command.
@cindex transient state
-Invoking a transient prefix command “activates” the respective
+Invoking a transient prefix command ``activates'' the respective
transient, i.e., it puts a transient keymap into effect, which binds
the transient's infix and suffix commands.
@@ -1445,73 +1499,65 @@ Invoking an infix command does not affect the transient state; the
transient remains active.
@item
-Invoking a (non-infix) suffix command “deactivates” the transient
+Invoking a (non-infix) suffix command ``deactivates'' the transient
state by removing the transient keymap and performing some
additional cleanup.
@item
Invoking a command that is bound in a keymap other than the
transient keymap is disallowed and trying to do so results in a
-warning. This does not “deactivate” the transient.
+warning. This does not ``deactivate'' the transient.
@end itemize
-But these are just the defaults. Whether a certain command
-deactivates or “exits” the transient is configurable. There is more
-than one way in which a command can be “transient” or “non-transient”;
-the exact behavior is implemented by calling a so-called “pre-command”
-function. Whether non-suffix commands are allowed to be called is
-configurable per transient.
+The behavior can be changed for all suffixes of a particular prefix
+and/or for individual suffixes. The values should nearly always be
+booleans, but certain functions, called ``pre-commands'', can also be
+used. These functions are named @code{transient--do-VERB}, and the symbol
+@code{VERB} can be used as a shorthand.
-@itemize
-@item
-The transient-ness of suffix commands (including infix commands) is
-controlled by the value of their @code{transient} slot, which can be set
-either when defining the command or when adding a binding to a
-transient while defining the respective transient prefix command.
+A boolean is interpreted as answering the question "does the
+transient stay active, when this command is invoked?" @code{t} means that
+the transient stays active, while @code{nil} means that invoking the command
+exits the transient.
-Valid values are booleans and the pre-commands described below.
+Note that when the suffix is a ``sub-prefix'', invoking that command
+always activates that sub-prefix, causing the outer prefix to no
+longer be active and displayed. Here @code{t} means that when you exit the
+inner prefix, then the outer prefix becomes active again, while @code{nil}
+means that all outer prefixes are exited at once.
@itemize
@item
-@code{t} is equivalent to @code{transient--do-stay}.
-@item
-@code{nil} is equivalent to @code{transient--do-exit}.
-@item
-If @code{transient} is unbound (and that is actually the default for
-non-infix suffixes) then the value of the prefix's
-@code{transient-suffix} slot is used instead. The default value of that
-slot is @code{nil}, so the suffix's @code{transient} slot being unbound is
-essentially equivalent to it being @code{nil}.
-@end itemize
+The behavior for non-suffixes can be set for a particular prefix,
+by the prefix's @code{transient-non-suffix} slot to a boolean, a suitable
+pre-command function, or a shorthand for such a function. See
+@ref{Pre-commands for Non-Suffixes}.
@item
-A suffix command can be a prefix command itself, i.e., a
-“sub-prefix”. While a sub-prefix is active we nearly always want
-@kbd{C-g} to take the user back to the “super-prefix”. However in rare
-cases this may not be desirable, and that makes the following
-complication necessary:
+The common behavior for the suffixes of a particular prefix can be
+set using the prefix's @code{transient-suffixes} slot.
-For @code{transient-suffix} objects the @code{transient} slot is unbound. We can
-ignore that for the most part because, as stated above, @code{nil} and the
-slot being unbound are equivalent, and mean “do exit”. That isn't
-actually true for suffixes that are sub-prefixes though. For such
-suffixes unbound means “do exit but allow going back”, which is the
-default, while @code{nil} means “do exit permanently”, which requires that
-slot to be explicitly set to that value.
+The value specified in this slot does @strong{not} affect infixes. Because
+it affects both regular suffixes as well as sub-prefixes, which
+have different needs, it is best to avoid explicitly specifying a
+function.
@item
-The transient-ness of certain built-in suffix commands is specified
-using @code{transient-predicate-map}. This is a special keymap, which
-binds commands to pre-commands (as opposed to keys to commands) and
-takes precedence over the @code{transient} slot.
+The behavior of an individual suffix can be changed using its
+@code{transient} slot. While it is usually best to use a boolean, for this
+slot it can occasionally make sense to specify a function explicitly.
+
+Note that this slot can be set when defining a suffix command using
+@code{transient-define-suffix} and/or in the definition of the prefix. If
+set in both places, then the latter takes precedence, as usual.
@end itemize
-The available pre-command functions are documented below. They are
-called by @code{transient--pre-command}, a function on @code{pre-command-hook} and
-the value that they return determines whether the transient is exited.
-To do so the value of one of the constants @code{transient--exit} or
-@code{transient--stay} is used (that way we don't have to remember if @code{t} means
-“exit” or “stay”).
+The available pre-command functions are documented in the following
+sub-sections. They are called by @code{transient--pre-command}, a function
+on @code{pre-command-hook}, and the value that they return determines whether
+the transient is exited. To do so the value of one of the constants
+@code{transient--exit} or @code{transient--stay} is used (that way we don't have to
+remember if @code{t} means ``exit'' or ``stay'').
Additionally, these functions may change the value of @code{this-command}
(which explains why they have to be called using @code{pre-command-hook}),
@@ -1519,11 +1565,39 @@ call @code{transient-export}, @code{transient--stack-zap} or @code{transient--st
and set the values of @code{transient--exitp}, @code{transient--helpp} or
@code{transient--editp}.
+For completeness sake, some notes about complications:
+
+@itemize
+@item
+The transient-ness of certain built-in suffix commands is specified
+using @code{transient-predicate-map}. This is a special keymap, which
+binds commands to pre-commands (as opposed to keys to commands) and
+takes precedence over the prefix's @code{transient-suffix} slot, but not
+the suffix's @code{transient} slot.
+
+@item
+While a sub-prefix is active we nearly always want @kbd{C-g} to take the
+user back to the ``super-prefix'', even when the other suffixes don't
+do that. However, in rare cases this may not be desirable, and that
+makes the following complication necessary:
+
+For @code{transient-suffix} objects the @code{transient} slot is unbound. We can
+ignore that for the most part because @code{nil} and the slot being unbound
+are treated as equivalent, and mean ``do exit''. That isn't actually
+true for suffixes that are sub-prefixes though. For such suffixes
+unbound means ``do exit but allow going back'', which is the default,
+while @code{nil} means ``do exit permanently'', which requires that slot to
+be explicitly set to that value.
+@end itemize
+
@anchor{Pre-commands for Infixes}
@subheading Pre-commands for Infixes
The default for infixes is @code{transient--do-stay}. This is also the only
-function that makes sense for infixes.
+function that makes sense for infixes, which is why this predicate is
+used even if the value of the prefix's @code{transient-suffix} slot is @code{t}. In
+extremely rare cases, one might want to use something else, which can
+be done by setting the infix's @code{transient} slot directly.
@defun transient--do-stay
Call the command without exporting variables and stay transient.
@@ -1534,23 +1608,16 @@ Call the command without exporting variables and stay transient.
By default, invoking a suffix causes the transient to be exited.
-If you want a different default behavior for a certain transient
-prefix command, then set its @code{:transient-suffix} slot. The value can be
-a boolean, answering the question "does the transient stay active,
-when a suffix command is invoked?" @code{t} means that the transient stays
-active, while @code{nil} means that invoking a suffix exits the transient.
-In either case, the exact behavior depends on whether the suffix is
-itself a prefix (i.e., a sub-prefix), an infix or a regular suffix.
-
The behavior for an individual suffix command can be changed by
-setting its @code{transient} slot to one of the following pre-commands.
+setting its @code{transient} slot to a boolean (which is highly recommended),
+or to one of the following pre-commands.
@defun transient--do-exit
Call the command after exporting variables and exit the transient.
@end defun
@defun transient--do-return
-Call the command after exporting variables and return to parent
+Call the command after exporting variables and return to the parent
prefix. If there is no parent prefix, then call @code{transient--do-exit}.
@end defun
@@ -1558,9 +1625,10 @@ prefix. If there is no parent prefix, then call @code{transient--do-exit}.
Call the command after exporting variables and stay transient.
@end defun
-The following pre-commands are suitable for sub-prefixes. Only the
-first should ever explicitly be set as the value of the @code{transient}
-slot.
+The following pre-commands are only suitable for sub-prefixes. It is
+not necessary to explicitly use these predicates because the correct
+predicate is automatically picked based on the value of the @code{transient}
+slot for the sub-prefix itself.
@defun transient--do-recurse
Call the transient prefix command, preparing for return to active
@@ -1568,15 +1636,25 @@ transient.
Whether we actually return to the parent transient is ultimately
under the control of each invoked suffix. The difference between
-this pre-command and @code{transient--do-replace} is that it changes the
-value of the @code{transient-suffix} slot to @code{transient--do-return}.
+this pre-command and @code{transient--do-stack} is that it changes the
+value of the @code{transient-suffix} slot to @code{t}.
If there is no parent transient, then only call this command and
skip the second step.
@end defun
+@defun transient--do-stack
+Call the transient prefix command, stacking the active transient.
+Push the active transient to the transient stack.
+
+Unless @code{transient--do-recurse} is explicitly used, this pre-command
+is automatically used for suffixes that are prefixes themselves,
+i.e., for sub-prefixes.
+@end defun
+
@defun transient--do-replace
Call the transient prefix command, replacing the active transient.
+Do not push the active transient to the transient stack.
Unless @code{transient--do-recurse} is explicitly used, this pre-command
is automatically used for suffixes that are prefixes themselves,
@@ -1587,7 +1665,7 @@ i.e., for sub-prefixes.
Suspend the active transient, saving the transient stack.
This is used by the command @code{transient-suspend} and optionally also by
-“external events” such as @code{handle-switch-frame}. Such bindings should
+``external events'' such as @code{handle-switch-frame}. Such bindings should
be added to @code{transient-predicate-map}.
@end defun
@@ -1598,17 +1676,17 @@ By default, non-suffixes (commands that are bound in other keymaps
beside the transient keymap) cannot be invoked. Trying to invoke
such a command results in a warning and the transient stays active.
-If you want a different behavior, then set the @code{:transient-non-suffix}
-slot of the transient prefix command. The value can be a boolean,
-answering the question, "is it allowed to invoke non-suffix commands?"
+If you want a different behavior, then set the @code{transient-non-suffix}
+slot of the transient prefix command. The value should be a boolean,
+answering the question, "is it allowed to invoke non-suffix commands?,
+a pre-command function, or a shorthand for such a function.
-If the value is @code{t} or @code{transient--do-stay}, then non-suffixes can be
-invoked, when it is @code{nil} or @code{transient--do-warn} (the default) then they
-cannot be invoked.
+If the value is @code{t}, then non-suffixes can be invoked, when it is @code{nil}
+(the default) then they cannot be invoked.
-The only other recommended value is @code{transient--do-leave}. If that is
-used, then non-suffixes can be invoked, but if one is invoked, then
-that exits the transient.
+The only other recommended value is @code{leave}. If that is used, then
+non-suffixes can be invoked, but if one is invoked, then that exits
+the transient.
@defun transient--do-warn
Call @code{transient-undefined} and stay transient.
@@ -1713,7 +1791,7 @@ The abstract @code{transient-child} class is the base class of both
@code{transient-group} (and therefore all groups) as well as of
@code{transient-suffix} (and therefore all suffix and infix commands).
-This class exists because the elements (or “children”) of certain
+This class exists because the elements (or ``children'') of certain
groups can be other groups instead of suffix and infix commands.
@item
@@ -1723,7 +1801,7 @@ group classes.
@item
The @code{transient-column} class is the simplest group.
-This is the default “flat” group. If the class is not specified
+This is the default ``flat'' group. If the class is not specified
explicitly and the first element is not a vector (i.e., not a group),
then this class is used.
@@ -1739,7 +1817,7 @@ Direct elements have to be groups whose elements have to be commands
or strings. Each subgroup represents a column. This class takes
care of inserting the subgroups' elements.
-This is the default “nested” group. If the class is not specified
+This is the default ``nested'' group. If the class is not specified
explicitly and the first element is a vector (i.e., a group), then
this class is used.
@@ -1850,6 +1928,24 @@ indicates that all remaining arguments are files.
@item
Classes used for infix commands that represent variables should
derived from the abstract @code{transient-variable} class.
+
+@item
+The @code{transient-information} class is special in that suffixes that use
+this class are not associated with a command and thus also not with
+any key binding. Such suffixes are only used to display arbitrary
+information, and that anywhere a suffix can appear. Display-only
+suffix specifications take this form:
+
+@lisp
+([LEVEL] :info DESCRIPTION [KEYWORD VALUE]...)
+@end lisp
+
+The @code{:info} keyword argument replaces the @code{:description} keyword used for
+other suffix classes. Other keyword arguments that you might want to
+set, include @code{:face}, predicate keywords (such as @code{:if}), and @code{:format}.
+By default the value of @code{:format} includes @code{%k}, which for this class is
+replaced with the empty string or spaces, if keys are being padded in
+the containing group.
@end itemize
Magit defines additional classes, which can serve as examples for the
@@ -1917,7 +2013,7 @@ function is how the value of a transient is determined so that the
invoked suffix command can use it.
Currently most values are strings, but that is not set in stone.
-@code{nil} is not a value, it means “no value”.
+@code{nil} is not a value, it means ``no value''.
Usually only infixes have a value, but see the method for
@code{transient-suffix}.
@@ -1970,12 +2066,13 @@ Show help for the prefix, infix or suffix command represented by
For prefixes, show the info manual, if that is specified using the
@code{info-manual} slot. Otherwise, show the manpage if that is specified
-using the @code{man-page} slot. Otherwise, show the command's doc string.
+using the @code{man-page} slot. Otherwise, show the command's
+documentation string.
-For suffixes, show the command's doc string.
+For suffixes, show the command's documentation string.
For infixes, show the manpage if that is specified. Otherwise show
-the command's doc string.
+the command's documentation string.
@end defun
@node Prefix Slots
@@ -2000,14 +2097,27 @@ remains active/transient when a suffix or arbitrary non-suffix
command is invoked. @xref{Transient State}.
@item
+@code{refresh-suffixes} Normally suffix objects and keymaps are only setup
+once, when the prefix is invoked. Setting this to @code{t}, causes them to
+be recreated after every command. This is useful when using @code{:if...}
+predicates, and those need to be rerun for some reason. Doing this
+is somewhat costly, and there is a risk of losing state, so this is
+disabled by default and still considered experimental.
+
+@item
@code{incompatible} A list of lists. Each sub-list specifies a set of
mutually exclusive arguments. Enabling one of these arguments
causes the others to be disabled. An argument may appear in
-multiple sub-lists.
+multiple sub-lists. Arguments must me given in the same form as
+used in the @code{argument} or @code{argument-format} slot of the respective
+suffix objects, usually something like @code{--switch} or @code{--option=%s}. For
+options and @code{transient-switches} suffixes it is also possible to match
+against a specific value, as returned by @code{transient-infix-value},
+for example, @code{--option=one}.
@item
@code{scope} For some transients it might be necessary to have a sort of
-secondary value, called a “scope”. See @code{transient-define-prefix}.
+secondary value, called a ``scope''. See @code{transient-define-prefix}.
@end itemize
@anchor{Internal Prefix Slots}
@@ -2079,8 +2189,14 @@ It must contain the following %-placeholders:
@end itemize
@item
-@code{description} The description, either a string or a function that is
-called with no argument and returns a string.
+@code{description} The description, either a string or a function, which is
+called with zero or one argument (the suffix object), and returns a
+string.
+
+@item
+@code{face} Face used for the description. In simple cases it is easier
+to use this instead of using a function as @code{description} and adding
+the styling there. @code{face} is appended using @code{add-face-text-property}.
@item
@code{show-help} A function used to display help for the suffix. If
@@ -2169,8 +2285,10 @@ function that takes the object as the only argument and which
returns a prompt string.
@item
-@code{choices} A list of valid values. How exactly that is used depends on
-the class of the object.
+@code{choices} A list of valid values, or a function that returns such a
+list. The latter is not implemented for @code{transient-switches}, because
+I couldn't think of a use-case. How exactly the choices are used
+varies depending on the class of the suffix.
@end itemize
@anchor{Slots of @code{transient-variable}}
@@ -2221,6 +2339,10 @@ what happens if you use more than one.
@code{if-not-derived} Enable if major-mode does not derive from value.
@end itemize
+By default these predicates run when the prefix command is invoked,
+but this can be changes, using the @code{refresh-suffixes} prefix slot.
+See @ref{Prefix Slots}.
+
One more slot is shared between group and suffix classes, @code{level}. Like
the slots documented above, it is a predicate, but it is used for a
different purpose. The value has to be an integer between 1
@@ -2228,326 +2350,6 @@ and 7. @code{level} controls whether a suffix or a group should be
available depending on user preference.
@xref{Enabling and Disabling Suffixes}.
-@node Related Abstractions and Packages
-@chapter Related Abstractions and Packages
-
-@node Comparison With Prefix Keys and Prefix Arguments
-@section Comparison With Prefix Keys and Prefix Arguments
-
-While transient commands were inspired by regular prefix keys and
-prefix arguments, they are also quite different and much more complex.
-
-The following diagrams illustrate some of the differences.
-
-@itemize
-@item
-@samp{(c)} represents a return to the command loop.
-@item
-@samp{(+)} represents the user's choice to press one key or another.
-@item
-@samp{@{WORD@}} are possible behaviors.
-@item
-@samp{@{NUMBER@}} is a footnote.
-@end itemize
-
-@anchor{Regular Prefix Commands}
-@subheading Regular Prefix Commands
-
-@xref{Prefix Keys,,,elisp,}.
-
-@example
- ,--> command1 --> (c)
- |
-(c)-(+)-> prefix command or key --+--> command2 --> (c)
- |
- `--> command3 --> (c)
-@end example
-
-@anchor{Regular Prefix Arguments}
-@subheading Regular Prefix Arguments
-
-@xref{Prefix Command Arguments,,,elisp,}.
-
-@example
- ,----------------------------------,
- | |
- v |
-(c)-(+)---> prefix argument command --(c)-(+)-> any command --> (c)
- | ^ |
- | | |
- `-- sets or changes --, ,-- maybe used --' |
- | | |
- v | |
- prefix argument state |
- ^ |
- | |
- `-------- discards --------'
-@end example
-
-@anchor{Transients}
-@subheading Transients
-
-(∩`-´)⊃━☆゚.*・。゚
-
-This diagram ignores the infix value and external state:
-
-@example
-(c)
- | ,- @{stay@} ------<-,-<------------<-,-<---,
-(+) | | | |
- | | | | |
- | | ,--> infix1 --| | |
- | | | | | |
- | | |--> infix2 --| | |
- v v | | | |
- prefix -(c)-(+)-> infix3 --' ^ |
- | | |
- |---------------> suffix1 -->--| |
- | | |
- |---------------> suffix2 ----@{1@}------> @{exit@} --> (c)
- | |
- |---------------> suffix3 -------------> @{exit@} --> (c)
- | |
- `--> any command --@{2@}-> @{warn@} -->--|
- | |
- |--> @{noop@} -->--|
- | |
- |--> @{call@} -->--'
- |
- `------------------> @{exit@} --> (c)
-@end example
-
-This diagram takes the infix value into account to an extend, while
-still ignoring external state:
-
-@example
-(c)
- | ,- @{stay@} ------<-,-<------------<-,-<---,
-(+) | | | |
- | | | | |
- | | ,--> infix1 --| | |
- | | | | | | |
- | | ,--> infix2 --| | |
- v v | | | | |
- prefix -(c)-(+)-> infix3 --' | |
- | | ^ |
- | | | |
- |---------------> suffix1 -->--| |
- | | ^ | |
- | | | | |
- |---------------> suffix2 ----@{1@}------> @{exit@} --> (c)
- | | ^ | |
- | | | | v
- | | | | |
- |---------------> suffix3 -------------> @{exit@} --> (c)
- | | ^ | |
- | sets | | v
- | | maybe | |
- | | used | |
- | | | | |
- | | infix --' | |
- | `---> value | |
- | ^ | |
- | | | |
- | hides | |
- | | | |
- | `--------------------------<---|
- | | |
- `--> any command --@{2@}-> @{warn@} -->--| |
- | | |
- |--> @{noop@} -->--| |
- | | |
- |--> @{call@} -->--' ^
- | |
- `------------------> @{exit@} --> (c)
-@end example
-
-This diagram provides more information about the infix value
-and also takes external state into account.
-
-@example
- ,----sets--- "anything"
- |
- v
- ,---------> external
- | state
- | | |
- | initialized | ☉‿⚆
- sets from |
- | | maybe
- | ,----------' used
- | | |
-(c) | | v
- | ,- @{stay@} --|---<-,-<------|-----<-,-<---,
-(+) | | | | | | |
- | | | v | | | |
- | | ,--> infix1 --| | | |
- | | | | | | | | |
- | | | | v | | | |
- | | ,--> infix2 --| | | |
- | | | | ^ | | | |
- v v | | | | | | |
- prefix -(c)-(+)-> infix3 --' | | |
- | | ^ | ^ |
- | | | v | |
- |---------------> suffix1 -->--| |
- | | | ^ | | |
- | | | | v | |
- |---------------> suffix2 ----@{1@}------> @{exit@} --> (c)
- | | | ^ | | |
- | | | | | | v
- | | | | v | |
- |---------------> suffix3 -------------> @{exit@} --> (c)
- | | | ^ | |
- | sets | | | v
- | | initialized maybe | |
- | | from used | |
- | | | | | |
- | | `-- infix ---' | |
- | `---> value -----------------------------> persistent
- | ^ ^ | | across
- | | | | | invocations -,
- | hides | | | |
- | | `----------------------------------------------'
- | | | |
- | `--------------------------<---|
- | | |
- `--> any command --@{2@}-> @{warn@} -->--| |
- | | |
- |--> @{noop@} -->--| |
- | | |
- |--> @{call@} -->--' ^
- | |
- `------------------> @{exit@} --> (c)
-@end example
-
-@itemize
-@item
-@samp{@{1@}} Transients can be configured to be exited when a suffix command
-is invoked. The default is to do so for all suffixes except for
-those that are common to all transients and which are used to
-perform tasks such as providing help and saving the value of the
-infix arguments for future invocations. The behavior can also be
-specified for individual suffix commands and may even depend on
-state.
-
-@item
-@samp{@{2@}} Transients can be configured to allow the user to invoke
-non-suffix commands. The default is to not allow that and instead
-warn the user.
-@end itemize
-
-Despite already being rather complex, even the last diagram leaves out
-many details. Most importantly it implies that the decision whether
-to remain transient is made later than it actually is made (for the
-most part a function on @code{pre-command-hook} is responsible). But such
-implementation details are of little relevance to users and are
-covered elsewhere.
-
-@node Comparison With Other Packages
-@section Comparison With Other Packages
-
-@anchor{Magit-Popup}
-@subheading Magit-Popup
-
-Transient is the successor to Magit-Popup (@pxref{Top,,,magit-popup,}).
-
-One major difference between these two implementations of the same
-ideas is that while Transient uses transient keymaps and embraces the
-command-loop, Magit-Popup implemented an inferior mechanism that does
-not use transient keymaps and that instead of using the command-loop
-implements a naive alternative based on @code{read-char}.
-
-Magit-Popup does not use classes and generic functions and defining a
-new command type is near impossible as it involves adding hard-coded
-special-cases to many functions. Because of that only a single new
-type was added, which was not already part of Magit-Popup's initial
-release.
-
-A lot of things are hard-coded in Magit-Popup. One random example is
-that the key bindings for switches must begin with @code{-} and those for
-options must begin with @code{=}.
-
-@anchor{Hydra}
-@subheading Hydra
-
-Hydra (see @uref{https://github.com/abo-abo/hydra}) is another package that
-provides features similar to those of Transient.
-
-Both packages use transient keymaps to make a set of commands
-temporarily available and show the available commands in a popup
-buffer.
-
-A Hydra “body” is equivalent to a Transient “prefix” and a Hydra
-“head” is equivalent to a Transient “suffix”. Hydra has no equivalent
-of a Transient “infix”.
-
-Both hydras and transients can be used as simple command dispatchers.
-Used like this they are similar to regular prefix commands and prefix
-keys, except that the available commands are shown in the popup buffer.
-
-(Another package that does this is @code{which-key}. It does so automatically
-for any incomplete key sequence. The advantage of that approach is
-that no additional work is necessary; the disadvantage is that the
-available commands are not organized semantically.)
-
-Both Hydra and Transient provide features that go beyond simple
-command dispatchers:
-
-@itemize
-@item
-Invoking a command from a hydra does not necessarily exit the hydra.
-That makes it possible to invoke the same command again, but using a
-shorter key sequence (i.e., the key that was used to enter the hydra
-does not have to be pressed again).
-
-Transient supports that too, but for now this feature is not a focus
-and the interface is a bit more complicated. A very basic example
-using the current interface:
-
-@lisp
-(transient-define-prefix outline-navigate ()
- :transient-suffix 'transient--do-stay
- :transient-non-suffix 'transient--do-warn
- [("p" "previous visible heading" outline-previous-visible-heading)
- ("n" "next visible heading" outline-next-visible-heading)])
-@end lisp
-
-@item
-Transient supports infix arguments; values that are set by infix
-commands and then consumed by the invoked suffix command(s).
-
-To my knowledge, Hydra does not support that.
-@end itemize
-
-Both packages make it possible to specify how exactly the available
-commands are outlined:
-
-@itemize
-@item
-With Hydra this is often done using an explicit format string, which
-gives authors a lot of flexibility and makes it possible to do fancy
-things.
-
-The downside of this is that it becomes harder for a user to add
-additional commands to an existing hydra and to change key bindings.
-
-@item
-Transient allows the author of a transient to organize the commands
-into groups and the use of generic functions allows authors of
-transients to control exactly how a certain command type is
-displayed.
-
-However while Transient supports giving sections a heading it does
-not currently support giving the displayed information more
-structure by, for example, using box-drawing characters.
-
-That could be implemented by defining a new group class, which lets
-the author specify a format string. It should be possible to
-implement that without modifying any existing code, but it does not
-currently exist.
-@end itemize
-
@node FAQ
@appendix FAQ
@@ -2559,10 +2361,10 @@ Yes, see @code{transient-display-buffer-action} in @ref{Configuration}.
@anchor{How can I copy text from the popup buffer?}
@appendixsec How can I copy text from the popup buffer?
-To be able to mark text in any transient popup buffer using the mouse,
-you have to add the following binding. Note that the region won't be
-visualized, while doing so. After you have quit the transient popup,
-you will be able to yank it another buffer.
+To be able to mark text in Transient's popup buffer using the mouse,
+you have to add the below binding. Note that for technical reasons,
+the region won't be visualized, while doing so. After you have quit
+the transient popup, you will be able to yank it in another buffer.
@lisp
(keymap-set transient-predicate-map
@@ -2570,6 +2372,16 @@ you will be able to yank it another buffer.
#'transient--do-stay)
@end lisp
+@anchor{How does Transient compare to prefix keys and universal arguments?}
+@appendixsec How does Transient compare to prefix keys and universal arguments?
+
+See @uref{https://github.com/magit/transient/wiki/Comparison-with-prefix-keys-and-universal-arguments}.
+
+@anchor{How does Transient compare to Magit-Popup and Hydra?}
+@appendixsec How does Transient compare to Magit-Popup and Hydra?
+
+See @uref{https://github.com/magit/transient/wiki/Comparison-with-other-packages}.
+
@anchor{Why did some of the key bindings change?}
@appendixsec Why did some of the key bindings change?
@@ -2589,14 +2401,14 @@ bindings. The bindings that do use a prefix do so to avoid wasting
too many non-prefix bindings, keeping them available for use in
individual transients. The bindings that do not use a prefix and that
are @strong{not} grayed out are very important bindings that are @strong{always}
-available, even when invoking the “common command key prefix” or @strong{any
+available, even when invoking the ``common command key prefix'' or @strong{any
other} transient-specific prefix. The non-prefix keys that @strong{are} grayed
out however, are not available when any incomplete prefix key sequence
-is active. They do not use the “common command key prefix” because it
+is active. They do not use the ``common command key prefix'' because it
is likely that users want to invoke them several times in a row and
e.g., @kbd{M-p M-p M-p} is much more convenient than @kbd{C-x M-p C-x M-p C-x M-p}.
-You may also have noticed that the “Set” command is bound to @kbd{C-x s},
+You may also have noticed that the ``Set'' command is bound to @kbd{C-x s},
while Magit-Popup used to bind @kbd{C-c C-c} instead. I have seen several
users praise the latter binding (sic), so I did not change it
willy-nilly. The reason that I changed it is that using different
@@ -2632,7 +2444,7 @@ for @kbd{q}.
If you want to get @kbd{q}'s old binding back then you can do so. Doing
that is a bit more complicated than changing a single key binding, so
I have implemented a function, @code{transient-bind-q-to-quit} that makes the
-necessary changes. See its doc string for more information.
+necessary changes. See its documentation string for more information.
@node Keystroke Index
@appendix Keystroke Index
diff --git a/doc/misc/url.texi b/doc/misc/url.texi
index 6d8ed2995bf..db717633faf 100644
--- a/doc/misc/url.texi
+++ b/doc/misc/url.texi
@@ -896,8 +896,8 @@ Creates a cache file name from @var{url} using MD5 hashing.
This is creates entries with very few cache collisions and is fast.
@cindex MD5
@smallexample
-(url-cache-create-filename-using-md5 "http://www.example.com/foo/bar")
- @result{} "/home/fx/.url/cache/fx/http/com/example/www/b8a35774ad20db71c7c3409a5410e74f"
+(url-cache-create-filename-using-md5 "https://www.example.com/foo/bar")
+ @result{} "/home/fx/.url/cache/fx/https/com/example/www/b8a35774ad20db71c7c3409a5410e74f"
@end smallexample
@end defun
@@ -906,8 +906,8 @@ Creates a cache file name from @var{url} more obviously connected to
@var{url} than for @code{url-cache-create-filename-using-md5}, but
more likely to conflict with other files.
@smallexample
-(url-cache-create-filename-human-readable "http://www.example.com/foo/bar")
- @result{} "/home/fx/.url/cache/fx/http/com/example/www/foo/bar"
+(url-cache-create-filename-human-readable "https://www.example.com/foo/bar")
+ @result{} "/home/fx/.url/cache/fx/https/com/example/www/foo/bar"
@end smallexample
@end defun
@@ -1083,16 +1083,18 @@ This is a regular expression that matches the shell prompt.
@defopt socks-server
This specifies the default server, it takes the form
@w{@code{("Default server" @var{server} @var{port} @var{version})}}
-where @var{version} can be either 4 or 5.
+where @var{version} can be 4, 4a, or 5.
@end defopt
@defvar socks-password
If this is @code{nil} then you will be asked for the password,
otherwise it will be used as the password for authenticating you to
-the @sc{socks} server.
+the @sc{socks} server. You can often set this to @code{""} for
+servers on your local network.
@end defvar
@defvar socks-username
This is the username to use when authenticating yourself to the
-@sc{socks} server. By default this is your login name.
+@sc{socks} server. By default, this is your login name. In versions
+4 and 4a, ERC uses this for the @samp{ID} field.
@end defvar
@defvar socks-timeout
This controls how long, in seconds, to wait for responses from the
@@ -1149,40 +1151,6 @@ If this variable is non-@code{nil} new network connections are never
opened by the URL library.
@end defvar
-@c @node Broken hostname resolution
-@c @subsection Broken Hostname Resolution
-
-@c @cindex hostname resolver
-@c @cindex resolver, hostname
-@c Some C libraries do not include the hostname resolver routines in
-@c their static libraries. If Emacs was linked statically, and was not
-@c linked with the resolver libraries, it will not be able to get to any
-@c machines off the local network. This is characterized by being able
-@c to reach someplace with a raw ip number, but not its hostname
-@c (@url{http://129.79.254.191/} works, but
-@c @url{https://www.cs.indiana.edu/} doesn't). This used to happen on
-@c SunOS4 and Ultrix, but is now probably now rare. If Emacs can't be
-@c rebuilt linked against the resolver library, it can use the external
-@c @command{nslookup} program instead.
-
-@c @defopt url-gateway-broken-resolution
-@c @cindex @code{nslookup} program
-@c @cindex program, @code{nslookup}
-@c If non-@code{nil}, this variable says to use the program specified by
-@c @code{url-gateway-nslookup-program} program to do hostname resolution.
-@c @end defopt
-
-@c @defopt url-gateway-nslookup-program
-@c The name of the program to do hostname lookup if Emacs can't do it
-@c directly. This program should expect a single argument on the command
-@c line---the hostname to resolve---and should produce output similar to
-@c the standard Unix @command{nslookup} program:
-@c @example
-@c Name: www.cs.indiana.edu
-@c Address: 129.79.254.191
-@c @end example
-@c @end defopt
-
@node History
@section History
@@ -1263,8 +1231,6 @@ the @file{*URL-DEBUG*} buffer.
A number means log all messages and show them with @code{message}.
It may also be a list of the types of messages to be logged.
@end defopt
-@defopt url-personal-mail-address
-@end defopt
@defopt url-privacy-level
@end defopt
@defopt url-lastloc-privacy-level
diff --git a/doc/misc/use-package.texi b/doc/misc/use-package.texi
index 5aad1bd8b84..d834e1be754 100644
--- a/doc/misc/use-package.texi
+++ b/doc/misc/use-package.texi
@@ -451,7 +451,7 @@ docstring of @code{system-type} for other valid values.
@item
Window system
-The example below loads a package only on macOS and X. See the
+The example below loads a package only on macOS and X@. See the
docstring of @code{window-system} for valid values.
@lisp
@@ -940,7 +940,7 @@ Examples:
Remapping of commands with @code{:bind} and @code{bind-key} works as
expected, because when the binding is a vector, it is passed straight
to @code{define-key}. @xref{Remapping Commands,,, elisp, GNU Emacs
-Lisp Reference Manual}), for more information about command remapping.
+Lisp Reference Manual}, for more information about command remapping.
For example, the following declaration will rebind
@code{fill-paragraph} (bound to @kbd{M-q} by default) to
@code{unfill-toggle}:
@@ -1554,8 +1554,11 @@ The standard Emacs package manager is documented in the Emacs manual
(@pxref{Package Installation,,, emacs, GNU Emacs Manual}). The
@code{use-package} macro provides the @code{:ensure} and @code{:pin}
keywords that interface with that package manager to automatically
-install packages. This is particularly useful if you use your init
-file on more than one system.
+install packages. The @code{:vc} keyword may be used to control how
+package sources are downloaded; e.g., from remote hosts
+(@pxref{Fetching Package Sources,,, emacs, GNU Emacs Manual}). This
+is particularly useful if you use your init file on more than one
+system.
@menu
* Install package::
@@ -1607,6 +1610,49 @@ packages:
You can override the above setting for a single package by adding
@w{@code{:ensure nil}} to its declaration.
+@findex :vc
+The @code{:vc} keyword can be used to control how packages are
+downloaded and/or installed. More specifically, it allows one to fetch
+and update packages directly from a version control system. This is
+especially convenient when wanting to install a package that is not on
+any package archive.
+
+The keyword accepts the same arguments as specified in
+@pxref{Fetching Package Sources,,, emacs, GNU Emacs Manual}, except
+that a name need not explicitly be given: it is inferred from the
+declaration. The accepted property list is augmented by a @code{:rev}
+keyword, which has the same shape as the @code{REV} argument to
+@code{package-vc-install}. Notably -- even when not specified --
+@code{:rev} defaults to checking out the last release of the package.
+You can use @code{:rev :newest} to check out the latest commit.
+
+For example,
+
+@example
+@group
+(use-package bbdb
+ :vc (:url "https://git.savannah.nongnu.org/git/bbdb.git"
+ :rev :newest))
+@end group
+@end example
+
+would try -- by invoking @code{package-vc-install} -- to install the
+latest commit of the package @code{foo} from the specified remote.
+
+This can also be used for local packages, by combining it with the
+@code{:load-path} (@pxref{Load path}) keyword:
+
+@example
+@group
+;; Use a local copy of BBDB instead of the one from GNU ELPA.
+(use-package bbdb
+ :vc t
+ :load-path "/path/to/bbdb/dir/")
+@end group
+@end example
+
+The above dispatches to @code{package-vc-install-from-checkout}.
+
@node Pinning packages
@section Pinning packages using @code{:pin}
@cindex installing package from specific archive
diff --git a/doc/misc/vtable.texi b/doc/misc/vtable.texi
index a4f2ed29d93..dd5b70cf32f 100644
--- a/doc/misc/vtable.texi
+++ b/doc/misc/vtable.texi
@@ -554,12 +554,19 @@ the object after this object; otherwise append to @var{table}. This
also updates the displayed table.
@end defun
-@defun vtable-update-object table object old-object
-Change @var{old-object} into @var{object} in @var{table}. This also
-updates the displayed table.
+@defun vtable-update-object table object &optional old-object
+Update @var{object}'s representation in @var{table}. Optional argument
+@var{old-object}, if non-@code{nil}, means to replace @var{old-object}
+with @var{object} and redisplay the associated row in the table. In
+either case, if the existing object is not found in the table (being
+compared with @code{equal}), signal an error.
This has the same effect as calling @code{vtable-remove-object} and
then @code{vtable-insert-object}, but is more efficient.
+
+Note a limitation: if the table's buffer is not in a visible window, or
+if its window has changed width since it was updated, updating the table
+is not possible, and an error is signaled.
@end defun
@defun vtable-column table index
diff --git a/doc/translations/README b/doc/translations/README
new file mode 100644
index 00000000000..02edb829dcf
--- /dev/null
+++ b/doc/translations/README
@@ -0,0 +1,211 @@
+* Translating the Emacs manuals
+
+** Copyright assignment
+
+People who contribute translated documents should provide a copyright
+assignment to the Free Software Foundation. See the "Copyright
+Assignment" section in the Emacs manual.
+
+
+** Translated documents license
+
+The translated documents are distributed under the same license as the
+original documents: the GNU Free Documentation License, Version 1.3 or
+any later version published by the Free Software Foundation.
+
+See https://www.gnu.org/licenses/fdl-1.3.html for more information.
+
+If you have any questions regarding the use of the FDL license in your
+translation work that do not appear in the FAQ, feel free to contact the
+GNU project.
+
+See https://www.gnu.org/contact/ for more information.
+
+** Location of the translated files
+
+*** Texinfo source files
+
+The source files of the translated manuals are located in the
+doc/translations directory, under the sub-directory corresponding to the
+translated language.
+
+ E.g., French manual sources are found under doc/translations/fr.
+
+The structure of each language's folder should match that of the English
+manuals (i.e. include misc, man, lispref, lispintro, emacs).
+
+*** Built files
+
+Translated deliverables in Info format are built at release time and are
+made available for local installation.
+
+
+** Source files format
+
+The manuals and their translations are written in the Texinfo format
+(with the exception of the org-mode manual, which is written in Org, and
+illustrations for the Introduction to Emacs Lisp Programming, which are
+EPS files).
+
+See https://www.gnu.org/software/Texinfo/ for more information.
+
+You must install the Texinfo package in order to verify the translated
+files, and refer to the Texinfo manual for information on the various
+Texinfo features.
+
+Emacs has a Texinfo mode that highlights the parts of the Texinfo code
+to be translated for easy reference.
+
+
+*** Texinfo specific issues
+
+Until the Emacs/Texinfo projects provide better solutions, here are a
+few rules to follow:
+
+- Under each @node, add an @anchor that has the same content as the
+ original English @node.
+
+- Translate the @node content but leave the @anchor in English.
+
+- Most Emacs manuals are set to include the docstyle.Texi file. This
+ file adds the "@documentencoding UTF-8" directive to the targeted
+ manual. There is no need to add this directive in a manual that
+ includes docstyle.texi.
+
+- Add a @documentlanguage directive that includes your language.
+
+ E.g., @documentlanguage zh
+
+This directive currently has little effect but will be useful in the
+future.
+
+- The @author directive can be used for the translator's name.
+
+ E.g., @author traduit en français par Achile Talon
+
+
+** Fixing the original document
+
+During the course of the translation, you might encounter passages in
+the original document that need to be updated or otherwise corrected, or
+even run into a bug in Emacs. If you cannot immediately correct the
+problem, please file a bug report promptly.
+
+See the 'Bugs' section in the Emacs manual.
+
+** Sending your contributions
+
+Send your contributions (files or revisions) for review to the Emacs
+development list at emacs-devel@gnu.org. Subscribing to the list is not
+obligatory.
+
+Always send contributions in the format of the original document. Most
+of the content in the Emacs manuals is in Texinfo format, so please do
+not send contributions in derivative formats (e.g. info, html, docbook,
+plain text, etc.)
+
+Before sending files for review, please ensure that they have been
+thoroughly checked for spelling/grammar/typography by at least using the
+tools provided by Emacs.
+
+Please also make sure that the Texinfo files build properly on your
+system.
+
+Send your contributions as patches (git diff -p --stat), and prefer the
+git format-patch form, since that format allows for easier review and
+easier installation of the changes by the persons with write access to
+the repository.
+
+The Emacs project has a lot of coding, documentation and commenting
+conventions. Sending such patches allows the project managers to make
+sure that the contributions comply with the various conventions.
+
+
+** Discussing translation issues
+
+Translation-related discussions are welcome on the emacs development
+list. Discussions specific to your language do not have to be in
+English.
+
+
+** Translation teams
+
+The number of words in the Emacs manuals is over 2,000,000 words and
+growing. While one individual could theoretically translate all the
+files, it is more practical to work in language teams.
+
+If you have a small group of translators willing to help, please make
+sure that the files are properly reviewed before sending them to the
+Emacs development list (see above).
+
+Please refer to the translation-related documents maintained by the GNU
+Project, and contact your language translation team to learn the
+practices they have developed over the years.
+
+See https://www.gnu.org/server/standards/README.translations.html for
+more information.
+
+
+** Translation processes
+
+Emacs does not yet provide tools that significantly help the translation
+process. A few useful functions would be:
+
+- automatic lookup of a list of glossary items when starting to work on
+ a translation "unit" (paragraph or otherwise); such glossary terms
+ should be easily insertable at point,
+
+- automatic lookup of past translations to check for similarity and
+ improve homogeneity over the whole document set; such past translation
+ matches should be easily insertable at point, etc.
+
+
+*** Using the PO format as an intermediate translation format
+
+Although the PO format has not been developed with documentation in
+mind, it is well-known among free software translation teams, and you
+can easily use the po4a utility to convert Texinfo to PO for work in
+translation tools that support the PO format.
+
+See https://po4a.org for more information.
+
+However, regardless of the intermediate file format that you might use,
+you should only send files in the original format (Texinfo, org-mode,
+eps) for review and installation.
+
+
+*** Free tools that you can use in your processes
+
+A number of free software tools are available outside the Emacs project,
+to help translators (both amateur and professional) in the translation
+process.
+
+If they have any features that you think Emacs should implement, you are
+welcome to provide patches to the Emacs project.
+
+Such tools include:
+
+- the GNOME Translation Editor, https://wiki.gnome.org/Apps/Gtranslator/
+- KDE's Lokalize, https://apps.kde.org/lokalize/
+- OmegaT, https://omegat.org
+- the Okapi Framework, https://www.okapiframework.org
+- pootle, https://pootle.translatehouse.org
+
+etc.
+
+
+* Licence of this document
+
+Copyright (C) 2024 Free Software Foundation, Inc.
+
+Copying and distribution of this file, with or without modification, are
+permitted in any medium without royalty provided the copyright notice
+and this notice are preserved. This file is offered as-is, without any
+warranty.
+
+
+Local Variables:
+mode: outline
+paragraph-separate: "[ ]*$"
+coding: utf-8
+End:
diff --git a/doc/translations/fr/misc/ses-fr.texi b/doc/translations/fr/misc/ses-fr.texi
new file mode 100644
index 00000000000..e1b9cac5fc3
--- /dev/null
+++ b/doc/translations/fr/misc/ses-fr.texi
@@ -0,0 +1,1631 @@
+\input texinfo @c -*- mode: texinfo; coding: utf-8; -*-
+@c %**start of header
+@setfilename ../../../../info/ses-fr.info
+@documentlanguage fr
+@documentencoding UTF-8
+@settitle @acronym{SES}: Le tableur simple d’Emacs
+@include docstyle.texi
+@setchapternewpage off
+@syncodeindex fn cp
+@syncodeindex vr cp
+@syncodeindex ky cp
+@c %**end of header
+
+@copying
+Ce fichier documente @acronym{SES} : le tableur simple d’Emacs (Simple
+Emacs Spreadsheet).
+
+Copyright @copyright{} 2002--2024 Free Software Foundation, Inc.
+
+@quotation
+Permission is granted to copy, distribute and/or modify this document
+under the terms of the GNU Free Documentation License, Version 1.3 or
+any later version published by the Free Software Foundation; with no
+Invariant Sections, with the Front-Cover Texts being ``A GNU Manual,''
+and with the Back-Cover Texts as in (a) below. A copy of the license
+is included in the section entitled ``GNU Free Documentation License.''
+
+(a) The FSF's Back-Cover Text is: ``You have the freedom to copy and
+modify this GNU manual.''
+@end quotation
+@end copying
+
+@dircategory Emacs misc features
+@direntry
+* @acronym{SES}-fr: (ses-fr). Le tableur simple d’Emacs.
+@end direntry
+
+@finalout
+
+@titlepage
+@title @acronym{SES}
+@subtitle Le tableur simple d’Emacs
+@author Jonathan A. Yavner
+@author @email{jyavner@@member.fsf.org}
+
+@page
+@vskip 0pt plus 1filll
+@insertcopying
+@end titlepage
+
+@contents
+
+@c ===================================================================
+
+@ifnottex
+@node Top
+@comment node-name, next, previous, up
+@top @acronym{SES}: Simple Emacs Spreadsheet
+
+@display
+@acronym{SES} est mode majeur de GNU Emacs pour éditer des fichiers
+tableur, c.-à-d.@: des fichiers contenant une grille rectangulaire de
+cellules. Les valeurs des cellules sont spécifiées par des formules
+pouvant se référer aux valeurs d’autres cellules.
+@end display
+@end ifnottex
+
+Pour les rapports d’anomalie, utiliser @kbd{M-x report-emacs-bug}.
+
+@insertcopying
+
+@menu
+* Boniment: Sales Pitch. Pourquoi utiliser @acronym{SES}?
+* Tuto: Quick Tutorial. Une introduction sommaire
+* Les bases: The Basics. Les commandes de base du tableur
+* Fonctions avancées: Advanced Features. Vous voulez en savoir plus ?
+* Pour les gourous: For Gurus. Vous voulez en savoir @emph{encore plus} ?
+* Index: Index. Index des concepts, fonctions et variables
+* Remerciements: Acknowledgments. Remerciements
+* Licence GNU pour la documentation libre: GNU Free Documentation License. La licence de cette documentation.
+@end menu
+
+@c ===================================================================
+
+@node Sales Pitch
+@comment node-name, next, previous, up
+@chapter Boniment
+@cindex features
+
+@itemize --
+@item Créer et éditer des feuilles de calcul avec un minimum de tracas.
+@item Prise en charge complète du Défaire/Refaire/Sauvegarde auto.
+@item Protection contre les virus enfouis dans les feuilles de calcul.
+@item Les formules de cellule sont directement du code Emacs Lisp.
+@item Fonctions d’impression pour contrôler l’apparence des cellules.
+@item Raccourcis clavier intuitifs : C-o = insérer une ligne, M-o = insérer une colonne, etc.
+@item « Débordement » des valeurs de cellule longues dans les cellules vides suivantes.
+@item La ligne d’en-tête montre les lettres désignant les colonnes.
+@item Autocomplétion pour la saisie des symboles de cellules nommées lors de la saisie des formules.
+@item Couper, copier et coller peut transferer les formules et les fonctions d’impression.
+@item Import and export de valeurs séparées par des tabulations, ou de formules séparées par des tabulations.
+@item Format de fichier en texte, facile à bidouiller.
+@end itemize
+
+@c ===================================================================
+
+@node Quick Tutorial
+@chapter Tuto
+@cindex introduction
+@cindex tuto
+
+Si vous désirez être rapidement lancé et pensez que vous savez ce que
+vous attendez d’un tableur simple, alors ce chapitre peut être tout ce
+dont vous avez besoin.
+
+Premièrement, visitez un nouveau fichier avec pour extension de nom de
+fichier @file{.ses}. Emacs vous présente alors une feuille de calcul
+vide contenant une seule cellule.
+
+Commencez par saisir une ligne d’en-tête : @kbd{"Revenu@key{RET}}. Le
+guillemet double @code{"} indique que vous saisissez une cellule
+textuelle, il ne fait pas partie de la valeur de la cellule, et aucun
+guillemet de fermeture n’est nécessaire.
+
+Pour insérer votre première valeur de revenu, vous devez d’abord
+redimensionner la feuille. Appuyer sur la touche @key{TAB} pour
+ajouter une nouvelle cellule et revenez à elle en remontant.
+Saisissez un nombre, tel que @samp{2.23}. Puis continuer pour ajouter
+quelques valeurs supplémentaires de revenu, par ex. :
+
+@example
+@group
+A
+ Revenu
+ 2.23
+ 0.02
+ 15.76
+ -4.00
+@end group
+@end example
+
+Pour additionner les valeurs entre elles, saisissez une expression
+Lisp :
+
+@example
+(+ A2 A3 A4 A5)
+@end example
+
+Peut-être désirez vous ajouter une cellule à la droite de la cellule
+@samp{A4} pour expliquer pourquoi vous avez une valeur négative. En
+appuyant sur @kbd{TAB} dans cette cellule vous ajouter entièrement une
+nouvelle colonne @samp{B} où vous pourrez ajouter une telle note.
+
+La colonne est assez étroite par défaut, mais en appuyant sur @kbd{w}
+vous pouvez la redimensionner selon vos besoins. Faites la de 22
+caractères de large. Vous pouvez maintenant ajoutez des notes
+descriptives pour chacune des cases, par ex.@: :
+
+@example
+@group
+A B
+ Revenu
+ 2.23 Frais de consultation
+ 0.02 Opinion informée
+ 15.76 Stand limonade
+ -4 Prêt à Joseph
+ 14.01 Total
+@end group
+@end example
+
+Par défaut, l’impression des valeurs de cellule se fait alignée à
+droite, c’est la raison d’un tel alignement pour les notes dans la
+colonne @samp{B}. Pour changer cela, vous pouvez saisir une fonction
+d’impression pour la colonne entière, en utilisant par ex. @kbd{M-p
+("%s")}. Le fait que @code{"%s"} soit contenu dans une liste indique à
+@acronym{SES} que l’alignement est à faire à gauche. Vous pouvez
+l’emporter sur la fonction d’impression de colonne pour l’une
+quelconque de ses cellules en donnant une fonction d’impression par
+cellule avec @kbd{p}.
+
+Vous pouvez nommer une fonction d’impression, et utiliser le nom de la
+fonction à la place de sa définition, de sorte à faciliter la
+modification de l’impression de toutes les cellules utilisant cette
+fonction. Par exemple tapez @kbd{M-x
+ses-define-local-printer@key{ret}}, puis @kbd{note@key{ret}}, puis
+@kbd{("%s")} pour définir une fonction d’impression nommée @code{note}
+dont la définition est @code{("%s")}, puis sur la colonne @samp{B} tapez
+@kbd{M-p note@key{ret}}
+
+@example
+@group
+A B
+ Revenu
+ 2.23 Frais de consultation
+ 0.02 Opinion informée
+ 15.76 Stand limonade
+ -4 Prêt à Joseph
+ 14.01 Total
+@end group
+@end example
+
+Si maintenant vous redéfinissez @code{note} avec pour nouvelle
+définition @kbd{("*%s")} qui ajoute un astérisque @code{*} devant le
+texte, la zone d’impression est modifiée ainsi :
+@example
+@group
+A B
+ Revenu
+ 2.23 *Frais de consultation
+ 0.02 *Opinion informée
+ 15.76 *Stand limonade
+ -4 *Prêt à Joseph
+ 14.01 *Total
+@end group
+@end example
+
+Notez que la cellule @samp{B1} reste affichée vide et n’est pas
+affichée comme @samp{*}. C’est parce que la valeur de la cellule est
+@code{nil}, et que les fonctions d’impression définies à partir d’une
+chaîne de formatage comme @code{"%s"} dans @code{("%s")} impriment
+systématiquement @code{nil} comme une chaîne vide, et tentent
+d’imprimer toute valeur non-@code{nil} en utilisant la fonction
+standarde @code{format} avec la chaîne de formatage, et si cela
+échoue, utilisent la fonction de repli @code{ses-prin1} la place.
+
+Si maintenant Joseph rembourse son prêt, vous pourriez effacer cette
+case ; par ex.@: en positionnant le curseur sur la cellule A5 et en
+appuyant sur @kbd{C-d}. Si vous faites celle le total imprimé dans la
+cellule A6 affichera @samp{######}. La raison de cela est la valeur
+dans une cellule vide est typiquement @code{nil} et que l’opérateur
+@code{+} ordinaire échoue à gérer une telle valeur. Au lieu de vider
+la cellule, vous pourriez littéralement saisir @samp{0}, ou supprimer
+entièrement la ligne en utilisant @kbd{C-k}. Une alternative est
+d’utiliser la fonction spéciale @code{ses+} au lieu du @code{+}
+ordinaire :
+
+@example
+(ses+ A2 A3 A4 A5)
+@end example
+
+Pour rendre une formule robuste au changement de géométrie de la
+feuille, vous pouvez utiliser la macro @code{ses-range} pour faire
+référence à une plage de cellules par ses extrémités, par ex. :
+
+@example
+(apply 'ses+ (ses-range A2 A5))
+@end example
+
+(Le @code{apply} est nécessaire parce que @code{ses-range} produite
+une @emph{liste} de valeurs, ce qui ouvre des possibilités plus
+complexes).
+
+Alternativement vous pouvez utiliser le modificateur @code{!} de
+@code{ses-range} pour retirer les cellules vides de la liste renvoyée,
+ce qui permet d’utiliser @code{+} au lieu de @code{ses+}:
+
+@lisp
+(apply '+ (ses-range A2 A5 !))
+@end lisp
+
+@c ===================================================================
+
+@node The Basics
+@comment node-name, next, previous, up
+@chapter Les bases
+@cindex commandes de base
+@cindex base, commandes de
+@findex ses-jump
+@findex ses-mark-row
+@findex ses-mark-column
+@findex ses-mark-whole-buffer
+@findex set-mark-command
+@findex keyboard-quit
+
+Pour créer une nouveau tableur, visitez un fichier inexistant dont le
+nom se termine en @file{.ses}. Par exemple, @kbd{C-x C-f essai.ses
+@key{ret}}.
+
+
+Un @dfn{identificateur de cellule} est un symbole avec une lettre de
+colonne et un numéro de ligne. La cellule B7 est la 2e column de la
+7e ligne. Pour les feuilles très larges, il ya deux lettres de
+colonne : la cellule AB7 les la 28e colonne de la 7e ligne. Les
+feuilles encore plus larges ont AAA1, etc. On se déplace avec les
+commandes ordinaires de déplacement d’Emacs.
+
+@table @kbd
+@item j
+Déplace le point vers la cellule spécifiée par identificateur
+(@code{ses-jump}). À moins que la cellule ne soit une cellule
+renommée, l’identificateur est insensible à la casse. Un argument
+préfixe @math{n} déplace vers la cellule de coordonnées @math{(n\div
+R, n \% C)} pour une feuille de @math{R} ligne et @math{C} colonnes,
+et @samp{A1} étant aux coordonnées @math{(0,0)}. La façon dont
+l’identificateur ou l’argument préfixe de commande sont interprétés
+peut être personnalisée via les variables
+@code{ses-jump-cell-name-function} et @code{ses-jump-prefix-function}.
+@end table
+
+Le Point est toujours sur le bord de gauche d’une cellule, ou à la fin
+de ligne vide. Quand la marque est inactive, la cellule courante est
+soulignée. Quand la marque est active, la plage est le rectangle de
+cellules mis en vedette (@acronym{SES} utilise toujours le mode de
+marque transitoire). Faire glisser la souris de @samp{A1} à @samp{A3}
+crée la plage @samp{A1-A2}. Beaucoup de commandes @acronym{SES}
+opèrent seulement sur une seule cellule, et non sur une plage.
+
+@table @kbd
+@item C-@key{SPC}
+@itemx C-@@
+Règle la marque au point (@code{set-mark-command}).
+
+@item C-g
+Désactive la marque (@code{keyboard-quit}).
+
+@item M-h
+Met en vedette la ligne courante (@code{ses-mark-row}).
+
+@item S-M-h
+Met en vedette la colonne courante (@code{ses-mark-column}).
+
+@item C-x h
+Mettre en vedette toutes les cellules (@code{mark-whole-buffer}).
+@end table
+
+@menu
+* Formules: Formulas.
+* Redimensionner: Resizing.
+* Fonctions d’impression: Printer functions.
+* Effacer des cellules: Clearing cells.
+* Copier/couper/coller: Copy/cut/paste.
+* Personnaliser @acronym{SES}: Customizing @acronym{SES}.
+@end menu
+
+@node Formulas
+@section Formules de cellule
+@cindex formules
+@cindex formules, saisire
+@cindex valeurs
+@cindex valeurs de cellule
+@cindex éditer des cellules
+@findex ses-read-cell
+@findex ses-read-symbole
+@findex ses-edit-cell
+@findex ses-recalculate-cell
+@findex ses-recalculate-all
+
+Pour insérer une valeur dans une cellule, tapez juste une expression
+numérique, un @samp{"texte entre guillemets anglais"}, ou une
+expression Lisp.
+
+@table @kbd
+@item 0..9
+Auto-insérer un nombre (@code{ses-read-cell}).
+
+@item -
+Auto-insérer un nombre négatif (@code{ses-read-cell}).
+
+@item .
+Auto-insérer un nombre décimal (@code{ses-read-cell}).
+
+@item "
+Auto-insérer une chaîne de caractères. Le guillemet anglais de
+terminaison est inséré automatiquement (@code{ses-read-cell}).
+
+@item (
+Auto-insérer une expression. La parenthèse de droite est insérée
+automatiquement (@code{ses-read-cell}). Pour accéder à la valeur
+d’une autre cellule, il suffit d’utiliser son identificateur dans
+votre expression. Dès que l’autre cellule change, la formule de cette
+cellule-ci est réévaluée. En tapant l’expression, vous pouvez
+utiliser les raccourcis clavier suivants :
+@table @kbd
+@item M-@key{TAB}
+pour compléter les noms de symboles, et
+@item C-h C-n
+pour lister les symboles de cellules renommées dans un tampon d’aide.
+@end table
+
+@item ' @r{(apostrophe)}
+Entrer un symbole (@code{ses-read-symbol}). @acronym{SES} se souvient
+de tous les symboles qui ont été utilisés comme formules, de sorte que
+vous pouvez taper juste le début d’un symbole et utiliser
+@kbd{@key{SPC}}, @kbd{@key{TAB}}, et @kbd{?} pour le compléter.
+@end table
+
+Pour saisire quelque-chose d’autre (par ex., un vecteur), commencer
+avec un chiffre, puis effacer le chiffre et tapez ce que vous désirez.
+
+@table @kbd
+@item @key{RET}
+Édite la formule existante dans la cellule courante (@code{ses-edit-cell}).
+
+@item C-c C-c
+Force le recalcul de la cellule ou plage courante (@code{ses-recalculate-cell}).
+
+@item C-c C-l
+Recalcule la feuille entière (@code{ses-recalculate-all}).
+@end table
+
+@node Resizing
+@section Redimensionner la feuille
+@cindex redimensionner des feuilles
+@cindex dimensions
+@cindex ligne, ajout ou suppression
+@cindex colonne, ajout ou suppression
+@cindex ajouter des lignes ou colonnes
+@cindex insérer des lignes ou colonnes
+@cindex enlever des lignes ou colonnes
+@cindex supprimer des lignes ou colonnes
+@findex ses-insert-row
+@findex ses-insert-column
+@findex ses-delete-row
+@findex ses-delete-column
+@findex ses-set-column-width
+@findex ses-forward-or-insert
+@findex ses-append-row-jump-first-column
+
+
+Commande de base :
+
+@table @kbd
+@item C-o
+(@code{ses-insert-row})
+
+@item M-o
+(@code{ses-insert-column})
+
+@item C-k
+(@code{ses-delete-row})
+
+@item M-k
+(@code{ses-delete-column})
+
+@item w
+(@code{ses-set-column-width})
+
+@item @key{TAB}
+Déplace le point sur la prochaine cellule vers la droite, ou insère
+une nouvelle colonne si on est déjà sur la dernière cellule de la
+ligne, ou insère une nouvelle ligne si on est sur la ligne de
+terminaison (@code{ses-forward-or-insert}).
+
+@item C-j
+Insère une nouvelle ligne sous la ligne courante et va à la colonne A
+de cette ligne (@code{ses-append-row-jump-first-column}).
+@end table
+
+En redimensionnant la feuille (à moins que vous ne fassiez que changer
+la largeur d’une colonne) les références de cellule au sein des
+formules sont toutes relocalisées de sorte à continuer à faire
+référence aux mêmes cellules. Si une formule mentionne B1 et que vous
+insérez une nouvelle première ligne, alors la formule mentionnera B2.
+
+Si vous supprimez une cellule à laquelle une formule fait référence,
+le symbole de cellule est supprimé de la formule, de sorte que
+@code{(+ A1 B1 C1)} après suppression de la troisième colonne devient
+@code{(+ A1 B1)}. Au cas où cela ne serait pas ce que vous désiriez :
+
+@table @kbd
+@item C-_
+@itemx C-x u
+Défait l’action action précédente (@code{(undo)}).
+@end table
+
+
+@node Printer functions
+@section Fonctions d’impression
+@cindex fonctions d’impression
+@cindex formatage de cellule
+@cindex cellules, formater
+
+Les fonctions d’impression convertissent des valeurs binaires de
+cellule en formes d’impression qu’Emacs affiche à l’écran.
+
+@menu
+* Différents types de fonctions d’impression: Various kinds of printer functions.
+* Configurer quelle fonction d’impression s’applique: Configuring what printer function applies.
+* Les fonctions d’impression standardes: Standard printer functions.
+* Les fonctions d’impression locales: Local printer functions.
+* Écrire une fonctions d’impression lambda: Writing a lambda printer function.
+@end menu
+
+@node Various kinds of printer functions
+@subsection Différents types de fonctions d’impression
+
+Lorsque on configure quelle fonction d’impression s’applique
+(@pxref{Configuring what printer function applies}), on peut saisir
+une fonction d’impression comme l’une des possibilités suivantes :
+
+@itemize
+@item
+Une chaîne de formatage, telle que @samp{"$%.2f"}. la chaîne formatée
+résultante est alignée à droite au sein de la cellule
+d’impression. Pour obtenir un alignement à gauche, utilisez des
+parenthèses : @samp{("$%.2f")}.
+@item
+Une fonction d’impression peut aussi être une fonction à un argument
+dont la valeur renvoyée est une chaîne (pour obtenir un alignement à
+droite) ou une liste d’une chaîne (pour obtenir un alignement à
+gauche). Une telle fonction peut à son tour être configurée comme :
+@itemize
+@item
+Une expression lambda, par exemple :
+
+@lisp
+(lambda (x)
+ (cond
+ ((null x) "")
+ ((numberp x) (format "%.2f" x))
+ (t (ses-center-span x ?# 'ses-prin1))))
+@end lisp
+
+Pendant la saisie d’une lambda, vous pouvez utiliser @kbd{M-@key{TAB}}
+pour completer les noms de symboles.
+@item
+Un symbole faisant référence à une fonction d’impression standarde
+(@pxref{Standard printer functions}).
+@item
+Un symbole faisant référence à une fonction d’impression locale
+(@pxref{Local printer functions}).
+@end itemize
+
+
+@end itemize
+
+
+@node Configuring what printer function applies
+@subsection Configurer quelle fonction d’impression s’applique
+
+Chaque cellule a une fonction d’impression. Si c’est @code{nil},
+alors la fonction d’impression de la colonne de cette cellule est
+utilisée. Et si cela est aussi @code{nil}, alors la fonction
+d’impression par défaut de la feuille est utilisée.
+
+@table @kbd
+@item p
+@findex ses-read-cell-printer
+Saisit une fonction d’impression pour la cellule ou plage courante
+(@code{ses-read-cell-printer}).
+
+@item M-p
+@findex ses-read-column-printer
+Saisit une fonction d’impression pour la colonne courante (@code{ses-read-column-printer}).
+
+@item C-c C-p
+@findex ses-read-default-printer
+Saisit la fonction d’impression par défaut de la feuille
+(@code{ses-read-default-printer}).
+@end table
+
+Les commandes @code{ses-read-@var{xxx}-printer} permettent les commandes
+suivantes pendant l’édition:
+
+@table @kbd
+@item @key{arrow-up}
+@itemx @key{arrow-down}
+Pour parcourir l’historique : les commandes
+@code{ses-read-@var{xxx}-printer} ont leur propre historique de
+mini-tampon, il est préchargé avec l’ensemble de toutes les fonctions
+d’impression utilisées dans cette feuille, plus les fonctions
+d’impression standardes (@pxref{Standard printer functions}) et les
+fonctions d’impression locales (@pxref{Local printer functions}).
+@item @key{TAB}
+Pour compléter les symboles de fonctions d’impression locales, et
+@item C-h C-p
+Pour lister les fonctions d’impression locales dans un tampon d’aide.
+@end table
+
+
+@node Standard printer functions
+@subsection Les fonctions d’impression standardes
+
+
+Mise à part @code{ses-prin1}, les autres fonctions d’impression
+standardes ne conviennent que pour les cellules, et non pour les
+colonnes ou comme fonction d’impression par défaut de la feuille,
+parce qu’elles formatent la valeur en utilisant la fonction
+d’impression de colonne (ou par défaut si @code{nil}) et ensuite
+post-traite le résultat, par ex.@: le centre :
+
+@ftable @code
+@item ses-center
+Centre juste.
+
+@item ses-center-span
+Centrer en débordant sur les cellules vides suivantes.
+
+@item ses-dashfill
+Centrer en utilisant des tirets (@samp{-}) au lieu d’espaces.
+
+@item ses-dashfill-span
+Centrer avec tirets et débordement.
+
+@item ses-tildefill-span
+Centrer avec tildes (@samp{~}) et débordement.
+
+@item ses-prin1
+C’est la fonction d’impression de repli, utilisée quand l’appel à la
+fonction d’impression configurée envoie une erreur.
+@end ftable
+
+@node Local printer functions
+@subsection Les fonctions d’impression locales
+
+@findex ses-define-local-printer
+Vous pouvez définir une fonction d’impression locale à la feuille avec
+la commande @code{ses-define-local-printer}. Par exemple, définissez
+une fonction d’impression @samp{toto} à @code{"%.2f"}, et ensuite
+utilisez le symbole @samp{toto} comme fonction d’impression. Ensuite,
+si vous rappelez @code{ses-define-local-printer} sur @samp{toto} pour
+le redéfinir comme @code{"%.3f"}, alors toutes les cellules utilisant
+la fonction d’impression @samp{toto} seront re-imprimées conformément.
+
+Il peut arriver que vous désiriez définir ou redéfinir certaines
+fonctions d’impression à chaque fois que vous ouvrez une feuille. Par
+exemple, imaginez que vous désiriez définir/re-définir automatiquement
+une fonction d’impression locale @code{euro} pour afficher un nombre
+comme une somme en euros, par exemple le nombre @code{3.1} serait
+affiché comme @code{3.10@dmn{}@euro{}}. Pour faire cela dans tout
+tampon SES qui n’est pas en lecture seule, vous pouvez ajouter ce
+genre de code à votre fichier d’init @file{.emacs} :
+
+@lisp
+(defun my-ses-mode-hook ()
+ (unless buffer-read-only
+ (ses-define-local-printer
+ 'euro
+ (lambda (x)
+ (cond
+ ((null x) "")
+ ((numberp x) (format "%.2f€" x))
+ (t (ses-center-span x ?# 'ses-prin1)))))))
+(add-hook 'ses-mode-hook 'my-ses-mode-hook)
+@end lisp
+
+Si vous remplacez la commande @code{ses-define-local-printer} par la
+fonction @code{ses-define-if-new-local-printer}
+@findex ses-define-if-new-local-printer
+la définition ne se produira que si aucune fonction d’impression de
+même nom n’est déjà définie.
+
+
+@node Writing a lambda printer function
+@subsection Écrire une fonctions d’impression lambda
+
+Vous pouvez écrire une fonction d’impression avec une expression
+lambda prenant un seul argument en deux cas :
+
+@itemize
+@item
+quand vous configurez la fonction d’impression s’appliquant à
+une cellule ou colonne, ou
+@item
+quand vous définissez une fonction d’impression avec la commande
+@code{ses-define-local-printer}.
+@end itemize
+
+En faisant cela, prenez garde à ce que la valeur renvoyée soit une
+chaîne, ou une liste contenant une chaîne, même quand l’argument
+d’entrée a une valeur inattendue. Voici un exemple :
+
+@example
+(lambda (val)
+ (cond
+ ((null val) "")
+ ((and (numberp val) (>= val 0)) (format "%.1f" val))
+ (t (ses-center-span val ?# 'ses-prin1))))
+@end example
+
+Cet exemple fait ceci :
+
+@itemize
+@item
+Quand la cellule est vide (c.-à-d.@: quand @code{val} est @code{nil}),
+imprime une chaîne vide @code{""}
+@item
+Quand la valeur de cellule est un nombre positif ou nul, formate la
+valeur en notation à virgule fixe avec une decimale après la virgule
+@item
+Sinon, gère la valeur comme erronnée en l’imprimant comme une
+s-expression (avec @code{ses-prin1}), centrée et entourée de
+croisillons @code{#} de bourrage.
+@end itemize
+
+Une autre précaution à prendre est d’éviter un débordement de pile à
+cause d’une fonction d’impression se rappelant elle-même sans
+fin. Cette erreur peut se produire quand vous utilisez une fonction
+d’impression locale comme fonction d’impression de colonne, et que
+cette fonction d’impression locale appelle implicitement la fonction
+d’impression de colonne courante, ainsi elle se rappelle elle-même
+récursivement. Imaginez par exemple que vous désirez créer une
+fonction d’impression locale @code{=bourre} qui centre le contenu
+imprimé d’une cellule et l’entoure de signes égal @code{=}, et que
+vous le faites (erronnément) comme cela :
+
+@lisp
+;; CODE ERRONÉ
+(lambda (x)
+ (cond
+ ((null x) "")
+ (t (ses-center x 0 ?=))))
+@end lisp
+
+Comme @code{=bourre} utilise la fonction d’impression standarde
+@code{ses-center} mais sans lui passer exemplicitement une fonction
+d’impression, @code{ses-center} appelle la fonction d’impression de
+colonne courante s’il y en a une, ou la fonction d’impression par
+défaut de la feuille sinon. Aussi, utiliser @code{=bourre} comme
+fonction d’impression de colonne aura pour résultat de causer un
+débordement de pile dans cette colonne sur toute cellule non vide,
+puisque @code{ses-center} rappelle récursivement la fonction qui l'a
+appelé. @acronym{SES} ne vérifie pas cela ; il vous faut donc faire
+attention. Par exemple, reécrivez @code{=bourre} ainsi :
+
+@lisp
+(lambda (x)
+ (cond
+ ((null x) "")
+ ((stringp x) (ses-center x 0 ?= " %s "))
+ (t (ses-center-span x ?# 'ses-prin1))))
+@end lisp
+
+Le code ci-dessus est réparé au sens où @code{ses-center} et
+@code{ses-center-span} sont toutes deux appelées avec un dernier
+argument @var{printer} explicite spécifiant la fonction d'impression,
+respectivement @code{" %s "} et @code{'ses-prin1}.
+
+
+Le code ci-dessus applique le bourrage de @code{=} seulement aux
+chaînes ; et aussi il entoure la chaîne par un espace de chaque côté
+avant de bourrer avec des signes @code{=}. Ainsi la chaîne @samp{Ula}
+s’affichera comme @samp{@w{=== Ula ===}} dans une colonne large de 11
+caractères. Toute valeur qui n’est ni @code{nil} (c.-à-d.@: une
+cellule vide) ni une chaîne est affichée comme une erreur par l’usage
+de bourrage par des croisillons @code{#}.
+
+@node Clearing cells
+@section Effacer des cellules
+@cindex effacer, commandes
+@findex ses-clear-cell-backward
+@findex ses-clear-cell-forward
+
+Ces commandes règlent à la fois la formule et la fonction d’impression
+à @code{nil} :
+
+@table @kbd
+@item @key{DEL}
+Se deplace à gauche et efface la cellule (@code{ses-clear-cell-backward}).
+
+@item C-d
+Efface la cellule et se déplace à droite (@code{ses-clear-cell-forward}).
+@end table
+
+
+@node Copy/cut/paste
+@section Copier, couper, et coller
+@cindex copier
+@cindex couper
+@cindex coller
+@findex kill-ring-save
+@findex mouse-set-region
+@findex mouse-set-secondary
+@findex ses-kill-override
+@findex yank
+@findex clipboard-yank
+@findex mouse-yank-at-click
+@findex mouse-yank-at-secondary
+@findex ses-yank-pop
+
+Les fonctions de copie opèrent sur des regions rectangulaires de
+cellules. Vous pouvez coller les copies dans des tampons
+non-@acronym{SES} pour exporter le texte d’impression.
+
+@table @kbd
+@item M-w
+@itemx [copy]
+@itemx [C-insert]
+Copie les cellules en vedette vers l’anneau presse-papier et le
+presse-papier primaire (@code{kill-ring-save}).
+
+@item [drag-mouse-1]
+Marque une region et la copie vers l’anneau presse-papier et le
+presse-papier primaire (@code{mouse-set-region}).
+
+@item [M-drag-mouse-1]
+Marque une region et la copie vers l’anneau presse-papier et le
+presse-papier secondaire (@code{mouse-set-secondary}).
+
+@item C-w
+@itemx [cut]
+@itemx [S-delete]
+Les fonctions couper ne suppriment pas en fait de lignes ou de
+colonnes --- elles les copient et puis les effacent
+(@code{ses-kill-override}).
+
+@item C-y
+@itemx [S-insert]
+Colle à partir de l’anneau presse-papier (@code{yank}). Les fonctions
+coller se comportent différemment selon le format du texte qu’elles
+insèrent :
+@itemize @bullet
+@item
+Quand on colle des cellules qui ont été coupées ou copiées à partir
+d’un tampon @acronym{SES}, le texte d’impression est ignoré et
+seulement la formule et fonction d’impression jointes sont insérées ;
+les références de cellule de la formule sont relocalisées à moins que
+vous n’utilisiez @kbd{C-u}.
+@item
+Le texte collé écrase un rectangle de cellules dont le coin haut
+gauche est la cellule courante. Si une partie du rectangle est
+au-délà des bords de la feuille, vous devez confirmer l’augmentation
+de la taille de la feuille.
+@item
+Du texte Non-@acronym{SES} est d’ordinaire inséré comme formule de
+remplacement pour la cellule courante. Si la formule serait un
+symbole, elle est traitée comme une chaîne à moins que vous
+n’utilisiez @kbd{C-u}. Les formules collées comprenant des erreurs de
+syntaxe sont toujours traitées comme des chaînes.
+@end itemize
+
+@item [paste]
+Colle à partir du presse-papier primaire ou de l’anneau presse-papier
+(@code{clipboard-yank}).
+
+@item [mouse-2]
+Règle le point et colle à partir du presse-papier primaire
+(@code{mouse-yank-at-click}).
+
+@item [M-mouse-2]
+Règle le point et colle à partir du presse-papier secondaire
+(@code{mouse-yank-secondary}).
+
+@item M-y
+Immédiatement après un coller, vous pouvez remplacer le texte avec un
+élément précédent à partir de l’anneau presse-papier
+(@code{ses-yank-pop}). Contrairement au yank-pop standard d’Emacs, la
+version de @acronym{SES} utilise @code{undo} pour supprimer l’ancien
+collage. Est-ce que cela ne fait aucune différence ?
+@end table
+
+@node Customizing @acronym{SES}
+@section Personnaliser @acronym{SES}
+@cindex personnaliser
+@vindex enable-local-eval
+
+Par défaut, une feuille venant d’être créée a 1 ligne et 1 colonne.
+La largeur de colonne est 7 et la fonction d’impression par défaut est
+@samp{"%.7g"}. Chacune de ces choses peut être personnalisée. Allez
+voir dans le groupe « ses ».
+
+Après avoir saisi une valeur de cellule, normalement
+@code{forward-char} est appelé, ce qui déplace le point vers la
+cellule suivante à droite, ou à la première cellule à gauche de la
+ligne suivante si la cellule courante est la plus à droite de la
+feuille. Vous pouvez personnaliser @code{ses-after-entry-functions}
+pour que le déplacement soit vers la gauche ou le haut ou le bas.
+Pour un mouvement diagonal, selectionnez deux fonctions de la liste.
+
+@vindex ses-jump-cell-name-function
+@code{ses-jump-cell-name-function} est une variable personnalisable
+réglée par défaut à la fonction @code{upcase}. Cette fonction est
+appelée quand vous passez un nom de cellule à la commande
+@command{ses-jump} (@kbd{j}), et que ce nom n’est pas le nom d’une
+cellule renommée. Elle change le nom de cellule saisi en celui de la
+cellule vers laquelle sauter. Le réglage par défaut @code{upcase} vous
+permet de saisir le nom de cellule en bas de casse. Un autre usage de
+@code{ses-jump-cell-name-function} pourrait être une
+internationalisation pour convertir des caractères non latins en
+équivalents latins pour nommer la cellule. Au lieu d’un nom de
+cellule, la fonction peut renvoyer des coordonnées de cellule sous la
+forme d’un cons, par exemple @code{(0 . 0)} pour la cellule @code{A1},
+@code{(1 . 0)} pour la cellule @code{A2}, etc.
+
+@vindex ses-jump-prefix-function
+@code{ses-jump-prefix-function} est une variable personnalisable
+réglée par défaut à la fonction @code{ses-jump-prefix}. Cette fonction
+est appelée quand vous donnez un argument préfixe à la commande
+@command{ses-jump} (@kbd{j}). Elle renvoie un nom de cellule ou des
+coordonnées de cellule correspondant à l’argument préfixe. Les
+coordonnées de cellule sont sous la forme d’un cons, par exemple
+@code{(1 . 0)} pour la cellule @code{A2}. Le réglage par défaut
+@code{ses-jump-prefix} numérote les cellules de gauche à droite et
+puis de haut en bas, de sorte que si on suppose une feuille 4×3,
+l’argument préfixe @samp{0} saute à la cellule @samp{A1}, l’argument
+préfixe @samp{2} saute à @samp{C1}, l’argument préfixe @samp{3} saute
+à @samp{A2}, etc.
+
+@vindex ses-mode-hook
+@code{ses-mode-hook} est un crochet de mode normal (une liste de
+fonctions qui s’exécutent quand le mode @acronym{SES} démarre sur un
+tampon).
+
+@vindex safe-functions
+La variable @code{safe-functions} est une liste de fonctions
+potentiellement risquées à traiter comme si elles étaient sûres lors
+de l’analyse des formules et fonctions d’impression. @xref{Virus
+protection}. Avant de personnaliser @code{safe-functions},
+réfléchissez à quel point vous faites confiance à la personne qui vous
+suggère cette modification. La valeur @code{t} désactive toute
+protection anti-virus. Une valeur donnant une liste-de-fonctions peut
+rendre une feuille « trop bien », mais elle crée aussi des portes
+dérobées dans votre armure anti-virus. Pour que votre protection
+contre les virus fonctionne, vous devez toujours appuyer sur @kbd{n}
+quand un avertissement contre un virus vous est présenté, à moins que
+vous compreniez ce que le code en question essaie de faire. N’écoutez
+pas ceux qui vous racontent de personnaliser @code{enable-local-eval}
+--- cette variable est pour les gens qui ne portent pas de ceinture de
+sécurité !
+
+
+@c ===================================================================
+
+@node Advanced Features
+@chapter Fonctions avancées
+@cindex avancées, fonctions
+@findex ses-read-header-row
+
+
+@table @kbd
+@item C-c M-C-h
+(@code{ses-set-header-row}).
+@findex ses-set-header-row
+@kindex C-c M-C-h
+La ligne d’en-tête au sommet de la fenêtre @acronym{SES} affiche
+normalement la ligne de colonne pour chaque colonne. Vous pouvez la
+régler pour afficher une copie de l’une des lignes, tell que qu’une
+ligne de titres de colonnes, ainsi cette ligne sera toujours visible.
+Par défaut la commande règle la ligne courante comme en-tête ;
+utiliser C-u pour une invite à désigner la ligne d’en-têre. Régler la
+ligne d’en-tête à la ligne 0 pour afficher les lettres de colonne de
+nouveau.
+@item [header-line mouse-3]
+Affiche un menu pour régler la ligne courante comme en-tête, ou
+revenir à des lettres de colonne.
+@item M-x ses-rename-cell
+@findex ses-rename-cell
+Renomme une cellule pour passer d'un nom standard du genre de A1 à
+toute chaîne pouvant être un nom valide pour une variable locale (Voir
+aussi @ref{Nonrelocatable references}).
+@item M-x ses-repair-cell-reference-all
+@findex ses-repair-cell-reference-all
+Quand vous interrompez la mise à jour d’une formule de cellule en
+tapant @kbd{C-g}, alors cela peut casser le lien de référence de
+cellule, ce qui compromet la mise à jour automatique de cellule quand
+toute autre cellule dont elle dépend est modifiée. Pour réparer cela,
+utilisez la fonction @code{ses-repair-cell-reference-all}
+@end table
+
+@menu
+* La zone d’impression: The print area.
+* Plages dans les formules: Ranges in formulas.
+* Trier par colonne: Sorting by column.
+* Fonctions de formule standardes: Standard formula functions.
+* Plus sur l’impression de cellule: More on cell printing.
+* Import et export: Import and export.
+* Protection contre les virus: Virus protection.
+* Feuilles avec détails et synthèse: Spreadsheets with details and summary.
+@end menu
+
+@node The print area
+@section La zone d’impression
+@cindex zone d’impression
+@cindex impression, zone d’
+@findex widen
+@findex ses-renarrow-buffer
+@findex ses-reprint-all
+
+Un fichier @acronym{SES} consiste en une zone d’impression et une zone
+de données. Normalement le tampon est réduit de sorte à n’afficher
+que la zone d’impression. La zone d’impression est en lecture seule,
+hormis pour les commandes spéciales de @acronym{SES} ; elle contient
+les valeurs de cellule formatées par les fonctions d’impression. La
+zone de données enregistre les formules, fonctions d’impression, etc.
+
+@table @kbd
+@item C-x n w
+Affiche à la fois les zones d’impression et de données (@code{widen}).
+
+@item C-c C-n
+Affiche seulement la zone d’impression (@code{ses-renarrow-buffer}).
+
+@item S-C-l
+@itemx M-C-l
+Recrée la zone d’impression en réévaluant pour toutes les cellules sa
+fonction d’impression (@code{ses-reprint-all}).
+@end table
+
+@node Ranges in formulas
+@section Plages dans les formules
+@cindex plages
+@findex ses-insert-plage-click
+@findex ses-insert-plage
+@findex ses-insert-ses-plage-click
+@findex ses-insert-ses-plage
+@vindex de
+@vindex à
+
+Une formule du genre de :
+@lisp
+(+ A1 A2 A3)
+@end lisp
+est la somme de trois cellules spécifiques. Si vous insérez une
+nouvelle deuxième ligne, la formule devient
+@lisp
+(+ A1 A3 A4)
+@end lisp
+et la nouvelle ligne n’est pas incluse dans la somme.
+
+La macro @code{(ses-range @var{de} @var{à})} s’évalue en une liste des
+valeurs dans un rectangle de cellules. Si votre formule est
+@lisp
+(apply '+ (ses-range A1 A3))
+@end lisp
+et que vous insérez une nouvelle deuxième ligne, elle devient
+@lisp
+(apply '+ (ses-range A1 A4))
+@end lisp
+et la nouvelle ligne est incluse dans la somme.
+
+Alors que vous saisissez ou éditez une formule dans le minitampon,
+vous pouvez sélectionner une plage dans la feuille (en utilisant la
+souris ou le clavier), et injecter une représentation de cette plage
+dans votre formule. Supposez que vous sélectionnez @samp{A1-C1} :
+
+@table @kbd
+@item [S-mouse-3]
+Insère @samp{A1 B1 C1} (@code{ses-insert-range-click})
+
+@item C-c C-r
+Version clavier (@code{ses-insert-range}).
+
+@item [C-S-mouse-3]
+Insère @samp{(ses-range A1 C1)} (@code{ses-insert-ses-range-click}).
+
+@item C-c C-s
+Version clavier (@code{ses-insert-ses-range}).
+@end table
+
+Si vous supprimez la cellule @var{de} ou @var{à} d’une plage, la
+cellule la plus proche toujours existante est utilisée à la place. Si
+vous supprimez l’entière plage, le relocalisateur de formule supprime
+le @samp{ses-range} de la formule.
+
+Si vous insérez une nouvelle ligne juste au delà de la fin d’une plage
+à une colonne, ou une nouvelle colonne juste au delà d’une plage à une
+ligne, la nouvelle cellule est incluse dans la plage. Les nouvelles
+cellules insérées juste avant une plage ne sont pas incluses.
+
+Des fanions peuvent être ajoutés à @code{ses-range} immédiatement
+après la cellule @var{à} .
+@table @code
+@item !
+Les cellules vides de la plage peuvent être enlevées en ajoutant le
+fanion @code{!}. Une cellule vide est une cellule dont la valeur est
+l’un des symboles @code{nil} ou @code{*skip*}. Par exemple
+@code{(ses-range A1 A4 !)} fait la même chose que @code{(list A1 A3)}
+quand les cellules @code{A2} et @code{A4} sont vides.
+@item _
+Les valeurs de cellules vides sont remplacées par l’argument suivant
+le fanion @code{_}, ou @code{0} quand le fanion @code{_} est le
+dernier dans la liste d’arguments. Par exemple @code{(ses-range A1 A4
+_ "vide")} fera la même chose que @code{(list A1 "vide" A3 "vide")}
+quand les cellules @code{A2} et @code{A4} sont vides. Similairement,
+@code{(ses-range A1 A4 _ )} fera la même chose que @code{(list A1 0 A3
+0)}.
+@item >v
+Quand l’ordre a de l’importance, liste les cellules en lisant les
+cellules ligne par ligne de la cellule en haut à gauche vers la
+cellule en bas à droite. Ce fanion est fourni pour être complet car
+c’est déjà l’ordre par défaut.
+@item <v
+Liste les cellules en lisant les cellules ligne par ligne de la
+cellule en haut à droite vers la cellule en bas à gauche.
+@item v>
+Liste les cellules en lisant les cellules colonne par colonne de la
+cellule en haut à gauche vers la cellule en bas à droite.
+@item v<
+Liste les cellules en lisant les cellules colonne par colonne de la
+cellule en haut à droite vers la cellule en bas à gauche.
+@item v
+Un raccourci pour @code{v>}.
+@item ^
+Un raccourci pour @code{^>}.
+@item >
+Un raccourci pour @code{>v}.
+@item <
+Un raccourci pour @code{>^}.
+@item *
+Au lieu de lister les cellules, en fait un vecteur ou une matrice Calc
+(@pxref{Top,,,calc,GNU Emacs Calc Manual}). Si la plage contient
+seulement une ligne ou une colonne un vecteur est fait, sinon une
+matrice est faite.
+@item *2
+Idem que @code{*} à ceci près qu’une matrice est toujours faite même
+quand il y a une seule ligne ou colonne dans la plage.
+@item *1
+Idem que @code{*} à ceci près qu’un vecteur est toujours fait même
+quand il n’y a qu’une ligne ou colonne dans la plage, c.-à-d.@: que la
+matrice correspondante est aplatie.
+@end table
+
+@node Sorting by column
+@section Trier par colonne
+@cindex trier
+@findex ses-sort-column
+@findex ses-sort-column-click
+
+@table @kbd
+@item C-c M-C-s
+Trie les cellules d’une plage en utilisant l’une des colonnes
+(@code{ses-sort-column}). Les lignes (ou lignes partielles si la
+plage n’inclut pas toutes les colonnes) sont réarrangées de sorte que
+la colonne choisie soit ordonnée.
+
+@item [header-line mouse-2]
+La façon la plus facile de trier est de cliquer sur mouse-2 sur la
+ligne d’en-tête de colonne (@code{ses-sort-column-click}).
+@end table
+
+La comparaison du tri utilise @code{string<}, ce qui fonctionne bien
+pour des nombres alignés à droite ou des chaînes alignées à gauche.
+
+Avec un argument préfixe, trie dans l’ordre descendant.
+
+Les lignes sont déplacées une à la fois, avec relocalisation des
+formules. Ceci fonctionne bien si les formules font référence à
+d’autres cellules dans leur ligne, mais non pas si bien pour des
+formules qui font référence à d’autres lignes dans la plage ou à des
+cellules hors de la plage.
+
+
+@node Standard formula functions
+@section Fonctions de formule standardes
+@cindex fonctions standardes de formule
+@cindex *skip*
+@cindex *error*
+@findex ses-delete-blanks
+@findex ses-average
+@findex ses+
+
+Souvent on désire qu’un calcul exclue les cellules vides. Voici
+quelques fonctions utiles à appeler dans vos formules :
+
+@table @code
+@item (ses-delete-blanks &rest @var{args})
+Renvoie une liste dont toutes les cellules vides (dont la valeur est
+soit @code{nil} ou @code{'*skip*}) ont été supprimées. L’ordre des
+arguments est inversé. Prière de noter que @code{ses-range} a un
+modificateur @code{!} qui permet de supprimer les cellules vides,
+ainsi il est possible d’écrire :
+@lisp
+(ses-range A1 A5 !)
+@end lisp
+au lieu de
+@lisp
+(apply 'ses-delete-blanks (ses-range A1 A5 <))
+@end lisp
+
+@item (ses+ &rest @var{args})
+Somme des arguments non vides pris en ordre inverse.
+
+@item (ses-average @var{liste})
+Moyenne des éléments non vides de @var{liste}. Ici la liste est
+passée comme un seul argument, vu que typiquement on la forme avec
+@code{ses-range}.
+@end table
+
+@node More on cell printing
+@section Plus sur l’impression de cellule
+@cindex cellule, plus sur l'impression
+@cindex impression de cellule
+@findex ses-truncate-cell
+@findex ses-recalculate-cell
+
+Valeurs spéciales de cellule :
+@itemize
+@item nil
+s’imprime typiquement de la même façon que "", mais permet que la
+cellule précédente déborde dessus.
+@item '*skip*
+remplace nil quand la cellule précédente déborde effectivement ; rien
+n’est donc imprimée pour cette cellule.
+@item '*error*
+indique que la formule a signalé une erreur au lieu de produire une
+valeur : la cellule imprimée est remplie de croisillons (#).
+@end itemize
+
+Lorsque la fonction d’impression est définie par une chaîne de
+formatage, par ex. @samp{"%.3f"}, @acronym{SES} imprime
+automatiquement @code{nil} comme une chaîne vide, mais si la fonction
+d’impression est définie par une expression lambda, vous devez définir
+explicitement comment @code{nil} est traité, par ex. :
+@example
+(lambda (x)
+ (cond
+ ((null x) "")
+ ((stringp x) (list x))
+ ((numberp x) (format "%.3f" x))
+ (t (ses-prin1 x)))
+@end example
+imprime @code{nil} comme une chaîne vide, aligne à gauche la valeur si
+c’est une chaîne, et si c’est un nombre l’aligne à droite en
+l’imprimant avec trois décimales.
+
+Il n’est pas nécessaire par contre que vous vous souciez de
+@code{'*skip*} dans la définition d’une fonction d’impression, en
+effet aucune fonction d’impression n’est appelée sur @code{'*skip*}.
+
+Si le résultat de la fonction d’impression est trop large pour la
+cellule et que la cellule suivante est @code{nil}, le résultat
+débordera sur la cellule suivante. Les résultats très larges peuvent
+déborder sur plusieurs cellules. Si le résultat est trop large pour
+l’espace disponible (jusqu'à la fin de la ligne ou la prochaine
+cellule non-@code{nil}), le résultat est tronqué si la valeur de
+cellule est une chaîne, ou remplacé par des croisillons (@samp{#})
+sinon.
+
+@acronym{SES} pourrait être perturbé par des résultats de fonction
+d'impression contenant des sauts de ligne ou des tabulations, aussi
+ces caractères sont remplacés par des points d'interrogation.
+
+@table @kbd
+@item t
+Confine une cellule à sa propre colonne (@code{ses-truncate-cell}).
+Ceci vous permet de déplacer le point sur la cellule de droite qui
+sinon serait couverte par un débordement. Si vous ne modifiez pas la
+cellule de droite, la cellule confinée débordera de nouveau la
+prochaine fois qu’elle sera imprimée.
+
+@item c
+Appliquée à une seule cellule, cette commande affiche dans la zone
+d’écho toute erreur de formule ou erreur d’impression survenue pendant
+le recalcul/la réimpression (@code{ses-recalculate-cell}). Vous
+pouvez utiliser cela pour défaire l’effet de @kbd{t}.
+@end table
+
+Quand une fonction d’impression signale une erreur, la fonction
+d’impression de repli
+@findex ses-prin1
+@code{ses-prin1} lui est substituée. Ceci est utile quand votre
+fonction d’impression de colonne est seulement numérique et que vous
+utilisez une chaîne comme valeur de cellule. Notez que la fonction
+d’impression par défaut standarde est @samp{"%.7g"} qui est numérique
+seulement, ainsi les cellules auxquelles la fonction d’impression par
+défaut standarde s’applique et qui ne sont pas vides et ne contiennent
+pas un nombre utilisent la fonction d’impression de repli
+@code{ses-prin1}, par ex.@: les cellules qui contiennent une chaîne
+font cela. @kbd{c} sur de telles cellules affiche « Format specifier
+doesn't match argument type ».
+
+
+@node Import and export
+@section Import et export
+@cindex import et export
+@cindex export, et import
+@findex ses-export-tsv
+@findex ses-export-tsf
+
+@table @kbd
+@item x t
+Exporte une plage de cellules comme des valeurs séparées par des
+tabulations (@code{ses-export-tsv}).
+@item x T
+Exporte une plage de cellules comme des formules séparées par des
+tabulations (@code{ses-export-tsf}).
+@end table
+
+Le texte exporté va dans l’anneau presse-papier ; vous pouvez le
+coller dans un autre tampon. Les colonnes sont séparées par des
+tabulations, les lignes par des sauts de lignes.
+
+Pour importer du texte, utilisez n’importe laquelle des commandes
+coller où le texte à coller contient des tabulations et/ou des sauts de
+lignes. Les formules importées ne sont pas relocalisées.
+
+@node Virus protection
+@section Protection contre les virus
+@cindex virus protection
+
+À chaque fois une formule ou fonction d’impression est lue d’un
+fichier ou est collée dans la feuille, elle est marquée comme
+« nécessitant une vérification de sécurité ». Plus tard, quand la
+formule ou la fonction d’impression est évaluée pour la première fois,
+elle est vérifiée comme sûre en utilisant le prédicat @code{unsafep} ;
+si elle s’avère « potentiellement risquée », la formule ou fonction
+d’impression en question est affichée et vous devez appuyer @kbd{Y}
+pour l’approuver ou @kbd{N} pour utiliser un substitut. Le substitut
+signale toujours une erreur.
+
+Les formules ou fonctions d’impression que vous tapez sont
+immédiatement vérifiées quant à leur sûreté. Si elles s’avèrent
+potentiellement risquées et que vous appuyez @kbd{N} pour refuser,
+l’action est annulée et l’ancienne formule ou fonction d’impression
+demeure.
+
+En plus des virus (qui tentent de se recopier dans d’autres
+fichiers), @code{unsafep} peut aussi détecter toutes sortes de chevaux
+de Troie, tels que des feuilles de calcul qui effacent les fichiers,
+envoient des courriels, inondent des sites Web, corrompent vos
+réglages d’Emacs, etc.
+
+Généralement, les formules et fonctions d’impression de feuilles sont
+des choses simples qui n’ont pas besoin de faire des traitements
+exotiques, aussi toute partie potentiellement dangereuse de
+l’environnement Emacs Lisp peut être exclus sans entraver votre style
+comme écrivain de formule. Lisez la documentation dans
+@file{unsafep.el} pour plus d’information sur la façon dont les formes
+Lisp sont classifiées comme sûres ou risquées.
+
+@node Spreadsheets with details and summary
+@section Feuilles avec détails et synthèse
+@cindex détails et synthèse
+@cindex synthèses, et détails
+
+Une organisation usuelle pour une feuille de calcul est d’avoir un tas
+de lignes de « détail », chacune décrivant possiblement une
+transaction, et ensuite un ensemble de lignes de « synthèse » qui
+affichent chacune des données condensées pour un certain sous-ensemble
+des détails. @acronym{SES} prend en charge ce type d’organisation via
+la fonction @code{ses-select}.
+
+@table @code
+@item (ses-select @var{de-plage} @var{test} @var{à-plage})
+Renvoie un sous-ensemble de @var{à-plage}. Pour chaque membre dans
+@var{de-plage} qui est égal à @var{test}, le membre correspondant de
+@var{à-plage} est inclus dans le résultat.
+@end table
+
+Exemple d’utilisation :
+@lisp
+(ses-average (ses-select (ses-range A1 A5) 'Bidochon (ses-range B1 B5)))
+@end lisp
+Ceci calcule la moyenne des valeurs de la colonne @samp{B} pour les
+lignes dont la valeur dans la colonne @samp{A} est le symbole
+@samp{'Bidochon}.
+
+Vous vous demandez peut-être pourquoi les arguments de
+@code{ses-select} ne consistent pas au lieu de @var{à-plage} de
+décalages @var{décalage-à-la-ligne} et @var{décalage-à-la-colonne}
+relativement à @var{de-plage} : spécifier @var{à-plage} explicitement
+assure que la formule est recalculée si l’une quelconque des cellules
+de cette plage est modifiée.
+
+Le fichier @file{etc/ses-example.el} dans la distribution Emacs est un
+exemple d’une feuille organisée en détails-et-synthèse.
+
+
+@c ===================================================================
+
+@node For Gurus
+@chapter Pour les gourous
+@cindex avancées, fonctions
+@cindex fonctions avancées
+
+@menu
+* Mises à jour différées: Deferred updates.
+* Références non-relocalisables: Nonrelocatable references.
+* La zone données: The data area.
+* Variables locales-tampon dans les feuilles: Buffer-local variables in spreadsheets.
+* Utilisation de advice-add dans @acronym{SES}: Uses of advice-add in @acronym{SES}.
+@end menu
+
+@node Deferred updates
+@section Mises à jour différées
+@cindex différées, mises à jour
+@cindex mises à jour différées
+@vindex run-with-idle-timer
+
+Pour épargner du temps de calcul redondant, les cellules dont le
+recalcul est rendu nécessaire par des changements dans d’autres
+cellules sont ajoutées à un ensemble. À la fin de la commande, chaque
+cellule de cet ensemble est recalculée une fois. Ceci peut créer un
+nouvel ensemble de cellules nécessitant un recalcul. Ce processus est
+répété jusqu'à ce que l’ensemble soit vide ou que des références
+circulaires soient détectées. Dans les cas extrêmes, et notamment si
+une référence circulaire est en cours de détection, vous pourriez voir
+des messages de progression de la forme « Recalculating... (@var{nnn}
+cells left) ». Si vous interrompez le calcul avec @kbd{C-g}, la
+feuille demeurera dans un état incohérent, utilisez alors @kbd{C-_} ou
+@kbd{C-c C-l} pour réparer cela.
+
+Pour épargner encore plus de temps en évitant les écritures
+redondantes, les cellules qui sont modifiées sont ajoutées à un
+ensemble au lieu d’être immédiatement écrites dans la zone de
+données. Chaque cellule de cet ensemble est écrite une fois à la fin
+de la commande. Si vous modifiez un grand nombre de cellules, vous
+pourriez voir un message de progression de la forme
+« Writing... (@var{nnn} cells left) ». Ces écritures différées de
+cellules ne peuvent pas être interrompues par @kbd{C-g}, alors il vous
+faudra juste attendre.
+
+@acronym{SES} utilise @code{run-with-idle-timer} pour déplacer le
+souligné de cellule quand Emacs fait défiler le tampon à la fin d’une
+commande, et aussi pour @c xxx narrow and underline
+réduire et souligner après visiter un fichier. Ceci peut être visible
+par une perturbation transitoire après visiter un fichier et certaines
+commandes de défilement. Vous pouvez continuer à taper sans vous
+inquiéter de cette perturbation.
+
+
+@node Nonrelocatable references
+@section Références non relocalisables
+@cindex non-relocalisables, références
+@cindex références non-relocalisables
+
+@kbd{C-y} relocalise toutes les références de cellule dans une formule
+collée, alors que @kbd{C-u C-y} n’en relocalise aucune. Et pour les
+cas mélangés ?
+
+La meilleure approche est de renommer les cellules que vous @emph{ne}
+voulez @emph{pas} être relocalisables en utilisant
+@code{ses-rename-cell}.
+@findex ses-rename-cell
+Les cellules qui n’ont pas un style de nom du genre de A1 ne sont pas
+relocalisées au collage. En utilisant cette méthode, les cellules
+concernées ne seront pas relocalisées quelle que soit la formule où
+elles apparaissent. Prière toutefois de noter que dans une formule
+contenant quelque plage @code{(ses-range @var{cell1} @var{cell2})}
+alors dans la formule collée chacune des bornes @var{cell1} et
+@var{cell2} de la plage est relocalisée, ou non, indépendemment, selon
+qu’elle est nommée du genre de @samp{A1} ou renommée.
+
+Une méthode alternative est d’utiliser
+@lisp
+(symbol-value 'B3)
+@end lisp
+pour faire une @dfn{référence absolue}. Le relocalisateur de formule
+saute par dessus tout ce qui est sous un @code{quote}, aussi cela ne
+sera pas relocalisé quand on le colle ou quand des lignes/colonnes
+sont insérées/supprimées. Toutefois, @samp{B3} ne sera pas
+enregistrée comme une dépendance de cette cellule, et donc cette
+cellule ne sera pas mise à jour automatiquement quand @samp{B3} est
+modifiée, c’est pourquoi l’usage de @code{ses-rename-cell} est la
+plupart du temps préférable.
+
+Les variables @code{row} et @code{col} sont liées dynamiquement
+pendant l’évaluation d’une formule de cellule. Vous pouvez utiliser
+@lisp
+(ses-cell-value row 0)
+@end lisp
+pour obtenir la valeur de la colonne la plus à gauche de la ligne
+courante. Ce type de dépendance n’est pas non plus enregistré.
+
+
+@node The data area
+@section La zone de données
+@cindex données, zone de
+@cindex zone de données
+@findex ses-reconstruct-all
+
+Commence avec un caractère saut de page (de code ASCII 014 en octal),
+suivi par un ensemble de macros de définition de cellule pour chaque
+ligne, suivi par l’ensemble des définitions de fonctions d’impression
+locales, suivi par les largeurs de colonnes, fonctions d’impression de
+colonne, fonction d’impression par défaut, et ligne d’en-tête. Ensuite
+il y a les paramètres globaux (ID de format fichier, nombre de lignes,
+nombre de colonnes, nombre de fonctions d’impression locales) et les
+variables locales (spécification du mode @acronym{SES} pour le tampon,
+etc.).
+
+Quand un fichier @acronym{SES} est chargé, tout d’abord les paramètres
+globaux sont chargés, puis l’ensemble de la zone de données est
+@code{eval}ué, et finalement les variables locales sont traitées.
+
+Vous pouvez éditer la zone de données, mais n’insérez pas ni ne
+supprimez de sauts de ligne, hormis dans la partie des variables
+locales, en effet @acronym{SES} localise les choses en comptant les
+sauts de ligne. Utilisez @kbd{C-x C-e} à la fin d’une ligne pour
+installer ce que vous avez édité dans les structures de données de la
+feuille (ceci ne met pas à jour la zone d’impression, utilisez, par
+ex., @kbd{C-c C-l} pour cela).
+
+La zone de données est maintenue comme une image des structures de
+données de la feuille stockée dans des variables locales tampon au
+moment du chargement initial de la zone. Si le contenu de la zone de
+données se trouve corrompu par la suite, vous pouvez essayer de
+reconstruire la zone de données à partir des structures de données
+avec :
+
+@table @kbd
+@item C-c M-C-l
+(@code{ses-reconstruct-all}).
+@end table
+
+
+@node Buffer-local variables in spreadsheets
+@section Les variables locales-tampon dans les feuilles de calcul
+@cindex locales-tampon, variables
+@cindex variables locales-tampon
+
+Vous pouvez ajouter des variables locales supplémentaires à la liste
+au bas de la zone de données, telles que des constantes cachées
+auxquelles vous désirez faire référence dans vos formules.
+
+Vous pouvez initialiser la variable @code{ses--symbolic-formulas} pour
+être une liste de symboles (comme une suite de chaînes entre
+parenthèses) à proposer comme complétions pour la commande @kbd{'}.
+Cette liste initiale de complétions sera utilisée à la place de
+l’ensemble effectif des symboles-comme-formules de la feuille.
+
+Pour un exemple de ceci, voir le fichier @file{etc/ses-example.ses}.
+
+Si (pour une raison quelconque) vous désirez que vos formules ou
+fonctions d’impression sauvegardent des données dans des variables,
+vous devez déclarer ces variables comme locales tampon pour éviter un
+avertissement de virus.
+
+Vous pouvez définir des fonctions en en faisant des valeurs pour la
+fausse variable locale @code{eval}. De telles fonctions peuvent
+ensuite être utilisées dans les formules et comme fonctions
+d’impression, mais d’ordinaire chaque @code{eval} est présenté à
+l’utilisateur pendant le chargement du fichier comme un virus
+potentiel. Et cela peut devenir gênant.
+
+Vous pouvez définir des fonctions dans votre fichier @file{.emacs}.
+Toute personne pourra encore lire la zone d’impression de votre
+feuille, mais ne pourra pas recalculer ou réimprimer quoi que ce soit
+qui dépende de vos fonctions. Pour éviter des avertissements contre
+les virus, chaque fonction utilisée dans une formule nécessite
+@lisp
+(put 'le-nom-de-votre-fonction 'safe-function t)
+@end lisp
+
+@node Uses of advice-add in @acronym{SES}
+@section Utilisation de advice-add dans @acronym{SES}
+@findex advice-add
+@findex copy-region-as-kill
+@findex yank
+
+@table @code
+@item copy-region-as-kill
+Quand on copie de la zone d’impression d’une feuille, traite la région
+comme un rectangle et joint pour chaque cellule sa formule et sa
+fonction d’impression comme des propriétés @code{'ses}.
+
+@item yank
+Quand on colle dans la zone d’impression d’une feuille de calcul,
+essaie de coller comme des cellules (si le texte à coller a des
+propriétés @code{'ses}), ensuite comme des formules séparées par des
+tabulations, ensuite (si tout le reste a échoué) comme une seule
+formule pour la cellule courante.
+@end table
+
+@c ===================================================================
+@node Index
+@unnumbered Index
+
+@printindex cp
+
+@c ===================================================================
+
+@node Acknowledgments
+@unnumbered Remerciements
+
+Codé par :
+@quotation
+@c jyavner@@member.fsf.org
+Jonathan Yavner,
+@c monnier@@gnu.org
+Stefan Monnier,
+@c shigeru.fukaya@@gmail.com
+Shigeru Fukaya,
+@c vincent.belaiche@@sourceforge.net
+Vincent Belaïche
+@end quotation
+
+@noindent
+Manuel Texinfo de :
+@quotation
+@c jyavner@@member.fsf.org
+Jonathan Yavner,
+@c brad@@chenla.org
+Brad Collins,
+@c vincent.belaiche@@sourceforge.net
+Vincent Belaïche
+@end quotation
+
+@noindent
+Idées de :
+@quotation
+@c christoph.conrad@@gmx.de
+Christoph Conrad,
+@c cyberbob@@redneck.gacracker.org
+CyberBob,
+@c syver-en@@online.no
+Syver Enstad,
+@c fischman@@zion.bpnetworks.com
+Ami Fischman,
+@c Thomas.Gehrlein@@t-online.de
+Thomas Gehrlein,
+@c c.f.a.johnson@@rogers.com
+Chris F.A. Johnson,
+@c lyusong@@hotmail.com
+Yusong Li,
+@c juri@@jurta.org
+Juri Linkov,
+@c maierh@@myself.com
+Harald Maier,
+@c anash@@san.rr.com
+Alan Nash,
+@c pinard@@iro.umontreal.ca
+François Pinard,
+@c ppinto@@cs.cmu.edu
+Pedro Pinto,
+@c xsteve@@riic.at
+Stefan Reichör,
+@c epameinondas@@gmx.de
+Oliver Scholz,
+@c rms@@gnu.org
+Richard M. Stallman,
+@c teirllm@@dms.auburn.edu
+Luc Teirlinck,
+@c jotto@@pobox.com
+J. Otto Tennant,
+@c jphil@@acs.pagesjaunes.fr
+Jean-Philippe Theberge,
+@c rrandresf@@hotmail.com
+Andrés Ramírez
+@end quotation
+
+@c ===================================================================
+
+@node GNU Free Documentation License
+@appendix GNU Free Documentation License
+@include doclicense.texi
+
+@bye
+@c Local Variables:
+@c ispell-dictionary: "fr"
+@c End:
diff --git a/etc/CALC-NEWS b/etc/CALC-NEWS
index 8e91affd788..06d4a3fc948 100644
--- a/etc/CALC-NEWS
+++ b/etc/CALC-NEWS
@@ -856,7 +856,7 @@ For changes in Emacs 23.1 and later, see the main Emacs NEWS file.
** Fixed obsolete trail tags gsmp, gneg, ginv to jsmp, jneg, jinv.
-** Fixed some errors and made improvements in units table [Ulrich Mueller].
+** Fixed some errors and made improvements in units table [Ulrich Müller].
* Version 1.07:
diff --git a/etc/ChangeLog.1 b/etc/ChangeLog.1
index 2806be2b322..0c7e432bba9 100644
--- a/etc/ChangeLog.1
+++ b/etc/ChangeLog.1
@@ -1778,7 +1778,7 @@
* refcards/orgcard.tex: Cleanup.
-2010-11-27 Ulrich Mueller <ulm@gentoo.org>
+2010-11-27 Ulrich Müller <ulm@gentoo.org>
* HELLO: Add ancient Greek (Bug#7418).
@@ -2497,7 +2497,7 @@
* NEWS: New function `locate-user-emacs-file'.
-2008-10-18 Ulrich Mueller <ulm@gentoo.org>
+2008-10-18 Ulrich Müller <ulm@gentoo.org>
* MACHINES: Add section for SuperH.
@@ -2624,7 +2624,7 @@
* images/custom/right.xpm:
* images/custom/right-pushed.xpm: New files.
-2008-05-07 Eric S. Raymond <esr@snark.thyrsus.com>
+2008-05-07 Eric S. Raymond <esr@thyrsus.com>
* NEWS: Support for Meta-CVS removed.
@@ -2914,7 +2914,7 @@
emacs48_mac.png, emacs256_mac.png, and emacs512_mac.png,
respectively.
-2007-12-08 Ulrich Mueller <ulm@gentoo.org> (tiny change)
+2007-12-08 Ulrich Müller <ulm@gentoo.org> (tiny change)
* emacs.desktop (Exec, Icon, Categories): Fix entries.
@@ -3015,7 +3015,7 @@
* NEWS: Mention desktop locking.
-2007-10-10 Eric S. Raymond <esr@snark.thyrsus.com>
+2007-10-10 Eric S. Raymond <esr@thyrsus.com>
* NEWS: Explain the VC fileset changes a bit better.
@@ -6019,7 +6019,7 @@
* Rename termcap to termcap.src, the historical name for an
uninstalled termcap file.
-1995-06-28 Eric S. Raymond <esr@spiff.gnu.ai.mit.edu>
+1995-06-28 Eric S. Raymond <esr@thyrsus.com>
* termcap.dat, termcap.ucb: Deleted and replaced.
@@ -6147,11 +6147,11 @@
* MACHINES: Add section for NeXT, from Thorsten Ohl.
-1993-04-28 Eric S. Raymond (eric@mole.gnu.ai.mit.edu)
+1993-04-28 Eric S. Raymond (esr@thyrsus.com)
* NEWS: Documented picture-mode improvements.
-1993-04-25 Eric S. Raymond (eric@mole.gnu.ai.mit.edu)
+1993-04-25 Eric S. Raymond (esr@thyrsus.com)
* NEWS: Described the new properties of arrow keys and
next-line-add-newlines. Fixed up the GUD description, it was
@@ -6160,23 +6160,23 @@
* news.texi: invocation-name now exists.
-1993-03-27 Eric S. Raymond (eric@geech.gnu.ai.mit.edu)
+1993-03-27 Eric S. Raymond (esr@thyrsus.com)
* MORE.STUFF: Added.
-1993-03-22 Eric S. Raymond (eric@geech.gnu.ai.mit.edu)
+1993-03-22 Eric S. Raymond (esr@thyrsus.com)
* NEWS: Preserved jimb's last change (documenting kill on
read-only buffers).
Added documentation on new info features.
-1993-03-22 Eric S. Raymond (eric@geech.gnu.ai.mit.edu)
+1993-03-22 Eric S. Raymond (esr@thyrsus.com)
* spook.lines: Alpha-sorted this, and added some new hot buttons
for the 1990s.
-1993-03-19 Eric S. Raymond (eric@geech.gnu.ai.mit.edu)
+1993-03-19 Eric S. Raymond (esr@thyrsus.com)
* MACHINES: Deleted some VMS caveats. If the src and lisp
ChangeLogs are correct, dired and mail and process control are now
@@ -6188,13 +6188,13 @@
* NEWS: Changed.
-1993-03-19 Eric S. Raymond (eric@geech.gnu.ai.mit.edu)
+1993-03-19 Eric S. Raymond (esr@thyrsus.com)
* sex.6: Added 900-line support.
* NEWS: Added news about the package finder.
-1993-03-19 Eric S. Raymond (eric@geech.gnu.ai.mit.edu)
+1993-03-19 Eric S. Raymond (esr@thyrsus.com)
* MACHINES: `Last updated 10 Feb 1992.' was obviously wrong, so
I nuked it. Let the file mod date serve. Merged in APOLLO and
@@ -6205,7 +6205,7 @@
* Makefile (relock, unlock): New productions.
-1993-03-18 Eric S. Raymond (eric@geech.gnu.ai.mit.edu)
+1993-03-18 Eric S. Raymond (esr@thyrsus.com)
Augean-stable cleaning time. Partly to save space, but mostly to
reduce the dizzying amount of *stuff* confronting someone exploring
@@ -6245,7 +6245,7 @@
names as per convention. Originals of all files merged still
exist with =-names.
-1993-03-17 Eric S. Raymond (eric@mole.gnu.ai.mit.edu)
+1993-03-17 Eric S. Raymond (esr@thyrsus.com)
* XENIX: Nuked (moved to =XENIX). The hackery it describes is
no longer necessary in the presence of 19's function-key-map
@@ -6254,7 +6254,7 @@
1993-03-10 Jim Blandy (jimb@totoro.cs.oberlin.edu)
* MACHINES: Update description of SYSVr3 and r4 support, due to
- Eric Raymond's changes.
+ Eric S. Raymond's changes.
1993-03-09 Jim Blandy (jimb@totoro.cs.oberlin.edu)
@@ -6272,7 +6272,7 @@
* NEWS: Document included tags tables.
-1992-07-22 Eric S. Raymond (eric@mole.gnu.ai.mit.edu)
+1992-07-22 Eric S. Raymond (esr@thyrsus.com)
* Corrected the news about VC to reflect reality.
diff --git a/etc/DEBUG b/etc/DEBUG
index 9dae54aeabd..4eae090621f 100644
--- a/etc/DEBUG
+++ b/etc/DEBUG
@@ -928,7 +928,10 @@ data that is modified only very rarely.)
It is also useful to look at the corrupted object or data structure in
a fresh Emacs session and compare its contents with a session that you
-are debugging.
+are debugging. This might be somewhat harder on modern systems which
+randomize addresses of running executables (the so-called Address
+Space Layout Randomization, or ASLR, feature). If you have this
+problem, see below under "How to disable ASLR".
** Debugging the TTY (non-windowed) version
@@ -1031,6 +1034,28 @@ Address sanitization is incompatible with undefined-behavior
sanitization, unfortunately. Address sanitization is also
incompatible with the --with-dumping=unexec option of 'configure'.
+*** Address poisoning/unpoisoning
+
+When compiled with address sanitization, Emacs will also try to mark
+dead/free lisp objects as poisoned, forbidding them from being
+accessed without being unpoisoned first. This adds an extra layer
+of checking with objects in internal free lists, which may otherwise
+evade traditional use-after-free checks. To disable this, add
+'allow_user_poisoning=0' to ASAN_OPTIONS, or build Emacs with
+'-DGC_ASAN_POISON_OBJECTS=0' in CFLAGS.
+
+While using GDB, memory addresses can be inspected by using helper
+functions additionally provided by the ASan library:
+
+ (gdb) call __asan_describe_address(ptr)
+
+To check whether an address range is poisoned or not, use:
+
+ (gdb) call __asan_region_is_poisoned(ptr, 8)
+
+Additional functions can be found in the header
+'sanitizer/asan_interface.h' in your compiler's headers directory.
+
** Running Emacs under Valgrind
Valgrind <https://valgrind.org/> is free software that can be useful
@@ -1058,6 +1083,37 @@ suppresses some Valgrind false alarms during Emacs garbage collection:
Unfortunately Valgrind suppression files tend to be system-dependent,
so you will need to keep one around that matches your system.
+** How to disable ASLR
+
+Modern systems use the so-called Address Space Layout Randomization,
+(ASLR) feature, which randomizes the base address of running programs,
+making it harder for malicious software or hackers to find the address
+of some function or variable in a running program by looking at its
+executable file. This causes the address of the same symbol to be
+different across rerunning of the same program. Sometimes, it can be
+useful to disable ASLR, for example, if you want to compare objects in
+two different Emacs sessions.
+
+On GNU/Linux, you can disable ASLR temporarily with the following
+shell command:
+
+ echo 0 > /proc/sys/kernel/randomize_va_space
+
+or by running Emacs in an environment where ASLR is temporarily
+disabled:
+
+ setarch -R emacs [args...]
+
+To disable ASLR in Emacs on MS-Windows, you will have to rebuild Emacs
+while adding '-Wl,-disable-dynamicbase' to LD_SWITCH_SYSTEM_TEMACS
+variable defined in src/Makefile. Alternatively, use some tool to
+edit the PE header of the Emacs executable file and reset the
+DYNAMIC_BASE (0x40) flag in the DllCharacteristics flags recorded by
+the PE header.
+
+On macOS, there's no official way for disabling ASLR, but there are
+various hacks that can be found by searching the Internet.
+
** How to recover buffer contents from an Emacs core dump file
The file etc/emacs-buffer.gdb defines a set of GDB commands for
@@ -1065,7 +1121,7 @@ recovering the contents of Emacs buffers from a core dump file. You
might also find those commands useful for displaying the list of
buffers in human-readable format from within the debugger.
-*** Debugging Emacs with LLDB
+** Debugging Emacs with LLDB
On systems where GDB is not available, like macOS with M1 chip, you
can also use LLDB for Emacs debugging.
@@ -1101,6 +1157,204 @@ Please refer to the LLDB reference on the web for more information
about LLDB. If you already know GDB, you will also find a mapping
from GDB commands to corresponding LLDB commands there.
+** Debugging Emacs on Android.
+
+A script located in the java/ directory automates the procedures
+necessary run Emacs under a Gdb session on an Android device connected
+to a computer using USB.
+
+Its requirements are the `adb' (Android Debug Bridge) utility and the
+Java debugger (jdb), utilized to cue the Android system to resume the
+Emacs process after the debugger attaches.
+
+If all three of those tools are present, simply run (from the Emacs
+source directory):
+
+ ../java/debug.sh -- [any extra arguments you wish to pass to gdb]
+
+Several lines of debug information will be printed, after which the
+Gdb prompt should be displayed.
+
+If there is no Gdbserver binary present on the device, then specify
+one to upload, like so:
+
+ ../java/debug.sh --gdbserver /path/to/gdbserver
+
+This Gdbserver should be statically linked or compiled using the
+Android NDK, and must target the same architecture as the debugged
+Emacs binary. Older versions of the Android NDK (such as r24)
+distribute suitable Gdbserver binaries, usually located within
+
+ prebuilt/android-<arch>/gdbserver/gdbserver
+
+relative to the root of the NDK distribution.
+
+To attach Emacs to an existing process on a target device, use the
+`--attach-existing' argument to debug.sh:
+
+ ../java/debug.sh --attach-existing [other arguments]
+
+If multiple Emacs processes are running, debug.sh will display the
+names and PIDs of each running process, and prompt for the process
+that it should attach to.
+
+After Emacs starts, type:
+
+ (gdb) handle SIGUSR1 noprint pass
+
+to ignore the SIGUSR1 signal that is sent by the Android port's
+`select' emulation. If this is overlooked, Emacs will stop each time
+a windowing event is received, which is probably unwanted.
+
+On top of the debugging procedure described above, Android also
+maintains a "logcat" buffer, where it prints backtraces during or
+after each crash. Its contents are of interest when performing
+post-mortem debugging after a crash, and can also be retrieved through
+the `adb' tool, like so:
+
+ $ adb logcat
+
+There are three forms of crash messages printed by Android. The first
+form is printed when a crash arises within Java code, and should
+resemble the following when printed in the logcat buffer:
+
+E AndroidRuntime: FATAL EXCEPTION: main
+E AndroidRuntime: Process: org.gnu.emacs, PID: 18057
+E AndroidRuntime: java.lang.RuntimeException: sample crash
+E AndroidRuntime: at org.gnu.emacs.EmacsService.onCreate(EmacsService.java:308)
+E AndroidRuntime: at android.app.ActivityThread.handleCreateService(ActivityThread.java:4485)
+E AndroidRuntime: ... 9 more
+
+The second form is printed when a fatal signal (such as an abort, or
+segmentation fault) is raised within C code. Here is an example of
+such a crash:
+
+F libc : Fatal signal 11 (SIGSEGV), code 1 (SEGV_MAPERR), fault addr 0x3 in tid 32644
+ (Emacs main thre), pid 32619 (org.gnu.emacs)
+F DEBUG : Cmdline: org.gnu.emacs
+F DEBUG : pid: 32619, tid: 32644, name: Emacs main thre >>> org.gnu.emacs <<<
+F DEBUG : #00 pc 002b27b0 /.../lib/arm64/libemacs.so (sfnt_read_cmap_table+32)
+F DEBUG : #01 pc 002c4ee8 /.../lib/arm64/libemacs.so (sfntfont_read_cmap+84)
+F DEBUG : #02 pc 002c4dc4 /.../lib/arm64/libemacs.so (sfntfont_lookup_char+396)
+F DEBUG : #03 pc 002c23d8 /.../lib/arm64/libemacs.so (sfntfont_list+1688)
+F DEBUG : #04 pc 0021112c /.../lib/arm64/libemacs.so (font_list_entities+864)
+F DEBUG : #05 pc 002138d8 /.../lib/arm64/libemacs.so (font_find_for_lface+1532)
+F DEBUG : #06 pc 00280c50 /.../lib/arm64/libemacs.so (fontset_find_font+2760)
+F DEBUG : #07 pc 0027cadc /.../lib/arm64/libemacs.so (fontset_font+792)
+F DEBUG : #08 pc 0027c710 /.../lib/arm64/libemacs.so (face_for_char+412)
+F DEBUG : #09 pc 00217314 /.../lib/arm64/libemacs.so (Finternal_char_font+324)
+F DEBUG : #10 pc 00240d78 /.../lib/arm64/libemacs.so (exec_byte_code+3112)
+F DEBUG : #11 pc 001f5ff8 /.../lib/arm64/libemacs.so (Ffuncall+392)
+F DEBUG : #12 pc 001f3cf0 /.../lib/arm64/libemacs.so (eval_sub+2260)
+F DEBUG : #13 pc 001f853c /.../lib/arm64/libemacs.so (Feval+80)
+F DEBUG : #14 pc 00240d78 /.../lib/arm64/libemacs.so (exec_byte_code+3112)
+F DEBUG : #15 pc 00240130 /.../lib/arm64/libemacs.so (Fbyte_code+120)
+F DEBUG : #16 pc 001f3d84 /.../lib/arm64/libemacs.so (eval_sub+2408)
+F DEBUG : #17 pc 00221d7c /.../lib/arm64/libemacs.so (readevalloop+1748)
+F DEBUG : #18 pc 002201a0 /.../lib/arm64/libemacs.so (Fload+2544)
+F DEBUG : #19 pc 00221f3c /.../lib/arm64/libemacs.so (save_match_data_load+88)
+F DEBUG : #20 pc 001f8414 /.../lib/arm64/libemacs.so (load_with_autoload_queue+252)
+F DEBUG : #21 pc 001f6550 /.../lib/arm64/libemacs.so (Fautoload_do_load+608)
+F DEBUG : #22 pc 00240d78 /.../lib/arm64/libemacs.so (exec_byte_code+3112)
+F DEBUG : #23 pc 001f5ff8 /.../lib/arm64/libemacs.so (Ffuncall+392)
+F DEBUG : #24 pc 001f1120 /.../lib/arm64/libemacs.so (Ffuncall_interactively+64)
+F DEBUG : #25 pc 001f5ff8 /.../lib/arm64/libemacs.so (Ffuncall+392)
+F DEBUG : #26 pc 001f8b8c /.../lib/arm64/libemacs.so (Fapply+916)
+F DEBUG : #27 pc 001f137c /.../lib/arm64/libemacs.so (Fcall_interactively+576)
+F DEBUG : #28 pc 00240d78 /.../lib/arm64/libemacs.so (exec_byte_code+3112)
+F DEBUG : #29 pc 001f5ff8 /.../lib/arm64/libemacs.so (Ffuncall+392)
+F DEBUG : #30 pc 0016d054 /.../lib/arm64/libemacs.so (command_loop_1+1344)
+F DEBUG : #31 pc 001f6d90 /.../lib/arm64/libemacs.so (internal_condition_case+92)
+F DEBUG : #32 pc 0016cafc /.../lib/arm64/libemacs.so (command_loop_2+48)
+F DEBUG : #33 pc 001f6660 /.../lib/arm64/libemacs.so (internal_catch+84)
+F DEBUG : #34 pc 0016c288 /.../lib/arm64/libemacs.so (command_loop+264)
+F DEBUG : #35 pc 0016c0d8 /.../lib/arm64/libemacs.so (recursive_edit_1+144)
+F DEBUG : #36 pc 0016c4fc /.../lib/arm64/libemacs.so (Frecursive_edit+348)
+F DEBUG : #37 pc 0016af9c /.../lib/arm64/libemacs.so (android_emacs_init+7132)
+F DEBUG : #38 pc 002ab8d4 /.../lib/arm64/libemacs.so (Java_org_gnu_emacs_...+3816)
+
+Where the first line (the one containing "libc") mentions the number
+of the fatal signal, the address of any VM fault, and the name and ID
+of the thread which crashed. Subsequent lines then contain a
+backtrace, recounting each function in the call stack culminating in
+the crash.
+
+The third form is printed when Emacs misuses the JVM in some fashion
+that is detected by the Android CheckJNI facility. It looks like:
+
+A/art﹕ art/runtime/check_jni.cc:65] JNI DETECTED ERROR IN APPLICATION: ...
+A/art﹕ art/runtime/check_jni.cc:65] in call to CallVoidMethodV
+A/art﹕ art/runtime/check_jni.cc:65] from void android.os.MessageQueue.nativePollOnce(long, int)
+A/art﹕ art/runtime/check_jni.cc:65] "main" prio=5 tid=1 Runnable
+A/art﹕ art/runtime/check_jni.cc:65] | group="main" sCount=0 dsCount=0 obj=0x87d30ef0 self=0xb4f07800
+A/art﹕ art/runtime/check_jni.cc:65] | sysTid=18828 nice=-11 cgrp=apps sched=0/0 handle=0xb6fdeec8
+A/art﹕ art/runtime/check_jni.cc:65] | state=R schedstat=( 2249126546 506089308 3210 ) utm=183 stm=41 core=3 HZ=100
+A/art﹕ art/runtime/check_jni.cc:65] | stack=0xbe0c8000-0xbe0ca000 stackSize=8MB
+A/art﹕ art/runtime/check_jni.cc:65] | held mutexes= "mutator lock"(shared held)
+A/art﹕ art/runtime/check_jni.cc:65] native: #00 pc 00004640 /system/lib/libbacktrace_libc++.so (UnwindCurrent::Unwind(unsigned int, ucontext*)+23)
+A/art﹕ art/runtime/check_jni.cc:65] native: #01 pc 00002e8d /system/lib/libbacktrace_libc++.so (Backtrace::Unwind(unsigned int, ucontext*)+8)
+A/art﹕ art/runtime/check_jni.cc:65] native: #02 pc 00248381 /system/lib/libart.so (art::DumpNativeStack(std::__1::basic_ostream<char, std::__1::char_traits<char> >&, int, char const*, art::mirror::ArtMethod*)+68)
+A/art﹕ art/runtime/check_jni.cc:65] native: #03 pc 0022cd0b /system/lib/libart.so (art::Thread::Dump(std::__1::basic_ostream<char, std::__1::char_traits<char> >&) const+146)
+A/art﹕ art/runtime/check_jni.cc:65] native: #04 pc 000b189b /system/lib/libart.so (art::JniAbort(char const*, char const*)+582)
+A/art﹕ art/runtime/check_jni.cc:65] native: #05 pc 000b1fd5 /system/lib/libart.so (art::JniAbortF(char const*, char const*, ...)+60)
+A/art﹕ art/runtime/check_jni.cc:65] native: #06 pc 000b50e5 /system/lib/libart.so (art::ScopedCheck::ScopedCheck(_JNIEnv*, int, char const*)+1284)
+A/art﹕ art/runtime/check_jni.cc:65] native: #07 pc 000bc59f /system/lib/libart.so (art::CheckJNI::CallVoidMethodV(_JNIEnv*, _jobject*, _jmethodID*, std::__va_list)+30)
+A/art﹕ art/runtime/check_jni.cc:65] native: #08 pc 00063803 /system/lib/libandroid_runtime.so (???)
+A/art﹕ art/runtime/check_jni.cc:65] native: #09 pc 000776bd /system/lib/libandroid_runtime.so (android::NativeDisplayEventReceiver::dispatchVsync(long long, int, unsigned int)+40)
+A/art﹕ art/runtime/check_jni.cc:65] native: #10 pc 00077885 /system/lib/libandroid_runtime.so (android::NativeDisplayEventReceiver::handleEvent(int, int, void*)+80)
+A/art﹕ art/runtime/check_jni.cc:65] native: #11 pc 00010f6f /system/lib/libutils.so (android::Looper::pollInner(int)+482)
+A/art﹕ art/runtime/check_jni.cc:65] native: #12 pc 00011019 /system/lib/libutils.so (android::Looper::pollOnce(int, int*, int*, void**)+92)
+A/art﹕ art/runtime/check_jni.cc:65] native: #13 pc 000830c1 /system/lib/libandroid_runtime.so (android::NativeMessageQueue::pollOnce(_JNIEnv*, int)+22)
+A/art﹕ art/runtime/check_jni.cc:65] native: #14 pc 000b22d7 /system/framework/arm/boot.oat (Java_android_os_MessageQueue_nativePollOnce__JI+102)
+A/art﹕ art/runtime/check_jni.cc:65] at android.os.MessageQueue.nativePollOnce(Native method)
+A/art﹕ art/runtime/check_jni.cc:65] at android.os.MessageQueue.next(MessageQueue.java:143)
+A/art﹕ art/runtime/check_jni.cc:65] at android.os.Looper.loop(Looper.java:130)
+A/art﹕ art/runtime/check_jni.cc:65] at android.app.ActivityThread.main(ActivityThread.java:5832)
+A/art﹕ art/runtime/check_jni.cc:65] at java.lang.reflect.Method.invoke!(Native method)
+A/art﹕ art/runtime/check_jni.cc:65] at java.lang.reflect.Method.invoke(Method.java:372)
+A/art﹕ art/runtime/check_jni.cc:65] at com.android.internal.os.ZygoteInit$MethodAndArgsCaller.run(ZygoteInit.java:1399)
+A/art﹕ art/runtime/check_jni.cc:65] at com.android.internal.os.ZygoteInit.main(ZygoteInit.java:1194)
+A/art﹕ art/runtime/check_jni.cc:65]
+
+In such situations, the first line explains what infraction Emacs
+committed, while the ensuing ones print backtraces for each running
+Java thread at the time of the error.
+
+If Emacs is executing on Android 5.0 and later, placing a breakpoint
+on
+
+ (gdb) break art::JavaVMExt::JniAbort
+
+will set a breakpoint that is hit each time such an error is detected.
+
+Since the logcat output is always rapidly being amended, it is worth
+piping it to a file or shell command buffer, and then searching for
+keywords such as "AndroidRuntime", "Fatal signal", or "JNI DETECTED
+ERROR IN APPLICATION".
+
+Once in a blue moon, it proves necessary to debug Java rather than C
+code. To this end, the `--jdb' option will attach the Java debugger
+instead of gdbserver. Lametably, it seems impossible to debug both C
+and Java code in concert.
+
+C code within Emacs rigorously checks for Java exceptions after
+calling any JVM function that may signal an out-of-memory error,
+employing one of the android_exception_check(_N) functions defined
+within android.c for this purpose. These functions operate presuming
+the preceding Java code does not signal exceptions of its own, and
+report out-of-memory errors upon any type of exception, not just OOM
+errors.
+
+If Emacs protests that it is out of memory, yet you witness a
+substantial amount of free space remaining, search the log buffer for
+a string containing:
+
+ "Possible out of memory error. The Java exception follows:"
+
+subsequent to which a reproduction of the exception precipitating the
+spurious OOM error should be located. This exception is invariably
+indicative of a bug within Emacs that should be fixed.
+
This file is part of GNU Emacs.
diff --git a/etc/EGLOT-NEWS b/etc/EGLOT-NEWS
index d6a9b29e235..12e7d3f6b9b 100644
--- a/etc/EGLOT-NEWS
+++ b/etc/EGLOT-NEWS
@@ -12,12 +12,177 @@ This file is about changes in Eglot, the Emacs client for LSP
(Language Server Protocol) distributed with GNU Emacs since Emacs
version 29.1 and with GNU ELPA since 2018.
-Note: references to Eglot issues are presented as "github#nnnn".
-This refers to https://github.com/joaotavora/eglot/issues/.
-That is, to look up issue github#1234, go to
+Note: references to some Eglot issues are presented as "github#nnnn".
+This refers to https://github.com/joaotavora/eglot/issues/. That is,
+to look up issue github#1234, go to
https://github.com/joaotavora/eglot/issues/1234.
+* Changes in upcoming Eglot
+
+
+* Changes in Eglot 1.17 (25/1/2024)
+
+** Fixes to completion (github#847, github#1349)
+
+** Fix code-action gathering for some servers (github#847)
+
+** Experimental support for Eglot-only subprojects
+
+Until project.el's support for subprojects improves, github#1337
+describes a reasonably sane way to configure nested sub-projects
+within a larger one just for Eglot purposes.
+
+
+* Changes in Eglot 1.16 (27/12/2023)
+
+** Code actions can be previewed in diff format
+
+The variable 'eglot-confirm-server-edits' replaces the obsolete
+'eglot-confirm-server-initiated-edits' and brings about a new
+confirmation model for code actions, making it possible to have only
+certain commands require user confirmation. It allows a temporary
+'diff-mode' buffer to display the proposed changes, so the user can
+apply them one by one. See bug#60338.
+
+** Completion sorting has been fixed
+
+In some situations, Eglot was not respecting the completion sort order
+decided by the language server, falling back on the sort order
+determined by the 'flex' completion style instead. See github#1306.
+
+** Improve mouse invocation of code actions
+
+When invoking code actions by middle clicking with the mouse on
+Flymake diagnostics, it was often the case that Eglot didn't request
+code actions correctly and thus no actions were offered to the user.
+This has been fixed. See github#1295.
+
+** Optimized file-watching capability
+
+Some servers, like the Pyright language server, issue too many file
+watching requests. This change slightly reduces the number of file
+watcher objects requested from the operating system, which can be a
+problem, particularly on Mac OS. See github#1228 and github#1226.
+
+** Faster, more accurate, event logging
+
+The Eglot events buffer takes advantage of new functionality in
+Jsonrpc 1.23. By default, Lisp-style printing of JSON-RPC message (a
+common cause of performance degradation) is disabled. The full
+original JSON message is presented instead. See new variable
+'eglot-events-buffer-config', which replaces the obsolete
+'eglot-events-buffer-size'.
+
+** 'textdocument/onTypeFormatting' feature has been fixed
+
+For 'newline' commands, Eglot sometimes sent the wrong character code
+to the server. Also this feature is now less chatty in the mode-line
+and messages buffer.
+
+** Partial fix C-M-i "middle-of-symbol" completions (github#1339)
+
+** Add "Extending Eglot" section to manual
+
+** Fixed Elisp interface 'eglot-lsp-context' (github#1336, github#1337)
+
+** Supports LSP's 'window/showRequest' (bug#62116)
+
+** The self-upgrade command is now called 'eglot-upgrade-eglot'
+
+** Newly added directories also watched (github#1228)
+
+** Send correct ':language-id' for JavaScript server (bug#67150)
+
+** New servers have been added to 'eglot-server-programs'.
+
+- nls (bug#63603)
+- nixd (bug#64214)
+- lexical (bug#65359)
+- terraform-ls (bug#65671)
+- ruff-lsp (bug#67441)
+- uiua (bug#67850)
+
+
+* Changes in Eglot 1.15 (29/4/2023)
+
+** Fix LSP "languageId" detection
+
+Many servers today support multiple languages, meaning they can handle
+more than one file type in the same connection. This relies on the
+client supplying a ':languageId' string. Previously, Eglot calculated
+this string based on an imperfect heuristic and was often wrong. See
+github#1206.
+
+** Fix problems with missing signature documentation (bug#62687)
+
+** Reworked 'eglot-imenu'
+
+Eglot's Imenu backend (used for M-x imenu among other extensions), has
+been reworked. Most newer servers respond to
+'textDocument/documentSymbol' with a vector of 'DocumentSymbol', not
+'SymbolInformation'. It's not worth it trying to make the two formats
+resemble each other. This also lays groundwork supporting a
+forthcoming "breadcrumb" feature of bug#58431.
+
+** New command 'eglot-update'
+
+This allows users to easily update to the latest version of Eglot.
+
+
+* Changes in Eglot 1.14 (3/4/2023)
+
+** Faster, more responsive completion
+
+Eglot takes advantage of LSP's "isIncomplete" flag in responses to
+completion requests to drive new completion-caching mechanism for the
+duration of each completion session. Once a full set of completions
+is obtained for a given position, the server needn't be contacted in
+many scenarios, resulting in significantly less communication
+overhead. This works with the popular Company package and stock
+completion-at-point interfaces.
+
+A variable 'eglot-cache-session-completions', t by default, controls
+this. The mechanism was tested with ccls, jdtls, pylsp, golsp and
+clangd. Notably, the C/C++ language server Clangd version 15 has a
+bug in its "isIcomplete" flag (it is fixed in later versions). If you
+run into problems, disable this mechanism like so:
+
+(add-hook 'c-common-mode-hook
+ (lambda () (setq-local eglot-cache-session-completions nil)))
+
+** At-point documentation less obtrusive in echo area
+
+Eglot takes advantage of new features of ElDoc to separate short
+documentation strings from large ones, sending the former to be shown in
+the ElDoc's echo area and the latter to be shown in other outlets,
+such as the *eldoc* buffer obtainable with 'C-h .'.
+
+** New variable 'eglot-prefer-plaintext'
+
+Customize this to t to opt-in to docstrings in plain text instead of
+Markdown.
+
+(bug#61373)
+
+** Progress indicators inhabit the mode-line by default
+
+To switch to the echo area, customize 'eglot-report-progress' to
+'messages'. To switch off progress reporting completely, set to nil.
+
+** Snippet support is easier to enable
+
+The user needn't manually activate 'yas-minor-mode' or
+'yas-global-mode'. If YASnippet is installed and the server supports
+snippets, it is used automatically, unless the symbol 'yasnippet' has
+been added to 'eglot-stay-out-of'.
+
+
+* Changes in Eglot 1.13 (15/03/2023)
+
+** ELPA installations on Emacs 26.3 are supported again.
+
+
* Changes in Eglot 1.12.29 (Eglot bundled with Emacs 29.1)
** Eglot has a new command to upgrade to the latest version.
@@ -27,6 +192,9 @@ latest version of Eglot from ELPA. This might be more convenient than
using the more general command 'package-install', which by default
will not upgrade "built-in" packages, those that come with Emacs.
+
+* Changes in Eglot 1.12 (13/03/2023)
+
** LSP inlay hints are now supported.
Inlay hints are small text annotations not unlike diagnostics, but
designed to help readability instead of indicating problems. For
@@ -335,7 +503,7 @@ This disconnects the server after last managed buffer is killed.
(github#217, github#270)
-** Completion support support has been fixed.
+** Completion support has been fixed.
Among other things, consider LSP's "filterText" cookies, which enable
a kind of poor-man's flex-matching for some backends.
diff --git a/etc/ERC-NEWS b/etc/ERC-NEWS
index 3a16519ecc3..d7f513addfb 100644
--- a/etc/ERC-NEWS
+++ b/etc/ERC-NEWS
@@ -1,4 +1,4 @@
-ERC NEWS -*- outline -*-
+ERC NEWS
Copyright (C) 2006-2024 Free Software Foundation, Inc.
See the end of the file for license conditions.
@@ -12,6 +12,701 @@ extensible IRC (Internet Relay Chat) client distributed with
GNU Emacs since Emacs version 22.1.
+* Changes in ERC 5.6
+
+** Module 'keep-place' has a more decorative cousin.
+Remember your place in ERC buffers a bit more easily with the help of
+a configurable, visible indicator. Optionally sync the indicator to
+any progress made while you haven't yet caught up to the live stream.
+See options 'erc-keep-place-indicator-style' and friends, and try M-x
+keep-place-indicator-mode to see it in action.
+
+** Module 'fill' offers an adaptive style based on 'visual-line-mode'.
+This style dynamically wraps messages to a window's width while
+mimicking the "hanging indent" look of 'erc-fill-static'. It also
+provides some movement and editing commands to optionally tame the
+less familiar aspects of 'visual-line' behavior. An interactive
+helper called 'erc-fill-wrap-nudge' makes easy work of adjusting the
+overhang on the fly. Set 'erc-fill-function' to 'erc-fill-wrap' to
+get started.
+
+** A module for nickname highlighting has joined ERC.
+Automatic nickname coloring has come to ERC core. Users familiar with
+'erc-hl-nicks', from which this module directly descends, will already
+be familiar with its suite of handy options. By default, each
+nickname in an ERC session receives a unique face with a unique (or
+uniformly dealt) foreground color. Add 'nicks' to 'erc-modules' to
+get started.
+
+** A unified interactive entry point.
+New users are often dismayed to discover that M-x ERC doesn't connect
+to its default network, Libera.Chat, over TLS. Though perhaps a
+decade overdue, this is no longer the case. Other UX improvements in
+this area aim to make the process of connecting interactively slightly
+more streamlined and less repetitive, even for veteran users.
+
+** Revised buffer-display handling.
+A point of friction for new users and one only just introduced with
+ERC 5.5 has been the lack of visual feedback when first connecting via
+M-x erc or when issuing a "/JOIN" command at the prompt. As explained
+below, in the news for 5.5, the discovery of a security issue led to
+most new ERC buffers being "buried" on creation. On further
+reflection, this was judged to have been an overcorrection in the case
+of interactive invocations, hence the borrowing of an old option,
+'erc-query-display', and the bestowing of a new alias,
+'erc-interactive-display', which better describes its expanded role as
+a more general buffer-display knob for interactive commands ("/QUERY"
+still among them).
+
+Accompanying this addition are "display"-suffixed aliases for related
+options 'erc-join-buffer' and 'erc-auto-query', which users have
+reported as being difficult to discover and remember. When the latter
+option (now known as 'erc-receive-query-display') is nil, ERC uses
+'erc-join-buffer' in its place, much like it does for
+'erc-interactive-display'. The old nil behavior can still be gotten
+via the new compatibility flag 'erc-receive-query-display-defer'. The
+relatively new option 'erc-reconnect-display' has likewise been
+renamed, this time for clarity, to 'erc-auto-reconnect-display'.
+
+This release also introduces a few subtleties affecting the display of
+new or reassociated buffers. One involves buffers that already occupy
+the selected window. ERC now treats these as deserving of an implicit
+'bury'. An escape hatch for this and most other baked-in behaviors is
+now available in the form of a new type variant recognized by all such
+options. That is, users can now specify their own function to
+exercise full control over nearly all buffer-display related
+decisions. See the newly expanded doc strings of 'erc-buffer-display'
+and friends, as well as Info node '(erc) display-buffer', for details.
+
+** Setting a module's mode variable via Customize earns a warning.
+Trying and failing to activate a module via its minor mode's Custom
+widget has been an age-old annoyance for new users. Previously
+ineffective, this method now actually works, but it also admonishes
+users to edit the 'erc-modules' widget instead.
+
+** ERC's status-sidebar has gained an accompanying module.
+Users can now add 'bufbar' to 'erc-modules' to achieve the same effect
+as toggling 'erc-status-sidebar-open' manually at the start of an IRC
+session. The module has also been outfitted to show channels and
+queries under their servers by default. To avoid confusion, the major
+mode for the actual sidebar buffer itself, 'erc-status-sidebar-mode',
+is no longer available interactively.
+
+** A new spin on a classic integration in erc-speedbar.
+Add 'nickbar' to 'erc-modules' to spawn a dynamically updating side
+window listing all the users in any target buffer. It's powered by
+the same speedbar.el integration you've always known, except this
+one's optionally accessible from the keyboard, just like any other
+side window. Hit '<RET>' over a nick to spawn a "/QUERY" or a
+"Lastlog" (Occur) session. See 'erc-nickbar-mode' for more.
+
+** Option 'erc-timestamp-use-align-to' more versatile.
+While this option has always offered to right-align stamps via the
+'display' text property, it's now more effective at doing so when set
+to a number indicating an offset from the right edge. Users of the
+'log' module may want to customize 'erc-log-filter-function' to
+'erc-stamp-prefix-log-filter' to avoid ragged right-hand stamps
+appearing in their saved logs.
+
+** Awkward entry point 'erc-server-select' improved but deprecated.
+The alternate entry point 'erc-server-select' has mainly served to
+confuse users in more recent years because it requires certain
+options, like 'erc-nick', to be configured ahead of time, and it
+doesn't support TLS. Its main selling point, historically, has been
+interactive completion based on the option 'erc-server-alist', which
+is a table of networks, servers, and ports. But most of the option's
+400-odd entries are sadly defunct or otherwise outdated. And, these
+days, most networks promote a well known load-balancing end point over
+individual servers anyway. Regardless, the command has now been
+improved to prompt for the same slate of parameters sought by
+'erc-tls'. Similarly, 'erc-server-alist' entries now support a fifth
+member in TLS ports (though this option too has been deprecated). If
+you feel these deprecations rash or unwarranted, please file a bug
+report and petition the maintainers for a reprieve.
+
+** Smarter reconnect handling for users on the move.
+ERC now offers a new, experimental reconnect strategy in the function
+'erc-server-delayed-check-reconnect', which tests for underlying
+connectivity before attempting to reconnect in earnest. See option
+'erc-server-reconnect-function' and new local module 'services-regain'
+(also experimental) to get started.
+
+** Modules rather than their libraries set major-mode keybindings.
+To put it another way, simply loading a built-in module's library no
+longer modifies 'erc-mode-map'. Instead, modifications occur during
+module setup. This should not impact most user configs since ERC
+doesn't bother with keys already taken and only removes bindings it's
+previously created. Note that while all affected bindings still
+reside in 'erc-mode-map', future built-in modules will use their own
+minor-mode maps, and new third-party modules should do the same.
+
+** Option 'erc-timestamp-format-right' deprecated.
+Having to account for this option prevented other ERC modules from
+easily determining what right-sided stamps would look like before
+insertion, which is knowledge needed for certain UI decisions. The
+way ERC has chosen to address this is imperfect and boils down to
+asking users who've customized this option to switch to
+'erc-timestamp-format' instead. If you're affected by this and feel
+that some other solution, like automatic migration, is justified,
+please make that known on the bug list.
+
+** Module 'noncommands' deprecated, replaced by 'command-indicator'.
+Command-line echoing has returned to ERC after a near decade-long
+hiatus. This means you can elect to have ERC leave a trail of (most)
+slash-command input submitted at the prompt, in a manner resembling
+that of a shell or a REPL. The particulars are likely of little
+interest to most users, but the gist is that this functionality was
+removed in 5.3.x (Emacs 24.5) without mention in this document or a
+change log. Everything's mostly been restored, except that the
+feature is now opt-in. The only real gotcha is that related faces and
+options, like 'erc-command-indicator', have moved to the 'erc-goodies'
+library, although their Custom groups remain the same. Add
+'command-indicator' to 'erc-modules' to get started.
+
+** Option 'erc-track-faces-normal-list' slightly more influential.
+This option has always been a source of confusion for users, mainly
+because its influence rode heavily on the makeup of faces in a given
+message. Historically, when a buffer's current mode-line face was a
+member of this option's value, ERC would only swap it out for a fellow
+"normal" if it was absent from the message being processed. Beginning
+with this release, ERC now looks to other ranked and, if necessary,
+unranked "normals" instead of sustaining the same face between
+messages. This was done to better honor the stated purpose of the
+option, which is to provide consistent visual feedback when buffer
+activity occurs. If you experience problems with this development,
+see the compatibility flag 'erc-track-ignore-normal-contenders-p'.
+
+** 'erc-button-alist' and 'erc-nick-popup-alist' have evolved slightly.
+It's no secret that the 'buttons' module treats potential nicknames
+specially. This is perhaps most evident in its treatment of the
+'nicknames' entry in 'erc-button-alist'. Indeed, to simplify ERC's
+move to next-gen "rich UI" extensions, this special treatment is being
+canonized. From here on out, this entry will no longer appear in the
+option's default value but will instead be applied implicitly so long
+as the option 'erc-button-buttonize-nicks' is non-nil, which it is by
+default. Relatedly, the option 'erc-nick-popup-alist' now favors
+functions, which ERC calls non-interactively, over arbitrary
+s-expressions, which ERC will continue to honor. Although the default
+lineup remains functionally equivalent, its members have all been
+updated accordingly.
+
+** 'erc-track-faces-priority-list' and 'erc-track-faces-normal-list' slimmed.
+These options have been purged of certain 'button'-related face
+combinations. Originally added in ERC 5.3, these combinations
+described the effect of "buttonizing" atop faces added by the 'match'
+module, like '(erc-nick-default-face erc-pal-face)'. However, since
+at least Emacs 27, 'match' has run before 'button' in
+'erc-insert-modify-hook', meaning such permutations aren't possible.
+
+More importantly, users who've customized either of these options
+should update them with the new default value of the option
+'erc-button-nickname-face'. Like 'erc-nick-default-face', which it
+replaces, the new 'erc-button-nick-default-face' is also a "real"
+face. Its sole reason for existing is to make it easier for users and
+modules to distinguish between basic buttonized faces and
+'erc-nick-default-face', which is now reserved to mean the base
+"speaker" face.
+
+** Option 'erc-query-on-unjoined-chan-privmsg' restored and renamed.
+This option was accidentally removed from the default client in ERC
+5.5 and was thus prevented from influencing PRIVMSG routing. It's now
+been restored with a slightly revised role contingent on a few
+assumptions explained in its doc string. For clarity, it has been
+renamed 'erc-ensure-target-buffer-on-privmsg'.
+
+** A smarter, more responsive prompt.
+ERC's prompt can be told to respond dynamically to incoming and
+outgoing messages by leveraging the familiar function variant of the
+option 'erc-prompt'. With this release, only predefined functions can
+take full advantage of this new dynamism, but an interface to empower
+third parties with the same possibilities may follow suit. To get
+started, customize 'erc-prompt' to 'erc-prompt-format', and see the
+option of the same name ('erc-prompt-format') for a rudimentary
+templating facility reminiscent of 'erc-mode-line-format'.
+
+** Module 'scrolltobottom' now optionally more aggressive.
+Enabling the experimental option 'erc-scrolltobottom-all' makes ERC
+more vigilant about staking down the input area in all ERC windows.
+And the option's 'relaxed' variant makes ERC's prompt stationary
+wherever it happens to reside instead of forcing it to the bottom of a
+window, meaning new input appears above the prompt, scrolling existing
+messages upward to compensate.
+
+** Subtle changes in two fundamental faces.
+Users of the default theme may notice that 'erc-action-face' and
+'erc-notice-face' now appear slightly less bold on systems supporting
+a weight of 'semi-bold'. This was done to make buttons detectable and
+to spare users from resorting to tweaking these faces, or options like
+'erc-notice-highlight-type', just to achieve this effect. It's
+currently most prominent in "/ME" messages, where 'erc-action-face'
+sits beneath 'erc-input-face', as well as 'erc-my-nick-face' in the
+speaker portion.
+
+** Fewer nick buttons in QUIT, JOIN, and PART messages.
+Common messages that show a nickname followed by a "userhost" often
+end up with redundant buttons because the nick reappears in or is the
+same as the "~user" portion. ERC now tamps down on this to make
+<TAB>ing around more convenient. To opt out, see the new variable
+'erc-button-highlight-nick-once'.
+
+** Improved interplay between buffer truncation and message logging.
+While most of these improvements are subtle, some affect everyday use.
+For example, users of the 'truncate' module may notice that truncation
+now happens between messages rather than arbitrary lines. And those
+with the default 'erc-insert-timestamp-left-and-right' for their
+'erc-insert-timestamp-function' will see date stamps reprinted after
+every "/CLEAR" but omitted from any logs. One notable casualty of
+these changes has been the deprecation of the ancient option
+'erc-truncate-buffer-on-save'. Users of the 'log' module can achieve
+the same effect by issuing a "/CLEAR" at the prompt.
+
+** The 'truncate' module no longer enables logging automatically.
+Users expecting 'truncate' to perform logging based on the option
+'erc-enable-logging' need to instead add 'log' to 'erc-modules' for
+continued integration. Under the original design, merely loading the
+library 'erc-log' caused 'truncate' to start writing logs, possibly
+against a user's wishes.
+
+** The function 'erc-echo-timestamp' is now a command.
+The option 'erc-echo-timestamps' (plural) has always enabled the
+contextual printing of timestamps to the echo area when moving between
+messages in an ERC buffer. Similar functionality is now available on
+demand by invoking the newly interactive function 'erc-echo-timestamp'
+atop any message. The new companion option 'erc-echo-timestamp-zone'
+determines the default timezone when not specified with a prefix
+argument.
+
+** Option 'erc-remove-parsed-property' deprecated.
+This option's nil behavior serves no practical purpose yet has the
+potential to degrade the user experience by competing for space with
+forthcoming features powered by next generation extensions. Anyone
+with a legitimate use for this option likely also possesses the
+knowledge to rig up a suitable analog with minimal effort. That said,
+the road to removal is long.
+
+** The 'track' module always ignores date stamps.
+Users of the stamp module who leave 'erc-insert-timestamp-function'
+set to its default of 'erc-insert-timestamp-left-and-right' will find
+that date stamps no longer affect the mode line, even for IRC commands
+not included in 'erc-track-exclude-types'.
+
+** Option 'erc-warn-about-blank-lines' is more informative.
+Enabled by default, this option now produces more useful feedback
+whenever ERC rejects prompt input containing whitespace-only lines.
+When paired with option 'erc-send-whitespace-lines', ERC echoes a
+tally of blank lines padded and trailing blanks culled.
+
+** A context-dependent mode segment in header and mode lines.
+The "%m" specifier has traditionally expanded to a lone "+" in server
+and query buffers and a string containing all switch modes (plus
+"limit" and "key" args) in channel buffers. It now becomes a string
+of user modes in server buffers and disappears completely in query
+buffers. In channels, it's grown to include all letters and their
+possibly truncated arguments, with the exception of stateful list
+modes, like "b".
+
+** In-buffer "status messages" are now a thing.
+The ancient option 'erc-ensure-target-buffer-on-privmsg' has been
+repurposed slightly to express a third state denoted by the symbol
+'status'. It tells ERC to revert to the old default behavior in which
+separate, "pseudo" target buffers for status-prefixed conversing
+co-existed alongside actual target buffers. Instead of this awkward
+arrangement, ERC now acts like other clients by default and inserts
+so-called "status messages" in situ, right between other messages.
+Similar insertion-routing behavior now also applies to CTCP ACTIONs
+directed at status-prefixed channels. Unfortunately, outgoing "/msg
+@#chan hi" messages aren't yet shown in the same fashion, but the
+groundwork has been laid, making such an addition almost trivial.
+
+** An easier way to see channel-membership prefixes on speakers.
+The option 'erc-format-@nick' has been deprecated in favor of the new
+boolean option 'erc-show-speaker-membership-status', a simple switch
+to enable the displaying of status prefixes on the speaker nicks of
+incoming chat messages. Prefixes on your speaker nick for outgoing
+chat messages continue to always be present.
+
+** Updating user options requires cycling associated minor modes.
+During a live ERC session, you may need to disable and re-enable a
+module's minor mode via 'M-x erc-foo-mode RET' or similar before an
+option's updated value takes effect. This primarily impacts new
+options introduced by this release and existing ones whose behavior
+has changed in some way. At present, ERC does not perform this step
+automatically on your behalf, even if a change was made in a
+'Custom-mode' buffer or via 'setopt'.
+
+** New broadcast-oriented slash commands /AME, /GME, and /GMSG.
+Also available as the library functions 'erc-cmd-AME', 'erc-cmd-GME',
+and 'erc-cmd-GMSG', these new slash commands can prove handy in test
+environments.
+
+** Miscellaneous UX changes.
+Some minor quality-of-life niceties have finally made their way to
+ERC. For example, fool visibility has become togglable with the new
+command 'erc-match-toggle-hidden-fools'. The 'button' module's
+'erc-button-previous' command now moves to the beginning instead of
+the end of buttons. A new command, 'erc-news', can be invoked to
+visit this very file. And the 'irccontrols' module now supports
+additional colors and special handling for "spoilers" (hidden text).
+
+** Changes in the library API.
+
+*** Some top-level dependencies have been removed.
+The library 'erc-goodies' is no longer loaded by ERC's main library.
+This was done to further cement the move toward a unidirectional
+dependency flow begun in 5.5. Additionally, a few barely used and
+newly introduced dependencies are now lazily loaded, which may upset
+some third-party code. The first of these is 'pp' because its
+'pp-to-string' is autoloaded in all supported ERC versions. Also gone
+are 'thingatpt', 'time-date', and 'iso8601'. All were used ultra
+sparingly, and the latter two have only been around for one minor
+release cycle, so their removal hopefully won't cause much churn.
+
+*** Some ERC-applied text properties have changed.
+Chiefly, a new set of metadata-oriented properties, the details of
+which should be considered internal, now occupy the first character of
+all inserted messages, including local notices, date stamps, and
+interactive feedback. These properties will likely form the basis for
+a new message-traversal/insertion/deletion API in future versions.
+Less impactfully, the no-op property 'rear-sticky' has been removed,
+and the value of the 'field' property for ERC's prompt has changed
+from 't' to the more useful 'erc-prompt', although the property of the
+same name has been retained and now has a value of 'hidden' when
+disconnected.
+
+*** Lists of faces in buttonized text are no longer nested.
+Previously, when "buttonizing" a new region, ERC would combine faces
+by blindly consing the new onto the existing. In theory, this kept a
+nice record of all modifications to a given region. However, it also
+complicated life for other modules wanting to analyze and operate on
+these regions. Beginning with this release, ERC now merges combined
+faces together when creating buttons, although the odd nested list may
+still crop up here and there.
+
+*** Members of insert- and send-related hooks have been reordered.
+As anyone reading this is no doubt aware, both built-in and
+third-party modules rely on certain hooks for adjusting incoming and
+outgoing messages upon insertion. And some modules only want to do so
+after others have done their damage. Traditionally, this has required
+various hacks and finagling to achieve. And while this release makes
+an effort to load modules in a more consistent order, that alone isn't
+enough to ensure predictability among essential members of important
+hooks.
+
+Luckily, ERC now leverages a feature introduced in Emacs 27, "hook
+depth," to secure the positions of a few key members of
+'erc-insert-modify-hook' and 'erc-send-modify-hook'. So far, this
+includes the functions 'erc-button-add-buttons', 'erc-match-message',
+'erc-fill', and 'erc-add-timestamp', which now appear in that order,
+when present, at depths beginning at 20 and ending below 80. Of most
+interest to module authors is the new relative positioning of the
+first three, which have been rotated leftward with respect to their
+previous places in recent ERC versions (fill, button, match ,stamp).
+A similar designated range from -80 to -20 also exists and is home to
+the function 'erc-controls-highlight'.
+
+ERC also provisionally reserves the same depth intervals for
+'erc-insert-pre-hook' and possibly other, similar hooks, but will
+continue to modify non-ERC hooks locally whenever possible, especially
+in new code.
+
+*** A singular entry point for inserting messages.
+Displaying "local" messages, like help text and interactive-command
+feedback, in ERC buffers has never been straightforward. As such,
+ancient patterns, like the pairing of preformatted "notice" text with
+ERC's oldest insertion function, 'erc-display-line', still appear
+quite frequently in the wild despite having been largely phased out of
+ERC's own code base in 2002. That this example has endured makes some
+sense because it's probably seen as less cumbersome than fiddling with
+the more powerful and complicated 'erc-display-message'.
+
+The latest twist in this tale comes with this release, for which a
+healthy helping of "pre-insertion" business has permanently ensconced
+itself in none other than 'erc-display-message'. While this would
+seem to put antiquated patterns, like the above mentioned
+'erc-make-notice' combo, at risk of having messages ignored or subject
+to degraded treatment by built-in modules, an adaptive measure has
+been introduced that recasts 'erc-display-line' as a thin wrapper
+around 'erc-display-message'. And though nothing of the sort has been
+done for the lower-level 'erc-display-line-1' (now an obsolete alias
+for 'erc-insert-line'), some last-ditch fallback code has been
+introduced to guarantee baseline functionality. As always, if you
+find these developments disturbing, please say so on the tracker.
+
+*** ERC now manages timestamp-related properties a bit differently.
+For starters, the 'cursor-sensor-functions' text property is absent by
+default unless the option 'erc-echo-timestamps' is already enabled on
+module init. And when present, the property's value no longer
+contains unique closures and thus no longer proves effective for
+traversing inserted messages. For now, ERC only provides an internal
+means of visiting messages, but a public interface is forthcoming.
+Also affecting the 'stamp' module is the deprecation of the function
+'erc-insert-aligned' and its removal from the default client's code.
+In the same library, the function 'erc-munge-invisibility-spec' has
+been renamed to 'erc-stamp--manage-local-options-state' to better
+reflect its purpose. Additionally, the module now merges its
+'invisible' property with existing ones and includes all white space
+around stamps when doing so.
+
+This "propertizing" of surrounding white space extends to all
+'stamp'-applied properties, like 'field', in all intervening space
+between message text and timestamps. Technically, this constitutes a
+breaking change from the perspective of detecting a timestamp's
+bounds. However, ERC has always propertized leading space before
+right-sided stamps on the same line as message text but not before
+those folded onto the next line. Such inconsistency made stamp
+detection overly complex and produced uneven results when toggling
+stamp visibility.
+
+*** Invisible message insertions not automatically made 'intangible'.
+Previously, when 'erc-display-message' and friends spotted the
+'invisible' text property with a value of t anywhere in text to be
+inserted, it would apply that property to the entire message, along
+with a t-valued 'intangible' property. Beginning with ERC 5.6, users
+expecting this behavior will have to instead perform the treatment
+themselves. To help with the transition, a temporary escape hatch has
+been made available to regain this behavior, but its existence is only
+guaranteed for this one minor version alone. See source code in the
+vicinity of 'erc-insert-line' for more.
+
+*** Date stamps have become independent messages.
+ERC now inserts "date stamps" generated from the option
+'erc-timestamp-format-left' as separate, standalone messages. This
+currently only matters if 'erc-insert-timestamp-function' is set to
+its default value of 'erc-insert-timestamp-left-and-right', however
+plans exist to decouple these features. In any case, ERC's near-term
+UI goals require exposing these stamps to existing code designed to
+operate on complete messages. For example, users likely expect date
+stamps to be togglable with 'erc-toggle-timestamps' while also being
+immune to hiding from commands like 'erc-match-toggle-hidden-fools'.
+Before this change, meeting such expectations demanded brittle
+heuristics that checked for the presence of these stamps in the
+leading portion of message bodies as well as special casing to act on
+these areas without inflicting collateral damage.
+
+Despite the rationale, this move admittedly ushers in a heightened
+potential for disruption because third-party members of ERC's
+modification hooks may not take kindly to encountering stamp-only
+messages. They may also expect members of 'erc-insert-pre-hook' and
+'erc-insert-done-hook' to run unconditionally, even though ERC
+suppresses those hooks when inserting date stamps. Third parties may
+also not appreciate that 'erc-timestamp-last-inserted-left' no longer
+records the final trailing newline in 'erc-timestamp-format-left'. If
+these inconveniences prove too encumbering to deal with right away,
+see the escape hatch 'erc-stamp-prepend-date-stamps-p', which should
+help ease the transition. As for detecting these new stamp-only
+messages from members of 'erc-insert-modify-hook' and friends, see the
+function 'erc-stamp-inserting-date-stamp-p'.
+
+*** The role of a module's Custom group is now more clearly defined.
+Associating built-in modules with Custom groups and "provided" library
+features has improved. More specifically, a module's group now enjoys
+the singular purpose of determining where the module's minor mode
+variable lives in the Customize interface. And although ERC is now
+slightly more adept at linking these entities, third-parties are still
+encouraged to keep a module's name aligned with its group's as well as
+the provided feature of its containing library, if only for the usual
+reasons of namespace hygiene and discoverability.
+
+*** The function 'erc-open' no longer uses the 'TGT-LIST' parameter.
+ERC has always used the parameter to initialize the local variable
+'erc-default-recipients', which stores a list of routing targets with
+the topmost considered "active." However, since at least ERC 5.1, a
+buffer and its active target effectively mate for life, making
+'TGT-LIST', in practice, a read-only list of a single target. And
+because that target must also appear as the 'CHANNEL' parameter,
+'TGT-LIST' mainly serves to reinforce 'erc-open's reputation of being
+unruly.
+
+*** ERC supports arbitrary CHANTYPES.
+Specifically, channels can be prefixed with any predesignated
+character, mainly to afford more flexibility to specialty services,
+like bridges to other protocols.
+
+*** 'erc-cmd-HELP' recognizes subcommands.
+Some IRC "slash" commands are hierarchical and require users to
+specify a subcommand to actually carry out anything of consequence.
+Built-in modules can now provide more detailed help for a particular
+subcommand by telling ERC to defer to a specialized handler. This
+facility can be opened up to third parties should any one request it.
+
+*** Message-formatting templates in 'notify' renamed.
+All templates beginning with the prefix "erc-message-english-notify_"
+have been renamed to begin with "erc-message-english-notify-". For
+example, the variable 'erc-message-english-notify_current' is now
+'erc-message-english-notify_current'. The old names have been
+preserved as obsolete aliases.
+
+*** Longtime quasi modules made proper.
+The 'fill' module is now defined by 'define-erc-module'. The same
+goes for ERC's imenu integration, which has 'imenu' now appearing in
+the default value of 'erc-modules'.
+
+*** Function 'erc-get-user-mode-prefix' renamed.
+This utility has been renamed to 'erc-get-channel-membership-prefix'
+to better reflect its role of delivering a formatted "status prefix",
+like "+" (for "voice"), and to avoid confusion with user modes, like
+"+i" (for "invisible"). Additionally, its lone parameter is now
+overloaded to accept an 'erc-channel-user' object as well as a string.
+
+*** Channel-membership table 'erc-channel-users' renamed.
+Distinguishing between 'erc-channel-user' objects and values of the
+'erc-channel-users' (plural) hash-table has been a constant source of
+confusion, even within ERC's own code base. The hash-table's values
+are cons cells whose CDR slot is an 'erc-channel-user'. To help keep
+things sane, 'erc-channel-users' (plural) is now officially being
+redubbed 'erc-channel-members'. Similarly, the utility function
+'erc-get-channel-user' has been renamed to 'erc-get-channel-member'.
+Expect deprecations of the old names to follow in a future release.
+
+*** The 'erc-channel-user' struct has a changed internally.
+The five boolean slots for membership prefixes have been folded
+("encoded") into a single integer slot. However, the old 'setf'-able
+accessors remain available, and the constructor's signature remains
+unchanged. Since third-party code must be recompiled when upgrading
+ERC anyway, users shouldn't experience any churn. The only caveat is
+that third-party code using the literal read-syntax of these objects,
+for example, in unit tests, will have to be updated.
+
+*** Hidden messages contain a preceding rather than trailing newline.
+ERC has traditionally only offered to hide messages involving fools,
+but plans are to make hiding more powerful. Anyone depending on the
+existing behavior should be aware that hidden messages now start and
+end one character earlier, so that hidden line endings precede rather
+than follow accompanying text. However, an escape hatch is available
+in the variable 'erc-legacy-invisible-bounds-p'. It reinstates the
+old behavior, which is unsupported by newer modules and features.
+
+*** 'erc-display-message' optionally combines faces.
+Users may notice that ERC now inserts some important error messages in
+a combination of 'erc-error-face' and 'erc-notice-face'. This is
+merely a consequence of 'erc-display-message' getting smarter about
+how it treats face properties when its 'type' parameter is a list that
+starts with t. Originally, ERC's authors intended to display both
+server-originating and ERC-generated errors in this style, but that
+intent was never realized. Though now possible, the effect has been
+limited to special errors involving usage and internal state. For
+third-party code, the key takeaway is that more 'font-lock-face'
+properties encountered in the wild may be combinations of faces rather
+than lone ones.
+
+*** 'erc-flood-protect' no longer influences input splitting.
+This variable's role has been narrowed to rate limiting only. ERC
+used to suppress protocol line-splitting when its value was nil, but
+that's now handled by setting 'erc-split-line-length' to zero.
+
+*** 'erc-pre-send-functions' visits prompt input post-split.
+ERC now adjusts input lines to fall within allowed length limits
+before showing hook members the result. For compatibility,
+third-party code can request that the final input be adjusted again
+prior to being sent. To facilitate this, the 'erc-input' object
+shared among hook members has gained a 'refoldp' slot. See doc string
+for details.
+
+*** More flexibility in sending and displaying prompt input.
+The abnormal hook 'erc-pre-send-functions' previously married outgoing
+message text to its inserted representation in an ERC target buffer.
+Going forward, users can populate the new slot 'substxt' with
+alternate text to insert in place of the 'string' slot's contents,
+which ERC still sends to the server. This dichotomy lets users
+completely avoid the often fiddly 'erc-send-modify-hook' and friends
+for use cases like language translation and subprotocol encoding.
+
+*** ERC's prompt survives the insertion of user input and messages.
+Previously, ERC's prompt and its input marker disappeared while
+running hooks during message insertion, and the position of its
+"insert marker" (ERC's per-buffer process mark) was inconsistent
+during these spells. To make insertion handling more predictable in
+preparation for incorporating various protocol extensions, the prompt
+and its bounding markers have become perennial fixtures.
+
+To effect this change, small behavioral differences in message
+insertion have been adopted. Crucially, 'erc-insert-marker' now has
+an "insertion type" of t, and 'erc-display-line-1' now calls 'insert'
+instead of 'insert-before-markers. This allows user code running on
+'erc-insert-modify-hook' and 'erc-insert-post-hook' to leave its own
+markers at the actual insertion point instead of resorting to
+workarounds. Message insertion for outgoing messages, in
+'erc-display-msg', remains as before. In rare cases, these changes
+may mean third-party code needs tweaking, for example, requiring the
+use of 'insert-before-markers' instead of 'insert'. As always, users
+feeling unduly inconvenienced by these changes are encouraged to voice
+their concerns on the bug list.
+
+*** Introducing new ways to detect ERC buffer types.
+The old standby 'erc-default-target' has served ERC well for over two
+decades. But a lesser known gotcha affecting its use has always
+haunted an unlucky few, that is, the function has always returned
+non-nil in "unjoined" channel buffers (those that the client has
+parted with or been kicked from). While perhaps not itself a major
+footgun, recessive pitfalls rooted in this subtlety continue to affect
+dependent functions, like 'erc-get-buffer'.
+
+To discourage misuse of 'erc-default-target', ERC 5.6 offers an
+alternative in the function 'erc-target', which is identical to the
+former except for its disregard for "joinedness." As a related bonus,
+the dependent function 'erc-server-buffer-p' is being rebranded as
+'erc-server-or-unjoined-channel-buffer-p'. Unfortunately, this
+release lacks a similar solution for detecting "joinedness" directly,
+but users can turn to 'xor'-ing 'erc-default-target' and 'erc-target'
+as a makeshift kludge.
+
+*** Channel-mode handling has become stricter and more predictable.
+ERC has always processed channel modes using "standardized" letters
+and popular status prefixes. Starting with this release, ERC will
+begin preferring advertised "CHANMODES" when interpreting letters and
+their arguments. To facilitate this transition, the functions
+'erc-set-modes', 'erc-parse-modes', and 'erc-update-modes', have all
+been provisionally deprecated. Expect a new, replacement API for
+handling specific "MODE" types and letters in coming releases. If
+you'd like a say in shaping how this transpires, please share your
+ideas and use cases on the tracker.
+
+*** A better way to define message-formatting templates.
+The functions 'erc-define-catalog-entry' and 'erc-define-catalog' have
+been deprecated in favor of 'erc-define-message-format-catalog', a new
+macro for defining template "catalogs" at the top level of libraries.
+
+*** Interface for determining display names renamed.
+The option 'erc-format-nick-function' has been renamed to
+'erc-speaker-from-channel-member-function' to better reflect its
+actual role. So too has the related function 'erc-format-nick', which
+is now 'erc-determine-speaker-from user'.
+
+*** A template-based approach to formatting inserted chat messages.
+Predicting and influencing how ERC formats messages containing a
+leading "<speaker>" has never been straightforward. The characters
+bracketing the speaker and the faces used for each component have
+always been hard-coded, with 'erc-format-query-as-channel-p' being the
+only knob of any consequence. With this release, ERC begins its
+transition to a unified formatting paradigm that builds upon the
+already familiar "language catalog" templating system. Using a
+separate "speaker catalog" keyed by contextual symbols, like
+'query-privmsg', ERC (and eventually everyone) will more easily be
+able to influence how inserted messages take shape in buffers.
+
+*** New format templates for inserted CTCP ACTION messages.
+In 5.5 and earlier, ERC displayed outgoing CTCP ACTION messages in
+'erc-input-face' alone (before buttonizing). Incoming ACTION messages
+mirrored this, except with 'erc-action-face' throughout. Going
+forward, inserted outgoing "/ME" messages will also incorporate
+'erc-action-face', only underneath 'erc-input-face', with
+'erc-my-nick-face' sitting atop both in the leading "speaker" nickname
+portion (again, pre-buttonizing). This new behavior sidesteps the
+traditional format template 'erc-message-english-ACTION' from the
+default "language catalog" in favor of an entry from the new internal
+"speaker catalog". Users needing to access the old behavior can do so
+by toggling a provided compatibility switch. See source code around
+the function 'erc-send-action' for details.
+
+*** Miscellaneous changes
+In 'erc-button-alist', 'Info-goto-node' has been supplanted by plain
+old 'info', and the "<URL:...>" entry has been removed because it was
+more or less redundant. In all ERC buffers, the "<TAB>" key is now
+bound to a new command, 'erc-tab', that calls 'completion-at-point'
+inside the input area and otherwise dispatches module-specific
+commands, like 'erc-button-next'.
+
+
* Changes in ERC 5.5
** Smarter buffer naming for withstanding collisions.
@@ -80,7 +775,9 @@ can now opt for an improved 'window-noselect' instead. It still
offers the same pronounced visual cue when connecting and joining but
now avoids any hijacking of the active window as well.
-(Edited for ERC 5.5.0.29.1 in Emacs 29.1.)
+Beyond this, additional flexibility is now available for controlling
+the behavior of newly created target buffers during reconnection.
+See the option 'erc-reconnect-display' for more.
** Improved handling of multiline prompt input.
This means better detection and handling of intervening and trailing
@@ -153,8 +850,8 @@ In an effort to help further tame ERC's complexity, the variable
'erc-default-recipients' is now expected to hold but a single target.
As a consequence, functions like 'erc-add-default-channel' that
imagine an alternate, aspirational model of buffer-target relations
-have been deprecated. See Emacs change-log entries from around July
-of 2022 for specifics.
+have been deprecated. For specifics, see entries in Emacs'
+ChangeLog.4 from around June 30, 2022.
A number of less consequential deprecations also debut in this
release. For example, the function 'erc-auto-query' was deemed too
@@ -683,7 +1380,7 @@ reconnection attempts that ERC will make per server.
in seconds, that ERC will wait between successive reconnect attempts.
*** erc-server-send-ping-timeout: Determines when to consider a connection
-stalled and restart it. The default is after 120 seconds.
+stalled and restart it. The default is after 120 seconds.
*** erc-system-name: Determines the system name to use when logging in.
The default is to figure this out by calling `system-name'.
@@ -1644,7 +2341,7 @@ in XEmacs.
Please use M-x customize-variable RET erc-modules RET to change the
default if it does not suite your needs.
-** THe symbol used in `erc-nickserv-passwords' for debian.org IRC servers
+** The symbol used in `erc-nickserv-passwords' for debian.org IRC servers
(formerly called OpenProjects, now FreeNode) has changed from
openprojects to freenode. You may need to update your configuration
for a successful automatic nickserv identification.
@@ -1701,5 +2398,6 @@ along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>.
Local variables:
coding: utf-8
mode: outline
+mode: emacs-news
paragraph-separate: "[ ]*$"
end:
diff --git a/etc/MACHINES b/etc/MACHINES
index 2485619eb0c..3e0628a64d0 100644
--- a/etc/MACHINES
+++ b/etc/MACHINES
@@ -131,6 +131,26 @@ the list at the end of this file.
The earliest release of Haiku that will successfully compile Emacs
is R1/Beta2. For windowing support, R1/Beta3 or later is required.
+** Android
+
+ Emacs is known to run on all Android versions from 2.2 onwards, on
+ Linux kernel 2.26.29 or later.
+
+ Android 2.2 has only been tested on ARM. mips64 has not been
+ tested, but builds. With these exceptions, Emacs is known to run on
+ all supported versions of Android on all supported machines: arm,
+ armv7, arm64, x86, x86_64, and mips.
+
+ See the file java/INSTALL for detailed installation instructions.
+
+ It is also possible to build Emacs for Android systems without using
+ GUI capabilities provided by the Android port. We do not know
+ exactly which configurations this works on, but the installation
+ instructions for such a build should be the same as for any Unix
+ system. (This does in turn imply that such a build must be carried
+ out on an Android device itself utilizing development tools provided
+ by third party package repositories.)
+
* Obsolete platforms
diff --git a/etc/NEWS b/etc/NEWS
index 4695bcc5334..6cefe11a2cc 100644
--- a/etc/NEWS
+++ b/etc/NEWS
@@ -1,75 +1,50 @@
GNU Emacs NEWS -- history of user-visible changes.
-Copyright (C) 2021-2024 Free Software Foundation, Inc.
+Copyright (C) 2022-2024 Free Software Foundation, Inc.
See the end of the file for license conditions.
Please send Emacs bug reports to 'bug-gnu-emacs@gnu.org'.
If possible, use 'M-x report-emacs-bug'.
-This file is about changes in Emacs version 29.
+This file is about changes in Emacs version 30.
See file HISTORY for a list of GNU Emacs versions and release dates.
-See files NEWS.28, NEWS.27, ..., NEWS.18, and NEWS.1-17 for changes
+See files NEWS.29, NEWS.28, ..., NEWS.18, and NEWS.1-17 for changes
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'.
-* Installation Changes in Emacs 29.4
+* Installation Changes in Emacs 30.1
-
-* Startup Changes in Emacs 29.4
++++
+** Emacs has been ported to the Android operating system.
+This requires Emacs to be compiled on another computer. The Android
+NDK, SDK, and a suitable Java compiler must also be installed.
-
-* Changes in Emacs 29.4
+See the file 'java/INSTALL' for more details.
-
-* Editing Changes in Emacs 29.4
+---
+** Native compilation is now enabled by default.
+'configure' will enable the Emacs Lisp native compiler, so long as
+libgccjit is present and functional on the system. To disable native
+compilation, configure Emacs with the option:
-
-* Changes in Specialized Modes and Packages in Emacs 29.4
+ ./configure --with-native-compilation=no
-
-* New Modes and Packages in Emacs 29.4
-
-
-* Incompatible Lisp Changes in Emacs 29.4
+---
+** Emacs now defaults to ossaudio library for sound on NetBSD and OpenBSD.
+Previously configure used ALSA libraries if installed on the
+system when configured '--with-sound=yes' (which is the default), with
+fallback to libossaudio. The libossaudio library included with the
+base system is now used even if ALSA is found to avoid relying on
+external packages and to resolve potential incompatibilities between
+Linux and BSD versions of ALSA. Use '--with-sound=alsa' to build with
+ALSA on these operating systems instead.
-* Lisp Changes in Emacs 29.4
-
-
-* Changes in Emacs 29.4 on Non-Free Operating Systems
-
-
-* Changes in Emacs 29.3
-Emacs 29.3 is an emergency bugfix release intended to fix several
-security vulnerabilities described below.
-
-** Arbitrary Lisp code is no longer evaluated as part of turning on Org mode.
-This is for security reasons, to avoid evaluating malicious Lisp code.
-
-** New buffer-local variable 'untrusted-content'.
-When this is non-nil, Lisp programs should treat buffer contents with
-extra caution.
-
-** Gnus now treats inline MIME contents as untrusted.
-To get back previous insecure behavior, 'untrusted-content' should be
-reset to nil in the buffer.
-
-** LaTeX preview is now by default disabled for email attachments.
-To get back previous insecure behavior, set the variable
-'org--latex-preview-when-risky' to a non-nil value.
-
-** Org mode now considers contents of remote files to be untrusted.
-Remote files are recognized by calling 'file-remote-p'.
-
-
-* Installation Changes in Emacs 29.2
-
-
-* Startup Changes in Emacs 29.2
+* Startup Changes in Emacs 30.1
** On GNU/Linux, Emacs is now the default application for 'org-protocol'.
Org mode provides a way to quickly capture bookmarks, notes, and links
@@ -85,4303 +60,2252 @@ URI scheme. See the Org mode manual, Info node "(org) Protocols" for
more details.
-* Changes in Emacs 29.2
-
-This is a bug-fix release with no new features.
-
-
-* Changes in Specialized Modes and Packages in Emacs 29.2
-
-** Tramp
-
-*** New user option 'tramp-show-ad-hoc-proxies'.
-When non-nil, ad-hoc definitions are kept in remote file names instead
-of showing the shortcuts.
-
-
-* Incompatible Lisp Changes in Emacs 29.2
-
-** 'with-sqlite-transaction' rolls back changes if its BODY fails.
-If the BODY of the macro signals an error, or committing the results
-of the transaction fails, the changes will now be rolled back.
-
-
-* Installation Changes in Emacs 29.1
-
-** Ahead-of-time native compilation can now be requested via configure.
-Use '--with-native-compilation=aot' to request that all the Lisp files
-in the Emacs tree should be natively compiled ahead of time. (This is
-slow on most machines.)
-
-This feature existed in Emacs 28.1, but was less easy to request.
-
-** Emacs can be built with the tree-sitter parsing library.
-This library, together with separate grammar libraries for each
-language, provides incremental parsing capabilities for several
-popular programming languages and other formatted files. Emacs built
-with this library offers major modes, described elsewhere in this
-file, that are based on the tree-sitter's parsers. If you have the
-tree-sitter library installed, the configure script will automatically
-include it in the build; use '--without-tree-sitter' at configure time
-to disable that.
-
-Emacs modes based on the tree-sitter library require an additional
-grammar library for each mode. These grammar libraries provide the
-tree-sitter library with language-specific lexical analysis and
-parsing capabilities, and are developed separately from the
-tree-sitter library itself. If you don't have a grammar library
-required by some Emacs major mode, and your distro doesn't provide it
-as an installable package, you can compile and install such a library
-yourself. Many libraries can be downloaded from the tree-sitter site:
-
- https://github.com/tree-sitter
-
-Emacs provides a user command, 'treesit-install-language-grammar',
-that automates the download and build process of a grammar library.
-It prompts for the language, the URL of the language grammar's VCS
-repository, and then uses the installed C/C++ compiler to build the
-library and install it.
-
-You can also do this manually. To compile such a library after
-cloning its Git repository, compile the files "scanner.c" and
-"parser.c" (sometimes named "scanner.cc" and "parser.cc") in the "src"
-subdirectory of the library's source tree using the C or C++ compiler,
-then link these two files into a shared library named
-"libtree-sitter-LANG.so" ("libtree-sitter-LANG.dll" on MS-Windows,
-"libtree-sitter-LANG.dylib" on macOS), where LANG is the name of the
-language supported by the grammar as it is expected by the Emacs major
-mode (for example, "c" for 'c-ts-mode', "cpp" for 'c++-ts-mode',
-"python" for 'python-ts-mode', etc.). Then place the shared library
-you've built in the same directory where you keep the other shared
-libraries used by Emacs, or in the "tree-sitter" subdirectory of your
-'user-emacs-directory', or in a directory mentioned in the variable
-'treesit-extra-load-path'.
-
-You only need to install language grammar libraries required by the
-Emacs modes you will use, as Emacs loads these libraries only when the
-corresponding mode is turned on in some buffer for the first time in
-an Emacs session.
-
-We generally recommend to use the latest versions of grammar libraries
-available from their sites, as these libraries are in constant
-development and occasionally add features and fix important bugs to
-follow the advances in the programming languages they support.
-
-** Emacs can be built with built-in support for accessing SQLite databases.
-This uses the popular sqlite3 library, and can be disabled by using
-the '--without-sqlite3' option to the 'configure' script.
-
-** Support for the WebP image format.
-This support is built by default when the libwebp library is
-available, and includes support for animated WebP images. To disable
-WebP support, use the '--without-webp' configure flag. Image
-specifiers can now use ':type webp'.
-
-** 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-<fingerprint>.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 on X now uses 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.
-
-'(featurep 'xinput2)' can be used to test for the presence of XInput 2
-support from Lisp programs.
-
-** Emacs can now be optionally built with the Cairo XCB backend.
-Configure Emacs with the '--with-cairo-xcb' option to use the Cairo
-XCB backend; the default is not to use it. This backend makes Emacs
-moderately faster when running over X connections with high latency,
-but is currently known to crash when Emacs repeatedly closes and opens
-a display connection to the same terminal; this could happen, for
-example, if you repeatedly visit files via emacsclient in a single
-client frame, each time deleting the frame with 'C-x C-c'.
-
-** Emacs now supports being built with pure GTK.
-To use this option, make sure the GTK 3 (version 3.22.23 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 recommend that you
-use this configuration only if you are running a window system other
-than X that's supported by GDK. 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'. Running this on WSL is also known to have problems.
-
-Note that, unlike the X build of Emacs, the PGTK build cannot
-automatically switch to text-mode interface (thus emulating '-nw') if
-it cannot determine the default display; it will instead complain and
-ask you to invoke it with the explicit '-nw' option.
-
-** 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
-can be enabled by configuring Emacs with the option '--with-be-app',
-which will require the Haiku Application Kit development headers and a
-C++ compiler to be present on your system. If Emacs is not built with
-the option '--with-be-app', the resulting Emacs will only run in
-text-mode terminals.
-
-To enable Cairo support, ensure that the Cairo and FreeType
-development files are present on your system, and configure Emacs with
-'--with-be-cairo'.
-
-Unlike X, there is no compile-time option to enable or disable
-double-buffering; it is always enabled. To disable it, change the
-frame parameter 'inhibit-double-buffering' instead.
-
-** Emacs no longer reduces the size of the Japanese dictionary.
-Building Emacs includes generation of a Japanese dictionary, which is
-used by Japanese input methods. Previously, the build included a step
-of reducing the size of this dictionary's vocabulary. This vocabulary
-reduction is now optional, by default off. If you need the Emacs
-build to include the vocabulary reduction, configure Emacs with the
-option '--with-small-ja-dic'. In an Emacs source tree already
-configured without that option, you can force the vocabulary reduction
-by saying
-
- make -C leim generate-ja-dic JA_DIC_NO_REDUCTION_OPTION=''
-
-after deleting "lisp/leim/ja-dic/ja-dic.el".
-
-** The docstrings of preloaded files are not in "etc/DOC" any more.
-Instead, they're fetched as needed from the corresponding ".elc"
-files, as was already the case for all the non-preloaded files.
-
-
-* Startup Changes in Emacs 29.1
-
-** '--batch' and '--script' now adjust the garbage collection levels.
-These switches now set 'gc-cons-percentage' to 1.0 (up from the
-default of 0.1). This means that batch processes will typically use
-more memory than before, but use less time doing garbage collection.
-Batch jobs that are supposed to run for a long time should adjust the
-limit back down again.
-
-** 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'.
-Use the '--init-directory' command-line option to set
-'user-emacs-directory'.
-
-** Emacs now has a '--fingerprint' option.
-This will output a string identifying the current Emacs build, and exit.
-
-** New hook 'after-pdump-load-hook'.
-This is run at the end of the Emacs startup process, and is meant to
-be used to reinitialize data structures that would normally be done at
-load time.
-
-** Native Compilation
-
-*** New command 'native-compile-prune-cache'.
-This command deletes old subdirectories of the eln cache (but not the
-ones for the current Emacs version). Note that subdirectories of the
-system directory where the "*.eln" files are installed (usually, the
-last entry in 'native-comp-eln-load-path') are not deleted.
-
-*** New function 'startup-redirect-eln-cache'.
-This function can be called in your init files to change the
-user-specific directory where Emacs stores the "*.eln" files produced
-by native compilation of Lisp packages Emacs loads. The default
-eln cache directory is unchanged: it is the "eln-cache" subdirectory
-of 'user-emacs-directory'.
-
-
-* Incompatible changes in Emacs 29.1
-
-** The image commands have changed key bindings.
-In previous Emacs versions, the '+', '-' and 'r' keys were bound when
-point was over an image. In Emacs 29.1, additional commands have been
-added, and this made it more likely that users would trigger the image
-commands by mistake. To avoid this, all image commands have been
-moved to the 'i' prefix keymap, so '+' is now 'i +', '-' is now 'i -',
-and 'r' is now 'i r'. In addition, these commands are now repeating,
-so you can rotate an image twice by saying 'i r r', for instance.
-
-** Emacs now picks the correct coding-system for X input methods.
-Previously, Emacs would use 'locale-coding-system' for input
-methods, which could in some circumstances be incorrect, especially
-when the input method chose to fall back to some other coding system.
-
-Emacs now automatically detects the coding-system used by input
-methods, and uses that to decode input in preference to the value of
-'locale-coding-system'. This unfortunately means that users who have
-changed the coding system used to decode X keyboard input must adjust
-their customizations to 'locale-coding-system' to the variable
-'x-input-coding-system' instead.
-
-** Bookmarks no longer include context for encrypted files.
-If you're visiting an encrypted file, setting a bookmark no longer
-includes excerpts from that buffer in the bookmarks file. This is
-implemented by the new hook 'bookmark-inhibit-context-functions',
-where packages can register a function which returns non-nil for file
-names to be excluded from adding such excerpts.
-
-** 'show-paren-mode' is now disabled in 'special-mode' buffers.
-In Emacs versions previous to Emacs 28.1, 'show-paren-mode' defaulted
-off. In Emacs 28.1, the mode was switched on in all buffers. In
-Emacs 29.1, this was changed to be switched on in all editing-related
-buffers, but not in buffers that inherit from 'special-mode'. To go
-back to how things worked in Emacs 28.1, put the following in your
-init file:
-
- (setopt show-paren-predicate t)
-
-** Explicitly-set read-only state is preserved when reverting a buffer.
-If you use the 'C-x C-q' command to change the read-only state of the
-buffer and then revert it, Emacs would previously use the file
-permission bits to determine whether the buffer should be read-only
-after reverting the buffer. Emacs now remembers the decision made in
-'C-x C-q'.
-
-** The Gtk selection face is no longer used for the region.
-The combination of a Gtk-controlled background and a foreground color
-controlled by the internal Emacs machinery led to low-contrast faces
-in common default setups. Emacs now uses the same 'region' face on
-Gtk and non-Gtk setups.
-
-** 'C-h f' and 'C-h x' may now require confirmation when you press 'RET'.
-If the text in the minibuffer cannot be completed to a single function
-or command, typing 'RET' will not automatically complete to the shortest
-candidate, but will instead ask for confirmation. Typing 'TAB' will
-complete as much as possible, and another 'TAB' will show all the
-possible completions. This allows you to insist on the functions name
-even if Help doesn't appear to know about it, by confirming with a
-second 'RET'.
-
-** Dired
-
-*** 'w' ('dired-copy-filename-as-kill') has changed behavior.
-If there are several files marked, file names containing space and
-quote characters will be quoted "like this".
-
-*** The 'd' command now more consistently skips dot files.
-In previous Emacs versions, commands like 'C-u 10 d' would put the "D"
-mark on the next ten files, no matter whether they were dot files
-(i.e., "." and "..") or not, while marking the next ten lines with the
-mouse (in 'transient-mark-mode') and then hitting 'd' would skip dot
-files. These now work equivalently.
-
-** Warning about "eager macro-expansion failure" is now an error.
-
-** Previously, the X "reverseVideo" value at startup was heeded for all frames.
-This meant that if you had a "reverseVideo" resource on the initial
-display, and then opened up a new frame on a display without any
-explicit "reverseVideo" setting, it would get heeded there, too. (This
-included terminal frames.) In Emacs 29, the "reverseVideo" X resource
-is handled like all the other X resources, and set on a per-frame basis.
-
-** 'E' in 'query-replace' now edits the replacement with exact case.
-Previously, this command did the same as 'e'.
-
-** '/ a' in "*Packages*" buffer now limits by archive name(s) instead of regexp.
-
-** Setting the goal columns now also affects '<prior>' and '<next>'.
-Previously, 'C-x C-n' only affected 'next-line' and 'previous-line',
-but it now also affects 'scroll-up-command' and 'scroll-down-command'.
-
-** 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 '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 actually 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 '<backtab>' are now bound in 'button-map'.
-This means that if point 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.
-
-** 'outline-minor-mode-cycle-map' is now parent of 'outline-minor-mode'.
-Instead of adding text property 'keymap' with 'outline-minor-mode-cycle'
-on outline headings in 'outline-minor-mode', the keymap
-'outline-minor-mode-cycle' is now active in the whole buffer.
-But keybindings in 'outline-minor-mode-cycle' still take effect
-only on outline headings because they are bound with the help of
-'outline-minor-mode-cycle--bind' that checks if point is on a heading.
-
-** 'Info-default-directory-list' is no longer populated at Emacs startup.
-If you have code in your init file that removes directories from
-'Info-default-directory-list', this will no longer work.
-
-** 'C-k' no longer deletes files in 'ido-mode'.
-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)
-
-** New user option 'term-clear-full-screen-programs'.
-By default, term.el will now work like most terminals when displaying
-full-screen programs: When they exit, the output is cleared, leaving
-what was displayed in the window before the programs started. Set
-this user option to nil to revert back to the old behavior.
-
-** Support for old EIEIO functions is not autoloaded any more.
-You need an explicit '(require 'eieio-compat)' to use 'defmethod'
-and 'defgeneric' (which were made obsolete in Emacs 25.1 by
-'cl-defmethod' and 'cl-defgeneric').
-Similarly you might need to '(require 'eieio-compat)' before loading
-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.
-
-** 'C-x 8 =' has been moved to 'C-x 8 = ='.
-You can now use 'C-x 8 =' to insert several characters with macron;
-for example, 'C-x 8 = a' will insert U+0101 LATIN SMALL LETTER A WITH
-MACRON. To insert a lone macron, type 'C-x 8 = =' instead of the
-previous 'C-x ='.
-
-** Eshell
-
-*** Eshell's PATH is now derived from 'exec-path'.
-For consistency with remote connections, Eshell now uses 'exec-path'
-to determine the execution path on the local or remote system, instead
-of using the PATH environment variable directly.
-
-*** '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.
-
-*** Eshell pipelines now only pipe stdout by default.
-To pipe both stdout and stderr, use the '|&' operator instead of '|'.
-
-** The 'delete-forward-char' command now deletes by grapheme clusters.
-This command is by default bound to the '<Delete>' function key
-(a.k.a. '<deletechar>'). When invoked without a prefix argument or
-with a positive prefix numeric argument, the command will now delete
-complete grapheme clusters produced by character composition. For
-example, if point is before an Emoji sequence, pressing '<Delete>'
-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.
-
-** Functions that recreate the "*scratch*" buffer now also initialize it.
-When functions like 'other-buffer' and 'server-execute' recreate
-"*scratch*", they now also insert 'initial-scratch-message' and set
-the major mode according to 'initial-major-mode', like at Emacs
-startup. Previously, these functions ignored
-'initial-scratch-message' and left "*scratch*" in 'fundamental-mode'.
-
-** Naming of Image-Dired thumbnail files has changed.
-Names of thumbnail files generated when 'image-dired-thumbnail-storage'
-is 'image-dired' now always end in ".jpg". This fixes various issues
-on different platforms, but means that thumbnails generated in Emacs 28
-will not be used in Emacs 29, and vice-versa. If disk space is an
-issue, consider deleting the 'image-dired-dir' directory (usually
-"~/.emacs.d/image-dired/") after upgrading to Emacs 29.
-
-** The 'rlogin' method in the URL library is now obsolete.
-Emacs will now display a warning if you request a URL like
-"rlogin://foo@example.org".
-
-** Setting 'url-gateway-method' to 'rlogin' is now obsolete.
-Emacs will now display a warning when setting it to that value.
-The user options 'url-gateway-rlogin-host',
-'url-gateway-rlogin-parameters', and 'url-gateway-rlogin-user-name'
-are also obsolete.
-
-** The user function 'url-irc-function' now takes a SCHEME argument.
-The user option 'url-irc-function' is now called with a sixth argument
-corresponding to the scheme portion of the target URL. For example,
-this would be "ircs" for a URL like "ircs://irc.libera.chat".
-
-** The linum.el library is now obsolete.
-We recommend using either the built-in 'display-line-numbers-mode', or
-the 'nlinum' package from GNU ELPA instead. The former has better
-performance, but the latter is closer to a drop-in replacement.
-
-1. To use 'display-line-numbers-mode', add something like this to your
- init file:
-
- (global-display-line-numbers-mode 1)
- ;; Alternatively, to use it only in programming modes:
- (add-hook 'prog-mode-hook #'display-line-numbers-mode)
-
-2. To use 'nlinum', add this to your Init file:
-
- (package-install 'nlinum)
- (global-nlinum-mode 1)
- ;; Alternatively, to use it only in programming modes:
- (add-hook 'prog-mode-hook #'nlinum-mode)
-
-3. To continue using the obsolete package 'linum', add this line to
- your Init file, in addition to any existing customizations:
-
- (require 'linum)
-
-** The thumbs.el library is now obsolete.
-We recommend using the 'image-dired' command instead.
-
-** The autoarg.el library is now marked obsolete.
-This library provides the 'autoarg-mode' and 'autoarg-kp-mode' minor
-modes to emulate the behavior of the historical editor Twenex Emacs.
-We believe it is no longer useful.
-
-** The quickurl.el library is now obsolete.
-Use 'abbrev', 'skeleton' or 'tempo' instead.
-
-** The rlogin.el library, and the 'rsh' command are now obsolete.
-Use something like 'M-x shell RET ssh <host> RET' instead.
-
-** The url-about.el library is now obsolete.
-
-** The autoload.el library is now obsolete.
-It is superseded by the new loaddefs-gen.el library.
-
-** The netrc.el library is now obsolete.
-Use the 'auth-source-netrc-parse-all' function in auth-source.el
-instead.
-
-** The url-dired.el library is now obsolete.
-
-** The fast-lock.el and lazy-lock.el libraries have been removed.
-They have been obsolete since Emacs 22.1.
-
-The variable 'font-lock-support-mode' is occasionally useful for
-debugging purposes. It is now a regular variable (instead of a user
-option) and can be set to nil to disable Just-in-time Lock mode.
-
-** The 'utf-8-auto' coding-system now produces BOM on encoding.
-This is actually a bugfix, since this is how 'utf-8-auto' was
-documented from day one; it just didn't behave according to
-documentation. It turns out some Lisp programs were using this
-coding-system on the wrong assumption that the "auto" part means some
-automagic handling of the end-of-line (EOL) format conversion; those
-programs will now start to fail, because BOM signature in UTF-8 encoded
-text is rarely expected. That is the reason we mention this bugfix
-here.
-
-In general, this coding-system should probably never be used for
-encoding, only for decoding.
+* Incompatible Changes in Emacs 30.1
+
+** Tree-Sitter modes are now declared as submodes of the non-TS modes.
+In order to help the use of those Tree-Sitter modes, they are now
+declared to have the corresponding non-Tree-Sitter mode as an
+additional parent.
+This way, things like `.dir-locals.el` settings, and YASnippet
+collections of snippets automatically apply to the new Tree-Sitter modes.
+
+Note that those modes still do not inherit from the non-TS mode, so
+configuration settings installed via mode hooks are not affected.
+
++++
+** URL now never sends user email addresses in HTTP requests.
+Emacs never sent email addresses by default, but it used to be
+possible to customize 'url-privacy-level' so that the users email
+address was sent along in HTTP requests. This feature has now been
+removed, as it was considered more dangerous than useful. RFC 9110
+(§ 10.1.2) also recommends against it. The user option
+'url-personal-mail-address' is now also obsolete.
+
+To send an email address in the header of individual HTTP requests,
+see the variable 'url-request-extra-headers'.
+
++++
+** 'completion-auto-help' now affects 'icomplete-in-buffer'.
+Previously, 'completion-auto-help' mostly affected only minibuffer
+completion. Now, if 'completion-auto-help' has the value 'lazy', then
+Icomplete's in-buffer display of possible completions will only appear
+after the 'completion-at-point' command has been invoked twice, and if
+'completion-auto-help' is nil, then Icomplete's in-buffer display is
+completely suppressed. Thus, if you use 'icomplete-in-buffer', ensure
+'completion-auto-help' is not customized to 'lazy' or nil.
+
++++
+** The "*Completions*" buffer now always accompanies 'icomplete-in-buffer'.
+Previously, it was not consistent whether the "*Completions*" buffer would
+appear when using 'icomplete-in-buffer'. Now the "*Completions*" buffer
+and Icomplete's in-buffer display of possible completions always
+appear together. If you would prefer to see only Icomplete's
+in-buffer display, and not the "*Completions*" buffer, you can add this
+to your init:
+
+ (advice-add 'completion-at-point :after #'minibuffer-hide-completions)
-* Changes in Emacs 29.1
-
-** New user option 'major-mode-remap-alist' to specify favorite major modes.
-This user option lets you remap the default modes (e.g. 'perl-mode' or
-'latex-mode') to your favorite ones (e.g. 'cperl-mode' or
-'LaTeX-mode') instead of having to use 'defalias', which can have
-undesirable side effects.
-This applies to all modes specified via 'auto-mode-alist', file-local
-variables, etc.
-
-** Emacs now supports Unicode Standard version 15.0.
-
-** New user option 'electric-quote-replace-consecutive'.
-This allows you to disable the default behavior of consecutive single
-quotes being replaced with a double quote.
-
-** Emacs is now capable of editing files with very long lines.
-The display of long lines has been optimized, and Emacs should no
-longer choke when a buffer on display contains long lines. The
-variable 'long-line-threshold' controls whether and when these display
-optimizations are in effect.
-
-A companion variable 'large-hscroll-threshold' controls when another
-set of display optimizations are in effect, which are aimed
-specifically at speeding up display of long lines that are truncated
-on display.
-
-If you still experience slowdowns while editing files with long lines,
-this may be due to line truncation, or to one of the enabled minor
-modes, or to the current major mode. Try turning off line truncation
-with 'C-x x t', or try disabling all known slow minor modes with
-'M-x so-long-minor-mode', or try disabling both known slow minor modes
-and the major mode with 'M-x so-long-mode', or visit the file with
-'M-x find-file-literally' instead of the usual 'C-x C-f'.
-
-In buffers in which these display optimizations are in effect, the
-'fontification-functions', 'pre-command-hook' and 'post-command-hook'
-hooks are executed on a narrowed portion of the buffer, whose size is
-controlled by the variables 'long-line-optimizations-region-size' and
-'long-line-optimizations-bol-search-limit', as if they were in a
-'with-restriction' form. This may, in particular, cause occasional
-mis-fontifications in these buffers. Modes which are affected by
-these optimizations and by the fact that the buffer is narrowed,
-should adapt and either modify their algorithm so as not to expect the
-entire buffer to be accessible, or, if accessing outside of the
-narrowed region doesn't hurt performance, use the
-'without-restriction' form to temporarily lift the restriction and
-access portions of the buffer outside of the narrowed region.
-
-The new function 'long-line-optimizations-p' returns non-nil when
-these optimizations are in effect in the current buffer.
-
-** New command to change the font size globally.
-To increase the font size, type 'C-x C-M-+' or 'C-x C-M-='; to
-decrease it, type 'C-x C-M--'; to restore the font size, type 'C-x
-C-M-0'. The final key in these commands may be repeated without the
-leading 'C-x' and without the modifiers, e.g. 'C-x C-M-+ C-M-+ C-M-+'
-and 'C-x C-M-+ + +' increase the font size by three steps. When
-'mouse-wheel-mode' is enabled, 'C-M-wheel-up' and 'C-M-wheel-down' also
-increase and decrease the font size globally. Additionally, the
-user option 'global-text-scale-adjust-resizes-frames' controls whether
-the frames are resized when the font size is changed.
-
-** New config variable 'syntax-wholeline-max' to reduce the cost of long lines.
-This variable is used by some operations (mostly syntax-propertization
-and font-locking) to treat lines longer than this variable as if they
-were made up of various smaller lines. This can help reduce the
-slowdowns seen in buffers made of a single long line, but can also
-cause misbehavior in the presence of such long lines (though most of
-that misbehavior should usually be limited to mis-highlighting). You
-can recover the previous behavior with:
-
- (setq syntax-wholeline-max most-positive-fixnum)
-
-** New bindings in 'find-function-setup-keys' for 'find-library'.
-When 'find-function-setup-keys' is enabled, 'C-x L' is now bound to
-'find-library', 'C-x 4 L' is now bound to 'find-library-other-window'
-and 'C-x 5 L' is now bound to 'find-library-other-frame'.
-
-** New key binding after 'M-x' or 'M-X': 'M-X'.
-Emacs allows different completion predicates to be used with 'M-x'
-(i.e., 'execute-extended-command') via the
-'read-extended-command-predicate' user option. Emacs also has the
-'M-X' (note upper case X) command, which only displays commands
-especially relevant to the current buffer. Emacs now allows toggling
-between these modes while the user is inputting a command by hitting
-'M-X' while in the minibuffer.
-
-** Interactively, 'kill-buffer' will now offer to save the buffer if unsaved.
-
-** New commands 'duplicate-line' and 'duplicate-dwim'.
-'duplicate-line' duplicates the current line the specified number of times.
-'duplicate-dwim' duplicates the region if it is active. If not, it
-works like 'duplicate-line'. An active rectangular region is
-duplicated on its right-hand side. The new user option
-'duplicate-line-final-position' specifies where to move point
-after duplicating a line.
-
-** Files with the ".eld" extension are now visited in 'lisp-data-mode'.
-
-** 'network-lookup-address-info' can now check numeric IP address validity.
-Specifying 'numeric' as the new optional HINTS argument makes it
-check if the passed address is a valid IPv4/IPv6 address (without DNS
-traffic).
-
- (network-lookup-address-info "127.1" 'ipv4 'numeric)
- => ([127 0 0 1 0])
-
-** New command 'find-sibling-file'.
-This command jumps to a file considered a "sibling file", which is
-determined according to the new user option 'find-sibling-rules'.
-
-** New user option 'delete-selection-temporary-region'.
-When non-nil, 'delete-selection-mode' will only delete the temporary
-regions (usually set by mouse-dragging or shift-selection).
-
-** New user option 'switch-to-prev-buffer-skip-regexp'.
-This should be a regexp or a list of regexps; buffers whose names
-match those regexps will be ignored by 'switch-to-prev-buffer' and
-'switch-to-next-buffer'.
-
-** New command 'rename-visited-file'.
-This command renames the file visited by the current buffer by moving
-it to a new name or location, and also makes the buffer visit this new
-file.
-
-** Menus
-
-*** The entries following the buffers in the "Buffers" menu can now be altered.
-Change the 'menu-bar-buffers-menu-command-entries' variable to alter
-the entries that follow the buffer list.
-
-** 'delete-process' is now a command.
-When called interactively, it will kill the process running in the
-current buffer (if any). This can be useful if you have runaway
-output in the current buffer (from a process or a network connection),
-and want to stop it.
-
-** 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 arguments to restart instead of just killing the current
-process.
-
-** Drag and Drop
-
-*** New user option 'mouse-drag-mode-line-buffer'.
-If non-nil, dragging on the buffer name part of the mode-line will
-drag the buffer's associated file to other programs. This option is
-currently only available on X, Haiku and Nextstep (GNUstep or macOS).
-
-*** 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.
-
-*** The value of 'mouse-drag-copy-region' can now be the symbol 'non-empty'.
-This prevents mouse drag gestures from putting empty strings onto the
-kill ring.
-
-*** 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.
-
-*** The X Direct Save (XDS) protocol is now supported.
-This means dropping an image or file link from programs such as
-Firefox will no longer create a temporary file in a random directory,
-instead asking you where to save the file first.
-
-** New user option 'record-all-keys'.
-If non-nil, this option will force recording of all input keys,
-including those typed in response to passwords prompt (this was the
-previous behavior). The default is nil, which inhibits recording of
-passwords.
-
-** New function 'command-query'.
-This function makes its argument command prompt the user for
-confirmation before executing.
-
-** The 'disabled' property of a command's symbol can now be a list.
-The first element of the list should be the symbol 'query', which will
-cause the command disabled this way prompt the user with a y/n or a
-yes/no question before executing. The new function 'command-query' is
-a convenient method of making commands disabled in this way.
-
-** 'count-words' will now report buffer totals if given a prefix.
-Without a prefix, it will only report the word count for the narrowed
-part of the buffer.
-
-** 'count-words' will now report sentence count when used interactively.
-
-** New user option 'set-message-functions'.
-It allows more flexible control of how echo-area messages are displayed
-by adding functions to this list. The default value is a list of one
-element: 'set-minibuffer-message', which displays echo-area messages
-at the end of the minibuffer text when the minibuffer is active.
-Other useful functions include 'inhibit-message', which allows
-specifying, via 'inhibit-message-regexps', the list of messages whose
-display should be inhibited; and 'set-multi-message' that accumulates
-recent messages and displays them stacked together.
-
-** New user option 'find-library-include-other-files'.
-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
-those tables.
-
-** 'write-file' will now copy some file mode bits.
-If the current buffer is visiting a file that is executable, the
-'C-x C-w' command will now make the new file executable, too.
-
-** New user option 'process-error-pause-time'.
-This determines how long to pause Emacs after a process
-filter/sentinel error has been handled.
-
-** New faces for font-lock.
-These faces are primarily meant for use with tree-sitter. They are:
-'font-lock-bracket-face', 'font-lock-delimiter-face',
-'font-lock-escape-face', 'font-lock-function-call-face',
-'font-lock-misc-punctuation-face', 'font-lock-number-face',
-'font-lock-operator-face', 'font-lock-property-name-face',
-'font-lock-property-use-face', 'font-lock-punctuation-face',
-'font-lock-regexp-face', and 'font-lock-variable-use-face'.
-
-** New face 'variable-pitch-text'.
-This face is like 'variable-pitch' (from which it inherits), but is
-slightly larger, which should help with the visual size differences
-between the default, non-proportional font and proportional fonts when
-mixed.
-
-** New face 'mode-line-active'.
-This inherits from the 'mode-line' face, but is the face actually used
-on the mode lines (along with 'mode-line-inactive').
-
-** New face attribute pseudo-value 'reset'.
-This value stands for the value of the corresponding attribute of the
-'default' face. It can be used to reset attribute values produced by
-inheriting from other faces.
-
-** New X resource "borderThickness".
-This controls the thickness of the external borders of the menu bars
-and pop-up menus.
-
-** New X resource "inputStyle".
-This controls the style of the pre-edit and status areas of X input
-methods.
-
-** New X resources "highlightForeground" and "highlightBackground".
-Only in the Lucid build, this controls colors used for highlighted
-menu item widgets.
-
-** On X, Emacs now tries to synchronize window resize with the window manager.
-This leads to less flicker and empty areas of a frame being displayed
-when a frame is being resized. Unfortunately, it does not work on
-some ancient buggy window managers, so if Emacs appears to freeze, but
-is still responsive to input, you can turn it off by setting the X
-resource "synchronizeResize" to "off".
-
-** On X, Emacs can optionally synchronize display with the graphics hardware.
-When this is enabled by setting the X resource "synchronizeResize" to
-"extended", frame content "tearing" is drastically reduced. This is
-only supported on the Motif, Lucid, and no-toolkit builds, and
-requires an X compositing manager supporting the extended frame
-synchronization protocol (see
-https://fishsoup.net/misc/wm-spec-synchronization.html).
-
-This behavior can be toggled on and off via the frame parameter
-'use-frame-synchronization'.
-
-** New frame parameter 'alpha-background' and X resource "alphaBackground".
-This controls the opacity of the text background when running on a
-composited display.
-
-** New frame parameter 'shaded'.
-With window managers which support this, it controls whether or not a
-frame's contents will be hidden, leaving only the title bar on display.
-
-** New user option 'x-gtk-use-native-input'.
-This controls whether or not GTK input methods are used by Emacs,
-instead of XIM input methods. Defaults to nil.
-
-** New user option 'use-system-tooltips'.
-This controls whether to use the toolkit tooltips, or Emacs's own
-native implementation of tooltips as small frames. This option is
-only meaningful if Emacs was built with GTK+, Nextstep, or Haiku
-support, and 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.
-
-** Non-native tooltips are now supported on Nextstep.
-This means Emacs built with GNUstep or built on macOS is now able to
-display different faces and images inside tooltips when the
-'use-system-tooltips' user option is nil.
-
-** New minor mode 'pixel-scroll-precision-mode'.
-When enabled, and if your mouse supports it, you can scroll the
-display up or down at pixel resolution, according to what your mouse
-wheel reports. Unlike 'pixel-scroll-mode', this mode scrolls the
-display pixel-by-pixel, as opposed to only animating line-by-line
-scrolls.
-
-** Terminal Emacs
-
-*** Emacs will now use 24-bit colors on terminals that support "Tc" capability.
-This is in addition to previously-supported ways of discovering 24-bit
-color support: either via the "RGB" or "setf24" capabilities, or if
-the 'COLORTERM' environment variable is set to the value "truecolor".
-
-*** Select active regions with xterm selection support.
-On terminals with xterm "setSelection" support, the active region may be
-saved to the X primary selection, following the
-'select-active-regions' variable. This support is enabled when
-'tty-select-active-regions' is non-nil.
-
-*** New command to set up display of unsupported characters.
-The new command 'standard-display-by-replacement-char' produces Lisp
-code that sets up the 'standard-display-table' to use a replacement
-character for display of characters that the text-mode terminal
-doesn't support. This code is intended to be used in your init files.
-This feature is most useful with the Linux console and similar
-terminals, where Emacs has a reliable way of determining which
-characters have glyphs in the font loaded into the terminal's memory.
-
-*** New functions to set terminal output buffer size.
-The new functions 'tty--set-output-buffer-size' and
-'tty--output-buffer-size' allow setting and retrieving the output
-buffer size of a terminal device. The default buffer size is and has
-always been BUFSIZ, which is defined in your system's stdio.h. When
-you set a buffer size with 'tty--set-output-buffer-size', this also
-prevents Emacs from explicitly flushing the tty output stream, except
-at the end of display update.
-
-** ERT
-
-*** New ERT variables 'ert-batch-print-length' and 'ert-batch-print-level'.
-These variables will override 'print-length' and 'print-level' when
-printing Lisp values in ERT batch test results.
-
-*** Redefining an ERT test in batch mode now signals an error.
-Executing 'ert-deftest' with the same name as an existing test causes
-the previous definition to be discarded, which was probably not
-intended when this occurs in batch mode. To remedy the error, rename
-tests so that they all have unique names.
-
-*** ERT can generate JUnit test reports.
-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.
+* Changes in Emacs 30.1
-*** Unbound test symbols now signal an 'ert-test-unbound' error.
-This affects the 'ert-select-tests' function and its callers.
+** 'describe-function' now shows the type of the function object.
+The text used to say things like "car is is a built-in function"
+whereas it now says "car is a primitive-function" where "primitive-function"
+is the symbol returned by `cl-type-of` and you can click on it to get
+information about that type.
-** Emoji
+** 'advice-remove' is now an interactive command.
+When called interactively, 'advice-remove' now prompts for an advised
+function to the advice to remove.
-*** Emacs now has several new methods for inserting Emoji.
-The Emoji commands are under the new 'C-x 8 e' prefix.
+** Emacs now supports Unicode Standard version 15.1.
-*** New command 'emoji-insert' (bound to 'C-x 8 e e' and 'C-x 8 e i').
-This command guides you through various Emoji categories and
-combinations in a graphical menu system.
+** Network Security Manager
-*** New command 'emoji-search' (bound to 'C-x 8 e s').
-This command lets you search for and insert an Emoji based on names.
++++
+*** The Network Security Manager now warns about 3DES by default.
+This cypher is no longer recommended owing to a major vulnerability
+disclosed in 2016, and its small 112 bit key size. Emacs now warns
+about its use also when 'network-security-level' is set to 'medium'
+(the default). See 'network-security-protocol-checks'.
-*** New command 'emoji-list' (bound to 'C-x 8 e l').
-This command lists all Emoji (categorized by themes) in a special
-buffer and lets you choose one of them to insert.
-
-*** New command 'emoji-recent' (bound to 'C-x 8 e r').
-This command lets you choose among the Emoji you have recently
-inserted and insert it.
-
-*** New command 'emoji-describe' (bound to 'C-x 8 e d').
-This command will tell you the name of the Emoji at point. (It also
-works for non-Emoji characters.)
-
-*** New commands 'emoji-zoom-increase' and 'emoji-zoom-decrease'.
-These are bound to 'C-x 8 e +' and 'C-x 8 e -', respectively. They
-can be used on any character, but are mainly useful for Emoji.
-
-*** New command 'emoji-zoom-reset'.
-This is bound to 'C-x 8 e 0', and undoes any size changes performed by
-'emoji-zoom-increase' and 'emoji-zoom-decrease'.
-
-*** New input method 'emoji'.
-This allows you to enter Emoji using short strings, eg ':face_palm:'
-or ':scream:'.
+---
+*** The Network Security Manager now warns about <2048 bits in DH key exchange.
+Emacs used to warn for Diffie-Hellman key exchanges with prime numbers
+smaller than 1024 bits. Since more servers now support it, this
+number has been bumped to 2048 bits.
** Help
-*** Variable values displayed by 'C-h v' in "*Help*" are now fontified.
-
-*** New user option 'help-clean-buttons'.
-If non-nil, link buttons in "*Help*" buffers will have any surrounding
-quotes removed.
+*** 'describe-function' shows function inferred type when available.
+For native compiled Lisp functions 'describe-function' prints (after
+the signature) the automatically inferred function type as well.
-*** 'M-x apropos-variable' output now includes values of variables.
-Such an apropos buffer is more easily viewed with outlining after
-enabling 'outline-minor-mode' in 'apropos-mode'.
+---
+*** New user option 'describe-bindings-outline-rules'.
+This user option controls outline visibility in the output buffer of
+'describe-bindings' when 'describe-bindings-outline' is non-nil.
-*** New docstring syntax to indicate that symbols shouldn't be links.
-When displaying docstrings in "*Help*" buffers, strings that are
-"`like-this'" are made into links (if they point to a bound
-function/variable). This can lead to false positives when talking
-about values that are symbols that happen to have the same names as
-functions/variables. To inhibit this buttonification, use the new
-"\\+`like-this'" syntax.
-
-*** New user option 'help-window-keep-selected'.
-If non-nil, commands to show the info manual and the source will reuse
-the same window in which the "*Help*" buffer is shown.
-
-*** 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 <open>, C-x C-f, <menu-bar> <file> <new-file>.
-
-This has been changed to:
-
- It is bound to <open> 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 was 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 is 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 back the old behavior.
-
-*** Jumping to function/variable source now saves mark before moving point.
-Jumping to source from a "*Help*" buffer moves point when the source
-buffer is already open. Now, the old point is pushed onto mark ring.
-
-*** New key bindings in "*Help*" buffers: 'n' and 'p'.
-These will take you (respectively) to the next and previous "page".
-
-*** 'describe-char' now also outputs the name of Emoji sequences.
-
-*** New key binding in "*Help*" buffer: 'I'.
-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.
-
-*** 'describe-keymap' now considers the symbol at point.
-If the symbol at point is a keymap, 'describe-keymap' suggests it as
-the default candidate.
-
-*** New command 'help-quick' displays an overview of common commands.
-The command pops up a buffer at the bottom of the screen with a few
-helpful commands for various tasks. You can toggle the display using
-'C-h C-q'.
-
-** Emacs now comes with Org v9.6.
-See the file "etc/ORG-NEWS" for user-visible changes in Org.
+---
+*** 'C-h m' ('describe-mode') uses outlining by default.
+Set 'describe-mode-outline' to nil to get back the old behavior.
** 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 initially, after Outline mode is turned on.
-When the value is a number, the user option 'outline-default-rules'
-determines the visibility of the subtree starting at the corresponding
-level. Values are provided to control showing a heading subtree
-depending on whether the heading matches a regexp, or on whether its
-subtree has long lines or is itself too long.
-
-** Outline Minor Mode
-
-*** New user option 'outline-minor-mode-use-buttons'.
-If non-nil, Outline Minor Mode will use buttons to hide/show outlines
-in addition to the ellipsis. The default is nil, but in 'help-mode'
-it has the value 'insert' that inserts the buttons directly into the
-buffer, and you can use 'RET' to cycle outline visibility. When
-the value is 'in-margins', Outline Minor Mode uses the window margins
-for buttons that hide/show outlines.
-
-*** Buttons and headings now have their own keymaps.
-'outline-button-icon-map', 'outline-overlay-button-map', and
-'outline-inserted-button-map' are now available as defined keymaps
-instead of being anonymous keymaps.
++++
+*** 'outline-minor-mode' is supported in tree-sitter major modes.
+It can be used in all tree-sitter major modes that set either the
+variable 'treesit-simple-imenu-settings' or 'treesit-outline-predicate'.
+
+** X selection requests are now handled much faster and asynchronously.
+This means it should be less necessary to disable the likes of
+'select-active-regions' when Emacs is running over a slow network
+connection.
+
+** Emacs now updates invisible frames that are made visible by a compositor.
+If an invisible or an iconified frame is shown to the user by the
+compositing manager, Emacs will now redisplay such a frame even though
+'frame-visible-p' returns nil or 'icon' for it. This can happen, for
+example, as part of preview for iconified frames.
+
+---
+** New user option 'menu-bar-close-window'.
+When non-nil, selecting "Close" from the "File" menu or clicking
+"Close" in the tool bar will result in the current window being
+closed, if possible.
+
++++
+** 'write-region-inhibit-fsync' now defaults to t in interactive mode,
+as it has in batch mode since Emacs 24.
+
++++
+** New user option 'remote-file-name-inhibit-delete-by-moving-to-trash'.
+When non-nil, this option suppresses moving remote files to the local
+trash when deleting. Default is nil.
+
+---
+** New user option 'remote-file-name-inhibit-auto-save'.
+If this user option is non-nil, 'auto-save-mode' will not auto-save
+remote buffers. The default is nil.
+
++++
+** New user option 'remote-file-name-access-timeout'.
+When a positive number, this option limits the call of 'access-file'
+for remote files to this number of seconds. Default is nil.
+
++++
+** New user option 'yes-or-no-prompt'.
+This allows the user to customize the prompt that is appended by
+'yes-or-no-p' when asking questions. The default value is
+"(yes or no) ".
+
+---
+** New face 'display-time-date-and-time'.
+This is used for displaying the time and date components of
+'display-time-mode'.
+
+---
+** New icon images for general use.
+Several symbolic icons are added to "etc/images/symbols", including
+plus, minus, check-mark, start, etc.
+
++++
+** Tool bars can now be placed on the bottom on more systems.
+The 'tool-bar-position' frame parameter can be set to 'bottom' on all
+window systems other than Nextstep.
+
++++
+** New global minor mode 'modifier-bar-mode'.
+When this minor mode is enabled, buttons representing modifier keys
+are displayed along the tool bar.
+
++++
+** "d" in the mode line now indicates that the window is dedicated.
+Windows have always been able to be dedicated to a specific buffer;
+see 'window-dedicated-p'. Now the mode line indicates the dedicated
+status of a window, with "d" appearing in the mode line if a window is
+dedicated and "D" if the window is strongly dedicated. This indicator
+appears before the buffer name, and after the buffer modification and
+remote buffer indicators (usually "---" together).
+
++++
+** New command 'toggle-window-dedicated'.
+This makes it easy to interactively mark a specific window as
+dedicated, so it won't be reused by 'display-buffer'. This can be
+useful for complicated window setups. It is bound to 'C-x w d'
+globally.
+
+---
+** New user option 'uniquify-dirname-transform'.
+This can be used to customize how buffer names are uniquified, by
+making arbitrary transforms on the buffer's directory name (whose
+components are used to uniquify buffer names when they clash). You
+can use this to distinguish between buffers visiting files with the
+same base name that belong to different projects by using the provided
+transform function 'project-uniquify-dirname-transform'.
+
+** 'insert-directory-program' is now a user option.
+On *BSD and macOS systems, this user option now defaults to the "gls"
+executable, if it exists. This should remove the need to change its
+value when installing GNU coreutils using something like ports or
+Homebrew.
+
++++
+** cl-print
+
++++
+*** You can expand the "..." truncation everywhere.
+The code that allowed "..." to be expanded in the "*Backtrace*" buffer
+should now work anywhere the data is generated by 'cl-print'.
+
++++
+*** The 'backtrace-ellipsis' button is replaced by 'cl-print-ellipsis'.
+
++++
+*** hash-tables' contents can be expanded via the ellipsis.
+
++++
+*** Modes can control the expansion via 'cl-print-expand-ellipsis-function'.
+
++++
+*** New setting 'raw' for 'cl-print-compiled'.
+This setting causes byte-compiled functions to be printed in full by
+'prin1'. A button on this output can be activated to disassemble the
+function.
+
++++
+*** There is a new chapter in the CL manual documenting cl-print.el.
+See the Info node "(cl) Printing".
+
+** Modeline elements can now be right-aligned.
+Anything following the symbol 'mode-line-format-right-align' in
+'mode-line-format' will be right-aligned. Exactly where it is
+right-aligned to is controlled by the new user option
+'mode-line-right-align-edge'.
** Windows
-*** New commands 'split-root-window-below' and 'split-root-window-right'.
-These commands split the root window in two, and are bound to 'C-x w 2'
-and 'C-x w 3', respectively. A number of other useful window-related
-commands are now available with key sequences that start with the
-'C-x w' prefix.
-
-*** New display action 'display-buffer-full-frame'.
-This action removes other windows from the frame when displaying a
-buffer on that frame.
-
-*** 'display-buffer' now can set up the body size of the chosen window.
-For example, a 'display-buffer-alist' entry of
-
- (window-width . (body-columns . 40))
-
-will make the body of the chosen window 40 columns wide. For the
-height use 'window-height' and 'body-lines', respectively.
-
-*** 'display-buffer' provides more options for using an existing window.
-The display buffer action functions 'display-buffer-use-some-window' and
-'display-buffer-use-least-recent-window' now honor the action alist
-entry 'window-min-height' as well as the entries listed below to make
-the display of several buffers in a row more amenable.
-
-*** New buffer display action alist entry 'lru-frames'.
-This allows specifying which frames 'display-buffer' should consider
-when using a window that shows another buffer. It is interpreted as
-per the ALL-FRAMES argument of 'get-lru-window'.
-
-*** New buffer display action alist entry 'lru-time'.
-'display-buffer' will ignore windows with a use time higher than this
-when using a window that shows another buffer.
-
-*** New buffer display action alist entry 'bump-use-time'.
-This has 'display-buffer' bump the use time of any window it returns,
-making it a less likely candidate for displaying another buffer.
-
-*** New buffer display action alist entry 'window-min-width'.
-This allows specifying a preferred minimum width of the window used to
-display a buffer.
-
-*** You can specify on which window 'scroll-other-window' operates.
-This is controlled by the new 'other-window-scroll-default' variable,
-which should be set to a function that returns a window. When this
-variable is nil, 'next-window' is used.
-
-** Frames
-
-*** Deleted frames can now be undeleted.
-The 16 most recently deleted frames can be undeleted with 'C-x 5 u' when
-'undelete-frame-mode' is enabled. Without a prefix argument, undelete
-the most recently deleted frame. With a numerical prefix argument
-between 1 and 16, where 1 is the most recently deleted frame, undelete
-the corresponding deleted frame.
+*** New action alist entry 'post-command-select-window' for 'display-buffer'.
+It specifies whether the window of the displayed buffer should be
+selected or deselected at the end of executing the current command.
-*** The variable 'icon-title-format' can now have the value t.
-That value means to use 'frame-title-format' for iconified frames.
-This is useful with some window managers and desktop environments
-which treat changes in frame's title as requests to raise the frame
-and/or give it input focus, or if you want the frame's title to be the
-same no matter if the frame is iconified or not.
++++
+*** New variable 'window-restore-killed-buffer-windows'.
+It specifies how 'set-window-configuration' and 'window-state-put'
+should proceed with windows whose buffer was killed after the
+corresponding configuration or state was recorded.
** Tab Bars and Tab Lines
-*** New user option 'tab-bar-auto-width' to automatically determine tab width.
-This option is non-nil by default, which resizes tab-bar tabs so that
-their width is evenly distributed across the tab bar. A companion
-option 'tab-bar-auto-width-max' controls the maximum width of a tab
-before its name on display is truncated.
+---
+*** New user option 'tab-bar-select-restore-windows'.
+It defines what to do with windows whose buffer was killed
+since the tab was last selected. By default it displays
+a placeholder buffer that provides information about the name
+of the killed buffer that was displayed in that window.
-*** 'C-x t RET' creates a new tab when the provided tab name doesn't exist.
-It prompts for the name of a tab and switches to it, creating a new
-tab if no tab exists by that name.
+---
+*** New user option 'tab-bar-tab-name-format-functions'.
+It can be used to add, remove and reorder functions that change
+the appearance of every tab on the tab bar.
-*** New keymap 'tab-bar-history-mode-map'.
-By default, it contains 'C-c <left>' and 'C-c <right>' to browse
-the history of tab window configurations back and forward.
+---
+*** New hook 'tab-bar-tab-post-select-functions'.
-** 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
-(started by directional formatting control characters such as RLO and
-LRI). The new command 'highlight-confusing-reorderings' finds and
-highlights segments of buffer text whose reordering for display is
-suspicious and could be malicious.
++++
+** New optional argument for modifying directory-local variables.
+The commands 'add-dir-local-variable', 'delete-dir-local-variable' and
+'copy-file-locals-to-dir-locals' now take an optional prefix argument,
+to enter the file you want to modify.
-** Emacs Server and Client
-
-*** New command-line option '-r'/'--reuse-frame' for emacsclient.
-With this command-line option, Emacs reuses an existing graphical client
-frame if one exists; otherwise it creates a new frame.
-
-*** New command-line option '-w N'/'--timeout=N' for emacsclient.
-With this command-line option, emacsclient will exit if Emacs does not
-respond within N seconds. The default is to wait forever.
-
-*** 'server-stop-automatically' can be used to automatically stop the server.
-The Emacs server will be automatically stopped when certain conditions
-are met. The conditions are determined by the argument to
-'server-stop-automatically', which can be 'empty', 'delete-frame' or
-'kill-terminal'.
-
-** Rcirc
-
-*** New command 'rcirc-when'.
-This shows the reception time of the message at point (if available).
-
-*** New user option 'rcirc-cycle-completion-flag'.
-Rcirc now uses the default 'completion-at-point' mechanism. The
-conventional IRC behavior of completing by cycling through the
-available options can be restored by enabling this option.
-
-*** New user option 'rcirc-bridge-bot-alist'.
-If you are in a channel where a bot is responsible for bridging
-between networks, you can use this variable to make these messages
-appear more native. For example, you might set the option to:
-
- (setopt rcirc-bridge-bot-alist '(("bridge" . "{\\(.+?\\)}[[:space:]]+")))
-
-for messages like
-
- 09:47 <bridge> {john} I am not on IRC
-
-to be reformatted into
-
- 09:47 <john> I am not on IRC
-
-*** New formatting commands.
-Most IRC clients (including rcirc) support basic formatting using
-control codes. Under the 'C-c C-f' prefix a few commands have been
-added to insert these automatically. For example, if a region is
-active and 'C-c C-f C-b' is invoked, markup is inserted for the region
-to be highlighted in bold.
+** Miscellaneous
-** Imenu
+---
+*** New face 'appt-notification' for 'appt-display-mode-line'.
+It can be used to customize the look of the appointment notification
+displayed on the mode line when 'appt-display-mode-line' is non-nil.
-*** 'imenu' is now bound to 'M-g i' globally.
+---
+*** Emacs now recognizes shebang lines that pass '-S'/'--split-string' to 'env'.
+When visiting a script that invokes 'env -S INTERPRETER ARGS...' in
+its shebang line, Emacs will now skip over 'env -S' and deduce the
+major mode based on the interpreter after 'env -S'.
-*** New function 'imenu-flush-cache'.
-Use it if you want Imenu to forget the buffer's index alist and
-recreate it anew next time 'imenu' is invoked.
+** Emacs Server and Client
-** Emacs is now capable of abandoning a window's redisplay that takes too long.
-This is controlled by the new variable 'max-redisplay-ticks'. If that
-variable is set to a non-zero value, display of a window will be
-aborted after that many low-level redisplay operations, thus
-preventing Emacs from becoming wedged when visiting files with very
-long lines. The default is zero, which disables the feature: Emacs
-will wait forever for redisplay to finish. (We believe you won't need
-this feature, given the ability to display buffers with very long
-lines.)
+---
+*** 'server-eval-args-left' can be used to pop and eval subsequent args.
+When '--eval' is passed to emacsclient and Emacs is evaluating each
+argument, this variable is set to those arguments not yet evaluated.
+It can be used to 'pop' arguments and process them by the function
+called in the '--eval' expression, which is useful when those
+arguments contain arbitrary characters that otherwise might require
+elaborate and error-prone escaping (to protect them from the shell).
+
++++
+** 'recover-file' can show diffs between auto save file and current file.
+When answering the prompt with "diff" or "=", it now shows the diffs
+between the auto save file and the current file.
+
+---
+** 'ffap-lax-url' now defaults to nil.
+Previously, it was set to t but this broke remote file name detection.
+
++++
+** Multi-character key echo now ends with a suggestion to use Help.
+Customize 'echo-keystrokes-help' to nil to prevent that.
+
++++
+** 'read-passwd' can toggle the visibility of passwords.
+Use 'TAB' in the minibuffer to show or hide the password. Likewise,
+there is an icon on the mode-line, which toggles the visibility of the
+password when clicking with 'mouse-1'.
-* Editing Changes in Emacs 29.1
-
-** 'M-SPC' is now bound to 'cycle-spacing'.
-Formerly it invoked 'just-one-space'. The actions performed by
-'cycle-spacing' and their order can now be customized via the user
-option 'cycle-spacing-actions'.
-
-** 'zap-to-char' and 'zap-up-to-char' are case-sensitive for upper-case chars.
-These commands now behave as case-sensitive for interactive calls when
-they are invoked with an uppercase character, regardless of the value
-of 'case-fold-search'.
-
-** 'scroll-other-window' and 'scroll-other-window-down' now respect remapping.
-These commands (bound to 'C-M-v' and 'C-M-V') used to scroll the other
-windows without looking at customizations in that other window. These
-functions now check whether they have been rebound in the buffer shown
-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:
-
- (cl-flet ((bla (x)
- (* x x)))
- (bla 42))
-
-This change also affects 'cl-macrolet', 'cl-flet*' and
-'cl-symbol-macrolet'.
-
-** New user option 'translate-upper-case-key-bindings'.
-Set this option to nil to inhibit the default translation of upper
-case keys to their lower case variants.
-
-** New command 'ensure-empty-lines'.
-This command increases (or decreases) the number of empty lines before
-point.
-
-** Improved mouse behavior with auto-scrolling modes.
-When clicking inside the 'scroll-margin' or 'hscroll-margin' region,
-point is now moved only when releasing the mouse button. This no
-longer results in a bogus selection, unless the mouse has also been
-dragged.
-
-** 'kill-ring-max' now defaults to 120.
-
-** New user option 'yank-menu-max-items'.
-Customize this option to limit the number of entries in the menu
-"Edit → Paste from Kill Menu". The default is 60.
-
-** New user option 'copy-region-blink-predicate'.
-By default, when copying a region with 'kill-ring-save', Emacs only
-blinks point and mark when the region is not denoted visually, that
-is, when either the region is inactive, or the 'region' face is
-indistinguishable from the 'default' face.
-
-Users who would rather enable blinking unconditionally can now set
-this user option to 'always'. To disable blinking unconditionally,
-either set this option to 'ignore', or set 'copy-region-blink-delay'
-to 0.
-
-** Performing a pinch gesture on a touchpad now increases the text scale.
-
-** Show Paren Mode
-
-*** New user option 'show-paren-context-when-offscreen'.
-When non-nil, if the point is in a closing delimiter and the opening
-delimiter is offscreen, shows some context around the opening
-delimiter in the echo area. The default is nil.
-
-This option can also be set to the symbols 'overlay' or 'child-frame',
-in which case the context is shown in an overlay or child-frame at the
-top-left of the current window. The latter option requires a
-graphical frame. On non-graphical frames, the context is shown in the
-echo area.
-
-** Comint
-
-*** 'comint-term-environment' is now aware of connection-local variables.
-The user option 'comint-terminfo-terminal' and the variable
-'system-uses-terminfo' can now be set as connection-local variables to
-change the terminal used on a remote host.
-
-*** New user option 'comint-delete-old-input'.
-When nil, this prevents comint from deleting the current input when
-inserting previous input using '<mouse-2>'. The default is t, to
-preserve previous behavior.
-
-*** New minor mode 'comint-fontify-input-mode'.
-This minor mode is enabled by default in "*shell*" and "*ielm*"
-buffers. It fontifies input text according to 'shell-mode' or
-'emacs-lisp-mode' font-lock rules. Customize the user options
-'shell-fontify-input-enable' and 'ielm-fontify-input-enable' to nil if
-you don't want to enable input fontification by default.
-
-** Mwheel
-
-*** New user options for alternate wheel events.
-The user options 'mouse-wheel-down-alternate-event' and
-'mouse-wheel-up-alternate-event' as well as the variables
-'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 Changes in Emacs 30.1
+
++++
+** New minor mode 'visual-wrap-prefix-mode'.
+When enabled, continuation lines displayed for a wrapped long line
+will receive a 'wrap-prefix' automatically computed from the line's
+surrounding context, such that continuation lines are indented on
+display as if they were filled with 'M-q' or similar. Unlike 'M-q',
+the indentation only happens on display, and doesn't change the buffer
+text in any way. The global minor mode
+'global-visual-wrap-prefix-mode' enables this minor mode in all
+buffers.
+
+(This minor mode is the 'adaptive-wrap' ELPA package renamed and
+lightly edited for inclusion in Emacs.)
+
++++
+** New user option 'gud-highlight-current-line'.
+When enabled, Gud will visually emphasize the line being executed upon
+pauses in the debugee's execution, such as those occasioned by
+breakpoints being hit.
+
+---
+** New global minor mode 'kill-ring-deindent-mode'.
+When enabled, text being saved to the kill ring will be de-indented by
+the column number at its start. For example, saving the entire
+function call within:
+
+foo ()
+{
+ long_function_with_several_arguments (argument_1_compute (),
+ argument_2_compute (),
+ argument_3_compute ());
+}
+
+will save:
+
+long_function_with_several_arguments (argument_1_compute (),
+ argument_2_compute (),
+ argument_3_compute ())
+
+to the kill ring, omitting the two columns of extra indentation that
+would otherwise be present in the second and third lines of the
+function call.
+
++++
+** Emacs now has better support for touchscreen devices.
+Many touch screen gestures are now implemented and translated into
+mouse or gesture events, and support for tapping tool bar buttons and
+opening menus has been written. Countless packages, such as Dired and
+Custom have been adjusted to better understand touch screen input.
+
+---
+** On X, Emacs now supports input methods which perform "string conversion".
+This means an input method can now ask Emacs to delete text
+surrounding point and replace it with something else, as well as query
+Emacs for surrounding text. If your input method allows you to "undo"
+mistaken compositions, this will now work as well.
+
+---
+** New command 'kill-matching-buffers-no-ask'.
+This works like 'kill-matching-buffers', but without asking for
+confirmation.
+
+---
+** New user option 'duplicate-region-final-position'.
+It controls the placement of point and the region after duplicating a
+region with 'duplicate-dwim'.
+
++++
+** New user option 'mouse-prefer-closest-glyph'.
+When enabled, clicking or dragging with the mouse will put the point
+or start the drag in front of the buffer position corresponding to the
+glyph with the closest X coordinate to the click or start of the drag.
+In other words, if the mouse pointer is in the right half of a glyph,
+point will be put after the buffer position corresponding to that glyph,
+whereas if the mouse pointer is in the left half of a glyph, point
+will be put in front the buffer position corresponding to that glyph.
+By default this is disabled.
** Internationalization
-*** The '<Delete>' function key now allows deleting the entire composed sequence.
-For the details, see the item about the 'delete-forward-char' command
-above.
-
-*** New user option 'composition-break-at-point'.
-Setting it to a non-nil value temporarily disables automatic
-composition of character sequences at point, and thus makes it easier
-to edit such sequences by allowing point to "enter" the composed
-sequence.
-
-*** Support for many old scripts and writing systems.
-Emacs now supports, and has language-environments and input methods,
-for several dozens of old scripts that were used in the past for
-various languages. For each such script Emacs now has font-selection
-and character composition rules, a language environment, and an input
-method. The newly-added scripts and the corresponding language
-environments are:
-
- Tai Tham script and the Northern Thai language environment
-
- Brahmi script and language environment
-
- Kaithi script and language environment
-
- Tirhuta script and language environment
+---
+*** Users in CJK locales can control width of some non-CJK characters.
+Some characters are considered by Unicode as "ambiguous" with respect
+to their display width: either "full-width" (i.e. taking 2 columns on
+display) or "narrow" (taking 1 column). The actual width depends on
+the fonts used for these characters by Emacs or (for text-mode frames)
+by the terminal emulator. Traditionally, font sets in CJK locales
+were set up so as to display these characters as full-width, and thus
+Emacs modified the char-width table in those locales to follow suit.
+Lately, the tendency is to display these characters as narrow. The
+new user option 'cjk-ambiguous-chars-are-wide' allows users to control
+whether Emacs considers these characters as full-width (the default)
+or narrow (if the variable is customized to the nil value).
+
+This setting affects the results of 'string-width' and similar
+functions in CJK locales.
+
+---
+*** New input methods for the Urdu, Pashto, and Sindhi languages.
+These languages are spoken in Pakistan and Afghanistan.
+
+---
+*** New input method "english-colemak".
+This input method supports the Colemak keyboard layout.
+
+*** Additional 'C-x 8' key translations for "æ" and "Æ".
+These characters can now be input with 'C-x 8 a e' and 'C-x 8 A E',
+respectively, in addition to the existing translations 'C-x 8 / e' and
+'C-x 8 / E'.
- Sharada script and language environment
-
- Siddham script and language environment
-
- Syloti Nagri script and language environment
-
- Modi script and language environment
-
- Baybayin script and Tagalog language environment
-
- Hanunoo script and language environment
-
- Buhid script and language environment
-
- Tagbanwa script and language environment
-
- Limbu script and language environment
-
- Balinese script and language environment
-
- Javanese script and language environment
-
- Sundanese script and language environment
-
- Batak script and language environment
-
- Rejang script and language environment
-
- Makasar script and language environment
-
- Lontara script and language environment
-
- Hanifi Rohingya script and language environment
-
- Grantha script and language environment
-
- Kharoshthi script and language environment
-
- Lepcha script and language environment
-
- Meetei Mayek script and language environment
+
+* Changes in Specialized Modes and Packages in Emacs 30.1
- Adlam script and language environment
+---
+** Titdic-cnv
+Most of the variables and functions in the file have been renamed to
+make sure they all use a 'tit-' namespace prefix.
- Mende Kikakui script and language environment
+---
+** Trace
+In batch mode, tracing now sends the trace to stdout.
- Wancho script and language environment
++++
+** Mwheel
+The 'wheel-up/down/left/right' events are now bound unconditionally,
+and the 'mouse-wheel-up/down/left/right-event' variables are thus used
+only to specify the 'mouse-4/5/6/7' events generated by older
+configurations such as X11 when the X server does not support at least
+version 2.1 of the X Input Extension, and 'xterm-mouse-mode'.
+
+** 'xterm-mouse-mode'
+This mode now emits 'wheel-up/down/right/left' events instead of
+'mouse-4/5/6/7' events for the mouse wheel.
+It uses the 'mouse-wheel-up/down/left/right-event'
+variables to decide which button maps to which wheel event (if any).
- Toto script and language environment
+** Info
- Gothic script and language environment
+---
+*** New user option 'Info-url-alist'.
+This user option associates manual names with URLs. It affects the
+'Info-goto-node-web' command. By default, associations for all
+Emacs-included manuals are set. Further associations can be added for
+arbitrary Info manuals.
- Coptic script and language environment
+*** Emacs can now display Info manuals compressed with 'lzip'.
+This requires the 'lzip' program to be installed on your system.
- Mongolian-traditional script and language environment
++++
+** New command 'lldb'.
+Run the LLDB debugger, analogous to the 'gud-gdb' command.
- Mongolian-cyrillic language environment
+** gdb-mi
-*** The "Oriya" language environment was renamed to "Odia".
-This is to follow the change in the official name of the script. The
-'oriya' input method was also renamed to 'odia'. However, the old
-name of the language environment and the input method are still
-supported.
+---
+*** Variable order and truncation can now be configured in 'gdb-many-windows'.
+The new user option 'gdb-locals-table-row-config' allows users to
+configure the order and max length of various properties in the local
+variables buffer when using 'gdb-many-windows'.
-*** New Greek translation of the Emacs tutorial.
-Type 'C-u C-h t' to select it in case your language setup does not do
-so automatically.
+By default, this user option is set to write the properties in the order:
+name, type and value, where the name and type are truncated to 20
+characters, and the value is truncated according to the value of
+'gdb-locals-value-limit'.
-*** New Ukrainian translation of the Emacs tutorial.
+If you want to get back the old behavior, set the user option to the value
-*** New Farsi/Persian translation of the Emacs tutorial.
+ (setopt gdb-locals-table-row-config
+ `((type . 0) (name . 0) (value . ,gdb-locals-value-limit)))
-*** New default phonetic input method for the Tamil language environment.
-The default input method for the Tamil language environment is now
-"tamil-phonetic" which is a customizable phonetic input method. To
-change the input method's translation rules, customize the user option
-'tamil-translation-rules'.
+---
+*** New user option 'gdb-display-io-buffer'.
+If this is nil, 'M-x gdb' will neither create nor display a separate
+buffer for the I/O of the program being debugged, but will instead
+redirect the program's interaction to the GDB execution buffer. The
+default is t, to preserve previous behavior.
-*** New 'tamil99' input method for the Tamil language.
-This supports the keyboard layout specifically designed for the Tamil
-language.
+** Grep
-*** New input method 'slovak-qwerty'.
-This is a variant of the 'slovak' input method, which corresponds to
-the QWERTY Slovak keyboards.
+*** New user option 'grep-use-headings'.
+When non-nil, the output of Grep is split into sections, one for each
+file, instead of having file names prefixed to each line. It is
+equivalent to the "--heading" option of some tools such as 'git grep'
+and 'rg'. The headings are displayed using the new 'grep-heading'
+face.
-*** New input method 'cyrillic-chuvash'.
-This input method is based on the russian-computer input method, and
-is intended for typing in the Chuvash language written in the Cyrillic
-script.
+** Compilation mode
-*** New input method 'cyrillic-mongolian'.
-This input method is for typing in the Mongolian language using the
-Cyrillic script. It is the default input method for the new
-Mongolian-cyrillic language environment, see above.
+---
+*** The 'omake' matching rule is now disabled by default.
+This is because it partly acts by modifying other rules which may
+occasionally be surprising. It can be re-enabled by adding 'omake' to
+'compilation-error-regexp-alist'.
-
-* Changes in Specialized Modes and Packages in Emacs 29.1
+*** Lua errors and stack traces are now recognized.
+Compilation mode now recognizes Lua language errors and stack traces.
+Every Lua error is recognized as a compilation error, and every Lua
+stack frame is recognized as a compilation info.
-** Ecomplete
+** Project
-*** New commands 'ecomplete-edit' and 'ecomplete-remove'.
-These allow you to (respectively) edit and bulk-remove entries from
-the ecomplete database.
++++
+*** New user option 'project-mode-line'.
+When non-nil, display the name of the current project on the mode
+line. Clicking 'mouse-1' on the project name pops up the project
+menu. The default value is nil.
+
+*** New user option 'project-file-history-behavior'.
+Customizing it to 'relativize' makes commands like 'project-find-file'
+and 'project-find-dir' display previous history entries relative to
+the current project.
+
+*** New user option 'project-key-prompt-style'.
+The look of the key prompt in the project switcher has been changed
+slightly. To get the previous one, set this option to 'brackets'.
+
+*** 'project-try-vc' tries harder to find the responsible VCS.
+When 'project-vc-extra-root-markers' is non-nil, and causes a
+subdirectory project to be detected which is not a VCS root, we now
+additionally traverse the parent directories until a VCS root is found
+(if any), so that the ignore rules for that repository are used, and
+the file listing's performance is still optimized.
+
+*** New commands 'project-any-command' and 'project-prefix-or-any-command'.
+The former is now bound to 'C-x p o' by default.
+The latter is designed primarily for use as a value of
+'project-switch-commands'. If instead of a short menu you prefer to
+have access to all keys defined inside 'project-prefix-map', as well
+as global bindings (to run other commands inside the project root),
+you can add this to your init script:
+
+ (setopt project-switch-commands #'project-prefix-or-any-command)
-*** New user option 'ecomplete-auto-select'.
-If non-nil and there's only one matching option, auto-select that.
+** VC
-*** New user option 'ecomplete-filter-regexp'.
-If non-nil, this user option describes what entries not to add to the
-database stored on disk.
+---
+*** Log-Edit buffers now display a tool bar.
+This tool bar contains items for committing log entries and editing or
+generating log entries, among other editing operations.
+
+---
+*** New user option 'vc-git-shortlog-switches'.
+This is a string or a list of strings that specifies the Git log
+switches for shortlogs, such as the one produced by 'C-x v L'.
+'vc-git-log-switches' is no longer used for shortlogs.
+
+---
+*** New value 'no-backend' for user option 'vc-display-status'.
+With this value only the revision number is displayed on the mode-line.
+
+---
+*** Obsolete command 'vc-switch-backend' re-added as 'vc-change-backend'.
+The command was previously obsoleted and unbound in Emacs 28.
+
+*** Support for viewing VC change history across renames.
+When a fileset's VC change history ('C-x v l') ends at a rename, we
+now print the old name(s) and a button which jumps to their history.
+Git and Hg are supported. Naturally, 'vc-git-print-log-follow' should
+be nil for this to work (or '--follow' should not be in
+'vc-hg-print-log-switches', in Hg's case). Unlike when the '--follow'
+switch is used, commands to see the diff of the old revision ('d'),
+check out an old file version ('f') or annotate it right away ('a'),
+also work on revisions which precede renames.
+
+---
+*** 'vc-annotate' now abbreviates the Git revision in the buffer name.
+When using the Git backend, 'vc-annotate' will use an abbreviated
+revision identifier in its buffer name. To restore the previous
+behavior, set 'vc-annotate-use-short-revision' to nil.
+
+*** New option 'vc-git-file-name-changes-switches'.
+It allows tweaking the thresholds for rename and copy detection.
+
+** Diff mode
+
+---
+*** New user option 'diff-refine-nonmodified'.
+When this is non-nil, 'diff-refine' will highlight lines that were added
+or removed in their entirety (as opposed to modified lines, where some
+parts of the line were modified), using the same faces as for
+highlighting the words added and removed within modified lines. The
+default value is nil.
+
++++
+*** 'diff-ignore-whitespace-hunk' can now be applied to all hunks.
+When called with a non-nil prefix argument,
+'diff-ignore-whitespace-hunk' now iterates over all the hunks in the
+current diff, regenerating them without whitespace changes.
+
++++
+*** New user option 'diff-ignore-whitespace-switches'.
+This allows changing which type of whitespace changes are ignored when
+regenerating hunks with 'diff-ignore-whitespace-hunk'. Defaults to
+the previously hard-coded "-b".
+
+*** New command 'diff-apply-buffer' bound to 'C-c RET a'.
+It applies the diff in the entire diff buffer and
+saves all modified file buffers.
-** Auth Source
+** Isearch and Replace
-*** New user option 'auth-source-pass-extra-query-keywords'.
-Whether to recognize additional keyword params, like ':max' and
-':require', as well as accept lists of query terms paired with
-applicable keywords. This disables most known behavioral quirks
-unique to auth-source-pass, such as wildcard subdomain matching.
+*** New command 'replace-regexp-as-diff'.
+It reads a regexp to search for and a string to replace with, then
+displays a buffer with replacements as diffs. After reviewing the
+changes in the output buffer you can apply the replacements as
+a patch to the current file buffer. There are also new commands
+'multi-file-replace-regexp-as-diff' that shows as diffs replacements
+in a list of specified files, and 'dired-do-replace-regexp-as-diff'
+that shows as diffs replacements in the marked files in Dired.
** Dired
-*** 'dired-guess-shell-command' moved from dired-x to dired.
-This means that 'dired-do-shell-command' will now provide smarter
-defaults without first having to require 'dired-x'. See the node
-"(emacs) Shell Command Guessing" in the Emacs manual for more details.
-
-*** 'dired-clean-up-buffers-too' moved from dired-x to dired.
-This means that Dired now offers to kill buffers visiting files and
-dirs when they are deleted in Dired. Before, you had to require
-'dired-x' to enable this behavior. To disable this behavior,
-customize the user option 'dired-clean-up-buffers-too' to nil. The
-related user option 'dired-clean-confirm-killing-deleted-buffers'
-(which see) has also been moved to 'dired'.
-
-*** 'dired-do-relsymlink' moved from dired-x to dired.
-The corresponding key 'Y' is now bound by default in Dired.
-
-*** 'dired-do-relsymlink-regexp' moved from dired-x to dired.
-The corresponding key sequence '% Y' is now bound by default in Dired.
-
-*** 'M-G' is now bound to 'dired-goto-subdir'.
-Before, that binding was only available if the dired-x package was
-loaded.
-
-*** 'dired-info' and 'dired-man' moved from dired-x to dired.
-The 'dired-info' and 'dired-man' commands have been moved from the
-dired-x package to dired. They have also been renamed to
-'dired-do-info' and 'dired-do-man'; the old command names are obsolete
-aliases.
+---
+*** New user option 'dired-movement-style'.
+When non-nil, make 'dired-next-line', 'dired-previous-line',
+'dired-next-dirline', 'dired-prev-dirline' skip empty lines.
+It also controls how to move point when encountering a boundary
+(e.g., if every line is visible, invoking 'dired-next-line' at
+the last line will move to the first line). The default is nil.
+
+*** New user option 'dired-filename-display-length'.
+It is an integer representing the maximum display length of filenames.
+The middle part of a filename whose length exceeds the restriction is
+hidden and an ellipsis is displayed instead. A value of 'window'
+means using the right edge of window as the display restriction. The
+default is nil.
+
+*** New user option 'shell-command-guess-functions'.
+It defines how to populate a list of commands available
+for 'M-!', 'M-&', '!', '&' and the context menu "Open With"
+based on marked files in Dired. Possible backends are
+'dired-guess-default', MIME types, XDG configuration
+and a universal command such as "open" or "start"
+that delegates to the OS.
+
+*** New command 'dired-do-open'.
+This command is bound to "Open" in the context menu; it "opens" the
+marked or clicked on files according to the OS conventions. For
+example, on systems supporting XDG, this runs 'xdg-open' on the
+files.
-The keys 'I' ('dired-do-info') and 'N' ('dired-do-man') are now bound
-in Dired mode by default. The user options 'dired-bind-man' and
-'dired-bind-info' no longer have any effect and are obsolete.
+*** The default value of 'dired-omit-size-limit' was increased.
+After performance improvements to omitting in large directories, the new
+default value is 300k, up from 100k. This means 'dired-omit-mode' will
+omit files in directories whose directory listing is up to 300 kilobytes
+in size.
-To get the old behavior back and unbind these keys in Dired mode, add
-the following to your Init file:
++++
+*** 'dired-listing-switches' handles connection-local values if exist.
+This allows to customize different switches for different remote machines.
- (with-eval-after-load 'dired
- (keymap-set dired-mode-map "N" nil)
- (keymap-set dired-mode-map "I" nil))
+** Registers
-*** New command 'dired-do-eww'.
-This command visits the file on the current line with EWW.
++++
+*** New mode of prompting for register names and showing preview.
+The new user option 'register-use-preview' can be customized to the
+value t or insist to request a different user interface of prompting for
+register names and previewing the registers: Emacs will require
+confirmation for overwriting the value of a register, and will show
+the preview of registers without delay. You can also customize this
+new option to disable the preview completely.
-*** 'browse-url-of-dired-file' can now call the secondary browser.
-When invoked with a prefix arg, this will now call
-'browse-url-secondary-browser-function' instead of the default
-browser. 'browse-url-of-dired-file' is bound to 'W' by default in
-dired mode.
+The default value of 'register-use-preview' preserves the behavior of
+Emacs 29 and before. See the Info node "(emacs) Registers" for more
+details about the new UI and its variants.
-*** New user option 'dired-omit-lines'.
-This is used by 'dired-omit-mode', and now allows you to hide based on
-other things than just the file names.
+** Ediff
-*** 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 'ediff-floating-control-frame'.
+If non-nil, try making the control frame be floating rather than tiled.
-*** 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
-back, say:
+Many X tiling window managers make the Ediff control frame a tiled
+window equal in size to the main Emacs frame, which works poorly.
+This option is useful to set if you use such a window manager.
- (setopt dired-free-space 'separate)
+** Buffer Selection
-*** New user option 'dired-make-directory-clickable'.
-If non-nil (which is the default), hitting 'RET' or 'mouse-1' on
-the directory components at the directory displayed at the start of
-the buffer will take you to that directory.
+---
+*** New user option 'bs-default-action-list'.
+You can now configure how to display the "*buffer-selection*" buffer
+using this new option. (Or set 'display-buffer-alist' directly.)
-*** Search and replace in Dired/Wdired supports more regexps.
-For example, the regexp ".*" will match only characters that are part
-of the file name. Also "^.*$" can be used to match at the beginning
-of the file name and at the end of the file name. This is used only
-when searching on file names. In Wdired this can be used when the new
-user option 'wdired-search-replace-filenames' is non-nil (which is the
-default).
+** Eshell
-** Elisp
++++
+*** New builtin Eshell command 'compile'.
+This command runs another command, sending its output to a compilation
+buffer when the command would output interactively. This can be useful
+when defining aliases so that they produce a compilation buffer when
+appropriate, but still allow piping the output elsewhere if desired.
+For more information, see the "(eshell) Built-ins" node in the Eshell
+manual.
+
++++
+*** Eshell's 'env' command now supports running commands.
+Like in many other shells, Eshell's 'env' command now lets you run a
+command passed as arguments to 'env'. If you pass any initial
+arguments of the form 'VAR=VALUE', 'env' will first set 'VAR' to
+'VALUE' before running the command.
+
+---
+*** Eshell's 'umask' command now supports setting the mask symbolically.
+Now, you can pass an argument like "u+w,o-r" to Eshell's 'umask'
+command, which will give write permission for owners of newly-created
+files and deny read permission for users who are not members of the
+file's group. See the Info node "(coreutils) File permissions" for
+more information on this notation.
+
++++
+*** New special reference type '#<marker POSITION BUFFER>'.
+This special reference type returns a marker at 'POSITION' in
+'BUFFER'. You can insert it by typing or using the new interactive
+command 'eshell-insert-marker'. You can also insert special
+references of any type using the new interactive command
+'eshell-insert-special-reference'. See the "(eshell) Arguments" node
+in the Eshell manual for more details.
+
++++
+*** New splice operator for Eshell dollar expansions.
+Dollar expansions in Eshell now let you splice the elements of the
+expansion in-place using '$@expr'. This makes it easier to fill lists
+of arguments into a command, such as when defining aliases. For more
+information, see the "(eshell) Dollars Expansion" node in the Eshell
+manual.
+
++++
+*** You can now splice Eshell globs in-place into argument lists.
+By setting 'eshell-glob-splice-results' to a non-nil value, Eshell
+will expand glob results in-place as if you had typed each matching
+file name individually. For more information, see the "(eshell)
+Globbing" node in the Eshell manual.
+
++++
+*** Eshell now supports negative numbers and ranges for indices.
+Now, you can retrieve the last element of a list with '$my-list[-1]'
+or get a sublist of elements 2 through 4 with '$my-list[2..5]'. For
+more information, see the "(eshell) Dollars Expansion" node in the
+Eshell manual.
+
++++
+*** Eshell commands can now be explicitly-remote (or local).
+By prefixing a command name in Eshell with a remote identifier, like
+"/ssh:user@remote:whoami", you can now run commands on a particular
+host no matter your current directory. Likewise, you can run a
+command on your local system no matter your current directory via
+"/:whoami". For more information, see the "(eshell) Remote Access"
+node in the Eshell manual.
+
++++
+*** Eshell's '$UID' and '$GID' variables are now connection-aware.
+Now, when expanding '$UID' or '$GID' in a remote directory, the value
+is the user or group ID associated with the remote connection.
+
+---
+*** Eshell now uses 'field' properties in its output.
+In particular, this means that pressing the '<home>' key moves the
+point to the beginning of your input, not the beginning of the whole
+line. If you want to go back to the old behavior, add something like
+this to your configuration:
+
+ (keymap-set eshell-mode-map "<home>" #'eshell-bol-ignoring-prompt)
+
+This also means you no longer need to adjust 'eshell-prompt-regexp'
+when customizing your Eshell prompt.
+
+---
+*** You can now properly unload Eshell.
+Calling '(unload-feature 'eshell)' no longer signals an error, and now
+correctly unloads Eshell and all of its modules.
+
++++
+*** 'eshell-read-aliases-list' is now an interactive command.
+After manually editing 'eshell-aliases-file', you can use this command
+to load the edited aliases.
+
++++
+*** 'rgrep' is now a builtin command.
+Running 'rgrep' in Eshell now uses the Emacs grep facility instead of
+calling external rgrep.
+
++++
+*** If a command exits abnormally, the Eshell prompt now shows its exit code.
+
++++
+*** New user option 'eshell-history-append'.
+If non-nil, each Eshell session will save history by appending new
+entries of that session to the history file rather than overwriting
+the file with the whole history of the session. The default is nil.
-*** New command 'elisp-eval-region-or-buffer' (bound to 'C-c C-e').
-This command evals the forms in the active region or in the whole buffer.
+** Minibuffer and Completions
-*** New commands 'elisp-byte-compile-file' and 'elisp-byte-compile-buffer'.
-These commands (bound to 'C-c C-f' and 'C-c C-b', respectively)
-byte-compile the visited file and the current buffer, respectively.
+*** New commands 'previous-line-completion' and 'next-line-completion'.
+Bound to '<up>' and '<down>' arrow keys, respectively, they navigate
+the "*Completions*" buffer vertically by lines, wrapping at the
+top/bottom when 'completion-auto-wrap' is non-nil.
+
+*** New user option 'minibuffer-visible-completions'.
+When customized to non-nil, you can use arrow keys in the minibuffer
+to navigate the completions displayed in the "*Completions*" window.
+Typing 'RET' selects the highlighted candidate. 'C-g' hides the
+completions window. When the completions window is not visible,
+then all these keys have their usual meaning in the minibuffer.
+This option is supported for in-buffer completion as well.
+
+*** Selected completion candidates are deselected on typing.
+When you type at the minibuffer prompt, the current completion
+candidate will be un-highlighted, and point in the "*Completions*" window
+will be moved off that candidate. 'minibuffer-choose-completion'
+('M-RET') will still choose a previously-selected completion
+candidate, but the new command 'minibuffer-choose-completion-or-exit'
+(bound to 'RET' by 'minibuffer-visible-completions') will exit with
+the minibuffer contents instead. This deselection behavior can be
+controlled with the new user option 'completion-auto-deselect', which
+is t by default.
+
+*** New value 'historical' for user option 'completions-sort'.
+When 'completions-sort' is set to 'historical', completion candidates
+will be first sorted alphabetically, and then re-sorted by their order
+in the minibuffer history, with more recent candidates appearing first.
+
++++
+*** 'completion-category-overrides' supports more metadata.
+The new supported completion properties are 'cycle-sort-function',
+'display-sort-function', 'annotation-function', 'affixation-function',
+and 'group-function'. You can now customize them for any category in
+'completion-category-overrides' that will override the properties
+defined in completion metadata.
+
++++
+*** 'completion-extra-properties' supports more metadata.
+The new supported completion properties are 'category',
+'group-function', 'display-sort-function', and 'cycle-sort-function'.
+
+** Pcomplete
+
+---
+*** New user option 'pcomplete-remote-file-ignore'.
+When this option is non-nil, remote file names are not completed by
+Pcomplete. Packages, like 'shell-mode', could set this in order to
+suppress remote file name completion at all.
+
+---
+*** Completion for the 'doas' command has been added.
+Command completion for 'doas' in Eshell and Shell mode will now work.
+
+** Shell mode
+
++++
+*** New user option 'shell-get-old-input-include-continuation-lines'.
+When this user option is non-nil, 'shell-get-old-input' ('C-RET')
+includes multiple shell "\" continuation lines from command output.
+Default is nil.
+
+** Make mode
+
+*** The Makefile browser is now obsolete.
+The command 'makefile-switch-to-browser' command is now obsolete,
+together with related commands used in the "*Macros and Targets*"
+buffer. We recommend using an alternative like 'imenu' instead.
+
+** Prog mode
+
++++
+*** New command 'prog-fill-reindent-defun'.
+This command either fills a single paragraph in a defun, such as a
+docstring, or a comment, or (re)indents the surrounding defun if
+point is not in a comment or a string. It is by default bound to
+'M-q' in 'prog-mode' and all its descendants.
+
+** Which Function mode
+
++++
+*** Which Function mode can now display function names on the header line.
+The new user option 'which-func-display' allows choosing where the
+function name is displayed. The default is 'mode' to display in the
+mode line. 'header' will display in the header line;
+'mode-and-header' displays in both the header line and mode line.
-** Games
+** Tramp
-*** New user option 'tetris-allow-repetitions'.
-This controls how randomness is implemented (whether to use pure
-randomness as before, or to use a bag).
++++
+*** New connection method "androidsu".
+This provides access to system files with elevated privileges granted by
+the idiosyncratic 'su' implementations and system utilities customary on
+Android.
+
++++
+*** New connection methods "dockercp" and "podmancp".
+These are the external methods counterparts of "docker" and "podman".
+
++++
+*** New connection methods "toolbox" and "flatpak".
+They allow accessing system containers provided by Toolbox or
+sandboxes provided by Flatpak.
+
++++
+*** Connection method "kubernetes" supports now optional container name.
+The host name for Kubernetes connections can be of kind [CONTAINER.]POD,
+in order to specify a dedicated container. If there is just the pod
+name, the first container in the pod is taken. The new user options
+'tramp-kubernetes-context' and 'tramp-kubernetes-namespace' allow
+accessing pods with different context or namespace but the default one.
+
++++
+*** Rename 'tramp-use-ssh-controlmaster-options' to 'tramp-use-connection-share'.
+The old name still exists as obsolete variable alias. This user
+option controls now connection sharing for both ssh-based and
+plink-based methods. It allows the values t, nil, and 'suppress'.
+The latter suppresses also "ControlMaster" settings in the user's
+"~/.ssh/config" file, or connection share configuration in PuTTY
+sessions, respectively.
+
++++
+*** New command 'tramp-cleanup-some-buffers'.
+It kills only a subset of opened remote buffers, subject to the user
+option 'tramp-cleanup-some-buffers-hook'.
+
++++
+*** New command 'inhibit-remote-files'.
+This command disables the handling of file names with the special
+remote file name syntax. It should be applied only when remote files
+won't be used in this Emacs instance. It provides a slightly improved
+performance of file name handling in Emacs.
+
++++
+*** New macro 'without-remote-files'.
+This macro could wrap code which handles local files only. Due to the
+temporary deactivation of remote files, it results in a slightly
+improved performance of file name handling in Emacs.
+
++++
+*** New user option 'tramp-completion-multi-hop-methods'.
+It contains a list of connection methods for which completion should
+be attempted at the end of a multi-hop chain. This allows completion
+candidates to include a list of, for example, containers running on a
+remote docker host.
+
++++
+*** New command 'tramp-revert-buffer-with-sudo'.
+It reverts the current buffer to visit with "sudo" permissions. The
+buffer must either visit a file, or it must run 'dired-mode'. Another
+method but "sudo" can be configured with user option
+'tramp-file-name-with-method'.
+
+---
+*** Direct asynchronous processes use 'tramp-remote-path'.
+When a direct asynchronous process is invoked, it uses 'tramp-remote-path'
+for setting the remote PATH environment variable.
-** Battery
+** File Notifications
-*** New user option 'battery-update-functions'.
-This can be used to trigger actions based on the battery status.
++++
+*** All backends except w32notify detect unmounting of a watched filesystem now.
+
+** EWW
+
++++
+*** 'eww-open-file' can now display the file in a new buffer.
+By default, the command reuses the "*eww*" buffer, but if called with
+the new argument NEW-BUFFER non-nil, it will use a new buffer instead.
+Interactively, invoke 'eww-open-file' with a prefix argument to
+activate this behavior.
+
+---
+*** 'eww' URL or keyword prompt now has tab completion.
+The interactive minibuffer prompt when invoking 'eww' now has support
+for tab completion.
+
++++
+*** 'eww' URL and keyword prompt now completes suggested URIs and bookmarks.
+The interactive minibuffer prompt when invoking 'eww' now provides
+completions from 'eww-suggest-uris'. 'eww-suggest-uris' now includes
+bookmark URIs.
+
++++
+*** New command 'eww-copy-alternate-url'.
+It copies an alternate link on the page currently visited in EWW into
+the kill ring. Alternate links are optional metadata that HTML pages
+use for linking to their alternative representations, such as
+translated versions or associated RSS feeds.
+
++++
+*** 'eww-open-in-new-buffer' supports the prefix argument.
+When invoked with the prefix argument ('C-u'),
+'eww-open-in-new-buffer' will not make the new buffer the current one.
+This is useful for continuing reading the URL in the current buffer
+when the new URL is fetched.
+
+---
+*** History navigation in EWW now works like other browsers.
+Previously, when navigating back and forward through page history, EWW
+would add a duplicate entry to the end of the history list each time.
+This made it impossible to navigate to the "end" of the history list.
+Now, navigating through history in EWW simply changes your position in
+the history list, allowing you to reach the end as expected. In
+addition, when browsing to a new page from a "historical" one (i.e. a
+page loaded by navigating back through history), EWW deletes the history
+entries newer than the current page. To change the behavior when
+browsing from "historical" pages, you can customize
+'eww-before-browse-history-function'.
+
++++
+*** 'eww-readable' now toggles display of the readable parts of a web page.
+When called interactively, 'eww-readable' toggles whether to display
+only the readable parts of a page or the full page. With a positive
+prefix argument, it always displays the readable parts, and with a zero
+or negative prefix, it always displays the full page.
+
++++
+*** New option 'eww-readable-urls'.
+This is a list of regular expressions matching the URLs where EWW should
+display only the readable parts by default. For more details, see
+"(eww) Basics" in the EWW manual.
+
+---
+*** New option 'eww-readable-adds-to-history'.
+When non-nil (the default), calling 'eww-readable' adds a new entry to
+the EWW page history.
+
+** go-ts-mode
+
++++
+*** New command 'go-ts-mode-docstring'.
+This command adds a docstring comment to the current defun. If a
+comment already exists, point is only moved to the comment. It is
+bound to 'C-c C-d' in 'go-ts-mode'.
+
+** Man mode
+
++++
+*** New user option 'Man-prefer-synchronous-call'.
+When this is non-nil, run the 'man' command synchronously rather than
+asynchronously (which is the default behavior).
+
++++
+*** New user option 'Man-support-remote-systems'.
+This option controls whether the man page is formatted on the remote
+system when the current buffer's default-directory is remote. You can
+invoke the 'man' command with a prefix argument to countermand the
+value of this option for the current invocation of 'man'.
** DocView
-*** doc-view can now generate SVG images when viewing PDF files.
-If Emacs is built with SVG support, doc-view can generate SVG files
-when using MuPDF as the converter for PDF files, which generally leads
-to sharper images (especially when zooming), and allows customization
-of background and foreground color of the page via the new user
-options 'doc-view-svg-background' and 'doc-view-svg-foreground'. To
-activate this behavior, set 'doc-view-mupdf-use-svg' to non-nil if
-your Emacs has SVG support. Note that, with some versions of MuPDF,
-SVG generation is known to sometimes produce SVG files that are buggy
-or can take a long time to render.
-
-** Enriched Mode
-
-*** New command 'enriched-toggle-markup'.
-This allows you to see the markup in 'enriched-mode' buffers (e.g.,
-the "HELLO" file). Bound to 'M-o m' by default.
-
-** Shell Script Mode
-
-*** New user option 'sh-indent-statement-after-and'.
-This controls how statements like the following are indented:
-
- foo &&
- bar
-
-*** New Flymake backend using the ShellCheck program.
-It is enabled by default, but requires that the external "shellcheck"
-command is installed.
-
-** CC Mode
-
-*** C++ Mode now supports most of the new features in the C++20 Standard.
-
-*** In Objective-C Mode, no extra types are recognized by default.
-The default value of 'objc-font-lock-extra-types' has been changed to
-nil, since too many identifiers were getting misfontified as types.
-This may cause some actual types not to get fontified. To get the old
-behavior back, customize the user option to the value suggested in its
-doc string.
-
-** Cperl Mode
+---
+*** New face 'doc-view-svg-face'.
+This replaces 'doc-view-svg-foreground' and 'doc-view-svg-background'.
+If you don't like the colors produced by the default definition of
+this new face when DocView displays documents, customize this face to
+restore the colors you were used to, or to get colors more to your
+liking.
-*** New user option 'cperl-file-style'.
-This option determines the indentation style to be used. It can also
-be used as a file-local variable.
+---
+*** DocView buffers now display a new tool bar.
+This tool bar contains options for searching and navigating within the
+document, replacing the incompatible items for incremental search and
+editing within the default tool bar displayed in the past.
-** Gud
-
-*** 'gud-go' is now bound to 'C-c C-v'.
-If given a prefix, it will prompt for an argument to use for the
-run/continue command.
-
-*** 'perldb' now recognizes '-E'.
-As of Perl 5.10, 'perl -E 0' behaves like 'perl -e 0' but also activates
-all optional features of the Perl version in use. 'perldb' now uses
-this invocation as its default.
-
-** Customize
-
-*** New command 'custom-toggle-hide-all-widgets'.
-This is bound to 'H' and toggles whether to hide or show the widget
-contents.
-
-** Diff Mode
-
-*** New user option 'diff-whitespace-style'.
-Sets the value of the buffer-local variable 'whitespace-style' in
-'diff-mode' buffers. By default, this variable is '(face trailing)',
-which preserves behavior of previous Emacs versions.
-
-*** New user option 'diff-add-log-use-relative-names'.
-If non-nil insert file names in ChangeLog skeletons relative to the
-VC root directory.
-
-** Ispell
-
-*** 'ispell-region' and 'ispell-buffer' now push the mark.
-These commands push onto the mark ring the location of the last
-misspelled word where corrections were offered, so that you can then
-skip back to that location with 'C-x C-x'.
+** Shortdoc
-** Dabbrev
++++
+*** New function 'shortdoc-function-examples'.
+This function returns examples of use of a given Emacs Lisp function
+from the available shortdoc information.
-*** New function 'dabbrev-capf' for use on 'completion-at-point-functions'.
++++
+*** New function 'shortdoc-help-fns-examples-function'.
+This function inserts into the current buffer examples of use of a
+given Emacs Lisp function, which it gleans from the shortdoc
+information. If you want 'describe-function' ('C-h f') to insert
+examples of using the function into regular "*Help*" buffers, add the
+following to your init file:
-*** New user option 'dabbrev-ignored-buffer-modes'.
-Buffers with major modes in this list will be ignored. By default,
-this includes "binary" buffers like 'archive-mode' and 'image-mode'.
+ (add-hook 'help-fns-describe-function-functions
+ #'shortdoc-help-fns-examples-function)
** Package
-*** New command 'package-upgrade'.
-This command allows you to upgrade packages without using 'list-packages'.
-A package that comes with the Emacs distribution can only be upgraded
-after you install, once, a newer version from ELPA via the
-package-menu displayed by 'list-packages'.
-
-*** New command 'package-upgrade-all'.
-This command allows upgrading all packages without any queries.
-A package that comes with the Emacs distribution will only be upgraded
-by this command after you install, once, a newer version of that
-package from ELPA via the package-menu displayed by 'list-packages'.
-
-*** New commands 'package-recompile' and 'package-recompile-all'.
-These commands can be useful if the ".elc" files are out of date
-(invalid byte code and macros).
-
-*** New DWIM action on 'x' in "*Packages*" buffer.
-If no packages are marked, 'x' will install the package under point if
-it isn't already, and remove it if it is installed. Customize the new
-option 'package-menu-use-current-if-no-marks' to the nil value to get
-back the old behavior of signaling an error in that case.
-
-*** New command 'package-vc-install'.
-Packages can now be installed directly from source by cloning from
-their repository.
-
-*** New command 'package-vc-install-from-checkout'.
-An existing checkout can now be loaded via package.el, by creating a
-symbolic link from the usual package directory to the checkout.
-
-*** New command 'package-vc-checkout'.
-Used to fetch the source of a package by cloning a repository without
-activating the package.
-
-*** New command 'package-vc-prepare-patch'.
-This command allows you to send patches to package maintainers, for
-packages checked out using 'package-vc-install'.
-
-*** New command 'package-report-bug'.
-This command helps you compose an email for sending bug reports to
-package maintainers, and is bound to 'b' in the "*Packages*" buffer.
-
-*** New user option 'package-vc-selected-packages'.
-By customizing this user option you can specify specific packages to
-install.
-
-*** New user option 'package-install-upgrade-built-in'.
-When enabled, 'package-install' will include in the list of
-upgradeable packages those built-in packages (like Eglot and
-use-package, for example) for which a newer version is available in
-package archives, and will allow installing those newer versions. By
-default, this is disabled; however, if 'package-install' is invoked
-with a prefix argument, it will act as if this new option were
-enabled.
-
-In addition, when this option is non-nil, built-in packages for which
-a new version is available in archives can be upgraded via the package
-menu produced by 'list-packages'. If you do set this option non-nil,
-we recommend not to use the 'U' command, but instead to use '/ u' to
-show the packages which can be upgraded, and then decide which ones of
-them you actually want to update from the archives.
-
-If you customize this option, we recommend you place its non-default
-setting in your early-init file.
-
-** Emacs Sessions (Desktop)
-
-*** New user 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.
-
-** 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
-
-*** 'q' in a "*Backtrace*" buffer no longer clears the buffer.
-Instead it just buries the buffer and switches the mode from
-'debugger-mode' to 'backtrace-mode', since commands like 'e' are no
-longer available after exiting the recursive edit.
-
-*** 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 behavior from previous Emacs versions.
-
-*** 'e' in edebug can now take a prefix arg to pretty-print the results.
-When invoked with a prefix argument, as in 'C-u e', this command will
-pop up a new buffer and show the full pretty-printed value there.
-
-*** 'C-x C-e' now interprets a non-zero prefix arg to pretty-print the results.
-When invoked with a non-zero prefix argument, as in 'C-u C-x C-e',
-this command will pop up a new buffer and show the full pretty-printed
-value there.
-
-*** You can now generate a backtrace from Lisp errors in redisplay.
-To do this, set the new variable 'backtrace-on-redisplay-error' to a
-non-nil value. The backtrace will be written to a special buffer
-named "*Redisplay-trace*". This buffer will not be automatically
-displayed in a window.
-
-** Compile
-
-*** New user option 'compilation-hidden-output'.
-This regular expression can be used to make specific parts of
-compilation output invisible.
-
-*** The 'compilation-auto-jump-to-first-error' user option has been extended.
-It can now have the additional values 'if-location-known' (which will
-only jump if the location of the first error is known), and
-'first-known' (which will jump to the first known error location).
-
-*** New user option 'compilation-max-output-line-length'.
-Lines longer than the value of this option will have their ends
-hidden, with a button to reveal the hidden text. This speeds up
-operations like grepping on files that have few newlines. The default
-value is 400; set to nil to disable hiding.
+---
+*** New user option 'package-vc-register-as-project'.
+When non-nil, it will automatically register every package as a
+project, that you can quickly select using 'project-switch-project'
+('C-x p p').
+
+---
+*** New user option 'package-vc-allow-build-commands'.
+Controls for which packages Emacs runs extra build commands when
+installing directly from the package VCS repository.
+
+---
+*** New command to start an inferior Emacs loading only specific packages.
+The new command 'package-isolate' will start a new Emacs process, as
+a sub-process of Emacs where you invoke the command, in a way that
+causes the new process to load only some of the installed packages.
+The command prompts for the packages to activate in this
+sub-process, and is intended for testing Emacs and/or the packages
+in a clean environment.
** Flymake
-*** New user option 'flymake-mode-line-lighter'.
++++
+*** New user option 'flymake-show-diagnostics-at-end-of-line'.
+When non-nil, Flymake shows summarized descriptions of diagnostics at
+the end of the line. Depending on your preference, this can either be
+distracting and easily confused with actual code, or a significant
+early aid that relieves you from moving the buffer or reaching for the
+mouse to consult an error message.
-** 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'.
+** Flyspell
-** New mode, 'emacs-news-mode', for editing the NEWS file.
-This mode adds some highlighting, makes the 'M-q' command aware of the
-format of NEWS entries, and has special commands for doing maintenance
-of the Emacs NEWS files. In addition, this mode turns on
-'outline-minor-mode', and thus displays customizable icons (see
-'icon-preference') in the margins. To disable these icons, set
-'outline-minor-mode-use-buttons' to a nil value.
+*** New user option 'flyspell-check-changes'.
+When non-nil, Flyspell mode spell-checks only words that you edited; it
+does not check unedited words just because you move point across them.
-** 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).
+** JS mode.
+The binding 'M-.' has been removed from the major mode keymaps in
+'js-mode' and 'js-ts-mode', having it default to the global binding
+which calls 'xref-find-definitions'. If the previous one worked
+better for you, use 'define-key' in your init script to bind
+'js-find-symbol' to that combination again.
-** savehist.el can now truncate variables that are too long.
-An element of user option 'savehist-additional-variables' can now be
-of the form '(VARIABLE . MAX-ELTS)', which means to truncate the
-VARIABLE's value to at most MAX-ELTS elements (if the value is a list)
-before saving the value.
+** Json mode.
+'js-json-mode' does not derive from 'js-mode' any more so as not
+to confuse tools like Eglot or YASnippet into thinking that those
+buffers contain Javascript code.
-** Minibuffer and Completions
+** Python mode
-*** New commands for navigating completions from the minibuffer.
-When the minibuffer is the current buffer, typing 'M-<up>' or
-'M-<down>' 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-<up>' and 'M-<down>' 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. These keys are also available for in-buffer
-completion, but they don't insert candidates automatically, you need
-to type 'M-RET' to insert the selected candidate to the buffer.
-
-*** 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 into 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. 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-auto-wrap'.
-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 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 commands to complete the minibuffer history.
-'minibuffer-complete-history' ('C-x <up>') is like 'minibuffer-complete'
-but completes on the history items instead of the default completion
-table. 'minibuffer-complete-defaults' ('C-x <down>') completes
-on the list of default items.
-
-*** User option 'minibuffer-eldef-shorten-default' is now obsolete.
-Customize the user option 'minibuffer-default-prompt-format' instead.
-
-*** 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 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 header 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 header 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. The default is to highlight
-using the 'completions-highlight' face.
-
-*** You can now define abbrevs for the minibuffer modes.
-'minibuffer-mode-abbrev-table' and
-'minibuffer-inactive-mode-abbrev-table' are now defined.
+---
+*** New user option 'python-indent-block-paren-deeper'.
+If non-nil, increase the indentation of the lines inside parens in a
+header of a block when they are indented to the same level as the body
+of the block:
-** Isearch and Replace
-
-*** Changes in how Isearch responds to 'mouse-yank-at-point'.
-If a user does 'C-s' and then uses '<mouse-2>' ('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.
-
-*** Changes for values 'no' and 'no-ding' of 'isearch-wrap-pause'.
-Now with these values the search will wrap around not only on repeating
-with 'C-s C-s', but also after typing a character.
-
-*** New user option 'char-fold-override'.
-Non-nil means that the default definitions of equivalent characters
-are overridden.
-
-*** New command 'describe-char-fold-equivalences'.
-It displays character equivalences used by 'char-fold-to-regexp'.
-
-*** New command 'isearch-emoji-by-name'.
-It is bound to 'C-x 8 e RET' during an incremental search. The
-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.
-
-** GDB/MI
-
-*** New user option 'gdb-debuginfod-enable-setting'.
-On capable platforms, GDB 10.1 and later can download missing source
-and debug info files from special-purpose servers, called "debuginfod
-servers". Use this new option to control whether 'M-x gdb' instructs
-GDB to download missing files from debuginfod servers when you debug
-the corresponding programs. The default is to ask you at the
-beginning of each debugging session whether to download the files for
-that session.
-
-** Glyphless Characters
-
-*** New minor mode 'glyphless-display-mode'.
-This allows an easy way to toggle seeing all glyphless characters in
-the current buffer.
-
-*** The extra slot of 'glyphless-char-display' can now have cons values.
-The extra slot of the 'glyphless-char-display' char-table can now have
-values that are cons cells, specifying separate values for text-mode
-and GUI terminals.
-
-*** "Replacement character" feature for undisplayable characters on TTYs.
-The 'acronym' method of displaying glyphless characters on text-mode
-frames treats single-character acronyms specially: they are displayed
-without the surrounding '[..]' "box", thus in effect treating such
-"acronyms" as replacement characters.
+ if (some_expression
+ and another_expression):
+ do_something()
-** Registers
+instead of:
-*** Buffer names can now be stored in registers.
-For instance, to enable jumping to the "*Messages*" buffer with
-'C-x r j m':
+ if (some_expression
+ and another_expression):
+ do_something()
- (set-register ?m '(buffer . "*Messages*"))
+*** New user option 'python-interpreter-args'.
+This allows the user to specify command line arguments to the non
+interactive Python interpreter specified by 'python-interpreter'.
-** Pixel Fill
+** use-package
-*** This is a new package that deals with filling variable-pitch text.
-
-*** New function 'pixel-fill-region'.
-This fills the region to be no wider than a specified pixel width.
-
-** Info
-
-*** Command '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
-info node. This command only works for the Emacs and Emacs Lisp manuals.
-
-** Shortdoc
-
-*** New command 'shortdoc-copy-function-as-kill' bound to 'w'.
-It copies the name of the function near point into the kill ring.
-
-*** 'N' and 'P' are now bound to 'shortdoc-{next,previous}-section'.
-This is in addition to the old keybindings 'C-c C-n' and 'C-c C-p'.
-
-** VC
-
-*** New command 'vc-pull-and-push'.
-This commands first does a "pull" command, and if that is successful,
-does a "push" command afterwards. Currently supported in Git and Bzr.
-
-*** 'C-x v b' prefix key is used now for branch commands.
-'vc-print-branch-log' is bound to 'C-x v b l', and new commands are
-'vc-create-branch' ('C-x v b c') and 'vc-switch-branch' ('C-x v b s').
-The VC Directory buffer now uses the prefix 'b' for these branch-related
-commands.
-
-*** New command 'vc-dir-mark-by-regexp' bound to '% m' and '* %'.
-This command marks files based on a regexp. If given a prefix
-argument, unmark instead.
-
-*** New command 'C-x v !' ('vc-edit-next-command').
-This prefix command requests editing of the next VC shell command
-before execution. For example, in a Git repository, you can produce a
-log of more than one branch by typing 'C-x v ! C-x v b l' and then
-appending additional branch names to the 'git log' command.
-
-The intention is that this command can be used to access a wide
-variety of version control system-specific functionality from VC
-without complexifying either the VC command set or the backend API.
-
-*** 'C-x v v' in a diffs buffer allows to commit only some of the changes.
-This command is intended to allow you to commit only some of the
-changes you have in your working tree. Begin by creating a buffer
-with the changes against the last commit, e.g. with 'C-x v D'
-('vc-root-diff'). Then edit the diffs to remove the hunks you don't
-want to commit. Finally, type 'C-x v v' in that diff buffer to commit
-only part of your changes, those whose hunks were left in the buffer.
-
-*** 'C-x v v' on an unregistered file will now use the most specific backend.
-Previously, if you had an SVN-covered "~/" directory, and a Git-covered
-directory in "~/foo/bar", using 'C-x v v' on a new, unregistered file
-"~/foo/bar/zot" would register it in the SVN repository in "~/" instead of
-in the Git repository in "~/foo/bar". This makes this command
-consistent with 'vc-responsible-backend'.
-
-*** Log Edit now fontifies long Git commit summary lines.
-Writing shorter summary lines avoids truncation in contexts in which
-Git commands display summary lines. See the two new user options
-'vc-git-log-edit-summary-target-len' and 'vc-git-log-edit-summary-max-len'.
-
-*** New 'log-edit-headers-separator' face.
-It is used to style the line that separates the 'log-edit' headers
-from the 'log-edit' summary.
-
-*** The function 'vc-read-revision' accepts a new MULTIPLE argument.
-If non-nil, multiple revisions can be queried. This is done using
-'completing-read-multiple'.
-
-*** New function 'vc-read-multiple-revisions'.
-This function invokes 'vc-read-revision' with a non-nil value for
-MULTIPLE.
-
-*** New command 'vc-prepare-patch'.
-Patches for any version control system can be prepared using VC. The
-command will query what commits to send and will compose messages for
-your mail user agent. The behavior of 'vc-prepare-patch' can be
-modified by the user options 'vc-prepare-patches-separately' and
-'vc-default-patch-addressee'.
-
-** Message
-
-*** New user option 'mml-attach-file-at-the-end'.
-If non-nil, 'C-c C-a' will put attached files at the end of the message.
-
-*** Message Mode now supports image yanking.
-
-*** New user option 'message-server-alist'.
-This controls automatic insertion of the "X-Message-SMTP-Method"
-header before sending a message.
-
-** HTML Mode
-
-*** HTML Mode now supports "text/html" and "image/*" yanking.
-
-** Texinfo Mode
-
-*** 'texinfo-mode' now has a specialized 'narrow-to-defun' definition.
-It narrows to the current node.
-
-** EUDC
-
-*** Deprecations planned for next release.
-After Emacs 29.1, some aspects of EUDC will be deprecated. The goal
-of these deprecations is to simplify EUDC server configuration by
-making 'eudc-server-hotlist' the only place to add servers. There
-will not be a need to set the server using the 'eudc-set-server'
-command. Instead, the 'eudc-server-hotlist' user option should be
-customized to have an entry for the server. The plan is to obsolete
-the 'eudc-hotlist' package since Customize is sufficient for changing
-'eudc-server-hotlist'. How the 'eudc-server' user option works in this
-context is to-be-determined; it can't be removed, because that would
-break compatibility, but it may become synchronized with
-'eudc-server-hotlist' so that 'eudc-server' is always equal to '(car
-eudc-server-hotlist)'. The first entry in 'eudc-server-hotlist' is the
-first server tried by 'eudc-expand-try-all'. The hotlist
-simplification will allow 'eudc-query-form' to show a drop down of
-possible servers, instead of requiring a call to 'eudc-set-server'
-like it does in this release. The default value of
-'eudc-ignore-options-file' will be changed from nil to t.
-
-*** New user option 'eudc-ignore-options-file' that defaults to nil.
-The 'eudc-ignore-options-file' user option can be configured to ignore
-the 'eudc-options-file' (typically "~/.emacs.d/eudc-options"). Most
-users should configure this to t and put EUDC configuration in the
-main Emacs initialization file ("~/.emacs" or "~/.emacs.d/init.el").
-
-*** 'eudc-expansion-overwrites-query' to 'eudc-expansion-save-query-as-kill'.
-The user option 'eudc-expansion-overwrites-query' is renamed to
-'eudc-expansion-save-query-as-kill' to reflect the actual behavior of
-the user option. The former is kept as alias.
-
-*** 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 of producing 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.
-
-*** New function 'eudc-capf-complete' with 'message-mode' integration.
-EUDC can now contribute email addresses to 'completion-at-point' by
-adding the new function 'eudc-capf-complete' to
-'completion-at-point-functions' in 'message-mode'.
-
-*** Additional attributes of query and results in eudcb-macos-contacts.el.
-The EUDC back-end for the macOS Contacts app now provides a wider set
-of attributes to use for queries, and delivers more attributes in
-query results.
-
-*** New back-end for ecomplete.
-A new back-end for ecomplete allows information from that database to
-be queried by EUDC, too. The attributes present in the EUDC query are
-used to select the entry type in the ecomplete database.
-
-*** New back-end for mailabbrev.
-A new back-end for mailabbrev allows information from that database to
-be queried by EUDC, too. Only the attributes 'email', 'name', and
-'firstname' are supported.
-
-** 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 the user option
-'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
-allowed images.
-
-*** New user option 'shr-use-xwidgets-for-media'.
-If non-nil (and Emacs has been built with support for xwidgets),
-display <video> elements with an xwidget. Note that this is
-experimental; it is known to crash Emacs on some systems, and just
-doesn't work on other systems. Also see etc/PROBLEMS.
-
-*** New user option 'eww-url-transformers'.
-These are used to alter an URL before using it. By default it removes
-the common "utm_" trackers from URLs.
-
-** Find Dired
-
-*** New command 'find-dired-with-command'.
-This enables users to run 'find-dired' with an arbitrary command,
-enabling running commands previously unsupported and also enabling new
-commands to be built on top.
++++
+*** New ':vc' keyword.
+This keyword enables the user to install packages using 'package-vc'.
** 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-summary-up-thread' and 'gnus-summary-down-thread' bindings removed.
-The 'gnus-summary-down-thread' binding to 'M-C-d' was shadowed by
-'gnus-summary-read-document', and these commands are also available on
-'T u' and 'T d' respectively.
-
-*** Gnus now uses a variable-pitch font in the headers by default.
-To get the monospace font back, you can put something like the
-following in your ".gnus" file:
-
- (set-face-attribute 'gnus-header nil :inherit 'unspecified)
-
-*** The default value of 'gnus-treat-fold-headers' is now 'head'.
-
-*** New face 'gnus-header'.
-All other 'gnus-header-*' faces inherit from this face now.
-
-*** New user option 'gnus-treat-emojize-symbols'.
-If non-nil, symbols that have an Emoji representation will be
-displayed as emojis. The default is nil.
+*** The 'nnweb-type' option 'gmane' has been removed.
+The gmane.org website is, sadly, down since a number of years with no
+prospect of it coming back. Therefore, it is no longer valid to set
+the user option 'nnweb-type' to 'gmane'.
-*** New command 'gnus-article-emojize-symbols'.
-This is bound to 'W D e' and will display symbols that have Emoji
-representation as Emoji.
-
-*** 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.
+---
+*** New user option 'gnus-mode-line-logo'.
+This allows the user to either disable the display of any logo or
+specify which logo will be displayed as part of the
+buffer-identification in the mode-line of Gnus buffers.
** Rmail
-*** Rmail partial summaries can now be applied one on top of the other.
-You can now narrow the set of messages selected by Rmail summary's
-criteria (recipients, topic, senders, etc.) by making a summary of the
-already summarized messages. For example, invoking
-'rmail-summary-by-senders', followed by 'rmail-summary-by-topic' will
-produce a summary where both the senders and the topic are according
-to your selection. The new user option
-'rmail-summary-progressively-narrow' controls whether the stacking of
-the filters is in effect; customize it to a non-nil value to enable
-this feature.
-
-*** New Rmail summary: by thread.
-The new command 'rmail-summary-by-thread' produces a summary of
-messages that belong to a single thread of discussion.
-
-** EIEIO
-
-*** 'slot-value' can now be used to access slots of 'cl-defstruct' objects.
-
-** Align
-
-*** Alignment in 'text-mode' has changed.
-Previously, 'M-x align' didn't do anything, and you had to say 'C-u
-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.
-
-** 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
-for the command they are bound to. This does not affect listings of
-key bindings and functions (such as 'C-h b').
-
-** Info Look
-
-*** info-look specs can now be expanded at run time instead of a load time.
-The new ':doc-spec-function' element can be used to compute the
-':doc-spec' element when the user asks for info on that particular
-mode (instead of at load time).
-
-** Ansi Color
-
-*** Support for ANSI 256-color and 24-bit colors.
-256-color and 24-bit color codes are now handled by ANSI color
-filters and displayed with the specified color.
-
-** Term Mode
-
-*** New user option 'term-bind-function-keys'.
-If non-nil, 'term-mode' will pass the function keys on to the
-underlying shell instead of using the normal Emacs bindings.
-
-*** Support for ANSI 256-color and 24-bit colors, italic and other fonts.
-'term-mode' can now display 256-color and 24-bit color codes. It can
-also handle ANSI codes for faint, italic and blinking text, displaying
-it with new 'term-{faint,italic,slow-blink,fast-blink}' faces.
-
-** Project
-
-*** 'project-find-file' and 'project-or-external-find-file' can include all.
-The commands 'project-find-file' and 'project-or-external-find-file'
-now accept a prefix argument, which is interpreted to mean "include
-all files".
-
-*** New command 'project-list-buffers' bound to 'C-x p C-b'.
-This command displays a list of buffers from the current project.
-
-*** '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.
-
-*** New user option 'project-vc-extra-root-markers'.
-Use it to add detection of nested projects (inside a VCS repository),
-or projects outside of VCS repositories.
+---
+*** New commands for reading mailing lists.
+The new Rmail commands 'rmail-mailing-list-post',
+'rmail-mailing-list-unsubscribe', 'rmail-mailing-list-help', and
+'rmail-mailing-list-archive' allow, respectively, posting to,
+unsubscribing from, requesting help about, and browsing the archives
+of, the mailing list from which the current email message was
+delivered.
+
+** Dictionary
+
+---
+*** New user option 'dictionary-search-interface'.
+Controls how the 'dictionary-search' command prompts for and displays
+dictionary definitions. Customize this user option to 'help' to have
+'dictionary-search' display definitions in a "*Help*" buffer and
+provide dictionary-based minibuffer completion for word selection.
+
+---
+*** New user option 'dictionary-read-word-prompt'.
+This allows the user to customize the prompt that is used by
+'dictionary-search' when asking for a word to search in the
+dictionary.
+
+---
+*** New user option 'dictionary-display-definition-function'.
+This allows the user to customize the way in which 'dictionary-search'
+displays word definitions. If non-nil, this user option should be set
+to a function that displays a word definition obtained from a
+dictionary server. The new function
+'dictionary-display-definition-in-help-buffer' can be used to display
+the definition in a "*Help*" buffer, instead of the default
+"*Dictionary*" buffer.
+
+---
+*** New user option 'dictionary-read-word-function'.
+This allows the user to customize the way in which 'dictionary-search'
+prompts for a word to search in the dictionary. This user option
+should be set to a function that lets the user select a word and
+returns it as a string. The new function
+'dictionary-completing-read-word' can be used to prompt with
+completion based on dictionary matches.
+
+---
+*** New user option 'dictionary-read-dictionary-function'.
+This allows the user to customize the way in which 'dictionary-search'
+prompts for a dictionary to search in. This user option should be set
+to a function that lets the user select a dictionary and returns its
+name as a string. The new function
+'dictionary-completing-read-dictionary' can be used to prompt with
+completion based on dictionaries that the server supports.
+
+** Pp
+
+*** New 'pp-default-function' user option replaces 'pp-use-max-width'.
+
+*** New default pretty printing function, which tries to obey 'fill-column'.
+
+*** 'pp-to-string' takes an additional PP-FUNCTION argument.
+This argument specifies the prettifying algorithm to use.
+
+** Emacs Lisp mode
+
+---
+*** ',@' now has 'prefix' syntax.
+Previously, the '@' character, which normally has 'symbol' syntax,
+would combine with a following Lisp symbol and interfere with symbol
+searching.
+
+---
+*** 'emacs-lisp-docstring-fill-column' now defaults to 72.
+It was previously 65. The new default formats documentation strings to
+fit on fewer lines without negatively impacting readability.
+
+** CPerl mode
+
+---
+*** Subroutine signatures are now supported.
+CPerl mode fontifies subroutine signatures like variable declarations
+which makes them visually distinct from subroutine prototypes.
+
+*** Syntax of Perl up to version 5.38 is supported.
+CPerl mode supports the new keywords for exception handling and the
+object oriented syntax which were added in Perl 5.36 and 5.38.
+
+*** New user option 'cperl-fontify-trailer'.
+This user option takes the values 'perl-code' or 'comment' and treats
+text after an "__END__" or "__DATA__" token accordingly. The default
+value of 'perl-code' is useful for trailing POD and for AutoSplit
+modules, the value 'comment' makes CPerl mode treat trailers as
+comment, like Perl mode does.
+
+*** New command 'cperl-file-style'.
+This command sets the indentation style for the current buffer. To
+change the default style, either use the user option with the same name
+or use the command 'cperl-set-style'.
+
+*** Commands using the Perl info page are obsolete.
+The Perl documentation in info format is no longer distributed with
+Perl or on CPAN since more than 10 years. Perl documentation can be
+read with 'cperl-perldoc' instead.
+
+*** Highlighting trailing whitespace has been removed.
+The user option 'cperl-invalid-face' is now obsolete, and does
+nothing. See the user option 'show-trailing-whitespace' instead.
-As a consequence, the 'VC project backend' is formally renamed to
-'VC-aware project backend'.
-
-*** New user option 'project-vc-include-untracked'.
-If non-nil, files untracked by a VCS are considered to be part of
-the project by a VC project based on that VCS.
-
-** Xref
-
-*** New command 'xref-go-forward'.
-It is bound to 'C-M-,' and jumps to the location where you previously
-invoked 'xref-go-back' ('M-,', also known as 'xref-pop-marker-stack').
-
-*** The depth of the Xref marker stack is now infinite.
-The implementation of the Xref marker stack was changed in a way that
-allows as many places to be saved on the stack as needed, limited only
-by the available memory. Therefore, the variables
-'find-tag-marker-ring-length' and 'xref-marker-ring-length' are now
-obsolete and unused; setting them has no effect.
-
-*** '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'.
-
-*** 'outline-minor-mode' is supported in Xref buffers.
-You can enable outlining by adding 'outline-minor-mode' to
-'xref-after-update-hook'.
-
-** File Notifications
-
-*** The new command 'file-notify-rm-all-watches' removes all file notifications.
-
-** Sql
-
-*** Sql now supports sending of passwords in-process.
-To improve security, if an sql product has ':password-in-comint' set
-to t, a password supplied via the minibuffer will be sent in-process,
-as opposed to via the command-line.
-
-** Image Mode
-
-*** New command 'image-transform-fit-to-window'.
-This command fits the image to the current window by scaling down or
-up as necessary. Unlike 'image-transform-fit-both', this can scale
-the image up as well as down. It is bound to 's w' in Image Mode by
-default.
-
-*** New command 'image-mode-wallpaper-set'.
-This command sets the desktop background to the current image. It is
-bound to 'W' in Image Mode by default.
-
-*** 'image-transform-fit-to-{height,width}' are now obsolete.
-Use the new command 'image-transform-fit-to-window' instead.
-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'.
+** Emacs Sessions (Desktop)
-*** 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.
++++
+*** Restoring buffers visiting remote files can now time out.
+When a buffer is restored which visits a remote file, the restoration
+of the session could hang if the remote host is off-line or slow to
+respond. Setting the user option 'remote-file-name-access-timeout' to
+a positive number will abandon the attempt to restore such buffers
+after a timeout of that many seconds, thus allowing the rest of
+desktop restoration to continue.
-*** New user option 'image-text-based-formats'.
-This controls whether or not to show a message, when opening certain
-image formats, explaining how to edit it as text. The default is to
-show this message for SVG and XPM.
+** Recentf
-*** New command 'image-transform-set-percent'.
-It allows resizing the image to a percentage of its original size, and
-is bound to 's p' in Image mode.
++++
+*** Checking recent remote files can now time out.
+Similarly to buffer restoration by Desktop, 'recentf-mode' checking
+of the accessibility of remote files can now time out if
+'remote-file-name-access-timeout' is set to a positive number.
-*** 'image-transform-original' renamed to 'image-transform-reset-to-original'.
-The old name was confusing, and is now an obsolete function alias.
+** Notifications
-*** 'image-transform-reset' renamed to 'image-transform-reset-to-initial'.
-The old name was confusing, and is now an obsolete function alias.
++++
+*** Allow using Icon Naming Specification for ':app-icon'.
+You can use a symbol as the value for ':app-icon' to provide icon name
+without specifying a file, like this:
-** Images
+ (notifications-notify
+ :title "I am playing music" :app-icon 'multimedia-player)
-*** New commands 'image-crop' and 'image-cut'.
-These commands allow interactively cropping/cutting the image at
-point. The commands are bound to keys 'i c' and 'i x' (respectively)
-in the local keymap over images. They rely on external programs, by
-default "convert" from ImageMagick, to do the actual cropping/eliding
-of the image file.
+** Image
-*** New commands 'image-flip-horizontally' and 'image-flip-vertically'.
-These commands horizontally and vertically flip the image under point,
-and are bound to 'i h' and 'i v', respectively.
++++
+*** Image :map property is now recomputed when image is transformed.
+Now images with clickable maps work as expected after you run commands
+such as `image-increase-size', `image-decrease-size', `image-rotate',
+`image-flip-horizontally', and `image-flip-vertically'.
-*** Users can now add special image conversion functions.
-This is done via 'image-converter-add-handler'.
++++
+*** New user option 'image-recompute-map-p'
+Set this option to nil to prevent Emacs from recomputing image maps.
** Image Dired
-*** 'image-dired-image-mode' is now based on 'image-mode'.
-This avoids converting images in the background, and makes Image-Dired
-noticeably faster. New keybindings from 'image-mode' are now
-available in the "*image-dired-display-image*" buffer; press '?' or
-'h' in that buffer to see the full list.
-
-*** Navigation and marking commands now work in image display buffer.
-The following new bindings have been added:
-- 'n', 'SPC' => 'image-dired-display-next'
-- 'p', 'DEL' => 'image-dired-display-previous'
-- 'm' => 'image-dired-mark-thumb-original-file'
-- 'd' => 'image-dired-flag-thumb-original-file'
-- 'u' => 'image-dired-unmark-thumb-original-file'
-
-*** New command 'image-dired-unmark-all-marks'.
-It removes all marks from all files in the thumbnail and the
-associated Dired buffer, and is bound to 'U' in the thumbnail and
-display buffer.
-
-*** New command 'image-dired-do-flagged-delete'.
-It deletes all flagged files, and is bound to 'x' in the thumbnail
-buffer. It replaces the command 'image-dired-delete-marked', which is
-now an obsolete alias.
-
-*** New command 'image-dired-copy-filename-as-kill'.
-It copies the name of the marked or current image to the kill ring,
-and is bound to 'w' in the thumbnail buffer.
-
-*** New command 'image-dired-wallpaper-set'.
-This command sets the desktop background to the image at point in the
-thumbnail buffer. It is bound to 'W' by default.
-
-*** 'image-dired-slideshow-start' is now bound to 'S'.
-It is bound in both the thumbnail and display buffer, and no longer
-prompts for a timeout; use a numerical prefix (e.g. 'C-u 8 S') to set
-the timeout.
-
-*** New user option 'image-dired-marking-shows-next'.
-If this option is non-nil (the default), marking, unmarking or
-flagging an image in either the thumbnail or display buffer shows the
-next image.
-
-*** New face 'image-dired-thumb-flagged'.
-If 'image-dired-thumb-mark' is non-nil (the default), this face is
-used for images that are flagged for deletion in the Dired buffer
-associated with Image-Dired.
-
-*** Image information is now shown in the header line of the thumbnail buffer.
-This replaces the message that most navigation commands in the
-thumbnail buffer used to show at the bottom of the screen.
-
-*** New specifiers for 'image-dired-display-properties-format'.
-This is used to format the new header line. The new specifiers are:
-"%d" for the name of the directory that the file is in, "%n" for
-file's number in the thumbnail buffer, and "%s" for the file size.
-
-The default format has been updated to use this. If you prefer the
-old format, add this to your Init file:
-
- (setopt image-dired-display-properties-format "%b: %f (%t): %c")
-
-*** New faces for the header line of the thumbnail buffer.
-These faces correspond to different parts of the header line, as
-specified in 'image-dired-display-properties-format':
-- 'image-dired-thumb-header-directory-name'
-- 'image-dired-thumb-header-file-name'
-- 'image-dired-thumb-header-file-size'
-- 'image-dired-thumb-header-image-count'
-
-*** PDF support.
-Image-Dired now displays thumbnails for PDF files. Type 'RET' on a
-PDF file in the thumbnail buffer to visit the corresponding PDF.
-
-*** Support GraphicsMagick command line tools.
-Support for the GraphicsMagick command line tool ("gm") has been
-added, and is used when it is available instead of ImageMagick.
-
-*** Support Thumbnail Managing Standard v0.9.0 (Dec 2020).
-This standard allows sharing generated thumbnails across different
-programs. Version 0.9.0 adds two larger thumbnail sizes: 512x512 and
-1024x1024 pixels. See the user option 'image-dired-thumbnail-storage'
-to use it; it is not enabled by default.
-
-*** Reduce dependency on external "exiftool" program.
-The 'image-dired-copy-with-exif-file-name' command no longer requires
-an external "exiftool" program to be available. The user options
-'image-dired-cmd-read-exif-data-program' and
-'image-dired-cmd-read-exif-data-options' are now obsolete.
-
-*** Support for bookmark.el.
-The command 'bookmark-set' (bound to 'C-x r m') is now supported in
-the thumbnail view, and will create a bookmark that opens the current
-directory in Image-Dired.
-
-*** The 'image-dired-slideshow-start' command no longer prompts.
-It no longer inconveniently prompts for a number of images and a
-delay: it runs indefinitely, but stops automatically on any command.
-You can set the delay with a prefix argument, or a negative prefix
-argument to prompt for a delay. Customize the user option
-'image-dired-slideshow-delay' to change the default from 5 seconds.
-
-*** 'image-dired-show-all-from-dir-max-files' increased to 1000.
-This user option controls asking for confirmation when starting
-Image-Dired in a directory with many files. Since Image-Dired creates
-thumbnails in the background in recent versions, this is not as
-important as it used to be. You can now also customize this option to
-nil to disable this confirmation completely.
-
-*** 'image-dired-thumb-size' increased to 128.
-
-*** 'image-dired-db-file' renamed to 'image-dired-tags-db-file'.
-
-*** 'image-dired-display-image-mode' renamed to 'image-dired-image-mode'.
-The corresponding keymap is now named 'image-dired-image-mode-map'.
-
-*** Some commands have been renamed to be shorter.
-- 'image-dired-display-thumbnail-original-image' has been renamed to
- 'image-dired-display-this'.
-- 'image-dired-display-next-thumbnail-original' has been renamed to
- 'image-dired-display-next'.
-- 'image-dired-display-previous-thumbnail-original' has been renamed
- to 'image-dired-display-previous'.
-The old names are now obsolete aliases.
-
-*** 'image-dired-thumb-{height,width}' are now obsolete.
-Customize 'image-dired-thumb-size' instead, which will set both the
-height and width.
-
-*** HTML image gallery generation is now obsolete.
-The 'image-dired-gallery-generate' command and these user options are
-now obsolete: 'image-dired-gallery-thumb-image-root-url',
-'image-dired-gallery-hidden-tags', 'image-dired-gallery-dir',
-'image-dired-gallery-image-root-url'.
-
-*** 'image-dired-rotate-thumbnail-{left,right}' are now obsolete.
-Instead, use commands 'image-dired-refresh-thumb' to generate a new
-thumbnail, or 'image-rotate' to rotate the thumbnail without updating
-the thumbnail file.
-
-*** Some commands and user options are now obsolete.
-Since 'image-dired-display-image-mode' is now based on 'image-mode',
-some commands and user options are no longer needed and are now obsolete:
-'image-dired-cmd-create-temp-image-options',
-'image-dired-cmd-create-temp-image-program',
-'image-dired-display-current-image-full',
-'image-dired-display-current-image-sized',
-'image-dired-display-window-height-correction',
-'image-dired-display-window-width-correction',
-'image-dired-temp-image-file'.
-
-** Exif
-
-*** New function 'exif-field'.
-This is a convenience function to extract the field data from
-'exif-parse-file' and 'exif-parse-buffer'.
-
-** Bookmarks
-
-*** 'list-bookmarks' now includes a type column.
-Types are registered via a 'bookmark-handler-type' symbol property on
-the jumping function.
-
-*** 'bookmark-sort-flag' can now be set to 'last-modified'.
-This will display bookmark list from most recently set to least
-recently set.
-
-*** When editing a bookmark annotation, 'C-c C-k' will now cancel.
-It is bound to the new command 'bookmark-edit-annotation-cancel'.
-
-*** New user option 'bookmark-fringe-mark'.
-This option controls the bitmap used to indicate bookmarks in the
-fringe (or nil to disable showing this marker).
-
-** Xwidget
-
-*** New user option 'xwidget-webkit-buffer-name-format'.
-This option controls how xwidget-webkit buffers are named.
-
-*** New user option 'xwidget-webkit-cookie-file'.
-This option controls whether the xwidget-webkit buffers save cookies
-set by web pages, and if so, in which file to save them.
-
-*** New minor mode 'xwidget-webkit-edit-mode'.
-When this mode is enabled, self-inserting characters and other common
-web browser shortcut keys are redefined to send themselves to the
-WebKit widget.
-
-*** New minor mode 'xwidget-webkit-isearch-mode'.
-This mode acts similarly to incremental search, and allows searching
-the contents of a WebKit widget. In xwidget-webkit mode, it is bound
-to 'C-s' and 'C-r'.
-
-*** New command 'xwidget-webkit-browse-history'.
-This command displays a buffer containing the page load history of
-the current WebKit widget, and allows you to navigate it.
-
-*** On X, the WebKit inspector is now available inside xwidgets.
-To access the inspector, right click on the widget and select "Inspect
-Element".
-
-*** "Open in New Window" in a WebKit widget's context menu now works.
-The newly created buffer will be displayed via 'display-buffer', which
-can be customized through the usual mechanism of 'display-buffer-alist'
-and friends.
-
-** Tramp
-
-*** New connection methods "docker", "podman" and "kubernetes".
-They allow accessing containers provided by Docker and similar
-programs.
-
-*** Tramp supports abbreviating remote home directories now.
-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 lets the 'scp'
-command do this job.
+*** New user option 'image-dired-thumb-naming'.
+You can now configure how a thumbnail is named using this option.
-*** Proper password prompts for methods "doas", "sudo" and "sudoedit".
-The password prompts for these methods reflect now the credentials of
-the user requesting such a connection, and not of the user who is the
-target. This has always been needed, just the password prompt and the
-related 'auth-sources' entry were wrong.
-
-*** New user option 'tramp-completion-use-cache'.
-During user and host name completion in the minibuffer, results from
-Tramp's connection cache are taken into account. This can be disabled
-by setting the user option 'tramp-completion-use-cache' to nil.
-
-** Browse URL
-
-*** New user option 'browse-url-default-scheme'.
-This user option decides which URL scheme that 'browse-url' and
-related functions will use by default. For example, you could
-customize this to "https" to always prefer HTTPS URLs.
-
-*** New user option 'browse-url-irc-function'.
-This option specifies a function for opening "irc://" links. It
-defaults to the new function 'browse-url-irc'.
-
-*** New function 'browse-url-irc'.
-This multipurpose autoloaded function can be used for opening "irc://"
-and "ircs://" URLS by any caller that passes a URL string as an initial
-arg.
-
-*** Support for the Netscape web browser has been removed.
-This support has been obsolete since Emacs 25.1. The final version of
-the Netscape web browser was released in February, 2008.
-
-*** Support for the Galeon web browser has been removed.
-This support has been obsolete since Emacs 25.1. The final version of
-the Galeon web browser was released in September, 2008.
-
-*** Support for the Mozilla web browser is now obsolete.
-Note that this historical web browser is different from Mozilla
-Firefox; it is its predecessor.
-
-** Python Mode
-
-*** Project shells and a new user option 'python-shell-dedicated'.
-When called with a prefix argument, 'run-python' now offers the choice
-of creating a shell dedicated to the current project. This shell runs
-in the project root directory and is shared among all project buffers.
-
-Without a prefix argument, the kind of shell (buffer-dedicated,
-project-dedicated or global) is specified by the new
-'python-shell-dedicated' user option.
-
-** Ruby Mode
-
-*** New user option 'ruby-toggle-block-space-before-parameters'.
-
-*** Support for endless methods.
-
-*** New user options that determine indentation logic.
-'ruby-method-params-indent', 'ruby-block-indent',
-'ruby-after-operator-indent', 'ruby-method-call-indent',
-'ruby-parenless-call-arguments-indent'. See the docstrings for
-explanations and examples.
-
-** Eshell
-
-*** New feature to easily bypass Eshell's own pipelining.
-Prefixing '|', '<' or '>' with an asterisk, i.e. '*|', '*<' or '*>',
-will cause the whole command to be passed to the operating system
-shell. This is particularly useful to bypass Eshell's own pipelining
-support for pipelines which will move a lot of data. See section
-"Running Shell Pipelines Natively" in the Eshell manual, node
-"(eshell) Pipelines".
-
-*** 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 the "(eshell) Electric forward slash" node in the
-Eshell manual for details.
-
-*** Improved support for redirection operators in Eshell.
-Eshell now supports a wider variety of redirection operators. For
-example, you can now redirect both stdout and stderr via '&>' or
-duplicate one output handle to another via 'NEW-FD>&OLD-FD'. For more
-information, see the "(eshell) Redirection" node in the Eshell manual.
-
-*** New eshell built-in command 'doas'.
-The privilege-escalation program 'doas' has been added to the existing
-'su' and 'sudo' commands from the 'eshell-tramp' module. The external
-command may still be accessed by using '*doas'.
-
-*** 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.
-
-*** Eshell globs ending with "/" now match only directories.
-Additionally, globs ending with "**/" or "***/" no longer raise an
-error, and now expand to all directories recursively (following
-symlinks in the latter case).
-
-*** Lisp forms in Eshell now treat a nil result as a failed exit status.
-When executing a command that looks like '(lisp form)' and returns
-nil, Eshell will set the exit status (available in the '$?'
-variable) to 2. This allows commands like that to be used in
-conditionals. To change this behavior, customize the new
-'eshell-lisp-form-nil-is-failure' user option.
-
-** Shell
-
-*** New user option 'shell-kill-buffer-on-exit'.
-Enabling this will automatically kill a "*shell*" buffer as soon as
-the shell session terminates.
-
-*** New minor mode 'shell-highlight-undef-mode'.
-Customize 'shell-highlight-undef-enable' to t if you want to enable
-this minor mode in "*shell*" buffers. It will highlight undefined
-commands with a warning face as you type.
-
-** Calc
-
-*** New user option 'calc-kill-line-numbering'.
-Set it to nil to exclude line numbering from kills and copies.
-
-** Hierarchy
+** ERT
-*** Tree Display can delay computation of children.
-'hierarchy-add-tree' and 'hierarchy-add-trees' have an optional
-argument which allows tree-widget display to be activated and computed
-only when the user expands the node.
++++
+*** New macro 'skip-when' to skip 'ert-deftest' tests.
+This can help avoid some awkward skip conditions. For example
+'(skip-unless (not noninteractive))' can be changed to the easier
+to read '(skip-when noninteractive)'.
+
++++
+*** Syntax highlighting unit testing support.
+An ERT extension ('ert-font-lock') now provides support for face
+assignment unit testing. For more information, see the "(ert) Syntax
+Highlighting Tests" node in the ERT manual.
+
+** URL
+
++++
+*** 'url-gateway-broken-resolution' is now obsolete.
+This option was intended for use on SunOS 4.x and Ultrix systems,
+neither of which have been supported by Emacs since version 23.1.
+The user option 'url-gateway-nslookup-program' and the function
+'url-gateway-nslookup-host' are consequently also obsolete.
+
+** Socks
+
++++
+*** Socks supports version 4a.
+The 'socks-server' user option accepts '4a' as a value for its version
+field.
+
+** Edmacro
+
++++
+*** New command 'edmacro-set-macro-to-region-lines'.
+Bound to 'C-c C-r', this command replaces the macro text with the
+lines of the region. If needed, the region is extended to include
+whole lines. If the region ends at the beginning of a line, that last
+line is excluded.
+
++++
+*** New user option 'edmacro-reverse-macro-lines'.
+When this is non-nil, the lines of key sequences are displayed with
+the most recent line first. This is can be useful when working with
+macros with many lines, such as from 'kmacro-edit-lossage'.
** Proced
-*** 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.
-
-*** Proced can now optionally show process details in color.
-New user option 'proced-enable-color-flag' enables coloring of Proced
-buffers. This option is disabled by default; customize it to a
-non-nil value to enable colors.
+---
+*** More control on automatic update of Proced buffers.
+The user option 'proced-auto-update-flag' can now be set to 2 additional
+values, which control automatic updates of Proced buffers that are not
+displayed in some window.
** Miscellaneous
-*** New user option 'webjump-use-internal-browser'.
-When non-nil, WebJump will use an internal browser to open web pages,
-instead of the default external browser.
+---
+*** Webjump now assumes URIs are HTTPS instead of HTTP.
+For links in 'webjump-sites' without an explicit URI scheme, it was
+previously assumed that they should be prefixed with "http://". Such
+URIs are now prefixed with "https://" instead.
+
+---
+*** 'bug-reference-mode' now supports 'thing-at-point'.
+Now, calling '(thing-at-point 'url)' when point is on a bug reference
+will return the URL for that bug.
+
++++
+*** New user option 'rcirc-log-time-format'
+This allows for rcirc logs to use a custom timestamp format, than the
+chat buffers use by default.
+
+---
+*** New user option 'Buffer-menu-group-by'.
+It controls how buffers are divided into groups that are displayed with
+headings using Outline minor mode.
+
++++
+*** New command 'Buffer-menu-toggle-internal'.
+This command toggles the display of internal buffers in Buffer Menu mode;
+that is, buffers not visiting a file and whose names start with a space.
+Previously, such buffers were never shown. This command is bound to 'I'
+in Buffer Menu mode.
-*** New user option 'font-lock-ignore'.
-This option provides a mechanism to selectively disable font-lock
-keyword-driven fontifications.
-
-*** New user option 'auto-save-visited-predicate'.
-This user option is a predicate function which is called by
-'auto-save-visited-mode' to decide whether or not to save a buffer.
-You can use it to automatically save only specific buffers, for
-example buffers using a particular mode or in some directory.
-
-*** New user option 'remote-file-name-inhibit-auto-save-visited'.
-If this user option is non-nil, 'auto-save-visited-mode' will not
-auto-save remote buffers. The default is nil.
-
-*** 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"
-manual for more details.
-
-*** New minor mode 'elide-head-mode'.
-Enabling this minor mode turns on hiding header material, like
-'elide-head' does; disabling it shows the header. The commands
-'elide-head' and 'elide-head-show' are now obsolete.
-
-*** New package ansi-osc.el.
-Support for OSC ("Operating System Command") escape sequences has been
-extracted from comint.el in order to provide interpretation of OSC
-sequences in compilation buffers.
-
-Adding the new function 'ansi-osc-compilation-filter' to
-'compilation-filter-hook' enables interpretation of OSC escape
-sequences in compilation buffers. By default, all sequences are
-filtered out.
-
-The list of handlers (already covering OSC 7 and 8) has been extended
-with a handler for OSC 2, the command to set a window title.
-
-*** 'recentf-mode' now uses abbreviated file names by default.
-This means that e.g. "/home/foo/bar" is now displayed as "~/bar".
-Customize the user option 'recentf-filename-handlers' to nil to get
-back the old behavior.
-
-*** New command 'recentf-open'.
-This command prompts for a recently opened file in the minibuffer, and
-visits it.
-
-*** 'ffap-machine-at-point' no longer pings hosts by default.
-It will now simply look at a hostname to determine if it is valid,
-instead of also trying to ping it. Customize the user option
-'ffap-machine-p-known' to 'ping' to get the old behavior back.
+** Customize
-*** The 'run-dig' command is now obsolete; use 'dig' instead.
++++
+*** New command 'customize-dirlocals'.
+This command pops up a buffer to edit the settings in ".dir-locals.el".
-*** Some 'bib-mode' commands and variables have been renamed.
-To respect Emacs naming conventions, the variable 'unread-bib-file'
-has been renamed to 'bib-unread-file'. The following commands have
-also been renamed:
- 'addbib' to 'bib-add'
- 'return-key-bib' to 'bib-return-key'
- 'mark-bib' to 'bib-mark'
- 'unread-bib' to 'bib-unread'
+---
+** New command 'customize-toggle-option'.
+This command can toggle boolean options for the duration of a session.
-*** 'outlineify-sticky' command is renamed to 'allout-outlinify-sticky'.
-The old name is still available as an obsolete function alias.
+** Calc
-*** The url-irc library now understands "ircs://" links.
++++
+*** Calc parses fractions written using U+2044 FRACTION SLASH.
+Fractions of the form "123⁄456" are handled as if written "123:456".
+Note in particular the difference in behavior from U+2215 DIVISION SLASH
+and U+002F SOLIDUS, which result in division rather than a rational
+fraction. You may also be interested to know that precomposed fraction
+characters, such as ½ (U+00BD VULGAR FRACTION ONE HALF), are also
+recognized as rational fractions. They have been since 2004, but it
+looks like it was never mentioned in the NEWS, or even the manual.
-*** New command 'world-clock-copy-time-as-kill' for 'world-clock-mode'.
-It copies the current line into the kill ring.
+** IELM
-*** 'edit-abbrevs' now uses font-locking.
-The new face 'abbrev-table-name' is used to display the abbrev table
-name.
+---
+*** IELM now remembers input history between sessions.
+The new user option 'ielm-history-file-name' is the name of the file
+where IELM input history will be saved. Customize it to nil to revert
+to the old behavior of not remembering input history between sessions.
-*** New key binding 'O' in "*Buffer List*".
-This key is now bound to 'Buffer-menu-view-other-window', which will
-view this line's buffer in View mode in another window.
+** EasyPG
-** Scheme Mode
++++
+*** New user option 'epa-keys-select-method'.
+This allows the user to customize the key selection method, which can be
+either by using a pop-up buffer or from the minibuffer. The pop-up
+buffer method is the default, which preserves previous behavior.
-*** Auto-detection of Scheme library files.
-Emacs now automatically enables the Scheme mode when opening R6RS
-Scheme Library Source (".sls") files and R7RS Scheme Library
-Definition (".sld") files.
+** Xwidget Webkit
-*** Imenu members for R6RS and R7RS library members.
-Imenu now lists the members directly nested in R6RS Scheme libraries
-('library') and R7RS libraries ('define-library').
++++
+*** New user option 'xwidget-webkit-disable-javascript'.
+This allows disabling JavaScript in xwidget Webkit sessions.
-* New Modes and Packages in Emacs 29.1
-
-** Eglot: Emacs Client for the Language Server Protocol.
-Emacs now comes with the Eglot package, which enhances various Emacs
-features, such as completion, documentation, error detection, etc.,
-based on data provided by language servers using the Language Server
-Protocol (LSP). See the new Info manual "(eglot) Top" for more. Also
-see "etc/EGLOT-NEWS".
-
-If you want to be able to use 'package-install' to upgrade Eglot to
-newer versions released on GNU ELPA, customize the new option
-'package-install-upgrade-built-in' to a non-nil value.
-
-** use-package: Declarative package configuration.
-use-package is now shipped with Emacs. It provides the 'use-package'
-macro, which allows you to isolate package configuration in your init
-file in a way that is declarative, tidy, and performance-oriented.
-See the new Info manual "(use-package) Top" for more.
-
-If you want to be able to use 'package-install' to upgrade use-package
-to newer versions released on GNU ELPA, customize the new option
-'package-install-upgrade-built-in' to a non-nil value.
-
-** New package 'wallpaper'.
-This package provides the command 'wallpaper-set', which sets the
-desktop background image. Depending on the system and the desktop,
-this may require an external program (such as "swaybg", "gm",
-"display" or "xloadimage"). If so, a suitable command should be
-detected automatically in most cases. It can also be customized
-manually if needed, using the new user options 'wallpaper-command' and
-'wallpaper-command-args'.
-
-** New package 'oclosure'.
-This allows the creation of OClosures, which are "functions with
-slots" or "function objects" that expose additional information about
-themselves. Use the new macros 'oclosure-define' and
-'oclosure-lambda' to create OClosures. See the "(elisp) OClosures"
-node for more information.
-
-*** 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.
-
-** New mode 'erts-mode'.
-This mode is used to edit files geared towards testing actions in
-Emacs buffers, like indentation and the like. The new ert function
-'ert-test-erts-file' is used to parse these files.
-
-** New major mode 'js-json-mode'.
-This is a lightweight variant of 'js-mode' that is used by default
-when visiting JSON files.
-
-** New major mode 'csharp-mode'.
-A major mode based on CC Mode for editing programs in the C# language.
-This mode is auto-enabled for files with the ".cs" extension.
-
-** New major modes based on the tree-sitter library.
-These new major modes are available if Emacs was built with the
-tree-sitter library. They provide support for font-locking,
-indentation, and navigation by defuns based on parsing the buffer text
-by a tree-sitter parser. Some major modes also offer support for
-Imenu and 'which-func'.
-
-The new modes based on tree-sitter are for now entirely optional, and
-you must turn them on manually, or load them in your init file, or
-customize 'auto-mode-alist' to turn them on automatically for certain
-files. You can also customize 'major-mode-remap-alist' to
-automatically turn on some tree-sitter based modes for the same files
-for which a "built-in" mode would be turned on. For example:
-
- (add-to-list 'major-mode-remap-alist '(ruby-mode . ruby-ts-mode))
-
-If you try these modes and don't like them, you can go back to the
-"built-in" modes by restarting Emacs. (If you use desktop.el to save
-and restore Emacs sessions, make sure no buffer under these modes is
-recorded in the desktop file, before restarting.) But please tell us
-why you didn't like the tree-sitter based modes, so that we could try
-improving them.
-
-Each major mode based on tree-sitter needs a language grammar library,
-usually named "libtree-sitter-LANG.so" ("libtree-sitter-LANG.dll" on
-MS-Windows), where LANG is the corresponding language name. Emacs
-looks for these libraries in the following places:
-
- . in the directories mentioned in the list 'treesit-extra-load-path'
- . in the "tree-sitter" subdirectory of your 'user-emacs-directory'
- (by default, "~/.emacs.d/tree-sitter")
- . in the standard system directories where other shared libraries are
- usually installed
-
-We recommend to install these libraries in one of the standard system
-locations (the last place in the above list).
-
-If a language grammar library required by a mode is not found in any
-of the above places, the mode will display a warning when you try to
-turn it on.
-
-*** New major mode 'typescript-ts-mode'.
-A major mode based on the tree-sitter library for editing programs
-in the TypeScript language.
-
-*** New major mode 'tsx-ts-mode'.
-A major mode based on the tree-sitter library for editing programs
-in the TypeScript language, with support for TSX.
-
-*** New major mode 'c-ts-mode'.
-An optional major mode based on the tree-sitter library for editing
-programs in the C language.
+* New Modes and Packages in Emacs 30.1
-*** New major mode 'c++-ts-mode'.
-An optional major mode based on the tree-sitter library for editing
-programs in the C++ language.
-
-*** New command 'c-or-c++-ts-mode'.
-A command that automatically guesses the language of a header file,
-and enables either 'c-ts-mode' or 'c++-ts-mode' accordingly.
-
-*** New major mode 'java-ts-mode'.
-An optional major mode based on the tree-sitter library for editing
-programs in the Java language.
-
-*** New major mode 'python-ts-mode'.
-An optional major mode based on the tree-sitter library for editing
-programs in the Python language.
+** New major modes based on the tree-sitter library
-*** New major mode 'css-ts-mode'.
++++
+*** New major mode 'html-ts-mode'.
An optional major mode based on the tree-sitter library for editing
-CSS (Cascading Style Sheets).
+HTML files.
-*** New major mode 'json-ts-mode'.
-An optional major mode based on the tree-sitter library for editing
-programs in the JSON language.
-
-*** New major mode 'csharp-ts-mode'.
-An optional major mode based on the tree-sitter library for editing
-programs in the C# language.
+---
+*** New major mode 'heex-ts-mode'.
+A major mode based on the tree-sitter library for editing HEEx files.
-*** New major mode 'bash-ts-mode'.
-Am optional major mode based on the tree-sitter library for editing
-Bash shell scripts.
+---
+*** New major mode 'elixir-ts-mode'.
+A major mode based on the tree-sitter library for editing Elixir files.
-*** New major mode 'dockerfile-ts-mode'.
-A major mode based on the tree-sitter library for editing
-Dockerfiles.
-
-*** New major mode 'cmake-ts-mode'.
-A major mode based on the tree-sitter library for editing CMake files.
-
-*** New major mode 'toml-ts-mode'.
-An optional major mode based on the tree-sitter library for editing
-files written in TOML, a format for writing configuration files.
+---
+*** New major mode 'lua-ts-mode'.
+A major mode based on the tree-sitter library for editing Lua files.
-*** New major mode 'go-ts-mode'.
-A major mode based on the tree-sitter library for editing programs in
-the Go language.
-
-*** New major mode 'go-mod-ts-mode'.
-A major mode based on the tree-sitter library for editing "go.mod"
-files.
-
-*** New major mode 'yaml-ts-mode'.
-A major mode based on the tree-sitter library for editing files
-written in YAML.
-
-*** New major mode 'rust-ts-mode'.
-A major mode based on the tree-sitter library for editing programs in
-the Rust language.
+** Minibuffer and Completions
-*** New major mode 'ruby-ts-mode'.
-An optional major mode based on the tree-sitter library for editing
-programs in the Ruby language.
++++
+*** New global minor mode 'minibuffer-regexp-mode'.
+This is a minor mode for editing regular expressions in the minibuffer.
+It highlights parens via ‘show-paren-mode’ and ‘blink-matching-paren’ in
+a user-friendly way, avoids reporting alleged paren mismatches and makes
+sexp navigation more intuitive.
+
++++
+*** New minor mode 'completion-preview-mode'.
+This minor mode shows you symbol completion suggestions as you type,
+using an inline preview. New user options in the 'completion-preview'
+customization group control exactly when Emacs displays this preview.
+
+---
+** The highly accessible Modus themes collection has eight items.
+The 'modus-operandi' and 'modus-vivendi' are the main themes that have
+been part of Emacs since version 28. The former is light, the latter
+dark. In addition to these, we now have 'modus-operandi-tinted' and
+'modus-vivendi-tinted' for easier legibility, as well as
+'modus-operandi-deuteranopia', 'modus-vivendi-deuteranopia',
+'modus-operandi-tritanopia', and 'modus-vivendi-tritanopia' to cover
+the needs of users with red-green or blue-yellow color deficiency.
+The Info manual "(modus-themes) Top" describes the details and
+showcases all their customization options.
+
++++
+** New global minor mode 'etags-regen-mode'.
+This minor mode generates the tags table automatically based on the
+current project configuration, and later updates it as you edit the
+files and save the changes.
+
++++
+** New package Compat.
+Emacs now comes with a stub implementation of the
+forwards-compatibility Compat package from GNU ELPA. This allows
+built-in packages to use the library more effectively, and helps
+preventing the installation of Compat if unnecessary.
-* Incompatible Lisp Changes in Emacs 29.1
-
-** The implementation of overlays has changed.
-Emacs now uses an implementation of overlays that is much more
-efficient than the original one, and should speed up all the
-operations that involve overlays, especially when there are lots of
-them in a buffer.
-
-As result of this, some minor incompatibilities in behavior could be
-observed, as described below. Except those minor incompatibilities,
-no other changes in behavior of overlays should be visible on the Lisp
-or user level, with the exception of better performance and the order
-of overlays returned by functions that don't promise any particular
-order.
-
-*** The function 'overlay-recenter' is now a no-op.
-This function does nothing, and in particular has no effect on the
-value returned by 'overlay-lists'. The purpose of 'overlay-recenter'
-was to allow more efficient lookup of overlays around a certain buffer
-position; however with the new implementation the lookup of overlays
-is efficient regardless of their position, and there's no longer any
-need to "optimize" the lookup, nor any notion of a "center" of the
-overlays.
-
-*** The function 'overlay-lists' returns one unified list of overlays.
-This function used to return a cons of two lists, one with overlays
-before the "center" position, the other after that "center". It now
-returns a list whose 'car' is the list of all the buffer overlays, and
-whose 'cdr' is always nil.
-
-** 'format-prompt' now uses 'substitute-command-keys'.
-This means that both the prompt and 'minibuffer-default-prompt-format'
-will have key definitions and single quotes handled specially.
-
-** New function 'substitute-quotes'.
-This function works like 'substitute-command-keys' but only
-substitutes quote characters.
-
-** 'find-image' now uses 'create-image'.
-This means that images found through 'find-image' also have
-auto-scaling applied. (This only makes a difference on HiDPI
-displays.)
-
-** Changes in how "raw" in-memory XBM images are specified.
-Some years back Emacs gained the ability to scale images, and you
-could then specify ':width' and ':height' when using 'create-image' on all
-image types -- except XBM images, because this format already used the
-':width' and ':height' arguments to specify the width/height of the "raw"
-in-memory format. This meant that if you used these specifications
-on, for instance, XBM files, Emacs would refuse to display them. This
-has been changed, and ':width'/':height' now works as with all other image
-formats, and the way to specify the width/height of the "raw"
-in-memory format is now by using ':data-width' and ':data-height'.
-
-** "loaddefs.el" generation has been reimplemented.
-The various "loaddefs.el" files in the Emacs tree (which contain
-information about autoloads, built-in packages and package prefixes)
-used to be generated by functions in autoloads.el. These are now
-generated by loaddefs-gen.el instead. This leads to functionally
-equivalent "loaddefs.el" files, but they do not use exactly the same
-syntax, so using 'M-x update-file-autoloads' no longer works. (This
-didn't work well in most files in the past, either, but it will now
-signal an error in any file.)
-
-In addition, files are scanned in a slightly different way.
-Previously, ';;;###' specs inside a top-level form (i.e., something
-like '(when ... ;;;### ...)' would be ignored. They are now parsed as
-usual.
-
-** Themes have special autoload cookies.
-All built-in themes are scraped for ';;;###theme-autoload' cookies
-that are loaded along with the regular auto-loaded code.
-
-** 'buffer-modified-p' has been extended.
-This function was previously documented to return only nil or t. This
-has been changed to nil/'autosaved'/non-nil. The new 'autosaved'
-value means that the buffer is modified, but that it hasn't been
-modified since the time of last auto-save.
-
-** 'with-silent-modifications' also restores buffer autosave status.
-'with-silent-modifications' is a macro meant to be used by the font
-locking machinery to allow applying text properties without changing
-the modification status of the buffer. However, it didn't restore the
-buffer autosave status, so applying font locking to a modified buffer
-that had already been auto-saved would trigger another auto-saving.
-This is no longer the case.
-
-** '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' face 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'.
-
-** 'make-process' has been extended to support ptys when ':stderr' is set.
-Previously, setting ':stderr' to a non-nil value would force the
-process's connection to use pipes. Now, Emacs will use a pty for
-stdin and stdout if requested no matter the value of ':stderr'.
-
-** 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
-needed.
-
-** Fonts
-
-*** Emacs now supports 'medium' fonts.
-Emacs previously didn't distinguish between the 'regular'/'normal'
-weight and the 'medium' weight, but it now also supports the (heavier)
-'medium' weight. However, this means that if you specify 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 by Help commands have changed.
-'help--describe-command', 'C-h b' and associated functions that output
-keymap descriptions have changed. In particular, prefix commands are
-not output at all, and instead of "??" for closures/functions, these
-functions output "[closure]"/"[lambda]". You can get back the old
-behavior of including prefix commands by customizing the new option
-'describe-bindings-show-prefix-commands' to a non-nil value.
-
-** 'downcase' details have changed slightly.
-In certain locales, changing the case of an ASCII-range character may
-turn it into a multibyte character, most notably with "I" in Turkish
-(the lowercase is "ı", 0x0131). Previously, 'downcase' on a unibyte
-string was buggy, and would mistakenly just return the lower byte of
-this, 0x31 (the digit "1"). 'downcase' on a unibyte string has now
-been changed to downcase such characters as if they were ASCII. To
-get proper locale-dependent downcasing, the string has to be converted
-to multibyte first. (This goes for the other case-changing functions,
-too.)
-
-** Functions in 'tramp-foreign-file-name-handler-alist' have changed.
-Functions to determine which Tramp file name handler to use are now
-passed a file name in dissected form (via 'tramp-dissect-file-name')
-instead of in string form.
-
-** 'def' indentation changes.
-In 'emacs-lisp-mode', forms with a symbol with a name that start with
-"def" have been automatically indented as if they were 'defun'-like
-forms, for instance:
-
- (defzot 1
- 2 3)
-
-This heuristic has now been removed, and all functions/macros that
-want to be indented this way have to be marked with
-
- (declare (indent defun))
-
-or the like. If the function/macro definition itself can't be
-changed, the indentation can also be adjusted by saying something
-like:
-
- (put 'defzot 'lisp-indent-function 'defun)
-
-** The 'inhibit-changing-match-data' variable is now obsolete.
-Instead, functions like 'string-match' and 'looking-at' now take an
-optional INHIBIT-MODIFY argument.
-
-** 'gnus-define-keys' is now obsolete.
-Use 'define-keymap' instead.
-
-** MozRepl has been removed from js.el.
-MozRepl was removed from Firefox in 2017, so this code doesn't work
-with recent versions of Firefox.
-
-** The function 'image-dired-get-exif-data' is now obsolete.
-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'.
-
-** 'compilation-last-buffer' is (finally) declared obsolete.
-It has been obsolete since Emacs 22.1, actually.
-
-** Calling 'lsh' now elicits a byte-compiler warning.
-'lsh' behaves in somewhat surprising and platform-dependent ways for
-negative arguments, and is generally slower than 'ash', which should be
-used instead. This warning can be suppressed by surrounding calls to
-'lsh' with the construct '(with-suppressed-warnings ((suspicious lsh)) ...)',
-but switching to 'ash' is generally much preferable.
-
-** Some functions and variables obsolete since Emacs 24 have been removed:
-'Buffer-menu-buffer+size-width', 'Electric-buffer-menu-mode',
-'Info-edit-map', 'allout-abbreviate-flattened-numbering',
-'allout-exposure-change-hook', 'allout-mode-deactivate-hook',
-'allout-structure-added-hook', 'allout-structure-deleted-hook',
-'allout-structure-shifted-hook', 'ansi-color-unfontify-region',
-'archive-extract-hooks', 'auth-source-forget-user-or-password',
-'auth-source-hide-passwords', 'auth-source-user-or-password',
-'automatic-hscrolling', 'automount-dir-prefix', 'bibtex-complete',
-'bibtex-entry-field-alist', 'buffer-has-markers-at',
-'buffer-substring-filters', 'byte-compile-disable-print-circle',
-'c-prepare-bug-report-hooks', 'cfengine-mode-abbrevs',
-'change-log-acknowledgement', 'chart-map',
-'checkdoc-comment-style-hooks', 'comint--unquote&expand-filename',
-'comint-dynamic-complete', 'comint-dynamic-complete-as-filename',
-'comint-dynamic-simple-complete', 'comint-unquote-filename',
-'command-history-map', 'compilation-parse-errors-function',
-'completion-annotate-function', 'condition-case-no-debug',
-'count-lines-region', 'crisp-mode-modeline-string',
-'custom-print-functions', 'cvs-string-prefix-p', 'data-debug-map',
-'deferred-action-function', 'deferred-action-list',
-'dired-pop-to-buffer', 'dired-shrink-to-fit',
-'dired-sort-set-modeline', 'dired-x-submit-report',
-'display-buffer-function',
-'ediff-choose-window-setup-function-automatically',
-'eieio-defgeneric', 'eieio-defmethod', 'emacs-lock-from-exiting',
-'erc-complete-word', 'erc-dcc-chat-filter-hook',
-'eshell-add-to-window-buffer-names', 'eshell-cmpl-suffix-list',
-'eshell-for', 'eshell-remove-from-window-buffer-names',
-'eshell-status-in-modeline', 'filesets-cache-fill-content-hooks',
-'font-list-limit', 'font-lock-maximum-size',
-'font-lock-reference-face', 'gnus-carpal',
-'gnus-debug-exclude-variables', 'gnus-debug-files',
-'gnus-local-domain', 'gnus-outgoing-message-group',
-'gnus-registry-user-format-function-M', 'gnus-secondary-servers',
-'gnus-subscribe-newsgroup-hooks', 'gud-inhibit-global-bindings',
-'hangul-input-method-inactivate', 'hfy-post-html-hooks',
-'image-extension-data', 'image-library-alist',
-'inactivate-current-input-method-function', 'inactivate-input-method',
-'inhibit-first-line-modes-regexps',
-'inhibit-first-line-modes-suffixes', 'input-method-inactivate-hook',
-'intdos', 'javascript-generic-mode', 'javascript-generic-mode-hook',
-'latex-string-prefix-p', 'macro-declaration-function' (function),
-'macro-declaration-function' (variable), 'mail-complete',
-'mail-complete-function', 'mail-mailer-swallows-blank-line',
-'mail-sent-via', 'make-register', 'makefile-complete',
-'menu-bar-kill-ring-save', 'meta-complete-symbol', 'meta-mode-map',
-'mh-kill-folder-suppress-prompt-hooks',
-'minibuffer-completing-symbol',
-'minibuffer-local-filename-must-match-map', 'mode25', 'mode4350',
-'mpc-string-prefix-p', 'msb-after-load-hooks',
-'nndiary-request-accept-article-hooks',
-'nndiary-request-create-group-hooks',
-'nndiary-request-update-info-hooks', 'nnimap-split-rule',
-'nntp-authinfo-file', 'ns-alternatives-map',
-'ns-store-cut-buffer-internal', 'package-menu-view-commentary',
-'pascal-last-completions', 'pascal-show-completions',
-'pascal-toggle-completions', 'pcomplete-arg-quote-list',
-'pcomplete-quote-argument', 'prolog-char-quote-workaround',
-'python-buffer', 'python-guess-indent', 'python-indent',
-'python-info-ppss-comment-or-string-p', 'python-info-ppss-context',
-'python-info-ppss-context-type', 'python-preoutput-result',
-'python-proc', 'python-send-receive', 'python-send-string',
-'python-use-skeletons', 'quail-inactivate', 'quail-inactivate-hook',
-'query-replace-interactive', 'rcirc-activity-hooks',
-'rcirc-print-hooks', 'rcirc-receive-message-hooks',
-'rcirc-sentinel-hooks', 'read-filename-at-point', 'redraw-modeline',
-'reftex-index-map', 'reftex-index-phrases-map',
-'reftex-select-bib-map', 'reftex-select-label-map', 'reftex-toc-map',
-'register-name-alist', 'register-value', 'report-emacs-bug-info',
-'report-emacs-bug-pretest-address',
-'rmail-default-dont-reply-to-names', 'rmail-dont-reply-to',
-'rmail-dont-reply-to-names', 'robin-inactivate',
-'robin-inactivate-hook', 'rst-block-face', 'rst-comment-face',
-'rst-definition-face', 'rst-directive-face', 'rst-emphasis1-face',
-'rst-emphasis2-face', 'rst-external-face', 'rst-literal-face',
-'rst-reference-face', 'semantic-change-hooks',
-'semantic-edits-delete-change-hooks',
-'semantic-edits-new-change-hooks',
-'semantic-edits-reparse-change-hooks', 'semantic-grammar-map',
-'semantic-grammar-syntax-table', 'semantic-lex-reset-hooks',
-'semanticdb-elisp-sym-function-arglist',
-'semanticdb-save-database-hooks', 'set-face-underline-p',
-'set-register-value', 'sh-maybe-here-document', 'speedbar-key-map',
-'speedbar-syntax-table', 'starttls-any-program-available',
-'strokes-modeline-string', 'strokes-report-bug',
-'term-default-bg-color', 'term-default-fg-color',
-'tex-string-prefix-p', 'timeclock-modeline-display',
-'timeclock-modeline-display', 'timeclock-update-modeline',
-'toggle-emacs-lock', 'tooltip-use-echo-area', 'turn-on-cwarn-mode',
-'turn-on-iimage-mode', 'ucs-input-inactivate', 'ucs-insert',
-'url-recreate-url-attributes', 'user-variable-p',
-'vc-string-prefix-p', 'vc-toggle-read-only', 'view-return-to-alist',
-'view-return-to-alist-update', 'w32-default-color-map' (function),
-'which-func-mode' (function), 'window-system-version',
-'winner-mode-leave-hook', 'x-cut-buffer-or-selection-value'.
-
-** Some functions and variables obsolete since Emacs 23 have been removed:
-'find-emacs-lisp-shadows', 'newsticker-cache-filename',
-'process-filter-multibyte-p', 'redisplay-end-trigger-functions',
-'set-process-filter-multibyte', 'set-window-redisplay-end-trigger',
-'unify-8859-on-decoding-mode', 'unify-8859-on-encoding-mode',
-'vc-arch-command', 'window-redisplay-end-trigger', 'x-selection'.
-
-** Some functions and variables obsolete since Emacs 21 or 22 have been removed:
-'c-toggle-auto-state', 'find-file-not-found-hooks',
-'ls-lisp-dired-ignore-case', 'query-replace-regexp-eval'.
-
-** New generic function 'function-documentation'.
-It 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',
-'base64-encode-region' and 'base64url-encode-region' no longer accept
-characters in the range U+0080..U+00FF as substitutes for single bytes
-in the range 128..255, but signal an error for all multibyte characters.
-The input must be unibyte encoded text.
-
-** The 'clone-indirect-buffer-hook' is now run by 'make-indirect-buffer'.
-It was previously only run by 'clone-indirect-buffer' and
-'clone-indirect-buffer-other-window'. Since 'make-indirect-buffer' is
-called by both of these, the hook is now run by all 3 of these
-functions.
-
-** '?\' at the end of a line now signals an error.
-Previously, it produced a nonsense value, -1, that was never intended.
-
-** Some libraries obsolete since Emacs 24.1 and 24.3 have been removed:
-abbrevlist.el, assoc.el, complete.el, cust-print.el,
-erc-hecomplete.el, mailpost.el, mouse-sel.el, old-emacs-lock.el,
-patcomp.el, pc-mode.el, pc-select.el, s-region.el, and sregex.el.
-
-** Many seldom-used generalized variables have been made obsolete.
-Emacs has a number of rather obscure generalized variables defined,
-that, for instance, allowed you to say things like:
-
- (setf (point-min) 4)
-
-These never caught on and have been made obsolete. The form above,
-for instance, is the same as saying
-
- (narrow-to-region 4 (point-max))
-
-The following generalized variables have been made obsolete:
-'buffer-file-name', 'buffer-local-value', 'buffer-modified-p',
-'buffer-name', 'buffer-string', 'buffer-substring', 'current-buffer',
-'current-column', 'current-global-map', 'current-input-mode',
-'current-local-map', 'current-window-configuration',
-'default-file-modes', 'documentation-property', 'eq', 'frame-height',
-'frame-width', 'frame-visible-p', 'global-key-binding',
-'local-key-binding', 'mark', 'mark-marker', 'marker-position',
-'mouse-position', 'point', 'point-marker', 'point-max', 'point-min',
-'read-mouse-position', 'screen-height', 'screen-width',
-'selected-frame', 'selected-screen', 'selected-window',
-'standard-case-table', 'syntax-table', 'visited-file-modtime',
-'window-height', 'window-width', and 'x-get-secondary-selection'.
-
-** The 'dotimes' loop variable can no longer be manipulated in the loop body.
-Previously, the 'dotimes' loop counter could be modified inside the
-loop body, but only in code using dynamic binding. Now the behavior
-is the same as when using lexical binding: changes to the loop
-variable have no effect on subsequent iterations. That is,
-
- (dotimes (i 10)
- (print i)
- (setq i (+ i 6)))
-
-now always prints the numbers 0 .. 9.
+* Incompatible Lisp Changes in Emacs 30.1
+
+---
+** Old derived.el functions removed.
+The following functions have been deleted because they were only used
+by code compiled with Emacs<21:
+'derived-mode-init-mode-variables', 'derived-mode-merge-abbrev-tables',
+'derived-mode-merge-keymaps', 'derived-mode-merge-syntax-tables',
+'derived-mode-run-hooks', 'derived-mode-set-abbrev-table',
+'derived-mode-set-keymap', 'derived-mode-set-syntax-table',
+'derived-mode-setup-function-name'.
+
++++
+** 'M-TAB' now invokes 'completion-at-point' also in Text mode.
+By default, Text mode no longer binds 'M-TAB' to
+'ispell-complete-word'. Instead, this mode arranges for
+'completion-at-point', globally bound to 'M-TAB', to perform word
+completion as well. You can have Text mode bind 'M-TAB' to
+'ispell-complete-word' as it did in previous Emacs versions, or
+disable Ispell word completion in Text mode altogether, by customizing
+the new user option 'text-mode-ispell-word-completion'.
+
+** 'pp' and 'pp-to-string' now always include a terminating newline.
+In the past they included a terminating newline in most cases but not all.
+
+** 'buffer-match-p' and 'match-buffers' take '&rest args'.
+They used to take a single '&optional arg' and were documented to use
+an unreliable hack to try and support condition predicates that
+don't accept this optional arg.
+The new semantics makes no such accommodation, but the code still
+supports it (with a warning) for backward compatibility.
+
+** 'post-gc-hook' runs after updating 'gcs-done' and 'gcs-elapsed'.
+
+---
+** The escape sequence '\x' not followed by hex digits is now an error.
+Previously, '\x' without at least one hex digit denoted character code
+zero (NUL) but as this was neither intended nor documented or even
+known by anyone, it is now treated as an error by the Lisp reader.
+
+---
+** Connection-local variables are applied in buffers visiting a remote file.
+This overrides possible directory-local or file-local variables with
+the same name.
+
+---
+** User option 'tramp-completion-reread-directory-timeout' has been removed.
+This user option has been obsoleted in Emacs 27, use
+'remote-file-name-inhibit-cache' instead.
+
+---
+** User options 'eshell-NAME-unload-hook' are now obsolete.
+These hooks were named incorrectly, and so they never actually ran
+when unloading the corresponding feature. Instead, you should use
+hooks named after the feature name, like 'esh-mode-unload-hook'.
+
++++
+** 'copy-tree' now copies records when its optional 2nd argument is non-nil.
+
++++
+** Regexp zero-width assertions followed by operators are better defined.
+Previously, regexps such as "xy\\B*" would have ill-defined behavior.
+Now any operator following a zero-width assertion applies to that
+assertion only (which is useless). For historical compatibility, an
+operator character following '^' or '\`' becomes literal, but we
+advise against relying on this.
+
+---
+** Mode-line mnemonics for some coding-systems have changed.
+The mode-line mnemonic for 'utf-7' is now the lowercase 'u', to be
+consistent with the other encodings of this family.
+
+The mode-line mnemonic for 'koi8-u' is now 'У', U+0423 CYRILLIC
+CAPITAL LETTER U, to distinguish between this encoding and the
+UTF-8/UTF-16 family.
+
+If your terminal cannot display 'У', or if you want to get the old
+behavior back for any other reason, you can do that using the
+'coding-system-put' function. For example, the following restores the
+previous behavior of showing 'U' in the mode line for 'koi8-u':
+
+ (coding-system-put 'koi8-u :mnemonic ?U)
+
+---
+** 'vietnamese-tcvn' is now a coding system alias for 'vietnamese-vscii'.
+VSCII-1 and TCVN-5712 are different names for the same character
+encoding. Therefore, the duplicate coding system definition has been
+dropped in favor of an alias.
+
+The mode-line mnemonic for 'vietnamese-vscii' and its aliases is the
+lowercase letter 'v'.
+
++++
+** Infinities and NaNs no longer act as symbols on non-IEEE platforms.
+On old platforms like the VAX that do not support IEEE floating-point,
+tokens like 0.0e+NaN and 1.0e+INF are no longer read as symbols.
+Instead, the Lisp reader approximates an infinity with the nearest
+finite value, and a NaN with some other non-numeric object that
+provokes an error if used numerically.
+
++++
+** X color support compatibility aliases are now marked obsolete.
+The compatibility aliases 'x-defined-colors', 'x-color-defined-p',
+'x-color-values', and 'x-display-color-p' are now obsolete.
+
++++
+** 'easy-mmode-define-{minor,global}-mode' aliases are now obsolete.
+Use 'define-minor-mode' and 'define-globalized-minor-mode' instead.
+
+** The obsolete calling convention of 'sit-for' has been removed.
+That convention was: '(sit-for SECONDS MILLISEC &optional NODISP)'.
+
+** The 'millisec' argument of 'sleep-for' has been declared obsolete.
+Use a float value for the first argument instead.
+
+** 'eshell-process-wait-{seconds,milliseconds}' options are now obsolete.
+Instead, use 'eshell-process-wait-time', which supports floating-point
+values.
-* Lisp Changes in Emacs 29.1
-
-** Interpreted closures are "safe for space".
-As was already the case for byte-compiled closures, instead of capturing
-the whole current lexical environment, interpreted closures now only
-capture the part of the environment that they need.
-The previous behavior could occasionally lead to memory leaks or
-to problems where a printed closure would not be 'read'able because
-of an un'read'able value in an unrelated lexical variable.
-
-** New accessor function 'file-attribute-file-identifier'.
-It returns the list of the inode number and device identifier
-retrieved by 'file-attributes'. This value can be used to identify a
-file uniquely. The device identifier can be a single number or (for
-remote files) a cons of 2 numbers.
-
-** New macro 'while-let'.
-This is like 'when-let', but repeats until a binding form is nil.
-
-** New function 'make-obsolete-generalized-variable'.
-This can be used to mark setters used by 'setf' as obsolete, and the
-byte-compiler will then warn about using them.
-
-** New functions 'pos-eol' and 'pos-bol'.
-These are like 'line-end-position' and 'line-beginning-position'
-(respectively), but ignore fields (and are more efficient).
-
-** New function 'compiled-function-p'.
-This returns non-nil if its argument is either a built-in, or a
-byte-compiled, or a natively-compiled function object, or a function
-loaded from a dynamic module.
-
-** 'deactivate-mark' can have new value 'dont-save'.
-This value means that Emacs should deactivate the mark as usual, but
-without setting the primary selection, if 'select-active-regions' is
-enabled.
-
-** New 'declare' form 'interactive-args'.
-This can be used to specify what forms to put into 'command-history'
-when executing commands interactively.
-
-** The FORM argument of 'time-convert' is mandatory.
-'time-convert' can still be called without it, as before, but the
-compiler now emits a warning about this deprecated usage.
-
-** Emacs now supports user-customizable and themable icons.
-These can be used for buttons in buffers and the like. See the
-"(elisp) Icons" and "(emacs) Icons" nodes in the manuals for details.
-
-** New arguments MESSAGE and TIMEOUT of 'set-transient-map'.
-MESSAGE specifies a message to display after activating the transient
-map, including a special formatting spec to list available keys.
-TIMEOUT is the idle time after which to deactivate the transient map.
-The default timeout value can be defined by the new variable
-'set-transient-map-timeout'.
-
-** New forms 'with-restriction' and 'without-restriction'.
-These forms can be used as enhanced alternatives to the
-'save-restriction' form combined with, respectively,
-'narrow-to-region' and 'widen'. They also accept an optional label
-argument, with which labeled narrowings can be created and lifted.
-See the "(elisp) Narrowing" node for details.
-
-** Connection Local Variables
-
-*** 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.
-
-*** New function 'connection-local-update-profile-variables'.
-This function allows to modify the settings of an existing
-connection-local profile.
-
-*** New macro 'with-connection-local-application-variables'.
-This macro works like 'with-connection-local-variables', but it allows
-using another application instead of 'tramp'. This is useful when
-running code in a buffer where Tramp has already set some
-connection-local variables.
-
-*** New macro 'setq-connection-local'.
-This allows dynamically setting variable values for a particular
-connection within the body of 'with-connection-local-{application-}variables'.
-See the "(elisp) Connection Local Variables" node in the Lisp
-Reference manual for more information.
-
-** 'plist-get', 'plist-put' and 'plist-member' are no longer limited to 'eq'.
-These function now take an optional comparison PREDICATE argument.
-
-** 'read-multiple-choice' can now use long-form answers.
-
-** 'M-s c' in 'read-regexp' now toggles case folding.
-
-** 'completing-read' now allows a function as its REQUIRE-MATCH argument.
-This function is called to see whether what the user has typed is a
-match. This is also available from functions that call
-'completing-read', like 'read-file-name'.
-
-** 'posn-col-row' can now give position data based on windows.
-Previously, it reported data only based on the frame.
-
-** 'file-expand-wildcards' can now also take a regexp as PATTERN argument.
-
-** vc-mtn (the VC backend for Monotone) has been made obsolete.
-
-** 'gui-set-selection' can specify different values for different data types.
-If DATA is a string, then its text properties are searched for values
-for each specific data type while the selection is being converted.
-
-** New eldoc function 'elisp-eldoc-var-docstring-with-value'.
-This function includes the current value of the variable in eldoc display
-and can be used as a more detailed alternative to 'elisp-eldoc-var-docstring'.
-
-** 'save-some-buffers' can now be extended to save other things.
-Traditionally, 'save-some-buffers' saved buffers, and also saved
-abbrevs. This has been generalized via the
-'save-some-buffers-functions' variable, and packages can now register
-things to be saved.
-
-** New function 'string-equal-ignore-case'.
-This compares strings ignoring case differences.
-
-** 'symbol-file' can now report natively-compiled ".eln" files.
-If Emacs was built with native-compilation enabled, Lisp programs can
-now call 'symbol-file' with the new optional 3rd argument non-nil to
-request the name of the ".eln" file which defined a given symbol.
-
-** New macro 'with-memoization' provides a very primitive form of memoization.
-
-** 'max-char' can now report the maximum codepoint according to Unicode.
-When called with a new optional argument UNICODE non-nil, 'max-char'
-will now report the maximum valid codepoint defined by the Unicode
-Standard.
-
-** Seq
-
-*** New function 'seq-split'.
-This returns a list of sub-sequences of the specified sequence.
-
-*** New function 'seq-remove-at-position'.
-This function returns a copy of the specified sequence with the
-element at a given (zero-based) index removed.
-
-*** New function 'seq-positions'.
-This returns a list of the (zero-based) indices of elements matching a
-given predicate in the specified sequence.
-
-*** New function 'seq-keep'.
-This is like 'seq-map', but removes all nil results from the returned
-list.
+* Lisp Changes in Emacs 30.1
+
+** New function 'help-fns-function-name'.
+For named functions, it just returns the name and otherwise
+it returns a short "unique" string that identifies the function.
+In either case, the string is propertized so clicking on it gives
+further details.
+
+** New function 'cl-type-of'.
+This function is like 'type-of' except that it sometimes returns
+a more precise type. For example, for nil and t it returns 'null'
+and 'boolean' respectively, instead of just 'symbol'.
+
+** New functions `primitive-function-p` and `cl-functionp`.
+`primitive-function-p` is like `subr-primitive-p` except that it returns
+t only if the argument is a function rather than a special-form,
+and `cl-functionp` is like `functionp` except it return nil
+for lists and symbols.
+
+** Built-in types have now corresponding classes.
+At the Lisp level, this means that things like (cl-find-class 'integer)
+will now return a class object, and at the UI level it means that
+things like 'C-h o integer RET' will show some information about that type.
+
+** New var 'major-mode-remap-defaults' and function 'major-mode-remap'.
+The first is like Emacs-29's 'major-mode-remap-alist' but to be set by
+packages (instead of users). The second looks up those two variables.
+
++++
+** Pcase's functions (in 'pred' and 'app') can specify the argument position.
+For example, instead of '(pred (< 5))' you can write '(pred (> _ 5))'.
+
++++
+** 'define-advice' now sets the new advice's 'name' property to NAME.
+Named advices defined with 'define-advice' can now be removed with
+'(advice-remove SYMBOL NAME)' in addition to '(advice-remove SYMBOL
+SYMBOL@NAME)'.
+
++++
+** New function 'require-with-check' to detect new versions shadowing.
+This is like 'require', but it checks whether the argument 'feature'
+is already loaded, in which case it either signals an error or
+forcibly reloads the file that defines the feature.
+
++++
+** New variable 'lisp-eval-depth-reserve'.
+It puts a limit to the amount by which Emacs can temporarily increase
+'max-lisp-eval-depth' when handling signals.
+
++++
+** New special form 'handler-bind'.
+It provides a functionality similar to 'condition-case' except it runs
+the handler code without unwinding the stack, such that we can record
+the backtrace and other dynamic state at the point of the error. See
+the Info node "(elisp) Handling Errors".
+
++++
+** New 'pop-up-frames' action alist entry for 'display-buffer'.
+This has the same effect as the variable of the same name and takes
+precedence over the variable when present.
+
+** New function 'merge-ordered-lists'.
+Mostly used internally to do a kind of topological sort of
+inheritance hierarchies.
+
++++
+** New polymorphic comparison function 'value<'.
+This function returns non-nil if the first argument is less than the
+second. It works for any two values of the same type with reasonable
+ordering for numbers, strings, symbols, bool-vectors, markers, buffers
+and processes. Conses, lists, vectors and records are ordered
+lexicographically.
+It is intended as a convenient ordering predicate for sorting, and is
+likely to be faster than hand-written Lisp functions.
+
++++
+** New 'sort' arguments and features.
+The 'sort' function can now be called using the signature
+
+ (sort SEQ &rest KEYWORD-ARGUMENTS)
+
+where arguments after the first are keyword/value pairs, all optional:
+':key' specifies a function that produces the sorting key from an element,
+':lessp' specifies the ordering predicate, defaulting to 'value<',
+':reverse' is used to reverse the sorting order,
+':in-place is used for in-place sorting, as the default is now to
+sort a copy of the input.
+
+The new signature is less error-prone and reduces the need to write
+ordering predicates by hand. We recommend that you use the ':key'
+argument instead of ':lessp' unless a suitable ordering predicate is
+already available. This can also be used for multi-key sorting:
+
+ (sort seq :key (lambda (x) (list (age x) (size x) (cost x))))
+
+sorts by the return value of 'age', then by 'size', then by 'cost'.
+
+The old signature, '(sort SEQ PREDICATE)', can still be used and sorts
+its input in-place as before.
+
+** New API for 'derived-mode-p' and control of the graph of major modes.
+
+*** 'derived-mode-p' now takes the list of modes as a single argument.
+The same holds for 'provided-mode-derived-p'.
+The old calling convention where multiple modes are passed as
+separate arguments is deprecated.
+
+*** New functions to access the graph of major modes.
+While 'define-derived-mode' still only supports single inheritance,
+modes can declare additional parents (for tests like 'derived-mode-p')
+with 'derived-mode-add-parents'.
+Accessing the 'derived-mode-parent' property directly is now
+deprecated in favor of the new functions 'derived-mode-set-parent'
+and 'derived-mode-all-parents'.
+
++++
+** Drag-and-drop functions can now be called once for compound drops.
+It is now possible for drag-and-drop handler functions to respond to
+drops incorporating more than one URL. Functions capable of this must
+set their 'dnd-multiple-handler' symbol properties to a non-nil value.
+See the Info node "(elisp) Drag and Drop".
+
+Incident to this change, the function 'dnd-handle-one-url' has been
+made obsolete, for it cannot take these new handlers into account.
+
+** New function 're-disassemble' to see the innards of a regexp.
+If you compiled with '--enable-checking', you can use this to help debug
+either your regexp performance problems or the regexp engine.
+
++++
+** XLFDs are no longer restricted to 255 characters.
+'font-xlfd-name' now returns an XLFD even if it is greater than 255
+characters in length, provided that the LONG_XLFDs argument is true.
+
+Other features in Emacs which employ XLFDs have been modified to
+produce and understand XLFDs larger than 255 characters.
+
+** 'defadvice' is marked as obsolete.
+See the "(elisp) Porting Old Advice" Info node for help converting
+them to use 'advice-add' or 'define-advice' instead.
+
+** 'cl-old-struct-compat-mode' is marked as obsolete.
+You may need to recompile our code if it was compiled with Emacs < 24.3.
+
++++
+** New macro 'static-if' for conditional evaluation of code.
+This macro hides a form from the evaluator or byte-compiler based on a
+compile-time condition. This is handy for avoiding byte-compilation
+warnings about code that will never actually run under some
+conditions.
+
++++
+** Desktop notifications are now supported on the Haiku operating system.
+The new function 'haiku-notifications-notify' provides a subset of the
+capabilities of the 'notifications-notify' function in a manner
+analogous to 'w32-notification-notify'.
+
++++
+** New value 'if-regular' for the REPLACE argument to 'insert-file-contents'.
+It results in 'insert-file-contents' erasing the buffer instead of
+preserving markers if the file being inserted is not a regular file,
+rather than signaling an error.
+
++++
+** New variable 'current-key-remap-sequence'.
+It is bound to the key sequence that caused a call to a function bound
+within 'function-key-map' or 'input-decode-map' around those calls.
+
++++
+** New variables describing the names of built in programs.
+The new variables 'ctags-program-name', 'ebrowse-program-name',
+'etags-program-name', 'hexl-program-name', 'emacsclient-program-name'
+'movemail-program-name', and 'rcs2log-program-name' should be used
+instead of "ctags", "ebrowse", "etags", "hexl", "emacsclient", and
+"rcs2log", when starting one of these built in programs in a
+subprocess.
+
++++
+** New variable 'case-symbols-as-words' affects case operations for symbols.
+If non-nil, then case operations such as 'upcase-initials' or
+'replace-match' (with nil FIXEDCASE) will treat the entire symbol name
+as a single word. This is useful for programming languages and styles
+where only the first letter of a symbol's name is ever capitalized.
+The default value of this variable is nil.
+
++++
+** 'x-popup-menu' now understands touch screen events.
+When a 'touchscreen-begin' or 'touchscreen-end' event is passed as the
+POSITION argument, it will behave as if that event was a mouse event.
+
++++
+** New functions for handling touch screen events.
+The new functions 'touch-screen-track-tap' and
+'touch-screen-track-drag' handle tracking common touch screen gestures
+from within a command.
+
+** New user option 'safe-local-variable-directories'.
+This user option names directories in which Emacs will treat all
+directory-local variables as safe.
+
++++
+** New parameter to 'touchscreen-end' events.
+CANCEL non-nil establishes that the touch sequence has been
+intercepted by programs such as window managers and should be ignored
+with Emacs.
+
+** New variable 'inhibit-auto-fill' to temporarily prevent auto-fill.
+
++++
+** New variable 'secondary-tool-bar-map'.
+If non-nil, this variable contains a keymap of menu items that are
+displayed along tool bar items inside 'tool-bar-map'.
+
+** New variable 'completion-lazy-hilit'.
+Lisp programs that present completion candidates may bind this
+variable non-nil around calls to functions such as
+'completion-all-completions'. This tells the underlying completion
+styles to skip eager fontification of completion candidates, which
+improves performance. Such a Lisp program can then use the
+'completion-lazy-hilit' function to fontify candidates just in time.
+
+** New primitive 'buffer-last-name'.
+It returns the name of a buffer before the last time it was renamed or
+killed.
+
+** New primitive 'marker-last-position'.
+It returns the last position of a marker in its buffer even if that
+buffer has been killed. ('marker-position' would return nil in that
+case.)
+
+
+** Functions and variables to transpose sexps
+
++++
+*** New helper variable 'transpose-sexps-function'.
+Emacs now can set this variable to customize the behavior of the
+'transpose-sexps' function.
+
++++
+*** New function 'transpose-sexps-default-function'.
+The previous implementation is moved into its own function, to be
+bound by 'transpose-sexps-function'.
+
+*** New function 'treesit-transpose-sexps'.
+Tree-sitter now unconditionally sets 'transpose-sexps-function' for all
+tree-sitter enabled modes. This functionality utilizes the new
+'transpose-sexps-function'.
+
+** Functions and variables to move by program statements
+
+*** New variable 'forward-sentence-function'.
+Major modes can now set this variable to customize the behavior of the
+'forward-sentence' command.
+
+*** New function 'forward-sentence-default-function'.
+The previous implementation of 'forward-sentence' is moved into its
+own function, to be bound by 'forward-sentence-function'.
+
+*** New function 'treesit-forward-sentence'.
+All tree-sitter enabled modes that define 'sentence' in
+'treesit-thing-settings' now set 'forward-sentence-function' to call
+'treesit-forward-sentence'.
+
+** Functions and variables to move by program sexps
+
+*** New function 'treesit-forward-sexp'.
+Tree-sitter conditionally sets 'forward-sexp-function' for major modes
+that have defined 'sexp' in 'treesit-thing-settings' to enable
+sexp-related motion commands.
+
++++
+** Returned strings are never docstrings.
+Functions and macros whose bodies consist of a single string literal now
+only return that string; it is not used as a docstring. Example:
+
+ (defun sing-a-song ()
+ "Sing a song.")
-** Themes
+The above function returns the string '"Sing a song."' but has no
+docstring. Previously, that string was used as both a docstring and
+return value, which was never what the programmer wanted. If you want
+the string to be a docstring, add an explicit return value.
-*** New hooks 'enable-theme-functions' and 'disable-theme-functions'.
-These are run after enabling and disabling a theme, respectively.
+This change applies to 'defun', 'defsubst', 'defmacro' and 'lambda'
+forms; other defining forms such as 'cl-defun' already worked this way.
-*** Themes can now be made obsolete.
-Using 'make-obsolete' on a theme is now supported. This will make
-'load-theme' issue a warning when loading the theme.
+** New or changed byte-compilation warnings
-** New hook 'display-monitors-changed-functions'.
-It is called whenever the configuration of different monitors on a
-display changes.
+---
+*** Warn about missing 'lexical-binding' directive.
+The compiler now warns if an Elisp file lacks the standard
+'-*- lexical-binding: ... -*-' cookie on the first line.
+This line typically looks something like
-** 'prin1' and 'prin1-to-string' now take an optional OVERRIDES argument.
-This argument can be used to override values of print-related settings.
+ ;;; My little pony mode -*- lexical-binding: t -*-
-** New minor mode 'header-line-indent-mode'.
-This is meant to be used by Lisp programs that show a header line
-which should be kept aligned with the buffer contents when the user
-switches 'display-line-numbers-mode' on or off, and when the width of
-line-number display changes. See the "(elisp) Header Lines" node in
-the Emacs Lisp Reference manual for more information.
+It is needed to inform the compiler about which dialect of ELisp
+your code is using: the modern dialect with lexical binding or
+the old dialect with only dynamic binding.
-** New global minor mode 'lost-selection-mode'.
-This global minor mode makes Emacs deactivate the mark in all buffers
-when the primary selection is obtained by another program.
+Lexical binding avoids some name conflicts and allows the compiler to
+detect more mistakes and generate more efficient code, so it is
+recommended. For how to adapt your code to lexical binding, see the
+manual section "(elisp) Converting to Lexical Binding".
-** On X, Emacs will try to preserve selection ownership when a frame is deleted.
-This means that if you make Emacs the owner of a selection, such as by
-selecting some text into the clipboard or primary selection, and then
-delete the current frame, you will still be able to insert the
-contents of that selection into other programs as long as another
-frame is open on the same display. This behavior can be disabled by
-setting the user option 'x-auto-preserve-selections' to nil.
+If your code cannot be converted to lexical binding, you can insert
+the line
-** New predicate 'char-uppercase-p'.
-This returns non-nil if its argument its an uppercase character.
+ ;;; -*- lexical-binding: nil -*-
-** Byte Compilation
+first in the file to declare that it uses the old dialect.
-*** Byte compilation will now warn about some quoting mistakes in docstrings.
-When writing code snippets that contains the "'" character (APOSTROPHE),
-that quote character has to be escaped to avoid Emacs displaying it as
-"’" (LEFT SINGLE QUOTATION MARK), which would make code examples like
+---
+*** Warn about empty bodies for more special forms and macros.
+The compiler now warns about an empty body argument to 'when',
+'unless', 'ignore-error' and 'with-suppressed-warnings' in addition to
+the existing warnings for 'let' and 'let*'. Example:
- (setq foo '(1 2 3))
+ (when (> x 2))
-invalid. Emacs will now warn during byte compilation if it sees
-something like that, and also warn about when using RIGHT/LEFT SINGLE
-QUOTATION MARK directly. In both these cases, if these characters
-should really be present in the docstring, they should be quoted with
-"\=".
+This warning can be suppressed using 'with-suppressed-warnings' with
+the warning name 'empty-body'.
-*** Byte compilation will now warn about some malformed 'defcustom' types.
-It is very common to write 'defcustom' types on the form:
+---
+*** Warn about quoted error names in 'condition-case' and 'ignore-error'.
+The compiler now warns about quoted condition (error) names
+in 'condition-case' and 'ignore-error'. Example:
- :type '(choice (const :tag "foo" 'bar))
+ (condition-case nil
+ (/ x y)
+ ('arith-error "division by zero"))
-I.e., double-quoting the 'bar', which is almost never the correct
-value. The byte compiler will now issue a warning if it encounters
-these forms.
+Quoting them adds the error name 'quote' to those handled or ignored
+respectively, which was probably not intended.
-** 'restore-buffer-modified-p' can now alter buffer auto-save state.
-With a FLAG value of 'autosaved', it will mark the buffer as having
-been auto-saved since the time of last modification.
+---
+*** Warn about comparison with literal constants without defined identity.
+The compiler now warns about comparisons by identity with a literal
+string, cons, vector, record, function, large integer or float as this
+may not match any value at all. Example:
-** 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.
+ (eq x "hello")
-** 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.
+Only literals for symbols and small integers (fixnums), including
+characters, are guaranteed to have a consistent (unique) identity.
+This warning applies to 'eq', 'eql', 'memq', 'memql', 'assq', 'rassq',
+'remq' and 'delq'.
-** 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.
+To compare by (structural) value, use 'equal', 'member', 'assoc',
+'rassoc', 'remove' or 'delete' instead. Floats and bignums can also
+be compared using 'eql', '=' and 'memql'. Function literals cannot be
+compared reliably at all.
-** 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 variable 'x-show-tooltip-timeout' allows the user to alter
-this for packages that don't use 'tooltip-show', but instead call the
-lower level function directly.
-
-** 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 up a new buffer where you can edit the string,
-and the provided callback is called when the user types 'C-c C-c'.
+This warning can be suppressed using 'with-suppressed-warnings' with
+the warning name 'suspicious'.
-** 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 variables 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 display of lines that don't end in a newline 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 argument 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.
-
-** Variable 'track-mouse' can have 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 functions for dragging items from Emacs to other programs.
-The new functions 'x-begin-drag', 'dnd-begin-file-drag',
-'dnd-begin-drag-files', and 'dnd-direct-save' allow dragging contents
-(such as files and text) from Emacs to other programs.
-
-** New function 'ietf-drums-parse-date-string'.
-This function parses RFC5322 (and RFC822) date strings, and should be
-used instead of 'parse-time-string' when parsing data that's standards
-compliant.
-
-** New macro 'setopt'.
-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'.
-This is meant to be used from ':eval' mode line constructs to create
-different mode line looks for selected and unselected windows.
-
-** New variable 'messages-buffer-name'.
-This variable (defaulting to "*Messages*") allows packages to override
-where messages are logged.
-
-** New function 'readablep'.
-This function says whether an object can be written out and then
-read back by the Emacs Lisp reader.
-
-** New variable 'print-unreadable-function'.
-This variable allows changing how Emacs prints unreadable objects.
-
-** The user option 'polling-period' now accepts floating point values.
-This means Emacs can now poll for input during Lisp execution more
-frequently than once in a second.
-
-** New function 'bidi-string-strip-control-characters'.
-This utility function is meant for displaying strings when it is
-essential that there's no bidirectional context. It removes all the
-bidirectional formatting control characters (such as RLM, LRO, PDF,
-etc.) from its argument string. The characters it removes are listed
-in the value of 'bidi-control-characters'.
-
-** The Gnus range functions have been moved to a new library, range.el.
-All the old names have been made obsolete.
-
-** New function 'function-alias-p'.
-This predicate says whether an object is a function alias, and if it
-is, the alias chain is returned.
-
-** New variable 'lisp-directory' holds the directory of Emacs's own Lisp files.
-
-** New facility for handling session state: 'multisession-value'.
-This can be used as a convenient way to store (simple) application
-state, and the command 'list-multisession-values' allows users to list
-(and edit) this data.
+---
+*** Warn about 'condition-case' without handlers.
+The compiler now warns when the 'condition-case' form is used without
+any actual handlers, as in
-** New function 'get-display-property'.
-This is like 'get-text-property', but works on the 'display' text
-property.
+ (condition-case nil (read buffer))
-** New function 'add-display-text-property'.
-This is like 'put-text-property', but works on the 'display' text
-property.
+because it has no effect other than the execution of the body form.
+In particular, no errors are caught or suppressed. If the intention
+was to catch all errors, add an explicit handler for 'error', or use
+'ignore-error' or 'ignore-errors'.
-** New 'min-width' 'display' property.
-This allows setting a minimum display width for a region of text.
+This warning can be suppressed using 'with-suppressed-warnings' with
+the warning name 'suspicious'.
-** 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.
+---
+*** Warn about 'unwind-protect' without unwind forms.
+The compiler now warns when the 'unwind-protect' form is used without
+any unwind forms, as in
-** New event type 'touch-end'.
-This event is sent whenever the user's finger moves off the mouse
-wheel on some mice, or when the user's finger moves off the touchpad.
+ (unwind-protect (read buffer))
-** New event type 'pinch'.
-This event is sent when a user performs a pinch gesture on a touchpad,
-which is comprised of placing two fingers on the touchpad and moving
-them towards or away from each other.
+because the behavior is identical to that of the argument; there is
+no protection of any kind. Perhaps the intended unwind forms have
+been misplaced or forgotten, or the use of 'unwind-protect' could be
+simplified away.
-** New hook 'x-pre-popup-menu-hook'.
-This hook is run before 'x-popup-menu' is about to display a
-deck-of-cards menu on screen.
+This warning can be suppressed using 'with-suppressed-warnings' with
+the warning name 'suspicious'.
-** New hook 'post-select-region-hook'.
-This hook is run immediately after 'select-active-regions'. It causes
-the region to be set as the primary selection.
+---
+*** Warn about useless trailing 'cond' clauses.
+The compiler now warns when a 'cond' form contains clauses following a
+default (unconditional) clause. Example:
-** 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 combination with a condition
-like '(and "\\`\\*.+\\*\\'" (major-mode . special-mode))'.
+ (cond ((= x 0) (say "none"))
+ (t (say "some"))
+ (say "goodbye"))
-** New function 'match-buffers'.
-It uses 'buffer-match-p' to gather a list of buffers that match a
-condition.
+Such a clause will never be executed but is likely to be a mistake,
+perhaps due to misplaced brackets.
-** New optional arguments TEXT-FACE and DEFAULT-FACE for 'tooltip-show'.
-They allow changing the faces used for the tooltip text and frame
-colors of the resulting tooltip frame from the default 'tooltip' face.
+This warning can be suppressed using 'with-suppressed-warnings' with
+the warning name 'suspicious'.
-** Text Security and Suspiciousness
+---
+*** Warn about mutation of constant values.
+The compiler now warns about code that modifies program constants in
+some obvious cases. Examples:
-*** New library textsec.el.
-This library contains a number of checks for whether a string is
-"suspicious". This usually means that the string contains characters
-that have glyphs that can be confused with other, more commonly used
-glyphs, or contains bidirectional (or other) formatting characters
-that may be used to confuse a user.
+ (setcar '(1 2) 7)
+ (aset [3 4] 0 8)
+ (aset "abc" 1 ?d)
-*** New user option 'textsec-check'.
-If non-nil (which is the default), Emacs packages that are vulnerable
-to attackers trying to confuse the users will use the textsec library
-to mark suspicious text. For instance shr/eww will mark suspicious
-URLs and links, Gnus will mark suspicious From addresses, and
-Message mode will query the user if the user is sending mail to a
-suspicious address. If this variable is nil, these checks are
-disabled.
+Such code may have unpredictable behavior because the constants are
+part of the program, not data structures generated afresh during
+execution, and the compiler does not expect them to change.
-*** New function 'textsec-suspicious-p'.
-This is the main function Emacs applications should be using to check
-whether a string is suspicious. It heeds the 'textsec-check' user
-option.
-
-** Keymaps and Key Definitions
-
-*** 'where-is-internal' can now filter events marked as non key events.
-If a command maps to a key binding like '[some-event]', and 'some-event'
-has a symbol plist containing a non-nil 'non-key-event' property, then
-that binding is ignored by 'where-is-internal'.
-
-*** New functions for defining and manipulating keystrokes.
-These all take the syntax defined by 'key-valid-p', which is basically
-the same syntax as the one accepted by the 'kbd' macro. None of the
-older functions have been deprecated or altered, but they are now
-de-emphasized in the documentation, and we encourage Lisp programs to
-switch to these new functions.
-
-*** Use 'keymap-set' instead of 'define-key'.
-
-*** Use 'keymap-global-set' instead of 'global-set-key'.
-
-*** Use 'keymap-local-set' instead of 'local-set-key'.
-
-*** Use 'keymap-global-unset' instead of 'global-unset-key'.
-
-*** Use 'keymap-local-unset' instead of 'local-unset-key'.
-
-*** Use 'keymap-substitute' instead of 'substitute-key-definition'.
-
-*** Use 'keymap-set-after' instead of 'define-key-after'.
-
-*** Use 'keymap-lookup' instead of 'lookup-key' and 'key-binding'.
-
-*** Use 'keymap-local-lookup' instead of 'local-key-binding'.
-
-*** Use 'keymap-global-lookup' instead of 'global-key-binding'.
-
-*** 'define-key' now takes an optional REMOVE argument.
-If non-nil, remove the definition from the keymap. This is subtly
-different from setting a definition to nil: when the keymap has a
-parent such a definition will shadow the parent's definition.
-
-*** 'read-multiple-choice' now takes an optional SHOW-HELP argument.
-If non-nil, show the help buffer immediately, before any user input.
-
-*** New function 'key-valid-p'.
-The 'kbd' function is quite permissive, and will try to return
-something usable even if the syntax of the argument isn't completely
-correct. The 'key-valid-p' predicate does a stricter check of the
-syntax.
-
-*** New function 'key-parse'.
-This is like 'kbd', but only returns vectors instead of a mix of
-vectors and strings.
-
-*** New ':type' for 'defcustom' for keys.
-The new 'key' type can be used for options that should be a valid key
-according to 'key-valid-p'. The type 'key-sequence' is now obsolete.
-
-** New function 'define-keymap'.
-This function allows defining a number of keystrokes with one form.
-
-** New macro 'defvar-keymap'.
-This macro allows defining keymap variables more conveniently.
-
-** 'defvar-keymap' can specify 'repeat-mode' behavior for the keymap.
-Use ':repeat t' to have all bindings be repeatable or for more
-advanced usage:
-
- :repeat (:enter (commands ...) :exit (commands ...))
-
-** 'kbd' can now be used in built-in, preloaded libraries.
-It no longer depends on edmacro.el and cl-lib.el.
-
-** New substitution in docstrings and 'substitute-command-keys'.
-Use \\`KEYSEQ' to insert a literal key sequence "KEYSEQ" (for example
-\\`C-k') in a docstring or when calling 'substitute-command-keys',
-which will use the same face as a command substitution. This should
-be used only when a key sequence has no corresponding command, for
-example when it is read directly with 'read-key-sequence'. It must be
-a valid key sequence according to 'key-valid-p'.
-
-** 'lookup-key' is more permissive when searching for extended menu items.
-In Emacs 28.1, the behavior of 'lookup-key' was changed: 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]'.
-
-This has been extended, so that when looking for a menu item with a
-symbol containing spaces, as in '[menu-bar Foo\ Bar]', first look for
-an exact match, then the lowercased '[menu-bar foo\ bar]' and finally
-'[menu-bar foo-bar]'. This further improves backwards-compatibility
-when converting menus to use 'easy-menu-define'.
-
-** New function 'file-name-split'.
-This returns a list of all the components of a file name.
-
-** New function 'file-name-parent-directory'.
-This returns the parent directory of a file name.
-
-** New macro 'with-undo-amalgamate'.
-It records a particular sequence of operations as a single undo step.
-
-** New command 'yank-media'.
-This command supports yanking non-plain-text media like images and
-HTML from other applications into Emacs. It is only supported in
-modes that have registered support for it, and only on capable
-platforms.
-
-** New command 'yank-media-types'.
-This command lets you examine all data in the current selection and
-the clipboard, and insert it into the buffer.
-
-** New variable 'yank-transform-functions'.
-This variable allows the user to alter the string to be inserted.
-
-** New command 'yank-in-context'.
-This command tries to preserve string/comment syntax when yanking.
-
-** 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
-instance) when covering huge amounts of data (that has no meaningful
-searchable data, like image data) with a 'display' text property.
+To avoid the warning, operate on an object created by the program
+(maybe a copy of the constant), or use a non-destructive operation
+instead.
-** 'insert-image' now takes an INHIBIT-ISEARCH optional argument.
-It marks the image with the 'inhibit-isearch' text property, which
-inhibits 'isearch' matching the STRING argument.
-
-** 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.
-The new variable 'query-replace-read-from-default' can be set to a
-function that returns the default value of FROM when 'query-replace'
-prompts for a string to be replaced. An example of such a function is
-'find-tag-default'.
-
-The new variable 'query-replace-read-from-regexp-default' can be set
-to a function (such as 'find-tag-default-as-regexp') that returns the
-default value of FROM when 'query-replace-regexp' prompts for a regexp
-whose matches are to be replaced. If these variables are nil (which
-is the default), 'query-replace' and 'query-replace-regexp' take the
-default value from the previous FROM-TO pair.
-
-** Lisp pretty-printer ('pp')
-
-*** New function 'pp-emacs-lisp-code'.
-'pp' formats general Lisp sexps. This function does much the same,
-but applies formatting rules appropriate for Emacs Lisp code. Note
-that this could currently be quite slow, and is thus appropriate only
-for relatively small code fragments.
-
-*** New user option 'pp-use-max-width'.
-If non-nil, 'pp' and all 'pp-*' commands that format the results, will
-attempt to limit the line length when formatting long lists and
-vectors. This uses 'pp-emacs-lisp-code', and thus could be slow for
-large lists.
-
-** New function 'file-has-changed-p'.
-This convenience function is useful when writing code that parses
-files at run-time, and allows Lisp programs to re-parse files only
-when they have changed.
-
-** 'abbreviate-file-name' now respects magic file name handlers.
-
-** New function 'font-has-char-p'.
-This can be used to check whether a specific font has a glyph for a
-character.
-
-** 'window-text-pixel-size' now accepts a new argument IGNORE-LINE-AT-END.
-This controls whether or not the last screen line of the text being
-measured will be counted for the purpose of calculating the text
-dimensions.
-
-** 'window-text-pixel-size' understands a new meaning of FROM.
-Specifying a cons as the FROM argument allows to start measuring text
-from a specified amount of pixels above or below a position.
-
-** 'window-body-width' and 'window-body-height' can use remapped faces.
-Specifying 'remap' as the PIXELWISE argument now checks if the default
-face was remapped, and if so, uses the remapped face to determine the
-character width/height.
-
-** 'set-window-vscroll' now accepts a new argument PRESERVE-VSCROLL-P.
-This means the vscroll will not be reset when set on a window that is
-"frozen" due to a mini-window being resized.
-
-** XDG Support
-
-*** New function 'xdg-state-home'.
-It returns the new 'XDG_STATE_HOME' environment variable. It should
-point to a file name that "contains state data that should persist
-between (application) restarts, but that is not important or portable
-enough to the user that it should be stored in $XDG_DATA_HOME".
-(This variable was introduced in the XDG Base Directory Specification
-version 0.8 released on May 8, 2021.)
-
-*** New function 'xdg-current-desktop'.
-It returns a list of strings, corresponding to the colon-separated
-list of names in the 'XDG_CURRENT_DESKTOP' environment variable, which
-identify the current desktop environment.
-(This variable was introduced in XDG Desktop Entry Specification
-version 1.2.)
-
-*** New function 'xdg-session-type'.
-It returns the 'XDG_SESSION_TYPE' environment variable. (This is not
-part of any official standard; see the man page pam_systemd(8) for
-more information.)
-
-** New macro 'with-delayed-message'.
-This macro is like 'progn', but will output the specified message if
-the body takes longer to execute than the specified timeout.
-
-** New function 'funcall-with-delayed-message'.
-This function is like 'funcall', but will output the specified message
-if the function takes longer to execute than the specified timeout.
-
-** Locale
-
-*** New variable 'current-locale-environment'.
-This holds the value of the previous call to 'set-locale-environment'.
-
-*** New macro 'with-locale-environment'.
-This macro can be used to change the locale temporarily while
-executing code.
-
-** Table
-
-*** New user option 'table-latex-environment'.
-This allows switching between "table" and "tabular".
-
-** Tabulated List Mode
-
-*** A column can now be set to an image descriptor.
-The 'tabulated-list-entries' variable now supports using an image
-descriptor, which means to insert an image in that column instead of
-text. See the documentation string of that variable for details.
-
-** ':keys' in 'menu-item' can now be a function.
-If so, it is called whenever the menu is computed, and can be used to
-calculate the keys dynamically.
-
-** New major mode 'clean-mode'.
-This is a new major mode meant for debugging. It kills absolutely all
-local variables and removes overlays and text properties.
-
-** 'kill-all-local-variables' can now kill all local variables.
-If given the new optional KILL-PERMANENT argument, it also kills
-permanent local variables.
-
-** Third 'mapconcat' argument SEPARATOR is now optional.
-An explicit nil always meant the empty string, now it can be left out.
-
-** New function 'image-at-point-p'.
-This function returns t if point is on a valid image, and nil
-otherwise.
-
-** New function 'buffer-text-pixel-size'.
-This is similar to 'window-text-pixel-size', but can be used when the
-buffer isn't displayed.
-
-** New function 'string-pixel-width'.
-This returns the width of a string in pixels. This can be useful when
-dealing with variable pitch fonts and glyphs that have widths that
-aren't integer multiples of the default font.
-
-** New function 'string-glyph-split'.
-This function splits a string into a list of strings representing
-separate glyphs. This takes into account combining characters and
-grapheme clusters, by treating each sequence of characters composed on
-display as a single unit.
-
-** Xwidget
-
-*** The function 'make-xwidget' now accepts an optional RELATED argument.
-This argument is used as another widget for the newly created WebKit
-widget to share settings and subprocesses with. It must be another
-WebKit widget.
-
-*** New function 'xwidget-perform-lispy-event'.
-This function allows you to send events to xwidgets. Usually, some
-equivalent of the event will be sent, but there is no guarantee of
-what the widget will actually receive.
-
-On GTK+, only key and function key events are implemented.
-
-*** New function 'xwidget-webkit-load-html'.
-This function is used to load HTML text into WebKit xwidgets
-directly, in contrast to creating a temporary file to hold the
-markup, and passing the URI of the file as an argument to
-'xwidget-webkit-goto-uri'.
-
-*** New functions for performing searches on WebKit xwidgets.
-Some new functions, such as 'xwidget-webkit-search', have been added
-for performing searches on WebKit xwidgets.
-
-*** New function 'xwidget-webkit-back-forward-list'.
-This function returns the history of page-loads in a WebKit xwidget.
-
-*** New function 'xwidget-webkit-estimated-load-progress'.
-This function returns the estimated progress of page loading in a
-WebKit xwidget.
-
-*** New function 'xwidget-webkit-stop-loading'.
-This function terminates all data transfer during page loads in a
-WebKit xwidget.
-
-*** 'load-changed' xwidget events are now more detailed.
-In particular, they can now have different arguments based on the
-state of the WebKit widget. 'load-finished' is sent when a load has
-completed, 'load-started' when a load first starts, 'load-redirected'
-after a redirect, and 'load-committed' when the WebKit widget first
-commits to the load.
-
-*** New event type 'xwidget-display-event'.
-These events are sent whenever an xwidget requests that Emacs displays
-another xwidget. The only arguments to this event are the xwidget
-that should be displayed, and the xwidget that asked to display it.
-
-*** New function 'xwidget-webkit-set-cookie-storage-file'.
-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.
-
-** Timestamps like '(1 . 1000)' now work without warnings being generated.
-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 accepts arguments that lack month, day, or time.
-The function now assumes the earliest possible 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
-'touchscreen-end' have been added to take better advantage of
-touch-capable display panels.
-
-** New error symbol 'permission-denied'.
-This is a subcategory of 'file-error', and is signaled when some file
-operation fails because the OS doesn't allow Emacs to access a file or
-a directory.
-
-** The ':underline' face attribute now accepts a new property.
-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.
-
-** New hook 'save-place-after-find-file-hook'.
-This is called at the end of 'save-place-find-file-hook'.
-
-** '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 argument POSIX.
-This is useful when quoting shell arguments for a remote shell
-invocation. Such shells are POSIX conformant by default.
-
-** 'make-process' can set connection type independently for input and output.
-When calling 'make-process', communication via pty can be enabled
-selectively for just input or output by passing a cons cell for
-':connection-type', e.g. '(pipe . pty)'. When examining a process
-later, you can determine whether a particular stream for a process
-uses a pty by passing one of 'stdin', 'stdout', or 'stderr' as the
-second argument to 'process-tty-name'.
-
-** '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 'internal-default-signal-process'.
-
-** Some system information functions honor remote systems now.
-'list-system-processes' returns remote process IDs.
-'memory-info' returns memory information of remote systems.
-'process-attributes' expects a remote process ID.
-This happens only when the current buffer's 'default-directory' is
-remote. In order to preserve the old behavior, bind
-'default-directory' to a local directory, like
-
- (let ((default-directory temporary-file-directory))
- (list-system-processes))
-
-** New functions 'take' and 'ntake'.
-'(take N LIST)' returns the first N elements of LIST; 'ntake' does
-the same but works by modifying LIST destructively.
-
-** 'string-split' is now an alias for 'split-string'.
-
-** 'format-spec' now accepts functions in the replacement.
-The function is called only when used in the format string. This is
-useful to avoid side-effects such as prompting, when the value is not
-actually being used for anything.
-
-** The variable 'max-specpdl-size' has been made obsolete.
-Now 'max-lisp-eval-depth' alone is used for limiting Lisp recursion
-and stack usage. 'max-specpdl-size' is still present as a plain
-variable for compatibility but its limiting powers have been taken away.
-
-** New function 'external-completion-table'.
-This function returns a completion table designed to ease
-communication between Emacs's completion facilities and external tools
-offering completion services, particularly tools whose full working
-set is too big to transfer to Emacs every time a completion is
-needed. The table uses new 'external' completion style exclusively
-and cannot work with regular styles such as 'basic' or 'flex'.
-
-** Magic file name handlers for 'make-directory-internal' are no longer needed.
-Instead, Emacs uses the already-existing 'make-directory' handlers.
-
-** '(make-directory DIR t)' returns non-nil if DIR already exists.
-This can let a caller know whether it created DIR. Formerly,
-'make-directory's return value was unspecified.
+This warning can be suppressed using 'with-suppressed-warnings' with
+the warning name 'mutate-constant'.
+
+---
+*** Warn about more ignored function return values.
+The compiler now warns when the return value from certain functions is
+implicitly ignored. Example:
+
+ (progn (nreverse my-list) my-list)
+
+will elicit a warning because it is usually pointless to call
+'nreverse' on a list without using the returned value.
+
+To silence the warning, make use of the value in some way, such as
+assigning it to a variable. You can also wrap the function call in
+'(ignore ...)', or use 'with-suppressed-warnings' with the warning
+name 'ignored-return-value'.
+
+The warning will only be issued for calls to functions declared
+'important-return-value' or 'side-effect-free' (but not 'error-free').
+
+---
+*** Warn about docstrings that contain control characters.
+The compiler now warns about docstrings with control characters other
+than newline and tab. This is often a result of improper escaping.
+Example:
+
+ (defun my-fun ()
+ "Uses c:\remote\dir\files and the key \C-x."
+ ...)
+
+where the docstring contains the four control characters 'CR', 'DEL',
+'FF' and 'C-x'.
+
+The warning name is 'docstrings-control-chars'.
+
+---
+*** The warning about wide docstrings can now be disabled separately.
+Its warning name is 'docstrings-wide'.
+
+---
+** New user option 'native-comp-async-warnings-errors-kind'.
+It allows control of what kinds of warnings and errors from asynchronous
+native compilation are reported to the parent Emacs process. The
+default is to report all errors and only important warnings. If you
+were used to customizing 'native-comp-async-report-warnings-errors' to
+nil or 'silent', we suggest that you now leave it at its default value,
+and see if you get only warnings that matter.
+
++++
+** New function declaration and property 'important-return-value'.
+The declaration '(important-return-value t)' sets the
+'important-return-value' property which indicates that the function
+return value should probably not be thrown away implicitly.
+
+** Bytecode is now always loaded eagerly.
+Bytecode compiled with older Emacs versions for lazy loading using
+'byte-compile-dynamic' is now loaded all at once.
+As a consequence, 'fetch-bytecode' has no use, does nothing, and is
+now obsolete. The variable 'byte-compile-dynamic' has no effect any
+more; compilation will always yield bytecode for eager loading.
+
++++
+** New functions 'file-user-uid' and 'file-group-gid'.
+These functions are like 'user-uid' and 'group-gid', respectively, but
+are aware of file name handlers, so they will return the remote UID or
+GID for remote files (or -1 if the connection has no associated user).
+
++++
+** 'fset', 'defalias' and 'defvaralias' now signal an error for cyclic aliases.
+Previously, 'fset', 'defalias' and 'defvaralias' could be made to
+build circular function and variable indirection chains as in
+
+ (defalias 'able 'baker)
+ (defalias 'baker 'able)
+
+but trying to use them would sometimes make Emacs hang. Now, an attempt
+to create such a loop results in an error.
+
+Since circular alias chains now cannot occur, 'function-alias-p',
+'indirect-function' and 'indirect-variable' will never signal an error.
+Their 'noerror' arguments have no effect and are therefore obsolete.
+
++++
+** 'treesit-font-lock-rules' now accepts additional global keywords.
+When supplied with ':default-language LANGUAGE', rules after it will
+default to use 'LANGUAGE'.
+
+---
+** New optional argument to 'modify-dir-local-variable'.
+A 5th argument, optional, has been added to
+'modify-dir-local-variable'. It can be used to specify which
+dir-locals file to modify.
+
+** Connection local variables
+
++++
+*** New macros 'connection-local-p' and 'connection-local-value'.
+The former macro returns non-nil if a variable has a connection-local
+binding. The latter macro returns the connection-local value of a
+variable if any, or its current value.
+
+** Hash tables
+
++++
+*** ':rehash-size' and ':rehash-threshold' args no longer have any effect.
+These keyword arguments are now ignored by 'make-hash-table'. Emacs
+manages the memory for all hash table objects in the same way.
+The functions 'hash-table-rehash-size' and 'hash-table-rehash-threshold'
+remain for compatibility but now always return the old default values.
+
++++
+*** The printed representation has been shrunk and simplified.
+The 'test' parameter is omitted if it is 'eql' (the default), as is
+'data' if empty. 'rehash-size', 'rehash-threshold' and 'size' are
+always omitted, and ignored if present when the object is read back in.
+
+** Obarrays
+
++++
+*** New obarray type.
+Obarrays are now represented by an opaque type instead of using vectors.
+They are created by 'obarray-make' and manage their internal storage
+automatically, which means that the size parameter to 'obarray-make' can
+safely be omitted. That is, they do not become slower as they fill up.
+
+The old vector representation is still accepted by functions operating
+on obarrays, but 'obarrayp' only returns t for obarray objects.
+'type-of' now returns 'obarray' for obarray objects.
+
+Old code which (incorrectly) created "obarrays" as Lisp vectors filled
+with something other than 0, as in '(make-vector N nil)', will no longer
+work, and should be rewritten to use 'obarray-make'. Alternatively, you
+can fill the vector with 0.
+
++++
+*** New function 'obarray-clear' removes all symbols from an obarray.
+
+---
+*** 'obarray-size' and 'obarray-default-size' are now obsolete.
+They pertained to the internal storage size which is now irrelevant.
+
++++
+** 'treesit-install-language-grammar' can handle local directory instead of URL.
+It is now possible to pass a directory of a local repository as URL
+inside 'treesit-language-source-alist', so that calling
+'treesit-install-language-grammar' would avoid cloning the repository.
+It may be useful, for example, for the purposes of bisecting a
+treesitter grammar.
+
++++
+** New buffer-local variable 'tabulated-list-groups'.
+It controls display and separate sorting of groups of entries.
+
+---
+** New text property 'context-menu-functions'.
+Like the variable with the same name, it adds menus from the list that
+is the value of the property to context menus shown when clicking on the
+text which as this property.
+
+---
+** Detecting the end of an iteration of a keyboard macro
+'read-event', 'read-char', and 'read-char-exclusive' no longer return -1
+when called at the end of an iteration of a the execution of a keyboard
+macro. Instead, they will transparently continue reading available input
+(e.g., from the keyboard). If you need to detect the end of a macro
+iteration, check the following condition before calling one of the
+aforementioned functions:
+
+ (and (arrayp executing-kbd-macro)
+ (>= executing-kbd-macro-index (length executing-kbd-macro))))
+
++++
+** 'vtable-update-object' updates an existing object with just two arguments.
+It is now possible to update the representation of an object in a vtable
+by calling 'vtable-update-object' with just the vtable and the object as
+arguments. (Previously the 'old-object' argument was required which, in
+this case, would mean repeating the object in the argument list.) When
+replacing an object with a different one, passing both the new and old
+objects is still necessary.
-* Changes in Emacs 29.1 on Non-Free Operating Systems
+* Changes in Emacs 30.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
-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.
-
-*** GUI Yes/No dialogs now include a "Cancel" button.
-The "Cancel" button is in addition to "Yes" and "No", and is intended
-to allow users to quit the dialog, as an equivalent of 'C-g' when Emacs
-asks a yes/no question via the echo area. This is controlled by the
-new variable 'w32-yes-no-dialog-show-cancel', by default t. Set it to
-nil to get back the old behavior of showing a modal dialog with only
-two buttons: "Yes" and "No".
-
-** Cygwin
-
-*** 'process-attributes' is now implemented.
-
-** macOS
-
-*** The 'ns-popup-font-panel' command has been removed.
-Use the general command 'M-x menu-set-font' instead.
++++
+*** You can now opt out of following the system's Dark mode.
+By default, Emacs on MS-Windows follows the system's Dark mode for its
+title bars' and scroll bars' appearance. If the new user option
+'w32-follow-system-dark-mode' is customized to the nil value, Emacs
+will disregard the system's Dark mode and will always use the default
+Light mode.
----------------------------------------------------------------------
diff --git a/etc/NEWS.20 b/etc/NEWS.20
index c17cb55c324..ad41c873c1d 100644
--- a/etc/NEWS.20
+++ b/etc/NEWS.20
@@ -1250,7 +1250,7 @@ for large documents), you can reuse these buffers by setting
*** References to external documents.
-The LaTeX package 'xr' allows to cross-reference labels in external
+The LaTeX package 'xr' allows cross-referencing labels in external
documents. RefTeX can provide information about the external
documents as well. To use this feature, set up the \externaldocument
macros required by the 'xr' package and rescan the document with
@@ -3260,7 +3260,7 @@ can connect to an Emacs server started by a non-root user.
it to return immediately without waiting for you to "finish" the
buffer in Emacs.
-*** The new option --alternate-editor allows to specify an editor to
+*** The new option --alternate-editor allows specifying an editor to
use if Emacs is not running. The environment variable
ALTERNATE_EDITOR can be used for the same effect; the command line
option takes precedence.
diff --git a/etc/NEWS.21 b/etc/NEWS.21
index 6f6ed67f1f7..d7f5ba184a5 100644
--- a/etc/NEWS.21
+++ b/etc/NEWS.21
@@ -1424,7 +1424,7 @@ digest message.
*** The new user option 'rmail-automatic-folder-directives' specifies
in which folder to put messages automatically.
-*** The new function 'rmail-redecode-body' allows to fix a message
+*** The new function 'rmail-redecode-body' allows fixing a message
with non-ASCII characters if Emacs happens to decode it incorrectly
due to missing or malformed "charset=" header.
@@ -1437,7 +1437,7 @@ use the -f option when sending mail.
** The Rmail command 'o' ('rmail-output-to-rmail-file') now writes the
current message in the internal 'emacs-mule' encoding, rather than in
the encoding taken from the variable 'buffer-file-coding-system'.
-This allows to save messages whose characters cannot be safely encoded
+This allows saving messages whose characters cannot be safely encoded
by the buffer's coding system, and makes sure the message will be
displayed correctly when you later visit the target Rmail file.
@@ -1465,7 +1465,7 @@ other than 'emacs-mule', you can customize the variable
sorted *Index* buffer which looks like the final index. Entries
can be edited from that buffer.
-*** Label and citation key selection now allow to select several
+*** Label and citation key selection now allow selecting several
items and reference them together (use 'm' to mark items, 'a' or
'A' to use all marked entries).
@@ -1804,7 +1804,7 @@ to phrases and to highlight entire lines containing a match.
*** The new package zone.el plays games with Emacs' display when
Emacs is idle.
-*** The new package tildify.el allows to add hard spaces or other text
+*** The new package tildify.el allows adding hard spaces or other text
fragments in accordance with the current major mode.
*** The new package xml.el provides a simple but generic XML
@@ -1826,7 +1826,7 @@ provides an alternative interface to VC-dired for CVS. It comes with
'log-view-mode' to view RCS and SCCS logs and 'log-edit-mode' used to
enter check-in log messages.
-*** The new package called 'woman' allows to browse Unix man pages
+*** The new package called 'woman' allows browsing Unix man pages
without invoking external programs.
The command `M-x woman' formats manual pages entirely in Emacs Lisp
@@ -2011,8 +2011,8 @@ recent file list can be displayed:
- sorted by file paths, file names, ascending or descending.
- showing paths relative to the current default-directory
-The 'recentf-filter-changer' menu filter function allows to
-dynamically change the menu appearance.
+The 'recentf-filter-changer' menu filter function allows
+dynamically changing the menu appearance.
*** 'elide-head' provides a mechanism for eliding boilerplate header
text.
@@ -2139,7 +2139,7 @@ new command M-x strokes-list-strokes.
** Hexl contains a new command 'hexl-insert-hex-string' which inserts
a string of hexadecimal numbers read from the mini-buffer.
-** Hexl mode allows to insert non-ASCII characters.
+** Hexl mode allows inserting non-ASCII characters.
The non-ASCII characters are encoded using the same encoding as the
file you are visiting in Hexl mode.
@@ -2369,7 +2369,7 @@ allows the animated display of strings.
** The new function 'interactive-form' can be used to obtain the
interactive form of a function.
-** The keyword :set-after in defcustom allows to specify dependencies
+** The keyword :set-after in defcustom allows specifying dependencies
between custom options. Example:
(defcustom default-input-method nil
@@ -3629,7 +3629,7 @@ Each face can specify the following display attributes:
13. Whether or not a box should be drawn around characters, its
color, the width of the box lines, and 3D appearance.
-Faces are frame-local by nature because Emacs allows to define the
+Faces are frame-local by nature because Emacs allows defining the
same named face (face names are symbols) differently for different
frames. Each frame has an alist of face definitions for all named
faces. The value of a named face in such an alist is a Lisp vector
diff --git a/etc/NEWS.22 b/etc/NEWS.22
index 56d839e8a13..848b9afda4b 100644
--- a/etc/NEWS.22
+++ b/etc/NEWS.22
@@ -2408,7 +2408,7 @@ called with a prefix argument. Related new options are
The new command 'reftex-create-bibtex-file' creates a BibTeX database
with all entries referenced in the current document. The keys "e" and
-"E" allow to produce a BibTeX database file from entries marked in a
+"E" allow producing a BibTeX database file from entries marked in a
citation selection buffer.
The command 'reftex-citation' uses the word in the buffer before the
diff --git a/etc/NEWS.23 b/etc/NEWS.23
index c2a43105864..3ba5bdd180c 100644
--- a/etc/NEWS.23
+++ b/etc/NEWS.23
@@ -1200,7 +1200,7 @@ of the region to comment, rather than the leftmost column.
*** The new commands 'pp-macroexpand-expression' and
'pp-macroexpand-last-sexp' pretty-print macro expansions.
-*** The new command 'set-file-modes' allows to set file's mode bits.
+*** The new command 'set-file-modes' allows setting file's mode bits.
The mode bits can be specified in symbolic notation, like with GNU
Coreutils, in addition to an octal number. 'chmod' is a new
convenience alias for this function.
@@ -1540,7 +1540,7 @@ authentication respectively.
*** New macro 'with-help-window' should set up help windows better
than 'with-output-to-temp-buffer' with 'print-help-return-message'.
-*** New option 'help-window-select' permits to customize whether help
+*** New option 'help-window-select' permits customizing whether help
window shall be automatically selected when invoking help.
*** New variable 'help-window-point-marker' permits one to specify a new
@@ -1670,7 +1670,7 @@ Previously, this information was hidden.
** TeX modes
*** New option 'latex-indent-within-escaped-parens'
-permits to customize indentation of LaTeX environments delimited
+permits customizing indentation of LaTeX environments delimited
by escaped parens.
** T-mouse Mode
@@ -1726,7 +1726,7 @@ and Bzr. VC will now pass a multiple-file commit to these systems as
a single changeset.
*** 'vc-dir' is a new command that displays file names and their VC
-status. It allows to apply various VC operations to a file, a
+status. It allows applying various VC operations to a file, a
directory or a set of files/directories.
*** VC switches are no longer appended, rather the first non-nil value is used.
diff --git a/etc/NEWS.24 b/etc/NEWS.24
index 484ff127d5d..f2e434352a7 100644
--- a/etc/NEWS.24
+++ b/etc/NEWS.24
@@ -872,7 +872,7 @@ name and arguments.
** Tramp
-*** New connection method "adb", which allows to access Android
+*** New connection method "adb", which allows accessing Android
devices by the Android Debug Bridge. The variable 'tramp-adb-program'
can be used to adapt the path of the "adb" program, if needed.
@@ -2703,12 +2703,12 @@ specified by 'display-buffer-fallback-action'.
display actions, taking precedence over 'display-buffer-base-action'.
*** New option 'window-combination-limit'.
-The new option 'window-combination-limit' allows to return the space
+The new option 'window-combination-limit' allows returning the space
obtained for resizing or creating a window more reliably to the window
from which such space was obtained.
*** New option 'window-combination-resize'.
-The new option 'window-combination-resize' allows to split a window that
+The new option 'window-combination-resize' allows splitting a window that
otherwise cannot be split because it's too small by stealing space from
other windows in the same combination. Subsequent resizing or deletion
of the window will resize all windows in the same combination as well.
@@ -2721,7 +2721,7 @@ frame, or quitting a window showing a buffer in a frame of its own.
These maximize and minimize the size of a window within its frame.
*** New commands 'switch-to-prev-buffer' and 'switch-to-next-buffer'.
-These functions allow to navigate through the live buffers that have
+These functions allow navigating through the live buffers that have
been shown in a specific window.
** Minibuffer changes
@@ -3496,7 +3496,7 @@ and 'window-body-height' are provided.
For each window you can specify a parameter to override the default
behavior of a number of functions like 'split-window', 'delete-window'
and 'delete-other-windows'. The variable 'ignore-window-parameters'
-allows to ignore processing such parameters.
+allows ignoring processing such parameters.
*** New semantics of third argument of 'split-window'.
The third argument of 'split-window' has been renamed to SIDE and can be
@@ -3554,7 +3554,7 @@ are user-customizable variables.
See the docstring of 'display-buffer' for details.
*** New functions 'window-state-get' and 'window-state-put'.
-These functions allow to save and restore the state of an arbitrary
+These functions allow saving and restoring the state of an arbitrary
frame or window as an Elisp object.
** Completion
diff --git a/etc/NEWS.25 b/etc/NEWS.25
index 3c5e9569b49..f647809074b 100644
--- a/etc/NEWS.25
+++ b/etc/NEWS.25
@@ -1158,6 +1158,11 @@ few or no entries have changed.
* New Modes and Packages in Emacs 25.1
+** New preloaded package 'obarray'
+
+Provides obarray operations under the 'obarray-' prefix, such as
+'obarray-make', 'obarrayp', and 'obarray-map'.
+
** pinentry.el allows GnuPG passphrase to be prompted through the
minibuffer instead of a graphical dialog, depending on whether the gpg
command is called from Emacs (i.e., INSIDE_EMACS environment variable
diff --git a/etc/NEWS.26 b/etc/NEWS.26
index 0668d486bdd..b374c8b5ed3 100644
--- a/etc/NEWS.26
+++ b/etc/NEWS.26
@@ -38,7 +38,7 @@ in its NEWS.)
** Installing Emacs now installs the emacs-module.h file.
The emacs-module.h file is now installed in the system-wide include
-directory as part of the Emacs installation. This allows to build
+directory as part of the Emacs installation. This allows building
Emacs modules outside of the Emacs source tree.
@@ -1927,6 +1927,6 @@ along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>.
Local variables:
coding: utf-8
-mode: outline
+mode: emacs-news
paragraph-separate: "[ ]*$"
end:
diff --git a/etc/NEWS.29 b/etc/NEWS.29
new file mode 100644
index 00000000000..3f94b0d4634
--- /dev/null
+++ b/etc/NEWS.29
@@ -0,0 +1,4382 @@
+GNU Emacs NEWS -- history of user-visible changes.
+
+Copyright (C) 2021-2024 Free Software Foundation, Inc.
+See the end of the file for license conditions.
+
+Please send Emacs bug reports to 'bug-gnu-emacs@gnu.org'.
+If possible, use 'M-x report-emacs-bug'.
+
+This file is about changes in Emacs version 29.
+
+See file HISTORY for a list of GNU Emacs versions and release dates.
+See files NEWS.28, NEWS.27, ..., NEWS.18, and NEWS.1-17 for changes
+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'.
+
+
+* Changes in Emacs 29.3
+Emacs 29.3 is an emergency bugfix release intended to fix several
+security vulnerabilities described below.
+
+** Arbitrary Lisp code is no longer evaluated as part of turning on Org mode.
+This is for security reasons, to avoid evaluating malicious Lisp code.
+
+** New buffer-local variable 'untrusted-content'.
+When this is non-nil, Lisp programs should treat buffer contents with
+extra caution.
+
+** Gnus now treats inline MIME contents as untrusted.
+To get back previous insecure behavior, 'untrusted-content' should be
+reset to nil in the buffer.
+
+** LaTeX preview is now by default disabled for email attachments.
+To get back previous insecure behavior, set the variable
+'org--latex-preview-when-risky' to a non-nil value.
+
+** Org mode now considers contents of remote files to be untrusted.
+Remote files are recognized by calling 'file-remote-p'.
+
+
+* Installation Changes in Emacs 29.2
+
+
+* Startup Changes in Emacs 29.2
+
+** On GNU/Linux, Emacs is now the default application for 'org-protocol'.
+Org mode provides a way to quickly capture bookmarks, notes, and links
+using 'emacsclient':
+
+ emacsclient "org-protocol://store-link?url=URL&title=TITLE"
+
+Previously, users had to manually configure their GNU/Linux desktop
+environment to open 'org-protocol' links in Emacs. These links should
+now open in Emacs automatically, as the "emacsclient.desktop" file now
+arranges for Emacs to be the default application for the 'org-protocol'
+URI scheme. See the Org mode manual, Info node "(org) Protocols" for
+more details.
+
+
+* Changes in Emacs 29.2
+
+This is a bug-fix release with no new features.
+
+
+* Changes in Specialized Modes and Packages in Emacs 29.2
+
+** Tramp
+
+*** New user option 'tramp-show-ad-hoc-proxies'.
+When non-nil, ad-hoc definitions are kept in remote file names instead
+of showing the shortcuts.
+
+
+* Incompatible Lisp Changes in Emacs 29.2
+
+** 'with-sqlite-transaction' rolls back changes if its BODY fails.
+If the BODY of the macro signals an error, or committing the results
+of the transaction fails, the changes will now be rolled back.
+
+
+* Installation Changes in Emacs 29.1
+
+** Ahead-of-time native compilation can now be requested via configure.
+Use '--with-native-compilation=aot' to request that all the Lisp files
+in the Emacs tree should be natively compiled ahead of time. (This is
+slow on most machines.)
+
+This feature existed in Emacs 28.1, but was less easy to request.
+
+** Emacs can be built with the tree-sitter parsing library.
+This library, together with separate grammar libraries for each
+language, provides incremental parsing capabilities for several
+popular programming languages and other formatted files. Emacs built
+with this library offers major modes, described elsewhere in this
+file, that are based on the tree-sitter's parsers. If you have the
+tree-sitter library installed, the configure script will automatically
+include it in the build; use '--without-tree-sitter' at configure time
+to disable that.
+
+Emacs modes based on the tree-sitter library require an additional
+grammar library for each mode. These grammar libraries provide the
+tree-sitter library with language-specific lexical analysis and
+parsing capabilities, and are developed separately from the
+tree-sitter library itself. If you don't have a grammar library
+required by some Emacs major mode, and your distro doesn't provide it
+as an installable package, you can compile and install such a library
+yourself. Many libraries can be downloaded from the tree-sitter site:
+
+ https://github.com/tree-sitter
+
+Emacs provides a user command, 'treesit-install-language-grammar',
+that automates the download and build process of a grammar library.
+It prompts for the language, the URL of the language grammar's VCS
+repository, and then uses the installed C/C++ compiler to build the
+library and install it.
+
+You can also do this manually. To compile such a library after
+cloning its Git repository, compile the files "scanner.c" and
+"parser.c" (sometimes named "scanner.cc" and "parser.cc") in the "src"
+subdirectory of the library's source tree using the C or C++ compiler,
+then link these two files into a shared library named
+"libtree-sitter-LANG.so" ("libtree-sitter-LANG.dll" on MS-Windows,
+"libtree-sitter-LANG.dylib" on macOS), where LANG is the name of the
+language supported by the grammar as it is expected by the Emacs major
+mode (for example, "c" for 'c-ts-mode', "cpp" for 'c++-ts-mode',
+"python" for 'python-ts-mode', etc.). Then place the shared library
+you've built in the same directory where you keep the other shared
+libraries used by Emacs, or in the "tree-sitter" subdirectory of your
+'user-emacs-directory', or in a directory mentioned in the variable
+'treesit-extra-load-path'.
+
+You only need to install language grammar libraries required by the
+Emacs modes you will use, as Emacs loads these libraries only when the
+corresponding mode is turned on in some buffer for the first time in
+an Emacs session.
+
+We generally recommend to use the latest versions of grammar libraries
+available from their sites, as these libraries are in constant
+development and occasionally add features and fix important bugs to
+follow the advances in the programming languages they support.
+
+** Emacs can be built with built-in support for accessing SQLite databases.
+This uses the popular sqlite3 library, and can be disabled by using
+the '--without-sqlite3' option to the 'configure' script.
+
+** Support for the WebP image format.
+This support is built by default when the libwebp library is
+available, and includes support for animated WebP images. To disable
+WebP support, use the '--without-webp' configure flag. Image
+specifiers can now use ':type webp'.
+
+** 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-<fingerprint>.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 on X now uses 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.
+
+'(featurep 'xinput2)' can be used to test for the presence of XInput 2
+support from Lisp programs.
+
+** Emacs can now be optionally built with the Cairo XCB backend.
+Configure Emacs with the '--with-cairo-xcb' option to use the Cairo
+XCB backend; the default is not to use it. This backend makes Emacs
+moderately faster when running over X connections with high latency,
+but is currently known to crash when Emacs repeatedly closes and opens
+a display connection to the same terminal; this could happen, for
+example, if you repeatedly visit files via emacsclient in a single
+client frame, each time deleting the frame with 'C-x C-c'.
+
+** Emacs now supports being built with pure GTK.
+To use this option, make sure the GTK 3 (version 3.22.23 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 recommend that you
+use this configuration only if you are running a window system other
+than X that's supported by GDK. 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'. Running this on WSL is also known to have problems.
+
+Note that, unlike the X build of Emacs, the PGTK build cannot
+automatically switch to text-mode interface (thus emulating '-nw') if
+it cannot determine the default display; it will instead complain and
+ask you to invoke it with the explicit '-nw' option.
+
+** 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
+can be enabled by configuring Emacs with the option '--with-be-app',
+which will require the Haiku Application Kit development headers and a
+C++ compiler to be present on your system. If Emacs is not built with
+the option '--with-be-app', the resulting Emacs will only run in
+text-mode terminals.
+
+To enable Cairo support, ensure that the Cairo and FreeType
+development files are present on your system, and configure Emacs with
+'--with-be-cairo'.
+
+Unlike X, there is no compile-time option to enable or disable
+double-buffering; it is always enabled. To disable it, change the
+frame parameter 'inhibit-double-buffering' instead.
+
+** Emacs no longer reduces the size of the Japanese dictionary.
+Building Emacs includes generation of a Japanese dictionary, which is
+used by Japanese input methods. Previously, the build included a step
+of reducing the size of this dictionary's vocabulary. This vocabulary
+reduction is now optional, by default off. If you need the Emacs
+build to include the vocabulary reduction, configure Emacs with the
+option '--with-small-ja-dic'. In an Emacs source tree already
+configured without that option, you can force the vocabulary reduction
+by saying
+
+ make -C leim generate-ja-dic JA_DIC_NO_REDUCTION_OPTION=''
+
+after deleting "lisp/leim/ja-dic/ja-dic.el".
+
+** The docstrings of preloaded files are not in "etc/DOC" any more.
+Instead, they're fetched as needed from the corresponding ".elc"
+files, as was already the case for all the non-preloaded files.
+
+
+* Startup Changes in Emacs 29.1
+
+** '--batch' and '--script' now adjust the garbage collection levels.
+These switches now set 'gc-cons-percentage' to 1.0 (up from the
+default of 0.1). This means that batch processes will typically use
+more memory than before, but use less time doing garbage collection.
+Batch jobs that are supposed to run for a long time should adjust the
+limit back down again.
+
+** 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'.
+Use the '--init-directory' command-line option to set
+'user-emacs-directory'.
+
+** Emacs now has a '--fingerprint' option.
+This will output a string identifying the current Emacs build, and exit.
+
+** New hook 'after-pdump-load-hook'.
+This is run at the end of the Emacs startup process, and is meant to
+be used to reinitialize data structures that would normally be done at
+load time.
+
+** Native Compilation
+
+*** New command 'native-compile-prune-cache'.
+This command deletes old subdirectories of the eln cache (but not the
+ones for the current Emacs version). Note that subdirectories of the
+system directory where the "*.eln" files are installed (usually, the
+last entry in 'native-comp-eln-load-path') are not deleted.
+
+*** New function 'startup-redirect-eln-cache'.
+This function can be called in your init files to change the
+user-specific directory where Emacs stores the "*.eln" files produced
+by native compilation of Lisp packages Emacs loads. The default
+eln cache directory is unchanged: it is the "eln-cache" subdirectory
+of 'user-emacs-directory'.
+
+
+* Incompatible changes in Emacs 29.1
+
+** The image commands have changed key bindings.
+In previous Emacs versions, the '+', '-' and 'r' keys were bound when
+point was over an image. In Emacs 29.1, additional commands have been
+added, and this made it more likely that users would trigger the image
+commands by mistake. To avoid this, all image commands have been
+moved to the 'i' prefix keymap, so '+' is now 'i +', '-' is now 'i -',
+and 'r' is now 'i r'. In addition, these commands are now repeating,
+so you can rotate an image twice by saying 'i r r', for instance.
+
+** Emacs now picks the correct coding-system for X input methods.
+Previously, Emacs would use 'locale-coding-system' for input
+methods, which could in some circumstances be incorrect, especially
+when the input method chose to fall back to some other coding system.
+
+Emacs now automatically detects the coding-system used by input
+methods, and uses that to decode input in preference to the value of
+'locale-coding-system'. This unfortunately means that users who have
+changed the coding system used to decode X keyboard input must adjust
+their customizations to 'locale-coding-system' to the variable
+'x-input-coding-system' instead.
+
+** Bookmarks no longer include context for encrypted files.
+If you're visiting an encrypted file, setting a bookmark no longer
+includes excerpts from that buffer in the bookmarks file. This is
+implemented by the new hook 'bookmark-inhibit-context-functions',
+where packages can register a function which returns non-nil for file
+names to be excluded from adding such excerpts.
+
+** 'show-paren-mode' is now disabled in 'special-mode' buffers.
+In Emacs versions previous to Emacs 28.1, 'show-paren-mode' defaulted
+off. In Emacs 28.1, the mode was switched on in all buffers. In
+Emacs 29.1, this was changed to be switched on in all editing-related
+buffers, but not in buffers that inherit from 'special-mode'. To go
+back to how things worked in Emacs 28.1, put the following in your
+init file:
+
+ (setopt show-paren-predicate t)
+
+** Explicitly-set read-only state is preserved when reverting a buffer.
+If you use the 'C-x C-q' command to change the read-only state of the
+buffer and then revert it, Emacs would previously use the file
+permission bits to determine whether the buffer should be read-only
+after reverting the buffer. Emacs now remembers the decision made in
+'C-x C-q'.
+
+** The Gtk selection face is no longer used for the region.
+The combination of a Gtk-controlled background and a foreground color
+controlled by the internal Emacs machinery led to low-contrast faces
+in common default setups. Emacs now uses the same 'region' face on
+Gtk and non-Gtk setups.
+
+** 'C-h f' and 'C-h x' may now require confirmation when you press 'RET'.
+If the text in the minibuffer cannot be completed to a single function
+or command, typing 'RET' will not automatically complete to the shortest
+candidate, but will instead ask for confirmation. Typing 'TAB' will
+complete as much as possible, and another 'TAB' will show all the
+possible completions. This allows you to insist on the functions name
+even if Help doesn't appear to know about it, by confirming with a
+second 'RET'.
+
+** Dired
+
+*** 'w' ('dired-copy-filename-as-kill') has changed behavior.
+If there are several files marked, file names containing space and
+quote characters will be quoted "like this".
+
+*** The 'd' command now more consistently skips dot files.
+In previous Emacs versions, commands like 'C-u 10 d' would put the "D"
+mark on the next ten files, no matter whether they were dot files
+(i.e., "." and "..") or not, while marking the next ten lines with the
+mouse (in 'transient-mark-mode') and then hitting 'd' would skip dot
+files. These now work equivalently.
+
+** Warning about "eager macro-expansion failure" is now an error.
+
+** Previously, the X "reverseVideo" value at startup was heeded for all frames.
+This meant that if you had a "reverseVideo" resource on the initial
+display, and then opened up a new frame on a display without any
+explicit "reverseVideo" setting, it would get heeded there, too. (This
+included terminal frames.) In Emacs 29, the "reverseVideo" X resource
+is handled like all the other X resources, and set on a per-frame basis.
+
+** 'E' in 'query-replace' now edits the replacement with exact case.
+Previously, this command did the same as 'e'.
+
+** '/ a' in "*Packages*" buffer now limits by archive name(s) instead of regexp.
+
+** Setting the goal columns now also affects '<prior>' and '<next>'.
+Previously, 'C-x C-n' only affected 'next-line' and 'previous-line',
+but it now also affects 'scroll-up-command' and 'scroll-down-command'.
+
+** 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 '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 actually 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 '<backtab>' are now bound in 'button-map'.
+This means that if point 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.
+
+** 'outline-minor-mode-cycle-map' is now parent of 'outline-minor-mode'.
+Instead of adding text property 'keymap' with 'outline-minor-mode-cycle'
+on outline headings in 'outline-minor-mode', the keymap
+'outline-minor-mode-cycle' is now active in the whole buffer.
+But keybindings in 'outline-minor-mode-cycle' still take effect
+only on outline headings because they are bound with the help of
+'outline-minor-mode-cycle--bind' that checks if point is on a heading.
+
+** 'Info-default-directory-list' is no longer populated at Emacs startup.
+If you have code in your init file that removes directories from
+'Info-default-directory-list', this will no longer work.
+
+** 'C-k' no longer deletes files in 'ido-mode'.
+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)
+
+** New user option 'term-clear-full-screen-programs'.
+By default, term.el will now work like most terminals when displaying
+full-screen programs: When they exit, the output is cleared, leaving
+what was displayed in the window before the programs started. Set
+this user option to nil to revert back to the old behavior.
+
+** Support for old EIEIO functions is not autoloaded any more.
+You need an explicit '(require 'eieio-compat)' to use 'defmethod'
+and 'defgeneric' (which were made obsolete in Emacs 25.1 by
+'cl-defmethod' and 'cl-defgeneric').
+Similarly you might need to '(require 'eieio-compat)' before loading
+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.
+
+** 'C-x 8 =' has been moved to 'C-x 8 = ='.
+You can now use 'C-x 8 =' to insert several characters with macron;
+for example, 'C-x 8 = a' will insert U+0101 LATIN SMALL LETTER A WITH
+MACRON. To insert a lone macron, type 'C-x 8 = =' instead of the
+previous 'C-x ='.
+
+** Eshell
+
+*** Eshell's PATH is now derived from 'exec-path'.
+For consistency with remote connections, Eshell now uses 'exec-path'
+to determine the execution path on the local or remote system, instead
+of using the PATH environment variable directly.
+
+*** '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.
+
+*** Eshell pipelines now only pipe stdout by default.
+To pipe both stdout and stderr, use the '|&' operator instead of '|'.
+
+** The 'delete-forward-char' command now deletes by grapheme clusters.
+This command is by default bound to the '<Delete>' function key
+(a.k.a. '<deletechar>'). When invoked without a prefix argument or
+with a positive prefix numeric argument, the command will now delete
+complete grapheme clusters produced by character composition. For
+example, if point is before an Emoji sequence, pressing '<Delete>'
+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.
+
+** Functions that recreate the "*scratch*" buffer now also initialize it.
+When functions like 'other-buffer' and 'server-execute' recreate
+"*scratch*", they now also insert 'initial-scratch-message' and set
+the major mode according to 'initial-major-mode', like at Emacs
+startup. Previously, these functions ignored
+'initial-scratch-message' and left "*scratch*" in 'fundamental-mode'.
+
+** Naming of Image-Dired thumbnail files has changed.
+Names of thumbnail files generated when 'image-dired-thumbnail-storage'
+is 'image-dired' now always end in ".jpg". This fixes various issues
+on different platforms, but means that thumbnails generated in Emacs 28
+will not be used in Emacs 29, and vice-versa. If disk space is an
+issue, consider deleting the 'image-dired-dir' directory (usually
+"~/.emacs.d/image-dired/") after upgrading to Emacs 29.
+
+** The 'rlogin' method in the URL library is now obsolete.
+Emacs will now display a warning if you request a URL like
+"rlogin://foo@example.org".
+
+** Setting 'url-gateway-method' to 'rlogin' is now obsolete.
+Emacs will now display a warning when setting it to that value.
+The user options 'url-gateway-rlogin-host',
+'url-gateway-rlogin-parameters', and 'url-gateway-rlogin-user-name'
+are also obsolete.
+
+** The user function 'url-irc-function' now takes a SCHEME argument.
+The user option 'url-irc-function' is now called with a sixth argument
+corresponding to the scheme portion of the target URL. For example,
+this would be "ircs" for a URL like "ircs://irc.libera.chat".
+
+** The linum.el library is now obsolete.
+We recommend using either the built-in 'display-line-numbers-mode', or
+the 'nlinum' package from GNU ELPA instead. The former has better
+performance, but the latter is closer to a drop-in replacement.
+
+1. To use 'display-line-numbers-mode', add something like this to your
+ init file:
+
+ (global-display-line-numbers-mode 1)
+ ;; Alternatively, to use it only in programming modes:
+ (add-hook 'prog-mode-hook #'display-line-numbers-mode)
+
+2. To use 'nlinum', add this to your Init file:
+
+ (package-install 'nlinum)
+ (global-nlinum-mode 1)
+ ;; Alternatively, to use it only in programming modes:
+ (add-hook 'prog-mode-hook #'nlinum-mode)
+
+3. To continue using the obsolete package 'linum', add this line to
+ your Init file, in addition to any existing customizations:
+
+ (require 'linum)
+
+** The thumbs.el library is now obsolete.
+We recommend using the 'image-dired' command instead.
+
+** The autoarg.el library is now marked obsolete.
+This library provides the 'autoarg-mode' and 'autoarg-kp-mode' minor
+modes to emulate the behavior of the historical editor Twenex Emacs.
+We believe it is no longer useful.
+
+** The quickurl.el library is now obsolete.
+Use 'abbrev', 'skeleton' or 'tempo' instead.
+
+** The rlogin.el library, and the 'rsh' command are now obsolete.
+Use something like 'M-x shell RET ssh <host> RET' instead.
+
+** The url-about.el library is now obsolete.
+
+** The autoload.el library is now obsolete.
+It is superseded by the new loaddefs-gen.el library.
+
+** The netrc.el library is now obsolete.
+Use the 'auth-source-netrc-parse-all' function in auth-source.el
+instead.
+
+** The url-dired.el library is now obsolete.
+
+** The fast-lock.el and lazy-lock.el libraries have been removed.
+They have been obsolete since Emacs 22.1.
+
+The variable 'font-lock-support-mode' is occasionally useful for
+debugging purposes. It is now a regular variable (instead of a user
+option) and can be set to nil to disable Just-in-time Lock mode.
+
+** The 'utf-8-auto' coding-system now produces BOM on encoding.
+This is actually a bugfix, since this is how 'utf-8-auto' was
+documented from day one; it just didn't behave according to
+documentation. It turns out some Lisp programs were using this
+coding-system on the wrong assumption that the "auto" part means some
+automagic handling of the end-of-line (EOL) format conversion; those
+programs will now start to fail, because BOM signature in UTF-8 encoded
+text is rarely expected. That is the reason we mention this bugfix
+here.
+
+In general, this coding-system should probably never be used for
+encoding, only for decoding.
+
+
+* Changes in Emacs 29.1
+
+** New user option 'major-mode-remap-alist' to specify favorite major modes.
+This user option lets you remap the default modes (e.g. 'perl-mode' or
+'latex-mode') to your favorite ones (e.g. 'cperl-mode' or
+'LaTeX-mode') instead of having to use 'defalias', which can have
+undesirable side effects.
+This applies to all modes specified via 'auto-mode-alist', file-local
+variables, etc.
+
+** Emacs now supports Unicode Standard version 15.0.
+
+** New user option 'electric-quote-replace-consecutive'.
+This allows you to disable the default behavior of consecutive single
+quotes being replaced with a double quote.
+
+** Emacs is now capable of editing files with very long lines.
+The display of long lines has been optimized, and Emacs should no
+longer choke when a buffer on display contains long lines. The
+variable 'long-line-threshold' controls whether and when these display
+optimizations are in effect.
+
+A companion variable 'large-hscroll-threshold' controls when another
+set of display optimizations are in effect, which are aimed
+specifically at speeding up display of long lines that are truncated
+on display.
+
+If you still experience slowdowns while editing files with long lines,
+this may be due to line truncation, or to one of the enabled minor
+modes, or to the current major mode. Try turning off line truncation
+with 'C-x x t', or try disabling all known slow minor modes with
+'M-x so-long-minor-mode', or try disabling both known slow minor modes
+and the major mode with 'M-x so-long-mode', or visit the file with
+'M-x find-file-literally' instead of the usual 'C-x C-f'.
+
+In buffers in which these display optimizations are in effect, the
+'fontification-functions', 'pre-command-hook' and 'post-command-hook'
+hooks are executed on a narrowed portion of the buffer, whose size is
+controlled by the variables 'long-line-optimizations-region-size' and
+'long-line-optimizations-bol-search-limit', as if they were in a
+'with-restriction' form. This may, in particular, cause occasional
+mis-fontifications in these buffers. Modes which are affected by
+these optimizations and by the fact that the buffer is narrowed,
+should adapt and either modify their algorithm so as not to expect the
+entire buffer to be accessible, or, if accessing outside of the
+narrowed region doesn't hurt performance, use the
+'without-restriction' form to temporarily lift the restriction and
+access portions of the buffer outside of the narrowed region.
+
+The new function 'long-line-optimizations-p' returns non-nil when
+these optimizations are in effect in the current buffer.
+
+** New command to change the font size globally.
+To increase the font size, type 'C-x C-M-+' or 'C-x C-M-='; to
+decrease it, type 'C-x C-M--'; to restore the font size, type 'C-x
+C-M-0'. The final key in these commands may be repeated without the
+leading 'C-x' and without the modifiers, e.g. 'C-x C-M-+ C-M-+ C-M-+'
+and 'C-x C-M-+ + +' increase the font size by three steps. When
+'mouse-wheel-mode' is enabled, 'C-M-wheel-up' and 'C-M-wheel-down' also
+increase and decrease the font size globally. Additionally, the
+user option 'global-text-scale-adjust-resizes-frames' controls whether
+the frames are resized when the font size is changed.
+
+** New config variable 'syntax-wholeline-max' to reduce the cost of long lines.
+This variable is used by some operations (mostly syntax-propertization
+and font-locking) to treat lines longer than this variable as if they
+were made up of various smaller lines. This can help reduce the
+slowdowns seen in buffers made of a single long line, but can also
+cause misbehavior in the presence of such long lines (though most of
+that misbehavior should usually be limited to mis-highlighting). You
+can recover the previous behavior with:
+
+ (setq syntax-wholeline-max most-positive-fixnum)
+
+** New bindings in 'find-function-setup-keys' for 'find-library'.
+When 'find-function-setup-keys' is enabled, 'C-x L' is now bound to
+'find-library', 'C-x 4 L' is now bound to 'find-library-other-window'
+and 'C-x 5 L' is now bound to 'find-library-other-frame'.
+
+** New key binding after 'M-x' or 'M-X': 'M-X'.
+Emacs allows different completion predicates to be used with 'M-x'
+(i.e., 'execute-extended-command') via the
+'read-extended-command-predicate' user option. Emacs also has the
+'M-X' (note upper case X) command, which only displays commands
+especially relevant to the current buffer. Emacs now allows toggling
+between these modes while the user is inputting a command by hitting
+'M-X' while in the minibuffer.
+
+** Interactively, 'kill-buffer' will now offer to save the buffer if unsaved.
+
+** New commands 'duplicate-line' and 'duplicate-dwim'.
+'duplicate-line' duplicates the current line the specified number of times.
+'duplicate-dwim' duplicates the region if it is active. If not, it
+works like 'duplicate-line'. An active rectangular region is
+duplicated on its right-hand side. The new user option
+'duplicate-line-final-position' specifies where to move point
+after duplicating a line.
+
+** Files with the ".eld" extension are now visited in 'lisp-data-mode'.
+
+** 'network-lookup-address-info' can now check numeric IP address validity.
+Specifying 'numeric' as the new optional HINTS argument makes it
+check if the passed address is a valid IPv4/IPv6 address (without DNS
+traffic).
+
+ (network-lookup-address-info "127.1" 'ipv4 'numeric)
+ => ([127 0 0 1 0])
+
+** New command 'find-sibling-file'.
+This command jumps to a file considered a "sibling file", which is
+determined according to the new user option 'find-sibling-rules'.
+
+** New user option 'delete-selection-temporary-region'.
+When non-nil, 'delete-selection-mode' will only delete the temporary
+regions (usually set by mouse-dragging or shift-selection).
+
+** New user option 'switch-to-prev-buffer-skip-regexp'.
+This should be a regexp or a list of regexps; buffers whose names
+match those regexps will be ignored by 'switch-to-prev-buffer' and
+'switch-to-next-buffer'.
+
+** New command 'rename-visited-file'.
+This command renames the file visited by the current buffer by moving
+it to a new name or location, and also makes the buffer visit this new
+file.
+
+** Menus
+
+*** The entries following the buffers in the "Buffers" menu can now be altered.
+Change the 'menu-bar-buffers-menu-command-entries' variable to alter
+the entries that follow the buffer list.
+
+** 'delete-process' is now a command.
+When called interactively, it will kill the process running in the
+current buffer (if any). This can be useful if you have runaway
+output in the current buffer (from a process or a network connection),
+and want to stop it.
+
+** 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 arguments to restart instead of just killing the current
+process.
+
+** Drag and Drop
+
+*** New user option 'mouse-drag-mode-line-buffer'.
+If non-nil, dragging on the buffer name part of the mode-line will
+drag the buffer's associated file to other programs. This option is
+currently only available on X, Haiku and Nextstep (GNUstep or macOS).
+
+*** 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.
+
+*** The value of 'mouse-drag-copy-region' can now be the symbol 'non-empty'.
+This prevents mouse drag gestures from putting empty strings onto the
+kill ring.
+
+*** 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.
+
+*** The X Direct Save (XDS) protocol is now supported.
+This means dropping an image or file link from programs such as
+Firefox will no longer create a temporary file in a random directory,
+instead asking you where to save the file first.
+
+** New user option 'record-all-keys'.
+If non-nil, this option will force recording of all input keys,
+including those typed in response to passwords prompt (this was the
+previous behavior). The default is nil, which inhibits recording of
+passwords.
+
+** New function 'command-query'.
+This function makes its argument command prompt the user for
+confirmation before executing.
+
+** The 'disabled' property of a command's symbol can now be a list.
+The first element of the list should be the symbol 'query', which will
+cause the command disabled this way prompt the user with a y/n or a
+yes/no question before executing. The new function 'command-query' is
+a convenient method of making commands disabled in this way.
+
+** 'count-words' will now report buffer totals if given a prefix.
+Without a prefix, it will only report the word count for the narrowed
+part of the buffer.
+
+** 'count-words' will now report sentence count when used interactively.
+
+** New user option 'set-message-functions'.
+It allows more flexible control of how echo-area messages are displayed
+by adding functions to this list. The default value is a list of one
+element: 'set-minibuffer-message', which displays echo-area messages
+at the end of the minibuffer text when the minibuffer is active.
+Other useful functions include 'inhibit-message', which allows
+specifying, via 'inhibit-message-regexps', the list of messages whose
+display should be inhibited; and 'set-multi-message' that accumulates
+recent messages and displays them stacked together.
+
+** New user option 'find-library-include-other-files'.
+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
+those tables.
+
+** 'write-file' will now copy some file mode bits.
+If the current buffer is visiting a file that is executable, the
+'C-x C-w' command will now make the new file executable, too.
+
+** New user option 'process-error-pause-time'.
+This determines how long to pause Emacs after a process
+filter/sentinel error has been handled.
+
+** New faces for font-lock.
+These faces are primarily meant for use with tree-sitter. They are:
+'font-lock-bracket-face', 'font-lock-delimiter-face',
+'font-lock-escape-face', 'font-lock-function-call-face',
+'font-lock-misc-punctuation-face', 'font-lock-number-face',
+'font-lock-operator-face', 'font-lock-property-name-face',
+'font-lock-property-use-face', 'font-lock-punctuation-face',
+'font-lock-regexp-face', and 'font-lock-variable-use-face'.
+
+** New face 'variable-pitch-text'.
+This face is like 'variable-pitch' (from which it inherits), but is
+slightly larger, which should help with the visual size differences
+between the default, non-proportional font and proportional fonts when
+mixed.
+
+** New face 'mode-line-active'.
+This inherits from the 'mode-line' face, but is the face actually used
+on the mode lines (along with 'mode-line-inactive').
+
+** New face attribute pseudo-value 'reset'.
+This value stands for the value of the corresponding attribute of the
+'default' face. It can be used to reset attribute values produced by
+inheriting from other faces.
+
+** New X resource "borderThickness".
+This controls the thickness of the external borders of the menu bars
+and pop-up menus.
+
+** New X resource "inputStyle".
+This controls the style of the pre-edit and status areas of X input
+methods.
+
+** New X resources "highlightForeground" and "highlightBackground".
+Only in the Lucid build, this controls colors used for highlighted
+menu item widgets.
+
+** On X, Emacs now tries to synchronize window resize with the window manager.
+This leads to less flicker and empty areas of a frame being displayed
+when a frame is being resized. Unfortunately, it does not work on
+some ancient buggy window managers, so if Emacs appears to freeze, but
+is still responsive to input, you can turn it off by setting the X
+resource "synchronizeResize" to "off".
+
+** On X, Emacs can optionally synchronize display with the graphics hardware.
+When this is enabled by setting the X resource "synchronizeResize" to
+"extended", frame content "tearing" is drastically reduced. This is
+only supported on the Motif, Lucid, and no-toolkit builds, and
+requires an X compositing manager supporting the extended frame
+synchronization protocol (see
+https://fishsoup.net/misc/wm-spec-synchronization.html).
+
+This behavior can be toggled on and off via the frame parameter
+'use-frame-synchronization'.
+
+** New frame parameter 'alpha-background' and X resource "alphaBackground".
+This controls the opacity of the text background when running on a
+composited display.
+
+** New frame parameter 'shaded'.
+With window managers which support this, it controls whether or not a
+frame's contents will be hidden, leaving only the title bar on display.
+
+** New user option 'x-gtk-use-native-input'.
+This controls whether or not GTK input methods are used by Emacs,
+instead of XIM input methods. Defaults to nil.
+
+** New user option 'use-system-tooltips'.
+This controls whether to use the toolkit tooltips, or Emacs's own
+native implementation of tooltips as small frames. This option is
+only meaningful if Emacs was built with GTK+, Nextstep, or Haiku
+support, and 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.
+
+** Non-native tooltips are now supported on Nextstep.
+This means Emacs built with GNUstep or built on macOS is now able to
+display different faces and images inside tooltips when the
+'use-system-tooltips' user option is nil.
+
+** New minor mode 'pixel-scroll-precision-mode'.
+When enabled, and if your mouse supports it, you can scroll the
+display up or down at pixel resolution, according to what your mouse
+wheel reports. Unlike 'pixel-scroll-mode', this mode scrolls the
+display pixel-by-pixel, as opposed to only animating line-by-line
+scrolls.
+
+** Terminal Emacs
+
+*** Emacs will now use 24-bit colors on terminals that support "Tc" capability.
+This is in addition to previously-supported ways of discovering 24-bit
+color support: either via the "RGB" or "setf24" capabilities, or if
+the 'COLORTERM' environment variable is set to the value "truecolor".
+
+*** Select active regions with xterm selection support.
+On terminals with xterm "setSelection" support, the active region may be
+saved to the X primary selection, following the
+'select-active-regions' variable. This support is enabled when
+'tty-select-active-regions' is non-nil.
+
+*** New command to set up display of unsupported characters.
+The new command 'standard-display-by-replacement-char' produces Lisp
+code that sets up the 'standard-display-table' to use a replacement
+character for display of characters that the text-mode terminal
+doesn't support. This code is intended to be used in your init files.
+This feature is most useful with the Linux console and similar
+terminals, where Emacs has a reliable way of determining which
+characters have glyphs in the font loaded into the terminal's memory.
+
+*** New functions to set terminal output buffer size.
+The new functions 'tty--set-output-buffer-size' and
+'tty--output-buffer-size' allow setting and retrieving the output
+buffer size of a terminal device. The default buffer size is and has
+always been BUFSIZ, which is defined in your system's stdio.h. When
+you set a buffer size with 'tty--set-output-buffer-size', this also
+prevents Emacs from explicitly flushing the tty output stream, except
+at the end of display update.
+
+** ERT
+
+*** New ERT variables 'ert-batch-print-length' and 'ert-batch-print-level'.
+These variables will override 'print-length' and 'print-level' when
+printing Lisp values in ERT batch test results.
+
+*** Redefining an ERT test in batch mode now signals an error.
+Executing 'ert-deftest' with the same name as an existing test causes
+the previous definition to be discarded, which was probably not
+intended when this occurs in batch mode. To remedy the error, rename
+tests so that they all have unique names.
+
+*** ERT can generate JUnit test reports.
+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.
+
+** Emoji
+
+*** Emacs now has several new methods for inserting Emoji.
+The Emoji commands are under the new 'C-x 8 e' prefix.
+
+*** New command 'emoji-insert' (bound to 'C-x 8 e e' and 'C-x 8 e i').
+This command guides you through various Emoji categories and
+combinations in a graphical menu system.
+
+*** New command 'emoji-search' (bound to 'C-x 8 e s').
+This command lets you search for and insert an Emoji based on names.
+
+*** New command 'emoji-list' (bound to 'C-x 8 e l').
+This command lists all Emoji (categorized by themes) in a special
+buffer and lets you choose one of them to insert.
+
+*** New command 'emoji-recent' (bound to 'C-x 8 e r').
+This command lets you choose among the Emoji you have recently
+inserted and insert it.
+
+*** New command 'emoji-describe' (bound to 'C-x 8 e d').
+This command will tell you the name of the Emoji at point. (It also
+works for non-Emoji characters.)
+
+*** New commands 'emoji-zoom-increase' and 'emoji-zoom-decrease'.
+These are bound to 'C-x 8 e +' and 'C-x 8 e -', respectively. They
+can be used on any character, but are mainly useful for Emoji.
+
+*** New command 'emoji-zoom-reset'.
+This is bound to 'C-x 8 e 0', and undoes any size changes performed by
+'emoji-zoom-increase' and 'emoji-zoom-decrease'.
+
+*** New input method 'emoji'.
+This allows you to enter Emoji using short strings, eg ':face_palm:'
+or ':scream:'.
+
+** Help
+
+*** Variable values displayed by 'C-h v' in "*Help*" are now fontified.
+
+*** New user option 'help-clean-buttons'.
+If non-nil, link buttons in "*Help*" buffers will have any surrounding
+quotes removed.
+
+*** 'M-x apropos-variable' output now includes values of variables.
+Such an apropos buffer is more easily viewed with outlining after
+enabling 'outline-minor-mode' in 'apropos-mode'.
+
+*** New docstring syntax to indicate that symbols shouldn't be links.
+When displaying docstrings in "*Help*" buffers, strings that are
+"`like-this'" are made into links (if they point to a bound
+function/variable). This can lead to false positives when talking
+about values that are symbols that happen to have the same names as
+functions/variables. To inhibit this buttonification, use the new
+"\\+`like-this'" syntax.
+
+*** New user option 'help-window-keep-selected'.
+If non-nil, commands to show the info manual and the source will reuse
+the same window in which the "*Help*" buffer is shown.
+
+*** 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 <open>, C-x C-f, <menu-bar> <file> <new-file>.
+
+This has been changed to:
+
+ It is bound to <open> 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 was 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 is 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 back the old behavior.
+
+*** Jumping to function/variable source now saves mark before moving point.
+Jumping to source from a "*Help*" buffer moves point when the source
+buffer is already open. Now, the old point is pushed onto mark ring.
+
+*** New key bindings in "*Help*" buffers: 'n' and 'p'.
+These will take you (respectively) to the next and previous "page".
+
+*** 'describe-char' now also outputs the name of Emoji sequences.
+
+*** New key binding in "*Help*" buffer: 'I'.
+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.
+
+*** 'describe-keymap' now considers the symbol at point.
+If the symbol at point is a keymap, 'describe-keymap' suggests it as
+the default candidate.
+
+*** New command 'help-quick' displays an overview of common commands.
+The command pops up a buffer at the bottom of the screen with a few
+helpful commands for various tasks. You can toggle the display using
+'C-h C-q'.
+
+** Emacs now comes with Org v9.6.
+See the file "etc/ORG-NEWS" for user-visible changes in Org.
+
+** 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 initially, after Outline mode is turned on.
+When the value is a number, the user option 'outline-default-rules'
+determines the visibility of the subtree starting at the corresponding
+level. Values are provided to control showing a heading subtree
+depending on whether the heading matches a regexp, or on whether its
+subtree has long lines or is itself too long.
+
+** Outline Minor Mode
+
+*** New user option 'outline-minor-mode-use-buttons'.
+If non-nil, Outline Minor Mode will use buttons to hide/show outlines
+in addition to the ellipsis. The default is nil, but in 'help-mode'
+it has the value 'insert' that inserts the buttons directly into the
+buffer, and you can use 'RET' to cycle outline visibility. When
+the value is 'in-margins', Outline Minor Mode uses the window margins
+for buttons that hide/show outlines.
+
+*** Buttons and headings now have their own keymaps.
+'outline-button-icon-map', 'outline-overlay-button-map', and
+'outline-inserted-button-map' are now available as defined keymaps
+instead of being anonymous keymaps.
+
+** Windows
+
+*** New commands 'split-root-window-below' and 'split-root-window-right'.
+These commands split the root window in two, and are bound to 'C-x w 2'
+and 'C-x w 3', respectively. A number of other useful window-related
+commands are now available with key sequences that start with the
+'C-x w' prefix.
+
+*** New display action 'display-buffer-full-frame'.
+This action removes other windows from the frame when displaying a
+buffer on that frame.
+
+*** 'display-buffer' now can set up the body size of the chosen window.
+For example, a 'display-buffer-alist' entry of
+
+ (window-width . (body-columns . 40))
+
+will make the body of the chosen window 40 columns wide. For the
+height use 'window-height' and 'body-lines', respectively.
+
+*** 'display-buffer' provides more options for using an existing window.
+The display buffer action functions 'display-buffer-use-some-window' and
+'display-buffer-use-least-recent-window' now honor the action alist
+entry 'window-min-height' as well as the entries listed below to make
+the display of several buffers in a row more amenable.
+
+*** New buffer display action alist entry 'lru-frames'.
+This allows specifying which frames 'display-buffer' should consider
+when using a window that shows another buffer. It is interpreted as
+per the ALL-FRAMES argument of 'get-lru-window'.
+
+*** New buffer display action alist entry 'lru-time'.
+'display-buffer' will ignore windows with a use time higher than this
+when using a window that shows another buffer.
+
+*** New buffer display action alist entry 'bump-use-time'.
+This has 'display-buffer' bump the use time of any window it returns,
+making it a less likely candidate for displaying another buffer.
+
+*** New buffer display action alist entry 'window-min-width'.
+This allows specifying a preferred minimum width of the window used to
+display a buffer.
+
+*** You can specify on which window 'scroll-other-window' operates.
+This is controlled by the new 'other-window-scroll-default' variable,
+which should be set to a function that returns a window. When this
+variable is nil, 'next-window' is used.
+
+** Frames
+
+*** Deleted frames can now be undeleted.
+The 16 most recently deleted frames can be undeleted with 'C-x 5 u' when
+'undelete-frame-mode' is enabled. Without a prefix argument, undelete
+the most recently deleted frame. With a numerical prefix argument
+between 1 and 16, where 1 is the most recently deleted frame, undelete
+the corresponding deleted frame.
+
+*** The variable 'icon-title-format' can now have the value t.
+That value means to use 'frame-title-format' for iconified frames.
+This is useful with some window managers and desktop environments
+which treat changes in frame's title as requests to raise the frame
+and/or give it input focus, or if you want the frame's title to be the
+same no matter if the frame is iconified or not.
+
+** Tab Bars and Tab Lines
+
+*** New user option 'tab-bar-auto-width' to automatically determine tab width.
+This option is non-nil by default, which resizes tab-bar tabs so that
+their width is evenly distributed across the tab bar. A companion
+option 'tab-bar-auto-width-max' controls the maximum width of a tab
+before its name on display is truncated.
+
+*** 'C-x t RET' creates a new tab when the provided tab name doesn't exist.
+It prompts for the name of a tab and switches to it, creating a new
+tab if no tab exists by that name.
+
+*** New keymap 'tab-bar-history-mode-map'.
+By default, it contains 'C-c <left>' and 'C-c <right>' 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
+(started by directional formatting control characters such as RLO and
+LRI). The new command 'highlight-confusing-reorderings' finds and
+highlights segments of buffer text whose reordering for display is
+suspicious and could be malicious.
+
+** Emacs Server and Client
+
+*** New command-line option '-r'/'--reuse-frame' for emacsclient.
+With this command-line option, Emacs reuses an existing graphical client
+frame if one exists; otherwise it creates a new frame.
+
+*** New command-line option '-w N'/'--timeout=N' for emacsclient.
+With this command-line option, emacsclient will exit if Emacs does not
+respond within N seconds. The default is to wait forever.
+
+*** 'server-stop-automatically' can be used to automatically stop the server.
+The Emacs server will be automatically stopped when certain conditions
+are met. The conditions are determined by the argument to
+'server-stop-automatically', which can be 'empty', 'delete-frame' or
+'kill-terminal'.
+
+** Rcirc
+
+*** New command 'rcirc-when'.
+This shows the reception time of the message at point (if available).
+
+*** New user option 'rcirc-cycle-completion-flag'.
+Rcirc now uses the default 'completion-at-point' mechanism. The
+conventional IRC behavior of completing by cycling through the
+available options can be restored by enabling this option.
+
+*** New user option 'rcirc-bridge-bot-alist'.
+If you are in a channel where a bot is responsible for bridging
+between networks, you can use this variable to make these messages
+appear more native. For example, you might set the option to:
+
+ (setopt rcirc-bridge-bot-alist '(("bridge" . "{\\(.+?\\)}[[:space:]]+")))
+
+for messages like
+
+ 09:47 <bridge> {john} I am not on IRC
+
+to be reformatted into
+
+ 09:47 <john> I am not on IRC
+
+*** New formatting commands.
+Most IRC clients (including rcirc) support basic formatting using
+control codes. Under the 'C-c C-f' prefix a few commands have been
+added to insert these automatically. For example, if a region is
+active and 'C-c C-f C-b' is invoked, markup is inserted for the region
+to be highlighted in bold.
+
+** Imenu
+
+*** 'imenu' is now bound to 'M-g i' globally.
+
+*** New function 'imenu-flush-cache'.
+Use it if you want Imenu to forget the buffer's index alist and
+recreate it anew next time 'imenu' is invoked.
+
+** Emacs is now capable of abandoning a window's redisplay that takes too long.
+This is controlled by the new variable 'max-redisplay-ticks'. If that
+variable is set to a non-zero value, display of a window will be
+aborted after that many low-level redisplay operations, thus
+preventing Emacs from becoming wedged when visiting files with very
+long lines. The default is zero, which disables the feature: Emacs
+will wait forever for redisplay to finish. (We believe you won't need
+this feature, given the ability to display buffers with very long
+lines.)
+
+
+* Editing Changes in Emacs 29.1
+
+** 'M-SPC' is now bound to 'cycle-spacing'.
+Formerly it invoked 'just-one-space'. The actions performed by
+'cycle-spacing' and their order can now be customized via the user
+option 'cycle-spacing-actions'.
+
+** 'zap-to-char' and 'zap-up-to-char' are case-sensitive for upper-case chars.
+These commands now behave as case-sensitive for interactive calls when
+they are invoked with an uppercase character, regardless of the value
+of 'case-fold-search'.
+
+** 'scroll-other-window' and 'scroll-other-window-down' now respect remapping.
+These commands (bound to 'C-M-v' and 'C-M-V') used to scroll the other
+windows without looking at customizations in that other window. These
+functions now check whether they have been rebound in the buffer shown
+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:
+
+ (cl-flet ((bla (x)
+ (* x x)))
+ (bla 42))
+
+This change also affects 'cl-macrolet', 'cl-flet*' and
+'cl-symbol-macrolet'.
+
+** New user option 'translate-upper-case-key-bindings'.
+Set this option to nil to inhibit the default translation of upper
+case keys to their lower case variants.
+
+** New command 'ensure-empty-lines'.
+This command increases (or decreases) the number of empty lines before
+point.
+
+** Improved mouse behavior with auto-scrolling modes.
+When clicking inside the 'scroll-margin' or 'hscroll-margin' region,
+point is now moved only when releasing the mouse button. This no
+longer results in a bogus selection, unless the mouse has also been
+dragged.
+
+** 'kill-ring-max' now defaults to 120.
+
+** New user option 'yank-menu-max-items'.
+Customize this option to limit the number of entries in the menu
+"Edit → Paste from Kill Menu". The default is 60.
+
+** New user option 'copy-region-blink-predicate'.
+By default, when copying a region with 'kill-ring-save', Emacs only
+blinks point and mark when the region is not denoted visually, that
+is, when either the region is inactive, or the 'region' face is
+indistinguishable from the 'default' face.
+
+Users who would rather enable blinking unconditionally can now set
+this user option to 'always'. To disable blinking unconditionally,
+either set this option to 'ignore', or set 'copy-region-blink-delay'
+to 0.
+
+** Performing a pinch gesture on a touchpad now increases the text scale.
+
+** Show Paren Mode
+
+*** New user option 'show-paren-context-when-offscreen'.
+When non-nil, if the point is in a closing delimiter and the opening
+delimiter is offscreen, shows some context around the opening
+delimiter in the echo area. The default is nil.
+
+This option can also be set to the symbols 'overlay' or 'child-frame',
+in which case the context is shown in an overlay or child-frame at the
+top-left of the current window. The latter option requires a
+graphical frame. On non-graphical frames, the context is shown in the
+echo area.
+
+** Comint
+
+*** 'comint-term-environment' is now aware of connection-local variables.
+The user option 'comint-terminfo-terminal' and the variable
+'system-uses-terminfo' can now be set as connection-local variables to
+change the terminal used on a remote host.
+
+*** New user option 'comint-delete-old-input'.
+When nil, this prevents comint from deleting the current input when
+inserting previous input using '<mouse-2>'. The default is t, to
+preserve previous behavior.
+
+*** New minor mode 'comint-fontify-input-mode'.
+This minor mode is enabled by default in "*shell*" and "*ielm*"
+buffers. It fontifies input text according to 'shell-mode' or
+'emacs-lisp-mode' font-lock rules. Customize the user options
+'shell-fontify-input-enable' and 'ielm-fontify-input-enable' to nil if
+you don't want to enable input fontification by default.
+
+** Mwheel
+
+*** New user options for alternate wheel events.
+The user options 'mouse-wheel-down-alternate-event' and
+'mouse-wheel-up-alternate-event' as well as the variables
+'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.
+
+** Internationalization
+
+*** The '<Delete>' function key now allows deleting the entire composed sequence.
+For the details, see the item about the 'delete-forward-char' command
+above.
+
+*** New user option 'composition-break-at-point'.
+Setting it to a non-nil value temporarily disables automatic
+composition of character sequences at point, and thus makes it easier
+to edit such sequences by allowing point to "enter" the composed
+sequence.
+
+*** Support for many old scripts and writing systems.
+Emacs now supports, and has language-environments and input methods,
+for several dozens of old scripts that were used in the past for
+various languages. For each such script Emacs now has font-selection
+and character composition rules, a language environment, and an input
+method. The newly-added scripts and the corresponding language
+environments are:
+
+ Tai Tham script and the Northern Thai language environment
+
+ Brahmi script and language environment
+
+ Kaithi script and language environment
+
+ Tirhuta script and language environment
+
+ Sharada script and language environment
+
+ Siddham script and language environment
+
+ Syloti Nagri script and language environment
+
+ Modi script and language environment
+
+ Baybayin script and Tagalog language environment
+
+ Hanunoo script and language environment
+
+ Buhid script and language environment
+
+ Tagbanwa script and language environment
+
+ Limbu script and language environment
+
+ Balinese script and language environment
+
+ Javanese script and language environment
+
+ Sundanese script and language environment
+
+ Batak script and language environment
+
+ Rejang script and language environment
+
+ Makasar script and language environment
+
+ Lontara script and language environment
+
+ Hanifi Rohingya script and language environment
+
+ Grantha script and language environment
+
+ Kharoshthi script and language environment
+
+ Lepcha script and language environment
+
+ Meetei Mayek script and language environment
+
+ Adlam script and language environment
+
+ Mende Kikakui script and language environment
+
+ Wancho script and language environment
+
+ Toto script and language environment
+
+ Gothic script and language environment
+
+ Coptic script and language environment
+
+ Mongolian-traditional script and language environment
+
+ Mongolian-cyrillic language environment
+
+*** The "Oriya" language environment was renamed to "Odia".
+This is to follow the change in the official name of the script. The
+'oriya' input method was also renamed to 'odia'. However, the old
+name of the language environment and the input method are still
+supported.
+
+*** New Greek translation of the Emacs tutorial.
+Type 'C-u C-h t' to select it in case your language setup does not do
+so automatically.
+
+*** New Ukrainian translation of the Emacs tutorial.
+
+*** New Farsi/Persian translation of the Emacs tutorial.
+
+*** New default phonetic input method for the Tamil language environment.
+The default input method for the Tamil language environment is now
+"tamil-phonetic" which is a customizable phonetic input method. To
+change the input method's translation rules, customize the user option
+'tamil-translation-rules'.
+
+*** New 'tamil99' input method for the Tamil language.
+This supports the keyboard layout specifically designed for the Tamil
+language.
+
+*** New input method 'slovak-qwerty'.
+This is a variant of the 'slovak' input method, which corresponds to
+the QWERTY Slovak keyboards.
+
+*** New input method 'cyrillic-chuvash'.
+This input method is based on the russian-computer input method, and
+is intended for typing in the Chuvash language written in the Cyrillic
+script.
+
+*** New input method 'cyrillic-mongolian'.
+This input method is for typing in the Mongolian language using the
+Cyrillic script. It is the default input method for the new
+Mongolian-cyrillic language environment, see above.
+
+
+* Changes in Specialized Modes and Packages in Emacs 29.1
+
+** Ecomplete
+
+*** New commands 'ecomplete-edit' and 'ecomplete-remove'.
+These allow you to (respectively) edit and bulk-remove entries from
+the ecomplete database.
+
+*** New user option 'ecomplete-auto-select'.
+If non-nil and there's only one matching option, auto-select that.
+
+*** New user option 'ecomplete-filter-regexp'.
+If non-nil, this user option describes what entries not to add to the
+database stored on disk.
+
+** Auth Source
+
+*** New user option 'auth-source-pass-extra-query-keywords'.
+Whether to recognize additional keyword params, like ':max' and
+':require', as well as accept lists of query terms paired with
+applicable keywords. This disables most known behavioral quirks
+unique to auth-source-pass, such as wildcard subdomain matching.
+
+** Dired
+
+*** 'dired-guess-shell-command' moved from dired-x to dired.
+This means that 'dired-do-shell-command' will now provide smarter
+defaults without first having to require 'dired-x'. See the node
+"(emacs) Shell Command Guessing" in the Emacs manual for more details.
+
+*** 'dired-clean-up-buffers-too' moved from dired-x to dired.
+This means that Dired now offers to kill buffers visiting files and
+dirs when they are deleted in Dired. Before, you had to require
+'dired-x' to enable this behavior. To disable this behavior,
+customize the user option 'dired-clean-up-buffers-too' to nil. The
+related user option 'dired-clean-confirm-killing-deleted-buffers'
+(which see) has also been moved to 'dired'.
+
+*** 'dired-do-relsymlink' moved from dired-x to dired.
+The corresponding key 'Y' is now bound by default in Dired.
+
+*** 'dired-do-relsymlink-regexp' moved from dired-x to dired.
+The corresponding key sequence '% Y' is now bound by default in Dired.
+
+*** 'M-G' is now bound to 'dired-goto-subdir'.
+Before, that binding was only available if the dired-x package was
+loaded.
+
+*** 'dired-info' and 'dired-man' moved from dired-x to dired.
+The 'dired-info' and 'dired-man' commands have been moved from the
+dired-x package to dired. They have also been renamed to
+'dired-do-info' and 'dired-do-man'; the old command names are obsolete
+aliases.
+
+The keys 'I' ('dired-do-info') and 'N' ('dired-do-man') are now bound
+in Dired mode by default. The user options 'dired-bind-man' and
+'dired-bind-info' no longer have any effect and are obsolete.
+
+To get the old behavior back and unbind these keys in Dired mode, add
+the following to your Init file:
+
+ (with-eval-after-load 'dired
+ (keymap-set dired-mode-map "N" nil)
+ (keymap-set dired-mode-map "I" nil))
+
+*** New command 'dired-do-eww'.
+This command visits the file on the current line with EWW.
+
+*** 'browse-url-of-dired-file' can now call the secondary browser.
+When invoked with a prefix arg, this will now call
+'browse-url-secondary-browser-function' instead of the default
+browser. 'browse-url-of-dired-file' is bound to 'W' by default in
+dired mode.
+
+*** New user option 'dired-omit-lines'.
+This is used by 'dired-omit-mode', and now allows you to hide based on
+other things than just the file names.
+
+*** 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
+back, say:
+
+ (setopt dired-free-space 'separate)
+
+*** New user option 'dired-make-directory-clickable'.
+If non-nil (which is the default), hitting 'RET' or 'mouse-1' on
+the directory components at the directory displayed at the start of
+the buffer will take you to that directory.
+
+*** Search and replace in Dired/Wdired supports more regexps.
+For example, the regexp ".*" will match only characters that are part
+of the file name. Also "^.*$" can be used to match at the beginning
+of the file name and at the end of the file name. This is used only
+when searching on file names. In Wdired this can be used when the new
+user option 'wdired-search-replace-filenames' is non-nil (which is the
+default).
+
+** Elisp
+
+*** New command 'elisp-eval-region-or-buffer' (bound to 'C-c C-e').
+This command evals the forms in the active region or in the whole buffer.
+
+*** New commands 'elisp-byte-compile-file' and 'elisp-byte-compile-buffer'.
+These commands (bound to 'C-c C-f' and 'C-c C-b', respectively)
+byte-compile the visited file and the current buffer, respectively.
+
+** Games
+
+*** New user option 'tetris-allow-repetitions'.
+This controls how randomness is implemented (whether to use pure
+randomness as before, or to use a bag).
+
+** Battery
+
+*** New user option 'battery-update-functions'.
+This can be used to trigger actions based on the battery status.
+
+** DocView
+
+*** doc-view can now generate SVG images when viewing PDF files.
+If Emacs is built with SVG support, doc-view can generate SVG files
+when using MuPDF as the converter for PDF files, which generally leads
+to sharper images (especially when zooming), and allows customization
+of background and foreground color of the page via the new user
+options 'doc-view-svg-background' and 'doc-view-svg-foreground'. To
+activate this behavior, set 'doc-view-mupdf-use-svg' to non-nil if
+your Emacs has SVG support. Note that, with some versions of MuPDF,
+SVG generation is known to sometimes produce SVG files that are buggy
+or can take a long time to render.
+
+** Enriched Mode
+
+*** New command 'enriched-toggle-markup'.
+This allows you to see the markup in 'enriched-mode' buffers (e.g.,
+the "HELLO" file). Bound to 'M-o m' by default.
+
+** Shell Script Mode
+
+*** New user option 'sh-indent-statement-after-and'.
+This controls how statements like the following are indented:
+
+ foo &&
+ bar
+
+*** New Flymake backend using the ShellCheck program.
+It is enabled by default, but requires that the external "shellcheck"
+command is installed.
+
+** CC Mode
+
+*** C++ Mode now supports most of the new features in the C++20 Standard.
+
+*** In Objective-C Mode, no extra types are recognized by default.
+The default value of 'objc-font-lock-extra-types' has been changed to
+nil, since too many identifiers were getting misfontified as types.
+This may cause some actual types not to get fontified. To get the old
+behavior back, customize the user option to the value suggested in its
+doc string.
+
+** Cperl Mode
+
+*** New user option 'cperl-file-style'.
+This option determines the indentation style to be used. It can also
+be used as a file-local variable.
+
+** Gud
+
+*** 'gud-go' is now bound to 'C-c C-v'.
+If given a prefix, it will prompt for an argument to use for the
+run/continue command.
+
+*** 'perldb' now recognizes '-E'.
+As of Perl 5.10, 'perl -E 0' behaves like 'perl -e 0' but also activates
+all optional features of the Perl version in use. 'perldb' now uses
+this invocation as its default.
+
+** Customize
+
+*** New command 'custom-toggle-hide-all-widgets'.
+This is bound to 'H' and toggles whether to hide or show the widget
+contents.
+
+** Diff Mode
+
+*** New user option 'diff-whitespace-style'.
+Sets the value of the buffer-local variable 'whitespace-style' in
+'diff-mode' buffers. By default, this variable is '(face trailing)',
+which preserves behavior of previous Emacs versions.
+
+*** New user option 'diff-add-log-use-relative-names'.
+If non-nil insert file names in ChangeLog skeletons relative to the
+VC root directory.
+
+** Ispell
+
+*** 'ispell-region' and 'ispell-buffer' now push the mark.
+These commands push onto the mark ring the location of the last
+misspelled word where corrections were offered, so that you can then
+skip back to that location with 'C-x C-x'.
+
+** Dabbrev
+
+*** New function 'dabbrev-capf' for use on 'completion-at-point-functions'.
+
+*** New user option 'dabbrev-ignored-buffer-modes'.
+Buffers with major modes in this list will be ignored. By default,
+this includes "binary" buffers like 'archive-mode' and 'image-mode'.
+
+** Package
+
+*** New command 'package-upgrade'.
+This command allows you to upgrade packages without using 'list-packages'.
+A package that comes with the Emacs distribution can only be upgraded
+after you install, once, a newer version from ELPA via the
+package-menu displayed by 'list-packages'.
+
+*** New command 'package-upgrade-all'.
+This command allows upgrading all packages without any queries.
+A package that comes with the Emacs distribution will only be upgraded
+by this command after you install, once, a newer version of that
+package from ELPA via the package-menu displayed by 'list-packages'.
+
+*** New commands 'package-recompile' and 'package-recompile-all'.
+These commands can be useful if the ".elc" files are out of date
+(invalid byte code and macros).
+
+*** New DWIM action on 'x' in "*Packages*" buffer.
+If no packages are marked, 'x' will install the package under point if
+it isn't already, and remove it if it is installed. Customize the new
+option 'package-menu-use-current-if-no-marks' to the nil value to get
+back the old behavior of signaling an error in that case.
+
+*** New command 'package-vc-install'.
+Packages can now be installed directly from source by cloning from
+their repository.
+
+*** New command 'package-vc-install-from-checkout'.
+An existing checkout can now be loaded via package.el, by creating a
+symbolic link from the usual package directory to the checkout.
+
+*** New command 'package-vc-checkout'.
+Used to fetch the source of a package by cloning a repository without
+activating the package.
+
+*** New command 'package-vc-prepare-patch'.
+This command allows you to send patches to package maintainers, for
+packages checked out using 'package-vc-install'.
+
+*** New command 'package-report-bug'.
+This command helps you compose an email for sending bug reports to
+package maintainers, and is bound to 'b' in the "*Packages*" buffer.
+
+*** New user option 'package-vc-selected-packages'.
+By customizing this user option you can specify specific packages to
+install.
+
+*** New user option 'package-install-upgrade-built-in'.
+When enabled, 'package-install' will include in the list of
+upgradeable packages those built-in packages (like Eglot and
+use-package, for example) for which a newer version is available in
+package archives, and will allow installing those newer versions. By
+default, this is disabled; however, if 'package-install' is invoked
+with a prefix argument, it will act as if this new option were
+enabled.
+
+In addition, when this option is non-nil, built-in packages for which
+a new version is available in archives can be upgraded via the package
+menu produced by 'list-packages'. If you do set this option non-nil,
+we recommend not to use the 'U' command, but instead to use '/ u' to
+show the packages which can be upgraded, and then decide which ones of
+them you actually want to update from the archives.
+
+If you customize this option, we recommend you place its non-default
+setting in your early-init file.
+
+** Emacs Sessions (Desktop)
+
+*** New user 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.
+
+** 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
+
+*** 'q' in a "*Backtrace*" buffer no longer clears the buffer.
+Instead it just buries the buffer and switches the mode from
+'debugger-mode' to 'backtrace-mode', since commands like 'e' are no
+longer available after exiting the recursive edit.
+
+*** 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 behavior from previous Emacs versions.
+
+*** 'e' in edebug can now take a prefix arg to pretty-print the results.
+When invoked with a prefix argument, as in 'C-u e', this command will
+pop up a new buffer and show the full pretty-printed value there.
+
+*** 'C-x C-e' now interprets a non-zero prefix arg to pretty-print the results.
+When invoked with a non-zero prefix argument, as in 'C-u C-x C-e',
+this command will pop up a new buffer and show the full pretty-printed
+value there.
+
+*** You can now generate a backtrace from Lisp errors in redisplay.
+To do this, set the new variable 'backtrace-on-redisplay-error' to a
+non-nil value. The backtrace will be written to a special buffer
+named "*Redisplay-trace*". This buffer will not be automatically
+displayed in a window.
+
+** Compile
+
+*** New user option 'compilation-hidden-output'.
+This regular expression can be used to make specific parts of
+compilation output invisible.
+
+*** The 'compilation-auto-jump-to-first-error' user option has been extended.
+It can now have the additional values 'if-location-known' (which will
+only jump if the location of the first error is known), and
+'first-known' (which will jump to the first known error location).
+
+*** New user option 'compilation-max-output-line-length'.
+Lines longer than the value of this option will have their ends
+hidden, with a button to reveal the hidden text. This speeds up
+operations like grepping on files that have few newlines. The default
+value is 400; set to nil to disable hiding.
+
+** 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, makes the 'M-q' command aware of the
+format of NEWS entries, and has special commands for doing maintenance
+of the Emacs NEWS files. In addition, this mode turns on
+'outline-minor-mode', and thus displays customizable icons (see
+'icon-preference') in the margins. To disable these icons, set
+'outline-minor-mode-use-buttons' to a nil value.
+
+** 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 user option 'savehist-additional-variables' can now be
+of the form '(VARIABLE . MAX-ELTS)', which means to truncate the
+VARIABLE's value to at most MAX-ELTS elements (if the value is a list)
+before saving the value.
+
+** Minibuffer and Completions
+
+*** New commands for navigating completions from the minibuffer.
+When the minibuffer is the current buffer, typing 'M-<up>' or
+'M-<down>' 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-<up>' and 'M-<down>' 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. These keys are also available for in-buffer
+completion, but they don't insert candidates automatically, you need
+to type 'M-RET' to insert the selected candidate to the buffer.
+
+*** 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 into 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. 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-auto-wrap'.
+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 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 commands to complete the minibuffer history.
+'minibuffer-complete-history' ('C-x <up>') is like 'minibuffer-complete'
+but completes on the history items instead of the default completion
+table. 'minibuffer-complete-defaults' ('C-x <down>') completes
+on the list of default items.
+
+*** User option 'minibuffer-eldef-shorten-default' is now obsolete.
+Customize the user option 'minibuffer-default-prompt-format' instead.
+
+*** 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 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 header 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 header 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. The default is to highlight
+using the 'completions-highlight' face.
+
+*** You can now define abbrevs for the minibuffer modes.
+'minibuffer-mode-abbrev-table' and
+'minibuffer-inactive-mode-abbrev-table' are now defined.
+
+** Isearch and Replace
+
+*** Changes in how Isearch responds to 'mouse-yank-at-point'.
+If a user does 'C-s' and then uses '<mouse-2>' ('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.
+
+*** Changes for values 'no' and 'no-ding' of 'isearch-wrap-pause'.
+Now with these values the search will wrap around not only on repeating
+with 'C-s C-s', but also after typing a character.
+
+*** New user option 'char-fold-override'.
+Non-nil means that the default definitions of equivalent characters
+are overridden.
+
+*** New command 'describe-char-fold-equivalences'.
+It displays character equivalences used by 'char-fold-to-regexp'.
+
+*** New command 'isearch-emoji-by-name'.
+It is bound to 'C-x 8 e RET' during an incremental search. The
+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.
+
+** GDB/MI
+
+*** New user option 'gdb-debuginfod-enable-setting'.
+On capable platforms, GDB 10.1 and later can download missing source
+and debug info files from special-purpose servers, called "debuginfod
+servers". Use this new option to control whether 'M-x gdb' instructs
+GDB to download missing files from debuginfod servers when you debug
+the corresponding programs. The default is to ask you at the
+beginning of each debugging session whether to download the files for
+that session.
+
+** Glyphless Characters
+
+*** New minor mode 'glyphless-display-mode'.
+This allows an easy way to toggle seeing all glyphless characters in
+the current buffer.
+
+*** The extra slot of 'glyphless-char-display' can now have cons values.
+The extra slot of the 'glyphless-char-display' char-table can now have
+values that are cons cells, specifying separate values for text-mode
+and GUI terminals.
+
+*** "Replacement character" feature for undisplayable characters on TTYs.
+The 'acronym' method of displaying glyphless characters on text-mode
+frames treats single-character acronyms specially: they are displayed
+without the surrounding '[..]' "box", thus in effect treating such
+"acronyms" as replacement characters.
+
+** Registers
+
+*** Buffer names can now be stored in registers.
+For instance, to enable jumping to the "*Messages*" buffer with
+'C-x r j m':
+
+ (set-register ?m '(buffer . "*Messages*"))
+
+** Pixel Fill
+
+*** This is a new package that deals with filling variable-pitch text.
+
+*** New function 'pixel-fill-region'.
+This fills the region to be no wider than a specified pixel width.
+
+** Info
+
+*** Command '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
+info node. This command only works for the Emacs and Emacs Lisp manuals.
+
+** Shortdoc
+
+*** New command 'shortdoc-copy-function-as-kill' bound to 'w'.
+It copies the name of the function near point into the kill ring.
+
+*** 'N' and 'P' are now bound to 'shortdoc-{next,previous}-section'.
+This is in addition to the old keybindings 'C-c C-n' and 'C-c C-p'.
+
+** VC
+
+*** New command 'vc-pull-and-push'.
+This commands first does a "pull" command, and if that is successful,
+does a "push" command afterwards. Currently supported in Git and Bzr.
+
+*** 'C-x v b' prefix key is used now for branch commands.
+'vc-print-branch-log' is bound to 'C-x v b l', and new commands are
+'vc-create-branch' ('C-x v b c') and 'vc-switch-branch' ('C-x v b s').
+The VC Directory buffer now uses the prefix 'b' for these branch-related
+commands.
+
+*** New command 'vc-dir-mark-by-regexp' bound to '% m' and '* %'.
+This command marks files based on a regexp. If given a prefix
+argument, unmark instead.
+
+*** New command 'C-x v !' ('vc-edit-next-command').
+This prefix command requests editing of the next VC shell command
+before execution. For example, in a Git repository, you can produce a
+log of more than one branch by typing 'C-x v ! C-x v b l' and then
+appending additional branch names to the 'git log' command.
+
+The intention is that this command can be used to access a wide
+variety of version control system-specific functionality from VC
+without complexifying either the VC command set or the backend API.
+
+*** 'C-x v v' in a diffs buffer allows to commit only some of the changes.
+This command is intended to allow you to commit only some of the
+changes you have in your working tree. Begin by creating a buffer
+with the changes against the last commit, e.g. with 'C-x v D'
+('vc-root-diff'). Then edit the diffs to remove the hunks you don't
+want to commit. Finally, type 'C-x v v' in that diff buffer to commit
+only part of your changes, those whose hunks were left in the buffer.
+
+*** 'C-x v v' on an unregistered file will now use the most specific backend.
+Previously, if you had an SVN-covered "~/" directory, and a Git-covered
+directory in "~/foo/bar", using 'C-x v v' on a new, unregistered file
+"~/foo/bar/zot" would register it in the SVN repository in "~/" instead of
+in the Git repository in "~/foo/bar". This makes this command
+consistent with 'vc-responsible-backend'.
+
+*** Log Edit now fontifies long Git commit summary lines.
+Writing shorter summary lines avoids truncation in contexts in which
+Git commands display summary lines. See the two new user options
+'vc-git-log-edit-summary-target-len' and 'vc-git-log-edit-summary-max-len'.
+
+*** New 'log-edit-headers-separator' face.
+It is used to style the line that separates the 'log-edit' headers
+from the 'log-edit' summary.
+
+*** The function 'vc-read-revision' accepts a new MULTIPLE argument.
+If non-nil, multiple revisions can be queried. This is done using
+'completing-read-multiple'.
+
+*** New function 'vc-read-multiple-revisions'.
+This function invokes 'vc-read-revision' with a non-nil value for
+MULTIPLE.
+
+*** New command 'vc-prepare-patch'.
+Patches for any version control system can be prepared using VC. The
+command will query what commits to send and will compose messages for
+your mail user agent. The behavior of 'vc-prepare-patch' can be
+modified by the user options 'vc-prepare-patches-separately' and
+'vc-default-patch-addressee'.
+
+** Message
+
+*** New user option 'mml-attach-file-at-the-end'.
+If non-nil, 'C-c C-a' will put attached files at the end of the message.
+
+*** Message Mode now supports image yanking.
+
+*** New user option 'message-server-alist'.
+This controls automatic insertion of the "X-Message-SMTP-Method"
+header before sending a message.
+
+** HTML Mode
+
+*** HTML Mode now supports "text/html" and "image/*" yanking.
+
+** Texinfo Mode
+
+*** 'texinfo-mode' now has a specialized 'narrow-to-defun' definition.
+It narrows to the current node.
+
+** EUDC
+
+*** Deprecations planned for next release.
+After Emacs 29.1, some aspects of EUDC will be deprecated. The goal
+of these deprecations is to simplify EUDC server configuration by
+making 'eudc-server-hotlist' the only place to add servers. There
+will not be a need to set the server using the 'eudc-set-server'
+command. Instead, the 'eudc-server-hotlist' user option should be
+customized to have an entry for the server. The plan is to obsolete
+the 'eudc-hotlist' package since Customize is sufficient for changing
+'eudc-server-hotlist'. How the 'eudc-server' user option works in this
+context is to-be-determined; it can't be removed, because that would
+break compatibility, but it may become synchronized with
+'eudc-server-hotlist' so that 'eudc-server' is always equal to '(car
+eudc-server-hotlist)'. The first entry in 'eudc-server-hotlist' is the
+first server tried by 'eudc-expand-try-all'. The hotlist
+simplification will allow 'eudc-query-form' to show a drop down of
+possible servers, instead of requiring a call to 'eudc-set-server'
+like it does in this release. The default value of
+'eudc-ignore-options-file' will be changed from nil to t.
+
+*** New user option 'eudc-ignore-options-file' that defaults to nil.
+The 'eudc-ignore-options-file' user option can be configured to ignore
+the 'eudc-options-file' (typically "~/.emacs.d/eudc-options"). Most
+users should configure this to t and put EUDC configuration in the
+main Emacs initialization file ("~/.emacs" or "~/.emacs.d/init.el").
+
+*** 'eudc-expansion-overwrites-query' to 'eudc-expansion-save-query-as-kill'.
+The user option 'eudc-expansion-overwrites-query' is renamed to
+'eudc-expansion-save-query-as-kill' to reflect the actual behavior of
+the user option. The former is kept as alias.
+
+*** 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 of producing 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.
+
+*** New function 'eudc-capf-complete' with 'message-mode' integration.
+EUDC can now contribute email addresses to 'completion-at-point' by
+adding the new function 'eudc-capf-complete' to
+'completion-at-point-functions' in 'message-mode'.
+
+*** Additional attributes of query and results in eudcb-macos-contacts.el.
+The EUDC back-end for the macOS Contacts app now provides a wider set
+of attributes to use for queries, and delivers more attributes in
+query results.
+
+*** New back-end for ecomplete.
+A new back-end for ecomplete allows information from that database to
+be queried by EUDC, too. The attributes present in the EUDC query are
+used to select the entry type in the ecomplete database.
+
+*** New back-end for mailabbrev.
+A new back-end for mailabbrev allows information from that database to
+be queried by EUDC, too. Only the attributes 'email', 'name', and
+'firstname' are supported.
+
+** 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 the user option
+'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
+allowed images.
+
+*** New user option 'shr-use-xwidgets-for-media'.
+If non-nil (and Emacs has been built with support for xwidgets),
+display <video> elements with an xwidget. Note that this is
+experimental; it is known to crash Emacs on some systems, and just
+doesn't work on other systems. Also see etc/PROBLEMS.
+
+*** New user option 'eww-url-transformers'.
+These are used to alter an URL before using it. By default it removes
+the common "utm_" trackers from URLs.
+
+** Find Dired
+
+*** New command 'find-dired-with-command'.
+This enables users to run 'find-dired' with an arbitrary command,
+enabling running commands previously unsupported and also enabling new
+commands to be built on top.
+
+** 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-summary-up-thread' and 'gnus-summary-down-thread' bindings removed.
+The 'gnus-summary-down-thread' binding to 'M-C-d' was shadowed by
+'gnus-summary-read-document', and these commands are also available on
+'T u' and 'T d' respectively.
+
+*** Gnus now uses a variable-pitch font in the headers by default.
+To get the monospace font back, you can put something like the
+following in your ".gnus" file:
+
+ (set-face-attribute 'gnus-header nil :inherit 'unspecified)
+
+*** The default value of 'gnus-treat-fold-headers' is now 'head'.
+
+*** New face 'gnus-header'.
+All other 'gnus-header-*' faces inherit from this face now.
+
+*** New user option 'gnus-treat-emojize-symbols'.
+If non-nil, symbols that have an Emoji representation will be
+displayed as emojis. The default is nil.
+
+*** New command 'gnus-article-emojize-symbols'.
+This is bound to 'W D e' and will display symbols that have Emoji
+representation as Emoji.
+
+*** 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.
+
+** Rmail
+
+*** Rmail partial summaries can now be applied one on top of the other.
+You can now narrow the set of messages selected by Rmail summary's
+criteria (recipients, topic, senders, etc.) by making a summary of the
+already summarized messages. For example, invoking
+'rmail-summary-by-senders', followed by 'rmail-summary-by-topic' will
+produce a summary where both the senders and the topic are according
+to your selection. The new user option
+'rmail-summary-progressively-narrow' controls whether the stacking of
+the filters is in effect; customize it to a non-nil value to enable
+this feature.
+
+*** New Rmail summary: by thread.
+The new command 'rmail-summary-by-thread' produces a summary of
+messages that belong to a single thread of discussion.
+
+** EIEIO
+
+*** 'slot-value' can now be used to access slots of 'cl-defstruct' objects.
+
+** Align
+
+*** Alignment in 'text-mode' has changed.
+Previously, 'M-x align' didn't do anything, and you had to say 'C-u
+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.
+
+** 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
+for the command they are bound to. This does not affect listings of
+key bindings and functions (such as 'C-h b').
+
+** Info Look
+
+*** info-look specs can now be expanded at run time instead of a load time.
+The new ':doc-spec-function' element can be used to compute the
+':doc-spec' element when the user asks for info on that particular
+mode (instead of at load time).
+
+** Ansi Color
+
+*** Support for ANSI 256-color and 24-bit colors.
+256-color and 24-bit color codes are now handled by ANSI color
+filters and displayed with the specified color.
+
+** Term Mode
+
+*** New user option 'term-bind-function-keys'.
+If non-nil, 'term-mode' will pass the function keys on to the
+underlying shell instead of using the normal Emacs bindings.
+
+*** Support for ANSI 256-color and 24-bit colors, italic and other fonts.
+'term-mode' can now display 256-color and 24-bit color codes. It can
+also handle ANSI codes for faint, italic and blinking text, displaying
+it with new 'term-{faint,italic,slow-blink,fast-blink}' faces.
+
+** Project
+
+*** 'project-find-file' and 'project-or-external-find-file' can include all.
+The commands 'project-find-file' and 'project-or-external-find-file'
+now accept a prefix argument, which is interpreted to mean "include
+all files".
+
+*** New command 'project-list-buffers' bound to 'C-x p C-b'.
+This command displays a list of buffers from the current project.
+
+*** '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.
+
+*** New user option 'project-vc-extra-root-markers'.
+Use it to add detection of nested projects (inside a VCS repository),
+or projects outside of VCS repositories.
+
+As a consequence, the 'VC project backend' is formally renamed to
+'VC-aware project backend'.
+
+*** New user option 'project-vc-include-untracked'.
+If non-nil, files untracked by a VCS are considered to be part of
+the project by a VC project based on that VCS.
+
+** Xref
+
+*** New command 'xref-go-forward'.
+It is bound to 'C-M-,' and jumps to the location where you previously
+invoked 'xref-go-back' ('M-,', also known as 'xref-pop-marker-stack').
+
+*** The depth of the Xref marker stack is now infinite.
+The implementation of the Xref marker stack was changed in a way that
+allows as many places to be saved on the stack as needed, limited only
+by the available memory. Therefore, the variables
+'find-tag-marker-ring-length' and 'xref-marker-ring-length' are now
+obsolete and unused; setting them has no effect.
+
+*** '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'.
+
+*** 'outline-minor-mode' is supported in Xref buffers.
+You can enable outlining by adding 'outline-minor-mode' to
+'xref-after-update-hook'.
+
+** File Notifications
+
+*** The new command 'file-notify-rm-all-watches' removes all file notifications.
+
+** Sql
+
+*** Sql now supports sending of passwords in-process.
+To improve security, if an sql product has ':password-in-comint' set
+to t, a password supplied via the minibuffer will be sent in-process,
+as opposed to via the command-line.
+
+** Image Mode
+
+*** New command 'image-transform-fit-to-window'.
+This command fits the image to the current window by scaling down or
+up as necessary. Unlike 'image-transform-fit-both', this can scale
+the image up as well as down. It is bound to 's w' in Image Mode by
+default.
+
+*** New command 'image-mode-wallpaper-set'.
+This command sets the desktop background to the current image. It is
+bound to 'W' in Image Mode by default.
+
+*** 'image-transform-fit-to-{height,width}' are now obsolete.
+Use the new command 'image-transform-fit-to-window' instead.
+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.
+
+*** New user option 'image-text-based-formats'.
+This controls whether or not to show a message, when opening certain
+image formats, explaining how to edit it as text. The default is to
+show this message for SVG and XPM.
+
+*** New command 'image-transform-set-percent'.
+It allows resizing the image to a percentage of its original size, and
+is bound to 's p' in Image mode.
+
+*** 'image-transform-original' renamed to 'image-transform-reset-to-original'.
+The old name was confusing, and is now an obsolete function alias.
+
+*** 'image-transform-reset' renamed to 'image-transform-reset-to-initial'.
+The old name was confusing, and is now an obsolete function alias.
+
+** Images
+
+*** New commands 'image-crop' and 'image-cut'.
+These commands allow interactively cropping/cutting the image at
+point. The commands are bound to keys 'i c' and 'i x' (respectively)
+in the local keymap over images. They rely on external programs, by
+default "convert" from ImageMagick, to do the actual cropping/eliding
+of the image file.
+
+*** New commands 'image-flip-horizontally' and 'image-flip-vertically'.
+These commands horizontally and vertically flip the image under point,
+and are bound to 'i h' and 'i v', respectively.
+
+*** Users can now add special image conversion functions.
+This is done via 'image-converter-add-handler'.
+
+** Image Dired
+
+*** 'image-dired-image-mode' is now based on 'image-mode'.
+This avoids converting images in the background, and makes Image-Dired
+noticeably faster. New keybindings from 'image-mode' are now
+available in the "*image-dired-display-image*" buffer; press '?' or
+'h' in that buffer to see the full list.
+
+*** Navigation and marking commands now work in image display buffer.
+The following new bindings have been added:
+- 'n', 'SPC' => 'image-dired-display-next'
+- 'p', 'DEL' => 'image-dired-display-previous'
+- 'm' => 'image-dired-mark-thumb-original-file'
+- 'd' => 'image-dired-flag-thumb-original-file'
+- 'u' => 'image-dired-unmark-thumb-original-file'
+
+*** New command 'image-dired-unmark-all-marks'.
+It removes all marks from all files in the thumbnail and the
+associated Dired buffer, and is bound to 'U' in the thumbnail and
+display buffer.
+
+*** New command 'image-dired-do-flagged-delete'.
+It deletes all flagged files, and is bound to 'x' in the thumbnail
+buffer. It replaces the command 'image-dired-delete-marked', which is
+now an obsolete alias.
+
+*** New command 'image-dired-copy-filename-as-kill'.
+It copies the name of the marked or current image to the kill ring,
+and is bound to 'w' in the thumbnail buffer.
+
+*** New command 'image-dired-wallpaper-set'.
+This command sets the desktop background to the image at point in the
+thumbnail buffer. It is bound to 'W' by default.
+
+*** 'image-dired-slideshow-start' is now bound to 'S'.
+It is bound in both the thumbnail and display buffer, and no longer
+prompts for a timeout; use a numerical prefix (e.g. 'C-u 8 S') to set
+the timeout.
+
+*** New user option 'image-dired-marking-shows-next'.
+If this option is non-nil (the default), marking, unmarking or
+flagging an image in either the thumbnail or display buffer shows the
+next image.
+
+*** New face 'image-dired-thumb-flagged'.
+If 'image-dired-thumb-mark' is non-nil (the default), this face is
+used for images that are flagged for deletion in the Dired buffer
+associated with Image-Dired.
+
+*** Image information is now shown in the header line of the thumbnail buffer.
+This replaces the message that most navigation commands in the
+thumbnail buffer used to show at the bottom of the screen.
+
+*** New specifiers for 'image-dired-display-properties-format'.
+This is used to format the new header line. The new specifiers are:
+"%d" for the name of the directory that the file is in, "%n" for
+file's number in the thumbnail buffer, and "%s" for the file size.
+
+The default format has been updated to use this. If you prefer the
+old format, add this to your Init file:
+
+ (setopt image-dired-display-properties-format "%b: %f (%t): %c")
+
+*** New faces for the header line of the thumbnail buffer.
+These faces correspond to different parts of the header line, as
+specified in 'image-dired-display-properties-format':
+- 'image-dired-thumb-header-directory-name'
+- 'image-dired-thumb-header-file-name'
+- 'image-dired-thumb-header-file-size'
+- 'image-dired-thumb-header-image-count'
+
+*** PDF support.
+Image-Dired now displays thumbnails for PDF files. Type 'RET' on a
+PDF file in the thumbnail buffer to visit the corresponding PDF.
+
+*** Support GraphicsMagick command line tools.
+Support for the GraphicsMagick command line tool ("gm") has been
+added, and is used when it is available instead of ImageMagick.
+
+*** Support Thumbnail Managing Standard v0.9.0 (Dec 2020).
+This standard allows sharing generated thumbnails across different
+programs. Version 0.9.0 adds two larger thumbnail sizes: 512x512 and
+1024x1024 pixels. See the user option 'image-dired-thumbnail-storage'
+to use it; it is not enabled by default.
+
+*** Reduce dependency on external "exiftool" program.
+The 'image-dired-copy-with-exif-file-name' command no longer requires
+an external "exiftool" program to be available. The user options
+'image-dired-cmd-read-exif-data-program' and
+'image-dired-cmd-read-exif-data-options' are now obsolete.
+
+*** Support for bookmark.el.
+The command 'bookmark-set' (bound to 'C-x r m') is now supported in
+the thumbnail view, and will create a bookmark that opens the current
+directory in Image-Dired.
+
+*** The 'image-dired-slideshow-start' command no longer prompts.
+It no longer inconveniently prompts for a number of images and a
+delay: it runs indefinitely, but stops automatically on any command.
+You can set the delay with a prefix argument, or a negative prefix
+argument to prompt for a delay. Customize the user option
+'image-dired-slideshow-delay' to change the default from 5 seconds.
+
+*** 'image-dired-show-all-from-dir-max-files' increased to 1000.
+This user option controls asking for confirmation when starting
+Image-Dired in a directory with many files. Since Image-Dired creates
+thumbnails in the background in recent versions, this is not as
+important as it used to be. You can now also customize this option to
+nil to disable this confirmation completely.
+
+*** 'image-dired-thumb-size' increased to 128.
+
+*** 'image-dired-db-file' renamed to 'image-dired-tags-db-file'.
+
+*** 'image-dired-display-image-mode' renamed to 'image-dired-image-mode'.
+The corresponding keymap is now named 'image-dired-image-mode-map'.
+
+*** Some commands have been renamed to be shorter.
+- 'image-dired-display-thumbnail-original-image' has been renamed to
+ 'image-dired-display-this'.
+- 'image-dired-display-next-thumbnail-original' has been renamed to
+ 'image-dired-display-next'.
+- 'image-dired-display-previous-thumbnail-original' has been renamed
+ to 'image-dired-display-previous'.
+The old names are now obsolete aliases.
+
+*** 'image-dired-thumb-{height,width}' are now obsolete.
+Customize 'image-dired-thumb-size' instead, which will set both the
+height and width.
+
+*** HTML image gallery generation is now obsolete.
+The 'image-dired-gallery-generate' command and these user options are
+now obsolete: 'image-dired-gallery-thumb-image-root-url',
+'image-dired-gallery-hidden-tags', 'image-dired-gallery-dir',
+'image-dired-gallery-image-root-url'.
+
+*** 'image-dired-rotate-thumbnail-{left,right}' are now obsolete.
+Instead, use commands 'image-dired-refresh-thumb' to generate a new
+thumbnail, or 'image-rotate' to rotate the thumbnail without updating
+the thumbnail file.
+
+*** Some commands and user options are now obsolete.
+Since 'image-dired-display-image-mode' is now based on 'image-mode',
+some commands and user options are no longer needed and are now obsolete:
+'image-dired-cmd-create-temp-image-options',
+'image-dired-cmd-create-temp-image-program',
+'image-dired-display-current-image-full',
+'image-dired-display-current-image-sized',
+'image-dired-display-window-height-correction',
+'image-dired-display-window-width-correction',
+'image-dired-temp-image-file'.
+
+** Exif
+
+*** New function 'exif-field'.
+This is a convenience function to extract the field data from
+'exif-parse-file' and 'exif-parse-buffer'.
+
+** Bookmarks
+
+*** 'list-bookmarks' now includes a type column.
+Types are registered via a 'bookmark-handler-type' symbol property on
+the jumping function.
+
+*** 'bookmark-sort-flag' can now be set to 'last-modified'.
+This will display bookmark list from most recently set to least
+recently set.
+
+*** When editing a bookmark annotation, 'C-c C-k' will now cancel.
+It is bound to the new command 'bookmark-edit-annotation-cancel'.
+
+*** New user option 'bookmark-fringe-mark'.
+This option controls the bitmap used to indicate bookmarks in the
+fringe (or nil to disable showing this marker).
+
+** Xwidget
+
+*** New user option 'xwidget-webkit-buffer-name-format'.
+This option controls how xwidget-webkit buffers are named.
+
+*** New user option 'xwidget-webkit-cookie-file'.
+This option controls whether the xwidget-webkit buffers save cookies
+set by web pages, and if so, in which file to save them.
+
+*** New minor mode 'xwidget-webkit-edit-mode'.
+When this mode is enabled, self-inserting characters and other common
+web browser shortcut keys are redefined to send themselves to the
+WebKit widget.
+
+*** New minor mode 'xwidget-webkit-isearch-mode'.
+This mode acts similarly to incremental search, and allows searching
+the contents of a WebKit widget. In xwidget-webkit mode, it is bound
+to 'C-s' and 'C-r'.
+
+*** New command 'xwidget-webkit-browse-history'.
+This command displays a buffer containing the page load history of
+the current WebKit widget, and allows you to navigate it.
+
+*** On X, the WebKit inspector is now available inside xwidgets.
+To access the inspector, right click on the widget and select "Inspect
+Element".
+
+*** "Open in New Window" in a WebKit widget's context menu now works.
+The newly created buffer will be displayed via 'display-buffer', which
+can be customized through the usual mechanism of 'display-buffer-alist'
+and friends.
+
+** Tramp
+
+*** New connection methods "docker", "podman" and "kubernetes".
+They allow accessing containers provided by Docker and similar
+programs.
+
+*** Tramp supports abbreviating remote home directories now.
+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 lets the 'scp'
+command do this job.
+
+*** Proper password prompts for methods "doas", "sudo" and "sudoedit".
+The password prompts for these methods reflect now the credentials of
+the user requesting such a connection, and not of the user who is the
+target. This has always been needed, just the password prompt and the
+related 'auth-sources' entry were wrong.
+
+*** New user option 'tramp-completion-use-cache'.
+During user and host name completion in the minibuffer, results from
+Tramp's connection cache are taken into account. This can be disabled
+by setting the user option 'tramp-completion-use-cache' to nil.
+
+** Browse URL
+
+*** New user option 'browse-url-default-scheme'.
+This user option decides which URL scheme that 'browse-url' and
+related functions will use by default. For example, you could
+customize this to "https" to always prefer HTTPS URLs.
+
+*** New user option 'browse-url-irc-function'.
+This option specifies a function for opening "irc://" links. It
+defaults to the new function 'browse-url-irc'.
+
+*** New function 'browse-url-irc'.
+This multipurpose autoloaded function can be used for opening "irc://"
+and "ircs://" URLS by any caller that passes a URL string as an initial
+arg.
+
+*** Support for the Netscape web browser has been removed.
+This support has been obsolete since Emacs 25.1. The final version of
+the Netscape web browser was released in February, 2008.
+
+*** Support for the Galeon web browser has been removed.
+This support has been obsolete since Emacs 25.1. The final version of
+the Galeon web browser was released in September, 2008.
+
+*** Support for the Mozilla web browser is now obsolete.
+Note that this historical web browser is different from Mozilla
+Firefox; it is its predecessor.
+
+** Python Mode
+
+*** Project shells and a new user option 'python-shell-dedicated'.
+When called with a prefix argument, 'run-python' now offers the choice
+of creating a shell dedicated to the current project. This shell runs
+in the project root directory and is shared among all project buffers.
+
+Without a prefix argument, the kind of shell (buffer-dedicated,
+project-dedicated or global) is specified by the new
+'python-shell-dedicated' user option.
+
+** Ruby Mode
+
+*** New user option 'ruby-toggle-block-space-before-parameters'.
+
+*** Support for endless methods.
+
+*** New user options that determine indentation logic.
+'ruby-method-params-indent', 'ruby-block-indent',
+'ruby-after-operator-indent', 'ruby-method-call-indent',
+'ruby-parenless-call-arguments-indent'. See the docstrings for
+explanations and examples.
+
+** Eshell
+
+*** New feature to easily bypass Eshell's own pipelining.
+Prefixing '|', '<' or '>' with an asterisk, i.e. '*|', '*<' or '*>',
+will cause the whole command to be passed to the operating system
+shell. This is particularly useful to bypass Eshell's own pipelining
+support for pipelines which will move a lot of data. See section
+"Running Shell Pipelines Natively" in the Eshell manual, node
+"(eshell) Pipelines".
+
+*** 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 the "(eshell) Electric forward slash" node in the
+Eshell manual for details.
+
+*** Improved support for redirection operators in Eshell.
+Eshell now supports a wider variety of redirection operators. For
+example, you can now redirect both stdout and stderr via '&>' or
+duplicate one output handle to another via 'NEW-FD>&OLD-FD'. For more
+information, see the "(eshell) Redirection" node in the Eshell manual.
+
+*** New eshell built-in command 'doas'.
+The privilege-escalation program 'doas' has been added to the existing
+'su' and 'sudo' commands from the 'eshell-tramp' module. The external
+command may still be accessed by using '*doas'.
+
+*** 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.
+
+*** Eshell globs ending with "/" now match only directories.
+Additionally, globs ending with "**/" or "***/" no longer raise an
+error, and now expand to all directories recursively (following
+symlinks in the latter case).
+
+*** Lisp forms in Eshell now treat a nil result as a failed exit status.
+When executing a command that looks like '(lisp form)' and returns
+nil, Eshell will set the exit status (available in the '$?'
+variable) to 2. This allows commands like that to be used in
+conditionals. To change this behavior, customize the new
+'eshell-lisp-form-nil-is-failure' user option.
+
+** Shell
+
+*** New user option 'shell-kill-buffer-on-exit'.
+Enabling this will automatically kill a "*shell*" buffer as soon as
+the shell session terminates.
+
+*** New minor mode 'shell-highlight-undef-mode'.
+Customize 'shell-highlight-undef-enable' to t if you want to enable
+this minor mode in "*shell*" buffers. It will highlight undefined
+commands with a warning face as you type.
+
+** Calc
+
+*** New user option 'calc-kill-line-numbering'.
+Set it to nil to exclude line numbering from kills and copies.
+
+** Hierarchy
+
+*** Tree Display can delay computation of children.
+'hierarchy-add-tree' and 'hierarchy-add-trees' have an optional
+argument which allows tree-widget display to be activated and computed
+only when the user expands the node.
+
+** Proced
+
+*** 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.
+
+*** Proced can now optionally show process details in color.
+New user option 'proced-enable-color-flag' enables coloring of Proced
+buffers. This option is disabled by default; customize it to a
+non-nil value to enable colors.
+
+** Miscellaneous
+
+*** New user option 'webjump-use-internal-browser'.
+When non-nil, WebJump will use an internal browser to open web pages,
+instead of the default external browser.
+
+*** New user option 'font-lock-ignore'.
+This option provides a mechanism to selectively disable font-lock
+keyword-driven fontifications.
+
+*** New user option 'auto-save-visited-predicate'.
+This user option is a predicate function which is called by
+'auto-save-visited-mode' to decide whether or not to save a buffer.
+You can use it to automatically save only specific buffers, for
+example buffers using a particular mode or in some directory.
+
+*** New user option 'remote-file-name-inhibit-auto-save-visited'.
+If this user option is non-nil, 'auto-save-visited-mode' will not
+auto-save remote buffers. The default is nil.
+
+*** 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"
+manual for more details.
+
+*** New minor mode 'elide-head-mode'.
+Enabling this minor mode turns on hiding header material, like
+'elide-head' does; disabling it shows the header. The commands
+'elide-head' and 'elide-head-show' are now obsolete.
+
+*** New package ansi-osc.el.
+Support for OSC ("Operating System Command") escape sequences has been
+extracted from comint.el in order to provide interpretation of OSC
+sequences in compilation buffers.
+
+Adding the new function 'ansi-osc-compilation-filter' to
+'compilation-filter-hook' enables interpretation of OSC escape
+sequences in compilation buffers. By default, all sequences are
+filtered out.
+
+The list of handlers (already covering OSC 7 and 8) has been extended
+with a handler for OSC 2, the command to set a window title.
+
+*** 'recentf-mode' now uses abbreviated file names by default.
+This means that e.g. "/home/foo/bar" is now displayed as "~/bar".
+Customize the user option 'recentf-filename-handlers' to nil to get
+back the old behavior.
+
+*** New command 'recentf-open'.
+This command prompts for a recently opened file in the minibuffer, and
+visits it.
+
+*** 'ffap-machine-at-point' no longer pings hosts by default.
+It will now simply look at a hostname to determine if it is valid,
+instead of also trying to ping it. Customize the user option
+'ffap-machine-p-known' to 'ping' to get the old behavior back.
+
+*** The 'run-dig' command is now obsolete; use 'dig' instead.
+
+*** Some 'bib-mode' commands and variables have been renamed.
+To respect Emacs naming conventions, the variable 'unread-bib-file'
+has been renamed to 'bib-unread-file'. The following commands have
+also been renamed:
+ 'addbib' to 'bib-add'
+ 'return-key-bib' to 'bib-return-key'
+ 'mark-bib' to 'bib-mark'
+ 'unread-bib' to 'bib-unread'
+
+*** 'outlineify-sticky' command is renamed to 'allout-outlinify-sticky'.
+The old name is still available as an obsolete function alias.
+
+*** The url-irc library now understands "ircs://" links.
+
+*** New command 'world-clock-copy-time-as-kill' for 'world-clock-mode'.
+It copies the current line into the kill ring.
+
+*** 'edit-abbrevs' now uses font-locking.
+The new face 'abbrev-table-name' is used to display the abbrev table
+name.
+
+*** New key binding 'O' in "*Buffer List*".
+This key is now bound to 'Buffer-menu-view-other-window', which will
+view this line's buffer in View mode in another window.
+
+** Scheme Mode
+
+*** Auto-detection of Scheme library files.
+Emacs now automatically enables the Scheme mode when opening R6RS
+Scheme Library Source (".sls") files and R7RS Scheme Library
+Definition (".sld") files.
+
+*** Imenu members for R6RS and R7RS library members.
+Imenu now lists the members directly nested in R6RS Scheme libraries
+('library') and R7RS libraries ('define-library').
+
+
+* New Modes and Packages in Emacs 29.1
+
+** Eglot: Emacs Client for the Language Server Protocol.
+Emacs now comes with the Eglot package, which enhances various Emacs
+features, such as completion, documentation, error detection, etc.,
+based on data provided by language servers using the Language Server
+Protocol (LSP). See the new Info manual "(eglot) Top" for more. Also
+see "etc/EGLOT-NEWS".
+
+If you want to be able to use 'package-install' to upgrade Eglot to
+newer versions released on GNU ELPA, customize the new option
+'package-install-upgrade-built-in' to a non-nil value.
+
+** use-package: Declarative package configuration.
+use-package is now shipped with Emacs. It provides the 'use-package'
+macro, which allows you to isolate package configuration in your init
+file in a way that is declarative, tidy, and performance-oriented.
+See the new Info manual "(use-package) Top" for more.
+
+If you want to be able to use 'package-install' to upgrade use-package
+to newer versions released on GNU ELPA, customize the new option
+'package-install-upgrade-built-in' to a non-nil value.
+
+** New package 'wallpaper'.
+This package provides the command 'wallpaper-set', which sets the
+desktop background image. Depending on the system and the desktop,
+this may require an external program (such as "swaybg", "gm",
+"display" or "xloadimage"). If so, a suitable command should be
+detected automatically in most cases. It can also be customized
+manually if needed, using the new user options 'wallpaper-command' and
+'wallpaper-command-args'.
+
+** New package 'oclosure'.
+This allows the creation of OClosures, which are "functions with
+slots" or "function objects" that expose additional information about
+themselves. Use the new macros 'oclosure-define' and
+'oclosure-lambda' to create OClosures. See the "(elisp) OClosures"
+node for more information.
+
+*** 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.
+
+** New mode 'erts-mode'.
+This mode is used to edit files geared towards testing actions in
+Emacs buffers, like indentation and the like. The new ert function
+'ert-test-erts-file' is used to parse these files.
+
+** New major mode 'js-json-mode'.
+This is a lightweight variant of 'js-mode' that is used by default
+when visiting JSON files.
+
+** New major mode 'csharp-mode'.
+A major mode based on CC Mode for editing programs in the C# language.
+This mode is auto-enabled for files with the ".cs" extension.
+
+** New major modes based on the tree-sitter library.
+These new major modes are available if Emacs was built with the
+tree-sitter library. They provide support for font-locking,
+indentation, and navigation by defuns based on parsing the buffer text
+by a tree-sitter parser. Some major modes also offer support for
+Imenu and 'which-func'.
+
+The new modes based on tree-sitter are for now entirely optional, and
+you must turn them on manually, or load them in your init file, or
+customize 'auto-mode-alist' to turn them on automatically for certain
+files. You can also customize 'major-mode-remap-alist' to
+automatically turn on some tree-sitter based modes for the same files
+for which a "built-in" mode would be turned on. For example:
+
+ (add-to-list 'major-mode-remap-alist '(ruby-mode . ruby-ts-mode))
+
+If you try these modes and don't like them, you can go back to the
+"built-in" modes by restarting Emacs. (If you use desktop.el to save
+and restore Emacs sessions, make sure no buffer under these modes is
+recorded in the desktop file, before restarting.) But please tell us
+why you didn't like the tree-sitter based modes, so that we could try
+improving them.
+
+Each major mode based on tree-sitter needs a language grammar library,
+usually named "libtree-sitter-LANG.so" ("libtree-sitter-LANG.dll" on
+MS-Windows), where LANG is the corresponding language name. Emacs
+looks for these libraries in the following places:
+
+ . in the directories mentioned in the list 'treesit-extra-load-path'
+ . in the "tree-sitter" subdirectory of your 'user-emacs-directory'
+ (by default, "~/.emacs.d/tree-sitter")
+ . in the standard system directories where other shared libraries are
+ usually installed
+
+We recommend to install these libraries in one of the standard system
+locations (the last place in the above list).
+
+If a language grammar library required by a mode is not found in any
+of the above places, the mode will display a warning when you try to
+turn it on.
+
+*** New major mode 'typescript-ts-mode'.
+A major mode based on the tree-sitter library for editing programs
+in the TypeScript language.
+
+*** New major mode 'tsx-ts-mode'.
+A major mode based on the tree-sitter library for editing programs
+in the TypeScript language, with support for TSX.
+
+*** New major mode 'c-ts-mode'.
+An optional major mode based on the tree-sitter library for editing
+programs in the C language.
+
+*** New major mode 'c++-ts-mode'.
+An optional major mode based on the tree-sitter library for editing
+programs in the C++ language.
+
+*** New command 'c-or-c++-ts-mode'.
+A command that automatically guesses the language of a header file,
+and enables either 'c-ts-mode' or 'c++-ts-mode' accordingly.
+
+*** New major mode 'java-ts-mode'.
+An optional major mode based on the tree-sitter library for editing
+programs in the Java language.
+
+*** New major mode 'python-ts-mode'.
+An optional major mode based on the tree-sitter library for editing
+programs in the Python language.
+
+*** New major mode 'css-ts-mode'.
+An optional major mode based on the tree-sitter library for editing
+CSS (Cascading Style Sheets).
+
+*** New major mode 'json-ts-mode'.
+An optional major mode based on the tree-sitter library for editing
+programs in the JSON language.
+
+*** New major mode 'csharp-ts-mode'.
+An optional major mode based on the tree-sitter library for editing
+programs in the C# language.
+
+*** New major mode 'bash-ts-mode'.
+Am optional major mode based on the tree-sitter library for editing
+Bash shell scripts.
+
+*** New major mode 'dockerfile-ts-mode'.
+A major mode based on the tree-sitter library for editing
+Dockerfiles.
+
+*** New major mode 'cmake-ts-mode'.
+A major mode based on the tree-sitter library for editing CMake files.
+
+*** New major mode 'toml-ts-mode'.
+An optional major mode based on the tree-sitter library for editing
+files written in TOML, a format for writing configuration files.
+
+*** New major mode 'go-ts-mode'.
+A major mode based on the tree-sitter library for editing programs in
+the Go language.
+
+*** New major mode 'go-mod-ts-mode'.
+A major mode based on the tree-sitter library for editing "go.mod"
+files.
+
+*** New major mode 'yaml-ts-mode'.
+A major mode based on the tree-sitter library for editing files
+written in YAML.
+
+*** New major mode 'rust-ts-mode'.
+A major mode based on the tree-sitter library for editing programs in
+the Rust language.
+
+*** New major mode 'ruby-ts-mode'.
+An optional major mode based on the tree-sitter library for editing
+programs in the Ruby language.
+
+
+* Incompatible Lisp Changes in Emacs 29.1
+
+** The implementation of overlays has changed.
+Emacs now uses an implementation of overlays that is much more
+efficient than the original one, and should speed up all the
+operations that involve overlays, especially when there are lots of
+them in a buffer.
+
+As result of this, some minor incompatibilities in behavior could be
+observed, as described below. Except those minor incompatibilities,
+no other changes in behavior of overlays should be visible on the Lisp
+or user level, with the exception of better performance and the order
+of overlays returned by functions that don't promise any particular
+order.
+
+*** The function 'overlay-recenter' is now a no-op.
+This function does nothing, and in particular has no effect on the
+value returned by 'overlay-lists'. The purpose of 'overlay-recenter'
+was to allow more efficient lookup of overlays around a certain buffer
+position; however with the new implementation the lookup of overlays
+is efficient regardless of their position, and there's no longer any
+need to "optimize" the lookup, nor any notion of a "center" of the
+overlays.
+
+*** The function 'overlay-lists' returns one unified list of overlays.
+This function used to return a cons of two lists, one with overlays
+before the "center" position, the other after that "center". It now
+returns a list whose 'car' is the list of all the buffer overlays, and
+whose 'cdr' is always nil.
+
+** 'format-prompt' now uses 'substitute-command-keys'.
+This means that both the prompt and 'minibuffer-default-prompt-format'
+will have key definitions and single quotes handled specially.
+
+** New function 'substitute-quotes'.
+This function works like 'substitute-command-keys' but only
+substitutes quote characters.
+
+** 'find-image' now uses 'create-image'.
+This means that images found through 'find-image' also have
+auto-scaling applied. (This only makes a difference on HiDPI
+displays.)
+
+** Changes in how "raw" in-memory XBM images are specified.
+Some years back Emacs gained the ability to scale images, and you
+could then specify ':width' and ':height' when using 'create-image' on all
+image types -- except XBM images, because this format already used the
+':width' and ':height' arguments to specify the width/height of the "raw"
+in-memory format. This meant that if you used these specifications
+on, for instance, XBM files, Emacs would refuse to display them. This
+has been changed, and ':width'/':height' now works as with all other image
+formats, and the way to specify the width/height of the "raw"
+in-memory format is now by using ':data-width' and ':data-height'.
+
+** "loaddefs.el" generation has been reimplemented.
+The various "loaddefs.el" files in the Emacs tree (which contain
+information about autoloads, built-in packages and package prefixes)
+used to be generated by functions in autoloads.el. These are now
+generated by loaddefs-gen.el instead. This leads to functionally
+equivalent "loaddefs.el" files, but they do not use exactly the same
+syntax, so using 'M-x update-file-autoloads' no longer works. (This
+didn't work well in most files in the past, either, but it will now
+signal an error in any file.)
+
+In addition, files are scanned in a slightly different way.
+Previously, ';;;###' specs inside a top-level form (i.e., something
+like '(when ... ;;;### ...)' would be ignored. They are now parsed as
+usual.
+
+** Themes have special autoload cookies.
+All built-in themes are scraped for ';;;###theme-autoload' cookies
+that are loaded along with the regular auto-loaded code.
+
+** 'buffer-modified-p' has been extended.
+This function was previously documented to return only nil or t. This
+has been changed to nil/'autosaved'/non-nil. The new 'autosaved'
+value means that the buffer is modified, but that it hasn't been
+modified since the time of last auto-save.
+
+** 'with-silent-modifications' also restores buffer autosave status.
+'with-silent-modifications' is a macro meant to be used by the font
+locking machinery to allow applying text properties without changing
+the modification status of the buffer. However, it didn't restore the
+buffer autosave status, so applying font locking to a modified buffer
+that had already been auto-saved would trigger another auto-saving.
+This is no longer the case.
+
+** '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' face 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'.
+
+** 'make-process' has been extended to support ptys when ':stderr' is set.
+Previously, setting ':stderr' to a non-nil value would force the
+process's connection to use pipes. Now, Emacs will use a pty for
+stdin and stdout if requested no matter the value of ':stderr'.
+
+** 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
+needed.
+
+** Fonts
+
+*** Emacs now supports 'medium' fonts.
+Emacs previously didn't distinguish between the 'regular'/'normal'
+weight and the 'medium' weight, but it now also supports the (heavier)
+'medium' weight. However, this means that if you specify 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 by Help commands have changed.
+'help--describe-command', 'C-h b' and associated functions that output
+keymap descriptions have changed. In particular, prefix commands are
+not output at all, and instead of "??" for closures/functions, these
+functions output "[closure]"/"[lambda]". You can get back the old
+behavior of including prefix commands by customizing the new option
+'describe-bindings-show-prefix-commands' to a non-nil value.
+
+** 'downcase' details have changed slightly.
+In certain locales, changing the case of an ASCII-range character may
+turn it into a multibyte character, most notably with "I" in Turkish
+(the lowercase is "ı", 0x0131). Previously, 'downcase' on a unibyte
+string was buggy, and would mistakenly just return the lower byte of
+this, 0x31 (the digit "1"). 'downcase' on a unibyte string has now
+been changed to downcase such characters as if they were ASCII. To
+get proper locale-dependent downcasing, the string has to be converted
+to multibyte first. (This goes for the other case-changing functions,
+too.)
+
+** Functions in 'tramp-foreign-file-name-handler-alist' have changed.
+Functions to determine which Tramp file name handler to use are now
+passed a file name in dissected form (via 'tramp-dissect-file-name')
+instead of in string form.
+
+** 'def' indentation changes.
+In 'emacs-lisp-mode', forms with a symbol with a name that start with
+"def" have been automatically indented as if they were 'defun'-like
+forms, for instance:
+
+ (defzot 1
+ 2 3)
+
+This heuristic has now been removed, and all functions/macros that
+want to be indented this way have to be marked with
+
+ (declare (indent defun))
+
+or the like. If the function/macro definition itself can't be
+changed, the indentation can also be adjusted by saying something
+like:
+
+ (put 'defzot 'lisp-indent-function 'defun)
+
+** The 'inhibit-changing-match-data' variable is now obsolete.
+Instead, functions like 'string-match' and 'looking-at' now take an
+optional INHIBIT-MODIFY argument.
+
+** 'gnus-define-keys' is now obsolete.
+Use 'define-keymap' instead.
+
+** MozRepl has been removed from js.el.
+MozRepl was removed from Firefox in 2017, so this code doesn't work
+with recent versions of Firefox.
+
+** The function 'image-dired-get-exif-data' is now obsolete.
+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'.
+
+** 'compilation-last-buffer' is (finally) declared obsolete.
+It has been obsolete since Emacs 22.1, actually.
+
+** Calling 'lsh' now elicits a byte-compiler warning.
+'lsh' behaves in somewhat surprising and platform-dependent ways for
+negative arguments, and is generally slower than 'ash', which should be
+used instead. This warning can be suppressed by surrounding calls to
+'lsh' with the construct '(with-suppressed-warnings ((suspicious lsh)) ...)',
+but switching to 'ash' is generally much preferable.
+
+** Some functions and variables obsolete since Emacs 24 have been removed:
+'Buffer-menu-buffer+size-width', 'Electric-buffer-menu-mode',
+'Info-edit-map', 'allout-abbreviate-flattened-numbering',
+'allout-exposure-change-hook', 'allout-mode-deactivate-hook',
+'allout-structure-added-hook', 'allout-structure-deleted-hook',
+'allout-structure-shifted-hook', 'ansi-color-unfontify-region',
+'archive-extract-hooks', 'auth-source-forget-user-or-password',
+'auth-source-hide-passwords', 'auth-source-user-or-password',
+'automatic-hscrolling', 'automount-dir-prefix', 'bibtex-complete',
+'bibtex-entry-field-alist', 'buffer-has-markers-at',
+'buffer-substring-filters', 'byte-compile-disable-print-circle',
+'c-prepare-bug-report-hooks', 'cfengine-mode-abbrevs',
+'change-log-acknowledgement', 'chart-map',
+'checkdoc-comment-style-hooks', 'comint--unquote&expand-filename',
+'comint-dynamic-complete', 'comint-dynamic-complete-as-filename',
+'comint-dynamic-simple-complete', 'comint-unquote-filename',
+'command-history-map', 'compilation-parse-errors-function',
+'completion-annotate-function', 'condition-case-no-debug',
+'count-lines-region', 'crisp-mode-modeline-string',
+'custom-print-functions', 'cvs-string-prefix-p', 'data-debug-map',
+'deferred-action-function', 'deferred-action-list',
+'dired-pop-to-buffer', 'dired-shrink-to-fit',
+'dired-sort-set-modeline', 'dired-x-submit-report',
+'display-buffer-function',
+'ediff-choose-window-setup-function-automatically',
+'eieio-defgeneric', 'eieio-defmethod', 'emacs-lock-from-exiting',
+'erc-complete-word', 'erc-dcc-chat-filter-hook',
+'eshell-add-to-window-buffer-names', 'eshell-cmpl-suffix-list',
+'eshell-for', 'eshell-remove-from-window-buffer-names',
+'eshell-status-in-modeline', 'filesets-cache-fill-content-hooks',
+'font-list-limit', 'font-lock-maximum-size',
+'font-lock-reference-face', 'gnus-carpal',
+'gnus-debug-exclude-variables', 'gnus-debug-files',
+'gnus-local-domain', 'gnus-outgoing-message-group',
+'gnus-registry-user-format-function-M', 'gnus-secondary-servers',
+'gnus-subscribe-newsgroup-hooks', 'gud-inhibit-global-bindings',
+'hangul-input-method-inactivate', 'hfy-post-html-hooks',
+'image-extension-data', 'image-library-alist',
+'inactivate-current-input-method-function', 'inactivate-input-method',
+'inhibit-first-line-modes-regexps',
+'inhibit-first-line-modes-suffixes', 'input-method-inactivate-hook',
+'intdos', 'javascript-generic-mode', 'javascript-generic-mode-hook',
+'latex-string-prefix-p', 'macro-declaration-function' (function),
+'macro-declaration-function' (variable), 'mail-complete',
+'mail-complete-function', 'mail-mailer-swallows-blank-line',
+'mail-sent-via', 'make-register', 'makefile-complete',
+'menu-bar-kill-ring-save', 'meta-complete-symbol', 'meta-mode-map',
+'mh-kill-folder-suppress-prompt-hooks',
+'minibuffer-completing-symbol',
+'minibuffer-local-filename-must-match-map', 'mode25', 'mode4350',
+'mpc-string-prefix-p', 'msb-after-load-hooks',
+'nndiary-request-accept-article-hooks',
+'nndiary-request-create-group-hooks',
+'nndiary-request-update-info-hooks', 'nnimap-split-rule',
+'nntp-authinfo-file', 'ns-alternatives-map',
+'ns-store-cut-buffer-internal', 'package-menu-view-commentary',
+'pascal-last-completions', 'pascal-show-completions',
+'pascal-toggle-completions', 'pcomplete-arg-quote-list',
+'pcomplete-quote-argument', 'prolog-char-quote-workaround',
+'python-buffer', 'python-guess-indent', 'python-indent',
+'python-info-ppss-comment-or-string-p', 'python-info-ppss-context',
+'python-info-ppss-context-type', 'python-preoutput-result',
+'python-proc', 'python-send-receive', 'python-send-string',
+'python-use-skeletons', 'quail-inactivate', 'quail-inactivate-hook',
+'query-replace-interactive', 'rcirc-activity-hooks',
+'rcirc-print-hooks', 'rcirc-receive-message-hooks',
+'rcirc-sentinel-hooks', 'read-filename-at-point', 'redraw-modeline',
+'reftex-index-map', 'reftex-index-phrases-map',
+'reftex-select-bib-map', 'reftex-select-label-map', 'reftex-toc-map',
+'register-name-alist', 'register-value', 'report-emacs-bug-info',
+'report-emacs-bug-pretest-address',
+'rmail-default-dont-reply-to-names', 'rmail-dont-reply-to',
+'rmail-dont-reply-to-names', 'robin-inactivate',
+'robin-inactivate-hook', 'rst-block-face', 'rst-comment-face',
+'rst-definition-face', 'rst-directive-face', 'rst-emphasis1-face',
+'rst-emphasis2-face', 'rst-external-face', 'rst-literal-face',
+'rst-reference-face', 'semantic-change-hooks',
+'semantic-edits-delete-change-hooks',
+'semantic-edits-new-change-hooks',
+'semantic-edits-reparse-change-hooks', 'semantic-grammar-map',
+'semantic-grammar-syntax-table', 'semantic-lex-reset-hooks',
+'semanticdb-elisp-sym-function-arglist',
+'semanticdb-save-database-hooks', 'set-face-underline-p',
+'set-register-value', 'sh-maybe-here-document', 'speedbar-key-map',
+'speedbar-syntax-table', 'starttls-any-program-available',
+'strokes-modeline-string', 'strokes-report-bug',
+'term-default-bg-color', 'term-default-fg-color',
+'tex-string-prefix-p', 'timeclock-modeline-display',
+'timeclock-modeline-display', 'timeclock-update-modeline',
+'toggle-emacs-lock', 'tooltip-use-echo-area', 'turn-on-cwarn-mode',
+'turn-on-iimage-mode', 'ucs-input-inactivate', 'ucs-insert',
+'url-recreate-url-attributes', 'user-variable-p',
+'vc-string-prefix-p', 'vc-toggle-read-only', 'view-return-to-alist',
+'view-return-to-alist-update', 'w32-default-color-map' (function),
+'which-func-mode' (function), 'window-system-version',
+'winner-mode-leave-hook', 'x-cut-buffer-or-selection-value'.
+
+** Some functions and variables obsolete since Emacs 23 have been removed:
+'find-emacs-lisp-shadows', 'newsticker-cache-filename',
+'process-filter-multibyte-p', 'redisplay-end-trigger-functions',
+'set-process-filter-multibyte', 'set-window-redisplay-end-trigger',
+'unify-8859-on-decoding-mode', 'unify-8859-on-encoding-mode',
+'vc-arch-command', 'window-redisplay-end-trigger', 'x-selection'.
+
+** Some functions and variables obsolete since Emacs 21 or 22 have been removed:
+'c-toggle-auto-state', 'find-file-not-found-hooks',
+'ls-lisp-dired-ignore-case', 'query-replace-regexp-eval'.
+
+** New generic function 'function-documentation'.
+It 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',
+'base64-encode-region' and 'base64url-encode-region' no longer accept
+characters in the range U+0080..U+00FF as substitutes for single bytes
+in the range 128..255, but signal an error for all multibyte characters.
+The input must be unibyte encoded text.
+
+** The 'clone-indirect-buffer-hook' is now run by 'make-indirect-buffer'.
+It was previously only run by 'clone-indirect-buffer' and
+'clone-indirect-buffer-other-window'. Since 'make-indirect-buffer' is
+called by both of these, the hook is now run by all 3 of these
+functions.
+
+** '?\' at the end of a line now signals an error.
+Previously, it produced a nonsense value, -1, that was never intended.
+
+** Some libraries obsolete since Emacs 24.1 and 24.3 have been removed:
+abbrevlist.el, assoc.el, complete.el, cust-print.el,
+erc-hecomplete.el, mailpost.el, mouse-sel.el, old-emacs-lock.el,
+patcomp.el, pc-mode.el, pc-select.el, s-region.el, and sregex.el.
+
+** Many seldom-used generalized variables have been made obsolete.
+Emacs has a number of rather obscure generalized variables defined,
+that, for instance, allowed you to say things like:
+
+ (setf (point-min) 4)
+
+These never caught on and have been made obsolete. The form above,
+for instance, is the same as saying
+
+ (narrow-to-region 4 (point-max))
+
+The following generalized variables have been made obsolete:
+'buffer-file-name', 'buffer-local-value', 'buffer-modified-p',
+'buffer-name', 'buffer-string', 'buffer-substring', 'current-buffer',
+'current-column', 'current-global-map', 'current-input-mode',
+'current-local-map', 'current-window-configuration',
+'default-file-modes', 'documentation-property', 'eq', 'frame-height',
+'frame-width', 'frame-visible-p', 'global-key-binding',
+'local-key-binding', 'mark', 'mark-marker', 'marker-position',
+'mouse-position', 'point', 'point-marker', 'point-max', 'point-min',
+'read-mouse-position', 'screen-height', 'screen-width',
+'selected-frame', 'selected-screen', 'selected-window',
+'standard-case-table', 'syntax-table', 'visited-file-modtime',
+'window-height', 'window-width', and 'x-get-secondary-selection'.
+
+** The 'dotimes' loop variable can no longer be manipulated in the loop body.
+Previously, the 'dotimes' loop counter could be modified inside the
+loop body, but only in code using dynamic binding. Now the behavior
+is the same as when using lexical binding: changes to the loop
+variable have no effect on subsequent iterations. That is,
+
+ (dotimes (i 10)
+ (print i)
+ (setq i (+ i 6)))
+
+now always prints the numbers 0 .. 9.
+
+
+* Lisp Changes in Emacs 29.1
+
+** Interpreted closures are "safe for space".
+As was already the case for byte-compiled closures, instead of capturing
+the whole current lexical environment, interpreted closures now only
+capture the part of the environment that they need.
+The previous behavior could occasionally lead to memory leaks or
+to problems where a printed closure would not be 'read'able because
+of an un'read'able value in an unrelated lexical variable.
+
+** New accessor function 'file-attribute-file-identifier'.
+It returns the list of the inode number and device identifier
+retrieved by 'file-attributes'. This value can be used to identify a
+file uniquely. The device identifier can be a single number or (for
+remote files) a cons of 2 numbers.
+
+** New macro 'while-let'.
+This is like 'when-let', but repeats until a binding form is nil.
+
+** New function 'make-obsolete-generalized-variable'.
+This can be used to mark setters used by 'setf' as obsolete, and the
+byte-compiler will then warn about using them.
+
+** New functions 'pos-eol' and 'pos-bol'.
+These are like 'line-end-position' and 'line-beginning-position'
+(respectively), but ignore fields (and are more efficient).
+
+** New function 'compiled-function-p'.
+This returns non-nil if its argument is either a built-in, or a
+byte-compiled, or a natively-compiled function object, or a function
+loaded from a dynamic module.
+
+** 'deactivate-mark' can have new value 'dont-save'.
+This value means that Emacs should deactivate the mark as usual, but
+without setting the primary selection, if 'select-active-regions' is
+enabled.
+
+** New 'declare' form 'interactive-args'.
+This can be used to specify what forms to put into 'command-history'
+when executing commands interactively.
+
+** The FORM argument of 'time-convert' is mandatory.
+'time-convert' can still be called without it, as before, but the
+compiler now emits a warning about this deprecated usage.
+
+** Emacs now supports user-customizable and themable icons.
+These can be used for buttons in buffers and the like. See the
+"(elisp) Icons" and "(emacs) Icons" nodes in the manuals for details.
+
+** New arguments MESSAGE and TIMEOUT of 'set-transient-map'.
+MESSAGE specifies a message to display after activating the transient
+map, including a special formatting spec to list available keys.
+TIMEOUT is the idle time after which to deactivate the transient map.
+The default timeout value can be defined by the new variable
+'set-transient-map-timeout'.
+
+** New forms 'with-restriction' and 'without-restriction'.
+These forms can be used as enhanced alternatives to the
+'save-restriction' form combined with, respectively,
+'narrow-to-region' and 'widen'. They also accept an optional label
+argument, with which labeled narrowings can be created and lifted.
+See the "(elisp) Narrowing" node for details.
+
+** Connection Local Variables
+
+*** 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.
+
+*** New function 'connection-local-update-profile-variables'.
+This function allows to modify the settings of an existing
+connection-local profile.
+
+*** New macro 'with-connection-local-application-variables'.
+This macro works like 'with-connection-local-variables', but it allows
+using another application instead of 'tramp'. This is useful when
+running code in a buffer where Tramp has already set some
+connection-local variables.
+
+*** New macro 'setq-connection-local'.
+This allows dynamically setting variable values for a particular
+connection within the body of 'with-connection-local-{application-}variables'.
+See the "(elisp) Connection Local Variables" node in the Lisp
+Reference manual for more information.
+
+** 'plist-get', 'plist-put' and 'plist-member' are no longer limited to 'eq'.
+These function now take an optional comparison PREDICATE argument.
+
+** 'read-multiple-choice' can now use long-form answers.
+
+** 'M-s c' in 'read-regexp' now toggles case folding.
+
+** 'completing-read' now allows a function as its REQUIRE-MATCH argument.
+This function is called to see whether what the user has typed is a
+match. This is also available from functions that call
+'completing-read', like 'read-file-name'.
+
+** 'posn-col-row' can now give position data based on windows.
+Previously, it reported data only based on the frame.
+
+** 'file-expand-wildcards' can now also take a regexp as PATTERN argument.
+
+** vc-mtn (the VC backend for Monotone) has been made obsolete.
+
+** 'gui-set-selection' can specify different values for different data types.
+If DATA is a string, then its text properties are searched for values
+for each specific data type while the selection is being converted.
+
+** New eldoc function 'elisp-eldoc-var-docstring-with-value'.
+This function includes the current value of the variable in eldoc display
+and can be used as a more detailed alternative to 'elisp-eldoc-var-docstring'.
+
+** 'save-some-buffers' can now be extended to save other things.
+Traditionally, 'save-some-buffers' saved buffers, and also saved
+abbrevs. This has been generalized via the
+'save-some-buffers-functions' variable, and packages can now register
+things to be saved.
+
+** New function 'string-equal-ignore-case'.
+This compares strings ignoring case differences.
+
+** 'symbol-file' can now report natively-compiled ".eln" files.
+If Emacs was built with native-compilation enabled, Lisp programs can
+now call 'symbol-file' with the new optional 3rd argument non-nil to
+request the name of the ".eln" file which defined a given symbol.
+
+** New macro 'with-memoization' provides a very primitive form of memoization.
+
+** 'max-char' can now report the maximum codepoint according to Unicode.
+When called with a new optional argument UNICODE non-nil, 'max-char'
+will now report the maximum valid codepoint defined by the Unicode
+Standard.
+
+** Seq
+
+*** New function 'seq-split'.
+This returns a list of sub-sequences of the specified sequence.
+
+*** New function 'seq-remove-at-position'.
+This function returns a copy of the specified sequence with the
+element at a given (zero-based) index removed.
+
+*** New function 'seq-positions'.
+This returns a list of the (zero-based) indices of elements matching a
+given predicate in the specified sequence.
+
+*** New function 'seq-keep'.
+This is like 'seq-map', but removes all nil results from the returned
+list.
+
+** Themes
+
+*** New hooks 'enable-theme-functions' and 'disable-theme-functions'.
+These are run after enabling and disabling a theme, respectively.
+
+*** Themes can now be made obsolete.
+Using 'make-obsolete' on a theme is now supported. This will make
+'load-theme' issue a warning when loading the theme.
+
+** New hook 'display-monitors-changed-functions'.
+It is called whenever the configuration of different monitors on a
+display changes.
+
+** 'prin1' and 'prin1-to-string' now take an optional OVERRIDES argument.
+This argument can be used to override values of print-related settings.
+
+** New minor mode 'header-line-indent-mode'.
+This is meant to be used by Lisp programs that show a header line
+which should be kept aligned with the buffer contents when the user
+switches 'display-line-numbers-mode' on or off, and when the width of
+line-number display changes. See the "(elisp) Header Lines" node in
+the Emacs Lisp Reference manual for more information.
+
+** New global minor mode 'lost-selection-mode'.
+This global minor mode makes Emacs deactivate the mark in all buffers
+when the primary selection is obtained by another program.
+
+** On X, Emacs will try to preserve selection ownership when a frame is deleted.
+This means that if you make Emacs the owner of a selection, such as by
+selecting some text into the clipboard or primary selection, and then
+delete the current frame, you will still be able to insert the
+contents of that selection into other programs as long as another
+frame is open on the same display. This behavior can be disabled by
+setting the user option 'x-auto-preserve-selections' to nil.
+
+** New predicate 'char-uppercase-p'.
+This returns non-nil if its argument its an uppercase character.
+
+** Byte Compilation
+
+*** Byte compilation will now warn about some quoting mistakes in docstrings.
+When writing code snippets that contains the "'" character (APOSTROPHE),
+that quote character has to be escaped to avoid Emacs displaying it as
+"’" (LEFT SINGLE QUOTATION MARK), which would make code examples like
+
+ (setq foo '(1 2 3))
+
+invalid. Emacs will now warn during byte compilation if it sees
+something like that, and also warn about when using RIGHT/LEFT SINGLE
+QUOTATION MARK directly. In both these cases, if these characters
+should really be present in the docstring, they should be quoted with
+"\=".
+
+*** Byte compilation will now warn about some malformed 'defcustom' types.
+It is very common to write 'defcustom' types on the form:
+
+ :type '(choice (const :tag "foo" 'bar))
+
+I.e., double-quoting the 'bar', which is almost never the correct
+value. The byte compiler will now issue a warning if it encounters
+these forms.
+
+** 'restore-buffer-modified-p' can now alter buffer auto-save state.
+With a FLAG value of 'autosaved', it will mark the buffer as having
+been auto-saved since the time of last modification.
+
+** 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 variable 'x-show-tooltip-timeout' allows the user to alter
+this for packages that don't use 'tooltip-show', but instead call the
+lower level function directly.
+
+** 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 up a new buffer where you can edit the string,
+and the provided 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 variables 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 display of lines that don't end in a newline 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 argument 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.
+
+** Variable 'track-mouse' can have 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 functions for dragging items from Emacs to other programs.
+The new functions 'x-begin-drag', 'dnd-begin-file-drag',
+'dnd-begin-drag-files', and 'dnd-direct-save' allow dragging contents
+(such as files and text) from Emacs to other programs.
+
+** New function 'ietf-drums-parse-date-string'.
+This function parses RFC5322 (and RFC822) date strings, and should be
+used instead of 'parse-time-string' when parsing data that's standards
+compliant.
+
+** New macro 'setopt'.
+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'.
+This is meant to be used from ':eval' mode line constructs to create
+different mode line looks for selected and unselected windows.
+
+** New variable 'messages-buffer-name'.
+This variable (defaulting to "*Messages*") allows packages to override
+where messages are logged.
+
+** New function 'readablep'.
+This function says whether an object can be written out and then
+read back by the Emacs Lisp reader.
+
+** New variable 'print-unreadable-function'.
+This variable allows changing how Emacs prints unreadable objects.
+
+** The user option 'polling-period' now accepts floating point values.
+This means Emacs can now poll for input during Lisp execution more
+frequently than once in a second.
+
+** New function 'bidi-string-strip-control-characters'.
+This utility function is meant for displaying strings when it is
+essential that there's no bidirectional context. It removes all the
+bidirectional formatting control characters (such as RLM, LRO, PDF,
+etc.) from its argument string. The characters it removes are listed
+in the value of 'bidi-control-characters'.
+
+** The Gnus range functions have been moved to a new library, range.el.
+All the old names have been made obsolete.
+
+** New function 'function-alias-p'.
+This predicate says whether an object is a function alias, and if it
+is, the alias chain is returned.
+
+** New variable 'lisp-directory' holds the directory of Emacs's own Lisp files.
+
+** New facility for handling session state: 'multisession-value'.
+This can be used as a convenient way to store (simple) application
+state, and the command 'list-multisession-values' allows users to list
+(and edit) this data.
+
+** New function 'get-display-property'.
+This is like 'get-text-property', but works on the 'display' text
+property.
+
+** New function 'add-display-text-property'.
+This is like 'put-text-property', but works on the 'display' text
+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
+wheel on some mice, or when the user's finger moves off the touchpad.
+
+** New event type 'pinch'.
+This event is sent when a user performs a pinch gesture on a touchpad,
+which is comprised of placing two fingers on the touchpad and moving
+them towards or away from each other.
+
+** New hook 'x-pre-popup-menu-hook'.
+This hook is run before 'x-popup-menu' is about to display a
+deck-of-cards menu on screen.
+
+** New hook 'post-select-region-hook'.
+This hook is run immediately after 'select-active-regions'. It causes
+the region to be set as the primary selection.
+
+** 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 combination with a condition
+like '(and "\\`\\*.+\\*\\'" (major-mode . special-mode))'.
+
+** New function 'match-buffers'.
+It uses 'buffer-match-p' to gather a list of buffers that match a
+condition.
+
+** New optional arguments TEXT-FACE and DEFAULT-FACE for 'tooltip-show'.
+They allow changing the faces used for the tooltip text and frame
+colors of the resulting tooltip frame from the default 'tooltip' face.
+
+** Text Security and Suspiciousness
+
+*** New library textsec.el.
+This library contains a number of checks for whether a string is
+"suspicious". This usually means that the string contains characters
+that have glyphs that can be confused with other, more commonly used
+glyphs, or contains bidirectional (or other) formatting characters
+that may be used to confuse a user.
+
+*** New user option 'textsec-check'.
+If non-nil (which is the default), Emacs packages that are vulnerable
+to attackers trying to confuse the users will use the textsec library
+to mark suspicious text. For instance shr/eww will mark suspicious
+URLs and links, Gnus will mark suspicious From addresses, and
+Message mode will query the user if the user is sending mail to a
+suspicious address. If this variable is nil, these checks are
+disabled.
+
+*** New function 'textsec-suspicious-p'.
+This is the main function Emacs applications should be using to check
+whether a string is suspicious. It heeds the 'textsec-check' user
+option.
+
+** Keymaps and Key Definitions
+
+*** 'where-is-internal' can now filter events marked as non key events.
+If a command maps to a key binding like '[some-event]', and 'some-event'
+has a symbol plist containing a non-nil 'non-key-event' property, then
+that binding is ignored by 'where-is-internal'.
+
+*** New functions for defining and manipulating keystrokes.
+These all take the syntax defined by 'key-valid-p', which is basically
+the same syntax as the one accepted by the 'kbd' macro. None of the
+older functions have been deprecated or altered, but they are now
+de-emphasized in the documentation, and we encourage Lisp programs to
+switch to these new functions.
+
+*** Use 'keymap-set' instead of 'define-key'.
+
+*** Use 'keymap-global-set' instead of 'global-set-key'.
+
+*** Use 'keymap-local-set' instead of 'local-set-key'.
+
+*** Use 'keymap-global-unset' instead of 'global-unset-key'.
+
+*** Use 'keymap-local-unset' instead of 'local-unset-key'.
+
+*** Use 'keymap-substitute' instead of 'substitute-key-definition'.
+
+*** Use 'keymap-set-after' instead of 'define-key-after'.
+
+*** Use 'keymap-lookup' instead of 'lookup-key' and 'key-binding'.
+
+*** Use 'keymap-local-lookup' instead of 'local-key-binding'.
+
+*** Use 'keymap-global-lookup' instead of 'global-key-binding'.
+
+*** 'define-key' now takes an optional REMOVE argument.
+If non-nil, remove the definition from the keymap. This is subtly
+different from setting a definition to nil: when the keymap has a
+parent such a definition will shadow the parent's definition.
+
+*** 'read-multiple-choice' now takes an optional SHOW-HELP argument.
+If non-nil, show the help buffer immediately, before any user input.
+
+*** New function 'key-valid-p'.
+The 'kbd' function is quite permissive, and will try to return
+something usable even if the syntax of the argument isn't completely
+correct. The 'key-valid-p' predicate does a stricter check of the
+syntax.
+
+*** New function 'key-parse'.
+This is like 'kbd', but only returns vectors instead of a mix of
+vectors and strings.
+
+*** New ':type' for 'defcustom' for keys.
+The new 'key' type can be used for options that should be a valid key
+according to 'key-valid-p'. The type 'key-sequence' is now obsolete.
+
+** New function 'define-keymap'.
+This function allows defining a number of keystrokes with one form.
+
+** New macro 'defvar-keymap'.
+This macro allows defining keymap variables more conveniently.
+
+** 'defvar-keymap' can specify 'repeat-mode' behavior for the keymap.
+Use ':repeat t' to have all bindings be repeatable or for more
+advanced usage:
+
+ :repeat (:enter (commands ...) :exit (commands ...))
+
+** 'kbd' can now be used in built-in, preloaded libraries.
+It no longer depends on edmacro.el and cl-lib.el.
+
+** New substitution in docstrings and 'substitute-command-keys'.
+Use \\`KEYSEQ' to insert a literal key sequence "KEYSEQ" (for example
+\\`C-k') in a docstring or when calling 'substitute-command-keys',
+which will use the same face as a command substitution. This should
+be used only when a key sequence has no corresponding command, for
+example when it is read directly with 'read-key-sequence'. It must be
+a valid key sequence according to 'key-valid-p'.
+
+** 'lookup-key' is more permissive when searching for extended menu items.
+In Emacs 28.1, the behavior of 'lookup-key' was changed: 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]'.
+
+This has been extended, so that when looking for a menu item with a
+symbol containing spaces, as in '[menu-bar Foo\ Bar]', first look for
+an exact match, then the lowercased '[menu-bar foo\ bar]' and finally
+'[menu-bar foo-bar]'. This further improves backwards-compatibility
+when converting menus to use 'easy-menu-define'.
+
+** New function 'file-name-split'.
+This returns a list of all the components of a file name.
+
+** New function 'file-name-parent-directory'.
+This returns the parent directory of a file name.
+
+** New macro 'with-undo-amalgamate'.
+It records a particular sequence of operations as a single undo step.
+
+** New command 'yank-media'.
+This command supports yanking non-plain-text media like images and
+HTML from other applications into Emacs. It is only supported in
+modes that have registered support for it, and only on capable
+platforms.
+
+** New command 'yank-media-types'.
+This command lets you examine all data in the current selection and
+the clipboard, and insert it into the buffer.
+
+** New variable 'yank-transform-functions'.
+This variable allows the user to alter the string to be inserted.
+
+** New command 'yank-in-context'.
+This command tries to preserve string/comment syntax when yanking.
+
+** 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
+instance) when covering huge amounts of data (that has no meaningful
+searchable data, like image data) with a 'display' text property.
+
+** 'insert-image' now takes an INHIBIT-ISEARCH optional argument.
+It marks the image with the 'inhibit-isearch' text property, which
+inhibits 'isearch' matching the STRING argument.
+
+** 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.
+The new variable 'query-replace-read-from-default' can be set to a
+function that returns the default value of FROM when 'query-replace'
+prompts for a string to be replaced. An example of such a function is
+'find-tag-default'.
+
+The new variable 'query-replace-read-from-regexp-default' can be set
+to a function (such as 'find-tag-default-as-regexp') that returns the
+default value of FROM when 'query-replace-regexp' prompts for a regexp
+whose matches are to be replaced. If these variables are nil (which
+is the default), 'query-replace' and 'query-replace-regexp' take the
+default value from the previous FROM-TO pair.
+
+** Lisp pretty-printer ('pp')
+
+*** New function 'pp-emacs-lisp-code'.
+'pp' formats general Lisp sexps. This function does much the same,
+but applies formatting rules appropriate for Emacs Lisp code. Note
+that this could currently be quite slow, and is thus appropriate only
+for relatively small code fragments.
+
+*** New user option 'pp-use-max-width'.
+If non-nil, 'pp' and all 'pp-*' commands that format the results, will
+attempt to limit the line length when formatting long lists and
+vectors. This uses 'pp-emacs-lisp-code', and thus could be slow for
+large lists.
+
+** New function 'file-has-changed-p'.
+This convenience function is useful when writing code that parses
+files at run-time, and allows Lisp programs to re-parse files only
+when they have changed.
+
+** 'abbreviate-file-name' now respects magic file name handlers.
+
+** New function 'font-has-char-p'.
+This can be used to check whether a specific font has a glyph for a
+character.
+
+** 'window-text-pixel-size' now accepts a new argument IGNORE-LINE-AT-END.
+This controls whether or not the last screen line of the text being
+measured will be counted for the purpose of calculating the text
+dimensions.
+
+** 'window-text-pixel-size' understands a new meaning of FROM.
+Specifying a cons as the FROM argument allows to start measuring text
+from a specified amount of pixels above or below a position.
+
+** 'window-body-width' and 'window-body-height' can use remapped faces.
+Specifying 'remap' as the PIXELWISE argument now checks if the default
+face was remapped, and if so, uses the remapped face to determine the
+character width/height.
+
+** 'set-window-vscroll' now accepts a new argument PRESERVE-VSCROLL-P.
+This means the vscroll will not be reset when set on a window that is
+"frozen" due to a mini-window being resized.
+
+** XDG Support
+
+*** New function 'xdg-state-home'.
+It returns the new 'XDG_STATE_HOME' environment variable. It should
+point to a file name that "contains state data that should persist
+between (application) restarts, but that is not important or portable
+enough to the user that it should be stored in $XDG_DATA_HOME".
+(This variable was introduced in the XDG Base Directory Specification
+version 0.8 released on May 8, 2021.)
+
+*** New function 'xdg-current-desktop'.
+It returns a list of strings, corresponding to the colon-separated
+list of names in the 'XDG_CURRENT_DESKTOP' environment variable, which
+identify the current desktop environment.
+(This variable was introduced in XDG Desktop Entry Specification
+version 1.2.)
+
+*** New function 'xdg-session-type'.
+It returns the 'XDG_SESSION_TYPE' environment variable. (This is not
+part of any official standard; see the man page pam_systemd(8) for
+more information.)
+
+** New macro 'with-delayed-message'.
+This macro is like 'progn', but will output the specified message if
+the body takes longer to execute than the specified timeout.
+
+** New function 'funcall-with-delayed-message'.
+This function is like 'funcall', but will output the specified message
+if the function takes longer to execute than the specified timeout.
+
+** Locale
+
+*** New variable 'current-locale-environment'.
+This holds the value of the previous call to 'set-locale-environment'.
+
+*** New macro 'with-locale-environment'.
+This macro can be used to change the locale temporarily while
+executing code.
+
+** Table
+
+*** New user option 'table-latex-environment'.
+This allows switching between "table" and "tabular".
+
+** Tabulated List Mode
+
+*** A column can now be set to an image descriptor.
+The 'tabulated-list-entries' variable now supports using an image
+descriptor, which means to insert an image in that column instead of
+text. See the documentation string of that variable for details.
+
+** ':keys' in 'menu-item' can now be a function.
+If so, it is called whenever the menu is computed, and can be used to
+calculate the keys dynamically.
+
+** New major mode 'clean-mode'.
+This is a new major mode meant for debugging. It kills absolutely all
+local variables and removes overlays and text properties.
+
+** 'kill-all-local-variables' can now kill all local variables.
+If given the new optional KILL-PERMANENT argument, it also kills
+permanent local variables.
+
+** Third 'mapconcat' argument SEPARATOR is now optional.
+An explicit nil always meant the empty string, now it can be left out.
+
+** New function 'image-at-point-p'.
+This function returns t if point is on a valid image, and nil
+otherwise.
+
+** New function 'buffer-text-pixel-size'.
+This is similar to 'window-text-pixel-size', but can be used when the
+buffer isn't displayed.
+
+** New function 'string-pixel-width'.
+This returns the width of a string in pixels. This can be useful when
+dealing with variable pitch fonts and glyphs that have widths that
+aren't integer multiples of the default font.
+
+** New function 'string-glyph-split'.
+This function splits a string into a list of strings representing
+separate glyphs. This takes into account combining characters and
+grapheme clusters, by treating each sequence of characters composed on
+display as a single unit.
+
+** Xwidget
+
+*** The function 'make-xwidget' now accepts an optional RELATED argument.
+This argument is used as another widget for the newly created WebKit
+widget to share settings and subprocesses with. It must be another
+WebKit widget.
+
+*** New function 'xwidget-perform-lispy-event'.
+This function allows you to send events to xwidgets. Usually, some
+equivalent of the event will be sent, but there is no guarantee of
+what the widget will actually receive.
+
+On GTK+, only key and function key events are implemented.
+
+*** New function 'xwidget-webkit-load-html'.
+This function is used to load HTML text into WebKit xwidgets
+directly, in contrast to creating a temporary file to hold the
+markup, and passing the URI of the file as an argument to
+'xwidget-webkit-goto-uri'.
+
+*** New functions for performing searches on WebKit xwidgets.
+Some new functions, such as 'xwidget-webkit-search', have been added
+for performing searches on WebKit xwidgets.
+
+*** New function 'xwidget-webkit-back-forward-list'.
+This function returns the history of page-loads in a WebKit xwidget.
+
+*** New function 'xwidget-webkit-estimated-load-progress'.
+This function returns the estimated progress of page loading in a
+WebKit xwidget.
+
+*** New function 'xwidget-webkit-stop-loading'.
+This function terminates all data transfer during page loads in a
+WebKit xwidget.
+
+*** 'load-changed' xwidget events are now more detailed.
+In particular, they can now have different arguments based on the
+state of the WebKit widget. 'load-finished' is sent when a load has
+completed, 'load-started' when a load first starts, 'load-redirected'
+after a redirect, and 'load-committed' when the WebKit widget first
+commits to the load.
+
+*** New event type 'xwidget-display-event'.
+These events are sent whenever an xwidget requests that Emacs displays
+another xwidget. The only arguments to this event are the xwidget
+that should be displayed, and the xwidget that asked to display it.
+
+*** New function 'xwidget-webkit-set-cookie-storage-file'.
+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.
+
+** Timestamps like '(1 . 1000)' now work without warnings being generated.
+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 accepts arguments that lack month, day, or time.
+The function now assumes the earliest possible 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
+'touchscreen-end' have been added to take better advantage of
+touch-capable display panels.
+
+** New error symbol 'permission-denied'.
+This is a subcategory of 'file-error', and is signaled when some file
+operation fails because the OS doesn't allow Emacs to access a file or
+a directory.
+
+** The ':underline' face attribute now accepts a new property.
+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.
+
+** New hook 'save-place-after-find-file-hook'.
+This is called at the end of 'save-place-find-file-hook'.
+
+** '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 argument POSIX.
+This is useful when quoting shell arguments for a remote shell
+invocation. Such shells are POSIX conformant by default.
+
+** 'make-process' can set connection type independently for input and output.
+When calling 'make-process', communication via pty can be enabled
+selectively for just input or output by passing a cons cell for
+':connection-type', e.g. '(pipe . pty)'. When examining a process
+later, you can determine whether a particular stream for a process
+uses a pty by passing one of 'stdin', 'stdout', or 'stderr' as the
+second argument to 'process-tty-name'.
+
+** '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 'internal-default-signal-process'.
+
+** Some system information functions honor remote systems now.
+'list-system-processes' returns remote process IDs.
+'memory-info' returns memory information of remote systems.
+'process-attributes' expects a remote process ID.
+This happens only when the current buffer's 'default-directory' is
+remote. In order to preserve the old behavior, bind
+'default-directory' to a local directory, like
+
+ (let ((default-directory temporary-file-directory))
+ (list-system-processes))
+
+** New functions 'take' and 'ntake'.
+'(take N LIST)' returns the first N elements of LIST; 'ntake' does
+the same but works by modifying LIST destructively.
+
+** 'string-split' is now an alias for 'split-string'.
+
+** 'format-spec' now accepts functions in the replacement.
+The function is called only when used in the format string. This is
+useful to avoid side-effects such as prompting, when the value is not
+actually being used for anything.
+
+** The variable 'max-specpdl-size' has been made obsolete.
+Now 'max-lisp-eval-depth' alone is used for limiting Lisp recursion
+and stack usage. 'max-specpdl-size' is still present as a plain
+variable for compatibility but its limiting powers have been taken away.
+
+** New function 'external-completion-table'.
+This function returns a completion table designed to ease
+communication between Emacs's completion facilities and external tools
+offering completion services, particularly tools whose full working
+set is too big to transfer to Emacs every time a completion is
+needed. The table uses new 'external' completion style exclusively
+and cannot work with regular styles such as 'basic' or 'flex'.
+
+** Magic file name handlers for 'make-directory-internal' are no longer needed.
+Instead, Emacs uses the already-existing 'make-directory' handlers.
+
+** '(make-directory DIR t)' returns non-nil if DIR already exists.
+This can let a caller know whether it created DIR. Formerly,
+'make-directory's return value was unspecified.
+
+
+* 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
+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.
+
+*** GUI Yes/No dialogs now include a "Cancel" button.
+The "Cancel" button is in addition to "Yes" and "No", and is intended
+to allow users to quit the dialog, as an equivalent of 'C-g' when Emacs
+asks a yes/no question via the echo area. This is controlled by the
+new variable 'w32-yes-no-dialog-show-cancel', by default t. Set it to
+nil to get back the old behavior of showing a modal dialog with only
+two buttons: "Yes" and "No".
+
+** Cygwin
+
+*** 'process-attributes' is now implemented.
+
+** macOS
+
+*** The 'ns-popup-font-panel' command has been removed.
+Use the general command 'M-x menu-set-font' instead.
+
+
+----------------------------------------------------------------------
+This file is part of GNU Emacs.
+
+GNU Emacs is free software: you can redistribute it and/or modify
+it under the terms of the GNU General Public License as published by
+the Free Software Foundation, either version 3 of the License, or
+(at your option) any later version.
+
+GNU Emacs is distributed in the hope that it will be useful,
+but WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+GNU General Public License for more details.
+
+You should have received a copy of the GNU General Public License
+along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>.
+
+
+Local variables:
+coding: utf-8
+mode: outline
+mode: emacs-news
+paragraph-separate: "[ ]"
+end:
diff --git a/etc/PROBLEMS b/etc/PROBLEMS
index b4df40f5d8e..19456640299 100644
--- a/etc/PROBLEMS
+++ b/etc/PROBLEMS
@@ -872,7 +872,7 @@ On many systems, it is possible to set LD_LIBRARY_PATH in your
environment to specify additional directories where shared libraries
can be found.
-Other systems allow to set LD_RUN_PATH in a similar way, but before
+Other systems allow setting LD_RUN_PATH in a similar way, but before
Emacs is linked. With LD_RUN_PATH set, the linker will include a
specified run-time search path in the executable.
@@ -1289,6 +1289,20 @@ you should use an Emacs input method instead.
* X runtime problems
+** X security problems
+
+*** Emacs faces trouble when running as an untrusted client.
+
+When Emacs is running as an untrusted client under X servers with the
+Security extension, it is unable to use some window manager features
+but reports them to the window manager anyway. This can lead to
+constant prompting by the window manager about Emacs being
+unresponsive. To resolve the problem, place:
+
+ (setq x-detect-server-trust t)
+
+in your early-init.el.
+
** X keyboard problems
*** `x-focus-frame' fails to activate the frame.
@@ -1772,8 +1786,8 @@ which can be carried out at the same time:
7) If selecting text with the mouse is slow, the main culprit is
likely `select-active-regions', coupled with a program monitoring
- the clipboard on the X server you are connected to. Try turning
- that off.
+ the clipboard or primary selection on the X server you are
+ connected to. Try turning that off.
However, over networks with moderate to high latency, with no
clipboard monitor running, the bottleneck is likely to be
@@ -1783,6 +1797,12 @@ which can be carried out at the same time:
cause Emacs features that relies on accurate mouse position
reporting to stop working reliably.
+8) If creating or resizing frames is slow, turn off
+ `frame-resize-pixelwise' (this will not take effect until you
+ create a new frame); then, enable `x-lax-frame-positioning'. This
+ means frame placement will be less accurate, but makes frame
+ creation, movement, and resize visibly faster.
+
*** Emacs gives the error, Couldn't find per display information.
This can result if the X server runs out of memory because Emacs uses
@@ -2566,7 +2586,7 @@ keyboard; printing that file on a PostScript printer will show what
keys can serve as Meta.
The 'xkeycaps' also shows a visual representation of the current
-keyboard settings. It also allows to modify them.
+keyboard settings. It also allows modifying them.
*** GNU/Linux: slow startup on Linux-based GNU systems.
@@ -2820,7 +2840,7 @@ one, you could use the following workarounds:
directory to that new home directory.
. Move all the *.eln files from ~/.emacs.d/eln-cache to a directory
out of the C:\Users tree, and customize Emacs to use that
- directory for *.eln files. This requires to call the function
+ directory for *.eln files. This requires calling the function
startup-redirect-eln-cache in your init file, to force Emacs to
write *.eln files compiled at run time to that directory.
. Delete all *.eln files in your ~/.emacs.d/eln-cache directory, and
@@ -3406,6 +3426,133 @@ Compose key to stop working.
On X Windows, users should not use Emacs configured with PGTK, since
this and many other problems do not exist on the regular X builds.
+* Runtime problems specific to Android
+
+** Text displayed in the default monospace font looks horrible.
+
+TrueType fonts incorporate instruction code executed by the font
+scaler (the component responsible for transforming outlines into
+bitmap images capable of being displayed onscreen) to align features
+of each glyph to pixel boundaries while maintaining their shape, in
+order to alleviate visual imperfections produced by scaling. The
+substandard instruction code provided by the Android "Droid Sans Mono"
+font misplaces features of glyphs containing, as components, "E" and
+"F", between PPEM sizes of 16 and 24, resulting in noticeable
+whitespace inconsistencies with other glyphs. Furthermore, the
+vertical stem in the glyph "T" is positioned too far to the left at
+PPEM sizes of 12.
+
+The remedy for this is to replace the instruction code with
+automatically generated code from the FreeType project's "ttfautohint"
+program. First, extract '/system/fonts/DroidSansMono.ttf' from your
+device:
+
+ $ adb pull /system/fonts/DroidSansMono.ttf
+ /system/fonts/DroidSansMono.ttf: 1 file pulled, 0 skipped.
+ 23.1 MB/s (90208 bytes in 0.004s)
+
+install the "ttfautohint" program:
+
+ http://freetype.org/ttfautohint/
+
+generate a font file with new hinting instructions:
+
+ $ ttfautohint DroidSansMono.ttf > DroidSansMono.ttf.rpl
+
+and upload them to your device, either back to /system/fonts (which is
+allowed by free versions of Android, such as Replicant):
+
+ $ adb root
+ $ adb remount
+ $ adb push DroidSansMono.ttf.rpl /system/fonts/DroidSansMono.ttf
+
+or to the user fonts directory described in the "Android Fonts" node
+of the Emacs manual. You may want to perform this procedure even if
+you are not experiencing problems with character display, as the
+automatically generated instructions result in more legible text.
+
+** Glyphs are missing within the "Arial" font or it does not load.
+
+Old versions of this font included instruction code that assumed a
+degree of latitude from the Microsoft font scaler, which grants fonts
+leave to address nonexistent points without aborting the scaling
+process, among other invalid TrueType operations. This issue may
+extend beyond Arial to encompass a larger selection of old fonts
+designed by Microsoft or Monotype; most of the time, installing newer
+versions of such fonts will suffice.
+
+** Some TrueType test fonts don't work.
+
+It is unlikely that any of these fonts will really prove useful for
+text editing tasks, since they are designed for the express purpose of
+testing a TrueType font scaler. The following explanation is present
+only to satisfy a cat-like curiosity.
+
+Most TrueType test fonts "hide" points by moving them to a
+preposterous location outside the confines of the glyph bounding box.
+The Microsoft scaler and FreeType promptly disregard such points.
+
+Nothing in the TrueType specifications implies that points "hidden" in
+this fashion should be afforded any special treatment, and thus Emacs
+eschews doing so. Consequently, black streaks are displayed as
+Emacs interpolates glyph edges between points within the glyph and
+points the test font attempts to hide.
+
+Since this behavior does not influence the display of real fonts, no
+action will be taken to address this problem.
+
+** Some other font's instruction code produces undesirable results.
+
+Executing instruction code is not a strict requirement for producing
+correct display results from most current fonts. If a font's
+instruction code produces results that are merely unpleasing, but not
+incorrect, then the font was presumably not designed for Emacs's
+scaler. If its uninstructed glyphs are satisfactory (such as when
+your screen resolution is high enough to ameliorate scaling
+artifacts), disable instruction code execution by appending its family
+name to the variable 'sfnt-uninstructable-font-regexp', then
+restarting Emacs.
+
+** CJK text does not display in Emacs, but does in other programs.
+
+When inserting CJK text into a buffer or visiting a file containing
+CJK text, Emacs often fails to locate a suitable font. This problem
+manifests itself as hollow squares with numbers and letters within
+being displayed in lieu of the text itself.
+
+The reason for this is Emacs's absence of support for OpenType fonts
+utilizing CFF (Compact Font Format) outlines, which the CJK fonts
+bundled with Android have been distributed as since Android 7.0.
+
+The solution is to install a TrueType CJK font to the user fonts
+directory detailed in the "Android Fonts" node of the Emacs manual.
+
+Introducing support for the byzantine CFF font format into the Android
+port is a large undertaking that we are looking for volunteers to
+perform. If you are interested in taking responsibility for this
+task, please contact <emacs-devel@gnu.org>.
+
+** Emacs can only execute spasmodically in the background.
+
+Recent Android releases impose "battery optimization" on programs for
+which it is not expressly disabled; such optimization inhibits the
+execution of background services outside brief windows of time
+distributed at intervals of several dozens of minutes. Such programs
+as ERC which must send "keep-alive" packets at a rate beyond that at
+which these windows arrive consequently lose, yielding connection
+timeouts after Emacs has been in the background long enough that
+battery optimization enters into effect.
+
+This optimization can be disabled through the Settings app: navigate
+to "Apps & notifications", "Emacs", "Battery", "Battery Optimization",
+before clicking the drop-down menu labeled "Not Optimized", selecting
+the option "All Apps", scrolling to "Emacs", clicking on its entry and
+selecting "Don't Optimize" in the dialog box thus displayed.
+
+The organization of the Settings app might disagree with that
+illustrated above, which if true you should consult the documentation
+or any search mechanism for it.
+
* Build-time problems
** Configuration
diff --git a/etc/TODO b/etc/TODO
index 9b3796515d2..52c77ccc28d 100644
--- a/etc/TODO
+++ b/etc/TODO
@@ -479,15 +479,6 @@ One way of doing this is to start with fx's dynamic loading, and use it
to implement things like auto-loaded buffer parsers and database
access in cases which need more than Lisp.
-** Fix portable dumping so that you can redump without using -batch
-
-*** Redumps and native compiler "preloaded" sub-folder.
-In order to depose new .eln files being compiled into the "preloaded"
-sub-folder the native compiler needs to know in advance if this file
-will be preloaded or not. As .eln files are not moved afterwards
-subsequent redumps might refer to .eln file out of the "preloaded"
-sub-folder.
-
** Imenu could be extended into a file-structure browsing mechanism
This could use code like that of customize-groups.
@@ -904,6 +895,30 @@ It would make it easy to add (and remove) mappings like
* Things to be done for specific packages or features
+** Native compiler improvements
+
+*** Performance
+
+**** Intra compilation unit call optimization
+
+We could have a mechanism similar to what we use for optimizing calls
+to primitive functions. IE using a link table for each compilation
+unit (CU) such that calls from functions in a CU targeting functions
+in the same CU don't have to go through funcall. If one of these
+functions is redefined, a trampoline is compiled and installed to
+restore the redirection through funcall.
+
+*** Features to be improved or missing
+
+**** Fix portable dumping so that you can redump without using -batch
+
+***** Redumps and native compiler "preloaded" sub-folder.
+In order to depose new .eln files being compiled into the "preloaded"
+sub-folder the native compiler needs to know in advance if this file
+will be preloaded or not. As .eln files are not moved afterwards
+subsequent redumps might refer to .eln file out of the "preloaded"
+sub-folder.
+
** NeXTstep port
*** Missing features
@@ -1245,7 +1260,7 @@ Necessary for indirect buffers to work?
*** Locating schemas
-**** Should 'rng-validate-mode' allow to specify a schema?
+**** Should 'rng-validate-mode' allow specifying a schema?
Give the user an opportunity to specify a schema if there is currently
none? Or should it at least give a hint to the user how to specify a
non-vacuous schema?
@@ -1747,6 +1762,19 @@ The former is based on the GVFS archive backend, which makes it
available on GNU/Linux only. That implementation has further
drawbacks like it doesn't support to write into archives.
+** Provide support for CFF outlines in the Android port.
+
+The file src/sfnt.c supplies the font backend for the Android port.
+It is presently a self contained TrueType scaler, implementing both a
+grayscale outline generator and an instruction code interpreter.
+
+Support for CFF (Compact Font Format) outlines will facilitate
+utilizing fonts distributed as ".otf" files, a category that currently
+encompasses all CJK and some Middle Eastern and Indic fonts
+distributed with Android, obviating the present requirement for users
+of such scripts to actively install TrueType versions of fonts
+otherwise bundled with the system.
+
* Other known bugs
** 'make-frame' forgets unhandled parameters, at least for X11 frames
diff --git a/etc/compilation.txt b/etc/compilation.txt
index c03d30afa79..05f0829864c 100644
--- a/etc/compilation.txt
+++ b/etc/compilation.txt
@@ -344,6 +344,19 @@ In /home/janneke/vc/guile/examples/gud-break.scm:
1033: 0 [stderr "~a:hello world\n" (# # #)]
+* Lua 5.1, 5.2, 5.3, 5.4, and LuaJIT 2.1
+
+/usr/bin/lua: database.lua:31: assertion failed!
+stack traceback:
+ [C]: in function 'assert'
+ database.lua:31: in field 'statement'
+ database.lua:42: in field 'table'
+ database.lua:55: in field 'row'
+ database.lua:63: in field 'value'
+ io.lua: in main chunk
+ [C]: in ?
+
+
* Lucid Compiler, lcc 3.x
symbol: lcc
diff --git a/etc/emacs_lldb.py b/etc/emacs_lldb.py
index ad235e46b89..9865fe391a2 100644
--- a/etc/emacs_lldb.py
+++ b/etc/emacs_lldb.py
@@ -56,6 +56,7 @@ class Lisp_Object:
"PVEC_BOOL_VECTOR": "struct Lisp_Bool_Vector",
"PVEC_BUFFER": "struct buffer",
"PVEC_HASH_TABLE": "struct Lisp_Hash_Table",
+ "PVEC_OBARRAY": "struct Lisp_Obarray",
"PVEC_TERMINAL": "struct terminal",
"PVEC_WINDOW_CONFIGURATION": "struct save_window_data",
"PVEC_SUBR": "struct Lisp_Subr",
@@ -78,22 +79,22 @@ class Lisp_Object:
# Object construction/initialization.
def __init__(self, lisp_obj):
- self.lisp_obj = lisp_obj
- self.frame = lisp_obj.GetFrame()
+ self.tagged = lisp_obj
+ self.unsigned = None
self.lisp_type = None
self.pvec_type = None
- self.value = None
+ self.untagged = None
self.init_unsigned()
self.init_lisp_types()
self.init_values()
def init_unsigned(self):
- if self.lisp_obj.GetNumChildren() != 0:
+ if self.tagged.GetType().GetTypeClass() == lldb.eTypeClassStruct:
# Lisp_Object is actually a struct.
- lisp_word = self.lisp_obj.GetValueForExpressionPath(".i")
+ lisp_word = self.tagged.GetValueForExpressionPath(".i")
self.unsigned = lisp_word.GetValueAsUnsigned()
else:
- self.unsigned = self.lisp_obj.GetValueAsUnsigned()
+ self.unsigned = self.tagged.GetValueAsUnsigned()
# Initialize self.lisp_type to the C Lisp_Type enumerator of the
# Lisp_Object, as a string. Initialize self.pvec_type likewise to
@@ -117,59 +118,64 @@ class Lisp_Object:
f">> More_Lisp_Bits::PSEUDOVECTOR_AREA_BITS)")
self.pvec_type = enumerator_name(typ)
- # Initialize self.value according to lisp_type and pvec_type.
+ # Initialize self.untagged according to lisp_type and pvec_type.
def init_values(self):
if self.lisp_type == "Lisp_Symbol":
offset = self.get_lisp_pointer("char").GetValueAsUnsigned()
- self.value = self.eval(f"(struct Lisp_Symbol *)"
- f" ((char *) &lispsym + {offset})")
+ self.untagged = self.eval(f"(struct Lisp_Symbol *)"
+ f" ((char *) &lispsym + {offset})",
+ True)
elif self.lisp_type == "Lisp_String":
- self.value = self.get_lisp_pointer("struct Lisp_String")
+ self.untagged = self.get_lisp_pointer("struct Lisp_String", True)
elif self.lisp_type == "Lisp_Vectorlike":
c_type = Lisp_Object.pvec2type[self.pvec_type]
- self.value = self.get_lisp_pointer(c_type)
+ self.untagged = self.get_lisp_pointer(c_type, True)
elif self.lisp_type == "Lisp_Cons":
- self.value = self.get_lisp_pointer("struct Lisp_Cons")
+ self.untagged = self.get_lisp_pointer("struct Lisp_Cons", True)
elif self.lisp_type == "Lisp_Float":
- self.value = self.get_lisp_pointer("struct Lisp_Float")
+ self.untagged = self.get_lisp_pointer("struct Lisp_Float", True)
elif self.lisp_type in ("Lisp_Int0", "Lisp_Int1"):
- self.value = self.eval(f"((EMACS_INT) {self.unsigned}) "
- f">> (GCTYPEBITS - 1)")
+ self.untagged = self.eval(f"((EMACS_INT) {self.unsigned}) "
+ f">> (GCTYPEBITS - 1)", True)
+ elif self.lisp_type == "Lisp_Type_Unused0":
+ self.untagged = self.unsigned
else:
- assert False, "Unknown Lisp type"
-
- # Create an SBValue for EXPR with name NAME.
- def create_value(self, name, expr):
- return self.lisp_obj.CreateValueFromExpression(name, expr)
+ assert False, f"Unknown Lisp type {self.lisp_type}"
# Evaluate EXPR in the context of the current frame.
- def eval(self, expr):
- return self.frame.EvaluateExpression(expr)
+ def eval(self, expr, make_var=False):
+ frame = self.tagged.GetFrame()
+ if make_var:
+ return frame.EvaluateExpression(expr)
+ options = lldb.SBExpressionOptions()
+ options.SetSuppressPersistentResult(True)
+ return frame.EvaluateExpression(expr, options)
# Return an SBValue for this object denoting a pointer of type
# TYP*.
- def get_lisp_pointer(self, typ):
+ def get_lisp_pointer(self, typ, make_var=False):
return self.eval(f"({typ}*) (((EMACS_INT) "
- f"{self.unsigned}) & VALMASK)")
+ f"{self.unsigned}) & VALMASK)",
+ make_var)
# If this is a Lisp_String, return an SBValue for its string data.
# Return None otherwise.
def get_string_data(self):
if self.lisp_type == "Lisp_String":
- return self.value.GetValueForExpressionPath("->u.s.data")
+ return self.untagged.GetValueForExpressionPath("->u.s.data")
return None
# if this is a Lisp_Symbol, return an SBBalue for its name.
# Return None otherwise.
def get_symbol_name(self):
if self.lisp_type == "Lisp_Symbol":
- name = self.value.GetValueForExpressionPath("->u.s.name")
+ name = self.untagged.GetValueForExpressionPath("->u.s.name")
return Lisp_Object(name).get_string_data()
return None
# Return a summary string for this object.
def summary(self):
- return str(self.value)
+ return str(self.untagged)
########################################################################
@@ -206,6 +212,50 @@ def xdebug_print(debugger, command, result, internal_dict):
def type_summary_Lisp_Object(obj, internal_dict):
return Lisp_Object(obj).summary()
+class Lisp_Object_Provider:
+ """Synthetic children provider for Lisp_Objects.
+ Supposedly only used by 'frame variable', where -P <n> can be used
+ to specify a printing depth. """
+ def __init__(self, valobj, internal_dict):
+ self.valobj = valobj
+ self.children = {}
+
+ def update(self):
+ lisp_obj = Lisp_Object(self.valobj)
+ lisp_type = lisp_obj.lisp_type
+ try:
+ if lisp_type == "Lisp_Symbol":
+ child = lisp_obj.get_symbol_name()
+ self.children["name"] = child
+ elif lisp_type == "Lisp_String":
+ child = lisp_obj.get_string_data()
+ self.children["data"] = child
+ elif lisp_type == "Lisp_Cons":
+ car = lisp_obj.untagged.GetValueForExpressionPath("->u.s.car")
+ cdr = lisp_obj.untagged.GetValueForExpressionPath("->u.s.u.cdr")
+ self.children["car"] = car
+ self.children["cdr"] = cdr
+ else:
+ self.children["untagged"] = lisp_obj.untagged
+ except:
+ print(f"*** exception in child provider update for {lisp_type}")
+ pass
+
+ def num_children(self):
+ return len(self.children)
+
+ def get_child_index(self, name):
+ index = 0
+ for child_name, child in self.children:
+ if child_name == name:
+ return index
+ index = index + 1
+ return -1
+
+ def get_child_at_index(self, index):
+ key = list(self.children)[index]
+ return self.children[key]
+
########################################################################
# Initialization
@@ -239,6 +289,17 @@ def define_type_summary(debugger, regex, function):
f"--python-function {python_function} "
+ regex)
+# Define Python class CLS as a children provider for the types
+# matching REFEXP. Providers are defined in the category Emacs, and
+# can be seen with 'type synthetic list -w Emacs', and deleted in a
+# similar way.
+def define_type_synthetic(debugger, regex, cls):
+ python_class = __name__ + "." + cls.__name__
+ debugger.HandleCommand(f"type synthetic add "
+ f"--category Emacs "
+ f"--python-class {python_class} "
+ + regex)
+
# Enable a given category of type summary providers.
def enable_type_category(debugger, category):
debugger.HandleCommand(f"type category enable {category}")
@@ -248,6 +309,7 @@ def __lldb_init_module(debugger, internal_dict):
define_command(debugger, xbacktrace)
define_command(debugger, xdebug_print)
define_type_summary(debugger, "Lisp_Object", type_summary_Lisp_Object)
+ define_type_synthetic(debugger, "Lisp_Object", Lisp_Object_Provider)
enable_type_category(debugger, "Emacs")
print('Emacs debugging support has been installed.')
diff --git a/etc/emacsclient-mail.desktop b/etc/emacsclient-mail.desktop
index 0a2420ddead..4f7f00ebefd 100644
--- a/etc/emacsclient-mail.desktop
+++ b/etc/emacsclient-mail.desktop
@@ -1,10 +1,7 @@
[Desktop Entry]
Categories=Network;Email;
Comment=GNU Emacs is an extensible, customizable text editor - and more
-# We want to pass the following commands to the shell wrapper:
-# u=$(echo "$1" | sed 's/[\"]/\\&/g'); exec emacsclient --alternate-editor= --display="$DISPLAY" --eval "(message-mailto \"$u\")"
-# Special chars '"', '$', and '\' must be escaped as '\\"', '\\$', and '\\\\'.
-Exec=sh -c "u=\\$(echo \\"\\$1\\" | sed 's/[\\\\\\"]/\\\\\\\\&/g'); exec emacsclient --alternate-editor= --display=\\"\\$DISPLAY\\" --eval \\"(message-mailto \\\\\\"\\$u\\\\\\")\\"" sh %u
+Exec=emacsclient --alternate-editor= --eval "(message-mailto (pop server-eval-args-left))" %u
Icon=emacs
Name=Emacs (Mail, Client)
MimeType=x-scheme-handler/mailto;
@@ -16,7 +13,7 @@ Actions=new-window;new-instance;
[Desktop Action new-window]
Name=New Window
-Exec=sh -c "u=\\$(echo \\"\\$1\\" | sed 's/[\\\\\\"]/\\\\\\\\&/g'); exec emacsclient --alternate-editor= --create-frame --eval \\"(message-mailto \\\\\\"\\$u\\\\\\")\\"" sh %u
+Exec=emacsclient --alternate-editor= --create-frame --eval "(message-mailto (pop server-eval-args-left))" %u
[Desktop Action new-instance]
Name=New Instance
diff --git a/etc/images/README b/etc/images/README
index 927e0149c7c..8e112448373 100644
--- a/etc/images/README
+++ b/etc/images/README
@@ -67,21 +67,25 @@ Emacs images and their source in the GNOME icons stock/ directory:
attach.xpm document/stock_attach
bookmark_add.xpm actions/bookmark_add
cancel.xpm slightly modified generic/stock_stop
- connect.xpm net/stock_connect
+ commit.xpm code/stock_run
connect-to-url.xpm net/stock_connect-to-url
+ connect.xpm net/stock_connect
contact.xpm net/stock_contact
data-save.xpm data/stock_data-save
delete.xpm generic/stock_delete
describe.xpm generic/stock_properties
disconnect.xpm net/stock_disconnect
exit.xpm generic/stock_exit
+ gen-changelog.xpm text/stock_autoformat
+ ins-changelog.xpm form/stock_show-form-dialog
+ load-changelog.xpm text/stock_insert_endnote
lock-broken.xpm data/stock_lock-broken
lock-ok.xpm data/stock_lock-ok
lock.xpm data/stock_lock
- redo.xpm generic/stock_redo
- search-replace.xpm slightly modified generic/stock_search-and-replace
next-page.xpm navigation/stock_next-page
+ redo.xpm generic/stock_redo
refresh.xpm generic/stock_refresh
+ search-replace.xpm slightly modified generic/stock_search-and-replace
separator.xpm ?
show.xpm slightly modified document/stock_new
sort-ascending.xpm slightly modified data/stock_sort-ascending
@@ -89,6 +93,7 @@ Emacs images and their source in the GNOME icons stock/ directory:
sort-criteria.xpm data/stock_sort-criteria
sort-descending.xpm slightly modified data/stock_sort-descending
sort-row-ascending.xpm data/stock_sort-row-ascending
+ view-diff.xpm text/stock_list_enum-restart
zoom-in.xpm navigation/stock_zoom-in
zoom-out.xpm navigation/stock_zoom-out
@@ -120,7 +125,7 @@ For more information see the adwaita-icon-theme repository at:
https://gitlab.gnome.org/GNOME/adwaita-icon-theme
-Emacs images and their source in the Adwaita/scalable directory:
+Emacs images and their source in the Adwaita/symbolic directory:
checked.svg ui/checkbox-checked-symbolic.svg
unchecked.svg ui/checkbox-symbolic.svg
@@ -132,3 +137,8 @@ Emacs images and their source in the Adwaita/scalable directory:
left.svg ui/pan-start-symbolic.svg
right.svg ui/pan-end-symbolic.svg
up.svg ui/pan-up-symbolic.svg
+ conceal.svg actions/view-conceal-symbolic.svg
+ reveal.svg actions/view-reveal-symbolic.svg
+
+conceal.pbm and reveal.pbm are generated from the respective *.svg
+files, using the ImageMagick converter tool.
diff --git a/etc/images/alt.pbm b/etc/images/alt.pbm
new file mode 100644
index 00000000000..7d12a48b552
--- /dev/null
+++ b/etc/images/alt.pbm
Binary files differ
diff --git a/etc/images/commit.pbm b/etc/images/commit.pbm
new file mode 100644
index 00000000000..11fe690ac1b
--- /dev/null
+++ b/etc/images/commit.pbm
Binary files differ
diff --git a/etc/images/commit.xpm b/etc/images/commit.xpm
new file mode 100644
index 00000000000..1730f155811
--- /dev/null
+++ b/etc/images/commit.xpm
@@ -0,0 +1,101 @@
+/* XPM */
+static char *commit[] = {
+/* columns rows colors chars-per-pixel */
+"24 24 71 1 ",
+" c None",
+". c black",
+"X c gray13",
+"o c gray14",
+"O c #252525",
+"+ c gray25",
+"@ c gray33",
+"# c #555555",
+"$ c #565656",
+"% c #5A5A5A",
+"& c #5D5D5D",
+"* c gray40",
+"= c #6C6C6C",
+"- c #DF421E",
+"; c #46A046",
+": c #625B81",
+"> c #887FA3",
+", c #848484",
+"< c gray53",
+"1 c #888888",
+"2 c #8E8E8E",
+"3 c #979797",
+"4 c #9A9A9A",
+"5 c #A0A0A0",
+"6 c gray65",
+"7 c #A9A9A9",
+"8 c #AEAEAE",
+"9 c gray75",
+"0 c #BBB6CA",
+"q c #C2C2C1",
+"w c gray76",
+"e c #C3C3C2",
+"r c #C3C3C3",
+"t c gray77",
+"y c #C7C7C6",
+"u c #C8C8C8",
+"i c gray79",
+"p c #C5C1D2",
+"a c #CAC6D6",
+"s c gray84",
+"d c #D8D8D8",
+"f c gray88",
+"g c #E1E1E1",
+"h c #E6E6E6",
+"j c #EDEDEB",
+"k c #EEEEED",
+"l c #EFEFEF",
+"z c #ECEAF0",
+"x c #ECEBF0",
+"c c #F0EFF3",
+"v c gray94",
+"b c #F1F1F0",
+"n c #F2F2F1",
+"m c #F4F4F3",
+"M c #F4F3F6",
+"N c #F5F5F4",
+"B c gray96",
+"V c #F6F6F5",
+"C c #F6F6F6",
+"Z c gray97",
+"A c #F8F8F7",
+"S c #F7F6F8",
+"D c #F8F8F8",
+"F c #F9F9F9",
+"G c gray98",
+"H c #FCFCFB",
+"J c gray99",
+"K c #FDFDFC",
+"L c #FDFDFD",
+"P c #FEFEFE",
+"I c white",
+/* pixels */
+" ...... ",
+" .xx00. ",
+" ..xp>>..",
+" .Spa>>>.",
+"+++++++++## .Mp>>. ",
+"IIIIIIIIIGs<o .c>. ",
+"IIIIIIIIIGhv5. .. ",
+"IIIIIIIIIGdIB3o ",
+"IIIIIIIIIBiIIg1X ",
+";:IIIIIIIB9gsiw2 ",
+"IIIIIIIIHB7*&#%<. ",
+":::G::::GBvsy64=. ",
+"GGGGGGGGGGGGGGG8. ",
+"--::G:::GGGGGGGw. ",
+"GGGGGGGGGGGGGGGy. ",
+"::A::AAAAAAAAAAy. ",
+"BBBBBBBBBBBBBBBy. ",
+"BBBBBBBBBBBBBBBw. ",
+":mmmmmmmmmmmmmmw. ",
+"vvvvvvvvvvvvvvvw. ",
+"---v:v:::v:::vvw. ",
+"lllllllllllllllw. ",
+"::::l--:lllllllw. ",
+"jjjjjjjjjjjjjjjw. "
+};
diff --git a/etc/images/conceal.pbm b/etc/images/conceal.pbm
new file mode 100644
index 00000000000..3df787d6fd6
--- /dev/null
+++ b/etc/images/conceal.pbm
Binary files differ
diff --git a/etc/images/conceal.svg b/etc/images/conceal.svg
new file mode 100644
index 00000000000..172b73ed3d3
--- /dev/null
+++ b/etc/images/conceal.svg
@@ -0,0 +1,4 @@
+<?xml version="1.0" encoding="UTF-8"?>
+<svg height="16px" viewBox="0 0 16 16" width="16px" xmlns="http://www.w3.org/2000/svg">
+ <path d="m 1.53125 0.46875 l -1.0625 1.0625 l 14 14 l 1.0625 -1.0625 l -2.382812 -2.382812 c 1.265624 -1.0625 2.171874 -2.496094 2.589843 -4.097657 c -0.914062 -3.523437 -4.097656 -5.984375 -7.738281 -5.988281 c -1.367188 0.011719 -2.707031 0.371094 -3.894531 1.042969 z m 6.46875 3.53125 c 2.210938 0 4 1.789062 4 4 c -0.003906 0.800781 -0.246094 1.578125 -0.699219 2.238281 l -1.46875 -1.46875 c 0.105469 -0.242187 0.164063 -0.503906 0.167969 -0.769531 c 0 -1.105469 -0.894531 -2 -2 -2 c -0.265625 0.003906 -0.527344 0.0625 -0.769531 0.167969 l -1.46875 -1.46875 c 0.660156 -0.453125 1.4375 -0.695313 2.238281 -0.699219 z m -6.144531 0.917969 c -0.753907 0.898437 -1.296875 1.957031 -1.59375 3.09375 c 0.914062 3.523437 4.097656 5.984375 7.738281 5.988281 c 0.855469 -0.007812 1.703125 -0.152344 2.511719 -0.425781 l -1.667969 -1.667969 c -0.277344 0.058594 -0.5625 0.089844 -0.84375 0.09375 c -2.210938 0 -4 -1.789062 -4 -4 c 0.003906 -0.28125 0.035156 -0.566406 0.09375 -0.84375 z m 0 0" fill="#2e3436"/>
+</svg>
diff --git a/etc/images/ctrl.pbm b/etc/images/ctrl.pbm
new file mode 100644
index 00000000000..c3ff817dc7a
--- /dev/null
+++ b/etc/images/ctrl.pbm
Binary files differ
diff --git a/etc/images/gen-changelog.pbm b/etc/images/gen-changelog.pbm
new file mode 100644
index 00000000000..40bea125b06
--- /dev/null
+++ b/etc/images/gen-changelog.pbm
Binary files differ
diff --git a/etc/images/gen-changelog.xpm b/etc/images/gen-changelog.xpm
new file mode 100644
index 00000000000..65ea7c16f04
--- /dev/null
+++ b/etc/images/gen-changelog.xpm
@@ -0,0 +1,152 @@
+/* XPM */
+static char *gen_changelog[] = {
+/* columns rows colors chars-per-pixel */
+"24 24 122 2 ",
+" c None",
+". c black",
+"X c gray10",
+"o c #353535",
+"O c #442D0E",
+"+ c #5E4417",
+"@ c #7D5A22",
+"# c #645435",
+"$ c #464646",
+"% c #505050",
+"& c gray32",
+"* c #535353",
+"= c gray33",
+"- c #585858",
+"; c gray35",
+": c #675E46",
+"> c gray39",
+", c #6E6E6C",
+"< c gray43",
+"1 c gray44",
+"2 c #787775",
+"3 c #797979",
+"4 c #7B7B7B",
+"5 c #88601F",
+"6 c #A27E36",
+"7 c #9A8558",
+"8 c #9F8B5F",
+"9 c #A09069",
+"0 c #BAA069",
+"q c #C7AF7A",
+"w c #CCB176",
+"e c #868583",
+"r c #868686",
+"t c gray53",
+"y c #8B8A86",
+"u c #888888",
+"i c #898989",
+"p c #8B8B88",
+"a c gray54",
+"s c #8B8B8B",
+"d c #8C8C89",
+"f c gray55",
+"g c #8D8D8D",
+"h c #8E8E8E",
+"j c gray56",
+"k c #909090",
+"l c gray57",
+"z c #929292",
+"x c #939393",
+"c c #969592",
+"v c gray58",
+"b c #959595",
+"n c #979797",
+"m c #9B9996",
+"M c #9C9B97",
+"N c #B8B39B",
+"B c #A4A4A4",
+"V c gray65",
+"C c #A8A7A3",
+"Z c #AAAAAA",
+"A c #B0AFAC",
+"S c gray70",
+"D c #B4B4B4",
+"F c #B6B6B6",
+"G c #C0BFBD",
+"H c #D6C08E",
+"J c #D9C28B",
+"K c #DEC58D",
+"L c #D8C291",
+"P c #DFCA96",
+"I c #E1CC99",
+"U c #C2C1BD",
+"Y c #F3E5BE",
+"T c #C5C5C5",
+"R c #C6C6C6",
+"E c gray79",
+"W c #CACACA",
+"Q c gray80",
+"! c #CECECE",
+"~ c #D2D0D0",
+"^ c #DBDAD8",
+"/ c gray86",
+"( c gainsboro",
+") c #DDDDDD",
+"_ c #F4E7C2",
+"` c #EBE8D3",
+"' c gray88",
+"] c #E1E1E1",
+"[ c #E2E2E2",
+"{ c gray89",
+"} c #E4E4E4",
+"| c gray90",
+" . c #E6E6E6",
+".. c #E7E7E7",
+"X. c #EAE8E3",
+"o. c gray91",
+"O. c #E9E9E9",
+"+. c #EAEAEA",
+"@. c gray92",
+"#. c #EFEDE9",
+"$. c #ECECEC",
+"%. c gray93",
+"&. c #EEEEEE",
+"*. c #EFEFEF",
+"=. c #FEFCE8",
+"-. c #FEFEED",
+";. c gray94",
+":. c #F1F1F1",
+">. c gray95",
+",. c #F3F3F3",
+"<. c #F4F4F4",
+"1. c gray96",
+"2. c #F6F6F6",
+"3. c gray97",
+"4. c #F8F8F8",
+"5. c #F9F9F9",
+"6. c gray98",
+"7. c #FBFBFB",
+"8. c gray99",
+"9. c #FDFDFD",
+"0. c #FEFEFE",
+"q. c white",
+/* pixels */
+" . . . . . . . . . . . . . . . . . . . . ",
+". [ >.>.>.>.>.>.>.<.<.<.<.<.<.<.<.<.<.<.) . ",
+". >.[ [ [ [ [ } } } } o.o.o.o.o.$.$.$.$.$.. ",
+". >.[ r r r r i i ; . & i o.o.$.$.$.$.>.>.. ",
+". >.[ [ [ } } } [ . N . [ $.$.$.$.$.>.>.>.. ",
+". >.[ r i i i i < . ` . = g g g g >.>.>.>.. ",
+". >.} } } } } 3 . . -.. . 3 o.>.>.>.>.>.<.. ",
+". >.} i i ; . . : _ =.6 # . . D >.>.>.<.<.. ",
+". <.} } o.. 7 q J P Y w I K 8 . T <.<.<.<.. ",
+". <.} i i & . . O @ 0 5 + . . n <.<.<.<.<.. ",
+". <.o.o.o.o.[ k . . H . X $ . <.<.<.<.<.4.. ",
+". <.o.i g g g g > . L . ; d C . <.<.4.4.4.. ",
+". <.o.$.$.$.$.$.o.. 9 o . 2 G U . 4.4.4.4.. ",
+". <.o.g g g g g g & . 1 T . i ~ C . 4.4.9.. ",
+". <.$.$.$.$.>.>.>.>.T ) T T . M ^ A . 9.9.. ",
+". <.$.g g g g k >.<.<.<.) ) S . C #.c . 9.. ",
+". 4.>.>.>.>.>.<.<.<.<.4.4.[ E D . M X.e . . ",
+". 4.>.k k k k k k k k n n n [ Q B . m X.< . ",
+". >.>.<.<.<.<.<.<.4.4.4.4.9.9.} Q B . c X.2 . ",
+". E $.4.<.<.<.4.4.4.4.4.9.9.9.9.} Q Z . y X.2 . ",
+" . . . . . . . . . . . . . . . . . . . . y X.. ",
+" . . ",
+" ",
+" "
+};
diff --git a/etc/images/gnus/gnus-pointer.svg b/etc/images/gnus/gnus-pointer.svg
new file mode 100644
index 00000000000..590e0f56d89
--- /dev/null
+++ b/etc/images/gnus/gnus-pointer.svg
@@ -0,0 +1,94 @@
+<?xml version="1.0" encoding="UTF-8" standalone="no"?>
+<!-- Gnu Emacs Logo
+
+ Copyright (C) 2008-2024 Free Software Foundation, Inc.
+
+ Author: Francesc Rocher <f.rocher@member.fsf.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 <https://www.gnu.org/licenses/>.
+
+-->
+<!-- Created with Inkscape (http://www.inkscape.org/) -->
+<svg
+ width="23.6206187542"
+ height="16"
+ version="1.0"
+ style="display:inline"
+ id="svg1"
+ sodipodi:docname="gnus-pointer.svg"
+ inkscape:version="1.3 (0e150ed6c4, 2023-07-21)"
+ viewBox="0 0 167.68044 113.58242"
+ xmlns:inkscape="http://www.inkscape.org/namespaces/inkscape"
+ xmlns:sodipodi="http://sodipodi.sourceforge.net/DTD/sodipodi-0.dtd"
+ xmlns="http://www.w3.org/2000/svg"
+ xmlns:svg="http://www.w3.org/2000/svg"
+ xmlns:rdf="http://www.w3.org/1999/02/22-rdf-syntax-ns#"
+ xmlns:cc="http://creativecommons.org/ns#"
+ xmlns:dc="http://purl.org/dc/elements/1.1/">
+ <defs
+ id="defs1" />
+ <sodipodi:namedview
+ id="namedview1"
+ pagecolor="#ffffff"
+ bordercolor="#666666"
+ borderopacity="1.0"
+ inkscape:showpageshadow="2"
+ inkscape:pageopacity="0.0"
+ inkscape:pagecheckerboard="0"
+ inkscape:deskcolor="#d1d1d1"
+ inkscape:zoom="2.7948886"
+ inkscape:cx="128.09097"
+ inkscape:cy="123.26073"
+ inkscape:current-layer="layer1" />
+ <metadata
+ id="metadata2166">
+ <rdf:RDF>
+ <cc:Work
+ rdf:about="">
+ <dc:format>image/svg+xml</dc:format>
+ <dc:type
+ rdf:resource="http://purl.org/dc/dcmitype/StillImage" />
+ <cc:license
+ rdf:resource="https://www.gnu.org/copyleft/gpl.html" />
+ <dc:title>gnus</dc:title>
+ <dc:date>2008/06/28</dc:date>
+ <dc:creator>
+ <cc:Agent>
+ <dc:title>Francesc Rocher</dc:title>
+ </cc:Agent>
+ </dc:creator>
+ <dc:rights>
+ <cc:Agent>
+ <dc:title>GPL</dc:title>
+ </cc:Agent>
+ </dc:rights>
+ <dc:description>gnus icon image</dc:description>
+ <cc:license
+ rdf:resource="https://www.gnu.org/copyleft/gpl.html" />
+ </cc:Work>
+ </rdf:RDF>
+ </metadata>
+ <g
+ inkscape:label="Layer 1"
+ inkscape:groupmode="layer"
+ id="layer1"
+ transform="translate(-214.53867,-140.13329)">
+ <path
+ style="fill-opacity:1"
+ d="m 321.70896,253.17911 c -0.36667,-0.36666 -0.67201,-5.20416 -0.67854,-10.75 -0.019,-16.11278 -3.80254,-26.01429 -11.53101,-30.17635 -1.90142,-1.02398 -3.45712,-2.07087 -3.45712,-2.32642 0,-1.43357 10.45296,-16.08056 11.47604,-16.08056 2.47319,0 9.23725,5.87604 10.97182,9.53138 5.03752,10.61578 4.34103,30.55989 -1.50929,43.21862 -3.28874,7.11606 -3.93373,7.9215 -5.2719,6.58333 z m -77.16152,-8.46295 c -4.45468,-3.91126 -4.44465,-5.90837 0.0814,-16.20837 6.498,-14.78751 34.5082,-54.96722 36.7536,-52.72182 1.31908,1.31908 -1.58012,6.7064 -6.9201,12.85902 -5.10867,5.88611 -15.27729,21.00949 -18.79544,27.95371 -3.51862,6.94514 -2.86216,9.83677 2.56492,11.29813 2.18779,0.58911 5.33413,0.77321 6.99187,0.4091 6.2872,-1.3809 18.78154,-10.37638 34.82869,-25.07544 1.63528,-1.49791 2.98143,-2.00796 3.86245,-1.46346 2.11637,1.30799 -7.3484,14.40921 -15.90222,22.01199 -16.20847,14.40636 -27.60611,21.67016 -36.7152,23.39889 -2.68566,0.50969 -3.8489,0.0855 -6.75,-2.46175 z m 106.49485,-47.00332 c -2.5122,-0.71522 -8.01566,-5.45017 -19.5,-16.77699 -12.82987,-12.6539 -16.81552,-16.00934 -20.11602,-16.9353 -9.0949,-2.5516 -16.05869,-0.67634 -18.98403,5.11216 -1.7056,3.37495 -5.29744,7.73307 -6.37338,7.73307 -0.34364,0 -1.1778,-1.5293 -1.8537,-3.39846 -1.42445,-3.93926 -8.55314,-10.8615 -13.72556,-13.32805 -3.4655,-1.65258 -3.70255,-1.63465 -7.9122,0.59856 -2.38681,1.26621 -5.39614,3.78466 -6.68739,5.59656 -2.99038,4.19616 -18.42665,18.22292 -22.26047,20.22784 -3.6871,1.92819 -10.16611,1.16914 -12.83946,-1.5042 -1.25983,-1.25984 -2.63141,-5.30077 -3.84411,-11.32548 -1.03697,-5.15172 -2.08806,-10.26677 -2.33574,-11.36677 -0.24769,-1.1 0.16855,-2.83295 0.92497,-3.85101 1.33079,-1.79111 1.50083,-1.78047 5.25386,0.32885 2.13321,1.19893 4.96021,3.93001 6.28222,6.06908 2.91698,4.71978 6.42385,5.78889 11.14802,3.3986 5.61805,-2.84256 13.87615,-9.63484 17.51425,-14.40546 5.80084,-7.60662 11.27676,-12.99393 13.86896,-13.64453 1.35462,-0.33999 4.82023,0.14973 7.70136,1.08827 4.00736,1.3054 6.38479,2.98928 10.11649,7.16527 l 4.87808,5.45885 1.83587,-3.01884 c 2.46937,-4.06056 10.61011,-8.08908 16.34622,-8.08908 7.64657,0 14.07091,3.70799 23.59667,13.61949 4.6942,4.88428 9.67621,10.28189 11.07114,11.99468 9.1173,11.19486 23.8278,13.70046 29.6705,5.0537 1.25211,-1.85302 3.42939,-4.44884 4.83841,-5.7685 l 2.56185,-2.39937 -0.72231,3.87057 c -1.32367,7.09295 -6.50404,19.06241 -9.26864,21.41558 -8.2221,6.99849 -14.31844,9.03606 -21.18586,7.08091 z"
+ id="path1" />
+ </g>
+</svg>
diff --git a/etc/images/hyper.pbm b/etc/images/hyper.pbm
new file mode 100644
index 00000000000..fdb79c2f3a9
--- /dev/null
+++ b/etc/images/hyper.pbm
Binary files differ
diff --git a/etc/images/ins-changelog.pbm b/etc/images/ins-changelog.pbm
new file mode 100644
index 00000000000..fb97cf7d5d8
--- /dev/null
+++ b/etc/images/ins-changelog.pbm
@@ -0,0 +1,3 @@
+P4
+24 24
+ \ No newline at end of file
diff --git a/etc/images/ins-changelog.xpm b/etc/images/ins-changelog.xpm
new file mode 100644
index 00000000000..24deee3c344
--- /dev/null
+++ b/etc/images/ins-changelog.xpm
@@ -0,0 +1,67 @@
+/* XPM */
+static char *ins_changelog[] = {
+/* columns rows colors chars-per-pixel */
+"24 24 37 1 ",
+" c None",
+". c black",
+"X c #161616",
+"o c gray25",
+"O c #4B4B49",
+"+ c #5D5D5D",
+"@ c #494066",
+"# c #767676",
+"$ c gray52",
+"% c #A0A0A0",
+"& c gray66",
+"* c gray68",
+"= c #BBBBBB",
+"- c #BCBCBC",
+"; c gray74",
+": c #C1C1C1",
+"> c gray76",
+", c #C3C3C3",
+"< c gray88",
+"1 c #E2E2E2",
+"2 c gray89",
+"3 c #E4E4E4",
+"4 c gray90",
+"5 c #E6E6E6",
+"6 c #E7E7E7",
+"7 c gray91",
+"8 c #EAEAEA",
+"9 c gray92",
+"0 c #ECECEC",
+"q c gray93",
+"w c #EEEEEE",
+"e c #EFEFEF",
+"r c gray94",
+"t c #F1F1F1",
+"y c #FBFBFB",
+"u c #FDFDFD",
+"i c #FEFEFE",
+/* pixels */
+" ",
+" ",
+" @ @@ @@ @@ @@ ",
+" @ ",
+" @ ",
+" @ @ ",
+" @ ",
+" ......... ",
+" @ .iiiiiii2>. ",
+" @ .itttttt>y&. ",
+" .itttttt*#+o. ",
+" @ .it@@@@t2$OX. ",
+" @ .iteeeeeeee=. ",
+" .ie@@@@@@@e=. ",
+" @ .ieeeeeeee9=. ",
+" @ .ie@@@@@@@9=. ",
+" .i999999499=. ",
+" @@ @@ @@.i9@@@@@@@4=. ",
+" .i944444444=. ",
+" .i4@@@@@@@4=. ",
+" .i444444222=. ",
+" .>-----====%. ",
+" ........... ",
+" "
+};
diff --git a/etc/images/last-page.pbm b/etc/images/last-page.pbm
new file mode 100644
index 00000000000..d25ce022183
--- /dev/null
+++ b/etc/images/last-page.pbm
Binary files differ
diff --git a/etc/images/last-page.xpm b/etc/images/last-page.xpm
new file mode 100644
index 00000000000..5704143aa2e
--- /dev/null
+++ b/etc/images/last-page.xpm
@@ -0,0 +1,122 @@
+/* XPM */
+static char *last_page[] = {
+/* columns rows colors chars-per-pixel */
+"24 24 92 1 ",
+" c None",
+". c black",
+"X c gray15",
+"o c #2F4050",
+"O c #344353",
+"+ c #3B4F63",
+"@ c #384F66",
+"# c #3A5067",
+"$ c #3C5064",
+"% c #3C5065",
+"& c #3E5166",
+"* c #3F5266",
+"= c #3A5168",
+"- c #3B5269",
+"; c #3D526A",
+": c #3E546A",
+"> c #3F556B",
+", c #3E5975",
+"< c #3F5A76",
+"1 c #464646",
+"2 c #494949",
+"3 c #405367",
+"4 c #405468",
+"5 c #40566C",
+"6 c #41576D",
+"7 c #42586E",
+"8 c #44586F",
+"9 c #45596F",
+"0 c #465B70",
+"q c #415B77",
+"w c #425C78",
+"e c #435E79",
+"r c #445F7A",
+"t c #46607B",
+"y c #47617B",
+"u c #47617C",
+"i c #48627D",
+"p c #49637D",
+"a c #4B647E",
+"s c #4C647F",
+"d c #4C657F",
+"f c gray38",
+"g c #6A6A6A",
+"h c #616A73",
+"j c #68727D",
+"k c #7C7C7C",
+"l c #4E6780",
+"z c #4F6881",
+"x c #506982",
+"c c #526A83",
+"v c #556D85",
+"b c #5B7289",
+"n c #7D8185",
+"m c #77838F",
+"M c #868788",
+"N c #888888",
+"B c #8B8B8B",
+"V c #8F9296",
+"C c #8F9396",
+"Z c #8F9397",
+"A c #909397",
+"S c #959595",
+"D c #91969C",
+"F c #91979C",
+"G c #92979C",
+"H c #92979D",
+"J c #9C9FA1",
+"K c #9D9FA2",
+"L c #A2A3A4",
+"P c #A6A6A6",
+"I c #ACACAC",
+"U c gray68",
+"Y c #B0B0B0",
+"T c #B2B2B2",
+"R c gray71",
+"E c #B6B6B6",
+"W c gray75",
+"Q c #C5C5C5",
+"! c gray79",
+"~ c gray80",
+"^ c LightGray",
+"/ c #D6D6D6",
+"( c #D8D8D8",
+") c #DADADA",
+"_ c #DEDEDE",
+"` c gray89",
+"' c #E5E5E5",
+"] c #E6E6E6",
+"[ c #EEEEEE",
+"{ c #F2F2F2",
+"} c #F6F6F6",
+"| c white",
+/* pixels */
+" ",
+" ",
+" ........ ........ ",
+" .vU/_][`!N2gNT~)]{|b. ",
+" .@T/_][}||PUTW~)]{|t. ",
+" .#T/_][}`|PUTW~)]{|t. ",
+" .-T/_][).|PUTW~)]{|t. ",
+" .-T/_]^..|PUTW~)]{|t. ",
+" .;T/_~...|PUTW~)]{|u. ",
+" .>T/Q.....X1fkSR]{|i. ",
+" .>T/_~...|PUTW~)]{|i. ",
+" .5T/_]^..|PUTW~)]{|a. ",
+" .5T/_][).|PUTW~)]{|d. ",
+" .7T/_][}`|PUTW~)]{|d. ",
+" .8T/_][}||PUTW~)]{|l. ",
+" .8R/_][}||PUTW~)]{|z. ",
+" .0MAZZZZZKPLHHHHHKmc. ",
+" .O43&&&&+hnjtrwwq<<c. ",
+" ..........o......... ",
+" ... ",
+" ",
+" ",
+" ",
+" "
+};
diff --git a/etc/images/load-changelog.pbm b/etc/images/load-changelog.pbm
new file mode 100644
index 00000000000..43f1a1b221f
--- /dev/null
+++ b/etc/images/load-changelog.pbm
Binary files differ
diff --git a/etc/images/load-changelog.xpm b/etc/images/load-changelog.xpm
new file mode 100644
index 00000000000..6d317b6afa2
--- /dev/null
+++ b/etc/images/load-changelog.xpm
@@ -0,0 +1,82 @@
+/* XPM */
+static char *load_changelog[] = {
+/* columns rows colors chars-per-pixel */
+"24 24 52 1 ",
+" c None",
+". c black",
+"X c #434343",
+"o c gray33",
+"O c #DF421E",
+"+ c #8B8B8B",
+"@ c gray55",
+"# c #8D8D8D",
+"$ c #8E8E8E",
+"% c gray56",
+"& c #909090",
+"* c gray57",
+"= c #929292",
+"- c #939393",
+"; c gray58",
+": c #959595",
+"> c gray66",
+", c #B7B7B7",
+"< c gray74",
+"1 c #C0C0C0",
+"2 c gray79",
+"3 c #CACACA",
+"4 c gray84",
+"5 c gray85",
+"6 c #DADADA",
+"7 c #DDDDDD",
+"8 c #DFDFDF",
+"9 c gray90",
+"0 c gray91",
+"q c #E9E9E9",
+"w c #EAEAEA",
+"e c gray92",
+"r c #ECECEC",
+"t c gray93",
+"y c #EEEEEE",
+"u c #EFEFEF",
+"i c gray94",
+"p c #F1F1F1",
+"a c gray95",
+"s c #F3F3F3",
+"d c #F4F4F4",
+"f c gray96",
+"g c #F6F6F6",
+"h c gray97",
+"j c #F8F8F8",
+"k c #F9F9F9",
+"l c gray98",
+"z c #FBFBFB",
+"x c gray99",
+"c c #FDFDFD",
+"v c #FEFEFE",
+"b c white",
+/* pixels */
+" .. .. .. .. ",
+" .d3..51..7>..d,.. ",
+" .d00tttttiiiiddd4. ",
+" .d0+$$$$$$&&&$jjt. ",
+" .d00ttiiiidddjjX5. ",
+" .d0$$$&9OOOOcjj........",
+" .dttiiidddddjjjo7. .",
+" .dttiiiddddddjjc5. .",
+" .jiidddddjjjcccc7. .",
+" .ji&&&&&&;;;;;cc7. .",
+" .jiiiddddjjjjccc7. .",
+" .ji&&&&&;;;;cccc7. .",
+" .iiidddjjjjccccct. .",
+" .3tjdjjjjjccccct<. .",
+" ................ .",
+" .",
+" .",
+" . .",
+" .. .",
+" OOOOOOOOOOOOO ......",
+" OOOOOOOOOOOOO .. ",
+" . ",
+" ",
+" "
+};
diff --git a/etc/images/meta.pbm b/etc/images/meta.pbm
new file mode 100644
index 00000000000..4d4c55c85c7
--- /dev/null
+++ b/etc/images/meta.pbm
Binary files differ
diff --git a/etc/images/reveal.pbm b/etc/images/reveal.pbm
new file mode 100644
index 00000000000..79d2f1f3307
--- /dev/null
+++ b/etc/images/reveal.pbm
Binary files differ
diff --git a/etc/images/reveal.svg b/etc/images/reveal.svg
new file mode 100644
index 00000000000..41ae3733a53
--- /dev/null
+++ b/etc/images/reveal.svg
@@ -0,0 +1,4 @@
+<?xml version="1.0" encoding="UTF-8"?>
+<svg height="16px" viewBox="0 0 16 16" width="16px" xmlns="http://www.w3.org/2000/svg">
+ <path d="m 8 2 c -3.648438 0.003906 -6.832031 2.476562 -7.738281 6.007812 c 0.914062 3.527344 4.097656 5.988282 7.738281 5.992188 c 3.648438 -0.003906 6.832031 -2.476562 7.738281 -6.011719 c -0.914062 -3.523437 -4.097656 -5.984375 -7.738281 -5.988281 z m 0 2 c 2.210938 0 4 1.789062 4 4 s -1.789062 4 -4 4 s -4 -1.789062 -4 -4 s 1.789062 -4 4 -4 z m 0 2 c -1.105469 0 -2 0.894531 -2 2 s 0.894531 2 2 2 s 2 -0.894531 2 -2 s -0.894531 -2 -2 -2 z m 0 0" fill="#2e3436"/>
+</svg>
diff --git a/etc/images/shift.pbm b/etc/images/shift.pbm
new file mode 100644
index 00000000000..fbb1f4abe06
--- /dev/null
+++ b/etc/images/shift.pbm
Binary files differ
diff --git a/etc/images/super.pbm b/etc/images/super.pbm
new file mode 100644
index 00000000000..aa126755f99
--- /dev/null
+++ b/etc/images/super.pbm
Binary files differ
diff --git a/etc/images/symbols/README b/etc/images/symbols/README
new file mode 100644
index 00000000000..24429302e63
--- /dev/null
+++ b/etc/images/symbols/README
@@ -0,0 +1,43 @@
+This directory contains icons for some inline symbols.
+
+COPYRIGHT AND LICENSE INFORMATION FOR IMAGE FILES
+
+Files: *.svg
+Author: Yuan Fu <casouri@gmail.com>
+Copyright (C) 2023-2024 Free Software Foundation, Inc.
+License: GNU General Public License version 3 or later (see COPYING)
+
+How I made these icons: I made them with Figma, and exported them into
+SVG. I made the shapes with vectors (SVG paths) rather than strokes,
+merged all the shapes into a single shape with union operation, and
+stripped filling attributes from the SVG files. This way the icons can
+be colored like normal text! I'm not exactly sure how it works, but as
+long as the icon uses SVG path, and there is only one path in the
+file, and there is no filling attributes, the icons can be colored as
+text.
+
+FWIW, this is the command I used to strip filling attributes:
+
+sed -i 's/fill="none"//g' <file>
+sed -i 's/fill="black"//g' <file>
+
+Naming: Use underscore to separate styles, dash are considered normal
+character so you can use it for names. End with the intended optical
+size for the icon.
+
+There should also be an order for all the keywords. Right now we have
+directions (left/right), circle, fill, and optical size. Among them,
+the order should be
+
+1. direction
+2. circle
+3. fill
+4. size
+
+E.g., arrow_right_circle_fill_16.
+
+
+
+Every time you modify the SVG icons, please use the ImageMagick
+`convert' utility to convert them to PBM icons, for the sake of
+Emacsen that cannot display SVG images.
diff --git a/etc/images/symbols/check-mark_16.pbm b/etc/images/symbols/check-mark_16.pbm
new file mode 100644
index 00000000000..5588c0c4c01
--- /dev/null
+++ b/etc/images/symbols/check-mark_16.pbm
Binary files differ
diff --git a/etc/images/symbols/check-mark_16.svg b/etc/images/symbols/check-mark_16.svg
new file mode 100644
index 00000000000..10bf765f4d2
--- /dev/null
+++ b/etc/images/symbols/check-mark_16.svg
@@ -0,0 +1,3 @@
+<svg width="16" height="16" viewBox="0 0 16 16" xmlns="http://www.w3.org/2000/svg">
+<path d="M6.58449 9.82778L3.75736 6.99807L2.3425 8.41164L6.58321 12.6562L13.6575 5.58837L12.2439 4.17351L6.58449 9.82778Z" />
+</svg>
diff --git a/etc/images/symbols/chevron_down_16.pbm b/etc/images/symbols/chevron_down_16.pbm
new file mode 100644
index 00000000000..3d9b75d1bcc
--- /dev/null
+++ b/etc/images/symbols/chevron_down_16.pbm
Binary files differ
diff --git a/etc/images/symbols/chevron_down_16.svg b/etc/images/symbols/chevron_down_16.svg
new file mode 100644
index 00000000000..016e4a5720e
--- /dev/null
+++ b/etc/images/symbols/chevron_down_16.svg
@@ -0,0 +1,3 @@
+<svg width="16" height="16" viewBox="0 0 16 16" xmlns="http://www.w3.org/2000/svg">
+<path d="M14 4.5L14 7L8 12L2 7L2 4.5L8 9.5L14 4.5Z" />
+</svg>
diff --git a/etc/images/symbols/chevron_left_16.pbm b/etc/images/symbols/chevron_left_16.pbm
new file mode 100644
index 00000000000..d965458790d
--- /dev/null
+++ b/etc/images/symbols/chevron_left_16.pbm
Binary files differ
diff --git a/etc/images/symbols/chevron_left_16.svg b/etc/images/symbols/chevron_left_16.svg
new file mode 100644
index 00000000000..3f1d044c8ce
--- /dev/null
+++ b/etc/images/symbols/chevron_left_16.svg
@@ -0,0 +1,3 @@
+<svg width="16" height="16" viewBox="0 0 16 16" xmlns="http://www.w3.org/2000/svg">
+<path d="M11 3.05H8.5L4 8.00001L8.5 13H11L6.5 8.00001L11 3.05Z" />
+</svg>
diff --git a/etc/images/symbols/chevron_right_16.pbm b/etc/images/symbols/chevron_right_16.pbm
new file mode 100644
index 00000000000..938785dce28
--- /dev/null
+++ b/etc/images/symbols/chevron_right_16.pbm
Binary files differ
diff --git a/etc/images/symbols/chevron_right_16.svg b/etc/images/symbols/chevron_right_16.svg
new file mode 100644
index 00000000000..e2806c2a648
--- /dev/null
+++ b/etc/images/symbols/chevron_right_16.svg
@@ -0,0 +1,3 @@
+<svg width="16" height="16" viewBox="0 0 16 16" xmlns="http://www.w3.org/2000/svg">
+<path d="M4.95455 3H7.45455L12 8L7.45455 13H4.95455L9.5 8L4.95455 3Z" />
+</svg>
diff --git a/etc/images/symbols/chevron_up_16.pbm b/etc/images/symbols/chevron_up_16.pbm
new file mode 100644
index 00000000000..ae6b215b7bd
--- /dev/null
+++ b/etc/images/symbols/chevron_up_16.pbm
Binary files differ
diff --git a/etc/images/symbols/chevron_up_16.svg b/etc/images/symbols/chevron_up_16.svg
new file mode 100644
index 00000000000..1c4b9c47622
--- /dev/null
+++ b/etc/images/symbols/chevron_up_16.svg
@@ -0,0 +1,3 @@
+<svg width="16" height="16" viewBox="0 0 16 16" xmlns="http://www.w3.org/2000/svg">
+<path d="M2 11.5L2 9L8 4L14 9L14 11.5L8 6.5L2 11.5Z" />
+</svg>
diff --git a/etc/images/symbols/cross_16.pbm b/etc/images/symbols/cross_16.pbm
new file mode 100644
index 00000000000..52996cdd589
--- /dev/null
+++ b/etc/images/symbols/cross_16.pbm
Binary files differ
diff --git a/etc/images/symbols/cross_16.svg b/etc/images/symbols/cross_16.svg
new file mode 100644
index 00000000000..f210cf230b6
--- /dev/null
+++ b/etc/images/symbols/cross_16.svg
@@ -0,0 +1,3 @@
+<svg width="16" height="16" viewBox="0 0 16 16" xmlns="http://www.w3.org/2000/svg">
+<path d="M5.17157 3.75736L3.75736 5.17157L6.58579 8L3.75736 10.8284L5.17157 12.2426L8 9.41421L10.8284 12.2426L12.2426 10.8284L9.41421 8L12.2426 5.17157L10.8284 3.75736L8 6.58579L5.17157 3.75736Z" />
+</svg>
diff --git a/etc/images/symbols/cross_circle_16.pbm b/etc/images/symbols/cross_circle_16.pbm
new file mode 100644
index 00000000000..57c537b0850
--- /dev/null
+++ b/etc/images/symbols/cross_circle_16.pbm
Binary files differ
diff --git a/etc/images/symbols/cross_circle_16.svg b/etc/images/symbols/cross_circle_16.svg
new file mode 100644
index 00000000000..1c05c7d8611
--- /dev/null
+++ b/etc/images/symbols/cross_circle_16.svg
@@ -0,0 +1,3 @@
+<svg width="16" height="16" viewBox="0 0 16 16" xmlns="http://www.w3.org/2000/svg">
+<path fill-rule="evenodd" clip-rule="evenodd" d="M15 8C15 11.866 11.866 15 8 15C4.13401 15 1 11.866 1 8C1 4.13401 4.13401 1 8 1C11.866 1 15 4.13401 15 8ZM13 8C13 10.7614 10.7614 13 8 13C5.23858 13 3 10.7614 3 8C3 5.23858 5.23858 3 8 3C10.7614 3 13 5.23858 13 8ZM9.76777 4.81802L11.182 6.23223L9.41421 8L11.182 9.76777L9.76777 11.182L8 9.41421L6.23223 11.182L4.81802 9.76777L6.58579 8L4.81802 6.23223L6.23223 4.81802L8 6.58579L9.76777 4.81802Z" />
+</svg>
diff --git a/etc/images/symbols/cross_circle_fill_16.pbm b/etc/images/symbols/cross_circle_fill_16.pbm
new file mode 100644
index 00000000000..81c3d377b35
--- /dev/null
+++ b/etc/images/symbols/cross_circle_fill_16.pbm
Binary files differ
diff --git a/etc/images/symbols/cross_circle_fill_16.svg b/etc/images/symbols/cross_circle_fill_16.svg
new file mode 100644
index 00000000000..62da8aa5fda
--- /dev/null
+++ b/etc/images/symbols/cross_circle_fill_16.svg
@@ -0,0 +1,3 @@
+<svg width="16" height="16" viewBox="0 0 16 16" xmlns="http://www.w3.org/2000/svg">
+<path fill-rule="evenodd" clip-rule="evenodd" d="M8 15C11.866 15 15 11.866 15 8C15 4.13401 11.866 1 8 1C4.13401 1 1 4.13401 1 8C1 11.866 4.13401 15 8 15ZM10.1213 4.46447L11.5355 5.87868L9.41421 8L11.5355 10.1213L10.1213 11.5355L8 9.41421L5.87868 11.5355L4.46447 10.1213L6.58579 8L4.46447 5.87868L5.87868 4.46447L8 6.58579L10.1213 4.46447Z" />
+</svg>
diff --git a/etc/images/symbols/dot_large_16.pbm b/etc/images/symbols/dot_large_16.pbm
new file mode 100644
index 00000000000..03154adb813
--- /dev/null
+++ b/etc/images/symbols/dot_large_16.pbm
Binary files differ
diff --git a/etc/images/symbols/dot_large_16.svg b/etc/images/symbols/dot_large_16.svg
new file mode 100644
index 00000000000..dcc8eee380b
--- /dev/null
+++ b/etc/images/symbols/dot_large_16.svg
@@ -0,0 +1,3 @@
+<svg width="16" height="16" viewBox="0 0 16 16" xmlns="http://www.w3.org/2000/svg">
+<circle cx="8" cy="8" r="6" />
+</svg>
diff --git a/etc/images/symbols/dot_medium_16.pbm b/etc/images/symbols/dot_medium_16.pbm
new file mode 100644
index 00000000000..d5af22f50c0
--- /dev/null
+++ b/etc/images/symbols/dot_medium_16.pbm
Binary files differ
diff --git a/etc/images/symbols/dot_medium_16.svg b/etc/images/symbols/dot_medium_16.svg
new file mode 100644
index 00000000000..18250ef12c6
--- /dev/null
+++ b/etc/images/symbols/dot_medium_16.svg
@@ -0,0 +1,3 @@
+<svg width="16" height="16" viewBox="0 0 16 16" xmlns="http://www.w3.org/2000/svg">
+<circle cx="8" cy="8" r="4" />
+</svg>
diff --git a/etc/images/symbols/dot_small_16.pbm b/etc/images/symbols/dot_small_16.pbm
new file mode 100644
index 00000000000..6feef99ef53
--- /dev/null
+++ b/etc/images/symbols/dot_small_16.pbm
Binary files differ
diff --git a/etc/images/symbols/dot_small_16.svg b/etc/images/symbols/dot_small_16.svg
new file mode 100644
index 00000000000..1d6a279b5dc
--- /dev/null
+++ b/etc/images/symbols/dot_small_16.svg
@@ -0,0 +1,3 @@
+<svg width="16" height="16" viewBox="0 0 16 16" xmlns="http://www.w3.org/2000/svg">
+<circle cx="8" cy="8" r="2" />
+</svg>
diff --git a/etc/images/symbols/heart_16.pbm b/etc/images/symbols/heart_16.pbm
new file mode 100644
index 00000000000..b3a8904b6e7
--- /dev/null
+++ b/etc/images/symbols/heart_16.pbm
Binary files differ
diff --git a/etc/images/symbols/heart_16.svg b/etc/images/symbols/heart_16.svg
new file mode 100644
index 00000000000..68bd767bd32
--- /dev/null
+++ b/etc/images/symbols/heart_16.svg
@@ -0,0 +1,3 @@
+<svg width="16" height="16" viewBox="0 0 16 16" xmlns="http://www.w3.org/2000/svg">
+<path fill-rule="evenodd" clip-rule="evenodd" d="M8 5.5C8 5.5 9.5 3.5 11 3.5C12.5 3.5 14 4.5 14 6.5C14 10.1005 8 13.5 8 13.5C8 13.5 2 10.1005 2 6.5C2 4.5 3.34315 3.5 5 3.5C6.5 3.5 8 5.5 8 5.5ZM8 7.5C9 6.5 10 5.5 11 5.5C11.4898 5.5 11.738 5.65071 12 6C12.3515 6.46863 12.2982 7.40369 12 8C11 10 8 11.5 8 11.5C8 11.5 5 10 4 8C3.70858 7.41714 3.64853 6.46863 4 6C4.26197 5.65071 4.55933 5.5 5 5.5C6 5.5 7 6.5 8 7.5Z" />
+</svg>
diff --git a/etc/images/symbols/heart_fill_16.pbm b/etc/images/symbols/heart_fill_16.pbm
new file mode 100644
index 00000000000..88722ed6228
--- /dev/null
+++ b/etc/images/symbols/heart_fill_16.pbm
Binary files differ
diff --git a/etc/images/symbols/heart_fill_16.svg b/etc/images/symbols/heart_fill_16.svg
new file mode 100644
index 00000000000..e1a90a55742
--- /dev/null
+++ b/etc/images/symbols/heart_fill_16.svg
@@ -0,0 +1,3 @@
+<svg width="16" height="16" viewBox="0 0 16 16" xmlns="http://www.w3.org/2000/svg">
+<path d="M11 3.5C9.5 3.5 8 5.5 8 5.5C8 5.5 6.5 3.5 5 3.5C3.34315 3.5 2 4.5 2 6.5C2 10.1005 8 13.5 8 13.5C8 13.5 14 10.1005 14 6.5C14 4.5 12.5 3.5 11 3.5Z" />
+</svg>
diff --git a/etc/images/symbols/heart_half_16.pbm b/etc/images/symbols/heart_half_16.pbm
new file mode 100644
index 00000000000..6d5724b1aea
--- /dev/null
+++ b/etc/images/symbols/heart_half_16.pbm
Binary files differ
diff --git a/etc/images/symbols/heart_half_16.svg b/etc/images/symbols/heart_half_16.svg
new file mode 100644
index 00000000000..0ccdf620d33
--- /dev/null
+++ b/etc/images/symbols/heart_half_16.svg
@@ -0,0 +1,3 @@
+<svg width="16" height="16" viewBox="0 0 16 16" xmlns="http://www.w3.org/2000/svg">
+<path fill-rule="evenodd" clip-rule="evenodd" d="M8 5.5C8 5.5 9.5 3.5 11 3.5C12.5 3.5 14 4.5 14 6.5C14 10.1005 8 13.5 8 13.5C8 13.5 2 10.1005 2 6.5C2 4.5 3.34315 3.5 5 3.5C6.5 3.5 8 5.5 8 5.5ZM12 8C11 10 8 11.5 8 11.5V7.5C9 6.5 10 5.5 11 5.5C11.4898 5.5 11.738 5.65071 12 6C12.3515 6.46863 12.2982 7.40369 12 8Z" />
+</svg>
diff --git a/etc/images/symbols/menu_16.pbm b/etc/images/symbols/menu_16.pbm
new file mode 100644
index 00000000000..72baff379e5
--- /dev/null
+++ b/etc/images/symbols/menu_16.pbm
Binary files differ
diff --git a/etc/images/symbols/menu_16.svg b/etc/images/symbols/menu_16.svg
new file mode 100644
index 00000000000..bddc433b2eb
--- /dev/null
+++ b/etc/images/symbols/menu_16.svg
@@ -0,0 +1,3 @@
+<svg width="16" height="16" viewBox="0 0 16 16" xmlns="http://www.w3.org/2000/svg">
+<path fill-rule="evenodd" clip-rule="evenodd" d="M14 3H2V5H14V3ZM14 7H2V9H14V7ZM2 11H14V13H2V11Z" />
+</svg>
diff --git a/etc/images/symbols/minus_16.pbm b/etc/images/symbols/minus_16.pbm
new file mode 100644
index 00000000000..c564ca290d8
--- /dev/null
+++ b/etc/images/symbols/minus_16.pbm
Binary files differ
diff --git a/etc/images/symbols/minus_16.svg b/etc/images/symbols/minus_16.svg
new file mode 100644
index 00000000000..f0769763e5d
--- /dev/null
+++ b/etc/images/symbols/minus_16.svg
@@ -0,0 +1,3 @@
+<svg width="16" height="16" viewBox="0 0 16 16" xmlns="http://www.w3.org/2000/svg">
+<path d="M12.5 7H3.5V9H12.5V7Z" />
+</svg>
diff --git a/etc/images/symbols/minus_circle_16.pbm b/etc/images/symbols/minus_circle_16.pbm
new file mode 100644
index 00000000000..049bb004b0f
--- /dev/null
+++ b/etc/images/symbols/minus_circle_16.pbm
Binary files differ
diff --git a/etc/images/symbols/minus_circle_16.svg b/etc/images/symbols/minus_circle_16.svg
new file mode 100644
index 00000000000..ced8594774f
--- /dev/null
+++ b/etc/images/symbols/minus_circle_16.svg
@@ -0,0 +1,3 @@
+<svg width="16" height="16" viewBox="0 0 16 16" xmlns="http://www.w3.org/2000/svg">
+<path fill-rule="evenodd" clip-rule="evenodd" d="M15 8C15 11.866 11.866 15 8 15C4.13401 15 1 11.866 1 8C1 4.13401 4.13401 1 8 1C11.866 1 15 4.13401 15 8ZM13 8C13 10.7614 10.7614 13 8 13C5.23858 13 3 10.7614 3 8C3 5.23858 5.23858 3 8 3C10.7614 3 13 5.23858 13 8ZM11.5 7V9H4.5V7H11.5Z" />
+</svg>
diff --git a/etc/images/symbols/minus_circle_fill_16.pbm b/etc/images/symbols/minus_circle_fill_16.pbm
new file mode 100644
index 00000000000..830d2d3e5c6
--- /dev/null
+++ b/etc/images/symbols/minus_circle_fill_16.pbm
Binary files differ
diff --git a/etc/images/symbols/minus_circle_fill_16.svg b/etc/images/symbols/minus_circle_fill_16.svg
new file mode 100644
index 00000000000..e298ccaa8b2
--- /dev/null
+++ b/etc/images/symbols/minus_circle_fill_16.svg
@@ -0,0 +1,3 @@
+<svg width="16" height="16" viewBox="0 0 16 16" xmlns="http://www.w3.org/2000/svg">
+<path fill-rule="evenodd" clip-rule="evenodd" d="M8 15C11.866 15 15 11.866 15 8C15 4.13401 11.866 1 8 1C4.13401 1 1 4.13401 1 8C1 11.866 4.13401 15 8 15ZM12 7V9H4V7H12Z" />
+</svg>
diff --git a/etc/images/symbols/plus_16.pbm b/etc/images/symbols/plus_16.pbm
new file mode 100644
index 00000000000..2d8a45a5db4
--- /dev/null
+++ b/etc/images/symbols/plus_16.pbm
Binary files differ
diff --git a/etc/images/symbols/plus_16.svg b/etc/images/symbols/plus_16.svg
new file mode 100644
index 00000000000..573a5e5ca76
--- /dev/null
+++ b/etc/images/symbols/plus_16.svg
@@ -0,0 +1,3 @@
+<svg width="16" height="16" viewBox="0 0 16 16" xmlns="http://www.w3.org/2000/svg">
+<path d="M9 3.5H7V7H3.5V9H7V12.5H9V9H12.5V7H9V3.5Z" />
+</svg>
diff --git a/etc/images/symbols/plus_circle_16.pbm b/etc/images/symbols/plus_circle_16.pbm
new file mode 100644
index 00000000000..ae616fb4682
--- /dev/null
+++ b/etc/images/symbols/plus_circle_16.pbm
Binary files differ
diff --git a/etc/images/symbols/plus_circle_16.svg b/etc/images/symbols/plus_circle_16.svg
new file mode 100644
index 00000000000..921857f5a84
--- /dev/null
+++ b/etc/images/symbols/plus_circle_16.svg
@@ -0,0 +1,3 @@
+<svg width="16" height="16" viewBox="0 0 16 16" xmlns="http://www.w3.org/2000/svg">
+<path fill-rule="evenodd" clip-rule="evenodd" d="M15 8C15 11.866 11.866 15 8 15C4.13401 15 1 11.866 1 8C1 4.13401 4.13401 1 8 1C11.866 1 15 4.13401 15 8ZM13 8C13 10.7614 10.7614 13 8 13C5.23858 13 3 10.7614 3 8C3 5.23858 5.23858 3 8 3C10.7614 3 13 5.23858 13 8ZM7 7V4.5H9V7H11.5V9H9V11.5H7V9H4.5V7H7Z" />
+</svg>
diff --git a/etc/images/symbols/plus_circle_fill_16.pbm b/etc/images/symbols/plus_circle_fill_16.pbm
new file mode 100644
index 00000000000..b0e52cdaa08
--- /dev/null
+++ b/etc/images/symbols/plus_circle_fill_16.pbm
Binary files differ
diff --git a/etc/images/symbols/plus_circle_fill_16.svg b/etc/images/symbols/plus_circle_fill_16.svg
new file mode 100644
index 00000000000..7f5de4ae3a8
--- /dev/null
+++ b/etc/images/symbols/plus_circle_fill_16.svg
@@ -0,0 +1,3 @@
+<svg width="16" height="16" viewBox="0 0 16 16" xmlns="http://www.w3.org/2000/svg">
+<path fill-rule="evenodd" clip-rule="evenodd" d="M8 15C11.866 15 15 11.866 15 8C15 4.13401 11.866 1 8 1C4.13401 1 1 4.13401 1 8C1 11.866 4.13401 15 8 15ZM7 7V4H9V7H12V9H9V12H7V9H4V7H7Z" />
+</svg>
diff --git a/etc/images/symbols/star_16.pbm b/etc/images/symbols/star_16.pbm
new file mode 100644
index 00000000000..4a63706a4f7
--- /dev/null
+++ b/etc/images/symbols/star_16.pbm
Binary files differ
diff --git a/etc/images/symbols/star_16.svg b/etc/images/symbols/star_16.svg
new file mode 100644
index 00000000000..7ccbd6f01a5
--- /dev/null
+++ b/etc/images/symbols/star_16.svg
@@ -0,0 +1,3 @@
+<svg width="16" height="16" viewBox="0 0 16 16" xmlns="http://www.w3.org/2000/svg">
+<path fill-rule="evenodd" clip-rule="evenodd" d="M9.6458 5.73475L8 1L6.3542 5.73475L1.34261 5.83688L5.33704 8.86525L3.8855 13.6631L8 10.8L12.1145 13.6631L10.663 8.86525L14.6574 5.83688L9.6458 5.73475ZM8.70534 7.02918L8 5L7.29466 7.02918L5.14683 7.07295L6.85873 8.37082L6.23664 10.4271L8 9.2L9.76336 10.4271L9.14127 8.37082L10.8532 7.07295L8.70534 7.02918Z" />
+</svg>
diff --git a/etc/images/symbols/star_fill_16.pbm b/etc/images/symbols/star_fill_16.pbm
new file mode 100644
index 00000000000..9bb2a2fb15b
--- /dev/null
+++ b/etc/images/symbols/star_fill_16.pbm
Binary files differ
diff --git a/etc/images/symbols/star_fill_16.svg b/etc/images/symbols/star_fill_16.svg
new file mode 100644
index 00000000000..0e03675edd5
--- /dev/null
+++ b/etc/images/symbols/star_fill_16.svg
@@ -0,0 +1,3 @@
+<svg width="16" height="16" viewBox="0 0 16 16" xmlns="http://www.w3.org/2000/svg">
+<path d="M8 1L9.6458 5.73475L14.6574 5.83688L10.663 8.86525L12.1145 13.6631L8 10.8L3.8855 13.6631L5.33704 8.86525L1.3426 5.83688L6.3542 5.73475L8 1Z" />
+</svg>
diff --git a/etc/images/symbols/star_half_16.pbm b/etc/images/symbols/star_half_16.pbm
new file mode 100644
index 00000000000..a57fd8687e4
--- /dev/null
+++ b/etc/images/symbols/star_half_16.pbm
Binary files differ
diff --git a/etc/images/symbols/star_half_16.svg b/etc/images/symbols/star_half_16.svg
new file mode 100644
index 00000000000..6c735ad64ae
--- /dev/null
+++ b/etc/images/symbols/star_half_16.svg
@@ -0,0 +1,3 @@
+<svg width="16" height="16" viewBox="0 0 16 16" xmlns="http://www.w3.org/2000/svg">
+<path fill-rule="evenodd" clip-rule="evenodd" d="M9.72809 5.62149L8 1L6.27191 5.62149L1.34261 5.83688L5.2039 8.90851L3.8855 13.6631L8 10.94L12.1145 13.6631L10.7961 8.90851L14.6574 5.83688L9.72809 5.62149ZM10.3511 11.236L8 9.67997V3.99997L8.98747 6.64082L11.8042 6.7639L9.59777 8.51912L10.3511 11.236Z" />
+</svg>
diff --git a/etc/images/view-diff.pbm b/etc/images/view-diff.pbm
new file mode 100644
index 00000000000..35aabdabb1e
--- /dev/null
+++ b/etc/images/view-diff.pbm
Binary files differ
diff --git a/etc/images/view-diff.xpm b/etc/images/view-diff.xpm
new file mode 100644
index 00000000000..3ebd0b3002b
--- /dev/null
+++ b/etc/images/view-diff.xpm
@@ -0,0 +1,93 @@
+/* XPM */
+static char *view_diff[] = {
+/* columns rows colors chars-per-pixel */
+"24 24 63 1 ",
+" c None",
+". c black",
+"X c gray43",
+"o c #6F6F6F",
+"O c gray44",
+"+ c #717171",
+"@ c #727272",
+"# c gray45",
+"$ c #747474",
+"% c gray46",
+"& c #767676",
+"* c #777777",
+"= c gray47",
+"- c #DF421E",
+"; c #E3846E",
+": c #838383",
+"> c gray74",
+", c #E19989",
+"< c #E29A8A",
+"1 c #E39B8B",
+"2 c #E59C8B",
+"3 c #E49C8C",
+"4 c #E4AB9E",
+"5 c #E8AEA1",
+"6 c #C5C5C5",
+"7 c gray79",
+"8 c gray81",
+"9 c #DADADA",
+"0 c gray86",
+"q c #DDDDDD",
+"w c #EAD4CE",
+"e c gray88",
+"r c #E1E1E1",
+"t c #E2E2E2",
+"y c gray89",
+"u c #E4E4E4",
+"i c gray90",
+"p c #E6E6E6",
+"a c #E7E7E7",
+"s c gray91",
+"d c #E9E9E9",
+"f c #EAEAEA",
+"g c gray92",
+"h c #ECECEC",
+"j c gray93",
+"k c #EEEEEE",
+"l c #EFEFEF",
+"z c gray94",
+"x c #F1F1F1",
+"c c gray95",
+"v c #F3F3F3",
+"b c #F4F4F4",
+"n c gray96",
+"m c #F6F6F6",
+"M c gray97",
+"N c #F8F8F8",
+"B c #F9F9F9",
+"V c gray98",
+"C c #FBFBFB",
+"Z c gray99",
+"A c #FDFDFD",
+"S c #FEFEFE",
+"D c white",
+/* pixels */
+" .................... ",
+".tcccccccbbbbbbbbbbbq. ",
+".ctttttiiiidddddhhhhh. ",
+".ctttti8Xidddddhhhhcc. ",
+".cttti8XXdd+++++++ccc. ",
+".ctiiiiiXddhhhhhhcccc. ",
+".c,---id+dd++++++$ccb. ",
+".ci,--dd+dhhhhchcccbb. ",
+".bi-,-dddhh+++$cbcbbb. ",
+".b-4d3dhhhhhccccbbbbb. ",
+".b-ddhhhhhhccccbbbNNN. ",
+".b-ddhhhhccccbbbbNNNN. ",
+".b;-whh6$0cccbbbbNNNN. ",
+".bd2-5h+c$b:$$$$$=NNZ. ",
+".bhhhhccq$bbbbbNNNNZZ. ",
+".bhhhcc0$qb$$$$==NZZZ. ",
+".Nccccc$$$bNNNNNZZZZZ. ",
+".NcccbbbbbNNNZZZZZZZZ. ",
+".ccbbbbbbNNNZZZZZZZZh. ",
+".7hNbbbNNNNNZZZZZZZh>. ",
+" .................... ",
+" ",
+" ",
+" "
+};
diff --git a/etc/publicsuffix.txt b/etc/publicsuffix.txt
index 60d72fd0d53..79248a73f04 100644
--- a/etc/publicsuffix.txt
+++ b/etc/publicsuffix.txt
@@ -380,11 +380,29 @@ org.bi
// biz : https://en.wikipedia.org/wiki/.biz
biz
-// bj : https://en.wikipedia.org/wiki/.bj
+// bj : https://nic.bj/bj-suffixes.txt
+// submitted by registry <contact@nic.bj>
bj
-asso.bj
-barreau.bj
-gouv.bj
+africa.bj
+agro.bj
+architectes.bj
+assur.bj
+avocats.bj
+co.bj
+com.bj
+eco.bj
+econo.bj
+edu.bj
+info.bj
+loisirs.bj
+money.bj
+net.bj
+org.bj
+ote.bj
+resto.bj
+restaurant.bj
+tourism.bj
+univ.bj
// bm : http://www.bermudanic.bm/dnr-text.txt
bm
@@ -1033,8 +1051,7 @@ fm
// fo : https://en.wikipedia.org/wiki/.fo
fo
-// fr : http://www.afnic.fr/
-// domaines descriptifs : https://www.afnic.fr/medias/documents/Cadre_legal/Afnic_Naming_Policy_12122016_VEN.pdf
+// fr : https://www.afnic.fr/ https://www.afnic.fr/wp-media/uploads/2022/12/afnic-naming-policy-2023-01-01.pdf
fr
asso.fr
com.fr
@@ -1042,22 +1059,11 @@ gouv.fr
nom.fr
prd.fr
tm.fr
-// domaines sectoriels : https://www.afnic.fr/en/products-and-services/the-fr-tld/sector-based-fr-domains-4.html
-aeroport.fr
-avocat.fr
+// Other SLDs now selfmanaged out of AFNIC range. Former "domaines sectoriels", still registration suffixes
avoues.fr
cci.fr
-chambagri.fr
-chirurgiens-dentistes.fr
-experts-comptables.fr
-geometre-expert.fr
greta.fr
huissier-justice.fr
-medecin.fr
-notaires.fr
-pharmacien.fr
-port.fr
-veterinaire.fr
// ga : https://en.wikipedia.org/wiki/.ga
ga
@@ -4052,555 +4058,8 @@ ac.mu
co.mu
or.mu
-// museum : http://about.museum/naming/
-// http://index.museum/
+// museum : https://welcome.museum/wp-content/uploads/2018/05/20180525-Registration-Policy-MUSEUM-EN_VF-2.pdf https://welcome.museum/buy-your-dot-museum-2/
museum
-academy.museum
-agriculture.museum
-air.museum
-airguard.museum
-alabama.museum
-alaska.museum
-amber.museum
-ambulance.museum
-american.museum
-americana.museum
-americanantiques.museum
-americanart.museum
-amsterdam.museum
-and.museum
-annefrank.museum
-anthro.museum
-anthropology.museum
-antiques.museum
-aquarium.museum
-arboretum.museum
-archaeological.museum
-archaeology.museum
-architecture.museum
-art.museum
-artanddesign.museum
-artcenter.museum
-artdeco.museum
-arteducation.museum
-artgallery.museum
-arts.museum
-artsandcrafts.museum
-asmatart.museum
-assassination.museum
-assisi.museum
-association.museum
-astronomy.museum
-atlanta.museum
-austin.museum
-australia.museum
-automotive.museum
-aviation.museum
-axis.museum
-badajoz.museum
-baghdad.museum
-bahn.museum
-bale.museum
-baltimore.museum
-barcelona.museum
-baseball.museum
-basel.museum
-baths.museum
-bauern.museum
-beauxarts.museum
-beeldengeluid.museum
-bellevue.museum
-bergbau.museum
-berkeley.museum
-berlin.museum
-bern.museum
-bible.museum
-bilbao.museum
-bill.museum
-birdart.museum
-birthplace.museum
-bonn.museum
-boston.museum
-botanical.museum
-botanicalgarden.museum
-botanicgarden.museum
-botany.museum
-brandywinevalley.museum
-brasil.museum
-bristol.museum
-british.museum
-britishcolumbia.museum
-broadcast.museum
-brunel.museum
-brussel.museum
-brussels.museum
-bruxelles.museum
-building.museum
-burghof.museum
-bus.museum
-bushey.museum
-cadaques.museum
-california.museum
-cambridge.museum
-can.museum
-canada.museum
-capebreton.museum
-carrier.museum
-cartoonart.museum
-casadelamoneda.museum
-castle.museum
-castres.museum
-celtic.museum
-center.museum
-chattanooga.museum
-cheltenham.museum
-chesapeakebay.museum
-chicago.museum
-children.museum
-childrens.museum
-childrensgarden.museum
-chiropractic.museum
-chocolate.museum
-christiansburg.museum
-cincinnati.museum
-cinema.museum
-circus.museum
-civilisation.museum
-civilization.museum
-civilwar.museum
-clinton.museum
-clock.museum
-coal.museum
-coastaldefence.museum
-cody.museum
-coldwar.museum
-collection.museum
-colonialwilliamsburg.museum
-coloradoplateau.museum
-columbia.museum
-columbus.museum
-communication.museum
-communications.museum
-community.museum
-computer.museum
-computerhistory.museum
-comunicações.museum
-contemporary.museum
-contemporaryart.museum
-convent.museum
-copenhagen.museum
-corporation.museum
-correios-e-telecomunicações.museum
-corvette.museum
-costume.museum
-countryestate.museum
-county.museum
-crafts.museum
-cranbrook.museum
-creation.museum
-cultural.museum
-culturalcenter.museum
-culture.museum
-cyber.museum
-cymru.museum
-dali.museum
-dallas.museum
-database.museum
-ddr.museum
-decorativearts.museum
-delaware.museum
-delmenhorst.museum
-denmark.museum
-depot.museum
-design.museum
-detroit.museum
-dinosaur.museum
-discovery.museum
-dolls.museum
-donostia.museum
-durham.museum
-eastafrica.museum
-eastcoast.museum
-education.museum
-educational.museum
-egyptian.museum
-eisenbahn.museum
-elburg.museum
-elvendrell.museum
-embroidery.museum
-encyclopedic.museum
-england.museum
-entomology.museum
-environment.museum
-environmentalconservation.museum
-epilepsy.museum
-essex.museum
-estate.museum
-ethnology.museum
-exeter.museum
-exhibition.museum
-family.museum
-farm.museum
-farmequipment.museum
-farmers.museum
-farmstead.museum
-field.museum
-figueres.museum
-filatelia.museum
-film.museum
-fineart.museum
-finearts.museum
-finland.museum
-flanders.museum
-florida.museum
-force.museum
-fortmissoula.museum
-fortworth.museum
-foundation.museum
-francaise.museum
-frankfurt.museum
-franziskaner.museum
-freemasonry.museum
-freiburg.museum
-fribourg.museum
-frog.museum
-fundacio.museum
-furniture.museum
-gallery.museum
-garden.museum
-gateway.museum
-geelvinck.museum
-gemological.museum
-geology.museum
-georgia.museum
-giessen.museum
-glas.museum
-glass.museum
-gorge.museum
-grandrapids.museum
-graz.museum
-guernsey.museum
-halloffame.museum
-hamburg.museum
-handson.museum
-harvestcelebration.museum
-hawaii.museum
-health.museum
-heimatunduhren.museum
-hellas.museum
-helsinki.museum
-hembygdsforbund.museum
-heritage.museum
-histoire.museum
-historical.museum
-historicalsociety.museum
-historichouses.museum
-historisch.museum
-historisches.museum
-history.museum
-historyofscience.museum
-horology.museum
-house.museum
-humanities.museum
-illustration.museum
-imageandsound.museum
-indian.museum
-indiana.museum
-indianapolis.museum
-indianmarket.museum
-intelligence.museum
-interactive.museum
-iraq.museum
-iron.museum
-isleofman.museum
-jamison.museum
-jefferson.museum
-jerusalem.museum
-jewelry.museum
-jewish.museum
-jewishart.museum
-jfk.museum
-journalism.museum
-judaica.museum
-judygarland.museum
-juedisches.museum
-juif.museum
-karate.museum
-karikatur.museum
-kids.museum
-koebenhavn.museum
-koeln.museum
-kunst.museum
-kunstsammlung.museum
-kunstunddesign.museum
-labor.museum
-labour.museum
-lajolla.museum
-lancashire.museum
-landes.museum
-lans.museum
-läns.museum
-larsson.museum
-lewismiller.museum
-lincoln.museum
-linz.museum
-living.museum
-livinghistory.museum
-localhistory.museum
-london.museum
-losangeles.museum
-louvre.museum
-loyalist.museum
-lucerne.museum
-luxembourg.museum
-luzern.museum
-mad.museum
-madrid.museum
-mallorca.museum
-manchester.museum
-mansion.museum
-mansions.museum
-manx.museum
-marburg.museum
-maritime.museum
-maritimo.museum
-maryland.museum
-marylhurst.museum
-media.museum
-medical.museum
-medizinhistorisches.museum
-meeres.museum
-memorial.museum
-mesaverde.museum
-michigan.museum
-midatlantic.museum
-military.museum
-mill.museum
-miners.museum
-mining.museum
-minnesota.museum
-missile.museum
-missoula.museum
-modern.museum
-moma.museum
-money.museum
-monmouth.museum
-monticello.museum
-montreal.museum
-moscow.museum
-motorcycle.museum
-muenchen.museum
-muenster.museum
-mulhouse.museum
-muncie.museum
-museet.museum
-museumcenter.museum
-museumvereniging.museum
-music.museum
-national.museum
-nationalfirearms.museum
-nationalheritage.museum
-nativeamerican.museum
-naturalhistory.museum
-naturalhistorymuseum.museum
-naturalsciences.museum
-nature.museum
-naturhistorisches.museum
-natuurwetenschappen.museum
-naumburg.museum
-naval.museum
-nebraska.museum
-neues.museum
-newhampshire.museum
-newjersey.museum
-newmexico.museum
-newport.museum
-newspaper.museum
-newyork.museum
-niepce.museum
-norfolk.museum
-north.museum
-nrw.museum
-nyc.museum
-nyny.museum
-oceanographic.museum
-oceanographique.museum
-omaha.museum
-online.museum
-ontario.museum
-openair.museum
-oregon.museum
-oregontrail.museum
-otago.museum
-oxford.museum
-pacific.museum
-paderborn.museum
-palace.museum
-paleo.museum
-palmsprings.museum
-panama.museum
-paris.museum
-pasadena.museum
-pharmacy.museum
-philadelphia.museum
-philadelphiaarea.museum
-philately.museum
-phoenix.museum
-photography.museum
-pilots.museum
-pittsburgh.museum
-planetarium.museum
-plantation.museum
-plants.museum
-plaza.museum
-portal.museum
-portland.museum
-portlligat.museum
-posts-and-telecommunications.museum
-preservation.museum
-presidio.museum
-press.museum
-project.museum
-public.museum
-pubol.museum
-quebec.museum
-railroad.museum
-railway.museum
-research.museum
-resistance.museum
-riodejaneiro.museum
-rochester.museum
-rockart.museum
-roma.museum
-russia.museum
-saintlouis.museum
-salem.museum
-salvadordali.museum
-salzburg.museum
-sandiego.museum
-sanfrancisco.museum
-santabarbara.museum
-santacruz.museum
-santafe.museum
-saskatchewan.museum
-satx.museum
-savannahga.museum
-schlesisches.museum
-schoenbrunn.museum
-schokoladen.museum
-school.museum
-schweiz.museum
-science.museum
-scienceandhistory.museum
-scienceandindustry.museum
-sciencecenter.museum
-sciencecenters.museum
-science-fiction.museum
-sciencehistory.museum
-sciences.museum
-sciencesnaturelles.museum
-scotland.museum
-seaport.museum
-settlement.museum
-settlers.museum
-shell.museum
-sherbrooke.museum
-sibenik.museum
-silk.museum
-ski.museum
-skole.museum
-society.museum
-sologne.museum
-soundandvision.museum
-southcarolina.museum
-southwest.museum
-space.museum
-spy.museum
-square.museum
-stadt.museum
-stalbans.museum
-starnberg.museum
-state.museum
-stateofdelaware.museum
-station.museum
-steam.museum
-steiermark.museum
-stjohn.museum
-stockholm.museum
-stpetersburg.museum
-stuttgart.museum
-suisse.museum
-surgeonshall.museum
-surrey.museum
-svizzera.museum
-sweden.museum
-sydney.museum
-tank.museum
-tcm.museum
-technology.museum
-telekommunikation.museum
-television.museum
-texas.museum
-textile.museum
-theater.museum
-time.museum
-timekeeping.museum
-topology.museum
-torino.museum
-touch.museum
-town.museum
-transport.museum
-tree.museum
-trolley.museum
-trust.museum
-trustee.museum
-uhren.museum
-ulm.museum
-undersea.museum
-university.museum
-usa.museum
-usantiques.museum
-usarts.museum
-uscountryestate.museum
-usculture.museum
-usdecorativearts.museum
-usgarden.museum
-ushistory.museum
-ushuaia.museum
-uslivinghistory.museum
-utah.museum
-uvic.museum
-valley.museum
-vantaa.museum
-versailles.museum
-viking.museum
-village.museum
-virginia.museum
-virtual.museum
-virtuel.museum
-vlaanderen.museum
-volkenkunde.museum
-wales.museum
-wallonie.museum
-war.museum
-washingtondc.museum
-watchandclock.museum
-watch-and-clock.museum
-western.museum
-westfalen.museum
-whaling.museum
-wildlife.museum
-williamsburg.museum
-windmill.museum
-workshop.museum
-york.museum
-yorkshire.museum
-yosemite.museum
-youth.museum
-zoological.museum
-zoology.museum
-ירושלים.museum
-иком.museum
// mv : https://en.wikipedia.org/wiki/.mv
// "mv" included because, contra Wikipedia, google.mv exists.
@@ -5676,52 +5135,60 @@ turystyka.pl
// Government domains
gov.pl
ap.gov.pl
+griw.gov.pl
ic.gov.pl
is.gov.pl
-us.gov.pl
kmpsp.gov.pl
+konsulat.gov.pl
kppsp.gov.pl
-kwpsp.gov.pl
-psp.gov.pl
-wskr.gov.pl
kwp.gov.pl
+kwpsp.gov.pl
+mup.gov.pl
mw.gov.pl
-ug.gov.pl
-um.gov.pl
-umig.gov.pl
-ugim.gov.pl
-upow.gov.pl
-uw.gov.pl
-starostwo.gov.pl
+oia.gov.pl
+oirm.gov.pl
+oke.gov.pl
+oow.gov.pl
+oschr.gov.pl
+oum.gov.pl
pa.gov.pl
+pinb.gov.pl
+piw.gov.pl
po.gov.pl
+pr.gov.pl
+psp.gov.pl
psse.gov.pl
pup.gov.pl
rzgw.gov.pl
sa.gov.pl
+sdn.gov.pl
+sko.gov.pl
so.gov.pl
sr.gov.pl
-wsa.gov.pl
-sko.gov.pl
+starostwo.gov.pl
+ug.gov.pl
+ugim.gov.pl
+um.gov.pl
+umig.gov.pl
+upow.gov.pl
+uppo.gov.pl
+us.gov.pl
+uw.gov.pl
uzs.gov.pl
+wif.gov.pl
wiih.gov.pl
winb.gov.pl
-pinb.gov.pl
wios.gov.pl
witd.gov.pl
-wzmiuw.gov.pl
-piw.gov.pl
wiw.gov.pl
-griw.gov.pl
-wif.gov.pl
-oum.gov.pl
-sdn.gov.pl
-zp.gov.pl
-uppo.gov.pl
-mup.gov.pl
+wkz.gov.pl
+wsa.gov.pl
+wskr.gov.pl
+wsse.gov.pl
wuoz.gov.pl
-konsulat.gov.pl
-oirm.gov.pl
+wzmiuw.gov.pl
+zp.gov.pl
+zpisdn.gov.pl
// pl regional domains (http://www.dns.pl/english/index.html)
augustow.pl
babia-gora.pl
@@ -5843,7 +5310,7 @@ zarow.pl
zgora.pl
zgorzelec.pl
-// pm : http://www.afnic.fr/medias/documents/AFNIC-naming-policy2012.pdf
+// pm : https://www.afnic.fr/wp-media/uploads/2022/12/afnic-naming-policy-2023-01-01.pdf
pm
// pn : http://www.government.pn/PnRegistry/policies.htm
@@ -5941,7 +5408,7 @@ net.qa
org.qa
sch.qa
-// re : http://www.afnic.re/obtenir/chartes/nommage-re/annexe-descriptifs
+// re : https://www.afnic.fr/wp-media/uploads/2022/12/afnic-naming-policy-2023-01-01.pdf
re
asso.re
com.re
@@ -6198,7 +5665,7 @@ td
// http://www.telnic.org/
tel
-// tf : https://en.wikipedia.org/wiki/.tf
+// tf : https://www.afnic.fr/wp-media/uploads/2022/12/afnic-naming-policy-2023-01-01.pdf
tf
// tg : https://en.wikipedia.org/wiki/.tg
@@ -6406,6 +5873,7 @@ kiev.ua
kirovograd.ua
km.ua
kr.ua
+kropyvnytskyi.ua
krym.ua
ks.ua
kv.ua
@@ -6413,6 +5881,7 @@ kyiv.ua
lg.ua
lt.ua
lugansk.ua
+luhansk.ua
lutsk.ua
lv.ua
lviv.ua
@@ -6436,11 +5905,13 @@ te.ua
ternopil.ua
uz.ua
uzhgorod.ua
+uzhhorod.ua
vinnica.ua
vinnytsia.ua
vn.ua
volyn.ua
yalta.ua
+zakarpattia.ua
zaporizhzhe.ua
zaporizhzhia.ua
zhitomir.ua
@@ -6552,7 +6023,6 @@ k12.ca.us
k12.co.us
k12.ct.us
k12.dc.us
-k12.de.us
k12.fl.us
k12.ga.us
k12.gu.us
@@ -6794,20 +6264,89 @@ k12.vi
net.vi
org.vi
-// vn : https://www.dot.vn/vnnic/vnnic/domainregistration.jsp
+// vn : https://www.vnnic.vn/en/domain/cctld-vn
+// https://vnnic.vn/sites/default/files/tailieu/vn.cctld.domains.txt
vn
+ac.vn
+ai.vn
+biz.vn
com.vn
-net.vn
-org.vn
edu.vn
gov.vn
-int.vn
-ac.vn
-biz.vn
+health.vn
+id.vn
info.vn
+int.vn
+io.vn
name.vn
+net.vn
+org.vn
pro.vn
-health.vn
+
+// vn geographical names
+angiang.vn
+bacgiang.vn
+backan.vn
+baclieu.vn
+bacninh.vn
+baria-vungtau.vn
+bentre.vn
+binhdinh.vn
+binhduong.vn
+binhphuoc.vn
+binhthuan.vn
+camau.vn
+cantho.vn
+caobang.vn
+daklak.vn
+daknong.vn
+danang.vn
+dienbien.vn
+dongnai.vn
+dongthap.vn
+gialai.vn
+hagiang.vn
+haiduong.vn
+haiphong.vn
+hanam.vn
+hanoi.vn
+hatinh.vn
+haugiang.vn
+hoabinh.vn
+hungyen.vn
+khanhhoa.vn
+kiengiang.vn
+kontum.vn
+laichau.vn
+lamdong.vn
+langson.vn
+laocai.vn
+longan.vn
+namdinh.vn
+nghean.vn
+ninhbinh.vn
+ninhthuan.vn
+phutho.vn
+phuyen.vn
+quangbinh.vn
+quangnam.vn
+quangngai.vn
+quangninh.vn
+quangtri.vn
+soctrang.vn
+sonla.vn
+tayninh.vn
+thaibinh.vn
+thainguyen.vn
+thanhhoa.vn
+thanhphohochiminh.vn
+thuathienhue.vn
+tiengiang.vn
+travinh.vn
+tuyenquang.vn
+vinhlong.vn
+vinhphuc.vn
+yenbai.vn
// vu : https://en.wikipedia.org/wiki/.vu
// http://www.vunic.vu/
@@ -6817,7 +6356,7 @@ edu.vu
net.vu
org.vu
-// wf : http://www.afnic.fr/medias/documents/AFNIC-naming-policy2012.pdf
+// wf : https://www.afnic.fr/wp-media/uploads/2022/12/afnic-naming-policy-2023-01-01.pdf
wf
// ws : https://en.wikipedia.org/wiki/.ws
@@ -6829,7 +6368,7 @@ org.ws
gov.ws
edu.ws
-// yt : http://www.afnic.fr/medias/documents/AFNIC-naming-policy2012.pdf
+// yt : https://www.afnic.fr/wp-media/uploads/2022/12/afnic-naming-policy-2023-01-01.pdf
yt
// IDN ccTLDs
@@ -7171,3462 +6710,4502 @@ org.zw
// newGTLDs
-// List of new gTLDs imported from https://www.icann.org/resources/registries/gtlds/v2/gtlds.json on 2022-11-29T15:14:18Z
+// List of new gTLDs imported from https://www.icann.org/resources/registries/gtlds/v2/gtlds.json on 2023-12-06T15:14:09Z
// This list is auto-generated, don't edit it manually.
-// aaa : 2015-02-26 American Automobile Association, Inc.
+// aaa : American Automobile Association, Inc.
+// https://www.iana.org/domains/root/db/aaa.html
aaa
-// aarp : 2015-05-21 AARP
+// aarp : AARP
+// https://www.iana.org/domains/root/db/aarp.html
aarp
-// abarth : 2015-07-30 Fiat Chrysler Automobiles N.V.
-abarth
-
-// abb : 2014-10-24 ABB Ltd
+// abb : ABB Ltd
+// https://www.iana.org/domains/root/db/abb.html
abb
-// abbott : 2014-07-24 Abbott Laboratories, Inc.
+// abbott : Abbott Laboratories, Inc.
+// https://www.iana.org/domains/root/db/abbott.html
abbott
-// abbvie : 2015-07-30 AbbVie Inc.
+// abbvie : AbbVie Inc.
+// https://www.iana.org/domains/root/db/abbvie.html
abbvie
-// abc : 2015-07-30 Disney Enterprises, Inc.
+// abc : Disney Enterprises, Inc.
+// https://www.iana.org/domains/root/db/abc.html
abc
-// able : 2015-06-25 Able Inc.
+// able : Able Inc.
+// https://www.iana.org/domains/root/db/able.html
able
-// abogado : 2014-04-24 Registry Services, LLC
+// abogado : Registry Services, LLC
+// https://www.iana.org/domains/root/db/abogado.html
abogado
-// abudhabi : 2015-07-30 Abu Dhabi Systems and Information Centre
+// abudhabi : Abu Dhabi Systems and Information Centre
+// https://www.iana.org/domains/root/db/abudhabi.html
abudhabi
-// academy : 2013-11-07 Binky Moon, LLC
+// academy : Binky Moon, LLC
+// https://www.iana.org/domains/root/db/academy.html
academy
-// accenture : 2014-08-15 Accenture plc
+// accenture : Accenture plc
+// https://www.iana.org/domains/root/db/accenture.html
accenture
-// accountant : 2014-11-20 dot Accountant Limited
+// accountant : dot Accountant Limited
+// https://www.iana.org/domains/root/db/accountant.html
accountant
-// accountants : 2014-03-20 Binky Moon, LLC
+// accountants : Binky Moon, LLC
+// https://www.iana.org/domains/root/db/accountants.html
accountants
-// aco : 2015-01-08 ACO Severin Ahlmann GmbH & Co. KG
+// aco : ACO Severin Ahlmann GmbH & Co. KG
+// https://www.iana.org/domains/root/db/aco.html
aco
-// actor : 2013-12-12 Dog Beach, LLC
+// actor : Dog Beach, LLC
+// https://www.iana.org/domains/root/db/actor.html
actor
-// ads : 2014-12-04 Charleston Road Registry Inc.
+// ads : Charleston Road Registry Inc.
+// https://www.iana.org/domains/root/db/ads.html
ads
-// adult : 2014-10-16 ICM Registry AD LLC
+// adult : ICM Registry AD LLC
+// https://www.iana.org/domains/root/db/adult.html
adult
-// aeg : 2015-03-19 Aktiebolaget Electrolux
+// aeg : Aktiebolaget Electrolux
+// https://www.iana.org/domains/root/db/aeg.html
aeg
-// aetna : 2015-05-21 Aetna Life Insurance Company
+// aetna : Aetna Life Insurance Company
+// https://www.iana.org/domains/root/db/aetna.html
aetna
-// afl : 2014-10-02 Australian Football League
+// afl : Australian Football League
+// https://www.iana.org/domains/root/db/afl.html
afl
-// africa : 2014-03-24 ZA Central Registry NPC trading as Registry.Africa
+// africa : ZA Central Registry NPC trading as Registry.Africa
+// https://www.iana.org/domains/root/db/africa.html
africa
-// agakhan : 2015-04-23 Fondation Aga Khan (Aga Khan Foundation)
+// agakhan : Fondation Aga Khan (Aga Khan Foundation)
+// https://www.iana.org/domains/root/db/agakhan.html
agakhan
-// agency : 2013-11-14 Binky Moon, LLC
+// agency : Binky Moon, LLC
+// https://www.iana.org/domains/root/db/agency.html
agency
-// aig : 2014-12-18 American International Group, Inc.
+// aig : American International Group, Inc.
+// https://www.iana.org/domains/root/db/aig.html
aig
-// airbus : 2015-07-30 Airbus S.A.S.
+// airbus : Airbus S.A.S.
+// https://www.iana.org/domains/root/db/airbus.html
airbus
-// airforce : 2014-03-06 Dog Beach, LLC
+// airforce : Dog Beach, LLC
+// https://www.iana.org/domains/root/db/airforce.html
airforce
-// airtel : 2014-10-24 Bharti Airtel Limited
+// airtel : Bharti Airtel Limited
+// https://www.iana.org/domains/root/db/airtel.html
airtel
-// akdn : 2015-04-23 Fondation Aga Khan (Aga Khan Foundation)
+// akdn : Fondation Aga Khan (Aga Khan Foundation)
+// https://www.iana.org/domains/root/db/akdn.html
akdn
-// alfaromeo : 2015-07-31 Fiat Chrysler Automobiles N.V.
-alfaromeo
-
-// alibaba : 2015-01-15 Alibaba Group Holding Limited
+// alibaba : Alibaba Group Holding Limited
+// https://www.iana.org/domains/root/db/alibaba.html
alibaba
-// alipay : 2015-01-15 Alibaba Group Holding Limited
+// alipay : Alibaba Group Holding Limited
+// https://www.iana.org/domains/root/db/alipay.html
alipay
-// allfinanz : 2014-07-03 Allfinanz Deutsche Vermögensberatung Aktiengesellschaft
+// allfinanz : Allfinanz Deutsche Vermögensberatung Aktiengesellschaft
+// https://www.iana.org/domains/root/db/allfinanz.html
allfinanz
-// allstate : 2015-07-31 Allstate Fire and Casualty Insurance Company
+// allstate : Allstate Fire and Casualty Insurance Company
+// https://www.iana.org/domains/root/db/allstate.html
allstate
-// ally : 2015-06-18 Ally Financial Inc.
+// ally : Ally Financial Inc.
+// https://www.iana.org/domains/root/db/ally.html
ally
-// alsace : 2014-07-02 Region Grand Est
+// alsace : Region Grand Est
+// https://www.iana.org/domains/root/db/alsace.html
alsace
-// alstom : 2015-07-30 ALSTOM
+// alstom : ALSTOM
+// https://www.iana.org/domains/root/db/alstom.html
alstom
-// amazon : 2019-12-19 Amazon Registry Services, Inc.
+// amazon : Amazon Registry Services, Inc.
+// https://www.iana.org/domains/root/db/amazon.html
amazon
-// americanexpress : 2015-07-31 American Express Travel Related Services Company, Inc.
+// americanexpress : American Express Travel Related Services Company, Inc.
+// https://www.iana.org/domains/root/db/americanexpress.html
americanexpress
-// americanfamily : 2015-07-23 AmFam, Inc.
+// americanfamily : AmFam, Inc.
+// https://www.iana.org/domains/root/db/americanfamily.html
americanfamily
-// amex : 2015-07-31 American Express Travel Related Services Company, Inc.
+// amex : American Express Travel Related Services Company, Inc.
+// https://www.iana.org/domains/root/db/amex.html
amex
-// amfam : 2015-07-23 AmFam, Inc.
+// amfam : AmFam, Inc.
+// https://www.iana.org/domains/root/db/amfam.html
amfam
-// amica : 2015-05-28 Amica Mutual Insurance Company
+// amica : Amica Mutual Insurance Company
+// https://www.iana.org/domains/root/db/amica.html
amica
-// amsterdam : 2014-07-24 Gemeente Amsterdam
+// amsterdam : Gemeente Amsterdam
+// https://www.iana.org/domains/root/db/amsterdam.html
amsterdam
-// analytics : 2014-12-18 Campus IP LLC
+// analytics : Campus IP LLC
+// https://www.iana.org/domains/root/db/analytics.html
analytics
-// android : 2014-08-07 Charleston Road Registry Inc.
+// android : Charleston Road Registry Inc.
+// https://www.iana.org/domains/root/db/android.html
android
-// anquan : 2015-01-08 Beijing Qihu Keji Co., Ltd.
+// anquan : Beijing Qihu Keji Co., Ltd.
+// https://www.iana.org/domains/root/db/anquan.html
anquan
-// anz : 2015-07-31 Australia and New Zealand Banking Group Limited
+// anz : Australia and New Zealand Banking Group Limited
+// https://www.iana.org/domains/root/db/anz.html
anz
-// aol : 2015-09-17 Oath Inc.
+// aol : Oath Inc.
+// https://www.iana.org/domains/root/db/aol.html
aol
-// apartments : 2014-12-11 Binky Moon, LLC
+// apartments : Binky Moon, LLC
+// https://www.iana.org/domains/root/db/apartments.html
apartments
-// app : 2015-05-14 Charleston Road Registry Inc.
+// app : Charleston Road Registry Inc.
+// https://www.iana.org/domains/root/db/app.html
app
-// apple : 2015-05-14 Apple Inc.
+// apple : Apple Inc.
+// https://www.iana.org/domains/root/db/apple.html
apple
-// aquarelle : 2014-07-24 Aquarelle.com
+// aquarelle : Aquarelle.com
+// https://www.iana.org/domains/root/db/aquarelle.html
aquarelle
-// arab : 2015-11-12 League of Arab States
+// arab : League of Arab States
+// https://www.iana.org/domains/root/db/arab.html
arab
-// aramco : 2014-11-20 Aramco Services Company
+// aramco : Aramco Services Company
+// https://www.iana.org/domains/root/db/aramco.html
aramco
-// archi : 2014-02-06 Identity Digital Limited
+// archi : Identity Digital Limited
+// https://www.iana.org/domains/root/db/archi.html
archi
-// army : 2014-03-06 Dog Beach, LLC
+// army : Dog Beach, LLC
+// https://www.iana.org/domains/root/db/army.html
army
-// art : 2016-03-24 UK Creative Ideas Limited
+// art : UK Creative Ideas Limited
+// https://www.iana.org/domains/root/db/art.html
art
-// arte : 2014-12-11 Association Relative à la Télévision Européenne G.E.I.E.
+// arte : Association Relative à la Télévision Européenne G.E.I.E.
+// https://www.iana.org/domains/root/db/arte.html
arte
-// asda : 2015-07-31 Wal-Mart Stores, Inc.
+// asda : Wal-Mart Stores, Inc.
+// https://www.iana.org/domains/root/db/asda.html
asda
-// associates : 2014-03-06 Binky Moon, LLC
+// associates : Binky Moon, LLC
+// https://www.iana.org/domains/root/db/associates.html
associates
-// athleta : 2015-07-30 The Gap, Inc.
+// athleta : The Gap, Inc.
+// https://www.iana.org/domains/root/db/athleta.html
athleta
-// attorney : 2014-03-20 Dog Beach, LLC
+// attorney : Dog Beach, LLC
+// https://www.iana.org/domains/root/db/attorney.html
attorney
-// auction : 2014-03-20 Dog Beach, LLC
+// auction : Dog Beach, LLC
+// https://www.iana.org/domains/root/db/auction.html
auction
-// audi : 2015-05-21 AUDI Aktiengesellschaft
+// audi : AUDI Aktiengesellschaft
+// https://www.iana.org/domains/root/db/audi.html
audi
-// audible : 2015-06-25 Amazon Registry Services, Inc.
+// audible : Amazon Registry Services, Inc.
+// https://www.iana.org/domains/root/db/audible.html
audible
-// audio : 2014-03-20 XYZ.COM LLC
+// audio : XYZ.COM LLC
+// https://www.iana.org/domains/root/db/audio.html
audio
-// auspost : 2015-08-13 Australian Postal Corporation
+// auspost : Australian Postal Corporation
+// https://www.iana.org/domains/root/db/auspost.html
auspost
-// author : 2014-12-18 Amazon Registry Services, Inc.
+// author : Amazon Registry Services, Inc.
+// https://www.iana.org/domains/root/db/author.html
author
-// auto : 2014-11-13 XYZ.COM LLC
+// auto : XYZ.COM LLC
+// https://www.iana.org/domains/root/db/auto.html
auto
-// autos : 2014-01-09 XYZ.COM LLC
+// autos : XYZ.COM LLC
+// https://www.iana.org/domains/root/db/autos.html
autos
-// avianca : 2015-01-08 Avianca Inc.
+// avianca : Avianca Inc.
+// https://www.iana.org/domains/root/db/avianca.html
avianca
-// aws : 2015-06-25 AWS Registry LLC
+// aws : AWS Registry LLC
+// https://www.iana.org/domains/root/db/aws.html
aws
-// axa : 2013-12-19 AXA Group Operations SAS
+// axa : AXA Group Operations SAS
+// https://www.iana.org/domains/root/db/axa.html
axa
-// azure : 2014-12-18 Microsoft Corporation
+// azure : Microsoft Corporation
+// https://www.iana.org/domains/root/db/azure.html
azure
-// baby : 2015-04-09 XYZ.COM LLC
+// baby : XYZ.COM LLC
+// https://www.iana.org/domains/root/db/baby.html
baby
-// baidu : 2015-01-08 Baidu, Inc.
+// baidu : Baidu, Inc.
+// https://www.iana.org/domains/root/db/baidu.html
baidu
-// banamex : 2015-07-30 Citigroup Inc.
+// banamex : Citigroup Inc.
+// https://www.iana.org/domains/root/db/banamex.html
banamex
-// bananarepublic : 2015-07-31 The Gap, Inc.
+// bananarepublic : The Gap, Inc.
+// https://www.iana.org/domains/root/db/bananarepublic.html
bananarepublic
-// band : 2014-06-12 Dog Beach, LLC
+// band : Dog Beach, LLC
+// https://www.iana.org/domains/root/db/band.html
band
-// bank : 2014-09-25 fTLD Registry Services LLC
+// bank : fTLD Registry Services LLC
+// https://www.iana.org/domains/root/db/bank.html
bank
-// bar : 2013-12-12 Punto 2012 Sociedad Anonima Promotora de Inversion de Capital Variable
+// bar : Punto 2012 Sociedad Anonima Promotora de Inversion de Capital Variable
+// https://www.iana.org/domains/root/db/bar.html
bar
-// barcelona : 2014-07-24 Municipi de Barcelona
+// barcelona : Municipi de Barcelona
+// https://www.iana.org/domains/root/db/barcelona.html
barcelona
-// barclaycard : 2014-11-20 Barclays Bank PLC
+// barclaycard : Barclays Bank PLC
+// https://www.iana.org/domains/root/db/barclaycard.html
barclaycard
-// barclays : 2014-11-20 Barclays Bank PLC
+// barclays : Barclays Bank PLC
+// https://www.iana.org/domains/root/db/barclays.html
barclays
-// barefoot : 2015-06-11 Gallo Vineyards, Inc.
+// barefoot : Gallo Vineyards, Inc.
+// https://www.iana.org/domains/root/db/barefoot.html
barefoot
-// bargains : 2013-11-14 Binky Moon, LLC
+// bargains : Binky Moon, LLC
+// https://www.iana.org/domains/root/db/bargains.html
bargains
-// baseball : 2015-10-29 MLB Advanced Media DH, LLC
+// baseball : MLB Advanced Media DH, LLC
+// https://www.iana.org/domains/root/db/baseball.html
baseball
-// basketball : 2015-08-20 Fédération Internationale de Basketball (FIBA)
+// basketball : Fédération Internationale de Basketball (FIBA)
+// https://www.iana.org/domains/root/db/basketball.html
basketball
-// bauhaus : 2014-04-17 Werkhaus GmbH
+// bauhaus : Werkhaus GmbH
+// https://www.iana.org/domains/root/db/bauhaus.html
bauhaus
-// bayern : 2014-01-23 Bayern Connect GmbH
+// bayern : Bayern Connect GmbH
+// https://www.iana.org/domains/root/db/bayern.html
bayern
-// bbc : 2014-12-18 British Broadcasting Corporation
+// bbc : British Broadcasting Corporation
+// https://www.iana.org/domains/root/db/bbc.html
bbc
-// bbt : 2015-07-23 BB&T Corporation
+// bbt : BB&T Corporation
+// https://www.iana.org/domains/root/db/bbt.html
bbt
-// bbva : 2014-10-02 BANCO BILBAO VIZCAYA ARGENTARIA, S.A.
+// bbva : BANCO BILBAO VIZCAYA ARGENTARIA, S.A.
+// https://www.iana.org/domains/root/db/bbva.html
bbva
-// bcg : 2015-04-02 The Boston Consulting Group, Inc.
+// bcg : The Boston Consulting Group, Inc.
+// https://www.iana.org/domains/root/db/bcg.html
bcg
-// bcn : 2014-07-24 Municipi de Barcelona
+// bcn : Municipi de Barcelona
+// https://www.iana.org/domains/root/db/bcn.html
bcn
-// beats : 2015-05-14 Beats Electronics, LLC
+// beats : Beats Electronics, LLC
+// https://www.iana.org/domains/root/db/beats.html
beats
-// beauty : 2015-12-03 XYZ.COM LLC
+// beauty : XYZ.COM LLC
+// https://www.iana.org/domains/root/db/beauty.html
beauty
-// beer : 2014-01-09 Registry Services, LLC
+// beer : Registry Services, LLC
+// https://www.iana.org/domains/root/db/beer.html
beer
-// bentley : 2014-12-18 Bentley Motors Limited
+// bentley : Bentley Motors Limited
+// https://www.iana.org/domains/root/db/bentley.html
bentley
-// berlin : 2013-10-31 dotBERLIN GmbH & Co. KG
+// berlin : dotBERLIN GmbH & Co. KG
+// https://www.iana.org/domains/root/db/berlin.html
berlin
-// best : 2013-12-19 BestTLD Pty Ltd
+// best : BestTLD Pty Ltd
+// https://www.iana.org/domains/root/db/best.html
best
-// bestbuy : 2015-07-31 BBY Solutions, Inc.
+// bestbuy : BBY Solutions, Inc.
+// https://www.iana.org/domains/root/db/bestbuy.html
bestbuy
-// bet : 2015-05-07 Identity Digital Limited
+// bet : Identity Digital Limited
+// https://www.iana.org/domains/root/db/bet.html
bet
-// bharti : 2014-01-09 Bharti Enterprises (Holding) Private Limited
+// bharti : Bharti Enterprises (Holding) Private Limited
+// https://www.iana.org/domains/root/db/bharti.html
bharti
-// bible : 2014-06-19 American Bible Society
+// bible : American Bible Society
+// https://www.iana.org/domains/root/db/bible.html
bible
-// bid : 2013-12-19 dot Bid Limited
+// bid : dot Bid Limited
+// https://www.iana.org/domains/root/db/bid.html
bid
-// bike : 2013-08-27 Binky Moon, LLC
+// bike : Binky Moon, LLC
+// https://www.iana.org/domains/root/db/bike.html
bike
-// bing : 2014-12-18 Microsoft Corporation
+// bing : Microsoft Corporation
+// https://www.iana.org/domains/root/db/bing.html
bing
-// bingo : 2014-12-04 Binky Moon, LLC
+// bingo : Binky Moon, LLC
+// https://www.iana.org/domains/root/db/bingo.html
bingo
-// bio : 2014-03-06 Identity Digital Limited
+// bio : Identity Digital Limited
+// https://www.iana.org/domains/root/db/bio.html
bio
-// black : 2014-01-16 Identity Digital Limited
+// black : Identity Digital Limited
+// https://www.iana.org/domains/root/db/black.html
black
-// blackfriday : 2014-01-16 Registry Services, LLC
+// blackfriday : Registry Services, LLC
+// https://www.iana.org/domains/root/db/blackfriday.html
blackfriday
-// blockbuster : 2015-07-30 Dish DBS Corporation
+// blockbuster : Dish DBS Corporation
+// https://www.iana.org/domains/root/db/blockbuster.html
blockbuster
-// blog : 2015-05-14 Knock Knock WHOIS There, LLC
+// blog : Knock Knock WHOIS There, LLC
+// https://www.iana.org/domains/root/db/blog.html
blog
-// bloomberg : 2014-07-17 Bloomberg IP Holdings LLC
+// bloomberg : Bloomberg IP Holdings LLC
+// https://www.iana.org/domains/root/db/bloomberg.html
bloomberg
-// blue : 2013-11-07 Identity Digital Limited
+// blue : Identity Digital Limited
+// https://www.iana.org/domains/root/db/blue.html
blue
-// bms : 2014-10-30 Bristol-Myers Squibb Company
+// bms : Bristol-Myers Squibb Company
+// https://www.iana.org/domains/root/db/bms.html
bms
-// bmw : 2014-01-09 Bayerische Motoren Werke Aktiengesellschaft
+// bmw : Bayerische Motoren Werke Aktiengesellschaft
+// https://www.iana.org/domains/root/db/bmw.html
bmw
-// bnpparibas : 2014-05-29 BNP Paribas
+// bnpparibas : BNP Paribas
+// https://www.iana.org/domains/root/db/bnpparibas.html
bnpparibas
-// boats : 2014-12-04 XYZ.COM LLC
+// boats : XYZ.COM LLC
+// https://www.iana.org/domains/root/db/boats.html
boats
-// boehringer : 2015-07-09 Boehringer Ingelheim International GmbH
+// boehringer : Boehringer Ingelheim International GmbH
+// https://www.iana.org/domains/root/db/boehringer.html
boehringer
-// bofa : 2015-07-31 Bank of America Corporation
+// bofa : Bank of America Corporation
+// https://www.iana.org/domains/root/db/bofa.html
bofa
-// bom : 2014-10-16 Núcleo de Informação e Coordenação do Ponto BR - NIC.br
+// bom : Núcleo de Informação e Coordenação do Ponto BR - NIC.br
+// https://www.iana.org/domains/root/db/bom.html
bom
-// bond : 2014-06-05 ShortDot SA
+// bond : ShortDot SA
+// https://www.iana.org/domains/root/db/bond.html
bond
-// boo : 2014-01-30 Charleston Road Registry Inc.
+// boo : Charleston Road Registry Inc.
+// https://www.iana.org/domains/root/db/boo.html
boo
-// book : 2015-08-27 Amazon Registry Services, Inc.
+// book : Amazon Registry Services, Inc.
+// https://www.iana.org/domains/root/db/book.html
book
-// booking : 2015-07-16 Booking.com B.V.
+// booking : Booking.com B.V.
+// https://www.iana.org/domains/root/db/booking.html
booking
-// bosch : 2015-06-18 Robert Bosch GMBH
+// bosch : Robert Bosch GMBH
+// https://www.iana.org/domains/root/db/bosch.html
bosch
-// bostik : 2015-05-28 Bostik SA
+// bostik : Bostik SA
+// https://www.iana.org/domains/root/db/bostik.html
bostik
-// boston : 2015-12-10 Registry Services, LLC
+// boston : Registry Services, LLC
+// https://www.iana.org/domains/root/db/boston.html
boston
-// bot : 2014-12-18 Amazon Registry Services, Inc.
+// bot : Amazon Registry Services, Inc.
+// https://www.iana.org/domains/root/db/bot.html
bot
-// boutique : 2013-11-14 Binky Moon, LLC
+// boutique : Binky Moon, LLC
+// https://www.iana.org/domains/root/db/boutique.html
boutique
-// box : 2015-11-12 Intercap Registry Inc.
+// box : Intercap Registry Inc.
+// https://www.iana.org/domains/root/db/box.html
box
-// bradesco : 2014-12-18 Banco Bradesco S.A.
+// bradesco : Banco Bradesco S.A.
+// https://www.iana.org/domains/root/db/bradesco.html
bradesco
-// bridgestone : 2014-12-18 Bridgestone Corporation
+// bridgestone : Bridgestone Corporation
+// https://www.iana.org/domains/root/db/bridgestone.html
bridgestone
-// broadway : 2014-12-22 Celebrate Broadway, Inc.
+// broadway : Celebrate Broadway, Inc.
+// https://www.iana.org/domains/root/db/broadway.html
broadway
-// broker : 2014-12-11 Dog Beach, LLC
+// broker : Dog Beach, LLC
+// https://www.iana.org/domains/root/db/broker.html
broker
-// brother : 2015-01-29 Brother Industries, Ltd.
+// brother : Brother Industries, Ltd.
+// https://www.iana.org/domains/root/db/brother.html
brother
-// brussels : 2014-02-06 DNS.be vzw
+// brussels : DNS.be vzw
+// https://www.iana.org/domains/root/db/brussels.html
brussels
-// build : 2013-11-07 Plan Bee LLC
+// build : Plan Bee LLC
+// https://www.iana.org/domains/root/db/build.html
build
-// builders : 2013-11-07 Binky Moon, LLC
+// builders : Binky Moon, LLC
+// https://www.iana.org/domains/root/db/builders.html
builders
-// business : 2013-11-07 Binky Moon, LLC
+// business : Binky Moon, LLC
+// https://www.iana.org/domains/root/db/business.html
business
-// buy : 2014-12-18 Amazon Registry Services, Inc.
+// buy : Amazon Registry Services, Inc.
+// https://www.iana.org/domains/root/db/buy.html
buy
-// buzz : 2013-10-02 DOTSTRATEGY CO.
+// buzz : DOTSTRATEGY CO.
+// https://www.iana.org/domains/root/db/buzz.html
buzz
-// bzh : 2014-02-27 Association www.bzh
+// bzh : Association www.bzh
+// https://www.iana.org/domains/root/db/bzh.html
bzh
-// cab : 2013-10-24 Binky Moon, LLC
+// cab : Binky Moon, LLC
+// https://www.iana.org/domains/root/db/cab.html
cab
-// cafe : 2015-02-11 Binky Moon, LLC
+// cafe : Binky Moon, LLC
+// https://www.iana.org/domains/root/db/cafe.html
cafe
-// cal : 2014-07-24 Charleston Road Registry Inc.
+// cal : Charleston Road Registry Inc.
+// https://www.iana.org/domains/root/db/cal.html
cal
-// call : 2014-12-18 Amazon Registry Services, Inc.
+// call : Amazon Registry Services, Inc.
+// https://www.iana.org/domains/root/db/call.html
call
-// calvinklein : 2015-07-30 PVH gTLD Holdings LLC
+// calvinklein : PVH gTLD Holdings LLC
+// https://www.iana.org/domains/root/db/calvinklein.html
calvinklein
-// cam : 2016-04-21 Cam Connecting SARL
+// cam : Cam Connecting SARL
+// https://www.iana.org/domains/root/db/cam.html
cam
-// camera : 2013-08-27 Binky Moon, LLC
+// camera : Binky Moon, LLC
+// https://www.iana.org/domains/root/db/camera.html
camera
-// camp : 2013-11-07 Binky Moon, LLC
+// camp : Binky Moon, LLC
+// https://www.iana.org/domains/root/db/camp.html
camp
-// canon : 2014-09-12 Canon Inc.
+// canon : Canon Inc.
+// https://www.iana.org/domains/root/db/canon.html
canon
-// capetown : 2014-03-24 ZA Central Registry NPC trading as ZA Central Registry
+// capetown : ZA Central Registry NPC trading as ZA Central Registry
+// https://www.iana.org/domains/root/db/capetown.html
capetown
-// capital : 2014-03-06 Binky Moon, LLC
+// capital : Binky Moon, LLC
+// https://www.iana.org/domains/root/db/capital.html
capital
-// capitalone : 2015-08-06 Capital One Financial Corporation
+// capitalone : Capital One Financial Corporation
+// https://www.iana.org/domains/root/db/capitalone.html
capitalone
-// car : 2015-01-22 XYZ.COM LLC
+// car : XYZ.COM LLC
+// https://www.iana.org/domains/root/db/car.html
car
-// caravan : 2013-12-12 Caravan International, Inc.
+// caravan : Caravan International, Inc.
+// https://www.iana.org/domains/root/db/caravan.html
caravan
-// cards : 2013-12-05 Binky Moon, LLC
+// cards : Binky Moon, LLC
+// https://www.iana.org/domains/root/db/cards.html
cards
-// care : 2014-03-06 Binky Moon, LLC
+// care : Binky Moon, LLC
+// https://www.iana.org/domains/root/db/care.html
care
-// career : 2013-10-09 dotCareer LLC
+// career : dotCareer LLC
+// https://www.iana.org/domains/root/db/career.html
career
-// careers : 2013-10-02 Binky Moon, LLC
+// careers : Binky Moon, LLC
+// https://www.iana.org/domains/root/db/careers.html
careers
-// cars : 2014-11-13 XYZ.COM LLC
+// cars : XYZ.COM LLC
+// https://www.iana.org/domains/root/db/cars.html
cars
-// casa : 2013-11-21 Registry Services, LLC
+// casa : Registry Services, LLC
+// https://www.iana.org/domains/root/db/casa.html
casa
-// case : 2015-09-03 Digity, LLC
+// case : Digity, LLC
+// https://www.iana.org/domains/root/db/case.html
case
-// cash : 2014-03-06 Binky Moon, LLC
+// cash : Binky Moon, LLC
+// https://www.iana.org/domains/root/db/cash.html
cash
-// casino : 2014-12-18 Binky Moon, LLC
+// casino : Binky Moon, LLC
+// https://www.iana.org/domains/root/db/casino.html
casino
-// catering : 2013-12-05 Binky Moon, LLC
+// catering : Binky Moon, LLC
+// https://www.iana.org/domains/root/db/catering.html
catering
-// catholic : 2015-10-21 Pontificium Consilium de Comunicationibus Socialibus (PCCS) (Pontifical Council for Social Communication)
+// catholic : Pontificium Consilium de Comunicationibus Socialibus (PCCS) (Pontifical Council for Social Communication)
+// https://www.iana.org/domains/root/db/catholic.html
catholic
-// cba : 2014-06-26 COMMONWEALTH BANK OF AUSTRALIA
+// cba : COMMONWEALTH BANK OF AUSTRALIA
+// https://www.iana.org/domains/root/db/cba.html
cba
-// cbn : 2014-08-22 The Christian Broadcasting Network, Inc.
+// cbn : The Christian Broadcasting Network, Inc.
+// https://www.iana.org/domains/root/db/cbn.html
cbn
-// cbre : 2015-07-02 CBRE, Inc.
+// cbre : CBRE, Inc.
+// https://www.iana.org/domains/root/db/cbre.html
cbre
-// cbs : 2015-08-06 CBS Domains Inc.
-cbs
-
-// center : 2013-11-07 Binky Moon, LLC
+// center : Binky Moon, LLC
+// https://www.iana.org/domains/root/db/center.html
center
-// ceo : 2013-11-07 CEOTLD Pty Ltd
+// ceo : XYZ.COM LLC
+// https://www.iana.org/domains/root/db/ceo.html
ceo
-// cern : 2014-06-05 European Organization for Nuclear Research ("CERN")
+// cern : European Organization for Nuclear Research ("CERN")
+// https://www.iana.org/domains/root/db/cern.html
cern
-// cfa : 2014-08-28 CFA Institute
+// cfa : CFA Institute
+// https://www.iana.org/domains/root/db/cfa.html
cfa
-// cfd : 2014-12-11 ShortDot SA
+// cfd : ShortDot SA
+// https://www.iana.org/domains/root/db/cfd.html
cfd
-// chanel : 2015-04-09 Chanel International B.V.
+// chanel : Chanel International B.V.
+// https://www.iana.org/domains/root/db/chanel.html
chanel
-// channel : 2014-05-08 Charleston Road Registry Inc.
+// channel : Charleston Road Registry Inc.
+// https://www.iana.org/domains/root/db/channel.html
channel
-// charity : 2018-04-11 Public Interest Registry
+// charity : Public Interest Registry
+// https://www.iana.org/domains/root/db/charity.html
charity
-// chase : 2015-04-30 JPMorgan Chase Bank, National Association
+// chase : JPMorgan Chase Bank, National Association
+// https://www.iana.org/domains/root/db/chase.html
chase
-// chat : 2014-12-04 Binky Moon, LLC
+// chat : Binky Moon, LLC
+// https://www.iana.org/domains/root/db/chat.html
chat
-// cheap : 2013-11-14 Binky Moon, LLC
+// cheap : Binky Moon, LLC
+// https://www.iana.org/domains/root/db/cheap.html
cheap
-// chintai : 2015-06-11 CHINTAI Corporation
+// chintai : CHINTAI Corporation
+// https://www.iana.org/domains/root/db/chintai.html
chintai
-// christmas : 2013-11-21 XYZ.COM LLC
+// christmas : XYZ.COM LLC
+// https://www.iana.org/domains/root/db/christmas.html
christmas
-// chrome : 2014-07-24 Charleston Road Registry Inc.
+// chrome : Charleston Road Registry Inc.
+// https://www.iana.org/domains/root/db/chrome.html
chrome
-// church : 2014-02-06 Binky Moon, LLC
+// church : Binky Moon, LLC
+// https://www.iana.org/domains/root/db/church.html
church
-// cipriani : 2015-02-19 Hotel Cipriani Srl
+// cipriani : Hotel Cipriani Srl
+// https://www.iana.org/domains/root/db/cipriani.html
cipriani
-// circle : 2014-12-18 Amazon Registry Services, Inc.
+// circle : Amazon Registry Services, Inc.
+// https://www.iana.org/domains/root/db/circle.html
circle
-// cisco : 2014-12-22 Cisco Technology, Inc.
+// cisco : Cisco Technology, Inc.
+// https://www.iana.org/domains/root/db/cisco.html
cisco
-// citadel : 2015-07-23 Citadel Domain LLC
+// citadel : Citadel Domain LLC
+// https://www.iana.org/domains/root/db/citadel.html
citadel
-// citi : 2015-07-30 Citigroup Inc.
+// citi : Citigroup Inc.
+// https://www.iana.org/domains/root/db/citi.html
citi
-// citic : 2014-01-09 CITIC Group Corporation
+// citic : CITIC Group Corporation
+// https://www.iana.org/domains/root/db/citic.html
citic
-// city : 2014-05-29 Binky Moon, LLC
+// city : Binky Moon, LLC
+// https://www.iana.org/domains/root/db/city.html
city
-// cityeats : 2014-12-11 Lifestyle Domain Holdings, Inc.
-cityeats
-
-// claims : 2014-03-20 Binky Moon, LLC
+// claims : Binky Moon, LLC
+// https://www.iana.org/domains/root/db/claims.html
claims
-// cleaning : 2013-12-05 Binky Moon, LLC
+// cleaning : Binky Moon, LLC
+// https://www.iana.org/domains/root/db/cleaning.html
cleaning
-// click : 2014-06-05 Internet Naming Company LLC
+// click : Internet Naming Company LLC
+// https://www.iana.org/domains/root/db/click.html
click
-// clinic : 2014-03-20 Binky Moon, LLC
+// clinic : Binky Moon, LLC
+// https://www.iana.org/domains/root/db/clinic.html
clinic
-// clinique : 2015-10-01 The Estée Lauder Companies Inc.
+// clinique : The Estée Lauder Companies Inc.
+// https://www.iana.org/domains/root/db/clinique.html
clinique
-// clothing : 2013-08-27 Binky Moon, LLC
+// clothing : Binky Moon, LLC
+// https://www.iana.org/domains/root/db/clothing.html
clothing
-// cloud : 2015-04-16 Aruba PEC S.p.A.
+// cloud : Aruba PEC S.p.A.
+// https://www.iana.org/domains/root/db/cloud.html
cloud
-// club : 2013-11-08 Registry Services, LLC
+// club : Registry Services, LLC
+// https://www.iana.org/domains/root/db/club.html
club
-// clubmed : 2015-06-25 Club Méditerranée S.A.
+// clubmed : Club Méditerranée S.A.
+// https://www.iana.org/domains/root/db/clubmed.html
clubmed
-// coach : 2014-10-09 Binky Moon, LLC
+// coach : Binky Moon, LLC
+// https://www.iana.org/domains/root/db/coach.html
coach
-// codes : 2013-10-31 Binky Moon, LLC
+// codes : Binky Moon, LLC
+// https://www.iana.org/domains/root/db/codes.html
codes
-// coffee : 2013-10-17 Binky Moon, LLC
+// coffee : Binky Moon, LLC
+// https://www.iana.org/domains/root/db/coffee.html
coffee
-// college : 2014-01-16 XYZ.COM LLC
+// college : XYZ.COM LLC
+// https://www.iana.org/domains/root/db/college.html
college
-// cologne : 2014-02-05 dotKoeln GmbH
+// cologne : dotKoeln GmbH
+// https://www.iana.org/domains/root/db/cologne.html
cologne
-// comcast : 2015-07-23 Comcast IP Holdings I, LLC
+// comcast : Comcast IP Holdings I, LLC
+// https://www.iana.org/domains/root/db/comcast.html
comcast
-// commbank : 2014-06-26 COMMONWEALTH BANK OF AUSTRALIA
+// commbank : COMMONWEALTH BANK OF AUSTRALIA
+// https://www.iana.org/domains/root/db/commbank.html
commbank
-// community : 2013-12-05 Binky Moon, LLC
+// community : Binky Moon, LLC
+// https://www.iana.org/domains/root/db/community.html
community
-// company : 2013-11-07 Binky Moon, LLC
+// company : Binky Moon, LLC
+// https://www.iana.org/domains/root/db/company.html
company
-// compare : 2015-10-08 Registry Services, LLC
+// compare : Registry Services, LLC
+// https://www.iana.org/domains/root/db/compare.html
compare
-// computer : 2013-10-24 Binky Moon, LLC
+// computer : Binky Moon, LLC
+// https://www.iana.org/domains/root/db/computer.html
computer
-// comsec : 2015-01-08 VeriSign, Inc.
+// comsec : VeriSign, Inc.
+// https://www.iana.org/domains/root/db/comsec.html
comsec
-// condos : 2013-12-05 Binky Moon, LLC
+// condos : Binky Moon, LLC
+// https://www.iana.org/domains/root/db/condos.html
condos
-// construction : 2013-09-16 Binky Moon, LLC
+// construction : Binky Moon, LLC
+// https://www.iana.org/domains/root/db/construction.html
construction
-// consulting : 2013-12-05 Dog Beach, LLC
+// consulting : Dog Beach, LLC
+// https://www.iana.org/domains/root/db/consulting.html
consulting
-// contact : 2015-01-08 Dog Beach, LLC
+// contact : Dog Beach, LLC
+// https://www.iana.org/domains/root/db/contact.html
contact
-// contractors : 2013-09-10 Binky Moon, LLC
+// contractors : Binky Moon, LLC
+// https://www.iana.org/domains/root/db/contractors.html
contractors
-// cooking : 2013-11-21 Registry Services, LLC
+// cooking : Registry Services, LLC
+// https://www.iana.org/domains/root/db/cooking.html
cooking
-// cookingchannel : 2015-07-02 Lifestyle Domain Holdings, Inc.
-cookingchannel
-
-// cool : 2013-11-14 Binky Moon, LLC
+// cool : Binky Moon, LLC
+// https://www.iana.org/domains/root/db/cool.html
cool
-// corsica : 2014-09-25 Collectivité de Corse
+// corsica : Collectivité de Corse
+// https://www.iana.org/domains/root/db/corsica.html
corsica
-// country : 2013-12-19 Internet Naming Company LLC
+// country : Internet Naming Company LLC
+// https://www.iana.org/domains/root/db/country.html
country
-// coupon : 2015-02-26 Amazon Registry Services, Inc.
+// coupon : Amazon Registry Services, Inc.
+// https://www.iana.org/domains/root/db/coupon.html
coupon
-// coupons : 2015-03-26 Binky Moon, LLC
+// coupons : Binky Moon, LLC
+// https://www.iana.org/domains/root/db/coupons.html
coupons
-// courses : 2014-12-04 Registry Services, LLC
+// courses : Registry Services, LLC
+// https://www.iana.org/domains/root/db/courses.html
courses
-// cpa : 2019-06-10 American Institute of Certified Public Accountants
+// cpa : American Institute of Certified Public Accountants
+// https://www.iana.org/domains/root/db/cpa.html
cpa
-// credit : 2014-03-20 Binky Moon, LLC
+// credit : Binky Moon, LLC
+// https://www.iana.org/domains/root/db/credit.html
credit
-// creditcard : 2014-03-20 Binky Moon, LLC
+// creditcard : Binky Moon, LLC
+// https://www.iana.org/domains/root/db/creditcard.html
creditcard
-// creditunion : 2015-01-22 DotCooperation LLC
+// creditunion : DotCooperation LLC
+// https://www.iana.org/domains/root/db/creditunion.html
creditunion
-// cricket : 2014-10-09 dot Cricket Limited
+// cricket : dot Cricket Limited
+// https://www.iana.org/domains/root/db/cricket.html
cricket
-// crown : 2014-10-24 Crown Equipment Corporation
+// crown : Crown Equipment Corporation
+// https://www.iana.org/domains/root/db/crown.html
crown
-// crs : 2014-04-03 Federated Co-operatives Limited
+// crs : Federated Co-operatives Limited
+// https://www.iana.org/domains/root/db/crs.html
crs
-// cruise : 2015-12-10 Viking River Cruises (Bermuda) Ltd.
+// cruise : Viking River Cruises (Bermuda) Ltd.
+// https://www.iana.org/domains/root/db/cruise.html
cruise
-// cruises : 2013-12-05 Binky Moon, LLC
+// cruises : Binky Moon, LLC
+// https://www.iana.org/domains/root/db/cruises.html
cruises
-// cuisinella : 2014-04-03 SCHMIDT GROUPE S.A.S.
+// cuisinella : SCHMIDT GROUPE S.A.S.
+// https://www.iana.org/domains/root/db/cuisinella.html
cuisinella
-// cymru : 2014-05-08 Nominet UK
+// cymru : Nominet UK
+// https://www.iana.org/domains/root/db/cymru.html
cymru
-// cyou : 2015-01-22 ShortDot SA
+// cyou : ShortDot SA
+// https://www.iana.org/domains/root/db/cyou.html
cyou
-// dabur : 2014-02-06 Dabur India Limited
+// dabur : Dabur India Limited
+// https://www.iana.org/domains/root/db/dabur.html
dabur
-// dad : 2014-01-23 Charleston Road Registry Inc.
+// dad : Charleston Road Registry Inc.
+// https://www.iana.org/domains/root/db/dad.html
dad
-// dance : 2013-10-24 Dog Beach, LLC
+// dance : Dog Beach, LLC
+// https://www.iana.org/domains/root/db/dance.html
dance
-// data : 2016-06-02 Dish DBS Corporation
+// data : Dish DBS Corporation
+// https://www.iana.org/domains/root/db/data.html
data
-// date : 2014-11-20 dot Date Limited
+// date : dot Date Limited
+// https://www.iana.org/domains/root/db/date.html
date
-// dating : 2013-12-05 Binky Moon, LLC
+// dating : Binky Moon, LLC
+// https://www.iana.org/domains/root/db/dating.html
dating
-// datsun : 2014-03-27 NISSAN MOTOR CO., LTD.
+// datsun : NISSAN MOTOR CO., LTD.
+// https://www.iana.org/domains/root/db/datsun.html
datsun
-// day : 2014-01-30 Charleston Road Registry Inc.
+// day : Charleston Road Registry Inc.
+// https://www.iana.org/domains/root/db/day.html
day
-// dclk : 2014-11-20 Charleston Road Registry Inc.
+// dclk : Charleston Road Registry Inc.
+// https://www.iana.org/domains/root/db/dclk.html
dclk
-// dds : 2015-05-07 Registry Services, LLC
+// dds : Registry Services, LLC
+// https://www.iana.org/domains/root/db/dds.html
dds
-// deal : 2015-06-25 Amazon Registry Services, Inc.
+// deal : Amazon Registry Services, Inc.
+// https://www.iana.org/domains/root/db/deal.html
deal
-// dealer : 2014-12-22 Intercap Registry Inc.
+// dealer : Intercap Registry Inc.
+// https://www.iana.org/domains/root/db/dealer.html
dealer
-// deals : 2014-05-22 Binky Moon, LLC
+// deals : Binky Moon, LLC
+// https://www.iana.org/domains/root/db/deals.html
deals
-// degree : 2014-03-06 Dog Beach, LLC
+// degree : Dog Beach, LLC
+// https://www.iana.org/domains/root/db/degree.html
degree
-// delivery : 2014-09-11 Binky Moon, LLC
+// delivery : Binky Moon, LLC
+// https://www.iana.org/domains/root/db/delivery.html
delivery
-// dell : 2014-10-24 Dell Inc.
+// dell : Dell Inc.
+// https://www.iana.org/domains/root/db/dell.html
dell
-// deloitte : 2015-07-31 Deloitte Touche Tohmatsu
+// deloitte : Deloitte Touche Tohmatsu
+// https://www.iana.org/domains/root/db/deloitte.html
deloitte
-// delta : 2015-02-19 Delta Air Lines, Inc.
+// delta : Delta Air Lines, Inc.
+// https://www.iana.org/domains/root/db/delta.html
delta
-// democrat : 2013-10-24 Dog Beach, LLC
+// democrat : Dog Beach, LLC
+// https://www.iana.org/domains/root/db/democrat.html
democrat
-// dental : 2014-03-20 Binky Moon, LLC
+// dental : Binky Moon, LLC
+// https://www.iana.org/domains/root/db/dental.html
dental
-// dentist : 2014-03-20 Dog Beach, LLC
+// dentist : Dog Beach, LLC
+// https://www.iana.org/domains/root/db/dentist.html
dentist
-// desi : 2013-11-14 Desi Networks LLC
+// desi
+// https://www.iana.org/domains/root/db/desi.html
desi
-// design : 2014-11-07 Registry Services, LLC
+// design : Registry Services, LLC
+// https://www.iana.org/domains/root/db/design.html
design
-// dev : 2014-10-16 Charleston Road Registry Inc.
+// dev : Charleston Road Registry Inc.
+// https://www.iana.org/domains/root/db/dev.html
dev
-// dhl : 2015-07-23 Deutsche Post AG
+// dhl : Deutsche Post AG
+// https://www.iana.org/domains/root/db/dhl.html
dhl
-// diamonds : 2013-09-22 Binky Moon, LLC
+// diamonds : Binky Moon, LLC
+// https://www.iana.org/domains/root/db/diamonds.html
diamonds
-// diet : 2014-06-26 XYZ.COM LLC
+// diet : XYZ.COM LLC
+// https://www.iana.org/domains/root/db/diet.html
diet
-// digital : 2014-03-06 Binky Moon, LLC
+// digital : Binky Moon, LLC
+// https://www.iana.org/domains/root/db/digital.html
digital
-// direct : 2014-04-10 Binky Moon, LLC
+// direct : Binky Moon, LLC
+// https://www.iana.org/domains/root/db/direct.html
direct
-// directory : 2013-09-20 Binky Moon, LLC
+// directory : Binky Moon, LLC
+// https://www.iana.org/domains/root/db/directory.html
directory
-// discount : 2014-03-06 Binky Moon, LLC
+// discount : Binky Moon, LLC
+// https://www.iana.org/domains/root/db/discount.html
discount
-// discover : 2015-07-23 Discover Financial Services
+// discover : Discover Financial Services
+// https://www.iana.org/domains/root/db/discover.html
discover
-// dish : 2015-07-30 Dish DBS Corporation
+// dish : Dish DBS Corporation
+// https://www.iana.org/domains/root/db/dish.html
dish
-// diy : 2015-11-05 Lifestyle Domain Holdings, Inc.
+// diy : Internet Naming Company LLC
+// https://www.iana.org/domains/root/db/diy.html
diy
-// dnp : 2013-12-13 Dai Nippon Printing Co., Ltd.
+// dnp : Dai Nippon Printing Co., Ltd.
+// https://www.iana.org/domains/root/db/dnp.html
dnp
-// docs : 2014-10-16 Charleston Road Registry Inc.
+// docs : Charleston Road Registry Inc.
+// https://www.iana.org/domains/root/db/docs.html
docs
-// doctor : 2016-06-02 Binky Moon, LLC
+// doctor : Binky Moon, LLC
+// https://www.iana.org/domains/root/db/doctor.html
doctor
-// dog : 2014-12-04 Binky Moon, LLC
+// dog : Binky Moon, LLC
+// https://www.iana.org/domains/root/db/dog.html
dog
-// domains : 2013-10-17 Binky Moon, LLC
+// domains : Binky Moon, LLC
+// https://www.iana.org/domains/root/db/domains.html
domains
-// dot : 2015-05-21 Dish DBS Corporation
+// dot : Dish DBS Corporation
+// https://www.iana.org/domains/root/db/dot.html
dot
-// download : 2014-11-20 dot Support Limited
+// download : dot Support Limited
+// https://www.iana.org/domains/root/db/download.html
download
-// drive : 2015-03-05 Charleston Road Registry Inc.
+// drive : Charleston Road Registry Inc.
+// https://www.iana.org/domains/root/db/drive.html
drive
-// dtv : 2015-06-04 Dish DBS Corporation
+// dtv : Dish DBS Corporation
+// https://www.iana.org/domains/root/db/dtv.html
dtv
-// dubai : 2015-01-01 Dubai Smart Government Department
+// dubai : Dubai Smart Government Department
+// https://www.iana.org/domains/root/db/dubai.html
dubai
-// dunlop : 2015-07-02 The Goodyear Tire & Rubber Company
+// dunlop : The Goodyear Tire & Rubber Company
+// https://www.iana.org/domains/root/db/dunlop.html
dunlop
-// dupont : 2015-06-25 DuPont Specialty Products USA, LLC
+// dupont : DuPont Specialty Products USA, LLC
+// https://www.iana.org/domains/root/db/dupont.html
dupont
-// durban : 2014-03-24 ZA Central Registry NPC trading as ZA Central Registry
+// durban : ZA Central Registry NPC trading as ZA Central Registry
+// https://www.iana.org/domains/root/db/durban.html
durban
-// dvag : 2014-06-23 Deutsche Vermögensberatung Aktiengesellschaft DVAG
+// dvag : Deutsche Vermögensberatung Aktiengesellschaft DVAG
+// https://www.iana.org/domains/root/db/dvag.html
dvag
-// dvr : 2016-05-26 DISH Technologies L.L.C.
+// dvr : DISH Technologies L.L.C.
+// https://www.iana.org/domains/root/db/dvr.html
dvr
-// earth : 2014-12-04 Interlink Systems Innovation Institute K.K.
+// earth : Interlink Systems Innovation Institute K.K.
+// https://www.iana.org/domains/root/db/earth.html
earth
-// eat : 2014-01-23 Charleston Road Registry Inc.
+// eat : Charleston Road Registry Inc.
+// https://www.iana.org/domains/root/db/eat.html
eat
-// eco : 2016-07-08 Big Room Inc.
+// eco : Big Room Inc.
+// https://www.iana.org/domains/root/db/eco.html
eco
-// edeka : 2014-12-18 EDEKA Verband kaufmännischer Genossenschaften e.V.
+// edeka : EDEKA Verband kaufmännischer Genossenschaften e.V.
+// https://www.iana.org/domains/root/db/edeka.html
edeka
-// education : 2013-11-07 Binky Moon, LLC
+// education : Binky Moon, LLC
+// https://www.iana.org/domains/root/db/education.html
education
-// email : 2013-10-31 Binky Moon, LLC
+// email : Binky Moon, LLC
+// https://www.iana.org/domains/root/db/email.html
email
-// emerck : 2014-04-03 Merck KGaA
+// emerck : Merck KGaA
+// https://www.iana.org/domains/root/db/emerck.html
emerck
-// energy : 2014-09-11 Binky Moon, LLC
+// energy : Binky Moon, LLC
+// https://www.iana.org/domains/root/db/energy.html
energy
-// engineer : 2014-03-06 Dog Beach, LLC
+// engineer : Dog Beach, LLC
+// https://www.iana.org/domains/root/db/engineer.html
engineer
-// engineering : 2014-03-06 Binky Moon, LLC
+// engineering : Binky Moon, LLC
+// https://www.iana.org/domains/root/db/engineering.html
engineering
-// enterprises : 2013-09-20 Binky Moon, LLC
+// enterprises : Binky Moon, LLC
+// https://www.iana.org/domains/root/db/enterprises.html
enterprises
-// epson : 2014-12-04 Seiko Epson Corporation
+// epson : Seiko Epson Corporation
+// https://www.iana.org/domains/root/db/epson.html
epson
-// equipment : 2013-08-27 Binky Moon, LLC
+// equipment : Binky Moon, LLC
+// https://www.iana.org/domains/root/db/equipment.html
equipment
-// ericsson : 2015-07-09 Telefonaktiebolaget L M Ericsson
+// ericsson : Telefonaktiebolaget L M Ericsson
+// https://www.iana.org/domains/root/db/ericsson.html
ericsson
-// erni : 2014-04-03 ERNI Group Holding AG
+// erni : ERNI Group Holding AG
+// https://www.iana.org/domains/root/db/erni.html
erni
-// esq : 2014-05-08 Charleston Road Registry Inc.
+// esq : Charleston Road Registry Inc.
+// https://www.iana.org/domains/root/db/esq.html
esq
-// estate : 2013-08-27 Binky Moon, LLC
+// estate : Binky Moon, LLC
+// https://www.iana.org/domains/root/db/estate.html
estate
-// etisalat : 2015-09-03 Emirates Telecommunications Corporation (trading as Etisalat)
-etisalat
-
-// eurovision : 2014-04-24 European Broadcasting Union (EBU)
+// eurovision : European Broadcasting Union (EBU)
+// https://www.iana.org/domains/root/db/eurovision.html
eurovision
-// eus : 2013-12-12 Puntueus Fundazioa
+// eus : Puntueus Fundazioa
+// https://www.iana.org/domains/root/db/eus.html
eus
-// events : 2013-12-05 Binky Moon, LLC
+// events : Binky Moon, LLC
+// https://www.iana.org/domains/root/db/events.html
events
-// exchange : 2014-03-06 Binky Moon, LLC
+// exchange : Binky Moon, LLC
+// https://www.iana.org/domains/root/db/exchange.html
exchange
-// expert : 2013-11-21 Binky Moon, LLC
+// expert : Binky Moon, LLC
+// https://www.iana.org/domains/root/db/expert.html
expert
-// exposed : 2013-12-05 Binky Moon, LLC
+// exposed : Binky Moon, LLC
+// https://www.iana.org/domains/root/db/exposed.html
exposed
-// express : 2015-02-11 Binky Moon, LLC
+// express : Binky Moon, LLC
+// https://www.iana.org/domains/root/db/express.html
express
-// extraspace : 2015-05-14 Extra Space Storage LLC
+// extraspace : Extra Space Storage LLC
+// https://www.iana.org/domains/root/db/extraspace.html
extraspace
-// fage : 2014-12-18 Fage International S.A.
+// fage : Fage International S.A.
+// https://www.iana.org/domains/root/db/fage.html
fage
-// fail : 2014-03-06 Binky Moon, LLC
+// fail : Binky Moon, LLC
+// https://www.iana.org/domains/root/db/fail.html
fail
-// fairwinds : 2014-11-13 FairWinds Partners, LLC
+// fairwinds : FairWinds Partners, LLC
+// https://www.iana.org/domains/root/db/fairwinds.html
fairwinds
-// faith : 2014-11-20 dot Faith Limited
+// faith : dot Faith Limited
+// https://www.iana.org/domains/root/db/faith.html
faith
-// family : 2015-04-02 Dog Beach, LLC
+// family : Dog Beach, LLC
+// https://www.iana.org/domains/root/db/family.html
family
-// fan : 2014-03-06 Dog Beach, LLC
+// fan : Dog Beach, LLC
+// https://www.iana.org/domains/root/db/fan.html
fan
-// fans : 2014-11-07 ZDNS International Limited
+// fans : ZDNS International Limited
+// https://www.iana.org/domains/root/db/fans.html
fans
-// farm : 2013-11-07 Binky Moon, LLC
+// farm : Binky Moon, LLC
+// https://www.iana.org/domains/root/db/farm.html
farm
-// farmers : 2015-07-09 Farmers Insurance Exchange
+// farmers : Farmers Insurance Exchange
+// https://www.iana.org/domains/root/db/farmers.html
farmers
-// fashion : 2014-07-03 Registry Services, LLC
+// fashion : Registry Services, LLC
+// https://www.iana.org/domains/root/db/fashion.html
fashion
-// fast : 2014-12-18 Amazon Registry Services, Inc.
+// fast : Amazon Registry Services, Inc.
+// https://www.iana.org/domains/root/db/fast.html
fast
-// fedex : 2015-08-06 Federal Express Corporation
+// fedex : Federal Express Corporation
+// https://www.iana.org/domains/root/db/fedex.html
fedex
-// feedback : 2013-12-19 Top Level Spectrum, Inc.
+// feedback : Top Level Spectrum, Inc.
+// https://www.iana.org/domains/root/db/feedback.html
feedback
-// ferrari : 2015-07-31 Fiat Chrysler Automobiles N.V.
+// ferrari : Fiat Chrysler Automobiles N.V.
+// https://www.iana.org/domains/root/db/ferrari.html
ferrari
-// ferrero : 2014-12-18 Ferrero Trading Lux S.A.
+// ferrero : Ferrero Trading Lux S.A.
+// https://www.iana.org/domains/root/db/ferrero.html
ferrero
-// fiat : 2015-07-31 Fiat Chrysler Automobiles N.V.
-fiat
-
-// fidelity : 2015-07-30 Fidelity Brokerage Services LLC
+// fidelity : Fidelity Brokerage Services LLC
+// https://www.iana.org/domains/root/db/fidelity.html
fidelity
-// fido : 2015-08-06 Rogers Communications Canada Inc.
+// fido : Rogers Communications Canada Inc.
+// https://www.iana.org/domains/root/db/fido.html
fido
-// film : 2015-01-08 Motion Picture Domain Registry Pty Ltd
+// film : Motion Picture Domain Registry Pty Ltd
+// https://www.iana.org/domains/root/db/film.html
film
-// final : 2014-10-16 Núcleo de Informação e Coordenação do Ponto BR - NIC.br
+// final : Núcleo de Informação e Coordenação do Ponto BR - NIC.br
+// https://www.iana.org/domains/root/db/final.html
final
-// finance : 2014-03-20 Binky Moon, LLC
+// finance : Binky Moon, LLC
+// https://www.iana.org/domains/root/db/finance.html
finance
-// financial : 2014-03-06 Binky Moon, LLC
+// financial : Binky Moon, LLC
+// https://www.iana.org/domains/root/db/financial.html
financial
-// fire : 2015-06-25 Amazon Registry Services, Inc.
+// fire : Amazon Registry Services, Inc.
+// https://www.iana.org/domains/root/db/fire.html
fire
-// firestone : 2014-12-18 Bridgestone Licensing Services, Inc
+// firestone : Bridgestone Licensing Services, Inc
+// https://www.iana.org/domains/root/db/firestone.html
firestone
-// firmdale : 2014-03-27 Firmdale Holdings Limited
+// firmdale : Firmdale Holdings Limited
+// https://www.iana.org/domains/root/db/firmdale.html
firmdale
-// fish : 2013-12-12 Binky Moon, LLC
+// fish : Binky Moon, LLC
+// https://www.iana.org/domains/root/db/fish.html
fish
-// fishing : 2013-11-21 Registry Services, LLC
+// fishing : Registry Services, LLC
+// https://www.iana.org/domains/root/db/fishing.html
fishing
-// fit : 2014-11-07 Registry Services, LLC
+// fit : Registry Services, LLC
+// https://www.iana.org/domains/root/db/fit.html
fit
-// fitness : 2014-03-06 Binky Moon, LLC
+// fitness : Binky Moon, LLC
+// https://www.iana.org/domains/root/db/fitness.html
fitness
-// flickr : 2015-04-02 Flickr, Inc.
+// flickr : Flickr, Inc.
+// https://www.iana.org/domains/root/db/flickr.html
flickr
-// flights : 2013-12-05 Binky Moon, LLC
+// flights : Binky Moon, LLC
+// https://www.iana.org/domains/root/db/flights.html
flights
-// flir : 2015-07-23 FLIR Systems, Inc.
+// flir : FLIR Systems, Inc.
+// https://www.iana.org/domains/root/db/flir.html
flir
-// florist : 2013-11-07 Binky Moon, LLC
+// florist : Binky Moon, LLC
+// https://www.iana.org/domains/root/db/florist.html
florist
-// flowers : 2014-10-09 XYZ.COM LLC
+// flowers : XYZ.COM LLC
+// https://www.iana.org/domains/root/db/flowers.html
flowers
-// fly : 2014-05-08 Charleston Road Registry Inc.
+// fly : Charleston Road Registry Inc.
+// https://www.iana.org/domains/root/db/fly.html
fly
-// foo : 2014-01-23 Charleston Road Registry Inc.
+// foo : Charleston Road Registry Inc.
+// https://www.iana.org/domains/root/db/foo.html
foo
-// food : 2016-04-21 Lifestyle Domain Holdings, Inc.
+// food : Internet Naming Company LLC
+// https://www.iana.org/domains/root/db/food.html
food
-// foodnetwork : 2015-07-02 Lifestyle Domain Holdings, Inc.
-foodnetwork
-
-// football : 2014-12-18 Binky Moon, LLC
+// football : Binky Moon, LLC
+// https://www.iana.org/domains/root/db/football.html
football
-// ford : 2014-11-13 Ford Motor Company
+// ford : Ford Motor Company
+// https://www.iana.org/domains/root/db/ford.html
ford
-// forex : 2014-12-11 Dog Beach, LLC
+// forex : Dog Beach, LLC
+// https://www.iana.org/domains/root/db/forex.html
forex
-// forsale : 2014-05-22 Dog Beach, LLC
+// forsale : Dog Beach, LLC
+// https://www.iana.org/domains/root/db/forsale.html
forsale
-// forum : 2015-04-02 Fegistry, LLC
+// forum : Fegistry, LLC
+// https://www.iana.org/domains/root/db/forum.html
forum
-// foundation : 2013-12-05 Public Interest Registry
+// foundation : Public Interest Registry
+// https://www.iana.org/domains/root/db/foundation.html
foundation
-// fox : 2015-09-11 FOX Registry, LLC
+// fox : FOX Registry, LLC
+// https://www.iana.org/domains/root/db/fox.html
fox
-// free : 2015-12-10 Amazon Registry Services, Inc.
+// free : Amazon Registry Services, Inc.
+// https://www.iana.org/domains/root/db/free.html
free
-// fresenius : 2015-07-30 Fresenius Immobilien-Verwaltungs-GmbH
+// fresenius : Fresenius Immobilien-Verwaltungs-GmbH
+// https://www.iana.org/domains/root/db/fresenius.html
fresenius
-// frl : 2014-05-15 FRLregistry B.V.
+// frl : FRLregistry B.V.
+// https://www.iana.org/domains/root/db/frl.html
frl
-// frogans : 2013-12-19 OP3FT
+// frogans : OP3FT
+// https://www.iana.org/domains/root/db/frogans.html
frogans
-// frontdoor : 2015-07-02 Lifestyle Domain Holdings, Inc.
-frontdoor
-
-// frontier : 2015-02-05 Frontier Communications Corporation
+// frontier : Frontier Communications Corporation
+// https://www.iana.org/domains/root/db/frontier.html
frontier
-// ftr : 2015-07-16 Frontier Communications Corporation
+// ftr : Frontier Communications Corporation
+// https://www.iana.org/domains/root/db/ftr.html
ftr
-// fujitsu : 2015-07-30 Fujitsu Limited
+// fujitsu : Fujitsu Limited
+// https://www.iana.org/domains/root/db/fujitsu.html
fujitsu
-// fun : 2016-01-14 Radix FZC
+// fun : Radix FZC DMCC
+// https://www.iana.org/domains/root/db/fun.html
fun
-// fund : 2014-03-20 Binky Moon, LLC
+// fund : Binky Moon, LLC
+// https://www.iana.org/domains/root/db/fund.html
fund
-// furniture : 2014-03-20 Binky Moon, LLC
+// furniture : Binky Moon, LLC
+// https://www.iana.org/domains/root/db/furniture.html
furniture
-// futbol : 2013-09-20 Dog Beach, LLC
+// futbol : Dog Beach, LLC
+// https://www.iana.org/domains/root/db/futbol.html
futbol
-// fyi : 2015-04-02 Binky Moon, LLC
+// fyi : Binky Moon, LLC
+// https://www.iana.org/domains/root/db/fyi.html
fyi
-// gal : 2013-11-07 Asociación puntoGAL
+// gal : Asociación puntoGAL
+// https://www.iana.org/domains/root/db/gal.html
gal
-// gallery : 2013-09-13 Binky Moon, LLC
+// gallery : Binky Moon, LLC
+// https://www.iana.org/domains/root/db/gallery.html
gallery
-// gallo : 2015-06-11 Gallo Vineyards, Inc.
+// gallo : Gallo Vineyards, Inc.
+// https://www.iana.org/domains/root/db/gallo.html
gallo
-// gallup : 2015-02-19 Gallup, Inc.
+// gallup : Gallup, Inc.
+// https://www.iana.org/domains/root/db/gallup.html
gallup
-// game : 2015-05-28 XYZ.COM LLC
+// game : XYZ.COM LLC
+// https://www.iana.org/domains/root/db/game.html
game
-// games : 2015-05-28 Dog Beach, LLC
+// games : Dog Beach, LLC
+// https://www.iana.org/domains/root/db/games.html
games
-// gap : 2015-07-31 The Gap, Inc.
+// gap : The Gap, Inc.
+// https://www.iana.org/domains/root/db/gap.html
gap
-// garden : 2014-06-26 Registry Services, LLC
+// garden : Registry Services, LLC
+// https://www.iana.org/domains/root/db/garden.html
garden
-// gay : 2019-05-23 Top Level Design, LLC
+// gay : Registry Services, LLC
+// https://www.iana.org/domains/root/db/gay.html
gay
-// gbiz : 2014-07-17 Charleston Road Registry Inc.
+// gbiz : Charleston Road Registry Inc.
+// https://www.iana.org/domains/root/db/gbiz.html
gbiz
-// gdn : 2014-07-31 Joint Stock Company "Navigation-information systems"
+// gdn : Joint Stock Company "Navigation-information systems"
+// https://www.iana.org/domains/root/db/gdn.html
gdn
-// gea : 2014-12-04 GEA Group Aktiengesellschaft
+// gea : GEA Group Aktiengesellschaft
+// https://www.iana.org/domains/root/db/gea.html
gea
-// gent : 2014-01-23 Easyhost BV
+// gent : Easyhost BV
+// https://www.iana.org/domains/root/db/gent.html
gent
-// genting : 2015-03-12 Resorts World Inc Pte. Ltd.
+// genting : Resorts World Inc Pte. Ltd.
+// https://www.iana.org/domains/root/db/genting.html
genting
-// george : 2015-07-31 Wal-Mart Stores, Inc.
+// george : Wal-Mart Stores, Inc.
+// https://www.iana.org/domains/root/db/george.html
george
-// ggee : 2014-01-09 GMO Internet, Inc.
+// ggee : GMO Internet, Inc.
+// https://www.iana.org/domains/root/db/ggee.html
ggee
-// gift : 2013-10-17 DotGift, LLC
+// gift : DotGift, LLC
+// https://www.iana.org/domains/root/db/gift.html
gift
-// gifts : 2014-07-03 Binky Moon, LLC
+// gifts : Binky Moon, LLC
+// https://www.iana.org/domains/root/db/gifts.html
gifts
-// gives : 2014-03-06 Public Interest Registry
+// gives : Public Interest Registry
+// https://www.iana.org/domains/root/db/gives.html
gives
-// giving : 2014-11-13 Public Interest Registry
+// giving : Public Interest Registry
+// https://www.iana.org/domains/root/db/giving.html
giving
-// glass : 2013-11-07 Binky Moon, LLC
+// glass : Binky Moon, LLC
+// https://www.iana.org/domains/root/db/glass.html
glass
-// gle : 2014-07-24 Charleston Road Registry Inc.
+// gle : Charleston Road Registry Inc.
+// https://www.iana.org/domains/root/db/gle.html
gle
-// global : 2014-04-17 Dot Global Domain Registry Limited
+// global : Identity Digital Limited
+// https://www.iana.org/domains/root/db/global.html
global
-// globo : 2013-12-19 Globo Comunicação e Participações S.A
+// globo : Globo Comunicação e Participações S.A
+// https://www.iana.org/domains/root/db/globo.html
globo
-// gmail : 2014-05-01 Charleston Road Registry Inc.
+// gmail : Charleston Road Registry Inc.
+// https://www.iana.org/domains/root/db/gmail.html
gmail
-// gmbh : 2016-01-29 Binky Moon, LLC
+// gmbh : Binky Moon, LLC
+// https://www.iana.org/domains/root/db/gmbh.html
gmbh
-// gmo : 2014-01-09 GMO Internet, Inc.
+// gmo : GMO Internet, Inc.
+// https://www.iana.org/domains/root/db/gmo.html
gmo
-// gmx : 2014-04-24 1&1 Mail & Media GmbH
+// gmx : 1&1 Mail & Media GmbH
+// https://www.iana.org/domains/root/db/gmx.html
gmx
-// godaddy : 2015-07-23 Go Daddy East, LLC
+// godaddy : Go Daddy East, LLC
+// https://www.iana.org/domains/root/db/godaddy.html
godaddy
-// gold : 2015-01-22 Binky Moon, LLC
+// gold : Binky Moon, LLC
+// https://www.iana.org/domains/root/db/gold.html
gold
-// goldpoint : 2014-11-20 YODOBASHI CAMERA CO.,LTD.
+// goldpoint : YODOBASHI CAMERA CO.,LTD.
+// https://www.iana.org/domains/root/db/goldpoint.html
goldpoint
-// golf : 2014-12-18 Binky Moon, LLC
+// golf : Binky Moon, LLC
+// https://www.iana.org/domains/root/db/golf.html
golf
-// goo : 2014-12-18 NTT Resonant Inc.
+// goo : NTT DOCOMO, INC.
+// https://www.iana.org/domains/root/db/goo.html
goo
-// goodyear : 2015-07-02 The Goodyear Tire & Rubber Company
+// goodyear : The Goodyear Tire & Rubber Company
+// https://www.iana.org/domains/root/db/goodyear.html
goodyear
-// goog : 2014-11-20 Charleston Road Registry Inc.
+// goog : Charleston Road Registry Inc.
+// https://www.iana.org/domains/root/db/goog.html
goog
-// google : 2014-07-24 Charleston Road Registry Inc.
+// google : Charleston Road Registry Inc.
+// https://www.iana.org/domains/root/db/google.html
google
-// gop : 2014-01-16 Republican State Leadership Committee, Inc.
+// gop : Republican State Leadership Committee, Inc.
+// https://www.iana.org/domains/root/db/gop.html
gop
-// got : 2014-12-18 Amazon Registry Services, Inc.
+// got : Amazon Registry Services, Inc.
+// https://www.iana.org/domains/root/db/got.html
got
-// grainger : 2015-05-07 Grainger Registry Services, LLC
+// grainger : Grainger Registry Services, LLC
+// https://www.iana.org/domains/root/db/grainger.html
grainger
-// graphics : 2013-09-13 Binky Moon, LLC
+// graphics : Binky Moon, LLC
+// https://www.iana.org/domains/root/db/graphics.html
graphics
-// gratis : 2014-03-20 Binky Moon, LLC
+// gratis : Binky Moon, LLC
+// https://www.iana.org/domains/root/db/gratis.html
gratis
-// green : 2014-05-08 Identity Digital Limited
+// green : Identity Digital Limited
+// https://www.iana.org/domains/root/db/green.html
green
-// gripe : 2014-03-06 Binky Moon, LLC
+// gripe : Binky Moon, LLC
+// https://www.iana.org/domains/root/db/gripe.html
gripe
-// grocery : 2016-06-16 Wal-Mart Stores, Inc.
+// grocery : Wal-Mart Stores, Inc.
+// https://www.iana.org/domains/root/db/grocery.html
grocery
-// group : 2014-08-15 Binky Moon, LLC
+// group : Binky Moon, LLC
+// https://www.iana.org/domains/root/db/group.html
group
-// guardian : 2015-07-30 The Guardian Life Insurance Company of America
+// guardian : The Guardian Life Insurance Company of America
+// https://www.iana.org/domains/root/db/guardian.html
guardian
-// gucci : 2014-11-13 Guccio Gucci S.p.a.
+// gucci : Guccio Gucci S.p.a.
+// https://www.iana.org/domains/root/db/gucci.html
gucci
-// guge : 2014-08-28 Charleston Road Registry Inc.
+// guge : Charleston Road Registry Inc.
+// https://www.iana.org/domains/root/db/guge.html
guge
-// guide : 2013-09-13 Binky Moon, LLC
+// guide : Binky Moon, LLC
+// https://www.iana.org/domains/root/db/guide.html
guide
-// guitars : 2013-11-14 XYZ.COM LLC
+// guitars : XYZ.COM LLC
+// https://www.iana.org/domains/root/db/guitars.html
guitars
-// guru : 2013-08-27 Binky Moon, LLC
+// guru : Binky Moon, LLC
+// https://www.iana.org/domains/root/db/guru.html
guru
-// hair : 2015-12-03 XYZ.COM LLC
+// hair : XYZ.COM LLC
+// https://www.iana.org/domains/root/db/hair.html
hair
-// hamburg : 2014-02-20 Hamburg Top-Level-Domain GmbH
+// hamburg : Hamburg Top-Level-Domain GmbH
+// https://www.iana.org/domains/root/db/hamburg.html
hamburg
-// hangout : 2014-11-13 Charleston Road Registry Inc.
+// hangout : Charleston Road Registry Inc.
+// https://www.iana.org/domains/root/db/hangout.html
hangout
-// haus : 2013-12-05 Dog Beach, LLC
+// haus : Dog Beach, LLC
+// https://www.iana.org/domains/root/db/haus.html
haus
-// hbo : 2015-07-30 HBO Registry Services, Inc.
+// hbo : HBO Registry Services, Inc.
+// https://www.iana.org/domains/root/db/hbo.html
hbo
-// hdfc : 2015-07-30 HOUSING DEVELOPMENT FINANCE CORPORATION LIMITED
+// hdfc : HOUSING DEVELOPMENT FINANCE CORPORATION LIMITED
+// https://www.iana.org/domains/root/db/hdfc.html
hdfc
-// hdfcbank : 2015-02-12 HDFC Bank Limited
+// hdfcbank : HDFC Bank Limited
+// https://www.iana.org/domains/root/db/hdfcbank.html
hdfcbank
-// health : 2015-02-11 DotHealth, LLC
+// health : Registry Services, LLC
+// https://www.iana.org/domains/root/db/health.html
health
-// healthcare : 2014-06-12 Binky Moon, LLC
+// healthcare : Binky Moon, LLC
+// https://www.iana.org/domains/root/db/healthcare.html
healthcare
-// help : 2014-06-26 Innovation service Limited
+// help : Innovation service Limited
+// https://www.iana.org/domains/root/db/help.html
help
-// helsinki : 2015-02-05 City of Helsinki
+// helsinki : City of Helsinki
+// https://www.iana.org/domains/root/db/helsinki.html
helsinki
-// here : 2014-02-06 Charleston Road Registry Inc.
+// here : Charleston Road Registry Inc.
+// https://www.iana.org/domains/root/db/here.html
here
-// hermes : 2014-07-10 HERMES INTERNATIONAL
+// hermes : HERMES INTERNATIONAL
+// https://www.iana.org/domains/root/db/hermes.html
hermes
-// hgtv : 2015-07-02 Lifestyle Domain Holdings, Inc.
-hgtv
-
-// hiphop : 2014-03-06 Dot Hip Hop, LLC
+// hiphop : Dot Hip Hop, LLC
+// https://www.iana.org/domains/root/db/hiphop.html
hiphop
-// hisamitsu : 2015-07-16 Hisamitsu Pharmaceutical Co.,Inc.
+// hisamitsu : Hisamitsu Pharmaceutical Co.,Inc.
+// https://www.iana.org/domains/root/db/hisamitsu.html
hisamitsu
-// hitachi : 2014-10-31 Hitachi, Ltd.
+// hitachi : Hitachi, Ltd.
+// https://www.iana.org/domains/root/db/hitachi.html
hitachi
-// hiv : 2014-03-13 Internet Naming Company LLC
+// hiv : Internet Naming Company LLC
+// https://www.iana.org/domains/root/db/hiv.html
hiv
-// hkt : 2015-05-14 PCCW-HKT DataCom Services Limited
+// hkt : PCCW-HKT DataCom Services Limited
+// https://www.iana.org/domains/root/db/hkt.html
hkt
-// hockey : 2015-03-19 Binky Moon, LLC
+// hockey : Binky Moon, LLC
+// https://www.iana.org/domains/root/db/hockey.html
hockey
-// holdings : 2013-08-27 Binky Moon, LLC
+// holdings : Binky Moon, LLC
+// https://www.iana.org/domains/root/db/holdings.html
holdings
-// holiday : 2013-11-07 Binky Moon, LLC
+// holiday : Binky Moon, LLC
+// https://www.iana.org/domains/root/db/holiday.html
holiday
-// homedepot : 2015-04-02 Home Depot Product Authority, LLC
+// homedepot : Home Depot Product Authority, LLC
+// https://www.iana.org/domains/root/db/homedepot.html
homedepot
-// homegoods : 2015-07-16 The TJX Companies, Inc.
+// homegoods : The TJX Companies, Inc.
+// https://www.iana.org/domains/root/db/homegoods.html
homegoods
-// homes : 2014-01-09 XYZ.COM LLC
+// homes : XYZ.COM LLC
+// https://www.iana.org/domains/root/db/homes.html
homes
-// homesense : 2015-07-16 The TJX Companies, Inc.
+// homesense : The TJX Companies, Inc.
+// https://www.iana.org/domains/root/db/homesense.html
homesense
-// honda : 2014-12-18 Honda Motor Co., Ltd.
+// honda : Honda Motor Co., Ltd.
+// https://www.iana.org/domains/root/db/honda.html
honda
-// horse : 2013-11-21 Registry Services, LLC
+// horse : Registry Services, LLC
+// https://www.iana.org/domains/root/db/horse.html
horse
-// hospital : 2016-10-20 Binky Moon, LLC
+// hospital : Binky Moon, LLC
+// https://www.iana.org/domains/root/db/hospital.html
hospital
-// host : 2014-04-17 Radix FZC
+// host : Radix FZC DMCC
+// https://www.iana.org/domains/root/db/host.html
host
-// hosting : 2014-05-29 XYZ.COM LLC
+// hosting : XYZ.COM LLC
+// https://www.iana.org/domains/root/db/hosting.html
hosting
-// hot : 2015-08-27 Amazon Registry Services, Inc.
+// hot : Amazon Registry Services, Inc.
+// https://www.iana.org/domains/root/db/hot.html
hot
-// hoteles : 2015-03-05 Travel Reservations SRL
-hoteles
-
-// hotels : 2016-04-07 Booking.com B.V.
+// hotels : Booking.com B.V.
+// https://www.iana.org/domains/root/db/hotels.html
hotels
-// hotmail : 2014-12-18 Microsoft Corporation
+// hotmail : Microsoft Corporation
+// https://www.iana.org/domains/root/db/hotmail.html
hotmail
-// house : 2013-11-07 Binky Moon, LLC
+// house : Binky Moon, LLC
+// https://www.iana.org/domains/root/db/house.html
house
-// how : 2014-01-23 Charleston Road Registry Inc.
+// how : Charleston Road Registry Inc.
+// https://www.iana.org/domains/root/db/how.html
how
-// hsbc : 2014-10-24 HSBC Global Services (UK) Limited
+// hsbc : HSBC Global Services (UK) Limited
+// https://www.iana.org/domains/root/db/hsbc.html
hsbc
-// hughes : 2015-07-30 Hughes Satellite Systems Corporation
+// hughes : Hughes Satellite Systems Corporation
+// https://www.iana.org/domains/root/db/hughes.html
hughes
-// hyatt : 2015-07-30 Hyatt GTLD, L.L.C.
+// hyatt : Hyatt GTLD, L.L.C.
+// https://www.iana.org/domains/root/db/hyatt.html
hyatt
-// hyundai : 2015-07-09 Hyundai Motor Company
+// hyundai : Hyundai Motor Company
+// https://www.iana.org/domains/root/db/hyundai.html
hyundai
-// ibm : 2014-07-31 International Business Machines Corporation
+// ibm : International Business Machines Corporation
+// https://www.iana.org/domains/root/db/ibm.html
ibm
-// icbc : 2015-02-19 Industrial and Commercial Bank of China Limited
+// icbc : Industrial and Commercial Bank of China Limited
+// https://www.iana.org/domains/root/db/icbc.html
icbc
-// ice : 2014-10-30 IntercontinentalExchange, Inc.
+// ice : IntercontinentalExchange, Inc.
+// https://www.iana.org/domains/root/db/ice.html
ice
-// icu : 2015-01-08 ShortDot SA
+// icu : ShortDot SA
+// https://www.iana.org/domains/root/db/icu.html
icu
-// ieee : 2015-07-23 IEEE Global LLC
+// ieee : IEEE Global LLC
+// https://www.iana.org/domains/root/db/ieee.html
ieee
-// ifm : 2014-01-30 ifm electronic gmbh
+// ifm : ifm electronic gmbh
+// https://www.iana.org/domains/root/db/ifm.html
ifm
-// ikano : 2015-07-09 Ikano S.A.
+// ikano : Ikano S.A.
+// https://www.iana.org/domains/root/db/ikano.html
ikano
-// imamat : 2015-08-06 Fondation Aga Khan (Aga Khan Foundation)
+// imamat : Fondation Aga Khan (Aga Khan Foundation)
+// https://www.iana.org/domains/root/db/imamat.html
imamat
-// imdb : 2015-06-25 Amazon Registry Services, Inc.
+// imdb : Amazon Registry Services, Inc.
+// https://www.iana.org/domains/root/db/imdb.html
imdb
-// immo : 2014-07-10 Binky Moon, LLC
+// immo : Binky Moon, LLC
+// https://www.iana.org/domains/root/db/immo.html
immo
-// immobilien : 2013-11-07 Dog Beach, LLC
+// immobilien : Dog Beach, LLC
+// https://www.iana.org/domains/root/db/immobilien.html
immobilien
-// inc : 2018-03-10 Intercap Registry Inc.
+// inc : Intercap Registry Inc.
+// https://www.iana.org/domains/root/db/inc.html
inc
-// industries : 2013-12-05 Binky Moon, LLC
+// industries : Binky Moon, LLC
+// https://www.iana.org/domains/root/db/industries.html
industries
-// infiniti : 2014-03-27 NISSAN MOTOR CO., LTD.
+// infiniti : NISSAN MOTOR CO., LTD.
+// https://www.iana.org/domains/root/db/infiniti.html
infiniti
-// ing : 2014-01-23 Charleston Road Registry Inc.
+// ing : Charleston Road Registry Inc.
+// https://www.iana.org/domains/root/db/ing.html
ing
-// ink : 2013-12-05 Top Level Design, LLC
+// ink : Registry Services, LLC
+// https://www.iana.org/domains/root/db/ink.html
ink
-// institute : 2013-11-07 Binky Moon, LLC
+// institute : Binky Moon, LLC
+// https://www.iana.org/domains/root/db/institute.html
institute
-// insurance : 2015-02-19 fTLD Registry Services LLC
+// insurance : fTLD Registry Services LLC
+// https://www.iana.org/domains/root/db/insurance.html
insurance
-// insure : 2014-03-20 Binky Moon, LLC
+// insure : Binky Moon, LLC
+// https://www.iana.org/domains/root/db/insure.html
insure
-// international : 2013-11-07 Binky Moon, LLC
+// international : Binky Moon, LLC
+// https://www.iana.org/domains/root/db/international.html
international
-// intuit : 2015-07-30 Intuit Administrative Services, Inc.
+// intuit : Intuit Administrative Services, Inc.
+// https://www.iana.org/domains/root/db/intuit.html
intuit
-// investments : 2014-03-20 Binky Moon, LLC
+// investments : Binky Moon, LLC
+// https://www.iana.org/domains/root/db/investments.html
investments
-// ipiranga : 2014-08-28 Ipiranga Produtos de Petroleo S.A.
+// ipiranga : Ipiranga Produtos de Petroleo S.A.
+// https://www.iana.org/domains/root/db/ipiranga.html
ipiranga
-// irish : 2014-08-07 Binky Moon, LLC
+// irish : Binky Moon, LLC
+// https://www.iana.org/domains/root/db/irish.html
irish
-// ismaili : 2015-08-06 Fondation Aga Khan (Aga Khan Foundation)
+// ismaili : Fondation Aga Khan (Aga Khan Foundation)
+// https://www.iana.org/domains/root/db/ismaili.html
ismaili
-// ist : 2014-08-28 Istanbul Metropolitan Municipality
+// ist : Istanbul Metropolitan Municipality
+// https://www.iana.org/domains/root/db/ist.html
ist
-// istanbul : 2014-08-28 Istanbul Metropolitan Municipality
+// istanbul : Istanbul Metropolitan Municipality
+// https://www.iana.org/domains/root/db/istanbul.html
istanbul
-// itau : 2014-10-02 Itau Unibanco Holding S.A.
+// itau : Itau Unibanco Holding S.A.
+// https://www.iana.org/domains/root/db/itau.html
itau
-// itv : 2015-07-09 ITV Services Limited
+// itv : ITV Services Limited
+// https://www.iana.org/domains/root/db/itv.html
itv
-// jaguar : 2014-11-13 Jaguar Land Rover Ltd
+// jaguar : Jaguar Land Rover Ltd
+// https://www.iana.org/domains/root/db/jaguar.html
jaguar
-// java : 2014-06-19 Oracle Corporation
+// java : Oracle Corporation
+// https://www.iana.org/domains/root/db/java.html
java
-// jcb : 2014-11-20 JCB Co., Ltd.
+// jcb : JCB Co., Ltd.
+// https://www.iana.org/domains/root/db/jcb.html
jcb
-// jeep : 2015-07-30 FCA US LLC.
+// jeep : FCA US LLC.
+// https://www.iana.org/domains/root/db/jeep.html
jeep
-// jetzt : 2014-01-09 Binky Moon, LLC
+// jetzt : Binky Moon, LLC
+// https://www.iana.org/domains/root/db/jetzt.html
jetzt
-// jewelry : 2015-03-05 Binky Moon, LLC
+// jewelry : Binky Moon, LLC
+// https://www.iana.org/domains/root/db/jewelry.html
jewelry
-// jio : 2015-04-02 Reliance Industries Limited
+// jio : Reliance Industries Limited
+// https://www.iana.org/domains/root/db/jio.html
jio
-// jll : 2015-04-02 Jones Lang LaSalle Incorporated
+// jll : Jones Lang LaSalle Incorporated
+// https://www.iana.org/domains/root/db/jll.html
jll
-// jmp : 2015-03-26 Matrix IP LLC
+// jmp : Matrix IP LLC
+// https://www.iana.org/domains/root/db/jmp.html
jmp
-// jnj : 2015-06-18 Johnson & Johnson Services, Inc.
+// jnj : Johnson & Johnson Services, Inc.
+// https://www.iana.org/domains/root/db/jnj.html
jnj
-// joburg : 2014-03-24 ZA Central Registry NPC trading as ZA Central Registry
+// joburg : ZA Central Registry NPC trading as ZA Central Registry
+// https://www.iana.org/domains/root/db/joburg.html
joburg
-// jot : 2014-12-18 Amazon Registry Services, Inc.
+// jot : Amazon Registry Services, Inc.
+// https://www.iana.org/domains/root/db/jot.html
jot
-// joy : 2014-12-18 Amazon Registry Services, Inc.
+// joy : Amazon Registry Services, Inc.
+// https://www.iana.org/domains/root/db/joy.html
joy
-// jpmorgan : 2015-04-30 JPMorgan Chase Bank, National Association
+// jpmorgan : JPMorgan Chase Bank, National Association
+// https://www.iana.org/domains/root/db/jpmorgan.html
jpmorgan
-// jprs : 2014-09-18 Japan Registry Services Co., Ltd.
+// jprs : Japan Registry Services Co., Ltd.
+// https://www.iana.org/domains/root/db/jprs.html
jprs
-// juegos : 2014-03-20 Internet Naming Company LLC
+// juegos : Internet Naming Company LLC
+// https://www.iana.org/domains/root/db/juegos.html
juegos
-// juniper : 2015-07-30 JUNIPER NETWORKS, INC.
+// juniper : JUNIPER NETWORKS, INC.
+// https://www.iana.org/domains/root/db/juniper.html
juniper
-// kaufen : 2013-11-07 Dog Beach, LLC
+// kaufen : Dog Beach, LLC
+// https://www.iana.org/domains/root/db/kaufen.html
kaufen
-// kddi : 2014-09-12 KDDI CORPORATION
+// kddi : KDDI CORPORATION
+// https://www.iana.org/domains/root/db/kddi.html
kddi
-// kerryhotels : 2015-04-30 Kerry Trading Co. Limited
+// kerryhotels : Kerry Trading Co. Limited
+// https://www.iana.org/domains/root/db/kerryhotels.html
kerryhotels
-// kerrylogistics : 2015-04-09 Kerry Trading Co. Limited
+// kerrylogistics : Kerry Trading Co. Limited
+// https://www.iana.org/domains/root/db/kerrylogistics.html
kerrylogistics
-// kerryproperties : 2015-04-09 Kerry Trading Co. Limited
+// kerryproperties : Kerry Trading Co. Limited
+// https://www.iana.org/domains/root/db/kerryproperties.html
kerryproperties
-// kfh : 2014-12-04 Kuwait Finance House
+// kfh : Kuwait Finance House
+// https://www.iana.org/domains/root/db/kfh.html
kfh
-// kia : 2015-07-09 KIA MOTORS CORPORATION
+// kia : KIA MOTORS CORPORATION
+// https://www.iana.org/domains/root/db/kia.html
kia
-// kids : 2021-08-13 DotKids Foundation Limited
+// kids : DotKids Foundation Limited
+// https://www.iana.org/domains/root/db/kids.html
kids
-// kim : 2013-09-23 Identity Digital Limited
+// kim : Identity Digital Limited
+// https://www.iana.org/domains/root/db/kim.html
kim
-// kinder : 2014-11-07 Ferrero Trading Lux S.A.
-kinder
-
-// kindle : 2015-06-25 Amazon Registry Services, Inc.
+// kindle : Amazon Registry Services, Inc.
+// https://www.iana.org/domains/root/db/kindle.html
kindle
-// kitchen : 2013-09-20 Binky Moon, LLC
+// kitchen : Binky Moon, LLC
+// https://www.iana.org/domains/root/db/kitchen.html
kitchen
-// kiwi : 2013-09-20 DOT KIWI LIMITED
+// kiwi : DOT KIWI LIMITED
+// https://www.iana.org/domains/root/db/kiwi.html
kiwi
-// koeln : 2014-01-09 dotKoeln GmbH
+// koeln : dotKoeln GmbH
+// https://www.iana.org/domains/root/db/koeln.html
koeln
-// komatsu : 2015-01-08 Komatsu Ltd.
+// komatsu : Komatsu Ltd.
+// https://www.iana.org/domains/root/db/komatsu.html
komatsu
-// kosher : 2015-08-20 Kosher Marketing Assets LLC
+// kosher : Kosher Marketing Assets LLC
+// https://www.iana.org/domains/root/db/kosher.html
kosher
-// kpmg : 2015-04-23 KPMG International Cooperative (KPMG International Genossenschaft)
+// kpmg : KPMG International Cooperative (KPMG International Genossenschaft)
+// https://www.iana.org/domains/root/db/kpmg.html
kpmg
-// kpn : 2015-01-08 Koninklijke KPN N.V.
+// kpn : Koninklijke KPN N.V.
+// https://www.iana.org/domains/root/db/kpn.html
kpn
-// krd : 2013-12-05 KRG Department of Information Technology
+// krd : KRG Department of Information Technology
+// https://www.iana.org/domains/root/db/krd.html
krd
-// kred : 2013-12-19 KredTLD Pty Ltd
+// kred : KredTLD Pty Ltd
+// https://www.iana.org/domains/root/db/kred.html
kred
-// kuokgroup : 2015-04-09 Kerry Trading Co. Limited
+// kuokgroup : Kerry Trading Co. Limited
+// https://www.iana.org/domains/root/db/kuokgroup.html
kuokgroup
-// kyoto : 2014-11-07 Academic Institution: Kyoto Jyoho Gakuen
+// kyoto : Academic Institution: Kyoto Jyoho Gakuen
+// https://www.iana.org/domains/root/db/kyoto.html
kyoto
-// lacaixa : 2014-01-09 Fundación Bancaria Caixa d’Estalvis i Pensions de Barcelona, “la Caixa”
+// lacaixa : Fundación Bancaria Caixa d’Estalvis i Pensions de Barcelona, “la Caixa”
+// https://www.iana.org/domains/root/db/lacaixa.html
lacaixa
-// lamborghini : 2015-06-04 Automobili Lamborghini S.p.A.
+// lamborghini : Automobili Lamborghini S.p.A.
+// https://www.iana.org/domains/root/db/lamborghini.html
lamborghini
-// lamer : 2015-10-01 The Estée Lauder Companies Inc.
+// lamer : The Estée Lauder Companies Inc.
+// https://www.iana.org/domains/root/db/lamer.html
lamer
-// lancaster : 2015-02-12 LANCASTER
+// lancaster : LANCASTER
+// https://www.iana.org/domains/root/db/lancaster.html
lancaster
-// lancia : 2015-07-31 Fiat Chrysler Automobiles N.V.
-lancia
-
-// land : 2013-09-10 Binky Moon, LLC
+// land : Binky Moon, LLC
+// https://www.iana.org/domains/root/db/land.html
land
-// landrover : 2014-11-13 Jaguar Land Rover Ltd
+// landrover : Jaguar Land Rover Ltd
+// https://www.iana.org/domains/root/db/landrover.html
landrover
-// lanxess : 2015-07-30 LANXESS Corporation
+// lanxess : LANXESS Corporation
+// https://www.iana.org/domains/root/db/lanxess.html
lanxess
-// lasalle : 2015-04-02 Jones Lang LaSalle Incorporated
+// lasalle : Jones Lang LaSalle Incorporated
+// https://www.iana.org/domains/root/db/lasalle.html
lasalle
-// lat : 2014-10-16 XYZ.COM LLC
+// lat : XYZ.COM LLC
+// https://www.iana.org/domains/root/db/lat.html
lat
-// latino : 2015-07-30 Dish DBS Corporation
+// latino : Dish DBS Corporation
+// https://www.iana.org/domains/root/db/latino.html
latino
-// latrobe : 2014-06-16 La Trobe University
+// latrobe : La Trobe University
+// https://www.iana.org/domains/root/db/latrobe.html
latrobe
-// law : 2015-01-22 Registry Services, LLC
+// law : Registry Services, LLC
+// https://www.iana.org/domains/root/db/law.html
law
-// lawyer : 2014-03-20 Dog Beach, LLC
+// lawyer : Dog Beach, LLC
+// https://www.iana.org/domains/root/db/lawyer.html
lawyer
-// lds : 2014-03-20 IRI Domain Management, LLC
+// lds : IRI Domain Management, LLC
+// https://www.iana.org/domains/root/db/lds.html
lds
-// lease : 2014-03-06 Binky Moon, LLC
+// lease : Binky Moon, LLC
+// https://www.iana.org/domains/root/db/lease.html
lease
-// leclerc : 2014-08-07 A.C.D. LEC Association des Centres Distributeurs Edouard Leclerc
+// leclerc : A.C.D. LEC Association des Centres Distributeurs Edouard Leclerc
+// https://www.iana.org/domains/root/db/leclerc.html
leclerc
-// lefrak : 2015-07-16 LeFrak Organization, Inc.
+// lefrak : LeFrak Organization, Inc.
+// https://www.iana.org/domains/root/db/lefrak.html
lefrak
-// legal : 2014-10-16 Binky Moon, LLC
+// legal : Binky Moon, LLC
+// https://www.iana.org/domains/root/db/legal.html
legal
-// lego : 2015-07-16 LEGO Juris A/S
+// lego : LEGO Juris A/S
+// https://www.iana.org/domains/root/db/lego.html
lego
-// lexus : 2015-04-23 TOYOTA MOTOR CORPORATION
+// lexus : TOYOTA MOTOR CORPORATION
+// https://www.iana.org/domains/root/db/lexus.html
lexus
-// lgbt : 2014-05-08 Identity Digital Limited
+// lgbt : Identity Digital Limited
+// https://www.iana.org/domains/root/db/lgbt.html
lgbt
-// lidl : 2014-09-18 Schwarz Domains und Services GmbH & Co. KG
+// lidl : Schwarz Domains und Services GmbH & Co. KG
+// https://www.iana.org/domains/root/db/lidl.html
lidl
-// life : 2014-02-06 Binky Moon, LLC
+// life : Binky Moon, LLC
+// https://www.iana.org/domains/root/db/life.html
life
-// lifeinsurance : 2015-01-15 American Council of Life Insurers
+// lifeinsurance : American Council of Life Insurers
+// https://www.iana.org/domains/root/db/lifeinsurance.html
lifeinsurance
-// lifestyle : 2014-12-11 Lifestyle Domain Holdings, Inc.
+// lifestyle : Internet Naming Company LLC
+// https://www.iana.org/domains/root/db/lifestyle.html
lifestyle
-// lighting : 2013-08-27 Binky Moon, LLC
+// lighting : Binky Moon, LLC
+// https://www.iana.org/domains/root/db/lighting.html
lighting
-// like : 2014-12-18 Amazon Registry Services, Inc.
+// like : Amazon Registry Services, Inc.
+// https://www.iana.org/domains/root/db/like.html
like
-// lilly : 2015-07-31 Eli Lilly and Company
+// lilly : Eli Lilly and Company
+// https://www.iana.org/domains/root/db/lilly.html
lilly
-// limited : 2014-03-06 Binky Moon, LLC
+// limited : Binky Moon, LLC
+// https://www.iana.org/domains/root/db/limited.html
limited
-// limo : 2013-10-17 Binky Moon, LLC
+// limo : Binky Moon, LLC
+// https://www.iana.org/domains/root/db/limo.html
limo
-// lincoln : 2014-11-13 Ford Motor Company
+// lincoln : Ford Motor Company
+// https://www.iana.org/domains/root/db/lincoln.html
lincoln
-// linde : 2014-12-04 Linde Aktiengesellschaft
-linde
-
-// link : 2013-11-14 Nova Registry Ltd
+// link : Nova Registry Ltd
+// https://www.iana.org/domains/root/db/link.html
link
-// lipsy : 2015-06-25 Lipsy Ltd
+// lipsy : Lipsy Ltd
+// https://www.iana.org/domains/root/db/lipsy.html
lipsy
-// live : 2014-12-04 Dog Beach, LLC
+// live : Dog Beach, LLC
+// https://www.iana.org/domains/root/db/live.html
live
-// living : 2015-07-30 Lifestyle Domain Holdings, Inc.
+// living : Internet Naming Company LLC
+// https://www.iana.org/domains/root/db/living.html
living
-// llc : 2017-12-14 Identity Digital Limited
+// llc : Identity Digital Limited
+// https://www.iana.org/domains/root/db/llc.html
llc
-// llp : 2019-08-26 Intercap Registry Inc.
+// llp : Intercap Registry Inc.
+// https://www.iana.org/domains/root/db/llp.html
llp
-// loan : 2014-11-20 dot Loan Limited
+// loan : dot Loan Limited
+// https://www.iana.org/domains/root/db/loan.html
loan
-// loans : 2014-03-20 Binky Moon, LLC
+// loans : Binky Moon, LLC
+// https://www.iana.org/domains/root/db/loans.html
loans
-// locker : 2015-06-04 Dish DBS Corporation
+// locker : Orange Domains LLC
+// https://www.iana.org/domains/root/db/locker.html
locker
-// locus : 2015-06-25 Locus Analytics LLC
+// locus : Locus Analytics LLC
+// https://www.iana.org/domains/root/db/locus.html
locus
-// loft : 2015-07-30 Annco, Inc.
-loft
-
-// lol : 2015-01-30 XYZ.COM LLC
+// lol : XYZ.COM LLC
+// https://www.iana.org/domains/root/db/lol.html
lol
-// london : 2013-11-14 Dot London Domains Limited
+// london : Dot London Domains Limited
+// https://www.iana.org/domains/root/db/london.html
london
-// lotte : 2014-11-07 Lotte Holdings Co., Ltd.
+// lotte : Lotte Holdings Co., Ltd.
+// https://www.iana.org/domains/root/db/lotte.html
lotte
-// lotto : 2014-04-10 Identity Digital Limited
+// lotto : Identity Digital Limited
+// https://www.iana.org/domains/root/db/lotto.html
lotto
-// love : 2014-12-22 Merchant Law Group LLP
+// love : Merchant Law Group LLP
+// https://www.iana.org/domains/root/db/love.html
love
-// lpl : 2015-07-30 LPL Holdings, Inc.
+// lpl : LPL Holdings, Inc.
+// https://www.iana.org/domains/root/db/lpl.html
lpl
-// lplfinancial : 2015-07-30 LPL Holdings, Inc.
+// lplfinancial : LPL Holdings, Inc.
+// https://www.iana.org/domains/root/db/lplfinancial.html
lplfinancial
-// ltd : 2014-09-25 Binky Moon, LLC
+// ltd : Binky Moon, LLC
+// https://www.iana.org/domains/root/db/ltd.html
ltd
-// ltda : 2014-04-17 InterNetX, Corp
+// ltda : InterNetX, Corp
+// https://www.iana.org/domains/root/db/ltda.html
ltda
-// lundbeck : 2015-08-06 H. Lundbeck A/S
+// lundbeck : H. Lundbeck A/S
+// https://www.iana.org/domains/root/db/lundbeck.html
lundbeck
-// luxe : 2014-01-09 Registry Services, LLC
+// luxe : Registry Services, LLC
+// https://www.iana.org/domains/root/db/luxe.html
luxe
-// luxury : 2013-10-17 Luxury Partners, LLC
+// luxury : Luxury Partners, LLC
+// https://www.iana.org/domains/root/db/luxury.html
luxury
-// macys : 2015-07-31 Macys, Inc.
-macys
-
-// madrid : 2014-05-01 Comunidad de Madrid
+// madrid : Comunidad de Madrid
+// https://www.iana.org/domains/root/db/madrid.html
madrid
-// maif : 2014-10-02 Mutuelle Assurance Instituteur France (MAIF)
+// maif : Mutuelle Assurance Instituteur France (MAIF)
+// https://www.iana.org/domains/root/db/maif.html
maif
-// maison : 2013-12-05 Binky Moon, LLC
+// maison : Binky Moon, LLC
+// https://www.iana.org/domains/root/db/maison.html
maison
-// makeup : 2015-01-15 XYZ.COM LLC
+// makeup : XYZ.COM LLC
+// https://www.iana.org/domains/root/db/makeup.html
makeup
-// man : 2014-12-04 MAN SE
+// man : MAN SE
+// https://www.iana.org/domains/root/db/man.html
man
-// management : 2013-11-07 Binky Moon, LLC
+// management : Binky Moon, LLC
+// https://www.iana.org/domains/root/db/management.html
management
-// mango : 2013-10-24 PUNTO FA S.L.
+// mango : PUNTO FA S.L.
+// https://www.iana.org/domains/root/db/mango.html
mango
-// map : 2016-06-09 Charleston Road Registry Inc.
+// map : Charleston Road Registry Inc.
+// https://www.iana.org/domains/root/db/map.html
map
-// market : 2014-03-06 Dog Beach, LLC
+// market : Dog Beach, LLC
+// https://www.iana.org/domains/root/db/market.html
market
-// marketing : 2013-11-07 Binky Moon, LLC
+// marketing : Binky Moon, LLC
+// https://www.iana.org/domains/root/db/marketing.html
marketing
-// markets : 2014-12-11 Dog Beach, LLC
+// markets : Dog Beach, LLC
+// https://www.iana.org/domains/root/db/markets.html
markets
-// marriott : 2014-10-09 Marriott Worldwide Corporation
+// marriott : Marriott Worldwide Corporation
+// https://www.iana.org/domains/root/db/marriott.html
marriott
-// marshalls : 2015-07-16 The TJX Companies, Inc.
+// marshalls : The TJX Companies, Inc.
+// https://www.iana.org/domains/root/db/marshalls.html
marshalls
-// maserati : 2015-07-31 Fiat Chrysler Automobiles N.V.
-maserati
-
-// mattel : 2015-08-06 Mattel Sites, Inc.
+// mattel : Mattel Sites, Inc.
+// https://www.iana.org/domains/root/db/mattel.html
mattel
-// mba : 2015-04-02 Binky Moon, LLC
+// mba : Binky Moon, LLC
+// https://www.iana.org/domains/root/db/mba.html
mba
-// mckinsey : 2015-07-31 McKinsey Holdings, Inc.
+// mckinsey : McKinsey Holdings, Inc.
+// https://www.iana.org/domains/root/db/mckinsey.html
mckinsey
-// med : 2015-08-06 Medistry LLC
+// med : Medistry LLC
+// https://www.iana.org/domains/root/db/med.html
med
-// media : 2014-03-06 Binky Moon, LLC
+// media : Binky Moon, LLC
+// https://www.iana.org/domains/root/db/media.html
media
-// meet : 2014-01-16 Charleston Road Registry Inc.
+// meet : Charleston Road Registry Inc.
+// https://www.iana.org/domains/root/db/meet.html
meet
-// melbourne : 2014-05-29 The Crown in right of the State of Victoria, represented by its Department of State Development, Business and Innovation
+// melbourne : The Crown in right of the State of Victoria, represented by its Department of State Development, Business and Innovation
+// https://www.iana.org/domains/root/db/melbourne.html
melbourne
-// meme : 2014-01-30 Charleston Road Registry Inc.
+// meme : Charleston Road Registry Inc.
+// https://www.iana.org/domains/root/db/meme.html
meme
-// memorial : 2014-10-16 Dog Beach, LLC
+// memorial : Dog Beach, LLC
+// https://www.iana.org/domains/root/db/memorial.html
memorial
-// men : 2015-02-26 Exclusive Registry Limited
+// men : Exclusive Registry Limited
+// https://www.iana.org/domains/root/db/men.html
men
-// menu : 2013-09-11 Dot Menu Registry, LLC
+// menu : Dot Menu Registry, LLC
+// https://www.iana.org/domains/root/db/menu.html
menu
-// merckmsd : 2016-07-14 MSD Registry Holdings, Inc.
+// merckmsd : MSD Registry Holdings, Inc.
+// https://www.iana.org/domains/root/db/merckmsd.html
merckmsd
-// miami : 2013-12-19 Registry Services, LLC
+// miami : Registry Services, LLC
+// https://www.iana.org/domains/root/db/miami.html
miami
-// microsoft : 2014-12-18 Microsoft Corporation
+// microsoft : Microsoft Corporation
+// https://www.iana.org/domains/root/db/microsoft.html
microsoft
-// mini : 2014-01-09 Bayerische Motoren Werke Aktiengesellschaft
+// mini : Bayerische Motoren Werke Aktiengesellschaft
+// https://www.iana.org/domains/root/db/mini.html
mini
-// mint : 2015-07-30 Intuit Administrative Services, Inc.
+// mint : Intuit Administrative Services, Inc.
+// https://www.iana.org/domains/root/db/mint.html
mint
-// mit : 2015-07-02 Massachusetts Institute of Technology
+// mit : Massachusetts Institute of Technology
+// https://www.iana.org/domains/root/db/mit.html
mit
-// mitsubishi : 2015-07-23 Mitsubishi Corporation
+// mitsubishi : Mitsubishi Corporation
+// https://www.iana.org/domains/root/db/mitsubishi.html
mitsubishi
-// mlb : 2015-05-21 MLB Advanced Media DH, LLC
+// mlb : MLB Advanced Media DH, LLC
+// https://www.iana.org/domains/root/db/mlb.html
mlb
-// mls : 2015-04-23 The Canadian Real Estate Association
+// mls : The Canadian Real Estate Association
+// https://www.iana.org/domains/root/db/mls.html
mls
-// mma : 2014-11-07 MMA IARD
+// mma : MMA IARD
+// https://www.iana.org/domains/root/db/mma.html
mma
-// mobile : 2016-06-02 Dish DBS Corporation
+// mobile : Dish DBS Corporation
+// https://www.iana.org/domains/root/db/mobile.html
mobile
-// moda : 2013-11-07 Dog Beach, LLC
+// moda : Dog Beach, LLC
+// https://www.iana.org/domains/root/db/moda.html
moda
-// moe : 2013-11-13 Interlink Systems Innovation Institute K.K.
+// moe : Interlink Systems Innovation Institute K.K.
+// https://www.iana.org/domains/root/db/moe.html
moe
-// moi : 2014-12-18 Amazon Registry Services, Inc.
+// moi : Amazon Registry Services, Inc.
+// https://www.iana.org/domains/root/db/moi.html
moi
-// mom : 2015-04-16 XYZ.COM LLC
+// mom : XYZ.COM LLC
+// https://www.iana.org/domains/root/db/mom.html
mom
-// monash : 2013-09-30 Monash University
+// monash : Monash University
+// https://www.iana.org/domains/root/db/monash.html
monash
-// money : 2014-10-16 Binky Moon, LLC
+// money : Binky Moon, LLC
+// https://www.iana.org/domains/root/db/money.html
money
-// monster : 2015-09-11 XYZ.COM LLC
+// monster : XYZ.COM LLC
+// https://www.iana.org/domains/root/db/monster.html
monster
-// mormon : 2013-12-05 IRI Domain Management, LLC
+// mormon : IRI Domain Management, LLC
+// https://www.iana.org/domains/root/db/mormon.html
mormon
-// mortgage : 2014-03-20 Dog Beach, LLC
+// mortgage : Dog Beach, LLC
+// https://www.iana.org/domains/root/db/mortgage.html
mortgage
-// moscow : 2013-12-19 Foundation for Assistance for Internet Technologies and Infrastructure Development (FAITID)
+// moscow : Foundation for Assistance for Internet Technologies and Infrastructure Development (FAITID)
+// https://www.iana.org/domains/root/db/moscow.html
moscow
-// moto : 2015-06-04 Motorola Trademark Holdings, LLC
+// moto : Motorola Trademark Holdings, LLC
+// https://www.iana.org/domains/root/db/moto.html
moto
-// motorcycles : 2014-01-09 XYZ.COM LLC
+// motorcycles : XYZ.COM LLC
+// https://www.iana.org/domains/root/db/motorcycles.html
motorcycles
-// mov : 2014-01-30 Charleston Road Registry Inc.
+// mov : Charleston Road Registry Inc.
+// https://www.iana.org/domains/root/db/mov.html
mov
-// movie : 2015-02-05 Binky Moon, LLC
+// movie : Binky Moon, LLC
+// https://www.iana.org/domains/root/db/movie.html
movie
-// msd : 2015-07-23 MSD Registry Holdings, Inc.
+// msd : MSD Registry Holdings, Inc.
+// https://www.iana.org/domains/root/db/msd.html
msd
-// mtn : 2014-12-04 MTN Dubai Limited
+// mtn : MTN Dubai Limited
+// https://www.iana.org/domains/root/db/mtn.html
mtn
-// mtr : 2015-03-12 MTR Corporation Limited
+// mtr : MTR Corporation Limited
+// https://www.iana.org/domains/root/db/mtr.html
mtr
-// music : 2021-05-04 DotMusic Limited
+// music : DotMusic Limited
+// https://www.iana.org/domains/root/db/music.html
music
-// mutual : 2015-04-02 Northwestern Mutual MU TLD Registry, LLC
-mutual
-
-// nab : 2015-08-20 National Australia Bank Limited
+// nab : National Australia Bank Limited
+// https://www.iana.org/domains/root/db/nab.html
nab
-// nagoya : 2013-10-24 GMO Registry, Inc.
+// nagoya : GMO Registry, Inc.
+// https://www.iana.org/domains/root/db/nagoya.html
nagoya
-// natura : 2015-03-12 NATURA COSMÉTICOS S.A.
+// natura : NATURA COSMÉTICOS S.A.
+// https://www.iana.org/domains/root/db/natura.html
natura
-// navy : 2014-03-06 Dog Beach, LLC
+// navy : Dog Beach, LLC
+// https://www.iana.org/domains/root/db/navy.html
navy
-// nba : 2015-07-31 NBA REGISTRY, LLC
+// nba : NBA REGISTRY, LLC
+// https://www.iana.org/domains/root/db/nba.html
nba
-// nec : 2015-01-08 NEC Corporation
+// nec : NEC Corporation
+// https://www.iana.org/domains/root/db/nec.html
nec
-// netbank : 2014-06-26 COMMONWEALTH BANK OF AUSTRALIA
+// netbank : COMMONWEALTH BANK OF AUSTRALIA
+// https://www.iana.org/domains/root/db/netbank.html
netbank
-// netflix : 2015-06-18 Netflix, Inc.
+// netflix : Netflix, Inc.
+// https://www.iana.org/domains/root/db/netflix.html
netflix
-// network : 2013-11-14 Binky Moon, LLC
+// network : Binky Moon, LLC
+// https://www.iana.org/domains/root/db/network.html
network
-// neustar : 2013-12-05 NeuStar, Inc.
+// neustar : NeuStar, Inc.
+// https://www.iana.org/domains/root/db/neustar.html
neustar
-// new : 2014-01-30 Charleston Road Registry Inc.
+// new : Charleston Road Registry Inc.
+// https://www.iana.org/domains/root/db/new.html
new
-// news : 2014-12-18 Dog Beach, LLC
+// news : Dog Beach, LLC
+// https://www.iana.org/domains/root/db/news.html
news
-// next : 2015-06-18 Next plc
+// next : Next plc
+// https://www.iana.org/domains/root/db/next.html
next
-// nextdirect : 2015-06-18 Next plc
+// nextdirect : Next plc
+// https://www.iana.org/domains/root/db/nextdirect.html
nextdirect
-// nexus : 2014-07-24 Charleston Road Registry Inc.
+// nexus : Charleston Road Registry Inc.
+// https://www.iana.org/domains/root/db/nexus.html
nexus
-// nfl : 2015-07-23 NFL Reg Ops LLC
+// nfl : NFL Reg Ops LLC
+// https://www.iana.org/domains/root/db/nfl.html
nfl
-// ngo : 2014-03-06 Public Interest Registry
+// ngo : Public Interest Registry
+// https://www.iana.org/domains/root/db/ngo.html
ngo
-// nhk : 2014-02-13 Japan Broadcasting Corporation (NHK)
+// nhk : Japan Broadcasting Corporation (NHK)
+// https://www.iana.org/domains/root/db/nhk.html
nhk
-// nico : 2014-12-04 DWANGO Co., Ltd.
+// nico : DWANGO Co., Ltd.
+// https://www.iana.org/domains/root/db/nico.html
nico
-// nike : 2015-07-23 NIKE, Inc.
+// nike : NIKE, Inc.
+// https://www.iana.org/domains/root/db/nike.html
nike
-// nikon : 2015-05-21 NIKON CORPORATION
+// nikon : NIKON CORPORATION
+// https://www.iana.org/domains/root/db/nikon.html
nikon
-// ninja : 2013-11-07 Dog Beach, LLC
+// ninja : Dog Beach, LLC
+// https://www.iana.org/domains/root/db/ninja.html
ninja
-// nissan : 2014-03-27 NISSAN MOTOR CO., LTD.
+// nissan : NISSAN MOTOR CO., LTD.
+// https://www.iana.org/domains/root/db/nissan.html
nissan
-// nissay : 2015-10-29 Nippon Life Insurance Company
+// nissay : Nippon Life Insurance Company
+// https://www.iana.org/domains/root/db/nissay.html
nissay
-// nokia : 2015-01-08 Nokia Corporation
+// nokia : Nokia Corporation
+// https://www.iana.org/domains/root/db/nokia.html
nokia
-// northwesternmutual : 2015-06-18 Northwestern Mutual Registry, LLC
-northwesternmutual
-
-// norton : 2014-12-04 NortonLifeLock Inc.
+// norton : NortonLifeLock Inc.
+// https://www.iana.org/domains/root/db/norton.html
norton
-// now : 2015-06-25 Amazon Registry Services, Inc.
+// now : Amazon Registry Services, Inc.
+// https://www.iana.org/domains/root/db/now.html
now
-// nowruz : 2014-09-04 Asia Green IT System Bilgisayar San. ve Tic. Ltd. Sti.
+// nowruz : Asia Green IT System Bilgisayar San. ve Tic. Ltd. Sti.
+// https://www.iana.org/domains/root/db/nowruz.html
nowruz
-// nowtv : 2015-05-14 Starbucks (HK) Limited
+// nowtv : Starbucks (HK) Limited
+// https://www.iana.org/domains/root/db/nowtv.html
nowtv
-// nra : 2014-05-22 NRA Holdings Company, INC.
+// nra : NRA Holdings Company, INC.
+// https://www.iana.org/domains/root/db/nra.html
nra
-// nrw : 2013-11-21 Minds + Machines GmbH
+// nrw : Minds + Machines GmbH
+// https://www.iana.org/domains/root/db/nrw.html
nrw
-// ntt : 2014-10-31 NIPPON TELEGRAPH AND TELEPHONE CORPORATION
+// ntt : NIPPON TELEGRAPH AND TELEPHONE CORPORATION
+// https://www.iana.org/domains/root/db/ntt.html
ntt
-// nyc : 2014-01-23 The City of New York by and through the New York City Department of Information Technology & Telecommunications
+// nyc : The City of New York by and through the New York City Department of Information Technology & Telecommunications
+// https://www.iana.org/domains/root/db/nyc.html
nyc
-// obi : 2014-09-25 OBI Group Holding SE & Co. KGaA
+// obi : OBI Group Holding SE & Co. KGaA
+// https://www.iana.org/domains/root/db/obi.html
obi
-// observer : 2015-04-30 Dog Beach, LLC
+// observer : Fegistry, LLC
+// https://www.iana.org/domains/root/db/observer.html
observer
-// office : 2015-03-12 Microsoft Corporation
+// office : Microsoft Corporation
+// https://www.iana.org/domains/root/db/office.html
office
-// okinawa : 2013-12-05 BRregistry, Inc.
+// okinawa : BRregistry, Inc.
+// https://www.iana.org/domains/root/db/okinawa.html
okinawa
-// olayan : 2015-05-14 Crescent Holding GmbH
+// olayan : Competrol (Luxembourg) Sarl
+// https://www.iana.org/domains/root/db/olayan.html
olayan
-// olayangroup : 2015-05-14 Crescent Holding GmbH
+// olayangroup : Competrol (Luxembourg) Sarl
+// https://www.iana.org/domains/root/db/olayangroup.html
olayangroup
-// oldnavy : 2015-07-31 The Gap, Inc.
+// oldnavy : The Gap, Inc.
+// https://www.iana.org/domains/root/db/oldnavy.html
oldnavy
-// ollo : 2015-06-04 Dish DBS Corporation
+// ollo : Dish DBS Corporation
+// https://www.iana.org/domains/root/db/ollo.html
ollo
-// omega : 2015-01-08 The Swatch Group Ltd
+// omega : The Swatch Group Ltd
+// https://www.iana.org/domains/root/db/omega.html
omega
-// one : 2014-11-07 One.com A/S
+// one : One.com A/S
+// https://www.iana.org/domains/root/db/one.html
one
-// ong : 2014-03-06 Public Interest Registry
+// ong : Public Interest Registry
+// https://www.iana.org/domains/root/db/ong.html
ong
-// onl : 2013-09-16 iRegistry GmbH
+// onl : iRegistry GmbH
+// https://www.iana.org/domains/root/db/onl.html
onl
-// online : 2015-01-15 Radix FZC
+// online : Radix FZC DMCC
+// https://www.iana.org/domains/root/db/online.html
online
-// ooo : 2014-01-09 INFIBEAM AVENUES LIMITED
+// ooo : INFIBEAM AVENUES LIMITED
+// https://www.iana.org/domains/root/db/ooo.html
ooo
-// open : 2015-07-31 American Express Travel Related Services Company, Inc.
+// open : American Express Travel Related Services Company, Inc.
+// https://www.iana.org/domains/root/db/open.html
open
-// oracle : 2014-06-19 Oracle Corporation
+// oracle : Oracle Corporation
+// https://www.iana.org/domains/root/db/oracle.html
oracle
-// orange : 2015-03-12 Orange Brand Services Limited
+// orange : Orange Brand Services Limited
+// https://www.iana.org/domains/root/db/orange.html
orange
-// organic : 2014-03-27 Identity Digital Limited
+// organic : Identity Digital Limited
+// https://www.iana.org/domains/root/db/organic.html
organic
-// origins : 2015-10-01 The Estée Lauder Companies Inc.
+// origins : The Estée Lauder Companies Inc.
+// https://www.iana.org/domains/root/db/origins.html
origins
-// osaka : 2014-09-04 Osaka Registry Co., Ltd.
+// osaka : Osaka Registry Co., Ltd.
+// https://www.iana.org/domains/root/db/osaka.html
osaka
-// otsuka : 2013-10-11 Otsuka Holdings Co., Ltd.
+// otsuka : Otsuka Holdings Co., Ltd.
+// https://www.iana.org/domains/root/db/otsuka.html
otsuka
-// ott : 2015-06-04 Dish DBS Corporation
+// ott : Dish DBS Corporation
+// https://www.iana.org/domains/root/db/ott.html
ott
-// ovh : 2014-01-16 MédiaBC
+// ovh : MédiaBC
+// https://www.iana.org/domains/root/db/ovh.html
ovh
-// page : 2014-12-04 Charleston Road Registry Inc.
+// page : Charleston Road Registry Inc.
+// https://www.iana.org/domains/root/db/page.html
page
-// panasonic : 2015-07-30 Panasonic Corporation
+// panasonic : Panasonic Holdings Corporation
+// https://www.iana.org/domains/root/db/panasonic.html
panasonic
-// paris : 2014-01-30 City of Paris
+// paris : City of Paris
+// https://www.iana.org/domains/root/db/paris.html
paris
-// pars : 2014-09-04 Asia Green IT System Bilgisayar San. ve Tic. Ltd. Sti.
+// pars : Asia Green IT System Bilgisayar San. ve Tic. Ltd. Sti.
+// https://www.iana.org/domains/root/db/pars.html
pars
-// partners : 2013-12-05 Binky Moon, LLC
+// partners : Binky Moon, LLC
+// https://www.iana.org/domains/root/db/partners.html
partners
-// parts : 2013-12-05 Binky Moon, LLC
+// parts : Binky Moon, LLC
+// https://www.iana.org/domains/root/db/parts.html
parts
-// party : 2014-09-11 Blue Sky Registry Limited
+// party : Blue Sky Registry Limited
+// https://www.iana.org/domains/root/db/party.html
party
-// passagens : 2015-03-05 Travel Reservations SRL
-passagens
-
-// pay : 2015-08-27 Amazon Registry Services, Inc.
+// pay : Amazon Registry Services, Inc.
+// https://www.iana.org/domains/root/db/pay.html
pay
-// pccw : 2015-05-14 PCCW Enterprises Limited
+// pccw : PCCW Enterprises Limited
+// https://www.iana.org/domains/root/db/pccw.html
pccw
-// pet : 2015-05-07 Identity Digital Limited
+// pet : Identity Digital Limited
+// https://www.iana.org/domains/root/db/pet.html
pet
-// pfizer : 2015-09-11 Pfizer Inc.
+// pfizer : Pfizer Inc.
+// https://www.iana.org/domains/root/db/pfizer.html
pfizer
-// pharmacy : 2014-06-19 National Association of Boards of Pharmacy
+// pharmacy : National Association of Boards of Pharmacy
+// https://www.iana.org/domains/root/db/pharmacy.html
pharmacy
-// phd : 2016-07-28 Charleston Road Registry Inc.
+// phd : Charleston Road Registry Inc.
+// https://www.iana.org/domains/root/db/phd.html
phd
-// philips : 2014-11-07 Koninklijke Philips N.V.
+// philips : Koninklijke Philips N.V.
+// https://www.iana.org/domains/root/db/philips.html
philips
-// phone : 2016-06-02 Dish DBS Corporation
+// phone : Dish DBS Corporation
+// https://www.iana.org/domains/root/db/phone.html
phone
-// photo : 2013-11-14 Registry Services, LLC
+// photo : Registry Services, LLC
+// https://www.iana.org/domains/root/db/photo.html
photo
-// photography : 2013-09-20 Binky Moon, LLC
+// photography : Binky Moon, LLC
+// https://www.iana.org/domains/root/db/photography.html
photography
-// photos : 2013-10-17 Binky Moon, LLC
+// photos : Binky Moon, LLC
+// https://www.iana.org/domains/root/db/photos.html
photos
-// physio : 2014-05-01 PhysBiz Pty Ltd
+// physio : PhysBiz Pty Ltd
+// https://www.iana.org/domains/root/db/physio.html
physio
-// pics : 2013-11-14 XYZ.COM LLC
+// pics : XYZ.COM LLC
+// https://www.iana.org/domains/root/db/pics.html
pics
-// pictet : 2014-06-26 Pictet Europe S.A.
+// pictet : Pictet Europe S.A.
+// https://www.iana.org/domains/root/db/pictet.html
pictet
-// pictures : 2014-03-06 Binky Moon, LLC
+// pictures : Binky Moon, LLC
+// https://www.iana.org/domains/root/db/pictures.html
pictures
-// pid : 2015-01-08 Top Level Spectrum, Inc.
+// pid : Top Level Spectrum, Inc.
+// https://www.iana.org/domains/root/db/pid.html
pid
-// pin : 2014-12-18 Amazon Registry Services, Inc.
+// pin : Amazon Registry Services, Inc.
+// https://www.iana.org/domains/root/db/pin.html
pin
-// ping : 2015-06-11 Ping Registry Provider, Inc.
+// ping : Ping Registry Provider, Inc.
+// https://www.iana.org/domains/root/db/ping.html
ping
-// pink : 2013-10-01 Identity Digital Limited
+// pink : Identity Digital Limited
+// https://www.iana.org/domains/root/db/pink.html
pink
-// pioneer : 2015-07-16 Pioneer Corporation
+// pioneer : Pioneer Corporation
+// https://www.iana.org/domains/root/db/pioneer.html
pioneer
-// pizza : 2014-06-26 Binky Moon, LLC
+// pizza : Binky Moon, LLC
+// https://www.iana.org/domains/root/db/pizza.html
pizza
-// place : 2014-04-24 Binky Moon, LLC
+// place : Binky Moon, LLC
+// https://www.iana.org/domains/root/db/place.html
place
-// play : 2015-03-05 Charleston Road Registry Inc.
+// play : Charleston Road Registry Inc.
+// https://www.iana.org/domains/root/db/play.html
play
-// playstation : 2015-07-02 Sony Interactive Entertainment Inc.
+// playstation : Sony Interactive Entertainment Inc.
+// https://www.iana.org/domains/root/db/playstation.html
playstation
-// plumbing : 2013-09-10 Binky Moon, LLC
+// plumbing : Binky Moon, LLC
+// https://www.iana.org/domains/root/db/plumbing.html
plumbing
-// plus : 2015-02-05 Binky Moon, LLC
+// plus : Binky Moon, LLC
+// https://www.iana.org/domains/root/db/plus.html
plus
-// pnc : 2015-07-02 PNC Domain Co., LLC
+// pnc : PNC Domain Co., LLC
+// https://www.iana.org/domains/root/db/pnc.html
pnc
-// pohl : 2014-06-23 Deutsche Vermögensberatung Aktiengesellschaft DVAG
+// pohl : Deutsche Vermögensberatung Aktiengesellschaft DVAG
+// https://www.iana.org/domains/root/db/pohl.html
pohl
-// poker : 2014-07-03 Identity Digital Limited
+// poker : Identity Digital Limited
+// https://www.iana.org/domains/root/db/poker.html
poker
-// politie : 2015-08-20 Politie Nederland
+// politie : Politie Nederland
+// https://www.iana.org/domains/root/db/politie.html
politie
-// porn : 2014-10-16 ICM Registry PN LLC
+// porn : ICM Registry PN LLC
+// https://www.iana.org/domains/root/db/porn.html
porn
-// pramerica : 2015-07-30 Prudential Financial, Inc.
+// pramerica : Prudential Financial, Inc.
+// https://www.iana.org/domains/root/db/pramerica.html
pramerica
-// praxi : 2013-12-05 Praxi S.p.A.
+// praxi : Praxi S.p.A.
+// https://www.iana.org/domains/root/db/praxi.html
praxi
-// press : 2014-04-03 Radix FZC
+// press : Radix FZC DMCC
+// https://www.iana.org/domains/root/db/press.html
press
-// prime : 2015-06-25 Amazon Registry Services, Inc.
+// prime : Amazon Registry Services, Inc.
+// https://www.iana.org/domains/root/db/prime.html
prime
-// prod : 2014-01-23 Charleston Road Registry Inc.
+// prod : Charleston Road Registry Inc.
+// https://www.iana.org/domains/root/db/prod.html
prod
-// productions : 2013-12-05 Binky Moon, LLC
+// productions : Binky Moon, LLC
+// https://www.iana.org/domains/root/db/productions.html
productions
-// prof : 2014-07-24 Charleston Road Registry Inc.
+// prof : Charleston Road Registry Inc.
+// https://www.iana.org/domains/root/db/prof.html
prof
-// progressive : 2015-07-23 Progressive Casualty Insurance Company
+// progressive : Progressive Casualty Insurance Company
+// https://www.iana.org/domains/root/db/progressive.html
progressive
-// promo : 2014-12-18 Identity Digital Limited
+// promo : Identity Digital Limited
+// https://www.iana.org/domains/root/db/promo.html
promo
-// properties : 2013-12-05 Binky Moon, LLC
+// properties : Binky Moon, LLC
+// https://www.iana.org/domains/root/db/properties.html
properties
-// property : 2014-05-22 Internet Naming Company LLC
+// property : Digital Property Infrastructure Limited
+// https://www.iana.org/domains/root/db/property.html
property
-// protection : 2015-04-23 XYZ.COM LLC
+// protection : XYZ.COM LLC
+// https://www.iana.org/domains/root/db/protection.html
protection
-// pru : 2015-07-30 Prudential Financial, Inc.
+// pru : Prudential Financial, Inc.
+// https://www.iana.org/domains/root/db/pru.html
pru
-// prudential : 2015-07-30 Prudential Financial, Inc.
+// prudential : Prudential Financial, Inc.
+// https://www.iana.org/domains/root/db/prudential.html
prudential
-// pub : 2013-12-12 Dog Beach, LLC
+// pub : Dog Beach, LLC
+// https://www.iana.org/domains/root/db/pub.html
pub
-// pwc : 2015-10-29 PricewaterhouseCoopers LLP
+// pwc : PricewaterhouseCoopers LLP
+// https://www.iana.org/domains/root/db/pwc.html
pwc
-// qpon : 2013-11-14 dotCOOL, Inc.
+// qpon : dotQPON LLC
+// https://www.iana.org/domains/root/db/qpon.html
qpon
-// quebec : 2013-12-19 PointQuébec Inc
+// quebec : PointQuébec Inc
+// https://www.iana.org/domains/root/db/quebec.html
quebec
-// quest : 2015-03-26 XYZ.COM LLC
+// quest : XYZ.COM LLC
+// https://www.iana.org/domains/root/db/quest.html
quest
-// racing : 2014-12-04 Premier Registry Limited
+// racing : Premier Registry Limited
+// https://www.iana.org/domains/root/db/racing.html
racing
-// radio : 2016-07-21 European Broadcasting Union (EBU)
+// radio : European Broadcasting Union (EBU)
+// https://www.iana.org/domains/root/db/radio.html
radio
-// read : 2014-12-18 Amazon Registry Services, Inc.
+// read : Amazon Registry Services, Inc.
+// https://www.iana.org/domains/root/db/read.html
read
-// realestate : 2015-09-11 dotRealEstate LLC
+// realestate : dotRealEstate LLC
+// https://www.iana.org/domains/root/db/realestate.html
realestate
-// realtor : 2014-05-29 Real Estate Domains LLC
+// realtor : Real Estate Domains LLC
+// https://www.iana.org/domains/root/db/realtor.html
realtor
-// realty : 2015-03-19 Dog Beach, LLC
+// realty : Internet Naming Company LLC
+// https://www.iana.org/domains/root/db/realty.html
realty
-// recipes : 2013-10-17 Binky Moon, LLC
+// recipes : Binky Moon, LLC
+// https://www.iana.org/domains/root/db/recipes.html
recipes
-// red : 2013-11-07 Identity Digital Limited
+// red : Identity Digital Limited
+// https://www.iana.org/domains/root/db/red.html
red
-// redstone : 2014-10-31 Redstone Haute Couture Co., Ltd.
+// redstone : Redstone Haute Couture Co., Ltd.
+// https://www.iana.org/domains/root/db/redstone.html
redstone
-// redumbrella : 2015-03-26 Travelers TLD, LLC
+// redumbrella : Travelers TLD, LLC
+// https://www.iana.org/domains/root/db/redumbrella.html
redumbrella
-// rehab : 2014-03-06 Dog Beach, LLC
+// rehab : Dog Beach, LLC
+// https://www.iana.org/domains/root/db/rehab.html
rehab
-// reise : 2014-03-13 Binky Moon, LLC
+// reise : Binky Moon, LLC
+// https://www.iana.org/domains/root/db/reise.html
reise
-// reisen : 2014-03-06 Binky Moon, LLC
+// reisen : Binky Moon, LLC
+// https://www.iana.org/domains/root/db/reisen.html
reisen
-// reit : 2014-09-04 National Association of Real Estate Investment Trusts, Inc.
+// reit : National Association of Real Estate Investment Trusts, Inc.
+// https://www.iana.org/domains/root/db/reit.html
reit
-// reliance : 2015-04-02 Reliance Industries Limited
+// reliance : Reliance Industries Limited
+// https://www.iana.org/domains/root/db/reliance.html
reliance
-// ren : 2013-12-12 ZDNS International Limited
+// ren : ZDNS International Limited
+// https://www.iana.org/domains/root/db/ren.html
ren
-// rent : 2014-12-04 XYZ.COM LLC
+// rent : XYZ.COM LLC
+// https://www.iana.org/domains/root/db/rent.html
rent
-// rentals : 2013-12-05 Binky Moon, LLC
+// rentals : Binky Moon, LLC
+// https://www.iana.org/domains/root/db/rentals.html
rentals
-// repair : 2013-11-07 Binky Moon, LLC
+// repair : Binky Moon, LLC
+// https://www.iana.org/domains/root/db/repair.html
repair
-// report : 2013-12-05 Binky Moon, LLC
+// report : Binky Moon, LLC
+// https://www.iana.org/domains/root/db/report.html
report
-// republican : 2014-03-20 Dog Beach, LLC
+// republican : Dog Beach, LLC
+// https://www.iana.org/domains/root/db/republican.html
republican
-// rest : 2013-12-19 Punto 2012 Sociedad Anonima Promotora de Inversion de Capital Variable
+// rest : Punto 2012 Sociedad Anonima Promotora de Inversion de Capital Variable
+// https://www.iana.org/domains/root/db/rest.html
rest
-// restaurant : 2014-07-03 Binky Moon, LLC
+// restaurant : Binky Moon, LLC
+// https://www.iana.org/domains/root/db/restaurant.html
restaurant
-// review : 2014-11-20 dot Review Limited
+// review : dot Review Limited
+// https://www.iana.org/domains/root/db/review.html
review
-// reviews : 2013-09-13 Dog Beach, LLC
+// reviews : Dog Beach, LLC
+// https://www.iana.org/domains/root/db/reviews.html
reviews
-// rexroth : 2015-06-18 Robert Bosch GMBH
+// rexroth : Robert Bosch GMBH
+// https://www.iana.org/domains/root/db/rexroth.html
rexroth
-// rich : 2013-11-21 iRegistry GmbH
+// rich : iRegistry GmbH
+// https://www.iana.org/domains/root/db/rich.html
rich
-// richardli : 2015-05-14 Pacific Century Asset Management (HK) Limited
+// richardli : Pacific Century Asset Management (HK) Limited
+// https://www.iana.org/domains/root/db/richardli.html
richardli
-// ricoh : 2014-11-20 Ricoh Company, Ltd.
+// ricoh : Ricoh Company, Ltd.
+// https://www.iana.org/domains/root/db/ricoh.html
ricoh
-// ril : 2015-04-02 Reliance Industries Limited
+// ril : Reliance Industries Limited
+// https://www.iana.org/domains/root/db/ril.html
ril
-// rio : 2014-02-27 Empresa Municipal de Informática SA - IPLANRIO
+// rio : Empresa Municipal de Informática SA - IPLANRIO
+// https://www.iana.org/domains/root/db/rio.html
rio
-// rip : 2014-07-10 Dog Beach, LLC
+// rip : Dog Beach, LLC
+// https://www.iana.org/domains/root/db/rip.html
rip
-// rocher : 2014-12-18 Ferrero Trading Lux S.A.
-rocher
-
-// rocks : 2013-11-14 Dog Beach, LLC
+// rocks : Dog Beach, LLC
+// https://www.iana.org/domains/root/db/rocks.html
rocks
-// rodeo : 2013-12-19 Registry Services, LLC
+// rodeo : Registry Services, LLC
+// https://www.iana.org/domains/root/db/rodeo.html
rodeo
-// rogers : 2015-08-06 Rogers Communications Canada Inc.
+// rogers : Rogers Communications Canada Inc.
+// https://www.iana.org/domains/root/db/rogers.html
rogers
-// room : 2014-12-18 Amazon Registry Services, Inc.
+// room : Amazon Registry Services, Inc.
+// https://www.iana.org/domains/root/db/room.html
room
-// rsvp : 2014-05-08 Charleston Road Registry Inc.
+// rsvp : Charleston Road Registry Inc.
+// https://www.iana.org/domains/root/db/rsvp.html
rsvp
-// rugby : 2016-12-15 World Rugby Strategic Developments Limited
+// rugby : World Rugby Strategic Developments Limited
+// https://www.iana.org/domains/root/db/rugby.html
rugby
-// ruhr : 2013-10-02 dotSaarland GmbH
+// ruhr : dotSaarland GmbH
+// https://www.iana.org/domains/root/db/ruhr.html
ruhr
-// run : 2015-03-19 Binky Moon, LLC
+// run : Binky Moon, LLC
+// https://www.iana.org/domains/root/db/run.html
run
-// rwe : 2015-04-02 RWE AG
+// rwe : RWE AG
+// https://www.iana.org/domains/root/db/rwe.html
rwe
-// ryukyu : 2014-01-09 BRregistry, Inc.
+// ryukyu : BRregistry, Inc.
+// https://www.iana.org/domains/root/db/ryukyu.html
ryukyu
-// saarland : 2013-12-12 dotSaarland GmbH
+// saarland : dotSaarland GmbH
+// https://www.iana.org/domains/root/db/saarland.html
saarland
-// safe : 2014-12-18 Amazon Registry Services, Inc.
+// safe : Amazon Registry Services, Inc.
+// https://www.iana.org/domains/root/db/safe.html
safe
-// safety : 2015-01-08 Safety Registry Services, LLC.
+// safety : Safety Registry Services, LLC.
+// https://www.iana.org/domains/root/db/safety.html
safety
-// sakura : 2014-12-18 SAKURA Internet Inc.
+// sakura : SAKURA Internet Inc.
+// https://www.iana.org/domains/root/db/sakura.html
sakura
-// sale : 2014-10-16 Dog Beach, LLC
+// sale : Dog Beach, LLC
+// https://www.iana.org/domains/root/db/sale.html
sale
-// salon : 2014-12-11 Binky Moon, LLC
+// salon : Binky Moon, LLC
+// https://www.iana.org/domains/root/db/salon.html
salon
-// samsclub : 2015-07-31 Wal-Mart Stores, Inc.
+// samsclub : Wal-Mart Stores, Inc.
+// https://www.iana.org/domains/root/db/samsclub.html
samsclub
-// samsung : 2014-04-03 SAMSUNG SDS CO., LTD
+// samsung : SAMSUNG SDS CO., LTD
+// https://www.iana.org/domains/root/db/samsung.html
samsung
-// sandvik : 2014-11-13 Sandvik AB
+// sandvik : Sandvik AB
+// https://www.iana.org/domains/root/db/sandvik.html
sandvik
-// sandvikcoromant : 2014-11-07 Sandvik AB
+// sandvikcoromant : Sandvik AB
+// https://www.iana.org/domains/root/db/sandvikcoromant.html
sandvikcoromant
-// sanofi : 2014-10-09 Sanofi
+// sanofi : Sanofi
+// https://www.iana.org/domains/root/db/sanofi.html
sanofi
-// sap : 2014-03-27 SAP AG
+// sap : SAP AG
+// https://www.iana.org/domains/root/db/sap.html
sap
-// sarl : 2014-07-03 Binky Moon, LLC
+// sarl : Binky Moon, LLC
+// https://www.iana.org/domains/root/db/sarl.html
sarl
-// sas : 2015-04-02 Research IP LLC
+// sas : Research IP LLC
+// https://www.iana.org/domains/root/db/sas.html
sas
-// save : 2015-06-25 Amazon Registry Services, Inc.
+// save : Amazon Registry Services, Inc.
+// https://www.iana.org/domains/root/db/save.html
save
-// saxo : 2014-10-31 Saxo Bank A/S
+// saxo : Saxo Bank A/S
+// https://www.iana.org/domains/root/db/saxo.html
saxo
-// sbi : 2015-03-12 STATE BANK OF INDIA
+// sbi : STATE BANK OF INDIA
+// https://www.iana.org/domains/root/db/sbi.html
sbi
-// sbs : 2014-11-07 ShortDot SA
+// sbs : ShortDot SA
+// https://www.iana.org/domains/root/db/sbs.html
sbs
-// sca : 2014-03-13 SVENSKA CELLULOSA AKTIEBOLAGET SCA (publ)
+// sca : SVENSKA CELLULOSA AKTIEBOLAGET SCA (publ)
+// https://www.iana.org/domains/root/db/sca.html
sca
-// scb : 2014-02-20 The Siam Commercial Bank Public Company Limited ("SCB")
+// scb : The Siam Commercial Bank Public Company Limited ("SCB")
+// https://www.iana.org/domains/root/db/scb.html
scb
-// schaeffler : 2015-08-06 Schaeffler Technologies AG & Co. KG
+// schaeffler : Schaeffler Technologies AG & Co. KG
+// https://www.iana.org/domains/root/db/schaeffler.html
schaeffler
-// schmidt : 2014-04-03 SCHMIDT GROUPE S.A.S.
+// schmidt : SCHMIDT GROUPE S.A.S.
+// https://www.iana.org/domains/root/db/schmidt.html
schmidt
-// scholarships : 2014-04-24 Scholarships.com, LLC
+// scholarships : Scholarships.com, LLC
+// https://www.iana.org/domains/root/db/scholarships.html
scholarships
-// school : 2014-12-18 Binky Moon, LLC
+// school : Binky Moon, LLC
+// https://www.iana.org/domains/root/db/school.html
school
-// schule : 2014-03-06 Binky Moon, LLC
+// schule : Binky Moon, LLC
+// https://www.iana.org/domains/root/db/schule.html
schule
-// schwarz : 2014-09-18 Schwarz Domains und Services GmbH & Co. KG
+// schwarz : Schwarz Domains und Services GmbH & Co. KG
+// https://www.iana.org/domains/root/db/schwarz.html
schwarz
-// science : 2014-09-11 dot Science Limited
+// science : dot Science Limited
+// https://www.iana.org/domains/root/db/science.html
science
-// scot : 2014-01-23 Dot Scot Registry Limited
+// scot : Dot Scot Registry Limited
+// https://www.iana.org/domains/root/db/scot.html
scot
-// search : 2016-06-09 Charleston Road Registry Inc.
+// search : Charleston Road Registry Inc.
+// https://www.iana.org/domains/root/db/search.html
search
-// seat : 2014-05-22 SEAT, S.A. (Sociedad Unipersonal)
+// seat : SEAT, S.A. (Sociedad Unipersonal)
+// https://www.iana.org/domains/root/db/seat.html
seat
-// secure : 2015-08-27 Amazon Registry Services, Inc.
+// secure : Amazon Registry Services, Inc.
+// https://www.iana.org/domains/root/db/secure.html
secure
-// security : 2015-05-14 XYZ.COM LLC
+// security : XYZ.COM LLC
+// https://www.iana.org/domains/root/db/security.html
security
-// seek : 2014-12-04 Seek Limited
+// seek : Seek Limited
+// https://www.iana.org/domains/root/db/seek.html
seek
-// select : 2015-10-08 Registry Services, LLC
+// select : Registry Services, LLC
+// https://www.iana.org/domains/root/db/select.html
select
-// sener : 2014-10-24 Sener Ingeniería y Sistemas, S.A.
+// sener : Sener Ingeniería y Sistemas, S.A.
+// https://www.iana.org/domains/root/db/sener.html
sener
-// services : 2014-02-27 Binky Moon, LLC
+// services : Binky Moon, LLC
+// https://www.iana.org/domains/root/db/services.html
services
-// ses : 2015-07-23 SES
-ses
-
-// seven : 2015-08-06 Seven West Media Ltd
+// seven : Seven West Media Ltd
+// https://www.iana.org/domains/root/db/seven.html
seven
-// sew : 2014-07-17 SEW-EURODRIVE GmbH & Co KG
+// sew : SEW-EURODRIVE GmbH & Co KG
+// https://www.iana.org/domains/root/db/sew.html
sew
-// sex : 2014-11-13 ICM Registry SX LLC
+// sex : ICM Registry SX LLC
+// https://www.iana.org/domains/root/db/sex.html
sex
-// sexy : 2013-09-11 Internet Naming Company LLC
+// sexy : Internet Naming Company LLC
+// https://www.iana.org/domains/root/db/sexy.html
sexy
-// sfr : 2015-08-13 Societe Francaise du Radiotelephone - SFR
+// sfr : Societe Francaise du Radiotelephone - SFR
+// https://www.iana.org/domains/root/db/sfr.html
sfr
-// shangrila : 2015-09-03 Shangri‐La International Hotel Management Limited
+// shangrila : Shangri‐La International Hotel Management Limited
+// https://www.iana.org/domains/root/db/shangrila.html
shangrila
-// sharp : 2014-05-01 Sharp Corporation
+// sharp : Sharp Corporation
+// https://www.iana.org/domains/root/db/sharp.html
sharp
-// shaw : 2015-04-23 Shaw Cablesystems G.P.
+// shaw : Shaw Cablesystems G.P.
+// https://www.iana.org/domains/root/db/shaw.html
shaw
-// shell : 2015-07-30 Shell Information Technology International Inc
+// shell : Shell Information Technology International Inc
+// https://www.iana.org/domains/root/db/shell.html
shell
-// shia : 2014-09-04 Asia Green IT System Bilgisayar San. ve Tic. Ltd. Sti.
+// shia : Asia Green IT System Bilgisayar San. ve Tic. Ltd. Sti.
+// https://www.iana.org/domains/root/db/shia.html
shia
-// shiksha : 2013-11-14 Identity Digital Limited
+// shiksha : Identity Digital Limited
+// https://www.iana.org/domains/root/db/shiksha.html
shiksha
-// shoes : 2013-10-02 Binky Moon, LLC
+// shoes : Binky Moon, LLC
+// https://www.iana.org/domains/root/db/shoes.html
shoes
-// shop : 2016-04-08 GMO Registry, Inc.
+// shop : GMO Registry, Inc.
+// https://www.iana.org/domains/root/db/shop.html
shop
-// shopping : 2016-03-31 Binky Moon, LLC
+// shopping : Binky Moon, LLC
+// https://www.iana.org/domains/root/db/shopping.html
shopping
-// shouji : 2015-01-08 Beijing Qihu Keji Co., Ltd.
+// shouji : Beijing Qihu Keji Co., Ltd.
+// https://www.iana.org/domains/root/db/shouji.html
shouji
-// show : 2015-03-05 Binky Moon, LLC
+// show : Binky Moon, LLC
+// https://www.iana.org/domains/root/db/show.html
show
-// showtime : 2015-08-06 CBS Domains Inc.
-showtime
-
-// silk : 2015-06-25 Amazon Registry Services, Inc.
+// silk : Amazon Registry Services, Inc.
+// https://www.iana.org/domains/root/db/silk.html
silk
-// sina : 2015-03-12 Sina Corporation
+// sina : Sina Corporation
+// https://www.iana.org/domains/root/db/sina.html
sina
-// singles : 2013-08-27 Binky Moon, LLC
+// singles : Binky Moon, LLC
+// https://www.iana.org/domains/root/db/singles.html
singles
-// site : 2015-01-15 Radix FZC
+// site : Radix FZC DMCC
+// https://www.iana.org/domains/root/db/site.html
site
-// ski : 2015-04-09 Identity Digital Limited
+// ski : Identity Digital Limited
+// https://www.iana.org/domains/root/db/ski.html
ski
-// skin : 2015-01-15 XYZ.COM LLC
+// skin : XYZ.COM LLC
+// https://www.iana.org/domains/root/db/skin.html
skin
-// sky : 2014-06-19 Sky International AG
+// sky : Sky International AG
+// https://www.iana.org/domains/root/db/sky.html
sky
-// skype : 2014-12-18 Microsoft Corporation
+// skype : Microsoft Corporation
+// https://www.iana.org/domains/root/db/skype.html
skype
-// sling : 2015-07-30 DISH Technologies L.L.C.
+// sling : DISH Technologies L.L.C.
+// https://www.iana.org/domains/root/db/sling.html
sling
-// smart : 2015-07-09 Smart Communications, Inc. (SMART)
+// smart : Smart Communications, Inc. (SMART)
+// https://www.iana.org/domains/root/db/smart.html
smart
-// smile : 2014-12-18 Amazon Registry Services, Inc.
+// smile : Amazon Registry Services, Inc.
+// https://www.iana.org/domains/root/db/smile.html
smile
-// sncf : 2015-02-19 Société Nationale des Chemins de fer Francais S N C F
+// sncf : Société Nationale SNCF
+// https://www.iana.org/domains/root/db/sncf.html
sncf
-// soccer : 2015-03-26 Binky Moon, LLC
+// soccer : Binky Moon, LLC
+// https://www.iana.org/domains/root/db/soccer.html
soccer
-// social : 2013-11-07 Dog Beach, LLC
+// social : Dog Beach, LLC
+// https://www.iana.org/domains/root/db/social.html
social
-// softbank : 2015-07-02 SoftBank Group Corp.
+// softbank : SoftBank Group Corp.
+// https://www.iana.org/domains/root/db/softbank.html
softbank
-// software : 2014-03-20 Dog Beach, LLC
+// software : Dog Beach, LLC
+// https://www.iana.org/domains/root/db/software.html
software
-// sohu : 2013-12-19 Sohu.com Limited
+// sohu : Sohu.com Limited
+// https://www.iana.org/domains/root/db/sohu.html
sohu
-// solar : 2013-11-07 Binky Moon, LLC
+// solar : Binky Moon, LLC
+// https://www.iana.org/domains/root/db/solar.html
solar
-// solutions : 2013-11-07 Binky Moon, LLC
+// solutions : Binky Moon, LLC
+// https://www.iana.org/domains/root/db/solutions.html
solutions
-// song : 2015-02-26 Amazon Registry Services, Inc.
+// song : Amazon Registry Services, Inc.
+// https://www.iana.org/domains/root/db/song.html
song
-// sony : 2015-01-08 Sony Corporation
+// sony : Sony Corporation
+// https://www.iana.org/domains/root/db/sony.html
sony
-// soy : 2014-01-23 Charleston Road Registry Inc.
+// soy : Charleston Road Registry Inc.
+// https://www.iana.org/domains/root/db/soy.html
soy
-// spa : 2019-09-19 Asia Spa and Wellness Promotion Council Limited
+// spa : Asia Spa and Wellness Promotion Council Limited
+// https://www.iana.org/domains/root/db/spa.html
spa
-// space : 2014-04-03 Radix FZC
+// space : Radix FZC DMCC
+// https://www.iana.org/domains/root/db/space.html
space
-// sport : 2017-11-16 Global Association of International Sports Federations (GAISF)
+// sport : SportAccord
+// https://www.iana.org/domains/root/db/sport.html
sport
-// spot : 2015-02-26 Amazon Registry Services, Inc.
+// spot : Amazon Registry Services, Inc.
+// https://www.iana.org/domains/root/db/spot.html
spot
-// srl : 2015-05-07 InterNetX, Corp
+// srl : InterNetX, Corp
+// https://www.iana.org/domains/root/db/srl.html
srl
-// stada : 2014-11-13 STADA Arzneimittel AG
+// stada : STADA Arzneimittel AG
+// https://www.iana.org/domains/root/db/stada.html
stada
-// staples : 2015-07-30 Staples, Inc.
+// staples : Staples, Inc.
+// https://www.iana.org/domains/root/db/staples.html
staples
-// star : 2015-01-08 Star India Private Limited
+// star : Star India Private Limited
+// https://www.iana.org/domains/root/db/star.html
star
-// statebank : 2015-03-12 STATE BANK OF INDIA
+// statebank : STATE BANK OF INDIA
+// https://www.iana.org/domains/root/db/statebank.html
statebank
-// statefarm : 2015-07-30 State Farm Mutual Automobile Insurance Company
+// statefarm : State Farm Mutual Automobile Insurance Company
+// https://www.iana.org/domains/root/db/statefarm.html
statefarm
-// stc : 2014-10-09 Saudi Telecom Company
+// stc : Saudi Telecom Company
+// https://www.iana.org/domains/root/db/stc.html
stc
-// stcgroup : 2014-10-09 Saudi Telecom Company
+// stcgroup : Saudi Telecom Company
+// https://www.iana.org/domains/root/db/stcgroup.html
stcgroup
-// stockholm : 2014-12-18 Stockholms kommun
+// stockholm : Stockholms kommun
+// https://www.iana.org/domains/root/db/stockholm.html
stockholm
-// storage : 2014-12-22 XYZ.COM LLC
+// storage : XYZ.COM LLC
+// https://www.iana.org/domains/root/db/storage.html
storage
-// store : 2015-04-09 Radix FZC
+// store : Radix FZC DMCC
+// https://www.iana.org/domains/root/db/store.html
store
-// stream : 2016-01-08 dot Stream Limited
+// stream : dot Stream Limited
+// https://www.iana.org/domains/root/db/stream.html
stream
-// studio : 2015-02-11 Dog Beach, LLC
+// studio : Dog Beach, LLC
+// https://www.iana.org/domains/root/db/studio.html
studio
-// study : 2014-12-11 Registry Services, LLC
+// study : Registry Services, LLC
+// https://www.iana.org/domains/root/db/study.html
study
-// style : 2014-12-04 Binky Moon, LLC
+// style : Binky Moon, LLC
+// https://www.iana.org/domains/root/db/style.html
style
-// sucks : 2014-12-22 Vox Populi Registry Ltd.
+// sucks : Vox Populi Registry Ltd.
+// https://www.iana.org/domains/root/db/sucks.html
sucks
-// supplies : 2013-12-19 Binky Moon, LLC
+// supplies : Binky Moon, LLC
+// https://www.iana.org/domains/root/db/supplies.html
supplies
-// supply : 2013-12-19 Binky Moon, LLC
+// supply : Binky Moon, LLC
+// https://www.iana.org/domains/root/db/supply.html
supply
-// support : 2013-10-24 Binky Moon, LLC
+// support : Binky Moon, LLC
+// https://www.iana.org/domains/root/db/support.html
support
-// surf : 2014-01-09 Registry Services, LLC
+// surf : Registry Services, LLC
+// https://www.iana.org/domains/root/db/surf.html
surf
-// surgery : 2014-03-20 Binky Moon, LLC
+// surgery : Binky Moon, LLC
+// https://www.iana.org/domains/root/db/surgery.html
surgery
-// suzuki : 2014-02-20 SUZUKI MOTOR CORPORATION
+// suzuki : SUZUKI MOTOR CORPORATION
+// https://www.iana.org/domains/root/db/suzuki.html
suzuki
-// swatch : 2015-01-08 The Swatch Group Ltd
+// swatch : The Swatch Group Ltd
+// https://www.iana.org/domains/root/db/swatch.html
swatch
-// swiss : 2014-10-16 Swiss Confederation
+// swiss : Swiss Confederation
+// https://www.iana.org/domains/root/db/swiss.html
swiss
-// sydney : 2014-09-18 State of New South Wales, Department of Premier and Cabinet
+// sydney : State of New South Wales, Department of Premier and Cabinet
+// https://www.iana.org/domains/root/db/sydney.html
sydney
-// systems : 2013-11-07 Binky Moon, LLC
+// systems : Binky Moon, LLC
+// https://www.iana.org/domains/root/db/systems.html
systems
-// tab : 2014-12-04 Tabcorp Holdings Limited
+// tab : Tabcorp Holdings Limited
+// https://www.iana.org/domains/root/db/tab.html
tab
-// taipei : 2014-07-10 Taipei City Government
+// taipei : Taipei City Government
+// https://www.iana.org/domains/root/db/taipei.html
taipei
-// talk : 2015-04-09 Amazon Registry Services, Inc.
+// talk : Amazon Registry Services, Inc.
+// https://www.iana.org/domains/root/db/talk.html
talk
-// taobao : 2015-01-15 Alibaba Group Holding Limited
+// taobao : Alibaba Group Holding Limited
+// https://www.iana.org/domains/root/db/taobao.html
taobao
-// target : 2015-07-31 Target Domain Holdings, LLC
+// target : Target Domain Holdings, LLC
+// https://www.iana.org/domains/root/db/target.html
target
-// tatamotors : 2015-03-12 Tata Motors Ltd
+// tatamotors : Tata Motors Ltd
+// https://www.iana.org/domains/root/db/tatamotors.html
tatamotors
-// tatar : 2014-04-24 Limited Liability Company "Coordination Center of Regional Domain of Tatarstan Republic"
+// tatar : Limited Liability Company "Coordination Center of Regional Domain of Tatarstan Republic"
+// https://www.iana.org/domains/root/db/tatar.html
tatar
-// tattoo : 2013-08-30 Top Level Design, LLC
+// tattoo : Registry Services, LLC
+// https://www.iana.org/domains/root/db/tattoo.html
tattoo
-// tax : 2014-03-20 Binky Moon, LLC
+// tax : Binky Moon, LLC
+// https://www.iana.org/domains/root/db/tax.html
tax
-// taxi : 2015-03-19 Binky Moon, LLC
+// taxi : Binky Moon, LLC
+// https://www.iana.org/domains/root/db/taxi.html
taxi
-// tci : 2014-09-12 Asia Green IT System Bilgisayar San. ve Tic. Ltd. Sti.
+// tci : Asia Green IT System Bilgisayar San. ve Tic. Ltd. Sti.
+// https://www.iana.org/domains/root/db/tci.html
tci
-// tdk : 2015-06-11 TDK Corporation
+// tdk : TDK Corporation
+// https://www.iana.org/domains/root/db/tdk.html
tdk
-// team : 2015-03-05 Binky Moon, LLC
+// team : Binky Moon, LLC
+// https://www.iana.org/domains/root/db/team.html
team
-// tech : 2015-01-30 Radix FZC
+// tech : Radix FZC DMCC
+// https://www.iana.org/domains/root/db/tech.html
tech
-// technology : 2013-09-13 Binky Moon, LLC
+// technology : Binky Moon, LLC
+// https://www.iana.org/domains/root/db/technology.html
technology
-// temasek : 2014-08-07 Temasek Holdings (Private) Limited
+// temasek : Temasek Holdings (Private) Limited
+// https://www.iana.org/domains/root/db/temasek.html
temasek
-// tennis : 2014-12-04 Binky Moon, LLC
+// tennis : Binky Moon, LLC
+// https://www.iana.org/domains/root/db/tennis.html
tennis
-// teva : 2015-07-02 Teva Pharmaceutical Industries Limited
+// teva : Teva Pharmaceutical Industries Limited
+// https://www.iana.org/domains/root/db/teva.html
teva
-// thd : 2015-04-02 Home Depot Product Authority, LLC
+// thd : Home Depot Product Authority, LLC
+// https://www.iana.org/domains/root/db/thd.html
thd
-// theater : 2015-03-19 Binky Moon, LLC
+// theater : Binky Moon, LLC
+// https://www.iana.org/domains/root/db/theater.html
theater
-// theatre : 2015-05-07 XYZ.COM LLC
+// theatre : XYZ.COM LLC
+// https://www.iana.org/domains/root/db/theatre.html
theatre
-// tiaa : 2015-07-23 Teachers Insurance and Annuity Association of America
+// tiaa : Teachers Insurance and Annuity Association of America
+// https://www.iana.org/domains/root/db/tiaa.html
tiaa
-// tickets : 2015-02-05 XYZ.COM LLC
+// tickets : XYZ.COM LLC
+// https://www.iana.org/domains/root/db/tickets.html
tickets
-// tienda : 2013-11-14 Binky Moon, LLC
+// tienda : Binky Moon, LLC
+// https://www.iana.org/domains/root/db/tienda.html
tienda
-// tiffany : 2015-01-30 Tiffany and Company
-tiffany
-
-// tips : 2013-09-20 Binky Moon, LLC
+// tips : Binky Moon, LLC
+// https://www.iana.org/domains/root/db/tips.html
tips
-// tires : 2014-11-07 Binky Moon, LLC
+// tires : Binky Moon, LLC
+// https://www.iana.org/domains/root/db/tires.html
tires
-// tirol : 2014-04-24 punkt Tirol GmbH
+// tirol : punkt Tirol GmbH
+// https://www.iana.org/domains/root/db/tirol.html
tirol
-// tjmaxx : 2015-07-16 The TJX Companies, Inc.
+// tjmaxx : The TJX Companies, Inc.
+// https://www.iana.org/domains/root/db/tjmaxx.html
tjmaxx
-// tjx : 2015-07-16 The TJX Companies, Inc.
+// tjx : The TJX Companies, Inc.
+// https://www.iana.org/domains/root/db/tjx.html
tjx
-// tkmaxx : 2015-07-16 The TJX Companies, Inc.
+// tkmaxx : The TJX Companies, Inc.
+// https://www.iana.org/domains/root/db/tkmaxx.html
tkmaxx
-// tmall : 2015-01-15 Alibaba Group Holding Limited
+// tmall : Alibaba Group Holding Limited
+// https://www.iana.org/domains/root/db/tmall.html
tmall
-// today : 2013-09-20 Binky Moon, LLC
+// today : Binky Moon, LLC
+// https://www.iana.org/domains/root/db/today.html
today
-// tokyo : 2013-11-13 GMO Registry, Inc.
+// tokyo : GMO Registry, Inc.
+// https://www.iana.org/domains/root/db/tokyo.html
tokyo
-// tools : 2013-11-21 Binky Moon, LLC
+// tools : Binky Moon, LLC
+// https://www.iana.org/domains/root/db/tools.html
tools
-// top : 2014-03-20 .TOP Registry
+// top : .TOP Registry
+// https://www.iana.org/domains/root/db/top.html
top
-// toray : 2014-12-18 Toray Industries, Inc.
+// toray : Toray Industries, Inc.
+// https://www.iana.org/domains/root/db/toray.html
toray
-// toshiba : 2014-04-10 TOSHIBA Corporation
+// toshiba : TOSHIBA Corporation
+// https://www.iana.org/domains/root/db/toshiba.html
toshiba
-// total : 2015-08-06 TOTAL SE
+// total : TotalEnergies SE
+// https://www.iana.org/domains/root/db/total.html
total
-// tours : 2015-01-22 Binky Moon, LLC
+// tours : Binky Moon, LLC
+// https://www.iana.org/domains/root/db/tours.html
tours
-// town : 2014-03-06 Binky Moon, LLC
+// town : Binky Moon, LLC
+// https://www.iana.org/domains/root/db/town.html
town
-// toyota : 2015-04-23 TOYOTA MOTOR CORPORATION
+// toyota : TOYOTA MOTOR CORPORATION
+// https://www.iana.org/domains/root/db/toyota.html
toyota
-// toys : 2014-03-06 Binky Moon, LLC
+// toys : Binky Moon, LLC
+// https://www.iana.org/domains/root/db/toys.html
toys
-// trade : 2014-01-23 Elite Registry Limited
+// trade : Elite Registry Limited
+// https://www.iana.org/domains/root/db/trade.html
trade
-// trading : 2014-12-11 Dog Beach, LLC
+// trading : Dog Beach, LLC
+// https://www.iana.org/domains/root/db/trading.html
trading
-// training : 2013-11-07 Binky Moon, LLC
+// training : Binky Moon, LLC
+// https://www.iana.org/domains/root/db/training.html
training
-// travel : 2015-10-09 Dog Beach, LLC
+// travel : Dog Beach, LLC
+// https://www.iana.org/domains/root/db/travel.html
travel
-// travelchannel : 2015-07-02 Lifestyle Domain Holdings, Inc.
-travelchannel
-
-// travelers : 2015-03-26 Travelers TLD, LLC
+// travelers : Travelers TLD, LLC
+// https://www.iana.org/domains/root/db/travelers.html
travelers
-// travelersinsurance : 2015-03-26 Travelers TLD, LLC
+// travelersinsurance : Travelers TLD, LLC
+// https://www.iana.org/domains/root/db/travelersinsurance.html
travelersinsurance
-// trust : 2014-10-16 Internet Naming Company LLC
+// trust : Internet Naming Company LLC
+// https://www.iana.org/domains/root/db/trust.html
trust
-// trv : 2015-03-26 Travelers TLD, LLC
+// trv : Travelers TLD, LLC
+// https://www.iana.org/domains/root/db/trv.html
trv
-// tube : 2015-06-11 Latin American Telecom LLC
+// tube : Latin American Telecom LLC
+// https://www.iana.org/domains/root/db/tube.html
tube
-// tui : 2014-07-03 TUI AG
+// tui : TUI AG
+// https://www.iana.org/domains/root/db/tui.html
tui
-// tunes : 2015-02-26 Amazon Registry Services, Inc.
+// tunes : Amazon Registry Services, Inc.
+// https://www.iana.org/domains/root/db/tunes.html
tunes
-// tushu : 2014-12-18 Amazon Registry Services, Inc.
+// tushu : Amazon Registry Services, Inc.
+// https://www.iana.org/domains/root/db/tushu.html
tushu
-// tvs : 2015-02-19 T V SUNDRAM IYENGAR & SONS LIMITED
+// tvs : T V SUNDRAM IYENGAR & SONS LIMITED
+// https://www.iana.org/domains/root/db/tvs.html
tvs
-// ubank : 2015-08-20 National Australia Bank Limited
+// ubank : National Australia Bank Limited
+// https://www.iana.org/domains/root/db/ubank.html
ubank
-// ubs : 2014-12-11 UBS AG
+// ubs : UBS AG
+// https://www.iana.org/domains/root/db/ubs.html
ubs
-// unicom : 2015-10-15 China United Network Communications Corporation Limited
+// unicom : China United Network Communications Corporation Limited
+// https://www.iana.org/domains/root/db/unicom.html
unicom
-// university : 2014-03-06 Binky Moon, LLC
+// university : Binky Moon, LLC
+// https://www.iana.org/domains/root/db/university.html
university
-// uno : 2013-09-11 Radix FZC
+// uno : Radix FZC DMCC
+// https://www.iana.org/domains/root/db/uno.html
uno
-// uol : 2014-05-01 UBN INTERNET LTDA.
+// uol : UBN INTERNET LTDA.
+// https://www.iana.org/domains/root/db/uol.html
uol
-// ups : 2015-06-25 UPS Market Driver, Inc.
+// ups : UPS Market Driver, Inc.
+// https://www.iana.org/domains/root/db/ups.html
ups
-// vacations : 2013-12-05 Binky Moon, LLC
+// vacations : Binky Moon, LLC
+// https://www.iana.org/domains/root/db/vacations.html
vacations
-// vana : 2014-12-11 Lifestyle Domain Holdings, Inc.
+// vana : Internet Naming Company LLC
+// https://www.iana.org/domains/root/db/vana.html
vana
-// vanguard : 2015-09-03 The Vanguard Group, Inc.
+// vanguard : The Vanguard Group, Inc.
+// https://www.iana.org/domains/root/db/vanguard.html
vanguard
-// vegas : 2014-01-16 Dot Vegas, Inc.
+// vegas : Dot Vegas, Inc.
+// https://www.iana.org/domains/root/db/vegas.html
vegas
-// ventures : 2013-08-27 Binky Moon, LLC
+// ventures : Binky Moon, LLC
+// https://www.iana.org/domains/root/db/ventures.html
ventures
-// verisign : 2015-08-13 VeriSign, Inc.
+// verisign : VeriSign, Inc.
+// https://www.iana.org/domains/root/db/verisign.html
verisign
-// versicherung : 2014-03-20 tldbox GmbH
+// versicherung : tldbox GmbH
+// https://www.iana.org/domains/root/db/versicherung.html
versicherung
-// vet : 2014-03-06 Dog Beach, LLC
+// vet : Dog Beach, LLC
+// https://www.iana.org/domains/root/db/vet.html
vet
-// viajes : 2013-10-17 Binky Moon, LLC
+// viajes : Binky Moon, LLC
+// https://www.iana.org/domains/root/db/viajes.html
viajes
-// video : 2014-10-16 Dog Beach, LLC
+// video : Dog Beach, LLC
+// https://www.iana.org/domains/root/db/video.html
video
-// vig : 2015-05-14 VIENNA INSURANCE GROUP AG Wiener Versicherung Gruppe
+// vig : VIENNA INSURANCE GROUP AG Wiener Versicherung Gruppe
+// https://www.iana.org/domains/root/db/vig.html
vig
-// viking : 2015-04-02 Viking River Cruises (Bermuda) Ltd.
+// viking : Viking River Cruises (Bermuda) Ltd.
+// https://www.iana.org/domains/root/db/viking.html
viking
-// villas : 2013-12-05 Binky Moon, LLC
+// villas : Binky Moon, LLC
+// https://www.iana.org/domains/root/db/villas.html
villas
-// vin : 2015-06-18 Binky Moon, LLC
+// vin : Binky Moon, LLC
+// https://www.iana.org/domains/root/db/vin.html
vin
-// vip : 2015-01-22 Registry Services, LLC
+// vip : Registry Services, LLC
+// https://www.iana.org/domains/root/db/vip.html
vip
-// virgin : 2014-09-25 Virgin Enterprises Limited
+// virgin : Virgin Enterprises Limited
+// https://www.iana.org/domains/root/db/virgin.html
virgin
-// visa : 2015-07-30 Visa Worldwide Pte. Limited
+// visa : Visa Worldwide Pte. Limited
+// https://www.iana.org/domains/root/db/visa.html
visa
-// vision : 2013-12-05 Binky Moon, LLC
+// vision : Binky Moon, LLC
+// https://www.iana.org/domains/root/db/vision.html
vision
-// viva : 2014-11-07 Saudi Telecom Company
+// viva : Saudi Telecom Company
+// https://www.iana.org/domains/root/db/viva.html
viva
-// vivo : 2015-07-31 Telefonica Brasil S.A.
+// vivo : Telefonica Brasil S.A.
+// https://www.iana.org/domains/root/db/vivo.html
vivo
-// vlaanderen : 2014-02-06 DNS.be vzw
+// vlaanderen : DNS.be vzw
+// https://www.iana.org/domains/root/db/vlaanderen.html
vlaanderen
-// vodka : 2013-12-19 Registry Services, LLC
+// vodka : Registry Services, LLC
+// https://www.iana.org/domains/root/db/vodka.html
vodka
-// volkswagen : 2015-05-14 Volkswagen Group of America Inc.
-volkswagen
-
-// volvo : 2015-11-12 Volvo Holding Sverige Aktiebolag
+// volvo : Volvo Holding Sverige Aktiebolag
+// https://www.iana.org/domains/root/db/volvo.html
volvo
-// vote : 2013-11-21 Monolith Registry LLC
+// vote : Monolith Registry LLC
+// https://www.iana.org/domains/root/db/vote.html
vote
-// voting : 2013-11-13 Valuetainment Corp.
+// voting : Valuetainment Corp.
+// https://www.iana.org/domains/root/db/voting.html
voting
-// voto : 2013-11-21 Monolith Registry LLC
+// voto : Monolith Registry LLC
+// https://www.iana.org/domains/root/db/voto.html
voto
-// voyage : 2013-08-27 Binky Moon, LLC
+// voyage : Binky Moon, LLC
+// https://www.iana.org/domains/root/db/voyage.html
voyage
-// vuelos : 2015-03-05 Travel Reservations SRL
-vuelos
-
-// wales : 2014-05-08 Nominet UK
+// wales : Nominet UK
+// https://www.iana.org/domains/root/db/wales.html
wales
-// walmart : 2015-07-31 Wal-Mart Stores, Inc.
+// walmart : Wal-Mart Stores, Inc.
+// https://www.iana.org/domains/root/db/walmart.html
walmart
-// walter : 2014-11-13 Sandvik AB
+// walter : Sandvik AB
+// https://www.iana.org/domains/root/db/walter.html
walter
-// wang : 2013-10-24 Zodiac Wang Limited
+// wang : Zodiac Wang Limited
+// https://www.iana.org/domains/root/db/wang.html
wang
-// wanggou : 2014-12-18 Amazon Registry Services, Inc.
+// wanggou : Amazon Registry Services, Inc.
+// https://www.iana.org/domains/root/db/wanggou.html
wanggou
-// watch : 2013-11-14 Binky Moon, LLC
+// watch : Binky Moon, LLC
+// https://www.iana.org/domains/root/db/watch.html
watch
-// watches : 2014-12-22 Identity Digital Limited
+// watches : Identity Digital Limited
+// https://www.iana.org/domains/root/db/watches.html
watches
-// weather : 2015-01-08 International Business Machines Corporation
+// weather : International Business Machines Corporation
+// https://www.iana.org/domains/root/db/weather.html
weather
-// weatherchannel : 2015-03-12 International Business Machines Corporation
+// weatherchannel : International Business Machines Corporation
+// https://www.iana.org/domains/root/db/weatherchannel.html
weatherchannel
-// webcam : 2014-01-23 dot Webcam Limited
+// webcam : dot Webcam Limited
+// https://www.iana.org/domains/root/db/webcam.html
webcam
-// weber : 2015-06-04 Saint-Gobain Weber SA
+// weber : Saint-Gobain Weber SA
+// https://www.iana.org/domains/root/db/weber.html
weber
-// website : 2014-04-03 Radix FZC
+// website : Radix FZC DMCC
+// https://www.iana.org/domains/root/db/website.html
website
-// wedding : 2014-04-24 Registry Services, LLC
+// wed
+// https://www.iana.org/domains/root/db/wed.html
+wed
+
+// wedding : Registry Services, LLC
+// https://www.iana.org/domains/root/db/wedding.html
wedding
-// weibo : 2015-03-05 Sina Corporation
+// weibo : Sina Corporation
+// https://www.iana.org/domains/root/db/weibo.html
weibo
-// weir : 2015-01-29 Weir Group IP Limited
+// weir : Weir Group IP Limited
+// https://www.iana.org/domains/root/db/weir.html
weir
-// whoswho : 2014-02-20 Who's Who Registry
+// whoswho : Who's Who Registry
+// https://www.iana.org/domains/root/db/whoswho.html
whoswho
-// wien : 2013-10-28 punkt.wien GmbH
+// wien : punkt.wien GmbH
+// https://www.iana.org/domains/root/db/wien.html
wien
-// wiki : 2013-11-07 Top Level Design, LLC
+// wiki : Registry Services, LLC
+// https://www.iana.org/domains/root/db/wiki.html
wiki
-// williamhill : 2014-03-13 William Hill Organization Limited
+// williamhill : William Hill Organization Limited
+// https://www.iana.org/domains/root/db/williamhill.html
williamhill
-// win : 2014-11-20 First Registry Limited
+// win : First Registry Limited
+// https://www.iana.org/domains/root/db/win.html
win
-// windows : 2014-12-18 Microsoft Corporation
+// windows : Microsoft Corporation
+// https://www.iana.org/domains/root/db/windows.html
windows
-// wine : 2015-06-18 Binky Moon, LLC
+// wine : Binky Moon, LLC
+// https://www.iana.org/domains/root/db/wine.html
wine
-// winners : 2015-07-16 The TJX Companies, Inc.
+// winners : The TJX Companies, Inc.
+// https://www.iana.org/domains/root/db/winners.html
winners
-// wme : 2014-02-13 William Morris Endeavor Entertainment, LLC
+// wme : William Morris Endeavor Entertainment, LLC
+// https://www.iana.org/domains/root/db/wme.html
wme
-// wolterskluwer : 2015-08-06 Wolters Kluwer N.V.
+// wolterskluwer : Wolters Kluwer N.V.
+// https://www.iana.org/domains/root/db/wolterskluwer.html
wolterskluwer
-// woodside : 2015-07-09 Woodside Petroleum Limited
+// woodside : Woodside Petroleum Limited
+// https://www.iana.org/domains/root/db/woodside.html
woodside
-// work : 2013-12-19 Registry Services, LLC
+// work : Registry Services, LLC
+// https://www.iana.org/domains/root/db/work.html
work
-// works : 2013-11-14 Binky Moon, LLC
+// works : Binky Moon, LLC
+// https://www.iana.org/domains/root/db/works.html
works
-// world : 2014-06-12 Binky Moon, LLC
+// world : Binky Moon, LLC
+// https://www.iana.org/domains/root/db/world.html
world
-// wow : 2015-10-08 Amazon Registry Services, Inc.
+// wow : Amazon Registry Services, Inc.
+// https://www.iana.org/domains/root/db/wow.html
wow
-// wtc : 2013-12-19 World Trade Centers Association, Inc.
+// wtc : World Trade Centers Association, Inc.
+// https://www.iana.org/domains/root/db/wtc.html
wtc
-// wtf : 2014-03-06 Binky Moon, LLC
+// wtf : Binky Moon, LLC
+// https://www.iana.org/domains/root/db/wtf.html
wtf
-// xbox : 2014-12-18 Microsoft Corporation
+// xbox : Microsoft Corporation
+// https://www.iana.org/domains/root/db/xbox.html
xbox
-// xerox : 2014-10-24 Xerox DNHC LLC
+// xerox : Xerox DNHC LLC
+// https://www.iana.org/domains/root/db/xerox.html
xerox
-// xfinity : 2015-07-09 Comcast IP Holdings I, LLC
+// xfinity : Comcast IP Holdings I, LLC
+// https://www.iana.org/domains/root/db/xfinity.html
xfinity
-// xihuan : 2015-01-08 Beijing Qihu Keji Co., Ltd.
+// xihuan : Beijing Qihu Keji Co., Ltd.
+// https://www.iana.org/domains/root/db/xihuan.html
xihuan
-// xin : 2014-12-11 Elegant Leader Limited
+// xin : Elegant Leader Limited
+// https://www.iana.org/domains/root/db/xin.html
xin
-// xn--11b4c3d : 2015-01-15 VeriSign Sarl
+// xn--11b4c3d : VeriSign Sarl
+// https://www.iana.org/domains/root/db/xn--11b4c3d.html
कॉम
-// xn--1ck2e1b : 2015-02-26 Amazon Registry Services, Inc.
+// xn--1ck2e1b : Amazon Registry Services, Inc.
+// https://www.iana.org/domains/root/db/xn--1ck2e1b.html
セール
-// xn--1qqw23a : 2014-01-09 Guangzhou YU Wei Information Technology Co., Ltd.
+// xn--1qqw23a : Guangzhou YU Wei Information Technology Co., Ltd.
+// https://www.iana.org/domains/root/db/xn--1qqw23a.html
佛山
-// xn--30rr7y : 2014-06-12 Excellent First Limited
+// xn--30rr7y : Excellent First Limited
+// https://www.iana.org/domains/root/db/xn--30rr7y.html
慈善
-// xn--3bst00m : 2013-09-13 Eagle Horizon Limited
+// xn--3bst00m : Eagle Horizon Limited
+// https://www.iana.org/domains/root/db/xn--3bst00m.html
集团
-// xn--3ds443g : 2013-09-08 TLD REGISTRY LIMITED OY
+// xn--3ds443g : TLD REGISTRY LIMITED OY
+// https://www.iana.org/domains/root/db/xn--3ds443g.html
在线
-// xn--3pxu8k : 2015-01-15 VeriSign Sarl
+// xn--3pxu8k : VeriSign Sarl
+// https://www.iana.org/domains/root/db/xn--3pxu8k.html
点看
-// xn--42c2d9a : 2015-01-15 VeriSign Sarl
+// xn--42c2d9a : VeriSign Sarl
+// https://www.iana.org/domains/root/db/xn--42c2d9a.html
คอม
-// xn--45q11c : 2013-11-21 Zodiac Gemini Ltd
+// xn--45q11c : Zodiac Gemini Ltd
+// https://www.iana.org/domains/root/db/xn--45q11c.html
八卦
-// xn--4gbrim : 2013-10-04 Helium TLDs Ltd
+// xn--4gbrim : Helium TLDs Ltd
+// https://www.iana.org/domains/root/db/xn--4gbrim.html
موقع
-// xn--55qw42g : 2013-11-08 China Organizational Name Administration Center
+// xn--55qw42g : China Organizational Name Administration Center
+// https://www.iana.org/domains/root/db/xn--55qw42g.html
公益
-// xn--55qx5d : 2013-11-14 China Internet Network Information Center (CNNIC)
+// xn--55qx5d : China Internet Network Information Center (CNNIC)
+// https://www.iana.org/domains/root/db/xn--55qx5d.html
公司
-// xn--5su34j936bgsg : 2015-09-03 Shangri‐La International Hotel Management Limited
+// xn--5su34j936bgsg : Shangri‐La International Hotel Management Limited
+// https://www.iana.org/domains/root/db/xn--5su34j936bgsg.html
香格里拉
-// xn--5tzm5g : 2014-12-22 Global Website TLD Asia Limited
+// xn--5tzm5g : Global Website TLD Asia Limited
+// https://www.iana.org/domains/root/db/xn--5tzm5g.html
网站
-// xn--6frz82g : 2013-09-23 Identity Digital Limited
+// xn--6frz82g : Identity Digital Limited
+// https://www.iana.org/domains/root/db/xn--6frz82g.html
移动
-// xn--6qq986b3xl : 2013-09-13 Tycoon Treasure Limited
+// xn--6qq986b3xl : Tycoon Treasure Limited
+// https://www.iana.org/domains/root/db/xn--6qq986b3xl.html
我爱你
-// xn--80adxhks : 2013-12-19 Foundation for Assistance for Internet Technologies and Infrastructure Development (FAITID)
+// xn--80adxhks : Foundation for Assistance for Internet Technologies and Infrastructure Development (FAITID)
+// https://www.iana.org/domains/root/db/xn--80adxhks.html
москва
-// xn--80aqecdr1a : 2015-10-21 Pontificium Consilium de Comunicationibus Socialibus (PCCS) (Pontifical Council for Social Communication)
+// xn--80aqecdr1a : Pontificium Consilium de Comunicationibus Socialibus (PCCS) (Pontifical Council for Social Communication)
+// https://www.iana.org/domains/root/db/xn--80aqecdr1a.html
католик
-// xn--80asehdb : 2013-07-14 CORE Association
+// xn--80asehdb : CORE Association
+// https://www.iana.org/domains/root/db/xn--80asehdb.html
онлайн
-// xn--80aswg : 2013-07-14 CORE Association
+// xn--80aswg : CORE Association
+// https://www.iana.org/domains/root/db/xn--80aswg.html
сайт
-// xn--8y0a063a : 2015-03-26 China United Network Communications Corporation Limited
+// xn--8y0a063a : China United Network Communications Corporation Limited
+// https://www.iana.org/domains/root/db/xn--8y0a063a.html
联通
-// xn--9dbq2a : 2015-01-15 VeriSign Sarl
+// xn--9dbq2a : VeriSign Sarl
+// https://www.iana.org/domains/root/db/xn--9dbq2a.html
קום
-// xn--9et52u : 2014-06-12 RISE VICTORY LIMITED
+// xn--9et52u : RISE VICTORY LIMITED
+// https://www.iana.org/domains/root/db/xn--9et52u.html
时尚
-// xn--9krt00a : 2015-03-12 Sina Corporation
+// xn--9krt00a : Sina Corporation
+// https://www.iana.org/domains/root/db/xn--9krt00a.html
微博
-// xn--b4w605ferd : 2014-08-07 Temasek Holdings (Private) Limited
+// xn--b4w605ferd : Temasek Holdings (Private) Limited
+// https://www.iana.org/domains/root/db/xn--b4w605ferd.html
淡马锡
-// xn--bck1b9a5dre4c : 2015-02-26 Amazon Registry Services, Inc.
+// xn--bck1b9a5dre4c : Amazon Registry Services, Inc.
+// https://www.iana.org/domains/root/db/xn--bck1b9a5dre4c.html
ファッション
-// xn--c1avg : 2013-11-14 Public Interest Registry
+// xn--c1avg : Public Interest Registry
+// https://www.iana.org/domains/root/db/xn--c1avg.html
орг
-// xn--c2br7g : 2015-01-15 VeriSign Sarl
+// xn--c2br7g : VeriSign Sarl
+// https://www.iana.org/domains/root/db/xn--c2br7g.html
नेट
-// xn--cck2b3b : 2015-02-26 Amazon Registry Services, Inc.
+// xn--cck2b3b : Amazon Registry Services, Inc.
+// https://www.iana.org/domains/root/db/xn--cck2b3b.html
ストア
-// xn--cckwcxetd : 2019-12-19 Amazon Registry Services, Inc.
+// xn--cckwcxetd : Amazon Registry Services, Inc.
+// https://www.iana.org/domains/root/db/xn--cckwcxetd.html
アマゾン
-// xn--cg4bki : 2013-09-27 SAMSUNG SDS CO., LTD
+// xn--cg4bki : SAMSUNG SDS CO., LTD
+// https://www.iana.org/domains/root/db/xn--cg4bki.html
삼성
-// xn--czr694b : 2014-01-16 Internet DotTrademark Organisation Limited
+// xn--czr694b : Internet DotTrademark Organisation Limited
+// https://www.iana.org/domains/root/db/xn--czr694b.html
商标
-// xn--czrs0t : 2013-12-19 Binky Moon, LLC
+// xn--czrs0t : Binky Moon, LLC
+// https://www.iana.org/domains/root/db/xn--czrs0t.html
商店
-// xn--czru2d : 2013-11-21 Zodiac Aquarius Limited
+// xn--czru2d : Zodiac Aquarius Limited
+// https://www.iana.org/domains/root/db/xn--czru2d.html
商城
-// xn--d1acj3b : 2013-11-20 The Foundation for Network Initiatives “The Smart Internet”
+// xn--d1acj3b : The Foundation for Network Initiatives “The Smart Internet”
+// https://www.iana.org/domains/root/db/xn--d1acj3b.html
дети
-// xn--eckvdtc9d : 2014-12-18 Amazon Registry Services, Inc.
+// xn--eckvdtc9d : Amazon Registry Services, Inc.
+// https://www.iana.org/domains/root/db/xn--eckvdtc9d.html
ポイント
-// xn--efvy88h : 2014-08-22 Guangzhou YU Wei Information Technology Co., Ltd.
+// xn--efvy88h : Guangzhou YU Wei Information Technology Co., Ltd.
+// https://www.iana.org/domains/root/db/xn--efvy88h.html
新闻
-// xn--fct429k : 2015-04-09 Amazon Registry Services, Inc.
+// xn--fct429k : Amazon Registry Services, Inc.
+// https://www.iana.org/domains/root/db/xn--fct429k.html
家電
-// xn--fhbei : 2015-01-15 VeriSign Sarl
+// xn--fhbei : VeriSign Sarl
+// https://www.iana.org/domains/root/db/xn--fhbei.html
كوم
-// xn--fiq228c5hs : 2013-09-08 TLD REGISTRY LIMITED OY
+// xn--fiq228c5hs : TLD REGISTRY LIMITED OY
+// https://www.iana.org/domains/root/db/xn--fiq228c5hs.html
中文网
-// xn--fiq64b : 2013-10-14 CITIC Group Corporation
+// xn--fiq64b : CITIC Group Corporation
+// https://www.iana.org/domains/root/db/xn--fiq64b.html
中信
-// xn--fjq720a : 2014-05-22 Binky Moon, LLC
+// xn--fjq720a : Binky Moon, LLC
+// https://www.iana.org/domains/root/db/xn--fjq720a.html
娱乐
-// xn--flw351e : 2014-07-31 Charleston Road Registry Inc.
+// xn--flw351e : Charleston Road Registry Inc.
+// https://www.iana.org/domains/root/db/xn--flw351e.html
谷歌
-// xn--fzys8d69uvgm : 2015-05-14 PCCW Enterprises Limited
+// xn--fzys8d69uvgm : PCCW Enterprises Limited
+// https://www.iana.org/domains/root/db/xn--fzys8d69uvgm.html
電訊盈科
-// xn--g2xx48c : 2015-01-30 Nawang Heli(Xiamen) Network Service Co., LTD.
+// xn--g2xx48c : Nawang Heli(Xiamen) Network Service Co., LTD.
+// https://www.iana.org/domains/root/db/xn--g2xx48c.html
购物
-// xn--gckr3f0f : 2015-02-26 Amazon Registry Services, Inc.
+// xn--gckr3f0f : Amazon Registry Services, Inc.
+// https://www.iana.org/domains/root/db/xn--gckr3f0f.html
クラウド
-// xn--gk3at1e : 2015-10-08 Amazon Registry Services, Inc.
+// xn--gk3at1e : Amazon Registry Services, Inc.
+// https://www.iana.org/domains/root/db/xn--gk3at1e.html
通販
-// xn--hxt814e : 2014-05-15 Zodiac Taurus Limited
+// xn--hxt814e : Zodiac Taurus Limited
+// https://www.iana.org/domains/root/db/xn--hxt814e.html
网店
-// xn--i1b6b1a6a2e : 2013-11-14 Public Interest Registry
+// xn--i1b6b1a6a2e : Public Interest Registry
+// https://www.iana.org/domains/root/db/xn--i1b6b1a6a2e.html
संगठन
-// xn--imr513n : 2014-12-11 Internet DotTrademark Organisation Limited
+// xn--imr513n : Internet DotTrademark Organisation Limited
+// https://www.iana.org/domains/root/db/xn--imr513n.html
餐厅
-// xn--io0a7i : 2013-11-14 China Internet Network Information Center (CNNIC)
+// xn--io0a7i : China Internet Network Information Center (CNNIC)
+// https://www.iana.org/domains/root/db/xn--io0a7i.html
网络
-// xn--j1aef : 2015-01-15 VeriSign Sarl
+// xn--j1aef : VeriSign Sarl
+// https://www.iana.org/domains/root/db/xn--j1aef.html
ком
-// xn--jlq480n2rg : 2019-12-19 Amazon Registry Services, Inc.
+// xn--jlq480n2rg : Amazon Registry Services, Inc.
+// https://www.iana.org/domains/root/db/xn--jlq480n2rg.html
亚马逊
-// xn--jlq61u9w7b : 2015-01-08 Nokia Corporation
-诺基亚
-
-// xn--jvr189m : 2015-02-26 Amazon Registry Services, Inc.
+// xn--jvr189m : Amazon Registry Services, Inc.
+// https://www.iana.org/domains/root/db/xn--jvr189m.html
食品
-// xn--kcrx77d1x4a : 2014-11-07 Koninklijke Philips N.V.
+// xn--kcrx77d1x4a : Koninklijke Philips N.V.
+// https://www.iana.org/domains/root/db/xn--kcrx77d1x4a.html
飞利浦
-// xn--kput3i : 2014-02-13 Beijing RITT-Net Technology Development Co., Ltd
+// xn--kput3i : Beijing RITT-Net Technology Development Co., Ltd
+// https://www.iana.org/domains/root/db/xn--kput3i.html
手机
-// xn--mgba3a3ejt : 2014-11-20 Aramco Services Company
+// xn--mgba3a3ejt : Aramco Services Company
+// https://www.iana.org/domains/root/db/xn--mgba3a3ejt.html
ارامكو
-// xn--mgba7c0bbn0a : 2015-05-14 Crescent Holding GmbH
+// xn--mgba7c0bbn0a : Competrol (Luxembourg) Sarl
+// https://www.iana.org/domains/root/db/xn--mgba7c0bbn0a.html
العليان
-// xn--mgbaakc7dvf : 2015-09-03 Emirates Telecommunications Corporation (trading as Etisalat)
-اتصالات
-
-// xn--mgbab2bd : 2013-10-31 CORE Association
+// xn--mgbab2bd : CORE Association
+// https://www.iana.org/domains/root/db/xn--mgbab2bd.html
بازار
-// xn--mgbca7dzdo : 2015-07-30 Abu Dhabi Systems and Information Centre
+// xn--mgbca7dzdo : Abu Dhabi Systems and Information Centre
+// https://www.iana.org/domains/root/db/xn--mgbca7dzdo.html
ابوظبي
-// xn--mgbi4ecexp : 2015-10-21 Pontificium Consilium de Comunicationibus Socialibus (PCCS) (Pontifical Council for Social Communication)
+// xn--mgbi4ecexp : Pontificium Consilium de Comunicationibus Socialibus (PCCS) (Pontifical Council for Social Communication)
+// https://www.iana.org/domains/root/db/xn--mgbi4ecexp.html
كاثوليك
-// xn--mgbt3dhd : 2014-09-04 Asia Green IT System Bilgisayar San. ve Tic. Ltd. Sti.
+// xn--mgbt3dhd : Asia Green IT System Bilgisayar San. ve Tic. Ltd. Sti.
+// https://www.iana.org/domains/root/db/xn--mgbt3dhd.html
همراه
-// xn--mk1bu44c : 2015-01-15 VeriSign Sarl
+// xn--mk1bu44c : VeriSign Sarl
+// https://www.iana.org/domains/root/db/xn--mk1bu44c.html
닷컴
-// xn--mxtq1m : 2014-03-06 Net-Chinese Co., Ltd.
+// xn--mxtq1m : Net-Chinese Co., Ltd.
+// https://www.iana.org/domains/root/db/xn--mxtq1m.html
政府
-// xn--ngbc5azd : 2013-07-13 International Domain Registry Pty. Ltd.
+// xn--ngbc5azd : International Domain Registry Pty. Ltd.
+// https://www.iana.org/domains/root/db/xn--ngbc5azd.html
شبكة
-// xn--ngbe9e0a : 2014-12-04 Kuwait Finance House
+// xn--ngbe9e0a : Kuwait Finance House
+// https://www.iana.org/domains/root/db/xn--ngbe9e0a.html
بيتك
-// xn--ngbrx : 2015-11-12 League of Arab States
+// xn--ngbrx : League of Arab States
+// https://www.iana.org/domains/root/db/xn--ngbrx.html
عرب
-// xn--nqv7f : 2013-11-14 Public Interest Registry
+// xn--nqv7f : Public Interest Registry
+// https://www.iana.org/domains/root/db/xn--nqv7f.html
机构
-// xn--nqv7fs00ema : 2013-11-14 Public Interest Registry
+// xn--nqv7fs00ema : Public Interest Registry
+// https://www.iana.org/domains/root/db/xn--nqv7fs00ema.html
组织机构
-// xn--nyqy26a : 2014-11-07 Stable Tone Limited
+// xn--nyqy26a : Stable Tone Limited
+// https://www.iana.org/domains/root/db/xn--nyqy26a.html
健康
-// xn--otu796d : 2017-08-06 Jiang Yu Liang Cai Technology Company Limited
+// xn--otu796d : Jiang Yu Liang Cai Technology Company Limited
+// https://www.iana.org/domains/root/db/xn--otu796d.html
招聘
-// xn--p1acf : 2013-12-12 Rusnames Limited
+// xn--p1acf : Rusnames Limited
+// https://www.iana.org/domains/root/db/xn--p1acf.html
рус
-// xn--pssy2u : 2015-01-15 VeriSign Sarl
+// xn--pssy2u : VeriSign Sarl
+// https://www.iana.org/domains/root/db/xn--pssy2u.html
大拿
-// xn--q9jyb4c : 2013-09-17 Charleston Road Registry Inc.
+// xn--q9jyb4c : Charleston Road Registry Inc.
+// https://www.iana.org/domains/root/db/xn--q9jyb4c.html
みんな
-// xn--qcka1pmc : 2014-07-31 Charleston Road Registry Inc.
+// xn--qcka1pmc : Charleston Road Registry Inc.
+// https://www.iana.org/domains/root/db/xn--qcka1pmc.html
グーグル
-// xn--rhqv96g : 2013-09-11 Stable Tone Limited
+// xn--rhqv96g : Stable Tone Limited
+// https://www.iana.org/domains/root/db/xn--rhqv96g.html
世界
-// xn--rovu88b : 2015-02-26 Amazon Registry Services, Inc.
+// xn--rovu88b : Amazon Registry Services, Inc.
+// https://www.iana.org/domains/root/db/xn--rovu88b.html
書籍
-// xn--ses554g : 2014-01-16 KNET Co., Ltd.
+// xn--ses554g : KNET Co., Ltd.
+// https://www.iana.org/domains/root/db/xn--ses554g.html
网址
-// xn--t60b56a : 2015-01-15 VeriSign Sarl
+// xn--t60b56a : VeriSign Sarl
+// https://www.iana.org/domains/root/db/xn--t60b56a.html
닷넷
-// xn--tckwe : 2015-01-15 VeriSign Sarl
+// xn--tckwe : VeriSign Sarl
+// https://www.iana.org/domains/root/db/xn--tckwe.html
コム
-// xn--tiq49xqyj : 2015-10-21 Pontificium Consilium de Comunicationibus Socialibus (PCCS) (Pontifical Council for Social Communication)
+// xn--tiq49xqyj : Pontificium Consilium de Comunicationibus Socialibus (PCCS) (Pontifical Council for Social Communication)
+// https://www.iana.org/domains/root/db/xn--tiq49xqyj.html
天主教
-// xn--unup4y : 2013-07-14 Binky Moon, LLC
+// xn--unup4y : Binky Moon, LLC
+// https://www.iana.org/domains/root/db/xn--unup4y.html
游戏
-// xn--vermgensberater-ctb : 2014-06-23 Deutsche Vermögensberatung Aktiengesellschaft DVAG
+// xn--vermgensberater-ctb : Deutsche Vermögensberatung Aktiengesellschaft DVAG
+// https://www.iana.org/domains/root/db/xn--vermgensberater-ctb.html
vermögensberater
-// xn--vermgensberatung-pwb : 2014-06-23 Deutsche Vermögensberatung Aktiengesellschaft DVAG
+// xn--vermgensberatung-pwb : Deutsche Vermögensberatung Aktiengesellschaft DVAG
+// https://www.iana.org/domains/root/db/xn--vermgensberatung-pwb.html
vermögensberatung
-// xn--vhquv : 2013-08-27 Binky Moon, LLC
+// xn--vhquv : Binky Moon, LLC
+// https://www.iana.org/domains/root/db/xn--vhquv.html
企业
-// xn--vuq861b : 2014-10-16 Beijing Tele-info Network Technology Co., Ltd.
+// xn--vuq861b : Beijing Tele-info Technology Co., Ltd.
+// https://www.iana.org/domains/root/db/xn--vuq861b.html
信息
-// xn--w4r85el8fhu5dnra : 2015-04-30 Kerry Trading Co. Limited
+// xn--w4r85el8fhu5dnra : Kerry Trading Co. Limited
+// https://www.iana.org/domains/root/db/xn--w4r85el8fhu5dnra.html
嘉里大酒店
-// xn--w4rs40l : 2015-07-30 Kerry Trading Co. Limited
+// xn--w4rs40l : Kerry Trading Co. Limited
+// https://www.iana.org/domains/root/db/xn--w4rs40l.html
嘉里
-// xn--xhq521b : 2013-11-14 Guangzhou YU Wei Information Technology Co., Ltd.
+// xn--xhq521b : Guangzhou YU Wei Information Technology Co., Ltd.
+// https://www.iana.org/domains/root/db/xn--xhq521b.html
广东
-// xn--zfr164b : 2013-11-08 China Organizational Name Administration Center
+// xn--zfr164b : China Organizational Name Administration Center
+// https://www.iana.org/domains/root/db/xn--zfr164b.html
政务
-// xyz : 2013-12-05 XYZ.COM LLC
+// xyz : XYZ.COM LLC
+// https://www.iana.org/domains/root/db/xyz.html
xyz
-// yachts : 2014-01-09 XYZ.COM LLC
+// yachts : XYZ.COM LLC
+// https://www.iana.org/domains/root/db/yachts.html
yachts
-// yahoo : 2015-04-02 Oath Inc.
+// yahoo : Oath Inc.
+// https://www.iana.org/domains/root/db/yahoo.html
yahoo
-// yamaxun : 2014-12-18 Amazon Registry Services, Inc.
+// yamaxun : Amazon Registry Services, Inc.
+// https://www.iana.org/domains/root/db/yamaxun.html
yamaxun
-// yandex : 2014-04-10 Yandex Europe B.V.
+// yandex : Yandex Europe B.V.
+// https://www.iana.org/domains/root/db/yandex.html
yandex
-// yodobashi : 2014-11-20 YODOBASHI CAMERA CO.,LTD.
+// yodobashi : YODOBASHI CAMERA CO.,LTD.
+// https://www.iana.org/domains/root/db/yodobashi.html
yodobashi
-// yoga : 2014-05-29 Registry Services, LLC
+// yoga : Registry Services, LLC
+// https://www.iana.org/domains/root/db/yoga.html
yoga
-// yokohama : 2013-12-12 GMO Registry, Inc.
+// yokohama : GMO Registry, Inc.
+// https://www.iana.org/domains/root/db/yokohama.html
yokohama
-// you : 2015-04-09 Amazon Registry Services, Inc.
+// you : Amazon Registry Services, Inc.
+// https://www.iana.org/domains/root/db/you.html
you
-// youtube : 2014-05-01 Charleston Road Registry Inc.
+// youtube : Charleston Road Registry Inc.
+// https://www.iana.org/domains/root/db/youtube.html
youtube
-// yun : 2015-01-08 Beijing Qihu Keji Co., Ltd.
+// yun : Beijing Qihu Keji Co., Ltd.
+// https://www.iana.org/domains/root/db/yun.html
yun
-// zappos : 2015-06-25 Amazon Registry Services, Inc.
+// zappos : Amazon Registry Services, Inc.
+// https://www.iana.org/domains/root/db/zappos.html
zappos
-// zara : 2014-11-07 Industria de Diseño Textil, S.A. (INDITEX, S.A.)
+// zara : Industria de Diseño Textil, S.A. (INDITEX, S.A.)
+// https://www.iana.org/domains/root/db/zara.html
zara
-// zero : 2014-12-18 Amazon Registry Services, Inc.
+// zero : Amazon Registry Services, Inc.
+// https://www.iana.org/domains/root/db/zero.html
zero
-// zip : 2014-05-08 Charleston Road Registry Inc.
+// zip : Charleston Road Registry Inc.
+// https://www.iana.org/domains/root/db/zip.html
zip
-// zone : 2013-11-14 Binky Moon, LLC
+// zone : Binky Moon, LLC
+// https://www.iana.org/domains/root/db/zone.html
zone
-// zuerich : 2014-11-07 Kanton Zürich (Canton of Zurich)
+// zuerich : Kanton Zürich (Canton of Zurich)
+// https://www.iana.org/domains/root/db/zuerich.html
zuerich
@@ -10668,6 +11247,11 @@ adobeaemcloud.net
hlx.page
hlx3.page
+// Adobe Developer Platform : https://developer.adobe.com
+// Submitted by Jesse MacFadyen<jessem@adobe.com>
+adobeio-static.net
+adobeioruntime.net
+
// Agnat sp. z o.o. : https://domena.pl
// Submitted by Przemyslaw Plewa <it-admin@domena.pl>
beep.pl
@@ -10682,6 +11266,24 @@ airkitapps.eu
// Submitted by Etienne Stalmans <security@aiven.io>
aivencloud.com
+// Akamai : https://www.akamai.com/
+// Submitted by Akamai Team <publicsuffixlist@akamai.com>
+akadns.net
+akamai.net
+akamai-staging.net
+akamaiedge.net
+akamaiedge-staging.net
+akamaihd.net
+akamaihd-staging.net
+akamaiorigin.net
+akamaiorigin-staging.net
+akamaized.net
+akamaized-staging.net
+edgekey.net
+edgekey-staging.net
+edgesuite.net
+edgesuite-staging.net
+
// alboto.ca : http://alboto.ca
// Submitted by Anton Avramov <avramov@alboto.ca>
barsy.ca
@@ -10711,11 +11313,78 @@ myamaze.net
// Submitted by AWS Security <psl-maintainers@amazon.com>
// Subsections of Amazon/subsidiaries will appear until "concludes" tag
+// Amazon API Gateway
+// Submitted by AWS Security <psl-maintainers@amazon.com>
+// Reference: 4d863337-ff98-4501-a6f2-361eba8445d6
+execute-api.cn-north-1.amazonaws.com.cn
+execute-api.cn-northwest-1.amazonaws.com.cn
+execute-api.af-south-1.amazonaws.com
+execute-api.ap-east-1.amazonaws.com
+execute-api.ap-northeast-1.amazonaws.com
+execute-api.ap-northeast-2.amazonaws.com
+execute-api.ap-northeast-3.amazonaws.com
+execute-api.ap-south-1.amazonaws.com
+execute-api.ap-south-2.amazonaws.com
+execute-api.ap-southeast-1.amazonaws.com
+execute-api.ap-southeast-2.amazonaws.com
+execute-api.ap-southeast-3.amazonaws.com
+execute-api.ap-southeast-4.amazonaws.com
+execute-api.ca-central-1.amazonaws.com
+execute-api.eu-central-1.amazonaws.com
+execute-api.eu-central-2.amazonaws.com
+execute-api.eu-north-1.amazonaws.com
+execute-api.eu-south-1.amazonaws.com
+execute-api.eu-south-2.amazonaws.com
+execute-api.eu-west-1.amazonaws.com
+execute-api.eu-west-2.amazonaws.com
+execute-api.eu-west-3.amazonaws.com
+execute-api.il-central-1.amazonaws.com
+execute-api.me-central-1.amazonaws.com
+execute-api.me-south-1.amazonaws.com
+execute-api.sa-east-1.amazonaws.com
+execute-api.us-east-1.amazonaws.com
+execute-api.us-east-2.amazonaws.com
+execute-api.us-gov-east-1.amazonaws.com
+execute-api.us-gov-west-1.amazonaws.com
+execute-api.us-west-1.amazonaws.com
+execute-api.us-west-2.amazonaws.com
+
// Amazon CloudFront
// Submitted by Donavan Miller <donavanm@amazon.com>
// Reference: 54144616-fd49-4435-8535-19c6a601bdb3
cloudfront.net
+// Amazon Cognito
+// Submitted by AWS Security <psl-maintainers@amazon.com>
+// Reference: 7bee1013-f456-47df-bfe8-03c78d946d61
+auth.af-south-1.amazoncognito.com
+auth.ap-northeast-1.amazoncognito.com
+auth.ap-northeast-2.amazoncognito.com
+auth.ap-northeast-3.amazoncognito.com
+auth.ap-south-1.amazoncognito.com
+auth.ap-southeast-1.amazoncognito.com
+auth.ap-southeast-2.amazoncognito.com
+auth.ap-southeast-3.amazoncognito.com
+auth.ca-central-1.amazoncognito.com
+auth.eu-central-1.amazoncognito.com
+auth.eu-north-1.amazoncognito.com
+auth.eu-south-1.amazoncognito.com
+auth.eu-west-1.amazoncognito.com
+auth.eu-west-2.amazoncognito.com
+auth.eu-west-3.amazoncognito.com
+auth.il-central-1.amazoncognito.com
+auth.me-south-1.amazoncognito.com
+auth.sa-east-1.amazoncognito.com
+auth.us-east-1.amazoncognito.com
+auth-fips.us-east-1.amazoncognito.com
+auth.us-east-2.amazoncognito.com
+auth-fips.us-east-2.amazoncognito.com
+auth-fips.us-gov-west-1.amazoncognito.com
+auth.us-west-1.amazoncognito.com
+auth-fips.us-west-1.amazoncognito.com
+auth.us-west-2.amazoncognito.com
+auth-fips.us-west-2.amazoncognito.com
+
// Amazon EC2
// Submitted by Luke Wells <psl-maintainers@amazon.com>
// Reference: 4c38fa71-58ac-4768-99e5-689c1767e537
@@ -10724,47 +11393,307 @@ cloudfront.net
*.compute.amazonaws.com.cn
us-east-1.amazonaws.com
+// Amazon EMR
+// Submitted by AWS Security <psl-maintainers@amazon.com>
+// Reference: 597f3f8e-9283-4e48-8e32-7ee25a1ff6ab
+emrappui-prod.cn-north-1.amazonaws.com.cn
+emrnotebooks-prod.cn-north-1.amazonaws.com.cn
+emrstudio-prod.cn-north-1.amazonaws.com.cn
+emrappui-prod.cn-northwest-1.amazonaws.com.cn
+emrnotebooks-prod.cn-northwest-1.amazonaws.com.cn
+emrstudio-prod.cn-northwest-1.amazonaws.com.cn
+emrappui-prod.af-south-1.amazonaws.com
+emrnotebooks-prod.af-south-1.amazonaws.com
+emrstudio-prod.af-south-1.amazonaws.com
+emrappui-prod.ap-east-1.amazonaws.com
+emrnotebooks-prod.ap-east-1.amazonaws.com
+emrstudio-prod.ap-east-1.amazonaws.com
+emrappui-prod.ap-northeast-1.amazonaws.com
+emrnotebooks-prod.ap-northeast-1.amazonaws.com
+emrstudio-prod.ap-northeast-1.amazonaws.com
+emrappui-prod.ap-northeast-2.amazonaws.com
+emrnotebooks-prod.ap-northeast-2.amazonaws.com
+emrstudio-prod.ap-northeast-2.amazonaws.com
+emrappui-prod.ap-northeast-3.amazonaws.com
+emrnotebooks-prod.ap-northeast-3.amazonaws.com
+emrstudio-prod.ap-northeast-3.amazonaws.com
+emrappui-prod.ap-south-1.amazonaws.com
+emrnotebooks-prod.ap-south-1.amazonaws.com
+emrstudio-prod.ap-south-1.amazonaws.com
+emrappui-prod.ap-southeast-1.amazonaws.com
+emrnotebooks-prod.ap-southeast-1.amazonaws.com
+emrstudio-prod.ap-southeast-1.amazonaws.com
+emrappui-prod.ap-southeast-2.amazonaws.com
+emrnotebooks-prod.ap-southeast-2.amazonaws.com
+emrstudio-prod.ap-southeast-2.amazonaws.com
+emrappui-prod.ap-southeast-3.amazonaws.com
+emrnotebooks-prod.ap-southeast-3.amazonaws.com
+emrstudio-prod.ap-southeast-3.amazonaws.com
+emrappui-prod.ca-central-1.amazonaws.com
+emrnotebooks-prod.ca-central-1.amazonaws.com
+emrstudio-prod.ca-central-1.amazonaws.com
+emrappui-prod.eu-central-1.amazonaws.com
+emrnotebooks-prod.eu-central-1.amazonaws.com
+emrstudio-prod.eu-central-1.amazonaws.com
+emrappui-prod.eu-north-1.amazonaws.com
+emrnotebooks-prod.eu-north-1.amazonaws.com
+emrstudio-prod.eu-north-1.amazonaws.com
+emrappui-prod.eu-south-1.amazonaws.com
+emrnotebooks-prod.eu-south-1.amazonaws.com
+emrstudio-prod.eu-south-1.amazonaws.com
+emrappui-prod.eu-west-1.amazonaws.com
+emrnotebooks-prod.eu-west-1.amazonaws.com
+emrstudio-prod.eu-west-1.amazonaws.com
+emrappui-prod.eu-west-2.amazonaws.com
+emrnotebooks-prod.eu-west-2.amazonaws.com
+emrstudio-prod.eu-west-2.amazonaws.com
+emrappui-prod.eu-west-3.amazonaws.com
+emrnotebooks-prod.eu-west-3.amazonaws.com
+emrstudio-prod.eu-west-3.amazonaws.com
+emrappui-prod.me-central-1.amazonaws.com
+emrnotebooks-prod.me-central-1.amazonaws.com
+emrstudio-prod.me-central-1.amazonaws.com
+emrappui-prod.me-south-1.amazonaws.com
+emrnotebooks-prod.me-south-1.amazonaws.com
+emrstudio-prod.me-south-1.amazonaws.com
+emrappui-prod.sa-east-1.amazonaws.com
+emrnotebooks-prod.sa-east-1.amazonaws.com
+emrstudio-prod.sa-east-1.amazonaws.com
+emrappui-prod.us-east-1.amazonaws.com
+emrnotebooks-prod.us-east-1.amazonaws.com
+emrstudio-prod.us-east-1.amazonaws.com
+emrappui-prod.us-east-2.amazonaws.com
+emrnotebooks-prod.us-east-2.amazonaws.com
+emrstudio-prod.us-east-2.amazonaws.com
+emrappui-prod.us-gov-east-1.amazonaws.com
+emrnotebooks-prod.us-gov-east-1.amazonaws.com
+emrstudio-prod.us-gov-east-1.amazonaws.com
+emrappui-prod.us-gov-west-1.amazonaws.com
+emrnotebooks-prod.us-gov-west-1.amazonaws.com
+emrstudio-prod.us-gov-west-1.amazonaws.com
+emrappui-prod.us-west-1.amazonaws.com
+emrnotebooks-prod.us-west-1.amazonaws.com
+emrstudio-prod.us-west-1.amazonaws.com
+emrappui-prod.us-west-2.amazonaws.com
+emrnotebooks-prod.us-west-2.amazonaws.com
+emrstudio-prod.us-west-2.amazonaws.com
+
+// Amazon Managed Workflows for Apache Airflow
+// Submitted by AWS Security <psl-maintainers@amazon.com>
+// Reference: 4ab55e6f-90c0-4a8d-b6a0-52ca5dbb1c2e
+*.cn-north-1.airflow.amazonaws.com.cn
+*.cn-northwest-1.airflow.amazonaws.com.cn
+*.ap-northeast-1.airflow.amazonaws.com
+*.ap-northeast-2.airflow.amazonaws.com
+*.ap-south-1.airflow.amazonaws.com
+*.ap-southeast-1.airflow.amazonaws.com
+*.ap-southeast-2.airflow.amazonaws.com
+*.ca-central-1.airflow.amazonaws.com
+*.eu-central-1.airflow.amazonaws.com
+*.eu-north-1.airflow.amazonaws.com
+*.eu-west-1.airflow.amazonaws.com
+*.eu-west-2.airflow.amazonaws.com
+*.eu-west-3.airflow.amazonaws.com
+*.sa-east-1.airflow.amazonaws.com
+*.us-east-1.airflow.amazonaws.com
+*.us-east-2.airflow.amazonaws.com
+*.us-west-2.airflow.amazonaws.com
+
// Amazon S3
-// Submitted by Luke Wells <psl-maintainers@amazon.com>
-// Reference: d068bd97-f0a9-4838-a6d8-954b622ef4ae
+// Submitted by AWS Security <psl-maintainers@amazon.com>
+// Reference: 0e801048-08f2-4064-9cb8-e7373e0b57f4
+s3.dualstack.cn-north-1.amazonaws.com.cn
+s3-accesspoint.dualstack.cn-north-1.amazonaws.com.cn
+s3-website.dualstack.cn-north-1.amazonaws.com.cn
s3.cn-north-1.amazonaws.com.cn
+s3-accesspoint.cn-north-1.amazonaws.com.cn
+s3-deprecated.cn-north-1.amazonaws.com.cn
+s3-object-lambda.cn-north-1.amazonaws.com.cn
+s3-website.cn-north-1.amazonaws.com.cn
+s3.dualstack.cn-northwest-1.amazonaws.com.cn
+s3-accesspoint.dualstack.cn-northwest-1.amazonaws.com.cn
+s3.cn-northwest-1.amazonaws.com.cn
+s3-accesspoint.cn-northwest-1.amazonaws.com.cn
+s3-object-lambda.cn-northwest-1.amazonaws.com.cn
+s3-website.cn-northwest-1.amazonaws.com.cn
+s3.dualstack.af-south-1.amazonaws.com
+s3-accesspoint.dualstack.af-south-1.amazonaws.com
+s3-website.dualstack.af-south-1.amazonaws.com
+s3.af-south-1.amazonaws.com
+s3-accesspoint.af-south-1.amazonaws.com
+s3-object-lambda.af-south-1.amazonaws.com
+s3-website.af-south-1.amazonaws.com
+s3.dualstack.ap-east-1.amazonaws.com
+s3-accesspoint.dualstack.ap-east-1.amazonaws.com
+s3.ap-east-1.amazonaws.com
+s3-accesspoint.ap-east-1.amazonaws.com
+s3-object-lambda.ap-east-1.amazonaws.com
+s3-website.ap-east-1.amazonaws.com
s3.dualstack.ap-northeast-1.amazonaws.com
+s3-accesspoint.dualstack.ap-northeast-1.amazonaws.com
+s3-website.dualstack.ap-northeast-1.amazonaws.com
+s3.ap-northeast-1.amazonaws.com
+s3-accesspoint.ap-northeast-1.amazonaws.com
+s3-object-lambda.ap-northeast-1.amazonaws.com
+s3-website.ap-northeast-1.amazonaws.com
s3.dualstack.ap-northeast-2.amazonaws.com
+s3-accesspoint.dualstack.ap-northeast-2.amazonaws.com
+s3-website.dualstack.ap-northeast-2.amazonaws.com
s3.ap-northeast-2.amazonaws.com
+s3-accesspoint.ap-northeast-2.amazonaws.com
+s3-object-lambda.ap-northeast-2.amazonaws.com
s3-website.ap-northeast-2.amazonaws.com
+s3.dualstack.ap-northeast-3.amazonaws.com
+s3-accesspoint.dualstack.ap-northeast-3.amazonaws.com
+s3-website.dualstack.ap-northeast-3.amazonaws.com
+s3.ap-northeast-3.amazonaws.com
+s3-accesspoint.ap-northeast-3.amazonaws.com
+s3-object-lambda.ap-northeast-3.amazonaws.com
+s3-website.ap-northeast-3.amazonaws.com
s3.dualstack.ap-south-1.amazonaws.com
+s3-accesspoint.dualstack.ap-south-1.amazonaws.com
+s3-website.dualstack.ap-south-1.amazonaws.com
s3.ap-south-1.amazonaws.com
+s3-accesspoint.ap-south-1.amazonaws.com
+s3-object-lambda.ap-south-1.amazonaws.com
s3-website.ap-south-1.amazonaws.com
+s3.dualstack.ap-south-2.amazonaws.com
+s3-accesspoint.dualstack.ap-south-2.amazonaws.com
+s3.ap-south-2.amazonaws.com
+s3-accesspoint.ap-south-2.amazonaws.com
+s3-object-lambda.ap-south-2.amazonaws.com
+s3-website.ap-south-2.amazonaws.com
s3.dualstack.ap-southeast-1.amazonaws.com
+s3-accesspoint.dualstack.ap-southeast-1.amazonaws.com
+s3-website.dualstack.ap-southeast-1.amazonaws.com
+s3.ap-southeast-1.amazonaws.com
+s3-accesspoint.ap-southeast-1.amazonaws.com
+s3-object-lambda.ap-southeast-1.amazonaws.com
+s3-website.ap-southeast-1.amazonaws.com
s3.dualstack.ap-southeast-2.amazonaws.com
+s3-accesspoint.dualstack.ap-southeast-2.amazonaws.com
+s3-website.dualstack.ap-southeast-2.amazonaws.com
+s3.ap-southeast-2.amazonaws.com
+s3-accesspoint.ap-southeast-2.amazonaws.com
+s3-object-lambda.ap-southeast-2.amazonaws.com
+s3-website.ap-southeast-2.amazonaws.com
+s3.dualstack.ap-southeast-3.amazonaws.com
+s3-accesspoint.dualstack.ap-southeast-3.amazonaws.com
+s3.ap-southeast-3.amazonaws.com
+s3-accesspoint.ap-southeast-3.amazonaws.com
+s3-object-lambda.ap-southeast-3.amazonaws.com
+s3-website.ap-southeast-3.amazonaws.com
+s3.dualstack.ap-southeast-4.amazonaws.com
+s3-accesspoint.dualstack.ap-southeast-4.amazonaws.com
+s3.ap-southeast-4.amazonaws.com
+s3-accesspoint.ap-southeast-4.amazonaws.com
+s3-object-lambda.ap-southeast-4.amazonaws.com
+s3-website.ap-southeast-4.amazonaws.com
s3.dualstack.ca-central-1.amazonaws.com
+s3-accesspoint.dualstack.ca-central-1.amazonaws.com
+s3-accesspoint-fips.dualstack.ca-central-1.amazonaws.com
+s3-fips.dualstack.ca-central-1.amazonaws.com
+s3-website.dualstack.ca-central-1.amazonaws.com
s3.ca-central-1.amazonaws.com
+s3-accesspoint.ca-central-1.amazonaws.com
+s3-accesspoint-fips.ca-central-1.amazonaws.com
+s3-fips.ca-central-1.amazonaws.com
+s3-object-lambda.ca-central-1.amazonaws.com
s3-website.ca-central-1.amazonaws.com
s3.dualstack.eu-central-1.amazonaws.com
+s3-accesspoint.dualstack.eu-central-1.amazonaws.com
+s3-website.dualstack.eu-central-1.amazonaws.com
s3.eu-central-1.amazonaws.com
+s3-accesspoint.eu-central-1.amazonaws.com
+s3-object-lambda.eu-central-1.amazonaws.com
s3-website.eu-central-1.amazonaws.com
+s3.dualstack.eu-central-2.amazonaws.com
+s3-accesspoint.dualstack.eu-central-2.amazonaws.com
+s3.eu-central-2.amazonaws.com
+s3-accesspoint.eu-central-2.amazonaws.com
+s3-object-lambda.eu-central-2.amazonaws.com
+s3-website.eu-central-2.amazonaws.com
+s3.dualstack.eu-north-1.amazonaws.com
+s3-accesspoint.dualstack.eu-north-1.amazonaws.com
+s3.eu-north-1.amazonaws.com
+s3-accesspoint.eu-north-1.amazonaws.com
+s3-object-lambda.eu-north-1.amazonaws.com
+s3-website.eu-north-1.amazonaws.com
+s3.dualstack.eu-south-1.amazonaws.com
+s3-accesspoint.dualstack.eu-south-1.amazonaws.com
+s3-website.dualstack.eu-south-1.amazonaws.com
+s3.eu-south-1.amazonaws.com
+s3-accesspoint.eu-south-1.amazonaws.com
+s3-object-lambda.eu-south-1.amazonaws.com
+s3-website.eu-south-1.amazonaws.com
+s3.dualstack.eu-south-2.amazonaws.com
+s3-accesspoint.dualstack.eu-south-2.amazonaws.com
+s3.eu-south-2.amazonaws.com
+s3-accesspoint.eu-south-2.amazonaws.com
+s3-object-lambda.eu-south-2.amazonaws.com
+s3-website.eu-south-2.amazonaws.com
s3.dualstack.eu-west-1.amazonaws.com
+s3-accesspoint.dualstack.eu-west-1.amazonaws.com
+s3-website.dualstack.eu-west-1.amazonaws.com
+s3.eu-west-1.amazonaws.com
+s3-accesspoint.eu-west-1.amazonaws.com
+s3-deprecated.eu-west-1.amazonaws.com
+s3-object-lambda.eu-west-1.amazonaws.com
+s3-website.eu-west-1.amazonaws.com
s3.dualstack.eu-west-2.amazonaws.com
+s3-accesspoint.dualstack.eu-west-2.amazonaws.com
s3.eu-west-2.amazonaws.com
+s3-accesspoint.eu-west-2.amazonaws.com
+s3-object-lambda.eu-west-2.amazonaws.com
s3-website.eu-west-2.amazonaws.com
s3.dualstack.eu-west-3.amazonaws.com
+s3-accesspoint.dualstack.eu-west-3.amazonaws.com
+s3-website.dualstack.eu-west-3.amazonaws.com
s3.eu-west-3.amazonaws.com
+s3-accesspoint.eu-west-3.amazonaws.com
+s3-object-lambda.eu-west-3.amazonaws.com
s3-website.eu-west-3.amazonaws.com
+s3.dualstack.il-central-1.amazonaws.com
+s3-accesspoint.dualstack.il-central-1.amazonaws.com
+s3.il-central-1.amazonaws.com
+s3-accesspoint.il-central-1.amazonaws.com
+s3-object-lambda.il-central-1.amazonaws.com
+s3-website.il-central-1.amazonaws.com
+s3.dualstack.me-central-1.amazonaws.com
+s3-accesspoint.dualstack.me-central-1.amazonaws.com
+s3.me-central-1.amazonaws.com
+s3-accesspoint.me-central-1.amazonaws.com
+s3-object-lambda.me-central-1.amazonaws.com
+s3-website.me-central-1.amazonaws.com
+s3.dualstack.me-south-1.amazonaws.com
+s3-accesspoint.dualstack.me-south-1.amazonaws.com
+s3.me-south-1.amazonaws.com
+s3-accesspoint.me-south-1.amazonaws.com
+s3-object-lambda.me-south-1.amazonaws.com
+s3-website.me-south-1.amazonaws.com
s3.amazonaws.com
+s3-1.amazonaws.com
+s3-ap-east-1.amazonaws.com
s3-ap-northeast-1.amazonaws.com
s3-ap-northeast-2.amazonaws.com
+s3-ap-northeast-3.amazonaws.com
s3-ap-south-1.amazonaws.com
s3-ap-southeast-1.amazonaws.com
s3-ap-southeast-2.amazonaws.com
s3-ca-central-1.amazonaws.com
s3-eu-central-1.amazonaws.com
+s3-eu-north-1.amazonaws.com
s3-eu-west-1.amazonaws.com
s3-eu-west-2.amazonaws.com
s3-eu-west-3.amazonaws.com
s3-external-1.amazonaws.com
+s3-fips-us-gov-east-1.amazonaws.com
s3-fips-us-gov-west-1.amazonaws.com
+mrap.accesspoint.s3-global.amazonaws.com
+s3-me-south-1.amazonaws.com
s3-sa-east-1.amazonaws.com
s3-us-east-2.amazonaws.com
+s3-us-gov-east-1.amazonaws.com
s3-us-gov-west-1.amazonaws.com
s3-us-west-1.amazonaws.com
s3-us-west-2.amazonaws.com
@@ -10774,80 +11703,277 @@ s3-website-ap-southeast-2.amazonaws.com
s3-website-eu-west-1.amazonaws.com
s3-website-sa-east-1.amazonaws.com
s3-website-us-east-1.amazonaws.com
+s3-website-us-gov-west-1.amazonaws.com
s3-website-us-west-1.amazonaws.com
s3-website-us-west-2.amazonaws.com
s3.dualstack.sa-east-1.amazonaws.com
+s3-accesspoint.dualstack.sa-east-1.amazonaws.com
+s3-website.dualstack.sa-east-1.amazonaws.com
+s3.sa-east-1.amazonaws.com
+s3-accesspoint.sa-east-1.amazonaws.com
+s3-object-lambda.sa-east-1.amazonaws.com
+s3-website.sa-east-1.amazonaws.com
s3.dualstack.us-east-1.amazonaws.com
+s3-accesspoint.dualstack.us-east-1.amazonaws.com
+s3-accesspoint-fips.dualstack.us-east-1.amazonaws.com
+s3-fips.dualstack.us-east-1.amazonaws.com
+s3-website.dualstack.us-east-1.amazonaws.com
+s3.us-east-1.amazonaws.com
+s3-accesspoint.us-east-1.amazonaws.com
+s3-accesspoint-fips.us-east-1.amazonaws.com
+s3-deprecated.us-east-1.amazonaws.com
+s3-fips.us-east-1.amazonaws.com
+s3-object-lambda.us-east-1.amazonaws.com
+s3-website.us-east-1.amazonaws.com
s3.dualstack.us-east-2.amazonaws.com
+s3-accesspoint.dualstack.us-east-2.amazonaws.com
+s3-accesspoint-fips.dualstack.us-east-2.amazonaws.com
+s3-fips.dualstack.us-east-2.amazonaws.com
s3.us-east-2.amazonaws.com
+s3-accesspoint.us-east-2.amazonaws.com
+s3-accesspoint-fips.us-east-2.amazonaws.com
+s3-deprecated.us-east-2.amazonaws.com
+s3-fips.us-east-2.amazonaws.com
+s3-object-lambda.us-east-2.amazonaws.com
s3-website.us-east-2.amazonaws.com
+s3.dualstack.us-gov-east-1.amazonaws.com
+s3-accesspoint.dualstack.us-gov-east-1.amazonaws.com
+s3-accesspoint-fips.dualstack.us-gov-east-1.amazonaws.com
+s3-fips.dualstack.us-gov-east-1.amazonaws.com
+s3.us-gov-east-1.amazonaws.com
+s3-accesspoint.us-gov-east-1.amazonaws.com
+s3-accesspoint-fips.us-gov-east-1.amazonaws.com
+s3-fips.us-gov-east-1.amazonaws.com
+s3-object-lambda.us-gov-east-1.amazonaws.com
+s3-website.us-gov-east-1.amazonaws.com
+s3.dualstack.us-gov-west-1.amazonaws.com
+s3-accesspoint.dualstack.us-gov-west-1.amazonaws.com
+s3-accesspoint-fips.dualstack.us-gov-west-1.amazonaws.com
+s3-fips.dualstack.us-gov-west-1.amazonaws.com
+s3.us-gov-west-1.amazonaws.com
+s3-accesspoint.us-gov-west-1.amazonaws.com
+s3-accesspoint-fips.us-gov-west-1.amazonaws.com
+s3-fips.us-gov-west-1.amazonaws.com
+s3-object-lambda.us-gov-west-1.amazonaws.com
+s3-website.us-gov-west-1.amazonaws.com
+s3.dualstack.us-west-1.amazonaws.com
+s3-accesspoint.dualstack.us-west-1.amazonaws.com
+s3-accesspoint-fips.dualstack.us-west-1.amazonaws.com
+s3-fips.dualstack.us-west-1.amazonaws.com
+s3-website.dualstack.us-west-1.amazonaws.com
+s3.us-west-1.amazonaws.com
+s3-accesspoint.us-west-1.amazonaws.com
+s3-accesspoint-fips.us-west-1.amazonaws.com
+s3-fips.us-west-1.amazonaws.com
+s3-object-lambda.us-west-1.amazonaws.com
+s3-website.us-west-1.amazonaws.com
+s3.dualstack.us-west-2.amazonaws.com
+s3-accesspoint.dualstack.us-west-2.amazonaws.com
+s3-accesspoint-fips.dualstack.us-west-2.amazonaws.com
+s3-fips.dualstack.us-west-2.amazonaws.com
+s3-website.dualstack.us-west-2.amazonaws.com
+s3.us-west-2.amazonaws.com
+s3-accesspoint.us-west-2.amazonaws.com
+s3-accesspoint-fips.us-west-2.amazonaws.com
+s3-deprecated.us-west-2.amazonaws.com
+s3-fips.us-west-2.amazonaws.com
+s3-object-lambda.us-west-2.amazonaws.com
+s3-website.us-west-2.amazonaws.com
+
+// Amazon SageMaker Notebook Instances
+// Submitted by AWS Security <psl-maintainers@amazon.com>
+// Reference: fe8c9e94-5a22-486d-8750-991a3a9b13c6
+notebook.af-south-1.sagemaker.aws
+notebook.ap-east-1.sagemaker.aws
+notebook.ap-northeast-1.sagemaker.aws
+notebook.ap-northeast-2.sagemaker.aws
+notebook.ap-northeast-3.sagemaker.aws
+notebook.ap-south-1.sagemaker.aws
+notebook.ap-south-2.sagemaker.aws
+notebook.ap-southeast-1.sagemaker.aws
+notebook.ap-southeast-2.sagemaker.aws
+notebook.ap-southeast-3.sagemaker.aws
+notebook.ap-southeast-4.sagemaker.aws
+notebook.ca-central-1.sagemaker.aws
+notebook.eu-central-1.sagemaker.aws
+notebook.eu-central-2.sagemaker.aws
+notebook.eu-north-1.sagemaker.aws
+notebook.eu-south-1.sagemaker.aws
+notebook.eu-south-2.sagemaker.aws
+notebook.eu-west-1.sagemaker.aws
+notebook.eu-west-2.sagemaker.aws
+notebook.eu-west-3.sagemaker.aws
+notebook.il-central-1.sagemaker.aws
+notebook.me-central-1.sagemaker.aws
+notebook.me-south-1.sagemaker.aws
+notebook.sa-east-1.sagemaker.aws
+notebook.us-east-1.sagemaker.aws
+notebook-fips.us-east-1.sagemaker.aws
+notebook.us-east-2.sagemaker.aws
+notebook-fips.us-east-2.sagemaker.aws
+notebook.us-gov-east-1.sagemaker.aws
+notebook-fips.us-gov-east-1.sagemaker.aws
+notebook.us-gov-west-1.sagemaker.aws
+notebook-fips.us-gov-west-1.sagemaker.aws
+notebook.us-west-1.sagemaker.aws
+notebook.us-west-2.sagemaker.aws
+notebook-fips.us-west-2.sagemaker.aws
+notebook.cn-north-1.sagemaker.com.cn
+notebook.cn-northwest-1.sagemaker.com.cn
+
+// Amazon SageMaker Studio
+// Submitted by AWS Security <psl-maintainers@amazon.com>
+// Reference: 057ee397-6bf8-4f20-b807-d7bc145ac980
+studio.af-south-1.sagemaker.aws
+studio.ap-east-1.sagemaker.aws
+studio.ap-northeast-1.sagemaker.aws
+studio.ap-northeast-2.sagemaker.aws
+studio.ap-northeast-3.sagemaker.aws
+studio.ap-south-1.sagemaker.aws
+studio.ap-southeast-1.sagemaker.aws
+studio.ap-southeast-2.sagemaker.aws
+studio.ap-southeast-3.sagemaker.aws
+studio.ca-central-1.sagemaker.aws
+studio.eu-central-1.sagemaker.aws
+studio.eu-north-1.sagemaker.aws
+studio.eu-south-1.sagemaker.aws
+studio.eu-west-1.sagemaker.aws
+studio.eu-west-2.sagemaker.aws
+studio.eu-west-3.sagemaker.aws
+studio.il-central-1.sagemaker.aws
+studio.me-central-1.sagemaker.aws
+studio.me-south-1.sagemaker.aws
+studio.sa-east-1.sagemaker.aws
+studio.us-east-1.sagemaker.aws
+studio.us-east-2.sagemaker.aws
+studio.us-gov-east-1.sagemaker.aws
+studio-fips.us-gov-east-1.sagemaker.aws
+studio.us-gov-west-1.sagemaker.aws
+studio-fips.us-gov-west-1.sagemaker.aws
+studio.us-west-1.sagemaker.aws
+studio.us-west-2.sagemaker.aws
+studio.cn-north-1.sagemaker.com.cn
+studio.cn-northwest-1.sagemaker.com.cn
+
+// Analytics on AWS
+// Submitted by AWS Security <psl-maintainers@amazon.com>
+// Reference: 955f9f40-a495-4e73-ae85-67b77ac9cadd
+analytics-gateway.ap-northeast-1.amazonaws.com
+analytics-gateway.ap-northeast-2.amazonaws.com
+analytics-gateway.ap-south-1.amazonaws.com
+analytics-gateway.ap-southeast-1.amazonaws.com
+analytics-gateway.ap-southeast-2.amazonaws.com
+analytics-gateway.eu-central-1.amazonaws.com
+analytics-gateway.eu-west-1.amazonaws.com
+analytics-gateway.us-east-1.amazonaws.com
+analytics-gateway.us-east-2.amazonaws.com
+analytics-gateway.us-west-2.amazonaws.com
+
+// AWS Amplify
+// Submitted by AWS Security <psl-maintainers@amazon.com>
+// Reference: 5ecce854-c033-4fc4-a755-1a9916d9a9bb
+*.amplifyapp.com
+
+// AWS App Runner
+// Submitted by AWS Security <psl-maintainers@amazon.com>
+// Reference: 6828c008-ba5d-442f-ade5-48da4e7c2316
+*.awsapprunner.com
// AWS Cloud9
// Submitted by: AWS Security <psl-maintainers@amazon.com>
-// Reference: 2b6dfa9a-3a7f-4367-b2e7-0321e77c0d59
+// Reference: 05c44955-977c-4b57-938a-f2af92733f9f
+webview-assets.aws-cloud9.af-south-1.amazonaws.com
vfs.cloud9.af-south-1.amazonaws.com
webview-assets.cloud9.af-south-1.amazonaws.com
+webview-assets.aws-cloud9.ap-east-1.amazonaws.com
vfs.cloud9.ap-east-1.amazonaws.com
webview-assets.cloud9.ap-east-1.amazonaws.com
+webview-assets.aws-cloud9.ap-northeast-1.amazonaws.com
vfs.cloud9.ap-northeast-1.amazonaws.com
webview-assets.cloud9.ap-northeast-1.amazonaws.com
+webview-assets.aws-cloud9.ap-northeast-2.amazonaws.com
vfs.cloud9.ap-northeast-2.amazonaws.com
webview-assets.cloud9.ap-northeast-2.amazonaws.com
+webview-assets.aws-cloud9.ap-northeast-3.amazonaws.com
vfs.cloud9.ap-northeast-3.amazonaws.com
webview-assets.cloud9.ap-northeast-3.amazonaws.com
+webview-assets.aws-cloud9.ap-south-1.amazonaws.com
vfs.cloud9.ap-south-1.amazonaws.com
webview-assets.cloud9.ap-south-1.amazonaws.com
+webview-assets.aws-cloud9.ap-southeast-1.amazonaws.com
vfs.cloud9.ap-southeast-1.amazonaws.com
webview-assets.cloud9.ap-southeast-1.amazonaws.com
+webview-assets.aws-cloud9.ap-southeast-2.amazonaws.com
vfs.cloud9.ap-southeast-2.amazonaws.com
webview-assets.cloud9.ap-southeast-2.amazonaws.com
+webview-assets.aws-cloud9.ca-central-1.amazonaws.com
vfs.cloud9.ca-central-1.amazonaws.com
webview-assets.cloud9.ca-central-1.amazonaws.com
+webview-assets.aws-cloud9.eu-central-1.amazonaws.com
vfs.cloud9.eu-central-1.amazonaws.com
webview-assets.cloud9.eu-central-1.amazonaws.com
+webview-assets.aws-cloud9.eu-north-1.amazonaws.com
vfs.cloud9.eu-north-1.amazonaws.com
webview-assets.cloud9.eu-north-1.amazonaws.com
+webview-assets.aws-cloud9.eu-south-1.amazonaws.com
vfs.cloud9.eu-south-1.amazonaws.com
webview-assets.cloud9.eu-south-1.amazonaws.com
+webview-assets.aws-cloud9.eu-west-1.amazonaws.com
vfs.cloud9.eu-west-1.amazonaws.com
webview-assets.cloud9.eu-west-1.amazonaws.com
+webview-assets.aws-cloud9.eu-west-2.amazonaws.com
vfs.cloud9.eu-west-2.amazonaws.com
webview-assets.cloud9.eu-west-2.amazonaws.com
+webview-assets.aws-cloud9.eu-west-3.amazonaws.com
vfs.cloud9.eu-west-3.amazonaws.com
webview-assets.cloud9.eu-west-3.amazonaws.com
+webview-assets.aws-cloud9.me-south-1.amazonaws.com
vfs.cloud9.me-south-1.amazonaws.com
webview-assets.cloud9.me-south-1.amazonaws.com
+webview-assets.aws-cloud9.sa-east-1.amazonaws.com
vfs.cloud9.sa-east-1.amazonaws.com
webview-assets.cloud9.sa-east-1.amazonaws.com
+webview-assets.aws-cloud9.us-east-1.amazonaws.com
vfs.cloud9.us-east-1.amazonaws.com
webview-assets.cloud9.us-east-1.amazonaws.com
+webview-assets.aws-cloud9.us-east-2.amazonaws.com
vfs.cloud9.us-east-2.amazonaws.com
webview-assets.cloud9.us-east-2.amazonaws.com
+webview-assets.aws-cloud9.us-west-1.amazonaws.com
vfs.cloud9.us-west-1.amazonaws.com
webview-assets.cloud9.us-west-1.amazonaws.com
+webview-assets.aws-cloud9.us-west-2.amazonaws.com
vfs.cloud9.us-west-2.amazonaws.com
webview-assets.cloud9.us-west-2.amazonaws.com
// AWS Elastic Beanstalk
-// Submitted by Luke Wells <psl-maintainers@amazon.com>
-// Reference: aa202394-43a0-4857-b245-8db04549137e
+// Submitted by AWS Security <psl-maintainers@amazon.com>
+// Reference: bb5a965c-dec3-4967-aa22-e306ad064797
cn-north-1.eb.amazonaws.com.cn
cn-northwest-1.eb.amazonaws.com.cn
elasticbeanstalk.com
+af-south-1.elasticbeanstalk.com
+ap-east-1.elasticbeanstalk.com
ap-northeast-1.elasticbeanstalk.com
ap-northeast-2.elasticbeanstalk.com
ap-northeast-3.elasticbeanstalk.com
ap-south-1.elasticbeanstalk.com
ap-southeast-1.elasticbeanstalk.com
ap-southeast-2.elasticbeanstalk.com
+ap-southeast-3.elasticbeanstalk.com
ca-central-1.elasticbeanstalk.com
eu-central-1.elasticbeanstalk.com
+eu-north-1.elasticbeanstalk.com
+eu-south-1.elasticbeanstalk.com
eu-west-1.elasticbeanstalk.com
eu-west-2.elasticbeanstalk.com
eu-west-3.elasticbeanstalk.com
+il-central-1.elasticbeanstalk.com
+me-south-1.elasticbeanstalk.com
sa-east-1.elasticbeanstalk.com
us-east-1.elasticbeanstalk.com
us-east-2.elasticbeanstalk.com
+us-gov-east-1.elasticbeanstalk.com
us-gov-west-1.elasticbeanstalk.com
us-west-1.elasticbeanstalk.com
us-west-2.elasticbeanstalk.com
@@ -10926,6 +12052,10 @@ cdn.prod.atlassian-dev.net
// Submitted by Lukas Reschke <lukas@authentick.net>
translated.page
+// Autocode : https://autocode.com
+// Submitted by Jacob Lee <jacob@autocode.com>
+autocode.dev
+
// AVM : https://avm.de
// Submitted by Andreas Weise <a.weise@avm.de>
myfritz.net
@@ -11054,6 +12184,11 @@ cafjs.com
// Submitted by Marcus Popp <admin@callidomus.com>
mycd.eu
+// Canva Pty Ltd : https://canva.com/
+// Submitted by Joel Aquilina <publicsuffixlist@canva.com>
+canva-apps.cn
+canva-apps.com
+
// Carrd : https://carrd.co
// Submitted by AJ <aj@carrd.co>
drr.ac
@@ -11971,6 +13106,7 @@ u.channelsdvr.net
// Fastly Inc. : http://www.fastly.com/
// Submitted by Fastly Security <security@fastly.com>
edgecompute.app
+fastly-edge.com
fastly-terrarium.com
fastlylb.net
map.fastlylb.net
@@ -12053,7 +13189,7 @@ shw.io
// Submitted by Jonathan Rudenberg <jonathan@flynn.io>
flynnhosting.net
-// Forgerock : https://www.forgerock.com
+// Forgerock : https://www.forgerock.com
// Submitted by Roderick Parr <roderick.parr@forgerock.com>
forgeblocks.com
id.forgerock.io
@@ -12100,7 +13236,7 @@ freemyip.com
// Submitted by Daniel A. Maierhofer <vorstand@funkfeuer.at>
wien.funkfeuer.at
-// Futureweb OG : http://www.futureweb.at
+// Futureweb GmbH : https://www.futureweb.at
// Submitted by Andreas Schnederle-Wagner <schnederle@futureweb.at>
*.futurecms.at
*.ex.futurecms.at
@@ -12485,6 +13621,10 @@ ngo.ng
edu.scot
sch.so
+// HostFly : https://www.ie.ua
+// Submitted by Bohdan Dub <support@hostfly.com.ua>
+ie.ua
+
// HostyHosting (hostyhosting.com)
hostyhosting.io
@@ -12603,7 +13743,6 @@ iobb.net
// Submitted by Ihor Kolodyuk <ik@jelastic.com>
mel.cloudlets.com.au
cloud.interhostsolutions.be
-users.scale.virtualcloud.com.br
mycloud.by
alp1.ae.flow.ch
appengine.flow.ch
@@ -12627,9 +13766,7 @@ ch.trendhosting.cloud
de.trendhosting.cloud
jele.club
amscompute.com
-clicketcloud.com
dopaas.com
-hidora.com
paas.hosted-by-previder.com
rag-cloud.hosteur.com
rag-cloud-ch.hosteur.com
@@ -12943,6 +14080,11 @@ cloudapp.net
azurestaticapps.net
1.azurestaticapps.net
2.azurestaticapps.net
+3.azurestaticapps.net
+4.azurestaticapps.net
+5.azurestaticapps.net
+6.azurestaticapps.net
+7.azurestaticapps.net
centralus.azurestaticapps.net
eastasia.azurestaticapps.net
eastus2.azurestaticapps.net
@@ -13009,7 +14151,22 @@ netlify.app
// ngrok : https://ngrok.com/
// Submitted by Alan Shreve <alan@ngrok.com>
+ngrok.app
+ngrok-free.app
+ngrok.dev
+ngrok-free.dev
ngrok.io
+ap.ngrok.io
+au.ngrok.io
+eu.ngrok.io
+in.ngrok.io
+jp.ngrok.io
+sa.ngrok.io
+us.ngrok.io
+ngrok.pizza
+
+// Nicolaus Copernicus University in Torun - MSK TORMAN (https://www.man.torun.pl)
+torun.pl
// Nimbus Hosting Ltd. : https://www.nimbushosting.co.uk/
// Submitted by Nicholas Ford <nick@nimbushosting.co.uk>
@@ -13406,6 +14563,10 @@ qoto.io
// Submitted by Xavier De Cock <xdecock@gmail.com>
qualifioapp.com
+// Quality Unit: https://qualityunit.com
+// Submitted by Vasyl Tsalko <vtsalko@qualityunit.com>
+ladesk.com
+
// QuickBackend: https://www.quickbackend.com
// Submitted by Dani Biro <dani@pymet.com>
qbuser.com
@@ -13529,6 +14690,56 @@ rocky.page
спб.рус
я.рус
+// SAKURA Internet Inc. : https://www.sakura.ad.jp/
+// Submitted by Internet Service Department <rs-vendor-ml@sakura.ad.jp>
+180r.com
+dojin.com
+sakuratan.com
+sakuraweb.com
+x0.com
+2-d.jp
+bona.jp
+crap.jp
+daynight.jp
+eek.jp
+flop.jp
+halfmoon.jp
+jeez.jp
+matrix.jp
+mimoza.jp
+ivory.ne.jp
+mail-box.ne.jp
+mints.ne.jp
+mokuren.ne.jp
+opal.ne.jp
+sakura.ne.jp
+sumomo.ne.jp
+topaz.ne.jp
+netgamers.jp
+nyanta.jp
+o0o0.jp
+rdy.jp
+rgr.jp
+rulez.jp
+s3.isk01.sakurastorage.jp
+s3.isk02.sakurastorage.jp
+saloon.jp
+sblo.jp
+skr.jp
+tank.jp
+uh-oh.jp
+undo.jp
+rs.webaccel.jp
+user.webaccel.jp
+websozai.jp
+xii.jp
+squares.net
+jpn.org
+kirara.st
+x0.to
+from.tv
+sakura.tv
+
// Salesforce.com, Inc. https://salesforce.com/
// Submitted by Michael Biven <mbiven@salesforce.com>
*.builder.code.com
@@ -13671,6 +14882,20 @@ bounty-full.com
alpha.bounty-full.com
beta.bounty-full.com
+// Smallregistry by Promopixel SARL: https://www.smallregistry.net
+// Former AFNIC's SLDs
+// Submitted by Jérôme Lipowicz <support@promopixel.com>
+aeroport.fr
+avocat.fr
+chambagri.fr
+chirurgiens-dentistes.fr
+experts-comptables.fr
+medecin.fr
+notaires.fr
+pharmacien.fr
+port.fr
+veterinaire.fr
+
// Small Technology Foundation : https://small-tech.org
// Submitted by Aral Balkan <aral@small-tech.org>
small-web.org
@@ -13681,6 +14906,9 @@ vp4.me
// Snowflake Inc : https://www.snowflake.com/
// Submitted by Faith Olapade <faith.olapade@snowflake.com>
+snowflake.app
+privatelink.snowflake.app
+streamlit.app
streamlitapp.com
// Snowplow Analytics : https://snowplowanalytics.com/
@@ -13761,6 +14989,10 @@ myspreadshop.co.uk
// Submitted by Jacob Lee <jacob@stdlib.com>
api.stdlib.com
+// Storipress : https://storipress.com
+// Submitted by Benno Liu <benno@storipress.com>
+storipress.app
+
// Storj Labs Inc. : https://storj.io/
// Submitted by Philip Hutchins <hostmaster@storj.io>
storj.farm
@@ -13956,6 +15188,10 @@ hk.org
ltd.hk
inc.hk
+// UK Intis Telecom LTD : https://it.com
+// Submitted by ITComdomains <to@it.com>
+it.com
+
// UNIVERSAL DOMAIN REGISTRY : https://www.udr.org.yt/
// see also: whois -h whois.udr.org.yt help
// Submitted by Atanunu Igbunuroghene <publicsuffixlist@udr.org.yt>
@@ -14124,6 +15360,8 @@ js.wpenginepowered.com
// Submitted by Shahar Talmi <shahar@wix.com>
wixsite.com
editorx.io
+wixstudio.io
+wix.run
// XenonCloud GbR: https://xenoncloud.net
// Submitted by Julian Uphoff <publicsuffixlist@xenoncloud.net>
diff --git a/etc/themes/deeper-blue-theme.el b/etc/themes/deeper-blue-theme.el
index e3435854a13..ab769281eb6 100644
--- a/etc/themes/deeper-blue-theme.el
+++ b/etc/themes/deeper-blue-theme.el
@@ -64,8 +64,8 @@
`(ediff-fine-diff-B ((,class (:background "cyan4" :foreground "white"))))
`(ediff-odd-diff-A ((,class (:background "Grey50" :foreground "White"))))
`(error ((,class (:foreground "red"))))
- `(flymake-errline ((,class (:background nil :underline "red"))))
- `(flymake-warnline ((,class (:background nil :underline "magenta3"))))
+ `(flymake-errline ((,class (:background unspecified :underline "red"))))
+ `(flymake-warnline ((,class (:background unspecified :underline "magenta3"))))
`(font-lock-builtin-face ((,class (:foreground "LightCoral"))))
`(font-lock-comment-delimiter-face ((,class (:foreground "gray50"))))
`(font-lock-comment-face ((,class (:foreground "gray50"))))
@@ -84,7 +84,7 @@
`(highlight ((,class (:background "DodgerBlue4"))))
`(ido-first-match ((,class (:weight normal :foreground "orange"))))
`(ido-only-match ((,class (:foreground "green"))))
- `(ido-subdir ((,class (:foreground nil :inherit font-lock-keyword-face))))
+ `(ido-subdir ((,class (:foreground unspecified :inherit font-lock-keyword-face))))
`(image-dired-thumb-flagged ((,class (:background "Red1"))))
`(image-dired-thumb-mark ((,class (:background "dodgerblue3"))))
`(info-header-node ((,class (:foreground "DeepSkyBlue1"))))
@@ -98,7 +98,7 @@
`(match ((,class (:background "DeepPink4"))))
`(minibuffer-prompt ((,class (:foreground "CadetBlue1"))))
`(mode-line ((,class (:background "gray75" :foreground "black" :box (:line-width 1 :style released-button)))))
- `(mode-line-buffer-id ((,class (:weight bold :background nil :foreground "blue4"))))
+ `(mode-line-buffer-id ((,class (:weight bold :background unspecified :foreground "blue4"))))
`(mode-line-inactive ((,class (:background "gray40" :foreground "black" :box (:line-width 1 :color "gray40" :style nil)))))
`(outline-1 ((,class (:foreground "SkyBlue1"))))
`(outline-2 ((,class (:foreground "CadetBlue1"))))
diff --git a/etc/themes/leuven-dark-theme.el b/etc/themes/leuven-dark-theme.el
index a1504c5c880..e5427f77909 100644
--- a/etc/themes/leuven-dark-theme.el
+++ b/etc/themes/leuven-dark-theme.el
@@ -621,11 +621,11 @@ more..."
`(helm-source-header ((,class (:weight bold :box (:line-width 1 :color "#3d3842") :background "#433e48" :foreground "#ffffff"))))
`(helm-swoop-target-line-block-face ((,class (:background "#3833ff" :foreground "#e0dde3"))))
`(helm-swoop-target-line-face ((,class (:background "#38330b"))))
- `(helm-swoop-target-word-face ((,class (:weight bold :foreground nil :background "#0742d2"))))
+ `(helm-swoop-target-word-face ((,class (:weight bold :foreground unspecified :background "#0742d2"))))
`(helm-visible-mark ((,class ,marked-line)))
`(helm-w3m-bookmarks-face ((,class (:underline t :foreground "#ff010b"))))
- `(highlight-changes ((,class (:foreground nil)))) ;; blue "#d4f754"
- `(highlight-changes-delete ((,class (:strike-through nil :foreground nil)))) ;; red "#4ff7d7"
+ `(highlight-changes ((,class (:foreground unspecified)))) ;; blue "#d4f754"
+ `(highlight-changes-delete ((,class (:strike-through nil :foreground unspecified)))) ;; red "#4ff7d7"
`(highlight-symbol-face ((,class (:background "#252080"))))
`(hl-line ((,class ,highlight-yellow))) ; Highlight current line.
`(hl-tags-face ((,class ,highlight-current-tag))) ; ~ Pair highlighting (matching tags).
@@ -643,7 +643,7 @@ more..."
`(info-file ((,class (:family "Sans Serif" :height 1.8 :weight bold :box (:line-width 1 :color "#ffff3d") :foreground "#9f6a1c" :background "#563c2a"))))
`(info-header-node ((,class (:underline t :foreground "#065aff")))) ; nodes in header
`(info-header-xref ((,class (:underline t :foreground "#e46f0b")))) ; cross references in header
- `(info-index-match ((,class (:weight bold :foreground nil :background "#0742d2")))) ; when using `i'
+ `(info-index-match ((,class (:weight bold :foreground unspecified :background "#0742d2")))) ; when using `i'
`(info-menu-header ((,class ,ol2))) ; menu titles (headers) -- major topics
`(info-menu-star ((,class (:foreground "#ffffff")))) ; every 3rd menu item
`(info-node ((,class (:underline t :foreground "#ffff0b")))) ; node names
diff --git a/etc/themes/leuven-theme.el b/etc/themes/leuven-theme.el
index 5b9daada3b2..2f20dc39859 100644
--- a/etc/themes/leuven-theme.el
+++ b/etc/themes/leuven-theme.el
@@ -618,11 +618,11 @@ more..."
`(helm-source-header ((,class (:weight bold :box (:line-width 1 :color "#C7C7C7") :background "#DEDEDE" :foreground "black"))))
`(helm-swoop-target-line-block-face ((,class (:background "#CCCC00" :foreground "#222222"))))
`(helm-swoop-target-line-face ((,class (:background "#CCCCFF"))))
- `(helm-swoop-target-word-face ((,class (:weight bold :foreground nil :background "#FDBD33"))))
+ `(helm-swoop-target-word-face ((,class (:weight bold :foreground unspecified :background "#FDBD33"))))
`(helm-visible-mark ((,class ,marked-line)))
`(helm-w3m-bookmarks-face ((,class (:underline t :foreground "cyan1"))))
- `(highlight-changes ((,class (:foreground nil)))) ;; blue "#2E08B5"
- `(highlight-changes-delete ((,class (:strike-through nil :foreground nil)))) ;; red "#B5082E"
+ `(highlight-changes ((,class (:foreground unspecified)))) ;; blue "#2E08B5"
+ `(highlight-changes-delete ((,class (:strike-through nil :foreground unspecified)))) ;; red "#B5082E"
`(highlight-symbol-face ((,class (:background "#FFFFA0"))))
`(hl-line ((,class ,highlight-yellow))) ; Highlight current line.
`(hl-tags-face ((,class ,highlight-current-tag))) ; ~ Pair highlighting (matching tags).
@@ -642,7 +642,7 @@ more..."
`(info-file ((,class (:family "Sans Serif" :height 1.8 :weight bold :box (:line-width 1 :color "#0000CC") :foreground "cornflower blue" :background "LightSteelBlue1"))))
`(info-header-node ((,class (:underline t :foreground "orange")))) ; nodes in header
`(info-header-xref ((,class (:underline t :foreground "dodger blue")))) ; cross references in header
- `(info-index-match ((,class (:weight bold :foreground nil :background "#FDBD33")))) ; when using `i'
+ `(info-index-match ((,class (:weight bold :foreground unspecified :background "#FDBD33")))) ; when using `i'
`(info-menu-header ((,class ,ol2))) ; menu titles (headers) -- major topics
`(info-menu-star ((,class (:foreground "black")))) ; every 3rd menu item
`(info-node ((,class (:underline t :foreground "blue")))) ; node names
diff --git a/etc/themes/manoj-dark-theme.el b/etc/themes/manoj-dark-theme.el
index abac21e9e33..81dac1902f0 100644
--- a/etc/themes/manoj-dark-theme.el
+++ b/etc/themes/manoj-dark-theme.el
@@ -411,10 +411,10 @@ jarring angry fruit salad look to reduce eye fatigue."
'(cursor ((t (:background "orchid"))))
'(custom-button-face ((t (:background "lightgrey" :foreground "black"
- :box '(:line-width 2 :style released-button)))))
+ :box (:line-width 2 :style released-button)))))
'(custom-button-pressed-face ((t (:background "lightgrey"
:foreground "black"
- :box '(:line-width 2 :style pressed-button)))))
+ :box (:line-width 2 :style pressed-button)))))
'(custom-changed-face ((t (:foreground "wheat" :background "blue"))))
'(custom-comment-face ((t (:background "dim gray"))))
'(custom-comment-tag-face ((t (:foreground "gray80"))))
@@ -430,7 +430,7 @@ jarring angry fruit salad look to reduce eye fatigue."
'(custom-variable-button-face ((t (:bold t :underline t :weight bold
:background "lightgrey"
:foreground "black"
- :box '(:line-width 2 :style released-button)))))
+ :box (:line-width 2 :style released-button)))))
'(custom-variable-tag-face ((t (:bold t :foreground "light blue"
:weight bold :height 1.2))))
@@ -526,8 +526,8 @@ jarring angry fruit salad look to reduce eye fatigue."
'(widget-mouse-face ((t (:background "darkseagreen2" :foreground "blue"))))
'(highlight-beyond-fill-column-face ((t (:underline t))))
- '(highlight-changes ((t (:foreground nil :background "#382f2f"))))
- '(highlight-changes-delete ((t (:foreground nil :background "#916868"))))
+ '(highlight-changes ((t (:foreground unspecified :background "#382f2f"))))
+ '(highlight-changes-delete ((t (:foreground unspecified :background "#916868"))))
'(holiday ((t (:background "chocolate4"))))
'(holiday-face ((t (:background "chocolate4"))))
@@ -586,15 +586,16 @@ jarring angry fruit salad look to reduce eye fatigue."
'(match ((t (:background "RoyalBlue3"))))
'(minibuffer-prompt ((t (:foreground "cyan"))))
'(mode-line ((t (:background "grey75" :foreground "Blue"
- :box '(:line-width -1 :style released-button)
+ :box (:line-width -1 :style released-button)
:height 0.9))))
'(mode-line-buffer-id ((t (:background "grey65" :foreground "red"
:bold t :weight bold :height 0.9))))
'(mode-line-emphasis ((t (:bold t :weight bold))))
'(mode-line-highlight ((t (:box (:line-width 2 :color "grey40"
- :style released-button :height 0.9)))))
+ :style released-button)
+ :height 0.9))))
'(mode-line-inactive ((t (:background "grey30" :foreground "grey80"
- :box '(:line-width -1 :color "grey40")
+ :box (:line-width -1 :color "grey40")
:weight light :height 0.9))))
'(mouse ((t (:background "OrangeRed"))))
diff --git a/etc/themes/modus-operandi-deuteranopia-theme.el b/etc/themes/modus-operandi-deuteranopia-theme.el
new file mode 100644
index 00000000000..42479965300
--- /dev/null
+++ b/etc/themes/modus-operandi-deuteranopia-theme.el
@@ -0,0 +1,515 @@
+;;; modus-operandi-deuteranopia-theme.el --- Deuteranopia-optimized theme with a white background -*- lexical-binding:t -*-
+
+;; Copyright (C) 2019-2024 Free Software Foundation, Inc.
+
+;; Author: Protesilaos Stavrou <info@protesilaos.com>
+;; Maintainer: Protesilaos Stavrou <info@protesilaos.com>
+;; URL: https://github.com/protesilaos/modus-themes
+;; Keywords: faces, theme, accessibility
+
+;; This file is part of GNU Emacs.
+
+;; GNU Emacs is free software: you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+;;
+;; GNU Emacs is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+;;
+;; You should have received a copy of the GNU General Public License
+;; along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>.
+
+;;; Commentary:
+;;
+;; The Modus themes conform with the highest standard for
+;; color-contrast accessibility between background and foreground
+;; values (WCAG AAA). Please refer to the official Info manual for
+;; further documentation (distributed with the themes, or available
+;; at: <https://protesilaos.com/emacs/modus-themes>).
+
+;;; Code:
+
+
+
+(eval-and-compile
+ (unless (and (fboundp 'require-theme)
+ load-file-name
+ (equal (file-name-directory load-file-name)
+ (expand-file-name "themes/" data-directory))
+ (require-theme 'modus-themes t))
+ (require 'modus-themes))
+
+;;;###theme-autoload
+ (deftheme modus-operandi-deuteranopia
+ "Deuteranopia-optimized theme with a white background.
+This variant is optimized for users with red-green color
+deficiency (deuteranopia). It 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 (WCAG AAA
+standard)."
+ :background-mode 'light
+ :kind 'color-scheme
+ :family 'modus)
+
+ (defconst modus-operandi-deuteranopia-palette
+ '(
+;;; Basic values
+
+ (bg-main "#ffffff")
+ (bg-dim "#f2f2f2")
+ (fg-main "#000000")
+ (fg-dim "#595959")
+ (fg-alt "#193668")
+ (bg-active "#c4c4c4")
+ (bg-inactive "#e0e0e0")
+ (border "#9f9f9f")
+
+;;; Common accent foregrounds
+
+ (red "#a60000")
+ (red-warmer "#972500")
+ (red-cooler "#a0132f")
+ (red-faint "#7f0000")
+ (red-intense "#d00000")
+ (green "#006800")
+ (green-warmer "#316500")
+ (green-cooler "#00663f")
+ (green-faint "#2a5045")
+ (green-intense "#008900")
+ (yellow "#695500")
+ (yellow-warmer "#973300")
+ (yellow-cooler "#77492f")
+ (yellow-faint "#624416")
+ (yellow-intense "#808000")
+ (blue "#0031a9")
+ (blue-warmer "#3548cf")
+ (blue-cooler "#0000b0")
+ (blue-faint "#003497")
+ (blue-intense "#0000ff")
+ (magenta "#721045")
+ (magenta-warmer "#8f0075")
+ (magenta-cooler "#531ab6")
+ (magenta-faint "#7c318f")
+ (magenta-intense "#dd22dd")
+ (cyan "#005e8b")
+ (cyan-warmer "#3f578f")
+ (cyan-cooler "#005f5f")
+ (cyan-faint "#005077")
+ (cyan-intense "#008899")
+
+;;; Uncommon accent foregrounds
+
+ (rust "#8a290f")
+ (gold "#80601f")
+ (olive "#56692d")
+ (slate "#2f3f83")
+ (indigo "#4a3a8a")
+ (maroon "#731c52")
+ (pink "#7b435c")
+
+;;; Common accent backgrounds
+
+ (bg-red-intense "#ff8f88")
+ (bg-green-intense "#8adf80")
+ (bg-yellow-intense "#f3d000")
+ (bg-blue-intense "#bfc9ff")
+ (bg-magenta-intense "#dfa0f0")
+ (bg-cyan-intense "#a4d5f9")
+
+ (bg-red-subtle "#ffcfbf")
+ (bg-green-subtle "#b3fabf")
+ (bg-yellow-subtle "#fff576")
+ (bg-blue-subtle "#ccdfff")
+ (bg-magenta-subtle "#ffddff")
+ (bg-cyan-subtle "#bfefff")
+
+ (bg-red-nuanced "#ffe8e8")
+ (bg-green-nuanced "#e0f6e0")
+ (bg-yellow-nuanced "#f8f0d0")
+ (bg-blue-nuanced "#ecedff")
+ (bg-magenta-nuanced "#f8e6f5")
+ (bg-cyan-nuanced "#e0f2fa")
+
+;;; Uncommon accent backgrounds
+
+ (bg-ochre "#f0e0cc")
+ (bg-lavender "#dfdbfa")
+ (bg-sage "#c0e7d4")
+
+;;; Graphs
+
+ (bg-graph-red-0 "#d0b029")
+ (bg-graph-red-1 "#e0cab4")
+ (bg-graph-green-0 "#8ad080")
+ (bg-graph-green-1 "#afdfa5")
+ (bg-graph-yellow-0 "#ffcf00")
+ (bg-graph-yellow-1 "#f9ff00")
+ (bg-graph-blue-0 "#7f9fff")
+ (bg-graph-blue-1 "#9fc6ff")
+ (bg-graph-magenta-0 "#b0b0d0")
+ (bg-graph-magenta-1 "#d0dfdf")
+ (bg-graph-cyan-0 "#6faad9")
+ (bg-graph-cyan-1 "#bfe0ff")
+
+;;; Special purpose
+
+ (bg-completion "#c0deff")
+ (bg-hover "#b2e4dc")
+ (bg-hover-secondary "#f5d0a0")
+ (bg-hl-line "#dae5ec")
+ (bg-region "#bdbdbd")
+ (fg-region "#000000")
+
+ (bg-char-0 "#7feaff")
+ (bg-char-1 "#ffaaff")
+ (bg-char-2 "#dff000")
+
+ (bg-mode-line-active "#d0d6ff")
+ (fg-mode-line-active "#0f0f0f")
+ (border-mode-line-active "#4f4f74")
+ (bg-mode-line-inactive "#e6e6e6")
+ (fg-mode-line-inactive "#585858")
+ (border-mode-line-inactive "#a3a3a3")
+
+ (modeline-err "#603a00")
+ (modeline-warning "#454500")
+ (modeline-info "#023d92")
+
+ (bg-tab-bar "#dfdfdf")
+ (bg-tab-current "#ffffff")
+ (bg-tab-other "#c2c2c2")
+
+;;; Diffs
+
+ (bg-added "#d5d7ff")
+ (bg-added-faint "#e6e6ff")
+ (bg-added-refine "#babcef")
+ (bg-added-fringe "#275acc")
+ (fg-added "#303099")
+ (fg-added-intense "#0303cc")
+
+ (bg-changed "#eecfdf")
+ (bg-changed-faint "#f0dde5")
+ (bg-changed-refine "#e0b0d0")
+ (bg-changed-fringe "#9f6ab0")
+ (fg-changed "#6f1343")
+ (fg-changed-intense "#7f0f9f")
+
+ (bg-removed "#f4f099")
+ (bg-removed-faint "#f6f6b7")
+ (bg-removed-refine "#ede06f")
+ (bg-removed-fringe "#c0b200")
+ (fg-removed "#553d00")
+ (fg-removed-intense "#7f6f00")
+
+ (bg-diff-context "#f3f3f3")
+
+;;; Paren match
+
+ (bg-paren-match "#5fcfff")
+ (fg-paren-match fg-main)
+ (bg-paren-expression "#efd3f5")
+ (underline-paren-match unspecified)
+
+;;; Mappings
+
+;;;; General mappings
+
+ (fringe bg-dim)
+ (cursor blue-intense)
+
+ (keybind blue-cooler)
+ (name blue-cooler)
+ (identifier yellow-faint)
+
+ (err yellow-warmer)
+ (warning yellow)
+ (info blue)
+
+ (underline-err yellow-intense)
+ (underline-warning magenta-faint)
+ (underline-note cyan)
+
+ (bg-prominent-err bg-yellow-intense)
+ (fg-prominent-err fg-main)
+ (bg-prominent-warning bg-magenta-intense)
+ (fg-prominent-warning fg-main)
+ (bg-prominent-note bg-cyan-intense)
+ (fg-prominent-note fg-main)
+
+ (bg-active-argument bg-yellow-nuanced)
+ (fg-active-argument yellow-warmer)
+ (bg-active-value bg-blue-nuanced)
+ (fg-active-value blue-warmer)
+
+;;;; Code mappings
+
+ (builtin magenta-warmer)
+ (comment yellow-cooler)
+ (constant blue-cooler)
+ (docstring green-faint)
+ (docmarkup magenta-faint)
+ (fnname magenta)
+ (keyword magenta-cooler)
+ (preprocessor red-cooler)
+ (string blue-warmer)
+ (type cyan-cooler)
+ (variable cyan)
+ (rx-construct yellow-cooler)
+ (rx-backslash blue-cooler)
+
+;;;; Accent mappings
+
+ (accent-0 blue)
+ (accent-1 yellow-warmer)
+ (accent-2 cyan)
+ (accent-3 magenta-cooler)
+
+;;;; Button mappings
+
+ (fg-button-active fg-main)
+ (fg-button-inactive fg-dim)
+ (bg-button-active bg-active)
+ (bg-button-inactive bg-dim)
+
+;;;; Completion mappings
+
+ (fg-completion-match-0 blue)
+ (fg-completion-match-1 yellow-warmer)
+ (fg-completion-match-2 cyan)
+ (fg-completion-match-3 magenta-cooler)
+ (bg-completion-match-0 unspecified)
+ (bg-completion-match-1 unspecified)
+ (bg-completion-match-2 unspecified)
+ (bg-completion-match-3 unspecified)
+
+;;;; Date mappings
+
+ (date-common cyan)
+ (date-deadline yellow-warmer)
+ (date-event fg-alt)
+ (date-holiday yellow-warmer)
+ (date-holiday-other blue)
+ (date-now fg-main)
+ (date-range fg-alt)
+ (date-scheduled yellow-cooler)
+ (date-weekday cyan)
+ (date-weekend yellow-faint)
+
+;;;; Line number mappings
+
+ (fg-line-number-inactive fg-dim)
+ (fg-line-number-active fg-main)
+ (bg-line-number-inactive bg-dim)
+ (bg-line-number-active bg-active)
+
+;;;; Link mappings
+
+ (fg-link blue-warmer)
+ (bg-link unspecified)
+ (underline-link blue-warmer)
+
+ (fg-link-symbolic cyan)
+ (bg-link-symbolic unspecified)
+ (underline-link-symbolic cyan)
+
+ (fg-link-visited yellow-faint)
+ (bg-link-visited unspecified)
+ (underline-link-visited yellow-faint)
+
+;;;; Mail mappings
+
+ (mail-cite-0 blue-warmer)
+ (mail-cite-1 yellow)
+ (mail-cite-2 cyan-faint)
+ (mail-cite-3 yellow-faint)
+ (mail-part blue)
+ (mail-recipient blue)
+ (mail-subject yellow-cooler)
+ (mail-other cyan-faint)
+
+;;;; Mark mappings
+
+ (bg-mark-delete bg-yellow-subtle)
+ (fg-mark-delete yellow)
+ (bg-mark-select bg-cyan-subtle)
+ (fg-mark-select cyan)
+ (bg-mark-other bg-magenta-subtle)
+ (fg-mark-other magenta)
+
+;;;; Prompt mappings
+
+ (fg-prompt blue)
+ (bg-prompt unspecified)
+
+;;;; Prose mappings
+
+ (bg-prose-block-delimiter bg-dim)
+ (fg-prose-block-delimiter fg-dim)
+ (bg-prose-block-contents bg-dim)
+
+ (bg-prose-code unspecified)
+ (fg-prose-code cyan-cooler)
+
+ (bg-prose-macro unspecified)
+ (fg-prose-macro magenta-cooler)
+
+ (bg-prose-verbatim unspecified)
+ (fg-prose-verbatim magenta-warmer)
+
+ (prose-done blue)
+ (prose-todo yellow-warmer)
+
+ (prose-metadata fg-dim)
+ (prose-metadata-value fg-alt)
+
+ (prose-table fg-alt)
+ (prose-table-formula yellow-warmer)
+
+ (prose-tag magenta-faint)
+
+;;;; Rainbow mappings
+
+ (rainbow-0 blue)
+ (rainbow-1 yellow)
+ (rainbow-2 blue-warmer)
+ (rainbow-3 yellow-cooler)
+ (rainbow-4 blue-cooler)
+ (rainbow-5 yellow-warmer)
+ (rainbow-6 blue-faint)
+ (rainbow-7 yellow-faint)
+ (rainbow-8 cyan)
+
+;;;; Search mappings
+
+ (bg-search-current bg-yellow-intense)
+ (bg-search-lazy bg-blue-intense)
+ (bg-search-replace bg-magenta-intense)
+
+ (bg-search-rx-group-0 bg-cyan-intense)
+ (bg-search-rx-group-1 bg-magenta-intense)
+ (bg-search-rx-group-2 bg-blue-subtle)
+ (bg-search-rx-group-3 bg-yellow-subtle)
+
+;;;; Space mappings
+
+ (bg-space unspecified)
+ (fg-space border)
+ (bg-space-err bg-yellow-intense)
+
+;;;; Terminal mappings
+
+ (bg-term-black "#000000")
+ (fg-term-black "#000000")
+ (bg-term-black-bright "#595959")
+ (fg-term-black-bright "#595959")
+
+ (bg-term-red red)
+ (fg-term-red red)
+ (bg-term-red-bright red-warmer)
+ (fg-term-red-bright red-warmer)
+
+ (bg-term-green green)
+ (fg-term-green green)
+ (bg-term-green-bright green-cooler)
+ (fg-term-green-bright green-cooler)
+
+ (bg-term-yellow yellow)
+ (fg-term-yellow yellow)
+ (bg-term-yellow-bright yellow-warmer)
+ (fg-term-yellow-bright yellow-warmer)
+
+ (bg-term-blue blue)
+ (fg-term-blue blue)
+ (bg-term-blue-bright blue-warmer)
+ (fg-term-blue-bright blue-warmer)
+
+ (bg-term-magenta magenta)
+ (fg-term-magenta magenta)
+ (bg-term-magenta-bright magenta-cooler)
+ (fg-term-magenta-bright magenta-cooler)
+
+ (bg-term-cyan cyan)
+ (fg-term-cyan cyan)
+ (bg-term-cyan-bright cyan-cooler)
+ (fg-term-cyan-bright cyan-cooler)
+
+ (bg-term-white "#a6a6a6")
+ (fg-term-white "#a6a6a6")
+ (bg-term-white-bright "#ffffff")
+ (fg-term-white-bright "#ffffff")
+
+;;;; Heading mappings
+
+ (fg-heading-0 cyan-cooler)
+ (fg-heading-1 fg-main)
+ (fg-heading-2 yellow-faint)
+ (fg-heading-3 fg-alt)
+ (fg-heading-4 magenta)
+ (fg-heading-5 green-faint)
+ (fg-heading-6 red-faint)
+ (fg-heading-7 cyan-warmer)
+ (fg-heading-8 fg-dim)
+
+ (bg-heading-0 unspecified)
+ (bg-heading-1 unspecified)
+ (bg-heading-2 unspecified)
+ (bg-heading-3 unspecified)
+ (bg-heading-4 unspecified)
+ (bg-heading-5 unspecified)
+ (bg-heading-6 unspecified)
+ (bg-heading-7 unspecified)
+ (bg-heading-8 unspecified)
+
+ (overline-heading-0 unspecified)
+ (overline-heading-1 unspecified)
+ (overline-heading-2 unspecified)
+ (overline-heading-3 unspecified)
+ (overline-heading-4 unspecified)
+ (overline-heading-5 unspecified)
+ (overline-heading-6 unspecified)
+ (overline-heading-7 unspecified)
+ (overline-heading-8 unspecified))
+ "The entire palette of the `modus-operandi-deuteranopia' theme.
+
+Named colors have the form (COLOR-NAME HEX-VALUE) with the former
+as a symbol and the latter as a string.
+
+Semantic color mappings have the form (MAPPING-NAME COLOR-NAME)
+with both as symbols. The latter is a named color that already
+exists in the palette and is associated with a HEX-VALUE.")
+
+ (defcustom modus-operandi-deuteranopia-palette-overrides nil
+ "Overrides for `modus-operandi-deuteranopia-palette'.
+
+Mirror the elements of the aforementioned palette, overriding
+their value.
+
+For overrides that are shared across all of the Modus themes,
+refer to `modus-themes-common-palette-overrides'.
+
+Theme-specific overrides take precedence over shared overrides.
+The idea of common overrides is to change semantic color
+mappings, such as to make the cursor red. Wherea theme-specific
+overrides can also be used to change the value of a named color,
+such as what hexadecimal RGB value the red-warmer symbol
+represents."
+ :group 'modus-themes
+ :package-version '(modus-themes . "4.0.0")
+ :version "30.1"
+ :type '(repeat (list symbol (choice symbol string)))
+ :set #'modus-themes--set-option
+ :initialize #'custom-initialize-default
+ :link '(info-link "(modus-themes) Palette overrides"))
+
+ (modus-themes-theme modus-operandi-deuteranopia
+ modus-operandi-deuteranopia-palette
+ modus-operandi-deuteranopia-palette-overrides)
+
+ (provide-theme 'modus-operandi-deuteranopia))
+
+;;; modus-operandi-deuteranopia-theme.el ends here
diff --git a/etc/themes/modus-operandi-theme.el b/etc/themes/modus-operandi-theme.el
index c18e1521013..fb2ff99a74b 100644
--- a/etc/themes/modus-operandi-theme.el
+++ b/etc/themes/modus-operandi-theme.el
@@ -1,13 +1,10 @@
-;;; modus-operandi-theme.el --- Elegant, highly legible and customizable light theme -*- lexical-binding:t -*-
+;;; modus-operandi-theme.el --- Elegant, highly legible theme with a white background -*- lexical-binding:t -*-
-;; Copyright (C) 2019-2024 Free Software Foundation, Inc.
+;; Copyright (C) 2019-2024 Free Software Foundation, Inc.
;; Author: Protesilaos Stavrou <info@protesilaos.com>
-;; Maintainer: Modus-Themes Development <~protesilaos/modus-themes@lists.sr.ht>
-;; URL: https://git.sr.ht/~protesilaos/modus-themes
-;; Mailing-List: https://lists.sr.ht/~protesilaos/modus-themes
-;; Version: 3.0.0
-;; Package-Requires: ((emacs "27.1"))
+;; Maintainer: Protesilaos Stavrou <info@protesilaos.com>
+;; URL: https://github.com/protesilaos/modus-themes
;; Keywords: faces, theme, accessibility
;; This file is part of GNU Emacs.
@@ -27,26 +24,11 @@
;;; Commentary:
;;
-;; Modus Operandi is the light variant of the Modus themes (Modus
-;; Vivendi is the dark one). The themes are designed for color-contrast
-;; accessibility. More specifically:
-;;
-;; 1. Provide a consistent minimum contrast ratio between background
-;; and foreground values of 7:1 or higher. This meets the highest
-;; such accessibility criterion per the guidelines of the Worldwide
-;; Web Consortium's Working Group on Accessibility (WCAG AAA
-;; standard).
-;;
-;; 2. Offer as close to full face coverage as possible. The list is
-;; already quite long, with more additions to follow as part of the
-;; ongoing development process.
-;;
-;; For a complete view of the project, also refer to the following files
-;; (should be distributed in the same repository/directory as the
-;; current item):
-;;
-;; - modus-themes.el (Main code shared between the themes)
-;; - modus-vivendi-theme.el (Dark theme)
+;; The Modus themes conform with the highest standard for
+;; color-contrast accessibility between background and foreground
+;; values (WCAG AAA). Please refer to the official Info manual for
+;; further documentation (distributed with the themes, or available
+;; at: <https://protesilaos.com/emacs/modus-themes>).
;;; Code:
@@ -60,18 +42,472 @@
(require-theme 'modus-themes t))
(require 'modus-themes))
+;;;###theme-autoload
(deftheme modus-operandi
- "Elegant, highly legible and customizable light theme.
+ "Elegant, highly legible theme with a white background.
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 (WCAG AAA standard).")
+7:1 (WCAG AAA standard)."
+ :background-mode 'light
+ :kind 'color-scheme
+ :family 'modus)
- (modus-themes-theme modus-operandi)
+ (defconst modus-operandi-palette
+ '(
+;;; Basic values
- (provide-theme 'modus-operandi))
+ (bg-main "#ffffff")
+ (bg-dim "#f2f2f2")
+ (fg-main "#000000")
+ (fg-dim "#595959")
+ (fg-alt "#193668")
+ (bg-active "#c4c4c4")
+ (bg-inactive "#e0e0e0")
+ (border "#9f9f9f")
-;;;###theme-autoload
-(put 'modus-operandi 'theme-properties '(:background-mode light :kind color-scheme :family modus))
+;;; Common accent foregrounds
+
+ (red "#a60000")
+ (red-warmer "#972500")
+ (red-cooler "#a0132f")
+ (red-faint "#7f0000")
+ (red-intense "#d00000")
+ (green "#006800")
+ (green-warmer "#316500")
+ (green-cooler "#00663f")
+ (green-faint "#2a5045")
+ (green-intense "#008900")
+ (yellow "#6f5500")
+ (yellow-warmer "#884900")
+ (yellow-cooler "#7a4f2f")
+ (yellow-faint "#624416")
+ (yellow-intense "#808000")
+ (blue "#0031a9")
+ (blue-warmer "#3548cf")
+ (blue-cooler "#0000b0")
+ (blue-faint "#003497")
+ (blue-intense "#0000ff")
+ (magenta "#721045")
+ (magenta-warmer "#8f0075")
+ (magenta-cooler "#531ab6")
+ (magenta-faint "#7c318f")
+ (magenta-intense "#dd22dd")
+ (cyan "#005e8b")
+ (cyan-warmer "#3f578f")
+ (cyan-cooler "#005f5f")
+ (cyan-faint "#005077")
+ (cyan-intense "#008899")
+
+;;; Uncommon accent foregrounds
+
+ (rust "#8a290f")
+ (gold "#80601f")
+ (olive "#56692d")
+ (slate "#2f3f83")
+ (indigo "#4a3a8a")
+ (maroon "#731c52")
+ (pink "#7b435c")
+
+;;; Common accent backgrounds
+
+ (bg-red-intense "#ff8f88")
+ (bg-green-intense "#8adf80")
+ (bg-yellow-intense "#f3d000")
+ (bg-blue-intense "#bfc9ff")
+ (bg-magenta-intense "#dfa0f0")
+ (bg-cyan-intense "#a4d5f9")
+
+ (bg-red-subtle "#ffcfbf")
+ (bg-green-subtle "#b3fabf")
+ (bg-yellow-subtle "#fff576")
+ (bg-blue-subtle "#ccdfff")
+ (bg-magenta-subtle "#ffddff")
+ (bg-cyan-subtle "#bfefff")
+
+ (bg-red-nuanced "#ffe8e8")
+ (bg-green-nuanced "#e0f6e0")
+ (bg-yellow-nuanced "#f8f0d0")
+ (bg-blue-nuanced "#ecedff")
+ (bg-magenta-nuanced "#f8e6f5")
+ (bg-cyan-nuanced "#e0f2fa")
+
+;;; Uncommon accent backgrounds
+
+ (bg-ochre "#f0e0cc")
+ (bg-lavender "#dfdbfa")
+ (bg-sage "#c0e7d4")
+
+;;; Graphs
+
+ (bg-graph-red-0 "#ef7969")
+ (bg-graph-red-1 "#ffaab4")
+ (bg-graph-green-0 "#2fe029")
+ (bg-graph-green-1 "#75ef30")
+ (bg-graph-yellow-0 "#ffcf00")
+ (bg-graph-yellow-1 "#f9ff00")
+ (bg-graph-blue-0 "#7f90ff")
+ (bg-graph-blue-1 "#9fc6ff")
+ (bg-graph-magenta-0 "#e07fff")
+ (bg-graph-magenta-1 "#fad0ff")
+ (bg-graph-cyan-0 "#70d3f0")
+ (bg-graph-cyan-1 "#afefff")
+
+;;; Special purpose
+
+ (bg-completion "#c0deff")
+ (bg-hover "#b2e4dc")
+ (bg-hover-secondary "#f5d0a0")
+ (bg-hl-line "#dae5ec")
+ (bg-region "#bdbdbd")
+ (fg-region "#000000")
+
+ (bg-char-0 "#7feaff")
+ (bg-char-1 "#ffaaff")
+ (bg-char-2 "#dff000")
+
+ (bg-mode-line-active "#c8c8c8")
+ (fg-mode-line-active "#000000")
+ (border-mode-line-active "#5a5a5a")
+ (bg-mode-line-inactive "#e6e6e6")
+ (fg-mode-line-inactive "#585858")
+ (border-mode-line-inactive "#a3a3a3")
+
+ (modeline-err "#7f0000")
+ (modeline-warning "#5f0070")
+ (modeline-info "#002580")
+
+ (bg-tab-bar "#dfdfdf")
+ (bg-tab-current "#ffffff")
+ (bg-tab-other "#c2c2c2")
+
+;;; Diffs
+
+ (bg-added "#c1f2d1")
+ (bg-added-faint "#d8f8e1")
+ (bg-added-refine "#aee5be")
+ (bg-added-fringe "#6cc06c")
+ (fg-added "#005000")
+ (fg-added-intense "#006700")
+
+ (bg-changed "#ffdfa9")
+ (bg-changed-faint "#ffefbf")
+ (bg-changed-refine "#fac090")
+ (bg-changed-fringe "#d7c20a")
+ (fg-changed "#553d00")
+ (fg-changed-intense "#655000")
+
+ (bg-removed "#ffd8d5")
+ (bg-removed-faint "#ffe9e9")
+ (bg-removed-refine "#f3b5af")
+ (bg-removed-fringe "#d84a4f")
+ (fg-removed "#8f1313")
+ (fg-removed-intense "#aa2222")
+
+ (bg-diff-context "#f3f3f3")
+
+;;; Paren match
+
+ (bg-paren-match "#5fcfff")
+ (fg-paren-match fg-main)
+ (bg-paren-expression "#efd3f5")
+ (underline-paren-match unspecified)
+
+;;; Mappings
+
+;;;; General mappings
+
+ (fringe bg-dim)
+ (cursor fg-main)
+
+ (keybind blue-cooler)
+ (name magenta)
+ (identifier yellow-cooler)
+
+ (err red)
+ (warning yellow-warmer)
+ (info cyan-cooler)
+
+ (underline-err red-intense)
+ (underline-warning yellow-intense)
+ (underline-note cyan-intense)
+
+ (bg-prominent-err bg-red-intense)
+ (fg-prominent-err fg-main)
+ (bg-prominent-warning bg-yellow-intense)
+ (fg-prominent-warning fg-main)
+ (bg-prominent-note bg-cyan-intense)
+ (fg-prominent-note fg-main)
+
+ (bg-active-argument bg-yellow-nuanced)
+ (fg-active-argument yellow-warmer)
+ (bg-active-value bg-cyan-nuanced)
+ (fg-active-value cyan-warmer)
+
+;;;; Code mappings
+
+ (builtin magenta-warmer)
+ (comment fg-dim)
+ (constant blue-cooler)
+ (docstring green-faint)
+ (docmarkup magenta-faint)
+ (fnname magenta)
+ (keyword magenta-cooler)
+ (preprocessor red-cooler)
+ (string blue-warmer)
+ (type cyan-cooler)
+ (variable cyan)
+ (rx-construct green-cooler)
+ (rx-backslash magenta)
+
+;;;; Accent mappings
+
+ (accent-0 blue)
+ (accent-1 magenta-warmer)
+ (accent-2 cyan)
+ (accent-3 red)
+
+;;;; Button mappings
+
+ (fg-button-active fg-main)
+ (fg-button-inactive fg-dim)
+ (bg-button-active bg-active)
+ (bg-button-inactive bg-dim)
+
+;;;; Completion mappings
+
+ (fg-completion-match-0 blue)
+ (fg-completion-match-1 magenta-warmer)
+ (fg-completion-match-2 cyan)
+ (fg-completion-match-3 red)
+ (bg-completion-match-0 unspecified)
+ (bg-completion-match-1 unspecified)
+ (bg-completion-match-2 unspecified)
+ (bg-completion-match-3 unspecified)
+
+;;;; Date mappings
+
+ (date-common cyan)
+ (date-deadline red)
+ (date-event fg-alt)
+ (date-holiday red-cooler)
+ (date-holiday-other blue)
+ (date-now fg-main)
+ (date-range fg-alt)
+ (date-scheduled yellow-warmer)
+ (date-weekday cyan)
+ (date-weekend red-faint)
+
+;;;; Line number mappings
+
+ (fg-line-number-inactive fg-dim)
+ (fg-line-number-active fg-main)
+ (bg-line-number-inactive bg-dim)
+ (bg-line-number-active bg-active)
+
+;;;; Link mappings
+
+ (fg-link blue-warmer)
+ (bg-link unspecified)
+ (underline-link blue-warmer)
+
+ (fg-link-symbolic cyan)
+ (bg-link-symbolic unspecified)
+ (underline-link-symbolic cyan)
+
+ (fg-link-visited magenta)
+ (bg-link-visited unspecified)
+ (underline-link-visited magenta)
+
+;;;; Mail mappings
+
+ (mail-cite-0 blue-faint)
+ (mail-cite-1 yellow-warmer)
+ (mail-cite-2 cyan-cooler)
+ (mail-cite-3 red-cooler)
+ (mail-part cyan)
+ (mail-recipient magenta-cooler)
+ (mail-subject magenta-warmer)
+ (mail-other magenta-faint)
+
+;;;; Mark mappings
+
+ (bg-mark-delete bg-red-subtle)
+ (fg-mark-delete red)
+ (bg-mark-select bg-cyan-subtle)
+ (fg-mark-select cyan)
+ (bg-mark-other bg-yellow-subtle)
+ (fg-mark-other yellow)
+
+;;;; Prompt mappings
+
+ (fg-prompt cyan-cooler)
+ (bg-prompt unspecified)
+
+;;;; Prose mappings
+
+ (bg-prose-block-delimiter bg-dim)
+ (fg-prose-block-delimiter fg-dim)
+ (bg-prose-block-contents bg-dim)
+
+ (bg-prose-code unspecified)
+ (fg-prose-code cyan-cooler)
+
+ (bg-prose-macro unspecified)
+ (fg-prose-macro magenta-cooler)
+
+ (bg-prose-verbatim unspecified)
+ (fg-prose-verbatim magenta-warmer)
+
+ (prose-done green)
+ (prose-todo red)
+
+ (prose-metadata fg-dim)
+ (prose-metadata-value fg-alt)
+
+ (prose-table fg-alt)
+ (prose-table-formula magenta-warmer)
+
+ (prose-tag magenta-faint)
+
+;;;; Rainbow mappings
+
+ (rainbow-0 fg-main)
+ (rainbow-1 magenta-intense)
+ (rainbow-2 cyan-intense)
+ (rainbow-3 red-warmer)
+ (rainbow-4 yellow-intense)
+ (rainbow-5 magenta-cooler)
+ (rainbow-6 green-intense)
+ (rainbow-7 blue-warmer)
+ (rainbow-8 magenta-warmer)
+
+;;;; Search mappings
+
+ (bg-search-current bg-yellow-intense)
+ (bg-search-lazy bg-cyan-intense)
+ (bg-search-replace bg-red-intense)
+
+ (bg-search-rx-group-0 bg-blue-intense)
+ (bg-search-rx-group-1 bg-green-intense)
+ (bg-search-rx-group-2 bg-red-subtle)
+ (bg-search-rx-group-3 bg-magenta-subtle)
+
+;;;; Space mappings
+
+ (bg-space unspecified)
+ (fg-space border)
+ (bg-space-err bg-red-intense)
+
+;;;; Terminal mappings
+
+ (bg-term-black "#000000")
+ (fg-term-black "#000000")
+ (bg-term-black-bright "#595959")
+ (fg-term-black-bright "#595959")
+
+ (bg-term-red red)
+ (fg-term-red red)
+ (bg-term-red-bright red-warmer)
+ (fg-term-red-bright red-warmer)
+
+ (bg-term-green green)
+ (fg-term-green green)
+ (bg-term-green-bright green-cooler)
+ (fg-term-green-bright green-cooler)
+
+ (bg-term-yellow yellow)
+ (fg-term-yellow yellow)
+ (bg-term-yellow-bright yellow-warmer)
+ (fg-term-yellow-bright yellow-warmer)
+
+ (bg-term-blue blue)
+ (fg-term-blue blue)
+ (bg-term-blue-bright blue-warmer)
+ (fg-term-blue-bright blue-warmer)
+
+ (bg-term-magenta magenta)
+ (fg-term-magenta magenta)
+ (bg-term-magenta-bright magenta-cooler)
+ (fg-term-magenta-bright magenta-cooler)
+
+ (bg-term-cyan cyan)
+ (fg-term-cyan cyan)
+ (bg-term-cyan-bright cyan-cooler)
+ (fg-term-cyan-bright cyan-cooler)
+
+ (bg-term-white "#a6a6a6")
+ (fg-term-white "#a6a6a6")
+ (bg-term-white-bright "#ffffff")
+ (fg-term-white-bright "#ffffff")
+
+;;;; Heading mappings
+
+ (fg-heading-0 cyan-cooler)
+ (fg-heading-1 fg-main)
+ (fg-heading-2 yellow-faint)
+ (fg-heading-3 fg-alt)
+ (fg-heading-4 magenta)
+ (fg-heading-5 green-faint)
+ (fg-heading-6 red-faint)
+ (fg-heading-7 cyan-warmer)
+ (fg-heading-8 fg-dim)
+
+ (bg-heading-0 unspecified)
+ (bg-heading-1 unspecified)
+ (bg-heading-2 unspecified)
+ (bg-heading-3 unspecified)
+ (bg-heading-4 unspecified)
+ (bg-heading-5 unspecified)
+ (bg-heading-6 unspecified)
+ (bg-heading-7 unspecified)
+ (bg-heading-8 unspecified)
+
+ (overline-heading-0 unspecified)
+ (overline-heading-1 unspecified)
+ (overline-heading-2 unspecified)
+ (overline-heading-3 unspecified)
+ (overline-heading-4 unspecified)
+ (overline-heading-5 unspecified)
+ (overline-heading-6 unspecified)
+ (overline-heading-7 unspecified)
+ (overline-heading-8 unspecified))
+ "The entire palette of the `modus-operandi' theme.
+
+Named colors have the form (COLOR-NAME HEX-VALUE) with the former
+as a symbol and the latter as a string.
+
+Semantic color mappings have the form (MAPPING-NAME COLOR-NAME)
+with both as symbols. The latter is a named color that already
+exists in the palette and is associated with a HEX-VALUE.")
+
+ (defcustom modus-operandi-palette-overrides nil
+ "Overrides for `modus-operandi-palette'.
+
+Mirror the elements of the aforementioned palette, overriding
+their value.
+
+For overrides that are shared across all of the Modus themes,
+refer to `modus-themes-common-palette-overrides'.
+
+Theme-specific overrides take precedence over shared overrides.
+The idea of common overrides is to change semantic color
+mappings, such as to make the cursor red. Wherea theme-specific
+overrides can also be used to change the value of a named color,
+such as what hexadecimal RGB value the red-warmer symbol
+represents."
+ :group 'modus-themes
+ :package-version '(modus-themes . "4.0.0")
+ :version "30.1"
+ :type '(repeat (list symbol (choice symbol string)))
+ :set #'modus-themes--set-option
+ :initialize #'custom-initialize-default
+ :link '(info-link "(modus-themes) Palette overrides"))
+
+ (modus-themes-theme modus-operandi
+ modus-operandi-palette
+ modus-operandi-palette-overrides)
+
+ (provide-theme 'modus-operandi))
;;; modus-operandi-theme.el ends here
diff --git a/etc/themes/modus-operandi-tinted-theme.el b/etc/themes/modus-operandi-tinted-theme.el
new file mode 100644
index 00000000000..f112456034b
--- /dev/null
+++ b/etc/themes/modus-operandi-tinted-theme.el
@@ -0,0 +1,513 @@
+;;; modus-operandi-tinted-theme.el --- Elegant, highly legible theme with a light ochre background -*- lexical-binding:t -*-
+
+;; Copyright (C) 2019-2024 Free Software Foundation, Inc.
+
+;; Author: Protesilaos Stavrou <info@protesilaos.com>
+;; Maintainer: Protesilaos Stavrou <info@protesilaos.com>
+;; URL: https://github.com/protesilaos/modus-themes
+;; Keywords: faces, theme, accessibility
+
+;; This file is part of GNU Emacs.
+
+;; GNU Emacs is free software: you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+;;
+;; GNU Emacs is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+;;
+;; You should have received a copy of the GNU General Public License
+;; along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>.
+
+;;; Commentary:
+;;
+;; The Modus themes conform with the highest standard for
+;; color-contrast accessibility between background and foreground
+;; values (WCAG AAA). Please refer to the official Info manual for
+;; further documentation (distributed with the themes, or available
+;; at: <https://protesilaos.com/emacs/modus-themes>).
+
+;;; Code:
+
+
+
+(eval-and-compile
+ (unless (and (fboundp 'require-theme)
+ load-file-name
+ (equal (file-name-directory load-file-name)
+ (expand-file-name "themes/" data-directory))
+ (require-theme 'modus-themes t))
+ (require 'modus-themes))
+
+;;;###theme-autoload
+ (deftheme modus-operandi-tinted
+ "Elegant, highly legible theme with a light ochre background.
+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 (WCAG AAA standard)."
+ :background-mode 'light
+ :kind 'color-scheme
+ :family 'modus)
+
+ (defconst modus-operandi-tinted-palette
+ '(
+;;; Basic values
+
+ (bg-main "#fbf7f0")
+ (bg-dim "#efe9dd")
+ (fg-main "#000000")
+ (fg-dim "#595959")
+ (fg-alt "#193668")
+ (bg-active "#c9b9b0")
+ (bg-inactive "#dfd5cf")
+ (border "#9f9690")
+
+;;; Common accent foregrounds
+
+ (red "#a60000")
+ (red-warmer "#972500")
+ (red-cooler "#a0132f")
+ (red-faint "#7f0000")
+ (red-intense "#d00000")
+ (green "#006800")
+ (green-warmer "#316500")
+ (green-cooler "#00663f")
+ (green-faint "#2a5045")
+ (green-intense "#008900")
+ (yellow "#6f5500")
+ (yellow-warmer "#884900")
+ (yellow-cooler "#7a4f2f")
+ (yellow-faint "#624416")
+ (yellow-intense "#808000")
+ (blue "#0031a9")
+ (blue-warmer "#3548cf")
+ (blue-cooler "#0000b0")
+ (blue-faint "#003497")
+ (blue-intense "#0000ff")
+ (magenta "#721045")
+ (magenta-warmer "#8f0075")
+ (magenta-cooler "#531ab6")
+ (magenta-faint "#7c318f")
+ (magenta-intense "#dd22dd")
+ (cyan "#005e8b")
+ (cyan-warmer "#3f578f")
+ (cyan-cooler "#005f5f")
+ (cyan-faint "#005077")
+ (cyan-intense "#008899")
+
+;;; Uncommon accent foregrounds
+
+ (rust "#8a290f")
+ (gold "#80601f")
+ (olive "#56692d")
+ (slate "#2f3f83")
+ (indigo "#4a3a8a")
+ (maroon "#731c52")
+ (pink "#7b435c")
+
+;;; Common accent backgrounds
+
+ (bg-red-intense "#ff8f88")
+ (bg-green-intense "#8adf80")
+ (bg-yellow-intense "#f3d000")
+ (bg-blue-intense "#bfc9ff")
+ (bg-magenta-intense "#dfa0f0")
+ (bg-cyan-intense "#a4d5f9")
+
+ (bg-red-subtle "#ffcfbf")
+ (bg-green-subtle "#b3fabf")
+ (bg-yellow-subtle "#fff576")
+ (bg-blue-subtle "#ccdfff")
+ (bg-magenta-subtle "#ffddff")
+ (bg-cyan-subtle "#bfefff")
+
+ (bg-red-nuanced "#ffe8e8")
+ (bg-green-nuanced "#e0f6e0")
+ (bg-yellow-nuanced "#f8f0d0")
+ (bg-blue-nuanced "#ecedff")
+ (bg-magenta-nuanced "#f8e6f5")
+ (bg-cyan-nuanced "#e0f2fa")
+
+;;; Uncommon accent backgrounds
+
+ (bg-ochre "#f0e0cc")
+ (bg-lavender "#dfdbfa")
+ (bg-sage "#c0e7d4")
+
+;;; Graphs
+
+ (bg-graph-red-0 "#ef7969")
+ (bg-graph-red-1 "#ffaab4")
+ (bg-graph-green-0 "#2fe029")
+ (bg-graph-green-1 "#75ef30")
+ (bg-graph-yellow-0 "#ffcf00")
+ (bg-graph-yellow-1 "#f9ff00")
+ (bg-graph-blue-0 "#7f90ff")
+ (bg-graph-blue-1 "#9fc6ff")
+ (bg-graph-magenta-0 "#e07fff")
+ (bg-graph-magenta-1 "#fad0ff")
+ (bg-graph-cyan-0 "#70d3f0")
+ (bg-graph-cyan-1 "#afefff")
+
+;;; Special purpose
+
+ (bg-completion "#f0c1cf")
+ (bg-hover "#b2e4dc")
+ (bg-hover-secondary "#f5d0a0")
+ (bg-hl-line "#f1d5d0")
+ (bg-region "#c2bcb5")
+ (fg-region "#000000")
+
+ (bg-char-0 "#7feaff")
+ (bg-char-1 "#ffaaff")
+ (bg-char-2 "#dff000")
+
+ (bg-mode-line-active "#cab9b2")
+ (fg-mode-line-active "#000000")
+ (border-mode-line-active "#545454")
+ (bg-mode-line-inactive "#dfd9cf")
+ (fg-mode-line-inactive "#585858")
+ (border-mode-line-inactive "#a59a94")
+
+ (modeline-err "#7f0000")
+ (modeline-warning "#5f0070")
+ (modeline-info "#002580")
+
+ (bg-tab-bar "#e0d4ce")
+ (bg-tab-current "#fbf7f0")
+ (bg-tab-other "#c8b8b2")
+
+;;; Diffs
+
+ (bg-added "#c3ebc1")
+ (bg-added-faint "#dcf8d1")
+ (bg-added-refine "#acd6a5")
+ (bg-added-fringe "#6cc06c")
+ (fg-added "#005000")
+ (fg-added-intense "#006700")
+
+ (bg-changed "#ffdfa9")
+ (bg-changed-faint "#ffefbf")
+ (bg-changed-refine "#fac090")
+ (bg-changed-fringe "#c0b200")
+ (fg-changed "#553d00")
+ (fg-changed-intense "#655000")
+
+ (bg-removed "#f4d0cf")
+ (bg-removed-faint "#ffe9e5")
+ (bg-removed-refine "#f3b5a7")
+ (bg-removed-fringe "#d84a4f")
+ (fg-removed "#8f1313")
+ (fg-removed-intense "#aa2222")
+
+ (bg-diff-context "#efe9df")
+
+;;; Paren match
+
+ (bg-paren-match "#7fdfcf")
+ (fg-paren-match fg-main)
+ (bg-paren-expression "#efd3f5")
+ (underline-paren-match unspecified)
+
+;;; Mappings
+
+;;;; General mappings
+
+ (fringe bg-dim)
+ (cursor red-intense)
+
+ (keybind red)
+ (name magenta)
+ (identifier yellow-cooler)
+
+ (err red)
+ (warning yellow-warmer)
+ (info cyan-cooler)
+
+ (underline-err red-intense)
+ (underline-warning yellow-intense)
+ (underline-note cyan-intense)
+
+ (bg-prominent-err bg-red-intense)
+ (fg-prominent-err fg-main)
+ (bg-prominent-warning bg-yellow-intense)
+ (fg-prominent-warning fg-main)
+ (bg-prominent-note bg-cyan-intense)
+ (fg-prominent-note fg-main)
+
+ (bg-active-argument bg-yellow-nuanced)
+ (fg-active-argument yellow-warmer)
+ (bg-active-value bg-cyan-nuanced)
+ (fg-active-value cyan-warmer)
+
+;;;; Code mappings
+
+ (builtin magenta-warmer)
+ (comment red-faint)
+ (constant blue-cooler)
+ (docstring green-faint)
+ (docmarkup magenta-faint)
+ (fnname magenta)
+ (keyword magenta-cooler)
+ (preprocessor red-cooler)
+ (string blue-warmer)
+ (type cyan-cooler)
+ (variable cyan)
+ (rx-construct green-cooler)
+ (rx-backslash magenta)
+
+;;;; Accent mappings
+
+ (accent-0 blue)
+ (accent-1 magenta-warmer)
+ (accent-2 cyan)
+ (accent-3 red)
+
+;;;; Button mappings
+
+ (fg-button-active fg-main)
+ (fg-button-inactive fg-dim)
+ (bg-button-active bg-active)
+ (bg-button-inactive bg-dim)
+
+;;;; Completion mappings
+
+ (fg-completion-match-0 blue)
+ (fg-completion-match-1 magenta-warmer)
+ (fg-completion-match-2 cyan)
+ (fg-completion-match-3 red)
+ (bg-completion-match-0 unspecified)
+ (bg-completion-match-1 unspecified)
+ (bg-completion-match-2 unspecified)
+ (bg-completion-match-3 unspecified)
+
+;;;; Date mappings
+
+ (date-common cyan)
+ (date-deadline red)
+ (date-event fg-alt)
+ (date-holiday red-cooler)
+ (date-holiday-other blue)
+ (date-now fg-main)
+ (date-range fg-alt)
+ (date-scheduled yellow-warmer)
+ (date-weekday cyan)
+ (date-weekend red-faint)
+
+;;;; Line number mappings
+
+ (fg-line-number-inactive fg-dim)
+ (fg-line-number-active fg-main)
+ (bg-line-number-inactive bg-dim)
+ (bg-line-number-active bg-active)
+
+;;;; Link mappings
+
+ (fg-link blue-warmer)
+ (bg-link unspecified)
+ (underline-link blue-warmer)
+
+ (fg-link-symbolic cyan)
+ (bg-link-symbolic unspecified)
+ (underline-link-symbolic cyan)
+
+ (fg-link-visited magenta)
+ (bg-link-visited unspecified)
+ (underline-link-visited magenta)
+
+;;;; Mail mappings
+
+ (mail-cite-0 blue-faint)
+ (mail-cite-1 yellow-warmer)
+ (mail-cite-2 cyan-cooler)
+ (mail-cite-3 red-cooler)
+ (mail-part cyan)
+ (mail-recipient magenta-cooler)
+ (mail-subject magenta-warmer)
+ (mail-other magenta-faint)
+
+;;;; Mark mappings
+
+ (bg-mark-delete bg-red-subtle)
+ (fg-mark-delete red)
+ (bg-mark-select bg-cyan-subtle)
+ (fg-mark-select cyan)
+ (bg-mark-other bg-yellow-subtle)
+ (fg-mark-other yellow)
+
+;;;; Prompt mappings
+
+ (fg-prompt cyan-cooler)
+ (bg-prompt unspecified)
+
+;;;; Prose mappings
+
+ (bg-prose-block-delimiter bg-dim)
+ (fg-prose-block-delimiter fg-dim)
+ (bg-prose-block-contents bg-dim)
+
+ (bg-prose-code unspecified)
+ (fg-prose-code cyan-cooler)
+
+ (bg-prose-macro unspecified)
+ (fg-prose-macro magenta-cooler)
+
+ (bg-prose-verbatim unspecified)
+ (fg-prose-verbatim magenta-warmer)
+
+ (prose-done green)
+ (prose-todo red)
+
+ (prose-metadata fg-dim)
+ (prose-metadata-value fg-alt)
+
+ (prose-table fg-alt)
+ (prose-table-formula magenta-warmer)
+
+ (prose-tag magenta-faint)
+
+;;;; Rainbow mappings
+
+ (rainbow-0 fg-main)
+ (rainbow-1 magenta-intense)
+ (rainbow-2 cyan-intense)
+ (rainbow-3 red-warmer)
+ (rainbow-4 yellow-intense)
+ (rainbow-5 magenta-cooler)
+ (rainbow-6 green-intense)
+ (rainbow-7 blue-warmer)
+ (rainbow-8 magenta-warmer)
+
+;;;; Search mappings
+
+ (bg-search-current bg-yellow-intense)
+ (bg-search-lazy bg-cyan-intense)
+ (bg-search-replace bg-red-intense)
+
+ (bg-search-rx-group-0 bg-blue-intense)
+ (bg-search-rx-group-1 bg-green-intense)
+ (bg-search-rx-group-2 bg-red-subtle)
+ (bg-search-rx-group-3 bg-magenta-subtle)
+
+;;;; Space mappings
+
+ (bg-space unspecified)
+ (fg-space border)
+ (bg-space-err bg-red-intense)
+
+;;;; Terminal mappings
+
+ (bg-term-black "#000000")
+ (fg-term-black "#000000")
+ (bg-term-black-bright "#595959")
+ (fg-term-black-bright "#595959")
+
+ (bg-term-red red)
+ (fg-term-red red)
+ (bg-term-red-bright red-warmer)
+ (fg-term-red-bright red-warmer)
+
+ (bg-term-green green)
+ (fg-term-green green)
+ (bg-term-green-bright green-cooler)
+ (fg-term-green-bright green-cooler)
+
+ (bg-term-yellow yellow)
+ (fg-term-yellow yellow)
+ (bg-term-yellow-bright yellow-warmer)
+ (fg-term-yellow-bright yellow-warmer)
+
+ (bg-term-blue blue)
+ (fg-term-blue blue)
+ (bg-term-blue-bright blue-warmer)
+ (fg-term-blue-bright blue-warmer)
+
+ (bg-term-magenta magenta)
+ (fg-term-magenta magenta)
+ (bg-term-magenta-bright magenta-cooler)
+ (fg-term-magenta-bright magenta-cooler)
+
+ (bg-term-cyan cyan)
+ (fg-term-cyan cyan)
+ (bg-term-cyan-bright cyan-cooler)
+ (fg-term-cyan-bright cyan-cooler)
+
+ (bg-term-white "#a6a6a6")
+ (fg-term-white "#a6a6a6")
+ (bg-term-white-bright "#ffffff")
+ (fg-term-white-bright "#ffffff")
+
+;;;; Heading mappings
+
+ (fg-heading-0 cyan-cooler)
+ (fg-heading-1 fg-main)
+ (fg-heading-2 yellow-faint)
+ (fg-heading-3 fg-alt)
+ (fg-heading-4 magenta)
+ (fg-heading-5 green-faint)
+ (fg-heading-6 red-faint)
+ (fg-heading-7 cyan-warmer)
+ (fg-heading-8 fg-dim)
+
+ (bg-heading-0 unspecified)
+ (bg-heading-1 unspecified)
+ (bg-heading-2 unspecified)
+ (bg-heading-3 unspecified)
+ (bg-heading-4 unspecified)
+ (bg-heading-5 unspecified)
+ (bg-heading-6 unspecified)
+ (bg-heading-7 unspecified)
+ (bg-heading-8 unspecified)
+
+ (overline-heading-0 unspecified)
+ (overline-heading-1 unspecified)
+ (overline-heading-2 unspecified)
+ (overline-heading-3 unspecified)
+ (overline-heading-4 unspecified)
+ (overline-heading-5 unspecified)
+ (overline-heading-6 unspecified)
+ (overline-heading-7 unspecified)
+ (overline-heading-8 unspecified))
+ "The entire palette of the `modus-operandi-tinted' theme.
+
+Named colors have the form (COLOR-NAME HEX-VALUE) with the former
+as a symbol and the latter as a string.
+
+Semantic color mappings have the form (MAPPING-NAME COLOR-NAME)
+with both as symbols. The latter is a named color that already
+exists in the palette and is associated with a HEX-VALUE.")
+
+ (defcustom modus-operandi-tinted-palette-overrides nil
+ "Overrides for `modus-operandi-tinted-palette'.
+
+Mirror the elements of the aforementioned palette, overriding
+their value.
+
+For overrides that are shared across all of the Modus themes,
+refer to `modus-themes-common-palette-overrides'.
+
+Theme-specific overrides take precedence over shared overrides.
+The idea of common overrides is to change semantic color
+mappings, such as to make the cursor red. Wherea theme-specific
+overrides can also be used to change the value of a named color,
+such as what hexadecimal RGB value the red-warmer symbol
+represents."
+ :group 'modus-themes
+ :package-version '(modus-themes . "4.0.0")
+ :version "30.1"
+ :type '(repeat (list symbol (choice symbol string)))
+ :set #'modus-themes--set-option
+ :initialize #'custom-initialize-default
+ :link '(info-link "(modus-themes) Palette overrides"))
+
+ (modus-themes-theme modus-operandi-tinted
+ modus-operandi-tinted-palette
+ modus-operandi-tinted-palette-overrides)
+
+ (provide-theme 'modus-operandi-tinted))
+
+;;; modus-operandi-tinted-theme.el ends here
diff --git a/etc/themes/modus-operandi-tritanopia-theme.el b/etc/themes/modus-operandi-tritanopia-theme.el
new file mode 100644
index 00000000000..56be8329784
--- /dev/null
+++ b/etc/themes/modus-operandi-tritanopia-theme.el
@@ -0,0 +1,515 @@
+;;; modus-operandi-tritanopia-theme.el --- Tritanopia-optimized theme with a white background -*- lexical-binding:t -*-
+
+;; Copyright (C) 2019-2024 Free Software Foundation, Inc.
+
+;; Author: Protesilaos Stavrou <info@protesilaos.com>
+;; Maintainer: Protesilaos Stavrou <info@protesilaos.com>
+;; URL: https://github.com/protesilaos/modus-themes
+;; Keywords: faces, theme, accessibility
+
+;; This file is part of GNU Emacs.
+
+;; GNU Emacs is free software: you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+;;
+;; GNU Emacs is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+;;
+;; You should have received a copy of the GNU General Public License
+;; along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>.
+
+;;; Commentary:
+;;
+;; The Modus themes conform with the highest standard for
+;; color-contrast accessibility between background and foreground
+;; values (WCAG AAA). Please refer to the official Info manual for
+;; further documentation (distributed with the themes, or available
+;; at: <https://protesilaos.com/emacs/modus-themes>).
+
+;;; Code:
+
+
+
+(eval-and-compile
+ (unless (and (fboundp 'require-theme)
+ load-file-name
+ (equal (file-name-directory load-file-name)
+ (expand-file-name "themes/" data-directory))
+ (require-theme 'modus-themes t))
+ (require 'modus-themes))
+
+;;;###theme-autoload
+ (deftheme modus-operandi-tritanopia
+ "Tritanopia-optimized theme with a white background.
+This variant is optimized for users with blue-yellow color
+deficiency (tritanopia). It 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 (WCAG AAA
+standard)."
+ :background-mode 'light
+ :kind 'color-scheme
+ :family 'modus)
+
+ (defconst modus-operandi-tritanopia-palette
+ '(
+;;; Basic values
+
+ (bg-main "#ffffff")
+ (bg-dim "#f2f2f2")
+ (fg-main "#000000")
+ (fg-dim "#595959")
+ (fg-alt "#193668")
+ (bg-active "#c4c4c4")
+ (bg-inactive "#e0e0e0")
+ (border "#9f9f9f")
+
+;;; Common accent foregrounds
+
+ (red "#a60000")
+ (red-warmer "#b21100")
+ (red-cooler "#a0132f")
+ (red-faint "#702000")
+ (red-intense "#d00000")
+ (green "#006800")
+ (green-warmer "#316500")
+ (green-cooler "#00663f")
+ (green-faint "#2a5045")
+ (green-intense "#008900")
+ (yellow "#695500")
+ (yellow-warmer "#973300")
+ (yellow-cooler "#77492f")
+ (yellow-faint "#624416")
+ (yellow-intense "#808000")
+ (blue "#0031a9")
+ (blue-warmer "#3548cf")
+ (blue-cooler "#0000b0")
+ (blue-faint "#003497")
+ (blue-intense "#0000ff")
+ (magenta "#721045")
+ (magenta-warmer "#8f0075")
+ (magenta-cooler "#531ab6")
+ (magenta-faint "#7c318f")
+ (magenta-intense "#cd22bd")
+ (cyan "#005e8b")
+ (cyan-warmer "#3f578f")
+ (cyan-cooler "#005f5f")
+ (cyan-faint "#004f5f")
+ (cyan-intense "#008899")
+
+;;; Uncommon accent foregrounds
+
+ (rust "#8a290f")
+ (gold "#80601f")
+ (olive "#56692d")
+ (slate "#2f3f83")
+ (indigo "#4a3a8a")
+ (maroon "#731c52")
+ (pink "#7b435c")
+
+;;; Common accent backgrounds
+
+ (bg-red-intense "#ff8f88")
+ (bg-green-intense "#8adf80")
+ (bg-yellow-intense "#f3d000")
+ (bg-blue-intense "#bfc9ff")
+ (bg-magenta-intense "#dfa0f0")
+ (bg-cyan-intense "#a4d5f9")
+
+ (bg-red-subtle "#ffcfbf")
+ (bg-green-subtle "#b3fabf")
+ (bg-yellow-subtle "#fff576")
+ (bg-blue-subtle "#ccdfff")
+ (bg-magenta-subtle "#ffddff")
+ (bg-cyan-subtle "#bfefff")
+
+ (bg-red-nuanced "#ffe8e8")
+ (bg-green-nuanced "#e0f6e0")
+ (bg-yellow-nuanced "#f8f0d0")
+ (bg-blue-nuanced "#ecedff")
+ (bg-magenta-nuanced "#f8e6f5")
+ (bg-cyan-nuanced "#e0f2fa")
+
+;;; Uncommon accent backgrounds
+
+ (bg-ochre "#f0e0cc")
+ (bg-lavender "#dfdbfa")
+ (bg-sage "#c0e7d4")
+
+;;; Graphs
+
+ (bg-graph-red-0 "#ef7969")
+ (bg-graph-red-1 "#ffaab4")
+ (bg-graph-green-0 "#70c3b0")
+ (bg-graph-green-1 "#a3dfe5")
+ (bg-graph-yellow-0 "#d99f9f")
+ (bg-graph-yellow-1 "#ffb58f")
+ (bg-graph-blue-0 "#80a0df")
+ (bg-graph-blue-1 "#9fcaff")
+ (bg-graph-magenta-0 "#efafcf")
+ (bg-graph-magenta-1 "#ffdaef")
+ (bg-graph-cyan-0 "#7fd3ed")
+ (bg-graph-cyan-1 "#afefff")
+
+;;; Special purpose
+
+ (bg-completion "#afdfef")
+ (bg-hover "#ffafbc")
+ (bg-hover-secondary "#9fdfff")
+ (bg-hl-line "#dfeaec")
+ (bg-region "#bdbdbd")
+ (fg-region "#000000")
+
+ (bg-char-0 "#ff908f")
+ (bg-char-1 "#bfbfff")
+ (bg-char-2 "#5fcfdf")
+
+ (bg-mode-line-active "#afe0f2")
+ (fg-mode-line-active "#0f0f0f")
+ (border-mode-line-active "#2f4f44")
+ (bg-mode-line-inactive "#e6e6e6")
+ (fg-mode-line-inactive "#585858")
+ (border-mode-line-inactive "#a3a3a3")
+
+ (modeline-err "#8f0000")
+ (modeline-warning "#6f306f")
+ (modeline-info "#00445f")
+
+ (bg-tab-bar "#dfdfdf")
+ (bg-tab-current "#ffffff")
+ (bg-tab-other "#c2c2c2")
+
+;;; Diffs
+
+ (bg-added "#b5e7ff")
+ (bg-added-faint "#c6f6ff")
+ (bg-added-refine "#9adcef")
+ (bg-added-fringe "#1782cc")
+ (fg-added "#005079")
+ (fg-added-intense "#0043aa")
+
+ (bg-changed "#eecfdf")
+ (bg-changed-faint "#f0dde5")
+ (bg-changed-refine "#e0b0d0")
+ (bg-changed-fringe "#9f6ab0")
+ (fg-changed "#6f1343")
+ (fg-changed-intense "#7f0f9f")
+
+ (bg-removed "#ffd8d5")
+ (bg-removed-faint "#ffe9e9")
+ (bg-removed-refine "#f3b5af")
+ (bg-removed-fringe "#d84a4f")
+ (fg-removed "#8f1313")
+ (fg-removed-intense "#aa2222")
+
+ (bg-diff-context "#f3f3f3")
+
+;;; Paren match
+
+ (bg-paren-match "#5fcfff")
+ (fg-paren-match fg-main)
+ (bg-paren-expression "#efd3f5")
+ (underline-paren-match unspecified)
+
+;;; Mappings
+
+;;;; General mappings
+
+ (fringe bg-dim)
+ (cursor red-intense)
+
+ (keybind red)
+ (name red-cooler)
+ (identifier red-faint)
+
+ (err red-warmer)
+ (warning magenta)
+ (info cyan)
+
+ (underline-err red-intense)
+ (underline-warning magenta-intense)
+ (underline-note cyan-intense)
+
+ (bg-prominent-err bg-red-intense)
+ (fg-prominent-err fg-main)
+ (bg-prominent-warning bg-magenta-intense)
+ (fg-prominent-warning fg-main)
+ (bg-prominent-note bg-cyan-intense)
+ (fg-prominent-note fg-main)
+
+ (bg-active-argument bg-red-nuanced)
+ (fg-active-argument red-warmer)
+ (bg-active-value bg-cyan-nuanced)
+ (fg-active-value cyan)
+
+;;;; Code mappings
+
+ (builtin magenta)
+ (comment red-faint)
+ (constant green-cooler)
+ (docstring fg-alt)
+ (docmarkup magenta-faint)
+ (fnname cyan-warmer)
+ (keyword red-cooler)
+ (preprocessor red-warmer)
+ (string cyan)
+ (type blue-warmer)
+ (variable cyan-cooler)
+ (rx-construct red)
+ (rx-backslash magenta)
+
+;;;; Accent mappings
+
+ (accent-0 cyan)
+ (accent-1 red-warmer)
+ (accent-2 cyan-cooler)
+ (accent-3 magenta)
+
+;;;; Button mappings
+
+ (fg-button-active fg-main)
+ (fg-button-inactive fg-dim)
+ (bg-button-active bg-active)
+ (bg-button-inactive bg-dim)
+
+;;;; Completion mappings
+
+ (fg-completion-match-0 cyan)
+ (fg-completion-match-1 red-warmer)
+ (fg-completion-match-2 magenta)
+ (fg-completion-match-3 cyan-cooler)
+ (bg-completion-match-0 unspecified)
+ (bg-completion-match-1 unspecified)
+ (bg-completion-match-2 unspecified)
+ (bg-completion-match-3 unspecified)
+
+;;;; Date mappings
+
+ (date-common cyan-cooler)
+ (date-deadline red)
+ (date-event fg-alt)
+ (date-holiday red)
+ (date-holiday-other cyan)
+ (date-now fg-main)
+ (date-range fg-alt)
+ (date-scheduled magenta)
+ (date-weekday cyan)
+ (date-weekend red-faint)
+
+;;;; Line number mappings
+
+ (fg-line-number-inactive fg-dim)
+ (fg-line-number-active fg-main)
+ (bg-line-number-inactive bg-dim)
+ (bg-line-number-active bg-active)
+
+;;;; Link mappings
+
+ (fg-link cyan)
+ (bg-link unspecified)
+ (underline-link cyan)
+
+ (fg-link-symbolic cyan-cooler)
+ (bg-link-symbolic unspecified)
+ (underline-link-symbolic cyan-cooler)
+
+ (fg-link-visited magenta)
+ (bg-link-visited unspecified)
+ (underline-link-visited magenta)
+
+;;;; Mail mappings
+
+ (mail-cite-0 cyan-faint)
+ (mail-cite-1 red-faint)
+ (mail-cite-2 magenta-warmer)
+ (mail-cite-3 cyan-warmer)
+ (mail-part cyan-cooler)
+ (mail-recipient cyan)
+ (mail-subject red-cooler)
+ (mail-other cyan)
+
+;;;; Mark mappings
+
+ (bg-mark-delete bg-red-subtle)
+ (fg-mark-delete red)
+ (bg-mark-select bg-cyan-subtle)
+ (fg-mark-select cyan)
+ (bg-mark-other bg-magenta-subtle)
+ (fg-mark-other magenta)
+
+;;;; Prompt mappings
+
+ (fg-prompt cyan-cooler)
+ (bg-prompt unspecified)
+
+;;;; Prose mappings
+
+ (bg-prose-block-delimiter bg-dim)
+ (fg-prose-block-delimiter fg-dim)
+ (bg-prose-block-contents bg-dim)
+
+ (bg-prose-code unspecified)
+ (fg-prose-code cyan)
+
+ (bg-prose-macro unspecified)
+ (fg-prose-macro red-warmer)
+
+ (bg-prose-verbatim unspecified)
+ (fg-prose-verbatim magenta-warmer)
+
+ (prose-done cyan)
+ (prose-todo red)
+
+ (prose-metadata fg-dim)
+ (prose-metadata-value fg-alt)
+
+ (prose-table fg-alt)
+ (prose-table-formula red-cooler)
+
+ (prose-tag magenta-faint)
+
+;;;; Rainbow mappings
+
+ (rainbow-0 cyan)
+ (rainbow-1 red)
+ (rainbow-2 cyan-warmer)
+ (rainbow-3 red-cooler)
+ (rainbow-4 cyan-cooler)
+ (rainbow-5 magenta)
+ (rainbow-6 cyan-faint)
+ (rainbow-7 magenta-faint)
+ (rainbow-8 red-faint)
+
+;;;; Search mappings
+
+ (bg-search-current bg-red-intense)
+ (bg-search-lazy bg-cyan-intense)
+ (bg-search-replace bg-magenta-intense)
+
+ (bg-search-rx-group-0 bg-blue-intense)
+ (bg-search-rx-group-1 bg-magenta-intense)
+ (bg-search-rx-group-2 bg-cyan-subtle)
+ (bg-search-rx-group-3 bg-red-subtle)
+
+;;;; Space mappings
+
+ (bg-space unspecified)
+ (fg-space border)
+ (bg-space-err bg-red-intense)
+
+;;;; Terminal mappings
+
+ (bg-term-black "#000000")
+ (fg-term-black "#000000")
+ (bg-term-black-bright "#595959")
+ (fg-term-black-bright "#595959")
+
+ (bg-term-red red)
+ (fg-term-red red)
+ (bg-term-red-bright red-warmer)
+ (fg-term-red-bright red-warmer)
+
+ (bg-term-green green)
+ (fg-term-green green)
+ (bg-term-green-bright green-cooler)
+ (fg-term-green-bright green-cooler)
+
+ (bg-term-yellow yellow)
+ (fg-term-yellow yellow)
+ (bg-term-yellow-bright yellow-warmer)
+ (fg-term-yellow-bright yellow-warmer)
+
+ (bg-term-blue blue)
+ (fg-term-blue blue)
+ (bg-term-blue-bright blue-warmer)
+ (fg-term-blue-bright blue-warmer)
+
+ (bg-term-magenta magenta)
+ (fg-term-magenta magenta)
+ (bg-term-magenta-bright magenta-cooler)
+ (fg-term-magenta-bright magenta-cooler)
+
+ (bg-term-cyan cyan)
+ (fg-term-cyan cyan)
+ (bg-term-cyan-bright cyan-cooler)
+ (fg-term-cyan-bright cyan-cooler)
+
+ (bg-term-white "#a6a6a6")
+ (fg-term-white "#a6a6a6")
+ (bg-term-white-bright "#ffffff")
+ (fg-term-white-bright "#ffffff")
+
+;;;; Heading mappings
+
+ (fg-heading-0 cyan-cooler)
+ (fg-heading-1 fg-main)
+ (fg-heading-2 red-faint)
+ (fg-heading-3 cyan-faint)
+ (fg-heading-4 magenta)
+ (fg-heading-5 green-faint)
+ (fg-heading-6 magenta-faint)
+ (fg-heading-7 cyan-warmer)
+ (fg-heading-8 fg-dim)
+
+ (bg-heading-0 unspecified)
+ (bg-heading-1 unspecified)
+ (bg-heading-2 unspecified)
+ (bg-heading-3 unspecified)
+ (bg-heading-4 unspecified)
+ (bg-heading-5 unspecified)
+ (bg-heading-6 unspecified)
+ (bg-heading-7 unspecified)
+ (bg-heading-8 unspecified)
+
+ (overline-heading-0 unspecified)
+ (overline-heading-1 unspecified)
+ (overline-heading-2 unspecified)
+ (overline-heading-3 unspecified)
+ (overline-heading-4 unspecified)
+ (overline-heading-5 unspecified)
+ (overline-heading-6 unspecified)
+ (overline-heading-7 unspecified)
+ (overline-heading-8 unspecified))
+ "The entire palette of the `modus-operandi-tritanopia' theme.
+
+Named colors have the form (COLOR-NAME HEX-VALUE) with the former
+as a symbol and the latter as a string.
+
+Semantic color mappings have the form (MAPPING-NAME COLOR-NAME)
+with both as symbols. The latter is a named color that already
+exists in the palette and is associated with a HEX-VALUE.")
+
+ (defcustom modus-operandi-tritanopia-palette-overrides nil
+ "Overrides for `modus-operandi-tritanopia-palette'.
+
+Mirror the elements of the aforementioned palette, overriding
+their value.
+
+For overrides that are shared across all of the Modus themes,
+refer to `modus-themes-common-palette-overrides'.
+
+Theme-specific overrides take precedence over shared overrides.
+The idea of common overrides is to change semantic color
+mappings, such as to make the cursor red. Wherea theme-specific
+overrides can also be used to change the value of a named color,
+such as what hexadecimal RGB value the red-warmer symbol
+represents."
+ :group 'modus-themes
+ :package-version '(modus-themes . "4.0.0")
+ :version "30.1"
+ :type '(repeat (list symbol (choice symbol string)))
+ :set #'modus-themes--set-option
+ :initialize #'custom-initialize-default
+ :link '(info-link "(modus-themes) Palette overrides"))
+
+ (modus-themes-theme modus-operandi-tritanopia
+ modus-operandi-tritanopia-palette
+ modus-operandi-tritanopia-palette-overrides)
+
+ (provide-theme 'modus-operandi-tritanopia))
+
+;;; modus-operandi-tritanopia-theme.el ends here
diff --git a/etc/themes/modus-themes.el b/etc/themes/modus-themes.el
index 1f97d9d08f0..b776f12671e 100644
--- a/etc/themes/modus-themes.el
+++ b/etc/themes/modus-themes.el
@@ -1,12 +1,11 @@
;;; modus-themes.el --- Elegant, highly legible and customizable themes -*- lexical-binding:t -*-
-;; Copyright (C) 2019-2024 Free Software Foundation, Inc.
+;; Copyright (C) 2019-2024 Free Software Foundation, Inc.
;; Author: Protesilaos Stavrou <info@protesilaos.com>
-;; Maintainer: Modus-Themes Development <~protesilaos/modus-themes@lists.sr.ht>
-;; URL: https://git.sr.ht/~protesilaos/modus-themes
-;; Mailing-List: https://lists.sr.ht/~protesilaos/modus-themes
-;; Version: 3.0.0
+;; Maintainer: Protesilaos Stavrou <info@protesilaos.com>
+;; URL: https://github.com/protesilaos/modus-themes
+;; Version: 4.4.0
;; Package-Requires: ((emacs "27.1"))
;; Keywords: faces, theme, accessibility
@@ -27,1215 +26,173 @@
;;; Commentary:
;;
-;; The Modus themes conform with the highest standard for color-contrast
-;; accessibility between background and foreground values (WCAG AAA).
-;; This file contains all customization variables, helper functions,
-;; interactive commands, and face specifications. Please refer to the
-;; official Info manual for further documentation (distributed with the
-;; themes, or available at: <https://protesilaos.com/emacs/modus-themes>).
-;;
-;; The themes share the following customization variables:
-;;
-;; modus-themes-completions (alist)
-;; modus-themes-headings (alist)
-;; modus-themes-org-agenda (alist)
-;; 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)
-;; modus-themes-variable-pitch-ui (boolean)
-;; modus-themes-box-buttons (choice)
-;; modus-themes-diffs (choice)
-;; modus-themes-fringes (choice)
-;; modus-themes-hl-line (choice)
-;; modus-themes-lang-checkers (choice)
-;; modus-themes-links (choice)
-;; modus-themes-mail-citations (choice)
-;; modus-themes-markup (choice)
-;; modus-themes-mode-line (choice)
-;; modus-themes-org-blocks (choice)
-;; modus-themes-paren-match (choice)
-;; modus-themes-prompts (choice)
-;; modus-themes-region (choice)
-;; modus-themes-syntax (choice)
-;;
-;; There also exist two unique customization variables for overriding
-;; color palette values. The specifics are documented in the manual.
-;; The symbols are:
-;;
-;; modus-themes-operandi-color-overrides (alist)
-;; modus-themes-vivendi-color-overrides (alist)
-;;
-;; Check the manual for all supported packages (there are hundreds of
-;; them).
-;;
-;; For a complete view of the project, also refer to the following files
-;; (should be distributed in the same repository/directory as the
-;; current item):
-;;
-;; - modus-operandi-theme.el (Light theme)
-;; - modus-vivendi-theme.el (Dark theme)
+;; The Modus themes conform with the highest standard for
+;; color-contrast accessibility between background and foreground
+;; values (WCAG AAA). Please refer to the official Info manual for
+;; further documentation (distributed with the themes, or available
+;; at: <https://protesilaos.com/emacs/modus-themes>).
;;; Code:
-(eval-when-compile
- (require 'cl-lib)
- (require 'subr-x))
+(eval-when-compile (require 'subr-x))
(defgroup modus-themes ()
- "Options for `modus-operandi', `modus-vivendi' themes.
+ "User options for the Modus themes.
The Modus themes conform with the WCAG AAA standard for color
contrast between background and foreground combinations (a
-minimum contrast of 7:1---the highest standard of its kind). The
-themes also strive to empower users with red-green color
-deficiency: this is achieved through customization variables that
-replace all relevant instances of green with blue, as well as the
-overall design of the themes which relies mostly on colors that
-cover the blue-cyan-magenta side of the spectrum."
+minimum contrast of 7:1---the highest standard of its kind).
+
+The Modus themes collection includes themes that are optimized
+for people with red-green or blue-yellow color
+deficiency (deuteranopia or tritanopia, respectively)."
:group 'faces
:link '(info-link "(modus-themes) Top")
+ :link '(url-link :tag "Homepage" "https://protesilaos.com/emacs/modus-themes")
+ :link '(url-link :tag "Sample pictures" "https://protesilaos.com/emacs/modus-themes-pictures")
:prefix "modus-themes-"
:tag "Modus Themes")
(defgroup modus-themes-faces ()
- "Faces defined by `modus-operandi' and `modus-vivendi' themes."
+ "Faces defined by the Modus themes."
:group 'modus-themes
:link '(info-link "(modus-themes) Top")
+ :link '(url-link :tag "Homepage" "https://protesilaos.com/emacs/modus-themes")
+ :link '(url-link :tag "Sample pictures" "https://protesilaos.com/emacs/modus-themes-pictures")
:prefix "modus-themes-"
:tag "Modus Themes Faces")
-(defvar modus-themes--version "3.0.0"
- "Current version of the Modus themes.
-
-The version either is the last tagged release, such as '1.0.0',
-or an in-development version like '1.1.0-dev'. As we use
-semantic versioning, tags of the '1.0.1' sort are not reported:
-those would count as part of '1.1.0-dev'.")
-
-;;;###autoload
-(defun modus-themes-version (&optional insert)
- "Print `modus-themes--version' in the echo area.
-If optional INSERT argument is provided from Lisp or as a prefix
-argument, insert the `modus-themes--version' at point."
- (interactive "P")
- (funcall (if insert 'insert 'message) modus-themes--version))
-
-;;;###autoload
-(defun modus-themes-report-bug ()
- "Submit a bug report or issue to the Modus themes developers."
- (interactive)
- (reporter-submit-bug-report
- "~protesilaos/modus-themes@lists.sr.ht"
- (format "modus-themes (%s)\n" modus-themes--version)
- ;; I am just getting started with this. Let's first see what people
- ;; think about it.
- nil nil nil nil))
-
-;;; Variables for each theme variant
-
-;;;; Modus Operandi
-
-(defconst modus-themes-operandi-colors
- '(;; base values
- (bg-main . "#ffffff") (fg-main . "#000000")
- (bg-dim . "#f8f8f8") (fg-dim . "#282828")
- (bg-alt . "#f0f0f0") (fg-alt . "#505050")
- ;; specifically for on/off states and must be combined with
- ;; themselves, though the backgrounds are also meant to be used with
- ;; other "active" values, defined further below; bg-active-accent
- ;; can work as a substitute for bg-active
- (bg-active . "#d7d7d7") (fg-active . "#0a0a0a")
- (bg-inactive . "#efefef") (fg-inactive . "#404148")
- (bg-active-accent . "#d0d6ff")
- ;; these special values are intended as alternatives to the base
- ;; values for cases where we need to avoid confusion between the
- ;; highlighted constructs; they must either be used as pairs based
- ;; on their name or each can be combined with {fg,bg}-{main,alt,dim}
- ;; always in accordance with their role as background or foreground
- (bg-special-cold . "#dde3f4") (bg-special-faint-cold . "#f0f1ff") (fg-special-cold . "#093060")
- (bg-special-mild . "#c4ede0") (bg-special-faint-mild . "#ebf5eb") (fg-special-mild . "#184034")
- (bg-special-warm . "#f0e0d4") (bg-special-faint-warm . "#fef2ea") (fg-special-warm . "#5d3026")
- (bg-special-calm . "#f8ddea") (bg-special-faint-calm . "#faeff9") (fg-special-calm . "#61284f")
- ;; foregrounds that can be combined with bg-main, bg-dim, bg-alt
- (red . "#a60000")
- (red-alt . "#972500")
- (red-alt-other . "#a0132f")
- (red-faint . "#7f1010")
- (red-alt-faint . "#702f00")
- (red-alt-other-faint . "#7f002f")
- (green . "#005e00")
- (green-alt . "#315b00")
- (green-alt-other . "#145c33")
- (green-faint . "#104410")
- (green-alt-faint . "#30440f")
- (green-alt-other-faint . "#0f443f")
- (yellow . "#813e00")
- (yellow-alt . "#70480f")
- (yellow-alt-other . "#863927")
- (yellow-faint . "#5f4400")
- (yellow-alt-faint . "#5d5000")
- (yellow-alt-other-faint . "#5e3a20")
- (blue . "#0031a9")
- (blue-alt . "#2544bb")
- (blue-alt-other . "#0000c0")
- (blue-faint . "#003497")
- (blue-alt-faint . "#0f3d8c")
- (blue-alt-other-faint . "#001087")
- (magenta . "#721045")
- (magenta-alt . "#8f0075")
- (magenta-alt-other . "#5317ac")
- (magenta-faint . "#752f50")
- (magenta-alt-faint . "#7b206f")
- (magenta-alt-other-faint . "#55348e")
- (cyan . "#00538b")
- (cyan-alt . "#30517f")
- (cyan-alt-other . "#005a5f")
- (cyan-faint . "#005077")
- (cyan-alt-faint . "#354f6f")
- (cyan-alt-other-faint . "#125458")
- ;; these foreground values can only be combined with bg-main and are
- ;; thus not suitable for general purpose highlighting
- (red-intense . "#b60000")
- (orange-intense . "#904200")
- (green-intense . "#006800")
- (yellow-intense . "#605b00")
- (blue-intense . "#1f1fce")
- (magenta-intense . "#a8007f")
- (purple-intense . "#7f10d0")
- (cyan-intense . "#005f88")
- ;; those foregrounds are meant exclusively for bg-active, bg-inactive
- (red-active . "#8a0000")
- (green-active . "#004c2e")
- (yellow-active . "#702f00")
- (blue-active . "#0030b4")
- (magenta-active . "#5c2092")
- (cyan-active . "#003f8a")
- ;; the "subtle" values below be combined with fg-dim, while the
- ;; "intense" should be paired with fg-main
- (red-subtle-bg . "#f2b0a2")
- (red-intense-bg . "#ff9f9f")
- (green-subtle-bg . "#aecf90")
- (green-intense-bg . "#5ada88")
- (yellow-subtle-bg . "#e4c340")
- (yellow-intense-bg . "#f5df23")
- (blue-subtle-bg . "#b5d0ff")
- (blue-intense-bg . "#77baff")
- (magenta-subtle-bg . "#f0d3ff")
- (magenta-intense-bg . "#d5baff")
- (cyan-subtle-bg . "#c0efff")
- (cyan-intense-bg . "#42cbd4")
- ;; those background values must be combined with fg-main and should
- ;; only be used for indicators that are placed on the fringes
- (red-fringe-bg . "#f08290")
- (green-fringe-bg . "#62c86a")
- (yellow-fringe-bg . "#dbba3f")
- (blue-fringe-bg . "#82afff")
- (magenta-fringe-bg . "#e0a3ff")
- (cyan-fringe-bg . "#2fcddf")
- ;; those background values should only be used for graphs or similar
- ;; applications where colored blocks are expected to be positioned
- ;; next to each other
- (red-graph-0-bg . "#ef7969")
- (red-graph-1-bg . "#ffaab4")
- (green-graph-0-bg . "#4faa09")
- (green-graph-1-bg . "#8fef00")
- (yellow-graph-0-bg . "#ffcf00")
- (yellow-graph-1-bg . "#f9ff00")
- (blue-graph-0-bg . "#7090ff")
- (blue-graph-1-bg . "#9fc6ff")
- (magenta-graph-0-bg . "#e07fff")
- (magenta-graph-1-bg . "#fad0ff")
- (cyan-graph-0-bg . "#70d3f0")
- (cyan-graph-1-bg . "#afefff")
- ;; the following are for cases where both the foreground and the
- ;; background need to have a similar hue and so must be combined
- ;; with themselves, even though the foregrounds can be paired with
- ;; any of the base backgrounds
- (red-refine-bg . "#ffcccc") (red-refine-fg . "#780000")
- (green-refine-bg . "#aceaac") (green-refine-fg . "#004c00")
- (yellow-refine-bg . "#fff29a") (yellow-refine-fg . "#604000")
- (blue-refine-bg . "#8fcfff") (blue-refine-fg . "#002f88")
- (magenta-refine-bg . "#ffccff") (magenta-refine-fg . "#770077")
- (cyan-refine-bg . "#8eecf4") (cyan-refine-fg . "#004850")
- ;; the "nuanced" backgrounds can be combined with all of the above
- ;; foregrounds, as well as those included here, while the "nuanced"
- ;; foregrounds can in turn also be combined with bg-main, bg-dim,
- ;; bg-alt
- (red-nuanced-bg . "#fff1f0") (red-nuanced-fg . "#5f0000")
- (green-nuanced-bg . "#ecf7ed") (green-nuanced-fg . "#004000")
- (yellow-nuanced-bg . "#fff3da") (yellow-nuanced-fg . "#3f3000")
- (blue-nuanced-bg . "#f3f3ff") (blue-nuanced-fg . "#201f55")
- (magenta-nuanced-bg . "#fdf0ff") (magenta-nuanced-fg . "#541f4f")
- (cyan-nuanced-bg . "#ebf6fa") (cyan-nuanced-fg . "#0f3360")
- ;; the following are reserved for specific cases
- ;;
- ;; bg-hl-line is between bg-dim and bg-alt, so it should
- ;; work with all accents that cover those two, plus bg-main
- ;;
- ;; bg-hl-alt and bg-hl-alt-intense should only be used when no
- ;; other grayscale or fairly neutral background is available to
- ;; properly draw attention to a given construct
- ;;
- ;; bg-header is between bg-active and bg-inactive, so it
- ;; can be combined with any of the "active" values, plus the
- ;; "special" and base foreground colors
- ;;
- ;; bg-paren-match, bg-paren-match-intense, bg-region,
- ;; bg-region-accent and bg-tab-active must be combined with fg-main,
- ;; while bg-tab-inactive should be combined with fg-dim, whereas
- ;; bg-tab-inactive-alt goes together with fg-main
- ;;
- ;; bg-completion-* and bg-char-* variants are meant to be combined
- ;; with fg-main
- ;;
- ;; fg-escape-char-construct and fg-escape-char-backslash can
- ;; be combined bg-main, bg-dim, bg-alt
- ;;
- ;; fg-lang-error, fg-lang-warning, fg-lang-note can be
- ;; combined with bg-main, bg-dim, bg-alt
- ;;
- ;; fg-mark-sel, fg-mark-del, fg-mark-alt can be combined
- ;; with bg-main, bg-dim, bg-alt, bg-hl-line
- ;;
- ;; fg-unfocused must be combined with bg-main
- ;;
- ;; fg-docstring, fg-comment-yellow can be combined with
- ;; bg-main, bg-dim, bg-alt
- ;;
- ;; the window divider colors apply to faces with just an fg value
- ;;
- ;; all pairs are combinable with themselves
- (bg-hl-line . "#f2eff3")
- (bg-hl-line-intense . "#e0e0e0")
- (bg-hl-line-intense-accent . "#cfe2ff")
- (bg-hl-alt . "#fbeee0")
- (bg-hl-alt-intense . "#e8dfd1")
- (bg-paren-match . "#e0af82")
- (bg-paren-match-intense . "#c488ff")
- (bg-paren-expression . "#dff0ff")
- (bg-region . "#bcbcbc")
- (bg-region-accent . "#afafef")
- (bg-region-accent-subtle . "#efdfff")
-
- (bg-completion . "#b7dbff")
- (bg-completion-subtle . "#def3ff")
-
- (bg-char-0 . "#7feaff")
- (bg-char-1 . "#ffaaff")
- (bg-char-2 . "#dff000")
-
- (bg-tab-active . "#f6f6f6")
- (bg-tab-inactive . "#b7b7b7")
- (bg-tab-inactive-accent . "#a9b4f6")
- (bg-tab-inactive-alt . "#9f9f9f")
- (bg-tab-inactive-alt-accent . "#9fa6d0")
-
- (red-tab . "#680000")
- (green-tab . "#003900")
- (yellow-tab . "#393000")
- (orange-tab . "#502300")
- (blue-tab . "#000080")
- (cyan-tab . "#052f60")
- (magenta-tab . "#5f004d")
- (purple-tab . "#400487")
-
- (fg-escape-char-construct . "#8b1030")
- (fg-escape-char-backslash . "#654d0f")
-
- (fg-lang-error . "#9f004f")
- (fg-lang-warning . "#604f0f")
- (fg-lang-note . "#4040ae")
- (fg-lang-underline-error . "#ef4f54")
- (fg-lang-underline-warning . "#cf9f00")
- (fg-lang-underline-note . "#3f6fef")
-
- (fg-window-divider-inner . "#888888")
- (fg-window-divider-outer . "#585858")
-
- (fg-unfocused . "#56576d")
-
- (fg-docstring . "#2a486a")
- (fg-comment-yellow . "#794319")
-
- (bg-header . "#e5e5e5") (fg-header . "#2a2a2a")
-
- (bg-whitespace . "#f5efef") (fg-whitespace . "#624956")
-
- (bg-diff-heading . "#b7cfe0") (fg-diff-heading . "#041645")
- (bg-diff-added . "#d4fad4") (fg-diff-added . "#004500")
- (bg-diff-added-deuteran . "#daefff") (fg-diff-added-deuteran . "#002044")
- (bg-diff-changed . "#fcefcf") (fg-diff-changed . "#524200")
- (bg-diff-removed . "#ffe8ef") (fg-diff-removed . "#691616")
-
- (bg-diff-refine-added . "#94cf94") (fg-diff-refine-added . "#002a00")
- (bg-diff-refine-added-deuteran . "#77c0ef") (fg-diff-refine-added-deuteran . "#000035")
- (bg-diff-refine-changed . "#cccf8f") (fg-diff-refine-changed . "#302010")
- (bg-diff-refine-removed . "#daa2b0") (fg-diff-refine-removed . "#400000")
-
- (bg-diff-focus-added . "#bbeabb") (fg-diff-focus-added . "#002c00")
- (bg-diff-focus-added-deuteran . "#bacfff") (fg-diff-focus-added-deuteran . "#001755")
- (bg-diff-focus-changed . "#ecdfbf") (fg-diff-focus-changed . "#392900")
- (bg-diff-focus-removed . "#efcbcf") (fg-diff-focus-removed . "#4a0000")
-
- (bg-mark-sel . "#a0f0cf") (fg-mark-sel . "#005040")
- (bg-mark-del . "#ffccbb") (fg-mark-del . "#840040")
- (bg-mark-alt . "#f5d88f") (fg-mark-alt . "#782900"))
- "The entire palette of the `modus-operandi' theme.
-Each element has the form (NAME . HEX) with the former as a
-symbol and the latter as a string.")
-
-;;;; Modus Vivendi
-
-(defconst modus-themes-vivendi-colors
- '(;; base values
- (bg-main . "#000000") (fg-main . "#ffffff")
- (bg-dim . "#100f10") (fg-dim . "#e0e6f0")
- (bg-alt . "#191a1b") (fg-alt . "#a8a8a8")
- ;; specifically for on/off states and must be combined with
- ;; themselves, though the backgrounds are also meant to be used with
- ;; other "active" values, defined further below; bg-active-accent
- ;; can work as a substitute for bg-active
- (bg-active . "#323232") (fg-active . "#f4f4f4")
- (bg-inactive . "#1e1e1e") (fg-inactive . "#bfc0c4")
- (bg-active-accent . "#2a2a66")
- ;; these special values are intended as alternatives to the base
- ;; values for cases where we need to avoid confusion between the
- ;; highlighted constructs; they must either be used as pairs based
- ;; on their name or each can be combined with {fg,bg}-{main,alt,dim}
- ;; always in accordance with their role as background or foreground
- (bg-special-cold . "#203448") (bg-special-faint-cold . "#0e183a") (fg-special-cold . "#c6eaff")
- (bg-special-mild . "#00322e") (bg-special-faint-mild . "#001f1a") (fg-special-mild . "#bfebe0")
- (bg-special-warm . "#382f27") (bg-special-faint-warm . "#241613") (fg-special-warm . "#f8dec0")
- (bg-special-calm . "#392a48") (bg-special-faint-calm . "#251232") (fg-special-calm . "#fbd6f4")
- ;; foregrounds that can be combined with bg-main, bg-dim, bg-alt
- (red . "#ff8059")
- (red-alt . "#ef8b50")
- (red-alt-other . "#ff9077")
- (red-faint . "#ffa0a0")
- (red-alt-faint . "#f5aa80")
- (red-alt-other-faint . "#ff9fbf")
- (green . "#44bc44")
- (green-alt . "#70b900")
- (green-alt-other . "#00c06f")
- (green-faint . "#78bf78")
- (green-alt-faint . "#99b56f")
- (green-alt-other-faint . "#88bf99")
- (yellow . "#d0bc00")
- (yellow-alt . "#c0c530")
- (yellow-alt-other . "#d3b55f")
- (yellow-faint . "#d2b580")
- (yellow-alt-faint . "#cabf77")
- (yellow-alt-other-faint . "#d0ba95")
- (blue . "#2fafff")
- (blue-alt . "#79a8ff" )
- (blue-alt-other . "#00bcff")
- (blue-faint . "#82b0ec")
- (blue-alt-faint . "#a0acef")
- (blue-alt-other-faint . "#80b2f0")
- (magenta . "#feacd0")
- (magenta-alt . "#f78fe7")
- (magenta-alt-other . "#b6a0ff")
- (magenta-faint . "#e0b2d6")
- (magenta-alt-faint . "#ef9fe4")
- (magenta-alt-other-faint . "#cfa6ff")
- (cyan . "#00d3d0")
- (cyan-alt . "#4ae2f0")
- (cyan-alt-other . "#6ae4b9")
- (cyan-faint . "#90c4ed")
- (cyan-alt-faint . "#a0bfdf")
- (cyan-alt-other-faint . "#a4d0bb")
- ;; these foreground values can only be combined with bg-main and are
- ;; thus not suitable for general purpose highlighting
- (red-intense . "#fe6060")
- (orange-intense . "#fba849")
- (green-intense . "#4fe42f")
- (yellow-intense . "#f0dd60")
- (blue-intense . "#4fafff")
- (magenta-intense . "#ff62d4")
- (purple-intense . "#9f80ff")
- (cyan-intense . "#3fdfd0")
- ;; those foregrounds are meant exclusively for bg-active, bg-inactive
- (red-active . "#ffa7ba")
- (green-active . "#70d73f")
- (yellow-active . "#dbbe5f")
- (blue-active . "#34cfff")
- (magenta-active . "#d5b1ff")
- (cyan-active . "#00d8b4")
- ;; the "subtle" values below be combined with fg-dim, while the
- ;; "intense" should be paired with fg-main
- (red-subtle-bg . "#762422")
- (red-intense-bg . "#a4202a")
- (green-subtle-bg . "#2f4a00")
- (green-intense-bg . "#006800")
- (yellow-subtle-bg . "#604200")
- (yellow-intense-bg . "#874900")
- (blue-subtle-bg . "#10387c")
- (blue-intense-bg . "#2a40b8")
- (magenta-subtle-bg . "#49366e")
- (magenta-intense-bg . "#7042a2")
- (cyan-subtle-bg . "#00415e")
- (cyan-intense-bg . "#005f88")
- ;; those background values must be combined with fg-main and should
- ;; only be used for indicators that are placed on the fringes
- (red-fringe-bg . "#8f1f4b")
- (green-fringe-bg . "#006700")
- (yellow-fringe-bg . "#6f4f00")
- (blue-fringe-bg . "#3f33af")
- (magenta-fringe-bg . "#6f2f89")
- (cyan-fringe-bg . "#004f8f")
- ;; those background values should only be used for graphs or similar
- ;; applications where colored blocks are expected to be positioned
- ;; next to each other
- (red-graph-0-bg . "#b52c2c")
- (red-graph-1-bg . "#702020")
- (green-graph-0-bg . "#4fd100")
- (green-graph-1-bg . "#007800")
- (yellow-graph-0-bg . "#f1e00a")
- (yellow-graph-1-bg . "#b08600")
- (blue-graph-0-bg . "#2fafef")
- (blue-graph-1-bg . "#1f2f8f")
- (magenta-graph-0-bg . "#bf94fe")
- (magenta-graph-1-bg . "#5f509f")
- (cyan-graph-0-bg . "#47dfea")
- (cyan-graph-1-bg . "#00808f")
- ;; the following are for cases where both the foreground and the
- ;; background need to have a similar hue and so must be combined
- ;; with themselves, even though the foregrounds can be paired with
- ;; any of the base backgrounds
- (red-refine-bg . "#77002a") (red-refine-fg . "#ffb9ab")
- (green-refine-bg . "#00422a") (green-refine-fg . "#9ff0cf")
- (yellow-refine-bg . "#693200") (yellow-refine-fg . "#e2d980")
- (blue-refine-bg . "#242679") (blue-refine-fg . "#8ecfff")
- (magenta-refine-bg . "#71206a") (magenta-refine-fg . "#ffcaf0")
- (cyan-refine-bg . "#004065") (cyan-refine-fg . "#8ae4f2")
- ;; the "nuanced" backgrounds can be combined with all of the above
- ;; foregrounds, as well as those included here, while the "nuanced"
- ;; foregrounds can in turn also be combined with bg-main, bg-dim,
- ;; bg-alt
- (red-nuanced-bg . "#2c0614") (red-nuanced-fg . "#ffcccc")
- (green-nuanced-bg . "#001904") (green-nuanced-fg . "#b8e2b8")
- (yellow-nuanced-bg . "#221000") (yellow-nuanced-fg . "#dfdfb0")
- (blue-nuanced-bg . "#0f0e39") (blue-nuanced-fg . "#bfd9ff")
- (magenta-nuanced-bg . "#230631") (magenta-nuanced-fg . "#e5cfef")
- (cyan-nuanced-bg . "#041529") (cyan-nuanced-fg . "#a8e5e5")
- ;; the following are reserved for specific cases
- ;;
- ;; bg-hl-line is between bg-dim and bg-alt, so it should
- ;; work with all accents that cover those two, plus bg-main
- ;;
- ;; bg-hl-alt and bg-hl-alt-intense should only be used when no
- ;; other grayscale or fairly neutral background is available to
- ;; properly draw attention to a given construct
- ;;
- ;; bg-header is between bg-active and bg-inactive, so it
- ;; can be combined with any of the "active" values, plus the
- ;; "special" and base foreground colors
- ;;
- ;; bg-paren-match, bg-paren-match-intense, bg-region,
- ;; bg-region-accent and bg-tab-active must be combined with fg-main,
- ;; while bg-tab-inactive should be combined with fg-dim, whereas
- ;; bg-tab-inactive-alt goes together with fg-main
- ;;
- ;; bg-completion-* and bg-char-* variants are meant to be combined
- ;; with fg-main
- ;;
- ;; fg-escape-char-construct and fg-escape-char-backslash can
- ;; be combined bg-main, bg-dim, bg-alt
- ;;
- ;; fg-lang-error, fg-lang-warning, fg-lang-note can be
- ;; combined with bg-main, bg-dim, bg-alt
- ;;
- ;; fg-mark-sel, fg-mark-del, fg-mark-alt can be combined
- ;; with bg-main, bg-dim, bg-alt, bg-hl-line
- ;;
- ;; fg-unfocused must be combined with bg-main
- ;;
- ;; fg-docstring, fg-comment-yellow can be combined with
- ;; bg-main, bg-dim, bg-alt
- ;;
- ;; the window divider colors apply to faces with just an fg value
- ;;
- ;; all pairs are combinable with themselves
- (bg-hl-line . "#151823")
- (bg-hl-line-intense . "#292929")
- (bg-hl-line-intense-accent . "#002a4f")
- (bg-hl-alt . "#181732")
- (bg-hl-alt-intense . "#282e46")
- (bg-paren-match . "#6f3355")
- (bg-paren-match-intense . "#7416b5")
- (bg-paren-expression . "#221044")
- (bg-region . "#3c3c3c")
- (bg-region-accent . "#4f3d88")
- (bg-region-accent-subtle . "#240f55")
-
- (bg-completion . "#142f69")
- (bg-completion-subtle . "#0e194b")
-
- (bg-char-0 . "#0050af")
- (bg-char-1 . "#7f1f7f")
- (bg-char-2 . "#625a00")
-
- (bg-tab-active . "#0e0e0e")
- (bg-tab-inactive . "#424242")
- (bg-tab-inactive-accent . "#35398f")
- (bg-tab-inactive-alt . "#595959")
- (bg-tab-inactive-alt-accent . "#505588")
-
- (red-tab . "#ffc0bf")
- (green-tab . "#88ef88")
- (yellow-tab . "#d2e580")
- (orange-tab . "#f5ca80")
- (blue-tab . "#92d9ff")
- (cyan-tab . "#60e7e0")
- (magenta-tab . "#ffb8ff")
- (purple-tab . "#cfcaff")
-
- (fg-escape-char-construct . "#e7a59a")
- (fg-escape-char-backslash . "#abab00")
-
- (fg-lang-error . "#ef8690")
- (fg-lang-warning . "#b0aa00")
- (fg-lang-note . "#9d9def")
- (fg-lang-underline-error . "#ff4a6f")
- (fg-lang-underline-warning . "#d0de00")
- (fg-lang-underline-note . "#5f6fff")
-
- (fg-window-divider-inner . "#646464")
- (fg-window-divider-outer . "#969696")
-
- (fg-unfocused . "#93959b")
-
- (fg-docstring . "#b0d6f5")
- (fg-comment-yellow . "#d0a070")
-
- (bg-header . "#212121") (fg-header . "#dddddd")
-
- (bg-whitespace . "#101424") (fg-whitespace . "#aa9e9f")
-
- (bg-diff-heading . "#304466") (fg-diff-heading . "#dae7ff")
- (bg-diff-added . "#0a280a") (fg-diff-added . "#94ba94")
- (bg-diff-added-deuteran . "#001a3f") (fg-diff-added-deuteran . "#c4cdf2")
- (bg-diff-changed . "#2a2000") (fg-diff-changed . "#b0ba9f")
- (bg-diff-removed . "#40160f") (fg-diff-removed . "#c6adaa")
-
- (bg-diff-refine-added . "#005a36") (fg-diff-refine-added . "#e0f6e0")
- (bg-diff-refine-added-deuteran . "#234f8f") (fg-diff-refine-added-deuteran . "#dde4ff")
- (bg-diff-refine-changed . "#585800") (fg-diff-refine-changed . "#ffffcc")
- (bg-diff-refine-removed . "#852828") (fg-diff-refine-removed . "#ffd9eb")
-
- (bg-diff-focus-added . "#1d3c25") (fg-diff-focus-added . "#b4ddb4")
- (bg-diff-focus-added-deuteran . "#003959") (fg-diff-focus-added-deuteran . "#bfe4ff")
- (bg-diff-focus-changed . "#424200") (fg-diff-focus-changed . "#d0daaf")
- (bg-diff-focus-removed . "#601f29") (fg-diff-focus-removed . "#eebdba")
-
- (bg-mark-sel . "#002f2f") (fg-mark-sel . "#60cfa2")
- (bg-mark-del . "#5a0000") (fg-mark-del . "#ff99aa")
- (bg-mark-alt . "#3f2210") (fg-mark-alt . "#f0aa20"))
- "The entire palette of the `modus-vivendi' theme.
-Each element has the form (NAME . HEX) with the former as a
-symbol and the latter as a string.")
-
-;;; Custom faces
+;;;; Custom faces
;; These faces are used internally to ensure consistency between various
;; groups and to streamline the evaluation of relevant customization
;; options.
-(defface modus-themes-subtle-red nil
- "Subtle red background combined with a dimmed foreground.
-This is used for general purpose highlighting, mostly in buffers
-or for completion interfaces.
-
-The actual styling of the face is done by `modus-themes-faces'."
- :group 'modus-themes-faces)
-
-(defface modus-themes-subtle-green nil
- "Subtle green background combined with a dimmed foreground.
-This is used for general purpose highlighting, mostly in buffers
-or for completion interfaces.
-
-The actual styling of the face is done by `modus-themes-faces'."
- :group 'modus-themes-faces)
-
-(defface modus-themes-subtle-yellow nil
- "Subtle yellow background combined with a dimmed foreground.
-This is used for general purpose highlighting, mostly in buffers
-or for completion interfaces.
-
-The actual styling of the face is done by `modus-themes-faces'."
- :group 'modus-themes-faces)
-
-(defface modus-themes-subtle-blue nil
- "Subtle blue background combined with a dimmed foreground.
-This is used for general purpose highlighting, mostly in buffers
-or for completion interfaces.
-
-The actual styling of the face is done by `modus-themes-faces'."
- :group 'modus-themes-faces)
-
-(defface modus-themes-subtle-magenta nil
- "Subtle magenta background combined with a dimmed foreground.
-This is used for general purpose highlighting, mostly in buffers
-or for completion interfaces.
-
-The actual styling of the face is done by `modus-themes-faces'."
- :group 'modus-themes-faces)
-
-(defface modus-themes-subtle-cyan nil
- "Subtle cyan background combined with a dimmed foreground.
-This is used for general purpose highlighting, mostly in buffers
-or for completion interfaces.
-
-The actual styling of the face is done by `modus-themes-faces'."
- :group 'modus-themes-faces)
-
-(defface modus-themes-subtle-neutral nil
- "Subtle gray background combined with a dimmed foreground.
-This is used for general purpose highlighting, mostly in buffers
-or for completion interfaces.
-
-The actual styling of the face is done by `modus-themes-faces'."
- :group 'modus-themes-faces)
-
-(defface modus-themes-intense-red nil
- "Intense red background combined with the main foreground.
-This is used for general purpose highlighting, mostly in buffers
-or for completion interfaces.
-
-The actual styling of the face is done by `modus-themes-faces'."
- :group 'modus-themes-faces)
-
-(defface modus-themes-intense-green nil
- "Intense green background combined with the main foreground.
-This is used for general purpose highlighting, mostly in buffers
-or for completion interfaces.
-
-The actual styling of the face is done by `modus-themes-faces'."
- :group 'modus-themes-faces)
-
-(defface modus-themes-intense-yellow nil
- "Intense yellow background combined with the main foreground.
-This is used for general purpose highlighting, mostly in buffers
-or for completion interfaces.
-
-The actual styling of the face is done by `modus-themes-faces'."
- :group 'modus-themes-faces)
-
-(defface modus-themes-intense-blue nil
- "Intense blue background combined with the main foreground.
-This is used for general purpose highlighting, mostly in buffers
-or for completion interfaces.
-
-The actual styling of the face is done by `modus-themes-faces'."
- :group 'modus-themes-faces)
-
-(defface modus-themes-intense-magenta nil
- "Intense magenta background combined with the main foreground.
-This is used for general purpose highlighting, mostly in buffers
-or for completion interfaces.
-
-The actual styling of the face is done by `modus-themes-faces'."
- :group 'modus-themes-faces)
-
-(defface modus-themes-intense-cyan nil
- "Intense cyan background combined with the main foreground.
-This is used for general purpose highlighting, mostly in buffers
-or for completion interfaces.
-
-The actual styling of the face is done by `modus-themes-faces'."
- :group 'modus-themes-faces)
-
-(defface modus-themes-intense-neutral nil
- "Intense gray background combined with the main foreground.
-This is used for general purpose highlighting, mostly in buffers
-or for completion interfaces.
-
-The actual styling of the face is done by `modus-themes-faces'."
- :group 'modus-themes-faces)
-
-(defface modus-themes-refine-red nil
- "Combination of accented red background and foreground.
-This is used for general purpose highlighting, mostly in buffers
-or for completion interfaces.
-
-The actual styling of the face is done by `modus-themes-faces'."
- :group 'modus-themes-faces)
-
-(defface modus-themes-refine-green nil
- "Combination of accented green background and foreground.
-This is used for general purpose highlighting, mostly in buffers
-or for completion interfaces.
-
-The actual styling of the face is done by `modus-themes-faces'."
- :group 'modus-themes-faces)
-
-(defface modus-themes-refine-yellow nil
- "Combination of accented yellow background and foreground.
-This is used for general purpose highlighting, mostly in buffers
-or for completion interfaces.
-
-The actual styling of the face is done by `modus-themes-faces'."
- :group 'modus-themes-faces)
-
-(defface modus-themes-refine-blue nil
- "Combination of accented blue background and foreground.
-This is used for general purpose highlighting, mostly in buffers
-or for completion interfaces.
-
-The actual styling of the face is done by `modus-themes-faces'."
- :group 'modus-themes-faces)
-
-(defface modus-themes-refine-magenta nil
- "Combination of accented magenta background and foreground.
-This is used for general purpose highlighting, mostly in buffers
-or for completion interfaces.
-
-The actual styling of the face is done by `modus-themes-faces'."
- :group 'modus-themes-faces)
-
-(defface modus-themes-refine-cyan nil
- "Combination of accented cyan background and foreground.
-This is used for general purpose highlighting, mostly in buffers
-or for completion interfaces.
-
-The actual styling of the face is done by `modus-themes-faces'."
- :group 'modus-themes-faces)
-
-(defface modus-themes-active-red nil
- "A red background meant for use on the mode line or similar.
-This is combined with the mode lines primary foreground value.
-
-The actual styling of the face is done by `modus-themes-faces'."
- :group 'modus-themes-faces)
-
-(defface modus-themes-active-green nil
- "A green background meant for use on the mode line or similar.
-This is combined with the mode lines primary foreground value.
-
-The actual styling of the face is done by `modus-themes-faces'."
- :group 'modus-themes-faces)
-(defface modus-themes-active-yellow nil
- "A yellow background meant for use on the mode line or similar.
-This is combined with the mode lines primary foreground value.
-
-The actual styling of the face is done by `modus-themes-faces'."
- :group 'modus-themes-faces)
-
-(defface modus-themes-active-blue nil
- "A blue background meant for use on the mode line or similar.
-This is combined with the mode lines primary foreground value.
-
-The actual styling of the face is done by `modus-themes-faces'."
- :group 'modus-themes-faces)
-
-(defface modus-themes-active-magenta nil
- "A magenta background meant for use on the mode line or similar.
-This is combined with the mode lines primary foreground value.
-
-The actual styling of the face is done by `modus-themes-faces'."
- :group 'modus-themes-faces)
-
-(defface modus-themes-active-cyan nil
- "A cyan background meant for use on the mode line or similar.
-This is combined with the mode lines primary foreground value.
-
-The actual styling of the face is done by `modus-themes-faces'."
- :group 'modus-themes-faces)
-
-(defface modus-themes-fringe-red nil
- "A red background meant for use on the fringe or similar.
-This is combined with the main foreground value.
-
-The actual styling of the face is done by `modus-themes-faces'."
- :group 'modus-themes-faces)
-
-(defface modus-themes-fringe-green nil
- "A green background meant for use on the fringe or similar.
-This is combined with the main foreground value.
-
-The actual styling of the face is done by `modus-themes-faces'."
- :group 'modus-themes-faces)
-
-(defface modus-themes-fringe-yellow nil
- "A yellow background meant for use on the fringe or similar.
-This is combined with the main foreground value.
-
-The actual styling of the face is done by `modus-themes-faces'."
- :group 'modus-themes-faces)
-
-(defface modus-themes-fringe-blue nil
- "A blue background meant for use on the fringe or similar.
-This is combined with the main foreground value.
-
-The actual styling of the face is done by `modus-themes-faces'."
- :group 'modus-themes-faces)
-
-(defface modus-themes-fringe-magenta nil
- "A magenta background meant for use on the fringe or similar.
-This is combined with the main foreground value.
-
-The actual styling of the face is done by `modus-themes-faces'."
- :group 'modus-themes-faces)
-
-(defface modus-themes-fringe-cyan nil
- "A cyan background meant for use on the fringe or similar.
-This is combined with the main foreground value.
-
-The actual styling of the face is done by `modus-themes-faces'."
- :group 'modus-themes-faces)
-
-(defface modus-themes-nuanced-red nil
- "A nuanced red background.
-This does not specify a foreground of its own. Instead it is
-meant to serve as the backdrop for elements such as Org blocks,
-headings, and any other surface that needs to retain the colors
-on display.
-
-The actual styling of the face is done by `modus-themes-faces'."
- :group 'modus-themes-faces)
-
-(defface modus-themes-nuanced-green nil
- "A nuanced green background.
-This does not specify a foreground of its own. Instead it is
-meant to serve as the backdrop for elements such as Org blocks,
-headings, and any other surface that needs to retain the colors
-on display.
-
-The actual styling of the face is done by `modus-themes-faces'."
- :group 'modus-themes-faces)
-
-(defface modus-themes-nuanced-yellow nil
- "A nuanced yellow background.
-This does not specify a foreground of its own. Instead it is
-meant to serve as the backdrop for elements such as Org blocks,
-headings, and any other surface that needs to retain the colors
-on display.
-
-The actual styling of the face is done by `modus-themes-faces'."
- :group 'modus-themes-faces)
-
-(defface modus-themes-nuanced-blue nil
- "A nuanced blue background.
-This does not specify a foreground of its own. Instead it is
-meant to serve as the backdrop for elements such as Org blocks,
-headings, and any other surface that needs to retain the colors
-on display.
-
-The actual styling of the face is done by `modus-themes-faces'."
- :group 'modus-themes-faces)
-
-(defface modus-themes-nuanced-magenta nil
- "A nuanced magenta background.
-This does not specify a foreground of its own. Instead it is
-meant to serve as the backdrop for elements such as Org blocks,
-headings, and any other surface that needs to retain the colors
-on display.
-
-The actual styling of the face is done by `modus-themes-faces'."
- :group 'modus-themes-faces)
-
-(defface modus-themes-nuanced-cyan nil
- "A nuanced cyan background.
-This does not specify a foreground of its own. Instead it is
-meant to serve as the backdrop for elements such as Org blocks,
-headings, and any other surface that needs to retain the colors
-on display.
-
-The actual styling of the face is done by `modus-themes-faces'."
- :group 'modus-themes-faces)
-
-(defface modus-themes-special-cold nil
- "Combines the special cold background and foreground values.
-This is intended for cases when a neutral gray background is not
-suitable and where a combination of more saturated colors would
-not be appropriate.
-
-The actual styling of the face is done by `modus-themes-faces'."
- :group 'modus-themes-faces)
-
-(defface modus-themes-special-mild nil
- "Combines the special mild background and foreground values.
-This is intended for cases when a neutral gray background is not
-suitable and where a combination of more saturated colors would
-not be appropriate.
-
-The actual styling of the face is done by `modus-themes-faces'."
- :group 'modus-themes-faces)
-
-(defface modus-themes-special-warm nil
- "Combines the special warm background and foreground values.
-This is intended for cases when a neutral gray background is not
-suitable and where a combination of more saturated colors would
-not be appropriate.
-
-The actual styling of the face is done by `modus-themes-faces'."
- :group 'modus-themes-faces)
-
-(defface modus-themes-special-calm nil
- "Combines the special calm background and foreground values.
-This is intended for cases when a neutral gray background is not
-suitable and where a combination of more saturated colors would
-not be appropriate.
-
-The actual styling of the face is done by `modus-themes-faces'."
- :group 'modus-themes-faces)
-
-(defface modus-themes-diff-added nil
- "Combines green colors for the added state in diffs.
-The applied colors are contingent on the value assigned to
-`modus-themes-diffs'.
-
-The actual styling of the face is done by `modus-themes-faces'."
- :group 'modus-themes-faces)
-
-(defface modus-themes-diff-changed nil
- "Combines yellow colors for the changed state in diffs.
-The applied colors are contingent on the value assigned to
-`modus-themes-diffs'.
-
-The actual styling of the face is done by `modus-themes-faces'."
- :group 'modus-themes-faces)
-
-(defface modus-themes-diff-removed nil
- "Combines red colors for the removed state in diffs.
-The applied colors are contingent on the value assigned to
-`modus-themes-diffs'.
-
-The actual styling of the face is done by `modus-themes-faces'."
- :group 'modus-themes-faces)
-
-(defface modus-themes-diff-refine-added nil
- "Combines green colors for word-wise added state in diffs.
-The applied colors are contingent on the value assigned to
-`modus-themes-diffs'.
-
-The actual styling of the face is done by `modus-themes-faces'."
- :group 'modus-themes-faces)
-
-(defface modus-themes-diff-refine-changed nil
- "Combines yellow colors for word-wise changed state in diffs.
-The applied colors are contingent on the value assigned to
-`modus-themes-diffs'.
-
-The actual styling of the face is done by `modus-themes-faces'."
- :group 'modus-themes-faces)
-
-(defface modus-themes-diff-refine-removed nil
- "Combines red colors for word-wise removed state in diffs.
-The applied colors are contingent on the value assigned to
-`modus-themes-diffs'.
-
-The actual styling of the face is done by `modus-themes-faces'."
- :group 'modus-themes-faces)
-
-(defface modus-themes-diff-focus-added nil
- "Combines green colors for the focused added state in diffs.
-The applied colors are contingent on the value assigned to
-`modus-themes-diffs'.
-
-The actual styling of the face is done by `modus-themes-faces'."
- :group 'modus-themes-faces)
-
-(defface modus-themes-diff-focus-changed nil
- "Combines yellow colors for the focused changed state in diffs.
-The applied colors are contingent on the value assigned to
-`modus-themes-diffs'.
-
-The actual styling of the face is done by `modus-themes-faces'."
- :group 'modus-themes-faces)
-
-(defface modus-themes-diff-focus-removed nil
- "Combines red colors for the focused removed state in diffs.
-The applied colors are contingent on the value assigned to
-`modus-themes-diffs'.
-
-The actual styling of the face is done by `modus-themes-faces'."
- :group 'modus-themes-faces)
-
-(defface modus-themes-diff-heading nil
- "Combines blue colors for the diff hunk heading.
-The applied colors are contingent on the value assigned to
-`modus-themes-diffs'.
-
-The actual styling of the face is done by `modus-themes-faces'."
- :group 'modus-themes-faces)
-
-(defface modus-themes-pseudo-header nil
- "Generic style for some elements that function like headings.
-The actual styling of the face is done by `modus-themes-faces'."
- :group 'modus-themes-faces)
-
-(defface modus-themes-mark-alt nil
- "Combines yellow colors for marking special lines.
-This is intended for use in modes such as Dired, Ibuffer, Proced.
-
-The actual styling of the face is done by `modus-themes-faces'."
- :group 'modus-themes-faces)
-
-(defface modus-themes-mark-del nil
- "Combines red colors for marking deletable lines.
-This is intended for use in modes such as Dired, Ibuffer, Proced.
-
-The actual styling of the face is done by `modus-themes-faces'."
- :group 'modus-themes-faces)
-
-(defface modus-themes-mark-sel nil
- "Combines green colors for marking lines.
-This is intended for use in modes such as Dired, Ibuffer, Proced.
-
-The actual styling of the face is done by `modus-themes-faces'."
- :group 'modus-themes-faces)
-
-(defface modus-themes-mark-symbol nil
- "Applies a blue color and other styles for mark indicators.
-This is intended for use in modes such as Dired, Ibuffer, Proced.
-
-The actual styling of the face is done by `modus-themes-faces'."
- :group 'modus-themes-faces)
-
-(defface modus-themes-heading-0 nil
- "General purpose face for use as the document's title.
-The exact attributes assigned to this face are contingent on the
-values assigned to the `modus-themes-headings' variable.
-
-The actual styling of the face is done by `modus-themes-faces'."
- :group 'modus-themes-faces)
-
-(defface modus-themes-heading-1 nil
- "General purpose face for use in headings level 1.
-The exact attributes assigned to this face are contingent on the
-values assigned to the `modus-themes-headings' variable.
-
-The actual styling of the face is done by `modus-themes-faces'."
- :group 'modus-themes-faces)
-
-(defface modus-themes-heading-2 nil
- "General purpose face for use in headings level 2.
-The exact attributes assigned to this face are contingent on the
-values assigned to the `modus-themes-headings' variable.
-
-The actual styling of the face is done by `modus-themes-faces'."
- :group 'modus-themes-faces)
-
-(defface modus-themes-heading-3 nil
- "General purpose face for use in headings level 3.
-The exact attributes assigned to this face are contingent on the
-values assigned to the `modus-themes-headings' variable.
-
-The actual styling of the face is done by `modus-themes-faces'."
- :group 'modus-themes-faces)
-
-(defface modus-themes-heading-4 nil
- "General purpose face for use in headings level 4.
-The exact attributes assigned to this face are contingent on the
-values assigned to the `modus-themes-headings' variable.
-
-The actual styling of the face is done by `modus-themes-faces'."
- :group 'modus-themes-faces)
-
-(defface modus-themes-heading-5 nil
- "General purpose face for use in headings level 5.
-The exact attributes assigned to this face are contingent on the
-values assigned to the `modus-themes-headings' variable.
-
-The actual styling of the face is done by `modus-themes-faces'."
- :group 'modus-themes-faces)
-
-(defface modus-themes-heading-6 nil
- "General purpose face for use in headings level 6.
-The exact attributes assigned to this face are contingent on the
-values assigned to the `modus-themes-headings' variable.
-
-The actual styling of the face is done by `modus-themes-faces'."
- :group 'modus-themes-faces)
-
-(defface modus-themes-heading-7 nil
- "General purpose face for use in headings level 7.
-The exact attributes assigned to this face are contingent on the
-values assigned to the `modus-themes-headings' variable.
-
-The actual styling of the face is done by `modus-themes-faces'."
- :group 'modus-themes-faces)
-
-(defface modus-themes-heading-8 nil
- "General purpose face for use in headings level 8.
-The exact attributes assigned to this face are contingent on the
-values assigned to the `modus-themes-headings' variable.
-
-The actual styling of the face is done by `modus-themes-faces'."
- :group 'modus-themes-faces)
-
-(defface modus-themes-hl-line nil
- "General purpose face for the current line.
-The exact attributes assigned to this face are contingent on the
-values assigned to the `modus-themes-hl-line' variable.
-
-The actual styling of the face is done by `modus-themes-faces'."
- :group 'modus-themes-faces)
+(dolist (color '( red green blue yellow magenta cyan
+ red-warmer green-warmer blue-warmer yellow-warmer magenta-warmer cyan-warmer
+ red-cooler green-cooler blue-cooler yellow-cooler magenta-cooler cyan-cooler
+ red-faint green-faint blue-faint yellow-faint magenta-faint cyan-faint
+ red-intense green-intense blue-intense yellow-intense magenta-intense cyan-intense))
+ (custom-declare-face
+ (intern (format "modus-themes-fg-%s" color))
+ nil (format "Face with %s foreground." color)
+ :package-version '(modus-themes . "4.0.0")
+ :version "30.1"
+ :group 'modus-themes-faces))
+
+(dolist (color '(red green yellow blue magenta cyan))
+ (custom-declare-face
+ (intern (format "modus-themes-nuanced-%s" color))
+ nil (format "Nuanced %s background." color)
+ :package-version '(modus-themes . "4.1.0")
+ :version "30.1"
+ :group 'modus-themes-faces))
+
+(dolist (color '(red green yellow blue magenta cyan))
+ (custom-declare-face
+ (intern (format "modus-themes-subtle-%s" color))
+ nil (format "Subtle %s background." color)
+ :package-version '(modus-themes . "4.0.0")
+ :version "30.1"
+ :group 'modus-themes-faces))
+
+(dolist (color '(red green yellow blue magenta cyan))
+ (custom-declare-face
+ (intern (format "modus-themes-intense-%s" color))
+ nil (format "Intense %s background." color)
+ :package-version '(modus-themes . "4.0.0")
+ :version "30.1"
+ :group 'modus-themes-faces))
+
+(dolist (scope '(alt del sel))
+ (custom-declare-face
+ (intern (format "modus-themes-mark-%s" scope))
+ nil (format "Mark of type %s." scope)
+ :package-version '(modus-themes . "4.0.0")
+ :version "30.1"
+ :group 'modus-themes-faces))
+
+(dolist (scope '(note warning error))
+ (custom-declare-face
+ (intern (format "modus-themes-lang-%s" scope))
+ nil (format "Linter or spell check of type %s." scope)
+ :package-version '(modus-themes . "4.0.0")
+ :version "30.1"
+ :group 'modus-themes-faces))
+
+(dolist (scope '(note warning error))
+ (custom-declare-face
+ (intern (format "modus-themes-prominent-%s" scope))
+ nil (format "Prominent notification of type %s." scope)
+ :package-version '(modus-themes . "4.2.0")
+ :version "30.1"
+ :group 'modus-themes-faces))
+
+(dolist (scope '(current lazy replace))
+ (custom-declare-face
+ (intern (format "modus-themes-search-%s" scope))
+ nil (format "Search of type %s." scope)
+ :package-version '(modus-themes . "4.0.0")
+ :version "30.1"
+ :group 'modus-themes-faces))
+
+(dotimes (n 4)
+ (custom-declare-face
+ (intern (format "modus-themes-search-rx-group-%s" n))
+ nil (format "Search regexp group number %s." n)
+ :package-version '(modus-themes . "4.4.0")
+ :version "30.1"
+ :group 'modus-themes-faces))
+
+(dolist (scope '(code macro verbatim))
+ (custom-declare-face
+ (intern (format "modus-themes-prose-%s" scope))
+ nil (format "Construct of type %s for prose." scope)
+ :package-version '(modus-themes . "4.0.0")
+ :version "30.1"
+ :group 'modus-themes-faces))
+
+(dotimes (n 9)
+ (custom-declare-face
+ (intern (format "modus-themes-heading-%d" n))
+ nil (format "Level %d heading." n)
+ :package-version '(modus-themes . "4.0.0")
+ :version "30.1"
+ :group 'modus-themes-faces))
(defface modus-themes-bold nil
"Generic face for applying a conditional bold weight.
-This behaves in accordance with `modus-themes-bold-constructs'.
-
-The actual styling of the face is done by `modus-themes-faces'."
+This behaves in accordance with `modus-themes-bold-constructs'."
+ :package-version '(modus-themes . "4.0.0")
+ :version "30.1"
:group 'modus-themes-faces)
(defface modus-themes-slant nil
"Generic face for applying a conditional slant (italics).
-This behaves in accordance with `modus-themes-italic-constructs'.
-
-The actual styling of the face is done by `modus-themes-faces'."
+This behaves in accordance with `modus-themes-italic-constructs'."
+ :package-version '(modus-themes . "4.0.0")
+ :version "30.1"
:group 'modus-themes-faces)
-(defface modus-themes-variable-pitch nil
- "Generic face for applying a conditional `variable-pitch'.
-This behaves in accordance with `modus-themes-mixed-fonts' and/or
-`modus-themes-variable-pitch-ui'.
-
-The actual styling of the face is done by `modus-themes-faces'."
+(defface modus-themes-key-binding nil
+ "Face for key bindings."
+ :package-version '(modus-themes . "4.0.0")
+ :version "30.1"
:group 'modus-themes-faces)
(defface modus-themes-fixed-pitch nil
- "Generic face for applying a conditional `fixed-pitch'.
-This behaves in accordance with `modus-themes-mixed-fonts'.
-
-The actual styling of the face is done by `modus-themes-faces'."
+ "Face for `fixed-pitch' if `modus-themes-mixed-fonts' is non-nil."
+ :package-version '(modus-themes . "4.0.0")
+ :version "30.1"
:group 'modus-themes-faces)
(defface modus-themes-ui-variable-pitch nil
- "Face for `modus-themes-variable-pitch-ui'.
-The actual styling of the face is done by `modus-themes-faces'."
- :group 'modus-themes-faces)
-
-(defface modus-themes-lang-note nil
- "Generic face for linter or spell checker notes.
-The exact attributes and color combinations are controlled by
-`modus-themes-lang-checkers'.
-
-The actual styling of the face is done by `modus-themes-faces'."
- :group 'modus-themes-faces)
-
-(defface modus-themes-lang-warning nil
- "Generic face for linter or spell checker warnings.
-The exact attributes and color combinations are controlled by
-`modus-themes-lang-checkers'.
-
-The actual styling of the face is done by `modus-themes-faces'."
- :group 'modus-themes-faces)
-
-(defface modus-themes-lang-error nil
- "Generic face for linter or spell checker errors.
-The exact attributes and color combinations are controlled by
-`modus-themes-lang-checkers'.
-
-The actual styling of the face is done by `modus-themes-faces'."
+ "Face for `variable-pitch' if `modus-themes-variable-pitch-ui' is non-nil."
+ :package-version '(modus-themes . "4.0.0")
+ :version "30.1"
:group 'modus-themes-faces)
(defface modus-themes-reset-soft nil
@@ -1243,231 +200,139 @@ The actual styling of the face is done by `modus-themes-faces'."
This is intended to be inherited by faces that should not retain
properties from their context (e.g. an overlay over an underlined
-text should not be underlined as well) yet still blend in. Also
-see `modus-themes-reset-hard'.
-
-The actual styling of the face is done by `modus-themes-faces'."
- :group 'modus-themes-faces)
-
-(defface modus-themes-reset-hard nil
- "Generic face to set all face properties to nil.
-
-This is intended to be inherited by faces that should not retain
-properties from their context (e.g. an overlay over an underlined
-text should not be underlined as well) and not blend in. Also
-see `modus-themes-reset-soft'.
-
-The actual styling of the face is done by `modus-themes-faces'."
- :group 'modus-themes-faces)
-
-(defface modus-themes-key-binding nil
- "Generic face for key bindings.
-The actual styling of the face is done by `modus-themes-faces'."
- :group 'modus-themes-faces)
-
-(defface modus-themes-search-success nil
- "Generic face for successful search.
-The actual styling of the face is done by `modus-themes-faces'."
- :group 'modus-themes-faces)
-
-(defface modus-themes-search-success-modeline nil
- "Generic mode line indicator for successful search.
-The actual styling of the face is done by `modus-themes-faces'."
- :group 'modus-themes-faces)
-
-(defface modus-themes-search-success-lazy nil
- "Generic face for successful, lazily highlighted search.
-The actual styling of the face is done by `modus-themes-faces'."
+text should not be underlined as well) yet still blend in."
:group 'modus-themes-faces)
(defface modus-themes-prompt nil
- "Generic face for command prompts.
-The actual styling of the face is done by `modus-themes-faces'."
- :group 'modus-themes-faces)
-
-;; "Grue" is "green" and "blue".
-(defface modus-themes-grue nil
- "Generic face for `modus-themes-deuteranopia' foreground.
-The actual styling of the face is done by `modus-themes-faces'."
- :group 'modus-themes-faces)
-
-(defface modus-themes-grue-active nil
- "Face for `modus-themes-deuteranopia' active foreground.
-The actual styling of the face is done by `modus-themes-faces'."
- :group 'modus-themes-faces)
-
-(defface modus-themes-grue-nuanced nil
- "Face for `modus-themes-deuteranopia' nuanced foreground.
-The actual styling of the face is done by `modus-themes-faces'."
- :group 'modus-themes-faces)
-
-(defface modus-themes-grue-background-active nil
- "Face for `modus-themes-deuteranopia' active background.
-The actual styling of the face is done by `modus-themes-faces'."
- :group 'modus-themes-faces)
-
-(defface modus-themes-grue-background-intense nil
- "Face for `modus-themes-deuteranopia' intense background.
-The actual styling of the face is done by `modus-themes-faces'."
- :group 'modus-themes-faces)
-
-(defface modus-themes-grue-background-subtle nil
- "Face for `modus-themes-deuteranopia' subtle background.
-The actual styling of the face is done by `modus-themes-faces'."
- :group 'modus-themes-faces)
-
-(defface modus-themes-grue-background-refine nil
- "Face for `modus-themes-deuteranopia' refined background.
-The actual styling of the face is done by `modus-themes-faces'."
- :group 'modus-themes-faces)
-
-(defface modus-themes-link-symlink nil
- "Face for `modus-themes-links' symbolic link.
-The actual styling of the face is done by `modus-themes-faces'."
- :group 'modus-themes-faces)
-
-(defface modus-themes-link-broken nil
- "Face for `modus-themes-links' broken link.
-The actual styling of the face is done by `modus-themes-faces'."
- :group 'modus-themes-faces)
-
-(defface modus-themes-tab-backdrop nil
- "Face of backdrop in tabbed interfaces.
-The actual styling of the face is done by `modus-themes-faces'."
- :group 'modus-themes-faces)
-
-(defface modus-themes-tab-active nil
- "Face of active tab.
-The actual styling of the face is done by `modus-themes-faces'."
- :group 'modus-themes-faces)
-
-(defface modus-themes-tab-inactive nil
- "Face of inactive tab.
-The actual styling of the face is done by `modus-themes-faces'."
- :group 'modus-themes-faces)
-
-(defface modus-themes-markup-code nil
- "Face of inline code markup.
-The actual styling of the face is done by `modus-themes-faces'."
- :group 'modus-themes-faces)
-
-(defface modus-themes-markup-macro nil
- "Face of macro markup.
-The actual styling of the face is done by `modus-themes-faces'."
- :group 'modus-themes-faces)
-
-(defface modus-themes-markup-verbatim nil
- "Face of verbatim markup.
-The actual styling of the face is done by `modus-themes-faces'."
+ "Generic face for command prompts."
:group 'modus-themes-faces)
(defface modus-themes-completion-selected nil
- "Face for current selection in completion UIs.
-The actual styling of the face is done by `modus-themes-faces'."
- :group 'modus-themes-faces)
-
-(defface modus-themes-completion-selected-popup nil
- "Face for current selection in completion UI popups.
-The actual styling of the face is done by `modus-themes-faces'."
- :group 'modus-themes-faces)
-
-(defface modus-themes-completion-match-0 nil
- "Face for completions matches 0.
-The actual styling of the face is done by `modus-themes-faces'."
+ "Face for current selection in completion UIs."
:group 'modus-themes-faces)
-(defface modus-themes-completion-match-1 nil
- "Face for completions matches 1.
-The actual styling of the face is done by `modus-themes-faces'."
+(defface modus-themes-button nil
+ "Face for graphical buttons."
:group 'modus-themes-faces)
-(defface modus-themes-completion-match-2 nil
- "Face for completions matches 2.
-The actual styling of the face is done by `modus-themes-faces'."
- :group 'modus-themes-faces)
-
-(defface modus-themes-completion-match-3 nil
- "Face for completions matches 3.
-The actual styling of the face is done by `modus-themes-faces'."
- :group 'modus-themes-faces)
-
-(defface modus-themes-box-button nil
- "Face for widget buttons (e.g. in the Custom UI).
-The actual styling of the face is done by `modus-themes-faces'."
- :group 'modus-themes-faces)
-
-(defface modus-themes-box-button-pressed nil
- "Face for pressed widget buttons (e.g. in the Custom UI).
-The actual styling of the face is done by `modus-themes-faces'."
- :group 'modus-themes-faces)
+(dotimes (n 4)
+ (custom-declare-face
+ (intern (format "modus-themes-completion-match-%d" n))
+ nil (format "Completions match level %d." n)
+ :package-version '(modus-themes . "4.0.0")
+ :version "30.1"
+ :group 'modus-themes-faces))
-;;; Customization variables
+;;;; Customization variables
-(defcustom modus-themes-inhibit-reload t
- "Control theme reload when setting options with Customize.
+(defcustom modus-themes-custom-auto-reload t
+ "Automatically reload theme after setting options with Customize.
-By default, customizing a theme-related user option through the
-Custom interfaces or with `customize-set-variable' will not
-reload the currently active Modus theme.
+All theme user options take effect when a theme is loaded. Any
+subsequent changes require the theme to be reloaded.
-Enable this behavior by setting this variable to nil."
+When this variable has a non-nil value, any change made via the
+Custom UI or related functions such as `customize-set-variable'
+and `setopt' (Emacs 29), will trigger a reload automatically.
+
+With a nil value, changes to user options have no further
+consequences. The user must manually reload the theme."
:group 'modus-themes
- :package-version '(modus-themes . "1.5.0")
- :version "28.1"
+ :package-version '(modus-themes . "4.0.0")
+ :version "30.1"
:type 'boolean
:link '(info-link "(modus-themes) Custom reload theme"))
(defun modus-themes--set-option (sym val)
"Custom setter for theme related user options.
Will set SYM to VAL, and reload the current theme, unless
-`modus-themes-inhibit-reload' is non-nil."
+`modus-themes-custom-auto-reload' is nil."
(set-default sym val)
- (unless (or modus-themes-inhibit-reload
- ;; Check if a theme is being loaded, in which case we
- ;; don't want to reload a theme if the setter is
- ;; invoked. `custom--inhibit-theme-enable' is set to nil
- ;; by `enable-theme'.
- (null (bound-and-true-p custom--inhibit-theme-enable)))
- (let ((modus-themes-inhibit-reload t))
- (pcase (modus-themes--current-theme)
- ('modus-operandi (modus-themes-load-operandi))
- ('modus-vivendi (modus-themes-load-vivendi))))))
-
-(defcustom modus-themes-operandi-color-overrides nil
- "Override colors in the Modus Operandi palette.
-
-For form, see `modus-themes-operandi-colors'."
+ (when (and modus-themes-custom-auto-reload
+ ;; Check if a theme is being loaded, in which case we
+ ;; don't want to reload a theme if the setter is
+ ;; invoked. `custom--inhibit-theme-enable' is set to nil
+ ;; by `enable-theme'.
+ (bound-and-true-p custom--inhibit-theme-enable))
+ (when-let* ((modus-themes-custom-auto-reload t)
+ (theme (modus-themes--current-theme)))
+ (modus-themes-load-theme theme))))
+
+(defcustom modus-themes-disable-other-themes t
+ "Disable all other themes when loading a Modus theme.
+
+When the value is non-nil, the commands `modus-themes-toggle' and
+`modus-themes-select', as well as the `modus-themes-load-theme'
+function, will disable all other themes while loading the
+specified Modus theme. This is done to ensure that Emacs does
+not blend two or more themes: such blends lead to awkward results
+that undermine the work of the designer.
+
+When the value is nil, the aforementioned commands and function
+will only disable other themes within the Modus collection.
+
+This option is provided because Emacs themes are not necessarily
+limited to colors/faces: they can consist of an arbitrary set of
+customizations. Users who use such customization bundles must
+set this variable to a nil value."
:group 'modus-themes
- :package-version '(modus-themes . "1.1.0")
- :version "28.1"
- :type '(alist :key-type symbol :value-type color)
+ :package-version '(modus-themes . "4.1.0")
+ :version "30.1"
+ :type 'boolean
+ :link '(info-link "(modus-themes) Disable other themes"))
+
+(defvaralias 'modus-themes-collection 'modus-themes-items
+ "Alias of `modus-themes-items'.")
+
+(defconst modus-themes-items
+ '( modus-operandi modus-vivendi
+ modus-operandi-tinted modus-vivendi-tinted
+ modus-operandi-deuteranopia modus-vivendi-deuteranopia
+ modus-operandi-tritanopia modus-vivendi-tritanopia)
+ "Symbols of the Modus themes.")
+
+(defcustom modus-themes-to-toggle '(modus-operandi modus-vivendi)
+ "Specify two Modus themes for `modus-themes-toggle' command.
+The variable `modus-themes-items' contains the symbols of all
+official themes that form part of this collection.
+
+The default value of this user option includes the original
+themes: `modus-operandi' (light) and `modus-vivendi' (dark).
+
+If the value is nil or otherwise does not specify two valid Modus
+themes, the command `modus-themes-toggle' reverts to selecting a
+theme from the list of available Modus themes. In effect, it is
+the same as using the command `modus-themes-select'."
+ :type `(choice
+ (const :tag "No toggle" nil)
+ (list :tag "Pick two themes to toggle between"
+ (choice :tag "Theme one of two"
+ ,@(mapcar (lambda (theme)
+ (list 'const theme))
+ modus-themes-items))
+ (choice :tag "Theme two of two"
+ ,@(mapcar (lambda (theme)
+ (list 'const theme))
+ modus-themes-items))))
+ :package-version '(modus-themes . "4.0.0")
+ :version "30.1"
:set #'modus-themes--set-option
:initialize #'custom-initialize-default
- :link '(info-link "(modus-themes) Override colors"))
+ :group 'modus-themes)
-(defcustom modus-themes-vivendi-color-overrides nil
- "Override colors in the Modus Vivendi palette.
+(defvaralias 'modus-themes-post-load-hook 'modus-themes-after-load-theme-hook)
-For form, see `modus-themes-vivendi-colors'."
- :group 'modus-themes
- :package-version '(modus-themes . "1.1.0")
- :version "28.1"
- :type '(alist :key-type symbol :value-type color)
+(defcustom modus-themes-after-load-theme-hook nil
+ "Hook that runs after loading a Modus theme.
+This is used by the command `modus-themes-toggle'."
+ :type 'hook
+ :package-version '(modus-themes . "4.0.0")
+ :version "30.1"
:set #'modus-themes--set-option
:initialize #'custom-initialize-default
- :link '(info-link "(modus-themes) Override colors"))
-
-;; The byte compiler complains when a defcustom isn't a top level form
-(let* ((names (mapcar (lambda (pair)
- (symbol-name (car pair)))
- modus-themes-operandi-colors))
- (colors (mapcar #'intern (sort names #'string<))))
- (put 'modus-themes-operandi-color-overrides
- 'custom-options (copy-sequence colors))
- (put 'modus-themes-vivendi-color-overrides
- 'custom-options (copy-sequence colors)))
+ :group 'modus-themes)
(defvaralias 'modus-themes-slanted-constructs 'modus-themes-italic-constructs)
@@ -1510,7 +375,9 @@ tables and code blocks, to remain monospaced when users opt for
something like the command `variable-pitch-mode'.
Users may need to explicitly configure the font family of
-`fixed-pitch' in order to get a consistent experience."
+`fixed-pitch' in order to get a consistent experience with their
+typography (also check the `fontaine' package on GNU ELPA (by
+Protesilaos))."
:group 'modus-themes
:package-version '(modus-themes . "1.7.0")
:version "29.1"
@@ -1519,68 +386,58 @@ 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)
+(defconst modus-themes--weight-widget
+ '(choice :tag "Font weight (must be supported by the typeface)"
+ (const :tag "Unspecified (use whatever the default is)" nil)
+ (const :tag "Thin" thin)
+ (const :tag "Ultra-light" ultralight)
+ (const :tag "Extra-light" extralight)
+ (const :tag "Light" light)
+ (const :tag "Semi-light" semilight)
+ (const :tag "Regular" regular)
+ (const :tag "Medium" medium)
+ (const :tag "Semi-bold" semibold)
+ (const :tag "Bold" bold)
+ (const :tag "Extra-bold" extrabold)
+ (const :tag "Ultra-bold" ultrabold))
+ "List of supported font weights used by `defcustom' forms.")
+
+(defconst modus-themes--headings-widget
+ `(set :tag "Properties" :greedy t
(const :tag "Proportionately spaced font (variable-pitch)" variable-pitch)
- (const :tag "Overline" overline)
- (choice :tag "Font weight (must be supported by the typeface)"
- (const :tag "Bold (default)" nil)
- (const :tag "Thin" thin)
- (const :tag "Ultra-light" ultralight)
- (const :tag "Extra-light" extralight)
- (const :tag "Light" light)
- (const :tag "Semi-light" semilight)
- (const :tag "Regular" regular)
- (const :tag "Medium" medium)
- (const :tag "Semi-bold" semibold)
- (const :tag "Extra-bold" extrabold)
- (const :tag "Ultra-bold" ultrabold))
+ ,modus-themes--weight-widget
(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)
- (const :tag "Monochrome" monochrome)))
+ (float :tag "Floating point"))))
"Refer to the doc string of `modus-themes-headings'.
This is a helper variable intended for internal use.")
(defcustom modus-themes-headings nil
- "Heading styles with optional list of values for levels 0-8.
+ "Heading styles with optional list of values per heading level.
-This is an alist that accepts a (key . list-of-values)
-combination. The key is either a number, representing the
+This is an alist that accepts a (KEY . LIST-OF-VALUES)
+combination. The KEY is either a number, representing the
heading's level (0-8) or t, which pertains to the fallback style.
+The named keys `agenda-date' and `agenda-structure' apply to the
+Org agenda.
-Level 0 is a special heading: it is used for what counts as a
-document title or equivalent, such as the #+title construct we
-find in Org files. Levels 1-8 are regular headings.
+Level 0 is used for what counts as a document title or
+equivalent, such as the #+title construct we find in Org files.
+Levels 1-8 are regular headings.
-The list of values covers symbols that refer to properties, as
-described below. Here is a complete sample, followed by a
-presentation of all available properties:
+The LIST-OF-VALUES covers symbols that refer to properties, as
+described below. Here is a complete sample with various
+stylistic combinations, followed by a presentation of all
+available properties:
(setq modus-themes-headings
- (quote ((1 . (background overline variable-pitch 1.5))
- (2 . (overline rainbow 1.3))
- (3 . (overline 1.1))
- (t . (monochrome)))))
+ (quote ((1 . (variable-pitch 1.5))
+ (2 . (1.3))
+ (agenda-date . (1.3))
+ (agenda-structure . (variable-pitch light 1.8))
+ (t . (1.1)))))
By default (a nil value for this variable), all headings have a
bold typographic weight, use a desaturated text color, have a
@@ -1588,20 +445,6 @@ font family that is the same as the `default' face (typically
monospaced), and a height that is equal to the `default' face's
height.
-A `rainbow' property makes the text color more saturated.
-
-An `overline' property draws a line above the area of the
-heading.
-
-A `background' property applies a subtle tinted color to the
-background of the heading.
-
-A `monochrome' property makes the heading the same as the base
-color, which is that of the `default' face's foreground. When
-`background' is also set, `monochrome' changes its color to gray.
-If both `monochrome' and `rainbow' are set, the former takes
-precedence.
-
A `variable-pitch' property changes the font family of the
heading to that of the `variable-pitch' face (normally a
proportionately spaced typeface).
@@ -1611,9 +454,7 @@ accordingly, such as `light', `semibold', etc. Valid symbols are
defined in the variable `modus-themes-weights'. The absence of a
weight means that bold will be used by virtue of inheriting the
`bold' face (check the manual for tweaking bold and italic
-faces). For backward compatibility, the `no-bold' value is
-accepted, though users are encouraged to specify a `regular'
-weight instead.
+faces).
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
@@ -1626,19 +467,20 @@ Combinations of any of those properties are expressed as a list,
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
+ (variable-pitch semibold 1.3)
+ (variable-pitch semibold (height 1.3)) ; same as above
+ (variable-pitch semibold (height . 1.3)) ; same as above
The order in which the properties are set is not significant.
In user configuration files the form may look like this:
(setq modus-themes-headings
- (quote ((1 . (background overline rainbow 1.5))
- (2 . (background overline 1.3))
- (t . (overline semibold)))))
+ (quote ((1 . (variable-pitch 1.5))
+ (2 . (1.3))
+ (agenda-date . (1.3))
+ (agenda-structure . (variable-pitch light 1.8))
+ (t . (1.1)))))
When defining the styles per heading level, it is possible to
pass a non-nil value (t) instead of a list of properties. This
@@ -1646,566 +488,51 @@ will retain the original aesthetic for that level. For example:
(setq modus-themes-headings
(quote ((1 . t) ; keep the default style
- (2 . (background overline))
- (t . (rainbow))))) ; style for all other headings
+ (2 . (semibold 1.2))
+ (t . (variable-pitch))))) ; style for all other headings
(setq modus-themes-headings
- (quote ((1 . (background overline))
- (2 . (rainbow semibold))
+ (quote ((1 . (variable-pitch extrabold 1.5))
+ (2 . (semibold))
(t . t)))) ; default style for all other levels
-For Org users, the extent of the heading depends on the variable
-`org-fontify-whole-heading-line'. This affects the `overline'
-and `background' properties. Depending on the version of Org,
-there may be others, such as `org-fontify-done-headline'."
+Note that the text color of headings, of their background, and
+overline can all be set via the overrides. It is possible to
+have any color combination for any heading level (something that
+could not be done in older versions of the themes).
+
+Read Info node `(modus-themes) Option for palette overrides' as
+well as Info node `(modus-themes) Make headings more or less
+colorful'. Else check `modus-themes-common-palette-overrides'
+and related user options."
:group 'modus-themes
- :package-version '(modus-themes . "2.5.0")
- :version "29.1"
+ :package-version '(modus-themes . "4.0.0")
+ :version "30.1"
:type `(alist
:options ,(mapcar (lambda (el)
- (list el modus-themes--headings-choice))
- '(0 1 2 3 4 5 6 7 8 t))
+ (list el modus-themes--headings-widget))
+ '(0 1 2 3 4 5 6 7 8 t agenda-date agenda-structure))
:key-type symbol
- :value-type ,modus-themes--headings-choice)
+ :value-type ,modus-themes--headings-widget)
:set #'modus-themes--set-option
:initialize #'custom-initialize-default
:link '(info-link "(modus-themes) Heading styles"))
-(defcustom modus-themes-org-agenda nil
- "Control the style of individual Org agenda constructs.
-
-This is an alist that accepts a (key . value) combination. Here
-is a sample, followed by a description of all possible
-combinations:
-
- (setq modus-themes-org-agenda
- (quote ((header-block . (variable-pitch 1.5 semibold))
- (header-date . (grayscale workaholic bold-today 1.2))
- (event . (accented italic varied))
- (scheduled . uniform)
- (habit . traffic-light))))
-
-A `header-block' key applies to elements that concern the
-headings which demarcate blocks in the structure of the agenda.
-By default (a nil value) those are rendered in a bold typographic
-weight, plus a height that is slightly taller than the default
-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 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 weight means that bold will be used by virtue
- of inheriting the `bold' face (check the manual for tweaking
- bold and italic faces).
-
-In case both a number and `no-scale' are in the list, the latter
-takes precedence. If two numbers are specified, the first one is
-applied.
-
-Example usage:
-
- (header-block . nil)
- (header-block . (1.5))
- (header-block . (no-scale))
- (header-block . (variable-pitch 1.5))
- (header-block . (variable-pitch 1.5 semibold))
-
-A `header-date' key covers date headings. Dates use only a
-foreground color by default (a nil value), with weekdays and
-weekends having a slight difference in hueness. The current date
-has an added gray background. This key accepts a list of values
-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). 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:
-
- (header-date . nil)
- (header-date . (workaholic))
- (header-date . (grayscale bold-all))
- (header-date . (grayscale workaholic))
- (header-date . (grayscale workaholic bold-today))
- (header-date . (grayscale workaholic bold-today 1.2))
-
-An `event' key covers (i) headings with a plain time stamp that
-are shown on the agenda, also known as events, (ii) entries
-imported from the diary, and (iii) other items that derive from a
-symbolic expression or sexp (phases of the moon, holidays, etc.).
-By default all those look the same and have a subtle foreground
-color (the default is a nil value or an empty list). This key
-accepts a list of properties. Those are:
-
-- `accented' applies an accent value to the event's foreground,
- replacing the original gray. It makes all entries stand out more.
-- `italic' adds a slant to the font's forms (italic or oblique
- forms, depending on the typeface).
-- `varied' differentiates between events with a plain time stamp
- and entries that are generated from either the diary or a
- symbolic expression. It generally puts more emphasis on
- events. When `varied' is combined with `accented', it makes
- only events use an accent color, while diary/sexp entries
- retain their original subtle foreground. When `varied' is used
- in tandem with `italic', it applies a slant only to diary and
- sexp entries, not events. And when `varied' is the sole
- property passed to the `event' key, it has the same meaning as
- the list (italic varied). The combination of `varied',
- `accented', `italic' covers all of the aforementioned cases.
-
-For example:
-
- (event . nil)
- (event . (italic))
- (event . (accented italic))
- (event . (accented italic varied))
-
-A `scheduled' key applies to tasks with a scheduled date. By
-default (a nil value), these use varying shades of yellow to
-denote (i) a past or current date and (ii) a future date. Valid
-values are symbols:
-
-- nil (default);
-- `uniform' to make all scheduled dates the same color;
-- `rainbow' to use contrasting colors for past, present, future
- scheduled dates.
-
-For example:
-
- (scheduled . nil)
- (scheduled . uniform)
- (scheduled . rainbow)
-
-A `habit' key applies to the `org-habit' graph. All possible
-value are passed as a symbol. Those are:
-
-- The default (nil) is meant to conform with the original
- aesthetic of `org-habit'. It employs all four color codes that
- correspond to the org-habit states---clear, ready, alert, and
- overdue---while distinguishing between their present and future
- variants. This results in a total of eight colors in use: red,
- yellow, green, blue, in tinted and shaded versions. They cover
- the full set of information provided by the `org-habit'
- consistency graph.
-
-- `simplified' is like the default except that it removes the
- dichotomy between current and future variants by applying
- uniform color-coded values. It applies a total of four colors:
- red, yellow, green, blue. They produce a simplified
- consistency graph that is more legible (or less \"busy\") than
- the default. The intent is to shift focus towards the
- distinction between the four states of a habit task, rather
- than each state's present/future outlook.
-
-- `traffic-light' further reduces the available colors to red,
- yellow, and green. As in `simplified', present and future
- variants appear uniformly, but differently from it, the CLEAR
- state is rendered in a green hue, instead of the original blue.
- This is meant to capture the use-case where a habit task being
- too early is less important than it being too late. The
- difference between READY and CLEAR states is 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
- color deficiency by substituting every instance of green with
- blue or cyan (depending on the specifics).
-
-For example:
-
- (habit . nil)
- (habit . simplified)
- (habit . traffic-light)"
- :group 'modus-themes
- :package-version '(modus-themes . "2.3.0")
- :version "29.1"
- :type '(set
- (cons :tag "Block header"
- (const header-block)
- (set :tag "Header presentation" :greedy t
- (choice :tag "Font style"
- (const :tag "Use the original typeface (default)" nil)
- (const :tag "Use `variable-pitch' font" variable-pitch))
- (choice :tag "Font weight (must be supported by the typeface)"
- (const :tag "Bold (default)" nil)
- (const :tag "Thin" thin)
- (const :tag "Ultra-light" ultralight)
- (const :tag "Extra-light" extralight)
- (const :tag "Light" light)
- (const :tag "Semi-light" semilight)
- (const :tag "Regular" regular)
- (const :tag "Medium" medium)
- (const :tag "Semi-bold" semibold)
- (const :tag "Extra-bold" extrabold)
- (const :tag "Ultra-bold" ultrabold))
- (radio :tag "Scaling"
- (const :tag "Slight increase in height (default)" nil)
- (const :tag "Do not scale" no-scale)
- (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
- (const :tag "Use grayscale for date headers" grayscale)
- (const :tag "Do not differentiate weekdays from weekends" workaholic)
- (const :tag "Make today bold" bold-today)
- (const :tag "Make all dates bold" bold-all)
- (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
- (const :tag "Apply an accent color" accented)
- (const :tag "Italic font slant (oblique forms)" italic)
- (const :tag "Differentiate events from diary/sexp entries" varied)))
- (cons :tag "Scheduled tasks"
- (const scheduled)
- (choice (const :tag "Yellow colors to distinguish current and future tasks (default)" nil)
- (const :tag "Uniform subtle warm color for all scheduled tasks" uniform)
- (const :tag "Rainbow-colored scheduled tasks" rainbow)))
- (cons :tag "Habit graph"
- (const habit)
- (choice (const :tag "Follow the original design of `org-habit' (default)" nil)
- (const :tag "Do not distinguish between present and future variants" simplified)
- (const :tag "Use only red, yellow, green" traffic-light))))
- :set #'modus-themes--set-option
- :initialize #'custom-initialize-default
- :link '(info-link "(modus-themes) Org agenda"))
-
-(defcustom modus-themes-fringes 'subtle
- "Control the visibility of fringes.
-
-When the value is nil, do not apply a distinct background color.
-
-With a value of `subtle' use a gray background color that is
-visible yet close to the main background color.
-
-With `intense' use a more pronounced gray background color."
- :group 'modus-themes
- :package-version '(modus-themes . "3.0.0")
- :version "29.1"
- :type '(choice
- (const :format "[%v] %t\n" :tag "No visible fringes" nil)
- (const :format "[%v] %t\n" :tag "Subtle gray background" subtle)
- (const :format "[%v] %t\n" :tag "Intense gray background" intense))
- :set #'modus-themes--set-option
- :initialize #'custom-initialize-default
- :link '(info-link "(modus-themes) Fringes"))
-
-(defcustom modus-themes-lang-checkers nil
- "Control the style of spelling and code checkers/linters.
-
-The value is a list of properties, each designated by a symbol.
-The default (nil) applies a color-coded underline to the affected
-text, while it leaves the original foreground intact. If the
-display spec of Emacs has support for it, the underline's style
-is that of a wave, otherwise it is a straight line.
-
-The property `straight-underline' ensures that the underline
-under the affected text is always drawn as a straight line.
-
-The property `text-also' applies the same color of the underline
-to the affected text.
-
-The property `background' adds a color-coded background.
-
-The property `intense' amplifies the applicable colors if
-`background' and/or `text-also' are set. If `intense' is set on
-its own, then it implies `text-also'.
-
-The property `faint' uses nuanced colors for the underline and
-for the foreground when `text-also' is included. If both `faint'
-and `intense' are specified, the former takes precedence.
-
-Combinations of any of those properties can be expressed in a
-list, as in those examples:
-
- (background)
- (straight-underline intense)
- (background text-also straight-underline)
-
-The order in which the properties are set is not significant.
-
-In user configuration files the form may look like this:
-
- (setq modus-themes-lang-checkers (quote (text-also background)))
-
-NOTE: The placement of the straight underline, though not the
-wave style, is controlled by the built-in variables
-`underline-minimum-offset', `x-underline-at-descent-line',
-`x-use-underline-position-properties'.
-
-To disable fringe indicators for Flymake or Flycheck, refer to
-variables `flymake-fringe-indicator-position' and
-`flycheck-indication-mode', respectively."
- :group 'modus-themes
- :package-version '(modus-themes . "1.7.0")
- :version "29.1"
- :type '(set :tag "Properties" :greedy t
- (const :tag "Straight underline" straight-underline)
- (const :tag "Colorise text as well" text-also)
- (const :tag "With background" background)
- (choice :tag "Overall coloration"
- (const :tag "Intense colors" intense)
- (const :tag "Faint colors" faint)))
- :set #'modus-themes--set-option
- :initialize #'custom-initialize-default
- :link '(info-link "(modus-themes) Language checkers"))
-
-(defcustom modus-themes-org-blocks nil
- "Set the overall style of Org code blocks, quotes, and the like.
-
-Nil (the default) means that the block has no background of its
-own: it uses the one that applies to the rest of the buffer. In
-this case, the delimiter lines have a gray color for their text,
-making them look exactly like all other Org properties.
-
-Option `gray-background' applies a subtle gray background to the
-block's contents. It also affects the begin and end lines of the
-block as they get another shade of gray as their background,
-which differentiates them from the contents of the block. All
-background colors extend to the edge of the window, giving the
-area a rectangular, \"blocky\" presentation.
-
-Option `tinted-background' uses a slightly colored background for
-the contents of the block. The exact color will depend on the
-programming language and is controlled by the variable
-`org-src-block-faces' (refer to the theme's source code for the
-current association list). For this to take effect, the Org
-buffer needs to be restarted with `org-mode-restart'. In this
-scenario, it may be better to inhibit the extension of the
-delimiter lines' background to the edge of the window because Org
-does not provide a mechanism to update their colors depending on
-the contents of the block. Disable the extension of such
-backgrounds by setting `org-fontify-whole-block-delimiter-line'
-to nil.
-
-Code blocks use their major mode's colors only when the variable
-`org-src-fontify-natively' is non-nil. While quote/verse blocks
-require setting `org-fontify-quote-and-verse-blocks' to a non-nil
-value.
-
-Older versions of the themes provided options `grayscale' (or
-`greyscale') and `rainbow'. Those will continue to work as they
-are aliases for `gray-background' and `tinted-background',
-respectively."
- :group 'modus-themes
- :package-version '(modus-themes . "2.1.0")
- :version "28.1"
- :type '(choice
- (const :format "[%v] %t\n" :tag "No Org block background (default)" nil)
- (const :format "[%v] %t\n" :tag "Subtle gray block background" gray-background)
- (const :format "[%v] %t\n" :tag "Alias for `gray-background'" grayscale) ; for backward compatibility
- (const :format "[%v] %t\n" :tag "Alias for `gray-background'" greyscale)
- (const :format "[%v] %t\n" :tag "Color-coded background per programming language" tinted-background)
- (const :format "[%v] %t\n" :tag "Alias for `tinted-background'" rainbow)) ; back compat
- :set #'modus-themes--set-option
- :initialize #'custom-initialize-default
- :link '(info-link "(modus-themes) Org mode blocks"))
-
-(defcustom modus-themes-mode-line nil
- "Control the overall style of the mode line.
-
-The value is a list of properties, each designated by a symbol.
-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 lines use different shades of grayscale values for the
-background, foreground, border.
-
-The `3d' property applies a three-dimensional effect to the
-active mode line. The inactive mode lines remain two-dimensional
-and are toned down a bit, relative to the default style.
-
-The `moody' property optimizes the mode line for use with the
-library of the same name (hereinafter referred to as Moody).
-In practice, it removes the box effect and replaces it with
-underline and overline properties. It also tones down the
-inactive mode lines. Despite its intended purpose, this option
-can also be used without the Moody library (please consult the
-themes' manual on this point for more details). If both `3d' and
-`moody' properties are set, the latter takes precedence.
-
-The `borderless' property removes the color of the borders. It
-does not actually remove the borders, but only makes their color
-the same as the background, effectively creating some padding.
-
-The `accented' property ensures that the active mode line uses a
-colored background instead of the standard shade of gray.
-
-A positive integer (natural number or natnum) applies a padding
-effect of NATNUM pixels at the boundaries of the mode lines. The
-default value is 1 and does not need to be specified explicitly.
-The padding has no effect when the `moody' property is also used,
-because Moody already applies its own tweaks. To ensure that the
-underline is placed at the bottom of the mode line, set
-`x-underline-at-descent-line' to non-nil (this is not needed when
-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:
-
- (accented)
- (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:
-
- (setq modus-themes-mode-line (quote (borderless accented)))
-
-Note that Moody does not expose any faces that the themes could
-style directly. Instead it re-purposes existing ones to render
-its tabs and ribbons. As such, there may be cases where the
-contrast ratio falls below the 7:1 target that the themes conform
-with (WCAG AAA). To hedge against this, we configure a fallback
-foreground for the `moody' property, which will come into effect
-when the background of the mode line changes to something less
-accessible, such as Moody ribbons (read the doc string of
-`set-face-attribute', specifically `:distant-foreground'). This
-fallback is activated when Emacs determines that the background
-and foreground of the given construct are too close to each other
-in terms of color distance. In practice, users will need to
-experiment with the variable `face-near-same-color-threshold' to
-trigger the effect. We find that a value of 45000 shall suffice,
-contrary to the default 30000. Though for the combinations that
-involve the `accented' and `moody' properties, as mentioned
-above, that should be raised up to 70000. Do not set it too
-high, because it has the adverse effect of always overriding the
-default colors (which have been carefully designed to be highly
-accessible).
-
-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 . "2.3.0")
- :version "29.1"
- :type '(set :tag "Properties" :greedy t
- (choice :tag "Overall style"
- (const :tag "Rectangular Border" nil)
- (const :tag "3d borders" 3d)
- (const :tag "No box effects (Moody-compatible)" moody))
- (const :tag "Colored background" accented)
- (const :tag "Without border color" borderless)
- (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-diffs nil
- "Adjust the overall style of diffs.
-
-The default (nil) uses fairly intense color combinations for
-diffs, by applying prominently colored backgrounds, with
-appropriately tinted foregrounds.
-
-Option `desaturated' follows the same principles as with the
-default (nil), though it tones down all relevant colors.
-
-Option `bg-only' applies a background but does not override the
-text's foreground. This makes it suitable for a non-nil value
-passed to `diff-font-lock-syntax' (note: Magit does not support
-syntax highlighting in diffs---last checked on 2021-12-02).
+(make-obsolete-variable 'modus-themes-org-blocks nil "4.4.0: Use palette overrides")
-When the user option `modus-themes-deuteranopia' is non-nil, all
-diffs will use a red/blue color-coding system instead of the
-standard red/green. Other stylistic changes are made in the
-interest of optimizing for such a use-case."
- :group 'modus-themes
- :package-version '(modus-themes . "2.0.0")
- :version "29.1"
- :type '(choice
- (const :format "[%v] %t\n" :tag "Intensely colored backgrounds (default)" nil)
- (const :format "[%v] %t\n" :tag "Slightly accented backgrounds with tinted text" desaturated)
- (const :format "[%v] %t\n" :tag "Apply color-coded backgrounds; keep syntax colors intact" bg-only))
- :set #'modus-themes--set-option
- :initialize #'custom-initialize-default
- :link '(info-link "(modus-themes) Diffs"))
-
-(defcustom modus-themes-completions
- '((selection . (intense))
- (popup . (intense)))
+(defcustom modus-themes-completions nil
"Control the style of completion user interfaces.
-This affects Company, Corfu, Flx, Helm, Icomplete/Fido, Ido, Ivy,
-Orderless, Selectrum, Vertico. The value is an alist that takes
-the form of a (KEY . PROPERTIES) combination. KEY is a symbol,
-while PROPERTIES is a list. Here is a sample, followed by a
-description of the particularities:
+This affects Company, Corfu, Flx, Icomplete/Fido, Ido, Ivy,
+Orderless, Vertico, and the standard *Completions* buffer. The
+value is an alist of expressions, each of which takes the form
+of (KEY . LIST-OF-PROPERTIES). KEY is a symbol, while PROPERTIES
+is a list. Here is a sample, followed by a description of the
+particularities:
(setq modus-themes-completions
- (quote ((matches . (extrabold background intense))
- (selection . (semibold accented intense))
- (popup . (accented)))))
+ (quote ((matches . (extrabold underline))
+ (selection . (semibold italic)))))
The `matches' key refers to the highlighted characters that
correspond to the user's input. When its properties are nil or
@@ -2214,11 +541,6 @@ have a bold weight and a colored foreground. The list of
properties may include any of the following symbols regardless of
the order they may appear in:
-- `background' to add a background color;
-
-- `intense' to increase the overall coloration (also amplifies
- the `background', if present);
-
- `underline' to draw a line below the characters;
- `italic' to use a slanted font (italic or oblique forms);
@@ -2235,13 +557,6 @@ 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;
- `italic' to use a slanted font (italic or oblique forms);
@@ -2251,99 +566,39 @@ follows (order is not significant):
variable `modus-themes-weights'. The absence of a weight means
that bold will be used.
-The `popup' key takes the same values as `selection'. The only
-difference is that it applies specifically to user interfaces
-that display an inline popup and thus have slightly different
-styling requirements than the minibuffer. The two prominent
-packages are `company' and `corfu'.
-
-Apart from specifying each key separately, a fallback list is
+Apart from specifying each key separately, a catch-all list is
accepted. This is only useful when the desired aesthetic is the
same across all keys that are not explicitly referenced. For
example, this:
(setq modus-themes-completions
- (quote ((t . (extrabold intense)))))
+ (quote ((t . (extrabold underline)))))
Is the same as:
(setq modus-themes-completions
- (quote ((matches . (extrabold intense))
- (selection . (extrabold intense))
- (popup . (extrabold intense)))))
-
-In the case of the fallback, any property that does not apply to
-the corresponding key is simply ignored (`matches' does not have
-`accented' and `text-also', while `selection' and `popup' do not
-have `background').
-
-Check the manual for tweaking `bold' and `italic' faces: Info
-node `(modus-themes) Configure bold and italic faces'.
-
-Also refer to the documentation of the `orderless' package for
-its intersection with `company' (if you choose to use those in
-tandem)."
+ (quote ((matches . (extrabold underline))
+ (selection . (extrabold underline)))))"
:group 'modus-themes
- :package-version '(modus-themes . "3.0.0")
- :version "29.1"
+ :package-version '(modus-themes . "4.0.0")
+ :version "30.1"
:type `(set
(cons :tag "Matches"
(const matches)
(set :tag "Style of matches" :greedy t
- (choice :tag "Font weight (must be supported by the typeface)"
- (const :tag "Bold (default)" nil)
- (const :tag "Thin" thin)
- (const :tag "Ultra-light" ultralight)
- (const :tag "Extra-light" extralight)
- (const :tag "Light" light)
- (const :tag "Semi-light" semilight)
- (const :tag "Regular" regular)
- (const :tag "Medium" medium)
- (const :tag "Semi-bold" semibold)
- (const :tag "Extra-bold" extrabold)
- (const :tag "Ultra-bold" ultrabold))
- (const :tag "With added background" background)
- (const :tag "Increased coloration" intense)
+ ,modus-themes--weight-widget
(const :tag "Italic font (oblique or slanted forms)" italic)
(const :tag "Underline" underline)))
(cons :tag "Selection"
(const selection)
(set :tag "Style of selection" :greedy t
- (choice :tag "Font weight (must be supported by the typeface)"
- (const :tag "Bold (default)" nil)
- (const :tag "Thin" thin)
- (const :tag "Ultra-light" ultralight)
- (const :tag "Extra-light" extralight)
- (const :tag "Light" light)
- (const :tag "Semi-light" semilight)
- (const :tag "Regular" regular)
- (const :tag "Medium" medium)
- (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)
+ ,modus-themes--weight-widget
(const :tag "Italic font (oblique or slanted forms)" italic)
(const :tag "Underline" underline)))
- (cons :tag "Popup"
- (const popup)
- (set :tag "Style of completion pop-ups" :greedy t
- (choice :tag "Font weight (must be supported by the typeface)"
- (const :tag "Bold (default)" nil)
- (const :tag "Thin" thin)
- (const :tag "Ultra-light" ultralight)
- (const :tag "Extra-light" extralight)
- (const :tag "Light" light)
- (const :tag "Semi-light" semilight)
- (const :tag "Regular" regular)
- (const :tag "Medium" medium)
- (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)
+ (cons :tag "Fallback for both matches and selection"
+ (const t)
+ (set :tag "Style of both matches and selection" :greedy t
+ ,modus-themes--weight-widget
(const :tag "Italic font (oblique or slanted forms)" italic)
(const :tag "Underline" underline))))
:set #'modus-themes--set-option
@@ -2355,512 +610,715 @@ tandem)."
The value is a list of properties, each designated by a symbol.
The default (a nil value or an empty list) means to only use a
-subtle accented foreground color.
-
-The property `background' applies a background color to the
-prompt's text. By default, this is a subtle accented value.
+subtle colored foreground color.
-The property `intense' makes the foreground color more prominent.
-If the `background' property is also set, it amplifies the value
-of the background as well.
-
-The property `gray' changes the prompt's colors to grayscale.
-This affects the foreground and, if the `background' property is
-also set, the background. Its effect is subtle, unless it is
-combined with the `intense' property.
-
-The property `bold' makes the text use a bold typographic weight.
-Similarly, `italic' adds a slant to the font's forms (italic or
+The `italic' property adds a slant to the font's forms (italic or
oblique forms, depending on the typeface).
-Combinations of any of those properties are expressed as a list,
-like in these examples:
-
- (intense)
- (bold intense)
- (intense bold gray)
- (intense background gray bold)
-
-The order in which the properties are set is not significant.
-
-In user configuration files the form may look like this:
-
- (setq modus-themes-prompts (quote (background gray)))"
- :group 'modus-themes
- :package-version '(modus-themes . "1.5.0")
- :version "28.1"
- :type '(set :tag "Properties" :greedy t
- (const :tag "With Background" background)
- (const :tag "Intense" intense)
- (const :tag "Grayscale" gray)
- (const :tag "Bold font weight" bold)
- (const :tag "Italic font slant" italic))
- :set #'modus-themes--set-option
- :initialize #'custom-initialize-default
- :link '(info-link "(modus-themes) Command prompts"))
-
-(defcustom modus-themes-hl-line '(intense)
- "Control the current line highlight of `hl-line-mode'.
-
-The value is a list of properties, each designated by a symbol.
-With a nil value, or an empty list, the style is a subtle gray
-background color.
-
-The property `accented' changes the background to a colored
-variant.
-
-An `underline' property draws a line below the highlighted area.
-Its color is similar to the background, so gray by default or an
-accent color when `accented' is also set.
-
-An `intense' property amplifies the colors in use, which may be
-both the background and the underline.
-
-Combinations of any of those properties are expressed as a list,
-like in these examples:
-
- (intense)
- (underline intense)
- (accented intense underline)
-
-The order in which the properties are set is not significant.
-
-In user configuration files the form may look like this:
-
- (setq modus-themes-hl-line (quote (underline accented)))
-
-Set `x-underline-at-descent-line' to a non-nil value so that the
-placement of the underline coincides with the lower boundary of
-the colored background."
- :group 'modus-themes
- :package-version '(modus-themes . "3.0.0")
- :version "29.1"
- :type '(set :tag "Properties" :greedy t
- (const :tag "Colored background" accented)
- (const :tag "Underline" underline)
- (const :tag "Intense style" intense))
- :set #'modus-themes--set-option
- :initialize #'custom-initialize-default
- :link '(info-link "(modus-themes) Line highlighting"))
-
-(defcustom modus-themes-subtle-line-numbers nil
- "Use more subtle style for command `display-line-numbers-mode'."
- :group 'modus-themes
- :package-version '(modus-themes . "1.2.0")
- :version "28.1"
- :type 'boolean
- :set #'modus-themes--set-option
- :initialize #'custom-initialize-default
- :link '(info-link "(modus-themes) Line numbers"))
-
-(defcustom modus-themes-markup nil
- "Style markup in Org, Markdown, and others.
-
-This affects constructs such as Org's =verbatim= and ~code~.
-
-The value is a list of properties, each designated by a symbol.
-The default (a nil value or an empty list) is a foreground
-color.
-
-The `italic' property applies a typographic slant (italics).
-
-The `bold' property applies a heavier typographic weight.
-
-The `background' property adds a background color. The
-background is a shade of gray, unless the `intense' property is
-also set.
-
-The `intense' property amplifies the existing coloration. When
-`background' is used, the background color is enhanced as well
-and becomes tinted instead of being gray.
+The symbol of a font weight attribute such as `light', `semibold',
+et cetera, adds the given weight to links. Valid symbols are
+defined in the variable `modus-themes-weights'. The absence of a
+weight means that the one of the underlying text will be used.
Combinations of any of those properties are expressed as a list,
like in these examples:
- (bold)
(bold italic)
- (bold italic intense)
- (bold italic intense background)
+ (italic semibold)
The order in which the properties are set is not significant.
In user configuration files the form may look like this:
- (setq modus-themes-markup (quote (bold italic)))
-
-Also check the variables `org-hide-emphasis-markers',
-`org-hide-macro-markers'."
+ (setq modus-themes-prompts (quote (extrabold italic)))"
:group 'modus-themes
- :package-version '(modus-themes . "2.1.0")
- :version "29.1"
- :type '(set :tag "Properties" :greedy t
- (const :tag "Added background" background)
- (const :tag "Intense colors" intense)
- (const :tag "Bold weight" bold)
- (const :tag "Italics (slanted text)" italic))
- :set #'modus-themes--set-option
- :initialize #'custom-initialize-default
- :link '(info-link "(modus-themes) Markup"))
-
-(defcustom modus-themes-paren-match nil
- "Control the style of matching parentheses or delimiters.
-
-The value is a list of properties, each designated by a symbol.
-The default (a nil value or an empty list) is a subtle background
-color.
-
-The `bold' property adds a bold weight to the characters of the
-matching delimiters.
-
-The `intense' property applies a more prominent background color
-to the delimiters.
-
-The `underline' property draws a straight line under the affected
-text.
-
-Combinations of any of those properties are expressed as a list,
-like in these examples:
-
- (bold)
- (underline intense)
- (bold intense underline)
-
-The order in which the properties are set is not significant.
-
-In user configuration files the form may look like this:
-
- (setq modus-themes-paren-match (quote (bold intense)))"
- :group 'modus-themes
- :package-version '(modus-themes . "1.5.0")
- :version "28.1"
- :type '(set :tag "Properties" :greedy t
- (const :tag "Bold weight" bold)
- (const :tag "Intense background color" intense)
- (const :tag "Underline" underline))
+ :package-version '(modus-themes . "4.0.0")
+ :version "30.1"
+ :type `(set :tag "Properties" :greedy t
+ (const :tag "Italic font slant" italic)
+ ,modus-themes--weight-widget)
:set #'modus-themes--set-option
:initialize #'custom-initialize-default
- :link '(info-link "(modus-themes) Matching parentheses"))
-
-(defcustom modus-themes-syntax nil
- "Control the overall style of code syntax highlighting.
-
-The value is a list of properties, each designated by a symbol.
-The default (a nil value or an empty list) is to use a balanced
-combination of colors on the cyan-blue-magenta side of the
-spectrum. There is little to no use of greens, yellows, and
-reds. Comments are gray, strings are blue colored, doc strings
-are a shade of cyan, while color combinations are designed to
-avoid exaggerations.
-
-The property `faint' fades the saturation of all applicable
-colors, where that is possible or appropriate.
-
-The property `yellow-comments' applies a yellow color to
-comments.
-
-The property `green-strings' applies a green color to strings and
-a green tint to doc strings.
-
-The property `alt-syntax' changes the combination of colors
-beyond strings and comments, so that the effective palette is
-broadened to provide greater variety relative to the default.
-
-Combinations of any of those properties are expressed as a list,
-like in these examples:
+ :link '(info-link "(modus-themes) Command prompts"))
- (faint)
- (green-strings yellow-comments)
- (alt-syntax green-strings yellow-comments)
- (faint alt-syntax green-strings yellow-comments)
+(defcustom modus-themes-common-palette-overrides nil
+ "Set palette overrides for all the Modus themes.
-The order in which the properties are set is not significant.
+Mirror the elements of a theme's palette, overriding their value.
+The palette variables are named THEME-NAME-palette, while
+individual theme overrides are THEME-NAME-palette-overrides. The
+THEME-NAME is one of the symbols in `modus-themes-items'. For
+example:
-In user configuration files the form may look like this:
+- `modus-operandi-palette'
+- `modus-operandi-palette-overrides'
- (setq modus-themes-syntax (quote (faint alt-syntax)))
+Individual theme overrides take precedence over these common
+overrides.
-Independent of this variable, users may also control the use of a
-bold weight or italic text: `modus-themes-bold-constructs' and
-`modus-themes-italic-constructs'."
+The idea of common overrides is to change semantic color
+mappings, such as to make the cursor red. Wherea theme-specific
+overrides can also be used to change the value of a named color,
+such as what hexadecimal RGB value the red-warmer symbol
+represents."
:group 'modus-themes
- :package-version '(modus-themes . "1.5.0")
- :version "28.1"
- :type '(set :tag "Properties" :greedy t
- (const :tag "Faint colors" faint)
- (const :tag "Yellow comments" yellow-comments)
- (const :tag "Green strings" green-strings)
- (const :tag "Alternative set of colors" alt-syntax))
+ :package-version '(modus-themes . "4.0.0")
+ :version "30.1"
+ :type '(repeat (list symbol (choice symbol string)))
+ ;; ;; NOTE 2023-01-07: The following is a functioning version of the
+ ;; ;; intended :type. However, I think the Custom UI is really
+ ;; ;; awkward for this specific case. Maybe the generic type I have
+ ;; ;; above is better, as it encourages the user to write out the
+ ;; ;; code and read the manual. Counter-arguments are welcome.
+ ;;
+ ;; :type `(repeat (list (radio :tag "Palette key to override"
+ ;; ,@(mapcar (lambda (x)
+ ;; (list 'const x))
+ ;; (mapcar #'car (modus-themes--current-theme-palette))))
+ ;; (choice :tag "Value to assign" :value unspecified
+ ;; (const :tag "`unspecified' (remove the original color)" unspecified)
+ ;; (string :tag "String with color name (e.g. \"gray50\") or hex RGB (e.g. \"#123456\")"
+ ;; :match-inline (color-supported-p val))
+ ;; (radio :tag "Palette key to map to"
+ ;; ,@(mapcar (lambda (x)
+ ;; (list 'const x))
+ ;; (mapcar #'car (modus-themes--current-theme-palette)))))))
:set #'modus-themes--set-option
:initialize #'custom-initialize-default
- :link '(info-link "(modus-themes) Syntax styles"))
-
-(defcustom modus-themes-links nil
- "Set the style of links.
-
-The value is a list of properties, each designated by a symbol.
-The default (a nil value or an empty list) is a prominent text
-color, typically blue, with an underline of the same color.
-
-For the style of the underline, a `neutral-underline' property
-turns the color of the line into a subtle gray, while the
-`no-underline' property removes the line altogether. If both of
-those are set, the latter takes precedence.
-
-For text coloration, a `faint' property desaturates the color of
-the text and the underline, unless the underline is affected by
-the aforementioned properties. While a `no-color' property
-removes the color from the text. If both of those are set, the
-latter takes precedence.
-
-A `bold' property applies a heavy typographic weight to the text
-of the link.
-
-An `italic' property adds a slant to the link's text (italic or
-oblique forms, depending on the typeface).
-
-A `background' property applies a subtle tinted background color.
+ :link '(info-link "(modus-themes) Palette overrides"))
-In case both `no-underline' and `no-color' are set, then a subtle
-gray background is applied to all links. This can still be
-combined with the `bold' and `italic' properties.
-
-Combinations of any of those properties are expressed as a list,
-like in these examples:
-
- (faint)
- (no-underline faint)
- (no-color no-underline bold)
- (italic bold background no-color no-underline)
-
-The order in which the properties are set is not significant.
-
-In user configuration files the form may look like this:
-
- (setq modus-themes-links (quote (neutral-underline background)))
-
-The placement of the underline, meaning its proximity to the
-text, is controlled by `x-use-underline-position-properties',
-`x-underline-at-descent-line', `underline-minimum-offset'.
-Please refer to their documentation strings."
- :group 'modus-themes
- :package-version '(modus-themes . "1.5.0")
- :version "28.1"
- :type '(set :tag "Properties" :greedy t
- (choice :tag "Text coloration"
- (const :tag "Saturared color (default)" nil)
- (const :tag "Faint coloration" faint)
- (const :tag "No color (use main black/white)" no-color))
- (choice :tag "Underline"
- (const :tag "Same color as text (default)" nil)
- (const :tag "Neutral (gray) underline color" neutral-underline)
- (const :tag "No underline" no-underline))
- (const :tag "Bold font weight" bold)
- (const :tag "Italic font slant" italic)
- (const :tag "Subtle background color" background))
- :set #'modus-themes--set-option
- :initialize #'custom-initialize-default
- :link '(info-link "(modus-themes) Link styles"))
-
-(defcustom modus-themes-region nil
- "Control the overall style of the active region.
-
-The value is a list of properties, each designated by a symbol.
-The default (a nil value or an empty list) is a prominent gray
-background that overrides all foreground colors in the area it
-encompasses. Its reach extends to the edge of the window.
-
-The `no-extend' property limits the region to the end of the
-line, so that it does not reach the edge of the window.
+
-The `bg-only' property makes the region's background color more
-subtle to allow the underlying text to retain its foreground
-colors.
+;;;; Presets of palette overrides
+
+(defvar modus-themes-preset-overrides-faint
+ '((bg-completion bg-inactive)
+ (bg-hl-line bg-dim)
+ (bg-paren-match bg-cyan-subtle)
+ (bg-region bg-active)
+
+ (bg-mode-line-active bg-inactive)
+ (border-mode-line-active fg-dim)
+ (bg-mode-line-inactive bg-dim)
+ (border-mode-line-inactive bg-active)
+
+ (bg-tab-bar bg-inactive)
+ (bg-tab-current bg-main)
+ (bg-tab-other bg-active)
+
+ (fringe unspecified)
+ (builtin maroon)
+ (comment fg-dim)
+ (constant blue-faint)
+ (docstring fg-alt)
+ (docmarkup magenta-faint)
+ (fnname pink)
+ (keyword indigo)
+ (preprocessor rust)
+ (string slate)
+ (type cyan-faint)
+ (variable cyan-faint)
+ (rx-construct gold)
+ (rx-backslash olive)
+
+ (underline-err red-faint)
+ (underline-warning yellow-faint)
+ (underline-note cyan-faint)
+
+ (bg-button-active bg-main)
+ (fg-button-active fg-main)
+ (bg-button-inactive bg-inactive)
+ (fg-button-inactive "gray50")
+
+ (date-common cyan-faint)
+ (date-deadline red-faint)
+ (date-event fg-alt)
+ (date-holiday magenta)
+ (date-now fg-main)
+ (date-scheduled yellow-faint)
+ (date-weekday fg-dim)
+ (date-weekend fg-dim)
+
+ (name maroon)
+ (identifier fg-dim)
+
+ (fg-line-number-active fg-main)
+ (fg-line-number-inactive "gray50")
+ (bg-line-number-active unspecified)
+ (bg-line-number-inactive unspecified)
+
+ (fg-link blue-faint)
+ (bg-link unspecified)
+ (underline-link bg-active)
+
+ (fg-link-symbolic cyan-faint)
+ (bg-link-symbolic unspecified)
+ (underline-link-symbolic bg-active)
+
+ (fg-link-visited magenta-faint)
+ (bg-link-visited unspecified)
+ (underline-link-visited bg-active)
+
+ (mail-cite-0 cyan-faint)
+ (mail-cite-1 yellow-faint)
+ (mail-cite-2 green-faint)
+ (mail-cite-3 red-faint)
+ (mail-part olive)
+ (mail-recipient indigo)
+ (mail-subject maroon)
+ (mail-other slate)
+
+ (fg-prompt cyan-faint)
+
+ (fg-prose-code olive)
+ (fg-prose-macro indigo)
+ (fg-prose-verbatim maroon)
+
+ (prose-done green-faint)
+ (prose-tag rust)
+ (prose-todo red-faint)
+
+ (rainbow-0 fg-main)
+ (rainbow-1 magenta)
+ (rainbow-2 cyan)
+ (rainbow-3 red-faint)
+ (rainbow-4 yellow-faint)
+ (rainbow-5 magenta-cooler)
+ (rainbow-6 green)
+ (rainbow-7 blue-warmer)
+ (rainbow-8 magenta-faint))
+ "Preset for palette overrides with faint coloration.
+
+This changes many parts of the theme to make them look less
+colorful/intense. Grays are toned down, gray backgrounds are
+removed from some contexts, and almost all accent colors are
+desaturated.
+
+All the preset overrides the themes provide (including this one):
+
+- `modus-themes-preset-overrides-faint'
+- `modus-themes-preset-overrides-intense'
+- `modus-themes-preset-overrides-cooler'
+- `modus-themes-preset-overrides-warmer'
+
+To set a preset, assign its symbol without a quote as the value
+of the `modus-themes-common-palette-overrides' or as the value of
+theme-specific options such as `modus-operandi-palette-overrides'.
+
+For overriding named colors and/or semantic color mappings read
+Info node `(modus-themes) Option for palette overrides'.")
+
+(defvar modus-themes-preset-overrides-intense
+ '((bg-region bg-cyan-intense)
+
+ (bg-completion bg-cyan-subtle)
+ (bg-hover bg-yellow-intense)
+ (bg-hover-secondary bg-magenta-intense)
+ (bg-hl-line bg-cyan-subtle)
+
+ (bg-mode-line-active bg-blue-subtle)
+ (fg-mode-line-active fg-main)
+ (border-mode-line-active blue-intense)
+
+ (fringe bg-inactive)
+ (comment red-faint)
+
+ (date-common cyan)
+ (date-deadline red)
+ (date-event blue)
+ (date-holiday magenta-warmer)
+ (date-now blue-faint)
+ (date-range blue)
+ (date-scheduled yellow-warmer)
+ (date-weekday fg-main)
+ (date-weekend red-faint)
+
+ (keybind blue-intense)
+
+ (mail-cite-0 blue)
+ (mail-cite-1 yellow-cooler)
+ (mail-cite-2 green-warmer)
+ (mail-cite-3 magenta)
+ (mail-part cyan)
+ (mail-recipient magenta-cooler)
+ (mail-subject red-warmer)
+ (mail-other cyan-cooler)
+
+ (fg-prompt blue-intense)
+
+ (bg-prose-block-delimiter bg-dim)
+ (fg-prose-block-delimiter red-faint)
+ (prose-done green-intense)
+ (prose-metadata magenta-faint)
+ (prose-metadata-value blue-cooler)
+ (prose-table blue)
+ (prose-todo red-intense)
+
+ (fg-heading-0 blue-cooler)
+ (fg-heading-1 magenta-cooler)
+ (fg-heading-2 magenta-warmer)
+ (fg-heading-3 blue)
+ (fg-heading-4 cyan)
+ (fg-heading-5 green-warmer)
+ (fg-heading-6 yellow)
+ (fg-heading-7 red)
+ (fg-heading-8 magenta)
+
+ (bg-heading-0 unspecified)
+ (bg-heading-1 bg-magenta-nuanced)
+ (bg-heading-2 bg-red-nuanced)
+ (bg-heading-3 bg-blue-nuanced)
+ (bg-heading-4 bg-cyan-nuanced)
+ (bg-heading-5 bg-green-nuanced)
+ (bg-heading-6 bg-yellow-nuanced)
+ (bg-heading-7 bg-red-nuanced)
+ (bg-heading-8 bg-magenta-nuanced)
+
+ (overline-heading-0 unspecified)
+ (overline-heading-1 magenta-cooler)
+ (overline-heading-2 magenta-warmer)
+ (overline-heading-3 blue)
+ (overline-heading-4 cyan)
+ (overline-heading-5 green)
+ (overline-heading-6 yellow-cooler)
+ (overline-heading-7 red-cooler)
+ (overline-heading-8 magenta))
+ "Preset for palette overrides with intense coloration.
+
+This changes many parts of the theme to make them look more
+colorful/intense. Many background colors are accented and
+coloration is increased to pop out more.
+
+All the preset overrides the themes provide (including this one):
+
+- `modus-themes-preset-overrides-faint'
+- `modus-themes-preset-overrides-intense'
+- `modus-themes-preset-overrides-cooler'
+- `modus-themes-preset-overrides-warmer'
+
+To set a preset, assign its symbol without a quote as the value
+of the `modus-themes-common-palette-overrides' or as the value of
+theme-specific options such as `modus-operandi-palette-overrides'.
+
+For overriding named colors and/or semantic color mappings read
+Info node `(modus-themes) Option for palette overrides'.")
+
+(defvar modus-themes-preset-overrides-cooler
+ '((fg-prompt blue-cooler)
+
+ (builtin magenta-faint)
+ (constant blue-cooler)
+ (fnname cyan-cooler)
+ (keyword magenta-cooler)
+ (preprocessor blue)
+ (string blue-warmer)
+ (type green-cooler)
+ (variable cyan)
+ (rx-construct blue-cooler)
+ (rx-backslash red)
+
+ (name blue-warmer)
+ (identifier magenta-faint)
+
+ (date-deadline magenta-cooler)
+ (date-scheduled yellow-cooler)
+ (date-weekday blue-faint)
+ (date-weekend red-faint)
+
+ (mail-cite-0 blue-faint)
+ (mail-cite-1 cyan-cooler)
+ (mail-cite-2 magenta-faint)
+ (mail-cite-3 yellow-cooler)
+ (mail-part cyan)
+ (mail-recipient blue-warmer)
+ (mail-subject magenta-cooler)
+ (mail-other blue)
+
+ (prose-tag fg-dim)
+ (fg-prose-verbatim blue-cooler))
+ "Preset of palette overrides with cooler colors.
+
+This changes parts of the palette to use more blue and
+blue-tinted colors.
+
+All the preset overrides the themes provide (including this one):
+
+- `modus-themes-preset-overrides-faint'
+- `modus-themes-preset-overrides-intense'
+- `modus-themes-preset-overrides-cooler'
+- `modus-themes-preset-overrides-warmer'
+
+To set a preset, assign its symbol without a quote as the value
+of the `modus-themes-common-palette-overrides' or as the value of
+theme-specific options such as `modus-operandi-palette-overrides'.
+
+For overriding named colors and/or semantic color mappings read
+Info node `(modus-themes) Option for palette overrides'.")
+
+(defvar modus-themes-preset-overrides-warmer
+ '((fg-prompt magenta-warmer)
+
+ (builtin magenta)
+ (constant blue-warmer)
+ (fnname magenta-cooler)
+ (keyword magenta-warmer)
+ (preprocessor red-cooler)
+ (string green-warmer)
+ (type cyan-cooler)
+ (variable cyan)
+ (rx-construct blue-cooler)
+ (rx-backslash red-warmer)
+
+ (name blue-warmer)
+ (identifier magenta)
+ (keybind magenta-warmer)
+
+ (accent-0 magenta-warmer)
+ (accent-1 cyan)
+ (accent-2 blue-warmer)
+ (accent-3 red-cooler)
+
+ (date-common cyan-cooler)
+ (date-holiday magenta-warmer)
+
+ (mail-cite-0 magenta-faint)
+ (mail-cite-1 cyan-cooler)
+ (mail-cite-2 green-warmer)
+ (mail-cite-3 red-faint)
+ (mail-part cyan)
+ (mail-recipient magenta)
+ (mail-subject blue-warmer)
+ (mail-other magenta-warmer)
+
+ (fg-prose-macro red-cooler)
+ (prose-tag fg-dim))
+ "Preset of palette overrides with warmer colors.
+
+This changes many parts of the theme to use warmer colors,
+including green and yellow.
+
+All the preset overrides the themes provide (including this one):
+
+- `modus-themes-preset-overrides-faint'
+- `modus-themes-preset-overrides-intense'
+- `modus-themes-preset-overrides-cooler'
+- `modus-themes-preset-overrides-warmer'
+
+To set a preset, assign its symbol without a quote as the value
+of the `modus-themes-common-palette-overrides' or as the value of
+theme-specific options such as `modus-operandi-palette-overrides'.
+
+For overriding named colors and/or semantic color mappings read
+Info node `(modus-themes) Option for palette overrides'.")
-The `accented' property applies a more colorful background to the
-region.
+
-Combinations of any of those properties are expressed as a list,
-like in these examples:
+;;;; Helper functions for theme setup
- (no-extend)
- (bg-only accented)
- (accented bg-only no-extend)
+;; This is the WCAG formula: https://www.w3.org/TR/WCAG20-TECHS/G18.html
+(defun modus-themes--wcag-contribution (channel weight)
+ "Return the CHANNEL contribution to overall luminance given WEIGHT."
+ (* weight
+ (if (<= channel 0.03928)
+ (/ channel 12.92)
+ (expt (/ (+ channel 0.055) 1.055) 2.4))))
-The order in which the properties are set is not significant.
+(defun modus-themes-wcag-formula (hex)
+ "Get WCAG value of color value HEX.
+The value is defined in hexadecimal RGB notation, such #123456."
+ (let ((channels (color-name-to-rgb hex))
+ (weights '(0.2126 0.7152 0.0722))
+ contribution)
+ (while channels
+ (push (modus-themes--wcag-contribution (pop channels) (pop weights)) contribution))
+ (apply #'+ contribution)))
-In user configuration files the form may look like this:
+;;;###autoload
+(defun modus-themes-contrast (c1 c2)
+ "Measure WCAG contrast ratio between C1 and C2.
+C1 and C2 are color values written in hexadecimal RGB."
+ (let ((ct (/ (+ (modus-themes-wcag-formula c1) 0.05)
+ (+ (modus-themes-wcag-formula c2) 0.05))))
+ (max ct (/ ct))))
- (setq modus-themes-region (quote (bg-only no-extend)))"
- :group 'modus-themes
- :package-version '(modus-themes . "1.5.0")
- :version "28.1"
- :type '(set :tag "Properties" :greedy t
- (const :tag "Do not extend to the edge of the window" no-extend)
- (const :tag "Background only (preserve underlying colors)" bg-only)
- (const :tag "Accented background" accented))
- :set #'modus-themes--set-option
- :initialize #'custom-initialize-default
- :link '(info-link "(modus-themes) Active region"))
-
-(defcustom modus-themes-deuteranopia nil
- "When non-nil use red/blue color-coding instead of red/green.
-
-This is to account for red-green color deficiency, also know as
-deuteranopia and variants. It applies to all contexts where
-there can be a color-coded distinction between failure or
-success, a to-do or done state, a mark for deletion versus a mark
-for selection (e.g. in Dired), current and lazily highlighted
-search matches, removed lines in diffs as opposed to added ones,
-and so on.
-
-Note that this does not change all colors throughout the active
-theme, but only applies to cases that have color-coding
-significance. For example, regular code syntax highlighting is
-not affected. There is no such need because of the themes'
-overarching commitment to the highest legibility standard, which
-ensures that text is readable regardless of hue, as well as the
-predominance of colors on the blue-cyan-magenta-purple side of
-the spectrum."
- :group 'modus-themes
- :package-version '(modus-themes . "2.0.0")
- :version "29.1"
- :type 'boolean
- :set #'modus-themes--set-option
- :initialize #'custom-initialize-default
- :link '(info-link "(modus-themes) Deuteranopia style"))
+(defun modus-themes--modus-p (theme)
+ "Return non-nil if THEME name has a modus- prefix."
+ (string-prefix-p "modus-" (symbol-name theme)))
-(defcustom modus-themes-mail-citations nil
- "Control the color of citations/quotes in messages or emails.
+(defun modus-themes--list-enabled-themes ()
+ "Return list of `custom-enabled-themes' with modus- prefix."
+ (seq-filter #'modus-themes--modus-p custom-enabled-themes))
-By default (a nil value) citations are styled with contrasting
-hues to denote their depth. Colors are easy to tell apart
-because they complement each other, but they otherwise are not
-very prominent.
+(defun modus-themes--load-no-enable (theme)
+ "Load but do not enable THEME if it belongs to `custom-known-themes'."
+ (unless (memq theme custom-known-themes)
+ (load-theme theme :no-confirm :no-enable)))
-Option `intense' is similar to the default in terms of using
-contrasting and complementary hues, but applies more saturated
-colors.
+(defun modus-themes--enable-themes ()
+ "Enable the Modus themes."
+ (mapc #'modus-themes--load-no-enable modus-themes-items))
-Option `faint' maintains the same color-based distinction between
-citation levels though the colors it uses have subtle differences
-between them.
+(defun modus-themes--list-known-themes ()
+ "Return list of `custom-known-themes' with modus- prefix."
+ (modus-themes--enable-themes)
+ (seq-filter #'modus-themes--modus-p custom-known-themes))
-Option `monochrome' turns all quotes into a shade of gray.
+(defun modus-themes--current-theme ()
+ "Return first enabled Modus theme."
+ (car (or (modus-themes--list-enabled-themes)
+ (modus-themes--list-known-themes))))
+
+(defun modus-themes--palette-symbol (theme &optional overrides)
+ "Return THEME palette as a symbol.
+With optional OVERRIDES, return THEME palette overrides as a
+symbol."
+ (when-let ((suffix (cond
+ ((and theme overrides)
+ "palette-overrides")
+ (theme
+ "palette"))))
+ (intern (format "%s-%s" theme suffix))))
+
+(defun modus-themes--palette-value (theme &optional overrides)
+ "Return palette value of THEME with optional OVERRIDES."
+ (let ((base-value (symbol-value (modus-themes--palette-symbol theme))))
+ (if overrides
+ (append (symbol-value (modus-themes--palette-symbol theme :overrides))
+ modus-themes-common-palette-overrides
+ base-value)
+ base-value)))
+
+(defun modus-themes--current-theme-palette (&optional overrides)
+ "Return palette value of active Modus theme, else produce `user-error'.
+With optional OVERRIDES return palette value plus whatever
+overrides."
+ (if-let ((theme (modus-themes--current-theme)))
+ (if overrides
+ (modus-themes--palette-value theme :overrides)
+ (modus-themes--palette-value theme))
+ (user-error "No enabled Modus theme could be found")))
+
+(defun modus-themes--disable-themes ()
+ "Disable themes per `modus-themes-disable-other-themes'."
+ (mapc #'disable-theme
+ (if modus-themes-disable-other-themes
+ custom-enabled-themes
+ (modus-themes--list-known-themes))))
+
+(defun modus-themes-load-theme (theme)
+ "Load THEME while disabling other themes.
+
+Which themes are disabled is determined by the user option
+`modus-themes-disable-other-themes'.
+
+Run the `modus-themes-after-load-theme-hook' as the final step
+after loading the THEME.
+
+Return THEME."
+ (modus-themes--disable-themes)
+ (load-theme theme :no-confirm)
+ (run-hooks 'modus-themes-after-load-theme-hook)
+ theme)
+
+(defun modus-themes--retrieve-palette-value (color palette)
+ "Return COLOR from PALETTE.
+Use recursion until COLOR is retrieved as a string. Refrain from
+doing so if the value of COLOR is not a key in the PALETTE.
+
+Return `unspecified' if the value of COLOR cannot be determined.
+This symbol is accepted by faces and is thus harmless.
+
+This function is used in the macros `modus-themes-theme',
+`modus-themes-with-colors'."
+ (let ((value (car (alist-get color palette))))
+ (cond
+ ((or (stringp value)
+ (eq value 'unspecified))
+ value)
+ ((and (symbolp value)
+ (memq value (mapcar #'car palette)))
+ (modus-themes--retrieve-palette-value value palette))
+ (t
+ 'unspecified))))
-Whatever the value assigned to this variable, citations in emails
-are controlled by typographic elements and/or indentation, which
-the themes do not touch."
- :group 'modus-themes
- :package-version '(modus-themes . "2.1.0")
- :version "29.1"
- :type '(choice
- (const :format "[%v] %t\n" :tag "Colorful email citations with contrasting hues (default)" nil)
- (const :format "[%v] %t\n" :tag "Like the default, but with more saturated colors" intense)
- (const :format "[%v] %t\n" :tag "Like the default, but with less saturated colors" faint)
- (const :format "[%v] %t\n" :tag "Deprecated alias of `faint'" desaturated)
- (const :format "[%v] %t\n" :tag "Uniformly gray mail citations" monochrome))
- :set #'modus-themes--set-option
- :initialize #'custom-initialize-default
- :link '(info-link "(modus-themes) Mail citations"))
+(defun modus-themes-get-color-value (color &optional overrides theme)
+ "Return color value of named COLOR for current Modus theme.
-(defcustom modus-themes-tabs-accented nil
- "Toggle accented tab backgrounds, instead of the default gray.
-This affects the built-in tab-bar mode and tab-line mode, as well
-as the Centaur tabs package."
- :group 'modus-themes
- :package-version '(modus-themes . "1.6.0")
- :version "28.1"
- :type 'boolean
- :set #'modus-themes--set-option
- :initialize #'custom-initialize-default
- :link '(info-link "(modus-themes) Tab style"))
+COLOR is a symbol that represents a named color entry in the
+palette.
-(defcustom modus-themes-box-buttons nil
- "Control the style of buttons in the Custom UI and related.
+If the value is the name of another color entry in the
+palette (so a mapping), recur until you find the underlying color
+value.
-The value is a list of properties, each designated by a symbol.
-The default (a nil value or an empty list) is a gray background
-combined with a pseudo three-dimensional effect.
+With optional OVERRIDES as a non-nil value, account for palette
+overrides. Else use the default palette.
-The `flat' property makes the button two dimensional.
+With optional THEME as a symbol among `modus-themes-items', use
+the palette of that item. Else use the current Modus theme.
-The `accented' property changes the background from gray to an
-accent color.
+If COLOR is not present in the palette, return the `unspecified'
+symbol, which is safe when used as a face attribute's value."
+ (if-let* ((palette (if theme
+ (modus-themes--palette-value theme overrides)
+ (modus-themes--current-theme-palette overrides)))
+ (value (modus-themes--retrieve-palette-value color palette)))
+ value
+ 'unspecified))
-The `faint' property reduces the overall coloration.
+;;;; Commands
-The `variable-pitch' property applies a proportionately spaced
-typeface to the button's text.
+(defvar modus-themes--select-theme-history nil
+ "Minibuffer history of `modus-themes--select-prompt'.")
+
+(defun modus-themes--annotate-theme (theme)
+ "Return completion annotation for THEME."
+ (when-let ((symbol (intern-soft theme))
+ (doc-string (get symbol 'theme-documentation)))
+ (format " -- %s"
+ (propertize (car (split-string doc-string "\\."))
+ 'face 'completions-annotations))))
+
+(defun modus-themes--completion-table (category candidates)
+ "Pass appropriate metadata CATEGORY to completion CANDIDATES."
+ (lambda (string pred action)
+ (if (eq action 'metadata)
+ `(metadata (category . ,category))
+ (complete-with-action action candidates string pred))))
+
+(defun modus-themes--completion-table-candidates ()
+ "Render `modus-themes--list-known-themes' as completion with theme category."
+ (modus-themes--completion-table 'theme (modus-themes--list-known-themes)))
+
+(defun modus-themes--select-prompt ()
+ "Minibuffer prompt to select a Modus theme."
+ (let ((completion-extra-properties `(:annotation-function ,#'modus-themes--annotate-theme)))
+ (intern
+ (completing-read
+ "Select Modus theme: "
+ (modus-themes--completion-table-candidates)
+ nil t nil
+ 'modus-themes--select-theme-history))))
-The `underline' property draws a line below the affected text and
-removes whatever box effect. This is optimal when Emacs runs
-inside a terminal emulator. If `flat' and `underline' are
-defined together, the latter takes precedence.
+;;;###autoload
+(defun modus-themes-select (theme)
+ "Load a Modus THEME using minibuffer completion.
+Run `modus-themes-after-load-theme-hook' after loading the theme.
+Disable other themes per `modus-themes-disable-other-themes'."
+ (interactive (list (modus-themes--select-prompt)))
+ (modus-themes-load-theme theme))
+
+(defun modus-themes--toggle-theme-p ()
+ "Return non-nil if `modus-themes-to-toggle' are valid."
+ (mapc
+ (lambda (theme)
+ (if (or (memq theme modus-themes-items)
+ (memq theme (modus-themes--list-known-themes)))
+ theme
+ (user-error "`%s' is not part of `modus-themes-items'" theme)))
+ modus-themes-to-toggle))
-The symbol of a weight attribute adjusts the font of the button
-accordingly, such as `light', `semibold', etc. Valid symbols are
-defined in the variable `modus-themes-weights'.
+;;;###autoload
+(defun modus-themes-toggle ()
+ "Toggle between the two `modus-themes-to-toggle'.
+If `modus-themes-to-toggle' does not specify two Modus themes,
+prompt with completion for a theme among our collection (this is
+practically the same as the `modus-themes-select' command).
-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.
+Run `modus-themes-after-load-theme-hook' after loading the theme.
+Disable other themes per `modus-themes-disable-other-themes'."
+ (interactive)
+ (if-let* ((themes (modus-themes--toggle-theme-p))
+ (one (car themes))
+ (two (cadr themes)))
+ (modus-themes-load-theme (if (eq (car custom-enabled-themes) one) two one))
+ (modus-themes-load-theme (modus-themes--select-prompt))))
+
+(defun modus-themes--list-colors-render (buffer theme &optional mappings &rest _)
+ "Render colors in BUFFER from THEME for `modus-themes-list-colors'.
+Optional MAPPINGS changes the output to only list the semantic
+color mappings of the palette, instead of its named colors."
+ (let* ((current-palette (modus-themes--palette-value theme mappings))
+ (palette (if mappings
+ (seq-remove (lambda (cell)
+ (stringp (cadr cell)))
+ current-palette)
+ current-palette))
+ (current-buffer buffer)
+ (current-theme theme))
+ (with-help-window buffer
+ (with-current-buffer standard-output
+ (erase-buffer)
+ (when (<= (display-color-cells) 256)
+ (insert (concat "Your display terminal may not render all color previews!\n"
+ "It seems to only support <= 256 colors.\n\n"))
+ (put-text-property (point-min) (point) 'face 'warning))
+ ;; We need this to properly render the first line.
+ (insert " ")
+ (dolist (cell palette)
+ (let* ((name (car cell))
+ (color (modus-themes-get-color-value name mappings theme))
+ (pad (make-string 10 ?\s))
+ (fg (if (eq color 'unspecified)
+ (progn
+ (readable-foreground-color (modus-themes-get-color-value 'bg-main nil theme))
+ (setq pad (make-string 6 ?\s)))
+ (readable-foreground-color color))))
+ (let ((old-point (point)))
+ (insert (format "%s %s" color pad))
+ (put-text-property old-point (point) 'face `( :foreground ,color)))
+ (let ((old-point (point)))
+ (insert (format " %s %s %s\n" color pad name))
+ (put-text-property old-point (point)
+ 'face `( :background ,color
+ :foreground ,fg
+ :extend t)))
+ ;; We need this to properly render the last line.
+ (insert " ")))
+ (setq-local revert-buffer-function
+ (lambda (_ignore-auto _noconfirm)
+ (modus-themes--list-colors-render current-buffer current-theme mappings)))))))
-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.
+(defvar modus-themes--list-colors-prompt-history '()
+ "Minibuffer history for `modus-themes--list-colors-prompt'.")
-Combinations of any of those properties are expressed as a list,
-like in these examples:
+(defun modus-themes--list-colors-prompt ()
+ "Prompt for Modus theme.
+Helper function for `modus-themes-list-colors'."
+ (let ((def (format "%s" (modus-themes--current-theme)))
+ (completion-extra-properties `(:annotation-function ,#'modus-themes--annotate-theme)))
+ (completing-read
+ (format "Use palette from theme [%s]: " def)
+ (modus-themes--completion-table-candidates)
+ nil t nil
+ 'modus-themes--list-colors-prompt-history def)))
- (flat)
- (variable-pitch flat)
- (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
+(defun modus-themes-list-colors (theme &optional mappings)
+ "Preview named colors of the Modus THEME of choice.
+With optional prefix argument for MAPPINGS preview the semantic
+color mappings instead of the named colors."
+ (interactive (list (intern (modus-themes--list-colors-prompt)) current-prefix-arg))
+ (modus-themes--list-colors-render
+ (format (if mappings "*%s-list-mappings*" "*%s-list-colors*") theme)
+ theme
+ mappings))
-The order in which the properties are set is not significant.
+(defalias 'modus-themes-preview-colors 'modus-themes-list-colors
+ "Alias of `modus-themes-list-colors'.")
-In user configuration files the form may look like this:
+(defun modus-themes-list-colors-current (&optional mappings)
+ "Call `modus-themes-list-colors' for the current Modus theme.
+Optional prefix argument MAPPINGS has the same meaning as for
+`modus-themes-list-colors'."
+ (interactive "P")
+ (modus-themes-list-colors (modus-themes--current-theme) mappings))
- (setq modus-themes-box-buttons (quote (variable-pitch flat 0.9)))"
- :group 'modus-themes
- :package-version '(modus-themes . "2.3.0")
- :version "29.1"
- :type '(set :tag "Properties" :greedy t
- (const :tag "Two-dimensional button" flat)
- (const :tag "Accented background instead of gray" accented)
- (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)
- (const :tag "Extra-light" extralight)
- (const :tag "Light" light)
- (const :tag "Semi-light" semilight)
- (const :tag "Regular (default)" nil)
- (const :tag "Medium" medium)
- (const :tag "Bold" bold)
- (const :tag "Semi-bold" semibold)
- (const :tag "Extra-bold" extrabold)
- (const :tag "Ultra-bold" ultrabold))
- (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"))
+(defalias 'modus-themes-preview-colors-current 'modus-themes-list-colors-current
+ "Alias of `modus-themes-list-colors-current'.")
-;;; Internal functions
+;;;; Internal functions
(defun modus-themes--warn (option)
"Warn that OPTION has changed."
@@ -2883,58 +1341,12 @@ Check PROPERTIES for an alist value that corresponds to
ALIST-KEY. If no alist is present, search the PROPERTIES
list given LIST-PRED, using DEFAULT as a fallback."
(if-let* ((val (or (alist-get alist-key properties)
- (cl-loop for x in properties
- if (funcall list-pred x) return x)
+ (seq-filter (lambda (x) (funcall list-pred x)) properties)
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'."
- (pcase theme
- ('modus-operandi
- (append modus-themes-operandi-color-overrides
- modus-themes-operandi-colors))
- ('modus-vivendi
- (append modus-themes-vivendi-color-overrides
- modus-themes-vivendi-colors))
- (_theme
- (error "'%s' is not a Modus theme" theme))))
-
-(defvar modus-themes-faces)
-(defvar modus-themes-custom-variables)
-
-(defmacro modus-themes-theme (name)
- "Bind NAME's color palette around face specs and variables.
-
-NAME should be the proper name of a Modus theme, either
-`modus-operandi' or `modus-vivendi'.
-
-Face specifications are passed to `custom-theme-set-faces'.
-While variables are handled by `custom-theme-set-variables'.
-Those are stored in `modus-themes-faces' and
-`modus-themes-custom-variables' respectively."
- (declare (indent 0))
- (let ((palette-sym (gensym))
- (colors (mapcar #'car modus-themes-operandi-colors)))
- `(let* ((class '((class color) (min-colors 89)))
- (,palette-sym (modus-themes--palette ',name))
- ,@(mapcar (lambda (color)
- (list color `(alist-get ',color ,palette-sym)))
- colors))
- (custom-theme-set-faces ',name ,@modus-themes-faces)
- (custom-theme-set-variables ',name ,@modus-themes-custom-variables))))
-
-(defun modus-themes--current-theme ()
- "Return current modus theme."
- (car
- (seq-filter
- (lambda (theme)
- (string-match-p "^modus" (symbol-name theme)))
- custom-enabled-themes)))
-
;; Helper functions that are meant to ease the implementation of the
;; above customization variables.
(defun modus-themes--bold-weight ()
@@ -2957,145 +1369,13 @@ Those are stored in `modus-themes-faces' and
(when modus-themes-variable-pitch-ui
(list :inherit 'variable-pitch)))
-(defun modus-themes--fringe (mainbg subtlebg intensebg)
- "Conditional use of background colors for fringes.
-MAINBG is the default. SUBTLEBG should be a subtle grayscale
-value. INTENSEBG must be a more pronounced grayscale color."
- (pcase modus-themes-fringes
- ('intense (list :background intensebg))
- ('subtle (list :background subtlebg))
- (_ (list :background mainbg))))
-
-(defun modus-themes--line-numbers (mainfg mainbg altfg &optional altbg)
- "Conditional use of colors for line numbers.
-MAINBG and MAINFG are the default colors. ALTFG is a color that
-combines with the theme's primary background (white/black)."
- (if modus-themes-subtle-line-numbers
- (list :background (or altbg 'unspecified) :foreground altfg)
- (list :background mainbg :foreground mainfg)))
-
-(defun modus-themes--markup (mainfg intensefg subtlebg intensebg)
- "Conditional use of colors for markup in Org and others.
-MAINFG is the default foreground. SUBTLEBG is a gray background.
-INTENSEBG is a colorful background for use with the main
-foreground. INTENSEFG is an alternative to the default."
- (let ((properties modus-themes-markup))
- (list
- :inherit
- (cond
- ((and (memq 'bold properties)
- (memq 'italic properties))
- (list 'bold-italic 'modus-themes-fixed-pitch))
- ((memq 'italic properties)
- (list 'italic 'modus-themes-fixed-pitch))
- ((memq 'bold properties)
- (list 'bold 'modus-themes-fixed-pitch))
- (t 'modus-themes-fixed-pitch))
- :background
- (cond
- ((and (memq 'background properties)
- (memq 'intense properties))
- intensebg)
- ((memq 'background properties)
- subtlebg)
- (t
- 'unspecified))
- :foreground
- (cond
- ((and (memq 'background properties)
- (memq 'intense properties))
- mainfg)
- ((memq 'intense properties)
- intensefg)
- (t
- mainfg)))))
-
-(defun modus-themes--lang-check (underline subtlefg intensefg intensefg-alt subtlebg intensebg faintfg)
- "Conditional use of foreground colors for language checkers.
-UNDERLINE is a color-code value for the affected text's underline
-property. SUBTLEFG and INTENSEFG follow the same color-coding
-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 ((properties (modus-themes--list-or-warn 'modus-themes-lang-checkers)))
- (list :underline
- (list :color
- (if (memq 'faint properties)
- faintfg underline)
- :style
- (if (memq 'straight-underline properties)
- 'line 'wave))
- :background
- (cond
- ((and (memq 'background properties)
- (memq 'faint properties))
- subtlebg)
- ((and (memq 'background properties)
- (memq 'intense properties))
- intensebg)
- ((memq 'background properties)
- subtlebg)
- ('unspecified))
- :foreground
- (cond
- ((and (memq 'faint properties)
- (memq 'text-also properties))
- faintfg)
- ((and (memq 'background properties)
- (memq 'intense properties))
- intensefg-alt)
- ((memq 'intense properties)
- intensefg)
- ((memq 'text-also properties)
- subtlefg)
- ('unspecified)))))
-
-(defun modus-themes--prompt (mainfg intensefg grayfg subtlebg intensebg intensebg-fg subtlebggray intensebggray)
+(defun modus-themes--prompt (fg bg)
"Conditional use of colors for text prompt faces.
-MAINFG is the prompt's standard foreground. INTENSEFG is a more
-prominent alternative to the main foreground, while GRAYFG is a
-less luminant shade of gray.
-
-SUBTLEBG is a subtle accented background that works with either
-MAINFG or INTENSEFG.
-
-INTENSEBG is a more pronounced accented background color that
-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--list-or-warn 'modus-themes-prompts)))
- (list :foreground
- (cond
- ((and (memq 'gray properties)
- (memq 'intense properties))
- 'unspecified)
- ((memq 'gray properties)
- grayfg)
- ((and (memq 'background properties)
- (memq 'intense properties))
- intensebg-fg)
- ((memq 'intense properties)
- intensefg)
- (mainfg))
- :background
- (cond
- ((and (memq 'gray properties)
- (memq 'background properties)
- (memq 'intense properties))
- intensebggray)
- ((and (memq 'gray properties)
- (memq 'background properties))
- subtlebggray)
- ((and (memq 'background properties)
- (memq 'intense properties))
- intensebg)
- ((memq 'background properties)
- subtlebg)
- ('unspecified))
- :inherit
+FG is the prompt's standard foreground. BG is a background
+color that is combined with FG-FOR-BG."
+ (let* ((properties (modus-themes--list-or-warn 'modus-themes-prompts))
+ (weight (modus-themes--weight properties)))
+ (list :inherit
(cond
((and (memq 'bold properties)
(memq 'italic properties))
@@ -3104,104 +1384,16 @@ theme's fallback text color."
'italic)
((memq 'bold properties)
'bold)
- ('unspecified)))))
-
-(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
-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--list-or-warn 'modus-themes-paren-match)))
- (list :inherit
- (if (memq 'bold properties)
- 'bold
- 'unspecified)
- :background
- (if (memq 'intense properties)
- intensebg
- normalbg)
- :underline
- (if (memq 'underline properties)
- t
- nil))))
-
-(defun modus-themes--syntax-foreground (fg faint)
- "Apply foreground value to code syntax.
-FG is the default. FAINT is typically the same color in its
-desaturated version."
- (let ((properties (modus-themes--list-or-warn 'modus-themes-syntax)))
- (list :foreground
- (cond
- ((memq 'faint properties)
- faint)
- (fg)))))
-
-(defun modus-themes--syntax-extra (fg faint alt &optional faint-alt)
- "Apply foreground value to code syntax.
-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--list-or-warn 'modus-themes-syntax)))
- (list :foreground
- (cond
- ((and (memq 'alt-syntax properties)
- (memq 'faint properties))
- (or faint-alt alt))
- ((memq 'faint properties)
- faint)
- ((memq 'alt-syntax properties)
- alt)
- (fg)))))
-
-(defun modus-themes--syntax-string (fg faint green alt &optional faint-green faint-alt)
- "Apply foreground value to strings in code syntax.
-FG is the default. FAINT is typically the same color in its
-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--list-or-warn 'modus-themes-syntax)))
- (list :foreground
- (cond
- ((and (memq 'faint properties)
- (memq 'green-strings properties))
- (or faint-green green))
- ((and (memq 'alt-syntax properties)
- (memq 'faint properties))
- (or faint-alt faint))
- ((memq 'faint properties)
- faint)
- ((memq 'green-strings properties)
- green)
- ((memq 'alt-syntax properties)
- alt)
- (fg)))))
-
-(defun modus-themes--syntax-comment (fg yellow &optional faint-yellow faint)
- "Apply foreground value to strings in code syntax.
-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--list-or-warn 'modus-themes-syntax)))
- (list :foreground
- (cond
- ((and (memq 'faint properties)
- (memq 'yellow-comments properties))
- (or faint-yellow yellow))
- ((and (memq 'alt-syntax properties)
- (memq 'yellow-comments properties)
- (not (memq 'green-strings properties)))
- yellow)
- ((memq 'yellow-comments properties)
- yellow)
- ((memq 'faint properties)
- (or faint fg))
- (fg)))))
-
-(defun modus-themes--key-cdr (key alist)
- "Get cdr of KEY in ALIST."
- (cdr (assoc key alist)))
+ ('unspecified))
+ :background bg
+ :foreground fg
+ :weight
+ ;; If we have `bold' specifically, we inherit the face of
+ ;; the same name. This allows the user to customise that
+ ;; face, such as to change its font family.
+ (if (and weight (not (eq weight 'bold)))
+ weight
+ 'unspecified))))
(defconst modus-themes-weights
'( thin ultralight extralight light semilight regular medium
@@ -3209,366 +1401,44 @@ an alternative to the default value."
"List of font weights.")
(defun modus-themes--weight (list)
- "Search for `modus-themes--heading' weight in LIST."
+ "Search for `modus-themes-weights' weight in LIST."
(catch 'found
(dolist (elt list)
(when (memq elt modus-themes-weights)
(throw 'found elt)))))
-(defun modus-themes--heading (level fg fg-alt bg bg-gray border)
+(defun modus-themes--heading (level fg &optional bg ol)
"Conditional styles for `modus-themes-headings'.
LEVEL is the heading's position in their order. FG is the
-default text color. FG-ALT is an accented, more saturated value
-than the default. BG is a nuanced, typically accented,
-background that can work well with either of the foreground
-values. BG-GRAY is a gray background. BORDER is a color value
-that combines well with the background and foreground."
- (let* ((key (modus-themes--key-cdr level modus-themes-headings))
- (style (or key (modus-themes--key-cdr t modus-themes-headings)))
+default text color. Optional BG is an appropriate background.
+Optional OL is the color of an overline."
+ (let* ((key (alist-get level modus-themes-headings))
+ (style (or key (alist-get t modus-themes-headings)))
(style-listp (listp style))
(properties style)
- (var (when (memq 'variable-pitch properties) 'variable-pitch))
- (varbold (if var
- (append (list 'bold) (list var))
- 'bold))
+ (var (when (and style-listp (memq 'variable-pitch properties)) 'variable-pitch))
(weight (when style-listp (modus-themes--weight style))))
- (list :inherit
- (cond
- ;; `no-bold' is for backward compatibility because we cannot
- ;; deprecate a variable's value.
- ((or weight (memq 'no-bold properties))
- var)
- (varbold))
- :background
- (cond
- ((and (memq 'monochrome properties)
- (memq 'background properties))
- bg-gray)
- ((memq 'background properties)
- bg)
- ('unspecified))
- :foreground
- (cond
- ((memq 'monochrome properties)
- 'unspecified)
- ((memq 'rainbow properties)
- fg-alt)
- (fg))
- :height
- (modus-themes--property-lookup properties 'height #'floatp 'unspecified)
- :weight
- (or weight 'unspecified)
- :overline
- (if (memq 'overline properties)
- border
- 'unspecified))))
-
-(defun modus-themes--agenda-structure (fg)
- "Control the style of the Org agenda structure.
-FG is the foreground color to use."
- (let* ((properties (modus-themes--key-cdr 'header-block modus-themes-org-agenda))
- (weight (modus-themes--weight properties)))
- (list :inherit
- (cond
- ((and weight (memq 'variable-pitch properties))
- 'variable-pitch)
- (weight 'unspecified)
- ((memq 'variable-pitch properties)
- (list 'bold 'variable-pitch))
- ('bold))
- :weight
- (or weight 'unspecified)
- :height
- (cond ((memq 'no-scale properties) 'unspecified)
- ((modus-themes--property-lookup properties 'height #'floatp 1.15)))
- :foreground fg)))
-
-(defun modus-themes--agenda-date (defaultfg grayscalefg &optional workaholicfg grayscaleworkaholicfg bg bold ul)
- "Control the style of date headings in Org agenda buffers.
-DEFAULTFG is the original accent color for the foreground.
-GRAYSCALEFG is a neutral color. Optional WORKAHOLICFG and
-GRAYSCALEWORKAHOLICFG are alternative foreground colors.
-Optional BG is a background color. Optional BOLD applies a bold
-weight. Optional UL applies an underline."
- (let ((properties (modus-themes--key-cdr 'header-date modus-themes-org-agenda)))
- (list :inherit
- (cond
- ((or (memq 'bold-all properties)
- (and bold (memq 'bold-today properties)))
- 'bold)
- (t
- 'unspecified))
- :background
- (cond
- ((memq 'underline-today properties)
- 'unspecified)
- ((or bg 'unspecified)))
- :foreground
- (cond
- ((and (memq 'grayscale properties)
- (memq 'workaholic properties))
- (or grayscaleworkaholicfg grayscalefg))
- ((memq 'grayscale properties)
- grayscalefg)
- ((memq 'workaholic properties)
- (or workaholicfg defaultfg))
- (t
- defaultfg))
- :height
- (modus-themes--property-lookup properties 'height #'floatp 'unspecified)
- :underline
- (if (and ul (memq 'underline-today properties))
- t
- 'unspecified))))
-
-(defun modus-themes--agenda-event (fg-accent &optional varied)
- "Control the style of the Org agenda events.
-FG-ACCENT is the accent color to use. Optional VARIED is a
-toggle to behave in accordance with the semantics of the `varied'
-property that the `event' key accepts in
-`modus-themes-org-agenda'."
- (let ((properties (modus-themes--key-cdr 'event modus-themes-org-agenda)))
- (list :foreground
- (cond
- ((or (and (memq 'varied properties) varied)
- (and (memq 'accented properties)
- (memq 'varied properties)
- varied))
- 'unspecified)
- ((memq 'accented properties)
- fg-accent)
- ('unspecified))
- :inherit
- (cond
- ((and (memq 'italic properties)
- (memq 'varied properties)
- varied)
- '(shadow italic))
- ((and (memq 'accented properties)
- (memq 'varied properties)
- varied)
- 'shadow)
- ((or (and (memq 'varied properties) varied)
- (and (memq 'italic properties) varied))
- '(shadow italic))
- ((and (memq 'italic properties)
- (not (memq 'varied properties)))
- '(shadow italic))
- ('shadow)))))
-
-(defun modus-themes--agenda-scheduled (defaultfg uniformfg rainbowfg)
- "Control the style of the Org agenda scheduled tasks.
-DEFAULTFG is an accented foreground color that is meant to
-differentiate between past or present and future tasks.
-UNIFORMFG is a more subtle color that eliminates the color coding
-for scheduled tasks. RAINBOWFG is a prominent accent value that
-clearly distinguishes past, present, future tasks."
- (pcase (modus-themes--key-cdr 'scheduled modus-themes-org-agenda)
- ('uniform (list :foreground uniformfg))
- ('rainbow (list :foreground rainbowfg))
- (_ (list :foreground defaultfg))))
-
-(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.
-
-Optional DEFAULT-D, TRAFFIC-D, SIMPLE-D are alternatives to the
-main colors, meant for dopia when `modus-themes-deuteranopia' is
-non-nil."
- (let ((habit (modus-themes--key-cdr 'habit modus-themes-org-agenda)))
- (cond
- ((and modus-themes-deuteranopia (null habit))
- (list :background (or default-d default)))
- ((and modus-themes-deuteranopia (eq habit 'traffic-light))
- (list :background (or traffic-d traffic)))
- ((and modus-themes-deuteranopia (eq habit 'simplified))
- (list :background (or simple-d simple)))
- (t
- (pcase habit
- ('traffic-light (list :background traffic))
- ('simplified (list :background simple))
- (_ (list :background default)))))))
-
-(defun modus-themes--org-block (bgblk fgdefault &optional fgblk)
- "Conditionally set the background of Org blocks.
-BGBLK applies to a distinct neutral background. Else blocks have
-no background of their own (the default), so they look the same
-as the rest of the buffer. FGDEFAULT is used when no distinct
-background is present. While optional FGBLK specifies a
-foreground value that can be combined with BGBLK.
-
-`modus-themes-org-blocks' also accepts `tinted-background' (alias
-`rainbow') as a value which applies to `org-src-block-faces' (see
-the theme's source code)."
- (if (or (eq modus-themes-org-blocks 'gray-background)
- (eq modus-themes-org-blocks 'grayscale)
- (eq modus-themes-org-blocks 'greyscale))
- (list :background bgblk :foreground (or fgblk fgdefault) :extend t)
- (list :background 'unspecified :foreground fgdefault)))
-
-(defun modus-themes--org-block-delim (bgaccent fgaccent bg fg)
- "Conditionally set the styles of Org block delimiters.
-BG, FG, BGACCENT, FGACCENT apply a background and foreground
-color respectively.
-
-The former pair is a grayscale combination that should be more
-distinct than the background of the block. It is applied to the
-default styles or when `modus-themes-org-blocks' is set
-to `grayscale' (or `greyscale').
-
-The latter pair should be more subtle than the background of the
-block, as it is used when `modus-themes-org-blocks' is
-set to `rainbow'."
- (pcase modus-themes-org-blocks
- ('gray-background (list :background bg :foreground fg :extend t))
- ('grayscale (list :background bg :foreground fg :extend t))
- ('greyscale (list :background bg :foreground fg :extend t))
- ('tinted-background (list :background bgaccent :foreground fgaccent :extend nil))
- ('rainbow (list :background bgaccent :foreground fgaccent :extend nil))
- (_ (list :foreground fg :extend nil))))
-
-(defun modus-themes--mode-line-attrs
- (fg bg fg-alt bg-alt fg-accent bg-accent border border-3d &optional alt-style fg-distant)
- "Color combinations for `modus-themes-mode-line'.
-
-FG and BG are the default colors. FG-ALT and BG-ALT are meant to
-accommodate the options for a 3D mode line or a `moody' compliant
-one. FG-ACCENT and BG-ACCENT are used for all variants. BORDER
-applies to all permutations of the mode line, except the
-three-dimensional effect, where BORDER-3D is used instead.
-
-Optional ALT-STYLE applies an appropriate style to the mode
-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--list-or-warn 'modus-themes-mode-line))
- (padding (modus-themes--property-lookup properties 'padding #'natnump 1))
- (height (modus-themes--property-lookup properties 'height #'floatp 'unspecified))
- (padded (> padding 1))
- (base (cond ((memq 'accented properties)
- (cons fg-accent bg-accent))
- ((and (or (memq 'moody properties)
- (memq '3d properties))
- (not (memq 'borderless properties)))
- (cons fg-alt bg-alt))
- ((cons fg bg))))
- (line (cond ((not (or (memq 'moody properties) padded))
- 'unspecified)
- ((and (not (memq 'moody properties))
- padded
- (memq 'borderless properties))
- 'unspecified)
- ((and (memq 'borderless properties)
- (memq 'accented properties))
- bg-accent)
- ((memq 'borderless properties)
- bg)
- (border))))
- (list :foreground (car base)
- :background (cdr base)
- :height height
- :box
- (cond ((memq 'moody properties)
- 'unspecified)
- ((and (memq '3d properties) padded)
- (list :line-width padding
- :color
- (cond ((and (memq 'accented properties)
- (memq 'borderless properties))
- bg-accent)
- ((or (memq 'accented properties)
- (memq 'borderless properties))
- bg)
- (bg-alt))
- :style (when alt-style 'released-button)))
- ((and (memq 'accented properties) padded)
- (list :line-width padding :color bg-accent))
- ((memq '3d properties)
- (list :line-width padding
- :color
- (cond ((and (memq 'accented properties)
- (memq 'borderless properties))
- bg-accent)
- ((memq 'borderless properties) bg)
- (border-3d))
- :style (when alt-style 'released-button)))
- ((and (memq 'accented properties)
- (memq 'borderless properties))
- (list :line-width padding :color bg-accent))
- ((or (memq 'borderless properties) padded)
- (list :line-width padding :color bg))
- (border))
- :overline line
- :underline line
- :distant-foreground
- (if (memq 'moody properties)
- fg-distant
- 'unspecified))))
-
-;; Basically this is just for the keycast key indicator.
-(defun modus-themes--mode-line-padded-box (color)
- "Set padding of mode line box attribute with given COLOR."
- (list :box (list :color color
- :line-width
- (or (cl-loop
- for x in modus-themes-mode-line
- if (natnump x) return x)
- 1))))
-
-(defun modus-themes--diff (mainbg mainfg altbg altfg &optional deubg deufg deualtbg deualtfg bg-only-fg)
- "Color combinations for `modus-themes-diffs'.
-
-MAINBG must be one of the dedicated backgrounds for diffs while
-MAINFG must be the same for the foreground.
-
-ALTBG needs to be a slightly accented background that is meant to
-be combined with ALTFG. Both must be less intense than MAINBG
-and MAINFG respectively.
-
-DEUBG and DEUFG must be combinations of colors that account for
-red-green color defficiency (deuteranopia). They are the
-equivalent of MAINBG and MAINFG.
-
-DEUALTBG and DEUALTFG are the equivalent of ALTBG and ALTFG for
-deuteranopia.
-
-Optional non-nil BG-ONLY-FG applies ALTFG else leaves the
-foreground unspecified."
- (if modus-themes-deuteranopia
- (pcase modus-themes-diffs
- ('desaturated (list :background (or deualtbg altbg) :foreground (or deualtfg altfg)))
- ('bg-only (list :background (or deualtbg altbg) :foreground (if bg-only-fg (or deualtfg altfg) 'unspecified)))
- (_ (list :background (or deubg mainbg) :foreground (or deufg mainfg))))
- (pcase modus-themes-diffs
- ('desaturated (list :background altbg :foreground altfg))
- ('bg-only (list :background altbg :foreground (if bg-only-fg altfg 'unspecified)))
- (_ (list :background mainbg :foreground mainfg)))))
-
-(defun modus-themes--deuteran (deuteran main)
- "Determine whether to color-code success as DEUTERAN or MAIN."
- (if modus-themes-deuteranopia
- (list deuteran)
- (list main)))
-
-(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."
+ (list :inherit (cond
+ ((not style-listp) 'bold)
+ ;; `no-bold' is for backward compatibility because we cannot
+ ;; deprecate a variable's value.
+ ((or weight (memq 'no-bold properties))
+ var)
+ (var (append (list 'bold) (list var)))
+ (t 'bold))
+ :background (or bg 'unspecified)
+ :foreground fg
+ :overline (or ol 'unspecified)
+ :height (if style-listp
+ (modus-themes--property-lookup properties 'height #'floatp 'unspecified)
+ 'unspecified)
+ :weight (or weight 'unspecified))))
+
+(defun modus-themes--completion-line (bg)
+ "Styles for `modus-themes-completions' with BG as the background."
(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))
- (text (memq 'text-also properties))
- (accented (memq 'accented properties))
- (intense (memq 'intense properties))
+ (properties (or (alist-get 'selection var) (alist-get t var)))
(italic (memq 'italic properties))
(weight (modus-themes--weight properties))
(bold (when (and weight (eq weight 'bold)) 'bold)))
@@ -3581,35 +1451,18 @@ other backgrounds."
'unspecified)
(italic 'bold-italic)
('bold))
- :background
- (cond
- ((and accented intense line)
- bgaccentintense)
- ((and accented line)
- bgaccent)
- (intense bgintense)
- (bg))
- :foreground
- (cond
- ((and line text intense)
- fgintense)
- ((and line text)
- fg)
- ('unspecified))
+ :background bg
+ :foreground '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)
+(defun modus-themes--completion-match (fg bg)
"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."
+FG and BG are the main colors."
(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))
+ (properties (or (alist-get 'matches var) (alist-get t var)))
(italic (memq 'italic properties))
(weight (modus-themes--weight properties))
(bold (when (and weight (eq weight 'bold)) 'bold)))
@@ -3622,443 +1475,13 @@ own."
'unspecified)
(italic 'bold-italic)
('bold))
- :background
- (cond
- ((and background intense)
- bgintense)
- (background bg)
- ('unspecified))
- :foreground
- (cond
- ((and background intense)
- 'unspecified)
- (background fg)
- (intense fgintense)
- (fg))
+ :background bg
+ :foreground fg
:underline
(if (memq 'underline properties) t 'unspecified)
:weight
(if (and weight (null bold)) weight 'unspecified))))
-(defun modus-themes--link (fg fgfaint underline bg bgneutral)
- "Conditional application of link styles.
-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--list-or-warn 'modus-themes-links)))
- (list :inherit
- (cond
- ((and (memq 'bold properties)
- (memq 'italic properties))
- 'bold-italic)
- ((memq 'italic properties)
- 'italic)
- ((memq 'bold properties)
- 'bold)
- ('unspecified))
- :background
- (cond
- ((and (memq 'no-color properties)
- (memq 'no-underline properties))
- bgneutral)
- ((memq 'background properties)
- bg)
- ('unspecified))
- :foreground
- (cond
- ((memq 'no-color properties)
- 'unspecified)
- ((memq 'faint properties)
- fgfaint)
- (fg))
- :underline
- (cond
- ((memq 'no-underline properties)
- 'unspecified)
- ((memq 'neutral-underline properties)
- underline)
- (t)))))
-
-(defun modus-themes--link-color (fg fgfaint &optional neutralfg)
- "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--list-or-warn 'modus-themes-links)))
- (list :foreground
- (cond
- ((memq 'no-color properties)
- (or neutralfg 'unspecified))
- ((memq 'faint properties)
- fgfaint)
- (fg))
- :underline
- (cond
- ((memq 'no-underline properties)
- 'unspecified)
- ((memq 'neutral-underline properties)
- (or neutralfg 'unspecified))
- (t)))))
-
-(defun modus-themes--region (bg fg bgsubtle bgaccent bgaccentsubtle)
- "Apply `modus-themes-region' styles.
-
-BG and FG are the main values that are used by default. BGSUBTLE
-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--list-or-warn 'modus-themes-region)))
- (list :background
- (cond
- ((and (memq 'accented properties)
- (memq 'bg-only properties))
- bgaccentsubtle)
- ((memq 'accented properties)
- bgaccent)
- ((memq 'bg-only properties)
- bgsubtle)
- (bg))
- :foreground
- (cond
- ((and (memq 'accented properties)
- (memq 'bg-only properties))
- 'unspecified)
- ((memq 'bg-only properties)
- 'unspecified)
- (fg))
- :extend
- (cond
- ((memq 'no-extend properties)
- nil)
- (t)))))
-
-(defun modus-themes--hl-line
- (bgdefault bgintense bgaccent bgaccentsubtle lineneutral lineaccent lineneutralintense lineaccentintense)
- "Apply `modus-themes-hl-line' styles.
-
-BGDEFAULT is a subtle neutral background. BGINTENSE is like the
-default, but more prominent. BGACCENT is a prominent accented
-background, while BGACCENTSUBTLE is more subtle. LINENEUTRAL and
-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--list-or-warn 'modus-themes-hl-line)))
- (list :background
- (cond
- ((and (memq 'intense properties)
- (memq 'accented properties))
- bgaccent)
- ((memq 'accented properties)
- bgaccentsubtle)
- ((memq 'intense properties)
- bgintense)
- (bgdefault))
- :underline
- (cond
- ((and (memq 'intense properties)
- (memq 'accented properties)
- (memq 'underline properties))
- lineaccentintense)
- ((and (memq 'accented properties)
- (memq 'underline properties))
- lineaccent)
- ((and (memq 'intense properties)
- (memq 'underline properties))
- lineneutralintense)
- ((or (memq 'no-background properties)
- (memq 'underline properties))
- lineneutral)
- ('unspecified)))))
-
-(defun modus-themes--mail-cite (mainfg intensefg subtlefg)
- "Combinations for `modus-themes-mail-citations'.
-
-MAINFG is an accented foreground value. SUBTLEFG is its
-desaturated counterpart. INTENSEFG is a more saturated variant."
- (pcase modus-themes-mail-citations
- ('monochrome (list :inherit 'shadow))
- ('intense (list :foreground intensefg))
- ('faint (list :foreground subtlefg))
- ('desaturated (list :foreground subtlefg))
- (_ (list :foreground mainfg))))
-
-(defun modus-themes--tab (bg &optional bgaccent fg fgaccent box-p bold-p var-p)
- "Helper function for tabs.
-BG is the default background, while BGACCENT is its more colorful
-alternative. Optional FG is a foreground color that combines
-with BG. Same principle FGACCENT.
-
-BOX-P and BOLD-P determine the use of a box property and the
-application of a bold weight, respectively. VAR-P controls the
-application of a variable-pitch font."
- (let ((background (if modus-themes-tabs-accented (or bgaccent bg) bg))
- (foreground (if modus-themes-tabs-accented (or fgaccent fg) fg)))
- (list
- :inherit (cond
- ((and bold-p var-p)
- (if modus-themes-variable-pitch-ui
- '(variable-pitch bold)
- '(bold)))
- (bold-p 'bold)
- (var-p (when modus-themes-variable-pitch-ui 'variable-pitch))
- ('unspecified))
- :background background
- :foreground (or foreground 'unspecified)
- :box (if box-p (list :line-width 2 :color background) 'unspecified))))
-
-(defun modus-themes--button (bg bgfaint bgaccent bgaccentfaint border &optional pressed-button-p)
- "Apply `modus-themes-box-buttons' styles.
-
-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
- (cond
- ((and (memq 'variable-pitch properties)
- (eq weight 'bold))
- (list 'bold 'variable-pitch))
- ((memq 'variable-pitch properties)
- 'variable-pitch)
- ((eq weight 'bold)
- 'bold)
- ('unspecified))
- :background
- (cond
- ((and (memq 'accented properties)
- (memq 'faint properties)
- bgaccentfaint))
- ((memq 'faint properties)
- bgfaint)
- ((memq 'accented properties)
- bgaccent)
- (bg))
- :box
- (cond
- ((memq 'underline properties)
- 'unspecified)
- ((memq 'flat properties)
- (list :line-width -1 :color border))
- ((list :line-width -1
- :style (if pressed-button-p
- 'pressed-button
- 'released-button)
- :color border)))
- :weight
- (cond
- ((eq weight 'bold)
- 'unspecified) ; we :inherit the `bold' face above
- (weight weight)
- ('unspecified))
- :height
- (modus-themes--property-lookup properties 'height #'floatp 'unspecified)
- :underline
- (if (memq 'underline properties)
- t
- 'unspecified))))
-
-
-
-;;;; Utilities for DIY users
-
-;;;;; List colors (a variant of M-x list-colors-display)
-
-(defun modus-themes--list-colors-render (buffer theme &rest _)
- "Render colors in BUFFER from THEME.
-Routine for `modus-themes-list-colors'."
- (let ((palette (seq-uniq (modus-themes--palette theme)
- (lambda (x y)
- (eq (car x) (car y)))))
- (current-buffer buffer)
- (current-theme theme))
- (with-help-window buffer
- (with-current-buffer standard-output
- (erase-buffer)
- (when (<= (display-color-cells) 256)
- (insert (concat "Your display terminal may not render all color previews!\n"
- "It seems to only support <= 256 colors.\n\n"))
- (put-text-property (point-min) (point) 'face 'warning))
- ;; We need this to properly render the first line.
- (insert " ")
- (dolist (cell palette)
- (let* ((name (car cell))
- (color (cdr cell))
- (fg (readable-foreground-color color))
- (pad (make-string 5 ?\s)))
- (let ((old-point (point)))
- (insert (format "%s %s" color pad))
- (put-text-property old-point (point) 'face `( :foreground ,color)))
- (let ((old-point (point)))
- (insert (format " %s %s %s\n" color pad name))
- (put-text-property old-point (point)
- 'face `( :background ,color
- :foreground ,fg
- :extend t)))
- ;; We need this to properly render the last line.
- (insert " ")))
- (setq-local revert-buffer-function
- (lambda (_ignore-auto _noconfirm)
- (modus-themes--list-colors-render current-buffer current-theme)))))))
-
-(defvar modus-themes--list-colors-prompt-history '()
- "Minibuffer history for `modus-themes--list-colors-prompt'.")
-
-(defun modus-themes--list-colors-prompt ()
- "Prompt for Modus theme.
-Helper function for `modus-themes-list-colors'."
- (let ((def (format "%s" (modus-themes--current-theme))))
- (completing-read
- (format "Use palette from theme [%s]: " def)
- '(modus-operandi modus-vivendi) nil t nil
- 'modus-themes--list-colors-prompt-history def)))
-
-(defun modus-themes-list-colors (theme)
- "Preview palette of the Modus THEME of choice."
- (interactive (list (intern (modus-themes--list-colors-prompt))))
- (modus-themes--list-colors-render
- (format "*%s-list-colors*" theme)
- theme))
-
-(defun modus-themes-list-colors-current ()
- "Call `modus-themes-list-colors' for the current Modus theme."
- (interactive)
- (modus-themes-list-colors (modus-themes--current-theme)))
-
-;;;;; Formula to measure relative luminance
-
-;; This is the WCAG formula: https://www.w3.org/TR/WCAG20-TECHS/G18.html
-(defun modus-themes-wcag-formula (hex)
- "Get WCAG value of color value HEX.
-The value is defined in hexadecimal RGB notation, such as those in
-`modus-themes-operandi-colors' and `modus-themes-vivendi-colors'."
- (cl-loop for k in '(0.2126 0.7152 0.0722)
- for x in (color-name-to-rgb hex)
- sum (* k (if (<= x 0.03928)
- (/ x 12.92)
- (expt (/ (+ x 0.055) 1.055) 2.4)))))
-
-;;;###autoload
-(defun modus-themes-contrast (c1 c2)
- "Measure WCAG contrast ratio between C1 and C2.
-C1 and C2 are color values written in hexadecimal RGB."
- (let ((ct (/ (+ (modus-themes-wcag-formula c1) 0.05)
- (+ (modus-themes-wcag-formula c2) 0.05))))
- (max ct (/ ct))))
-
-;;;;; Retrieve colors from the themes
-
-(defun modus-themes-current-palette ()
- "Return current color palette."
- (modus-themes--palette (modus-themes--current-theme)))
-
-;;;###autoload
-(defun modus-themes-color (color)
- "Return color value for COLOR from current palette.
-COLOR is a key in `modus-themes-operandi-colors' or
-`modus-themes-vivendi-colors'."
- (alist-get color (modus-themes-current-palette)))
-
-;;;###autoload
-(defun modus-themes-color-alts (light-color dark-color)
- "Return color value from current palette.
-When Modus Operandi is enabled, return color value for color
-LIGHT-COLOR. When Modus Vivendi is enabled, return color value
-for DARK-COLOR. LIGHT-COLOR and DARK-COLOR are keys in
-`modus-themes-operandi-colors' or `modus-themes-vivendi-colors'."
- (let* ((theme (modus-themes--current-theme))
- (color (pcase theme
- ('modus-operandi light-color)
- ('modus-vivendi dark-color)
- (_theme
- (error "'%s' is not a Modus theme" theme)))))
- (alist-get color (modus-themes--palette theme))))
-
-(defmacro modus-themes-with-colors (&rest body)
- "Evaluate BODY with colors from current palette bound.
-For colors bound, see `modus-themes-operandi-colors' or
-`modus-themes-vivendi-colors'."
- (declare (indent 0))
- (let ((palette-sym (gensym))
- (colors (mapcar #'car modus-themes-operandi-colors)))
- `(let* ((class '((class color) (min-colors 89)))
- (,palette-sym (modus-themes-current-palette))
- ,@(mapcar (lambda (color)
- (list color `(alist-get ',color ,palette-sym)))
- colors))
- (ignore class ,@colors) ; Silence unused variable warnings
- ,@body)))
-
-
-
-;;;; Commands
-
-;;;###autoload
-(defun modus-themes-load-themes ()
- "Ensure that the Modus themes are in `custom-enabled-themes'.
-
-This function is intended for use in package declarations such as
-those defined with the help of `use-package'. The idea is to add
-this function to the `:init' stage of the package's loading, so
-that subsequent calls that assume the presence of a loaded theme,
-like `modus-themes-toggle' or `modus-themes-load-operandi', will
-continue to work as intended even if they are lazy-loaded (such
-as when they are declared in the `:config' phase)."
- (unless (or (custom-theme-p 'modus-operandi)
- (custom-theme-p 'modus-vivendi))
- (load-theme 'modus-operandi t t)
- (load-theme 'modus-vivendi t t)))
-
-(defvar modus-themes-after-load-theme-hook nil
- "Hook that runs after the `modus-themes-toggle' routines.")
-
-;;;###autoload
-(defun modus-themes-load-operandi ()
- "Load `modus-operandi' and disable `modus-vivendi'.
-Also run `modus-themes-after-load-theme-hook'."
- (interactive)
- (disable-theme 'modus-vivendi)
- (load-theme 'modus-operandi t)
- (run-hooks 'modus-themes-after-load-theme-hook))
-
-;;;###autoload
-(defun modus-themes-load-vivendi ()
- "Load `modus-vivendi' and disable `modus-operandi'.
-Also run `modus-themes-after-load-theme-hook'."
- (interactive)
- (disable-theme 'modus-operandi)
- (load-theme 'modus-vivendi t)
- (run-hooks 'modus-themes-after-load-theme-hook))
-
-(defun modus-themes--load-prompt ()
- "Helper for `modus-themes-toggle'."
- (let ((theme
- (intern
- (completing-read "Load Modus theme (will disable all others): "
- '(modus-operandi modus-vivendi) nil t))))
- (mapc #'disable-theme custom-enabled-themes)
- (pcase theme
- ('modus-operandi (modus-themes-load-operandi))
- ('modus-vivendi (modus-themes-load-vivendi)))))
-
-;;;###autoload
-(defun modus-themes-toggle ()
- "Toggle between `modus-operandi' and `modus-vivendi' themes.
-Also runs `modus-themes-after-load-theme-hook' at its last stage
-by virtue of calling either of `modus-themes-load-operandi' and
-`modus-themes-load-vivendi' functions."
- (interactive)
- (modus-themes-load-themes)
- (pcase (modus-themes--current-theme)
- ('modus-operandi (modus-themes-load-vivendi))
- ('modus-vivendi (modus-themes-load-operandi))
- (_ (modus-themes--load-prompt))))
-
;;;; Face specifications
@@ -4067,901 +1490,624 @@ by virtue of calling either of `modus-themes-load-operandi' and
'(
;;;; custom faces
;; these bespoke faces are inherited by other constructs below
+;;;;; just the foregrounds
+ `(modus-themes-fg-red ((,c :foreground ,red)))
+ `(modus-themes-fg-red-warmer ((,c :foreground ,red-warmer)))
+ `(modus-themes-fg-red-cooler ((,c :foreground ,red-cooler)))
+ `(modus-themes-fg-red-faint ((,c :foreground ,red-faint)))
+ `(modus-themes-fg-red-intense ((,c :foreground ,red-intense)))
+ `(modus-themes-fg-green ((,c :foreground ,green)))
+ `(modus-themes-fg-green-warmer ((,c :foreground ,green-warmer)))
+ `(modus-themes-fg-green-cooler ((,c :foreground ,green-cooler)))
+ `(modus-themes-fg-green-faint ((,c :foreground ,green-faint)))
+ `(modus-themes-fg-green-intense ((,c :foreground ,green-intense)))
+ `(modus-themes-fg-yellow ((,c :foreground ,yellow)))
+ `(modus-themes-fg-yellow-warmer ((,c :foreground ,yellow-warmer)))
+ `(modus-themes-fg-yellow-cooler ((,c :foreground ,yellow-cooler)))
+ `(modus-themes-fg-yellow-faint ((,c :foreground ,yellow-faint)))
+ `(modus-themes-fg-yellow-intense ((,c :foreground ,yellow-intense)))
+ `(modus-themes-fg-blue ((,c :foreground ,blue)))
+ `(modus-themes-fg-blue-warmer ((,c :foreground ,blue-warmer)))
+ `(modus-themes-fg-blue-cooler ((,c :foreground ,blue-cooler)))
+ `(modus-themes-fg-blue-faint ((,c :foreground ,blue-faint)))
+ `(modus-themes-fg-blue-intense ((,c :foreground ,blue-intense)))
+ `(modus-themes-fg-magenta ((,c :foreground ,magenta)))
+ `(modus-themes-fg-magenta-warmer ((,c :foreground ,magenta-warmer)))
+ `(modus-themes-fg-magenta-cooler ((,c :foreground ,magenta-cooler)))
+ `(modus-themes-fg-magenta-faint ((,c :foreground ,magenta-faint)))
+ `(modus-themes-fg-magenta-intense ((,c :foreground ,magenta-intense)))
+ `(modus-themes-fg-cyan ((,c :foreground ,cyan)))
+ `(modus-themes-fg-cyan-warmer ((,c :foreground ,cyan-warmer)))
+ `(modus-themes-fg-cyan-cooler ((,c :foreground ,cyan-cooler)))
+ `(modus-themes-fg-cyan-faint ((,c :foreground ,cyan-faint)))
+ `(modus-themes-fg-cyan-intense ((,c :foreground ,cyan-intense)))
+;;;;; nuanced colored backgrounds
+ `(modus-themes-nuanced-red ((,c :background ,bg-red-nuanced :extend t)))
+ `(modus-themes-nuanced-green ((,c :background ,bg-green-nuanced :extend t)))
+ `(modus-themes-nuanced-yellow ((,c :background ,bg-yellow-nuanced :extend t)))
+ `(modus-themes-nuanced-blue ((,c :background ,bg-blue-nuanced :extend t)))
+ `(modus-themes-nuanced-magenta ((,c :background ,bg-magenta-nuanced :extend t)))
+ `(modus-themes-nuanced-cyan ((,c :background ,bg-cyan-nuanced :extend t)))
;;;;; subtle colored backgrounds
- `(modus-themes-subtle-red ((,class :background ,red-subtle-bg :foreground ,fg-dim)))
- `(modus-themes-subtle-green ((,class :background ,green-subtle-bg :foreground ,fg-dim)))
- `(modus-themes-subtle-yellow ((,class :background ,yellow-subtle-bg :foreground ,fg-dim)))
- `(modus-themes-subtle-blue ((,class :background ,blue-subtle-bg :foreground ,fg-dim)))
- `(modus-themes-subtle-magenta ((,class :background ,magenta-subtle-bg :foreground ,fg-dim)))
- `(modus-themes-subtle-cyan ((,class :background ,cyan-subtle-bg :foreground ,fg-dim)))
- `(modus-themes-subtle-neutral ((,class :background ,bg-inactive :foreground ,fg-inactive)))
+ `(modus-themes-subtle-red ((,c :background ,bg-red-subtle :foreground ,fg-main)))
+ `(modus-themes-subtle-green ((,c :background ,bg-green-subtle :foreground ,fg-main)))
+ `(modus-themes-subtle-yellow ((,c :background ,bg-yellow-subtle :foreground ,fg-main)))
+ `(modus-themes-subtle-blue ((,c :background ,bg-blue-subtle :foreground ,fg-main)))
+ `(modus-themes-subtle-magenta ((,c :background ,bg-magenta-subtle :foreground ,fg-main)))
+ `(modus-themes-subtle-cyan ((,c :background ,bg-cyan-subtle :foreground ,fg-main)))
;;;;; intense colored backgrounds
- `(modus-themes-intense-red ((,class :background ,red-intense-bg :foreground ,fg-main)))
- `(modus-themes-intense-green ((,class :background ,green-intense-bg :foreground ,fg-main)))
- `(modus-themes-intense-yellow ((,class :background ,yellow-intense-bg :foreground ,fg-main)))
- `(modus-themes-intense-blue ((,class :background ,blue-intense-bg :foreground ,fg-main)))
- `(modus-themes-intense-magenta ((,class :background ,magenta-intense-bg :foreground ,fg-main)))
- `(modus-themes-intense-cyan ((,class :background ,cyan-intense-bg :foreground ,fg-main)))
- `(modus-themes-intense-neutral ((,class :background ,bg-active :foreground ,fg-main)))
-;;;;; refined background and foreground combinations
- ;; general purpose styles that use an accented foreground against an
- ;; accented background
- `(modus-themes-refine-red ((,class :background ,red-refine-bg :foreground ,red-refine-fg)))
- `(modus-themes-refine-green ((,class :background ,green-refine-bg :foreground ,green-refine-fg)))
- `(modus-themes-refine-yellow ((,class :background ,yellow-refine-bg :foreground ,yellow-refine-fg)))
- `(modus-themes-refine-blue ((,class :background ,blue-refine-bg :foreground ,blue-refine-fg)))
- `(modus-themes-refine-magenta ((,class :background ,magenta-refine-bg :foreground ,magenta-refine-fg)))
- `(modus-themes-refine-cyan ((,class :background ,cyan-refine-bg :foreground ,cyan-refine-fg)))
-;;;;; "active" combinations, mostly for use on the mode line
- `(modus-themes-active-red ((,class :background ,red-active :foreground ,bg-active)))
- `(modus-themes-active-green ((,class :background ,green-active :foreground ,bg-active)))
- `(modus-themes-active-yellow ((,class :background ,yellow-active :foreground ,bg-active)))
- `(modus-themes-active-blue ((,class :background ,blue-active :foreground ,bg-active)))
- `(modus-themes-active-magenta ((,class :background ,magenta-active :foreground ,bg-active)))
- `(modus-themes-active-cyan ((,class :background ,cyan-active :foreground ,bg-active)))
-;;;;; nuanced backgrounds
- ;; useful for adding an accented background that is suitable for all
- ;; main foreground colors (intended for use in Org source blocks)
- `(modus-themes-nuanced-red ((,class :background ,red-nuanced-bg :extend t)))
- `(modus-themes-nuanced-green ((,class :background ,green-nuanced-bg :extend t)))
- `(modus-themes-nuanced-yellow ((,class :background ,yellow-nuanced-bg :extend t)))
- `(modus-themes-nuanced-blue ((,class :background ,blue-nuanced-bg :extend t)))
- `(modus-themes-nuanced-magenta ((,class :background ,magenta-nuanced-bg :extend t)))
- `(modus-themes-nuanced-cyan ((,class :background ,cyan-nuanced-bg :extend t)))
-;;;;; fringe-specific combinations
- `(modus-themes-fringe-red ((,class :background ,red-fringe-bg :foreground ,fg-main)))
- `(modus-themes-fringe-green ((,class :background ,green-fringe-bg :foreground ,fg-main)))
- `(modus-themes-fringe-yellow ((,class :background ,yellow-fringe-bg :foreground ,fg-main)))
- `(modus-themes-fringe-blue ((,class :background ,blue-fringe-bg :foreground ,fg-main)))
- `(modus-themes-fringe-magenta ((,class :background ,magenta-fringe-bg :foreground ,fg-main)))
- `(modus-themes-fringe-cyan ((,class :background ,cyan-fringe-bg :foreground ,fg-main)))
-;;;;; special base values
- ;; these are closer to the grayscale than the accents defined above
- ;; and should only be used when the next closest alternative would be
- ;; a grayscale value than an accented one
- `(modus-themes-special-cold ((,class :background ,bg-special-cold :foreground ,fg-special-cold)))
- `(modus-themes-special-mild ((,class :background ,bg-special-mild :foreground ,fg-special-mild)))
- `(modus-themes-special-warm ((,class :background ,bg-special-warm :foreground ,fg-special-warm)))
- `(modus-themes-special-calm ((,class :background ,bg-special-calm :foreground ,fg-special-calm)))
-;;;;; diff-specific combinations
- ;; intended for `diff-mode' or equivalent
- `(modus-themes-diff-added
- ((,class ,@(modus-themes--diff
- bg-diff-focus-added fg-diff-focus-added
- green-nuanced-bg fg-diff-added
- bg-diff-focus-added-deuteran fg-diff-focus-added-deuteran
- blue-nuanced-bg fg-diff-added-deuteran))))
- `(modus-themes-diff-changed
- ((,class ,@(modus-themes--diff
- bg-diff-focus-changed fg-diff-focus-changed
- yellow-nuanced-bg fg-diff-changed))))
- `(modus-themes-diff-removed
- ((,class ,@(modus-themes--diff
- bg-diff-focus-removed fg-diff-focus-removed
- red-nuanced-bg fg-diff-removed))))
- `(modus-themes-diff-refine-added
- ((,class ,@(modus-themes--diff
- bg-diff-refine-added fg-diff-refine-added
- bg-diff-focus-added fg-diff-focus-added
- bg-diff-refine-added-deuteran fg-diff-refine-added-deuteran
- bg-diff-focus-added-deuteran fg-diff-focus-added-deuteran))))
- `(modus-themes-diff-refine-changed
- ((,class ,@(modus-themes--diff
- bg-diff-refine-changed fg-diff-refine-changed
- bg-diff-focus-changed fg-diff-focus-changed))))
- `(modus-themes-diff-refine-removed
- ((,class ,@(modus-themes--diff
- bg-diff-refine-removed fg-diff-refine-removed
- bg-diff-focus-removed fg-diff-focus-removed))))
- `(modus-themes-diff-focus-added
- ((,class ,@(modus-themes--diff
- bg-diff-focus-added fg-diff-focus-added
- bg-diff-added fg-diff-added
- bg-diff-focus-added-deuteran fg-diff-focus-added-deuteran
- bg-diff-added-deuteran fg-diff-added-deuteran))))
- `(modus-themes-diff-focus-changed
- ((,class ,@(modus-themes--diff
- bg-diff-focus-changed fg-diff-focus-changed
- bg-diff-changed fg-diff-changed))))
- `(modus-themes-diff-focus-removed
- ((,class ,@(modus-themes--diff
- bg-diff-focus-removed fg-diff-focus-removed
- bg-diff-removed fg-diff-removed))))
- `(modus-themes-diff-heading
- ((,class ,@(modus-themes--diff
- bg-diff-heading fg-diff-heading
- cyan-nuanced-bg cyan-nuanced-fg
- bg-header fg-main
- bg-header fg-main
- t))))
-;;;;; deuteranopia-specific
- `(modus-themes-grue ((,class :foreground ,@(modus-themes--deuteran blue green))))
- `(modus-themes-grue-active ((,class :foreground ,@(modus-themes--deuteran blue-active green-active))))
- `(modus-themes-grue-nuanced ((,class :foreground ,@(modus-themes--deuteran blue-nuanced-fg green-nuanced-fg))))
- `(modus-themes-grue-background-active ((,class :inherit ,@(modus-themes--deuteran
- 'modus-themes-fringe-blue
- 'modus-themes-fringe-green))))
- `(modus-themes-grue-background-intense ((,class :inherit ,@(modus-themes--deuteran
- 'modus-themes-intense-blue
- 'modus-themes-intense-green))))
- `(modus-themes-grue-background-subtle ((,class :inherit ,@(modus-themes--deuteran
- 'modus-themes-subtle-blue
- 'modus-themes-subtle-green))))
- `(modus-themes-grue-background-subtle ((,class :inherit ,@(modus-themes--deuteran
- 'modus-themes-refine-blue
- 'modus-themes-refine-green))))
+ `(modus-themes-intense-red ((,c :background ,bg-red-intense :foreground ,fg-main)))
+ `(modus-themes-intense-green ((,c :background ,bg-green-intense :foreground ,fg-main)))
+ `(modus-themes-intense-yellow ((,c :background ,bg-yellow-intense :foreground ,fg-main)))
+ `(modus-themes-intense-blue ((,c :background ,bg-blue-intense :foreground ,fg-main)))
+ `(modus-themes-intense-magenta ((,c :background ,bg-magenta-intense :foreground ,fg-main)))
+ `(modus-themes-intense-cyan ((,c :background ,bg-cyan-intense :foreground ,fg-main)))
;;;;; mark indicators
;; color combinations intended for Dired, Ibuffer, or equivalent
- `(modus-themes-pseudo-header ((,class :inherit bold :foreground ,fg-main)))
- `(modus-themes-mark-alt ((,class :inherit bold :background ,bg-mark-alt :foreground ,fg-mark-alt)))
- `(modus-themes-mark-del ((,class :inherit bold :background ,bg-mark-del :foreground ,fg-mark-del)))
- `(modus-themes-mark-sel ((,class :inherit bold
- :background ,@(modus-themes--deuteran
- cyan-refine-bg
- bg-mark-sel)
- :foreground ,fg-mark-sel)))
- `(modus-themes-mark-symbol ((,class :inherit bold :foreground ,blue-alt)))
+ `(modus-themes-mark-alt ((,c :inherit bold :background ,bg-mark-other :foreground ,fg-mark-other)))
+ `(modus-themes-mark-del ((,c :inherit bold :background ,bg-mark-delete :foreground ,fg-mark-delete)))
+ `(modus-themes-mark-sel ((,c :inherit bold :background ,bg-mark-select :foreground ,fg-mark-select)))
;;;;; heading levels
;; styles for regular headings used in Org, Markdown, Info, etc.
- `(modus-themes-heading-0
- ((,class ,@(modus-themes--heading
- 0 cyan-alt-other blue-alt
- cyan-nuanced-bg bg-alt bg-region))))
- `(modus-themes-heading-1
- ((,class ,@(modus-themes--heading
- 1 fg-main magenta-alt-other
- magenta-nuanced-bg bg-alt bg-region))))
- `(modus-themes-heading-2
- ((,class ,@(modus-themes--heading
- 2 fg-special-warm magenta-alt
- red-nuanced-bg bg-alt bg-region))))
- `(modus-themes-heading-3
- ((,class ,@(modus-themes--heading
- 3 fg-special-cold blue
- blue-nuanced-bg bg-alt bg-region))))
- `(modus-themes-heading-4
- ((,class ,@(modus-themes--heading
- 4 fg-special-mild cyan
- cyan-nuanced-bg bg-alt bg-region))))
- `(modus-themes-heading-5
- ((,class ,@(modus-themes--heading
- 5 fg-special-calm green-alt-other
- green-nuanced-bg bg-alt bg-region))))
- `(modus-themes-heading-6
- ((,class ,@(modus-themes--heading
- 6 yellow-nuanced-fg yellow-alt-other
- yellow-nuanced-bg bg-alt bg-region))))
- `(modus-themes-heading-7
- ((,class ,@(modus-themes--heading
- 7 red-nuanced-fg red-alt
- red-nuanced-bg bg-alt bg-region))))
- `(modus-themes-heading-8
- ((,class ,@(modus-themes--heading
- 8 magenta-nuanced-fg magenta
- bg-alt bg-alt bg-region))))
+ `(modus-themes-heading-0 ((,c ,@(modus-themes--heading 0 fg-heading-0 bg-heading-0 overline-heading-0))))
+ `(modus-themes-heading-1 ((,c ,@(modus-themes--heading 1 fg-heading-1 bg-heading-1 overline-heading-1))))
+ `(modus-themes-heading-2 ((,c ,@(modus-themes--heading 2 fg-heading-2 bg-heading-2 overline-heading-2))))
+ `(modus-themes-heading-3 ((,c ,@(modus-themes--heading 3 fg-heading-3 bg-heading-3 overline-heading-3))))
+ `(modus-themes-heading-4 ((,c ,@(modus-themes--heading 4 fg-heading-4 bg-heading-4 overline-heading-4))))
+ `(modus-themes-heading-5 ((,c ,@(modus-themes--heading 5 fg-heading-5 bg-heading-5 overline-heading-5))))
+ `(modus-themes-heading-6 ((,c ,@(modus-themes--heading 6 fg-heading-6 bg-heading-6 overline-heading-6))))
+ `(modus-themes-heading-7 ((,c ,@(modus-themes--heading 7 fg-heading-7 bg-heading-7 overline-heading-7))))
+ `(modus-themes-heading-8 ((,c ,@(modus-themes--heading 8 fg-heading-8 bg-heading-8 overline-heading-8))))
;;;;; language checkers
- `(modus-themes-lang-error ((,class ,@(modus-themes--lang-check
- fg-lang-underline-error fg-lang-error
- red red-refine-fg red-nuanced-bg red-refine-bg red-faint))))
- `(modus-themes-lang-note ((,class ,@(modus-themes--lang-check
- fg-lang-underline-note fg-lang-note
- blue-alt blue-refine-fg blue-nuanced-bg blue-refine-bg blue-faint))))
- `(modus-themes-lang-warning ((,class ,@(modus-themes--lang-check
- fg-lang-underline-warning fg-lang-warning
- yellow yellow-refine-fg yellow-nuanced-bg yellow-refine-bg yellow-faint))))
-;;;;; links
- `(modus-themes-link-broken ((,class :inherit button ,@(modus-themes--link-color red red-faint))))
- `(modus-themes-link-symlink ((,class :inherit button ,@(modus-themes--link-color cyan cyan-faint))))
+ `(modus-themes-lang-error ((,c :underline (:style wave :color ,underline-err))))
+ `(modus-themes-lang-note ((,c :underline (:style wave :color ,underline-note))))
+ `(modus-themes-lang-warning ((,c :underline (:style wave :color ,underline-warning))))
+;;;;; prominent semantic notes
+ `(modus-themes-prominent-error ((,c :background ,bg-prominent-err :foreground ,fg-prominent-err)))
+ `(modus-themes-prominent-note ((,c :background ,bg-prominent-note :foreground ,fg-prominent-note)))
+ `(modus-themes-prominent-warning ((,c :background ,bg-prominent-warning :foreground ,fg-prominent-warning)))
;;;;; markup
- `(modus-themes-markup-code
- ((,class ,@(modus-themes--markup cyan-alt-other cyan-intense bg-alt
- bg-special-faint-mild))))
- `(modus-themes-markup-macro
- ((,class ,@(modus-themes--markup magenta-alt-other purple-intense bg-alt
- bg-special-faint-cold))))
- `(modus-themes-markup-verbatim
- ((,class ,@(modus-themes--markup magenta-alt magenta-intense bg-alt
- bg-special-faint-calm))))
+ `(modus-themes-prose-code ((,c :inherit modus-themes-fixed-pitch :background ,bg-prose-code :foreground ,fg-prose-code)))
+ `(modus-themes-prose-macro ((,c :inherit modus-themes-fixed-pitch :background ,bg-prose-macro :foreground ,fg-prose-macro)))
+ `(modus-themes-prose-verbatim ((,c :inherit modus-themes-fixed-pitch :background ,bg-prose-verbatim :foreground ,fg-prose-verbatim)))
;;;;; search
- `(modus-themes-search-success ((,class :inherit modus-themes-intense-yellow)))
- `(modus-themes-search-success-lazy ((,class :inherit modus-themes-subtle-cyan)))
- `(modus-themes-search-success-modeline ((,class :foreground ,@(modus-themes--deuteran
- blue-active
- green-active))))
-;;;;; tabs
- `(modus-themes-tab-active ((,class ,@(modus-themes--tab bg-tab-active nil nil nil t t))))
- `(modus-themes-tab-backdrop ((,class ,@(modus-themes--tab bg-active bg-active-accent nil nil nil nil t))))
- `(modus-themes-tab-inactive ((,class ,@(modus-themes--tab bg-tab-inactive bg-tab-inactive-accent fg-dim nil t))))
+ `(modus-themes-search-current ((,c :background ,bg-search-current :foreground ,fg-main)))
+ `(modus-themes-search-lazy ((,c :background ,bg-search-lazy :foreground ,fg-main)))
+ `(modus-themes-search-replace ((,c :background ,bg-search-replace :foreground ,fg-main)))
+;;;;; search regexp groups
+ `(modus-themes-search-rx-group-0 ((,c :background ,bg-search-rx-group-0 :foreground ,fg-main)))
+ `(modus-themes-search-rx-group-1 ((,c :background ,bg-search-rx-group-1 :foreground ,fg-main)))
+ `(modus-themes-search-rx-group-2 ((,c :background ,bg-search-rx-group-2 :foreground ,fg-main)))
+ `(modus-themes-search-rx-group-3 ((,c :background ,bg-search-rx-group-3 :foreground ,fg-main)))
;;;;; completion frameworks
- `(modus-themes-completion-match-0
- ((,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-match
- 'matches bg-special-faint-cold blue
- blue-subtle-bg blue-intense))))
- `(modus-themes-completion-match-2
- ((,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-match
- 'matches bg-special-faint-warm yellow
- yellow-subtle-bg orange-intense))))
- `(modus-themes-completion-selected
- ((,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-line
- 'popup bg-active blue-alt
- bg-region blue-active
- cyan-subtle-bg cyan-refine-bg))))
-;;;;; buttons
- `(modus-themes-box-button
- ((,class ,@(modus-themes--button bg-active bg-main bg-active-accent
- bg-special-cold bg-region))))
- `(modus-themes-box-button-pressed
- ((,class ,@(modus-themes--button bg-active bg-main bg-active-accent
- bg-special-cold bg-region t))))
+ `(modus-themes-completion-match-0 ((,c ,@(modus-themes--completion-match fg-completion-match-0 bg-completion-match-0))))
+ `(modus-themes-completion-match-1 ((,c ,@(modus-themes--completion-match fg-completion-match-1 bg-completion-match-1))))
+ `(modus-themes-completion-match-2 ((,c ,@(modus-themes--completion-match fg-completion-match-2 bg-completion-match-2))))
+ `(modus-themes-completion-match-3 ((,c ,@(modus-themes--completion-match fg-completion-match-3 bg-completion-match-3))))
+ `(modus-themes-completion-selected ((,c ,@(modus-themes--completion-line bg-completion))))
;;;;; typography
- `(modus-themes-bold ((,class ,@(modus-themes--bold-weight))))
- `(modus-themes-fixed-pitch ((,class ,@(modus-themes--fixed-pitch))))
- `(modus-themes-slant ((,class ,@(modus-themes--slant))))
- `(modus-themes-ui-variable-pitch ((,class ,@(modus-themes--variable-pitch-ui))))
+ `(modus-themes-bold ((,c ,@(modus-themes--bold-weight))))
+ `(modus-themes-fixed-pitch ((,c ,@(modus-themes--fixed-pitch))))
+ `(modus-themes-slant ((,c ,@(modus-themes--slant))))
+ `(modus-themes-ui-variable-pitch ((,c ,@(modus-themes--variable-pitch-ui))))
;;;;; other custom faces
- `(modus-themes-hl-line ((,class ,@(modus-themes--hl-line
- bg-hl-line bg-hl-line-intense
- bg-hl-line-intense-accent blue-nuanced-bg
- bg-region blue-intense-bg
- fg-alt blue-intense)
- :extend t)))
- `(modus-themes-key-binding ((,class :inherit (bold modus-themes-fixed-pitch)
- :foreground ,blue-alt-other)))
- `(modus-themes-prompt ((,class ,@(modus-themes--prompt
- cyan-alt-other blue-alt-other fg-alt
- cyan-nuanced-bg blue-refine-bg fg-main
- bg-alt bg-active))))
- `(modus-themes-reset-hard ((,class :inherit (fixed-pitch modus-themes-reset-soft)
- :family ,(face-attribute 'default :family))))
- `(modus-themes-reset-soft ((,class :background ,bg-main :foreground ,fg-main
- :weight normal :slant normal :strike-through nil
- :box nil :underline nil :overline nil :extend nil)))
+ `(modus-themes-button ((,c :inherit variable-pitch
+ :box (:line-width 1 :color ,border :style released-button)
+ :background ,bg-button-active
+ :foreground ,fg-button-active)))
+ `(modus-themes-key-binding ((,c :inherit (bold modus-themes-fixed-pitch) :foreground ,keybind)))
+ `(modus-themes-prompt ((,c ,@(modus-themes--prompt fg-prompt bg-prompt))))
+ `(modus-themes-reset-soft ((,c :background ,bg-main :foreground ,fg-main
+ :weight normal :slant normal :strike-through nil
+ :box nil :underline nil :overline nil :extend nil)))
;;;; standard faces
;;;;; absolute essentials
- `(default ((,class :background ,bg-main :foreground ,fg-main)))
- `(cursor ((,class :background ,fg-main)))
- `(fringe ((,class ,@(modus-themes--fringe bg-main bg-inactive bg-active)
- :foreground ,fg-main)))
- `(vertical-border ((,class :foreground ,fg-window-divider-inner)))
+ `(default ((,c :background ,bg-main :foreground ,fg-main)))
+ `(cursor ((,c :background ,cursor)))
+ `(fringe ((,c :background ,fringe :foreground ,fg-main)))
+ `(menu ((,c :background ,bg-dim :foreground ,fg-main)))
+ `(scroll-bar ((,c :background ,fringe :foreground ,border)))
+ `(tool-bar ((,c :background ,bg-dim :foreground ,fg-main)))
+ `(vertical-border ((,c :foreground ,border)))
;;;;; 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)))
- `(comint-highlight-prompt ((,class :inherit modus-themes-prompt)))
- `(confusingly-reordered ((,class :inherit modus-themes-lang-error)))
- `(edmacro-label ((,class :inherit bold :foreground ,cyan)))
- `(elisp-shorthand-font-lock-face ((,class :inherit font-lock-variable-name-face)))
- `(error ((,class :inherit bold :foreground ,red)))
- `(escape-glyph ((,class :foreground ,fg-escape-char-construct)))
- `(file-name-shadow ((,class :inherit shadow)))
- `(header-line ((,class :inherit modus-themes-ui-variable-pitch
- :background ,bg-header :foreground ,fg-header)))
- `(header-line-highlight ((,class :inherit highlight)))
- `(help-argument-name ((,class :inherit modus-themes-slant :foreground ,cyan)))
- `(help-key-binding ((,class :inherit modus-themes-key-binding)))
- `(homoglyph ((,class :foreground ,red-alt-faint)))
- `(ibuffer-locked-buffer ((,class :foreground ,yellow-alt-other-faint)))
- `(icon-button ((,class :inherit modus-themes-box-button)))
- `(italic ((,class :slant italic)))
- `(nobreak-hyphen ((,class :foreground ,fg-escape-char-construct)))
- `(nobreak-space ((,class :foreground ,fg-escape-char-construct :underline t)))
- `(menu ((,class :inverse-video unspecified :inherit modus-themes-intense-neutral)))
- `(minibuffer-prompt ((,class :inherit modus-themes-prompt)))
- `(mm-command-output ((,class :foreground ,red-alt-other)))
- `(mm-uu-extract ((,class :background ,bg-dim :foreground ,fg-special-mild)))
- `(next-error ((,class :inherit modus-themes-subtle-red :extend t)))
- `(pgtk-im-0 ((,class :inherit modus-themes-refine-cyan)))
- `(read-multiple-choice-face ((,class :inherit (bold modus-themes-mark-alt))))
- `(rectangle-preview ((,class :inherit modus-themes-special-warm)))
- `(region ((,class ,@(modus-themes--region bg-region fg-main
- 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)))
- `(warning ((,class :inherit bold :foreground ,yellow)))
+ `(appt-notification ((,c :inherit bold :foreground ,modeline-err)))
+ `(blink-matching-paren-offscreen ((,c :background ,bg-paren-match)))
+ `(bold ((,c :weight bold)))
+ `(bold-italic ((,c :inherit (bold italic))))
+ `(underline ((,c :underline ,fg-dim)))
+ `(buffer-menu-buffer ((,c :inherit bold)))
+ `(child-frame-border ((,c :background ,border)))
+ `(comint-highlight-input ((,c :inherit bold)))
+ `(comint-highlight-prompt ((,c :inherit modus-themes-prompt)))
+ `(confusingly-reordered ((,c :inherit modus-themes-lang-error)))
+ `(edmacro-label ((,c :inherit bold :foreground ,accent-0)))
+ `(elisp-shorthand-font-lock-face ((,c :inherit font-lock-variable-name-face)))
+ `(error ((,c :inherit bold :foreground ,err)))
+ `(escape-glyph ((,c :foreground ,err)))
+ `(file-name-shadow ((,c :inherit shadow)))
+ `(header-line ((,c :inherit modus-themes-ui-variable-pitch :background ,bg-dim)))
+ `(header-line-highlight ((,c :background ,bg-hover :foreground ,fg-main :box ,fg-main)))
+ `(help-argument-name ((,c :inherit modus-themes-slant :foreground ,variable)))
+ `(help-key-binding ((,c :inherit modus-themes-key-binding)))
+ `(highlight ((,c :background ,bg-hover :foreground ,fg-main)))
+ `(homoglyph ((,c :foreground ,warning)))
+ `(ibuffer-locked-buffer ((,c :foreground ,warning)))
+ `(icon-button ((,c :inherit modus-themes-button)))
+ `(italic ((,c :slant italic)))
+ `(nobreak-hyphen ((,c :foreground ,err)))
+ `(nobreak-space ((,c :foreground ,err :underline t)))
+ `(menu ((,c :inverse-video unspecified :background ,bg-active :foreground ,fg-main)))
+ `(minibuffer-prompt ((,c :inherit modus-themes-prompt)))
+ `(mm-command-output ((,c :foreground ,mail-part)))
+ `(mm-uu-extract ((,c :foreground ,mail-part)))
+ `(next-error ((,c :inherit modus-themes-prominent-error :extend t)))
+ `(pgtk-im-0 ((,c :inherit modus-themes-prominent-note)))
+ `(read-multiple-choice-face ((,c :inherit modus-themes-mark-sel)))
+ `(rectangle-preview ((,c :inherit secondary-selection)))
+ `(region ((,c :background ,bg-region :foreground ,fg-region)))
+ `(secondary-selection ((,c :background ,bg-hover-secondary :foreground ,fg-main)))
+ `(separator-line ((,c :underline ,bg-active)))
+ `(shadow ((,c :foreground ,fg-dim)))
+ `(success ((,c :inherit bold :foreground ,info)))
+ `(trailing-whitespace ((,c :background ,bg-space-err)))
+ `(warning ((,c :inherit bold :foreground ,warning)))
;;;;; buttons, links, widgets
- `(button ((,class ,@(modus-themes--link
- blue-alt-other blue-alt-other-faint
- bg-region blue-nuanced-bg bg-alt))))
- `(link ((,class :inherit button)))
- `(link-visited ((,class :inherit button
- ,@(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 ,@(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)))
- `(widget-single-line-field ((,class :inherit widget-field)))
-;;;;; alert
- `(alert-high-face ((,class :inherit bold :foreground ,red-alt)))
- `(alert-low-face ((,class :foreground ,fg-special-mild)))
- `(alert-moderate-face ((,class :inherit bold :foreground ,yellow)))
- `(alert-trivial-face ((,class :foreground ,fg-special-calm)))
- `(alert-urgent-face ((,class :inherit bold :foreground ,red-intense)))
+ `(button ((,c :background ,bg-link :foreground ,fg-link :underline ,underline-link)))
+ `(link ((,c :inherit button)))
+ `(link-visited ((,c :background ,bg-link-visited :foreground ,fg-link-visited :underline ,underline-link-visited)))
+ `(tooltip ((,c :background ,bg-active :foreground ,fg-main)))
+;;;;; agda2-mode
+ `(agda2-highlight-bound-variable-face ((,c :inherit font-lock-variable-name-face)))
+ `(agda2-highlight-catchall-clause-face ((,c :background ,bg-inactive)))
+ `(agda2-highlight-coinductive-constructor-face ((,c :inherit font-lock-type-face)))
+ `(agda2-highlight-coverage-problem-face ((,c :inherit modus-themes-lang-error)))
+ `(agda2-highlight-datatype-face ((,c :inherit font-lock-type-face)))
+ `(agda2-highlight-deadcode-face ((,c :background ,bg-active)))
+ `(agda2-highlight-dotted-face ((,c :inherit font-lock-variable-name-face)))
+ `(agda2-highlight-error-face ((,c :inherit modus-themes-lang-error)))
+ `(agda2-highlight-field-face ((,c :inherit font-lock-type-face)))
+ `(agda2-highlight-function-face ((,c :inherit font-lock-function-name-face)))
+ `(agda2-highlight-generalizable-variable-face ((,c :inherit font-lock-variable-name-face)))
+ `(agda2-highlight-incomplete-pattern-face ((,c :inherit modus-themes-lang-warning)))
+ `(agda2-highlight-inductive-constructor-face ((,c :inherit font-lock-type-face)))
+ `(agda2-highlight-keyword-face ((,c :inherit font-lock-keyword-face)))
+ `(agda2-highlight-macro-face ((,c :inherit font-lock-keyword-face)))
+ `(agda2-highlight-module-face ((,c :inherit font-lock-variable-name-face)))
+ `(agda2-highlight-number-face ((,c :inherit shadow)))
+ `(agda2-highlight-operator-face ((,c :inherit font-lock-variable-name-face)))
+ `(agda2-highlight-positivity-problem-face ((,c :inherit modus-themes-lang-warning)))
+ `(agda2-highlight-postulate-face ((,c :inherit font-lock-type-face)))
+ `(agda2-highlight-pragma-face ((,c :inherit font-lock-preprocessor-face)))
+ `(agda2-highlight-primitive-face ((,c :inherit font-lock-type-face)))
+ `(agda2-highlight-primitive-type-face ((,c :inherit font-lock-type-face)))
+ `(agda2-highlight-record-face ((,c :inherit font-lock-type-face)))
+ `(agda2-highlight-string-face ((,c :inherit font-lock-string-face)))
+ `(agda2-highlight-symbol-face ((,c :inherit font-lock-constant-face)))
+ `(agda2-highlight-termination-problem-face ((,c :inherit modus-themes-lang-warning)))
+ `(agda2-highlight-typechecks-face ((,c :inherit font-lock-warning-face)))
+ `(agda2-highlight-unsolved-constraint-face ((,c :inherit modus-themes-lang-warning)))
+ `(agda2-highlight-unsolved-meta-face ((,c :inherit modus-themes-lang-warning)))
;;;;; all-the-icons
- `(all-the-icons-blue ((,class :foreground ,blue-alt-other)))
- `(all-the-icons-blue-alt ((,class :foreground ,blue-alt)))
- `(all-the-icons-cyan ((,class :foreground ,cyan-intense)))
- `(all-the-icons-cyan-alt ((,class :foreground ,cyan-alt)))
- `(all-the-icons-dblue ((,class :foreground ,blue-faint)))
- `(all-the-icons-dcyan ((,class :foreground ,cyan-faint)))
- `(all-the-icons-dgreen ((,class :foreground ,green)))
- `(all-the-icons-dmaroon ((,class :foreground ,magenta-alt-faint)))
- `(all-the-icons-dorange ((,class :foreground ,red-alt-faint)))
- `(all-the-icons-dpink ((,class :foreground ,magenta-faint)))
- `(all-the-icons-dpurple ((,class :foreground ,magenta-alt-other-faint)))
- `(all-the-icons-dred ((,class :foreground ,red-faint)))
- `(all-the-icons-dsilver ((,class :foreground ,cyan-alt-faint)))
- `(all-the-icons-dyellow ((,class :foreground ,yellow-alt-faint)))
- `(all-the-icons-green ((,class :foreground ,green-intense)))
- `(all-the-icons-lblue ((,class :foreground ,blue-alt-other)))
- `(all-the-icons-lcyan ((,class :foreground ,cyan)))
- `(all-the-icons-lgreen ((,class :foreground ,green-alt-other)))
- `(all-the-icons-lmaroon ((,class :foreground ,magenta-alt)))
- `(all-the-icons-lorange ((,class :foreground ,red-alt)))
- `(all-the-icons-lpink ((,class :foreground ,magenta)))
- `(all-the-icons-lpurple ((,class :foreground ,magenta-faint)))
- `(all-the-icons-lred ((,class :foreground ,red)))
- `(all-the-icons-lsilver ((,class :foreground ,fg-docstring)))
- `(all-the-icons-lyellow ((,class :foreground ,yellow-alt)))
- `(all-the-icons-maroon ((,class :foreground ,magenta-intense)))
- `(all-the-icons-orange ((,class :foreground ,orange-intense)))
- `(all-the-icons-pink ((,class :foreground ,fg-special-calm)))
- `(all-the-icons-purple ((,class :foreground ,magenta-alt-other)))
- `(all-the-icons-purple-alt ((,class :foreground ,purple-intense)))
- `(all-the-icons-red ((,class :foreground ,red-intense)))
- `(all-the-icons-red-alt ((,class :foreground ,red-alt-other)))
- `(all-the-icons-silver ((,class :foreground ,fg-special-cold)))
- `(all-the-icons-yellow ((,class :foreground ,yellow)))
+ `(all-the-icons-blue ((,c :foreground ,blue-cooler)))
+ `(all-the-icons-blue-alt ((,c :foreground ,blue-warmer)))
+ `(all-the-icons-cyan ((,c :foreground ,cyan)))
+ `(all-the-icons-cyan-alt ((,c :foreground ,cyan-warmer)))
+ `(all-the-icons-dblue ((,c :foreground ,blue-faint)))
+ `(all-the-icons-dcyan ((,c :foreground ,cyan-faint)))
+ `(all-the-icons-dgreen ((,c :foreground ,green-faint)))
+ `(all-the-icons-dmaroon ((,c :foreground ,magenta-faint)))
+ `(all-the-icons-dorange ((,c :foreground ,red-faint)))
+ `(all-the-icons-dpink ((,c :foreground ,magenta-faint)))
+ `(all-the-icons-dpurple ((,c :foreground ,magenta-cooler)))
+ `(all-the-icons-dred ((,c :foreground ,red)))
+ `(all-the-icons-dsilver ((,c :foreground ,cyan-faint)))
+ `(all-the-icons-dyellow ((,c :foreground ,yellow-faint)))
+ `(all-the-icons-green ((,c :foreground ,green)))
+ `(all-the-icons-lblue ((,c :foreground ,blue-cooler)))
+ `(all-the-icons-lcyan ((,c :foreground ,cyan)))
+ `(all-the-icons-lgreen ((,c :foreground ,green-warmer)))
+ `(all-the-icons-lmaroon ((,c :foreground ,magenta-warmer)))
+ `(all-the-icons-lorange ((,c :foreground ,red-warmer)))
+ `(all-the-icons-lpink ((,c :foreground ,magenta)))
+ `(all-the-icons-lpurple ((,c :foreground ,magenta-faint)))
+ `(all-the-icons-lred ((,c :foreground ,red-faint)))
+ `(all-the-icons-lsilver ((,c :foreground "gray50")))
+ `(all-the-icons-lyellow ((,c :foreground ,yellow-warmer)))
+ `(all-the-icons-maroon ((,c :foreground ,magenta)))
+ `(all-the-icons-orange ((,c :foreground ,yellow-warmer)))
+ `(all-the-icons-pink ((,c :foreground ,magenta-warmer)))
+ `(all-the-icons-purple ((,c :foreground ,magenta-cooler)))
+ `(all-the-icons-purple-alt ((,c :foreground ,blue-warmer)))
+ `(all-the-icons-red ((,c :foreground ,red)))
+ `(all-the-icons-red-alt ((,c :foreground ,red-cooler)))
+ `(all-the-icons-silver ((,c :foreground "gray50")))
+ `(all-the-icons-yellow ((,c :foreground ,yellow)))
;;;;; all-the-icons-dired
- `(all-the-icons-dired-dir-face ((,class :foreground ,cyan-faint)))
+ `(all-the-icons-dired-dir-face ((,c :foreground ,cyan-faint)))
;;;;; all-the-icons-ibuffer
- `(all-the-icons-ibuffer-dir-face ((,class :foreground ,cyan-faint)))
- `(all-the-icons-ibuffer-file-face ((,class :foreground ,blue-faint)))
- `(all-the-icons-ibuffer-mode-face ((,class :foreground ,cyan)))
- `(all-the-icons-ibuffer-size-face ((,class :foreground ,cyan-alt-other)))
+ `(all-the-icons-ibuffer-dir-face ((,c :foreground ,cyan-faint)))
+ `(all-the-icons-ibuffer-file-face ((,c :foreground ,blue-faint)))
+ `(all-the-icons-ibuffer-mode-face ((,c :foreground ,cyan)))
+ `(all-the-icons-ibuffer-size-face ((,c :foreground ,cyan-cooler)))
;;;;; annotate
- `(annotate-annotation ((,class :inherit modus-themes-subtle-blue)))
- `(annotate-annotation-secondary ((,class :inherit modus-themes-subtle-green)))
- `(annotate-highlight ((,class :background ,blue-nuanced-bg :underline ,blue-intense)))
- `(annotate-highlight-secondary ((,class :background ,green-nuanced-bg :underline ,green-intense)))
+ `(annotate-annotation ((,c :inherit modus-themes-subtle-blue)))
+ `(annotate-annotation-secondary ((,c :inherit modus-themes-subtle-magenta)))
+ `(annotate-highlight ((,c :background ,bg-blue-subtle :underline ,blue-intense)))
+ `(annotate-highlight-secondary ((,c :background ,bg-magenta-subtle :underline ,magenta-intense)))
;;;;; ansi-color
;; Those are in Emacs28.
- `(ansi-color-black ((,class :background "black" :foreground "black")))
- `(ansi-color-blue ((,class :background ,blue :foreground ,blue)))
- `(ansi-color-bold ((,class :inherit bold)))
- `(ansi-color-bright-black ((,class :background "gray35" :foreground "gray35")))
- `(ansi-color-bright-blue ((,class :background ,blue-alt :foreground ,blue-alt)))
- `(ansi-color-bright-cyan ((,class :background ,cyan-alt-other :foreground ,cyan-alt-other)))
- `(ansi-color-bright-green ((,class :background ,green-alt-other :foreground ,green-alt-other)))
- `(ansi-color-bright-magenta ((,class :background ,magenta-alt-other :foreground ,magenta-alt-other)))
- `(ansi-color-bright-red ((,class :background ,red-alt :foreground ,red-alt)))
- `(ansi-color-bright-white ((,class :background "white" :foreground "white")))
- `(ansi-color-bright-yellow ((,class :background ,yellow-alt :foreground ,yellow-alt)))
- `(ansi-color-cyan ((,class :background ,cyan :foreground ,cyan)))
- `(ansi-color-green ((,class :background ,green :foreground ,green)))
- `(ansi-color-magenta ((,class :background ,magenta :foreground ,magenta)))
- `(ansi-color-red ((,class :background ,red :foreground ,red)))
- `(ansi-color-white ((,class :background "gray65" :foreground "gray65")))
- `(ansi-color-yellow ((,class :background ,yellow :foreground ,yellow)))
+ `(ansi-color-black ((,c :background ,bg-term-black :foreground ,fg-term-black)))
+ `(ansi-color-blue ((,c :background ,bg-term-blue :foreground ,fg-term-blue)))
+ `(ansi-color-bold ((,c :inherit bold)))
+ `(ansi-color-bright-black ((,c :background ,bg-term-black-bright :foreground ,fg-term-black-bright)))
+ `(ansi-color-bright-blue ((,c :background ,bg-term-blue-bright :foreground ,fg-term-blue-bright)))
+ `(ansi-color-bright-cyan ((,c :background ,bg-term-cyan-bright :foreground ,fg-term-cyan-bright)))
+ `(ansi-color-bright-green ((,c :background ,bg-term-green-bright :foreground ,fg-term-green-bright)))
+ `(ansi-color-bright-magenta ((,c :background ,bg-term-magenta-bright :foreground ,fg-term-magenta-bright)))
+ `(ansi-color-bright-red ((,c :background ,bg-term-red-bright :foreground ,fg-term-red-bright)))
+ `(ansi-color-bright-white ((,c :background ,bg-term-white-bright :foreground ,fg-term-white-bright)))
+ `(ansi-color-bright-yellow ((,c :background ,bg-term-yellow-bright :foreground ,fg-term-yellow-bright)))
+ `(ansi-color-cyan ((,c :background ,bg-term-cyan :foreground ,fg-term-cyan)))
+ `(ansi-color-green ((,c :background ,bg-term-green :foreground ,fg-term-green)))
+ `(ansi-color-magenta ((,c :background ,bg-term-magenta :foreground ,fg-term-magenta)))
+ `(ansi-color-red ((,c :background ,bg-term-red :foreground ,fg-term-red)))
+ `(ansi-color-white ((,c :background ,bg-term-white :foreground ,fg-term-white)))
+ `(ansi-color-yellow ((,c :background ,bg-term-yellow :foreground ,fg-term-yellow)))
;;;;; anzu
- `(anzu-match-1 ((,class :inherit modus-themes-subtle-cyan)))
- `(anzu-match-2 ((,class :inherit modus-themes-search-success)))
- `(anzu-match-3 ((,class :inherit modus-themes-subtle-yellow)))
- `(anzu-mode-line ((,class :inherit (bold modus-themes-search-success-modeline))))
- `(anzu-mode-line-no-match ((,class :inherit bold :foreground ,red-active)))
- `(anzu-replace-highlight ((,class :inherit modus-themes-refine-red :underline t)))
- `(anzu-replace-to ((,class :inherit modus-themes-search-success)))
-;;;;; apropos
- `(apropos-button ((,class :foreground ,magenta-alt-other)))
- `(apropos-function-button ((,class :foreground ,magenta)))
- `(apropos-keybinding ((,class :inherit modus-themes-key-binding)))
- `(apropos-misc-button ((,class :foreground ,green-alt-other)))
- `(apropos-property ((,class :inherit modus-themes-bold :foreground ,magenta-alt)))
- `(apropos-symbol ((,class :inherit modus-themes-pseudo-header)))
- `(apropos-user-option-button ((,class :foreground ,cyan)))
- `(apropos-variable-button ((,class :foreground ,blue-alt)))
-;;;;; artbollocks-mode
- `(artbollocks-face ((,class :inherit modus-themes-lang-note)))
- `(artbollocks-lexical-illusions-face ((,class :background ,bg-alt :foreground ,red-alt :underline t)))
- `(artbollocks-passive-voice-face ((,class :inherit modus-themes-lang-warning)))
- `(artbollocks-weasel-words-face ((,class :inherit modus-themes-lang-error)))
+ `(anzu-match-1 ((,c :inherit modus-themes-subtle-cyan)))
+ `(anzu-match-2 ((,c :inherit modus-themes-search-current)))
+ `(anzu-match-3 ((,c :inherit modus-themes-subtle-yellow)))
+ `(anzu-mode-line ((,c :inherit bold)))
+ `(anzu-mode-line-no-match ((,c :inherit error)))
+ `(anzu-replace-highlight ((,c :inherit modus-themes-search-replace)))
+ `(anzu-replace-to ((,c :inherit modus-themes-search-current)))
;;;;; auctex and Tex
- `(font-latex-bold-face ((,class :inherit bold)))
- `(font-latex-doctex-documentation-face ((,class :inherit font-lock-doc-face)))
- `(font-latex-doctex-preprocessor-face ((,class :inherit font-lock-preprocessor-face)))
- `(font-latex-italic-face ((,class :inherit italic)))
- `(font-latex-math-face ((,class :inherit font-lock-constant-face)))
- `(font-latex-script-char-face ((,class :inherit font-lock-builtin-face)))
- `(font-latex-sectioning-5-face ((,class :inherit (bold modus-themes-variable-pitch) :foreground ,blue-nuanced-fg)))
- `(font-latex-sedate-face ((,class :inherit font-lock-keyword-face)))
- `(font-latex-slide-title-face ((,class :inherit modus-themes-heading-1)))
- `(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-underline-face ((,class :inherit underline)))
- `(font-latex-verbatim-face ((,class :inherit modus-themes-markup-verbatim)))
- `(font-latex-warning-face ((,class :inherit font-lock-warning-face)))
- `(tex-verbatim ((,class :inherit modus-themes-markup-verbatim)))
- `(texinfo-heading ((,class :foreground ,magenta)))
- `(TeX-error-description-error ((,class :inherit error)))
- `(TeX-error-description-help ((,class :inherit success)))
- `(TeX-error-description-tex-said ((,class :inherit success)))
- `(TeX-error-description-warning ((,class :inherit warning)))
+ `(font-latex-bold-face ((,c :inherit bold)))
+ `(font-latex-doctex-documentation-face ((,c :inherit font-lock-doc-face)))
+ `(font-latex-doctex-preprocessor-face ((,c :inherit font-lock-preprocessor-face)))
+ `(font-latex-italic-face ((,c :inherit italic)))
+ `(font-latex-math-face ((,c :inherit font-lock-constant-face)))
+ `(font-latex-script-char-face ((,c :inherit font-lock-builtin-face)))
+ `(font-latex-sectioning-5-face ((,c :inherit (bold modus-themes-variable-pitch) :foreground ,fg-alt)))
+ `(font-latex-sedate-face ((,c :inherit font-lock-keyword-face)))
+ `(font-latex-slide-title-face ((,c :inherit modus-themes-heading-1)))
+ `(font-latex-string-face ((,c :inherit font-lock-string-face)))
+ `(font-latex-subscript-face ((,c :height 0.95)))
+ `(font-latex-superscript-face ((,c :height 0.95)))
+ `(font-latex-underline-face ((,c :inherit underline)))
+ `(font-latex-verbatim-face ((,c :inherit modus-themes-prose-verbatim)))
+ `(font-latex-warning-face ((,c :inherit font-lock-warning-face)))
+ `(tex-verbatim ((,c :inherit modus-themes-prose-verbatim)))
+ ;; `(texinfo-heading ((,c :foreground ,magenta)))
+ `(TeX-error-description-error ((,c :inherit error)))
+ `(TeX-error-description-help ((,c :inherit success)))
+ `(TeX-error-description-tex-said ((,c :inherit success)))
+ `(TeX-error-description-warning ((,c :inherit warning)))
;;;;; auto-dim-other-buffers
- `(auto-dim-other-buffers-face ((,class :background ,bg-alt)))
+ `(auto-dim-other-buffers-face ((,c :background ,bg-inactive)))
;;;;; avy
- `(avy-background-face ((,class :background ,bg-dim :foreground ,fg-dim :extend t)))
- `(avy-goto-char-timer-face ((,class :inherit (modus-themes-intense-neutral bold))))
- `(avy-lead-face ((,class :inherit (bold modus-themes-reset-soft) :background ,bg-char-0)))
- `(avy-lead-face-0 ((,class :inherit (bold modus-themes-reset-soft) :background ,bg-char-1)))
- `(avy-lead-face-1 ((,class :inherit (modus-themes-special-warm modus-themes-reset-soft))))
- `(avy-lead-face-2 ((,class :inherit (bold modus-themes-reset-soft) :background ,bg-char-2)))
+ `(avy-background-face ((,c :background ,bg-dim :foreground ,fg-dim :extend t)))
+ `(avy-goto-char-timer-face ((,c :inherit bold :background ,bg-active)))
+ `(avy-lead-face ((,c :inherit (bold modus-themes-reset-soft) :background ,bg-char-0)))
+ `(avy-lead-face-0 ((,c :inherit (bold modus-themes-reset-soft) :background ,bg-char-1)))
+ `(avy-lead-face-1 ((,c :inherit modus-themes-reset-soft :background ,bg-inactive)))
+ `(avy-lead-face-2 ((,c :inherit (bold modus-themes-reset-soft) :background ,bg-char-2)))
;;;;; aw (ace-window)
- `(aw-background-face ((,class :foreground ,fg-unfocused)))
- `(aw-key-face ((,class :inherit modus-themes-key-binding)))
- `(aw-leading-char-face ((,class :inherit (bold modus-themes-reset-soft) :height 1.5
- :foreground ,red-intense)))
- `(aw-minibuffer-leading-char-face ((,class :inherit (modus-themes-intense-red bold))))
- `(aw-mode-line-face ((,class :inherit bold)))
-;;;;; awesome-tray
- `(awesome-tray-module-awesome-tab-face ((,class :inherit bold :foreground ,red-alt-other)))
- `(awesome-tray-module-battery-face ((,class :inherit bold :foreground ,cyan-alt-other)))
- `(awesome-tray-module-buffer-name-face ((,class :inherit bold :foreground ,yellow-alt-other)))
- `(awesome-tray-module-circe-face ((,class :inherit bold :foreground ,blue-alt)))
- `(awesome-tray-module-date-face ((,class :inherit bold :foreground ,fg-dim)))
- `(awesome-tray-module-evil-face ((,class :inherit bold :foreground ,green-alt)))
- `(awesome-tray-module-git-face ((,class :inherit bold :foreground ,magenta)))
- `(awesome-tray-module-last-command-face ((,class :inherit bold :foreground ,blue-alt-other)))
- `(awesome-tray-module-location-face ((,class :inherit bold :foreground ,yellow)))
- `(awesome-tray-module-mode-name-face ((,class :inherit bold :foreground ,green)))
- `(awesome-tray-module-parent-dir-face ((,class :inherit bold :foreground ,cyan)))
- `(awesome-tray-module-rvm-face ((,class :inherit bold :foreground ,magenta-alt-other)))
-;;;;; bbdb
- `(bbdb-name ((,class :foreground ,magenta-alt-other)))
- `(bbdb-organization ((,class :foreground ,red-alt-other)))
- `(bbdb-field-name ((,class :foreground ,cyan-alt-other)))
+ `(aw-background-face ((,c :foreground "gray50")))
+ `(aw-key-face ((,c :inherit modus-themes-key-binding)))
+ `(aw-leading-char-face ((,c :inherit (bold modus-themes-reset-soft) :height 1.5 :foreground ,red-intense)))
+ `(aw-minibuffer-leading-char-face ((,c :inherit modus-themes-key-binding)))
+ `(aw-mode-line-face ((,c :inherit bold)))
;;;;; binder
- `(binder-sidebar-highlight ((,class :inherit modus-themes-subtle-cyan)))
- `(binder-sidebar-marked ((,class :inherit modus-themes-mark-sel)))
- `(binder-sidebar-missing ((,class :inherit modus-themes-subtle-red)))
- `(binder-sidebar-tags ((,class :foreground ,cyan)))
-;;;;; bm
- `(bm-face ((,class :inherit modus-themes-subtle-yellow :extend t)))
- `(bm-fringe-face ((,class :inherit modus-themes-fringe-yellow)))
- `(bm-fringe-persistent-face ((,class :inherit modus-themes-fringe-blue)))
- `(bm-persistent-face ((,class :inherit modus-themes-intense-blue :extend t)))
+ `(binder-sidebar-highlight ((,c :inherit modus-themes-hl-line)))
+ `(binder-sidebar-marked ((,c :inherit modus-themes-mark-sel)))
+ `(binder-sidebar-missing ((,c :inherit modus-themes-mark-del)))
+ `(binder-sidebar-tags ((,c :foreground ,variable)))
+;;;;; breadcrumb
+ `(breadcrumb-face ((,c :foreground ,fg-alt)))
+ `(breadcrumb-imenu-leaf-face ((,c :inherit bold :foreground ,modeline-info))) ; same as `which-func'
+ `(breadcrumb-project-leaf-face ((,c :inherit bold)))
;;;;; bongo
- `(bongo-album-title ((,class :foreground ,fg-active)))
- `(bongo-artist ((,class :foreground ,magenta-active)))
- `(bongo-currently-playing-track ((,class :inherit bold)))
- `(bongo-elapsed-track-part ((,class :inherit modus-themes-subtle-magenta :underline t)))
- `(bongo-filled-seek-bar ((,class :background ,blue-intense-bg :foreground ,fg-main)))
- `(bongo-marked-track ((,class :foreground ,fg-mark-alt)))
- `(bongo-marked-track-line ((,class :background ,bg-mark-alt)))
- `(bongo-played-track ((,class :foreground ,fg-unfocused :strike-through t)))
- `(bongo-track-length ((,class :inherit shadow)))
- `(bongo-track-title ((,class :foreground ,blue-active)))
- `(bongo-unfilled-seek-bar ((,class :background ,bg-special-cold :foreground ,fg-main)))
+ `(bongo-album-title (( )))
+ `(bongo-artist ((,c :foreground ,accent-0)))
+ `(bongo-currently-playing-track ((,c :inherit bold)))
+ `(bongo-elapsed-track-part ((,c :background ,bg-inactive :underline t)))
+ `(bongo-filled-seek-bar ((,c :background ,bg-hover)))
+ `(bongo-marked-track ((,c :inherit modus-themes-mark-alt)))
+ `(bongo-marked-track-line ((,c :background ,bg-dim)))
+ `(bongo-played-track ((,c :inherit shadow :strike-through t)))
+ `(bongo-track-length ((,c :inherit shadow)))
+ `(bongo-track-title ((,c :foreground ,accent-1)))
+ `(bongo-unfilled-seek-bar ((,c :background ,bg-dim)))
;;;;; boon
- `(boon-modeline-cmd ((,class :inherit modus-themes-active-blue)))
- `(boon-modeline-ins ((,class :inherit modus-themes-active-red)))
- `(boon-modeline-off ((,class :inherit modus-themes-active-yellow)))
- `(boon-modeline-spc ((,class :inherit modus-themes-active-green)))
+ `(boon-modeline-cmd ((,c :inherit modus-themes-intense-blue)))
+ `(boon-modeline-ins ((,c :inherit modus-themes-intense-red)))
+ `(boon-modeline-off ((,c :inherit modus-themes-intense-yellow)))
+ `(boon-modeline-spc ((,c :inherit modus-themes-intense-green)))
;;;;; bookmark
- `(bookmark-face ((,class :inherit modus-themes-fringe-cyan)))
- `(bookmark-menu-bookmark ((,class :inherit bold)))
-;;;;; breakpoint (built-in gdb-mi.el)
- `(breakpoint-disabled ((,class :inherit shadow)))
- `(breakpoint-enabled ((,class :inherit bold :foreground ,red)))
+ `(bookmark-face ((,c :inherit success)))
+ `(bookmark-menu-bookmark ((,c :inherit bold)))
;;;;; calendar and diary
- `(calendar-month-header ((,class :inherit modus-themes-pseudo-header)))
- `(calendar-today ((,class :inherit bold :underline t)))
- `(calendar-weekday-header ((,class :foreground ,fg-unfocused)))
- `(calendar-weekend-header ((,class :foreground ,red-faint)))
- `(diary ((,class :background ,blue-nuanced-bg :foreground ,blue-alt-other)))
- `(diary-anniversary ((,class :foreground ,red-alt-other)))
- `(diary-time ((,class :foreground ,cyan)))
- `(holiday ((,class :background ,magenta-nuanced-bg :foreground ,magenta-alt)))
-;;;;; calfw
- `(cfw:face-annotation ((,class :foreground ,fg-special-warm)))
- `(cfw:face-day-title ((,class :foreground ,fg-main)))
- `(cfw:face-default-content ((,class :foreground ,green-alt)))
- `(cfw:face-default-day ((,class :inherit (cfw:face-day-title bold))))
- `(cfw:face-disable ((,class :foreground ,fg-unfocused)))
- `(cfw:face-grid ((,class :foreground ,fg-window-divider-outer)))
- `(cfw:face-header ((,class :inherit bold :foreground ,fg-main)))
- `(cfw:face-holiday ((,class :foreground ,magenta-alt-other)))
- `(cfw:face-periods ((,class :foreground ,cyan-alt-other)))
- `(cfw:face-saturday ((,class :inherit bold :foreground ,cyan-alt-other)))
- `(cfw:face-select ((,class :inherit modus-themes-intense-blue)))
- `(cfw:face-sunday ((,class :inherit bold :foreground ,cyan-alt-other)))
- `(cfw:face-title ((,class :inherit modus-themes-heading-1 :background ,bg-main :overline nil :foreground ,fg-special-cold)))
- `(cfw:face-today ((,class :background ,bg-inactive)))
- `(cfw:face-today-title ((,class :background ,bg-active)))
- `(cfw:face-toolbar ((,class :background ,bg-alt :foreground ,bg-alt)))
- `(cfw:face-toolbar-button-off ((,class :inherit shadow)))
- `(cfw:face-toolbar-button-on ((,class :inherit bold :background ,blue-nuanced-bg
- :foreground ,blue-alt)))
+ `(calendar-month-header ((,c :inherit bold)))
+ `(calendar-today ((,c :inherit bold :underline t)))
+ `(calendar-weekday-header ((,c :foreground ,date-weekday)))
+ `(calendar-weekend-header ((,c :foreground ,date-weekend)))
+ `(diary ((,c :foreground ,date-common)))
+ `(diary-anniversary ((,c :foreground ,date-holiday)))
+ `(diary-time ((,c :foreground ,date-common)))
+ `(holiday ((,c :foreground ,date-holiday)))
;;;;; calibredb
- `(calibredb-archive-face ((,class :foreground ,magenta-alt-faint)))
- `(calibredb-author-face ((,class :foreground ,blue-faint)))
- `(calibredb-comment-face ((,class :inherit shadow)))
- `(calibredb-date-face ((,class :foreground ,cyan)))
- `(calibredb-edit-annotation-header-title-face ((,class :inherit bold)))
- `(calibredb-favorite-face ((,class :foreground ,red-alt)))
+ ;; NOTE 2022-12-27: Calibredb needs to be reviewed. I had to
+ ;; change the applicable colors for the transition to
+ ;; modus-themes version 4, but I cannot test this currently (it
+ ;; depends on an external program).
+ `(calibredb-archive-face ((,c :foreground ,accent-3)))
+ `(calibredb-author-face ((,c :foreground ,name)))
+ `(calibredb-comment-face ((,c :inherit shadow)))
+ `(calibredb-date-face ((,c :foreground ,date-common)))
+ `(calibredb-edit-annotation-header-title-face ((,c :inherit bold)))
+ `(calibredb-favorite-face ((,c :foreground ,red-warmer)))
`(calibredb-file-face (( )))
- `(calibredb-format-face ((,class :foreground ,cyan-faint)))
- `(calibredb-highlight-face ((,class :inherit success)))
+ `(calibredb-format-face ((,c :foreground ,fg-alt)))
+ `(calibredb-highlight-face ((,c :inherit success)))
`(calibredb-id-face (( )))
`(calibredb-ids-face (( )))
- `(calibredb-search-header-highlight-face ((,class :inherit modus-themes-hl-line)))
- `(calibredb-search-header-library-name-face ((,class :foreground ,blue-active)))
- `(calibredb-search-header-library-path-face ((,class :inherit bold)))
- `(calibredb-search-header-sort-face ((,class :inherit bold :foreground ,magenta-active)))
- `(calibredb-search-header-total-face ((,class :inherit bold :foreground ,cyan-active)))
- `(calibredb-search-header-filter-face ((,class :inherit bold)))
- `(calibredb-mark-face ((,class :inherit modus-themes-mark-sel)))
+ `(calibredb-search-header-highlight-face ((,c :background ,bg-hl-line :extend t)))
+ `(calibredb-search-header-library-name-face ((,c :foreground ,accent-2)))
+ `(calibredb-search-header-library-path-face ((,c :inherit bold)))
+ `(calibredb-search-header-sort-face ((,c :inherit bold :foreground ,accent-1)))
+ `(calibredb-search-header-total-face ((,c :inherit bold :foreground ,accent-0)))
+ `(calibredb-search-header-filter-face ((,c :inherit bold)))
+ `(calibredb-mark-face ((,c :inherit modus-themes-mark-sel)))
`(calibredb-size-face (( )))
- `(calibredb-tag-face ((,class :foreground ,magenta-alt-faint)))
+ `(calibredb-tag-face ((,c :foreground ,fg-alt)))
;;;;; centaur-tabs
- `(centaur-tabs-active-bar-face ((,class :background ,blue-active)))
- `(centaur-tabs-close-mouse-face ((,class :inherit bold :foreground ,red-active :underline t)))
- `(centaur-tabs-close-selected ((,class :inherit centaur-tabs-selected)))
- `(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 ((,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)))
- `(centaur-tabs-unselected-modified ((,class :inherit (italic centaur-tabs-unselected))))
-;;;;; cfrs
- `(cfrs-border-color ((,class :background ,fg-window-divider-inner)))
+ `(centaur-tabs-active-bar-face ((,c :background ,blue)))
+ `(centaur-tabs-close-mouse-face ((,c :inherit bold :foreground ,red :underline t)))
+ `(centaur-tabs-close-selected ((,c :inherit centaur-tabs-selected)))
+ `(centaur-tabs-close-unselected ((,c :inherit centaur-tabs-unselected)))
+ `(centaur-tabs-modified-marker-selected ((,c :inherit centaur-tabs-selected)))
+ `(centaur-tabs-modified-marker-unselected ((,c :inherit centaur-tabs-unselected)))
+ `(centaur-tabs-default ((,c :background ,bg-main)))
+ `(centaur-tabs-selected ((,c :inherit bold :box (:line-width -2 :color ,bg-tab-current) :background ,bg-tab-current)))
+ `(centaur-tabs-selected-modified ((,c :inherit (italic centaur-tabs-selected))))
+ `(centaur-tabs-unselected ((,c :box (:line-width -2 :color ,bg-tab-other) :background ,bg-tab-other)))
+ `(centaur-tabs-unselected-modified ((,c :inherit (italic centaur-tabs-unselected))))
;;;;; change-log and log-view (`vc-print-log' and `vc-print-root-log')
- `(change-log-acknowledgment ((,class :inherit shadow)))
- `(change-log-conditionals ((,class :foreground ,yellow)))
- `(change-log-date ((,class :foreground ,cyan)))
- `(change-log-email ((,class :foreground ,cyan-alt-other)))
- `(change-log-file ((,class :inherit bold :foreground ,fg-special-cold)))
- `(change-log-function ((,class :foreground ,green-alt-other)))
- `(change-log-list ((,class :foreground ,magenta-alt)))
- `(change-log-name ((,class :foreground ,magenta-alt-other)))
- `(log-edit-header ((,class :foreground ,fg-special-warm)))
- `(log-edit-headers-separator ((,class :height 1 :background ,fg-window-divider-inner :extend t)))
- `(log-edit-summary ((,class :inherit bold :foreground ,blue)))
- `(log-edit-unknown-header ((,class :inherit shadow)))
- `(log-view-commit-body ((,class :foreground ,blue-nuanced-fg)))
- `(log-view-file ((,class :inherit bold :foreground ,fg-special-cold)))
- `(log-view-message ((,class :background ,bg-alt :foreground ,fg-alt)))
+ `(change-log-acknowledgment ((,c :foreground ,identifier)))
+ `(change-log-conditionals ((,c :inherit error)))
+ `(change-log-date ((,c :foreground ,date-common)))
+ `(change-log-email ((,c :foreground ,fg-alt)))
+ `(change-log-file ((,c :inherit bold)))
+ `(change-log-function ((,c :inherit warning)))
+ `(change-log-list ((,c :inherit bold)))
+ `(change-log-name ((,c :foreground ,name)))
+ `(log-edit-header ((,c :inherit bold)))
+ `(log-edit-headers-separator ((,c :height 1 :background ,border :extend t)))
+ `(log-edit-summary ((,c :inherit success)))
+ `(log-edit-unknown-header ((,c :inherit shadow)))
+ `(log-view-commit-body (( )))
+ `(log-view-file ((,c :inherit bold)))
+ `(log-view-message ((,c :foreground ,identifier)))
;;;;; cider
- `(cider-debug-code-overlay-face ((,class :background ,bg-alt)))
- `(cider-debug-prompt-face ((,class :foreground ,magenta-alt :underline t)))
- `(cider-deprecated-face ((,class :inherit modus-themes-refine-yellow)))
- `(cider-docview-emphasis-face ((,class :inherit italic :foreground ,fg-special-cold)))
- `(cider-docview-literal-face ((,class :foreground ,blue-alt)))
- `(cider-docview-strong-face ((,class :inherit bold :foreground ,fg-special-cold)))
- `(cider-docview-table-border-face ((,class :inherit shadow)))
- `(cider-enlightened-face ((,class :box (:line-width -1 :color ,yellow-alt :style nil) :background ,bg-dim)))
- `(cider-enlightened-local-face ((,class :inherit bold :foreground ,yellow-alt-other)))
- `(cider-error-highlight-face ((,class :foreground ,red :underline t)))
- `(cider-fragile-button-face ((,class :box (:line-width 3 :color ,fg-alt :style released-button) :foreground ,yellow)))
- `(cider-fringe-good-face ((,class :foreground ,green-active)))
- `(cider-instrumented-face ((,class :box (:line-width -1 :color ,red :style nil) :background ,bg-dim)))
- `(cider-reader-conditional-face ((,class :inherit italic :foreground ,fg-special-warm)))
- `(cider-repl-input-face ((,class :inherit bold)))
- `(cider-repl-prompt-face ((,class :inherit modus-themes-prompt)))
- `(cider-repl-stderr-face ((,class :inherit bold :foreground ,red)))
- `(cider-repl-stdout-face ((,class :foreground ,blue)))
- `(cider-result-overlay-face ((,class :box (:line-width -1 :color ,blue :style nil) :background ,bg-dim)))
- `(cider-stacktrace-error-class-face ((,class :inherit bold :foreground ,red)))
- `(cider-stacktrace-error-message-face ((,class :inherit italic :foreground ,red-alt-other)))
- `(cider-stacktrace-face ((,class :foreground ,fg-main)))
- `(cider-stacktrace-filter-active-face ((,class :foreground ,cyan-alt :underline t)))
- `(cider-stacktrace-filter-inactive-face ((,class :foreground ,cyan-alt)))
- `(cider-stacktrace-fn-face ((,class :inherit bold :foreground ,fg-main)))
- `(cider-stacktrace-ns-face ((,class :inherit (shadow italic))))
- `(cider-stacktrace-promoted-button-face ((,class :box (:line-width 3 :color ,fg-alt :style released-button) :foreground ,red)))
- `(cider-stacktrace-suppressed-button-face ((,class :box (:line-width 3 :color ,fg-alt :style pressed-button)
- :background ,bg-alt :foreground ,fg-alt)))
- `(cider-test-error-face ((,class :inherit modus-themes-subtle-red)))
- `(cider-test-failure-face ((,class :inherit (modus-themes-intense-red bold))))
- `(cider-test-success-face ((,class :inherit modus-themes-grue-background-intense)))
- `(cider-traced-face ((,class :box (:line-width -1 :color ,cyan :style nil) :background ,bg-dim)))
- `(cider-warning-highlight-face ((,class :foreground ,yellow :underline t)))
+ `(cider-deprecated-face ((,c :inherit warning)))
+ `(cider-enlightened-face ((,c :box ,warning)))
+ `(cider-enlightened-local-face ((,c :inherit warning)))
+ `(cider-error-highlight-face ((,c :inherit modus-themes-lang-error)))
+ `(cider-fringe-good-face ((,c :foreground ,info)))
+ `(cider-instrumented-face ((,c :box ,err)))
+ `(cider-reader-conditional-face ((,c :inherit font-lock-type-face)))
+ `(cider-repl-prompt-face ((,c :inherit minibuffer-prompt)))
+ `(cider-repl-stderr-face ((,c :foreground ,err)))
+ `(cider-repl-stdout-face (( )))
+ `(cider-warning-highlight-face ((,c :inherit modus-themes-lang-warning)))
;;;;; circe (and lui)
- `(circe-fool-face ((,class :inherit shadow)))
- `(circe-highlight-nick-face ((,class :inherit bold :foreground ,blue)))
- `(circe-prompt-face ((,class :inherit modus-themes-prompt)))
- `(circe-server-face ((,class :foreground ,fg-unfocused)))
- `(lui-button-face ((,class :inherit button)))
- `(lui-highlight-face ((,class :foreground ,magenta-alt)))
- `(lui-time-stamp-face ((,class :foreground ,blue-nuanced-fg)))
+ `(circe-fool-face ((,c :inherit shadow)))
+ `(circe-highlight-nick-face ((,c :inherit error)))
+ `(circe-prompt-face ((,c :inherit modus-themes-prompt)))
+ `(circe-server-face ((,c :inherit shadow)))
+ `(lui-button-face ((,c :inherit button)))
+ `(lui-highlight-face ((,c :inherit error)))
+ `(lui-time-stamp-face ((,c :foreground ,date-common)))
;;;;; citar
- `(citar ((,class :inherit shadow)))
+ `(citar ((,c :inherit shadow)))
`(citar-highlight (( )))
-;;;;; color-rg
- `(color-rg-font-lock-column-number ((,class :foreground ,magenta-alt-other)))
- `(color-rg-font-lock-command ((,class :inherit bold :foreground ,fg-main)))
- `(color-rg-font-lock-file ((,class :inherit bold :foreground ,fg-special-cold)))
- `(color-rg-font-lock-flash ((,class :inherit modus-themes-intense-blue)))
- `(color-rg-font-lock-function-location ((,class :inherit modus-themes-special-calm)))
- `(color-rg-font-lock-header-line-directory ((,class :foreground ,blue-active)))
- `(color-rg-font-lock-header-line-edit-mode ((,class :foreground ,magenta-active)))
- `(color-rg-font-lock-header-line-keyword ((,class :foreground ,green-active)))
- `(color-rg-font-lock-header-line-text ((,class :foreground ,fg-active)))
- `(color-rg-font-lock-line-number ((,class :foreground ,fg-special-warm)))
- `(color-rg-font-lock-mark-changed ((,class :inherit bold :foreground ,blue)))
- `(color-rg-font-lock-mark-deleted ((,class :inherit bold :foreground ,red)))
- `(color-rg-font-lock-match ((,class :inherit modus-themes-special-calm)))
- `(color-rg-font-lock-position-splitter ((,class :inherit shadow)))
+;;;;; clojure-mode
+ `(clojure-keyword-face ((,c :inherit font-lock-builtin-face)))
;;;;; column-enforce-mode
- `(column-enforce-face ((,class :inherit modus-themes-refine-yellow)))
+ `(column-enforce-face ((,c :inherit modus-themes-prominent-error)))
;;;;; company-mode
- `(company-echo-common ((,class :inherit modus-themes-completion-match-0)))
- `(company-preview ((,class :background ,bg-dim :foreground ,fg-dim)))
- `(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-scrollbar-bg ((,class :background ,bg-active)))
- `(company-scrollbar-fg ((,class :background ,fg-active)))
- `(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)))
- `(company-tooltip-mouse ((,class :inherit highlight)))
- `(company-tooltip-scrollbar-thumb ((,class :background ,fg-active)))
- `(company-tooltip-scrollbar-track ((,class :background ,bg-active)))
- `(company-tooltip-search ((,class :inherit (modus-themes-search-success-lazy bold))))
- `(company-tooltip-search-selection ((,class :inherit modus-themes-search-success :underline t)))
- `(company-tooltip-selection ((,class :inherit modus-themes-completion-selected-popup)))
-;;;;; company-posframe
- `(company-posframe-active-backend-name ((,class :inherit bold :background ,bg-active :foreground ,blue-active)))
- `(company-posframe-inactive-backend-name ((,class :background ,bg-active :foreground ,fg-active)))
- `(company-posframe-metadata ((,class :background ,bg-inactive :foreground ,fg-inactive)))
+ `(company-echo-common ((,c :inherit modus-themes-completion-match-0)))
+ `(company-preview ((,c :background ,bg-dim :foreground ,fg-dim)))
+ `(company-preview-common ((,c :inherit company-echo-common)))
+ `(company-preview-search ((,c :background ,bg-yellow-intense)))
+ `(company-scrollbar-bg ((,c :background ,bg-active)))
+ `(company-scrollbar-fg ((,c :background ,fg-main)))
+ `(company-template-field ((,c :background ,bg-active)))
+ `(company-tooltip ((,c :background ,bg-dim)))
+ `(company-tooltip-annotation ((,c :inherit completions-annotations)))
+ `(company-tooltip-common ((,c :inherit company-echo-common)))
+ `(company-tooltip-deprecated ((,c :inherit company-tooltip :strike-through t)))
+ `(company-tooltip-mouse ((,c :inherit highlight)))
+ `(company-tooltip-scrollbar-thumb ((,c :background ,fg-alt)))
+ `(company-tooltip-scrollbar-track ((,c :background ,bg-inactive)))
+ `(company-tooltip-search ((,c :inherit secondary-selection)))
+ `(company-tooltip-search-selection ((,c :inherit secondary-selection :underline t)))
+ `(company-tooltip-selection ((,c :inherit modus-themes-completion-selected)))
;;;;; compilation
- `(compilation-column-number ((,class :inherit compilation-line-number)))
- `(compilation-error ((,class :inherit modus-themes-bold :foreground ,red)))
- `(compilation-info ((,class :inherit modus-themes-bold :foreground ,fg-special-cold)))
- `(compilation-line-number ((,class :foreground ,fg-special-warm)))
- `(compilation-mode-line-exit ((,class :inherit bold)))
- `(compilation-mode-line-fail ((,class :inherit modus-themes-bold :foreground ,red-active)))
- `(compilation-mode-line-run ((,class :inherit modus-themes-bold :foreground ,cyan-active)))
- `(compilation-warning ((,class :inherit modus-themes-bold :foreground ,yellow-alt)))
+ `(compilation-column-number ((,c :inherit compilation-line-number)))
+ `(compilation-error ((,c :inherit modus-themes-bold :foreground ,err)))
+ `(compilation-info ((,c :inherit modus-themes-bold :foreground ,info)))
+ `(compilation-line-number ((,c :inherit shadow)))
+ `(compilation-mode-line-exit ((,c :inherit bold)))
+ `(compilation-mode-line-fail ((,c :inherit bold :foreground ,modeline-err)))
+ `(compilation-mode-line-run ((,c :inherit bold :foreground ,modeline-warning)))
+ `(compilation-warning ((,c :inherit modus-themes-bold :foreground ,warning)))
;;;;; completions
- `(completions-annotations ((,class :inherit modus-themes-slant :foreground ,cyan-faint)))
- `(completions-common-part ((,class :inherit modus-themes-completion-match-0)))
- `(completions-first-difference ((,class :inherit modus-themes-completion-match-1)))
+ `(completions-annotations ((,c :inherit modus-themes-slant :foreground ,docstring)))
+ `(completions-common-part ((,c :inherit modus-themes-completion-match-0)))
+ `(completions-first-difference ((,c :inherit modus-themes-completion-match-1)))
+ `(completions-highlight ((,c :inherit modus-themes-completion-selected)))
;;;;; consult
- `(consult-async-running ((,class :inherit bold :foreground ,blue)))
- `(consult-async-split ((,class :foreground ,magenta-alt)))
- `(consult-bookmark ((,class :foreground ,blue)))
- `(consult-file ((,class :foreground ,fg-special-cold)))
- `(consult-imenu-prefix ((,class :inherit shadow)))
- `(consult-key ((,class :inherit modus-themes-key-binding)))
- `(consult-line-number ((,class :foreground ,fg-special-warm)))
- `(consult-line-number-prefix ((,class :foreground ,fg-unfocused)))
- `(consult-narrow-indicator ((,class :foreground ,magenta-alt)))
- `(consult-preview-cursor ((,class :inherit modus-themes-intense-blue)))
- `(consult-preview-insertion ((,class :inherit modus-themes-special-warm)))
+ `(consult-async-split ((,c :inherit error)))
+ `(consult-file ((,c :inherit modus-themes-bold :foreground ,info)))
+ `(consult-key ((,c :inherit modus-themes-key-binding)))
+ `(consult-imenu-prefix ((,c :inherit shadow)))
+ `(consult-line-number ((,c :inherit shadow)))
+ `(consult-line-number-prefix ((,c :inherit shadow)))
+ `(consult-preview-insertion ((,c :background ,bg-dim)))
;;;;; corfu
- `(corfu-current ((,class :inherit modus-themes-completion-selected-popup)))
- `(corfu-bar ((,class :background ,fg-alt)))
- `(corfu-border ((,class :background ,bg-active)))
- `(corfu-default ((,class :background ,bg-alt)))
+ `(corfu-current ((,c :inherit modus-themes-completion-selected)))
+ `(corfu-bar ((,c :background ,fg-dim)))
+ `(corfu-border ((,c :background ,bg-active)))
+ `(corfu-default ((,c :background ,bg-dim)))
+;;;;; corfu-candidate-overlay
+ `(corfu-candidate-overlay-face ((t :inherit shadow)))
;;;;; corfu-quick
- `(corfu-quick1 ((,class :inherit bold :background ,bg-char-0)))
- `(corfu-quick2 ((,class :inherit bold :background ,bg-char-1)))
+ `(corfu-quick1 ((,c :inherit bold :background ,bg-char-0)))
+ `(corfu-quick2 ((,c :inherit bold :background ,bg-char-1)))
;;;;; counsel
- `(counsel-active-mode ((,class :foreground ,magenta-alt-other)))
- `(counsel-application-name ((,class :foreground ,red-alt-other)))
- `(counsel-key-binding ((,class :inherit modus-themes-key-binding)))
- `(counsel-outline-1 ((,class :inherit org-level-1)))
- `(counsel-outline-2 ((,class :inherit org-level-2)))
- `(counsel-outline-3 ((,class :inherit org-level-3)))
- `(counsel-outline-4 ((,class :inherit org-level-4)))
- `(counsel-outline-5 ((,class :inherit org-level-5)))
- `(counsel-outline-6 ((,class :inherit org-level-6)))
- `(counsel-outline-7 ((,class :inherit org-level-7)))
- `(counsel-outline-8 ((,class :inherit org-level-8)))
- `(counsel-outline-default ((,class :foreground ,fg-main)))
- `(counsel-variable-documentation ((,class :inherit modus-themes-slant :foreground ,yellow-alt-other)))
-;;;;; counsel-css
- `(counsel-css-selector-depth-face-1 ((,class :foreground ,blue)))
- `(counsel-css-selector-depth-face-2 ((,class :foreground ,cyan)))
- `(counsel-css-selector-depth-face-3 ((,class :foreground ,green)))
- `(counsel-css-selector-depth-face-4 ((,class :foreground ,yellow)))
- `(counsel-css-selector-depth-face-5 ((,class :foreground ,magenta)))
- `(counsel-css-selector-depth-face-6 ((,class :foreground ,red)))
-;;;;; cov
- `(cov-coverage-not-run-face ((,class :foreground ,red-intense)))
- `(cov-coverage-run-face ((,class :foreground ,green-intense)))
- `(cov-heavy-face ((,class :foreground ,magenta-intense)))
- `(cov-light-face ((,class :foreground ,blue-intense)))
- `(cov-med-face ((,class :foreground ,yellow-intense)))
- `(cov-none-face ((,class :foreground ,cyan-intense)))
+ `(counsel-active-mode ((,c :foreground ,keyword)))
+ `(counsel-application-name ((,c :foreground ,name)))
+ `(counsel-key-binding ((,c :inherit modus-themes-key-binding)))
+ `(counsel-outline-default ((,c :foreground ,fg-main)))
+ `(counsel-variable-documentation ((,c :inherit font-lock-doc-face)))
;;;;; cperl-mode
- `(cperl-nonoverridable-face ((,class :foreground unspecified)))
- `(cperl-array-face ((,class :inherit font-lock-keyword-face)))
- `(cperl-hash-face ((,class :inherit font-lock-variable-name-face)))
+ `(cperl-nonoverridable-face ((,c :foreground unspecified)))
+ `(cperl-array-face ((,c :inherit font-lock-keyword-face)))
+ `(cperl-hash-face ((,c :inherit font-lock-variable-name-face)))
;;;;; crontab-mode
- `(crontab-minute ((,class :foreground ,blue-alt)))
- `(crontab-hour ((,class :foreground ,magenta-alt-other)))
- `(crontab-month-day ((,class :foreground ,magenta-alt)))
- `(crontab-month ((,class :foreground ,blue)))
- `(crontab-week-day ((,class :foreground ,cyan)))
- `(crontab-predefined ((,class :foreground ,blue-alt)))
-;;;;; css-mode
- `(css-property ((,class :inherit font-lock-type-face)))
- `(css-selector ((,class :inherit font-lock-keyword-face)))
+ `(crontab-minute ((,c :foreground ,string)))
+ `(crontab-hour ((,c :foreground ,keyword)))
+ `(crontab-month-day ((,c :foreground ,builtin)))
+ `(crontab-month ((,c :foreground ,constant)))
+ `(crontab-week-day ((,c :foreground ,variable)))
+ `(crontab-predefined ((,c :foreground ,string)))
;;;;; csv-mode
- `(csv-separator-face ((,class :foreground ,red-intense)))
+ `(csv-separator-face ((,c :foreground ,red-intense)))
;;;;; ctrlf
- `(ctrlf-highlight-active ((,class :inherit modus-themes-search-success)))
- `(ctrlf-highlight-line ((,class :inherit modus-themes-hl-line)))
- `(ctrlf-highlight-passive ((,class :inherit modus-themes-search-success-lazy)))
+ `(ctrlf-highlight-active ((,c :inherit modus-themes-search-current)))
+ `(ctrlf-highlight-line ((,c :background ,bg-hl-line :extend t)))
+ `(ctrlf-highlight-passive ((,c :inherit modus-themes-search-lazy)))
;;;;; custom (M-x customize)
- `(custom-button ((,class :inherit modus-themes-box-button)))
- `(custom-button-mouse ((,class :inherit (highlight custom-button))))
- `(custom-button-pressed ((,class :inherit modus-themes-box-button-pressed)))
- `(custom-changed ((,class :inherit modus-themes-subtle-cyan)))
- `(custom-comment ((,class :inherit shadow)))
- `(custom-comment-tag ((,class :background ,bg-alt :foreground ,yellow-alt-other)))
- `(custom-face-tag ((,class :inherit bold :foreground ,blue-intense)))
- `(custom-group-tag ((,class :inherit modus-themes-pseudo-header :foreground ,magenta-alt)))
- `(custom-group-tag-1 ((,class :inherit modus-themes-special-warm)))
- `(custom-invalid ((,class :inherit (modus-themes-intense-red bold))))
- `(custom-modified ((,class :inherit modus-themes-subtle-cyan)))
- `(custom-rogue ((,class :inherit modus-themes-refine-magenta)))
- `(custom-set ((,class :foreground ,blue-alt)))
- `(custom-state ((,class :foreground ,red-alt-faint)))
- `(custom-themed ((,class :inherit modus-themes-subtle-blue)))
- `(custom-variable-obsolete ((,class :inherit shadow)))
- `(custom-variable-tag ((,class :foreground ,cyan)))
-;;;;; dap-mode
- `(dap-mouse-eval-thing-face ((,class :box (:line-width -1 :color ,blue-active :style nil)
- :background ,bg-active :foreground ,fg-main)))
- `(dap-result-overlay-face ((,class :box (:line-width -1 :color ,bg-active :style nil)
- :background ,bg-active :foreground ,fg-main)))
- `(dap-ui-breakpoint-verified-fringe ((,class :inherit bold :foreground ,green-active)))
- `(dap-ui-compile-errline ((,class :inherit bold :foreground ,red-intense)))
- `(dap-ui-locals-scope-face ((,class :inherit bold :foreground ,magenta :underline t)))
- `(dap-ui-locals-variable-face ((,class :inherit bold :foreground ,cyan)))
- `(dap-ui-locals-variable-leaf-face ((,class :inherit italic :foreground ,cyan-alt-other)))
- `(dap-ui-marker-face ((,class :inherit modus-themes-subtle-blue)))
- `(dap-ui-sessions-stack-frame-face ((,class :inherit bold :foreground ,magenta-alt)))
- `(dap-ui-sessions-terminated-active-face ((,class :inherit bold :foreground ,fg-alt)))
- `(dap-ui-sessions-terminated-face ((,class :inherit shadow)))
+ `(custom-button ((,c :inherit modus-themes-button)))
+ `(custom-button-mouse ((,c :inherit (highlight custom-button))))
+ `(custom-button-pressed ((,c :inherit (secondary-selection custom-button))))
+ `(custom-changed ((,c :background ,bg-changed)))
+ `(custom-comment ((,c :inherit shadow)))
+ `(custom-comment-tag ((,c :inherit (bold shadow))))
+ `(custom-invalid ((,c :inherit error :strike-through t)))
+ `(custom-modified ((,c :inherit custom-changed)))
+ `(custom-rogue ((,c :inherit custom-invalid)))
+ `(custom-set ((,c :inherit success)))
+ `(custom-state ((,c :foreground ,warning)))
+ `(custom-themed ((,c :inherit custom-changed)))
+ `(custom-variable-obsolete ((,c :inherit shadow)))
+ `(custom-face-tag ((,c :inherit bold :foreground ,type)))
+ `(custom-group-tag ((,c :inherit bold :foreground ,builtin)))
+ `(custom-group-tag-1 ((,c :inherit bold :foreground ,constant)))
+ `(custom-variable-tag ((,c :inherit bold :foreground ,variable)))
+;;;;; dashboard
+ `(dashboard-heading ((,c :foreground ,name)))
+ `(dashboard-items-face (( ))) ; use the underlying style of all-the-icons
;;;;; deadgrep
- `(deadgrep-filename-face ((,class :inherit bold :foreground ,fg-special-cold)))
- `(deadgrep-match-face ((,class :inherit modus-themes-special-calm)))
- `(deadgrep-meta-face ((,class :inherit shadow)))
- `(deadgrep-regexp-metachar-face ((,class :inherit bold :foreground ,yellow-intense)))
- `(deadgrep-search-term-face ((,class :inherit bold :foreground ,green-intense)))
+ `(deadgrep-filename-face ((,c :inherit bold :foreground ,name)))
+ `(deadgrep-match-face ((,c :inherit match)))
+ `(deadgrep-meta-face ((,c :inherit shadow)))
+ `(deadgrep-regexp-metachar-face ((,c :inherit font-lock-regexp-grouping-construct)))
+ `(deadgrep-search-term-face ((,c :inherit success)))
;;;;; debbugs
- `(debbugs-gnu-archived ((,class :inverse-video t)))
- `(debbugs-gnu-done ((,class :inherit shadow)))
- `(debbugs-gnu-forwarded ((,class :foreground ,fg-special-warm)))
- `(debbugs-gnu-handled ((,class :foreground ,blue)))
- `(debbugs-gnu-new ((,class :foreground ,red)))
- `(debbugs-gnu-pending ((,class :foreground ,cyan)))
- `(debbugs-gnu-stale-1 ((,class :foreground ,yellow-nuanced-fg)))
- `(debbugs-gnu-stale-2 ((,class :foreground ,yellow)))
- `(debbugs-gnu-stale-3 ((,class :foreground ,yellow-alt)))
- `(debbugs-gnu-stale-4 ((,class :foreground ,yellow-alt-other)))
- `(debbugs-gnu-stale-5 ((,class :foreground ,red-alt)))
- `(debbugs-gnu-tagged ((,class :foreground ,magenta-alt)))
+ `(debbugs-gnu-archived ((,c :background ,bg-inactive :foreground ,fg-dim)))
+ `(debbugs-gnu-done ((,c :inherit success)))
+ `(debbugs-gnu-forwarded ((,c :inherit modus-themes-slant :foreground ,info)))
+ `(debbugs-gnu-handled (( )))
+ `(debbugs-gnu-marked ((,c :inherit modus-themes-mark-sel)))
+ `(debbugs-gnu-marked-stale ((,c :inherit modus-themes-mark-alt)))
+ `(debbugs-gnu-new ((,c :inherit error)))
+ `(debbugs-gnu-pending ((,c :inherit modus-themes-slant :foreground ,fg-alt)))
+ `(debbugs-gnu-stale-1 ((,c :foreground ,red-cooler)))
+ `(debbugs-gnu-stale-2 ((,c :foreground ,yellow-warmer)))
+ `(debbugs-gnu-stale-3 ((,c :foreground ,magenta-warmer)))
+ `(debbugs-gnu-stale-4 ((,c :foreground ,magenta-cooler)))
+ `(debbugs-gnu-stale-5 ((,c :foreground ,cyan-faint)))
+ `(debbugs-gnu-tagged ((,c :inherit modus-themes-mark-alt)))
+ `(debbugs-gnu-title ((,c :inherit bold)))
;;;;; deft
- `(deft-filter-string-face ((,class :inherit bold :foreground ,blue)))
- `(deft-header-face ((,class :foreground ,fg-special-warm)))
- `(deft-separator-face ((,class :foreground "gray50")))
- `(deft-summary-face ((,class :inherit (shadow modus-themes-slant))))
- `(deft-time-face ((,class :foreground ,cyan)))
- `(deft-title-face ((,class :inherit bold)))
+ `(deft-filter-string-face ((,c :inherit success)))
+ `(deft-header-face ((,c :inherit shadow)))
+ `(deft-separator-face ((,c :foreground "gray50")))
+ `(deft-summary-face ((,c :inherit (shadow modus-themes-slant))))
+ `(deft-time-face ((,c :foreground ,date-common)))
+ `(deft-title-face ((,c :inherit bold)))
;;;;; denote
- `(denote-faces-date ((,class :foreground ,cyan)))
- `(denote-faces-keywords ((,class :inherit modus-themes-bold :foreground ,magenta-alt)))
+ `(denote-faces-date ((,c :foreground ,date-common)))
+ `(denote-faces-delimiter ((,c :inherit shadow)))
+ `(denote-faces-extension ((,c :inherit shadow)))
+ `(denote-faces-keywords ((,c :inherit modus-themes-bold :foreground ,keyword)))
+ `(denote-faces-link ((,c :inherit link)))
+ `(denote-faces-prompt-current-name ((,c :inherit modus-themes-slant :foreground ,fg-changed-intense)))
+ `(denote-faces-prompt-new-name ((,c :inherit modus-themes-slant :foreground ,fg-added-intense)))
+ `(denote-faces-prompt-old-name ((,c :inherit modus-themes-slant :foreground ,fg-removed-intense)))
+ `(denote-faces-signature ((,c :inherit modus-themes-bold :foreground ,string)))
+ `(denote-faces-subdirectory ((,c :inherit modus-themes-bold :foreground ,fg-alt)))
+ `(denote-faces-time ((,c :inherit denote-faces-date)))
+ `(denote-faces-time-delimiter ((,c :inherit shadow)))
+ `(denote-faces-title (( )))
;;;;; devdocs
- `(devdocs-code-block ((,class :inherit modus-themes-fixed-pitch :background ,bg-dim :extend t)))
+ `(devdocs-code-block ((,c :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)))
- `(dictionary-word-definition-face (()))
- `(dictionary-word-entry-face ((,class :inherit font-lock-comment-face)))
+ `(dictionary-button-face ((,c :inherit bold)))
+ `(dictionary-reference-face ((,c :inherit link)))
+ `(dictionary-word-definition-face (( )))
+ `(dictionary-word-entry-face ((,c :inherit font-lock-comment-face)))
;;;;; diff-hl
- `(diff-hl-change ((,class :inherit modus-themes-fringe-yellow)))
- `(diff-hl-delete ((,class :inherit modus-themes-fringe-red)))
- `(diff-hl-insert ((,class :inherit modus-themes-grue-background-active)))
- `(diff-hl-reverted-hunk-highlight ((,class :background ,fg-main :foreground ,bg-main)))
+ `(diff-hl-change ((,c :background ,bg-changed-fringe)))
+ `(diff-hl-delete ((,c :background ,bg-removed-fringe)))
+ `(diff-hl-insert ((,c :background ,bg-added-fringe)))
+ `(diff-hl-reverted-hunk-highlight ((,c :background ,fg-main :foreground ,bg-main)))
;;;;; diff-mode
- `(diff-added ((,class :inherit modus-themes-diff-added)))
- `(diff-changed ((,class :inherit modus-themes-diff-changed :extend t)))
- `(diff-changed-unspecified ((,class :inherit diff-changed)))
- `(diff-context ((,class ,@(unless (eq modus-themes-diffs 'bg-only) (list :foreground fg-unfocused)))))
- `(diff-error ((,class :inherit modus-themes-intense-red)))
- `(diff-file-header ((,class :inherit (bold diff-header))))
- `(diff-function ((,class :inherit modus-themes-diff-heading)))
- `(diff-header ((,class :foreground ,fg-main)))
- `(diff-hunk-header ((,class :inherit (bold modus-themes-diff-heading))))
- `(diff-index ((,class :inherit bold :foreground ,blue-alt)))
- `(diff-indicator-added ((,class :inherit (modus-themes-grue diff-added bold))))
- `(diff-indicator-changed ((,class :inherit (diff-changed bold) :foreground ,yellow)))
- `(diff-indicator-removed ((,class :inherit (diff-removed bold) :foreground ,red)))
- `(diff-nonexistent ((,class :inherit (modus-themes-neutral bold))))
- `(diff-refine-added ((,class :inherit modus-themes-diff-refine-added)))
- `(diff-refine-changed ((,class :inherit modus-themes-diff-refine-changed)))
- `(diff-refine-removed ((,class :inherit modus-themes-diff-refine-removed)))
- `(diff-removed ((,class :inherit modus-themes-diff-removed)))
+ `(diff-added ((,c :background ,bg-added :foreground ,fg-added)))
+ `(diff-changed ((,c :background ,bg-changed :foreground ,fg-changed :extend t)))
+ `(diff-changed-unspecified ((,c :inherit diff-changed)))
+ `(diff-removed ((,c :background ,bg-removed :foreground ,fg-removed)))
+ `(diff-refine-added ((,c :background ,bg-added-refine :foreground ,fg-added)))
+ `(diff-refine-changed ((,c :background ,bg-changed-refine :foreground ,fg-changed)))
+ `(diff-refine-removed ((,c :background ,bg-removed-refine :foreground ,fg-removed)))
+ `(diff-indicator-added ((,c :inherit diff-added :foreground ,fg-added-intense)))
+ `(diff-indicator-changed ((,c :inherit diff-changed :foreground ,fg-changed-intense)))
+ `(diff-indicator-removed ((,c :inherit diff-removed :foreground ,fg-removed-intense)))
+ `(diff-context (( )))
+ `(diff-error ((,c :inherit error)))
+ `(diff-file-header ((,c :inherit bold)))
+ `(diff-function ((,c :background ,bg-inactive)))
+ `(diff-header (( )))
+ `(diff-hunk-header ((,c :inherit bold :background ,bg-inactive)))
+ `(diff-index ((,c :inherit italic)))
+ `(diff-nonexistent ((,c :inherit bold)))
;;;;; dim-autoload
- `(dim-autoload-cookie-line ((,class :inherit font-lock-comment-face)))
-;;;;; dir-treeview
- `(dir-treeview-archive-face ((,class :foreground ,fg-special-warm)))
- `(dir-treeview-archive-icon-face ((,class :inherit dir-treeview-default-icon-face :foreground ,yellow)))
- `(dir-treeview-audio-face ((,class :foreground ,magenta)))
- `(dir-treeview-audio-icon-face ((,class :inherit dir-treeview-default-icon-face :foreground ,magenta-alt)))
- `(dir-treeview-control-face ((,class :inherit shadow)))
- `(dir-treeview-control-mouse-face ((,class :inherit highlight)))
- `(dir-treeview-default-icon-face ((,class :inherit (shadow bold) :family "Font Awesome")))
- `(dir-treeview-default-filename-face ((,class :foreground ,fg-main)))
- `(dir-treeview-directory-face ((,class :foreground ,blue)))
- `(dir-treeview-directory-icon-face ((,class :inherit dir-treeview-default-icon-face :foreground ,blue-alt)))
- `(dir-treeview-executable-face ((,class :foreground ,red-alt)))
- `(dir-treeview-executable-icon-face ((,class :inherit dir-treeview-default-icon-face :foreground ,red-alt-other)))
- `(dir-treeview-image-face ((,class :foreground ,green-alt-other)))
- `(dir-treeview-image-icon-face ((,class :inherit dir-treeview-default-icon-face :foreground ,green-alt)))
- `(dir-treeview-indent-face ((,class :inherit shadow)))
- `(dir-treeview-label-mouse-face ((,class :inherit highlight)))
- `(dir-treeview-start-dir-face ((,class :inherit modus-themes-pseudo-header)))
- `(dir-treeview-symlink-face ((,class :inherit modus-themes-link-symlink)))
- `(dir-treeview-video-face ((,class :foreground ,magenta-alt-other)))
- `(dir-treeview-video-icon-face ((,class :inherit dir-treeview-default-icon-face :foreground ,magenta-alt-other)))
+ `(dim-autoload-cookie-line ((,c :inherit font-lock-comment-face)))
;;;;; dired
- `(dired-broken-symlink ((,class :inherit modus-themes-link-broken)))
- `(dired-directory ((,class :foreground ,blue)))
- `(dired-flagged ((,class :inherit modus-themes-mark-del)))
- `(dired-header ((,class :inherit modus-themes-pseudo-header)))
- `(dired-ignored ((,class :inherit shadow)))
- `(dired-mark ((,class :inherit modus-themes-mark-symbol)))
- `(dired-marked ((,class :inherit modus-themes-mark-sel)))
- `(dired-perm-write ((,class :foreground ,fg-special-warm)))
- `(dired-symlink ((,class :inherit modus-themes-link-symlink)))
- `(dired-warning ((,class :inherit bold :foreground ,yellow)))
+ `(dired-broken-symlink ((,c :inherit button :foreground ,err)))
+ `(dired-directory ((,c :foreground ,accent-0)))
+ `(dired-flagged ((,c :inherit modus-themes-mark-del)))
+ `(dired-header ((,c :inherit bold)))
+ `(dired-ignored ((,c :inherit shadow)))
+ `(dired-mark ((,c :inherit bold)))
+ `(dired-marked ((,c :inherit modus-themes-mark-sel)))
+ `(dired-perm-write ((,c :inherit shadow)))
+ `(dired-symlink ((,c :inherit button :background ,bg-link-symbolic :foreground ,fg-link-symbolic :underline ,underline-link-symbolic)))
+ `(dired-warning ((,c :inherit warning)))
;;;;; dired-async
- `(dired-async-failures ((,class :inherit bold :foreground ,red-active)))
- `(dired-async-message ((,class :inherit bold :foreground ,blue-active)))
- `(dired-async-mode-message ((,class :inherit bold :foreground ,cyan-active)))
+ `(dired-async-failures ((,c :inherit error)))
+ `(dired-async-message ((,c :inherit bold)))
+ `(dired-async-mode-message ((,c :inherit bold)))
;;;;; dired-git
- `(dired-git-branch-else ((,class :inherit bold :foreground ,magenta-alt)))
- `(dired-git-branch-master ((,class :inherit bold :foreground ,magenta-alt-other)))
+ `(dired-git-branch-else ((,c :inherit bold :foreground ,accent-0)))
+ `(dired-git-branch-master ((,c :inherit bold :foreground ,accent-1)))
;;;;; dired-git-info
- `(dgi-commit-message-face ((,class :foreground ,cyan-alt-other)))
+ `(dgi-commit-message-face ((,c :foreground ,docstring)))
;;;;; dired-narrow
- `(dired-narrow-blink ((,class :inherit (modus-themes-subtle-cyan bold))))
+ `(dired-narrow-blink ((,c :inherit (modus-themes-prominent-warning bold))))
;;;;; dired-subtree
;; remove backgrounds from dired-subtree faces, else they break
;; dired-{flagged,marked} and any other face that sets a background
@@ -4974,2596 +2120,2036 @@ by virtue of calling either of `modus-themes-load-operandi' and
`(dired-subtree-depth-5-face (()))
`(dired-subtree-depth-6-face (()))
;;;;; diredfl
- `(diredfl-autofile-name ((,class :inherit modus-themes-special-cold)))
- `(diredfl-compressed-file-name ((,class :foreground ,fg-special-warm)))
- `(diredfl-compressed-file-suffix ((,class :foreground ,red-alt)))
- `(diredfl-date-time ((,class :foreground ,cyan)))
- `(diredfl-deletion ((,class :inherit modus-themes-mark-del)))
- `(diredfl-deletion-file-name ((,class :inherit modus-themes-mark-del)))
- `(diredfl-dir-heading ((,class :inherit modus-themes-pseudo-header)))
- `(diredfl-dir-name ((,class :inherit dired-directory)))
- `(diredfl-dir-priv ((,class :foreground ,blue-alt)))
- `(diredfl-exec-priv ((,class :foreground ,magenta-alt)))
- `(diredfl-executable-tag ((,class :foreground ,magenta-alt)))
- `(diredfl-file-name ((,class :foreground ,fg-main)))
- `(diredfl-file-suffix ((,class :foreground ,magenta-alt-other)))
- `(diredfl-flag-mark ((,class :inherit modus-themes-mark-sel)))
- `(diredfl-flag-mark-line ((,class :inherit modus-themes-mark-sel)))
- `(diredfl-ignored-file-name ((,class :inherit shadow)))
- `(diredfl-link-priv ((,class :foreground ,blue-alt-other)))
- `(diredfl-no-priv ((,class :foreground "gray50")))
- `(diredfl-number ((,class :foreground ,cyan-alt-other-faint)))
- `(diredfl-other-priv ((,class :foreground ,yellow)))
- `(diredfl-rare-priv ((,class :foreground ,red)))
- `(diredfl-read-priv ((,class :foreground ,fg-main)))
- `(diredfl-symlink ((,class :inherit dired-symlink)))
- `(diredfl-tagged-autofile-name ((,class :inherit modus-themes-refine-magenta)))
- `(diredfl-write-priv ((,class :foreground ,cyan)))
-;;;;; dired+
- `(diredp-autofile-name ((,class :inherit modus-themes-special-cold)))
- `(diredp-compressed-file-name ((,class :foreground ,fg-special-warm)))
- `(diredp-compressed-file-suffix ((,class :foreground ,red-alt)))
- `(diredp-date-time ((,class :foreground ,cyan)))
- `(diredp-deletion ((,class :inherit modus-themes-mark-del)))
- `(diredp-deletion-file-name ((,class :inherit modus-themes-mark-del)))
- `(diredp-dir-heading ((,class :inherit modus-themes-pseudo-header)))
- `(diredp-dir-name ((,class :inherit dired-directory)))
- `(diredp-dir-priv ((,class :foreground ,blue-alt)))
- `(diredp-exec-priv ((,class :foreground ,magenta-alt)))
- `(diredp-executable-tag ((,class :foreground ,magenta-alt)))
- `(diredp-file-name ((,class :foreground ,fg-main)))
- `(diredp-file-suffix ((,class :foreground ,magenta-alt-other)))
- `(diredp-flag-mark ((,class :inherit modus-themes-mark-sel)))
- `(diredp-flag-mark-line ((,class :inherit modus-themes-mark-sel)))
- `(diredp-ignored-file-name ((,class :inherit shadow)))
- `(diredp-link-priv ((,class :foreground ,blue-alt-other)))
- `(diredp-mode-line-flagged ((,class :foreground ,red-active)))
- `(diredp-mode-line-marked ((,class :foreground ,green-active)))
- `(diredp-no-priv ((,class :foreground "gray50")))
- `(diredp-number ((,class :foreground ,cyan-alt-other-faint)))
- `(diredp-omit-file-name ((,class :inherit shadow :strike-through t)))
- `(diredp-other-priv ((,class :foreground ,yellow)))
- `(diredp-rare-priv ((,class :foreground ,red)))
- `(diredp-read-priv ((,class :foreground ,fg-main)))
- `(diredp-symlink ((,class :inherit dired-symlink)))
- `(diredp-tagged-autofile-name ((,class :inherit modus-themes-refine-magenta)))
- `(diredp-write-priv ((,class :foreground ,cyan)))
+ `(diredfl-autofile-name ((,c :background ,bg-inactive)))
+ `(diredfl-compressed-file-name ((,c :foreground ,warning)))
+ `(diredfl-compressed-file-suffix ((,c :foreground ,err)))
+ `(diredfl-date-time ((,c :foreground ,date-common)))
+ `(diredfl-deletion ((,c :inherit dired-flagged)))
+ `(diredfl-deletion-file-name ((,c :inherit diredfl-deletion)))
+ `(diredfl-dir-heading ((,c :inherit bold)))
+ `(diredfl-dir-name ((,c :inherit dired-directory)))
+ `(diredfl-dir-priv ((,c :inherit dired-directory)))
+ `(diredfl-exec-priv ((,c :foreground ,accent-1)))
+ `(diredfl-executable-tag ((,c :inherit diredfl-exec-priv)))
+ `(diredfl-file-name ((,c :foreground ,fg-main)))
+ `(diredfl-file-suffix ((,c :foreground ,variable)))
+ `(diredfl-flag-mark ((,c :inherit dired-marked)))
+ `(diredfl-flag-mark-line ((,c :inherit dired-marked)))
+ `(diredfl-ignored-file-name ((,c :inherit shadow)))
+ `(diredfl-link-priv ((,c :foreground ,fg-link)))
+ `(diredfl-no-priv ((,c :inherit shadow)))
+ `(diredfl-number ((,c :inherit shadow)))
+ `(diredfl-other-priv ((,c :foreground ,accent-2)))
+ `(diredfl-rare-priv ((,c :foreground ,accent-3)))
+ `(diredfl-read-priv ((,c :foreground ,fg-main)))
+ `(diredfl-symlink ((,c :inherit dired-symlink)))
+ `(diredfl-tagged-autofile-name ((,c :inherit (diredfl-autofile-name dired-marked))))
+ `(diredfl-write-priv ((,c :foreground ,accent-0)))
+;;;;; disk-usage
+ `(disk-usage-inaccessible ((,c :inherit error)))
+ `(disk-usage-percent ((,c :foreground ,accent-0)))
+ `(disk-usage-size ((,c :foreground ,accent-1)))
+ `(disk-usage-symlink ((,c :inherit dired-symlink)))
+ `(disk-usage-symlink-directory ((,c :inherit dired-symlink)))
;;;;; display-fill-column-indicator-mode
- `(fill-column-indicator ((,class :height 1 :background ,bg-region :foreground ,bg-region)))
+ `(fill-column-indicator ((,c :height 1 :background ,bg-active :foreground ,bg-active)))
;;;;; doom-modeline
- `(doom-modeline-bar ((,class :inherit modus-themes-active-blue)))
- `(doom-modeline-bar-inactive ((,class :background ,fg-inactive :foreground ,bg-main)))
- `(doom-modeline-battery-charging ((,class :foreground ,green-active)))
- `(doom-modeline-battery-critical ((,class :inherit bold :foreground ,red-active)))
- `(doom-modeline-battery-error ((,class :inherit bold :box (:line-width -2)
- :foreground ,red-active)))
- `(doom-modeline-battery-full ((,class :foreground ,blue-active)))
- `(doom-modeline-battery-normal ((,class :foreground ,fg-active)))
- `(doom-modeline-battery-warning ((,class :inherit bold :foreground ,yellow-active)))
- `(doom-modeline-buffer-file ((,class :inherit bold :foreground ,fg-active)))
- `(doom-modeline-buffer-major-mode ((,class :inherit bold :foreground ,cyan-active)))
- `(doom-modeline-buffer-minor-mode ((,class :foreground ,fg-inactive)))
- `(doom-modeline-buffer-modified ((,class :inherit bold :foreground ,magenta-active)))
- `(doom-modeline-buffer-path ((,class :inherit bold :foreground ,fg-active)))
- `(doom-modeline-debug ((,class :inherit bold :foreground ,yellow-active)))
- `(doom-modeline-debug-visual ((,class :inherit bold :foreground ,red-active)))
- `(doom-modeline-evil-emacs-state ((,class :inherit bold :foreground ,magenta-active)))
- `(doom-modeline-evil-insert-state ((,class :inherit bold :foreground ,green-active)))
- `(doom-modeline-evil-motion-state ((,class :inherit bold :foreground ,fg-inactive)))
- `(doom-modeline-evil-normal-state ((,class :inherit bold :foreground ,fg-active)))
- `(doom-modeline-evil-operator-state ((,class :inherit bold :foreground ,blue-active)))
- `(doom-modeline-evil-replace-state ((,class :inherit bold :foreground ,red-active)))
- `(doom-modeline-evil-visual-state ((,class :inherit bold :foreground ,cyan-active)))
- `(doom-modeline-highlight ((,class :inherit bold :foreground ,blue-active)))
- `(doom-modeline-host ((,class :inherit italic)))
- `(doom-modeline-info ((,class :foreground ,green-active)))
- `(doom-modeline-lsp-error ((,class :inherit bold :foreground ,red-active)))
- `(doom-modeline-lsp-success ((,class :inherit (bold modus-themes-grue-active))))
- `(doom-modeline-lsp-warning ((,class :inherit bold :foreground ,yellow-active)))
- `(doom-modeline-panel ((,class :inherit modus-themes-active-blue)))
- `(doom-modeline-persp-buffer-not-in-persp ((,class :inherit italic :foreground ,yellow-active)))
- `(doom-modeline-persp-name ((,class :foreground ,fg-active)))
- `(doom-modeline-project-dir ((,class :inherit bold :foreground ,blue-active)))
- `(doom-modeline-project-parent-dir ((,class :foreground ,blue-active)))
- `(doom-modeline-project-root-dir ((,class :foreground ,fg-active)))
- `(doom-modeline-unread-number ((,class :inherit italic :foreground ,fg-active)))
- `(doom-modeline-urgent ((,class :inherit bold :foreground ,red-active)))
- `(doom-modeline-warning ((,class :inherit bold :foreground ,yellow-active)))
-;;;;; easy-jekyll
- `(easy-jekyll-help-face ((,class :background ,bg-dim :foreground ,blue-alt-other)))
-;;;;; ebdb
- `(ebdb-address-default ((,class :foreground ,fg-special-calm)))
- `(ebdb-defunct ((,class :inherit shadow)))
- `(ebdb-field-hidden ((,class :foreground ,magenta)))
- `(ebdb-label ((,class :foreground ,cyan-alt-other)))
- `(ebdb-mail-default ((,class :foreground ,fg-main)))
- `(ebdb-mail-primary ((,class :foreground ,magenta-alt)))
- `(ebdb-marked ((,class :background ,cyan-intense-bg)))
- `(ebdb-organization-name ((,class :foreground ,red-alt-other)))
- `(ebdb-person-name ((,class :foreground ,magenta-alt-other)))
- `(ebdb-phone-default ((,class :foreground ,cyan)))
- `(eieio-custom-slot-tag-face ((,class :foreground ,red-alt)))
+ `(doom-modeline-bar ((,c :background ,blue)))
+ `(doom-modeline-bar-inactive ((,c :background ,border)))
+ `(doom-modeline-battery-charging ((,c :foreground ,modeline-info)))
+ `(doom-modeline-battery-critical ((,c :underline t :foreground ,modeline-err)))
+ `(doom-modeline-battery-error ((,c :underline t :foreground ,modeline-err)))
+ `(doom-modeline-battery-full (( )))
+ `(doom-modeline-battery-warning ((,c :inherit warning)))
+ `(doom-modeline-buffer-file ((,c :inherit bold)))
+ `(doom-modeline-buffer-major-mode (( )))
+ `(doom-modeline-buffer-minor-mode (( )))
+ `(doom-modeline-buffer-modified ((,c :foreground ,modeline-err)))
+ `(doom-modeline-buffer-path (( )))
+ `(doom-modeline-evil-emacs-state ((,c :inherit italic)))
+ `(doom-modeline-evil-insert-state ((,c :foreground ,modeline-info)))
+ `(doom-modeline-evil-motion-state (( )))
+ `(doom-modeline-evil-normal-state (( )))
+ `(doom-modeline-evil-operator-state ((,c :inherit bold)))
+ `(doom-modeline-evil-replace-state ((,c :inherit error)))
+ `(doom-modeline-evil-visual-state ((,c :inherit warning)))
+ `(doom-modeline-info ((,c :inherit success)))
+ `(doom-modeline-input-method (( )))
+ `(doom-modeline-lsp-error ((,c :inherit bold-italic)))
+ `(doom-modeline-lsp-running (( )))
+ `(doom-modeline-lsp-success ((,c :inherit success)))
+ `(doom-modeline-lsp-warning ((,c :inherit warning)))
+ `(doom-modeline-notification ((,c :inherit error)))
+ `(doom-modeline-project-dir (( )))
+ `(doom-modeline-project-parent-dir (( )))
+ `(doom-modeline-project-root-dir (( )))
+ `(doom-modeline-repl-success ((,c :inherit success)))
+ `(doom-modeline-repl-warning ((,c :inherit warning)))
+ `(doom-modeline-time (( )))
+ `(doom-modeline-urgent ((,c :inherit bold-italic :foreground ,modeline-err)))
+ `(doom-modeline-warning ((,c :inherit warning)))
;;;;; ediff
- `(ediff-current-diff-A ((,class :inherit modus-themes-diff-removed)))
- `(ediff-current-diff-Ancestor ((,class ,@(modus-themes--diff
- bg-special-cold fg-special-cold
- blue-nuanced-bg blue))))
- `(ediff-current-diff-B ((,class :inherit modus-themes-diff-added)))
- `(ediff-current-diff-C ((,class :inherit modus-themes-diff-changed)))
- `(ediff-even-diff-A ((,class :background ,bg-alt)))
- `(ediff-even-diff-Ancestor ((,class :background ,bg-alt)))
- `(ediff-even-diff-B ((,class :background ,bg-alt)))
- `(ediff-even-diff-C ((,class :background ,bg-alt)))
- `(ediff-fine-diff-A ((,class :inherit modus-themes-diff-refine-removed)))
- `(ediff-fine-diff-Ancestor ((,class :inherit modus-themes-refine-cyan)))
- `(ediff-fine-diff-B ((,class :inherit modus-themes-diff-refine-added)))
- `(ediff-fine-diff-C ((,class :inherit modus-themes-diff-refine-changed)))
- `(ediff-odd-diff-A ((,class :inherit ediff-even-diff-A)))
- `(ediff-odd-diff-Ancestor ((,class :inherit ediff-even-diff-Ancestor)))
- `(ediff-odd-diff-B ((,class :inherit ediff-even-diff-B)))
- `(ediff-odd-diff-C ((,class :inherit ediff-even-diff-C)))
+ `(ediff-current-diff-A ((,c :background ,bg-removed :foreground ,fg-removed)))
+ `(ediff-current-diff-Ancestor ((,c :background ,bg-region)))
+ `(ediff-current-diff-B ((,c :background ,bg-added :foreground ,fg-added)))
+ `(ediff-current-diff-C ((,c :background ,bg-changed :foreground ,fg-changed)))
+ `(ediff-even-diff-A ((,c :background ,bg-diff-context)))
+ `(ediff-even-diff-Ancestor ((,c :background ,bg-diff-context)))
+ `(ediff-even-diff-B ((,c :background ,bg-diff-context)))
+ `(ediff-even-diff-C ((,c :background ,bg-diff-context)))
+ `(ediff-fine-diff-A ((,c :background ,bg-removed-refine :foreground ,fg-removed)))
+ `(ediff-fine-diff-Ancestor ((,c :inherit modus-themes-subtle-cyan)))
+ `(ediff-fine-diff-B ((,c :background ,bg-added-refine :foreground ,fg-added)))
+ `(ediff-fine-diff-C ((,c :background ,bg-changed-refine :foreground ,fg-changed)))
+ `(ediff-odd-diff-A ((,c :inherit ediff-even-diff-A)))
+ `(ediff-odd-diff-Ancestor ((,c :inherit ediff-even-diff-Ancestor)))
+ `(ediff-odd-diff-B ((,c :inherit ediff-even-diff-B)))
+ `(ediff-odd-diff-C ((,c :inherit ediff-even-diff-C)))
;;;;; ein (Emacs IPython Notebook)
- `(ein:basecell-input-area-face ((,class :background ,bg-dim :extend t)))
+ `(ein:basecell-input-area-face ((,c :background ,bg-dim :extend t)))
`(ein:cell-output-area (( )))
- `(ein:cell-output-area-error ((,class :background ,red-nuanced-bg :extend t)))
- `(ein:cell-output-stderr ((,class :background ,red-nuanced-bg :extend t)))
+ `(ein:cell-output-area-error ((,c :background ,bg-removed :extend t)))
+ `(ein:cell-output-stderr ((,c :background ,bg-removed :extend t)))
`(ein:markdowncell-input-area-face (( )))
- `(ein:notification-tab-normal ((,class :underline t)))
+ `(ein:notification-tab-normal ((,c :underline t)))
;;;;; eglot
- `(eglot-mode-line ((,class :inherit modus-themes-bold :foreground ,magenta-active)))
+ `(eglot-mode-line ((,c :inherit modus-themes-bold :foreground ,modeline-info)))
+ `(eglot-diagnostic-tag-unnecessary-face ((,c :inherit modus-themes-lang-note)))
;;;;; el-search
- `(el-search-highlight-in-prompt-face ((,class :inherit bold :foreground ,magenta-alt)))
- `(el-search-match ((,class :inherit modus-themes-search-success)))
- `(el-search-other-match ((,class :inherit modus-themes-special-mild)))
- `(el-search-occur-match ((,class :inherit modus-themes-special-calm)))
+ `(el-search-highlight-in-prompt-face ((,c :inherit italic)))
+ `(el-search-match ((,c :inherit modus-themes-search-current)))
+ `(el-search-other-match ((,c :inherit modus-themes-search-lazy)))
+ `(el-search-occur-match ((,c :inherit match)))
;;;;; eldoc
;; NOTE: see https://github.com/purcell/package-lint/issues/187
- (list 'eldoc-highlight-function-argument `((,class :inherit bold
- :background ,yellow-nuanced-bg
- :foreground ,yellow-alt-other)))
+ (list 'eldoc-highlight-function-argument `((,c :inherit bold :background ,bg-active-argument :foreground ,fg-active-argument)))
;;;;; eldoc-box
- `(eldoc-box-body ((,class :background ,bg-alt :foreground ,fg-main)))
- `(eldoc-box-border ((,class :background ,fg-alt)))
+ `(eldoc-box-body ((,c :background ,bg-dim :foreground ,fg-main)))
+ `(eldoc-box-border ((,c :background ,border)))
;;;;; elfeed
- `(elfeed-log-date-face ((,class :inherit elfeed-search-date-face)))
- `(elfeed-log-debug-level-face ((,class :inherit elfeed-search-filter-face)))
- `(elfeed-log-error-level-face ((,class :inherit error)))
- `(elfeed-log-info-level-face ((,class :inherit success)))
- `(elfeed-log-warn-level-face ((,class :inherit warning)))
- `(elfeed-search-date-face ((,class :foreground ,cyan)))
- `(elfeed-search-feed-face ((,class :foreground ,blue-faint)))
- `(elfeed-search-filter-face ((,class :inherit bold :foreground ,magenta-active)))
- `(elfeed-search-last-update-face ((,class :inherit bold :foreground ,cyan-active)))
- `(elfeed-search-tag-face ((,class :foreground ,magenta-alt-faint)))
- `(elfeed-search-title-face ((,class :foreground ,fg-dim)))
- `(elfeed-search-unread-count-face ((,class :inherit bold :foreground ,fg-active)))
- `(elfeed-search-unread-title-face ((,class :inherit bold :foreground ,fg-main)))
+ `(elfeed-log-date-face ((,c :inherit elfeed-search-date-face)))
+ `(elfeed-log-debug-level-face ((,c :inherit elfeed-search-filter-face)))
+ `(elfeed-log-error-level-face ((,c :inherit error)))
+ `(elfeed-log-info-level-face ((,c :inherit success)))
+ `(elfeed-log-warn-level-face ((,c :inherit warning)))
+ `(elfeed-search-date-face ((,c :foreground ,date-common)))
+ `(elfeed-search-feed-face ((,c :foreground ,accent-1)))
+ `(elfeed-search-filter-face ((,c :inherit bold)))
+ `(elfeed-search-last-update-face ((,c :inherit bold :foreground ,date-common)))
+ `(elfeed-search-tag-face ((,c :foreground ,accent-0)))
+ `(elfeed-search-title-face ((,c :foreground ,fg-dim)))
+ `(elfeed-search-unread-count-face (( )))
+ `(elfeed-search-unread-title-face ((,c :inherit bold :foreground ,fg-main)))
;;;;; elfeed-score
- `(elfeed-score-date-face ((,class :foreground ,blue)))
- `(elfeed-score-debug-level-face ((,class :foreground ,magenta-alt-other)))
- `(elfeed-score-error-level-face ((,class :foreground ,red)))
- `(elfeed-score-info-level-face ((,class :foreground ,cyan)))
- `(elfeed-score-warn-level-face ((,class :foreground ,yellow)))
+ `(elfeed-score-date-face ((,c :foreground ,date-common)))
+ `(elfeed-score-debug-level-face ((,c :inherit bold)))
+ `(elfeed-score-error-level-face ((,c :inherit error)))
+ `(elfeed-score-info-level-face ((,c :inherit success)))
+ `(elfeed-score-warn-level-face ((,c :inherit warning)))
;;;;; elpher
- `(elpher-gemini-heading1 ((,class :inherit modus-themes-heading-1)))
- `(elpher-gemini-heading2 ((,class :inherit modus-themes-heading-2)))
- `(elpher-gemini-heading3 ((,class :inherit modus-themes-heading-3)))
+ `(elpher-gemini-heading1 ((,c :inherit modus-themes-heading-1)))
+ `(elpher-gemini-heading2 ((,c :inherit modus-themes-heading-2)))
+ `(elpher-gemini-heading3 ((,c :inherit modus-themes-heading-3)))
;;;;; embark
- `(embark-keybinding ((,class :inherit modus-themes-key-binding)))
- `(embark-collect-marked ((,class :inherit modus-themes-mark-sel)))
+ `(embark-keybinding ((,c :inherit modus-themes-key-binding)))
+ `(embark-collect-marked ((,c :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 ((,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)))
- `(ement-room-self ((,class :inherit bold :foreground ,magenta)))
- `(ement-room-self-message ((,class :foreground ,magenta-faint)))
- `(ement-room-timestamp ((,class :inherit shadow)))
- `(ement-room-timestamp-header ((,class :inherit bold :foreground ,cyan)))
- `(ement-room-user ((,class :inherit bold :foreground ,blue)))
+ `(ement-room-fully-read-marker ((,c :inherit success)))
+ `(ement-room-membership ((,c :inherit shadow)))
+ `(ement-room-mention ((,c :inherit highlight)))
+ `(ement-room-name ((,c :inherit bold)))
+ `(ement-room-reactions ((,c :inherit shadow)))
+ `(ement-room-read-receipt-marker ((,c :inherit match)))
+ `(ement-room-self ((,c :inherit bold :foreground ,accent-1)))
+ `(ement-room-self-message ((,c :foreground ,fg-alt)))
+ `(ement-room-timestamp ((,c :inherit shadow)))
+ `(ement-room-timestamp-header ((,c :inherit bold :foreground ,date-common)))
+ `(ement-room-user ((,c :inherit bold :foreground ,accent-0)))
;;;;; emms
- `(emms-browser-album-face ((,class :foreground ,magenta-alt-other)))
- `(emms-browser-artist-face ((,class :foreground ,cyan)))
- `(emms-browser-composer-face ((,class :foreground ,magenta-alt)))
- `(emms-browser-performer-face ((,class :inherit emms-browser-artist-face)))
- `(emms-browser-track-face ((,class :inherit emms-playlist-track-face)))
- `(emms-browser-year/genre-face ((,class :foreground ,cyan-alt-other)))
- `(emms-playlist-track-face ((,class :foreground ,blue-alt)))
- `(emms-playlist-selected-face ((,class :inherit bold :foreground ,blue-alt-other)))
- `(emms-metaplaylist-mode-current-face ((,class :inherit emms-playlist-selected-face)))
- `(emms-metaplaylist-mode-face ((,class :foreground ,cyan)))
+ `(emms-browser-album-face ((,c :foreground ,keyword)))
+ `(emms-browser-artist-face ((,c :foreground ,variable)))
+ `(emms-browser-composer-face ((,c :foreground ,builtin)))
+ `(emms-browser-performer-face ((,c :inherit emms-browser-artist-face)))
+ `(emms-browser-track-face ((,c :inherit emms-playlist-track-face)))
+ `(emms-browser-year/genre-face ((,c :foreground ,type)))
+ `(emms-playlist-track-face ((,c :foreground ,string)))
+ `(emms-playlist-selected-face ((,c :inherit bold :foreground ,constant)))
+ `(emms-metaplaylist-mode-current-face ((,c :inherit emms-playlist-selected-face)))
+ `(emms-metaplaylist-mode-face ((,c :foreground ,variable)))
;;;;; enh-ruby-mode (enhanced-ruby-mode)
- `(enh-ruby-heredoc-delimiter-face ((,class :inherit font-lock-constant-face)))
- `(enh-ruby-op-face ((,class :foreground ,fg-main)))
- `(enh-ruby-regexp-delimiter-face ((,class :inherit font-lock-regexp-grouping-construct)))
- `(enh-ruby-regexp-face ((,class :inherit font-lock-string-face)))
- `(enh-ruby-string-delimiter-face ((,class :inherit font-lock-string-face)))
- `(erm-syn-errline ((,class :inherit modus-themes-lang-error)))
- `(erm-syn-warnline ((,class :inherit modus-themes-lang-warning)))
+ `(enh-ruby-heredoc-delimiter-face ((,c :inherit font-lock-constant-face)))
+ `(enh-ruby-op-face ((,c :foreground ,fg-main)))
+ `(enh-ruby-regexp-delimiter-face ((,c :inherit font-lock-regexp-grouping-construct)))
+ `(enh-ruby-regexp-face ((,c :inherit font-lock-string-face)))
+ `(enh-ruby-string-delimiter-face ((,c :inherit font-lock-string-face)))
+ `(erm-syn-errline ((,c :inherit modus-themes-lang-error)))
+ `(erm-syn-warnline ((,c :inherit modus-themes-lang-warning)))
;;;;; epa
- `(epa-field-body ((,class :foreground ,fg-main)))
- `(epa-field-name ((,class :inherit bold :foreground ,fg-dim)))
- `(epa-mark ((,class :inherit bold :foreground ,magenta)))
- `(epa-string ((,class :foreground ,blue-alt)))
- `(epa-validity-disabled ((,class :foreground ,red)))
- `(epa-validity-high ((,class :inherit bold :foreground ,cyan)))
- `(epa-validity-low ((,class :inherit shadow)))
- `(epa-validity-medium ((,class :foreground ,green-alt)))
-;;;;; equake
- `(equake-buffer-face ((,class :background ,bg-main :foreground ,fg-main)))
- `(equake-shell-type-eshell ((,class :background ,bg-inactive :foreground ,blue-active)))
- `(equake-shell-type-rash ((,class :background ,bg-inactive :foreground ,red-active)))
- `(equake-shell-type-shell ((,class :background ,bg-inactive :foreground ,cyan-active)))
- `(equake-shell-type-term ((,class :background ,bg-inactive :foreground ,yellow-active)))
- `(equake-shell-type-vterm ((,class :background ,bg-inactive :foreground ,magenta-active)))
- `(equake-tab-active ((,class :background ,fg-alt :foreground ,bg-alt)))
- `(equake-tab-inactive ((,class :foreground ,fg-inactive)))
+ `(epa-field-body (( )))
+ `(epa-field-name ((,c :inherit bold :foreground ,fg-dim)))
+ `(epa-mark ((,c :inherit bold)))
+ `(epa-string ((,c :foreground ,string)))
+ `(epa-validity-disabled ((,c :foreground ,err)))
+ `(epa-validity-high ((,c :inherit success)))
+ `(epa-validity-low ((,c :inherit shadow)))
+ `(epa-validity-medium ((,c :foreground ,info)))
;;;;; erc
- `(erc-action-face ((,class :foreground ,cyan-alt-other)))
- `(erc-bold-face ((,class :inherit bold)))
- `(erc-button ((,class :inherit button)))
- `(erc-command-indicator-face ((,class :inherit bold :foreground ,cyan-alt)))
- `(erc-current-nick-face ((,class :inherit bold :foreground ,red-alt)))
- `(erc-dangerous-host-face ((,class :inherit modus-themes-intense-red)))
- `(erc-direct-msg-face ((,class :foreground ,fg-special-warm)))
- `(erc-error-face ((,class :inherit bold :foreground ,red)))
- `(erc-fool-face ((,class :inherit shadow)))
- `(erc-header-line ((,class :background ,bg-header :foreground ,fg-header)))
- `(erc-input-face ((,class :foreground ,magenta)))
- `(erc-inverse-face ((,class :inherit erc-default-face :inverse-video t)))
- `(erc-keyword-face ((,class :inherit bold :foreground ,magenta-alt-other)))
- `(erc-my-nick-face ((,class :inherit bold :foreground ,magenta)))
- `(erc-my-nick-prefix-face ((,class :inherit erc-my-nick-face)))
- `(erc-nick-default-face ((,class :inherit bold :foreground ,blue)))
- `(erc-nick-msg-face ((,class :inherit warning)))
- `(erc-nick-prefix-face ((,class :inherit erc-nick-default-face)))
- `(erc-notice-face ((,class :inherit font-lock-comment-face)))
- `(erc-pal-face ((,class :inherit bold :foreground ,magenta-alt)))
- `(erc-prompt-face ((,class :inherit modus-themes-prompt)))
- `(erc-timestamp-face ((,class :foreground ,cyan)))
- `(erc-underline-face ((,class :underline t)))
- `(bg:erc-color-face0 ((,class :background "white")))
- `(bg:erc-color-face1 ((,class :background "black")))
- `(bg:erc-color-face10 ((,class :background ,cyan-subtle-bg)))
- `(bg:erc-color-face11 ((,class :background ,cyan-intense-bg)))
- `(bg:erc-color-face12 ((,class :background ,blue-subtle-bg)))
- `(bg:erc-color-face13 ((,class :background ,magenta-subtle-bg)))
- `(bg:erc-color-face14 ((,class :background "gray60")))
- `(bg:erc-color-face15 ((,class :background "gray80")))
- `(bg:erc-color-face2 ((,class :background ,blue-intense-bg)))
- `(bg:erc-color-face3 ((,class :background ,green-intense-bg)))
- `(bg:erc-color-face4 ((,class :background ,red-subtle-bg)))
- `(bg:erc-color-face5 ((,class :background ,red-intense-bg)))
- `(bg:erc-color-face6 ((,class :background ,magenta-refine-bg)))
- `(bg:erc-color-face7 ((,class :background ,yellow-subtle-bg)))
- `(bg:erc-color-face8 ((,class :background ,yellow-refine-bg)))
- `(bg:erc-color-face9 ((,class :background ,green-subtle-bg)))
- `(fg:erc-color-face0 ((,class :foreground "white")))
- `(fg:erc-color-face1 ((,class :foreground "black")))
- `(fg:erc-color-face10 ((,class :foreground ,cyan)))
- `(fg:erc-color-face11 ((,class :foreground ,cyan-alt-other)))
- `(fg:erc-color-face12 ((,class :foreground ,blue)))
- `(fg:erc-color-face13 ((,class :foreground ,magenta-alt)))
- `(fg:erc-color-face14 ((,class :foreground "gray60")))
- `(fg:erc-color-face15 ((,class :foreground "gray80")))
- `(fg:erc-color-face2 ((,class :foreground ,blue-alt-other)))
- `(fg:erc-color-face3 ((,class :foreground ,green)))
- `(fg:erc-color-face4 ((,class :foreground ,red)))
- `(fg:erc-color-face5 ((,class :foreground ,red-alt)))
- `(fg:erc-color-face6 ((,class :foreground ,magenta-alt-other)))
- `(fg:erc-color-face7 ((,class :foreground ,yellow-alt-other)))
- `(fg:erc-color-face8 ((,class :foreground ,yellow-alt)))
- `(fg:erc-color-face9 ((,class :foreground ,green-alt-other)))
-;;;;; eros
- `(eros-result-overlay-face ((,class :box (:line-width -1 :color ,blue)
- :background ,bg-dim :foreground ,fg-dim)))
+ `(erc-action-face ((,c :foreground ,accent-2)))
+ `(erc-bold-face ((,c :inherit bold)))
+ `(erc-button ((,c :inherit button)))
+ `(erc-command-indicator-face ((,c :inherit bold :foreground ,accent-3)))
+ `(erc-current-nick-face ((,c :inherit match)))
+ `(erc-dangerous-host-face ((,c :inherit error)))
+ `(erc-direct-msg-face ((,c :inherit shadow)))
+ `(erc-error-face ((,c :inherit error)))
+ `(erc-fill-wrap-merge-indicator-face ((,c :foreground ,fg-dim)))
+ `(erc-fool-face ((,c :inherit shadow)))
+ `(erc-input-face ((,c :foreground ,fnname)))
+ `(erc-inverse-face ((,c :inherit erc-default-face :inverse-video t)))
+ `(erc-keep-place-indicator-arrow ((,c :foreground ,info)))
+ `(erc-keyword-face ((,c :inherit bold :foreground ,keyword)))
+ `(erc-my-nick-face ((,c :inherit bold :foreground ,name)))
+ `(erc-my-nick-prefix-face ((,c :inherit erc-my-nick-face)))
+ `(erc-nick-default-face ((,c :inherit bold :foreground ,accent-0)))
+ `(erc-nick-msg-face ((,c :inherit warning)))
+ `(erc-nick-prefix-face ((,c :inherit erc-nick-default-face)))
+ `(erc-notice-face ((,c :inherit font-lock-comment-face)))
+ `(erc-pal-face ((,c :inherit bold :foreground ,accent-1)))
+ `(erc-prompt-face ((,c :inherit modus-themes-prompt)))
+ `(erc-timestamp-face ((,c :foreground ,date-common)))
+ `(erc-underline-face ((,c :underline t)))
;;;;; ert
- `(ert-test-result-expected ((,class :inherit modus-themes-intense-green)))
- `(ert-test-result-unexpected ((,class :inherit modus-themes-intense-red)))
+ `(ert-test-result-expected ((,c :inherit modus-themes-prominent-note)))
+ `(ert-test-result-unexpected ((,c :inherit modus-themes-prominent-error)))
+;;;;; erts-mode
+ `(erts-mode-end-test ((,c :inherit error)))
+ `(erts-mode-specification-name ((,c :inherit bold)))
+ `(erts-mode-specification-value ((,c :foreground ,string)))
+ `(erts-mode-start-test ((,c :inherit success)))
;;;;; eshell
- `(eshell-ls-archive ((,class :foreground ,cyan-alt)))
- `(eshell-ls-backup ((,class :inherit shadow)))
- `(eshell-ls-clutter ((,class :foreground ,red-alt)))
- `(eshell-ls-directory ((,class :foreground ,blue-alt)))
- `(eshell-ls-executable ((,class :foreground ,magenta-alt)))
- `(eshell-ls-missing ((,class :inherit modus-themes-intense-red)))
- `(eshell-ls-product ((,class :inherit shadow)))
- `(eshell-ls-readonly ((,class :foreground ,yellow-faint)))
- `(eshell-ls-special ((,class :foreground ,magenta)))
- `(eshell-ls-symlink ((,class :inherit modus-themes-link-symlink)))
- `(eshell-ls-unreadable ((,class :background ,bg-inactive :foreground ,fg-inactive)))
- `(eshell-prompt ((,class :inherit modus-themes-prompt)))
+ `(eshell-ls-archive ((,c :foreground ,accent-2)))
+ `(eshell-ls-backup ((,c :inherit shadow)))
+ `(eshell-ls-clutter ((,c :inherit shadow)))
+ `(eshell-ls-directory ((,c :foreground ,accent-0)))
+ `(eshell-ls-executable ((,c :foreground ,accent-1)))
+ `(eshell-ls-missing ((,c :inherit error)))
+ `(eshell-ls-product ((,c :inherit shadow)))
+ `(eshell-ls-readonly ((,c :foreground ,warning)))
+ `(eshell-ls-special ((,c :foreground ,accent-3)))
+ `(eshell-ls-symlink ((,c :inherit link)))
+ `(eshell-ls-unreadable ((,c :inherit shadow)))
+ `(eshell-prompt ((,c :inherit modus-themes-prompt)))
;;;;; eshell-fringe-status
- `(eshell-fringe-status-failure ((,class :inherit error)))
- `(eshell-fringe-status-success ((,class :inherit success)))
-;;;;; eshell-git-prompt
- `(eshell-git-prompt-add-face ((,class :foreground ,magenta-alt-other)))
- `(eshell-git-prompt-branch-face ((,class :foreground ,magenta-alt)))
- `(eshell-git-prompt-directory-face ((,class :inherit bold :foreground ,blue)))
- `(eshell-git-prompt-exit-fail-face ((,class :inherit error)))
- `(eshell-git-prompt-exit-success-face ((,class :inherit success)))
- `(eshell-git-prompt-modified-face ((,class :foreground ,yellow)))
- `(eshell-git-prompt-powerline-clean-face ((,class :background ,green-refine-bg)))
- `(eshell-git-prompt-powerline-dir-face ((,class :background ,blue-refine-bg)))
- `(eshell-git-prompt-powerline-not-clean-face ((,class :background ,yellow-fringe-bg)))
- `(eshell-git-prompt-robyrussell-branch-face ((,class :foreground ,magenta-alt)))
- `(eshell-git-prompt-robyrussell-git-dirty-face ((,class :foreground ,yellow)))
- `(eshell-git-prompt-robyrussell-git-face ((,class :foreground ,magenta-alt-other)))
-;;;;; eshell-prompt-extras (epe)
- `(epe-dir-face ((,class :inherit bold :foreground ,blue)))
- `(epe-git-dir-face ((,class :foreground ,red-alt-other)))
- `(epe-git-face ((,class :foreground ,magenta-alt)))
- `(epe-pipeline-delimiter-face ((,class :inherit shadow)))
- `(epe-pipeline-host-face ((,class :foreground ,fg-main)))
- `(epe-pipeline-time-face ((,class :foreground ,fg-main)))
- `(epe-pipeline-user-face ((,class :foreground ,magenta-alt-other)))
- `(epe-remote-face ((,class :inherit (shadow modus-themes-slant))))
- `(epe-status-face ((,class :foreground ,magenta-alt-other)))
- `(epe-venv-face ((,class :inherit (shadow modus-themes-slant))))
-;;;;; eshell-syntax-highlighting
- `(eshell-syntax-highlighting-directory-face ((,class :inherit eshell-ls-directory)))
- `(eshell-syntax-highlighting-invalid-face ((,class :foreground ,red)))
- `(eshell-syntax-highlighting-shell-command-face ((,class :foreground ,fg-main)))
+ `(eshell-fringe-status-failure ((,c :inherit error)))
+ `(eshell-fringe-status-success ((,c :inherit success)))
;;;;; evil-mode
- `(evil-ex-commands ((,class :foreground ,magenta-alt-other)))
- `(evil-ex-info ((,class :foreground ,cyan-alt-other)))
- `(evil-ex-lazy-highlight ((,class :inherit modus-themes-search-success-lazy)))
- `(evil-ex-search ((,class :inherit modus-themes-search-success)))
- `(evil-ex-substitute-matches ((,class :inherit modus-themes-refine-yellow :underline t)))
- `(evil-ex-substitute-replacement ((,class :inherit modus-themes-search-success)))
-;;;;; evil-goggles
- `(evil-goggles-change-face ((,class :inherit modus-themes-refine-yellow)))
- `(evil-goggles-commentary-face ((,class :inherit (modus-themes-subtle-neutral modus-themes-slant))))
- `(evil-goggles-default-face ((,class :inherit modus-themes-subtle-neutral)))
- `(evil-goggles-delete-face ((,class :inherit modus-themes-refine-red)))
- `(evil-goggles-fill-and-move-face ((,class :inherit evil-goggles-default-face)))
- `(evil-goggles-indent-face ((,class :inherit evil-goggles-default-face)))
- `(evil-goggles-join-face ((,class :inherit modus-themes-subtle-green)))
- `(evil-goggles-nerd-commenter-face ((,class :inherit evil-goggles-commentary-face)))
- `(evil-goggles-paste-face ((,class :inherit modus-themes-subtle-cyan)))
- `(evil-goggles-record-macro-face ((,class :inherit modus-themes-special-cold)))
- `(evil-goggles-replace-with-register-face ((,class :inherit modus-themes-refine-magenta)))
- `(evil-goggles-set-marker-face ((,class :inherit modus-themes-intense-magenta)))
- `(evil-goggles-shift-face ((,class :inherit evil-goggles-default-face)))
- `(evil-goggles-surround-face ((,class :inherit evil-goggles-default-face)))
- `(evil-goggles-yank-face ((,class :inherit modus-themes-subtle-blue)))
-;;;;; evil-snipe
- `(evil-snipe-first-match-face ((,class :inherit (bold modus-themes-intense-blue))))
- `(evil-snipe-matches-face ((,class :inherit modus-themes-refine-magenta)))
-;;;;; evil-visual-mark-mode
- `(evil-visual-mark-face ((,class :inherit modus-themes-intense-magenta)))
+ `(evil-ex-commands ((,c :inherit font-lock-keyword-face)))
+ `(evil-ex-info ((,c :inherit font-lock-type-face)))
+ `(evil-ex-lazy-highlight ((,c :inherit modus-themes-search-lazy)))
+ `(evil-ex-search ((,c :inherit modus-themes-search-current)))
+ `(evil-ex-substitute-matches ((,c :inherit modus-themes-search-replace)))
+ `(evil-ex-substitute-replacement ((,c :inherit modus-themes-search-current)))
;;;;; eww
- `(eww-invalid-certificate ((,class :foreground ,red-faint)))
- `(eww-valid-certificate ((,class :foreground ,blue-faint)))
- `(eww-form-checkbox ((,class :inherit eww-form-text)))
- `(eww-form-file ((,class :inherit eww-form-submit)))
- `(eww-form-select ((,class :inherit eww-form-submit)))
- `(eww-form-submit ((,class :inherit modus-themes-box-button)))
- `(eww-form-text ((,class :inherit widget-field)))
- `(eww-form-textarea ((,class :inherit eww-form-text)))
+ `(eww-invalid-certificate ((,c :foreground ,err)))
+ `(eww-valid-certificate ((,c :foreground ,info)))
+ `(eww-form-checkbox ((,c :inherit eww-form-text)))
+ `(eww-form-file ((,c :inherit eww-form-submit)))
+ `(eww-form-select ((,c :inherit eww-form-submit)))
+ `(eww-form-submit ((,c :inherit modus-themes-button)))
+ `(eww-form-text ((,c :inherit widget-field)))
+ `(eww-form-textarea ((,c :inherit eww-form-text)))
;;;;; eyebrowse
- `(eyebrowse-mode-line-active ((,class :inherit bold :foreground ,blue-active)))
-;;;;; fancy-dabbrev
- `(fancy-dabbrev-menu-face ((,class :background ,bg-alt :foreground ,fg-alt)))
- `(fancy-dabbrev-preview-face ((,class :inherit shadow :underline t)))
- `(fancy-dabbrev-selection-face ((,class :inherit (modus-themes-intense-cyan bold))))
+ `(eyebrowse-mode-line-active ((,c :inherit mode-line-emphasis)))
;;;;; flycheck
- `(flycheck-error ((,class :inherit modus-themes-lang-error)))
- `(flycheck-error-list-checker-name ((,class :foreground ,magenta-active)))
- `(flycheck-error-list-column-number ((,class :foreground ,fg-special-cold)))
- `(flycheck-error-list-error ((,class :inherit modus-themes-bold :foreground ,red)))
- `(flycheck-error-list-filename ((,class :foreground ,blue)))
- `(flycheck-error-list-highlight ((,class :inherit modus-themes-hl-line)))
- `(flycheck-error-list-id ((,class :foreground ,magenta-alt-other)))
- `(flycheck-error-list-id-with-explainer ((,class :inherit flycheck-error-list-id :box t)))
- `(flycheck-error-list-info ((,class :foreground ,cyan)))
- `(flycheck-error-list-line-number ((,class :foreground ,fg-special-warm)))
- `(flycheck-error-list-warning ((,class :foreground ,yellow)))
- `(flycheck-fringe-error ((,class :inherit modus-themes-fringe-red)))
- `(flycheck-fringe-info ((,class :inherit modus-themes-fringe-cyan)))
- `(flycheck-fringe-warning ((,class :inherit modus-themes-fringe-yellow)))
- `(flycheck-info ((,class :inherit modus-themes-lang-note)))
- `(flycheck-verify-select-checker ((,class :box (:line-width 1 :color nil :style released-button))))
- `(flycheck-warning ((,class :inherit modus-themes-lang-warning)))
+ `(flycheck-error ((,c :inherit modus-themes-lang-error)))
+ `(flycheck-fringe-error ((,c :inherit modus-themes-prominent-error)))
+ `(flycheck-fringe-info ((,c :inherit modus-themes-prominent-note)))
+ `(flycheck-fringe-warning ((,c :inherit modus-themes-prominent-warning)))
+ `(flycheck-info ((,c :inherit modus-themes-lang-note)))
+ `(flycheck-warning ((,c :inherit modus-themes-lang-warning)))
;;;;; flycheck-color-mode-line
- `(flycheck-color-mode-line-error-face ((,class :inherit flycheck-fringe-error)))
- `(flycheck-color-mode-line-info-face ((,class :inherit flycheck-fringe-info)))
- `(flycheck-color-mode-line-running-face ((,class :inherit italic :foreground ,fg-inactive)))
- `(flycheck-color-mode-line-info-face ((,class :inherit flycheck-fringe-warning)))
+ `(flycheck-color-mode-line-error-face ((,c :inherit flycheck-fringe-error)))
+ `(flycheck-color-mode-line-info-face ((,c :inherit flycheck-fringe-info)))
+ `(flycheck-color-mode-line-running-face ((,c :inherit italic)))
+ `(flycheck-color-mode-line-info-face ((,c :inherit flycheck-fringe-warning)))
;;;;; flycheck-indicator
- `(flycheck-indicator-disabled ((,class :inherit modus-themes-slant :foreground ,fg-inactive)))
- `(flycheck-indicator-error ((,class :inherit modus-themes-bold :foreground ,red-active)))
- `(flycheck-indicator-info ((,class :inherit modus-themes-bold :foreground ,blue-active)))
- `(flycheck-indicator-running ((,class :inherit modus-themes-bold :foreground ,magenta-active)))
- `(flycheck-indicator-success ((,class :inherit (modus-themes-bold modus-themes-grue-active))))
- `(flycheck-indicator-warning ((,class :inherit modus-themes-bold :foreground ,yellow-active)))
-;;;;; flycheck-posframe
- `(flycheck-posframe-background-face ((,class :background ,bg-alt)))
- `(flycheck-posframe-border-face ((,class :inherit shadow)))
- `(flycheck-posframe-error-face ((,class :inherit bold :foreground ,red)))
- `(flycheck-posframe-face ((,class :inherit modus-themes-slant :foreground ,fg-main)))
- `(flycheck-posframe-info-face ((,class :inherit bold :foreground ,cyan)))
- `(flycheck-posframe-warning-face ((,class :inherit bold :foreground ,yellow)))
+ `(flycheck-indicator-disabled ((,c :inherit modus-themes-slant :foreground ,fg-dim)))
+ `(flycheck-indicator-error ((,c :inherit error)))
+ `(flycheck-indicator-info ((,c :inherit bold)))
+ `(flycheck-indicator-running ((,c :inherit modus-themes-slant)))
+ `(flycheck-indicator-success ((,c :inherit success)))
+ `(flycheck-indicator-warning ((,c :inherit warning)))
;;;;; flymake
- `(flymake-error ((,class :inherit modus-themes-lang-error)))
- `(flymake-note ((,class :inherit modus-themes-lang-note)))
- `(flymake-warning ((,class :inherit modus-themes-lang-warning)))
+ `(flymake-end-of-line-diagnostics-face ((,c :inherit modus-themes-slant :height 0.85 :box ,border)))
+ `(flymake-error ((,c :inherit modus-themes-lang-error)))
+ `(flymake-error-echo ((,c :inherit error)))
+ `(flymake-error-echo-at-eol ((,c :inherit flymake-end-of-line-diagnostics-face :foreground ,err)))
+ `(flymake-note ((,c :inherit modus-themes-lang-note)))
+ `(flymake-note-echo ((,c :inherit success)))
+ `(flymake-note-echo-at-eol ((,c :inherit flymake-end-of-line-diagnostics-face :foreground ,info)))
+ `(flymake-warning ((,c :inherit modus-themes-lang-warning)))
+ `(flymake-warning-echo ((,c :inherit warning)))
+ `(flymake-note-echo-at-eol ((,c :inherit flymake-end-of-line-diagnostics-face :foreground ,warning)))
;;;;; flyspell
- `(flyspell-duplicate ((,class :inherit modus-themes-lang-warning)))
- `(flyspell-incorrect ((,class :inherit modus-themes-lang-error)))
+ `(flyspell-duplicate ((,c :inherit modus-themes-lang-warning)))
+ `(flyspell-incorrect ((,c :inherit modus-themes-lang-error)))
;;;;; flx
- `(flx-highlight-face ((,class :inherit modus-themes-completion-match-0)))
-;;;;; freeze-it
- `(freeze-it-show ((,class :background ,bg-dim :foreground ,fg-special-warm)))
+ `(flx-highlight-face ((,c :inherit modus-themes-completion-match-0)))
;;;;; focus
- `(focus-unfocused ((,class :foreground ,fg-unfocused)))
+ `(focus-unfocused ((,c :foreground "gray50")))
;;;;; fold-this
- `(fold-this-overlay ((,class :inherit modus-themes-special-mild)))
+ `(fold-this-overlay ((,c :background ,bg-inactive)))
;;;;; font-lock
- `(font-lock-builtin-face ((,class :inherit modus-themes-bold
- ,@(modus-themes--syntax-extra
- magenta-alt magenta-alt-faint
- magenta magenta-faint))))
- `(font-lock-comment-delimiter-face ((,class :inherit font-lock-comment-face)))
- `(font-lock-comment-face ((,class :inherit modus-themes-slant
- ,@(modus-themes--syntax-comment
- fg-alt fg-comment-yellow yellow-alt-other-faint))))
- `(font-lock-constant-face ((,class ,@(modus-themes--syntax-extra
- blue-alt-other blue-alt-other-faint
- magenta-alt-other magenta-alt-other-faint))))
- `(font-lock-doc-face ((,class :inherit modus-themes-slant
- ,@(modus-themes--syntax-string
- fg-docstring fg-special-cold
- fg-special-mild fg-special-calm
- fg-special-mild magenta-nuanced-fg))))
- `(font-lock-function-name-face ((,class ,@(modus-themes--syntax-extra
- magenta magenta-faint
- magenta-alt magenta-alt-faint))))
- `(font-lock-keyword-face ((,class :inherit modus-themes-bold
- ,@(modus-themes--syntax-extra
- magenta-alt-other magenta-alt-other-faint
- cyan cyan-faint))))
- `(font-lock-negation-char-face ((,class :inherit modus-themes-bold
- ,@(modus-themes--syntax-foreground
- yellow yellow-faint))))
- `(font-lock-preprocessor-face ((,class ,@(modus-themes--syntax-extra
- red-alt-other red-alt-other-faint
- cyan-alt-other cyan-alt-faint))))
- `(font-lock-regexp-grouping-backslash ((,class :inherit modus-themes-bold
- ,@(modus-themes--syntax-string
- fg-escape-char-backslash yellow-alt-faint
- yellow-alt magenta-alt
- red-faint green-alt-other-faint))))
- `(font-lock-regexp-grouping-construct ((,class :inherit modus-themes-bold
- ,@(modus-themes--syntax-string
- fg-escape-char-construct red-alt-other-faint
- red-alt-other blue-alt-other
- blue-faint blue-alt-other-faint))))
- `(font-lock-string-face ((,class ,@(modus-themes--syntax-string
- blue-alt blue-alt-faint
- green-alt-other red-alt-other
- green-alt-faint red-alt-faint))))
- `(font-lock-type-face ((,class :inherit modus-themes-bold
- ,@(modus-themes--syntax-extra
- cyan-alt-other cyan-alt-faint
- magenta-alt-other magenta-alt-other-faint))))
- `(font-lock-variable-name-face ((,class ,@(modus-themes--syntax-extra
- cyan cyan-faint
- blue-alt blue-alt-faint))))
- `(font-lock-warning-face ((,class :inherit modus-themes-bold
- ,@(modus-themes--syntax-comment
- yellow red yellow-alt-faint red-faint))))
-;;;;; forge
- `(forge-post-author ((,class :inherit bold :foreground ,fg-main)))
- `(forge-post-date ((,class :foreground ,fg-special-cold)))
- `(forge-topic-closed ((,class :inherit shadow)))
- `(forge-topic-merged ((,class :inherit shadow)))
- `(forge-topic-open ((,class :foreground ,fg-special-mild)))
- `(forge-topic-unmerged ((,class :inherit modus-themes-slant :foreground ,magenta)))
- `(forge-topic-unread ((,class :inherit bold :foreground ,fg-main)))
-;;;;; fountain-mode
- `(fountain-character ((,class :foreground ,blue-alt-other)))
- `(fountain-comment ((,class :inherit font-lock-comment-face)))
- `(fountain-dialog ((,class :foreground ,blue-alt)))
- `(fountain-metadata-key ((,class :foreground ,green-alt-other)))
- `(fountain-metadata-value ((,class :foreground ,blue)))
- `(fountain-non-printing ((,class :inherit shadow)))
- `(fountain-note ((,class :inherit modus-themes-slant :foreground ,yellow)))
- `(fountain-page-break ((,class :inherit bold :foreground ,red-alt)))
- `(fountain-page-number ((,class :inherit bold :foreground ,red-alt-other)))
- `(fountain-paren ((,class :foreground ,cyan)))
- `(fountain-scene-heading ((,class :inherit bold :foreground ,blue-nuanced-fg)))
- `(fountain-section-heading ((,class :inherit modus-themes-heading-1)))
- `(fountain-section-heading-1 ((,class :inherit modus-themes-heading-1)))
- `(fountain-section-heading-2 ((,class :inherit modus-themes-heading-2)))
- `(fountain-section-heading-3 ((,class :inherit modus-themes-heading-3)))
- `(fountain-section-heading-4 ((,class :inherit modus-themes-heading-4)))
- `(fountain-section-heading-5 ((,class :inherit modus-themes-heading-5)))
- `(fountain-synopsis ((,class :foreground ,cyan-alt)))
- `(fountain-trans ((,class :foreground ,yellow-alt-other)))
+ `(font-lock-builtin-face ((,c :inherit modus-themes-bold :foreground ,builtin)))
+ `(font-lock-comment-delimiter-face ((,c :inherit font-lock-comment-face)))
+ `(font-lock-comment-face ((,c :inherit modus-themes-slant :foreground ,comment)))
+ `(font-lock-constant-face ((,c :foreground ,constant)))
+ `(font-lock-doc-face ((,c :inherit modus-themes-slant :foreground ,docstring)))
+ `(font-lock-doc-markup-face ((,c :inherit modus-themes-slant :foreground ,docmarkup)))
+ `(font-lock-function-name-face ((,c :foreground ,fnname)))
+ `(font-lock-keyword-face ((,c :inherit modus-themes-bold :foreground ,keyword)))
+ `(font-lock-negation-char-face ((,c :inherit error)))
+ `(font-lock-preprocessor-face ((,c :foreground ,preprocessor)))
+ `(font-lock-regexp-grouping-backslash ((,c :inherit modus-themes-bold :foreground ,rx-backslash)))
+ `(font-lock-regexp-grouping-construct ((,c :inherit modus-themes-bold :foreground ,rx-construct)))
+ `(font-lock-string-face ((,c :foreground ,string)))
+ `(font-lock-type-face ((,c :inherit modus-themes-bold :foreground ,type)))
+ `(font-lock-variable-name-face ((,c :foreground ,variable)))
+ `(font-lock-warning-face ((,c :inherit modus-themes-bold :foreground ,warning)))
;;;;; geiser
- `(geiser-font-lock-autodoc-current-arg ((,class :inherit bold
- :background ,yellow-nuanced-bg
- :foreground ,yellow-alt-other)))
- `(geiser-font-lock-autodoc-identifier ((,class :foreground ,cyan)))
- `(geiser-font-lock-doc-button ((,class :inherit button :foreground ,fg-docstring)))
- `(geiser-font-lock-doc-link ((,class :inherit button)))
- `(geiser-font-lock-error-link ((,class :inherit button :foreground ,red)))
- `(geiser-font-lock-image-button ((,class :inherit button :foreground ,green-alt)))
- `(geiser-font-lock-repl-input ((,class :inherit bold)))
- `(geiser-font-lock-repl-output ((,class :inherit font-lock-keyword-face)))
- `(geiser-font-lock-repl-prompt ((,class :inherit modus-themes-prompt)))
- `(geiser-font-lock-xref-header ((,class :inherit bold)))
- `(geiser-font-lock-xref-link ((,class :inherit button)))
+ `(geiser-font-lock-autodoc-current-arg ((,c :inherit bold :background ,bg-active-argument :foreground ,fg-active-argument)))
+ `(geiser-font-lock-autodoc-identifier ((,c :foreground ,docstring)))
+ `(geiser-font-lock-doc-button ((,c :inherit button)))
+ `(geiser-font-lock-doc-link ((,c :inherit button)))
+ `(geiser-font-lock-error-link ((,c :inherit button :foreground ,err)))
+ `(geiser-font-lock-image-button ((,c :inherit button :foreground ,info)))
+ `(geiser-font-lock-repl-input ((,c :inherit bold)))
+ `(geiser-font-lock-repl-output ((,c :inherit font-lock-keyword-face)))
+ `(geiser-font-lock-repl-prompt ((,c :inherit modus-themes-prompt)))
+ `(geiser-font-lock-xref-header ((,c :inherit bold)))
+ `(geiser-font-lock-xref-link ((,c :inherit button)))
;;;;; git-commit
- `(git-commit-comment-action ((,class :inherit font-lock-comment-face)))
- `(git-commit-comment-branch-local ((,class :inherit font-lock-comment-face :foreground ,blue-alt)))
- `(git-commit-comment-branch-remote ((,class :inherit font-lock-comment-face :foreground ,magenta-alt)))
- `(git-commit-comment-detached ((,class :inherit font-lock-comment-face :foreground ,cyan-alt)))
- `(git-commit-comment-file ((,class :inherit font-lock-comment-face :foreground ,cyan)))
- `(git-commit-comment-heading ((,class :inherit (bold font-lock-comment-face))))
- `(git-commit-keyword ((,class :foreground ,magenta)))
- `(git-commit-known-pseudo-header ((,class :foreground ,cyan-alt-other)))
- `(git-commit-nonempty-second-line ((,class :inherit error)))
- `(git-commit-overlong-summary ((,class :inherit warning)))
- `(git-commit-pseudo-header ((,class :foreground ,blue)))
- `(git-commit-summary ((,class :inherit bold :foreground ,blue)))
+ `(git-commit-comment-action ((,c :inherit font-lock-comment-face)))
+ `(git-commit-comment-branch-local ((,c :inherit font-lock-comment-face :foreground ,accent-0)))
+ `(git-commit-comment-branch-remote ((,c :inherit font-lock-comment-face :foreground ,accent-1)))
+ `(git-commit-comment-heading ((,c :inherit (bold font-lock-comment-face))))
+ `(git-commit-comment-file ((,c :inherit font-lock-comment-face :foreground ,name)))
+ `(git-commit-keyword ((,c :foreground ,keyword)))
+ `(git-commit-nonempty-second-line ((,c :inherit error)))
+ `(git-commit-overlong-summary ((,c :inherit warning)))
+ `(git-commit-summary ((,c :inherit success)))
;;;;; git-gutter
- `(git-gutter:added ((,class :inherit modus-themes-grue-background-active)))
- `(git-gutter:deleted ((,class :inherit modus-themes-fringe-red)))
- `(git-gutter:modified ((,class :inherit modus-themes-fringe-yellow)))
- `(git-gutter:separator ((,class :inherit modus-themes-fringe-cyan)))
- `(git-gutter:unchanged ((,class :inherit modus-themes-fringe-magenta)))
+ `(git-gutter:added ((,c :background ,bg-added-fringe)))
+ `(git-gutter:deleted ((,c :background ,bg-removed-fringe)))
+ `(git-gutter:modified ((,c :background ,bg-changed-fringe)))
+ `(git-gutter:separator ((,c :inherit modus-themes-intense-cyan)))
+ `(git-gutter:unchanged ((,c :inherit modus-themes-intense-magenta)))
;;;;; git-gutter-fr
- `(git-gutter-fr:added ((,class :inherit modus-themes-grue-background-active)))
- `(git-gutter-fr:deleted ((,class :inherit modus-themes-fringe-red)))
- `(git-gutter-fr:modified ((,class :inherit modus-themes-fringe-yellow)))
+ `(git-gutter-fr:added ((,c :background ,bg-added-fringe)))
+ `(git-gutter-fr:deleted ((,c :background ,bg-removed-fringe)))
+ `(git-gutter-fr:modified ((,c :background ,bg-changed-fringe)))
;;;;; git-rebase
- `(git-rebase-comment-hash ((,class :inherit font-lock-comment-face :foreground ,cyan)))
- `(git-rebase-comment-heading ((,class :inherit (bold font-lock-comment-face))))
- `(git-rebase-description ((,class :foreground ,fg-main)))
- `(git-rebase-hash ((,class :foreground ,cyan-alt-other)))
+ `(git-rebase-comment-hash ((,c :inherit (bold font-lock-comment-face) :foreground ,identifier)))
+ `(git-rebase-comment-heading ((,c :inherit (bold font-lock-comment-face))))
+ `(git-rebase-description ((,c :foreground ,fg-main)))
+ `(git-rebase-hash ((,c :foreground ,identifier)))
;;;;; git-timemachine
- `(git-timemachine-commit ((,class :inherit bold :foreground ,yellow-active)))
- `(git-timemachine-minibuffer-author-face ((,class :foreground ,fg-special-warm)))
- `(git-timemachine-minibuffer-detail-face ((,class :foreground ,red-alt)))
+ `(git-timemachine-commit ((,c :inherit warning)))
+ `(git-timemachine-minibuffer-author-face ((,c :foreground ,name)))
+ `(git-timemachine-minibuffer-detail-face ((,c :foreground ,fg-main)))
;;;;; gnus
- `(gnus-button ((,class :inherit button)))
- `(gnus-cite-1 ((,class :inherit message-cited-text-1)))
- `(gnus-cite-2 ((,class :inherit message-cited-text-2)))
- `(gnus-cite-3 ((,class :inherit message-cited-text-3)))
- `(gnus-cite-4 ((,class :inherit message-cited-text-4)))
- `(gnus-cite-5 ((,class :inherit gnus-cite-1)))
- `(gnus-cite-6 ((,class :inherit gnus-cite-2)))
- `(gnus-cite-7 ((,class :inherit gnus-cite-3)))
- `(gnus-cite-8 ((,class :inherit gnus-cite-4)))
- `(gnus-cite-9 ((,class :inherit gnus-cite-1)))
- `(gnus-cite-10 ((,class :inherit gnus-cite-2)))
- `(gnus-cite-11 ((,class :inherit gnus-cite-3)))
- `(gnus-cite-attribution ((,class :inherit italic :foreground ,fg-main)))
- `(gnus-emphasis-bold ((,class :inherit bold)))
- `(gnus-emphasis-bold-italic ((,class :inherit bold-italic)))
- `(gnus-emphasis-highlight-words ((,class :inherit modus-themes-refine-yellow)))
- `(gnus-emphasis-italic ((,class :inherit italic)))
- `(gnus-emphasis-underline-bold ((,class :inherit gnus-emphasis-bold :underline t)))
- `(gnus-emphasis-underline-bold-italic ((,class :inherit gnus-emphasis-bold-italic :underline t)))
- `(gnus-emphasis-underline-italic ((,class :inherit gnus-emphasis-italic :underline t)))
- `(gnus-group-mail-1 ((,class :inherit bold :foreground ,magenta-alt)))
- `(gnus-group-mail-1-empty ((,class :foreground ,magenta-alt)))
- `(gnus-group-mail-2 ((,class :inherit bold :foreground ,magenta)))
- `(gnus-group-mail-2-empty ((,class :foreground ,magenta)))
- `(gnus-group-mail-3 ((,class :inherit bold :foreground ,magenta-alt-other)))
- `(gnus-group-mail-3-empty ((,class :foreground ,magenta-alt-other)))
- `(gnus-group-mail-low ((,class :inherit bold :foreground ,magenta-nuanced-fg)))
- `(gnus-group-mail-low-empty ((,class :foreground ,magenta-nuanced-fg)))
- `(gnus-group-news-1 ((,class :inherit bold :foreground ,green)))
- `(gnus-group-news-1-empty ((,class :foreground ,green)))
- `(gnus-group-news-2 ((,class :inherit bold :foreground ,cyan)))
- `(gnus-group-news-2-empty ((,class :foreground ,cyan)))
- `(gnus-group-news-3 ((,class :inherit bold :foreground ,yellow-nuanced-fg)))
- `(gnus-group-news-3-empty ((,class :foreground ,yellow-nuanced-fg)))
- `(gnus-group-news-4 ((,class :inherit bold :foreground ,cyan-nuanced-fg)))
- `(gnus-group-news-4-empty ((,class :foreground ,cyan-nuanced-fg)))
- `(gnus-group-news-5 ((,class :inherit bold :foreground ,red-nuanced-fg)))
- `(gnus-group-news-5-empty ((,class :foreground ,red-nuanced-fg)))
- `(gnus-group-news-6 ((,class :inherit bold :foreground ,fg-unfocused)))
- `(gnus-group-news-6-empty ((,class :foreground ,fg-unfocused)))
- `(gnus-group-news-low ((,class :inherit bold :foreground ,green-nuanced-fg)))
- `(gnus-group-news-low-empty ((,class :foreground ,green-nuanced-fg)))
- `(gnus-header-content ((,class :inherit message-header-other)))
- `(gnus-header-from ((,class :inherit message-header-to :underline nil)))
- `(gnus-header-name ((,class :inherit message-header-name)))
- `(gnus-header-newsgroups ((,class :inherit message-header-newsgroups)))
- `(gnus-header-subject ((,class :inherit message-header-subject)))
- `(gnus-server-agent ((,class :inherit bold :foreground ,cyan)))
- `(gnus-server-closed ((,class :inherit bold :foreground ,magenta)))
- `(gnus-server-cloud ((,class :inherit bold :foreground ,cyan-alt)))
- `(gnus-server-cloud-host ((,class :inherit modus-themes-refine-cyan)))
- `(gnus-server-denied ((,class :inherit bold :foreground ,red)))
- `(gnus-server-offline ((,class :inherit bold :foreground ,yellow)))
- `(gnus-server-opened ((,class :inherit bold :foreground ,green)))
- `(gnus-signature ((,class :inherit italic :foreground ,fg-special-cold)))
- `(gnus-splash ((,class :inherit shadow)))
- `(gnus-summary-cancelled ((,class :inherit modus-themes-mark-alt :extend t)))
- `(gnus-summary-high-ancient ((,class :inherit bold :foreground ,fg-alt)))
- `(gnus-summary-high-read ((,class :inherit bold :foreground ,fg-special-cold)))
- `(gnus-summary-high-ticked ((,class :inherit bold :foreground ,red-alt-other)))
- `(gnus-summary-high-undownloaded ((,class :inherit bold :foreground ,yellow)))
- `(gnus-summary-high-unread ((,class :inherit bold :foreground ,fg-main)))
- `(gnus-summary-low-ancient ((,class :inherit italic :foreground ,fg-alt)))
- `(gnus-summary-low-read ((,class :inherit italic :foreground ,fg-alt)))
- `(gnus-summary-low-ticked ((,class :inherit italic :foreground ,red-refine-fg)))
- `(gnus-summary-low-undownloaded ((,class :inherit italic :foreground ,yellow-refine-fg)))
- `(gnus-summary-low-unread ((,class :inherit italic :foreground ,fg-special-cold)))
- `(gnus-summary-normal-ancient ((,class :foreground ,fg-special-calm)))
- `(gnus-summary-normal-read ((,class :inherit shadow)))
- `(gnus-summary-normal-ticked ((,class :foreground ,red-alt-other)))
- `(gnus-summary-normal-undownloaded ((,class :foreground ,yellow)))
- `(gnus-summary-normal-unread ((,class :foreground ,fg-main)))
- `(gnus-summary-selected ((,class :inherit highlight :extend t)))
+ `(gnus-button ((,c :inherit button :underline nil)))
+ `(gnus-cite-1 ((,c :inherit message-cited-text-1)))
+ `(gnus-cite-2 ((,c :inherit message-cited-text-2)))
+ `(gnus-cite-3 ((,c :inherit message-cited-text-3)))
+ `(gnus-cite-4 ((,c :inherit message-cited-text-4)))
+ `(gnus-cite-5 ((,c :inherit message-cited-text-1)))
+ `(gnus-cite-6 ((,c :inherit message-cited-text-2)))
+ `(gnus-cite-7 ((,c :inherit message-cited-text-3)))
+ `(gnus-cite-8 ((,c :inherit message-cited-text-4)))
+ `(gnus-cite-9 ((,c :inherit message-cited-text-1)))
+ `(gnus-cite-10 ((,c :inherit message-cited-text-2)))
+ `(gnus-cite-11 ((,c :inherit message-cited-text-3)))
+ `(gnus-cite-attribution ((,c :inherit italic)))
+ `(gnus-emphasis-bold ((,c :inherit bold)))
+ `(gnus-emphasis-bold-italic ((,c :inherit bold-italic)))
+ `(gnus-emphasis-highlight-words ((,c :inherit warning)))
+ `(gnus-emphasis-italic ((,c :inherit italic)))
+ `(gnus-emphasis-underline-bold ((,c :inherit gnus-emphasis-bold :underline t)))
+ `(gnus-emphasis-underline-bold-italic ((,c :inherit gnus-emphasis-bold-italic :underline t)))
+ `(gnus-emphasis-underline-italic ((,c :inherit gnus-emphasis-italic :underline t)))
+ `(gnus-group-mail-1 ((,c :inherit (bold gnus-group-mail-1-empty))))
+ `(gnus-group-mail-1-empty ((,c :foreground ,magenta-warmer)))
+ `(gnus-group-mail-2 ((,c :inherit (bold gnus-group-mail-2-empty))))
+ `(gnus-group-mail-2-empty ((,c :foreground ,magenta)))
+ `(gnus-group-mail-3 ((,c :inherit (bold gnus-group-mail-3-empty))))
+ `(gnus-group-mail-3-empty ((,c :foreground ,magenta-cooler)))
+ `(gnus-group-mail-low ((,c :inherit (bold gnus-group-mail-low-empty))))
+ `(gnus-group-mail-low-empty ((,c :foreground ,fg-dim)))
+ `(gnus-group-news-1 ((,c :inherit (bold gnus-group-news-1-empty))))
+ `(gnus-group-news-1-empty ((,c :foreground ,green)))
+ `(gnus-group-news-2 ((,c :inherit (bold gnus-group-news-2-empty))))
+ `(gnus-group-news-2-empty ((,c :foreground ,cyan)))
+ `(gnus-group-news-3 ((,c :inherit (bold gnus-group-news-3-empty))))
+ `(gnus-group-news-3-empty ((,c :foreground ,yellow-faint)))
+ `(gnus-group-news-4 ((,c :inherit (bold gnus-group-news-4-empty))))
+ `(gnus-group-news-4-empty ((,c :foreground ,magenta-faint)))
+ `(gnus-group-news-5 ((,c :inherit (bold gnus-group-news-5-empty))))
+ `(gnus-group-news-5-empty ((,c :foreground ,fg-alt)))
+ `(gnus-group-news-6 ((,c :inherit (bold gnus-group-news-6-empty))))
+ `(gnus-group-news-6-empty ((,c :foreground ,fg-dim)))
+ `(gnus-group-news-low ((,c :inherit (bold gnus-group-news-low-empty))))
+ `(gnus-group-news-low-empty ((,c :foreground ,fg-dim)))
+ `(gnus-header-content ((,c :inherit message-header-other)))
+ `(gnus-header-from ((,c :inherit message-header-to :underline nil)))
+ `(gnus-header-name ((,c :inherit message-header-name)))
+ `(gnus-header-newsgroups ((,c :inherit message-header-newsgroups)))
+ `(gnus-header-subject ((,c :inherit message-header-subject)))
+ `(gnus-server-agent ((,c :inherit bold)))
+ `(gnus-server-closed ((,c :inherit italic)))
+ `(gnus-server-cloud ((,c :inherit bold :foreground ,fg-alt)))
+ `(gnus-server-cloud-host ((,c :inherit bold :foreground ,fg-alt :underline t)))
+ `(gnus-server-denied ((,c :inherit error)))
+ `(gnus-server-offline ((,c :inherit shadow)))
+ `(gnus-server-opened ((,c :inherit success)))
+ `(gnus-summary-cancelled ((,c :inherit italic :foreground ,warning)))
+ `(gnus-summary-high-ancient ((,c :inherit bold :foreground ,fg-alt)))
+ `(gnus-summary-high-read ((,c :inherit bold :foreground ,fg-dim)))
+ `(gnus-summary-high-ticked ((,c :inherit bold :foreground ,err)))
+ `(gnus-summary-high-undownloaded ((,c :inherit bold-italic :foreground ,warning)))
+ `(gnus-summary-high-unread ((,c :inherit bold)))
+ `(gnus-summary-low-ancient ((,c :inherit italic)))
+ `(gnus-summary-low-read ((,c :inherit (shadow italic))))
+ `(gnus-summary-low-ticked ((,c :inherit italic :foreground ,err)))
+ `(gnus-summary-low-undownloaded ((,c :inherit italic :foreground ,warning)))
+ `(gnus-summary-low-unread ((,c :inherit italic)))
+ `(gnus-summary-normal-ancient (( )))
+ `(gnus-summary-normal-read ((,c :inherit shadow)))
+ `(gnus-summary-normal-ticked ((,c :foreground ,err)))
+ `(gnus-summary-normal-undownloaded ((,c :foreground ,warning)))
+ `(gnus-summary-normal-unread (( )))
+ `(gnus-summary-selected ((,c :inherit highlight)))
;;;;; gotest
- `(go-test--ok-face ((,class :inherit success)))
- `(go-test--error-face ((,class :inherit error)))
- `(go-test--warning-face ((,class :inherit warning)))
- `(go-test--pointer-face ((,class :foreground ,magenta-alt-other)))
- `(go-test--standard-face ((,class :foreground ,fg-special-cold)))
+ `(go-test--ok-face ((,c :inherit success)))
+ `(go-test--error-face ((,c :inherit error)))
+ `(go-test--warning-face ((,c :inherit warning)))
+ `(go-test--pointer-face ((,c :foreground ,accent-0)))
+ `(go-test--standard-face (( )))
;;;;; golden-ratio-scroll-screen
- `(golden-ratio-scroll-highlight-line-face ((,class :background ,cyan-subtle-bg :foreground ,fg-main)))
-;;;;; helm
- `(helm-M-x-key ((,class :inherit modus-themes-key-binding)))
- `(helm-action ((,class :underline t)))
- `(helm-bookmark-addressbook ((,class :foreground ,green-alt)))
- `(helm-bookmark-directory ((,class :inherit bold :foreground ,blue)))
- `(helm-bookmark-file ((,class :foreground ,fg-main)))
- `(helm-bookmark-file-not-found ((,class :background ,bg-alt :foreground ,fg-alt)))
- `(helm-bookmark-gnus ((,class :foreground ,magenta)))
- `(helm-bookmark-info ((,class :foreground ,cyan-alt)))
- `(helm-bookmark-man ((,class :foreground ,yellow-alt)))
- `(helm-bookmark-w3m ((,class :foreground ,blue-alt)))
- `(helm-buffer-archive ((,class :inherit bold :foreground ,cyan)))
- `(helm-buffer-directory ((,class :inherit bold :foreground ,blue)))
- `(helm-buffer-file ((,class :foreground ,fg-main)))
- `(helm-buffer-modified ((,class :foreground ,yellow-alt)))
- `(helm-buffer-not-saved ((,class :foreground ,red-alt)))
- `(helm-buffer-process ((,class :foreground ,magenta)))
- `(helm-buffer-saved-out ((,class :inherit bold :background ,bg-alt :foreground ,red)))
- `(helm-buffer-size ((,class :inherit shadow)))
- `(helm-candidate-number ((,class :foreground ,cyan-active)))
- `(helm-candidate-number-suspended ((,class :foreground ,yellow-active)))
- `(helm-comint-prompts-buffer-name ((,class :foreground ,green-active)))
- `(helm-comint-prompts-promptidx ((,class :foreground ,cyan-active)))
- `(helm-delete-async-message ((,class :inherit bold :foreground ,magenta-active)))
- `(helm-eob-line ((,class :background ,bg-main :foreground ,fg-main)))
- `(helm-eshell-prompts-buffer-name ((,class :foreground ,green-active)))
- `(helm-eshell-prompts-promptidx ((,class :foreground ,cyan-active)))
- `(helm-etags-file ((,class :foreground ,fg-dim :underline t)))
- `(helm-ff-backup-file ((,class :inherit shadow)))
- `(helm-ff-denied ((,class :inherit modus-themes-intense-red)))
- `(helm-ff-directory ((,class :inherit helm-buffer-directory)))
- `(helm-ff-dirs ((,class :inherit bold :foreground ,blue-alt-other)))
- `(helm-ff-dotted-directory ((,class :inherit bold :background ,bg-alt :foreground ,fg-alt)))
- `(helm-ff-dotted-symlink-directory ((,class :inherit (button helm-ff-dotted-directory))))
- `(helm-ff-executable ((,class :foreground ,magenta-alt)))
- `(helm-ff-file ((,class :foreground ,fg-main)))
- `(helm-ff-file-extension ((,class :foreground ,fg-special-warm)))
- `(helm-ff-invalid-symlink ((,class :inherit modus-themes-link-broken)))
- `(helm-ff-pipe ((,class :inherit modus-themes-special-calm)))
- `(helm-ff-prefix ((,class :inherit modus-themes-special-warm)))
- `(helm-ff-socket ((,class :foreground ,red-alt-other)))
- `(helm-ff-suid ((,class :inherit modus-themes-special-warm)))
- `(helm-ff-symlink ((,class :inherit modus-themes-link-symlink)))
- `(helm-ff-truename ((,class :foreground ,blue-alt-other)))
- `(helm-fd-finish ((,class :inherit success)))
- `(helm-grep-cmd-line ((,class :foreground ,yellow-alt-other)))
- `(helm-grep-file ((,class :inherit bold :foreground ,fg-special-cold)))
- `(helm-grep-finish ((,class :inherit bold)))
- `(helm-grep-lineno ((,class :foreground ,fg-special-warm)))
- `(helm-grep-match ((,class :inherit modus-themes-special-calm)))
- `(helm-header ((,class :inherit bold :foreground ,fg-special-cold)))
- `(helm-header-line-left-margin ((,class :inherit bold :foreground ,yellow-intense)))
- `(helm-history-deleted ((,class :inherit modus-themes-special-warm)))
- `(helm-history-remote ((,class :foreground ,red-alt-other)))
- `(helm-lisp-completion-info ((,class :inherit modus-themes-bold :foreground ,fg-special-cold)))
- `(helm-lisp-show-completion ((,class :inherit modus-themes-special-warm)))
- `(helm-locate-finish ((,class :inherit success)))
- `(helm-match ((,class :inherit modus-themes-completion-match-0)))
- `(helm-match-item ((,class :inherit helm-match)))
- `(helm-minibuffer-prompt ((,class :inherit modus-themes-prompt)))
- `(helm-moccur-buffer ((,class :inherit button :foreground ,cyan-alt-other)))
- `(helm-mode-prefix ((,class :inherit modus-themes-special-calm)))
- `(helm-non-file-buffer ((,class :inherit shadow)))
- `(helm-prefarg ((,class :foreground ,red-active)))
- `(helm-resume-need-update ((,class :inherit modus-themes-special-calm)))
- `(helm-selection ((,class :inherit modus-themes-completion-selected)))
- `(helm-selection-line ((,class :background ,bg-hl-alt-intense)))
- `(helm-separator ((,class :foreground ,fg-special-mild)))
- `(helm-time-zone-current ((,class :foreground ,green)))
- `(helm-time-zone-home ((,class :foreground ,magenta)))
- `(helm-source-header ((,class :inherit modus-themes-pseudo-header :foreground ,fg-special-warm)))
- `(helm-top-columns ((,class :inherit helm-header)))
- `(helm-ucs-char ((,class :foreground ,yellow-alt-other)))
- `(helm-visible-mark ((,class :inherit modus-themes-subtle-cyan)))
-;;;;; helm-ls-git
- `(helm-ls-git-added-copied-face ((,class :foreground ,green-intense)))
- `(helm-ls-git-added-modified-face ((,class :foreground ,yellow-intense)))
- `(helm-ls-git-conflict-face ((,class :inherit bold :foreground ,red-intense)))
- `(helm-ls-git-deleted-and-staged-face ((,class :foreground ,red-nuanced-fg)))
- `(helm-ls-git-deleted-not-staged-face ((,class :foreground ,red)))
- `(helm-ls-git-modified-and-staged-face ((,class :foreground ,yellow-nuanced-fg)))
- `(helm-ls-git-modified-not-staged-face ((,class :foreground ,yellow)))
- `(helm-ls-git-renamed-modified-face ((,class :foreground ,magenta)))
- `(helm-ls-git-untracked-face ((,class :foreground ,fg-special-cold)))
-;;;;; helm-switch-shell
- `(helm-switch-shell-new-shell-face ((,class :inherit modus-themes-completion-match-0)))
-;;;;; helm-xref
- `(helm-xref-file-name ((,class :inherit modus-themes-bold :foreground ,fg-special-cold)))
+ `(golden-ratio-scroll-highlight-line-face ((,c :background ,bg-cyan-subtle :foreground ,fg-main)))
;;;;; helpful
- `(helpful-heading ((,class :inherit modus-themes-heading-1)))
+ `(helpful-heading ((,c :inherit modus-themes-heading-1)))
;;;;; highlight region or ad-hoc regexp
;; HACK 2022-06-23: The :inverse-video prevents hl-line-mode from
;; overriding the background. Such an override really defeats the
;; purpose of setting those highlights.
;;
- ;; NOTE 2022-10-04: We do not use the ,class here but instead
+ ;; NOTE 2022-10-04: We do not use the ,c here but instead
;; hardcode color values. We have to do this as the themes lack
;; entries in their palette for such an edge case. Defining those
;; entries is not appropriate.
`(hi-aquamarine ((((class color) (min-colors 88) (background light))
- :background "white" :foreground "#227f9f" :inverse-video t)
+ :background "#ffffff" :foreground "#227f9f" :inverse-video t)
(((class color) (min-colors 88) (background dark))
- :background "black" :foreground "#66cbdc" :inverse-video t)))
- `(hi-black-b ((,class :inverse-video t)))
- `(hi-black-hb ((,class :background ,bg-main :foreground ,fg-alt :inverse-video t)))
+ :background "#000000" :foreground "#66cbdc" :inverse-video t)))
+ `(hi-black-b ((,c :inverse-video t)))
+ `(hi-black-hb ((,c :background ,bg-main :foreground ,fg-dim :inverse-video t)))
`(hi-blue ((((class color) (min-colors 88) (background light))
- :background "white" :foreground "#3366dd" :inverse-video t)
+ :background "#ffffff" :foreground "#3366dd" :inverse-video t)
(((class color) (min-colors 88) (background dark))
- :background "black" :foreground "#aaccff" :inverse-video t)))
- `(hi-blue-b ((,class :inherit (bold hi-blue))))
+ :background "#000000" :foreground "#aaccff" :inverse-video t)))
+ `(hi-blue-b ((,c :inherit (bold hi-blue))))
`(hi-green ((((class color) (min-colors 88) (background light))
- :background "white" :foreground "#008a00" :inverse-video t)
- (((class color) (min-colors 88) (background dark))
- :background "black" :foreground "#66dd66" :inverse-video t)))
- `(hi-green-b ((,class :inherit (bold hi-green))))
+ :background "#ffffff" :foreground "#008a00" :inverse-video t)
+ (((class color) (min-colors 88) (background dark))
+ :background "#000000" :foreground "#66dd66" :inverse-video t)))
+ `(hi-green-b ((,c :inherit (bold hi-green))))
`(hi-pink ((((class color) (min-colors 88) (background light))
- :background "white" :foreground "#bd30aa" :inverse-video t)
- (((class color) (min-colors 88) (background dark))
- :background "black" :foreground "#ff88ee" :inverse-video t)))
+ :background "#ffffff" :foreground "#bd30aa" :inverse-video t)
+ (((class color) (min-colors 88) (background dark))
+ :background "#000000" :foreground "#ff88ee" :inverse-video t)))
`(hi-red-b ((((class color) (min-colors 88) (background light))
- :background "white" :foreground "#dd0000" :inverse-video t)
- (((class color) (min-colors 88) (background dark))
- :background "black" :foreground "#f06666" :inverse-video t)))
+ :background "#ffffff" :foreground "#dd0000" :inverse-video t)
+ (((class color) (min-colors 88) (background dark))
+ :background "#000000" :foreground "#f06666" :inverse-video t)))
`(hi-salmon ((((class color) (min-colors 88) (background light))
- :background "white" :foreground "#bf555a" :inverse-video t)
+ :background "#ffffff" :foreground "#bf555a" :inverse-video t)
(((class color) (min-colors 88) (background dark))
- :background "black" :foreground "#e08a50" :inverse-video t)))
+ :background "#000000" :foreground "#e08a50" :inverse-video t)))
`(hi-yellow ((((class color) (min-colors 88) (background light))
- :background "white" :foreground "#af6400" :inverse-video t)
+ :background "#ffffff" :foreground "#af6400" :inverse-video t)
(((class color) (min-colors 88) (background dark))
- :background "black" :foreground "#faea00" :inverse-video t)))
- `(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)))
- `(hl-line ((,class :inherit modus-themes-hl-line)))
-;;;;; highlight-indentation
- `(highlight-indentation-face ((,class :inherit modus-themes-hl-line)))
- `(highlight-indentation-current-column-face ((,class :background ,bg-active)))
+ :background "#000000" :foreground "#faea00" :inverse-video t)))
+ `(highlight-changes ((,c :foreground ,warning :underline nil)))
+ `(highlight-changes-delete ((,c :foreground ,err :underline t)))
+ `(hl-line ((,c :background ,bg-hl-line :extend t)))
;;;;; highlight-numbers
- `(highlight-numbers-number ((,class :foreground ,blue-alt-other)))
+ `(highlight-numbers-number ((,c :foreground ,constant)))
;;;;; highlight-thing
- `(highlight-thing ((,class :inherit modus-themes-special-calm)))
-;;;;; hl-defined
- `(hdefd-functions ((,class :foreground ,blue)))
- `(hdefd-undefined ((,class :foreground ,red-alt)))
- `(hdefd-variables ((,class :foreground ,cyan-alt)))
+ `(highlight-thing ((,c :inherit match)))
;;;;; hl-fill-column
- `(hl-fill-column-face ((,class :background ,bg-active :foreground ,fg-active)))
+ `(hl-fill-column-face ((,c :background ,bg-active)))
;;;;; hl-todo
- `(hl-todo ((,class :inherit (bold modus-themes-slant) :foreground ,red-alt-other)))
+ `(hl-todo ((,c :inherit (bold font-lock-comment-face) :foreground ,err)))
;;;;; hydra
- `(hydra-face-amaranth ((,class :inherit bold :foreground ,yellow-alt)))
- `(hydra-face-blue ((,class :inherit bold :foreground ,blue)))
- `(hydra-face-pink ((,class :inherit bold :foreground ,magenta-alt-faint)))
- `(hydra-face-red ((,class :inherit bold :foreground ,red-faint)))
- `(hydra-face-teal ((,class :inherit bold :foreground ,cyan-alt-other)))
+ `(hydra-face-amaranth ((,c :inherit bold :foreground ,yellow-warmer)))
+ `(hydra-face-blue ((,c :inherit bold :foreground ,blue)))
+ `(hydra-face-pink ((,c :inherit bold :foreground ,magenta)))
+ `(hydra-face-red ((,c :inherit bold :foreground ,red-faint)))
+ `(hydra-face-teal ((,c :inherit bold :foreground ,cyan-cooler)))
;;;;; icomplete
- `(icomplete-first-match ((,class :inherit modus-themes-completion-match-0)))
- `(icomplete-selected-match ((,class :inherit modus-themes-completion-selected)))
-;;;;; icomplete-vertical
- `(icomplete-vertical-separator ((,class :inherit shadow)))
+ `(icomplete-first-match ((,c :inherit modus-themes-completion-match-0)))
+ `(icomplete-selected-match ((,c :inherit modus-themes-completion-selected)))
;;;;; ido-mode
- `(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)))
- `(ido-subdir ((,class :foreground ,blue)))
- `(ido-virtual ((,class :foreground ,magenta-alt-other)))
+ `(ido-first-match ((,c :inherit modus-themes-completion-match-0)))
+ `(ido-incomplete-regexp ((,c :inherit error)))
+ `(ido-indicator ((,c :inherit bold)))
+ `(ido-only-match ((,c :inherit ido-first-match)))
+ `(ido-subdir ((,c :foreground ,accent-0)))
+ `(ido-virtual ((,c :foreground ,accent-1)))
;;;;; iedit
- `(iedit-occurrence ((,class :inherit modus-themes-refine-blue)))
- `(iedit-read-only-occurrence ((,class :inherit modus-themes-intense-yellow)))
+ `(iedit-occurrence ((,c :inherit modus-themes-search-lazy)))
+ `(iedit-read-only-occurrence ((,c :inherit modus-themes-search-current)))
;;;;; iflipb
- `(iflipb-current-buffer-face ((,class :inherit bold :foreground ,cyan-alt)))
- `(iflipb-other-buffer-face ((,class :inherit shadow)))
+ `(iflipb-current-buffer-face ((,c :inherit bold :foreground ,name)))
+ `(iflipb-other-buffer-face ((,c :inherit shadow)))
;;;;; image-dired
- `(image-dired-thumb-flagged ((,class :background ,red-intense-bg)))
- `(image-dired-thumb-header-file-name ((,class :inherit bold)))
- `(image-dired-thumb-header-file-size ((,class :foreground ,blue-active)))
- `(image-dired-thumb-mark ((,class :inherit modus-themes-grue-background-intense)))
+ `(image-dired-thumb-flagged ((,c :inherit modus-themes-mark-del :box (:line-width -3))))
+ `(image-dired-thumb-header-file-name ((,c :inherit bold)))
+ `(image-dired-thumb-header-file-size ((,c :foreground ,constant)))
+ `(image-dired-thumb-mark ((,c :inherit modus-themes-mark-sel :box (:line-width -3))))
;;;;; imenu-list
- `(imenu-list-entry-face-0 ((,class :foreground ,cyan)))
- `(imenu-list-entry-face-1 ((,class :foreground ,blue)))
- `(imenu-list-entry-face-2 ((,class :foreground ,cyan-alt-other)))
- `(imenu-list-entry-face-3 ((,class :foreground ,blue-alt)))
- `(imenu-list-entry-subalist-face-0 ((,class :inherit bold :foreground ,magenta-alt-other :underline t)))
- `(imenu-list-entry-subalist-face-1 ((,class :inherit bold :foreground ,magenta :underline t)))
- `(imenu-list-entry-subalist-face-2 ((,class :inherit bold :foreground ,green-alt-other :underline t)))
- `(imenu-list-entry-subalist-face-3 ((,class :inherit bold :foreground ,red-alt-other :underline t)))
+ `(imenu-list-entry-face-0 ((,c :foreground ,fg-heading-1)))
+ `(imenu-list-entry-face-1 ((,c :foreground ,fg-heading-2)))
+ `(imenu-list-entry-face-2 ((,c :foreground ,fg-heading-3)))
+ `(imenu-list-entry-face-3 ((,c :foreground ,fg-heading-4)))
+ `(imenu-list-entry-subalist-face-0 ((,c :inherit bold :foreground ,fg-heading-1 :underline t)))
+ `(imenu-list-entry-subalist-face-1 ((,c :inherit bold :foreground ,fg-heading-2 :underline t)))
+ `(imenu-list-entry-subalist-face-2 ((,c :inherit bold :foreground ,fg-heading-3 :underline t)))
+ `(imenu-list-entry-subalist-face-3 ((,c :inherit bold :foreground ,fg-heading-4 :underline t)))
;;;;; indium
- `(indium-breakpoint-face ((,class :foreground ,red-active)))
- `(indium-frame-url-face ((,class :inherit (shadow button))))
- `(indium-keyword-face ((,class :inherit font-lock-keyword-face)))
- `(indium-litable-face ((,class :inherit modus-themes-slant :foreground ,fg-special-warm)))
- `(indium-repl-error-face ((,class :inherit error)))
- `(indium-repl-prompt-face ((,class :inherit modus-themes-prompt)))
- `(indium-repl-stdout-face ((,class :foreground ,fg-main)))
+ `(indium-breakpoint-face ((,c :foreground ,err)))
+ `(indium-frame-url-face ((,c :inherit (shadow button))))
+ `(indium-keyword-face ((,c :inherit font-lock-keyword-face)))
+ `(indium-litable-face ((,c :inherit modus-themes-slant)))
+ `(indium-repl-error-face ((,c :inherit error)))
+ `(indium-repl-prompt-face ((,c :inherit modus-themes-prompt)))
+ `(indium-repl-stdout-face (( )))
;;;;; info
- `(Info-quoted ((,class :inherit modus-themes-markup-verbatim))) ; the capitalization is canonical
- `(info-header-node ((,class :inherit (shadow bold))))
- `(info-header-xref ((,class :foreground ,blue-active)))
- `(info-index-match ((,class :inherit match)))
- `(info-menu-header ((,class :inherit modus-themes-pseudo-header)))
- `(info-menu-star ((,class :foreground ,red)))
- `(info-node ((,class :inherit bold)))
- `(info-title-1 ((,class :inherit modus-themes-heading-1)))
- `(info-title-2 ((,class :inherit modus-themes-heading-2)))
- `(info-title-3 ((,class :inherit modus-themes-heading-3)))
- `(info-title-4 ((,class :inherit modus-themes-heading-4)))
+ `(Info-quoted ((,c :inherit modus-themes-prose-verbatim))) ; the capitalization is canonical
+ `(info-header-node ((,c :inherit (shadow bold))))
+ `(info-header-xref ((,c :foreground ,fg-link)))
+ `(info-index-match ((,c :inherit match)))
+ `(info-menu-header ((,c :inherit bold)))
+ `(info-menu-star ((,c :inherit error)))
+ `(info-node ((,c :inherit bold)))
+ `(info-title-1 ((,c :inherit modus-themes-heading-1)))
+ `(info-title-2 ((,c :inherit modus-themes-heading-2)))
+ `(info-title-3 ((,c :inherit modus-themes-heading-3)))
+ `(info-title-4 ((,c :inherit modus-themes-heading-4)))
;;;;; info+ (info-plus)
- `(info-command-ref-item ((,class :inherit font-lock-function-name-face)))
- `(info-constant-ref-item ((,class :inherit font-lock-constant-face)))
- `(info-custom-delimited ((,class :inherit modus-themes-markup-verbatim)))
- `(info-double-quoted-name ((,class :inherit font-lock-string-face)))
+ `(info-command-ref-item ((,c :inherit font-lock-function-name-face)))
+ `(info-constant-ref-item ((,c :inherit font-lock-constant-face)))
+ `(info-custom-delimited ((,c :inherit modus-themes-prose-verbatim)))
+ `(info-double-quoted-name ((,c :inherit font-lock-string-face)))
`(info-file (( )))
- `(info-function-ref-item ((,class :inherit font-lock-function-name-face)))
- `(info-glossary-word ((,class :inherit modus-themes-box-button)))
+ `(info-function-ref-item ((,c :inherit font-lock-function-name-face)))
+ `(info-glossary-word ((,c :inherit modus-themes-button)))
`(info-indented-text (( )))
`(info-isolated-backquote (( )))
`(info-isolated-quote (( )))
- `(info-macro-ref-item ((,class :inherit font-lock-keyword-face)))
- `(info-menu ((,class :inherit bold)))
- `(info-quoted-name ((,class :inherit modus-themes-markup-verbatim)))
- `(info-reference-item ((,class :inherit bold)))
- `(info-special-form-ref-item ((,class :inherit warning)))
- `(info-string ((,class :inherit font-lock-string-face)))
- `(info-syntax-class-item ((,class :inherit modus-themes-markup-code)))
- `(info-user-option-ref-item ((,class :inherit font-lock-variable-name-face)))
- `(info-variable-ref-item ((,class :inherit font-lock-variable-name-face)))
+ `(info-macro-ref-item ((,c :inherit font-lock-keyword-face)))
+ `(info-menu ((,c :inherit bold)))
+ `(info-quoted-name ((,c :inherit modus-themes-prose-verbatim)))
+ `(info-reference-item ((,c :inherit bold)))
+ `(info-special-form-ref-item ((,c :inherit warning)))
+ `(info-string ((,c :inherit font-lock-string-face)))
+ `(info-syntax-class-item ((,c :inherit modus-themes-prose-code)))
+ `(info-user-option-ref-item ((,c :inherit font-lock-variable-name-face)))
+ `(info-variable-ref-item ((,c :inherit font-lock-variable-name-face)))
;;;;; info-colors
- `(info-colors-lisp-code-block ((,class :inherit modus-themes-fixed-pitch)))
- `(info-colors-ref-item-command ((,class :inherit font-lock-function-name-face)))
- `(info-colors-ref-item-constant ((,class :inherit font-lock-constant-face)))
- `(info-colors-ref-item-function ((,class :inherit font-lock-function-name-face)))
- `(info-colors-ref-item-macro ((,class :inherit font-lock-keyword-face)))
- `(info-colors-ref-item-other ((,class :inherit font-lock-doc-face)))
- `(info-colors-ref-item-special-form ((,class :inherit font-lock-keyword-face)))
- `(info-colors-ref-item-syntax-class ((,class :inherit font-lock-builtin-face)))
- `(info-colors-ref-item-type ((,class :inherit font-lock-type-face)))
- `(info-colors-ref-item-user-option ((,class :inherit font-lock-variable-name-face)))
- `(info-colors-ref-item-variable ((,class :inherit font-lock-variable-name-face)))
-;;;;; interaction-log
- `(ilog-buffer-face ((,class :foreground ,magenta-alt-other)))
- `(ilog-change-face ((,class :foreground ,magenta-alt)))
- `(ilog-echo-face ((,class :foreground ,yellow-alt-other)))
- `(ilog-load-face ((,class :foreground ,green)))
- `(ilog-message-face ((,class :inherit shadow)))
- `(ilog-non-change-face ((,class :foreground ,blue)))
+ `(info-colors-lisp-code-block ((,c :inherit modus-themes-fixed-pitch)))
+ `(info-colors-ref-item-command ((,c :inherit font-lock-function-name-face)))
+ `(info-colors-ref-item-constant ((,c :inherit font-lock-constant-face)))
+ `(info-colors-ref-item-function ((,c :inherit font-lock-function-name-face)))
+ `(info-colors-ref-item-macro ((,c :inherit font-lock-keyword-face)))
+ `(info-colors-ref-item-other ((,c :inherit font-lock-doc-face)))
+ `(info-colors-ref-item-special-form ((,c :inherit font-lock-keyword-face)))
+ `(info-colors-ref-item-syntax-class ((,c :inherit font-lock-builtin-face)))
+ `(info-colors-ref-item-type ((,c :inherit font-lock-type-face)))
+ `(info-colors-ref-item-user-option ((,c :inherit font-lock-variable-name-face)))
+ `(info-colors-ref-item-variable ((,c :inherit font-lock-variable-name-face)))
;;;;; ioccur
- `(ioccur-cursor ((,class :foreground ,fg-main)))
- `(ioccur-invalid-regexp ((,class :foreground ,red)))
- `(ioccur-match-face ((,class :inherit modus-themes-special-calm)))
- `(ioccur-match-overlay-face ((,class :inherit modus-themes-special-cold :extend t)))
- `(ioccur-num-line-face ((,class :foreground ,fg-special-warm)))
- `(ioccur-overlay-face ((,class :inherit modus-themes-refine-blue :extend t)))
- `(ioccur-regexp-face ((,class :inherit (modus-themes-intense-magenta bold))))
- `(ioccur-title-face ((,class :inherit modus-themes-pseudo-header :foreground ,fg-special-cold)))
+ `(ioccur-cursor ((,c :foreground ,fg-main)))
+ `(ioccur-invalid-regexp ((,c :inherit error)))
+ `(ioccur-match-face ((,c :inherit match)))
+ `(ioccur-match-overlay-face ((,c :background ,bg-inactive :extend t)))
+ `(ioccur-num-line-face ((,c :inherit shadow)))
+ `(ioccur-overlay-face ((,c :background ,bg-hl-line :extend t)))
+ `(ioccur-regexp-face ((,c :inherit (modus-themes-search-current bold))))
+ `(ioccur-title-face ((,c :inherit bold :foreground ,name)))
;;;;; isearch, occur, and the like
- `(isearch ((,class :inherit modus-themes-search-success)))
- `(isearch-fail ((,class :inherit modus-themes-refine-red)))
- `(isearch-group-1 ((,class :inherit modus-themes-refine-blue)))
- `(isearch-group-2 ((,class :inherit modus-themes-refine-magenta)))
- `(lazy-highlight ((,class :inherit modus-themes-search-success-lazy)))
- `(match ((,class :inherit modus-themes-special-calm)))
- `(query-replace ((,class :inherit modus-themes-intense-red)))
+ `(isearch ((,c :inherit modus-themes-search-current)))
+ `(isearch-fail ((,c :inherit modus-themes-prominent-error)))
+ `(isearch-group-1 ((,c :inherit modus-themes-search-rx-group-0)))
+ `(isearch-group-2 ((,c :inherit modus-themes-search-rx-group-1)))
+ `(lazy-highlight ((,c :inherit modus-themes-search-lazy)))
+ `(match ((,c :background ,bg-magenta-subtle :foreground ,fg-main)))
+ `(query-replace ((,c :inherit modus-themes-search-replace)))
;;;;; ivy
- `(ivy-action ((,class :inherit modus-themes-key-binding)))
- `(ivy-confirm-face ((,class :inherit success)))
- `(ivy-current-match ((,class :inherit modus-themes-completion-selected)))
- `(ivy-cursor ((,class :background ,fg-main :foreground ,bg-main)))
- `(ivy-highlight-face ((,class :foreground ,magenta)))
- `(ivy-match-required-face ((,class :inherit error)))
+ `(ivy-action ((,c :inherit modus-themes-key-binding)))
+ `(ivy-confirm-face ((,c :inherit success)))
+ `(ivy-current-match ((,c :inherit modus-themes-completion-selected)))
+ `(ivy-match-required-face ((,c :inherit error)))
`(ivy-minibuffer-match-face-1 (( )))
- `(ivy-minibuffer-match-face-2 ((,class :inherit modus-themes-completion-match-0)))
- `(ivy-minibuffer-match-face-3 ((,class :inherit modus-themes-completion-match-1)))
- `(ivy-minibuffer-match-face-4 ((,class :inherit modus-themes-completion-match-2)))
- `(ivy-org ((,class :foreground ,cyan-alt-other)))
- `(ivy-remote ((,class :foreground ,magenta)))
- `(ivy-separator ((,class :inherit shadow)))
- `(ivy-subdir ((,class :foreground ,blue)))
- `(ivy-virtual ((,class :foreground ,magenta-alt-other)))
+ `(ivy-minibuffer-match-face-2 ((,c :inherit modus-themes-completion-match-0)))
+ `(ivy-minibuffer-match-face-3 ((,c :inherit modus-themes-completion-match-1)))
+ `(ivy-minibuffer-match-face-4 ((,c :inherit modus-themes-completion-match-2)))
+ `(ivy-remote ((,c :inherit italic)))
+ `(ivy-separator ((,c :inherit shadow)))
+ `(ivy-subdir ((,c :foreground ,accent-0)))
+ `(ivy-virtual ((,c :foreground ,accent-1)))
;;;;; ivy-posframe
- `(ivy-posframe-border ((,class :background ,fg-window-divider-inner)))
- `(ivy-posframe-cursor ((,class :background ,fg-main :foreground ,bg-main)))
+ `(ivy-posframe-border ((,c :background ,border)))
+ `(ivy-posframe-cursor ((,c :background ,fg-main :foreground ,bg-main)))
+;;;;; japanese-holidays
+ `(japanese-holiday-saturday ((,c :foreground ,date-holiday-other)))
;;;;; jira (org-jira)
- `(jiralib-comment-face ((,class :background ,bg-alt)))
- `(jiralib-comment-header-face ((,class :inherit bold)))
- `(jiralib-issue-info-face ((,class :inherit modus-themes-special-warm)))
- `(jiralib-issue-info-header-face ((,class :inherit (modus-themes-special-warm bold))))
- `(jiralib-issue-summary-face ((,class :inherit bold)))
- `(jiralib-link-filter-face ((,class :underline t)))
- `(jiralib-link-issue-face ((,class :underline t)))
- `(jiralib-link-project-face ((,class :underline t)))
+ `(jiralib-comment-face ((,c :background ,bg-inactive)))
+ `(jiralib-comment-header-face ((,c :inherit bold)))
+ `(jiralib-issue-info-face ((,c :background ,bg-inactive)))
+ `(jiralib-issue-info-header-face ((,c :inherit bold :background ,bg-inactive)))
+ `(jiralib-issue-summary-face ((,c :inherit bold)))
+ `(jiralib-link-filter-face ((,c :underline t)))
+ `(jiralib-link-issue-face ((,c :underline t)))
+ `(jiralib-link-project-face ((,c :underline t)))
+;;;;; jit-spell
+ `(jit-spell-misspelling ((,c :inherit modus-themes-lang-error)))
+;;;;; jinx
+ `(jinx-misspelled ((,c :inherit modus-themes-lang-warning)))
;;;;; journalctl-mode
- `(journalctl-error-face ((,class :inherit error)))
- `(journalctl-finished-face ((,class :inherit success)))
- `(journalctl-host-face ((,class :foreground ,blue)))
- `(journalctl-process-face ((,class :foreground ,cyan-alt-other)))
- `(journalctl-starting-face ((,class :foreground ,green)))
- `(journalctl-timestamp-face ((,class :foreground ,fg-special-cold)))
- `(journalctl-warning-face ((,class :inherit warning)))
+ `(journalctl-error-face ((,c :inherit error)))
+ `(journalctl-finished-face ((,c :inherit success)))
+ `(journalctl-host-face ((,c :foreground ,name)))
+ `(journalctl-process-face ((,c :foreground ,warning)))
+ `(journalctl-starting-face ((,c :foreground ,info)))
+ `(journalctl-timestamp-face ((,c :foreground ,date-common)))
+ `(journalctl-warning-face ((,c :inherit warning)))
;;;;; js2-mode
- `(js2-error ((,class :inherit modus-themes-lang-error)))
- `(js2-external-variable ((,class :inherit font-lock-variable-name-face)))
- `(js2-function-call ((,class :inherit font-lock-function-name-face)))
- `(js2-function-param ((,class :inherit font-lock-constant-face)))
- `(js2-instance-member ((,class :inherit font-lock-keyword-face)))
- `(js2-jsdoc-html-tag-delimiter ((,class :foreground ,fg-main)))
- `(js2-jsdoc-html-tag-name ((,class :inherit font-lock-function-name-face)))
- `(js2-jsdoc-tag ((,class :inherit (font-lock-builtin-face font-lock-comment-face) :weight normal)))
- `(js2-jsdoc-type ((,class :inherit (font-lock-type-face font-lock-comment-face) :weight normal)))
- `(js2-jsdoc-value ((,class :inherit (font-lock-constant-face font-lock-comment-face) :weight normal)))
- `(js2-object-property ((,class :foreground ,fg-main)))
- `(js2-object-property-access ((,class :foreground ,fg-main)))
- `(js2-private-function-call ((,class :inherit font-lock-preprocessor-face)))
- `(js2-private-member ((,class :inherit font-lock-warning-face)))
- `(js2-warning ((,class :inherit modus-themes-lang-warning)))
+ `(js2-error ((,c :inherit modus-themes-lang-error)))
+ `(js2-external-variable ((,c :inherit font-lock-variable-name-face)))
+ `(js2-function-call ((,c :inherit font-lock-function-name-face)))
+ `(js2-function-param ((,c :inherit font-lock-constant-face)))
+ `(js2-instance-member ((,c :inherit font-lock-keyword-face)))
+ `(js2-jsdoc-html-tag-delimiter ((,c :foreground ,fg-main)))
+ `(js2-jsdoc-html-tag-name ((,c :inherit font-lock-function-name-face)))
+ `(js2-jsdoc-tag ((,c :inherit (font-lock-builtin-face font-lock-comment-face) :weight normal)))
+ `(js2-jsdoc-type ((,c :inherit (font-lock-type-face font-lock-comment-face) :weight normal)))
+ `(js2-jsdoc-value ((,c :inherit (font-lock-constant-face font-lock-comment-face) :weight normal)))
+ `(js2-object-property ((,c :foreground ,fg-main)))
+ `(js2-object-property-access ((,c :foreground ,fg-main)))
+ `(js2-private-function-call ((,c :inherit font-lock-preprocessor-face)))
+ `(js2-private-member ((,c :inherit font-lock-warning-face)))
+ `(js2-warning ((,c :inherit modus-themes-lang-warning)))
;;;;; julia
- `(julia-macro-face ((,class :inherit font-lock-builtin-face)))
- `(julia-quoted-symbol-face ((,class :inherit font-lock-constant-face)))
-;;;;; jupyter
- `(jupyter-eval-overlay ((,class :inherit bold :foreground ,blue)))
- `(jupyter-repl-input-prompt ((,class :foreground ,cyan-alt-other)))
- `(jupyter-repl-output-prompt ((,class :foreground ,magenta-alt-other)))
- `(jupyter-repl-traceback ((,class :inherit modus-themes-intense-red)))
+ `(julia-macro-face ((,c :inherit font-lock-builtin-face)))
+ `(julia-quoted-symbol-face ((,c :inherit font-lock-constant-face)))
;;;;; kaocha-runner
- `(kaocha-runner-error-face ((,class :inherit error)))
- `(kaocha-runner-success-face ((,class :inherit success)))
- `(kaocha-runner-warning-face ((,class :inherit warning)))
+ `(kaocha-runner-error-face ((,c :inherit error)))
+ `(kaocha-runner-success-face ((,c :inherit success)))
+ `(kaocha-runner-warning-face ((,c :inherit warning)))
;;;;; keycast
- `(keycast-command ((,class :inherit bold :foreground ,blue-active)))
- ;; FIXME 2022-05-03: The padding breaks `keycast-tab-bar-mode'
- `(keycast-key ((,class ;; ,@(modus-themes--mode-line-padded-box blue-active)
- :background ,blue-active :foreground ,bg-main)))
+ `(keycast-command ((,c :inherit bold)))
+ `(keycast-key ((,c :inherit modus-themes-bold :background ,keybind :foreground ,bg-main)))
;;;;; ledger-mode
- `(ledger-font-auto-xact-face ((,class :foreground ,magenta)))
- `(ledger-font-account-name-face ((,class :foreground ,fg-special-cold)))
- `(ledger-font-directive-face ((,class :foreground ,magenta-alt-other)))
- `(ledger-font-posting-date-face ((,class :inherit bold :foreground ,fg-main)))
- `(ledger-font-periodic-xact-face ((,class :foreground ,cyan-alt-other)))
- `(ledger-font-posting-amount-face ((,class :foreground ,fg-special-mild)))
- `(ledger-font-payee-cleared-face ((,class :foreground ,blue-alt)))
- `(ledger-font-payee-pending-face ((,class :foreground ,yellow)))
- `(ledger-font-payee-uncleared-face ((,class :foreground ,red-alt-other)))
- `(ledger-font-xact-highlight-face ((,class :background ,bg-hl-alt)))
+ `(ledger-font-auto-xact-face ((,c :inherit font-lock-builtin-face)))
+ `(ledger-font-account-name-face ((,c :foreground ,name)))
+ `(ledger-font-directive-face ((,c :inherit font-lock-keyword-face)))
+ `(ledger-font-posting-date-face ((,c :inherit modus-themes-bold :foreground ,date-common)))
+ `(ledger-font-periodic-xact-face ((,c :inherit font-lock-variable-name-face)))
+ `(ledger-font-posting-amount-face ((,c :inherit font-lock-constant-face)))
+ `(ledger-font-payee-cleared-face ((,c :inherit success)))
+ `(ledger-font-payee-pending-face ((,c :inherit warning)))
+ `(ledger-font-payee-uncleared-face ((,c :inherit error)))
+ `(ledger-font-xact-highlight-face ((,c :background ,bg-hl-line :extend t)))
;;;;; leerzeichen
- `(leerzeichen ((,class :background ,bg-whitespace :foreground ,fg-whitespace)))
+ `(leerzeichen ((,c :background ,bg-inactive)))
;;;;; line numbers (display-line-numbers-mode and global variant)
;; Here we cannot inherit `modus-themes-fixed-pitch'. We need to
;; fall back to `default' otherwise line numbers do not scale when
;; using `text-scale-adjust'.
- `(line-number
- ((,class :inherit ,(if modus-themes-mixed-fonts '(fixed-pitch default) 'default)
- ,@(modus-themes--line-numbers
- fg-alt bg-dim
- fg-unfocused))))
- `(line-number-current-line
- ((,class :inherit (bold line-number)
- ,@(modus-themes--line-numbers
- fg-main bg-active
- blue-alt-other))))
- `(line-number-major-tick
- ((,class :inherit (bold line-number)
- ,@(modus-themes--line-numbers
- yellow-nuanced-fg yellow-nuanced-bg
- red-alt))))
- `(line-number-minor-tick
- ((,class :inherit (bold line-number)
- ,@(modus-themes--line-numbers
- fg-alt bg-inactive
- fg-inactive))))
-;;;;; lsp-mode
- `(lsp-face-highlight-read ((,class :inherit modus-themes-subtle-blue :underline t)))
- `(lsp-face-highlight-textual ((,class :inherit modus-themes-subtle-blue)))
- `(lsp-face-highlight-write ((,class :inherit (modus-themes-refine-blue bold))))
- `(lsp-face-semhl-constant ((,class :foreground ,blue-alt-other)))
- `(lsp-face-semhl-deprecated ((,class :inherit modus-themes-lang-warning)))
- `(lsp-face-semhl-enummember ((,class :foreground ,blue-alt-other)))
- `(lsp-face-semhl-field ((,class :foreground ,cyan-alt)))
- `(lsp-face-semhl-field-static ((,class :inherit modus-themes-slant :foreground ,cyan-alt)))
- `(lsp-face-semhl-function ((,class :foreground ,magenta)))
- `(lsp-face-semhl-method ((,class :foreground ,magenta)))
- `(lsp-face-semhl-namespace ((,class :inherit modus-themes-bold :foreground ,magenta-alt)))
- `(lsp-face-semhl-preprocessor ((,class :foreground ,red-alt-other)))
- `(lsp-face-semhl-static-method ((,class :inherit modus-themes-slant :foreground ,magenta)))
- `(lsp-face-semhl-type-class ((,class :foreground ,magenta-alt)))
- `(lsp-face-semhl-type-enum ((,class :foreground ,magenta-alt)))
- `(lsp-face-semhl-type-primitive ((,class :inherit modus-themes-slant :foreground ,magenta-alt)))
- `(lsp-face-semhl-type-template ((,class :inherit modus-themes-slant :foreground ,magenta-alt)))
- `(lsp-face-semhl-type-typedef ((,class :inherit modus-themes-slant :foreground ,magenta-alt)))
- `(lsp-face-semhl-variable ((,class :foreground ,cyan)))
- `(lsp-face-semhl-variable-local ((,class :foreground ,cyan)))
- `(lsp-face-semhl-variable-parameter ((,class :foreground ,cyan-alt-other)))
- `(lsp-lens-face ((,class :inherit shadow :height 0.8)))
- `(lsp-lens-mouse-face ((,class :height 0.8 :foreground ,blue-alt-other :underline t)))
- `(lsp-ui-doc-background ((,class :background ,bg-alt)))
- `(lsp-ui-doc-header ((,class :background ,bg-header :foreground ,fg-header)))
- `(lsp-ui-doc-url ((,class :inherit button)))
- `(lsp-ui-peek-filename ((,class :foreground ,fg-special-warm)))
- `(lsp-ui-peek-footer ((,class :background ,bg-header :foreground ,fg-header)))
- `(lsp-ui-peek-header ((,class :background ,bg-header :foreground ,fg-header)))
- `(lsp-ui-peek-highlight ((,class :inherit modus-themes-subtle-blue)))
- `(lsp-ui-peek-line-number ((,class :inherit shadow)))
- `(lsp-ui-peek-list ((,class :background ,bg-dim)))
- `(lsp-ui-peek-peek ((,class :background ,bg-alt)))
- `(lsp-ui-peek-selection ((,class :inherit modus-themes-subtle-cyan)))
- `(lsp-ui-sideline-code-action ((,class :foreground ,yellow)))
- `(lsp-ui-sideline-current-symbol ((,class :inherit bold :height 0.99 :box (:line-width -1 :style nil) :foreground ,fg-main)))
- `(lsp-ui-sideline-symbol ((,class :inherit bold :height 0.99 :box (:line-width -1 :style nil) :foreground ,fg-alt)))
- `(lsp-ui-sideline-symbol-info ((,class :inherit italic :height 0.99)))
-;;;;; macrostep
- `(macrostep-compiler-macro-face ((,class :inherit italic)))
- `(macrostep-expansion-highlight-face ((,class :background ,blue-nuanced-bg)))
- `(macrostep-gensym-1 ((,class :inherit bold :foreground ,blue :box t)))
- `(macrostep-gensym-2 ((,class :inherit bold :foreground ,green :box t)))
- `(macrostep-gensym-3 ((,class :inherit bold :foreground ,yellow :box t)))
- `(macrostep-gensym-4 ((,class :inherit bold :foreground ,red :box t)))
- `(macrostep-gensym-5 ((,class :inherit bold :foreground ,magenta :box t)))
- `(macrostep-macro-face ((,class :inherit button :foreground ,green-alt)))
+ `(line-number ((,c :inherit ,(if modus-themes-mixed-fonts '(fixed-pitch default) 'default) :background ,bg-line-number-inactive :foreground ,fg-line-number-inactive)))
+ `(line-number-current-line ((,c :inherit (bold line-number) :background ,bg-line-number-active :foreground ,fg-line-number-active)))
+ `(line-number-major-tick ((,c :inherit line-number :foreground ,err)))
+ `(line-number-minor-tick ((,c :inherit line-number :foreground ,fg-alt)))
;;;;; magit
- `(magit-bisect-bad ((,class :inherit error)))
- `(magit-bisect-good ((,class :inherit success)))
- `(magit-bisect-skip ((,class :inherit warning)))
- `(magit-blame-date ((,class :foreground ,blue)))
- `(magit-blame-dimmed ((,class :inherit (shadow modus-themes-reset-hard))))
- `(magit-blame-hash ((,class :foreground ,fg-special-warm)))
- `(magit-blame-heading ((,class :inherit modus-themes-reset-hard :background ,bg-alt :extend t)))
- `(magit-blame-highlight ((,class :inherit modus-themes-nuanced-cyan)))
- `(magit-blame-margin ((,class :inherit (magit-blame-highlight modus-themes-reset-hard))))
- `(magit-blame-name ((,class :foreground ,magenta-alt-other)))
- `(magit-blame-summary ((,class :foreground ,cyan-alt-other)))
- ;; ;; NOTE 2021-11-23: we do not set the `magit-branch-current'
- ;; ;; because its definition checks if the :box attribute can be set
- ;; ;; and if not, it uses :inverse-video. Useful for terminal
- ;; ;; emulators.
- ;;
- ;; `(magit-branch-current ((,class :foreground ,blue-alt-other :box t)))
- `(magit-branch-local ((,class :foreground ,blue-alt)))
- `(magit-branch-remote ((,class :foreground ,magenta-alt)))
- `(magit-branch-remote-head ((,class :foreground ,magenta-alt-other :box t)))
- `(magit-branch-upstream ((,class :inherit italic)))
- `(magit-branch-warning ((,class :inherit warning)))
- `(magit-cherry-equivalent ((,class :background ,bg-main :foreground ,magenta-intense)))
- `(magit-cherry-unmatched ((,class :background ,bg-main :foreground ,cyan-intense)))
- ;; NOTE: here we break from the pattern of inheriting from the
- ;; modus-themes-diff-* faces, though only for the standard actions,
- ;; not the highlighted ones. This is because Magit's interaction
- ;; model relies on highlighting the current diff hunk.
- `(magit-diff-added ((,class ,@(modus-themes--diff
- bg-diff-added fg-diff-added
- green-nuanced-bg fg-diff-added
- bg-diff-added-deuteran fg-diff-added-deuteran
- blue-nuanced-bg fg-diff-added-deuteran))))
- `(magit-diff-added-highlight ((,class :inherit modus-themes-diff-focus-added)))
- `(magit-diff-base ((,class ,@(modus-themes--diff
- bg-diff-changed fg-diff-changed
- yellow-nuanced-bg fg-diff-changed))))
- `(magit-diff-base-highlight ((,class :inherit modus-themes-diff-focus-changed)))
- `(magit-diff-context ((,class ,@(unless (eq modus-themes-diffs 'bg-only) (list :foreground fg-unfocused)))))
- `(magit-diff-context-highlight ((,class ,@(modus-themes--diff
- bg-inactive fg-inactive
- bg-dim fg-alt
- bg-dim fg-alt))))
- `(magit-diff-file-heading ((,class :inherit bold :foreground ,fg-special-cold)))
- `(magit-diff-file-heading-highlight ((,class :inherit (modus-themes-special-cold bold))))
- `(magit-diff-file-heading-selection ((,class :inherit modus-themes-refine-cyan)))
- ;; NOTE: here we break from the pattern of inheriting from the
- ;; modus-themes-diff-* faces.
- `(magit-diff-hunk-heading ((,class :inherit bold
- ,@(modus-themes--diff
- bg-active fg-inactive
- bg-inactive fg-inactive
- bg-inactive fg-inactive
- nil nil
- t))))
- ;; NOTE: we do not follow the pattern of inheriting from
- ;; modus-themes-grue-* faces, as this is a special case.
- `(magit-diff-hunk-heading-highlight
- ((,class :inherit bold
- :background ,@(modus-themes--deuteran bg-active bg-diff-heading)
- :foreground ,@(modus-themes--deuteran fg-main fg-diff-heading))))
- `(magit-diff-hunk-heading-selection ((,class :inherit modus-themes-refine-blue)))
- `(magit-diff-hunk-region ((,class :inherit bold)))
- `(magit-diff-lines-boundary ((,class :background ,fg-main)))
- `(magit-diff-lines-heading ((,class :inherit modus-themes-refine-magenta)))
- `(magit-diff-removed ((,class ,@(modus-themes--diff
- bg-diff-removed fg-diff-removed
- red-nuanced-bg fg-diff-removed))))
- `(magit-diff-removed-highlight ((,class :inherit modus-themes-diff-focus-removed)))
- `(magit-diffstat-added ((,class :inherit modus-themes-grue)))
- `(magit-diffstat-removed ((,class :foreground ,red)))
- `(magit-dimmed ((,class :foreground ,fg-unfocused)))
- `(magit-filename ((,class :foreground ,fg-special-cold)))
- `(magit-hash ((,class :inherit shadow)))
- `(magit-head ((,class :inherit magit-branch-local)))
- `(magit-header-line ((,class :inherit bold :foreground ,magenta-active)))
- `(magit-header-line-key ((,class :inherit modus-themes-key-binding)))
- `(magit-header-line-log-select ((,class :inherit bold :foreground ,fg-main)))
- `(magit-keyword ((,class :foreground ,magenta)))
- `(magit-keyword-squash ((,class :inherit bold :foreground ,yellow-alt-other)))
- `(magit-log-author ((,class :foreground ,cyan)))
- `(magit-log-date ((,class :inherit shadow)))
- `(magit-log-graph ((,class :foreground ,fg-dim)))
- `(magit-mode-line-process ((,class :inherit bold :foreground ,cyan-active)))
- `(magit-mode-line-process-error ((,class :inherit bold :foreground ,red-active)))
- `(magit-process-ng ((,class :inherit error)))
- `(magit-process-ok ((,class :inherit success)))
- `(magit-reflog-amend ((,class :inherit warning)))
- `(magit-reflog-checkout ((,class :inherit bold :foreground ,blue-alt)))
- `(magit-reflog-cherry-pick ((,class :inherit success)))
- `(magit-reflog-commit ((,class :inherit bold)))
- `(magit-reflog-merge ((,class :inherit success)))
- `(magit-reflog-other ((,class :inherit bold :foreground ,cyan)))
- `(magit-reflog-rebase ((,class :inherit bold :foreground ,magenta)))
- `(magit-reflog-remote ((,class :inherit bold :foreground ,magenta-alt-other)))
- `(magit-reflog-reset ((,class :inherit error)))
- `(magit-refname ((,class :inherit shadow)))
- `(magit-refname-pullreq ((,class :inherit shadow)))
- `(magit-refname-stash ((,class :inherit shadow)))
- `(magit-refname-wip ((,class :inherit shadow)))
- `(magit-section ((,class :background ,bg-dim :foreground ,fg-main)))
- `(magit-section-heading ((,class :inherit bold :foreground ,cyan)))
- `(magit-section-heading-selection ((,class :inherit (modus-themes-refine-cyan bold))))
- `(magit-section-highlight ((,class :background ,bg-alt)))
- `(magit-sequence-done ((,class :inherit success)))
- `(magit-sequence-drop ((,class :inherit error)))
- `(magit-sequence-exec ((,class :inherit bold :foreground ,magenta-alt)))
- `(magit-sequence-head ((,class :inherit bold :foreground ,cyan-alt)))
- `(magit-sequence-onto ((,class :inherit (bold shadow))))
- `(magit-sequence-part ((,class :inherit warning)))
- `(magit-sequence-pick ((,class :inherit bold)))
- `(magit-sequence-stop ((,class :inherit error)))
- `(magit-signature-bad ((,class :inherit error)))
- `(magit-signature-error ((,class :inherit error)))
- `(magit-signature-expired ((,class :inherit warning)))
- `(magit-signature-expired-key ((,class :foreground ,yellow)))
- `(magit-signature-good ((,class :inherit success)))
- `(magit-signature-revoked ((,class :inherit bold :foreground ,magenta)))
- `(magit-signature-untrusted ((,class :inherit (bold shadow))))
- `(magit-tag ((,class :foreground ,yellow-alt-other)))
-;;;;; magit-imerge
- `(magit-imerge-overriding-value ((,class :inherit bold :foreground ,red-alt)))
+ `(magit-bisect-bad ((,c :inherit error)))
+ `(magit-bisect-good ((,c :inherit success)))
+ `(magit-bisect-skip ((,c :inherit warning)))
+ `(magit-blame-date (( )))
+ `(magit-blame-dimmed ((,c :inherit shadow)))
+ `(magit-blame-hash (( )))
+ `(magit-blame-highlight ((,c :background ,bg-active :foreground ,fg-main)))
+ `(magit-blame-name (( )))
+ `(magit-blame-summary (( )))
+ `(magit-branch-local ((,c :foreground ,accent-0)))
+ `(magit-branch-remote ((,c :foreground ,accent-1)))
+ `(magit-branch-upstream ((,c :inherit italic)))
+ `(magit-branch-warning ((,c :inherit warning)))
+ `(magit-cherry-equivalent ((,c :foreground ,magenta)))
+ `(magit-cherry-unmatched ((,c :foreground ,cyan)))
+ `(magit-diff-added ((,c :background ,bg-added-faint :foreground ,fg-added)))
+ `(magit-diff-added-highlight ((,c :background ,bg-added :foreground ,fg-added)))
+ `(magit-diff-base ((,c :background ,bg-changed-faint :foreground ,fg-changed)))
+ `(magit-diff-base-highlight ((,c :background ,bg-changed :foreground ,fg-changed)))
+ `(magit-diff-context ((,c :inherit shadow)))
+ `(magit-diff-context-highlight ((,c :background ,bg-diff-context)))
+ `(magit-diff-file-heading ((,c :inherit bold :foreground ,accent-0)))
+ `(magit-diff-file-heading-highlight ((,c :inherit magit-diff-file-heading :background ,bg-inactive)))
+ `(magit-diff-file-heading-selection ((,c :inherit bold :background ,bg-hover-secondary)))
+ `(magit-diff-hunk-heading ((,c :background ,bg-inactive)))
+ `(magit-diff-hunk-heading-highlight ((,c :inherit bold :background ,bg-active)))
+ `(magit-diff-hunk-heading-selection ((,c :inherit bold :background ,bg-hover-secondary)))
+ `(magit-diff-hunk-region ((,c :inherit bold)))
+ `(magit-diff-lines-boundary ((,c :background ,fg-main)))
+ `(magit-diff-lines-heading ((,c :background ,fg-dim :foreground ,bg-main)))
+ `(magit-diff-removed ((,c :background ,bg-removed-faint :foreground ,fg-removed)))
+ `(magit-diff-removed-highlight ((,c :background ,bg-removed :foreground ,fg-removed)))
+ `(magit-diffstat-added ((,c :foreground ,fg-added-intense)))
+ `(magit-diffstat-removed ((,c :foreground ,fg-removed-intense)))
+ `(magit-dimmed ((,c :inherit shadow)))
+ `(magit-filename ((,c :foreground ,accent-2)))
+ `(magit-hash ((,c :foreground ,identifier)))
+ `(magit-head ((,c :inherit magit-branch-local)))
+ `(magit-header-line ((,c :inherit bold)))
+ `(magit-header-line-key ((,c :inherit modus-themes-key-binding)))
+ `(magit-header-line-log-select ((,c :inherit bold)))
+ `(magit-keyword ((,c :foreground ,keyword)))
+ `(magit-keyword-squash ((,c :inherit bold :foreground ,warning)))
+ `(magit-log-author ((,c :foreground ,name)))
+ `(magit-log-date ((,c :foreground ,date-common)))
+ `(magit-log-graph ((,c :inherit shadow)))
+ `(magit-mode-line-process ((,c :inherit bold :foreground ,modeline-info)))
+ `(magit-mode-line-process-error ((,c :inherit bold :foreground ,modeline-err)))
+ `(magit-process-ng ((,c :inherit error)))
+ `(magit-process-ok ((,c :inherit success)))
+ `(magit-reflog-amend ((,c :inherit warning)))
+ `(magit-reflog-checkout ((,c :inherit bold :foreground ,blue)))
+ `(magit-reflog-cherry-pick ((,c :inherit success)))
+ `(magit-reflog-commit ((,c :inherit bold)))
+ `(magit-reflog-merge ((,c :inherit success)))
+ `(magit-reflog-other ((,c :inherit bold :foreground ,cyan)))
+ `(magit-reflog-rebase ((,c :inherit bold :foreground ,magenta)))
+ `(magit-reflog-remote ((,c :inherit (bold magit-branch-remote))))
+ `(magit-reflog-reset ((,c :inherit error)))
+ `(magit-refname ((,c :inherit shadow)))
+ `(magit-refname-pullreq ((,c :inherit shadow)))
+ `(magit-refname-stash ((,c :inherit shadow)))
+ `(magit-refname-wip ((,c :inherit shadow)))
+ `(magit-section ((,c :background ,bg-dim :foreground ,fg-main)))
+ `(magit-section-heading ((,c :inherit bold)))
+ `(magit-section-heading-selection ((,c :inherit bold :background ,bg-hover-secondary)))
+ `(magit-section-highlight ((,c :background ,bg-dim)))
+ `(magit-sequence-done ((,c :inherit success)))
+ `(magit-sequence-drop ((,c :inherit error)))
+ `(magit-sequence-exec ((,c :inherit bold :foreground ,magenta)))
+ `(magit-sequence-head ((,c :inherit bold :foreground ,cyan)))
+ `(magit-sequence-onto ((,c :inherit (bold shadow))))
+ `(magit-sequence-part ((,c :inherit warning)))
+ `(magit-sequence-pick ((,c :inherit bold)))
+ `(magit-sequence-stop ((,c :inherit error)))
+ `(magit-signature-bad ((,c :inherit error)))
+ `(magit-signature-error ((,c :inherit error)))
+ `(magit-signature-expired ((,c :inherit warning)))
+ `(magit-signature-expired-key ((,c :foreground ,warning)))
+ `(magit-signature-good ((,c :inherit success)))
+ `(magit-signature-revoked ((,c :inherit bold :foreground ,warning)))
+ `(magit-signature-untrusted ((,c :inherit (bold shadow))))
+ `(magit-tag ((,c :foreground ,accent-3))) ; compare with branches
;;;;; make-mode (makefiles)
- `(makefile-makepp-perl ((,class :background ,cyan-nuanced-bg)))
- `(makefile-space ((,class :background ,magenta-nuanced-bg)))
+ `(makefile-makepp-perl ((,c :background ,bg-dim)))
+ `(makefile-space ((,c :background ,bg-inactive)))
;;;;; man
- `(Man-overstrike ((,class :inherit bold :foreground ,magenta-alt)))
- `(Man-reverse ((,class :inherit modus-themes-subtle-magenta)))
- `(Man-underline ((,class :foreground ,cyan-alt-other :underline t)))
+ `(Man-overstrike ((,c :inherit bold :foreground ,accent-0)))
+ `(Man-underline ((,c :foreground ,accent-1 :underline t)))
;;;;; marginalia
- `(marginalia-archive ((,class :foreground ,cyan-alt-other)))
- `(marginalia-char ((,class :foreground ,magenta)))
- `(marginalia-date ((,class :foreground ,cyan)))
- `(marginalia-documentation ((,class :inherit modus-themes-slant :foreground ,fg-docstring)))
- `(marginalia-file-name ((,class :foreground ,blue-faint)))
- `(marginalia-file-owner ((,class :foreground ,red-faint)))
- `(marginalia-file-priv-dir ((,class :foreground ,blue-alt)))
- `(marginalia-file-priv-exec ((,class :foreground ,magenta-alt)))
- `(marginalia-file-priv-link ((,class :foreground ,blue-alt-other)))
- `(marginalia-file-priv-no ((,class :foreground "gray50")))
- `(marginalia-file-priv-other ((,class :foreground ,yellow)))
- `(marginalia-file-priv-rare ((,class :foreground ,red)))
- `(marginalia-file-priv-read ((,class :foreground ,fg-main)))
- `(marginalia-file-priv-write ((,class :foreground ,cyan)))
- `(marginalia-function ((,class :foreground ,magenta-alt-faint)))
- `(marginalia-key ((,class :inherit modus-themes-key-binding)))
- `(marginalia-lighter ((,class :foreground ,blue-alt)))
- `(marginalia-list ((,class :foreground ,magenta-alt-other-faint)))
- `(marginalia-mode ((,class :foreground ,cyan)))
- `(marginalia-modified ((,class :foreground ,magenta-alt-faint)))
- `(marginalia-null ((,class :inherit shadow)))
- `(marginalia-number ((,class :foreground ,cyan)))
- `(marginalia-size ((,class :foreground ,cyan-alt-other-faint)))
- `(marginalia-string ((,class :foreground ,blue-alt)))
- `(marginalia-symbol ((,class :foreground ,blue-alt-other-faint)))
- `(marginalia-true ((,class :foreground ,fg-main)))
- `(marginalia-type ((,class :foreground ,cyan-alt-other)))
- `(marginalia-value ((,class :foreground ,cyan)))
- `(marginalia-version ((,class :foreground ,cyan)))
+ `(marginalia-archive ((,c :foreground ,accent-0)))
+ `(marginalia-char ((,c :foreground ,accent-2)))
+ `(marginalia-date ((,c :foreground ,date-common)))
+ `(marginalia-documentation ((,c :inherit modus-themes-slant :foreground ,docstring)))
+ `(marginalia-file-name (( )))
+ `(marginalia-file-owner ((,c :inherit shadow)))
+ `(marginalia-file-priv-dir ((,c :foreground ,accent-0)))
+ `(marginalia-file-priv-exec ((,c :foreground ,accent-1)))
+ `(marginalia-file-priv-link ((,c :foreground ,fg-link)))
+ `(marginalia-file-priv-no ((,c :inherit shadow)))
+ `(marginalia-file-priv-other ((,c :foreground ,accent-2)))
+ `(marginalia-file-priv-rare ((,c :foreground ,accent-3)))
+ `(marginalia-file-priv-read ((,c :foreground ,fg-main)))
+ `(marginalia-file-priv-write ((,c :foreground ,accent-0)))
+ `(marginalia-function ((,c :foreground ,fnname)))
+ `(marginalia-key ((,c :inherit modus-themes-key-binding)))
+ `(marginalia-lighter ((,c :inherit shadow)))
+ `(marginalia-liqst ((,c :inherit shadow)))
+ `(marginalia-mode ((,c :foreground ,constant)))
+ `(marginalia-modified ((,c :inherit warning)))
+ `(marginalia-null ((,c :inherit shadow)))
+ `(marginalia-number ((,c :foreground ,constant)))
+ `(marginalia-size ((,c :foreground ,variable)))
+ `(marginalia-string ((,c :foreground ,string)))
+ `(marginalia-symbol ((,c :foreground ,builtin)))
+ `(marginalia-true (( )))
+ `(marginalia-type ((,c :foreground ,type)))
+ `(marginalia-value ((,c :inherit shadow)))
+ `(marginalia-version ((,c :foreground ,date-common)))
;;;;; markdown-mode
- `(markdown-blockquote-face ((,class :inherit modus-themes-slant :foreground ,fg-special-cold)))
- `(markdown-bold-face ((,class :inherit bold)))
- `(markdown-code-face ((,class :inherit modus-themes-fixed-pitch :background ,bg-dim :extend t)))
- `(markdown-comment-face ((,class :inherit font-lock-comment-face)))
- `(markdown-footnote-marker-face ((,class :inherit bold :foreground ,cyan-alt)))
- `(markdown-footnote-text-face ((,class :inherit modus-themes-slant :foreground ,fg-main)))
- `(markdown-gfm-checkbox-face ((,class :foreground ,yellow-alt-other)))
- `(markdown-header-delimiter-face ((,class :inherit modus-themes-bold :foreground ,fg-dim)))
- `(markdown-header-face ((t nil)))
- `(markdown-header-face-1 ((,class :inherit modus-themes-heading-1)))
- `(markdown-header-face-2 ((,class :inherit modus-themes-heading-2)))
- `(markdown-header-face-3 ((,class :inherit modus-themes-heading-3)))
- `(markdown-header-face-4 ((,class :inherit modus-themes-heading-4)))
- `(markdown-header-face-5 ((,class :inherit modus-themes-heading-5)))
- `(markdown-header-face-6 ((,class :inherit modus-themes-heading-6)))
- `(markdown-header-rule-face ((,class :inherit bold :foreground ,fg-special-warm)))
- `(markdown-highlighting-face ((,class :inherit modus-themes-refine-yellow)))
- `(markdown-hr-face ((,class :inherit bold :foreground ,fg-special-warm)))
- `(markdown-html-attr-name-face ((,class :inherit modus-themes-fixed-pitch
- :foreground ,cyan)))
- `(markdown-html-attr-value-face ((,class :inherit modus-themes-fixed-pitch
- :foreground ,blue)))
- `(markdown-html-entity-face ((,class :inherit modus-themes-fixed-pitch
- :foreground ,cyan)))
- `(markdown-html-tag-delimiter-face ((,class :inherit modus-themes-fixed-pitch
- :foreground ,fg-special-mild)))
- `(markdown-html-tag-name-face ((,class :inherit modus-themes-fixed-pitch
- :foreground ,magenta-alt)))
- `(markdown-inline-code-face ((,class :inherit modus-themes-markup-verbatim)))
- `(markdown-italic-face ((,class :inherit italic)))
- `(markdown-language-info-face ((,class :inherit modus-themes-fixed-pitch
- :foreground ,fg-special-cold)))
- `(markdown-language-keyword-face ((,class :inherit modus-themes-fixed-pitch
- :background ,bg-alt
- :foreground ,fg-alt)))
- `(markdown-line-break-face ((,class :inherit modus-themes-refine-cyan :underline t)))
- `(markdown-link-face ((,class :inherit button)))
- `(markdown-link-title-face ((,class :inherit modus-themes-slant :foreground ,fg-special-cold)))
- `(markdown-list-face ((,class :foreground ,fg-dim)))
- `(markdown-markup-face ((,class :inherit shadow)))
- `(markdown-math-face ((,class :foreground ,magenta-alt-other)))
- `(markdown-metadata-key-face ((,class :foreground ,cyan-alt-other)))
- `(markdown-metadata-value-face ((,class :foreground ,blue-alt)))
- `(markdown-missing-link-face ((,class :inherit bold :foreground ,yellow)))
- `(markdown-plain-url-face ((,class :inherit markdown-link-face)))
- `(markdown-pre-face ((,class :inherit markdown-code-face :foreground ,fg-special-mild)))
- `(markdown-reference-face ((,class :inherit markdown-markup-face)))
- `(markdown-strike-through-face ((,class :strike-through t)))
- `(markdown-table-face ((,class :inherit modus-themes-fixed-pitch
- :foreground ,fg-special-cold)))
- `(markdown-url-face ((,class :foreground ,blue-alt)))
+ `(markdown-blockquote-face ((,c :inherit font-lock-doc-face)))
+ `(markdown-bold-face ((,c :inherit bold)))
+ `(markdown-code-face ((,c :inherit modus-themes-fixed-pitch :background ,bg-dim :extend t)))
+ `(markdown-gfm-checkbox-face ((,c :foreground ,warning)))
+ `(markdown-header-face (( )))
+ `(markdown-header-face-1 ((,c :inherit modus-themes-heading-1)))
+ `(markdown-header-face-2 ((,c :inherit modus-themes-heading-2)))
+ `(markdown-header-face-3 ((,c :inherit modus-themes-heading-3)))
+ `(markdown-header-face-4 ((,c :inherit modus-themes-heading-4)))
+ `(markdown-header-face-5 ((,c :inherit modus-themes-heading-5)))
+ `(markdown-header-face-6 ((,c :inherit modus-themes-heading-6)))
+ `(markdown-highlighting-face ((,c :inherit secondary-selection)))
+ `(markdown-inline-code-face ((,c :inherit modus-themes-prose-code)))
+ `(markdown-italic-face ((,c :inherit italic)))
+ `(markdown-language-keyword-face ((,c :inherit modus-themes-fixed-pitch :background ,bg-prose-block-delimiter :foreground ,fg-prose-block-delimiter)))
+ `(markdown-line-break-face ((,c :inherit nobreak-space)))
+ `(markdown-link-face ((,c :inherit link)))
+ `(markdown-markup-face ((,c :inherit shadow)))
+ `(markdown-metadata-key-face ((,c :inherit bold)))
+ `(markdown-metadata-value-face ((,c :foreground ,string)))
+ `(markdown-missing-link-face ((,c :inherit warning)))
+ `(markdown-pre-face ((,c :inherit markdown-code-face)))
+ `(markdown-table-face ((,c :inherit modus-themes-fixed-pitch :foreground ,prose-table)))
+ `(markdown-url-face ((,c :foreground ,fg-alt)))
;;;;; markup-faces (`adoc-mode')
- `(markup-attribute-face ((,class :inherit (italic markup-meta-face))))
- `(markup-bold-face ((,class :inherit bold :foreground ,red-nuanced-fg)))
- `(markup-code-face ((,class :foreground ,magenta)))
- `(markup-comment-face ((,class :inherit font-lock-comment-face)))
- `(markup-complex-replacement-face ((,class :background ,magenta-nuanced-bg :foreground ,magenta-alt-other)))
- `(markup-emphasis-face ((,class :inherit markup-italic-face)))
- `(markup-error-face ((,class :inherit error)))
- `(markup-gen-face ((,class :foreground ,magenta-alt)))
- `(markup-internal-reference-face ((,class :inherit modus-themes-slant :foreground ,fg-alt)))
- `(markup-italic-face ((,class :inherit italic)))
- `(markup-list-face ((,class :inherit modus-themes-special-cold)))
- `(markup-meta-face ((,class :inherit (modus-themes-fixed-pitch shadow))))
- `(markup-meta-hide-face ((,class :foreground "gray50")))
- `(markup-reference-face ((,class :inherit modus-themes-slant :foreground ,blue-alt)))
- `(markup-replacement-face ((,class :inherit modus-themes-fixed-pitch :foreground ,red-alt)))
- `(markup-secondary-text-face ((,class :height 0.9 :foreground ,cyan-alt-other)))
- `(markup-small-face ((,class :inherit markup-gen-face :height 0.9)))
- `(markup-strong-face ((,class :inherit markup-bold-face)))
- `(markup-subscript-face ((,class :height 0.9 :foreground ,magenta-alt-other)))
- `(markup-superscript-face ((,class :height 0.9 :foreground ,magenta-alt-other)))
- `(markup-table-cell-face ((,class :inherit modus-themes-subtle-neutral)))
- `(markup-table-face ((,class :inherit modus-themes-subtle-neutral)))
- `(markup-table-row-face ((,class :inherit modus-themes-special-cold)))
- `(markup-title-0-face ((,class :inherit modus-themes-heading-1)))
- `(markup-title-1-face ((,class :inherit modus-themes-heading-2)))
- `(markup-title-2-face ((,class :inherit modus-themes-heading-3)))
- `(markup-title-3-face ((,class :inherit modus-themes-heading-4)))
- `(markup-title-4-face ((,class :inherit modus-themes-heading-5)))
- `(markup-title-5-face ((,class :inherit modus-themes-heading-6)))
- `(markup-verbatim-face ((,class :inherit modus-themes-fixed-pitch :background ,bg-alt)))
-;;;;; mentor
- `(mentor-download-message ((,class :foreground ,fg-special-warm)))
- `(mentor-download-name ((,class :foreground ,fg-special-cold)))
- `(mentor-download-progress ((,class :foreground ,blue-alt-other)))
- `(mentor-download-size ((,class :foreground ,magenta-alt-other)))
- `(mentor-download-speed-down ((,class :foreground ,cyan-alt)))
- `(mentor-download-speed-up ((,class :foreground ,red-alt)))
- `(mentor-download-state ((,class :foreground ,yellow-alt)))
- `(mentor-highlight-face ((,class :inherit modus-themes-subtle-blue)))
- `(mentor-tracker-name ((,class :foreground ,magenta-alt)))
+ `(markup-attribute-face ((,c :inherit (modus-themes-slant markup-meta-face))))
+ `(markup-bold-face ((,c :inherit bold)))
+ `(markup-code-face ((,c :inherit modus-themes-prose-code)))
+ `(markup-comment-face ((,c :inherit font-lock-comment-face)))
+ `(markup-complex-replacement-face ((,c :inherit modus-themes-prose-macro)))
+ `(markup-emphasis-face ((,c :inherit markup-italic-face)))
+ `(markup-error-face ((,c :inherit error)))
+ `(markup-gen-face ((,c :inherit modus-themes-prose-verbatim)))
+ `(markup-internal-reference-face ((,c :inherit (shadow modus-themes-slant))))
+ `(markup-italic-face ((,c :inherit italic)))
+ `(markup-list-face ((,c :background ,bg-inactive)))
+ `(markup-meta-face ((,c :inherit (modus-themes-fixed-pitch shadow))))
+ `(markup-meta-hide-face ((,c :foreground "gray50")))
+ `(markup-reference-face ((,c :inherit modus-themes-slant :foreground ,fg-alt)))
+ `(markup-replacement-face ((,c :inherit modus-themes-fixed-pitch :foreground ,err)))
+ `(markup-secondary-text-face ((,c :height 0.9 :foreground ,fg-alt)))
+ `(markup-small-face ((,c :inherit markup-gen-face :height 0.9)))
+ `(markup-strong-face ((,c :inherit markup-bold-face)))
+ `(markup-subscript-face ((,c :height 0.9 :foreground ,fg-alt)))
+ `(markup-superscript-face ((,c :height 0.9 :foreground ,fg-alt)))
+ `(markup-table-cell-face (( )))
+ `(markup-table-face ((,c :foreground ,prose-table)))
+ `(markup-table-row-face (( )))
+ `(markup-title-0-face ((,c :inherit modus-themes-heading-1)))
+ `(markup-title-1-face ((,c :inherit modus-themes-heading-2)))
+ `(markup-title-2-face ((,c :inherit modus-themes-heading-3)))
+ `(markup-title-3-face ((,c :inherit modus-themes-heading-4)))
+ `(markup-title-4-face ((,c :inherit modus-themes-heading-5)))
+ `(markup-title-5-face ((,c :inherit modus-themes-heading-6)))
+ `(markup-verbatim-face ((,c :inherit modus-themes-prose-verbatim)))
+;;;;; mct
+ `(mct-highlight-candidate ((,c :inherit modus-themes-completion-selected)))
;;;;; messages
- `(message-cited-text-1 ((,class ,@(modus-themes--mail-cite blue-faint blue fg-special-cold))))
- `(message-cited-text-2 ((,class ,@(modus-themes--mail-cite yellow-faint yellow yellow-alt-faint))))
- `(message-cited-text-3 ((,class ,@(modus-themes--mail-cite magenta-alt-faint magenta-alt fg-special-calm))))
- `(message-cited-text-4 ((,class ,@(modus-themes--mail-cite cyan-alt-other-faint cyan-alt-other fg-special-mild))))
- `(message-header-cc ((,class :foreground ,blue-alt-other)))
- `(message-header-name ((,class :inherit bold :foreground ,cyan)))
- `(message-header-newsgroups ((,class :inherit message-header-other)))
- `(message-header-other ((,class :foreground ,fg-special-calm)))
- `(message-header-subject ((,class :inherit bold :foreground ,magenta-alt)))
- `(message-header-to ((,class :inherit bold :foreground ,magenta-alt-other)))
- `(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)))
+ `(message-cited-text-1 ((,c :foreground ,mail-cite-0)))
+ `(message-cited-text-2 ((,c :foreground ,mail-cite-1)))
+ `(message-cited-text-3 ((,c :foreground ,mail-cite-2)))
+ `(message-cited-text-4 ((,c :foreground ,mail-cite-3)))
+ `(message-header-name ((,c :inherit bold)))
+ `(message-header-newsgroups ((,c :inherit message-header-other)))
+ `(message-header-to ((,c :inherit bold :foreground ,mail-recipient)))
+ `(message-header-cc ((,c :foreground ,mail-recipient)))
+ `(message-header-subject ((,c :inherit bold :foreground ,mail-subject)))
+ `(message-header-xheader ((,c :inherit message-header-other)))
+ `(message-header-other ((,c :foreground ,mail-other)))
+ `(message-mml ((,c :foreground ,mail-part)))
+ `(message-separator ((,c :background ,bg-inactive :foreground ,fg-main)))
;;;;; minimap
- `(minimap-active-region-background ((,class :background ,bg-active)))
- `(minimap-current-line-face ((,class :background ,cyan-intense-bg :foreground ,fg-main)))
-;;;;; mmm-mode
- `(mmm-cleanup-submode-face ((,class :background ,yellow-nuanced-bg)))
- `(mmm-code-submode-face ((,class :background ,bg-alt)))
- `(mmm-comment-submode-face ((,class :background ,blue-nuanced-bg)))
- `(mmm-declaration-submode-face ((,class :background ,cyan-nuanced-bg)))
- `(mmm-default-submode-face ((,class :background ,bg-dim)))
- `(mmm-init-submode-face ((,class :background ,magenta-nuanced-bg)))
- `(mmm-output-submode-face ((,class :background ,red-nuanced-bg)))
- `(mmm-special-submode-face ((,class :background ,green-nuanced-bg)))
+ `(minimap-active-region-background ((,c :background ,bg-active)))
+ `(minimap-current-line-face ((,c :background ,bg-cyan-intense :foreground ,fg-main)))
;;;;; mode-line
- `(mode-line ((,class :inherit modus-themes-ui-variable-pitch
- ,@(modus-themes--mode-line-attrs
- fg-active bg-active
- fg-dim bg-active
- fg-main bg-active-accent
- fg-alt bg-active
- 'alt-style bg-main))))
- `(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 ,@(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
- fg-alt bg-dim
- fg-inactive bg-inactive
- bg-region bg-active))))
+ `(mode-line ((,c :inherit modus-themes-ui-variable-pitch
+ :box ,border-mode-line-active
+ :background ,bg-mode-line-active
+ :foreground ,fg-mode-line-active)))
+ `(mode-line-active ((,c :inherit mode-line)))
+ `(mode-line-buffer-id ((,c :inherit bold)))
+ `(mode-line-emphasis ((,c :inherit bold :foreground ,modeline-info)))
+ `(mode-line-highlight ((,c :background ,bg-hover :foreground ,fg-main :box ,fg-main)))
+ `(mode-line-inactive ((,c :inherit modus-themes-ui-variable-pitch
+ :box ,border-mode-line-inactive
+ :background ,bg-mode-line-inactive
+ :foreground ,fg-mode-line-inactive)))
;;;;; mood-line
- `(mood-line-modified ((,class :foreground ,magenta-active)))
- `(mood-line-status-error ((,class :inherit bold :foreground ,red-active)))
- `(mood-line-status-info ((,class :foreground ,cyan-active)))
- `(mood-line-status-neutral ((,class :foreground ,blue-active)))
- `(mood-line-status-success ((,class :inherit modus-themes-grue-active)))
- `(mood-line-status-warning ((,class :inherit bold :foreground ,yellow-active)))
- `(mood-line-unimportant ((,class :foreground ,fg-inactive)))
+ `(mood-line-modified ((,c :inherit italic)))
+ `(mood-line-status-error ((,c :inherit error)))
+ `(mood-line-status-info ((,c :foreground ,info)))
+ `(mood-line-status-neutral (( )))
+ `(mood-line-status-success ((,c :inherit success)))
+ `(mood-line-status-warning ((,c :inherit warning)))
+ `(mood-line-unimportant ((,c :inherit shadow)))
;;;;; mpdel
- `(mpdel-browser-directory-face ((,class :foreground ,blue)))
- `(mpdel-playlist-current-song-face ((,class :inherit bold :foreground ,blue-alt-other)))
+ `(mpdel-browser-directory-face ((,c :foreground ,accent-0)))
+ `(mpdel-playlist-current-song-face ((,c :inherit bold :foreground ,accent-0)))
;;;;; mu4e
- `(mu4e-attach-number-face ((,class :inherit bold :foreground ,fg-dim)))
- `(mu4e-cited-1-face ((,class :inherit message-cited-text-1)))
- `(mu4e-cited-2-face ((,class :inherit message-cited-text-2)))
- `(mu4e-cited-3-face ((,class :inherit message-cited-text-3)))
- `(mu4e-cited-4-face ((,class :inherit message-cited-text-4)))
- `(mu4e-cited-5-face ((,class :inherit message-cited-text-1)))
- `(mu4e-cited-6-face ((,class :inherit message-cited-text-2)))
- `(mu4e-cited-7-face ((,class :inherit message-cited-text-3)))
- `(mu4e-compose-header-face ((,class :inherit mu4e-compose-separator-face)))
- `(mu4e-compose-separator-face ((,class :inherit modus-themes-intense-neutral)))
- `(mu4e-contact-face ((,class :inherit message-header-to)))
- `(mu4e-context-face ((,class :foreground ,blue-active)))
- `(mu4e-draft-face ((,class :foreground ,magenta-alt)))
- `(mu4e-flagged-face ((,class :foreground ,red-alt-other)))
- `(mu4e-footer-face ((,class :inherit modus-themes-slant :foreground ,fg-special-cold)))
- `(mu4e-forwarded-face ((,class :foreground ,magenta-alt-other)))
- `(mu4e-header-face ((,class :inherit shadow)))
- `(mu4e-header-highlight-face ((,class :inherit modus-themes-hl-line)))
- `(mu4e-header-key-face ((,class :inherit message-header-name)))
- `(mu4e-header-marks-face ((,class :inherit mu4e-special-header-value-face)))
- `(mu4e-header-title-face ((,class :foreground ,fg-special-mild)))
- `(mu4e-header-value-face ((,class :inherit message-header-other)))
- `(mu4e-highlight-face ((,class :inherit modus-themes-key-binding)))
- `(mu4e-link-face ((,class :inherit button)))
- `(mu4e-modeline-face ((,class :foreground ,magenta-active)))
- `(mu4e-moved-face ((,class :inherit modus-themes-slant :foreground ,yellow)))
- `(mu4e-ok-face ((,class :inherit bold :foreground ,green)))
- `(mu4e-region-code ((,class :inherit modus-themes-special-calm)))
- `(mu4e-related-face ((,class :inherit (italic shadow))))
- `(mu4e-replied-face ((,class :foreground ,blue)))
- `(mu4e-special-header-value-face ((,class :inherit message-header-subject)))
- `(mu4e-system-face ((,class :inherit modus-themes-slant :foreground ,fg-mark-del)))
- `(mu4e-title-face ((,class :foreground ,fg-main)))
- `(mu4e-trashed-face ((,class :foreground ,red)))
- `(mu4e-unread-face ((,class :inherit bold)))
- `(mu4e-url-number-face ((,class :inherit shadow)))
- `(mu4e-view-body-face ((,class :foreground ,fg-main)))
- `(mu4e-warning-face ((,class :inherit warning)))
+ `(mu4e-attach-number-face ((,c :inherit bold :foreground ,fg-dim)))
+ `(mu4e-cited-1-face ((,c :inherit message-cited-text-1)))
+ `(mu4e-cited-2-face ((,c :inherit message-cited-text-2)))
+ `(mu4e-cited-3-face ((,c :inherit message-cited-text-3)))
+ `(mu4e-cited-4-face ((,c :inherit message-cited-text-4)))
+ `(mu4e-cited-5-face ((,c :inherit message-cited-text-1)))
+ `(mu4e-cited-6-face ((,c :inherit message-cited-text-2)))
+ `(mu4e-cited-7-face ((,c :inherit message-cited-text-3)))
+ `(mu4e-compose-header-face ((,c :inherit mu4e-compose-separator-face)))
+ `(mu4e-compose-separator-face ((,c :inherit message-separator)))
+ `(mu4e-contact-face ((,c :inherit message-header-to)))
+ `(mu4e-context-face ((,c :inherit bold)))
+ `(mu4e-draft-face ((,c :foreground ,warning)))
+ `(mu4e-flagged-face ((,c :foreground ,keyword)))
+ `(mu4e-footer-face ((,c :inherit italic :foreground ,fg-alt)))
+ `(mu4e-forwarded-face ((,c :inherit italic :foreground ,info)))
+ `(mu4e-header-face ((,c :inherit shadow)))
+ `(mu4e-header-highlight-face ((,c :background ,bg-hl-line :extend t)))
+ `(mu4e-header-key-face ((,c :inherit message-header-name)))
+ `(mu4e-header-marks-face ((,c :inherit mu4e-special-header-value-face)))
+ `(mu4e-header-title-face ((,c :foreground ,fg-alt)))
+ `(mu4e-header-value-face ((,c :inherit message-header-other)))
+ `(mu4e-highlight-face ((,c :inherit modus-themes-key-binding)))
+ `(mu4e-link-face ((,c :inherit link)))
+ `(mu4e-modeline-face (( )))
+ `(mu4e-moved-face ((,c :inherit italic :foreground ,warning)))
+ `(mu4e-ok-face ((,c :inherit success)))
+ `(mu4e-region-code ((,c :foreground ,builtin)))
+ `(mu4e-related-face ((,c :inherit (italic shadow))))
+ `(mu4e-replied-face ((,c :foreground ,info)))
+ `(mu4e-special-header-value-face ((,c :inherit message-header-subject)))
+ `(mu4e-system-face ((,c :inherit italic)))
+ `(mu4e-thread-fold-face ((,c :foreground ,border)))
+ `(mu4e-title-face (( )))
+ `(mu4e-trashed-face ((,c :foreground ,err)))
+ `(mu4e-unread-face ((,c :inherit bold)))
+ `(mu4e-url-number-face ((,c :inherit shadow)))
+ `(mu4e-view-body-face (( )))
+ `(mu4e-warning-face ((,c :inherit warning)))
;;;;; multiple-cursors
- `(mc/cursor-bar-face ((,class :height 1 :background ,fg-main)))
- `(mc/cursor-face ((,class :inverse-video t)))
- `(mc/region-face ((,class :inherit region)))
-;;;;; nano-modeline
- `(nano-modeline-active-primary ((,class :inherit mode-line :foreground ,fg-special-mild)))
- `(nano-modeline-active-secondary ((,class :inherit mode-line :foreground ,fg-special-cold)))
- `(nano-modeline-active-status-** ((,class :inherit mode-line :background ,yellow-subtle-bg)))
- `(nano-modeline-active-status-RO ((,class :inherit mode-line :background ,red-subtle-bg)))
- `(nano-modeline-active-status-RW ((,class :inherit mode-line :background ,cyan-subtle-bg)))
- `(nano-modeline-inactive-primary ((,class :inherit mode-line-inactive :foreground ,fg-inactive)))
- `(nano-modeline-inactive-secondary ((,class :inherit mode-line-inactive :foreground ,fg-inactive)))
- `(nano-modeline-inactive-status-** ((,class :inherit mode-line-inactive :foreground ,yellow-active)))
- `(nano-modeline-inactive-status-RO ((,class :inherit mode-line-inactive :foreground ,red-active)))
- `(nano-modeline-inactive-status-RW ((,class :inherit mode-line-inactive :foreground ,cyan-active)))
+ `(mc/cursor-bar-face ((,c :height 1 :foreground ,fg-main :background ,bg-main)))
+ `(mc/cursor-face ((,c :inverse-video t)))
+ `(mc/region-face ((,c :inherit region)))
+;;;;; nerd-icons
+ `(nerd-icons-blue ((,c :foreground ,blue-cooler)))
+ `(nerd-icons-blue-alt ((,c :foreground ,blue-warmer)))
+ `(nerd-icons-cyan ((,c :foreground ,cyan)))
+ `(nerd-icons-cyan-alt ((,c :foreground ,cyan-warmer)))
+ `(nerd-icons-dblue ((,c :foreground ,blue-faint)))
+ `(nerd-icons-dcyan ((,c :foreground ,cyan-faint)))
+ `(nerd-icons-dgreen ((,c :foreground ,green-faint)))
+ `(nerd-icons-dmaroon ((,c :foreground ,magenta-faint)))
+ `(nerd-icons-dorange ((,c :foreground ,red-faint)))
+ `(nerd-icons-dpink ((,c :foreground ,magenta-faint)))
+ `(nerd-icons-dpurple ((,c :foreground ,magenta-cooler)))
+ `(nerd-icons-dred ((,c :foreground ,red)))
+ `(nerd-icons-dsilver ((,c :foreground ,cyan-faint)))
+ `(nerd-icons-dyellow ((,c :foreground ,yellow-faint)))
+ `(nerd-icons-green ((,c :foreground ,green)))
+ `(nerd-icons-lblue ((,c :foreground ,blue-cooler)))
+ `(nerd-icons-lcyan ((,c :foreground ,cyan)))
+ `(nerd-icons-lgreen ((,c :foreground ,green-warmer)))
+ `(nerd-icons-lmaroon ((,c :foreground ,magenta-warmer)))
+ `(nerd-icons-lorange ((,c :foreground ,red-warmer)))
+ `(nerd-icons-lpink ((,c :foreground ,magenta)))
+ `(nerd-icons-lpurple ((,c :foreground ,magenta-faint)))
+ `(nerd-icons-lred ((,c :foreground ,red-faint)))
+ `(nerd-icons-lsilver ((,c :foreground "gray50")))
+ `(nerd-icons-lyellow ((,c :foreground ,yellow-warmer)))
+ `(nerd-icons-maroon ((,c :foreground ,magenta)))
+ `(nerd-icons-orange ((,c :foreground ,yellow-warmer)))
+ `(nerd-icons-pink ((,c :foreground ,magenta-warmer)))
+ `(nerd-icons-purple ((,c :foreground ,magenta-cooler)))
+ `(nerd-icons-purple-alt ((,c :foreground ,blue-warmer)))
+ `(nerd-icons-red ((,c :foreground ,red)))
+ `(nerd-icons-red-alt ((,c :foreground ,red-cooler)))
+ `(nerd-icons-silver ((,c :foreground "gray50")))
+ `(nerd-icons-yellow ((,c :foreground ,yellow)))
+;;;;; nerd-icons-completion
+ `(nerd-icons-completion-dir-face ((,c :foreground ,cyan-faint)))
+;;;;; nerd-icons-dired
+ `(nerd-icons-dired-dir-face ((,c :foreground ,cyan-faint)))
+;;;;; nerd-icons-ibuffer
+ `(nerd-icons-ibuffer-dir-face ((,c :foreground ,cyan-faint)))
+ `(nerd-icons-ibuffer-file-face ((,c :foreground ,blue-faint)))
+ `(nerd-icons-ibuffer-mode-face ((,c :foreground ,cyan)))
+ `(nerd-icons-ibuffer-size-face ((,c :foreground ,cyan-cooler)))
;;;;; neotree
- `(neo-banner-face ((,class :foreground ,magenta)))
- `(neo-button-face ((,class :inherit button)))
- `(neo-dir-link-face ((,class :inherit bold :foreground ,blue)))
- `(neo-expand-btn-face ((,class :foreground ,cyan)))
- `(neo-file-link-face ((,class :foreground ,fg-main)))
- `(neo-header-face ((,class :inherit bold :foreground ,fg-main)))
- `(neo-root-dir-face ((,class :inherit bold :foreground ,cyan-alt)))
- `(neo-vc-added-face ((,class :inherit modus-themes-grue)))
- `(neo-vc-conflict-face ((,class :inherit error)))
- `(neo-vc-default-face ((,class :foreground ,fg-main)))
- `(neo-vc-edited-face ((,class :foreground ,yellow)))
- `(neo-vc-ignored-face ((,class :foreground ,fg-inactive)))
- `(neo-vc-missing-face ((,class :foreground ,red-alt)))
- `(neo-vc-needs-merge-face ((,class :foreground ,magenta-alt)))
- `(neo-vc-needs-update-face ((,class :underline t)))
- `(neo-vc-removed-face ((,class :strike-through t)))
- `(neo-vc-unlocked-changes-face ((,class :inherit modus-themes-refine-blue)))
- `(neo-vc-up-to-date-face ((,class :inherit shadow)))
- `(neo-vc-user-face ((,class :foreground ,magenta)))
+ `(neo-banner-face ((,c :foreground ,accent-0)))
+ `(neo-button-face ((,c :inherit button)))
+ `(neo-dir-link-face (( )))
+ `(neo-expand-btn-face (( )))
+ `(neo-file-link-face (( )))
+ `(neo-header-face ((,c :inherit bold)))
+ `(neo-root-dir-face ((,c :inherit bold :foreground ,accent-0)))
+ `(neo-vc-added-face ((,c :inherit success)))
+ `(neo-vc-conflict-face ((,c :inherit error)))
+ `(neo-vc-default-face (( )))
+ `(neo-vc-edited-face ((,c :inherit italic)))
+ `(neo-vc-ignored-face ((,c :inherit shadow)))
+ `(neo-vc-missing-face ((,c :inherit error)))
+ `(neo-vc-needs-merge-face ((,c :inherit italic)))
+ `(neo-vc-needs-update-face ((,c :underline t)))
+ `(neo-vc-removed-face ((,c :strike-through t)))
+ `(neo-vc-unlocked-changes-face ((,c :inherit success)))
+ `(neo-vc-up-to-date-face (( )))
+ `(neo-vc-user-face ((,c :inherit warning)))
;;;;; notmuch
- `(notmuch-crypto-decryption ((,class :inherit (shadow bold))))
- `(notmuch-crypto-part-header ((,class :foreground ,magenta-alt-other)))
- `(notmuch-crypto-signature-bad ((,class :inherit error)))
- `(notmuch-crypto-signature-good ((,class :inherit success)))
- `(notmuch-crypto-signature-good-key ((,class :inherit bold :foreground ,cyan)))
- `(notmuch-crypto-signature-unknown ((,class :inherit warning)))
- `(notmuch-hello-logo-background ((,class :background "gray50")))
- `(notmuch-jump-key ((,class :inherit modus-themes-key-binding)))
- `(notmuch-message-summary-face ((,class :inherit (bold modus-themes-nuanced-cyan))))
- `(notmuch-search-count ((,class :inherit shadow)))
- `(notmuch-search-date ((,class :foreground ,cyan)))
- `(notmuch-search-flagged-face ((,class :foreground ,red-alt-other)))
- `(notmuch-search-matching-authors ((,class :foreground ,fg-special-cold)))
- `(notmuch-search-non-matching-authors ((,class :inherit shadow)))
- `(notmuch-search-subject ((,class :foreground ,fg-main)))
- `(notmuch-search-unread-face ((,class :inherit bold)))
- `(notmuch-tag-added ((,class :underline ,blue)))
- `(notmuch-tag-deleted ((,class :strike-through ,red)))
- `(notmuch-tag-face ((,class :foreground ,blue)))
- `(notmuch-tag-flagged ((,class :foreground ,red-alt)))
- `(notmuch-tag-unread ((,class :foreground ,magenta-alt)))
- `(notmuch-tree-match-author-face ((,class :inherit notmuch-search-matching-authors)))
- `(notmuch-tree-match-date-face ((,class :inherit notmuch-search-date)))
- `(notmuch-tree-match-face ((,class :foreground ,fg-main)))
- `(notmuch-tree-match-tag-face ((,class :inherit notmuch-tag-face)))
- `(notmuch-tree-no-match-face ((,class :inherit shadow)))
- `(notmuch-tree-no-match-date-face ((,class :inherit shadow)))
- `(notmuch-wash-cited-text ((,class :inherit message-cited-text-1)))
- `(notmuch-wash-toggle-button ((,class :background ,bg-alt :foreground ,fg-alt)))
+ `(notmuch-crypto-decryption ((,c :inherit bold)))
+ `(notmuch-crypto-part-header ((,c :foreground ,mail-part))) ; like `message-mml'
+ `(notmuch-crypto-signature-bad ((,c :inherit error)))
+ `(notmuch-crypto-signature-good ((,c :inherit success)))
+ `(notmuch-crypto-signature-good-key ((,c :inherit success)))
+ `(notmuch-crypto-signature-unknown ((,c :inherit warning)))
+ `(notmuch-jump-key ((,c :inherit modus-themes-key-binding)))
+ `(notmuch-message-summary-face ((,c :inherit bold :background ,bg-inactive)))
+ `(notmuch-search-count ((,c :foreground ,fg-dim)))
+ `(notmuch-search-date ((,c :foreground ,date-common)))
+ `(notmuch-search-flagged-face ((,c :foreground ,keyword)))
+ `(notmuch-search-matching-authors ((,c :foreground ,mail-recipient)))
+ `(notmuch-search-non-matching-authors ((,c :inherit shadow)))
+ `(notmuch-search-subject ((,c :foreground ,fg-main)))
+ `(notmuch-search-unread-face ((,c :inherit bold)))
+ `(notmuch-tag-added ((,c :underline ,info)))
+ `(notmuch-tag-deleted ((,c :strike-through ,err)))
+ `(notmuch-tag-face ((,c :foreground ,accent-0)))
+ `(notmuch-tag-flagged ((,c :foreground ,keyword)))
+ `(notmuch-tag-unread ((,c :foreground ,accent-1)))
+ `(notmuch-tree-match-author-face ((,c :inherit notmuch-search-matching-authors)))
+ `(notmuch-tree-match-date-face ((,c :inherit notmuch-search-date)))
+ `(notmuch-tree-match-face ((,c :foreground ,fg-main)))
+ `(notmuch-tree-match-tag-face ((,c :inherit notmuch-tag-face)))
+ `(notmuch-tree-no-match-face ((,c :inherit shadow)))
+ `(notmuch-tree-no-match-date-face ((,c :inherit shadow)))
+ `(notmuch-wash-cited-text ((,c :inherit message-cited-text-1)))
+ `(notmuch-wash-toggle-button ((,c :background ,bg-dim)))
;;;;; num3-mode
- `(num3-face-even ((,class :inherit bold :background ,bg-alt)))
+ `(num3-face-even ((,c :inherit bold :background ,bg-inactive)))
;;;;; nxml-mode
- `(nxml-attribute-colon ((,class :foreground ,fg-main)))
- `(nxml-attribute-local-name ((,class :inherit font-lock-variable-name-face)))
- `(nxml-attribute-prefix ((,class :inherit font-lock-type-face)))
- `(nxml-attribute-value ((,class :inherit font-lock-constant-face)))
- `(nxml-cdata-section-CDATA ((,class :inherit error)))
- `(nxml-cdata-section-delimiter ((,class :inherit error)))
- `(nxml-char-ref-delimiter ((,class :foreground ,fg-special-mild)))
- `(nxml-char-ref-number ((,class :inherit modus-themes-bold :foreground ,fg-special-mild)))
- `(nxml-delimited-data ((,class :inherit modus-themes-slant :foreground ,fg-special-cold)))
- `(nxml-delimiter ((,class :foreground ,fg-dim)))
- `(nxml-element-colon ((,class :foreground ,fg-main)))
- `(nxml-element-local-name ((,class :inherit font-lock-function-name-face)))
- `(nxml-element-prefix ((,class :inherit font-lock-builtin-face)))
- `(nxml-entity-ref-delimiter ((,class :foreground ,fg-special-mild)))
- `(nxml-entity-ref-name ((,class :inherit modus-themes-bold :foreground ,fg-special-mild)))
- `(nxml-glyph ((,class :inherit modus-themes-intense-neutral)))
- `(nxml-hash ((,class :inherit (bold font-lock-string-face))))
- `(nxml-heading ((,class :inherit bold)))
- `(nxml-name ((,class :inherit font-lock-builtin-face)))
- `(nxml-namespace-attribute-colon ((,class :foreground ,fg-main)))
- `(nxml-namespace-attribute-prefix ((,class :inherit font-lock-variable-name-face)))
- `(nxml-processing-instruction-target ((,class :inherit font-lock-keyword-face)))
- `(nxml-prolog-keyword ((,class :inherit font-lock-keyword-face)))
- `(nxml-ref ((,class :inherit modus-themes-bold :foreground ,fg-special-mild)))
- `(rng-error ((,class :inherit error)))
+ `(nxml-attribute-colon ((,c :foreground ,fg-main)))
+ `(nxml-attribute-local-name ((,c :inherit font-lock-variable-name-face)))
+ `(nxml-attribute-prefix ((,c :inherit font-lock-type-face)))
+ `(nxml-attribute-value ((,c :inherit font-lock-constant-face)))
+ `(nxml-cdata-section-CDATA ((,c :inherit error)))
+ `(nxml-cdata-section-delimiter ((,c :inherit error)))
+ `(nxml-char-ref-delimiter ((,c :inherit shadow)))
+ `(nxml-char-ref-number ((,c :inherit (shadow modus-themes-bold))))
+ `(nxml-delimited-data ((,c :inherit (shadow modus-themes-slant))))
+ `(nxml-delimiter ((,c :foreground ,fg-dim)))
+ `(nxml-element-colon ((,c :foreground ,fg-main)))
+ `(nxml-element-local-name ((,c :inherit font-lock-function-name-face)))
+ `(nxml-element-prefix ((,c :inherit font-lock-builtin-face)))
+ `(nxml-entity-ref-delimiter ((,c :inherit shadow)))
+ `(nxml-entity-ref-name ((,c :inherit (shadow modus-themes-bold))))
+ `(nxml-glyph ((,c :background ,bg-active :foreground ,fg-main)))
+ `(nxml-hash ((,c :inherit (bold font-lock-string-face))))
+ `(nxml-heading ((,c :inherit bold)))
+ `(nxml-name ((,c :inherit font-lock-builtin-face)))
+ `(nxml-namespace-attribute-colon ((,c :foreground ,fg-main)))
+ `(nxml-namespace-attribute-prefix ((,c :inherit font-lock-variable-name-face)))
+ `(nxml-processing-instruction-target ((,c :inherit font-lock-keyword-face)))
+ `(nxml-prolog-keyword ((,c :inherit font-lock-keyword-face)))
+ `(nxml-ref ((,c :inherit (shadow modus-themes-bold))))
+ `(rng-error ((,c :inherit error)))
;;;;; olivetti
- `(olivetti-fringe ((,class :background ,bg-main)))
+ `(olivetti-fringe ((,c :background ,fringe)))
;;;;; orderless
- `(orderless-match-face-0 ((,class :inherit modus-themes-completion-match-0)))
- `(orderless-match-face-1 ((,class :inherit modus-themes-completion-match-1)))
- `(orderless-match-face-2 ((,class :inherit modus-themes-completion-match-2)))
- `(orderless-match-face-3 ((,class :inherit modus-themes-completion-match-3)))
+ `(orderless-match-face-0 ((,c :inherit modus-themes-completion-match-0)))
+ `(orderless-match-face-1 ((,c :inherit modus-themes-completion-match-1)))
+ `(orderless-match-face-2 ((,c :inherit modus-themes-completion-match-2)))
+ `(orderless-match-face-3 ((,c :inherit modus-themes-completion-match-3)))
;;;;; 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 :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))))
- `(org-agenda-date-today
- ((,class ,@(modus-themes--agenda-date cyan fg-main nil nil bg-special-cold t t))))
- `(org-agenda-date-weekend
- ((,class ,@(modus-themes--agenda-date cyan-alt-other-faint fg-alt cyan fg-main))))
- `(org-agenda-date-weekend-today
- ((,class ,@(modus-themes--agenda-date cyan-alt-other-faint fg-alt cyan fg-main bg-special-cold t t))))
- `(org-agenda-diary ((,class :inherit org-agenda-calendar-sexp)))
- `(org-agenda-dimmed-todo-face ((,class :inherit shadow)))
- `(org-agenda-done ((,class :inherit modus-themes-grue-nuanced)))
- `(org-agenda-filter-category ((,class :inherit bold :foreground ,cyan-active)))
- `(org-agenda-filter-effort ((,class :inherit bold :foreground ,cyan-active)))
- `(org-agenda-filter-regexp ((,class :inherit bold :foreground ,cyan-active)))
- `(org-agenda-filter-tags ((,class :inherit bold :foreground ,cyan-active)))
- `(org-agenda-restriction-lock ((,class :background ,bg-dim :foreground ,fg-dim)))
- `(org-agenda-structure ((,class ,@(modus-themes--agenda-structure blue-alt))))
- `(org-agenda-structure-filter ((,class :inherit org-agenda-structure :foreground ,yellow)))
- `(org-agenda-structure-secondary ((,class :foreground ,cyan)))
- `(org-archived ((,class :background ,bg-alt :foreground ,fg-alt)))
- `(org-block ((,class :inherit modus-themes-fixed-pitch
- ,@(modus-themes--org-block bg-dim fg-main))))
- `(org-block-begin-line ((,class :inherit modus-themes-fixed-pitch
- ,@(modus-themes--org-block-delim
- bg-dim fg-special-cold
- bg-alt fg-alt))))
- `(org-block-end-line ((,class :inherit org-block-begin-line)))
- `(org-checkbox ((,class :foreground ,yellow-alt-other)))
- `(org-checkbox-statistics-done ((,class :inherit org-done)))
- `(org-checkbox-statistics-todo ((,class :inherit org-todo)))
- `(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)))
- `(org-column-title ((,class :inherit (bold modus-themes-fixed-pitch default)
- :underline t :background ,bg-alt)))
- `(org-date ((,class :inherit (modus-themes-link-symlink modus-themes-fixed-pitch))))
- `(org-date-selected ((,class :foreground ,blue-alt :inverse-video t)))
- `(org-dispatcher-highlight ((,class :inherit (bold modus-themes-mark-alt))))
- `(org-document-info ((,class :foreground ,fg-special-cold)))
- `(org-document-info-keyword ((,class :inherit (shadow modus-themes-fixed-pitch))))
- `(org-document-title ((,class :inherit modus-themes-heading-0)))
- `(org-done ((,class :inherit modus-themes-grue)))
- `(org-drawer ((,class :inherit (shadow modus-themes-fixed-pitch))))
- `(org-ellipsis (())) ; inherits from the heading's color
- `(org-footnote ((,class :inherit button
- ,@(modus-themes--link-color
- blue-alt blue-alt-faint))))
- `(org-formula ((,class :inherit modus-themes-fixed-pitch :foreground ,red-alt)))
- `(org-habit-alert-face ((,class ,@(modus-themes--agenda-habit
- yellow-graph-0-bg
- yellow-graph-0-bg
- yellow-graph-1-bg)
- :foreground "black"))) ; special case
- `(org-habit-alert-future-face ((,class ,@(modus-themes--agenda-habit
- yellow-graph-1-bg
- yellow-graph-0-bg
- yellow-graph-1-bg))))
- `(org-habit-clear-face ((,class ,@(modus-themes--agenda-habit
- blue-graph-0-bg
- green-graph-1-bg
- blue-graph-1-bg
- blue-graph-1-bg
- blue-graph-1-bg)
- :foreground "black"))) ; special case
- `(org-habit-clear-future-face ((,class ,@(modus-themes--agenda-habit
- blue-graph-1-bg
- green-graph-1-bg
- blue-graph-1-bg
- blue-graph-1-bg
- blue-graph-1-bg))))
- `(org-habit-overdue-face ((,class ,@(modus-themes--agenda-habit
- red-graph-0-bg
- red-graph-0-bg
- red-graph-1-bg))))
- `(org-habit-overdue-future-face ((,class ,@(modus-themes--agenda-habit
- red-graph-1-bg
- red-graph-0-bg
- red-graph-1-bg))))
- `(org-habit-ready-face ((,class ,@(modus-themes--agenda-habit
- green-graph-0-bg
- green-graph-0-bg
- green-graph-1-bg
- cyan-graph-0-bg
- blue-graph-0-bg
- cyan-graph-1-bg)
- :foreground "black"))) ; special case
- `(org-habit-ready-future-face ((,class ,@(modus-themes--agenda-habit
- green-graph-1-bg
- green-graph-0-bg
- green-graph-1-bg
- cyan-graph-1-bg
- blue-graph-0-bg
- cyan-graph-1-bg))))
- `(org-headline-done ((,class :inherit (modus-themes-variable-pitch modus-themes-grue-nuanced))))
- `(org-headline-todo ((,class :inherit modus-themes-variable-pitch :foreground ,red-nuanced-fg)))
- `(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-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)))
- `(org-level-4 ((,class :inherit modus-themes-heading-4)))
- `(org-level-5 ((,class :inherit modus-themes-heading-5)))
- `(org-level-6 ((,class :inherit modus-themes-heading-6)))
- `(org-level-7 ((,class :inherit modus-themes-heading-7)))
- `(org-level-8 ((,class :inherit modus-themes-heading-8)))
- `(org-link ((,class :inherit button)))
- `(org-list-dt ((,class :inherit bold)))
- `(org-macro ((,class :inherit modus-themes-markup-macro)))
- `(org-meta-line ((,class :inherit (shadow modus-themes-fixed-pitch))))
- `(org-mode-line-clock ((,class :foreground ,fg-main)))
- `(org-mode-line-clock-overrun ((,class :inherit bold :foreground ,red-active)))
- `(org-priority ((,class :foreground ,magenta)))
- `(org-property-value ((,class :inherit modus-themes-fixed-pitch :foreground ,fg-special-cold)))
- `(org-quote ((,class ,@(modus-themes--org-block bg-dim fg-special-cold fg-main))))
- `(org-scheduled ((,class ,@(modus-themes--agenda-scheduled yellow-faint fg-special-warm magenta-alt))))
- `(org-scheduled-previously ((,class ,@(modus-themes--agenda-scheduled yellow fg-special-warm yellow-alt-other))))
- `(org-scheduled-today ((,class ,@(modus-themes--agenda-scheduled yellow fg-special-warm magenta-alt-other))))
- `(org-sexp-date ((,class :foreground ,cyan-alt-other)))
- `(org-special-keyword ((,class :inherit (shadow modus-themes-fixed-pitch))))
- `(org-table ((,class :inherit modus-themes-fixed-pitch :foreground ,fg-special-cold)))
- `(org-table-header ((,class :inherit (fixed-pitch modus-themes-special-cold))))
- `(org-tag ((,class :foreground ,magenta-nuanced-fg)))
- `(org-tag-group ((,class :inherit bold :foreground ,cyan-nuanced-fg)))
- `(org-target ((,class :underline t)))
- `(org-time-grid ((,class :inherit shadow)))
- `(org-todo ((,class :foreground ,red)))
- `(org-upcoming-deadline ((,class :foreground ,red-alt-other)))
- `(org-upcoming-distant-deadline ((,class :foreground ,red-faint)))
- `(org-verbatim ((,class :inherit modus-themes-markup-verbatim)))
- `(org-verse ((,class :inherit org-quote)))
- `(org-warning ((,class :inherit bold :foreground ,red-alt-other)))
+ `(org-agenda-calendar-daterange ((,c :foreground ,date-range)))
+ `(org-agenda-calendar-event ((,c :foreground ,date-event)))
+ `(org-agenda-calendar-sexp ((,c :inherit (modus-themes-slant org-agenda-calendar-event))))
+ `(org-agenda-clocking ((,c :inherit bold :background ,bg-active-argument :foreground ,fg-active-argument)))
+ `(org-agenda-column-dateline ((,c :background ,bg-inactive)))
+ `(org-agenda-current-time ((,c :foreground ,date-now)))
+ `(org-agenda-date ((,c ,@(modus-themes--heading 'agenda-date date-weekday))))
+ `(org-agenda-date-today ((,c :inherit org-agenda-date :underline t)))
+ `(org-agenda-date-weekend ((,c :inherit org-agenda-date :foreground ,date-weekend)))
+ `(org-agenda-date-weekend-today ((,c :inherit org-agenda-date-today :foreground ,date-weekend)))
+ `(org-agenda-diary ((,c :inherit org-agenda-calendar-sexp)))
+ `(org-agenda-dimmed-todo-face ((,c :inherit shadow)))
+ `(org-agenda-done ((,c :inherit org-done)))
+ `(org-agenda-filter-category ((,c :inherit bold :foreground ,modeline-err)))
+ `(org-agenda-filter-effort ((,c :inherit bold :foreground ,modeline-err)))
+ `(org-agenda-filter-regexp ((,c :inherit bold :foreground ,modeline-err)))
+ `(org-agenda-filter-tags ((,c :inherit bold :foreground ,modeline-err)))
+ `(org-agenda-restriction-lock ((,c :background ,bg-dim :foreground ,fg-dim)))
+ `(org-agenda-structure ((,c ,@(modus-themes--heading 'agenda-structure fg-alt))))
+ `(org-agenda-structure-filter ((,c :inherit org-agenda-structure :foreground ,warning)))
+ `(org-agenda-structure-secondary ((,c :inherit font-lock-doc-face)))
+ `(org-archived ((,c :background ,bg-inactive :foreground ,fg-main)))
+ `(org-block ((,c :inherit modus-themes-fixed-pitch :background ,bg-prose-block-contents :extend t)))
+ `(org-block-begin-line ((,c :inherit modus-themes-fixed-pitch :background ,bg-prose-block-delimiter :foreground ,fg-prose-block-delimiter :extend t)))
+ `(org-block-end-line ((,c :inherit org-block-begin-line)))
+ `(org-checkbox ((,c :inherit modus-themes-fixed-pitch :foreground ,warning)))
+ `(org-checkbox-statistics-done ((,c :inherit org-done)))
+ `(org-checkbox-statistics-todo ((,c :inherit org-todo)))
+ `(org-clock-overlay ((,c :inherit secondary-selection)))
+ `(org-code ((,c :inherit modus-themes-prose-code)))
+ `(org-column ((,c :inherit default :background ,bg-dim)))
+ `(org-column-title ((,c :inherit (bold default) :underline t :background ,bg-dim)))
+ `(org-date ((,c :inherit modus-themes-fixed-pitch :foreground ,date-common)))
+ `(org-date-selected ((,c :foreground ,date-common :inverse-video t)))
+ ;; NOTE 2024-03-17: Normally we do not want to add this padding
+ ;; with the :box, but I do it here because the keys are otherwise
+ ;; very hard to read. The square brackets around them are not
+ ;; colored, which is what is causing the problem.
+ `(org-dispatcher-highlight ((,c :inherit modus-themes-bold :box (:line-width 2 :color ,bg-hover-secondary) :background ,bg-hover-secondary :foreground ,fg-main)))
+ `(org-document-info ((,c :foreground ,prose-metadata-value)))
+ `(org-document-info-keyword ((,c :inherit modus-themes-fixed-pitch :foreground ,prose-metadata)))
+ `(org-document-title ((,c :inherit modus-themes-heading-0)))
+ `(org-done ((,c :foreground ,prose-done)))
+ `(org-drawer ((,c :inherit modus-themes-fixed-pitch :foreground ,prose-metadata)))
+ `(org-ellipsis (( ))) ; inherits from the heading's color
+ `(org-footnote ((,c :inherit link)))
+ `(org-formula ((,c :inherit modus-themes-fixed-pitch :foreground ,prose-table-formula)))
+ `(org-headline-done ((,c :inherit org-done)))
+ `(org-headline-todo ((,c :inherit org-todo)))
+ `(org-hide ((,c :foreground ,bg-main)))
+ `(org-indent ((,c :inherit (fixed-pitch org-hide))))
+ `(org-imminent-deadline ((,c :inherit modus-themes-bold :foreground ,date-deadline)))
+ `(org-latex-and-related ((,c :foreground ,type)))
+ `(org-level-1 ((,c :inherit modus-themes-heading-1)))
+ `(org-level-2 ((,c :inherit modus-themes-heading-2)))
+ `(org-level-3 ((,c :inherit modus-themes-heading-3)))
+ `(org-level-4 ((,c :inherit modus-themes-heading-4)))
+ `(org-level-5 ((,c :inherit modus-themes-heading-5)))
+ `(org-level-6 ((,c :inherit modus-themes-heading-6)))
+ `(org-level-7 ((,c :inherit modus-themes-heading-7)))
+ `(org-level-8 ((,c :inherit modus-themes-heading-8)))
+ `(org-link ((,c :inherit link)))
+ `(org-list-dt ((,c :inherit bold)))
+ `(org-macro ((,c :inherit modus-themes-prose-macro)))
+ `(org-meta-line ((,c :inherit modus-themes-fixed-pitch :foreground ,prose-metadata)))
+ `(org-mode-line-clock (( )))
+ `(org-mode-line-clock-overrun ((,c :inherit bold :foreground ,modeline-err)))
+ `(org-priority ((,c :foreground ,prose-tag)))
+ `(org-property-value ((,c :inherit modus-themes-fixed-pitch :foreground ,prose-metadata-value)))
+ `(org-quote ((,c :inherit org-block)))
+ `(org-scheduled ((,c :foreground ,date-scheduled)))
+ `(org-scheduled-previously ((,c :inherit org-scheduled)))
+ `(org-scheduled-today ((,c :inherit (modus-themes-bold org-scheduled))))
+ `(org-sexp-date ((,c :foreground ,date-common)))
+ `(org-special-keyword ((,c :inherit org-drawer)))
+ `(org-table ((,c :inherit modus-themes-fixed-pitch :foreground ,prose-table)))
+ `(org-table-header ((,c :inherit (bold org-table))))
+ `(org-tag ((,c :foreground ,prose-tag)))
+ `(org-tag-group ((,c :inherit (bold org-tag))))
+ `(org-target ((,c :underline t)))
+ `(org-time-grid ((,c :foreground ,fg-dim)))
+ `(org-todo ((,c :foreground ,prose-todo)))
+ `(org-upcoming-deadline ((,c :foreground ,date-deadline)))
+ `(org-upcoming-distant-deadline ((,c :inherit org-upcoming-deadline)))
+ `(org-verbatim ((,c :inherit modus-themes-prose-verbatim)))
+ `(org-verse ((,c :inherit org-block)))
+ `(org-warning ((,c :inherit warning)))
+;;;;; org-habit
+ `(org-habit-alert-face ((,c :background ,bg-graph-yellow-0 :foreground "#000000"))) ; fg is special case
+ `(org-habit-alert-future-face ((,c :background ,bg-graph-yellow-1)))
+ `(org-habit-clear-face ((,c :background ,bg-graph-blue-0 :foreground "#000000"))) ; fg is special case
+ `(org-habit-clear-future-face ((,c :background ,bg-graph-blue-1)))
+ `(org-habit-overdue-face ((,c :background ,bg-graph-red-0)))
+ `(org-habit-overdue-future-face ((,c :background ,bg-graph-red-1)))
+ `(org-habit-ready-face ((,c :background ,bg-graph-green-0 :foreground "#000000"))) ; fg is special case
+ `(org-habit-ready-future-face ((,c :background ,bg-graph-green-1)))
;;;;; org-journal
- `(org-journal-calendar-entry-face ((,class :inherit modus-themes-slant :foreground ,yellow-alt-other)))
- `(org-journal-calendar-scheduled-face ((,class :inherit modus-themes-slant :foreground ,red-alt-other)))
- `(org-journal-highlight ((,class :foreground ,magenta-alt)))
+ `(org-journal-calendar-entry-face ((,c :inherit modus-themes-slant :foreground ,date-common)))
+ `(org-journal-calendar-scheduled-face ((,c :inherit (modus-themes-slant org-scheduled))))
+ `(org-journal-highlight ((,c :foreground ,err)))
;;;;; org-noter
- `(org-noter-no-notes-exist-face ((,class :inherit error)))
- `(org-noter-notes-exist-face ((,class :inherit success)))
+ `(org-noter-no-notes-exist-face ((,c :inherit error)))
+ `(org-noter-notes-exist-face ((,c :inherit success)))
;;;;; org-pomodoro
- `(org-pomodoro-mode-line ((,class :foreground ,red-active)))
- `(org-pomodoro-mode-line-break ((,class :foreground ,cyan-active)))
- `(org-pomodoro-mode-line-overtime ((,class :inherit bold :foreground ,red-active)))
+ `(org-pomodoro-mode-line ((,c :foreground ,err)))
+ `(org-pomodoro-mode-line-break ((,c :foreground ,info)))
+ `(org-pomodoro-mode-line-overtime ((,c :inherit error)))
;;;;; org-recur
- `(org-recur ((,class :foreground ,magenta-active)))
+ `(org-recur ((,c :foreground ,fg-alt)))
;;;;; org-roam
- `(org-roam-dim ((,class :foreground "gray50")))
- `(org-roam-header-line ((,class :inherit bold :foreground ,magenta-active)))
- `(org-roam-olp ((,class :inherit shadow)))
- `(org-roam-preview-heading ((,class :inherit modus-themes-subtle-neutral)))
- `(org-roam-preview-heading-highlight ((,class :inherit modus-themes-intense-neutral)))
- `(org-roam-preview-heading-selection ((,class :inherit modus-themes-special-cold)))
- `(org-roam-preview-region ((,class :inherit bold)))
- `(org-roam-title ((,class :inherit modus-themes-pseudo-header)))
+ `(org-roam-dim ((,c :foreground "gray50")))
+ `(org-roam-olp ((,c :inherit shadow)))
+ `(org-roam-preview-heading ((,c :background ,bg-inactive)))
+ `(org-roam-preview-heading-highlight ((,c :background ,bg-active :foreground ,fg-main)))
+ `(org-roam-preview-region ((,c :inherit bold)))
+ `(org-roam-title ((,c :inherit bold)))
;;;;; org-superstar
- `(org-superstar-item ((,class :foreground ,fg-main)))
- `(org-superstar-leading ((,class :foreground ,fg-whitespace)))
-;;;;; org-table-sticky-header
- `(org-table-sticky-header-face ((,class :inherit modus-themes-special-cold)))
+ `(org-superstar-item ((,c :foreground ,fg-main)))
;;;;; org-tree-slide
- `(org-tree-slide-header-overlay-face ((,class :inherit org-document-title)))
+ `(org-tree-slide-header-overlay-face ((,c :inherit org-document-title)))
;;;;; origami
- `(origami-fold-header-face ((,class :background ,bg-dim :foreground ,fg-dim :box t)))
- `(origami-fold-replacement-face ((,class :background ,bg-alt :foreground ,fg-alt)))
+ `(origami-fold-header-face ((,c :background ,bg-dim :foreground ,fg-dim :box t)))
+ `(origami-fold-replacement-face ((,c :background ,bg-inactive :foreground ,fg-dim)))
;;;;; outline-mode
- `(outline-1 ((,class :inherit modus-themes-heading-1)))
- `(outline-2 ((,class :inherit modus-themes-heading-2)))
- `(outline-3 ((,class :inherit modus-themes-heading-3)))
- `(outline-4 ((,class :inherit modus-themes-heading-4)))
- `(outline-5 ((,class :inherit modus-themes-heading-5)))
- `(outline-6 ((,class :inherit modus-themes-heading-6)))
- `(outline-7 ((,class :inherit modus-themes-heading-7)))
- `(outline-8 ((,class :inherit modus-themes-heading-8)))
+ `(outline-1 ((,c :inherit modus-themes-heading-1)))
+ `(outline-2 ((,c :inherit modus-themes-heading-2)))
+ `(outline-3 ((,c :inherit modus-themes-heading-3)))
+ `(outline-4 ((,c :inherit modus-themes-heading-4)))
+ `(outline-5 ((,c :inherit modus-themes-heading-5)))
+ `(outline-6 ((,c :inherit modus-themes-heading-6)))
+ `(outline-7 ((,c :inherit modus-themes-heading-7)))
+ `(outline-8 ((,c :inherit modus-themes-heading-8)))
;;;;; outline-minor-faces
`(outline-minor-0 (()))
;;;;; package (M-x list-packages)
- `(package-description ((,class :foreground ,fg-special-cold)))
- `(package-help-section-name ((,class :inherit bold :foreground ,cyan)))
- `(package-name ((,class :inherit button)))
- `(package-status-available ((,class :foreground ,cyan-alt-other)))
- `(package-status-avail-obso ((,class :inherit error)))
- `(package-status-built-in ((,class :foreground ,magenta)))
- `(package-status-dependency ((,class :foreground ,magenta-alt-other)))
- `(package-status-disabled ((,class :inherit modus-themes-subtle-red)))
- `(package-status-external ((,class :foreground ,cyan-alt-other)))
- `(package-status-held ((,class :foreground ,yellow-alt)))
- `(package-status-incompat ((,class :inherit warning)))
- `(package-status-installed ((,class :foreground ,fg-special-warm)))
- `(package-status-new ((,class :inherit success)))
- `(package-status-unsigned ((,class :inherit error)))
+ `(package-description ((,c :foreground ,docstring)))
+ `(package-help-section-name ((,c :inherit bold)))
+ `(package-name ((,c :inherit link)))
+ `(package-status-available ((,c :foreground ,date-common)))
+ `(package-status-avail-obso ((,c :inherit error)))
+ `(package-status-built-in ((,c :foreground ,builtin)))
+ `(package-status-dependency ((,c :foreground ,warning)))
+ `(package-status-disabled ((,c :inherit error :strike-through t)))
+ `(package-status-from-source ((,c :foreground ,type)))
+ `(package-status-held ((,c :foreground ,warning)))
+ `(package-status-incompat ((,c :inherit warning)))
+ `(package-status-installed ((,c :foreground ,fg-alt)))
+ `(package-status-new ((,c :inherit success)))
+ `(package-status-unsigned ((,c :inherit error)))
;;;;; page-break-lines
- `(page-break-lines ((,class :inherit default :foreground ,fg-window-divider-outer)))
+ `(page-break-lines ((,c :inherit default :foreground "gray50")))
;;;;; pandoc-mode
- `(pandoc-citation-key-face ((,class :background ,bg-dim :foreground ,magenta-alt)))
- `(pandoc-directive-@@-face ((,class :background ,bg-dim :foreground ,blue-alt-other)))
- `(pandoc-directive-braces-face ((,class :foreground ,blue-alt-other)))
- `(pandoc-directive-contents-face ((,class :foreground ,cyan-alt-other)))
- `(pandoc-directive-type-face ((,class :foreground ,magenta)))
+ `(pandoc-citation-key-face ((,c :inherit font-lock-builtin-face)))
+ `(pandoc-directive-@@-face ((,c :inherit font-lock-keyword-face)))
+ `(pandoc-directive-braces-face ((,c :inherit font-lock-constant-face)))
+ `(pandoc-directive-contents-face ((,c :inherit font-lock-string-face)))
+ `(pandoc-directive-type-face ((,c :inherit font-lock-type-face)))
;;;;; paren-face
- `(parenthesis ((,class :foreground ,fg-unfocused)))
+ `(parenthesis ((,c :inherit shadow)))
;;;;; pass
- `(pass-mode-directory-face ((,class :inherit bold :foreground ,fg-special-cold)))
- `(pass-mode-entry-face ((,class :background ,bg-main :foreground ,fg-main)))
- `(pass-mode-header-face ((,class :foreground ,fg-special-warm)))
+ `(pass-mode-directory-face ((,c :inherit bold :foreground ,accent-0)))
+ `(pass-mode-entry-face ((,c :background ,bg-main :foreground ,fg-main)))
+ `(pass-mode-header-face ((,c :inherit shadow)))
;;;;; pdf-tools
- `(pdf-links-read-link ((,class :background ,fg-main :foreground ,magenta-intense-bg :inherit bold))) ; Foreground is background and vice versa
- `(pdf-occur-document-face ((,class :inherit shadow)))
- `(pdf-occur-page-face ((,class :inherit shadow)))
+ `(pdf-links-read-link ((,c :background ,fg-main :foreground ,bg-magenta-intense :inherit bold))) ; Foreground is background and vice versa
+ `(pdf-occur-document-face ((,c :inherit shadow)))
+ `(pdf-occur-page-face ((,c :inherit shadow)))
;;;;; persp-mode
- `(persp-face-lighter-buffer-not-in-persp ((,class :inherit modus-themes-intense-red)))
- `(persp-face-lighter-default ((,class :inherit bold :foreground ,blue-active)))
- `(persp-face-lighter-nil-persp ((,class :inherit bold :foreground ,fg-active)))
+ `(persp-face-lighter-buffer-not-in-persp ((,c :inherit error)))
+ `(persp-face-lighter-default ((,c :inherit bold :foreground ,name)))
+ `(persp-face-lighter-nil-persp ((,c :inherit bold)))
;;;;; perspective
- `(persp-selected-face ((,class :inherit bold :foreground ,blue-active)))
-;;;;; phi-grep
- `(phi-grep-heading-face ((,class :inherit modus-themes-pseudo-header :foreground ,fg-special-cold)))
- `(phi-grep-line-number-face ((,class :foreground ,fg-special-warm)))
- `(phi-grep-match-face ((,class :inherit modus-themes-special-calm)))
- `(phi-grep-modified-face ((,class :inherit modus-themes-refine-yellow)))
- `(phi-grep-overlay-face ((,class :inherit modus-themes-refine-blue)))
-;;;;; pomidor
- `(pomidor-break-face ((,class :foreground ,blue-alt-other)))
- `(pomidor-overwork-face ((,class :foreground ,red-alt-other)))
- `(pomidor-skip-face ((,class :inherit (shadow modus-themes-slant))))
- `(pomidor-work-face ((,class :inherit modus-themes-grue)))
+ `(persp-selected-face ((,c :inherit bold :foreground ,name)))
+;;;;; proced
+ `(proced-cpu ((,c :foreground ,keyword)))
+ `(proced-emacs-pid ((,c :foreground ,identifier :underline t)))
+ `(proced-executable ((,c :foreground ,name)))
+ `(proced-interruptible-sleep-status-code ((,c :inherit shadow)))
+ `(proced-mem ((,c :foreground ,type)))
+ `(proced-memory-high-usage ((,c :foreground ,err)))
+ `(proced-memory-low-usage ((,c :foreground ,info)))
+ `(proced-memory-medium-usage ((,c :foreground ,warning)))
+ `(proced-pgrp ((,c :inherit proced-pid)))
+ `(proced-pid ((,c :foreground ,identifier)))
+ `(proced-ppid ((,c :inherit proced-pid)))
+ `(proced-run-status-code ((,c :inherit success)))
+ `(proced-sess ((,c :inherit proced-pid)))
+ `(proced-session-leader-pid ((,c :inherit bold :foreground ,identifier)))
+ `(proced-time-colon (( )))
+ `(proced-uninterruptible-sleep-status-code ((,c :inherit error)))
+ `(proced-user (( )))
;;;;; popup
- `(popup-face ((,class :background ,bg-alt :foreground ,fg-main)))
- `(popup-isearch-match ((,class :inherit modus-themes-search-success)))
- `(popup-menu-mouse-face ((,class :inherit highlight)))
- `(popup-menu-selection-face ((,class :inherit modus-themes-completion-selected-popup)))
- `(popup-scroll-bar-background-face ((,class :background ,bg-active)))
- `(popup-scroll-bar-foreground-face ((,class :foreground ,fg-active)))
- `(popup-summary-face ((,class :background ,bg-active :foreground ,fg-inactive)))
- `(popup-tip-face ((,class :inherit modus-themes-refine-yellow)))
+ `(popup-face ((,c :background ,bg-inactive :foreground ,fg-main)))
+ `(popup-isearch-match ((,c :inherit modus-themes-search-current)))
+ `(popup-menu-mouse-face ((,c :inherit highlight)))
+ `(popup-menu-selection-face ((,c :inherit modus-themes-completion-selected)))
+ `(popup-scroll-bar-background-face ((,c :background ,bg-active)))
+ `(popup-scroll-bar-foreground-face (( )))
+ `(popup-summary-face ((,c :background ,bg-active :foreground ,fg-dim)))
+ `(popup-tip-face ((,c :inherit modus-themes-intense-yellow)))
;;;;; powerline
- `(powerline-active0 ((,class :background ,fg-unfocused :foreground ,bg-main)))
- `(powerline-active1 ((,class :inherit mode-line-active)))
- `(powerline-active2 ((,class :inherit mode-line-inactive)))
- `(powerline-inactive0 ((,class :background ,bg-active :foreground ,fg-alt)))
- `(powerline-inactive1 ((,class :background ,bg-main :foreground ,fg-alt)))
- `(powerline-inactive2 ((,class :inherit mode-line-inactive)))
+ `(powerline-active0 ((,c :background ,fg-dim :foreground ,bg-main)))
+ `(powerline-active1 ((,c :inherit mode-line)))
+ `(powerline-active2 ((,c :inherit mode-line-inactive)))
+ `(powerline-inactive0 ((,c :background ,bg-active :foreground ,fg-dim)))
+ `(powerline-inactive1 ((,c :background ,bg-main :foreground ,fg-dim)))
+ `(powerline-inactive2 ((,c :inherit mode-line-inactive)))
;;;;; powerline-evil
- `(powerline-evil-base-face ((,class :background ,fg-main :foreground ,bg-main)))
- `(powerline-evil-emacs-face ((,class :inherit modus-themes-active-magenta)))
- `(powerline-evil-insert-face ((,class :inherit modus-themes-active-green)))
- `(powerline-evil-motion-face ((,class :inherit modus-themes-active-blue)))
- `(powerline-evil-normal-face ((,class :background ,fg-alt :foreground ,bg-main)))
- `(powerline-evil-operator-face ((,class :inherit modus-themes-active-yellow)))
- `(powerline-evil-replace-face ((,class :inherit modus-themes-active-red)))
- `(powerline-evil-visual-face ((,class :inherit modus-themes-active-cyan)))
+ `(powerline-evil-base-face ((,c :background ,fg-main :foreground ,bg-main)))
+ `(powerline-evil-emacs-face ((,c :inherit bold :background ,bg-main)))
+ `(powerline-evil-insert-face ((,c :inherit success :background ,bg-main)))
+ `(powerline-evil-motion-face ((,c :inherit italic :background ,bg-main)))
+ `(powerline-evil-normal-face ((,c :background ,bg-main :foreground ,fg-alt)))
+ `(powerline-evil-operator-face ((,c :inherit warning :background ,bg-main)))
+ `(powerline-evil-replace-face ((,c :inherit error :background ,bg-main)))
+ `(powerline-evil-visual-face ((,c :inherit bold :background ,bg-main)))
;;;;; prescient
- `(prescient-primary-highlight ((,class :inherit modus-themes-completion-match-0)))
- `(prescient-secondary-highlight ((,class :inherit modus-themes-completion-match-1)))
+ `(prescient-primary-highlight ((,c :inherit modus-themes-completion-match-0)))
+ `(prescient-secondary-highlight ((,c :inherit modus-themes-completion-match-1)))
;;;;; proced
- `(proced-mark ((,class :inherit modus-themes-mark-symbol)))
- `(proced-marked ((,class :inherit modus-themes-mark-alt)))
- `(proced-sort-header ((,class :inherit bold :foreground ,fg-special-calm :underline t)))
+ `(proced-mark ((,c :inherit bold)))
+ `(proced-marked ((,c :inherit modus-themes-mark-alt)))
+ `(proced-sort-header ((,c :inherit bold :underline t)))
;;;;; prodigy
- `(prodigy-green-face ((,class :inherit success)))
- `(prodigy-red-face ((,class :inherit error)))
- `(prodigy-yellow-face ((,class :inherit warning)))
+ `(prodigy-green-face ((,c :inherit success)))
+ `(prodigy-red-face ((,c :inherit error)))
+ `(prodigy-yellow-face ((,c :inherit warning)))
;;;;; pulse
- `(pulse-highlight-start-face ((,class :background ,bg-active-accent :extend t)))
+ `(pulse-highlight-start-face ((,c :background ,bg-blue-intense :extend t)))
;;;;; pyim
- `(pyim-page ((,class :background ,bg-active :foreground ,fg-active)))
- `(pyim-page-selection ((,class :inherit bold :background ,bg-active :foreground ,blue-active)))
- `(pyim-page-subword ((,class :background ,bg-inactive)))
+ `(pyim-page ((,c :background ,bg-active)))
+ `(pyim-page-selection ((,c :inherit bold :background ,bg-active :foreground ,info)))
+ `(pyim-page-subword ((,c :background ,bg-inactive)))
;;;;; quick-peek
- `(quick-peek-background-face ((,class :background ,bg-alt)))
- `(quick-peek-border-face ((,class :background ,fg-window-divider-inner :height 1)))
- `(quick-peek-padding-face ((,class :background ,bg-alt :height 0.15)))
-;;;;; racket-mode
- `(racket-debug-break-face ((,class :inherit modus-themes-intense-red)))
- `(racket-debug-locals-face ((,class :box (:line-width -1 :color nil)
- :foreground ,green-alt-other)))
- `(racket-debug-result-face ((,class :inherit bold :box (:line-width -1 :color nil)
- :foreground ,green)))
- `(racket-here-string-face ((,class :foreground ,blue-alt)))
- `(racket-keyword-argument-face ((,class :foreground ,red-alt)))
- `(racket-logger-config-face ((,class :inherit (shadow modus-themes-slant))))
- `(racket-logger-debug-face ((,class :foreground ,blue-alt-other)))
- `(racket-logger-info-face ((,class :foreground ,fg-lang-note)))
- `(racket-logger-topic-face ((,class :inherit modus-themes-slant :foreground ,magenta)))
- `(racket-selfeval-face ((,class :foreground ,green-alt)))
- `(racket-xp-error-face ((,class :inherit modus-themes-lang-error)))
-;;;;; rainbow-blocks
- `(rainbow-blocks-depth-1-face ((,class :foreground ,magenta-alt-other)))
- `(rainbow-blocks-depth-2-face ((,class :foreground ,blue)))
- `(rainbow-blocks-depth-3-face ((,class :foreground ,magenta-alt)))
- `(rainbow-blocks-depth-4-face ((,class :foreground ,green)))
- `(rainbow-blocks-depth-5-face ((,class :foreground ,magenta)))
- `(rainbow-blocks-depth-6-face ((,class :foreground ,cyan)))
- `(rainbow-blocks-depth-7-face ((,class :foreground ,yellow)))
- `(rainbow-blocks-depth-8-face ((,class :foreground ,cyan-alt)))
- `(rainbow-blocks-depth-9-face ((,class :foreground ,red-alt)))
- `(rainbow-blocks-unmatched-face ((,class :foreground ,red)))
+ `(quick-peek-background-face ((,c :background ,bg-inactive)))
+ `(quick-peek-border-face ((,c :background ,border :height 1)))
+ `(quick-peek-padding-face ((,c :background ,bg-inactive :height 0.15)))
;;;;; rainbow-delimiters
- `(rainbow-delimiters-base-error-face ((,class :background ,red-subtle-bg :foreground ,fg-main)))
- `(rainbow-delimiters-base-face ((,class :foreground ,fg-main)))
- `(rainbow-delimiters-depth-1-face ((,class :foreground ,fg-main)))
- `(rainbow-delimiters-depth-2-face ((,class :foreground ,magenta-intense)))
- `(rainbow-delimiters-depth-3-face ((,class :foreground ,cyan-intense)))
- `(rainbow-delimiters-depth-4-face ((,class :foreground ,orange-intense)))
- `(rainbow-delimiters-depth-5-face ((,class :foreground ,purple-intense)))
- `(rainbow-delimiters-depth-6-face ((,class :foreground ,green-intense)))
- `(rainbow-delimiters-depth-7-face ((,class :foreground ,red-intense)))
- `(rainbow-delimiters-depth-8-face ((,class :foreground ,blue-intense)))
- `(rainbow-delimiters-depth-9-face ((,class :foreground ,yellow-intense)))
- `(rainbow-delimiters-mismatched-face ((,class :inherit (bold modus-themes-refine-yellow))))
- `(rainbow-delimiters-unmatched-face ((,class :inherit (bold modus-themes-refine-red))))
+ `(rainbow-delimiters-base-error-face ((,c :inherit modus-themes-prominent-error)))
+ `(rainbow-delimiters-base-face ((,c :foreground ,fg-main)))
+ `(rainbow-delimiters-depth-1-face ((,c :foreground ,rainbow-0)))
+ `(rainbow-delimiters-depth-2-face ((,c :foreground ,rainbow-1)))
+ `(rainbow-delimiters-depth-3-face ((,c :foreground ,rainbow-2)))
+ `(rainbow-delimiters-depth-4-face ((,c :foreground ,rainbow-3)))
+ `(rainbow-delimiters-depth-5-face ((,c :foreground ,rainbow-4)))
+ `(rainbow-delimiters-depth-6-face ((,c :foreground ,rainbow-5)))
+ `(rainbow-delimiters-depth-7-face ((,c :foreground ,rainbow-6)))
+ `(rainbow-delimiters-depth-8-face ((,c :foreground ,rainbow-7)))
+ `(rainbow-delimiters-depth-9-face ((,c :foreground ,rainbow-8)))
+ `(rainbow-delimiters-mismatched-face ((,c :inherit (bold modus-themes-prominent-warning))))
+ `(rainbow-delimiters-unmatched-face ((,c :inherit (bold modus-themes-prominent-error))))
;;;;; rcirc
- `(rcirc-bright-nick ((,class :inherit bold :foreground ,magenta-intense)))
- `(rcirc-dim-nick ((,class :inherit shadow)))
- `(rcirc-monospace-text ((,class :inherit fixed-pitch)))
- `(rcirc-my-nick ((,class :inherit bold :foreground ,magenta)))
- `(rcirc-nick-in-message ((,class :inherit bold :foreground ,red-alt)))
- `(rcirc-nick-in-message-full-line ((,class :inherit bold :foreground ,cyan-alt-other)))
- `(rcirc-other-nick ((,class :inherit bold :foreground ,blue)))
- `(rcirc-prompt ((,class :inherit modus-themes-prompt)))
- `(rcirc-server ((,class :inherit shadow)))
- `(rcirc-timestamp ((,class :foreground ,cyan)))
- `(rcirc-track-keyword ((,class :inherit bold)))
- `(rcirc-track-nick ((,class :inherit bold :foreground ,red-active)))
- `(rcirc-url ((,class :inherit link)))
+ `(rcirc-bright-nick ((,c :inherit bold :foreground ,accent-2)))
+ `(rcirc-dim-nick ((,c :inherit shadow)))
+ `(rcirc-monospace-text ((,c :inherit fixed-pitch)))
+ `(rcirc-my-nick ((,c :inherit bold :foreground ,accent-1)))
+ `(rcirc-nick-in-message ((,c :inherit rcirc-my-nick)))
+ `(rcirc-nick-in-message-full-line ((,c :inherit rcirc-my-nick)))
+ `(rcirc-other-nick ((,c :inherit bold :foreground ,accent-0)))
+ `(rcirc-prompt ((,c :inherit minibuffer-prompt)))
+ `(rcirc-server ((,c :inherit font-lock-comment-face)))
+ `(rcirc-timestamp ((,c :foreground ,date-common)))
+ `(rcirc-track-keyword ((,c :inherit bold :foreground ,modeline-warning)))
+ `(rcirc-track-nick ((,c :inherit rcirc-my-nick)))
+ `(rcirc-url ((,c :inherit link)))
;;;;; recursion-indicator
- `(recursion-indicator-general ((,class :foreground ,blue-active)))
- `(recursion-indicator-minibuffer ((,class :foreground ,red-active)))
+ `(recursion-indicator-general ((,c :foreground ,modeline-err)))
+ `(recursion-indicator-minibuffer ((,c :foreground ,modeline-info)))
;;;;; regexp-builder (re-builder)
- `(reb-match-0 ((,class :inherit modus-themes-refine-cyan)))
- `(reb-match-1 ((,class :inherit modus-themes-subtle-magenta)))
- `(reb-match-2 ((,class :inherit modus-themes-subtle-green)))
- `(reb-match-3 ((,class :inherit modus-themes-refine-yellow)))
- `(reb-regexp-grouping-backslash ((,class :inherit font-lock-regexp-grouping-backslash)))
- `(reb-regexp-grouping-construct ((,class :inherit font-lock-regexp-grouping-construct)))
+ `(reb-match-0 ((,c :inherit modus-themes-search-rx-group-0)))
+ `(reb-match-1 ((,c :inherit modus-themes-search-rx-group-1)))
+ `(reb-match-2 ((,c :inherit modus-themes-search-rx-group-2)))
+ `(reb-match-3 ((,c :inherit modus-themes-search-rx-group-3)))
+ `(reb-regexp-grouping-backslash ((,c :inherit font-lock-regexp-grouping-backslash)))
+ `(reb-regexp-grouping-construct ((,c :inherit font-lock-regexp-grouping-construct)))
;;;;; rg (rg.el)
- `(rg-column-number-face ((,class :foreground ,magenta-alt-other)))
- `(rg-context-face ((,class :foreground ,fg-unfocused)))
- `(rg-error-face ((,class :inherit bold :foreground ,red)))
- `(rg-file-tag-face ((,class :foreground ,fg-special-cold)))
- `(rg-filename-face ((,class :inherit bold :foreground ,fg-special-cold)))
- `(rg-line-number-face ((,class :foreground ,fg-special-warm)))
- `(rg-literal-face ((,class :foreground ,blue-alt)))
- `(rg-match-face ((,class :inherit modus-themes-special-calm)))
- `(rg-regexp-face ((,class :foreground ,magenta-active)))
- `(rg-toggle-off-face ((,class :inherit bold :foreground ,fg-inactive)))
- `(rg-toggle-on-face ((,class :inherit bold :foreground ,cyan-active)))
- `(rg-warning-face ((,class :inherit bold :foreground ,yellow)))
+ `(rg-column-number-face ((,c :inherit shadow)))
+ `(rg-context-face ((,c :inherit shadow)))
+ `(rg-error-face ((,c :inherit error)))
+ `(rg-file-tag-face ((,c :inherit font-lock-builtin-face)))
+ `(rg-filename-face ((,c :inherit bold :foreground ,name)))
+ `(rg-line-number-face ((,c :inherit shadow)))
+ `(rg-literal-face ((,c :inherit font-lock-constant-face)))
+ `(rg-match-face ((,c :inherit match)))
+ `(rg-regexp-face ((,c :foreground ,name)))
+ `(rg-toggle-off-face ((,c :inherit (shadow bold))))
+ `(rg-toggle-on-face ((,c :inherit success)))
+ `(rg-warning-face ((,c :inherit warning)))
;;;;; ripgrep
- `(ripgrep-context-face ((,class :foreground ,fg-unfocused)))
- `(ripgrep-error-face ((,class :inherit bold :foreground ,red)))
- `(ripgrep-hit-face ((,class :foreground ,cyan)))
- `(ripgrep-match-face ((,class :inherit modus-themes-special-calm)))
+ `(ripgrep-context-face ((,c :inherit shadow)))
+ `(ripgrep-error-face ((,c :inherit error)))
+ `(ripgrep-hit-face ((,c :inherit success)))
+ `(ripgrep-match-face ((,c :inherit match)))
;;;;; rmail
- `(rmail-header-name ((,class :foreground ,cyan-alt-other)))
- `(rmail-highlight ((,class :inherit bold :foreground ,magenta-alt)))
+ `(rmail-header-name ((,c :inherit bold)))
+ `(rmail-highlight ((,c :inherit bold :foreground ,mail-other)))
+;;;;; rst-mode
+ `(rst-level-1 ((,c :inherit modus-themes-heading-1)))
+ `(rst-level-2 ((,c :inherit modus-themes-heading-2)))
+ `(rst-level-3 ((,c :inherit modus-themes-heading-3)))
+ `(rst-level-4 ((,c :inherit modus-themes-heading-4)))
+ `(rst-level-5 ((,c :inherit modus-themes-heading-5)))
+ `(rst-level-6 ((,c :inherit modus-themes-heading-6)))
;;;;; ruler-mode
- `(ruler-mode-column-number ((,class :inherit ruler-mode-default :foreground ,fg-main)))
- `(ruler-mode-comment-column ((,class :inherit ruler-mode-default :foreground ,red)))
- `(ruler-mode-current-column ((,class :inherit ruler-mode-default :background ,blue-subtle-bg :foreground ,fg-main)))
- `(ruler-mode-default ((,class :inherit default :background ,bg-alt :foreground ,fg-unfocused)))
- `(ruler-mode-fill-column ((,class :inherit ruler-mode-default :foreground ,green)))
- `(ruler-mode-fringes ((,class :inherit ruler-mode-default :foreground ,cyan)))
- `(ruler-mode-goal-column ((,class :inherit ruler-mode-default :foreground ,blue)))
- `(ruler-mode-margins ((,class :inherit ruler-mode-default :foreground ,bg-main)))
- `(ruler-mode-pad ((,class :inherit ruler-mode-default :background ,bg-active :foreground ,fg-inactive)))
- `(ruler-mode-tab-stop ((,class :inherit ruler-mode-default :foreground ,fg-special-warm)))
-;;;;; selectrum
- `(selectrum-current-candidate ((,class :inherit modus-themes-completion-selected)))
- `(selectrum-mouse-highlight ((,class :inherit highlight)))
- `(selectrum-quick-keys-highlight ((,class :inherit bold :background ,bg-char-0)))
- `(selectrum-quick-keys-match ((,class :inherit bold :background ,bg-char-1)))
-;;;;; semantic
- `(semantic-complete-inline-face ((,class :foreground ,fg-special-warm :underline t)))
- `(semantic-decoration-on-fileless-includes ((,class :inherit modus-themes-refine-green)))
- `(semantic-decoration-on-private-members-face ((,class :inherit modus-themes-refine-cyan)))
- `(semantic-decoration-on-protected-members-face ((,class :background ,bg-dim)))
- `(semantic-decoration-on-unknown-includes ((,class :inherit modus-themes-refine-red)))
- `(semantic-decoration-on-unparsed-includes ((,class :inherit modus-themes-refine-yellow)))
- `(semantic-highlight-edits-face ((,class :background ,bg-alt)))
- `(semantic-highlight-func-current-tag-face ((,class :background ,bg-alt)))
- `(semantic-idle-symbol-highlight ((,class :inherit modus-themes-special-mild)))
- `(semantic-tag-boundary-face ((,class :overline ,blue-intense)))
- `(semantic-unmatched-syntax-face ((,class :underline ,fg-lang-error)))
+ `(ruler-mode-column-number ((,c :inherit ruler-mode-default)))
+ `(ruler-mode-comment-column ((,c :inherit ruler-mode-default :foreground ,red)))
+ `(ruler-mode-current-column ((,c :inherit ruler-mode-default :background ,bg-active :foreground ,fg-main)))
+ `(ruler-mode-default ((,c :inherit default :background ,bg-dim :foreground ,fg-dim)))
+ `(ruler-mode-fill-column ((,c :inherit ruler-mode-default :foreground ,green)))
+ `(ruler-mode-fringes ((,c :inherit ruler-mode-default :foreground ,cyan)))
+ `(ruler-mode-goal-column ((,c :inherit ruler-mode-default :foreground ,blue)))
+ `(ruler-mode-margins ((,c :inherit ruler-mode-default :foreground ,bg-main)))
+ `(ruler-mode-pad ((,c :inherit ruler-mode-default :background ,bg-inactive :foreground ,fg-dim)))
+ `(ruler-mode-tab-stop ((,c :inherit ruler-mode-default :foreground ,yellow)))
;;;;; sesman
- `(sesman-browser-button-face ((,class :inherit button)))
- `(sesman-browser-highligh-face ((,class :inherit highlight)))
- `(sesman-buffer-face ((,class :foreground ,magenta)))
- `(sesman-directory-face ((,class :inherit bold :foreground ,blue)))
- `(sesman-project-face ((,class :inherit bold :foreground ,magenta-alt-other)))
+ `(sesman-browser-button-face ((,c :inherit button)))
+ `(sesman-browser-highligh-face ((,c :inherit highlight)))
+ `(sesman-buffer-face ((,c :foreground ,accent-1)))
+ `(sesman-directory-face ((,c :inherit bold :foreground ,accent-0)))
+ `(sesman-project-face ((,c :inherit bold :foreground ,accent-2)))
;;;;; shell-script-mode
- `(sh-heredoc ((,class :foreground ,blue-alt)))
- `(sh-quoted-exec ((,class :inherit modus-themes-bold :foreground ,magenta-alt)))
+ `(sh-heredoc ((,c :inherit font-lock-string-face)))
+ `(sh-quoted-exec ((,c :inherit font-lock-builtin-face)))
;;;;; shortdoc
- `(shortdoc-heading ((,class :inherit modus-themes-pseudo-header)))
+ `(shortdoc-heading ((,c :inherit bold)))
`(shortdoc-section (())) ; remove the default's variable-pitch style
;;;;; show-paren-mode
- `(show-paren-match ((,class ,@(modus-themes--paren bg-paren-match
- bg-paren-match-intense)
- :foreground ,fg-main)))
- `(show-paren-match-expression ((,class :background ,bg-paren-expression)))
- `(show-paren-mismatch ((,class :inherit modus-themes-intense-red)))
+ `(show-paren-match ((,c :background ,bg-paren-match :foreground ,fg-paren-match :underline ,underline-paren-match)))
+ `(show-paren-match-expression ((,c :background ,bg-paren-expression)))
+ `(show-paren-mismatch ((,c :inherit modus-themes-prominent-error)))
;;;;; 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-selected-link ((,class :inherit modus-themes-subtle-red)))
+ `(shr-abbreviation ((,c :inherit modus-themes-lang-note)))
+ `(shr-code ((,c :inherit modus-themes-prose-verbatim)))
+ `(shr-h1 ((,c :inherit modus-themes-heading-1)))
+ `(shr-h2 ((,c :inherit modus-themes-heading-2)))
+ `(shr-h3 ((,c :inherit modus-themes-heading-3)))
+ `(shr-h4 ((,c :inherit modus-themes-heading-4)))
+ `(shr-h5 ((,c :inherit modus-themes-heading-5)))
+ `(shr-h6 ((,c :inherit modus-themes-heading-6)))
+ `(shr-mark ((,c :inherit match)))
+ `(shr-selected-link ((,c :inherit modus-themes-mark-sel)))
;;;;; side-notes
- `(side-notes ((,class :background ,bg-dim :foreground ,fg-dim)))
+ `(side-notes ((,c :background ,bg-dim :foreground ,fg-dim)))
;;;;; sieve-mode
- `(sieve-action-commands ((,class :inherit font-lock-builtin-face)))
- `(sieve-control-commands ((,class :inherit font-lock-keyword-face)))
- `(sieve-tagged-arguments ((,class :inherit font-lock-type-face)))
- `(sieve-test-commands ((,class :inherit font-lock-function-name-face)))
+ `(sieve-action-commands ((,c :inherit font-lock-builtin-face)))
+ `(sieve-control-commands ((,c :inherit font-lock-keyword-face)))
+ `(sieve-tagged-arguments ((,c :inherit font-lock-type-face)))
+ `(sieve-test-commands ((,c :inherit font-lock-function-name-face)))
;;;;; skewer-mode
- `(skewer-error-face ((,class :foreground ,red :underline t)))
+ `(skewer-error-face ((,c :inherit modus-themes-lang-error)))
;;;;; slime (sldb)
- `(sldb-condition-face ((,class :inherit font-lock-preprocessor-face)))
- `(sldb-restart-number-face ((,class :inherit bold)))
- `(sldb-restart-type-face ((,class :inherit font-lock-type-face)))
- `(sldb-restartable-frame-line-face ((,class :inherit success)))
- `(sldb-section-face ((,class :inherit modus-themes-pseudo-header)))
- `(slime-error-face ((,class :inherit modus-themes-lang-error)))
- `(slime-note-face ((,class :underline t)))
- `(slime-repl-input-face ((,class :inherit bold)))
- `(slime-repl-inputed-output-face ((,class :inherit font-lock-string-face)))
- `(slime-repl-output-mouseover-face ((,class :inherit highlight)))
- `(slime-repl-prompt-face ((,class :inherit modus-themes-prompt)))
- `(slime-style-warning-face ((,class :inherit modus-themes-lang-note)))
- `(slime-warning-face ((,class :inherit modus-themes-lang-warning)))
+ `(sldb-condition-face ((,c :inherit font-lock-preprocessor-face)))
+ `(sldb-restart-number-face ((,c :inherit bold)))
+ `(sldb-restart-type-face ((,c :inherit font-lock-type-face)))
+ `(sldb-restartable-frame-line-face ((,c :inherit success)))
+ `(sldb-section-face ((,c :inherit bold)))
+ `(slime-error-face ((,c :inherit modus-themes-lang-error)))
+ `(slime-note-face ((,c :underline t)))
+ `(slime-repl-input-face ((,c :inherit bold)))
+ `(slime-repl-inputed-output-face ((,c :inherit font-lock-string-face)))
+ `(slime-repl-output-mouseover-face ((,c :inherit highlight)))
+ `(slime-repl-prompt-face ((,c :inherit modus-themes-prompt)))
+ `(slime-style-warning-face ((,c :inherit modus-themes-lang-note)))
+ `(slime-warning-face ((,c :inherit modus-themes-lang-warning)))
;;;;; sly
- `(sly-action-face ((,class :inherit font-lock-type-face)))
- `(sly-db-condition-face ((,class :inherit font-lock-preprocessor-face)))
- `(sly-db-restartable-frame-line-face ((,class :inherit success)))
- `(sly-error-face ((,class :inherit modus-themes-lang-error)))
- `(sly-mode-line ((,class :inherit mode-line-emphasis)))
- `(sly-mrepl-output-face ((,class :inherit font-lock-string-face)))
- `(sly-mrepl-output-face ((,class :inherit font-lock-string-face)))
- `(sly-mrepl-prompt-face ((,class :inherit modus-themes-prompt)))
- `(sly-note-face ((,class :inherit modus-themes-lang-note)))
- `(sly-stickers-placed-face ((,class :inherit modus-themes-subtle-neutral)))
- `(sly-style-warning-face ((,class :inherit modus-themes-lang-note)))
- `(sly-warning-face ((,class :inherit modus-themes-lang-warning)))
+ `(sly-action-face ((,c :inherit font-lock-type-face)))
+ `(sly-db-condition-face ((,c :inherit font-lock-preprocessor-face)))
+ `(sly-db-restartable-frame-line-face ((,c :inherit success)))
+ `(sly-error-face ((,c :inherit modus-themes-lang-error)))
+ `(sly-mode-line ((,c :inherit mode-line-emphasis)))
+ `(sly-mrepl-output-face ((,c :inherit font-lock-string-face)))
+ `(sly-mrepl-output-face ((,c :inherit font-lock-string-face)))
+ `(sly-mrepl-prompt-face ((,c :inherit modus-themes-prompt)))
+ `(sly-note-face ((,c :inherit modus-themes-lang-note)))
+ `(sly-stickers-placed-face ((,c :background ,bg-inactive)))
+ `(sly-style-warning-face ((,c :inherit modus-themes-lang-note)))
+ `(sly-warning-face ((,c :inherit modus-themes-lang-warning)))
;;;;; smart-mode-line
- `(sml/charging ((,class :foreground ,green-active)))
- `(sml/discharging ((,class :foreground ,red-active)))
- `(sml/filename ((,class :inherit bold :foreground ,blue-active)))
- `(sml/folder ((,class :foreground ,fg-active)))
- `(sml/git ((,class :inherit bold :foreground ,green-active)))
- `(sml/global ((,class :foreground ,fg-active)))
- `(sml/line-number ((,class :inherit sml/global)))
- `(sml/minor-modes ((,class :inherit sml/global)))
- `(sml/modes ((,class :inherit bold :foreground ,fg-active)))
- `(sml/modified ((,class :inherit bold :foreground ,magenta-active)))
- `(sml/mule-info ((,class :inherit sml/global)))
- `(sml/name-filling ((,class :foreground ,yellow-active)))
- `(sml/not-modified ((,class :inherit sml/global)))
- `(sml/numbers-separator ((,class :inherit sml/global)))
- `(sml/outside-modified ((,class :inherit modus-themes-intense-red)))
- `(sml/position-percentage ((,class :inherit sml/global)))
- `(sml/prefix ((,class :foreground ,green-active)))
- `(sml/process ((,class :inherit sml/prefix)))
- `(sml/projectile ((,class :inherit sml/git)))
- `(sml/read-only ((,class :inherit bold :foreground ,cyan-active)))
- `(sml/remote ((,class :inherit sml/global)))
- `(sml/sudo ((,class :inherit modus-themes-subtle-red)))
- `(sml/time ((,class :inherit sml/global)))
- `(sml/vc ((,class :inherit sml/git)))
- `(sml/vc-edited ((,class :inherit bold :foreground ,yellow-active)))
-;;;;; smartparens
- `(sp-pair-overlay-face ((,class :inherit modus-themes-special-warm)))
- `(sp-show-pair-enclosing ((,class :inherit modus-themes-special-mild)))
- `(sp-show-pair-match-face ((,class ,@(modus-themes--paren bg-paren-match
- bg-paren-match-intense)
- :foreground ,fg-main)))
- `(sp-show-pair-mismatch-face ((,class :inherit modus-themes-intense-red)))
- `(sp-wrap-overlay-closing-pair ((,class :inherit sp-pair-overlay-face)))
- `(sp-wrap-overlay-face ((,class :inherit sp-pair-overlay-face)))
- `(sp-wrap-overlay-opening-pair ((,class :inherit sp-pair-overlay-face)))
- `(sp-wrap-tag-overlay-face ((,class :inherit sp-pair-overlay-face)))
+ `(sml/charging ((,c :foreground ,info)))
+ `(sml/discharging ((,c :foreground ,err)))
+ `(sml/filename ((,c :inherit bold :foreground ,name)))
+ `(sml/folder (( )))
+ `(sml/git ((,c :inherit success)))
+ `(sml/global (( )))
+ `(sml/line-number ((,c :inherit sml/global)))
+ `(sml/minor-modes ((,c :inherit sml/global)))
+ `(sml/modes ((,c :inherit bold)))
+ `(sml/modified ((,c :inherit italic)))
+ `(sml/mule-info ((,c :inherit sml/global)))
+ `(sml/name-filling ((,c :inherit warning)))
+ `(sml/not-modified ((,c :inherit sml/global)))
+ `(sml/numbers-separator ((,c :inherit sml/global)))
+ `(sml/outside-modified ((,c :inherit modus-themes-prominent-error)))
+ `(sml/position-percentage ((,c :inherit sml/global)))
+ `(sml/prefix ((,c :foreground ,fg-alt)))
+ `(sml/process ((,c :inherit sml/prefix)))
+ `(sml/projectile ((,c :inherit sml/git)))
+ `(sml/read-only (( )))
+ `(sml/remote ((,c :inherit sml/global)))
+ `(sml/sudo ((,c :inherit warning)))
+ `(sml/time ((,c :inherit sml/global)))
+ `(sml/vc ((,c :inherit sml/git)))
+ `(sml/vc-edited ((,c :inherit italic)))
;;;;; smerge
- `(smerge-base ((,class :inherit modus-themes-diff-changed)))
- `(smerge-lower ((,class :inherit modus-themes-diff-added)))
- `(smerge-markers ((,class :inherit modus-themes-diff-heading)))
- `(smerge-refined-added ((,class :inherit modus-themes-diff-refine-added)))
+ `(smerge-base ((,c :inherit diff-changed)))
+ `(smerge-lower ((,c :inherit diff-added)))
+ `(smerge-markers ((,c :inherit diff-header)))
+ `(smerge-refined-added ((,c :inherit diff-refine-added)))
`(smerge-refined-changed (()))
- `(smerge-refined-removed ((,class :inherit modus-themes-diff-refine-removed)))
- `(smerge-upper ((,class :inherit modus-themes-diff-removed)))
-;;;;; spaceline
- `(spaceline-evil-emacs ((,class :inherit modus-themes-active-magenta)))
- `(spaceline-evil-insert ((,class :inherit modus-themes-active-green)))
- `(spaceline-evil-motion ((,class :inherit modus-themes-active-blue)))
- `(spaceline-evil-normal ((,class :background ,fg-alt :foreground ,bg-alt)))
- `(spaceline-evil-replace ((,class :inherit modus-themes-active-red)))
- `(spaceline-evil-visual ((,class :inherit modus-themes-active-cyan)))
- `(spaceline-flycheck-error ((,class :foreground ,red-active)))
- `(spaceline-flycheck-info ((,class :foreground ,cyan-active)))
- `(spaceline-flycheck-warning ((,class :foreground ,yellow-active)))
- `(spaceline-highlight-face ((,class :inherit modus-themes-fringe-blue)))
- `(spaceline-modified ((,class :inherit modus-themes-fringe-magenta)))
- `(spaceline-python-venv ((,class :foreground ,magenta-active)))
- `(spaceline-read-only ((,class :inherit modus-themes-fringe-red)))
- `(spaceline-unmodified ((,class :inherit modus-themes-fringe-cyan)))
+ `(smerge-refined-removed ((,c :inherit diff-refine-removed)))
+ `(smerge-upper ((,c :inherit diff-removed)))
;;;;; speedbar
- `(speedbar-button-face ((,class :inherit button)))
- `(speedbar-directory-face ((,class :inherit bold :foreground ,blue)))
- `(speedbar-file-face ((,class :foreground ,fg-main)))
- `(speedbar-highlight-face ((,class :inherit highlight)))
- `(speedbar-selected-face ((,class :inherit bold :foreground ,cyan)))
- `(speedbar-separator-face ((,class :inherit modus-themes-intense-neutral)))
- `(speedbar-tag-face ((,class :foreground ,yellow-alt-other)))
+ `(speedbar-button-face ((,c :inherit button)))
+ `(speedbar-directory-face ((,c :inherit bold :foreground ,accent-0)))
+ `(speedbar-file-face ((,c :foreground ,fg-main)))
+ `(speedbar-highlight-face ((,c :inherit highlight)))
+ `(speedbar-selected-face ((,c :inherit modus-themes-mark-sel)))
+ `(speedbar-separator-face ((,c :background ,bg-active :foreground ,fg-main)))
+ `(speedbar-tag-face ((,c :foreground ,accent-1)))
;;;;; spell-fu
- `(spell-fu-incorrect-face ((,class :inherit modus-themes-lang-error)))
+ `(spell-fu-incorrect-face ((,c :inherit modus-themes-lang-error)))
;;;;; stripes
- `(stripes ((,class :background ,bg-alt)))
+ `(stripes ((,c :background ,bg-inactive)))
;;;;; suggest
- `(suggest-heading ((,class :inherit bold :foreground ,yellow-alt-other)))
+ `(suggest-heading ((,c :inherit warning)))
;;;;; switch-window
- `(switch-window-background ((,class :background ,bg-dim)))
- `(switch-window-label ((,class :height 3.0 :foreground ,blue-intense)))
+ `(switch-window-background ((,c :background ,bg-inactive)))
+ `(switch-window-label ((,c :height 3.0 :foreground ,red-intense)))
;;;;; swiper
`(swiper-background-match-face-1 (( )))
- `(swiper-background-match-face-2 ((,class :inherit modus-themes-completion-match-0)))
- `(swiper-background-match-face-3 ((,class :inherit modus-themes-completion-match-1)))
- `(swiper-background-match-face-4 ((,class :inherit modus-themes-completion-match-2)))
- `(swiper-line-face ((,class :background ,bg-hl-alt-intense)))
+ `(swiper-background-match-face-2 ((,c :inherit modus-themes-completion-match-0)))
+ `(swiper-background-match-face-3 ((,c :inherit modus-themes-completion-match-1)))
+ `(swiper-background-match-face-4 ((,c :inherit modus-themes-completion-match-2)))
+ `(swiper-line-face ((,c :background ,bg-hl-line :extend t)))
`(swiper-match-face-1 (( )))
- `(swiper-match-face-2 ((,class :inherit modus-themes-completion-match-0)))
- `(swiper-match-face-3 ((,class :inherit modus-themes-completion-match-1)))
- `(swiper-match-face-4 ((,class :inherit modus-themes-completion-match-2)))
-;;;;; sx
- `(sx-inbox-item-type ((,class :foreground ,magenta-alt-other)))
- `(sx-inbox-item-type-unread ((,class :inherit (sx-inbox-item-type bold))))
- `(sx-question-list-answers ((,class :foreground ,green)))
- `(sx-question-list-answers-accepted ((,class :box t :foreground ,green)))
- `(sx-question-list-bounty ((,class :inherit bold :background ,bg-alt :foreground ,yellow)))
- `(sx-question-list-date ((,class :foreground ,fg-special-cold)))
- `(sx-question-list-favorite ((,class :inherit bold :foreground ,fg-special-warm)))
- `(sx-question-list-parent ((,class :foreground ,fg-main)))
- `(sx-question-list-read-question ((,class :inherit shadow)))
- `(sx-question-list-score ((,class :foreground ,fg-special-mild)))
- `(sx-question-list-score-upvoted ((,class :inherit (sx-question-list-score bold))))
- `(sx-question-list-unread-question ((,class :inherit bold :foreground ,fg-main)))
- `(sx-question-mode-accepted ((,class :inherit bold :height 1.3 :foreground ,green)))
- `(sx-question-mode-closed ((,class :inherit modus-themes-active-yellow :box (:line-width 2 :color nil))))
- `(sx-question-mode-closed-reason ((,class :box (:line-width 2 :color nil) :foreground ,fg-main)))
- `(sx-question-mode-content-face ((,class :background ,bg-dim)))
- `(sx-question-mode-date ((,class :foreground ,blue)))
- `(sx-question-mode-header ((,class :inherit bold :foreground ,cyan)))
- `(sx-question-mode-kbd-tag ((,class :inherit bold :height 0.9 :box (:line-width 3 :color ,fg-main :style released-button) :foreground ,fg-main)))
- `(sx-question-mode-score ((,class :foreground ,fg-dim)))
- `(sx-question-mode-score-downvoted ((,class :foreground ,yellow)))
- `(sx-question-mode-score-upvoted ((,class :inherit bold :foreground ,magenta)))
- `(sx-question-mode-title ((,class :inherit bold :foreground ,fg-main)))
- `(sx-question-mode-title-comments ((,class :inherit (shadow bold))))
- `(sx-tag ((,class :foreground ,magenta-alt)))
- `(sx-user-name ((,class :foreground ,blue-alt)))
- `(sx-user-reputation ((,class :inherit shadow)))
+ `(swiper-match-face-2 ((,c :inherit modus-themes-completion-match-0)))
+ `(swiper-match-face-3 ((,c :inherit modus-themes-completion-match-1)))
+ `(swiper-match-face-4 ((,c :inherit modus-themes-completion-match-2)))
;;;;; symbol-overlay
- `(symbol-overlay-default-face ((,class :inherit modus-themes-special-warm)))
- `(symbol-overlay-face-1 ((,class :inherit modus-themes-intense-blue)))
- `(symbol-overlay-face-2 ((,class :inherit modus-themes-refine-magenta)))
- `(symbol-overlay-face-3 ((,class :inherit modus-themes-intense-yellow)))
- `(symbol-overlay-face-4 ((,class :inherit modus-themes-intense-magenta)))
- `(symbol-overlay-face-5 ((,class :inherit modus-themes-intense-red)))
- `(symbol-overlay-face-6 ((,class :inherit modus-themes-refine-red)))
- `(symbol-overlay-face-7 ((,class :inherit modus-themes-intense-cyan)))
- `(symbol-overlay-face-8 ((,class :inherit modus-themes-refine-cyan)))
+ `(symbol-overlay-default-face ((,c :background ,bg-inactive)))
+ `(symbol-overlay-face-1 ((,c :inherit modus-themes-intense-blue)))
+ `(symbol-overlay-face-2 ((,c :inherit modus-themes-intense-magenta)))
+ `(symbol-overlay-face-3 ((,c :inherit modus-themes-intense-yellow)))
+ `(symbol-overlay-face-4 ((,c :inherit modus-themes-intense-magenta)))
+ `(symbol-overlay-face-5 ((,c :inherit modus-themes-intense-red)))
+ `(symbol-overlay-face-6 ((,c :inherit modus-themes-intense-red)))
+ `(symbol-overlay-face-7 ((,c :inherit modus-themes-intense-cyan)))
+ `(symbol-overlay-face-8 ((,c :inherit modus-themes-intense-cyan)))
;;;;; syslog-mode
- `(syslog-debug ((,class :inherit bold :foreground ,cyan-alt-other)))
- `(syslog-error ((,class :inherit error)))
- `(syslog-file ((,class :inherit bold :foreground ,fg-special-cold)))
- `(syslog-hide ((,class :background ,bg-main :foreground ,fg-main)))
- `(syslog-hour ((,class :inherit bold :foreground ,magenta-alt-other)))
- `(syslog-info ((,class :inherit success)))
- `(syslog-ip ((,class :inherit bold :foreground ,fg-special-mild :underline t)))
- `(syslog-su ((,class :inherit bold :foreground ,red-alt)))
- `(syslog-warn ((,class :inherit warning)))
-;;;;; tab-bar-groups
- `(tab-bar-groups-tab-1 ((,class :inherit modus-themes-ui-variable-pitch :foreground ,blue-tab)))
- `(tab-bar-groups-tab-2 ((,class :inherit modus-themes-ui-variable-pitch :foreground ,red-tab)))
- `(tab-bar-groups-tab-3 ((,class :inherit modus-themes-ui-variable-pitch :foreground ,green-tab)))
- `(tab-bar-groups-tab-4 ((,class :inherit modus-themes-ui-variable-pitch :foreground ,orange-tab)))
- `(tab-bar-groups-tab-5 ((,class :inherit modus-themes-ui-variable-pitch :foreground ,purple-tab)))
- `(tab-bar-groups-tab-6 ((,class :inherit modus-themes-ui-variable-pitch :foreground ,cyan-tab)))
- `(tab-bar-groups-tab-7 ((,class :inherit modus-themes-ui-variable-pitch :foreground ,yellow-tab)))
- `(tab-bar-groups-tab-8 ((,class :inherit modus-themes-ui-variable-pitch :foreground ,magenta-tab)))
+ `(syslog-debug ((,c :inherit italic)))
+ `(syslog-error ((,c :inherit error)))
+ `(syslog-file ((,c :inherit bold :foreground ,name)))
+ `(syslog-hide ((,c :background ,bg-main :foreground ,fg-main)))
+ `(syslog-hour ((,c :inherit bold :foreground ,date-common)))
+ `(syslog-info ((,c :inherit success)))
+ `(syslog-ip ((,c :inherit bold :foreground ,name :underline t)))
+ `(syslog-su ((,c :inherit error :underline t)))
+ `(syslog-warn ((,c :inherit warning)))
;;;;; tab-bar-mode
- `(tab-bar ((,class :inherit modus-themes-tab-backdrop)))
- `(tab-bar-tab-group-current ((,class ,@(modus-themes--tab bg-tab-active)
- :box (:line-width (2 . -2) :color "gray50"))))
- `(tab-bar-tab-group-inactive ((,class ,@(modus-themes--tab bg-tab-inactive bg-tab-inactive-accent fg-dim)
- :box (:line-width (2 . -2) :color "gray50"))))
- `(tab-bar-tab ((,class :inherit modus-themes-tab-active)))
- `(tab-bar-tab-inactive ((,class :inherit modus-themes-tab-inactive)))
+ `(tab-bar ((,c :inherit modus-themes-ui-variable-pitch :background ,bg-tab-bar)))
+ `(tab-bar-tab-group-current ((,c :inherit bold :background ,bg-tab-current :box (:line-width -2 :color ,bg-tab-current) :foreground ,fg-alt)))
+ `(tab-bar-tab-group-inactive ((,c :background ,bg-tab-bar :box (:line-width -2 :color ,bg-tab-bar) :foreground ,fg-alt)))
+ `(tab-bar-tab ((,c :inherit bold :box (:line-width -2 :color ,bg-tab-current) :background ,bg-tab-current)))
+ `(tab-bar-tab-inactive ((,c :box (:line-width -2 :color ,bg-tab-other) :background ,bg-tab-other)))
+ `(tab-bar-tab-ungrouped ((,c :inherit tab-bar-tab-inactive)))
;;;;; tab-line-mode
- `(tab-line ((,class :inherit modus-themes-tab-backdrop :height 0.95)))
- `(tab-line-close-highlight ((,class :foreground ,red)))
- `(tab-line-highlight ((,class :inherit modus-themes-active-blue)))
- `(tab-line-tab ((,class :inherit modus-themes-tab-active)))
- `(tab-line-tab-current ((,class :inherit tab-line-tab)))
- `(tab-line-tab-inactive ((,class :inherit modus-themes-tab-inactive)))
- `(tab-line-tab-inactive-alternate ((,class ,@(modus-themes--tab bg-tab-inactive-alt
- bg-tab-inactive-alt-accent fg-main nil t))))
- `(tab-line-tab-modified ((,class :foreground ,red-alt-other-faint)))
+ `(tab-line ((,c :inherit modus-themes-ui-variable-pitch :background ,bg-tab-bar :height 0.95)))
+ `(tab-line-close-highlight ((,c :foreground ,err)))
+ `(tab-line-highlight ((,c :inherit highlight)))
+ `(tab-line-tab (( )))
+ `(tab-line-tab-current ((,c :inherit bold :box (:line-width -2 :color ,bg-tab-current) :background ,bg-tab-current)))
+ `(tab-line-tab-inactive ((,c :box (:line-width -2 :color ,bg-tab-other) :background ,bg-tab-other)))
+ `(tab-line-tab-inactive-alternate ((,c :inherit tab-line-tab-inactive :foreground ,fg-alt)))
+ `(tab-line-tab-modified ((,c :foreground ,warning)))
;;;;; table (built-in table.el)
- `(table-cell ((,class :background ,blue-nuanced-bg)))
+ `(table-cell ((,c :background ,bg-dim)))
;;;;; telega
- `(telega-button ((,class :box t :foreground ,blue)))
- `(telega-button-active ((,class :box ,blue-intense-bg :background ,blue-intense-bg :foreground ,fg-main)))
- `(telega-button-highlight ((,class :inherit modus-themes-subtle-magenta)))
- `(telega-chat-prompt ((,class :inherit bold)))
- `(telega-entity-type-code ((,class :inherit modus-themes-markup-verbatim)))
- `(telega-entity-type-mention ((,class :foreground ,cyan)))
- `(telega-entity-type-pre ((,class :inherit modus-themes-markup-code)))
- `(telega-entity-type-spoiler ((,class :background ,fg-main :foreground ,fg-main)))
- `(telega-msg-heading ((,class :background ,bg-alt)))
- `(telega-msg-self-title ((,class :inherit bold)))
- `(telega-root-heading ((,class :inherit modus-themes-subtle-neutral)))
- `(telega-secret-title ((,class :foreground ,magenta-alt)))
- `(telega-unmuted-count ((,class :foreground ,blue-alt-other)))
- `(telega-user-online-status ((,class :foreground ,cyan-active)))
- `(telega-username ((,class :foreground ,cyan-alt-other)))
- `(telega-webpage-chat-link ((,class :background ,bg-alt)))
- `(telega-webpage-fixed ((,class :inherit modus-themes-fixed-pitch :height 0.85)))
- `(telega-webpage-header ((,class :inherit modus-themes-variable-pitch :height 1.3)))
- `(telega-webpage-preformatted ((,class :inherit modus-themes-fixed-pitch :background ,bg-alt)))
- `(telega-webpage-subheader ((,class :inherit modus-themes-variable-pitch :height 1.15)))
-;;;;; telephone-line
- `(telephone-line-accent-active ((,class :background ,fg-inactive :foreground ,bg-inactive)))
- `(telephone-line-accent-inactive ((,class :background ,bg-active :foreground ,fg-active)))
- `(telephone-line-error ((,class :inherit bold :foreground ,red-active)))
- `(telephone-line-evil ((,class :foreground ,fg-main)))
- `(telephone-line-evil-emacs ((,class :inherit telephone-line-evil :background ,magenta-intense-bg)))
- `(telephone-line-evil-insert ((,class :inherit telephone-line-evil :background ,green-intense-bg)))
- `(telephone-line-evil-motion ((,class :inherit telephone-line-evil :background ,yellow-intense-bg)))
- `(telephone-line-evil-normal ((,class :inherit telephone-line-evil :background ,bg-alt)))
- `(telephone-line-evil-operator ((,class :inherit telephone-line-evil :background ,yellow-subtle-bg)))
- `(telephone-line-evil-replace ((,class :inherit telephone-line-evil :background ,red-intense-bg)))
- `(telephone-line-evil-visual ((,class :inherit telephone-line-evil :background ,cyan-intense-bg)))
- `(telephone-line-projectile ((,class :foreground ,cyan-active)))
- `(telephone-line-unimportant ((,class :foreground ,fg-inactive)))
- `(telephone-line-warning ((,class :inherit bold :foreground ,yellow-active)))
+ `(telega-button ((,c :box t :foreground ,fg-link)))
+ `(telega-button-active ((,c :box ,fg-link :background ,fg-link :foreground ,bg-main)))
+ `(telega-button-highlight ((,c :inherit secondary-selection)))
+ `(telega-chat-prompt ((,c :inherit modus-themes-prompt)))
+ `(telega-entity-type-code ((,c :inherit modus-themes-prose-verbatim)))
+ `(telega-entity-type-mention ((,c :foreground ,cyan)))
+ `(telega-entity-type-pre ((,c :inherit modus-themes-prose-code)))
+ `(telega-entity-type-spoiler ((,c :background ,fg-main :foreground ,fg-main)))
+ `(telega-msg-heading ((,c :background ,bg-inactive)))
+ `(telega-msg-self-title ((,c :inherit bold)))
+ `(telega-root-heading ((,c :background ,bg-inactive)))
+ `(telega-secret-title ((,c :foreground ,magenta-warmer)))
+ `(telega-unmuted-count ((,c :foreground ,blue-cooler)))
+ `(telega-user-online-status ((,c :foreground ,cyan)))
+ `(telega-username ((,c :foreground ,cyan-cooler)))
+ `(telega-webpage-chat-link ((,c :background ,bg-inactive)))
+ `(telega-webpage-fixed ((,c :inherit modus-themes-fixed-pitch :height 0.85)))
+ `(telega-webpage-header ((,c :inherit modus-themes-variable-pitch :height 1.3)))
+ `(telega-webpage-preformatted ((,c :inherit modus-themes-fixed-pitch :background ,bg-inactive)))
+ `(telega-webpage-subheader ((,c :inherit modus-themes-variable-pitch :height 1.15)))
;;;;; terraform-mode
- `(terraform--resource-name-face ((,class ,@(modus-themes--syntax-string
- magenta-alt-other magenta-alt-other-faint
- red-alt red-alt))))
- `(terraform--resource-type-face ((,class ,@(modus-themes--syntax-string
- green green-faint
- blue-alt magenta-alt))))
+ `(terraform--resource-name-face ((,c :foreground ,keyword)))
+ `(terraform--resource-type-face ((,c :foreground ,type)))
;;;;; term
- `(term ((,class :background ,bg-main :foreground ,fg-main)))
- `(term-bold ((,class :inherit bold)))
- `(term-color-black ((,class :background "gray35" :foreground "gray35")))
- `(term-color-blue ((,class :background ,blue :foreground ,blue)))
- `(term-color-cyan ((,class :background ,cyan :foreground ,cyan)))
- `(term-color-green ((,class :background ,green :foreground ,green)))
- `(term-color-magenta ((,class :background ,magenta :foreground ,magenta)))
- `(term-color-red ((,class :background ,red :foreground ,red)))
- `(term-color-white ((,class :background "gray65" :foreground "gray65")))
- `(term-color-yellow ((,class :background ,yellow :foreground ,yellow)))
- `(term-underline ((,class :underline t)))
+ ;; NOTE 2023-08-10: `term-color-black' and `term-color-white' use
+ ;; the "bright" semantic color mappings to make sure they are
+ ;; distinct from `term'.
+ `(term ((,c :background ,bg-main :foreground ,fg-main)))
+ `(term-bold ((,c :inherit bold)))
+ `(term-color-black ((,c :background ,bg-term-black-bright :foreground ,fg-term-black-bright)))
+ `(term-color-blue ((,c :background ,bg-term-blue :foreground ,fg-term-blue)))
+ `(term-color-cyan ((,c :background ,bg-term-cyan :foreground ,fg-term-cyan)))
+ `(term-color-green ((,c :background ,bg-term-green :foreground ,fg-term-green)))
+ `(term-color-magenta ((,c :background ,bg-term-magenta :foreground ,fg-term-magenta)))
+ `(term-color-red ((,c :background ,bg-term-red :foreground ,fg-term-red)))
+ `(term-color-white ((,c :background ,bg-term-white-bright :foreground ,fg-term-white-bright)))
+ `(term-color-yellow ((,c :background ,bg-term-yellow :foreground ,fg-term-yellow)))
+ `(term-underline ((,c :underline t)))
;;;;; textsec
- `(textsec-suspicious (()))
-;;;;; tomatinho
- `(tomatinho-ok-face ((,class :foreground ,blue-intense)))
- `(tomatinho-pause-face ((,class :foreground ,yellow-intense)))
- `(tomatinho-reset-face ((,class :inherit shadow)))
+ `(textsec-suspicious (( )))
;;;;; transient
- `(transient-active-infix ((,class :inherit modus-themes-special-mild)))
- `(transient-amaranth ((,class :inherit bold :foreground ,yellow-alt)))
+ `(transient-active-infix ((,c :inherit highlight)))
+ `(transient-amaranth ((,c :inherit bold :foreground ,yellow-warmer)))
;; Placate the compiler for what is a spurious warning. We also
;; have to do this with `eldoc-highlight-function-argument'.
- (list 'transient-argument `((,class :inherit bold :background ,cyan-nuanced-bg :foreground ,cyan)))
- `(transient-blue ((,class :inherit bold :foreground ,blue)))
- `(transient-disabled-suffix ((,class :inherit modus-themes-intense-red)))
- `(transient-enabled-suffix ((,class :inherit modus-themes-grue-background-subtle)))
- `(transient-heading ((,class :inherit bold :foreground ,fg-main)))
- `(transient-inactive-argument ((,class :inherit shadow)))
- `(transient-inactive-value ((,class :inherit shadow)))
- `(transient-key ((,class :inherit modus-themes-key-binding)))
- `(transient-mismatched-key ((,class :underline t)))
- `(transient-nonstandard-key ((,class :underline t)))
- `(transient-pink ((,class :inherit bold :foreground ,magenta-alt-faint)))
- `(transient-purple ((,class :inherit bold :foreground ,magenta-alt-other)))
- `(transient-red ((,class :inherit bold :foreground ,red-faint)))
- `(transient-teal ((,class :inherit bold :foreground ,cyan-alt-other)))
- `(transient-unreachable ((,class :inherit shadow)))
- `(transient-unreachable-key ((,class :inherit shadow)))
- `(transient-value ((,class :inherit bold :background ,yellow-nuanced-bg :foreground ,yellow-alt-other)))
+ (list 'transient-argument `((,c :inherit bold :background ,bg-active-argument :foreground ,fg-active-argument)))
+ `(transient-blue ((,c :inherit bold :foreground ,blue)))
+ `(transient-disabled-suffix ((,c :inherit modus-themes-mark-del)))
+ `(transient-enabled-suffix ((,c :inherit modus-themes-subtle-cyan)))
+ `(transient-heading ((,c :inherit bold :foreground ,fg-main)))
+ `(transient-inactive-argument ((,c :inherit shadow)))
+ `(transient-inactive-value ((,c :inherit shadow)))
+ ;; NOTE 2023-12-09 10:30:09 +0200: The new user option
+ ;; `transient-semantic-coloring' is enabled by default. This is
+ ;; not good for us, because we are making it harder for users who
+ ;; need accessible colors to use the transient interfaces. I
+ ;; could set that user option to nil, but I think it is less
+ ;; intrusive to enforce uniformity among the relevant faces.
+ ;; Those who want semantic coloring can modify these faces.
+ `(transient-key ((,c :inherit modus-themes-key-binding)))
+ `(transient-key-exit ((,c :inherit modus-themes-key-binding)))
+ `(transient-key-noop ((,c :inherit (shadow modus-themes-key-binding))))
+ `(transient-key-return ((,c :inherit modus-themes-key-binding)))
+ `(transient-key-stay ((,c :inherit modus-themes-key-binding)))
+ `(transient-mismatched-key ((,c :underline t)))
+ `(transient-nonstandard-key ((,c :underline t)))
+ `(transient-pink ((,c :inherit bold :foreground ,magenta)))
+ `(transient-purple ((,c :inherit bold :foreground ,magenta-cooler)))
+ `(transient-red ((,c :inherit bold :foreground ,red-faint)))
+ `(transient-teal ((,c :inherit bold :foreground ,cyan-cooler)))
+ `(transient-unreachable ((,c :inherit shadow)))
+ `(transient-unreachable-key ((,c :inherit shadow)))
+ `(transient-value ((,c :inherit bold :background ,bg-active-value :foreground ,fg-active-value)))
;;;;; trashed
- `(trashed-deleted ((,class :inherit modus-themes-mark-del)))
- `(trashed-directory ((,class :foreground ,blue)))
- `(trashed-mark ((,class :inherit modus-themes-mark-symbol)))
- `(trashed-marked ((,class :inherit modus-themes-mark-alt)))
- `(trashed-restored ((,class :inherit modus-themes-mark-sel)))
- `(trashed-symlink ((,class :inherit modus-themes-link-symlink)))
+ `(trashed-deleted ((,c :inherit modus-themes-mark-del)))
+ `(trashed-directory ((,c :foreground ,accent-0)))
+ `(trashed-mark ((,c :inherit bold)))
+ `(trashed-marked ((,c :inherit modus-themes-mark-alt)))
+ `(trashed-restored ((,c :inherit modus-themes-mark-sel)))
;;;;; tree-sitter
- `(tree-sitter-hl-face:attribute ((,class :inherit font-lock-variable-name-face)))
- `(tree-sitter-hl-face:constant.builtin ((,class :inherit tree-sitter-hl-face:constant)))
- `(tree-sitter-hl-face:escape ((,class :inherit font-lock-regexp-grouping-backslash)))
- `(tree-sitter-hl-face:function ((,class :inherit font-lock-function-name-face)))
- `(tree-sitter-hl-face:function.call ((,class :inherit tree-sitter-hl-face:function)))
+ `(tree-sitter-hl-face:attribute ((,c :inherit font-lock-variable-name-face)))
+ `(tree-sitter-hl-face:constant.builtin ((,c :inherit tree-sitter-hl-face:constant)))
+ `(tree-sitter-hl-face:escape ((,c :inherit font-lock-regexp-grouping-backslash)))
+ `(tree-sitter-hl-face:function ((,c :inherit font-lock-function-name-face)))
+ `(tree-sitter-hl-face:function.call ((,c :inherit tree-sitter-hl-face:function)))
`(tree-sitter-hl-face:label (( )))
`(tree-sitter-hl-face:method.call (( )))
- `(tree-sitter-hl-face:operator ((,class :inherit modus-themes-bold)))
+ `(tree-sitter-hl-face:operator ((,c :inherit modus-themes-bold)))
`(tree-sitter-hl-face:property (( )))
- `(tree-sitter-hl-face:property.definition ((,class :inherit font-lock-variable-name-face)))
+ `(tree-sitter-hl-face:property.definition ((,c :inherit font-lock-variable-name-face)))
`(tree-sitter-hl-face:punctuation (( )))
`(tree-sitter-hl-face:punctuation.bracket (( )))
`(tree-sitter-hl-face:punctuation.delimiter (( )))
- `(tree-sitter-hl-face:punctuation.special ((,class :inherit font-lock-regexp-grouping-construct)))
- `(tree-sitter-hl-face:string.special ((,class :inherit tree-sitter-hl-face:string)))
- `(tree-sitter-hl-face:tag ((,class :inherit font-lock-function-name-face)))
+ `(tree-sitter-hl-face:punctuation.special ((,c :inherit font-lock-regexp-grouping-construct)))
+ `(tree-sitter-hl-face:string.special ((,c :inherit tree-sitter-hl-face:string)))
+ `(tree-sitter-hl-face:tag ((,c :inherit font-lock-function-name-face)))
`(tree-sitter-hl-face:type.argument (( )))
-;;;;; treemacs
- `(treemacs-directory-collapsed-face ((,class :foreground ,magenta-alt)))
- `(treemacs-directory-face ((,class :inherit dired-directory)))
- `(treemacs-file-face ((,class :foreground ,fg-main)))
- `(treemacs-fringe-indicator-face ((,class :foreground ,fg-main)))
- `(treemacs-git-added-face ((,class :inherit success)))
- `(treemacs-git-conflict-face ((,class :inherit error)))
- `(treemacs-git-ignored-face ((,class :inherit shadow)))
- `(treemacs-git-modified-face ((,class :inherit warning)))
- `(treemacs-git-renamed-face ((,class :inherit italic)))
- `(treemacs-git-unmodified-face ((,class :foreground ,fg-main)))
- `(treemacs-git-untracked-face ((,class :inherit shadow)))
- `(treemacs-help-column-face ((,class :inherit modus-themes-bold :foreground ,magenta-alt-other :underline t)))
- `(treemacs-help-title-face ((,class :foreground ,blue-alt-other)))
- `(treemacs-on-failure-pulse-face ((,class :inherit modus-themes-intense-red)))
- `(treemacs-on-success-pulse-face ((,class :inherit modus-themes-grue-background-intense)))
- `(treemacs-root-face ((,class :inherit bold :foreground ,blue-alt-other :height 1.2 :underline t)))
- `(treemacs-root-remote-disconnected-face ((,class :inherit treemacs-root-remote-face :foreground ,yellow)))
- `(treemacs-root-remote-face ((,class :inherit treemacs-root-face :foreground ,magenta)))
- `(treemacs-root-remote-unreadable-face ((,class :inherit treemacs-root-unreadable-face)))
- `(treemacs-root-unreadable-face ((,class :inherit treemacs-root-face :strike-through t)))
- `(treemacs-tags-face ((,class :foreground ,blue-alt)))
;;;;; tty-menu
- `(tty-menu-disabled-face ((,class :background ,bg-alt :foreground ,fg-alt)))
- `(tty-menu-enabled-face ((,class :inherit bold :background ,bg-alt :foreground ,fg-main)))
- `(tty-menu-selected-face ((,class :inherit modus-themes-intense-blue)))
+ `(tty-menu-disabled-face ((,c :background ,bg-inactive :foreground ,fg-dim)))
+ `(tty-menu-enabled-face ((,c :inherit bold :background ,bg-inactive :foreground ,fg-main)))
+ `(tty-menu-selected-face ((,c :inherit modus-themes-intense-blue)))
;;;;; tuareg
- `(caml-types-def-face ((,class :inherit modus-themes-subtle-red)))
- `(caml-types-expr-face ((,class :inherit modus-themes-subtle-green)))
- `(caml-types-occ-face ((,class :inherit modus-themes-subtle-green)))
- `(caml-types-scope-face ((,class :inherit modus-themes-subtle-blue)))
- `(caml-types-typed-face ((,class :inherit modus-themes-subtle-magenta)))
- `(tuareg-font-double-semicolon-face ((,class :inherit font-lock-preprocessor-face)))
- `(tuareg-font-lock-attribute-face ((,class :inherit font-lock-function-name-face)))
- `(tuareg-font-lock-constructor-face ((,class :foreground ,fg-main)))
- `(tuareg-font-lock-error-face ((,class :inherit (modus-themes-intense-red bold))))
- `(tuareg-font-lock-extension-node-face ((,class :background ,bg-alt :foreground ,magenta)))
- `(tuareg-font-lock-governing-face ((,class :inherit bold :foreground ,fg-main)))
- `(tuareg-font-lock-infix-extension-node-face ((,class :inherit font-lock-function-name-face)))
- `(tuareg-font-lock-interactive-directive-face ((,class :foreground ,fg-special-cold)))
- `(tuareg-font-lock-interactive-error-face ((,class :inherit error)))
- `(tuareg-font-lock-interactive-output-face ((,class :inherit font-lock-constant-face)))
- `(tuareg-font-lock-label-face ((,class :inherit font-lock-type-face)))
- `(tuareg-font-lock-line-number-face ((,class :foreground ,fg-special-warm)))
- `(tuareg-font-lock-module-face ((,class :inherit font-lock-builtin-face)))
- `(tuareg-font-lock-multistage-face ((,class :inherit bold :background ,bg-alt :foreground ,blue)))
- `(tuareg-font-lock-operator-face ((,class :inherit font-lock-preprocessor-face)))
- `(tuareg-opam-error-face ((,class :inherit error)))
- `(tuareg-opam-pkg-variable-name-face ((,class :inherit font-lock-variable-name-face)))
+ `(caml-types-def-face ((,c :inherit modus-themes-subtle-red)))
+ `(caml-types-expr-face ((,c :inherit modus-themes-subtle-green)))
+ `(caml-types-occ-face ((,c :inherit modus-themes-subtle-green)))
+ `(caml-types-scope-face ((,c :inherit modus-themes-subtle-blue)))
+ `(caml-types-typed-face ((,c :inherit modus-themes-subtle-magenta)))
+ `(tuareg-font-double-semicolon-face ((,c :inherit font-lock-preprocessor-face)))
+ `(tuareg-font-lock-attribute-face ((,c :inherit font-lock-function-name-face)))
+ `(tuareg-font-lock-constructor-face ((,c :foreground ,fg-main)))
+ `(tuareg-font-lock-error-face ((,c :inherit (modus-themes-intense-red bold))))
+ ;; `(tuareg-font-lock-extension-node-face ((,c :background ,bg-inactive :foreground ,magenta)))
+ `(tuareg-font-lock-governing-face ((,c :inherit bold :foreground ,fg-main)))
+ `(tuareg-font-lock-infix-extension-node-face ((,c :inherit font-lock-function-name-face)))
+ `(tuareg-font-lock-interactive-directive-face ((,c :inherit font-lock-preprocessor-face)))
+ `(tuareg-font-lock-interactive-error-face ((,c :inherit error)))
+ `(tuareg-font-lock-interactive-output-face ((,c :inherit font-lock-constant-face)))
+ `(tuareg-font-lock-label-face ((,c :inherit font-lock-type-face)))
+ `(tuareg-font-lock-line-number-face ((,c :inherit shadow)))
+ `(tuareg-font-lock-module-face ((,c :inherit font-lock-builtin-face)))
+ ;; `(tuareg-font-lock-multistage-face ((,c :inherit bold :background ,bg-inactive :foreground ,blue)))
+ `(tuareg-font-lock-operator-face ((,c :inherit font-lock-preprocessor-face)))
+ `(tuareg-opam-error-face ((,c :inherit error)))
+ `(tuareg-opam-pkg-variable-name-face ((,c :inherit font-lock-variable-name-face)))
;;;;; typescript
- `(typescript-jsdoc-tag ((,class :inherit (font-lock-builtin-face font-lock-comment-face) :weight normal)))
- `(typescript-jsdoc-type ((,class :inherit (font-lock-type-face font-lock-comment-face) :weight normal)))
- `(typescript-jsdoc-value ((,class :inherit (font-lock-constant-face font-lock-comment-face) :weight normal)))
+ `(typescript-jsdoc-tag ((,c :inherit (font-lock-builtin-face font-lock-comment-face) :weight normal)))
+ `(typescript-jsdoc-type ((,c :inherit (font-lock-type-face font-lock-comment-face) :weight normal)))
+ `(typescript-jsdoc-value ((,c :inherit (font-lock-constant-face font-lock-comment-face) :weight normal)))
;;;;; undo-tree
- `(undo-tree-visualizer-active-branch-face ((,class :inherit bold :foreground ,fg-main)))
- `(undo-tree-visualizer-current-face ((,class :foreground ,blue-intense)))
- `(undo-tree-visualizer-default-face ((,class :inherit shadow)))
- `(undo-tree-visualizer-register-face ((,class :foreground ,magenta-intense)))
- `(undo-tree-visualizer-unmodified-face ((,class :foreground ,green-intense)))
+ `(undo-tree-visualizer-active-branch-face ((,c :inherit bold :foreground ,fg-main)))
+ `(undo-tree-visualizer-current-face ((,c :foreground ,blue-intense)))
+ `(undo-tree-visualizer-default-face ((,c :inherit shadow)))
+ `(undo-tree-visualizer-register-face ((,c :foreground ,magenta-intense)))
+ `(undo-tree-visualizer-unmodified-face ((,c :foreground ,green-intense)))
;;;;; vc (vc-dir.el, vc-hooks.el)
- `(vc-dir-directory ((,class :foreground ,blue)))
- `(vc-dir-file ((,class :foreground ,fg-main)))
- `(vc-dir-header ((,class :foreground ,cyan-alt-other)))
- `(vc-dir-header-value ((,class :foreground ,magenta-alt-other)))
- `(vc-dir-mark-indicator ((,class :foreground ,blue-alt-other)))
- `(vc-dir-status-edited ((,class :foreground ,yellow)))
- `(vc-dir-status-ignored ((,class :inherit shadow)))
- `(vc-dir-status-up-to-date ((,class :foreground ,cyan)))
- `(vc-dir-status-warning ((,class :inherit error)))
- `(vc-conflict-state ((,class :inherit bold :foreground ,red-active)))
- `(vc-edited-state ((,class :foreground ,yellow-active)))
- `(vc-locally-added-state ((,class :foreground ,cyan-active)))
- `(vc-locked-state ((,class :foreground ,blue-active)))
- `(vc-missing-state ((,class :inherit modus-themes-slant :foreground ,magenta-active)))
- `(vc-needs-update-state ((,class :inherit modus-themes-slant :foreground ,green-active)))
- `(vc-removed-state ((,class :foreground ,red-active)))
- `(vc-state-base ((,class :foreground ,fg-active)))
- `(vc-up-to-date-state ((,class :foreground ,fg-special-cold)))
+ `(vc-dir-directory (( )))
+ `(vc-dir-file ((,c :foreground ,name)))
+ `(vc-dir-header ((,c :inherit bold)))
+ `(vc-dir-header-value ((,c :foreground ,string)))
+ `(vc-dir-mark-indicator (( )))
+ `(vc-dir-status-edited ((,c :inherit italic)))
+ `(vc-dir-status-ignored ((,c :inherit shadow)))
+ `(vc-dir-status-up-to-date ((,c :foreground ,info)))
+ `(vc-dir-status-warning ((,c :inherit error)))
+ `(vc-conflict-state ((,c :inherit error)))
+ `(vc-edited-state ((,c :inherit italic)))
+ `(vc-git-log-edit-summary-max-warning ((,c :inherit error)))
+ `(vc-git-log-edit-summary-target-warning ((,c :inherit warning)))
+ `(vc-locally-added-state ((,c :inherit italic)))
+ `(vc-locked-state ((,c :inherit success)))
+ `(vc-missing-state ((,c :inherit error)))
+ `(vc-needs-update-state ((,c :inherit error)))
+ `(vc-removed-state ((,c :inherit error)))
+ `(vc-state-base (( )))
+ `(vc-up-to-date-state (( )))
;;;;; vertico
- `(vertico-current ((,class :inherit modus-themes-completion-selected)))
+ `(vertico-current ((,c :inherit modus-themes-completion-selected)))
;;;;; vertico-quick
- `(vertico-quick1 ((,class :inherit bold :background ,bg-char-0)))
- `(vertico-quick2 ((,class :inherit bold :background ,bg-char-1)))
+ `(vertico-quick1 ((,c :inherit bold :background ,bg-char-0)))
+ `(vertico-quick2 ((,c :inherit bold :background ,bg-char-1)))
;;;;; vimish-fold
- `(vimish-fold-fringe ((,class :foreground ,cyan-active)))
- `(vimish-fold-mouse-face ((,class :inherit modus-themes-intense-blue)))
- `(vimish-fold-overlay ((,class :background ,bg-alt :foreground ,fg-special-cold)))
+ `(vimish-fold-fringe ((,c :foreground ,cyan)))
+ `(vimish-fold-mouse-face ((,c :inherit modus-themes-intense-blue)))
+ `(vimish-fold-overlay ((,c :background ,bg-inactive)))
;;;;; visible-mark
- `(visible-mark-active ((,class :background ,blue-intense-bg)))
- `(visible-mark-face1 ((,class :background ,cyan-intense-bg)))
- `(visible-mark-face2 ((,class :background ,yellow-intense-bg)))
- `(visible-mark-forward-face1 ((,class :background ,magenta-intense-bg)))
- `(visible-mark-forward-face2 ((,class :background ,green-intense-bg)))
+ `(visible-mark-active ((,c :background ,bg-blue-intense)))
+ `(visible-mark-face1 ((,c :background ,bg-cyan-intense)))
+ `(visible-mark-face2 ((,c :background ,bg-yellow-intense)))
+ `(visible-mark-forward-face1 ((,c :background ,bg-magenta-intense)))
+ `(visible-mark-forward-face2 ((,c :background ,bg-green-intense)))
;;;;; visual-regexp
- `(vr/group-0 ((,class :inherit modus-themes-intense-blue)))
- `(vr/group-1 ((,class :inherit modus-themes-intense-magenta)))
- `(vr/group-2 ((,class :inherit modus-themes-intense-green)))
- `(vr/match-0 ((,class :inherit modus-themes-refine-yellow)))
- `(vr/match-1 ((,class :inherit modus-themes-refine-yellow)))
- `(vr/match-separator-face ((,class :inherit (modus-themes-intense-neutral bold))))
+ `(vr/group-0 ((,c :inherit modus-themes-search-rx-group-0)))
+ `(vr/group-1 ((,c :inherit modus-themes-search-rx-group-1)))
+ `(vr/group-2 ((,c :inherit modus-themes-search-rx-group-2)))
+ `(vr/match-0 ((,c :inherit modus-themes-search-current)))
+ `(vr/match-1 ((,c :inherit modus-themes-search-lazy)))
+ `(vr/match-separator-face ((,c :inherit bold :background ,bg-active)))
;;;;; vterm
- `(vterm-color-black ((,class :background "gray35" :foreground "gray35")))
- `(vterm-color-blue ((,class :background ,blue :foreground ,blue)))
- `(vterm-color-cyan ((,class :background ,cyan :foreground ,cyan)))
- `(vterm-color-default ((,class :background ,bg-main :foreground ,fg-main)))
- `(vterm-color-green ((,class :background ,green :foreground ,green)))
- `(vterm-color-inverse-video ((,class :background ,bg-main :inverse-video t)))
- `(vterm-color-magenta ((,class :background ,magenta :foreground ,magenta)))
- `(vterm-color-red ((,class :background ,red :foreground ,red)))
- `(vterm-color-underline ((,class :foreground ,fg-special-warm :underline t)))
- `(vterm-color-white ((,class :background "gray65" :foreground "gray65")))
- `(vterm-color-yellow ((,class :background ,yellow :foreground ,yellow)))
+ ;; NOTE 2023-08-10: `vterm-color-black' and `vterm-color-white'
+ ;; use the "bright" semantic color mappings to make sure they are
+ ;; distinct from `vterm-color-default'.
+ `(vterm-color-black ((,c :background ,bg-term-black :foreground ,fg-term-black)))
+ `(vterm-color-blue ((,c :background ,bg-term-blue :foreground ,fg-term-blue)))
+ `(vterm-color-cyan ((,c :background ,bg-term-cyan :foreground ,fg-term-cyan)))
+ `(vterm-color-default ((,c :background ,bg-main :foreground ,fg-main)))
+ `(vterm-color-green ((,c :background ,bg-term-green :foreground ,fg-term-green)))
+ `(vterm-color-inverse-video ((,c :background ,bg-main :inverse-video t)))
+ `(vterm-color-magenta ((,c :background ,bg-term-magenta :foreground ,fg-term-magenta)))
+ `(vterm-color-red ((,c :background ,bg-term-red :foreground ,fg-term-red)))
+ `(vterm-color-underline ((,c :underline t)))
+ `(vterm-color-white ((,c :background ,bg-term-white :foreground ,fg-term-white)))
+ `(vterm-color-yellow ((,c :background ,bg-term-yellow :foreground ,fg-term-yellow)))
;;;;; vundo
- `(vundo-highlight ((,class :inherit (bold vundo-node) :foreground ,red-intense)))
+ `(vundo-default ((,c :inherit shadow)))
+ `(vundo-highlight ((,c :inherit (bold vundo-node) :foreground ,red)))
+ `(vundo-last-saved ((,c :inherit (bold vundo-node) :foreground ,blue)))
+ `(vundo-saved ((,c :inherit vundo-node :foreground ,blue-intense)))
;;;;; wcheck-mode
- `(wcheck-default-face ((,class :foreground ,red :underline t)))
+ `(wcheck-default-face ((,c :foreground ,red :underline t)))
;;;;; web-mode
- `(web-mode-annotation-face ((,class :inherit web-mode-comment-face)))
- `(web-mode-annotation-html-face ((,class :inherit web-mode-comment-face)))
- `(web-mode-annotation-tag-face ((,class :inherit web-mode-comment-face :underline t)))
- `(web-mode-block-attr-name-face ((,class :inherit font-lock-constant-face)))
- `(web-mode-block-attr-value-face ((,class :inherit font-lock-type-face)))
- `(web-mode-block-comment-face ((,class :inherit web-mode-comment-face)))
- `(web-mode-block-control-face ((,class :inherit font-lock-builtin-face)))
- `(web-mode-block-delimiter-face ((,class :foreground ,fg-main)))
- `(web-mode-block-face ((,class :background ,bg-dim)))
- `(web-mode-block-string-face ((,class :inherit web-mode-string-face)))
- `(web-mode-bold-face ((,class :inherit bold)))
- `(web-mode-builtin-face ((,class :inherit font-lock-builtin-face)))
- `(web-mode-comment-face ((,class :inherit font-lock-comment-face)))
- `(web-mode-comment-keyword-face ((,class :inherit font-lock-warning-face)))
- `(web-mode-constant-face ((,class :inherit font-lock-constant-face)))
- `(web-mode-css-at-rule-face ((,class :inherit font-lock-constant-face)))
- `(web-mode-css-color-face ((,class :inherit font-lock-builtin-face)))
- `(web-mode-css-comment-face ((,class :inherit web-mode-comment-face)))
- `(web-mode-css-function-face ((,class :inherit font-lock-builtin-face)))
- `(web-mode-css-priority-face ((,class :inherit font-lock-warning-face)))
- `(web-mode-css-property-name-face ((,class :inherit font-lock-keyword-face)))
- `(web-mode-css-pseudo-class-face ((,class :inherit font-lock-doc-face)))
- `(web-mode-css-selector-face ((,class :inherit font-lock-keyword-face)))
- `(web-mode-css-string-face ((,class :inherit web-mode-string-face)))
- `(web-mode-css-variable-face ((,class :foreground ,fg-special-warm)))
- `(web-mode-current-column-highlight-face ((,class :background ,bg-alt)))
- `(web-mode-current-element-highlight-face ((,class :inherit modus-themes-special-mild)))
- `(web-mode-doctype-face ((,class :inherit modus-themes-slant :foreground ,fg-special-cold)))
- `(web-mode-error-face ((,class :inherit modus-themes-intense-red)))
- `(web-mode-filter-face ((,class :inherit font-lock-function-name-face)))
- `(web-mode-folded-face ((,class :underline t)))
- `(web-mode-function-call-face ((,class :inherit font-lock-function-name-face)))
- `(web-mode-function-name-face ((,class :inherit font-lock-function-name-face)))
- `(web-mode-html-attr-custom-face ((,class :inherit font-lock-variable-name-face)))
- `(web-mode-html-attr-engine-face ((,class :foreground ,fg-main)))
- `(web-mode-html-attr-equal-face ((,class :foreground ,fg-main)))
- `(web-mode-html-attr-name-face ((,class :inherit font-lock-variable-name-face)))
- `(web-mode-html-attr-value-face ((,class :inherit font-lock-constant-face)))
- `(web-mode-html-entity-face ((,class :inherit font-lock-negation-char-face)))
- `(web-mode-html-tag-bracket-face ((,class :foreground ,fg-dim)))
- `(web-mode-html-tag-custom-face ((,class :inherit font-lock-function-name-face)))
- `(web-mode-html-tag-face ((,class :inherit font-lock-function-name-face)))
- `(web-mode-html-tag-namespaced-face ((,class :inherit font-lock-builtin-face)))
- `(web-mode-html-tag-unclosed-face ((,class :inherit error :underline t)))
- `(web-mode-inlay-face ((,class :background ,bg-alt)))
- `(web-mode-italic-face ((,class :inherit italic)))
- `(web-mode-javascript-comment-face ((,class :inherit web-mode-comment-face)))
- `(web-mode-javascript-string-face ((,class :inherit web-mode-string-face)))
- `(web-mode-json-comment-face ((,class :inherit web-mode-comment-face)))
- `(web-mode-json-context-face ((,class :inherit font-lock-builtin-face)))
- `(web-mode-json-key-face ((,class :foreground ,blue-nuanced-fg)))
- `(web-mode-json-string-face ((,class :inherit web-mode-string-face)))
- `(web-mode-jsx-depth-1-face ((,class :background ,blue-intense-bg :foreground ,fg-main)))
- `(web-mode-jsx-depth-2-face ((,class :background ,blue-subtle-bg :foreground ,fg-main)))
- `(web-mode-jsx-depth-3-face ((,class :background ,bg-special-cold :foreground ,fg-special-cold)))
- `(web-mode-jsx-depth-4-face ((,class :background ,bg-alt :foreground ,blue-refine-fg)))
- `(web-mode-jsx-depth-5-face ((,class :background ,bg-alt :foreground ,blue-nuanced-fg)))
- `(web-mode-keyword-face ((,class :inherit font-lock-keyword-face)))
- `(web-mode-param-name-face ((,class :inherit font-lock-function-name-face)))
- `(web-mode-part-comment-face ((,class :inherit web-mode-comment-face)))
- `(web-mode-part-face ((,class :inherit web-mode-block-face)))
- `(web-mode-part-string-face ((,class :inherit web-mode-string-face)))
- `(web-mode-preprocessor-face ((,class :inherit font-lock-preprocessor-face)))
- `(web-mode-script-face ((,class :inherit web-mode-part-face)))
- `(web-mode-sql-keyword-face ((,class :inherit font-lock-negation-char-face)))
- `(web-mode-string-face ((,class :inherit font-lock-string-face)))
- `(web-mode-style-face ((,class :inherit web-mode-part-face)))
- `(web-mode-symbol-face ((,class :inherit font-lock-constant-face)))
- `(web-mode-type-face ((,class :inherit font-lock-builtin-face)))
- `(web-mode-underline-face ((,class :underline t)))
- `(web-mode-variable-name-face ((,class :inherit font-lock-variable-name-face)))
- `(web-mode-warning-face ((,class :inherit font-lock-warning-face)))
- `(web-mode-whitespace-face ((,class :background ,bg-whitespace :foreground ,fg-whitespace)))
+ `(web-mode-annotation-face ((,c :inherit web-mode-comment-face)))
+ `(web-mode-annotation-html-face ((,c :inherit web-mode-comment-face)))
+ `(web-mode-annotation-tag-face ((,c :inherit web-mode-comment-face :underline t)))
+ `(web-mode-block-attr-name-face ((,c :inherit font-lock-constant-face)))
+ `(web-mode-block-attr-value-face ((,c :inherit font-lock-type-face)))
+ `(web-mode-block-comment-face ((,c :inherit web-mode-comment-face)))
+ `(web-mode-block-control-face ((,c :inherit font-lock-builtin-face)))
+ `(web-mode-block-delimiter-face ((,c :foreground ,fg-main)))
+ `(web-mode-block-face ((,c :background ,bg-dim)))
+ `(web-mode-block-string-face ((,c :inherit web-mode-string-face)))
+ `(web-mode-bold-face ((,c :inherit bold)))
+ `(web-mode-builtin-face ((,c :inherit font-lock-builtin-face)))
+ `(web-mode-comment-face ((,c :inherit font-lock-comment-face)))
+ `(web-mode-comment-keyword-face ((,c :inherit font-lock-warning-face)))
+ `(web-mode-constant-face ((,c :inherit font-lock-constant-face)))
+ `(web-mode-css-at-rule-face ((,c :inherit font-lock-constant-face)))
+ `(web-mode-css-color-face ((,c :inherit font-lock-builtin-face)))
+ `(web-mode-css-comment-face ((,c :inherit web-mode-comment-face)))
+ `(web-mode-css-function-face ((,c :inherit font-lock-builtin-face)))
+ `(web-mode-css-priority-face ((,c :inherit font-lock-warning-face)))
+ `(web-mode-css-property-name-face ((,c :inherit font-lock-keyword-face)))
+ `(web-mode-css-pseudo-class-face ((,c :inherit font-lock-doc-face)))
+ `(web-mode-css-selector-face ((,c :inherit font-lock-keyword-face)))
+ `(web-mode-css-string-face ((,c :inherit web-mode-string-face)))
+ `(web-mode-css-variable-face ((,c :inherit font-lock-variable-name-face)))
+ `(web-mode-current-column-highlight-face ((,c :background ,bg-inactive)))
+ `(web-mode-current-element-highlight-face ((,c :inherit modus-themes-cyan-subtle)))
+ `(web-mode-doctype-face ((,c :inherit font-lock-doc-face)))
+ `(web-mode-error-face ((,c :inherit error)))
+ `(web-mode-filter-face ((,c :inherit font-lock-function-name-face)))
+ `(web-mode-folded-face ((,c :underline t)))
+ `(web-mode-function-call-face ((,c :inherit font-lock-function-name-face)))
+ `(web-mode-function-name-face ((,c :inherit font-lock-function-name-face)))
+ `(web-mode-html-attr-custom-face ((,c :inherit font-lock-variable-name-face)))
+ `(web-mode-html-attr-engine-face ((,c :foreground ,fg-main)))
+ `(web-mode-html-attr-equal-face ((,c :foreground ,fg-main)))
+ `(web-mode-html-attr-name-face ((,c :inherit font-lock-variable-name-face)))
+ `(web-mode-html-attr-value-face ((,c :inherit font-lock-constant-face)))
+ `(web-mode-html-entity-face ((,c :inherit font-lock-negation-char-face)))
+ `(web-mode-html-tag-bracket-face ((,c :foreground ,fg-dim)))
+ `(web-mode-html-tag-custom-face ((,c :inherit font-lock-function-name-face)))
+ `(web-mode-html-tag-face ((,c :inherit font-lock-function-name-face)))
+ `(web-mode-html-tag-namespaced-face ((,c :inherit font-lock-builtin-face)))
+ `(web-mode-html-tag-unclosed-face ((,c :inherit error :underline t)))
+ `(web-mode-inlay-face ((,c :background ,bg-inactive)))
+ `(web-mode-italic-face ((,c :inherit italic)))
+ `(web-mode-javascript-comment-face ((,c :inherit web-mode-comment-face)))
+ `(web-mode-javascript-string-face ((,c :inherit web-mode-string-face)))
+ `(web-mode-json-comment-face ((,c :inherit web-mode-comment-face)))
+ `(web-mode-json-context-face ((,c :inherit font-lock-builtin-face)))
+ `(web-mode-json-key-face ((,c :foreground ,blue-faint)))
+ `(web-mode-json-string-face ((,c :inherit web-mode-string-face)))
+ `(web-mode-keyword-face ((,c :inherit font-lock-keyword-face)))
+ `(web-mode-param-name-face ((,c :inherit font-lock-function-name-face)))
+ `(web-mode-part-comment-face ((,c :inherit web-mode-comment-face)))
+ `(web-mode-part-face ((,c :inherit web-mode-block-face)))
+ `(web-mode-part-string-face ((,c :inherit web-mode-string-face)))
+ `(web-mode-preprocessor-face ((,c :inherit font-lock-preprocessor-face)))
+ `(web-mode-script-face ((,c :inherit web-mode-part-face)))
+ `(web-mode-sql-keyword-face ((,c :inherit font-lock-negation-char-face)))
+ `(web-mode-string-face ((,c :inherit font-lock-string-face)))
+ `(web-mode-style-face ((,c :inherit web-mode-part-face)))
+ `(web-mode-symbol-face ((,c :inherit font-lock-constant-face)))
+ `(web-mode-type-face ((,c :inherit font-lock-builtin-face)))
+ `(web-mode-underline-face ((,c :underline t)))
+ `(web-mode-variable-name-face ((,c :inherit font-lock-variable-name-face)))
+ `(web-mode-warning-face ((,c :inherit warning)))
+ `(web-mode-whitespace-face ((,c :background ,bg-inactive)))
;;;;; wgrep
- `(wgrep-delete-face ((,class :inherit warning)))
- `(wgrep-done-face ((,class :inherit success)))
- `(wgrep-face ((,class :inherit bold)))
- `(wgrep-file-face ((,class :foreground ,fg-special-warm)))
- `(wgrep-reject-face ((,class :inherit error)))
+ `(wgrep-delete-face ((,c :inherit warning)))
+ `(wgrep-done-face ((,c :inherit success)))
+ `(wgrep-face ((,c :inherit bold)))
+ `(wgrep-file-face ((,c :foreground ,fg-alt)))
+ `(wgrep-reject-face ((,c :inherit error)))
;;;;; which-function-mode
- `(which-func ((,class :foreground ,magenta-active)))
+ `(which-func ((,c :inherit bold :foreground ,modeline-info))) ; same as `breadcrumb-imenu-leaf-face'
;;;;; which-key
- `(which-key-command-description-face ((,class :foreground ,fg-main)))
- `(which-key-group-description-face ((,class :foreground ,magenta-alt)))
- `(which-key-highlighted-command-face ((,class :foreground ,yellow :underline t)))
- `(which-key-key-face ((,class :inherit modus-themes-key-binding)))
- `(which-key-local-map-description-face ((,class :foreground ,fg-main)))
- `(which-key-note-face ((,class :foreground ,fg-special-warm)))
- `(which-key-separator-face ((,class :inherit shadow)))
- `(which-key-special-key-face ((,class :inherit bold :foreground ,red-alt)))
+ `(which-key-command-description-face ((,c :foreground ,fg-main)))
+ `(which-key-group-description-face ((,c :foreground ,type)))
+ `(which-key-highlighted-command-face ((,c :foreground ,warning :underline t)))
+ `(which-key-key-face ((,c :inherit modus-themes-key-binding)))
+ `(which-key-local-map-description-face ((,c :foreground ,fg-main)))
+ `(which-key-note-face ((,c :inherit shadow)))
+ `(which-key-separator-face ((,c :inherit shadow)))
+ `(which-key-special-key-face ((,c :inherit error)))
;;;;; whitespace-mode
- `(whitespace-big-indent ((,class :inherit modus-themes-subtle-red)))
- `(whitespace-empty ((,class :inherit modus-themes-intense-magenta)))
- `(whitespace-hspace ((,class :background ,bg-whitespace :foreground ,fg-whitespace)))
- `(whitespace-indentation ((,class :background ,bg-whitespace :foreground ,fg-whitespace)))
- `(whitespace-line ((,class :inherit modus-themes-subtle-yellow)))
- `(whitespace-newline ((,class :background ,bg-whitespace :foreground ,fg-whitespace)))
- `(whitespace-space ((,class :background ,bg-whitespace :foreground ,fg-whitespace)))
- `(whitespace-space-after-tab ((,class :inherit modus-themes-subtle-magenta)))
- `(whitespace-space-before-tab ((,class :inherit modus-themes-subtle-cyan)))
- `(whitespace-tab ((,class :background ,bg-whitespace :foreground ,fg-whitespace)))
- `(whitespace-trailing ((,class :inherit modus-themes-intense-red)))
+ `(whitespace-big-indent ((,c :background ,bg-space-err)))
+ `(whitespace-empty ((,c :background ,bg-space)))
+ `(whitespace-hspace ((,c :background ,bg-space :foreground ,fg-space)))
+ `(whitespace-indentation ((,c :background ,bg-space :foreground ,fg-space)))
+ `(whitespace-line ((,c :background ,bg-space :foreground ,warning)))
+ `(whitespace-newline ((,c :background ,bg-space :foreground ,fg-space)))
+ `(whitespace-space ((,c :background ,bg-space :foreground ,fg-space)))
+ `(whitespace-space-after-tab ((,c :inherit warning :background ,bg-space)))
+ `(whitespace-space-before-tab ((,c :inherit warning :background ,bg-space)))
+ `(whitespace-tab ((,c :background ,bg-space :foreground ,fg-space)))
+ `(whitespace-trailing ((,c :background ,bg-space-err)))
;;;;; window-divider-mode
- `(window-divider ((,class :foreground ,fg-window-divider-inner)))
- `(window-divider-first-pixel ((,class :foreground ,fg-window-divider-outer)))
- `(window-divider-last-pixel ((,class :foreground ,fg-window-divider-outer)))
-;;;;; winum
- `(winum-face ((,class :inherit modus-themes-bold :foreground ,cyan-active)))
+ `(window-divider ((,c :foreground ,border)))
+ `(window-divider-first-pixel ((,c :foreground ,bg-inactive)))
+ `(window-divider-last-pixel ((,c :foreground ,bg-inactive)))
+;;;;; widget
+ `(widget-button ((,c :inherit bold :foreground ,fg-link)))
+ `(widget-button-pressed ((,c :inherit widget-button :foreground ,fg-link-visited)))
+ `(widget-documentation ((,c :inherit font-lock-doc-face)))
+ `(widget-field ((,c :background ,bg-inactive :foreground ,fg-main :extend nil)))
+ `(widget-inactive ((,c :background ,bg-button-inactive :foreground ,fg-button-inactive)))
+ `(widget-single-line-field ((,c :inherit widget-field)))
;;;;; writegood-mode
- `(writegood-duplicates-face ((,class :background ,bg-alt :foreground ,red-alt :underline t)))
- `(writegood-passive-voice-face ((,class :inherit modus-themes-lang-warning)))
- `(writegood-weasels-face ((,class :inherit modus-themes-lang-error)))
+ `(writegood-duplicates-face ((,c :inherit modus-themes-lang-error)))
+ `(writegood-passive-voice-face ((,c :inherit modus-themes-lang-warning)))
+ `(writegood-weasels-face ((,c :inherit modus-themes-lang-warning)))
;;;;; woman
- `(woman-addition ((,class :foreground ,magenta-alt-other)))
- `(woman-bold ((,class :inherit bold :foreground ,magenta-alt)))
- `(woman-italic ((,class :inherit italic :foreground ,cyan)))
- `(woman-unknown ((,class :foreground ,green-alt)))
+ `(woman-addition ((,c :foreground ,accent-2)))
+ `(woman-bold ((,c :inherit bold :foreground ,accent-0)))
+ `(woman-italic ((,c :inherit italic :foreground ,accent-1)))
+ `(woman-unknown ((,c :foreground ,accent-3)))
;;;;; xah-elisp-mode
- `(xah-elisp-at-symbol ((,class :inherit font-lock-warning-face)))
- `(xah-elisp-cap-variable ((,class :inherit font-lock-preprocessor-face)))
- `(xah-elisp-command-face ((,class :inherit font-lock-type-face)))
- `(xah-elisp-dollar-symbol ((,class :inherit font-lock-variable-name-face)))
-;;;;; xref
- `(xref-file-header ((,class :inherit bold :foreground ,fg-special-cold)))
- `(xref-line-number ((,class :inherit shadow)))
- `(xref-match ((,class :inherit match)))
+ `(xah-elisp-at-symbol ((,c :inherit font-lock-warning-face)))
+ `(xah-elisp-cap-variable ((,c :inherit font-lock-preprocessor-face)))
+ `(xah-elisp-command-face ((,c :inherit font-lock-type-face)))
+ `(xah-elisp-dollar-symbol ((,c :inherit font-lock-variable-name-face)))
;;;;; yaml-mode
- `(yaml-tab-face ((,class :inherit modus-themes-intense-red)))
+ `(yaml-tab-face ((,c :background ,bg-space-err)))
;;;;; yasnippet
- `(yas-field-highlight-face ((,class :background ,bg-hl-alt-intense)))
+ `(yas-field-highlight-face ((,c :inherit highlight)))
;;;;; ztree
- `(ztreep-arrow-face ((,class :foreground ,fg-inactive)))
- `(ztreep-diff-header-face ((,class :inherit bold :height 1.2 :foreground ,fg-special-cold)))
- `(ztreep-diff-header-small-face ((,class :foreground ,fg-main)))
- `(ztreep-diff-model-add-face ((,class :inherit modus-themes-grue)))
- `(ztreep-diff-model-diff-face ((,class :foreground ,red)))
- `(ztreep-diff-model-ignored-face ((,class :inherit shadow :strike-through t)))
- `(ztreep-diff-model-normal-face ((,class :inherit shadow)))
- `(ztreep-expand-sign-face ((,class :inherit ztreep-arrow-face)))
- `(ztreep-header-face ((,class :inherit bold :height 1.2 :foreground ,fg-special-cold)))
- `(ztreep-leaf-face ((,class :foreground ,cyan)))
- `(ztreep-node-count-children-face ((,class :foreground ,fg-special-warm)))
- `(ztreep-node-face ((,class :foreground ,fg-main))))
+ `(ztreep-arrow-face ((,c :inherit shadow)))
+ `(ztreep-diff-header-face ((,c :inherit modus-themes-heading-0)))
+ `(ztreep-diff-header-small-face ((,c :inherit font-lock-doc-face)))
+ `(ztreep-diff-model-add-face ((,c :foreground ,info)))
+ `(ztreep-diff-model-diff-face ((,c :foreground ,err)))
+ `(ztreep-diff-model-ignored-face ((,c :foreground ,fg-dim :strike-through t)))
+ `(ztreep-diff-model-normal-face (( )))
+ `(ztreep-expand-sign-face ((,c :inherit shadow)))
+ `(ztreep-header-face ((,c :inherit modus-themes-heading-0)))
+ `(ztreep-leaf-face (( )))
+ `(ztreep-node-count-children-face ((,c :inherit (shadow italic))))
+ `(ztreep-node-face ((,c :foreground ,accent-0))))
"Face specs for use with `modus-themes-theme'.")
(defconst modus-themes-custom-variables
'(
;;;; ansi-colors
`(ansi-color-faces-vector [default bold shadow italic underline success warning error])
- `(ansi-color-names-vector ["gray35" ,red ,green ,yellow ,blue ,magenta ,cyan "gray65"])
-;;;; awesome-tray
- `(awesome-tray-mode-line-active-color ,blue)
- `(awesome-tray-mode-line-inactive-color ,bg-active)
+ `(ansi-color-names-vector ["#595959" ,red ,green ,yellow ,blue ,magenta ,cyan "#a6a6a6"])
;;;; chart
`(chart-face-color-list
- '( ,red-graph-0-bg ,green-graph-0-bg ,yellow-graph-0-bg ,blue-graph-0-bg ,magenta-graph-0-bg ,cyan-graph-0-bg
- ,red-graph-1-bg ,green-graph-1-bg ,yellow-graph-1-bg ,blue-graph-1-bg ,magenta-graph-1-bg ,cyan-graph-1-bg))
+ '( ,bg-graph-red-0 ,bg-graph-green-0 ,bg-graph-yellow-0 ,bg-graph-blue-0 ,bg-graph-magenta-0 ,bg-graph-cyan-0
+ ,bg-graph-red-1 ,bg-graph-green-1 ,bg-graph-yellow-1 ,bg-graph-blue-1 ,bg-graph-magenta-1 ,bg-graph-cyan-1))
;;;; exwm
- `(exwm-floating-border-color ,fg-window-divider-inner)
+ `(exwm-floating-border-color ,border)
;;;; flymake fringe indicators
- `(flymake-error-bitmap '(flymake-double-exclamation-mark modus-themes-fringe-red))
- `(flymake-warning-bitmap '(exclamation-mark modus-themes-fringe-yellow))
- `(flymake-note-bitmap '(exclamation-mark modus-themes-fringe-cyan))
+ `(flymake-error-bitmap '(flymake-double-exclamation-mark modus-themes-prominent-error))
+ `(flymake-warning-bitmap '(exclamation-mark modus-themes-prominent-warning))
+ `(flymake-note-bitmap '(exclamation-mark modus-themes-prominent-note))
;;;; highlight-changes
`(highlight-changes-colors nil)
`(highlight-changes-face-list '(success warning error bold bold-italic))
;;;; ibuffer
`(ibuffer-deletion-face 'modus-themes-mark-del)
- `(ibuffer-filter-group-name-face 'modus-themes-pseudo-header)
+ `(ibuffer-filter-group-name-face 'bold)
`(ibuffer-marked-face 'modus-themes-mark-sel)
`(ibuffer-title-face 'default)
;;;; hl-todo
`(hl-todo-keyword-faces
- '(("HOLD" . ,yellow-alt)
- ("TODO" . ,magenta)
- ("NEXT" . ,magenta-alt-other)
- ("THEM" . ,magenta-alt)
- ("PROG" . ,cyan)
- ("OKAY" . ,cyan-alt)
- ("DONT" . ,green-alt)
- ("FAIL" . ,red)
- ("BUG" . ,red)
- ("DONE" . ,green)
- ("NOTE" . ,yellow-alt-other)
- ("KLUDGE" . ,yellow)
- ("HACK" . ,yellow)
- ("TEMP" . ,red-nuanced-fg)
- ("FIXME" . ,red-alt-other)
- ("XXX+" . ,red-alt)
- ("REVIEW" . ,cyan-alt-other)
- ("DEPRECATED" . ,blue-nuanced-fg)))
-;;;; mini-modeline
- `(mini-modeline-face-attr '(:background unspecified))
+ '(("HOLD" . ,warning)
+ ("TODO" . ,err)
+ ("NEXT" . ,fg-alt)
+ ("THEM" . ,fg-alt)
+ ("PROG" . ,info)
+ ("OKAY" . ,info)
+ ("DONT" . ,warning)
+ ("FAIL" . ,err)
+ ("BUG" . ,err)
+ ("DONE" . ,info)
+ ("NOTE" . ,warning)
+ ("KLUDGE" . ,warning)
+ ("HACK" . ,warning)
+ ("TEMP" . ,warning)
+ ("FIXME" . ,err)
+ ("XXX+" . ,err)
+ ("REVIEW" . ,info)
+ ("DEPRECATED" . ,info)))
;;;; pdf-tools
- `(pdf-view-midnight-colors
- '(,fg-main . ,bg-dim))
-;;;; 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)
- " "
- "]"))
+ `(pdf-view-midnight-colors '(,fg-main . ,bg-dim))
+;;;; rcirc-color
+ `(rcirc-colors
+ '(modus-themes-fg-red
+ modus-themes-fg-green
+ modus-themes-fg-blue
+ modus-themes-fg-yellow
+ modus-themes-fg-magenta
+ modus-themes-fg-cyan
+ modus-themes-fg-red-warmer
+ modus-themes-fg-green-warmer
+ modus-themes-fg-blue-warmer
+ modus-themes-fg-yellow-warmer
+ modus-themes-fg-magenta-warmer
+ modus-themes-fg-cyan-warmer
+ modus-themes-fg-red-cooler
+ modus-themes-fg-green-cooler
+ modus-themes-fg-blue-cooler
+ modus-themes-fg-yellow-cooler
+ modus-themes-fg-magenta-cooler
+ modus-themes-fg-cyan-cooler
+ modus-themes-fg-red-faint
+ modus-themes-fg-green-faint
+ modus-themes-fg-blue-faint
+ modus-themes-fg-yellow-faint
+ modus-themes-fg-magenta-faint
+ modus-themes-fg-cyan-faint
+ modus-themes-fg-red-intense
+ modus-themes-fg-green-intense
+ modus-themes-fg-blue-intense
+ modus-themes-fg-yellow-intense
+ modus-themes-fg-magenta-intense
+ modus-themes-fg-cyan-intense))
+;;;; rustic-ansi-faces
+ `(rustic-ansi-faces
+ [,fg-term-black
+ ,fg-term-red
+ ,fg-term-green
+ ,fg-term-yellow
+ ,fg-term-blue
+ ,fg-term-magenta
+ ,fg-term-cyan
+ ,fg-term-white])
;;;; 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"])
- (if (or (eq modus-themes-org-blocks 'tinted-background)
- (eq modus-themes-org-blocks 'rainbow))
- `(org-src-block-faces
- `(("emacs-lisp" modus-themes-nuanced-magenta)
- ("elisp" modus-themes-nuanced-magenta)
- ("clojure" modus-themes-nuanced-magenta)
- ("clojurescript" modus-themes-nuanced-magenta)
- ("c" modus-themes-nuanced-blue)
- ("c++" modus-themes-nuanced-blue)
- ("sh" modus-themes-nuanced-green)
- ("shell" modus-themes-nuanced-green)
- ("html" modus-themes-nuanced-yellow)
- ("xml" modus-themes-nuanced-yellow)
- ("css" modus-themes-nuanced-red)
- ("scss" modus-themes-nuanced-red)
- ("python" modus-themes-nuanced-green)
- ("ipython" modus-themes-nuanced-magenta)
- ("r" modus-themes-nuanced-cyan)
- ("yaml" modus-themes-nuanced-cyan)
- ("conf" modus-themes-nuanced-cyan)
- ("docker" modus-themes-nuanced-cyan)))
- `(org-src-block-faces '())))
+ `(xterm-color-names
+ [,fg-term-black
+ ,fg-term-red
+ ,fg-term-green
+ ,fg-term-yellow
+ ,fg-term-blue
+ ,fg-term-magenta
+ ,fg-term-cyan
+ ,fg-term-white])
+ `(xterm-color-names-bright
+ [,fg-term-black-bright
+ ,fg-term-red-bright
+ ,fg-term-green-bright
+ ,fg-term-yellow-bright
+ ,fg-term-blue-bright
+ ,fg-term-magenta-bright
+ ,fg-term-cyan-bright
+ ,fg-term-white-bright]))
"Custom variables for `modus-themes-theme'.")
+;;; Theme macros
+
+;;;; Instantiate a Modus theme
+
+;;;###autoload
+(defmacro modus-themes-theme (name palette &optional overrides)
+ "Bind NAME's color PALETTE around face specs and variables.
+Face specifications are passed to `custom-theme-set-faces'.
+While variables are handled by `custom-theme-set-variables'.
+Those are stored in `modus-themes-faces' and
+`modus-themes-custom-variables' respectively.
+
+Optional OVERRIDES are appended to PALETTE, overriding
+corresponding entries."
+ (declare (indent 0))
+ (let ((sym (gensym))
+ (colors (mapcar #'car (symbol-value palette))))
+ `(let* ((c '((class color) (min-colors 256)))
+ (,sym (modus-themes--palette-value ',name ',overrides))
+ ,@(mapcar (lambda (color)
+ (list color
+ `(modus-themes--retrieve-palette-value ',color ,sym)))
+ colors))
+ (ignore c ,@colors) ; Silence unused variable warnings
+ (custom-theme-set-faces ',name ,@modus-themes-faces)
+ (custom-theme-set-variables ',name ,@modus-themes-custom-variables))))
+
+;;;; Use theme colors
+
+(defmacro modus-themes-with-colors (&rest body)
+ "Evaluate BODY with colors from current palette bound."
+ (declare (indent 0))
+ (let* ((sym (gensym))
+ ;; NOTE 2022-08-23: We just give it a sample palette at this
+ ;; stage. It only needs to collect each car. Then we
+ ;; instantiate the actual theme's palette. We have to do this
+ ;; otherwise the macro does not work properly when called from
+ ;; inside a function.
+ (colors (mapcar #'car (modus-themes--current-theme-palette))))
+ `(let* ((c '((class color) (min-colors 256)))
+ (,sym (modus-themes--current-theme-palette :overrides))
+ ,@(mapcar (lambda (color)
+ (list color
+ `(modus-themes--retrieve-palette-value ',color ,sym)))
+ colors))
+ (ignore c ,@colors) ; Silence unused variable warnings
+ ,@body)))
+
+;;;; Add themes from package to path
+
;;;###autoload
(when load-file-name
(let ((dir (file-name-directory load-file-name)))
diff --git a/etc/themes/modus-vivendi-deuteranopia-theme.el b/etc/themes/modus-vivendi-deuteranopia-theme.el
new file mode 100644
index 00000000000..d721dba09a9
--- /dev/null
+++ b/etc/themes/modus-vivendi-deuteranopia-theme.el
@@ -0,0 +1,515 @@
+;;; modus-vivendi-deuteranopia-theme.el --- Deuteranopia-optimized theme with a black background -*- lexical-binding:t -*-
+
+;; Copyright (C) 2019-2024 Free Software Foundation, Inc.
+
+;; Author: Protesilaos Stavrou <info@protesilaos.com>
+;; Maintainer: Protesilaos Stavrou <info@protesilaos.com>
+;; URL: https://github.com/protesilaos/modus-themes
+;; Keywords: faces, theme, accessibility
+
+;; This file is part of GNU Emacs.
+
+;; GNU Emacs is free software: you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+;;
+;; GNU Emacs is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+;;
+;; You should have received a copy of the GNU General Public License
+;; along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>.
+
+;;; Commentary:
+;;
+;; The Modus themes conform with the highest standard for
+;; color-contrast accessibility between background and foreground
+;; values (WCAG AAA). Please refer to the official Info manual for
+;; further documentation (distributed with the themes, or available
+;; at: <https://protesilaos.com/emacs/modus-themes>).
+
+;;; Code:
+
+
+
+(eval-and-compile
+ (unless (and (fboundp 'require-theme)
+ load-file-name
+ (equal (file-name-directory load-file-name)
+ (expand-file-name "themes/" data-directory))
+ (require-theme 'modus-themes t))
+ (require 'modus-themes))
+
+;;;###theme-autoload
+ (deftheme modus-vivendi-deuteranopia
+ "Deuteranopia-optimized theme with a black background.
+This variant is optimized for users with red-green color
+deficiency (deuteranopia). It 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 (WCAG AAA
+standard)."
+ :background-mode 'dark
+ :kind 'color-scheme
+ :family 'modus)
+
+ (defconst modus-vivendi-deuteranopia-palette
+ '(
+;;; Basic values
+
+ (bg-main "#000000")
+ (bg-dim "#1e1e1e")
+ (fg-main "#ffffff")
+ (fg-dim "#989898")
+ (fg-alt "#c6daff")
+ (bg-active "#535353")
+ (bg-inactive "#303030")
+ (border "#646464")
+
+;;; Common accent foregrounds
+
+ (red "#ff5f59")
+ (red-warmer "#ff6b55")
+ (red-cooler "#ff7f9f")
+ (red-faint "#ff9580")
+ (red-intense "#ff5f5f")
+ (green "#44bc44")
+ (green-warmer "#70b900")
+ (green-cooler "#00c06f")
+ (green-faint "#88ca9f")
+ (green-intense "#44df44")
+ (yellow "#cabf00")
+ (yellow-warmer "#ffa00f")
+ (yellow-cooler "#d8af7a")
+ (yellow-faint "#d2b580")
+ (yellow-intense "#efef00")
+ (blue "#2fafff")
+ (blue-warmer "#79a8ff")
+ (blue-cooler "#00bcff")
+ (blue-faint "#82b0ec")
+ (blue-intense "#338fff")
+ (magenta "#feacd0")
+ (magenta-warmer "#f78fe7")
+ (magenta-cooler "#b6a0ff")
+ (magenta-faint "#caa6df")
+ (magenta-intense "#ff66ff")
+ (cyan "#00d3d0")
+ (cyan-warmer "#4ae2f0")
+ (cyan-cooler "#6ae4b9")
+ (cyan-faint "#9ac8e0")
+ (cyan-intense "#00eff0")
+
+;;; Uncommon accent foregrounds
+
+ (rust "#db7b5f")
+ (gold "#c0965b")
+ (olive "#9cbd6f")
+ (slate "#76afbf")
+ (indigo "#9099d9")
+ (maroon "#cf7fa7")
+ (pink "#d09dc0")
+
+;;; Common accent backgrounds
+
+ (bg-red-intense "#9d1f1f")
+ (bg-green-intense "#2f822f")
+ (bg-yellow-intense "#7a6100")
+ (bg-blue-intense "#1640b0")
+ (bg-magenta-intense "#7030af")
+ (bg-cyan-intense "#2266ae")
+
+ (bg-red-subtle "#620f2a")
+ (bg-green-subtle "#00422a")
+ (bg-yellow-subtle "#4a4000")
+ (bg-blue-subtle "#242679")
+ (bg-magenta-subtle "#552f5f")
+ (bg-cyan-subtle "#004065")
+
+ (bg-red-nuanced "#3a0c14")
+ (bg-green-nuanced "#092f1f")
+ (bg-yellow-nuanced "#381d0f")
+ (bg-blue-nuanced "#12154a")
+ (bg-magenta-nuanced "#2f0c3f")
+ (bg-cyan-nuanced "#042837")
+
+;;; Uncommon accent backgrounds
+
+ (bg-ochre "#442c2f")
+ (bg-lavender "#38325c")
+ (bg-sage "#0f3d30")
+
+;;; Graphs
+
+ (bg-graph-red-0 "#bf6000")
+ (bg-graph-red-1 "#733500")
+ (bg-graph-green-0 "#6fbf8f")
+ (bg-graph-green-1 "#2f5f4f")
+ (bg-graph-yellow-0 "#c1c00a")
+ (bg-graph-yellow-1 "#7f6640")
+ (bg-graph-blue-0 "#0f90ef")
+ (bg-graph-blue-1 "#1f2f8f")
+ (bg-graph-magenta-0 "#7f7f8e")
+ (bg-graph-magenta-1 "#4f4f5f")
+ (bg-graph-cyan-0 "#376f9a")
+ (bg-graph-cyan-1 "#00404f")
+
+;;; Special purpose
+
+ (bg-completion "#2f447f")
+ (bg-hover "#45605e")
+ (bg-hover-secondary "#654a39")
+ (bg-hl-line "#2f3849")
+ (bg-region "#5a5a5a")
+ (fg-region "#ffffff")
+
+ (bg-char-0 "#0050af")
+ (bg-char-1 "#7f1f7f")
+ (bg-char-2 "#625a00")
+
+ (bg-mode-line-active "#2a2a6a")
+ (fg-mode-line-active "#f0f0f0")
+ (border-mode-line-active "#8080a7")
+ (bg-mode-line-inactive "#2d2d2d")
+ (fg-mode-line-inactive "#969696")
+ (border-mode-line-inactive "#606060")
+
+ (modeline-err "#e5bf00")
+ (modeline-warning "#c0cf35")
+ (modeline-info "#abeadf")
+
+ (bg-tab-bar "#313131")
+ (bg-tab-current "#000000")
+ (bg-tab-other "#545454")
+
+;;; Diffs
+
+ (bg-added "#003066")
+ (bg-added-faint "#001a4f")
+ (bg-added-refine "#0f4a77")
+ (bg-added-fringe "#006fff")
+ (fg-added "#c4d5ff")
+ (fg-added-intense "#8080ff")
+
+ (bg-changed "#2f123f")
+ (bg-changed-faint "#1f022f")
+ (bg-changed-refine "#3f325f")
+ (bg-changed-fringe "#7f55a0")
+ (fg-changed "#e3cfff")
+ (fg-changed-intense "#cf9fe2")
+
+ (bg-removed "#3d3d00")
+ (bg-removed-faint "#281f00")
+ (bg-removed-refine "#555500")
+ (bg-removed-fringe "#d0c03f")
+ (fg-removed "#d4d48f")
+ (fg-removed-intense "#d0b05f")
+
+ (bg-diff-context "#1a1a1a")
+
+;;; Paren match
+
+ (bg-paren-match "#2f7f9f")
+ (fg-paren-match fg-main)
+ (bg-paren-expression "#453040")
+ (underline-paren-match unspecified)
+
+;;; Mappings
+
+;;;; General mappings
+
+ (fringe bg-dim)
+ (cursor yellow-intense)
+
+ (keybind blue-cooler)
+ (name blue-cooler)
+ (identifier yellow-faint)
+
+ (err yellow-warmer)
+ (warning yellow)
+ (info blue)
+
+ (underline-err yellow-intense)
+ (underline-warning magenta-faint)
+ (underline-note cyan)
+
+ (bg-prominent-err bg-yellow-intense)
+ (fg-prominent-err fg-main)
+ (bg-prominent-warning bg-magenta-intense)
+ (fg-prominent-warning fg-main)
+ (bg-prominent-note bg-cyan-intense)
+ (fg-prominent-note fg-main)
+
+ (bg-active-argument bg-yellow-nuanced)
+ (fg-active-argument yellow-warmer)
+ (bg-active-value bg-blue-nuanced)
+ (fg-active-value blue-warmer)
+
+;;;; Code mappings
+
+ (builtin magenta-warmer)
+ (comment yellow-cooler)
+ (constant blue-cooler)
+ (docstring cyan-faint)
+ (docmarkup magenta-faint)
+ (fnname magenta)
+ (keyword magenta-cooler)
+ (preprocessor red-cooler)
+ (string blue-warmer)
+ (type cyan-cooler)
+ (variable cyan)
+ (rx-construct yellow-cooler)
+ (rx-backslash blue-cooler)
+
+;;;; Accent mappings
+
+ (accent-0 blue-cooler)
+ (accent-1 yellow)
+ (accent-2 cyan-cooler)
+ (accent-3 magenta-warmer)
+
+;;;; Button mappings
+
+ (fg-button-active fg-main)
+ (fg-button-inactive fg-dim)
+ (bg-button-active bg-active)
+ (bg-button-inactive bg-dim)
+
+;;;; Completion mappings
+
+ (fg-completion-match-0 blue-cooler)
+ (fg-completion-match-1 yellow)
+ (fg-completion-match-2 cyan-cooler)
+ (fg-completion-match-3 magenta-warmer)
+ (bg-completion-match-0 unspecified)
+ (bg-completion-match-1 unspecified)
+ (bg-completion-match-2 unspecified)
+ (bg-completion-match-3 unspecified)
+
+;;;; Date mappings
+
+ (date-common cyan)
+ (date-deadline yellow-warmer)
+ (date-event fg-alt)
+ (date-holiday yellow-warmer)
+ (date-holiday-other blue)
+ (date-now fg-main)
+ (date-range fg-alt)
+ (date-scheduled yellow-cooler)
+ (date-weekday cyan)
+ (date-weekend yellow-faint)
+
+;;;; Line number mappings
+
+ (fg-line-number-inactive fg-dim)
+ (fg-line-number-active fg-main)
+ (bg-line-number-inactive bg-dim)
+ (bg-line-number-active bg-active)
+
+;;;; Link mappings
+
+ (fg-link blue-warmer)
+ (bg-link unspecified)
+ (underline-link blue-warmer)
+
+ (fg-link-symbolic cyan)
+ (bg-link-symbolic unspecified)
+ (underline-link-symbolic cyan)
+
+ (fg-link-visited yellow-faint)
+ (bg-link-visited unspecified)
+ (underline-link-visited yellow-faint)
+
+;;;; Mail mappings
+
+ (mail-cite-0 blue-warmer)
+ (mail-cite-1 yellow-cooler)
+ (mail-cite-2 cyan-faint)
+ (mail-cite-3 yellow)
+ (mail-part blue)
+ (mail-recipient blue)
+ (mail-subject yellow-warmer)
+ (mail-other cyan-faint)
+
+;;;; Mark mappings
+
+ (bg-mark-delete bg-yellow-subtle)
+ (fg-mark-delete yellow)
+ (bg-mark-select bg-cyan-subtle)
+ (fg-mark-select cyan)
+ (bg-mark-other bg-magenta-subtle)
+ (fg-mark-other magenta-warmer)
+
+;;;; Prompt mappings
+
+ (fg-prompt blue)
+ (bg-prompt unspecified)
+
+;;;; Prose mappings
+
+ (bg-prose-block-delimiter bg-dim)
+ (fg-prose-block-delimiter fg-dim)
+ (bg-prose-block-contents bg-dim)
+
+ (bg-prose-code unspecified)
+ (fg-prose-code cyan-cooler)
+
+ (bg-prose-macro unspecified)
+ (fg-prose-macro magenta-cooler)
+
+ (bg-prose-verbatim unspecified)
+ (fg-prose-verbatim magenta-warmer)
+
+ (prose-done blue)
+ (prose-todo yellow-warmer)
+
+ (prose-metadata fg-dim)
+ (prose-metadata-value fg-alt)
+
+ (prose-table fg-alt)
+ (prose-table-formula yellow-warmer)
+
+ (prose-tag magenta-faint)
+
+;;;; Rainbow mappings
+
+ (rainbow-0 yellow-warmer)
+ (rainbow-1 blue)
+ (rainbow-2 yellow-cooler)
+ (rainbow-3 blue-warmer)
+ (rainbow-4 yellow)
+ (rainbow-5 cyan-warmer)
+ (rainbow-6 yellow-faint)
+ (rainbow-7 blue-faint)
+ (rainbow-8 magenta-faint)
+
+;;;; Search mappings
+
+ (bg-search-current bg-yellow-intense)
+ (bg-search-lazy bg-blue-intense)
+ (bg-search-replace bg-magenta-intense)
+
+ (bg-search-rx-group-0 bg-cyan-intense)
+ (bg-search-rx-group-1 bg-magenta-intense)
+ (bg-search-rx-group-2 bg-blue-subtle)
+ (bg-search-rx-group-3 bg-yellow-subtle)
+
+;;;; Space mappings
+
+ (bg-space unspecified)
+ (fg-space border)
+ (bg-space-err bg-yellow-intense)
+
+;;;; Terminal mappings
+
+ (bg-term-black "#000000")
+ (fg-term-black "#000000")
+ (bg-term-black-bright "#595959")
+ (fg-term-black-bright "#595959")
+
+ (bg-term-red red)
+ (fg-term-red red)
+ (bg-term-red-bright red-warmer)
+ (fg-term-red-bright red-warmer)
+
+ (bg-term-green green)
+ (fg-term-green green)
+ (bg-term-green-bright green-cooler)
+ (fg-term-green-bright green-cooler)
+
+ (bg-term-yellow yellow)
+ (fg-term-yellow yellow)
+ (bg-term-yellow-bright yellow-warmer)
+ (fg-term-yellow-bright yellow-warmer)
+
+ (bg-term-blue blue)
+ (fg-term-blue blue)
+ (bg-term-blue-bright blue-warmer)
+ (fg-term-blue-bright blue-warmer)
+
+ (bg-term-magenta magenta)
+ (fg-term-magenta magenta)
+ (bg-term-magenta-bright magenta-cooler)
+ (fg-term-magenta-bright magenta-cooler)
+
+ (bg-term-cyan cyan)
+ (fg-term-cyan cyan)
+ (bg-term-cyan-bright cyan-cooler)
+ (fg-term-cyan-bright cyan-cooler)
+
+ (bg-term-white "#a6a6a6")
+ (fg-term-white "#a6a6a6")
+ (bg-term-white-bright "#ffffff")
+ (fg-term-white-bright "#ffffff")
+
+;;;; Heading mappings
+
+ (fg-heading-0 cyan-cooler)
+ (fg-heading-1 fg-main)
+ (fg-heading-2 yellow-faint)
+ (fg-heading-3 blue-faint)
+ (fg-heading-4 magenta)
+ (fg-heading-5 green-faint)
+ (fg-heading-6 red-faint)
+ (fg-heading-7 cyan-faint)
+ (fg-heading-8 fg-dim)
+
+ (bg-heading-0 unspecified)
+ (bg-heading-1 unspecified)
+ (bg-heading-2 unspecified)
+ (bg-heading-3 unspecified)
+ (bg-heading-4 unspecified)
+ (bg-heading-5 unspecified)
+ (bg-heading-6 unspecified)
+ (bg-heading-7 unspecified)
+ (bg-heading-8 unspecified)
+
+ (overline-heading-0 unspecified)
+ (overline-heading-1 unspecified)
+ (overline-heading-2 unspecified)
+ (overline-heading-3 unspecified)
+ (overline-heading-4 unspecified)
+ (overline-heading-5 unspecified)
+ (overline-heading-6 unspecified)
+ (overline-heading-7 unspecified)
+ (overline-heading-8 unspecified))
+ "The entire palette of the `modus-vivendi-deuteranopia' theme.
+
+Named colors have the form (COLOR-NAME HEX-VALUE) with the former
+as a symbol and the latter as a string.
+
+Semantic color mappings have the form (MAPPING-NAME COLOR-NAME)
+with both as symbols. The latter is a named color that already
+exists in the palette and is associated with a HEX-VALUE.")
+
+ (defcustom modus-vivendi-deuteranopia-palette-overrides nil
+ "Overrides for `modus-vivendi-deuteranopia-palette'.
+
+Mirror the elements of the aforementioned palette, overriding
+their value.
+
+For overrides that are shared across all of the Modus themes,
+refer to `modus-themes-common-palette-overrides'.
+
+Theme-specific overrides take precedence over shared overrides.
+The idea of common overrides is to change semantic color
+mappings, such as to make the cursor red. Wherea theme-specific
+overrides can also be used to change the value of a named color,
+such as what hexadecimal RGB value the red-warmer symbol
+represents."
+ :group 'modus-themes
+ :package-version '(modus-themes . "4.0.0")
+ :version "30.1"
+ :type '(repeat (list symbol (choice symbol string)))
+ :set #'modus-themes--set-option
+ :initialize #'custom-initialize-default
+ :link '(info-link "(modus-themes) Palette overrides"))
+
+ (modus-themes-theme modus-vivendi-deuteranopia
+ modus-vivendi-deuteranopia-palette
+ modus-vivendi-deuteranopia-palette-overrides)
+
+ (provide-theme 'modus-vivendi-deuteranopia))
+
+;;; modus-vivendi-deuteranopia-theme.el ends here
diff --git a/etc/themes/modus-vivendi-theme.el b/etc/themes/modus-vivendi-theme.el
index 6ad2a737897..8b822974c15 100644
--- a/etc/themes/modus-vivendi-theme.el
+++ b/etc/themes/modus-vivendi-theme.el
@@ -1,13 +1,10 @@
-;;; modus-vivendi-theme.el --- Elegant, highly legible and customizable dark theme -*- lexical-binding:t -*-
+;;; modus-vivendi-theme.el --- Elegant, highly legible theme with a black background -*- lexical-binding:t -*-
-;; Copyright (C) 2019-2024 Free Software Foundation, Inc.
+;; Copyright (C) 2019-2024 Free Software Foundation, Inc.
;; Author: Protesilaos Stavrou <info@protesilaos.com>
-;; Maintainer: Modus-Themes Development <~protesilaos/modus-themes@lists.sr.ht>
-;; URL: https://git.sr.ht/~protesilaos/modus-themes
-;; Mailing-List: https://lists.sr.ht/~protesilaos/modus-themes
-;; Version: 3.0.0
-;; Package-Requires: ((emacs "27.1"))
+;; Maintainer: Protesilaos Stavrou <info@protesilaos.com>
+;; URL: https://github.com/protesilaos/modus-themes
;; Keywords: faces, theme, accessibility
;; This file is part of GNU Emacs.
@@ -27,26 +24,11 @@
;;; Commentary:
;;
-;; Modus Vivendi is the dark variant of the Modus themes (Modus Operandi
-;; is the light one). The themes are designed for color-contrast
-;; accessibility. More specifically:
-;;
-;; 1. Provide a consistent minimum contrast ratio between background
-;; and foreground values of 7:1 or higher. This meets the highest
-;; such accessibility criterion per the guidelines of the Worldwide
-;; Web Consortium's Working Group on Accessibility (WCAG AAA
-;; standard).
-;;
-;; 2. Offer as close to full face coverage as possible. The list is
-;; already quite long, with more additions to follow as part of the
-;; ongoing development process.
-;;
-;; For a complete view of the project, also refer to the following files
-;; (should be distributed in the same repository/directory as the
-;; current item):
-;;
-;; - modus-themes.el (Main code shared between the themes)
-;; - modus-operandi-theme.el (Light theme)
+;; The Modus themes conform with the highest standard for
+;; color-contrast accessibility between background and foreground
+;; values (WCAG AAA). Please refer to the official Info manual for
+;; further documentation (distributed with the themes, or available
+;; at: <https://protesilaos.com/emacs/modus-themes>).
;;; Code:
@@ -60,18 +42,472 @@
(require-theme 'modus-themes t))
(require 'modus-themes))
+;;;###theme-autoload
(deftheme modus-vivendi
- "Elegant, highly legible and customizable dark theme.
+ "Elegant, highly legible theme with a black background.
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 (WCAG AAA standard).")
+7:1 (WCAG AAA standard)."
+ :background-mode 'dark
+ :kind 'color-scheme
+ :family 'modus)
- (modus-themes-theme modus-vivendi)
+ (defconst modus-vivendi-palette
+ '(
+;;; Basic values
- (provide-theme 'modus-vivendi))
+ (bg-main "#000000")
+ (bg-dim "#1e1e1e")
+ (fg-main "#ffffff")
+ (fg-dim "#989898")
+ (fg-alt "#c6daff")
+ (bg-active "#535353")
+ (bg-inactive "#303030")
+ (border "#646464")
-;;;###theme-autoload
-(put 'modus-vivendi 'theme-properties '(:background-mode dark :kind color-scheme :family modus))
+;;; Common accent foregrounds
+
+ (red "#ff5f59")
+ (red-warmer "#ff6b55")
+ (red-cooler "#ff7f9f")
+ (red-faint "#ff9580")
+ (red-intense "#ff5f5f")
+ (green "#44bc44")
+ (green-warmer "#70b900")
+ (green-cooler "#00c06f")
+ (green-faint "#88ca9f")
+ (green-intense "#44df44")
+ (yellow "#d0bc00")
+ (yellow-warmer "#fec43f")
+ (yellow-cooler "#dfaf7a")
+ (yellow-faint "#d2b580")
+ (yellow-intense "#efef00")
+ (blue "#2fafff")
+ (blue-warmer "#79a8ff")
+ (blue-cooler "#00bcff")
+ (blue-faint "#82b0ec")
+ (blue-intense "#338fff")
+ (magenta "#feacd0")
+ (magenta-warmer "#f78fe7")
+ (magenta-cooler "#b6a0ff")
+ (magenta-faint "#caa6df")
+ (magenta-intense "#ff66ff")
+ (cyan "#00d3d0")
+ (cyan-warmer "#4ae2f0")
+ (cyan-cooler "#6ae4b9")
+ (cyan-faint "#9ac8e0")
+ (cyan-intense "#00eff0")
+
+;;; Uncommon accent foregrounds
+
+ (rust "#db7b5f")
+ (gold "#c0965b")
+ (olive "#9cbd6f")
+ (slate "#76afbf")
+ (indigo "#9099d9")
+ (maroon "#cf7fa7")
+ (pink "#d09dc0")
+
+;;; Common accent backgrounds
+
+ (bg-red-intense "#9d1f1f")
+ (bg-green-intense "#2f822f")
+ (bg-yellow-intense "#7a6100")
+ (bg-blue-intense "#1640b0")
+ (bg-magenta-intense "#7030af")
+ (bg-cyan-intense "#2266ae")
+
+ (bg-red-subtle "#620f2a")
+ (bg-green-subtle "#00422a")
+ (bg-yellow-subtle "#4a4000")
+ (bg-blue-subtle "#242679")
+ (bg-magenta-subtle "#552f5f")
+ (bg-cyan-subtle "#004065")
+
+ (bg-red-nuanced "#3a0c14")
+ (bg-green-nuanced "#092f1f")
+ (bg-yellow-nuanced "#381d0f")
+ (bg-blue-nuanced "#12154a")
+ (bg-magenta-nuanced "#2f0c3f")
+ (bg-cyan-nuanced "#042837")
+
+;;; Uncommon accent backgrounds
+
+ (bg-ochre "#442c2f")
+ (bg-lavender "#38325c")
+ (bg-sage "#0f3d30")
+
+;;; Graphs
+
+ (bg-graph-red-0 "#b52c2c")
+ (bg-graph-red-1 "#702020")
+ (bg-graph-green-0 "#0fed00")
+ (bg-graph-green-1 "#007800")
+ (bg-graph-yellow-0 "#f1e00a")
+ (bg-graph-yellow-1 "#b08940")
+ (bg-graph-blue-0 "#2fafef")
+ (bg-graph-blue-1 "#1f2f8f")
+ (bg-graph-magenta-0 "#bf94fe")
+ (bg-graph-magenta-1 "#5f509f")
+ (bg-graph-cyan-0 "#47dfea")
+ (bg-graph-cyan-1 "#00808f")
+
+;;; Special purpose
+
+ (bg-completion "#2f447f")
+ (bg-hover "#45605e")
+ (bg-hover-secondary "#654a39")
+ (bg-hl-line "#2f3849")
+ (bg-region "#5a5a5a")
+ (fg-region "#ffffff")
+
+ (bg-char-0 "#0050af")
+ (bg-char-1 "#7f1f7f")
+ (bg-char-2 "#625a00")
+
+ (bg-mode-line-active "#505050")
+ (fg-mode-line-active "#ffffff")
+ (border-mode-line-active "#959595")
+ (bg-mode-line-inactive "#2d2d2d")
+ (fg-mode-line-inactive "#969696")
+ (border-mode-line-inactive "#606060")
+
+ (modeline-err "#ffa9bf")
+ (modeline-warning "#dfcf43")
+ (modeline-info "#9fefff")
+
+ (bg-tab-bar "#313131")
+ (bg-tab-current "#000000")
+ (bg-tab-other "#545454")
+
+;;; Diffs
+
+ (bg-added "#00381f")
+ (bg-added-faint "#002910")
+ (bg-added-refine "#034f2f")
+ (bg-added-fringe "#237f3f")
+ (fg-added "#a0e0a0")
+ (fg-added-intense "#80e080")
+
+ (bg-changed "#363300")
+ (bg-changed-faint "#2a1f00")
+ (bg-changed-refine "#4a4a00")
+ (bg-changed-fringe "#8a7a00")
+ (fg-changed "#efef80")
+ (fg-changed-intense "#c0b05f")
+
+ (bg-removed "#4f1119")
+ (bg-removed-faint "#380a0f")
+ (bg-removed-refine "#781a1f")
+ (bg-removed-fringe "#b81a1f")
+ (fg-removed "#ffbfbf")
+ (fg-removed-intense "#ff9095")
+
+ (bg-diff-context "#1a1a1a")
+
+;;; Paren match
+
+ (bg-paren-match "#2f7f9f")
+ (fg-paren-match fg-main)
+ (bg-paren-expression "#453040")
+ (underline-paren-match unspecified)
+
+;;; Mappings
+
+;;;; General mappings
+
+ (fringe bg-dim)
+ (cursor fg-main)
+
+ (keybind blue-cooler)
+ (name magenta)
+ (identifier yellow-faint)
+
+ (err red)
+ (warning yellow-warmer)
+ (info cyan-cooler)
+
+ (underline-err red-intense)
+ (underline-warning yellow)
+ (underline-note cyan)
+
+ (bg-prominent-err bg-red-intense)
+ (fg-prominent-err fg-main)
+ (bg-prominent-warning bg-yellow-intense)
+ (fg-prominent-warning fg-main)
+ (bg-prominent-note bg-cyan-intense)
+ (fg-prominent-note fg-main)
+
+ (bg-active-argument bg-yellow-nuanced)
+ (fg-active-argument yellow-cooler)
+ (bg-active-value bg-cyan-nuanced)
+ (fg-active-value cyan-cooler)
+
+;;;; Code mappings
+
+ (builtin magenta-warmer)
+ (comment fg-dim)
+ (constant blue-cooler)
+ (docstring cyan-faint)
+ (docmarkup magenta-faint)
+ (fnname magenta)
+ (keyword magenta-cooler)
+ (preprocessor red-cooler)
+ (string blue-warmer)
+ (type cyan-cooler)
+ (variable cyan)
+ (rx-construct green-cooler)
+ (rx-backslash magenta)
+
+;;;; Accent mappings
+
+ (accent-0 blue-cooler)
+ (accent-1 magenta-warmer)
+ (accent-2 cyan-cooler)
+ (accent-3 yellow)
+
+;;;; Button mappings
+
+ (fg-button-active fg-main)
+ (fg-button-inactive fg-dim)
+ (bg-button-active bg-active)
+ (bg-button-inactive bg-dim)
+
+;;;; Completion mappings
+
+ (fg-completion-match-0 blue-cooler)
+ (fg-completion-match-1 magenta-warmer)
+ (fg-completion-match-2 cyan-cooler)
+ (fg-completion-match-3 yellow)
+ (bg-completion-match-0 unspecified)
+ (bg-completion-match-1 unspecified)
+ (bg-completion-match-2 unspecified)
+ (bg-completion-match-3 unspecified)
+
+;;;; Date mappings
+
+ (date-common cyan)
+ (date-deadline red)
+ (date-event fg-alt)
+ (date-holiday red-cooler)
+ (date-holiday-other blue)
+ (date-now fg-main)
+ (date-range fg-alt)
+ (date-scheduled yellow-warmer)
+ (date-weekday cyan)
+ (date-weekend red-faint)
+
+;;;; Line number mappings
+
+ (fg-line-number-inactive fg-dim)
+ (fg-line-number-active fg-main)
+ (bg-line-number-inactive bg-dim)
+ (bg-line-number-active bg-active)
+
+;;;; Link mappings
+
+ (fg-link blue-warmer)
+ (bg-link unspecified)
+ (underline-link blue-warmer)
+
+ (fg-link-symbolic cyan)
+ (bg-link-symbolic unspecified)
+ (underline-link-symbolic cyan)
+
+ (fg-link-visited magenta)
+ (bg-link-visited unspecified)
+ (underline-link-visited magenta)
+
+;;;; Mail mappings
+
+ (mail-cite-0 blue-warmer)
+ (mail-cite-1 yellow-cooler)
+ (mail-cite-2 cyan-cooler)
+ (mail-cite-3 red-cooler)
+ (mail-part blue)
+ (mail-recipient magenta-cooler)
+ (mail-subject magenta-warmer)
+ (mail-other magenta-faint)
+
+;;;; Mark mappings
+
+ (bg-mark-delete bg-red-subtle)
+ (fg-mark-delete red-cooler)
+ (bg-mark-select bg-cyan-subtle)
+ (fg-mark-select cyan)
+ (bg-mark-other bg-yellow-subtle)
+ (fg-mark-other yellow)
+
+;;;; Prompt mappings
+
+ (fg-prompt cyan-cooler)
+ (bg-prompt unspecified)
+
+;;;; Prose mappings
+
+ (bg-prose-block-delimiter bg-dim)
+ (fg-prose-block-delimiter fg-dim)
+ (bg-prose-block-contents bg-dim)
+
+ (bg-prose-code unspecified)
+ (fg-prose-code cyan-cooler)
+
+ (bg-prose-macro unspecified)
+ (fg-prose-macro magenta-cooler)
+
+ (bg-prose-verbatim unspecified)
+ (fg-prose-verbatim magenta-warmer)
+
+ (prose-done green)
+ (prose-todo red)
+
+ (prose-metadata fg-dim)
+ (prose-metadata-value fg-alt)
+
+ (prose-table fg-alt)
+ (prose-table-formula magenta-warmer)
+
+ (prose-tag magenta-faint)
+
+;;;; Rainbow mappings
+
+ (rainbow-0 fg-main)
+ (rainbow-1 magenta-intense)
+ (rainbow-2 cyan-intense)
+ (rainbow-3 red-warmer)
+ (rainbow-4 yellow-intense)
+ (rainbow-5 magenta-cooler)
+ (rainbow-6 green-intense)
+ (rainbow-7 blue-warmer)
+ (rainbow-8 magenta-warmer)
+
+;;;; Search mappings
+
+ (bg-search-current bg-yellow-intense)
+ (bg-search-lazy bg-cyan-intense)
+ (bg-search-replace bg-red-intense)
+
+ (bg-search-rx-group-0 bg-blue-intense)
+ (bg-search-rx-group-1 bg-green-intense)
+ (bg-search-rx-group-2 bg-red-subtle)
+ (bg-search-rx-group-3 bg-magenta-subtle)
+
+;;;; Space mappings
+
+ (bg-space unspecified)
+ (fg-space border)
+ (bg-space-err bg-red-intense)
+
+;;;; Terminal mappings
+
+ (bg-term-black "#000000")
+ (fg-term-black "#000000")
+ (bg-term-black-bright "#595959")
+ (fg-term-black-bright "#595959")
+
+ (bg-term-red red)
+ (fg-term-red red)
+ (bg-term-red-bright red-warmer)
+ (fg-term-red-bright red-warmer)
+
+ (bg-term-green green)
+ (fg-term-green green)
+ (bg-term-green-bright green-cooler)
+ (fg-term-green-bright green-cooler)
+
+ (bg-term-yellow yellow)
+ (fg-term-yellow yellow)
+ (bg-term-yellow-bright yellow-warmer)
+ (fg-term-yellow-bright yellow-warmer)
+
+ (bg-term-blue blue)
+ (fg-term-blue blue)
+ (bg-term-blue-bright blue-warmer)
+ (fg-term-blue-bright blue-warmer)
+
+ (bg-term-magenta magenta)
+ (fg-term-magenta magenta)
+ (bg-term-magenta-bright magenta-cooler)
+ (fg-term-magenta-bright magenta-cooler)
+
+ (bg-term-cyan cyan)
+ (fg-term-cyan cyan)
+ (bg-term-cyan-bright cyan-cooler)
+ (fg-term-cyan-bright cyan-cooler)
+
+ (bg-term-white "#a6a6a6")
+ (fg-term-white "#a6a6a6")
+ (bg-term-white-bright "#ffffff")
+ (fg-term-white-bright "#ffffff")
+
+;;;; Heading mappings
+
+ (fg-heading-0 cyan-cooler)
+ (fg-heading-1 fg-main)
+ (fg-heading-2 yellow-faint)
+ (fg-heading-3 blue-faint)
+ (fg-heading-4 magenta)
+ (fg-heading-5 green-faint)
+ (fg-heading-6 red-faint)
+ (fg-heading-7 cyan-faint)
+ (fg-heading-8 fg-dim)
+
+ (bg-heading-0 unspecified)
+ (bg-heading-1 unspecified)
+ (bg-heading-2 unspecified)
+ (bg-heading-3 unspecified)
+ (bg-heading-4 unspecified)
+ (bg-heading-5 unspecified)
+ (bg-heading-6 unspecified)
+ (bg-heading-7 unspecified)
+ (bg-heading-8 unspecified)
+
+ (overline-heading-0 unspecified)
+ (overline-heading-1 unspecified)
+ (overline-heading-2 unspecified)
+ (overline-heading-3 unspecified)
+ (overline-heading-4 unspecified)
+ (overline-heading-5 unspecified)
+ (overline-heading-6 unspecified)
+ (overline-heading-7 unspecified)
+ (overline-heading-8 unspecified))
+ "The entire palette of the `modus-vivendi' theme.
+
+Named colors have the form (COLOR-NAME HEX-VALUE) with the former
+as a symbol and the latter as a string.
+
+Semantic color mappings have the form (MAPPING-NAME COLOR-NAME)
+with both as symbols. The latter is a named color that already
+exists in the palette and is associated with a HEX-VALUE.")
+
+ (defcustom modus-vivendi-palette-overrides nil
+ "Overrides for `modus-vivendi-palette'.
+
+Mirror the elements of the aforementioned palette, overriding
+their value.
+
+For overrides that are shared across all of the Modus themes,
+refer to `modus-themes-common-palette-overrides'.
+
+Theme-specific overrides take precedence over shared overrides.
+The idea of common overrides is to change semantic color
+mappings, such as to make the cursor red. Wherea theme-specific
+overrides can also be used to change the value of a named color,
+such as what hexadecimal RGB value the red-warmer symbol
+represents."
+ :group 'modus-themes
+ :package-version '(modus-themes . "4.0.0")
+ :version "30.1"
+ :type '(repeat (list symbol (choice symbol string)))
+ :set #'modus-themes--set-option
+ :initialize #'custom-initialize-default
+ :link '(info-link "(modus-themes) Palette overrides"))
+
+ (modus-themes-theme modus-vivendi
+ modus-vivendi-palette
+ modus-vivendi-palette-overrides)
+
+ (provide-theme 'modus-vivendi))
;;; modus-vivendi-theme.el ends here
diff --git a/etc/themes/modus-vivendi-tinted-theme.el b/etc/themes/modus-vivendi-tinted-theme.el
new file mode 100644
index 00000000000..5aa44304ee9
--- /dev/null
+++ b/etc/themes/modus-vivendi-tinted-theme.el
@@ -0,0 +1,513 @@
+;;; modus-vivendi-tinted-theme.el --- Elegant, highly legible theme with a night sky background -*- lexical-binding:t -*-
+
+;; Copyright (C) 2019-2024 Free Software Foundation, Inc.
+
+;; Author: Protesilaos Stavrou <info@protesilaos.com>
+;; Maintainer: Protesilaos Stavrou <info@protesilaos.com>
+;; URL: https://github.com/protesilaos/modus-themes
+;; Keywords: faces, theme, accessibility
+
+;; This file is part of GNU Emacs.
+
+;; GNU Emacs is free software: you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+;;
+;; GNU Emacs is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+;;
+;; You should have received a copy of the GNU General Public License
+;; along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>.
+
+;;; Commentary:
+;;
+;; The Modus themes conform with the highest standard for
+;; color-contrast accessibility between background and foreground
+;; values (WCAG AAA). Please refer to the official Info manual for
+;; further documentation (distributed with the themes, or available
+;; at: <https://protesilaos.com/emacs/modus-themes>).
+
+;;; Code:
+
+
+
+(eval-and-compile
+ (unless (and (fboundp 'require-theme)
+ load-file-name
+ (equal (file-name-directory load-file-name)
+ (expand-file-name "themes/" data-directory))
+ (require-theme 'modus-themes t))
+ (require 'modus-themes))
+
+;;;###theme-autoload
+ (deftheme modus-vivendi-tinted
+ "Elegant, highly legible theme with a night sky background.
+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 (WCAG AAA standard)."
+ :background-mode 'dark
+ :kind 'color-scheme
+ :family 'modus)
+
+ (defconst modus-vivendi-tinted-palette
+ '(
+;;; Basic values
+
+ (bg-main "#0d0e1c")
+ (bg-dim "#1d2235")
+ (fg-main "#ffffff")
+ (fg-dim "#989898")
+ (fg-alt "#c6daff")
+ (bg-active "#4a4f69")
+ (bg-inactive "#2b3045")
+ (border "#61647a")
+
+;;; Common accent foregrounds
+
+ (red "#ff5f59")
+ (red-warmer "#ff6b55")
+ (red-cooler "#ff7f9f")
+ (red-faint "#ff9f80")
+ (red-intense "#ff5f5f")
+ (green "#44bc44")
+ (green-warmer "#70b900")
+ (green-cooler "#00c06f")
+ (green-faint "#88ca9f")
+ (green-intense "#44df44")
+ (yellow "#d0bc00")
+ (yellow-warmer "#fec43f")
+ (yellow-cooler "#dfaf7a")
+ (yellow-faint "#d2b580")
+ (yellow-intense "#efef00")
+ (blue "#2fafff")
+ (blue-warmer "#79a8ff")
+ (blue-cooler "#00bcff")
+ (blue-faint "#82b0ec")
+ (blue-intense "#338fff")
+ (magenta "#feacd0")
+ (magenta-warmer "#f78fe7")
+ (magenta-cooler "#b6a0ff")
+ (magenta-faint "#caa6df")
+ (magenta-intense "#ff66ff")
+ (cyan "#00d3d0")
+ (cyan-warmer "#4ae2f0")
+ (cyan-cooler "#6ae4b9")
+ (cyan-faint "#9ac8e0")
+ (cyan-intense "#00eff0")
+
+;;; Uncommon accent foregrounds
+
+ (rust "#db7b5f")
+ (gold "#c0965b")
+ (olive "#9cbd6f")
+ (slate "#76afbf")
+ (indigo "#9099d9")
+ (maroon "#cf7fa7")
+ (pink "#d09dc0")
+
+;;; Common accent backgrounds
+
+ (bg-red-intense "#9d1f1f")
+ (bg-green-intense "#2f822f")
+ (bg-yellow-intense "#7a6100")
+ (bg-blue-intense "#1640b0")
+ (bg-magenta-intense "#7030af")
+ (bg-cyan-intense "#2266ae")
+
+ (bg-red-subtle "#620f2a")
+ (bg-green-subtle "#00422a")
+ (bg-yellow-subtle "#4a4000")
+ (bg-blue-subtle "#242679")
+ (bg-magenta-subtle "#552f5f")
+ (bg-cyan-subtle "#004065")
+
+ (bg-red-nuanced "#3a0c14")
+ (bg-green-nuanced "#092f1f")
+ (bg-yellow-nuanced "#381d0f")
+ (bg-blue-nuanced "#12154a")
+ (bg-magenta-nuanced "#2f0c3f")
+ (bg-cyan-nuanced "#042837")
+
+;;; Uncommon accent backgrounds
+
+ (bg-ochre "#442c2f")
+ (bg-lavender "#38325c")
+ (bg-sage "#0f3d30")
+
+;;; Graphs
+
+ (bg-graph-red-0 "#b52c2c")
+ (bg-graph-red-1 "#702020")
+ (bg-graph-green-0 "#0fed00")
+ (bg-graph-green-1 "#007800")
+ (bg-graph-yellow-0 "#f1e00a")
+ (bg-graph-yellow-1 "#b08940")
+ (bg-graph-blue-0 "#2fafef")
+ (bg-graph-blue-1 "#1f2f8f")
+ (bg-graph-magenta-0 "#bf94fe")
+ (bg-graph-magenta-1 "#5f509f")
+ (bg-graph-cyan-0 "#47dfea")
+ (bg-graph-cyan-1 "#00808f")
+
+;;; Special purpose
+
+ (bg-completion "#483d8a")
+ (bg-hover "#45605e")
+ (bg-hover-secondary "#654a39")
+ (bg-hl-line "#303a6f")
+ (bg-region "#555a66")
+ (fg-region "#ffffff")
+
+ (bg-char-0 "#0050af")
+ (bg-char-1 "#7f1f7f")
+ (bg-char-2 "#625a00")
+
+ (bg-mode-line-active "#484d67")
+ (fg-mode-line-active "#ffffff")
+ (border-mode-line-active "#979797")
+ (bg-mode-line-inactive "#292d48")
+ (fg-mode-line-inactive "#969696")
+ (border-mode-line-inactive "#606270")
+
+ (modeline-err "#ffa9bf")
+ (modeline-warning "#dfcf43")
+ (modeline-info "#9fefff")
+
+ (bg-tab-bar "#2c3045")
+ (bg-tab-current "#0d0e1c")
+ (bg-tab-other "#4a4f6a")
+
+;;; Diffs
+
+ (bg-added "#003a2f")
+ (bg-added-faint "#002922")
+ (bg-added-refine "#035542")
+ (bg-added-fringe "#23884f")
+ (fg-added "#a0e0a0")
+ (fg-added-intense "#80e080")
+
+ (bg-changed "#363300")
+ (bg-changed-faint "#2a1f00")
+ (bg-changed-refine "#4a4a00")
+ (bg-changed-fringe "#8f7a30")
+ (fg-changed "#efef80")
+ (fg-changed-intense "#c0b05f")
+
+ (bg-removed "#4f1127")
+ (bg-removed-faint "#380a19")
+ (bg-removed-refine "#781a3a")
+ (bg-removed-fringe "#b81a26")
+ (fg-removed "#ffbfbf")
+ (fg-removed-intense "#ff9095")
+
+ (bg-diff-context "#1a1f30")
+
+;;; Paren match
+
+ (bg-paren-match "#5f789f")
+ (fg-paren-match fg-main)
+ (bg-paren-expression "#453040")
+ (underline-paren-match unspecified)
+
+;;; Mappings
+
+;;;; General mappings
+
+ (fringe bg-dim)
+ (cursor magenta-intense)
+
+ (keybind magenta-cooler)
+ (name magenta)
+ (identifier yellow-faint)
+
+ (err red)
+ (warning yellow-warmer)
+ (info cyan-cooler)
+
+ (underline-err red-intense)
+ (underline-warning yellow)
+ (underline-note cyan)
+
+ (bg-prominent-err bg-red-intense)
+ (fg-prominent-err fg-main)
+ (bg-prominent-warning bg-yellow-intense)
+ (fg-prominent-warning fg-main)
+ (bg-prominent-note bg-cyan-intense)
+ (fg-prominent-note fg-main)
+
+ (bg-active-argument bg-yellow-nuanced)
+ (fg-active-argument yellow-cooler)
+ (bg-active-value bg-cyan-nuanced)
+ (fg-active-value cyan-cooler)
+
+;;;; Code mappings
+
+ (builtin magenta-warmer)
+ (comment red-faint)
+ (constant blue-cooler)
+ (docstring cyan-faint)
+ (docmarkup magenta-faint)
+ (fnname magenta)
+ (keyword magenta-cooler)
+ (preprocessor red-cooler)
+ (string blue-warmer)
+ (type cyan-cooler)
+ (variable cyan)
+ (rx-construct green-cooler)
+ (rx-backslash magenta)
+
+;;;; Accent mappings
+
+ (accent-0 blue-cooler)
+ (accent-1 magenta-warmer)
+ (accent-2 cyan-cooler)
+ (accent-3 yellow)
+
+;;;; Button mappings
+
+ (fg-button-active fg-main)
+ (fg-button-inactive fg-dim)
+ (bg-button-active bg-active)
+ (bg-button-inactive bg-dim)
+
+;;;; Completion mappings
+
+ (fg-completion-match-0 blue-cooler)
+ (fg-completion-match-1 magenta-warmer)
+ (fg-completion-match-2 cyan-cooler)
+ (fg-completion-match-3 yellow)
+ (bg-completion-match-0 unspecified)
+ (bg-completion-match-1 unspecified)
+ (bg-completion-match-2 unspecified)
+ (bg-completion-match-3 unspecified)
+
+;;;; Date mappings
+
+ (date-common cyan)
+ (date-deadline red)
+ (date-event fg-alt)
+ (date-holiday red-cooler)
+ (date-holiday-other blue)
+ (date-now fg-main)
+ (date-range fg-alt)
+ (date-scheduled yellow-warmer)
+ (date-weekday cyan)
+ (date-weekend red-faint)
+
+;;;; Line number mappings
+
+ (fg-line-number-inactive fg-dim)
+ (fg-line-number-active fg-main)
+ (bg-line-number-inactive bg-dim)
+ (bg-line-number-active bg-active)
+
+;;;; Link mappings
+
+ (fg-link blue-warmer)
+ (bg-link unspecified)
+ (underline-link blue-warmer)
+
+ (fg-link-symbolic cyan)
+ (bg-link-symbolic unspecified)
+ (underline-link-symbolic cyan)
+
+ (fg-link-visited magenta)
+ (bg-link-visited unspecified)
+ (underline-link-visited magenta)
+
+;;;; Mail mappings
+
+ (mail-cite-0 blue-warmer)
+ (mail-cite-1 yellow-cooler)
+ (mail-cite-2 cyan-cooler)
+ (mail-cite-3 red-cooler)
+ (mail-part blue)
+ (mail-recipient magenta-cooler)
+ (mail-subject magenta-warmer)
+ (mail-other magenta-faint)
+
+;;;; Mark mappings
+
+ (bg-mark-delete bg-red-subtle)
+ (fg-mark-delete red-cooler)
+ (bg-mark-select bg-cyan-subtle)
+ (fg-mark-select cyan)
+ (bg-mark-other bg-yellow-subtle)
+ (fg-mark-other yellow)
+
+;;;; Prompt mappings
+
+ (fg-prompt cyan-cooler)
+ (bg-prompt unspecified)
+
+;;;; Prose mappings
+
+ (bg-prose-block-delimiter bg-dim)
+ (fg-prose-block-delimiter fg-dim)
+ (bg-prose-block-contents bg-dim)
+
+ (bg-prose-code unspecified)
+ (fg-prose-code cyan-cooler)
+
+ (bg-prose-macro unspecified)
+ (fg-prose-macro magenta-cooler)
+
+ (bg-prose-verbatim unspecified)
+ (fg-prose-verbatim magenta-warmer)
+
+ (prose-done green)
+ (prose-todo red)
+
+ (prose-metadata fg-dim)
+ (prose-metadata-value fg-alt)
+
+ (prose-table fg-alt)
+ (prose-table-formula magenta-warmer)
+
+ (prose-tag magenta-faint)
+
+;;;; Rainbow mappings
+
+ (rainbow-0 fg-main)
+ (rainbow-1 magenta-intense)
+ (rainbow-2 cyan-intense)
+ (rainbow-3 red-warmer)
+ (rainbow-4 yellow-intense)
+ (rainbow-5 magenta-cooler)
+ (rainbow-6 green-intense)
+ (rainbow-7 blue-warmer)
+ (rainbow-8 magenta-warmer)
+
+;;;; Search mappings
+
+ (bg-search-current bg-yellow-intense)
+ (bg-search-lazy bg-cyan-intense)
+ (bg-search-replace bg-red-intense)
+
+ (bg-search-rx-group-0 bg-blue-intense)
+ (bg-search-rx-group-1 bg-green-intense)
+ (bg-search-rx-group-2 bg-red-subtle)
+ (bg-search-rx-group-3 bg-magenta-subtle)
+
+;;;; Space mappings
+
+ (bg-space unspecified)
+ (fg-space border)
+ (bg-space-err bg-red-intense)
+
+;;;; Terminal mappings
+
+ (bg-term-black "#000000")
+ (fg-term-black "#000000")
+ (bg-term-black-bright "#595959")
+ (fg-term-black-bright "#595959")
+
+ (bg-term-red red)
+ (fg-term-red red)
+ (bg-term-red-bright red-warmer)
+ (fg-term-red-bright red-warmer)
+
+ (bg-term-green green)
+ (fg-term-green green)
+ (bg-term-green-bright green-cooler)
+ (fg-term-green-bright green-cooler)
+
+ (bg-term-yellow yellow)
+ (fg-term-yellow yellow)
+ (bg-term-yellow-bright yellow-warmer)
+ (fg-term-yellow-bright yellow-warmer)
+
+ (bg-term-blue blue)
+ (fg-term-blue blue)
+ (bg-term-blue-bright blue-warmer)
+ (fg-term-blue-bright blue-warmer)
+
+ (bg-term-magenta magenta)
+ (fg-term-magenta magenta)
+ (bg-term-magenta-bright magenta-cooler)
+ (fg-term-magenta-bright magenta-cooler)
+
+ (bg-term-cyan cyan)
+ (fg-term-cyan cyan)
+ (bg-term-cyan-bright cyan-cooler)
+ (fg-term-cyan-bright cyan-cooler)
+
+ (bg-term-white "#a6a6a6")
+ (fg-term-white "#a6a6a6")
+ (bg-term-white-bright "#ffffff")
+ (fg-term-white-bright "#ffffff")
+
+;;;; Heading mappings
+
+ (fg-heading-0 cyan-cooler)
+ (fg-heading-1 fg-main)
+ (fg-heading-2 yellow-faint)
+ (fg-heading-3 blue-faint)
+ (fg-heading-4 magenta)
+ (fg-heading-5 green-faint)
+ (fg-heading-6 red-faint)
+ (fg-heading-7 cyan-faint)
+ (fg-heading-8 fg-dim)
+
+ (bg-heading-0 unspecified)
+ (bg-heading-1 unspecified)
+ (bg-heading-2 unspecified)
+ (bg-heading-3 unspecified)
+ (bg-heading-4 unspecified)
+ (bg-heading-5 unspecified)
+ (bg-heading-6 unspecified)
+ (bg-heading-7 unspecified)
+ (bg-heading-8 unspecified)
+
+ (overline-heading-0 unspecified)
+ (overline-heading-1 unspecified)
+ (overline-heading-2 unspecified)
+ (overline-heading-3 unspecified)
+ (overline-heading-4 unspecified)
+ (overline-heading-5 unspecified)
+ (overline-heading-6 unspecified)
+ (overline-heading-7 unspecified)
+ (overline-heading-8 unspecified))
+ "The entire palette of the `modus-vivendi-tinted' theme.
+
+Named colors have the form (COLOR-NAME HEX-VALUE) with the former
+as a symbol and the latter as a string.
+
+Semantic color mappings have the form (MAPPING-NAME COLOR-NAME)
+with both as symbols. The latter is a named color that already
+exists in the palette and is associated with a HEX-VALUE.")
+
+ (defcustom modus-vivendi-tinted-palette-overrides nil
+ "Overrides for `modus-vivendi-tinted-palette'.
+
+Mirror the elements of the aforementioned palette, overriding
+their value.
+
+For overrides that are shared across all of the Modus themes,
+refer to `modus-themes-common-palette-overrides'.
+
+Theme-specific overrides take precedence over shared overrides.
+The idea of common overrides is to change semantic color
+mappings, such as to make the cursor red. Wherea theme-specific
+overrides can also be used to change the value of a named color,
+such as what hexadecimal RGB value the red-warmer symbol
+represents."
+ :group 'modus-themes
+ :package-version '(modus-themes . "4.0.0")
+ :version "30.1"
+ :type '(repeat (list symbol (choice symbol string)))
+ :set #'modus-themes--set-option
+ :initialize #'custom-initialize-default
+ :link '(info-link "(modus-themes) Palette overrides"))
+
+ (modus-themes-theme modus-vivendi-tinted
+ modus-vivendi-tinted-palette
+ modus-vivendi-tinted-palette-overrides)
+
+ (provide-theme 'modus-vivendi-tinted))
+
+;;; modus-vivendi-tinted-theme.el ends here
diff --git a/etc/themes/modus-vivendi-tritanopia-theme.el b/etc/themes/modus-vivendi-tritanopia-theme.el
new file mode 100644
index 00000000000..2327a1e9c97
--- /dev/null
+++ b/etc/themes/modus-vivendi-tritanopia-theme.el
@@ -0,0 +1,515 @@
+;;; modus-vivendi-tritanopia-theme.el --- Tritanopia-optimized theme with a black background -*- lexical-binding:t -*-
+
+;; Copyright (C) 2019-2024 Free Software Foundation, Inc.
+
+;; Author: Protesilaos Stavrou <info@protesilaos.com>
+;; Maintainer: Protesilaos Stavrou <info@protesilaos.com>
+;; URL: https://github.com/protesilaos/modus-themes
+;; Keywords: faces, theme, accessibility
+
+;; This file is part of GNU Emacs.
+
+;; GNU Emacs is free software: you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+;;
+;; GNU Emacs is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+;;
+;; You should have received a copy of the GNU General Public License
+;; along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>.
+
+;;; Commentary:
+;;
+;; The Modus themes conform with the highest standard for
+;; color-contrast accessibility between background and foreground
+;; values (WCAG AAA). Please refer to the official Info manual for
+;; further documentation (distributed with the themes, or available
+;; at: <https://protesilaos.com/emacs/modus-themes>).
+
+;;; Code:
+
+
+
+(eval-and-compile
+ (unless (and (fboundp 'require-theme)
+ load-file-name
+ (equal (file-name-directory load-file-name)
+ (expand-file-name "themes/" data-directory))
+ (require-theme 'modus-themes t))
+ (require 'modus-themes))
+
+;;;###theme-autoload
+ (deftheme modus-vivendi-tritanopia
+ "Tritanopia-optimized theme with a black background.
+This variant is optimized for users with blue-yellow color
+deficiency (tritanopia). It 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 (WCAG AAA
+standard)."
+ :background-mode 'dark
+ :kind 'color-scheme
+ :family 'modus)
+
+ (defconst modus-vivendi-tritanopia-palette
+ '(
+;;; Basic values
+
+ (bg-main "#000000")
+ (bg-dim "#1e1e1e")
+ (fg-main "#ffffff")
+ (fg-dim "#989898")
+ (fg-alt "#c6daff")
+ (bg-active "#535353")
+ (bg-inactive "#303030")
+ (border "#646464")
+
+;;; Common accent foregrounds
+
+ (red "#ff5f59")
+ (red-warmer "#ff6740")
+ (red-cooler "#ff6f9f")
+ (red-faint "#ff9070")
+ (red-intense "#ff5f5f")
+ (green "#44bc44")
+ (green-warmer "#70b900")
+ (green-cooler "#00c06f")
+ (green-faint "#88ca9f")
+ (green-intense "#44df44")
+ (yellow "#cabf00")
+ (yellow-warmer "#ffa00f")
+ (yellow-cooler "#d8af7a")
+ (yellow-faint "#d2b580")
+ (yellow-intense "#efef00")
+ (blue "#2fafff")
+ (blue-warmer "#79a8ff")
+ (blue-cooler "#00bcff")
+ (blue-faint "#82b0ec")
+ (blue-intense "#338fff")
+ (magenta "#feacd0")
+ (magenta-warmer "#f78fe7")
+ (magenta-cooler "#b6a0ff")
+ (magenta-faint "#caa6df")
+ (magenta-intense "#ef7fff")
+ (cyan "#00d3d0")
+ (cyan-warmer "#4ae2ff")
+ (cyan-cooler "#6ae4b9")
+ (cyan-faint "#7fdbdf")
+ (cyan-intense "#00eff0")
+
+;;; Uncommon accent foregrounds
+
+ (rust "#db7b5f")
+ (gold "#c0965b")
+ (olive "#9cbd6f")
+ (slate "#76afbf")
+ (indigo "#9099d9")
+ (maroon "#cf7fa7")
+ (pink "#d09dc0")
+
+;;; Common accent backgrounds
+
+ (bg-red-intense "#9d1f1f")
+ (bg-green-intense "#2f822f")
+ (bg-yellow-intense "#7a6100")
+ (bg-blue-intense "#1640b0")
+ (bg-magenta-intense "#7030af")
+ (bg-cyan-intense "#2266ae")
+
+ (bg-red-subtle "#620f2a")
+ (bg-green-subtle "#00422a")
+ (bg-yellow-subtle "#4a4000")
+ (bg-blue-subtle "#242679")
+ (bg-magenta-subtle "#552f5f")
+ (bg-cyan-subtle "#004065")
+
+ (bg-red-nuanced "#3a0c14")
+ (bg-green-nuanced "#092f1f")
+ (bg-yellow-nuanced "#381d0f")
+ (bg-blue-nuanced "#12154a")
+ (bg-magenta-nuanced "#2f0c3f")
+ (bg-cyan-nuanced "#042837")
+
+;;; Uncommon accent backgrounds
+
+ (bg-ochre "#442c2f")
+ (bg-lavender "#38325c")
+ (bg-sage "#0f3d30")
+
+;;; Graphs
+
+ (bg-graph-red-0 "#b52c2c")
+ (bg-graph-red-1 "#702020")
+ (bg-graph-green-0 "#afd1c0")
+ (bg-graph-green-1 "#607a8f")
+ (bg-graph-yellow-0 "#facfd6")
+ (bg-graph-yellow-1 "#b57b85")
+ (bg-graph-blue-0 "#4f9fdf")
+ (bg-graph-blue-1 "#004559")
+ (bg-graph-magenta-0 "#b6427f")
+ (bg-graph-magenta-1 "#7f506f")
+ (bg-graph-cyan-0 "#57dfea")
+ (bg-graph-cyan-1 "#00808f")
+
+;;; Special purpose
+
+ (bg-completion "#004253")
+ (bg-hover "#8e3e3b")
+ (bg-hover-secondary "#00405f")
+ (bg-hl-line "#2f3849")
+ (bg-region "#5a5a5a")
+ (fg-region "#ffffff")
+
+ (bg-char-0 "#922a00")
+ (bg-char-1 "#00709f")
+ (bg-char-2 "#5f3faf")
+
+ (bg-mode-line-active "#003c52")
+ (fg-mode-line-active "#f0f0f0")
+ (border-mode-line-active "#5f8fb4")
+ (bg-mode-line-inactive "#2d2d2d")
+ (fg-mode-line-inactive "#969696")
+ (border-mode-line-inactive "#606060")
+
+ (modeline-err "#ff7fbf")
+ (modeline-warning "#df9f93")
+ (modeline-info "#4fcfef")
+
+ (bg-tab-bar "#313131")
+ (bg-tab-current "#000000")
+ (bg-tab-other "#545454")
+
+;;; Diffs
+
+ (bg-added "#004254")
+ (bg-added-faint "#003042")
+ (bg-added-refine "#004f7f")
+ (bg-added-fringe "#008fcf")
+ (fg-added "#9fdfdf")
+ (fg-added-intense "#50c0ef")
+
+ (bg-changed "#2f123f")
+ (bg-changed-faint "#1f022f")
+ (bg-changed-refine "#3f325f")
+ (bg-changed-fringe "#7f55a0")
+ (fg-changed "#e3cfff")
+ (fg-changed-intense "#cf9fe2")
+
+ (bg-removed "#4f1119")
+ (bg-removed-faint "#380a0f")
+ (bg-removed-refine "#781a1f")
+ (bg-removed-fringe "#b81a1f")
+ (fg-removed "#ffbfbf")
+ (fg-removed-intense "#ff9095")
+
+ (bg-diff-context "#1a1a1a")
+
+;;; Paren match
+
+ (bg-paren-match "#2f7f9f")
+ (fg-paren-match fg-main)
+ (bg-paren-expression "#453040")
+ (underline-paren-match unspecified)
+
+;;; Mappings
+
+;;;; General mappings
+
+ (fringe bg-dim)
+ (cursor red-intense)
+
+ (keybind red)
+ (name red-cooler)
+ (identifier red-faint)
+
+ (err red-warmer)
+ (warning magenta)
+ (info cyan)
+
+ (underline-err red-intense)
+ (underline-warning magenta-intense)
+ (underline-note cyan-intense)
+
+ (bg-prominent-err bg-red-intense)
+ (fg-prominent-err fg-main)
+ (bg-prominent-warning bg-magenta-intense)
+ (fg-prominent-warning fg-main)
+ (bg-prominent-note bg-cyan-intense)
+ (fg-prominent-note fg-main)
+
+ (bg-active-argument bg-red-nuanced)
+ (fg-active-argument red-warmer)
+ (bg-active-value bg-cyan-nuanced)
+ (fg-active-value cyan)
+
+;;;; Code mappings
+
+ (builtin magenta)
+ (comment red-faint)
+ (constant green-faint)
+ (docstring fg-alt)
+ (docmarkup magenta-faint)
+ (fnname cyan-warmer)
+ (keyword red-cooler)
+ (preprocessor red-warmer)
+ (string cyan)
+ (type blue-warmer)
+ (variable cyan-cooler)
+ (rx-construct red)
+ (rx-backslash magenta)
+
+;;;; Accent mappings
+
+ (accent-0 cyan)
+ (accent-1 red-warmer)
+ (accent-2 cyan-cooler)
+ (accent-3 magenta)
+
+;;;; Button mappings
+
+ (fg-button-active fg-main)
+ (fg-button-inactive fg-dim)
+ (bg-button-active bg-active)
+ (bg-button-inactive bg-dim)
+
+;;;; Completion mappings
+
+ (fg-completion-match-0 cyan)
+ (fg-completion-match-1 red-warmer)
+ (fg-completion-match-2 magenta)
+ (fg-completion-match-3 cyan-cooler)
+ (bg-completion-match-0 unspecified)
+ (bg-completion-match-1 unspecified)
+ (bg-completion-match-2 unspecified)
+ (bg-completion-match-3 unspecified)
+
+;;;; Date mappings
+
+ (date-common cyan-cooler)
+ (date-deadline red)
+ (date-event fg-alt)
+ (date-holiday red-intense)
+ (date-holiday-other cyan-warmer)
+ (date-now fg-main)
+ (date-range fg-alt)
+ (date-scheduled magenta)
+ (date-weekday cyan)
+ (date-weekend red-faint)
+
+;;;; Line number mappings
+
+ (fg-line-number-inactive fg-dim)
+ (fg-line-number-active fg-main)
+ (bg-line-number-inactive bg-dim)
+ (bg-line-number-active bg-active)
+
+;;;; Link mappings
+
+ (fg-link cyan)
+ (bg-link unspecified)
+ (underline-link cyan)
+
+ (fg-link-symbolic cyan-cooler)
+ (bg-link-symbolic unspecified)
+ (underline-link-symbolic cyan-cooler)
+
+ (fg-link-visited magenta)
+ (bg-link-visited unspecified)
+ (underline-link-visited magenta)
+
+;;;; Mail mappings
+
+ (mail-cite-0 cyan-faint)
+ (mail-cite-1 red-faint)
+ (mail-cite-2 magenta-warmer)
+ (mail-cite-3 cyan-warmer)
+ (mail-part cyan-cooler)
+ (mail-recipient cyan)
+ (mail-subject red-cooler)
+ (mail-other cyan)
+
+;;;; Mark mappings
+
+ (bg-mark-delete bg-red-subtle)
+ (fg-mark-delete red)
+ (bg-mark-select bg-cyan-subtle)
+ (fg-mark-select cyan)
+ (bg-mark-other bg-magenta-subtle)
+ (fg-mark-other magenta-warmer)
+
+;;;; Prompt mappings
+
+ (fg-prompt cyan-cooler)
+ (bg-prompt unspecified)
+
+;;;; Prose mappings
+
+ (bg-prose-block-delimiter bg-dim)
+ (fg-prose-block-delimiter fg-dim)
+ (bg-prose-block-contents bg-dim)
+
+ (bg-prose-code unspecified)
+ (fg-prose-code cyan)
+
+ (bg-prose-macro unspecified)
+ (fg-prose-macro red-warmer)
+
+ (bg-prose-verbatim unspecified)
+ (fg-prose-verbatim magenta-warmer)
+
+ (prose-done cyan)
+ (prose-todo red)
+
+ (prose-metadata fg-dim)
+ (prose-metadata-value fg-alt)
+
+ (prose-table fg-alt)
+ (prose-table-formula red-cooler)
+
+ (prose-tag magenta-faint)
+
+;;;; Rainbow mappings
+
+ (rainbow-0 cyan)
+ (rainbow-1 red)
+ (rainbow-2 cyan-warmer)
+ (rainbow-3 red-cooler)
+ (rainbow-4 cyan-cooler)
+ (rainbow-5 magenta)
+ (rainbow-6 cyan-faint)
+ (rainbow-7 magenta-faint)
+ (rainbow-8 red-faint)
+
+;;;; Search mappings
+
+ (bg-search-current bg-red-intense)
+ (bg-search-lazy bg-cyan-intense)
+ (bg-search-replace bg-magenta-intense)
+
+ (bg-search-rx-group-0 bg-blue-intense)
+ (bg-search-rx-group-1 bg-magenta-intense)
+ (bg-search-rx-group-2 bg-cyan-subtle)
+ (bg-search-rx-group-3 bg-red-subtle)
+
+;;;; Space mappings
+
+ (bg-space unspecified)
+ (fg-space border)
+ (bg-space-err bg-red-intense)
+
+;;;; Terminal mappings
+
+ (bg-term-black "#000000")
+ (fg-term-black "#000000")
+ (bg-term-black-bright "#595959")
+ (fg-term-black-bright "#595959")
+
+ (bg-term-red red)
+ (fg-term-red red)
+ (bg-term-red-bright red-warmer)
+ (fg-term-red-bright red-warmer)
+
+ (bg-term-green green)
+ (fg-term-green green)
+ (bg-term-green-bright green-cooler)
+ (fg-term-green-bright green-cooler)
+
+ (bg-term-yellow yellow)
+ (fg-term-yellow yellow)
+ (bg-term-yellow-bright yellow-warmer)
+ (fg-term-yellow-bright yellow-warmer)
+
+ (bg-term-blue blue)
+ (fg-term-blue blue)
+ (bg-term-blue-bright blue-warmer)
+ (fg-term-blue-bright blue-warmer)
+
+ (bg-term-magenta magenta)
+ (fg-term-magenta magenta)
+ (bg-term-magenta-bright magenta-cooler)
+ (fg-term-magenta-bright magenta-cooler)
+
+ (bg-term-cyan cyan)
+ (fg-term-cyan cyan)
+ (bg-term-cyan-bright cyan-cooler)
+ (fg-term-cyan-bright cyan-cooler)
+
+ (bg-term-white "#a6a6a6")
+ (fg-term-white "#a6a6a6")
+ (bg-term-white-bright "#ffffff")
+ (fg-term-white-bright "#ffffff")
+
+;;;; Heading mappings
+
+ (fg-heading-0 cyan-cooler)
+ (fg-heading-1 fg-main)
+ (fg-heading-2 red-faint)
+ (fg-heading-3 cyan-faint)
+ (fg-heading-4 magenta)
+ (fg-heading-5 green-faint)
+ (fg-heading-6 magenta-faint)
+ (fg-heading-7 cyan-faint)
+ (fg-heading-8 fg-dim)
+
+ (bg-heading-0 unspecified)
+ (bg-heading-1 unspecified)
+ (bg-heading-2 unspecified)
+ (bg-heading-3 unspecified)
+ (bg-heading-4 unspecified)
+ (bg-heading-5 unspecified)
+ (bg-heading-6 unspecified)
+ (bg-heading-7 unspecified)
+ (bg-heading-8 unspecified)
+
+ (overline-heading-0 unspecified)
+ (overline-heading-1 unspecified)
+ (overline-heading-2 unspecified)
+ (overline-heading-3 unspecified)
+ (overline-heading-4 unspecified)
+ (overline-heading-5 unspecified)
+ (overline-heading-6 unspecified)
+ (overline-heading-7 unspecified)
+ (overline-heading-8 unspecified))
+ "The entire palette of the `modus-vivendi-tritanopia' theme.
+
+Named colors have the form (COLOR-NAME HEX-VALUE) with the former
+as a symbol and the latter as a string.
+
+Semantic color mappings have the form (MAPPING-NAME COLOR-NAME)
+with both as symbols. The latter is a named color that already
+exists in the palette and is associated with a HEX-VALUE.")
+
+ (defcustom modus-vivendi-tritanopia-palette-overrides nil
+ "Overrides for `modus-vivendi-tritanopia-palette'.
+
+Mirror the elements of the aforementioned palette, overriding
+their value.
+
+For overrides that are shared across all of the Modus themes,
+refer to `modus-themes-common-palette-overrides'.
+
+Theme-specific overrides take precedence over shared overrides.
+The idea of common overrides is to change semantic color
+mappings, such as to make the cursor red. Wherea theme-specific
+overrides can also be used to change the value of a named color,
+such as what hexadecimal RGB value the red-warmer symbol
+represents."
+ :group 'modus-themes
+ :package-version '(modus-themes . "4.0.0")
+ :version "30.1"
+ :type '(repeat (list symbol (choice symbol string)))
+ :set #'modus-themes--set-option
+ :initialize #'custom-initialize-default
+ :link '(info-link "(modus-themes) Palette overrides"))
+
+ (modus-themes-theme modus-vivendi-tritanopia
+ modus-vivendi-tritanopia-palette
+ modus-vivendi-tritanopia-palette-overrides)
+
+ (provide-theme 'modus-vivendi-tritanopia))
+
+;;; modus-vivendi-tritanopia-theme.el ends here
diff --git a/etc/themes/whiteboard-theme.el b/etc/themes/whiteboard-theme.el
index 46e449bd88e..2db11fcb4b8 100644
--- a/etc/themes/whiteboard-theme.el
+++ b/etc/themes/whiteboard-theme.el
@@ -44,8 +44,8 @@
`(cursor ((,class (:background "Green4"))))
`(default ((,class (:background "whitesmoke" :foreground "black"))))
`(dired-marked ((,class (:background "dodgerblue3" :foreground "white"))))
- `(flymake-errline ((,class (:background nil :underline "red"))))
- `(flymake-warnline ((,class (:background nil :underline "magenta3"))))
+ `(flymake-errline ((,class (:background unspecified :underline "red"))))
+ `(flymake-warnline ((,class (:background unspecified :underline "magenta3"))))
`(font-lock-builtin-face ((,class (:foreground "DarkOrange3"))))
`(font-lock-comment-delimiter-face ((,class (:foreground "gray50"))))
`(font-lock-comment-face ((,class (:foreground "gray50"))))
@@ -65,7 +65,7 @@
`(highlight ((,class (:background "SkyBlue1"))))
`(ido-first-match ((,class (:weight normal :foreground "DarkOrange3"))))
`(ido-only-match ((,class (:foreground "SeaGreen4"))))
- `(ido-subdir ((,class (:foreground nil :inherit font-lock-keyword-face))))
+ `(ido-subdir ((,class (:foreground unspecified :inherit font-lock-keyword-face))))
`(image-dired-thumb-flagged ((,class :background "Red1")))
`(image-dired-thumb-mark ((,class :background "dodgerblue3")))
`(info-header-node ((,class (:foreground "DeepSkyBlue1"))))
@@ -79,7 +79,7 @@
`(match ((,class (:background "LightPink1"))))
`(minibuffer-prompt ((,class (:foreground "DodgerBlue4"))))
`(mode-line ((,class (:background "gray75" :foreground "black" :box (:line-width 1 :style released-button)))))
- `(mode-line-buffer-id ((,class (:weight bold :background nil :foreground "blue4"))))
+ `(mode-line-buffer-id ((,class (:weight bold :background unspecified :foreground "blue4"))))
`(mode-line-inactive ((,class (:background "gray40" :foreground "black" :box (:line-width 1 :color "gray40" :style nil)))))
`(outline-1 ((,class (:foreground "Blue3"))))
`(outline-2 ((,class (:foreground "DodgerBlue"))))
diff --git a/exec/Makefile.in b/exec/Makefile.in
new file mode 100644
index 00000000000..36f0c0c74a9
--- /dev/null
+++ b/exec/Makefile.in
@@ -0,0 +1,143 @@
+### @configure_input@
+
+# Copyright (C) 2023-2024 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 <https://www.gnu.org/licenses/>.
+
+# Configure build directory information.
+
+ srcdir = @srcdir@
+ VPATH = @srcdir@
+ builddir = @builddir@
+
+# Set up compilation tools.
+
+ CC = @CC@
+ AS = @AS@
+ LD = @LD@
+ M4 = @M4@
+ CPP = @CPP@
+ ASFLAGS = @ASFLAGS@
+ ARFLAGS = @ARFLAGS@
+ CFLAGS = @CFLAGS@
+ CPPFLAGS = @CPPFLAGS@
+ LDFLAGS = @LDFLAGS@
+LOADERFLAGS = @LOADERFLAGS@
+FIND_DELETE = @FIND_DELETE@
+
+# Set up object files.
+
+ LOADER = @exec_loader@
+ OBJS = @OBJS@
+ LOADOBJS = $(patsubst %.s,%.o,$(LOADER))
+
+# Set up automatic dependency tracking.
+
+AUTO_DEPEND = @AUTO_DEPEND@
+DEPDIR = deps
+ifeq ($(AUTO_DEPEND),yes)
+DEPFLAGS = -MMD -MF $(DEPDIR)/$*.d -MP
+-include $(OBJS:%.o=$(DEPDIR)/%.d)
+-include $(DEPDIR)/test.d
+-include $(DEPDIR)/exec1.d
+else
+DEPFLAGS =
+include $(srcdir)/deps.mk
+endif
+
+# Set up the appropriate targets.
+
+all: libexec.a loader
+
+# Set up automatic Makefile regeneration.
+
+$(srcdir)/configure: $(srcdir)/configure.ac
+ cd $(srcdir) && autoreconf
+
+config.status: $(srcdir)/configure
+ if [ -x config.status ]; then \
+ ./config.status --recheck; \
+ else \
+ $(srcdir)/configure; \
+ fi
+
+Makefile: config.status Makefile.in
+ MAKE="$(MAKE)" ./config.status
+
+# Set up rules to build targets.
+
+.SUFFIXES: .c .s
+.c.o:
+ $(CC) -c $(CPPFLAGS) $(CFLAGS) $(DEPFLAGS) -I. -I$(srcdir) $< -o $@
+.s.o:
+ $(M4) $< > $(notdir $<).s
+ $(AS) $(ASFLAGS) $(notdir $<).s -o $@
+
+# Set up dependencies for config-mips.m4.
+
+config-mips.m4: config-mips.m4.in
+ cd $(srcdir) && ./config.status $@
+$(LOADOBJS): config-mips.m4
+
+# Set up rules to build libexec.a.
+
+libexec.a: $(OBJS)
+ $(AR) cru $(ARFLAGS) $@ $^
+
+# And loader.
+
+loader: $(LOADOBJS)
+ $(LD) -o $@ $(LOADERFLAGS) $(LOADOBJS)
+
+# And test.
+
+test: test.o libexec.a
+ $(CC) $(LDFLAGS) $< libexec.a -o $@
+
+# And exec1.
+
+exec1: exec1.o libexec.a
+ $(CC) $(LDFLAGS) $< libexec.a -o $@
+
+# Set up targets for cleaning.
+
+.PHONY: clean distclean maintainer-clean extraclean bootstrap-clean
+clean:
+ rm -f *.o *.a loader test exec1 *.s.s
+ifeq ($(AUTO_DEPEND),yes)
+ rm -rf deps/*.d
+endif
+
+distclean: clean
+ rm -f Makefile config.status config.h config-mips.m4
+
+maintainer-clean: distclean
+
+### This doesn't actually appear in the coding standards, but Karl
+### says GCC supports it, and that's where the configuration part of
+### the coding standards seem to come from. It's like distclean, but
+### it deletes backup and autosave files too.
+
+# config.* and install-sh are copied from build-aux in the root of
+# this repository by autogen.sh.
+extraclean: maintainer-clean
+ -rm -f config-tmp-* $(srcdir)/aclocal.m4 $(srcdir)/configure \
+ $(srcdir)/src/config.in $(srcdir)/config.guess \
+ $(srcdir)/config.sub $(srcdir)/install-sh
+ -[ "$(srcdir)" = "." ] || \
+ find $(srcdir) '(' -name '*~' -o -name '#*' ')' $(FIND_DELETE)
+ -find . '(' -name '*~' -o -name '#*' ')' $(FIND_DELETE)
+bootstrap-clean: extraclean
diff --git a/exec/README b/exec/README
new file mode 100644
index 00000000000..f7eb21cfc84
--- /dev/null
+++ b/exec/README
@@ -0,0 +1,3 @@
+This directory holds the source code to a library used to replace the
+`execve' and `execveat' system calls, used by the Android port of
+Emacs to start executables without intervention from the system.
diff --git a/exec/config-mips.m4.in b/exec/config-mips.m4.in
new file mode 100644
index 00000000000..67a14e36b61
--- /dev/null
+++ b/exec/config-mips.m4.in
@@ -0,0 +1,42 @@
+dnl Assembler templates for MIPS computers.
+dnl
+dnl Copyright (C) 2023-2024 Free Software Foundation, Inc.
+dnl
+dnl This file is part of GNU Emacs.
+dnl
+dnl GNU Emacs is free software: you can redistribute it and/or modify
+dnl it under the terms of the GNU General Public License as published by
+dnl the Free Software Foundation, either version 3 of the License, or
+dnl (at your option) any later version.
+dnl
+dnl GNU Emacs is distributed in the hope that it will be useful,
+dnl but WITHOUT ANY WARRANTY; without even the implied warranty of
+dnl MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+dnl GNU General Public License for more details.
+dnl
+dnl You should have received a copy of the GNU General Public License
+dnl along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>.
+
+define(`SYSCALL_open', `ifelse(`@MIPS_N32@',`yes',`6002',`4005')')
+define(`SYSCALL_close', `ifelse(`@MIPS_N32@',`yes',`6003',`4006')')
+define(`SYSCALL_mmap', `ifelse(`@MIPS_N32@',`yes',`6009',`4090')')
+define(`SYSCALL_nanosleep', `ifelse(`@MIPS_N32@',`yes',`6034',`4166')')
+define(`SYSCALL_exit', `ifelse(`@MIPS_N32@',`yes',`6058',`4001')')
+define(`SYSCALL_prctl', `ifelse(`@MIPS_N32@',`yes',`6153',`4192')')
+
+define(`SYSCALL', `ifelse(`@MIPS_N32@',`yes',` move $a4, $1
+ move $a5, $2
+ move $a6, $3
+ move $a7, $4',` addi $sp, -32
+ sw $1, 16($sp)
+ sw $2, 20($sp)
+ sw $3, 24($sp)
+ sw $4, 28($sp)')')
+
+define(`RESTORE', `ifelse(`@MIPS_N32@',`yes',` nop',` addi $sp, 32')')
+
+dnl For mips64. Some assemblers don't want to assemble `daddi'.
+define(`DADDI2', `ifelse(`@DADDI_BROKEN@',`yes',` li $at, $2
+dadd $1, $1, $at',` daddi $1, $2')')
+define(`DADDI3', `ifelse(`@DADDI_BROKEN@',`yes',` li $at, $3
+dadd $1, $2, $at',` daddi $1, $2, $3')')
diff --git a/exec/configure.ac b/exec/configure.ac
new file mode 100644
index 00000000000..a473a1dc633
--- /dev/null
+++ b/exec/configure.ac
@@ -0,0 +1,560 @@
+dnl Autoconf script for GNU Emacs's exec library.
+dnl To rebuild the 'configure' script from this, execute the command
+dnl autoconf
+dnl in the directory containing this script.
+dnl If you changed any AC_DEFINES, also run autoheader.
+dnl
+dnl Copyright (C) 2023-2024 Free Software Foundation, Inc.
+dnl
+dnl This file is part of GNU Emacs.
+dnl
+dnl GNU Emacs is free software: you can redistribute it and/or modify
+dnl it under the terms of the GNU General Public License as published by
+dnl the Free Software Foundation, either version 3 of the License, or
+dnl (at your option) any later version.
+dnl
+dnl GNU Emacs is distributed in the hope that it will be useful,
+dnl but WITHOUT ANY WARRANTY; without even the implied warranty of
+dnl MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+dnl GNU General Public License for more details.
+dnl
+dnl You should have received a copy of the GNU General Public License
+dnl along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>.
+
+AC_PREREQ([2.65])
+AC_INIT([libexec], [30.0.50], [bug-gnu-emacs@gnu.org], [],
+ [https://www.gnu.org/software/emacs/])
+
+AH_TOP([/* Copyright (C) 2024 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 <https://www.gnu.org/licenses/>. */])
+
+AC_ARG_WITH([reentrancy],
+ [AS_HELP_STRING([--with-reentrancy],
+ [Generate library which can be used within a signal handler.])],
+ [AC_DEFINE([REENTRANT], [1])])
+
+AC_USE_SYSTEM_EXTENSIONS
+AC_PROG_CC
+AC_PROG_CPP
+AC_PROG_INSTALL
+
+AC_TYPE_UINT8_T
+AC_TYPE_UINT16_T
+AC_TYPE_UINT32_T
+AC_TYPE_UINT64_T
+AC_TYPE_UINTPTR_T
+AC_TYPE_SIZE_T
+AC_TYPE_SSIZE_T
+AC_TYPE_PID_T
+
+AC_HEADER_STDBOOL
+AC_CHECK_FUNCS([getpagesize stpcpy])
+AC_CHECK_DECLS([stpcpy])
+AC_CHECK_FUNC([process_vm_readv],
+ [AC_CHECK_FUNC([process_vm_writev],
+ [AC_CHECK_DECL([process_vm_readv],
+ [AC_DEFINE([HAVE_PROCESS_VM], [1],
+ [Define to 1 if process_vm_readv is available.])],
+ [], [[
+#include <sys/uio.h>
+ ]])])])
+AC_CHECK_HEADERS([sys/param.h sys/uio.h])
+AC_CHECK_MEMBERS([siginfo_t.si_syscall], [], [],
+ [[
+#include <signal.h>
+ ]])
+
+AH_BOTTOM([
+#ifdef HAVE_STDBOOL_H
+# include <stdbool.h>
+#else
+# ifndef HAVE__BOOL
+# ifdef __cplusplus
+typedef bool _Bool;
+# else
+# define _Bool signed char
+# endif
+# endif
+# define bool _Bool
+# define false 0
+# define true 1
+# define __bool_true_false_are_defined 1
+#endif
+
+#ifdef HAVE_SYS_PARAM_H
+#include <sys/param.h>
+#endif /* HAVE_SYS_PARAM_H */
+
+#ifndef MAX
+#define MAX(a, b) ((a) > (b) ? (a) : (b))
+#endif /* MAX */
+
+#ifndef MIN
+#define MIN(a, b) ((a) < (b) ? (a) : (b))
+#endif /* MIN */
+])
+
+AC_C_BIGENDIAN
+
+AH_TEMPLATE([SYSCALL_HEADER], [Define to header holding system call numbers.])
+AH_TEMPLATE([USER_HEADER], [Define to header holding USER_REGS_STRUCT.])
+AH_TEMPLATE([USER_REGS_STRUCT], [Define to structure holding user registers.])
+AH_TEMPLATE([SYSCALL_NUM_REG], [Define to register holding the system call number.])
+AH_TEMPLATE([SYSCALL_ARG_REG], [Define to register holding arg0 to system calls.])
+AH_TEMPLATE([SYSCALL_ARG1_REG], [Define to register holding arg1 to system calls.])
+AH_TEMPLATE([SYSCALL_ARG2_REG], [Define to register holding arg2 to system calls.])
+AH_TEMPLATE([SYSCALL_ARG3_REG], [Define to register holding arg3 to system calls.])
+AH_TEMPLATE([SYSCALL_RET_REG], [Define to register holding value of system calls.])
+AH_TEMPLATE([STACK_POINTER], [Define to register holding the stack pointer.])
+AH_TEMPLATE([EXEC_SYSCALL], [Define to number of the `exec' system call.])
+AH_TEMPLATE([USER_WORD], [Define to word type used by tracees.])
+AH_TEMPLATE([USER_SWORD], [Define to signed word type used by tracees.])
+AH_TEMPLATE([EXEC_64], [Define to 1 if the system utilizes 64-bit ELF.])
+AH_TEMPLATE([STACK_GROWS_DOWNWARDS], [Define to 1 if the stack grows downwards.])
+AH_TEMPLATE([ABI_RED_ZONE], [Define to number of reserved bytes past the stack frame.])
+AH_TEMPLATE([EXECUTABLE_BASE], [Virtual address for loading PIC executables])
+AH_TEMPLATE([INTERPRETER_BASE], [Virtual address for loading PIC interpreters])
+AH_TEMPLATE([CLONE_SYSCALL], [Define to number of the `clone' system call.])
+AH_TEMPLATE([CLONE3_SYSCALL], [Define to number of the `clone3' system call.])
+AH_TEMPLATE([READLINK_SYSCALL], [Define to number of the `readlink' system call.])
+AH_TEMPLATE([READLINKAT_SYSCALL], [Define to number of the `readlinkat' system call.])
+AH_TEMPLATE([OPEN_SYSCALL], [Define to number of the `open' system call.])
+AH_TEMPLATE([OPENAT_SYSCALL], [Define to number of the `openat' system call.])
+AH_TEMPLATE([REENTRANT], [Define to 1 if the library is used within a signal handler.])
+
+AC_CANONICAL_HOST
+
+# Check whether or not sys/user exists. If it doesn't, try
+# asm/user.h, and croak if that doesn't exist either.
+AS_CASE([$host], [*mips*], [], [*],
+ [AC_CHECK_HEADER([sys/user.h], [user_h="<sys/user.h>"],
+ [AC_CHECK_HEADER([asm/user.h], [user_h="<asm/user.h>"],
+ [AC_MSG_ERROR([Can not find working user.h])])])])
+
+# Look for required tools.
+
+AC_ARG_VAR([M4], [`m4' preprocessor command.])
+AC_ARG_VAR([AS], [`as' assembler command.])
+AC_ARG_VAR([LD], [`ld' linker command.])
+
+# Check for a working m4.
+AC_CHECK_PROGS([M4], [gm4 m4],
+ [AC_MSG_ERROR([Cannot find m4])])
+
+# Check for a working assembler.
+AC_CHECK_TOOL([AS], [as],
+ [AC_MSG_ERROR([Cannot find a working assembler])])
+
+# And ar.
+AC_CHECK_TOOL([AR], [ar],
+ [AC_MSG_ERROR([Cannot find a working ar])])
+
+# And ld.
+AC_CHECK_TOOL([LD], [ld],
+ [AC_MSG_ERROR([Cannot find a working linker])])
+
+# Now check if ld is a C compiler.
+LDPREFIX=
+AC_CACHE_CHECK([whether ld is a C compiler],
+ [exec_cv_ld_is_cc],
+ [cat <<_ACEOF > conftest.c
+AC_LANG_PROGRAM(,)
+_ACEOF
+ exec_cv_ld_is_cc=yes
+ $LD -c conftest.c -o conftest.$OBJEXT >&AS_MESSAGE_LOG_FD 2>&1 \
+ || exec_cv_ld_is_cc=no
+ rm -f conftest.c conftest.$OBJEXT])
+
+# And if as is a C compiler.
+AC_CACHE_CHECK([whether as is a C compiler],
+ [exec_cv_as_is_cc],
+ [cat <<_ACEOF > conftest.c
+AC_LANG_PROGRAM(,)
+_ACEOF
+ exec_cv_as_is_cc=yes
+ $AS -c conftest.c -o conftest.$OBJEXT >&AS_MESSAGE_LOG_FD 2>&1 \
+ || exec_cv_as_is_cc=no
+ rm -f conftest.c conftest.$OBJEXT])
+
+# If ld is a C compiler, pass `-nostdlib', `-nostartfiles', and
+# `-static'. Also, set LDPREFIX to -Wl,
+AS_IF([test "x$exec_cv_ld_is_cc" = "xyes"],
+ [LOADERFLAGS="$LOADERFLAGS -nostdlib -nostartfiles -static"
+ LDPREFIX=-Wl,])
+
+# If as is a C compiler, add `-c' to ASFLAGS.
+AS_IF([test "x$exec_cv_as_is_cc" = "xyes"],
+ [ASFLAGS="$ASFLAGS -c"])
+
+AC_DEFUN([exec_CHECK_LINUX_CLONE3],
+[
+AC_CHECK_DECL([__NR_clone3],
+ [AC_DEFINE([CLONE3_SYSCALL], [__NR_clone3])],
+ [], [[
+#include <asm/unistd.h>
+]])
+])
+
+AC_DEFUN([exec_CHECK_MIPS_NABI],
+[
+AC_CACHE_CHECK([whether MIPS NABI calling convention is used],
+ [exec_cv_mips_nabi],
+ [AC_COMPILE_IFELSE([AC_LANG_PROGRAM([[
+#include <sgidefs.h>
+]], [[
+#ifndef __mips64__
+#if _MIPS_SIM == _ABIO32
+OABI in use.
+#endif /* _MIPS_SIM == _ABIO32 */
+#endif /* !__mips64__ */
+]])], [exec_cv_mips_nabi=yes],
+ [exec_cv_mips_nabi=no])])
+
+dnl mips64 systems use N64 calling convention, a variant of nabi
+dnl calling convention.
+AS_IF([test "x$exec_cv_mips_nabi" != "xno"],
+ [AC_DEFINE([MIPS_NABI], [1],
+ [Define to 1 if MIPS NABI calling convention is being used.])],
+ [OBJS="$OBJS mipsfpu.o"])
+])
+
+# Determine the system type and define appropriate macros.
+exec_loader=
+is_mips=
+OBJS="exec.o trace.o"
+DADDI_BROKEN=no
+
+AS_CASE([$host], [x86_64-*linux*],
+ [AC_CHECK_MEMBER([struct user_regs_struct.rdi],
+ [AC_DEFINE([SYSCALL_HEADER], [<asm/unistd.h>])
+ AC_DEFINE_UNQUOTED([USER_HEADER], [$user_h])
+ AC_DEFINE([USER_REGS_STRUCT], [struct user_regs_struct])
+ AC_DEFINE([SYSCALL_NUM_REG], [orig_rax])
+ AC_DEFINE([SYSCALL_RET_REG], [rax])
+ AC_DEFINE([SYSCALL_ARG_REG], [rdi])
+ AC_DEFINE([SYSCALL_ARG1_REG], [rsi])
+ AC_DEFINE([SYSCALL_ARG2_REG], [rdx])
+ AC_DEFINE([SYSCALL_ARG3_REG], [r10])
+ AC_DEFINE([STACK_POINTER], [rsp])
+ AC_DEFINE([EXEC_SYSCALL], [__NR_execve])
+ AC_DEFINE([USER_WORD], [uintptr_t])
+ AC_DEFINE([USER_SWORD], [intptr_t])
+ AC_DEFINE([EXEC_64], [1])
+ AC_DEFINE([ABI_RED_ZONE], [128])
+ AC_DEFINE([EXECUTABLE_BASE], [0x555555554000])
+ AC_DEFINE([INTERPRETER_BASE], [0x600000000000])
+ AC_DEFINE([STACK_GROWS_DOWNWARDS], [1])
+ AC_DEFINE([CLONE_SYSCALL], [__NR_clone])
+ AC_DEFINE([READLINK_SYSCALL], [__NR_readlink])
+ AC_DEFINE([READLINKAT_SYSCALL], [__NR_readlinkat])
+ AC_DEFINE([OPEN_SYSCALL], [__NR_open])
+ AC_DEFINE([OPENAT_SYSCALL], [__NR_openat])
+ exec_CHECK_LINUX_CLONE3
+ # Make sure the loader doesn't conflict with other position
+ # dependent code.
+ LOADERFLAGS="$LOADERFLAGS $LDPREFIX-Ttext=0x200000000000"
+ exec_loader=loader-x86_64.s],
+ [AC_MSG_ERROR([Missing `rdi' in user_regs_struct])],
+ [[
+#include $user_h
+ ]])], [i[[34567]]86-*linux*],
+ [AC_CHECK_MEMBER([struct user_regs_struct.edi],
+ [AC_DEFINE([SYSCALL_HEADER], [<asm/unistd.h>])
+ AC_DEFINE_UNQUOTED([USER_HEADER], [$user_h])
+ AC_DEFINE([USER_REGS_STRUCT], [struct user_regs_struct])
+ AC_DEFINE([SYSCALL_NUM_REG], [orig_eax])
+ AC_DEFINE([SYSCALL_RET_REG], [eax])
+ AC_DEFINE([SYSCALL_ARG_REG], [ebx])
+ AC_DEFINE([SYSCALL_ARG1_REG], [ecx])
+ AC_DEFINE([SYSCALL_ARG2_REG], [edx])
+ AC_DEFINE([SYSCALL_ARG3_REG], [esi])
+ AC_DEFINE([STACK_POINTER], [esp])
+ AC_DEFINE([EXEC_SYSCALL], [__NR_execve])
+ AC_DEFINE([USER_WORD], [uintptr_t])
+ AC_DEFINE([USER_SWORD], [intptr_t])
+ AC_DEFINE([EXECUTABLE_BASE], [0x0f000000])
+ AC_DEFINE([INTERPRETER_BASE], [0xaf000000])
+ AC_DEFINE([STACK_GROWS_DOWNWARDS], [1])
+ AC_DEFINE([CLONE_SYSCALL], [__NR_clone])
+ AC_DEFINE([READLINK_SYSCALL], [__NR_readlink])
+ AC_DEFINE([READLINKAT_SYSCALL], [__NR_readlinkat])
+ AC_DEFINE([OPEN_SYSCALL], [__NR_open])
+ AC_DEFINE([OPENAT_SYSCALL], [__NR_openat])
+ exec_CHECK_LINUX_CLONE3
+ # Make sure the loader doesn't conflict with other position
+ # dependent code.
+ LOADERFLAGS="$LOADERFLAGS $LDPREFIX-Ttext=0xa0000000"
+ exec_loader=loader-x86.s],
+ [AC_MSG_ERROR([Missing `edi' in user_regs_struct])],
+ [[
+#include $user_h
+ ]])], [aarch64-*linux*],
+ [AC_CHECK_MEMBER([struct user_regs_struct.sp],
+ [AC_DEFINE([SYSCALL_HEADER], [<asm/unistd.h>])
+ AC_DEFINE_UNQUOTED([USER_HEADER], [$user_h])
+ AC_DEFINE([USER_REGS_STRUCT], [struct user_regs_struct])
+ AC_DEFINE([SYSCALL_NUM_REG], [[regs[8]]])
+ AC_DEFINE([SYSCALL_RET_REG], [[regs[0]]])
+ AC_DEFINE([SYSCALL_ARG_REG], [[regs[0]]])
+ AC_DEFINE([SYSCALL_ARG1_REG], [[regs[1]]])
+ AC_DEFINE([SYSCALL_ARG2_REG], [[regs[2]]])
+ AC_DEFINE([SYSCALL_ARG3_REG], [[regs[3]]])
+ AC_DEFINE([STACK_POINTER], [sp])
+ AC_DEFINE([EXEC_SYSCALL], [__NR_execve])
+ AC_DEFINE([USER_WORD], [uintptr_t])
+ AC_DEFINE([USER_SWORD], [intptr_t])
+ AC_DEFINE([EXEC_64], [1])
+ AC_DEFINE([EXECUTABLE_BASE], [0x3000000000])
+ AC_DEFINE([INTERPRETER_BASE], [0x3f00000000])
+ AC_DEFINE([STACK_GROWS_DOWNWARDS], [1])
+ AC_DEFINE([CLONE_SYSCALL], [__NR_clone])
+ # Note that aarch64 has neither `readlink' nor `open'.
+ AC_DEFINE([READLINKAT_SYSCALL], [__NR_readlinkat])
+ AC_DEFINE([OPENAT_SYSCALL], [__NR_openat])
+ exec_CHECK_LINUX_CLONE3
+ # Make sure the loader doesn't conflict with other position
+ # dependent code. ARM places rather significant restrictions on
+ # virtual addresses for a 64 bit architecture.
+ LOADERFLAGS="$LOADERFLAGS $LDPREFIX-Ttext=0x2000000000"
+ exec_loader=loader-aarch64.s],
+ [AC_MSG_ERROR([Missing `sp' in user_regs_struct])],
+ [[
+#include $user_h
+ ]])], [arm*linux*eabi* | armv7*linux*],
+ [AC_CHECK_MEMBER([struct user_regs.uregs],
+ [AC_DEFINE([SYSCALL_HEADER], [<asm/unistd.h>])
+ AC_DEFINE_UNQUOTED([USER_HEADER], [$user_h])
+ AC_DEFINE([USER_REGS_STRUCT], [struct user_regs])
+ AC_DEFINE([SYSCALL_NUM_REG], [[uregs[7]]])
+ AC_DEFINE([SYSCALL_RET_REG], [[uregs[0]]])
+ AC_DEFINE([SYSCALL_ARG_REG], [[uregs[0]]])
+ AC_DEFINE([SYSCALL_ARG1_REG], [[uregs[1]]])
+ AC_DEFINE([SYSCALL_ARG2_REG], [[uregs[2]]])
+ AC_DEFINE([SYSCALL_ARG3_REG], [[uregs[3]]])
+ AC_DEFINE([STACK_POINTER], [[uregs[13]]])
+ AC_DEFINE([EXEC_SYSCALL], [__NR_execve])
+ AC_DEFINE([USER_WORD], [uintptr_t])
+ AC_DEFINE([USER_SWORD], [intptr_t])
+ AC_DEFINE([EXECUTABLE_BASE], [0x0f000000])
+ AC_DEFINE([INTERPRETER_BASE], [0x1f000000])
+ AC_DEFINE([STACK_GROWS_DOWNWARDS], [1])
+ AC_DEFINE([CLONE_SYSCALL], [__NR_clone])
+ AC_DEFINE([READLINK_SYSCALL], [__NR_readlink])
+ AC_DEFINE([READLINKAT_SYSCALL], [__NR_readlinkat])
+ AC_DEFINE([OPEN_SYSCALL], [__NR_open])
+ AC_DEFINE([OPENAT_SYSCALL], [__NR_openat])
+ exec_CHECK_LINUX_CLONE3
+ LOADERFLAGS="$LOADERFLAGS $LDPREFIX-Ttext=0x20000000"
+ exec_loader=loader-armeabi.s],
+ [AC_CHECK_MEMBER([struct pt_regs.uregs],
+ [AC_DEFINE([SYSCALL_HEADER], [<asm/unistd.h>])
+ AC_DEFINE_UNQUOTED([USER_HEADER], [<asm/ptrace.h>])
+ AC_DEFINE([USER_REGS_STRUCT], [struct pt_regs])
+ AC_DEFINE([SYSCALL_NUM_REG], [[uregs[7]]])
+ AC_DEFINE([SYSCALL_RET_REG], [[uregs[0]]])
+ AC_DEFINE([SYSCALL_ARG_REG], [[uregs[0]]])
+ AC_DEFINE([SYSCALL_ARG1_REG], [[uregs[1]]])
+ AC_DEFINE([SYSCALL_ARG2_REG], [[uregs[2]]])
+ AC_DEFINE([SYSCALL_ARG3_REG], [[uregs[3]]])
+ AC_DEFINE([STACK_POINTER], [[uregs[13]]])
+ AC_DEFINE([EXEC_SYSCALL], [__NR_execve])
+ AC_DEFINE([USER_WORD], [uintptr_t])
+ AC_DEFINE([USER_SWORD], [intptr_t])
+ AC_DEFINE([EXECUTABLE_BASE], [0x0f000000])
+ AC_DEFINE([INTERPRETER_BASE], [0x1f000000])
+ AC_DEFINE([STACK_GROWS_DOWNWARDS], [1])
+ AC_DEFINE([CLONE_SYSCALL], [__NR_clone])
+ AC_DEFINE([READLINK_SYSCALL], [__NR_readlink])
+ AC_DEFINE([READLINKAT_SYSCALL], [__NR_readlinkat])
+ AC_DEFINE([OPEN_SYSCALL], [__NR_open])
+ AC_DEFINE([OPENAT_SYSCALL], [__NR_openat])
+ exec_CHECK_LINUX_CLONE3
+ LOADERFLAGS="$LOADERFLAGS $LDPREFIX-Ttext=0x20000000"
+ exec_loader=loader-armeabi.s],
+ [AC_MSG_ERROR([Missing `uregs' in user_regs_struct or pt_regs])],
+ [[
+#include <asm/ptrace.h>
+ ]])],
+ [[
+#include $user_h
+ ]])], [mipsel*linux*],
+ [AC_DEFINE([SYSCALL_HEADER], [<asm/unistd.h>])
+ AC_DEFINE([USER_HEADER], ["mipsel-user.h"])
+ AC_DEFINE([USER_REGS_STRUCT], [struct mipsel_regs])
+ AC_DEFINE([SYSCALL_NUM_REG], [[gregs[2]]]) # v0
+ AC_DEFINE([SYSCALL_RET_REG], [[gregs[4]]]) # a0
+ AC_DEFINE([SYSCALL_ARG_REG], [[gregs[4]]]) # a0
+ AC_DEFINE([SYSCALL_ARG1_REG], [[gregs[5]]]) # a1
+ AC_DEFINE([SYSCALL_ARG2_REG], [[gregs[4]]]) # a2
+ AC_DEFINE([SYSCALL_ARG3_REG], [[gregs[5]]]) # a3
+ AC_DEFINE([STACK_POINTER], [[gregs[29]]]) # sp
+ AC_DEFINE([EXEC_SYSCALL], [__NR_execve])
+ AC_DEFINE([USER_WORD], [uintptr_t])
+ AC_DEFINE([USER_SWORD], [intptr_t])
+ AC_DEFINE([EXECUTABLE_BASE], [0x0f000000])
+ AC_DEFINE([INTERPRETER_BASE], [0x1f000000])
+ AC_DEFINE([STACK_GROWS_DOWNWARDS], [1])
+ AC_DEFINE([CLONE_SYSCALL], [__NR_clone])
+ AC_DEFINE([READLINK_SYSCALL], [__NR_readlink])
+ AC_DEFINE([READLINKAT_SYSCALL], [__NR_readlinkat])
+ AC_DEFINE([OPEN_SYSCALL], [__NR_open])
+ AC_DEFINE([OPENAT_SYSCALL], [__NR_openat])
+ AC_CHECK_DECL([_MIPS_SIM], [exec_CHECK_MIPS_NABI],
+ [AC_MSG_ERROR([_MIPS_SIM could not be determined]),
+ [[
+#include <sgidefs.h>
+]]])
+ exec_CHECK_LINUX_CLONE3
+ LOADERFLAGS="$LOADERFLAGS $LDPREFIX-Ttext=0x20000000"
+ is_mips=yes
+ exec_loader=loader-mipsel.s], [mips64el*linux*],
+ [AC_DEFINE([SYSCALL_HEADER], [<asm/unistd.h>])
+ AC_DEFINE([USER_HEADER], ["mipsel-user.h"])
+ AC_DEFINE([USER_REGS_STRUCT], [struct mipsel_regs])
+ AC_DEFINE([SYSCALL_NUM_REG], [[gregs[2]]]) # v0
+ AC_DEFINE([SYSCALL_RET_REG], [[gregs[4]]]) # a0
+ AC_DEFINE([SYSCALL_ARG_REG], [[gregs[4]]]) # a0
+ AC_DEFINE([SYSCALL_ARG1_REG], [[gregs[5]]]) # a1
+ AC_DEFINE([SYSCALL_ARG2_REG], [[gregs[4]]]) # a2
+ AC_DEFINE([SYSCALL_ARG3_REG], [[gregs[5]]]) # a3
+ AC_DEFINE([STACK_POINTER], [[gregs[29]]]) # sp
+ AC_DEFINE([EXEC_SYSCALL], [__NR_execve])
+ AC_DEFINE([USER_WORD], [uintptr_t])
+ AC_DEFINE([USER_SWORD], [intptr_t])
+ AC_DEFINE([EXEC_64], [1])
+ AC_DEFINE([EXECUTABLE_BASE], [0x400000])
+ AC_DEFINE([INTERPRETER_BASE], [0x3f00000000])
+ AC_DEFINE([STACK_GROWS_DOWNWARDS], [1])
+ AC_DEFINE([CLONE_SYSCALL], [__NR_clone])
+ AC_DEFINE([READLINK_SYSCALL], [__NR_readlink])
+ AC_DEFINE([READLINKAT_SYSCALL], [__NR_readlinkat])
+ AC_DEFINE([OPEN_SYSCALL], [__NR_open])
+ AC_DEFINE([OPENAT_SYSCALL], [__NR_openat])
+ AC_CACHE_CHECK([whether as understands `daddi'],
+ [exec_cv_as_daddi],
+ [exec_cv_as_daddi=no
+ cat <<_ACEOF >conftest.s
+ .section text
+ .global __start
+__start:
+ li $t0, 0
+ li $t1, 0
+ daddi $t0, $t1, 1
+ daddi $t0, $t1, -1
+ daddi $t0, -1
+ daddi $t0, 1
+
+_ACEOF
+ $AS $ASFLAGS conftest.s -o conftest.$OBJEXT \
+ >&AS_MESSAGE_LOG_FD 2>&1 \
+ && exec_cv_as_daddi=yes
+ rm -f conftest.s conftest.$OBJEXT])
+ AS_IF([test "x$exec_cv_as_daddi" != "xyes"],
+ [DADDI_BROKEN=yes])
+ exec_CHECK_LINUX_CLONE3
+ exec_CHECK_MIPS_NABI
+ LOADERFLAGS="$LOADERFLAGS $LDPREFIX-Ttext=0x3e00000000"
+ is_mips=yes
+ exec_loader=loader-mips64el.s], [*],
+ [AC_MSG_ERROR([Please port libexec to $host])])
+
+AC_SUBST([DADDI_BROKEN])
+
+MIPS_N32=$exec_cv_mips_nabi
+
+AC_ARG_VAR([LOADERFLAGS], [Flags used to link the loader.])
+AC_ARG_VAR([ARFLAGS], [Flags for the archiver.])
+AC_ARG_VAR([ASFLAGS], [Flags for the assembler.])
+
+# Make the assembler optimize for code size. Don't do this on MIPS,
+# as the assembler code manages branch delays manually.
+
+AC_CACHE_CHECK([whether as understands -O],
+ [exec_cv_as_O],
+ [exec_cv_as_O=no
+ cat <<_ACEOF >conftest.s
+ .section text
+ .global _start
+_start:
+
+_ACEOF
+ $AS $ASFLAGS -O conftest.s -o conftest.$OBJEXT \
+ >&AS_MESSAGE_LOG_FD 2>&1 \
+ && exec_cv_as_O=yes
+ rm -f conftest.s conftest.$OBJEXT])
+
+AS_IF([test "$exec_cv_as_O" = "yes" \
+ && test "$is_mips" != "yes"],
+ [ASFLAGS="$ASFLAGS -O"])
+
+# Make the assembler generate debug information.
+
+AC_CACHE_CHECK([whether as understands -g],
+ [exec_cv_as_g],
+ [exec_cv_as_g=no
+ cat <<_ACEOF >conftest.s
+ .section text
+ .global _start
+_start:
+
+_ACEOF
+ $AS $ASFLAGS -g conftest.s -o conftest.$OBJEXT \
+ >&AS_MESSAGE_LOG_FD 2>&1 \
+ && exec_cv_as_g=yes
+ rm -f conftest.s conftest.$OBJEXT])
+AS_IF([test "$exec_cv_as_g" = "yes"], [ASFLAGS="$ASFLAGS -g"])
+
+# Check for the ability to automatically generate dependencies for C
+# source files.
+AUTO_DEPEND=no
+AS_IF([test "x$GCC" = xyes],
+ [AC_CACHE_CHECK([whether gcc understands -MMD -MF],
+ [exec_cv_autodepend],
+ [SAVE_CFLAGS="$CFLAGS"
+ CFLAGS="$CFLAGS -MMD -MF deps.d -MP"
+ AC_COMPILE_IFELSE([AC_LANG_PROGRAM([[]], [[]])],
+ [exec_cv_autodepend=yes],
+ [exec_cv_autodepend=no])
+ CFLAGS="$SAVE_CFLAGS"
+ test -f deps.d || emacs_cv_autodepend=no
+ rm -rf deps.d])
+ AS_IF([test "x$exec_cv_autodepend" = xyes],
+ [AUTO_DEPEND=yes
+ AS_MKDIR_P([deps])])])
+
+# Now check for some other stuff.
+
+AC_CACHE_CHECK([for 'find' args to delete a file],
+ [exec_cv_find_delete],
+ [AS_IF([touch conftest.tmp && find conftest.tmp -delete 2>/dev/null &&
+ test ! -f conftest.tmp], [exec_cv_find_delete="-delete"],
+ [exec_cv_find_delete="-exec rm -f {} ';'"])])
+FIND_DELETE=$exec_cv_find_delete
+AC_SUBST([FIND_DELETE])
+
+AC_CONFIG_HEADERS([config.h])
+AC_CONFIG_FILES([Makefile config-mips.m4])
+
+AC_SUBST([AUTO_DEPEND])
+AC_SUBST([LOADERFLAGS])
+AC_SUBST([ARFLAGS])
+AC_SUBST([ASFLAGS])
+AC_SUBST([exec_loader])
+AC_SUBST([MIPS_N32])
+AC_SUBST([OBJS])
+
+AC_OUTPUT
diff --git a/exec/deps.mk b/exec/deps.mk
new file mode 100644
index 00000000000..2425503ab44
--- /dev/null
+++ b/exec/deps.mk
@@ -0,0 +1,21 @@
+### deps.mk
+
+## Copyright (C) 2023-2024 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 <https://www.gnu.org/licenses/>.
+
+exec.o: exec.h config.h
+trace.o: exec.h config.h
diff --git a/exec/exec.c b/exec/exec.c
new file mode 100644
index 00000000000..cbe22d4f18c
--- /dev/null
+++ b/exec/exec.c
@@ -0,0 +1,1168 @@
+/* Program execution for Emacs.
+
+Copyright (C) 2023-2024 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 <https://www.gnu.org/licenses/>. */
+
+#include <config.h>
+
+#include <errno.h>
+#include <unistd.h>
+#include <fcntl.h>
+#include <assert.h>
+#include <string.h>
+#include <ctype.h>
+#include <stdlib.h>
+
+#include <sys/ptrace.h>
+#include <sys/param.h>
+#include <sys/mman.h>
+
+#include "exec.h"
+
+#if defined __mips__ && !defined MIPS_NABI
+#include "mipsfpu.h"
+#endif /* defined __mips__ && !defined MIPS_NABI */
+
+
+
+
+/* Define replacements for required string functions. */
+
+#if !defined HAVE_STPCPY || !defined HAVE_DECL_STPCPY
+
+/* Copy SRC to DEST, returning the address of the terminating '\0' in
+ DEST. */
+
+static char *
+rpl_stpcpy (char *dest, const char *src)
+{
+ register char *d;
+ register const char *s;
+
+ d = dest;
+ s = src;
+
+ do
+ *d++ = *s;
+ while (*s++ != '\0');
+
+ return d - 1;
+}
+
+#define stpcpy rpl_stpcpy
+#endif /* !defined HAVE_STPCPY || !defined HAVE_DECL_STPCPY */
+
+
+
+/* Executable reading functions.
+ These functions extract information from an executable that is
+ about to be loaded.
+
+ `exec_0' takes the name of the program, determines whether or not
+ its format is correct, and if so, returns the list of actions that
+ the loader should perform.
+
+ The actions include:
+
+ - Making the stack executable, if PT_GNU_STACK.
+ - Mapping PT_LOAD sections into the executable with the correct
+ memory protection.
+ - On MIPS, setting the floating point register size.
+ - Transferring control to the interpreter or executable. */
+
+
+/* Check whether or not FD starts with a #!, and return the executable
+ to load if it does. Value is NAME if no interpreter character was
+ found, or the interpreter otherwise. Value is NULL upon an IO
+ error.
+
+ If an additional command line argument is specified, place it in
+ *EXTRA. */
+
+static const char *
+check_interpreter (const char *name, int fd, const char **extra)
+{
+ static char buffer[PATH_MAX], *start;
+ char first[2], *end, *ws;
+ ssize_t rc;
+
+ /* Read the first character. */
+ rc = read (fd, &first, 2);
+
+ if (rc != 2)
+ goto fail;
+
+ if (first[0] != '#' || first[1] != '!')
+ goto nomatch;
+
+ rc = read (fd, buffer, PATH_MAX);
+
+ if (rc < 0)
+ goto fail;
+
+ /* Strip leading whitespace. */
+ start = buffer;
+ while (*start && ((unsigned char) *start) < 128 && isspace (*start))
+ ++start;
+
+ /* Look for a newline character. */
+ end = memchr (start, '\n', rc);
+
+ if (!end)
+ goto fail;
+
+ /* The string containing the interpreter is now in start. NULL
+ terminate it. */
+ *end = '\0';
+
+ /* Now look for any whitespace characters. */
+ ws = strchr (start, ' ');
+
+ /* If there's no whitespace, return the entire start. */
+
+ if (!ws)
+ {
+ if (lseek (fd, 0, SEEK_SET))
+ goto fail;
+
+ return start;
+ }
+
+ /* Otherwise, split the string at the whitespace and return the
+ additional argument. */
+ *ws = '\0';
+
+ if (lseek (fd, 0, SEEK_SET))
+ goto fail;
+
+ *extra = ws + 1;
+ return start;
+
+ nomatch:
+ /* There's no interpreter. */
+ if (lseek (fd, 0, SEEK_SET))
+ goto fail;
+
+ return name;
+
+ fail:
+ errno = ENOEXEC;
+ return NULL;
+}
+
+/* Static area used to store data placed on the loader's stack. */
+static char loader_area[65536];
+
+/* Number of bytes used in that area. */
+static int loader_area_used;
+
+
+
+/* Structure definitions for commands placed in the loader area.
+ Arrange these so that each member is naturally aligned. */
+
+struct exec_open_command
+{
+ /* Word identifying the type of this command. */
+ USER_WORD command;
+
+ /* NULL-terminated file name follows, padded to the size of a user
+ word. */
+};
+
+struct exec_map_command
+{
+ /* Word identifying the type of this command. */
+ USER_WORD command;
+
+ /* Where the file will be mapped. */
+ USER_WORD vm_address;
+
+ /* Offset into the file to map from. */
+ USER_WORD file_offset;
+
+ /* Memory protection for mprotect. */
+ USER_WORD protection;
+
+ /* Number of bytes to be mapped. */
+ USER_WORD length;
+
+ /* Flags for mmap. */
+ USER_WORD flags;
+
+ /* Number of bytes to clear at the end of this mapping. */
+ USER_WORD clear;
+};
+
+struct exec_jump_command
+{
+ /* Word identifying the type of this command. */
+ USER_WORD command;
+
+ /* Address to jump to. */
+ USER_WORD entry;
+
+ /* The value of AT_ENTRY inside the aux vector. */
+ USER_WORD at_entry;
+
+ /* The value of AT_PHENT inside the aux vector. */
+ USER_WORD at_phent;
+
+ /* The value of AT_PHNUM inside the aux vector. */
+ USER_WORD at_phnum;
+
+ /* The value of AT_PHDR inside the aux vector. */
+ USER_WORD at_phdr;
+
+ /* The value of AT_BASE inside the aux vector. */
+ USER_WORD at_base;
+
+#if defined __mips__ && !defined MIPS_NABI
+ /* The FPU mode to apply. */
+ USER_WORD fpu_mode;
+#endif /* defined __mips__ && !defined MIPS_NABI */
+};
+
+
+
+/* Write a command to open the file NAME to the loader area.
+ If ALTERNATE is true, then use the command code 16 instead
+ of 0. Value is 1 upon failure, else 0. */
+
+static int
+write_open_command (const char *name, bool alternate)
+{
+ struct exec_open_command command;
+ size_t size;
+
+ /* First, write the command to open NAME. This is followed by NAME
+ itself, padded to sizeof (USER_WORD) bytes. */
+
+ command.command = alternate ? 16 : 0;
+ if (sizeof loader_area - loader_area_used < sizeof command)
+ return 1;
+ memcpy (loader_area + loader_area_used, &command, sizeof command);
+ loader_area_used += sizeof command;
+
+ /* Calculate the length of NAME. */
+ size = strlen (name) + 1;
+
+ /* Round it up. */
+ size = ((size + (sizeof (USER_WORD) - 1))
+ & ~(sizeof (USER_WORD) - 1));
+
+ if (sizeof loader_area - loader_area_used < size)
+ return 1;
+
+ /* Now copy name to the loader area, filling the padding with NULL
+ bytes. */
+ strncpy (loader_area + loader_area_used, name, size);
+
+ /* Increase loader_area_used. */
+ loader_area_used += size;
+ return 0;
+}
+
+/* Write the commands necessary to map the executable file into memory
+ for the given PT_LOAD program HEADER. Value is 1 upon failure,
+ else 0. If USE_ALTERNATE, use the command code 17 instead of
+ 1.
+
+ Apply the given OFFSET to virtual addresses that will be mapped. */
+
+static int
+write_load_command (program_header *header, bool use_alternate,
+ USER_WORD offset)
+{
+ struct exec_map_command command;
+ struct exec_map_command command1;
+ USER_WORD start, end;
+ bool need_command1;
+ static long pagesize;
+
+ /* First, write the commands necessary to map the specified segment
+ itself.
+
+ This is the area between header->p_vaddr and header->p_filesz,
+ rounded up to the page size. */
+
+#ifndef PAGE_MASK
+ /* This system doesn't define a fixed page size. */
+
+#ifdef HAVE_GETPAGESIZE
+ if (!pagesize)
+ pagesize = getpagesize ();
+#else /* HAVE_GETPAGESIZE */
+ if (!pagesize)
+ pagesize = sysconf (_SC_PAGESIZE);
+#endif /* HAVE_GETPAGESIZE */
+
+#define PAGE_MASK (~(pagesize - 1))
+#define PAGE_SIZE (pagesize)
+#endif /* PAGE_MASK */
+
+ start = header->p_vaddr & PAGE_MASK;
+ end = ((header->p_vaddr + header->p_filesz
+ + PAGE_SIZE)
+ & PAGE_MASK);
+
+ command.command = use_alternate ? 17 : 1;
+ command.vm_address = start;
+ command.file_offset = header->p_offset & PAGE_MASK;
+ command.protection = 0;
+ command.length = end - start;
+ command.clear = 0;
+ command.flags = MAP_PRIVATE | MAP_FIXED;
+
+ /* Apply the memory protection specified in the header. */
+
+ if (header->p_flags & 4) /* PF_R */
+ command.protection |= PROT_READ;
+
+ if (header->p_flags & 2) /* PF_W */
+ command.protection |= PROT_WRITE;
+
+ if (header->p_flags & 1) /* PF_X */
+ command.protection |= PROT_EXEC;
+
+ /* Next, write any command necessary to map pages in the area
+ between p_filesz and p_memsz. */
+ need_command1 = false;
+
+ if (header->p_memsz > header->p_filesz)
+ {
+ /* If there are bytes after end which need to be initialized, do
+ that now. */
+ command.clear = end - header->p_vaddr - header->p_filesz;
+ start = end;
+ end = header->p_vaddr + header->p_memsz + PAGE_SIZE;
+ end &= PAGE_MASK;
+
+ if (end > start)
+ {
+ command1.command = 4;
+ command1.vm_address = start;
+ command1.file_offset = 0;
+ command1.length = end - start;
+ command1.clear = 0;
+ command1.protection = command.protection;
+ command1.flags = MAP_PRIVATE | MAP_ANONYMOUS | MAP_FIXED;
+ need_command1 = true;
+ }
+ }
+
+ /* Apply the offset to both commands if necessary. */
+
+ if (offset)
+ {
+ if (need_command1)
+ command1.vm_address += offset;
+
+ command.vm_address += offset;
+ }
+
+ /* Write both commands. */
+
+ if (sizeof loader_area - loader_area_used < sizeof command)
+ return 1;
+
+ memcpy (loader_area + loader_area_used, &command,
+ sizeof command);
+ loader_area_used += sizeof command;
+
+ if (!need_command1)
+ return 0;
+
+ if (sizeof loader_area - loader_area_used < sizeof command1)
+ return 1;
+
+ memcpy (loader_area + loader_area_used, &command1,
+ sizeof command1);
+ loader_area_used += sizeof command1;
+
+ return 0;
+}
+
+#if defined __mips__ && !defined MIPS_NABI
+
+/* Static storage used for MIPS ABI flags. */
+static struct mips_elf_abi_flags exec_abi, interpreter_abi;
+
+/* Static storage for interpreter headers. */
+static elf_header exec_interpreter_header;
+
+/* Pointer to the ELF header of this executable's interpreter. */
+static elf_header *interpreter_header;
+
+/* Pointer to any PT_MIPS_ABIFLAGS program header found in the
+ executable itself. */
+static struct mips_elf_abi_flags *exec_abiflags;
+
+/* Pointer to any PT_MIPS_ABIFLAGS program header found in the
+ executable's ELF interpreter. */
+static struct mips_elf_abi_flags *interpreter_abiflags;
+
+#endif /* defined __mips__ && !defined MIPS_NABI */
+
+/* Process the specified program HEADER; HEADER is from the ELF
+ interpreter of another executable. FD is the executable file from
+ which it is being read, NAME is its file name, and ELF_HEADER is
+ its header.
+
+ If ELF_HEADER->e_type is ET_DYN, add the base address for position
+ independent interpreter code to virtual addresses.
+
+ Value is 1 upon failure, else 0. */
+
+static int
+process_interpreter_1 (const char *name, int fd,
+ program_header *header,
+ elf_header *elf_header)
+{
+ int rc;
+#if defined __mips__ && !defined MIPS_NABI
+ ssize_t rc1;
+#endif /* defined __mips__ && !defined MIPS_NABI */
+
+ switch (header->p_type)
+ {
+ default: /* PT_NULL, PT_NOTE, PT_DYNAMIC, PT_INTERP, et cetera */
+ rc = 0;
+ break;
+
+ case 1: /* PT_LOAD */
+ /* This describes a segment in the file that must be loaded.
+ Write the appropriate load command. */
+
+ if (elf_header->e_type == 3) /* ET_DYN */
+ rc = write_load_command (header, true,
+ INTERPRETER_BASE);
+ else
+ rc = write_load_command (header, true, 0);
+
+ break;
+
+#if defined __mips__ && !defined MIPS_NABI
+ case 0x70000003: /* PT_MIPS_ABIFLAGS */
+ /* Record this header for later use. */
+ rc1 = pread (fd, &interpreter_abi, sizeof interpreter_abi,
+ header->p_offset);
+
+ if (rc1 != sizeof interpreter_abi)
+ return 1;
+
+ interpreter_abiflags = &interpreter_abi;
+ rc = 0;
+#endif /* defined __mips__ && !defined MIPS_NABI */
+ }
+
+ return rc;
+}
+
+/* Read the ELF interpreter specified in the given program header from
+ FD, and append the commands necessary to load it to the load area.
+ Then, return the interpreter entry point in *ENTRY.
+
+ Value is 1 upon failure, else 0. */
+
+static int
+process_interpreter (int fd, program_header *prog_header,
+ USER_WORD *entry)
+{
+ char buffer[PATH_MAX + 1];
+ int rc, size, i;
+ elf_header header;
+ program_header program;
+
+ /* Read the interpreter name. */
+ size = MIN (prog_header->p_filesz, PATH_MAX);
+ rc = pread (fd, buffer, size, prog_header->p_offset);
+ if (rc < size)
+ return 1;
+
+ /* Make sure the name is NULL terminated. */
+ buffer[size] = '\0';
+
+ /* Check if the file is executable. This is unfortunately not
+ atomic. */
+
+ if (access (buffer, X_OK))
+ return 1;
+
+ /* Read the interpreter's header much like exec_0.
+
+ However, use special command codes in `process_program_header' if
+ it is position independent. That way, the loader knows it should
+ use the open interpreter instead. */
+
+ fd = open (buffer, O_RDONLY);
+
+ if (fd < 0)
+ return 1;
+
+ rc = read (fd, &header, sizeof header);
+
+ if (rc < sizeof header)
+ goto fail;
+
+#if defined __mips__ && !defined MIPS_NABI
+ /* Record this interpreter's header for later use determining the
+ floating point ABI. */
+ exec_interpreter_header = header;
+ interpreter_header = &exec_interpreter_header;
+#endif /* defined __mips__ && !defined MIPS_NABI */
+
+ /* Verify that this is indeed an ELF file. */
+
+ if (header.e_ident[0] != 0x7f
+ || header.e_ident[1] != 'E'
+ || header.e_ident[2] != 'L'
+ || header.e_ident[3] != 'F')
+ goto fail;
+
+ /* Now check that the class is correct. */
+#ifdef EXEC_64
+ if (header.e_ident[4] != 2)
+ goto fail;
+#else /* !EXEC_64 */
+ if (header.e_ident[4] != 1)
+ goto fail;
+#endif /* EXEC_64 */
+
+ /* And the endianness. */
+#ifndef WORDS_BIGENDIAN
+ if (header.e_ident[5] != 1)
+ goto fail;
+#else /* WORDS_BIGENDIAN */
+ if (header.e_ident[5] != 2)
+ goto fail;
+#endif /* EXEC_64 */
+
+ /* Check that this is an executable. */
+ if (header.e_type != 2 && header.e_type != 3)
+ goto fail;
+
+ /* Now check that the ELF program header makes sense. */
+ if (header.e_phnum > 0xffff
+ || (header.e_phentsize
+ != sizeof (program_header)))
+ goto fail;
+
+ if (write_open_command (buffer, true))
+ goto fail;
+
+ for (i = 0; i < header.e_phnum; ++i)
+ {
+ rc = read (fd, &program, sizeof program);
+ if (rc < sizeof program)
+ goto fail;
+
+ if (process_interpreter_1 (buffer, fd, &program,
+ &header))
+ goto fail;
+ }
+
+ if (header.e_type == 3) /* ET_DYN */
+ *entry = header.e_entry + INTERPRETER_BASE;
+ else
+ *entry = header.e_entry;
+
+ close (fd);
+ return 0;
+
+ fail:
+ close (fd);
+ return 1;
+}
+
+/* Process the specified program HEADER. FD is the executable file
+ from which it is being read, NAME is its file name, and ELF_HEADER
+ is its header.
+
+ If ELF_HEADER->e_type is ET_DYN, add the base address for position
+ independent code to virtual addresses.
+
+ If OFFSET is non-NULL, and *OFFSET is -1, write the virtual address
+ of HEADER if it describes a PT_LOAD segment.
+
+ If an interpreter is found, set *ENTRY to its entry point.
+
+ Value is 1 upon failure, else 0. */
+
+static int
+process_program_header (const char *name, int fd,
+ program_header *header,
+ elf_header *elf_header,
+ USER_WORD *entry,
+ USER_WORD *offset)
+{
+ int rc;
+#if defined __mips__ && !defined MIPS_NABI
+ ssize_t rc1;
+#endif /* defined __mips__ && !defined MIPS_NABI */
+
+ switch (header->p_type)
+ {
+ default: /* PT_NULL, PT_NOTE, PT_DYNAMIC, et cetera */
+ rc = 0;
+ break;
+
+ case 1: /* PT_LOAD */
+ /* This describes a segment in the file that must be loaded.
+ Write the appropriate load command. */
+
+ if (elf_header->e_type == 3) /* ET_DYN */
+ {
+ rc = write_load_command (header, false,
+ EXECUTABLE_BASE);
+
+ if (!rc && offset && *offset == (USER_WORD) -1)
+ *offset = EXECUTABLE_BASE + header->p_vaddr;
+ }
+ else
+ {
+ rc = write_load_command (header, false, 0);
+
+ if (!rc && offset && *offset == (USER_WORD) -1)
+ *offset = header->p_vaddr;
+ }
+
+ break;
+
+ case 3: /* PT_INTERP */
+ /* This describes another executable that must be loaded. Open
+ the interpreter and process each of its headers as well. */
+ rc = process_interpreter (fd, header, entry);
+ break;
+
+ case 1685382481: /* PT_GNU_STACK */
+ /* TODO */
+ rc = 0;
+ break;
+
+#if defined __mips__ && !defined MIPS_NABI
+ case 0x70000003: /* PT_MIPS_ABIFLAGS */
+ /* Record this header for later use. */
+ rc1 = pread (fd, &exec_abi, sizeof exec_abi,
+ header->p_offset);
+
+ if (rc1 != sizeof exec_abi)
+ return 1;
+
+ exec_abiflags = &exec_abi;
+ rc = 0;
+#endif /* defined __mips__ && !defined MIPS_NABI */
+ }
+
+ return rc;
+}
+
+/* Prepend one or two extra arguments ARG1 and ARG2 to a pending
+ execve system call. Replace the argument immediately after
+ with ARG3.
+
+ TRACEE is the tracee performing the system call, and REGS are its
+ current user registers. Value is 1 upon failure, else 0. */
+
+static int
+insert_args (struct exec_tracee *tracee, USER_REGS_STRUCT *regs,
+ const char *arg1, const char *arg2, const char *arg3)
+{
+ USER_WORD argv, argc, word, new;
+ USER_WORD new1, new2, new3, i;
+ size_t text_size, effective_size;
+ USER_REGS_STRUCT original;
+
+ /* First, get a pointer to the current argument vector. */
+ argv = regs->SYSCALL_ARG1_REG;
+
+ /* Now figure out how many arguments there are. */
+ argc = 0;
+ while (true)
+ {
+ /* Clear errno. PTRACE_PEEKDATA returns the word read the same
+ way failure indications are returned, so the only way to
+ catch IO errors is by clearing errno before the call to
+ ptrace and checking it afterwards. */
+
+ errno = 0;
+ word = ptrace (PTRACE_PEEKDATA, tracee->pid,
+ (void *) argv, NULL);
+ argv += sizeof (USER_WORD);
+
+ if (errno)
+ return 1;
+
+ if (!word)
+ break;
+
+ ++argc;
+ };
+
+ /* Allocate enough to hold that many arguments, alongside the argc
+ text. */
+
+ text_size = (strlen (arg1) + 1
+ + (arg2 ? strlen (arg2) + 1 : 0)
+ + strlen (arg3) + 1);
+
+ /* Round it up to the user word size. */
+ text_size += sizeof (USER_WORD) - 1;
+ text_size &= ~(sizeof (USER_WORD) - 1);
+
+ /* Now allocate the new argv. Make sure argc is at least 1; it
+ needs to hold ARG3. */
+
+ effective_size = sizeof word * (MAX (1, argc) + 2) + text_size;
+
+ if (arg2)
+ effective_size += sizeof word;
+
+ /* Copy regs to original so that user_alloca knows it should append
+ the ABI red zone. */
+
+ memcpy (&original, regs, sizeof *regs);
+ new = user_alloca (tracee, &original, regs,
+ effective_size);
+
+ if (!new)
+ goto fail;
+
+ /* Figure out where argv starts. */
+
+ new3 = new + text_size;
+
+ /* Now write the first two strings. */
+
+ new1 = new + strlen (arg1) + 1;
+ new2 = new1 + (arg2 ? strlen (arg2) + 1 : 0);
+
+ if (user_copy (tracee, (const unsigned char *) arg1,
+ new, new1 - new))
+ goto fail;
+
+ if (arg2 && user_copy (tracee, (const unsigned char *) arg2,
+ new1, new2 - new1))
+ goto fail;
+
+ /* Write the replacement arg3, the file name of the executable. */
+
+ if (user_copy (tracee, (const unsigned char *) arg3,
+ new2, new3 - new2))
+ goto fail;
+
+ /* Start copying argv back to new2. First, write the one or two new
+ arguments. */
+
+ if (ptrace (PTRACE_POKETEXT, tracee->pid,
+ (void *) new3, (void *) new))
+ goto fail;
+
+ new3 += sizeof new3;
+
+ if (arg2 && ptrace (PTRACE_POKETEXT, tracee->pid,
+ (void *) new3, (void *) new1))
+ goto fail;
+ else if (arg2)
+ new3 += sizeof new3;
+
+ /* Next, write the third argument. */
+
+ if (ptrace (PTRACE_POKETEXT, tracee->pid, (void *) new3,
+ (void *) new2))
+ goto fail;
+
+ new3 += sizeof new3;
+
+ /* Copy the remaining arguments back. */
+
+ argv = regs->SYSCALL_ARG1_REG;
+
+ if (argc)
+ {
+ /* Make sure the trailing NULL is included. */
+ argc += 1;
+
+ /* Now copy each argument in argv, starting from argv[1]. */
+
+ for (i = 1; i < argc; ++i)
+ {
+ /* Read one argument. */
+ word = ptrace (PTRACE_PEEKDATA, tracee->pid,
+ (void *) (argv + i * sizeof argv), NULL);
+
+ /* Write one argument, then increment new3. */
+
+ if (ptrace (PTRACE_POKETEXT, tracee->pid,
+ (void *) new3, (void *) word))
+ goto fail;
+
+ new3 += sizeof new3;
+ }
+ }
+ else
+ {
+ /* Just write the trailing NULL. */
+
+ if (ptrace (PTRACE_POKETEXT, tracee->pid,
+ (void *) new3, (void *) 0))
+ goto fail;
+
+ new3 += sizeof new3;
+ }
+
+ /* Assert that new3 is not out of bounds. */
+ assert (new3 == new + effective_size);
+
+ /* And that it is properly aligned. */
+ assert (!(new3 & (sizeof new3 - 2)));
+
+ /* Now modify the system call argument to point to new +
+ text_size. */
+
+ regs->SYSCALL_ARG1_REG = new + text_size;
+
+#ifdef __aarch64__
+ if (aarch64_set_regs (tracee->pid, regs, false))
+ goto fail;
+#else /* !__aarch64__ */
+ if (ptrace (PTRACE_SETREGS, tracee->pid, NULL, regs))
+ goto fail;
+#endif /* __aarch64__ */
+
+ /* Success. */
+
+ return 0;
+
+ fail:
+ /* Restore the original stack pointer. */
+#ifdef __aarch64__
+ aarch64_set_regs (tracee->pid, &original, false);
+#else /* !__aarch64__ */
+ ptrace (PTRACE_SETREGS, tracee->pid, NULL, &original);
+#endif /* __aarch64__ */
+ errno = ENOMEM;
+ return 1;
+}
+
+
+
+/* Format PID, an unsigned process identifier, in base 10. Place the
+ result in *IN, and return a pointer to the byte after the
+ result. REM should be NULL. */
+
+char *
+format_pid (char *in, unsigned int pid)
+{
+ unsigned int digits[32], *fill;
+
+ fill = digits;
+
+ for (; pid != 0; pid = pid / 10)
+ *fill++ = pid % 10;
+
+ /* Insert 0 if the number would otherwise be empty. */
+
+ if (fill == digits)
+ *fill++ = 0;
+
+ while (fill != digits)
+ {
+ --fill;
+ *in++ = '0' + *fill;
+ }
+
+ *in = '\0';
+ return in;
+}
+
+/* Return a sequence of actions required to load the executable under
+ the file NAME for the given TRACEE. First, see if the file starts
+ with #!; in that case, find the program to open and use that
+ instead.
+
+ If REENTRANT is not defined, NAME is actually a buffer of size
+ PATH_MAX + 80. In that case, copy over the file name actually
+ opened.
+
+ Next, read the executable header, and add the necessary memory
+ mappings for each file. Finally, return the action data and its
+ size in *SIZE.
+
+ Finally, use REGS to add the required interpreter arguments to the
+ caller's argv.
+
+ Value is NULL upon failure, with errno set accordingly. */
+
+char *
+exec_0 (char *name, struct exec_tracee *tracee,
+ size_t *size, USER_REGS_STRUCT *regs)
+{
+ int fd, rc, i;
+ elf_header header;
+ const char *interpreter_name, *extra;
+ program_header program;
+ USER_WORD entry, program_entry, offset;
+ USER_WORD header_offset;
+ struct exec_jump_command jump;
+#if defined __mips__ && !defined MIPS_NABI
+ int fpu_mode;
+#endif /* defined __mips__ && !defined MIPS_NABI */
+ char buffer[80], buffer1[PATH_MAX + 80], *rewrite;
+ ssize_t link_size;
+ size_t remaining;
+
+ /* If the process is trying to run /proc/self/exe, make it run
+ itself instead. */
+
+ if (!strcmp (name, "/proc/self/exe") && tracee->exec_file)
+ {
+ strncpy (name, tracee->exec_file, PATH_MAX - 1);
+ name[PATH_MAX] = '\0';
+ }
+ else
+ {
+ /* If name is not absolute, then make it relative to TRACEE's
+ cwd. Do not use sprintf at it is not reentrant and it
+ mishandles results longer than INT_MAX. */
+
+ if (name[0] && name[0] != '/')
+ {
+ /* Clear both buffers. */
+ memset (buffer, 0, sizeof buffer);
+ memset (buffer1, 0, sizeof buffer1);
+
+ /* Copy over /proc, the PID, and /cwd/. */
+ rewrite = stpcpy (buffer, "/proc/");
+ rewrite = format_pid (rewrite, tracee->pid);
+ strcpy (rewrite, "/cwd");
+
+ /* Resolve this symbolic link. */
+
+ link_size = readlink (buffer, buffer1,
+ PATH_MAX + 1);
+
+ if (link_size < 0)
+ return NULL;
+
+ /* Check that the name is a reasonable size. */
+
+ if (link_size > PATH_MAX)
+ {
+ /* The name is too long. */
+ errno = ENAMETOOLONG;
+ return NULL;
+ }
+
+ /* Add a directory separator if necessary. */
+
+ if (!link_size || buffer1[link_size - 1] != '/')
+ buffer1[link_size] = '/', link_size++;
+
+ rewrite = buffer1 + link_size;
+ remaining = buffer1 + sizeof buffer1 - rewrite - 1;
+ memcpy (rewrite, name, strnlen (name, remaining));
+
+ /* Replace name with buffer1. */
+#ifndef REENTRANT
+ strcpy (name, buffer1);
+#endif /* REENTRANT */
+ }
+ }
+
+ /* Check that the file is accessible and executable. */
+
+ if (access (name, X_OK))
+ return NULL;
+
+ fd = open (name, O_RDONLY);
+ if (fd < 0)
+ return NULL;
+
+ /* Now read the header. */
+
+ extra = NULL;
+ interpreter_name = check_interpreter (name, fd, &extra);
+ if (!interpreter_name)
+ goto fail;
+
+ /* Open the interpreter instead, if necessary. */
+ if (interpreter_name != name)
+ {
+ close (fd);
+ fd = open (interpreter_name, O_RDONLY);
+ if (fd < 0)
+ return NULL;
+
+ /* Now, rewrite the argument list to include `interpreter_name'
+ and perhaps `extra'. */
+
+ if (insert_args (tracee, regs, interpreter_name,
+ extra, name))
+ goto fail1;
+ }
+
+ rc = read (fd, &header, sizeof header);
+
+ if (rc < sizeof header)
+ goto fail1;
+
+ /* Verify that this is indeed an ELF file. */
+
+ if (header.e_ident[0] != 0x7f
+ || header.e_ident[1] != 'E'
+ || header.e_ident[2] != 'L'
+ || header.e_ident[3] != 'F')
+ goto fail1;
+
+ /* Now check that the class is correct. */
+#ifdef EXEC_64
+ if (header.e_ident[4] != 2)
+ goto fail1;
+#else /* !EXEC_64 */
+ if (header.e_ident[4] != 1)
+ goto fail1;
+#endif /* EXEC_64 */
+
+ /* And the endianness. */
+#ifndef WORDS_BIGENDIAN
+ if (header.e_ident[5] != 1)
+ goto fail1;
+#else /* WORDS_BIGENDIAN */
+ if (header.e_ident[5] != 2)
+ goto fail1;
+#endif /* EXEC_64 */
+
+ /* Check that this is an executable. */
+ if (header.e_type != 2 && header.e_type != 3)
+ goto fail1;
+
+ /* Now check that the ELF program header makes sense. */
+ if (header.e_phnum > 0xffff
+ || (header.e_phentsize
+ != sizeof (program_header)))
+ goto fail1;
+
+ /* Seek to the first program header and read each one. */
+ rc = lseek (fd, header.e_phoff, SEEK_SET);
+ if (rc < 0)
+ goto fail1;
+ loader_area_used = 0;
+
+ /* Write the command used to open the executable. */
+ if (write_open_command (interpreter_name, false))
+ goto fail1;
+
+ /* Apply base addresses for PIC code. */
+
+ if (header.e_type == 3) /* ET_DYN */
+ offset = EXECUTABLE_BASE;
+ else
+ offset = 0;
+
+ /* entry and program_entry are initially the same, but entry may be
+ set to that of the interpreter if one is present. */
+
+ entry = header.e_entry + offset;
+ program_entry = header.e_entry;
+
+#if defined __mips__ && !defined MIPS_NABI
+ /* Clear MIPS ABI flags. */
+ exec_abiflags = NULL;
+ interpreter_abiflags = NULL;
+ interpreter_header = NULL;
+#endif /* defined __mips__ && !defined MIPS_NABI */
+
+ /* Set header_offset to -1; `process_program_header' then updates it
+ to that of the first mapping. */
+ header_offset = -1;
+
+ for (i = 0; i < header.e_phnum; ++i)
+ {
+ rc = read (fd, &program, sizeof program);
+ if (rc < sizeof program)
+ goto fail1;
+
+ if (process_program_header (interpreter_name, fd,
+ &program, &header,
+ &entry, &header_offset))
+ goto fail1;
+ }
+
+ /* Write the entry point and program entry. */
+
+ jump.command = 3;
+ jump.entry = entry;
+
+ /* Now calculate values for the aux vector. */
+
+ jump.at_entry = program_entry + offset;
+ jump.at_phent = header.e_phentsize;
+ jump.at_phnum = header.e_phnum;
+ jump.at_base = (entry == header.e_entry + offset
+ ? EXECUTABLE_BASE
+ : INTERPRETER_BASE);
+
+#if defined __mips__ && !defined MIPS_NABI
+ /* Finally, calculate the FPU mode wanted by the executable. */
+
+ if (determine_fpu_mode (&header, interpreter_header,
+ &fpu_mode, exec_abiflags,
+ interpreter_abiflags))
+ /* N.B. that `determine_fpu_mode' sets errno. */
+ goto fail;
+
+ /* If the processor is too new to support FR0 operation, place the
+ executable in floating point emulation mode. */
+
+ if (fpu_mode == FP_FR0 && !cpu_supports_fr0_p ())
+ fpu_mode = FP_FRE;
+
+ jump.fpu_mode = fpu_mode;
+#endif /* defined __mips__ && !defined MIPS_NABI */
+
+ /* The offset used for at_phdr should be that of the first
+ mapping. */
+
+ if (header_offset == (USER_WORD) -1)
+ header_offset = 0;
+
+ jump.at_phdr = header.e_phoff + header_offset;
+
+ if (sizeof loader_area - loader_area_used < sizeof jump)
+ goto fail1;
+
+ memcpy (loader_area + loader_area_used, &jump,
+ sizeof jump);
+ loader_area_used += sizeof jump;
+
+ /* Close the file descriptor and return the number of bytes
+ used. */
+
+ close (fd);
+ *size = loader_area_used;
+
+ /* Make sure the loader area is properly aligned. */
+ assert (!(loader_area_used & (sizeof (USER_WORD) - 1)));
+ return loader_area;
+
+ fail1:
+ errno = ENOEXEC;
+ fail:
+ close (fd);
+ return NULL;
+}
diff --git a/exec/exec.h b/exec/exec.h
new file mode 100644
index 00000000000..3ce06c35311
--- /dev/null
+++ b/exec/exec.h
@@ -0,0 +1,206 @@
+/* Program execution for Emacs.
+
+Copyright (C) 2023-2024 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 <https://www.gnu.org/licenses/>. */
+
+
+
+#ifndef _EXEC_H_
+#define _EXEC_H_
+
+#ifdef HAVE_STDINT_H
+#include <stdint.h>
+#endif /* HAVE_STDINT_H */
+
+#include <sys/types.h>
+
+#include USER_HEADER
+
+/* Define a replacement for `uint64_t' if it's not present in the C
+ library. */
+
+#ifndef UINT64_MAX
+
+typedef struct
+{
+ uint32_t word1;
+ uint32_t word2;
+} xint64_t;
+
+#else /* UINT64_MAX */
+typedef uint64_t xint64_t;
+#endif /* !UINT64_MAX */
+
+
+
+/* 32-bit ELF headers. */
+
+struct elf_header_32
+{
+ unsigned char e_ident[16];
+ uint16_t e_type;
+ uint16_t e_machine;
+ uint32_t e_version;
+ uint32_t e_entry;
+ uint32_t e_phoff;
+ uint32_t e_shoff;
+ uint32_t e_flags;
+ uint16_t e_ehsize;
+ uint16_t e_phentsize;
+ uint16_t e_phnum;
+ uint16_t e_shentsize;
+ uint16_t e_shnum;
+ uint16_t e_shstrndx;
+};
+
+struct program_header_32
+{
+ uint32_t p_type;
+ uint32_t p_offset;
+ uint32_t p_vaddr;
+ uint32_t p_paddr;
+ uint32_t p_filesz;
+ uint32_t p_memsz;
+ uint32_t p_flags;
+ uint32_t p_align;
+};
+
+struct dt_entry_32
+{
+ uint32_t d_tag;
+ uint32_t d_val;
+};
+
+
+
+struct elf_header_64
+{
+ unsigned char e_ident[16];
+ uint16_t e_type;
+ uint16_t e_machine;
+ uint32_t e_version;
+ xint64_t e_entry;
+ xint64_t e_phoff;
+ xint64_t e_shoff;
+ uint32_t e_flags;
+ uint16_t e_ehsize;
+ uint16_t e_phentsize;
+ uint16_t e_phnum;
+ uint16_t e_shentsize;
+ uint16_t e_shnum;
+ uint16_t e_shstrndx;
+};
+
+struct program_header_64
+{
+ uint32_t p_type;
+ uint32_t p_flags;
+ xint64_t p_offset;
+ xint64_t p_vaddr;
+ xint64_t p_paddr;
+ xint64_t p_filesz;
+ xint64_t p_memsz;
+ xint64_t p_align;
+};
+
+struct dt_entry_64
+{
+ xint64_t d_tag;
+ xint64_t d_val;
+};
+
+
+
+/* Define some types to the correct values. */
+
+#ifdef EXEC_64
+typedef struct elf_header_64 elf_header;
+typedef struct program_header_64 program_header;
+typedef struct dt_entry_64 dt_entry;
+#else /* !EXEC_64 */
+typedef struct elf_header_32 elf_header;
+typedef struct program_header_32 program_header;
+typedef struct dt_entry_32 dt_entry;
+#endif /* EXEC_64 */
+
+
+
+/* Defined in trace.c. */
+
+/* Structure describing a process being traced. */
+
+struct exec_tracee
+{
+ /* The next process being traced. */
+ struct exec_tracee *next;
+
+ /* Address of any stack pointer to restore after system call
+ completion. */
+ USER_WORD sp;
+
+ /* The thread ID of this process. */
+ pid_t pid;
+
+ /* Whether or not the tracee is currently waiting for a system call
+ to complete. */
+ bool waiting_for_syscall : 1;
+
+ /* Whether or not the tracee has been created but is not yet
+ processed by `handle_clone'. */
+ bool new_child : 1;
+
+#ifndef REENTRANT
+ /* Name of the executable being run. */
+ char *exec_file;
+#endif /* !REENTRANT */
+};
+
+
+
+#ifdef __aarch64__
+
+extern int aarch64_get_regs (pid_t, USER_REGS_STRUCT *);
+extern int aarch64_set_regs (pid_t, USER_REGS_STRUCT *, bool);
+
+#endif /* __aarch64__ */
+
+
+
+extern char *format_pid (char *, unsigned int);
+extern USER_WORD user_alloca (struct exec_tracee *, USER_REGS_STRUCT *,
+ USER_REGS_STRUCT *, USER_WORD);
+extern int user_copy (struct exec_tracee *, const unsigned char *,
+ USER_WORD, USER_WORD);
+extern void exec_init (const char *);
+
+
+
+extern int tracing_execve (const char *, char *const *,
+ char *const *);
+extern int after_fork (pid_t);
+extern pid_t exec_waitpid (pid_t, int *, int);
+
+
+
+/* Defined in exec.c. */
+
+extern char *exec_0 (char *, struct exec_tracee *,
+ size_t *, USER_REGS_STRUCT *);
+
+
+
+#endif /* _EXEC_H_ */
diff --git a/exec/exec1.c b/exec/exec1.c
new file mode 100644
index 00000000000..aaff9a94c62
--- /dev/null
+++ b/exec/exec1.c
@@ -0,0 +1,94 @@
+/* Program execution for Emacs.
+
+Copyright (C) 2023-2024 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 <https://www.gnu.org/licenses/>. */
+
+#include <config.h>
+#include <unistd.h>
+#include <stdlib.h>
+#include <stdio.h>
+#include <sys/wait.h>
+
+#include "exec.h"
+
+/* exec1 is a program which takes another program and its arguments,
+ forks, and executes that program, all while tracing it and its
+ children to use the program execution mechanism defined in exec.c.
+
+ This is necessary to bypass security restrictions which prohibit
+ Emacs from loading executables from certain directories, by, in
+ effect, replacing the executable loader in the Linux kernel. */
+
+
+
+int
+main (int argc, char **argv)
+{
+ pid_t pid, pid1;
+ extern char **environ;
+ int wstatus;
+
+ pid1 = getpid ();
+ pid = fork ();
+
+ if (!pid)
+ {
+ /* Set the process group used to the parent. */
+ if (setpgid (0, pid1))
+ perror ("setpgid");
+
+ tracing_execve (argv[2], argv + 2, environ);
+
+ /* An error occurred. Exit with failure. */
+ exit (127);
+ }
+ else
+ {
+ /* Provide the file name of the loader. */
+ exec_init (argv[1]);
+
+ if (after_fork (pid))
+ exit (127);
+
+ /* Start waiting for the process to exit. */
+
+ while (true)
+ {
+ pid1 = exec_waitpid (-1, &wstatus, 0);
+
+ /* If the child process exits normally, exit with its status
+ code. If not, raise the signal that caused it to
+ exit. */
+
+ if (pid == pid1)
+ {
+ if (WIFEXITED (wstatus))
+ exit (WEXITSTATUS (wstatus));
+ else /* if WIFSIGNALED (wstatus) */
+ {
+ raise (WTERMSIG (wstatus));
+
+ /* Just in case the signal raised doesn't cause an
+ exit. */
+ exit (127);
+ }
+ }
+
+ /* Otherwise, continue looping. */
+ }
+ }
+}
diff --git a/exec/loader-aarch64.s b/exec/loader-aarch64.s
new file mode 100644
index 00000000000..0fc9606c62a
--- /dev/null
+++ b/exec/loader-aarch64.s
@@ -0,0 +1,187 @@
+// Copyright (C) 2023-2024 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 <https://www.gnu.org/licenses/>.
+
+// Notice that aarch64 requires that sp be aligned to 16 bytes while
+// accessing memory from sp, so x20 is used to chase down the load
+// area.
+
+ .section .text
+ .global _start
+_start:
+ //mov x8, 101 // SYS_nanosleep
+ //adr x0, timespec // req
+ //mov x1, #0 // rem
+ //svc #0 // syscall
+ mov x20, sp // x20 = sp
+ ldr x10, [x20] // x10 = original SP
+ add x20, x20, #16 // x20 = start of load area
+ mov x28, #-1 // x28 = secondary fd
+.next_action:
+ ldr x11, [x20] // action number
+ and x12, x11, #-17 // actual action number
+ cbz x12, .open_file // open file?
+ cmp x12, #3 // jump?
+ beq .rest_of_exec
+ cmp x12, #4 // anonymous mmap?
+ beq .do_mmap_anon
+.do_mmap:
+ ldr x0, [x20, 8] // vm_address
+ ldr x1, [x20, 32] // length
+ ldr x2, [x20, 24] // protection
+ ldr x3, [x20, 40] // flags
+ tst x11, #16 // primary fd?
+ mov x4, x29 // primary fd
+ beq .do_mmap_1
+ mov x4, x28 // secondary fd
+.do_mmap_1:
+ mov x8, #222 // SYS_mmap
+ ldr x5, [x20, 16] // file_offset
+ svc #0 // syscall
+ ldr x9, [x20, 8] // length
+ cmp x0, x9 // mmap result
+ bne .perror // print error
+ ldr x3, [x20, 48] // clear
+ add x1, x1, x0 // x1 = vm_address + end
+ sub x3, x1, x3 // x3 = x1 - clear
+ mov x0, #0 // x0 = 0
+.fill64:
+ sub x2, x1, x3 // x2 = x1 - x3
+ cmp x2, #63 // x2 >= 64?
+ ble .fillb // start filling bytes
+ stp x0, x0, [x3] // x3[0] = 0, x3[1] = 0
+ stp x0, x0, [x3, 16] // x3[2] = 0, x3[3] = 0
+ stp x0, x0, [x3, 32] // x3[4] = 0, x3[5] = 0
+ stp x0, x0, [x3, 48] // x3[6] = 0, x3[7] = 0
+ add x3, x3, #64 // x3 += 8
+ b .fill64
+.fillb:
+ cmp x1, x3 // x1 == x3?
+ beq .continue // done
+ strb w0, [x3], #1 // ((char *) x3)++ = 0
+ b .fillb
+.continue:
+ add x20, x20, #56 // next action
+ b .next_action
+.do_mmap_anon:
+ ldr x0, [x20, 8] // vm_address
+ ldr x1, [x20, 32] // length
+ ldr x2, [x20, 24] // protection
+ ldr x3, [x20, 40] // flags
+ mov x4, #-1 // fd
+ b .do_mmap_1
+.open_file:
+ mov x8, #56 // SYS_openat
+ mov x0, #-100 // AT_FDCWD
+ add x1, x20, #8 // file name
+ mov x2, #0 // O_RDONLY
+ mov x3, #0 // mode
+ svc #0 // syscall
+ cmp x0, #-1 // rc < 0?
+ ble .perror
+ mov x19, x1 // x19 == x1
+.nextc:
+ ldrb w2, [x1], #1 // b = *x1++
+ cmp w2, #47 // dir separator?
+ bne .nextc1 // not dir separator
+ mov x19, x1 // x19 = char past separator
+.nextc1:
+ cbnz w2, .nextc // b?
+ add x1, x1, #7 // round up x1
+ and x20, x1, #-8 // mask for round, set x20
+ tst x11, #16 // primary fd?
+ bne .secondary // secondary fd
+ mov x29, x0 // primary fd
+ mov x8, #167 // SYS_prctl
+ mov x0, #15 // PR_SET_NAME
+ mov x1, x19 // basename
+ mov x2, #0 // arg2
+ mov x3, #0 // arg3
+ mov x4, #0 // arg4
+ mov x5, #0 // arg5
+ svc #0 // syscall
+ b .next_action // next action
+.secondary:
+ mov x28, x0 // secondary fd
+ b .next_action // next action.
+.perror:
+ mov x8, #93 // SYS_exit
+ mvn x0, x0 // x1 = ~x0
+ add x0, x0, 1 // x1 += 1
+ svc #0 // exit
+.rest_of_exec:
+ mov x7, x20 // x7 = x20
+ mov x20, x10 // x20 = x10
+ ldr x9, [x20] // argc
+ add x9, x9, #2 // x9 += 2
+ lsl x9, x9, #3 // argc * 8
+ add x20, x20, x9 // now past argv
+.skipenv:
+ ldr x9, [x20], #8 // x9 = *envp++
+ cbnz x9, .skipenv // x9?
+.one_auxv:
+ ldr x9, [x20], #16 // x9 = *sp, sp += 2
+ cbz x9, .cleanup // !x9?
+ cmp x9, #3 // is AT_PHDR?
+ beq .replace_phdr // replace
+ cmp x9, #4 // is AT_PHENT?
+ beq .replace_phent // replace
+ cmp x9, #5 // is AT_PHNUM?
+ beq .replace_phnum // replace
+ cmp x9, #9 // is AT_ENTRY?
+ beq .replace_entry // replace
+ cmp x9, #7 // is AT_BASE?
+ beq .replace_base // replace
+ b .one_auxv // next auxv
+.replace_phdr:
+ ldr x9, [x7, 40] // at_phdr
+ str x9, [x20, -8] // store value
+ b .one_auxv
+.replace_phent:
+ ldr x9, [x7, 24] // at_phent
+ str x9, [x20, -8] // store value
+ b .one_auxv
+.replace_phnum:
+ ldr x9, [x7, 32] // at_phnum
+ str x9, [x20, -8] // store value
+ b .one_auxv
+.replace_entry:
+ ldr x9, [x7, 16] // at_entry
+ str x9, [x20, -8] // store value
+ b .one_auxv
+.replace_base:
+ ldr x9, [x7, 48] // at_base
+ str x9, [x20, -8] // store value
+ b .one_auxv
+.cleanup:
+ cmp x28, #-1 // is secondary fd set?
+ bne .cleanup1 // not set
+ mov x8, #57 // SYS_close
+ mov x0, x28 // secondary fd
+ svc #0 // syscall
+.cleanup1:
+ mov x8, #57 // SYS_close
+ mov x0, x29 // primary fd
+ svc #0 // syscall
+.enter:
+ mov sp, x10 // restore original SP
+ mov x0, #0 // clear rtld_fini
+ ldr x1, [x7, 8] // branch to code
+ br x1
+
+timespec:
+ .quad 10
+ .quad 10
diff --git a/exec/loader-armeabi.s b/exec/loader-armeabi.s
new file mode 100644
index 00000000000..5601088262c
--- /dev/null
+++ b/exec/loader-armeabi.s
@@ -0,0 +1,204 @@
+@ Copyright (C) 2023-2024 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 <https:@www.gnu.org/licenses/>.
+
+ .section .text
+ .global _start
+_start:
+ @mov r7, #162 @ SYS_nanosleep
+ @adr r0, timespec @ req
+ @mov r1, #0 @ rem
+ @swi #0 @ syscall
+ mov r8, sp @ r8 = sp
+ ldr r9, [r8], #8 @ r9 = original sp, r8 += 8
+ mov r14, #-1 @ r14 = secondary fd
+.next_action:
+ ldr r11, [r8] @ r11 = action number
+ and r12, r11, #-17 @ actual action number
+ cmp r12, #0 @ open file?
+ beq .open_file @ open file.
+ cmp r12, #3 @ jump?
+ beq .rest_of_exec @ jump to code.
+ cmp r12, #4 @ anonymous mmap?
+ beq .do_mmap_anon @ anonymous mmap.
+.do_mmap:
+ add r6, r8, #4 @ r6 = r8 + 4
+ ldm r6!, {r0, r5} @ vm_address, file_offset
+ ldm r6!, {r1, r2} @ protection, length
+ mov r3, r1 @ swap
+ lsr r5, #12 @ divide file offset by page size
+ mov r1, r2 @ swap
+ mov r2, r3 @ swap
+ ldm r6!, {r3, r12} @ flags, clear
+ tst r11, #16 @ primary fd?
+ mov r4, r10 @ primary fd
+ beq .do_mmap_1
+ mov r4, r14 @ secondary fd
+.do_mmap_1:
+ mov r7, #192 @ SYS_mmap2
+ swi #0 @ syscall
+ ldr r2, [r8, #4] @ vm_address
+ cmp r2, r0 @ rc == vm_address?
+ bne .perror
+ add r0, r1, r2 @ r0 = length + vm_address
+ sub r3, r0, r12 @ r3 = r0 - clear
+ mov r1, #0 @ r1 = 0
+.align:
+ cmp r0, r3 @ r0 == r3?
+ beq .continue @ continue
+ tst r3, #3 @ r3 & 3?
+ bne .fill32 @ fill aligned
+ strb r1, [r3], #1 @ fill byte
+ b .align @ align again
+.fill32:
+ sub r2, r0, r3 @ r2 = r0 - r3
+ cmp r2, #31 @ r2 >= 32?
+ ble .fillb @ start filling bytes
+ str r1, [r3], #4 @ *r3++ = 0
+ str r1, [r3], #4 @ *r3++ = 0
+ str r1, [r3], #4 @ *r3++ = 0
+ str r1, [r3], #4 @ *r3++ = 0
+ str r1, [r3], #4 @ *r3++ = 0
+ str r1, [r3], #4 @ *r3++ = 0
+ str r1, [r3], #4 @ *r3++ = 0
+ str r1, [r3], #4 @ *r3++ = 0
+ b .fill32
+.fillb:
+ cmp r0, r3 @ r0 == r3
+ beq .continue @ done
+ strb r1, [r3], #1 @ ((char *) r3)++ = 0
+ b .fillb
+.continue:
+ add r8, r8, #28 @ next action
+ b .next_action
+.do_mmap_anon:
+ add r6, r8, #4 @ r6 = r8 + 4
+ ldm r6!, {r0, r5} @ vm_address, file_offset
+ ldm r6!, {r1, r2} @ protection, length
+ mov r3, r1 @ swap
+ lsr r5, #12 @ divide file offset by page size
+ mov r1, r2 @ swap
+ mov r2, r3 @ swap
+ ldm r6!, {r3, r12} @ flags, clear
+ mov r4, #-1 @ fd
+ b .do_mmap_1
+.open_file:
+ mov r7, #5 @ SYS_open
+ add r0, r8, #4 @ file name
+ mov r1, #0 @ O_RDONLY
+ mov r2, #0 @ mode
+ swi #0 @ syscall
+ cmp r0, #-1 @ r0 <= -1?
+ ble .perror
+ add r8, r8, #4 @ r8 = start of string
+ mov r1, r8 @ r1 = r8
+.nextc:
+ ldrb r2, [r8], #1 @ b = *r0++
+ cmp r2, #47 @ dir separator?
+ bne .nextc1 @ not dir separator
+ mov r1, r8 @ r1 = char past separator
+.nextc1:
+ cmp r2, #0 @ b?
+ bne .nextc @ next character
+ add r8, r8, #3 @ round up r8
+ and r8, r8, #-4 @ mask for round, set r8
+ tst r11, #16 @ primary fd?
+ bne .secondary @ secondary fd
+ mov r10, r0 @ primary fd
+ mov r7, #172 @ SYS_prctl
+ mov r0, #15 @ PR_SET_NAME, r1 = name
+ mov r2, #0 @ arg2
+ mov r3, #0 @ arg3
+ mov r4, #0 @ arg4
+ mov r5, #0 @ arg5
+ swi #0 @ syscall
+ b .next_action @ next action
+.secondary:
+ mov r14, r0 @ secondary fd
+ b .next_action @ next action
+.perror:
+ mov r7, #1 @ SYS_exit
+ mvn r0, r0 @ r0 = ~r0
+ add r0, r0, #1 @ r0 += 1
+ swi #0
+.rest_of_exec:
+ mov r7, r9 @ r7 = original SP
+ ldr r6, [r7] @ argc
+ add r6, r6, #2 @ argc + 2
+ lsl r6, r6, #2 @ argc *= 4
+ add r7, r7, r6 @ now past argv
+.skipenv:
+ ldr r6, [r7], #4 @ r6 = *r7++
+ cmp r6, #0 @ r6?
+ bne .skipenv @ r6?
+.one_auxv:
+ ldr r6, [r7], #8 @ r6 = *r7, r7 += 2
+ cmp r6, #0 @ !r6?
+ beq .cleanup @ r6?
+ cmp r6, #3 @ is AT_PHDR?
+ beq .replace_phdr @ replace
+ cmp r6, #4 @ is AT_PHENT?
+ beq .replace_phent @ replace
+ cmp r6, #5 @ is AT_PHNUM?
+ beq .replace_phnum @ replace
+ cmp r6, #9 @ is AT_ENTRY?
+ beq .replace_entry @ replace
+ cmp r6, #7 @ is AT_BASE?
+ beq .replace_base @ replace
+ b .one_auxv @ next auxv
+.replace_phdr:
+ ldr r6, [r8, #20] @ at_phdr
+ str r6, [r7, #-4] @ store value
+ b .one_auxv
+.replace_phent:
+ ldr r6, [r8, #12] @ at_phent
+ str r6, [r7, #-4] @ store value
+ b .one_auxv
+.replace_phnum:
+ ldr r6, [r8, #16] @ at_phnum
+ str r6, [r7, #-4] @ store value
+ b .one_auxv
+.replace_entry:
+ ldr r6, [r8, #8] @ at_entry
+ str r6, [r7, #-4] @ store value
+ b .one_auxv
+.replace_base:
+ ldr r6, [r8, #24] @ at_base
+ str r6, [r7, #-4] @ store value
+ b .one_auxv
+.cleanup:
+ cmp r14, #-1 @ secondary fd set?
+ bne .cleanup1 @ not set
+ mov r7, #6 @ SYS_close
+ mov r0, r14 @ secondary fd
+ swi #0 @ syscall
+.cleanup1:
+ mov r7, #6 @ SYS_close
+ mov r0, r10 @ primary fd
+ swi #0 @ syscall
+.enter:
+ mov sp, r9 @ restore original SP
+ mov r0, #0 @ clear rtld_fini
+ ldr r1, [r8, #4] @ branch to code
+ bx r1
+
+timespec:
+ .long 10
+ .long 10
+
+@ Local Variables:
+@ asm-comment-char: ?@
+@ End:
diff --git a/exec/loader-mips64el.s b/exec/loader-mips64el.s
new file mode 100644
index 00000000000..0ff140f9f31
--- /dev/null
+++ b/exec/loader-mips64el.s
@@ -0,0 +1,234 @@
+# Copyright (C) 2023-2024 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 <https://www.gnu.org/licenses/>.
+
+include(`config-mips.m4')
+
+ .set noreorder # delay slots managed by hand
+ .set noat # no assembler macros
+ .section .text
+ .global __start
+__start:
+dnl li $v0, 5034 # SYS_nanosleep
+dnl dla $a0, .timespec # rqtp
+dnl li $a1, 0 # rmtp
+dnl syscall # syscall
+ ld $s2, ($sp) # original stack pointer
+ DADDI3( $s0, $sp, 16) # start of load area
+ DADDI2( $sp, -16) # primary fd, secondary fd
+ li $t0, -1 # secondary fd
+ sd $t0, 8($sp) # initialize secondary fd
+.next_action:
+ ld $s1, ($s0) # action number
+ andi $t0, $s1, 15 # t0 = action number & 15
+ beqz $t0, .open_file # open file?
+ nop # delay slot
+ DADDI2( $t0, -3) # t0 -= 3
+ beqz $t0, .rest_of_exec # jump to code
+ nop # delay slot
+ li $t1, 1
+ beq $t0, $t1, .do_mmap_anon # anonymous mmap?
+ nop # delay slot
+.do_mmap:
+ ld $t0, 8($s0) # vm address
+ ld $t1, 16($s0) # file_offset
+ ld $t2, 24($s0) # protection
+ ld $t3, 32($s0) # length
+ ld $v0, 40($s0) # flags
+ ld $v1, ($sp) # primary fd
+ andi $s3, $s1, 16 # s1 & 16?
+ beqz $s3, .do_mmap_1 # secondary fd?
+ nop # delay slot
+ ld $v1, 8($sp) # secondary fd
+.do_mmap_1:
+ move $a0, $t0 # syscall arg
+ move $a1, $t3 # syscall arg
+ move $a2, $t2 # syscall arg
+ move $a3, $v0 # syscall arg
+ move $a4, $v1 # syscall arg
+ move $a5, $t1 # syscall arg
+ li $v0, 5009 # SYS_mmap
+ syscall # syscall
+ bne $a3, $zero, .perror # perror?
+ nop # delay slot
+ ld $t1, 48($s0) # clear
+ dadd $t0, $a0, $a1 # t0 = end of mapping
+ dsub $t1, $t0, $t1 # t1 = t0 - clear
+.align:
+ beq $t0, $t1, .continue # already finished
+ nop # delay slot
+ andi $t2, $t1, 7 # t1 & 7?
+ bnez $t2, .filld # start filling longs
+ nop # delay slot
+.filld:
+ dsub $t2, $t0, $t1 # t2 = t0 - t1
+ sltiu $t2, $t2, 64 # t2 < 64?
+ bne $t2, $zero, .fillb # fill bytes
+ nop # delay slot
+ sd $zero, ($t1) # zero doubleword
+ DADDI2( $t1, 8) # next doubleword
+ sd $zero, ($t1) # zero doubleword
+ DADDI2( $t1, 8) # next doubleword
+ sd $zero, ($t1) # zero doubleword
+ DADDI2( $t1, 8) # next doubleword
+ sd $zero, ($t1) # zero doubleword
+ DADDI2( $t1, 8) # next doubleword
+ sd $zero, ($t1) # zero doubleword
+ DADDI2( $t1, 8) # next doubleword
+ sd $zero, ($t1) # zero doubleword
+ DADDI2( $t1, 8) # next doubleword
+ sd $zero, ($t1) # zero doubleword
+ DADDI2( $t1, 8) # next doubleword
+ sd $zero, ($t1) # zero doubleword
+ DADDI2( $t1, 8) # next doubleword
+ j .filld # fill either doubleword or byte
+ nop # delay slot
+.fillb:
+ beq $t0, $t1, .continue # already finished?
+ nop # delay slot
+ sb $zero, ($t1) # clear byte
+ DADDI2( $t1, 1) # t1++
+.continue:
+ DADDI2( $s0, 56) # s0 = next action
+ j .next_action # next action
+ nop # delay slot
+.do_mmap_anon:
+ ld $t0, 8($s0) # vm address
+ ld $t1, 16($s0) # file_offset
+ ld $t2, 24($s0) # protection
+ ld $t3, 32($s0) # length
+ ld $v0, 40($s0) # flags
+ li $v1, -1 # fd
+ j .do_mmap_1 # do mmap
+ nop # branch delay slot
+.open_file:
+ li $v0, 5002 # SYS_open
+ DADDI3( $a0, $s0, 8) # start of name
+ move $a1, $zero # flags = O_RDONLY
+ move $a2, $zero # mode = 0
+ syscall # syscall
+ bne $a3, $zero, .perror # perror
+ nop # delay slot
+ DADDI2( $s0, 8) # start of string
+ move $t3, $s0 # t3 = s0
+.nextc:
+ lb $t0, ($s0) # load byte
+ DADDI2( $s0, 1) # s0++
+ li $t1, 47 # directory separator `/'
+ bne $t0, $t1, .nextc1 # is separator char?
+ nop # delay slot
+ move $t3, $s0 # t3 = char past separator
+.nextc1:
+ bnez $t0, .nextc # next character?
+ nop # delay slot
+ DADDI2( $s0, 7) # adjust for round
+ li $t2, -8 # t2 = -8
+ and $s0, $s0, $t2 # mask for round
+ andi $t0, $s1, 16 # t1 = s1 & 16
+ move $t1, $sp # address of primary fd
+ beqz $t0, .primary # primary fd?
+ nop # delay slot
+ DADDI2( $t1, 8) # address of secondary fd
+ sd $v0, ($t1) # store fd
+ j .next_action # next action
+ nop # delay slot
+.primary:
+ sd $v0, ($t1) # store fd
+ li $v0, 5153 # SYS_prctl
+ li $a0, 15 # PR_SET_NAME
+ move $a1, $t3 # char past separator
+ move $a2, $zero # a2
+ move $a3, $zero # a3
+ move $a4, $zero # a4
+ move $a5, $zero # a5
+ syscall # syscall
+ j .next_action # next action
+ nop # delay slot
+.perror:
+ move $a0, $v0 # errno
+ li $v0, 5058 # SYS_exit
+ syscall # syscall
+.rest_of_exec:
+ move $s1, $s2 # original SP
+ ld $t0, ($s1) # argc
+ dsll $t0, $t0, 3 # argc *= 8
+ DADDI2( $t0, 16) # argc += 16
+ dadd $s1, $s1, $t0 # s1 = start of envp
+.skipenv:
+ ld $t0, ($s1) # t0 = *s1
+ DADDI2( $s1, 8) # s1++
+ bne $t0, $zero, .skipenv # skip again
+ nop # delay slot
+ dla $t3, .auxvtab # address of auxv table
+.one_auxv:
+ ld $t0, ($s1) # t0 = auxv type
+ li $t1, 10 # t1 = 10
+ beqz $t0, .finish # is AT_IGNORE?
+ nop # delay slot
+ sltu $t1, $t0, $t1 # t1 = t0 < num offsets
+ beqz $t1, .next # next auxv
+ nop # delay slot
+ dsll $t1, $t0, 2 # t1 = t0 * 4
+ dadd $t1, $t3, $t1 # t1 = .auxvtab + t1
+ lw $t2, ($t1) # t2 = *t1
+ beqz $t2, .next # skip auxv
+ nop # delay slot
+ dadd $t2, $s0, $t2 # t2 = s0 + t2
+ ld $t2, ($t2) # t2 = *t2
+ sd $t2, 8($s1) # set auxv value
+.next:
+ DADDI2( $s1, 16) # next auxv
+ j .one_auxv # next auxv
+ nop # delay slot
+.finish:
+ ld $t0, 8($sp) # secondary fd
+ li $t1, -1 # t1 = -1
+ ld $s1, ($sp) # s1 = primary fd
+ li $v0, 5003 # SYS_close
+ beq $t0, $t2, .finish1 # secondary fd set?
+ nop # delay slot
+ move $a0, $t0 # secondary fd
+ syscall # syscall
+ li $v0, 5003 # SYS_close
+.finish1:
+ move $a0, $s1 # primary fd
+ syscall # syscall
+.jump:
+ move $v0, $zero # rtld_fini
+ ld $t0, 8($s0) # entry
+ move $sp, $s2 # restore stack pointer, delay slot
+ jr $t0 # enter
+ nop # delay slot
+
+.auxvtab:
+ .long 0 # 0
+ .long 0 # 1
+ .long 0 # 2
+ .long 40 # 3 AT_PHDR
+ .long 24 # 4 AT_PHENT
+ .long 32 # 5 AT_PHNUM
+ .long 0 # 6
+ .long 48 # 7 AT_BASE
+ .long 0 # 8
+ .long 16 # 9 AT_ENTRY
+
+.timespec:
+ .quad 10
+ .quad 10
+
+# Local Variables:
+# asm-comment-char: ?#
+# End:
diff --git a/exec/loader-mipsel.s b/exec/loader-mipsel.s
new file mode 100644
index 00000000000..f1cdcfcf149
--- /dev/null
+++ b/exec/loader-mipsel.s
@@ -0,0 +1,236 @@
+# Copyright (C) 2023-2024 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 <https://www.gnu.org/licenses/>.
+
+include(`config-mips.m4')
+
+# Make sure not to use t4 through t7, in order to maintain portability
+# with N32 ABI systems.
+
+ .set noreorder # delay slots managed by hand
+ .section .text
+ .global __start
+__start:
+dnl li $v0, SYSCALL_nanosleep # SYS_nanosleep
+dnl la $a0, .timespec # rqtp
+dnl li $a1, 0 # rmtp
+dnl syscall # syscall
+ lw $s6, ($sp) # original stack pointer
+ addi $s0, $sp, 8 # start of load area
+ addi $sp, -8 # primary fd, secondary fd
+ li $t0, -1 # secondary fd
+ sw $t0, 4($sp) # initialize secondary fd
+.next_action:
+ lw $s2, ($s0) # action number
+ nop # delay slot
+ andi $t0, $s2, 15 # t0 = s2 & 15
+ beqz $t0, .open_file # open file?
+ li $t1, 3 # t1 = 3, delay slot
+ beq $t0, $t1, .rest_of_exec # jump to code
+ li $t1, 4 # t1 = 4, delay slot
+ beq $t0, $t1, .do_mmap_anon # anonymous mmap
+.do_mmap:
+ lw $a0, 4($s0) # vm_address, delay slot
+ lw $v1, 8($s0) # file_offset
+ lw $a2, 12($s0) # protection
+ lw $a1, 16($s0) # length
+ lw $a3, 20($s0) # flags
+ lw $v0, ($sp) # primary fd
+ andi $t1, $s2, 16 # t1 = s2 & 16
+ beqz $t1, .do_mmap_1 # secondary fd?
+ nop # delay slot
+ lw $v0, 4($sp) # secondary fd
+ nop # delay slot
+.do_mmap_1:
+SYSCALL(`$v0',`$v1',`$zero',`$zero') # syscall args
+ li $v0, SYSCALL_mmap # SYS_mmap
+ syscall # syscall
+ bne $a3, $zero, .perror # perror
+RESTORE() # delay slot, restore sp
+ lw $s5, 24($s0) # clear
+ add $t0, $a0, $a1 # t0 = length + vm_address, delay slot
+ sub $t1, $t0, $s5 # t1 = t0 - clear
+.align:
+ beq $t0, $t1, .continue # already finished?
+ nop # delay slot
+ andi $t2, $t1, 3 # t1 & 3?
+ bnez $t2, .fillw # start filling longs
+ nop # delay slot
+ sb $zero, ($t1) # clear byte
+ addi $t1, $t1, 1 # t1++
+ j .align # continue
+ nop # delay slot
+.fillw:
+ sub $t2, $t0, $t1 # t2 = t0 - t1
+ sltiu $t2, $t2, 32 # r2 < 32?
+ bne $t2, $zero, .fillb # fill bytes
+ nop # delay slot
+ sw $zero, ($t1) # zero word
+ addi $t1, $t1, 4 # next word
+ sw $zero, ($t1) # zero word
+ addi $t1, $t1, 4 # next word
+ sw $zero, ($t1) # zero word
+ addi $t1, $t1, 4 # next word
+ sw $zero, ($t1) # zero word
+ addi $t1, $t1, 4 # next word
+ sw $zero, ($t1) # zero word
+ addi $t1, $t1, 4 # next word
+ sw $zero, ($t1) # zero word
+ addi $t1, $t1, 4 # next word
+ sw $zero, ($t1) # zero word
+ addi $t1, $t1, 4 # next word
+ sw $zero, ($t1) # zero word
+ addi $t1, $t1, 4 # next word
+ j .fillw # fill either word or byte
+ nop # delay slot
+.fillb:
+ beq $t0, $t1, .continue # already finished?
+ nop # delay slot
+ sb $zero, ($t1) # clear byte
+ addi $t1, $t1, 1 # t1++
+.continue:
+ addi $s0, $s0, 28 # s0 = next action
+ j .next_action # next action
+ nop # delay slot
+.do_mmap_anon:
+ lw $v1, 8($s0) # file_offset
+ lw $a2, 12($s0) # protection
+ lw $a1, 16($s0) # length
+ lw $a3, 20($s0) # flags
+ li $t4, -1 # fd
+ j .do_mmap_1 # do mmap
+ nop # delay slot
+.open_file:
+ li $v0, SYSCALL_open # SYS_open
+ addi $a0, $s0, 4 # start of name
+ move $a1, $zero # flags = O_RDONLY
+ move $a2, $zero # mode = 0
+ syscall # syscall
+ bne $a3, $zero, .perror # perror
+ addi $s0, $s0, 4 # start of string, delay slot
+ move $t3, $s0 # t3 = char past separator
+.nextc:
+ lb $t0, ($s0) # load byte
+ addi $s0, $s0, 1 # s0++
+ li $t1, 47 # directory separator `/'
+ bne $t0, $t1, .nextc1 # is separator char?
+ nop # delay slot
+ move $t3, $s0 # t3 = char past separator
+.nextc1:
+ bnez $t0, .nextc # next character?
+ nop # delay slot
+ addi $s0, $s0, 3 # adjust for round
+ li $t2, -4 # t2 = -4
+ and $s0, $s0, $t2 # mask for round
+ andi $t0, $s2, 16 # t1 = s2 & 16
+ beqz $t0, .primary # primary fd?
+ move $t0, $sp # address of primary fd, delay slot
+ addi $t0, $t0, 4 # address of secondary fd
+ j .next_action # next action
+.primary:
+ sw $v0, ($t0) # store fd, delay slot
+ li $v0, SYSCALL_prctl # SYS_prctl
+ li $a0, 15 # PR_SET_NAME
+ move $a1, $t3 # name
+ move $a2, $zero # arg1
+ move $a3, $zero # arg2
+SYSCALL(`$a2',`$a2',`$a2',`$a2') # syscall args
+ syscall # syscall
+RESTORE() # restore sp
+ j .next_action # next action
+ nop # delay slot
+.perror:
+ move $a0, $v0 # errno
+ li $v0, SYSCALL_exit # SYS_exit
+ syscall # syscall
+.rest_of_exec:
+ move $s1, $s6 # s1 = original SP
+ lw $t0, ($s1) # argc
+ nop # delay slot
+ sll $t0, $t0, 2 # argc *= 4
+ addi $t0, $t0, 8 # argc += 8
+ add $s1, $s1, $t0 # s1 = start of envp
+.skipenv:
+ lw $t0, ($s1) # t0 = *s1
+ addi $s1, $s1, 4 # s1++
+ bne $t0, $zero, .skipenv # skip again
+ nop # delay slot
+ la $s2, .auxvtab # address of auxv table
+.one_auxv:
+ lw $t0, ($s1) # t0 = auxv type
+ li $t1, 10 # t1 = 10, delay slot
+ beqz $t0, .finish # is AT_IGNORE?
+ sltu $t1, $t0, $t1 # t1 = t0 < num offsets, delay slot
+ beq $t1, $zero, .next # next auxv
+ sll $t1, $t0, 2 # t1 = t0 * 4, delay slot
+ add $t1, $s2, $t1 # t1 = .auxvtab + t1
+ lw $t2, ($t1) # t2 = *t1
+ nop # delay slot
+ beqz $t2, .next # skip auxv
+ add $t2, $s0, $t2 # t2 = s0 + t2
+ lw $t2, ($t2) # t2 = *t2
+ nop # delay slot
+ sw $t2, 4($s1) # set auxv value
+.next:
+ addi $s1, $s1, 8 # next auxv
+ j .one_auxv # next auxv
+ nop # delay slot
+.finish:
+ lw $t0, 4($sp) # secondary fd
+ lw $s1, ($sp) # primary fd, delay slot, preserved
+ li $t2, -1 # immediate -1
+ beq $t0, $t2, .finish1 # secondary fd set?
+ li $v0, SYSCALL_close # SYS_close, delay slot
+ move $a0, $t0 # fd
+ syscall # syscall
+ li $v0, SYSCALL_close # SYS_close
+.finish1:
+ move $a0, $s1 # primary fd
+ syscall # syscall
+ li $v0, SYSCALL_prctl # SYS_prctl
+ li $a0, 45 # PR_SET_FP_MODE
+ lw $a1, 28($s0) # fpu_mode
+ move $a2, $zero # arg3
+ move $a3, $zero # arg4
+SYSCALL(`$a2',`$a2',`$a2',`$a2') # syscall args
+ syscall # syscall
+RESTORE() # restore sp
+.jump:
+ move $v0, $zero # rtld_fini
+ lw $t0, 4($s0) # entry
+ move $sp, $s6 # restore stack pointer, delay slot
+ jr $t0 # enter
+ nop # delay slot
+
+.auxvtab:
+ .long 0 # 0
+ .long 0 # 1
+ .long 0 # 2
+ .long 20 # 3 AT_PHDR
+ .long 12 # 4 AT_PHENT
+ .long 16 # 5 AT_PHNUM
+ .long 0 # 6
+ .long 24 # 7 AT_BASE
+ .long 0 # 8
+ .long 8 # 9 AT_ENTRY
+
+.timespec:
+ .long 10
+ .long 10
+
+# Local Variables:
+# asm-comment-char: ?#
+# End:
diff --git a/exec/loader-x86.s b/exec/loader-x86.s
new file mode 100644
index 00000000000..216bc88f976
--- /dev/null
+++ b/exec/loader-x86.s
@@ -0,0 +1,203 @@
+define(`CC', `
+dnl')
+
+CC Copyright (C) 2023-2024 Free Software Foundation, Inc.
+CC
+CC This file is part of GNU Emacs.
+CC
+CC GNU Emacs is free software: you can redistribute it and/or modify
+CC it under the terms of the GNU General Public License as published
+CC by the Free Software Foundation, either version 3 of the License,
+CC or (at your option) any later version.
+CC
+CC GNU Emacs is distributed in the hope that it will be useful, but
+CC WITHOUT ANY WARRANTY; without even the implied warranty of
+CC MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+CC General Public License for more details.
+CC
+CC You should have received a copy of the GNU General Public License
+CC along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>.
+
+ .section .text
+ .global _start
+_start:
+dnl movl $162, %eax CC SYS_nanosleep
+dnl leal timespec, %ebx
+dnl xorl %ecx, %ecx
+dnl int $0x80
+ leal 8(%esp), %ebp CC ebp = start of load area
+ subl $8, %esp CC (%esp) = primary fd, 4(%esp) = secondary fd
+ movl $-1, 4(%esp)
+.next_action:
+ movl (%ebp), %edx CC edx = action number
+ andl $-17, %edx
+ cmpl $0, %edx CC open file?
+ je .open_file
+ cmpl $3, %edx CC jump?
+ je .rest_of_exec
+ cmpl $4, %edx CC anonymous mmap?
+ je .do_mmap_anon
+.do_mmap:
+ subl $24, %esp
+ movl $90, %eax CC SYS_old_mmap
+ movl %esp, %ebx
+ movl 4(%ebp), %ecx CC address
+ movl %ecx, (%esp)
+ movl 16(%ebp), %ecx CC length
+ movl %ecx, 4(%esp)
+ movl 12(%ebp), %ecx CC protection
+ movl %ecx, 8(%esp)
+ movl 20(%ebp), %ecx CC flags
+ movl %ecx, 12(%esp)
+ testl $16, (%ebp) CC primary?
+ movl 28(%esp), %ecx
+ cmovzl 24(%esp), %ecx
+ movl %ecx, 16(%esp) CC fd
+ movl 8(%ebp), %ecx CC offset
+ movl %ecx, 20(%esp)
+.do_mmap_1:
+ int $0x80
+ addl $24, %esp CC restore esp
+ cmpl $-1, %eax CC mmap failed?
+ je .perror
+ movl 24(%ebp), %ecx CC clear
+ testl %ecx, %ecx
+ jz .continue
+ movl 4(%ebp), %esi CC start of mapping
+ addl 16(%ebp), %esi CC end of mapping
+ subl %ecx, %esi CC start of clear area
+.again:
+ testl %ecx, %ecx
+ jz .continue
+ subl $1, %ecx
+ movb $0, (%esi, %ecx, 1)
+ jmp .again
+.continue:
+ leal 28(%ebp), %ebp
+ jmp .next_action
+.do_mmap_anon:
+ subl $24, %esp
+ movl $90, %eax CC SYS_old_mmap
+ movl %esp, %ebx
+ movl 4(%ebp), %ecx CC address
+ movl %ecx, (%esp)
+ movl 16(%ebp), %ecx CC length
+ movl %ecx, 4(%esp)
+ movl 12(%ebp), %ecx CC protection
+ movl %ecx, 8(%esp)
+ movl 20(%ebp), %ecx CC flags
+ movl %ecx, 12(%esp)
+ movl $-1, 16(%esp) CC fd
+ movl 8(%ebp), %ecx CC offset
+ movl %ecx, 20(%esp)
+ jmp .do_mmap_1
+.open_file:
+ movl $5, %eax CC SYS_open
+ leal 4(%ebp), %ebx CC ebx = %esp + 8
+ pushl %ebx
+ xorl %ecx, %ecx CC flags = O_RDONLY
+ xorl %edx, %edx CC mode = 0
+ int $0x80
+ cmpl $-1, %eax CC open failed?
+ jle .perror
+ movl %ebp, %esi CC (esi) = original action number
+ popl %ebp CC ebp = start of string
+ movl %ebp, %ecx CC char past separator
+ decl %ebp
+.nextc:
+ incl %ebp
+ movb (%ebp), %dl CC dl = *ebp
+ cmpb $47, %dl CC dl == '\?'?
+ jne .nextc1
+ leal 1(%ebp), %ecx CC ecx = char past separator
+.nextc1:
+ cmpb $0, %dl CC dl == 0?
+ jne .nextc
+ addl $4, %ebp CC adjust past ebp prior to rounding
+ andl $-4, %ebp CC round ebp up to the next long
+ testl $16, (%esi) CC original action number & 16?
+ jz .primary
+ movl %eax, 4(%esp) CC secondary fd = eax
+ jmp .next_action
+.primary:
+ pushl %ebp
+ xorl %esi, %esi CC arg3
+ movl %eax, 4(%esp) CC primary fd = eax
+ xorl %edx, %edx CC arg2
+ movl $15, %ebx CC PR_SET_NAME, arg1 = ecx
+ xorl %edi, %edi CC arg4
+ movl $172, %eax CC SYS_prctl
+ xorl %ebp, %ebp CC arg5
+ int $0x80 CC syscall
+ popl %ebp
+ jmp .next_action
+.perror:
+ movl %eax, %ebx
+ negl %ebx
+ movl $1, %eax
+ int $0x80
+.rest_of_exec:
+ movl 8(%esp), %ecx CC ecx = original stack pointer
+ movl (%ecx), %esi CC esi = argc
+ leal 8(%ecx, %esi, 4), %ecx CC ecx = start of environ
+.skip_environ:
+ movl (%ecx), %esi CC envp[N]
+ addl $4, %ecx
+ testl %esi, %esi CC envp[n] ?
+ jnz .skip_environ CC otherwise, esi is now at the start of auxv
+.one_auxv:
+ movl (%ecx), %esi CC auxv type
+ leal 8(%ecx), %ecx CC skip to next auxv
+ testl %esi, %esi CC is 0?
+ jz .cleanup
+ cmpl $3, %esi CC is AT_PHDR
+ je .replace_phdr
+ cmpl $4, %esi CC is AT_PHENT?
+ je .replace_phent
+ cmpl $5, %esi CC is AT_PHNUM?
+ je .replace_phnum
+ cmpl $9, %esi CC is AT_ENTRY?
+ je .replace_entry
+ cmpl $7, %esi CC is AT_BASE
+ je .replace_base
+ jmp .one_auxv
+.replace_phdr:
+ movl 20(%ebp), %esi
+ movl %esi, -4(%ecx)
+ jmp .one_auxv
+.replace_phent:
+ movl 12(%ebp), %esi
+ movl %esi, -4(%ecx)
+ jmp .one_auxv
+.replace_phnum:
+ movl 16(%ebp), %esi
+ movl %esi, -4(%ecx)
+ jmp .one_auxv
+.replace_entry:
+ movl 8(%ebp), %esi
+ movl %esi, -4(%ecx)
+ jmp .one_auxv
+.replace_base:
+ movl 24(%ebp), %esi
+ movl %esi, -4(%ecx)
+ jmp .one_auxv
+.cleanup:
+ movl $6, %eax CC SYS_close
+ cmpl $-1, 4(%esp) CC see if interpreter fd is set
+ je .cleanup_1
+ movl 4(%esp), %ebx
+ int $0x80
+ movl $6, %eax CC SYS_close
+.cleanup_1:
+ movl (%esp), %ebx
+ int $0x80
+.enter:
+ pushl $0
+ popfl CC restore floating point state
+ movl 8(%esp), %esp CC restore initial stack pointer
+ xorl %edx, %edx CC clear rtld_fini
+ jmpl *4(%ebp) CC entry
+
+timespec:
+ .long 10
+ .long 10
diff --git a/exec/loader-x86_64.s b/exec/loader-x86_64.s
new file mode 100644
index 00000000000..2ef779e4504
--- /dev/null
+++ b/exec/loader-x86_64.s
@@ -0,0 +1,195 @@
+define(`CC', `
+dnl')
+
+CC Copyright (C) 2023-2024 Free Software Foundation, Inc.
+CC
+CC This file is part of GNU Emacs.
+CC
+CC GNU Emacs is free software: you can redistribute it and/or modify
+CC it under the terms of the GNU General Public License as published
+CC by the Free Software Foundation, either version 3 of the License,
+CC or (at your option) any later version.
+CC
+CC GNU Emacs is distributed in the hope that it will be useful, but
+CC WITHOUT ANY WARRANTY; without even the implied warranty of
+CC MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+CC General Public License for more details.
+CC
+CC You should have received a copy of the GNU General Public License
+CC along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>.
+
+ .section .text
+ .global _start
+_start:
+dnl movq $35, %rax CC SYS_nanosleep
+dnl leaq timespec(%rip), %rdi
+dnl xorq %rsi, %rsi
+dnl syscall
+ popq %r13 CC original SP
+ popq %r15 CC size of load area.
+ movq $-1, %r12 CC r12 is the interpreter fd
+.next_action:
+ movq (%rsp), %r14 CC action number
+ movq %r14, %r15 CC original action number
+ andq $-17, %r14
+ cmpq $0, %r14 CC open file?
+ je .open_file
+ cmpq $3, %r14 CC jump?
+ je .rest_of_exec
+ cmpq $4, %r14 CC anonymous mmap?
+ je .do_mmap_anon
+.do_mmap:
+ movq $9, %rax CC SYS_mmap
+ movq 8(%rsp), %rdi CC address
+ movq 16(%rsp), %r9 CC offset
+ movq 24(%rsp), %rdx CC protection
+ movq 32(%rsp), %rsi CC length
+ movq 40(%rsp), %r10 CC flags
+ CC set r8 to the primary fd unless r15 & 16
+ testq $16, %r15
+ movq %r12, %r8
+ cmovzq %rbx, %r8
+.do_mmap_1:
+ syscall
+ cmpq $-1, %rax CC mmap failed
+ je .perror
+ movq 48(%rsp), %r9 CC clear
+ testq %r9, %r9
+ jz .continue
+ movq 8(%rsp), %r10 CC start of mapping
+ addq 32(%rsp), %r10 CC end of mapping
+ subq %r9, %r10 CC start of clear area
+.again:
+ testq %r9, %r9
+ jz .continue
+ subq $1, %r9
+ movb $0, (%r10, %r9, 1)
+ jmp .again
+.continue:
+ leaq 56(%rsp), %rsp
+ jmp .next_action
+.do_mmap_anon:
+ movq $9, %rax CC SYS_mmap
+ movq 8(%rsp), %rdi CC address
+ movq 16(%rsp), %r9 CC offset
+ movq 24(%rsp), %rdx CC protection
+ movq 32(%rsp), %rsi CC length
+ movq 40(%rsp), %r10 CC flags
+ movq $-1, %r8 CC -1
+ jmp .do_mmap_1
+.open_file:
+ movq $2, %rax CC SYS_open
+ leaq 8(%rsp), %rdi CC rdi = %rsp + 8
+ xorq %rsi, %rsi CC flags = O_RDONLY
+ xorq %rdx, %rdx CC mode = 0
+ syscall
+ cmpq $-1, %rax CC open failed
+ jle .perror
+ movq %rdi, %rsp CC rsp = start of string
+ subq $1, %rsp
+ movq %rsp, %r14 CC r14 = start of string
+.nextc:
+ addq $1, %rsp
+ movb (%rsp), %dil CC rdi = *rsp
+ cmpb $47, %dil CC *rsp == '/'?
+ jne .nextc1
+ movq %rsp, %r14 CC r14 = rsp
+ addq $1, %r14 CC r14 = char past separator
+.nextc1:
+ cmpb $0, %dil CC *rsp == 0?
+ jne .nextc
+ addq $8, %rsp CC adjust past rsp prior to rounding
+ andq $-8, %rsp CC round rsp up to the next quad
+ testq $16, %r15 CC r15 & 16?
+ jz .primary
+ movq %rax, %r12 CC otherwise, move fd to r12
+ jmp .next_action
+.primary:
+ movq %rax, %rbx CC if not, move fd to rbx
+ movq $157, %rax CC SYS_prctl
+ movq $15, %rdi CC PR_SET_NAME
+ movq %r14, %rsi CC arg1
+ xorq %rdx, %rdx CC arg2
+ xorq %r10, %r10 CC arg3
+ xorq %r8, %r8 CC arg4
+ xorq %r9, %r9 CC arg5
+ syscall
+ jmp .next_action
+.perror:
+ movq %rax, %r12 CC error code
+ negq %r12
+ movq $1, %rax CC SYS_write
+ movq $1, %rdi CC stdout
+ leaq error(%rip), %rsi CC buffer
+ movq $23, %rdx CC count
+ syscall
+ movq $60, %rax CC SYS_exit
+ movq %r12, %rdi CC code
+ syscall
+.rest_of_exec: CC rsp now points to six quads:
+ movq %rsp, %r8 CC now, they are r8
+ movq %r13, %rsp CC restore SP
+ popq %r10 CC argc
+ leaq 8(%rsp,%r10,8), %rsp CC now at start of environ
+.skip_environ:
+ popq %r10 CC envp[N]
+ testq %r10, %r10 CC envp[n]?
+ jnz .skip_environ CC otherwise, rsp is now at the start of auxv
+.one_auxv:
+ popq %rcx CC auxv type
+ addq $8, %rsp CC skip value
+ testq %rcx, %rcx CC is 0?
+ jz .cleanup
+ cmpq $3, %rcx CC is AT_PHDR?
+ je .replace_phdr
+ cmpq $4, %rcx CC is AT_PHENT?
+ je .replace_phent
+ cmpq $5, %rcx CC is AT_PHNUM?
+ je .replace_phnum
+ cmpq $9, %rcx CC is AT_ENTRY?
+ je .replace_entry
+ cmpq $7, %rcx CC is AT_BASE?
+ je .replace_base
+ jmp .one_auxv
+.replace_phdr:
+ movq 40(%r8), %r9
+ movq %r9, -8(%rsp) CC set at_phdr
+ jmp .one_auxv
+.replace_phent:
+ movq 24(%r8), %r9
+ movq %r9, -8(%rsp) CC set at_phent
+ jmp .one_auxv
+.replace_phnum:
+ movq 32(%r8), %r9
+ movq %r9, -8(%rsp) CC set at_phnum
+ jmp .one_auxv
+.replace_entry:
+ movq 16(%r8), %r9
+ movq %r9, -8(%rsp) CC set at_entry
+ jmp .one_auxv
+.replace_base:
+ movq 48(%r8), %r9
+ movq %r9, -8(%rsp) CC set at_base
+ jmp .one_auxv
+.cleanup:
+ movq $3, %rax CC SYS_close
+ cmpq $-1, %r12 CC see if interpreter fd is set
+ je .cleanup_1
+ movq %r12, %rdi
+ syscall
+ movq $3, %rax CC SYS_close
+.cleanup_1:
+ movq %rbx, %rdi
+ syscall
+.enter:
+ pushq $0
+ popfq CC clear FP state
+ movq %r13, %rsp CC restore SP
+ xorq %rdx, %rdx CC clear rtld_fini
+ jmpq *8(%r8) CC entry
+
+error:
+ .ascii "_start: internal error."
+timespec:
+ .quad 10
+ .quad 10
diff --git a/exec/mipsel-user.h b/exec/mipsel-user.h
new file mode 100644
index 00000000000..04f4a2a5089
--- /dev/null
+++ b/exec/mipsel-user.h
@@ -0,0 +1,42 @@
+/* Program execution for Emacs.
+
+Copyright (C) 2023-2024 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 <https://www.gnu.org/licenses/>. */
+
+
+
+#ifndef _MIPSEL_USER_H_
+#define _MIPSEL_USER_H_
+
+#include <sys/user.h>
+
+#ifndef ELF_NGREG
+#define ELF_NGREG 45
+#endif /* ELF_NGREG */
+
+
+
+/* This file defines a structure containing user mode general purpose
+ registers on 32-bit mipsel systems. */
+
+struct mipsel_regs
+{
+ /* General purpose registers. */
+ uint64_t gregs[ELF_NGREG];
+};
+
+#endif /* _MIPSEL_USER_H_ */
diff --git a/exec/mipsfpu.c b/exec/mipsfpu.c
new file mode 100644
index 00000000000..5fd81fb9237
--- /dev/null
+++ b/exec/mipsfpu.c
@@ -0,0 +1,289 @@
+/* Program execution for Emacs.
+
+Copyright (C) 2023-2024 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 <https://www.gnu.org/licenses/>. */
+
+#include <config.h>
+#include <errno.h>
+
+#include "mipsfpu.h"
+
+
+
+/* OABI MIPS systems support several different modes of execution.
+ Each mode differs in the size and utilization of the hardware
+ floating-point registers.
+
+ Linux normally sets the floating point mode to one appropriate for
+ execution, taking into account the floating point modes of the
+ interpreter and executable binaries. However, this logic is
+ forsaken when the `execve' system call is overwritten.
+
+ Thus, the correct floating point mode must be determined and set
+ within the loader binary. */
+
+
+
+/* Various constants used throughout this code. */
+
+#define MIPS_ABI_FP_ANY 0 /* FP ABI doesn't matter */
+#define MIPS_ABI_FP_DOUBLE 1 /* -mdouble-float */
+#define MIPS_ABI_FP_SINGLE 2 /* -msingle-float */
+#define MIPS_ABI_FP_SOFT 3 /* -msoft-float */
+#define MIPS_ABI_FP_OLD_64 4 /* -mips32r2 -mfp64 */
+#define MIPS_ABI_FP_XX 5 /* -mfpxx */
+#define MIPS_ABI_FP_64 6 /* -mips32r2 -mfp64 */
+#define MIPS_ABI_FP_64A 7 /* -mips32r2 -mfp64 -mno-odd-spreg */
+
+#define EF_MIPS_NOREORDER 1 /* A .noreorder directive was used. */
+#define EF_MIPS_PIC 2 /* Contains PIC code. */
+#define EF_MIPS_CPIC 4 /* Uses PIC calling sequence. */
+#define EF_MIPS_XGOT 8
+#define EF_MIPS_64BIT_WHIRL 16
+#define EF_MIPS_ABI2 32
+#define EF_MIPS_ABI_ON32 64
+#define EF_MIPS_FP64 512 /* Uses FP64 (12 callee-saved). */
+#define EF_MIPS_NAN2008 1024 /* Uses IEEE 754-2008 NaN encoding. */
+#define EF_MIPS_ARCH 0xf0000000 /* MIPS architecture level. */
+
+
+
+/* Structure describing the requirements of a single floating-point
+ ABI. */
+
+struct mode_description
+{
+ /* Whether or not the ABI only executes single precision
+ instructions, and can operate in both 32-bit or 64-bit floating
+ point mode. */
+ bool single;
+
+ /* Whether or not the ABI performs floating point operations in
+ software, using integer registers. */
+ bool soft;
+
+ /* Whether or not the ABI requires the use of 64-bit floating point
+ registers. */
+ bool fr1;
+
+ /* Whether or not the ABI requires the use of 64-bit floating point
+ registers on NABI systems, and 32-bit ones on OABI systems. */
+ bool frdefault;
+
+ /* Whether or not this ABI requires single precision floating point
+ emulation. */
+ bool fre;
+};
+
+static struct mode_description fpu_reqs[] =
+ {
+ [MIPS_ABI_FP_ANY] = { true, true, true, true, true, },
+ [MIPS_ABI_FP_DOUBLE] = { false, false, false, true, true, },
+ [MIPS_ABI_FP_SINGLE] = { true, false, false, false, false, },
+ [MIPS_ABI_FP_SOFT] = { false, true, false, false, false, },
+ [MIPS_ABI_FP_OLD_64] = { false, false, false, false, false, },
+ [MIPS_ABI_FP_XX] = { false, false, true, true, true, },
+ [MIPS_ABI_FP_64] = { false, false, true, false, false, },
+ [MIPS_ABI_FP_64A] = { false, false, true, false, true, },
+ };
+
+
+
+/* Return whether or not the given floating-point ABI is valid. */
+
+static bool
+valid_abi_p (int abi)
+{
+ switch (abi)
+ {
+ case MIPS_ABI_FP_ANY:
+ case MIPS_ABI_FP_DOUBLE:
+ case MIPS_ABI_FP_SINGLE:
+ case MIPS_ABI_FP_SOFT:
+ case MIPS_ABI_FP_OLD_64:
+ case MIPS_ABI_FP_XX:
+ case MIPS_ABI_FP_64:
+ case MIPS_ABI_FP_64A:
+ return true;
+
+ default:
+ return false;
+ }
+}
+
+/* Return the floating point mode appropriate for the specified
+ floating point ABI. */
+
+static int
+fp_mode_for_abi (int abi)
+{
+ struct mode_description *desc;
+
+ desc = &fpu_reqs[abi];
+
+ if (desc->fre)
+ return FP_FRE;
+ else if (desc->fr1)
+ return FP_FR1;
+
+ return FP_FR0;
+}
+
+/* Determine whether or not the CPU is capable of operating in FR0
+ floating point mode. */
+
+bool
+cpu_supports_fr0_p (void)
+{
+#if defined __mips_isa_rev && __mips_isa_rev >= 6
+ return true;
+#else /* !defined __mips_isa_rev | mips_isa_rev < 6 */
+ return false;
+#endif /* defined __mips_isa_rev && mips_isa_rev >= 6 */
+}
+
+/* Determine the FPU mode for the executable whose ELF header is
+ HEADER. If INTERPRETER is non-NULL, also take an interpreter whose
+ header is INTERPRETER into account.
+
+ ABIFLAGS should be HEADER's corresponding PT_MIPS_ABIFLAGS program
+ header, and ABIFLAGS1 should be that of INTERPRETER, if set. Both
+ fields may be NULL if no PT_MIPS_ABIFLAGS header is present; in
+ that case, use HEADER->e_flags to determine the ABI instead.
+
+ Return the FPU mode in *MODE. Value is 0 upon success, 1
+ otherwise, with errno set. */
+
+int
+determine_fpu_mode (elf_header *header, elf_header *interpreter,
+ int *mode, struct mips_elf_abi_flags *abiflags,
+ struct mips_elf_abi_flags *abiflags1)
+{
+ int exec_abi, interpreter_abi;
+ struct mode_description *exec_desc, *interpreter_desc, common;
+
+ /* Figure out the executable's floating point ABI. First, consult
+ header->e_flags, and use the old 64-bit floating point ABI if it
+ is specified. */
+
+ exec_abi = MIPS_ABI_FP_ANY;
+
+ /* First, check HEADER->e_flags. */
+
+ if (header->e_flags & EF_MIPS_FP64)
+ exec_abi = MIPS_ABI_FP_OLD_64;
+
+ /* Next, use ABIFLAGS if it exists. */
+
+ if (abiflags && valid_abi_p (abiflags->fp_abi))
+ exec_abi = abiflags->fp_abi;
+ else if (abiflags)
+ {
+ errno = ENOEXEC;
+ return 1;
+ }
+
+ /* Now determine that of the interpreter. */
+
+ interpreter_abi = MIPS_ABI_FP_ANY;
+
+ if (interpreter)
+ {
+ if (interpreter->e_flags & EF_MIPS_FP64)
+ interpreter_abi = MIPS_ABI_FP_OLD_64;
+
+ if (abiflags1 && valid_abi_p (abiflags->fp_abi))
+ interpreter_abi = abiflags->fp_abi;
+ else if (abiflags1)
+ {
+ errno = ELIBBAD;
+ return 1;
+ }
+ }
+
+ /* If no interpreter flag is set, just return that of the
+ executable. */
+
+ if (!interpreter)
+ {
+ *mode = fp_mode_for_abi (exec_abi);
+ return 0;
+ }
+
+ /* Otherwise, compare both ABIs and try to find one which will run
+ both kinds of code.
+
+ First, see if there's an easy way out: both ABIs are identical,
+ or one ABI is MIPS_ABI_FP_ANY. */
+
+ if (exec_abi == interpreter_abi)
+ {
+ *mode = fp_mode_for_abi (exec_abi);
+ return 0;
+ }
+ else if (exec_abi == MIPS_ABI_FP_ANY)
+ {
+ *mode = fp_mode_for_abi (interpreter_abi);
+ return 0;
+ }
+ else if (interpreter_abi == MIPS_ABI_FP_ANY)
+ {
+ *mode = fp_mode_for_abi (exec_abi);
+ return 0;
+ }
+
+ /* If that doesn't work, compare various characteristics of both
+ ABIs and select an appropriate floating point mode. */
+
+ exec_desc = &fpu_reqs[exec_abi];
+ interpreter_desc = &fpu_reqs[interpreter_abi];
+
+ /* Merge both sets of requirements. */
+ common.single = exec_desc->single && interpreter_desc->single;
+ common.soft = exec_desc->soft && interpreter_desc->soft;
+ common.fr1 = exec_desc->fr1 && interpreter_desc->fr1;
+ common.frdefault = exec_desc->frdefault && interpreter_desc->frdefault;
+ common.fre = exec_desc->fre && interpreter_desc->fre;
+
+ /* Default to a mode capable of running code expecting 32-bit
+ registers. */
+
+ if (!(header->e_flags & EF_MIPS_ABI2))
+ *mode = FP_FR0;
+ else
+ /* But in this case, use FR1. */
+ *mode = FP_FR1;
+
+ if (common.fre && !common.frdefault && !common.fr1)
+ /* Floating point emulation mode is required. */
+ *mode = FP_FRE;
+ else if ((common.fr1 && common.frdefault)
+ || (common.single && !common.frdefault)
+ || common.fr1)
+ /* 64-bit mode is required. */
+ *mode = FP_FR1;
+ else if (!common.fre && !common.frdefault
+ && !common.fr1 && !common.single
+ && !common.soft)
+ {
+ /* The floating point modes specified are incompatible. */
+ errno = ELIBBAD;
+ return -1;
+ }
+
+ return 0;
+}
diff --git a/exec/mipsfpu.h b/exec/mipsfpu.h
new file mode 100644
index 00000000000..1669102942b
--- /dev/null
+++ b/exec/mipsfpu.h
@@ -0,0 +1,82 @@
+/* Program execution for Emacs.
+
+Copyright (C) 2023-2024 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 <https://www.gnu.org/licenses/>. */
+
+
+
+#ifndef _MIPSFPU_H_
+#define _MIPSFPU_H_
+
+#include "exec.h"
+
+struct mips_elf_abi_flags
+{
+ /* Version of flags structure. */
+ uint16_t version;
+
+ /* The level of the ISA: 1-5, 32, 64. */
+ uint8_t isa_level;
+
+ /* The revision of ISA: 0 for MIPS V and below, 1-n otherwise. */
+ uint8_t isa_rev;
+
+ /* The size of general purpose registers. */
+ uint8_t gpr_size;
+
+ /* The size of co-processor 1 registers. */
+ uint8_t cpr1_size;
+
+ /* The size of co-processor 2 registers. */
+ uint8_t cpr2_size;
+
+ /* The floating-point ABI. */
+ uint8_t fp_abi;
+
+ /* Mask of processor-specific extensions. */
+ uint32_t isa_ext;
+
+ /* Mask of ASEs used. */
+ uint32_t ases;
+
+ /* Mask of general flags. */
+ uint32_t flags1;
+
+ /* Mask of general flags. */
+ uint32_t flags2;
+};
+
+
+
+/* Floating point modes. */
+
+#define FP_FR0 0
+#define FP_FR1 1
+#define FP_FRE 3
+
+
+
+/* Defined in mipsfpu.c. */
+
+extern bool cpu_supports_fr0_p (void);
+extern int determine_fpu_mode (elf_header *, elf_header *,
+ int *, struct mips_elf_abi_flags *,
+ struct mips_elf_abi_flags *);
+
+
+
+#endif /* _MIPSFPU_H_ */
diff --git a/exec/test.c b/exec/test.c
new file mode 100644
index 00000000000..7185c958b87
--- /dev/null
+++ b/exec/test.c
@@ -0,0 +1,105 @@
+/* Program execution for Emacs.
+
+Copyright (C) 2023-2024 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 <https://www.gnu.org/licenses/>. */
+
+#include <config.h>
+
+#include <signal.h>
+#include <stdio.h>
+#include <unistd.h>
+#include <stdlib.h>
+#include <errno.h>
+#include <string.h>
+
+#include <sys/wait.h>
+
+#include "exec.h"
+
+
+
+static void
+print_usage (void)
+{
+ fprintf (stderr, "test loader-name program [args...]\n"
+ "Run the given program using the specified loader.\n");
+}
+
+
+
+extern char **environ;
+
+/* This program uses libexec to wrap the execution of a child
+ process. */
+
+int
+main (int argc, char **argv)
+{
+ pid_t pid, child;
+ int sig;
+ sigset_t sigset;
+
+ /* Check that there are a sufficient number of arguments. */
+
+ if (argc < 3)
+ {
+ print_usage ();
+ return 1;
+ }
+
+ exec_init (argv[1]);
+
+ /* Block SIGCHLD to avoid reentrant modification of the child
+ process list. */
+
+ sigemptyset (&sigset);
+ sigaddset (&sigset, SIGCHLD);
+ sigprocmask (SIG_BLOCK, &sigset, NULL);
+
+ if (!(pid = fork ()))
+ {
+ tracing_execve (argv[2], argv + 2, environ);
+ fprintf (stderr, "tracing_execve: %s\n",
+ strerror (errno));
+ exit (1);
+ }
+ else if (after_fork (pid))
+ {
+ fprintf (stderr, "after_fork: %s\n",
+ strerror (errno));
+ exit (1);
+ }
+
+ /* Now start waiting for child processes to exit. */
+
+ while (true)
+ {
+ child = exec_waitpid (-1, &sig, 0);
+
+ /* If pid is -1, a system call has been handled. */
+
+ if (child == -1)
+ continue;
+
+ /* If the main process exits, then exit as well. */
+
+ if (child == pid && !WIFSTOPPED (sig))
+ return (WIFEXITED (sig)
+ ? WEXITSTATUS (sig)
+ : WTERMSIG (sig));
+ }
+}
diff --git a/exec/trace.c b/exec/trace.c
new file mode 100644
index 00000000000..05d862f5b9f
--- /dev/null
+++ b/exec/trace.c
@@ -0,0 +1,1702 @@
+/* Program execution for Emacs.
+
+Copyright (C) 2023-2024 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 <https://www.gnu.org/licenses/>. */
+
+#include <config.h>
+
+#include <sys/ptrace.h>
+#include <sys/types.h>
+#include <sys/wait.h>
+
+#include <limits.h>
+#include <stddef.h>
+#include <string.h>
+#include <assert.h>
+#include <signal.h>
+#include <unistd.h>
+#include <stdlib.h>
+#include <errno.h>
+#include <fcntl.h>
+
+#include "exec.h"
+
+#include SYSCALL_HEADER
+#include USER_HEADER
+
+#ifdef __aarch64__
+#include <sys/uio.h> /* for struct iovec */
+#include <linux/elf.h> /* for NT_* */
+#endif /* __aarch64__ */
+
+#ifdef HAVE_SYS_UIO_H
+#include <sys/uio.h> /* for process_vm_readv */
+#endif /* HAVE_SYS_UIO_H */
+
+#ifndef SYS_SECCOMP
+#define SYS_SECCOMP 1
+#endif /* SYS_SECCOMP */
+
+#ifndef PTRACE_GETEVENTMSG
+#define PTRACE_GETEVENTMSG 0x4201
+#endif /* PTRACE_GETEVENTMSG */
+
+
+
+/* Program tracing functions.
+
+ The main entry point is the function `tracing_execve', which traces
+ the thread and calls exec. Each time that thread calls `clone',
+ the new child is traced as well.
+
+ Instead of calling `waitpid', call `exec_waitpid' instead. */
+
+
+
+/* Number of tracees children are allowed to create. */
+#define MAX_TRACEES 4096
+
+#ifdef __aarch64__
+
+/* Place PID's registers into *REGS. Return 1 upon failure, else
+ 0. */
+
+int
+aarch64_get_regs (pid_t pid, USER_REGS_STRUCT *regs)
+{
+ struct iovec iov;
+
+ iov.iov_base = regs;
+ iov.iov_len = sizeof *regs;
+
+ return (ptrace (PTRACE_GETREGSET, pid, NT_PRSTATUS,
+ &iov) != 0);
+}
+
+/* Set PID's registers to *REGS. If SYSCALL_P, also update the
+ current system call number to the `x8' register.
+
+ Value is 1 upon failure, else 0. */
+
+int
+aarch64_set_regs (pid_t pid, USER_REGS_STRUCT *regs,
+ bool syscall_p)
+{
+ struct iovec iov;
+ USER_WORD callno;
+ long rc;
+
+ /* Write the user registers. */
+
+ iov.iov_base = regs;
+ iov.iov_len = sizeof *regs;
+
+ rc = ptrace (PTRACE_SETREGSET, pid, NT_PRSTATUS,
+ &iov);
+ if (rc < 0)
+ return 1;
+
+ /* Now, write the system call number if necessary. */
+
+ if (syscall_p)
+ {
+ callno = regs->regs[8];
+ iov.iov_base = &callno;
+ iov.iov_len = sizeof callno;
+
+ return (ptrace (PTRACE_SETREGSET, pid, NT_ARM_SYSTEM_CALL,
+ &iov) != 0);
+ }
+
+ return 0;
+}
+
+#endif /* __aarch64__ */
+
+
+
+/* List of all processes which are being traced. */
+static struct exec_tracee *tracing_processes;
+
+
+
+/* Read N bytes from TRACEE's memory, starting at the specified user
+ ADDRESS. Return its contents in BUFFER.
+
+ If there are unreadable pages within ADDRESS + N, the contents of
+ BUFFER after the first such page becomes undefined. */
+
+static void
+read_memory (struct exec_tracee *tracee, char *buffer,
+ USER_WORD n, USER_WORD address)
+{
+ USER_WORD word, n_words, n_bytes, i;
+ long rc;
+#ifdef HAVE_PROCESS_VM
+ struct iovec iov, remote;
+
+ /* If `process_vm_readv' is available, use it instead. */
+
+ iov.iov_base = buffer;
+ iov.iov_len = n;
+ remote.iov_base = (void *) address;
+ remote.iov_len = n;
+
+ /* Return immediately if successful. As long as some bytes were
+ read, consider the read to have been a success. */
+
+ if (n <= SSIZE_MAX
+ && ((size_t) process_vm_readv (tracee->pid, &iov, 1,
+ &remote, 1, 0) != -1))
+ return;
+
+#endif /* HAVE_PROCESS_VM */
+
+ /* First, read entire words from the tracee. */
+ n_words = n & ~(sizeof (USER_WORD) - 1);
+
+ /* Next, determine the number of bytes to read from the last
+ word. */
+ n_bytes = n & (sizeof (USER_WORD) - 1);
+
+ /* Start reading words. */
+ i = 0;
+ while (n_words)
+ {
+ rc = ptrace (PTRACE_PEEKTEXT, tracee->pid,
+ (void *) address + i, NULL);
+ word = rc;
+ memcpy (buffer, &word, sizeof word);
+ buffer += sizeof word;
+ i += sizeof word;
+ n_words -= sizeof word;
+ }
+
+ /* Now, read the remaining bytes. */
+ assert (n_bytes < sizeof (word));
+
+ if (n_bytes)
+ {
+ rc = ptrace (PTRACE_PEEKTEXT, tracee->pid,
+ (void *) address + i, NULL);
+ word = rc;
+
+ /* Copy only n_bytes to the caller. */
+ memcpy (buffer, &word, n_bytes);
+ }
+}
+
+/* Allocate N bytes of memory from TRACEE's stack. Return the address
+ of that memory upon success, else 0.
+
+ Place the updated user-mode registers of TRACEE in *NEW_REGS, which
+ should initially contain the current stack pointer of TRACEE.
+
+ REGS should contain the user mode registers of TRACEE prior to the
+ system call starting; it is not updated to reflect any changes. */
+
+USER_WORD
+user_alloca (struct exec_tracee *tracee, USER_REGS_STRUCT *regs,
+ USER_REGS_STRUCT *new_regs, USER_WORD n)
+{
+ USER_WORD sp, old_sp;
+
+ /* Get the current stack pointer. */
+ old_sp = sp = new_regs->STACK_POINTER;
+
+#if RED_ZONE_SIZE
+ /* Some ABI rules specify a ``red zone'' around the stack pointer
+ that is reserved for compiler optimizations. */
+
+#ifdef STACK_GROWS_DOWNWARDS
+ if (sp == regs->STACK_POINTER)
+ sp -= RED_ZONE_SIZE;
+#else /* !STACK_GROWS_DOWNWARDS */
+ if (sp == regs->STACK_POINTER)
+ sp += RED_ZONE_SIZE;
+#endif /* STACK_GROWS_DOWNWARDS */
+#endif /* RED_ZONE_SIZE */
+
+ /* Now take N off the stack. */
+
+#ifdef STACK_GROWS_DOWNWARDS
+ sp = sp - n;
+
+ /* Check for overflow. */
+
+ if (sp > new_regs->STACK_POINTER)
+ return 0;
+#else /* !STACK_GROWS_DOWNWARDS */
+ sp = sp + n;
+
+ /* Check for overflow. */
+
+ if (sp < new_regs->STACK_POINTER)
+ return 0;
+#endif /* STACK_GROWS_DOWNWARDS */
+
+ /* Set the stack pointer. */
+ new_regs->STACK_POINTER = sp;
+
+#ifdef __aarch64__
+ if (aarch64_set_regs (tracee->pid, new_regs, false))
+ goto fail;
+#else /* !__aarch64__ */
+ if (ptrace (PTRACE_SETREGS, tracee->pid, NULL,
+ new_regs))
+ goto fail;
+#endif /* __aarch64__ */
+
+ /* Now return the start of the new area. */
+#ifdef STACK_GROWS_DOWNWARDS
+ return sp;
+#else /* !STACK_GROWS_DOWNWARDS */
+ return sp - n;
+#endif /* STACK_GROWS_DOWNWARDS */
+
+ fail:
+ /* Restore the old stack pointer. */
+ new_regs->STACK_POINTER = old_sp;
+ return 0;
+}
+
+/* Copy N bytes to ADDRESS in TRACEE's address space from BUFFER.
+ Value is 0 upon success, else 1. */
+
+int
+user_copy (struct exec_tracee *tracee, const unsigned char *buffer,
+ USER_WORD address, USER_WORD n)
+{
+ USER_WORD start, end, word;
+ unsigned char *bytes;
+#ifdef HAVE_PROCESS_VM
+ struct iovec iov, remote;
+
+ /* Try to use `process_vm_writev' if possible, but fall back to
+ ptrace if something bad happens. */
+
+ iov.iov_base = (void *) buffer;
+ iov.iov_len = n;
+ remote.iov_base = (void *) address;
+ remote.iov_len = n;
+
+ if (n <= SSIZE_MAX
+ && ((size_t) process_vm_writev (tracee->pid, &iov, 1,
+ &remote, 1, 0) == n))
+ return 0;
+#endif /* HAVE_PROCESS_VM */
+
+ /* Calculate the start and end positions for the write. */
+
+ start = address;
+ end = address + n;
+
+ /* Write from start to the last word. */
+
+ while (start < end)
+ {
+ if (start + sizeof word <= end)
+ {
+ /* Write a word by itself and increment start. */
+ memcpy (&word, buffer, sizeof word);
+ buffer += sizeof word;
+
+ if (ptrace (PTRACE_POKEDATA, tracee->pid,
+ (void *) start, (void *) word))
+ return 1;
+
+ start += sizeof word;
+ }
+ else
+ {
+ /* Only end - start bytes should be written.
+ Read the word at start from tracee->pid, then write
+ it back with changes. */
+
+ word = ptrace (PTRACE_PEEKDATA, tracee->pid,
+ (void *) start, NULL);
+ bytes = (unsigned char *) &word;
+ memcpy (bytes, buffer, end - start);
+
+ if (ptrace (PTRACE_POKEDATA, tracee->pid,
+ (void *) start, (void *) word))
+ return 1;
+
+ /* Writing was successful. */
+ return 0;
+ }
+ }
+
+ return 0;
+}
+
+
+
+/* Chain of free exec_tracee structures. */
+static struct exec_tracee *free_tracees;
+
+/* Remove the specified TRACEE from the chain of all processes being
+ traced. */
+
+static void
+remove_tracee (struct exec_tracee *tracee)
+{
+ struct exec_tracee **last;
+
+ last = &tracing_processes;
+ while (*last)
+ {
+ if (*last == tracee)
+ {
+ *last = tracee->next;
+
+ /* Link the tracee onto the list of free tracees. */
+ tracee->next = free_tracees;
+
+#ifndef REENTRANT
+ /* Free the exec file, if any. */
+ free (tracee->exec_file);
+ tracee->exec_file = NULL;
+#endif /* REENTRANT */
+
+ free_tracees = tracee;
+
+ return;
+ }
+ else
+ last = &(*last)->next;
+ }
+}
+
+
+
+/* Child process tracing. */
+
+/* Array of `struct exec_tracees' that they are allocated from. */
+static struct exec_tracee static_tracees[MAX_TRACEES];
+
+/* Number of tracees currently allocated. */
+static int tracees;
+
+/* Return the `struct exec_tracee' corresponding to the specified
+ PROCESS. */
+
+static struct exec_tracee *
+find_tracee (pid_t process)
+{
+ struct exec_tracee *tracee;
+
+ for (tracee = tracing_processes; tracee; tracee = tracee->next)
+ {
+ if (tracee->pid == process)
+ return tracee;
+ }
+
+ return NULL;
+}
+
+/* Prepare to handle the completion of a `clone' system call.
+
+ If the new clone is not yet being traced, create a new tracee for
+ PARENT's child, copying over its current command line. Then, set
+ `new_child' in the new tracee. Otherwise, continue it until the
+ next syscall. */
+
+static void
+handle_clone_prepare (struct exec_tracee *parent)
+{
+#ifndef REENTRANT
+ long rc;
+ unsigned long pid;
+ struct exec_tracee *tracee;
+
+ rc = ptrace (PTRACE_GETEVENTMSG, parent->pid, NULL,
+ &pid);
+ if (rc)
+ return;
+
+ /* See if the tracee already exists. */
+ tracee = find_tracee (pid);
+
+ if (tracee)
+ {
+ /* Continue the tracee. Record its command line, as that has
+ not yet been done. */
+
+ assert (tracee->new_child);
+ tracee->new_child = false;
+ tracee->exec_file = NULL;
+ ptrace (PTRACE_SYSCALL, tracee->pid, 0, 0);
+
+ if (parent->exec_file)
+ tracee->exec_file = strdup (parent->exec_file);
+ return;
+ }
+
+ if (free_tracees)
+ {
+ tracee = free_tracees;
+ free_tracees = free_tracees->next;
+ }
+ else if (tracees < MAX_TRACEES)
+ {
+ tracee = &static_tracees[tracees];
+ tracees++;
+ }
+#ifndef REENTRANT
+ /* Try to allocate a tracee using `malloc' if this library is
+ not being built to run inside a signal handler. */
+ else if ((tracee = malloc (sizeof *tracee)))
+ ;
+#endif /* REENTRANT */
+ else
+ return;
+
+ tracee->pid = pid;
+ tracee->next = tracing_processes;
+ tracee->waiting_for_syscall = false;
+ tracee->new_child = true;
+ tracee->exec_file = NULL;
+ tracing_processes = tracee;
+
+ /* Copy over the command line. */
+
+ if (parent->exec_file)
+ tracee->exec_file = strdup (parent->exec_file);
+#endif /* REENTRANT */
+}
+
+/* Handle the completion of a `clone' or `clone3' system call,
+ resulting in the creation of the process PID. If TRACEE is NULL,
+ allocate a new tracee structure from a static area for the
+ processes's pid, then set TRACEE->new_child to true and await the
+ parent's corresponding ptrace event to arrive; otherwise, just
+ clear TRACEE->new_child.
+
+ Value is 0 upon success, 2 if TRACEE should remain suspended until
+ the parent's ptrace-stop, and 1 otherwise. */
+
+static int
+handle_clone (struct exec_tracee *tracee, pid_t pid)
+{
+ long rc;
+ int flags, value;
+
+ /* Now allocate a new tracee, either from static_tracees or the free
+ list, if no tracee was supplied. */
+
+ value = 0;
+
+ if (!tracee)
+ {
+ if (free_tracees)
+ {
+ tracee = free_tracees;
+ free_tracees = free_tracees->next;
+ }
+ else if (tracees < MAX_TRACEES)
+ {
+ tracee = &static_tracees[tracees];
+ tracees++;
+ }
+#ifndef REENTRANT
+ /* Try to allocate a tracee using `malloc' if this library is
+ not being built to run inside a signal handler. */
+ else if ((tracee = malloc (sizeof *tracee)))
+ ;
+#endif /* REENTRANT */
+ else
+ return 1;
+
+ tracee->pid = pid;
+ tracee->next = tracing_processes;
+ tracee->waiting_for_syscall = false;
+#ifndef REENTRANT
+ tracee->exec_file = NULL;
+#endif /* REENTRANT */
+ tracing_processes = tracee;
+ tracee->new_child = true;
+
+ /* Wait for the ptrace-stop to happen in the parent. */
+ value = 2;
+ }
+ else
+ /* Clear the flag saying that this is a newly created child
+ process. */
+ tracee->new_child = false;
+
+ /* Apply required options to the child, so that the kernel
+ automatically traces children and makes it easy to differentiate
+ between system call traps and other kinds of traps. */
+
+ flags = PTRACE_O_TRACECLONE;
+ flags |= PTRACE_O_TRACEVFORK;
+ flags |= PTRACE_O_TRACEFORK;
+ flags |= PTRACE_O_TRACESYSGOOD;
+ flags |= PTRACE_O_TRACEEXIT;
+
+ rc = ptrace (PTRACE_SETOPTIONS, pid, 0, flags);
+
+ if (rc)
+ goto bail;
+
+ if (value != 2)
+ {
+ /* The new tracee is currently stopped. Continue it until the next
+ system call. */
+
+ rc = ptrace (PTRACE_SYSCALL, pid, 0, 0);
+
+ if (rc)
+ goto bail;
+ }
+
+ return value;
+
+ bail:
+ remove_tracee (tracee);
+ return 1;
+}
+
+
+
+/* NOTICE: none of these functions should ever call `malloc' or
+ another async signal unsafe function. */
+
+/* File name of the loader binary. */
+static const char *loader_name;
+
+
+
+/* Return whether or not the trap signal described by SIGNAL is
+ generated by a system call being attempted by a tracee. */
+
+static bool
+syscall_trap_p (siginfo_t *signal)
+{
+ /* SIGTRAP delivered by the kernel means this is a system call
+ stop. */
+ return (signal->si_code == SIGTRAP
+ || signal->si_code == (SIGTRAP | SI_KERNEL));
+}
+
+/* Check if the wait status STATUS indicates a system call trap.
+ TRACEE is the process whose stop STATUS describes. If TRACEE exits
+ while this information is being determined, return -1; if STATUS
+ indicates some other kind of stop, return 1 after continuing
+ TRACEE. Value is 0 otherwise. */
+
+static int
+check_signal (struct exec_tracee *tracee, int status)
+{
+ siginfo_t siginfo;
+
+ switch ((status & 0xfff00) >> 8)
+ {
+ case SIGTRAP:
+ /* Now, use PTRACE_GETSIGINFO to determine whether or not the
+ signal was delivered in response to a system call. */
+
+ if (ptrace (PTRACE_GETSIGINFO, tracee->pid, 0, &siginfo))
+ return -1;
+
+ if (!syscall_trap_p (&siginfo))
+ {
+ if (siginfo.si_code < 0)
+ /* SIGTRAP delivered from userspace. Pass it on. */
+ ptrace (PTRACE_SYSCALL, tracee->pid, 0, SIGTRAP);
+ else
+ ptrace (PTRACE_SYSCALL, tracee->pid, 0, 0);
+
+ return 1;
+ }
+
+ case SIGTRAP | 0x80: /* SIGTRAP | 0x80 specifically refers to
+ system call traps. */
+ break;
+
+#ifdef SIGSYS
+ case SIGSYS:
+ if (ptrace (PTRACE_GETSIGINFO, tracee->pid, 0, &siginfo))
+ return -1;
+
+ /* Continue the process until the next syscall, but don't
+ pass through the signal if an emulated syscall led to
+ it. */
+#ifdef HAVE_SIGINFO_T_SI_SYSCALL
+#ifndef __arm__
+ ptrace (PTRACE_SYSCALL, tracee->pid,
+ 0, ((siginfo.si_code == SYS_SECCOMP
+ && siginfo.si_syscall == -1)
+ ? 0 : status));
+#else /* __arm__ */
+ ptrace (PTRACE_SYSCALL, tracee->pid,
+ 0, ((siginfo.si_code == SYS_SECCOMP
+ && siginfo.si_syscall == 222)
+ ? 0 : status));
+#endif /* !__arm__ */
+#else /* !HAVE_SIGINFO_T_SI_SYSCALL */
+ /* Drop this signal, since what caused it is unknown. */
+ ptrace (PTRACE_SYSCALL, tracee->pid, 0, 0);
+#endif /* HAVE_SIGINFO_T_SI_SYSCALL */
+ return 1;
+#endif /* SIGSYS */
+
+ default:
+ /* Continue the process until the next syscall. */
+ ptrace (PTRACE_SYSCALL, tracee->pid, 0, status);
+ return 1;
+ }
+
+ return 0;
+}
+
+
+
+/* Handle an `exec' system call from the given TRACEE. REGS are the
+ tracee's current user-mode registers.
+
+ Rewrite the system call arguments to use the loader binary. Then,
+ continue the system call until the loader is loaded. Write the
+ information necessary to load the original executable into the
+ loader's stack.
+
+ Value is 0 upon success, 1 upon a generic failure before the loader
+ is loaded, 2 if the process has stopped, and 3 if something failed,
+ but it is too late to handle it.
+
+ Set errno appropriately upon returning a generic failure. */
+
+static int
+handle_exec (struct exec_tracee *tracee, USER_REGS_STRUCT *regs)
+{
+ char buffer[PATH_MAX + 80], *area;
+ USER_REGS_STRUCT original;
+ size_t size, loader_size;
+ USER_WORD loader, size1, sp;
+ int rc, wstatus;
+ siginfo_t siginfo;
+
+ /* Save the old stack pointer. */
+ sp = regs->STACK_POINTER;
+
+ /* Read the file name. */
+ read_memory (tracee, buffer, PATH_MAX,
+ regs->SYSCALL_ARG_REG);
+
+ /* Make sure BUFFER is NULL terminated. */
+
+ if (!memchr (buffer, '\0', PATH_MAX))
+ {
+ errno = ENAMETOOLONG;
+ return 1;
+ }
+
+ /* Copy over the registers as they originally were. */
+ memcpy (&original, regs, sizeof *regs);
+
+ /* Figure out what the loader needs to do. */
+ again1:
+ area = exec_0 (buffer, tracee, &size, regs);
+
+ if (!area)
+ {
+ /* Handle SIGINTR errors caused by IO. */
+ if (errno == EINTR)
+ goto again1;
+
+ return 1;
+ }
+
+ /* Rewrite the first argument to point to the loader. */
+
+ loader_size = strlen (loader_name) + 1;
+ loader = user_alloca (tracee, &original, regs,
+ loader_size);
+
+ if (!loader)
+ {
+ errno = ENOMEM;
+ return 1;
+ }
+
+ if (user_copy (tracee, (unsigned char *) loader_name,
+ loader, loader_size))
+ {
+ errno = EIO;
+ return 1;
+ }
+
+ regs->SYSCALL_ARG_REG = loader;
+
+#ifdef __aarch64__
+
+ if (aarch64_set_regs (tracee->pid, regs, false))
+ {
+ errno = EIO;
+ return 1;
+ }
+
+#else /* !__aarch64__ */
+
+ if (ptrace (PTRACE_SETREGS, tracee->pid, NULL,
+ regs))
+ {
+ errno = EIO;
+ return 1;
+ }
+
+#endif /* __aarch64__ */
+
+ /* Continue the system call until loader starts. */
+
+ if (ptrace (PTRACE_SYSCALL, tracee->pid, NULL, NULL))
+ {
+ errno = EIO;
+ return 1;
+ }
+
+#ifndef REENTRANT
+ /* Now that the loader has started, record the value to use for
+ /proc/self/exe. Don't give up just because strdup fails.
+
+ Note that exec_0 copies the absolute file name into buffer. */
+
+ if (tracee->exec_file)
+ free (tracee->exec_file);
+ tracee->exec_file = strdup (buffer);
+#endif /* REENTRANT */
+
+ again:
+ rc = waitpid (tracee->pid, &wstatus, __WALL);
+ if (rc == -1 && errno == EINTR)
+ goto again;
+
+ if (rc < 0)
+ return 1;
+
+ if (!WIFSTOPPED (wstatus))
+ /* The process has been killed in response to a signal.
+ In this case, simply return 2. */
+ return 2;
+ else
+ {
+ /* Then, check if STATUS is not a syscall-stop, and try again if
+ it isn't. */
+ rc = check_signal (tracee, wstatus);
+
+ if (rc == -1)
+ return 2;
+ else if (rc)
+ goto again;
+
+ /* Retrieve the signal information and determine whether or not
+ the system call has completed. */
+
+ if (ptrace (PTRACE_GETSIGINFO, tracee->pid, 0,
+ &siginfo))
+ return 3;
+
+ if (!syscall_trap_p (&siginfo))
+ {
+ /* Continue. */
+ if (ptrace (PTRACE_SYSCALL, tracee->pid, 0, 0))
+ return 3;
+
+ goto again;
+ }
+ }
+
+#ifdef __aarch64__
+
+ if (aarch64_get_regs (tracee->pid, &original))
+ return 3;
+
+#else /* !__aarch64__ */
+
+ /* The system call has now completed. Get the registers again. */
+
+ if (ptrace (PTRACE_GETREGS, tracee->pid, NULL,
+ &original))
+ return 3;
+
+#endif /* __aarch64__ */
+
+ *regs = original;
+
+ /* Upon failure, wait for the next system call and return
+ success. */
+
+ if (original.SYSCALL_RET_REG)
+ {
+ /* Restore the original stack pointer. */
+ regs->STACK_POINTER = sp;
+
+#ifdef __aarch64__
+ aarch64_set_regs (tracee->pid, regs, false);
+#else /* !__aarch64__ */
+ ptrace (PTRACE_SETREGS, tracee->pid, NULL, regs);
+#endif /* __aarch64__ */
+
+ goto exec_failure;
+ }
+
+ /* Write the loader area to the stack, followed by its size and the
+ original stack pointer. */
+
+ loader = user_alloca (tracee, &original, regs,
+ size + sizeof loader * 2);
+ if (!loader)
+ return 3;
+
+ size1 = size;
+
+#ifndef STACK_GROWS_DOWNWARDS
+
+ NOT_IMPLEMENTED;
+
+#else /* STACK_GROWS_DOWNWARDS */
+
+ if (user_copy (tracee, (unsigned char *) area,
+ loader + sizeof size1 * 2, size)
+ || user_copy (tracee, (unsigned char *) &size1,
+ loader + sizeof size1, sizeof size1))
+ return 3;
+
+ size1 = original.STACK_POINTER;
+
+ if (user_copy (tracee, (unsigned char *) &size1,
+ loader, sizeof size1))
+ return 3;
+
+#endif /* STACK_GROWS_DOWNWARDS */
+
+ /* Continue. */
+ if (ptrace (PTRACE_SYSCALL, tracee->pid, 0, 0))
+ return 3;
+
+ return 0;
+
+ exec_failure:
+ return 3;
+}
+
+
+
+/* Define replacements for required string functions. */
+
+#if !defined HAVE_STPCPY || !defined HAVE_DECL_STPCPY
+
+/* Copy SRC to DEST, returning the address of the terminating '\0' in
+ DEST. */
+
+static char *
+rpl_stpcpy (char *dest, const char *src)
+{
+ register char *d;
+ register const char *s;
+
+ d = dest;
+ s = src;
+
+ do
+ *d++ = *s;
+ while (*s++ != '\0');
+
+ return d - 1;
+}
+
+#define stpcpy rpl_stpcpy
+#endif /* !defined HAVE_STPCPY || !defined HAVE_DECL_STPCPY */
+
+
+
+/* Modify BUFFER, of size SIZE, so that it holds the absolute name of
+ the file identified by BUFFER, relative to the current working
+ directory of TRACEE if FD be AT_FDCWD, or the file referenced by FD
+ otherwise.
+
+ Value is 1 if this information is unavailable (of which there are
+ variety of causes), and 0 on success. */
+
+static int
+canon_path (struct exec_tracee *tracee, int fd, char *buffer,
+ ptrdiff_t size)
+{
+ char link[sizeof "/proc//fd/" + 48], *p; /* Or /proc/pid/cwd. */
+ char target[PATH_MAX];
+ ssize_t rc, length;
+
+ if (buffer[0] == '/')
+ /* Absolute file name; return immediately. */
+ return 0;
+ else if (fd == AT_FDCWD)
+ {
+ p = stpcpy (link, "/proc/");
+ p = format_pid (p, tracee->pid);
+ stpcpy (p, "/cwd");
+ }
+ else if (fd < 0)
+ /* Invalid file descriptor. */
+ return 1;
+ else
+ {
+ p = stpcpy (link, "/proc/");
+ p = format_pid (p, tracee->pid);
+ p = stpcpy (p, "/fd/");
+ format_pid (p, fd);
+ }
+
+ /* Read LINK's target, and should it be oversized, punt. */
+ rc = readlink (link, target, PATH_MAX);
+ if (rc < 0 || rc >= PATH_MAX)
+ return 1;
+
+ /* Consider the amount by which BUFFER's existing contents should be
+ displaced. */
+
+ length = strlen (buffer) + 1;
+ if ((length + rc + (target[rc - 1] != '/')) > size)
+ /* Punt if this would overflow. */
+ return 1;
+
+ memmove ((buffer + rc + (target[rc - 1] != '/')),
+ buffer, length);
+
+ /* Copy the new file name into BUFFER. */
+ memcpy (buffer, target, rc);
+
+ /* Insert separator in between if need be. */
+ if (target[rc - 1] != '/')
+ buffer[rc] = '/';
+
+ return 0;
+}
+
+/* Handle a `readlink' or `readlinkat' system call.
+
+ CALLNO is the system call number, and REGS are the current user
+ registers of the TRACEE.
+
+ If the file name specified in either a `readlink' or `readlinkat'
+ system call is `/proc/self/exe', write the name of the executable
+ being run into the buffer specified in the system call. Do not
+ handle relative file names at the moment.
+
+ Return the number of bytes written to the tracee's buffer in
+ *RESULT.
+
+ Value is 0 upon success. Value is 1 upon failure, and 2 if the
+ system call has been emulated. */
+
+static int
+handle_readlinkat (USER_WORD callno, USER_REGS_STRUCT *regs,
+ struct exec_tracee *tracee, USER_WORD *result)
+{
+#ifdef REENTRANT
+ /* readlinkat cannot be handled specially when the library is built
+ to be reentrant, as the file name information cannot be
+ recorded. */
+ return 0;
+#else /* !REENTRANT */
+
+ char buffer[PATH_MAX + 1];
+ USER_WORD address, return_buffer, size;
+ size_t length;
+ char proc_pid_exe[sizeof "/proc//exe" + 24], *p;
+ int dirfd;
+
+ /* Read the file name. */
+
+#ifdef READLINK_SYSCALL
+ if (callno == READLINK_SYSCALL)
+ {
+ dirfd = AT_FDCWD;
+ address = regs->SYSCALL_ARG_REG;
+ return_buffer = regs->SYSCALL_ARG1_REG;
+ size = regs->SYSCALL_ARG2_REG;
+ }
+ else
+#endif /* READLINK_SYSCALL */
+ {
+ dirfd = (USER_SWORD) regs->SYSCALL_ARG_REG;
+ address = regs->SYSCALL_ARG1_REG;
+ return_buffer = regs->SYSCALL_ARG2_REG;
+ size = regs->SYSCALL_ARG3_REG;
+ }
+
+ read_memory (tracee, buffer, PATH_MAX, address);
+
+ /* Make sure BUFFER is NULL terminated. */
+
+ if (!memchr (buffer, '\0', PATH_MAX))
+ {
+ errno = ENAMETOOLONG;
+ return 1;
+ }
+
+ /* Expand BUFFER into an absolute file name. TODO:
+ AT_SYMLINK_FOLLOW? */
+
+ if (canon_path (tracee, dirfd, buffer, sizeof buffer))
+ return 0;
+
+ /* Now check if the caller is looking for /proc/self/exe or its
+ equivalent with the PID made explicit.
+
+ dirfd can be ignored, as for now only absolute file names are
+ handled. FIXME. */
+
+ p = stpcpy (proc_pid_exe, "/proc/");
+ p = format_pid (p, tracee->pid);
+ stpcpy (p, "/exe");
+
+ if ((strcmp (buffer, "/proc/self/exe")
+ && strcmp (buffer, proc_pid_exe))
+ || !tracee->exec_file)
+ return 0;
+
+ /* Copy over tracee->exec_file. Truncate it to PATH_MAX, length, or
+ size, whichever is smaller. */
+
+ length = strlen (tracee->exec_file);
+ length = MIN (size, MIN (PATH_MAX, length));
+ strncpy (buffer, tracee->exec_file, length);
+
+ if (user_copy (tracee, (unsigned char *) buffer,
+ return_buffer, length))
+ {
+ errno = EIO;
+ return 1;
+ }
+
+ *result = length;
+ return 2;
+#endif /* REENTRANT */
+}
+
+/* Handle an `open' or `openat' system call.
+
+ CALLNO is the system call number, and REGS are the current user
+ registers of the TRACEE.
+
+ If the file name specified in such system call is `/proc/self/exe',
+ replace the file name with the executable loaded into the process
+ issuing this system call.
+
+ Value is 0 upon success and 1 upon failure. */
+
+static int
+handle_openat (USER_WORD callno, USER_REGS_STRUCT *regs,
+ struct exec_tracee *tracee, USER_WORD *result)
+{
+#ifdef REENTRANT
+ /* readlinkat cannot be handled specially when the library is built
+ to be reentrant, as the file name information cannot be
+ recorded. */
+ return 0;
+#else /* !REENTRANT */
+ char buffer[PATH_MAX + 1];
+ USER_WORD address;
+ size_t length;
+ USER_REGS_STRUCT original;
+ char proc_pid_exe[sizeof "/proc//exe" + 24], *p;
+ int dirfd;
+
+ /* Read the file name. */
+
+#ifdef OPEN_SYSCALL
+ if (callno == OPEN_SYSCALL)
+ {
+ dirfd = AT_FDCWD;
+ address = regs->SYSCALL_ARG_REG;
+ }
+ else
+#endif /* OPEN_SYSCALL */
+ {
+ dirfd = (USER_SWORD) regs->SYSCALL_ARG_REG;
+ address = regs->SYSCALL_ARG1_REG;
+ }
+
+ /* Read the file name into the buffer and verify that it is NULL
+ terminated. */
+ read_memory (tracee, buffer, PATH_MAX, address);
+
+ if (!memchr (buffer, '\0', PATH_MAX))
+ {
+ errno = ENAMETOOLONG;
+ return 1;
+ }
+
+ /* Expand BUFFER into an absolute file name. TODO:
+ AT_SYMLINK_FOLLOW? */
+
+ if (canon_path (tracee, dirfd, buffer, sizeof buffer))
+ return 0;
+
+ /* Now check if the caller is looking for /proc/self/exe or its
+ equivalent with the PID made explicit.
+
+ dirfd can be ignored, as for now only absolute file names are
+ handled. FIXME. */
+
+ p = stpcpy (proc_pid_exe, "/proc/");
+ p = format_pid (p, tracee->pid);
+ stpcpy (p, "/exe");
+
+ if ((strcmp (buffer, "/proc/self/exe")
+ && strcmp (buffer, proc_pid_exe))
+ || !tracee->exec_file)
+ return 0;
+
+ /* Copy over tracee->exec_file. This doesn't correctly handle the
+ scenario where tracee->exec_file is longer than PATH_MAX, but
+ that has yet to be encountered in practice. */
+
+ original = *regs;
+ length = strlen (tracee->exec_file);
+ address = user_alloca (tracee, &original, regs, length + 1);
+
+ if (!address
+ || user_copy (tracee, (unsigned char *) tracee->exec_file,
+ address, length))
+ goto fail;
+
+ /* Replace the file name buffer with ADDRESS. */
+
+#ifdef OPEN_SYSCALL
+ if (callno == OPEN_SYSCALL)
+ regs->SYSCALL_ARG_REG = address;
+ else
+#endif /* OPEN_SYSCALL */
+ regs->SYSCALL_ARG1_REG = address;
+
+#ifdef __aarch64__
+ if (aarch64_set_regs (tracee->pid, regs, false))
+ goto fail;
+#else /* !__aarch64__ */
+ if (ptrace (PTRACE_SETREGS, tracee->pid, NULL, regs))
+ goto fail;
+#endif /* __aarch64__ */
+
+ /* Resume the system call. */
+ return 0;
+
+ fail:
+ errno = EIO;
+ return 1;
+#endif /* REENTRANT */
+}
+
+/* Process the system call at which TRACEE is stopped. If the system
+ call is not known or not exec, send TRACEE on its way. Otherwise,
+ rewrite it to load the loader and perform an appropriate action. */
+
+static void
+process_system_call (struct exec_tracee *tracee)
+{
+ USER_REGS_STRUCT regs;
+ int rc, wstatus, save_errno;
+ USER_WORD callno, sp;
+ USER_WORD result;
+ bool reporting_error;
+
+#ifdef __aarch64__
+ rc = aarch64_get_regs (tracee->pid, &regs);
+#else /* !__aarch64__ */
+ rc = ptrace (PTRACE_GETREGS, tracee->pid, NULL,
+ &regs);
+#endif /* __aarch64__ */
+
+ /* TODO: what to do if this fails? */
+ if (rc < 0)
+ return;
+
+ /* Save the stack pointer. */
+ sp = regs.STACK_POINTER;
+
+ /* Now dispatch based on the system call. */
+ callno = regs.SYSCALL_NUM_REG;
+ switch (callno)
+ {
+ case EXEC_SYSCALL:
+
+ /* exec system calls should be handled synchronously. */
+ assert (!tracee->waiting_for_syscall);
+ rc = handle_exec (tracee, &regs);
+
+ switch (rc)
+ {
+ case 3:
+ /* It's too late to do anything about this error,. */
+ break;
+
+ case 2:
+ /* The process has gone away. */
+ remove_tracee (tracee);
+ break;
+
+ case 1:
+ /* An error has occurred; errno is set to the error. */
+ goto report_syscall_error;
+ }
+
+ break;
+
+#ifdef READLINK_SYSCALL
+ case READLINK_SYSCALL:
+#endif /* READLINK_SYSCALL */
+ case READLINKAT_SYSCALL:
+
+ /* This system call is already in progress if
+ TRACEE->waiting_for_syscall is true. */
+
+ if (!tracee->waiting_for_syscall)
+ {
+ /* Handle this readlinkat system call. */
+ rc = handle_readlinkat (callno, &regs, tracee,
+ &result);
+
+ /* rc means the same as in `handle_exec'. */
+
+ if (rc == 1)
+ goto report_syscall_error;
+ else if (rc == 2)
+ goto emulate_syscall;
+ }
+
+ goto continue_syscall;
+
+#ifdef OPEN_SYSCALL
+ case OPEN_SYSCALL:
+#endif /* OPEN_SYSCALL */
+ case OPENAT_SYSCALL:
+
+ /* This system call is already in progress if
+ TRACEE->waiting_for_syscall is true. */
+
+ if (!tracee->waiting_for_syscall)
+ {
+ /* Handle this open system call. */
+ rc = handle_openat (callno, &regs, tracee, &result);
+
+ /* rc means the same as in `handle_exec', except that `open'
+ is never emulated. */
+
+ if (rc == 1)
+ goto report_syscall_error;
+
+ /* The stack pointer must be restored after it was modified
+ by `user_alloca'; record sp in TRACEE, which will be
+ restored after this system call completes. */
+ tracee->sp = sp;
+ }
+ else
+ {
+ /* Restore that stack pointer. */
+ regs.STACK_POINTER = tracee->sp;
+
+#ifdef __aarch64__
+ if (aarch64_set_regs (tracee->pid, &regs, true))
+ return;
+#else /* !__aarch64__ */
+ if (ptrace (PTRACE_SETREGS, tracee->pid, NULL, &regs))
+ return;
+#endif /* __aarch64__ */
+ }
+
+ /* Fallthrough. */
+
+ default:
+ continue_syscall:
+ /* Don't wait for the system call to finish; instead, the system
+ will DTRT upon the next call to PTRACE_SYSCALL after the
+ syscall-trap signal is delivered. */
+
+ rc = ptrace (PTRACE_SYSCALL, tracee->pid,
+ NULL, NULL);
+ if (rc < 0)
+ return;
+
+ tracee->waiting_for_syscall = !tracee->waiting_for_syscall;
+ }
+
+ return;
+
+ report_syscall_error:
+ reporting_error = true;
+ goto common;
+
+ emulate_syscall:
+ reporting_error = false;
+ common:
+
+ /* Reporting an error or emulating a system call works by setting
+ the system call number to -1, letting it continue, and then
+ substituting errno for ENOSYS in the case of an error.
+
+ Make sure that the stack pointer is restored to its original
+ position upon exit, or bad things can happen. */
+
+ /* First, save errno; system calls below will clobber it. */
+ save_errno = errno;
+
+ regs.SYSCALL_NUM_REG = -1;
+ regs.STACK_POINTER = sp;
+
+#ifdef __aarch64__
+ if (aarch64_set_regs (tracee->pid, &regs, true))
+ return;
+#else /* !__aarch64__ */
+
+#ifdef __arm__
+ /* On ARM systems, a special request is used to update the system
+ call number as known to the kernel. In addition, the system call
+ number must be valid, so use `tuxcall'. Hopefully, nobody will
+ run this on a kernel with Tux. */
+
+ if (ptrace (PTRACE_SET_SYSCALL, tracee->pid, NULL, 222))
+ return;
+#endif /* __arm__ */
+
+ if (ptrace (PTRACE_SETREGS, tracee->pid, NULL, &regs))
+ return;
+#endif /* __aarch64__ */
+
+ /* Do this invalid system call. */
+ if (ptrace (PTRACE_SYSCALL, tracee->pid, NULL, NULL))
+ return;
+
+ again1:
+ rc = waitpid (tracee->pid, &wstatus, __WALL);
+ if (rc == -1 && errno == EINTR)
+ goto again1;
+
+ /* Return if waitpid fails. */
+
+ if (rc == -1)
+ return;
+
+ /* If the process received a signal, see if the signal is SIGSYS and
+ from seccomp. If so, discard it. */
+
+ if (WIFSTOPPED (wstatus))
+ {
+ rc = check_signal (tracee, wstatus);
+
+ if (rc == -1)
+ return;
+ else if (rc)
+ goto again1;
+ }
+
+ if (!WIFSTOPPED (wstatus))
+ /* The process has been killed in response to a signal. In this
+ case, simply unlink the tracee and return. */
+ remove_tracee (tracee);
+ else if (reporting_error)
+ {
+#ifdef __mips__
+ /* MIPS systems place errno in v0 and set a3 to 1. */
+ regs.gregs[2] = save_errno;
+ regs.gregs[7] = 1;
+#else /* !__mips__ */
+ regs.SYSCALL_RET_REG = -save_errno;
+#endif /* __mips__ */
+
+ /* Report errno. */
+#ifdef __aarch64__
+ aarch64_set_regs (tracee->pid, &regs, false);
+#else /* !__aarch64__ */
+ ptrace (PTRACE_SETREGS, tracee->pid, NULL, &regs);
+#endif /* __aarch64__ */
+
+ /* Now wait for the next system call to happen. */
+ ptrace (PTRACE_SYSCALL, tracee->pid, NULL, NULL);
+ }
+ else
+ {
+ /* No error is being reported. Return the result in the
+ appropriate registers. */
+
+#ifdef __mips__
+ /* MIPS systems place errno in v0 and set a3 to 1. */
+ regs.gregs[2] = result;
+ regs.gregs[7] = 0;
+#else /* !__mips__ */
+ regs.SYSCALL_RET_REG = result;
+#endif /* __mips__ */
+
+ /* Report errno. */
+#ifdef __aarch64__
+ aarch64_set_regs (tracee->pid, &regs, false);
+#else /* !__aarch64__ */
+ ptrace (PTRACE_SETREGS, tracee->pid, NULL, &regs);
+#endif /* __aarch64__ */
+
+ /* Now wait for the next system call to happen. */
+ ptrace (PTRACE_SYSCALL, tracee->pid, NULL, NULL);
+ }
+}
+
+
+
+/* Like `execve', but asks the parent to begin tracing this thread.
+ Fail if tracing is unsuccessful. */
+
+int
+tracing_execve (const char *file, char *const *argv,
+ char *const *envp)
+{
+ int rc;
+
+ /* Start tracing self. */
+ rc = ptrace (PTRACE_TRACEME, 0, NULL, NULL);
+ if (rc)
+ return rc;
+
+ /* Notify the parent to enter signal-delivery-stop. */
+ raise (SIGSTOP);
+ return execve (file, argv, envp);
+}
+
+/* Wait for PID to trace itself, and make a record of that process.
+ Value is 1 or 2 upon failure, 0 otherwise. Make sure that SIGCHLD
+ is blocked around calls to this function.
+
+ If failure occurs because PID exited, value is 2; upon any other
+ kind of failure, value is 1. */
+
+int
+after_fork (pid_t pid)
+{
+ int wstatus, rc, flags;
+ struct exec_tracee *tracee;
+
+ /* First, wait for something to happen to PID. */
+ again:
+ rc = waitpid (pid, &wstatus, __WALL);
+ if (rc != pid && errno == EINTR)
+ goto again;
+
+ if (rc != pid)
+ return 1;
+
+ /* If the child exited (or in general wasn't traced), return 2. */
+
+ if (!WIFSTOPPED (wstatus))
+ return 2;
+
+ /* Apply required options to the child, so that the kernel
+ automatically traces children and makes it easy to differentiate
+ between system call traps and other kinds of traps. */
+
+ flags = PTRACE_O_TRACECLONE;
+ flags |= PTRACE_O_TRACEVFORK;
+ flags |= PTRACE_O_TRACEFORK;
+ flags |= PTRACE_O_TRACESYSGOOD;
+ flags |= PTRACE_O_TRACEEXIT;
+
+ rc = ptrace (PTRACE_SETOPTIONS, pid, 0, flags);
+
+ if (rc)
+ {
+ /* If the kernel can't trace child processes upon creation and
+ exit, then it can't work reliably. */
+ ptrace (PTRACE_DETACH, pid, 0, 0);
+ return 1;
+ }
+
+ /* Request that the child stop upon the next system call. */
+ rc = ptrace (PTRACE_SYSCALL, pid, 0, 0);
+ if (rc)
+ return 1;
+
+ /* Enter the child in `tracing_processes'. */
+
+ if (free_tracees)
+ {
+ tracee = free_tracees;
+ free_tracees = free_tracees->next;
+ }
+ else
+ tracee = malloc (sizeof *tracee);
+
+ if (!tracee)
+ return 1;
+
+ tracee->pid = pid;
+ tracee->next = tracing_processes;
+ tracee->waiting_for_syscall = false;
+ tracee->new_child = false;
+#ifndef REENTRANT
+ tracee->exec_file = NULL;
+#endif /* REENTRANT */
+ tracing_processes = tracee;
+ return 0;
+}
+
+/* Wait for a child process to exit, like `waitpid'. However, if a
+ child stops to perform a system call, send it on its way and return
+ -1. OPTIONS must not contain WUNTRACED. */
+
+pid_t
+exec_waitpid (pid_t pid, int *wstatus, int options)
+{
+ int status;
+ struct exec_tracee *tracee;
+ siginfo_t siginfo;
+
+ pid = waitpid (pid, &status, options | __WALL);
+ if (pid < 0)
+ return pid;
+
+ /* Copy status into *WSTATUS if specified. */
+ if (wstatus)
+ *wstatus = status;
+
+ /* WIFSTOPPED (status) means that the process has been stopped in
+ response to a system call. Find its tracee and process the
+ system call. */
+
+ if (WIFSTOPPED (status))
+ {
+ tracee = find_tracee (pid);
+
+ if (!tracee || tracee->new_child)
+ {
+ if (WSTOPSIG (status) == SIGSTOP)
+ /* A new process has been created and stopped. Record
+ it now. */
+ handle_clone (tracee, pid);
+
+ return -1;
+ }
+
+ /* Now extract the stop signal, including ptrace event bits. */
+ status &= 0xfff00;
+ status = status >> 8;
+
+ switch (status)
+ {
+ case SIGTRAP:
+ /* Now, use PTRACE_GETSIGINFO to determine whether or not the
+ signal was delivered in response to a system call. */
+
+ if (ptrace (PTRACE_GETSIGINFO, pid, 0, &siginfo))
+ return -1;
+
+ if (!syscall_trap_p (&siginfo))
+ {
+ if (siginfo.si_code < 0)
+ /* SIGTRAP delivered from userspace. Pass it on. */
+ ptrace (PTRACE_SYSCALL, pid, 0, SIGTRAP);
+ else
+ ptrace (PTRACE_SYSCALL, pid, 0, 0);
+
+ return -1;
+ }
+
+ case SIGTRAP | 0x80: /* SIGTRAP | 0x80 specifically refers to
+ system call traps. */
+ /* Otherwise, process the system call and continue waiting. */
+ process_system_call (tracee);
+ return -1;
+
+ case SIGTRAP | (PTRACE_EVENT_EXIT << 8):
+ /* The tracee has exited. Make it finish correctly. */
+ ptrace (PTRACE_SYSCALL, pid, 0, 0);
+ remove_tracee (tracee);
+ return -1;
+
+ case SIGTRAP | (PTRACE_EVENT_FORK << 8):
+ case SIGTRAP | (PTRACE_EVENT_VFORK << 8):
+ case SIGTRAP | (PTRACE_EVENT_CLONE << 8):
+
+ /* Both PTRACE_EVENT_CLONE and SIGSTOP must arrive before a
+ process is continued. Otherwise, its parent's cmdline
+ cannot be obtained and propagated.
+
+ If the PID of the new process is currently not being
+ traced, create a new tracee. Set `new_child' to true,
+ and copy over the old command line in preparation for a
+ SIGSTOP signal being delivered to it.
+
+ Otherwise, start the tracee running until the next
+ syscall. */
+
+ handle_clone_prepare (tracee);
+
+ /* These events are handled by tracing SIGSTOP signals sent
+ to unknown tracees. Make sure not to pass through
+ status, as there's no signal really being delivered. */
+ ptrace (PTRACE_SYSCALL, pid, 0, 0);
+ return -1;
+
+#ifdef SIGSYS
+ case SIGSYS:
+ if (ptrace (PTRACE_GETSIGINFO, pid, 0, &siginfo))
+ return -1;
+
+ /* Continue the process until the next syscall, but don't
+ pass through the signal if an emulated syscall led to
+ it. */
+#ifdef HAVE_SIGINFO_T_SI_SYSCALL
+#ifndef __arm__
+ ptrace (PTRACE_SYSCALL, pid, 0, ((siginfo.si_code == SYS_SECCOMP
+ && siginfo.si_syscall == -1)
+ ? 0 : status));
+#else /* __arm__ */
+ ptrace (PTRACE_SYSCALL, pid, 0, ((siginfo.si_code == SYS_SECCOMP
+ && siginfo.si_syscall == 222)
+ ? 0 : status));
+#endif /* !__arm__ */
+#else /* !HAVE_SIGINFO_T_SI_SYSCALL */
+ /* Drop this signal, since what caused it is unknown. */
+ ptrace (PTRACE_SYSCALL, pid, 0, 0);
+#endif /* HAVE_SIGINFO_T_SI_SYSCALL */
+ return -1;
+#endif /* SIGSYS */
+
+ default:
+ /* Continue the process until the next syscall. */
+ ptrace (PTRACE_SYSCALL, pid, 0, status);
+ return -1;
+ }
+ }
+ else
+ {
+ /* The process has exited. Unlink the associated tracee. */
+ tracee = find_tracee (pid);
+
+ if (tracee)
+ remove_tracee (tracee);
+
+ return pid;
+ }
+}
+
+
+
+/* Initialize the exec library. LOADER should be the file name of the
+ loader binary; it is not copied. */
+
+void
+exec_init (const char *loader)
+{
+ loader_name = loader;
+}
diff --git a/java/AndroidManifest.xml.in b/java/AndroidManifest.xml.in
new file mode 100644
index 00000000000..563914fb02c
--- /dev/null
+++ b/java/AndroidManifest.xml.in
@@ -0,0 +1,335 @@
+<!-- @configure_input@
+
+Copyright (C) 2023-2024 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 <https://www.gnu.org/licenses/>. -->
+
+<!-- targetSandboxVersion must be 1. Otherwise, fascist security
+ restrictions prevent Emacs from making HTTP connections. -->
+
+<manifest xmlns:android="http://schemas.android.com/apk/res/android"
+ package="org.gnu.emacs"
+ android:targetSandboxVersion="1"
+ android:installLocation="auto"
+ android:requestLegacyExternalStorage="true"
+ @ANDROID_SHARED_USER_ID@
+ @ANDROID_SHARED_USER_NAME@
+ android:versionCode="@emacs_major_version@"
+ android:versionName="@version@">
+
+ <!-- Paste in every permission in existence so Emacs can do
+ anything. -->
+
+ <uses-permission android:name="android.permission.READ_CONTACTS" />
+ <uses-permission android:name="android.permission.WRITE_CONTACTS" />
+ <uses-permission android:name="android.permission.VIBRATE" />
+ <uses-permission android:name="android.permission.ACCESS_COARSE_LOCATION" />
+ <uses-permission android:name="android.permission.ACCESS_NETWORK_STATE" />
+ <uses-permission android:name="android.permission.INTERNET" />
+ <uses-permission android:name="android.permission.SET_WALLPAPER" />
+ <uses-permission android:name="android.permission.READ_CALENDAR" />
+ <uses-permission android:name="android.permission.WRITE_CALENDAR" />
+ <!-- Despite the claim that WRITE_EXTERNAL_STORAGE also covers
+ reading from external storage, specifying READ_EXTERNAL_STORAGE
+ seems to still be necessary on some versions of Android.
+ (bug#64445) -->
+ <uses-permission android:name="android.permission.READ_EXTERNAL_STORAGE" />
+ <uses-permission android:name="android.permission.WRITE_EXTERNAL_STORAGE" />
+ <uses-permission android:name="android.permission.SEND_SMS" />
+ <uses-permission android:name="android.permission.RECEIVE_SMS" />
+ <uses-permission android:name="android.permission.RECEIVE_MMS"/>
+ <uses-permission android:name="android.permission.WRITE_SMS"/>
+ <uses-permission android:name="android.permission.READ_SMS"/>
+ <uses-permission android:name="android.permission.NFC" />
+ <uses-permission android:name="android.permission.TRANSMIT_IR" />
+ <uses-permission android:name="android.permission.READ_PHONE_STATE"/>
+ <uses-permission android:name="android.permission.WAKE_LOCK"/>
+ <uses-permission android:name="android.permission.FOREGROUND_SERVICE"/>
+ <uses-permission android:name="android.permission.REQUEST_INSTALL_PACKAGES"/>
+ <uses-permission android:name="android.permission.REQUEST_DELETE_PACKAGES"/>
+ <uses-permission android:name="android.permission.SYSTEM_ALERT_WINDOW"/>
+ <uses-permission android:name="android.permission.RECORD_AUDIO" />
+ <uses-permission android:name="android.permission.CAMERA" />
+
+ <uses-permission android:name="android.permission.ACCEPT_HANDOVER" />
+ <uses-permission android:name="android.permission.ACCESS_BACKGROUND_LOCATION" />
+ <uses-permission android:name="android.permission.ACCESS_FINE_LOCATION" />
+ <uses-permission android:name="android.permission.ACCESS_MEDIA_LOCATION" />
+ <uses-permission android:name="android.permission.ACCESS_NOTIFICATIONS" />
+ <uses-permission android:name="android.permission.ACTIVITY_RECOGNITION" />
+ <uses-permission android:name="android.permission.ANSWER_PHONE_CALLS" />
+ <uses-permission android:name="android.permission.BLUETOOTH_ADVERTISE" />
+ <uses-permission android:name="android.permission.BLUETOOTH_CONNECT" />
+ <uses-permission android:name="android.permission.BLUETOOTH_SCAN" />
+ <uses-permission android:name="android.permission.BODY_SENSORS" />
+ <uses-permission android:name="android.permission.BODY_SENSORS_BACKGROUND" />
+ <uses-permission android:name="android.permission.CALL_PHONE" />
+ <uses-permission android:name="android.permission.CAPTURE_CONSENTLESS_BUGREPORT_ON_USERDEBUG_BUILD" />
+ <uses-permission android:name="android.permission.GET_ACCOUNTS" />
+ <uses-permission android:name="android.permission.INSTANT_APP_FOREGROUND_SERVICE" />
+ <uses-permission android:name="android.permission.INTERACT_ACROSS_PROFILES" />
+ <uses-permission android:name="android.permission.LOADER_USAGE_STATS" />
+ <uses-permission android:name="android.permission.MANAGE_IPSEC_TUNNELS" />
+ <uses-permission android:name="android.permission.MANAGE_MEDIA" />
+ <uses-permission android:name="android.permission.MANAGE_ONGOING_CALLS" />
+ <uses-permission android:name="android.permission.NEARBY_WIFI_DEVICES" />
+ <uses-permission android:name="android.permission.PACKAGE_USAGE_STATS" />
+ <uses-permission android:name="android.permission.PROCESS_OUTGOING_CALLS" />
+ <uses-permission android:name="android.permission.READ_CALL_LOG" />
+ <uses-permission android:name="android.permission.READ_CELL_BROADCASTS" />
+ <uses-permission android:name="android.permission.READ_MEDIA_AUDIO" />
+ <uses-permission android:name="android.permission.READ_MEDIA_IMAGES" />
+ <uses-permission android:name="android.permission.READ_MEDIA_VIDEO" />
+ <uses-permission android:name="android.permission.READ_MEDIA_VISUAL_USER_SELECTED" />
+ <uses-permission android:name="android.permission.READ_PHONE_NUMBERS" />
+ <uses-permission android:name="android.permission.READ_SMS" />
+ <uses-permission android:name="android.permission.RECEIVE_MMS" />
+ <uses-permission android:name="android.permission.RECEIVE_WAP_PUSH" />
+ <uses-permission android:name="android.permission.SCHEDULE_EXACT_ALARM" />
+ <uses-permission android:name="android.permission.SMS_FINANCIAL_TRANSACTIONS" />
+ <uses-permission android:name="android.permission.TURN_SCREEN_ON" />
+ <uses-permission android:name="android.permission.USE_FULL_SCREEN_INTENT" />
+ <uses-permission android:name="android.permission.USE_ICC_AUTH_WITH_DEVICE_IDENTIFIER" />
+ <uses-permission android:name="android.permission.USE_SIP" />
+ <uses-permission android:name="android.permission.UWB_RANGING" />
+ <uses-permission android:name="android.permission.WIFI_ACCESS_COEX_UNSAFE_CHANNELS" />
+ <uses-permission android:name="android.permission.WRITE_CALL_LOG" />
+ <uses-permission android:name="android.permission.WRITE_SETTINGS" />
+
+ <uses-permission android:name="android.permission.ACCESS_ADSERVICES_AD_ID" />
+ <uses-permission android:name="android.permission.ACCESS_ADSERVICES_ATTRIBUTION" />
+ <uses-permission android:name="android.permission.ACCESS_ADSERVICES_CUSTOM_AUDIENCE" />
+ <uses-permission android:name="android.permission.ACCESS_ADSERVICES_TOPICS" />
+ <uses-permission android:name="android.permission.ACCESS_LOCATION_EXTRA_COMMANDS" />
+ <uses-permission android:name="android.permission.ACCESS_NOTIFICATION_POLICY" />
+ <uses-permission android:name="android.permission.ACCESS_WIFI_STATE" />
+ <uses-permission android:name="android.permission.AUTHENTICATE_ACCOUNTS" />
+ <uses-permission android:name="android.permission.BLUETOOTH" />
+ <uses-permission android:name="android.permission.BLUETOOTH_ADMIN" />
+ <uses-permission android:name="android.permission.BROADCAST_STICKY" />
+ <uses-permission android:name="android.permission.CHANGE_NETWORK_STATE" />
+ <uses-permission android:name="android.permission.CHANGE_WIFI_MULTICAST_STATE" />
+ <uses-permission android:name="android.permission.CHANGE_WIFI_STATE" />
+ <uses-permission android:name="android.permission.CREDENTIAL_MANAGER_QUERY_CANDIDATE_CREDENTIALS" />
+ <uses-permission android:name="android.permission.CREDENTIAL_MANAGER_SET_ALLOWED_PROVIDERS" />
+ <uses-permission android:name="android.permission.CREDENTIAL_MANAGER_SET_ORIGIN" />
+ <uses-permission android:name="android.permission.DELIVER_COMPANION_MESSAGES" />
+ <uses-permission android:name="android.permission.DETECT_SCREEN_CAPTURE" />
+ <uses-permission android:name="android.permission.DISABLE_KEYGUARD" />
+ <uses-permission android:name="android.permission.ENFORCE_UPDATE_OWNERSHIP" />
+ <uses-permission android:name="android.permission.EXPAND_STATUS_BAR" />
+ <uses-permission android:name="android.permission.FLASHLIGHT" />
+ <uses-permission android:name="android.permission.FOREGROUND_SERVICE_CAMERA" />
+ <uses-permission android:name="android.permission.FOREGROUND_SERVICE_CONNECTED_DEVICE" />
+ <uses-permission android:name="android.permission.FOREGROUND_SERVICE_DATA_SYNC" />
+ <uses-permission android:name="android.permission.FOREGROUND_SERVICE_FILE_MANAGEMENT" />
+ <uses-permission android:name="android.permission.FOREGROUND_SERVICE_HEALTH" />
+ <uses-permission android:name="android.permission.FOREGROUND_SERVICE_LOCATION" />
+ <uses-permission android:name="android.permission.FOREGROUND_SERVICE_MEDIA_PLAYBACK" />
+ <uses-permission android:name="android.permission.FOREGROUND_SERVICE_MEDIA_PROJECTION" />
+ <uses-permission android:name="android.permission.FOREGROUND_SERVICE_MICROPHONE" />
+ <uses-permission android:name="android.permission.FOREGROUND_SERVICE_PHONE_CALL" />
+ <uses-permission android:name="android.permission.FOREGROUND_SERVICE_REMOTE_MESSAGING" />
+ <uses-permission android:name="android.permission.FOREGROUND_SERVICE_SYSTEM_EXEMPTED" />
+ <uses-permission android:name="android.permission.GET_PACKAGE_SIZE" />
+ <uses-permission android:name="android.permission.GET_TASKS" />
+ <uses-permission android:name="android.permission.HIDE_OVERLAY_WINDOWS" />
+ <uses-permission android:name="android.permission.HIGH_SAMPLING_RATE_SENSORS" />
+ <uses-permission android:name="android.permission.KILL_BACKGROUND_PROCESSES" />
+ <uses-permission android:name="android.permission.MANAGE_ACCOUNTS" />
+ <uses-permission android:name="android.permission.MANAGE_OWN_CALLS" />
+ <uses-permission android:name="android.permission.MODIFY_AUDIO_SETTINGS" />
+ <uses-permission android:name="android.permission.NFC_PREFERRED_PAYMENT_INFO" />
+ <uses-permission android:name="android.permission.NFC_TRANSACTION_EVENT" />
+ <uses-permission android:name="android.permission.PERSISTENT_ACTIVITY" />
+ <uses-permission android:name="android.permission.QUERY_ALL_PACKAGES" />
+ <uses-permission android:name="android.permission.READ_BASIC_PHONE_STATE" />
+ <uses-permission android:name="android.permission.READ_INSTALL_SESSIONS" />
+ <uses-permission android:name="android.permission.READ_NEARBY_STREAMING_POLICY" />
+ <uses-permission android:name="android.permission.READ_PROFILE" />
+ <uses-permission android:name="android.permission.READ_SOCIAL_STREAM" />
+ <uses-permission android:name="android.permission.READ_SYNC_SETTINGS" />
+ <uses-permission android:name="android.permission.READ_SYNC_STATS" />
+ <uses-permission android:name="android.permission.READ_USER_DICTIONARY" />
+ <uses-permission android:name="android.permission.RECEIVE_BOOT_COMPLETED" />
+ <uses-permission android:name="android.permission.REORDER_TASKS" />
+ <uses-permission android:name="android.permission.REQUEST_COMPANION_PROFILE_GLASSES" />
+ <uses-permission android:name="android.permission.REQUEST_COMPANION_PROFILE_WATCH" />
+ <uses-permission android:name="android.permission.REQUEST_COMPANION_RUN_IN_BACKGROUND" />
+ <uses-permission android:name="android.permission.REQUEST_COMPANION_START_FOREGROUND_SERVICES_FROM_BACKGROUND" />
+ <uses-permission android:name="android.permission.REQUEST_COMPANION_USE_DATA_IN_BACKGROUND" />
+ <uses-permission android:name="android.permission.REQUEST_IGNORE_BATTERY_OPTIMIZATIONS" />
+ <uses-permission android:name="android.permission.REQUEST_OBSERVE_COMPANION_DEVICE_PRESENCE" />
+ <uses-permission android:name="android.permission.REQUEST_PASSWORD_COMPLEXITY" />
+ <uses-permission android:name="android.permission.RESTART_PACKAGES" />
+ <uses-permission android:name="android.permission.RUN_USER_INITIATED_JOBS" />
+ <uses-permission android:name="android.permission.SET_WALLPAPER_HINTS" />
+ <uses-permission android:name="android.permission.SUBSCRIBED_FEEDS_READ" />
+ <uses-permission android:name="android.permission.SUBSCRIBED_FEEDS_WRITE" />
+ <uses-permission android:name="android.permission.UPDATE_PACKAGES_WITHOUT_USER_ACTION" />
+ <uses-permission android:name="android.permission.USE_BIOMETRIC" />
+ <uses-permission android:name="android.permission.USE_CREDENTIALS" />
+ <uses-permission android:name="android.permission.USE_EXACT_ALARM" />
+ <uses-permission android:name="android.permission.USE_FINGERPRINT" />
+ <uses-permission android:name="android.permission.WRITE_PROFILE" />
+ <uses-permission android:name="android.permission.WRITE_SMS" />
+ <uses-permission android:name="android.permission.WRITE_SOCIAL_STREAM" />
+ <uses-permission android:name="android.permission.WRITE_SYNC_SETTINGS" />
+ <uses-permission android:name="android.permission.WRITE_USER_DICTIONARY" />
+
+ <!-- This is required on Android 11 or later to access /sdcard. -->
+
+ <uses-permission android:name="android.permission.MANAGE_EXTERNAL_STORAGE"/>
+
+ <!-- And under Android 13 or later to post desktop
+ notifications. -->
+
+ <uses-permission android:name="android.permission.POST_NOTIFICATIONS"/>
+
+ <!-- Under Android 14 or later to run within the background. -->
+
+ <uses-permission android:name="android.permission.FOREGROUND_SERVICE_SPECIAL_USE"/>
+
+ <uses-sdk android:minSdkVersion="@ANDROID_MIN_SDK@"
+ android:targetSdkVersion="34"/>
+
+ <application android:name="org.gnu.emacs.EmacsApplication"
+ android:label="Emacs"
+ android:icon="@mipmap/emacs_icon"
+ android:hardwareAccelerated="true"
+ android:supportsRtl="true"
+ android:theme="@style/EmacsStyle"
+ android:debuggable="@ANDROID_DEBUGGABLE@"
+ android:allowBackup="true"
+ android:extractNativeLibs="true">
+
+ <activity android:name="org.gnu.emacs.EmacsActivity"
+ android:launchMode="singleInstance"
+ android:taskAffinity="emacs.primary_frame"
+ android:windowSoftInputMode="adjustResize"
+ android:exported="true"
+ android:configChanges="orientation|screenSize|screenLayout|keyboardHidden|locale|fontScale">
+ <intent-filter>
+ <action android:name="android.intent.action.MAIN" />
+ <category android:name="android.intent.category.DEFAULT" />
+ <category android:name="android.intent.category.LAUNCHER" />
+ </intent-filter>
+ </activity>
+
+ <activity android:name="org.gnu.emacs.EmacsOpenActivity"
+ android:taskAffinity="emacs.open_dialog"
+ android:excludeFromRecents="true"
+ android:exported="true">
+
+ <!-- Allow Emacs to open all kinds of files known to Android. -->
+
+ <intent-filter>
+ <action android:name="android.intent.action.VIEW"/>
+ <action android:name="android.intent.action.EDIT"/>
+ <action android:name="android.intent.action.PICK"/>
+ <category android:name="android.intent.category.DEFAULT"/>
+ <!-- Don't offer to start Emacs for URLs that designate
+ resources other than files. -->
+ <data android:mimeType="*/*" android:scheme="file"/>
+ <data android:mimeType="*/*" android:scheme="content"/>
+ </intent-filter>
+
+ <!-- Facilitate opening org-protocol:// URLs as well, the same
+ way emacsclient.desktop does. -->
+
+ <intent-filter>
+ <action android:name="android.intent.action.VIEW"/>
+ <category android:name="android.intent.category.DEFAULT"/>
+ <category android:name="android.intent.category.BROWSABLE"/>
+ <data android:scheme="org-protocol"/>
+ </intent-filter>
+
+ <!-- And also mailto links. -->
+
+ <intent-filter>
+ <action android:name="android.intent.action.VIEW"/>
+ <category android:name="android.intent.category.DEFAULT"/>
+ <category android:name="android.intent.category.BROWSABLE"/>
+ <data android:scheme="mailto"/>
+ </intent-filter>
+
+ <intent-filter>
+ <action android:name="android.intent.action.SENDTO"/>
+ <data android:scheme="mailto"/>
+ <category android:name="android.intent.category.DEFAULT"/>
+ </intent-filter>
+ </activity>
+
+ <activity android:name="org.gnu.emacs.EmacsMultitaskActivity"
+ android:taskAffinity="emacs.secondary_frame"
+ android:windowSoftInputMode="adjustResize"
+ android:exported="true"
+ android:configChanges="orientation|screenSize|screenLayout|keyboardHidden|locale|fontScale"/>
+
+ <activity android:autoRemoveFromRecents="true"
+ android:label="Emacs options"
+ android:exported="true"
+ android:name=".EmacsPreferencesActivity">
+ <intent-filter>
+ <action android:name="android.intent.action.APPLICATION_PREFERENCES" />
+ <category android:name="android.intent.category.DEFAULT" />
+ </intent-filter>
+ </activity>
+
+ <!-- Android 6 and earlier don't display ``application
+ preferences'' activities in Settings, so display the
+ preferences activity as a launcher icon instead. -->
+
+ <activity android:autoRemoveFromRecents="true"
+ android:label="Emacs options"
+ android:enabled="@bool/isBeforeNougat"
+ android:exported="@bool/isBeforeNougat"
+ android:icon="@drawable/emacs_wrench"
+ android:name=".EmacsLauncherPreferencesActivity">
+ <intent-filter>
+ <action android:name="android.intent.action.MAIN" />
+ <category android:name="android.intent.category.DEFAULT" />
+ <category android:name="android.intent.category.LAUNCHER" />
+ </intent-filter>
+ </activity>
+
+ <provider android:name="org.gnu.emacs.EmacsDocumentsProvider"
+ android:authorities="org.gnu.emacs"
+ android:exported="true"
+ android:grantUriPermissions="true"
+ android:permission="android.permission.MANAGE_DOCUMENTS"
+ android:enabled="@bool/isAtLeastKitKat">
+ <intent-filter>
+ <action
+ android:name="android.content.action.DOCUMENTS_PROVIDER"/>
+ </intent-filter>
+ </provider>
+
+ <receiver android:name=".EmacsDesktopNotification$CancellationReceiver"
+ android:exported="false">
+ <intent-filter>
+ <action android:name="org.gnu.emacs.DISMISSED" />
+ </intent-filter>
+ </receiver>
+
+ <service android:name="org.gnu.emacs.EmacsService"
+ android:directBootAware="false"
+ android:enabled="true"
+ android:exported="false"
+ android:foregroundServiceType="specialUse"
+ android:label="GNU Emacs service"/>
+ </application>
+</manifest>
diff --git a/java/INSTALL b/java/INSTALL
new file mode 100644
index 00000000000..f1063b40c25
--- /dev/null
+++ b/java/INSTALL
@@ -0,0 +1,1026 @@
+Installation instructions for Android
+Copyright (C) 2023-2024 Free Software Foundation, Inc.
+See the end of the file for license conditions.
+
+Please read the entirety of this file before attempting to build Emacs
+as an application package which can run on Android devices.
+
+When building from the source repository (as opposed to from a release
+tarball), make sure to read INSTALL.REPO in the top-level directory as
+well.
+
+
+
+Android is an unusual operating system in that program binaries cannot
+be produced on computers running Android themselves. Instead, they
+must be built on some other computer using a set of tools known as the
+``Android SDK'' (Software Development Kit) and the ``Android NDK''
+(Native Development Kit.) Appropriate versions of both must be
+obtained to build GNU Emacs; after being built, the generated binaries
+will work on almost all Android devices. This document does not
+elaborate on how both sets of tools can be obtained. However, for
+your freedom's sake, you should use the Android SDK provided by the
+Debian project.
+
+In addition to the Android SDK and Android NDK, Emacs also requires
+the Java compiler from OpenJDK 1.7.0 to be installed on your system,
+along with a working `m4' macro processor. Building on GNU systems is
+all that is officially supported. We are told that Mac OS works too,
+and other Unix systems will likely work as well, but MS Windows and
+Cygwin will not.
+
+Once all of those tools are obtained, you may invoke the `configure'
+script like so:
+
+ ./configure --with-android=/path/to/android.jar \
+ ANDROID_CC=/path/to/android/ndk/cc \
+ SDK_BUILD_TOOLS=/path/to/sdk/build/tools
+
+Replacing the paths in the command line above with:
+
+ - the path to the `android.jar' headers which come with the Android
+ SDK. They must correspond to Android version 14 (API level 34).
+
+ - the path to the C compiler in the Android NDK, for the kind of CPU
+ you are building Emacs to run on.
+
+ - the path to the directory in the Android SDK containing binaries
+ such as `aapt', `apksigner', and `d8'. These are used to build
+ the application package.
+
+Where the type of CPU can either be `armeabi', `armv7*', `i686',
+`x86_64', `mips', or `mips64'.
+
+After the configuration process completes, you may run:
+
+ make all
+
+Once `make' finishes, there should be a file in the `java' directory
+named along the lines of:
+
+ emacs-<version>-<api-version>-<abi>.apk
+
+where <api-version> is the oldest version of Android that the package
+will run on, and <abi> is the type of Android machine the package was
+built for.
+
+The generated package can be uploaded onto an SD card (or similar
+medium) and installed on-device.
+
+
+LOCATING NECESSARY FILES
+
+As illustrated above, building Emacs for Android requires the presence
+three separate components of the Android SDK and NDK. Subsequent to
+their installation, the contents of the Android development tools are
+organized into several directories, of which those pertinent to the
+Emacs compilation process are:
+
+ platforms
+ ndk
+ build-tools
+
+The platforms directory contains one subdirectory for each API level
+whose headers have been installed. Each of these directories in turn
+includes the android.jar archive for that version of Android, also
+necessary for compiling Emacs.
+
+It is imperative that Emacs is compiled using the headers for the
+exact API level that it is written for. This is currently API level
+34, so the correct android.jar archive is located within a directory
+whose name begins with `android-34'. Minor revisions to the headers
+are inconsequential towards the Emacs compilation process; if there is
+a directory named `android-34-extN' (where N represents a revision to
+the Android SDK), whether you provide `configure' with that
+directory's android.jar or the android.jar contained within the
+directory named `android-34' is of no special importance.
+
+The ndk directory contains one subdirectory for each version of the
+Android NDK installed. This directory in turn contains the C and C++
+compilation system. In contrast to the Java headers mentioned within
+the previous paragraph, the version of the NDK used does not affect
+Emacs to the extent the version of android.jar does. Having said
+that, each version of the NDK only supports a limited range of API
+levels; your choice of C compiler binary (or __ANDROID_API__) bears
+upon the earliest version of Android the compiled package will
+support.
+
+In most cases, each subdirectory contains a folder named `toolchains',
+holding an `llvm' directory and one directory for each GCC toolchain
+supplied by the NDK. The C compiler is then positioned within
+`prebuilt/*/bin' inside that directory.
+
+The build-tools directory holds subdirectories containing the utility
+programs used to convert class files output by the Java compiler to
+the DEX format employed by Android. There is one subdirectory for
+each version of the build tools, but the version you opt for is not of
+paramount significance: if your version does not work, configure will
+protest, so install a newer one. We anticipate that most recent
+releases will work, such as those from the 33.0.x and 34.0.x series.
+
+
+BUILDING WITH OLD NDK VERSIONS
+
+Building Emacs with an old version of the Android NDK requires special
+setup. This is because there is no separate C compiler binary for
+each version of Android in those versions of the NDK.
+
+Before running `configure', you must identify three variables:
+
+ - What kind of Android system you are building Emacs for.
+
+ - The minimum API version of Android you want to build Emacs for.
+
+ - The locations of the system root and include files for that
+ version of Android in the NDK.
+
+That information must then be specified as arguments to the NDK C
+compiler. For example:
+
+ ./configure [...] \
+ ANDROID_CC="i686-linux-android-gcc \
+ --sysroot=/path/to/ndk/platforms/android-14/arch-x86/"
+ ANDROID_CFLAGS="-isystem /path/to/ndk/sysroot/usr/include \
+ -isystem /path/to/ndk/sysroot/usr/include/i686-linux-android \
+ -D__ANDROID_API__=14"
+
+Where __ANDROID_API__ and the version identifier in
+"platforms/android-14" defines the version of Android you are building
+for, and the include directories specify the paths to the relevant
+Android headers. In addition, it may be necessary to specify
+"-gdwarf-2", due to a bug in the Android NDK.
+
+Even older versions of the Android SDK do not require the extra
+`-isystem' directives.
+
+Emacs is known to run on Android 2.2 (API version 8) or later, with
+the NDK r10b or later. We wanted to make Emacs work on even older
+versions of Android, but they are missing the required JNI graphics
+library that allows Emacs to display text from C code.
+
+Due to an extremely nasty bug in the Android 2.2 system, the generated
+Emacs package cannot be compressed in builds for Android 2.2. As a
+result, the Emacs package will be approximately 100 megabytes larger
+than a compressed package for a newer version of Android.
+
+
+BUILDING C++ DEPENDENCIES
+
+In normal circumstances, Emacs should automatically detect and configure
+one of the C++ standard libraries part of the NDK when such a library is
+required to build a dependency specified under `--with-ndk-path'.
+
+Nevertheless, this process is not infalliable, and with certain versions
+of the NDK is liable to fail to locate a C++ compiler, requiring that
+you run the `make_standalone_toolchain.py' script in the NDK
+distribution to create a ``standalone toolchain'' and substitute the
+same for the regular compiler toolchain. See
+https://developer.android.com/ndk/guides/standalone_toolchain for
+further details.
+
+Some versions of the NDK that ship GCC 4.9.x exhibit a bug where the
+compiler cannot locate `stddef.h' after being copied to a standalone
+toolchain. To work around this problem, add:
+
+ -isystem /path/to/toolchain/include/c++/4.9.x
+
+to ANDROID_CFLAGS.
+
+
+DEBUG AND RELEASE BUILDS
+
+Android makes a distinction between ``debug'' and ``release'' builds
+of applications. With ``release'' builds, the system will apply
+stronger optimizations to the application at the cost of being unable
+to debug them with the steps in etc/DEBUG.
+
+Emacs is built as a debuggable package by default, but:
+
+ ./configure --without-android-debug
+
+will create a release build of Emacs instead. This may be useful when
+running Emacs on resource constrained machines.
+
+If you are building an Emacs package for redistribution, we urge you
+to provide both debug and release versions.
+
+
+BUILDING WITH A SHARED USER ID
+
+Sometimes it may be desirable to build Emacs so that it is able to
+access executables and application data from another program. To
+achieve this, that other program must have a ``shared user ID'', and
+be signed with the same signing key used to sign Emacs (normally
+`emacs.keystore'.)
+
+Once you have both that signing key and its ``shared user ID'', you
+can give it to configure:
+
+ ./configure --with-shared-user-id=MY.SHARED.USER.ID
+
+For instance,
+
+ ./configure --with-shared-user-id=com.termux
+
+will result in Termux (https://termux.dev)'s application data being
+accessible to Emacs, within its own application data directory located
+at `/data/data/com.termux/files'.
+
+Don't do this if you already have Emacs installed with a different
+shared user ID, as the system does not allow programs to change their
+user IDs after being installed.
+
+
+BUILDING WITH THIRD PARTY LIBRARIES
+
+The Android NDK does not support the usual ways of locating third
+party libraries, especially not via `pkg-config'. Instead, it uses
+its own system called `ndk-build'. The one exception to this rule is
+zlib, which is considered a part of the Android OS itself and is
+available on all devices running Android.
+
+Android also requires that each application include its own
+dependencies, as the system makes no guarantee about the existence of
+any particular library.
+
+Emacs is not built with the `ndk-build' system. Instead, it is built
+with Autoconf and Make.
+
+However, it supports building and including dependencies which use the
+similarly Make-based `ndk-build' system.
+
+To use dependencies built through `ndk-build', you must specify a list
+of directories within which Emacs will search for ``Android.mk''
+files, like so:
+
+ ./configure "--with-ndk-path=directory1 directory2"
+
+If `configure' complains about not being able to find
+``libc++_shared.so'', then you must locate that file in your copy of
+the NDK, and specify it like so:
+
+ ./configure --with-ndk-cxx-shared=/path/to/sysroot/libc++_shared.so
+
+Emacs will then read the ``Android.mk'' file in each directory, and
+automatically build and use those modules.
+
+When building for Intel systems, some ``ndk-build'' modules require
+the Netwide Assembler, usually installed under ``nasm'', to be present
+on the system that is building Emacs.
+
+Google, Inc. has adapted many common Emacs dependencies to use the
+`ndk-build' system. Here is a non-exhaustive list of what is known to
+work, along with what has to be patched to make them work:
+
+ libpng - https://android.googlesource.com/platform/external/libpng
+ libwebp - https://android.googlesource.com/platform/external/webp
+ (You must apply the patch at the end of this file for the resulting
+ binary to work on armv7 devices.)
+ giflib - https://android.googlesource.com/platform/external/giflib
+ (You must add LOCAL_EXPORT_CFLAGS := -I$(LOCAL_PATH) before
+ its Android.mk includes $(BUILD_STATIC_LIBRARY))
+ libjpeg-turbo - https://android.googlesource.com/platform/external/libjpeg-turbo
+ (You must add LOCAL_EXPORT_C_INCLUDE_DIRS := $(LOCAL_PATH) before
+ its Android.mk includes $(BUILD_SHARED_LIBRARY))
+ libxml2 - https://android.googlesource.com/platform/external/libxml2/
+ (You must also place the dependency icu4c in ``--with-ndk-path'',
+ and apply the patch at the end of this file.)
+ icu4c - https://android.googlesource.com/platform/external/icu/
+ (You must apply the patch at the end of this file.)
+ sqlite3 - https://android.googlesource.com/platform/external/sqlite/
+ (You must apply the patch at the end of this file, and add the `dist'
+ directory to ``--with-ndk-path''.)
+ libselinux - https://android.googlesource.com/platform/external/libselinux
+ (You must apply the patches at the end of the file, and obtain
+ the following three dependencies.)
+ libpackagelistparser
+ https://android.googlesource.com/platform/system/core/+/refs/heads/nougat-mr1-dev/libpackagelistparser/
+ (You must add LOCAL_EXPORT_C_INCLUDE_DIRS := $(LOCAL_PATH)/include before
+ its Android.mk includes $(BUILD_SHARED_LIBRARY))
+ libpcre - https://android.googlesource.com/platform/external/pcre
+ libcrypto - https://android.googlesource.com/platform/external/boringssl
+ (You must apply the patch at the end of this file when building for
+ ARM systems.)
+
+Many of these dependencies have been migrated over to the
+``Android.bp'' build system now used to build Android itself.
+However, the old ``Android.mk'' Makefiles are still present in older
+branches, and can be easily adapted to newer versions.
+
+In addition, some Emacs dependencies provide `ndk-build' support
+themselves:
+
+ libjansson - https://github.com/akheron/jansson
+ (You must add LOCAL_EXPORT_INCLUDES := $(LOCAL_C_INCLUDES) before
+ its Android.mk includes $(BUILD_SHARED_LIBRARY), then copy
+ android/jansson_config.h to android/jansson_private_config.h.)
+
+Emacs developers have ported the following dependencies to ARM Android
+systems:
+
+ gnutls, gmp - https://sourceforge.net/projects/android-ports-for-gnu-emacs
+ (Please see the section GNUTLS near the end of this file.)
+ libtiff - https://sourceforge.net/projects/android-ports-for-gnu-emacs
+ (Extract and point ``--with-ndk-path'' to tiff-4.5.0-emacs.tar.gz.)
+ tree-sitter - https://sourceforge.net/projects/android-ports-for-gnu-emacs
+ (Please see the section TREE-SITTER near the end of this file.)
+ harfbuzz - https://sourceforge.net/projects/android-ports-for-gnu-emacs
+ (Please see the section HARFBUZZ near the end of this file.)
+
+And other developers have ported the following dependencies to Android
+systems:
+
+ ImageMagick, lcms2 - https://github.com/MolotovCherry/Android-ImageMagick7
+ (Please see the section IMAGEMAGICK near the end of this file.)
+
+We anticipate that most untested non-trivial ndk-build dependencies
+will need adjustments in Emacs to work, as the Emacs build system
+which emulates ndk-build is in an extremely early state.
+
+
+GNUTLS
+
+Modified copies of GnuTLS and its dependencies (such as libgmp,
+libtasn1, p11-kit) which can be built with the ndk-build system can be
+found at https://sourceforge.net/projects/android-ports-for-gnu-emacs.
+
+They have only been tested on arm64 Android systems running Android
+5.0 or later, and armv7l systems running Android 13 or later, so your
+mileage may vary, especially if you are trying to build Emacs for
+another kind of machine.
+
+To build Emacs with GnuTLS, you must unpack each of the following tar
+archives in that site:
+
+ gmp-6.2.1-emacs.tgz
+ gnutls-3.7.8-emacs.tar.gz
+ libtasn1-4.19.0-emacs.tar.gz
+ p11-kit-0.24.1-emacs.tar.gz
+ nettle-3.8-emacs.tar.gz
+
+and add the resulting folders to ``--with-ndk-path''. Note that you
+should not try to build these packages separately using any
+`configure' script or Makefiles inside.
+
+
+TREE-SITTER
+
+A copy of tree-sitter modified to build with the ndk-build system can
+also be found that URL. To build Emacs with tree-sitter, you must
+unpack the following tar archive in that site:
+
+ tree-sitter-0.20.7-emacs.tar.gz
+
+and add the resulting folder to ``--with-ndk-build''.
+
+
+HARFBUZZ
+
+A copy of HarfBuzz modified to build with the ndk-build system can
+also be found at that URL. To build Emacs with HarfBuzz, you must
+unpack the following tar archive in that site:
+
+ harfbuzz-7.1.0-emacs.tar.gz
+
+and add the resulting folder to ``--with-ndk-build''.
+
+
+IMAGEMAGICK
+
+There is a third party port of ImageMagick to Android. Unfortunately,
+the port also uses its own patched versions of libpng, libjpeg,
+libtiff and libwebp, which conflict with those used by Emacs. Its
+Makefiles were also written for MS Windows, so you must also apply the
+patch at the end of this file.
+
+
+
+PATCH FOR LIBXML2
+
+This patch must be applied to the Android.mk in Google's version of
+libxml2 before it can be built for Emacs. In addition, you must also
+revert the commit `edb5870767fed8712a9b77ef34097209b61ab2db'.
+
+diff --git a/Android.mk b/Android.mk
+index 07c7b372..2494274f 100644
+--- a/Android.mk
++++ b/Android.mk
+@@ -80,6 +80,7 @@ LOCAL_SHARED_LIBRARIES := libicuuc
+ LOCAL_MODULE:= libxml2
+ LOCAL_CLANG := true
+ LOCAL_ADDITIONAL_DEPENDENCIES += $(LOCAL_PATH)/Android.mk
++LOCAL_EXPORT_C_INCLUDES += $(LOCAL_PATH)/include
+ include $(BUILD_SHARED_LIBRARY)
+
+ # For the host
+@@ -94,3 +95,5 @@ LOCAL_MODULE := libxml2
+ LOCAL_CLANG := true
+ LOCAL_ADDITIONAL_DEPENDENCIES += $(LOCAL_PATH)/Android.mk
+ include $(BUILD_HOST_STATIC_LIBRARY)
++
++$(call import-module,libicuuc)
+
+PATCH FOR ICU
+
+This patch must be applied to icu4j/Android.mk in Google's version of
+icu before it can be built for Emacs.
+
+diff --git a/icu4j/Android.mk b/icu4j/Android.mk
+index d1ab3d5..69eff81 100644
+--- a/icu4j/Android.mk
++++ b/icu4j/Android.mk
+@@ -69,7 +69,7 @@ include $(BUILD_STATIC_JAVA_LIBRARY)
+ # Path to the ICU4C data files in the Android device file system:
+ icu4c_data := /system/usr/icu
+ icu4j_config_root := $(LOCAL_PATH)/main/classes/core/src
+-include external/icu/icu4j/adjust_icudt_path.mk
++include $(LOCAL_PATH)/adjust_icudt_path.mk
+
+ include $(CLEAR_VARS)
+ LOCAL_SRC_FILES := $(icu4j_src_files)
+
+diff --git a/icu4c/source/common/Android.mk b/icu4c/source/common/Android.mk
+index 8e5f757..44bb130 100644
+--- a/icu4c/source/common/Android.mk
++++ b/icu4c/source/common/Android.mk
+@@ -231,7 +231,7 @@ include $(CLEAR_VARS)
+ LOCAL_SRC_FILES += $(src_files)
+ LOCAL_C_INCLUDES += $(c_includes) $(optional_android_logging_includes)
+ LOCAL_CFLAGS += $(local_cflags) -DPIC -fPIC
+-LOCAL_SHARED_LIBRARIES += libdl $(optional_android_logging_libraries)
++LOCAL_SHARED_LIBRARIES += libdl libstdc++ $(optional_android_logging_libraries)
+ LOCAL_MODULE_TAGS := optional
+ LOCAL_MODULE := libicuuc
+ LOCAL_RTTI_FLAG := -frtti
+
+PATCH FOR SQLITE3
+
+diff --git a/dist/Android.mk b/dist/Android.mk
+index bf277d2..36734d9 100644
+--- a/dist/Android.mk
++++ b/dist/Android.mk
+@@ -141,6 +141,7 @@ include $(BUILD_HOST_EXECUTABLE)
+ include $(CLEAR_VARS)
+ LOCAL_SRC_FILES := $(common_src_files)
+ LOCAL_CFLAGS += $(minimal_sqlite_flags)
++LOCAL_EXPORT_C_INCLUDES += $(LOCAL_PATH)
+ LOCAL_MODULE:= libsqlite_static_minimal
+ LOCAL_SDK_VERSION := 23
+ include $(BUILD_STATIC_LIBRARY)
+
+diff --git a/dist/sqlite3.c b/dist/sqlite3.c
+index b0536a4..8fa1ee9 100644
+--- a/dist/sqlite3.c
++++ b/dist/sqlite3.c
+@@ -26474,7 +26474,7 @@ SQLITE_PRIVATE const char *sqlite3OpcodeName(int i){
+ */
+ #if !defined(HAVE_POSIX_FALLOCATE) \
+ && (_XOPEN_SOURCE >= 600 || _POSIX_C_SOURCE >= 200112L)
+-# define HAVE_POSIX_FALLOCATE 1
++/* # define HAVE_POSIX_FALLOCATE 1 */
+ #endif
+
+ /*
+
+PATCH FOR WEBP
+
+diff --git a/Android.mk b/Android.mk
+index c7bcb0f5..d4da1704 100644
+--- a/Android.mk
++++ b/Android.mk
+@@ -28,9 +28,10 @@ ifneq ($(findstring armeabi-v7a, $(TARGET_ARCH_ABI)),)
+ # Setting LOCAL_ARM_NEON will enable -mfpu=neon which may cause illegal
+ # instructions to be generated for armv7a code. Instead target the neon code
+ # specifically.
+- NEON := c.neon
+- USE_CPUFEATURES := yes
+- WEBP_CFLAGS += -DHAVE_CPU_FEATURES_H
++ # NEON := c.neon
++ # USE_CPUFEATURES := yes
++ # WEBP_CFLAGS += -DHAVE_CPU_FEATURES_H
++ NEON := c
+ else
+ NEON := c
+ endif
+
+PATCHES FOR SELINUX
+
+diff --git a/Android.mk b/Android.mk
+index 659232e..1e64fd6 100644
+--- a/Android.mk
++++ b/Android.mk
+@@ -116,3 +116,7 @@ LOCAL_STATIC_LIBRARIES := libselinux
+ LOCAL_WHOLE_STATIC_LIBRARIES := libpcre
+ LOCAL_C_INCLUDES := external/pcre
+ include $(BUILD_HOST_EXECUTABLE)
++
++$(call import-module,libpcre)
++$(call import-module,libpackagelistparser)
++$(call import-module,libcrypto)
+
+diff --git a/src/android.c b/src/android.c
+index 5206a9f..b351ffc 100644
+--- a/src/android.c
++++ b/src/android.c
+@@ -21,8 +21,7 @@
+ #include <selinux/label.h>
+ #include <selinux/avc.h>
+ #include <openssl/sha.h>
+-#include <private/android_filesystem_config.h>
+-#include <log/log.h>
++#include <android/log.h>
+ #include "policy.h"
+ #include "callbacks.h"
+ #include "selinux_internal.h"
+@@ -686,6 +685,7 @@ static int seapp_context_lookup(enum seapp_kind kind,
+ seinfo = parsedseinfo;
+ }
+
++#if 0
+ userid = uid / AID_USER;
+ isOwner = (userid == 0);
+ appid = uid % AID_USER;
+@@ -702,9 +702,13 @@ static int seapp_context_lookup(enum seapp_kind kind,
+ username = "_app";
+ appid -= AID_APP;
+ } else {
++#endif
+ username = "_isolated";
++ appid = 0;
++#if 0
+ appid -= AID_ISOLATED_START;
+ }
++#endif
+
+ if (appid >= CAT_MAPPING_MAX_ID || userid >= CAT_MAPPING_MAX_ID)
+ goto err;
+@@ -1662,8 +1666,10 @@ int selinux_log_callback(int type, const char *fmt, ...)
+
+ va_start(ap, fmt);
+ if (vasprintf(&strp, fmt, ap) != -1) {
++#if 0
+ LOG_PRI(priority, "SELinux", "%s", strp);
+ LOG_EVENT_STRING(AUDITD_LOG_TAG, strp);
++#endif
+ free(strp);
+ }
+ va_end(ap);
+
+PATCH FOR BORINGSSL
+
+diff --git a/Android.mk b/Android.mk
+index 3e3ef2a..277d4a9 100644
+--- a/Android.mk
++++ b/Android.mk
+@@ -27,7 +27,9 @@ LOCAL_MODULE := libcrypto
+ LOCAL_EXPORT_C_INCLUDE_DIRS := $(LOCAL_PATH)/src/include
+ LOCAL_ADDITIONAL_DEPENDENCIES := $(LOCAL_PATH)/Android.mk $(LOCAL_PATH)/crypto-sources.mk
+ LOCAL_CFLAGS += -fvisibility=hidden -DBORINGSSL_SHARED_LIBRARY -DBORINGSSL_IMPLEMENTATION -DOPENSSL_SMALL -Wno-unused-parameter
++LOCAL_CFLAGS_arm = -DOPENSSL_STATIC_ARMCAP -DOPENSSL_NO_ASM
+ LOCAL_SDK_VERSION := 9
++LOCAL_LDFLAGS = --no-undefined
+ # sha256-armv4.S does not compile with clang.
+ LOCAL_CLANG_ASFLAGS_arm += -no-integrated-as
+ LOCAL_CLANG_ASFLAGS_arm64 += -march=armv8-a+crypto
+diff --git a/sources.mk b/sources.mk
+index e82f3d5..be3a3c4 100644
+--- a/sources.mk
++++ b/sources.mk
+@@ -337,20 +337,20 @@ linux_aarch64_sources := \
+ linux-aarch64/crypto/sha/sha256-armv8.S\
+ linux-aarch64/crypto/sha/sha512-armv8.S\
+
+-linux_arm_sources := \
+- linux-arm/crypto/aes/aes-armv4.S\
+- linux-arm/crypto/aes/aesv8-armx32.S\
+- linux-arm/crypto/aes/bsaes-armv7.S\
+- linux-arm/crypto/bn/armv4-mont.S\
+- linux-arm/crypto/modes/ghash-armv4.S\
+- linux-arm/crypto/modes/ghashv8-armx32.S\
+- linux-arm/crypto/sha/sha1-armv4-large.S\
+- linux-arm/crypto/sha/sha256-armv4.S\
+- linux-arm/crypto/sha/sha512-armv4.S\
+- src/crypto/chacha/chacha_vec_arm.S\
+- src/crypto/cpu-arm-asm.S\
+- src/crypto/curve25519/asm/x25519-asm-arm.S\
+- src/crypto/poly1305/poly1305_arm_asm.S\
++# linux_arm_sources := \
++# linux-arm/crypto/aes/aes-armv4.S\
++# linux-arm/crypto/aes/aesv8-armx32.S\
++# linux-arm/crypto/aes/bsaes-armv7.S\
++# linux-arm/crypto/bn/armv4-mont.S\
++# linux-arm/crypto/modes/ghash-armv4.S\
++# linux-arm/crypto/modes/ghashv8-armx32.S\
++# linux-arm/crypto/sha/sha1-armv4-large.S\
++# linux-arm/crypto/sha/sha256-armv4.S\
++# linux-arm/crypto/sha/sha512-armv4.S\
++# src/crypto/chacha/chacha_vec_arm.S\
++# src/crypto/cpu-arm-asm.S\
++# src/crypto/curve25519/asm/x25519-asm-arm.S\
++# src/crypto/poly1305/poly1305_arm_asm.S\
+
+ linux_x86_sources := \
+ linux-x86/crypto/aes/aes-586.S\
+
+PATCH FOR IMAGEMAGICK
+
+diff --git a/Android.mk b/Android.mk
+index 5ab6699..4441417 100644
+--- a/Android.mk
++++ b/Android.mk
+@@ -52,6 +52,20 @@ LZMA_LIB_PATH := $(LOCAL_PATH)/xz-5.2.4
+ BZLIB_LIB_PATH := $(LOCAL_PATH)/bzip-1.0.8
+ LCMS_LIB_PATH := $(LOCAL_PATH)/liblcms2-2.9
+
++LIBBZ2_ENABLED := true
++LIBFFTW_ENABLED := true
++LIBFREETYPE2_ENABLED := true
++LIBJPEG_TURBO_ENABLED := true
++LIBLZMA_ENABLED := true
++LIBOPENJPEG_ENABLED := true
++LIBPNG_ENABLED := true
++LIBTIFF_ENABLED := true
++LIBWEBP_ENABLED := true
++LIBXML2_ENABLED := true
++LIBZLIB_ENABLED := true
++LIBLCMS2_ENABLED := true
++BUILD_MAGICKWAND := true
++
+ #-------------------------------------------------------------
+ # Include all modules
+ #-------------------------------------------------------------
+@@ -68,6 +82,9 @@ include $(MAKE_PATH)/libjpeg-turbo.mk
+ # libopenjpeg
+ include $(MAKE_PATH)/libopenjpeg.mk
+
++# libwebp
++include $(MAKE_PATH)/libwebp.mk
++
+ # libtiff
+ include $(MAKE_PATH)/libtiff.mk
+
+@@ -77,9 +94,6 @@ include $(MAKE_PATH)/libpng.mk
+ # libfreetype2
+ include $(MAKE_PATH)/libfreetype2.mk
+
+-# libwebp
+-include $(MAKE_PATH)/libwebp.mk
+-
+ # libfftw
+ include $(MAKE_PATH)/libfftw.mk
+
+diff --git a/libjpeg-turbo-2.0.2/jconfig.h b/libjpeg-turbo-2.0.2/jconfig.h
+index 47d14c9..5c6f8ee 100644
+--- a/libjpeg-turbo-2.0.2/jconfig.h
++++ b/libjpeg-turbo-2.0.2/jconfig.h
+@@ -1,57 +1,43 @@
+-/* autogenerated jconfig.h based on Android.mk var JCONFIG_FLAGS */
++/* autogenerated jconfig.h based on Android.mk var JCONFIG_FLAGS */
+ #ifndef JPEG_LIB_VERSION
+ #define JPEG_LIB_VERSION 62
+ #endif
+-
+ #ifndef LIBJPEG_TURBO_VERSION
+ #define LIBJPEG_TURBO_VERSION 2.0.2
+ #endif
+-
+ #ifndef LIBJPEG_TURBO_VERSION_NUMBER
+ #define LIBJPEG_TURBO_VERSION_NUMBER 202
+ #endif
+-
+ #ifndef C_ARITH_CODING_SUPPORTED
+ #define C_ARITH_CODING_SUPPORTED
+ #endif
+-
+ #ifndef D_ARITH_CODING_SUPPORTED
+ #define D_ARITH_CODING_SUPPORTED
+ #endif
+-
+ #ifndef MEM_SRCDST_SUPPORTED
+ #define MEM_SRCDST_SUPPORTED
+ #endif
+-
+ #ifndef WITH_SIMD
+ #define WITH_SIMD
+ #endif
+-
+ #ifndef BITS_IN_JSAMPLE
+ #define BITS_IN_JSAMPLE 8
+ #endif
+-
+ #ifndef HAVE_LOCALE_H
+ #define HAVE_LOCALE_H
+ #endif
+-
+ #ifndef HAVE_STDDEF_H
+ #define HAVE_STDDEF_H
+ #endif
+-
+ #ifndef HAVE_STDLIB_H
+ #define HAVE_STDLIB_H
+ #endif
+-
+ #ifndef NEED_SYS_TYPES_H
+ #define NEED_SYS_TYPES_H
+ #endif
+-
+ #ifndef HAVE_UNSIGNED_CHAR
+ #define HAVE_UNSIGNED_CHAR
+ #endif
+-
+ #ifndef HAVE_UNSIGNED_SHORT
+ #define HAVE_UNSIGNED_SHORT
+ #endif
+-
+diff --git a/libxml2-2.9.9/encoding.c b/libxml2-2.9.9/encoding.c
+index a3aaf10..60f165b 100644
+--- a/libxml2-2.9.9/encoding.c
++++ b/libxml2-2.9.9/encoding.c
+@@ -2394,7 +2394,6 @@ xmlCharEncOutput(xmlOutputBufferPtr output, int init)
+ {
+ int ret;
+ size_t written;
+- size_t writtentot = 0;
+ size_t toconv;
+ int c_in;
+ int c_out;
+@@ -2451,7 +2450,6 @@ retry:
+ xmlBufContent(in), &c_in);
+ xmlBufShrink(in, c_in);
+ xmlBufAddLen(out, c_out);
+- writtentot += c_out;
+ if (ret == -1) {
+ if (c_out > 0) {
+ /* Can be a limitation of iconv or uconv */
+@@ -2536,7 +2534,6 @@ retry:
+ }
+
+ xmlBufAddLen(out, c_out);
+- writtentot += c_out;
+ goto retry;
+ }
+ }
+@@ -2567,9 +2564,7 @@ xmlCharEncOutFunc(xmlCharEncodingHandler *handler, xmlBufferPtr out,
+ xmlBufferPtr in) {
+ int ret;
+ int written;
+- int writtentot = 0;
+ int toconv;
+- int output = 0;
+
+ if (handler == NULL) return(-1);
+ if (out == NULL) return(-1);
+@@ -2612,7 +2607,6 @@ retry:
+ in->content, &toconv);
+ xmlBufferShrink(in, toconv);
+ out->use += written;
+- writtentot += written;
+ out->content[out->use] = 0;
+ if (ret == -1) {
+ if (written > 0) {
+@@ -2622,8 +2616,6 @@ retry:
+ ret = -3;
+ }
+
+- if (ret >= 0) output += ret;
+-
+ /*
+ * Attempt to handle error cases
+ */
+@@ -2700,7 +2692,6 @@ retry:
+ }
+
+ out->use += written;
+- writtentot += written;
+ out->content[out->use] = 0;
+ goto retry;
+ }
+diff --git a/libxml2-2.9.9/xpath.c b/libxml2-2.9.9/xpath.c
+index 5e3bb9f..505ec82 100644
+--- a/libxml2-2.9.9/xpath.c
++++ b/libxml2-2.9.9/xpath.c
+@@ -10547,7 +10547,7 @@ xmlXPathCompFilterExpr(xmlXPathParserContextPtr ctxt) {
+
+ static xmlChar *
+ xmlXPathScanName(xmlXPathParserContextPtr ctxt) {
+- int len = 0, l;
++ int l;
+ int c;
+ const xmlChar *cur;
+ xmlChar *ret;
+@@ -10567,7 +10567,6 @@ xmlXPathScanName(xmlXPathParserContextPtr ctxt) {
+ (c == '_') || (c == ':') ||
+ (IS_COMBINING(c)) ||
+ (IS_EXTENDER(c)))) {
+- len += l;
+ NEXTL(l);
+ c = CUR_CHAR(l);
+ }
+diff --git a/make/libicu4c.mk b/make/libicu4c.mk
+index 21ec121..8b77865 100644
+--- a/make/libicu4c.mk
++++ b/make/libicu4c.mk
+@@ -250,7 +250,7 @@ LOCAL_MODULE := libicuuc
+ LOCAL_SRC_FILES := $(src_files)
+
+ # when built in android, they require uconfig_local (because of android project), but we don't need this
+-$(shell > $(ICU_COMMON_PATH)/unicode/uconfig_local.h echo /* Autogenerated stub file to make libicuuc build happy */) \
++$(shell > $(ICU_COMMON_PATH)/unicode/uconfig_local.h echo /\* Autogenerated stub file to make libicuuc build happy \*/) \
+
+ ifeq ($(LIBXML2_ENABLED),true)
+ include $(BUILD_STATIC_LIBRARY)
+diff --git a/make/libjpeg-turbo.mk b/make/libjpeg-turbo.mk
+index d39dd41..fdebcf3 100644
+--- a/make/libjpeg-turbo.mk
++++ b/make/libjpeg-turbo.mk
+@@ -230,30 +230,30 @@ JCONFIG_FLAGS += \
+ HAVE_UNSIGNED_SHORT
+
+ JCONFIGINT_FLAGS += \
+- BUILD="20190814" \
+- PACKAGE_NAME="libjpeg-turbo" \
+- VERSION="2.0.2"
++ BUILD=\"20190814\" \
++ PACKAGE_NAME=\"libjpeg-turbo\" \
++ VERSION=\"2.0.2\"
+
+ # originally defined in jconfigint.h, but the substitution has problems with spaces
+ LOCAL_CFLAGS := \
+ -DINLINE="inline __attribute__((always_inline))"
+
+ # create definition file jconfig.h, needed in order to build
+-$(shell echo /* autogenerated jconfig.h based on Android.mk var JCONFIG_FLAGS */ > $(JPEG_LIB_PATH)/jconfig.h)
++$(shell echo \/\* autogenerated jconfig.h based on Android.mk var JCONFIG_FLAGS \*\/ > $(JPEG_LIB_PATH)/jconfig.h)
+ $(foreach name,$(JCONFIG_FLAGS), \
+ $(if $(findstring =,$(name)), \
+- $(shell >>$(JPEG_LIB_PATH)/jconfig.h echo #ifndef $(firstword $(subst =, ,$(name)))) \
++ $(shell >>$(JPEG_LIB_PATH)/jconfig.h echo \#ifndef $(firstword $(subst =, ,$(name)))) \
+ , \
+- $(shell >>$(JPEG_LIB_PATH)/jconfig.h echo #ifndef $(name)) \
++ $(shell >>$(JPEG_LIB_PATH)/jconfig.h echo \#ifndef $(name)) \
+ ) \
+- $(shell >>$(JPEG_LIB_PATH)/jconfig.h echo #define $(subst =, ,$(name))) \
+- $(shell >>$(JPEG_LIB_PATH)/jconfig.h echo #endif) \
++ $(shell >>$(JPEG_LIB_PATH)/jconfig.h echo \#define $(subst =, ,$(name))) \
++ $(shell >>$(JPEG_LIB_PATH)/jconfig.h echo \#endif) \
+ $(shell >> $(JPEG_LIB_PATH)/jconfig.h echo.) \
+ )
+
+ # create definition file jconfigint.h, needed in order to build
+-$(shell >$(JPEG_LIB_PATH)/jconfigint.h echo /* autogenerated jconfigint.h based on Android.mk vars JCONFIGINT_FLAGS */)
+-$(foreach name,$(JCONFIGINT_FLAGS),$(shell >>$(JPEG_LIB_PATH)/jconfigint.h echo #define $(subst =, ,$(name))))
++$(shell >$(JPEG_LIB_PATH)/jconfigint.h echo /\* autogenerated jconfigint.h based on Android.mk vars JCONFIGINT_FLAGS \*/)
++$(foreach name,$(JCONFIGINT_FLAGS),$(shell >>$(JPEG_LIB_PATH)/jconfigint.h echo \#define $(subst =, ,$(name))))
+
+ ifeq ($(LIBJPEG_TURBO_ENABLED),true)
+ include $(BUILD_STATIC_LIBRARY)
+diff --git a/make/liblcms2.mk b/make/liblcms2.mk
+index e1fd3b9..29ca791 100644
+--- a/make/liblcms2.mk
++++ b/make/liblcms2.mk
+@@ -10,6 +10,10 @@ LOCAL_C_INCLUDES := \
+ $(LCMS_LIB_PATH)/include \
+ $(LCMS_LIB_PATH)/src
+
++LOCAL_EXPORT_C_INCLUDES := \
++ $(LCMS_LIB_PATH) \
++ $(LCMS_LIB_PATH)/include \
++ $(LCMS_LIB_PATH)/src
+
+ LOCAL_CFLAGS := \
+ -DHAVE_FUNC_ATTRIBUTE_VISIBILITY=1 \
+diff --git a/make/libmagick++-7.mk b/make/libmagick++-7.mk
+index 5352ccb..929396d 100644
+--- a/make/libmagick++-7.mk
++++ b/make/libmagick++-7.mk
+@@ -12,7 +12,7 @@ LOCAL_C_INCLUDES := \
+
+ ifneq ($(STATIC_BUILD),true)
+ LOCAL_LDFLAGS += -fexceptions
+- LOCAL_LDLIBS := -L$(SYSROOT)/usr/lib -llog -lz
++ LOCAL_LDLIBS := -llog -lz
+ endif
+
+ LOCAL_SRC_FILES := \
+diff --git a/make/libmagickcore-7.mk b/make/libmagickcore-7.mk
+index 81293b2..d51fced 100644
+--- a/make/libmagickcore-7.mk
++++ b/make/libmagickcore-7.mk
+@@ -25,6 +25,7 @@ else ifeq ($(TARGET_ARCH_ABI),x86_64)
+
+ endif
+
++LOCAL_EXPORT_C_INCLUDES += $(IMAGE_MAGICK)
+
+ LOCAL_C_INCLUDES += \
+ $(IMAGE_MAGICK) \
+@@ -45,10 +46,9 @@ LOCAL_C_INCLUDES += \
+ $(BZLIB_LIB_PATH) \
+ $(LCMS_LIB_PATH)/include
+
+-
+ ifneq ($(STATIC_BUILD),true)
+ # ignored in static library builds
+- LOCAL_LDLIBS := -L$(SYSROOT)/usr/lib -llog -lz
++ LOCAL_LDLIBS := -llog -lz
+ endif
+
+
+diff --git a/make/libmagickwand-7.mk b/make/libmagickwand-7.mk
+index 7be2fb6..0bbcca5 100644
+--- a/make/libmagickwand-7.mk
++++ b/make/libmagickwand-7.mk
+@@ -14,7 +14,7 @@ LOCAL_C_INCLUDES := \
+
+ # always ignored in static builds
+ ifneq ($(STATIC_BUILD),true)
+- LOCAL_LDLIBS := -L$(SYSROOT)/usr/lib -llog -lz
++ LOCAL_LDLIBS := -llog -lz
+ endif
+
+ LOCAL_SRC_FILES := \
+@@ -54,6 +54,29 @@ ifeq ($(OPENCL_BUILD),true)
+ LOCAL_SHARED_LIBRARIES += libopencl
+ endif
+
++LOCAL_SHARED_LIBRARIES += libstdc++
++
++ifeq ($(TARGET_ARCH_ABI),arm64-v8a)
++ LOCAL_EXPORT_C_INCLUDES += $(IMAGE_MAGICK)/configs/arm64
++ LOCAL_C_INCLUDES += $(IMAGE_MAGICK)/configs/arm64
++else ifeq ($(TARGET_ARCH_ABI),armeabi-v7a)
++ LOCAL_EXPORT_C_INCLUDES += $(IMAGE_MAGICK)/configs/arm
++ LOCAL_C_INCLUDES += $(IMAGE_MAGICK)/configs/arm
++else ifeq ($(TARGET_ARCH_ABI),x86)
++ LOCAL_EXPORT_C_INCLUDES += $(IMAGE_MAGICK)/configs/x86
++ LOCAL_C_INCLUDES += $(IMAGE_MAGICK)/configs/x86
++else ifeq ($(TARGET_ARCH_ABI),x86_64)
++ LOCAL_EXPORT_C_INCLUDES += $(IMAGE_MAGICK)/configs/x86-64
++ LOCAL_C_INCLUDES += $(IMAGE_MAGICK)/configs/x86-64
++
++ ifneq ($(STATIC_BUILD),true)
++ LOCAL_LDFLAGS += -latomic
++ endif
++
++endif
++
++LOCAL_EXPORT_C_INCLUDES += $(IMAGE_MAGICK)
++
+ ifeq ($(BUILD_MAGICKWAND),true)
+ ifeq ($(STATIC_BUILD),true)
+ LOCAL_STATIC_LIBRARIES := \
+diff --git a/make/libpng.mk b/make/libpng.mk
+index 24fb8ac..dda05fd 100644
+--- a/make/libpng.mk
++++ b/make/libpng.mk
+@@ -30,6 +30,7 @@ ifeq ($(TARGET_ARCH_ABI), arm64-v8a)
+ endif # TARGET_ARCH_ABI == arm64-v8a
+
+
++LOCAL_EXPORT_C_INCLUDES := $(PNG_LIB_PATH)
+ LOCAL_C_INCLUDES := $(PNG_LIB_PATH)
+
+ LOCAL_SRC_FILES += \
+diff --git a/make/libtiff.mk b/make/libtiff.mk
+index ca43f25..2b17508 100644
+--- a/make/libtiff.mk
++++ b/make/libtiff.mk
+@@ -12,6 +12,9 @@ LOCAL_C_INCLUDES := \
+ $(LZMA_LIB_PATH)/liblzma/api \
+ $(WEBP_LIB_PATH)/src
+
++LOCAL_EXPORT_C_INCLUDES := \
++ $(TIFF_LIB_PATH)
++
+ ifeq ($(LIBLZMA_ENABLED),true)
+ LOCAL_CFLAGS += -DLZMA_SUPPORT=1
+ endif
+diff --git a/make/magick.mk b/make/magick.mk
+index 3ba4b1d..5471608 100644
+--- a/make/magick.mk
++++ b/make/magick.mk
+@@ -18,7 +18,7 @@ LOCAL_C_INCLUDES := \
+ $(FREETYPE_LIB_PATH)/include
+
+
+-LOCAL_LDLIBS := -L$(SYSROOT)/usr/lib -llog -lz
++LOCAL_LDLIBS := -llog -lz
+ LOCAL_SRC_FILES := \
+ $(IMAGE_MAGICK)/utilities/magick.c \
+
+
+
+This file is part of GNU Emacs.
+
+GNU Emacs is free software: you can redistribute it and/or modify
+it under the terms of the GNU General Public License as published by
+the Free Software Foundation, either version 3 of the License, or
+(at your option) any later version.
+
+GNU Emacs is distributed in the hope that it will be useful,
+but WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+GNU General Public License for more details.
+
+You should have received a copy of the GNU General Public License
+along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>.
diff --git a/java/Makefile.in b/java/Makefile.in
new file mode 100644
index 00000000000..c23b52ed44e
--- /dev/null
+++ b/java/Makefile.in
@@ -0,0 +1,343 @@
+### @configure_input@
+
+# Copyright (C) 2023-2024 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 <https://www.gnu.org/licenses/>.
+
+top_builddir = @top_builddir@
+top_srcdir = @top_srcdir@
+srcdir = @srcdir@
+builddir = @builddir@
+version = @version@
+
+# Don't install movemail if mailutils are to be used.
+emacs_use_mailutils = @emacs_use_mailutils@
+
+# This is the host lib-src and lib, not the cross compiler's lib-src.
+libsrc = ../lib-src
+EXEEXT = @EXEEXT@
+
+-include ${top_builddir}/src/verbose.mk
+
+SHELL = @SHELL@
+JAVAC = @JAVAC@
+AAPT = @AAPT@
+D8 = @D8@
+ZIPALIGN = @ZIPALIGN@
+JARSIGNER = @JARSIGNER@
+APKSIGNER = @APKSIGNER@
+JARSIGNER_FLAGS =
+ANDROID_JAR = @ANDROID_JAR@
+ANDROID_ABI = @ANDROID_ABI@
+ANDROID_SDK_18_OR_EARLIER = @ANDROID_SDK_18_OR_EARLIER@
+ANDROID_SDK_8_OR_EARLIER = @ANDROID_SDK_8_OR_EARLIER@
+WARN_JAVAFLAGS = @WARN_JAVAFLAGS@
+JAVAFLAGS = $(WARN_JAVAFLAGS) -classpath "$(ANDROID_JAR):$(srcdir)"
+FIND_DELETE = @FIND_DELETE@
+
+# Android 4.3 and earlier require Emacs to be signed with a different
+# digital signature algorithm.
+
+ifneq (,$(ANDROID_SDK_18_OR_EARLIER))
+JARSIGNER_FLAGS = -sigalg MD5withRSA -digestalg SHA1
+else
+JARSIGNER_FLAGS =
+endif
+
+# When building Emacs for Android 2.2, assets must not be compressed.
+# Otherwise, the asset manager fails to extract files larger than 1
+# MB.
+
+ifneq (,$(ANDROID_SDK_8_OR_EARLIER))
+AAPT_ASSET_ARGS = -0 ""
+else
+AAPT_ASSET_ARGS =
+endif
+
+SIGN_EMACS = -keystore $(srcdir)/emacs.keystore -storepass \
+ emacs1 $(JARSIGNER_FLAGS)
+SIGN_EMACS_V2 = sign --v2-signing-enabled --ks \
+ $(srcdir)/emacs.keystore -debuggable-apk-permitted \
+ --ks-pass pass:emacs1
+
+JAVA_FILES := $(wildcard $(srcdir)/org/gnu/emacs/*.java)
+RESOURCE_FILES := $(foreach file,$(wildcard $(srcdir)/res/*), \
+ $(wildcard $(file)/*))
+
+# R.java is a file generated by the `aapt' utility containing
+# constants that can then be used to locate ``resource identifiers''.
+# It is not a regular file and should not be compiled as Java source
+# code. Instead, it is automatically included by the Java compiler.
+RESOURCE_FILE := $(srcdir)/org/gnu/emacs/R.java
+
+# CLASS_FILES is what should actually be built and included in the
+# resulting Emacs executable. The Java compiler might generate more
+# than one class file for each source file, so this only serves as a
+# list of dependencies for Make.
+CLASS_FILES := $(foreach file,$(JAVA_FILES),$(basename $(file)).class)
+
+# Remove RESOURCE_FILE from JAVA_FILES, if it is already present.
+JAVA_FILES := $(filter-out $(RESOURCE_FILE),$(JAVA_FILES))
+
+# Compute the name for the Emacs application package. This should be:
+# emacs-<version>-<min-sdk>-<abi>.apk
+
+ANDROID_MIN_SDK := @ANDROID_MIN_SDK@
+APK_NAME := emacs-$(version)-$(ANDROID_MIN_SDK)-$(ANDROID_ABI).apk
+
+# How this stuff works.
+
+# emacs.apk depends on emacs.apk-in, which is simply a ZIP archive
+# containing the following files:
+# lib/$(ANDROID_ABI)/libemacs.so
+# lib/$(ANDROID_ABI)/libandroid-emacs.so
+# lib/$(ANDROID_ABI)/libctags.so
+# lib/$(ANDROID_ABI)/libetags.so
+# lib/$(ANDROID_ABI)/libhexl.so
+# lib/$(ANDROID_ABI)/libmovemail.so
+# lib/$(ANDROID_ABI)/librcs2log.so
+# lib/$(ANDROID_ABI)/libebrowse.so
+# assets/info/
+# assets/etc/
+# assets/lisp/
+
+.PHONY: emacs.apk-in all
+all: $(APK_NAME)
+
+# Binaries to cross-compile.
+CROSS_SRC_BINS := $(top_builddir)/cross/src/android-emacs
+CROSS_LIBSRC_BINS := $(top_builddir)/cross/lib-src/ctags \
+ $(top_builddir)/cross/lib-src/hexl \
+ $(top_builddir)/cross/lib-src/ebrowse \
+ $(top_builddir)/cross/lib-src/emacsclient \
+ $(top_builddir)/cross/lib-src/etags
+CROSS_LIBSRC_BINS_MOVEMAIL := $(top_builddir)/cross/lib-src/movemail
+CROSS_EXEC_BINS := $(top_builddir)/exec/exec1 $(top_builddir)/exec/loader
+CROSS_BINS = $(CROSS_SRC_BINS) $(CROSS_LIBSRC_BINS) $(CROSS_EXEC_BINS)
+
+ifneq ($(emacs_use_mailutils),yes)
+CROSS_LIBSRC_BINS := $(CROSS_LIBSRC_BINS) $(CROSS_LIBSRC_BINS_MOVEMAIL)
+endif
+
+# Libraries to cross-compile.
+CROSS_LIBS = $(top_builddir)/cross/src/libemacs.so
+
+# Make sure gnulib is built first!
+# If not, then the recursive invocations of make below will try to
+# build gnulib at the same time.
+CROSS_ARCHIVES = $(top_builddir)/cross/lib/libgnu.a
+
+# Third party libraries to compile.
+-include $(top_builddir)/cross/ndk-build/ndk-build.mk
+
+.PHONY: $(CROSS_BINS) $(CROSS_LIBS) $(CROSS_ARCHIVES)
+
+# There should only be a single invocation of $(MAKE) -C
+# $(top_srcdir)/cross for each directory under $(top_srcdir)/cross.
+$(CROSS_SRC_BINS) $(CROSS_LIBS) &: $(CROSS_ARCHIVES)
+ $(MAKE) -C $(top_builddir)/cross $(foreach file, \
+ $(CROSS_SRC_BINS) \
+ $(CROSS_LIBS), \
+ src/$(notdir $(file)))
+
+$(CROSS_LIBSRC_BINS) &: $(CROSS_ARCHIVES)
+ $(MAKE) -C $(top_builddir)/cross $(foreach file, \
+ $(CROSS_LIBSRC_BINS), \
+ lib-src/$(notdir $(file)))
+
+$(CROSS_ARCHIVES):
+ $(MAKE) -C $(top_builddir)/cross lib/libgnu.a
+
+# These two binaries are helpers used to execute binaries on Android
+# 10 and later.
+
+$(CROSS_EXEC_BINS) &:
+ $(MAKE) -C $(top_builddir)/exec $(notdir $(CROSS_EXEC_BINS))
+
+# This is needed to generate the ``.directory-tree'' file used by the
+# Android emulations of readdir and faccessat.
+
+$(libsrc)/asset-directory-tool:
+ $(MAKE) -C $(libsrc) $(notdir $@)
+
+# install_tmp is a directory used to generate emacs.apk-in.
+# That is then packaged into $(APK_NAME).
+# There is no need to depend on NDK_BUILD_SHARED as libemacs.so
+# does already.
+
+.PHONY: install_temp install_temp/assets/directory-tree
+install_temp: $(CROSS_BINS) $(CROSS_LIBS) $(RESOURCE_FILES)
+ $(AM_V_GEN)
+# Make the working directory for this stuff
+ $(AM_V_SILENT) rm -rf install_temp
+ $(AM_V_SILENT) mkdir -p install_temp/lib/$(ANDROID_ABI)
+ $(AM_V_SILENT) mkdir -p install_temp/assets/etc
+ $(AM_V_SILENT) mkdir -p install_temp/assets/lisp
+ $(AM_V_SILENT) mkdir -p install_temp/assets/info
+# Install architecture independents to assets/etc and assets/lisp
+ $(AM_V_SILENT) cp -r $(top_srcdir)/lisp install_temp/assets
+ $(AM_V_SILENT) cp -r $(top_srcdir)/etc install_temp/assets
+ $(AM_V_SILENT) cp -r $(top_srcdir)/info install_temp/assets
+# Replace etc/DOC generated by compiling Emacs for the build machine
+# with etc/DOC from the cross-compiled Emacs.
+ $(AM_V_SILENT) test -f $(top_builddir)/cross/etc/DOC \
+ && cp -r $(top_builddir)/cross/etc/DOC \
+ install_temp/assets/etc
+# Remove undesirable files from those directories.
+ $(AM_V_SILENT) \
+ for subdir in `find install_temp -type d -print`; do \
+ chmod a+rx $${subdir} ; \
+ rm -rf $${subdir}/.gitignore ; \
+ rm -rf $${subdir}/.DS_Store ; \
+ rm -rf $${subdir}/#* ; \
+ rm -rf $${subdir}/.#* ; \
+ rm -rf $${subdir}/*~ ; \
+ rm -rf $${subdir}/*.orig ; \
+ rm -rf $${subdir}/ChangeLog* ; \
+ rm -rf $${subdir}/[mM]akefile*[.-]in ; \
+ rm -rf $${subdir}/Makefile; \
+ done
+# Generate the directory tree for those directories.
+# Install architecture dependents to lib/$(ANDROID_ABI). This
+# perculiar naming scheme is required to make Android preserve these
+# binaries upon installation.
+ $(AM_V_SILENT) \
+ for file in $(CROSS_BINS); do \
+ if [ -x $$file ]; then \
+ filename=`basename $$file`; \
+ cp -f $$file install_temp/lib/$(ANDROID_ABI)/lib$${filename}.so; \
+ fi \
+ done
+ $(AM_V_SILENT) \
+ for file in $(CROSS_LIBS); do \
+ if [ -x $$file ]; then \
+ cp -f $$file install_temp/lib/$(ANDROID_ABI); \
+ fi \
+ done
+# Next, produce a version of rcs2log befitting Android's naming
+# conventions and shell interpreter location.
+ $(AM_V_at) \
+ sed 's|/bin/sh|/system/bin/sh|' \
+ $(top_srcdir)/lib-src/rcs2log > \
+ install_temp/lib/$(ANDROID_ABI)/librcs2log.so
+ $(AM_V_at) chmod +x install_temp/lib/$(ANDROID_ABI)/librcs2log.so
+ifneq ($(NDK_BUILD_SHARED),)
+ $(AM_V_SILENT) cp -f $(NDK_BUILD_SHARED) \
+ install_temp/lib/$(ANDROID_ABI)
+endif
+
+install_temp/assets/directory-tree: $(libsrc)/asset-directory-tool \
+ install_temp install_temp/assets/version \
+ install_temp/assets/build_info
+ $(AM_V_GEN) $(libsrc)/asset-directory-tool install_temp/assets \
+ install_temp/assets/directory-tree
+
+install_temp/assets/version: install_temp
+ $(AM_V_GEN) { (cd $(top_srcdir) \
+ && git rev-parse HEAD || echo "Unknown") \
+ && (git rev-parse --abbrev-ref HEAD \
+ || echo "Unknown") } 2> /dev/null > $@
+
+install_temp/assets/build_info: install_temp
+ $(AM_V_GEN) { hostname; date +%s; } > $@
+
+emacs.apk-in: install_temp install_temp/assets/directory-tree \
+ AndroidManifest.xml install_temp/assets/version \
+ install_temp/assets/build_info classes.dex
+# Package everything. Redirect the generated R.java to install_temp, as
+# it must already have been generated as a prerequisite of
+# classes.dex's.
+ $(AM_V_AAPT) $(AAPT) p -I "$(ANDROID_JAR)" -F $@ \
+ -f -M AndroidManifest.xml $(AAPT_ASSET_ARGS) \
+ -A install_temp/assets \
+ -S $(top_srcdir)/java/res -J install_temp
+ $(AM_V_SILENT) $(AAPT) a $@ classes.dex
+ $(AM_V_SILENT) pushd install_temp &> /dev/null; \
+ $(AAPT) add ../$@ `find lib -type f`; \
+ popd &> /dev/null
+ $(AM_V_SILENT) rm -rf install_temp
+
+# Makefile itself.
+.PRECIOUS: $(top_srcdir)/config.status Makefile
+$(top_srcdir)/config.status: $(top_srcdir)/configure.ac $(top_srcdir)/m4/*.m4
+ $(MAKE) -C $(dir $@) $(notdir $@)
+Makefile: $(top_srcdir)/config.status $(top_srcdir)/java/Makefile.in
+ $(MAKE) -C .. java/$@
+
+# AndroidManifest.xml:
+AndroidManifest.xml: $(top_srcdir)/configure.ac $(top_srcdir)/m4/*.m4 \
+ $(srcdir)/AndroidManifest.xml.in
+ pushd ..; ./config.status java/AndroidManifest.xml; popd
+
+# R.java:
+$(RESOURCE_FILE): $(RESOURCE_FILES)
+ $(AM_V_GEN) $(AAPT) p -I "$(ANDROID_JAR)" -f \
+ -J $(dir $@) -M AndroidManifest.xml \
+ -S $(top_srcdir)/java/res
+
+# Make all class files depend on R.java being built.
+$(CLASS_FILES): $(RESOURCE_FILE)
+
+.SUFFIXES: .java .class
+$(CLASS_FILES) &: $(JAVA_FILES)
+ $(AM_V_JAVAC) $(JAVAC) $(JAVAFLAGS) $(JAVA_FILES)
+ $(AM_V_SILENT) touch $(CLASS_FILES)
+
+# N.B. that find must be called all over again in case javac generated
+# nested classes.
+
+classes.dex: $(CLASS_FILES)
+ $(AM_V_D8) $(D8) --classpath $(ANDROID_JAR) \
+ $(subst $$,\$$,$(shell find $(srcdir) -type f \
+ -name *.class)) --output $(builddir)
+
+# When emacs.keystore expires, regenerate it with:
+#
+# keytool -genkey -v -keystore emacs.keystore -alias "Emacs keystore" \
+# -keyalg RSA -sigalg SHA1withRSA -keysize 2048 -validity 100000
+
+.PHONY: clean maintainer-clean
+
+$(APK_NAME): emacs.apk-in $(srcdir)/emacs.keystore
+ $(AM_V_GEN)
+ $(AM_V_SILENT) cp -f emacs.apk-in $@.unaligned
+ $(AM_V_SILENT) $(JARSIGNER) $(SIGN_EMACS) $@.unaligned "Emacs keystore"
+ $(AM_V_SILENT) $(ZIPALIGN) -f 4 $@.unaligned $@
+# Signing must happen after alignment!
+ $(AM_V_SILENT) $(APKSIGNER) $(SIGN_EMACS_V2) $@
+ $(AM_V_SILENT) rm -f $@.unaligned *.idsig
+
+# TAGS generation.
+
+ETAGS = $(top_builddir)/lib-src/etags
+
+$(ETAGS): FORCE
+ $(MAKE) -C ../lib-src $(notdir $@)
+
+tagsfiles = $(JAVA_FILES) $(RESOURCE_FILE)
+
+.PHONY: tags FORCE
+tags: TAGS
+TAGS: $(ETAGS) $(tagsfiles)
+ $(AM_V_GEN) $(ETAGS) $(tagsfiles)
+
+clean:
+ rm -f *.apk emacs.apk-in *.dex *.unaligned *.class *.idsig
+ rm -rf install-temp $(RESOURCE_FILE) TAGS
+ find . -name '*.class' $(FIND_DELETE)
+
+maintainer-clean distclean bootstrap-clean: clean
+ rm -f Makefile ndk-build.mk
diff --git a/java/README b/java/README
new file mode 100644
index 00000000000..a909cdd22ef
--- /dev/null
+++ b/java/README
@@ -0,0 +1,27 @@
+This directory holds the Java sources of the port of GNU Emacs to
+Android-like systems, along with files needed to create an application
+package out of them. If you need to build this port, please read the
+file INSTALL in this directory.
+
+The ``org/gnu/emacs'' subdirectory contains the Java sources under the
+``org.gnu.emacs'' package identifier.
+
+``AndroidManifest.xml'' contains a manifest describing the Java
+sources to the system.
+
+The ``res'' directory contains resources, mainly the Emacs icon and
+several ``boolean resources'' which are used as a form of conditional
+evaluation for manifest entries.
+
+`emacs.keystore' is the signing key used to build Emacs. It is kept
+here, and we encourage all people redistributing Emacs to use this
+key. It holds no security value, and otherwise it will be impossible
+to install different builds of Emacs on top of each other.
+
+Please keep the Java code indented with tabs and formatted according
+to the rules for C code in the GNU coding standards. Always use
+C-style comments.
+
+Refer to the file `admin/notes/java' in the toplevel directory of the
+Emacs distribution or repository for specifics regarding writing Java
+code for Emacs and the organization of the Android port.
diff --git a/java/debug.sh b/java/debug.sh
new file mode 100755
index 00000000000..c5d40141355
--- /dev/null
+++ b/java/debug.sh
@@ -0,0 +1,371 @@
+#!/bin/bash
+### Run Emacs under GDB or JDB on Android.
+
+## Copyright (C) 2023-2024 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 <https://www.gnu.org/licenses/>.
+
+set -m
+oldpwd=`pwd`
+cd `dirname $0`
+
+devices=`adb devices | grep device | awk -- '/device\y/ { print $1 }' -`
+device=
+progname=$0
+package=org.gnu.emacs
+activity=org.gnu.emacs.EmacsActivity
+gdb_port=5039
+jdb_port=64013
+jdb=no
+attach_existing=no
+gdbserver=
+gdb=gdb
+
+while [ $# -gt 0 ]; do
+ case "$1" in
+ ## This option specifies the serial number of a device to use.
+ "--device" )
+ device="$2"
+ if [ -z device ]; then
+ echo "You must specify an argument to --device"
+ exit 1
+ fi
+ shift
+ ;;
+ "--help" )
+ echo "Usage: $progname [options] -- [gdb options]"
+ echo ""
+ echo " --device DEVICE run Emacs on the specified device"
+ echo " --port PORT run the GDB server on a specific port"
+ echo " --jdb-port PORT run the JDB server on a specific port"
+ echo " --jdb run JDB instead of GDB"
+ echo " --gdb use specified GDB binary"
+ echo " --attach-existing attach to an existing process"
+ echo " --gdbserver BINARY upload and use the specified gdbserver binary"
+ echo " --help print this message"
+ echo ""
+ echo "Available devices:"
+ for device in $devices; do
+ echo " " $device
+ done
+ echo ""
+ exit 0
+ ;;
+ "--jdb" )
+ jdb=yes
+ ;;
+ "--gdb" )
+ shift
+ gdb=$1
+ ;;
+ "--gdbserver" )
+ shift
+ gdbserver=$1
+ ;;
+ "--port" )
+ shift
+ gdb_port=$1
+ ;;
+ "--jdb-port" )
+ shift
+ jdb_port=$1
+ ;;
+ "--attach-existing" )
+ attach_existing=yes
+ ;;
+ "--" )
+ shift
+ gdbargs=$@
+ break;
+ ;;
+ * )
+ echo "$progname: Unrecognized argument $1"
+ exit 1
+ ;;
+ esac
+ shift
+done
+
+if [ -z "$devices" ]; then
+ echo "No devices are available."
+ exit 1
+fi
+
+if [ `wc -w <<< "$devices"` -gt 1 ] && [ -z $device ]; then
+ echo "Multiple devices are available. Please specify one with"
+ echo "the option --device and try again."
+ exit 1
+fi
+
+if [ -z $device ]; then
+ device=$devices
+fi
+
+echo "Looking for $package on device $device"
+
+# Find the application data directory
+app_data_dir=`adb -s $device shell run-as $package sh -c 'pwd 2> /dev/null'`
+
+if [ -z $app_data_dir ]; then
+ echo "The data directory for the package $package was not found."
+ echo "Is it installed?"
+fi
+
+echo "Found application data directory at" "$app_data_dir"
+
+# Generate an awk script to extract PIDs from Android ps output. It
+# is enough to run `ps' as the package user on newer versions of
+# Android, but that doesn't work on Android 2.3.
+cat << EOF > tmp.awk
+BEGIN {
+ pid = 0;
+ pid_column = 2;
+}
+
+{
+ # Remove any trailing carriage return from the input line.
+ gsub ("\r", "", \$NF)
+
+ # If this is line 1, figure out which column contains the PID.
+ if (NR == 1)
+ {
+ for (n = 1; n <= NF; ++n)
+ {
+ if (\$n == "PID")
+ pid_column=n;
+ }
+ }
+ else if (\$NF == "$package")
+ print \$pid_column
+}
+EOF
+
+# Make sure that file disappears once this script exits.
+trap "rm -f $(pwd)/tmp.awk" 0
+
+# First, run ps to fetch the list of process IDs.
+package_pids=`adb -s $device shell ps`
+
+# Next, extract the list of PIDs currently running.
+package_pids=`awk -f tmp.awk <<< $package_pids`
+
+if [ "$attach_existing" != "yes" ]; then
+ # Finally, kill each existing process.
+ for pid in $package_pids; do
+ echo "Killing existing process $pid..."
+ adb -s $device shell run-as $package kill -9 $pid &> /dev/null
+ done
+
+ # Now run the main activity. This must be done as the adb user and
+ # not as the package user.
+ echo "Starting activity $activity and attaching debugger"
+
+ # Exit if the activity could not be started.
+ adb -s $device shell am start -D -n "$package/$activity"
+ if [ ! $? ]; then
+ exit 1;
+ fi
+
+ # Sleep for a bit. Otherwise, the process may not have started
+ # yet.
+ sleep 1
+
+ # Now look for processes matching the package again.
+ package_pids=`adb -s $device shell ps`
+
+ # Next, remove lines matching "ps" itself.
+ package_pids=`awk -f tmp.awk <<< $package_pids`
+fi
+
+rm tmp.awk
+
+pid=$package_pids
+num_pids=`wc -w <<< "$package_pids"`
+
+if [ $num_pids -gt 1 ]; then
+ echo "More than one process was started:"
+ echo ""
+ adb -s $device shell run-as $package ps | awk -- "{
+ if (!match (\$0, /ps/) && match (\$0, /$package/))
+ print \$0
+ }"
+ echo ""
+ printf "Which one do you want to attach to? "
+ read pid
+elif [ -z $package_pids ]; then
+ echo "No processes were found to attach to."
+ exit 1
+fi
+
+# If either --jdb was specified or debug.sh is not connecting to an
+# existing process, then store a suitable JDB invocation in
+# jdb_command. GDB will then run JDB to unblock the application from
+# the wait dialog after startup.
+
+if [ "$jdb" = "yes" ] || [ "$attach_existing" != yes ]; then
+ adb -s $device forward --remove-all
+ adb -s $device forward "tcp:$jdb_port" "jdwp:$pid"
+
+ if [ ! $? ]; then
+ echo "Failed to forward jdwp:$pid to $jdb_port!"
+ echo "Perhaps you need to specify a different port with --port?"
+ exit 1;
+ fi
+
+ jdb_command="jdb -connect \
+ com.sun.jdi.SocketAttach:hostname=localhost,port=$jdb_port"
+
+ if [ $jdb = "yes" ]; then
+ # Just start JDB and then exit
+ $jdb_command
+ exit 1
+ fi
+fi
+
+if [ -n "$jdb_command" ]; then
+ echo "Starting JDB to unblock application."
+
+ # Start JDB to unblock the application.
+ coproc JDB { $jdb_command; }
+
+ # Tell JDB to first suspend all threads.
+ echo "suspend" >&${JDB[1]}
+
+ # Tell JDB to print a magic string once the program is
+ # initialized.
+ echo "print \"__verify_jdb_has_started__\"" >&${JDB[1]}
+
+ # Now wait for JDB to give the string back.
+ line=
+ while :; do
+ read -u ${JDB[0]} line
+ if [ ! $? ]; then
+ echo "Failed to read JDB output"
+ exit 1
+ fi
+
+ case "$line" in
+ *__verify_jdb_has_started__*)
+ # Android only polls for a Java debugger every 200ms, so
+ # the debugger must be connected for at least that long.
+ echo "Pausing 1 second for the program to continue."
+ sleep 1
+ break
+ ;;
+ esac
+ done
+
+ # Note that JDB does not exit until GDB is fully attached!
+fi
+
+# See if gdbserver has to be uploaded
+gdbserver_cmd=
+is_root=
+if [ -z "$gdbserver" ]; then
+ gdbserver_bin=/system/bin/gdbserver64
+else
+ gdbserver_bin=/data/local/tmp/gdbserver
+ gdbserver_cat="cat $gdbserver_bin | run-as $package sh -c \
+ \"tee gdbserver > /dev/null\""
+
+ # Upload the specified gdbserver binary to the device.
+ adb -s $device push "$gdbserver" "$gdbserver_bin"
+
+ if (adb -s $device shell ls /system/bin | grep -G tee); then
+ # Copy it to the user directory.
+ adb -s $device shell "$gdbserver_cat"
+ adb -s $device shell "run-as $package chmod 777 gdbserver"
+ gdbserver_cmd="./gdbserver"
+ else
+ # Hopefully this is an old version of Android which allows
+ # execution from /data/local/tmp. Its `chmod' doesn't support
+ # `+x' either.
+ adb -s $device shell "chmod 777 $gdbserver_bin"
+ gdbserver_cmd="$gdbserver_bin"
+
+ # If the user is root, then there is no need to open any kind
+ # of TCP socket.
+ if (adb -s $device shell id | grep -G root); then
+ gdbserver=
+ is_root=yes
+ fi
+ fi
+fi
+
+# Now start gdbserver on the device asynchronously.
+
+echo "Attaching gdbserver to $pid on $device..."
+exec 5<> /tmp/file-descriptor-stamp
+rm -f /tmp/file-descriptor-stamp
+
+if [ -z "$gdbserver" ]; then
+ if [ "$is_root" = "yes" ]; then
+ adb -s $device shell $gdbserver_bin --multi \
+ "0.0.0.0:7564" --attach $pid >&5 &
+ gdb_socket="tcp:7564"
+ else
+ adb -s $device shell $gdbserver_bin --multi \
+ "0.0.0.0:7564" --attach $pid >&5 &
+ gdb_socket="tcp:7564"
+ fi
+else
+ # Normally the program cannot access $gdbserver_bin when it is
+ # placed in /data/local/tmp.
+ adb -s $device shell run-as $package $gdbserver_cmd --multi \
+ "+debug.$package.socket" --attach $pid >&5 &
+ gdb_socket="localfilesystem:$app_data_dir/debug.$package.socket"
+fi
+
+# In order to allow adb to forward to the gdbserver socket, make the
+# app data directory a+x.
+adb -s $device shell run-as $package chmod a+x $app_data_dir
+
+# Wait until gdbserver successfully runs.
+line=
+while read -u 5 line; do
+ case "$line" in
+ *Attached* )
+ break;
+ ;;
+ *error* | *Error* | failed )
+ echo "GDB error:" $line
+ exit 1
+ ;;
+ * )
+ ;;
+ esac
+done
+
+# Now that GDB is attached, tell the Java debugger to resume execution
+# and then exit.
+
+if [ -n "$jdb_command" ]; then
+ echo "resume" >&${JDB[1]}
+ echo "exit" >&${JDB[1]}
+fi
+
+# Forward the gdb server port here.
+adb -s $device forward "tcp:$gdb_port" $gdb_socket
+if [ ! $? ]; then
+ echo "Failed to forward $app_data_dir/debug.$package.socket"
+ echo "to $gdb_port! Perhaps you need to specify a different port"
+ echo "with --port?"
+ exit 1;
+fi
+
+# Finally, start gdb with any extra arguments needed.
+cd "$oldpwd"
+$gdb --eval-command "target remote localhost:$gdb_port" $gdbargs
diff --git a/java/emacs.keystore b/java/emacs.keystore
new file mode 100644
index 00000000000..76d80b6db65
--- /dev/null
+++ b/java/emacs.keystore
Binary files differ
diff --git a/java/org/gnu/emacs/EmacsActivity.java b/java/org/gnu/emacs/EmacsActivity.java
new file mode 100644
index 00000000000..e380b7bfc2a
--- /dev/null
+++ b/java/org/gnu/emacs/EmacsActivity.java
@@ -0,0 +1,581 @@
+/* Communication module for Android terminals. -*- c-file-style: "GNU" -*-
+
+Copyright (C) 2023-2024 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 <https://www.gnu.org/licenses/>. */
+
+package org.gnu.emacs;
+
+import java.lang.IllegalStateException;
+
+import java.util.List;
+import java.util.ArrayList;
+
+import java.util.concurrent.TimeUnit;
+
+import android.app.Activity;
+
+import android.content.ContentResolver;
+import android.content.Context;
+import android.content.Intent;
+
+import android.os.Build;
+import android.os.Bundle;
+import android.os.SystemClock;
+
+import android.util.Log;
+
+import android.net.Uri;
+
+import android.view.Menu;
+import android.view.View;
+import android.view.ViewTreeObserver;
+import android.view.Window;
+import android.view.WindowInsets;
+import android.view.WindowInsetsController;
+
+import android.widget.FrameLayout;
+
+public class EmacsActivity extends Activity
+ implements EmacsWindowAttachmentManager.WindowConsumer,
+ ViewTreeObserver.OnGlobalLayoutListener
+{
+ public static final String TAG = "EmacsActivity";
+
+ /* ID for URIs from a granted document tree. */
+ public static final int ACCEPT_DOCUMENT_TREE = 1;
+
+ /* The currently attached EmacsWindow, or null if none. */
+ private EmacsWindow window;
+
+ /* The frame layout associated with the activity. */
+ private FrameLayout layout;
+
+ /* List of activities with focus. */
+ public static final List<EmacsActivity> focusedActivities;
+
+ /* The last activity to have been focused. */
+ public static EmacsActivity lastFocusedActivity;
+
+ /* The currently focused window. */
+ public static EmacsWindow focusedWindow;
+
+ /* Whether or not this activity is paused. */
+ private boolean isPaused;
+
+ /* Whether or not this activity is fullscreen. */
+ private boolean isFullscreen;
+
+ /* The last context menu to be closed. */
+ private static Menu lastClosedMenu;
+
+ /* The time of the most recent call to onStop. */
+ private static long timeOfLastInteraction;
+
+ static
+ {
+ focusedActivities = new ArrayList<EmacsActivity> ();
+ };
+
+ public static void
+ invalidateFocus1 (EmacsWindow window, boolean resetWhenChildless)
+ {
+ if (window.view.isFocused ())
+ focusedWindow = window;
+
+ synchronized (window.children)
+ {
+ for (EmacsWindow child : window.children)
+ invalidateFocus1 (child, false);
+
+ /* If no focused window was previously detected among WINDOW's
+ children and RESETWHENCHILDLESS is set (implying it is a
+ toplevel window), request that it be focused, to avoid
+ creating a situation where no windows exist focused or can be
+ transferred the input focus by user action. */
+ if (focusedWindow == null && resetWhenChildless)
+ {
+ window.view.requestFocus ();
+ focusedWindow = window;
+ }
+ }
+ }
+
+ public static void
+ invalidateFocus (int whence)
+ {
+ EmacsWindow oldFocus;
+
+ /* Walk through each focused activity and assign the window focus
+ to the bottom-most focused window within. Record the old focus
+ as well. */
+ oldFocus = focusedWindow;
+ focusedWindow = null;
+
+ for (EmacsActivity activity : focusedActivities)
+ {
+ if (activity.window != null)
+ invalidateFocus1 (activity.window, focusedWindow == null);
+ }
+
+ /* Send focus in- and out- events to the previous and current
+ focus. */
+
+ if (oldFocus != null)
+ EmacsNative.sendFocusOut (oldFocus.handle,
+ System.currentTimeMillis ());
+
+ if (focusedWindow != null)
+ EmacsNative.sendFocusIn (focusedWindow.handle,
+ System.currentTimeMillis ());
+ }
+
+ @Override
+ public final void
+ detachWindow ()
+ {
+ syncFullscreenWith (null);
+
+ if (window == null)
+ Log.w (TAG, "detachWindow called, but there is no window");
+ else
+ {
+ /* Clear the window's pointer to this activity and remove the
+ window's view. */
+ window.setConsumer (null);
+
+ /* The window can't be iconified any longer. */
+ window.noticeDeiconified ();
+ layout.removeView (window.view);
+ window = null;
+
+ invalidateFocus (0);
+ }
+ }
+
+ @Override
+ public final void
+ attachWindow (EmacsWindow child)
+ {
+ if (window != null)
+ throw new IllegalStateException ("trying to attach window when one"
+ + " already exists");
+
+ syncFullscreenWith (child);
+
+ /* Record and attach the view. */
+
+ window = child;
+ layout.addView (window.view);
+ child.setConsumer (this);
+
+ /* If the window isn't no-focus-on-map, focus its view. */
+ if (!child.getDontFocusOnMap ())
+ window.view.requestFocus ();
+
+ /* If the activity is iconified, send that to the window. */
+ if (isPaused)
+ window.noticeIconified ();
+
+ /* Invalidate the focus. Since attachWindow may be called from
+ either the main or the UI thread, post this to the UI thread. */
+
+ runOnUiThread (new Runnable () {
+ @Override
+ public void
+ run ()
+ {
+ invalidateFocus (1);
+ }
+ });
+ }
+
+ @Override
+ public final void
+ destroy ()
+ {
+ finish ();
+ }
+
+ @Override
+ public final EmacsWindow
+ getAttachedWindow ()
+ {
+ return window;
+ }
+
+ @Override
+ public final void
+ onCreate (Bundle savedInstanceState)
+ {
+ FrameLayout.LayoutParams params;
+ Intent intent;
+ View decorView;
+ ViewTreeObserver observer;
+ int matchParent;
+
+ /* See if Emacs should be started with any extra arguments, such
+ as `--quick'. */
+ intent = getIntent ();
+ EmacsService.extraStartupArgument
+ = intent.getStringExtra ("org.gnu.emacs.STARTUP_ARGUMENT");
+
+ matchParent = FrameLayout.LayoutParams.MATCH_PARENT;
+ params
+ = new FrameLayout.LayoutParams (matchParent,
+ matchParent);
+
+ /* Make the frame layout. */
+ layout = new FrameLayout (this);
+ layout.setLayoutParams (params);
+
+ /* Set it as the content view. */
+ setContentView (layout);
+
+ /* Maybe start the Emacs service if necessary. */
+ EmacsService.startEmacsService (this);
+
+ /* Add this activity to the list of available activities. */
+ EmacsWindowAttachmentManager.MANAGER.registerWindowConsumer (this);
+
+ /* Start observing global layout changes between Jelly Bean and Q.
+ This is required to restore the fullscreen state whenever the
+ on screen keyboard is displayed, as there is otherwise no way
+ to determine when the on screen keyboard becomes visible. */
+
+ if (Build.VERSION.SDK_INT >= Build.VERSION_CODES.JELLY_BEAN
+ && Build.VERSION.SDK_INT < Build.VERSION_CODES.R)
+ {
+ decorView = getWindow ().getDecorView ();
+ observer = decorView.getViewTreeObserver ();
+ observer.addOnGlobalLayoutListener (this);
+ }
+
+ super.onCreate (savedInstanceState);
+
+ /* Call `onWindowFocusChanged' to read the focus state, which fails
+ to be called after an activity is recreated. */
+ onWindowFocusChanged (false);
+ }
+
+ @Override
+ public final void
+ onGlobalLayout ()
+ {
+ syncFullscreenWith (window);
+ }
+
+ @Override
+ public final void
+ onStop ()
+ {
+ timeOfLastInteraction = SystemClock.elapsedRealtime ();
+
+ super.onStop ();
+ }
+
+ /* Return whether the task is being finished in response to explicit
+ user action. That is to say, Activity.isFinished, but as
+ documented. */
+
+ public final boolean
+ isReallyFinishing ()
+ {
+ long atime, dtime;
+ int hours;
+
+ if (Build.VERSION.SDK_INT < Build.VERSION_CODES.N)
+ return isFinishing ();
+
+ /* When the number of tasks retained in the recents list exceeds a
+ threshold, Android 7 and later so destroy activities in trimming
+ them from recents on the expiry of a timeout that isFinishing
+ returns true, in direct contradiction to the documentation. This
+ timeout is generally 6 hours, but admits of customization by
+ individual system distributors, so to err on the side of the
+ caution, the timeout Emacs applies is a more conservative figure
+ of 4 hours. */
+
+ if (timeOfLastInteraction == 0)
+ return isFinishing ();
+
+ atime = timeOfLastInteraction;
+
+ /* Compare atime with the current system time. */
+ dtime = SystemClock.elapsedRealtime () - atime;
+ if (dtime + 1000000 < TimeUnit.HOURS.toMillis (4))
+ return isFinishing ();
+
+ return false;
+ }
+
+ @Override
+ public final void
+ onDestroy ()
+ {
+ EmacsWindowAttachmentManager manager;
+ boolean isMultitask;
+
+ manager = EmacsWindowAttachmentManager.MANAGER;
+
+ /* The activity will die shortly hereafter. If there is a window
+ attached, close it now. */
+ isMultitask = this instanceof EmacsMultitaskActivity;
+ manager.removeWindowConsumer (this, (isMultitask
+ || isReallyFinishing ()));
+ focusedActivities.remove (this);
+ invalidateFocus (2);
+
+ /* Remove this activity from the static field, lest it leak. */
+ if (lastFocusedActivity == this)
+ lastFocusedActivity = null;
+
+ super.onDestroy ();
+ }
+
+ @Override
+ public final void
+ onWindowFocusChanged (boolean isFocused)
+ {
+ /* At times and on certain versions of Android ISFOCUSED does not
+ reflect whether the window actually holds focus, so replace it
+ with the value of `hasWindowFocus'. */
+ isFocused = hasWindowFocus ();
+
+ if (isFocused)
+ {
+ if (!focusedActivities.contains (this))
+ focusedActivities.add (this);
+
+ lastFocusedActivity = this;
+
+ /* Update the window insets as the focus change may have
+ changed the window insets as well, and the system does not
+ automatically restore visibility flags. */
+
+ if (Build.VERSION.SDK_INT >= Build.VERSION_CODES.JELLY_BEAN
+ && Build.VERSION.SDK_INT < Build.VERSION_CODES.R
+ && isFullscreen)
+ syncFullscreenWith (window);
+ }
+ else
+ focusedActivities.remove (this);
+
+ invalidateFocus (3);
+ }
+
+ @Override
+ public final void
+ onPause ()
+ {
+ isPaused = true;
+
+ EmacsWindowAttachmentManager.MANAGER.noticeIconified (this);
+ super.onPause ();
+ }
+
+ @Override
+ public final void
+ onResume ()
+ {
+ isPaused = false;
+ timeOfLastInteraction = 0;
+
+ EmacsWindowAttachmentManager.MANAGER.noticeDeiconified (this);
+ super.onResume ();
+ }
+
+ @Override
+ public final void
+ onContextMenuClosed (Menu menu)
+ {
+ int serial;
+
+ /* See the comment inside onMenuItemClick. */
+
+ if (((EmacsContextMenu.wasSubmenuSelected == -2)
+ || (EmacsContextMenu.wasSubmenuSelected >= 0
+ && ((System.currentTimeMillis ()
+ - EmacsContextMenu.wasSubmenuSelected)
+ <= 300)))
+ || menu == lastClosedMenu)
+ {
+ EmacsContextMenu.wasSubmenuSelected = -1;
+ lastClosedMenu = menu;
+ return;
+ }
+
+ /* lastClosedMenu is set because Android apparently calls this
+ function twice. */
+
+ lastClosedMenu = null;
+
+ /* Send a context menu event given that no menu item has already
+ been selected. */
+ if (!EmacsContextMenu.itemAlreadySelected)
+ {
+ serial = EmacsContextMenu.lastMenuEventSerial;
+ EmacsNative.sendContextMenu ((short) 0, 0,
+ serial);
+ }
+
+ super.onContextMenuClosed (menu);
+ }
+
+ @SuppressWarnings ("deprecation")
+ public final void
+ syncFullscreenWith (EmacsWindow emacsWindow)
+ {
+ WindowInsetsController controller;
+ Window window;
+ int behavior, flags;
+ View view;
+
+ if (emacsWindow != null)
+ isFullscreen = emacsWindow.fullscreen;
+ else
+ isFullscreen = false;
+
+ /* On Android 11 or later, use the window insets controller to
+ control whether or not the view is fullscreen. */
+
+ if (Build.VERSION.SDK_INT >= Build.VERSION_CODES.R)
+ {
+ window = getWindow ();
+
+ /* If there is no attached window, return immediately. */
+ if (window == null)
+ return;
+
+ behavior = WindowInsetsController.BEHAVIOR_SHOW_TRANSIENT_BARS_BY_SWIPE;
+ controller = window.getInsetsController ();
+ controller.setSystemBarsBehavior (behavior);
+
+ if (isFullscreen)
+ controller.hide (WindowInsets.Type.statusBars ()
+ | WindowInsets.Type.navigationBars ());
+ else
+ controller.show (WindowInsets.Type.statusBars ()
+ | WindowInsets.Type.navigationBars ());
+
+ return;
+ }
+
+ if (Build.VERSION.SDK_INT >= Build.VERSION_CODES.JELLY_BEAN)
+ {
+ /* On Android 4.1 or later, use `setSystemUiVisibility'. */
+
+ window = getWindow ();
+
+ if (window == null)
+ return;
+
+ view = window.getDecorView ();
+
+ if (isFullscreen)
+ {
+ flags = 0;
+ flags |= View.SYSTEM_UI_FLAG_FULLSCREEN;
+
+ if (Build.VERSION.SDK_INT >= Build.VERSION_CODES.KITKAT)
+ {
+ /* These flags means that Emacs will be full screen as
+ long as the state flag is set. */
+ flags |= View.SYSTEM_UI_FLAG_HIDE_NAVIGATION;
+ flags |= View.SYSTEM_UI_FLAG_IMMERSIVE;
+ flags |= View.SYSTEM_UI_FLAG_IMMERSIVE_STICKY;
+ }
+
+ /* Apply the given flags. */
+ view.setSystemUiVisibility (flags);
+ }
+ else
+ view.setSystemUiVisibility (View.SYSTEM_UI_FLAG_VISIBLE);
+ }
+ }
+
+ @Override
+ public final void
+ onAttachedToWindow ()
+ {
+ super.onAttachedToWindow ();
+
+ /* Update the window insets. */
+ syncFullscreenWith (window);
+ }
+
+ @Override
+ public final void
+ onNewIntent (Intent intent)
+ {
+ String tag, action;
+
+ /* This function is called when EmacsActivity is relaunched from a
+ notification. */
+
+ if (intent == null || EmacsService.SERVICE == null)
+ return;
+
+ tag = intent.getStringExtra (EmacsDesktopNotification.NOTIFICATION_TAG);
+ action
+ = intent.getStringExtra (EmacsDesktopNotification.NOTIFICATION_ACTION);
+
+ if (tag == null || action == null)
+ return;
+
+ EmacsNative.sendNotificationAction (tag, action);
+ }
+
+
+ @Override
+ public final void
+ onActivityResult (int requestCode, int resultCode, Intent data)
+ {
+ ContentResolver resolver;
+ Uri uri;
+ int flags;
+
+ switch (requestCode)
+ {
+ case ACCEPT_DOCUMENT_TREE:
+
+ /* A document granted through
+ EmacsService.requestDirectoryAccess. */
+
+ if (resultCode == RESULT_OK)
+ {
+ resolver = getContentResolver ();
+ uri = data.getData ();
+ flags = (Intent.FLAG_GRANT_READ_URI_PERMISSION
+ | Intent.FLAG_GRANT_WRITE_URI_PERMISSION);
+
+ try
+ {
+ if (uri != null)
+ resolver.takePersistableUriPermission (uri, flags);
+ }
+ catch (Exception exception)
+ {
+ /* Permission to access URI might've been revoked in
+ between selecting the file and this callback being
+ invoked. Don't crash in such cases. */
+ }
+ }
+
+ break;
+ }
+ }
+};
diff --git a/java/org/gnu/emacs/EmacsApplication.java b/java/org/gnu/emacs/EmacsApplication.java
new file mode 100644
index 00000000000..b5f8e688b65
--- /dev/null
+++ b/java/org/gnu/emacs/EmacsApplication.java
@@ -0,0 +1,159 @@
+/* Communication module for Android terminals. -*- c-file-style: "GNU" -*-
+
+Copyright (C) 2023-2024 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 <https://www.gnu.org/licenses/>. */
+
+package org.gnu.emacs;
+
+import java.io.File;
+import java.io.FileFilter;
+
+import android.content.Context;
+
+import android.app.Application;
+
+import android.content.pm.ApplicationInfo;
+import android.content.pm.PackageManager.ApplicationInfoFlags;
+import android.content.pm.PackageManager;
+
+import android.os.Build;
+
+import android.util.Log;
+
+public final class EmacsApplication extends Application
+{
+ private static final String TAG = "EmacsApplication";
+
+ /* The name of the dump file to use, or NULL if this Emacs binary
+ has yet to be dumped. */
+ public static String dumpFileName;
+
+ /* The name of the APK file housing Emacs, or NULL if it could not
+ be ascertained. */
+ public static String apkFileName;
+
+ @SuppressWarnings ("deprecation")
+ private String
+ getApkFile ()
+ {
+ PackageManager manager;
+ ApplicationInfo info;
+
+ manager = getPackageManager ();
+
+ try
+ {
+ if (Build.VERSION.SDK_INT < Build.VERSION_CODES.TIRAMISU)
+ info = manager.getApplicationInfo ("org.gnu.emacs", 0);
+ else
+ info = manager.getApplicationInfo ("org.gnu.emacs",
+ ApplicationInfoFlags.of (0));
+
+ /* Return an empty string upon failure. */
+
+ if (info.sourceDir != null)
+ return info.sourceDir;
+
+ return null;
+ }
+ catch (Exception e)
+ {
+ return null;
+ }
+ }
+
+ public static void
+ findDumpFile (Context context)
+ {
+ File filesDirectory, apk;
+ File[] allFiles;
+ String wantedDumpFile;
+ int i;
+
+ wantedDumpFile = ("emacs-" + EmacsNative.getFingerprint ()
+ + ".pdmp");
+
+ /* Obtain a list of all files ending with ``.pdmp''. Then, look
+ for a file named ``emacs-<fingerprint>.pdmp'' and delete the
+ rest. */
+ filesDirectory = context.getFilesDir ();
+
+ allFiles = filesDirectory.listFiles (new FileFilter () {
+ @Override
+ public boolean
+ accept (File file)
+ {
+ return (!file.isDirectory ()
+ && file.getName ().endsWith (".pdmp"));
+ }
+ });
+
+ if (allFiles == null)
+ return;
+
+ /* Now try to find the right dump file. */
+ for (i = 0; i < allFiles.length; ++i)
+ {
+ if (allFiles[i].getName ().equals (wantedDumpFile))
+ {
+ /* Compare the last modified time of the dumpfile with
+ that of apkFileName, the time at which Emacs was
+ installed. Delete it if the dump file was created
+ before Emacs was installed, even if the C signature
+ (representing libemacs.so) remains identical. */
+
+ if (apkFileName != null)
+ {
+ apk = new File (apkFileName);
+
+ if (apk.lastModified ()
+ > allFiles[i].lastModified ())
+ {
+ allFiles[i].delete ();
+
+ /* Don't set the dump file name in this case. */
+ continue;
+ }
+ }
+
+ dumpFileName = allFiles[i].getAbsolutePath ();
+ }
+ else
+ /* Delete this outdated dump file. */
+ allFiles[i].delete ();
+ }
+ }
+
+ @Override
+ public void
+ onCreate ()
+ {
+ /* Block signals which don't interest the current thread and its
+ descendants created by the system. The original signal mask
+ will be restored for the Emacs thread in `initEmacs'. */
+ EmacsNative.setupSystemThread ();
+
+ /* Establish the name of the APK. */
+ apkFileName = getApkFile ();
+
+ /* Locate a suitable dump file. */
+ findDumpFile (this);
+
+ /* Start the rest of the application. */
+ super.onCreate ();
+ }
+};
diff --git a/java/org/gnu/emacs/EmacsClipboard.java b/java/org/gnu/emacs/EmacsClipboard.java
new file mode 100644
index 00000000000..9db436ca1e2
--- /dev/null
+++ b/java/org/gnu/emacs/EmacsClipboard.java
@@ -0,0 +1,47 @@
+/* Communication module for Android terminals. -*- c-file-style: "GNU" -*-
+
+Copyright (C) 2023-2024 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 <https://www.gnu.org/licenses/>. */
+
+package org.gnu.emacs;
+
+import android.os.Build;
+
+/* This class provides helper code for accessing the clipboard,
+ abstracting between the different interfaces on API 8 and 11. */
+
+public abstract class EmacsClipboard
+{
+ public abstract void setClipboard (byte[] bytes);
+ public abstract int ownsClipboard ();
+ public abstract boolean clipboardExists ();
+ public abstract byte[] getClipboard ();
+
+ public abstract byte[][] getClipboardTargets ();
+ public abstract long[] getClipboardData (byte[] target);
+
+ /* Create the correct kind of clipboard for this system. */
+
+ public static EmacsClipboard
+ makeClipboard ()
+ {
+ if (Build.VERSION.SDK_INT >= Build.VERSION_CODES.HONEYCOMB)
+ return new EmacsSdk11Clipboard ();
+ else
+ return new EmacsSdk8Clipboard ();
+ }
+};
diff --git a/java/org/gnu/emacs/EmacsContextMenu.java b/java/org/gnu/emacs/EmacsContextMenu.java
new file mode 100644
index 00000000000..2bbf2a313d6
--- /dev/null
+++ b/java/org/gnu/emacs/EmacsContextMenu.java
@@ -0,0 +1,405 @@
+/* Communication module for Android terminals. -*- c-file-style: "GNU" -*-
+
+Copyright (C) 2023-2024 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 <https://www.gnu.org/licenses/>. */
+
+package org.gnu.emacs;
+
+import java.util.List;
+import java.util.ArrayList;
+
+import java.util.concurrent.Callable;
+import java.util.concurrent.FutureTask;
+
+import android.content.Context;
+import android.content.Intent;
+
+import android.os.Build;
+
+import android.view.ContextMenu;
+import android.view.Menu;
+import android.view.MenuItem;
+import android.view.View;
+import android.view.SubMenu;
+
+import android.util.Log;
+
+/* Context menu implementation. This object is built from JNI and
+ describes a menu hierarchy. Then, `inflate' can turn it into an
+ Android menu, which can be turned into a popup (or other kind of)
+ menu. */
+
+public final class EmacsContextMenu
+{
+ private static final String TAG = "EmacsContextMenu";
+
+ /* Whether or not an item was selected. */
+ public static boolean itemAlreadySelected;
+
+ /* Whether or not a submenu was selected.
+ Value is -1 if no; value is -2 if yes, and a context menu
+ close event will definitely be sent. Any other value is
+ the timestamp when the submenu was selected. */
+ public static long wasSubmenuSelected;
+
+ /* The serial ID of the last context menu to be displayed. */
+ public static int lastMenuEventSerial;
+
+ /* The last group ID used for a menu item. */
+ public int lastGroupId;
+
+ private static final class Item implements MenuItem.OnMenuItemClickListener
+ {
+ public int itemID;
+ public String itemName, tooltip;
+ public EmacsContextMenu subMenu;
+ public boolean isEnabled, isCheckable, isChecked;
+ public EmacsView inflatedView;
+ public boolean isRadio;
+
+ @Override
+ public boolean
+ onMenuItemClick (MenuItem item)
+ {
+ if (subMenu != null)
+ {
+ /* Android 6.0 and earlier don't support nested submenus
+ properly, so display the submenu popup by hand. */
+
+ if (Build.VERSION.SDK_INT < Build.VERSION_CODES.N)
+ {
+ /* Still set wasSubmenuSelected -- if not set, the
+ dismissal of this context menu will result in a
+ context menu event being sent. */
+ wasSubmenuSelected = -2;
+
+ /* Running a popup menu from inside a click handler
+ doesn't work, so make sure it is displayed
+ outside. */
+
+ inflatedView.post (new Runnable () {
+ @Override
+ public void
+ run ()
+ {
+ inflatedView.popupMenu (subMenu, 0, 0, true);
+ }
+ });
+
+ return true;
+ }
+
+ /* After opening a submenu within a submenu, Android will
+ send onContextMenuClosed for a ContextMenuBuilder. This
+ will normally confuse Emacs into thinking that the
+ context menu has been dismissed. Wrong!
+
+ Setting this flag makes EmacsActivity to only handle
+ SubMenuBuilder being closed, which always means the menu
+ has actually been dismissed.
+
+ However, these extraneous events aren't sent on devices
+ where submenus display without dismissing their parents.
+ Thus, only ignore the close event if it happens within
+ 300 milliseconds of the submenu being selected. */
+ wasSubmenuSelected = System.currentTimeMillis ();
+ return false;
+ }
+
+ /* Send a context menu event. */
+ EmacsNative.sendContextMenu ((short) 0, itemID,
+ lastMenuEventSerial);
+
+ /* Say that an item has already been selected. */
+ itemAlreadySelected = true;
+ return true;
+ }
+ };
+
+ /* List of menu items contained in this menu. */
+ public List<Item> menuItems;
+
+ /* The parent context menu, or NULL if none. */
+ private EmacsContextMenu parent;
+
+ /* The title of this context menu, or NULL if none. */
+ private String title;
+
+
+
+ /* Create a context menu with no items inside and the title TITLE,
+ which may be NULL. */
+
+ public static EmacsContextMenu
+ createContextMenu (String title)
+ {
+ EmacsContextMenu menu;
+
+ menu = new EmacsContextMenu ();
+ menu.title = title;
+ menu.menuItems = new ArrayList<Item> ();
+
+ return menu;
+ }
+
+ /* Add a normal menu item to the context menu with the id ITEMID and
+ the name ITEMNAME. Enable it if ISENABLED, else keep it
+ disabled.
+
+ If this is not a submenu and ISCHECKABLE is set, make the item
+ checkable. Likewise, if ISCHECKED is set, make the item
+ checked.
+
+ If TOOLTIP is non-NULL, set the menu item tooltip to TOOLTIP.
+
+ If ISRADIO, then display the check mark as a radio button. */
+
+ public void
+ addItem (int itemID, String itemName, boolean isEnabled,
+ boolean isCheckable, boolean isChecked,
+ String tooltip, boolean isRadio)
+ {
+ Item item;
+
+ item = new Item ();
+ item.itemID = itemID;
+ item.itemName = itemName;
+ item.isEnabled = isEnabled;
+ item.isCheckable = isCheckable;
+ item.isChecked = isChecked;
+ item.tooltip = tooltip;
+ item.isRadio = isRadio;
+
+ menuItems.add (item);
+ }
+
+ /* Create a disabled menu item with the name ITEMNAME. */
+
+ public void
+ addPane (String itemName)
+ {
+ Item item;
+
+ item = new Item ();
+ item.itemName = itemName;
+
+ menuItems.add (item);
+ }
+
+ /* Add a submenu to the context menu with the specified title and
+ item name. */
+
+ public EmacsContextMenu
+ addSubmenu (String itemName, String tooltip)
+ {
+ EmacsContextMenu submenu;
+ Item item;
+
+ item = new Item ();
+ item.itemID = 0;
+ item.itemName = itemName;
+ item.tooltip = tooltip;
+ item.subMenu = createContextMenu (itemName);
+ item.subMenu.parent = this;
+
+ menuItems.add (item);
+ return item.subMenu;
+ }
+
+ /* Add the contents of this menu to MENU. Assume MENU will be
+ displayed in INFLATEDVIEW. */
+
+ private void
+ inflateMenuItems (Menu menu, EmacsView inflatedView)
+ {
+ Intent intent;
+ MenuItem menuItem;
+ SubMenu submenu;
+
+ for (Item item : menuItems)
+ {
+ if (item.subMenu != null)
+ {
+ /* This is a submenu. On versions of Android which
+ support doing so, create the submenu and add the
+ contents of the menu to it.
+
+ Note that Android 4.0 and later technically supports
+ having multiple layers of nested submenus, but if they
+ are used, onContextMenuClosed becomes unreliable. */
+
+ if (Build.VERSION.SDK_INT >= Build.VERSION_CODES.N)
+ {
+ submenu = menu.addSubMenu (item.itemName);
+ item.subMenu.inflateMenuItems (submenu, inflatedView);
+
+ /* This is still needed to set wasSubmenuSelected. */
+ menuItem = submenu.getItem ();
+ }
+ else
+ menuItem = menu.add (item.itemName);
+
+ item.inflatedView = inflatedView;
+ menuItem.setOnMenuItemClickListener (item);
+ }
+ else
+ {
+ if (item.isRadio)
+ menuItem = menu.add (++lastGroupId, Menu.NONE, Menu.NONE,
+ item.itemName);
+ else
+ menuItem = menu.add (item.itemName);
+ menuItem.setOnMenuItemClickListener (item);
+
+ /* If the item ID is zero, then disable the item. */
+ if (item.itemID == 0 || !item.isEnabled)
+ menuItem.setEnabled (false);
+
+ /* Now make the menu item display a checkmark as
+ appropriate. */
+
+ if (item.isCheckable)
+ menuItem.setCheckable (true);
+
+ if (item.isChecked)
+ menuItem.setChecked (true);
+
+ /* Define an exclusively checkable group if the item is a
+ radio button. */
+
+ if (item.isRadio)
+ menu.setGroupCheckable (lastGroupId, true, true);
+
+ /* If the tooltip text is set and the system is new enough
+ to support menu item tooltips, set it on the item. */
+
+ if (item.tooltip != null
+ && Build.VERSION.SDK_INT >= Build.VERSION_CODES.O)
+ menuItem.setTooltipText (item.tooltip);
+ }
+ }
+ }
+
+ /* Enter the items in this context menu to MENU.
+ Assume that MENU will be displayed in VIEW; this may lead to
+ popupMenu being called on VIEW if a submenu is selected.
+
+ If MENU is a ContextMenu, set its header title to the one
+ contained in this object. */
+
+ public void
+ expandTo (Menu menu, EmacsView view)
+ {
+ inflateMenuItems (menu, view);
+
+ /* See if menu is a ContextMenu and a title is set. */
+ if (title == null || !(menu instanceof ContextMenu))
+ return;
+
+ /* Set its title to this.title. */
+ ((ContextMenu) menu).setHeaderTitle (title);
+ }
+
+ /* Return the parent or NULL. */
+
+ public EmacsContextMenu
+ parent ()
+ {
+ return this.parent;
+ }
+
+ /* Like display, but does the actual work and runs in the main
+ thread. */
+
+ private boolean
+ display1 (EmacsWindow window, int xPosition, int yPosition)
+ {
+ /* Set this flag to false. It is used to decide whether or not to
+ send 0 in response to the context menu being closed. */
+ itemAlreadySelected = false;
+
+ /* No submenu has been selected yet. */
+ wasSubmenuSelected = -1;
+
+ return window.view.popupMenu (this, xPosition, yPosition,
+ false);
+ }
+
+ /* Display this context menu on WINDOW, at xPosition and yPosition.
+ SERIAL is a number that will be returned in any menu event
+ generated to identify this context menu. */
+
+ public boolean
+ display (final EmacsWindow window, final int xPosition,
+ final int yPosition, final int serial)
+ {
+ FutureTask<Boolean> task;
+
+ /* Android will permanently cease to display any popup menus at
+ all if the list of menu items is empty. Prevent this by
+ promptly returning if there are no menu items. */
+
+ if (menuItems.isEmpty ())
+ return false;
+
+ task = new FutureTask<Boolean> (new Callable<Boolean> () {
+ @Override
+ public Boolean
+ call ()
+ {
+ boolean rc;
+
+ lastMenuEventSerial = serial;
+ rc = display1 (window, xPosition, yPosition);
+
+ /* Android 3.0 to Android 7.0 perform duplicate calls to
+ onContextMenuClosed the second time a context menu is
+ dismissed. Since the second call after such a dismissal is
+ otherwise liable to prematurely cancel any context menu
+ displayed immediately afterwards, ignore calls received
+ within 150 milliseconds of this menu's being displayed. */
+
+ if (rc && Build.VERSION.SDK_INT >= Build.VERSION_CODES.HONEYCOMB
+ && Build.VERSION.SDK_INT < Build.VERSION_CODES.N)
+ wasSubmenuSelected = System.currentTimeMillis () - 150;
+
+ return rc;
+ }
+ });
+
+ return EmacsService.<Boolean>syncRunnable (task);
+ }
+
+ /* Dismiss this context menu. WINDOW is the window where the
+ context menu is being displayed. */
+
+ public void
+ dismiss (final EmacsWindow window)
+ {
+ Runnable runnable;
+
+ EmacsService.SERVICE.runOnUiThread (new Runnable () {
+ @Override
+ public void
+ run ()
+ {
+ window.view.cancelPopupMenu ();
+ itemAlreadySelected = false;
+ }
+ });
+ }
+};
diff --git a/java/org/gnu/emacs/EmacsCursor.java b/java/org/gnu/emacs/EmacsCursor.java
new file mode 100644
index 00000000000..1049c03d7da
--- /dev/null
+++ b/java/org/gnu/emacs/EmacsCursor.java
@@ -0,0 +1,47 @@
+/* Communication module for Android terminals. -*- c-file-style: "GNU" -*-
+
+Copyright (C) 2023-2024 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 <https://www.gnu.org/licenses/>. */
+
+package org.gnu.emacs;
+
+import android.view.PointerIcon;
+import android.os.Build;
+
+/* Cursor wrapper. Note that pointer icons are not supported prior to
+ Android 24. */
+
+public final class EmacsCursor extends EmacsHandleObject
+{
+ /* The pointer icon associated with this cursor. */
+ public final PointerIcon icon;
+
+ public
+ EmacsCursor (short handle, int glyph)
+ {
+ super (handle);
+
+ if (Build.VERSION.SDK_INT < Build.VERSION_CODES.N)
+ {
+ icon = null;
+ return;
+ }
+
+ icon = PointerIcon.getSystemIcon (EmacsService.SERVICE,
+ glyph);
+ }
+};
diff --git a/java/org/gnu/emacs/EmacsDesktopNotification.java b/java/org/gnu/emacs/EmacsDesktopNotification.java
new file mode 100644
index 00000000000..72569631a8c
--- /dev/null
+++ b/java/org/gnu/emacs/EmacsDesktopNotification.java
@@ -0,0 +1,344 @@
+/* Communication module for Android terminals. -*- c-file-style: "GNU" -*-
+
+Copyright (C) 2023-2024 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 <https://www.gnu.org/licenses/>. */
+
+package org.gnu.emacs;
+
+import android.app.Notification;
+import android.app.NotificationManager;
+import android.app.NotificationChannel;
+import android.app.PendingIntent;
+
+import android.content.BroadcastReceiver;
+import android.content.Context;
+import android.content.Intent;
+
+import android.net.Uri;
+
+import android.os.Build;
+
+import android.widget.RemoteViews;
+
+
+
+/* Structure designating a single desktop notification.
+
+ New versions of Android also organize notifications into individual
+ ``channels'', which are used to implement groups. Unlike on other
+ systems, notification importance is set for each group, not for
+ each individual notification. */
+
+
+
+public final class EmacsDesktopNotification
+{
+ /* Intent tag for notification action data. */
+ public static final String NOTIFICATION_ACTION = "emacs:notification_action";
+
+ /* Intent tag for notification IDs. */
+ public static final String NOTIFICATION_TAG = "emacs:notification_tag";
+
+ /* Action ID assigned to the broadcast receiver which should be
+ notified of any notification's being dismissed. */
+ public static final String NOTIFICATION_DISMISSED = "org.gnu.emacs.DISMISSED";
+
+ /* The content of this desktop notification. */
+ public final String content;
+
+ /* The title of this desktop notification. */
+ public final String title;
+
+ /* The notification group. */
+ public final String group;
+
+ /* String identifying this notification for future replacement.
+ Typically a string resembling ``XXXX.NNNN.YYYY'', where XXXX is
+ the system boot time, NNNN is the PID of this Emacs instance, and
+ YYYY is the counter value returned by the notifications display
+ function. */
+ public final String tag;
+
+ /* The identifier of this notification's icon. */
+ public final int icon;
+
+ /* The importance of this notification's group. */
+ public final int importance;
+
+ /* Array of actions and their user-facing text to be offered by this
+ notification. */
+ public final String[] actions, titles;
+
+ /* Delay in miliseconds after which this notification should be
+ automatically dismissed. */
+ public final long delay;
+
+ public
+ EmacsDesktopNotification (String title, String content,
+ String group, String tag, int icon,
+ int importance,
+ String[] actions, String[] titles,
+ long delay)
+ {
+ this.content = content;
+ this.title = title;
+ this.group = group;
+ this.tag = tag;
+ this.icon = icon;
+ this.importance = importance;
+ this.actions = actions;
+ this.titles = titles;
+ this.delay = delay;
+ }
+
+
+
+ /* Functions for displaying desktop notifications. */
+
+ /* Insert each action in actions and titles into the notification
+ builder BUILDER, with pending intents created with CONTEXT holding
+ suitable metadata. */
+
+ @SuppressWarnings ("deprecation")
+ private void
+ insertActions (Context context, Notification.Builder builder)
+ {
+ int i;
+ PendingIntent pending;
+ Intent intent;
+ Notification.Action.Builder action;
+
+ if (actions == null)
+ return;
+
+ for (i = 0; i < actions.length; ++i)
+ {
+ /* Actions named default should not be displayed. */
+ if (actions[i].equals ("default"))
+ continue;
+
+ intent = new Intent (context, EmacsActivity.class);
+ intent.addFlags (Intent.FLAG_ACTIVITY_NEW_TASK);
+
+ /* Pending intents are specific to combinations of class, action
+ and data, but not information provided as extras. In order
+ that its target may be invoked with the action and tag set
+ below, generate a URL from those two elements and specify it
+ as the intent data, which ensures that the intent allocated
+ fully reflects the duo. */
+
+ intent.setData (new Uri.Builder ().scheme ("action")
+ .appendPath (tag).appendPath (actions[i])
+ .build ());
+ intent.putExtra (NOTIFICATION_ACTION, actions[i]);
+ intent.putExtra (NOTIFICATION_TAG, tag);
+
+ if (Build.VERSION.SDK_INT >= Build.VERSION_CODES.S)
+ pending = PendingIntent.getActivity (context, 0, intent,
+ PendingIntent.FLAG_IMMUTABLE);
+ else
+ pending = PendingIntent.getActivity (context, 0, intent, 0);
+
+ if (Build.VERSION.SDK_INT >= Build.VERSION_CODES.M)
+ {
+ action = new Notification.Action.Builder (0, titles[i], pending);
+ builder.addAction (action.build ());
+ }
+ else
+ builder.addAction (0, titles[i], pending);
+ }
+ }
+
+ /* Internal helper for `display' executed on the main thread. */
+
+ @SuppressWarnings ("deprecation") /* Notification.Builder (Context). */
+ private void
+ display1 (Context context)
+ {
+ NotificationManager manager;
+ NotificationChannel channel;
+ Notification notification;
+ Object tem;
+ RemoteViews contentView;
+ Intent intent;
+ PendingIntent pending;
+ int priority;
+ Notification.Builder builder;
+
+ tem = context.getSystemService (Context.NOTIFICATION_SERVICE);
+ manager = (NotificationManager) tem;
+
+ if (Build.VERSION.SDK_INT >= Build.VERSION_CODES.O)
+ {
+ /* Create the notification channel for this group. If a group
+ already exists with the same name, its linked attributes
+ (such as its importance) will be overridden. */
+ channel = new NotificationChannel (group, group, importance);
+ manager.createNotificationChannel (channel);
+ builder = new Notification.Builder (context, group);
+
+ /* Create and configure a notification object and display
+ it. */
+
+ builder.setContentTitle (title);
+ builder.setContentText (content);
+ builder.setSmallIcon (icon);
+ builder.setTimeoutAfter (delay);
+
+ insertActions (context, builder);
+ notification = builder.build ();
+ }
+ else if (Build.VERSION.SDK_INT >= Build.VERSION_CODES.HONEYCOMB)
+ {
+ /* Android 7.1 and earlier don't segregate notifications into
+ distinct categories, but permit an importance to be
+ assigned to each individual notification. */
+
+ builder = new Notification.Builder (context);
+ builder.setContentTitle (title);
+ builder.setContentText (content);
+ builder.setSmallIcon (icon);
+
+ if (Build.VERSION.SDK_INT >= Build.VERSION_CODES.JELLY_BEAN)
+ {
+ switch (importance)
+ {
+ case 2: /* IMPORTANCE_LOW */
+ default:
+ priority = Notification.PRIORITY_LOW;
+ break;
+
+ case 3: /* IMPORTANCE_DEFAULT */
+ priority = Notification.PRIORITY_DEFAULT;
+ break;
+
+ case 4: /* IMPORTANCE_HIGH */
+ priority = Notification.PRIORITY_HIGH;
+ break;
+ }
+
+ builder.setPriority (priority);
+ insertActions (context, builder);
+ notification = builder.build ();
+ }
+ else
+ notification = builder.getNotification ();
+ }
+ else
+ {
+ notification = new Notification ();
+ notification.icon = icon;
+
+ /* This remote widget tree is defined in
+ java/res/layout/sdk8_notifications_view.xml. */
+ notification.contentView
+ = contentView
+ = new RemoteViews ("org.gnu.emacs",
+ R.layout.sdk8_notifications_view);
+ contentView.setTextViewText (R.id.sdk8_notifications_title,
+ title);
+ contentView.setTextViewText (R.id.sdk8_notifications_content,
+ content);
+ }
+
+ /* Provide a content intent which starts Emacs when the
+ notification is clicked. */
+
+ intent = new Intent (context, EmacsActivity.class);
+ intent.addFlags (Intent.FLAG_ACTIVITY_NEW_TASK);
+ intent.setData (new Uri.Builder ()
+ .scheme ("action")
+ .appendPath (tag)
+ .build ());
+ intent.putExtra (NOTIFICATION_ACTION, "default");
+ intent.putExtra (NOTIFICATION_TAG, tag);
+
+ if (Build.VERSION.SDK_INT >= Build.VERSION_CODES.S)
+ pending = PendingIntent.getActivity (context, 0, intent,
+ PendingIntent.FLAG_IMMUTABLE);
+ else
+ pending = PendingIntent.getActivity (context, 0, intent, 0);
+
+ notification.contentIntent = pending;
+
+ /* Provide a cancellation intent to respond to notification
+ dismissals. */
+
+ intent = new Intent (context, CancellationReceiver.class);
+ intent.setAction (NOTIFICATION_DISMISSED);
+ intent.setPackage ("org.gnu.emacs");
+ intent.setData (new Uri.Builder ()
+ .scheme ("action")
+ .appendPath (tag)
+ .build ());
+ intent.putExtra (NOTIFICATION_TAG, tag);
+
+ if (Build.VERSION.SDK_INT >= Build.VERSION_CODES.S)
+ pending = PendingIntent.getBroadcast (context, 0, intent,
+ PendingIntent.FLAG_IMMUTABLE);
+ else
+ pending = PendingIntent.getBroadcast (context, 0, intent, 0);
+
+ notification.deleteIntent = pending;
+ manager.notify (tag, 2, notification);
+ }
+
+ /* Display this desktop notification.
+
+ Create a notification channel named GROUP or update its
+ importance if such a channel is already defined. */
+
+ public void
+ display ()
+ {
+ EmacsService.SERVICE.runOnUiThread (new Runnable () {
+ @Override
+ public void
+ run ()
+ {
+ display1 (EmacsService.SERVICE);
+ }
+ });
+ }
+
+
+
+ /* Broadcast receiver. This is something of a system-wide callback
+ arranged to be invoked whenever a notification posted by Emacs is
+ dismissed, in order to relay news of its dismissal to
+ androidselect.c and run or remove callbacks as appropriate. */
+
+ public static class CancellationReceiver extends BroadcastReceiver
+ {
+ @Override
+ public void
+ onReceive (Context context, Intent intent)
+ {
+ String tag, action;
+
+ if (intent == null || EmacsService.SERVICE == null)
+ return;
+
+ tag = intent.getStringExtra (NOTIFICATION_TAG);
+
+ if (tag == null)
+ return;
+
+ EmacsNative.sendNotificationDeleted (tag);
+ }
+ };
+};
diff --git a/java/org/gnu/emacs/EmacsDialog.java b/java/org/gnu/emacs/EmacsDialog.java
new file mode 100644
index 00000000000..0d5b650f7d0
--- /dev/null
+++ b/java/org/gnu/emacs/EmacsDialog.java
@@ -0,0 +1,419 @@
+/* Communication module for Android terminals. -*- c-file-style: "GNU" -*-
+
+Copyright (C) 2023-2024 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 <https://www.gnu.org/licenses/>. */
+
+package org.gnu.emacs;
+
+import java.util.List;
+import java.util.ArrayList;
+
+import java.util.concurrent.Callable;
+import java.util.concurrent.FutureTask;
+
+import android.app.AlertDialog;
+
+import android.content.Context;
+import android.content.DialogInterface;
+
+import android.content.res.Resources.NotFoundException;
+import android.content.res.Resources.Theme;
+import android.content.res.TypedArray;
+
+import android.os.Build;
+
+import android.provider.Settings;
+
+import android.util.Log;
+
+import android.widget.Button;
+import android.widget.LinearLayout;
+import android.widget.FrameLayout;
+
+import android.view.ContextThemeWrapper;
+import android.view.View;
+import android.view.ViewGroup;
+import android.view.Window;
+import android.view.WindowManager;
+
+/* Toolkit dialog implementation. This object is built from JNI and
+ describes a single alert dialog. Then, `inflate' turns it into
+ AlertDialog. */
+
+public final class EmacsDialog implements DialogInterface.OnDismissListener
+{
+ private static final String TAG = "EmacsDialog";
+
+ /* List of buttons in this dialog. */
+ private List<EmacsButton> buttons;
+
+ /* Dialog title. */
+ private String title;
+
+ /* Dialog text. */
+ private String text;
+
+ /* Whether or not a selection has already been made. */
+ private boolean wasButtonClicked;
+
+ /* Dialog to dismiss after click. */
+ private AlertDialog dismissDialog;
+
+ /* The menu serial associated with this dialog box. */
+ private int menuEventSerial;
+
+ private final class EmacsButton implements View.OnClickListener,
+ DialogInterface.OnClickListener
+ {
+ /* Name of this button. */
+ public String name;
+
+ /* ID of this button. */
+ public int id;
+
+ /* Whether or not the button is enabled. */
+ public boolean enabled;
+
+ @Override
+ public void
+ onClick (View view)
+ {
+ wasButtonClicked = true;
+ EmacsNative.sendContextMenu ((short) 0, id, menuEventSerial);
+ dismissDialog.dismiss ();
+ }
+
+ @Override
+ public void
+ onClick (DialogInterface dialog, int which)
+ {
+ wasButtonClicked = true;
+ EmacsNative.sendContextMenu ((short) 0, id, menuEventSerial);
+ }
+ };
+
+ /* Create a popup dialog with the title TITLE and the text TEXT.
+ TITLE may be NULL. MENUEVENTSERIAL is a number which will
+ identify this popup dialog inside events it sends. */
+
+ public static EmacsDialog
+ createDialog (String title, String text, int menuEventSerial)
+ {
+ EmacsDialog dialog;
+
+ dialog = new EmacsDialog ();
+ dialog.buttons = new ArrayList<EmacsButton> ();
+ dialog.title = title;
+ dialog.text = text;
+ dialog.menuEventSerial = menuEventSerial;
+
+ return dialog;
+ }
+
+ /* Add a button named NAME, with the identifier ID. If DISABLE,
+ disable the button. */
+
+ public void
+ addButton (String name, int id, boolean disable)
+ {
+ EmacsButton button;
+
+ button = new EmacsButton ();
+ button.name = name;
+ button.id = id;
+ button.enabled = !disable;
+ buttons.add (button);
+ }
+
+ /* Turn this dialog into an AlertDialog for the specified
+ CONTEXT.
+
+ Upon a button being selected, the dialog will send an
+ ANDROID_CONTEXT_MENU event with the id of that button.
+
+ Upon the dialog being dismissed, an ANDROID_CONTEXT_MENU event
+ will be sent with an id of 0. */
+
+ public AlertDialog
+ toAlertDialog (Context context)
+ {
+ AlertDialog dialog;
+ int size, styleId, flag;
+ int[] attrs;
+ EmacsButton button;
+ EmacsDialogButtonLayout layout;
+ Button buttonView;
+ ViewGroup.LayoutParams layoutParams;
+ Theme theme;
+ TypedArray attributes;
+ Window window;
+
+ /* Wrap the context within a style wrapper. Any dialog properties
+ tied to EmacsStyle (such as those applied by the system ``dark
+ theme'') will thus affect the dialog irrespective of whether
+ CONTEXT is an activity or the service. */
+
+ context = new ContextThemeWrapper (context, R.style.EmacsStyle);
+
+ size = buttons.size ();
+ styleId = -1;
+
+ if (size <= 3)
+ {
+ dialog = new AlertDialog.Builder (context).create ();
+ dialog.setMessage (text);
+ dialog.setCancelable (true);
+ dialog.setOnDismissListener (this);
+
+ if (title != null)
+ dialog.setTitle (title);
+
+ /* There are less than 4 buttons. Add the buttons the way
+ Android intends them to be added. */
+
+ if (size >= 1)
+ {
+ button = buttons.get (0);
+ dialog.setButton (DialogInterface.BUTTON_POSITIVE,
+ button.name, button);
+ }
+
+ if (size >= 2)
+ {
+ button = buttons.get (1);
+ dialog.setButton (DialogInterface.BUTTON_NEGATIVE,
+ button.name, button);
+ }
+
+ if (size >= 3)
+ {
+ button = buttons.get (2);
+ dialog.setButton (DialogInterface.BUTTON_NEUTRAL,
+ button.name, button);
+ }
+ }
+ else
+ {
+ /* There are more than 3 buttons. Add them all to a special
+ container widget that handles wrapping. First, create the
+ layout. */
+
+ layout = new EmacsDialogButtonLayout (context);
+ layoutParams
+ = new FrameLayout.LayoutParams (ViewGroup.LayoutParams.MATCH_PARENT,
+ ViewGroup.LayoutParams.WRAP_CONTENT);
+ layout.setLayoutParams (layoutParams);
+
+ /* Add that layout to the dialog's custom view.
+
+ android.R.id.custom is documented to work. But looking it
+ up returns NULL, so setView must be used instead. */
+
+ dialog = new AlertDialog.Builder (context).setView (layout).create ();
+ dialog.setMessage (text);
+ dialog.setCancelable (true);
+ dialog.setOnDismissListener (this);
+
+ if (title != null)
+ dialog.setTitle (title);
+
+ /* Now that the dialog has been created, set the style of each
+ custom button to match the usual dialog buttons found on
+ Android 5 and later. */
+
+ if (Build.VERSION.SDK_INT >= Build.VERSION_CODES.LOLLIPOP)
+ {
+ /* Obtain the Theme associated with the dialog. */
+ theme = dialog.getContext ().getTheme ();
+
+ /* Resolve the dialog button style. */
+ attrs
+ = new int [] { android.R.attr.buttonBarNeutralButtonStyle, };
+
+ try
+ {
+ attributes = theme.obtainStyledAttributes (attrs);
+
+ /* Look for the style ID. Default to -1 if it could
+ not be found. */
+ styleId = attributes.getResourceId (0, -1);
+
+ /* Now clean up the TypedAttributes object. */
+ attributes.recycle ();
+ }
+ catch (NotFoundException e)
+ {
+ /* Nothing to do here. */
+ }
+ }
+
+ /* Create each button and add it to the layout. Set the style
+ if necessary. */
+
+ for (EmacsButton emacsButton : buttons)
+ {
+ if (styleId == -1)
+ /* No specific style... */
+ buttonView = new Button (context);
+ else
+ /* Use the given styleId. */
+ buttonView = new Button (context, null, 0, styleId);
+
+ /* Set the text and on click handler. */
+ buttonView.setText (emacsButton.name);
+ buttonView.setOnClickListener (emacsButton);
+ buttonView.setEnabled (emacsButton.enabled);
+ layout.addView (buttonView);
+ }
+ }
+
+ return dialog;
+ }
+
+ /* Internal helper for display run on the main thread. */
+
+ @SuppressWarnings("deprecation")
+ private boolean
+ display1 ()
+ {
+ Context context;
+ int size, type;
+ Button buttonView;
+ EmacsButton button;
+ AlertDialog dialog;
+ Window window;
+
+ if (EmacsActivity.focusedActivities.isEmpty ())
+ {
+ /* If focusedActivities is empty then this dialog may have
+ been displayed immediately after another popup dialog was
+ dismissed. Or Emacs might legitimately be in the
+ background, possibly displaying this popup in response to
+ an Emacsclient request. Try the service context if it will
+ work, then any focused EmacsOpenActivity, and finally the
+ last EmacsActivity to be focused. */
+
+ if (Build.VERSION.SDK_INT < Build.VERSION_CODES.M
+ || Settings.canDrawOverlays (EmacsService.SERVICE))
+ context = EmacsService.SERVICE;
+ else if (EmacsOpenActivity.currentActivity != null)
+ context = EmacsOpenActivity.currentActivity;
+ else
+ context = EmacsActivity.lastFocusedActivity;
+
+ if (context == null)
+ return false;
+ }
+ else
+ /* Display using the activity context when Emacs is in the
+ foreground, as this allows the dialog to be dismissed more
+ consistently. */
+ context = EmacsActivity.focusedActivities.get (0);
+
+ dialog = dismissDialog = toAlertDialog (context);
+
+ try
+ {
+ if (context == EmacsService.SERVICE)
+ {
+ /* Apply the system alert window type to make sure this
+ dialog can be displayed. */
+
+ window = dialog.getWindow ();
+ type = (Build.VERSION.SDK_INT >= Build.VERSION_CODES.O
+ ? WindowManager.LayoutParams.TYPE_APPLICATION_OVERLAY
+ : WindowManager.LayoutParams.TYPE_PHONE);
+ window.setType (type);
+ }
+
+ dismissDialog.show ();
+ }
+ catch (Exception exception)
+ {
+ /* This can happen when the system decides Emacs is not in the
+ foreground any longer. */
+ return false;
+ }
+
+ /* If there are less than four buttons, then they must be
+ individually enabled or disabled after the dialog is
+ displayed. */
+ size = buttons.size ();
+
+ if (size <= 3)
+ {
+ if (size >= 1)
+ {
+ button = buttons.get (0);
+ buttonView
+ = dialog.getButton (DialogInterface.BUTTON_POSITIVE);
+ buttonView.setEnabled (button.enabled);
+ }
+
+ if (size >= 2)
+ {
+ button = buttons.get (1);
+ buttonView
+ = dialog.getButton (DialogInterface.BUTTON_NEGATIVE);
+ buttonView.setEnabled (button.enabled);
+ }
+
+ if (size >= 3)
+ {
+ button = buttons.get (2);
+ buttonView
+ = dialog.getButton (DialogInterface.BUTTON_NEUTRAL);
+ buttonView.setEnabled (button.enabled);
+ }
+ }
+
+ return true;
+ }
+
+ /* Display this dialog for a suitable activity.
+ Value is false if the dialog could not be displayed,
+ and true otherwise. */
+
+ public boolean
+ display ()
+ {
+ FutureTask<Boolean> task;
+
+ task = new FutureTask<Boolean> (new Callable<Boolean> () {
+ @Override
+ public Boolean
+ call ()
+ {
+ return display1 ();
+ }
+ });
+
+ return EmacsService.<Boolean>syncRunnable (task);
+ }
+
+
+
+ @Override
+ public void
+ onDismiss (DialogInterface dialog)
+ {
+ if (wasButtonClicked)
+ return;
+
+ EmacsNative.sendContextMenu ((short) 0, 0, menuEventSerial);
+ }
+};
diff --git a/java/org/gnu/emacs/EmacsDialogButtonLayout.java b/java/org/gnu/emacs/EmacsDialogButtonLayout.java
new file mode 100644
index 00000000000..da57d1c4404
--- /dev/null
+++ b/java/org/gnu/emacs/EmacsDialogButtonLayout.java
@@ -0,0 +1,152 @@
+/* Communication module for Android terminals. -*- c-file-style: "GNU" -*-
+
+Copyright (C) 2023-2024 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 <https://www.gnu.org/licenses/>. */
+
+package org.gnu.emacs;
+
+
+
+import android.content.Context;
+
+import android.view.View;
+import android.view.View.MeasureSpec;
+import android.view.ViewGroup;
+
+
+
+/* This ``view group'' implements a container widget for multiple
+ buttons of the type found in pop-up dialogs. It is used when
+ displaying a dialog box that contains more than three buttons, as
+ the default dialog box widget is not capable of holding more than
+ that many. */
+
+
+
+public final class EmacsDialogButtonLayout extends ViewGroup
+{
+ public
+ EmacsDialogButtonLayout (Context context)
+ {
+ super (context);
+ }
+
+ @Override
+ protected void
+ onMeasure (int widthMeasureSpec, int heightMeasureSpec)
+ {
+ int width, count, i, x, y, height, spec, tempSpec;
+ View view;
+
+ /* Obtain the width of this widget and create the measure
+ specification used to measure children. */
+
+ width = MeasureSpec.getSize (widthMeasureSpec);
+ spec = MeasureSpec.makeMeasureSpec (0, MeasureSpec.UNSPECIFIED);
+ tempSpec
+ = MeasureSpec.makeMeasureSpec (width, MeasureSpec.AT_MOST);
+ x = y = height = 0;
+
+ /* Run through each widget. */
+
+ count = getChildCount ();
+
+ for (i = 0; i < count; ++i)
+ {
+ view = getChildAt (i);
+
+ /* Measure this view. */
+ view.measure (spec, spec);
+
+ if (width - x < view.getMeasuredWidth ())
+ {
+ /* Move onto the next line, unless this line is empty. */
+
+ if (x != 0)
+ {
+ y += height;
+ height = x = 0;
+ }
+
+ if (view.getMeasuredWidth () > width)
+ /* Measure the view again, this time forcing it to be at
+ most width wide, if it is not already. */
+ view.measure (tempSpec, spec);
+ }
+
+ height = Math.max (height, view.getMeasuredHeight ());
+ x += view.getMeasuredWidth ();
+ }
+
+ /* Now set the measured size of this widget. */
+ setMeasuredDimension (width, y + height);
+ }
+
+ @Override
+ protected void
+ onLayout (boolean changed, int left, int top, int right,
+ int bottom)
+ {
+ int width, count, i, x, y, height, spec, tempSpec;
+ View view;
+
+ /* Obtain the width of this widget and create the measure
+ specification used to measure children. */
+
+ width = getMeasuredWidth ();
+ spec = MeasureSpec.makeMeasureSpec (0, MeasureSpec.UNSPECIFIED);
+ tempSpec
+ = MeasureSpec.makeMeasureSpec (width, MeasureSpec.AT_MOST);
+ x = y = height = 0;
+
+ /* Run through each widget. */
+
+ count = getChildCount ();
+
+ for (i = 0; i < count; ++i)
+ {
+ view = getChildAt (i);
+
+ /* Measure this view. */
+ view.measure (spec, spec);
+
+ if (width - x < view.getMeasuredWidth ())
+ {
+ /* Move onto the next line, unless this line is empty. */
+
+ if (x != 0)
+ {
+ y += height;
+ height = x = 0;
+ }
+
+ if (view.getMeasuredWidth () > width)
+ /* Measure the view again, this time forcing it to be at
+ most width wide, if it is not already. */
+ view.measure (tempSpec, spec);
+ }
+
+ /* Now assign this view its position. */
+ view.layout (x, y, x + view.getMeasuredWidth (),
+ y + view.getMeasuredHeight ());
+
+ /* And move on to the next widget. */
+ height = Math.max (height, view.getMeasuredHeight ());
+ x += view.getMeasuredWidth ();
+ }
+ }
+};
diff --git a/java/org/gnu/emacs/EmacsDirectoryEntry.java b/java/org/gnu/emacs/EmacsDirectoryEntry.java
new file mode 100644
index 00000000000..4a7526dddc6
--- /dev/null
+++ b/java/org/gnu/emacs/EmacsDirectoryEntry.java
@@ -0,0 +1,33 @@
+/* Communication module for Android terminals. -*- c-file-style: "GNU" -*-
+
+Copyright (C) 2023-2024 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 <https://www.gnu.org/licenses/>. */
+
+package org.gnu.emacs;
+
+/* Structure holding a single ``directory entry'' from a document
+ provider. */
+
+public final class EmacsDirectoryEntry
+{
+ /* The type of this directory entry. 0 means a regular file and 1
+ means a directory. */
+ public int d_type;
+
+ /* The display name of the file represented. */
+ public String d_name;
+};
diff --git a/java/org/gnu/emacs/EmacsDocumentsProvider.java b/java/org/gnu/emacs/EmacsDocumentsProvider.java
new file mode 100644
index 00000000000..7c5de9e0e14
--- /dev/null
+++ b/java/org/gnu/emacs/EmacsDocumentsProvider.java
@@ -0,0 +1,578 @@
+/* Communication module for Android terminals. -*- c-file-style: "GNU" -*-
+
+Copyright (C) 2023-2024 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 <https://www.gnu.org/licenses/>. */
+
+package org.gnu.emacs;
+
+import android.content.Context;
+
+import android.database.Cursor;
+import android.database.MatrixCursor;
+
+import android.os.Build;
+import android.os.CancellationSignal;
+import android.os.ParcelFileDescriptor;
+
+import android.provider.DocumentsContract.Document;
+import android.provider.DocumentsContract.Root;
+import static android.provider.DocumentsContract.buildChildDocumentsUri;
+import android.provider.DocumentsProvider;
+
+import android.webkit.MimeTypeMap;
+
+import android.net.Uri;
+
+import java.io.File;
+import java.io.FileInputStream;
+import java.io.FileNotFoundException;
+import java.io.FileOutputStream;
+import java.io.IOException;
+
+/* ``Documents provider''. This allows Emacs's home directory to be
+ modified by other programs holding permissions to manage system
+ storage, which is useful to (for example) correct misconfigurations
+ which prevent Emacs from starting up.
+
+ This functionality is only available on Android 19 and later. */
+
+public final class EmacsDocumentsProvider extends DocumentsProvider
+{
+ /* Home directory. This is the directory whose contents are
+ initially returned to requesting applications. */
+ private File baseDir;
+
+ /* The default projection for requests for the root directory. */
+ private static final String[] DEFAULT_ROOT_PROJECTION;
+
+ /* The default projection for requests for a file. */
+ private static final String[] DEFAULT_DOCUMENT_PROJECTION;
+
+ static
+ {
+ DEFAULT_ROOT_PROJECTION = new String[] {
+ Root.COLUMN_ROOT_ID,
+ Root.COLUMN_MIME_TYPES,
+ Root.COLUMN_FLAGS,
+ Root.COLUMN_ICON,
+ Root.COLUMN_TITLE,
+ Root.COLUMN_SUMMARY,
+ Root.COLUMN_DOCUMENT_ID,
+ Root.COLUMN_AVAILABLE_BYTES,
+ };
+
+ DEFAULT_DOCUMENT_PROJECTION = new String[] {
+ Document.COLUMN_DOCUMENT_ID,
+ Document.COLUMN_MIME_TYPE,
+ Document.COLUMN_DISPLAY_NAME,
+ Document.COLUMN_LAST_MODIFIED,
+ Document.COLUMN_FLAGS,
+ Document.COLUMN_SIZE,
+ };
+ }
+
+ @Override
+ public boolean
+ onCreate ()
+ {
+ /* Set the base directory to Emacs's files directory. */
+ baseDir = getContext ().getFilesDir ();
+ return true;
+ }
+
+ @Override
+ public Cursor
+ queryRoots (String[] projection)
+ {
+ MatrixCursor result;
+ MatrixCursor.RowBuilder row;
+
+ /* If the requestor asked for nothing at all, then it wants some
+ data by default. */
+
+ if (projection == null)
+ projection = DEFAULT_ROOT_PROJECTION;
+
+ result = new MatrixCursor (projection);
+ row = result.newRow ();
+
+ /* Now create and add a row for each file in the base
+ directory. */
+ row.add (Root.COLUMN_ROOT_ID, baseDir.getAbsolutePath ());
+ row.add (Root.COLUMN_SUMMARY, "Emacs home directory");
+
+ /* Add the appropriate flags. */
+
+ row.add (Root.COLUMN_FLAGS, (Root.FLAG_SUPPORTS_CREATE
+ | Root.FLAG_SUPPORTS_IS_CHILD));
+ row.add (Root.COLUMN_ICON, R.drawable.emacs);
+ row.add (Root.FLAG_LOCAL_ONLY);
+ row.add (Root.COLUMN_TITLE, "Emacs");
+ row.add (Root.COLUMN_DOCUMENT_ID, baseDir.getAbsolutePath ());
+
+ return result;
+ }
+
+ private Uri
+ getNotificationUri (File file)
+ {
+ Uri updatedUri;
+
+ updatedUri
+ = buildChildDocumentsUri ("org.gnu.emacs",
+ file.getAbsolutePath ());
+
+ return updatedUri;
+ }
+
+ /* Inform the system that FILE's contents (or FILE itself) has
+ changed. */
+
+ private void
+ notifyChange (File file)
+ {
+ Uri updatedUri;
+ Context context;
+
+ context = getContext ();
+ updatedUri
+ = buildChildDocumentsUri ("org.gnu.emacs",
+ file.getAbsolutePath ());
+ context.getContentResolver ().notifyChange (updatedUri, null);
+ }
+
+ /* Inform the system that FILE's contents (or FILE itself) has
+ changed. FILE is a string describing containing the file name of
+ a directory as opposed to a File. */
+
+ private void
+ notifyChangeByName (String file)
+ {
+ Uri updatedUri;
+ Context context;
+
+ context = getContext ();
+ updatedUri
+ = buildChildDocumentsUri ("org.gnu.emacs", file);
+ context.getContentResolver ().notifyChange (updatedUri, null);
+ }
+
+ /* Return the MIME type of a file FILE. */
+
+ private String
+ getMimeType (File file)
+ {
+ String name, extension, mime;
+ int extensionSeparator;
+ MimeTypeMap singleton;
+
+ if (file.isDirectory ())
+ return Document.MIME_TYPE_DIR;
+
+ /* Abuse WebView stuff to get the file's MIME type. */
+ name = file.getName ();
+ extensionSeparator = name.lastIndexOf ('.');
+
+ if (extensionSeparator > 0)
+ {
+ singleton = MimeTypeMap.getSingleton ();
+ extension = name.substring (extensionSeparator + 1);
+ mime = singleton.getMimeTypeFromExtension (extension);
+
+ if (mime != null)
+ return mime;
+ }
+
+ return "application/octet-stream";
+ }
+
+ /* Append the specified FILE to the query result RESULT.
+ Handle both directories and ordinary files. */
+
+ private void
+ queryDocument1 (MatrixCursor result, File file)
+ {
+ MatrixCursor.RowBuilder row;
+ String fileName, displayName, mimeType;
+ int flags;
+
+ row = result.newRow ();
+ flags = 0;
+
+ /* fileName is a string that the system will ask for some time in
+ the future. Here, it is just the absolute name of the file. */
+ fileName = file.getAbsolutePath ();
+
+ /* If file is a directory, add the right flags for that. */
+
+ if (file.isDirectory ())
+ {
+ if (file.canWrite ())
+ {
+ flags |= Document.FLAG_DIR_SUPPORTS_CREATE;
+ flags |= Document.FLAG_SUPPORTS_DELETE;
+
+ if (Build.VERSION.SDK_INT >= Build.VERSION_CODES.LOLLIPOP)
+ flags |= Document.FLAG_SUPPORTS_RENAME;
+
+ if (Build.VERSION.SDK_INT >= Build.VERSION_CODES.N)
+ flags |= Document.FLAG_SUPPORTS_MOVE;
+ }
+ }
+ else if (file.canWrite ())
+ {
+ /* Apply the correct flags for a writable file. */
+ flags |= Document.FLAG_SUPPORTS_WRITE;
+ flags |= Document.FLAG_SUPPORTS_DELETE;
+
+ if (Build.VERSION.SDK_INT >= Build.VERSION_CODES.LOLLIPOP)
+ flags |= Document.FLAG_SUPPORTS_RENAME;
+
+ if (Build.VERSION.SDK_INT >= Build.VERSION_CODES.N)
+ {
+ flags |= Document.FLAG_SUPPORTS_REMOVE;
+ flags |= Document.FLAG_SUPPORTS_MOVE;
+ }
+ }
+
+ displayName = file.getName ();
+ mimeType = getMimeType (file);
+
+ row.add (Document.COLUMN_DOCUMENT_ID, fileName);
+ row.add (Document.COLUMN_DISPLAY_NAME, displayName);
+ row.add (Document.COLUMN_SIZE, file.length ());
+ row.add (Document.COLUMN_MIME_TYPE, mimeType);
+ row.add (Document.COLUMN_LAST_MODIFIED, file.lastModified ());
+ row.add (Document.COLUMN_FLAGS, flags);
+ }
+
+ @Override
+ public Cursor
+ queryDocument (String documentId, String[] projection)
+ throws FileNotFoundException
+ {
+ MatrixCursor result;
+ File file;
+ Context context;
+
+ file = new File (documentId);
+ context = getContext ();
+
+ if (projection == null)
+ projection = DEFAULT_DOCUMENT_PROJECTION;
+
+ result = new MatrixCursor (projection);
+ queryDocument1 (result, file);
+
+ /* Now allow interested applications to detect changes. */
+ result.setNotificationUri (context.getContentResolver (),
+ getNotificationUri (file));
+
+ return result;
+ }
+
+ @Override
+ public Cursor
+ queryChildDocuments (String parentDocumentId, String[] projection,
+ String sortOrder) throws FileNotFoundException
+ {
+ MatrixCursor result;
+ File directory;
+ File[] files;
+ Context context;
+
+ if (projection == null)
+ projection = DEFAULT_DOCUMENT_PROJECTION;
+
+ result = new MatrixCursor (projection);
+
+ /* Try to open the file corresponding to the location being
+ requested. */
+ directory = new File (parentDocumentId);
+
+ /* Look up each child. */
+ files = directory.listFiles ();
+
+ if (files != null)
+ {
+ /* Now add each child. */
+ for (File child : files)
+ queryDocument1 (result, child);
+ }
+
+ context = getContext ();
+
+ /* Now allow interested applications to detect changes. */
+ result.setNotificationUri (context.getContentResolver (),
+ getNotificationUri (directory));
+
+ return result;
+ }
+
+ @Override
+ public ParcelFileDescriptor
+ openDocument (String documentId, String mode,
+ CancellationSignal signal) throws FileNotFoundException
+ {
+ return ParcelFileDescriptor.open (new File (documentId),
+ ParcelFileDescriptor.parseMode (mode));
+ }
+
+ @Override
+ public String
+ createDocument (String documentId, String mimeType,
+ String displayName) throws FileNotFoundException
+ {
+ File file, parentFile;
+ boolean rc;
+
+ file = new File (documentId, displayName);
+
+ try
+ {
+ rc = false;
+
+ if (Document.MIME_TYPE_DIR.equals (mimeType))
+ {
+ file.mkdirs ();
+
+ if (file.isDirectory ())
+ rc = true;
+ }
+ else
+ {
+ file.createNewFile ();
+
+ if (file.isFile ()
+ && file.setWritable (true)
+ && file.setReadable (true))
+ rc = true;
+ }
+
+ if (!rc)
+ throw new FileNotFoundException ("rc != 1");
+ }
+ catch (IOException e)
+ {
+ throw new FileNotFoundException (e.toString ());
+ }
+
+ parentFile = file.getParentFile ();
+
+ if (parentFile != null)
+ notifyChange (parentFile);
+
+ return file.getAbsolutePath ();
+ }
+
+ private void
+ deleteDocument1 (File child)
+ {
+ File[] children;
+
+ /* Don't delete symlinks recursively.
+
+ Calling readlink or stat is problematic due to file name
+ encoding problems, so try to delete the file first, and only
+ try to delete files recursively afterword. */
+
+ if (child.delete ())
+ return;
+
+ children = child.listFiles ();
+
+ if (children != null)
+ {
+ for (File file : children)
+ deleteDocument1 (file);
+ }
+
+ child.delete ();
+ }
+
+ @Override
+ public void
+ deleteDocument (String documentId)
+ throws FileNotFoundException
+ {
+ File file, parent;
+ File[] children;
+
+ /* Java makes recursively deleting a file hard. File name
+ encoding issues also prevent easily calling into C... */
+
+ file = new File (documentId);
+ parent = file.getParentFile ();
+
+ if (parent == null)
+ throw new RuntimeException ("trying to delete file without"
+ + " parent!");
+
+ if (file.delete ())
+ {
+ /* Tell the system about the change. */
+ notifyChange (parent);
+ return;
+ }
+
+ children = file.listFiles ();
+
+ if (children != null)
+ {
+ for (File child : children)
+ deleteDocument1 (child);
+ }
+
+ if (file.delete ())
+ /* Tell the system about the change. */
+ notifyChange (parent);
+ }
+
+ @Override
+ public void
+ removeDocument (String documentId, String parentDocumentId)
+ throws FileNotFoundException
+ {
+ deleteDocument (documentId);
+ }
+
+ @Override
+ public String
+ getDocumentType (String documentId)
+ {
+ return getMimeType (new File (documentId));
+ }
+
+ @Override
+ public String
+ renameDocument (String documentId, String displayName)
+ throws FileNotFoundException
+ {
+ File file, newName;
+ File parent;
+
+ file = new File (documentId);
+ parent = file.getParentFile ();
+ newName = new File (parent, displayName);
+
+ if (parent == null)
+ throw new FileNotFoundException ("parent is null");
+
+ file = new File (documentId);
+
+ if (!file.renameTo (newName))
+ return null;
+
+ notifyChange (parent);
+ return newName.getAbsolutePath ();
+ }
+
+ @Override
+ public boolean
+ isChildDocument (String parentDocumentId, String documentId)
+ {
+ return documentId.startsWith (parentDocumentId);
+ }
+
+ @Override
+ public String
+ moveDocument (String sourceDocumentId,
+ String sourceParentDocumentId,
+ String targetParentDocumentId)
+ throws FileNotFoundException
+ {
+ File file, newName;
+ FileInputStream inputStream;
+ FileOutputStream outputStream;
+ byte buffer[];
+ int length;
+
+ file = new File (sourceDocumentId);
+
+ /* Now, create the file name of the parent document. */
+ newName = new File (targetParentDocumentId,
+ file.getName ());
+
+ /* Try to perform a simple rename, before falling back to
+ copying. */
+
+ if (file.renameTo (newName))
+ {
+ notifyChangeByName (file.getParent ());
+ notifyChangeByName (targetParentDocumentId);
+ return newName.getAbsolutePath ();
+ }
+
+ /* If that doesn't work, create the new file and copy over the old
+ file's contents. */
+
+ inputStream = null;
+ outputStream = null;
+
+ try
+ {
+ if (!newName.createNewFile ()
+ || !newName.setWritable (true)
+ || !newName.setReadable (true))
+ throw new FileNotFoundException ("failed to create new file");
+
+ /* Open the file in preparation for a copy. */
+
+ inputStream = new FileInputStream (file);
+ outputStream = new FileOutputStream (newName);
+
+ /* Allocate the buffer used to hold data. */
+
+ buffer = new byte[4096];
+
+ while ((length = inputStream.read (buffer)) > 0)
+ outputStream.write (buffer, 0, length);
+ }
+ catch (IOException e)
+ {
+ throw new FileNotFoundException ("IOException: " + e);
+ }
+ finally
+ {
+ try
+ {
+ if (inputStream != null)
+ inputStream.close ();
+ }
+ catch (IOException e)
+ {
+
+ }
+
+ try
+ {
+ if (outputStream != null)
+ outputStream.close ();
+ }
+ catch (IOException e)
+ {
+
+ }
+ }
+
+ file.delete ();
+ notifyChangeByName (file.getParent ());
+ notifyChangeByName (targetParentDocumentId);
+
+ return newName.getAbsolutePath ();
+ }
+}
diff --git a/java/org/gnu/emacs/EmacsDrawLine.java b/java/org/gnu/emacs/EmacsDrawLine.java
new file mode 100644
index 00000000000..61b7d54d63c
--- /dev/null
+++ b/java/org/gnu/emacs/EmacsDrawLine.java
@@ -0,0 +1,77 @@
+/* Communication module for Android terminals. -*- c-file-style: "GNU" -*-
+
+Copyright (C) 2023-2024 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 <https://www.gnu.org/licenses/>. */
+
+package org.gnu.emacs;
+
+import android.graphics.Canvas;
+import android.graphics.Paint;
+import android.graphics.Rect;
+
+public final class EmacsDrawLine
+{
+ public static void
+ perform (EmacsDrawable drawable, EmacsGC gc,
+ int x, int y, int x2, int y2)
+ {
+ Canvas canvas;
+ Paint paint;
+ int x0, x1, y0, y1;
+
+ /* TODO implement stippling. */
+ if (gc.fill_style == EmacsGC.GC_FILL_OPAQUE_STIPPLED)
+ return;
+
+ /* Calculate the leftmost and rightmost points. */
+
+ x0 = Math.min (x, x2 + 1);
+ x1 = Math.max (x, x2 + 1);
+ y0 = Math.min (y, y2 + 1);
+ y1 = Math.max (y, y2 + 1);
+
+ /* And the clip rectangle. */
+
+ paint = gc.gcPaint;
+ canvas = drawable.lockCanvas (gc);
+
+ if (canvas == null)
+ return;
+
+ paint.setStyle (Paint.Style.FILL);
+
+ /* Since drawLine has PostScript style behavior, adjust the
+ coordinates appropriately.
+
+ The left most pixel of a straight line is always partially
+ filled. Patch it in manually. */
+
+ if (gc.clip_mask == null)
+ {
+ canvas.drawLine ((float) x + 0.5f, (float) y + 0.5f,
+ (float) x2 + 0.5f, (float) y2 + 0.5f,
+ paint);
+
+ if (x2 > x)
+ canvas.drawRect (new Rect (x, y, x + 1, y + 1), paint);
+ }
+
+ /* DrawLine with clip mask not implemented; it is not used by
+ Emacs. */
+ drawable.damageRect (x0, y0, x1, y1);
+ }
+}
diff --git a/java/org/gnu/emacs/EmacsDrawPoint.java b/java/org/gnu/emacs/EmacsDrawPoint.java
new file mode 100644
index 00000000000..859c590b1d0
--- /dev/null
+++ b/java/org/gnu/emacs/EmacsDrawPoint.java
@@ -0,0 +1,34 @@
+/* Communication module for Android terminals. -*- c-file-style: "GNU" -*-
+
+Copyright (C) 2023-2024 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 <https://www.gnu.org/licenses/>. */
+
+package org.gnu.emacs;
+
+public final class EmacsDrawPoint
+{
+ public static void
+ perform (EmacsDrawable drawable,
+ EmacsGC immutableGC, int x, int y)
+ {
+ /* Use EmacsFillRectangle instead of EmacsDrawRectangle, as the
+ latter actually draws a rectangle one pixel wider than
+ specified. */
+ EmacsFillRectangle.perform (drawable, immutableGC,
+ x, y, 1, 1);
+ }
+}
diff --git a/java/org/gnu/emacs/EmacsDrawRectangle.java b/java/org/gnu/emacs/EmacsDrawRectangle.java
new file mode 100644
index 00000000000..a8f68c6530a
--- /dev/null
+++ b/java/org/gnu/emacs/EmacsDrawRectangle.java
@@ -0,0 +1,119 @@
+/* Communication module for Android terminals. -*- c-file-style: "GNU" -*-
+
+Copyright (C) 2023-2024 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 <https://www.gnu.org/licenses/>. */
+
+package org.gnu.emacs;
+
+import android.graphics.Bitmap;
+import android.graphics.Canvas;
+import android.graphics.Paint;
+import android.graphics.Rect;
+import android.graphics.RectF;
+
+import android.util.Log;
+
+public final class EmacsDrawRectangle
+{
+ public static void
+ perform (EmacsDrawable drawable, EmacsGC gc,
+ int x, int y, int width, int height)
+ {
+ Paint maskPaint, paint;
+ Canvas maskCanvas;
+ Bitmap maskBitmap;
+ Rect maskRect, dstRect;
+ Canvas canvas;
+ Bitmap clipBitmap;
+
+ /* TODO implement stippling. */
+ if (gc.fill_style == EmacsGC.GC_FILL_OPAQUE_STIPPLED)
+ return;
+
+ canvas = drawable.lockCanvas (gc);
+
+ if (canvas == null)
+ return;
+
+ paint = gc.gcPaint;
+ paint.setStyle (Paint.Style.STROKE);
+
+ if (gc.clip_mask == null)
+ /* Use canvas.drawRect with a RectF. That seems to reliably
+ get PostScript behavior. */
+ canvas.drawRect (new RectF (x + 0.5f, y + 0.5f,
+ x + width + 0.5f,
+ y + height + 0.5f),
+ paint);
+ else
+ {
+ /* Drawing with a clip mask involves calculating the
+ intersection of the clip mask with the dst rect, and
+ extrapolating the corresponding part of the src rect. */
+ clipBitmap = gc.clip_mask.bitmap;
+ dstRect = new Rect (x, y, x + width, y + height);
+ maskRect = new Rect (gc.clip_x_origin,
+ gc.clip_y_origin,
+ (gc.clip_x_origin
+ + clipBitmap.getWidth ()),
+ (gc.clip_y_origin
+ + clipBitmap.getHeight ()));
+
+ if (!maskRect.setIntersect (dstRect, maskRect))
+ /* There is no intersection between the clip mask and the
+ dest rect. */
+ return;
+
+ /* Finally, create a temporary bitmap that is the size of
+ maskRect. */
+
+ maskBitmap
+ = Bitmap.createBitmap (maskRect.width (), maskRect.height (),
+ Bitmap.Config.ARGB_8888);
+
+ /* Draw the mask onto the maskBitmap. */
+ maskCanvas = new Canvas (maskBitmap);
+ maskRect.offset (-gc.clip_x_origin,
+ -gc.clip_y_origin);
+ maskCanvas.drawBitmap (gc.clip_mask.bitmap,
+ maskRect, new Rect (0, 0,
+ maskRect.width (),
+ maskRect.height ()),
+ paint);
+ maskRect.offset (gc.clip_x_origin,
+ gc.clip_y_origin);
+
+ /* Set the transfer mode to SRC_IN to preserve only the parts
+ of the source that overlap with the mask. */
+ maskPaint = new Paint ();
+ maskPaint.setXfermode (EmacsGC.srcInAlu);
+ maskPaint.setStyle (Paint.Style.STROKE);
+
+ /* Draw the source. */
+ maskCanvas.drawRect (maskRect, maskPaint);
+
+ /* Finally, draw the mask bitmap to the destination. */
+ paint.setXfermode (null);
+ canvas.drawBitmap (maskBitmap, null, maskRect, paint);
+
+ /* Recycle this unused bitmap. */
+ maskBitmap.recycle ();
+ }
+
+ drawable.damageRect (x, y, x + width + 1, y + height + 1);
+ }
+}
diff --git a/java/org/gnu/emacs/EmacsDrawable.java b/java/org/gnu/emacs/EmacsDrawable.java
new file mode 100644
index 00000000000..a75a8f7017d
--- /dev/null
+++ b/java/org/gnu/emacs/EmacsDrawable.java
@@ -0,0 +1,33 @@
+/* Communication module for Android terminals. -*- c-file-style: "GNU" -*-
+
+Copyright (C) 2023-2024 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 <https://www.gnu.org/licenses/>. */
+
+package org.gnu.emacs;
+
+import android.graphics.Rect;
+import android.graphics.Bitmap;
+import android.graphics.Canvas;
+
+public interface EmacsDrawable
+{
+ public Canvas lockCanvas (EmacsGC gc);
+ public void damageRect (Rect damageRect);
+ public void damageRect (int left, int top, int right, int bottom);
+ public Bitmap getBitmap ();
+ public boolean isDestroyed ();
+};
diff --git a/java/org/gnu/emacs/EmacsFillPolygon.java b/java/org/gnu/emacs/EmacsFillPolygon.java
new file mode 100644
index 00000000000..6bc8333984a
--- /dev/null
+++ b/java/org/gnu/emacs/EmacsFillPolygon.java
@@ -0,0 +1,80 @@
+/* Communication module for Android terminals. -*- c-file-style: "GNU" -*-
+
+Copyright (C) 2023-2024 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 <https://www.gnu.org/licenses/>. */
+
+package org.gnu.emacs;
+
+import android.graphics.Canvas;
+import android.graphics.Paint;
+import android.graphics.Path;
+import android.graphics.Point;
+import android.graphics.Rect;
+import android.graphics.RectF;
+
+public final class EmacsFillPolygon
+{
+ public static void
+ perform (EmacsDrawable drawable, EmacsGC gc, Point points[])
+ {
+ Canvas canvas;
+ Path path;
+ Paint paint;
+ Rect rect;
+ RectF rectF;
+ int i;
+
+ canvas = drawable.lockCanvas (gc);
+
+ if (canvas == null)
+ return;
+
+ paint = gc.gcPaint;
+
+ /* Build the path from the given array of points. */
+ path = new Path ();
+
+ if (points.length >= 1)
+ {
+ path.moveTo (points[0].x, points[0].y);
+
+ for (i = 1; i < points.length; ++i)
+ path.lineTo (points[i].x, points[i].y);
+
+ path.close ();
+ }
+
+ /* Compute the damage rectangle. */
+ rectF = new RectF (0, 0, 0, 0);
+ path.computeBounds (rectF, true);
+
+ rect = new Rect ((int) Math.floor (rectF.left),
+ (int) Math.floor (rectF.top),
+ (int) Math.ceil (rectF.right),
+ (int) Math.ceil (rectF.bottom));
+
+ paint.setStyle (Paint.Style.FILL);
+
+ if (gc.clip_mask == null)
+ canvas.drawPath (path, paint);
+
+ drawable.damageRect (rect);
+
+ /* FillPolygon with clip mask not implemented; it is not used by
+ Emacs. */
+ }
+}
diff --git a/java/org/gnu/emacs/EmacsFillRectangle.java b/java/org/gnu/emacs/EmacsFillRectangle.java
new file mode 100644
index 00000000000..ca87c06c014
--- /dev/null
+++ b/java/org/gnu/emacs/EmacsFillRectangle.java
@@ -0,0 +1,116 @@
+/* Communication module for Android terminals. -*- c-file-style: "GNU" -*-
+
+Copyright (C) 2023-2024 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 <https://www.gnu.org/licenses/>. */
+
+package org.gnu.emacs;
+
+import android.graphics.Bitmap;
+import android.graphics.Canvas;
+import android.graphics.Paint;
+import android.graphics.Rect;
+
+import android.util.Log;
+
+public final class EmacsFillRectangle
+{
+ public static void
+ perform (EmacsDrawable drawable, EmacsGC gc,
+ int x, int y, int width, int height)
+ {
+ Paint maskPaint, paint;
+ Canvas maskCanvas;
+ Bitmap maskBitmap;
+ Rect rect;
+ Rect maskRect, dstRect;
+ Canvas canvas;
+ Bitmap clipBitmap;
+
+ /* TODO implement stippling. */
+ if (gc.fill_style == EmacsGC.GC_FILL_OPAQUE_STIPPLED)
+ return;
+
+ canvas = drawable.lockCanvas (gc);
+
+ if (canvas == null)
+ return;
+
+ paint = gc.gcPaint;
+ rect = new Rect (x, y, x + width, y + height);
+
+ paint.setStyle (Paint.Style.FILL);
+
+ if (gc.clip_mask == null)
+ canvas.drawRect (rect, paint);
+ else
+ {
+ /* Drawing with a clip mask involves calculating the
+ intersection of the clip mask with the dst rect, and
+ extrapolating the corresponding part of the src rect. */
+
+ clipBitmap = gc.clip_mask.bitmap;
+ dstRect = new Rect (x, y, x + width, y + height);
+ maskRect = new Rect (gc.clip_x_origin,
+ gc.clip_y_origin,
+ (gc.clip_x_origin
+ + clipBitmap.getWidth ()),
+ (gc.clip_y_origin
+ + clipBitmap.getHeight ()));
+
+ if (!maskRect.setIntersect (dstRect, maskRect))
+ /* There is no intersection between the clip mask and the
+ dest rect. */
+ return;
+
+ /* Finally, create a temporary bitmap that is the size of
+ maskRect. */
+
+ maskBitmap
+ = Bitmap.createBitmap (maskRect.width (), maskRect.height (),
+ Bitmap.Config.ARGB_8888);
+
+ /* Draw the mask onto the maskBitmap. */
+ maskCanvas = new Canvas (maskBitmap);
+ maskRect.offset (-gc.clip_x_origin,
+ -gc.clip_y_origin);
+ maskCanvas.drawBitmap (gc.clip_mask.bitmap,
+ maskRect, new Rect (0, 0,
+ maskRect.width (),
+ maskRect.height ()),
+ paint);
+ maskRect.offset (gc.clip_x_origin,
+ gc.clip_y_origin);
+
+ /* Set the transfer mode to SRC_IN to preserve only the parts
+ of the source that overlap with the mask. */
+ maskPaint = new Paint ();
+ maskPaint.setXfermode (EmacsGC.srcInAlu);
+
+ /* Draw the source. */
+ maskCanvas.drawRect (maskRect, maskPaint);
+
+ /* Finally, draw the mask bitmap to the destination. */
+ paint.setXfermode (null);
+ canvas.drawBitmap (maskBitmap, null, maskRect, paint);
+
+ /* Recycle this unused bitmap. */
+ maskBitmap.recycle ();
+ }
+
+ drawable.damageRect (rect);
+ }
+}
diff --git a/java/org/gnu/emacs/EmacsFontDriver.java b/java/org/gnu/emacs/EmacsFontDriver.java
new file mode 100644
index 00000000000..09d0377bd5e
--- /dev/null
+++ b/java/org/gnu/emacs/EmacsFontDriver.java
@@ -0,0 +1,180 @@
+/* Font backend for Android terminals. -*- c-file-style: "GNU" -*-
+
+Copyright (C) 2023-2024 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 <https://www.gnu.org/licenses/>. */
+
+package org.gnu.emacs;
+
+import android.os.Build;
+
+/* This code is mostly unused. See sfntfont-android.c for the code
+ that is actually used. */
+
+public abstract class EmacsFontDriver
+{
+ /* Font weights. */
+ public static final int THIN = 0;
+ public static final int ULTRA_LIGHT = 40;
+ public static final int LIGHT = 50;
+ public static final int SEMI_LIGHT = 55;
+ public static final int REGULAR = 80;
+ public static final int MEDIUM = 100;
+ public static final int SEMI_BOLD = 180;
+ public static final int BOLD = 200;
+ public static final int EXTRA_BOLD = 205;
+ public static final int BLACK = 210;
+ public static final int ULTRA_HEAVY = 250;
+
+ /* Font slants. */
+ public static final int REVERSE_OBLIQUE = 0;
+ public static final int REVERSE_ITALIC = 10;
+ public static final int NORMAL = 100;
+ public static final int ITALIC = 200;
+ public static final int OBLIQUE = 210;
+
+ /* Font widths. */
+ public static final int ULTRA_CONDENSED = 50;
+ public static final int EXTRA_CONDENSED = 63;
+ public static final int CONDENSED = 75;
+ public static final int SEMI_CONDENSED = 87;
+ public static final int UNSPECIFIED = 100;
+ public static final int SEMI_EXPANDED = 113;
+ public static final int EXPANDED = 125;
+ public static final int EXTRA_EXPANDED = 150;
+ public static final int ULTRA_EXPANDED = 200;
+
+ /* Font spacings. */
+ public static final int PROPORTIONAL = 0;
+ public static final int DUAL = 90;
+ public static final int MONO = 100;
+ public static final int CHARCELL = 110;
+
+ /* Special glyph codes. */
+ public static final int FONT_INVALID_CODE = 0xFFFFFFFF;
+
+
+
+ public static class FontSpec
+ {
+ /* The fields below mean the same as they do in enum
+ font_property_index in font.h. */
+
+ public String foundry;
+ public String family;
+ public String adstyle;
+ public String registry;
+ public Integer width;
+ public Integer weight;
+ public Integer slant;
+ public Integer size;
+ public Integer spacing;
+ public Integer avgwidth;
+ public Integer dpi;
+
+ @Override
+ public String
+ toString ()
+ {
+ return ("foundry: " + foundry
+ + " family: " + family
+ + " adstyle: " + adstyle
+ + " registry: " + registry
+ + " width: " + width
+ + " weight: " + weight
+ + " slant: " + slant
+ + " spacing: " + spacing
+ + " avgwidth: " + avgwidth
+ + " dpi: " + dpi);
+ }
+ };
+
+ public static class FontMetrics
+ {
+ public short lbearing;
+ public short rbearing;
+ public short width;
+ public short ascent;
+ public short descent;
+
+ @Override
+ public String
+ toString ()
+ {
+ return ("lbearing " + lbearing
+ + " rbearing " + rbearing
+ + " width " + width
+ + " ascent " + ascent
+ + " descent " + descent);
+ }
+ }
+
+ public static class FontEntity extends FontSpec
+ {
+ /* No extra fields here. */
+ };
+
+ public abstract class FontObject extends FontSpec
+ {
+ public int minWidth;
+ public int maxWidth;
+ public int pixelSize;
+ public int height;
+ public int spaceWidth;
+ public int averageWidth;
+ public int ascent;
+ public int descent;
+ public int underlineThickness;
+ public int underlinePosition;
+ public int baselineOffset;
+ public int relativeCompose;
+ public int defaultAscent;
+ public int encodingCharset;
+ public int repertoryCharset;
+
+ public
+ FontObject ()
+ {
+ encodingCharset = -1;
+ repertoryCharset = -1;
+ }
+ };
+
+
+
+ /* These mean the same as they do in struct font_driver. */
+ public abstract FontEntity[] list (FontSpec fontSpec);
+ public abstract FontEntity match (FontSpec fontSpec);
+ public abstract String[] listFamilies ();
+ public abstract FontObject openFont (FontEntity fontEntity, int pixelSize);
+ public abstract int hasChar (FontSpec font, int charCode);
+ public abstract void textExtents (FontObject font, int code[],
+ FontMetrics fontMetrics);
+ public abstract int encodeChar (FontObject fontObject, int charCode);
+ public abstract int draw (FontObject fontObject, EmacsGC gc,
+ EmacsDrawable drawable, int[] chars,
+ int x, int y, int backgroundWidth,
+ boolean withBackground);
+
+ public static EmacsFontDriver
+ createFontDriver ()
+ {
+ if (Build.VERSION.SDK_INT >= Build.VERSION_CODES.M)
+ return new EmacsSdk23FontDriver ();
+
+ return new EmacsSdk7FontDriver ();
+ }
+};
diff --git a/java/org/gnu/emacs/EmacsGC.java b/java/org/gnu/emacs/EmacsGC.java
new file mode 100644
index 00000000000..e45f0666fe2
--- /dev/null
+++ b/java/org/gnu/emacs/EmacsGC.java
@@ -0,0 +1,121 @@
+/* Communication module for Android terminals. -*- c-file-style: "GNU" -*-
+
+Copyright (C) 2023-2024 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 <https://www.gnu.org/licenses/>. */
+
+package org.gnu.emacs;
+
+import android.graphics.Rect;
+import android.graphics.Paint;
+
+import android.graphics.PorterDuff.Mode;
+import android.graphics.PorterDuffXfermode;
+import android.graphics.Xfermode;
+
+/* X like graphics context structures. Keep the enums in synch with
+ androidgui.h! */
+
+public final class EmacsGC extends EmacsHandleObject
+{
+ public static final int GC_COPY = 0;
+ public static final int GC_XOR = 1;
+
+ public static final int GC_FILL_SOLID = 0;
+ public static final int GC_FILL_OPAQUE_STIPPLED = 1;
+
+ public static final Xfermode xorAlu, srcInAlu;
+
+ public int function, fill_style;
+ public int foreground, background;
+ public int clip_x_origin, clip_y_origin;
+ public int ts_origin_x, ts_origin_y;
+ public Rect clip_rects[], real_clip_rects[];
+ public EmacsPixmap clip_mask, stipple;
+ public Paint gcPaint;
+
+ /* ID incremented every time the clipping rectangles of any GC
+ changes. */
+ private static long clip_serial;
+
+ /* The value of clipRectID after the last time this GCs clip
+ rectangles changed. 0 if there are no clip rectangles. */
+ public long clipRectID;
+
+ static
+ {
+ xorAlu = new PorterDuffXfermode (Mode.XOR);
+ srcInAlu = new PorterDuffXfermode (Mode.SRC_IN);
+ }
+
+ /* The following fields are only set on immutable GCs. */
+
+ public
+ EmacsGC (short handle)
+ {
+ /* For historical reasons the C code has an extra layer of
+ indirection above this GC handle. struct android_gc is the GC
+ used by Emacs code, while android_gcontext is the type of the
+ handle. */
+ super (handle);
+
+ fill_style = GC_FILL_SOLID;
+ function = GC_COPY;
+ foreground = 0;
+ background = 0xffffff;
+ gcPaint = new Paint ();
+ }
+
+ /* Mark this GC as dirty. Apply parameters to the paint and
+ recompute real_clip_rects. */
+
+ public void
+ markDirty (boolean clipRectsChanged)
+ {
+ int i;
+
+ if (clipRectsChanged)
+ {
+ if ((ts_origin_x != 0 || ts_origin_y != 0)
+ && clip_rects != null)
+ {
+ real_clip_rects = new Rect[clip_rects.length];
+
+ for (i = 0; i < clip_rects.length; ++i)
+ {
+ real_clip_rects[i] = new Rect (clip_rects[i]);
+ real_clip_rects[i].offset (ts_origin_x, ts_origin_y);
+ }
+ }
+ else
+ real_clip_rects = clip_rects;
+
+ clipRectID = ++clip_serial;
+ }
+
+ gcPaint.setStrokeWidth (1f);
+ gcPaint.setColor (foreground | 0xff000000);
+ gcPaint.setXfermode (function == GC_XOR
+ ? xorAlu : srcInAlu);
+ }
+
+ public void
+ resetXfermode ()
+ {
+ gcPaint.setXfermode (function == GC_XOR
+ ? xorAlu : srcInAlu);
+ }
+};
diff --git a/java/org/gnu/emacs/EmacsHandleObject.java b/java/org/gnu/emacs/EmacsHandleObject.java
new file mode 100644
index 00000000000..8534f08519c
--- /dev/null
+++ b/java/org/gnu/emacs/EmacsHandleObject.java
@@ -0,0 +1,59 @@
+/* Communication module for Android terminals. -*- c-file-style: "GNU" -*-
+
+Copyright (C) 2023-2024 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 <https://www.gnu.org/licenses/>. */
+
+package org.gnu.emacs;
+
+import java.lang.IllegalStateException;
+
+/* This defines something that is a so-called ``handle''. Handles
+ must be created by C code, and will remain existing until
+ destroyHandle is called. C code then refers to the handle by a
+ number which maps into the Java object representing the handle.
+
+ All handle operations must be done from the Emacs thread. */
+
+public abstract class EmacsHandleObject
+{
+ /* Whether or not this handle has been destroyed. */
+ volatile boolean destroyed;
+
+ /* The handle associated with this object. */
+ public short handle;
+
+ public
+ EmacsHandleObject (short handle)
+ {
+ this.handle = handle;
+ }
+
+ public void
+ destroyHandle () throws IllegalStateException
+ {
+ synchronized (this)
+ {
+ destroyed = true;
+ }
+ }
+
+ public boolean
+ isDestroyed ()
+ {
+ return destroyed;
+ }
+};
diff --git a/java/org/gnu/emacs/EmacsHolder.java b/java/org/gnu/emacs/EmacsHolder.java
new file mode 100644
index 00000000000..6d093d27e06
--- /dev/null
+++ b/java/org/gnu/emacs/EmacsHolder.java
@@ -0,0 +1,30 @@
+/* Communication module for Android terminals. -*- c-file-style: "GNU" -*-
+
+Copyright (C) 2023-2024 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 <https://www.gnu.org/licenses/>. */
+
+package org.gnu.emacs;
+
+
+
+/* This class serves as a simple reference to an object of type T.
+ Nothing could be found inside the standard library. */
+
+public final class EmacsHolder<T>
+{
+ T thing;
+};
diff --git a/java/org/gnu/emacs/EmacsInputConnection.java b/java/org/gnu/emacs/EmacsInputConnection.java
new file mode 100644
index 00000000000..054eca66cf3
--- /dev/null
+++ b/java/org/gnu/emacs/EmacsInputConnection.java
@@ -0,0 +1,713 @@
+/* Communication module for Android terminals. -*- c-file-style: "GNU" -*-
+
+Copyright (C) 2023-2024 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 <https://www.gnu.org/licenses/>. */
+
+package org.gnu.emacs;
+
+import android.os.Build;
+import android.os.Bundle;
+import android.os.Handler;
+
+import android.view.KeyEvent;
+
+import android.view.inputmethod.CompletionInfo;
+import android.view.inputmethod.CorrectionInfo;
+import android.view.inputmethod.ExtractedText;
+import android.view.inputmethod.ExtractedTextRequest;
+import android.view.inputmethod.InputConnection;
+import android.view.inputmethod.InputContentInfo;
+import android.view.inputmethod.SurroundingText;
+import android.view.inputmethod.TextAttribute;
+import android.view.inputmethod.TextSnapshot;
+
+import android.util.Log;
+
+/* Android input methods, take number six. See textconv.c for more
+ details; this is more-or-less a thin wrapper around that file. */
+
+public final class EmacsInputConnection implements InputConnection
+{
+ private static final String TAG = "EmacsInputConnection";
+
+ /* View associated with this input connection. */
+ private EmacsView view;
+
+ /* The handle ID associated with that view's window. */
+ private short windowHandle;
+
+ /* Number of batch edits currently underway. Used to avoid
+ synchronizing with the Emacs thread after each
+ `endBatchEdit'. */
+ private int batchEditCount;
+
+ /* Whether or not to synchronize and call `updateIC' with the
+ selection position after committing text.
+
+ This helps with on screen keyboard programs found in some vendor
+ versions of Android, which rely on immediate updates to the point
+ position after text is committed in order to place the cursor
+ within that text. */
+
+ private static boolean syncAfterCommit;
+
+ /* Whether or not to return empty text with the offset set to zero
+ if a request arrives that has no flags set and has requested no
+ characters at all.
+
+ This is necessary with on screen keyboard programs found in some
+ vendor versions of Android which don't rely on the documented
+ meaning of `ExtractedText.startOffset', and instead take the
+ selection offset inside at face value. */
+
+ private static boolean extractAbsoluteOffsets;
+
+ static
+ {
+ if (Build.MANUFACTURER.equalsIgnoreCase ("Huawei")
+ || Build.MANUFACTURER.equalsIgnoreCase ("Honor"))
+ extractAbsoluteOffsets = syncAfterCommit = true;
+
+ /* The Samsung and Vivo keyboards take `selectionStart' at face
+ value if some text is returned, and also searches for words
+ solely within that text. However, when no text is returned, it
+ falls back to getTextAfterCursor and getTextBeforeCursor. */
+ if (Build.MANUFACTURER.equalsIgnoreCase ("Samsung")
+ || Build.MANUFACTURER.equalsIgnoreCase ("Vivo"))
+ extractAbsoluteOffsets = true;
+ };
+
+
+ public
+ EmacsInputConnection (EmacsView view)
+ {
+ this.view = view;
+ this.windowHandle = view.window.handle;
+ }
+
+
+ /* The functions below are called by input methods whenever they
+ need to perform an edit. */
+
+ @Override
+ public boolean
+ beginBatchEdit ()
+ {
+ /* Return if the input connection is out of date. */
+ if (view.icSerial < view.icGeneration)
+ return false;
+
+ if (EmacsService.DEBUG_IC)
+ Log.d (TAG, "beginBatchEdit");
+
+ EmacsNative.beginBatchEdit (windowHandle);
+
+ /* Keep a record of the number of outstanding batch edits here as
+ well. */
+ batchEditCount++;
+ return true;
+ }
+
+ @Override
+ public boolean
+ endBatchEdit ()
+ {
+ /* Return if the input connection is out of date. */
+ if (view.icSerial < view.icGeneration)
+ return false;
+
+ if (EmacsService.DEBUG_IC)
+ Log.d (TAG, "endBatchEdit");
+
+ EmacsNative.endBatchEdit (windowHandle);
+
+ /* Subtract one from the UI thread record of the number of batch
+ edits currently under way. */
+
+ if (batchEditCount > 0)
+ batchEditCount -= 1;
+
+ return batchEditCount > 0;
+ }
+
+ public boolean
+ commitCompletion (CompletionInfo info)
+ {
+ /* Return if the input connection is out of date. */
+ if (view.icSerial < view.icGeneration)
+ return false;
+
+ if (EmacsService.DEBUG_IC)
+ Log.d (TAG, "commitCompletion: " + info);
+
+ EmacsNative.commitCompletion (windowHandle,
+ info.getText ().toString (),
+ info.getPosition ());
+ return true;
+ }
+
+ @Override
+ public boolean
+ commitCorrection (CorrectionInfo info)
+ {
+ /* The input method calls this function not to commit text, but to
+ indicate that a subsequent edit will consist of a correction.
+ Emacs has no use for this information.
+
+ Of course this completely contradicts the provided
+ documentation, but this is how Android actually behaves. */
+ return false;
+ }
+
+ @Override
+ public boolean
+ commitText (CharSequence text, int newCursorPosition)
+ {
+ int[] selection;
+
+ /* Return if the input connection is out of date. */
+ if (view.icSerial < view.icGeneration)
+ return false;
+
+ if (EmacsService.DEBUG_IC)
+ Log.d (TAG, "commitText: " + text + " " + newCursorPosition);
+
+ EmacsNative.commitText (windowHandle, text.toString (),
+ newCursorPosition);
+
+ if (syncAfterCommit)
+ {
+ /* Synchronize with the Emacs thread, obtain the new
+ selection, and report it immediately. */
+
+ selection = EmacsNative.getSelection (windowHandle);
+
+ if (EmacsService.DEBUG_IC && selection != null)
+ Log.d (TAG, "commitText: new selection is " + selection[0]
+ + ", by " + selection[1]);
+
+ if (selection != null)
+ /* N.B. that the composing region is removed after text is
+ committed. */
+ view.imManager.updateSelection (view, selection[0],
+ selection[1], -1, -1);
+ }
+
+ return true;
+ }
+
+ @Override
+ public boolean
+ commitText (CharSequence text, int newCursorPosition,
+ TextAttribute textAttribute)
+ {
+ return commitText (text, newCursorPosition);
+ }
+
+ @Override
+ public boolean
+ deleteSurroundingText (int leftLength, int rightLength)
+ {
+ /* Return if the input connection is out of date. */
+ if (view.icSerial < view.icGeneration)
+ return false;
+
+ if (EmacsService.DEBUG_IC)
+ Log.d (TAG, ("deleteSurroundingText: "
+ + leftLength + " " + rightLength));
+
+ EmacsNative.deleteSurroundingText (windowHandle, leftLength,
+ rightLength);
+ return true;
+ }
+
+ @Override
+ public boolean
+ deleteSurroundingTextInCodePoints (int leftLength, int rightLength)
+ {
+ /* Emacs returns characters which cannot be represented in a Java
+ `char' as NULL characters, so code points always reflect
+ characters themselves. */
+ return deleteSurroundingText (leftLength, rightLength);
+ }
+
+ @Override
+ public boolean
+ finishComposingText ()
+ {
+ /* Return if the input connection is out of date. */
+ if (view.icSerial < view.icGeneration)
+ return false;
+
+ if (EmacsService.DEBUG_IC)
+ Log.d (TAG, "finishComposingText");
+
+ EmacsNative.finishComposingText (windowHandle);
+ return true;
+ }
+
+ @Override
+ public String
+ getSelectedText (int flags)
+ {
+ /* Return if the input connection is out of date. */
+ if (view.icSerial < view.icGeneration)
+ return null;
+
+ if (EmacsService.DEBUG_IC)
+ Log.d (TAG, "getSelectedText: " + flags);
+
+ return EmacsNative.getSelectedText (windowHandle, flags);
+ }
+
+ @Override
+ public String
+ getTextAfterCursor (int length, int flags)
+ {
+ String string;
+
+ /* Return if the input connection is out of date. */
+ if (view.icSerial < view.icGeneration)
+ return null;
+
+ if (EmacsService.DEBUG_IC)
+ Log.d (TAG, "getTextAfterCursor: " + length + " " + flags);
+
+ string = EmacsNative.getTextAfterCursor (windowHandle, length,
+ flags);
+
+ if (EmacsService.DEBUG_IC)
+ Log.d (TAG, " --> " + string);
+
+ return string;
+ }
+
+ @Override
+ public String
+ getTextBeforeCursor (int length, int flags)
+ {
+ String string;
+
+ /* Return if the input connection is out of date. */
+ if (view.icSerial < view.icGeneration)
+ return null;
+
+ if (EmacsService.DEBUG_IC)
+ Log.d (TAG, "getTextBeforeCursor: " + length + " " + flags);
+
+ string = EmacsNative.getTextBeforeCursor (windowHandle, length,
+ flags);
+
+ if (EmacsService.DEBUG_IC)
+ Log.d (TAG, " --> " + string);
+
+ return string;
+ }
+
+ @Override
+ public boolean
+ setComposingText (CharSequence text, int newCursorPosition)
+ {
+ /* Return if the input connection is out of date. */
+ if (view.icSerial < view.icGeneration)
+ return false;
+
+ if (EmacsService.DEBUG_IC)
+ Log.d (TAG, ("setComposingText: "
+ + text + " ## " + newCursorPosition));
+
+ EmacsNative.setComposingText (windowHandle, text.toString (),
+ newCursorPosition);
+ return true;
+ }
+
+ @Override
+ public boolean
+ setComposingText (CharSequence text, int newCursorPosition,
+ TextAttribute textAttribute)
+ {
+ return setComposingText (text, newCursorPosition);
+ }
+
+ @Override
+ public boolean
+ setComposingRegion (int start, int end)
+ {
+ /* Return if the input connection is out of date. */
+ if (view.icSerial < view.icGeneration)
+ return false;
+
+ if (EmacsService.DEBUG_IC)
+ Log.d (TAG, "setComposingRegion: " + start + " " + end);
+
+ EmacsNative.setComposingRegion (windowHandle, start, end);
+ return true;
+ }
+
+ @Override
+ public boolean
+ setComposingRegion (int start, int end, TextAttribute textAttribute)
+ {
+ return setComposingRegion (start, end);
+ }
+
+ @Override
+ public boolean
+ performEditorAction (int editorAction)
+ {
+ /* Return if the input connection is out of date. */
+ if (view.icSerial < view.icGeneration)
+ return false;
+
+ if (EmacsService.DEBUG_IC)
+ Log.d (TAG, "performEditorAction: " + editorAction);
+
+ EmacsNative.performEditorAction (windowHandle, editorAction);
+ return true;
+ }
+
+ @Override
+ public boolean
+ performContextMenuAction (int contextMenuAction)
+ {
+ int action;
+
+ /* Return if the input connection is out of date. */
+ if (view.icSerial < view.icGeneration)
+ return false;
+
+ if (EmacsService.DEBUG_IC)
+ Log.d (TAG, "performContextMenuAction: " + contextMenuAction);
+
+ /* Translate the action in Java code. That way, a great deal of
+ JNI boilerplate can be avoided. */
+
+ switch (contextMenuAction)
+ {
+ case android.R.id.selectAll:
+ action = 0;
+ break;
+
+ case android.R.id.startSelectingText:
+ action = 1;
+ break;
+
+ case android.R.id.stopSelectingText:
+ action = 2;
+ break;
+
+ case android.R.id.cut:
+ action = 3;
+ break;
+
+ case android.R.id.copy:
+ action = 4;
+ break;
+
+ case android.R.id.paste:
+ action = 5;
+ break;
+
+ default:
+ return true;
+ }
+
+ EmacsNative.performContextMenuAction (windowHandle, action);
+ return true;
+ }
+
+ @Override
+ public ExtractedText
+ getExtractedText (ExtractedTextRequest request, int flags)
+ {
+ ExtractedText text;
+ int[] selection;
+
+ /* Return if the input connection is out of date. */
+ if (view.icSerial < view.icGeneration)
+ return null;
+
+ if (EmacsService.DEBUG_IC)
+ Log.d (TAG, "getExtractedText: " + request.hintMaxChars + ", "
+ + request.hintMaxLines + " " + flags);
+
+ /* If a request arrives with hintMaxChars, hintMaxLines and flags
+ set to 0, and the system is known to be buggy, return an empty
+ extracted text object with the absolute selection positions. */
+
+ if (extractAbsoluteOffsets
+ && request.hintMaxChars == 0
+ && request.hintMaxLines == 0
+ && flags == 0)
+ {
+ /* Obtain the selection. */
+ selection = EmacsNative.getSelection (windowHandle);
+ if (selection == null)
+ return null;
+
+ /* Create the workaround extracted text. */
+ text = new ExtractedText ();
+ text.partialStartOffset = -1;
+ text.partialEndOffset = -1;
+ text.text = "";
+ text.selectionStart = selection[0];
+ text.selectionEnd = selection[1];
+ }
+ else
+ text = EmacsNative.getExtractedText (windowHandle, request,
+ flags);
+
+ if (text == null)
+ {
+ if (EmacsService.DEBUG_IC)
+ Log.d (TAG, "getExtractedText: text is NULL");
+
+ return null;
+ }
+
+ if (EmacsService.DEBUG_IC)
+ Log.d (TAG, "getExtractedText: " + text.text + " @"
+ + text.startOffset + ":" + text.selectionStart
+ + ", " + text.selectionEnd);
+
+ return text;
+ }
+
+ @Override
+ public boolean
+ setSelection (int start, int end)
+ {
+ /* Return if the input connection is out of date. */
+ if (view.icSerial < view.icGeneration)
+ return false;
+
+ if (EmacsService.DEBUG_IC)
+ Log.d (TAG, "setSelection: " + start + " " + end);
+
+ EmacsNative.setSelection (windowHandle, start, end);
+ return true;
+ }
+
+ @Override
+ /* ACTION_MULTIPLE is apparently obsolete. */
+ @SuppressWarnings ("deprecation")
+ public boolean
+ sendKeyEvent (KeyEvent key)
+ {
+ /* Return if the input connection is out of date. */
+ if (view.icSerial < view.icGeneration)
+ return false;
+
+ if (EmacsService.DEBUG_IC)
+ Log.d (TAG, "sendKeyEvent: " + key);
+
+ /* Use the standard API if possible. */
+
+ if (Build.VERSION.SDK_INT >= Build.VERSION_CODES.N)
+ view.imManager.dispatchKeyEventFromInputMethod (view, key);
+ else
+ {
+ /* Fall back to dispatching the event manually if not. */
+
+ switch (key.getAction ())
+ {
+ case KeyEvent.ACTION_DOWN:
+ view.onKeyDown (key.getKeyCode (), key);
+ break;
+
+ case KeyEvent.ACTION_UP:
+ view.onKeyUp (key.getKeyCode (), key);
+ break;
+
+ case KeyEvent.ACTION_MULTIPLE:
+ view.onKeyMultiple (key.getKeyCode (),
+ key.getRepeatCount (),
+ key);
+ break;
+ }
+ }
+
+ return true;
+ }
+
+ @Override
+ public boolean
+ requestCursorUpdates (int cursorUpdateMode)
+ {
+ /* Return if the input connection is out of date. */
+ if (view.icSerial < view.icGeneration)
+ return false;
+
+ if (EmacsService.DEBUG_IC)
+ Log.d (TAG, "requestCursorUpdates: " + cursorUpdateMode);
+
+ EmacsNative.requestCursorUpdates (windowHandle, cursorUpdateMode);
+ return true;
+ }
+
+ @Override
+ public boolean
+ requestCursorUpdates (int cursorUpdateMode, int filter)
+ {
+ if (filter != 0)
+ return false;
+
+ return requestCursorUpdates (cursorUpdateMode);
+ }
+
+ @Override
+ public SurroundingText
+ getSurroundingText (int beforeLength, int afterLength,
+ int flags)
+ {
+ SurroundingText text;
+
+ /* Return if the input connection is out of date. */
+ if (view.icSerial < view.icGeneration)
+ return null;
+
+ if (EmacsService.DEBUG_IC)
+ Log.d (TAG, ("getSurroundingText: " + beforeLength + ", "
+ + afterLength));
+
+ text = EmacsNative.getSurroundingText (windowHandle, beforeLength,
+ afterLength, flags);
+
+ if (EmacsService.DEBUG_IC && text != null)
+ Log.d (TAG, ("getSurroundingText: "
+ + text.getSelectionStart ()
+ + ","
+ + text.getSelectionEnd ()
+ + "+"
+ + text.getOffset ()
+ + ": "
+ + text.getText ()));
+
+ return text;
+ }
+
+ @Override
+ public TextSnapshot
+ takeSnapshot ()
+ {
+ TextSnapshot snapshot;
+
+ /* Return if the input connection is out of date. */
+ if (view.icSerial < view.icGeneration)
+ return null;
+
+ snapshot = EmacsNative.takeSnapshot (windowHandle);
+
+ if (EmacsService.DEBUG_IC)
+ Log.d (TAG, ("takeSnapshot: "
+ + snapshot.getSurroundingText ().getText ()
+ + " @ " + snapshot.getCompositionEnd ()
+ + ", " + snapshot.getCompositionStart ()));
+
+ return snapshot;
+ }
+
+ @Override
+ public void
+ closeConnection ()
+ {
+ batchEditCount = 0;
+ }
+
+ @Override
+ public boolean
+ replaceText (int start, int end, CharSequence text,
+ int newCursorPosition, TextAttribute attributes)
+ {
+ if (EmacsService.DEBUG_IC)
+ Log.d (TAG, ("replaceText: " + text + ":: " + start + ","
+ + end + "," + newCursorPosition));
+
+ EmacsNative.replaceText (windowHandle, start, end,
+ text.toString (), newCursorPosition,
+ attributes);
+ return true;
+ }
+
+
+
+ public void
+ reset ()
+ {
+ batchEditCount = 0;
+ }
+
+
+ /* Override functions which are not implemented. */
+
+ @Override
+ public Handler
+ getHandler ()
+ {
+ return null;
+ }
+
+ @Override
+ public boolean
+ commitContent (InputContentInfo inputContentInfo, int flags,
+ Bundle opts)
+ {
+ return false;
+ }
+
+ @Override
+ public boolean
+ setImeConsumesInput (boolean imeConsumesInput)
+ {
+ return false;
+ }
+
+ @Override
+ public boolean
+ clearMetaKeyStates (int states)
+ {
+ return false;
+ }
+
+ @Override
+ public boolean
+ reportFullscreenMode (boolean enabled)
+ {
+ return false;
+ }
+
+ @Override
+ public boolean
+ performSpellCheck ()
+ {
+ return false;
+ }
+
+ @Override
+ public boolean
+ performPrivateCommand (String action, Bundle data)
+ {
+ return false;
+ }
+
+ @Override
+ public int
+ getCursorCapsMode (int reqModes)
+ {
+ return 0;
+ }
+}
diff --git a/java/org/gnu/emacs/EmacsLauncherPreferencesActivity.java b/java/org/gnu/emacs/EmacsLauncherPreferencesActivity.java
new file mode 100644
index 00000000000..21a43b261a0
--- /dev/null
+++ b/java/org/gnu/emacs/EmacsLauncherPreferencesActivity.java
@@ -0,0 +1,31 @@
+/* Communication module for Android terminals. -*- c-file-style: "GNU" -*-
+
+Copyright (C) 2023-2024 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 <https://www.gnu.org/licenses/>. */
+
+package org.gnu.emacs;
+
+/* This class only exists because EmacsPreferencesActivity is already
+ defined as an activity, the system wants a new class in order to
+ define a new activity, and only activities can be enabled or
+ disabled per the API level of the host. */
+
+public final class EmacsLauncherPreferencesActivity
+ extends EmacsPreferencesActivity
+{
+
+}
diff --git a/java/org/gnu/emacs/EmacsMultitaskActivity.java b/java/org/gnu/emacs/EmacsMultitaskActivity.java
new file mode 100644
index 00000000000..7229e34496e
--- /dev/null
+++ b/java/org/gnu/emacs/EmacsMultitaskActivity.java
@@ -0,0 +1,29 @@
+/* Communication module for Android terminals. -*- c-file-style: "GNU" -*-
+
+Copyright (C) 2023-2024 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 <https://www.gnu.org/licenses/>. */
+
+package org.gnu.emacs;
+
+/* This class only exists because EmacsActivity is already defined as
+ an activity, and the system wants a new class in order to define a
+ new activity. */
+
+public final class EmacsMultitaskActivity extends EmacsActivity
+{
+
+}
diff --git a/java/org/gnu/emacs/EmacsNative.java b/java/org/gnu/emacs/EmacsNative.java
new file mode 100644
index 00000000000..654e94b1a7d
--- /dev/null
+++ b/java/org/gnu/emacs/EmacsNative.java
@@ -0,0 +1,359 @@
+/* Communication module for Android terminals. -*- c-file-style: "GNU" -*-
+
+Copyright (C) 2023-2024 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 <https://www.gnu.org/licenses/>. */
+
+package org.gnu.emacs;
+
+import android.content.res.AssetManager;
+
+import android.graphics.Bitmap;
+
+import android.view.inputmethod.ExtractedText;
+import android.view.inputmethod.ExtractedTextRequest;
+import android.view.inputmethod.SurroundingText;
+import android.view.inputmethod.TextAttribute;
+import android.view.inputmethod.TextSnapshot;
+
+public final class EmacsNative
+{
+ /* List of native libraries that must be loaded during class
+ initialization. */
+ private static final String[] libraryDeps;
+
+
+ /* Like `dup' in C. */
+ public static native int dup (int fd);
+
+ /* Like `close' in C. */
+ public static native int close (int fd);
+
+ /* Obtain the fingerprint of this build of Emacs. The fingerprint
+ can be used to determine the dump file name. */
+ public static native String getFingerprint ();
+
+ /* Set certain parameters before initializing Emacs.
+
+ assetManager must be the asset manager associated with the
+ context that is loading Emacs. It is saved and remains for the
+ remainder the lifetime of the Emacs process.
+
+ filesDir must be the package's data storage location for the
+ current Android user.
+
+ libDir must be the package's data storage location for native
+ libraries. It is used as PATH.
+
+ cacheDir must be the package's cache directory. It is used as
+ the `temporary-file-directory'.
+
+ pixelDensityX and pixelDensityY are the DPI values that will be
+ used by Emacs.
+
+ scaledDensity is the DPI value used to translate point sizes to
+ pixel sizes when loading fonts.
+
+ classPath must be the classpath of this app_process process, or
+ NULL.
+
+ emacsService must be the EmacsService singleton, or NULL.
+
+ apiLevel is the version of Android being run. */
+ public static native void setEmacsParams (AssetManager assetManager,
+ String filesDir,
+ String libDir,
+ String cacheDir,
+ float pixelDensityX,
+ float pixelDensityY,
+ float scaledDensity,
+ String classPath,
+ EmacsService emacsService,
+ int apiLevel);
+
+ /* Initialize Emacs with the argument array ARGV. Each argument
+ must contain a NULL terminated string, or else the behavior is
+ undefined.
+
+ DUMPFILE is the dump file to use, or NULL if Emacs is to load
+ loadup.el itself. */
+ public static native void initEmacs (String argv[], String dumpFile);
+
+ /* Call shut_down_emacs to auto-save and unlock files in the main
+ thread, then return. */
+ public static native void shutDownEmacs ();
+
+ /* Garbage collect and clear each frame's image cache. */
+ public static native void onLowMemory ();
+
+ /* Abort and generate a native core dump. */
+ public static native void emacsAbort ();
+
+ /* Set Vquit_flag to t, resulting in Emacs quitting as soon as
+ possible. */
+ public static native void quit ();
+
+ /* Send an ANDROID_CONFIGURE_NOTIFY event. The values of all the
+ functions below are the serials of the events sent. */
+ public static native long sendConfigureNotify (short window, long time,
+ int x, int y, int width,
+ int height);
+
+ /* Send an ANDROID_KEY_PRESS event. */
+ public static native long sendKeyPress (short window, long time, int state,
+ int keyCode, int unicodeChar);
+
+ /* Send an ANDROID_KEY_RELEASE event. */
+ public static native long sendKeyRelease (short window, long time, int state,
+ int keyCode, int unicodeChar);
+
+ /* Send an ANDROID_FOCUS_IN event. */
+ public static native long sendFocusIn (short window, long time);
+
+ /* Send an ANDROID_FOCUS_OUT event. */
+ public static native long sendFocusOut (short window, long time);
+
+ /* Send an ANDROID_WINDOW_ACTION event. */
+ public static native long sendWindowAction (short window, int action);
+
+ /* Send an ANDROID_ENTER_NOTIFY event. */
+ public static native long sendEnterNotify (short window, int x, int y,
+ long time);
+
+ /* Send an ANDROID_LEAVE_NOTIFY event. */
+ public static native long sendLeaveNotify (short window, int x, int y,
+ long time);
+
+ /* Send an ANDROID_MOTION_NOTIFY event. */
+ public static native long sendMotionNotify (short window, int x, int y,
+ long time);
+
+ /* Send an ANDROID_BUTTON_PRESS event. */
+ public static native long sendButtonPress (short window, int x, int y,
+ long time, int state,
+ int button);
+
+ /* Send an ANDROID_BUTTON_RELEASE event. */
+ public static native long sendButtonRelease (short window, int x, int y,
+ long time, int state,
+ int button);
+
+ /* Send an ANDROID_TOUCH_DOWN event. */
+ public static native long sendTouchDown (short window, int x, int y,
+ long time, int pointerID,
+ int flags);
+
+ /* Send an ANDROID_TOUCH_UP event. */
+ public static native long sendTouchUp (short window, int x, int y,
+ long time, int pointerID,
+ int flags);
+
+ /* Send an ANDROID_TOUCH_MOVE event. */
+ public static native long sendTouchMove (short window, int x, int y,
+ long time, int pointerID,
+ int flags);
+
+ /* Send an ANDROID_WHEEL event. */
+ public static native long sendWheel (short window, int x, int y,
+ long time, int state,
+ float xDelta, float yDelta);
+
+ /* Send an ANDROID_ICONIFIED event. */
+ public static native long sendIconified (short window);
+
+ /* Send an ANDROID_DEICONIFIED event. */
+ public static native long sendDeiconified (short window);
+
+ /* Send an ANDROID_CONTEXT_MENU event. */
+ public static native long sendContextMenu (short window, int menuEventID,
+ int menuEventSerial);
+
+ /* Send an ANDROID_EXPOSE event. */
+ public static native long sendExpose (short window, int x, int y,
+ int width, int height);
+
+ /* Send an ANDROID_DND_DRAG event. */
+ public static native long sendDndDrag (short window, int x, int y);
+
+ /* Send an ANDROID_DND_URI event. */
+ public static native long sendDndUri (short window, int x, int y,
+ String text);
+
+ /* Send an ANDROID_DND_TEXT event. */
+ public static native long sendDndText (short window, int x, int y,
+ String text);
+
+ /* Send an ANDROID_NOTIFICATION_CANCELED event. */
+ public static native void sendNotificationDeleted (String tag);
+
+ /* Send an ANDROID_NOTIFICATION_ACTION event. */
+ public static native void sendNotificationAction (String tag, String action);
+
+ /* Return the file name associated with the specified file
+ descriptor, or NULL if there is none. */
+ public static native byte[] getProcName (int fd);
+
+ /* Notice that the Emacs thread will now start waiting for the main
+ thread's looper to respond. */
+ public static native void beginSynchronous ();
+
+ /* Notice that the Emacs thread will has finished waiting for the
+ main thread's looper to respond. */
+ public static native void endSynchronous ();
+
+ /* Prevent deadlocks while reliably allowing queries from the Emacs
+ thread to the main thread to complete by waiting for a query to
+ start from the main thread, then answer it; assume that a query
+ is certain to start shortly. */
+ public static native void answerQuerySpin ();
+
+ /* Return whether or not KEYCODE_VOLUME_DOWN, KEYCODE_VOLUME_UP and
+ KEYCODE_VOLUME_MUTE should be forwarded to Emacs. */
+ public static native boolean shouldForwardMultimediaButtons ();
+
+ /* Return whether KEYCODE_SPACE combined with META_CTRL_MASK should
+ be prevented from reaching the system input method. */
+ public static native boolean shouldForwardCtrlSpace ();
+
+ /* Initialize the current thread, by blocking signals that do not
+ interest it. */
+ public static native void setupSystemThread ();
+
+
+
+ /* Input connection functions. These mostly correspond to their
+ counterparts in Android's InputConnection. */
+
+ public static native void beginBatchEdit (short window);
+ public static native void endBatchEdit (short window);
+ public static native void commitCompletion (short window, String text,
+ int position);
+ public static native void commitText (short window, String text,
+ int position);
+ public static native void deleteSurroundingText (short window,
+ int leftLength,
+ int rightLength);
+ public static native void finishComposingText (short window);
+ public static native void replaceText (short window, int start, int end,
+ String text, int newCursorPosition,
+ TextAttribute attributes);
+ public static native String getSelectedText (short window, int flags);
+ public static native String getTextAfterCursor (short window, int length,
+ int flags);
+ public static native String getTextBeforeCursor (short window, int length,
+ int flags);
+ public static native void setComposingText (short window, String text,
+ int newCursorPosition);
+ public static native void setComposingRegion (short window, int start,
+ int end);
+ public static native void setSelection (short window, int start, int end);
+ public static native void performEditorAction (short window,
+ int editorAction);
+ public static native void performContextMenuAction (short window,
+ int contextMenuAction);
+ public static native ExtractedText getExtractedText (short window,
+ ExtractedTextRequest req,
+ int flags);
+ public static native void requestSelectionUpdate (short window);
+ public static native void requestCursorUpdates (short window, int mode);
+ public static native void clearInputFlags (short window);
+ public static native SurroundingText getSurroundingText (short window,
+ int left, int right,
+ int flags);
+ public static native TextSnapshot takeSnapshot (short window);
+
+
+ /* Return the current value of the selection, or -1 upon
+ failure. */
+ public static native int[] getSelection (short window);
+
+
+ /* Graphics functions used as replacements for potentially buggy
+ Android APIs. */
+
+ public static native void blitRect (Bitmap src, Bitmap dest, int x1,
+ int y1, int x2, int y2);
+
+ /* Increment the generation ID of the specified BITMAP, forcing its
+ texture to be re-uploaded to the GPU. */
+ public static native void notifyPixelsChanged (Bitmap bitmap);
+
+
+ /* Functions used to synchronize document provider access with the
+ main thread. */
+
+ /* Wait for a call to `safPostRequest' while also reading async
+ input.
+
+ If asynchronous input arrives and sets Vquit_flag, return 1. */
+ public static native int safSyncAndReadInput ();
+
+ /* Wait for a call to `safPostRequest'. */
+ public static native void safSync ();
+
+ /* Post the semaphore used to await the completion of SAF
+ operations. */
+ public static native void safPostRequest ();
+
+ /* Detect and return FD is writable. FD may be truncated to 0 bytes
+ in the process. */
+ public static native boolean ftruncate (int fd);
+
+
+ /* Functions that assist in generating content file names. */
+
+ /* Calculate an 8 digit checksum for the byte array DISPLAYNAME
+ suitable for inclusion in a content file name. */
+ public static native String displayNameHash (byte[] displayName);
+
+ static
+ {
+ /* Older versions of Android cannot link correctly with shared
+ libraries that link with other shared libraries built along
+ Emacs unless all requisite shared libraries are explicitly
+ loaded from Java.
+
+ Every time you add a new shared library dependency to Emacs,
+ please add it here as well. */
+
+ libraryDeps = new String[] { "c++_shared", "gnustl_shared",
+ "stlport_shared", "gabi++_shared",
+ "png_emacs", "selinux_emacs",
+ "crypto_emacs", "pcre_emacs",
+ "packagelistparser_emacs",
+ "gnutls_emacs", "gmp_emacs",
+ "nettle_emacs", "p11-kit_emacs",
+ "tasn1_emacs", "hogweed_emacs",
+ "jansson_emacs", "jpeg_emacs",
+ "tiff_emacs", "xml2_emacs",
+ "icuuc_emacs", "harfbuzz_emacs",
+ "tree-sitter_emacs", };
+
+ for (String dependency : libraryDeps)
+ {
+ try
+ {
+ System.loadLibrary (dependency);
+ }
+ catch (UnsatisfiedLinkError exception)
+ {
+ /* Ignore this exception. */
+ }
+ }
+
+ System.loadLibrary ("emacs");
+ };
+};
diff --git a/java/org/gnu/emacs/EmacsNoninteractive.java b/java/org/gnu/emacs/EmacsNoninteractive.java
new file mode 100644
index 00000000000..ba23399cb3e
--- /dev/null
+++ b/java/org/gnu/emacs/EmacsNoninteractive.java
@@ -0,0 +1,203 @@
+/* Communication module for Android terminals. -*- c-file-style: "GNU" -*-
+
+Copyright (C) 2023-2024 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 <https://www.gnu.org/licenses/>. */
+
+package org.gnu.emacs;
+
+import android.os.Looper;
+import android.os.Build;
+
+import android.content.Context;
+import android.content.res.AssetManager;
+
+import java.lang.reflect.Constructor;
+import java.lang.reflect.Method;
+
+/* Noninteractive Emacs.
+
+ This is the class that libandroid-emacs.so starts.
+ libandroid-emacs.so figures out the system classpath, then starts
+ dalvikvm with the framework jars.
+
+ At that point, dalvikvm calls main, which sets up the main looper,
+ creates an ActivityThread and attaches it to the main thread.
+
+ Then, it obtains an application context for the LoadedApk in the
+ application thread.
+
+ Finally, it obtains the necessary context specific objects and
+ initializes Emacs. */
+
+@SuppressWarnings ("unchecked")
+public final class EmacsNoninteractive
+{
+ public static void
+ main (String[] args)
+ {
+ Object activityThread, loadedApk;
+ Class activityThreadClass, loadedApkClass, contextImplClass;
+ Class compatibilityInfoClass;
+ Method method;
+ Context context;
+ AssetManager assets;
+ String filesDir, libDir, cacheDir;
+
+ Looper.prepare ();
+ context = null;
+ assets = null;
+ filesDir = libDir = cacheDir = null;
+
+ try
+ {
+ /* Get the activity thread. */
+ activityThreadClass = Class.forName ("android.app.ActivityThread");
+
+ /* Get the systemMain method. */
+ method = activityThreadClass.getMethod ("systemMain");
+
+ /* Create and attach the activity thread. */
+ activityThread = method.invoke (null);
+ context = null;
+
+ /* Now get an LoadedApk. */
+
+ try
+ {
+ loadedApkClass = Class.forName ("android.app.LoadedApk");
+ }
+ catch (ClassNotFoundException exception)
+ {
+ /* Android 2.2 has no LoadedApk class, but fortunately it
+ does not need to be used, since contexts can be
+ directly created. */
+
+ loadedApkClass = null;
+ contextImplClass = Class.forName ("android.app.ContextImpl");
+
+ method = activityThreadClass.getDeclaredMethod ("getSystemContext");
+ context = (Context) method.invoke (activityThread);
+ method = contextImplClass.getDeclaredMethod ("createPackageContext",
+ String.class,
+ int.class);
+ method.setAccessible (true);
+ context = (Context) method.invoke (context, "org.gnu.emacs",
+ 0);
+ }
+
+ /* If the context has not already been created, then do what
+ is appropriate for newer versions of Android. */
+
+ if (context == null)
+ {
+ /* Get a LoadedApk. How to do this varies by Android version.
+ On Android 2.3.3 and earlier, there is no
+ ``compatibilityInfo'' argument to getPackageInfo. */
+
+ if (Build.VERSION.SDK_INT
+ <= Build.VERSION_CODES.GINGERBREAD_MR1)
+ {
+ method
+ = activityThreadClass.getMethod ("getPackageInfo",
+ String.class,
+ int.class);
+ loadedApk = method.invoke (activityThread, "org.gnu.emacs",
+ 0);
+ }
+ else
+ {
+ compatibilityInfoClass
+ = Class.forName ("android.content.res.CompatibilityInfo");
+
+ method
+ = activityThreadClass.getMethod ("getPackageInfo",
+ String.class,
+ compatibilityInfoClass,
+ int.class);
+ loadedApk = method.invoke (activityThread, "org.gnu.emacs",
+ null, 0);
+ }
+
+ if (loadedApk == null)
+ throw new RuntimeException ("getPackageInfo returned NULL");
+
+ /* Now, get a context. */
+ contextImplClass = Class.forName ("android.app.ContextImpl");
+
+ try
+ {
+ method
+ = contextImplClass.getDeclaredMethod ("createAppContext",
+ activityThreadClass,
+ loadedApkClass);
+ method.setAccessible (true);
+ context = (Context) method.invoke (null, activityThread,
+ loadedApk);
+ }
+ catch (NoSuchMethodException exception)
+ {
+ /* Older Android versions don't have createAppContext, but
+ instead require creating a ContextImpl, and then
+ calling createPackageContext. */
+ method
+ = activityThreadClass.getDeclaredMethod ("getSystemContext");
+ context = (Context) method.invoke (activityThread);
+ method
+ = contextImplClass.getDeclaredMethod ("createPackageContext",
+ String.class,
+ int.class);
+ method.setAccessible (true);
+ context = (Context) method.invoke (context, "org.gnu.emacs",
+ 0);
+ }
+ }
+
+ /* Don't actually start the looper or anything. Instead, obtain
+ an AssetManager. */
+ assets = context.getAssets ();
+
+ /* Now configure Emacs. The class path should already be set. */
+
+ filesDir = context.getFilesDir ().getCanonicalPath ();
+ libDir = EmacsService.getLibraryDirectory (context);
+ cacheDir = context.getCacheDir ().getCanonicalPath ();
+ }
+ catch (Exception e)
+ {
+ System.err.println ("Internal error: " + e);
+ System.err.println ("This means that the Android platform changed,");
+ System.err.println ("and that Emacs needs adjustments in order to");
+ System.err.println ("obtain required system internal resources.");
+ System.err.println ("Please report this bug to bug-gnu-emacs@gnu.org.");
+ e.printStackTrace ();
+
+ System.exit (1);
+ }
+
+ EmacsNative.setEmacsParams (assets, filesDir,
+ libDir, cacheDir, 0.0f,
+ 0.0f, 0.0f, null, null,
+ Build.VERSION.SDK_INT);
+
+ /* Now find the dump file that Emacs should use, if it has already
+ been dumped. */
+ EmacsApplication.findDumpFile (context);
+
+ /* Start Emacs. */
+ EmacsNative.initEmacs (args, EmacsApplication.dumpFileName);
+ }
+};
diff --git a/java/org/gnu/emacs/EmacsOpenActivity.java b/java/org/gnu/emacs/EmacsOpenActivity.java
new file mode 100644
index 00000000000..327a53bc417
--- /dev/null
+++ b/java/org/gnu/emacs/EmacsOpenActivity.java
@@ -0,0 +1,763 @@
+/* Communication module for Android terminals. -*- c-file-style: "GNU" -*-
+
+Copyright (C) 2023-2024 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 <https://www.gnu.org/licenses/>. */
+
+package org.gnu.emacs;
+
+/* This class makes the Emacs server work reasonably on Android.
+
+ There is no way to make the Unix socket publicly available on
+ Android.
+
+ Instead, this activity tries to connect to the Emacs server, to
+ make it open files the system asks Emacs to open, and to emulate
+ some reasonable behavior when Emacs has not yet started.
+
+ First, Emacs registers itself as an application that can open text
+ and image files.
+
+ Then, when the user is asked to open a file and selects ``Emacs''
+ as the application that will open the file, the system pops up a
+ window, this activity, and calls the `onCreate' function.
+
+ `onCreate' then tries very to find the file name of the file that
+ was selected, and give it to emacsclient.
+
+ If emacsclient successfully opens the file, then this activity
+ starts EmacsActivity (to bring it on to the screen); otherwise, it
+ displays the output of emacsclient or any error message that occurs
+ and exits. */
+
+import android.app.AlertDialog;
+import android.app.Activity;
+
+import android.content.ContentResolver;
+import android.content.DialogInterface;
+import android.content.Intent;
+
+import android.net.Uri;
+
+import android.os.Build;
+import android.os.Bundle;
+import android.os.ParcelFileDescriptor;
+import android.os.Parcelable;
+
+import android.util.Log;
+
+import java.io.File;
+import java.io.FileInputStream;
+import java.io.FileNotFoundException;
+import java.io.FileOutputStream;
+import java.io.FileReader;
+import java.io.IOException;
+import java.io.InputStream;
+import java.io.UnsupportedEncodingException;
+
+import java.util.List;
+
+public final class EmacsOpenActivity extends Activity
+ implements DialogInterface.OnClickListener,
+ DialogInterface.OnCancelListener
+{
+ private static final String TAG = "EmacsOpenActivity";
+
+ /* The name of any file that should be opened as EmacsThread starts
+ Emacs. This is never cleared, even if EmacsOpenActivity is
+ started a second time, as EmacsThread only starts once. */
+ public static String fileToOpen;
+
+ /* Any currently focused EmacsOpenActivity. Used to show pop ups
+ while the activity is active and Emacs doesn't have permission to
+ display over other programs. */
+ public static EmacsOpenActivity currentActivity;
+
+ private class EmacsClientThread extends Thread
+ {
+ private ProcessBuilder builder;
+
+ public
+ EmacsClientThread (ProcessBuilder processBuilder)
+ {
+ builder = processBuilder;
+ }
+
+ @Override
+ public void
+ run ()
+ {
+ Process process;
+ InputStream error;
+ String errorText;
+
+ try
+ {
+ /* Start emacsclient. */
+ process = builder.start ();
+ process.waitFor ();
+
+ /* Now figure out whether or not starting the process was
+ successful. */
+ if (process.exitValue () == 0)
+ finishSuccess ();
+ else
+ finishFailure ("Error opening file", null);
+ }
+ catch (IOException exception)
+ {
+ finishFailure ("Internal error", exception.toString ());
+ }
+ catch (InterruptedException exception)
+ {
+ finishFailure ("Internal error", exception.toString ());
+ }
+ }
+ }
+
+ @Override
+ public void
+ onClick (DialogInterface dialog, int which)
+ {
+ finish ();
+ }
+
+ @Override
+ public void
+ onCancel (DialogInterface dialog)
+ {
+ finish ();
+ }
+
+ public String
+ readEmacsClientLog ()
+ {
+ File file, cache;
+ FileReader reader;
+ char[] buffer;
+ int rc;
+ StringBuilder builder;
+
+ /* Because the ProcessBuilder functions necessary to redirect
+ process output are not implemented on Android 7 and earlier,
+ print a generic error message. */
+
+ if (Build.VERSION.SDK_INT < Build.VERSION_CODES.O)
+ return ("This is likely because the Emacs server"
+ + " is not running, or because you did"
+ + " not grant Emacs permission to access"
+ + " external storage.");
+
+ cache = getCacheDir ();
+ file = new File (cache, "emacsclient.log");
+ builder = new StringBuilder ();
+ reader = null;
+
+ try
+ {
+ reader = new FileReader (file);
+ buffer = new char[2048];
+
+ while ((rc = reader.read (buffer, 0, 2048)) != -1)
+ builder.append (buffer, 0, rc);
+
+ reader.close ();
+ return builder.toString ();
+ }
+ catch (IOException exception)
+ {
+ /* Close the reader if it's already been opened. */
+
+ try
+ {
+ if (reader != null)
+ reader.close ();
+ }
+ catch (IOException e)
+ {
+ /* Not sure what to do here. */
+ }
+
+ return ("Couldn't read emacsclient.log: "
+ + exception.toString ());
+ }
+ }
+
+ private void
+ displayFailureDialog (String title, String text)
+ {
+ AlertDialog.Builder builder;
+ AlertDialog dialog;
+
+ builder = new AlertDialog.Builder (this);
+ dialog = builder.create ();
+ dialog.setTitle (title);
+
+ if (text == null)
+ /* Read in emacsclient.log instead. */
+ text = readEmacsClientLog ();
+
+ dialog.setMessage (text);
+ dialog.setButton (DialogInterface.BUTTON_POSITIVE, "OK", this);
+ dialog.setOnCancelListener (this);
+ dialog.show ();
+ }
+
+ /* Check that the specified FILE is non-NULL and readable.
+
+ If it is not, then copy the file in FD to a location in the
+ system cache directory and return the name of that file.
+
+ Alternatively, return URI formatted into a `/content/' file name
+ if the system runs Android 4.4 or later. */
+
+ private String
+ checkReadableOrCopy (String file, ParcelFileDescriptor fd,
+ Uri uri)
+ throws IOException, FileNotFoundException
+ {
+ File inFile;
+ FileOutputStream outStream;
+ InputStream stream;
+ byte buffer[];
+ int read;
+ String content;
+
+ if (file != null)
+ {
+ inFile = new File (file);
+
+ if (inFile.canRead ())
+ return file;
+
+ content = inFile.getName ();
+ }
+ else
+ /* content is the name of this content file if the next branch
+ is not taken. */
+ content = uri.getLastPathSegment ();
+
+ if (Build.VERSION.SDK_INT >= Build.VERSION_CODES.KITKAT)
+ {
+ content = EmacsService.buildContentName (uri, getContentResolver ());
+ return content;
+ }
+
+ /* The file is unnamed if content is NULL. Generate a unique
+ name with the current time as a reference. */
+
+ if (content == null)
+ content = "content." + System.currentTimeMillis () / 1000;
+
+ /* inFile is now the file being written to. */
+ inFile = new File (getCacheDir (), content);
+ buffer = new byte[4098];
+
+ /* Initialize both streams to NULL. */
+ outStream = null;
+ stream = null;
+
+ try
+ {
+ outStream = new FileOutputStream (inFile);
+ stream = new FileInputStream (fd.getFileDescriptor ());
+
+ while ((read = stream.read (buffer)) >= 0)
+ outStream.write (buffer, 0, read);
+ }
+ finally
+ {
+ /* Note that this does not close FD.
+
+ Keep in mind that execution is transferred to ``finally''
+ even if an exception happens inside the while loop
+ above. */
+
+ if (stream != null)
+ stream.close ();
+
+ if (outStream != null)
+ outStream.close ();
+ }
+
+ return inFile.getCanonicalPath ();
+ }
+
+ /* Finish this activity in response to emacsclient having
+ successfully opened a file.
+
+ In the main thread, close this window, and open a window
+ belonging to an Emacs frame. */
+
+ public void
+ finishSuccess ()
+ {
+ runOnUiThread (new Runnable () {
+ @Override
+ public void
+ run ()
+ {
+ Intent intent;
+
+ intent = new Intent (EmacsOpenActivity.this,
+ EmacsActivity.class);
+
+ /* This means only an existing frame will be displayed. */
+ intent.addFlags (Intent.FLAG_ACTIVITY_REORDER_TO_FRONT);
+ startActivity (intent);
+
+ EmacsOpenActivity.this.finish ();
+ }
+ });
+ }
+
+ /* Finish this activity after displaying a dialog associated with
+ failure to open a file.
+
+ Use TITLE as the title of the dialog. If TEXT is non-NULL,
+ display that text in the dialog. Otherwise, use the contents of
+ emacsclient.log in the cache directory instead, or describe why
+ that file cannot be read. */
+
+ public void
+ finishFailure (final String title, final String text)
+ {
+ runOnUiThread (new Runnable () {
+ @Override
+ public void
+ run ()
+ {
+ displayFailureDialog (title, text);
+ }
+ });
+ }
+
+ /* Start `emacsclient' with the provided list of ARGUMENTS, after
+ ARGUMENTS[0] is replaced with the name of the emacsclient binary.
+
+ Create a new thread to await its completion, subsequently
+ reporting any errors that arise to the user. */
+
+ public void
+ startEmacsClient (String[] arguments)
+ {
+ String libDir;
+ ProcessBuilder builder;
+ Process process;
+ EmacsClientThread thread;
+ File file;
+ Intent intent;
+
+ libDir = EmacsService.getLibraryDirectory (this);
+ arguments[0] = libDir + "/libemacsclient.so";
+
+ builder = new ProcessBuilder (arguments);
+
+ /* Redirection is unfortunately not possible in Android 7 and
+ earlier. */
+
+ if (Build.VERSION.SDK_INT >= Build.VERSION_CODES.O)
+ {
+ file = new File (getCacheDir (), "emacsclient.log");
+
+ /* Redirect standard error to a file so that errors can be
+ meaningfully reported. */
+
+ if (file.exists ())
+ file.delete ();
+
+ builder.redirectError (file);
+ }
+
+ /* Track process output in a new thread, since this is the UI
+ thread and doing so here can cause deadlocks when EmacsService
+ decides to wait for something. */
+
+ thread = new EmacsClientThread (builder);
+ thread.start ();
+ }
+
+ /* Run emacsclient to open the file specified in the Intent that
+ caused this activity to start.
+
+ Determine the name of the file corresponding to the URI specified
+ in that intent; then, run emacsclient and wait for it to finish.
+
+ Finally, display any error message, transfer the focus to an
+ Emacs frame, and finish the activity. */
+
+ @SuppressWarnings ("deprecation") /* getParcelableExtra */
+ @Override
+ public void
+ onCreate (Bundle savedInstanceState)
+ {
+ String action, fileName;
+ Intent intent;
+ Uri uri;
+ ContentResolver resolver;
+ ParcelFileDescriptor fd;
+ byte[] names;
+ String errorBlurb, scheme;
+ String subjectString, textString, attachmentString;
+ CharSequence tem;
+ String tem1;
+ String[] emails;
+ StringBuilder builder;
+ List<Parcelable> list;
+
+ super.onCreate (savedInstanceState);
+
+ /* Obtain the intent that started Emacs. */
+ intent = getIntent ();
+ action = intent.getAction ();
+ resolver = getContentResolver ();
+
+ if (action == null)
+ {
+ finish ();
+ return;
+ }
+
+ /* Now see if the action specified is supported by Emacs. */
+
+ if (action.equals ("android.intent.action.VIEW")
+ || action.equals ("android.intent.action.EDIT")
+ || action.equals ("android.intent.action.PICK")
+ || action.equals ("android.intent.action.SEND")
+ || action.equals ("android.intent.action.SENDTO"))
+ {
+ /* Obtain the URI of the action. */
+ uri = intent.getData ();
+
+ if (uri == null)
+ {
+ finish ();
+ return;
+ }
+
+ scheme = uri.getScheme ();
+
+ /* It is possible for scheme to be NULL, under Android 2.3 at
+ least. */
+
+ if (scheme == null)
+ return;
+
+ /* If URL is a mailto URI, call `message-mailto' much the same
+ way emacsclient-mail.desktop does. */
+
+ if (scheme.equals ("mailto"))
+ {
+ /* Escape the special characters $ and " before enclosing
+ the string within the `message-mailto' wrapper. */
+ fileName = uri.toString ();
+
+ /* If fileName is merely mailto: (absent either an email
+ address or content), then the program launching Emacs
+ conceivably provided such an URI to exclude non-email
+ programs from the Share dialog. Intents created thus
+ might hold the recipient email as a string array, which
+ is non-standard behavior. */
+
+ if (fileName.equals ("mailto:") || fileName.equals ("mailto://"))
+ {
+ emails = intent.getStringArrayExtra (Intent.EXTRA_EMAIL);
+
+ if (emails[0] != null && emails.length > 0)
+ fileName = "mailto:" + emails[0];
+ }
+
+ /* Subsequently, escape fileName such that it is rendered
+ safe to append to the command line. */
+
+ fileName = (fileName
+ .replace ("\\", "\\\\")
+ .replace ("\"", "\\\"")
+ .replace ("$", "\\$"));
+
+ fileName = "(message-mailto \"" + fileName + "\" ";
+
+ /* Parse the intent itself to ascertain if any
+ non-standard subject, body, or something else of the
+ like is set. Such fields, non-standard as they are,
+ yield to fields provided within the URL itself; refer
+ to message-mailto. */
+
+ textString = attachmentString = subjectString = "()";
+
+ tem = intent.getCharSequenceExtra (Intent.EXTRA_SUBJECT);
+
+ if (tem != null)
+ subjectString = ("\"" + (tem.toString ()
+ .replace ("\\", "\\\\")
+ .replace ("\"", "\\\"")
+ .replace ("$", "\\$"))
+ + "\" ");
+
+ tem = intent.getCharSequenceExtra (Intent.EXTRA_TEXT);
+
+ if (tem != null)
+ textString = ("\"" + (tem.toString ()
+ .replace ("\\", "\\\\")
+ .replace ("\"", "\\\"")
+ .replace ("$", "\\$"))
+ + "\" ");
+
+ /* Producing a list of attachments is prey to two
+ mannerisms of the system: in the first instance, these
+ attachments are content URIs which don't allude to
+ their content types; and in the second instance, they
+ are either a list of such URIs or one individual URI,
+ subject to the type of the intent itself. */
+
+ if (Intent.ACTION_SEND.equals (action))
+ {
+ /* The attachment in this case is a single content
+ URI. */
+
+ if (Build.VERSION.SDK_INT >= Build.VERSION_CODES.TIRAMISU)
+ uri = intent.getParcelableExtra (Intent.EXTRA_STREAM,
+ Uri.class);
+ else
+ uri = intent.getParcelableExtra (Intent.EXTRA_STREAM);
+
+ if ((scheme = uri.getScheme ()) != null
+ && scheme.equals ("content")
+ && (Build.VERSION.SDK_INT
+ >= Build.VERSION_CODES.KITKAT))
+ {
+ tem1 = EmacsService.buildContentName (uri, resolver);
+ attachmentString = ("'(\"" + (tem1.replace ("\\", "\\\\")
+ .replace ("\"", "\\\"")
+ .replace ("$", "\\$"))
+ + "\")");
+ }
+ else if (scheme != null && scheme.equals ("file"))
+ {
+ tem1 = uri.getPath ();
+ attachmentString = ("'(\"" + (tem1.replace ("\\", "\\\\")
+ .replace ("\"", "\\\"")
+ .replace ("$", "\\$"))
+ + "\")");
+ }
+ }
+ else
+ {
+ if (Build.VERSION.SDK_INT >= Build.VERSION_CODES.TIRAMISU)
+ list
+ = intent.getParcelableArrayListExtra (Intent.EXTRA_STREAM,
+ Parcelable.class);
+ else
+ list
+ = intent.getParcelableArrayListExtra (Intent.EXTRA_STREAM);
+
+ if (list != null)
+ {
+ builder = new StringBuilder ("'(");
+
+ for (Parcelable parcelable : list)
+ {
+ if (!(parcelable instanceof Uri))
+ continue;
+
+ uri = (Uri) parcelable;
+
+ if (uri != null
+ && (scheme = uri.getScheme ()) != null
+ && scheme.equals ("content")
+ && (Build.VERSION.SDK_INT
+ >= Build.VERSION_CODES.KITKAT))
+ {
+ tem1
+ = EmacsService.buildContentName (uri, resolver);
+ builder.append ("\"");
+ builder.append (tem1.replace ("\\", "\\\\")
+ .replace ("\"", "\\\"")
+ .replace ("$", "\\$"));
+ builder.append ("\"");
+ }
+ else if (scheme != null
+ && scheme.equals ("file"))
+ {
+ tem1 = uri.getPath ();
+ builder.append ("\"");
+ builder.append (tem1.replace ("\\", "\\\\")
+ .replace ("\"", "\\\"")
+ .replace ("$", "\\$"));
+ builder.append ("\"");
+ }
+ }
+
+ builder.append (")");
+ attachmentString = builder.toString ();
+ }
+ }
+
+ fileName += subjectString;
+ fileName += textString;
+ fileName += attachmentString;
+ fileName += ")";
+
+ /* Execute emacsclient in order to execute this code. */
+ currentActivity = this;
+ startEmacsClient (new String[] { "--timeout=10", "--no-wait",
+ "--eval", fileName, });
+ return;
+ }
+
+ /* Now, try to get the file name. */
+
+ if (scheme.equals ("file"))
+ fileName = uri.getPath ();
+ else
+ {
+ fileName = null;
+
+ if (scheme.equals ("content")
+ /* Retrieving the native file descriptor of a
+ ParcelFileDescriptor requires Honeycomb, and
+ proceeding without this capability is pointless on
+ systems before KitKat, since Emacs doesn't support
+ opening content files on those. */
+ && Build.VERSION.SDK_INT >= Build.VERSION_CODES.HONEYCOMB)
+ {
+ /* This is one of the annoying Android ``content''
+ URIs. Most of the time, there is actually an
+ underlying file, but it cannot be found without
+ opening the file and doing readlink on its file
+ descriptor in /proc/self/fd. */
+ fd = null;
+
+ try
+ {
+ fd = resolver.openFileDescriptor (uri, "r");
+ names = EmacsNative.getProcName (fd.getFd ());
+
+ /* What is the right encoding here? */
+
+ if (names != null)
+ fileName = new String (names, "UTF-8");
+
+ fileName = checkReadableOrCopy (fileName, fd, uri);
+ }
+ catch (FileNotFoundException exception)
+ {
+ /* Do nothing. */
+ }
+ catch (IOException exception)
+ {
+ /* Do nothing. */
+ }
+ catch (SecurityException exception)
+ {
+ /* This means Emacs lacks the rights to open this
+ file. Display the error message and exit. */
+ displayFailureDialog ("Error opening file",
+ exception.toString ());
+ return;
+ }
+
+ if (fd != null)
+ {
+ try
+ {
+ fd.close ();
+ }
+ catch (IOException exception)
+ {
+ /* Do nothing. */
+ }
+ }
+ }
+ else if (scheme.equals ("org-protocol"))
+ /* URL is an org-protocol:// link, which is meant to be
+ directly relayed to emacsclient. */
+ fileName = uri.toString ();
+
+ if (fileName == null)
+ {
+ errorBlurb = ("The URI: " + uri + " could not be opened"
+ + ", as it does not encode file name inform"
+ + "ation.");
+ displayFailureDialog ("Error opening file", errorBlurb);
+ return;
+ }
+ }
+
+ /* If the Emacs service is not running, then start Emacs and make
+ it open this file. */
+
+ if (EmacsService.SERVICE == null)
+ {
+ fileToOpen = fileName;
+ intent = new Intent (EmacsOpenActivity.this,
+ EmacsActivity.class);
+ finish ();
+ startActivity (intent);
+ return;
+ }
+
+ /* And start emacsclient. Set `currentActivity' to this now.
+ Presumably, it will shortly become capable of displaying
+ dialogs. */
+ currentActivity = this;
+ startEmacsClient (new String[] { "--timeout=10", "--no-wait",
+ "--reuse-frame", fileName, });
+ }
+ else
+ finish ();
+ }
+
+
+
+ @Override
+ public void
+ onDestroy ()
+ {
+ /* Clear `currentActivity' if it refers to the activity being
+ destroyed. */
+
+ if (currentActivity == this)
+ this.currentActivity = null;
+
+ super.onDestroy ();
+ }
+
+ @Override
+ public void
+ onWindowFocusChanged (boolean isFocused)
+ {
+ if (isFocused)
+ currentActivity = this;
+ else if (currentActivity == this)
+ currentActivity = null;
+
+ super.onWindowFocusChanged (isFocused);
+ }
+
+ @Override
+ public void
+ onPause ()
+ {
+ /* XXX: clear currentActivity here as well; I don't know whether
+ or not onWindowFocusChanged is always called prior to this. */
+
+ if (currentActivity == this)
+ currentActivity = null;
+
+ super.onPause ();
+ }
+}
diff --git a/java/org/gnu/emacs/EmacsPixmap.java b/java/org/gnu/emacs/EmacsPixmap.java
new file mode 100644
index 00000000000..c621e2de3c5
--- /dev/null
+++ b/java/org/gnu/emacs/EmacsPixmap.java
@@ -0,0 +1,170 @@
+/* Communication module for Android terminals. -*- c-file-style: "GNU" -*-
+
+Copyright (C) 2023-2024 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 <https://www.gnu.org/licenses/>. */
+
+package org.gnu.emacs;
+
+import java.lang.IllegalArgumentException;
+
+import android.graphics.Bitmap;
+import android.graphics.Canvas;
+import android.graphics.Rect;
+
+import android.os.Build;
+
+/* Drawable backed by bitmap. */
+
+public final class EmacsPixmap extends EmacsHandleObject
+ implements EmacsDrawable
+{
+ /* The depth of the bitmap. This is not actually used, just defined
+ in order to be consistent with X. */
+ public final int depth, width, height;
+
+ /* The bitmap itself. */
+ public Bitmap bitmap;
+
+ /* The canvas used to draw to BITMAP. */
+ public Canvas canvas;
+
+ /* Whether or not GC should be explicitly triggered upon
+ release. */
+ private final boolean needCollect;
+
+ /* ID used to determine whether or not the GC clip rects
+ changed. */
+ private long gcClipRectID;
+
+ public
+ EmacsPixmap (short handle, int width, int height, int depth)
+ {
+ super (handle);
+
+ if (depth != 1 && depth != 24)
+ throw new IllegalArgumentException ("Invalid depth specified"
+ + " for pixmap: " + depth);
+
+ switch (depth)
+ {
+ case 1:
+ if (Build.VERSION.SDK_INT >= Build.VERSION_CODES.O)
+ bitmap = Bitmap.createBitmap (width, height,
+ Bitmap.Config.ALPHA_8,
+ false);
+ else
+ bitmap = Bitmap.createBitmap (width, height,
+ Bitmap.Config.ALPHA_8);
+ break;
+
+ case 24:
+
+ /* Emacs doesn't just use the first kind of `createBitmap'
+ because the latter allows specifying that the pixmap is
+ always opaque, which really increases efficiency. */
+ if (Build.VERSION.SDK_INT < Build.VERSION_CODES.O)
+ bitmap = Bitmap.createBitmap (width, height,
+ Bitmap.Config.ARGB_8888);
+ else
+ bitmap = Bitmap.createBitmap (width, height,
+ Bitmap.Config.ARGB_8888,
+ false);
+ break;
+ }
+
+ if (Build.VERSION.SDK_INT < Build.VERSION_CODES.HONEYCOMB_MR1)
+ /* On these old versions of Android, Bitmap.recycle frees bitmap
+ contents immediately. */
+ needCollect = false;
+ else if (Build.VERSION.SDK_INT < Build.VERSION_CODES.KITKAT)
+ needCollect = (bitmap.getByteCount ()
+ >= 1024 * 512);
+ else
+ needCollect = (bitmap.getAllocationByteCount ()
+ >= 1024 * 512);
+
+ bitmap.eraseColor (0xff000000);
+
+ this.width = width;
+ this.height = height;
+ this.depth = depth;
+ }
+
+ @Override
+ public Canvas
+ lockCanvas (EmacsGC gc)
+ {
+ int i;
+
+ if (canvas == null)
+ {
+ canvas = new Canvas (bitmap);
+ canvas.save ();
+ }
+
+ /* Now see if clipping has to be redone. */
+ if (gc.clipRectID == gcClipRectID)
+ return canvas;
+
+ /* It does have to be redone. Reapply gc.real_clip_rects. */
+ canvas.restore ();
+ canvas.save ();
+
+ if (gc.real_clip_rects != null)
+ {
+ for (i = 0; i < gc.real_clip_rects.length; ++i)
+ canvas.clipRect (gc.real_clip_rects[i]);
+ }
+
+ /* Save the clip rect ID again. */
+ gcClipRectID = gc.clipRectID;
+ return canvas;
+ }
+
+ @Override
+ public void
+ damageRect (Rect damageRect)
+ {
+
+ }
+
+ @Override
+ public void
+ damageRect (int left, int top, int right, int bottom)
+ {
+
+ }
+
+ @Override
+ public Bitmap
+ getBitmap ()
+ {
+ return bitmap;
+ }
+
+ @Override
+ public void
+ destroyHandle ()
+ {
+ bitmap.recycle ();
+ bitmap = null;
+
+ /* Collect the bitmap storage if the bitmap is big. */
+ if (needCollect)
+ Runtime.getRuntime ().gc ();
+ }
+};
diff --git a/java/org/gnu/emacs/EmacsPreferencesActivity.java b/java/org/gnu/emacs/EmacsPreferencesActivity.java
new file mode 100644
index 00000000000..766e2e11d46
--- /dev/null
+++ b/java/org/gnu/emacs/EmacsPreferencesActivity.java
@@ -0,0 +1,169 @@
+/* Communication module for Android terminals. -*- c-file-style: "GNU" -*-
+
+Copyright (C) 2023-2024 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 <https://www.gnu.org/licenses/>. */
+
+package org.gnu.emacs;
+
+import java.io.File;
+
+import android.app.Activity;
+
+import android.content.Intent;
+
+import android.os.Bundle;
+import android.os.Build;
+
+import android.widget.Toast;
+
+import android.preference.*;
+
+/* This module provides a ``preferences'' display for Emacs. It is
+ supposed to be launched from inside the Settings application to
+ perform various actions, such as starting Emacs with the ``-Q''
+ option, which would not be possible otherwise, as there is no
+ command line on Android.
+
+ This file extends a deprecated preferences activity, but no suitable
+ alternative exists that is identical in appearance to system settings
+ forms. */
+
+@SuppressWarnings ("deprecation")
+public class EmacsPreferencesActivity extends PreferenceActivity
+{
+ /* Restart Emacs with -Q. Call EmacsThread.exit to kill Emacs now,
+ and tell the system to start EmacsActivity with some parameters
+ later. */
+
+ private void
+ startEmacsQ ()
+ {
+ Intent intent;
+
+ intent = new Intent (this, EmacsActivity.class);
+ intent.addFlags (Intent.FLAG_ACTIVITY_NEW_TASK
+ | Intent.FLAG_ACTIVITY_CLEAR_TASK);
+ intent.putExtra ("org.gnu.emacs.STARTUP_ARGUMENT", "--quick");
+ startActivity (intent);
+ System.exit (0);
+ }
+
+ /* Restart Emacs with `--debug-init'. Call EmacsThread.exit to kill
+ Emacs now, and tell the system to EmacsActivity with some
+ parameters later. */
+
+ private void
+ startEmacsDebugInit ()
+ {
+ Intent intent;
+
+ intent = new Intent (this, EmacsActivity.class);
+ intent.addFlags (Intent.FLAG_ACTIVITY_NEW_TASK
+ | Intent.FLAG_ACTIVITY_CLEAR_TASK);
+ intent.putExtra ("org.gnu.emacs.STARTUP_ARGUMENT", "--debug-init");
+ startActivity (intent);
+ System.exit (0);
+ }
+
+ /* Erase Emacs's dump file. */
+
+ private void
+ eraseDumpFile ()
+ {
+ String wantedDumpFile;
+ File file;
+ Toast toast;
+
+ wantedDumpFile = ("emacs-" + EmacsNative.getFingerprint ()
+ + ".pdmp");
+ file = new File (getFilesDir (), wantedDumpFile);
+
+ if (file.exists ())
+ file.delete ();
+
+ /* Make sure to clear EmacsApplication.dumpFileName, or
+ starting Emacs without restarting this program will
+ make Emacs try to load a nonexistent dump file. */
+ EmacsApplication.dumpFileName = null;
+
+ /* Display a message stating that the dump file has been
+ erased. */
+ toast = Toast.makeText (this, "Dump file removed",
+ Toast.LENGTH_SHORT);
+ toast.show ();
+ }
+
+ @Override
+ public final void
+ onCreate (Bundle savedInstanceState)
+ {
+ Preference tem;
+ Preference.OnPreferenceClickListener listener;
+
+ if (Build.VERSION.SDK_INT >= Build.VERSION_CODES.LOLLIPOP)
+ setTheme (android.R.style.Theme_DeviceDefault_Settings);
+ else if (Build.VERSION.SDK_INT
+ >= Build.VERSION_CODES.ICE_CREAM_SANDWICH)
+ setTheme (android.R.style.Theme_DeviceDefault);
+
+ /* This must come before using any preference APIs. */
+ super.onCreate (savedInstanceState);
+
+ /* Add preferences from the XML file where they are defined. */
+ addPreferencesFromResource (R.xml.preferences);
+
+ /* Now, set up on click handlers for each of the preferences
+ items. */
+
+ tem = findPreference ("start_quick");
+ listener = new Preference.OnPreferenceClickListener () {
+ @Override
+ public boolean
+ onPreferenceClick (Preference preference)
+ {
+ startEmacsQ ();
+ return true;
+ }
+ };
+
+ tem.setOnPreferenceClickListener (listener);
+ tem = findPreference ("start_debug_init");
+ listener = new Preference.OnPreferenceClickListener () {
+ @Override
+ public boolean
+ onPreferenceClick (Preference preference)
+ {
+ startEmacsDebugInit ();
+ return true;
+ }
+ };
+
+ tem.setOnPreferenceClickListener (listener);
+ tem = findPreference ("erase_dump");
+ listener = new Preference.OnPreferenceClickListener () {
+ @Override
+ public boolean
+ onPreferenceClick (Preference preference)
+ {
+ eraseDumpFile ();
+ return true;
+ }
+ };
+
+ tem.setOnPreferenceClickListener (listener);
+ }
+};
diff --git a/java/org/gnu/emacs/EmacsSafThread.java b/java/org/gnu/emacs/EmacsSafThread.java
new file mode 100644
index 00000000000..14c3f222833
--- /dev/null
+++ b/java/org/gnu/emacs/EmacsSafThread.java
@@ -0,0 +1,1708 @@
+/* Communication module for Android terminals. -*- c-file-style: "GNU" -*-
+
+Copyright (C) 2023-2024 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 <https://www.gnu.org/licenses/>. */
+
+package org.gnu.emacs;
+
+import java.util.Collection;
+import java.util.HashMap;
+import java.util.Iterator;
+
+import java.io.FileNotFoundException;
+import java.io.IOException;
+
+import android.content.ContentResolver;
+import android.database.Cursor;
+import android.net.Uri;
+
+import android.os.Build;
+import android.os.CancellationSignal;
+import android.os.Handler;
+import android.os.HandlerThread;
+import android.os.OperationCanceledException;
+import android.os.ParcelFileDescriptor;
+import android.os.SystemClock;
+
+import android.util.Log;
+
+import android.provider.DocumentsContract;
+import android.provider.DocumentsContract.Document;
+
+
+
+/* Emacs runs long-running SAF operations on a second thread running
+ its own handler. These operations include opening files and
+ maintaining the path to document ID cache.
+
+ Because Emacs paths are based on file display names, while Android
+ document identifiers have no discernible hierarchy of their own,
+ each file name lookup must carry out a repeated search for
+ directory documents with the names of all of the file name's
+ constituent components, where each iteration searches within the
+ directory document identified by the previous iteration.
+
+ A time limited cache tying components to document IDs is maintained
+ in order to speed up consecutive searches for file names sharing
+ the same components. Since listening for changes to each document
+ in the cache is prohibitively expensive, Emacs instead elects to
+ periodically remove entries that are older than a predetermined
+ amount of a time.
+
+ The cache is split into two levels: the first caches the
+ relationships between display names and document IDs, while the
+ second caches individual document IDs and their contents (children,
+ type, etc.)
+
+ Long-running operations are also run on this thread for another
+ reason: Android uses special cancellation objects to terminate
+ ongoing IPC operations. However, the functions that perform these
+ operations block instead of providing mechanisms for the caller to
+ wait for their completion while also reading async input, as a
+ consequence of which the calling thread is unable to signal the
+ cancellation objects that it provides. Performing the blocking
+ operations in this auxiliary thread enables the main thread to wait
+ for completion itself, signaling the cancellation objects when it
+ deems necessary. */
+
+
+
+public final class EmacsSafThread extends HandlerThread
+{
+ private static final String TAG = "EmacsSafThread";
+
+ /* The content resolver used by this thread. */
+ private final ContentResolver resolver;
+
+ /* Map between tree URIs and the cache entry representing its
+ toplevel directory. */
+ private final HashMap<Uri, CacheToplevel> cacheToplevels;
+
+ /* Handler for this thread's main loop. */
+ private Handler handler;
+
+ /* File access mode constants. See `man 7 inode'. */
+ public static final int S_IRUSR = 0000400;
+ public static final int S_IWUSR = 0000200;
+ public static final int S_IXUSR = 0000100;
+ public static final int S_IFCHR = 0020000;
+ public static final int S_IFDIR = 0040000;
+ public static final int S_IFREG = 0100000;
+
+ /* Number of seconds in between each attempt to prune the storage
+ cache. */
+ public static final int CACHE_PRUNE_TIME = 10;
+
+ /* Number of seconds after which an entry in the cache is to be
+ considered invalid. */
+ public static final int CACHE_INVALID_TIME = 10;
+
+ public
+ EmacsSafThread (ContentResolver resolver)
+ {
+ super ("Document provider access thread");
+ this.resolver = resolver;
+ this.cacheToplevels = new HashMap<Uri, CacheToplevel> ();
+ }
+
+
+
+ @Override
+ public void
+ start ()
+ {
+ super.start ();
+
+ /* Set up the handler after the thread starts. */
+ handler = new Handler (getLooper ());
+
+ /* And start periodically pruning the cache. */
+ postPruneMessage ();
+ }
+
+
+ private static final class CacheToplevel
+ {
+ /* Map between document names and children. */
+ HashMap<String, DocIdEntry> children;
+
+ /* Map between document names and file status. */
+ HashMap<String, StatCacheEntry> statCache;
+
+ /* Map between document IDs and cache items. */
+ HashMap<String, CacheEntry> idCache;
+ };
+
+ private static final class StatCacheEntry
+ {
+ /* The time at which this cache entry was created. */
+ long time;
+
+ /* Flags, size, and modification time of this file. */
+ long flags, size, mtime;
+
+ /* Whether or not this file is a directory. */
+ boolean isDirectory;
+
+ public
+ StatCacheEntry ()
+ {
+ time = SystemClock.uptimeMillis ();
+ }
+
+ public boolean
+ isValid ()
+ {
+ return ((SystemClock.uptimeMillis () - time)
+ < CACHE_INVALID_TIME * 1000);
+ }
+ };
+
+ private static final class DocIdEntry
+ {
+ /* The document ID. */
+ String documentId;
+
+ /* The time this entry was created. */
+ long time;
+
+ public
+ DocIdEntry ()
+ {
+ time = SystemClock.uptimeMillis ();
+ }
+
+ /* Return a cache entry comprised of the state of the file
+ identified by `documentId'. TREE is the URI of the tree
+ containing this entry, and TOPLEVEL is the toplevel
+ representing it. SIGNAL is a cancellation signal.
+
+ RESOLVER is the content provider used to retrieve file
+ information.
+
+ Value is NULL if the file cannot be found. */
+
+ public CacheEntry
+ getCacheEntry (ContentResolver resolver, Uri tree,
+ CacheToplevel toplevel,
+ CancellationSignal signal)
+ {
+ Uri uri;
+ String[] projection;
+ String type;
+ Cursor cursor;
+ int column;
+ CacheEntry entry;
+
+ /* Create a document URI representing DOCUMENTID within URI's
+ authority. */
+
+ uri = DocumentsContract.buildDocumentUriUsingTree (tree,
+ documentId);
+ projection = new String[] {
+ Document.COLUMN_MIME_TYPE,
+ };
+
+ cursor = null;
+
+ try
+ {
+ cursor = resolver.query (uri, projection, null,
+ null, null, signal);
+
+ if (!cursor.moveToFirst ())
+ return null;
+
+ column = cursor.getColumnIndex (Document.COLUMN_MIME_TYPE);
+
+ if (column < 0)
+ return null;
+
+ type = cursor.getString (column);
+
+ if (type == null)
+ return null;
+
+ entry = new CacheEntry ();
+ entry.type = type;
+ toplevel.idCache.put (documentId, entry);
+ return entry;
+ }
+ catch (OperationCanceledException e)
+ {
+ throw e;
+ }
+ catch (Throwable e)
+ {
+ return null;
+ }
+ finally
+ {
+ if (cursor != null)
+ cursor.close ();
+ }
+ }
+
+ public boolean
+ isValid ()
+ {
+ return ((SystemClock.uptimeMillis () - time)
+ < CACHE_INVALID_TIME * 1000);
+ }
+ };
+
+ private static final class CacheEntry
+ {
+ /* The type of this document. */
+ String type;
+
+ /* Map between document names and children. */
+ HashMap<String, DocIdEntry> children;
+
+ /* The time this entry was created. */
+ long time;
+
+ public
+ CacheEntry ()
+ {
+ children = new HashMap<String, DocIdEntry> ();
+ time = SystemClock.uptimeMillis ();
+ }
+
+ public boolean
+ isValid ()
+ {
+ return ((SystemClock.uptimeMillis () - time)
+ < CACHE_INVALID_TIME * 1000);
+ }
+ };
+
+ /* Create or return a toplevel for the given tree URI. */
+
+ private CacheToplevel
+ getCache (Uri uri)
+ {
+ CacheToplevel toplevel;
+
+ toplevel = cacheToplevels.get (uri);
+
+ if (toplevel != null)
+ return toplevel;
+
+ toplevel = new CacheToplevel ();
+ toplevel.children = new HashMap<String, DocIdEntry> ();
+ toplevel.statCache = new HashMap<String, StatCacheEntry> ();
+ toplevel.idCache = new HashMap<String, CacheEntry> ();
+ cacheToplevels.put (uri, toplevel);
+ return toplevel;
+ }
+
+ /* Remove each cache entry within COLLECTION older than
+ CACHE_INVALID_TIME. */
+
+ private void
+ pruneCache1 (Collection<DocIdEntry> collection)
+ {
+ Iterator<DocIdEntry> iter;
+ DocIdEntry tem;
+
+ iter = collection.iterator ();
+ while (iter.hasNext ())
+ {
+ /* Get the cache entry. */
+ tem = iter.next ();
+
+ /* If it's not valid anymore, remove it. Iterating over a
+ collection whose contents are being removed is undefined
+ unless the removal is performed using the iterator's own
+ `remove' function, so tem.remove cannot be used here. */
+
+ if (tem.isValid ())
+ continue;
+
+ iter.remove ();
+ }
+ }
+
+ /* Remove every entry older than CACHE_INVALID_TIME from each
+ toplevel inside `cachedToplevels'. */
+
+ private void
+ pruneCache ()
+ {
+ Iterator<CacheEntry> iter;
+ Iterator<StatCacheEntry> statIter;
+ CacheEntry tem;
+ StatCacheEntry stat;
+
+ for (CacheToplevel toplevel : cacheToplevels.values ())
+ {
+ /* First, clean up expired cache entries. */
+ iter = toplevel.idCache.values ().iterator ();
+
+ while (iter.hasNext ())
+ {
+ /* Get the cache entry. */
+ tem = iter.next ();
+
+ /* If it's not valid anymore, remove it. Iterating over a
+ collection whose contents are being removed is
+ undefined unless the removal is performed using the
+ iterator's own `remove' function, so tem.remove cannot
+ be used here. */
+
+ if (tem.isValid ())
+ {
+ /* Otherwise, clean up expired items in its document
+ ID cache. */
+ pruneCache1 (tem.children.values ());
+ continue;
+ }
+
+ iter.remove ();
+ }
+
+ statIter = toplevel.statCache.values ().iterator ();
+
+ while (statIter.hasNext ())
+ {
+ /* Get the cache entry. */
+ stat = statIter.next ();
+
+ /* If it's not valid anymore, remove it. Iterating over a
+ collection whose contents are being removed is
+ undefined unless the removal is performed using the
+ iterator's own `remove' function, so tem.remove cannot
+ be used here. */
+
+ if (stat.isValid ())
+ continue;
+
+ statIter.remove ();
+ }
+ }
+
+ postPruneMessage ();
+ }
+
+ /* Cache file information within TOPLEVEL, under the list of
+ children CHILDREN.
+
+ NAME, ID, and TYPE should respectively be the display name of the
+ document within its parent document (the CacheEntry whose
+ `children' field is CHILDREN), its document ID, and its MIME
+ type.
+
+ If ID_ENTRY_EXISTS, don't create a new document ID entry within
+ CHILDREN indexed by NAME.
+
+ Value is the cache entry saved for the document ID. */
+
+ private CacheEntry
+ cacheChild (CacheToplevel toplevel,
+ HashMap<String, DocIdEntry> children,
+ String name, String id, String type,
+ boolean id_entry_exists)
+ {
+ DocIdEntry idEntry;
+ CacheEntry cacheEntry;
+
+ if (!id_entry_exists)
+ {
+ idEntry = new DocIdEntry ();
+ idEntry.documentId = id;
+ children.put (name, idEntry);
+ }
+
+ cacheEntry = new CacheEntry ();
+ cacheEntry.type = type;
+ toplevel.idCache.put (id, cacheEntry);
+ return cacheEntry;
+ }
+
+ /* Cache file status for DOCUMENTID within TOPLEVEL. Value is the
+ new cache entry. CURSOR is the cursor from where to retrieve the
+ file status, in the form of the columns COLUMN_FLAGS,
+ COLUMN_SIZE, COLUMN_MIME_TYPE and COLUMN_LAST_MODIFIED.
+
+ If NO_CACHE, don't cache the file status; just return the
+ entry. */
+
+ private StatCacheEntry
+ cacheFileStatus (String documentId, CacheToplevel toplevel,
+ Cursor cursor, boolean no_cache)
+ {
+ StatCacheEntry entry;
+ int flagsIndex, columnIndex, typeIndex;
+ int sizeIndex, mtimeIndex;
+ String type;
+
+ /* Obtain the indices for columns wanted from this cursor. */
+ flagsIndex = cursor.getColumnIndex (Document.COLUMN_FLAGS);
+ sizeIndex = cursor.getColumnIndex (Document.COLUMN_SIZE);
+ typeIndex = cursor.getColumnIndex (Document.COLUMN_MIME_TYPE);
+ mtimeIndex = cursor.getColumnIndex (Document.COLUMN_LAST_MODIFIED);
+
+ /* COLUMN_LAST_MODIFIED is allowed to be absent in a
+ conforming documents provider. */
+ if (flagsIndex < 0 || sizeIndex < 0 || typeIndex < 0)
+ return null;
+
+ /* Get the file status from CURSOR. */
+ entry = new StatCacheEntry ();
+ entry.flags = cursor.getInt (flagsIndex);
+ type = cursor.getString (typeIndex);
+
+ if (type == null)
+ return null;
+
+ entry.isDirectory = type.equals (Document.MIME_TYPE_DIR);
+
+ if (cursor.isNull (sizeIndex))
+ /* The size is unknown. */
+ entry.size = -1;
+ else
+ entry.size = cursor.getLong (sizeIndex);
+
+ /* mtimeIndex is potentially unset, since document providers
+ aren't obligated to provide modification times. */
+
+ if (mtimeIndex >= 0 && !cursor.isNull (mtimeIndex))
+ entry.mtime = cursor.getLong (mtimeIndex);
+
+ /* Finally, add this entry to the cache and return. */
+ if (!no_cache)
+ toplevel.statCache.put (documentId, entry);
+ return entry;
+ }
+
+ /* Cache the type and as many of the children of the directory
+ designated by DOCUMENTID as possible into TOPLEVEL.
+
+ CURSOR should be a cursor representing an open directory stream,
+ with its projection consisting of at least the display name,
+ document ID and MIME type columns.
+
+ Rewind the position of CURSOR to before its first element after
+ completion. */
+
+ private void
+ cacheDirectoryFromCursor (CacheToplevel toplevel, String documentId,
+ Cursor cursor)
+ {
+ CacheEntry entry, constituent;
+ int nameColumn, idColumn, typeColumn;
+ String id, name, type;
+ DocIdEntry idEntry;
+
+ /* Find the numbers of the columns wanted. */
+
+ nameColumn
+ = cursor.getColumnIndex (Document.COLUMN_DISPLAY_NAME);
+ idColumn
+ = cursor.getColumnIndex (Document.COLUMN_DOCUMENT_ID);
+ typeColumn
+ = cursor.getColumnIndex (Document.COLUMN_MIME_TYPE);
+
+ if (nameColumn < 0 || idColumn < 0 || typeColumn < 0)
+ return;
+
+ entry = new CacheEntry ();
+
+ /* We know this is a directory already. */
+ entry.type = Document.MIME_TYPE_DIR;
+ toplevel.idCache.put (documentId, entry);
+
+ /* Now, try to cache each of its constituents. */
+
+ while (cursor.moveToNext ())
+ {
+ try
+ {
+ name = cursor.getString (nameColumn);
+ id = cursor.getString (idColumn);
+ type = cursor.getString (typeColumn);
+
+ if (name == null || id == null || type == null)
+ continue;
+
+ /* First, add the name and ID to ENTRY's map of
+ children. */
+ idEntry = new DocIdEntry ();
+ idEntry.documentId = id;
+ entry.children.put (id, idEntry);
+
+ /* Cache the file status for ID within TOPELVEL too; if a
+ directory listing is being requested, it's very likely
+ that a series of calls for file status will follow. */
+
+ cacheFileStatus (id, toplevel, cursor, false);
+
+ /* If this constituent is a directory, don't cache any
+ information about it. It cannot be cached without
+ knowing its children. */
+
+ if (type.equals (Document.MIME_TYPE_DIR))
+ continue;
+
+ /* Otherwise, create a new cache entry comprised of its
+ type. */
+ constituent = new CacheEntry ();
+ constituent.type = type;
+ toplevel.idCache.put (documentId, entry);
+ }
+ catch (Exception e)
+ {
+ e.printStackTrace ();
+ continue;
+ }
+ }
+
+ /* Rewind cursor back to the beginning. */
+ cursor.moveToPosition (-1);
+ }
+
+ /* Post a message to run `pruneCache' every CACHE_PRUNE_TIME
+ seconds. */
+
+ private void
+ postPruneMessage ()
+ {
+ handler.postDelayed (new Runnable () {
+ @Override
+ public void
+ run ()
+ {
+ pruneCache ();
+ }
+ }, CACHE_PRUNE_TIME * 1000);
+ }
+
+ /* Invalidate the cache entry denoted by DOCUMENT_ID, within the
+ document tree URI.
+ Call this after deleting a document or directory.
+
+ At the same time, remove the final component within the file name
+ CACHENAME from the cache if it exists. */
+
+ public void
+ postInvalidateCache (final Uri uri, final String documentId,
+ final String cacheName)
+ {
+ handler.post (new Runnable () {
+ @Override
+ public void
+ run ()
+ {
+ CacheToplevel toplevel;
+ HashMap<String, DocIdEntry> children;
+ String[] components;
+ CacheEntry entry;
+ DocIdEntry idEntry;
+
+ toplevel = getCache (uri);
+ toplevel.idCache.remove (documentId);
+ toplevel.statCache.remove (documentId);
+
+ /* If the parent of CACHENAME is cached, remove it. */
+
+ children = toplevel.children;
+ components = cacheName.split ("/");
+
+ for (String component : components)
+ {
+ /* Java `split' removes trailing empty matches but not
+ leading or intermediary ones. */
+ if (component.isEmpty ())
+ continue;
+
+ if (component == components[components.length - 1])
+ {
+ /* This is the last component, so remove it from
+ children. */
+ children.remove (component);
+ return;
+ }
+ else
+ {
+ /* Search for this component within the last level
+ of the cache. */
+
+ idEntry = children.get (component);
+
+ if (idEntry == null)
+ /* Not cached, so return. */
+ return;
+
+ entry = toplevel.idCache.get (idEntry.documentId);
+
+ if (entry == null)
+ /* Not cached, so return. */
+ return;
+
+ /* Locate the next component within this
+ directory. */
+ children = entry.children;
+ }
+ }
+ }
+ });
+ }
+
+ /* Invalidate the cache entry denoted by DOCUMENT_ID, within the
+ document tree URI.
+ Call this after deleting a document or directory.
+
+ At the same time, remove the child referring to DOCUMENTID from
+ within CACHENAME's cache entry if it exists. */
+
+ public void
+ postInvalidateCacheDir (final Uri uri, final String documentId,
+ final String cacheName)
+ {
+ handler.post (new Runnable () {
+ @Override
+ public void
+ run ()
+ {
+ CacheToplevel toplevel;
+ HashMap<String, DocIdEntry> children;
+ String[] components;
+ CacheEntry entry;
+ DocIdEntry idEntry;
+ Iterator<DocIdEntry> iter;
+
+ toplevel = getCache (uri);
+ toplevel.idCache.remove (documentId);
+ toplevel.statCache.remove (documentId);
+
+ /* Now remove DOCUMENTID from CACHENAME's cache entry, if
+ any. */
+
+ children = toplevel.children;
+ components = cacheName.split ("/");
+
+ for (String component : components)
+ {
+ /* Java `split' removes trailing empty matches but not
+ leading or intermediary ones. */
+ if (component.isEmpty ())
+ continue;
+
+ /* Search for this component within the last level
+ of the cache. */
+
+ idEntry = children.get (component);
+
+ if (idEntry == null)
+ /* Not cached, so return. */
+ return;
+
+ entry = toplevel.idCache.get (idEntry.documentId);
+
+ if (entry == null)
+ /* Not cached, so return. */
+ return;
+
+ /* Locate the next component within this
+ directory. */
+ children = entry.children;
+ }
+
+ iter = children.values ().iterator ();
+ while (iter.hasNext ())
+ {
+ idEntry = iter.next ();
+
+ if (idEntry.documentId.equals (documentId))
+ {
+ iter.remove ();
+ break;
+ }
+ }
+ }
+ });
+ }
+
+ /* Invalidate the file status cache entry for DOCUMENTID within URI.
+ Call this when the contents of a file (i.e. the constituents of a
+ directory file) may have changed, but the document's display name
+ has not. */
+
+ public void
+ postInvalidateStat (final Uri uri, final String documentId)
+ {
+ handler.post (new Runnable () {
+ @Override
+ public void
+ run ()
+ {
+ CacheToplevel toplevel;
+
+ toplevel = getCache (uri);
+ toplevel.statCache.remove (documentId);
+ }
+ });
+ }
+
+
+
+ /* ``Prototypes'' for nested functions that are run within the SAF
+ thread and accepts a cancellation signal. They differ in their
+ return types. */
+
+ private abstract class SafIntFunction
+ {
+ /* The ``throws Throwable'' here is a Java idiosyncrasy that tells
+ the compiler to allow arbitrary error objects to be signaled
+ from within this function.
+
+ Later, runIntFunction will try to re-throw any error object
+ generated by this function in the Emacs thread, using a trick
+ to avoid the compiler requirement to expressly declare that an
+ error (and which types of errors) will be signaled. */
+
+ public abstract int runInt (CancellationSignal signal)
+ throws Throwable;
+ };
+
+ private abstract class SafObjectFunction
+ {
+ /* The ``throws Throwable'' here is a Java idiosyncrasy that tells
+ the compiler to allow arbitrary error objects to be signaled
+ from within this function.
+
+ Later, runObjectFunction will try to re-throw any error object
+ generated by this function in the Emacs thread, using a trick
+ to avoid the compiler requirement to expressly declare that an
+ error (and which types of errors) will be signaled. */
+
+ public abstract Object runObject (CancellationSignal signal)
+ throws Throwable;
+ };
+
+
+
+ /* Functions that run cancel-able queries. These functions are
+ internally run within the SAF thread. */
+
+ /* Throw the specified EXCEPTION. The type template T is erased by
+ the compiler before the object is compiled, so the compiled code
+ simply throws EXCEPTION without the cast being verified.
+
+ T should be RuntimeException to obtain the desired effect of
+ throwing an exception without a compiler check. */
+
+ @SuppressWarnings("unchecked")
+ private static <T extends Throwable> void
+ throwException (Throwable exception)
+ throws T
+ {
+ throw (T) exception;
+ }
+
+ /* Run the given function (or rather, its `runInt' field) within the
+ SAF thread, waiting for it to complete.
+
+ If async input arrives in the meantime and sets Vquit_flag,
+ signal the cancellation signal supplied to that function.
+
+ Rethrow any exception thrown from that function, and return its
+ value otherwise. */
+
+ private int
+ runIntFunction (final SafIntFunction function)
+ {
+ final EmacsHolder<Object> result;
+ final CancellationSignal signal;
+ Throwable throwable;
+
+ result = new EmacsHolder<Object> ();
+ signal = new CancellationSignal ();
+
+ handler.post (new Runnable () {
+ @Override
+ public void
+ run ()
+ {
+ try
+ {
+ result.thing
+ = Integer.valueOf (function.runInt (signal));
+ }
+ catch (Throwable throwable)
+ {
+ result.thing = throwable;
+ }
+
+ EmacsNative.safPostRequest ();
+ }
+ });
+
+ if (EmacsNative.safSyncAndReadInput () != 0)
+ {
+ signal.cancel ();
+
+ /* Now wait for the function to finish. Either the signal has
+ arrived after the query took place, in which case it will
+ finish normally, or an OperationCanceledException will be
+ thrown. */
+
+ EmacsNative.safSync ();
+ }
+
+ if (result.thing instanceof Throwable)
+ {
+ throwable = (Throwable) result.thing;
+ EmacsSafThread.<RuntimeException>throwException (throwable);
+ }
+
+ return (Integer) result.thing;
+ }
+
+ /* Run the given function (or rather, its `runObject' field) within
+ the SAF thread, waiting for it to complete.
+
+ If async input arrives in the meantime and sets Vquit_flag,
+ signal the cancellation signal supplied to that function.
+
+ Rethrow any exception thrown from that function, and return its
+ value otherwise. */
+
+ private Object
+ runObjectFunction (final SafObjectFunction function)
+ {
+ final EmacsHolder<Object> result;
+ final CancellationSignal signal;
+ Throwable throwable;
+
+ result = new EmacsHolder<Object> ();
+ signal = new CancellationSignal ();
+
+ handler.post (new Runnable () {
+ @Override
+ public void
+ run ()
+ {
+ try
+ {
+ result.thing = function.runObject (signal);
+ }
+ catch (Throwable throwable)
+ {
+ result.thing = throwable;
+ }
+
+ EmacsNative.safPostRequest ();
+ }
+ });
+
+ if (EmacsNative.safSyncAndReadInput () != 0)
+ {
+ signal.cancel ();
+
+ /* Now wait for the function to finish. Either the signal has
+ arrived after the query took place, in which case it will
+ finish normally, or an OperationCanceledException will be
+ thrown. */
+
+ EmacsNative.safSync ();
+ }
+
+ if (result.thing instanceof Throwable)
+ {
+ throwable = (Throwable) result.thing;
+ EmacsSafThread.<RuntimeException>throwException (throwable);
+ }
+
+ return result.thing;
+ }
+
+ /* The crux of `documentIdFromName1', run within the SAF thread.
+ SIGNAL should be a cancellation signal run upon quitting. */
+
+ private int
+ documentIdFromName1 (String tree_uri, String name,
+ String[] id_return, CancellationSignal signal)
+ {
+ Uri uri, treeUri;
+ String id, type, newId, newType;
+ String[] components, projection;
+ Cursor cursor;
+ int nameColumn, idColumn, typeColumn;
+ CacheToplevel toplevel;
+ DocIdEntry idEntry;
+ HashMap<String, DocIdEntry> children, next;
+ CacheEntry cache;
+
+ projection = new String[] {
+ Document.COLUMN_DISPLAY_NAME,
+ Document.COLUMN_DOCUMENT_ID,
+ Document.COLUMN_MIME_TYPE,
+ };
+
+ /* Parse the URI identifying the tree first. */
+ uri = Uri.parse (tree_uri);
+
+ /* Now, split NAME into its individual components. */
+ components = name.split ("/");
+
+ /* Set id and type to the value at the root of the tree. */
+ type = id = null;
+ cursor = null;
+
+ /* Obtain the top level of this cache. */
+ toplevel = getCache (uri);
+
+ /* Set the current map of children to this top level. */
+ children = toplevel.children;
+
+ /* For each component... */
+
+ try
+ {
+ for (String component : components)
+ {
+ /* Java split doesn't behave very much like strtok when it
+ comes to trailing and leading delimiters... */
+ if (component.isEmpty ())
+ continue;
+
+ /* Search for component within the currently cached list
+ of children. */
+
+ idEntry = children.get (component);
+
+ if (idEntry != null)
+ {
+ /* The document ID is known. Now find the
+ corresponding document ID cache. */
+
+ cache = toplevel.idCache.get (idEntry.documentId);
+
+ /* Fetch just the information for this document. */
+
+ if (cache == null)
+ cache = idEntry.getCacheEntry (resolver, uri, toplevel,
+ signal);
+
+ if (cache == null)
+ {
+ /* File status matching idEntry could not be
+ obtained. Treat this as if the file does not
+ exist. */
+
+ children.remove (component);
+
+ if (id == null)
+ id = DocumentsContract.getTreeDocumentId (uri);
+
+ id_return[0] = id;
+
+ if ((type == null
+ || type.equals (Document.MIME_TYPE_DIR))
+ /* ... and type and id currently represent the
+ penultimate component. */
+ && component == components[components.length - 1])
+ return -2;
+
+ return -1;
+ }
+
+ /* Otherwise, use the cached information. */
+ id = idEntry.documentId;
+ type = cache.type;
+ children = cache.children;
+ continue;
+ }
+
+ /* Create the tree URI for URI from ID if it exists, or
+ the root otherwise. */
+
+ if (id == null)
+ id = DocumentsContract.getTreeDocumentId (uri);
+
+ treeUri
+ = DocumentsContract.buildChildDocumentsUriUsingTree (uri, id);
+
+ /* Look for a file in this directory by the name of
+ component. */
+
+ cursor = resolver.query (treeUri, projection,
+ (Document.COLUMN_DISPLAY_NAME
+ + " = ?"),
+ new String[] { component, },
+ null, signal);
+
+ if (cursor == null)
+ return -1;
+
+ /* Find the column numbers for each of the columns that
+ are wanted. */
+
+ nameColumn
+ = cursor.getColumnIndex (Document.COLUMN_DISPLAY_NAME);
+ idColumn
+ = cursor.getColumnIndex (Document.COLUMN_DOCUMENT_ID);
+ typeColumn
+ = cursor.getColumnIndex (Document.COLUMN_MIME_TYPE);
+
+ if (nameColumn < 0 || idColumn < 0 || typeColumn < 0)
+ return -1;
+
+ next = null;
+
+ while (true)
+ {
+ /* Even though the query selects for a specific
+ display name, some content providers nevertheless
+ return every file within the directory. */
+
+ if (!cursor.moveToNext ())
+ {
+ /* If a component has been found, break out of the
+ loop. */
+
+ if (next != null)
+ break;
+
+ /* If the last component considered is a
+ directory... */
+ if ((type == null
+ || type.equals (Document.MIME_TYPE_DIR))
+ /* ... and type and id currently represent the
+ penultimate component. */
+ && component == components[components.length - 1])
+ {
+ /* The cursor is empty. In this case, return
+ -2 and the current document ID (belonging
+ to the previous component) in
+ ID_RETURN. */
+
+ id_return[0] = id;
+
+ /* But return -1 on the off chance that id is
+ null. */
+
+ if (id == null)
+ return -1;
+
+ return -2;
+ }
+
+ /* The last component found is not a directory, so
+ return -1. */
+ return -1;
+ }
+
+ /* So move CURSOR to a row with the right display
+ name. */
+
+ name = cursor.getString (nameColumn);
+ newId = cursor.getString (idColumn);
+ newType = cursor.getString (typeColumn);
+
+ /* Any of the three variables above may be NULL if the
+ column data is of the wrong type depending on how
+ the Cursor returned is implemented. */
+
+ if (name == null || newId == null || newType == null)
+ return -1;
+
+ /* Cache this name, even if it isn't the document
+ that's being searched for. */
+
+ cache = cacheChild (toplevel, children, name,
+ newId, newType,
+ idEntry != null);
+
+ /* Record the desired component once it is located,
+ but continue reading and caching items from the
+ cursor. */
+
+ if (name.equals (component))
+ {
+ id = newId;
+ next = cache.children;
+ type = newType;
+ }
+ }
+
+ children = next;
+
+ /* Now close the cursor. */
+ cursor.close ();
+ cursor = null;
+
+ /* ID may have become NULL if the data is in an invalid
+ format. */
+ if (id == null)
+ return -1;
+ }
+ }
+ finally
+ {
+ /* If an error is thrown within the block above, let
+ android_saf_exception_check handle it, but make sure the
+ cursor is closed. */
+
+ if (cursor != null)
+ cursor.close ();
+ }
+
+ /* Here, id is either NULL (meaning the same as TREE_URI), and
+ type is either NULL (in which case id should also be NULL) or
+ the MIME type of the file. */
+
+ /* First return the ID. */
+
+ if (id == null)
+ id_return[0] = DocumentsContract.getTreeDocumentId (uri);
+ else
+ id_return[0] = id;
+
+ /* Next, return whether or not this is a directory. */
+ if (type == null || type.equals (Document.MIME_TYPE_DIR))
+ return 1;
+
+ return 0;
+ }
+
+ /* Find the document ID of the file within TREE_URI designated by
+ NAME.
+
+ NAME is a ``file name'' comprised of the display names of
+ individual files. Each constituent component prior to the last
+ must name a directory file within TREE_URI.
+
+ Upon success, return 0 or 1 (contingent upon whether or not the
+ last component within NAME is a directory) and place the document
+ ID of the named file in ID_RETURN[0].
+
+ If the designated file can't be located, but each component of
+ NAME up to the last component can and is a directory, return -2
+ and the ID of the last component located in ID_RETURN[0].
+
+ If the designated file can't be located, return -1, or signal one
+ of OperationCanceledException, SecurityException,
+ FileNotFoundException, or UnsupportedOperationException. */
+
+ public int
+ documentIdFromName (final String tree_uri, final String name,
+ final String[] id_return)
+ {
+ return runIntFunction (new SafIntFunction () {
+ @Override
+ public int
+ runInt (CancellationSignal signal)
+ {
+ return documentIdFromName1 (tree_uri, name, id_return,
+ signal);
+ }
+ });
+ }
+
+ /* The bulk of `statDocument'. SIGNAL should be a cancellation
+ signal. */
+
+ private long[]
+ statDocument1 (String uri, String documentId,
+ CancellationSignal signal, boolean noCache)
+ {
+ Uri uriObject, tree;
+ String[] projection;
+ long[] stat;
+ Cursor cursor;
+ CacheToplevel toplevel;
+ StatCacheEntry cache;
+
+ tree = Uri.parse (uri);
+
+ if (documentId == null)
+ documentId = DocumentsContract.getTreeDocumentId (tree);
+
+ /* Create a document URI representing DOCUMENTID within URI's
+ authority. */
+
+ uriObject
+ = DocumentsContract.buildDocumentUriUsingTree (tree, documentId);
+
+ /* See if the file status cache currently contains this
+ document. */
+
+ toplevel = getCache (tree);
+ cache = toplevel.statCache.get (documentId);
+
+ if (cache == null || !cache.isValid ())
+ {
+ /* Stat this document and enter its information into the
+ cache. */
+
+ projection = new String[] {
+ Document.COLUMN_FLAGS,
+ Document.COLUMN_LAST_MODIFIED,
+ Document.COLUMN_MIME_TYPE,
+ Document.COLUMN_SIZE,
+ };
+
+ cursor = resolver.query (uriObject, projection, null,
+ null, null, signal);
+
+ if (cursor == null)
+ return null;
+
+ try
+ {
+ if (!cursor.moveToFirst ())
+ return null;
+
+ cache = cacheFileStatus (documentId, toplevel, cursor,
+ noCache);
+ }
+ finally
+ {
+ cursor.close ();
+ }
+
+ /* If cache is still null, return null. */
+
+ if (cache == null)
+ return null;
+ }
+
+ /* Create the array of file status and populate it with the
+ information within cache. */
+ stat = new long[3];
+
+ stat[0] |= S_IRUSR;
+ if ((cache.flags & Document.FLAG_SUPPORTS_WRITE) != 0)
+ stat[0] |= S_IWUSR;
+
+ if (Build.VERSION.SDK_INT >= Build.VERSION_CODES.N
+ && (cache.flags & Document.FLAG_VIRTUAL_DOCUMENT) != 0)
+ stat[0] |= S_IFCHR;
+
+ stat[1] = cache.size;
+
+ /* Check if this is a directory file. */
+ if (cache.isDirectory
+ /* Files shouldn't be specials and directories at the same
+ time, but Android doesn't forbid document providers
+ from returning this information. */
+ && (stat[0] & S_IFCHR) == 0)
+ {
+ /* Since FLAG_SUPPORTS_WRITE doesn't apply to directories,
+ just assume they're writable. */
+ stat[0] |= S_IFDIR | S_IWUSR | S_IXUSR;
+
+ /* Directory files cannot be modified if
+ FLAG_DIR_SUPPORTS_CREATE is not set. */
+
+ if ((cache.flags & Document.FLAG_DIR_SUPPORTS_CREATE) == 0)
+ stat[0] &= ~S_IWUSR;
+ }
+
+ /* If this file is neither a character special nor a
+ directory, indicate that it's a regular file. */
+
+ if ((stat[0] & (S_IFDIR | S_IFCHR)) == 0)
+ stat[0] |= S_IFREG;
+
+ stat[2] = cache.mtime;
+ return stat;
+ }
+
+ /* Return file status for the document designated by the given
+ DOCUMENTID and tree URI. If DOCUMENTID is NULL, use the document
+ ID in URI itself.
+
+ Value is null upon failure, or an array of longs [MODE, SIZE,
+ MTIM] upon success, where MODE contains the file type and access
+ modes of the file as in `struct stat', SIZE is the size of the
+ file in BYTES or -1 if not known, and MTIM is the time of the
+ last modification to this file in milliseconds since 00:00,
+ January 1st, 1970.
+
+ If NOCACHE, refrain from placing the file status within the
+ status cache.
+
+ OperationCanceledException and other typical exceptions may be
+ signaled upon receiving async input or other errors. */
+
+ public long[]
+ statDocument (final String uri, final String documentId,
+ final boolean noCache)
+ {
+ return (long[]) runObjectFunction (new SafObjectFunction () {
+ @Override
+ public Object
+ runObject (CancellationSignal signal)
+ {
+ return statDocument1 (uri, documentId, signal, noCache);
+ }
+ });
+ }
+
+ /* The bulk of `accessDocument'. SIGNAL should be a cancellation
+ signal. */
+
+ private int
+ accessDocument1 (String uri, String documentId, boolean writable,
+ CancellationSignal signal)
+ {
+ Uri uriObject;
+ String[] projection;
+ int tem, index;
+ String tem1;
+ Cursor cursor;
+ CacheToplevel toplevel;
+ CacheEntry entry;
+
+ uriObject = Uri.parse (uri);
+
+ if (documentId == null)
+ documentId = DocumentsContract.getTreeDocumentId (uriObject);
+
+ /* If WRITABLE is false and the document ID is cached, use its
+ cached value instead. This speeds up
+ `directory-files-with-attributes' a little. */
+
+ if (!writable)
+ {
+ toplevel = getCache (uriObject);
+ entry = toplevel.idCache.get (documentId);
+
+ if (entry != null)
+ return 0;
+ }
+
+ /* Create a document URI representing DOCUMENTID within URI's
+ authority. */
+
+ uriObject
+ = DocumentsContract.buildDocumentUriUsingTree (uriObject, documentId);
+
+ /* Now stat this document. */
+
+ projection = new String[] {
+ Document.COLUMN_FLAGS,
+ Document.COLUMN_MIME_TYPE,
+ };
+
+ cursor = resolver.query (uriObject, projection, null,
+ null, null, signal);
+
+ if (cursor == null)
+ return -1;
+
+ try
+ {
+ if (!cursor.moveToFirst ())
+ return -1;
+
+ if (!writable)
+ return 0;
+
+ index = cursor.getColumnIndex (Document.COLUMN_MIME_TYPE);
+ if (index < 0)
+ return -3;
+
+ /* Get the type of this file to check if it's a directory. */
+ tem1 = cursor.getString (index);
+
+ /* Check if this is a directory file. */
+ if (tem1.equals (Document.MIME_TYPE_DIR))
+ {
+ /* If so, don't check for FLAG_SUPPORTS_WRITE.
+ Check for FLAG_DIR_SUPPORTS_CREATE instead. */
+
+ index = cursor.getColumnIndex (Document.COLUMN_FLAGS);
+ if (index < 0)
+ return -3;
+
+ tem = cursor.getInt (index);
+ if ((tem & Document.FLAG_DIR_SUPPORTS_CREATE) == 0)
+ return -3;
+
+ return 0;
+ }
+
+ index = cursor.getColumnIndex (Document.COLUMN_FLAGS);
+ if (index < 0)
+ return -3;
+
+ tem = cursor.getInt (index);
+ if (writable && (tem & Document.FLAG_SUPPORTS_WRITE) == 0)
+ return -3;
+ }
+ finally
+ {
+ /* Close the cursor if an exception occurs. */
+ cursor.close ();
+ }
+
+ return 0;
+ }
+
+ /* Find out whether Emacs has access to the document designated by
+ the specified DOCUMENTID within the tree URI. If DOCUMENTID is
+ NULL, use the document ID in URI itself.
+
+ If WRITABLE, also check that the file is writable, which is true
+ if it is either a directory or its flags contains
+ FLAG_SUPPORTS_WRITE.
+
+ Value is 0 if the file is accessible, and one of the following if
+ not:
+
+ -1, if the file does not exist.
+ -2, if WRITABLE and the file is not writable.
+ -3, upon any other error.
+
+ In addition, arbitrary runtime exceptions (such as
+ SecurityException or UnsupportedOperationException) may be
+ thrown. */
+
+ public int
+ accessDocument (final String uri, final String documentId,
+ final boolean writable)
+ {
+ return runIntFunction (new SafIntFunction () {
+ @Override
+ public int
+ runInt (CancellationSignal signal)
+ {
+ return accessDocument1 (uri, documentId, writable,
+ signal);
+ }
+ });
+ }
+
+ /* The crux of openDocumentDirectory. SIGNAL must be a cancellation
+ signal. */
+
+ private Cursor
+ openDocumentDirectory1 (String uri, String documentId,
+ CancellationSignal signal)
+ {
+ Uri uriObject, tree;
+ Cursor cursor;
+ String projection[];
+ CacheToplevel toplevel;
+
+ tree = uriObject = Uri.parse (uri);
+
+ /* If documentId is not set, use the document ID of the tree URI
+ itself. */
+
+ if (documentId == null)
+ documentId = DocumentsContract.getTreeDocumentId (uriObject);
+
+ /* Build a URI representing each directory entry within
+ DOCUMENTID. */
+
+ uriObject
+ = DocumentsContract.buildChildDocumentsUriUsingTree (uriObject,
+ documentId);
+
+ projection = new String [] {
+ Document.COLUMN_DISPLAY_NAME,
+ Document.COLUMN_DOCUMENT_ID,
+ Document.COLUMN_MIME_TYPE,
+ Document.COLUMN_FLAGS,
+ Document.COLUMN_LAST_MODIFIED,
+ Document.COLUMN_SIZE,
+ };
+
+ cursor = resolver.query (uriObject, projection, null, null,
+ null, signal);
+
+ /* Create a new cache entry tied to this document ID. */
+
+ if (cursor != null)
+ {
+ toplevel = getCache (tree);
+ cacheDirectoryFromCursor (toplevel, documentId,
+ cursor);
+ }
+
+ /* Return the cursor. */
+ return cursor;
+ }
+
+ /* Open a cursor representing each entry within the directory
+ designated by the specified DOCUMENTID within the tree URI.
+
+ If DOCUMENTID is NULL, use the document ID within URI itself.
+ Value is NULL upon failure.
+
+ In addition, arbitrary runtime exceptions (such as
+ SecurityException or UnsupportedOperationException) may be
+ thrown. */
+
+ public Cursor
+ openDocumentDirectory (final String uri, final String documentId)
+ {
+ return (Cursor) runObjectFunction (new SafObjectFunction () {
+ @Override
+ public Object
+ runObject (CancellationSignal signal)
+ {
+ return openDocumentDirectory1 (uri, documentId, signal);
+ }
+ });
+ }
+
+ /* The crux of `openDocument'. SIGNAL must be a cancellation
+ signal. */
+
+ public ParcelFileDescriptor
+ openDocument1 (String uri, String documentId, boolean read,
+ boolean write, boolean truncate,
+ CancellationSignal signal)
+ throws Throwable
+ {
+ Uri treeUri, documentUri;
+ String mode;
+ ParcelFileDescriptor fileDescriptor;
+ CacheToplevel toplevel;
+
+ treeUri = Uri.parse (uri);
+
+ /* documentId must be set for this request, since it doesn't make
+ sense to ``open'' the root of the directory tree. */
+
+ documentUri
+ = DocumentsContract.buildDocumentUriUsingTree (treeUri, documentId);
+
+ /* Select the mode used to open the file. */
+
+ if (write)
+ {
+ if (read)
+ {
+ if (truncate)
+ mode = "rwt";
+ else
+ mode = "rw";
+ }
+ else
+ /* Set mode to w when WRITE && !READ, disregarding TRUNCATE.
+ In contradiction with the ContentResolver documentation,
+ document providers seem to truncate files whenever w is
+ specified, at least superficially. (But see below.) */
+ mode = "w";
+ }
+ else
+ mode = "r";
+
+ fileDescriptor
+ = resolver.openFileDescriptor (documentUri, mode,
+ signal);
+
+ /* If a writable on-disk file descriptor is requested and TRUNCATE
+ is set, then probe the file descriptor to detect if it is
+ actually readable. If not, close this file descriptor and
+ reopen it with MODE set to rw; some document providers granting
+ access to Samba shares don't implement rwt, but these document
+ providers invariably truncate the file opened even when the
+ mode is merely w.
+
+ This may be ascribed to a mix-up in Android's documentation
+ regardin DocumentsProvider: the `openDocument' function is only
+ documented to accept r or rw, whereas the default
+ implementation of the `openFile' function (which documents rwt)
+ delegates to `openDocument'. */
+
+ if (read && write && truncate && fileDescriptor != null
+ && !EmacsNative.ftruncate (fileDescriptor.getFd ()))
+ {
+ try
+ {
+ fileDescriptor.closeWithError ("File descriptor requested"
+ + " is not writable");
+ }
+ catch (IOException e)
+ {
+ Log.w (TAG, "Leaking unclosed file descriptor " + e);
+ }
+
+ fileDescriptor
+ = resolver.openFileDescriptor (documentUri, "rw", signal);
+
+ /* Try to truncate fileDescriptor just to stay on the safe
+ side. */
+ if (fileDescriptor != null)
+ EmacsNative.ftruncate (fileDescriptor.getFd ());
+ }
+ else if (!read && write && truncate && fileDescriptor != null)
+ /* Moreover, document providers that return actual seekable
+ files characteristically neglect to truncate the file
+ returned when the access mode is merely w, so attempt to
+ truncate it by hand. */
+ EmacsNative.ftruncate (fileDescriptor.getFd ());
+
+ /* Every time a document is opened, remove it from the file status
+ cache. */
+ toplevel = getCache (treeUri);
+ toplevel.statCache.remove (documentId);
+
+ return fileDescriptor;
+ }
+
+ /* Open a file descriptor for a file document designated by
+ DOCUMENTID within the document tree identified by URI. If
+ TRUNCATE and the document already exists, truncate its contents
+ before returning.
+
+ If READ && WRITE, open the file under either the `rw' or `rwt'
+ access mode, which implies that the value must be a seekable
+ on-disk file. If WRITE && !READ or TRUNC && WRITE, also truncate
+ the file after it is opened.
+
+ If only READ or WRITE is set, value may be a non-seekable FIFO or
+ one end of a socket pair.
+
+ Value is NULL upon failure or a parcel file descriptor upon
+ success. Call `ParcelFileDescriptor.close' on this file
+ descriptor instead of using the `close' system call.
+
+ FileNotFoundException and/or SecurityException and/or
+ UnsupportedOperationException and/or OperationCanceledException
+ may be thrown upon failure. */
+
+ public ParcelFileDescriptor
+ openDocument (final String uri, final String documentId,
+ final boolean read, final boolean write,
+ final boolean truncate)
+ {
+ Object tem;
+
+ tem = runObjectFunction (new SafObjectFunction () {
+ @Override
+ public Object
+ runObject (CancellationSignal signal)
+ throws Throwable
+ {
+ return openDocument1 (uri, documentId, read,
+ write, truncate, signal);
+ }
+ });
+
+ return (ParcelFileDescriptor) tem;
+ }
+};
diff --git a/java/org/gnu/emacs/EmacsSdk11Clipboard.java b/java/org/gnu/emacs/EmacsSdk11Clipboard.java
new file mode 100644
index 00000000000..850bb6c8deb
--- /dev/null
+++ b/java/org/gnu/emacs/EmacsSdk11Clipboard.java
@@ -0,0 +1,308 @@
+/* Communication module for Android terminals. -*- c-file-style: "GNU" -*-
+
+Copyright (C) 2023-2024 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 <https://www.gnu.org/licenses/>. */
+
+package org.gnu.emacs;
+
+import android.content.ClipboardManager;
+import android.content.Context;
+import android.content.ContentResolver;
+import android.content.ClipData;
+import android.content.ClipDescription;
+
+import android.content.res.AssetFileDescriptor;
+
+import android.net.Uri;
+
+import android.util.Log;
+
+import android.os.Build;
+
+import java.io.FileNotFoundException;
+import java.io.IOException;
+import java.io.UnsupportedEncodingException;
+
+/* This class implements EmacsClipboard for Android 3.0 and later
+ systems. */
+
+public final class EmacsSdk11Clipboard extends EmacsClipboard
+ implements ClipboardManager.OnPrimaryClipChangedListener
+{
+ private static final String TAG = "EmacsSdk11Clipboard";
+ private ClipboardManager manager;
+ private boolean ownsClipboard;
+ private int clipboardChangedCount;
+ private int monitoredClipboardChangedCount;
+ private ContentResolver resolver;
+
+ public
+ EmacsSdk11Clipboard ()
+ {
+ manager = EmacsService.SERVICE.getClipboardManager ();
+
+ /* The system forbids Emacs from reading clipboard data in the
+ background under Android 10 or later. */
+
+ if (Build.VERSION.SDK_INT < Build.VERSION_CODES.Q)
+ manager.addPrimaryClipChangedListener (this);
+
+ /* Now obtain the content resolver used to open file
+ descriptors. */
+
+ resolver = EmacsService.SERVICE.getContentResolver ();
+ }
+
+ @Override
+ public synchronized void
+ onPrimaryClipChanged ()
+ {
+ /* Increment monitoredClipboardChangeCount. If it is now greater
+ than clipboardChangedCount, then Emacs no longer owns the
+ clipboard. */
+ monitoredClipboardChangedCount++;
+
+ if (monitoredClipboardChangedCount > clipboardChangedCount)
+ {
+ ownsClipboard = false;
+
+ /* Reset both values back to 0. */
+ monitoredClipboardChangedCount = 0;
+ clipboardChangedCount = 0;
+ }
+ }
+
+ /* Set the clipboard text to CLIPBOARD, a string in UTF-8
+ encoding. */
+
+ @Override
+ public synchronized void
+ setClipboard (byte[] bytes)
+ {
+ ClipData data;
+ String string;
+
+ try
+ {
+ string = new String (bytes, "UTF-8");
+ data = ClipData.newPlainText ("Emacs", string);
+ manager.setPrimaryClip (data);
+ ownsClipboard = true;
+
+ /* onPrimaryClipChanged will be called again. Use this
+ variable to keep track of how many times the clipboard has
+ been changed. */
+ ++clipboardChangedCount;
+ }
+ catch (UnsupportedEncodingException exception)
+ {
+ Log.w (TAG, "setClipboard: " + exception);
+ }
+ }
+
+ /* Return whether or not Emacs owns the clipboard. Value is 1 if
+ Emacs does, 0 if Emacs does not, and -1 if that information is
+ unavailable. */
+
+ @Override
+ public synchronized int
+ ownsClipboard ()
+ {
+ if (Build.VERSION.SDK_INT >= Build.VERSION_CODES.Q)
+ return -1;
+
+ return ownsClipboard ? 1 : 0;
+ }
+
+ /* Return whether or not clipboard content currently exists. */
+
+ @Override
+ public boolean
+ clipboardExists ()
+ {
+ return manager.hasPrimaryClip ();
+ }
+
+ /* Return the current content of the clipboard, as plain text, or
+ NULL if no content is available. */
+
+ @Override
+ public byte[]
+ getClipboard ()
+ {
+ ClipData clip;
+ CharSequence text;
+ Context context;
+
+ clip = manager.getPrimaryClip ();
+
+ if (clip == null || clip.getItemCount () < 1)
+ return null;
+
+ context = EmacsService.SERVICE;
+
+ try
+ {
+ text = clip.getItemAt (0).coerceToText (context);
+ return text.toString ().getBytes ("UTF-8");
+ }
+ catch (UnsupportedEncodingException exception)
+ {
+ Log.w (TAG, "getClipboard: " + exception);
+ }
+
+ return null;
+ }
+
+ /* Return an array of targets currently provided by the
+ clipboard, or NULL if there are none. */
+
+ @Override
+ public byte[][]
+ getClipboardTargets ()
+ {
+ ClipData clip;
+ ClipDescription description;
+ byte[][] typeArray;
+ int i;
+
+ /* N.B. that Android calls the clipboard the ``primary clip''; it
+ is not related to the X primary selection. */
+ clip = manager.getPrimaryClip ();
+
+ if (clip == null)
+ return null;
+
+ description = clip.getDescription ();
+ i = description.getMimeTypeCount ();
+ typeArray = new byte[i][i];
+
+ try
+ {
+ for (i = 0; i < description.getMimeTypeCount (); ++i)
+ typeArray[i] = description.getMimeType (i).getBytes ("UTF-8");
+ }
+ catch (UnsupportedEncodingException exception)
+ {
+ return null;
+ }
+
+ return typeArray;
+ }
+
+ /* Return the clipboard data for the given target, or NULL if it
+ does not exist.
+
+ Value is normally an array of three longs: the file descriptor,
+ the start offset of the data, and its length; length may be
+ AssetFileDescriptor.UNKNOWN_LENGTH, meaning that the data extends
+ from that offset to the end of the file.
+
+ Do not use this function to open text targets; use `getClipboard'
+ for that instead, as it will handle selection data consisting
+ solely of a URI. */
+
+ @Override
+ public long[]
+ getClipboardData (byte[] target)
+ {
+ ClipData data;
+ String mimeType;
+ int fd;
+ AssetFileDescriptor assetFd;
+ Uri uri;
+ long[] value;
+
+ /* Decode the target given by Emacs. */
+ try
+ {
+ mimeType = new String (target, "UTF-8");
+ }
+ catch (UnsupportedEncodingException exception)
+ {
+ return null;
+ }
+
+ /* Now obtain the clipboard data and the data corresponding to
+ that MIME type. */
+
+ data = manager.getPrimaryClip ();
+
+ if (data == null || data.getItemCount () < 1)
+ return null;
+
+ fd = -1;
+
+ try
+ {
+ uri = data.getItemAt (0).getUri ();
+
+ if (uri == null)
+ return null;
+
+ /* Now open the file descriptor. */
+ assetFd = resolver.openTypedAssetFileDescriptor (uri, mimeType,
+ null);
+
+ /* Duplicate the file descriptor. */
+ fd = assetFd.getParcelFileDescriptor ().getFd ();
+ fd = EmacsNative.dup (fd);
+
+ /* Return the relevant information. */
+ value = new long[] { fd, assetFd.getStartOffset (),
+ assetFd.getLength (), };
+
+ /* Close the original offset. */
+ assetFd.close ();
+ }
+ catch (SecurityException e)
+ {
+ /* Guarantee a file descriptor duplicated or detached is
+ ultimately closed if an error arises. */
+
+ if (fd != -1)
+ EmacsNative.close (fd);
+
+ return null;
+ }
+ catch (FileNotFoundException e)
+ {
+ /* Guarantee a file descriptor duplicated or detached is
+ ultimately closed if an error arises. */
+
+ if (fd != -1)
+ EmacsNative.close (fd);
+
+ return null;
+ }
+ catch (IOException e)
+ {
+ /* Guarantee a file descriptor duplicated or detached is
+ ultimately closed if an error arises. */
+
+ if (fd != -1)
+ EmacsNative.close (fd);
+
+ return null;
+ }
+
+ /* Don't return value if the file descriptor couldn't be
+ created. */
+
+ return fd != -1 ? value : null;
+ }
+};
diff --git a/java/org/gnu/emacs/EmacsSdk23FontDriver.java b/java/org/gnu/emacs/EmacsSdk23FontDriver.java
new file mode 100644
index 00000000000..91153feaa11
--- /dev/null
+++ b/java/org/gnu/emacs/EmacsSdk23FontDriver.java
@@ -0,0 +1,120 @@
+/* Font backend for Android terminals. -*- c-file-style: "GNU" -*-
+
+Copyright (C) 2023-2024 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 <https://www.gnu.org/licenses/>. */
+
+package org.gnu.emacs;
+
+import android.graphics.Paint;
+import android.graphics.Rect;
+
+public final class EmacsSdk23FontDriver extends EmacsSdk7FontDriver
+{
+ private void
+ textExtents1 (Sdk7FontObject font, int code, FontMetrics metrics,
+ Paint paint, Rect bounds)
+ {
+ char[] text;
+
+ text = new char[2];
+ text[0] = (char) code;
+ text[1] = 'c';
+
+ paint.getTextBounds (text, 0, 1, bounds);
+
+ metrics.lbearing = (short) bounds.left;
+ metrics.rbearing = (short) bounds.right;
+ metrics.ascent = (short) -bounds.top;
+ metrics.descent = (short) bounds.bottom;
+ metrics.width
+ = (short) paint.getRunAdvance (text, 0, 1, 0, 1, false, 1);
+ }
+
+ @Override
+ public void
+ textExtents (FontObject font, int code[], FontMetrics fontMetrics)
+ {
+ int i;
+ Paint paintCache;
+ Rect boundsCache;
+ Sdk7FontObject fontObject;
+ char[] text;
+ float width;
+
+ fontObject = (Sdk7FontObject) font;
+ paintCache = fontObject.typeface.typefacePaint;
+ paintCache.setTextSize (fontObject.pixelSize);
+ boundsCache = new Rect ();
+
+ if (code.length == 0)
+ {
+ fontMetrics.lbearing = 0;
+ fontMetrics.rbearing = 0;
+ fontMetrics.ascent = 0;
+ fontMetrics.descent = 0;
+ fontMetrics.width = 0;
+ }
+ else if (code.length == 1)
+ textExtents1 ((Sdk7FontObject) font, code[0], fontMetrics,
+ paintCache, boundsCache);
+ else
+ {
+ text = new char[code.length + 1];
+
+ for (i = 0; i < code.length; ++i)
+ text[i] = (char) code[i];
+
+ text[code.length] = 'c';
+
+ paintCache.getTextBounds (text, 0, code.length,
+ boundsCache);
+ width = paintCache.getRunAdvance (text, 0, code.length, 0,
+ code.length,
+ false, code.length);
+
+ fontMetrics.lbearing = (short) boundsCache.left;
+ fontMetrics.rbearing = (short) boundsCache.right;
+ fontMetrics.ascent = (short) -boundsCache.top;
+ fontMetrics.descent = (short) boundsCache.bottom;
+ fontMetrics.width = (short) width;
+ }
+ }
+
+ @Override
+ public int
+ hasChar (FontSpec font, int charCode)
+ {
+ Sdk7FontObject fontObject;
+ Paint paint;
+
+ if (font instanceof Sdk7FontObject)
+ {
+ fontObject = (Sdk7FontObject) font;
+ paint = fontObject.typeface.typefacePaint;
+ }
+ else
+ paint = ((Sdk7FontEntity) font).typeface.typefacePaint;
+
+ /* If the character falls within the confines of the BMP, return
+ 1. */
+ if (charCode < 65536)
+ return paint.hasGlyph (String.valueOf ((char) charCode)) ? 1 : 0;
+
+ /* Otherwise return 0. */
+ return 0;
+ }
+};
diff --git a/java/org/gnu/emacs/EmacsSdk7FontDriver.java b/java/org/gnu/emacs/EmacsSdk7FontDriver.java
new file mode 100644
index 00000000000..49d9514c104
--- /dev/null
+++ b/java/org/gnu/emacs/EmacsSdk7FontDriver.java
@@ -0,0 +1,497 @@
+/* Font backend for Android terminals. -*- c-file-style: "GNU" -*-
+
+Copyright (C) 2023-2024 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 <https://www.gnu.org/licenses/>. */
+
+package org.gnu.emacs;
+
+import java.io.File;
+
+import java.util.LinkedList;
+import java.util.List;
+
+import android.graphics.Paint;
+import android.graphics.Rect;
+import android.graphics.Typeface;
+import android.graphics.Canvas;
+
+import android.util.Log;
+
+
+
+/* EmacsSdk7FontDriver implements a fallback font driver under
+ Android. This font driver is enabled when the SFNT font driver (in
+ sfntfont-android.c) proves incapable of locating any fonts, which
+ has hitherto not been observed in practice.
+
+ This font driver does not supply each font installed on the system,
+ in lieu of which it provides a list of fonts for each conceivable
+ style and sub-type of the system's own Typefaces, which arises from
+ Android's absence of suitable APIs for loading individual font
+ files. */
+
+public class EmacsSdk7FontDriver extends EmacsFontDriver
+{
+ private static final String TOFU_STRING = "\uDB3F\uDFFD";
+ private static final String EM_STRING = "m";
+ private static final String TAG = "EmacsSdk7FontDriver";
+
+ protected static final class Sdk7Typeface
+ {
+ /* The typeface and paint. */
+ public Typeface typeface;
+ public Paint typefacePaint;
+ public String familyName;
+ public int slant, width, weight, spacing;
+
+ public
+ Sdk7Typeface (String familyName, Typeface typeface)
+ {
+ String style, testString;
+ int index, measured, i;
+ float[] widths;
+
+ /* Initialize the font style fields and create a paint object
+ linked with that typeface. */
+
+ slant = NORMAL;
+ weight = REGULAR;
+ width = UNSPECIFIED;
+ spacing = PROPORTIONAL;
+
+ this.typeface = typeface;
+ this.familyName = familyName;
+
+ typefacePaint = new Paint ();
+ typefacePaint.setAntiAlias (true);
+ typefacePaint.setTypeface (typeface);
+ }
+
+ @Override
+ public String
+ toString ()
+ {
+ return ("Sdk7Typeface ("
+ + String.valueOf (familyName) + ", "
+ + String.valueOf (slant) + ", "
+ + String.valueOf (width) + ", "
+ + String.valueOf (weight) + ", "
+ + String.valueOf (spacing) + ")");
+ }
+ };
+
+ protected static final class Sdk7FontEntity extends FontEntity
+ {
+ /* The typeface. */
+ public Sdk7Typeface typeface;
+
+ @SuppressWarnings ("deprecation")
+ public
+ Sdk7FontEntity (Sdk7Typeface typeface)
+ {
+ foundry = "Google";
+ family = typeface.familyName;
+ adstyle = null;
+ weight = typeface.weight;
+ slant = typeface.slant;
+ spacing = typeface.spacing;
+ width = typeface.width;
+ dpi = Math.round (EmacsService.SERVICE.metrics.scaledDensity * 160f);
+
+ this.typeface = typeface;
+ }
+ };
+
+ protected final class Sdk7FontObject extends FontObject
+ {
+ /* The typeface. */
+ public Sdk7Typeface typeface;
+
+ @SuppressWarnings ("deprecation")
+ public
+ Sdk7FontObject (Sdk7Typeface typeface, int pixelSize)
+ {
+ float totalWidth;
+ String testWidth, testString;
+
+ this.typeface = typeface;
+ this.pixelSize = pixelSize;
+
+ family = typeface.familyName;
+ adstyle = null;
+ weight = typeface.weight;
+ slant = typeface.slant;
+ spacing = typeface.spacing;
+ width = typeface.width;
+ dpi = Math.round (EmacsService.SERVICE.metrics.scaledDensity * 160f);
+
+ /* Compute the ascent and descent. */
+ typeface.typefacePaint.setTextSize (pixelSize);
+ ascent
+ = Math.round (-typeface.typefacePaint.ascent ());
+ descent
+ = Math.round (typeface.typefacePaint.descent ());
+
+ /* Compute the average width. */
+ testString = "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ";
+ totalWidth = typeface.typefacePaint.measureText (testString);
+
+ if (totalWidth > 0)
+ avgwidth = Math.round (totalWidth
+ / testString.length ());
+
+ /* Android doesn't expose the font average width and height
+ information, so this will have to do. */
+ minWidth = maxWidth = avgwidth;
+
+ /* This is different from avgwidth in the font spec! */
+ averageWidth = avgwidth;
+
+ /* Set the space width. */
+ totalWidth = typeface.typefacePaint.measureText (" ");
+ spaceWidth = Math.round (totalWidth);
+
+ /* Set the height and default ascent. */
+ height = ascent + descent;
+ defaultAscent = ascent;
+ }
+ };
+
+ private String[] fontFamilyList;
+ private Sdk7Typeface[] typefaceList;
+ private Sdk7Typeface fallbackTypeface;
+
+ public
+ EmacsSdk7FontDriver ()
+ {
+ int i;
+ Typeface typeface;
+
+ typefaceList = new Sdk7Typeface[5];
+
+ /* Initialize the default monospace and Sans Serif typefaces.
+ Initialize the same typeface with various distinct styles. */
+ fallbackTypeface = new Sdk7Typeface ("Sans Serif",
+ Typeface.DEFAULT);
+ typefaceList[1] = fallbackTypeface;
+
+ fallbackTypeface = new Sdk7Typeface ("Sans Serif",
+ Typeface.create (Typeface.DEFAULT,
+ Typeface.BOLD));
+ fallbackTypeface.weight = BOLD;
+ typefaceList[2] = fallbackTypeface;
+
+ fallbackTypeface = new Sdk7Typeface ("Sans Serif",
+ Typeface.create (Typeface.DEFAULT,
+ Typeface.ITALIC));
+ fallbackTypeface.slant = ITALIC;
+ typefaceList[3] = fallbackTypeface;
+
+ fallbackTypeface
+ = new Sdk7Typeface ("Sans Serif",
+ Typeface.create (Typeface.DEFAULT,
+ Typeface.BOLD_ITALIC));
+ fallbackTypeface.weight = BOLD;
+ fallbackTypeface.slant = ITALIC;
+ typefaceList[4] = fallbackTypeface;
+
+ fallbackTypeface = new Sdk7Typeface ("Monospace",
+ Typeface.MONOSPACE);
+ fallbackTypeface.spacing = MONO;
+ typefaceList[0] = fallbackTypeface;
+
+ fontFamilyList = new String[] { "Monospace", "Sans Serif", };
+ }
+
+ private boolean
+ checkMatch (Sdk7Typeface typeface, FontSpec fontSpec)
+ {
+ if (fontSpec.family != null
+ && !fontSpec.family.equals (typeface.familyName))
+ return false;
+
+ if (fontSpec.slant != null
+ && !fontSpec.weight.equals (typeface.weight))
+ return false;
+
+ if (fontSpec.spacing != null
+ && !fontSpec.spacing.equals (typeface.spacing))
+ return false;
+
+ if (fontSpec.weight != null
+ && !fontSpec.weight.equals (typeface.weight))
+ return false;
+
+ if (fontSpec.width != null
+ && !fontSpec.width.equals (typeface.width))
+ return false;
+
+ return true;
+ }
+
+ @Override
+ public FontEntity[]
+ list (FontSpec fontSpec)
+ {
+ LinkedList<FontEntity> list;
+ int i;
+
+ list = new LinkedList<FontEntity> ();
+
+ for (i = 0; i < typefaceList.length; ++i)
+ {
+ if (checkMatch (typefaceList[i], fontSpec))
+ list.add (new Sdk7FontEntity (typefaceList[i]));
+ }
+
+ return list.toArray (new FontEntity[0]);
+ }
+
+ @Override
+ public FontEntity
+ match (FontSpec fontSpec)
+ {
+ FontEntity[] entities;
+ int i;
+
+ entities = this.list (fontSpec);
+
+ if (entities.length == 0)
+ return new Sdk7FontEntity (fallbackTypeface);
+
+ return entities[0];
+ }
+
+ @Override
+ public String[]
+ listFamilies ()
+ {
+ return fontFamilyList;
+ }
+
+ @Override
+ public FontObject
+ openFont (FontEntity fontEntity, int pixelSize)
+ {
+ return new Sdk7FontObject (((Sdk7FontEntity) fontEntity).typeface,
+ pixelSize);
+ }
+
+ @Override
+ public int
+ hasChar (FontSpec font, int charCode)
+ {
+ float missingGlyphWidth, width;
+ Rect rect1, rect2;
+ Paint paint;
+ Sdk7FontObject fontObject;
+
+ /* Ignore characters outside the BMP. */
+
+ if (charCode > 65535)
+ return 0;
+
+ if (font instanceof Sdk7FontObject)
+ {
+ fontObject = (Sdk7FontObject) font;
+ paint = fontObject.typeface.typefacePaint;
+ }
+ else
+ paint = ((Sdk7FontEntity) font).typeface.typefacePaint;
+
+ paint.setTextSize (10);
+
+ if (Character.isWhitespace ((char) charCode))
+ return 1;
+
+ missingGlyphWidth = paint.measureText (TOFU_STRING);
+ width = paint.measureText ("" + charCode);
+
+ if (width == 0f)
+ return 0;
+
+ if (width != missingGlyphWidth)
+ return 1;
+
+ rect1 = new Rect ();
+ rect2 = new Rect ();
+
+ paint.getTextBounds (TOFU_STRING, 0, TOFU_STRING.length (),
+ rect1);
+ paint.getTextBounds ("" + (char) charCode, 0, 1, rect2);
+ return rect1.equals (rect2) ? 0 : 1;
+ }
+
+ private void
+ textExtents1 (Sdk7FontObject font, int code, FontMetrics metrics,
+ Paint paint, Rect bounds)
+ {
+ char[] text;
+
+ text = new char[1];
+ text[0] = (char) code;
+
+ paint.getTextBounds (text, 0, 1, bounds);
+
+ /* bounds is the bounding box of the glyph corresponding to CODE.
+ Translate these into XCharStruct values.
+
+ The origin is at 0, 0, and lbearing is the distance counting
+ rightwards from the origin to the left most pixel in the glyph
+ raster. rbearing is the distance between the origin and the
+ rightmost pixel in the glyph raster. ascent is the distance
+ counting upwards between the the topmost pixel in the glyph
+ raster. descent is the distance (once again counting
+ downwards) between the origin and the bottommost pixel in the
+ glyph raster.
+
+ width is the distance between the origin and the origin of any
+ character to the right. */
+
+ metrics.lbearing = (short) bounds.left;
+ metrics.rbearing = (short) bounds.right;
+ metrics.ascent = (short) -bounds.top;
+ metrics.descent = (short) bounds.bottom;
+ metrics.width = (short) paint.measureText ("" + text[0]);
+ }
+
+ @Override
+ public void
+ textExtents (FontObject font, int code[], FontMetrics fontMetrics)
+ {
+ int i;
+ Paint paintCache;
+ Rect boundsCache;
+ Sdk7FontObject fontObject;
+ char[] text;
+ float width;
+
+ fontObject = (Sdk7FontObject) font;
+ paintCache = fontObject.typeface.typefacePaint;
+ paintCache.setTextSize (fontObject.pixelSize);
+ boundsCache = new Rect ();
+
+ if (code.length == 0)
+ {
+ fontMetrics.lbearing = 0;
+ fontMetrics.rbearing = 0;
+ fontMetrics.ascent = 0;
+ fontMetrics.descent = 0;
+ fontMetrics.width = 0;
+ }
+ else if (code.length == 1)
+ textExtents1 ((Sdk7FontObject) font, code[0], fontMetrics,
+ paintCache, boundsCache);
+ else
+ {
+ text = new char[code.length];
+
+ for (i = 0; i < code.length; ++i)
+ text[i] = (char) code[i];
+
+ paintCache.getTextBounds (text, 0, code.length,
+ boundsCache);
+ width = paintCache.measureText (text, 0, code.length);
+
+ fontMetrics.lbearing = (short) boundsCache.left;
+ fontMetrics.rbearing = (short) boundsCache.right;
+ fontMetrics.ascent = (short) -boundsCache.top;
+ fontMetrics.descent = (short) boundsCache.bottom;
+ fontMetrics.width = (short) Math.round (width);
+ }
+ }
+
+ @Override
+ public int
+ encodeChar (FontObject fontObject, int charCode)
+ {
+ if (charCode > 65535)
+ return FONT_INVALID_CODE;
+
+ return charCode;
+ }
+
+ @Override
+ public int
+ draw (FontObject fontObject, EmacsGC gc, EmacsDrawable drawable,
+ int[] chars, int x, int y, int backgroundWidth,
+ boolean withBackground)
+ {
+ Rect backgroundRect, bounds;
+ Sdk7FontObject sdk7FontObject;
+ int i;
+ Canvas canvas;
+ Paint paint;
+ char[] array;
+
+ sdk7FontObject = (Sdk7FontObject) fontObject;
+
+ backgroundRect = new Rect ();
+ backgroundRect.top = y - sdk7FontObject.ascent;
+ backgroundRect.left = x;
+ backgroundRect.right = x + backgroundWidth;
+ backgroundRect.bottom = y + sdk7FontObject.descent;
+
+ canvas = drawable.lockCanvas (gc);
+
+ if (canvas == null)
+ return 0;
+
+ paint = gc.gcPaint;
+ paint.setStyle (Paint.Style.FILL);
+
+ if (withBackground)
+ {
+ paint.setColor (gc.background | 0xff000000);
+ canvas.drawRect (backgroundRect, paint);
+ paint.setColor (gc.foreground | 0xff000000);
+ }
+
+ paint.setTextSize (sdk7FontObject.pixelSize);
+ paint.setTypeface (sdk7FontObject.typeface.typeface);
+ paint.setAntiAlias (true);
+
+ /* Android applies kerning to non-monospaced fonts by default,
+ which brings the dimensions of strings drawn via `drawText' out
+ of agreement with measurements previously provided to redisplay
+ by textExtents. To avert such disaster, draw each character
+ individually, advancing the origin point by hand. */
+
+ bounds = new Rect ();
+ array = new char[1];
+
+ for (i = 0; i < chars.length; ++i)
+ {
+ /* Retrieve the text bounds for this character so as to
+ compute the damage rectangle. */
+ array[0] = (char) chars[i];
+ paint.getTextBounds (array, 0, 1, bounds);
+ bounds.offset (x, y);
+ backgroundRect.union (bounds);
+
+ /* Draw this character. */
+ canvas.drawText (array, 0, 1, x, y, paint);
+
+ /* Advance the origin point by that much. */
+ x += paint.measureText ("" + array[0]);
+ }
+
+ drawable.damageRect (backgroundRect);
+ paint.setAntiAlias (false);
+ return 1;
+ }
+};
diff --git a/java/org/gnu/emacs/EmacsSdk8Clipboard.java b/java/org/gnu/emacs/EmacsSdk8Clipboard.java
new file mode 100644
index 00000000000..418f55c12c1
--- /dev/null
+++ b/java/org/gnu/emacs/EmacsSdk8Clipboard.java
@@ -0,0 +1,147 @@
+/* Communication module for Android terminals. -*- c-file-style: "GNU" -*-
+
+Copyright (C) 2023-2024 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 <https://www.gnu.org/licenses/>. */
+
+package org.gnu.emacs;
+
+/* Importing the entire package instead of just the legacy
+ ClipboardManager class avoids the deprecation warning. */
+
+import android.text.*;
+
+import android.content.Context;
+import android.util.Log;
+
+import java.io.UnsupportedEncodingException;
+
+/* This class implements EmacsClipboard for Android 2.2 and other
+ similarly old systems. */
+
+@SuppressWarnings ("deprecation")
+public final class EmacsSdk8Clipboard extends EmacsClipboard
+{
+ private static final String TAG = "EmacsSdk8Clipboard";
+ private ClipboardManager manager;
+
+ public
+ EmacsSdk8Clipboard ()
+ {
+ String what;
+ Context context;
+
+ what = Context.CLIPBOARD_SERVICE;
+ context = EmacsService.SERVICE;
+ manager
+ = (ClipboardManager) context.getSystemService (what);
+ }
+
+ /* Set the clipboard text to CLIPBOARD, a string in UTF-8
+ encoding. */
+
+ @Override
+ public void
+ setClipboard (byte[] bytes)
+ {
+ try
+ {
+ manager.setText (new String (bytes, "UTF-8"));
+ }
+ catch (UnsupportedEncodingException exception)
+ {
+ Log.w (TAG, "setClipboard: " + exception);
+ }
+ }
+
+ /* Return whether or not Emacs owns the clipboard. Value is 1 if
+ Emacs does, 0 if Emacs does not, and -1 if that information is
+ unavailable. */
+
+ @Override
+ public int
+ ownsClipboard ()
+ {
+ return -1;
+ }
+
+ /* Return whether or not clipboard content currently exists. */
+
+ @Override
+ public boolean
+ clipboardExists ()
+ {
+ return manager.hasText ();
+ }
+
+ /* Return the current content of the clipboard, as plain text, or
+ NULL if no content is available. */
+
+ @Override
+ public byte[]
+ getClipboard ()
+ {
+ String string;
+ CharSequence text;
+
+ text = manager.getText ();
+
+ if (text == null)
+ return null;
+
+ string = text.toString ();
+
+ try
+ {
+ return string.getBytes ("UTF-8");
+ }
+ catch (UnsupportedEncodingException exception)
+ {
+ Log.w (TAG, "getClipboard: " + exception);
+ }
+
+ return null;
+ }
+
+ /* Return an array of targets currently provided by the
+ clipboard, or NULL if there are none. */
+
+ @Override
+ public byte[][]
+ getClipboardTargets ()
+ {
+ return null;
+ }
+
+ /* Return the clipboard data for the given target, or NULL if it
+ does not exist.
+
+ Value is normally an array of three longs: the file descriptor,
+ the start offset of the data, and its length; length may be
+ AssetFileDescriptor.UNKOWN_LENGTH, meaning that the data extends
+ from that offset to the end of the file.
+
+ Do not use this function to open text targets; use `getClipboard'
+ for that instead, as it will handle selection data consisting
+ solely of a URI. */
+
+ @Override
+ public long[]
+ getClipboardData (byte[] target)
+ {
+ return null;
+ }
+};
diff --git a/java/org/gnu/emacs/EmacsService.java b/java/org/gnu/emacs/EmacsService.java
new file mode 100644
index 00000000000..446cd26a3dd
--- /dev/null
+++ b/java/org/gnu/emacs/EmacsService.java
@@ -0,0 +1,2120 @@
+/* Communication module for Android terminals. -*- c-file-style: "GNU" -*-
+
+Copyright (C) 2023-2024 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 <https://www.gnu.org/licenses/>. */
+
+package org.gnu.emacs;
+
+import java.io.ByteArrayOutputStream;
+import java.io.FileNotFoundException;
+import java.io.IOException;
+import java.io.UnsupportedEncodingException;
+
+import java.util.ArrayList;
+import java.util.HashSet;
+import java.util.List;
+
+import java.util.concurrent.Callable;
+import java.util.concurrent.ExecutionException;
+import java.util.concurrent.FutureTask;
+
+import java.util.concurrent.atomic.AtomicInteger;
+
+import android.database.Cursor;
+
+import android.graphics.Matrix;
+import android.graphics.Point;
+
+import android.webkit.MimeTypeMap;
+
+import android.view.InputDevice;
+import android.view.KeyEvent;
+import android.view.inputmethod.CursorAnchorInfo;
+import android.view.inputmethod.ExtractedText;
+
+import android.app.AlarmManager;
+import android.app.Notification;
+import android.app.NotificationChannel;
+import android.app.NotificationManager;
+import android.app.PendingIntent;
+import android.app.Service;
+
+import android.content.ClipboardManager;
+import android.content.Context;
+import android.content.ContentResolver;
+import android.content.Intent;
+import android.content.IntentFilter;
+import android.content.UriPermission;
+
+import android.content.pm.PackageManager;
+
+import android.content.res.AssetManager;
+import android.content.res.Configuration;
+
+import android.hardware.input.InputManager;
+
+import android.net.Uri;
+
+import android.os.BatteryManager;
+import android.os.Build;
+import android.os.Environment;
+import android.os.Looper;
+import android.os.IBinder;
+import android.os.Handler;
+import android.os.ParcelFileDescriptor;
+import android.os.Vibrator;
+import android.os.VibratorManager;
+import android.os.VibrationEffect;
+
+import android.provider.DocumentsContract;
+import android.provider.DocumentsContract.Document;
+import android.provider.OpenableColumns;
+import android.provider.Settings;
+
+import android.util.Log;
+import android.util.DisplayMetrics;
+
+import android.widget.Toast;
+
+/* EmacsService is the service that starts the thread running Emacs
+ and handles requests by that Emacs instance. */
+
+public final class EmacsService extends Service
+{
+ public static final String TAG = "EmacsService";
+
+ /* The started Emacs service object. */
+ public static EmacsService SERVICE;
+
+ /* If non-NULL, an extra argument to pass to
+ `android_emacs_init'. */
+ public static String extraStartupArgument;
+
+ /* The thread running Emacs C code. */
+ private EmacsThread thread;
+
+ /* Handler used to run tasks on the main thread. */
+ private Handler handler;
+
+ /* Content resolver used to access URIs. */
+ private ContentResolver resolver;
+
+ /* Keep this in synch with androidgui.h. */
+ public static final int IC_MODE_NULL = 0;
+ public static final int IC_MODE_ACTION = 1;
+ public static final int IC_MODE_TEXT = 2;
+ public static final int IC_MODE_PASSWORD = 3;
+
+ /* Display metrics used by font backends. */
+ public DisplayMetrics metrics;
+
+ /* Flag that says whether or not to print verbose debugging
+ information when responding to an input method. */
+ public static final boolean DEBUG_IC = false;
+
+ /* Flag that says whether or not to stringently check that only the
+ Emacs thread is performing drawing calls. */
+ private static final boolean DEBUG_THREADS = false;
+
+ /* Atomic integer used for synchronization between
+ icBeginSynchronous/icEndSynchronous and viewGetSelection.
+
+ Value is 0 if no query is in progress, 1 if viewGetSelection is
+ being called, and 2 if icBeginSynchronous was called. */
+ public static final AtomicInteger servicingQuery;
+
+ /* Thread used to query document providers, or null if it hasn't
+ been created yet. */
+ private EmacsSafThread storageThread;
+
+ /* The Thread object representing the Android user interface
+ thread. */
+ private Thread mainThread;
+
+ static
+ {
+ servicingQuery = new AtomicInteger ();
+ };
+
+ /* Return the directory leading to the directory in which native
+ library files are stored on behalf of CONTEXT. */
+
+ public static String
+ getLibraryDirectory (Context context)
+ {
+ int apiLevel;
+
+ apiLevel = Build.VERSION.SDK_INT;
+
+ if (apiLevel >= Build.VERSION_CODES.GINGERBREAD)
+ return context.getApplicationInfo ().nativeLibraryDir;
+
+ return context.getApplicationInfo ().dataDir + "/lib";
+ }
+
+ @Override
+ public int
+ onStartCommand (Intent intent, int flags, int startId)
+ {
+ Notification notification;
+ NotificationManager manager;
+ NotificationChannel channel;
+ String infoBlurb;
+ Object tem;
+
+ if (Build.VERSION.SDK_INT >= Build.VERSION_CODES.O)
+ {
+ tem = getSystemService (Context.NOTIFICATION_SERVICE);
+ manager = (NotificationManager) tem;
+ infoBlurb = ("This notification is displayed to keep Emacs"
+ + " running while it is in the background. You"
+ + " may disable it if you want;"
+ + " see (emacs)Android Environment.");
+ channel
+ = new NotificationChannel ("emacs", "Emacs Background Service",
+ NotificationManager.IMPORTANCE_DEFAULT);
+ manager.createNotificationChannel (channel);
+ notification = (new Notification.Builder (this, "emacs")
+ .setContentTitle ("Emacs")
+ .setContentText (infoBlurb)
+ .setSmallIcon (android.R.drawable.sym_def_app_icon)
+ .build ());
+ manager.notify (1, notification);
+ startForeground (1, notification);
+ }
+
+ return START_NOT_STICKY;
+ }
+
+ @Override
+ public IBinder
+ onBind (Intent intent)
+ {
+ return null;
+ }
+
+ /* Return the display density, adjusted in accord with the user's
+ text scaling preferences. */
+
+ @SuppressWarnings ("deprecation")
+ private static float
+ getScaledDensity (DisplayMetrics metrics)
+ {
+ /* The scaled density has been made obsolete by the introduction
+ of non-linear text scaling in Android 34, where there is no
+ longer a fixed relation between point and pixel sizes, but
+ remains useful, considering that Emacs does not support
+ non-linear text scaling. */
+ return metrics.scaledDensity;
+ }
+
+ @Override
+ public void
+ onCreate ()
+ {
+ final AssetManager manager;
+ Context app_context;
+ final String filesDir, libDir, cacheDir, classPath;
+ final double pixelDensityX;
+ final double pixelDensityY;
+ final double scaledDensity;
+ double tempScaledDensity;
+
+ SERVICE = this;
+ handler = new Handler (Looper.getMainLooper ());
+ manager = getAssets ();
+ app_context = getApplicationContext ();
+ metrics = getResources ().getDisplayMetrics ();
+ pixelDensityX = metrics.xdpi;
+ pixelDensityY = metrics.ydpi;
+ tempScaledDensity = ((getScaledDensity (metrics)
+ / metrics.density)
+ * pixelDensityX);
+ resolver = getContentResolver ();
+ mainThread = Thread.currentThread ();
+
+ /* If the density used to compute the text size is lesser than
+ 160, there's likely a bug with display density computation.
+ Reset it to 160 in that case.
+
+ Note that Android uses 160 ``dpi'' as the density where 1 point
+ corresponds to 1 pixel, not 72 or 96 as used elsewhere. This
+ difference is codified in PT_PER_INCH defined in font.h. */
+
+ if (tempScaledDensity < 160)
+ tempScaledDensity = 160;
+
+ /* scaledDensity is const as required to refer to it from within
+ the nested function below. */
+ scaledDensity = tempScaledDensity;
+
+ try
+ {
+ /* Configure Emacs with the asset manager and other necessary
+ parameters. */
+ filesDir = app_context.getFilesDir ().getCanonicalPath ();
+ libDir = getLibraryDirectory (this);
+ cacheDir = app_context.getCacheDir ().getCanonicalPath ();
+
+ /* Now provide this application's apk file, so a recursive
+ invocation of app_process (through android-emacs) can
+ find EmacsNoninteractive. */
+ classPath = EmacsApplication.apkFileName;
+
+ Log.d (TAG, "Initializing Emacs, where filesDir = " + filesDir
+ + ", libDir = " + libDir + ", and classPath = " + classPath
+ + "; fileToOpen = " + EmacsOpenActivity.fileToOpen
+ + "; display density: " + pixelDensityX + " by "
+ + pixelDensityY + " scaled to " + scaledDensity);
+
+ /* Start the thread that runs Emacs. */
+ thread = new EmacsThread (this, new Runnable () {
+ @Override
+ public void
+ run ()
+ {
+ EmacsNative.setEmacsParams (manager, filesDir, libDir,
+ cacheDir, (float) pixelDensityX,
+ (float) pixelDensityY,
+ (float) scaledDensity,
+ classPath, EmacsService.this,
+ Build.VERSION.SDK_INT);
+ }
+ }, extraStartupArgument,
+ /* If any file needs to be opened, open it now. */
+ EmacsOpenActivity.fileToOpen);
+ thread.start ();
+ }
+ catch (IOException exception)
+ {
+ EmacsNative.emacsAbort ();
+ return;
+ }
+ }
+
+ /* The native functions the subsequent two functions call do nothing
+ in the infrequent case the Emacs thread is awaiting a response
+ for the main thread. Caveat emptor! */
+
+ @Override
+ public void
+ onDestroy ()
+ {
+ /* This function is called immediately before the system kills
+ Emacs. In this respect, it is rather akin to a SIGDANGER
+ signal, so force an auto-save accordingly. */
+
+ EmacsNative.shutDownEmacs ();
+ super.onDestroy ();
+ }
+
+ @Override
+ public void
+ onLowMemory ()
+ {
+ EmacsNative.onLowMemory ();
+ super.onLowMemory ();
+ }
+
+
+
+ /* Functions from here on must only be called from the Emacs
+ thread. */
+
+ public void
+ runOnUiThread (Runnable runnable)
+ {
+ handler.post (runnable);
+ }
+
+ public EmacsView
+ getEmacsView (final EmacsWindow window, final int visibility,
+ final boolean isFocusedByDefault)
+ {
+ Runnable runnable;
+ FutureTask<EmacsView> task;
+
+ task = new FutureTask<EmacsView> (new Callable<EmacsView> () {
+ @Override
+ public EmacsView
+ call ()
+ {
+ EmacsView view;
+
+ view = new EmacsView (window);
+ view.setVisibility (visibility);
+
+ /* The following function is only present on Android 26
+ or later. */
+ if (Build.VERSION.SDK_INT >= Build.VERSION_CODES.O)
+ view.setFocusedByDefault (isFocusedByDefault);
+
+ return view;
+ }
+ });
+
+ return EmacsService.<EmacsView>syncRunnable (task);
+ }
+
+ public void
+ getLocationOnScreen (final EmacsView view, final int[] coordinates)
+ {
+ FutureTask<Void> task;
+
+ task = new FutureTask<Void> (new Callable<Void> () {
+ public Void
+ call ()
+ {
+ view.getLocationOnScreen (coordinates);
+ return null;
+ }
+ });
+
+ EmacsService.<Void>syncRunnable (task);
+ }
+
+
+
+ public static void
+ checkEmacsThread ()
+ {
+ if (DEBUG_THREADS)
+ {
+ /* When SERVICE is NULL, Emacs is being executed non-interactively. */
+ if (SERVICE == null
+ /* It was previously assumed that only instances of
+ `EmacsThread' were valid for graphics calls, but this is
+ no longer true now that Lisp threads can be attached to
+ the JVM. */
+ || (Thread.currentThread () != SERVICE.mainThread))
+ return;
+
+ throw new RuntimeException ("Emacs thread function"
+ + " called from other thread!");
+ }
+ }
+
+ /* These drawing functions must only be called from the Emacs
+ thread. */
+
+ public void
+ fillRectangle (EmacsDrawable drawable, EmacsGC gc,
+ int x, int y, int width, int height)
+ {
+ checkEmacsThread ();
+ EmacsFillRectangle.perform (drawable, gc, x, y,
+ width, height);
+ }
+
+ public void
+ fillPolygon (EmacsDrawable drawable, EmacsGC gc,
+ Point points[])
+ {
+ checkEmacsThread ();
+ EmacsFillPolygon.perform (drawable, gc, points);
+ }
+
+ public void
+ drawRectangle (EmacsDrawable drawable, EmacsGC gc,
+ int x, int y, int width, int height)
+ {
+ checkEmacsThread ();
+ EmacsDrawRectangle.perform (drawable, gc, x, y,
+ width, height);
+ }
+
+ public void
+ drawLine (EmacsDrawable drawable, EmacsGC gc,
+ int x, int y, int x2, int y2)
+ {
+ checkEmacsThread ();
+ EmacsDrawLine.perform (drawable, gc, x, y,
+ x2, y2);
+ }
+
+ public void
+ drawPoint (EmacsDrawable drawable, EmacsGC gc,
+ int x, int y)
+ {
+ checkEmacsThread ();
+ EmacsDrawPoint.perform (drawable, gc, x, y);
+ }
+
+ @SuppressWarnings ("deprecation")
+ public void
+ ringBell (int duration)
+ {
+ Vibrator vibrator;
+ VibrationEffect effect;
+ VibratorManager vibratorManager;
+ Object tem;
+ int amplitude;
+
+ if (Build.VERSION.SDK_INT >= Build.VERSION_CODES.S)
+ {
+ tem = getSystemService (Context.VIBRATOR_MANAGER_SERVICE);
+ vibratorManager = (VibratorManager) tem;
+ vibrator = vibratorManager.getDefaultVibrator ();
+ }
+ else
+ vibrator
+ = (Vibrator) getSystemService (Context.VIBRATOR_SERVICE);
+
+ if (Build.VERSION.SDK_INT >= Build.VERSION_CODES.O)
+ {
+ amplitude = VibrationEffect.DEFAULT_AMPLITUDE;
+ effect
+ = VibrationEffect.createOneShot (duration, amplitude);
+ vibrator.vibrate (effect);
+ }
+ else
+ vibrator.vibrate (duration);
+ }
+
+ public short[]
+ queryTree (EmacsWindow window)
+ {
+ short[] array;
+ List<EmacsWindow> windowList;
+ int i;
+
+ if (window == null)
+ /* Just return all the windows without a parent. */
+ windowList = EmacsWindowAttachmentManager.MANAGER.copyWindows ();
+ else
+ windowList = window.children;
+
+ synchronized (windowList)
+ {
+ array = new short[windowList.size () + 1];
+ i = 1;
+
+ array[0] = (window == null
+ ? 0 : (window.parent != null
+ ? window.parent.handle : 0));
+
+ for (EmacsWindow treeWindow : windowList)
+ array[i++] = treeWindow.handle;
+ }
+
+ return array;
+ }
+
+ public int
+ getScreenWidth (boolean mmWise)
+ {
+ DisplayMetrics metrics;
+
+ metrics = getResources ().getDisplayMetrics ();
+
+ if (!mmWise)
+ return metrics.widthPixels;
+ else
+ return (int) ((metrics.widthPixels / metrics.xdpi) * 2540.0);
+ }
+
+ public int
+ getScreenHeight (boolean mmWise)
+ {
+ DisplayMetrics metrics;
+
+ metrics = getResources ().getDisplayMetrics ();
+
+ if (!mmWise)
+ return metrics.heightPixels;
+ else
+ return (int) ((metrics.heightPixels / metrics.ydpi) * 2540.0);
+ }
+
+ public boolean
+ detectMouse ()
+ {
+ InputManager manager;
+ InputDevice device;
+ int[] ids;
+ int i;
+
+ if (Build.VERSION.SDK_INT
+ /* Android 4.0 and earlier don't support mouse input events at
+ all. */
+ < Build.VERSION_CODES.JELLY_BEAN)
+ return false;
+
+ manager = (InputManager) getSystemService (Context.INPUT_SERVICE);
+ ids = manager.getInputDeviceIds ();
+
+ for (i = 0; i < ids.length; ++i)
+ {
+ device = manager.getInputDevice (ids[i]);
+
+ if (device == null)
+ continue;
+
+ if (Build.VERSION.SDK_INT >= Build.VERSION_CODES.LOLLIPOP)
+ {
+ if (device.supportsSource (InputDevice.SOURCE_MOUSE))
+ return true;
+ }
+ else
+ {
+ /* `supportsSource' is only present on API level 21 and
+ later, but earlier versions provide a bit mask
+ containing each supported source. */
+
+ if ((device.getSources () & InputDevice.SOURCE_MOUSE) != 0)
+ return true;
+ }
+ }
+
+ return false;
+ }
+
+ public boolean
+ detectKeyboard ()
+ {
+ Configuration configuration;
+
+ configuration = getResources ().getConfiguration ();
+ return configuration.keyboard != Configuration.KEYBOARD_NOKEYS;
+ }
+
+ public String
+ nameKeysym (int keysym)
+ {
+ if (Build.VERSION.SDK_INT >= Build.VERSION_CODES.HONEYCOMB_MR1)
+ return KeyEvent.keyCodeToString (keysym);
+
+ return String.valueOf (keysym);
+ }
+
+
+
+ /* Start the Emacs service if necessary. On Android 26 and up,
+ start Emacs as a foreground service with a notification, to avoid
+ it being killed by the system.
+
+ On older systems, simply start it as a normal background
+ service. */
+
+ public static void
+ startEmacsService (Context context)
+ {
+ if (EmacsService.SERVICE == null)
+ {
+ if (Build.VERSION.SDK_INT < Build.VERSION_CODES.O)
+ /* Start the Emacs service now. */
+ context.startService (new Intent (context,
+ EmacsService.class));
+ else
+ /* Display the permanent notification and start Emacs as a
+ foreground service. */
+ context.startForegroundService (new Intent (context,
+ EmacsService.class));
+ }
+ }
+
+ /* Ask the system to open the specified URL in an application that
+ understands how to open it.
+
+ If SEND, tell the system to also open applications that can
+ ``send'' the URL (through mail, for example), instead of only
+ those that can view the URL.
+
+ Value is NULL upon success, or a string describing the error
+ upon failure. */
+
+ public String
+ browseUrl (String url, boolean send)
+ {
+ Intent intent;
+ Uri uri;
+
+ try
+ {
+ /* Parse the URI. */
+ if (!send)
+ {
+ uri = Uri.parse (url);
+
+ if (Build.VERSION.SDK_INT >= Build.VERSION_CODES.KITKAT)
+ {
+ /* On Android 4.4 and later, check if URI is actually
+ a file name. If so, rewrite it into a content
+ provider URI, so that it can be accessed by other
+ programs. */
+
+ if (uri.getScheme ().equals ("file")
+ && uri.getPath () != null)
+ uri
+ = DocumentsContract.buildDocumentUri ("org.gnu.emacs",
+ uri.getPath ());
+ }
+
+ intent = new Intent (Intent.ACTION_VIEW, uri);
+
+ /* Set several flags on the Intent prompting the system to
+ permit the recipient to read and edit the URI
+ indefinitely. */
+
+ intent.setFlags (Intent.FLAG_ACTIVITY_NEW_TASK
+ | Intent.FLAG_GRANT_READ_URI_PERMISSION
+ | Intent.FLAG_GRANT_WRITE_URI_PERMISSION);
+
+ if (Build.VERSION.SDK_INT >= Build.VERSION_CODES.KITKAT)
+ intent.addFlags (Intent.FLAG_GRANT_PERSISTABLE_URI_PERMISSION);
+ }
+ else
+ {
+ intent = new Intent (Intent.ACTION_SEND);
+ intent.setType ("text/plain");
+ intent.putExtra (Intent.EXTRA_SUBJECT, "Sharing link");
+ intent.putExtra (Intent.EXTRA_TEXT, url);
+
+ /* Display a list of programs able to send this URL. */
+ intent = Intent.createChooser (intent, "Send");
+
+ /* Apparently flags need to be set after a chooser is
+ created. */
+ intent.addFlags (Intent.FLAG_ACTIVITY_NEW_TASK);
+ }
+
+ startActivity (intent);
+ }
+ catch (Exception e)
+ {
+ return e.toString ();
+ }
+
+ return null;
+ }
+
+ /* Get a SDK 11 ClipboardManager.
+
+ Android 4.0.x requires that this be called from the main
+ thread. */
+
+ public ClipboardManager
+ getClipboardManager ()
+ {
+ FutureTask<Object> task;
+
+ task = new FutureTask<Object> (new Callable<Object> () {
+ public Object
+ call ()
+ {
+ return getSystemService (Context.CLIPBOARD_SERVICE);
+ }
+ });
+
+ return (ClipboardManager) EmacsService.<Object>syncRunnable (task);
+ }
+
+ public void
+ restartEmacs ()
+ {
+ Intent intent;
+ PendingIntent pending;
+ AlarmManager manager;
+
+ intent = new Intent (this, EmacsActivity.class);
+ intent.addFlags (Intent.FLAG_ACTIVITY_NEW_TASK
+ | Intent.FLAG_ACTIVITY_CLEAR_TASK);
+
+ if (Build.VERSION.SDK_INT >= Build.VERSION_CODES.KITKAT)
+ startActivity (intent);
+ else
+ {
+ /* Experimentation has established that Android 4.3 and earlier
+ versions do not attempt to recreate a process when it crashes
+ immediately after requesting that an intent for itself be
+ started. Schedule an intent to start some time after Emacs
+ exits instead. */
+
+ pending = PendingIntent.getActivity (this, 0, intent, 0);
+ manager = (AlarmManager) getSystemService (Context.ALARM_SERVICE);
+ manager.set (AlarmManager.RTC, System.currentTimeMillis () + 100,
+ pending);
+ }
+
+ System.exit (0);
+ }
+
+ /* Wait synchronously for the specified TASK to complete in the UI
+ thread, then return its result. Must be called from the Emacs
+ thread. */
+
+ public static <V> V
+ syncRunnable (FutureTask<V> task)
+ {
+ V object;
+
+ EmacsNative.beginSynchronous ();
+ SERVICE.runOnUiThread (task);
+
+ try
+ {
+ object = task.get ();
+ }
+ catch (ExecutionException exception)
+ {
+ /* Wrap this exception in a RuntimeException and signal it to
+ the caller. */
+ throw new RuntimeException (exception.getCause ());
+ }
+ catch (InterruptedException exception)
+ {
+ EmacsNative.emacsAbort ();
+ object = null;
+ }
+
+ EmacsNative.endSynchronous ();
+
+ return object;
+ }
+
+
+
+ /* IMM functions such as `updateSelection' holds an internal lock
+ that is also taken before `onCreateInputConnection' (in
+ EmacsView.java) is called; when that then asks the UI thread for
+ the current selection, a dead lock results. To remedy this,
+ reply to any synchronous queries now -- and prohibit more queries
+ for the duration of `updateSelection' -- if EmacsView may have
+ been asking for the value of the region. */
+
+ public static void
+ icBeginSynchronous ()
+ {
+ /* Set servicingQuery to 2, so viewGetSelection knows it shouldn't
+ proceed. */
+
+ if (servicingQuery.getAndSet (2) == 1)
+ /* But if viewGetSelection is already in progress, answer it
+ first. */
+ EmacsNative.answerQuerySpin ();
+ }
+
+ public static void
+ icEndSynchronous ()
+ {
+ if (servicingQuery.getAndSet (0) != 2)
+ throw new RuntimeException ("incorrect value of `servicingQuery': "
+ + "likely 1");
+ }
+
+ public static int[]
+ viewGetSelection (short window)
+ {
+ int[] selection;
+
+ /* See if a query is already in progress from the other
+ direction. */
+ if (!servicingQuery.compareAndSet (0, 1))
+ return null;
+
+ /* Now call the regular getSelection. Note that this can't race
+ with answerQuerySpin, as `android_servicing_query' can never be
+ 2 when icBeginSynchronous is called, so a query will always be
+ started. */
+ selection = EmacsNative.getSelection (window);
+
+ /* Finally, clear servicingQuery if its value is still 1. If a
+ query has started from the other side, it ought to be 2. */
+
+ servicingQuery.compareAndSet (1, 0);
+ return selection;
+ }
+
+
+
+ public void
+ updateIC (EmacsWindow window, int newSelectionStart,
+ int newSelectionEnd, int composingRegionStart,
+ int composingRegionEnd)
+ {
+ if (DEBUG_IC)
+ Log.d (TAG, ("updateIC: " + window + " " + newSelectionStart
+ + " " + newSelectionEnd + " "
+ + composingRegionStart + " "
+ + composingRegionEnd));
+
+ icBeginSynchronous ();
+ window.view.imManager.updateSelection (window.view,
+ newSelectionStart,
+ newSelectionEnd,
+ composingRegionStart,
+ composingRegionEnd);
+ icEndSynchronous ();
+ }
+
+ public void
+ resetIC (EmacsWindow window, int icMode)
+ {
+ int oldMode;
+
+ if (DEBUG_IC)
+ Log.d (TAG, "resetIC: " + window + ", " + icMode);
+
+ if (Build.VERSION.SDK_INT >= Build.VERSION_CODES.TIRAMISU
+ && (oldMode = window.view.getICMode ()) == icMode
+ /* Don't do this if there is currently no input
+ connection. */
+ && oldMode != IC_MODE_NULL)
+ {
+ if (DEBUG_IC)
+ Log.d (TAG, "resetIC: calling invalidateInput");
+
+ /* Android 33 and later allow the IM reset to be optimized out
+ and replaced by a call to `invalidateInput', which is much
+ faster, as it does not involve resetting the input
+ connection. */
+
+ icBeginSynchronous ();
+ window.view.imManager.invalidateInput (window.view);
+ icEndSynchronous ();
+
+ return;
+ }
+
+ window.view.setICMode (icMode);
+
+ icBeginSynchronous ();
+ window.view.icGeneration++;
+ window.view.imManager.restartInput (window.view);
+ icEndSynchronous ();
+ }
+
+ public void
+ updateCursorAnchorInfo (EmacsWindow window, float x,
+ float y, float yBaseline,
+ float yBottom)
+ {
+ CursorAnchorInfo info;
+ CursorAnchorInfo.Builder builder;
+ Matrix matrix;
+ int[] offsets;
+
+ if (Build.VERSION.SDK_INT < Build.VERSION_CODES.LOLLIPOP)
+ return;
+
+ offsets = new int[2];
+ builder = new CursorAnchorInfo.Builder ();
+ matrix = new Matrix (window.view.getMatrix ());
+ window.view.getLocationOnScreen (offsets);
+ matrix.postTranslate (offsets[0], offsets[1]);
+ builder.setMatrix (matrix);
+ builder.setInsertionMarkerLocation (x, y, yBaseline, yBottom,
+ 0);
+ info = builder.build ();
+
+ if (DEBUG_IC)
+ Log.d (TAG, ("updateCursorAnchorInfo: " + x + " " + y
+ + " " + yBaseline + "-" + yBottom));
+
+ icBeginSynchronous ();
+ window.view.imManager.updateCursorAnchorInfo (window.view, info);
+ icEndSynchronous ();
+ }
+
+
+
+ /* Content provider functions. */
+
+ /* Open a content URI described by the bytes BYTES, a non-terminated
+ string; make it writable if WRITABLE, and readable if READABLE.
+ Truncate the file if TRUNCATE.
+
+ Value is the resulting file descriptor or -1 upon failure. */
+
+ public int
+ openContentUri (byte[] bytes, boolean writable, boolean readable,
+ boolean truncate)
+ {
+ String name, mode;
+ ParcelFileDescriptor fd;
+ int i;
+
+ /* Figure out the file access mode. */
+
+ mode = "";
+
+ if (readable)
+ mode += "r";
+
+ if (writable)
+ mode += "w";
+
+ if (truncate)
+ mode += "t";
+
+ /* Try to open an associated ParcelFileDescriptor. */
+
+ try
+ {
+ /* The usual file name encoding question rears its ugly head
+ again. */
+
+ name = new String (bytes, "UTF-8");
+ fd = resolver.openFileDescriptor (Uri.parse (name), mode);
+
+ /* Use detachFd on newer versions of Android or plain old
+ dup. */
+
+ if (Build.VERSION.SDK_INT >= Build.VERSION_CODES.HONEYCOMB_MR1)
+ {
+ i = fd.detachFd ();
+ fd.close ();
+
+ return i;
+ }
+ else
+ {
+ i = EmacsNative.dup (fd.getFd ());
+ fd.close ();
+
+ return i;
+ }
+ }
+ catch (Exception exception)
+ {
+ exception.printStackTrace ();
+ return -1;
+ }
+ }
+
+ /* Return whether Emacs is directly permitted to access the
+ content:// URI NAME. This is not a suitable test for files which
+ Emacs can access by virtue of their containing document
+ trees. */
+
+ public boolean
+ checkContentUri (String name, boolean readable, boolean writable)
+ {
+ String mode;
+ ParcelFileDescriptor fd;
+ Uri uri;
+ int rc, flags;
+ ParcelFileDescriptor descriptor;
+
+ uri = Uri.parse (name);
+ flags = 0;
+
+ if (readable)
+ flags |= Intent.FLAG_GRANT_READ_URI_PERMISSION;
+
+ if (writable)
+ flags |= Intent.FLAG_GRANT_WRITE_URI_PERMISSION;
+
+ rc = checkCallingUriPermission (uri, flags);
+
+ if (rc == PackageManager.PERMISSION_GRANTED)
+ return true;
+
+ /* In the event checkCallingUriPermission fails and only read
+ permissions are being verified, attempt to query the URI. This
+ enables ascertaining whether drag and drop URIs can be
+ accessed, something otherwise not provided for. */
+
+ descriptor = null;
+
+ try
+ {
+ descriptor = resolver.openFileDescriptor (uri, "r");
+ return true;
+ }
+ catch (Exception exception)
+ {
+ /* Ignored. */
+ }
+ finally
+ {
+ try
+ {
+ if (descriptor != null)
+ descriptor.close ();
+ }
+ catch (IOException exception)
+ {
+ /* Ignored. */
+ }
+ }
+
+ return false;
+ }
+
+ /* Return a 8 character checksum for the string STRING, after encoding
+ as UTF-8 data. */
+
+ public static String
+ getDisplayNameHash (String string)
+ {
+ byte[] encoded;
+ ByteArrayOutputStream stream;
+ int i, ch;
+
+ /* Much of the VFS code expects file names to be encoded as modified
+ UTF-8 data, but Android's JNI implementation produces (while not
+ accepting!) regular UTF-8 sequences for all characters, even
+ non-Emoji ones. With no documentation to this effect, save for
+ two comments nestled in the source code of the Java virtual
+ machine, it is not sound to assume that this behavior will not be
+ revised in future or modified releases of Android, and as such,
+ encode STRING into modified UTF-8 by hand, to protect against
+ future changes in this respect. */
+
+ stream = new ByteArrayOutputStream ();
+
+ for (i = 0; i < string.length (); ++i)
+ {
+ ch = string.charAt (i);
+
+ if (ch != 0 && ch <= 127)
+ stream.write (ch);
+ else if (ch <= 2047)
+ {
+ stream.write (0xc0 | (0x1f & (ch >> 6)));
+ stream.write (0x80 | (0x3f & ch));
+ }
+ else
+ {
+ stream.write (0xe0 | (0x0f & (ch >> 12)));
+ stream.write (0x80 | (0x3f & (ch >> 6)));
+ stream.write (0x80 | (0x3f & ch));
+ }
+ }
+
+ encoded = stream.toByteArray ();
+
+ /* Closing a ByteArrayOutputStream has no effect.
+ encoded.close (); */
+
+ return EmacsNative.displayNameHash (encoded);
+ }
+
+ /* Build a content file name for URI.
+
+ Return a file name within the /contents/by-authority
+ pseudo-directory that `android_get_content_name' can then
+ transform back into an encoded URI.
+
+ If a display name can be requested from URI (using the resolver
+ RESOLVER), append it to this file name.
+
+ A content name consists of any number of unencoded path segments
+ separated by `/' characters, possibly followed by a question mark
+ and an encoded query string. */
+
+ public static String
+ buildContentName (Uri uri, ContentResolver resolver)
+ {
+ StringBuilder builder;
+ String displayName;
+ Cursor cursor;
+ int column;
+
+ displayName = null;
+ cursor = null;
+
+ try
+ {
+ cursor = resolver.query (uri, null, null, null, null);
+
+ if (cursor != null)
+ {
+ cursor.moveToFirst ();
+ column
+ = cursor.getColumnIndexOrThrow (OpenableColumns.DISPLAY_NAME);
+ displayName
+ = cursor.getString (column);
+
+ /* Verify that the display name is valid, i.e. it
+ contains no characters unsuitable for a file name and
+ is nonempty. */
+ if (displayName.isEmpty () || displayName.contains ("/"))
+ displayName = null;
+ }
+ }
+ catch (Exception e)
+ {
+ /* Ignored. */
+ }
+ finally
+ {
+ if (cursor != null)
+ cursor.close ();
+ }
+
+ /* If a display name is available, at this point it should be the
+ value of displayName. */
+
+ builder = new StringBuilder (displayName != null
+ ? "/content/by-authority-named/"
+ : "/content/by-authority/");
+ builder.append (uri.getAuthority ());
+
+ /* First, append each path segment. */
+
+ for (String segment : uri.getPathSegments ())
+ {
+ /* FIXME: what if segment contains a slash character? */
+ builder.append ('/');
+ builder.append (uri.encode (segment));
+ }
+
+ /* Now, append the query string if necessary. */
+
+ if (uri.getEncodedQuery () != null)
+ builder.append ('?').append (uri.getEncodedQuery ());
+
+ /* Append the display name. */
+
+ if (displayName != null)
+ {
+ builder.append ('/');
+ builder.append (getDisplayNameHash (displayName));
+ builder.append ('/');
+ builder.append (displayName);
+ }
+
+ return builder.toString ();
+ }
+
+
+
+ private long[]
+ queryBattery19 ()
+ {
+ IntentFilter filter;
+ Intent battery;
+ long capacity, chargeCounter, currentAvg, currentNow;
+ long status, remaining, plugged, temp;
+
+ filter = new IntentFilter (Intent.ACTION_BATTERY_CHANGED);
+ battery = registerReceiver (null, filter);
+
+ if (battery == null)
+ return null;
+
+ capacity = battery.getIntExtra (BatteryManager.EXTRA_LEVEL, 0);
+ chargeCounter
+ = (battery.getIntExtra (BatteryManager.EXTRA_SCALE, 0)
+ / battery.getIntExtra (BatteryManager.EXTRA_LEVEL, 100) * 100);
+ currentAvg = 0;
+ currentNow = 0;
+ status = battery.getIntExtra (BatteryManager.EXTRA_STATUS, 0);
+ remaining = -1;
+ plugged = battery.getIntExtra (BatteryManager.EXTRA_PLUGGED, 0);
+ temp = battery.getIntExtra (BatteryManager.EXTRA_TEMPERATURE, 0);
+
+ return new long[] { capacity, chargeCounter, currentAvg,
+ currentNow, remaining, status, plugged,
+ temp, };
+ }
+
+ /* Return the status of the battery. See struct
+ android_battery_status for the order of the elements
+ returned.
+
+ Value may be null upon failure. */
+
+ public long[]
+ queryBattery ()
+ {
+ Object tem;
+ BatteryManager manager;
+ long capacity, chargeCounter, currentAvg, currentNow;
+ long status, remaining, plugged, temp;
+ int prop;
+ IntentFilter filter;
+ Intent battery;
+
+ /* Android 4.4 or earlier require applications to use a different
+ API to query the battery status. */
+
+ if (Build.VERSION.SDK_INT < Build.VERSION_CODES.LOLLIPOP)
+ return queryBattery19 ();
+
+ tem = getSystemService (Context.BATTERY_SERVICE);
+ manager = (BatteryManager) tem;
+ remaining = -1;
+
+ prop = BatteryManager.BATTERY_PROPERTY_CAPACITY;
+ capacity = manager.getLongProperty (prop);
+ prop = BatteryManager.BATTERY_PROPERTY_CHARGE_COUNTER;
+ chargeCounter = manager.getLongProperty (prop);
+ prop = BatteryManager.BATTERY_PROPERTY_CURRENT_AVERAGE;
+ currentAvg = manager.getLongProperty (prop);
+ prop = BatteryManager.BATTERY_PROPERTY_CURRENT_NOW;
+ currentNow = manager.getLongProperty (prop);
+
+ /* Return the battery status. N.B. that Android 7.1 and earlier
+ only return ``charging'' or ``discharging''. */
+
+ if (Build.VERSION.SDK_INT >= Build.VERSION_CODES.O)
+ status
+ = manager.getIntProperty (BatteryManager.BATTERY_PROPERTY_STATUS);
+ else if (Build.VERSION.SDK_INT >= Build.VERSION_CODES.M)
+ status = (manager.isCharging ()
+ ? BatteryManager.BATTERY_STATUS_CHARGING
+ : BatteryManager.BATTERY_STATUS_DISCHARGING);
+ else
+ status = (currentNow > 0
+ ? BatteryManager.BATTERY_STATUS_CHARGING
+ : BatteryManager.BATTERY_STATUS_DISCHARGING);
+
+ if (Build.VERSION.SDK_INT >= Build.VERSION_CODES.P)
+ remaining = manager.computeChargeTimeRemaining ();
+
+ plugged = -1;
+ temp = -1;
+
+ /* Now obtain additional information from the battery manager. */
+
+ filter = new IntentFilter (Intent.ACTION_BATTERY_CHANGED);
+ battery = registerReceiver (null, filter);
+
+ if (battery != null)
+ {
+ plugged = battery.getIntExtra (BatteryManager.EXTRA_PLUGGED, 0);
+ temp = battery.getIntExtra (BatteryManager.EXTRA_TEMPERATURE, 0);
+
+ /* Make status more reliable. */
+ if (Build.VERSION.SDK_INT < Build.VERSION_CODES.M)
+ status = battery.getIntExtra (BatteryManager.EXTRA_STATUS, 0);
+ }
+
+ return new long[] { capacity, chargeCounter, currentAvg,
+ currentNow, remaining, status, plugged,
+ temp, };
+ }
+
+ public void
+ updateExtractedText (EmacsWindow window, ExtractedText text,
+ int token)
+ {
+ if (DEBUG_IC)
+ Log.d (TAG, "updateExtractedText: @" + token + ", " + text);
+
+ icBeginSynchronous ();
+ window.view.imManager.updateExtractedText (window.view,
+ token, text);
+ icEndSynchronous ();
+ }
+
+
+
+ /* Document tree management functions. These functions shouldn't be
+ called before Android 5.0. */
+
+ /* Return an array of each document authority providing at least one
+ tree URI that Emacs holds the rights to persistently access. */
+
+ public String[]
+ getDocumentAuthorities ()
+ {
+ List<UriPermission> permissions;
+ HashSet<String> allProviders;
+ Uri uri;
+
+ permissions = resolver.getPersistedUriPermissions ();
+ allProviders = new HashSet<String> ();
+
+ for (UriPermission permission : permissions)
+ {
+ uri = permission.getUri ();
+
+ if (DocumentsContract.isTreeUri (uri)
+ && permission.isReadPermission ())
+ allProviders.add (uri.getAuthority ());
+ }
+
+ return allProviders.toArray (new String[0]);
+ }
+
+ /* Start a file chooser activity to request access to a directory
+ tree.
+
+ Value is 1 if the activity couldn't be started for some reason,
+ and 0 in any other case. */
+
+ public int
+ requestDirectoryAccess ()
+ {
+ FutureTask<Integer> task;
+
+ /* Return 1 if Android is too old to support this feature. */
+
+ if (Build.VERSION.SDK_INT < Build.VERSION_CODES.LOLLIPOP)
+ return 1;
+
+ task = new FutureTask<Integer> (new Callable<Integer> () {
+ @Override
+ public Integer
+ call ()
+ {
+ EmacsActivity activity;
+ Intent intent;
+ int id, rc;
+
+ /* Try to obtain an activity that will receive the response
+ from the file chooser dialog. */
+
+ if (EmacsActivity.focusedActivities.isEmpty ())
+ {
+ /* If focusedActivities is empty then this dialog may
+ have been displayed immediately after another popup
+ dialog was dismissed. Try the EmacsActivity to be
+ focused. */
+
+ activity = EmacsActivity.lastFocusedActivity;
+
+ if (activity == null)
+ /* Still no luck. Return failure. */
+ return 1;
+ }
+ else
+ activity = EmacsActivity.focusedActivities.get (0);
+
+ /* Now create the intent. */
+ intent = new Intent (Intent.ACTION_OPEN_DOCUMENT_TREE);
+ rc = 1;
+
+ try
+ {
+ id = EmacsActivity.ACCEPT_DOCUMENT_TREE;
+ activity.startActivityForResult (intent, id, null);
+ rc = 0;
+ }
+ catch (Exception e)
+ {
+ e.printStackTrace ();
+ }
+
+ return rc;
+ }
+ });
+
+ return EmacsService.<Integer>syncRunnable (task);
+ }
+
+ /* Return an array of each tree provided by the document PROVIDER
+ that Emacs has permission to access.
+
+ Value is an array if the provider really does exist, NULL
+ otherwise. */
+
+ public String[]
+ getDocumentTrees (byte provider[])
+ {
+ String providerName;
+ List<String> treeList;
+ List<UriPermission> permissions;
+ Uri uri;
+
+ try
+ {
+ providerName = new String (provider, "US-ASCII");
+ }
+ catch (UnsupportedEncodingException exception)
+ {
+ return null;
+ }
+
+ permissions = resolver.getPersistedUriPermissions ();
+ treeList = new ArrayList<String> ();
+
+ for (UriPermission permission : permissions)
+ {
+ uri = permission.getUri ();
+
+ if (DocumentsContract.isTreeUri (uri)
+ && uri.getAuthority ().equals (providerName)
+ && permission.isReadPermission ())
+ /* Make sure the tree document ID is encoded. Refrain from
+ encoding characters such as +:&?#, since they don't
+ conflict with file name separators or other special
+ characters. */
+ treeList.add (Uri.encode (DocumentsContract.getTreeDocumentId (uri),
+ " +:&?#"));
+ }
+
+ return treeList.toArray (new String[0]);
+ }
+
+ /* Find the document ID of the file within TREE_URI designated by
+ NAME.
+
+ NAME is a ``file name'' comprised of the display names of
+ individual files. Each constituent component prior to the last
+ must name a directory file within TREE_URI.
+
+ Upon success, return 0 or 1 (contingent upon whether or not the
+ last component within NAME is a directory) and place the document
+ ID of the named file in ID_RETURN[0].
+
+ If the designated file can't be located, but each component of
+ NAME up to the last component can and is a directory, return -2
+ and the ID of the last component located in ID_RETURN[0].
+
+ If the designated file can't be located, return -1, or signal one
+ of OperationCanceledException, SecurityException,
+ FileNotFoundException, or UnsupportedOperationException. */
+
+ public int
+ documentIdFromName (String tree_uri, String name, String[] id_return)
+ {
+ /* Start the thread used to run SAF requests if it isn't already
+ running. */
+
+ if (storageThread == null)
+ {
+ storageThread = new EmacsSafThread (resolver);
+ storageThread.start ();
+ }
+
+ return storageThread.documentIdFromName (tree_uri, name,
+ id_return);
+ }
+
+ /* Return an encoded document URI representing a tree with the
+ specified IDENTIFIER supplied by the authority AUTHORITY.
+
+ Return null instead if Emacs does not have permanent access
+ to the specified document tree recorded on disk. */
+
+ public String
+ getTreeUri (String tree, String authority)
+ {
+ Uri uri, grantedUri;
+ List<UriPermission> permissions;
+
+ /* First, build the URI. */
+ tree = Uri.decode (tree);
+ uri = DocumentsContract.buildTreeDocumentUri (authority, tree);
+
+ /* Now, search for it within the list of persisted URI
+ permissions. */
+ permissions = resolver.getPersistedUriPermissions ();
+
+ for (UriPermission permission : permissions)
+ {
+ /* If the permission doesn't entitle Emacs to read access,
+ skip it. */
+
+ if (!permission.isReadPermission ())
+ continue;
+
+ grantedUri = permission.getUri ();
+
+ if (grantedUri.equals (uri))
+ return uri.toString ();
+ }
+
+ /* Emacs doesn't have permission to access this tree URI. */
+ return null;
+ }
+
+ /* Return file status for the document designated by the given
+ DOCUMENTID and tree URI. If DOCUMENTID is NULL, use the document
+ ID in URI itself.
+
+ Value is null upon failure, or an array of longs [MODE, SIZE,
+ MTIM] upon success, where MODE contains the file type and access
+ modes of the file as in `struct stat', SIZE is the size of the
+ file in BYTES or -1 if not known, and MTIM is the time of the
+ last modification to this file in milliseconds since 00:00,
+ January 1st, 1970.
+
+ If NOCACHE, refrain from placing the file status within the
+ status cache.
+
+ OperationCanceledException and other typical exceptions may be
+ signaled upon receiving async input or other errors. */
+
+ public long[]
+ statDocument (String uri, String documentId, boolean noCache)
+ {
+ /* Start the thread used to run SAF requests if it isn't already
+ running. */
+
+ if (storageThread == null)
+ {
+ storageThread = new EmacsSafThread (resolver);
+ storageThread.start ();
+ }
+
+ return storageThread.statDocument (uri, documentId, noCache);
+ }
+
+ /* Find out whether Emacs has access to the document designated by
+ the specified DOCUMENTID within the tree URI. If DOCUMENTID is
+ NULL, use the document ID in URI itself.
+
+ If WRITABLE, also check that the file is writable, which is true
+ if it is either a directory or its flags contains
+ FLAG_SUPPORTS_WRITE.
+
+ Value is 0 if the file is accessible, and one of the following if
+ not:
+
+ -1, if the file does not exist.
+ -2, if WRITABLE and the file is not writable.
+ -3, upon any other error.
+
+ In addition, arbitrary runtime exceptions (such as
+ SecurityException or UnsupportedOperationException) may be
+ thrown. */
+
+ public int
+ accessDocument (String uri, String documentId, boolean writable)
+ {
+ /* Start the thread used to run SAF requests if it isn't already
+ running. */
+
+ if (storageThread == null)
+ {
+ storageThread = new EmacsSafThread (resolver);
+ storageThread.start ();
+ }
+
+ return storageThread.accessDocument (uri, documentId, writable);
+ }
+
+ /* Open a cursor representing each entry within the directory
+ designated by the specified DOCUMENTID within the tree URI.
+
+ If DOCUMENTID is NULL, use the document ID within URI itself.
+ Value is NULL upon failure.
+
+ In addition, arbitrary runtime exceptions (such as
+ SecurityException or UnsupportedOperationException) may be
+ thrown. */
+
+ public Cursor
+ openDocumentDirectory (String uri, String documentId)
+ {
+ /* Start the thread used to run SAF requests if it isn't already
+ running. */
+
+ if (storageThread == null)
+ {
+ storageThread = new EmacsSafThread (resolver);
+ storageThread.start ();
+ }
+
+ return storageThread.openDocumentDirectory (uri, documentId);
+ }
+
+ /* Read a single directory entry from the specified CURSOR. Return
+ NULL if at the end of the directory stream, and a directory entry
+ with `d_name' set to NULL if an error occurs. */
+
+ public EmacsDirectoryEntry
+ readDirectoryEntry (Cursor cursor)
+ {
+ EmacsDirectoryEntry entry;
+ int index;
+ String name, type;
+
+ entry = new EmacsDirectoryEntry ();
+
+ while (true)
+ {
+ if (!cursor.moveToNext ())
+ return null;
+
+ /* First, retrieve the display name. */
+ index = cursor.getColumnIndex (Document.COLUMN_DISPLAY_NAME);
+
+ if (index < 0)
+ /* Return an invalid directory entry upon failure. */
+ return entry;
+
+ try
+ {
+ name = cursor.getString (index);
+ }
+ catch (Exception exception)
+ {
+ return entry;
+ }
+
+ /* Skip this entry if its name cannot be represented. NAME
+ can still be null here, since some Cursors are permitted to
+ return NULL if INDEX is not a string. */
+
+ if (name == null || name.equals ("..")
+ || name.equals (".") || name.contains ("/")
+ || name.contains ("\0"))
+ continue;
+
+ /* Now, look for its type. */
+
+ index = cursor.getColumnIndex (Document.COLUMN_MIME_TYPE);
+
+ if (index < 0)
+ /* Return an invalid directory entry upon failure. */
+ return entry;
+
+ try
+ {
+ type = cursor.getString (index);
+ }
+ catch (Exception exception)
+ {
+ return entry;
+ }
+
+ if (type != null
+ && type.equals (Document.MIME_TYPE_DIR))
+ entry.d_type = 1;
+ entry.d_name = name;
+ return entry;
+ }
+
+ /* Not reached. */
+ }
+
+ /* Open a file descriptor for a file document designated by
+ DOCUMENTID within the document tree identified by URI. If
+ TRUNCATE and the document already exists, truncate its contents
+ before returning.
+
+ If READ && WRITE, open the file under either the `rw' or `rwt'
+ access mode, which implies that the value must be a seekable
+ on-disk file. If TRUNC && WRITE, also truncate the file after it
+ is opened.
+
+ If only READ or WRITE is set, value may be a non-seekable FIFO or
+ one end of a socket pair.
+
+ Value is NULL upon failure or a parcel file descriptor upon
+ success. Call `ParcelFileDescriptor.close' on this file
+ descriptor instead of using the `close' system call.
+
+ FileNotFoundException and/or SecurityException and
+ UnsupportedOperationException may be thrown upon failure. */
+
+ public ParcelFileDescriptor
+ openDocument (String uri, String documentId,
+ boolean read, boolean write, boolean truncate)
+ {
+ /* Start the thread used to run SAF requests if it isn't already
+ running. */
+
+ if (storageThread == null)
+ {
+ storageThread = new EmacsSafThread (resolver);
+ storageThread.start ();
+ }
+
+ return storageThread.openDocument (uri, documentId, read, write,
+ truncate);
+ }
+
+ /* Create a new document with the given display NAME within the
+ directory identified by DOCUMENTID inside the document tree
+ designated by URI.
+
+ If DOCUMENTID is NULL, create the document inside the root of
+ that tree.
+
+ Either FileNotFoundException, SecurityException or
+ UnsupportedOperationException may be thrown upon failure.
+
+ Return the document ID of the new file upon success, NULL
+ otherwise. */
+
+ public String
+ createDocument (String uri, String documentId, String name)
+ throws FileNotFoundException
+ {
+ String mimeType, separator, mime, extension;
+ int index;
+ MimeTypeMap singleton;
+ Uri treeUri, directoryUri, docUri;
+
+ /* Try to get the MIME type for this document.
+ Default to ``application/octet-stream''. */
+
+ mimeType = "application/octet-stream";
+
+ /* Abuse WebView stuff to get the file's MIME type. */
+
+ index = name.lastIndexOf ('.');
+
+ if (index > 0)
+ {
+ singleton = MimeTypeMap.getSingleton ();
+ extension = name.substring (index + 1);
+ mime = singleton.getMimeTypeFromExtension (extension);
+
+ if (mime != null)
+ mimeType = mime;
+ }
+
+ /* Now parse URI. */
+ treeUri = Uri.parse (uri);
+
+ if (documentId == null)
+ documentId = DocumentsContract.getTreeDocumentId (treeUri);
+
+ /* And build a file URI referring to the directory. */
+
+ directoryUri
+ = DocumentsContract.buildChildDocumentsUriUsingTree (treeUri,
+ documentId);
+
+ docUri = DocumentsContract.createDocument (resolver,
+ directoryUri,
+ mimeType, name);
+
+ if (docUri == null)
+ return null;
+
+ /* Invalidate the file status of the containing directory. */
+
+ if (storageThread != null)
+ storageThread.postInvalidateStat (treeUri, documentId);
+
+ /* Return the ID of the new document. */
+ return DocumentsContract.getDocumentId (docUri);
+ }
+
+ /* Like `createDocument', but create a directory instead of an
+ ordinary document. */
+
+ public String
+ createDirectory (String uri, String documentId, String name)
+ throws FileNotFoundException
+ {
+ int index;
+ Uri treeUri, directoryUri, docUri;
+
+ /* Now parse URI. */
+ treeUri = Uri.parse (uri);
+
+ if (documentId == null)
+ documentId = DocumentsContract.getTreeDocumentId (treeUri);
+
+ /* And build a file URI referring to the directory. */
+
+ directoryUri
+ = DocumentsContract.buildChildDocumentsUriUsingTree (treeUri,
+ documentId);
+
+ /* If name ends with a directory separator character, delete
+ it. */
+
+ if (name.endsWith ("/"))
+ name = name.substring (0, name.length () - 1);
+
+ /* From Android's perspective, directories are just ordinary
+ documents with the `MIME_TYPE_DIR' type. */
+
+ docUri = DocumentsContract.createDocument (resolver,
+ directoryUri,
+ Document.MIME_TYPE_DIR,
+ name);
+
+ if (docUri == null)
+ return null;
+
+ /* Return the ID of the new document, but first invalidate the
+ state of the containing directory. */
+
+ if (storageThread != null)
+ storageThread.postInvalidateStat (treeUri, documentId);
+
+ return DocumentsContract.getDocumentId (docUri);
+ }
+
+ /* Delete the document identified by ID from the document tree
+ identified by URI. Return 0 upon success and -1 upon
+ failure.
+
+ NAME should be the name of the document being deleted, and is
+ used to invalidate the cache. */
+
+ public int
+ deleteDocument (String uri, String id, String name)
+ throws FileNotFoundException
+ {
+ Uri uriObject, tree;
+
+ tree = Uri.parse (uri);
+ uriObject = DocumentsContract.buildDocumentUriUsingTree (tree, id);
+
+ if (DocumentsContract.deleteDocument (resolver, uriObject))
+ {
+ if (storageThread != null)
+ storageThread.postInvalidateCache (tree, id, name);
+
+ return 0;
+ }
+
+ return -1;
+ }
+
+ /* Rename the document designated by DOCID inside the directory tree
+ identified by URI, which should be within the directory
+ designated by DIR, to NAME. If the file can't be renamed because
+ it doesn't support renaming, return -1, 0 otherwise. */
+
+ public int
+ renameDocument (String uri, String docId, String dir, String name)
+ throws FileNotFoundException
+ {
+ Uri tree, uriObject;
+
+ tree = Uri.parse (uri);
+ uriObject = DocumentsContract.buildDocumentUriUsingTree (tree, docId);
+
+ if (DocumentsContract.renameDocument (resolver, uriObject,
+ name)
+ != null)
+ {
+ /* Invalidate the cache. */
+ if (storageThread != null)
+ storageThread.postInvalidateCacheDir (tree, docId,
+ name);
+ return 0;
+ }
+
+ /* Handle errors specially, so `android_saf_rename_document' can
+ return ENXDEV. */
+ return -1;
+ }
+
+ /* Move the document designated by DOCID from the directory under
+ DIR_NAME designated by SRCID to the directory designated by
+ DSTID. If the ID of the document being moved changes as a
+ consequence of the movement, return the new ID, else NULL.
+
+ URI is the document tree containing all three documents. */
+
+ public String
+ moveDocument (String uri, String docId, String dirName,
+ String dstId, String srcId)
+ throws FileNotFoundException
+ {
+ Uri uri1, docId1, dstId1, srcId1;
+ Uri name;
+
+ if (Build.VERSION.SDK_INT < Build.VERSION_CODES.N)
+ throw new UnsupportedOperationException ("Documents aren't capable"
+ + " of being moved on Android"
+ + " versions before 7.0.");
+
+ uri1 = Uri.parse (uri);
+ docId1 = DocumentsContract.buildDocumentUriUsingTree (uri1, docId);
+ dstId1 = DocumentsContract.buildDocumentUriUsingTree (uri1, dstId);
+ srcId1 = DocumentsContract.buildDocumentUriUsingTree (uri1, srcId);
+
+ /* Move the document; this function returns the new ID of the
+ document should it change. */
+ name = DocumentsContract.moveDocument (resolver, docId1,
+ srcId1, dstId1);
+
+ /* Now invalidate the caches for both DIRNAME and DOCID. */
+
+ if (storageThread != null)
+ {
+ storageThread.postInvalidateCacheDir (uri1, docId, dirName);
+
+ /* Invalidate the stat cache entries for both the source and
+ destination directories, since their contents have
+ changed. */
+ storageThread.postInvalidateStat (uri1, dstId);
+ storageThread.postInvalidateStat (uri1, srcId);
+ }
+
+ return (name != null
+ ? DocumentsContract.getDocumentId (name)
+ : null);
+ }
+
+ /* Return if there is a content provider by the name of AUTHORITY
+ supplying at least one tree URI Emacs retains persistent rights
+ to access. */
+
+ public boolean
+ validAuthority (String authority)
+ {
+ List<UriPermission> permissions;
+ Uri uri;
+
+ permissions = resolver.getPersistedUriPermissions ();
+
+ for (UriPermission permission : permissions)
+ {
+ uri = permission.getUri ();
+
+ if (DocumentsContract.isTreeUri (uri)
+ && permission.isReadPermission ()
+ && uri.getAuthority ().equals (authority))
+ return true;
+ }
+
+ return false;
+ }
+
+
+
+ /* Functions for detecting and requesting storage permissions. */
+
+ public boolean
+ externalStorageAvailable ()
+ {
+ final String readPermission;
+
+ readPermission = "android.permission.READ_EXTERNAL_STORAGE";
+
+ return (Build.VERSION.SDK_INT < Build.VERSION_CODES.R
+ ? (checkSelfPermission (readPermission)
+ == PackageManager.PERMISSION_GRANTED)
+ : Environment.isExternalStorageManager ());
+ }
+
+ private void
+ requestStorageAccess23 ()
+ {
+ Runnable runnable;
+
+ runnable = new Runnable () {
+ @Override
+ public void
+ run ()
+ {
+ EmacsActivity activity;
+ String permission, permission1;
+
+ permission = "android.permission.READ_EXTERNAL_STORAGE";
+ permission1 = "android.permission.WRITE_EXTERNAL_STORAGE";
+
+ /* Find an activity that is entitled to display a permission
+ request dialog. */
+
+ if (EmacsActivity.focusedActivities.isEmpty ())
+ {
+ /* If focusedActivities is empty then this dialog may
+ have been displayed immediately after another popup
+ dialog was dismissed. Try the EmacsActivity to be
+ focused. */
+
+ activity = EmacsActivity.lastFocusedActivity;
+
+ if (activity == null)
+ {
+ /* Still no luck. Return failure. */
+ return;
+ }
+ }
+ else
+ activity = EmacsActivity.focusedActivities.get (0);
+
+ /* Now request these permissions. */
+ activity.requestPermissions (new String[] { permission,
+ permission1, },
+ 0);
+ }
+ };
+
+ runOnUiThread (runnable);
+ }
+
+ private void
+ requestStorageAccess30 ()
+ {
+ Runnable runnable;
+ final Intent intent;
+
+ intent
+ = new Intent (Settings.ACTION_MANAGE_APP_ALL_FILES_ACCESS_PERMISSION,
+ Uri.parse ("package:org.gnu.emacs"));
+
+ runnable = new Runnable () {
+ @Override
+ public void
+ run ()
+ {
+ EmacsActivity activity;
+
+ /* Find an activity that is entitled to display a permission
+ request dialog. */
+
+ if (EmacsActivity.focusedActivities.isEmpty ())
+ {
+ /* If focusedActivities is empty then this dialog may
+ have been displayed immediately after another popup
+ dialog was dismissed. Try the EmacsActivity to be
+ focused. */
+
+ activity = EmacsActivity.lastFocusedActivity;
+
+ if (activity == null)
+ {
+ /* Still no luck. Return failure. */
+ return;
+ }
+ }
+ else
+ activity = EmacsActivity.focusedActivities.get (0);
+
+ /* Now request these permissions. */
+
+ activity.startActivity (intent);
+ }
+ };
+
+ runOnUiThread (runnable);
+ }
+
+ public void
+ requestStorageAccess ()
+ {
+ if (Build.VERSION.SDK_INT < Build.VERSION_CODES.R)
+ requestStorageAccess23 ();
+ else
+ requestStorageAccess30 ();
+ }
+
+
+
+ /* Notification miscellany. */
+
+ /* Cancel any notification displayed with the tag TAG. */
+
+ public void
+ cancelNotification (final String string)
+ {
+ Object tem;
+ final NotificationManager manager;
+
+ tem = getSystemService (Context.NOTIFICATION_SERVICE);
+ manager = (NotificationManager) tem;
+
+ runOnUiThread (new Runnable () {
+ @Override
+ public void
+ run ()
+ {
+ manager.cancel (string, 2);
+ }
+ });
+ }
+};
diff --git a/java/org/gnu/emacs/EmacsSurfaceView.java b/java/org/gnu/emacs/EmacsSurfaceView.java
new file mode 100644
index 00000000000..e5601041538
--- /dev/null
+++ b/java/org/gnu/emacs/EmacsSurfaceView.java
@@ -0,0 +1,223 @@
+/* Communication module for Android terminals. -*- c-file-style: "GNU" -*-
+
+Copyright (C) 2023-2024 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 <https://www.gnu.org/licenses/>. */
+
+package org.gnu.emacs;
+
+import android.view.View;
+
+import android.os.Build;
+
+import android.graphics.Bitmap;
+import android.graphics.Canvas;
+import android.graphics.Rect;
+import android.graphics.Paint;
+
+import java.lang.ref.WeakReference;
+
+/* This originally extended SurfaceView. However, doing so proved to
+ be too slow, and Android's surface view keeps up to three of its
+ own back buffers, which use too much memory (up to 96 MB for a
+ single frame.) */
+
+public final class EmacsSurfaceView extends View
+{
+ private static final String TAG = "EmacsSurfaceView";
+
+ /* The complete buffer contents at the time of the last draw. */
+ private Bitmap frontBuffer;
+
+ /* Whether frontBuffer has been updated since the last call to
+ `onDraw'. */
+ private boolean bitmapChanged;
+
+ /* Canvas representing the front buffer. */
+ private Canvas bitmapCanvas;
+
+ /* Reference to the last bitmap copied to the front buffer. */
+ private WeakReference<Bitmap> bitmap;
+
+ /* Paint objects used on the main and UI threads, respectively. */
+ private static final Paint bitmapPaint, uiThreadPaint;
+
+ static
+ {
+ /* Create two different Paint objects; one is used on the main
+ thread for buffer swaps, while the other is used from the UI
+ thread in `onDraw'. This is necessary because Paint objects
+ are not thread-safe, even if their uses are interlocked. */
+
+ bitmapPaint = new Paint ();
+ uiThreadPaint = new Paint ();
+ };
+
+ public
+ EmacsSurfaceView (EmacsView view)
+ {
+ super (view.getContext ());
+
+ this.bitmap = new WeakReference<Bitmap> (null);
+ }
+
+ private void
+ copyToFrontBuffer (Bitmap bitmap, Rect damageRect)
+ {
+ EmacsService.checkEmacsThread ();
+
+ if (Build.VERSION.SDK_INT != Build.VERSION_CODES.O
+ && Build.VERSION.SDK_INT != Build.VERSION_CODES.O_MR1
+ && Build.VERSION.SDK_INT != Build.VERSION_CODES.N_MR1
+ && Build.VERSION.SDK_INT != Build.VERSION_CODES.N)
+ {
+ /* If `drawBitmap' can safely be used while a bitmap is locked
+ by another thread, continue here... */
+
+ if (damageRect != null)
+ bitmapCanvas.drawBitmap (bitmap, damageRect, damageRect,
+ bitmapPaint);
+ else
+ bitmapCanvas.drawBitmap (bitmap, 0f, 0f, bitmapPaint);
+ }
+ else
+ {
+ /* But if it can not, as on Android 7.0 through 8.1, then use
+ a replacement function. */
+
+ if (damageRect != null)
+ EmacsNative.blitRect (bitmap, frontBuffer,
+ damageRect.left,
+ damageRect.top,
+ damageRect.right,
+ damageRect.bottom);
+ else
+ EmacsNative.blitRect (bitmap, frontBuffer, 0, 0,
+ bitmap.getWidth (),
+ bitmap.getHeight ());
+ }
+
+ /* See the large comment inside `onDraw'. */
+ bitmapChanged = true;
+ }
+
+ private void
+ reconfigureFrontBuffer (Bitmap bitmap)
+ {
+ /* First, remove the old front buffer. */
+
+ if (frontBuffer != null)
+ {
+ frontBuffer.recycle ();
+ frontBuffer = null;
+ bitmapCanvas = null;
+ }
+
+ this.bitmap = new WeakReference<Bitmap> (bitmap);
+
+ /* Next, create the new front buffer if necessary. */
+
+ if (bitmap != null && frontBuffer == null)
+ {
+ if (Build.VERSION.SDK_INT >= Build.VERSION_CODES.O)
+ frontBuffer = Bitmap.createBitmap (bitmap.getWidth (),
+ bitmap.getHeight (),
+ Bitmap.Config.ARGB_8888,
+ false);
+ else
+ frontBuffer = Bitmap.createBitmap (bitmap.getWidth (),
+ bitmap.getHeight (),
+ Bitmap.Config.ARGB_8888);
+
+ bitmapCanvas = new Canvas (frontBuffer);
+
+ /* And copy over the bitmap contents. */
+ copyToFrontBuffer (bitmap, null);
+ }
+ else if (bitmap != null)
+ /* Just copy over the bitmap contents. */
+ copyToFrontBuffer (bitmap, null);
+ }
+
+ public synchronized void
+ setBitmap (Bitmap bitmap, Rect damageRect)
+ {
+ if (bitmap != this.bitmap.get ())
+ reconfigureFrontBuffer (bitmap);
+ else if (bitmap != null)
+ copyToFrontBuffer (bitmap, damageRect);
+
+ if (bitmap != null)
+ {
+ /* In newer versions of Android, the invalid rectangle is
+ supposedly internally calculated by the system. How that
+ is done is unknown, but calling `invalidateRect' is now
+ deprecated.
+
+ Fortunately, nobody has deprecated the version of
+ `postInvalidate' that accepts a dirty rectangle. */
+
+ if (damageRect != null)
+ postInvalidate (damageRect.left, damageRect.top,
+ damageRect.right, damageRect.bottom);
+ else
+ postInvalidate ();
+ }
+ }
+
+ @Override
+ public synchronized void
+ onDraw (Canvas canvas)
+ {
+ /* Paint the view's bitmap; the bitmap might be recycled right
+ now. */
+
+ if (frontBuffer != null)
+ {
+ /* The first time the bitmap is drawn after a buffer swap,
+ mark its contents as having changed. This increments the
+ ``generation ID'' used by Android to avoid uploading buffer
+ textures for unchanged bitmaps.
+
+ When a buffer swap takes place, the bitmap is initially
+ updated from the Emacs thread, resulting in the generation
+ ID being increased. If the render thread is texturizing
+ the bitmap while the swap takes place, it might record the
+ generation ID after the update for a texture containing the
+ contents of the bitmap prior to the swap, leaving the
+ texture tied to the bitmap partially updated.
+
+ Android never calls `onDraw' if the render thread is still
+ processing the bitmap. Update the generation ID here to
+ ensure that a new texture will be uploaded if the bitmap
+ has changed.
+
+ Uploading the bitmap contents to the GPU uses an excessive
+ amount of memory, as the entire bitmap is placed into the
+ graphics command queue, but this memory is actually shared
+ among all other applications and reclaimed by the system
+ when necessary. */
+
+ if (bitmapChanged)
+ {
+ EmacsNative.notifyPixelsChanged (frontBuffer);
+ bitmapChanged = false;
+ }
+
+ canvas.drawBitmap (frontBuffer, 0f, 0f, uiThreadPaint);
+ }
+ }
+};
diff --git a/java/org/gnu/emacs/EmacsThread.java b/java/org/gnu/emacs/EmacsThread.java
new file mode 100644
index 00000000000..4adcb98b2f7
--- /dev/null
+++ b/java/org/gnu/emacs/EmacsThread.java
@@ -0,0 +1,82 @@
+/* Communication module for Android terminals. -*- c-file-style: "GNU" -*-
+
+Copyright (C) 2023-2024 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 <https://www.gnu.org/licenses/>. */
+
+package org.gnu.emacs;
+
+import java.lang.Thread;
+import java.util.Arrays;
+
+import android.util.Log;
+
+public final class EmacsThread extends Thread
+{
+ private static final String TAG = "EmacsThread";
+
+ /* Whether or not Emacs should be started with an additional
+ argument, and that additional argument if non-NULL. */
+ private String extraStartupArgument;
+
+ /* Runnable run to initialize Emacs. */
+ private Runnable paramsClosure;
+
+ /* Whether or not to open a file after starting Emacs. */
+ private String fileToOpen;
+
+ public
+ EmacsThread (EmacsService service, Runnable paramsClosure,
+ String extraStartupArgument, String fileToOpen)
+ {
+ super ("Emacs main thread");
+ this.extraStartupArgument = extraStartupArgument;
+ this.paramsClosure = paramsClosure;
+ this.fileToOpen = fileToOpen;
+ }
+
+ @Override
+ public void
+ run ()
+ {
+ String args[];
+
+ if (fileToOpen == null)
+ {
+ if (extraStartupArgument == null)
+ args = new String[] { "libandroid-emacs.so", };
+ else
+ args = new String[] { "libandroid-emacs.so",
+ extraStartupArgument, };
+ }
+ else
+ {
+ if (extraStartupArgument == null)
+ args = new String[] { "libandroid-emacs.so",
+ fileToOpen, };
+ else
+ args = new String[] { "libandroid-emacs.so",
+ extraStartupArgument,
+ fileToOpen, };
+ }
+
+ paramsClosure.run ();
+
+ /* Run the native code now. */
+ Log.d (TAG, "run: " + Arrays.toString (args));
+ EmacsNative.initEmacs (args, EmacsApplication.dumpFileName);
+ }
+};
diff --git a/java/org/gnu/emacs/EmacsView.java b/java/org/gnu/emacs/EmacsView.java
new file mode 100644
index 00000000000..109208b2518
--- /dev/null
+++ b/java/org/gnu/emacs/EmacsView.java
@@ -0,0 +1,938 @@
+/* Communication module for Android terminals. -*- c-file-style: "GNU" -*-
+
+Copyright (C) 2023-2024 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 <https://www.gnu.org/licenses/>. */
+
+package org.gnu.emacs;
+
+import android.content.Context;
+
+import android.text.InputType;
+
+import android.view.ContextMenu;
+import android.view.DragEvent;
+import android.view.View;
+import android.view.KeyEvent;
+import android.view.MotionEvent;
+import android.view.ViewGroup;
+import android.view.ViewTreeObserver;
+import android.view.WindowInsets;
+
+import android.view.inputmethod.EditorInfo;
+import android.view.inputmethod.InputConnection;
+import android.view.inputmethod.InputMethodManager;
+
+import android.graphics.Bitmap;
+import android.graphics.Canvas;
+import android.graphics.Rect;
+import android.graphics.Region;
+import android.graphics.Paint;
+
+import android.os.Build;
+import android.util.Log;
+
+/* This is an Android view which has a back and front buffer. When
+ swapBuffers is called, the back buffer is swapped to the front
+ buffer, and any damage is invalidated. frontBitmap and backBitmap
+ are modified and used both from the UI and the Emacs thread. As a
+ result, there is a lock held during all drawing operations.
+
+ It is also a ViewGroup, as it also lays out children. */
+
+public final class EmacsView extends ViewGroup
+ implements ViewTreeObserver.OnGlobalLayoutListener
+{
+ public static final String TAG = "EmacsView";
+
+ /* The associated EmacsWindow. */
+ public EmacsWindow window;
+
+ /* The buffer bitmap. */
+ public Bitmap bitmap;
+
+ /* The associated canvases. */
+ public Canvas canvas;
+
+ /* The damage region. */
+ public Region damageRegion;
+
+ /* The associated surface view. */
+ private EmacsSurfaceView surfaceView;
+
+ /* Whether or not a configure event must be sent for the next layout
+ event regardless of what changed. */
+ public boolean mustReportLayout;
+
+ /* Whether or not bitmaps must be recreated upon the next call to
+ getBitmap. */
+ private boolean bitmapDirty;
+
+ /* Whether or not a popup is active. */
+ private boolean popupActive;
+
+ /* The current context menu. */
+ private EmacsContextMenu contextMenu;
+
+ /* The last measured width and height. */
+ private int measuredWidth, measuredHeight;
+
+ /* Object acting as a lock for those values. */
+ private Object dimensionsLock;
+
+ /* The serial of the last clip rectangle change. */
+ private long lastClipSerial;
+
+ /* The InputMethodManager for this view's context. */
+ public InputMethodManager imManager;
+
+ /* Whether or not this view is attached to a window. */
+ public boolean isAttachedToWindow;
+
+ /* Whether or not this view should have the on screen keyboard
+ displayed whenever possible. */
+ public boolean isCurrentlyTextEditor;
+
+ /* The associated input connection. */
+ private EmacsInputConnection inputConnection;
+
+ /* The current IC mode. See `android_reset_ic' for more
+ details. */
+ private int icMode;
+
+ /* The number of calls to `resetIC' to have taken place the last
+ time an InputConnection was created. */
+ public long icSerial;
+
+ /* The number of calls to `recetIC' that have taken place. */
+ public volatile long icGeneration;
+
+ public
+ EmacsView (EmacsWindow window)
+ {
+ super (EmacsService.SERVICE);
+
+ Object tem;
+ Context context;
+
+ this.window = window;
+ this.damageRegion = new Region ();
+
+ setFocusable (true);
+ setFocusableInTouchMode (true);
+
+ /* Create the surface view. */
+ this.surfaceView = new EmacsSurfaceView (this);
+ addView (this.surfaceView);
+
+ /* Get rid of the default focus highlight. */
+ if (Build.VERSION.SDK_INT > Build.VERSION_CODES.O)
+ setDefaultFocusHighlightEnabled (false);
+
+ /* Obtain the input method manager. */
+ context = getContext ();
+ tem = context.getSystemService (Context.INPUT_METHOD_SERVICE);
+ imManager = (InputMethodManager) tem;
+
+ /* Add this view as its own global layout listener. */
+ getViewTreeObserver ().addOnGlobalLayoutListener (this);
+
+ /* Create an object used as a lock. */
+ this.dimensionsLock = new Object ();
+ }
+
+ private void
+ handleDirtyBitmap ()
+ {
+ Bitmap oldBitmap;
+ int measuredWidth, measuredHeight;
+
+ synchronized (dimensionsLock)
+ {
+ /* Load measuredWidth and measuredHeight. */
+ measuredWidth = this.measuredWidth;
+ measuredHeight = this.measuredHeight;
+ }
+
+ if (measuredWidth == 0 || measuredHeight == 0)
+ return;
+
+ if (!isAttachedToWindow)
+ return;
+
+ /* If bitmap is the same width and height as the measured width
+ and height, there is no need to do anything. Avoid allocating
+ the extra bitmap. */
+ if (bitmap != null
+ && (bitmap.getWidth () == measuredWidth
+ && bitmap.getHeight () == measuredHeight))
+ {
+ bitmapDirty = false;
+ return;
+ }
+
+ /* Save the old bitmap. */
+ oldBitmap = bitmap;
+
+ /* Recreate the back buffer bitmap. */
+ bitmap
+ = Bitmap.createBitmap (measuredWidth,
+ measuredHeight,
+ Bitmap.Config.ARGB_8888);
+ bitmap.eraseColor (window.background | 0xff000000);
+
+ /* And canvases. */
+ canvas = new Canvas (bitmap);
+ canvas.save ();
+
+ /* Since the clip rectangles have been cleared, clear the clip
+ rectangle ID. */
+ lastClipSerial = 0;
+
+ /* Copy over the contents of the old bitmap. */
+ if (oldBitmap != null)
+ canvas.drawBitmap (oldBitmap, 0f, 0f, new Paint ());
+
+ bitmapDirty = false;
+
+ /* Explicitly free the old bitmap's memory. */
+
+ if (oldBitmap != null)
+ oldBitmap.recycle ();
+
+ /* Some Android versions still don't free the bitmap until the
+ next GC. */
+ Runtime.getRuntime ().gc ();
+ }
+
+ public synchronized void
+ explicitlyDirtyBitmap ()
+ {
+ bitmapDirty = true;
+ }
+
+ public synchronized Bitmap
+ getBitmap ()
+ {
+ if (bitmapDirty || bitmap == null)
+ handleDirtyBitmap ();
+
+ return bitmap;
+ }
+
+ public synchronized Canvas
+ getCanvas (EmacsGC gc)
+ {
+ int i;
+
+ if (bitmapDirty || bitmap == null)
+ handleDirtyBitmap ();
+
+ if (canvas == null)
+ return null;
+
+ /* Update clip rectangles if necessary. */
+ if (gc.clipRectID != lastClipSerial)
+ {
+ canvas.restore ();
+ canvas.save ();
+
+ if (gc.real_clip_rects != null)
+ {
+ for (i = 0; i < gc.real_clip_rects.length; ++i)
+ canvas.clipRect (gc.real_clip_rects[i]);
+ }
+
+ lastClipSerial = gc.clipRectID;
+ }
+
+ return canvas;
+ }
+
+ public void
+ prepareForLayout (int wantedWidth, int wantedHeight)
+ {
+ synchronized (dimensionsLock)
+ {
+ measuredWidth = wantedWidth;
+ measuredHeight = wantedWidth;
+ }
+ }
+
+ @Override
+ protected void
+ onMeasure (int widthMeasureSpec, int heightMeasureSpec)
+ {
+ Rect measurements;
+ int width, height;
+
+ /* Return the width and height of the window regardless of what
+ the parent says. */
+ measurements = window.getGeometry ();
+
+ width = measurements.width ();
+ height = measurements.height ();
+
+ /* Now apply any extra requirements in widthMeasureSpec and
+ heightMeasureSpec. */
+
+ if (MeasureSpec.getMode (widthMeasureSpec) == MeasureSpec.EXACTLY)
+ width = MeasureSpec.getSize (widthMeasureSpec);
+ else if (MeasureSpec.getMode (widthMeasureSpec) == MeasureSpec.AT_MOST
+ && width > MeasureSpec.getSize (widthMeasureSpec))
+ width = MeasureSpec.getSize (widthMeasureSpec);
+
+ if (MeasureSpec.getMode (heightMeasureSpec) == MeasureSpec.EXACTLY)
+ height = MeasureSpec.getSize (heightMeasureSpec);
+ else if (MeasureSpec.getMode (heightMeasureSpec) == MeasureSpec.AT_MOST
+ && height > MeasureSpec.getSize (heightMeasureSpec))
+ height = MeasureSpec.getSize (heightMeasureSpec);
+
+ super.setMeasuredDimension (width, height);
+ }
+
+ /* Return whether this view's window is focused. This is made
+ necessary by Android 11's unreliable dispatch of
+ onWindowFocusChanged prior to gesture navigation away from a
+ frame. */
+
+ public boolean
+ checkWindowFocus ()
+ {
+ EmacsActivity activity;
+ Object consumer;
+
+ consumer = window.getAttachedConsumer ();
+
+ if (!(consumer instanceof EmacsActivity))
+ return false;
+
+ activity = (EmacsActivity) consumer;
+ return activity.hasWindowFocus ();
+ }
+
+ /* Note that the monitor lock for the window must never be held from
+ within the lock for the view, because the window also locks the
+ other way around. */
+
+ @Override
+ protected void
+ onLayout (boolean changed, int left, int top, int right,
+ int bottom)
+ {
+ int count, i, oldMeasuredWidth, oldMeasuredHeight;
+ View child;
+ Rect windowRect;
+ boolean needExpose;
+ WindowInsets rootWindowInsets;
+
+ count = getChildCount ();
+ needExpose = false;
+
+ synchronized (dimensionsLock)
+ {
+ /* Load measuredWidth and measuredHeight. */
+ oldMeasuredWidth = measuredWidth;
+ oldMeasuredHeight = measuredHeight;
+
+ /* Set measuredWidth and measuredHeight. */
+ measuredWidth = right - left;
+ measuredHeight = bottom - top;
+ }
+
+ /* If oldMeasuredHeight or oldMeasuredWidth are wrong, set changed
+ to true as well. */
+
+ if (right - left != oldMeasuredWidth
+ || bottom - top != oldMeasuredHeight)
+ changed = true;
+
+ /* Dirty the back buffer if the layout change resulted in the view
+ being resized. */
+
+ if (changed)
+ {
+ explicitlyDirtyBitmap ();
+
+ /* Expose the window upon a change in the view's size. */
+
+ if (right - left > oldMeasuredWidth
+ || bottom - top > oldMeasuredHeight)
+ needExpose = true;
+
+ /* This might return NULL if this view is not attached. */
+ if (Build.VERSION.SDK_INT >= Build.VERSION_CODES.R)
+ {
+ /* If a toplevel view is focused and isCurrentlyTextEditor
+ is enabled when the IME is hidden, clear
+ isCurrentlyTextEditor so it isn't shown again if the
+ user dismisses Emacs before returning. */
+ rootWindowInsets = getRootWindowInsets ();
+
+ if (isCurrentlyTextEditor
+ && rootWindowInsets != null
+ && isAttachedToWindow
+ && !rootWindowInsets.isVisible (WindowInsets.Type.ime ())
+ /* N.B. that the keyboard is dismissed during gesture
+ navigation under Android 30, but the system is
+ quite temperamental regarding whether the window is
+ focused at that point. Ideally
+ isCurrentlyTextEditor shouldn't be reset in that
+ case, but detecting that situation appears to be
+ impossible. Sigh. */
+ && (window == EmacsActivity.focusedWindow
+ && hasWindowFocus ()))
+ isCurrentlyTextEditor = false;
+ }
+ }
+
+ for (i = 0; i < count; ++i)
+ {
+ child = getChildAt (i);
+
+ if (child == surfaceView)
+ child.layout (0, 0, right - left, bottom - top);
+ else if (child.getVisibility () != GONE)
+ {
+ if (!(child instanceof EmacsView))
+ continue;
+
+ /* What to do: lay out the view precisely according to its
+ window rect. */
+ windowRect = ((EmacsView) child).window.getGeometry ();
+ child.layout (windowRect.left, windowRect.top,
+ windowRect.right, windowRect.bottom);
+ }
+ }
+
+ /* Now report the layout change to the window. */
+
+ if (changed || mustReportLayout)
+ {
+ mustReportLayout = false;
+ window.viewLayout (left, top, right, bottom);
+ }
+
+ if (needExpose)
+ EmacsNative.sendExpose (this.window.handle, 0, 0,
+ right - left, bottom - top);
+ }
+
+ public void
+ damageRect (Rect damageRect)
+ {
+ EmacsService.checkEmacsThread ();
+ damageRegion.union (damageRect);
+ }
+
+ /* This function enables damage to be recorded without consing a new
+ Rect object. */
+
+ public void
+ damageRect (int left, int top, int right, int bottom)
+ {
+ EmacsService.checkEmacsThread ();
+ damageRegion.op (left, top, right, bottom, Region.Op.UNION);
+ }
+
+ /* This method is called from both the UI thread and the Emacs
+ thread. */
+
+ public void
+ swapBuffers ()
+ {
+ Canvas canvas;
+ Rect damageRect;
+
+ /* Make sure this function is called only from the Emacs
+ thread. */
+ EmacsService.checkEmacsThread ();
+
+ damageRect = null;
+
+ /* Now see if there is a damage region. */
+
+ if (damageRegion.isEmpty ())
+ return;
+
+ /* And extract and clear the damage region. */
+
+ damageRect = damageRegion.getBounds ();
+ damageRegion.setEmpty ();
+
+ synchronized (this)
+ {
+ /* Transfer the bitmap to the surface view, then invalidate
+ it. */
+ surfaceView.setBitmap (bitmap, damageRect);
+ }
+ }
+
+ @Override
+ public boolean
+ onKeyPreIme (int keyCode, KeyEvent event)
+ {
+ /* Several Android systems intercept key events representing
+ C-SPC. Avert this by detecting C-SPC events here and relaying
+ them directly to onKeyDown.
+
+ Make this optional though, since some input methods also
+ leverage C-SPC as a shortcut for switching languages. */
+
+ if ((keyCode == KeyEvent.KEYCODE_SPACE
+ && (window.eventModifiers (event)
+ & KeyEvent.META_CTRL_MASK) != 0)
+ && !EmacsNative.shouldForwardCtrlSpace ())
+ return onKeyDown (keyCode, event);
+
+ return super.onKeyPreIme (keyCode, event);
+ }
+
+ @Override
+ public boolean
+ onKeyDown (int keyCode, KeyEvent event)
+ {
+ if ((keyCode == KeyEvent.KEYCODE_VOLUME_UP
+ || keyCode == KeyEvent.KEYCODE_VOLUME_DOWN
+ || keyCode == KeyEvent.KEYCODE_VOLUME_MUTE)
+ && !EmacsNative.shouldForwardMultimediaButtons ())
+ return false;
+
+ window.onKeyDown (keyCode, event);
+ return true;
+ }
+
+ @Override
+ public boolean
+ onKeyMultiple (int keyCode, int repeatCount, KeyEvent event)
+ {
+ if ((keyCode == KeyEvent.KEYCODE_VOLUME_UP
+ || keyCode == KeyEvent.KEYCODE_VOLUME_DOWN
+ || keyCode == KeyEvent.KEYCODE_VOLUME_MUTE)
+ && !EmacsNative.shouldForwardMultimediaButtons ())
+ return false;
+
+ window.onKeyDown (keyCode, event);
+ return true;
+ }
+
+ @Override
+ public boolean
+ onKeyUp (int keyCode, KeyEvent event)
+ {
+ if ((keyCode == KeyEvent.KEYCODE_VOLUME_UP
+ || keyCode == KeyEvent.KEYCODE_VOLUME_DOWN
+ || keyCode == KeyEvent.KEYCODE_VOLUME_MUTE)
+ && !EmacsNative.shouldForwardMultimediaButtons ())
+ return false;
+
+ window.onKeyUp (keyCode, event);
+ return true;
+ }
+
+ @Override
+ public void
+ onFocusChanged (boolean gainFocus, int direction,
+ Rect previouslyFocusedRect)
+ {
+ window.onFocusChanged (gainFocus);
+ super.onFocusChanged (gainFocus, direction,
+ previouslyFocusedRect);
+ }
+
+ @Override
+ public boolean
+ onGenericMotionEvent (MotionEvent motion)
+ {
+ return window.onGenericMotionEvent (motion);
+ }
+
+ @Override
+ public boolean
+ onTouchEvent (MotionEvent motion)
+ {
+ return window.onTouchEvent (motion);
+ }
+
+ @Override
+ public boolean
+ onDragEvent (DragEvent drag)
+ {
+ /* Inter-program drag and drop isn't supported under Android 23
+ and earlier. */
+
+ if (Build.VERSION.SDK_INT < Build.VERSION_CODES.N)
+ return false;
+
+ return window.onDragEvent (drag);
+ }
+
+
+
+ private void
+ moveChildToBack (View child)
+ {
+ int index;
+
+ index = indexOfChild (child);
+
+ if (index > 0)
+ {
+ detachViewFromParent (index);
+
+ /* The view at 0 is the surface view. */
+ attachViewToParent (child, 1,
+ child.getLayoutParams ());
+ }
+ }
+
+ /* The following four functions must not be called if the view has
+ no parent, or is parented to an activity. */
+
+ public void
+ raise ()
+ {
+ EmacsView parent;
+
+ parent = (EmacsView) getParent ();
+
+ if (parent.indexOfChild (this)
+ == parent.getChildCount () - 1)
+ return;
+
+ parent.bringChildToFront (this);
+ }
+
+ public void
+ lower ()
+ {
+ EmacsView parent;
+
+ parent = (EmacsView) getParent ();
+
+ if (parent.indexOfChild (this) == 1)
+ return;
+
+ parent.moveChildToBack (this);
+ }
+
+ public void
+ moveAbove (EmacsView view)
+ {
+ EmacsView parent;
+ int index;
+
+ parent = (EmacsView) getParent ();
+
+ if (parent != view.getParent ())
+ throw new IllegalStateException ("Moving view above non-sibling");
+
+ index = parent.indexOfChild (this);
+ parent.detachViewFromParent (index);
+ index = parent.indexOfChild (view);
+ parent.attachViewToParent (this, index + 1, getLayoutParams ());
+ }
+
+ public void
+ moveBelow (EmacsView view)
+ {
+ EmacsView parent;
+ int index;
+
+ parent = (EmacsView) getParent ();
+
+ if (parent != view.getParent ())
+ throw new IllegalStateException ("Moving view above non-sibling");
+
+ index = parent.indexOfChild (this);
+ parent.detachViewFromParent (index);
+ index = parent.indexOfChild (view);
+ parent.attachViewToParent (this, index, getLayoutParams ());
+ }
+
+ @Override
+ protected void
+ onCreateContextMenu (ContextMenu menu)
+ {
+ if (contextMenu == null)
+ return;
+
+ contextMenu.expandTo (menu, this);
+ }
+
+ public boolean
+ popupMenu (EmacsContextMenu menu, int xPosition,
+ int yPosition, boolean force)
+ {
+ if (popupActive && !force)
+ return false;
+
+ /* Android will permanently cease to display any popup menus at
+ all if the list of menu items is empty. Prevent this by
+ promptly returning if there are no menu items. */
+
+ if (menu.menuItems.isEmpty ())
+ return false;
+
+ contextMenu = menu;
+ popupActive = true;
+
+ /* Use showContextMenu (float, float) on N to get actual popup
+ behavior. */
+ if (Build.VERSION.SDK_INT >= Build.VERSION_CODES.N)
+ return showContextMenu ((float) xPosition, (float) yPosition);
+ else
+ return showContextMenu ();
+ }
+
+ public void
+ cancelPopupMenu ()
+ {
+ if (!popupActive)
+ throw new IllegalStateException ("cancelPopupMenu called without"
+ + " popupActive set");
+
+ contextMenu = null;
+ popupActive = false;
+
+ /* It is not possible to know with 100% certainty which activity
+ is currently displaying the context menu. Loop through each
+ activity and call `closeContextMenu' instead. */
+
+ for (EmacsWindowAttachmentManager.WindowConsumer consumer
+ : EmacsWindowAttachmentManager.MANAGER.consumers)
+ {
+ if (consumer instanceof EmacsActivity)
+ ((EmacsActivity) consumer).closeContextMenu ();
+ }
+ }
+
+ @Override
+ public synchronized void
+ onDetachedFromWindow ()
+ {
+ Bitmap savedBitmap;
+
+ savedBitmap = bitmap;
+ isAttachedToWindow = false;
+ bitmap = null;
+ canvas = null;
+
+ surfaceView.setBitmap (null, null);
+
+ /* Recycle the bitmap and call GC. */
+
+ if (savedBitmap != null)
+ savedBitmap.recycle ();
+
+ /* Collect the bitmap storage; it could be large. */
+ Runtime.getRuntime ().gc ();
+
+ super.onDetachedFromWindow ();
+ }
+
+ @Override
+ public synchronized void
+ onAttachedToWindow ()
+ {
+ isAttachedToWindow = true;
+
+ /* Dirty the bitmap, as it was destroyed when onDetachedFromWindow
+ was called. */
+ bitmapDirty = true;
+
+ synchronized (dimensionsLock)
+ {
+ /* Now expose the view contents again. */
+ EmacsNative.sendExpose (this.window.handle, 0, 0,
+ measuredWidth, measuredHeight);
+ }
+
+ super.onAttachedToWindow ();
+ }
+
+ public void
+ showOnScreenKeyboard ()
+ {
+ /* Specifying no flags at all tells the system the user asked for
+ the input method to be displayed. */
+
+ imManager.showSoftInput (this, 0);
+ isCurrentlyTextEditor = true;
+ }
+
+ public void
+ hideOnScreenKeyboard ()
+ {
+ imManager.hideSoftInputFromWindow (this.getWindowToken (),
+ 0);
+ isCurrentlyTextEditor = false;
+ }
+
+ @Override
+ public InputConnection
+ onCreateInputConnection (EditorInfo info)
+ {
+ int mode;
+ int[] selection;
+
+ /* Figure out what kind of IME behavior Emacs wants. */
+ mode = getICMode ();
+
+ /* Make sure the input method never displays a full screen input
+ box that obscures Emacs. */
+ info.imeOptions = EditorInfo.IME_FLAG_NO_FULLSCREEN;
+ info.imeOptions |= EditorInfo.IME_FLAG_NO_EXTRACT_UI;
+
+ /* Set a reasonable inputType. */
+ info.inputType = InputType.TYPE_CLASS_TEXT;
+
+ /* If this fails or ANDROID_IC_MODE_NULL was requested, then don't
+ initialize the input connection. */
+
+ if (mode == EmacsService.IC_MODE_NULL)
+ {
+ info.inputType = InputType.TYPE_NULL;
+ return null;
+ }
+
+ /* Set icSerial. If icSerial < icGeneration, the input connection
+ has been reset, and future input should be ignored until a new
+ connection is created. */
+
+ icSerial = icGeneration;
+
+ /* Reset flags set by the previous input method. */
+
+ EmacsNative.clearInputFlags (window.handle);
+
+ /* Obtain the current position of point and set it as the
+ selection. Don't do this under one specific situation: if
+ `android_update_ic' is being called in the main thread, trying
+ to synchronize with it can cause a dead lock in the IM manager.
+ See icBeginSynchronous in EmacsService.java for more
+ details. */
+
+ selection = EmacsService.viewGetSelection (window.handle);
+
+ if (selection == null)
+ {
+ /* If the selection could not be obtained, return 0 by 0.
+ However, ask for the selection position to be updated as
+ soon as possible. */
+
+ selection = new int[] { 0, 0, };
+ EmacsNative.requestSelectionUpdate (window.handle);
+ }
+
+ if (mode == EmacsService.IC_MODE_ACTION
+ || mode == EmacsService.IC_MODE_PASSWORD)
+ info.imeOptions |= EditorInfo.IME_ACTION_DONE;
+
+ if (mode == EmacsService.IC_MODE_PASSWORD)
+ info.inputType |= InputType.TYPE_TEXT_VARIATION_PASSWORD;
+
+ /* Set the initial selection fields. */
+ info.initialSelStart = selection[0];
+ info.initialSelEnd = selection[1];
+
+ /* Create the input connection if necessary. */
+
+ if (inputConnection == null)
+ inputConnection = new EmacsInputConnection (this);
+ else
+ /* Clear several pieces of state in the input connection. */
+ inputConnection.reset ();
+
+ /* Return the input connection. */
+ return inputConnection;
+ }
+
+ @Override
+ public synchronized boolean
+ onCheckIsTextEditor ()
+ {
+ /* If value is true, then the system will display the on screen
+ keyboard. */
+ return isCurrentlyTextEditor;
+ }
+
+ @Override
+ public boolean
+ isOpaque ()
+ {
+ /* Returning true here allows the system to not draw the contents
+ of windows underneath this view, thereby improving
+ performance. */
+ return true;
+ }
+
+ public synchronized void
+ setICMode (int icMode)
+ {
+ this.icMode = icMode;
+ }
+
+ public synchronized int
+ getICMode ()
+ {
+ return icMode;
+ }
+
+ @Override
+ public void
+ onGlobalLayout ()
+ {
+ int[] locations;
+
+ /* Get the absolute offset of this view and specify its left and
+ top position in subsequent ConfigureNotify events. */
+
+ locations = new int[2];
+ getLocationInWindow (locations);
+ window.notifyContentRectPosition (locations[0],
+ locations[1]);
+ }
+
+ @Override
+ public WindowInsets
+ onApplyWindowInsets (WindowInsets insets)
+ {
+ WindowInsets rootWindowInsets;
+
+ /* This function is called when window insets change, which
+ encompasses input method visibility changes under Android 30
+ and later. If a toplevel view is focused and
+ isCurrentlyTextEditor is enabled when the IME is hidden, clear
+ isCurrentlyTextEditor so it isn't shown again if the user
+ dismisses Emacs before returning. */
+
+ if (Build.VERSION.SDK_INT < Build.VERSION_CODES.R)
+ return super.onApplyWindowInsets (insets);
+
+ /* This might return NULL if this view is not attached. */
+ rootWindowInsets = getRootWindowInsets ();
+
+ if (isCurrentlyTextEditor
+ && rootWindowInsets != null
+ && isAttachedToWindow
+ && !rootWindowInsets.isVisible (WindowInsets.Type.ime ())
+ && window == EmacsActivity.focusedWindow)
+ isCurrentlyTextEditor = false;
+
+ return super.onApplyWindowInsets (insets);
+ }
+};
diff --git a/java/org/gnu/emacs/EmacsWindow.java b/java/org/gnu/emacs/EmacsWindow.java
new file mode 100644
index 00000000000..2baede1d2d0
--- /dev/null
+++ b/java/org/gnu/emacs/EmacsWindow.java
@@ -0,0 +1,1878 @@
+/* Communication module for Android terminals. -*- c-file-style: "GNU" -*-
+
+Copyright (C) 2023-2024 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 <https://www.gnu.org/licenses/>. */
+
+package org.gnu.emacs;
+
+import java.lang.IllegalStateException;
+import java.util.ArrayList;
+import java.util.List;
+import java.util.ListIterator;
+import java.util.LinkedHashMap;
+import java.util.Map;
+
+import android.app.Activity;
+
+import android.content.ClipData;
+import android.content.ClipDescription;
+import android.content.ContentResolver;
+import android.content.Context;
+
+import android.graphics.Rect;
+import android.graphics.Canvas;
+import android.graphics.Bitmap;
+import android.graphics.PixelFormat;
+
+import android.net.Uri;
+
+import android.view.DragEvent;
+import android.view.Gravity;
+import android.view.InputDevice;
+import android.view.KeyEvent;
+import android.view.MotionEvent;
+import android.view.View;
+import android.view.ViewManager;
+import android.view.WindowManager;
+
+import android.util.SparseArray;
+import android.util.Log;
+
+import android.os.Build;
+
+/* This defines a window, which is a handle. Windows represent a
+ rectangular subset of the screen with their own contents.
+
+ Windows either have a parent window, in which case their views are
+ attached to the parent's view, or are "floating", in which case
+ their views are attached to the parent activity (if any), else
+ nothing.
+
+ Views are also drawables, meaning they can accept drawing
+ requests. */
+
+public final class EmacsWindow extends EmacsHandleObject
+ implements EmacsDrawable
+{
+ private static final String TAG = "EmacsWindow";
+
+ private static class Coordinate
+ {
+ /* Integral coordinate. */
+ int x, y;
+
+ /* Button associated with the coordinate, or 0 if it is a touch
+ event. */
+ int button;
+
+ /* Pointer ID associated with the coordinate. */
+ int id;
+
+ public
+ Coordinate (int x, int y, int button, int id)
+ {
+ this.x = x;
+ this.y = y;
+ this.button = button;
+ this.id = id;
+ }
+ };
+
+ /* The view associated with the window. */
+ public EmacsView view;
+
+ /* The geometry of the window. */
+ private Rect rect;
+
+ /* The parent window, or null if it is the root window. */
+ public EmacsWindow parent;
+
+ /* List of all children in stacking order. This must be kept
+ consistent with their Z order!
+
+ Synchronize access to this list with itself. */
+ public ArrayList<EmacsWindow> children;
+
+ /* Map between pointer identifiers and last known position. Used to
+ compute which pointer changed upon a touch event. */
+ private SparseArray<Coordinate> pointerMap;
+
+ /* The window consumer currently attached, if it exists. */
+ private EmacsWindowAttachmentManager.WindowConsumer attached;
+
+ /* The window background scratch GC. foreground is always the
+ window background. */
+ private EmacsGC scratchGC;
+
+ /* The button state and keyboard modifier mask at the time of the
+ last button press or release event. */
+ public int lastButtonState;
+
+ /* Whether or not the window is mapped. */
+ private volatile boolean isMapped;
+
+ /* Whether or not to ask for focus upon being mapped. */
+ private boolean dontFocusOnMap;
+
+ /* Whether or not the window is override-redirect. An
+ override-redirect window always has its own system window. */
+ private boolean overrideRedirect;
+
+ /* The window manager that is the parent of this window. NULL if
+ there is no such window manager. */
+ private WindowManager windowManager;
+
+ /* The time of the last KEYCODE_VOLUME_DOWN release. This is used
+ to quit Emacs upon two rapid clicks of the volume down
+ button. */
+ private long lastVolumeButtonRelease;
+
+ /* Linked list of character strings which were recently sent as
+ events. */
+ public LinkedHashMap<Integer, String> eventStrings;
+
+ /* Whether or not this window is fullscreen. */
+ public boolean fullscreen;
+
+ /* The window background pixel. This is used by EmacsView when
+ creating new bitmaps. */
+ public volatile int background;
+
+ /* The position of this window relative to the root window. */
+ public int xPosition, yPosition;
+
+ /* The position of the last drag and drop event received; both
+ values are -1 if no drag and drop operation is under way. */
+ private int dndXPosition, dndYPosition;
+
+ public
+ EmacsWindow (short handle, final EmacsWindow parent, int x, int y,
+ int width, int height, boolean overrideRedirect)
+ {
+ super (handle);
+
+ rect = new Rect (x, y, x + width, y + height);
+ pointerMap = new SparseArray<Coordinate> ();
+
+ /* Create the view from the context's UI thread. The window is
+ unmapped, so the view is GONE. */
+ view = EmacsService.SERVICE.getEmacsView (this, View.GONE,
+ parent == null);
+ this.parent = parent;
+ this.overrideRedirect = overrideRedirect;
+
+ /* Create the list of children. */
+ children = new ArrayList<EmacsWindow> ();
+
+ if (parent != null)
+ {
+ synchronized (parent.children)
+ {
+ parent.children.add (this);
+ }
+
+ EmacsService.SERVICE.runOnUiThread (new Runnable () {
+ @Override
+ public void
+ run ()
+ {
+ parent.view.addView (view);
+ }
+ });
+ }
+
+ scratchGC = new EmacsGC ((short) 0);
+
+ /* Create the map of input method-committed strings. Keep at most
+ ten strings in the map. */
+
+ eventStrings
+ = new LinkedHashMap<Integer, String> () {
+ @Override
+ protected boolean
+ removeEldestEntry (Map.Entry<Integer, String> entry)
+ {
+ return size () > 10;
+ }
+ };
+
+ dndXPosition = -1;
+ dndYPosition = -1;
+ }
+
+ public void
+ changeWindowBackground (int pixel)
+ {
+ /* scratchGC is used as the argument to a FillRectangles req. */
+ scratchGC.foreground = pixel;
+ scratchGC.markDirty (false);
+
+ /* Make the background known to the view as well. */
+ background = pixel;
+ }
+
+ public synchronized Rect
+ getGeometry ()
+ {
+ return new Rect (rect);
+ }
+
+ @Override
+ public synchronized void
+ destroyHandle () throws IllegalStateException
+ {
+ if (parent != null)
+ {
+ synchronized (parent.children)
+ {
+ parent.children.remove (this);
+ }
+ }
+
+ EmacsActivity.invalidateFocus (4);
+
+ if (!children.isEmpty ())
+ throw new IllegalStateException ("Trying to destroy window with "
+ + "children!");
+
+ /* Remove the view from its parent and make it invisible. */
+ EmacsService.SERVICE.runOnUiThread (new Runnable () {
+ public void
+ run ()
+ {
+ ViewManager parent;
+ EmacsWindowAttachmentManager manager;
+
+ if (EmacsActivity.focusedWindow == EmacsWindow.this)
+ EmacsActivity.focusedWindow = null;
+
+ manager = EmacsWindowAttachmentManager.MANAGER;
+ view.setVisibility (View.GONE);
+
+ /* If the window manager is set, use that instead. */
+ if (windowManager != null)
+ parent = windowManager;
+ else
+ parent = (ViewManager) view.getParent ();
+ windowManager = null;
+
+ if (parent != null)
+ parent.removeView (view);
+
+ manager.detachWindow (EmacsWindow.this);
+ }
+ });
+
+ super.destroyHandle ();
+ }
+
+ public void
+ setConsumer (EmacsWindowAttachmentManager.WindowConsumer consumer)
+ {
+ attached = consumer;
+ }
+
+ public EmacsWindowAttachmentManager.WindowConsumer
+ getAttachedConsumer ()
+ {
+ return attached;
+ }
+
+ public synchronized long
+ viewLayout (int left, int top, int right, int bottom)
+ {
+ int rectWidth, rectHeight;
+
+ rect.left = left;
+ rect.top = top;
+ rect.right = right;
+ rect.bottom = bottom;
+
+ rectWidth = right - left;
+ rectHeight = bottom - top;
+
+ /* If parent is null, use xPosition and yPosition instead of the
+ geometry rectangle positions. */
+
+ if (parent == null)
+ {
+ left = xPosition;
+ top = yPosition;
+ }
+
+ return EmacsNative.sendConfigureNotify (this.handle,
+ System.currentTimeMillis (),
+ left, top, rectWidth,
+ rectHeight);
+ }
+
+ public void
+ requestViewLayout ()
+ {
+ view.explicitlyDirtyBitmap ();
+
+ EmacsService.SERVICE.runOnUiThread (new Runnable () {
+ @Override
+ public void
+ run ()
+ {
+ if (overrideRedirect)
+ /* Set the layout parameters again. */
+ view.setLayoutParams (getWindowLayoutParams ());
+
+ view.mustReportLayout = true;
+ view.requestLayout ();
+ }
+ });
+ }
+
+ public synchronized void
+ resizeWindow (int width, int height)
+ {
+ rect.right = rect.left + width;
+ rect.bottom = rect.top + height;
+
+ requestViewLayout ();
+ }
+
+ public synchronized void
+ moveWindow (int x, int y)
+ {
+ int width, height;
+
+ width = rect.width ();
+ height = rect.height ();
+
+ rect.left = x;
+ rect.top = y;
+ rect.right = x + width;
+ rect.bottom = y + height;
+
+ requestViewLayout ();
+ }
+
+ /* Return WM layout parameters for an override redirect window with
+ the geometry provided here. */
+
+ private WindowManager.LayoutParams
+ getWindowLayoutParams ()
+ {
+ WindowManager.LayoutParams params;
+ int flags, type;
+ Rect rect;
+
+ flags = 0;
+ rect = getGeometry ();
+ flags |= WindowManager.LayoutParams.FLAG_NOT_FOCUSABLE;
+ flags |= WindowManager.LayoutParams.FLAG_NOT_TOUCHABLE;
+ type = WindowManager.LayoutParams.TYPE_APPLICATION_ATTACHED_DIALOG;
+
+ params
+ = new WindowManager.LayoutParams (rect.width (), rect.height (),
+ rect.left, rect.top,
+ type, flags,
+ PixelFormat.RGBA_8888);
+ params.gravity = Gravity.TOP | Gravity.LEFT;
+ return params;
+ }
+
+ private Activity
+ findSuitableActivityContext ()
+ {
+ /* Find a recently focused activity. */
+ if (!EmacsActivity.focusedActivities.isEmpty ())
+ return EmacsActivity.focusedActivities.get (0);
+
+ /* Resort to the last activity to be focused. */
+ return EmacsActivity.lastFocusedActivity;
+ }
+
+ public synchronized void
+ mapWindow ()
+ {
+ final int width, height;
+
+ if (isMapped)
+ return;
+
+ isMapped = true;
+ width = rect.width ();
+ height = rect.height ();
+
+ if (parent == null)
+ {
+ EmacsService.SERVICE.runOnUiThread (new Runnable () {
+ @Override
+ public void
+ run ()
+ {
+ EmacsWindowAttachmentManager manager;
+ WindowManager windowManager;
+ Activity ctx;
+ Object tem;
+ WindowManager.LayoutParams params;
+
+ /* Make the view visible, first of all. */
+ view.setVisibility (View.VISIBLE);
+
+ if (!overrideRedirect)
+ {
+ manager = EmacsWindowAttachmentManager.MANAGER;
+
+ /* If parent is the root window, notice that there are new
+ children available for interested activities to pick
+ up. */
+ manager.registerWindow (EmacsWindow.this);
+
+ if (!getDontFocusOnMap ())
+ /* Eventually this should check no-focus-on-map. */
+ view.requestFocus ();
+ }
+ else
+ {
+ /* But if the window is an override-redirect window,
+ then:
+
+ - Find an activity that is currently active.
+
+ - Map the window as a panel on top of that
+ activity using the system window manager. */
+
+ ctx = findSuitableActivityContext ();
+
+ if (ctx == null)
+ {
+ Log.w (TAG, "failed to attach override-redirect window"
+ + " for want of activity");
+ return;
+ }
+
+ tem = ctx.getSystemService (Context.WINDOW_SERVICE);
+ windowManager = (WindowManager) tem;
+
+ /* Calculate layout parameters and propagate the
+ activity's token into it. */
+
+ params = getWindowLayoutParams ();
+ params.token = (ctx.findViewById (android.R.id.content)
+ .getWindowToken ());
+ view.setLayoutParams (params);
+
+ /* Attach the view. */
+ try
+ {
+ view.prepareForLayout (width, height);
+ windowManager.addView (view, params);
+
+ /* Record the window manager being used in the
+ EmacsWindow object. */
+ EmacsWindow.this.windowManager = windowManager;
+ }
+ catch (Exception e)
+ {
+ Log.w (TAG,
+ "failed to attach override-redirect window, " + e);
+ }
+ }
+ }
+ });
+ }
+ else
+ {
+ /* Do the same thing as above, but don't register this
+ window. */
+ EmacsService.SERVICE.runOnUiThread (new Runnable () {
+ @Override
+ public void
+ run ()
+ {
+ /* Prior to mapping the view, set its measuredWidth and
+ measuredHeight to some reasonable value, in order to
+ avoid excessive bitmap dirtying. */
+
+ view.prepareForLayout (width, height);
+ view.setVisibility (View.VISIBLE);
+
+ if (!getDontFocusOnMap ())
+ view.requestFocus ();
+ }
+ });
+ }
+ }
+
+ public synchronized void
+ unmapWindow ()
+ {
+ if (!isMapped)
+ return;
+
+ isMapped = false;
+
+ view.post (new Runnable () {
+ @Override
+ public void
+ run ()
+ {
+ EmacsWindowAttachmentManager manager;
+
+ manager = EmacsWindowAttachmentManager.MANAGER;
+
+ view.setVisibility (View.GONE);
+
+ /* Detach the view from the window manager if possible. */
+ if (windowManager != null)
+ windowManager.removeView (view);
+ windowManager = null;
+
+ /* Now that the window is unmapped, unregister it as
+ well. */
+ manager.detachWindow (EmacsWindow.this);
+ }
+ });
+ }
+
+ @Override
+ public Canvas
+ lockCanvas (EmacsGC gc)
+ {
+ return view.getCanvas (gc);
+ }
+
+ @Override
+ public void
+ damageRect (Rect damageRect)
+ {
+ view.damageRect (damageRect.left,
+ damageRect.top,
+ damageRect.right,
+ damageRect.bottom);
+ }
+
+ @Override
+ public void
+ damageRect (int left, int top, int right, int bottom)
+ {
+ view.damageRect (left, top, right, bottom);
+ }
+
+ public void
+ swapBuffers ()
+ {
+ view.swapBuffers ();
+ }
+
+ public void
+ clearWindow ()
+ {
+ EmacsService.SERVICE.fillRectangle (this, scratchGC,
+ 0, 0, rect.width (),
+ rect.height ());
+ }
+
+ public void
+ clearArea (int x, int y, int width, int height)
+ {
+ EmacsService.SERVICE.fillRectangle (this, scratchGC,
+ x, y, width, height);
+ }
+
+ @Override
+ public Bitmap
+ getBitmap ()
+ {
+ return view.getBitmap ();
+ }
+
+ /* event.getCharacters is used because older input methods still
+ require it. */
+ @SuppressWarnings ("deprecation")
+ public int
+ getEventUnicodeChar (KeyEvent event, int state)
+ {
+ String characters;
+
+ if (event.getUnicodeChar (state) != 0)
+ return event.getUnicodeChar (state);
+
+ characters = event.getCharacters ();
+
+ if (characters != null && characters.length () == 1)
+ return characters.charAt (0);
+
+ return characters == null ? 0 : -1;
+ }
+
+ public void
+ saveUnicodeString (int serial, String string)
+ {
+ eventStrings.put (serial, string);
+ }
+
+
+
+ /* Return the modifier mask associated with the specified keyboard
+ input EVENT. Replace bits corresponding to Left or Right keys
+ with their corresponding general modifier bits. */
+
+ public static int
+ eventModifiers (KeyEvent event)
+ {
+ int state;
+
+ if (Build.VERSION.SDK_INT >= Build.VERSION_CODES.HONEYCOMB_MR2)
+ state = event.getModifiers ();
+ else
+ {
+ /* Replace this with getMetaState and manual
+ normalization. */
+ state = event.getMetaState ();
+
+ /* Normalize the state by setting the generic modifier bit if
+ either a left or right modifier is pressed. */
+
+ if ((state & KeyEvent.META_ALT_LEFT_ON) != 0
+ || (state & KeyEvent.META_ALT_RIGHT_ON) != 0)
+ state |= KeyEvent.META_ALT_MASK;
+
+ if ((state & KeyEvent.META_CTRL_LEFT_ON) != 0
+ || (state & KeyEvent.META_CTRL_RIGHT_ON) != 0)
+ state |= KeyEvent.META_CTRL_MASK;
+ }
+
+ return state;
+ }
+
+ /* event.getCharacters is used because older input methods still
+ require it. */
+ @SuppressWarnings ("deprecation")
+ public void
+ onKeyDown (int keyCode, KeyEvent event)
+ {
+ int state, state_1, extra_ignored;
+ long serial;
+ String characters;
+
+ if (keyCode == KeyEvent.KEYCODE_BACK)
+ {
+ /* New Android systems display Back navigation buttons on a
+ row of virtual buttons at the bottom of the screen. These
+ buttons function much as physical buttons do, in that key
+ down events are produced when a finger taps them, even if
+ the finger is not ultimately released after the OS's
+ gesture navigation is activated.
+
+ Deliver onKeyDown events in onKeyUp instead, so as not to
+ navigate backwards during gesture navigation. */
+
+ return;
+ }
+
+ state = eventModifiers (event);
+
+ /* Num Lock, Scroll Lock and Meta aren't supported by systems older
+ than Android 3.0. */
+
+ if (Build.VERSION.SDK_INT >= Build.VERSION_CODES.HONEYCOMB)
+ extra_ignored = (KeyEvent.META_NUM_LOCK_ON
+ | KeyEvent.META_SCROLL_LOCK_ON
+ | KeyEvent.META_META_MASK);
+ else
+ extra_ignored = 0;
+
+ /* Ignore meta-state understood by Emacs for now, or key presses
+ such as Ctrl+C and Meta+C will not be recognized as ASCII key
+ press events. */
+
+ state_1
+ = state & ~(KeyEvent.META_ALT_MASK | KeyEvent.META_CTRL_MASK
+ | KeyEvent.META_SYM_ON | extra_ignored);
+
+ /* There's no distinction between Right Alt and Alt Gr on Android,
+ so restore META_ALT_RIGHT_ON if set in state to enable composing
+ characters. (bug#69321) */
+
+ if ((state & KeyEvent.META_ALT_RIGHT_ON) != 0)
+ {
+ state_1 |= KeyEvent.META_ALT_ON | KeyEvent.META_ALT_RIGHT_ON;
+
+ /* If Alt is also not depressed, remove its bit from the mask
+ reported to Emacs. */
+ if ((state & KeyEvent.META_ALT_LEFT_ON) == 0)
+ state &= ~KeyEvent.META_ALT_MASK;
+ }
+
+ synchronized (eventStrings)
+ {
+ serial
+ = EmacsNative.sendKeyPress (this.handle,
+ event.getEventTime (),
+ state, keyCode,
+ getEventUnicodeChar (event,
+ state_1));
+
+ characters = event.getCharacters ();
+
+ if (characters != null && characters.length () > 1)
+ saveUnicodeString ((int) serial, characters);
+ }
+ }
+
+ public void
+ onKeyUp (int keyCode, KeyEvent event)
+ {
+ int state, state_1, unicode_char, extra_ignored;
+ long time;
+
+ /* Compute the event's modifier mask. */
+ state = eventModifiers (event);
+
+ /* Num Lock, Scroll Lock and Meta aren't supported by systems older
+ than Android 3.0. */
+
+ if (Build.VERSION.SDK_INT >= Build.VERSION_CODES.HONEYCOMB)
+ extra_ignored = (KeyEvent.META_NUM_LOCK_ON
+ | KeyEvent.META_SCROLL_LOCK_ON
+ | KeyEvent.META_META_MASK);
+ else
+ extra_ignored = 0;
+
+ /* Ignore meta-state understood by Emacs for now, or key presses
+ such as Ctrl+C and Meta+C will not be recognized as ASCII key
+ press events. */
+
+ state_1
+ = state & ~(KeyEvent.META_ALT_MASK | KeyEvent.META_CTRL_MASK
+ | KeyEvent.META_SYM_ON | extra_ignored);
+
+ /* There's no distinction between Right Alt and Alt Gr on Android,
+ so restore META_ALT_RIGHT_ON if set in state to enable composing
+ characters. */
+
+ if ((state & KeyEvent.META_ALT_RIGHT_ON) != 0)
+ {
+ state_1 |= KeyEvent.META_ALT_ON | KeyEvent.META_ALT_RIGHT_ON;
+
+ /* If Alt is also not depressed, remove its bit from the mask
+ reported to Emacs. */
+ if ((state & KeyEvent.META_ALT_LEFT_ON) == 0)
+ state &= ~KeyEvent.META_ALT_MASK;
+ }
+
+ unicode_char = getEventUnicodeChar (event, state_1);
+
+ if (keyCode == KeyEvent.KEYCODE_BACK)
+ {
+ /* If the key press's been canceled, return immediately. */
+
+ if ((event.getFlags () & KeyEvent.FLAG_CANCELED) != 0)
+ return;
+
+ EmacsNative.sendKeyPress (this.handle, event.getEventTime (),
+ state, keyCode, unicode_char);
+ }
+
+ EmacsNative.sendKeyRelease (this.handle, event.getEventTime (),
+ state, keyCode, unicode_char);
+
+ if (keyCode == KeyEvent.KEYCODE_VOLUME_DOWN)
+ {
+ /* Check if this volume down press should quit Emacs.
+ Most Android devices have no physical keyboard, so it
+ is unreasonably hard to press C-g. */
+
+ time = event.getEventTime ();
+
+ if (time - lastVolumeButtonRelease < 350)
+ EmacsNative.quit ();
+
+ lastVolumeButtonRelease = time;
+ }
+ }
+
+ public void
+ onFocusChanged (boolean gainFocus)
+ {
+ EmacsActivity.invalidateFocus (gainFocus ? 6 : 5);
+ }
+
+ /* Notice that the activity has been detached or destroyed.
+
+ ISFINISHING is set if the activity is not the main activity, or
+ if the activity was not destroyed in response to explicit user
+ action. */
+
+ public void
+ onActivityDetached (boolean isFinishing)
+ {
+ /* Destroy the associated frame when the activity is detached in
+ response to explicit user action. */
+
+ if (isFinishing)
+ EmacsNative.sendWindowAction (this.handle, 0);
+ }
+
+
+
+ /* Mouse and touch event handling.
+
+ Android does not conceptually distinguish between mouse events
+ (those coming from a device whose movement affects the on-screen
+ pointer image) and touch screen events. Each click or touch
+ starts a single pointer gesture sequence, and subsequent motion
+ of the device will result in updates being reported relative to
+ that sequence until the mouse button or touch is released.
+
+ When a touch, click, or pointer motion takes place, several kinds
+ of event can be sent:
+
+ ACTION_DOWN or ACTION_POINTER_DOWN is sent with a new coordinate
+ and an associated ``pointer ID'' identifying the event and its
+ gesture sequence when a click or touch takes place. Emacs is
+ responsible for recording both the position and pointer ID of
+ this click for the purpose of determining future changes to its
+ position.
+
+ ACTION_UP or ACTION_POINTER_UP is sent with a pointer ID when the
+ click associated with a previous ACTION_DOWN event is released.
+
+ ACTION_CANCEL (or ACTION_POINTER_UP with FLAG_CANCELED) is sent
+ if a similar situation transpires: the window system has chosen
+ to grab the click, and future changes to its position will no
+ longer be reported to Emacs.
+
+ ACTION_MOVE is sent if a coordinate tied to a click that has not
+ been released changes. Emacs processes this event by comparing
+ each of the coordinates within the event with its recollection of
+ those contained within prior ACTION_DOWN and ACTION_MOVE events;
+ the pointer ID of the differing coordinate is then reported
+ within a touch or pointer motion event along with its new
+ position.
+
+ The events described above are all sent for both touch and mouse
+ click events. Determining whether an ACTION_DOWN event is
+ associated with a button event is performed by inspecting the
+ mouse button state associated with that event. If it contains
+ any mouse buttons that were not contained in the button state at
+ the time of the last ACTION_DOWN or ACTION_UP event, the
+ coordinate contained within is assumed to be a mouse click,
+ leading to it and associated motion or ACTION_UP events being
+ reported as mouse button or motion events. Otherwise, those
+ events are reported as touch screen events, with the touch ID set
+ to the pointer ID.
+
+ In addition to the events illustrated above, Android also sends
+ several other types of event upon select types of activity from a
+ mouse device:
+
+ ACTION_HOVER_MOVE is sent with the coordinate of the mouse
+ pointer if it moves above a frame prior to any click taking
+ place. Emacs sends a mouse motion event containing the
+ coordinate.
+
+ ACTION_HOVER_ENTER and ACTION_HOVER_LEAVE are respectively sent
+ when the mouse pointer enters and leaves a frame. Moreover,
+ ACTION_HOVER_LEAVE events are sent immediately before an
+ ACTION_DOWN event associated with a mouse click. These
+ extraneous events are distinct in that their button states always
+ contain an additional button compared to the button state
+ recorded at the time of the last ACTION_UP event.
+
+ On Android 6.0 and later, ACTION_BUTTON_PRESS is sent with the
+ coordinate of the mouse pointer if a mouse click occurs,
+ alongside a ACTION_DOWN event. ACTION_BUTTON_RELEASE is sent
+ with the same information upon a mouse click being released, also
+ accompanying an ACTION_UP event.
+
+ However, both types of button events are implemented in a buggy
+ fashion and cannot be used to report button events. */
+
+ /* Look through the button state to determine what button EVENT was
+ generated from. DOWN is true if EVENT is a button press event,
+ false otherwise. Value is the X number of the button. */
+
+ private int
+ whatButtonWasIt (MotionEvent event, boolean down)
+ {
+ int eventState, notIn;
+
+ /* Obtain the new button state. */
+ eventState = event.getButtonState ();
+
+ /* Compute which button is now set or no longer set. */
+
+ notIn = (down ? eventState & ~lastButtonState
+ : lastButtonState & ~eventState);
+
+ if ((notIn & (MotionEvent.BUTTON_PRIMARY
+ | MotionEvent.BUTTON_SECONDARY
+ | MotionEvent.BUTTON_TERTIARY)) == 0)
+ /* No buttons have been pressed, so this is a touch event. */
+ return 0;
+
+ if ((notIn & MotionEvent.BUTTON_PRIMARY) != 0)
+ return 1;
+
+ if ((notIn & MotionEvent.BUTTON_SECONDARY) != 0)
+ return 3;
+
+ if ((notIn & MotionEvent.BUTTON_TERTIARY) != 0)
+ return 2;
+
+ /* Buttons 4, 5, 6 and 7 are actually scroll wheels under X.
+ Thus, report additional buttons starting at 8. */
+
+ if ((notIn & MotionEvent.BUTTON_BACK) != 0)
+ return 8;
+
+ if ((notIn & MotionEvent.BUTTON_FORWARD) != 0)
+ return 9;
+
+ /* Report stylus events as touch screen events. */
+
+ if ((notIn & MotionEvent.BUTTON_STYLUS_PRIMARY) != 0)
+ return 0;
+
+ if ((notIn & MotionEvent.BUTTON_STYLUS_SECONDARY) != 0)
+ return 0;
+
+ /* Not a real value. */
+ return 11;
+ }
+
+ /* Return the mouse button associated with the specified ACTION_DOWN
+ or ACTION_POINTER_DOWN EVENT.
+
+ Value is 0 if no mouse button was pressed, or the X number of
+ that mouse button. */
+
+ private int
+ buttonForEvent (MotionEvent event)
+ {
+ /* ICS and earlier don't support true mouse button events, so
+ treat all down events as touch screen events. */
+
+ if (Build.VERSION.SDK_INT
+ < Build.VERSION_CODES.ICE_CREAM_SANDWICH)
+ return 0;
+
+ return whatButtonWasIt (event, true);
+ }
+
+ /* Return the coordinate object associated with the specified
+ EVENT, or null if it is not known. */
+
+ private Coordinate
+ figureChange (MotionEvent event)
+ {
+ int i, truncatedX, truncatedY, pointerIndex, pointerID, count;
+ Coordinate coordinate;
+
+ /* Initialize this variable now. */
+ coordinate = null;
+
+ switch (event.getActionMasked ())
+ {
+ case MotionEvent.ACTION_DOWN:
+ /* Primary pointer pressed with index 0. */
+
+ pointerID = event.getPointerId (0);
+ coordinate = new Coordinate ((int) event.getX (0),
+ (int) event.getY (0),
+ buttonForEvent (event),
+ pointerID);
+ pointerMap.put (pointerID, coordinate);
+ break;
+
+ case MotionEvent.ACTION_UP:
+ case MotionEvent.ACTION_CANCEL:
+ /* Primary pointer released with index 0. */
+ pointerID = event.getPointerId (0);
+ coordinate = pointerMap.get (pointerID);
+ pointerMap.delete (pointerID);
+ break;
+
+ case MotionEvent.ACTION_POINTER_DOWN:
+ /* New pointer. Find the pointer ID from the index and place
+ it in the map. */
+ pointerIndex = event.getActionIndex ();
+ pointerID = event.getPointerId (pointerIndex);
+ coordinate = new Coordinate ((int) event.getX (pointerIndex),
+ (int) event.getY (pointerIndex),
+ buttonForEvent (event),
+ pointerID);
+ pointerMap.put (pointerID, coordinate);
+ break;
+
+ case MotionEvent.ACTION_POINTER_UP:
+ /* Pointer removed. Remove it from the map. */
+ pointerIndex = event.getActionIndex ();
+ pointerID = event.getPointerId (pointerIndex);
+ coordinate = pointerMap.get (pointerID);
+ pointerMap.delete (pointerID);
+ break;
+
+ default:
+
+ /* Loop through each pointer in the event. */
+
+ count = event.getPointerCount ();
+ for (i = 0; i < count; ++i)
+ {
+ pointerID = event.getPointerId (i);
+
+ /* Look up that pointer in the map. */
+ coordinate = pointerMap.get (pointerID);
+
+ if (coordinate != null)
+ {
+ /* See if coordinates have changed. */
+ truncatedX = (int) event.getX (i);
+ truncatedY = (int) event.getY (i);
+
+ if (truncatedX != coordinate.x
+ || truncatedY != coordinate.y)
+ {
+ /* The pointer changed. Update the coordinate and
+ break out of the loop. */
+ coordinate.x = truncatedX;
+ coordinate.y = truncatedY;
+
+ break;
+ }
+ }
+ }
+
+ /* Set coordinate to NULL if the loop failed to find any
+ matching pointer. */
+
+ if (i == count)
+ coordinate = null;
+ }
+
+ /* Return the pointer ID. */
+ return coordinate;
+ }
+
+ /* Return the modifier mask associated with the specified motion
+ EVENT. Replace bits corresponding to Left or Right keys with
+ their corresponding general modifier bits. */
+
+ private int
+ motionEventModifiers (MotionEvent event)
+ {
+ int state;
+
+ state = event.getMetaState ();
+
+ /* Normalize the state by setting the generic modifier bit if
+ either a left or right modifier is pressed. */
+
+ if ((state & KeyEvent.META_ALT_LEFT_ON) != 0
+ || (state & KeyEvent.META_ALT_RIGHT_ON) != 0)
+ state |= KeyEvent.META_ALT_MASK;
+
+ if ((state & KeyEvent.META_CTRL_LEFT_ON) != 0
+ || (state & KeyEvent.META_CTRL_RIGHT_ON) != 0)
+ state |= KeyEvent.META_CTRL_MASK;
+
+ return state;
+ }
+
+ /* Process a single ACTION_DOWN, ACTION_POINTER_DOWN, ACTION_UP,
+ ACTION_POINTER_UP, ACTION_CANCEL, or ACTION_MOVE event.
+
+ Ascertain which coordinate changed and send an appropriate mouse
+ or touch screen event. */
+
+ private void
+ motionEvent (MotionEvent event)
+ {
+ Coordinate coordinate;
+ int modifiers;
+ long time;
+
+ /* Find data associated with this event's pointer. Namely, its
+ current location, whether or not a change has taken place, and
+ whether or not it is a button event. */
+
+ coordinate = figureChange (event);
+
+ if (coordinate == null)
+ return;
+
+ time = event.getEventTime ();
+
+ if (coordinate.button != 0)
+ {
+ /* This event is tied to a mouse click, so report mouse motion
+ and button events. */
+
+ modifiers = motionEventModifiers (event);
+
+ switch (event.getAction ())
+ {
+ case MotionEvent.ACTION_POINTER_DOWN:
+ case MotionEvent.ACTION_DOWN:
+ EmacsNative.sendButtonPress (this.handle, coordinate.x,
+ coordinate.y, time, modifiers,
+ coordinate.button);
+ break;
+
+ case MotionEvent.ACTION_POINTER_UP:
+ case MotionEvent.ACTION_UP:
+ case MotionEvent.ACTION_CANCEL:
+ EmacsNative.sendButtonRelease (this.handle, coordinate.x,
+ coordinate.y, time, modifiers,
+ coordinate.button);
+ break;
+
+ case MotionEvent.ACTION_MOVE:
+ EmacsNative.sendMotionNotify (this.handle, coordinate.x,
+ coordinate.y, time);
+ break;
+ }
+ }
+ else
+ {
+ /* This event is a touch event, and the touch ID is the
+ pointer ID. */
+
+ switch (event.getActionMasked ())
+ {
+ case MotionEvent.ACTION_DOWN:
+ case MotionEvent.ACTION_POINTER_DOWN:
+ /* Touch down event. */
+ EmacsNative.sendTouchDown (this.handle, coordinate.x,
+ coordinate.y, time,
+ coordinate.id, 0);
+ break;
+
+ case MotionEvent.ACTION_UP:
+ case MotionEvent.ACTION_POINTER_UP:
+ /* Touch up event. */
+ EmacsNative.sendTouchUp (this.handle, coordinate.x,
+ coordinate.y, time,
+ coordinate.id, 0);
+ break;
+
+ case MotionEvent.ACTION_CANCEL:
+ /* Touch sequence cancellation event. */
+ EmacsNative.sendTouchUp (this.handle, coordinate.x,
+ coordinate.y, time,
+ coordinate.id,
+ 1 /* ANDROID_TOUCH_SEQUENCE_CANCELED */);
+ break;
+
+ case MotionEvent.ACTION_MOVE:
+ /* Pointer motion event. */
+ EmacsNative.sendTouchMove (this.handle, coordinate.x,
+ coordinate.y, time,
+ coordinate.id, 0);
+ break;
+ }
+ }
+
+ if (Build.VERSION.SDK_INT
+ < Build.VERSION_CODES.ICE_CREAM_SANDWICH)
+ return;
+
+ /* Now update the button state. */
+ lastButtonState = event.getButtonState ();
+ return;
+ }
+
+ public boolean
+ onTouchEvent (MotionEvent event)
+ {
+ switch (event.getActionMasked ())
+ {
+ case MotionEvent.ACTION_DOWN:
+ case MotionEvent.ACTION_POINTER_DOWN:
+ case MotionEvent.ACTION_UP:
+ case MotionEvent.ACTION_POINTER_UP:
+ case MotionEvent.ACTION_CANCEL:
+ case MotionEvent.ACTION_MOVE:
+ motionEvent (event);
+ return true;
+ }
+
+ return false;
+ }
+
+ public boolean
+ onGenericMotionEvent (MotionEvent event)
+ {
+ switch (event.getAction ())
+ {
+ case MotionEvent.ACTION_HOVER_ENTER:
+ EmacsNative.sendEnterNotify (this.handle, (int) event.getX (),
+ (int) event.getY (),
+ event.getEventTime ());
+ return true;
+
+ case MotionEvent.ACTION_HOVER_MOVE:
+ EmacsNative.sendMotionNotify (this.handle, (int) event.getX (),
+ (int) event.getY (),
+ event.getEventTime ());
+ return true;
+
+ case MotionEvent.ACTION_HOVER_EXIT:
+
+ /* If the exit event comes from a button press, its button
+ state will have extra bits compared to the last known
+ button state. Since the exit event will interfere with
+ tool bar button presses, ignore such splurious events. */
+
+ if ((event.getButtonState () & ~lastButtonState) == 0)
+ EmacsNative.sendLeaveNotify (this.handle, (int) event.getX (),
+ (int) event.getY (),
+ event.getEventTime ());
+
+ return true;
+
+ case MotionEvent.ACTION_DOWN:
+ case MotionEvent.ACTION_POINTER_DOWN:
+ case MotionEvent.ACTION_UP:
+ case MotionEvent.ACTION_POINTER_UP:
+ case MotionEvent.ACTION_CANCEL:
+ case MotionEvent.ACTION_MOVE:
+ /* MotionEvents may either be sent to onGenericMotionEvent or
+ onTouchEvent depending on if Android thinks it is a mouse
+ event or not, but we detect them ourselves. */
+ motionEvent (event);
+ return true;
+
+ case MotionEvent.ACTION_SCROLL:
+ /* Send a scroll event with the specified deltas. */
+ EmacsNative.sendWheel (this.handle, (int) event.getX (),
+ (int) event.getY (),
+ event.getEventTime (),
+ motionEventModifiers (event),
+ event.getAxisValue (MotionEvent.AXIS_HSCROLL),
+ event.getAxisValue (MotionEvent.AXIS_VSCROLL));
+ return true;
+ }
+
+ return false;
+ }
+
+
+
+ public synchronized void
+ reparentTo (final EmacsWindow otherWindow, int x, int y)
+ {
+ int width, height;
+
+ /* Reparent this window to the other window. */
+
+ if (parent != null)
+ {
+ synchronized (parent.children)
+ {
+ parent.children.remove (this);
+ }
+ }
+
+ if (otherWindow != null)
+ {
+ synchronized (otherWindow.children)
+ {
+ otherWindow.children.add (this);
+ }
+ }
+
+ parent = otherWindow;
+
+ /* Move this window to the new location. */
+ width = rect.width ();
+ height = rect.height ();
+ rect.left = x;
+ rect.top = y;
+ rect.right = x + width;
+ rect.bottom = y + height;
+
+ /* Now do the work necessary on the UI thread to reparent the
+ window. */
+ EmacsService.SERVICE.runOnUiThread (new Runnable () {
+ @Override
+ public void
+ run ()
+ {
+ EmacsWindowAttachmentManager manager;
+ ViewManager parent;
+
+ /* First, detach this window if necessary. */
+ manager = EmacsWindowAttachmentManager.MANAGER;
+ manager.detachWindow (EmacsWindow.this);
+
+ /* Also unparent this view. */
+
+ /* If the window manager is set, use that instead. */
+ if (windowManager != null)
+ parent = windowManager;
+ else
+ parent = (ViewManager) view.getParent ();
+ windowManager = null;
+
+ if (parent != null)
+ parent.removeView (view);
+
+ /* Next, either add this window as a child of the new
+ parent's view, or make it available again. */
+ if (otherWindow != null)
+ otherWindow.view.addView (view);
+ else if (EmacsWindow.this.isMapped)
+ manager.registerWindow (EmacsWindow.this);
+
+ /* Request relayout. */
+ view.requestLayout ();
+ }
+ });
+ }
+
+ public void
+ makeInputFocus (long time)
+ {
+ /* TIME is currently ignored. Request the input focus now. */
+
+ EmacsService.SERVICE.runOnUiThread (new Runnable () {
+ @Override
+ public void
+ run ()
+ {
+ view.requestFocus ();
+ }
+ });
+ }
+
+ public synchronized void
+ raise ()
+ {
+ /* This does nothing here. */
+ if (parent == null)
+ return;
+
+ synchronized (parent.children)
+ {
+ /* Remove and add this view again. */
+ parent.children.remove (this);
+ parent.children.add (this);
+ }
+
+ /* Request a relayout. */
+ EmacsService.SERVICE.runOnUiThread (new Runnable () {
+ @Override
+ public void
+ run ()
+ {
+ view.raise ();
+ }
+ });
+ }
+
+ public synchronized void
+ lower ()
+ {
+ /* This does nothing here. */
+ if (parent == null)
+ return;
+
+ synchronized (parent.children)
+ {
+ /* Remove and add this view again. */
+ parent.children.remove (this);
+ parent.children.add (this);
+ }
+
+ /* Request a relayout. */
+ EmacsService.SERVICE.runOnUiThread (new Runnable () {
+ @Override
+ public void
+ run ()
+ {
+ view.lower ();
+ }
+ });
+ }
+
+ public synchronized void
+ reconfigure (final EmacsWindow window, final int stackMode)
+ {
+ ListIterator<EmacsWindow> iterator;
+ EmacsWindow object;
+
+ /* This does nothing here. */
+ if (parent == null)
+ return;
+
+ /* If window is NULL, call lower or upper subject to
+ stackMode. */
+
+ if (window == null)
+ {
+ if (stackMode == 1) /* ANDROID_BELOW */
+ lower ();
+ else
+ raise ();
+
+ return;
+ }
+
+ /* Otherwise, if window.parent is distinct from this, return. */
+ if (window.parent != this.parent)
+ return;
+
+ /* Synchronize with the parent's child list. Iterate over each
+ item until WINDOW is encountered, before moving this window to
+ the location prescribed by STACKMODE. */
+
+ synchronized (parent.children)
+ {
+ /* Remove this window from parent.children, for it will be
+ reinserted before or after WINDOW. */
+ parent.children.remove (this);
+
+ /* Create an iterator. */
+ iterator = parent.children.listIterator ();
+
+ while (iterator.hasNext ())
+ {
+ object = iterator.next ();
+
+ if (object == window)
+ {
+ /* Now place this before or after the cursor of the
+ iterator. */
+
+ if (stackMode == 0) /* ANDROID_ABOVE */
+ iterator.add (this);
+ else
+ {
+ iterator.previous ();
+ iterator.add (this);
+ }
+
+ /* Effect the same adjustment upon the view
+ hierarchy. */
+
+ EmacsService.SERVICE.runOnUiThread (new Runnable () {
+ @Override
+ public void
+ run ()
+ {
+ if (stackMode == 0)
+ view.moveAbove (window.view);
+ else
+ view.moveBelow (window.view);
+ }
+ });
+ }
+ }
+
+ /* parent.children does not list WINDOW, which should never
+ transpire. */
+ EmacsNative.emacsAbort ();
+ }
+ }
+
+ public synchronized int[]
+ getWindowGeometry ()
+ {
+ int[] array;
+
+ array = new int[4];
+
+ array[0] = parent != null ? rect.left : xPosition;
+ array[1] = parent != null ? rect.top : yPosition;
+ array[2] = rect.width ();
+ array[3] = rect.height ();
+
+ return array;
+ }
+
+ public void
+ noticeIconified ()
+ {
+ EmacsNative.sendIconified (this.handle);
+ }
+
+ public void
+ noticeDeiconified ()
+ {
+ EmacsNative.sendDeiconified (this.handle);
+ }
+
+ public synchronized void
+ setDontAcceptFocus (final boolean dontAcceptFocus)
+ {
+ /* Update the view's focus state. */
+ EmacsService.SERVICE.runOnUiThread (new Runnable () {
+ @Override
+ public void
+ run ()
+ {
+ view.setFocusable (!dontAcceptFocus);
+ view.setFocusableInTouchMode (!dontAcceptFocus);
+ }
+ });
+ }
+
+ public synchronized void
+ setDontFocusOnMap (final boolean dontFocusOnMap)
+ {
+ this.dontFocusOnMap = dontFocusOnMap;
+ }
+
+ public synchronized boolean
+ getDontFocusOnMap ()
+ {
+ return dontFocusOnMap;
+ }
+
+ public int[]
+ translateCoordinates (int x, int y)
+ {
+ int[] array;
+
+ /* This is supposed to translate coordinates to the root
+ window. */
+ array = new int[2];
+ EmacsService.SERVICE.getLocationOnScreen (view, array);
+
+ /* Now, the coordinates of the view should be in array. Offset X
+ and Y by them. */
+ array[0] += x;
+ array[1] += y;
+
+ /* Return the resulting coordinates. */
+ return array;
+ }
+
+ public void
+ toggleOnScreenKeyboard (final boolean on)
+ {
+ /* Even though InputMethodManager functions are thread safe,
+ `showOnScreenKeyboard' etc must be called from the UI thread in
+ order to avoid deadlocks if the calls happen in tandem with a
+ call to a synchronizing function within
+ `onCreateInputConnection'. */
+
+ EmacsService.SERVICE.runOnUiThread (new Runnable () {
+ @Override
+ public void
+ run ()
+ {
+ if (on)
+ view.showOnScreenKeyboard ();
+ else
+ view.hideOnScreenKeyboard ();
+ }
+ });
+ }
+
+ public String
+ lookupString (int eventSerial)
+ {
+ String any;
+
+ synchronized (eventStrings)
+ {
+ any = eventStrings.remove (eventSerial);
+ }
+
+ return any;
+ }
+
+ public void
+ setFullscreen (final boolean isFullscreen)
+ {
+ EmacsService.SERVICE.runOnUiThread (new Runnable () {
+ @Override
+ public void
+ run ()
+ {
+ EmacsActivity activity;
+ Object tem;
+
+ fullscreen = isFullscreen;
+ tem = getAttachedConsumer ();
+
+ if (tem != null)
+ {
+ activity = (EmacsActivity) tem;
+ activity.syncFullscreenWith (EmacsWindow.this);
+ }
+ }
+ });
+ }
+
+ public void
+ defineCursor (final EmacsCursor cursor)
+ {
+ /* Don't post this message if pointer icons aren't supported. */
+
+ if (Build.VERSION.SDK_INT >= Build.VERSION_CODES.N)
+ view.post (new Runnable () {
+ @Override
+ public void
+ run ()
+ {
+ if (cursor != null)
+ view.setPointerIcon (cursor.icon);
+ else
+ view.setPointerIcon (null);
+ }
+ });
+ }
+
+ public synchronized void
+ notifyContentRectPosition (int xPosition, int yPosition)
+ {
+ Rect geometry;
+
+ /* Ignore these notifications if not a child of the root
+ window. */
+ if (parent != null)
+ return;
+
+ /* xPosition and yPosition are the position of this window
+ relative to the screen. Set them and request a ConfigureNotify
+ event. */
+
+ if (this.xPosition != xPosition
+ || this.yPosition != yPosition)
+ {
+ this.xPosition = xPosition;
+ this.yPosition = yPosition;
+
+ EmacsNative.sendConfigureNotify (this.handle,
+ System.currentTimeMillis (),
+ xPosition, yPosition,
+ rect.width (), rect.height ());
+ }
+ }
+
+
+
+ /* Drag and drop.
+
+ Android 7.0 and later permit multiple windows to be juxtaposed
+ on-screen, consequently enabling items selected from one window
+ to be dragged onto another. Data is transferred across program
+ boundaries using ClipData items, much the same way clipboard data
+ is transferred.
+
+ When an item is dropped, Emacs must ascertain whether the clip
+ data represents plain text, a content URI incorporating a file,
+ or some other data. This is implemented by examining the clip
+ data's ``description'', which enumerates each of the MIME data
+ types the clip data is capable of providing data in.
+
+ If the clip data represents plain text, then that text is copied
+ into a string and conveyed to Lisp code. Otherwise, Emacs must
+ solicit rights to access the URI from the system, absent which it
+ is accounted plain text and reinterpreted as such, to cue the
+ user that something has gone awry.
+
+ Moreover, events are regularly sent as the item being dragged
+ travels across the frame, even if it might not be dropped. This
+ facilitates cursor motion and scrolling in response, as provided
+ by the options dnd-indicate-insertion-point and
+ dnd-scroll-margin. */
+
+ /* Register the drag and drop event EVENT. */
+
+ public boolean
+ onDragEvent (DragEvent event)
+ {
+ ClipData data;
+ ClipDescription description;
+ int i, j, x, y, itemCount;
+ String type, uriString;
+ Uri uri;
+ EmacsActivity activity;
+ StringBuilder builder;
+ ContentResolver resolver;
+
+ x = (int) event.getX ();
+ y = (int) event.getY ();
+
+ switch (event.getAction ())
+ {
+ case DragEvent.ACTION_DRAG_STARTED:
+ /* Return true to continue the drag and drop operation. */
+ return true;
+
+ case DragEvent.ACTION_DRAG_LOCATION:
+ /* Send this drag motion event to Emacs. Skip this when the
+ integer position hasn't changed, for Android sends events
+ even if the movement from the previous position of the drag
+ is less than 1 pixel on either axis. */
+
+ if (x != dndXPosition || y != dndYPosition)
+ {
+ EmacsNative.sendDndDrag (handle, x, y);
+ dndXPosition = x;
+ dndYPosition = y;
+ }
+
+ return true;
+
+ case DragEvent.ACTION_DROP:
+ /* Reset this view's record of the previous drag and drop
+ event's position. */
+ dndXPosition = -1;
+ dndYPosition = -1;
+
+ /* Judge whether this is plain text, or if it's a file URI for
+ which permissions must be requested. */
+
+ data = event.getClipData ();
+ description = data.getDescription ();
+ itemCount = data.getItemCount ();
+
+ /* If there are insufficient items within the clip data,
+ return false. */
+
+ if (itemCount < 1)
+ return false;
+
+ /* Search for plain text data within the clipboard. */
+
+ for (i = 0; i < description.getMimeTypeCount (); ++i)
+ {
+ type = description.getMimeType (i);
+
+ if (type.equals (ClipDescription.MIMETYPE_TEXT_PLAIN)
+ || type.equals (ClipDescription.MIMETYPE_TEXT_HTML))
+ {
+ /* The data being dropped is plain text; encode it
+ suitably and send it to the main thread. */
+ type = (data.getItemAt (0).coerceToText (EmacsService.SERVICE)
+ .toString ());
+ EmacsNative.sendDndText (handle, x, y, type);
+ return true;
+ }
+ else if (type.equals (ClipDescription.MIMETYPE_TEXT_URILIST))
+ {
+ /* The data being dropped is a list of URIs; encode it
+ suitably and send it to the main thread. */
+ type = (data.getItemAt (0).coerceToText (EmacsService.SERVICE)
+ .toString ());
+ EmacsNative.sendDndUri (handle, x, y, type);
+ return true;
+ }
+ }
+
+ /* There's no plain text data within this clipboard item, so
+ each item within should be treated as a content URI
+ designating a file. */
+
+ /* Collect the URIs into a string with each suffixed
+ by newlines, much as in a text/uri-list. */
+ builder = new StringBuilder ();
+
+ for (i = 0; i < itemCount; ++i)
+ {
+ /* If the item dropped is a URI, send it to the
+ main thread. */
+
+ uri = data.getItemAt (i).getUri ();
+
+ /* Attempt to acquire permissions for this URI;
+ failing which, insert it as text instead. */
+
+ if (uri != null
+ && uri.getScheme () != null
+ && uri.getScheme ().equals ("content")
+ && (activity = EmacsActivity.lastFocusedActivity) != null)
+ {
+ if ((activity.requestDragAndDropPermissions (event) == null))
+ uri = null;
+ else
+ {
+ resolver = activity.getContentResolver ();
+
+ /* Substitute a content file name for the URI, if
+ possible. */
+ uriString = EmacsService.buildContentName (uri, resolver);
+
+ if (uriString != null)
+ {
+ builder.append (uriString).append ("\n");
+ continue;
+ }
+ }
+ }
+
+ if (uri != null)
+ builder.append (uri.toString ()).append ("\n");
+ else
+ {
+ /* Treat each URI that Emacs cannot secure
+ permissions for as plain text. */
+ type = (data.getItemAt (i)
+ .coerceToText (EmacsService.SERVICE)
+ .toString ());
+ EmacsNative.sendDndText (handle, x, y, type);
+ }
+ }
+
+ /* Now send each URI to Emacs. */
+
+ if (builder.length () > 0)
+ EmacsNative.sendDndUri (handle, x, y, builder.toString ());
+ return true;
+
+ default:
+ /* Reset this view's record of the previous drag and drop
+ event's position. */
+ dndXPosition = -1;
+ dndYPosition = -1;
+ }
+
+ return true;
+ }
+
+
+
+ /* Miscellaneous functions for debugging graphics code. */
+
+ /* Recreate the activity to which this window is attached, if any.
+ This is nonfunctional on Android 2.3.7 and earlier. */
+
+ public void
+ recreateActivity ()
+ {
+ final EmacsWindowAttachmentManager.WindowConsumer attached;
+
+ attached = this.attached;
+
+ if (Build.VERSION.SDK_INT < Build.VERSION_CODES.HONEYCOMB)
+ return;
+
+ view.post (new Runnable () {
+ @Override
+ public void
+ run ()
+ {
+ if (attached instanceof EmacsActivity)
+ ((EmacsActivity) attached).recreate ();
+ }
+ });
+ }
+};
diff --git a/java/org/gnu/emacs/EmacsWindowAttachmentManager.java b/java/org/gnu/emacs/EmacsWindowAttachmentManager.java
new file mode 100644
index 00000000000..aae4e2ee49b
--- /dev/null
+++ b/java/org/gnu/emacs/EmacsWindowAttachmentManager.java
@@ -0,0 +1,211 @@
+/* Communication module for Android terminals. -*- c-file-style: "GNU" -*-
+
+Copyright (C) 2023-2024 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 <https://www.gnu.org/licenses/>. */
+
+package org.gnu.emacs;
+
+import java.util.ArrayList;
+import java.util.List;
+
+import android.app.ActivityOptions;
+import android.content.Intent;
+import android.os.Build;
+import android.util.Log;
+
+/* Code to paper over the differences in lifecycles between
+ "activities" and windows. There are four interfaces to an instance
+ of this class:
+
+ registerWindowConsumer (WindowConsumer)
+ registerWindow (EmacsWindow)
+ removeWindowConsumer (WindowConsumer)
+ removeWindow (EmacsWindow)
+
+ A WindowConsumer is expected to allow an EmacsWindow to be attached
+ to it, and be created or destroyed.
+
+ Every time a window is created, registerWindow checks the list of
+ window consumers. If a consumer exists and does not currently have
+ a window of its own attached, it gets the new window. Otherwise,
+ the window attachment manager starts a new consumer.
+
+ Every time a consumer is registered, registerWindowConsumer checks
+ the list of available windows. If a window exists and is not
+ currently attached to a consumer, then the consumer gets it.
+
+ Finally, every time a window is removed, the consumer is
+ destroyed. */
+
+public final class EmacsWindowAttachmentManager
+{
+ private final static String TAG = "EmacsWindowAttachmentManager";
+
+ /* The single window attachment manager ``object''. */
+ public static final EmacsWindowAttachmentManager MANAGER;
+
+ static
+ {
+ MANAGER = new EmacsWindowAttachmentManager ();
+ };
+
+ public interface WindowConsumer
+ {
+ public void attachWindow (EmacsWindow window);
+ public EmacsWindow getAttachedWindow ();
+ public void detachWindow ();
+ public void destroy ();
+ };
+
+ /* List of currently attached window consumers. */
+ public List<WindowConsumer> consumers;
+
+ /* List of currently attached windows. */
+ public List<EmacsWindow> windows;
+
+ public
+ EmacsWindowAttachmentManager ()
+ {
+ consumers = new ArrayList<WindowConsumer> ();
+ windows = new ArrayList<EmacsWindow> ();
+ }
+
+ public void
+ registerWindowConsumer (WindowConsumer consumer)
+ {
+ consumers.add (consumer);
+
+ for (EmacsWindow window : windows)
+ {
+ if (window.getAttachedConsumer () == null)
+ {
+ consumer.attachWindow (window);
+ return;
+ }
+ }
+
+ EmacsNative.sendWindowAction ((short) 0, 0);
+ }
+
+ public synchronized void
+ registerWindow (EmacsWindow window)
+ {
+ Intent intent;
+ ActivityOptions options;
+
+ if (windows.contains (window))
+ /* The window is already registered. */
+ return;
+
+ windows.add (window);
+
+ for (WindowConsumer consumer : consumers)
+ {
+ if (consumer.getAttachedWindow () == null)
+ {
+ consumer.attachWindow (window);
+ return;
+ }
+ }
+
+ intent = new Intent (EmacsService.SERVICE,
+ EmacsMultitaskActivity.class);
+
+ intent.addFlags (Intent.FLAG_ACTIVITY_NEW_TASK
+ | Intent.FLAG_ACTIVITY_MULTIPLE_TASK);
+
+ /* Intent.FLAG_ACTIVITY_NEW_DOCUMENT is lamentably unavailable on
+ older systems than Lolipop. */
+ if (Build.VERSION.SDK_INT >= Build.VERSION_CODES.LOLLIPOP)
+ intent.addFlags (Intent.FLAG_ACTIVITY_NEW_DOCUMENT);
+
+ if (Build.VERSION.SDK_INT < Build.VERSION_CODES.N)
+ EmacsService.SERVICE.startActivity (intent);
+ else
+ {
+ /* Specify the desired window size. */
+ options = ActivityOptions.makeBasic ();
+ options.setLaunchBounds (window.getGeometry ());
+ EmacsService.SERVICE.startActivity (intent,
+ options.toBundle ());
+ }
+ }
+
+ public void
+ removeWindowConsumer (WindowConsumer consumer, boolean isFinishing)
+ {
+ EmacsWindow window;
+
+ window = consumer.getAttachedWindow ();
+
+ if (window != null)
+ {
+ consumer.detachWindow ();
+ window.onActivityDetached (isFinishing);
+ }
+
+ consumers.remove (consumer);
+ }
+
+ public synchronized void
+ detachWindow (EmacsWindow window)
+ {
+ WindowConsumer consumer;
+
+ if (window.getAttachedConsumer () != null)
+ {
+ consumer = window.getAttachedConsumer ();
+
+ consumers.remove (consumer);
+ consumer.destroy ();
+ }
+
+ windows.remove (window);
+ }
+
+ public void
+ noticeIconified (WindowConsumer consumer)
+ {
+ EmacsWindow window;
+
+ /* If a window is attached, send the appropriate iconification
+ events. */
+ window = consumer.getAttachedWindow ();
+
+ if (window != null)
+ window.noticeIconified ();
+ }
+
+ public void
+ noticeDeiconified (WindowConsumer consumer)
+ {
+ EmacsWindow window;
+
+ /* If a window is attached, send the appropriate iconification
+ events. */
+ window = consumer.getAttachedWindow ();
+
+ if (window != null)
+ window.noticeDeiconified ();
+ }
+
+ public synchronized List<EmacsWindow>
+ copyWindows ()
+ {
+ return new ArrayList<EmacsWindow> (windows);
+ }
+};
diff --git a/java/res/drawable/emacs.png b/java/res/drawable/emacs.png
new file mode 100644
index 00000000000..9ab43d704be
--- /dev/null
+++ b/java/res/drawable/emacs.png
Binary files differ
diff --git a/java/res/drawable/emacs_background.xml b/java/res/drawable/emacs_background.xml
new file mode 100644
index 00000000000..448ca48d1cb
--- /dev/null
+++ b/java/res/drawable/emacs_background.xml
@@ -0,0 +1,42 @@
+<!-- Adaptive icon for Emacs.
+
+Copyright (C) 2023-2024 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 <https://www.gnu.org/licenses/>. -->
+
+<vector xmlns:android="http://schemas.android.com/apk/res/android"
+ xmlns:aapt="http://schemas.android.com/aapt"
+ android:width="108dp"
+ android:height="108dp"
+ android:viewportWidth="512"
+ android:viewportHeight="512">
+ <path
+ android:pathData="M-4.99,-5.79h521.12v526.76h-521.12z"
+ android:strokeWidth="10.6667">
+ <aapt:attr name="android:fillColor">
+ <gradient
+ android:startX="0"
+ android:startY="0"
+ android:endX="512"
+ android:endY="512"
+ android:type="linear">
+ <item android:offset="0" android:color="#FF8381C5"/>
+ <item android:offset="0.64" android:color="#FE806BBC"/>
+ <item android:offset="1" android:color="#FDA52ECB"/>
+ </gradient>
+ </aapt:attr>
+ </path>
+</vector>
diff --git a/java/res/drawable/emacs_foreground.xml b/java/res/drawable/emacs_foreground.xml
new file mode 100644
index 00000000000..d4d71f8e29a
--- /dev/null
+++ b/java/res/drawable/emacs_foreground.xml
@@ -0,0 +1,39 @@
+<!-- Adaptive icon for Emacs.
+
+Copyright (C) 2023-2024 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 <https://www.gnu.org/licenses/>. -->
+
+<vector xmlns:android="http://schemas.android.com/apk/res/android"
+ xmlns:aapt="http://schemas.android.com/aapt"
+ android:width="108dp"
+ android:height="108dp"
+ android:viewportWidth="512"
+ android:viewportHeight="512">
+ <group android:scaleX="0.6"
+ android:scaleY="0.6"
+ android:translateX="102.4"
+ android:translateY="102.4">
+ <path
+ android:pathData="m174.83,422.11c0,0 19.74,1.4 45.13,-0.84 10.28,-0.91 49.33,-4.74 78.52,-11.14 0,0 35.59,-7.62 54.63,-14.63 19.92,-7.34 30.76,-13.57 35.64,-22.4 -0.21,-1.81 1.5,-8.22 -7.68,-12.08 -23.49,-9.85 -50.73,-8.07 -104.63,-9.21 -59.78,-2.05 -79.66,-12.06 -90.26,-20.12 -10.16,-8.18 -5.05,-30.79 38.47,-50.71 21.92,-10.61 107.87,-30.19 107.87,-30.19 -28.95,-14.31 -82.92,-39.46 -94.01,-44.89 -9.73,-4.76 -25.3,-11.94 -28.68,-20.61 -3.83,-8.33 9.04,-15.51 16.22,-17.56 23.14,-6.68 55.82,-10.83 85.55,-11.29 14.95,-0.23 17.37,-1.2 17.37,-1.2 20.62,-3.42 34.2,-17.53 28.54,-39.88 -5.08,-22.81 -31.86,-36.21 -57.31,-31.57 -23.97,4.37 -81.74,21.15 -81.74,21.15 71.41,-0.62 83.36,0.57 88.7,8.04 3.15,4.41 -1.43,10.45 -20.48,13.56 -20.73,3.39 -63.83,7.46 -63.83,7.46 -41.34,2.46 -70.47,2.62 -79.2,21.11 -5.71,12.08 6.09,22.76 11.25,29.45 21.84,24.29 53.39,37.39 73.69,47.04 7.64,3.63 30.06,10.48 30.06,10.48 -65.88,-3.62 -113.4,16.61 -141.28,39.9 -31.53,29.16 -17.58,63.92 47.01,85.33 38.15,12.64 57.07,18.59 113.98,13.46 33.52,-1.81 38.8,-0.73 39.14,2.02 0.47,3.87 -37.23,13.49 -47.52,16.46 -26.19,7.55 -94.83,22.8 -95.17,22.88z"
+ android:strokeLineJoin="miter"
+ android:strokeWidth="0"
+ android:fillColor="#ffffff"
+ android:strokeColor="#a0000000"
+ android:fillType="evenOdd"
+ android:strokeLineCap="butt"/>
+ </group>
+</vector>
diff --git a/java/res/drawable/emacs_wrench.png b/java/res/drawable/emacs_wrench.png
new file mode 100644
index 00000000000..50572d3bed1
--- /dev/null
+++ b/java/res/drawable/emacs_wrench.png
Binary files differ
diff --git a/java/res/layout/sdk8_notifications_view.xml b/java/res/layout/sdk8_notifications_view.xml
new file mode 100644
index 00000000000..a6a441b098f
--- /dev/null
+++ b/java/res/layout/sdk8_notifications_view.xml
@@ -0,0 +1,33 @@
+<!-- Notification content widget tree for GNU Emacs on Android 2.3.
+
+Copyright (C) 2023-2024 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 <https://www.gnu.org/licenses/>. -->
+
+<LinearLayout xmlns:android="http://schemas.android.com/apk/res/android"
+ android:orientation="vertical"
+ android:layout_width="match_parent"
+ android:layout_height="wrap_content"
+ android:padding="8dp">
+ <TextView android:id="@+id/sdk8_notifications_title"
+ android:textColor="#000000"
+ android:layout_width="wrap_content"
+ android:layout_height="wrap_content"/>
+ <TextView android:id="@+id/sdk8_notifications_content"
+ android:textColor="#000000"
+ android:layout_width="wrap_content"
+ android:layout_height="wrap_content"/>
+</LinearLayout>
diff --git a/java/res/mipmap-v26/emacs_icon.xml b/java/res/mipmap-v26/emacs_icon.xml
new file mode 100644
index 00000000000..f0a8df92846
--- /dev/null
+++ b/java/res/mipmap-v26/emacs_icon.xml
@@ -0,0 +1,23 @@
+<!-- Adaptive icon for Emacs.
+
+Copyright (C) 2023-2024 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 <https://www.gnu.org/licenses/>. -->
+
+<adaptive-icon xmlns:android="http://schemas.android.com/apk/res/android">
+ <background android:drawable="@drawable/emacs_background"/>
+ <foreground android:drawable="@drawable/emacs_foreground"/>
+</adaptive-icon>
diff --git a/java/res/mipmap/emacs_icon.png b/java/res/mipmap/emacs_icon.png
new file mode 100644
index 00000000000..9ab43d704be
--- /dev/null
+++ b/java/res/mipmap/emacs_icon.png
Binary files differ
diff --git a/java/res/values-v11/style.xml b/java/res/values-v11/style.xml
new file mode 100644
index 00000000000..f55dd378e39
--- /dev/null
+++ b/java/res/values-v11/style.xml
@@ -0,0 +1,24 @@
+<!-- Style resources for GNU Emacs on Android.
+
+Copyright (C) 2023-2024 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 <https://www.gnu.org/licenses/>. -->
+
+<resources>
+ <!-- Style used for popup menus and relatives on Android 3.x. -->
+ <style name="EmacsStyle" parent="@android:style/Theme.Holo.NoActionBar"/>
+ <style name="EmacsStyleOpen" parent="@android:style/Theme.Holo"/>
+</resources>
diff --git a/java/res/values-v14/style.xml b/java/res/values-v14/style.xml
new file mode 100644
index 00000000000..aa19067d4ec
--- /dev/null
+++ b/java/res/values-v14/style.xml
@@ -0,0 +1,25 @@
+<!-- Style resources for GNU Emacs on Android.
+
+Copyright (C) 2023-2024 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 <https://www.gnu.org/licenses/>. -->
+
+<resources>
+ <!-- Style used for popup menus and relatives between Android 4.0
+ and Android 10. -->
+ <style name="EmacsStyle" parent="@android:style/Theme.DeviceDefault.NoActionBar"/>
+ <style name="EmacsStyleOpen" parent="@android:style/Theme.DeviceDefault"/>
+</resources>
diff --git a/java/res/values-v19/bool.xml b/java/res/values-v19/bool.xml
new file mode 100644
index 00000000000..fa0f8b5c486
--- /dev/null
+++ b/java/res/values-v19/bool.xml
@@ -0,0 +1,22 @@
+<!-- Boolean resources for GNU Emacs on Android 4.4 or later.
+
+Copyright (C) 2023-2024 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 <https://www.gnu.org/licenses/>. -->
+
+<resources>
+ <bool name="isAtLeastKitKat">true</bool>
+</resources>
diff --git a/java/res/values-v24/bool.xml b/java/res/values-v24/bool.xml
new file mode 100644
index 00000000000..aeab90a0da0
--- /dev/null
+++ b/java/res/values-v24/bool.xml
@@ -0,0 +1,22 @@
+<!-- Boolean resources for GNU Emacs on Android.
+
+Copyright (C) 2023-2024 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 <https://www.gnu.org/licenses/>. -->
+
+<resources>
+ <bool name="isBeforeNougat">false</bool>
+</resources>
diff --git a/java/res/values-v29/style.xml b/java/res/values-v29/style.xml
new file mode 100644
index 00000000000..4de416c645e
--- /dev/null
+++ b/java/res/values-v29/style.xml
@@ -0,0 +1,32 @@
+<!-- Style resources for GNU Emacs on Android.
+
+Copyright (C) 2023-2024 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 <https://www.gnu.org/licenses/>. -->
+
+<resources>
+ <!-- Style used for popup menus and relatives from Android 10.0
+ onwards-->
+ <style name="EmacsStyle" parent="@android:style/Theme.DeviceDefault.DayNight">
+ <item name="android:windowActionBar">false</item>
+ <item name="android:windowNoTitle">true</item>
+
+ <!-- Required to make sure the status bar text remains legible. -->
+ <item name="android:statusBarColor">@android:color/black</item>
+ </style>
+ <style name="EmacsStyleOpen"
+ parent="@android:style/Theme.DeviceDefault.DayNight"/>
+</resources>
diff --git a/java/res/values/bool.xml b/java/res/values/bool.xml
new file mode 100644
index 00000000000..f7a7528bead
--- /dev/null
+++ b/java/res/values/bool.xml
@@ -0,0 +1,23 @@
+<!-- Boolean resources for GNU Emacs on Android.
+
+Copyright (C) 2023-2024 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 <https://www.gnu.org/licenses/>. -->
+
+<resources>
+ <bool name="isAtLeastKitKat">false</bool>
+ <bool name="isBeforeNougat">true</bool>
+</resources>
diff --git a/java/res/values/strings.xml b/java/res/values/strings.xml
new file mode 100644
index 00000000000..f858b44fe4b
--- /dev/null
+++ b/java/res/values/strings.xml
@@ -0,0 +1,45 @@
+<!-- String resources used by GNU Emacs on Android.
+
+Copyright (C) 2023-2024 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 <https://www.gnu.org/licenses/>. -->
+
+<resources>
+ <string name="start_quick_title">
+ Restart Emacs with -Q
+ </string>
+ <string name="start_quick_caption">
+ Restart Emacs, but do not load site lisp or init files.
+ </string>
+ <string name="start_debug_init_title">
+ Restart Emacs with --debug-init
+ </string>
+ <string name="start_debug_init_caption">
+ Restart Emacs, and display the debugger should an error occur while loading initialization files.
+ </string>
+ <string name="erase_dump_title">
+ Delete dump file
+ </string>
+ <string name="erase_dump_caption">
+ Remove the dumped state created when Emacs was installed.
+ </string>
+
+ <!-- This resource describes the purpose of any `sharedUserId'
+ specified at configure-time. -->
+ <string name="shared_user_name">
+ Emacs shared user
+ </string>
+</resources>
diff --git a/java/res/values/style.xml b/java/res/values/style.xml
new file mode 100644
index 00000000000..64f2f68aea9
--- /dev/null
+++ b/java/res/values/style.xml
@@ -0,0 +1,26 @@
+<!-- Style resources for GNU Emacs on Android.
+
+Copyright (C) 2023-2024 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 <https://www.gnu.org/licenses/>. -->
+
+<resources>
+ <!-- Style used for popup menus and relatives on Android 2.2 and
+ 2.3. Styles used for newer Android versions are defined in
+ the res/values- directories for their respective API levels. -->
+ <style name="EmacsStyle" parent="@android:style/Theme.NoTitleBar"/>
+ <style name="EmacsStyleOpen" parent="@android:style/Theme"/>
+</resources>
diff --git a/java/res/xml/preferences.xml b/java/res/xml/preferences.xml
new file mode 100644
index 00000000000..8ff93910446
--- /dev/null
+++ b/java/res/xml/preferences.xml
@@ -0,0 +1,30 @@
+<!-- Descriptions for the preferences screen for GNU Emacs on Android.
+
+Copyright (C) 2023-2024 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 <https://www.gnu.org/licenses/>. -->
+
+<PreferenceScreen xmlns:android="http://schemas.android.com/apk/res/android">
+ <Preference android:key="start_quick"
+ android:title="@string/start_quick_title"
+ android:summary="@string/start_quick_caption"/>
+ <Preference android:key="start_debug_init"
+ android:title="@string/start_debug_init_title"
+ android:summary="@string/start_debug_init_caption"/>
+ <Preference android:key="erase_dump"
+ android:title="@string/erase_dump_title"
+ android:summary="@string/erase_dump_caption"/>
+</PreferenceScreen>
diff --git a/leim/MISC-DIC/CTLau-b5.html b/leim/MISC-DIC/CTLau-b5.html
index 117a6ee374e..f174e61db2b 100644
--- a/leim/MISC-DIC/CTLau-b5.html
+++ b/leim/MISC-DIC/CTLau-b5.html
@@ -197,7 +197,7 @@ GAM P̬apAT
GAN ڤyԻ
GANG ü]ոeC
GAP F
-GAT N˸
+GAT N˸
GAU s¤Eeh[b\ϩS
GEI XOJ޺ߦٰծVvɫHҧTB
GENG V
@@ -231,7 +231,7 @@ GWAAT A
GWAI ducֺktӭyޮ۸QXo
GWAN gxuҶvpOa
GWANG F
-GWAT ]
+GWAT ]
GWING
GWOH LGq
GWOK
diff --git a/leim/Makefile.in b/leim/Makefile.in
index f7a23178919..bc1eeb5e634 100644
--- a/leim/Makefile.in
+++ b/leim/Makefile.in
@@ -101,11 +101,11 @@ ${leimdir}/quail ${leimdir}/ja-dic:
## All of TIT_GB and TIT_BIG5.
${leimdir}/quail/%.el: ${srcdir}/CXTERM-DIC/%.tit
$(AM_V_GEN)${RUN_EMACS} -l titdic-cnv \
- -f batch-titdic-convert -dir ${leimdir}/quail $<
+ -f batch-tit-dic-convert -dir ${leimdir}/quail $<
misc_convert = $(AM_V_GEN)${RUN_EMACS} \
- -l titdic-cnv -f batch-miscdic-convert -dir ${leimdir}/quail
+ -l titdic-cnv -f batch-tit-miscdic-convert -dir ${leimdir}/quail
## CTLau.el, CTLau-b5.el.
${leimdir}/quail/CT%.el: ${srcdir}/MISC-DIC/CT%.html
@@ -148,7 +148,7 @@ ${leimdir}/ja-dic/ja-dic.el: $(srcdir)/SKK-DIC/SKK-JISYO.L small-ja-dic-option
-f batch-skkdic-convert -dir "$(leimdir)/ja-dic" $(JA_DIC_NO_REDUCTION_OPTION) "$<"
${srcdir}/../lisp/language/pinyin.el: ${srcdir}/MISC-DIC/pinyin.map
- $(AM_V_GEN)${RUN_EMACS} -l titdic-cnv -f pinyin-convert $< $@
+ $(AM_V_GEN)${RUN_EMACS} -l titdic-cnv -f tit-pinyin-convert $< $@
.PHONY: bootstrap-clean distclean maintainer-clean gen-clean
diff --git a/leim/SKK-DIC/SKK-JISYO.L b/leim/SKK-DIC/SKK-JISYO.L
index 2d4f6198984..792f5318269 100644
--- a/leim/SKK-DIC/SKK-JISYO.L
+++ b/leim/SKK-DIC/SKK-JISYO.L
@@ -73335,7 +73335,7 @@ zyklus /륹/ĥ륹/
礯 //
///
/»/
- /;engineer/;(̾)/////;ܻҤʤ///;-//
+ /;engineer/;(̾)/////;ܻҤʤ///;-//
//
Ƥ /Ū/
礦 /Ĺ/
@@ -87687,7 +87687,7 @@ zyklus /륹/ĥ륹/
ۤ /ĸ/
/ͷ/
/з/
- /Ƹ;represent/ݸ;limits.-̵/
+ /Ƹ;reproduce/ݸ;limits.-̵/
󤫤Τ /Ƹǽ/
󤻤 /Ƹ/
Ƥ /Ƹ/
diff --git a/lib-src/ChangeLog.1 b/lib-src/ChangeLog.1
index db92560fc69..5acb93fb76f 100644
--- a/lib-src/ChangeLog.1
+++ b/lib-src/ChangeLog.1
@@ -1853,7 +1853,7 @@
* emacsclient.c (main): Remove unused variables.
(start_daemon_and_retry_set_socket): Use EXIT_FAILURE.
-2010-09-25 Ulrich Mueller <ulm@gentoo.org>
+2010-09-25 Ulrich Müller <ulm@gentoo.org>
* etags.c (compressors, print_language_names): Support xz compression.
@@ -2498,7 +2498,7 @@
* makefile.w32-in ($(BLD)/sorted-doc.$(O)): Remove spurious backslash.
Reported by Guillaume Conjat <gconjat.ext@orange-ftgroup.com>.
-2008-10-29 Ulrich Mueller <ulm@gentoo.org>
+2008-10-29 Ulrich Müller <ulm@gentoo.org>
* emacsclient.c (set_local_socket): Use TMPDIR (default /tmp)
instead of hardcoded /tmp.
@@ -2539,7 +2539,7 @@
* Makefile.in (CFLAGS): Drop -universal under NS_IMPL_COCOA.
(.m.o): Dispense with GNUstep-specific flags.
-2008-08-05 Ulrich Mueller <ulm@gentoo.org>
+2008-08-05 Ulrich Müller <ulm@gentoo.org>
* pop.c (socket_connection): Add conditionals for
HAVE_KRB5_ERROR_TEXT and HAVE_KRB5_ERROR_E_TEXT to support
@@ -3003,7 +3003,7 @@
* Makefile.in (etags, ctags): Define EMACS_NAME as "GNU Emacs".
-2007-02-20 Ulrich Mueller <ulm@kph.uni-mainz.de> (tiny change)
+2007-02-20 Ulrich Müller <ulm@kph.uni-mainz.de> (tiny change)
* Makefile.in (EMACS, EMACSOPT): New variables.
(blessmail): Use `--no-site-file' when compiling.
@@ -8281,7 +8281,7 @@
* etags.c (C_entries): Save the definedef status even when a
newline is met inside a string.
-1993-03-19 Eric S. Raymond (eric@geech.gnu.ai.mit.edu)
+1993-03-19 Eric S. Raymond (esr@thyrsus.com)
* Makefile.in (EXECUTABLES): Add rcs-checkin.
@@ -8482,7 +8482,7 @@
1992-08-07 Jim Blandy (jimb@pogo.cs.oberlin.edu)
- * timer.c: Installed new version from Eric Raymond; this is more
+ * timer.c: Installed new version from Eric S. Raymond; this is more
portable, since it doesn't try to use SIGIO.
1992-07-17 Jim Blandy (jimb@wookumz.gnu.ai.mit.edu)
diff --git a/lib-src/Makefile.in b/lib-src/Makefile.in
index a0d47b346cd..3cdf1620781 100644
--- a/lib-src/Makefile.in
+++ b/lib-src/Makefile.in
@@ -96,6 +96,14 @@ localstatedir=@localstatedir@
srcdir=@srcdir@
VPATH=@srcdir@
+# Cross-compilation setup
+
+XCONFIGURE=@XCONFIGURE@
+
+ifneq ($(XCONFIGURE),)
+vpath $(srcdir)
+endif
+
# The top-level source directory, also set by configure.
top_srcdir=@top_srcdir@
# MinGW CPPFLAGS may use this.
@@ -140,6 +148,9 @@ HAVE_BE_APP=@HAVE_BE_APP@
HAIKU_LIBS=@HAIKU_LIBS@
HAIKU_CFLAGS=@HAIKU_CFLAGS@
+## Android build-time support
+ANDROID=@ANDROID@
+
# emacsclientw.exe for MinGW, empty otherwise
CLIENTW = @CLIENTW@
@@ -156,8 +167,13 @@ UTILITIES = hexl${EXEEXT} \
ifeq ($(HAVE_BE_APP),yes)
DONT_INSTALL= make-docfile${EXEEXT} make-fingerprint${EXEEXT} be-resources
else
+ifeq ($(XCONFIGURE)$(HAVE_ANDROID),yes)
+DONT_INSTALL = make-docfile${EXEEXT} make-fingerprint${EXEEXT} \
+ asset-directory-tool${EXEEXT}
+else
DONT_INSTALL= make-docfile${EXEEXT} make-fingerprint${EXEEXT}
endif
+endif
# Like UTILITIES, but they're not system-dependent, and should not be
# deleted by the distclean target.
@@ -193,18 +209,18 @@ LIBRESOLV=@LIBRESOLV@
## -llockfile if HAVE_LIBLOCKFILE or -lmail if HAVE_LIBMAIL
LIBS_MAIL=@LIBS_MAIL@
## empty or -lrt or -lposix4 if HAVE_CLOCK_GETTIME
-LIB_CLOCK_GETTIME = @LIB_CLOCK_GETTIME@
+CLOCK_TIME_LIB = @CLOCK_TIME_LIB@
## empty or -lbcrypt or -ladvapi32
-LIB_GETRANDOM = @LIB_GETRANDOM@
+GETRANDOM_LIB = @GETRANDOM_LIB@
## Whatever libraries are needed for euidaccess
-LIB_EACCESS=@LIB_EACCESS@
+EUIDACCESS_LIBGEN=@EUIDACCESS_LIBGEN@
## Libraries needed for file_has_acl
-LIB_HAS_ACL=@LIB_HAS_ACL@
+FILE_HAS_ACL_LIB=@FILE_HAS_ACL_LIB@
## empty or -lwsock2 for MinGW
LIB_WSOCK32=@LIB_WSOCK32@
## Extra libraries for etags
-LIBS_ETAGS = $(LIB_CLOCK_GETTIME) $(LIB_GETRANDOM)
+LIBS_ETAGS = $(CLOCK_TIME_LIB) $(GETRANDOM_LIB)
HAVE_SECCOMP=@HAVE_SECCOMP@
HAVE_LIBSECCOMP=@HAVE_LIBSECCOMP@
@@ -303,7 +319,7 @@ maybe-blessmail: $(BLESSMAIL_TARGET)
## up if chown or chgrp fails, as the package responsible for
## installing Emacs can fix this problem later.
$(DESTDIR)${archlibdir}: all
- $(info $ )
+ $(info $.)
$(info Installing utilities run internally by Emacs.)
umask 022 && ${MKDIR_P} "$(DESTDIR)${archlibdir}"
exp_archlibdir=`cd "$(DESTDIR)${archlibdir}" && pwd -P` && \
@@ -345,7 +361,7 @@ $(DESTDIR)${archlibdir}: all
.PHONY: bootstrap-clean check tags
install: $(DESTDIR)${archlibdir}
- $(info $ )
+ $(info $.)
$(info Installing utilities for users to run.)
umask 022 && ${MKDIR_P} "$(DESTDIR)${bindir}"
for file in ${INSTALLABLES} ; do \
@@ -374,7 +390,7 @@ clean: mostlyclean
rm -f ${EXE_FILES}
distclean: clean
- rm -f TAGS Makefile blessmail
+ rm -f TAGS Makefile blessmail Makefile.android
bootstrap-clean maintainer-clean: distclean
@@ -406,6 +422,9 @@ etags${EXEEXT}: ${etags_deps}
ctags${EXEEXT}: ${srcdir}/ctags.c ${etags_deps}
$(AM_V_CCLD)$(CC) ${ALL_CFLAGS} -o $@ $< $(etags_libs)
+asset-directory-tool${EXEEXT}: ${srcdir}/asset-directory-tool.c $(config_h)
+ $(AM_V_CCLD)$(CC) ${ALL_CFLAGS} $< $(LOADLIBES) -o $@
+
ebrowse${EXEEXT}: ${srcdir}/ebrowse.c ${srcdir}/../lib/min-max.h $(NTLIB) \
$(config_h)
$(AM_V_CCLD)$(CC) ${ALL_CFLAGS} -o $@ $< $(NTLIB) $(LOADLIBES)
@@ -426,12 +445,14 @@ pop.o: ${srcdir}/pop.c ${srcdir}/pop.h ${srcdir}/../lib/min-max.h $(config_h)
emacsclient${EXEEXT}: ${srcdir}/emacsclient.c $(NTLIB) $(config_h)
$(AM_V_CCLD)$(CC) ${ALL_CFLAGS} $< \
$(NTLIB) $(LOADLIBES) \
- $(LIB_WSOCK32) $(LIB_EACCESS) $(LIB_HAS_ACL) $(LIBS_ECLIENT) -o $@
+ $(LIB_WSOCK32) $(EUIDACCESS_LIBGEN) \
+ $(FILE_HAS_ACL_LIB) $(LIBS_ECLIENT) \
+ -o $@
emacsclientw${EXEEXT}: ${srcdir}/emacsclient.c $(NTLIB) $(CLIENTRES) $(config_h)
$(AM_V_CCLD)$(CC) ${ALL_CFLAGS} $(CLIENTRES) -mwindows $< \
$(LOADLIBES) \
- $(LIB_WSOCK32) $(LIB_EACCESS) $(LIBS_ECLIENT) -o $@
+ $(LIB_WSOCK32) $(EUIDACCESS_LIBGEN) $(LIBS_ECLIENT) -o $@
be-resources: ${srcdir}/be_resources.cc ${config_h}
$(AM_V_CXXLD)$(CXX) ${ALL_CXXFLAGS} ${HAIKU_LIBS} $< -o $@
@@ -460,7 +481,7 @@ emacsclient.res: ../nt/emacsclient.rc $(NTINC)/../icons/emacs.ico
ifeq ($(SECCOMP_FILTER),1)
seccomp-filter$(EXEEXT): $(srcdir)/seccomp-filter.c $(config_h)
$(AM_V_CCLD)$(CC) $(ALL_CFLAGS) $(LIBSECCOMP_CFLAGS) $< \
- $(LIBSECCOMP_LIBS) -o $@
+ $(LIBSECCOMP_LIBS) $(LOADLIBES) -o $@
seccomp-filter.bpf seccomp-filter.pfc seccomp-filter-exec.bpf seccomp-filter-exec.pfc: seccomp-filter$(EXEEXT)
$(AM_V_GEN)./seccomp-filter$(EXEEXT) \
diff --git a/lib-src/asset-directory-tool.c b/lib-src/asset-directory-tool.c
new file mode 100644
index 00000000000..31735586193
--- /dev/null
+++ b/lib-src/asset-directory-tool.c
@@ -0,0 +1,289 @@
+/* Android asset directory tool.
+
+Copyright (C) 2023-2024 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 <https://www.gnu.org/licenses/>. */
+
+#include <config.h>
+
+#include <stdio.h>
+#include <fcntl.h>
+#include <errno.h>
+#include <byteswap.h>
+#include <stdlib.h>
+#include <dirent.h>
+#include <string.h>
+#include <unistd.h>
+
+#include <sys/stat.h>
+
+/* This program takes a directory as input, and generates a
+ ``directory-tree'' file suitable for inclusion in an Android
+ application package.
+
+ Such a file records the layout of the `assets' directory in the
+ package. Emacs records this information itself and uses it in the
+ Android emulation of readdir, because the system asset manager APIs
+ are routinely buggy, and are often unable to locate directories or
+ files.
+
+ The file is packed, with no data alignment guarantees made. The
+ file starts with the bytes "EMACS", following which is the name of
+ the first file or directory, a NULL byte and an unsigned int
+ indicating the offset from the start of the file to the start of
+ the next sibling. Following that is a list of subdirectories or
+ files in the same format. The long is stored LSB first.
+
+ Directories can be distinguished from ordinary files through the
+ last bytes of their file names (immediately previous to their
+ terminating NULL bytes), which are set to the directory separator
+ character `/'. */
+
+
+
+struct directory_tree
+{
+ /* The offset to the next sibling. */
+ size_t offset;
+
+ /* The name of this directory or file. */
+ char *name;
+
+ /* Subdirectories and files inside this directory. */
+ struct directory_tree *children, *next;
+};
+
+/* Exit with EXIT_FAILURE, after printing a description of a failing
+ function WHAT along with the details of the error. */
+
+static _Noreturn void
+croak (const char *what)
+{
+ perror (what);
+ exit (EXIT_FAILURE);
+}
+
+/* Like malloc, but aborts on failure. */
+
+static void *
+xmalloc (size_t size)
+{
+ void *ptr;
+
+ ptr = malloc (size);
+
+ if (!ptr)
+ croak ("malloc");
+
+ return ptr;
+}
+
+/* Recursively build a struct directory_tree structure for each
+ subdirectory or file in DIR, in preparation for writing it out to
+ disk. PARENT should be the directory tree associated with the
+ parent directory, or else PARENT->offset must be initialized to
+ 5. */
+
+static void
+main_1 (DIR *dir, struct directory_tree *parent)
+{
+ struct dirent *dirent;
+ int dir_fd, fd;
+ struct stat statb;
+ struct directory_tree *this, **last;
+ size_t length;
+ DIR *otherdir;
+
+ dir_fd = dirfd (dir);
+ last = &parent->children;
+
+ while ((dirent = readdir (dir)))
+ {
+ /* Determine what kind of file DIRENT is. */
+
+ if (fstatat (dir_fd, dirent->d_name, &statb,
+ AT_SYMLINK_NOFOLLOW) == -1)
+ croak ("fstatat");
+
+ /* Ignore . and ... */
+
+ if (!strcmp (dirent->d_name, ".")
+ || !strcmp (dirent->d_name, ".."))
+ continue;
+
+ length = strlen (dirent->d_name);
+
+ if (statb.st_mode & S_IFDIR)
+ {
+ /* This is a directory. Write its name followed by a
+ trailing slash, then a NULL byte, and the offset to the
+ next sibling. */
+ this = xmalloc (sizeof *this);
+ this->children = NULL;
+ this->next = NULL;
+ *last = this;
+ last = &this->next;
+ this->name = xmalloc (length + 2);
+ strcpy (this->name, dirent->d_name);
+
+ /* Now record the offset to the end of this directory. This
+ is length + 1, for the file name, and 5 more bytes for
+ the trailing NULL and long. */
+ this->offset = parent->offset + length + 6;
+
+ /* Terminate that with a slash and trailing NULL byte. */
+ this->name[length] = '/';
+ this->name[length + 1] = '\0';
+
+ /* Open and build that directory recursively. */
+
+ fd = openat (dir_fd, dirent->d_name, O_DIRECTORY,
+ O_RDONLY);
+ if (fd < 0)
+ croak ("openat");
+ otherdir = fdopendir (fd);
+ if (!otherdir)
+ croak ("fdopendir");
+
+ main_1 (otherdir, this);
+
+ /* Close this directory. */
+ closedir (otherdir);
+
+ /* Finally, set parent->offset to this->offset as well. */
+ parent->offset = this->offset;
+ }
+ else if (statb.st_mode & S_IFREG)
+ {
+ /* This is a regular file. */
+ this = xmalloc (sizeof *this);
+ this->children = NULL;
+ this->next = NULL;
+ *last = this;
+ last = &this->next;
+ this->name = xmalloc (length + 1);
+ strcpy (this->name, dirent->d_name);
+
+ /* This is one byte shorter because there is no trailing
+ slash. */
+ this->offset = parent->offset + length + 5;
+ parent->offset = this->offset;
+ }
+ }
+}
+
+/* Write the struct directory_tree TREE and all of is children to the
+ file descriptor FD. OFFSET is the offset of TREE and may be
+ modified; it is only used for checking purposes. */
+
+static void
+main_2 (int fd, struct directory_tree *tree, size_t *offset)
+{
+ ssize_t size;
+ struct directory_tree *child;
+ unsigned int output;
+
+ /* Write tree->name with the trailing NULL byte. */
+ size = strlen (tree->name) + 1;
+ if (write (fd, tree->name, size) < size)
+ croak ("write");
+
+ /* Write the offset. */
+#ifdef WORDS_BIGENDIAN
+ output = bswap_32 (tree->offset);
+#else
+ output = tree->offset;
+#endif
+ if (write (fd, &output, 4) < 1)
+ croak ("write");
+ size += 4;
+
+ /* Now update offset. */
+ *offset += size;
+
+ /* Write out each child. */
+ for (child = tree->children; child; child = child->next)
+ main_2 (fd, child, offset);
+
+ /* Verify the offset is correct. */
+ if (tree->offset != *offset)
+ {
+ fprintf (stderr,
+ "asset-directory-tool: invalid offset: expected %tu, "
+ "got %tu.\n"
+ "Please report this bug to bug-gnu-emacs@gnu.org, along\n"
+ "with an archive containing the contents of the java/inst"
+ "all_temp directory.\n",
+ tree->offset, *offset);
+ abort ();
+ }
+}
+
+int
+main (int argc, char **argv)
+{
+ int fd;
+ DIR *indir;
+ struct directory_tree tree;
+ size_t offset;
+
+ if (argc != 3)
+ {
+ fprintf (stderr, "usage: %s directory output-file\n",
+ argv[0]);
+ return EXIT_FAILURE;
+ }
+
+ fd = open (argv[2], O_CREAT | O_TRUNC | O_RDWR,
+ S_IRUSR | S_IWUSR | S_IRGRP | S_IWGRP);
+
+ if (fd < 0)
+ {
+ perror ("open");
+ return EXIT_FAILURE;
+ }
+
+ indir = opendir (argv[1]);
+
+ if (!indir)
+ {
+ perror ("opendir");
+ return EXIT_FAILURE;
+ }
+
+ /* Write the first 5 byte header to FD. */
+
+ if (write (fd, "EMACS", 5) < 5)
+ {
+ perror ("write");
+ return EXIT_FAILURE;
+ }
+
+ /* Now iterate through children of INDIR, building the directory
+ tree. */
+ tree.offset = 5;
+ tree.children = NULL;
+
+ main_1 (indir, &tree);
+ closedir (indir);
+
+ /* Finally, write the directory tree to the output file. */
+ offset = 5;
+ for (; tree.children; tree.children = tree.children->next)
+ main_2 (fd, tree.children, &offset);
+
+ return 0;
+}
diff --git a/lib-src/ebrowse.c b/lib-src/ebrowse.c
index fa06472e708..821c29272a4 100644
--- a/lib-src/ebrowse.c
+++ b/lib-src/ebrowse.c
@@ -31,11 +31,6 @@ along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. */
#include <min-max.h>
#include <unlocked-io.h>
-/* The SunOS compiler doesn't have SEEK_END. */
-#ifndef SEEK_END
-#define SEEK_END 2
-#endif
-
/* Files are read in chunks of this number of bytes. */
enum { READ_CHUNK_SIZE = 100 * 1024 };
@@ -3772,8 +3767,9 @@ main (int argc, char **argv)
if (n_input_files == input_filenames_size)
{
input_filenames_size = max (10, 2 * input_filenames_size);
- input_filenames = (char **) xrealloc ((void *)input_filenames,
- input_filenames_size);
+ input_filenames = xrealloc (input_filenames,
+ (input_filenames_size
+ * sizeof *input_filenames));
}
input_filenames[n_input_files++] = xstrdup (optarg);
break;
diff --git a/lib-src/emacsclient.c b/lib-src/emacsclient.c
index 9e72ee61144..ea34d5f7b93 100644
--- a/lib-src/emacsclient.c
+++ b/lib-src/emacsclient.c
@@ -618,6 +618,7 @@ decode_options (int argc, char **argv)
display in DISPLAY (if any). */
if (create_frame && !tty && !display)
{
+#ifndef HAVE_ANDROID
/* Set these here so we use a default_display only when the user
didn't give us an explicit display. */
#if defined (NS_IMPL_COCOA)
@@ -626,14 +627,22 @@ decode_options (int argc, char **argv)
alt_display = "w32";
#elif defined (HAVE_HAIKU)
alt_display = "be";
-#endif
+#endif /* NS_IMPL_COCOA */
#ifdef HAVE_PGTK
display = egetenv ("WAYLAND_DISPLAY");
alt_display = egetenv ("DISPLAY");
-#else
+#else /* !HAVE_PGTK */
display = egetenv ("DISPLAY");
-#endif
+#endif /* HAVE_PGTK */
+#else /* HAVE_ANDROID */
+ /* Disregard the DISPLAY environment variable under Android.
+ Several terminal emulator programs furnish their own X
+ servers and set DISPLAY, but an Android build is incapable of
+ displaying X frames. */
+ alt_display = NULL;
+ display = "android";
+#endif /* !HAVE_ANDROID */
}
if (!display)
diff --git a/lib-src/etags.c b/lib-src/etags.c
index bf99f5a50a6..032cfa8010b 100644
--- a/lib-src/etags.c
+++ b/lib-src/etags.c
@@ -109,6 +109,7 @@ University of California, as described above. */
#include <limits.h>
#include <unistd.h>
#include <stdarg.h>
+#include <stdckdint.h>
#include <stdlib.h>
#include <string.h>
#include <sysstdio.h>
@@ -3824,7 +3825,7 @@ C_entries (int c_ext, /* extension of C */
{
case fstartlist:
/* This prevents tagging fb in
- void (__attribute__((noreturn)) *fb) (void);
+ void (__attribute__ ((noreturn)) *fb) (void);
Fixing this is not easy and not very important. */
fvdef = finlist;
continue;
@@ -4379,14 +4380,14 @@ Yacc_entries (FILE *inf)
#define LOOKING_AT(cp, kw) /* kw is the keyword, a literal string */ \
((assert ("" kw), true) /* syntax error if not a literal string */ \
- && strneq ((cp), kw, sizeof (kw)-1) /* cp points at kw */ \
+ && strneq (cp, kw, sizeof (kw) - 1) /* cp points at kw */ \
&& notinname ((cp)[sizeof (kw)-1]) /* end of kw */ \
&& ((cp) = skip_spaces ((cp) + sizeof (kw) - 1), true)) /* skip spaces */
/* Similar to LOOKING_AT but does not use notinname, does not skip */
#define LOOKING_AT_NOCASE(cp, kw) /* the keyword is a literal string */ \
((assert ("" kw), true) /* syntax error if not a literal string */ \
- && strncaseeq ((cp), kw, sizeof (kw)-1) /* cp points at kw */ \
+ && strncaseeq (cp, kw, sizeof (kw) - 1) /* cp points at kw */ \
&& ((cp) += sizeof (kw) - 1, true)) /* skip spaces */
/*
@@ -7774,7 +7775,7 @@ escape_shell_arg_string (char *str)
#endif
static void
-do_move_file(const char *src_file, const char *dst_file)
+do_move_file (const char *src_file, const char *dst_file)
{
if (rename (src_file, dst_file) == 0)
return;
@@ -8038,7 +8039,7 @@ xnmalloc (ptrdiff_t nitems, ptrdiff_t item_size)
ptrdiff_t nbytes;
assume (0 <= nitems);
assume (0 < item_size);
- if (INT_MULTIPLY_WRAPV (nitems, item_size, &nbytes))
+ if (ckd_mul (&nbytes, nitems, item_size))
memory_full ();
return xmalloc (nbytes);
}
@@ -8049,7 +8050,7 @@ xnrealloc (void *pa, ptrdiff_t nitems, ptrdiff_t item_size)
ptrdiff_t nbytes;
assume (0 <= nitems);
assume (0 < item_size);
- if (INT_MULTIPLY_WRAPV (nitems, item_size, &nbytes) || SIZE_MAX < nbytes)
+ if (ckd_mul (&nbytes, nitems, item_size) || SIZE_MAX < nbytes)
memory_full ();
void *result = realloc (pa, nbytes);
if (!result)
diff --git a/lib-src/movemail.c b/lib-src/movemail.c
index c9f6000f9d5..407f95e4541 100644
--- a/lib-src/movemail.c
+++ b/lib-src/movemail.c
@@ -62,6 +62,7 @@ along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. */
#include <stdlib.h>
#include <errno.h>
#include <time.h>
+#include <timespec.h>
#include <getopt.h>
#include <unistd.h>
@@ -469,7 +470,7 @@ main (int argc, char **argv)
that were set on the file. Better to just empty the file. */
if (unlink (inname) < 0 && errno != ENOENT)
#endif /* MAIL_UNLINK_SPOOL */
- creat (inname, 0600);
+ close (creat (inname, 0600));
}
#endif /* not MAIL_USE_SYSTEM_LOCK */
@@ -846,7 +847,7 @@ movemail_strftime (char *s, size_t size, char const *format,
static bool
mbx_delimit_begin (FILE *mbf)
{
- time_t now = time (NULL);
+ time_t now = current_timespec ().tv_sec;
struct tm *ltime = localtime (&now);
if (!ltime)
return false;
diff --git a/lib-src/seccomp-filter.c b/lib-src/seccomp-filter.c
index 8846e6aedae..0aeb6e8d88a 100644
--- a/lib-src/seccomp-filter.c
+++ b/lib-src/seccomp-filter.c
@@ -114,7 +114,7 @@ set_attribute (enum scmp_filter_attr attr, uint32_t value)
{ \
const struct scmp_arg_cmp arg_array[] = {__VA_ARGS__}; \
enum { arg_cnt = sizeof arg_array / sizeof *arg_array }; \
- int status = seccomp_rule_add_array (ctx, (action), (syscall), \
+ int status = seccomp_rule_add_array (ctx, action, syscall, \
arg_cnt, arg_array); \
if (status < 0) \
fail (-status, "seccomp_rule_add_array (%s, %s, %d, {%s})", \
@@ -143,7 +143,7 @@ export_filter (const char *file,
}
#define EXPORT_FILTER(file, function) \
- export_filter ((file), (function), #function)
+ export_filter (file, function, #function)
int
main (int argc, char **argv)
diff --git a/lib-src/update-game-score.c b/lib-src/update-game-score.c
index 01e8eb6cdcc..4139073bcd7 100644
--- a/lib-src/update-game-score.c
+++ b/lib-src/update-game-score.c
@@ -185,8 +185,6 @@ main (int argc, char **argv)
ptrdiff_t scorecount, scorealloc;
ptrdiff_t max_scores = MAX_SCORES;
- srand (time (0));
-
while ((c = getopt (argc, argv, "hrm:d:")) != -1)
switch (c)
{
@@ -485,8 +483,8 @@ lock_file (const char *filename, void **state)
return -1;
attempts = 0;
}
-
- sleep ((rand () & 1) + 1);
+ else
+ sleep (1);
}
close (fd);
diff --git a/lib/Makefile.in b/lib/Makefile.in
index 1d30a9c2917..6706d73ace0 100644
--- a/lib/Makefile.in
+++ b/lib/Makefile.in
@@ -20,6 +20,15 @@
srcdir = @srcdir@
VPATH = @srcdir@
+# This is not empty if this is a Makefile that will be copied to
+# cross/lib.
+XCONFIGURE = @XCONFIGURE@
+
+# This is required to make sure symbol visibility is correct and
+# functions like readlinkat do not end up replacing their OS
+# counterparts.
+ANDROID_BUILD_CFLAGS = @ANDROID_BUILD_CFLAGS@
+
# Variables substituted by 'configure', and not autogenerated in gnulib.mk,
# or needed before gnulib.mk is included.
abs_top_srcdir = @abs_top_srcdir@
@@ -33,11 +42,11 @@ all:
HAVE_NATIVE_COMP = @HAVE_NATIVE_COMP@
-ALL_CFLAGS= \
+ALL_CFLAGS = \
$(C_SWITCH_SYSTEM) $(C_SWITCH_MACHINE) $(DEPFLAGS) \
$(GNULIB_WARN_CFLAGS) $(WERROR_CFLAGS) $(PROFILING_CFLAGS) $(CFLAGS) \
- -I. -I../src -I$(srcdir) -I$(srcdir)/../src \
- $(if $(patsubst e-%,,$(notdir $<)),,-Demacs)
+ -I. -I../src -I$(srcdir) -I$(top_srcdir)/src \
+ $(if $(patsubst e-%,,$(notdir $<)),,-Demacs) $(ANDROID_BUILD_CFLAGS)
ifeq ($(HAVE_NATIVE_COMP),yes)
ALL_CFLAGS += -DGL_COMPILE_CRYPTO_STREAM
@@ -52,6 +61,12 @@ ifneq ($(SYSTEM_TYPE),windows-nt)
libgnu_a_SOURCES += openat-die.c save-cwd.c
endif
+ifeq ($(XCONFIGURE),android)
+# The next line is necessary to override -I$(srcdir), which will end
+# up pulling in lots of headers from the host.
+ALL_CFLAGS += -I$(top_srcdir)/cross -I.
+endif
+
DEPDIR = deps
ifeq ($(AUTO_DEPEND),yes)
DEPFLAGS = -MMD -MF $(DEPDIR)/$*.d -MP
@@ -60,11 +75,14 @@ else
DEPFLAGS =
endif
+# This piece of code interferes with cross compilation
+ifeq ($(XCONFIGURE),)
.PRECIOUS: ../config.status Makefile
../config.status: $(top_srcdir)/configure.ac $(top_srcdir)/m4/*.m4
$(MAKE) -C .. $(notdir $@)
Makefile: ../config.status $(srcdir)/Makefile.in
$(MAKE) -C .. lib/$@
+endif
# Object modules that need not be built for Emacs.
# Emacs does not need e-regex.o (it has its own regex-emacs.c),
@@ -111,10 +129,10 @@ clean:
mostlyclean: clean
rm -f $(filter-out %-t,$(MOSTLYCLEANFILES))
distclean bootstrap-clean: mostlyclean
- rm -f Makefile
+ rm -f Makefile Makefile.android
rm -fr $(DEPDIR)
maintainer-clean: distclean
- rm -f TAGS gnulib.mk
+ rm -f TAGS gnulib.mk gnulib.mk.android
-rmdir malloc sys 2>/dev/null || true
.PHONY: mostlyclean clean distclean bootstrap-clean maintainer-clean
diff --git a/lib/_Noreturn.h b/lib/_Noreturn.h
index 6c94c62ba67..7326bd47733 100644
--- a/lib/_Noreturn.h
+++ b/lib/_Noreturn.h
@@ -26,6 +26,11 @@
AIX system header files and several gnulib header files use precisely
this syntax with 'extern'. */
# define _Noreturn [[noreturn]]
+# elif (defined __clang__ && __clang_major__ < 16 \
+ && defined _GL_WORK_AROUND_LLVM_BUG_59792)
+ /* Compile with -D_GL_WORK_AROUND_LLVM_BUG_59792 to work around
+ that rare LLVM bug, though you may get many false-alarm warnings. */
+# define _Noreturn
# elif ((!defined __cplusplus || defined __clang__) \
&& (201112 <= (defined __STDC_VERSION__ ? __STDC_VERSION__ : 0) \
|| (!defined __STRICT_ANSI__ \
diff --git a/lib/acl-internal.h b/lib/acl-internal.h
index a7f7387a133..ef1f84dc243 100644
--- a/lib/acl-internal.h
+++ b/lib/acl-internal.h
@@ -17,6 +17,11 @@
Written by Paul Eggert, Andreas Grünbacher, and Bruno Haible. */
+/* This file uses _GL_INLINE_HEADER_BEGIN, _GL_INLINE, _GL_ATTRIBUTE_PURE. */
+#if !_GL_CONFIG_H_INCLUDED
+ #error "Please include config.h first."
+#endif
+
#include "acl.h"
#include <stdlib.h>
@@ -47,9 +52,6 @@ extern int aclsort (int, int, struct acl *);
#include <errno.h>
#include <limits.h>
-#ifndef MIN
-# define MIN(a,b) ((a) < (b) ? (a) : (b))
-#endif
#ifndef SIZE_MAX
# define SIZE_MAX ((size_t) -1)
@@ -60,9 +62,6 @@ extern int aclsort (int, int, struct acl *);
# define fchmod(fd, mode) (-1)
#endif
-#ifndef _GL_INLINE_HEADER_BEGIN
- #error "Please include config.h first."
-#endif
_GL_INLINE_HEADER_BEGIN
#ifndef ACL_INTERNAL_INLINE
# define ACL_INTERNAL_INLINE _GL_INLINE
diff --git a/lib/acl.h b/lib/acl.h
index cdcb3b802e3..a3aeb8fc86a 100644
--- a/lib/acl.h
+++ b/lib/acl.h
@@ -20,6 +20,11 @@
#ifndef _GL_ACL_H
#define _GL_ACL_H 1
+/* This file uses _GL_ATTRIBUTE_CONST. */
+#if !_GL_CONFIG_H_INCLUDED
+ #error "Please include config.h first."
+#endif
+
#include <sys/types.h>
#include <sys/stat.h>
diff --git a/lib/alloca.in.h b/lib/alloca.in.h
index 49c86125b69..6aa47df8ec3 100644
--- a/lib/alloca.in.h
+++ b/lib/alloca.in.h
@@ -1,7 +1,7 @@
/* Memory allocation on the stack.
- Copyright (C) 1995, 1999, 2001-2004, 2006-2024 Free Software
- Foundation, Inc.
+ Copyright (C) 1995, 1999, 2001-2004, 2006-2024 Free Software Foundation,
+ Inc.
This file is free software: you can redistribute it and/or modify
it under the terms of the GNU Lesser General Public License as
diff --git a/lib/attribute.h b/lib/attribute.h
index bb80a4dca53..710341ba417 100644
--- a/lib/attribute.h
+++ b/lib/attribute.h
@@ -32,7 +32,7 @@
/* This file defines two types of attributes:
- * C2x standard attributes. These have macro names that do not begin with
+ * C23 standard attributes. These have macro names that do not begin with
'ATTRIBUTE_'.
* Selected GCC attributes; see:
https://gcc.gnu.org/onlinedocs/gcc/Common-Function-Attributes.html
@@ -41,6 +41,21 @@
These names begin with 'ATTRIBUTE_' to avoid name clashes. */
+/* This file uses _GL_ATTRIBUTE_ALLOC_SIZE, _GL_ATTRIBUTE_ALWAYS_INLINE,
+ _GL_ATTRIBUTE_ARTIFICIAL, _GL_ATTRIBUTE_COLD, _GL_ATTRIBUTE_CONST,
+ _GL_ATTRIBUTE_DEALLOC, _GL_ATTRIBUTE_DEPRECATED, _GL_ATTRIBUTE_ERROR,
+ _GL_ATTRIBUTE_WARNING, _GL_ATTRIBUTE_EXTERNALLY_VISIBLE,
+ _GL_ATTRIBUTE_FALLTHROUGH, _GL_ATTRIBUTE_FORMAT, _GL_ATTRIBUTE_LEAF,
+ _GL_ATTRIBUTE_MALLOC, _GL_ATTRIBUTE_MAY_ALIAS, _GL_ATTRIBUTE_MAYBE_UNUSED,
+ _GL_ATTRIBUTE_NODISCARD, _GL_ATTRIBUTE_NOINLINE, _GL_ATTRIBUTE_NONNULL,
+ _GL_ATTRIBUTE_NONSTRING, _GL_ATTRIBUTE_NOTHROW, _GL_ATTRIBUTE_PACKED,
+ _GL_ATTRIBUTE_PURE, _GL_ATTRIBUTE_RETURNS_NONNULL,
+ _GL_ATTRIBUTE_SENTINEL. */
+#if !_GL_CONFIG_H_INCLUDED
+ #error "Please include config.h first."
+#endif
+
+
/* =============== Attributes for specific kinds of functions =============== */
/* Attributes for functions that should not be used. */
@@ -167,6 +182,8 @@
/* The function does not throw exceptions. */
/* Applies to: functions. */
+/* After a function's parameter list, this attribute must come first, before
+ other attributes. */
#define ATTRIBUTE_NOTHROW _GL_ATTRIBUTE_NOTHROW
/* Do not inline the function. */
diff --git a/lib/binary-io.h b/lib/binary-io.h
index 077e3dda0f6..0cc5c11748c 100644
--- a/lib/binary-io.h
+++ b/lib/binary-io.h
@@ -1,6 +1,5 @@
/* Binary mode I/O.
- Copyright (C) 2001, 2003, 2005, 2008-2024 Free Software Foundation,
- Inc.
+ Copyright (C) 2001, 2003, 2005, 2008-2024 Free Software Foundation, Inc.
This file is free software: you can redistribute it and/or modify
it under the terms of the GNU Lesser General Public License as
@@ -18,6 +17,11 @@
#ifndef _BINARY_H
#define _BINARY_H
+/* This file uses _GL_INLINE_HEADER_BEGIN, _GL_INLINE, _GL_UNUSED. */
+#if !_GL_CONFIG_H_INCLUDED
+ #error "Please include config.h first."
+#endif
+
/* For systems that distinguish between text and binary I/O.
O_BINARY is guaranteed by the gnulib <fcntl.h>. */
#include <fcntl.h>
@@ -26,9 +30,6 @@
so we include it here first. */
#include <stdio.h>
-#ifndef _GL_INLINE_HEADER_BEGIN
- #error "Please include config.h first."
-#endif
_GL_INLINE_HEADER_BEGIN
#ifndef BINARY_IO_INLINE
# define BINARY_IO_INLINE _GL_INLINE
diff --git a/lib/boot-time-aux.h b/lib/boot-time-aux.h
new file mode 100644
index 00000000000..8b966fe691f
--- /dev/null
+++ b/lib/boot-time-aux.h
@@ -0,0 +1,323 @@
+/* Auxiliary functions for determining the time when the machine last booted.
+ Copyright (C) 2023-2024 Free Software Foundation, Inc.
+
+ This file 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 file is distributed in the hope that it will be useful,
+ but WITHOUT ANY WARRANTY; without even the implied warranty of
+ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ GNU General Public License for more details.
+
+ You should have received a copy of the GNU General Public License
+ along with this program. If not, see <https://www.gnu.org/licenses/>. */
+
+/* Written by Bruno Haible <bruno@clisp.org>. */
+
+#define SIZEOF(a) (sizeof(a)/sizeof(a[0]))
+
+#if defined __linux__ || defined __ANDROID__
+
+/* Store the uptime counter, as managed by the Linux kernel, in *P_UPTIME.
+ Return 0 upon success, -1 upon failure. */
+_GL_ATTRIBUTE_MAYBE_UNUSED
+static int
+get_linux_uptime (struct timespec *p_uptime)
+{
+ /* The clock_gettime facility returns the uptime with a resolution of 1 µsec.
+ It is available with glibc >= 2.14, Android, or musl libc.
+ In glibc < 2.17 it required linking with librt. */
+# if !defined __GLIBC__ || 2 < __GLIBC__ + (17 <= __GLIBC_MINOR__)
+ if (clock_gettime (CLOCK_BOOTTIME, p_uptime) >= 0)
+ return 0;
+# endif
+
+ /* /proc/uptime contains the uptime with a resolution of 0.01 sec.
+ But it does not have read permissions on Android. */
+# if !defined __ANDROID__
+ FILE *fp = fopen ("/proc/uptime", "re");
+ if (fp != NULL)
+ {
+ char buf[32 + 1];
+ size_t n = fread (buf, 1, sizeof (buf) - 1, fp);
+ fclose (fp);
+ if (n > 0)
+ {
+ buf[n] = '\0';
+ /* buf now contains two values: the uptime and the idle time. */
+ time_t s = 0;
+ char *p;
+ for (p = buf; '0' <= *p && *p <= '9'; p++)
+ s = 10 * s + (*p - '0');
+ if (buf < p)
+ {
+ long ns = 0;
+ if (*p++ == '.')
+ for (int i = 0; i < 9; i++)
+ ns = 10 * ns + ('0' <= *p && *p <= '9' ? *p++ - '0' : 0);
+ p_uptime->tv_sec = s;
+ p_uptime->tv_nsec = ns;
+ return 0;
+ }
+ }
+ }
+# endif
+
+# if HAVE_DECL_SYSINFO /* not available in Android API < 9 */
+ /* The sysinfo call returns the uptime with a resolution of 1 sec only. */
+ struct sysinfo info;
+ if (sysinfo (&info) >= 0)
+ {
+ p_uptime->tv_sec = info.uptime;
+ p_uptime->tv_nsec = 0;
+ return 0;
+ }
+# endif
+
+ return -1;
+}
+
+#endif
+
+#if defined __linux__ && !defined __ANDROID__
+
+static int
+get_linux_boot_time_fallback (struct timespec *p_boot_time)
+{
+ /* On Devuan with the 'runit' init system and on Artix with the 's6' init
+ system, UTMP_FILE contains USER_PROCESS and other entries, but no
+ BOOT_TIME entry.
+ On Alpine Linux, UTMP_FILE is not filled. It is always empty.
+ So, in both cases, get the time stamp of a file that gets touched only
+ during the boot process. */
+
+ const char * const boot_touched_files[] =
+ {
+ "/var/lib/systemd/random-seed", /* seen on distros with systemd */
+ "/var/lib/urandom/random-seed", /* seen on Devuan with runit */
+ "/var/lib/random-seed", /* seen on Artix with s6 */
+ /* This must come last, since on several distros /var/run/utmp is
+ modified when a user logs in, i.e. long after boot. */
+ "/var/run/utmp" /* seen on Alpine Linux with OpenRC */
+ };
+ for (idx_t i = 0; i < SIZEOF (boot_touched_files); i++)
+ {
+ const char *filename = boot_touched_files[i];
+ struct stat statbuf;
+ if (stat (filename, &statbuf) >= 0)
+ {
+ *p_boot_time = get_stat_mtime (&statbuf);
+ return 0;
+ }
+ }
+ return -1;
+}
+
+/* The following approach is only usable as a fallback, because it is of
+ the form
+ boot_time = (time now) - (kernel's ktime_get_boottime[_ts64] ())
+ and therefore produces wrong values after the date has been bumped in the
+ running system, which happens frequently if the system is running in a
+ virtual machine and this VM has been put into "saved" or "sleep" state
+ and then resumed. */
+static int
+get_linux_boot_time_final_fallback (struct timespec *p_boot_time)
+{
+ struct timespec uptime;
+ if (get_linux_uptime (&uptime) >= 0)
+ {
+ struct timespec result;
+# if !defined __GLIBC__ || 2 < __GLIBC__ + (16 <= __GLIBC_MINOR__)
+ /* Better than:
+ if (0 <= clock_gettime (CLOCK_REALTIME, &result))
+ because timespec_get does not need -lrt in glibc 2.16.
+ */
+ if (! timespec_get (&result, TIME_UTC))
+ return -1;
+# else
+ /* Fall back on lower-res approach that does not need -lrt.
+ This is good enough; on these hosts UPTIME is even lower-res. */
+ struct timeval tv;
+ int r = gettimeofday (&tv, NULL);
+ if (r < 0)
+ return r;
+ result.tv_sec = tv.tv_sec;
+ result.tv_nsec = tv.tv_usec * 1000;
+# endif
+
+ if (result.tv_nsec < uptime.tv_nsec)
+ {
+ result.tv_nsec += 1000000000;
+ result.tv_sec -= 1;
+ }
+ result.tv_sec -= uptime.tv_sec;
+ result.tv_nsec -= uptime.tv_nsec;
+ *p_boot_time = result;
+ return 0;
+ }
+ return -1;
+}
+
+#endif
+
+#if defined __ANDROID__
+
+static int
+get_android_boot_time (struct timespec *p_boot_time)
+{
+ /* On Android, there is no /var, and normal processes don't have access
+ to system files. Therefore use the kernel's uptime counter, although
+ it produces wrong values after the date has been bumped in the running
+ system. */
+ struct timespec uptime;
+ if (get_linux_uptime (&uptime) >= 0)
+ {
+ struct timespec result;
+ if (clock_gettime (CLOCK_REALTIME, &result) >= 0)
+ {
+ if (result.tv_nsec < uptime.tv_nsec)
+ {
+ result.tv_nsec += 1000000000;
+ result.tv_sec -= 1;
+ }
+ result.tv_sec -= uptime.tv_sec;
+ result.tv_nsec -= uptime.tv_nsec;
+ *p_boot_time = result;
+ return 0;
+ }
+ }
+ return -1;
+}
+
+#endif
+
+#if defined __OpenBSD__
+
+static int
+get_openbsd_boot_time (struct timespec *p_boot_time)
+{
+ /* On OpenBSD, UTMP_FILE is not filled. It contains only dummy entries.
+ So, get the time stamp of a file that gets touched only during the
+ boot process. */
+ const char * const boot_touched_files[] =
+ {
+ "/var/db/host.random",
+ "/var/run/utmp"
+ };
+ for (idx_t i = 0; i < SIZEOF (boot_touched_files); i++)
+ {
+ const char *filename = boot_touched_files[i];
+ struct stat statbuf;
+ if (stat (filename, &statbuf) >= 0)
+ {
+ *p_boot_time = get_stat_mtime (&statbuf);
+ return 0;
+ }
+ }
+ return -1;
+}
+
+#endif
+
+#if HAVE_SYS_SYSCTL_H && HAVE_SYSCTL \
+ && defined CTL_KERN && defined KERN_BOOTTIME \
+ && !defined __minix
+/* macOS, FreeBSD, GNU/kFreeBSD, NetBSD, OpenBSD */
+/* On Minix 3.3 this sysctl produces garbage results. Therefore avoid it. */
+
+/* The following approach is only usable as a fallback, because it produces
+ wrong values after the date has been bumped in the running system, which
+ happens frequently if the system is running in a virtual machine and this
+ VM has been put into "saved" or "sleep" state and then resumed. */
+static int
+get_bsd_boot_time_final_fallback (struct timespec *p_boot_time)
+{
+ static int request[2] = { CTL_KERN, KERN_BOOTTIME };
+ struct timeval result;
+ size_t result_len = sizeof result;
+
+ if (sysctl (request, 2, &result, &result_len, NULL, 0) >= 0)
+ {
+ p_boot_time->tv_sec = result.tv_sec;
+ p_boot_time->tv_nsec = result.tv_usec * 1000;
+ return 0;
+ }
+ return -1;
+}
+
+#endif
+
+#if defined __HAIKU__
+
+static int
+get_haiku_boot_time (struct timespec *p_boot_time)
+{
+ /* On Haiku, /etc/utmp does not exist. During boot,
+ 1. the current time is restored, but possibly with a wrong time zone,
+ that is, with an offset of a few hours,
+ 2. some symlinks and files get created,
+ 3. the various devices are brought up, in particular the network device,
+ 4. the correct date and time is set,
+ 5. some more device nodes get created.
+ The boot time can be retrieved by looking at a directory created during
+ phase 5, such as /dev/input. */
+ const char * const boot_touched_file = "/dev/input";
+ struct stat statbuf;
+ if (stat (boot_touched_file, &statbuf) >= 0)
+ {
+ *p_boot_time = get_stat_mtime (&statbuf);
+ return 0;
+ }
+ return -1;
+}
+
+#endif
+
+#if HAVE_OS_H /* BeOS, Haiku */
+
+/* The following approach is only usable as a fallback, because it produces
+ wrong values after the date has been bumped in the running system, which
+ happens frequently if the system is running in a virtual machine and this
+ VM has been put into "saved" or "sleep" state and then resumed. */
+static int
+get_haiku_boot_time_final_fallback (struct timespec *p_boot_time)
+{
+ system_info si;
+
+ get_system_info (&si);
+ p_boot_time->tv_sec = si.boot_time / 1000000;
+ p_boot_time->tv_nsec = (si.boot_time % 1000000) * 1000;
+ return 0;
+}
+
+#endif
+
+#if defined __CYGWIN__ || defined _WIN32
+
+static int
+get_windows_boot_time (struct timespec *p_boot_time)
+{
+ /* On Cygwin, /var/run/utmp is empty.
+ On native Windows, <utmpx.h> and <utmp.h> don't exist.
+ Instead, on Windows, the boot time can be retrieved by looking at the
+ time stamp of a file that (normally) gets touched only during the boot
+ process, namely C:\pagefile.sys. */
+ const char * const boot_touched_file =
+ #if defined __CYGWIN__ && !defined _WIN32
+ "/cygdrive/c/pagefile.sys"
+ #else
+ "C:\\pagefile.sys"
+ #endif
+ ;
+ struct stat statbuf;
+ if (stat (boot_touched_file, &statbuf) >= 0)
+ {
+ *p_boot_time = get_stat_mtime (&statbuf);
+ return 0;
+ }
+ return -1;
+}
+
+#endif
diff --git a/lib/boot-time.c b/lib/boot-time.c
new file mode 100644
index 00000000000..c1171e8024d
--- /dev/null
+++ b/lib/boot-time.c
@@ -0,0 +1,294 @@
+/* Determine the time when the machine last booted.
+ Copyright (C) 2023-2024 Free Software Foundation, Inc.
+
+ This file 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 file is distributed in the hope that it will be useful,
+ but WITHOUT ANY WARRANTY; without even the implied warranty of
+ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ GNU General Public License for more details.
+
+ You should have received a copy of the GNU General Public License
+ along with this program. If not, see <https://www.gnu.org/licenses/>. */
+
+/* Written by Bruno Haible <bruno@clisp.org>. */
+
+#include <config.h>
+
+/* Specification. */
+#include "boot-time.h"
+
+#include <stddef.h>
+#include <stdio.h>
+#include <string.h>
+#include <sys/types.h>
+#include <sys/stat.h>
+
+#if defined __linux__ || defined __ANDROID__
+# include <sys/sysinfo.h>
+# include <time.h>
+#endif
+
+#if HAVE_SYS_SYSCTL_H && !(defined __GLIBC__ && defined __linux__) && !defined __minix
+# if HAVE_SYS_PARAM_H
+# include <sys/param.h>
+# endif
+# include <sys/sysctl.h>
+#endif
+
+#if HAVE_OS_H
+# include <OS.h>
+#endif
+
+#include "idx.h"
+#include "readutmp.h"
+#include "stat-time.h"
+
+/* Each of the FILE streams in this file is only used in a single thread. */
+#include "unlocked-io.h"
+
+/* Some helper functions. */
+#include "boot-time-aux.h"
+
+/* The following macros describe the 'struct UTMP_STRUCT_NAME',
+ *not* 'struct gl_utmp'. */
+#undef UT_USER
+
+/* Accessor macro for the member named ut_user or ut_name. */
+#if (HAVE_UTMPX_H ? HAVE_STRUCT_UTMPX_UT_NAME \
+ : HAVE_UTMP_H && HAVE_STRUCT_UTMP_UT_NAME)
+# define UT_USER(UT) ((UT)->ut_name)
+#else
+# define UT_USER(UT) ((UT)->ut_user)
+#endif
+
+#if !HAVE_UTMPX_H && HAVE_UTMP_H && defined UTMP_NAME_FUNCTION
+# if !HAVE_DECL_ENDUTENT /* Android */
+void endutent (void);
+# endif
+#endif
+
+#if defined __linux__ || HAVE_UTMPX_H || HAVE_UTMP_H || defined __CYGWIN__ || defined _WIN32
+
+static int
+get_boot_time_uncached (struct timespec *p_boot_time)
+{
+ struct timespec found_boot_time = {0};
+
+# if (HAVE_UTMPX_H ? HAVE_STRUCT_UTMPX_UT_TYPE : HAVE_STRUCT_UTMP_UT_TYPE)
+
+ /* Try to find the boot time in the /var/run/utmp file. */
+
+# if defined UTMP_NAME_FUNCTION /* glibc, musl, macOS, FreeBSD, NetBSD, Minix, AIX, IRIX, Solaris, Cygwin, Android */
+
+ /* Ignore the return value for now.
+ Solaris' utmpname returns 1 upon success -- which is contrary
+ to what the GNU libc version does. In addition, older GNU libc
+ versions are actually void. */
+ UTMP_NAME_FUNCTION ((char *) UTMP_FILE);
+
+ SET_UTMP_ENT ();
+
+# if (defined __linux__ && !defined __ANDROID__) || defined __minix
+ /* Timestamp of the "runlevel" entry, if any. */
+ struct timespec runlevel_ts = {0};
+# endif
+
+ void const *entry;
+
+ while ((entry = GET_UTMP_ENT ()) != NULL)
+ {
+ struct UTMP_STRUCT_NAME const *ut = (struct UTMP_STRUCT_NAME const *) entry;
+
+ struct timespec ts =
+ #if (HAVE_UTMPX_H ? 1 : HAVE_STRUCT_UTMP_UT_TV)
+ { .tv_sec = ut->ut_tv.tv_sec, .tv_nsec = ut->ut_tv.tv_usec * 1000 };
+ #else
+ { .tv_sec = ut->ut_time, .tv_nsec = 0 };
+ #endif
+
+ if (ut->ut_type == BOOT_TIME)
+ found_boot_time = ts;
+
+# if defined __linux__ && !defined __ANDROID__
+ if (memcmp (UT_USER (ut), "runlevel", strlen ("runlevel") + 1) == 0
+ && memcmp (ut->ut_line, "~", strlen ("~") + 1) == 0)
+ runlevel_ts = ts;
+# endif
+# if defined __minix
+ if (UT_USER (ut)[0] == '\0'
+ && memcmp (ut->ut_line, "run-level ", strlen ("run-level ")) == 0)
+ runlevel_ts = ts;
+# endif
+ }
+
+ END_UTMP_ENT ();
+
+# if defined __linux__ && !defined __ANDROID__
+ /* On Raspbian, which runs on hardware without a real-time clock, during boot,
+ 1. the clock gets set to 1970-01-01 00:00:00,
+ 2. an entry gets written into /var/run/utmp, with ut_type = BOOT_TIME,
+ ut_user = "reboot", ut_line = "~", time = 1970-01-01 00:00:05 or so,
+ 3. the clock gets set to a correct value through NTP,
+ 4. an entry gets written into /var/run/utmp, with
+ ut_user = "runlevel", ut_line = "~", time = correct value.
+ In this case, get the time from the "runlevel" entry. */
+
+ /* Workaround for Raspbian: */
+ if (found_boot_time.tv_sec <= 60 && runlevel_ts.tv_sec != 0)
+ found_boot_time = runlevel_ts;
+ if (found_boot_time.tv_sec == 0)
+ {
+ /* Workaround for Alpine Linux: */
+ get_linux_boot_time_fallback (&found_boot_time);
+ }
+# endif
+
+# if defined __ANDROID__
+ if (found_boot_time.tv_sec == 0)
+ {
+ /* Workaround for Android: */
+ get_android_boot_time (&found_boot_time);
+ }
+# endif
+
+# if defined __minix
+ /* On Minix, during boot,
+ 1. an entry gets written into /var/run/utmp, with ut_type = BOOT_TIME,
+ ut_user = "", ut_line = "system boot", time = 1970-01-01 00:00:00,
+ 2. an entry gets written into /var/run/utmp, with
+ ut_user = "", ut_line = "run-level m", time = correct value.
+ In this case, copy the time from the "run-level m" entry to the
+ "system boot" entry. */
+ if (found_boot_time.tv_sec <= 60 && runlevel_ts.tv_sec != 0)
+ found_boot_time = runlevel_ts;
+# endif
+
+# else /* HP-UX, Haiku */
+
+ FILE *f = fopen (UTMP_FILE, "re");
+
+ if (f != NULL)
+ {
+ for (;;)
+ {
+ struct UTMP_STRUCT_NAME ut;
+
+ if (fread (&ut, sizeof ut, 1, f) == 0)
+ break;
+
+ struct timespec ts =
+ #if (HAVE_UTMPX_H ? 1 : HAVE_STRUCT_UTMP_UT_TV)
+ { .tv_sec = ut.ut_tv.tv_sec, .tv_nsec = ut.ut_tv.tv_usec * 1000 };
+ #else
+ { .tv_sec = ut.ut_time, .tv_nsec = 0 };
+ #endif
+
+ if (ut.ut_type == BOOT_TIME)
+ found_boot_time = ts;
+ }
+
+ fclose (f);
+ }
+
+# endif
+
+# if defined __linux__ && !defined __ANDROID__
+ if (found_boot_time.tv_sec == 0)
+ {
+ get_linux_boot_time_final_fallback (&found_boot_time);
+ }
+# endif
+
+# else /* Adélie Linux, old FreeBSD, OpenBSD, native Windows */
+
+# if defined __linux__ && !defined __ANDROID__
+ /* Workaround for Adélie Linux: */
+ get_linux_boot_time_fallback (&found_boot_time);
+ if (found_boot_time.tv_sec == 0)
+ get_linux_boot_time_final_fallback (&found_boot_time);
+# endif
+
+# if defined __OpenBSD__
+ /* Workaround for OpenBSD: */
+ get_openbsd_boot_time (&found_boot_time);
+# endif
+
+# endif
+
+# if HAVE_SYS_SYSCTL_H && HAVE_SYSCTL \
+ && defined CTL_KERN && defined KERN_BOOTTIME \
+ && !defined __minix
+ if (found_boot_time.tv_sec == 0)
+ {
+ get_bsd_boot_time_final_fallback (&found_boot_time);
+ }
+# endif
+
+# if defined __HAIKU__
+ if (found_boot_time.tv_sec == 0)
+ {
+ get_haiku_boot_time (&found_boot_time);
+ }
+# endif
+
+# if HAVE_OS_H
+ if (found_boot_time.tv_sec == 0)
+ {
+ get_haiku_boot_time_final_fallback (&found_boot_time);
+ }
+# endif
+
+# if defined __CYGWIN__ || defined _WIN32
+ if (found_boot_time.tv_sec == 0)
+ {
+ /* Workaround for Windows: */
+ get_windows_boot_time (&found_boot_time);
+ }
+# endif
+
+ if (found_boot_time.tv_sec != 0)
+ {
+ *p_boot_time = found_boot_time;
+ return 0;
+ }
+ else
+ return -1;
+}
+
+int
+get_boot_time (struct timespec *p_boot_time)
+{
+ /* Cache the result from get_boot_time_uncached. */
+ static int volatile cached_result = -1;
+ static struct timespec volatile cached_boot_time;
+
+ if (cached_result < 0)
+ {
+ struct timespec boot_time;
+ int result = get_boot_time_uncached (&boot_time);
+ cached_boot_time = boot_time;
+ cached_result = result;
+ }
+
+ if (cached_result == 0)
+ {
+ *p_boot_time = cached_boot_time;
+ return 0;
+ }
+ else
+ return -1;
+}
+
+#else
+
+int
+get_boot_time (struct timespec *p_boot_time)
+{
+ return -1;
+}
+
+#endif
diff --git a/lib/boot-time.h b/lib/boot-time.h
new file mode 100644
index 00000000000..99684323ec6
--- /dev/null
+++ b/lib/boot-time.h
@@ -0,0 +1,44 @@
+/* Determine the time when the machine last booted.
+ Copyright (C) 2023-2024 Free Software Foundation, Inc.
+
+ This file 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 file is distributed in the hope that it will be useful,
+ but WITHOUT ANY WARRANTY; without even the implied warranty of
+ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ GNU General Public License for more details.
+
+ You should have received a copy of the GNU General Public License
+ along with this program. If not, see <https://www.gnu.org/licenses/>. */
+
+/* Written by Bruno Haible <bruno@clisp.org>. */
+
+#ifndef _BOOT_TIME_H
+#define _BOOT_TIME_H
+
+#include <time.h>
+
+#ifdef __cplusplus
+extern "C" {
+#endif
+
+
+/* Store the approximate time when the machine last booted in *P_BOOT_TIME,
+ and return 0. If it cannot be determined, return -1.
+
+ This function is not multithread-safe, since on many platforms it
+ invokes the functions setutxent, getutxent, endutxent. These
+ functions are needed because they may lock FILE (so that we don't
+ read garbage when a concurrent process writes to FILE), but their
+ drawback is that they have a common global state. */
+extern int get_boot_time (struct timespec *p_boot_time);
+
+
+#ifdef __cplusplus
+}
+#endif
+
+#endif /* _BOOT_TIME_H */
diff --git a/lib/c++defs.h b/lib/c++defs.h
index ac8e08e609c..eb66967b09b 100644
--- a/lib/c++defs.h
+++ b/lib/c++defs.h
@@ -99,6 +99,12 @@
Example:
_GL_FUNCDECL_RPL (open, int, (const char *filename, int flags, ...)
_GL_ARG_NONNULL ((1)));
+
+ Note: Attributes, such as _GL_ATTRIBUTE_DEPRECATED, are supported in front
+ of a _GL_FUNCDECL_RPL invocation only in C mode, not in C++ mode. (That's
+ because
+ [[...]] extern "C" <declaration>;
+ is invalid syntax in C++.)
*/
#define _GL_FUNCDECL_RPL(func,rettype,parameters_and_attributes) \
_GL_FUNCDECL_RPL_1 (rpl_##func, rettype, parameters_and_attributes)
diff --git a/lib/c-ctype.h b/lib/c-ctype.h
index c5d0f9f7dbe..b582de4a7fd 100644
--- a/lib/c-ctype.h
+++ b/lib/c-ctype.h
@@ -5,8 +5,7 @@
<ctype.h> functions' behaviour depends on the current locale set via
setlocale.
- Copyright (C) 2000-2003, 2006, 2008-2024 Free Software Foundation,
- Inc.
+ Copyright (C) 2000-2003, 2006, 2008-2024 Free Software Foundation, Inc.
This file is free software: you can redistribute it and/or modify
it under the terms of the GNU Lesser General Public License as
@@ -24,9 +23,11 @@
#ifndef C_CTYPE_H
#define C_CTYPE_H
-#ifndef _GL_INLINE_HEADER_BEGIN
+/* This file uses _GL_INLINE_HEADER_BEGIN, _GL_INLINE. */
+#if !_GL_CONFIG_H_INCLUDED
#error "Please include config.h first."
#endif
+
_GL_INLINE_HEADER_BEGIN
#ifndef C_CTYPE_INLINE
# define C_CTYPE_INLINE _GL_INLINE
diff --git a/lib/c-strcase.h b/lib/c-strcase.h
index f0f389a133c..b75e8dd1cb3 100644
--- a/lib/c-strcase.h
+++ b/lib/c-strcase.h
@@ -18,6 +18,11 @@
#ifndef C_STRCASE_H
#define C_STRCASE_H
+/* This file uses _GL_ATTRIBUTE_PURE. */
+#if !_GL_CONFIG_H_INCLUDED
+ #error "Please include config.h first."
+#endif
+
#include <stddef.h>
diff --git a/lib/c-strcasecmp.c b/lib/c-strcasecmp.c
index a4bad4f2e2f..1fa575a8562 100644
--- a/lib/c-strcasecmp.c
+++ b/lib/c-strcasecmp.c
@@ -1,6 +1,5 @@
/* c-strcasecmp.c -- case insensitive string comparator in C locale
- Copyright (C) 1998-1999, 2005-2006, 2009-2024 Free Software
- Foundation, Inc.
+ Copyright (C) 1998-1999, 2005-2006, 2009-2024 Free Software Foundation, Inc.
This file is free software: you can redistribute it and/or modify
it under the terms of the GNU Lesser General Public License as
diff --git a/lib/c-strncasecmp.c b/lib/c-strncasecmp.c
index 693601586be..4c8b0b6b841 100644
--- a/lib/c-strncasecmp.c
+++ b/lib/c-strncasecmp.c
@@ -1,6 +1,5 @@
/* c-strncasecmp.c -- case insensitive string comparator in C locale
- Copyright (C) 1998-1999, 2005-2006, 2009-2024 Free Software
- Foundation, Inc.
+ Copyright (C) 1998-1999, 2005-2006, 2009-2024 Free Software Foundation, Inc.
This file is free software: you can redistribute it and/or modify
it under the terms of the GNU Lesser General Public License as
diff --git a/lib/careadlinkat.c b/lib/careadlinkat.c
index 4b0ceb5e31f..f308b6963ae 100644
--- a/lib/careadlinkat.c
+++ b/lib/careadlinkat.c
@@ -1,7 +1,7 @@
/* Read symbolic links into a buffer without size limitation, relative to fd.
- Copyright (C) 2001, 2003-2004, 2007, 2009-2024 Free Software
- Foundation, Inc.
+ Copyright (C) 2001, 2003-2004, 2007, 2009-2024 Free Software Foundation,
+ Inc.
This file is free software: you can redistribute it and/or modify
it under the terms of the GNU Lesser General Public License as
@@ -35,10 +35,6 @@
# define SIZE_MAX ((size_t) -1)
#endif
-#ifndef SSIZE_MAX
-# define SSIZE_MAX ((ssize_t) (SIZE_MAX / 2))
-#endif
-
#include "allocator.h"
enum { STACK_BUF_SIZE = 1024 };
@@ -55,7 +51,9 @@ enum { STACK_BUF_SIZE = 1024 };
When the GCC bug is fixed this workaround should be limited to the
broken GCC versions. */
#if _GL_GNUC_PREREQ (10, 1)
-# if defined GCC_LINT || defined lint
+# if _GL_GNUC_PREREQ (12, 1)
+# pragma GCC diagnostic ignored "-Wreturn-local-addr"
+# elif defined GCC_LINT || defined lint
__attribute__ ((__noinline__))
# elif __OPTIMIZE__ && !__NO_INLINE__
# define GCC_BOGUS_WRETURN_LOCAL_ADDR
diff --git a/lib/careadlinkat.h b/lib/careadlinkat.h
index 5e6f8815e00..473e6531e67 100644
--- a/lib/careadlinkat.h
+++ b/lib/careadlinkat.h
@@ -20,6 +20,11 @@
#ifndef _GL_CAREADLINKAT_H
#define _GL_CAREADLINKAT_H
+/* This file uses HAVE_READLINKAT. */
+#if !_GL_CONFIG_H_INCLUDED
+ #error "Please include config.h first."
+#endif
+
#include <fcntl.h>
#include <unistd.h>
diff --git a/lib/cdefs.h b/lib/cdefs.h
index bc416c73198..d38382ad9d8 100644
--- a/lib/cdefs.h
+++ b/lib/cdefs.h
@@ -42,8 +42,8 @@
#if (defined __has_attribute \
&& (!defined __clang_minor__ \
|| (defined __apple_build_version__ \
- ? 6000000 <= __apple_build_version__ \
- : 3 < __clang_major__ + (5 <= __clang_minor__))))
+ ? 7000000 <= __apple_build_version__ \
+ : 5 <= __clang_major__)))
# define __glibc_has_attribute(attr) __has_attribute (attr)
#else
# define __glibc_has_attribute(attr) 0
@@ -140,32 +140,37 @@
#endif
+/* Gnulib avoids these definitions, as they don't work on non-glibc platforms.
+ In particular, __bos and __bos0 are defined differently in the Android libc.
+ */
+#ifndef __GNULIB_CDEFS
+
/* Fortify support. */
-#define __bos(ptr) __builtin_object_size (ptr, __USE_FORTIFY_LEVEL > 1)
-#define __bos0(ptr) __builtin_object_size (ptr, 0)
+# define __bos(ptr) __builtin_object_size (ptr, __USE_FORTIFY_LEVEL > 1)
+# define __bos0(ptr) __builtin_object_size (ptr, 0)
/* Use __builtin_dynamic_object_size at _FORTIFY_SOURCE=3 when available. */
-#if __USE_FORTIFY_LEVEL == 3 && (__glibc_clang_prereq (9, 0) \
- || __GNUC_PREREQ (12, 0))
-# define __glibc_objsize0(__o) __builtin_dynamic_object_size (__o, 0)
-# define __glibc_objsize(__o) __builtin_dynamic_object_size (__o, 1)
-#else
-# define __glibc_objsize0(__o) __bos0 (__o)
-# define __glibc_objsize(__o) __bos (__o)
-#endif
+# if __USE_FORTIFY_LEVEL == 3 && (__glibc_clang_prereq (9, 0) \
+ || __GNUC_PREREQ (12, 0))
+# define __glibc_objsize0(__o) __builtin_dynamic_object_size (__o, 0)
+# define __glibc_objsize(__o) __builtin_dynamic_object_size (__o, 1)
+# else
+# define __glibc_objsize0(__o) __bos0 (__o)
+# define __glibc_objsize(__o) __bos (__o)
+# endif
/* Compile time conditions to choose between the regular, _chk and _chk_warn
variants. These conditions should get evaluated to constant and optimized
away. */
-#define __glibc_safe_len_cond(__l, __s, __osz) ((__l) <= (__osz) / (__s))
-#define __glibc_unsigned_or_positive(__l) \
+# define __glibc_safe_len_cond(__l, __s, __osz) ((__l) <= (__osz) / (__s))
+# define __glibc_unsigned_or_positive(__l) \
((__typeof (__l)) 0 < (__typeof (__l)) -1 \
|| (__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, or unknown (-1) */
-#define __glibc_safe_or_unknown_len(__l, __s, __osz) \
+# define __glibc_safe_or_unknown_len(__l, __s, __osz) \
((__osz) == (__SIZE_TYPE__) -1 \
|| (__glibc_unsigned_or_positive (__l) \
&& __builtin_constant_p (__glibc_safe_len_cond ((__SIZE_TYPE__) (__l), \
@@ -175,7 +180,7 @@
/* 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
false. */
-#define __glibc_unsafe_len(__l, __s, __osz) \
+# define __glibc_unsafe_len(__l, __s, __osz) \
(__glibc_unsigned_or_positive (__l) \
&& __builtin_constant_p (__glibc_safe_len_cond ((__SIZE_TYPE__) (__l), \
__s, __osz)) \
@@ -184,7 +189,7 @@
/* Fortify function f. __f_alias, __f_chk and __f_chk_warn must be
declared. */
-#define __glibc_fortify(f, __l, __s, __osz, ...) \
+# define __glibc_fortify(f, __l, __s, __osz, ...) \
(__glibc_safe_or_unknown_len (__l, __s, __osz) \
? __ ## f ## _alias (__VA_ARGS__) \
: (__glibc_unsafe_len (__l, __s, __osz) \
@@ -194,13 +199,16 @@
/* Fortify function f, where object size argument passed to f is the number of
elements and not total size. */
-#define __glibc_fortify_n(f, __l, __s, __osz, ...) \
+# define __glibc_fortify_n(f, __l, __s, __osz, ...) \
(__glibc_safe_or_unknown_len (__l, __s, __osz) \
? __ ## f ## _alias (__VA_ARGS__) \
: (__glibc_unsafe_len (__l, __s, __osz) \
? __ ## f ## _chk_warn (__VA_ARGS__, (__osz) / (__s)) \
: __ ## f ## _chk (__VA_ARGS__, (__osz) / (__s)))) \
+#endif
+
+
#if __GNUC_PREREQ (4,3)
# define __warnattr(msg) __attribute__((__warning__ (msg)))
# define __errordecl(name, msg) \
diff --git a/lib/cloexec.c b/lib/cloexec.c
index b4279752880..cdb0d740eb7 100644
--- a/lib/cloexec.c
+++ b/lib/cloexec.c
@@ -1,7 +1,6 @@
/* cloexec.c - set or clear the close-on-exec descriptor flag
- Copyright (C) 1991, 2004-2006, 2009-2024 Free Software Foundation,
- Inc.
+ Copyright (C) 1991, 2004-2006, 2009-2024 Free Software Foundation, Inc.
This file is free software: you can redistribute it and/or modify
it under the terms of the GNU Lesser General Public License as
diff --git a/lib/close-stream.c b/lib/close-stream.c
index ae53f93aabe..81094c6863c 100644
--- a/lib/close-stream.c
+++ b/lib/close-stream.c
@@ -1,7 +1,6 @@
/* Close a stream, with nicer error checking than fclose's.
- Copyright (C) 1998-2002, 2004, 2006-2024 Free Software Foundation,
- Inc.
+ Copyright (C) 1998-2002, 2004, 2006-2024 Free Software Foundation, Inc.
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/lib/count-leading-zeros.h b/lib/count-leading-zeros.h
index f8be420abc7..545749d6d27 100644
--- a/lib/count-leading-zeros.h
+++ b/lib/count-leading-zeros.h
@@ -19,12 +19,14 @@
#ifndef COUNT_LEADING_ZEROS_H
#define COUNT_LEADING_ZEROS_H 1
+/* This file uses _GL_INLINE_HEADER_BEGIN, _GL_INLINE. */
+#if !_GL_CONFIG_H_INCLUDED
+ #error "Please include config.h first."
+#endif
+
#include <limits.h>
#include <stdlib.h>
-#ifndef _GL_INLINE_HEADER_BEGIN
- #error "Please include config.h first."
-#endif
_GL_INLINE_HEADER_BEGIN
#ifndef COUNT_LEADING_ZEROS_INLINE
# define COUNT_LEADING_ZEROS_INLINE _GL_INLINE
diff --git a/lib/count-one-bits.h b/lib/count-one-bits.h
index 0b1e9e2e722..8d67f8718a4 100644
--- a/lib/count-one-bits.h
+++ b/lib/count-one-bits.h
@@ -19,12 +19,14 @@
#ifndef COUNT_ONE_BITS_H
#define COUNT_ONE_BITS_H 1
+/* This file uses _GL_INLINE_HEADER_BEGIN, _GL_INLINE. */
+#if !_GL_CONFIG_H_INCLUDED
+ #error "Please include config.h first."
+#endif
+
#include <limits.h>
#include <stdlib.h>
-#ifndef _GL_INLINE_HEADER_BEGIN
- #error "Please include config.h first."
-#endif
_GL_INLINE_HEADER_BEGIN
#ifndef COUNT_ONE_BITS_INLINE
# define COUNT_ONE_BITS_INLINE _GL_INLINE
diff --git a/lib/count-trailing-zeros.h b/lib/count-trailing-zeros.h
index 9e785267f92..ed1e0131147 100644
--- a/lib/count-trailing-zeros.h
+++ b/lib/count-trailing-zeros.h
@@ -19,12 +19,14 @@
#ifndef COUNT_TRAILING_ZEROS_H
#define COUNT_TRAILING_ZEROS_H 1
+/* This file uses _GL_INLINE_HEADER_BEGIN, _GL_INLINE. */
+#if !_GL_CONFIG_H_INCLUDED
+ #error "Please include config.h first."
+#endif
+
#include <limits.h>
#include <stdlib.h>
-#ifndef _GL_INLINE_HEADER_BEGIN
- #error "Please include config.h first."
-#endif
_GL_INLINE_HEADER_BEGIN
#ifndef COUNT_TRAILING_ZEROS_INLINE
# define COUNT_TRAILING_ZEROS_INLINE _GL_INLINE
diff --git a/lib/diffseq.h b/lib/diffseq.h
index ec5189921aa..0c5bc9cbc6d 100644
--- a/lib/diffseq.h
+++ b/lib/diffseq.h
@@ -1,7 +1,7 @@
/* Analyze differences between two vectors.
- Copyright (C) 1988-1989, 1992-1995, 2001-2004, 2006-2024 Free
- Software Foundation, Inc.
+ Copyright (C) 1988-1989, 1992-1995, 2001-2004, 2006-2024 Free Software
+ Foundation, Inc.
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
@@ -48,6 +48,10 @@
OFFSET A signed integer type sufficient to hold the
difference between two indices. Usually
something like ptrdiff_t.
+ OFFSET_MAX (Optional) The maximum value of OFFSET (e.g.,
+ PTRDIFF_MAX). If omitted, it is inferred in a
+ way portable to the vast majority of C platforms,
+ as they lack padding bits.
EXTRA_CONTEXT_FIELDS Declarations of fields for 'struct context'.
NOTE_DELETE(ctxt, xoff) Record the removal of the object xvec[xoff].
NOTE_INSERT(ctxt, yoff) Record the insertion of the object yvec[yoff].
@@ -74,8 +78,10 @@
*/
/* Maximum value of type OFFSET. */
-#define OFFSET_MAX \
- ((((OFFSET)1 << (sizeof (OFFSET) * CHAR_BIT - 2)) - 1) * 2 + 1)
+#ifndef OFFSET_MAX
+# define OFFSET_MAX \
+ ((((OFFSET) 1 << (sizeof (OFFSET) * CHAR_BIT - 2)) - 1) * 2 + 1)
+#endif
/* Default to no early abort. */
#ifndef EARLY_ABORT
@@ -86,14 +92,11 @@
# define NOTE_ORDERED false
#endif
-/* Use this to suppress gcc's "...may be used before initialized" warnings.
- Beware: The Code argument must not contain commas. */
-#ifndef IF_LINT
-# if defined GCC_LINT || defined lint
-# define IF_LINT(Code) Code
-# else
-# define IF_LINT(Code) /* empty */
-# endif
+/* Suppress gcc's "...may be used before initialized" warnings,
+ generated by GCC versions up to at least GCC 13.2. */
+#if __GNUC__ + (__GNUC_MINOR__ >= 7) > 4
+# pragma GCC diagnostic push
+# pragma GCC diagnostic ignored "-Wmaybe-uninitialized"
#endif
/*
@@ -376,13 +379,8 @@ diag (OFFSET xoff, OFFSET xlim, OFFSET yoff, OFFSET ylim, bool find_minimal,
and report halfway between our best results so far. */
if (c >= ctxt->too_expensive)
{
- OFFSET fxybest;
- OFFSET fxbest IF_LINT (= 0);
- OFFSET bxybest;
- OFFSET bxbest IF_LINT (= 0);
-
/* Find forward diagonal that maximizes X + Y. */
- fxybest = -1;
+ OFFSET fxybest = -1, fxbest;
for (d = fmax; d >= fmin; d -= 2)
{
OFFSET x = MIN (fd[d], xlim);
@@ -400,7 +398,7 @@ diag (OFFSET xoff, OFFSET xlim, OFFSET yoff, OFFSET ylim, bool find_minimal,
}
/* Find backward diagonal that minimizes X + Y. */
- bxybest = OFFSET_MAX;
+ OFFSET bxybest = OFFSET_MAX, bxbest;
for (d = bmax; d >= bmin; d -= 2)
{
OFFSET x = MAX (xoff, bd[d]);
@@ -556,6 +554,10 @@ compareseq (OFFSET xoff, OFFSET xlim, OFFSET yoff, OFFSET ylim,
#undef XREF_YREF_EQUAL
}
+#if __GNUC__ + (__GNUC_MINOR__ >= 7) > 4
+# pragma GCC diagnostic pop
+#endif
+
#undef ELEMENT
#undef EQUAL
#undef OFFSET
diff --git a/lib/dirent-private.h b/lib/dirent-private.h
new file mode 100644
index 00000000000..335fbc351a5
--- /dev/null
+++ b/lib/dirent-private.h
@@ -0,0 +1,67 @@
+/* Private details of the DIR type.
+ Copyright (C) 2011-2024 Free Software Foundation, Inc.
+
+ This file is free software: you can redistribute it and/or modify
+ it under the terms of the GNU Lesser General Public License as
+ published by the Free Software Foundation; either version 2.1 of the
+ License, or (at your option) any later version.
+
+ This file 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 Lesser General Public License for more details.
+
+ You should have received a copy of the GNU Lesser General Public License
+ along with this program. If not, see <https://www.gnu.org/licenses/>. */
+
+#ifndef _DIRENT_PRIVATE_H
+#define _DIRENT_PRIVATE_H 1
+
+#if HAVE_DIRENT_H /* mingw */
+
+# undef DIR
+
+struct gl_directory
+{
+ /* File descriptor to close during closedir().
+ Needed for implementing fdopendir(). */
+ int fd_to_close;
+ /* Pointer to the real DIR. */
+ DIR *real_dirp;
+};
+
+/* Restore definition from dirent.h. */
+# define DIR struct gl_directory
+
+#else /* MSVC */
+
+# define WIN32_LEAN_AND_MEAN
+# include <windows.h>
+
+/* Don't assume that UNICODE is not defined. */
+# undef WIN32_FIND_DATA
+# define WIN32_FIND_DATA WIN32_FIND_DATAA
+
+struct gl_directory
+{
+ /* File descriptor to close during closedir().
+ Needed for implementing fdopendir(). */
+ int fd_to_close;
+ /* Status, or error code to produce in next readdir() call.
+ -2 means the end of the directory is already reached,
+ -1 means the entry was already filled by FindFirstFile,
+ 0 means the entry needs to be filled using FindNextFile.
+ A positive value is an error code. */
+ int status;
+ /* Handle, reading the directory, at current position. */
+ HANDLE current;
+ /* Found directory entry. */
+ WIN32_FIND_DATA entry;
+ /* Argument to pass to FindFirstFile. It consists of the absolutized
+ directory name, followed by a directory separator and the wildcards. */
+ char dir_name_mask[1];
+};
+
+#endif
+
+#endif /* _DIRENT_PRIVATE_H */
diff --git a/lib/dirent.in.h b/lib/dirent.in.h
index 19c1014cf5a..f05b880077f 100644
--- a/lib/dirent.in.h
+++ b/lib/dirent.in.h
@@ -29,6 +29,12 @@
#ifndef _@GUARD_PREFIX@_DIRENT_H
#define _@GUARD_PREFIX@_DIRENT_H
+/* This file uses _GL_ATTRIBUTE_DEALLOC, _GL_ATTRIBUTE_MALLOC,
+ _GL_ATTRIBUTE_PURE, GNULIB_POSIXCHECK, HAVE_RAW_DECL_*. */
+#if !_GL_CONFIG_H_INCLUDED
+ #error "Please include config.h first."
+#endif
+
/* Get ino_t. Needed on some systems, including glibc 2.8. */
#include <sys/types.h>
@@ -50,11 +56,24 @@ struct dirent
# define DT_LNK 10 /* symbolic link */
# define DT_SOCK 12 /* socket */
# define DT_WHT 14 /* whiteout */
-typedef struct gl_directory DIR;
# define GNULIB_defined_struct_dirent 1
# endif
#endif
+#if !@DIR_HAS_FD_MEMBER@
+# if !GNULIB_defined_DIR
+/* struct gl_directory is a type with a field 'int fd_to_close'.
+ It is needed for implementing fdopendir(). */
+struct gl_directory;
+# if @HAVE_DIRENT_H@
+# define DIR struct gl_directory
+# else
+typedef struct gl_directory DIR;
+# endif
+# define GNULIB_defined_DIR 1
+# endif
+#endif
+
/* _GL_ATTRIBUTE_DEALLOC (F, I) declares that the function returns pointers
that can be freed by passing them as the Ith argument to the
function F. */
@@ -143,7 +162,7 @@ _GL_CXXALIAS_SYS (opendir, DIR *, (const char *dir_name));
# endif
_GL_CXXALIASWARN (opendir);
#else
-# if @GNULIB_CLOSEDIR@ && __GNUC__ >= 11 && !defined opendir
+# if @GNULIB_CLOSEDIR@ && !GNULIB_defined_DIR && __GNUC__ >= 11 && !defined opendir
/* For -Wmismatched-dealloc: Associate opendir with closedir or
rpl_closedir. */
_GL_FUNCDECL_SYS (opendir, DIR *,
@@ -161,10 +180,19 @@ _GL_WARN_ON_USE (opendir, "opendir is not portable - "
#endif
#if @GNULIB_READDIR@
-# if !@HAVE_READDIR@
+# if @REPLACE_READDIR@
+# if !(defined __cplusplus && defined GNULIB_NAMESPACE)
+# undef readdir
+# define readdir rpl_readdir
+# endif
+_GL_FUNCDECL_RPL (readdir, struct dirent *, (DIR *dirp) _GL_ARG_NONNULL ((1)));
+_GL_CXXALIAS_RPL (readdir, struct dirent *, (DIR *dirp));
+# else
+# if !@HAVE_READDIR@
_GL_FUNCDECL_SYS (readdir, struct dirent *, (DIR *dirp) _GL_ARG_NONNULL ((1)));
-# endif
+# endif
_GL_CXXALIAS_SYS (readdir, struct dirent *, (DIR *dirp));
+# endif
_GL_CXXALIASWARN (readdir);
#elif defined GNULIB_POSIXCHECK
# undef readdir
@@ -175,10 +203,19 @@ _GL_WARN_ON_USE (readdir, "readdir is not portable - "
#endif
#if @GNULIB_REWINDDIR@
-# if !@HAVE_REWINDDIR@
+# if @REPLACE_REWINDDIR@
+# if !(defined __cplusplus && defined GNULIB_NAMESPACE)
+# undef rewinddir
+# define rewinddir rpl_rewinddir
+# endif
+_GL_FUNCDECL_RPL (rewinddir, void, (DIR *dirp) _GL_ARG_NONNULL ((1)));
+_GL_CXXALIAS_RPL (rewinddir, void, (DIR *dirp));
+# else
+# if !@HAVE_REWINDDIR@
_GL_FUNCDECL_SYS (rewinddir, void, (DIR *dirp) _GL_ARG_NONNULL ((1)));
-# endif
+# endif
_GL_CXXALIAS_SYS (rewinddir, void, (DIR *dirp));
+# endif
_GL_CXXALIASWARN (rewinddir);
#elif defined GNULIB_POSIXCHECK
# undef rewinddir
@@ -200,12 +237,6 @@ _GL_WARN_ON_USE (rewinddir, "rewinddir is not portable - "
_GL_FUNCDECL_RPL (dirfd, int, (DIR *) _GL_ARG_NONNULL ((1)));
_GL_CXXALIAS_RPL (dirfd, int, (DIR *));
-# ifdef __KLIBC__
-/* Gnulib internal hooks needed to maintain the dirfd metadata. */
-_GL_EXTERN_C int _gl_register_dirp_fd (int fd, DIR *dirp)
- _GL_ARG_NONNULL ((2));
-_GL_EXTERN_C void _gl_unregister_dirp_fd (int fd);
-# endif
# else
# if defined __cplusplus && defined GNULIB_NAMESPACE && defined dirfd
/* dirfd is defined as a macro and not as a function.
diff --git a/lib/dirfd.c b/lib/dirfd.c
index 89b39c66636..afcf382e301 100644
--- a/lib/dirfd.c
+++ b/lib/dirfd.c
@@ -22,77 +22,23 @@
#include <dirent.h>
#include <errno.h>
-#ifdef __KLIBC__
-# include <stdlib.h>
-# include <io.h>
-
-static struct dirp_fd_list
-{
- DIR *dirp;
- int fd;
- struct dirp_fd_list *next;
-} *dirp_fd_start = NULL;
-
-/* Register fd associated with dirp to dirp_fd_list. */
-int
-_gl_register_dirp_fd (int fd, DIR *dirp)
-{
- struct dirp_fd_list *new_dirp_fd = malloc (sizeof *new_dirp_fd);
- if (!new_dirp_fd)
- return -1;
-
- new_dirp_fd->dirp = dirp;
- new_dirp_fd->fd = fd;
- new_dirp_fd->next = dirp_fd_start;
-
- dirp_fd_start = new_dirp_fd;
-
- return 0;
-}
-
-/* Unregister fd from dirp_fd_list with closing it */
-void
-_gl_unregister_dirp_fd (int fd)
-{
- struct dirp_fd_list *dirp_fd;
- struct dirp_fd_list *dirp_fd_prev;
-
- for (dirp_fd_prev = NULL, dirp_fd = dirp_fd_start; dirp_fd;
- dirp_fd_prev = dirp_fd, dirp_fd = dirp_fd->next)
- {
- if (dirp_fd->fd == fd)
- {
- if (dirp_fd_prev)
- dirp_fd_prev->next = dirp_fd->next;
- else /* dirp_fd == dirp_fd_start */
- dirp_fd_start = dirp_fd_start->next;
-
- close (fd);
- free (dirp_fd);
- break;
- }
- }
-}
+#if GNULIB_defined_DIR
+# include "dirent-private.h"
#endif
int
dirfd (DIR *dir_p)
{
+#if GNULIB_defined_DIR
+ int fd = dir_p->fd_to_close;
+ if (fd == -1)
+ errno = EINVAL;
+ return fd;
+#else
int fd = DIR_TO_FD (dir_p);
if (fd == -1)
-#ifndef __KLIBC__
errno = ENOTSUP;
-#else
- {
- struct dirp_fd_list *dirp_fd;
-
- for (dirp_fd = dirp_fd_start; dirp_fd; dirp_fd = dirp_fd->next)
- if (dirp_fd->dirp == dir_p)
- return dirp_fd->fd;
-
- errno = EINVAL;
- }
-#endif
return fd;
+#endif
}
diff --git a/lib/dup2.c b/lib/dup2.c
index 7e1960e48d3..916e113dd89 100644
--- a/lib/dup2.c
+++ b/lib/dup2.c
@@ -1,7 +1,6 @@
/* Duplicate an open file descriptor to a specified file descriptor.
- Copyright (C) 1999, 2004-2007, 2009-2024 Free Software Foundation,
- Inc.
+ Copyright (C) 1999, 2004-2007, 2009-2024 Free Software Foundation, Inc.
This file is free software: you can redistribute it and/or modify
it under the terms of the GNU Lesser General Public License as
diff --git a/lib/eloop-threshold.h b/lib/eloop-threshold.h
index 144fb674a21..84d19b458b8 100644
--- a/lib/eloop-threshold.h
+++ b/lib/eloop-threshold.h
@@ -19,6 +19,11 @@
#ifndef _ELOOP_THRESHOLD_H
#define _ELOOP_THRESHOLD_H 1
+/* This file uses _GL_ATTRIBUTE_CONST. */
+#if !_LIBC && !_GL_CONFIG_H_INCLUDED
+ #error "Please include config.h first."
+#endif
+
#include <limits.h>
#ifdef _LIBC
# include <sys/param.h>
diff --git a/lib/execinfo.in.h b/lib/execinfo.in.h
index 6a922276fa3..0ffb2c386e7 100644
--- a/lib/execinfo.in.h
+++ b/lib/execinfo.in.h
@@ -20,9 +20,11 @@
#ifndef _GL_EXECINFO_H
#define _GL_EXECINFO_H
-#ifndef _GL_INLINE_HEADER_BEGIN
+/* This file uses _GL_INLINE_HEADER_BEGIN, _GL_INLINE. */
+#if !_GL_CONFIG_H_INCLUDED
#error "Please include config.h first."
#endif
+
_GL_INLINE_HEADER_BEGIN
#ifndef _GL_EXECINFO_INLINE
# define _GL_EXECINFO_INLINE _GL_INLINE
diff --git a/lib/faccessat.c b/lib/faccessat.c
index f82eca2dbe3..8178ca8632e 100644
--- a/lib/faccessat.c
+++ b/lib/faccessat.c
@@ -40,10 +40,14 @@ orig_faccessat (int fd, char const *name, int mode, int flag)
}
#endif
+#ifdef __osf__
/* Write "unistd.h" here, not <unistd.h>, otherwise OSF/1 5.1 DTK cc
eliminates this include because of the preliminary #include <unistd.h>
above. */
-#include "unistd.h"
+# include "unistd.h"
+#else
+# include <unistd.h>
+#endif
#ifndef HAVE_ACCESS
/* Mingw lacks access, but it also lacks real vs. effective ids, so
diff --git a/lib/fcntl.in.h b/lib/fcntl.in.h
index 4bf1e198ce9..eea3b9542a5 100644
--- a/lib/fcntl.in.h
+++ b/lib/fcntl.in.h
@@ -74,6 +74,11 @@
#ifndef _@GUARD_PREFIX@_FCNTL_H
#define _@GUARD_PREFIX@_FCNTL_H
+/* This file uses GNULIB_POSIXCHECK, HAVE_RAW_DECL_*. */
+#if !_GL_CONFIG_H_INCLUDED
+ #error "Please include config.h first."
+#endif
+
#ifndef __GLIBC__ /* Avoid namespace pollution on glibc systems. */
# include <unistd.h>
#endif
diff --git a/lib/fdopendir.c b/lib/fdopendir.c
index a654a328dad..bdbb2ea912f 100644
--- a/lib/fdopendir.c
+++ b/lib/fdopendir.c
@@ -25,17 +25,40 @@
#if !HAVE_FDOPENDIR
-# include "openat.h"
-# include "openat-priv.h"
-# include "save-cwd.h"
+# if GNULIB_defined_DIR
+/* We are in control of the file descriptor of a DIR. */
-# if GNULIB_DIRENT_SAFER
-# include "dirent--.h"
-# endif
+# include "dirent-private.h"
-# ifndef REPLACE_FCHDIR
-# define REPLACE_FCHDIR 0
-# endif
+# if !REPLACE_FCHDIR
+# error "unexpected configuration: GNULIB_defined_DIR but fchdir not replaced"
+# endif
+
+DIR *
+fdopendir (int fd)
+{
+ char const *name = _gl_directory_name (fd);
+ DIR *dirp = name ? opendir (name) : NULL;
+ if (dirp != NULL)
+ dirp->fd_to_close = fd;
+ return dirp;
+}
+
+# else
+/* We are not in control of the file descriptor of a DIR, and therefore have to
+ play tricks with file descriptors before and after a call to opendir(). */
+
+# include "openat.h"
+# include "openat-priv.h"
+# include "save-cwd.h"
+
+# if GNULIB_DIRENT_SAFER
+# include "dirent--.h"
+# endif
+
+# ifndef REPLACE_FCHDIR
+# define REPLACE_FCHDIR 0
+# endif
static DIR *fdopendir_with_dup (int, int, struct saved_cwd const *);
static DIR *fd_clone_opendir (int, struct saved_cwd const *);
@@ -62,41 +85,6 @@ static DIR *fd_clone_opendir (int, struct saved_cwd const *);
If this function returns successfully, FD is under control of the
dirent.h system, and the caller should not close or modify the state of
FD other than by the dirent.h functions. */
-# ifdef __KLIBC__
-# include <InnoTekLIBC/backend.h>
-
-DIR *
-fdopendir (int fd)
-{
- char path[_MAX_PATH];
- DIR *dirp;
-
- /* Get a path from fd */
- if (__libc_Back_ioFHToPath (fd, path, sizeof (path)))
- return NULL;
-
- dirp = opendir (path);
- if (!dirp)
- return NULL;
-
- /* Unregister fd registered by opendir() */
- _gl_unregister_dirp_fd (dirfd (dirp));
-
- /* Register our fd */
- if (_gl_register_dirp_fd (fd, dirp))
- {
- int saved_errno = errno;
-
- closedir (dirp);
-
- errno = saved_errno;
-
- dirp = NULL;
- }
-
- return dirp;
-}
-# else
DIR *
fdopendir (int fd)
{
@@ -119,7 +107,6 @@ fdopendir (int fd)
return dir;
}
-# endif
/* Like fdopendir, except that if OLDER_DUPFD is not -1, it is known
to be a dup of FD which is less than FD - 1 and which will be
@@ -188,7 +175,7 @@ fd_clone_opendir (int fd, struct saved_cwd const *cwd)
if (proc_file != buf)
free (proc_file);
}
-# if REPLACE_FCHDIR
+# if REPLACE_FCHDIR
if (! dir && EXPECTED_ERRNO (saved_errno))
{
char const *name = _gl_directory_name (fd);
@@ -203,7 +190,7 @@ fd_clone_opendir (int fd, struct saved_cwd const *cwd)
return dp;
}
-# endif
+# endif
errno = saved_errno;
return dir;
}
@@ -223,6 +210,8 @@ fd_clone_opendir (int fd, struct saved_cwd const *cwd)
}
}
+# endif
+
#else /* HAVE_FDOPENDIR */
# include <errno.h>
diff --git a/lib/file-has-acl.c b/lib/file-has-acl.c
index 980a5956cc3..898fb030d1d 100644
--- a/lib/file-has-acl.c
+++ b/lib/file-has-acl.c
@@ -28,10 +28,122 @@
#include "acl.h"
#include "acl-internal.h"
+#include "attribute.h"
+#include "minmax.h"
-#if GETXATTR_WITH_POSIX_ACLS
+#if USE_ACL && HAVE_LINUX_XATTR_H && HAVE_LISTXATTR
+# include <stdckdint.h>
+# include <string.h>
+# include <arpa/inet.h>
# include <sys/xattr.h>
# include <linux/xattr.h>
+# ifndef XATTR_NAME_NFSV4_ACL
+# define XATTR_NAME_NFSV4_ACL "system.nfs4_acl"
+# endif
+# ifndef XATTR_NAME_POSIX_ACL_ACCESS
+# define XATTR_NAME_POSIX_ACL_ACCESS "system.posix_acl_access"
+# endif
+# ifndef XATTR_NAME_POSIX_ACL_DEFAULT
+# define XATTR_NAME_POSIX_ACL_DEFAULT "system.posix_acl_default"
+# endif
+
+enum {
+ /* ACE4_ACCESS_ALLOWED_ACE_TYPE = 0x00000000, */
+ ACE4_ACCESS_DENIED_ACE_TYPE = 0x00000001,
+ ACE4_IDENTIFIER_GROUP = 0x00000040
+};
+
+/* Return true if ATTR is in the set represented by the NUL-terminated
+ strings in LISTBUF, which is of size LISTSIZE. */
+
+ATTRIBUTE_PURE static bool
+have_xattr (char const *attr, char const *listbuf, ssize_t listsize)
+{
+ char const *blim = listbuf + listsize;
+ for (char const *b = listbuf; b < blim; b += strlen (b) + 1)
+ for (char const *a = attr; *a == *b; a++, b++)
+ if (!*a)
+ return true;
+ return false;
+}
+
+/* Return 1 if given ACL in XDR format is non-trivial, 0 if it is trivial.
+ -1 upon failure to determine it. Possibly change errno. Assume that
+ the ACL is valid, except avoid undefined behavior even if invalid.
+
+ See <https://linux.die.net/man/5/nfs4_acl>. The NFSv4 acls are
+ defined in Internet RFC 7530 and as such, every NFSv4 server
+ supporting ACLs should support NFSv4 ACLs (they differ from from
+ POSIX draft ACLs). The ACLs can be obtained via the
+ nfsv4-acl-tools, e.g., the nfs4_getfacl command. Gnulib provides
+ only basic support of NFSv4 ACLs, i.e., recognize trivial vs
+ nontrivial ACLs. */
+
+static int
+acl_nfs4_nontrivial (uint32_t *xattr, ssize_t nbytes)
+{
+ enum { BYTES_PER_NETWORK_UINT = 4};
+
+ /* Grab the number of aces in the acl. */
+ nbytes -= BYTES_PER_NETWORK_UINT;
+ if (nbytes < 0)
+ return -1;
+ uint32_t num_aces = ntohl (*xattr++);
+ if (6 < num_aces)
+ return 1;
+ int ace_found = 0;
+
+ for (int ace_n = 0; ace_n < num_aces; ace_n++)
+ {
+ /* Get the acl type and flag. Skip the mask; it's too risky to
+ test it and it does not seem to be needed. Get the wholen. */
+ nbytes -= 4 * BYTES_PER_NETWORK_UINT;
+ if (nbytes < 0)
+ return -1;
+ uint32_t type = ntohl (xattr[0]);
+ uint32_t flag = ntohl (xattr[1]);
+ uint32_t wholen = ntohl (xattr[3]);
+ xattr += 4;
+ int whowords = (wholen / BYTES_PER_NETWORK_UINT
+ + (wholen % BYTES_PER_NETWORK_UINT != 0));
+ int64_t wholen4 = whowords;
+ wholen4 *= BYTES_PER_NETWORK_UINT;
+
+ /* Trivial ACLs have only ACE4_ACCESS_ALLOWED_ACE_TYPE or
+ ACE4_ACCESS_DENIED_ACE_TYPE. */
+ if (ACE4_ACCESS_DENIED_ACE_TYPE < type)
+ return 1;
+
+ /* RFC 7530 says FLAG should be 0, but be generous to NetApp and
+ also accept the group flag. */
+ if (flag & ~ACE4_IDENTIFIER_GROUP)
+ return 1;
+
+ /* Get the who string. Check NBYTES - WHOLEN4 before storing
+ into NBYTES, to avoid truncation on conversion. */
+ if (nbytes - wholen4 < 0)
+ return -1;
+ nbytes -= wholen4;
+
+ /* For a trivial ACL, max 6 (typically 3) ACEs, 3 allow, 3 deny.
+ Check that there is at most one ACE of each TYPE and WHO. */
+ int who2
+ = (wholen == 6 && memcmp (xattr, "OWNER@", 6) == 0 ? 0
+ : wholen == 6 && memcmp (xattr, "GROUP@", 6) == 0 ? 2
+ : wholen == 9 && memcmp (xattr, "EVERYONE@", 9) == 0 ? 4
+ : -1);
+ if (who2 < 0)
+ return 1;
+ int ace_found_bit = 1 << (who2 | type);
+ if (ace_found & ace_found_bit)
+ return 1;
+ ace_found |= ace_found_bit;
+
+ xattr += whowords;
+ }
+
+ return 0;
+}
#endif
/* Return 1 if NAME has a nontrivial access control list,
@@ -48,25 +160,95 @@ file_has_acl (char const *name, struct stat const *sb)
if (! S_ISLNK (sb->st_mode))
{
-# if GETXATTR_WITH_POSIX_ACLS
-
- ssize_t ret;
+# if HAVE_LINUX_XATTR_H && HAVE_LISTXATTR
+ int initial_errno = errno;
+
+ /* The max length of a trivial NFSv4 ACL is 6 words for owner,
+ 6 for group, 7 for everyone, all times 2 because there are
+ both allow and deny ACEs. There are 6 words for owner
+ because of type, flag, mask, wholen, "OWNER@"+pad and
+ similarly for group; everyone is another word to hold
+ "EVERYONE@". */
+ typedef uint32_t trivial_NFSv4_xattr_buf[2 * (6 + 6 + 7)];
+
+ /* A buffer large enough to hold any trivial NFSv4 ACL,
+ and also useful as a small array of char. */
+ union {
+ trivial_NFSv4_xattr_buf xattr;
+ char ch[sizeof (trivial_NFSv4_xattr_buf)];
+ } stackbuf;
+
+ char *listbuf = stackbuf.ch;
+ ssize_t listbufsize = sizeof stackbuf.ch;
+ char *heapbuf = NULL;
+ ssize_t listsize;
+
+ /* Use listxattr first, as this means just one syscall in the
+ typical case where the file lacks an ACL. Try stackbuf
+ first, falling back on malloc if stackbuf is too small. */
+ while ((listsize = listxattr (name, listbuf, listbufsize)) < 0
+ && errno == ERANGE)
+ {
+ free (heapbuf);
+ ssize_t newsize = listxattr (name, NULL, 0);
+ if (newsize <= 0)
+ return newsize;
+
+ /* Grow LISTBUFSIZE to at least NEWSIZE. Grow it by a
+ nontrivial amount too, to defend against denial of
+ service by an adversary that fiddles with ACLs. */
+ bool overflow = ckd_add (&listbufsize, listbufsize, listbufsize >> 1);
+ listbufsize = MAX (listbufsize, newsize);
+ if (overflow || SIZE_MAX < listbufsize)
+ {
+ errno = ENOMEM;
+ return -1;
+ }
- ret = getxattr (name, XATTR_NAME_POSIX_ACL_ACCESS, NULL, 0);
- if (ret < 0 && errno == ENODATA)
- ret = 0;
- else if (ret > 0)
- return 1;
+ listbuf = heapbuf = malloc (listbufsize);
+ if (!listbuf)
+ return -1;
+ }
- if (ret == 0 && S_ISDIR (sb->st_mode))
+ /* In Fedora 39, a file can have both NFSv4 and POSIX ACLs,
+ but if it has an NFSv4 ACL that's the one that matters.
+ In earlier Fedora the two types of ACLs were mutually exclusive.
+ Attempt to work correctly on both kinds of systems. */
+ bool nfsv4_acl
+ = 0 < listsize && have_xattr (XATTR_NAME_NFSV4_ACL, listbuf, listsize);
+ int ret
+ = (listsize <= 0 ? listsize
+ : (nfsv4_acl
+ || have_xattr (XATTR_NAME_POSIX_ACL_ACCESS, listbuf, listsize)
+ || (S_ISDIR (sb->st_mode)
+ && have_xattr (XATTR_NAME_POSIX_ACL_DEFAULT,
+ listbuf, listsize))));
+ free (heapbuf);
+
+ /* If there is an NFSv4 ACL, follow up with a getxattr syscall
+ to see whether the NFSv4 ACL is nontrivial. */
+ if (nfsv4_acl)
{
- ret = getxattr (name, XATTR_NAME_POSIX_ACL_DEFAULT, NULL, 0);
- if (ret < 0 && errno == ENODATA)
- ret = 0;
- else if (ret > 0)
- return 1;
+ ret = getxattr (name, XATTR_NAME_NFSV4_ACL,
+ stackbuf.xattr, sizeof stackbuf.xattr);
+ if (ret < 0)
+ switch (errno)
+ {
+ case ENODATA: return 0;
+ case ERANGE : return 1; /* ACL must be nontrivial. */
+ }
+ else
+ {
+ /* It looks like a trivial ACL, but investigate further. */
+ ret = acl_nfs4_nontrivial (stackbuf.xattr, ret);
+ if (ret < 0)
+ {
+ errno = EINVAL;
+ return ret;
+ }
+ errno = initial_errno;
+ }
}
-
if (ret < 0)
return - acl_errno_valid (errno);
return ret;
diff --git a/lib/filemode.h b/lib/filemode.h
index d819b633222..2dee82f0be1 100644
--- a/lib/filemode.h
+++ b/lib/filemode.h
@@ -1,7 +1,7 @@
/* Make a string describing file modes.
- Copyright (C) 1998-1999, 2003, 2006, 2009-2024 Free Software
- Foundation, Inc.
+ Copyright (C) 1998-1999, 2003, 2006, 2009-2024 Free Software Foundation,
+ Inc.
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
@@ -17,6 +17,12 @@
along with this program. If not, see <https://www.gnu.org/licenses/>. */
#ifndef FILEMODE_H_
+# define FILEMODE_H_
+
+/* This file uses HAVE_DECL_STRMODE. */
+# if !_GL_CONFIG_H_INCLUDED
+# error "Please include config.h first."
+# endif
# include <sys/types.h>
# include <sys/stat.h>
diff --git a/lib/filevercmp.h b/lib/filevercmp.h
index c5b30ffcf46..8c549fcda00 100644
--- a/lib/filevercmp.h
+++ b/lib/filevercmp.h
@@ -20,6 +20,11 @@
#ifndef FILEVERCMP_H
#define FILEVERCMP_H
+/* This file uses _GL_ATTRIBUTE_PURE. */
+#if !_GL_CONFIG_H_INCLUDED
+ #error "Please include config.h first."
+#endif
+
#include <stddef.h>
/* Compare strings A and B as file names containing version numbers,
diff --git a/lib/flexmember.h b/lib/flexmember.h
index 12af5dc573e..6ef66a32d32 100644
--- a/lib/flexmember.h
+++ b/lib/flexmember.h
@@ -20,6 +20,11 @@
Written by Paul Eggert. */
+/* This file uses _Alignof. */
+#if !_GL_CONFIG_H_INCLUDED
+ #error "Please include config.h first."
+#endif
+
#include <stddef.h>
/* Nonzero multiple of alignment of TYPE, suitable for FLEXSIZEOF below.
@@ -38,7 +43,7 @@
followed by N bytes of other data. The result is suitable as an
argument to malloc. For example:
- struct s { int n; char d[FLEXIBLE_ARRAY_MEMBER]; };
+ struct s { int a; char d[FLEXIBLE_ARRAY_MEMBER]; };
struct s *p = malloc (FLEXSIZEOF (struct s, d, n * sizeof (char)));
FLEXSIZEOF (TYPE, MEMBER, N) is not simply (sizeof (TYPE) + N),
@@ -58,3 +63,14 @@
#define FLEXSIZEOF(type, member, n) \
((offsetof (type, member) + FLEXALIGNOF (type) - 1 + (n)) \
& ~ (FLEXALIGNOF (type) - 1))
+
+/* Yield a properly aligned upper bound on the size of a struct of
+ type TYPE with a flexible array member named MEMBER that has N
+ elements. The result is suitable as an argument to malloc.
+ For example:
+
+ struct s { int a; double d[FLEXIBLE_ARRAY_MEMBER]; };
+ struct s *p = malloc (FLEXNSIZEOF (struct s, d, n));
+ */
+#define FLEXNSIZEOF(type, member, n) \
+ FLEXSIZEOF (type, member, (n) * sizeof (((type *) 0)->member[0]))
diff --git a/lib/fpending.c b/lib/fpending.c
index 9193954ddb5..51468955844 100644
--- a/lib/fpending.c
+++ b/lib/fpending.c
@@ -1,6 +1,6 @@
/* fpending.c -- return the number of pending output bytes on a stream
- Copyright (C) 2000, 2004, 2006-2007, 2009-2024 Free Software
- Foundation, Inc.
+ Copyright (C) 2000, 2004, 2006-2007, 2009-2024 Free Software Foundation,
+ Inc.
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
@@ -41,7 +41,7 @@ __fpending (FILE *fp)
return fp->_IO_write_ptr - fp->_IO_write_base;
#elif defined __sferror || defined __DragonFly__ || defined __ANDROID__
/* FreeBSD, NetBSD, OpenBSD, DragonFly, Mac OS X, Cygwin < 1.7.34, Minix 3, Android */
- return fp->_p - fp->_bf._base;
+ return fp_->_p - fp_->_bf._base;
#elif defined __EMX__ /* emx+gcc */
return fp->_ptr - fp->_buffer;
#elif defined __minix /* Minix */
diff --git a/lib/fpending.h b/lib/fpending.h
index 8ba7c1f81b5..28db3b403d9 100644
--- a/lib/fpending.h
+++ b/lib/fpending.h
@@ -1,7 +1,7 @@
/* Declare __fpending.
- Copyright (C) 2000, 2003, 2005-2006, 2009-2024 Free Software
- Foundation, Inc.
+ Copyright (C) 2000, 2003, 2005-2006, 2009-2024 Free Software Foundation,
+ Inc.
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
@@ -18,6 +18,12 @@
Written by Jim Meyering. */
+/* This file uses _GL_ATTRIBUTE_PURE, HAVE_STDIO_EXT_H,
+ HAVE_DECL___FPENDING. */
+#if !_GL_CONFIG_H_INCLUDED
+ #error "Please include config.h first."
+#endif
+
#include <stddef.h>
#include <stdio.h>
#if HAVE_STDIO_EXT_H
diff --git a/lib/fsusage.c b/lib/fsusage.c
index d99a02f01f3..97d0eef7aa8 100644
--- a/lib/fsusage.c
+++ b/lib/fsusage.c
@@ -1,7 +1,7 @@
/* fsusage.c -- return space usage of mounted file systems
- Copyright (C) 1991-1992, 1996, 1998-1999, 2002-2006, 2009-2024 Free
- Software Foundation, Inc.
+ Copyright (C) 1991-1992, 1996, 1998-1999, 2002-2006, 2009-2024 Free Software
+ Foundation, Inc.
This file is free software: you can redistribute it and/or modify
it under the terms of the GNU Lesser General Public License as
diff --git a/lib/getdelim.c b/lib/getdelim.c
new file mode 100644
index 00000000000..58063b156e7
--- /dev/null
+++ b/lib/getdelim.c
@@ -0,0 +1,143 @@
+/* getdelim.c --- Implementation of replacement getdelim function.
+ Copyright (C) 1994, 1996-1998, 2001, 2003, 2005-2024 Free Software
+ Foundation, Inc.
+
+ This file is free software: you can redistribute it and/or modify
+ it under the terms of the GNU Lesser General Public License as
+ published by the Free Software Foundation; either version 2.1 of the
+ License, or (at your option) any later version.
+
+ This file 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 Lesser General Public License for more details.
+
+ You should have received a copy of the GNU Lesser General Public License
+ along with this program. If not, see <https://www.gnu.org/licenses/>. */
+
+/* Ported from glibc by Simon Josefsson. */
+
+/* Don't use __attribute__ __nonnull__ in this compilation unit. Otherwise gcc
+ optimizes away the lineptr == NULL || n == NULL || fp == NULL tests below. */
+#define _GL_ARG_NONNULL(params)
+
+#include <config.h>
+
+#include <stdio.h>
+
+#include <limits.h>
+#include <stdint.h>
+#include <stdlib.h>
+#include <errno.h>
+
+#if USE_UNLOCKED_IO
+# include "unlocked-io.h"
+# define getc_maybe_unlocked(fp) getc(fp)
+#elif !HAVE_FLOCKFILE || !HAVE_FUNLOCKFILE || !HAVE_DECL_GETC_UNLOCKED
+# undef flockfile
+# undef funlockfile
+# define flockfile(x) ((void) 0)
+# define funlockfile(x) ((void) 0)
+# define getc_maybe_unlocked(fp) getc(fp)
+#else
+# define getc_maybe_unlocked(fp) getc_unlocked(fp)
+#endif
+
+static void
+alloc_failed (void)
+{
+#if defined _WIN32 && ! defined __CYGWIN__
+ /* Avoid errno problem without using the realloc module; see:
+ https://lists.gnu.org/r/bug-gnulib/2016-08/msg00025.html */
+ errno = ENOMEM;
+#endif
+}
+
+/* Read up to (and including) a DELIMITER from FP into *LINEPTR (and
+ NUL-terminate it). *LINEPTR is a pointer returned from malloc (or
+ NULL), pointing to *N characters of space. It is realloc'ed as
+ necessary. Returns the number of characters read (not including
+ the null terminator), or -1 on error or EOF. */
+
+ssize_t
+getdelim (char **lineptr, size_t *n, int delimiter, FILE *fp)
+{
+ ssize_t result;
+ size_t cur_len = 0;
+
+ if (lineptr == NULL || n == NULL || fp == NULL)
+ {
+ errno = EINVAL;
+ return -1;
+ }
+
+ flockfile (fp);
+
+ if (*lineptr == NULL || *n == 0)
+ {
+ char *new_lineptr;
+ *n = 120;
+ new_lineptr = (char *) realloc (*lineptr, *n);
+ if (new_lineptr == NULL)
+ {
+ alloc_failed ();
+ result = -1;
+ goto unlock_return;
+ }
+ *lineptr = new_lineptr;
+ }
+
+ for (;;)
+ {
+ int i;
+
+ i = getc_maybe_unlocked (fp);
+ if (i == EOF)
+ {
+ result = -1;
+ break;
+ }
+
+ /* Make enough space for len+1 (for final NUL) bytes. */
+ if (cur_len + 1 >= *n)
+ {
+ size_t needed_max =
+ SSIZE_MAX < SIZE_MAX ? (size_t) SSIZE_MAX + 1 : SIZE_MAX;
+ size_t needed = 2 * *n + 1; /* Be generous. */
+ char *new_lineptr;
+
+ if (needed_max < needed)
+ needed = needed_max;
+ if (cur_len + 1 >= needed)
+ {
+ result = -1;
+ errno = EOVERFLOW;
+ goto unlock_return;
+ }
+
+ new_lineptr = (char *) realloc (*lineptr, needed);
+ if (new_lineptr == NULL)
+ {
+ alloc_failed ();
+ result = -1;
+ goto unlock_return;
+ }
+
+ *lineptr = new_lineptr;
+ *n = needed;
+ }
+
+ (*lineptr)[cur_len] = i;
+ cur_len++;
+
+ if (i == delimiter)
+ break;
+ }
+ (*lineptr)[cur_len] = '\0';
+ result = cur_len ? cur_len : result;
+
+ unlock_return:
+ funlockfile (fp); /* doesn't set errno */
+
+ return result;
+}
diff --git a/lib/getgroups.c b/lib/getgroups.c
index 346954adaad..9f4908e9977 100644
--- a/lib/getgroups.c
+++ b/lib/getgroups.c
@@ -1,7 +1,6 @@
/* provide consistent interface to getgroups for systems that don't allow N==0
- Copyright (C) 1996, 1999, 2003, 2006-2024 Free Software Foundation,
- Inc.
+ Copyright (C) 1996, 1999, 2003, 2006-2024 Free Software Foundation, Inc.
This file is free software: you can redistribute it and/or modify
it under the terms of the GNU Lesser General Public License as
diff --git a/lib/getline.c b/lib/getline.c
new file mode 100644
index 00000000000..2d03b64689e
--- /dev/null
+++ b/lib/getline.c
@@ -0,0 +1,27 @@
+/* getline.c --- Implementation of replacement getline function.
+ Copyright (C) 2005-2007, 2009-2024 Free Software Foundation, Inc.
+
+ This file is free software: you can redistribute it and/or modify
+ it under the terms of the GNU Lesser General Public License as
+ published by the Free Software Foundation; either version 2.1 of the
+ License, or (at your option) any later version.
+
+ This file 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 Lesser General Public License for more details.
+
+ You should have received a copy of the GNU Lesser General Public License
+ along with this program. If not, see <https://www.gnu.org/licenses/>. */
+
+/* Written by Simon Josefsson. */
+
+#include <config.h>
+
+#include <stdio.h>
+
+ssize_t
+getline (char **lineptr, size_t *n, FILE *stream)
+{
+ return getdelim (lineptr, n, '\n', stream);
+}
diff --git a/lib/getloadavg.c b/lib/getloadavg.c
index 7f0a236c870..c940e4c7ee0 100644
--- a/lib/getloadavg.c
+++ b/lib/getloadavg.c
@@ -1,7 +1,7 @@
/* Get the system load averages.
- Copyright (C) 1985-1989, 1991-1995, 1997, 1999-2000, 2003-2024 Free
- Software Foundation, Inc.
+ Copyright (C) 1985-1989, 1991-1995, 1997, 1999-2000, 2003-2024 Free Software
+ Foundation, Inc.
NOTE: The canonical source of this file is maintained with gnulib.
Bugs can be reported to bug-gnulib@gnu.org.
diff --git a/lib/getopt-cdefs.in.h b/lib/getopt-cdefs.in.h
index 7a791392de5..a1d304d49e8 100644
--- a/lib/getopt-cdefs.in.h
+++ b/lib/getopt-cdefs.in.h
@@ -57,7 +57,11 @@
#ifndef __THROW
# if defined __cplusplus && (__GNUC_PREREQ (2,8) || __clang_major__ >= 4)
-# define __THROW throw ()
+# if __cplusplus >= 201103L
+# define __THROW noexcept (true)
+# else
+# define __THROW throw ()
+# endif
# else
# define __THROW
# endif
diff --git a/lib/getopt-pfx-core.h b/lib/getopt-pfx-core.h
index 4167f322323..78b7816aa42 100644
--- a/lib/getopt-pfx-core.h
+++ b/lib/getopt-pfx-core.h
@@ -47,7 +47,7 @@
# define optind __GETOPT_ID (optind)
# define optopt __GETOPT_ID (optopt)
-/* Work around a a problem on macOS, which declares getopt with a
+/* Work around a problem on macOS, which declares getopt with a
trailing __DARWIN_ALIAS(getopt) that would expand to something like
__asm("_" "rpl_getopt" "$UNIX2003") were it not for the following
hack to suppress the macOS declaration <https://bugs.gnu.org/40205>. */
diff --git a/lib/getopt.c b/lib/getopt.c
index e2951f74601..f66f119ec50 100644
--- a/lib/getopt.c
+++ b/lib/getopt.c
@@ -21,7 +21,7 @@
# include <config.h>
#endif
-#include "getopt.h"
+#include <getopt.h>
#include <stdio.h>
#include <stdlib.h>
@@ -223,8 +223,9 @@ process_long_option (int argc, char **argv, const char *optstring,
{
/* Didn't find an exact match, so look for abbreviations. */
unsigned char *ambig_set = NULL;
- int ambig_malloced = 0;
- int ambig_fallback = 0;
+ /* Use simpler fallback diagnostic if ambig_set == &ambig_fallback. */
+ unsigned char ambig_fallback;
+ void *ambig_malloced = NULL;
int indfound = -1;
for (p = longopts, option_index = 0; p->name; p++, option_index++)
@@ -242,39 +243,42 @@ process_long_option (int argc, char **argv, const char *optstring,
|| pfound->val != p->val)
{
/* Second or later nonexact match found. */
- if (!ambig_fallback)
+ if (ambig_set != &ambig_fallback)
{
if (!print_errors)
/* Don't waste effort tracking the ambig set if
we're not going to print it anyway. */
- ambig_fallback = 1;
+ ambig_set = &ambig_fallback;
else if (!ambig_set)
{
if (__libc_use_alloca (n_options))
ambig_set = alloca (n_options);
- else if ((ambig_set = malloc (n_options)) == NULL)
- /* Fall back to simpler error message. */
- ambig_fallback = 1;
else
- ambig_malloced = 1;
+ {
+ ambig_malloced = malloc (n_options);
+ /* Fall back to simpler diagnostic if
+ memory allocation fails. */
+ ambig_set = (ambig_malloced ? ambig_malloced
+ : &ambig_fallback);
+ }
- if (ambig_set)
+ if (ambig_set != &ambig_fallback)
{
memset (ambig_set, 0, n_options);
ambig_set[indfound] = 1;
}
}
- if (ambig_set)
+ if (ambig_set && ambig_set != &ambig_fallback)
ambig_set[option_index] = 1;
}
}
}
- if (ambig_set || ambig_fallback)
+ if (ambig_set)
{
if (print_errors)
{
- if (ambig_fallback)
+ if (ambig_set == &ambig_fallback)
fprintf (stderr, _("%s: option '%s%s' is ambiguous\n"),
argv[0], prefix, d->__nextchar);
else
@@ -296,8 +300,7 @@ process_long_option (int argc, char **argv, const char *optstring,
funlockfile (stderr);
}
}
- if (ambig_malloced)
- free (ambig_set);
+ free (ambig_malloced);
d->__nextchar += strlen (d->__nextchar);
d->optind++;
d->optopt = 0;
diff --git a/lib/getopt1.c b/lib/getopt1.c
index 0c8e29b5b91..c42d29f8b57 100644
--- a/lib/getopt1.c
+++ b/lib/getopt1.c
@@ -21,7 +21,7 @@
# include <config.h>
#endif
-#include "getopt.h"
+#include <getopt.h>
#include "getopt_int.h"
int
diff --git a/lib/gettext.h b/lib/gettext.h
index 970032306e5..39d5ae4daa5 100644
--- a/lib/gettext.h
+++ b/lib/gettext.h
@@ -1,6 +1,6 @@
/* Convenience header for conditional use of GNU <libintl.h>.
- Copyright (C) 1995-1998, 2000-2002, 2004-2006, 2009-2024 Free
- Software Foundation, Inc.
+ Copyright (C) 1995-1998, 2000-2002, 2004-2006, 2009-2024 Free Software
+ Foundation, Inc.
This file is free software: you can redistribute it and/or modify
it under the terms of the GNU Lesser General Public License as
diff --git a/lib/gettime.c b/lib/gettime.c
index fff502bd19c..38d36859415 100644
--- a/lib/gettime.c
+++ b/lib/gettime.c
@@ -1,7 +1,6 @@
/* gettime -- get the system clock
- Copyright (C) 2002, 2004-2007, 2009-2024 Free Software Foundation,
- Inc.
+ Copyright (C) 2002, 2004-2007, 2009-2024 Free Software Foundation, Inc.
This file is free software: you can redistribute it and/or modify
it under the terms of the GNU Lesser General Public License as
@@ -36,8 +35,8 @@ gettime (struct timespec *ts)
#else
struct timeval tv;
gettimeofday (&tv, NULL);
- ts->tv_sec = tv.tv_sec;
- ts->tv_nsec = tv.tv_usec * 1000;
+ *ts = (struct timespec) { .tv_sec = tv.tv_sec,
+ .tv_nsec = tv.tv_usec * 1000 };
#endif
}
diff --git a/lib/gettimeofday.c b/lib/gettimeofday.c
index 5d441f116a3..8dd26f73c03 100644
--- a/lib/gettimeofday.c
+++ b/lib/gettimeofday.c
@@ -1,7 +1,6 @@
/* Provide gettimeofday for systems that don't have it or for which it's broken.
- Copyright (C) 2001-2003, 2005-2007, 2009-2024 Free Software
- Foundation, Inc.
+ Copyright (C) 2001-2003, 2005-2007, 2009-2024 Free Software Foundation, Inc.
This file is free software: you can redistribute it and/or modify
it under the terms of the GNU Lesser General Public License as
@@ -114,8 +113,10 @@ gettimeofday (struct timeval *restrict tv, void *restrict tz)
ULONGLONG since_1970 =
since_1601 - (ULONGLONG) 134774 * (ULONGLONG) 86400 * (ULONGLONG) 10000000;
ULONGLONG microseconds_since_1970 = since_1970 / (ULONGLONG) 10;
- tv->tv_sec = microseconds_since_1970 / (ULONGLONG) 1000000;
- tv->tv_usec = microseconds_since_1970 % (ULONGLONG) 1000000;
+ *tv = (struct timeval) {
+ .tv_sec = microseconds_since_1970 / (ULONGLONG) 1000000,
+ .tv_usec = microseconds_since_1970 % (ULONGLONG) 1000000
+ };
return 0;
@@ -128,10 +129,7 @@ gettimeofday (struct timeval *restrict tv, void *restrict tz)
struct timeval otv;
int result = gettimeofday (&otv, (struct timezone *) tz);
if (result == 0)
- {
- tv->tv_sec = otv.tv_sec;
- tv->tv_usec = otv.tv_usec;
- }
+ *tv = otv;
# else
int result = gettimeofday (tv, (struct timezone *) tz);
# endif
@@ -144,8 +142,7 @@ gettimeofday (struct timeval *restrict tv, void *restrict tz)
# error "Only 1-second nominal clock resolution found. Is that intended?" \
"If so, compile with the -DOK_TO_USE_1S_CLOCK option."
# endif
- tv->tv_sec = time (NULL);
- tv->tv_usec = 0;
+ *tv = (struct timeval) { .tv_sec = time (NULL), .tv_usec = 0 };
return 0;
diff --git a/lib/gnulib.mk.in b/lib/gnulib.mk.in
index 2cc887f6f7c..711ddcf1260 100644
--- a/lib/gnulib.mk.in
+++ b/lib/gnulib.mk.in
@@ -34,6 +34,7 @@
# --no-libtool \
# --macro-prefix=gl \
# --no-vc-files \
+# --avoid=access \
# --avoid=btowc \
# --avoid=chmod \
# --avoid=close \
@@ -41,7 +42,12 @@
# --avoid=dup \
# --avoid=fchdir \
# --avoid=fstat \
+# --avoid=iswblank \
+# --avoid=iswctype \
+# --avoid=iswdigit \
+# --avoid=iswxdigit \
# --avoid=langinfo \
+# --avoid=localename-unsafe-limited \
# --avoid=lock \
# --avoid=mbrtowc \
# --avoid=mbsinit \
@@ -67,9 +73,12 @@
# --avoid=utime-h \
# --avoid=wchar \
# --avoid=wcrtomb \
+# --avoid=wctype \
# --avoid=wctype-h \
+# alignasof \
# alloca-opt \
# binary-io \
+# boot-time \
# byteswap \
# c-ctype \
# c-strcase \
@@ -93,7 +102,6 @@
# dup2 \
# environ \
# execinfo \
-# explicit_bzero \
# faccessat \
# fchmodat \
# fcntl \
@@ -110,6 +118,7 @@
# fsusage \
# fsync \
# futimens \
+# getline \
# getloadavg \
# getopt-gnu \
# getrandom \
@@ -126,6 +135,7 @@
# memmem-simple \
# mempcpy \
# memrchr \
+# memset_explicit \
# minmax \
# mkostemp \
# mktime \
@@ -145,8 +155,8 @@
# socklen \
# stat-time \
# std-gnu11 \
-# stdalign \
# stdbool \
+# stdckdint \
# stddef \
# stdio \
# stpcpy \
@@ -156,7 +166,7 @@
# sys_stat \
# sys_time \
# tempname \
-# time \
+# time-h \
# time_r \
# time_rz \
# timegm \
@@ -167,16 +177,34 @@
# update-copyright \
# utimensat \
# vla \
-# warnings
+# warnings \
+# year2038
MOSTLYCLEANFILES += core *.stackdump
# Start of GNU Make output.
+AAPT = @AAPT@
ALLOCA = @ALLOCA@
ALLOCA_H = @ALLOCA_H@
ALSA_CFLAGS = @ALSA_CFLAGS@
ALSA_LIBS = @ALSA_LIBS@
AM_DEFAULT_VERBOSITY = @AM_DEFAULT_VERBOSITY@
+ANDROID = @ANDROID@
+ANDROID_ABI = @ANDROID_ABI@
+ANDROID_BUILD_CFLAGS = @ANDROID_BUILD_CFLAGS@
+ANDROID_CC = @ANDROID_CC@
+ANDROID_CFLAGS = @ANDROID_CFLAGS@
+ANDROID_DEBUGGABLE = @ANDROID_DEBUGGABLE@
+ANDROID_JAR = @ANDROID_JAR@
+ANDROID_LDFLAGS = @ANDROID_LDFLAGS@
+ANDROID_LIBS = @ANDROID_LIBS@
+ANDROID_MIN_SDK = @ANDROID_MIN_SDK@
+ANDROID_OBJ = @ANDROID_OBJ@
+ANDROID_SDK_18_OR_EARLIER = @ANDROID_SDK_18_OR_EARLIER@
+ANDROID_SDK_8_OR_EARLIER = @ANDROID_SDK_8_OR_EARLIER@
+ANDROID_SHARED_USER_ID = @ANDROID_SHARED_USER_ID@
+ANDROID_SHARED_USER_NAME = @ANDROID_SHARED_USER_NAME@
+APKSIGNER = @APKSIGNER@
APPLE_UNIVERSAL_BUILD = @APPLE_UNIVERSAL_BUILD@
AR = @AR@
ARFLAGS = @ARFLAGS@
@@ -204,6 +232,7 @@ CFLAGS_SOUND = @CFLAGS_SOUND@
CHECK_STRUCTS = @CHECK_STRUCTS@
CLIENTRES = @CLIENTRES@
CLIENTW = @CLIENTW@
+CLOCK_TIME_LIB = @CLOCK_TIME_LIB@
CM_OBJ = @CM_OBJ@
COM_ERRLIB = @COM_ERRLIB@
CPP = @CPP@
@@ -215,11 +244,13 @@ CYGWIN_OBJ = @CYGWIN_OBJ@
C_SWITCH_MACHINE = @C_SWITCH_MACHINE@
C_SWITCH_SYSTEM = @C_SWITCH_SYSTEM@
C_SWITCH_X_SITE = @C_SWITCH_X_SITE@
+D8 = @D8@
DBUS_CFLAGS = @DBUS_CFLAGS@
DBUS_LIBS = @DBUS_LIBS@
DBUS_OBJ = @DBUS_OBJ@
DEFS = @DEFS@
DESLIB = @DESLIB@
+DIR_HAS_FD_MEMBER = @DIR_HAS_FD_MEMBER@
DOCMISC_W32 = @DOCMISC_W32@
DUMPING = @DUMPING@
DYNAMIC_LIB_SECONDARY_SUFFIX = @DYNAMIC_LIB_SECONDARY_SUFFIX@
@@ -238,8 +269,10 @@ ENOLINK_VALUE = @ENOLINK_VALUE@
EOVERFLOW_HIDDEN = @EOVERFLOW_HIDDEN@
EOVERFLOW_VALUE = @EOVERFLOW_VALUE@
ERRNO_H = @ERRNO_H@
+EUIDACCESS_LIBGEN = @EUIDACCESS_LIBGEN@
EXECINFO_H = @EXECINFO_H@
EXEEXT = @EXEEXT@
+FILE_HAS_ACL_LIB = @FILE_HAS_ACL_LIB@
FIND_DELETE = @FIND_DELETE@
FIRSTFILE_OBJ = @FIRSTFILE_OBJ@
FONTCONFIG_CFLAGS = @FONTCONFIG_CFLAGS@
@@ -253,8 +286,10 @@ GETADDRINFO_A_LIBS = @GETADDRINFO_A_LIBS@
GETLOADAVG_LIBS = @GETLOADAVG_LIBS@
GETOPT_CDEFS_H = @GETOPT_CDEFS_H@
GETOPT_H = @GETOPT_H@
+GETRANDOM_LIB = @GETRANDOM_LIB@
GFILENOTIFY_CFLAGS = @GFILENOTIFY_CFLAGS@
GFILENOTIFY_LIBS = @GFILENOTIFY_LIBS@
+GIF_CFLAGS = @GIF_CFLAGS@
GL_CFLAG_ALLOW_WARNINGS = @GL_CFLAG_ALLOW_WARNINGS@
GL_CFLAG_GNULIB_WARNINGS = @GL_CFLAG_GNULIB_WARNINGS@
GL_COND_LIBTOOL_CONDITION = @GL_COND_LIBTOOL_CONDITION@
@@ -264,7 +299,6 @@ GL_COND_OBJ_DIRFD_CONDITION = @GL_COND_OBJ_DIRFD_CONDITION@
GL_COND_OBJ_DUP2_CONDITION = @GL_COND_OBJ_DUP2_CONDITION@
GL_COND_OBJ_EUIDACCESS_CONDITION = @GL_COND_OBJ_EUIDACCESS_CONDITION@
GL_COND_OBJ_EXECINFO_CONDITION = @GL_COND_OBJ_EXECINFO_CONDITION@
-GL_COND_OBJ_EXPLICIT_BZERO_CONDITION = @GL_COND_OBJ_EXPLICIT_BZERO_CONDITION@
GL_COND_OBJ_FACCESSAT_CONDITION = @GL_COND_OBJ_FACCESSAT_CONDITION@
GL_COND_OBJ_FCHMODAT_CONDITION = @GL_COND_OBJ_FCHMODAT_CONDITION@
GL_COND_OBJ_FCNTL_CONDITION = @GL_COND_OBJ_FCNTL_CONDITION@
@@ -275,8 +309,10 @@ GL_COND_OBJ_FSTATAT_CONDITION = @GL_COND_OBJ_FSTATAT_CONDITION@
GL_COND_OBJ_FSUSAGE_CONDITION = @GL_COND_OBJ_FSUSAGE_CONDITION@
GL_COND_OBJ_FSYNC_CONDITION = @GL_COND_OBJ_FSYNC_CONDITION@
GL_COND_OBJ_FUTIMENS_CONDITION = @GL_COND_OBJ_FUTIMENS_CONDITION@
+GL_COND_OBJ_GETDELIM_CONDITION = @GL_COND_OBJ_GETDELIM_CONDITION@
GL_COND_OBJ_GETDTABLESIZE_CONDITION = @GL_COND_OBJ_GETDTABLESIZE_CONDITION@
GL_COND_OBJ_GETGROUPS_CONDITION = @GL_COND_OBJ_GETGROUPS_CONDITION@
+GL_COND_OBJ_GETLINE_CONDITION = @GL_COND_OBJ_GETLINE_CONDITION@
GL_COND_OBJ_GETLOADAVG_CONDITION = @GL_COND_OBJ_GETLOADAVG_CONDITION@
GL_COND_OBJ_GETOPT_CONDITION = @GL_COND_OBJ_GETOPT_CONDITION@
GL_COND_OBJ_GETRANDOM_CONDITION = @GL_COND_OBJ_GETRANDOM_CONDITION@
@@ -286,6 +322,7 @@ GL_COND_OBJ_LCHMOD_CONDITION = @GL_COND_OBJ_LCHMOD_CONDITION@
GL_COND_OBJ_LSTAT_CONDITION = @GL_COND_OBJ_LSTAT_CONDITION@
GL_COND_OBJ_MEMPCPY_CONDITION = @GL_COND_OBJ_MEMPCPY_CONDITION@
GL_COND_OBJ_MEMRCHR_CONDITION = @GL_COND_OBJ_MEMRCHR_CONDITION@
+GL_COND_OBJ_MEMSET_EXPLICIT_CONDITION = @GL_COND_OBJ_MEMSET_EXPLICIT_CONDITION@
GL_COND_OBJ_MINI_GMP_GNULIB_CONDITION = @GL_COND_OBJ_MINI_GMP_GNULIB_CONDITION@
GL_COND_OBJ_MKOSTEMP_CONDITION = @GL_COND_OBJ_MKOSTEMP_CONDITION@
GL_COND_OBJ_NANOSLEEP_CONDITION = @GL_COND_OBJ_NANOSLEEP_CONDITION@
@@ -321,7 +358,6 @@ GL_GENERATE_GMP_H_CONDITION = @GL_GENERATE_GMP_H_CONDITION@
GL_GENERATE_IEEE754_H_CONDITION = @GL_GENERATE_IEEE754_H_CONDITION@
GL_GENERATE_LIMITS_H_CONDITION = @GL_GENERATE_LIMITS_H_CONDITION@
GL_GENERATE_MINI_GMP_H_CONDITION = @GL_GENERATE_MINI_GMP_H_CONDITION@
-GL_GENERATE_STDALIGN_H_CONDITION = @GL_GENERATE_STDALIGN_H_CONDITION@
GL_GENERATE_STDCKDINT_H_CONDITION = @GL_GENERATE_STDCKDINT_H_CONDITION@
GL_GENERATE_STDDEF_H_CONDITION = @GL_GENERATE_STDDEF_H_CONDITION@
GL_GENERATE_STDINT_H_CONDITION = @GL_GENERATE_STDINT_H_CONDITION@
@@ -407,6 +443,7 @@ GL_GNULIB_GETOPT_POSIX = @GL_GNULIB_GETOPT_POSIX@
GL_GNULIB_GETPAGESIZE = @GL_GNULIB_GETPAGESIZE@
GL_GNULIB_GETPASS = @GL_GNULIB_GETPASS@
GL_GNULIB_GETPASS_GNU = @GL_GNULIB_GETPASS_GNU@
+GL_GNULIB_GETPROGNAME = @GL_GNULIB_GETPROGNAME@
GL_GNULIB_GETRANDOM = @GL_GNULIB_GETRANDOM@
GL_GNULIB_GETSUBOPT = @GL_GNULIB_GETSUBOPT@
GL_GNULIB_GETTIMEOFDAY = @GL_GNULIB_GETTIMEOFDAY@
@@ -440,6 +477,7 @@ GL_GNULIB_MBSSEP = @GL_GNULIB_MBSSEP@
GL_GNULIB_MBSSPN = @GL_GNULIB_MBSSPN@
GL_GNULIB_MBSSTR = @GL_GNULIB_MBSSTR@
GL_GNULIB_MBSTOK_R = @GL_GNULIB_MBSTOK_R@
+GL_GNULIB_MBSTOWCS = @GL_GNULIB_MBSTOWCS@
GL_GNULIB_MBTOWC = @GL_GNULIB_MBTOWC@
GL_GNULIB_MDA_ACCESS = @GL_GNULIB_MDA_ACCESS@
GL_GNULIB_MDA_CHDIR = @GL_GNULIB_MDA_CHDIR@
@@ -485,6 +523,7 @@ GL_GNULIB_MEMCHR = @GL_GNULIB_MEMCHR@
GL_GNULIB_MEMMEM = @GL_GNULIB_MEMMEM@
GL_GNULIB_MEMPCPY = @GL_GNULIB_MEMPCPY@
GL_GNULIB_MEMRCHR = @GL_GNULIB_MEMRCHR@
+GL_GNULIB_MEMSET_EXPLICIT = @GL_GNULIB_MEMSET_EXPLICIT@
GL_GNULIB_MKDIR = @GL_GNULIB_MKDIR@
GL_GNULIB_MKDIRAT = @GL_GNULIB_MKDIRAT@
GL_GNULIB_MKDTEMP = @GL_GNULIB_MKDTEMP@
@@ -526,6 +565,7 @@ GL_GNULIB_PUTS = @GL_GNULIB_PUTS@
GL_GNULIB_PWRITE = @GL_GNULIB_PWRITE@
GL_GNULIB_QSORT_R = @GL_GNULIB_QSORT_R@
GL_GNULIB_RAISE = @GL_GNULIB_RAISE@
+GL_GNULIB_RAND = @GL_GNULIB_RAND@
GL_GNULIB_RANDOM = @GL_GNULIB_RANDOM@
GL_GNULIB_RANDOM_R = @GL_GNULIB_RANDOM_R@
GL_GNULIB_RAWMEMCHR = @GL_GNULIB_RAWMEMCHR@
@@ -590,6 +630,7 @@ GL_GNULIB_STRVERSCMP = @GL_GNULIB_STRVERSCMP@
GL_GNULIB_SYMLINK = @GL_GNULIB_SYMLINK@
GL_GNULIB_SYMLINKAT = @GL_GNULIB_SYMLINKAT@
GL_GNULIB_SYSTEM_POSIX = @GL_GNULIB_SYSTEM_POSIX@
+GL_GNULIB_TIME = @GL_GNULIB_TIME@
GL_GNULIB_TIMEGM = @GL_GNULIB_TIMEGM@
GL_GNULIB_TIMESPEC_GET = @GL_GNULIB_TIMESPEC_GET@
GL_GNULIB_TIMESPEC_GETRES = @GL_GNULIB_TIMESPEC_GETRES@
@@ -624,7 +665,6 @@ GL_GNULIB__EXIT = @GL_GNULIB__EXIT@
GMALLOC_OBJ = @GMALLOC_OBJ@
GMP_H = @GMP_H@
GNULIBHEADERS_OVERRIDE_WINT_T = @GNULIBHEADERS_OVERRIDE_WINT_T@
-GNULIB_GETTIMEOFDAY = @GNULIB_GETTIMEOFDAY@
GNULIB_WARN_CFLAGS = @GNULIB_WARN_CFLAGS@
GNUSTEP_CFLAGS = @GNUSTEP_CFLAGS@
GNU_OBJC_CFLAGS = @GNU_OBJC_CFLAGS@
@@ -674,6 +714,7 @@ HAVE_DECL_GETLOGIN = @HAVE_DECL_GETLOGIN@
HAVE_DECL_GETLOGIN_R = @HAVE_DECL_GETLOGIN_R@
HAVE_DECL_GETPAGESIZE = @HAVE_DECL_GETPAGESIZE@
HAVE_DECL_GETUSERSHELL = @HAVE_DECL_GETUSERSHELL@
+HAVE_DECL_GETW = @HAVE_DECL_GETW@
HAVE_DECL_IMAXABS = @HAVE_DECL_IMAXABS@
HAVE_DECL_IMAXDIV = @HAVE_DECL_IMAXDIV@
HAVE_DECL_INITSTATE = @HAVE_DECL_INITSTATE@
@@ -682,6 +723,8 @@ HAVE_DECL_MEMMEM = @HAVE_DECL_MEMMEM@
HAVE_DECL_MEMRCHR = @HAVE_DECL_MEMRCHR@
HAVE_DECL_OBSTACK_PRINTF = @HAVE_DECL_OBSTACK_PRINTF@
HAVE_DECL_POSIX_SPAWN_SETSID = @HAVE_DECL_POSIX_SPAWN_SETSID@
+HAVE_DECL_PROGRAM_INVOCATION_NAME = @HAVE_DECL_PROGRAM_INVOCATION_NAME@
+HAVE_DECL_PUTW = @HAVE_DECL_PUTW@
HAVE_DECL_SETENV = @HAVE_DECL_SETENV@
HAVE_DECL_SETHOSTNAME = @HAVE_DECL_SETHOSTNAME@
HAVE_DECL_SETSTATE = @HAVE_DECL_SETSTATE@
@@ -727,6 +770,7 @@ HAVE_GETLOGIN = @HAVE_GETLOGIN@
HAVE_GETOPT_H = @HAVE_GETOPT_H@
HAVE_GETPAGESIZE = @HAVE_GETPAGESIZE@
HAVE_GETPASS = @HAVE_GETPASS@
+HAVE_GETPROGNAME = @HAVE_GETPROGNAME@
HAVE_GETRANDOM = @HAVE_GETRANDOM@
HAVE_GETSUBOPT = @HAVE_GETSUBOPT@
HAVE_GETTIMEOFDAY = @HAVE_GETTIMEOFDAY@
@@ -734,6 +778,8 @@ HAVE_GETUMASK = @HAVE_GETUMASK@
HAVE_GRANTPT = @HAVE_GRANTPT@
HAVE_GROUP_MEMBER = @HAVE_GROUP_MEMBER@
HAVE_GSETTINGS = @HAVE_GSETTINGS@
+HAVE_IMAXABS = @HAVE_IMAXABS@
+HAVE_IMAXDIV = @HAVE_IMAXDIV@
HAVE_IMAXDIV_T = @HAVE_IMAXDIV_T@
HAVE_INITSTATE = @HAVE_INITSTATE@
HAVE_INTTYPES_H = @HAVE_INTTYPES_H@
@@ -749,6 +795,7 @@ HAVE_MAX_ALIGN_T = @HAVE_MAX_ALIGN_T@
HAVE_MBSLEN = @HAVE_MBSLEN@
HAVE_MBTOWC = @HAVE_MBTOWC@
HAVE_MEMPCPY = @HAVE_MEMPCPY@
+HAVE_MEMSET_EXPLICIT = @HAVE_MEMSET_EXPLICIT@
HAVE_MKDIRAT = @HAVE_MKDIRAT@
HAVE_MKDTEMP = @HAVE_MKDTEMP@
HAVE_MKFIFO = @HAVE_MKFIFO@
@@ -875,6 +922,9 @@ INSTALL_PROGRAM = @INSTALL_PROGRAM@
INSTALL_SCRIPT = @INSTALL_SCRIPT@
INT32_MAX_LT_INTMAX_MAX = @INT32_MAX_LT_INTMAX_MAX@
INT64_MAX_EQ_LONG_MAX = @INT64_MAX_EQ_LONG_MAX@
+JARSIGNER = @JARSIGNER@
+JAVAC = @JAVAC@
+JPEG_CFLAGS = @JPEG_CFLAGS@
JSON_CFLAGS = @JSON_CFLAGS@
JSON_LIBS = @JSON_LIBS@
JSON_OBJ = @JSON_OBJ@
@@ -893,6 +943,7 @@ LIBGCCJIT_CFLAGS = @LIBGCCJIT_CFLAGS@
LIBGCCJIT_LIBS = @LIBGCCJIT_LIBS@
LIBGIF = @LIBGIF@
LIBGMP = @LIBGMP@
+LIBGMP_CFLAGS = @LIBGMP_CFLAGS@
LIBGNUTLS_CFLAGS = @LIBGNUTLS_CFLAGS@
LIBGNUTLS_LIBS = @LIBGNUTLS_LIBS@
LIBGNU_LIBDEPS = @LIBGNU_LIBDEPS@
@@ -910,6 +961,7 @@ LIBRESOLV = @LIBRESOLV@
LIBS = @LIBS@
LIBSECCOMP_CFLAGS = @LIBSECCOMP_CFLAGS@
LIBSECCOMP_LIBS = @LIBSECCOMP_LIBS@
+LIBSELINUX_CFLAGS = @LIBSELINUX_CFLAGS@
LIBSELINUX_LIBS = @LIBSELINUX_LIBS@
LIBSOUND = @LIBSOUND@
LIBSYSTEMD_CFLAGS = @LIBSYSTEMD_CFLAGS@
@@ -935,13 +987,13 @@ LIB_CLOCK_GETTIME = @LIB_CLOCK_GETTIME@
LIB_EACCESS = @LIB_EACCESS@
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@
LIB_WSOCK32 = @LIB_WSOCK32@
+LIB_XATTR = @LIB_XATTR@
LIMITS_H = @LIMITS_H@
LN_S_FILEONLY = @LN_S_FILEONLY@
LTLIBGMP = @LTLIBGMP@
@@ -955,7 +1007,20 @@ MKDIR_P = @MKDIR_P@
MODULES_OBJ = @MODULES_OBJ@
MODULES_SECONDARY_SUFFIX = @MODULES_SECONDARY_SUFFIX@
MODULES_SUFFIX = @MODULES_SUFFIX@
+NANOSLEEP_LIB = @NANOSLEEP_LIB@
NATIVE_COMPILATION_AOT = @NATIVE_COMPILATION_AOT@
+NDK_BUILD_ABI = @NDK_BUILD_ABI@
+NDK_BUILD_ANDROID_MK = @NDK_BUILD_ANDROID_MK@
+NDK_BUILD_ANY_CXX_MODULE = @NDK_BUILD_ANY_CXX_MODULE@
+NDK_BUILD_AR = @NDK_BUILD_AR@
+NDK_BUILD_ARCH = @NDK_BUILD_ARCH@
+NDK_BUILD_CC = @NDK_BUILD_CC@
+NDK_BUILD_CFLAGS = @NDK_BUILD_CFLAGS@
+NDK_BUILD_CXX = @NDK_BUILD_CXX@
+NDK_BUILD_CXX_SHARED = @NDK_BUILD_CXX_SHARED@
+NDK_BUILD_MODULES = @NDK_BUILD_MODULES@
+NDK_BUILD_NASM = @NDK_BUILD_NASM@
+NDK_BUILD_SDK = @NDK_BUILD_SDK@
NEXT_ASSERT_H = @NEXT_ASSERT_H@
NEXT_AS_FIRST_DIRECTIVE_ASSERT_H = @NEXT_AS_FIRST_DIRECTIVE_ASSERT_H@
NEXT_AS_FIRST_DIRECTIVE_DIRENT_H = @NEXT_AS_FIRST_DIRECTIVE_DIRENT_H@
@@ -1031,7 +1096,9 @@ PRE_ALLOC_OBJ = @PRE_ALLOC_OBJ@
PRIPTR_PREFIX = @PRIPTR_PREFIX@
PROFILING_CFLAGS = @PROFILING_CFLAGS@
PTHREAD_H_DEFINES_STRUCT_TIMESPEC = @PTHREAD_H_DEFINES_STRUCT_TIMESPEC@
+PTHREAD_SIGMASK_LIB = @PTHREAD_SIGMASK_LIB@
PTRDIFF_T_SUFFIX = @PTRDIFF_T_SUFFIX@
+QCOPY_ACL_LIB = @QCOPY_ACL_LIB@
RALLOC_OBJ = @RALLOC_OBJ@
RANLIB = @RANLIB@
REPLACE_ACCESS = @REPLACE_ACCESS@
@@ -1050,6 +1117,7 @@ REPLACE_DIRFD = @REPLACE_DIRFD@
REPLACE_DPRINTF = @REPLACE_DPRINTF@
REPLACE_DUP = @REPLACE_DUP@
REPLACE_DUP2 = @REPLACE_DUP2@
+REPLACE_DUP3 = @REPLACE_DUP3@
REPLACE_EXECL = @REPLACE_EXECL@
REPLACE_EXECLE = @REPLACE_EXECLE@
REPLACE_EXECLP = @REPLACE_EXECLP@
@@ -1058,10 +1126,12 @@ REPLACE_EXECVE = @REPLACE_EXECVE@
REPLACE_EXECVP = @REPLACE_EXECVP@
REPLACE_EXECVPE = @REPLACE_EXECVPE@
REPLACE_FACCESSAT = @REPLACE_FACCESSAT@
+REPLACE_FCHDIR = @REPLACE_FCHDIR@
REPLACE_FCHMODAT = @REPLACE_FCHMODAT@
REPLACE_FCHOWNAT = @REPLACE_FCHOWNAT@
REPLACE_FCLOSE = @REPLACE_FCLOSE@
REPLACE_FCNTL = @REPLACE_FCNTL@
+REPLACE_FDATASYNC = @REPLACE_FDATASYNC@
REPLACE_FDOPEN = @REPLACE_FDOPEN@
REPLACE_FDOPENDIR = @REPLACE_FDOPENDIR@
REPLACE_FFLUSH = @REPLACE_FFLUSH@
@@ -1084,15 +1154,21 @@ REPLACE_GETCWD = @REPLACE_GETCWD@
REPLACE_GETDELIM = @REPLACE_GETDELIM@
REPLACE_GETDOMAINNAME = @REPLACE_GETDOMAINNAME@
REPLACE_GETDTABLESIZE = @REPLACE_GETDTABLESIZE@
+REPLACE_GETENTROPY = @REPLACE_GETENTROPY@
REPLACE_GETGROUPS = @REPLACE_GETGROUPS@
REPLACE_GETLINE = @REPLACE_GETLINE@
+REPLACE_GETLOADAVG = @REPLACE_GETLOADAVG@
REPLACE_GETLOGIN_R = @REPLACE_GETLOGIN_R@
REPLACE_GETPAGESIZE = @REPLACE_GETPAGESIZE@
REPLACE_GETPASS = @REPLACE_GETPASS@
REPLACE_GETPASS_FOR_GETPASS_GNU = @REPLACE_GETPASS_FOR_GETPASS_GNU@
+REPLACE_GETPROGNAME = @REPLACE_GETPROGNAME@
REPLACE_GETRANDOM = @REPLACE_GETRANDOM@
+REPLACE_GETSUBOPT = @REPLACE_GETSUBOPT@
REPLACE_GETTIMEOFDAY = @REPLACE_GETTIMEOFDAY@
REPLACE_GMTIME = @REPLACE_GMTIME@
+REPLACE_IMAXABS = @REPLACE_IMAXABS@
+REPLACE_IMAXDIV = @REPLACE_IMAXDIV@
REPLACE_INITSTATE = @REPLACE_INITSTATE@
REPLACE_ISATTY = @REPLACE_ISATTY@
REPLACE_LCHOWN = @REPLACE_LCHOWN@
@@ -1104,14 +1180,20 @@ REPLACE_LSEEK = @REPLACE_LSEEK@
REPLACE_LSTAT = @REPLACE_LSTAT@
REPLACE_MALLOC_FOR_MALLOC_GNU = @REPLACE_MALLOC_FOR_MALLOC_GNU@
REPLACE_MALLOC_FOR_MALLOC_POSIX = @REPLACE_MALLOC_FOR_MALLOC_POSIX@
+REPLACE_MBSTOWCS = @REPLACE_MBSTOWCS@
REPLACE_MBTOWC = @REPLACE_MBTOWC@
+REPLACE_MB_CUR_MAX = @REPLACE_MB_CUR_MAX@
REPLACE_MEMCHR = @REPLACE_MEMCHR@
REPLACE_MEMMEM = @REPLACE_MEMMEM@
+REPLACE_MEMPCPY = @REPLACE_MEMPCPY@
+REPLACE_MEMSET_EXPLICIT = @REPLACE_MEMSET_EXPLICIT@
REPLACE_MKDIR = @REPLACE_MKDIR@
REPLACE_MKFIFO = @REPLACE_MKFIFO@
REPLACE_MKFIFOAT = @REPLACE_MKFIFOAT@
REPLACE_MKNOD = @REPLACE_MKNOD@
REPLACE_MKNODAT = @REPLACE_MKNODAT@
+REPLACE_MKOSTEMP = @REPLACE_MKOSTEMP@
+REPLACE_MKOSTEMPS = @REPLACE_MKOSTEMPS@
REPLACE_MKSTEMP = @REPLACE_MKSTEMP@
REPLACE_MKTIME = @REPLACE_MKTIME@
REPLACE_NANOSLEEP = @REPLACE_NANOSLEEP@
@@ -1121,8 +1203,10 @@ REPLACE_OPEN = @REPLACE_OPEN@
REPLACE_OPENAT = @REPLACE_OPENAT@
REPLACE_OPENDIR = @REPLACE_OPENDIR@
REPLACE_PERROR = @REPLACE_PERROR@
+REPLACE_PIPE2 = @REPLACE_PIPE2@
REPLACE_POPEN = @REPLACE_POPEN@
REPLACE_POSIX_MEMALIGN = @REPLACE_POSIX_MEMALIGN@
+REPLACE_POSIX_OPENPT = @REPLACE_POSIX_OPENPT@
REPLACE_PREAD = @REPLACE_PREAD@
REPLACE_PRINTF = @REPLACE_PRINTF@
REPLACE_PSELECT = @REPLACE_PSELECT@
@@ -1133,9 +1217,11 @@ REPLACE_PUTENV = @REPLACE_PUTENV@
REPLACE_PWRITE = @REPLACE_PWRITE@
REPLACE_QSORT_R = @REPLACE_QSORT_R@
REPLACE_RAISE = @REPLACE_RAISE@
+REPLACE_RAND = @REPLACE_RAND@
REPLACE_RANDOM = @REPLACE_RANDOM@
REPLACE_RANDOM_R = @REPLACE_RANDOM_R@
REPLACE_READ = @REPLACE_READ@
+REPLACE_READDIR = @REPLACE_READDIR@
REPLACE_READLINK = @REPLACE_READLINK@
REPLACE_READLINKAT = @REPLACE_READLINKAT@
REPLACE_REALLOCARRAY = @REPLACE_REALLOCARRAY@
@@ -1145,9 +1231,11 @@ REPLACE_REALPATH = @REPLACE_REALPATH@
REPLACE_REMOVE = @REPLACE_REMOVE@
REPLACE_RENAME = @REPLACE_RENAME@
REPLACE_RENAMEAT = @REPLACE_RENAMEAT@
+REPLACE_REWINDDIR = @REPLACE_REWINDDIR@
REPLACE_RMDIR = @REPLACE_RMDIR@
REPLACE_SELECT = @REPLACE_SELECT@
REPLACE_SETENV = @REPLACE_SETENV@
+REPLACE_SETHOSTNAME = @REPLACE_SETHOSTNAME@
REPLACE_SETSTATE = @REPLACE_SETSTATE@
REPLACE_SLEEP = @REPLACE_SLEEP@
REPLACE_SNPRINTF = @REPLACE_SNPRINTF@
@@ -1155,6 +1243,7 @@ REPLACE_SPRINTF = @REPLACE_SPRINTF@
REPLACE_STAT = @REPLACE_STAT@
REPLACE_STDIO_READ_FUNCS = @REPLACE_STDIO_READ_FUNCS@
REPLACE_STDIO_WRITE_FUNCS = @REPLACE_STDIO_WRITE_FUNCS@
+REPLACE_STPCPY = @REPLACE_STPCPY@
REPLACE_STPNCPY = @REPLACE_STPNCPY@
REPLACE_STRCASESTR = @REPLACE_STRCASESTR@
REPLACE_STRCHRNUL = @REPLACE_STRCHRNUL@
@@ -1178,9 +1267,13 @@ REPLACE_STRTOUL = @REPLACE_STRTOUL@
REPLACE_STRTOULL = @REPLACE_STRTOULL@
REPLACE_STRTOUMAX = @REPLACE_STRTOUMAX@
REPLACE_STRUCT_TIMEVAL = @REPLACE_STRUCT_TIMEVAL@
+REPLACE_STRVERSCMP = @REPLACE_STRVERSCMP@
REPLACE_SYMLINK = @REPLACE_SYMLINK@
REPLACE_SYMLINKAT = @REPLACE_SYMLINKAT@
+REPLACE_TIME = @REPLACE_TIME@
REPLACE_TIMEGM = @REPLACE_TIMEGM@
+REPLACE_TIMESPEC_GET = @REPLACE_TIMESPEC_GET@
+REPLACE_TIMESPEC_GETRES = @REPLACE_TIMESPEC_GETRES@
REPLACE_TMPFILE = @REPLACE_TMPFILE@
REPLACE_TRUNCATE = @REPLACE_TRUNCATE@
REPLACE_TTYNAME_R = @REPLACE_TTYNAME_R@
@@ -1198,8 +1291,10 @@ REPLACE_VSNPRINTF = @REPLACE_VSNPRINTF@
REPLACE_VSPRINTF = @REPLACE_VSPRINTF@
REPLACE_WCTOMB = @REPLACE_WCTOMB@
REPLACE_WRITE = @REPLACE_WRITE@
+REPLACE__EXIT = @REPLACE__EXIT@
RSVG_CFLAGS = @RSVG_CFLAGS@
RSVG_LIBS = @RSVG_LIBS@
+SDK_BUILD_TOOLS = @SDK_BUILD_TOOLS@
SEPCHAR = @SEPCHAR@
SETFATTR = @SETFATTR@
SETTINGS_CFLAGS = @SETTINGS_CFLAGS@
@@ -1209,8 +1304,8 @@ SIG_ATOMIC_T_SUFFIX = @SIG_ATOMIC_T_SUFFIX@
SIZEOF_LONG = @SIZEOF_LONG@
SIZE_T_SUFFIX = @SIZE_T_SUFFIX@
SMALL_JA_DIC = @SMALL_JA_DIC@
+SQLITE3_CFLAGS = @SQLITE3_CFLAGS@
SQLITE3_LIBS = @SQLITE3_LIBS@
-STDALIGN_H = @STDALIGN_H@
STDCKDINT_H = @STDCKDINT_H@
STDDEF_H = @STDDEF_H@
STDINT_H = @STDINT_H@
@@ -1218,6 +1313,8 @@ SUBDIR_MAKEFILES_IN = @SUBDIR_MAKEFILES_IN@
SYSTEM_TYPE = @SYSTEM_TYPE@
SYS_TIME_H_DEFINES_STRUCT_TIMESPEC = @SYS_TIME_H_DEFINES_STRUCT_TIMESPEC@
TERMCAP_OBJ = @TERMCAP_OBJ@
+TIFF_CFLAGS = @TIFF_CFLAGS@
+TIMER_TIME_LIB = @TIMER_TIME_LIB@
TIME_H_DEFINES_STRUCT_TIMESPEC = @TIME_H_DEFINES_STRUCT_TIMESPEC@
TIME_H_DEFINES_TIME_UTC = @TIME_H_DEFINES_TIME_UTC@
TOOLKIT_LIBW = @TOOLKIT_LIBW@
@@ -1238,6 +1335,7 @@ W32_LIBS = @W32_LIBS@
W32_OBJ = @W32_OBJ@
W32_RES_LINK = @W32_RES_LINK@
WARN_CFLAGS = @WARN_CFLAGS@
+WARN_JAVAFLAGS = @WARN_JAVAFLAGS@
WCHAR_T_SUFFIX = @WCHAR_T_SUFFIX@
WEBKIT_CFLAGS = @WEBKIT_CFLAGS@
WEBKIT_LIBS = @WEBKIT_LIBS@
@@ -1256,6 +1354,7 @@ XARGS_LIMIT = @XARGS_LIMIT@
XCB_LIBS = @XCB_LIBS@
XCOMPOSITE_CFLAGS = @XCOMPOSITE_CFLAGS@
XCOMPOSITE_LIBS = @XCOMPOSITE_LIBS@
+XCONFIGURE = @XCONFIGURE@
XCRUN = @XCRUN@
XDBE_CFLAGS = @XDBE_CFLAGS@
XDBE_LIBS = @XDBE_LIBS@
@@ -1280,6 +1379,7 @@ XSYNC_CFLAGS = @XSYNC_CFLAGS@
XSYNC_LIBS = @XSYNC_LIBS@
XWIDGETS_OBJ = @XWIDGETS_OBJ@
X_TOOLKIT_TYPE = @X_TOOLKIT_TYPE@
+ZIPALIGN = @ZIPALIGN@
ac_ct_CC = @ac_ct_CC@
ac_ct_CXX = @ac_ct_CXX@
ac_ct_OBJC = @ac_ct_OBJC@
@@ -1302,6 +1402,7 @@ datarootdir = @datarootdir@
docdir = @docdir@
dvidir = @dvidir@
emacs_major_version = @emacs_major_version@
+emacs_use_mailutils = @emacs_use_mailutils@
etcdir = @etcdir@
etcdocdir = @etcdocdir@
exec_prefix = @exec_prefix@
@@ -1325,6 +1426,7 @@ gl_GNULIB_ENABLED_e80bf6f757095d2e5fc94dafb8f8fc8b_CONDITION = @gl_GNULIB_ENABLE
gl_GNULIB_ENABLED_ef455225c00f5049c808c2eda3e76866_CONDITION = @gl_GNULIB_ENABLED_ef455225c00f5049c808c2eda3e76866_CONDITION@
gl_GNULIB_ENABLED_euidaccess_CONDITION = @gl_GNULIB_ENABLED_euidaccess_CONDITION@
gl_GNULIB_ENABLED_fd38c7e463b54744b77b98aeafb4fa7c_CONDITION = @gl_GNULIB_ENABLED_fd38c7e463b54744b77b98aeafb4fa7c_CONDITION@
+gl_GNULIB_ENABLED_getdelim_CONDITION = @gl_GNULIB_ENABLED_getdelim_CONDITION@
gl_GNULIB_ENABLED_getdtablesize_CONDITION = @gl_GNULIB_ENABLED_getdtablesize_CONDITION@
gl_GNULIB_ENABLED_getgroups_CONDITION = @gl_GNULIB_ENABLED_getgroups_CONDITION@
gl_GNULIB_ENABLED_lchmod_CONDITION = @gl_GNULIB_ENABLED_lchmod_CONDITION@
@@ -1508,6 +1610,16 @@ libgnu_a_SOURCES += binary-io.h binary-io.c
endif
## end gnulib module binary-io
+## begin gnulib module boot-time
+ifeq (,$(OMIT_GNULIB_MODULE_boot-time))
+
+libgnu_a_SOURCES += boot-time.c
+
+EXTRA_DIST += boot-time-aux.h boot-time.h readutmp.h
+
+endif
+## end gnulib module boot-time
+
## begin gnulib module byteswap
ifeq (,$(OMIT_GNULIB_MODULE_byteswap))
@@ -1699,6 +1811,7 @@ dirent.h: dirent.in.h $(top_builddir)/config.status $(CXXDEFS_H) $(ARG_NONNULL_H
-e 's|@''PRAGMA_SYSTEM_HEADER''@|@PRAGMA_SYSTEM_HEADER@|g' \
-e 's|@''PRAGMA_COLUMNS''@|@PRAGMA_COLUMNS@|g' \
-e 's|@''NEXT_DIRENT_H''@|$(NEXT_DIRENT_H)|g' \
+ -e 's/@''DIR_HAS_FD_MEMBER''@/$(DIR_HAS_FD_MEMBER)/g' \
-e 's/@''GNULIB_OPENDIR''@/$(GL_GNULIB_OPENDIR)/g' \
-e 's/@''GNULIB_READDIR''@/$(GL_GNULIB_READDIR)/g' \
-e 's/@''GNULIB_REWINDDIR''@/$(GL_GNULIB_REWINDDIR)/g' \
@@ -1717,6 +1830,8 @@ dirent.h: dirent.in.h $(top_builddir)/config.status $(CXXDEFS_H) $(ARG_NONNULL_H
-e 's|@''HAVE_SCANDIR''@|$(HAVE_SCANDIR)|g' \
-e 's|@''HAVE_ALPHASORT''@|$(HAVE_ALPHASORT)|g' \
-e 's|@''REPLACE_OPENDIR''@|$(REPLACE_OPENDIR)|g' \
+ -e 's|@''REPLACE_READDIR''@|$(REPLACE_READDIR)|g' \
+ -e 's|@''REPLACE_REWINDDIR''@|$(REPLACE_REWINDDIR)|g' \
-e 's|@''REPLACE_CLOSEDIR''@|$(REPLACE_CLOSEDIR)|g' \
-e 's|@''REPLACE_DIRFD''@|$(REPLACE_DIRFD)|g' \
-e 's|@''REPLACE_FDOPENDIR''@|$(REPLACE_FDOPENDIR)|g' \
@@ -1741,6 +1856,8 @@ libgnu_a_SOURCES += dirfd.c
endif
endif
+EXTRA_DIST += dirent-private.h
+
endif
## end gnulib module dirfd
@@ -1857,16 +1974,6 @@ EXTRA_DIST += execinfo.in.h
endif
## end gnulib module execinfo
-## begin gnulib module explicit_bzero
-ifeq (,$(OMIT_GNULIB_MODULE_explicit_bzero))
-
-ifneq (,$(GL_COND_OBJ_EXPLICIT_BZERO_CONDITION))
-libgnu_a_SOURCES += explicit_bzero.c
-endif
-
-endif
-## end gnulib module explicit_bzero
-
## begin gnulib module faccessat
ifeq (,$(OMIT_GNULIB_MODULE_faccessat))
@@ -1951,6 +2058,8 @@ ifneq (,$(GL_COND_OBJ_FDOPENDIR_CONDITION))
libgnu_a_SOURCES += fdopendir.c
endif
+EXTRA_DIST += dirent-private.h
+
endif
## end gnulib module fdopendir
@@ -2091,6 +2200,18 @@ gl_V_at = $(AM_V_GEN)
endif
## end gnulib module gen-header
+## begin gnulib module getdelim
+ifeq (,$(OMIT_GNULIB_MODULE_getdelim))
+
+ifneq (,$(gl_GNULIB_ENABLED_getdelim_CONDITION))
+ifneq (,$(GL_COND_OBJ_GETDELIM_CONDITION))
+libgnu_a_SOURCES += getdelim.c
+endif
+
+endif
+endif
+## end gnulib module getdelim
+
## begin gnulib module getdtablesize
ifeq (,$(OMIT_GNULIB_MODULE_getdtablesize))
@@ -2115,6 +2236,16 @@ endif
endif
## end gnulib module getgroups
+## begin gnulib module getline
+ifeq (,$(OMIT_GNULIB_MODULE_getline))
+
+ifneq (,$(GL_COND_OBJ_GETLINE_CONDITION))
+libgnu_a_SOURCES += getline.c
+endif
+
+endif
+## end gnulib module getline
+
## begin gnulib module getloadavg
ifeq (,$(OMIT_GNULIB_MODULE_getloadavg))
@@ -2367,6 +2498,8 @@ inttypes.h: inttypes.in.h $(top_builddir)/config.status $(CXXDEFS_H) $(WARN_ON_U
-e 's/@''HAVE_DECL_STRTOIMAX''@/$(HAVE_DECL_STRTOIMAX)/g' \
-e 's/@''HAVE_DECL_STRTOUMAX''@/$(HAVE_DECL_STRTOUMAX)/g' \
-e 's/@''HAVE_IMAXDIV_T''@/$(HAVE_IMAXDIV_T)/g' \
+ -e 's/@''REPLACE_IMAXABS''@/$(REPLACE_IMAXABS)/g' \
+ -e 's/@''REPLACE_IMAXDIV''@/$(REPLACE_IMAXDIV)/g' \
-e 's/@''REPLACE_STRTOIMAX''@/$(REPLACE_STRTOIMAX)/g' \
-e 's/@''REPLACE_STRTOUMAX''@/$(REPLACE_STRTOUMAX)/g' \
-e 's/@''INT32_MAX_LT_INTMAX_MAX''@/$(INT32_MAX_LT_INTMAX_MAX)/g' \
@@ -2536,6 +2669,16 @@ endif
endif
## end gnulib module memrchr
+## begin gnulib module memset_explicit
+ifeq (,$(OMIT_GNULIB_MODULE_memset_explicit))
+
+ifneq (,$(GL_COND_OBJ_MEMSET_EXPLICIT_CONDITION))
+libgnu_a_SOURCES += memset_explicit.c
+endif
+
+endif
+## end gnulib module memset_explicit
+
## begin gnulib module minmax
ifeq (,$(OMIT_GNULIB_MODULE_minmax))
@@ -2603,7 +2746,9 @@ ifeq (,$(OMIT_GNULIB_MODULE_nstrftime))
libgnu_a_SOURCES += nstrftime.c
-EXTRA_DIST += strftime.h
+EXTRA_DIST += strftime.c strftime.h
+
+EXTRA_libgnu_a_SOURCES += strftime.c
endif
## end gnulib module nstrftime
@@ -2895,28 +3040,6 @@ EXTRA_DIST += stat-time.h
endif
## end gnulib module stat-time
-## begin gnulib module stdalign
-ifeq (,$(OMIT_GNULIB_MODULE_stdalign))
-
-BUILT_SOURCES += $(STDALIGN_H)
-
-# We need the following in order to create <stdalign.h> when the system
-# doesn't have one that works.
-ifneq (,$(GL_GENERATE_STDALIGN_H_CONDITION))
-stdalign.h: stdalign.in.h $(top_builddir)/config.status
- $(gl_V_at)$(SED_HEADER_TO_AT_t) $(srcdir)/stdalign.in.h
- $(AM_V_at)mv $@-t $@
-else
-stdalign.h: $(top_builddir)/config.status
- rm -f $@
-endif
-MOSTLYCLEANFILES += stdalign.h stdalign.h-t
-
-EXTRA_DIST += stdalign.in.h
-
-endif
-## end gnulib module stdalign
-
## begin gnulib module stdckdint
ifeq (,$(OMIT_GNULIB_MODULE_stdckdint))
@@ -3095,14 +3218,17 @@ stdio.h: stdio.in.h $(top_builddir)/config.status $(CXXDEFS_H) $(ARG_NONNULL_H)
-e 's/@''GNULIB_MDA_GETW''@/$(GL_GNULIB_MDA_GETW)/g' \
-e 's/@''GNULIB_MDA_PUTW''@/$(GL_GNULIB_MDA_PUTW)/g' \
-e 's/@''GNULIB_MDA_TEMPNAM''@/$(GL_GNULIB_MDA_TEMPNAM)/g' \
- < $(srcdir)/stdio.in.h | \
- sed -e 's|@''HAVE_DECL_FCLOSEALL''@|$(HAVE_DECL_FCLOSEALL)|g' \
+ < $(srcdir)/stdio.in.h > $@-t1
+ $(AM_V_at)sed \
+ -e 's|@''HAVE_DECL_FCLOSEALL''@|$(HAVE_DECL_FCLOSEALL)|g' \
-e 's|@''HAVE_DECL_FPURGE''@|$(HAVE_DECL_FPURGE)|g' \
-e 's|@''HAVE_DECL_FSEEKO''@|$(HAVE_DECL_FSEEKO)|g' \
-e 's|@''HAVE_DECL_FTELLO''@|$(HAVE_DECL_FTELLO)|g' \
-e 's|@''HAVE_DECL_GETDELIM''@|$(HAVE_DECL_GETDELIM)|g' \
-e 's|@''HAVE_DECL_GETLINE''@|$(HAVE_DECL_GETLINE)|g' \
+ -e 's|@''HAVE_DECL_GETW''@|$(HAVE_DECL_GETW)|g' \
-e 's|@''HAVE_DECL_OBSTACK_PRINTF''@|$(HAVE_DECL_OBSTACK_PRINTF)|g' \
+ -e 's|@''HAVE_DECL_PUTW''@|$(HAVE_DECL_PUTW)|g' \
-e 's|@''HAVE_DECL_SNPRINTF''@|$(HAVE_DECL_SNPRINTF)|g' \
-e 's|@''HAVE_DECL_VSNPRINTF''@|$(HAVE_DECL_VSNPRINTF)|g' \
-e 's|@''HAVE_DPRINTF''@|$(HAVE_DPRINTF)|g' \
@@ -3113,6 +3239,8 @@ stdio.h: stdio.in.h $(top_builddir)/config.status $(CXXDEFS_H) $(ARG_NONNULL_H)
-e 's|@''HAVE_RENAMEAT''@|$(HAVE_RENAMEAT)|g' \
-e 's|@''HAVE_VASPRINTF''@|$(HAVE_VASPRINTF)|g' \
-e 's|@''HAVE_VDPRINTF''@|$(HAVE_VDPRINTF)|g' \
+ < $@-t1 > $@-t2
+ $(AM_V_at)sed \
-e 's|@''REPLACE_DPRINTF''@|$(REPLACE_DPRINTF)|g' \
-e 's|@''REPLACE_FCLOSE''@|$(REPLACE_FCLOSE)|g' \
-e 's|@''REPLACE_FDOPEN''@|$(REPLACE_FDOPEN)|g' \
@@ -3150,9 +3278,10 @@ stdio.h: stdio.in.h $(top_builddir)/config.status $(CXXDEFS_H) $(ARG_NONNULL_H)
-e '/definitions of _GL_FUNCDECL_RPL/r $(CXXDEFS_H)' \
-e '/definition of _GL_ARG_NONNULL/r $(ARG_NONNULL_H)' \
-e '/definition of _GL_WARN_ON_USE/r $(WARN_ON_USE_H)' \
- > $@-t
- $(AM_V_at)mv $@-t $@
-MOSTLYCLEANFILES += stdio.h stdio.h-t
+ < $@-t2 > $@-t3
+ $(AM_V_at)rm -f $@-t1 $@-t2
+ $(AM_V_at)mv $@-t3 $@
+MOSTLYCLEANFILES += stdio.h stdio.h-t1 stdio.h-t2 stdio.h-t3
ifneq (,$(GL_COND_OBJ_STDIO_READ_CONDITION))
libgnu_a_SOURCES += stdio-read.c
@@ -3189,10 +3318,12 @@ stdlib.h: stdlib.in.h $(top_builddir)/config.status $(CXXDEFS_H) \
-e 's/@''GNULIB_CANONICALIZE_FILE_NAME''@/$(GL_GNULIB_CANONICALIZE_FILE_NAME)/g' \
-e 's/@''GNULIB_FREE_POSIX''@/$(GL_GNULIB_FREE_POSIX)/g' \
-e 's/@''GNULIB_GETLOADAVG''@/$(GL_GNULIB_GETLOADAVG)/g' \
+ -e 's/@''GNULIB_GETPROGNAME''@/$(GL_GNULIB_GETPROGNAME)/g' \
-e 's/@''GNULIB_GETSUBOPT''@/$(GL_GNULIB_GETSUBOPT)/g' \
-e 's/@''GNULIB_GRANTPT''@/$(GL_GNULIB_GRANTPT)/g' \
-e 's/@''GNULIB_MALLOC_GNU''@/$(GL_GNULIB_MALLOC_GNU)/g' \
-e 's/@''GNULIB_MALLOC_POSIX''@/$(GL_GNULIB_MALLOC_POSIX)/g' \
+ -e 's/@''GNULIB_MBSTOWCS''@/$(GL_GNULIB_MBSTOWCS)/g' \
-e 's/@''GNULIB_MBTOWC''@/$(GL_GNULIB_MBTOWC)/g' \
-e 's/@''GNULIB_MKDTEMP''@/$(GL_GNULIB_MKDTEMP)/g' \
-e 's/@''GNULIB_MKOSTEMP''@/$(GL_GNULIB_MKOSTEMP)/g' \
@@ -3205,6 +3336,7 @@ stdlib.h: stdlib.in.h $(top_builddir)/config.status $(CXXDEFS_H) \
-e 's/@''GNULIB_PTSNAME_R''@/$(GL_GNULIB_PTSNAME_R)/g' \
-e 's/@''GNULIB_PUTENV''@/$(GL_GNULIB_PUTENV)/g' \
-e 's/@''GNULIB_QSORT_R''@/$(GL_GNULIB_QSORT_R)/g' \
+ -e 's/@''GNULIB_RAND''@/$(GL_GNULIB_RAND)/g' \
-e 's/@''GNULIB_RANDOM''@/$(GL_GNULIB_RANDOM)/g' \
-e 's/@''GNULIB_RANDOM_R''@/$(GL_GNULIB_RANDOM_R)/g' \
-e 's/@''GNULIB_REALLOC_GNU''@/$(GL_GNULIB_REALLOC_GNU)/g' \
@@ -3229,8 +3361,9 @@ stdlib.h: stdlib.in.h $(top_builddir)/config.status $(CXXDEFS_H) \
-e 's/@''GNULIB_MDA_GCVT''@/$(GL_GNULIB_MDA_GCVT)/g' \
-e 's/@''GNULIB_MDA_MKTEMP''@/$(GL_GNULIB_MDA_MKTEMP)/g' \
-e 's/@''GNULIB_MDA_PUTENV''@/$(GL_GNULIB_MDA_PUTENV)/g' \
- < $(srcdir)/stdlib.in.h | \
- sed -e 's|@''HAVE__EXIT''@|$(HAVE__EXIT)|g' \
+ < $(srcdir)/stdlib.in.h > $@-t1
+ $(AM_V_at)sed \
+ -e 's|@''HAVE__EXIT''@|$(HAVE__EXIT)|g' \
-e 's|@''HAVE_ALIGNED_ALLOC''@|$(HAVE_ALIGNED_ALLOC)|g' \
-e 's|@''HAVE_ATOLL''@|$(HAVE_ATOLL)|g' \
-e 's|@''HAVE_CANONICALIZE_FILE_NAME''@|$(HAVE_CANONICALIZE_FILE_NAME)|g' \
@@ -3238,6 +3371,8 @@ stdlib.h: stdlib.in.h $(top_builddir)/config.status $(CXXDEFS_H) \
-e 's|@''HAVE_DECL_FCVT''@|$(HAVE_DECL_FCVT)|g' \
-e 's|@''HAVE_DECL_GCVT''@|$(HAVE_DECL_GCVT)|g' \
-e 's|@''HAVE_DECL_GETLOADAVG''@|$(HAVE_DECL_GETLOADAVG)|g' \
+ -e 's|@''HAVE_DECL_PROGRAM_INVOCATION_NAME''@|$(HAVE_DECL_PROGRAM_INVOCATION_NAME)|g' \
+ -e 's|@''HAVE_GETPROGNAME''@|$(HAVE_GETPROGNAME)|g' \
-e 's|@''HAVE_GETSUBOPT''@|$(HAVE_GETSUBOPT)|g' \
-e 's|@''HAVE_GRANTPT''@|$(HAVE_GRANTPT)|g' \
-e 's|@''HAVE_INITSTATE''@|$(HAVE_INITSTATE)|g' \
@@ -3273,21 +3408,33 @@ stdlib.h: stdlib.in.h $(top_builddir)/config.status $(CXXDEFS_H) \
-e 's|@''HAVE_SYS_LOADAVG_H''@|$(HAVE_SYS_LOADAVG_H)|g' \
-e 's|@''HAVE_UNLOCKPT''@|$(HAVE_UNLOCKPT)|g' \
-e 's|@''HAVE_DECL_UNSETENV''@|$(HAVE_DECL_UNSETENV)|g' \
+ < $@-t1 > $@-t2
+ $(AM_V_at)sed \
+ -e 's|@''REPLACE__EXIT''@|$(REPLACE__EXIT)|g' \
-e 's|@''REPLACE_ALIGNED_ALLOC''@|$(REPLACE_ALIGNED_ALLOC)|g' \
-e 's|@''REPLACE_CALLOC_FOR_CALLOC_GNU''@|$(REPLACE_CALLOC_FOR_CALLOC_GNU)|g' \
-e 's|@''REPLACE_CALLOC_FOR_CALLOC_POSIX''@|$(REPLACE_CALLOC_FOR_CALLOC_POSIX)|g' \
-e 's|@''REPLACE_CANONICALIZE_FILE_NAME''@|$(REPLACE_CANONICALIZE_FILE_NAME)|g' \
-e 's|@''REPLACE_FREE''@|$(REPLACE_FREE)|g' \
+ -e 's|@''REPLACE_GETLOADAVG''@|$(REPLACE_GETLOADAVG)|g' \
+ -e 's|@''REPLACE_GETPROGNAME''@|$(REPLACE_GETPROGNAME)|g' \
+ -e 's|@''REPLACE_GETSUBOPT''@|$(REPLACE_GETSUBOPT)|g' \
-e 's|@''REPLACE_INITSTATE''@|$(REPLACE_INITSTATE)|g' \
-e 's|@''REPLACE_MALLOC_FOR_MALLOC_GNU''@|$(REPLACE_MALLOC_FOR_MALLOC_GNU)|g' \
-e 's|@''REPLACE_MALLOC_FOR_MALLOC_POSIX''@|$(REPLACE_MALLOC_FOR_MALLOC_POSIX)|g' \
+ -e 's|@''REPLACE_MB_CUR_MAX''@|$(REPLACE_MB_CUR_MAX)|g' \
+ -e 's|@''REPLACE_MBSTOWCS''@|$(REPLACE_MBSTOWCS)|g' \
-e 's|@''REPLACE_MBTOWC''@|$(REPLACE_MBTOWC)|g' \
+ -e 's|@''REPLACE_MKOSTEMP''@|$(REPLACE_MKOSTEMP)|g' \
+ -e 's|@''REPLACE_MKOSTEMPS''@|$(REPLACE_MKOSTEMPS)|g' \
-e 's|@''REPLACE_MKSTEMP''@|$(REPLACE_MKSTEMP)|g' \
-e 's|@''REPLACE_POSIX_MEMALIGN''@|$(REPLACE_POSIX_MEMALIGN)|g' \
+ -e 's|@''REPLACE_POSIX_OPENPT''@|$(REPLACE_POSIX_OPENPT)|g' \
-e 's|@''REPLACE_PTSNAME''@|$(REPLACE_PTSNAME)|g' \
-e 's|@''REPLACE_PTSNAME_R''@|$(REPLACE_PTSNAME_R)|g' \
-e 's|@''REPLACE_PUTENV''@|$(REPLACE_PUTENV)|g' \
-e 's|@''REPLACE_QSORT_R''@|$(REPLACE_QSORT_R)|g' \
+ -e 's|@''REPLACE_RAND''@|$(REPLACE_RAND)|g' \
-e 's|@''REPLACE_RANDOM''@|$(REPLACE_RANDOM)|g' \
-e 's|@''REPLACE_RANDOM_R''@|$(REPLACE_RANDOM_R)|g' \
-e 's|@''REPLACE_REALLOC_FOR_REALLOC_GNU''@|$(REPLACE_REALLOC_FOR_REALLOC_GNU)|g' \
@@ -3308,9 +3455,10 @@ stdlib.h: stdlib.in.h $(top_builddir)/config.status $(CXXDEFS_H) \
-e '/definition of _Noreturn/r $(_NORETURN_H)' \
-e '/definition of _GL_ARG_NONNULL/r $(ARG_NONNULL_H)' \
-e '/definition of _GL_WARN_ON_USE/r $(WARN_ON_USE_H)' \
- > $@-t
- $(AM_V_at)mv $@-t $@
-MOSTLYCLEANFILES += stdlib.h stdlib.h-t
+ < $@-t2 > $@-t3
+ $(AM_V_at)rm -f $@-t1 $@-t2
+ $(AM_V_at)mv $@-t3 $@
+MOSTLYCLEANFILES += stdlib.h stdlib.h-t1 stdlib.h-t2 stdlib.h-t3
EXTRA_DIST += stdlib.in.h
@@ -3362,6 +3510,7 @@ string.h: string.in.h $(top_builddir)/config.status $(CXXDEFS_H) $(ARG_NONNULL_H
-e 's/@''GNULIB_MEMMEM''@/$(GL_GNULIB_MEMMEM)/g' \
-e 's/@''GNULIB_MEMPCPY''@/$(GL_GNULIB_MEMPCPY)/g' \
-e 's/@''GNULIB_MEMRCHR''@/$(GL_GNULIB_MEMRCHR)/g' \
+ -e 's/@''GNULIB_MEMSET_EXPLICIT''@/$(GL_GNULIB_MEMSET_EXPLICIT)/g' \
-e 's/@''GNULIB_RAWMEMCHR''@/$(GL_GNULIB_RAWMEMCHR)/g' \
-e 's/@''GNULIB_STPCPY''@/$(GL_GNULIB_STPCPY)/g' \
-e 's/@''GNULIB_STPNCPY''@/$(GL_GNULIB_STPNCPY)/g' \
@@ -3385,14 +3534,16 @@ string.h: string.in.h $(top_builddir)/config.status $(CXXDEFS_H) $(ARG_NONNULL_H
-e 's/@''GNULIB_MDA_MEMCCPY''@/$(GL_GNULIB_MDA_MEMCCPY)/g' \
-e 's/@''GNULIB_MDA_STRDUP''@/$(GL_GNULIB_MDA_STRDUP)/g' \
-e 's/@''GNULIB_FREE_POSIX''@/$(GL_GNULIB_FREE_POSIX)/g' \
- < $(srcdir)/string.in.h | \
- sed -e 's|@''HAVE_EXPLICIT_BZERO''@|$(HAVE_EXPLICIT_BZERO)|g' \
+ < $(srcdir)/string.in.h > $@-t1
+ $(AM_V_at)sed \
+ -e 's|@''HAVE_EXPLICIT_BZERO''@|$(HAVE_EXPLICIT_BZERO)|g' \
-e 's|@''HAVE_FFSL''@|$(HAVE_FFSL)|g' \
-e 's|@''HAVE_FFSLL''@|$(HAVE_FFSLL)|g' \
-e 's|@''HAVE_MBSLEN''@|$(HAVE_MBSLEN)|g' \
-e 's|@''HAVE_DECL_MEMMEM''@|$(HAVE_DECL_MEMMEM)|g' \
-e 's|@''HAVE_MEMPCPY''@|$(HAVE_MEMPCPY)|g' \
-e 's|@''HAVE_DECL_MEMRCHR''@|$(HAVE_DECL_MEMRCHR)|g' \
+ -e 's|@''HAVE_MEMSET_EXPLICIT''@|$(HAVE_MEMSET_EXPLICIT)|g' \
-e 's|@''HAVE_RAWMEMCHR''@|$(HAVE_RAWMEMCHR)|g' \
-e 's|@''HAVE_STPCPY''@|$(HAVE_STPCPY)|g' \
-e 's|@''HAVE_STPNCPY''@|$(HAVE_STPNCPY)|g' \
@@ -3413,7 +3564,10 @@ string.h: string.in.h $(top_builddir)/config.status $(CXXDEFS_H) $(ARG_NONNULL_H
-e 's|@''REPLACE_FFSLL''@|$(REPLACE_FFSLL)|g' \
-e 's|@''REPLACE_MEMCHR''@|$(REPLACE_MEMCHR)|g' \
-e 's|@''REPLACE_MEMMEM''@|$(REPLACE_MEMMEM)|g' \
+ -e 's|@''REPLACE_MEMPCPY''@|$(REPLACE_MEMPCPY)|g' \
+ -e 's|@''REPLACE_MEMSET_EXPLICIT''@|$(REPLACE_MEMSET_EXPLICIT)|g' \
-e 's|@''REPLACE_FREE''@|$(REPLACE_FREE)|g' \
+ -e 's|@''REPLACE_STPCPY''@|$(REPLACE_STPCPY)|g' \
-e 's|@''REPLACE_STPNCPY''@|$(REPLACE_STPNCPY)|g' \
-e 's|@''REPLACE_STRCHRNUL''@|$(REPLACE_STRCHRNUL)|g' \
-e 's|@''REPLACE_STRDUP''@|$(REPLACE_STRDUP)|g' \
@@ -3427,13 +3581,15 @@ string.h: string.in.h $(top_builddir)/config.status $(CXXDEFS_H) $(ARG_NONNULL_H
-e 's|@''REPLACE_STRERROR_R''@|$(REPLACE_STRERROR_R)|g' \
-e 's|@''REPLACE_STRERRORNAME_NP''@|$(REPLACE_STRERRORNAME_NP)|g' \
-e 's|@''REPLACE_STRSIGNAL''@|$(REPLACE_STRSIGNAL)|g' \
+ -e 's|@''REPLACE_STRVERSCMP''@|$(REPLACE_STRVERSCMP)|g' \
-e 's|@''UNDEFINE_STRTOK_R''@|$(UNDEFINE_STRTOK_R)|g' \
-e '/definitions of _GL_FUNCDECL_RPL/r $(CXXDEFS_H)' \
-e '/definition of _GL_ARG_NONNULL/r $(ARG_NONNULL_H)' \
-e '/definition of _GL_WARN_ON_USE/r $(WARN_ON_USE_H)' \
- > $@-t
- $(AM_V_at)mv $@-t $@
-MOSTLYCLEANFILES += string.h string.h-t
+ < $@-t1 > $@-t2
+ $(AM_V_at)rm -f $@-t1
+ $(AM_V_at)mv $@-t2 $@
+MOSTLYCLEANFILES += string.h string.h-t1 string.h-t2
EXTRA_DIST += string.in.h
@@ -3697,8 +3853,8 @@ EXTRA_DIST += tempname.h
endif
## end gnulib module tempname
-## begin gnulib module time
-ifeq (,$(OMIT_GNULIB_MODULE_time))
+## begin gnulib module time-h
+ifeq (,$(OMIT_GNULIB_MODULE_time-h))
BUILT_SOURCES += time.h
@@ -3717,6 +3873,7 @@ time.h: time.in.h $(top_builddir)/config.status $(CXXDEFS_H) $(ARG_NONNULL_H) $(
-e 's/@''GNULIB_NANOSLEEP''@/$(GL_GNULIB_NANOSLEEP)/g' \
-e 's/@''GNULIB_STRFTIME''@/$(GL_GNULIB_STRFTIME)/g' \
-e 's/@''GNULIB_STRPTIME''@/$(GL_GNULIB_STRPTIME)/g' \
+ -e 's/@''GNULIB_TIME''@/$(GL_GNULIB_TIME)/g' \
-e 's/@''GNULIB_TIMEGM''@/$(GL_GNULIB_TIMEGM)/g' \
-e 's/@''GNULIB_TIMESPEC_GET''@/$(GL_GNULIB_TIMESPEC_GET)/g' \
-e 's/@''GNULIB_TIMESPEC_GETRES''@/$(GL_GNULIB_TIMESPEC_GETRES)/g' \
@@ -3738,7 +3895,10 @@ time.h: time.in.h $(top_builddir)/config.status $(CXXDEFS_H) $(ARG_NONNULL_H) $(
-e 's|@''REPLACE_MKTIME''@|$(REPLACE_MKTIME)|g' \
-e 's|@''REPLACE_NANOSLEEP''@|$(REPLACE_NANOSLEEP)|g' \
-e 's|@''REPLACE_STRFTIME''@|$(REPLACE_STRFTIME)|g' \
+ -e 's|@''REPLACE_TIME''@|$(REPLACE_TIME)|g' \
-e 's|@''REPLACE_TIMEGM''@|$(REPLACE_TIMEGM)|g' \
+ -e 's|@''REPLACE_TIMESPEC_GET''@|$(REPLACE_TIMESPEC_GET)|g' \
+ -e 's|@''REPLACE_TIMESPEC_GETRES''@|$(REPLACE_TIMESPEC_GETRES)|g' \
-e 's|@''REPLACE_TZSET''@|$(REPLACE_TZSET)|g' \
-e 's|@''PTHREAD_H_DEFINES_STRUCT_TIMESPEC''@|$(PTHREAD_H_DEFINES_STRUCT_TIMESPEC)|g' \
-e 's|@''SYS_TIME_H_DEFINES_STRUCT_TIMESPEC''@|$(SYS_TIME_H_DEFINES_STRUCT_TIMESPEC)|g' \
@@ -3755,7 +3915,7 @@ MOSTLYCLEANFILES += time.h time.h-t
EXTRA_DIST += time.in.h
endif
-## end gnulib module time
+## end gnulib module time-h
## begin gnulib module time_r
ifeq (,$(OMIT_GNULIB_MODULE_time_r))
@@ -3867,6 +4027,8 @@ unistd.h: unistd.in.h $(top_builddir)/config.status $(CXXDEFS_H) $(ARG_NONNULL_H
-e 's/@''GNULIB_FDATASYNC''@/$(GL_GNULIB_FDATASYNC)/g' \
-e 's/@''GNULIB_FSYNC''@/$(GL_GNULIB_FSYNC)/g' \
-e 's/@''GNULIB_FTRUNCATE''@/$(GL_GNULIB_FTRUNCATE)/g' \
+ < $(srcdir)/unistd.in.h > $@-t1
+ $(AM_V_at)sed \
-e 's/@''GNULIB_GETCWD''@/$(GL_GNULIB_GETCWD)/g' \
-e 's/@''GNULIB_GETDOMAINNAME''@/$(GL_GNULIB_GETDOMAINNAME)/g' \
-e 's/@''GNULIB_GETDTABLESIZE''@/$(GL_GNULIB_GETDTABLESIZE)/g' \
@@ -3928,8 +4090,9 @@ unistd.h: unistd.in.h $(top_builddir)/config.status $(CXXDEFS_H) $(ARG_NONNULL_H
-e 's/@''GNULIB_MDA_SWAB''@/$(GL_GNULIB_MDA_SWAB)/g' \
-e 's/@''GNULIB_MDA_UNLINK''@/$(GL_GNULIB_MDA_UNLINK)/g' \
-e 's/@''GNULIB_MDA_WRITE''@/$(GL_GNULIB_MDA_WRITE)/g' \
- < $(srcdir)/unistd.in.h | \
- sed -e 's|@''HAVE_CHOWN''@|$(HAVE_CHOWN)|g' \
+ < $@-t1 > $@-t2
+ $(AM_V_at)sed \
+ -e 's|@''HAVE_CHOWN''@|$(HAVE_CHOWN)|g' \
-e 's|@''HAVE_COPY_FILE_RANGE''@|$(HAVE_COPY_FILE_RANGE)|g' \
-e 's|@''HAVE_DUP3''@|$(HAVE_DUP3)|g' \
-e 's|@''HAVE_EUIDACCESS''@|$(HAVE_EUIDACCESS)|g' \
@@ -3976,13 +4139,15 @@ unistd.h: unistd.in.h $(top_builddir)/config.status $(CXXDEFS_H) $(ARG_NONNULL_H
-e 's|@''HAVE_DECL_TTYNAME_R''@|$(HAVE_DECL_TTYNAME_R)|g' \
-e 's|@''HAVE_OS_H''@|$(HAVE_OS_H)|g' \
-e 's|@''HAVE_SYS_PARAM_H''@|$(HAVE_SYS_PARAM_H)|g' \
- | \
- sed -e 's|@''REPLACE_ACCESS''@|$(REPLACE_ACCESS)|g' \
+ < $@-t2 > $@-t3
+ $(AM_V_at)sed \
+ -e 's|@''REPLACE_ACCESS''@|$(REPLACE_ACCESS)|g' \
-e 's|@''REPLACE_CHOWN''@|$(REPLACE_CHOWN)|g' \
-e 's|@''REPLACE_CLOSE''@|$(REPLACE_CLOSE)|g' \
-e 's|@''REPLACE_COPY_FILE_RANGE''@|$(REPLACE_COPY_FILE_RANGE)|g' \
-e 's|@''REPLACE_DUP''@|$(REPLACE_DUP)|g' \
-e 's|@''REPLACE_DUP2''@|$(REPLACE_DUP2)|g' \
+ -e 's|@''REPLACE_DUP3''@|$(REPLACE_DUP3)|g' \
-e 's|@''REPLACE_EXECL''@|$(REPLACE_EXECL)|g' \
-e 's|@''REPLACE_EXECLE''@|$(REPLACE_EXECLE)|g' \
-e 's|@''REPLACE_EXECLP''@|$(REPLACE_EXECLP)|g' \
@@ -3991,11 +4156,14 @@ unistd.h: unistd.in.h $(top_builddir)/config.status $(CXXDEFS_H) $(ARG_NONNULL_H
-e 's|@''REPLACE_EXECVP''@|$(REPLACE_EXECVP)|g' \
-e 's|@''REPLACE_EXECVPE''@|$(REPLACE_EXECVPE)|g' \
-e 's|@''REPLACE_FACCESSAT''@|$(REPLACE_FACCESSAT)|g' \
+ -e 's|@''REPLACE_FCHDIR''@|$(REPLACE_FCHDIR)|g' \
-e 's|@''REPLACE_FCHOWNAT''@|$(REPLACE_FCHOWNAT)|g' \
+ -e 's|@''REPLACE_FDATASYNC''@|$(REPLACE_FDATASYNC)|g' \
-e 's|@''REPLACE_FTRUNCATE''@|$(REPLACE_FTRUNCATE)|g' \
-e 's|@''REPLACE_GETCWD''@|$(REPLACE_GETCWD)|g' \
-e 's|@''REPLACE_GETDOMAINNAME''@|$(REPLACE_GETDOMAINNAME)|g' \
-e 's|@''REPLACE_GETDTABLESIZE''@|$(REPLACE_GETDTABLESIZE)|g' \
+ -e 's|@''REPLACE_GETENTROPY''@|$(REPLACE_GETENTROPY)|g' \
-e 's|@''REPLACE_GETLOGIN_R''@|$(REPLACE_GETLOGIN_R)|g' \
-e 's|@''REPLACE_GETGROUPS''@|$(REPLACE_GETGROUPS)|g' \
-e 's|@''REPLACE_GETPAGESIZE''@|$(REPLACE_GETPAGESIZE)|g' \
@@ -4006,12 +4174,14 @@ unistd.h: unistd.in.h $(top_builddir)/config.status $(CXXDEFS_H) $(ARG_NONNULL_H
-e 's|@''REPLACE_LINK''@|$(REPLACE_LINK)|g' \
-e 's|@''REPLACE_LINKAT''@|$(REPLACE_LINKAT)|g' \
-e 's|@''REPLACE_LSEEK''@|$(REPLACE_LSEEK)|g' \
+ -e 's|@''REPLACE_PIPE2''@|$(REPLACE_PIPE2)|g' \
-e 's|@''REPLACE_PREAD''@|$(REPLACE_PREAD)|g' \
-e 's|@''REPLACE_PWRITE''@|$(REPLACE_PWRITE)|g' \
-e 's|@''REPLACE_READ''@|$(REPLACE_READ)|g' \
-e 's|@''REPLACE_READLINK''@|$(REPLACE_READLINK)|g' \
-e 's|@''REPLACE_READLINKAT''@|$(REPLACE_READLINKAT)|g' \
-e 's|@''REPLACE_RMDIR''@|$(REPLACE_RMDIR)|g' \
+ -e 's|@''REPLACE_SETHOSTNAME''@|$(REPLACE_SETHOSTNAME)|g' \
-e 's|@''REPLACE_SLEEP''@|$(REPLACE_SLEEP)|g' \
-e 's|@''REPLACE_SYMLINK''@|$(REPLACE_SYMLINK)|g' \
-e 's|@''REPLACE_SYMLINKAT''@|$(REPLACE_SYMLINKAT)|g' \
@@ -4027,9 +4197,10 @@ unistd.h: unistd.in.h $(top_builddir)/config.status $(CXXDEFS_H) $(ARG_NONNULL_H
-e '/definitions of _GL_FUNCDECL_RPL/r $(CXXDEFS_H)' \
-e '/definition of _GL_ARG_NONNULL/r $(ARG_NONNULL_H)' \
-e '/definition of _GL_WARN_ON_USE/r $(WARN_ON_USE_H)' \
- > $@-t
- $(AM_V_at)mv $@-t $@
-MOSTLYCLEANFILES += unistd.h unistd.h-t
+ < $@-t3 > $@-t4
+ $(AM_V_at)rm -f $@-t1 $@-t2 $@-t3
+ $(AM_V_at)mv $@-t4 $@
+MOSTLYCLEANFILES += unistd.h unistd.h-t1 unistd.h-t2 unistd.h-t3 unistd.h-t4
EXTRA_DIST += unistd.in.h
diff --git a/lib/group-member.c b/lib/group-member.c
index 300d58bdbaa..43b49831003 100644
--- a/lib/group-member.c
+++ b/lib/group-member.c
@@ -1,7 +1,7 @@
/* group-member.c -- determine whether group id is in calling user's group list
- Copyright (C) 1994, 1997-1998, 2003, 2005-2006, 2009-2024 Free
- Software Foundation, Inc.
+ Copyright (C) 1994, 1997-1998, 2003, 2005-2006, 2009-2024 Free Software
+ Foundation, Inc.
This file is free software: you can redistribute it and/or modify
it under the terms of the GNU Lesser General Public License as
diff --git a/lib/intprops-internal.h b/lib/intprops-internal.h
index dcbf537786a..c8a87d2bb27 100644
--- a/lib/intprops-internal.h
+++ b/lib/intprops-internal.h
@@ -20,6 +20,11 @@
#include <limits.h>
+/* Pacify GCC 13.2 in some calls to _GL_EXPR_SIGNED. */
+#if defined __GNUC__ && 4 < __GNUC__ + (3 <= __GNUC_MINOR__)
+# pragma GCC diagnostic ignored "-Wtype-limits"
+#endif
+
/* Return a value with the common real type of E and V and the value of V.
Do not evaluate E. */
#define _GL_INT_CONVERT(e, v) ((1 ? 0 : (e)) + (v))
diff --git a/lib/inttypes.in.h b/lib/inttypes.in.h
index 8e067e29ca0..b9ab8a4b424 100644
--- a/lib/inttypes.in.h
+++ b/lib/inttypes.in.h
@@ -46,6 +46,11 @@
#if ! defined INTTYPES_H && ! defined _GL_JUST_INCLUDE_SYSTEM_INTTYPES_H
#define INTTYPES_H
+/* This file uses GNULIB_POSIXCHECK, HAVE_RAW_DECL_*. */
+#if !_GL_CONFIG_H_INCLUDED
+ #error "Please include config.h first."
+#endif
+
/* Include <stdint.h> or the gnulib replacement.
But avoid namespace pollution on glibc systems. */
#ifndef __GLIBC__
@@ -903,8 +908,21 @@ extern "C" {
#endif
#if @GNULIB_IMAXABS@
-# if !@HAVE_DECL_IMAXABS@
-extern intmax_t imaxabs (intmax_t);
+# if @REPLACE_IMAXABS@
+# if !(defined __cplusplus && defined GNULIB_NAMESPACE)
+# undef imaxabs
+# define imaxabs rpl_imaxabs
+# endif
+_GL_FUNCDECL_RPL (imaxabs, intmax_t, (intmax_t x));
+_GL_CXXALIAS_RPL (imaxabs, intmax_t, (intmax_t x));
+# else
+# if !@HAVE_DECL_IMAXABS@
+_GL_FUNCDECL_SYS (imaxabs, intmax_t, (intmax_t x));
+# endif
+_GL_CXXALIAS_SYS (imaxabs, intmax_t, (intmax_t x));
+# endif
+# if __GLIBC__ >= 2
+_GL_CXXALIASWARN (imaxabs);
# endif
#elif defined GNULIB_POSIXCHECK
# undef imaxabs
@@ -921,8 +939,21 @@ typedef struct { intmax_t quot; intmax_t rem; } imaxdiv_t;
# define GNULIB_defined_imaxdiv_t 1
# endif
# endif
-# if !@HAVE_DECL_IMAXDIV@
-extern imaxdiv_t imaxdiv (intmax_t, intmax_t);
+# if @REPLACE_IMAXDIV@
+# if !(defined __cplusplus && defined GNULIB_NAMESPACE)
+# undef imaxdiv
+# define imaxdiv rpl_imaxdiv
+# endif
+_GL_FUNCDECL_RPL (imaxdiv, imaxdiv_t, (intmax_t numer, intmax_t denom));
+_GL_CXXALIAS_RPL (imaxdiv, imaxdiv_t, (intmax_t numer, intmax_t denom));
+# else
+# if !@HAVE_DECL_IMAXDIV@
+_GL_FUNCDECL_SYS (imaxdiv, imaxdiv_t, (intmax_t numer, intmax_t denom));
+# endif
+_GL_CXXALIAS_SYS (imaxdiv, imaxdiv_t, (intmax_t numer, intmax_t denom));
+# endif
+# if __GLIBC__ >= 2
+_GL_CXXALIASWARN (imaxdiv);
# endif
#elif defined GNULIB_POSIXCHECK
# undef imaxdiv
diff --git a/lib/libc-config.h b/lib/libc-config.h
index 0364c560aa5..70114608fb1 100644
--- a/lib/libc-config.h
+++ b/lib/libc-config.h
@@ -137,8 +137,6 @@
# undef __attribute_returns_twice__
# undef __attribute_used__
# undef __attribute_warn_unused_result__
-# undef __bos
-# undef __bos0
# undef __errordecl
# undef __extension__
# undef __extern_always_inline
@@ -147,21 +145,13 @@
# 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
@@ -170,6 +160,18 @@
# undef __va_arg_pack_len
# undef __warnattr
# undef __wur
+# ifndef __GNULIB_CDEFS
+# undef __bos
+# undef __bos0
+# undef __glibc_fortify
+# undef __glibc_fortify_n
+# undef __glibc_objsize
+# undef __glibc_objsize0
+# undef __glibc_safe_len_cond
+# undef __glibc_safe_or_unknown_len
+# undef __glibc_unsafe_len
+# undef __glibc_unsigned_or_positive
+# endif
/* Include our copy of glibc <sys/cdefs.h>. */
# include <cdefs.h>
diff --git a/lib/limits.in.h b/lib/limits.in.h
index cca1f6167fd..c65eb4c1cfe 100644
--- a/lib/limits.in.h
+++ b/lib/limits.in.h
@@ -99,7 +99,12 @@
# endif
#endif
-/* Macros specified by C2x and by ISO/IEC TS 18661-1:2014. */
+/* Assume no multibyte character is longer than 16 bytes. */
+#ifndef MB_LEN_MAX
+# define MB_LEN_MAX 16
+#endif
+
+/* Macros specified by C23 and by ISO/IEC TS 18661-1:2014. */
#if (! defined ULLONG_WIDTH \
&& (defined _GNU_SOURCE || defined __STDC_WANT_IEC_60559_BFP_EXT__ \
@@ -117,13 +122,28 @@
# define ULLONG_WIDTH _GL_INTEGER_WIDTH (0, ULLONG_MAX)
#endif
-/* Macros specified by C2x. */
+/* Macros specified by C23. */
-#if (! defined BOOL_WIDTH \
- && (defined _GNU_SOURCE \
- || (defined __STDC_VERSION__ && 201710 < __STDC_VERSION__)))
-# define BOOL_MAX 1
-# define BOOL_WIDTH 1
+#if (defined _GNU_SOURCE \
+ || (defined __STDC_VERSION__ && 201710 < __STDC_VERSION__))
+# if ! defined BOOL_WIDTH
+# define BOOL_WIDTH 1
+# define BOOL_MAX 1
+# elif ! defined BOOL_MAX
+# define BOOL_MAX 1
+# endif
+#endif
+
+/* Macro specified by POSIX. */
+
+/* The maximum ssize_t value. Although it might not be of ssize_t type
+ as it should be, it's too much trouble to fix this minor detail. */
+#ifndef SSIZE_MAX
+# ifdef _WIN64
+# define SSIZE_MAX LLONG_MAX
+# else
+# define SSIZE_MAX LONG_MAX
+# endif
#endif
#endif /* _@GUARD_PREFIX@_LIMITS_H */
diff --git a/lib/malloc.c b/lib/malloc.c
index 7b954ae1129..2a7867a1d1f 100644
--- a/lib/malloc.c
+++ b/lib/malloc.c
@@ -1,7 +1,6 @@
/* malloc() function that is glibc compatible.
- Copyright (C) 1997-1998, 2006-2007, 2009-2024 Free Software
- Foundation, Inc.
+ Copyright (C) 1997-1998, 2006-2007, 2009-2024 Free Software Foundation, Inc.
This file is free software: you can redistribute it and/or modify
it under the terms of the GNU Lesser General Public License as
diff --git a/lib/malloc/dynarray_emplace_enlarge.c b/lib/malloc/dynarray_emplace_enlarge.c
index 7c4c4c66e75..7bdba1597e0 100644
--- a/lib/malloc/dynarray_emplace_enlarge.c
+++ b/lib/malloc/dynarray_emplace_enlarge.c
@@ -22,7 +22,7 @@
#include <dynarray.h>
#include <errno.h>
-#include <intprops.h>
+#include <stdckdint.h>
#include <stdlib.h>
#include <string.h>
@@ -56,7 +56,7 @@ __libc_dynarray_emplace_enlarge (struct dynarray_header *list,
}
size_t new_size;
- if (INT_MULTIPLY_WRAPV (new_allocated, element_size, &new_size))
+ if (ckd_mul (&new_size, new_allocated, element_size))
return false;
void *new_array;
if (list->array == scratch)
diff --git a/lib/malloc/dynarray_resize.c b/lib/malloc/dynarray_resize.c
index b28da9bfc8a..7323f8eeb0c 100644
--- a/lib/malloc/dynarray_resize.c
+++ b/lib/malloc/dynarray_resize.c
@@ -22,7 +22,7 @@
#include <dynarray.h>
#include <errno.h>
-#include <intprops.h>
+#include <stdckdint.h>
#include <stdlib.h>
#include <string.h>
@@ -42,7 +42,7 @@ __libc_dynarray_resize (struct dynarray_header *list, size_t size,
over-allocation here. */
size_t new_size_bytes;
- if (INT_MULTIPLY_WRAPV (size, element_size, &new_size_bytes))
+ if (ckd_mul (&new_size_bytes, size, element_size))
{
/* Overflow. */
__set_errno (ENOMEM);
diff --git a/lib/md5-stream.c b/lib/md5-stream.c
index ca82b067e42..c82f18145e0 100644
--- a/lib/md5-stream.c
+++ b/lib/md5-stream.c
@@ -1,7 +1,7 @@
/* Functions to compute MD5 message digest of files or memory blocks.
according to the definition of MD5 in RFC 1321 from April 1992.
- Copyright (C) 1995-1997, 1999-2001, 2005-2006, 2008-2024 Free
- Software Foundation, Inc.
+ Copyright (C) 1995-1997, 1999-2001, 2005-2006, 2008-2024 Free Software
+ Foundation, Inc.
This file is part of the GNU C Library.
This file is free software: you can redistribute it and/or modify
diff --git a/lib/md5.c b/lib/md5.c
index 1818216a4b9..8e02f15d14d 100644
--- a/lib/md5.c
+++ b/lib/md5.c
@@ -1,7 +1,7 @@
/* Functions to compute MD5 message digest of files or memory blocks.
according to the definition of MD5 in RFC 1321 from April 1992.
- Copyright (C) 1995-1997, 1999-2001, 2005-2006, 2008-2024 Free
- Software Foundation, Inc.
+ Copyright (C) 1995-1997, 1999-2001, 2005-2006, 2008-2024 Free Software
+ Foundation, Inc.
This file is part of the GNU C Library.
This file is free software: you can redistribute it and/or modify
diff --git a/lib/md5.h b/lib/md5.h
index 0938daa8628..2f470703f5c 100644
--- a/lib/md5.h
+++ b/lib/md5.h
@@ -1,7 +1,7 @@
/* Declaration of functions and data types used for MD5 sum computing
library functions.
- Copyright (C) 1995-1997, 1999-2001, 2004-2006, 2008-2024 Free
- Software Foundation, Inc.
+ Copyright (C) 1995-1997, 1999-2001, 2004-2006, 2008-2024 Free Software
+ Foundation, Inc.
This file is part of the GNU C Library.
This file is free software: you can redistribute it and/or modify
@@ -20,6 +20,11 @@
#ifndef _MD5_H
#define _MD5_H 1
+/* This file uses HAVE_OPENSSL_MD5. */
+#if !_GL_CONFIG_H_INCLUDED
+ #error "Please include config.h first."
+#endif
+
#include <stdio.h>
#include <stdint.h>
@@ -27,7 +32,21 @@
# ifndef OPENSSL_API_COMPAT
# define OPENSSL_API_COMPAT 0x10101000L /* FIXME: Use OpenSSL 1.1+ API. */
# endif
-# include <openssl/md5.h>
+/* If <openssl/macros.h> would give a compile-time error, don't use OpenSSL. */
+# include <openssl/opensslv.h>
+# if OPENSSL_VERSION_MAJOR >= 3
+# include <openssl/configuration.h>
+# if (OPENSSL_CONFIGURED_API \
+ < (OPENSSL_API_COMPAT < 0x900000L ? OPENSSL_API_COMPAT : \
+ ((OPENSSL_API_COMPAT >> 28) & 0xF) * 10000 \
+ + ((OPENSSL_API_COMPAT >> 20) & 0xFF) * 100 \
+ + ((OPENSSL_API_COMPAT >> 12) & 0xFF)))
+# undef HAVE_OPENSSL_MD5
+# endif
+# endif
+# if HAVE_OPENSSL_MD5
+# include <openssl/md5.h>
+# endif
# endif
#define MD5_DIGEST_SIZE 16
@@ -44,7 +63,11 @@
#ifndef __THROW
# if defined __cplusplus && (__GNUC_PREREQ (2,8) || __clang_major__ >= 4)
-# define __THROW throw ()
+# if __cplusplus >= 201103L
+# define __THROW noexcept (true)
+# else
+# define __THROW throw ()
+# endif
# else
# define __THROW
# endif
diff --git a/lib/memmem.c b/lib/memmem.c
index 6fbc36e6654..e9b8c5392b6 100644
--- a/lib/memmem.c
+++ b/lib/memmem.c
@@ -1,5 +1,5 @@
-/* Copyright (C) 1991-1994, 1996-1998, 2000, 2004, 2007-2024 Free
- Software Foundation, Inc.
+/* Copyright (C) 1991-1994, 1996-1998, 2000, 2004, 2007-2024 Free Software
+ Foundation, Inc.
This file is part of the GNU C Library.
This file is free software: you can redistribute it and/or modify
diff --git a/lib/memrchr.c b/lib/memrchr.c
index 025869b6022..3df1f479c78 100644
--- a/lib/memrchr.c
+++ b/lib/memrchr.c
@@ -1,7 +1,7 @@
/* memrchr -- find the last occurrence of a byte in a memory block
- Copyright (C) 1991, 1993, 1996-1997, 1999-2000, 2003-2024 Free
- Software Foundation, Inc.
+ Copyright (C) 1991, 1993, 1996-1997, 1999-2000, 2003-2024 Free Software
+ Foundation, Inc.
Based on strlen implementation by Torbjorn Granlund (tege@sics.se),
with help from Dan Sahlin (dan@sics.se) and
diff --git a/lib/memset_explicit.c b/lib/memset_explicit.c
new file mode 100644
index 00000000000..cf6cc647847
--- /dev/null
+++ b/lib/memset_explicit.c
@@ -0,0 +1,55 @@
+/* Erase sensitive data from memory.
+ Copyright 2022-2024 Free Software Foundation, Inc.
+
+ This file is free software: you can redistribute it and/or modify
+ it under the terms of the GNU Lesser General Public License as
+ published by the Free Software Foundation; either version 2.1 of the
+ License, or (at your option) any later version.
+
+ This file 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 Lesser General Public License for more details.
+
+ You should have received a copy of the GNU Lesser General Public License
+ along with this program. If not, see <https://www.gnu.org/licenses/>. */
+
+#include <config.h>
+
+/* memset_s need this define */
+#if HAVE_MEMSET_S
+# define __STDC_WANT_LIB_EXT1__ 1
+#endif
+
+#include <string.h>
+
+/* Set S's bytes to C, where S has LEN bytes. The compiler will not
+ optimize effects away, even if S is dead after the call. */
+void *
+memset_explicit (void *s, int c, size_t len)
+{
+#if HAVE_EXPLICIT_MEMSET
+ return explicit_memset (s, c, len);
+#elif HAVE_MEMSET_S
+ (void) memset_s (s, len, c, len);
+ return s;
+#elif defined __GNUC__ && !defined __clang__
+ memset (s, c, len);
+ /* Compiler barrier. */
+ __asm__ volatile ("" ::: "memory");
+ return s;
+#elif defined __clang__
+ memset (s, c, len);
+ /* Compiler barrier. */
+ /* With asm ("" ::: "memory") LLVM analyzes uses of 's' and finds that the
+ whole thing is dead and eliminates it. Use 'g' to work around this
+ problem. See <https://bugs.llvm.org/show_bug.cgi?id=15495#c11>. */
+ __asm__ volatile ("" : : "g"(s) : "memory");
+ return s;
+#else
+ /* Invoke memset through a volatile function pointer. This defeats compiler
+ optimizations. */
+ void * (* const volatile volatile_memset) (void *, int, size_t) = memset;
+ return volatile_memset (s, c, len);
+#endif
+}
diff --git a/lib/mini-gmp.c b/lib/mini-gmp.c
index ea037b801dc..69a72bfd460 100644
--- a/lib/mini-gmp.c
+++ b/lib/mini-gmp.c
@@ -172,12 +172,19 @@ see https://www.gnu.org/licenses/. */
} \
} while (0)
+/* If mp_limb_t is of size smaller than int, plain u*v implies
+ automatic promotion to *signed* int, and then multiply may overflow
+ and cause undefined behavior. Explicitly cast to unsigned int for
+ that case. */
+#define gmp_umullo_limb(u, v) \
+ ((sizeof(mp_limb_t) >= sizeof(int)) ? (u)*(v) : (unsigned int)(u) * (v))
+
#define gmp_udiv_qrnnd_preinv(q, r, nh, nl, d, di) \
do { \
mp_limb_t _qh, _ql, _r, _mask; \
gmp_umul_ppmm (_qh, _ql, (nh), (di)); \
gmp_add_ssaaaa (_qh, _ql, _qh, _ql, (nh) + 1, (nl)); \
- _r = (nl) - _qh * (d); \
+ _r = (nl) - gmp_umullo_limb (_qh, (d)); \
_mask = -(mp_limb_t) (_r > _ql); /* both > and >= are OK */ \
_qh += _mask; \
_r += _mask & (d); \
@@ -198,7 +205,7 @@ see https://www.gnu.org/licenses/. */
gmp_add_ssaaaa ((q), _q0, (q), _q0, (n2), (n1)); \
\
/* Compute the two most significant limbs of n - q'd */ \
- (r1) = (n1) - (d1) * (q); \
+ (r1) = (n1) - gmp_umullo_limb ((d1), (q)); \
gmp_sub_ddmmss ((r1), (r0), (r1), (n0), (d1), (d0)); \
gmp_umul_ppmm (_t1, _t0, (d0), (q)); \
gmp_sub_ddmmss ((r1), (r0), (r1), (r0), _t1, _t0); \
diff --git a/lib/minmax.h b/lib/minmax.h
index c72e4e3a1dd..f3df58b0d70 100644
--- a/lib/minmax.h
+++ b/lib/minmax.h
@@ -23,6 +23,11 @@
MIN, MAX macro redefinitions on some systems; the workaround is to
#include this file as the last one among the #include list. */
+/* This file uses HAVE_MINMAX_IN_LIMITS_H, HAVE_MINMAX_IN_SYS_PARAM_H. */
+#if !_GL_CONFIG_H_INCLUDED
+ #error "Please include config.h first."
+#endif
+
/* Before we define the following symbols we get the <limits.h> file
since otherwise we get redefinitions on some systems if <limits.h> is
included after this file. Likewise for <sys/param.h>.
diff --git a/lib/mktime.c b/lib/mktime.c
index 6d0e2a98acb..c704f415740 100644
--- a/lib/mktime.c
+++ b/lib/mktime.c
@@ -46,6 +46,7 @@
#include <errno.h>
#include <limits.h>
#include <stdbool.h>
+#include <stdckdint.h>
#include <stdlib.h>
#include <string.h>
@@ -379,7 +380,7 @@ __mktime_internal (struct tm *tp,
/* Invert CONVERT by probing. First assume the same offset as last
time. */
- INT_SUBTRACT_WRAPV (0, off, &negative_offset_guess);
+ ckd_sub (&negative_offset_guess, 0, off);
long_int t0 = ydhms_diff (year, yday, hour, min, sec,
EPOCH_YEAR - TM_YEAR_BASE, 0, 0, 0,
negative_offset_guess);
@@ -465,7 +466,7 @@ __mktime_internal (struct tm *tp,
for (direction = -1; direction <= 1; direction += 2)
{
long_int ot;
- if (! INT_ADD_WRAPV (t, delta * direction, &ot))
+ if (! ckd_add (&ot, t, delta * direction))
{
struct tm otm;
if (! ranged_convert (convert, &ot, &otm))
@@ -503,8 +504,8 @@ __mktime_internal (struct tm *tp,
/* Set *OFFSET to the low-order bits of T - T0 - NEGATIVE_OFFSET_GUESS.
This is just a heuristic to speed up the next mktime call, and
correctness is unaffected if integer overflow occurs here. */
- INT_SUBTRACT_WRAPV (t, t0, offset);
- INT_SUBTRACT_WRAPV (*offset, negative_offset_guess, offset);
+ ckd_sub (offset, t, t0);
+ ckd_sub (offset, *offset, negative_offset_guess);
if (LEAP_SECONDS_POSSIBLE && sec_requested != tm.tm_sec)
{
@@ -513,7 +514,7 @@ __mktime_internal (struct tm *tp,
long_int sec_adjustment = sec == 0 && tm.tm_sec == 60;
sec_adjustment -= sec;
sec_adjustment += sec_requested;
- if (INT_ADD_WRAPV (t, sec_adjustment, &t)
+ if (ckd_add (&t, t, sec_adjustment)
|| ! (mktime_min <= t && t <= mktime_max))
{
__set_errno (EOVERFLOW);
diff --git a/lib/nanosleep.c b/lib/nanosleep.c
index e5fa4c70386..c6a76ec0eb4 100644
--- a/lib/nanosleep.c
+++ b/lib/nanosleep.c
@@ -1,7 +1,6 @@
/* Provide a replacement for the POSIX nanosleep function.
- Copyright (C) 1999-2000, 2002, 2004-2024 Free Software Foundation,
- Inc.
+ Copyright (C) 1999-2000, 2002, 2004-2024 Free Software Foundation, Inc.
This file is free software: you can redistribute it and/or modify
it under the terms of the GNU Lesser General Public License as
@@ -61,8 +60,7 @@ nanosleep (const struct timespec *requested_delay,
static_assert (TYPE_MAXIMUM (time_t) / 24 / 24 / 60 / 60);
const time_t limit = 24 * 24 * 60 * 60;
time_t seconds = requested_delay->tv_sec;
- struct timespec intermediate;
- intermediate.tv_nsec = requested_delay->tv_nsec;
+ struct timespec intermediate = *requested_delay;
while (limit < seconds)
{
diff --git a/lib/nproc.c b/lib/nproc.c
index e21152ade7d..92a07e82890 100644
--- a/lib/nproc.c
+++ b/lib/nproc.c
@@ -46,7 +46,7 @@
# include <sys/param.h>
#endif
-#if HAVE_SYS_SYSCTL_H && ! defined __GLIBC__
+#if HAVE_SYS_SYSCTL_H && !(defined __GLIBC__ && defined __linux__)
# include <sys/sysctl.h>
#endif
@@ -306,7 +306,7 @@ num_processors_ignoring_omp (enum nproc_query query)
/* Finally, as fallback, use the APIs that don't distinguish between
NPROC_CURRENT and NPROC_ALL. */
-#if HAVE_SYSCTL && ! defined __GLIBC__ && defined HW_NCPU
+#if HAVE_SYSCTL && !(defined __GLIBC__ && defined __linux__) && defined HW_NCPU
{ /* This works on macOS, FreeBSD, NetBSD, OpenBSD.
macOS 10.14 does not allow mib to be const. */
int nprocs;
diff --git a/lib/nstrftime.c b/lib/nstrftime.c
index b058ec6a621..88490064297 100644
--- a/lib/nstrftime.c
+++ b/lib/nstrftime.c
@@ -1,5 +1,6 @@
-/* Copyright (C) 1991-2024 Free Software Foundation, Inc.
- This file is part of the GNU C Library.
+/* Generate time strings.
+
+ Copyright (C) 2024 Free Software Foundation, Inc.
This file is free software: you can redistribute it and/or modify
it under the terms of the GNU Lesser General Public License as
@@ -14,1477 +15,5 @@
You should have received a copy of the GNU Lesser General Public License
along with this program. If not, see <https://www.gnu.org/licenses/>. */
-#ifdef _LIBC
-# define USE_IN_EXTENDED_LOCALE_MODEL 1
-# define HAVE_STRUCT_ERA_ENTRY 1
-# define HAVE_TM_GMTOFF 1
-# define HAVE_STRUCT_TM_TM_ZONE 1
-# define HAVE_TZNAME 1
-# include "../locale/localeinfo.h"
-#else
-# include <libc-config.h>
-# if FPRINTFTIME
-# include "fprintftime.h"
-# else
-# include "strftime.h"
-# endif
-# include "time-internal.h"
-#endif
-
-#include <ctype.h>
-#include <errno.h>
-#include <time.h>
-
-#if HAVE_TZNAME && !HAVE_DECL_TZNAME
-extern char *tzname[];
-#endif
-
-/* Do multibyte processing if multibyte encodings are supported, unless
- multibyte sequences are safe in formats. Multibyte sequences are
- safe if they cannot contain byte sequences that look like format
- conversion specifications. The multibyte encodings used by the
- C library on the various platforms (UTF-8, GB2312, GBK, CP936,
- GB18030, EUC-TW, BIG5, BIG5-HKSCS, CP950, EUC-JP, EUC-KR, CP949,
- SHIFT_JIS, CP932, JOHAB) are safe for formats, because the byte '%'
- cannot occur in a multibyte character except in the first byte.
-
- The DEC-HANYU encoding used on OSF/1 is not safe for formats, but
- this encoding has never been seen in real-life use, so we ignore
- it. */
-#if !(defined __osf__ && 0)
-# define MULTIBYTE_IS_FORMAT_SAFE 1
-#endif
-#define DO_MULTIBYTE (! MULTIBYTE_IS_FORMAT_SAFE)
-
-#if DO_MULTIBYTE
-# include <wchar.h>
- static const mbstate_t mbstate_zero;
-#endif
-
-#include <limits.h>
-#include <stddef.h>
-#include <stdlib.h>
-#include <string.h>
-
-#include "attribute.h"
-#include <intprops.h>
-
-#ifdef COMPILE_WIDE
-# include <endian.h>
-# define CHAR_T wchar_t
-# define UCHAR_T unsigned int
-# define L_(Str) L##Str
-# define NLW(Sym) _NL_W##Sym
-
-# define MEMCPY(d, s, n) __wmemcpy (d, s, n)
-# define STRLEN(s) __wcslen (s)
-
-#else
-# define CHAR_T char
-# define UCHAR_T unsigned char
-# define L_(Str) Str
-# define NLW(Sym) Sym
-# define ABALTMON_1 _NL_ABALTMON_1
-
-# define MEMCPY(d, s, n) memcpy (d, s, n)
-# define STRLEN(s) strlen (s)
-
-#endif
-
-/* Shift A right by B bits portably, by dividing A by 2**B and
- truncating towards minus infinity. A and B should be free of side
- effects, and B should be in the range 0 <= B <= INT_BITS - 2, where
- INT_BITS is the number of useful bits in an int. GNU code can
- assume that INT_BITS is at least 32.
-
- ISO C99 says that A >> B is implementation-defined if A < 0. Some
- implementations (e.g., UNICOS 9.0 on a Cray Y-MP EL) don't shift
- right in the usual way when A < 0, so SHR falls back on division if
- ordinary A >> B doesn't seem to be the usual signed shift. */
-#define SHR(a, b) \
- (-1 >> 1 == -1 \
- ? (a) >> (b) \
- : ((a) + ((a) < 0)) / (1 << (b)) - ((a) < 0))
-
-#define TM_YEAR_BASE 1900
-
-#ifndef __isleap
-/* Nonzero if YEAR is a leap year (every 4 years,
- except every 100th isn't, and every 400th is). */
-# define __isleap(year) \
- ((year) % 4 == 0 && ((year) % 100 != 0 || (year) % 400 == 0))
-#endif
-
-
-#ifdef _LIBC
-# define mktime_z(tz, tm) mktime (tm)
-# define tzname __tzname
-# define tzset __tzset
-#endif
-
-#ifndef FPRINTFTIME
-# define FPRINTFTIME 0
-#endif
-
-#if FPRINTFTIME
-# define STREAM_OR_CHAR_T FILE
-# define STRFTIME_ARG(x) /* empty */
-#else
-# define STREAM_OR_CHAR_T CHAR_T
-# define STRFTIME_ARG(x) x,
-#endif
-
-#if FPRINTFTIME
-# define memset_byte(P, Len, Byte) \
- do { size_t _i; for (_i = 0; _i < Len; _i++) fputc (Byte, P); } while (0)
-# define memset_space(P, Len) memset_byte (P, Len, ' ')
-# define memset_zero(P, Len) memset_byte (P, Len, '0')
-#elif defined COMPILE_WIDE
-# define memset_space(P, Len) (wmemset (P, L' ', Len), (P) += (Len))
-# define memset_zero(P, Len) (wmemset (P, L'0', Len), (P) += (Len))
-#else
-# define memset_space(P, Len) (memset (P, ' ', Len), (P) += (Len))
-# define memset_zero(P, Len) (memset (P, '0', Len), (P) += (Len))
-#endif
-
-#if FPRINTFTIME
-# define advance(P, N)
-#else
-# define advance(P, N) ((P) += (N))
-#endif
-
-#define add(n, f) width_add (width, n, f)
-#define width_add(width, n, f) \
- do \
- { \
- size_t _n = (n); \
- size_t _w = pad == L_('-') || width < 0 ? 0 : width; \
- size_t _incr = _n < _w ? _w : _n; \
- if (_incr >= maxsize - i) \
- { \
- errno = ERANGE; \
- return 0; \
- } \
- if (p) \
- { \
- if (_n < _w) \
- { \
- size_t _delta = _w - _n; \
- if (pad == L_('0') || pad == L_('+')) \
- memset_zero (p, _delta); \
- else \
- memset_space (p, _delta); \
- } \
- f; \
- advance (p, _n); \
- } \
- i += _incr; \
- } while (0)
-
-#define add1(c) width_add1 (width, c)
-#if FPRINTFTIME
-# define width_add1(width, c) width_add (width, 1, fputc (c, p))
-#else
-# define width_add1(width, c) width_add (width, 1, *p = c)
-#endif
-
-#define cpy(n, s) width_cpy (width, n, s)
-#if FPRINTFTIME
-# define width_cpy(width, n, s) \
- width_add (width, n, \
- do \
- { \
- if (to_lowcase) \
- fwrite_lowcase (p, (s), _n); \
- else if (to_uppcase) \
- fwrite_uppcase (p, (s), _n); \
- else \
- { \
- /* Ignore the value of fwrite. The caller can determine whether \
- an error occurred by inspecting ferror (P). All known fwrite \
- implementations set the stream's error indicator when they \
- fail due to ENOMEM etc., even though C11 and POSIX.1-2008 do \
- not require this. */ \
- fwrite (s, _n, 1, p); \
- } \
- } \
- while (0) \
- )
-#else
-# define width_cpy(width, n, s) \
- width_add (width, n, \
- if (to_lowcase) \
- memcpy_lowcase (p, (s), _n LOCALE_ARG); \
- else if (to_uppcase) \
- memcpy_uppcase (p, (s), _n LOCALE_ARG); \
- else \
- MEMCPY ((void *) p, (void const *) (s), _n))
-#endif
-
-#ifdef COMPILE_WIDE
-# ifndef USE_IN_EXTENDED_LOCALE_MODEL
-# undef __mbsrtowcs_l
-# define __mbsrtowcs_l(d, s, l, st, loc) __mbsrtowcs (d, s, l, st)
-# endif
-# define widen(os, ws, l) \
- { \
- mbstate_t __st; \
- const char *__s = os; \
- memset (&__st, '\0', sizeof (__st)); \
- l = __mbsrtowcs_l (NULL, &__s, 0, &__st, loc); \
- ws = (wchar_t *) alloca ((l + 1) * sizeof (wchar_t)); \
- (void) __mbsrtowcs_l (ws, &__s, l, &__st, loc); \
- }
-#endif
-
-
-#if defined _LIBC && defined USE_IN_EXTENDED_LOCALE_MODEL
-/* We use this code also for the extended locale handling where the
- function gets as an additional argument the locale which has to be
- used. To access the values we have to redefine the _NL_CURRENT
- macro. */
-# define strftime __strftime_l
-# define wcsftime __wcsftime_l
-# undef _NL_CURRENT
-# define _NL_CURRENT(category, item) \
- (current->values[_NL_ITEM_INDEX (item)].string)
-# define LOCALE_PARAM , locale_t loc
-# define LOCALE_ARG , loc
-# define HELPER_LOCALE_ARG , current
-#else
-# define LOCALE_PARAM
-# define LOCALE_ARG
-# ifdef _LIBC
-# define HELPER_LOCALE_ARG , _NL_CURRENT_DATA (LC_TIME)
-# else
-# define HELPER_LOCALE_ARG
-# endif
-#endif
-
-#ifdef COMPILE_WIDE
-# ifdef USE_IN_EXTENDED_LOCALE_MODEL
-# define TOUPPER(Ch, L) __towupper_l (Ch, L)
-# define TOLOWER(Ch, L) __towlower_l (Ch, L)
-# else
-# define TOUPPER(Ch, L) towupper (Ch)
-# define TOLOWER(Ch, L) towlower (Ch)
-# endif
-#else
-# ifdef USE_IN_EXTENDED_LOCALE_MODEL
-# define TOUPPER(Ch, L) __toupper_l (Ch, L)
-# define TOLOWER(Ch, L) __tolower_l (Ch, L)
-# else
-# define TOUPPER(Ch, L) toupper (Ch)
-# define TOLOWER(Ch, L) tolower (Ch)
-# endif
-#endif
-/* We don't use 'isdigit' here since the locale dependent
- interpretation is not what we want here. We only need to accept
- the arabic digits in the ASCII range. One day there is perhaps a
- more reliable way to accept other sets of digits. */
-#define ISDIGIT(Ch) ((unsigned int) (Ch) - L_('0') <= 9)
-
-#if FPRINTFTIME
-static void
-fwrite_lowcase (FILE *fp, const CHAR_T *src, size_t len)
-{
- while (len-- > 0)
- {
- fputc (TOLOWER ((UCHAR_T) *src, loc), fp);
- ++src;
- }
-}
-
-static void
-fwrite_uppcase (FILE *fp, const CHAR_T *src, size_t len)
-{
- while (len-- > 0)
- {
- fputc (TOUPPER ((UCHAR_T) *src, loc), fp);
- ++src;
- }
-}
-#else
-static CHAR_T *memcpy_lowcase (CHAR_T *dest, const CHAR_T *src,
- size_t len LOCALE_PARAM);
-
-static CHAR_T *
-memcpy_lowcase (CHAR_T *dest, const CHAR_T *src, size_t len LOCALE_PARAM)
-{
- while (len-- > 0)
- dest[len] = TOLOWER ((UCHAR_T) src[len], loc);
- return dest;
-}
-
-static CHAR_T *memcpy_uppcase (CHAR_T *dest, const CHAR_T *src,
- size_t len LOCALE_PARAM);
-
-static CHAR_T *
-memcpy_uppcase (CHAR_T *dest, const CHAR_T *src, size_t len LOCALE_PARAM)
-{
- while (len-- > 0)
- dest[len] = TOUPPER ((UCHAR_T) src[len], loc);
- return dest;
-}
-#endif
-
-
-#if ! HAVE_TM_GMTOFF
-/* Yield the difference between *A and *B,
- measured in seconds, ignoring leap seconds. */
-# define tm_diff ftime_tm_diff
-static int tm_diff (const struct tm *, const struct tm *);
-static int
-tm_diff (const struct tm *a, const struct tm *b)
-{
- /* Compute intervening leap days correctly even if year is negative.
- Take care to avoid int overflow in leap day calculations,
- but it's OK to assume that A and B are close to each other. */
- int a4 = SHR (a->tm_year, 2) + SHR (TM_YEAR_BASE, 2) - ! (a->tm_year & 3);
- int b4 = SHR (b->tm_year, 2) + SHR (TM_YEAR_BASE, 2) - ! (b->tm_year & 3);
- int a100 = (a4 + (a4 < 0)) / 25 - (a4 < 0);
- int b100 = (b4 + (b4 < 0)) / 25 - (b4 < 0);
- int a400 = SHR (a100, 2);
- int b400 = SHR (b100, 2);
- int intervening_leap_days = (a4 - b4) - (a100 - b100) + (a400 - b400);
- int years = a->tm_year - b->tm_year;
- int days = (365 * years + intervening_leap_days
- + (a->tm_yday - b->tm_yday));
- return (60 * (60 * (24 * days + (a->tm_hour - b->tm_hour))
- + (a->tm_min - b->tm_min))
- + (a->tm_sec - b->tm_sec));
-}
-#endif /* ! HAVE_TM_GMTOFF */
-
-
-
-/* The number of days from the first day of the first ISO week of this
- year to the year day YDAY with week day WDAY. ISO weeks start on
- Monday; the first ISO week has the year's first Thursday. YDAY may
- be as small as YDAY_MINIMUM. */
-#define ISO_WEEK_START_WDAY 1 /* Monday */
-#define ISO_WEEK1_WDAY 4 /* Thursday */
-#define YDAY_MINIMUM (-366)
-static int iso_week_days (int, int);
-static __inline int
-iso_week_days (int yday, int wday)
-{
- /* Add enough to the first operand of % to make it nonnegative. */
- int big_enough_multiple_of_7 = (-YDAY_MINIMUM / 7 + 2) * 7;
- return (yday
- - (yday - wday + ISO_WEEK1_WDAY + big_enough_multiple_of_7) % 7
- + ISO_WEEK1_WDAY - ISO_WEEK_START_WDAY);
-}
-
-
-/* When compiling this file, GNU applications can #define my_strftime
- to a symbol (typically nstrftime) to get an extended strftime with
- extra arguments TZ and NS. */
-
-#if FPRINTFTIME
-# undef my_strftime
-# define my_strftime fprintftime
-#endif
-
-#ifdef my_strftime
-# define extra_args , tz, ns
-# define extra_args_spec , timezone_t tz, int ns
-#else
-# if defined COMPILE_WIDE
-# define my_strftime wcsftime
-# define nl_get_alt_digit _nl_get_walt_digit
-# else
-# define my_strftime strftime
-# define nl_get_alt_digit _nl_get_alt_digit
-# endif
-# define extra_args
-# define extra_args_spec
-/* We don't have this information in general. */
-# define tz 1
-# define ns 0
-#endif
-
-static size_t __strftime_internal (STREAM_OR_CHAR_T *, STRFTIME_ARG (size_t)
- const CHAR_T *, const struct tm *,
- bool, int, int, bool *
- extra_args_spec LOCALE_PARAM);
-
-/* Write information from TP into S according to the format
- string FORMAT, writing no more that MAXSIZE characters
- (including the terminating '\0') and returning number of
- characters written. If S is NULL, nothing will be written
- anywhere, so to determine how many characters would be
- written, use NULL for S and (size_t) -1 for MAXSIZE. */
-size_t
-my_strftime (STREAM_OR_CHAR_T *s, STRFTIME_ARG (size_t maxsize)
- const CHAR_T *format,
- const struct tm *tp extra_args_spec LOCALE_PARAM)
-{
- bool tzset_called = false;
- return __strftime_internal (s, STRFTIME_ARG (maxsize) format, tp, false,
- 0, -1, &tzset_called extra_args LOCALE_ARG);
-}
-libc_hidden_def (my_strftime)
-
-/* Just like my_strftime, above, but with more parameters.
- UPCASE indicates that the result should be converted to upper case.
- YR_SPEC and WIDTH specify the padding and width for the year.
- *TZSET_CALLED indicates whether tzset has been called here. */
-static size_t
-__strftime_internal (STREAM_OR_CHAR_T *s, STRFTIME_ARG (size_t maxsize)
- const CHAR_T *format,
- const struct tm *tp, bool upcase,
- int yr_spec, int width, bool *tzset_called
- extra_args_spec LOCALE_PARAM)
-{
-#if defined _LIBC && defined USE_IN_EXTENDED_LOCALE_MODEL
- struct __locale_data *const current = loc->__locales[LC_TIME];
-#endif
-#if FPRINTFTIME
- size_t maxsize = (size_t) -1;
-#endif
-
- int saved_errno = errno;
- int hour12 = tp->tm_hour;
-#ifdef _NL_CURRENT
- /* We cannot make the following values variables since we must delay
- the evaluation of these values until really needed since some
- expressions might not be valid in every situation. The 'struct tm'
- might be generated by a strptime() call that initialized
- only a few elements. Dereference the pointers only if the format
- requires this. Then it is ok to fail if the pointers are invalid. */
-# define a_wkday \
- ((const CHAR_T *) (tp->tm_wday < 0 || tp->tm_wday > 6 \
- ? "?" : _NL_CURRENT (LC_TIME, NLW(ABDAY_1) + tp->tm_wday)))
-# define f_wkday \
- ((const CHAR_T *) (tp->tm_wday < 0 || tp->tm_wday > 6 \
- ? "?" : _NL_CURRENT (LC_TIME, NLW(DAY_1) + tp->tm_wday)))
-# define a_month \
- ((const CHAR_T *) (tp->tm_mon < 0 || tp->tm_mon > 11 \
- ? "?" : _NL_CURRENT (LC_TIME, NLW(ABMON_1) + tp->tm_mon)))
-# define f_month \
- ((const CHAR_T *) (tp->tm_mon < 0 || tp->tm_mon > 11 \
- ? "?" : _NL_CURRENT (LC_TIME, NLW(MON_1) + tp->tm_mon)))
-# define a_altmonth \
- ((const CHAR_T *) (tp->tm_mon < 0 || tp->tm_mon > 11 \
- ? "?" : _NL_CURRENT (LC_TIME, NLW(ABALTMON_1) + tp->tm_mon)))
-# define f_altmonth \
- ((const CHAR_T *) (tp->tm_mon < 0 || tp->tm_mon > 11 \
- ? "?" : _NL_CURRENT (LC_TIME, NLW(ALTMON_1) + tp->tm_mon)))
-# define ampm \
- ((const CHAR_T *) _NL_CURRENT (LC_TIME, tp->tm_hour > 11 \
- ? NLW(PM_STR) : NLW(AM_STR)))
-
-# define aw_len STRLEN (a_wkday)
-# define am_len STRLEN (a_month)
-# define aam_len STRLEN (a_altmonth)
-# define ap_len STRLEN (ampm)
-#endif
-#if HAVE_TZNAME
- char **tzname_vec = tzname;
-#endif
- const char *zone;
- size_t i = 0;
- STREAM_OR_CHAR_T *p = s;
- const CHAR_T *f;
-#if DO_MULTIBYTE && !defined COMPILE_WIDE
- const char *format_end = NULL;
-#endif
-
- zone = NULL;
-#if HAVE_STRUCT_TM_TM_ZONE
- /* The POSIX test suite assumes that setting
- the environment variable TZ to a new value before calling strftime()
- will influence the result (the %Z format) even if the information in
- TP is computed with a totally different time zone.
- This is bogus: though POSIX allows bad behavior like this,
- POSIX does not require it. Do the right thing instead. */
- zone = (const char *) tp->tm_zone;
-#endif
-#if HAVE_TZNAME
- if (!tz)
- {
- if (! (zone && *zone))
- zone = "GMT";
- }
- else
- {
-# if !HAVE_STRUCT_TM_TM_ZONE
- /* Infer the zone name from *TZ instead of from TZNAME. */
- tzname_vec = tz->tzname_copy;
-# endif
- }
- /* The tzset() call might have changed the value. */
- if (!(zone && *zone) && tp->tm_isdst >= 0)
- {
- /* POSIX.1 requires that local time zone information be used as
- though strftime called tzset. */
-# ifndef my_strftime
- if (!*tzset_called)
- {
- tzset ();
- *tzset_called = true;
- }
-# endif
- zone = tzname_vec[tp->tm_isdst != 0];
- }
-#endif
- if (! zone)
- zone = "";
-
- if (hour12 > 12)
- hour12 -= 12;
- else
- if (hour12 == 0)
- hour12 = 12;
-
- for (f = format; *f != '\0'; width = -1, f++)
- {
- int pad = 0; /* Padding for number ('_', '-', '+', '0', or 0). */
- int modifier; /* Field modifier ('E', 'O', or 0). */
- int digits = 0; /* Max digits for numeric format. */
- int number_value; /* Numeric value to be printed. */
- unsigned int u_number_value; /* (unsigned int) number_value. */
- bool negative_number; /* The number is negative. */
- bool always_output_a_sign; /* +/- should always be output. */
- int tz_colon_mask; /* Bitmask of where ':' should appear. */
- const CHAR_T *subfmt;
- CHAR_T *bufp;
- CHAR_T buf[1
- + 2 /* for the two colons in a %::z or %:::z time zone */
- + (sizeof (int) < sizeof (time_t)
- ? INT_STRLEN_BOUND (time_t)
- : INT_STRLEN_BOUND (int))];
- bool to_lowcase = false;
- bool to_uppcase = upcase;
- size_t colons;
- bool change_case = false;
- int format_char;
- int subwidth;
-
-#if DO_MULTIBYTE && !defined COMPILE_WIDE
- switch (*f)
- {
- case L_('%'):
- break;
-
- case L_('\b'): case L_('\t'): case L_('\n'):
- case L_('\v'): case L_('\f'): case L_('\r'):
- case L_(' '): case L_('!'): case L_('"'): case L_('#'): case L_('&'):
- case L_('\''): case L_('('): case L_(')'): case L_('*'): case L_('+'):
- case L_(','): case L_('-'): case L_('.'): case L_('/'): case L_('0'):
- case L_('1'): case L_('2'): case L_('3'): case L_('4'): case L_('5'):
- case L_('6'): case L_('7'): case L_('8'): case L_('9'): case L_(':'):
- case L_(';'): case L_('<'): case L_('='): case L_('>'): case L_('?'):
- case L_('A'): case L_('B'): case L_('C'): case L_('D'): case L_('E'):
- case L_('F'): case L_('G'): case L_('H'): case L_('I'): case L_('J'):
- case L_('K'): case L_('L'): case L_('M'): case L_('N'): case L_('O'):
- case L_('P'): case L_('Q'): case L_('R'): case L_('S'): case L_('T'):
- case L_('U'): case L_('V'): case L_('W'): case L_('X'): case L_('Y'):
- case L_('Z'): case L_('['): case L_('\\'): case L_(']'): case L_('^'):
- case L_('_'): case L_('a'): case L_('b'): case L_('c'): case L_('d'):
- case L_('e'): case L_('f'): case L_('g'): case L_('h'): case L_('i'):
- case L_('j'): case L_('k'): case L_('l'): case L_('m'): case L_('n'):
- case L_('o'): case L_('p'): case L_('q'): case L_('r'): case L_('s'):
- case L_('t'): case L_('u'): case L_('v'): case L_('w'): case L_('x'):
- case L_('y'): case L_('z'): case L_('{'): case L_('|'): case L_('}'):
- case L_('~'):
- /* The C Standard requires these 98 characters (plus '%') to
- be in the basic execution character set. None of these
- characters can start a multibyte sequence, so they need
- not be analyzed further. */
- add1 (*f);
- continue;
-
- default:
- /* Copy this multibyte sequence until we reach its end, find
- an error, or come back to the initial shift state. */
- {
- mbstate_t mbstate = mbstate_zero;
- size_t len = 0;
- size_t fsize;
-
- if (! format_end)
- format_end = f + strlen (f) + 1;
- fsize = format_end - f;
-
- do
- {
- size_t bytes = mbrlen (f + len, fsize - len, &mbstate);
-
- if (bytes == 0)
- break;
-
- if (bytes == (size_t) -2)
- {
- len += strlen (f + len);
- break;
- }
-
- if (bytes == (size_t) -1)
- {
- len++;
- break;
- }
-
- len += bytes;
- }
- while (! mbsinit (&mbstate));
-
- cpy (len, f);
- f += len - 1;
- continue;
- }
- }
-
-#else /* ! DO_MULTIBYTE */
-
- /* Either multibyte encodings are not supported, they are
- safe for formats, so any non-'%' byte can be copied through,
- or this is the wide character version. */
- if (*f != L_('%'))
- {
- add1 (*f);
- continue;
- }
-
-#endif /* ! DO_MULTIBYTE */
-
- char const *percent = f;
-
- /* Check for flags that can modify a format. */
- while (1)
- {
- switch (*++f)
- {
- /* This influences the number formats. */
- case L_('_'):
- case L_('-'):
- case L_('+'):
- case L_('0'):
- pad = *f;
- continue;
-
- /* This changes textual output. */
- case L_('^'):
- to_uppcase = true;
- continue;
- case L_('#'):
- change_case = true;
- continue;
-
- default:
- break;
- }
- break;
- }
-
- if (ISDIGIT (*f))
- {
- width = 0;
- do
- {
- if (INT_MULTIPLY_WRAPV (width, 10, &width)
- || INT_ADD_WRAPV (width, *f - L_('0'), &width))
- width = INT_MAX;
- ++f;
- }
- while (ISDIGIT (*f));
- }
-
- /* Check for modifiers. */
- switch (*f)
- {
- case L_('E'):
- case L_('O'):
- modifier = *f++;
- break;
-
- default:
- modifier = 0;
- break;
- }
-
- /* Now do the specified format. */
- format_char = *f;
- switch (format_char)
- {
-#define DO_NUMBER(d, v) \
- do \
- { \
- digits = d; \
- number_value = v; \
- goto do_number; \
- } \
- while (0)
-#define DO_SIGNED_NUMBER(d, negative, v) \
- DO_MAYBE_SIGNED_NUMBER (d, negative, v, do_signed_number)
-#define DO_YEARISH(d, negative, v) \
- DO_MAYBE_SIGNED_NUMBER (d, negative, v, do_yearish)
-#define DO_MAYBE_SIGNED_NUMBER(d, negative, v, label) \
- do \
- { \
- digits = d; \
- negative_number = negative; \
- u_number_value = v; \
- goto label; \
- } \
- while (0)
-
- /* The mask is not what you might think.
- When the ordinal i'th bit is set, insert a colon
- before the i'th digit of the time zone representation. */
-#define DO_TZ_OFFSET(d, mask, v) \
- do \
- { \
- digits = d; \
- tz_colon_mask = mask; \
- u_number_value = v; \
- goto do_tz_offset; \
- } \
- while (0)
-#define DO_NUMBER_SPACEPAD(d, v) \
- do \
- { \
- digits = d; \
- number_value = v; \
- goto do_number_spacepad; \
- } \
- while (0)
-
- case L_('%'):
- if (f - 1 != percent)
- goto bad_percent;
- add1 (*f);
- break;
-
- case L_('a'):
- if (modifier != 0)
- goto bad_format;
- if (change_case)
- {
- to_uppcase = true;
- to_lowcase = false;
- }
-#ifdef _NL_CURRENT
- cpy (aw_len, a_wkday);
- break;
-#else
- goto underlying_strftime;
-#endif
-
- case 'A':
- if (modifier != 0)
- goto bad_format;
- if (change_case)
- {
- to_uppcase = true;
- to_lowcase = false;
- }
-#ifdef _NL_CURRENT
- cpy (STRLEN (f_wkday), f_wkday);
- break;
-#else
- goto underlying_strftime;
-#endif
-
- case L_('b'):
- case L_('h'):
- if (change_case)
- {
- to_uppcase = true;
- to_lowcase = false;
- }
- if (modifier == L_('E'))
- goto bad_format;
-#ifdef _NL_CURRENT
- if (modifier == L_('O'))
- cpy (aam_len, a_altmonth);
- else
- cpy (am_len, a_month);
- break;
-#else
- goto underlying_strftime;
-#endif
-
- case L_('B'):
- if (modifier == L_('E'))
- goto bad_format;
- if (change_case)
- {
- to_uppcase = true;
- to_lowcase = false;
- }
-#ifdef _NL_CURRENT
- if (modifier == L_('O'))
- cpy (STRLEN (f_altmonth), f_altmonth);
- else
- cpy (STRLEN (f_month), f_month);
- break;
-#else
- goto underlying_strftime;
-#endif
-
- case L_('c'):
- if (modifier == L_('O'))
- goto bad_format;
-#ifdef _NL_CURRENT
- if (! (modifier == L_('E')
- && (*(subfmt =
- (const CHAR_T *) _NL_CURRENT (LC_TIME,
- NLW(ERA_D_T_FMT)))
- != '\0')))
- subfmt = (const CHAR_T *) _NL_CURRENT (LC_TIME, NLW(D_T_FMT));
-#else
- goto underlying_strftime;
-#endif
-
- subformat:
- subwidth = -1;
- subformat_width:
- {
- size_t len = __strftime_internal (NULL, STRFTIME_ARG ((size_t) -1)
- subfmt, tp, to_uppcase,
- pad, subwidth, tzset_called
- extra_args LOCALE_ARG);
- add (len, __strftime_internal (p,
- STRFTIME_ARG (maxsize - i)
- subfmt, tp, to_uppcase,
- pad, subwidth, tzset_called
- extra_args LOCALE_ARG));
- }
- break;
-
-#if !(defined _NL_CURRENT && HAVE_STRUCT_ERA_ENTRY)
- underlying_strftime:
- {
- /* The relevant information is available only via the
- underlying strftime implementation, so use that. */
- char ufmt[5];
- char *u = ufmt;
- char ubuf[1024]; /* enough for any single format in practice */
- size_t len;
- /* Make sure we're calling the actual underlying strftime.
- In some cases, config.h contains something like
- "#define strftime rpl_strftime". */
-# ifdef strftime
-# undef strftime
- size_t strftime ();
-# endif
-
- /* The space helps distinguish strftime failure from empty
- output. */
- *u++ = ' ';
- *u++ = '%';
- if (modifier != 0)
- *u++ = modifier;
- *u++ = format_char;
- *u = '\0';
- len = strftime (ubuf, sizeof ubuf, ufmt, tp);
- if (len != 0)
- cpy (len - 1, ubuf + 1);
- }
- break;
-#endif
-
- case L_('C'):
- if (modifier == L_('E'))
- {
-#if HAVE_STRUCT_ERA_ENTRY
- struct era_entry *era = _nl_get_era_entry (tp HELPER_LOCALE_ARG);
- if (era)
- {
-# ifdef COMPILE_WIDE
- size_t len = __wcslen (era->era_wname);
- cpy (len, era->era_wname);
-# else
- size_t len = strlen (era->era_name);
- cpy (len, era->era_name);
-# endif
- break;
- }
-#else
- goto underlying_strftime;
-#endif
- }
-
- {
- bool negative_year = tp->tm_year < - TM_YEAR_BASE;
- bool zero_thru_1899 = !negative_year & (tp->tm_year < 0);
- int century = ((tp->tm_year - 99 * zero_thru_1899) / 100
- + TM_YEAR_BASE / 100);
- DO_YEARISH (2, negative_year, century);
- }
-
- case L_('x'):
- if (modifier == L_('O'))
- goto bad_format;
-#ifdef _NL_CURRENT
- if (! (modifier == L_('E')
- && (*(subfmt =
- (const CHAR_T *) _NL_CURRENT (LC_TIME, NLW(ERA_D_FMT)))
- != L_('\0'))))
- subfmt = (const CHAR_T *) _NL_CURRENT (LC_TIME, NLW(D_FMT));
- goto subformat;
-#else
- goto underlying_strftime;
-#endif
- case L_('D'):
- if (modifier != 0)
- goto bad_format;
- subfmt = L_("%m/%d/%y");
- goto subformat;
-
- case L_('d'):
- if (modifier == L_('E'))
- goto bad_format;
-
- DO_NUMBER (2, tp->tm_mday);
-
- case L_('e'):
- if (modifier == L_('E'))
- goto bad_format;
-
- DO_NUMBER_SPACEPAD (2, tp->tm_mday);
-
- /* All numeric formats set DIGITS and NUMBER_VALUE (or U_NUMBER_VALUE)
- and then jump to one of these labels. */
-
- do_tz_offset:
- always_output_a_sign = true;
- goto do_number_body;
-
- do_yearish:
- if (pad == 0)
- pad = yr_spec;
- always_output_a_sign
- = (pad == L_('+')
- && ((digits == 2 ? 99 : 9999) < u_number_value
- || digits < width));
- goto do_maybe_signed_number;
-
- do_number_spacepad:
- if (pad == 0)
- pad = L_('_');
-
- do_number:
- /* Format NUMBER_VALUE according to the MODIFIER flag. */
- negative_number = number_value < 0;
- u_number_value = number_value;
-
- do_signed_number:
- always_output_a_sign = false;
-
- do_maybe_signed_number:
- tz_colon_mask = 0;
-
- do_number_body:
- /* Format U_NUMBER_VALUE according to the MODIFIER flag.
- NEGATIVE_NUMBER is nonzero if the original number was
- negative; in this case it was converted directly to
- unsigned int (i.e., modulo (UINT_MAX + 1)) without
- negating it. */
- if (modifier == L_('O') && !negative_number)
- {
-#ifdef _NL_CURRENT
- /* Get the locale specific alternate representation of
- the number. If none exist NULL is returned. */
- const CHAR_T *cp = nl_get_alt_digit (u_number_value
- HELPER_LOCALE_ARG);
-
- if (cp != NULL)
- {
- size_t digitlen = STRLEN (cp);
- if (digitlen != 0)
- {
- cpy (digitlen, cp);
- break;
- }
- }
-#else
- goto underlying_strftime;
-#endif
- }
-
- bufp = buf + sizeof (buf) / sizeof (buf[0]);
-
- if (negative_number)
- u_number_value = - u_number_value;
-
- do
- {
- if (tz_colon_mask & 1)
- *--bufp = ':';
- tz_colon_mask >>= 1;
- *--bufp = u_number_value % 10 + L_('0');
- u_number_value /= 10;
- }
- while (u_number_value != 0 || tz_colon_mask != 0);
-
- do_number_sign_and_padding:
- if (pad == 0)
- pad = L_('0');
- if (width < 0)
- width = digits;
-
- {
- CHAR_T sign_char = (negative_number ? L_('-')
- : always_output_a_sign ? L_('+')
- : 0);
- int numlen = buf + sizeof buf / sizeof buf[0] - bufp;
- int shortage = width - !!sign_char - numlen;
- int padding = pad == L_('-') || shortage <= 0 ? 0 : shortage;
-
- if (sign_char)
- {
- if (pad == L_('_'))
- {
- if (p)
- memset_space (p, padding);
- i += padding;
- width -= padding;
- }
- width_add1 (0, sign_char);
- width--;
- }
-
- cpy (numlen, bufp);
- }
- break;
-
- case L_('F'):
- if (modifier != 0)
- goto bad_format;
- if (pad == 0 && width < 0)
- {
- pad = L_('+');
- subwidth = 4;
- }
- else
- {
- subwidth = width - 6;
- if (subwidth < 0)
- subwidth = 0;
- }
- subfmt = L_("%Y-%m-%d");
- goto subformat_width;
-
- case L_('H'):
- if (modifier == L_('E'))
- goto bad_format;
-
- DO_NUMBER (2, tp->tm_hour);
-
- case L_('I'):
- if (modifier == L_('E'))
- goto bad_format;
-
- DO_NUMBER (2, hour12);
-
- case L_('k'): /* GNU extension. */
- if (modifier == L_('E'))
- goto bad_format;
-
- DO_NUMBER_SPACEPAD (2, tp->tm_hour);
-
- case L_('l'): /* GNU extension. */
- if (modifier == L_('E'))
- goto bad_format;
-
- DO_NUMBER_SPACEPAD (2, hour12);
-
- case L_('j'):
- if (modifier == L_('E'))
- goto bad_format;
-
- DO_SIGNED_NUMBER (3, tp->tm_yday < -1, tp->tm_yday + 1U);
-
- case L_('M'):
- if (modifier == L_('E'))
- goto bad_format;
-
- DO_NUMBER (2, tp->tm_min);
-
- case L_('m'):
- if (modifier == L_('E'))
- goto bad_format;
-
- DO_SIGNED_NUMBER (2, tp->tm_mon < -1, tp->tm_mon + 1U);
-
-#ifndef _LIBC
- case L_('N'): /* GNU extension. */
- if (modifier == L_('E'))
- goto bad_format;
- {
- int n = ns, ns_digits = 9;
- if (width <= 0)
- width = ns_digits;
- int ndigs = ns_digits;
- while (width < ndigs || (1 < ndigs && n % 10 == 0))
- ndigs--, n /= 10;
- for (int j = ndigs; 0 < j; j--)
- buf[j - 1] = n % 10 + L_('0'), n /= 10;
- if (!pad)
- pad = L_('0');
- width_cpy (0, ndigs, buf);
- width_add (width - ndigs, 0, (void) 0);
- }
- break;
-#endif
-
- case L_('n'):
- add1 (L_('\n'));
- break;
-
- case L_('P'):
- to_lowcase = true;
-#ifndef _NL_CURRENT
- format_char = L_('p');
-#endif
- FALLTHROUGH;
- case L_('p'):
- if (change_case)
- {
- to_uppcase = false;
- to_lowcase = true;
- }
-#ifdef _NL_CURRENT
- cpy (ap_len, ampm);
- break;
-#else
- goto underlying_strftime;
-#endif
-
- case L_('q'): /* GNU extension. */
- DO_SIGNED_NUMBER (1, false, ((tp->tm_mon * 11) >> 5) + 1);
-
- case L_('R'):
- subfmt = L_("%H:%M");
- goto subformat;
-
- case L_('r'):
-#ifdef _NL_CURRENT
- if (*(subfmt = (const CHAR_T *) _NL_CURRENT (LC_TIME,
- NLW(T_FMT_AMPM)))
- == L_('\0'))
- subfmt = L_("%I:%M:%S %p");
- goto subformat;
-#else
- goto underlying_strftime;
-#endif
-
- case L_('S'):
- if (modifier == L_('E'))
- goto bad_format;
-
- DO_NUMBER (2, tp->tm_sec);
-
- case L_('s'): /* GNU extension. */
- {
- struct tm ltm;
- time_t t;
-
- ltm = *tp;
- ltm.tm_yday = -1;
- t = mktime_z (tz, &ltm);
- if (ltm.tm_yday < 0)
- {
- errno = EOVERFLOW;
- return 0;
- }
-
- /* Generate string value for T using time_t arithmetic;
- this works even if sizeof (long) < sizeof (time_t). */
-
- bufp = buf + sizeof (buf) / sizeof (buf[0]);
- negative_number = t < 0;
-
- do
- {
- int d = t % 10;
- t /= 10;
- *--bufp = (negative_number ? -d : d) + L_('0');
- }
- while (t != 0);
-
- digits = 1;
- always_output_a_sign = false;
- goto do_number_sign_and_padding;
- }
-
- case L_('X'):
- if (modifier == L_('O'))
- goto bad_format;
-#ifdef _NL_CURRENT
- if (! (modifier == L_('E')
- && (*(subfmt =
- (const CHAR_T *) _NL_CURRENT (LC_TIME, NLW(ERA_T_FMT)))
- != L_('\0'))))
- subfmt = (const CHAR_T *) _NL_CURRENT (LC_TIME, NLW(T_FMT));
- goto subformat;
-#else
- goto underlying_strftime;
-#endif
- case L_('T'):
- subfmt = L_("%H:%M:%S");
- goto subformat;
-
- case L_('t'):
- add1 (L_('\t'));
- break;
-
- case L_('u'):
- DO_NUMBER (1, (tp->tm_wday - 1 + 7) % 7 + 1);
-
- case L_('U'):
- if (modifier == L_('E'))
- goto bad_format;
-
- DO_NUMBER (2, (tp->tm_yday - tp->tm_wday + 7) / 7);
-
- case L_('V'):
- case L_('g'):
- case L_('G'):
- if (modifier == L_('E'))
- goto bad_format;
- {
- /* YEAR is a leap year if and only if (tp->tm_year + TM_YEAR_BASE)
- is a leap year, except that YEAR and YEAR - 1 both work
- correctly even when (tp->tm_year + TM_YEAR_BASE) would
- overflow. */
- int year = (tp->tm_year
- + (tp->tm_year < 0
- ? TM_YEAR_BASE % 400
- : TM_YEAR_BASE % 400 - 400));
- int year_adjust = 0;
- int days = iso_week_days (tp->tm_yday, tp->tm_wday);
-
- if (days < 0)
- {
- /* This ISO week belongs to the previous year. */
- year_adjust = -1;
- days = iso_week_days (tp->tm_yday + (365 + __isleap (year - 1)),
- tp->tm_wday);
- }
- else
- {
- int d = iso_week_days (tp->tm_yday - (365 + __isleap (year)),
- tp->tm_wday);
- if (0 <= d)
- {
- /* This ISO week belongs to the next year. */
- year_adjust = 1;
- days = d;
- }
- }
-
- switch (*f)
- {
- case L_('g'):
- {
- int yy = (tp->tm_year % 100 + year_adjust) % 100;
- DO_YEARISH (2, false,
- (0 <= yy
- ? yy
- : tp->tm_year < -TM_YEAR_BASE - year_adjust
- ? -yy
- : yy + 100));
- }
-
- case L_('G'):
- DO_YEARISH (4, tp->tm_year < -TM_YEAR_BASE - year_adjust,
- (tp->tm_year + (unsigned int) TM_YEAR_BASE
- + year_adjust));
-
- default:
- DO_NUMBER (2, days / 7 + 1);
- }
- }
-
- case L_('W'):
- if (modifier == L_('E'))
- goto bad_format;
-
- DO_NUMBER (2, (tp->tm_yday - (tp->tm_wday - 1 + 7) % 7 + 7) / 7);
-
- case L_('w'):
- if (modifier == L_('E'))
- goto bad_format;
-
- DO_NUMBER (1, tp->tm_wday);
-
- case L_('Y'):
- if (modifier == L_('E'))
- {
-#if HAVE_STRUCT_ERA_ENTRY
- struct era_entry *era = _nl_get_era_entry (tp HELPER_LOCALE_ARG);
- if (era)
- {
-# ifdef COMPILE_WIDE
- subfmt = era->era_wformat;
-# else
- subfmt = era->era_format;
-# endif
- if (pad == 0)
- pad = yr_spec;
- goto subformat;
- }
-#else
- goto underlying_strftime;
-#endif
- }
- if (modifier == L_('O'))
- goto bad_format;
-
- DO_YEARISH (4, tp->tm_year < -TM_YEAR_BASE,
- tp->tm_year + (unsigned int) TM_YEAR_BASE);
-
- case L_('y'):
- if (modifier == L_('E'))
- {
-#if HAVE_STRUCT_ERA_ENTRY
- struct era_entry *era = _nl_get_era_entry (tp HELPER_LOCALE_ARG);
- if (era)
- {
- int delta = tp->tm_year - era->start_date[0];
- if (pad == 0)
- pad = yr_spec;
- DO_NUMBER (2, (era->offset
- + delta * era->absolute_direction));
- }
-#else
- goto underlying_strftime;
-#endif
- }
-
- {
- int yy = tp->tm_year % 100;
- if (yy < 0)
- yy = tp->tm_year < - TM_YEAR_BASE ? -yy : yy + 100;
- DO_YEARISH (2, false, yy);
- }
-
- case L_('Z'):
- if (change_case)
- {
- to_uppcase = false;
- to_lowcase = true;
- }
-
-#ifdef COMPILE_WIDE
- {
- /* The zone string is always given in multibyte form. We have
- to transform it first. */
- wchar_t *wczone;
- size_t len;
- widen (zone, wczone, len);
- cpy (len, wczone);
- }
-#else
- cpy (strlen (zone), zone);
-#endif
- break;
-
- case L_(':'):
- /* :, ::, and ::: are valid only just before 'z'.
- :::: etc. are rejected later. */
- for (colons = 1; f[colons] == L_(':'); colons++)
- continue;
- if (f[colons] != L_('z'))
- goto bad_format;
- f += colons;
- goto do_z_conversion;
-
- case L_('z'):
- colons = 0;
-
- do_z_conversion:
- if (tp->tm_isdst < 0)
- break;
-
- {
- int diff;
- int hour_diff;
- int min_diff;
- int sec_diff;
-#if HAVE_TM_GMTOFF
- diff = tp->tm_gmtoff;
-#else
- if (!tz)
- diff = 0;
- else
- {
- struct tm gtm;
- struct tm ltm;
- time_t lt;
-
- /* POSIX.1 requires that local time zone information be used as
- though strftime called tzset. */
-# ifndef my_strftime
- if (!*tzset_called)
- {
- tzset ();
- *tzset_called = true;
- }
-# endif
-
- ltm = *tp;
- ltm.tm_wday = -1;
- lt = mktime_z (tz, &ltm);
- if (ltm.tm_wday < 0 || ! localtime_rz (0, &lt, &gtm))
- break;
- diff = tm_diff (&ltm, &gtm);
- }
-#endif
-
- negative_number = diff < 0 || (diff == 0 && *zone == '-');
- hour_diff = diff / 60 / 60;
- min_diff = diff / 60 % 60;
- sec_diff = diff % 60;
-
- switch (colons)
- {
- case 0: /* +hhmm */
- DO_TZ_OFFSET (5, 0, hour_diff * 100 + min_diff);
-
- case 1: tz_hh_mm: /* +hh:mm */
- DO_TZ_OFFSET (6, 04, hour_diff * 100 + min_diff);
-
- case 2: tz_hh_mm_ss: /* +hh:mm:ss */
- DO_TZ_OFFSET (9, 024,
- hour_diff * 10000 + min_diff * 100 + sec_diff);
-
- case 3: /* +hh if possible, else +hh:mm, else +hh:mm:ss */
- if (sec_diff != 0)
- goto tz_hh_mm_ss;
- if (min_diff != 0)
- goto tz_hh_mm;
- DO_TZ_OFFSET (3, 0, hour_diff);
-
- default:
- goto bad_format;
- }
- }
-
- case L_('\0'): /* GNU extension: % at end of format. */
- bad_percent:
- --f;
- FALLTHROUGH;
- default:
- /* Unknown format; output the format, including the '%',
- since this is most likely the right thing to do if a
- multibyte string has been misparsed. */
- bad_format:
- cpy (f - percent + 1, percent);
- break;
- }
- }
-
-#if ! FPRINTFTIME
- if (p && maxsize != 0)
- *p = L_('\0');
-#endif
-
- errno = saved_errno;
- return i;
-}
+#define my_strftime nstrftime
+#include "strftime.c"
diff --git a/lib/open.c b/lib/open.c
index adcac458a78..e690c9ea779 100644
--- a/lib/open.c
+++ b/lib/open.c
@@ -38,9 +38,13 @@ orig_open (const char *filename, int flags, mode_t mode)
}
/* Specification. */
+#ifdef __osf__
/* Write "fcntl.h" here, not <fcntl.h>, otherwise OSF/1 5.1 DTK cc eliminates
this include because of the preliminary #include <fcntl.h> above. */
-#include "fcntl.h"
+# include "fcntl.h"
+#else
+# include <fcntl.h>
+#endif
#include "cloexec.h"
diff --git a/lib/openat-proc.c b/lib/openat-proc.c
index d544853c67b..7ccb734f424 100644
--- a/lib/openat-proc.c
+++ b/lib/openat-proc.c
@@ -30,9 +30,12 @@
#include <string.h>
#include <unistd.h>
-#ifdef __KLIBC__
+#ifdef __KLIBC__ /* OS/2 */
# include <InnoTekLIBC/backend.h>
#endif
+#ifdef __MVS__ /* z/OS */
+# include <termios.h>
+#endif
#include "intprops.h"
@@ -53,7 +56,8 @@ openat_proc_name (char buf[OPENAT_BUFFER_SIZE], int fd, char const *file)
return buf;
}
-#ifndef __KLIBC__
+#if !(defined __KLIBC__ || defined __MVS__)
+ /* Generic code for Linux, Solaris, and similar platforms. */
# define PROC_SELF_FD_FORMAT "/proc/self/fd/%d/"
{
enum {
@@ -107,14 +111,29 @@ openat_proc_name (char buf[OPENAT_BUFFER_SIZE], int fd, char const *file)
dirlen = sprintf (result, PROC_SELF_FD_FORMAT, fd);
}
}
-#else
+#else /* (defined __KLIBC__ || defined __MVS__), i.e. OS/2 or z/OS */
/* OS/2 kLIBC provides a function to retrieve a path from a fd. */
{
- char dir[_MAX_PATH];
size_t bufsize;
+# ifdef __KLIBC__
+ char dir[_MAX_PATH];
if (__libc_Back_ioFHToPath (fd, dir, sizeof dir))
return NULL;
+# endif
+# ifdef __MVS__
+ char dir[_XOPEN_PATH_MAX];
+ /* Documentation:
+ https://www.ibm.com/docs/en/zos/2.2.0?topic=functions-w-ioctl-w-pioctl-control-devices */
+ if (w_ioctl (fd, _IOCC_GPN, sizeof dir, dir) < 0)
+ return NULL;
+ /* Documentation:
+ https://www.ibm.com/docs/en/zos/2.2.0?topic=functions-e2a-l-convert-characters-from-ebcdic-ascii */
+ dirlen = __e2a_l (dir, strlen (dir));
+ if (dirlen < 0 || dirlen >= sizeof dir)
+ return NULL;
+ dir[dirlen] = '\0';
+# endif
dirlen = strlen (dir);
bufsize = dirlen + 1 + strlen (file) + 1; /* 1 for '/', 1 for null */
diff --git a/lib/openat.h b/lib/openat.h
index 95d7c1a9443..dc34092bb3f 100644
--- a/lib/openat.h
+++ b/lib/openat.h
@@ -19,15 +19,18 @@
#ifndef _GL_HEADER_OPENAT
#define _GL_HEADER_OPENAT
+/* This file uses _GL_INLINE_HEADER_BEGIN, _GL_INLINE, _Noreturn,
+ _GL_ATTRIBUTE_DEPRECATED, HAVE_OPENAT. */
+#if !_GL_CONFIG_H_INCLUDED
+ #error "Please include config.h first."
+#endif
+
#include <fcntl.h>
#include <sys/types.h>
#include <sys/stat.h>
#include <unistd.h>
-#ifndef _GL_INLINE_HEADER_BEGIN
- #error "Please include config.h first."
-#endif
_GL_INLINE_HEADER_BEGIN
#if !HAVE_OPENAT
diff --git a/lib/pathmax.h b/lib/pathmax.h
index 85961ae8f53..d6512c6f570 100644
--- a/lib/pathmax.h
+++ b/lib/pathmax.h
@@ -39,6 +39,11 @@
#endif
*/
+/* This file uses HAVE_SYS_PARAM_H. */
+# if !_GL_CONFIG_H_INCLUDED
+# error "Please include config.h first."
+# endif
+
# include <unistd.h>
# include <limits.h>
diff --git a/lib/pselect.c b/lib/pselect.c
index 50200a4b421..54732e5cce3 100644
--- a/lib/pselect.c
+++ b/lib/pselect.c
@@ -45,6 +45,12 @@ pselect (int nfds, fd_set *restrict rfds,
sigset_t origmask;
struct timeval tv, *tvp;
+ if (nfds < 0 || nfds > FD_SETSIZE)
+ {
+ errno = EINVAL;
+ return -1;
+ }
+
if (timeout)
{
if (! (0 <= timeout->tv_nsec && timeout->tv_nsec < 1000000000))
@@ -53,8 +59,10 @@ pselect (int nfds, fd_set *restrict rfds,
return -1;
}
- tv.tv_sec = timeout->tv_sec;
- tv.tv_usec = (timeout->tv_nsec + 999) / 1000;
+ tv = (struct timeval) {
+ .tv_sec = timeout->tv_sec,
+ .tv_usec = (timeout->tv_nsec + 999) / 1000
+ };
tvp = &tv;
}
else
diff --git a/lib/qcopy-acl.c b/lib/qcopy-acl.c
index 5da70ed3384..dfc39cead05 100644
--- a/lib/qcopy-acl.c
+++ b/lib/qcopy-acl.c
@@ -23,6 +23,20 @@
#include "acl-internal.h"
+#if USE_XATTR
+
+# include <attr/libattr.h>
+
+/* Returns 1 if NAME is the name of an extended attribute that is related
+ to permissions, i.e. ACLs. Returns 0 otherwise. */
+
+static int
+is_attr_permissions (const char *name, struct error_context *ctx)
+{
+ return attr_copy_action (name, ctx) == ATTR_ACTION_PERMISSIONS;
+}
+
+#endif /* USE_XATTR */
/* Copy access control lists from one file to another. If SOURCE_DESC is
a valid file descriptor, use file descriptor operations, else use
@@ -39,13 +53,33 @@ int
qcopy_acl (const char *src_name, int source_desc, const char *dst_name,
int dest_desc, mode_t mode)
{
- struct permission_context ctx;
int ret;
+#ifdef USE_XATTR
+ /* in case no ACLs present and also to set higher mode bits
+ we chmod before setting ACLs as doing it after could overwrite them
+ (especially true for NFSv4, posix ACL has that ugly "mask" hack that
+ nobody understands) */
+ ret = chmod_or_fchmod (dst_name, dest_desc, mode);
+ /* Rather than fiddling with acls one by one, we just copy the whole ACL xattrs
+ (Posix or NFSv4). Of course, that won't address ACLs conversion
+ (i.e. posix <-> nfs4) but we can't do it anyway, so for now, we don't care
+ Functions attr_copy_* return 0 in case we copied something OR nothing
+ to copy */
+ if (ret == 0)
+ ret = source_desc <= 0 || dest_desc <= 0
+ ? attr_copy_file (src_name, dst_name, is_attr_permissions, NULL)
+ : attr_copy_fd (src_name, source_desc, dst_name, dest_desc,
+ is_attr_permissions, NULL);
+#else
+ /* no XATTR, so we proceed the old dusty way */
+ struct permission_context ctx;
+
ret = get_permissions (src_name, source_desc, mode, &ctx);
if (ret != 0)
return -2;
ret = set_permissions (&ctx, dst_name, dest_desc);
free_permission_context (&ctx);
+#endif
return ret;
}
diff --git a/lib/rawmemchr.c b/lib/rawmemchr.c
index 37639287f01..013e7f8cced 100644
--- a/lib/rawmemchr.c
+++ b/lib/rawmemchr.c
@@ -19,7 +19,7 @@
/* Specification. */
#include <string.h>
-/* A function definition is only needed if HAVE_RAWMEMCHR is not defined. */
+/* A function definition is needed only if HAVE_RAWMEMCHR is not defined. */
#if !HAVE_RAWMEMCHR
# include <limits.h>
@@ -30,19 +30,30 @@
void *
rawmemchr (const void *s, int c_in)
{
- /* Change this typedef to experiment with performance. */
+# ifdef __CHERI_PURE_CAPABILITY__
+ /* Most architectures let you read an aligned word,
+ even if the unsigned char array at S ends in the middle of the word.
+ However CHERI does not, so call memchr
+ with the underlying object's remaining length.
+ This cannot return NULL if S points to a C_IN-terminated array.
+ Use builtins rather than including <cheri.h> which is less stable. */
+ return memchr (s, c_in, (__builtin_cheri_length_get (s)
+ - __builtin_cheri_offset_get (s)));
+# else
+
+ /* You can change this typedef to experiment with performance. */
typedef uintptr_t longword;
- /* If you change the "uintptr_t", you should change UINTPTR_WIDTH to match.
- This verifies that the type does not have padding bits. */
- static_assert (UINTPTR_WIDTH == UCHAR_WIDTH * sizeof (longword));
+ /* Verify that the longword type lacks padding bits. */
+ static_assert (UINTPTR_WIDTH == UCHAR_WIDTH * sizeof (uintptr_t));
const unsigned char *char_ptr;
unsigned char c = c_in;
/* Handle the first few bytes by reading one byte at a time.
- Do this until CHAR_PTR is aligned on a longword boundary. */
+ Do this until CHAR_PTR is aligned on a natural longword boundary,
+ as using alignof (longword) might be slower. */
for (char_ptr = (const unsigned char *) s;
- (uintptr_t) char_ptr % alignof (longword) != 0;
+ (uintptr_t) char_ptr % sizeof (longword) != 0;
++char_ptr)
if (*char_ptr == c)
return (void *) char_ptr;
@@ -118,6 +129,7 @@ rawmemchr (const void *s, int c_in)
while (*char_ptr != c)
char_ptr++;
return (void *) char_ptr;
+# endif
}
#endif
diff --git a/lib/readutmp.h b/lib/readutmp.h
new file mode 100644
index 00000000000..dcfd44dbbc9
--- /dev/null
+++ b/lib/readutmp.h
@@ -0,0 +1,338 @@
+/* Declarations for GNU's read utmp module.
+
+ Copyright (C) 1992-2007, 2009-2024 Free Software Foundation, Inc.
+
+ This program is free software: you can redistribute it and/or modify
+ it under the terms of the GNU General Public License as published by
+ the Free Software Foundation, either version 3 of the License, or
+ (at your option) any later version.
+
+ This program is distributed in the hope that it will be useful,
+ but WITHOUT ANY WARRANTY; without even the implied warranty of
+ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ GNU General Public License for more details.
+
+ You should have received a copy of the GNU General Public License
+ along with this program. If not, see <https://www.gnu.org/licenses/>. */
+
+/* Written by jla; revised by djm */
+
+#ifndef __READUTMP_H__
+#define __READUTMP_H__
+
+/* This file uses _GL_ATTRIBUTE_MALLOC, _GL_ATTRIBUTE_RETURNS_NONNULL,
+ HAVE_UTMP_H, HAVE_UTMPX_H, HAVE_STRUCT_UTMP_*, HAVE_STRUCT_UTMPX_*,
+ HAVE_UTMPNAME, HAVE_UTMPXNAME. */
+#if !_GL_CONFIG_H_INCLUDED
+# error "Please include config.h first."
+#endif
+
+#include "idx.h"
+
+#include <stdlib.h>
+#include <sys/types.h>
+#include <time.h>
+
+/* AIX 4.3.3 has both utmp.h and utmpx.h, but only struct utmp
+ has the ut_exit member. */
+#if (HAVE_UTMPX_H && HAVE_UTMP_H && HAVE_STRUCT_UTMP_UT_EXIT \
+ && ! HAVE_STRUCT_UTMPX_UT_EXIT)
+# undef HAVE_UTMPX_H
+#endif
+
+/* HPUX 10.20 needs utmp.h, for the definition of e.g., UTMP_FILE. */
+#if HAVE_UTMP_H
+# include <utmp.h>
+#endif
+
+/* Needed for BOOT_TIME and USER_PROCESS. */
+#if HAVE_UTMPX_H
+# if defined _THREAD_SAFE && defined UTMP_DATA_INIT
+ /* When including both utmp.h and utmpx.h on AIX 4.3, with _THREAD_SAFE
+ defined, work around the duplicate struct utmp_data declaration. */
+# define utmp_data gl_aix_4_3_workaround_utmp_data
+# endif
+# include <utmpx.h>
+#endif
+
+
+#ifdef __cplusplus
+extern "C" {
+#endif
+
+
+/* Type of entries returned by read_utmp on all platforms. */
+struct gl_utmp
+{
+ /* All 'char *' here are of arbitrary length and point to storage
+ with lifetime equal to that of this struct. */
+ char *ut_user; /* User name */
+ char *ut_id; /* Session ID */
+ char *ut_line; /* seat / device */
+ char *ut_host; /* for remote sessions: user@host or host,
+ for local sessions: the X11 display :N */
+ struct timespec ut_ts; /* time */
+ pid_t ut_pid; /* process ID of ? */
+ pid_t ut_session; /* process ID of session leader */
+ short ut_type; /* BOOT_TIME, USER_PROCESS, or other */
+ struct { int e_termination; int e_exit; } ut_exit;
+};
+
+/* The following types, macros, and constants describe the 'struct gl_utmp'. */
+#define UT_USER(UT) ((UT)->ut_user)
+#define UT_TIME_MEMBER(UT) ((UT)->ut_ts.tv_sec)
+#define UT_PID(UT) ((UT)->ut_pid)
+#define UT_TYPE_EQ(UT, V) ((UT)->ut_type == (V))
+#define UT_TYPE_NOT_DEFINED 0
+#define UT_EXIT_E_TERMINATION(UT) ((UT)->ut_exit.e_termination)
+#define UT_EXIT_E_EXIT(UT) ((UT)->ut_exit.e_exit)
+
+/* Type of entry returned by read_utmp(). */
+typedef struct gl_utmp STRUCT_UTMP;
+
+/* Size of the UT_USER (ut) member, or -1 if unbounded. */
+enum { UT_USER_SIZE = -1 };
+
+/* Size of the ut->ut_id member, or -1 if unbounded. */
+enum { UT_ID_SIZE = -1 };
+
+/* Size of the ut->ut_line member, or -1 if unbounded. */
+enum { UT_LINE_SIZE = -1 };
+
+/* Size of the ut->ut_host member, or -1 if unbounded. */
+enum { UT_HOST_SIZE = -1 };
+
+
+/* When read_utmp accesses a file (as opposed to fetching the information
+ from systemd), it uses the following low-level types and macros.
+ Keep them here, rather than moving them into readutmp.c, for backward
+ compatibility. */
+
+#if HAVE_UTMPX_H
+
+/* <utmpx.h> defines 'struct utmpx' with the following fields:
+
+ Field Type Platforms
+ ---------- ------ ---------
+ ⎡ ut_user char[] glibc, musl, macOS, FreeBSD, AIX, HP-UX, IRIX, Solaris, Cygwin, Android
+ ⎣ ut_name char[] NetBSD, Minix
+ ut_id char[] glibc, musl, macOS, FreeBSD, NetBSD, Minix, AIX, HP-UX, IRIX, Solaris, Cygwin, Android
+ ut_line char[] glibc, musl, macOS, FreeBSD, NetBSD, Minix, AIX, HP-UX, IRIX, Solaris, Cygwin, Android
+ ut_pid pid_t glibc, musl, macOS, FreeBSD, NetBSD, Minix, AIX, HP-UX, IRIX, Solaris, Cygwin, Android
+ ut_type short glibc, musl, macOS, FreeBSD, NetBSD, Minix, AIX, HP-UX, IRIX, Solaris, Cygwin, Android
+ ⎡ ut_tv struct glibc, musl, macOS, FreeBSD, NetBSD, Minix, AIX, HP-UX, IRIX, Solaris, Cygwin, Android
+ ⎢ { tv_sec; tv_usec; }
+ ⎣ ut_time time_t Cygwin
+ ut_host char[] glibc, musl, macOS, FreeBSD, NetBSD, Minix, AIX, HP-UX, IRIX, Solaris, Cygwin, Android
+ ut_exit struct glibc, musl, NetBSD, Minix, HP-UX, IRIX, Solaris, Android
+ { e_termination; e_exit; }
+ ut_session [long] int glibc, musl, NetBSD, Minix, IRIX, Solaris, Android
+ ⎡ ut_addr [long] int HP-UX, Cygwin
+ ⎢ ut_addr_v6 [u]int[4] glibc, musl, Android
+ ⎣ ut_ss struct sockaddr_storage NetBSD, Minix
+ */
+
+# if __GLIBC__ && _TIME_BITS == 64
+/* This is a near-copy of glibc's struct utmpx, which stops working
+ after the year 2038. Unlike the glibc version, struct utmpx32
+ describes the file format even if time_t is 64 bits. */
+#define _GL_UT_USER_SIZE sizeof (((struct utmpx *) 0)->ut_user)
+#define _GL_UT_ID_SIZE sizeof (((struct utmpx *) 0)->ut_id)
+#define _GL_UT_LINE_SIZE sizeof (((struct utmpx *) 0)->ut_line)
+#define _GL_UT_HOST_SIZE sizeof (((struct utmpx *) 0)->ut_host)
+struct utmpx32
+{
+ short int ut_type; /* Type of login. */
+ pid_t ut_pid; /* Process ID of login process. */
+ char ut_line[_GL_UT_LINE_SIZE]; /* Devicename. */
+ char ut_id[_GL_UT_ID_SIZE]; /* Inittab ID. */
+ char ut_user[_GL_UT_USER_SIZE]; /* Username. */
+ char ut_host[_GL_UT_HOST_SIZE]; /* Hostname for remote login. */
+ struct __exit_status ut_exit; /* Exit status of a process marked
+ as DEAD_PROCESS. */
+ /* The fields ut_session and ut_tv must be the same size when compiled
+ 32- and 64-bit. This allows files and shared memory to be shared
+ between 32- and 64-bit applications. */
+ int ut_session; /* Session ID, used for windowing. */
+ struct
+ {
+ /* Seconds. Unsigned not signed, as glibc did not exist before 1970,
+ and if the format is still in use after 2038 its timestamps
+ will surely have the sign bit on. This hack stops working
+ at 2106-02-07 06:28:16 UTC. */
+ unsigned int tv_sec;
+ int tv_usec; /* Microseconds. */
+ } ut_tv; /* Time entry was made. */
+ int ut_addr_v6[4]; /* Internet address of remote host. */
+ char ut_reserved[20]; /* Reserved for future use. */
+};
+# define UTMP_STRUCT_NAME utmpx32
+# else
+# define UTMP_STRUCT_NAME utmpx
+# endif
+# define SET_UTMP_ENT setutxent
+# define GET_UTMP_ENT getutxent
+# define END_UTMP_ENT endutxent
+# ifdef HAVE_UTMPXNAME /* glibc, musl, macOS, NetBSD, Minix, IRIX, Solaris, Cygwin */
+# define UTMP_NAME_FUNCTION utmpxname
+# elif defined UTXDB_ACTIVE /* FreeBSD */
+# define UTMP_NAME_FUNCTION(x) setutxdb (UTXDB_ACTIVE, x)
+# elif defined __ANDROID__ /* Android */
+/* As of Android NDK r26, the getutxent, setutxent functions are no-ops.
+ Therefore we can ignore the file name. */
+# define UTMP_NAME_FUNCTION(x) ((void) (x))
+# endif
+
+#elif HAVE_UTMP_H
+
+/* <utmp.h> defines 'struct utmp' with the following fields:
+
+ Field Type Platforms
+ ---------- ------ ---------
+ ⎡ ut_user char[] glibc, musl, AIX, HP-UX, IRIX, Solaris, Cygwin, Android
+ ⎣ ut_name char[] macOS, old FreeBSD, NetBSD, OpenBSD, Minix
+ ut_id char[] glibc, musl, AIX, HP-UX, IRIX, Solaris, Cygwin, Android
+ ut_line char[] glibc, musl, macOS, old FreeBSD, NetBSD, OpenBSD, Minix, AIX, HP-UX, IRIX, Solaris, Cygwin, Android
+ ut_pid pid_t glibc, musl, AIX, HP-UX, IRIX, Solaris, Cygwin, Android
+ ut_type short glibc, musl, AIX, HP-UX, IRIX, Solaris, Cygwin, Android
+ ⎡ ut_tv struct glibc, musl, Android
+ ⎢ { tv_sec; tv_usec; }
+ ⎣ ut_time time_t macOS, old FreeBSD, NetBSD, OpenBSD, Minix, AIX, HP-UX, IRIX, Solaris, Cygwin
+ ut_host char[] glibc, musl, macOS, old FreeBSD, NetBSD, OpenBSD, Minix, AIX, HP-UX, Cygwin, Android
+ ut_exit struct glibc, musl, AIX, HP-UX, IRIX, Solaris, Android
+ { e_termination; e_exit; }
+ ut_session [long] int glibc, musl, Android
+ ⎡ ut_addr [long] int HP-UX, Cygwin
+ ⎣ ut_addr_v6 [u]int[4] glibc, musl, Android
+ */
+
+# define UTMP_STRUCT_NAME utmp
+# define SET_UTMP_ENT setutent
+# define GET_UTMP_ENT getutent
+# define END_UTMP_ENT endutent
+# ifdef HAVE_UTMPNAME /* glibc, musl, NetBSD, Minix, AIX, HP-UX, IRIX, Solaris, Cygwin, Android */
+# define UTMP_NAME_FUNCTION utmpname
+# endif
+
+#endif
+
+/* Evaluates to 1 if gl_utmp's ut_id field may ever have a non-zero value. */
+#define HAVE_STRUCT_XTMP_UT_ID \
+ (READUTMP_USE_SYSTEMD \
+ || (HAVE_UTMPX_H ? HAVE_STRUCT_UTMPX_UT_ID : HAVE_STRUCT_UTMP_UT_ID))
+
+/* Evaluates to 1 if gl_utmp's ut_pid field may ever have a non-zero value. */
+#define HAVE_STRUCT_XTMP_UT_PID \
+ (READUTMP_USE_SYSTEMD \
+ || (HAVE_UTMPX_H ? HAVE_STRUCT_UTMPX_UT_PID : HAVE_STRUCT_UTMP_UT_PID))
+
+/* Evaluates to 1 if gl_utmp's ut_host field may ever be non-empty. */
+#define HAVE_STRUCT_XTMP_UT_HOST \
+ (READUTMP_USE_SYSTEMD \
+ || (HAVE_UTMPX_H ? HAVE_STRUCT_UTMPX_UT_HOST : HAVE_STRUCT_UTMP_UT_HOST))
+
+/* Definition of UTMP_FILE.
+ On glibc systems, UTMP_FILE is "/var/run/utmp". */
+#if !defined UTMP_FILE && defined _PATH_UTMP
+# define UTMP_FILE _PATH_UTMP
+#endif
+#ifdef UTMPX_FILE /* Solaris, SysVr4 */
+# undef UTMP_FILE
+# define UTMP_FILE UTMPX_FILE
+#endif
+#ifndef UTMP_FILE
+# define UTMP_FILE "/etc/utmp"
+#endif
+
+/* Definition of WTMP_FILE.
+ On glibc systems, UTMP_FILE is "/var/log/wtmp". */
+#if !defined WTMP_FILE && defined _PATH_WTMP
+# define WTMP_FILE _PATH_WTMP
+#endif
+#ifdef WTMPX_FILE /* Solaris, SysVr4 */
+# undef WTMP_FILE
+# define WTMP_FILE WTMPX_FILE
+#endif
+#ifndef WTMP_FILE
+# define WTMP_FILE "/etc/wtmp"
+#endif
+
+/* In early versions of Android, <utmp.h> did not define BOOT_TIME, only
+ USER_PROCESS. We need to use the value that is defined in newer versions
+ of Android. */
+#if defined __ANDROID__ && !defined BOOT_TIME
+# define BOOT_TIME 2
+#endif
+
+/* Some platforms, such as OpenBSD, don't have an ut_type field and don't have
+ the BOOT_TIME and USER_PROCESS macros. But we want to support them in
+ 'struct gl_utmp'. */
+#if !(HAVE_UTMPX_H ? HAVE_STRUCT_UTMPX_UT_TYPE : HAVE_STRUCT_UTMP_UT_TYPE)
+# define BOOT_TIME 2
+# define USER_PROCESS 0
+#endif
+
+/* Macros that test (UT)->ut_type. */
+#ifdef BOOT_TIME
+# define UT_TYPE_BOOT_TIME(UT) ((UT)->ut_type == BOOT_TIME)
+#else
+# define UT_TYPE_BOOT_TIME(UT) 0
+#endif
+#ifdef USER_PROCESS
+# define UT_TYPE_USER_PROCESS(UT) ((UT)->ut_type == USER_PROCESS)
+#else
+# define UT_TYPE_USER_PROCESS(UT) 0
+#endif
+
+/* Determines whether an entry *UT corresponds to a user process. */
+#define IS_USER_PROCESS(UT) \
+ ((UT)->ut_user[0] && UT_TYPE_USER_PROCESS (UT))
+
+/* Define if read_utmp is not just a dummy. */
+#if READUTMP_USE_SYSTEMD || HAVE_UTMPX_H || HAVE_UTMP_H || defined __CYGWIN__ || defined _WIN32
+# define READ_UTMP_SUPPORTED 1
+#endif
+
+/* Options for read_utmp. */
+enum
+ {
+ READ_UTMP_CHECK_PIDS = 1,
+ READ_UTMP_USER_PROCESS = 2,
+ READ_UTMP_BOOT_TIME = 4,
+ READ_UTMP_NO_BOOT_TIME = 8
+ };
+
+/* Return a copy of (UT)->ut_user, without trailing spaces,
+ as a freshly allocated string. */
+char *extract_trimmed_name (const STRUCT_UTMP *ut)
+ _GL_ATTRIBUTE_MALLOC _GL_ATTRIBUTE_DEALLOC_FREE
+ _GL_ATTRIBUTE_RETURNS_NONNULL;
+
+/* Read the utmp entries corresponding to file FILE into freshly-
+ malloc'd storage, set *UTMP_BUF to that pointer, set *N_ENTRIES to
+ the number of entries, and return zero. If there is any error,
+ return -1, setting errno, and don't modify the parameters.
+ A good candidate for FILE is UTMP_FILE.
+ If OPTIONS & READ_UTMP_CHECK_PIDS is nonzero, omit entries whose
+ process-IDs do not currently exist.
+ If OPTIONS & READ_UTMP_USER_PROCESS is nonzero, omit entries which
+ do not correspond to a user process.
+ If OPTIONS & READ_UTMP_BOOT_TIME is nonzero, omit all entries except
+ the one that contains the boot time.
+ If OPTIONS & READ_UTMP_NO_BOOT_TIME is nonzero, omit the boot time
+ entries.
+
+ This function is not multithread-safe, since on many platforms it
+ invokes the functions setutxent, getutxent, endutxent. These
+ functions are needed because they may lock FILE (so that we don't
+ read garbage when a concurrent process writes to FILE), but their
+ drawback is that they have a common global state. */
+int read_utmp (char const *file, idx_t *n_entries, STRUCT_UTMP **utmp_buf,
+ int options);
+
+
+#ifdef __cplusplus
+}
+#endif
+
+#endif /* __READUTMP_H__ */
diff --git a/lib/regcomp.c b/lib/regcomp.c
index c79f9eb9e93..696cf813f3c 100644
--- a/lib/regcomp.c
+++ b/lib/regcomp.c
@@ -905,7 +905,7 @@ init_word_char (re_dfa_t *dfa)
bitset_word_t bits3 = 0x07fffffe;
if (BITSET_WORD_BITS == 64)
{
- /* Pacify gcc -Woverflow on 32-bit platformns. */
+ /* Pacify gcc -Woverflow on 32-bit platforms. */
dfa->word_char[0] = bits1 << 31 << 1 | bits0;
dfa->word_char[1] = bits3 << 31 << 1 | bits2;
i = 2;
diff --git a/lib/regex.c b/lib/regex.c
index 08031cecc04..4b1a6ed68e3 100644
--- a/lib/regex.c
+++ b/lib/regex.c
@@ -26,10 +26,6 @@
# pragma GCC diagnostic ignored "-Wsuggest-attribute=pure"
# pragma GCC diagnostic ignored "-Wvla"
# endif
-# if __GNUC_PREREQ (4, 3)
-# pragma GCC diagnostic ignored "-Wold-style-definition"
-# pragma GCC diagnostic ignored "-Wtype-limits"
-# endif
#endif
/* Make sure no one compiles this code with a C++ compiler. */
diff --git a/lib/regex_internal.h b/lib/regex_internal.h
index 717d632e822..6165cb17c70 100644
--- a/lib/regex_internal.h
+++ b/lib/regex_internal.h
@@ -29,6 +29,7 @@
#include <locale.h>
#include <wchar.h>
#include <wctype.h>
+#include <stdckdint.h>
#include <stdint.h>
#ifndef _LIBC
@@ -150,9 +151,6 @@
as some non-GCC platforms lack them, an issue when this code is
used in Gnulib. */
-#ifndef SSIZE_MAX
-# define SSIZE_MAX ((ssize_t) (SIZE_MAX / 2))
-#endif
#ifndef ULONG_WIDTH
# define ULONG_WIDTH REGEX_UINTEGER_WIDTH (ULONG_MAX)
/* The number of usable bits in an unsigned integer type with maximum
@@ -822,7 +820,7 @@ re_string_elem_size_at (const re_string_t *pstr, Idx idx)
}
#ifdef _LIBC
-# if __GNUC__ >= 7
+# if __glibc_has_attribute (__fallthrough__)
# define FALLTHROUGH __attribute__ ((__fallthrough__))
# else
# define FALLTHROUGH ((void) 0)
diff --git a/lib/regexec.c b/lib/regexec.c
index d42b2cc9029..9f065dfa020 100644
--- a/lib/regexec.c
+++ b/lib/regexec.c
@@ -324,7 +324,7 @@ re_search_2_stub (struct re_pattern_buffer *bufp, const char *string1,
char *s = NULL;
if (__glibc_unlikely ((length1 < 0 || length2 < 0 || stop < 0
- || INT_ADD_WRAPV (length1, length2, &len))))
+ || ckd_add (&len, length1, length2))))
return -2;
/* Concatenate the strings. */
diff --git a/lib/save-cwd.h b/lib/save-cwd.h
index 79900ee0b08..692e4b97be2 100644
--- a/lib/save-cwd.h
+++ b/lib/save-cwd.h
@@ -1,7 +1,7 @@
/* Save and restore current working directory.
- Copyright (C) 1995, 1997-1998, 2003, 2009-2024 Free Software
- Foundation, Inc.
+ Copyright (C) 1995, 1997-1998, 2003, 2009-2024 Free Software Foundation,
+ Inc.
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/lib/set-permissions.c b/lib/set-permissions.c
index a3d4cc839e5..83a355faa5c 100644
--- a/lib/set-permissions.c
+++ b/lib/set-permissions.c
@@ -22,6 +22,7 @@
#include "acl.h"
#include "acl-internal.h"
+#include "minmax.h"
#if USE_ACL
# if ! defined HAVE_ACL_FROM_MODE && defined HAVE_ACL_FROM_TEXT /* FreeBSD, IRIX, Tru64, Cygwin >= 2.5 */
diff --git a/lib/sha1.c b/lib/sha1.c
index 454d68e266d..24fcd0b0139 100644
--- a/lib/sha1.c
+++ b/lib/sha1.c
@@ -1,8 +1,7 @@
/* sha1.c - Functions to compute SHA1 message digest of files or
memory blocks according to the NIST specification FIPS-180-1.
- Copyright (C) 2000-2001, 2003-2006, 2008-2024 Free Software
- Foundation, Inc.
+ Copyright (C) 2000-2001, 2003-2006, 2008-2024 Free Software Foundation, Inc.
This file is free software: you can redistribute it and/or modify
it under the terms of the GNU Lesser General Public License as
diff --git a/lib/sha1.h b/lib/sha1.h
index b604a42958f..940163eb528 100644
--- a/lib/sha1.h
+++ b/lib/sha1.h
@@ -19,6 +19,11 @@
#ifndef SHA1_H
# define SHA1_H 1
+/* This file uses HAVE_OPENSSL_SHA1. */
+# if !_GL_CONFIG_H_INCLUDED
+# error "Please include config.h first."
+# endif
+
# include <stdio.h>
# include <stdint.h>
@@ -26,7 +31,21 @@
# ifndef OPENSSL_API_COMPAT
# define OPENSSL_API_COMPAT 0x10101000L /* FIXME: Use OpenSSL 1.1+ API. */
# endif
-# include <openssl/sha.h>
+/* If <openssl/macros.h> would give a compile-time error, don't use OpenSSL. */
+# include <openssl/opensslv.h>
+# if OPENSSL_VERSION_MAJOR >= 3
+# include <openssl/configuration.h>
+# if (OPENSSL_CONFIGURED_API \
+ < (OPENSSL_API_COMPAT < 0x900000L ? OPENSSL_API_COMPAT : \
+ ((OPENSSL_API_COMPAT >> 28) & 0xF) * 10000 \
+ + ((OPENSSL_API_COMPAT >> 20) & 0xFF) * 100 \
+ + ((OPENSSL_API_COMPAT >> 12) & 0xFF)))
+# undef HAVE_OPENSSL_SHA1
+# endif
+# endif
+# if HAVE_OPENSSL_SHA1
+# include <openssl/sha.h>
+# endif
# endif
# ifdef __cplusplus
diff --git a/lib/sha256.h b/lib/sha256.h
index a1e3466186e..a9d7abb8a2c 100644
--- a/lib/sha256.h
+++ b/lib/sha256.h
@@ -18,6 +18,11 @@
#ifndef SHA256_H
# define SHA256_H 1
+/* This file uses HAVE_OPENSSL_SHA256. */
+# if !_GL_CONFIG_H_INCLUDED
+# error "Please include config.h first."
+# endif
+
# include <stdio.h>
# include <stdint.h>
@@ -25,7 +30,21 @@
# ifndef OPENSSL_API_COMPAT
# define OPENSSL_API_COMPAT 0x10101000L /* FIXME: Use OpenSSL 1.1+ API. */
# endif
-# include <openssl/sha.h>
+/* If <openssl/macros.h> would give a compile-time error, don't use OpenSSL. */
+# include <openssl/opensslv.h>
+# if OPENSSL_VERSION_MAJOR >= 3
+# include <openssl/configuration.h>
+# if (OPENSSL_CONFIGURED_API \
+ < (OPENSSL_API_COMPAT < 0x900000L ? OPENSSL_API_COMPAT : \
+ ((OPENSSL_API_COMPAT >> 28) & 0xF) * 10000 \
+ + ((OPENSSL_API_COMPAT >> 20) & 0xFF) * 100 \
+ + ((OPENSSL_API_COMPAT >> 12) & 0xFF)))
+# undef HAVE_OPENSSL_SHA256
+# endif
+# endif
+# if HAVE_OPENSSL_SHA256
+# include <openssl/sha.h>
+# endif
# endif
# ifdef __cplusplus
diff --git a/lib/sha512.h b/lib/sha512.h
index 9c688cc3d71..f6bac85488e 100644
--- a/lib/sha512.h
+++ b/lib/sha512.h
@@ -18,6 +18,11 @@
#ifndef SHA512_H
# define SHA512_H 1
+/* This file uses HAVE_OPENSSL_SHA512. */
+# if !_GL_CONFIG_H_INCLUDED
+# error "Please include config.h first."
+# endif
+
# include <stdio.h>
# include "u64.h"
@@ -25,7 +30,21 @@
# ifndef OPENSSL_API_COMPAT
# define OPENSSL_API_COMPAT 0x10101000L /* FIXME: Use OpenSSL 1.1+ API. */
# endif
-# include <openssl/sha.h>
+/* If <openssl/macros.h> would give a compile-time error, don't use OpenSSL. */
+# include <openssl/opensslv.h>
+# if OPENSSL_VERSION_MAJOR >= 3
+# include <openssl/configuration.h>
+# if (OPENSSL_CONFIGURED_API \
+ < (OPENSSL_API_COMPAT < 0x900000L ? OPENSSL_API_COMPAT : \
+ ((OPENSSL_API_COMPAT >> 28) & 0xF) * 10000 \
+ + ((OPENSSL_API_COMPAT >> 20) & 0xFF) * 100 \
+ + ((OPENSSL_API_COMPAT >> 12) & 0xFF)))
+# undef HAVE_OPENSSL_SHA512
+# endif
+# endif
+# if HAVE_OPENSSL_SHA512
+# include <openssl/sha.h>
+# endif
# endif
# ifdef __cplusplus
diff --git a/lib/sig2str.c b/lib/sig2str.c
index ac20be041a4..c6b91e38498 100644
--- a/lib/sig2str.c
+++ b/lib/sig2str.c
@@ -1,7 +1,6 @@
/* sig2str.c -- convert between signal names and numbers
- Copyright (C) 2002, 2004, 2006, 2009-2024 Free Software Foundation,
- Inc.
+ Copyright (C) 2002, 2004, 2006, 2009-2024 Free Software Foundation, Inc.
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/lib/signal.in.h b/lib/signal.in.h
index 7029ac97408..107226e3dcf 100644
--- a/lib/signal.in.h
+++ b/lib/signal.in.h
@@ -55,6 +55,11 @@
#ifndef _@GUARD_PREFIX@_SIGNAL_H
#define _@GUARD_PREFIX@_SIGNAL_H
+/* This file uses GNULIB_POSIXCHECK, HAVE_RAW_DECL_*. */
+#if !_GL_CONFIG_H_INCLUDED
+ #error "Please include config.h first."
+#endif
+
/* For testing the OpenBSD version. */
#if (@GNULIB_PTHREAD_SIGMASK@ || defined GNULIB_POSIXCHECK) \
&& defined __OpenBSD__
diff --git a/lib/stat-time.h b/lib/stat-time.h
index 95064479805..3cd8478f310 100644
--- a/lib/stat-time.h
+++ b/lib/stat-time.h
@@ -20,15 +20,18 @@
#ifndef STAT_TIME_H
#define STAT_TIME_H 1
+/* This file uses _GL_INLINE_HEADER_BEGIN, _GL_INLINE, _GL_UNUSED,
+ _GL_ATTRIBUTE_PURE, HAVE_STRUCT_STAT_*. */
+#if !_GL_CONFIG_H_INCLUDED
+ #error "Please include config.h first."
+#endif
+
#include <errno.h>
#include <stdckdint.h>
#include <stddef.h>
#include <sys/stat.h>
#include <time.h>
-#ifndef _GL_INLINE_HEADER_BEGIN
- #error "Please include config.h first."
-#endif
_GL_INLINE_HEADER_BEGIN
#ifndef _GL_STAT_TIME_INLINE
# define _GL_STAT_TIME_INLINE _GL_INLINE
@@ -49,11 +52,13 @@ extern "C" {
#if _GL_WINDOWS_STAT_TIMESPEC || defined HAVE_STRUCT_STAT_ST_ATIM_TV_NSEC
# if _GL_WINDOWS_STAT_TIMESPEC || defined TYPEOF_STRUCT_STAT_ST_ATIM_IS_STRUCT_TIMESPEC
# define STAT_TIMESPEC(st, st_xtim) ((st)->st_xtim)
+# define STAT_TIMESPEC_OFFSETOF(st_xtim) offsetof (struct stat, st_xtim)
# else
# define STAT_TIMESPEC_NS(st, st_xtim) ((st)->st_xtim.tv_nsec)
# endif
#elif defined HAVE_STRUCT_STAT_ST_ATIMESPEC_TV_NSEC
# define STAT_TIMESPEC(st, st_xtim) ((st)->st_xtim##espec)
+# define STAT_TIMESPEC_OFFSETOF(st_xtim) offsetof (struct stat, st_xtim##espec)
#elif defined HAVE_STRUCT_STAT_ST_ATIMENSEC
# define STAT_TIMESPEC_NS(st, st_xtim) ((st)->st_xtim##ensec)
#elif defined HAVE_STRUCT_STAT_ST_ATIM_ST__TIM_TV_NSEC
@@ -119,10 +124,8 @@ get_stat_atime (struct stat const *st)
#ifdef STAT_TIMESPEC
return STAT_TIMESPEC (st, st_atim);
#else
- struct timespec t;
- t.tv_sec = st->st_atime;
- t.tv_nsec = get_stat_atime_ns (st);
- return t;
+ return (struct timespec) { .tv_sec = st->st_atime,
+ .tv_nsec = get_stat_atime_ns (st) };
#endif
}
@@ -133,10 +136,8 @@ get_stat_ctime (struct stat const *st)
#ifdef STAT_TIMESPEC
return STAT_TIMESPEC (st, st_ctim);
#else
- struct timespec t;
- t.tv_sec = st->st_ctime;
- t.tv_nsec = get_stat_ctime_ns (st);
- return t;
+ return (struct timespec) { .tv_sec = st->st_ctime,
+ .tv_nsec = get_stat_ctime_ns (st) };
#endif
}
@@ -147,10 +148,8 @@ get_stat_mtime (struct stat const *st)
#ifdef STAT_TIMESPEC
return STAT_TIMESPEC (st, st_mtim);
#else
- struct timespec t;
- t.tv_sec = st->st_mtime;
- t.tv_nsec = get_stat_mtime_ns (st);
- return t;
+ return (struct timespec) { .tv_sec = st->st_mtime,
+ .tv_nsec = get_stat_mtime_ns (st) };
#endif
}
@@ -165,8 +164,8 @@ get_stat_birthtime (_GL_UNUSED struct stat const *st)
|| defined HAVE_STRUCT_STAT_ST_BIRTHTIM_TV_NSEC)
t = STAT_TIMESPEC (st, st_birthtim);
#elif defined HAVE_STRUCT_STAT_ST_BIRTHTIMENSEC
- t.tv_sec = st->st_birthtime;
- t.tv_nsec = st->st_birthtimensec;
+ t = (struct timespec) { .tv_sec = st->st_birthtime,
+ .tv_nsec = st->st_birthtimensec };
#elif defined _WIN32 && ! defined __CYGWIN__
/* Native Windows platforms (but not Cygwin) put the "file creation
time" in st_ctime (!). See
@@ -174,13 +173,11 @@ get_stat_birthtime (_GL_UNUSED struct stat const *st)
# if _GL_WINDOWS_STAT_TIMESPEC
t = st->st_ctim;
# else
- t.tv_sec = st->st_ctime;
- t.tv_nsec = 0;
+ t = (struct timespec) { .tv_sec = st->st_ctime };
# endif
#else
/* Birth time is not supported. */
- t.tv_sec = -1;
- t.tv_nsec = -1;
+ t = (struct timespec) { .tv_sec = -1, .tv_nsec = -1 };
#endif
#if (defined HAVE_STRUCT_STAT_ST_BIRTHTIMESPEC_TV_NSEC \
@@ -192,30 +189,28 @@ get_stat_birthtime (_GL_UNUSED struct stat const *st)
sometimes returns junk in the birth time fields; work around this
bug if it is detected. */
if (! (t.tv_sec && 0 <= t.tv_nsec && t.tv_nsec < 1000000000))
- {
- t.tv_sec = -1;
- t.tv_nsec = -1;
- }
+ t = (struct timespec) { .tv_sec = -1, .tv_nsec = -1 };
#endif
return t;
}
/* If a stat-like function returned RESULT, normalize the timestamps
- in *ST, in case this platform suffers from the Solaris 11 bug where
+ in *ST, if this platform suffers from a macOS and Solaris bug where
tv_nsec might be negative. Return the adjusted RESULT, setting
errno to EOVERFLOW if normalization overflowed. This function
is intended to be private to this .h file. */
_GL_STAT_TIME_INLINE int
stat_time_normalize (int result, _GL_UNUSED struct stat *st)
{
-#if defined __sun && defined STAT_TIMESPEC
+#if (((defined __APPLE__ && defined __MACH__) || defined __sun) \
+ && defined STAT_TIMESPEC_OFFSETOF)
if (result == 0)
{
long int timespec_hz = 1000000000;
- short int const ts_off[] = { offsetof (struct stat, st_atim),
- offsetof (struct stat, st_mtim),
- offsetof (struct stat, st_ctim) };
+ short int const ts_off[] = { STAT_TIMESPEC_OFFSETOF (st_atim),
+ STAT_TIMESPEC_OFFSETOF (st_mtim),
+ STAT_TIMESPEC_OFFSETOF (st_ctim) };
int i;
for (i = 0; i < sizeof ts_off / sizeof *ts_off; i++)
{
@@ -229,8 +224,7 @@ stat_time_normalize (int result, _GL_UNUSED struct stat *st)
}
ts->tv_nsec = r;
/* Overflow is possible, as Solaris 11 stat can yield
- tv_sec == TYPE_MINIMUM (time_t) && tv_nsec == -1000000000.
- INT_ADD_WRAPV is OK, since time_t is signed on Solaris. */
+ tv_sec == TYPE_MINIMUM (time_t) && tv_nsec == -1000000000. */
if (ckd_add (&ts->tv_sec, q, ts->tv_sec))
{
errno = EOVERFLOW;
diff --git a/lib/stdalign.in.h b/lib/stdalign.in.h
index 0a58e3208a5..ff9e5ec6d67 100644
--- a/lib/stdalign.in.h
+++ b/lib/stdalign.in.h
@@ -17,117 +17,33 @@
/* Written by Paul Eggert and Bruno Haible. */
-#ifndef _GL_STDALIGN_H
-#define _GL_STDALIGN_H
+/* Define two obsolescent C11 macros, assuming alignas and alignof are
+ either keywords or alignasof-defined macros. */
-/* ISO C11 <stdalign.h> for platforms that lack it.
+#ifndef _@GUARD_PREFIX@_STDALIGN_H
- References:
- ISO C11 (latest free draft
- <http://www.open-std.org/jtc1/sc22/wg14/www/docs/n1570.pdf>)
- sections 6.5.3.4, 6.7.5, 7.15.
- C++11 (latest free draft
- <http://www.open-std.org/jtc1/sc22/wg21/docs/papers/2011/n3242.pdf>)
- section 18.10. */
-
-/* alignof (TYPE), also known as _Alignof (TYPE), yields the alignment
- requirement of a structure member (i.e., slot or field) that is of
- type TYPE, as an integer constant expression.
-
- This differs from GCC's and clang's __alignof__ operator, which can
- yield a better-performing alignment for an object of that type. For
- example, on x86 with GCC and on Linux/x86 with clang,
- __alignof__ (double) and __alignof__ (long long) are 8, whereas
- alignof (double) and alignof (long long) are 4 unless the option
- '-malign-double' is used.
-
- The result cannot be used as a value for an 'enum' constant, if you
- want to be portable to HP-UX 10.20 cc and AIX 3.2.5 xlc. */
-
-/* FreeBSD 9.1 <sys/cdefs.h>, included by <stddef.h> and lots of other
- standard headers, defines conflicting implementations of _Alignas
- and _Alignof that are no better than ours; override them. */
-#undef _Alignas
-#undef _Alignof
-
-/* GCC releases before GCC 4.9 had a bug in _Alignof. See GCC bug 52023
- <https://gcc.gnu.org/bugzilla/show_bug.cgi?id=52023>.
- clang versions < 8.0.0 have the same bug. */
-#if (!defined __STDC_VERSION__ || __STDC_VERSION__ < 201112 \
- || (defined __GNUC__ && __GNUC__ < 4 + (__GNUC_MINOR__ < 9) \
- && !defined __clang__) \
- || (defined __clang__ && __clang_major__ < 8))
-# ifdef __cplusplus
-# if (201103 <= __cplusplus || defined _MSC_VER)
-# define _Alignof(type) alignof (type)
-# else
- template <class __t> struct __alignof_helper { char __a; __t __b; };
-# define _Alignof(type) offsetof (__alignof_helper<type>, __b)
-# define _GL_STDALIGN_NEEDS_STDDEF 1
-# endif
-# else
-# define _Alignof(type) offsetof (struct { char __a; type __b; }, __b)
-# define _GL_STDALIGN_NEEDS_STDDEF 1
-# endif
+#if __GNUC__ >= 3
+@PRAGMA_SYSTEM_HEADER@
#endif
-#if ! (defined __cplusplus && (201103 <= __cplusplus || defined _MSC_VER))
-# define alignof _Alignof
-#endif
-#define __alignof_is_defined 1
-
-/* alignas (A), also known as _Alignas (A), aligns a variable or type
- to the alignment A, where A is an integer constant expression. For
- example:
-
- int alignas (8) foo;
- struct s { int a; int alignas (8) bar; };
+@PRAGMA_COLUMNS@
- aligns the address of FOO and the offset of BAR to be multiples of 8.
-
- A should be a power of two that is at least the type's alignment
- and at most the implementation's alignment limit. This limit is
- 2**28 on typical GNUish hosts, and 2**13 on MSVC. To be portable
- to MSVC through at least version 10.0, A should be an integer
- constant, as MSVC does not support expressions such as 1 << 3.
- To be portable to Sun C 5.11, do not align auto variables to
- anything stricter than their default alignment.
-
- The following C11 requirements are not supported here:
-
- - If A is zero, alignas has no effect.
- - alignas can be used multiple times; the strictest one wins.
- - alignas (TYPE) is equivalent to alignas (alignof (TYPE)).
+/* We need to include the system's <stdalign.h> when it exists, because it might
+ define 'alignof' as a macro when it's not a keyword or compiler built-in. */
+#if @HAVE_STDALIGN_H@
+/* The include_next requires a split double-inclusion guard. */
+# @INCLUDE_NEXT@ @NEXT_STDALIGN_H@
+#endif
- */
+#ifndef _@GUARD_PREFIX@_STDALIGN_H
+#define _@GUARD_PREFIX@_STDALIGN_H
-#if !defined __STDC_VERSION__ || __STDC_VERSION__ < 201112
-# if defined __cplusplus && (201103 <= __cplusplus || defined _MSC_VER)
-# define _Alignas(a) alignas (a)
-# elif (!defined __attribute__ \
- && ((defined __APPLE__ && defined __MACH__ \
- ? 4 < __GNUC__ + (1 <= __GNUC_MINOR__) \
- : __GNUC__ && !defined __ibmxl__) \
- || (4 <= __clang_major__) \
- || (__ia64 && (61200 <= __HP_cc || 61200 <= __HP_aCC)) \
- || __ICC || 0x590 <= __SUNPRO_C || 0x0600 <= __xlC__))
-# define _Alignas(a) __attribute__ ((__aligned__ (a)))
-# elif 1300 <= _MSC_VER
-# define _Alignas(a) __declspec (align (a))
-# endif
-#endif
-#if ((defined _Alignas \
- && !(defined __cplusplus && (201103 <= __cplusplus || defined _MSC_VER))) \
- || (defined __STDC_VERSION__ && 201112 <= __STDC_VERSION__))
-# define alignas _Alignas
-#endif
#if (defined alignas \
+ || (defined __STDC_VERSION__ && 202311 <= __STDC_VERSION__) \
|| (defined __cplusplus && (201103 <= __cplusplus || defined _MSC_VER)))
# define __alignas_is_defined 1
#endif
-/* Include <stddef.h> if needed for offsetof. */
-#if _GL_STDALIGN_NEEDS_STDDEF
-# include <stddef.h>
-#endif
+#define __alignof_is_defined 1
-#endif /* _GL_STDALIGN_H */
+#endif /* _@GUARD_PREFIX@_STDALIGN_H */
+#endif /* _@GUARD_PREFIX@_STDALIGN_H */
diff --git a/lib/stddef.in.h b/lib/stddef.in.h
index 362a2720992..fa8998d9b72 100644
--- a/lib/stddef.in.h
+++ b/lib/stddef.in.h
@@ -18,7 +18,7 @@
/* Written by Eric Blake. */
/*
- * POSIX 2008 <stddef.h> for platforms that have issues.
+ * POSIX 2008 and ISO C 23 <stddef.h> for platforms that have issues.
* <https://pubs.opengroup.org/onlinepubs/9699919799/basedefs/stddef.h.html>
*/
@@ -37,9 +37,9 @@
remember if special invocation has ever been used to obtain wint_t,
in which case we need to clean up NULL yet again. */
-# if !(defined _@GUARD_PREFIX@_STDDEF_H && defined _GL_STDDEF_WINT_T)
+# if !(defined _@GUARD_PREFIX@_STDDEF_H && defined _@GUARD_PREFIX@_STDDEF_WINT_T)
# ifdef __need_wint_t
-# define _GL_STDDEF_WINT_T
+# define _@GUARD_PREFIX@_STDDEF_WINT_T
# endif
# @INCLUDE_NEXT@ @NEXT_STDDEF_H@
/* On TinyCC, make sure that the macros that indicate the special invocation
@@ -58,7 +58,7 @@
/* On AIX 7.2, with xlc in 64-bit mode, <stddef.h> defines max_align_t to a
type with alignment 4, but 'long' has alignment 8. */
-# if defined _AIX && defined __LP64__
+# if defined _AIX && defined __LP64__ && !@HAVE_MAX_ALIGN_T@
# if !GNULIB_defined_max_align_t
# ifdef _MAX_ALIGN_T
/* /usr/include/stddef.h has already defined max_align_t. Override it. */
@@ -69,6 +69,7 @@ typedef long rpl_max_align_t;
typedef long max_align_t;
# define _MAX_ALIGN_T
# endif
+# define __CLANG_MAX_ALIGN_T_DEFINED
# define GNULIB_defined_max_align_t 1
# endif
# endif
@@ -79,7 +80,7 @@ typedef long max_align_t;
/* On NetBSD 5.0, the definition of NULL lacks proper parentheses. */
# if (@REPLACE_NULL@ \
- && (!defined _@GUARD_PREFIX@_STDDEF_H || defined _GL_STDDEF_WINT_T))
+ && (!defined _@GUARD_PREFIX@_STDDEF_H || defined _@GUARD_PREFIX@_STDDEF_WINT_T))
# undef NULL
# ifdef __cplusplus
/* ISO C++ says that the macro NULL must expand to an integer constant
@@ -100,6 +101,33 @@ typedef long max_align_t;
# ifndef _@GUARD_PREFIX@_STDDEF_H
# define _@GUARD_PREFIX@_STDDEF_H
+/* This file uses _Noreturn, _GL_ATTRIBUTE_NOTHROW. */
+#if !_GL_CONFIG_H_INCLUDED
+ #error "Please include config.h first."
+#endif
+
+/* _GL_ATTRIBUTE_NOTHROW declares that the function does not throw exceptions.
+ */
+#ifndef _GL_ATTRIBUTE_NOTHROW
+# if defined __cplusplus
+# if (__GNUC__ + (__GNUC_MINOR__ >= 8) > 2) || __clang_major >= 4
+# if __cplusplus >= 201103L
+# define _GL_ATTRIBUTE_NOTHROW noexcept (true)
+# else
+# define _GL_ATTRIBUTE_NOTHROW throw ()
+# endif
+# else
+# define _GL_ATTRIBUTE_NOTHROW
+# endif
+# else
+# if (__GNUC__ + (__GNUC_MINOR__ >= 3) > 3) || defined __clang__
+# define _GL_ATTRIBUTE_NOTHROW __attribute__ ((__nothrow__))
+# else
+# define _GL_ATTRIBUTE_NOTHROW
+# endif
+# endif
+#endif
+
/* Some platforms lack wchar_t. */
#if !@HAVE_WCHAR_T@
# define wchar_t int
@@ -137,11 +165,49 @@ typedef union
long int __i _GL_STDDEF_ALIGNAS (long int);
} rpl_max_align_t;
# define max_align_t rpl_max_align_t
+# define __CLANG_MAX_ALIGN_T_DEFINED
# define GNULIB_defined_max_align_t 1
# endif
# endif
#endif
+/* ISO C 23 § 7.21.1 The unreachable macro */
+#ifndef unreachable
+
+/* Code borrowed from verify.h. */
+# ifndef _GL_HAS_BUILTIN_UNREACHABLE
+# if defined __clang_major__ && __clang_major__ < 5
+# define _GL_HAS_BUILTIN_UNREACHABLE 0
+# elif 4 < __GNUC__ + (5 <= __GNUC_MINOR__)
+# define _GL_HAS_BUILTIN_UNREACHABLE 1
+# elif defined __has_builtin
+# define _GL_HAS_BUILTIN_UNREACHABLE __has_builtin (__builtin_unreachable)
+# else
+# define _GL_HAS_BUILTIN_UNREACHABLE 0
+# endif
+# endif
+
+# if _GL_HAS_BUILTIN_UNREACHABLE
+# define unreachable() __builtin_unreachable ()
+# elif 1200 <= _MSC_VER
+# define unreachable() __assume (0)
+# else
+/* Declare abort(), without including <stdlib.h>. */
+extern
+# if defined __cplusplus
+"C"
+# endif
+_Noreturn
+void abort (void)
+# if defined __cplusplus && (__GLIBC__ >= 2)
+_GL_ATTRIBUTE_NOTHROW
+# endif
+;
+# define unreachable() abort ()
+# endif
+
+#endif
+
# endif /* _@GUARD_PREFIX@_STDDEF_H */
# endif /* _@GUARD_PREFIX@_STDDEF_H */
#endif /* __need_XXX */
diff --git a/lib/stdint.in.h b/lib/stdint.in.h
index 446f29ecb57..fea7483b9cc 100644
--- a/lib/stdint.in.h
+++ b/lib/stdint.in.h
@@ -306,6 +306,8 @@ typedef gl_uint_fast32_t gl_uint_fast16_t;
uintptr_t to avoid conflicting declarations of system functions like
_findclose in <io.h>. */
# if !((defined __KLIBC__ && defined _INTPTR_T_DECLARED) \
+ || (defined __INTPTR_WIDTH__ \
+ && __INTPTR_WIDTH__ != (defined _WIN64 ? LLONG_WIDTH : LONG_WIDTH)) \
|| defined __MINGW32__)
# undef intptr_t
# undef uintptr_t
diff --git a/lib/stdio-impl.h b/lib/stdio-impl.h
index da6555ae820..63ebf7c64b7 100644
--- a/lib/stdio-impl.h
+++ b/lib/stdio-impl.h
@@ -71,6 +71,12 @@
# else
# define _gl_flags_file_t short
# endif
+# ifdef __LP64__
+# define _gl_file_offset_t int64_t
+# else
+ /* see https://android.googlesource.com/platform/bionic/+/master/docs/32-bit-abi.md */
+# define _gl_file_offset_t __kernel_off_t
+# endif
/* Up to this commit from 2015-10-12
<https://android.googlesource.com/platform/bionic.git/+/f0141dfab10a4b332769d52fa76631a64741297a>
the innards of FILE were public, and fp_ub could be defined like for OpenBSD,
@@ -96,7 +102,7 @@
unsigned char _nbuf[1]; \
struct { unsigned char *_base; size_t _size; } _lb; \
int _blksize; \
- fpos_t _offset; \
+ _gl_file_offset_t _offset; \
/* More fields, not relevant here. */ \
} *) fp)
# else
diff --git a/lib/stdio.in.h b/lib/stdio.in.h
index 9a078eae0a2..4947307e578 100644
--- a/lib/stdio.in.h
+++ b/lib/stdio.in.h
@@ -36,6 +36,18 @@
#ifndef _@GUARD_PREFIX@_STDIO_H
+/* Suppress macOS deprecation warnings for sprintf and vsprintf. */
+#if (defined __APPLE__ && defined __MACH__) && !defined _POSIX_C_SOURCE
+# ifdef __ENVIRONMENT_MAC_OS_X_VERSION_MIN_REQUIRED__
+# include <AvailabilityMacros.h>
+# endif
+# if (defined MAC_OS_X_VERSION_MIN_REQUIRED \
+ && 130000 <= MAC_OS_X_VERSION_MIN_REQUIRED)
+# define _POSIX_C_SOURCE 200809L
+# define _GL_DEFINED__POSIX_C_SOURCE
+# endif
+#endif
+
#define _GL_ALREADY_INCLUDING_STDIO_H
/* The include_next requires a split double-inclusion guard. */
@@ -43,9 +55,21 @@
#undef _GL_ALREADY_INCLUDING_STDIO_H
+#ifdef _GL_DEFINED__POSIX_C_SOURCE
+# undef _GL_DEFINED__POSIX_C_SOURCE
+# undef _POSIX_C_SOURCE
+#endif
+
#ifndef _@GUARD_PREFIX@_STDIO_H
#define _@GUARD_PREFIX@_STDIO_H
+/* This file uses _GL_ATTRIBUTE_DEALLOC, _GL_ATTRIBUTE_FORMAT,
+ _GL_ATTRIBUTE_MALLOC, _GL_ATTRIBUTE_NOTHROW, GNULIB_POSIXCHECK,
+ HAVE_RAW_DECL_*. */
+#if !_GL_CONFIG_H_INCLUDED
+ #error "Please include config.h first."
+#endif
+
/* Get va_list. Needed on many systems, including glibc 2.8. */
#include <stdarg.h>
@@ -116,6 +140,38 @@
# endif
#endif
+/* _GL_ATTRIBUTE_MALLOC declares that the function returns a pointer to freshly
+ allocated memory. */
+#ifndef _GL_ATTRIBUTE_MALLOC
+# if __GNUC__ >= 3 || defined __clang__
+# define _GL_ATTRIBUTE_MALLOC __attribute__ ((__malloc__))
+# else
+# define _GL_ATTRIBUTE_MALLOC
+# endif
+#endif
+
+/* _GL_ATTRIBUTE_NOTHROW declares that the function does not throw exceptions.
+ */
+#ifndef _GL_ATTRIBUTE_NOTHROW
+# if defined __cplusplus
+# if (__GNUC__ + (__GNUC_MINOR__ >= 8) > 2) || __clang_major >= 4
+# if __cplusplus >= 201103L
+# define _GL_ATTRIBUTE_NOTHROW noexcept (true)
+# else
+# define _GL_ATTRIBUTE_NOTHROW throw ()
+# endif
+# else
+# define _GL_ATTRIBUTE_NOTHROW
+# endif
+# else
+# if (__GNUC__ + (__GNUC_MINOR__ >= 3) > 3) || defined __clang__
+# define _GL_ATTRIBUTE_NOTHROW __attribute__ ((__nothrow__))
+# else
+# define _GL_ATTRIBUTE_NOTHROW
+# endif
+# endif
+#endif
+
/* An __attribute__ __format__ specifier for a function that takes a format
string and arguments, where the format string directives are the ones
standardized by ISO C99 and POSIX.
@@ -193,6 +249,36 @@
# undef putc_unlocked
#endif
+
+/* Maximum number of characters produced by printing a NaN value. */
+#ifndef _PRINTF_NAN_LEN_MAX
+# if defined __FreeBSD__ || defined __DragonFly__ \
+ || defined __NetBSD__ \
+ || (defined __APPLE__ && defined __MACH__)
+/* On BSD systems, a NaN value prints as just "nan", without a sign. */
+# define _PRINTF_NAN_LEN_MAX 3
+# elif (__GLIBC__ >= 2) || MUSL_LIBC || defined __OpenBSD__ || defined __sun || defined __CYGWIN__
+/* glibc, musl libc, OpenBSD, Solaris libc, and Cygwin produce "[-]nan". */
+# define _PRINTF_NAN_LEN_MAX 4
+# elif defined _AIX
+/* AIX produces "[-]NaNQ". */
+# define _PRINTF_NAN_LEN_MAX 5
+# elif defined _WIN32 && !defined __CYGWIN__
+/* On native Windows, the output can be:
+ - with MSVC ucrt: "[-]nan" or "[-]nan(ind)" or "[-]nan(snan)",
+ - with mingw: "[-]1.#IND" or "[-]1.#QNAN". */
+# define _PRINTF_NAN_LEN_MAX 10
+# elif defined __sgi
+/* On IRIX, the output typically is "[-]nan0xNNNNNNNN" with 8 hexadecimal
+ digits. */
+# define _PRINTF_NAN_LEN_MAX 14
+# else
+/* We don't know, but 32 should be a safe maximum. */
+# define _PRINTF_NAN_LEN_MAX 32
+# endif
+#endif
+
+
#if @GNULIB_DPRINTF@
# if @REPLACE_DPRINTF@
# if !(defined __cplusplus && defined GNULIB_NAMESPACE)
@@ -210,7 +296,9 @@ _GL_FUNCDECL_SYS (dprintf, int, (int fd, const char *restrict format, ...)
# endif
_GL_CXXALIAS_SYS (dprintf, int, (int fd, const char *restrict format, ...));
# endif
+# if __GLIBC__ >= 2
_GL_CXXALIASWARN (dprintf);
+# endif
#elif defined GNULIB_POSIXCHECK
# undef dprintf
# if HAVE_RAW_DECL_DPRINTF
@@ -273,7 +361,8 @@ _GL_CXXALIASWARN (fcloseall);
# endif
_GL_FUNCDECL_RPL (fdopen, FILE *,
(int fd, const char *mode)
- _GL_ARG_NONNULL ((2)) _GL_ATTRIBUTE_DEALLOC (fclose, 1));
+ _GL_ARG_NONNULL ((2)) _GL_ATTRIBUTE_DEALLOC (fclose, 1)
+ _GL_ATTRIBUTE_MALLOC);
_GL_CXXALIAS_RPL (fdopen, FILE *, (int fd, const char *mode));
# elif defined _WIN32 && !defined __CYGWIN__
# if !(defined __cplusplus && defined GNULIB_NAMESPACE)
@@ -284,9 +373,18 @@ _GL_CXXALIAS_MDA (fdopen, FILE *, (int fd, const char *mode));
# else
# if __GNUC__ >= 11
/* For -Wmismatched-dealloc: Associate fdopen with fclose or rpl_fclose. */
+# if __GLIBC__ + (__GLIBC_MINOR__ >= 2) > 2
_GL_FUNCDECL_SYS (fdopen, FILE *,
(int fd, const char *mode)
- _GL_ARG_NONNULL ((2)) _GL_ATTRIBUTE_DEALLOC (fclose, 1));
+ _GL_ATTRIBUTE_NOTHROW
+ _GL_ARG_NONNULL ((2)) _GL_ATTRIBUTE_DEALLOC (fclose, 1)
+ _GL_ATTRIBUTE_MALLOC);
+# else
+_GL_FUNCDECL_SYS (fdopen, FILE *,
+ (int fd, const char *mode)
+ _GL_ARG_NONNULL ((2)) _GL_ATTRIBUTE_DEALLOC (fclose, 1)
+ _GL_ATTRIBUTE_MALLOC);
+# endif
# endif
_GL_CXXALIAS_SYS (fdopen, FILE *, (int fd, const char *mode));
# endif
@@ -294,9 +392,18 @@ _GL_CXXALIASWARN (fdopen);
#else
# if @GNULIB_FCLOSE@ && __GNUC__ >= 11 && !defined fdopen
/* For -Wmismatched-dealloc: Associate fdopen with fclose or rpl_fclose. */
+# if __GLIBC__ + (__GLIBC_MINOR__ >= 2) > 2
+_GL_FUNCDECL_SYS (fdopen, FILE *,
+ (int fd, const char *mode)
+ _GL_ATTRIBUTE_NOTHROW
+ _GL_ARG_NONNULL ((2)) _GL_ATTRIBUTE_DEALLOC (fclose, 1)
+ _GL_ATTRIBUTE_MALLOC);
+# else
_GL_FUNCDECL_SYS (fdopen, FILE *,
(int fd, const char *mode)
- _GL_ARG_NONNULL ((2)) _GL_ATTRIBUTE_DEALLOC (fclose, 1));
+ _GL_ARG_NONNULL ((2)) _GL_ATTRIBUTE_DEALLOC (fclose, 1)
+ _GL_ATTRIBUTE_MALLOC);
+# endif
# endif
# if defined GNULIB_POSIXCHECK
# undef fdopen
@@ -407,7 +514,8 @@ _GL_CXXALIASWARN (fileno);
# endif
_GL_FUNCDECL_RPL (fopen, FILE *,
(const char *restrict filename, const char *restrict mode)
- _GL_ARG_NONNULL ((1, 2)) _GL_ATTRIBUTE_DEALLOC (fclose, 1));
+ _GL_ARG_NONNULL ((1, 2)) _GL_ATTRIBUTE_DEALLOC (fclose, 1)
+ _GL_ATTRIBUTE_MALLOC);
_GL_CXXALIAS_RPL (fopen, FILE *,
(const char *restrict filename, const char *restrict mode));
# else
@@ -882,7 +990,9 @@ _GL_CXXALIAS_SYS (getdelim, ssize_t,
int delimiter,
FILE *restrict stream));
# endif
+# if __GLIBC__ >= 2
_GL_CXXALIASWARN (getdelim);
+# endif
#elif defined GNULIB_POSIXCHECK
# undef getdelim
# if HAVE_RAW_DECL_GETDELIM
@@ -921,7 +1031,7 @@ _GL_CXXALIAS_SYS (getline, ssize_t,
(char **restrict lineptr, size_t *restrict linesize,
FILE *restrict stream));
# endif
-# if @HAVE_DECL_GETLINE@
+# if __GLIBC__ >= 2 && @HAVE_DECL_GETLINE@
_GL_CXXALIASWARN (getline);
# endif
#elif defined GNULIB_POSIXCHECK
@@ -951,9 +1061,17 @@ _GL_WARN_ON_USE (gets, "gets is a security hole - use fgets instead");
# endif
_GL_CXXALIAS_MDA (getw, int, (FILE *restrict stream));
# else
+# if @HAVE_DECL_GETW@
+# if defined __APPLE__ && defined __MACH__
+/* The presence of the declaration depends on _POSIX_C_SOURCE. */
+_GL_FUNCDECL_SYS (getw, int, (FILE *restrict stream));
+# endif
_GL_CXXALIAS_SYS (getw, int, (FILE *restrict stream));
+# endif
# endif
+# if __GLIBC__ >= 2
_GL_CXXALIASWARN (getw);
+# endif
#endif
#if @GNULIB_OBSTACK_PRINTF@ || @GNULIB_OBSTACK_PRINTF_POSIX@
@@ -1052,13 +1170,15 @@ _GL_WARN_ON_USE (perror, "perror is not always POSIX compliant - "
# endif
_GL_FUNCDECL_RPL (popen, FILE *,
(const char *cmd, const char *mode)
- _GL_ARG_NONNULL ((1, 2)) _GL_ATTRIBUTE_DEALLOC (pclose, 1));
+ _GL_ARG_NONNULL ((1, 2)) _GL_ATTRIBUTE_DEALLOC (pclose, 1)
+ _GL_ATTRIBUTE_MALLOC);
_GL_CXXALIAS_RPL (popen, FILE *, (const char *cmd, const char *mode));
# else
# if !@HAVE_POPEN@ || __GNUC__ >= 11
_GL_FUNCDECL_SYS (popen, FILE *,
(const char *cmd, const char *mode)
- _GL_ARG_NONNULL ((1, 2)) _GL_ATTRIBUTE_DEALLOC (pclose, 1));
+ _GL_ARG_NONNULL ((1, 2)) _GL_ATTRIBUTE_DEALLOC (pclose, 1)
+ _GL_ATTRIBUTE_MALLOC);
# endif
_GL_CXXALIAS_SYS (popen, FILE *, (const char *cmd, const char *mode));
# endif
@@ -1068,7 +1188,8 @@ _GL_CXXALIASWARN (popen);
/* For -Wmismatched-dealloc: Associate popen with pclose or rpl_pclose. */
_GL_FUNCDECL_SYS (popen, FILE *,
(const char *cmd, const char *mode)
- _GL_ARG_NONNULL ((1, 2)) _GL_ATTRIBUTE_DEALLOC (pclose, 1));
+ _GL_ARG_NONNULL ((1, 2)) _GL_ATTRIBUTE_DEALLOC (pclose, 1)
+ _GL_ATTRIBUTE_MALLOC);
# endif
# if defined GNULIB_POSIXCHECK
# undef popen
@@ -1190,9 +1311,17 @@ _GL_CXXALIASWARN (puts);
# endif
_GL_CXXALIAS_MDA (putw, int, (int w, FILE *restrict stream));
# else
+# if @HAVE_DECL_PUTW@
+# if defined __APPLE__ && defined __MACH__
+/* The presence of the declaration depends on _POSIX_C_SOURCE. */
+_GL_FUNCDECL_SYS (putw, int, (int w, FILE *restrict stream));
+# endif
_GL_CXXALIAS_SYS (putw, int, (int w, FILE *restrict stream));
+# endif
# endif
+# if __GLIBC__ >= 2
_GL_CXXALIASWARN (putw);
+# endif
#endif
#if @GNULIB_REMOVE@
@@ -1398,13 +1527,15 @@ _GL_CXXALIASWARN (tempnam);
# define tmpfile rpl_tmpfile
# endif
_GL_FUNCDECL_RPL (tmpfile, FILE *, (void)
- _GL_ATTRIBUTE_DEALLOC (fclose, 1));
+ _GL_ATTRIBUTE_DEALLOC (fclose, 1)
+ _GL_ATTRIBUTE_MALLOC);
_GL_CXXALIAS_RPL (tmpfile, FILE *, (void));
# else
# if __GNUC__ >= 11
/* For -Wmismatched-dealloc: Associate tmpfile with fclose or rpl_fclose. */
_GL_FUNCDECL_SYS (tmpfile, FILE *, (void)
- _GL_ATTRIBUTE_DEALLOC (fclose, 1));
+ _GL_ATTRIBUTE_DEALLOC (fclose, 1)
+ _GL_ATTRIBUTE_MALLOC);
# endif
_GL_CXXALIAS_SYS (tmpfile, FILE *, (void));
# endif
@@ -1415,7 +1546,8 @@ _GL_CXXALIASWARN (tmpfile);
# if @GNULIB_FCLOSE@ && __GNUC__ >= 11 && !defined tmpfile
/* For -Wmismatched-dealloc: Associate tmpfile with fclose or rpl_fclose. */
_GL_FUNCDECL_SYS (tmpfile, FILE *, (void)
- _GL_ATTRIBUTE_DEALLOC (fclose, 1));
+ _GL_ATTRIBUTE_DEALLOC (fclose, 1)
+ _GL_ATTRIBUTE_MALLOC);
# endif
# if defined GNULIB_POSIXCHECK
# undef tmpfile
diff --git a/lib/stdlib.in.h b/lib/stdlib.in.h
index 7355ccddd85..b901d175aeb 100644
--- a/lib/stdlib.in.h
+++ b/lib/stdlib.in.h
@@ -1,7 +1,6 @@
/* A GNU-like <stdlib.h>.
- Copyright (C) 1995, 2001-2004, 2006-2024 Free Software Foundation,
- Inc.
+ Copyright (C) 1995, 2001-2004, 2006-2024 Free Software Foundation, Inc.
This file is free software: you can redistribute it and/or modify
it under the terms of the GNU Lesser General Public License as
@@ -38,6 +37,13 @@
#ifndef _@GUARD_PREFIX@_STDLIB_H
#define _@GUARD_PREFIX@_STDLIB_H
+/* This file uses _Noreturn, _GL_ATTRIBUTE_DEALLOC, _GL_ATTRIBUTE_MALLOC,
+ _GL_ATTRIBUTE_NOTHROW, _GL_ATTRIBUTE_PURE, GNULIB_POSIXCHECK,
+ HAVE_RAW_DECL_*. */
+#if !_GL_CONFIG_H_INCLUDED
+ #error "Please include config.h first."
+#endif
+
/* NetBSD 5.0 mis-defines NULL. */
#include <stddef.h>
@@ -68,9 +74,7 @@
# include <random.h>
# endif
-# if !@HAVE_STRUCT_RANDOM_DATA@ || @REPLACE_RANDOM_R@ || !@HAVE_RANDOM_R@
-# include <stdint.h>
-# endif
+# include <stdint.h>
# if !@HAVE_STRUCT_RANDOM_DATA@
/* Define 'struct random_data'.
@@ -129,6 +133,28 @@ struct random_data
# endif
#endif
+/* _GL_ATTRIBUTE_NOTHROW declares that the function does not throw exceptions.
+ */
+#ifndef _GL_ATTRIBUTE_NOTHROW
+# if defined __cplusplus
+# if (__GNUC__ + (__GNUC_MINOR__ >= 8) > 2) || __clang_major >= 4
+# if __cplusplus >= 201103L
+# define _GL_ATTRIBUTE_NOTHROW noexcept (true)
+# else
+# define _GL_ATTRIBUTE_NOTHROW throw ()
+# endif
+# else
+# define _GL_ATTRIBUTE_NOTHROW
+# endif
+# else
+# if (__GNUC__ + (__GNUC_MINOR__ >= 3) > 3) || defined __clang__
+# define _GL_ATTRIBUTE_NOTHROW __attribute__ ((__nothrow__))
+# else
+# define _GL_ATTRIBUTE_NOTHROW
+# endif
+# endif
+#endif
+
/* The __attribute__ feature is available in gcc versions 2.5 and later.
The attribute __pure__ was added in gcc 2.96. */
#ifndef _GL_ATTRIBUTE_PURE
@@ -165,11 +191,22 @@ struct random_data
#if @GNULIB__EXIT@
/* Terminate the current process with the given return code, without running
the 'atexit' handlers. */
-# if !@HAVE__EXIT@
+# if @REPLACE__EXIT@
+# if !(defined __cplusplus && defined GNULIB_NAMESPACE)
+# undef _Exit
+# define _Exit rpl__Exit
+# endif
+_GL_FUNCDECL_RPL (_Exit, _Noreturn void, (int status));
+_GL_CXXALIAS_RPL (_Exit, void, (int status));
+# else
+# if !@HAVE__EXIT@
_GL_FUNCDECL_SYS (_Exit, _Noreturn void, (int status));
-# endif
+# endif
_GL_CXXALIAS_SYS (_Exit, void, (int status));
+# endif
+# if __GLIBC__ >= 2
_GL_CXXALIASWARN (_Exit);
+# endif
#elif defined GNULIB_POSIXCHECK
# undef _Exit
# if HAVE_RAW_DECL__EXIT
@@ -186,7 +223,7 @@ _GL_WARN_ON_USE (_Exit, "_Exit is unportable - "
# define free rpl_free
# endif
# if defined __cplusplus && (__GLIBC__ + (__GLIBC_MINOR__ >= 14) > 2)
-_GL_FUNCDECL_RPL (free, void, (void *ptr) throw ());
+_GL_FUNCDECL_RPL (free, void, (void *ptr) _GL_ATTRIBUTE_NOTHROW);
# else
_GL_FUNCDECL_RPL (free, void, (void *ptr));
# endif
@@ -220,9 +257,16 @@ _GL_CXXALIAS_RPL (aligned_alloc, void *, (size_t alignment, size_t size));
# if @HAVE_ALIGNED_ALLOC@
# if __GNUC__ >= 11
/* For -Wmismatched-dealloc: Associate aligned_alloc with free or rpl_free. */
+# if __GLIBC__ + (__GLIBC_MINOR__ >= 16) > 2
_GL_FUNCDECL_SYS (aligned_alloc, void *,
(size_t alignment, size_t size)
+ _GL_ATTRIBUTE_NOTHROW
_GL_ATTRIBUTE_MALLOC _GL_ATTRIBUTE_DEALLOC_FREE);
+# else
+_GL_FUNCDECL_SYS (aligned_alloc, void *,
+ (size_t alignment, size_t size)
+ _GL_ATTRIBUTE_MALLOC _GL_ATTRIBUTE_DEALLOC_FREE);
+# endif
# endif
_GL_CXXALIAS_SYS (aligned_alloc, void *, (size_t alignment, size_t size));
# endif
@@ -233,9 +277,16 @@ _GL_CXXALIASWARN (aligned_alloc);
#else
# if @GNULIB_FREE_POSIX@ && __GNUC__ >= 11 && !defined aligned_alloc
/* For -Wmismatched-dealloc: Associate aligned_alloc with free or rpl_free. */
+# if __GLIBC__ + (__GLIBC_MINOR__ >= 16) > 2
+_GL_FUNCDECL_SYS (aligned_alloc, void *,
+ (size_t alignment, size_t size)
+ _GL_ATTRIBUTE_NOTHROW
+ _GL_ATTRIBUTE_MALLOC _GL_ATTRIBUTE_DEALLOC_FREE);
+# else
_GL_FUNCDECL_SYS (aligned_alloc, void *,
(size_t alignment, size_t size)
_GL_ATTRIBUTE_MALLOC _GL_ATTRIBUTE_DEALLOC_FREE);
+# endif
# endif
# if defined GNULIB_POSIXCHECK
# undef aligned_alloc
@@ -278,9 +329,16 @@ _GL_CXXALIAS_RPL (calloc, void *, (size_t nmemb, size_t size));
# else
# if __GNUC__ >= 11
/* For -Wmismatched-dealloc: Associate calloc with free or rpl_free. */
+# if __GLIBC__ + (__GLIBC_MINOR__ >= 14) > 2
+_GL_FUNCDECL_SYS (calloc, void *,
+ (size_t nmemb, size_t size)
+ _GL_ATTRIBUTE_NOTHROW
+ _GL_ATTRIBUTE_MALLOC _GL_ATTRIBUTE_DEALLOC_FREE);
+# else
_GL_FUNCDECL_SYS (calloc, void *,
(size_t nmemb, size_t size)
_GL_ATTRIBUTE_MALLOC _GL_ATTRIBUTE_DEALLOC_FREE);
+# endif
# endif
_GL_CXXALIAS_SYS (calloc, void *, (size_t nmemb, size_t size));
# endif
@@ -290,9 +348,16 @@ _GL_CXXALIASWARN (calloc);
#else
# if @GNULIB_FREE_POSIX@ && __GNUC__ >= 11 && !defined calloc
/* For -Wmismatched-dealloc: Associate calloc with free or rpl_free. */
+# if __GLIBC__ + (__GLIBC_MINOR__ >= 14) > 2
+_GL_FUNCDECL_SYS (calloc, void *,
+ (size_t nmemb, size_t size)
+ _GL_ATTRIBUTE_NOTHROW
+ _GL_ATTRIBUTE_MALLOC _GL_ATTRIBUTE_DEALLOC_FREE);
+# else
_GL_FUNCDECL_SYS (calloc, void *,
(size_t nmemb, size_t size)
_GL_ATTRIBUTE_MALLOC _GL_ATTRIBUTE_DEALLOC_FREE);
+# endif
# endif
# if defined GNULIB_POSIXCHECK
# undef calloc
@@ -314,10 +379,18 @@ _GL_FUNCDECL_RPL (canonicalize_file_name, char *,
_GL_CXXALIAS_RPL (canonicalize_file_name, char *, (const char *name));
# else
# if !@HAVE_CANONICALIZE_FILE_NAME@ || __GNUC__ >= 11
+# if __GLIBC__ + (__GLIBC_MINOR__ >= 2) > 2
+_GL_FUNCDECL_SYS (canonicalize_file_name, char *,
+ (const char *name)
+ _GL_ATTRIBUTE_NOTHROW
+ _GL_ARG_NONNULL ((1))
+ _GL_ATTRIBUTE_MALLOC _GL_ATTRIBUTE_DEALLOC_FREE);
+# else
_GL_FUNCDECL_SYS (canonicalize_file_name, char *,
(const char *name)
_GL_ARG_NONNULL ((1))
_GL_ATTRIBUTE_MALLOC _GL_ATTRIBUTE_DEALLOC_FREE);
+# endif
# endif
_GL_CXXALIAS_SYS (canonicalize_file_name, char *, (const char *name));
# endif
@@ -330,10 +403,18 @@ _GL_CXXALIASWARN (canonicalize_file_name);
# if @GNULIB_FREE_POSIX@ && __GNUC__ >= 11 && !defined canonicalize_file_name
/* For -Wmismatched-dealloc: Associate canonicalize_file_name with free or
rpl_free. */
+# if __GLIBC__ + (__GLIBC_MINOR__ >= 2) > 2
+_GL_FUNCDECL_SYS (canonicalize_file_name, char *,
+ (const char *name)
+ _GL_ATTRIBUTE_NOTHROW
+ _GL_ARG_NONNULL ((1))
+ _GL_ATTRIBUTE_MALLOC _GL_ATTRIBUTE_DEALLOC_FREE);
+# else
_GL_FUNCDECL_SYS (canonicalize_file_name, char *,
(const char *name)
_GL_ARG_NONNULL ((1))
_GL_ATTRIBUTE_MALLOC _GL_ATTRIBUTE_DEALLOC_FREE);
+# endif
# endif
# if defined GNULIB_POSIXCHECK
# undef canonicalize_file_name
@@ -417,12 +498,24 @@ _GL_CXXALIASWARN (gcvt);
The three numbers are the load average of the last 1 minute, the last 5
minutes, and the last 15 minutes, respectively.
LOADAVG is an array of NELEM numbers. */
-# if !@HAVE_DECL_GETLOADAVG@
+# if @REPLACE_GETLOADAVG@
+# if !(defined __cplusplus && defined GNULIB_NAMESPACE)
+# undef getloadavg
+# define getloadavg rpl_getloadavg
+# endif
+_GL_FUNCDECL_RPL (getloadavg, int, (double loadavg[], int nelem)
+ _GL_ARG_NONNULL ((1)));
+_GL_CXXALIAS_RPL (getloadavg, int, (double loadavg[], int nelem));
+# else
+# if !@HAVE_DECL_GETLOADAVG@
_GL_FUNCDECL_SYS (getloadavg, int, (double loadavg[], int nelem)
_GL_ARG_NONNULL ((1)));
-# endif
+# endif
_GL_CXXALIAS_SYS (getloadavg, int, (double loadavg[], int nelem));
+# endif
+# if __GLIBC__ >= 2
_GL_CXXALIASWARN (getloadavg);
+# endif
#elif defined GNULIB_POSIXCHECK
# undef getloadavg
# if HAVE_RAW_DECL_GETLOADAVG
@@ -431,6 +524,41 @@ _GL_WARN_ON_USE (getloadavg, "getloadavg is not portable - "
# endif
#endif
+#if @GNULIB_GETPROGNAME@
+/* Return the base name of the executing program.
+ On native Windows this will usually end in ".exe" or ".EXE". */
+# if @REPLACE_GETPROGNAME@
+# if !(defined __cplusplus && defined GNULIB_NAMESPACE)
+# undef getprogname
+# define getprogname rpl_getprogname
+# endif
+# if @HAVE_DECL_PROGRAM_INVOCATION_NAME@
+_GL_FUNCDECL_RPL (getprogname, const char *, (void) _GL_ATTRIBUTE_PURE);
+# else
+_GL_FUNCDECL_RPL (getprogname, const char *, (void));
+# endif
+_GL_CXXALIAS_RPL (getprogname, const char *, (void));
+# else
+# if !@HAVE_GETPROGNAME@
+# if @HAVE_DECL_PROGRAM_INVOCATION_NAME@
+_GL_FUNCDECL_SYS (getprogname, const char *, (void) _GL_ATTRIBUTE_PURE);
+# else
+_GL_FUNCDECL_SYS (getprogname, const char *, (void));
+# endif
+# endif
+_GL_CXXALIAS_SYS (getprogname, const char *, (void));
+# endif
+# if __GLIBC__ >= 2
+_GL_CXXALIASWARN (getprogname);
+# endif
+#elif defined GNULIB_POSIXCHECK
+# undef getprogname
+# if HAVE_RAW_DECL_GETPROGNAME
+_GL_WARN_ON_USE (getprogname, "getprogname is unportable - "
+ "use gnulib module getprogname for portability");
+# endif
+#endif
+
#if @GNULIB_GETSUBOPT@
/* Assuming *OPTIONP is a comma separated list of elements of the form
"token" or "token=value", getsubopt parses the first of these elements.
@@ -443,14 +571,28 @@ _GL_WARN_ON_USE (getloadavg, "getloadavg is not portable - "
Otherwise it returns -1, and *OPTIONP and *VALUEP are undefined.
For more details see the POSIX specification.
https://pubs.opengroup.org/onlinepubs/9699919799/functions/getsubopt.html */
-# if !@HAVE_GETSUBOPT@
+# if @REPLACE_GETSUBOPT@
+# if !(defined __cplusplus && defined GNULIB_NAMESPACE)
+# undef getsubopt
+# define getsubopt rpl_getsubopt
+# endif
+_GL_FUNCDECL_RPL (getsubopt, int,
+ (char **optionp, char *const *tokens, char **valuep)
+ _GL_ARG_NONNULL ((1, 2, 3)));
+_GL_CXXALIAS_RPL (getsubopt, int,
+ (char **optionp, char *const *tokens, char **valuep));
+# else
+# if !@HAVE_GETSUBOPT@
_GL_FUNCDECL_SYS (getsubopt, int,
(char **optionp, char *const *tokens, char **valuep)
_GL_ARG_NONNULL ((1, 2, 3)));
-# endif
+# endif
_GL_CXXALIAS_SYS (getsubopt, int,
(char **optionp, char *const *tokens, char **valuep));
+# endif
+# if __GLIBC__ >= 2
_GL_CXXALIASWARN (getsubopt);
+# endif
#elif defined GNULIB_POSIXCHECK
# undef getsubopt
# if HAVE_RAW_DECL_GETSUBOPT
@@ -494,9 +636,16 @@ _GL_CXXALIAS_RPL (malloc, void *, (size_t size));
# else
# if __GNUC__ >= 11
/* For -Wmismatched-dealloc: Associate malloc with free or rpl_free. */
+# if __GLIBC__ + (__GLIBC_MINOR__ >= 14) > 2
_GL_FUNCDECL_SYS (malloc, void *,
(size_t size)
+ _GL_ATTRIBUTE_NOTHROW
_GL_ATTRIBUTE_MALLOC _GL_ATTRIBUTE_DEALLOC_FREE);
+# else
+_GL_FUNCDECL_SYS (malloc, void *,
+ (size_t size)
+ _GL_ATTRIBUTE_MALLOC _GL_ATTRIBUTE_DEALLOC_FREE);
+# endif
# endif
_GL_CXXALIAS_SYS (malloc, void *, (size_t size));
# endif
@@ -506,9 +655,16 @@ _GL_CXXALIASWARN (malloc);
#else
# if @GNULIB_FREE_POSIX@ && __GNUC__ >= 11 && !defined malloc
/* For -Wmismatched-dealloc: Associate malloc with free or rpl_free. */
+# if __GLIBC__ + (__GLIBC_MINOR__ >= 14) > 2
_GL_FUNCDECL_SYS (malloc, void *,
(size_t size)
+ _GL_ATTRIBUTE_NOTHROW
_GL_ATTRIBUTE_MALLOC _GL_ATTRIBUTE_DEALLOC_FREE);
+# else
+_GL_FUNCDECL_SYS (malloc, void *,
+ (size_t size)
+ _GL_ATTRIBUTE_MALLOC _GL_ATTRIBUTE_DEALLOC_FREE);
+# endif
# endif
# if defined GNULIB_POSIXCHECK && !_GL_USE_STDLIB_ALLOC
# undef malloc
@@ -518,6 +674,51 @@ _GL_WARN_ON_USE (malloc, "malloc is not POSIX compliant everywhere - "
# endif
#endif
+/* Return maximum number of bytes of a multibyte character. */
+#if @REPLACE_MB_CUR_MAX@
+# if !GNULIB_defined_MB_CUR_MAX
+static inline
+int gl_MB_CUR_MAX (void)
+{
+ /* Turn the value 3 to the value 4, as needed for the UTF-8 encoding. */
+ return MB_CUR_MAX + (MB_CUR_MAX == 3);
+}
+# undef MB_CUR_MAX
+# define MB_CUR_MAX gl_MB_CUR_MAX ()
+# define GNULIB_defined_MB_CUR_MAX 1
+# endif
+#endif
+
+/* Convert a string to a wide string. */
+#if @GNULIB_MBSTOWCS@
+# if @REPLACE_MBSTOWCS@
+# if !(defined __cplusplus && defined GNULIB_NAMESPACE)
+# undef mbstowcs
+# define mbstowcs rpl_mbstowcs
+# endif
+_GL_FUNCDECL_RPL (mbstowcs, size_t,
+ (wchar_t *restrict dest, const char *restrict src,
+ size_t len)
+ _GL_ARG_NONNULL ((2)));
+_GL_CXXALIAS_RPL (mbstowcs, size_t,
+ (wchar_t *restrict dest, const char *restrict src,
+ size_t len));
+# else
+_GL_CXXALIAS_SYS (mbstowcs, size_t,
+ (wchar_t *restrict dest, const char *restrict src,
+ size_t len));
+# endif
+# if __GLIBC__ >= 2
+_GL_CXXALIASWARN (mbstowcs);
+# endif
+#elif defined GNULIB_POSIXCHECK
+# undef mbstowcs
+# if HAVE_RAW_DECL_MBSTOWCS
+_GL_WARN_ON_USE (mbstowcs, "mbstowcs is unportable - "
+ "use gnulib module mbstowcs for portability");
+# endif
+#endif
+
/* Convert a multibyte character to a wide character. */
#if @GNULIB_MBTOWC@
# if @REPLACE_MBTOWC@
@@ -580,12 +781,24 @@ _GL_WARN_ON_USE (mkdtemp, "mkdtemp is unportable - "
implementation.
Returns the open file descriptor if successful, otherwise -1 and errno
set. */
-# if !@HAVE_MKOSTEMP@
+# if @REPLACE_MKOSTEMP@
+# if !(defined __cplusplus && defined GNULIB_NAMESPACE)
+# undef mkostemp
+# define mkostemp rpl_mkostemp
+# endif
+_GL_FUNCDECL_RPL (mkostemp, int, (char * /*template*/, int /*flags*/)
+ _GL_ARG_NONNULL ((1)));
+_GL_CXXALIAS_RPL (mkostemp, int, (char * /*template*/, int /*flags*/));
+# else
+# if !@HAVE_MKOSTEMP@
_GL_FUNCDECL_SYS (mkostemp, int, (char * /*template*/, int /*flags*/)
_GL_ARG_NONNULL ((1)));
-# endif
+# endif
_GL_CXXALIAS_SYS (mkostemp, int, (char * /*template*/, int /*flags*/));
+# endif
+# if __GLIBC__ >= 2
_GL_CXXALIASWARN (mkostemp);
+# endif
#elif defined GNULIB_POSIXCHECK
# undef mkostemp
# if HAVE_RAW_DECL_MKOSTEMP
@@ -608,14 +821,28 @@ _GL_WARN_ON_USE (mkostemp, "mkostemp is unportable - "
implementation.
Returns the open file descriptor if successful, otherwise -1 and errno
set. */
-# if !@HAVE_MKOSTEMPS@
+# if @REPLACE_MKOSTEMPS@
+# if !(defined __cplusplus && defined GNULIB_NAMESPACE)
+# undef mkostemps
+# define mkostemps rpl_mkostemps
+# endif
+_GL_FUNCDECL_RPL (mkostemps, int,
+ (char * /*template*/, int /*suffixlen*/, int /*flags*/)
+ _GL_ARG_NONNULL ((1)));
+_GL_CXXALIAS_RPL (mkostemps, int,
+ (char * /*template*/, int /*suffixlen*/, int /*flags*/));
+# else
+# if !@HAVE_MKOSTEMPS@
_GL_FUNCDECL_SYS (mkostemps, int,
(char * /*template*/, int /*suffixlen*/, int /*flags*/)
_GL_ARG_NONNULL ((1)));
-# endif
+# endif
_GL_CXXALIAS_SYS (mkostemps, int,
(char * /*template*/, int /*suffixlen*/, int /*flags*/));
+# endif
+# if __GLIBC__ >= 2
_GL_CXXALIASWARN (mkostemps);
+# endif
#elif defined GNULIB_POSIXCHECK
# undef mkostemps
# if HAVE_RAW_DECL_MKOSTEMPS
@@ -714,7 +941,7 @@ _GL_CXXALIAS_SYS (posix_memalign, int,
(void **memptr, size_t alignment, size_t size));
# endif
# endif
-# if @HAVE_POSIX_MEMALIGN@
+# if __GLIBC__ >= 2 && @HAVE_POSIX_MEMALIGN@
_GL_CXXALIASWARN (posix_memalign);
# endif
#elif defined GNULIB_POSIXCHECK
@@ -728,11 +955,22 @@ _GL_WARN_ON_USE (posix_memalign, "posix_memalign is not portable - "
#if @GNULIB_POSIX_OPENPT@
/* Return an FD open to the master side of a pseudo-terminal. Flags should
include O_RDWR, and may also include O_NOCTTY. */
-# if !@HAVE_POSIX_OPENPT@
+# if @REPLACE_POSIX_OPENPT@
+# if !(defined __cplusplus && defined GNULIB_NAMESPACE)
+# undef posix_openpt
+# define posix_openpt rpl_posix_openpt
+# endif
+_GL_FUNCDECL_RPL (posix_openpt, int, (int flags));
+_GL_CXXALIAS_RPL (posix_openpt, int, (int flags));
+# else
+# if !@HAVE_POSIX_OPENPT@
_GL_FUNCDECL_SYS (posix_openpt, int, (int flags));
-# endif
+# endif
_GL_CXXALIAS_SYS (posix_openpt, int, (int flags));
+# endif
+# if __GLIBC__ >= 2
_GL_CXXALIASWARN (posix_openpt);
+# endif
#elif defined GNULIB_POSIXCHECK
# undef posix_openpt
# if HAVE_RAW_DECL_POSIX_OPENPT
@@ -809,6 +1047,10 @@ _GL_CXXALIAS_RPL (putenv, int, (char *string));
# define putenv _putenv
# endif
_GL_CXXALIAS_MDA (putenv, int, (char *string));
+# elif defined __KLIBC__
+/* Need to cast, because on OS/2 kLIBC, the first parameter is
+ const char *string. */
+_GL_CXXALIAS_SYS_CAST (putenv, int, (char *string));
# else
_GL_CXXALIAS_SYS (putenv, int, (char *string));
# endif
@@ -825,6 +1067,10 @@ _GL_CXXALIASWARN (putenv);
/* Need to cast, because on mingw, the parameter is either
'const char *string' or 'char *string'. */
_GL_CXXALIAS_MDA_CAST (putenv, int, (char *string));
+# elif defined __KLIBC__
+/* Need to cast, because on OS/2 kLIBC, the first parameter is
+ const char *string. */
+_GL_CXXALIAS_SYS_CAST (putenv, int, (char *string));
# else
_GL_CXXALIAS_SYS (putenv, int, (char *string));
# endif
@@ -866,7 +1112,9 @@ _GL_CXXALIAS_SYS (qsort_r, void, (void *base, size_t nmemb, size_t size,
_gl_qsort_r_compar_fn compare,
void *arg));
# endif
+# if __GLIBC__ >= 2
_GL_CXXALIASWARN (qsort_r);
+# endif
#elif defined GNULIB_POSIXCHECK
# undef qsort_r
# if HAVE_RAW_DECL_QSORT_R
@@ -876,11 +1124,26 @@ _GL_WARN_ON_USE (qsort_r, "qsort_r is not portable - "
#endif
-#if @GNULIB_RANDOM_R@
-# if !@HAVE_RANDOM_R@
-# ifndef RAND_MAX
-# define RAND_MAX 2147483647
+#if @GNULIB_RAND@ || (@GNULIB_RANDOM_R@ && !@HAVE_RANDOM_R@)
+# ifndef RAND_MAX
+# define RAND_MAX 2147483647
+# endif
+#endif
+
+
+#if @GNULIB_RAND@
+# if @REPLACE_RAND@
+# if !(defined __cplusplus && defined GNULIB_NAMESPACE)
+# undef rand
+# define rand rpl_rand
# endif
+_GL_FUNCDECL_RPL (rand, int, (void));
+_GL_CXXALIAS_RPL (rand, int, (void));
+# else
+_GL_CXXALIAS_SYS (rand, int, (void));
+# endif
+# if __GLIBC__ >= 2
+_GL_CXXALIASWARN (rand);
# endif
#endif
@@ -901,7 +1164,9 @@ _GL_FUNCDECL_SYS (random, long, (void));
int. */
_GL_CXXALIAS_SYS_CAST (random, long, (void));
# endif
+# if __GLIBC__ >= 2
_GL_CXXALIASWARN (random);
+# endif
#elif defined GNULIB_POSIXCHECK
# undef random
# if HAVE_RAW_DECL_RANDOM
@@ -926,7 +1191,9 @@ _GL_FUNCDECL_SYS (srandom, void, (unsigned int seed));
unsigned long seed. */
_GL_CXXALIAS_SYS_CAST (srandom, void, (unsigned int seed));
# endif
+# if __GLIBC__ >= 2
_GL_CXXALIASWARN (srandom);
+# endif
#elif defined GNULIB_POSIXCHECK
# undef srandom
# if HAVE_RAW_DECL_SRANDOM
@@ -957,7 +1224,9 @@ _GL_FUNCDECL_SYS (initstate, char *,
_GL_CXXALIAS_SYS_CAST (initstate, char *,
(unsigned int seed, char *buf, size_t buf_size));
# endif
+# if __GLIBC__ >= 2
_GL_CXXALIASWARN (initstate);
+# endif
#elif defined GNULIB_POSIXCHECK
# undef initstate
# if HAVE_RAW_DECL_INITSTATE
@@ -982,7 +1251,9 @@ _GL_FUNCDECL_SYS (setstate, char *, (char *arg_state) _GL_ARG_NONNULL ((1)));
is const char *arg_state. */
_GL_CXXALIAS_SYS_CAST (setstate, char *, (char *arg_state));
# endif
+# if __GLIBC__ >= 2
_GL_CXXALIASWARN (setstate);
+# endif
#elif defined GNULIB_POSIXCHECK
# undef setstate
# if HAVE_RAW_DECL_SETSTATE
@@ -1127,8 +1398,16 @@ _GL_CXXALIAS_RPL (realloc, void *, (void *ptr, size_t size));
# else
# if __GNUC__ >= 11
/* For -Wmismatched-dealloc: Associate realloc with free or rpl_free. */
-_GL_FUNCDECL_SYS (realloc, void *, (void *ptr, size_t size)
- _GL_ATTRIBUTE_DEALLOC_FREE);
+# if __GLIBC__ + (__GLIBC_MINOR__ >= 14) > 2
+_GL_FUNCDECL_SYS (realloc, void *,
+ (void *ptr, size_t size)
+ _GL_ATTRIBUTE_NOTHROW
+ _GL_ATTRIBUTE_DEALLOC_FREE);
+# else
+_GL_FUNCDECL_SYS (realloc, void *,
+ (void *ptr, size_t size)
+ _GL_ATTRIBUTE_DEALLOC_FREE);
+# endif
# endif
_GL_CXXALIAS_SYS (realloc, void *, (void *ptr, size_t size));
# endif
@@ -1138,8 +1417,16 @@ _GL_CXXALIASWARN (realloc);
#else
# if @GNULIB_FREE_POSIX@ && __GNUC__ >= 11 && !defined realloc
/* For -Wmismatched-dealloc: Associate realloc with free or rpl_free. */
-_GL_FUNCDECL_SYS (realloc, void *, (void *ptr, size_t size)
- _GL_ATTRIBUTE_DEALLOC_FREE);
+# if __GLIBC__ + (__GLIBC_MINOR__ >= 14) > 2
+_GL_FUNCDECL_SYS (realloc, void *,
+ (void *ptr, size_t size)
+ _GL_ATTRIBUTE_NOTHROW
+ _GL_ATTRIBUTE_DEALLOC_FREE);
+# else
+_GL_FUNCDECL_SYS (realloc, void *,
+ (void *ptr, size_t size)
+ _GL_ATTRIBUTE_DEALLOC_FREE);
+# endif
# endif
# if defined GNULIB_POSIXCHECK && !_GL_USE_STDLIB_ALLOC
# undef realloc
@@ -1168,7 +1455,9 @@ _GL_FUNCDECL_SYS (reallocarray, void *,
_GL_CXXALIAS_SYS (reallocarray, void *,
(void *ptr, size_t nmemb, size_t size));
# endif
+# if __GLIBC__ >= 2
_GL_CXXALIASWARN (reallocarray);
+# endif
#elif defined GNULIB_POSIXCHECK
# undef reallocarray
# if HAVE_RAW_DECL_REALLOCARRAY
diff --git a/lib/strftime.c b/lib/strftime.c
new file mode 100644
index 00000000000..128176cad40
--- /dev/null
+++ b/lib/strftime.c
@@ -0,0 +1,2051 @@
+/* Copyright (C) 1991-2024 Free Software Foundation, Inc.
+ This file is part of the GNU C Library.
+
+ This file is free software: you can redistribute it and/or modify
+ it under the terms of the GNU Lesser General Public License as
+ published by the Free Software Foundation, either version 3 of the
+ License, or (at your option) any later version.
+
+ This file 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 Lesser General Public License for more details.
+
+ You should have received a copy of the GNU Lesser General Public License
+ along with this program. If not, see <https://www.gnu.org/licenses/>. */
+
+#ifndef FPRINTFTIME
+# define FPRINTFTIME 0
+#endif
+
+#ifndef USE_C_LOCALE
+# define USE_C_LOCALE 0
+#endif
+
+#ifdef _LIBC
+# define USE_IN_EXTENDED_LOCALE_MODEL 1
+# define HAVE_STRUCT_ERA_ENTRY 1
+# define HAVE_TM_GMTOFF 1
+# define HAVE_STRUCT_TM_TM_ZONE 1
+# define HAVE_TZNAME 1
+# include "../locale/localeinfo.h"
+#else
+# include <libc-config.h>
+# if FPRINTFTIME
+# include "fprintftime.h"
+# else
+# include "strftime.h"
+# endif
+# include "time-internal.h"
+#endif
+
+/* Whether to require GNU behavior for AM and PM indicators, even on
+ other platforms. This matters only in non-C locales.
+ The default is to require it; you can override this via
+ AC_DEFINE([REQUIRE_GNUISH_STRFTIME_AM_PM], 1) and if you do that
+ you may be able to omit Gnulib's localename module and its dependencies. */
+#ifndef REQUIRE_GNUISH_STRFTIME_AM_PM
+# define REQUIRE_GNUISH_STRFTIME_AM_PM true
+#endif
+#if USE_C_LOCALE
+# undef REQUIRE_GNUISH_STRFTIME_AM_PM
+# define REQUIRE_GNUISH_STRFTIME_AM_PM false
+#endif
+
+#if USE_C_LOCALE
+# include "c-ctype.h"
+#else
+# include <ctype.h>
+#endif
+#include <errno.h>
+#include <time.h>
+
+#if HAVE_TZNAME && !HAVE_DECL_TZNAME
+extern char *tzname[];
+#endif
+
+/* Do multibyte processing if multibyte encodings are supported, unless
+ multibyte sequences are safe in formats. Multibyte sequences are
+ safe if they cannot contain byte sequences that look like format
+ conversion specifications. The multibyte encodings used by the
+ C library on the various platforms (UTF-8, GB2312, GBK, CP936,
+ GB18030, EUC-TW, BIG5, BIG5-HKSCS, CP950, EUC-JP, EUC-KR, CP949,
+ SHIFT_JIS, CP932, JOHAB) are safe for formats, because the byte '%'
+ cannot occur in a multibyte character except in the first byte.
+
+ The DEC-HANYU encoding used on OSF/1 is not safe for formats, but
+ this encoding has never been seen in real-life use, so we ignore
+ it. */
+#if !(defined __osf__ && 0)
+# define MULTIBYTE_IS_FORMAT_SAFE 1
+#endif
+#define DO_MULTIBYTE (! MULTIBYTE_IS_FORMAT_SAFE)
+
+#if DO_MULTIBYTE
+# include <wchar.h>
+ static const mbstate_t mbstate_zero;
+#endif
+
+#include <limits.h>
+#include <stdckdint.h>
+#include <stddef.h>
+#include <stdlib.h>
+#include <string.h>
+
+#if USE_C_LOCALE && HAVE_STRFTIME_L
+# include <locale.h>
+#endif
+
+#if (defined __NetBSD__ || defined __sun) && REQUIRE_GNUISH_STRFTIME_AM_PM
+# include <locale.h>
+# include "localename.h"
+#endif
+
+#include "attribute.h"
+#include <intprops.h>
+
+#ifdef COMPILE_WIDE
+# include <endian.h>
+# define CHAR_T wchar_t
+# define UCHAR_T unsigned int
+# define L_(Str) L##Str
+# define NLW(Sym) _NL_W##Sym
+
+# define MEMCPY(d, s, n) __wmemcpy (d, s, n)
+# define STRLEN(s) __wcslen (s)
+
+#else
+# define CHAR_T char
+# define UCHAR_T unsigned char
+# define L_(Str) Str
+# define NLW(Sym) Sym
+# define ABALTMON_1 _NL_ABALTMON_1
+
+# define MEMCPY(d, s, n) memcpy (d, s, n)
+# define STRLEN(s) strlen (s)
+
+#endif
+
+/* Shift A right by B bits portably, by dividing A by 2**B and
+ truncating towards minus infinity. A and B should be free of side
+ effects, and B should be in the range 0 <= B <= INT_BITS - 2, where
+ INT_BITS is the number of useful bits in an int. GNU code can
+ assume that INT_BITS is at least 32.
+
+ ISO C99 says that A >> B is implementation-defined if A < 0. Some
+ implementations (e.g., UNICOS 9.0 on a Cray Y-MP EL) don't shift
+ right in the usual way when A < 0, so SHR falls back on division if
+ ordinary A >> B doesn't seem to be the usual signed shift. */
+#define SHR(a, b) \
+ (-1 >> 1 == -1 \
+ ? (a) >> (b) \
+ : ((a) + ((a) < 0)) / (1 << (b)) - ((a) < 0))
+
+#define TM_YEAR_BASE 1900
+
+#ifndef __isleap
+/* Nonzero if YEAR is a leap year (every 4 years,
+ except every 100th isn't, and every 400th is). */
+# define __isleap(year) \
+ ((year) % 4 == 0 && ((year) % 100 != 0 || (year) % 400 == 0))
+#endif
+
+
+#ifdef _LIBC
+# define mktime_z(tz, tm) mktime (tm)
+# define tzname __tzname
+# define tzset __tzset
+
+# define time_t __time64_t
+# define __gmtime_r(t, tp) __gmtime64_r (t, tp)
+# define mktime(tp) __mktime64 (tp)
+#endif
+
+#if FPRINTFTIME
+# define STREAM_OR_CHAR_T FILE
+# define STRFTIME_ARG(x) /* empty */
+#else
+# define STREAM_OR_CHAR_T CHAR_T
+# define STRFTIME_ARG(x) x,
+#endif
+
+#if FPRINTFTIME
+# define memset_byte(P, Len, Byte) \
+ do { size_t _i; for (_i = 0; _i < Len; _i++) fputc (Byte, P); } while (0)
+# define memset_space(P, Len) memset_byte (P, Len, ' ')
+# define memset_zero(P, Len) memset_byte (P, Len, '0')
+#elif defined COMPILE_WIDE
+# define memset_space(P, Len) (wmemset (P, L' ', Len), (P) += (Len))
+# define memset_zero(P, Len) (wmemset (P, L'0', Len), (P) += (Len))
+#else
+# define memset_space(P, Len) (memset (P, ' ', Len), (P) += (Len))
+# define memset_zero(P, Len) (memset (P, '0', Len), (P) += (Len))
+#endif
+
+#if FPRINTFTIME
+# define advance(P, N)
+#else
+# define advance(P, N) ((P) += (N))
+#endif
+
+#define add(n, f) width_add (width, n, f)
+#define width_add(width, n, f) \
+ do \
+ { \
+ size_t _n = (n); \
+ size_t _w = pad == L_('-') || width < 0 ? 0 : width; \
+ size_t _incr = _n < _w ? _w : _n; \
+ if (_incr >= maxsize - i) \
+ { \
+ errno = ERANGE; \
+ return 0; \
+ } \
+ if (p) \
+ { \
+ if (_n < _w) \
+ { \
+ size_t _delta = _w - _n; \
+ if (pad == L_('0') || pad == L_('+')) \
+ memset_zero (p, _delta); \
+ else \
+ memset_space (p, _delta); \
+ } \
+ f; \
+ advance (p, _n); \
+ } \
+ i += _incr; \
+ } while (0)
+
+#define add1(c) width_add1 (width, c)
+#if FPRINTFTIME
+# define width_add1(width, c) width_add (width, 1, fputc (c, p))
+#else
+# define width_add1(width, c) width_add (width, 1, *p = c)
+#endif
+
+#define cpy(n, s) width_cpy (width, n, s)
+#if FPRINTFTIME
+# define width_cpy(width, n, s) \
+ width_add (width, n, \
+ do \
+ { \
+ if (to_lowcase) \
+ fwrite_lowcase (p, (s), _n); \
+ else if (to_uppcase) \
+ fwrite_uppcase (p, (s), _n); \
+ else \
+ { \
+ /* Ignore the value of fwrite. The caller can determine whether \
+ an error occurred by inspecting ferror (P). All known fwrite \
+ implementations set the stream's error indicator when they \
+ fail due to ENOMEM etc., even though C11 and POSIX.1-2008 do \
+ not require this. */ \
+ fwrite (s, _n, 1, p); \
+ } \
+ } \
+ while (0) \
+ )
+#else
+# define width_cpy(width, n, s) \
+ width_add (width, n, \
+ if (to_lowcase) \
+ memcpy_lowcase (p, (s), _n LOCALE_ARG); \
+ else if (to_uppcase) \
+ memcpy_uppcase (p, (s), _n LOCALE_ARG); \
+ else \
+ MEMCPY ((void *) p, (void const *) (s), _n))
+#endif
+
+#ifdef COMPILE_WIDE
+# ifndef USE_IN_EXTENDED_LOCALE_MODEL
+# undef __mbsrtowcs_l
+# define __mbsrtowcs_l(d, s, l, st, loc) __mbsrtowcs (d, s, l, st)
+# endif
+#endif
+
+
+#if defined _LIBC && defined USE_IN_EXTENDED_LOCALE_MODEL
+/* We use this code also for the extended locale handling where the
+ function gets as an additional argument the locale which has to be
+ used. To access the values we have to redefine the _NL_CURRENT
+ macro. */
+# define strftime __strftime_l
+# define wcsftime __wcsftime_l
+# undef _NL_CURRENT
+# define _NL_CURRENT(category, item) \
+ (current->values[_NL_ITEM_INDEX (item)].string)
+# define LOCALE_PARAM , locale_t loc
+# define LOCALE_ARG , loc
+# define HELPER_LOCALE_ARG , current
+#else
+# define LOCALE_PARAM
+# define LOCALE_ARG
+# ifdef _LIBC
+# define HELPER_LOCALE_ARG , _NL_CURRENT_DATA (LC_TIME)
+# else
+# define HELPER_LOCALE_ARG
+# endif
+#endif
+
+#ifdef COMPILE_WIDE
+# ifdef USE_IN_EXTENDED_LOCALE_MODEL
+# define TOUPPER(Ch, L) __towupper_l (Ch, L)
+# define TOLOWER(Ch, L) __towlower_l (Ch, L)
+# else
+# define TOUPPER(Ch, L) towupper (Ch)
+# define TOLOWER(Ch, L) towlower (Ch)
+# endif
+#else
+# ifdef USE_IN_EXTENDED_LOCALE_MODEL
+# define TOUPPER(Ch, L) __toupper_l (Ch, L)
+# define TOLOWER(Ch, L) __tolower_l (Ch, L)
+# else
+# if USE_C_LOCALE
+# define TOUPPER(Ch, L) c_toupper (Ch)
+# define TOLOWER(Ch, L) c_tolower (Ch)
+# else
+# define TOUPPER(Ch, L) toupper (Ch)
+# define TOLOWER(Ch, L) tolower (Ch)
+# endif
+# endif
+#endif
+/* We don't use 'isdigit' here since the locale dependent
+ interpretation is not what we want here. We only need to accept
+ the arabic digits in the ASCII range. One day there is perhaps a
+ more reliable way to accept other sets of digits. */
+#define ISDIGIT(Ch) ((unsigned int) (Ch) - L_('0') <= 9)
+
+/* Avoid false GCC warning "'memset' specified size 18446744073709551615 exceeds
+ maximum object size 9223372036854775807", caused by insufficient data flow
+ analysis and value propagation of the 'width_add' expansion when GCC is not
+ optimizing. Cf. <https://gcc.gnu.org/bugzilla/show_bug.cgi?id=88443>. */
+#if __GNUC__ >= 7 && !__OPTIMIZE__
+# pragma GCC diagnostic ignored "-Wstringop-overflow"
+#endif
+
+#if FPRINTFTIME
+static void
+fwrite_lowcase (FILE *fp, const CHAR_T *src, size_t len)
+{
+ while (len-- > 0)
+ {
+ fputc (TOLOWER ((UCHAR_T) *src, loc), fp);
+ ++src;
+ }
+}
+
+static void
+fwrite_uppcase (FILE *fp, const CHAR_T *src, size_t len)
+{
+ while (len-- > 0)
+ {
+ fputc (TOUPPER ((UCHAR_T) *src, loc), fp);
+ ++src;
+ }
+}
+#else
+static CHAR_T *memcpy_lowcase (CHAR_T *dest, const CHAR_T *src,
+ size_t len LOCALE_PARAM);
+
+static CHAR_T *
+memcpy_lowcase (CHAR_T *dest, const CHAR_T *src, size_t len LOCALE_PARAM)
+{
+ while (len-- > 0)
+ dest[len] = TOLOWER ((UCHAR_T) src[len], loc);
+ return dest;
+}
+
+static CHAR_T *memcpy_uppcase (CHAR_T *dest, const CHAR_T *src,
+ size_t len LOCALE_PARAM);
+
+static CHAR_T *
+memcpy_uppcase (CHAR_T *dest, const CHAR_T *src, size_t len LOCALE_PARAM)
+{
+ while (len-- > 0)
+ dest[len] = TOUPPER ((UCHAR_T) src[len], loc);
+ return dest;
+}
+#endif
+
+
+#if USE_C_LOCALE && HAVE_STRFTIME_L
+
+/* Cache for the C locale object.
+ Marked volatile so that different threads see the same value
+ (avoids locking). */
+static volatile locale_t c_locale_cache;
+
+/* Return the C locale object, or (locale_t) 0 with errno set
+ if it cannot be created. */
+static locale_t
+c_locale (void)
+{
+ if (!c_locale_cache)
+ c_locale_cache = newlocale (LC_ALL_MASK, "C", (locale_t) 0);
+ return c_locale_cache;
+}
+
+#endif
+
+
+#if (defined __NetBSD__ || defined __sun) && REQUIRE_GNUISH_STRFTIME_AM_PM
+
+/* Return true if an AM/PM indicator should be removed. */
+static bool
+should_remove_ampm (void)
+{
+ /* According to glibc's 'am_pm' attribute in the locale database, an AM/PM
+ indicator should be absent in the locales for the following languages:
+ ab an ast az be ber bg br bs ce cs csb cv da de dsb eo et eu fa fi fo fr
+ fur fy ga gl gv hr hsb ht hu hy it ka kk kl ku kv kw ky lb lg li lij ln
+ lt lv mg mhr mi mk mn ms mt nb nds nhn nl nn nr nso oc os pap pl pt ro
+ ru rw sah sc se sgs sk sl sm sr ss st su sv szl tg tk tn ts tt ug uk unm
+ uz ve wae wo xh zu */
+ const char *loc = gl_locale_name_unsafe (LC_TIME, "LC_TIME");
+ bool remove_ampm = false;
+ switch (loc[0])
+ {
+ case 'a':
+ switch (loc[1])
+ {
+ case 'b': case 'n': case 'z':
+ if (loc[2] == '\0' || loc[2] == '_')
+ remove_ampm = true;
+ break;
+ case 's':
+ if (loc[2] == 't' && (loc[3] == '\0' || loc[3] == '_'))
+ remove_ampm = true;
+ break;
+ default:
+ break;
+ }
+ break;
+ case 'b':
+ switch (loc[1])
+ {
+ case 'e':
+ if (loc[2] == '\0' || loc[2] == '_'
+ || (loc[2] == 'r' && (loc[3] == '\0' || loc[3] == '_')))
+ remove_ampm = true;
+ break;
+ case 'g': case 'r': case 's':
+ if (loc[2] == '\0' || loc[2] == '_')
+ remove_ampm = true;
+ break;
+ default:
+ break;
+ }
+ break;
+ case 'c':
+ switch (loc[1])
+ {
+ case 'e': case 'v':
+ if (loc[2] == '\0' || loc[2] == '_')
+ remove_ampm = true;
+ break;
+ case 's':
+ if (loc[2] == '\0' || loc[2] == '_'
+ || (loc[2] == 'b' && (loc[3] == '\0' || loc[3] == '_')))
+ remove_ampm = true;
+ break;
+ default:
+ break;
+ }
+ break;
+ case 'd':
+ switch (loc[1])
+ {
+ case 'a': case 'e':
+ if (loc[2] == '\0' || loc[2] == '_')
+ remove_ampm = true;
+ break;
+ case 's':
+ if (loc[2] == 'b' && (loc[3] == '\0' || loc[3] == '_'))
+ remove_ampm = true;
+ break;
+ default:
+ break;
+ }
+ break;
+ case 'e':
+ switch (loc[1])
+ {
+ case 'o': case 't': case 'u':
+ if (loc[2] == '\0' || loc[2] == '_')
+ remove_ampm = true;
+ break;
+ default:
+ break;
+ }
+ break;
+ case 'f':
+ switch (loc[1])
+ {
+ case 'a': case 'i': case 'o': case 'r': case 'y':
+ if (loc[2] == '\0' || loc[2] == '_')
+ remove_ampm = true;
+ break;
+ case 'u':
+ if (loc[2] == 'r' && (loc[3] == '\0' || loc[3] == '_'))
+ remove_ampm = true;
+ break;
+ default:
+ break;
+ }
+ break;
+ case 'g':
+ switch (loc[1])
+ {
+ case 'a': case 'l': case 'v':
+ if (loc[2] == '\0' || loc[2] == '_')
+ remove_ampm = true;
+ break;
+ default:
+ break;
+ }
+ break;
+ case 'h':
+ switch (loc[1])
+ {
+ case 'r': case 't': case 'u': case 'y':
+ if (loc[2] == '\0' || loc[2] == '_')
+ remove_ampm = true;
+ break;
+ case 's':
+ if (loc[2] == 'b' && (loc[3] == '\0' || loc[3] == '_'))
+ remove_ampm = true;
+ break;
+ default:
+ break;
+ }
+ break;
+ case 'i':
+ switch (loc[1])
+ {
+ case 't':
+ if (loc[2] == '\0' || loc[2] == '_')
+ remove_ampm = true;
+ break;
+ default:
+ break;
+ }
+ break;
+ case 'k':
+ switch (loc[1])
+ {
+ case 'a': case 'k': case 'l': case 'u': case 'v': case 'w': case 'y':
+ if (loc[2] == '\0' || loc[2] == '_')
+ remove_ampm = true;
+ break;
+ default:
+ break;
+ }
+ break;
+ case 'l':
+ switch (loc[1])
+ {
+ case 'b': case 'g': case 'n': case 't': case 'v':
+ if (loc[2] == '\0' || loc[2] == '_')
+ remove_ampm = true;
+ break;
+ case 'i':
+ if (loc[2] == 'j' && (loc[3] == '\0' || loc[3] == '_'))
+ remove_ampm = true;
+ break;
+ default:
+ break;
+ }
+ break;
+ case 'm':
+ switch (loc[1])
+ {
+ case 'g': case 'i': case 'k': case 'n': case 's': case 't':
+ if (loc[2] == '\0' || loc[2] == '_')
+ remove_ampm = true;
+ break;
+ case 'h':
+ if (loc[2] == 'r' && (loc[3] == '\0' || loc[3] == '_'))
+ remove_ampm = true;
+ break;
+ default:
+ break;
+ }
+ break;
+ case 'n':
+ switch (loc[1])
+ {
+ case 'b': case 'l': case 'n': case 'r':
+ if (loc[2] == '\0' || loc[2] == '_')
+ remove_ampm = true;
+ break;
+ case 'd':
+ if (loc[2] == 's' && (loc[3] == '\0' || loc[3] == '_'))
+ remove_ampm = true;
+ break;
+ case 'h':
+ if (loc[2] == 'n' && (loc[3] == '\0' || loc[3] == '_'))
+ remove_ampm = true;
+ break;
+ case 's':
+ if (loc[2] == 'o' && (loc[3] == '\0' || loc[3] == '_'))
+ remove_ampm = true;
+ break;
+ default:
+ break;
+ }
+ break;
+ case 'o':
+ switch (loc[1])
+ {
+ case 'c': case 's':
+ if (loc[2] == '\0' || loc[2] == '_')
+ remove_ampm = true;
+ break;
+ default:
+ break;
+ }
+ break;
+ case 'p':
+ switch (loc[1])
+ {
+ case 'l': case 't':
+ if (loc[2] == '\0' || loc[2] == '_')
+ remove_ampm = true;
+ break;
+ case 'a':
+ if (loc[2] == 'p' && (loc[3] == '\0' || loc[3] == '_'))
+ remove_ampm = true;
+ break;
+ default:
+ break;
+ }
+ break;
+ case 'r':
+ switch (loc[1])
+ {
+ case 'o': case 'u': case 'w':
+ if (loc[2] == '\0' || loc[2] == '_')
+ remove_ampm = true;
+ break;
+ default:
+ break;
+ }
+ break;
+ case 's':
+ switch (loc[1])
+ {
+ case 'c': case 'e': case 'k': case 'l': case 'm': case 'r': case 's':
+ case 't': case 'u': case 'v':
+ if (loc[2] == '\0' || loc[2] == '_')
+ remove_ampm = true;
+ break;
+ case 'a':
+ if (loc[2] == 'h' && (loc[3] == '\0' || loc[3] == '_'))
+ remove_ampm = true;
+ break;
+ case 'g':
+ if (loc[2] == 's' && (loc[3] == '\0' || loc[3] == '_'))
+ remove_ampm = true;
+ break;
+ case 'z':
+ if (loc[2] == 'l' && (loc[3] == '\0' || loc[3] == '_'))
+ remove_ampm = true;
+ break;
+ default:
+ break;
+ }
+ break;
+ case 't':
+ switch (loc[1])
+ {
+ case 'g': case 'k': case 'n': case 's': case 't':
+ if (loc[2] == '\0' || loc[2] == '_')
+ remove_ampm = true;
+ break;
+ default:
+ break;
+ }
+ break;
+ case 'u':
+ switch (loc[1])
+ {
+ case 'g': case 'k': case 'z':
+ if (loc[2] == '\0' || loc[2] == '_')
+ remove_ampm = true;
+ break;
+ case 'n':
+ if (loc[2] == 'm'&& (loc[3] == '\0' || loc[3] == '_'))
+ remove_ampm = true;
+ break;
+ default:
+ break;
+ }
+ break;
+ case 'v':
+ switch (loc[1])
+ {
+ case 'e':
+ if (loc[2] == '\0' || loc[2] == '_')
+ remove_ampm = true;
+ break;
+ default:
+ break;
+ }
+ break;
+ case 'w':
+ switch (loc[1])
+ {
+ case 'a':
+ if (loc[2] == 'e' && (loc[3] == '\0' || loc[3] == '_'))
+ remove_ampm = true;
+ break;
+ case 'o':
+ if (loc[2] == '\0' || loc[2] == '_')
+ remove_ampm = true;
+ break;
+ default:
+ break;
+ }
+ break;
+ case 'x':
+ switch (loc[1])
+ {
+ case 'h':
+ if (loc[2] == '\0' || loc[2] == '_')
+ remove_ampm = true;
+ break;
+ default:
+ break;
+ }
+ break;
+ case 'z':
+ switch (loc[1])
+ {
+ case 'u':
+ if (loc[2] == '\0' || loc[2] == '_')
+ remove_ampm = true;
+ break;
+ default:
+ break;
+ }
+ break;
+ default:
+ break;
+ }
+ return remove_ampm;
+}
+
+#endif
+
+
+#if ! HAVE_TM_GMTOFF
+/* Yield the difference between *A and *B,
+ measured in seconds, ignoring leap seconds. */
+# define tm_diff ftime_tm_diff
+static int tm_diff (const struct tm *, const struct tm *);
+static int
+tm_diff (const struct tm *a, const struct tm *b)
+{
+ /* Compute intervening leap days correctly even if year is negative.
+ Take care to avoid int overflow in leap day calculations,
+ but it's OK to assume that A and B are close to each other. */
+ int a4 = SHR (a->tm_year, 2) + SHR (TM_YEAR_BASE, 2) - ! (a->tm_year & 3);
+ int b4 = SHR (b->tm_year, 2) + SHR (TM_YEAR_BASE, 2) - ! (b->tm_year & 3);
+ int a100 = (a4 + (a4 < 0)) / 25 - (a4 < 0);
+ int b100 = (b4 + (b4 < 0)) / 25 - (b4 < 0);
+ int a400 = SHR (a100, 2);
+ int b400 = SHR (b100, 2);
+ int intervening_leap_days = (a4 - b4) - (a100 - b100) + (a400 - b400);
+ int years = a->tm_year - b->tm_year;
+ int days = (365 * years + intervening_leap_days
+ + (a->tm_yday - b->tm_yday));
+ return (60 * (60 * (24 * days + (a->tm_hour - b->tm_hour))
+ + (a->tm_min - b->tm_min))
+ + (a->tm_sec - b->tm_sec));
+}
+#endif /* ! HAVE_TM_GMTOFF */
+
+
+
+/* The number of days from the first day of the first ISO week of this
+ year to the year day YDAY with week day WDAY. ISO weeks start on
+ Monday; the first ISO week has the year's first Thursday. YDAY may
+ be as small as YDAY_MINIMUM. */
+#define ISO_WEEK_START_WDAY 1 /* Monday */
+#define ISO_WEEK1_WDAY 4 /* Thursday */
+#define YDAY_MINIMUM (-366)
+static int iso_week_days (int, int);
+static __inline int
+iso_week_days (int yday, int wday)
+{
+ /* Add enough to the first operand of % to make it nonnegative. */
+ int big_enough_multiple_of_7 = (-YDAY_MINIMUM / 7 + 2) * 7;
+ return (yday
+ - (yday - wday + ISO_WEEK1_WDAY + big_enough_multiple_of_7) % 7
+ + ISO_WEEK1_WDAY - ISO_WEEK_START_WDAY);
+}
+
+
+#if !defined _NL_CURRENT && (USE_C_LOCALE && !HAVE_STRFTIME_L)
+static CHAR_T const c_weekday_names[][sizeof "Wednesday"] =
+ {
+ L_("Sunday"), L_("Monday"), L_("Tuesday"), L_("Wednesday"),
+ L_("Thursday"), L_("Friday"), L_("Saturday")
+ };
+static CHAR_T const c_month_names[][sizeof "September"] =
+ {
+ L_("January"), L_("February"), L_("March"), L_("April"), L_("May"),
+ L_("June"), L_("July"), L_("August"), L_("September"), L_("October"),
+ L_("November"), L_("December")
+ };
+#endif
+
+
+/* When compiling this file, GNU applications can #define my_strftime
+ to a symbol (typically nstrftime) to get an extended strftime with
+ extra arguments TZ and NS. */
+
+#ifdef my_strftime
+# define extra_args , tz, ns
+# define extra_args_spec , timezone_t tz, int ns
+#else
+# if defined COMPILE_WIDE
+# define my_strftime wcsftime
+# define nl_get_alt_digit _nl_get_walt_digit
+# else
+# define my_strftime strftime
+# define nl_get_alt_digit _nl_get_alt_digit
+# endif
+# define extra_args
+# define extra_args_spec
+/* We don't have this information in general. */
+# define tz 1
+# define ns 0
+#endif
+
+static size_t __strftime_internal (STREAM_OR_CHAR_T *, STRFTIME_ARG (size_t)
+ const CHAR_T *, const struct tm *,
+ bool, int, int, bool *
+ extra_args_spec LOCALE_PARAM);
+
+/* Write information from TP into S according to the format
+ string FORMAT, writing no more that MAXSIZE characters
+ (including the terminating '\0') and returning number of
+ characters written. If S is NULL, nothing will be written
+ anywhere, so to determine how many characters would be
+ written, use NULL for S and (size_t) -1 for MAXSIZE. */
+size_t
+my_strftime (STREAM_OR_CHAR_T *s, STRFTIME_ARG (size_t maxsize)
+ const CHAR_T *format,
+ const struct tm *tp extra_args_spec LOCALE_PARAM)
+{
+ bool tzset_called = false;
+ return __strftime_internal (s, STRFTIME_ARG (maxsize) format, tp, false,
+ 0, -1, &tzset_called extra_args LOCALE_ARG);
+}
+libc_hidden_def (my_strftime)
+
+/* Just like my_strftime, above, but with more parameters.
+ UPCASE indicates that the result should be converted to upper case.
+ YR_SPEC and WIDTH specify the padding and width for the year.
+ *TZSET_CALLED indicates whether tzset has been called here. */
+static size_t
+__strftime_internal (STREAM_OR_CHAR_T *s, STRFTIME_ARG (size_t maxsize)
+ const CHAR_T *format,
+ const struct tm *tp, bool upcase,
+ int yr_spec, int width, bool *tzset_called
+ extra_args_spec LOCALE_PARAM)
+{
+#if defined _LIBC && defined USE_IN_EXTENDED_LOCALE_MODEL
+ struct __locale_data *const current = loc->__locales[LC_TIME];
+#endif
+#if FPRINTFTIME
+ size_t maxsize = (size_t) -1;
+#endif
+
+ int saved_errno = errno;
+ int hour12 = tp->tm_hour;
+#ifdef _NL_CURRENT
+ /* We cannot make the following values variables since we must delay
+ the evaluation of these values until really needed since some
+ expressions might not be valid in every situation. The 'struct tm'
+ might be generated by a strptime() call that initialized
+ only a few elements. Dereference the pointers only if the format
+ requires this. Then it is ok to fail if the pointers are invalid. */
+# define a_wkday \
+ ((const CHAR_T *) (tp->tm_wday < 0 || tp->tm_wday > 6 \
+ ? "?" : _NL_CURRENT (LC_TIME, NLW(ABDAY_1) + tp->tm_wday)))
+# define f_wkday \
+ ((const CHAR_T *) (tp->tm_wday < 0 || tp->tm_wday > 6 \
+ ? "?" : _NL_CURRENT (LC_TIME, NLW(DAY_1) + tp->tm_wday)))
+# define a_month \
+ ((const CHAR_T *) (tp->tm_mon < 0 || tp->tm_mon > 11 \
+ ? "?" : _NL_CURRENT (LC_TIME, NLW(ABMON_1) + tp->tm_mon)))
+# define f_month \
+ ((const CHAR_T *) (tp->tm_mon < 0 || tp->tm_mon > 11 \
+ ? "?" : _NL_CURRENT (LC_TIME, NLW(MON_1) + tp->tm_mon)))
+# define a_altmonth \
+ ((const CHAR_T *) (tp->tm_mon < 0 || tp->tm_mon > 11 \
+ ? "?" : _NL_CURRENT (LC_TIME, NLW(ABALTMON_1) + tp->tm_mon)))
+# define f_altmonth \
+ ((const CHAR_T *) (tp->tm_mon < 0 || tp->tm_mon > 11 \
+ ? "?" : _NL_CURRENT (LC_TIME, NLW(ALTMON_1) + tp->tm_mon)))
+# define ampm \
+ ((const CHAR_T *) _NL_CURRENT (LC_TIME, tp->tm_hour > 11 \
+ ? NLW(PM_STR) : NLW(AM_STR)))
+
+# define aw_len STRLEN (a_wkday)
+# define am_len STRLEN (a_month)
+# define aam_len STRLEN (a_altmonth)
+# define ap_len STRLEN (ampm)
+#elif USE_C_LOCALE && !HAVE_STRFTIME_L
+/* The English abbreviated weekday names are just the first 3 characters of the
+ English full weekday names. */
+# define a_wkday \
+ (tp->tm_wday < 0 || tp->tm_wday > 6 ? L_("?") : c_weekday_names[tp->tm_wday])
+# define aw_len 3
+# define f_wkday \
+ (tp->tm_wday < 0 || tp->tm_wday > 6 ? L_("?") : c_weekday_names[tp->tm_wday])
+/* The English abbreviated month names are just the first 3 characters of the
+ English full month names. */
+# define a_month \
+ (tp->tm_mon < 0 || tp->tm_mon > 11 ? L_("?") : c_month_names[tp->tm_mon])
+# define am_len 3
+# define f_month \
+ (tp->tm_mon < 0 || tp->tm_mon > 11 ? L_("?") : c_month_names[tp->tm_mon])
+/* The English AM/PM strings happen to have the same length, namely 2. */
+# define ampm (L_("AMPM") + 2 * (tp->tm_hour > 11))
+# define ap_len 2
+#endif
+#if HAVE_TZNAME
+ char **tzname_vec = tzname;
+#endif
+ const char *zone;
+ size_t i = 0;
+ STREAM_OR_CHAR_T *p = s;
+ const CHAR_T *f;
+#if DO_MULTIBYTE && !defined COMPILE_WIDE
+ const char *format_end = NULL;
+#endif
+
+ zone = NULL;
+#if HAVE_STRUCT_TM_TM_ZONE
+ /* The POSIX test suite assumes that setting
+ the environment variable TZ to a new value before calling strftime()
+ will influence the result (the %Z format) even if the information in
+ TP is computed with a totally different time zone.
+ This is bogus: though POSIX allows bad behavior like this,
+ POSIX does not require it. Do the right thing instead. */
+ zone = (const char *) tp->tm_zone;
+#endif
+#if HAVE_TZNAME
+ if (!tz)
+ {
+ if (! (zone && *zone))
+ zone = "GMT";
+ }
+ else
+ {
+# if !HAVE_STRUCT_TM_TM_ZONE
+ /* Infer the zone name from *TZ instead of from TZNAME. */
+ tzname_vec = tz->tzname_copy;
+# endif
+ }
+ /* The tzset() call might have changed the value. */
+ if (!(zone && *zone) && tp->tm_isdst >= 0)
+ {
+ /* POSIX.1 requires that local time zone information be used as
+ though strftime called tzset. */
+# ifndef my_strftime
+ if (!*tzset_called)
+ {
+ tzset ();
+ *tzset_called = true;
+ }
+# endif
+ zone = tzname_vec[tp->tm_isdst != 0];
+ }
+#endif
+ if (! zone)
+ zone = "";
+
+ if (hour12 > 12)
+ hour12 -= 12;
+ else
+ if (hour12 == 0)
+ hour12 = 12;
+
+ for (f = format; *f != '\0'; width = -1, f++)
+ {
+ int pad = 0; /* Padding for number ('_', '-', '+', '0', or 0). */
+ int modifier; /* Field modifier ('E', 'O', or 0). */
+ int digits = 0; /* Max digits for numeric format. */
+ int number_value; /* Numeric value to be printed. */
+ unsigned int u_number_value; /* (unsigned int) number_value. */
+ bool negative_number; /* The number is negative. */
+ bool always_output_a_sign; /* +/- should always be output. */
+ int tz_colon_mask; /* Bitmask of where ':' should appear. */
+ const CHAR_T *subfmt;
+ CHAR_T *bufp;
+ CHAR_T buf[1
+ + 2 /* for the two colons in a %::z or %:::z time zone */
+ + (sizeof (int) < sizeof (time_t)
+ ? INT_STRLEN_BOUND (time_t)
+ : INT_STRLEN_BOUND (int))];
+ bool to_lowcase = false;
+ bool to_uppcase = upcase;
+ size_t colons;
+ bool change_case = false;
+ int format_char;
+ int subwidth;
+
+#if DO_MULTIBYTE && !defined COMPILE_WIDE
+ switch (*f)
+ {
+ case L_('%'):
+ break;
+
+ case L_('\b'): case L_('\t'): case L_('\n'):
+ case L_('\v'): case L_('\f'): case L_('\r'):
+ case L_(' '): case L_('!'): case L_('"'): case L_('#'): case L_('&'):
+ case L_('\''): case L_('('): case L_(')'): case L_('*'): case L_('+'):
+ case L_(','): case L_('-'): case L_('.'): case L_('/'): case L_('0'):
+ case L_('1'): case L_('2'): case L_('3'): case L_('4'): case L_('5'):
+ case L_('6'): case L_('7'): case L_('8'): case L_('9'): case L_(':'):
+ case L_(';'): case L_('<'): case L_('='): case L_('>'): case L_('?'):
+ case L_('A'): case L_('B'): case L_('C'): case L_('D'): case L_('E'):
+ case L_('F'): case L_('G'): case L_('H'): case L_('I'): case L_('J'):
+ case L_('K'): case L_('L'): case L_('M'): case L_('N'): case L_('O'):
+ case L_('P'): case L_('Q'): case L_('R'): case L_('S'): case L_('T'):
+ case L_('U'): case L_('V'): case L_('W'): case L_('X'): case L_('Y'):
+ case L_('Z'): case L_('['): case L_('\\'): case L_(']'): case L_('^'):
+ case L_('_'): case L_('a'): case L_('b'): case L_('c'): case L_('d'):
+ case L_('e'): case L_('f'): case L_('g'): case L_('h'): case L_('i'):
+ case L_('j'): case L_('k'): case L_('l'): case L_('m'): case L_('n'):
+ case L_('o'): case L_('p'): case L_('q'): case L_('r'): case L_('s'):
+ case L_('t'): case L_('u'): case L_('v'): case L_('w'): case L_('x'):
+ case L_('y'): case L_('z'): case L_('{'): case L_('|'): case L_('}'):
+ case L_('~'):
+ /* The C Standard requires these 98 characters (plus '%') to
+ be in the basic execution character set. None of these
+ characters can start a multibyte sequence, so they need
+ not be analyzed further. */
+ add1 (*f);
+ continue;
+
+ default:
+ /* Copy this multibyte sequence until we reach its end, find
+ an error, or come back to the initial shift state. */
+ {
+ mbstate_t mbstate = mbstate_zero;
+ size_t len = 0;
+ size_t fsize;
+
+ if (! format_end)
+ format_end = f + strlen (f) + 1;
+ fsize = format_end - f;
+
+ do
+ {
+ size_t bytes = mbrlen (f + len, fsize - len, &mbstate);
+
+ if (bytes == 0)
+ break;
+
+ if (bytes == (size_t) -2)
+ {
+ len += strlen (f + len);
+ break;
+ }
+
+ if (bytes == (size_t) -1)
+ {
+ len++;
+ break;
+ }
+
+ len += bytes;
+ }
+ while (! mbsinit (&mbstate));
+
+ cpy (len, f);
+ f += len - 1;
+ continue;
+ }
+ }
+
+#else /* ! DO_MULTIBYTE */
+
+ /* Either multibyte encodings are not supported, they are
+ safe for formats, so any non-'%' byte can be copied through,
+ or this is the wide character version. */
+ if (*f != L_('%'))
+ {
+ add1 (*f);
+ continue;
+ }
+
+#endif /* ! DO_MULTIBYTE */
+
+ char const *percent = f;
+
+ /* Check for flags that can modify a format. */
+ while (1)
+ {
+ switch (*++f)
+ {
+ /* This influences the number formats. */
+ case L_('_'):
+ case L_('-'):
+ case L_('+'):
+ case L_('0'):
+ pad = *f;
+ continue;
+
+ /* This changes textual output. */
+ case L_('^'):
+ to_uppcase = true;
+ continue;
+ case L_('#'):
+ change_case = true;
+ continue;
+
+ default:
+ break;
+ }
+ break;
+ }
+
+ if (ISDIGIT (*f))
+ {
+ width = 0;
+ do
+ {
+ if (ckd_mul (&width, width, 10)
+ || ckd_add (&width, width, *f - L_('0')))
+ width = INT_MAX;
+ ++f;
+ }
+ while (ISDIGIT (*f));
+ }
+
+ /* Check for modifiers. */
+ switch (*f)
+ {
+ case L_('E'):
+ case L_('O'):
+ modifier = *f++;
+ break;
+
+ default:
+ modifier = 0;
+ break;
+ }
+
+ /* Now do the specified format. */
+ format_char = *f;
+ switch (format_char)
+ {
+#define DO_NUMBER(d, v) \
+ do \
+ { \
+ digits = d; \
+ number_value = v; \
+ goto do_number; \
+ } \
+ while (0)
+#define DO_SIGNED_NUMBER(d, negative, v) \
+ DO_MAYBE_SIGNED_NUMBER (d, negative, v, do_signed_number)
+#define DO_YEARISH(d, negative, v) \
+ DO_MAYBE_SIGNED_NUMBER (d, negative, v, do_yearish)
+#define DO_MAYBE_SIGNED_NUMBER(d, negative, v, label) \
+ do \
+ { \
+ digits = d; \
+ negative_number = negative; \
+ u_number_value = v; \
+ goto label; \
+ } \
+ while (0)
+
+ /* The mask is not what you might think.
+ When the ordinal i'th bit is set, insert a colon
+ before the i'th digit of the time zone representation. */
+#define DO_TZ_OFFSET(d, mask, v) \
+ do \
+ { \
+ digits = d; \
+ tz_colon_mask = mask; \
+ u_number_value = v; \
+ goto do_tz_offset; \
+ } \
+ while (0)
+#define DO_NUMBER_SPACEPAD(d, v) \
+ do \
+ { \
+ digits = d; \
+ number_value = v; \
+ goto do_number_spacepad; \
+ } \
+ while (0)
+
+ case L_('%'):
+ if (f - 1 != percent)
+ goto bad_percent;
+ add1 (*f);
+ break;
+
+ case L_('a'):
+ if (modifier != 0)
+ goto bad_format;
+ if (change_case)
+ {
+ to_uppcase = true;
+ to_lowcase = false;
+ }
+#if defined _NL_CURRENT || (USE_C_LOCALE && !HAVE_STRFTIME_L)
+ cpy (aw_len, a_wkday);
+ break;
+#else
+ goto underlying_strftime;
+#endif
+
+ case 'A':
+ if (modifier != 0)
+ goto bad_format;
+ if (change_case)
+ {
+ to_uppcase = true;
+ to_lowcase = false;
+ }
+#if defined _NL_CURRENT || (USE_C_LOCALE && !HAVE_STRFTIME_L)
+ cpy (STRLEN (f_wkday), f_wkday);
+ break;
+#else
+ goto underlying_strftime;
+#endif
+
+ case L_('b'):
+ case L_('h'):
+ if (change_case)
+ {
+ to_uppcase = true;
+ to_lowcase = false;
+ }
+ if (modifier == L_('E'))
+ goto bad_format;
+#ifdef _NL_CURRENT
+ if (modifier == L_('O'))
+ cpy (aam_len, a_altmonth);
+ else
+ cpy (am_len, a_month);
+ break;
+#elif USE_C_LOCALE && !HAVE_STRFTIME_L
+ cpy (am_len, a_month);
+ break;
+#else
+ goto underlying_strftime;
+#endif
+
+ case L_('B'):
+ if (modifier == L_('E'))
+ goto bad_format;
+ if (change_case)
+ {
+ to_uppcase = true;
+ to_lowcase = false;
+ }
+#ifdef _NL_CURRENT
+ if (modifier == L_('O'))
+ cpy (STRLEN (f_altmonth), f_altmonth);
+ else
+ cpy (STRLEN (f_month), f_month);
+ break;
+#elif USE_C_LOCALE && !HAVE_STRFTIME_L
+ cpy (STRLEN (f_month), f_month);
+ break;
+#else
+ goto underlying_strftime;
+#endif
+
+ case L_('c'):
+ if (modifier == L_('O'))
+ goto bad_format;
+#ifdef _NL_CURRENT
+ if (! (modifier == L_('E')
+ && (*(subfmt =
+ (const CHAR_T *) _NL_CURRENT (LC_TIME,
+ NLW(ERA_D_T_FMT)))
+ != '\0')))
+ subfmt = (const CHAR_T *) _NL_CURRENT (LC_TIME, NLW(D_T_FMT));
+#elif USE_C_LOCALE && !HAVE_STRFTIME_L
+ subfmt = L_("%a %b %e %H:%M:%S %Y");
+#else
+ goto underlying_strftime;
+#endif
+
+ subformat:
+ subwidth = -1;
+ subformat_width:
+ {
+ size_t len = __strftime_internal (NULL, STRFTIME_ARG ((size_t) -1)
+ subfmt, tp, to_uppcase,
+ pad, subwidth, tzset_called
+ extra_args LOCALE_ARG);
+ add (len, __strftime_internal (p,
+ STRFTIME_ARG (maxsize - i)
+ subfmt, tp, to_uppcase,
+ pad, subwidth, tzset_called
+ extra_args LOCALE_ARG));
+ }
+ break;
+
+#if !((defined _NL_CURRENT && HAVE_STRUCT_ERA_ENTRY) || (USE_C_LOCALE && !HAVE_STRFTIME_L))
+ underlying_strftime:
+ {
+ /* The relevant information is available only via the
+ underlying strftime implementation, so use that. */
+ char ufmt[5];
+ char *u = ufmt;
+ char ubuf[1024]; /* enough for any single format in practice */
+ size_t len;
+ /* Make sure we're calling the actual underlying strftime.
+ In some cases, config.h contains something like
+ "#define strftime rpl_strftime". */
+# ifdef strftime
+# undef strftime
+ size_t strftime (char *, size_t, const char *, struct tm const *);
+# endif
+
+ /* The space helps distinguish strftime failure from empty
+ output. */
+ *u++ = ' ';
+ *u++ = '%';
+ if (modifier != 0)
+ *u++ = modifier;
+ *u++ = format_char;
+ *u = '\0';
+
+# if USE_C_LOCALE /* implies HAVE_STRFTIME_L */
+ locale_t locale = c_locale ();
+ if (!locale)
+ return 0; /* errno is set here */
+ len = strftime_l (ubuf, sizeof ubuf, ufmt, tp, locale);
+# else
+ len = strftime (ubuf, sizeof ubuf, ufmt, tp);
+# endif
+ if (len != 0)
+ {
+# if defined __NetBSD__ || defined __sun /* NetBSD, Solaris */
+ if (format_char == L_('c'))
+ {
+ /* The output of the strftime %c directive consists of the
+ date, the time, and the time zone. But the time zone is
+ wrong, since neither TZ nor ZONE was passed as argument.
+ Therefore, remove the the last space-delimited word.
+ In order not to accidentally remove a date or a year
+ (that contains no letter) or an AM/PM indicator (that has
+ length 2), remove that last word only if it contains a
+ letter and has length >= 3. */
+ char *space;
+ for (space = ubuf + len - 1; *space != ' '; space--)
+ ;
+ if (space > ubuf)
+ {
+ /* Found a space. */
+ if (strlen (space + 1) >= 3)
+ {
+ /* The last word has length >= 3. */
+ bool found_letter = false;
+ const char *p;
+ for (p = space + 1; *p != '\0'; p++)
+ if ((*p >= 'A' && *p <= 'Z')
+ || (*p >= 'a' && *p <= 'z'))
+ {
+ found_letter = true;
+ break;
+ }
+ if (found_letter)
+ {
+ /* The last word contains a letter. */
+ *space = '\0';
+ len = space - ubuf;
+ }
+ }
+ }
+ }
+# if REQUIRE_GNUISH_STRFTIME_AM_PM
+ /* The output of the strftime %p and %r directives contains
+ an AM/PM indicator even for locales where it is not
+ suitable, such as French. Remove this indicator. */
+ else if (format_char == L_('p'))
+ {
+ bool found_ampm = (len > 1);
+ if (found_ampm && should_remove_ampm ())
+ {
+ ubuf[1] = '\0';
+ len = 1;
+ }
+ }
+ else if (format_char == L_('r'))
+ {
+ char last_char = ubuf[len - 1];
+ bool found_ampm = !(last_char >= '0' && last_char <= '9');
+ if (found_ampm && should_remove_ampm ())
+ {
+ char *space;
+ for (space = ubuf + len - 1; *space != ' '; space--)
+ ;
+ if (space > ubuf)
+ {
+ *space = '\0';
+ len = space - ubuf;
+ }
+ }
+ }
+# endif
+# endif
+ cpy (len - 1, ubuf + 1);
+ }
+ }
+ break;
+#endif
+
+ case L_('C'):
+ if (modifier == L_('E'))
+ {
+#if HAVE_STRUCT_ERA_ENTRY
+ struct era_entry *era = _nl_get_era_entry (tp HELPER_LOCALE_ARG);
+ if (era)
+ {
+# ifdef COMPILE_WIDE
+ size_t len = __wcslen (era->era_wname);
+ cpy (len, era->era_wname);
+# else
+ size_t len = strlen (era->era_name);
+ cpy (len, era->era_name);
+# endif
+ break;
+ }
+#elif USE_C_LOCALE && !HAVE_STRFTIME_L
+#else
+ goto underlying_strftime;
+#endif
+ }
+
+ {
+ bool negative_year = tp->tm_year < - TM_YEAR_BASE;
+ bool zero_thru_1899 = !negative_year & (tp->tm_year < 0);
+ int century = ((tp->tm_year - 99 * zero_thru_1899) / 100
+ + TM_YEAR_BASE / 100);
+ DO_YEARISH (2, negative_year, century);
+ }
+
+ case L_('x'):
+ if (modifier == L_('O'))
+ goto bad_format;
+#ifdef _NL_CURRENT
+ if (! (modifier == L_('E')
+ && (*(subfmt =
+ (const CHAR_T *) _NL_CURRENT (LC_TIME, NLW(ERA_D_FMT)))
+ != L_('\0'))))
+ subfmt = (const CHAR_T *) _NL_CURRENT (LC_TIME, NLW(D_FMT));
+ goto subformat;
+#elif USE_C_LOCALE && !HAVE_STRFTIME_L
+ subfmt = L_("%m/%d/%y");
+ goto subformat;
+#else
+ goto underlying_strftime;
+#endif
+ case L_('D'):
+ if (modifier != 0)
+ goto bad_format;
+ subfmt = L_("%m/%d/%y");
+ goto subformat;
+
+ case L_('d'):
+ if (modifier == L_('E'))
+ goto bad_format;
+
+ DO_NUMBER (2, tp->tm_mday);
+
+ case L_('e'):
+ if (modifier == L_('E'))
+ goto bad_format;
+
+ DO_NUMBER_SPACEPAD (2, tp->tm_mday);
+
+ /* All numeric formats set DIGITS and NUMBER_VALUE (or U_NUMBER_VALUE)
+ and then jump to one of these labels. */
+
+ do_tz_offset:
+ always_output_a_sign = true;
+ goto do_number_body;
+
+ do_yearish:
+ if (pad == 0)
+ pad = yr_spec;
+ always_output_a_sign
+ = (pad == L_('+')
+ && ((digits == 2 ? 99 : 9999) < u_number_value
+ || digits < width));
+ goto do_maybe_signed_number;
+
+ do_number_spacepad:
+ if (pad == 0)
+ pad = L_('_');
+
+ do_number:
+ /* Format NUMBER_VALUE according to the MODIFIER flag. */
+ negative_number = number_value < 0;
+ u_number_value = number_value;
+
+ do_signed_number:
+ always_output_a_sign = false;
+
+ do_maybe_signed_number:
+ tz_colon_mask = 0;
+
+ do_number_body:
+ /* Format U_NUMBER_VALUE according to the MODIFIER flag.
+ NEGATIVE_NUMBER is nonzero if the original number was
+ negative; in this case it was converted directly to
+ unsigned int (i.e., modulo (UINT_MAX + 1)) without
+ negating it. */
+ if (modifier == L_('O') && !negative_number)
+ {
+#ifdef _NL_CURRENT
+ /* Get the locale specific alternate representation of
+ the number. If none exist NULL is returned. */
+ const CHAR_T *cp = nl_get_alt_digit (u_number_value
+ HELPER_LOCALE_ARG);
+
+ if (cp != NULL)
+ {
+ size_t digitlen = STRLEN (cp);
+ if (digitlen != 0)
+ {
+ cpy (digitlen, cp);
+ break;
+ }
+ }
+#elif USE_C_LOCALE && !HAVE_STRFTIME_L
+#else
+ goto underlying_strftime;
+#endif
+ }
+
+ bufp = buf + sizeof (buf) / sizeof (buf[0]);
+
+ if (negative_number)
+ u_number_value = - u_number_value;
+
+ do
+ {
+ if (tz_colon_mask & 1)
+ *--bufp = ':';
+ tz_colon_mask >>= 1;
+ *--bufp = u_number_value % 10 + L_('0');
+ u_number_value /= 10;
+ }
+ while (u_number_value != 0 || tz_colon_mask != 0);
+
+ do_number_sign_and_padding:
+ if (pad == 0)
+ pad = L_('0');
+ if (width < 0)
+ width = digits;
+
+ {
+ CHAR_T sign_char = (negative_number ? L_('-')
+ : always_output_a_sign ? L_('+')
+ : 0);
+ int numlen = buf + sizeof buf / sizeof buf[0] - bufp;
+ int shortage = width - !!sign_char - numlen;
+ int padding = pad == L_('-') || shortage <= 0 ? 0 : shortage;
+
+ if (sign_char)
+ {
+ if (pad == L_('_'))
+ {
+ if (p)
+ memset_space (p, padding);
+ i += padding;
+ width -= padding;
+ }
+ width_add1 (0, sign_char);
+ width--;
+ }
+
+ cpy (numlen, bufp);
+ }
+ break;
+
+ case L_('F'):
+ if (modifier != 0)
+ goto bad_format;
+ if (pad == 0 && width < 0)
+ {
+ pad = L_('+');
+ subwidth = 4;
+ }
+ else
+ {
+ subwidth = width - 6;
+ if (subwidth < 0)
+ subwidth = 0;
+ }
+ subfmt = L_("%Y-%m-%d");
+ goto subformat_width;
+
+ case L_('H'):
+ if (modifier == L_('E'))
+ goto bad_format;
+
+ DO_NUMBER (2, tp->tm_hour);
+
+ case L_('I'):
+ if (modifier == L_('E'))
+ goto bad_format;
+
+ DO_NUMBER (2, hour12);
+
+ case L_('k'): /* GNU extension. */
+ if (modifier == L_('E'))
+ goto bad_format;
+
+ DO_NUMBER_SPACEPAD (2, tp->tm_hour);
+
+ case L_('l'): /* GNU extension. */
+ if (modifier == L_('E'))
+ goto bad_format;
+
+ DO_NUMBER_SPACEPAD (2, hour12);
+
+ case L_('j'):
+ if (modifier == L_('E'))
+ goto bad_format;
+
+ DO_SIGNED_NUMBER (3, tp->tm_yday < -1, tp->tm_yday + 1U);
+
+ case L_('M'):
+ if (modifier == L_('E'))
+ goto bad_format;
+
+ DO_NUMBER (2, tp->tm_min);
+
+ case L_('m'):
+ if (modifier == L_('E'))
+ goto bad_format;
+
+ DO_SIGNED_NUMBER (2, tp->tm_mon < -1, tp->tm_mon + 1U);
+
+#ifndef _LIBC
+ case L_('N'): /* GNU extension. */
+ if (modifier == L_('E'))
+ goto bad_format;
+ {
+ int n = ns, ns_digits = 9;
+ if (width <= 0)
+ width = ns_digits;
+ int ndigs = ns_digits;
+ while (width < ndigs || (1 < ndigs && n % 10 == 0))
+ ndigs--, n /= 10;
+ for (int j = ndigs; 0 < j; j--)
+ buf[j - 1] = n % 10 + L_('0'), n /= 10;
+ if (!pad)
+ pad = L_('0');
+ width_cpy (0, ndigs, buf);
+ width_add (width - ndigs, 0, (void) 0);
+ }
+ break;
+#endif
+
+ case L_('n'):
+ add1 (L_('\n'));
+ break;
+
+ case L_('P'):
+ to_lowcase = true;
+#ifndef _NL_CURRENT
+ format_char = L_('p');
+#endif
+ FALLTHROUGH;
+ case L_('p'):
+ if (change_case)
+ {
+ to_uppcase = false;
+ to_lowcase = true;
+ }
+#if defined _NL_CURRENT || (USE_C_LOCALE && !HAVE_STRFTIME_L)
+ cpy (ap_len, ampm);
+ break;
+#else
+ goto underlying_strftime;
+#endif
+
+ case L_('q'): /* GNU extension. */
+ DO_SIGNED_NUMBER (1, false, ((tp->tm_mon * 11) >> 5) + 1);
+
+ case L_('R'):
+ subfmt = L_("%H:%M");
+ goto subformat;
+
+ case L_('r'):
+#ifdef _NL_CURRENT
+ if (*(subfmt = (const CHAR_T *) _NL_CURRENT (LC_TIME,
+ NLW(T_FMT_AMPM)))
+ == L_('\0'))
+ subfmt = L_("%I:%M:%S %p");
+ goto subformat;
+#elif USE_C_LOCALE && !HAVE_STRFTIME_L
+ subfmt = L_("%I:%M:%S %p");
+ goto subformat;
+#elif (defined __APPLE__ && defined __MACH__) || defined __FreeBSD__
+ /* macOS, FreeBSD strftime() may produce empty output for "%r". */
+ subfmt = L_("%I:%M:%S %p");
+ goto subformat;
+#else
+ goto underlying_strftime;
+#endif
+
+ case L_('S'):
+ if (modifier == L_('E'))
+ goto bad_format;
+
+ DO_NUMBER (2, tp->tm_sec);
+
+ case L_('s'): /* GNU extension. */
+ {
+ struct tm ltm;
+ time_t t;
+
+ ltm = *tp;
+ ltm.tm_yday = -1;
+ t = mktime_z (tz, &ltm);
+ if (ltm.tm_yday < 0)
+ {
+ errno = EOVERFLOW;
+ return 0;
+ }
+
+ /* Generate string value for T using time_t arithmetic;
+ this works even if sizeof (long) < sizeof (time_t). */
+
+ bufp = buf + sizeof (buf) / sizeof (buf[0]);
+ negative_number = t < 0;
+
+ do
+ {
+ int d = t % 10;
+ t /= 10;
+ *--bufp = (negative_number ? -d : d) + L_('0');
+ }
+ while (t != 0);
+
+ digits = 1;
+ always_output_a_sign = false;
+ goto do_number_sign_and_padding;
+ }
+
+ case L_('X'):
+ if (modifier == L_('O'))
+ goto bad_format;
+#ifdef _NL_CURRENT
+ if (! (modifier == L_('E')
+ && (*(subfmt =
+ (const CHAR_T *) _NL_CURRENT (LC_TIME, NLW(ERA_T_FMT)))
+ != L_('\0'))))
+ subfmt = (const CHAR_T *) _NL_CURRENT (LC_TIME, NLW(T_FMT));
+ goto subformat;
+#elif USE_C_LOCALE && !HAVE_STRFTIME_L
+ subfmt = L_("%H:%M:%S");
+ goto subformat;
+#else
+ goto underlying_strftime;
+#endif
+ case L_('T'):
+ subfmt = L_("%H:%M:%S");
+ goto subformat;
+
+ case L_('t'):
+ add1 (L_('\t'));
+ break;
+
+ case L_('u'):
+ DO_NUMBER (1, (tp->tm_wday - 1 + 7) % 7 + 1);
+
+ case L_('U'):
+ if (modifier == L_('E'))
+ goto bad_format;
+
+ DO_NUMBER (2, (tp->tm_yday - tp->tm_wday + 7) / 7);
+
+ case L_('V'):
+ case L_('g'):
+ case L_('G'):
+ if (modifier == L_('E'))
+ goto bad_format;
+ {
+ /* YEAR is a leap year if and only if (tp->tm_year + TM_YEAR_BASE)
+ is a leap year, except that YEAR and YEAR - 1 both work
+ correctly even when (tp->tm_year + TM_YEAR_BASE) would
+ overflow. */
+ int year = (tp->tm_year
+ + (tp->tm_year < 0
+ ? TM_YEAR_BASE % 400
+ : TM_YEAR_BASE % 400 - 400));
+ int year_adjust = 0;
+ int days = iso_week_days (tp->tm_yday, tp->tm_wday);
+
+ if (days < 0)
+ {
+ /* This ISO week belongs to the previous year. */
+ year_adjust = -1;
+ days = iso_week_days (tp->tm_yday + (365 + __isleap (year - 1)),
+ tp->tm_wday);
+ }
+ else
+ {
+ int d = iso_week_days (tp->tm_yday - (365 + __isleap (year)),
+ tp->tm_wday);
+ if (0 <= d)
+ {
+ /* This ISO week belongs to the next year. */
+ year_adjust = 1;
+ days = d;
+ }
+ }
+
+ switch (*f)
+ {
+ case L_('g'):
+ {
+ int yy = (tp->tm_year % 100 + year_adjust) % 100;
+ DO_YEARISH (2, false,
+ (0 <= yy
+ ? yy
+ : tp->tm_year < -TM_YEAR_BASE - year_adjust
+ ? -yy
+ : yy + 100));
+ }
+
+ case L_('G'):
+ DO_YEARISH (4, tp->tm_year < -TM_YEAR_BASE - year_adjust,
+ (tp->tm_year + (unsigned int) TM_YEAR_BASE
+ + year_adjust));
+
+ default:
+ DO_NUMBER (2, days / 7 + 1);
+ }
+ }
+
+ case L_('W'):
+ if (modifier == L_('E'))
+ goto bad_format;
+
+ DO_NUMBER (2, (tp->tm_yday - (tp->tm_wday - 1 + 7) % 7 + 7) / 7);
+
+ case L_('w'):
+ if (modifier == L_('E'))
+ goto bad_format;
+
+ DO_NUMBER (1, tp->tm_wday);
+
+ case L_('Y'):
+ if (modifier == L_('E'))
+ {
+#if HAVE_STRUCT_ERA_ENTRY
+ struct era_entry *era = _nl_get_era_entry (tp HELPER_LOCALE_ARG);
+ if (era)
+ {
+# ifdef COMPILE_WIDE
+ subfmt = era->era_wformat;
+# else
+ subfmt = era->era_format;
+# endif
+ if (pad == 0)
+ pad = yr_spec;
+ goto subformat;
+ }
+#elif USE_C_LOCALE && !HAVE_STRFTIME_L
+#else
+ goto underlying_strftime;
+#endif
+ }
+ if (modifier == L_('O'))
+ goto bad_format;
+
+ DO_YEARISH (4, tp->tm_year < -TM_YEAR_BASE,
+ tp->tm_year + (unsigned int) TM_YEAR_BASE);
+
+ case L_('y'):
+ if (modifier == L_('E'))
+ {
+#if HAVE_STRUCT_ERA_ENTRY
+ struct era_entry *era = _nl_get_era_entry (tp HELPER_LOCALE_ARG);
+ if (era)
+ {
+ int delta = tp->tm_year - era->start_date[0];
+ if (pad == 0)
+ pad = yr_spec;
+ DO_NUMBER (2, (era->offset
+ + delta * era->absolute_direction));
+ }
+#elif USE_C_LOCALE && !HAVE_STRFTIME_L
+#else
+ goto underlying_strftime;
+#endif
+ }
+
+ {
+ int yy = tp->tm_year % 100;
+ if (yy < 0)
+ yy = tp->tm_year < - TM_YEAR_BASE ? -yy : yy + 100;
+ DO_YEARISH (2, false, yy);
+ }
+
+ case L_('Z'):
+ if (change_case)
+ {
+ to_uppcase = false;
+ to_lowcase = true;
+ }
+
+#ifdef COMPILE_WIDE
+ {
+ /* The zone string is always given in multibyte form. We have
+ to convert it to wide character. */
+ size_t w = pad == L_('-') || width < 0 ? 0 : width;
+ char const *z = zone;
+ mbstate_t st = {0};
+ size_t len = __mbsrtowcs_l (p, &z, maxsize - i, &st, loc);
+ if (len == (size_t) -1)
+ return 0;
+ size_t incr = len < w ? w : len;
+ if (incr >= maxsize - i)
+ {
+ errno = ERANGE;
+ return 0;
+ }
+ if (p)
+ {
+ if (len < w)
+ {
+ size_t delta = w - len;
+ __wmemmove (p + delta, p, len);
+ wchar_t wc = pad == L_('0') || pad == L_('+') ? L'0' : L' ';
+ wmemset (p, wc, delta);
+ }
+ p += incr;
+ }
+ i += incr;
+ }
+#else
+ cpy (strlen (zone), zone);
+#endif
+ break;
+
+ case L_(':'):
+ /* :, ::, and ::: are valid only just before 'z'.
+ :::: etc. are rejected later. */
+ for (colons = 1; f[colons] == L_(':'); colons++)
+ continue;
+ if (f[colons] != L_('z'))
+ goto bad_format;
+ f += colons;
+ goto do_z_conversion;
+
+ case L_('z'):
+ colons = 0;
+
+ do_z_conversion:
+ if (tp->tm_isdst < 0)
+ break;
+
+ {
+ int diff;
+ int hour_diff;
+ int min_diff;
+ int sec_diff;
+#if HAVE_TM_GMTOFF
+ diff = tp->tm_gmtoff;
+#else
+ if (!tz)
+ diff = 0;
+ else
+ {
+ struct tm gtm;
+ struct tm ltm;
+ time_t lt;
+
+ /* POSIX.1 requires that local time zone information be used as
+ though strftime called tzset. */
+# ifndef my_strftime
+ if (!*tzset_called)
+ {
+ tzset ();
+ *tzset_called = true;
+ }
+# endif
+
+ ltm = *tp;
+ ltm.tm_wday = -1;
+ lt = mktime_z (tz, &ltm);
+ if (ltm.tm_wday < 0 || ! localtime_rz (0, &lt, &gtm))
+ break;
+ diff = tm_diff (&ltm, &gtm);
+ }
+#endif
+
+ negative_number = diff < 0 || (diff == 0 && *zone == '-');
+ hour_diff = diff / 60 / 60;
+ min_diff = diff / 60 % 60;
+ sec_diff = diff % 60;
+
+ switch (colons)
+ {
+ case 0: /* +hhmm */
+ DO_TZ_OFFSET (5, 0, hour_diff * 100 + min_diff);
+
+ case 1: tz_hh_mm: /* +hh:mm */
+ DO_TZ_OFFSET (6, 04, hour_diff * 100 + min_diff);
+
+ case 2: tz_hh_mm_ss: /* +hh:mm:ss */
+ DO_TZ_OFFSET (9, 024,
+ hour_diff * 10000 + min_diff * 100 + sec_diff);
+
+ case 3: /* +hh if possible, else +hh:mm, else +hh:mm:ss */
+ if (sec_diff != 0)
+ goto tz_hh_mm_ss;
+ if (min_diff != 0)
+ goto tz_hh_mm;
+ DO_TZ_OFFSET (3, 0, hour_diff);
+
+ default:
+ goto bad_format;
+ }
+ }
+
+ case L_('\0'): /* GNU extension: % at end of format. */
+ bad_percent:
+ --f;
+ FALLTHROUGH;
+ default:
+ /* Unknown format; output the format, including the '%',
+ since this is most likely the right thing to do if a
+ multibyte string has been misparsed. */
+ bad_format:
+ cpy (f - percent + 1, percent);
+ break;
+ }
+ }
+
+#if ! FPRINTFTIME
+ if (p && maxsize != 0)
+ *p = L_('\0');
+#endif
+
+ errno = saved_errno;
+ return i;
+}
diff --git a/lib/strftime.h b/lib/strftime.h
index d6efdb848a3..8ce62cdb6d7 100644
--- a/lib/strftime.h
+++ b/lib/strftime.h
@@ -21,17 +21,68 @@
extern "C" {
#endif
-/* Just like strftime, but with two more arguments:
- POSIX requires that strftime use the local timezone information.
- Use the timezone __TZ instead. Use __NS as the number of
- nanoseconds in the %N directive.
-
- On error, set errno and return 0. Otherwise, return the number of
- bytes generated (not counting the trailing NUL), preserving errno
- if the number is 0. This errno behavior is in draft POSIX 202x
- plus some requested changes to POSIX. */
-size_t nstrftime (char *restrict, size_t, char const *, struct tm const *,
- timezone_t __tz, int __ns);
+/* Formats the broken-down time *__TP, with additional __NS nanoseconds,
+ into the buffer __S of size __MAXSIZE, according to the rules of the
+ LC_TIME category of the current locale.
+
+ Uses the time zone __TZ.
+ If *__TP represents local time, __TZ should be set to
+ tzalloc (getenv ("TZ")).
+ If *__TP represents universal time (a.k.a. GMT), __TZ should be set to
+ (timezone_t) 0.
+
+ The format string __FORMAT, including GNU extensions, is described in
+ the GNU libc's strftime() documentation:
+ <https://www.gnu.org/software/libc/manual/html_node/Formatting-Calendar-Time.html>
+ Additionally, the following conversion is supported:
+ %N The number of nanoseconds, passed as __NS argument.
+ Here's a summary of the available conversions (= format directives):
+ literal characters %n %t %%
+ date:
+ century %C
+ year %Y %y
+ week-based year %G %g
+ month (in year) %m %B %b %h
+ week in year %U %W %V
+ day in year %j
+ day (in month) %d %e
+ day in week %u %w %A %a
+ year, month, day %x %F %D
+ time:
+ half-day %p %P
+ hour %H %k %I %l
+ minute (in hour) %M
+ hour, minute %R
+ second (in minute) %S
+ hour, minute, second %r %T %X
+ second (since epoch) %s
+ date and time: %c
+ time zone: %z %Z
+ nanosecond %N
+
+ Stores the result, as a string with a trailing NUL character, at the
+ beginning of the array __S[0..__MAXSIZE-1], if it fits, and returns
+ the length of that string, not counting the trailing NUL. In this case,
+ errno is preserved if the return value is 0.
+ If it does not fit, this function sets errno to ERANGE and returns 0.
+ Upon other errors, this function sets errno and returns 0 as well.
+
+ Note: The errno behavior is in draft POSIX 202x plus some requested
+ changes to POSIX.
+
+ This function is like strftime, but with two more arguments:
+ * __TZ instead of the local timezone information,
+ * __NS as the number of nanoseconds in the %N directive.
+ */
+size_t nstrftime (char *restrict __s, size_t __maxsize,
+ char const *__format,
+ struct tm const *__tp, timezone_t __tz, int __ns);
+
+/* Like nstrftime, except that it uses the "C" locale instead of the
+ current locale. */
+size_t c_nstrftime (char *restrict __s, size_t __maxsize,
+ char const *__format,
+ struct tm const *__tp, timezone_t __tz, int __ns);
#ifdef __cplusplus
}
diff --git a/lib/string.in.h b/lib/string.in.h
index 6550dec08e3..44ec2e7ecdb 100644
--- a/lib/string.in.h
+++ b/lib/string.in.h
@@ -44,6 +44,13 @@
#ifndef _@GUARD_PREFIX@_STRING_H
#define _@GUARD_PREFIX@_STRING_H
+/* This file uses _GL_ATTRIBUTE_DEALLOC, _GL_ATTRIBUTE_MALLOC,
+ _GL_ATTRIBUTE_NOTHROW, _GL_ATTRIBUTE_PURE, GNULIB_POSIXCHECK,
+ HAVE_RAW_DECL_*. */
+#if !_GL_CONFIG_H_INCLUDED
+ #error "Please include config.h first."
+#endif
+
/* NetBSD 5.0 mis-defines NULL. */
#include <stddef.h>
@@ -59,10 +66,11 @@
# include <unistd.h>
#endif
-/* AIX 7.2 declares ffsl and ffsll in <strings.h>, not in <string.h>. */
+/* AIX 7.2 and Android 13 declare ffsl and ffsll in <strings.h>, not in
+ <string.h>. */
/* But in any case avoid namespace pollution on glibc systems. */
#if ((@GNULIB_FFSL@ || @GNULIB_FFSLL@ || defined GNULIB_POSIXCHECK) \
- && defined _AIX) \
+ && (defined _AIX || defined __ANDROID__)) \
&& ! defined __GLIBC__
# include <strings.h>
#endif
@@ -82,7 +90,14 @@
can be freed via 'free'; it can be used only after declaring 'free'. */
/* Applies to: functions. Cannot be used on inline functions. */
#ifndef _GL_ATTRIBUTE_DEALLOC_FREE
-# define _GL_ATTRIBUTE_DEALLOC_FREE _GL_ATTRIBUTE_DEALLOC (free, 1)
+# if defined __cplusplus && defined __GNUC__ && !defined __clang__
+/* Work around GCC bug <https://gcc.gnu.org/bugzilla/show_bug.cgi?id=108231> */
+# define _GL_ATTRIBUTE_DEALLOC_FREE \
+ _GL_ATTRIBUTE_DEALLOC ((void (*) (void *)) free, 1)
+# else
+# define _GL_ATTRIBUTE_DEALLOC_FREE \
+ _GL_ATTRIBUTE_DEALLOC (free, 1)
+# endif
#endif
/* _GL_ATTRIBUTE_MALLOC declares that the function returns a pointer to freshly
@@ -96,6 +111,28 @@
# endif
#endif
+/* _GL_ATTRIBUTE_NOTHROW declares that the function does not throw exceptions.
+ */
+#ifndef _GL_ATTRIBUTE_NOTHROW
+# if defined __cplusplus
+# if (__GNUC__ + (__GNUC_MINOR__ >= 8) > 2) || __clang_major >= 4
+# if __cplusplus >= 201103L
+# define _GL_ATTRIBUTE_NOTHROW noexcept (true)
+# else
+# define _GL_ATTRIBUTE_NOTHROW throw ()
+# endif
+# else
+# define _GL_ATTRIBUTE_NOTHROW
+# endif
+# else
+# if (__GNUC__ + (__GNUC_MINOR__ >= 3) > 3) || defined __clang__
+# define _GL_ATTRIBUTE_NOTHROW __attribute__ ((__nothrow__))
+# else
+# define _GL_ATTRIBUTE_NOTHROW
+# endif
+# endif
+#endif
+
/* The __attribute__ feature is available in gcc versions 2.5 and later.
The attribute __pure__ was added in gcc 2.96. */
#ifndef _GL_ATTRIBUTE_PURE
@@ -118,7 +155,11 @@
# if (@REPLACE_FREE@ && !defined free \
&& !(defined __cplusplus && defined GNULIB_NAMESPACE))
/* We can't do '#define free rpl_free' here. */
+# if defined __cplusplus && (__GLIBC__ + (__GLIBC_MINOR__ >= 14) > 2)
+_GL_EXTERN_C void rpl_free (void *) _GL_ATTRIBUTE_NOTHROW;
+# else
_GL_EXTERN_C void rpl_free (void *);
+# endif
# undef _GL_ATTRIBUTE_DEALLOC_FREE
# define _GL_ATTRIBUTE_DEALLOC_FREE _GL_ATTRIBUTE_DEALLOC (rpl_free, 1)
# else
@@ -130,7 +171,7 @@ _GL_EXTERN_C
void __cdecl free (void *);
# else
# if defined __cplusplus && (__GLIBC__ + (__GLIBC_MINOR__ >= 14) > 2)
-_GL_EXTERN_C void free (void *) throw ();
+_GL_EXTERN_C void free (void *) _GL_ATTRIBUTE_NOTHROW;
# else
_GL_EXTERN_C void free (void *);
# endif
@@ -145,7 +186,7 @@ _GL_EXTERN_C
void __cdecl free (void *);
# else
# if defined __cplusplus && (__GLIBC__ + (__GLIBC_MINOR__ >= 14) > 2)
-_GL_EXTERN_C void free (void *) throw ();
+_GL_EXTERN_C void free (void *) _GL_ATTRIBUTE_NOTHROW;
# else
_GL_EXTERN_C void free (void *);
# endif
@@ -248,9 +289,12 @@ _GL_CXXALIAS_SYS_CAST2 (memchr,
# if ((__GLIBC__ == 2 && __GLIBC_MINOR__ >= 10) && !defined __UCLIBC__) \
&& (__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 *,
+ (void *__s, int __c, size_t __n)
+ _GL_ATTRIBUTE_NOTHROW);
_GL_CXXALIASWARN1 (memchr, void const *,
- (void const *__s, int __c, size_t __n) throw ());
+ (void const *__s, int __c, size_t __n)
+ _GL_ATTRIBUTE_NOTHROW);
# elif __GLIBC__ >= 2
_GL_CXXALIASWARN (memchr);
# endif
@@ -300,16 +344,32 @@ _GL_WARN_ON_USE (memmem, "memmem is unportable and often quadratic - "
/* Copy N bytes of SRC to DEST, return pointer to bytes after the
last written byte. */
#if @GNULIB_MEMPCPY@
-# if ! @HAVE_MEMPCPY@
+# if @REPLACE_MEMPCPY@
+# if !(defined __cplusplus && defined GNULIB_NAMESPACE)
+# undef mempcpy
+# define mempcpy rpl_mempcpy
+# endif
+_GL_FUNCDECL_RPL (mempcpy, void *,
+ (void *restrict __dest, void const *restrict __src,
+ size_t __n)
+ _GL_ARG_NONNULL ((1, 2)));
+_GL_CXXALIAS_RPL (mempcpy, void *,
+ (void *restrict __dest, void const *restrict __src,
+ size_t __n));
+# else
+# if !@HAVE_MEMPCPY@
_GL_FUNCDECL_SYS (mempcpy, void *,
(void *restrict __dest, void const *restrict __src,
size_t __n)
_GL_ARG_NONNULL ((1, 2)));
-# endif
+# endif
_GL_CXXALIAS_SYS (mempcpy, void *,
(void *restrict __dest, void const *restrict __src,
size_t __n));
+# endif
+# if __GLIBC__ >= 2
_GL_CXXALIASWARN (mempcpy);
+# endif
#elif defined GNULIB_POSIXCHECK
# undef mempcpy
# if HAVE_RAW_DECL_MEMPCPY
@@ -334,9 +394,13 @@ _GL_CXXALIAS_SYS_CAST2 (memrchr,
# if ((__GLIBC__ == 2 && __GLIBC_MINOR__ >= 10) && !defined __UCLIBC__) \
&& (__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_CXXALIASWARN1 (memrchr, void *,
+ (void *, int, size_t)
+ _GL_ATTRIBUTE_NOTHROW);
+_GL_CXXALIASWARN1 (memrchr, void const *,
+ (void const *, int, size_t)
+ _GL_ATTRIBUTE_NOTHROW);
+# elif __GLIBC__ >= 2
_GL_CXXALIASWARN (memrchr);
# endif
#elif defined GNULIB_POSIXCHECK
@@ -347,6 +411,33 @@ _GL_WARN_ON_USE (memrchr, "memrchr is unportable - "
# endif
#endif
+/* Overwrite a block of memory. The compiler will not optimize
+ effects away, even if the block is dead after the call. */
+#if @GNULIB_MEMSET_EXPLICIT@
+# if @REPLACE_MEMSET_EXPLICIT@
+# if !(defined __cplusplus && defined GNULIB_NAMESPACE)
+# undef memset_explicit
+# define memset_explicit rpl_memset_explicit
+# endif
+_GL_FUNCDECL_RPL (memset_explicit, void *,
+ (void *__dest, int __c, size_t __n) _GL_ARG_NONNULL ((1)));
+_GL_CXXALIAS_RPL (memset_explicit, void *, (void *__dest, int __c, size_t __n));
+# else
+# if !@HAVE_MEMSET_EXPLICIT@
+_GL_FUNCDECL_SYS (memset_explicit, void *,
+ (void *__dest, int __c, size_t __n) _GL_ARG_NONNULL ((1)));
+# endif
+_GL_CXXALIAS_SYS (memset_explicit, void *, (void *__dest, int __c, size_t __n));
+# endif
+_GL_CXXALIASWARN (memset_explicit);
+#elif defined GNULIB_POSIXCHECK
+# undef memset_explicit
+# if HAVE_RAW_DECL_MEMSET_EXPLICIT
+_GL_WARN_ON_USE (memset_explicit, "memset_explicit is unportable - "
+ "use gnulib module memset_explicit for portability");
+# endif
+#endif
+
/* Find the first occurrence of C in S. More efficient than
memchr(S,C,N), at the expense of undefined behavior if C does not
occur within N bytes. */
@@ -365,9 +456,12 @@ _GL_CXXALIAS_SYS_CAST2 (rawmemchr,
# if ((__GLIBC__ == 2 && __GLIBC_MINOR__ >= 10) && !defined __UCLIBC__) \
&& (__GNUC__ > 4 || (__GNUC__ == 4 && __GNUC_MINOR__ >= 4) \
|| defined __clang__)
-_GL_CXXALIASWARN1 (rawmemchr, void *, (void *__s, int __c_in) throw ());
+_GL_CXXALIASWARN1 (rawmemchr, void *,
+ (void *__s, int __c_in)
+ _GL_ATTRIBUTE_NOTHROW);
_GL_CXXALIASWARN1 (rawmemchr, void const *,
- (void const *__s, int __c_in) throw ());
+ (void const *__s, int __c_in)
+ _GL_ATTRIBUTE_NOTHROW);
# else
_GL_CXXALIASWARN (rawmemchr);
# endif
@@ -381,14 +475,28 @@ _GL_WARN_ON_USE (rawmemchr, "rawmemchr is unportable - "
/* Copy SRC to DST, returning the address of the terminating '\0' in DST. */
#if @GNULIB_STPCPY@
-# if ! @HAVE_STPCPY@
+# if @REPLACE_STPCPY@
+# if !(defined __cplusplus && defined GNULIB_NAMESPACE)
+# undef stpcpy
+# define stpcpy rpl_stpcpy
+# endif
+_GL_FUNCDECL_RPL (stpcpy, char *,
+ (char *restrict __dst, char const *restrict __src)
+ _GL_ARG_NONNULL ((1, 2)));
+_GL_CXXALIAS_RPL (stpcpy, char *,
+ (char *restrict __dst, char const *restrict __src));
+# else
+# if !@HAVE_STPCPY@
_GL_FUNCDECL_SYS (stpcpy, char *,
(char *restrict __dst, char const *restrict __src)
_GL_ARG_NONNULL ((1, 2)));
-# endif
+# endif
_GL_CXXALIAS_SYS (stpcpy, char *,
(char *restrict __dst, char const *restrict __src));
+# endif
+# if __GLIBC__ >= 2
_GL_CXXALIASWARN (stpcpy);
+# endif
#elif defined GNULIB_POSIXCHECK
# undef stpcpy
# if HAVE_RAW_DECL_STPCPY
@@ -423,7 +531,9 @@ _GL_CXXALIAS_SYS (stpncpy, char *,
(char *restrict __dst, char const *restrict __src,
size_t __n));
# endif
+# if __GLIBC__ >= 2
_GL_CXXALIASWARN (stpncpy);
+# endif
#elif defined GNULIB_POSIXCHECK
# undef stpncpy
# if HAVE_RAW_DECL_STPNCPY
@@ -471,10 +581,13 @@ _GL_CXXALIAS_SYS_CAST2 (strchrnul,
# if ((__GLIBC__ == 2 && __GLIBC_MINOR__ >= 10) && !defined __UCLIBC__) \
&& (__GNUC__ > 4 || (__GNUC__ == 4 && __GNUC_MINOR__ >= 4) \
|| defined __clang__)
-_GL_CXXALIASWARN1 (strchrnul, char *, (char *__s, int __c_in) throw ());
+_GL_CXXALIASWARN1 (strchrnul, char *,
+ (char *__s, int __c_in)
+ _GL_ATTRIBUTE_NOTHROW);
_GL_CXXALIASWARN1 (strchrnul, char const *,
- (char const *__s, int __c_in) throw ());
-# else
+ (char const *__s, int __c_in)
+ _GL_ATTRIBUTE_NOTHROW);
+# elif __GLIBC__ >= 2
_GL_CXXALIASWARN (strchrnul);
# endif
#elif defined GNULIB_POSIXCHECK
@@ -509,10 +622,18 @@ _GL_CXXALIAS_MDA (strdup, char *, (char const *__s));
# undef strdup
# endif
# if (!@HAVE_DECL_STRDUP@ || __GNUC__ >= 11) && !defined strdup
+# if __GLIBC__ + (__GLIBC_MINOR__ >= 2) > 2
_GL_FUNCDECL_SYS (strdup, char *,
(char const *__s)
+ _GL_ATTRIBUTE_NOTHROW
_GL_ARG_NONNULL ((1))
_GL_ATTRIBUTE_MALLOC _GL_ATTRIBUTE_DEALLOC_FREE);
+# else
+_GL_FUNCDECL_SYS (strdup, char *,
+ (char const *__s)
+ _GL_ARG_NONNULL ((1))
+ _GL_ATTRIBUTE_MALLOC _GL_ATTRIBUTE_DEALLOC_FREE);
+# endif
# endif
_GL_CXXALIAS_SYS (strdup, char *, (char const *__s));
# endif
@@ -520,10 +641,18 @@ _GL_CXXALIASWARN (strdup);
#else
# if __GNUC__ >= 11 && !defined strdup
/* For -Wmismatched-dealloc: Associate strdup with free or rpl_free. */
+# if __GLIBC__ + (__GLIBC_MINOR__ >= 2) > 2
_GL_FUNCDECL_SYS (strdup, char *,
(char const *__s)
+ _GL_ATTRIBUTE_NOTHROW
_GL_ARG_NONNULL ((1))
_GL_ATTRIBUTE_MALLOC _GL_ATTRIBUTE_DEALLOC_FREE);
+# else
+_GL_FUNCDECL_SYS (strdup, char *,
+ (char const *__s)
+ _GL_ARG_NONNULL ((1))
+ _GL_ATTRIBUTE_MALLOC _GL_ATTRIBUTE_DEALLOC_FREE);
+# endif
# endif
# if defined GNULIB_POSIXCHECK
# undef strdup
@@ -592,10 +721,18 @@ _GL_FUNCDECL_RPL (strndup, char *,
_GL_CXXALIAS_RPL (strndup, char *, (char const *__s, size_t __n));
# else
# if !@HAVE_DECL_STRNDUP@ || (__GNUC__ >= 11 && !defined strndup)
+# if __GLIBC__ + (__GLIBC_MINOR__ >= 2) > 2
_GL_FUNCDECL_SYS (strndup, char *,
(char const *__s, size_t __n)
+ _GL_ATTRIBUTE_NOTHROW
_GL_ARG_NONNULL ((1))
_GL_ATTRIBUTE_MALLOC _GL_ATTRIBUTE_DEALLOC_FREE);
+# else
+_GL_FUNCDECL_SYS (strndup, char *,
+ (char const *__s, size_t __n)
+ _GL_ARG_NONNULL ((1))
+ _GL_ATTRIBUTE_MALLOC _GL_ATTRIBUTE_DEALLOC_FREE);
+# endif
# endif
_GL_CXXALIAS_SYS (strndup, char *, (char const *__s, size_t __n));
# endif
@@ -603,10 +740,18 @@ _GL_CXXALIASWARN (strndup);
#else
# if __GNUC__ >= 11 && !defined strndup
/* For -Wmismatched-dealloc: Associate strndup with free or rpl_free. */
+# if __GLIBC__ + (__GLIBC_MINOR__ >= 2) > 2
+_GL_FUNCDECL_SYS (strndup, char *,
+ (char const *__s, size_t __n)
+ _GL_ATTRIBUTE_NOTHROW
+ _GL_ARG_NONNULL ((1))
+ _GL_ATTRIBUTE_MALLOC _GL_ATTRIBUTE_DEALLOC_FREE);
+# else
_GL_FUNCDECL_SYS (strndup, char *,
(char const *__s, size_t __n)
_GL_ARG_NONNULL ((1))
_GL_ATTRIBUTE_MALLOC _GL_ATTRIBUTE_DEALLOC_FREE);
+# endif
# endif
# if defined GNULIB_POSIXCHECK
# undef strndup
@@ -675,9 +820,12 @@ _GL_CXXALIAS_SYS_CAST2 (strpbrk,
# if ((__GLIBC__ == 2 && __GLIBC_MINOR__ >= 10) && !defined __UCLIBC__) \
&& (__GNUC__ > 4 || (__GNUC__ == 4 && __GNUC_MINOR__ >= 4) \
|| defined __clang__)
-_GL_CXXALIASWARN1 (strpbrk, char *, (char *__s, char const *__accept) throw ());
+_GL_CXXALIASWARN1 (strpbrk, char *,
+ (char *__s, char const *__accept)
+ _GL_ATTRIBUTE_NOTHROW);
_GL_CXXALIASWARN1 (strpbrk, char const *,
- (char const *__s, char const *__accept) throw ());
+ (char const *__s, char const *__accept)
+ _GL_ATTRIBUTE_NOTHROW);
# elif __GLIBC__ >= 2
_GL_CXXALIASWARN (strpbrk);
# endif
@@ -785,9 +933,11 @@ _GL_CXXALIAS_SYS_CAST2 (strstr,
&& (__GNUC__ > 4 || (__GNUC__ == 4 && __GNUC_MINOR__ >= 4) \
|| defined __clang__)
_GL_CXXALIASWARN1 (strstr, char *,
- (char *haystack, const char *needle) throw ());
+ (char *haystack, const char *needle)
+ _GL_ATTRIBUTE_NOTHROW);
_GL_CXXALIASWARN1 (strstr, const char *,
- (const char *haystack, const char *needle) throw ());
+ (const char *haystack, const char *needle)
+ _GL_ATTRIBUTE_NOTHROW);
# elif __GLIBC__ >= 2
_GL_CXXALIASWARN (strstr);
# endif
@@ -836,10 +986,12 @@ _GL_CXXALIAS_SYS_CAST2 (strcasestr,
&& (__GNUC__ > 4 || (__GNUC__ == 4 && __GNUC_MINOR__ >= 4) \
|| defined __clang__)
_GL_CXXALIASWARN1 (strcasestr, char *,
- (char *haystack, const char *needle) throw ());
+ (char *haystack, const char *needle)
+ _GL_ATTRIBUTE_NOTHROW);
_GL_CXXALIASWARN1 (strcasestr, const char *,
- (const char *haystack, const char *needle) throw ());
-# else
+ (const char *haystack, const char *needle)
+ _GL_ATTRIBUTE_NOTHROW);
+# elif __GLIBC__ >= 2
_GL_CXXALIASWARN (strcasestr);
# endif
#elif defined GNULIB_POSIXCHECK
@@ -1187,7 +1339,7 @@ _GL_FUNCDECL_SYS (strerror_r, int, (int errnum, char *buf, size_t buflen)
# endif
_GL_CXXALIAS_SYS (strerror_r, int, (int errnum, char *buf, size_t buflen));
# endif
-# if @HAVE_DECL_STRERROR_R@
+# if __GLIBC__ >= 2 && @HAVE_DECL_STRERROR_R@
_GL_CXXALIASWARN (strerror_r);
# endif
#elif defined GNULIB_POSIXCHECK
@@ -1277,12 +1429,22 @@ _GL_WARN_ON_USE (strsignal, "strsignal is unportable - "
#endif
#if @GNULIB_STRVERSCMP@
-# if !@HAVE_STRVERSCMP@
+# if @REPLACE_STRVERSCMP@
+# if !(defined __cplusplus && defined GNULIB_NAMESPACE)
+# define strverscmp rpl_strverscmp
+# endif
+_GL_FUNCDECL_RPL (strverscmp, int, (const char *, const char *)
+ _GL_ATTRIBUTE_PURE
+ _GL_ARG_NONNULL ((1, 2)));
+_GL_CXXALIAS_RPL (strverscmp, int, (const char *, const char *));
+# else
+# if !@HAVE_STRVERSCMP@
_GL_FUNCDECL_SYS (strverscmp, int, (const char *, const char *)
_GL_ATTRIBUTE_PURE
_GL_ARG_NONNULL ((1, 2)));
-# endif
+# endif
_GL_CXXALIAS_SYS (strverscmp, int, (const char *, const char *));
+# endif
_GL_CXXALIASWARN (strverscmp);
#elif defined GNULIB_POSIXCHECK
# undef strverscmp
diff --git a/lib/strtoimax.c b/lib/strtoimax.c
index be6cd1fb7dd..1bc62621ec5 100644
--- a/lib/strtoimax.c
+++ b/lib/strtoimax.c
@@ -1,7 +1,7 @@
/* Convert string representation of a number into an intmax_t value.
- Copyright (C) 1999, 2001-2004, 2006, 2009-2024 Free Software
- Foundation, Inc.
+ Copyright (C) 1999, 2001-2004, 2006, 2009-2024 Free Software Foundation,
+ Inc.
This file is free software: you can redistribute it and/or modify
it under the terms of the GNU Lesser General Public License as
diff --git a/lib/strtol.c b/lib/strtol.c
index e023277e55e..914cf5b57ab 100644
--- a/lib/strtol.c
+++ b/lib/strtol.c
@@ -1,7 +1,7 @@
/* Convert string representation of a number into an integer value.
- Copyright (C) 1991-1992, 1994-1999, 2003, 2005-2007, 2009-2024 Free
- Software Foundation, Inc.
+ Copyright (C) 1991-1992, 1994-1999, 2003, 2005-2007, 2009-2024 Free Software
+ Foundation, Inc.
NOTE: The canonical source of this file is maintained with the GNU C
Library. Bugs can be reported to bug-glibc@gnu.org.
@@ -288,6 +288,11 @@ INTERNAL (strtol) (const STRING_TYPE *nptr, STRING_TYPE **endptr,
s += 2;
base = 16;
}
+ else if ((base == 0 || base == 2) && TOUPPER (s[1]) == L_('B'))
+ {
+ s += 2;
+ base = 2;
+ }
else if (base == 0)
base = 8;
}
@@ -378,11 +383,14 @@ INTERNAL (strtol) (const STRING_TYPE *nptr, STRING_TYPE **endptr,
noconv:
/* We must handle a special case here: the base is 0 or 16 and the
first two characters are '0' and 'x', but the rest are no
- hexadecimal digits. This is no error case. We return 0 and
- ENDPTR points to the 'x'. */
+ hexadecimal digits. Likewise when the base is 0 or 2 and the
+ first two characters are '0' and 'b', but the rest are no binary
+ digits. This is no error case. We return 0 and ENDPTR points to
+ the 'x' or 'b'. */
if (endptr != NULL)
{
- if (save - nptr >= 2 && TOUPPER (save[-1]) == L_('X')
+ if (save - nptr >= 2
+ && (TOUPPER (save[-1]) == L_('X') || TOUPPER (save[-1]) == L_('B'))
&& save[-2] == L_('0'))
*endptr = (STRING_TYPE *) &save[-1];
else
diff --git a/lib/strtoll.c b/lib/strtoll.c
index 840a03b11e8..d3f5e47fc12 100644
--- a/lib/strtoll.c
+++ b/lib/strtoll.c
@@ -1,6 +1,6 @@
/* Function to parse a 'long long int' from text.
- Copyright (C) 1995-1997, 1999, 2001, 2009-2024 Free Software
- Foundation, Inc.
+ Copyright (C) 1995-1997, 1999, 2001, 2009-2024 Free Software Foundation,
+ Inc.
This file is part of the GNU C Library.
This file is free software: you can redistribute it and/or modify
diff --git a/lib/sys_random.in.h b/lib/sys_random.in.h
index 62508f352b0..22f67b17635 100644
--- a/lib/sys_random.in.h
+++ b/lib/sys_random.in.h
@@ -45,6 +45,11 @@
#ifndef _@GUARD_PREFIX@_SYS_RANDOM_H
#define _@GUARD_PREFIX@_SYS_RANDOM_H
+/* This file uses GNULIB_POSIXCHECK, HAVE_RAW_DECL_*. */
+#if !_GL_CONFIG_H_INCLUDED
+ #error "Please include config.h first."
+#endif
+
#include <sys/types.h>
/* Define the GRND_* constants. */
diff --git a/lib/sys_select.in.h b/lib/sys_select.in.h
index f17d2087ca9..de29c77949a 100644
--- a/lib/sys_select.in.h
+++ b/lib/sys_select.in.h
@@ -19,6 +19,13 @@
# endif
@PRAGMA_COLUMNS@
+/* This file uses #include_next of a system file that defines time_t.
+ For the 'year2038' module to work right, <config.h> needs to have been
+ included before. */
+#if !_GL_CONFIG_H_INCLUDED
+ #error "Please include config.h first."
+#endif
+
/* On OSF/1 and Solaris 2.6, <sys/types.h> and <sys/time.h>
both include <sys/select.h>.
On Cygwin and OpenBSD, <sys/time.h> includes <sys/select.h>.
@@ -71,6 +78,11 @@
#ifndef _@GUARD_PREFIX@_SYS_SELECT_H
+/* This file uses GNULIB_POSIXCHECK, HAVE_RAW_DECL_*. */
+#if !_GL_CONFIG_H_INCLUDED
+ #error "Please include config.h first."
+#endif
+
/* On many platforms, <sys/select.h> assumes prior inclusion of
<sys/types.h>. Also, mingw defines sigset_t there, instead of
in <signal.h> where it belongs. */
diff --git a/lib/sys_stat.in.h b/lib/sys_stat.in.h
index 61317602344..bf08f33536d 100644
--- a/lib/sys_stat.in.h
+++ b/lib/sys_stat.in.h
@@ -25,6 +25,13 @@
#endif
@PRAGMA_COLUMNS@
+/* This file uses #include_next of a system file that defines time_t.
+ For the 'year2038' module to work right, <config.h> needs to have been
+ included before. */
+#if !_GL_CONFIG_H_INCLUDED
+ #error "Please include config.h first."
+#endif
+
#if defined __need_system_sys_stat_h
/* Special invocation convention. */
@@ -48,12 +55,41 @@
#ifndef _@GUARD_PREFIX@_SYS_STAT_H
#define _@GUARD_PREFIX@_SYS_STAT_H
+/* This file uses _GL_ATTRIBUTE_NOTHROW, GNULIB_POSIXCHECK, HAVE_RAW_DECL_*. */
+#if !_GL_CONFIG_H_INCLUDED
+ #error "Please include config.h first."
+#endif
+
+
+/* _GL_ATTRIBUTE_NOTHROW declares that the function does not throw exceptions.
+ */
+#ifndef _GL_ATTRIBUTE_NOTHROW
+# if defined __cplusplus
+# if (__GNUC__ + (__GNUC_MINOR__ >= 8) > 2) || __clang_major >= 4
+# if __cplusplus >= 201103L
+# define _GL_ATTRIBUTE_NOTHROW noexcept (true)
+# else
+# define _GL_ATTRIBUTE_NOTHROW throw ()
+# endif
+# else
+# define _GL_ATTRIBUTE_NOTHROW
+# endif
+# else
+# if (__GNUC__ + (__GNUC_MINOR__ >= 3) > 3) || defined __clang__
+# define _GL_ATTRIBUTE_NOTHROW __attribute__ ((__nothrow__))
+# else
+# define _GL_ATTRIBUTE_NOTHROW
+# endif
+# endif
+#endif
+
/* The definitions of _GL_FUNCDECL_RPL etc. are copied here. */
/* The definition of _GL_ARG_NONNULL is copied here. */
/* The definition of _GL_WARN_ON_USE is copied here. */
+
/* Before doing "#define mknod rpl_mknod" below, we need to include all
headers that may declare mknod(). OS/2 kLIBC declares mknod() in
<unistd.h>, not in <sys/stat.h>. */
@@ -549,7 +585,7 @@ _GL_FUNCDECL_SYS (futimens, int, (int fd, struct timespec const times[2]));
# endif
_GL_CXXALIAS_SYS (futimens, int, (int fd, struct timespec const times[2]));
# endif
-# if @HAVE_FUTIMENS@
+# if __GLIBC__ >= 2 && @HAVE_FUTIMENS@
_GL_CXXALIASWARN (futimens);
# endif
#elif defined GNULIB_POSIXCHECK
@@ -563,7 +599,11 @@ _GL_WARN_ON_USE (futimens, "futimens is not portable - "
#if @GNULIB_GETUMASK@
# if !@HAVE_GETUMASK@
+# if __GLIBC__ + (__GLIBC_MINOR__ >= 2) > 2
+_GL_FUNCDECL_SYS (getumask, mode_t, (void) _GL_ATTRIBUTE_NOTHROW);
+# else
_GL_FUNCDECL_SYS (getumask, mode_t, (void));
+# endif
# endif
_GL_CXXALIAS_SYS (getumask, mode_t, (void));
# if @HAVE_GETUMASK@
@@ -716,7 +756,9 @@ _GL_FUNCDECL_SYS (mkfifoat, int, (int fd, char const *file, mode_t mode)
# endif
_GL_CXXALIAS_SYS (mkfifoat, int, (int fd, char const *file, mode_t mode));
# endif
+# if __GLIBC__ >= 2
_GL_CXXALIASWARN (mkfifoat);
+# endif
#elif defined GNULIB_POSIXCHECK
# undef mkfifoat
# if HAVE_RAW_DECL_MKFIFOAT
@@ -773,7 +815,9 @@ _GL_FUNCDECL_SYS (mknodat, int,
_GL_CXXALIAS_SYS (mknodat, int,
(int fd, char const *file, mode_t mode, dev_t dev));
# endif
+# if __GLIBC__ >= 2
_GL_CXXALIASWARN (mknodat);
+# endif
#elif defined GNULIB_POSIXCHECK
# undef mknodat
# if HAVE_RAW_DECL_MKNODAT
@@ -937,7 +981,7 @@ _GL_FUNCDECL_SYS (utimensat, int, (int fd, char const *name,
_GL_CXXALIAS_SYS (utimensat, int, (int fd, char const *name,
struct timespec const times[2], int flag));
# endif
-# if @HAVE_UTIMENSAT@
+# if __GLIBC__ >= 2 && @HAVE_UTIMENSAT@
_GL_CXXALIASWARN (utimensat);
# endif
#elif defined GNULIB_POSIXCHECK
diff --git a/lib/sys_time.in.h b/lib/sys_time.in.h
index fda89d7b904..4a301c48ba1 100644
--- a/lib/sys_time.in.h
+++ b/lib/sys_time.in.h
@@ -24,6 +24,13 @@
#endif
@PRAGMA_COLUMNS@
+/* This file uses #include_next of a system file that defines time_t.
+ For the 'year2038' module to work right, <config.h> needs to have been
+ included before. */
+#if !_GL_CONFIG_H_INCLUDED
+ #error "Please include config.h first."
+#endif
+
/* On Cygwin and on many BSDish systems, <sys/time.h> includes itself
recursively via <sys/select.h>.
Simply delegate to the system's header in this case; it is a no-op.
@@ -41,6 +48,11 @@
#ifndef _@GUARD_PREFIX@_SYS_TIME_H
#define _@GUARD_PREFIX@_SYS_TIME_H
+/* This file uses GNULIB_POSIXCHECK, HAVE_RAW_DECL_*. */
+#if !_GL_CONFIG_H_INCLUDED
+ #error "Please include config.h first."
+#endif
+
#if ! @HAVE_SYS_TIME_H@
# include <time.h>
#endif
diff --git a/lib/sys_types.in.h b/lib/sys_types.in.h
index d1d240be0a8..0a0ccc3c379 100644
--- a/lib/sys_types.in.h
+++ b/lib/sys_types.in.h
@@ -20,6 +20,13 @@
#endif
@PRAGMA_COLUMNS@
+/* This file uses #include_next of a system file that defines time_t.
+ For the 'year2038' module to work right, <config.h> needs to have been
+ included before. */
+#if !_GL_CONFIG_H_INCLUDED
+ #error "Please include config.h first."
+#endif
+
#if defined _WIN32 && !defined __CYGWIN__ \
&& (defined __need_off_t || defined __need___off64_t \
|| defined __need_ssize_t || defined __need_time_t)
diff --git a/lib/tempname.c b/lib/tempname.c
index fec5f7b29d6..446ddeaef19 100644
--- a/lib/tempname.c
+++ b/lib/tempname.c
@@ -193,7 +193,7 @@ try_tempname_len (char *tmpl, int suffixlen, void *args,
char *XXXXXX;
unsigned int count;
int fd = -1;
- int save_errno = errno;
+ int saved_errno = errno;
/* A lower bound on the number of temporary files to attempt to
generate. The maximum total number of temporary file names that
@@ -258,7 +258,7 @@ try_tempname_len (char *tmpl, int suffixlen, void *args,
fd = tryfunc (tmpl, args);
if (fd >= 0)
{
- __set_errno (save_errno);
+ __set_errno (saved_errno);
return fd;
}
else if (errno != EEXIST)
diff --git a/lib/time.in.h b/lib/time.in.h
index f6c3315d3a8..df99c8abca9 100644
--- a/lib/time.in.h
+++ b/lib/time.in.h
@@ -20,6 +20,13 @@
#endif
@PRAGMA_COLUMNS@
+/* This file uses #include_next of a system file that defines time_t.
+ For the 'year2038' module to work right, <config.h> needs to have been
+ included before. */
+#if !_GL_CONFIG_H_INCLUDED
+ #error "Please include config.h first."
+#endif
+
/* Don't get in the way of glibc when it includes time.h merely to
declare a few standard symbols, rather than to declare all the
symbols. (However, skip this for MinGW as it treats __need_time_t
@@ -45,6 +52,12 @@
# @INCLUDE_NEXT@ @NEXT_TIME_H@
+/* This file uses _GL_ATTRIBUTE_DEPRECATED, GNULIB_POSIXCHECK,
+ HAVE_RAW_DECL_*. */
+# if !_GL_CONFIG_H_INCLUDED
+# error "Please include config.h first."
+# endif
+
/* NetBSD 5.0 mis-defines NULL. */
# include <stddef.h>
@@ -112,23 +125,79 @@ struct __time_t_must_be_integral {
/* Set *TS to the current time, and return BASE.
Upon failure, return 0. */
# if @GNULIB_TIMESPEC_GET@
-# if ! @HAVE_TIMESPEC_GET@
+# if @REPLACE_TIMESPEC_GET@
+# if !(defined __cplusplus && defined GNULIB_NAMESPACE)
+# undef timespec_get
+# define timespec_get rpl_timespec_get
+# endif
+_GL_FUNCDECL_RPL (timespec_get, int, (struct timespec *ts, int base)
+ _GL_ARG_NONNULL ((1)));
+_GL_CXXALIAS_RPL (timespec_get, int, (struct timespec *ts, int base));
+# else
+# if !@HAVE_TIMESPEC_GET@
_GL_FUNCDECL_SYS (timespec_get, int, (struct timespec *ts, int base)
_GL_ARG_NONNULL ((1)));
-# endif
+# endif
_GL_CXXALIAS_SYS (timespec_get, int, (struct timespec *ts, int base));
+# endif
+# if __GLIBC__ >= 2
_GL_CXXALIASWARN (timespec_get);
+# endif
+# elif defined GNULIB_POSIXCHECK
+# undef timespec_get
+# if HAVE_RAW_DECL_TIMESPEC_GET
+_GL_WARN_ON_USE (timespec_get, "timespec_get is unportable - "
+ "use gnulib module timespec_get for portability");
+# endif
# endif
/* Set *TS to the current time resolution, and return BASE.
Upon failure, return 0. */
# if @GNULIB_TIMESPEC_GETRES@
-# if ! @HAVE_TIMESPEC_GETRES@
+# if @REPLACE_TIMESPEC_GETRES@
+# if !(defined __cplusplus && defined GNULIB_NAMESPACE)
+# undef timespec_getres
+# define timespec_getres rpl_timespec_getres
+# endif
+_GL_FUNCDECL_RPL (timespec_getres, int, (struct timespec *ts, int base)
+ _GL_ARG_NONNULL ((1)));
+_GL_CXXALIAS_RPL (timespec_getres, int, (struct timespec *ts, int base));
+# else
+# if !@HAVE_TIMESPEC_GETRES@
_GL_FUNCDECL_SYS (timespec_getres, int, (struct timespec *ts, int base)
_GL_ARG_NONNULL ((1)));
-# endif
+# endif
_GL_CXXALIAS_SYS (timespec_getres, int, (struct timespec *ts, int base));
+# endif
_GL_CXXALIASWARN (timespec_getres);
+# elif defined GNULIB_POSIXCHECK
+# undef timespec_getres
+# if HAVE_RAW_DECL_TIMESPEC_GETRES
+_GL_WARN_ON_USE (timespec_getres, "timespec_getres is unportable - "
+ "use gnulib module timespec_getres for portability");
+# endif
+# endif
+
+/* Return the number of seconds that have elapsed since the Epoch. */
+# if @GNULIB_TIME@
+# if @REPLACE_TIME@
+# if !(defined __cplusplus && defined GNULIB_NAMESPACE)
+# define time rpl_time
+# endif
+_GL_FUNCDECL_RPL (time, time_t, (time_t *__tp));
+_GL_CXXALIAS_RPL (time, time_t, (time_t *__tp));
+# else
+_GL_CXXALIAS_SYS (time, time_t, (time_t *__tp));
+# endif
+# if __GLIBC__ >= 2
+_GL_CXXALIASWARN (time);
+# endif
+# elif defined GNULIB_POSIXCHECK
+# undef time
+# if HAVE_RAW_DECL_TIME
+_GL_WARN_ON_USE (time, "time has consistency problems - "
+ "use gnulib module time for portability");
+# endif
# endif
/* Sleep for at least RQTP seconds unless interrupted, If interrupted,
@@ -154,6 +223,12 @@ _GL_CXXALIAS_SYS (nanosleep, int,
(struct timespec const *__rqtp, struct timespec *__rmtp));
# endif
_GL_CXXALIASWARN (nanosleep);
+# elif defined GNULIB_POSIXCHECK
+# undef nanosleep
+# if HAVE_RAW_DECL_NANOSLEEP
+_GL_WARN_ON_USE (nanosleep, "nanosleep is unportable - "
+ "use gnulib module nanosleep for portability");
+# endif
# endif
/* Initialize time conversion information. */
@@ -189,6 +264,12 @@ _GL_CXXALIAS_MDA (tzset, void, (void));
_GL_CXXALIAS_SYS (tzset, void, (void));
# endif
_GL_CXXALIASWARN (tzset);
+# elif defined GNULIB_POSIXCHECK
+# undef tzset
+# if HAVE_RAW_DECL_TZSET
+_GL_WARN_ON_USE (tzset, "tzset has portability problems - "
+ "use gnulib module tzset for portability");
+# endif
# endif
/* Return the 'time_t' representation of TP and normalize TP. */
@@ -205,6 +286,12 @@ _GL_CXXALIAS_SYS (mktime, time_t, (struct tm *__tp));
# if __GLIBC__ >= 2
_GL_CXXALIASWARN (mktime);
# endif
+# elif defined GNULIB_POSIXCHECK
+# undef mktime
+# if HAVE_RAW_DECL_MKTIME
+_GL_WARN_ON_USE (mktime, "mktime has portability problems - "
+ "use gnulib module mktime for portability");
+# endif
# endif
/* Convert TIMER to RESULT, assuming local time and UTC respectively. See
@@ -255,6 +342,17 @@ _GL_CXXALIAS_SYS (gmtime_r, struct tm *, (time_t const *restrict __timer,
# if @HAVE_DECL_LOCALTIME_R@
_GL_CXXALIASWARN (gmtime_r);
# endif
+# elif defined GNULIB_POSIXCHECK
+# undef localtime_r
+# if HAVE_RAW_DECL_LOCALTIME_R
+_GL_WARN_ON_USE (localtime_r, "localtime_r is unportable - "
+ "use gnulib module time_r for portability");
+# endif
+# undef gmtime_r
+# if HAVE_RAW_DECL_GMTIME_R
+_GL_WARN_ON_USE (gmtime_r, "gmtime_r is unportable - "
+ "use gnulib module time_r for portability");
+# endif
# endif
/* Convert TIMER to RESULT, assuming local time and UTC respectively. See
@@ -275,6 +373,12 @@ _GL_CXXALIAS_SYS (localtime, struct tm *, (time_t const *__timer));
# if __GLIBC__ >= 2
_GL_CXXALIASWARN (localtime);
# endif
+# elif defined GNULIB_POSIXCHECK
+# undef localtime
+# if HAVE_RAW_DECL_LOCALTIME
+_GL_WARN_ON_USE (localtime, "localtime has portability problems - "
+ "use gnulib module localtime for portability");
+# endif
# endif
# if 0 || @REPLACE_GMTIME@
@@ -306,6 +410,12 @@ _GL_CXXALIAS_SYS (strptime, char *, (char const *restrict __buf,
char const *restrict __format,
struct tm *restrict __tm));
_GL_CXXALIASWARN (strptime);
+# elif defined GNULIB_POSIXCHECK
+# undef strptime
+# if HAVE_RAW_DECL_STRPTIME
+_GL_WARN_ON_USE (strptime, "strptime is unportable - "
+ "use gnulib module strptime for portability");
+# endif
# endif
/* Convert *TP to a date and time string. See
@@ -315,6 +425,9 @@ _GL_CXXALIASWARN (strptime);
# if !(defined __cplusplus && defined GNULIB_NAMESPACE)
# define ctime rpl_ctime
# endif
+# ifndef __cplusplus
+_GL_ATTRIBUTE_DEPRECATED
+# endif
_GL_FUNCDECL_RPL (ctime, char *, (time_t const *__tp)
_GL_ARG_NONNULL ((1)));
_GL_CXXALIAS_RPL (ctime, char *, (time_t const *__tp));
@@ -324,6 +437,8 @@ _GL_CXXALIAS_SYS (ctime, char *, (time_t const *__tp));
# if __GLIBC__ >= 2
_GL_CXXALIASWARN (ctime);
# endif
+# elif defined GNULIB_POSIXCHECK
+/* No need to warn about portability, as a more serious warning is below. */
# endif
/* Convert *TP to a date and time string. See
@@ -348,6 +463,12 @@ _GL_CXXALIAS_SYS (strftime, size_t,
# if __GLIBC__ >= 2
_GL_CXXALIASWARN (strftime);
# endif
+# elif defined GNULIB_POSIXCHECK
+# undef strftime
+# if HAVE_RAW_DECL_STRFTIME
+_GL_WARN_ON_USE (strftime, "strftime has portability problems - "
+ "use gnulib module strftime-fixes for portability");
+# endif
# endif
# if defined _GNU_SOURCE && @GNULIB_TIME_RZ@ && ! @HAVE_TIMEZONE_T@
@@ -422,7 +543,15 @@ _GL_FUNCDECL_SYS (timegm, time_t, (struct tm *__tm) _GL_ARG_NONNULL ((1)));
# endif
_GL_CXXALIAS_SYS (timegm, time_t, (struct tm *__tm));
# endif
+# if __GLIBC__ >= 2
_GL_CXXALIASWARN (timegm);
+# endif
+# elif defined GNULIB_POSIXCHECK
+# undef timegm
+# if HAVE_RAW_DECL_TIMEGM
+_GL_WARN_ON_USE (timegm, "timegm is unportable - "
+ "use gnulib module timegm for portability");
+# endif
# endif
/* Encourage applications to avoid unsafe functions that can overrun
@@ -430,8 +559,10 @@ _GL_CXXALIASWARN (timegm);
applications should use strftime (or even sprintf) instead. */
# if defined GNULIB_POSIXCHECK
# undef asctime
+# if HAVE_RAW_DECL_ASCTIME
_GL_WARN_ON_USE (asctime, "asctime can overrun buffers in some cases - "
"better use strftime (or even sprintf) instead");
+# endif
# endif
# if defined GNULIB_POSIXCHECK
# undef asctime_r
@@ -442,8 +573,10 @@ _GL_WARN_ON_USE (asctime_r, "asctime_r can overrun buffers in some cases - "
# endif
# if defined GNULIB_POSIXCHECK
# undef ctime
+# if HAVE_RAW_DECL_CTIME
_GL_WARN_ON_USE (ctime, "ctime can overrun buffers in some cases - "
"better use strftime (or even sprintf) instead");
+# endif
# endif
# if defined GNULIB_POSIXCHECK
# undef ctime_r
diff --git a/lib/time_r.c b/lib/time_r.c
index 4201e73f743..b724f3b38de 100644
--- a/lib/time_r.c
+++ b/lib/time_r.c
@@ -1,7 +1,6 @@
/* Reentrant time functions like localtime_r.
- Copyright (C) 2003, 2006-2007, 2010-2024 Free Software Foundation,
- Inc.
+ Copyright (C) 2003, 2006-2007, 2010-2024 Free Software Foundation, Inc.
This file is free software: you can redistribute it and/or modify
it under the terms of the GNU Lesser General Public License as
@@ -22,6 +21,11 @@
#include <time.h>
+/* The replacement functions in this file are only used on native Windows.
+ They are multithread-safe, because the gmtime() and localtime() functions
+ on native Windows — both in the ucrt and in the older MSVCRT — return a
+ pointer to a 'struct tm' in thread-local memory. */
+
static struct tm *
copy_tm_result (struct tm *dest, struct tm const *src)
{
diff --git a/lib/timespec-add.c b/lib/timespec-add.c
index 981edc8d8f9..e10c19842cd 100644
--- a/lib/timespec-add.c
+++ b/lib/timespec-add.c
@@ -23,6 +23,7 @@
#include <config.h>
#include "timespec.h"
+#include <stdckdint.h>
#include "intprops.h"
struct timespec
@@ -38,7 +39,7 @@ timespec_add (struct timespec a, struct timespec b)
{
rns = nsd;
time_t bs1;
- if (!INT_ADD_WRAPV (bs, 1, &bs1))
+ if (!ckd_add (&bs1, bs, 1))
bs = bs1;
else if (rs < 0)
rs++;
@@ -46,7 +47,7 @@ timespec_add (struct timespec a, struct timespec b)
goto high_overflow;
}
- if (INT_ADD_WRAPV (rs, bs, &rs))
+ if (ckd_add (&rs, rs, bs))
{
if (bs < 0)
{
diff --git a/lib/timespec-sub.c b/lib/timespec-sub.c
index 2224bc19163..315cc638369 100644
--- a/lib/timespec-sub.c
+++ b/lib/timespec-sub.c
@@ -24,6 +24,7 @@
#include <config.h>
#include "timespec.h"
+#include <stdckdint.h>
#include "intprops.h"
struct timespec
@@ -38,7 +39,7 @@ timespec_sub (struct timespec a, struct timespec b)
{
rns = ns + TIMESPEC_HZ;
time_t bs1;
- if (!INT_ADD_WRAPV (bs, 1, &bs1))
+ if (!ckd_add (&bs1, bs, 1))
bs = bs1;
else if (- TYPE_SIGNED (time_t) < rs)
rs--;
@@ -46,7 +47,7 @@ timespec_sub (struct timespec a, struct timespec b)
goto low_overflow;
}
- if (INT_SUBTRACT_WRAPV (rs, bs, &rs))
+ if (ckd_sub (&rs, rs, bs))
{
if (0 < bs)
{
diff --git a/lib/timespec.h b/lib/timespec.h
index 4ca03aa9302..69ce348569d 100644
--- a/lib/timespec.h
+++ b/lib/timespec.h
@@ -19,11 +19,14 @@
#if ! defined TIMESPEC_H
#define TIMESPEC_H
-#include <time.h>
-
-#ifndef _GL_INLINE_HEADER_BEGIN
+/* This file uses _GL_INLINE_HEADER_BEGIN, _GL_INLINE, _GL_ATTRIBUTE_CONST,
+ _GL_ATTRIBUTE_PURE, _GL_CMP. */
+#if !_GL_CONFIG_H_INCLUDED
#error "Please include config.h first."
#endif
+
+#include <time.h>
+
_GL_INLINE_HEADER_BEGIN
#ifndef _GL_TIMESPEC_INLINE
# define _GL_TIMESPEC_INLINE _GL_INLINE
@@ -52,10 +55,7 @@ enum { LOG10_TIMESPEC_RESOLUTION = LOG10_TIMESPEC_HZ };
_GL_TIMESPEC_INLINE struct timespec
make_timespec (time_t s, long int ns)
{
- struct timespec r;
- r.tv_sec = s;
- r.tv_nsec = ns;
- return r;
+ return (struct timespec) { .tv_sec = s, .tv_nsec = ns };
}
/* Return negative, zero, positive if A < B, A == B, A > B, respectively. */
diff --git a/lib/u64.h b/lib/u64.h
index b71d224e649..63339cca0fc 100644
--- a/lib/u64.h
+++ b/lib/u64.h
@@ -17,11 +17,13 @@
/* Written by Paul Eggert. */
-#include <stdint.h>
-
-#ifndef _GL_INLINE_HEADER_BEGIN
+/* This file uses _GL_INLINE_HEADER_BEGIN, _GL_INLINE. */
+#if !_GL_CONFIG_H_INCLUDED
#error "Please include config.h first."
#endif
+
+#include <stdint.h>
+
_GL_INLINE_HEADER_BEGIN
#ifndef _GL_U64_INLINE
# define _GL_U64_INLINE _GL_INLINE
diff --git a/lib/unistd.c b/lib/unistd.c
index 50b75ff44b7..f3b3f7bd2fe 100644
--- a/lib/unistd.c
+++ b/lib/unistd.c
@@ -18,5 +18,5 @@
#include <config.h>
#define _GL_UNISTD_INLINE _GL_EXTERN_INLINE
-#include "unistd.h"
+#include <unistd.h>
typedef int dummy;
diff --git a/lib/unistd.in.h b/lib/unistd.in.h
index cde0c1f1475..b412966367d 100644
--- a/lib/unistd.in.h
+++ b/lib/unistd.in.h
@@ -40,6 +40,24 @@
# undef _GL_INCLUDING_UNISTD_H
#endif
+/* Avoid lseek bugs in FreeBSD, macOS <https://bugs.gnu.org/61386>.
+ This bug is fixed after FreeBSD 13; see <https://bugs.freebsd.org/256205>.
+ Use macOS "9999" to stand for a future fixed macOS version. */
+#if defined __FreeBSD__ && __FreeBSD__ < 14
+# undef SEEK_DATA
+# undef SEEK_HOLE
+#elif defined __APPLE__ && defined __MACH__ && defined SEEK_DATA
+# ifdef __ENVIRONMENT_MAC_OS_X_VERSION_MIN_REQUIRED__
+# include <AvailabilityMacros.h>
+# endif
+# if (!defined MAC_OS_X_VERSION_MIN_REQUIRED \
+ || MAC_OS_X_VERSION_MIN_REQUIRED < 99990000)
+# include <sys/fcntl.h> /* It also defines the two macros. */
+# undef SEEK_DATA
+# undef SEEK_HOLE
+# endif
+#endif
+
/* Get all possible declarations of gethostname(). */
#if @GNULIB_GETHOSTNAME@ && @UNISTD_H_HAVE_WINSOCK2_H@ \
&& !defined _GL_INCLUDING_WINSOCK2_H
@@ -51,6 +69,12 @@
#if !defined _@GUARD_PREFIX@_UNISTD_H && !defined _GL_INCLUDING_WINSOCK2_H
#define _@GUARD_PREFIX@_UNISTD_H
+/* This file uses _GL_INLINE_HEADER_BEGIN, _GL_INLINE, GNULIB_POSIXCHECK,
+ HAVE_RAW_DECL_*. */
+#if !_GL_CONFIG_H_INCLUDED
+ #error "Please include config.h first."
+#endif
+
/* NetBSD 5.0 mis-defines NULL. Also get size_t. */
/* But avoid namespace pollution on glibc systems. */
#ifndef __GLIBC__
@@ -152,9 +176,6 @@
# include <getopt-pfx-core.h>
#endif
-#ifndef _GL_INLINE_HEADER_BEGIN
- #error "Please include config.h first."
-#endif
_GL_INLINE_HEADER_BEGIN
#ifndef _GL_UNISTD_INLINE
# define _GL_UNISTD_INLINE _GL_INLINE
@@ -541,17 +562,22 @@ _GL_CXXALIASWARN (dup2);
Return newfd if successful, otherwise -1 and errno set.
See the Linux man page at
<https://www.kernel.org/doc/man-pages/online/pages/man2/dup3.2.html>. */
-# if @HAVE_DUP3@
+# if @REPLACE_DUP3@
# if !(defined __cplusplus && defined GNULIB_NAMESPACE)
+# undef dup3
# define dup3 rpl_dup3
# endif
_GL_FUNCDECL_RPL (dup3, int, (int oldfd, int newfd, int flags));
_GL_CXXALIAS_RPL (dup3, int, (int oldfd, int newfd, int flags));
# else
+# if !@HAVE_DUP3@
_GL_FUNCDECL_SYS (dup3, int, (int oldfd, int newfd, int flags));
+# endif
_GL_CXXALIAS_SYS (dup3, int, (int oldfd, int newfd, int flags));
# endif
+# if __GLIBC__ >= 2
_GL_CXXALIASWARN (dup3);
+# endif
#elif defined GNULIB_POSIXCHECK
# undef dup3
# if HAVE_RAW_DECL_DUP3
@@ -870,7 +896,9 @@ _GL_FUNCDECL_SYS (execvpe, int,
_GL_CXXALIAS_SYS (execvpe, int,
(const char *program, char * const *argv, char * const *env));
# endif
+# if __GLIBC__ >= 2
_GL_CXXALIASWARN (execvpe);
+# endif
#elif defined GNULIB_POSIXCHECK
# undef execvpe
# if HAVE_RAW_DECL_EXECVPE
@@ -925,7 +953,9 @@ _GL_FUNCDECL_SYS (faccessat, int,
_GL_CXXALIAS_SYS (faccessat, int,
(int fd, char const *file, int mode, int flag));
# endif
+# if __GLIBC__ >= 2
_GL_CXXALIASWARN (faccessat);
+# endif
#elif defined GNULIB_POSIXCHECK
# undef faccessat
# if HAVE_RAW_DECL_FACCESSAT
@@ -941,23 +971,28 @@ _GL_WARN_ON_USE (faccessat, "faccessat is not portable - "
Return 0 if successful, otherwise -1 and errno set.
See the POSIX:2008 specification
<https://pubs.opengroup.org/onlinepubs/9699919799/functions/fchdir.html>. */
-# if ! @HAVE_FCHDIR@
+# if @REPLACE_FCHDIR@
+# if !(defined __cplusplus && defined GNULIB_NAMESPACE)
+# undef fchdir
+# define fchdir rpl_fchdir
+# endif
+_GL_FUNCDECL_RPL (fchdir, int, (int /*fd*/));
+_GL_CXXALIAS_RPL (fchdir, int, (int /*fd*/));
+# else
+# if !@HAVE_FCHDIR@ || !@HAVE_DECL_FCHDIR@
_GL_FUNCDECL_SYS (fchdir, int, (int /*fd*/));
-
+# endif
+_GL_CXXALIAS_SYS (fchdir, int, (int /*fd*/));
+# endif
+_GL_CXXALIASWARN (fchdir);
+# if @REPLACE_FCHDIR@ || !@HAVE_FCHDIR@
/* Gnulib internal hooks needed to maintain the fchdir metadata. */
_GL_EXTERN_C int _gl_register_fd (int fd, const char *filename)
_GL_ARG_NONNULL ((2));
_GL_EXTERN_C void _gl_unregister_fd (int fd);
_GL_EXTERN_C int _gl_register_dup (int oldfd, int newfd);
_GL_EXTERN_C const char *_gl_directory_name (int fd);
-
-# else
-# if !@HAVE_DECL_FCHDIR@
-_GL_FUNCDECL_SYS (fchdir, int, (int /*fd*/));
-# endif
# endif
-_GL_CXXALIAS_SYS (fchdir, int, (int /*fd*/));
-_GL_CXXALIASWARN (fchdir);
#elif defined GNULIB_POSIXCHECK
# undef fchdir
# if HAVE_RAW_DECL_FCHDIR
@@ -1002,11 +1037,22 @@ _GL_WARN_ON_USE (fchownat, "fchownat is not portable - "
Return 0 if successful, otherwise -1 and errno set.
See POSIX:2008 specification
<https://pubs.opengroup.org/onlinepubs/9699919799/functions/fdatasync.html>. */
-# if !@HAVE_FDATASYNC@ || !@HAVE_DECL_FDATASYNC@
+# if @REPLACE_FDATASYNC@
+# if !(defined __cplusplus && defined GNULIB_NAMESPACE)
+# undef fdatasync
+# define fdatasync rpl_fdatasync
+# endif
+_GL_FUNCDECL_RPL (fdatasync, int, (int fd));
+_GL_CXXALIAS_RPL (fdatasync, int, (int fd));
+# else
+# if !@HAVE_FDATASYNC@|| !@HAVE_DECL_FDATASYNC@
_GL_FUNCDECL_SYS (fdatasync, int, (int fd));
-# endif
+# endif
_GL_CXXALIAS_SYS (fdatasync, int, (int fd));
+# endif
+# if __GLIBC__ >= 2
_GL_CXXALIASWARN (fdatasync);
+# endif
#elif defined GNULIB_POSIXCHECK
# undef fdatasync
# if HAVE_RAW_DECL_FDATASYNC
@@ -1053,7 +1099,9 @@ _GL_FUNCDECL_SYS (ftruncate, int, (int fd, off_t length));
# endif
_GL_CXXALIAS_SYS (ftruncate, int, (int fd, off_t length));
# endif
+# if __GLIBC__ >= 2
_GL_CXXALIASWARN (ftruncate);
+# endif
#elif defined GNULIB_POSIXCHECK
# undef ftruncate
# if HAVE_RAW_DECL_FTRUNCATE
@@ -1070,10 +1118,10 @@ _GL_WARN_ON_USE (ftruncate, "ftruncate is unportable - "
or SIZE was too small.
See the POSIX:2008 specification
<https://pubs.opengroup.org/onlinepubs/9699919799/functions/getcwd.html>.
- Additionally, the gnulib module 'getcwd' guarantees the following GNU
- extension: If BUF is NULL, an array is allocated with 'malloc'; the array
- is SIZE bytes long, unless SIZE == 0, in which case it is as big as
- necessary. */
+ Additionally, the gnulib module 'getcwd' or 'getcwd-lgpl' guarantees the
+ following GNU extension: If BUF is NULL, an array is allocated with
+ 'malloc'; the array is SIZE bytes long, unless SIZE == 0, in which case
+ it is as big as necessary. */
# if @REPLACE_GETCWD@
# if !(defined __cplusplus && defined GNULIB_NAMESPACE)
# define getcwd rpl_getcwd
@@ -1185,11 +1233,22 @@ _GL_WARN_ON_USE (getdtablesize, "getdtablesize is unportable - "
#if @GNULIB_GETENTROPY@
/* Fill a buffer with random bytes. */
-# if !@HAVE_GETENTROPY@
+# if @REPLACE_GETENTROPY@
+# if !(defined __cplusplus && defined GNULIB_NAMESPACE)
+# undef getentropy
+# define getentropy rpl_getentropy
+# endif
+_GL_FUNCDECL_RPL (getentropy, int, (void *buffer, size_t length));
+_GL_CXXALIAS_RPL (getentropy, int, (void *buffer, size_t length));
+# else
+# if !@HAVE_GETENTROPY@
_GL_FUNCDECL_SYS (getentropy, int, (void *buffer, size_t length));
-# endif
+# endif
_GL_CXXALIAS_SYS (getentropy, int, (void *buffer, size_t length));
+# endif
+# if __GLIBC__ >= 2
_GL_CXXALIASWARN (getentropy);
+# endif
#elif defined GNULIB_POSIXCHECK
# undef getentropy
# if HAVE_RAW_DECL_GETENTROPY
@@ -1323,7 +1382,9 @@ _GL_FUNCDECL_SYS (getlogin_r, int, (char *name, size_t size)
int size. */
_GL_CXXALIAS_SYS_CAST (getlogin_r, int, (char *name, size_t size));
# endif
+# if __GLIBC__ >= 2
_GL_CXXALIASWARN (getlogin_r);
+# endif
#elif defined GNULIB_POSIXCHECK
# undef getlogin_r
# if HAVE_RAW_DECL_GETLOGIN_R
@@ -1661,7 +1722,9 @@ _GL_CXXALIAS_SYS (linkat, int,
(int fd1, const char *path1, int fd2, const char *path2,
int flag));
# endif
+# if __GLIBC__ >= 2
_GL_CXXALIASWARN (linkat);
+# endif
#elif defined GNULIB_POSIXCHECK
# undef linkat
# if HAVE_RAW_DECL_LINKAT
@@ -1742,8 +1805,9 @@ _GL_WARN_ON_USE (pipe, "pipe is unportable - "
Return 0 upon success, or -1 with errno set upon failure.
See also the Linux man page at
<https://www.kernel.org/doc/man-pages/online/pages/man2/pipe2.2.html>. */
-# if @HAVE_PIPE2@
+# if @REPLACE_PIPE2@
# if !(defined __cplusplus && defined GNULIB_NAMESPACE)
+# undef pipe2
# define pipe2 rpl_pipe2
# endif
_GL_FUNCDECL_RPL (pipe2, int, (int fd[2], int flags) _GL_ARG_NONNULL ((1)));
@@ -1752,7 +1816,9 @@ _GL_CXXALIAS_RPL (pipe2, int, (int fd[2], int flags));
_GL_FUNCDECL_SYS (pipe2, int, (int fd[2], int flags) _GL_ARG_NONNULL ((1)));
_GL_CXXALIAS_SYS (pipe2, int, (int fd[2], int flags));
# endif
+# if __GLIBC__ >= 2
_GL_CXXALIASWARN (pipe2);
+# endif
#elif defined GNULIB_POSIXCHECK
# undef pipe2
# if HAVE_RAW_DECL_PIPE2
@@ -1787,7 +1853,9 @@ _GL_FUNCDECL_SYS (pread, ssize_t,
_GL_CXXALIAS_SYS (pread, ssize_t,
(int fd, void *buf, size_t bufsize, off_t offset));
# endif
+# if __GLIBC__ >= 2
_GL_CXXALIASWARN (pread);
+# endif
#elif defined GNULIB_POSIXCHECK
# undef pread
# if HAVE_RAW_DECL_PREAD
@@ -1822,7 +1890,9 @@ _GL_FUNCDECL_SYS (pwrite, ssize_t,
_GL_CXXALIAS_SYS (pwrite, ssize_t,
(int fd, const void *buf, size_t bufsize, off_t offset));
# endif
+# if __GLIBC__ >= 2
_GL_CXXALIASWARN (pwrite);
+# endif
#elif defined GNULIB_POSIXCHECK
# undef pwrite
# if HAVE_RAW_DECL_PWRITE
@@ -1936,7 +2006,9 @@ _GL_CXXALIAS_SYS (readlinkat, ssize_t,
(int fd, char const *restrict file,
char *restrict buf, size_t len));
# endif
+# if __GLIBC__ >= 2
_GL_CXXALIASWARN (readlinkat);
+# endif
#elif defined GNULIB_POSIXCHECK
# undef readlinkat
# if HAVE_RAW_DECL_READLINKAT
@@ -1996,15 +2068,27 @@ _GL_CXXALIASWARN (rmdir);
Platforms with no ability to set the hostname return -1 and set
errno = ENOSYS. */
-# if !@HAVE_SETHOSTNAME@ || !@HAVE_DECL_SETHOSTNAME@
+# if @REPLACE_SETHOSTNAME@
+# if !(defined __cplusplus && defined GNULIB_NAMESPACE)
+# undef sethostname
+# define sethostname rpl_sethostname
+# endif
+_GL_FUNCDECL_RPL (sethostname, int, (const char *name, size_t len)
+ _GL_ARG_NONNULL ((1)));
+_GL_CXXALIAS_RPL (sethostname, int, (const char *name, size_t len));
+# else
+# if !@HAVE_SETHOSTNAME@ || !@HAVE_DECL_SETHOSTNAME@
_GL_FUNCDECL_SYS (sethostname, int, (const char *name, size_t len)
_GL_ARG_NONNULL ((1)));
-# endif
+# endif
/* Need to cast, because on Solaris 11 2011-10, Mac OS X 10.5, IRIX 6.5
and FreeBSD 6.4 the second parameter is int. On Solaris 11
2011-10, the first parameter is not const. */
_GL_CXXALIAS_SYS_CAST (sethostname, int, (const char *name, size_t len));
+# endif
+# if __GLIBC__ >= 2
_GL_CXXALIASWARN (sethostname);
+# endif
#elif defined GNULIB_POSIXCHECK
# undef sethostname
# if HAVE_RAW_DECL_SETHOSTNAME
@@ -2113,7 +2197,9 @@ _GL_FUNCDECL_SYS (symlinkat, int,
_GL_CXXALIAS_SYS (symlinkat, int,
(char const *contents, int fd, char const *file));
# endif
+# if __GLIBC__ >= 2
_GL_CXXALIASWARN (symlinkat);
+# endif
#elif defined GNULIB_POSIXCHECK
# undef symlinkat
# if HAVE_RAW_DECL_SYMLINKAT
@@ -2143,7 +2229,9 @@ _GL_FUNCDECL_SYS (truncate, int, (const char *filename, off_t length)
# endif
_GL_CXXALIAS_SYS (truncate, int, (const char *filename, off_t length));
# endif
+# if __GLIBC__ >= 2
_GL_CXXALIASWARN (truncate);
+# endif
#elif defined GNULIB_POSIXCHECK
# undef truncate
# if HAVE_RAW_DECL_TRUNCATE
@@ -2173,7 +2261,9 @@ _GL_FUNCDECL_SYS (ttyname_r, int,
_GL_CXXALIAS_SYS (ttyname_r, int,
(int fd, char *buf, size_t buflen));
# endif
+# if __GLIBC__ >= 2
_GL_CXXALIASWARN (ttyname_r);
+# endif
#elif defined GNULIB_POSIXCHECK
# undef ttyname_r
# if HAVE_RAW_DECL_TTYNAME_R
diff --git a/lib/unlocked-io.h b/lib/unlocked-io.h
index 1f8d3cd9a4e..0cd9bbf3c98 100644
--- a/lib/unlocked-io.h
+++ b/lib/unlocked-io.h
@@ -31,6 +31,11 @@
the *_unlocked functions directly. On hosts that lack those
functions, invoke the non-thread-safe versions instead. */
+/* This file uses HAVE_DECL_*_UNLOCKED. */
+# if !_GL_CONFIG_H_INCLUDED
+# error "Please include config.h first."
+# endif
+
# include <stdio.h>
# if HAVE_DECL_CLEARERR_UNLOCKED || defined clearerr_unlocked
@@ -96,7 +101,7 @@
# define fwrite_unlocked(w,x,y,z) fwrite (w,x,y,z)
# endif
-# if HAVE_DECL_GETC_UNLOCKED || defined get_unlocked
+# if HAVE_DECL_GETC_UNLOCKED || defined getc_unlocked
# undef getc
# define getc(x) getc_unlocked (x)
# else
diff --git a/lib/utimens.c b/lib/utimens.c
index 325b8b145be..4bfb9c91a7b 100644
--- a/lib/utimens.c
+++ b/lib/utimens.c
@@ -231,8 +231,8 @@ fdutimens (int fd, char const *file, struct timespec const timespec[2])
The same bug occurs in Solaris 11.1 (Apr 2013).
- FIXME: Simplify this for Linux in 2016 and for Solaris in
- 2024, when file system bugs are no longer common. */
+ FIXME: Simplify this in 2024, when these file system bugs are
+ no longer common on Gnulib target platforms. */
if (adjustment_needed == 2)
{
if (fd < 0 ? stat (file, &st) : fstat (fd, &st))
@@ -405,10 +405,10 @@ fdutimens (int fd, char const *file, struct timespec const timespec[2])
struct timeval *t;
if (ts)
{
- timeval[0].tv_sec = ts[0].tv_sec;
- timeval[0].tv_usec = ts[0].tv_nsec / 1000;
- timeval[1].tv_sec = ts[1].tv_sec;
- timeval[1].tv_usec = ts[1].tv_nsec / 1000;
+ timeval[0] = (struct timeval) { .tv_sec = ts[0].tv_sec,
+ .tv_usec = ts[0].tv_nsec / 1000 };
+ timeval[1] = (struct timeval) { .tv_sec = ts[1].tv_sec,
+ .tv_usec = ts[1].tv_nsec / 1000 };
t = timeval;
}
else
@@ -502,8 +502,8 @@ fdutimens (int fd, char const *file, struct timespec const timespec[2])
struct utimbuf *ut;
if (ts)
{
- utimbuf.actime = ts[0].tv_sec;
- utimbuf.modtime = ts[1].tv_sec;
+ utimbuf = (struct utimbuf) { .actime = ts[0].tv_sec,
+ .modtime = ts[1].tv_sec };
ut = &utimbuf;
}
else
@@ -621,10 +621,10 @@ lutimens (char const *file, struct timespec const timespec[2])
int result;
if (ts)
{
- timeval[0].tv_sec = ts[0].tv_sec;
- timeval[0].tv_usec = ts[0].tv_nsec / 1000;
- timeval[1].tv_sec = ts[1].tv_sec;
- timeval[1].tv_usec = ts[1].tv_nsec / 1000;
+ timeval[0] = (struct timeval) { .tv_sec = ts[0].tv_sec,
+ .tv_usec = ts[0].tv_nsec / 1000 };
+ timeval[1] = (struct timeval) { .tv_sec = ts[1].tv_sec,
+ .tv_usec = ts[1].tv_nsec / 1000 };
t = timeval;
}
else
diff --git a/lib/utimens.h b/lib/utimens.h
index 16c935d9ba8..7c740afd36d 100644
--- a/lib/utimens.h
+++ b/lib/utimens.h
@@ -17,6 +17,11 @@
/* Written by Paul Eggert. */
+/* This file uses _GL_INLINE_HEADER_BEGIN, _GL_INLINE. */
+#if !_GL_CONFIG_H_INCLUDED
+ #error "Please include config.h first."
+#endif
+
#include <time.h>
int fdutimens (int, char const *, struct timespec const [2]);
int utimens (char const *, struct timespec const [2]);
@@ -26,9 +31,6 @@ int lutimens (char const *, struct timespec const [2]);
# include <fcntl.h>
# include <sys/stat.h>
-#ifndef _GL_INLINE_HEADER_BEGIN
- #error "Please include config.h first."
-#endif
_GL_INLINE_HEADER_BEGIN
#ifndef _GL_UTIMENS_INLINE
# define _GL_UTIMENS_INLINE _GL_INLINE
diff --git a/lib/verify.h b/lib/verify.h
index ab554ab861f..08268c2498f 100644
--- a/lib/verify.h
+++ b/lib/verify.h
@@ -37,7 +37,7 @@
&& (4 < __GNUC__ + (6 <= __GNUC_MINOR__) || 5 <= __clang_major__)))
# define _GL_HAVE__STATIC_ASSERT 1
# endif
-# if (202000 <= __STDC_VERSION__ \
+# if (202311 <= __STDC_VERSION__ \
|| (!defined __STRICT_ANSI__ && 9 <= __GNUC__))
# define _GL_HAVE__STATIC_ASSERT1 1
# endif
@@ -188,9 +188,9 @@ template <int w>
_gl_verify_type<(R) ? 1 : -1>
#elif defined _GL_HAVE__STATIC_ASSERT
# define _GL_VERIFY_TYPE(R, DIAGNOSTIC) \
- struct { \
- _Static_assert (R, DIAGNOSTIC); \
- int _gl_dummy; \
+ struct { \
+ _Static_assert (R, DIAGNOSTIC); \
+ int _gl_dummy; \
}
#else
# define _GL_VERIFY_TYPE(R, DIAGNOSTIC) \
@@ -212,8 +212,8 @@ template <int w>
#elif defined _GL_HAVE__STATIC_ASSERT
# define _GL_VERIFY(R, DIAGNOSTIC, ...) _Static_assert (R, DIAGNOSTIC)
#else
-# define _GL_VERIFY(R, DIAGNOSTIC, ...) \
- extern int (*_GL_GENSYM (_gl_verify_function) (void)) \
+# 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"
@@ -222,28 +222,57 @@ template <int w>
/* _GL_STATIC_ASSERT_H is defined if this code is copied into assert.h. */
#ifdef _GL_STATIC_ASSERT_H
-# if !defined _GL_HAVE__STATIC_ASSERT1 && !defined _Static_assert
-# define _Static_assert(R, ...) \
- _GL_VERIFY ((R), "static assertion failed", -)
+/* Define _Static_assert if needed. */
+/* With clang ≥ 3.8.0 in C++ mode, _Static_assert already works and accepts
+ 1 or 2 arguments. We better don't override it, because clang's standard
+ C++ library uses static_assert inside classes in several places, and our
+ replacement via _GL_VERIFY does not work in these contexts. */
+# if (defined __cplusplus && defined __clang__ \
+ && (4 <= __clang_major__ + (8 <= __clang_minor__)))
+# if 5 <= __clang_major__
+/* Avoid "warning: 'static_assert' with no message is a C++17 extension". */
+# pragma clang diagnostic ignored "-Wc++17-extensions"
+# else
+/* Avoid "warning: static_assert with no message is a C++1z extension". */
+# pragma clang diagnostic ignored "-Wc++1z-extensions"
+# endif
+# elif !defined _GL_HAVE__STATIC_ASSERT1 && !defined _Static_assert
+# if !defined _MSC_VER || defined __clang__
+# define _Static_assert(...) \
+ _GL_VERIFY (__VA_ARGS__, "static assertion failed", -)
+# else
+# if defined __cplusplus && _MSC_VER >= 1910
+ /* In MSVC 14.1 or newer, static_assert accepts one or two arguments,
+ but _Static_assert is not defined. */
+# define _Static_assert static_assert
+# else
+ /* Work around MSVC preprocessor incompatibility with ISO C; see
+ <https://stackoverflow.com/questions/5134523/>. */
+# define _Static_assert(R, ...) \
+ _GL_VERIFY ((R), "static assertion failed", -)
+# endif
+# endif
# endif
+/* Define static_assert if needed. */
# if (!defined static_assert \
&& __STDC_VERSION__ < 202311 \
&& (!defined __cplusplus \
|| (__cpp_static_assert < 201411 \
- && __GNUG__ < 6 && __clang_major__ < 6)))
+ && __GNUG__ < 6 && __clang_major__ < 6 && _MSC_VER < 1910)))
# if defined __cplusplus && _MSC_VER >= 1900 && !defined __clang__
/* MSVC 14 in C++ mode supports the two-arguments static_assert but not
the one-argument static_assert, and it does not support _Static_assert.
We have to play preprocessor tricks to distinguish the two cases.
- Since the MSVC preprocessor is not ISO C compliant (cf.
- <https://stackoverflow.com/questions/5134523/>), the solution is specific
- to MSVC. */
+ Since the MSVC preprocessor is not ISO C compliant (see above),.
+ the solution is specific to MSVC. */
# define _GL_EXPAND(x) x
# define _GL_SA1(a1) static_assert ((a1), "static assertion failed")
# define _GL_SA2 static_assert
# define _GL_SA3 static_assert
# define _GL_SA_PICK(x1,x2,x3,x4,...) x4
# define static_assert(...) _GL_EXPAND(_GL_SA_PICK(__VA_ARGS__,_GL_SA3,_GL_SA2,_GL_SA1)) (__VA_ARGS__)
+/* Avoid "fatal error C1189: #error: The C++ Standard Library forbids macroizing keywords." */
+# define _ALLOW_KEYWORD_MACROS 1
# else
# define static_assert _Static_assert /* C11 requires this #define. */
# endif
@@ -252,7 +281,9 @@ template <int w>
/* @assert.h omit start@ */
-#if 3 < __GNUC__ + (3 < __GNUC_MINOR__ + (4 <= __GNUC_PATCHLEVEL__))
+#if defined __clang_major__ && __clang_major__ < 5
+# define _GL_HAS_BUILTIN_TRAP 0
+#elif 3 < __GNUC__ + (3 < __GNUC_MINOR__ + (4 <= __GNUC_PATCHLEVEL__))
# define _GL_HAS_BUILTIN_TRAP 1
#elif defined __has_builtin
# define _GL_HAS_BUILTIN_TRAP __has_builtin (__builtin_trap)
@@ -260,12 +291,16 @@ template <int w>
# define _GL_HAS_BUILTIN_TRAP 0
#endif
-#if 4 < __GNUC__ + (5 <= __GNUC_MINOR__)
-# define _GL_HAS_BUILTIN_UNREACHABLE 1
-#elif defined __has_builtin
-# define _GL_HAS_BUILTIN_UNREACHABLE __has_builtin (__builtin_unreachable)
-#else
-# define _GL_HAS_BUILTIN_UNREACHABLE 0
+#ifndef _GL_HAS_BUILTIN_UNREACHABLE
+# if defined __clang_major__ && __clang_major__ < 5
+# define _GL_HAS_BUILTIN_UNREACHABLE 0
+# elif 4 < __GNUC__ + (5 <= __GNUC_MINOR__)
+# define _GL_HAS_BUILTIN_UNREACHABLE 1
+# elif defined __has_builtin
+# define _GL_HAS_BUILTIN_UNREACHABLE __has_builtin (__builtin_unreachable)
+# else
+# define _GL_HAS_BUILTIN_UNREACHABLE 0
+# endif
#endif
/* Each of these macros verifies that its argument R is nonzero. To
diff --git a/lib/warn-on-use.h b/lib/warn-on-use.h
index 8f4d40dcbeb..701013a07f4 100644
--- a/lib/warn-on-use.h
+++ b/lib/warn-on-use.h
@@ -32,6 +32,10 @@
_GL_WARN_ON_USE_ATTRIBUTE is for functions with 'static' or 'inline'
linkage.
+ _GL_WARN_ON_USE should not be used more than once for a given function
+ in a given compilation unit (because this may generate a warning even
+ if the function is never called).
+
However, one of the reasons that a function is a portability trap is
if it has the wrong signature. Declaring FUNCTION with a different
signature in C is a compilation error, so this macro must use the
diff --git a/lib/xalloc-oversized.h b/lib/xalloc-oversized.h
index 2be82cd275d..7f30f83e769 100644
--- a/lib/xalloc-oversized.h
+++ b/lib/xalloc-oversized.h
@@ -1,7 +1,6 @@
/* xalloc-oversized.h -- memory allocation size checking
- Copyright (C) 1990-2000, 2003-2004, 2006-2024 Free Software
- Foundation, Inc.
+ Copyright (C) 1990-2000, 2003-2004, 2006-2024 Free Software Foundation, Inc.
This file is free software: you can redistribute it and/or modify
it under the terms of the GNU Lesser General Public License as
@@ -30,8 +29,7 @@
is SIZE_MAX - 1. */
#define __xalloc_oversized(n, s) \
((s) != 0 \
- && ((size_t) (PTRDIFF_MAX < SIZE_MAX ? PTRDIFF_MAX : SIZE_MAX - 1) / (s) \
- < (n)))
+ && (PTRDIFF_MAX < SIZE_MAX ? PTRDIFF_MAX : SIZE_MAX - 1) / (s) < (n))
/* Return 1 if and only if an array of N objects, each of size S,
cannot exist reliably because its total size in bytes would exceed
@@ -49,13 +47,13 @@
#if 7 <= __GNUC__ && !defined __clang__ && PTRDIFF_MAX < SIZE_MAX
# define xalloc_oversized(n, s) \
__builtin_mul_overflow_p (n, s, (ptrdiff_t) 1)
-#elif (5 <= __GNUC__ && !defined __ICC && !__STRICT_ANSI__ \
- && PTRDIFF_MAX < SIZE_MAX)
+#elif 5 <= __GNUC__ && !defined __ICC && PTRDIFF_MAX < SIZE_MAX
# define xalloc_oversized(n, s) \
(__builtin_constant_p (n) && __builtin_constant_p (s) \
? __xalloc_oversized (n, s) \
- : ({ ptrdiff_t __xalloc_count; \
- __builtin_mul_overflow (n, s, &__xalloc_count); }))
+ : __extension__ \
+ ({ ptrdiff_t __xalloc_count; \
+ __builtin_mul_overflow (n, s, &__xalloc_count); }))
/* Other compilers use integer division; this may be slower but is
more portable. */
diff --git a/lisp/ChangeLog.13 b/lisp/ChangeLog.13
index d5ff28d9bcd..414cd1d25f8 100644
--- a/lisp/ChangeLog.13
+++ b/lisp/ChangeLog.13
@@ -4251,7 +4251,7 @@
* doc-view.el (doc-view-mode): Support tramp, compressed files and
files inside archives uniformly.
-2008-01-09 Eric S. Raymond <esr@snark.thyrsus.com>
+2008-01-09 Eric S. Raymond <esr@thyrsus.com>
* textmodes/sgml-mode.el (sgml-tag-syntax-table): Initialize this
constant with a computation on sgml-specials rather than a literal
@@ -4656,7 +4656,7 @@
(vc-git-dir-state): Use it instead of processing the status
results here.
-2008-01-02 Eric S. Raymond <esr@snark.thyrsus.com>
+2008-01-02 Eric S. Raymond <esr@thyrsus.com>
* progmodes/grep.el (grep-find-ignored-directories):
Initialize from the value of vc-directory-exclusion-list.
@@ -4718,7 +4718,7 @@
MS-Windows and MS-DOS.
(ispell-grep-options): Use "-Ei" on MS-Windows and MS-DOS.
-2008-01-02 Eric S. Raymond <esr@snark.thyrsus.com>
+2008-01-02 Eric S. Raymond <esr@thyrsus.com>
* vc-svn.el (vc-svn-modify-change comment): New function.
@@ -4727,7 +4727,7 @@
* vc-git.el (vc-git-dir-state): Set the vc-backend property.
Do not disable undo, with-temp-buffer does it by default.
-2008-01-01 Eric S. Raymond <esr@snark.thyrsus.com>
+2008-01-01 Eric S. Raymond <esr@thyrsus.com>
* vc-svn.el (vc-svn-parse-status): Set the `unregistered' property
correctly.
@@ -4802,7 +4802,7 @@
* vc-hg.el (vc-hg-dir-state): Set the vc-backend property.
-2007-12-29 Eric S. Raymond <esr@snark.thyrsus.com>
+2007-12-29 Eric S. Raymond <esr@thyrsus.com>
* vc-svn.el (vc-svn-parse-status): Recognize 'unregistered,
'added, 'removed.
@@ -4943,7 +4943,7 @@
* menu-bar.el (menu-bar-describe-menu): Remove dots from menu text.
-2007-12-28 Eric S. Raymond <esr@snark.thyrsus.com>
+2007-12-28 Eric S. Raymond <esr@thyrsus.com>
* vc-hooks.el, vc.el: Move vc-directory-exclusion-list from vc.el
to vc-hooks.el so it will be available to other modes, such as
@@ -4997,7 +4997,7 @@
* calc/calccomp.el (math-to-percentsigns): Change placeholder
for percent signs.
-2007-12-27 Eric S. Raymond <esr@snark.thyrsus.com>
+2007-12-27 Eric S. Raymond <esr@thyrsus.com>
* vc.el (vc-dired-ignorable-p, vc-dired-hook): Speed optimization;
use completion-ignored-extensions to detect files that should be
@@ -5015,7 +5015,7 @@
(ps-print-preprint-region): Use `ps-mark-active-p' instead of
`region-active-p' for error checking.
-2007-12-27 Eric S. Raymond <esr@snark.thyrsus.com>
+2007-12-27 Eric S. Raymond <esr@thyrsus.com>
* vc.el, vc-sccs.el, vc-rcs.el, vc-cvs.el, vc-mcvs.el:
Put new machinery in place to support editing of change comments
@@ -5029,7 +5029,7 @@
* international/mule-cmds.el (select-safe-coding-system):
When a buffer is modified, cancel the writing.
-2007-12-26 Eric S. Raymond <esr@snark.thyrsus.com>
+2007-12-26 Eric S. Raymond <esr@thyrsus.com>
* log-view.el: Add Subversion and Mercurial log format samples.
@@ -7753,7 +7753,7 @@
* textmodes/remember.el (remember-buffer):
Use define-obsolete-function-alias rather than defalias.
-2007-11-03 Ulrich Mueller <ulm@gentoo.org> (tiny change)
+2007-11-03 Ulrich Müller <ulm@gentoo.org> (tiny change)
* simple.el (bad-packages-alist): Anchor semantic regexp.
@@ -9147,7 +9147,7 @@
don't try other `or' branches regardless of the value returned by
fill-region; just return t.
-2007-10-20 Eric S. Raymond <esr@snark.thyrsus.com>
+2007-10-20 Eric S. Raymond <esr@thyrsus.com>
* vc.el (vc-do-command): Condition out a misleading message when
running asynchronously.
@@ -9197,7 +9197,7 @@
* vc-hg.el: Require log-view at compile time.
-2007-10-20 Eric S. Raymond <esr@snark.thyrsus.com>
+2007-10-20 Eric S. Raymond <esr@thyrsus.com>
* log-view.el (log-view-diff): Adapt log-view-diff for new VC API.
@@ -9812,7 +9812,7 @@
* bs.el (bs--mark-unmark): New function.
(bs-mark-current, bs-unmark-current): Use it.
-2007-10-11 Eric S. Raymond <esr@snark.thyrsus.com>
+2007-10-11 Eric S. Raymond <esr@thyrsus.com>
* vc.el (vc-diff):
(vc-diff-internal): Merge a patch by Juanma Barranquero. Also,
@@ -9830,7 +9830,7 @@
Use `follow-call-process-filter' rather than `process-filter'.
Simplify.
-2007-10-11 Eric S. Raymond <esr@snark.thyrsus.com>
+2007-10-11 Eric S. Raymond <esr@thyrsus.com>
* vc-hooks.el (vc-registered): Robustify this function a bit
against filenames with no directory component.
@@ -9919,7 +9919,7 @@
* help-fns.el (describe-variable): Add missing " " for multiline
obsolescence info and missing EOL after global value.
-2007-10-10 Eric S. Raymond <esr@snark.thyrsus.com>
+2007-10-10 Eric S. Raymond <esr@thyrsus.com>
* add-log.el:
* ediff-vers.el:
@@ -9950,7 +9950,7 @@
mode" in docstrings and messages.
(follow-menu-filter): Fix arg passed to `bound-and-true-p'.
-2007-10-10 Eric S. Raymond <esr@snark.thyrsus.com>
+2007-10-10 Eric S. Raymond <esr@thyrsus.com>
* vc.el (vc-next-action): Rewrite completely; this principal
entry point now operates on a current fileset selected either
@@ -10329,7 +10329,7 @@
(smerge-refine-subst): New function holding most of smerge-refine.
(smerge-refine): Use it.
-2007-10-08 Eric S. Raymond <esr@snark.thyrsus.com>
+2007-10-08 Eric S. Raymond <esr@thyrsus.com>
* vc.el (vc-default-wash-log): Remove unused code, the
log washers all live in the backends now.
@@ -10390,7 +10390,7 @@
* net/tramp-fish.el (tramp-fish-handle-process-file):
Rewrite temporary file handling.
-2007-10-06 Eric S. Raymond <esr@snark.thyrsus.com>
+2007-10-06 Eric S. Raymond <esr@thyrsus.com>
* vc.el: Workfile version -> focus version change. Port various
comments from new VC to reduce the noise in the diff.
@@ -12516,7 +12516,7 @@
* net/tramp-ftp.el (top): Autoload `tramp-set-connection-property'.
(tramp-ftp-file-name-handler): Set "started" property.
-2007-08-24 Ulrich Mueller <ulm@gentoo.org> (tiny change)
+2007-08-24 Ulrich Müller <ulm@gentoo.org> (tiny change)
* files.el (backup-buffer-copy): Don't wrap delete in
condition-case, only try to delete if file exists.
@@ -12758,7 +12758,7 @@
2007-08-20 Thien-Thi Nguyen <ttn@gnuvola.org>
* vc-rcs.el (vc-rcs-annotate-command):
- Fix bug introduced 2007-07-18T16:32:40Z!esr@snark.thyrsus.com:
+ Fix bug introduced 2007-07-18T16:32:40Z!esr@thyrsus.com:
Add back :vc-annotate-prefix propertization.
2007-08-20 Andreas Schwab <schwab@suse.de>
@@ -14226,7 +14226,7 @@
* vc-hooks.el (vc-find-root): Walk up the tree to find an existing
`file' from which to start the search.
-2007-07-19 Eric S. Raymond <esr@snark.thyrsus.com>
+2007-07-19 Eric S. Raymond <esr@thyrsus.com>
* vc-cvs.el (vc-cvs-checkin, vc-cvs-diff): Finish transition from
having a single file argument to having a list of files as the
@@ -14245,7 +14245,7 @@
* uniquify.el: Docstring fixes.
-2007-07-18 Eric S. Raymond <esr@snark.thyrsus.com>
+2007-07-18 Eric S. Raymond <esr@thyrsus.com>
* vc.el (revision-granularity, create-repo): Document new vc
backend properties.
diff --git a/lisp/ChangeLog.14 b/lisp/ChangeLog.14
index f62f57dc85a..3d6df493041 100644
--- a/lisp/ChangeLog.14
+++ b/lisp/ChangeLog.14
@@ -39,7 +39,7 @@
* language/korean.el (korean-cp949): New coding system. Set cp949
as an alias to it.
-2009-06-18 Ulrich Mueller <ulm@gentoo.org>
+2009-06-18 Ulrich Müller <ulm@gentoo.org>
* pgg-gpg.el (pgg-gpg-lookup-key-owner): Handle colon listings
format used by GnuPG 2.0.11.
@@ -459,7 +459,7 @@
* subr.el (assoc-default): Doc fix.
-2009-04-29 Ulrich Mueller <ulm@gentoo.org>
+2009-04-29 Ulrich Müller <ulm@gentoo.org>
* files.el (hack-local-variables-prop-line)
(hack-local-variables, dir-locals-read-from-file):
@@ -3281,7 +3281,7 @@
(ispell-find-aspell-dictionaries): Better error message. Use correct
dictionary alist for default. Better fallback default dictionary.
-2009-01-16 Ulrich Mueller <ulm@kph.uni-mainz.de>
+2009-01-16 Ulrich Müller <ulm@kph.uni-mainz.de>
* international/quail.el (quail-insert-kbd-layout):
Delete superfluous handling of 8-bit code. (Bug#1418)
@@ -3736,7 +3736,7 @@
* simple.el (visual-line-mode-map): Remove M-[ and M-] bindings.
-2009-01-04 Ulrich Mueller <ulm@kph.uni-mainz.de>
+2009-01-04 Ulrich Müller <ulm@kph.uni-mainz.de>
* progmodes/sh-script.el (sh-ancestor-alist): Doc fix.
@@ -4380,7 +4380,7 @@
2008-12-10 Juanma Barranquero <lekktu@gmail.com>
* net/tramp.el (top): Don't fail if there is no current message.
- [Ulrich Mueller sent a patch, which I saw too late.] (Bug#1514)
+ [Ulrich Müller sent a patch, which I saw too late.] (Bug#1514)
2008-12-10 Kenichi Handa <handa@m17n.org>
@@ -5317,7 +5317,7 @@
(math-standard-units): Fix typo in constant's description.
(math-additional-units): Fix typo in docstring.
-2008-11-19 Ulrich Mueller <ulm@kph.uni-mainz.de>
+2008-11-19 Ulrich Müller <ulm@kph.uni-mainz.de>
* calc/calc-units.el (math-standard-units): Add eps0,
permittivity of vacuum.
@@ -6087,7 +6087,7 @@
* progmodes/gud.el (gud-tooltip-mode): Use `tooltip-functions'.
-2008-10-29 Ulrich Mueller <ulm@gentoo.org>
+2008-10-29 Ulrich Müller <ulm@gentoo.org>
* server.el (server-socket-dir): Use TMPDIR (default /tmp) instead
of hardcoded /tmp.
@@ -6284,7 +6284,7 @@
* pcmpl-rpm.el (pcomplete/rpm): Make "rpm -qp" use file completion.
-2008-10-23 Ulrich Mueller <ulm@kph.uni-mainz.de>
+2008-10-23 Ulrich Müller <ulm@kph.uni-mainz.de>
* international/mule-cmds.el (describe-language-environment):
Indent sample text.
@@ -7198,7 +7198,7 @@
* play/fortune.el (fortune-program-options): Change to a list.
(fortune-in-buffer): Use apply.
-2008-09-20 Ulrich Mueller <ulm@kph.uni-mainz.de>
+2008-09-20 Ulrich Müller <ulm@kph.uni-mainz.de>
* emacs-lisp/authors.el: Change encoding of file to utf-8.
(authors-coding-system): Likewise.
@@ -12125,7 +12125,7 @@
* vc-dispatcher.el (top-level): Revert previous change: require cl
when compiling.
-2008-05-16 Eric S. Raymond <esr@snark.thyrsus.com>
+2008-05-16 Eric S. Raymond <esr@thyrsus.com>
* vc.el (vc-default-status-printer)
(vc-default-prettify-state-info): Enhance the state prettyprinter
@@ -12143,7 +12143,7 @@
* net/tramp.el (tramp-handle-write-region): Fix check for short track.
Reported by Glenn Morris <rgm@gnu.org>.
-2008-05-16 Eric S. Raymond <esr@snark.thyrsus.com>
+2008-05-16 Eric S. Raymond <esr@thyrsus.com>
* vc.el: Remove my analysis of SCCS/RCS concurrency issues from
the end of the file, it was good work at one time but has been
@@ -12179,7 +12179,7 @@
(ses-mode): Set indent-tabs-mode to nil.
(ses-center): Use string-width rather than length.
-2008-05-15 Eric S. Raymond <esr@snark.thyrsus.com>
+2008-05-15 Eric S. Raymond <esr@thyrsus.com>
* vc-cvs.el, vc-git.el, vc-hg.el, vc-hooks.el, vc-mcvs.el,
* vc-rcs.el, vc-sccs.el, vc-svn.el, vc.el:
@@ -12204,7 +12204,7 @@
* progmodes/cc-mode.el (declare-function): Add compat definition.
(awk-mode-syntax-table, c-awk-unstick-NL-prop): Declare for compiler.
-2008-05-14 Eric S. Raymond <esr@snark.thyrsus.com>
+2008-05-14 Eric S. Raymond <esr@thyrsus.com>
* vc-dispatcher.el (vc-dispatcher-selection): Change the returned
list to a cons so the caller can get back both expanded and
@@ -12251,7 +12251,7 @@
(tramp-echo-mark-marker): New defconst.
(tramp-check-for-regexp): Use it.
-2008-05-14 Eric S. Raymond <esr@snark.thyrsus.com>
+2008-05-14 Eric S. Raymond <esr@thyrsus.com>
* vc.el (vc-deduce-fileset): Do the right thing when visiting a
buffer (say, a log buffer or diff buffer) with a vc-dir buffer
@@ -12343,7 +12343,7 @@
(dired-toggle-marks, dired-change-marks, dired-unmark-all-files):
buffer-read-only -> inhibit-read-only.
-2008-05-12 Eric S. Raymond <esr@snark.thyrsus.com>
+2008-05-12 Eric S. Raymond <esr@thyrsus.com>
* vc.el (vc-expand-dirs): Stop this function from tossing out
explicitly specified files.
@@ -12395,7 +12395,7 @@
* emulation/cua-base.el: Put isearch-scroll property
on cua-scroll-up and cua-scroll-down.
-2008-05-11 Eric S. Raymond <esr@snark.thyrsus.com>
+2008-05-11 Eric S. Raymond <esr@thyrsus.com>
* vc-hooks.el (vc-recompute-state): Remove (dead code).
@@ -12416,7 +12416,7 @@
* smerge-mode.el (smerge-command-prefix): Fix custom type.
-2008-05-10 Eric S. Raymond <esr@snark.thyrsus.com>
+2008-05-10 Eric S. Raymond <esr@thyrsus.com>
* vc-dispatcher.el (vc-dir-next-directory, vc-dir-prev-directory):
New functions implementing motion to next and previous directory.
@@ -12449,7 +12449,7 @@
* vc-hooks.el (vc-prefix-map): Remove duplicate binding.
-2008-05-09 Eric S. Raymond <esr@snark.thyrsus.com>
+2008-05-09 Eric S. Raymond <esr@thyrsus.com>
* vc.el (vc-dir):
* vc-hooks.el: Tweak the VC directory bindings. These are now
@@ -12466,7 +12466,7 @@
* simple.el (start-file-process): Clarify docstring.
-2008-05-09 Eric S. Raymond <esr@snark.thyrsus.com>
+2008-05-09 Eric S. Raymond <esr@thyrsus.com>
* vc-sccs.el, vc-svn.el, vc-git.el, vc-hg.el, vc-mtn.el:
Remove stub implementations of, and references to, wash-log.
@@ -12515,7 +12515,7 @@
* vc.el (vc-version-diff, vc-print-log, vc-revert, vc-rollback)
(vc-update): Remove unused let bindings.
-2008-05-09 Eric S. Raymond <esr@snark.thyrsus.com>
+2008-05-09 Eric S. Raymond <esr@thyrsus.com>
* vc.el (vc-deduce-fileset, vc-next-action, vc-version-diff)
(vc-diff, vc-revert, vc-rollback, vc-update):
@@ -12609,7 +12609,7 @@
(robin-current-package-name): Doc fix.
(robin-activate): Don't use `iff' in docstring.
-2008-05-07 Eric S. Raymond <esr@snark.thyrsus.com>
+2008-05-07 Eric S. Raymond <esr@thyrsus.com>
* vc.el, vc-dispatcher.el: VC-Dired support removed.
The code uses a ewoc-based implementation now.
@@ -12639,7 +12639,7 @@
* progmodes/fortran.el (fortran-mode): Fix font-lock-syntactic-keywords
oddness.
-2008-05-06 Eric S. Raymond <esr@snark.thyrsus.com>
+2008-05-06 Eric S. Raymond <esr@thyrsus.com>
* vc-hooks.el (vc-find-file-hook):
* vc-dispatcher.el (vc-resynch-window): Decouple vc-dispatcher
@@ -12692,7 +12692,7 @@
* dired.el (dired-read-dir-and-switches): Fix up last change.
-2008-05-05 Eric S. Raymond <esr@snark.thyrsus.com>
+2008-05-05 Eric S. Raymond <esr@thyrsus.com>
* vc.el (vc-deduce-fileset): Lift all the policy and UI stuff
out of this function, move it to vc-dispatcher-selection-set.
@@ -12770,7 +12770,7 @@
* ls-lisp.el (ls-lisp-insert-directory): Use `string-width'
instead of `length' for comparing length of user and group names.
-2008-05-03 Eric S. Raymond <esr@snark.thyrsus.com>
+2008-05-03 Eric S. Raymond <esr@thyrsus.com>
* vc-dispatcher.el: New file, separates out the UI and command
execution machinery from VCS-specific logic left in vc.el.
@@ -12789,7 +12789,7 @@
* progmodes/grep.el (grep-mode-map): Bind "g" to recompile (like
in dired &c).
-2008-05-02 Eric S. Raymond <esr@snark.thyrsus.com>
+2008-05-02 Eric S. Raymond <esr@thyrsus.com>
* vc-arch.el, vc-bzr.el, vc-cvs.el, vc-git.el, vc-hg.el,
* vc-hooks.el, vc-mcvs.el, vc-mtn.el, vc-rcs.el, vc-sccs.el,
@@ -12846,7 +12846,7 @@
function that is no longer there.
(hilit-chg-set): Remove running of highlight-changes-enable-hook.
-2008-05-02 Eric S. Raymond <esr@snark.thyrsus.com>
+2008-05-02 Eric S. Raymond <esr@thyrsus.com>
* vc.el (vc-default-dired-state-info): Change name of primitive
to prettify-state-info, in preparation for ripping out dired mode.
@@ -12879,7 +12879,7 @@
* progmodes/compile.el (compilation-auto-jump):
Set window point to `pos' explicitly.
-2008-05-01 Eric S. Raymond <esr@snark.thyrsus.com>
+2008-05-01 Eric S. Raymond <esr@thyrsus.com>
* vc-bzr.el (vc-bzr-state): Allow this to return 'ignored
when appropriate.
diff --git a/lisp/ChangeLog.15 b/lisp/ChangeLog.15
index 000821ee6d1..a441dc46ad3 100644
--- a/lisp/ChangeLog.15
+++ b/lisp/ChangeLog.15
@@ -3931,7 +3931,7 @@
* emacs-lisp/autoload.el (autoload-find-destination): The function
coding-system-eol-type may return non-numeric values. (Bug#7414)
-2010-11-18 Ulrich Mueller <ulm@gentoo.org>
+2010-11-18 Ulrich Müller <ulm@gentoo.org>
* server.el (server-force-stop): Ensure the server is stopped (Bug#7409).
@@ -6386,7 +6386,7 @@
* eshell/esh-util.el, eshell/esh-var.el:
Remove leading `*' from docs of faces and defcustoms.
-2010-09-25 Ulrich Mueller <ulm@gentoo.org>
+2010-09-25 Ulrich Müller <ulm@gentoo.org>
* eshell/em-ls.el (eshell-ls-archive-regexp):
* eshell/esh-util.el (eshell-tar-regexp):
@@ -11888,7 +11888,7 @@
(log-edit-mode, log-edit-extra-flags, log-edit-mode):
New declarations.
-2010-04-09 Eric Raymond <esr@snark.thyrsus.com>
+2010-04-09 Eric S. Raymond <esr@thyrsus.com>
* vc-hooks.el, vc-git.el: Improve documentation comments.
@@ -14485,7 +14485,7 @@
color queries. Recompute faces after getting the background
color.
-2009-12-07 Ulrich Mueller <ulm@gentoo.org>
+2009-12-07 Ulrich Müller <ulm@gentoo.org>
* emacs-lisp/bytecomp.el (byte-compile-insert-header): Put the version
number comment back on its own line, for easier parsing.
@@ -17532,7 +17532,7 @@
(flyspell-word-search-backward): Remove nil argument in calls to
flyspell-get-word, since it is not needed now.
-2009-10-17 Ulrich Mueller <ulm@gentoo.org>
+2009-10-17 Ulrich Müller <ulm@gentoo.org>
* play/doctor.el (doctor-adverbp): Exclude some nouns. (Bug#4565)
diff --git a/lisp/ChangeLog.16 b/lisp/ChangeLog.16
index 35a8e44ed5e..fa956ac8784 100644
--- a/lisp/ChangeLog.16
+++ b/lisp/ChangeLog.16
@@ -10665,8 +10665,7 @@
* textmodes/rst.el: Add comments.
(rst-transition, rst-adornment): New faces.
(rst-adornment-faces-alist): Make default safe to reevaluate.
- Fixes
- http://sourceforge.net/tracker/?func=detail&atid=422030&aid=3479603&group_id=38414.
+ Fixes https://sourceforge.net/p/docutils/bugs/180/.
Improve customization tags.
(rst-define-level-faces): Clarify meaning.
@@ -15383,7 +15382,7 @@
* calendar/calendar.el (calendar-mode):
Locally set scroll-margin to 0. (Bug#10379)
-2012-01-06 Ulrich Mueller <ulm@gentoo.org>
+2012-01-06 Ulrich Müller <ulm@gentoo.org>
* play/doctor.el (doctor-death): Escape "," characters. (Bug#10370)
@@ -17134,7 +17133,7 @@
(mouse-drag-vertical-line): Call mouse-drag-line.
* window.el (window-at-side-p, windows-at-side): New functions.
-2011-10-21 Ulrich Mueller <ulm@gentoo.org>
+2011-10-21 Ulrich Müller <ulm@gentoo.org>
* tar-mode.el (tar-grind-file-mode):
Fix handling of setuid/setgid, handle sticky bit. (Bug#9817)
diff --git a/lisp/ChangeLog.17 b/lisp/ChangeLog.17
index cd1ceb2daef..0e69fd5e461 100644
--- a/lisp/ChangeLog.17
+++ b/lisp/ChangeLog.17
@@ -4218,7 +4218,7 @@
(package-activate-1): Reload files given by `package--list-loaded-files'.
Fix bug#10125, bug#18443, and bug#18448.
-2014-12-13 Eric S. Raymond <esr@snark.thyrsus.com>
+2014-12-13 Eric S. Raymond <esr@thyrsus.com>
* vc/vc-svn.el (vc-svn-diff): Fix bug #19312.
@@ -4253,7 +4253,7 @@
* files.el (directory-files-recursively): Don't follow symlinks to
other directories.
-2014-12-12 Eric S. Raymond <esr@snark.thyrsus.com>
+2014-12-12 Eric S. Raymond <esr@thyrsus.com>
* vc/vc-dav.el, vc/vc-git.el, vc/vc-hg.el, vc/vc-src.el:
* vc/vc.el: latest-on-branch-p is no longer a public method.
@@ -4276,7 +4276,7 @@
* emacs-lisp/let-alist.el: Add new package and macro.
-2014-12-10 Eric S. Raymond <esr@snark.thyrsus.com>
+2014-12-10 Eric S. Raymond <esr@thyrsus.com>
* vc/vc-dispatcher.el, vc/vc-hooks.el, vc/vc-rcs.el:
* vc/vc-sccs.el, vc/vc.el: Righteous featurectomy of vc-keep-workfiles,
@@ -4308,7 +4308,7 @@
(ruby-toggle-string-quotes): New command that allows you to quickly
toggle between single-quoted and double-quoted string literals.
-2014-12-09 Eric S. Raymond <esr@snark.thyrsus.com>
+2014-12-09 Eric S. Raymond <esr@thyrsus.com>
* vc/vc-src.el (vc-src-do-comand): Prepend -- to file argument
list, avoids problems witt names containing hyphens.
@@ -4429,7 +4429,7 @@
* vc/vc-hg.el (vc-hg-dir-status-files): Only include ignores files
when FILES is non-nil (bug#19304).
-2014-12-08 Eric S. Raymond <esr@snark.thyrsus.com>
+2014-12-08 Eric S. Raymond <esr@thyrsus.com>
* vc/vc-arch.el: Move to obsolete directory so a test framework
won't trip over bit-rot in it. There has been no Arch snapshot
@@ -4593,7 +4593,7 @@
more extensions when generating includes (programs)
(bug#19254).
-2014-12-03 Eric S. Raymond <esr@snark.thyrsus.com>
+2014-12-03 Eric S. Raymond <esr@thyrsus.com>
* files.el (file-tree-walk): Fix docstring.
@@ -4636,7 +4636,7 @@
* whitespace.el (whitespace-big-indent-regexp): Add :version.
-2014-12-02 Eric S. Raymond <esr@snark.thyrsus.com>
+2014-12-02 Eric S. Raymond <esr@thyrsus.com>
* subr.el (filter): New macro. Because it's just silly for a Lisp
not to have this in 2014. And VC needs it.
@@ -4659,7 +4659,7 @@
is no longer a public method. It is now local to the one place
it's used, in the RCS steal-lock method.
-2014-12-01 Eric S. Raymond <esr@snark.thyrsus.com>
+2014-12-01 Eric S. Raymond <esr@thyrsus.com>
* vc/vc.el: In all backends: API simplification; could-register
is no longer a public method. (vc-cvs.el still has a private
@@ -4772,7 +4772,7 @@
* net/eww.el (eww): Leave point in a place that doesn't cause
scrolling when displaying "Loading...".
-2014-12-01 Eric S. Raymond <esr@snark.thyrsus.com>
+2014-12-01 Eric S. Raymond <esr@thyrsus.com>
* vc/vc.el, vc/vc-cvs.el, vc/vc-rcs.el, vc/vc-svn.el: The 'merge'
backend method of RCS/CVS/SVN is now 'merge-file', to contrast with
@@ -4791,7 +4791,7 @@
* emacs-lisp/inline.el: New file.
-2014-12-01 Eric S. Raymond <esr@snark.thyrsus.com>
+2014-12-01 Eric S. Raymond <esr@thyrsus.com>
* vc/vc.el, vc-hooks.el: All backends: API simplification;
vc-state-heuristic is no longer a public method, having been
@@ -5226,7 +5226,7 @@
* vc/vc.el: Fix a typo in the commentary.
-2014-11-20 Eric S. Raymond <esr@snark.thyrsus.com>
+2014-11-20 Eric S. Raymond <esr@thyrsus.com>
* vc/vc-src.el, vc/vc.el: Added support for SRC. Needs more
testing and a real log-view mode.
@@ -24676,7 +24676,7 @@
* frame.el (display-monitor-attributes-list): Add NS case.
(ns-display-monitor-attributes-list): Declare.
-2013-05-09 Ulrich Mueller <ulm@gentoo.org>
+2013-05-09 Ulrich Müller <ulm@gentoo.org>
* descr-text.el (describe-char): Fix %d/%x typo. (Bug#14360)
diff --git a/lisp/ChangeLog.3 b/lisp/ChangeLog.3
index 5e651e8dccf..843492958dd 100644
--- a/lisp/ChangeLog.3
+++ b/lisp/ChangeLog.3
@@ -990,7 +990,7 @@
(compilation-minor-mode): New function to toggle
compilation-minor-mode; if setting it, call compilation-setup.
-1993-04-28 Eric S. Raymond (eric@mole.gnu.ai.mit.edu)
+1993-04-28 Eric S. Raymond (esr@thyrsus.com)
* bibtex.el: Installed Aaron Larson's new bibtex.el. See the
header comment for details.
@@ -1004,7 +1004,7 @@
* files.el (file-truename): Undo last change.
-1993-04-27 Eric S. Raymond (eric@mole.gnu.ai.mit.edu)
+1993-04-27 Eric S. Raymond (esr@thyrsus.com)
* files.el (file-truename): Do the right thing when $HOME = "".
@@ -1058,7 +1058,7 @@
(find-tag-noselect): If NEXT-P is '-, pop location off
tags-location-stack.
-1993-04-26 Eric S. Raymond (eric@mole.gnu.ai.mit.edu)
+1993-04-26 Eric S. Raymond (esr@thyrsus.com)
* cmacexp.el: Installed Francesco Potortì's enhanced and
cleaned-up version, see its commentary for details.
@@ -1070,13 +1070,13 @@
Defvars added for many variables.
(te-stty-string): Specify the characters explicitly--not `stty dec'.
-1993-04-26 Eric S. Raymond (eric@mole.gnu.ai.mit.edu)
+1993-04-26 Eric S. Raymond (esr@thyrsus.com)
* files.el (cd): Handle leading "~" like an absolute filename.
* dired.el: Changed fsets to defaliases.
-1993-04-25 Eric S. Raymond (eric@mole.gnu.ai.mit.edu)
+1993-04-25 Eric S. Raymond (esr@thyrsus.com)
* comint.el (comint-mod): Nuked. A call to ring-mod replaces it.
(comint-mem): Nuked. A call to member replaces it.
@@ -1099,7 +1099,7 @@
(vc-finish-logentry, vc-next-comment, vc-previous-comment):
Replace *VC-comment-buffer* with a ring vector.
-1993-04-25 Eric S. Raymond (eric@mole.gnu.ai.mit.edu)
+1993-04-25 Eric S. Raymond (esr@thyrsus.com)
* simple.el (down-arrow): New function.
Uses next-line-add-newlines to suppress addition of new lines at end of
@@ -1138,11 +1138,11 @@
* shell.el (shell-prompt-pattern): Add `;' as potential prompt
delimiter (for `es' and `rc' shells most particularly).
-1993-04-23 Eric S. Raymond (eric@mole.gnu.ai.mit.edu)
+1993-04-23 Eric S. Raymond (esr@thyrsus.com)
* isearch.el: Replaced all fsets with defaliases.
-1993-04-23 Eric S. Raymond (eric@mole.gnu.ai.mit.edu)
+1993-04-23 Eric S. Raymond (esr@thyrsus.com)
* bytecomp.el (define-function): Change name back to defaliases
to get things in a known-good state. The unload patch had been
@@ -1190,7 +1190,7 @@
* ange-ftp.el (ange-ftp-binary-file-name-regexp):
Match .z and .z-part-?? files.
-1993-04-21 Eric S. Raymond (eric@mole.gnu.ai.mit.edu)
+1993-04-21 Eric S. Raymond (esr@thyrsus.com)
* makefile.el: Rewritten and simplified, commentary added. It now
will usually detect when the makefile target or macro lists need
@@ -1223,7 +1223,7 @@
* sendmail.el (mail-do-fcc): Make a numeric time zone indicator
with current-time-zone--don't run `date'.
-1993-04-16 Eric S. Raymond (eric@mole.gnu.ai.mit.edu)
+1993-04-16 Eric S. Raymond (esr@thyrsus.com)
* bytecomp.el (byte-compile, byte-compile-keep-pending)
(byte-compile-file-form-defmumble): Generate define-function
@@ -1237,7 +1237,7 @@
* diff.el (diff-parse-differences): Small robustification ---
don't lose if we call this with compilation-parsing-end nil
-1993-04-16 Eric S. Raymond (eric@mole.gnu.ai.mit.edu)
+1993-04-16 Eric S. Raymond (esr@thyrsus.com)
* electric.el (shrink-window-if-larger-than-buffer):
Move to window.el.
@@ -1286,14 +1286,14 @@
* isearch.el: Doc fixes.
-1993-04-14 Eric S. Raymond (eric@mole.gnu.ai.mit.edu)
+1993-04-14 Eric S. Raymond (esr@thyrsus.com)
* gud.el (gud-mode): Created C-c synonym bindings in the GUD
buffer's local map.
(gud-key-prefix): Change to C-x C-a.
-1993-04-14 Eric S. Raymond (eric@mole.gnu.ai.mit.edu)
+1993-04-14 Eric S. Raymond (esr@thyrsus.com)
* help-macro.el: Name changed from help-screen.el to fit in a
14-character limit.
@@ -1301,7 +1301,7 @@
* sun-curs.el: Name changed from sun-cursors.el to protect the
innocents.
-1993-04-14 Eric S. Raymond (eric@mole.gnu.ai.mit.edu)
+1993-04-14 Eric S. Raymond (esr@thyrsus.com)
* finder.el: Rewritten. The Finder is now a major mode with the
ability to browse package commentary sections and a completely
@@ -1352,7 +1352,7 @@
* rot13.el (rot13-other-window): Add autoload.
(rot13-display-table): Use `vector', not `make-rope'.
-1993-04-10 Eric S. Raymond (eric@mole.gnu.ai.mit.edu)
+1993-04-10 Eric S. Raymond (esr@thyrsus.com)
* gud.el (gdb, sdb, dbx): Improve prompting a la grep.
@@ -1369,7 +1369,7 @@
empty string in response to the keyword prompt, restore the old
window configuration properly.
-1993-04-09 Eric S. Raymond (eric@geech.gnu.ai.mit.edu)
+1993-04-09 Eric S. Raymond (esr@thyrsus.com)
* emerge.el (emerge-with-ancestor): Applied Donald Erway's fix
patch, which included the following explanatory comment: "D.Erway
@@ -1394,7 +1394,7 @@
* autoload.el (generate-file-autoloads): Doc fix.
-1993-04-08 Eric S. Raymond (eric@geech.gnu.ai.mit.edu)
+1993-04-08 Eric S. Raymond (esr@thyrsus.com)
* gud.el: Massive changes, amounting nearly to a rewrite. The new
features include auto-configuring support for SVr4, more commands,
@@ -1508,7 +1508,7 @@
Change MIPS RISC CC regexp (last one) to
be anchored at bol, and to never match multiple lines.
-1993-04-03 Eric S. Raymond (eric@geech.gnu.ai.mit.edu)
+1993-04-03 Eric S. Raymond (esr@thyrsus.com)
* man.el, assoc.el: Installed Barry Warsaw's new and much more
featureful man page browser.
@@ -1520,7 +1520,7 @@
* comint.el: New comint-read-noecho.
-1993-04-02 Eric S. Raymond (eric@geech.gnu.ai.mit.edu)
+1993-04-02 Eric S. Raymond (esr@thyrsus.com)
* chistory.el (repeat-history-command): Bug fix. Someone forgot a car.
@@ -1595,7 +1595,7 @@
editing ability and be able to abort when called from a process
filter. Re-arranged and updated docstring.
-1993-03-30 Eric S. Raymond (eric@mole.gnu.ai.mit.edu)
+1993-03-30 Eric S. Raymond (esr@thyrsus.com)
* ring.el: Changed summary line.
@@ -1611,7 +1611,7 @@
* buff-menu.el: Put back removed years in copyright notice.
-1993-03-29 Eric S. Raymond (eric@geech.gnu.ai.mit.edu)
+1993-03-29 Eric S. Raymond (esr@thyrsus.com)
* vc.el (vc-next-action, vc-print-log, vc-diff, vc-revert-buffer):
Improve logic for parent buffer finding.
@@ -1652,7 +1652,7 @@
rlogin-password-paranoia is set.
(rlogin-with-args, rlogin-password): New functions.
-1993-03-28 Eric S. Raymond (eric@geech.gnu.ai.mit.edu)
+1993-03-28 Eric S. Raymond (esr@thyrsus.com)
* vc.el (vc-comment-to-changelog): A useful vc-checkin hook, added.
(vc-checkout): Now rejects attempts to check out files via FTP.
@@ -1674,7 +1674,7 @@
* ebuff-menu.el (electric-buffer-menu-mode-map): fillarray isn't a
valid operation on maps any more.
-1993-03-27 Eric S. Raymond (eric@geech.gnu.ai.mit.edu)
+1993-03-27 Eric S. Raymond (esr@thyrsus.com)
* refer.el: Installed.
@@ -1682,7 +1682,7 @@
* lucid.el (try-face-font, find-face, get-face): New aliases.
-1993-03-27 Eric S. Raymond (eric@geech.gnu.ai.mit.edu)
+1993-03-27 Eric S. Raymond (esr@thyrsus.com)
* abbrevlist.el, old-inf-lisp.el, old-screen.el, old-shell.el,
* oshell.el: Removed.
@@ -1702,13 +1702,13 @@
(set-case-syntax-delims, set-case-syntax-pair, set-case-syntax):
Rename arg STRING to TABLE. Do not set the standard case table.
-1993-03-26 Eric S. Raymond (eric@geech.gnu.ai.mit.edu)
+1993-03-26 Eric S. Raymond (esr@thyrsus.com)
* loaddefs.el: Commented out function-key-error definition and
uses in the global keymaps. RMS and jimb objected to the amount
of space these took up in the keybinding listings.
-1993-03-27 Eric S. Raymond (eric@geech.gnu.ai.mit.edu)
+1993-03-27 Eric S. Raymond (esr@thyrsus.com)
* lpr.el (printify-buffer): Add, debugged from Roland McGrath's
printify-buffer code in LCD.
@@ -1739,7 +1739,7 @@
(set-visited-file-name): Kill local-write-file-hooks as local var.
(basic-save-buffer): Use local-write-file-hooks.
-1993-03-26 Eric S. Raymond (eric@geech.gnu.ai.mit.edu)
+1993-03-26 Eric S. Raymond (esr@thyrsus.com)
* yow.el (psychoanalyze-pinhead): Needed a prefrontal lobotomy.
I gave it one.
@@ -1752,7 +1752,7 @@
* uncompress.el: Add provide call.
-1993-03-25 Eric S. Raymond (eric@geech.gnu.ai.mit.edu)
+1993-03-25 Eric S. Raymond (esr@thyrsus.com)
* lisp-mnt.el (lm-last-modified-date): Fix return bug.
@@ -1784,7 +1784,7 @@
* term/x-win.el: Bind M-next to an alias scroll-other-window-1
to get better doc string output.
-1993-03-23 Eric S. Raymond (eric@geech.gnu.ai.mit.edu)
+1993-03-23 Eric S. Raymond (esr@thyrsus.com)
* compile.el: Fix library headers.
@@ -1793,7 +1793,7 @@
* files.el (insert-directory): Do chase symlinks before passing
the directory name to ls.
-1993-03-23 Eric S. Raymond (eric@geech.gnu.ai.mit.edu)
+1993-03-23 Eric S. Raymond (esr@thyrsus.com)
* buff-menu.el: Incorporated changes from Bob Weiner's enhanced
buff-menu from the LCD archive.
@@ -1802,7 +1802,7 @@
* replace.el (query-replace-map): Define backspace like delete.
-1993-03-22 Eric S. Raymond (eric@geech.gnu.ai.mit.edu)
+1993-03-22 Eric S. Raymond (esr@thyrsus.com)
* cookie.el: Created. This file contains what was formerly the
guts of spook.el, lightly hacked to support more than one
@@ -1822,7 +1822,7 @@
* term/x-win.el (x-win-suspend-error):
suspend-hook renamed from suspend-hooks.
-1993-03-22 Eric S. Raymond (eric@geech.gnu.ai.mit.edu)
+1993-03-22 Eric S. Raymond (esr@thyrsus.com)
* help.el, register.el, replace.el, reposition.el, rfc822.el,
* rlogin.el, rot13.el, scribe.el, scroll-bar.el, sendmail.el,
@@ -1835,14 +1835,14 @@
* diary-insert.el: Change the name to diary-ins.el.
* calendar.el: Change all autoload references to diary-ins.
-1993-03-22 Eric S. Raymond (eric@geech.gnu.ai.mit.edu)
+1993-03-22 Eric S. Raymond (esr@thyrsus.com)
* man.el, mlconvert.el, mlsupport.el, modula2.el, mouse.el,
* mpuz.el, netunam.el, novice.el, nroff-mode.el, options.el,
* outline.el, page.el, paragraphs.el, picture.el, prolog.el,
* rect.el: Add or correct Commentary sections.
-1993-03-22 Eric S. Raymond (eric@geech.gnu.ai.mit.edu)
+1993-03-22 Eric S. Raymond (esr@thyrsus.com)
* abbrev.el, ada.el, add-log.el, array.el, autoinsert.el,
* autoload.el, awk-mode.el, bib-mode.el, bibtex.el, buff-menu.el,
@@ -1889,19 +1889,19 @@
* lucid.el: Alias lower-screen and raise-screen to lower-frame and
raise-frame, the new names for those functions.
-1993-03-19 Eric S. Raymond (eric@geech.gnu.ai.mit.edu)
+1993-03-19 Eric S. Raymond (esr@thyrsus.com)
* bush.el: Deleted.
* finder.el: Make sure that when new keywords are compiled, we see them
immediately.
-1993-03-19 Eric S. Raymond (eric@geech.gnu.ai.mit.edu)
+1993-03-19 Eric S. Raymond (esr@thyrsus.com)
* vt100-led.el, bg-mouse.el, sup-mouse.el, sun-mouse.el:
Moved to term directory.
-1993-03-18 Eric S. Raymond (eric@geech.gnu.ai.mit.edu)
+1993-03-18 Eric S. Raymond (esr@thyrsus.com)
* Makefile: Created. This exists mainly so developers elsewhere
can unlock the lisp files to accept an update tar, then relock
@@ -1916,7 +1916,7 @@
* solar.el (solar-time-string): Round the time properly.
-1993-03-18 Eric S. Raymond (eric@geech.gnu.ai.mit.edu)
+1993-03-18 Eric S. Raymond (esr@thyrsus.com)
* abbrev.el, abbrevlist.el, add-log.el, apropos.el, array.el,
* autoload.el, awk-mode.el, cal-french.el, cal-mayan.el,
@@ -1938,7 +1938,7 @@
* tex-mode.el (tex-send-command): Fix the command sent so that no
blank is inserted when replacing the asterisk with the file name.
-1993-03-18 Eric S. Raymond (eric@mole.gnu.ai.mit.edu)
+1993-03-18 Eric S. Raymond (esr@thyrsus.com)
* term/wyse50.el (function-key-map): Nuke code no longer bound to keys.
@@ -1949,7 +1949,7 @@
Fix things so that bindings are added to the keymap already created by
terminal initialization.
-1993-03-17 Eric S. Raymond (eric@mole.gnu.ai.mit.edu)
+1993-03-17 Eric S. Raymond (esr@thyrsus.com)
* help-screen.el: Installed, following release. Now package
writers can easily implement help screens resembling Emacs's
@@ -1961,7 +1961,7 @@
* finder-inf.el: Deleted the RCS file.
-1993-03-17 Eric S. Raymond (eric@mole.gnu.ai.mit.edu)
+1993-03-17 Eric S. Raymond (esr@thyrsus.com)
* isearch.el, lselect.el, select.el, scroll-bar.el, texinfo.el,
* pending-del.el, profile.el, texinfmt.el, ls-lisp.el, meese.el,
@@ -1974,14 +1974,14 @@
* case-table.el, byte-run.el, ange-ftp.el, backquote.el:
Add or correct library header comments.
-1993-03-17 Eric S. Raymond (eric@mole.gnu.ai.mit.edu)
+1993-03-17 Eric S. Raymond (esr@thyrsus.com)
* finder.el (finder-compile-keywords): Treat nil in a path
argument as $PWD.
(finder-by-keyword): Handle LFD as input gracefully.
-1993-03-17 Eric S. Raymond (eric@mole.gnu.ai.mit.edu)
+1993-03-17 Eric S. Raymond (esr@thyrsus.com)
* vc-hooks.el: Increment version number to match vc.el's.
@@ -2017,7 +2017,7 @@
* loaddefs.el (minor-mode-alist): Make the mode line element for
overwrite-mode be the symbol `overwrite-mode'.
-1993-03-16 Eric S. Raymond (eric@mole.gnu.ai.mit.edu)
+1993-03-16 Eric S. Raymond (esr@thyrsus.com)
* vc.el, vc-hooks.el: The macro vc-error-occurred has to move from
vc.el to vc-hooks.el for C-x C-f of a nonexistent file to work.
@@ -2074,11 +2074,11 @@
(rmail-summary-rmail-update): Do nothing if rmail buffer not visible.
(rmail-summary-mode-map): Don't bind C-n, C-p. Use ordinary move cmds.
-1993-03-12 Eric S. Raymond (eric@mole.gnu.ai.mit.edu)
+1993-03-12 Eric S. Raymond (esr@thyrsus.com)
* term/x-win.el: Added library headers.
-1993-03-12 Eric S. Raymond (eric@mole.gnu.ai.mit.edu)
+1993-03-12 Eric S. Raymond (esr@thyrsus.com)
* loaddefs.el (global-map): Fix a typo in the binding of
[kp-backtab].
@@ -2092,7 +2092,7 @@
* term/x-win.el: Cancel previous change, since it discarded
earlier necessary changes.
-1993-03-11 Eric S. Raymond (eric@mole.gnu.ai.mit.edu)
+1993-03-11 Eric S. Raymond (esr@thyrsus.com)
* term/vt100.el:
Added headers, commented out code the duplicates startup effects.
@@ -2115,7 +2115,7 @@
suspend-hooks, not suspend-hook. The latter is an obsolete name.
Use add-hook instead of setting suspend-hooks directly.
-1993-03-11 Eric S. Raymond (eric@mole.gnu.ai.mit.edu)
+1993-03-11 Eric S. Raymond (esr@thyrsus.com)
A boatload of changes to terminal support and terminal capability
initialization that make it a lot smarter, with a more uniform
@@ -2197,7 +2197,7 @@
Likewise their Meta versions.
Also add `ascii-character' properties.
-1993-03-09 Eric S. Raymond (eric@mole.gnu.ai.mit.edu)
+1993-03-09 Eric S. Raymond (esr@thyrsus.com)
* term/at386.el: Removed. The new terminal initialization stuff
makes it superfluous. I wrote it, so I should know. :-)
@@ -3300,7 +3300,7 @@
(ange-ftp-read-passwd, ange-ftp-process-filter): Uncomment out the
calls to ange-ftp-repaint-buffer.
-1992-11-11 Eric S. Raymond (eric@mole.gnu.ai.mit.edu)
+1992-11-11 Eric S. Raymond (esr@thyrsus.com)
* c-mode.el (c-style-alist): Add quotes around C++ style name.
@@ -4680,7 +4680,7 @@
* compile.el (compilation-parse-errors): Write progress messages
on all regexp matches, not just errors.
-1992-08-04 Eric S. Raymond (eric@mole.gnu.ai.mit.edu)
+1992-08-04 Eric S. Raymond (esr@thyrsus.com)
* view.el (view-mode): Teach this how to use help-char.
@@ -4727,7 +4727,7 @@
* etags.el (complete-tag): Error if no tags table loaded.
-1992-08-03 Eric S. Raymond (eric@mole.gnu.ai.mit.edu)
+1992-08-03 Eric S. Raymond (esr@thyrsus.com)
* ebuff-menu.el, echistory.el, help.el, hexl.el: Teach these packages
to use help-char, and add the appropriate magic to doc strings.
@@ -5085,7 +5085,7 @@
* diff.el (diff-rcs, diff-sccs): Delete.
-1992-07-27 Eric S. Raymond (eric@mole.gnu.ai.mit.edu)
+1992-07-27 Eric S. Raymond (esr@thyrsus.com)
* tar-mode.el (tar-subfile-save-buffer): Whoever changed
current-time forgot to check for breakage. Added code to print
@@ -5201,7 +5201,7 @@
* c++-mode.el (indent-c++-exp): Fix typo "innerloop-done".
Make last-depth local.
-1992-07-23 Eric S. Raymond (eric@mole.gnu.ai.mit.edu)
+1992-07-23 Eric S. Raymond (esr@thyrsus.com)
* flow-ctrl.el: Fixed set-input-mode call broken by new third
arg for meta control.
@@ -5266,11 +5266,11 @@
* byte-opt.el (disassemble-offset, byte-decompile-bytecode-1):
Support for relative jumps removed.
-1992-07-22 Eric S. Raymond (eric@mole.gnu.ai.mit.edu)
+1992-07-22 Eric S. Raymond (esr@thyrsus.com)
* Removed all Last-Modified headers.
-1992-07-21 Eric S. Raymond (eric@mole.gnu.ai.mit.edu)
+1992-07-21 Eric S. Raymond (esr@thyrsus.com)
* files.el (trim-versions-without-asking): Non-nil, non-t value
suppresses all trimming of excess backups. This is so we can make
@@ -5335,7 +5335,7 @@
Modified the remaining version by adding new argument GLOBAL
and setting the parameters locally if GLOBAL is nil.
-1992-07-21 Eric S. Raymond (eric@mole.gnu.ai.mit.edu)
+1992-07-21 Eric S. Raymond (esr@thyrsus.com)
* Turfed r2bibtex.el. Refbib.el turns out to be a newer version
of the same package.
@@ -5484,7 +5484,7 @@
(find-file-noselect): Don't remove the automount prefix here; let
abbreviate-file-name take care of it.
-1992-07-17 Eric S. Raymond (eric@mole.gnu.ai.mit.edu)
+1992-07-17 Eric S. Raymond (esr@thyrsus.com)
* Keywords added for [n-z]*.el. Finder now under construction.
@@ -5495,7 +5495,7 @@
ending with the latter may be deleted accidentally when space is
low.
-1992-07-17 Eric S. Raymond (eric@mole.gnu.ai.mit.edu)
+1992-07-17 Eric S. Raymond (esr@thyrsus.com)
* Keywords added for [a-m]*.el. The keyword categories will
probably need some tuning, but at least this will suffice
@@ -5508,7 +5508,7 @@
* Changed all copying notices to GPL version 2.
-1992-07-16 Eric S. Raymond (eric@mole.gnu.ai.mit.edu)
+1992-07-16 Eric S. Raymond (esr@thyrsus.com)
* Finished decorating the library files with new standard headers.
@@ -5537,14 +5537,14 @@
* byte-run.el (defsubst): Remove extra closing paren at the end
of this function.
-1992-07-16 Eric S. Raymond (eric@mole.gnu.ai.mit.edu)
+1992-07-16 Eric S. Raymond (esr@thyrsus.com)
* At RMS's request, all occurrences of `elisp' changed to `Emacs Lisp'.
* New library headers for [fghijklmn]*.el. First steps towards
keyword-based code finder via Keywords header.
-1992-07-15 Eric S. Raymond (eric@mole.gnu.ai.mit.edu)
+1992-07-15 Eric S. Raymond (esr@thyrsus.com)
* New library headers for [opqrst]*.el. Ghod, this is boring.
@@ -5594,7 +5594,7 @@
(set-frame-height, set-frame-width): Functions deleted; they are
defined in frame.c.
-1992-07-14 Eric S. Raymond (eric@mole.gnu.ai.mit.edu)
+1992-07-14 Eric S. Raymond (esr@thyrsus.com)
* [uvwxy]*.el: Added headers for new Emacs Lisp documentation
conventions.
@@ -5604,7 +5604,7 @@
* calendar.el (calendar-mode): Change key bindings for all
functions to make them consistent with Version 19 requirements.
-1992-07-13 Eric S. Raymond (eric@mole.gnu.ai.mit.edu)
+1992-07-13 Eric S. Raymond (esr@thyrsus.com)
* comint.el: Minor changes to comments to reflect the fact that
comint has won its war and replaced shell mode.
@@ -5750,7 +5750,7 @@
* etags.el (visit-tags-table): Remove automounter prefixes before
setting tags-file-name.
-1992-07-06 Eric S. Raymond (eric@mole.gnu.ai.mit.edu)
+1992-07-06 Eric S. Raymond (esr@thyrsus.com)
* Moved gdb.el to =gdb.el. The autoload generation for
loaddefs.el was getting screwed up by the conflicting autoloads
@@ -6157,7 +6157,7 @@
* info.el (Info-enable-edit): Now a user option.
-1992-06-03 Eric S. Raymond (eric@mole.gnu.ai.mit.edu)
+1992-06-03 Eric S. Raymond (esr@thyrsus.com)
* sendmail.el (mail-signature): Suppress move to end of buffer if
we gave a prefix argument (requested by Bob Chassell).
@@ -6250,7 +6250,7 @@
* flow-ctrl.el (evade-flow-control-memstr=): Rename from memstr=.
-1992-05-31 Eric S. Raymond (eric@mole.gnu.ai.mit.edu)
+1992-05-31 Eric S. Raymond (esr@thyrsus.com)
* bibtex.el: Merged in alarson's changes.
@@ -6261,7 +6261,7 @@
* subr.el (lambda): Add docstring.
-1992-05-31 Eric S. Raymond (eric@mole.gnu.ai.mit.edu)
+1992-05-31 Eric S. Raymond (esr@thyrsus.com)
* gdb.el: Nuked --- subsumed by gdb entry point of gud.el.
@@ -6275,7 +6275,7 @@
old version still exists in the ~n~ files if this loses, but
the code looks good.
-1992-05-30 Eric S. Raymond (eric@mole.gnu.ai.mit.edu)
+1992-05-30 Eric S. Raymond (esr@thyrsus.com)
* profile.el: Installed.
@@ -6715,7 +6715,7 @@
* term/new-at386.el: Rewritten to use function-key-map.
-1992-01-10 Eric S. Raymond (eric@mole.gnu.ai.mit.edu)
+1992-01-10 Eric S. Raymond (esr@thyrsus.com)
* flow-ctrl.el: Installed.
@@ -6751,14 +6751,14 @@
(sendmail-send-it): Delete code for mail-aliases.
(build-mail-aliases, expand-mail-aliases): Autoloads deleted.
-1991-12-14 Eric S. Raymond (eric@mole.gnu.ai.mit.edu)
+1991-12-14 Eric S. Raymond (esr@thyrsus.com)
* etags.el (find-tag-noselect): Fix subtle bug due to
save-excursion.
(tags-tag-match): New function, made smarter about exact matches.
-1991-12-13 Eric S. Raymond (eric@mole.gnu.ai.mit.edu)
+1991-12-13 Eric S. Raymond (esr@thyrsus.com)
* perl-mode.el: Installed.
@@ -6767,7 +6767,7 @@
* sendmail.el (mail-default-headers): New user variable.
(mail-setup): Insert value of that variable.
-1991-12-11 Eric S. Raymond (eric@mole.gnu.ai.mit.edu)
+1991-12-11 Eric S. Raymond (esr@thyrsus.com)
* c-mode.el: Added C++ style to c-style-alist.
@@ -6777,7 +6777,7 @@
* man.el (nuke-nroff-bs): Simplify o^H+. Delete "reformatting" msg.
-1991-12-08 Eric S. Raymond (eric@mole.gnu.ai.mit.edu)
+1991-12-08 Eric S. Raymond (esr@thyrsus.com)
* blackbox.el: Applied doc patch. No functions affected.
@@ -12032,7 +12032,7 @@
1988-12-22 Richard Stallman (rms@mole.ai.mit.edu)
- * term/at386.el: Eric Raymond's changes to work with keypad.el.
+ * term/at386.el: Eric S. Raymond's changes to work with keypad.el.
* loaddefs.el (completion-ignored-extensions): Add .a and .ln.
diff --git a/lisp/ChangeLog.4 b/lisp/ChangeLog.4
index c5f470dddbd..3d8421a1c7e 100644
--- a/lisp/ChangeLog.4
+++ b/lisp/ChangeLog.4
@@ -1055,7 +1055,7 @@
(gud-irixdbx-marker-filter): New function.
(dbx): Insert case for Irix.
-1994-04-27 Ulrich Mueller (ulm@vsnhd1.cern.ch)
+1994-04-27 Ulrich Müller (ulm@vsnhd1.cern.ch)
* case-table.el (describe-buffer-case-table): Don't use
text-char-description.
@@ -3384,7 +3384,7 @@
* font-lock.el (shell-font-lock-keywords): Doc fix.
-1994-02-02 Eric S. Raymond (eric@mole.gnu.ai.mit.edu)
+1994-02-02 Eric S. Raymond (esr@thyrsus.com)
* vc-hooks.el (vc-mode-line): Use force-mode-line-update instead
of the Emacs 18 kluge.
@@ -3402,7 +3402,7 @@
* files.el (file-relative-name): Allow for ancestors as well
as descendants.
-1994-02-02 Eric S. Raymond (eric@mole.gnu.ai.mit.edu)
+1994-02-02 Eric S. Raymond (esr@thyrsus.com)
* vc.el (vc-parse-buffer): Arrange for old properties to get
cleared when their match string is not found in the master file.
@@ -4189,7 +4189,7 @@
* paths.el (rmail-spool-directory): Use dgux, not dgux-unix.
* lpr.el (lpr-command): Use dgux, not dgux-unix.
-1993-12-14 Ulrich Mueller (ulm@vsnhd1.cern.ch)
+1993-12-14 Ulrich Müller (ulm@vsnhd1.cern.ch)
* gud.el (gud-format-command): Use gud-last-last-frame if
gud-last-frame is nil.
@@ -4200,7 +4200,7 @@
* info.el (Info-insert-dir): For generated menu items, add ::.
-1993-12-13 Ulrich Mueller (ulm@vsnhd1.cern.ch)
+1993-12-13 Ulrich Müller (ulm@vsnhd1.cern.ch)
* gud.el (gud-mipsdbx-massage-args, gud-mipsdbx-marker-filter):
New functions for dbx support on Mips under Ultrix.
@@ -4811,7 +4811,7 @@
(add-new-page): Insert new page in specified location.
(original-page-delimiter): Set default value to "^^L".
-1993-11-15 Eric S. Raymond (eric@mole.gnu.ai.mit.edu)
+1993-11-15 Eric S. Raymond (esr@thyrsus.com)
* vc.el: vc-static-header-alist shouldn't have been declared const.
@@ -5535,7 +5535,7 @@
* rmail.el (rmail-convert-to-babyl-format): Protect against
nonsensical content-length values.
-1993-10-04 Eric S. Raymond (eric@mole.gnu.ai.mit.edu)
+1993-10-04 Eric S. Raymond (esr@thyrsus.com)
* vc.el (vc-next-action): Fix (throw ... ) invocation to work with 19;
allows vc-next-action on all marked files in a dired buffer to work.
diff --git a/lisp/ChangeLog.5 b/lisp/ChangeLog.5
index 74e5e52dd63..1cbd1f923d0 100644
--- a/lisp/ChangeLog.5
+++ b/lisp/ChangeLog.5
@@ -4253,7 +4253,7 @@
the autogenerated label in the minibuffer caused the killed text
to appear in front of the bibtex entry.
-1995-01-05 Eric S. Raymond <esr@locke.ccil.org>
+1995-01-05 Eric S. Raymond <esr@thyrsus.com>
* vc.el (vc-do-command): Change RCS handling so rcsdiff won't strip
away relative-pathname information. This function no longer sets the
@@ -5463,7 +5463,7 @@
(makefile-font-lock-keywords): Use makefile-tab-face.
(makefile-font-lock-keywords): Use defvar, not defconst.
-1994-10-28 Ulrich Mueller <ulm@vsnhd1.cern.ch>
+1994-10-28 Ulrich Müller <ulm@vsnhd1.cern.ch>
* iso-acc.el (iso-accents-mode): Variable renamed from
iso-accents-minor-mode.
diff --git a/lisp/ChangeLog.6 b/lisp/ChangeLog.6
index 8d94109de4d..84253b2d079 100644
--- a/lisp/ChangeLog.6
+++ b/lisp/ChangeLog.6
@@ -7197,7 +7197,7 @@
* faces.el (x-font-regexp): Add \\(\\) for substring extraction.
-1995-07-27 Ulrich Mueller <ulm@vsnhd1.cern.ch>
+1995-07-27 Ulrich Müller <ulm@vsnhd1.cern.ch>
* fortran.el (fortran-break-line): Fixed a bug that sometimes
deleted first character in statement field of continuation line.
@@ -7910,7 +7910,7 @@
* paths.el (remote-shell-program): Fix typo checking /usr/bin/remsh.
-1995-06-26 Eric S. Raymond <esr@snark.thyrsus.com>
+1995-06-26 Eric S. Raymond <esr@thyrsus.com>
* vc.el (vc-start-entry): Prevent lossage when doing a mass checkin
from a VC-dired buffer.
diff --git a/lisp/ChangeLog.7 b/lisp/ChangeLog.7
index dc280d2908f..efd01a86166 100644
--- a/lisp/ChangeLog.7
+++ b/lisp/ChangeLog.7
@@ -3825,7 +3825,7 @@
* progmodes/perl-mode.el (perl-mode): Add autoload cookie.
-1998-04-29 Eric S. Raymond <esr@snark.thyrsus.com>
+1998-04-29 Eric S. Raymond <esr@thyrsus.com>
Many small changes that mostly eliminate the explicit mail separator
variable and use the new rfc822-goto-eoh primitive instead:
@@ -13054,7 +13054,7 @@
* mail/sendmail.el (mail-mode): Make adaptive-fill-regexp
match more values. Bind adaptive-fill-first-line-regexp too.
-1997-07-26 Eric S. Raymond <esr@snark.thyrsus.com>
+1997-07-26 Eric S. Raymond <esr@thyrsus.com>
* telnet.el (telnet): Handle multiple telnet programs better.
(telnet-host-properties): New variable.
diff --git a/lisp/Makefile.in b/lisp/Makefile.in
index 521558a9598..95cb6a97213 100644
--- a/lisp/Makefile.in
+++ b/lisp/Makefile.in
@@ -72,9 +72,10 @@ AUTOGENEL = ${loaddefs} ${srcdir}/cus-load.el ${srcdir}/finder-inf.el \
${srcdir}/subdirs.el ${srcdir}/eshell/esh-groups.el
# Set load-prefer-newer for the benefit of the non-bootstrappers.
+# Set org--inhibit-version-check to avoid unnecessarily aborting the build.
BYTE_COMPILE_FLAGS = \
--eval "(setq load-prefer-newer t byte-compile-warnings 'all)" \
- $(BYTE_COMPILE_EXTRA_FLAGS)
+ --eval "(setq org--inhibit-version-check 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)
@@ -94,6 +95,8 @@ COMPILE_FIRST = \
ifeq ($(HAVE_NATIVE_COMP),yes)
COMPILE_FIRST += $(lisp)/emacs-lisp/comp.elc
COMPILE_FIRST += $(lisp)/emacs-lisp/comp-cstr.elc
+COMPILE_FIRST += $(lisp)/emacs-lisp/comp-common.elc
+COMPILE_FIRST += $(lisp)/emacs-lisp/comp-run.elc
endif
COMPILE_FIRST += $(lisp)/emacs-lisp/loaddefs-gen.elc
COMPILE_FIRST += $(lisp)/emacs-lisp/radix-tree.elc
@@ -350,11 +353,7 @@ compile-first: $(COMPILE_FIRST)
# TARGETS is set dynamically in the recursive call from 'compile-main'.
# Do not build comp.el unless necessary not to exceed max-lisp-eval-depth
# in normal builds.
-ifneq ($(HAVE_NATIVE_COMP),yes)
-compile-targets: $(filter-out ./emacs-lisp/comp-cstr.elc,$(filter-out ./emacs-lisp/comp.elc,$(TARGETS)))
-else
compile-targets: $(TARGETS)
-endif
# Compile all the Elisp files that need it. Beware: it approximates
# 'no-byte-compile', so watch out for false-positives!
@@ -525,8 +524,8 @@ check-declare:
## This finds a lot of duplicates between foo.el and obsolete/foo.el.
check-defun-dups:
sed -n -e '/^(defun /s/\(.\)(.*/\1/p' \
- $$(find . -name '*.el' ! -name '.*' -print | \
- grep -Ev '(loaddefs|ldefs-boot)\.el|obsolete') | sort | uniq -d
+ `find . -name '*.el' ! -name '.*' -print | \
+ grep -Ev '(loaddefs|ldefs-boot)\.el|obsolete'` | sort | uniq -d
# Dependencies
diff --git a/lisp/abbrev.el b/lisp/abbrev.el
index 9afa617908e..188eeb720c0 100644
--- a/lisp/abbrev.el
+++ b/lisp/abbrev.el
@@ -531,7 +531,7 @@ PROPS is a list of properties."
(defun abbrev-table-p (object)
"Return non-nil if OBJECT is an abbrev table."
(and (obarrayp object)
- (numberp (ignore-error 'wrong-type-argument
+ (numberp (ignore-error wrong-type-argument
(abbrev-table-get object :abbrev-table-modiff)))))
(defun abbrev-table-empty-p (object &optional ignore-system)
@@ -602,8 +602,7 @@ It is nil if the abbrev has already been unexpanded.")
"Undefine all abbrevs in abbrev table TABLE, leaving TABLE empty."
(setq abbrevs-changed t)
(let* ((sym (obarray-get table "")))
- (dotimes (i (length table))
- (aset table i 0))
+ (obarray-clear table)
;; Preserve the table's properties.
(cl-assert sym)
(let ((newsym (obarray-put table "")))
@@ -721,7 +720,7 @@ either a single abbrev table or a list of abbrev tables."
;; to treat the distinction between a single table and a list of tables.
(cond
((consp tables) tables)
- ((vectorp tables) (list tables))
+ ((obarrayp tables) (list tables))
(t
(let ((tables (if (listp local-abbrev-table)
(append local-abbrev-table
diff --git a/lisp/align.el b/lisp/align.el
index fe996da1444..81ccc4b5e2d 100644
--- a/lisp/align.el
+++ b/lisp/align.el
@@ -164,12 +164,14 @@ values may cause unexpected behavior at times."
:group 'align)
(defcustom align-highlight-change-face 'highlight
- "The face to highlight with if changes are necessary."
+ "The face to highlight with if changes are necessary.
+Used by the `align-highlight-rule' command."
:type 'face
:group 'align)
(defcustom align-highlight-nochange-face 'secondary-selection
- "The face to highlight with if no changes are necessary."
+ "The face to highlight with if no changes are necessary.
+Used by the `align-highlight-rule' command."
:type 'face
:group 'align)
@@ -179,13 +181,12 @@ If nil, then no messages will ever be printed to the minibuffer."
:type '(choice (const :tag "Align a large region silently" nil) integer)
:group 'align)
-(defcustom align-c++-modes '( c++-mode c-mode java-mode
- c-ts-mode c++-ts-mode)
+(defcustom align-c++-modes '( c++-mode c-mode java-mode)
"A list of modes whose syntax resembles C/C++."
:type '(repeat symbol)
:group 'align)
-(defcustom align-perl-modes '(perl-mode cperl-mode)
+(defcustom align-perl-modes '(perl-mode)
"A list of modes where Perl syntax is to be seen."
:type '(repeat symbol)
:group 'align)
@@ -209,20 +210,20 @@ If nil, then no messages will ever be printed to the minibuffer."
(defcustom align-dq-string-modes
(append align-lisp-modes align-c++-modes align-perl-modes
- '(python-mode vhdl-mode))
+ '(python-base-mode vhdl-mode))
"A list of modes where double quoted strings should be excluded."
:type '(repeat symbol)
:group 'align)
(defcustom align-sq-string-modes
- (append align-perl-modes '(python-mode))
+ (append align-perl-modes '(python-base-mode))
"A list of modes where single quoted strings should be excluded."
:type '(repeat symbol)
:group 'align)
(defcustom align-open-comment-modes
(append align-lisp-modes align-c++-modes align-perl-modes
- '(python-mode makefile-mode vhdl-mode))
+ '(python-base-mode makefile-mode vhdl-mode))
"A list of modes with a single-line comment syntax.
These are comments as in Lisp, which have a beginning, but end with
the line (i.e., `comment-end' is an empty string)."
@@ -448,7 +449,7 @@ The possible settings for `align-region-separate' are:
(regexp . ,(concat "[^=!<> \t\n]\\(\\s-*\\)="
"\\(\\s-*\\)\\([^>= \t\n]\\|$\\)"))
(group . (1 2))
- (modes . '(python-mode))
+ (modes . '(python-base-mode))
(tab-stop . nil))
(make-assignment
@@ -476,7 +477,7 @@ The possible settings for `align-region-separate' are:
(basic-comma-delimiter
(regexp . ",\\(\\s-*\\)[^# \t\n]")
(repeat . t)
- (modes . (append align-perl-modes '(python-mode)))
+ (modes . (append align-perl-modes '(python-base-mode)))
(run-if . ,(lambda () current-prefix-arg)))
(c++-comment
@@ -506,7 +507,7 @@ The possible settings for `align-region-separate' are:
(python-chain-logic
(regexp . "\\(\\s-*\\)\\(\\<and\\>\\|\\<or\\>\\)")
- (modes . '(python-mode))
+ (modes . '(python-base-mode))
(valid . ,(lambda ()
(save-excursion
(goto-char (match-end 2))
@@ -523,7 +524,7 @@ The possible settings for `align-region-separate' are:
(basic-line-continuation
(regexp . "\\(\\s-*\\)\\\\$")
- (modes . '(python-mode makefile-mode)))
+ (modes . '(python-base-mode makefile-mode)))
(tex-record-separator
(regexp . ,(lambda (end reverse)
@@ -553,8 +554,7 @@ The possible settings for `align-region-separate' are:
(repeat . t)
(run-if . ,(lambda ()
(and (not (eq '- current-prefix-arg))
- (not (apply #'provided-mode-derived-p
- major-mode align-tex-modes))))))
+ (not (derived-mode-p align-tex-modes))))))
;; With a negative prefix argument, lists of dollar figures will
;; be aligned.
@@ -568,7 +568,25 @@ The possible settings for `align-region-separate' are:
(css-declaration
(regexp . "^\\s-*\\(?:\\w-?\\)+:\\(\\s-*\\).*;")
(group . (1))
- (modes . '(css-mode html-mode))))
+ (modes . '(css-base-mode html-mode)))
+
+ (toml-assignment
+ (regexp . ,(rx (group (zero-or-more (syntax whitespace)))
+ "="
+ (group (zero-or-more (syntax whitespace)))))
+ (group . (1 2))
+ (modes . '(conf-toml-mode lua-mode)))
+
+ (double-dash-comment
+ (regexp . ,(rx (group (zero-or-more (syntax whitespace)))
+ "--"
+ (zero-or-more nonl)))
+ (modes . '(lua-mode))
+ (column . comment-column)
+ (valid . ,(lambda ()
+ (save-excursion
+ (goto-char (match-beginning 1))
+ (not (bolp)))))))
"A list describing all of the available alignment rules.
The format is:
@@ -1261,6 +1279,14 @@ Otherwise, create a new marker at position POS, with type TYPE."
(move-marker ,marker-var ,pos)
(setq ,marker-var (copy-marker ,pos ,type))))
+(defun align--rule-should-run (rule)
+ "Given an `align-rules-list' entry RULE, return t if it should run.
+This is decided by the `modes' and `run-if' keys in the alist
+RULE. Their meaning is documented in `align-rules-list' (which see)."
+ (let-alist rule
+ (not (or (and .modes (not (derived-mode-p (eval .modes))))
+ (and .run-if (not (funcall .run-if)))))))
+
(defun align-region (beg end separate rules exclude-rules
&optional func)
"Align a region based on a given set of alignment rules.
@@ -1298,23 +1324,20 @@ This feature (of passing a FUNC) is used internally to locate the
position of exclusion areas, but could also be used for any other
purpose where you might want to know where the regions that the
aligner would have dealt with are."
- (let ((end-mark (and end (copy-marker end t)))
- (real-beg beg)
- (report (and (not func) align-large-region beg end
- (>= (- end beg) align-large-region)))
- (rule-index 1)
- (rule-count (length rules))
- markers)
+ (let* ((end-mark (and end (copy-marker end t)))
+ (real-beg beg)
+ (report (and (not func) align-large-region beg end
+ (>= (- end beg) align-large-region)))
+ (rules (seq-filter #'align--rule-should-run rules))
+ (rule-index 1)
+ (rule-count (length rules))
+ markers)
(if (and align-indent-before-aligning real-beg end-mark)
(indent-region real-beg end-mark nil))
(while rules
- (let* ((rule (car rules))
- (run-if (assq 'run-if rule))
- (modes (assq 'modes rule)))
- ;; unless the `run-if' form tells us not to, look for the
- ;; rule..
- (unless (or (and modes (not (apply #'derived-mode-p (eval (cdr modes)))))
- (and run-if (not (funcall (cdr run-if)))))
+ (let ((rule (car rules)))
+ (progn
+ ;; Search for a match for the rule.
(let* ((case-fold-search case-fold-search)
(case-fold (assq 'case-fold rule))
(regexp (cdr (assq 'regexp rule)))
@@ -1323,12 +1346,18 @@ aligner would have dealt with are."
(thissep (if rulesep (cdr rulesep) separate))
same (eol 0)
search-start
- groups ;; group-c
- spacing spacing-c
- tab-stop tab-stop-c
- repeat repeat-c
- valid valid-c
- first
+ (groups (ensure-list (or (cdr (assq 'group rule)) 1)))
+ (spacing (cdr (assq 'spacing rule)))
+ (tab-stop (let ((rule-ts (assq 'tab-stop rule)))
+ (cond (rule-ts
+ (cdr rule-ts))
+ ((symbolp align-to-tab-stop)
+ (symbol-value align-to-tab-stop))
+ (t
+ align-to-tab-stop))))
+ (repeat (cdr (assq 'repeat rule)))
+ (valid (assq 'valid rule))
+ (first (car groups))
regions index
last-point
save-match-data
@@ -1445,45 +1474,12 @@ aligner would have dealt with are."
(if (and (bolp) (> (point) search-start))
(forward-char -1))
- ;; lookup the `group' attribute the first time
- ;; that we need it
- (unless nil ;; group-c
- (setq groups (or (cdr (assq 'group rule)) 1))
- (unless (listp groups)
- (setq groups (list groups)))
- (setq first (car groups)))
-
- (unless spacing-c
- (setq spacing (cdr (assq 'spacing rule))
- spacing-c t))
-
- (unless tab-stop-c
- (setq tab-stop
- (let ((rule-ts (assq 'tab-stop rule)))
- (cond (rule-ts
- (cdr rule-ts))
- ((symbolp align-to-tab-stop)
- (symbol-value align-to-tab-stop))
- (t
- align-to-tab-stop)))
- tab-stop-c t))
-
;; test whether we have found a match on the same
;; line as a previous match
(when (> (point) eol)
(setq same nil)
(align--set-marker eol (line-end-position)))
- ;; lookup the `repeat' attribute the first time
- (or repeat-c
- (setq repeat (cdr (assq 'repeat rule))
- repeat-c t))
-
- ;; lookup the `valid' attribute the first time
- (or valid-c
- (setq valid (assq 'valid rule)
- valid-c t))
-
;; remember the beginning position of this rule
;; match, and save the match-data, since either
;; the `valid' form, or the code that searches for
diff --git a/lisp/allout-widgets.el b/lisp/allout-widgets.el
index 62210cd0cb0..7f5831d4124 100644
--- a/lisp/allout-widgets.el
+++ b/lisp/allout-widgets.el
@@ -613,7 +613,8 @@ outline hot-spot navigation (see `allout-mode')."
#'allout-widgets-post-command-business 'local)
(remove-hook 'pre-command-hook
#'allout-widgets-pre-command-business 'local)
- (assq-delete-all 'allout-widgets-mode-inhibit minor-mode-alist)
+ (setq minor-mode-alist
+ (assq-delete-all 'allout-widgets-mode-inhibit minor-mode-alist))
(set-buffer-modified-p was-modified))))
;;;_ > allout-widgets-mode-off
(defun allout-widgets-mode-off ()
diff --git a/lisp/allout.el b/lisp/allout.el
index ebe8b1c49b9..e3fe8d08841 100644
--- a/lisp/allout.el
+++ b/lisp/allout.el
@@ -5,7 +5,7 @@
;; Author: Ken Manheimer <ken dot manheimer at gmail...>
;; Created: Dec 1991 -- first release to usenet
;; Version: 2.3
-;; Keywords: outlines, wp, languages, PGP, GnuPG
+;; Keywords: outlines, text, languages, PGP, GnuPG
;; Website: https://myriadicity.net/software-and-systems/craft/emacs-allout
;; This file is part of GNU Emacs.
@@ -161,9 +161,9 @@ respective `allout-mode' keybinding variables, `allout-command-prefix',
(defcustom allout-command-prefix "\C-c "
"Key sequence to be used as prefix for outline mode command key bindings.
-Default is `\C-c<space>'; just `\C-c' is more short-and-sweet, if you're
-willing to let allout use a bunch of \C-c keybindings."
- :type 'string
+Default is \\`C-c SPC'; just \\`C-c' is more short-and-sweet, if you're
+willing to let allout use a bunch of \\`C-c' keybindings."
+ :type 'key-sequence
:group 'allout-keybindings
:set #'allout-compose-and-institute-keymap)
;;;_ = allout-keybindings-binding
@@ -5390,7 +5390,7 @@ Defaults:
;; not specified -- default it:
(setq tobuf (concat "*" (buffer-name frombuf) " exposed*")))
(if (listp format)
- (nreverse format))
+ (setq format (reverse format)))
(let* ((listified
(progn (set-buffer frombuf)
@@ -6195,7 +6195,7 @@ for details on preparing Emacs for automatic allout activation."
(allout-open-topic 2)
(insert (substitute-command-keys
(concat "Dummy outline topic header -- see"
- " `allout-mode' docstring: `\\[describe-mode]'.")))
+ " `allout-mode' docstring: \\[describe-mode]")))
(allout-adjust-file-variable
"allout-layout" (or allout-layout '(-1 : 0))))))
;;;_ > allout-file-vars-section-data ()
@@ -6307,7 +6307,7 @@ not its value."
(if (yes-or-no-p (format-message
"%s entry `%s' is unbound -- remove it? "
configvar-name sym))
- (delq sym (symbol-value configvar-name)))
+ (set configvar-name (delq sym (symbol-value configvar-name))))
(push (symbol-value sym) got)))
(reverse got)))
;;;_ : Topics:
diff --git a/lisp/ansi-osc.el b/lisp/ansi-osc.el
index 7e686193f69..8dbaeb45132 100644
--- a/lisp/ansi-osc.el
+++ b/lisp/ansi-osc.el
@@ -121,7 +121,8 @@ and `shell-dirtrack-mode'."
(let ((url (url-generic-parse-url text)))
(when (and (string= (url-type url) "file")
(or (null (url-host url))
- (string= (url-host url) (system-name))))
+ ;; Use `downcase' to match `url-generic-parse-url' behavior
+ (string= (url-host url) (downcase (system-name)))))
(ignore-errors
(cd-absolute (url-unhex-string (url-filename url)))))))
diff --git a/lisp/apropos.el b/lisp/apropos.el
index 4e2b545d4b7..6c6cd0b593d 100644
--- a/lisp/apropos.el
+++ b/lisp/apropos.el
@@ -54,6 +54,8 @@
;;; Code:
+(eval-when-compile (require 'cl-lib))
+
(defgroup apropos nil
"Apropos commands for users and programmers."
:group 'help
@@ -193,9 +195,6 @@ property list, WIDGET-DOC is the widget docstring, FACE-DOC is
the face docstring, and CUS-GROUP-DOC is the custom group
docstring. Each docstring is either nil or a string.")
-(defvar apropos-item ()
- "Current item in or for `apropos-accumulator'.")
-
(defvar apropos-synonyms '(
("find" "open" "edit")
("kill" "cut")
@@ -907,6 +906,18 @@ Optional arg BUFFER (default: current buffer) is the buffer to check."
((symbolp def) (funcall f def))
((eq 'defun (car-safe def)) (funcall f (cdr def)))))))))
+(defun apropos--documentation-add (symbol doc pos)
+ (when (setq doc (apropos-documentation-internal doc))
+ (let ((score (apropos-score-doc doc))
+ (item (cdr (assq symbol apropos-accumulator))))
+ (unless item
+ (push (cons symbol
+ (setq item (list (apropos-score-symbol symbol 2)
+ nil nil)))
+ apropos-accumulator))
+ (setf (nth pos item) doc)
+ (setcar item (+ (car item) score)))))
+
;;;###autoload
(defun apropos-documentation (pattern &optional do-all)
"Show symbols whose documentation contains matches for PATTERN.
@@ -929,40 +940,28 @@ Returns list of symbols and documentation found."
(setq apropos--current (list #'apropos-documentation pattern do-all))
(apropos-parse-pattern pattern t)
(or do-all (setq do-all apropos-do-all))
- (setq apropos-accumulator () apropos-files-scanned ())
- (with-temp-buffer
- (let ((standard-input (current-buffer))
- (apropos-sort-by-scores apropos-documentation-sort-by-scores)
- f v sf sv)
- (apropos-documentation-check-doc-file)
- (funcall
- (if do-all #'mapatoms #'apropos--map-preloaded-atoms)
- (lambda (symbol)
- (setq f (apropos-safe-documentation symbol)
- v (get symbol 'variable-documentation))
- (if (integerp v) (setq v nil))
- (setq f (apropos-documentation-internal f)
- v (apropos-documentation-internal v))
- (setq sf (apropos-score-doc f)
- sv (apropos-score-doc v))
- (if (or f v)
- (if (setq apropos-item
- (cdr (assq symbol apropos-accumulator)))
- (progn
- (if f
- (progn
- (setcar (nthcdr 1 apropos-item) f)
- (setcar apropos-item (+ (car apropos-item) sf))))
- (if v
- (progn
- (setcar (nthcdr 2 apropos-item) v)
- (setcar apropos-item (+ (car apropos-item) sv)))))
- (setq apropos-accumulator
- (cons (list symbol
- (+ (apropos-score-symbol symbol 2) sf sv)
- f v)
- apropos-accumulator))))))
- (apropos-print nil "\n----------------\n" nil t))))
+ (let ((apropos-accumulator ())
+ (apropos-files-scanned ())
+ (delayed (make-hash-table :test #'equal)))
+ (with-temp-buffer
+ (let ((standard-input (current-buffer))
+ (apropos-sort-by-scores apropos-documentation-sort-by-scores)
+ f v)
+ (apropos-documentation-check-doc-file)
+ (funcall
+ (if do-all #'mapatoms #'apropos--map-preloaded-atoms)
+ (lambda (symbol)
+ (setq f (apropos-safe-documentation symbol)
+ v (get symbol 'variable-documentation))
+ (if (integerp v) (setq v nil))
+ (if (consp f)
+ (push (list symbol (cdr f) 1) (gethash (car f) delayed))
+ (apropos--documentation-add symbol f 1))
+ (if (consp v)
+ (push (list symbol (cdr v) 2) (gethash (car v) delayed))
+ (apropos--documentation-add symbol v 2))))
+ (maphash #'apropos--documentation-add-from-elc delayed)
+ (apropos-print nil "\n----------------\n" nil t)))))
(defun apropos-value-internal (predicate symbol function)
@@ -983,11 +982,11 @@ Returns list of symbols and documentation found."
symbol)))
(defun apropos-documentation-internal (doc)
+ ;; By the time we get here, refs to DOC or to .elc files should have
+ ;; been converted into actual strings.
+ (cl-assert (not (or (consp doc) (integerp doc))))
(cond
- ((consp doc)
- (apropos-documentation-check-elc-file (car doc)))
- ((and doc
- ;; Sanity check in case bad data sneaked into the
+ ((and ;; Sanity check in case bad data sneaked into the
;; documentation slot.
(stringp doc)
(string-match apropos-all-words-regexp doc)
@@ -1054,110 +1053,62 @@ non-nil."
;; So we exclude them.
(cond ((= 3 type) (boundp symbol))
((= 2 type) (fboundp symbol))))
- (or (and (setq apropos-item (assq symbol apropos-accumulator))
- (setcar (cdr apropos-item)
- (apropos-score-doc doc)))
- (setq apropos-item (list symbol
- (+ (apropos-score-symbol symbol 2)
- (apropos-score-doc doc))
- nil nil)
- apropos-accumulator (cons apropos-item
- apropos-accumulator)))
- (when apropos-match-face
- (setq doc (substitute-command-keys doc))
- (if (or (string-match apropos-pattern-quoted doc)
- (string-match apropos-all-words-regexp doc))
- (put-text-property (match-beginning 0)
- (match-end 0)
- 'face apropos-match-face doc)))
- (setcar (nthcdr type apropos-item) doc))))
+ (let ((apropos-item (assq symbol apropos-accumulator)))
+ (or (and apropos-item
+ (setcar (cdr apropos-item)
+ (apropos-score-doc doc)))
+ (setq apropos-item (list symbol
+ (+ (apropos-score-symbol symbol 2)
+ (apropos-score-doc doc))
+ nil nil)
+ apropos-accumulator (cons apropos-item
+ apropos-accumulator)))
+ (when apropos-match-face
+ (setq doc (substitute-command-keys doc))
+ (if (or (string-match apropos-pattern-quoted doc)
+ (string-match apropos-all-words-regexp doc))
+ (put-text-property (match-beginning 0)
+ (match-end 0)
+ 'face apropos-match-face doc)))
+ (setcar (nthcdr type apropos-item) doc)))))
(setq sepa (goto-char sepb)))))
-(defun apropos-documentation-check-elc-file (file)
- ;; .elc files have the location of the file specified as #$, but for
- ;; built-in files, that's a relative name (while for the rest, it's
- ;; absolute). So expand the name in the former case.
- (unless (file-name-absolute-p file)
- (setq file (expand-file-name file lisp-directory)))
- (if (or (member file apropos-files-scanned)
- (not (file-exists-p file)))
- nil
- (let (symbol doc beg end this-is-a-variable)
- (setq apropos-files-scanned (cons file apropos-files-scanned))
- (erase-buffer)
- (insert-file-contents file)
- (while (search-forward "#@" nil t)
- ;; Read the comment length, and advance over it.
- ;; This #@ may be a false positive, so don't get upset if
- ;; it's not followed by the expected number of bytes to skip.
- (when (and (setq end (ignore-errors (read))) (natnump end))
- (setq beg (1+ (point))
- end (+ (point) end -1))
- (forward-char)
- (if (save-restriction
- ;; match ^ and $ relative to doc string
- (narrow-to-region beg end)
- (re-search-forward apropos-all-words-regexp nil t))
- (progn
- (goto-char (+ end 2))
- (setq doc (buffer-substring beg end)
- end (- (match-end 0) beg)
- beg (- (match-beginning 0) beg))
- (when (apropos-true-hit-doc doc)
- (setq this-is-a-variable (looking-at "(def\\(var\\|const\\) ")
- symbol (progn
- (skip-chars-forward "(a-z")
- (forward-char)
- (read))
- symbol (if (consp symbol)
- (nth 1 symbol)
- symbol))
- (if (if this-is-a-variable
- (get symbol 'variable-documentation)
- (and (fboundp symbol) (apropos-safe-documentation symbol)))
- (progn
- (or (and (setq apropos-item (assq symbol apropos-accumulator))
- (setcar (cdr apropos-item)
- (+ (cadr apropos-item) (apropos-score-doc doc))))
- (setq apropos-item (list symbol
- (+ (apropos-score-symbol symbol 2)
- (apropos-score-doc doc))
- nil nil)
- apropos-accumulator (cons apropos-item
- apropos-accumulator)))
- (when apropos-match-face
- (setq doc (substitute-command-keys doc))
- (if (or (string-match apropos-pattern-quoted doc)
- (string-match apropos-all-words-regexp doc))
- (put-text-property (match-beginning 0)
- (match-end 0)
- 'face apropos-match-face doc)))
- (setcar (nthcdr (if this-is-a-variable 3 2)
- apropos-item)
- doc)))))))))))
-
-
+(defun apropos--documentation-add-from-elc (file defs)
+ (erase-buffer)
+ (insert-file-contents
+ (if (file-name-absolute-p file) file
+ (expand-file-name file lisp-directory)))
+ (pcase-dolist (`(,symbol ,begbyte ,pos) defs)
+ ;; We presume the file-bytes are the same as the buffer bytes,
+ ;; which should indeed be the case because .elc files use the
+ ;; `emacs-internal' encoding.
+ (let* ((beg (byte-to-position (+ (point-min) begbyte)))
+ (sizeend (1- beg))
+ (size (save-excursion
+ (goto-char beg)
+ (skip-chars-backward " 0-9")
+ (cl-assert (looking-back "#@" (- (point) 2)))
+ (string-to-number (buffer-substring (point) sizeend))))
+ (end (byte-to-position (+ begbyte size -1))))
+ (when (save-restriction
+ ;; match ^ and $ relative to doc string
+ (narrow-to-region beg end)
+ (goto-char (point-min))
+ (re-search-forward apropos-all-words-regexp nil t))
+ (let ((doc (buffer-substring beg end)))
+ (when (apropos-true-hit-doc doc)
+ (apropos--documentation-add symbol doc pos)))))))
(defun apropos-safe-documentation (function)
"Like `documentation', except it avoids calling `get_doc_string'.
Will return nil instead."
- (while (and function (symbolp function))
- (setq function (symbol-function function)))
- (if (eq (car-safe function) 'macro)
- (setq function (cdr function)))
- (setq function (if (byte-code-function-p function)
- (if (> (length function) 4)
- (aref function 4))
- (if (autoloadp function)
- (nth 2 function)
- (if (eq (car-safe function) 'lambda)
- (if (stringp (nth 2 function))
- (nth 2 function)
- (if (stringp (nth 3 function))
- (nth 3 function)))))))
- (if (integerp function)
- nil
- function))
+ (when (setq function (indirect-function function))
+ ;; FIXME: `function-documentation' says not to call it, but `documentation'
+ ;; would turn (FILE . POS) references into strings too eagerly, so
+ ;; we do want to use the lower-level function.
+ (let ((doc (function-documentation function)))
+ ;; Docstrings from the DOC file are handled elsewhere.
+ (if (integerp doc) nil doc))))
(defcustom apropos-compact-layout nil
"If non-nil, use a single line per binding."
@@ -1263,14 +1214,16 @@ as a heading."
(put-text-property (- (point) 3) (point)
'face 'apropos-keybinding)))
(terpri))
- (apropos-print-doc 2
+ (apropos-print-doc apropos-item
+ 2
(if (commandp symbol)
'apropos-command
(if (macrop symbol)
'apropos-macro
'apropos-function))
(not nosubst))
- (apropos-print-doc 3
+ (apropos-print-doc apropos-item
+ 3
(if (custom-variable-p symbol)
'apropos-user-option
'apropos-variable)
@@ -1288,10 +1241,10 @@ as a heading."
(lambda (_)
(message "Value: %s" value))))
(insert "\n")))
- (apropos-print-doc 7 'apropos-group t)
- (apropos-print-doc 6 'apropos-face t)
- (apropos-print-doc 5 'apropos-widget t)
- (apropos-print-doc 4 'apropos-plist nil))
+ (apropos-print-doc apropos-item 7 'apropos-group t)
+ (apropos-print-doc apropos-item 6 'apropos-face t)
+ (apropos-print-doc apropos-item 5 'apropos-widget t)
+ (apropos-print-doc apropos-item 4 'apropos-plist nil))
(setq-local truncate-partial-width-windows t)
(setq-local truncate-lines t)))
(when help-window-select
@@ -1299,7 +1252,7 @@ as a heading."
(prog1 apropos-accumulator
(setq apropos-accumulator ()))) ; permit gc
-(defun apropos-print-doc (i type do-keys)
+(defun apropos-print-doc (apropos-item i type do-keys)
(let ((doc (nth i apropos-item)))
(when (stringp doc)
(if apropos-compact-layout
diff --git a/lisp/arc-mode.el b/lisp/arc-mode.el
index d3120057220..9a8dd6679e3 100644
--- a/lisp/arc-mode.el
+++ b/lisp/arc-mode.el
@@ -231,13 +231,27 @@ Archive and member name will be added."
:group 'archive)
(defcustom archive-zip-extract
- (cond ((executable-find "unzip") '("unzip" "-qq" "-c"))
+ (cond ((executable-find "unzip")
+ (if (and (eq system-type 'android)
+ ;; Mind that the unzip provided by Android
+ ;; does not understand -qq or -c, their
+ ;; functions being assumed by -q and -p
+ ;; respectively. Furthermore, the user
+ ;; might install an unzip executable
+ ;; distinct from the system-provided unzip,
+ ;; and such situations must be detected as
+ ;; well.
+ (member (executable-find "unzip")
+ '("/bin/unzip"
+ "/system/bin/unzip")))
+ '("unzip" "-q" "-p")
+ '("unzip" "-qq" "-c")))
(archive-7z-program `(,archive-7z-program "x" "-so"))
((executable-find "pkunzip") '("pkunzip" "-e" "-o-"))
(t '("unzip" "-qq" "-c")))
"Program and its options to run in order to extract a zip file member.
-Extraction should happen to standard output. Archive and member name will
-be added."
+Extraction should happen to standard output. Archive and member
+name will be added."
:type '(list (string :tag "Program")
(repeat :tag "Options"
:inline t
@@ -645,6 +659,49 @@ Does not signal an error if optional argument NOERROR is non-nil."
(if (not noerror)
(error "Line does not describe a member of the archive")))))
;; -------------------------------------------------------------------------
+;;; Section: Helper functions for requiring filename extensions
+
+(defun archive--act-files (command files)
+ (lambda (archive)
+ (apply #'call-process (car command)
+ nil nil nil (append (cdr command) (cons archive files)))))
+
+(defun archive--need-rename-p (&optional archive)
+ (let ((archive
+ (file-name-nondirectory (or archive buffer-file-name))))
+ (cl-case archive-subtype
+ ((zip) (not (seq-contains-p archive ?. #'eq))))))
+
+(defun archive--ensure-extension (archive ensure-extension)
+ (if ensure-extension
+ (make-temp-name (expand-file-name (concat archive "_tmp.")))
+ archive))
+
+(defun archive--maybe-rename (newname need-rename-p)
+ ;; Operating with archive as current buffer, and protect
+ ;; `default-directory' from being modified in `rename-visited-file'.
+ (when need-rename-p
+ (let ((default-directory default-directory))
+ (rename-visited-file newname))))
+
+(defun archive--with-ensure-extension (archive proc-fn)
+ (let ((saved default-directory))
+ (with-current-buffer (find-buffer-visiting archive)
+ (let ((ensure-extension (archive--need-rename-p))
+ (default-directory saved))
+ (unwind-protect
+ ;; Some archive programs (like zip) expect filenames to
+ ;; have an extension, so if necessary, temporarily rename
+ ;; an extensionless file for write accesses.
+ (let ((archive (archive--ensure-extension
+ archive ensure-extension)))
+ (archive--maybe-rename archive ensure-extension)
+ (let ((exitcode (funcall proc-fn archive)))
+ (or (zerop exitcode)
+ (error "Updating was unsuccessful (%S)" exitcode))))
+ (progn (archive--maybe-rename archive ensure-extension)
+ (revert-buffer nil t)))))))
+;; -------------------------------------------------------------------------
;;; Section: the mode definition
;;;###autoload
@@ -1378,16 +1435,9 @@ 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
- nil
- nil
- (append (cdr command)
- (list archive ename)))))
- (or (zerop exitcode)
- (error "Updating was unsuccessful (%S)" exitcode))))
+ (default-directory (file-name-as-directory archive-tmpdir)))
+ (archive--with-ensure-extension
+ archive (archive--act-files command (list ename)))))
(archive-delete-local tmpfile))))
(defun archive-write-file (&optional file)
@@ -1510,9 +1560,7 @@ as a relative change like \"g+rw\" as for chmod(2)."
(archive-resummarize))
(error "Setting group is not supported for this archive type"))))
-(defun archive-expunge ()
- "Do the flagged deletions."
- (interactive)
+(defun archive--expunge-maybe-force (force)
(let (files)
(save-excursion
(goto-char archive-file-list-start)
@@ -1526,7 +1574,8 @@ as a relative change like \"g+rw\" as for chmod(2)."
(and files
(or (not archive-read-only)
(error "Archive is read-only"))
- (or (yes-or-no-p (format "Really delete %d member%s? "
+ (or force
+ (yes-or-no-p (format "Really delete %d member%s? "
(length files)
(if (null (cdr files)) "" "s")))
(error "Operation aborted"))
@@ -1540,13 +1589,14 @@ as a relative change like \"g+rw\" as for chmod(2)."
(archive-resummarize)
(revert-buffer))))))
+(defun archive-expunge ()
+ "Do the flagged deletions."
+ (interactive)
+ (archive--expunge-maybe-force nil))
+
(defun archive-*-expunge (archive files command)
- (apply #'call-process
- (car command)
- nil
- nil
- nil
- (append (cdr command) (cons archive files))))
+ (archive--with-ensure-extension
+ archive (archive--act-files command files)))
(defun archive-rename-entry (newname)
"Change the name associated with this entry in the archive file."
@@ -2058,16 +2108,14 @@ This doesn't recover lost files, it just undoes changes in the buffer itself."
(t
(archive-extract-by-stdout
archive
- ;; unzip expands wildcards in NAME, so we need to quote it. But
- ;; not on DOS/Windows, since that fails extraction on those
- ;; systems (unless w32-quote-process-args is nil), and file names
- ;; with wildcards in zip archives don't work there anyway.
- ;; FIXME: Does pkunzip need similar treatment?
- (if (and (or (not (memq system-type '(windows-nt ms-dos)))
- (and (boundp 'w32-quote-process-args)
- (null w32-quote-process-args)))
- (equal (car archive-zip-extract) "unzip"))
- (shell-quote-argument name)
+ ;; unzip expands wildcard characters in NAME, so we need to quote
+ ;; wildcard characters in a special way: replace each such
+ ;; character C with a single-character alternative [C]. We
+ ;; cannot use 'shell-quote-argument' here because that doesn't
+ ;; protect wildcard characters from being expanded by unzip
+ ;; itself.
+ (if (equal (car archive-zip-extract) "unzip")
+ (replace-regexp-in-string "[[?*]" "[\\&]" name)
name)
archive-zip-extract))))
diff --git a/lisp/auth-source-pass.el b/lisp/auth-source-pass.el
index 047957dbe0b..03fd1f35811 100644
--- a/lisp/auth-source-pass.el
+++ b/lisp/auth-source-pass.el
@@ -122,9 +122,9 @@ HOSTS can be a string or a list of strings."
(defun auth-source-pass--build-result-many (hosts ports users require max)
"Return multiple `auth-source-pass--build-result' values."
- (unless (listp hosts) (setq hosts (list hosts)))
- (unless (listp users) (setq users (list users)))
- (unless (listp ports) (setq ports (list ports)))
+ (setq hosts (ensure-list hosts))
+ (setq users (ensure-list users))
+ (setq ports (ensure-list ports))
(let* ((auth-source-pass--match-regexp (auth-source-pass--match-regexp
auth-source-pass-port-separator))
(rv (auth-source-pass--find-match-many hosts users ports
diff --git a/lisp/auth-source.el b/lisp/auth-source.el
index 5969cdbf9f8..5f5629d9cfc 100644
--- a/lisp/auth-source.el
+++ b/lisp/auth-source.el
@@ -233,8 +233,8 @@ EPA/EPG set up, the file will be encrypted and decrypted
automatically. See Info node `(epa)Encrypting/decrypting gpg files'
for details.
-It's best to customize this with `\\[customize-variable]' because the choices
-can get pretty complex."
+It's best to customize this with \\[customize-variable] because
+the choices can get pretty complex."
:version "26.1" ; neither new nor changed default
:type `(repeat :tag "Authentication Sources"
(choice
@@ -386,7 +386,6 @@ soon as a function returns non-nil.")
(cond
((equal extension "plist")
(auth-source-backend
- source
:source source
:type 'plstore
:search-function #'auth-source-plstore-search
@@ -394,13 +393,11 @@ soon as a function returns non-nil.")
:data (plstore-open source)))
((member-ignore-case extension '("json"))
(auth-source-backend
- source
:source source
:type 'json
:search-function #'auth-source-json-search))
(t
(auth-source-backend
- source
:source source
:type 'netrc
:search-function #'auth-source-netrc-search
@@ -448,7 +445,6 @@ soon as a function returns non-nil.")
(setq source (symbol-name source)))
(auth-source-backend
- (format "Mac OS Keychain (%s)" source)
:source source
:type keychain-type
:search-function #'auth-source-macos-keychain-search
@@ -489,7 +485,6 @@ soon as a function returns non-nil.")
(if (featurep 'secrets)
(auth-source-backend
- (format "Secrets API (%s)" source)
:source source
:type 'secrets
:search-function #'auth-source-secrets-search
@@ -497,7 +492,6 @@ soon as a function returns non-nil.")
(auth-source-do-warn
"auth-source-backend-parse: no Secrets API, ignoring spec: %S" entry)
(auth-source-backend
- (format "Ignored Secrets API (%s)" source)
:source ""
:type 'ignore))))))
@@ -898,8 +892,7 @@ Remove trailing \": \"."
(defun auth-source-ensure-strings (values)
(if (eq values t)
values
- (unless (listp values)
- (setq values (list values)))
+ (setq values (ensure-list values))
(mapcar (lambda (value)
(if (numberp value)
(format "%s" value)
@@ -1952,25 +1945,30 @@ entries for git.gnus.org:
(returned-keys (delete-dups (append
'(:host :login :port :secret)
search-keys)))
- ;; Extract host and port from spec
+ ;; Extract host, port and user from spec
(hosts (plist-get spec :host))
- (hosts (if (and hosts (listp hosts)) hosts `(,hosts)))
+ (hosts (if (consp hosts) hosts `(,hosts)))
(ports (plist-get spec :port))
- (ports (if (and ports (listp ports)) ports `(,ports)))
+ (ports (if (consp ports) ports `(,ports)))
+ (users (plist-get spec :user))
+ (users (if (consp users) users `(,users)))
;; Loop through all combinations of host/port and pass each of these to
- ;; auth-source-macos-keychain-search-items
+ ;; auth-source-macos-keychain-search-items. Convert numeric port to
+ ;; string (bug#68376).
(items (catch 'match
(dolist (host hosts)
(dolist (port ports)
- (let* ((port (if port (format "%S" port)))
- (items (apply #'auth-source-macos-keychain-search-items
- coll
- type
- max
- host port
- search-spec)))
- (when items
- (throw 'match items)))))))
+ (when (numberp port) (setq port (number-to-string port)))
+ (dolist (user users)
+ (let ((items (apply
+ #'auth-source-macos-keychain-search-items
+ coll
+ type
+ max
+ host port user
+ search-spec)))
+ (when items
+ (throw 'match items))))))))
;; ensure each item has each key in `returned-keys'
(items (mapcar (lambda (plist)
@@ -1987,7 +1985,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
@@ -2002,8 +2000,9 @@ entries for git.gnus.org:
collect var))
'utf-8)))
-(cl-defun auth-source-macos-keychain-search-items (coll _type _max host port
- &key label type user
+(cl-defun auth-source-macos-keychain-search-items (coll _type _max
+ host port user
+ &key label type
&allow-other-keys)
(let* ((keychain-generic (eq type 'macos-keychain-generic))
(args `(,(if keychain-generic
@@ -2021,47 +2020,49 @@ entries for git.gnus.org:
(when port
(if keychain-generic
(setq args (append args (list "-s" port)))
- (setq args (append args (list
- (if (string-match "[0-9]+" port) "-P" "-r")
- port)))))
+ (setq args (append args (if (string-match-p "\\`[[:digit:]]+\\'" port)
+ (list "-P" port)
+ (list "-r" (substring
+ (format "%-4s" port)
+ 0 4)))))))
- (unless (equal coll "default")
- (setq args (append args (list coll))))
+ (unless (equal coll "default")
+ (setq args (append args (list coll))))
- (with-temp-buffer
- (apply #'call-process "/usr/bin/security" nil t nil args)
- (goto-char (point-min))
- (while (not (eobp))
- (cond
- ((looking-at "^password: \\(?:0x[0-9A-F]+\\)? *\"\\(.+\\)\"")
- (setq ret (auth-source-macos-keychain-result-append
- ret
- keychain-generic
- "secret"
- (let ((v (auth-source--decode-octal-string
- (match-string 1))))
- (lambda () v)))))
- ;; TODO: check if this is really the label
- ;; match 0x00000007 <blob>="AppleID"
- ((looking-at
- "^[ ]+0x00000007 <blob>=\\(?:0x[0-9A-F]+\\)? *\"\\(.+\\)\"")
- (setq ret (auth-source-macos-keychain-result-append
- ret
- keychain-generic
- "label"
- (auth-source--decode-octal-string (match-string 1)))))
- ;; match "crtr"<uint32>="aapl"
- ;; match "svce"<blob>="AppleID"
- ((looking-at
- "^[ ]+\"\\([a-z]+\\)\"[^=]+=\\(?:0x[0-9A-F]+\\)? *\"\\(.+\\)\"")
- (setq ret (auth-source-macos-keychain-result-append
- ret
- keychain-generic
- (auth-source--decode-octal-string (match-string 1))
- (auth-source--decode-octal-string (match-string 2))))))
- (forward-line)))
- ;; return `ret' iff it has the :secret key
- (and (plist-get ret :secret) (list ret))))
+ (with-temp-buffer
+ (apply #'call-process "/usr/bin/security" nil t nil args)
+ (goto-char (point-min))
+ (while (not (eobp))
+ (cond
+ ((looking-at "^password: \\(?:0x[0-9A-F]+\\)? *\"\\(.+\\)\"")
+ (setq ret (auth-source-macos-keychain-result-append
+ ret
+ keychain-generic
+ "secret"
+ (let ((v (auth-source--decode-octal-string
+ (match-string 1))))
+ (lambda () v)))))
+ ;; TODO: check if this is really the label
+ ;; match 0x00000007 <blob>="AppleID"
+ ((looking-at
+ "^[ ]+0x00000007 <blob>=\\(?:0x[0-9A-F]+\\)? *\"\\(.+\\)\"")
+ (setq ret (auth-source-macos-keychain-result-append
+ ret
+ keychain-generic
+ "label"
+ (auth-source--decode-octal-string (match-string 1)))))
+ ;; match "crtr"<uint32>="aapl"
+ ;; match "svce"<blob>="AppleID"
+ ((looking-at
+ "^[ ]+\"\\([a-z]+\\)\"[^=]+=\\(?:0x[0-9A-F]+\\)? *\"\\(.+\\)\"")
+ (setq ret (auth-source-macos-keychain-result-append
+ ret
+ keychain-generic
+ (auth-source--decode-octal-string (match-string 1))
+ (auth-source--decode-octal-string (match-string 2))))))
+ (forward-line)))
+ ;; return `ret' iff it has the :secret key
+ (and (plist-get ret :secret) (list ret))))
(defun auth-source-macos-keychain-result-append (result generic k v)
(push v result)
diff --git a/lisp/battery.el b/lisp/battery.el
index 6eaa49fa070..4aae3e0ef54 100644
--- a/lisp/battery.el
+++ b/lisp/battery.el
@@ -29,9 +29,11 @@
;; - The `/sys/class/power_supply/' files of Linux >= 2.6.39.
;; - The `/proc/acpi/' directory structure of Linux 2.4.20 and 2.6.
;; - The `/proc/apm' file format of Linux version 1.3.58 or newer.
+;; - The Haiku ACPI battery driver.
;; - BSD by using the `apm' program.
;; - Darwin (macOS) by using the `pmset' program.
;; - Windows via the GetSystemPowerStatus API call.
+;; - Android 5 or later via the BatteryManager APIs.
;;; Code:
@@ -106,6 +108,12 @@ Value does not include \".\" or \"..\"."
(file-readable-p "/proc/")
(file-readable-p "/proc/apm"))
#'battery-linux-proc-apm)
+ ;; Now try the Android battery status function.
+ ;; Note that even though the Linux kernel APIs are sometimes
+ ;; available on Android, they are badly implemented by Android
+ ;; kernels, so avoid using those.
+ ((eq system-type 'android)
+ #'battery-android)
((and (eq system-type 'berkeley-unix)
(file-executable-p "/usr/sbin/apm"))
#'battery-bsd-apm)
@@ -1072,6 +1080,78 @@ The following %-sequences are provided:
(cons ?t (or remaining-time "N/A")))))
+;;; `BatteryManager' interface for Android.
+
+(declare-function android-query-battery "androidfns.c")
+
+(defun battery-android ()
+ "Get battery status information using Android.
+
+The following %-sequences are provided:
+%c Current capacity (mAh)
+%r Current rate of charge or discharge (mA)
+%L AC line status (verbose).
+%B Battery status (verbose)
+%b Battery status, empty means high, `-' means low,
+ `+' means charging and `?' means unknown.
+%d Temperature (in degrees Celsius)
+%p Battery load percentage.
+%m Remaining time (to charge) in minutes.
+%h Remaining time (to charge) in hours.
+%t Remaining time (to charge) in the form `h:min'."
+ (when-let* ((status (android-query-battery)))
+ (let* ((percentage nil)
+ (capacity nil)
+ (sym-status nil)
+ (symbol nil)
+ (rate nil)
+ (remaining nil)
+ (hours nil)
+ (minutes nil))
+ ;; Figure out the percentage.
+ (setq percentage (number-to-string (car status)))
+ ;; Figure out the capacity
+ (setq capacity (number-to-string (/ (cadr status) 1000)))
+ ;; Figure out the battery status.
+ (let ((percentage (car status)))
+ (cl-ecase (nth 4 status)
+ (2 (setq sym-status "charging" symbol "+"))
+ (3 (setq sym-status "discharging"
+ symbol (if (< percentage 15) "-" " ")))
+ (5 (setq sym-status "full" symbol " "))
+ (4 (setq sym-status "not charging"
+ symbol (if (< percentage 15) "-" " ")))
+ (1 (setq sym-status "unknown" symbol "?"))))
+ ;; Figure out the rate of charge.
+ (setq rate (/ (nth 3 status) 1000))
+ ;; Figure out the remaining time.
+ (let* ((time (nth 5 status))
+ (mins (/ time (* 1000 60)))
+ (hours-left (/ mins 60))
+ (mins (mod mins 60)))
+ (unless (eq time -1)
+ (setq remaining (format "%d:%d" hours-left mins)
+ hours (number-to-string hours-left)
+ minutes (number-to-string mins))))
+ ;; Return results.
+ (list (cons ?c capacity)
+ (cons ?p percentage)
+ (cons ?r rate)
+ (cons ?B sym-status)
+ (cons ?b symbol)
+ (cons ?m (or minutes "N/A"))
+ (cons ?h (or hours "N/A"))
+ (cons ?t (or remaining "N/A"))
+ (cons ?L (cl-case (nth 6 status)
+ (0 "off-line")
+ (1 "on-line")
+ (2 "on-line (dock)")
+ (3 "on-line (USB)")
+ (4 "on-line (wireless)")
+ (t "unknown")))
+ (cons ?t (/ (or (nth 7 status) 0) 10.0))))))
+
+
;;; Private functions.
(defun battery-format (format alist)
diff --git a/lisp/use-package/bind-key.el b/lisp/bind-key.el
index 2c70357a1c0..780314fecbd 100644
--- a/lisp/use-package/bind-key.el
+++ b/lisp/bind-key.el
@@ -6,11 +6,13 @@
;; Maintainer: John Wiegley <johnw@newartisans.com>
;; Created: 16 Jun 2012
;; Version: 2.4.1
-;; Package: bind-key
;; Package-Requires: ((emacs "24.3"))
;; Keywords: keys keybinding config dotemacs extensions
;; URL: https://github.com/jwiegley/use-package
+;; This is a GNU ELPA :core package. Avoid functionality that is not
+;; compatible with the version of Emacs recorded above.
+
;; This file is part of GNU Emacs.
;; GNU Emacs is free software: you can redistribute it and/or modify
@@ -153,6 +155,7 @@ add keys to that keymap."
(add-to-list 'emulation-mode-map-alists
`((override-global-mode . ,override-global-map)))
+;;;###autoload
(defvar personal-keybindings nil
"List of bindings performed by `bind-key'.
@@ -449,34 +452,31 @@ This binds keys in such a way that bindings are not overridden by
other modes. See `override-global-mode'."
(macroexp-progn (bind-keys-form args 'override-global-map)))
-(defun get-binding-description (elem)
- (cond
- ((listp elem)
+(defun bind-key--get-binding-description (elem)
+ (let (doc)
(cond
- ((memq (car elem) '(lambda function))
- (if (and bind-key-describe-special-forms
- (stringp (nth 2 elem)))
- (nth 2 elem)
- "#<lambda>"))
- ((eq 'closure (car elem))
- (if (and bind-key-describe-special-forms
- (stringp (nth 3 elem)))
- (nth 3 elem)
- "#<closure>"))
- ((eq 'keymap (car elem))
- "#<keymap>")
+ ((symbolp elem)
+ (cond
+ ((and bind-key-describe-special-forms (keymapp elem)
+ ;; FIXME: Is this really ever better than the symbol-name?
+ ;; FIXME: `variable-documentation' describe what's in
+ ;; elem's `symbol-value', whereas `elem' here stands for
+ ;; its `symbol-function'.
+ (stringp (setq doc (get elem 'variable-documentation))))
+ doc)
+ (t elem)))
+ ((and bind-key-describe-special-forms (functionp elem)
+ (stringp (setq doc (documentation elem))))
+ doc) ;;FIXME: Keep only the first line?
+ ;; FIXME: Use `help-fns-function-name'?
+ ((consp elem)
+ (if (symbolp (car elem))
+ (format "#<%s>" (car elem))
+ elem))
(t
- elem)))
- ;; must be a symbol, non-symbol keymap case covered above
- ((and bind-key-describe-special-forms (keymapp elem))
- (let ((doc (get elem 'variable-documentation)))
- (if (stringp doc) doc elem)))
- ((symbolp elem)
- elem)
- (t
- "#<byte-compiled lambda>")))
-
-(defun compare-keybindings (l r)
+ (format "#<%s>" (type-of elem))))))
+
+(defun bind-key--compare-keybindings (l r)
(let* ((regex bind-key-segregation-regexp)
(lgroup (and (string-match regex (caar l))
(match-string 0 (caar l))))
@@ -519,7 +519,7 @@ other modes. See `override-global-mode'."
(setq personal-keybindings
(sort personal-keybindings
(lambda (l r)
- (car (compare-keybindings l r))))))
+ (car (bind-key--compare-keybindings l r))))))
(if (not (eq (cdar last-binding) (cdar binding)))
(princ (format "\n\n%s: %s\n%s\n\n"
@@ -527,7 +527,7 @@ other modes. See `override-global-mode'."
(make-string (+ 21 (car bind-key-column-widths)
(cdr bind-key-column-widths)) ?-)))
(if (and last-binding
- (cdr (compare-keybindings last-binding binding)))
+ (cdr (bind-key--compare-keybindings last-binding binding)))
(princ "\n")))
(let* ((key-name (caar binding))
@@ -536,10 +536,10 @@ other modes. See `override-global-mode'."
(read-kbd-macro key-name)))
(command (nth 1 binding))
(was-command (nth 2 binding))
- (command-desc (get-binding-description command))
+ (command-desc (bind-key--get-binding-description command))
(was-command-desc (and was-command
- (get-binding-description was-command)))
- (at-present-desc (get-binding-description at-present)))
+ (bind-key--get-binding-description was-command)))
+ (at-present-desc (bind-key--get-binding-description at-present)))
(let ((line
(format
(format "%%-%ds%%-%ds%%s\n" (car bind-key-column-widths)
@@ -557,6 +557,11 @@ other modes. See `override-global-mode'."
(setq last-binding binding)))))
+(define-obsolete-function-alias 'get-binding-description
+ 'bind-key--get-binding-description "30.1")
+(define-obsolete-function-alias 'compare-keybindings
+ 'bind-key--compare-keybindings "30.1")
+
(provide 'bind-key)
;; Local Variables:
diff --git a/lisp/bindings.el b/lisp/bindings.el
index b4e20513a65..4690897fed4 100644
--- a/lisp/bindings.el
+++ b/lisp/bindings.el
@@ -298,12 +298,108 @@ Value is used for `mode-line-frame-identification', which see."
;;;###autoload
(put 'mode-line-frame-identification 'risky-local-variable t)
+(defvar mode-line-window-dedicated-keymap
+ (let ((map (make-sparse-keymap)))
+ (define-key map [mode-line mouse-1] #'toggle-window-dedicated)
+ (purecopy map)) "\
+Keymap for what is displayed by `mode-line-window-dedicated'.")
+
+(defun mode-line-window-control ()
+ "Compute mode line construct for window dedicated state.
+Value is used for `mode-line-window-dedicated', which see."
+ (cond
+ ((eq (window-dedicated-p) t)
+ (propertize
+ "D"
+ 'help-echo "Window strongly dedicated to its buffer\nmouse-1: Toggle"
+ 'local-map mode-line-window-dedicated-keymap
+ 'mouse-face 'mode-line-highlight))
+ ((window-dedicated-p)
+ (propertize
+ "d"
+ 'help-echo "Window dedicated to its buffer\nmouse-1: Toggle"
+ 'local-map mode-line-window-dedicated-keymap
+ 'mouse-face 'mode-line-highlight))
+ (t "")))
+
+(defvar mode-line-window-dedicated '(:eval (mode-line-window-control))
+ "Mode line construct to describe the current window.")
+;;;###autoload
+(put 'mode-line-window-dedicated 'risky-local-variable t)
+
(defvar-local mode-line-process nil
"Mode line construct for displaying info on process status.
Normally nil in most modes, since there is no process to display.")
;;;###autoload
(put 'mode-line-process 'risky-local-variable t)
+(defcustom mode-line-right-align-edge 'window
+ "Where function `mode-line-format-right-align' should align to.
+Internally, that function uses `:align-to' in a display property,
+so aligns to the left edge of the given area. See info node
+`(elisp)Pixel Specification'.
+
+Must be set to a symbol. Acceptable values are:
+- `window': align to extreme right of window, regardless of margins
+ or fringes
+- `right-fringe': align to right-fringe
+- `right-margin': align to right-margin"
+ :type '(choice (const right-margin)
+ (const right-fringe)
+ (const window))
+ :group 'mode-line
+ :version "30.1")
+
+(defun mode--line-format-right-align ()
+ "Right-align all following mode-line constructs.
+
+When the symbol `mode-line-format-right-align' appears in
+`mode-line-format', return a string of one space, with a display
+property to make it appear long enough to align anything after
+that symbol to the right of the rendered mode line. Exactly how
+far to the right is controlled by `mode-line-right-align-edge'.
+
+It is important that the symbol `mode-line-format-right-align' be
+included in `mode-line-format' (and not another similar construct
+such as `(:eval (mode-line-format-right-align)'). This is because
+the symbol `mode-line-format-right-align' is processed by
+`format-mode-line' as a variable."
+ (let* ((rest (cdr (memq 'mode-line-format-right-align
+ mode-line-format)))
+ (rest-str (format-mode-line `("" ,@rest)))
+ (rest-width (progn
+ (add-face-text-property
+ 0 (length rest-str) 'mode-line t rest-str)
+ (string-pixel-width rest-str))))
+ (propertize " " 'display
+ ;; The `right' spec doesn't work on TTY frames
+ ;; when windows are split horizontally (bug#59620)
+ (if (and (display-graphic-p)
+ (not (eq mode-line-right-align-edge 'window)))
+ `(space :align-to (- ,mode-line-right-align-edge
+ (,rest-width)))
+ `(space :align-to (,(- (window-pixel-width)
+ (window-scroll-bar-width)
+ (window-right-divider-width)
+ (* (or (cdr (window-margins)) 1)
+ (frame-char-width))
+ ;; Manually account for value of
+ ;; `mode-line-right-align-edge' even
+ ;; when display is non-graphical
+ (pcase mode-line-right-align-edge
+ ('right-margin
+ (or (cdr (window-margins)) 0))
+ ('right-fringe
+ ;; what here?
+ (or (cadr (window-fringes)) 0))
+ (_ 0))
+ rest-width)))))))
+
+(defvar mode-line-format-right-align '(:eval (mode--line-format-right-align))
+ "Mode line construct to right align all following constructs.")
+;;;###autoload
+(put 'mode-line-format-right-align 'risky-local-variable t)
+
(defun bindings--define-key (map key item)
"Define KEY in keymap MAP according to ITEM from a menu.
This is like `define-key', but it takes the definition from the
@@ -609,12 +705,14 @@ By default, this shows the information specified by `global-mode-string'.")
'mode-line-mule-info
'mode-line-client
'mode-line-modified
- 'mode-line-remote)
- 'display '(min-width (5.0)))
+ 'mode-line-remote
+ 'mode-line-window-dedicated)
+ 'display '(min-width (6.0)))
'mode-line-frame-identification
'mode-line-buffer-identification
" "
'mode-line-position
+ '(project-mode-line project-mode-line-format)
'(vc-mode vc-mode)
" "
'mode-line-modes
@@ -670,6 +768,8 @@ or not."
"Return the value of symbol VAR if it is bound, else nil.
Note that if `lexical-binding' is in effect, this function isn't
meaningful if it refers to a lexically bound variable."
+ (unless (symbolp var)
+ (signal 'wrong-type-argument (list 'symbolp var)))
`(and (boundp (quote ,var)) ,var))
;; Use mode-line-mode-menu for local minor-modes only.
@@ -725,7 +825,7 @@ meaningful if it refers to a lexically bound variable."
"Describe minor mode for EVENT on minor modes area of the mode line."
(interactive "@e")
(let ((indicator (car (nth 4 (car (cdr event))))))
- (describe-minor-mode-from-indicator indicator)))
+ (describe-minor-mode-from-indicator indicator event)))
(defvar mode-line-defining-kbd-macro (propertize " Def" 'face 'font-lock-warning-face)
"String displayed in the mode line in keyboard macro recording mode.")
@@ -1216,6 +1316,10 @@ if `inhibit-field-text-motion' is non-nil."
(define-key global-map [insertchar] 'overwrite-mode)
(define-key global-map [C-insertchar] 'kill-ring-save)
(define-key global-map [S-insertchar] 'yank)
+;; The next three keys are used on MS Windows and Android.
+(define-key global-map [copy] 'kill-ring-save)
+(define-key global-map [paste] 'yank)
+(define-key global-map [cut] 'kill-region)
(define-key global-map [undo] 'undo)
(define-key global-map [redo] 'repeat-complex-command)
(define-key global-map [again] 'repeat-complex-command) ; Sun keyboard
@@ -1535,6 +1639,9 @@ if `inhibit-field-text-motion' is non-nil."
(define-key special-event-map [sigusr1] 'ignore)
(define-key special-event-map [sigusr2] 'ignore)
+;; Text conversion
+(define-key global-map [text-conversion] 'analyze-text-conversion)
+
;; Don't look for autoload cookies in this file.
;; Local Variables:
;; no-update-autoloads: t
diff --git a/lisp/bookmark.el b/lisp/bookmark.el
index 56b43b3e1d3..bf2357207d8 100644
--- a/lisp/bookmark.el
+++ b/lisp/bookmark.el
@@ -142,7 +142,7 @@ Nil means don't prompt for confirmation."
"Non-nil means show annotations when jumping to a bookmark."
:type 'boolean)
-(defconst bookmark-bmenu-buffer "*Bookmark List*"
+(defvar bookmark-bmenu-buffer "*Bookmark List*"
"Name of buffer used for Bookmark List.")
(defvar bookmark-bmenu-use-header-line t
@@ -511,12 +511,15 @@ BM is a bookmark as returned from function `bookmark-get-bookmark'.
See user option `bookmark-fringe-mark'."
(let ((filename (cdr (assq 'filename bm)))
(pos (cdr (assq 'position bm)))
+ ;; Don't expand file names for non-existing remote connections.
+ (non-essential t)
overlays found temp)
(when (and pos filename)
- (setq filename (expand-file-name filename))
+ (setq filename (abbreviate-file-name (expand-file-name filename)))
(dolist (buf (buffer-list))
(with-current-buffer buf
- (when (equal filename buffer-file-name)
+ (when (equal filename
+ (ignore-errors (bookmark-buffer-file-name)))
(setq overlays
(save-excursion
(goto-char pos)
@@ -1190,6 +1193,8 @@ it to the name of the bookmark currently being set, advancing
(if (stringp dired-directory)
dired-directory
(car dired-directory)))
+ ((and (boundp 'Info-current-file) (stringp Info-current-file))
+ Info-current-file)
(t (error "Buffer not visiting a file or directory")))))
(defvar bookmark--watch-already-asked-mtime nil
diff --git a/lisp/bs.el b/lisp/bs.el
index c71fbff8449..9db93ea0423 100644
--- a/lisp/bs.el
+++ b/lisp/bs.el
@@ -420,9 +420,6 @@ naming a sort behavior. Default is \"by nothing\" which means no sorting."
Non-nil means to show all buffers. Otherwise show buffers
defined by current configuration `bs-current-configuration'.")
-(defvar bs--window-config-coming-from nil
- "Window configuration before starting Buffer Selection Menu.")
-
(defvar bs--intern-show-never "^ \\|\\*buffer-selection\\*"
"Regular expression specifying which buffers never to show.
A buffer whose name matches this regular expression will never be
@@ -491,6 +488,23 @@ Used internally, only.")
"<mouse-2>" #'bs-mouse-select
"<mouse-3>" #'bs-mouse-select-other-frame)
+(defcustom bs-default-action-list '((display-buffer-reuse-window
+ display-buffer-below-selected)
+ (reusable-frames . nil)
+ (window-height . window-min-height))
+ "Default action list for showing the '*bs-selection*' buffer.
+
+This list will be passed to `pop-to-buffer' as its ACTION argument.
+It should be a cons cell (FUNCTIONS . ALIST), where FUNCTIONS is
+an action function or a list of action functions and ALIST is an
+action alist. Each such action function should accept two
+arguments: a buffer to display and an alist of the same form as
+ALIST. See `display-buffer' for details."
+ :type display-buffer--action-custom-type
+ :risky t
+ :version "30.1"
+ :group 'bs)
+
;; ----------------------------------------------------------------------
;; Functions
;; ----------------------------------------------------------------------
@@ -590,21 +604,6 @@ in `bs-string-current' or `bs-string-current-marked'."
(format "Show buffer by configuration %S"
bs-current-configuration)))
-(defun bs--track-window-changes (frame)
- "Track window changes to refresh the buffer list.
-Used from `window-size-change-functions'."
- (let ((win (get-buffer-window "*buffer-selection*" frame)))
- (when win
- (with-selected-window win
- (bs--set-window-height)))))
-
-(defun bs--remove-hooks ()
- "Remove `bs--track-window-changes' and auxiliary hooks."
- (remove-hook 'window-size-change-functions 'bs--track-window-changes)
- ;; Remove itself
- (remove-hook 'kill-buffer-hook 'bs--remove-hooks t)
- (remove-hook 'change-major-mode-hook 'bs--remove-hooks t))
-
(put 'bs-mode 'mode-class 'special)
(define-derived-mode bs-mode nil "Buffer-Selection-Menu"
@@ -663,25 +662,13 @@ apply it.
(setq-local font-lock-defaults '(bs-mode-font-lock-keywords t))
(setq-local font-lock-verbose nil)
(setq-local font-lock-global-modes '(not bs-mode))
- (setq-local revert-buffer-function 'bs-refresh)
- (add-hook 'window-size-change-functions 'bs--track-window-changes)
- (add-hook 'kill-buffer-hook 'bs--remove-hooks nil t)
- (add-hook 'change-major-mode-hook 'bs--remove-hooks nil t))
-
-(defun bs--restore-window-config ()
- "Restore window configuration on the current frame."
- (when bs--window-config-coming-from
- (let ((frame (selected-frame)))
- (unwind-protect
- (set-window-configuration bs--window-config-coming-from)
- (select-frame frame)))
- (setq bs--window-config-coming-from nil)))
+ (setq-local revert-buffer-function 'bs-refresh))
(defun bs-kill ()
"Let buffer disappear and reset window configuration."
(interactive)
(bury-buffer (current-buffer))
- (bs--restore-window-config))
+ (quit-window))
(defun bs-abort ()
"Ding and leave Buffer Selection Menu without a selection."
@@ -705,7 +692,9 @@ Arguments are IGNORED (for `revert-buffer')."
(defun bs--set-window-height ()
"Change the height of the selected window to suit the current buffer list."
(unless (one-window-p t)
- (fit-window-to-buffer (selected-window) bs-max-window-height)))
+ (fit-window-to-buffer (selected-window) bs-max-window-height nil nil nil
+ ;; preserve-size
+ t)))
(defun bs--current-buffer ()
"Return buffer on current line.
@@ -742,7 +731,7 @@ Leave Buffer Selection Menu."
(interactive)
(let ((buffer (bs--current-buffer)))
(bury-buffer (current-buffer))
- (bs--restore-window-config)
+ (quit-window)
(switch-to-buffer buffer)
(when bs--marked-buffers
;; Some marked buffers for selection
@@ -765,7 +754,7 @@ Leave Buffer Selection Menu."
(interactive)
(let ((buffer (bs--current-buffer)))
(bury-buffer (current-buffer))
- (bs--restore-window-config)
+ (quit-window)
(switch-to-buffer-other-window buffer)))
(defun bs-tmp-select-other-window ()
@@ -781,7 +770,7 @@ Leave Buffer Selection Menu."
(interactive)
(let ((buffer (bs--current-buffer)))
(bury-buffer (current-buffer))
- (bs--restore-window-config)
+ (quit-window)
(switch-to-buffer-other-frame buffer)))
(defun bs-mouse-select-other-frame (event)
@@ -944,7 +933,7 @@ WHAT is a value of nil, `never', or `always'."
(end-of-line)
(if (eobp) (point) (1+ (point)))))
(when (eobp)
- (backward-delete-char 1)
+ (delete-char -1)
(beginning-of-line)
(recenter -1))
(bs--set-window-height)))
@@ -1165,7 +1154,18 @@ Select buffer *buffer-selection* and display buffers according to current
configuration `bs-current-configuration'. Set window height, fontify buffer
and move point to current buffer."
(setq bs-current-list list)
- (switch-to-buffer (get-buffer-create "*buffer-selection*"))
+ (let* ((window-combination-limit 'window-size)
+ (bs-buf (get-buffer-create "*buffer-selection*"))
+ (bs-win (progn
+ (pop-to-buffer bs-buf bs-default-action-list)
+ (selected-window))))
+ ;; Delete other windows showing *buffer-selection*.
+ ;; Done after pop-to-buffer, instead of just calling delete-windows-on,
+ ;; to allow display-buffer-reuse(-mode)?-window to be used in ALIST.
+ (dolist (w (get-buffer-window-list bs-buf 'not t))
+ (unless (eq w bs-win)
+ (with-demoted-errors "Error deleting window: %S"
+ (delete-window w)))))
(bs-mode)
(let* ((inhibit-read-only t)
(map-fun (lambda (entry)
@@ -1346,11 +1346,11 @@ ALL-BUFFERS is the list of buffers appearing in Buffer Selection Menu."
'help-echo "mouse-2: select this buffer, mouse-3: select in other frame"
'mouse-face 'highlight))
-(defun bs--get-mode-name (start-buffer _all-buffers)
+(defun bs--get-mode-name (_start-buffer _all-buffers)
"Return the name of mode of current buffer for Buffer Selection Menu.
START-BUFFER is the buffer where we started buffer selection.
ALL-BUFFERS is the list of buffers appearing in Buffer Selection Menu."
- (format-mode-line mode-name nil nil start-buffer))
+ (format-mode-line mode-name nil nil nil))
(defun bs--get-file-name (_start-buffer _all-buffers)
"Return string for column `File' in Buffer Selection Menu.
@@ -1435,21 +1435,8 @@ for buffer selection."
;; Only when not in buffer *buffer-selection*
;; we have to set the buffer we started the command
(setq bs--buffer-coming-from (current-buffer)))
- (let ((liste (bs-buffer-list))
- (active-window (get-window-with-predicate
- (lambda (w)
- (string= (buffer-name (window-buffer w))
- "*buffer-selection*"))
- nil (selected-frame))))
- (if active-window
- (select-window active-window)
- (bs--restore-window-config)
- (setq bs--window-config-coming-from (current-window-configuration))
- (when (> (window-height) 7)
- ;; Errors would mess with the window configuration (bug#10882).
- (ignore-errors (select-window (split-window-below)))))
- (bs-show-in-buffer liste)
- (bs-message-without-log "%s" (bs--current-config-message)))))
+ (bs-show-in-buffer (bs-buffer-list))
+ (bs-message-without-log "%s" (bs--current-config-message))))
(defun bs--configuration-name-for-prefix-arg (prefix)
"Convert prefix argument PREFIX to a name of a buffer configuration.
diff --git a/lisp/buff-menu.el b/lisp/buff-menu.el
index 82afea3d053..ec5337e3fda 100644
--- a/lisp/buff-menu.el
+++ b/lisp/buff-menu.el
@@ -95,11 +95,35 @@ as it is by default."
:group 'Buffer-menu
:version "22.1")
+(defcustom Buffer-menu-group-by nil
+ "If non-nil, a function to call to divide buffer-menu buffers into groups.
+This function is called with one argument: a list of entries in the same
+format as in `tabulated-list-entries', and should return a list in the
+format suitable for `tabulated-list-groups'. Also, when this variable
+is non-nil, `outline-minor-mode' is enabled in the Buffer Menu and you
+can use Outline minor mode commands to show/hide groups of buffers,
+according to the value of `outline-regexp'.
+The default options can group by a mode, and by a root directory of
+a project or just `default-directory'.
+If this is nil, buffers are not divided into groups."
+ :type '(choice (const :tag "No grouping" nil)
+ (function-item :tag "Group by mode"
+ Buffer-menu-group-by-mode)
+ (function-item :tag "Group by project root or directory"
+ Buffer-menu-group-by-root)
+ (function :tag "Custom function"))
+ :group 'Buffer-menu
+ :version "30.1")
+
(defvar-local Buffer-menu-files-only nil
"Non-nil if the current Buffer Menu lists only file buffers.
This is set by the prefix argument to `buffer-menu' and related
commands.")
+(defvar-local Buffer-menu-show-internal nil
+ "Non-nil if the current Buffer Menu lists internal buffers.
+Internal buffers are those whose names start with a space.")
+
(defvar-local Buffer-menu-filter-predicate nil
"Function to filter out buffers in the buffer list.
Buffers that don't satisfy the predicate will be skipped.
@@ -140,6 +164,7 @@ then the buffer will be displayed in the buffer list.")
"V" #'Buffer-menu-view
"O" #'Buffer-menu-view-other-window
"T" #'Buffer-menu-toggle-files-only
+ "I" #'Buffer-menu-toggle-internal
"M-s a C-s" #'Buffer-menu-isearch-buffers
"M-s a C-M-s" #'Buffer-menu-isearch-buffers-regexp
"M-s a C-o" #'Buffer-menu-multi-occur
@@ -197,6 +222,10 @@ then the buffer will be displayed in the buffer list.")
:help "Toggle whether the current buffer-menu displays only file buffers"
:style toggle
:selected Buffer-menu-files-only]
+ ["Show Internal Buffers" Buffer-menu-toggle-internal
+ :help "Toggle whether the current buffer-menu displays internal buffers"
+ :style toggle
+ :selected Buffer-menu-show-internal]
"---"
["Refresh" revert-buffer
:help "Refresh the *Buffer List* buffer contents"]
@@ -317,6 +346,11 @@ ARG, show only buffers that are visiting files."
(interactive "P")
(display-buffer (list-buffers-noselect arg)))
+(defun Buffer-menu--selection-message ()
+ (message (cond (Buffer-menu-files-only "Showing only file-visiting buffers.")
+ (Buffer-menu-show-internal "Showing all buffers.")
+ (t "Showing all buffers except internal ones."))))
+
(defun Buffer-menu-toggle-files-only (arg)
"Toggle whether the current `buffer-menu' displays only file buffers.
With a positive ARG, display only file buffers. With zero or
@@ -325,9 +359,18 @@ negative ARG, display other buffers as well."
(setq Buffer-menu-files-only
(cond ((not arg) (not Buffer-menu-files-only))
((> (prefix-numeric-value arg) 0) t)))
- (message (if Buffer-menu-files-only
- "Showing only file-visiting buffers."
- "Showing all non-internal buffers."))
+ (Buffer-menu--selection-message)
+ (revert-buffer))
+
+(defun Buffer-menu-toggle-internal (arg)
+ "Toggle whether the current `buffer-menu' displays internal buffers.
+With a positive ARG, don't show internal buffers. With zero or
+negative ARG, display internal buffers as well."
+ (interactive "P" Buffer-menu-mode)
+ (setq Buffer-menu-show-internal
+ (cond ((not arg) (not Buffer-menu-show-internal))
+ ((> (prefix-numeric-value arg) 0) t)))
+ (Buffer-menu--selection-message)
(revert-buffer))
(define-obsolete-function-alias 'Buffer-menu-sort 'tabulated-list-sort
@@ -385,14 +428,12 @@ When called interactively prompt for MARK; RET remove all marks."
(interactive "cRemove marks (RET means all):" Buffer-menu-mode)
(save-excursion
(goto-char (point-min))
- (when (tabulated-list-header-overlay-p)
- (forward-line))
(while (not (eobp))
- (let ((xmarks (list (aref (tabulated-list-get-entry) 0)
- (aref (tabulated-list-get-entry) 2))))
- (when (or (char-equal mark ?\r)
- (member (char-to-string mark) xmarks))
- (Buffer-menu--unmark)))
+ (when-let ((entry (tabulated-list-get-entry)))
+ (let ((xmarks (list (aref entry 0) (aref entry 2))))
+ (when (or (char-equal mark ?\r)
+ (member (char-to-string mark) xmarks))
+ (Buffer-menu--unmark))))
(forward-line))))
(defun Buffer-menu-unmark-all ()
@@ -416,7 +457,7 @@ When called interactively prompt for MARK; RET remove all marks."
(defun Buffer-menu-delete (&optional arg)
"Mark the buffer on this Buffer Menu buffer line for deletion.
-A subsequent \\<Buffer-menu-mode-map>`\\[Buffer-menu-execute]' command
+A subsequent \\<Buffer-menu-mode-map>\\[Buffer-menu-execute] command \
will delete it.
If prefix argument ARG is non-nil, it specifies the number of
@@ -437,16 +478,16 @@ buffers to delete; a negative ARG means to delete backwards."
(defun Buffer-menu-delete-backwards (&optional arg)
"Mark the buffer on this Buffer Menu line for deletion, and move up.
-A subsequent \\<Buffer-menu-mode-map>`\\[Buffer-menu-execute]'
-command will delete the marked buffer. Prefix ARG means move
-that many lines."
+A subsequent \\<Buffer-menu-mode-map>\\[Buffer-menu-execute] command \
+will delete the marked buffer. Prefix ARG
+ means move that many lines."
(interactive "p" Buffer-menu-mode)
(Buffer-menu-delete (- (or arg 1))))
(defun Buffer-menu-save ()
"Mark the buffer on this Buffer Menu line for saving.
-A subsequent \\<Buffer-menu-mode-map>`\\[Buffer-menu-execute]' command
-will save it."
+A subsequent \\<Buffer-menu-mode-map>\\[Buffer-menu-execute] \
+command will save it."
(interactive nil Buffer-menu-mode)
(when (Buffer-menu-buffer)
(tabulated-list-set-col 2 "S" t)
@@ -463,8 +504,8 @@ it as modified."
(defun Buffer-menu-execute ()
"Save and/or delete marked buffers in the Buffer Menu.
-Buffers marked with \\<Buffer-menu-mode-map>`\\[Buffer-menu-save]' are saved.
-Buffers marked with \\<Buffer-menu-mode-map>`\\[Buffer-menu-delete]' are deleted."
+Buffers marked with \\<Buffer-menu-mode-map>\\[Buffer-menu-save] are saved.
+Buffers marked with \\<Buffer-menu-mode-map>\\[Buffer-menu-delete] are deleted."
(interactive nil Buffer-menu-mode)
(save-excursion
(Buffer-menu-beginning)
@@ -492,7 +533,7 @@ Buffers marked with \\<Buffer-menu-mode-map>`\\[Buffer-menu-delete]' are deleted
(defun Buffer-menu-select ()
"Select this line's buffer; also, display buffers marked with `>'.
-You can mark buffers with the \\<Buffer-menu-mode-map>`\\[Buffer-menu-mark]' command.
+You can mark buffers with the \\<Buffer-menu-mode-map>\\[Buffer-menu-mark] command.
This command deletes and replaces all the previously existing windows
in the selected frame, and will remove any marks."
@@ -515,15 +556,16 @@ in the selected frame, and will remove any marks."
(defun Buffer-menu-marked-buffers (&optional unmark)
"Return the list of buffers marked with `Buffer-menu-mark'.
If UNMARK is non-nil, unmark them."
- (let (buffers)
- (Buffer-menu-beginning)
- (while (re-search-forward "^>" nil t)
- (let ((buffer (Buffer-menu-buffer)))
- (if (and buffer unmark)
- (tabulated-list-set-col 0 " " t))
- (if (buffer-live-p buffer)
- (push buffer buffers))))
- (nreverse buffers)))
+ (save-excursion
+ (let (buffers)
+ (Buffer-menu-beginning)
+ (while (re-search-forward "^>" nil t)
+ (let ((buffer (Buffer-menu-buffer)))
+ (if (and buffer unmark)
+ (tabulated-list-set-col 0 " " t))
+ (if (buffer-live-p buffer)
+ (push buffer buffers))))
+ (nreverse buffers))))
(defun Buffer-menu-isearch-buffers ()
"Search for a string through all marked buffers using Isearch."
@@ -569,13 +611,17 @@ If UNMARK is non-nil, unmark them."
(defun Buffer-menu-other-window ()
"Select this line's buffer in other window, leaving buffer menu visible."
(interactive nil Buffer-menu-mode)
- (switch-to-buffer-other-window (Buffer-menu-buffer t)))
+ (let ((display-buffer-overriding-action
+ '(nil (inhibit-same-window . t))))
+ (switch-to-buffer-other-window (Buffer-menu-buffer t))))
(defun Buffer-menu-switch-other-window ()
"Make the other window select this line's buffer.
The current window remains selected."
(interactive nil Buffer-menu-mode)
- (display-buffer (Buffer-menu-buffer t) t))
+ (let ((display-buffer-overriding-action
+ '(nil (inhibit-same-window . t))))
+ (display-buffer (Buffer-menu-buffer t) t)))
(defun Buffer-menu-2-window ()
"Select this line's buffer, with previous buffer in second window."
@@ -647,7 +693,12 @@ See more at `Buffer-menu-filter-predicate'."
(setq Buffer-menu-buffer-list buffer-list)
(setq Buffer-menu-filter-predicate filter-predicate)
(list-buffers--refresh buffer-list old-buffer)
- (tabulated-list-print))
+ (tabulated-list-print)
+ (when tabulated-list-groups
+ (setq-local outline-minor-mode-cycle t
+ outline-minor-mode-highlight t
+ outline-minor-mode-use-buttons 'in-margins)
+ (outline-minor-mode 1)))
buffer))
(defun Buffer-menu-mouse-select (event)
@@ -667,6 +718,7 @@ See more at `Buffer-menu-filter-predicate'."
(marked-buffers (Buffer-menu-marked-buffers))
(buffer-menu-buffer (current-buffer))
(show-non-file (not Buffer-menu-files-only))
+ (show-internal Buffer-menu-show-internal)
(filter-predicate (and (functionp Buffer-menu-filter-predicate)
Buffer-menu-filter-predicate))
entries name-width)
@@ -686,7 +738,8 @@ See more at `Buffer-menu-filter-predicate'."
(file buffer-file-name))
(when (and (buffer-live-p buffer)
(or buffer-list
- (and (or (not (string= (substring name 0 1) " "))
+ (and (or show-internal
+ (not (string= (substring name 0 1) " "))
file)
(not (eq buffer buffer-menu-buffer))
(or file show-non-file)
@@ -721,7 +774,11 @@ See more at `Buffer-menu-filter-predicate'."
`("Mode" ,Buffer-menu-mode-width t)
'("File" 1 t)))
(setq tabulated-list-use-header-line Buffer-menu-use-header-line)
- (setq tabulated-list-entries (nreverse entries)))
+ (setq tabulated-list-entries (nreverse entries))
+ (when Buffer-menu-group-by
+ (setq tabulated-list-groups
+ (seq-group-by Buffer-menu-group-by
+ tabulated-list-entries))))
(tabulated-list-init-header))
(defun tabulated-list-entry-size-> (entry1 entry2)
@@ -740,4 +797,14 @@ See more at `Buffer-menu-filter-predicate'."
(abbreviate-file-name list-buffers-directory))
(t "")))
+(defun Buffer-menu-group-by-mode (entry)
+ (concat "* " (aref (cadr entry) 5)))
+
+(declare-function project-root "project" (project))
+(defun Buffer-menu-group-by-root (entry)
+ (concat "* " (with-current-buffer (car entry)
+ (if-let ((project (project-current)))
+ (project-root project)
+ default-directory))))
+
;;; buff-menu.el ends here
diff --git a/lisp/button.el b/lisp/button.el
index ed8990655d3..c0584729172 100644
--- a/lisp/button.el
+++ b/lisp/button.el
@@ -72,7 +72,12 @@ Mode-specific keymaps may want to use this as their parent keymap."
;; mode-line or header-line, the `mode-line' or `header-line' prefix
;; shouldn't be necessary!
"<mode-line> <mouse-2>" #'push-button
- "<header-line> <mouse-2>" #'push-button)
+ "<header-line> <mouse-2>" #'push-button
+ ;; `push-button' will automatically dispatch to
+ ;; `touch-screen-track-tap'.
+ "<mode-line> <touchscreen-down>" #'push-button
+ "<header-line> <touchscreen-down>" #'push-button
+ "<touchscreen-down>" #'push-button)
(define-minor-mode button-mode
"A minor mode for navigating to buttons with the TAB key."
@@ -123,7 +128,7 @@ argument).
In addition, the keyword argument :supertype may be used to specify a
`button-type' from which NAME inherits its default property values
-(however, the inheritance happens only when NAME is defined; subsequent
+\(however, the inheritance happens only when NAME is defined; subsequent
changes to a supertype are not reflected in its subtypes)."
(declare (indent defun))
(let ((catsym (make-symbol (concat (symbol-name name) "-button")))
@@ -454,18 +459,22 @@ instead of starting at the next button."
(defun push-button (&optional pos use-mouse-action)
"Perform the action specified by a button at location POS.
-POS may be either a buffer position or a mouse-event. If
-USE-MOUSE-ACTION is non-nil, invoke the button's `mouse-action'
-property instead of its `action' property; if the button has no
-`mouse-action', the value of `action' is used instead.
+POS may be either a buffer position, a mouse-event, or a
+`touchscreen-down' event. If USE-MOUSE-ACTION is non-nil, invoke
+the button's `mouse-action' property instead of its `action'
+property; if the button has no `mouse-action', the value of
+`action' is used instead.
+
+If POS is a `touchscreen-down' event, wait for the corresponding
+`touchscreen-up' event before calling `push-button'.
The action in both cases may be either a function to call or a
marker to display and is invoked using `button-activate' (which
see).
POS defaults to point, except when `push-button' is invoked
-interactively as the result of a mouse-event, in which case, the
-mouse event is used.
+interactively as the result of a mouse-event or touchscreen
+event, in which case, the position in the event event is used.
If there's no button at POS, do nothing and return nil, otherwise
return t.
@@ -483,7 +492,12 @@ pushing a button, use the `button-describe' command."
(if str-button
;; mode-line, header-line, or display string event.
(button-activate str t)
- (push-button (posn-point posn) t)))))
+ (if (eq (car-safe pos) 'touchscreen-down)
+ ;; If touch-screen-track tap returns nil, then the
+ ;; tap was canceled.
+ (when (touch-screen-track-tap pos nil nil t)
+ (push-button (posn-point posn) t))
+ (push-button (posn-point posn) t))))))
;; POS is just normal position
(let ((button (button-at (or pos (point)))))
(when button
diff --git a/lisp/calc/calc-aent.el b/lisp/calc/calc-aent.el
index 263e3664b39..a21efc0238d 100644
--- a/lisp/calc/calc-aent.el
+++ b/lisp/calc/calc-aent.el
@@ -505,6 +505,7 @@ The value t means abort and give an error message.")
("⅝" "(5:8)") ; 5/8
("⅞" "(7:8)") ; 7/8
("⅟" "1:") ; 1/...
+ ("⁄" ":") ; arbitrary fractions of the form 123⁄456
;; superscripts
("⁰" "0") ; 0
("¹" "1") ; 1
@@ -547,22 +548,41 @@ The value t means abort and give an error message.")
"₀₁₂₃₄₅₆₇₈₉₊₋₍₎" ; 0123456789+-()
"A string consisting of the subscripts allowed by Calc.")
+(defvar math--read-preprocess-re-cache nil
+ "Cached regexp and tag: (REGEXP REPLACEMENTS SUPERSCRIPTS SUBSCRIPTS)")
+
;;;###autoload
(defun math-read-preprocess-string (str)
"Replace some substrings of STR by Calc equivalents."
- (setq str
- (replace-regexp-in-string (concat "[" math-read-superscripts "]+")
- "^(\\&)" str))
- (setq str
- (replace-regexp-in-string (concat "[" math-read-subscripts "]+")
- "_(\\&)" str))
- (let ((rep-list math-read-replacement-list))
- (while rep-list
- (setq str
- (replace-regexp-in-string (nth 0 (car rep-list))
- (nth 1 (car rep-list)) str))
- (setq rep-list (cdr rep-list))))
- str)
+ (unless (and (eq (nth 1 math--read-preprocess-re-cache)
+ math-read-replacement-list)
+ (eq (nth 2 math--read-preprocess-re-cache)
+ math-read-superscripts)
+ (eq (nth 3 math--read-preprocess-re-cache)
+ math-read-subscripts))
+ ;; Cache invalid, recompute.
+ (setq math--read-preprocess-re-cache
+ (list (rx-to-string
+ `(or (or (+ (in ,math-read-superscripts))
+ (group (+ (in ,math-read-subscripts))))
+ (group (or ,@(mapcar #'car math-read-replacement-list))))
+ t)
+ math-read-replacement-list
+ math-read-superscripts
+ math-read-subscripts)))
+ (replace-regexp-in-string
+ (nth 0 math--read-preprocess-re-cache)
+ (lambda (s)
+ (if (match-beginning 2)
+ (cadr (assoc s math-read-replacement-list)) ; not super/subscript
+ (concat (if (match-beginning 1) "_" "^")
+ "("
+ (mapconcat (lambda (c)
+ (cadr (assoc (char-to-string c)
+ math-read-replacement-list)))
+ s)
+ ")")))
+ str t))
;; The next few variables are local to math-read-exprs (and math-read-expr
;; in calc-ext.el), but are set in functions they call.
diff --git a/lisp/calc/calc-ext.el b/lisp/calc/calc-ext.el
index 6f7e4dee402..191149892a8 100644
--- a/lisp/calc/calc-ext.el
+++ b/lisp/calc/calc-ext.el
@@ -1297,12 +1297,13 @@ calc-kill calc-kill-region calc-yank))))
0))
(let ((msg (nth calc-prefix-help-phase msgs)))
(message "%s" (if msg
- (concat group ": " msg ":"
+ (concat group ": " (substitute-command-keys msg) ":"
(make-string
(- (apply #'max (mapcar #'length msgs))
(length msg))
?\s)
- " [MORE]"
+ (substitute-command-keys
+ " [\\`?'=MORE]")
(if key
(concat " " (char-to-string key)
"-")
diff --git a/lisp/calc/calc-graph.el b/lisp/calc/calc-graph.el
index 33cd1e90423..fb817b1bc3d 100644
--- a/lisp/calc/calc-graph.el
+++ b/lisp/calc/calc-graph.el
@@ -598,9 +598,10 @@
(math-build-var-name (car math-arglist))
'(var DUMMY var-DUMMY)))))
(setq calc-graph-ycache (assoc calc-graph-yvalue calc-graph-data-cache))
- (delq calc-graph-ycache calc-graph-data-cache)
- (nconc calc-graph-data-cache
- (list (or calc-graph-ycache (setq calc-graph-ycache (list calc-graph-yvalue)))))
+ (setq calc-graph-data-cache
+ (nconc (delq calc-graph-ycache calc-graph-data-cache)
+ (list (or calc-graph-ycache
+ (setq calc-graph-ycache (list calc-graph-yvalue))))))
(if (and (not (setq calc-graph-xvec (eq (car-safe calc-graph-xvalue) 'vec)))
calc-graph-refine (cdr (cdr calc-graph-ycache)))
(calc-graph-refine-2d)
diff --git a/lisp/calc/calc-help.el b/lisp/calc/calc-help.el
index dfd674ea63b..6ba49137b73 100644
--- a/lisp/calc/calc-help.el
+++ b/lisp/calc/calc-help.el
@@ -39,8 +39,11 @@
(or calc-dispatch-help (sit-for echo-keystrokes))
(let ((key (calc-read-key-sequence
(if calc-dispatch-help
- "Calc Help options: Help, Info, Tutorial, Summary; Key, Function; ?=more"
- (format "%s (Type ? for a list of Calc Help options)"
+ (substitute-command-keys
+ (concat "Calc Help options: \\`h'elp, \\`i'nfo, \\`t'utorial, "
+ "\\`s'ummary; \\`k'ey, \\`f'unction; \\`?'=more"))
+ (format (substitute-command-keys
+ "%s (Type \\`?' for a list of Calc Help options)")
(key-description (this-command-keys))))
calc-help-map)))
(setq key (lookup-key calc-help-map key))
@@ -76,7 +79,10 @@
(describe-function 'calc-help-for-help)
(select-window (get-buffer-window "*Help*"))
(while (progn
- (message "Calc Help options: Help, Info, ... press SPC, DEL to scroll, C-g to cancel")
+ (message (substitute-command-keys
+ (concat
+ "Calc Help options: \\`h'elp, \\`i'nfo, ... press "
+ "\\`SPC', \\`DEL' to scroll, \\`C-g' to cancel")))
(memq (setq key (read-event))
'(? ?\C-h ?\C-? ?\C-v ?\M-v)))
(condition-case nil
@@ -453,47 +459,47 @@
(defun calc-h-prefix-help ()
(interactive)
(calc-do-prefix-help
- '("Help; Bindings; Info, Tutorial, Summary; News"
- "describe: Key, C (briefly), Function, Variable")
+ '("\\`h'elp; \\`b'indings; \\`i'nfo, \\`t'utorial, \\`s'ummary; \\`n'ews"
+ "describe: \\`k'ey, \\`c' (briefly), \\`f'unction, \\`v'ariable")
"help" ?h))
(defun calc-inverse-prefix-help ()
(interactive)
(calc-do-prefix-help
- '("I + S (arcsin), C (arccos), T (arctan); Q (square)"
- "I + E (ln), L (exp), B (alog: B^X); f E (lnp1), f L (expm1)"
- "I + F (ceiling), R (truncate); a S (invert func)"
- "I + a m (match-not); c h (from-hms); k n (prev prime)"
- "I + f G (gamma-Q); f e (erfc); k B (etc., lower-tail dists)"
- "I + V S (reverse sort); V G (reverse grade)"
- "I + v s (remove subvec); v h (tail)"
- "I + t + (alt sum), t M (mean with error)"
- "I + t S (pop std dev), t C (pop covar)")
+ '("\\`I' + \\`S' (arcsin), \\`C' (arccos), \\`T' (arctan); \\`Q' (square)"
+ "\\`I' + \\`E' (ln), \\`L' (exp), \\`B' (alog: B^X); \\`f E' (lnp1), \\`f L' (expm1)"
+ "\\`I' + \\`F' (ceiling), \\`R' (truncate); \\`a S' (invert func)"
+ "\\`I' + \\`a m' (match-not); \\`c h' (from-hms); \\`k n' (prev prime)"
+ "\\`I' + \\`f G' (gamma-Q); \\`f e' (erfc); \\`k B' (etc., lower-tail dists)"
+ "\\`I' + \\`V S' (reverse sort); \\`V G' (reverse grade)"
+ "\\`I' + \\`v s' (remove subvec); \\`v h' (tail)"
+ "\\`I' + \\`t' + (alt sum), \\`t M' (mean with error)"
+ "\\`I' + \\`t S' (pop std dev), \\`t C' (pop covar)")
"inverse" nil))
(defun calc-hyperbolic-prefix-help ()
(interactive)
(calc-do-prefix-help
- '("H + S (sinh), C (cosh), T (tanh); E (exp10), L (log10)"
- "H + F (float floor), R (float round); P (constant \"e\")"
- "H + a d (total derivative); k c (permutations)"
- "H + k b (bern-poly), k e (euler-poly); k s (stirling-2)"
- "H + f G (gamma-g), f B (beta-B); v h (rhead), v k (rcons)"
- "H + v e (expand w/filler); V H (weighted histogram)"
- "H + a S (general solve eqn), j I (general isolate)"
- "H + a R (widen/root), a N (widen/min), a X (widen/max)"
- "H + t M (median), t S (variance), t C (correlation coef)"
- "H + c f/F/c (pervasive float/frac/clean)")
+ '("\\`H' + \\`S' (sinh), \\`C' (cosh), \\`T' (tanh); \\`E' (exp10), \\`L' (log10)"
+ "\\`H' + \\`F' (float floor), \\`R' (float round); \\`P' (constant \"e\")"
+ "\\`H' + \\`a d' (total derivative); \\`k c' (permutations)"
+ "\\`H' + \\`k b' (bern-poly), \\`k e' (euler-poly); \\`k s' (stirling-2)"
+ "\\`H' + \\`f G' (gamma-g), \\`f B' (beta-B); \\`v h' (rhead), \\`v k' (rcons)"
+ "\\`H' + \\`v e' (expand w/filler); \\`V H' (weighted histogram)"
+ "\\`H' + \\`a S' (general solve eqn), \\`j I' (general isolate)"
+ "\\`H' + \\`a R' (widen/root), \\`a N' (widen/min), \\`a X' (widen/max)"
+ "\\`H' + \\`t M' (median), \\`t S' (variance), \\`t C' (correlation coef)"
+ "\\`H' + \\`c' \\`f'/\\`F'/\\`c' (pervasive float/frac/clean)")
"hyperbolic" nil))
(defun calc-inv-hyp-prefix-help ()
(interactive)
(calc-do-prefix-help
- '("I H + S (arcsinh), C (arccosh), T (arctanh)"
- "I H + E (log10), L (exp10); f G (gamma-G)"
- "I H + F (float ceiling), R (float truncate)"
- "I H + t S (pop variance)"
- "I H + a S (general invert func); v h (rtail)")
+ '("\\`I H' + \\`S' (arcsinh), \\`C' (arccosh), \\`T' (arctanh)"
+ "\\`I H' + \\`E' (log10), \\`L' (exp10); \\`f G' (gamma-G)"
+ "\\`I H' + \\`F' (float ceiling), \\`R' (float truncate)"
+ "\\`I H' + \\`t S' (pop variance)"
+ "\\`I H' + \\`a S' (general invert func); \\`v h' (rtail)")
"inverse-hyperbolic" nil))
(defun calc-option-prefix-help ()
@@ -505,10 +511,10 @@
(defun calc-f-prefix-help ()
(interactive)
(calc-do-prefix-help
- '("miN, maX; Hypot; Im, Re; Sign; [, ] (incr/decr)"
- "Gamma, Beta, Erf, besselJ, besselY"
- "SHIFT + int-sQrt; Int-log, Exp(x)-1, Ln(x+1); arcTan2"
- "SHIFT + Abssqr; Mantissa, eXponent, Scale"
+ '("mi\\`n', ma\\`x'; \\`h'ypot; \\`i'm, \\`r'e; \\`s'ign; \\`[', \\`]' (incr/decr)"
+ "\\`g'amma, \\`b'eta, \\`e'rf, bessel\\`j', bessel\\`y'"
+ "int-s\\`Q'rt; \\`I'nt-log, \\`E'xp(x)-1, \\`L'n(x+1); arc\\`T'an2"
+ "\\`A'bssqr; \\`M'antissa, e\\`X'ponent, \\`S'cale"
"SHIFT + incomplete: Gamma-P, Beta-I")
"functions" ?f))
@@ -516,165 +522,165 @@
(defun calc-s-prefix-help ()
(interactive)
(calc-do-prefix-help
- '("Store, inTo, Xchg, Unstore; Recall, 0-9; : (:=); = (=>)"
- "Let; Copy, K=copy constant; Declare; Insert, Perm; Edit"
- "Negate, +, -, *, /, ^, &, |, [, ]; Map"
- "SHIFT + Decls, GenCount, TimeZone, Holidays; IntegLimit"
- "SHIFT + LineStyles, PointStyles, plotRejects; Units"
- "SHIFT + Eval-, AlgSimp-, ExtSimp-, FitRules")
+ '("\\`s'tore, in\\`t'o, \\`x'chg, \\`u'nstore; \\`r'ecall, \\`0'-\\`9'; \\`:' (:=); \\`=' (=>)"
+ "\\`l'et; \\`c'opy, \\`k'=copy constant; \\`d'eclare; \\`i'nsert, \\`p'erm; \\`e'dit"
+ "\\`n'egate, \\`+', \\`-', \\`*', \\`/', \\`^', \\`&', \\`|', \\`[', \\`]'; Map"
+ "\\`D'ecls, \\`G'enCount, \\`T'imeZone, \\`H'olidays; \\`I'ntegLimit"
+ "\\`L'ineStyles, \\`P'ointStyles, plot\\`R'ejects; \\`U'nits"
+ "\\`E'val-, \\`A'lgSimp-, e\\`X'tSimp-, \\`F'itRules")
"store" ?s))
(defun calc-r-prefix-help ()
(interactive)
(calc-do-prefix-help
- '("digits 0-9: recall, same as `s r 0-9'"
- "Save to register, Insert from register")
+ '("digits \\`0'-\\`9': recall, same as \\`s r' \\`0'-\\`9'"
+ "\\`s'ave to register, \\`i'nsert from register")
"recall/register" ?r))
(defun calc-j-prefix-help ()
(interactive)
(calc-do-prefix-help
- '("Select, Additional, Once; eVal, Formula; Rewrite"
- "More, Less, 1-9, Next, Previous"
- "Unselect, Clear; Display; Enable; Breakable"
- "\\=' (replace), \\=` (edit), +, -, *, /, RET (grab), DEL"
- "SHIFT + swap: Left, Right; maybe: Select, Once"
- "SHIFT + Commute, Merge, Distrib, jump-Eqn, Isolate"
- "SHIFT + Negate, & (invert); Unpack")
+ '("\\`s'elect, \\`a'dditional, \\`o'nce; e\\`v'al, \\`f'ormula; \\`r'ewrite"
+ "\\`m'ore, \\`l'ess, \\`1'-\\`9', \\`n'ext, \\`p'revious"
+ "\\`u'nselect, \\`c'lear; \\`d'isplay; \\`e'nable; \\`b'reakable"
+ "\\=' (replace), \\=` (edit), \\`+', \\`-', \\`*', \\`/', \\`RET' (grab), \\`DEL'"
+ "swap: \\`L'eft, \\`R'ight; maybe: \\`S'elect, \\`O'nce"
+ "\\`C'ommute, \\`M'erge, \\`D'istrib, jump-\\`E'qn, \\`I'solate"
+ "\\`N'egate, \\`&' (invert); \\`U'npack")
"select" ?j))
(defun calc-a-prefix-help ()
(interactive)
(calc-do-prefix-help
- '("Simplify, Extended-simplify, eVal; \" (exp-formula)"
- "eXpand, Collect, Factor, Apart, Norm-rat"
- "GCD, /, \\, % (polys); Polint"
- "Derivative, Integral, Taylor; _ (subscr)"
- "suBstitute; Rewrite, Match"
- "SHIFT + Solve; Root, miN, maX; Poly-roots; Fit"
- "SHIFT + Map; Tabulate, + (sum), * (prod); num-Integ"
- "relations: =, # (not =), <, >, [ (< or =), ] (> or =)"
- "logical: & (and), | (or), ! (not); : (if)"
- "misc: { (in-set); . (rmeq)")
+ '("\\`s'implify, \\`e'xtended-simplify, e\\`v'al; \\`\"' (exp-formula)"
+ "e\\`x'pand, \\`c'ollect, \\`f'actor, \\`a'part, \\`n'orm-rat"
+ "\\`g' (GCD), \\`/', \\`\\', \\`%' (polys); \\`p'olint"
+ "\\`d'erivative, \\`i'ntegral, \\`t'aylor; \\`_' (subscr)"
+ "su\\`b'stitute; \\`r'ewrite, \\`m'atch"
+ "\\`S'olve; \\`R'oot, mi\\`N', ma\\`X'; \\`P'oly-roots; \\`F'it"
+ "\\`M'ap; \\`T'abulate, \\`+' (sum), \\`*' (prod); num-\\`I'nteg"
+ "relations: \\`=', \\`#' (not =), \\`<', \\`>', \\`[' (< or =), \\`]' (> or =)"
+ "logical: \\`&' (and), \\`|' (or), \\`!' (not); \\`:' (if)"
+ "misc: \\`{' (in-set); \\`.' (rmeq)")
"algebra" ?a))
(defun calc-b-prefix-help ()
(interactive)
(calc-do-prefix-help
- '("And, Or, Xor, Diff, Not; Wordsize, Clip"
- "Lshift, Rshift, roTate; SHIFT + signed Lshift, Rshift"
- "SHIFT + business: Pv, Npv, Fv, pMt, #pmts, raTe, Irr"
- "SHIFT + business: Sln, sYd, Ddb; %ch")
+ '("\\`a'nd, \\`o'r, \\`x'or, \\`d'iff, \\`n'ot; \\`w'ordsize, \\`c'lip"
+ "\\`l'shift, \\`r'shift, ro\\`t'ate; signed \\`L'shift, \\`R'shift"
+ "business: \\`P'v, \\`N'pv, \\`F'v, p\\`M't, \\`#'pmts, ra\\`T'e, \\`I'rr"
+ "business: \\`S'ln, s\\`Y'd, \\`D'db; \\`%'ch")
"binary/bus" ?b))
(defun calc-c-prefix-help ()
(interactive)
(calc-do-prefix-help
- '("Deg, Rad, HMS; Float; Polar/rect; Clean, 0-9; %"
- "SHIFT + Fraction")
+ '("\\`d'eg, \\`r'ad, \\`h'ms; \\`f'loat; \\`p'olar/rect; \\`c'lean, \\`0'-\\`9'; \\`%'"
+ "\\`F'raction")
"convert" ?c))
(defun calc-d-prefix-help ()
(interactive)
(calc-do-prefix-help
- '("Group, \",\"; Normal, Fix, Sci, Eng, \".\"; Over"
- "Radix, Zeros, 2, 8, 0, 6; Hms; Date; Complex, I, J"
- "Why; Line-nums, line-Breaks; <, =, > (justify); Plain"
- "\" (strings); Truncate, [, ]; SPC (refresh), RET, @"
- "SHIFT + language: Normal, One-line, Big, Unformatted"
- "SHIFT + language: C, Pascal, Fortran; TeX, LaTeX, Eqn"
- "SHIFT + language: Yacas, X=Maxima, A=Giac"
- "SHIFT + language: Mathematica, W=Maple")
+ '("\\`g'roup, \\`,'; \\`n'ormal, \\`f'ix, \\`s'ci, \\`e'ng, \\`.'; \\`o'ver"
+ "\\`r'adix, \\`z'eros, \\`2', \\`8', \\`0', \\`6'; \\`h'ms; \\`d'ate; \\`c'omplex, \\`i', \\`j'"
+ "\\`w'hy; \\`l'ine-nums, line-\\`b'reaks; \\`<', \\`=', \\`>' (justify); \\`p'lain"
+ "\\`\"' (strings); \\`t'runcate, \\`[', \\`]'; \\`SPC' (refresh), \\`RET', \\`@'"
+ "language: \\`N'ormal, \\`O'ne-line, \\`B'ig, \\`U'nformatted"
+ "language: \\`C', \\`P'ascal, \\`F'ortran; \\`T'eX, \\`L'aTeX, \\`E'qn"
+ "language: \\`Y'acas, \\`X'=Maxima, \\`A'=Giac"
+ "language: \\`M'athematica, \\`W'=Maple")
"display" ?d))
(defun calc-g-prefix-help ()
(interactive)
(calc-do-prefix-help
- '("Fast; Add, Delete, Juggle; Plot, Clear; Quit"
- "Header, Name, Grid, Border, Key; View-commands, X-display"
- "x-axis: Range, Title, Log, Zero; lineStyle"
- "SHIFT + y-axis: Range, Title, Log, Zero; pointStyle"
- "SHIFT + Print; Device, Output-file; X-geometry"
- "SHIFT + Num-pts; Command, Kill, View-trail"
- "SHIFT + 3d: Fast, Add; CTRL + z-axis: Range, Title, Log")
+ '("\\`f'ast; \\`a'dd, \\`d'elete, \\`j'uggle; \\`p'lot, \\`c'lear; \\`q'uit"
+ "\\`h'eader, \\`n'ame, \\`g'rid, \\`b'order, \\`k'ey; \\`v'iew-commands, \\`x'-display"
+ "x-axis: \\`r'ange, \\`t'itle, \\`l'og, \\`z'ero; line\\`s'tyle"
+ "y-axis: \\`R'ange, \\`T'itle, \\`L'og, \\`Z'ero; point\\`S'tyle"
+ "\\`P'rint; \\`D'evice, \\`O'utput-file; \\`X'-geometry"
+ "\\`N'um-pts; \\`C'ommand, \\`K'ill, \\`V'iew-trail"
+ "3d: \\`F'ast, \\`A'dd; z-axis: \\`C-r' (range), \\`C-t' (title), \\`C-l' (log)")
"graph" ?g))
(defun calc-k-prefix-help ()
(interactive)
(calc-do-prefix-help
- '("GCD, LCM; Choose (binomial), Double-factorial"
- "Random, random-Again, sHuffle"
- "Factors, Prime-test, Next-prime, Totient, Moebius"
- "Bernoulli, Euler, Stirling"
- "SHIFT + Extended-gcd"
- "SHIFT + dists: Binomial, Chi-square, F, Normal"
- "SHIFT + dists: Poisson, student's-T")
+ '("\\`g' (GCD), \\`l' (LCM); \\`c'hoose (binomial), \\`d'ouble-factorial"
+ "\\`r'andom, random-\\`a'gain, s\\`h'uffle"
+ "\\`f'actors, \\`p'rime-test, \\`n'ext-prime, \\`t'otient, \\`m'oebius"
+ "\\`b'ernoulli, \\`e'uler, \\`s'tirling"
+ "\\`E'xtended-gcd"
+ "dists: \\`B'inomial, \\`C'hi-square, \\`F', \\`N'ormal"
+ "dists: \\`P'oisson, student\\='s-\\`T'")
"combinatorics" ?k))
(defun calc-m-prefix-help ()
(interactive)
(calc-do-prefix-help
- '("Deg, Rad, HMS; Frac; Polar; Inf; Alg, Total; Symb; Vec/mat"
- "Working; Xtensions; Mode-save; preserve Embedded modes"
- "SHIFT + Shifted-prefixes, mode-Filename; Record; reCompute"
- "SHIFT + simplify: Off, Num, basIc, Algebraic, Bin, Ext, Units")
+ '("\\`d'eg, \\`r'ad, \\`h' (HMS); \\`f'rac; \\`p'olar; \\`i'nf; \\`a'lg, \\`t'otal; \\`s'ymb; \\`v'ec/mat"
+ "\\`w'orking; \\`x'tensions; \\`m'ode-save; preserve \\`e'mbedded modes"
+ "\\`S'hifted-prefixes, mode-\\`F'ilename; \\`R'ecord; re\\`C'ompute"
+ "simplify: \\`O'ff, \\`N'um, bas\\`I'c, \\`A'lgebraic, \\`B'in, \\`E'xt, \\`U'nits")
"mode" ?m))
(defun calc-t-prefix-help ()
(interactive)
(calc-do-prefix-help
- '("Display; Fwd, Back; Next, Prev, Here, [, ]; Yank"
- "Search, Rev; In, Out; <, >; Kill; Marker; . (abbrev)"
- "SHIFT + time: Now; Part; Date, Julian, Unix, Czone"
- "SHIFT + time: newWeek, newMonth, newYear; Incmonth"
- "SHIFT + time: +, - (business days)"
- "digits 0-9: store-to, same as `s t 0-9'")
+ '("\\`d'isplay; \\`f'wd, \\`b'ack; \\`n'ext, \\`p'rev, \\`h'ere, \\`[', \\`]'; \\`y'ank"
+ "\\`s'earch, \\`r'ev; \\`i'n, \\`o'ut; \\`<', \\`>'; \\`k'ill; \\`m'arker; \\`.' (abbrev)"
+ "time: \\`N'ow; \\`P'art; \\`D'ate, \\`J'ulian, \\`U'nix, \\`C'zone"
+ "time: new\\`W'eek, new\\`M'onth, new\\`Y'ear; \\`I'ncmonth"
+ "time: \\`+', \\`-' (business days)"
+ "digits \\`0'-\\`9': store-to, same as \\`s t' \\`0'-\\`9'")
"trail/time" ?t))
(defun calc-u-prefix-help ()
(interactive)
(calc-do-prefix-help
- '("Simplify, Convert, coNvert exact, Temperature-convert, Base-units"
- "Autorange; Remove, eXtract; Explain; View-table; 0-9"
- "Define, Undefine, Get-defn, Permanent"
- "SHIFT + View-table-other-window"
- "SHIFT + stat: Mean, G-mean, Std-dev, Covar, maX, miN"
- "SHIFT + stat: + (sum), - (asum), * (prod), # (count)")
+ '("\\`s'implify, \\`c'onvert, co\\`n'vert exact, \\`t'emperature-convert, \\`b'ase-units"
+ "\\`a'utorange; \\`r'emove, e\\`x'tract; \\`e'xplain; \\`v'iew-table; \\`0'-\\`9'"
+ "\\`d'efine, \\`u'ndefine, \\`g'et-defn, \\`p'ermanent"
+ "\\`V'iew-table-other-window"
+ "stat: \\`M'ean, \\`G'-mean, \\`S'td-dev, \\`C'ovar, ma\\`X', mi\\`N'"
+ "stat: \\`+' (sum), \\`-' (asum), \\`*' (prod), \\`#' (count)")
"units/stat" ?u))
(defun calc-l-prefix-help ()
(interactive)
(calc-do-prefix-help
- '("Quantity, DB level, Np level"
- "+, -, *, /"
- "Scientific pitch notation, Midi number, Frequency"
+ '("\\`q'uantity, \\`d' (DB level), \\`n' (NP level)"
+ "\\`+', \\`-', \\`*', \\`/'"
+ "\\`s'cientific pitch notation, \\`m'idi number, \\`f'requency"
)
"log units" ?l))
(defun calc-v-prefix-help ()
(interactive)
(calc-do-prefix-help
- '("Pack, Unpack, Identity, Diagonal, indeX, Build"
- "Row, Column, Subvector; Length; Find; Mask, Expand"
- "Transpose, Arrange, reVerse; Head, Kons; rNorm"
- "SHIFT + Det, & (inverse), LUD, Trace, conJtrn, Cross"
- "SHIFT + Sort, Grade, Histogram; cNorm"
- "SHIFT + Apply, Map, Reduce, accUm, Inner-, Outer-prod"
- "SHIFT + sets: V (union), ^ (intersection), - (diff)"
- "SHIFT + sets: Xor, ~ (complement), Floor, Enum"
- "SHIFT + sets: : (span), # (card), + (rdup)"
- "<, =, > (justification); , (commas); [, {, ( (brackets)"
- "} (matrix brackets); . (abbreviate); / (multi-lines)")
+ '("\\`p'ack, \\`u'npack, \\`i'dentity, \\`d'iagonal, inde\\`x', \\`b'uild"
+ "\\`r'ow, \\`c'olumn, \\`s'ubvector; \\`l'ength; \\`f'ind; \\`m'ask, \\`e'xpand"
+ "\\`t'ranspose, \\`a'rrange, re\\`v'erse; \\`h'ead, \\`k'ons; r\\`n'orm"
+ "\\`D'et, \\`&' (inverse), \\`L'UD, \\`T'race, con\\`J'trn, \\`C'ross"
+ "\\`S'ort, \\`G'rade, \\`H'istogram; c\\`N'orm"
+ "\\`A'pply, \\`M'ap, \\`R'educe, acc\\`U'm, \\`I'nner-, \\`O'uter-prod"
+ "sets: \\`V' (union), \\`^' (intersection), \\`-' (diff)"
+ "sets: \\`X'or, \\`~' (complement), \\`F'loor, \\`E'num"
+ "sets: \\`:' (span), \\`#' (card), \\`+' (rdup)"
+ "\\`<', \\`=', \\`>' (justification); \\`,' (commas); \\`[', \\`{', \\`(' (brackets)"
+ "\\`}' (matrix brackets); \\`.' (abbreviate); \\`/' (multi-lines)")
"vec/mat" ?v))
(provide 'calc-help)
diff --git a/lisp/calc/calc-misc.el b/lisp/calc/calc-misc.el
index 39b306ceb62..8c692ac006c 100644
--- a/lisp/calc/calc-misc.el
+++ b/lisp/calc/calc-misc.el
@@ -114,8 +114,11 @@ Calc user interface as before (either \\`C-x * C' or \\`C-x * K'; initially \\`C
(let (key)
(select-window win)
(while (progn
- (message "Calc options: Calc, Keypad, ... %s"
- "press SPC, DEL to scroll, C-g to cancel")
+ (message
+ (substitute-command-keys
+ (concat
+ "Calc options: \\`c'alc, \\`k'eypad, ... "
+ "press \\`SPC', \\`DEL' to scroll, \\`C-g' to cancel")))
(memq (setq key (read-event))
'(? ?\C-h ?\C-? ?\C-v ?\M-v)))
(condition-case nil
@@ -192,7 +195,6 @@ Calc user interface as before (either \\`C-x * C' or \\`C-x * K'; initially \\`C
;;;###autoload
(defun calc-info-goto-node (node)
"Go to a node in the Calculator info documentation."
- (interactive)
(select-window (get-largest-window))
(info (concat "(Calc)" node)))
@@ -216,27 +218,26 @@ Calc user interface as before (either \\`C-x * C' or \\`C-x * K'; initially \\`C
(defun calc-help ()
(interactive)
(let ((msgs
- ;; FIXME: Change these to `substitute-command-keys' syntax.
(mapcar #'substitute-command-keys
'("Press \\`h' for complete help; press \\`?' repeatedly for a summary"
- "Letter keys: Negate; Precision; Yank; Why; Xtended cmd; Quit"
- "Letter keys: SHIFT + Undo, reDo; Inverse, Hyperbolic, Option"
- "Letter keys: SHIFT + sQrt; Sin, Cos, Tan; Exp, Ln, logB"
- "Letter keys: SHIFT + Floor, Round; Abs, conJ, arG; Pi"
- "Letter keys: SHIFT + Num-eval; More-recn; eXec-kbd-macro; Keep-args"
- "Other keys: +, -, *, /, ^, \\ (int div), : (frac div)"
- "Other keys: & (1/x), | (concat), % (modulo), ! (factorial)"
- "Other keys: \\=' (alg-entry), = (eval), \\=` (edit); M-RET (last-args)"
- "Other keys: \\`SPC'/\\`RET' (enter/dup), LFD (over); < > (scroll horiz)"
- "Other keys: \\`DEL' (drop), \\`M-DEL' (drop-above); { } (scroll vert)"
+ "Letter keys: \\`n'egate; \\`p'recision; \\`y'ank; \\`w'hy; \\`x'tended cmd; \\`q'uit"
+ "Letter keys: \\`U'ndo, re\\`D'o; \\`I'nverse, \\`H'yperbolic, \\`O'ption"
+ "Letter keys: s\\`Q'rt; \\`S'in, \\`C'os, \\`T'an; \\`E'xp, \\`L'n, log\\`B'"
+ "Letter keys: \\`F'loor, \\`R'ound; \\`A'bs, con\\`J', ar\\`G'; \\`P'i"
+ "Letter keys: \\`N'um-eval; \\`M'ore-recn; e\\`X'ec-kbd-macro; \\`K'eep-args"
+ "Other keys: \\`+', \\`-', \\`*', \\`/', \\`^', \\`\\' (int div), \\`:' (frac div)"
+ "Other keys: \\`&' (1/x), \\`|' (concat), \\`%' (modulo), \\`!' (factorial)"
+ "Other keys: \\=' (alg-entry), \\`=' (eval), \\=` (edit); \\`M-RET' (last-args)"
+ "Other keys: \\`SPC'/\\`RET' (enter/dup), \\`LFD' (over); \\`<' \\`>' (scroll horiz)"
+ "Other keys: \\`DEL' (drop), \\`M-DEL' (drop-above); \\`{' \\`}' (scroll vert)"
"Other keys: \\`TAB' (swap/roll-dn), \\`M-TAB' (roll-up)"
- "Other keys: [ , ; ] (vector), ( , ) (complex), ( ; ) (polar)"
- "Prefix keys: Algebra, Binary/business, Convert, Display"
- "Prefix keys: Functions, Graphics, Help, J (select)"
- "Prefix keys: Kombinatorics/statistics, Modes, Store/recall"
- "Prefix keys: Trail/time, Units/statistics, Vector/matrix"
- "Prefix keys: Z (user), SHIFT + Z (define)"
- "Prefix keys: prefix + ? gives further help for that prefix"
+ "Other keys: \\`[' \\`,' \\`;' \\`]' (vector), \\`(' \\`,' \\`)' (complex), \\`(' \\`;' \\`)' (polar)"
+ "Prefix keys: \\`a'lgebra, \\`b'inary/business, \\`c'onvert, \\`d'isplay"
+ "Prefix keys: \\`f'unctions, \\`g'raphics, \\`h'elp, \\`j' (select)"
+ "Prefix keys: \\`k'ombinatorics/statistics, \\`m'odes, \\`s'tore/recall"
+ "Prefix keys: \\`t'rail/time, \\`u'nits/statistics, \\`v'ector/matrix"
+ "Prefix keys: \\`z' (user), \\`Z' (define)"
+ "Prefix keys: prefix + \\`?' gives further help for that prefix"
" Calc by Dave Gillespie, daveg@synaptics.com"))))
(if calc-full-help-flag
msgs
@@ -260,7 +261,7 @@ Calc user interface as before (either \\`C-x * C' or \\`C-x * K'; initially \\`C
msgs))
(length msg))
?\ )
- " [?=MORE]")
+ (substitute-command-keys " [\\`?'=MORE]"))
""))))))))
diff --git a/lisp/calc/calc-prog.el b/lisp/calc/calc-prog.el
index 413002f3ed7..8dff7f1f264 100644
--- a/lisp/calc/calc-prog.el
+++ b/lisp/calc/calc-prog.el
@@ -936,7 +936,6 @@
(defun calc-edit-macro-finish-edit (cmdname key)
"Finish editing a Calc macro.
Redefine the corresponding command."
- (interactive)
(let ((cmd (intern cmdname)))
(calc-edit-macro-pre-finish-edit)
(let* ((str (buffer-substring calc-edit-top (point-max)))
@@ -1226,13 +1225,17 @@ Redefine the corresponding command."
(interactive)
(calc-kbd-if))
+(defun calc--at-end-of-kmacro-p ()
+ (and (arrayp executing-kbd-macro)
+ (>= executing-kbd-macro-index (length executing-kbd-macro))))
+
(defun calc-kbd-skip-to-else-if (else-okay)
(let ((count 0)
ch)
(while (>= count 0)
- (setq ch (read-char))
- (if (= ch -1)
+ (if (calc--at-end-of-kmacro-p)
(error "Unterminated Z[ in keyboard macro"))
+ (setq ch (read-char))
(if (= ch ?Z)
(progn
(setq ch (read-char))
@@ -1300,9 +1303,9 @@ Redefine the corresponding command."
(or executing-kbd-macro
(message "Reading loop body..."))
(while (>= count 0)
- (setq ch (read-event))
- (if (eq ch -1)
+ (if (calc--at-end-of-kmacro-p)
(error "Unterminated Z%c in keyboard macro" open))
+ (setq ch (read-event))
(if (eq ch ?Z)
(progn
(setq ch (read-event)
@@ -1428,9 +1431,9 @@ Redefine the corresponding command."
(if defining-kbd-macro
(message "Reading body..."))
(while (>= count 0)
- (setq ch (read-char))
- (if (= ch -1)
+ (if (calc--at-end-of-kmacro-p)
(error "Unterminated Z` in keyboard macro"))
+ (setq ch (read-char))
(if (= ch ?Z)
(progn
(setq ch (read-char)
diff --git a/lisp/calc/calc-units.el b/lisp/calc/calc-units.el
index 2540c33e446..fba2b9c50fb 100644
--- a/lisp/calc/calc-units.el
+++ b/lisp/calc/calc-units.el
@@ -32,7 +32,7 @@
;;; Units operations.
-;;; Units table last updated 9-Jan-91 by Ulrich Mueller (ulm@vsnhd1.cern.ch)
+;;; Units table last updated 9-Jan-91 by Ulrich Müller (ulm@vsnhd1.cern.ch)
;;; with some additions by Przemek Klosowski (przemek@rrdstrad.nist.gov)
;;; Updated April 2002 by Jochen Küpper
@@ -43,11 +43,12 @@
;;; Measures, by François Cardarelli)
;;; All conversions are exact unless otherwise noted.
-;; CODATA values updated February 2016, using 2014 adjustment
-;; https://arxiv.org/pdf/1507.07956.pdf
-
;; Updated November 2018 for the redefinition of the SI
-;; https://www.bipm.org/utils/en/pdf/CGPM/Draft-Resolution-A-EN.pdf
+;; https://www.bipm.org/en/committees/cg/cgpm/26-2018/resolution-1
+
+;; CODATA values last updated November 2023, using 2018 adjustment:
+;; E. Tiesinga, P. J. Mohr, D. B. Newell, and B. N. Taylor,
+;; Rev. Mod. Phys. 93, 025010 (2021)
(defvar math-standard-units
'( ;; Length
@@ -57,12 +58,13 @@
( ft "12 in" "Foot")
( yd "3 ft" "Yard" )
( mi "5280 ft" "Mile" )
- ( au "149597870691. m" "Astronomical Unit" nil
- "149597870691 m (*)")
- ;; (approx) NASA JPL (https://neo.jpl.nasa.gov/glossary/au.html)
+ ( au "149597870700 m" "Astronomical Unit")
+ ;; "149 597 870 700 m exactly"
+ ;; http://www.iau.org/static/resolutions/IAU2012_English.pdf
( lyr "c yr" "Light Year" )
- ( pc "3.0856775854*10^16 m" "Parsec (**)" nil
- "3.0856775854 10^16 m (*)") ;; (approx) ESUWM
+ ( pc "(648000/pi) au" "Parsec (**)")
+ ;; "The parsec is defined as exactly (648 000/π) au"
+ ;; http://www.iau.org/static/resolutions/IAU2015_English.pdf
( nmi "1852 m" "Nautical Mile" )
( fath "6 ft" "Fathom" )
( fur "660 ft" "Furlong")
@@ -121,7 +123,6 @@
( mph "mi/hr" "*Miles per hour" )
( kph "km/hr" "Kilometers per hour" )
( knot "nmi/hr" "Knot" )
- ( c "299792458 m/s" "Speed of light" ) ;; SI definition
;; Acceleration
( ga "980665*10^(-5) m/s^2" "*\"g\" acceleration" nil
@@ -142,8 +143,8 @@
"31.10347680 g") ;; ESUWM, 1/12 exact value for lbt
( ct "(2/10) g" "Carat" nil
"0.2 g") ;; ESUWM
- ( u "1.660539040*10^(-27) kg" "Unified atomic mass" nil
- "1.660539040 10^-27 kg (*)");;(approx) CODATA
+ ( u "1.66053906660*10^(-27) kg" "Unified atomic mass" nil
+ "1.66053906660 10^-27 kg (*)") ;; (approx) CODATA
;; Force
( N "m kg/s^2" "*Newton" )
@@ -181,9 +182,9 @@
( hpm "75 m kgf/s" "Metric Horsepower") ;;ESUWM
;; Temperature
- ( K nil "*Degree Kelvin" K )
- ( dK "K" "Degree Kelvin" K )
- ( degK "K" "Degree Kelvin" K )
+ ( K nil "*Kelvin" K )
+ ;; FIXME: Add °C and °F, but it requires that we sort out input etc for
+ ;; the ° sign.
( dC "K" "Degree Celsius" C )
( degC "K" "Degree Celsius" C )
( dF "(5/9) K" "Degree Fahrenheit" F )
@@ -209,9 +210,6 @@
( A nil "*Ampere" )
( C "A s" "Coulomb" )
( Fdy "ech Nav" "Faraday" )
- ( e "ech" "Elementary charge" )
- ( ech "1.602176634*10^(-19) C" "Elementary charge" nil
- "1.602176634 10^-19 C") ;; SI definition
( V "W/A" "Volt" )
( ohm "V/A" "Ohm" )
( Ω "ohm" "Ohm" )
@@ -258,57 +256,81 @@
;; Solid angle
( sr nil "*Steradian" )
+ ;; Constants defining the International System of Units (SI)
+ ( c "299792458 m/s" "*Speed of light" )
+ ( h "6.62607015*10^(-34) J s" "Planck constant" nil
+ "6.62607015 10^-34 J s")
+ ( ech "1.602176634*10^(-19) C" "Elementary charge" nil
+ "1.602176634 10^-19 C")
+ ( e "ech" "Elementary charge" nil
+ "1.602176634 10^-19 C")
+ ( k "1.380649*10^(-23) J/K" "Boltzmann constant" nil
+ "1.380649 10^-23 J/K")
+ ( Nav "6.02214076*10^(23) / mol" "Avogadro constant" nil
+ "6.02214076 10^23 / mol")
+
;; Other physical quantities
;; Unless otherwise mentioned, the values are from CODATA,
;; and are approximate.
- ( h "6.62607015*10^(-34) J s" "*Planck's constant" nil
- "6.62607015 10^-34 J s") ;; SI definition
- ( hbar "h / (2 pi)" "Planck's constant" ) ;; Exact
+ ( hbar "h / (2 pi)" "*Reduced Planck constant" )
;; After the 2018 SI redefinition, eps0 and mu0 are measured quantities,
;; and mu0 no longer has the previous exact value of 4 pi 10^(-7) H/m.
( eps0 "ech^2 / (2 alpha h c)" "Permittivity of vacuum" )
( ε0 "eps0" "Permittivity of vacuum" )
- ( mu0 "1 / (eps0 c^2)" "Permeability of vacuum") ;; Exact
- ( μ0 "mu0" "Permeability of vacuum") ;; Exact
- ( G "6.67408*10^(-11) m^3/(kg s^2)" "Gravitational constant" nil
- "6.67408 10^-11 m^3/(kg s^2) (*)")
- ( Nav "6.02214076*10^(23) / mol" "Avogadro's constant" nil
- "6.02214076 10^23 / mol") ;; SI definition
- ( me "9.10938356*10^(-31) kg" "Electron rest mass" nil
- "9.10938356 10^-31 kg (*)")
- ( mp "1.672621898*10^(-27) kg" "Proton rest mass" nil
- "1.672621898 10^-27 kg (*)")
- ( mn "1.674927471*10^(-27) kg" "Neutron rest mass" nil
- "1.674927471 10^-27 kg (*)")
- ( mmu "1.883531594*10^(-28) kg" "Muon rest mass" nil
- "1.883531594 10^-28 kg (*)")
+ ( mu0 "1 / (eps0 c^2)" "Permeability of vacuum")
+ ( μ0 "mu0" "Permeability of vacuum")
+ ( G "6.67430*10^(-11) m^3/(kg s^2)" "Gravitational constant" nil
+ "6.67430 10^-11 m^3/(kg s^2) (*)")
+ ( me "9.1093837015*10^(-31) kg" "Electron rest mass" nil
+ "9.1093837015 10^-31 kg (*)")
+ ( mp "1.67262192369*10^(-27) kg" "Proton rest mass" nil
+ "1.67262192369 10^-27 kg (*)")
+ ( mn "1.67492749804*10^(-27) kg" "Neutron rest mass" nil
+ "1.67492749804 10^-27 kg (*)")
+ ( mmu "1.883531627*10^(-28) kg" "Muon rest mass" nil
+ "1.883531627 10^-28 kg (*)")
( mμ "mmu" "Muon rest mass" nil
- "1.883531594 10^-28 kg (*)")
- ( Ryd "10973731.568508 /m" "Rydberg's constant" nil
- "10973731.568508 /m (*)")
- ( k "1.380649*10^(-23) J/K" "Boltzmann's constant" nil
- "1.380649 10^-23 J/K") ;; SI definition
+ "1.883531627 10^-28 kg (*)")
+ ( Ryd "10973731.568160 /m" "Rydberg constant" nil
+ "10973731.568160 /m (*)")
( sigma "2 pi^5 k^4 / (15 h^3 c^2)" "Stefan-Boltzmann constant")
( σ "sigma" "Stefan-Boltzmann constant")
- ( alpha "7.2973525664*10^(-3)" "Fine structure constant" nil
- "7.2973525664 10^-3 (*)")
- ( α "alpha" "Fine structure constant" nil
- "7.2973525664 10^-3 (*)")
- ( muB "927.4009994*10^(-26) J/T" "Bohr magneton" nil
- "927.4009994 10^-26 J/T (*)")
- ( muN "5.050783699*10^(-27) J/T" "Nuclear magneton" nil
- "5.050783699 10^-27 J/T (*)")
- ( mue "-928.4764620*10^(-26) J/T" "Electron magnetic moment" nil
- "-928.4764620 10^-26 J/T (*)")
- ( mup "1.4106067873*10^(-26) J/T" "Proton magnetic moment" nil
- "1.4106067873 10^-26 J/T (*)")
- ( R0 "Nav k" "Molar gas constant") ;; Exact
- ( V0 "22.710947*10^(-3) m^3/mol" "Standard volume of ideal gas" nil
- "22.710947 10^-3 m^3/mol (*)")
+ ( alpha "7.2973525693*10^(-3)" "Fine structure constant" nil
+ "7.2973525693 10^-3 (*)")
+ ( α "alpha" "Fine structure constant" nil
+ "7.2973525693 10^-3 (*)")
+ ( muB "9.2740100783*10^(-24) J/T" "Bohr magneton" nil
+ "9.2740100783 10^-24 J/T (*)")
+ ( muN "5.0507837461*10^(-27) J/T" "Nuclear magneton" nil
+ "5.0507837461 10^-27 J/T (*)")
+ ( mue "-9.2847647043*10^(-24) J/T" "Electron magnetic moment" nil
+ "-9.2847647043 10^-24 J/T (*)")
+ ( mup "1.41060679736*10^(-26) J/T" "Proton magnetic moment" nil
+ "1.41060679736 10^-26 J/T (*)")
+ ( R0 "Nav k" "Molar gas constant" )
+ ( V0 "R0 273.15 K / 10^5 Pa" "Standard volume of ideal gas" )
+ ;; IUPAC 1982 standard temperature and pressure
+
;; Logarithmic units
( Np nil "*Neper")
- ( dB "(ln(10)/20) Np" "decibel")))
+ ( dB "(ln(10)/20) Np" "decibel"))
+ "List of predefined units for Calc.
+
+Each element is (NAME DEF DESC TEMP-UNIT HUMAN-DEF), where:
+
+NAME is the unit symbol.
+DEF is a string defining the unit as a Calc expression; nil if base unit.
+DESC is a string describing the unit (to a human reader).
+ A leading asterisk indicates that the unit is first in its group.
+TEMP-UNIT is `K', `C' or `F' for temperature units and is used to identify
+ the unit when doing absolute temperature conversion
+ (`calc-convert-temperature'). For other units, nil.
+HUMAN-DEF is a string defining the unit (to a human reader).
+ If absent or nil, DEF is used.
+(*) in HUMAN-DEF means that the definition is approximate, otherwise exact.
+(**) in DESC means that the unit name is different in TeX and LaTeX
+ display modes.")
(defvar math-additional-units nil
"Additional units table for user-defined units.
@@ -319,28 +341,28 @@ that the combined units table will be rebuilt.")
(defvar math-unit-prefixes
'( ( ?Q (^ 10 30) "quetta" )
( ?R (^ 10 27) "ronna" )
- ( ?Y (^ 10 24) "Yotta" )
- ( ?Z (^ 10 21) "Zetta" )
- ( ?E (^ 10 18) "Exa" )
- ( ?P (^ 10 15) "Peta" )
- ( ?T (^ 10 12) "Tera" )
- ( ?G (^ 10 9) "Giga" )
- ( ?M (^ 10 6) "Mega" )
- ( ?k (^ 10 3) "Kilo" )
- ( ?K (^ 10 3) "Kilo" )
- ( ?h (^ 10 2) "Hecto" )
- ( ?H (^ 10 2) "Hecto" )
- ( ?D (^ 10 1) "Deka" )
+ ( ?Y (^ 10 24) "yotta" )
+ ( ?Z (^ 10 21) "zetta" )
+ ( ?E (^ 10 18) "exa" )
+ ( ?P (^ 10 15) "peta" )
+ ( ?T (^ 10 12) "tera" )
+ ( ?G (^ 10 9) "giga" )
+ ( ?M (^ 10 6) "mega" )
+ ( ?k (^ 10 3) "kilo" )
+ ( ?K (^ 10 3) "kilo" )
+ ( ?h (^ 10 2) "hecto" )
+ ( ?H (^ 10 2) "hecto" )
+ ( ?D (^ 10 1) "deka" )
( 0 (^ 10 0) nil )
- ( ?d (^ 10 -1) "Deci" )
- ( ?c (^ 10 -2) "Centi" )
- ( ?m (^ 10 -3) "Milli" )
- ( ?u (^ 10 -6) "Micro" )
- ( ?μ (^ 10 -6) "Micro" )
- ( ?n (^ 10 -9) "Nano" )
- ( ?p (^ 10 -12) "Pico" )
- ( ?f (^ 10 -15) "Femto" )
- ( ?a (^ 10 -18) "Atto" )
+ ( ?d (^ 10 -1) "deci" )
+ ( ?c (^ 10 -2) "centi" )
+ ( ?m (^ 10 -3) "milli" )
+ ( ?u (^ 10 -6) "micro" )
+ ( ?μ (^ 10 -6) "micro" )
+ ( ?n (^ 10 -9) "nano" )
+ ( ?p (^ 10 -12) "pico" )
+ ( ?f (^ 10 -15) "femto" )
+ ( ?a (^ 10 -18) "atto" )
( ?z (^ 10 -21) "zepto" )
( ?y (^ 10 -24) "yocto" )
( ?r (^ 10 -27) "ronto" )
diff --git a/lisp/calc/calc.el b/lisp/calc/calc.el
index 3eab7facadf..e6448625cee 100644
--- a/lisp/calc/calc.el
+++ b/lisp/calc/calc.el
@@ -906,6 +906,8 @@ Used by `calc-user-invocation'.")
(defvar calc-embedded-mode-hook nil
"Hook run when starting embedded mode.")
+(defvar calc-eval-error)
+
;; The following modes use specially-formatted data.
(put 'calc-mode 'mode-class 'special)
@@ -1188,8 +1190,12 @@ Used by `calc-user-invocation'.")
"Start the Calculator."
(let ((key (calc-read-key-sequence
(if calc-dispatch-help
- "Calc options: Calc, Keypad, Quick, Embed; eXit; Info, Tutorial; Grab; ?=more"
- (format "%s (Type ? for a list of Calc options)"
+ (substitute-command-keys
+ (concat
+ "Calc options: \\`c'alc, \\`k'eypad, \\`q'uick, \\`e'mbed; "
+ "e\\`x'it; \\`i'nfo, \\`t'utorial; \\`g'rab; \\`?'=more"))
+ (format (substitute-command-keys
+ "%s (Type \\`?' for a list of Calc options)")
(key-description (this-command-keys))))
calc-dispatch-map)))
(setq key (lookup-key calc-dispatch-map key))
@@ -1279,6 +1285,8 @@ the trail buffer."
(setq calc-trail-buffer nil)
t))))
+(defvar touch-screen-display-keyboard)
+
(defun calc-mode ()
"Calculator major mode.
@@ -1353,7 +1361,10 @@ Notations: 3.14e6 3.14 * 10^6
(calc-set-mode-line)
(calc-check-defines)
(if calc-buffer-list (setq calc-stack (copy-sequence calc-stack)))
- (add-to-list 'calc-buffer-list (current-buffer) t))
+ (add-to-list 'calc-buffer-list (current-buffer) t)
+ ;; While Calc buffers are read only, the on screen keyboard should
+ ;; be displayed in order to accept user input.
+ (setq-local touch-screen-display-keyboard t))
(defvar calc-check-defines 'calc-check-defines) ; Suitable for run-hooks.
(defun calc-check-defines ()
@@ -1447,49 +1458,54 @@ See `window-dedicated-p' for what that means."
(calc-grab-region (region-beginning) (region-end) nil)
(when (= (prefix-numeric-value arg) -2)
(calc-keypad))))
- (when (get-buffer-window "*Calc Keypad*")
- (calc-keypad)
- (set-buffer (window-buffer)))
- (if (derived-mode-p 'calc-mode)
- (calc-quit)
- (calc-create-buffer)
- (setq calc-was-keypad-mode nil)
- (if (or (eq full-display t)
- (and (null full-display) calc-full-mode))
- (switch-to-buffer (current-buffer) t)
- (if (get-buffer-window (current-buffer))
- (select-window (get-buffer-window (current-buffer)))
- (if calc-window-hook
- (run-hooks 'calc-window-hook)
- (let ((w (get-largest-window)))
- (if (and pop-up-windows
- (> (window-height w)
- (+ window-min-height calc-window-height 2)))
- (progn
- (setq w (split-window w
- (- (window-height w)
- calc-window-height 2)
- nil))
- (set-window-buffer w (current-buffer))
- (select-window w))
- (pop-to-buffer (current-buffer)))))))
- (with-current-buffer (calc-trail-buffer)
- (and calc-display-trail
- (calc-trail-display 1 t)))
- (message (substitute-command-keys
- (concat "Welcome to the GNU Emacs Calculator! \\<calc-mode-map>"
- "Press \\[calc-help] or \\[calc-help-prefix] for help, \\[calc-quit] to quit")))
- (run-hooks 'calc-start-hook)
- (and (windowp full-display)
- (window-point full-display)
- (select-window full-display))
- (and calc-make-windows-dedicated
- (set-window-dedicated-p nil t))
- (calc-check-defines)
- (when (and calc-said-hello interactive)
- (sit-for 2)
- (message ""))
- (setq calc-said-hello t))))
+ ;; If the selected window changes here, Emacs may think that the
+ ;; selected window is read only, and no on screen keyboard should
+ ;; be displayed. Make sure that any active on screen keyboard is
+ ;; not hidden by accident.
+ (let ((touch-screen-display-keyboard t))
+ (when (get-buffer-window "*Calc Keypad*")
+ (calc-keypad)
+ (set-buffer (window-buffer)))
+ (if (derived-mode-p 'calc-mode)
+ (calc-quit)
+ (calc-create-buffer)
+ (setq calc-was-keypad-mode nil)
+ (if (or (eq full-display t)
+ (and (null full-display) calc-full-mode))
+ (switch-to-buffer (current-buffer) t)
+ (if (get-buffer-window (current-buffer))
+ (select-window (get-buffer-window (current-buffer)))
+ (if calc-window-hook
+ (run-hooks 'calc-window-hook)
+ (let ((w (get-largest-window)))
+ (if (and pop-up-windows
+ (> (window-height w)
+ (+ window-min-height calc-window-height 2)))
+ (progn
+ (setq w (split-window w
+ (- (window-height w)
+ calc-window-height 2)
+ nil))
+ (set-window-buffer w (current-buffer))
+ (select-window w))
+ (pop-to-buffer (current-buffer)))))))
+ (with-current-buffer (calc-trail-buffer)
+ (and calc-display-trail
+ (calc-trail-display 1 t)))
+ (message (substitute-command-keys
+ (concat "Welcome to the GNU Emacs Calculator! \\<calc-mode-map>"
+ "Press \\[calc-help] or \\[calc-help-prefix] for help, \\[calc-quit] to quit")))
+ (run-hooks 'calc-start-hook)
+ (and (windowp full-display)
+ (window-point full-display)
+ (select-window full-display))
+ (and calc-make-windows-dedicated
+ (set-window-dedicated-p nil t))
+ (calc-check-defines)
+ (when (and calc-said-hello interactive)
+ (sit-for 2)
+ (message ""))
+ (setq calc-said-hello t)))))
;;;###autoload
(defun full-calc (&optional interactive)
@@ -2478,7 +2494,8 @@ the United States."
(interactive)
(cond ((eq last-command 'calcDigit-start)
(delete-minibuffer-contents))
- (t (backward-delete-char 1)))
+ (t (with-suppressed-warnings ((interactive-only backward-delete-char))
+ (backward-delete-char 1))))
(if (= (calc-minibuffer-size) 0)
(progn
(setq last-command-event 13)
diff --git a/lisp/calculator.el b/lisp/calculator.el
index d1479931ad6..ef1e6d8dbc3 100644
--- a/lisp/calculator.el
+++ b/lisp/calculator.el
@@ -1350,8 +1350,9 @@ Optional string argument KEYS will force using it as the keys entered."
(calculator-update-display t))
(defun calculator-saved-move (n)
- "Go N elements up the list of saved values."
- (interactive)
+ "Go N elements up the list of saved values.
+Interactively, N is the prefix numeric argument and defaults to 1."
+ (interactive "p")
(when (and calculator-saved-list
(or (null calculator-stack) calculator-display-fragile))
(setq calculator-saved-ptr
diff --git a/lisp/calendar/appt.el b/lisp/calendar/appt.el
index d8ed2470abe..7572e706283 100644
--- a/lisp/calendar/appt.el
+++ b/lisp/calendar/appt.el
@@ -165,6 +165,12 @@ Only relevant if reminders are being displayed in a window."
:type 'function
:group 'appt)
+(defface appt-notification
+ '((t :inherit mode-line-emphasis))
+ "Face for appointment notification on the modeline.
+Shown when `appt-display-mode-line' is non-nil."
+ :group 'mode-line-faces
+ :version "30.1")
;;; Internal variables below this point.
@@ -406,10 +412,10 @@ displayed in a window:
(appt-mode-line (mapcar #'number-to-string
min-list)
t)
- 'face 'mode-line-emphasis)
+ 'face 'appt-notification)
" ")))
;; Reset count to 0 in case we display another appt on the next cycle.
- (setq appt-display-count (if (eq '(0) min-list) 0
+ (setq appt-display-count (if (equal '(0) min-list) 0
(1+ prev-appt-display-count))))
;; If we have changed the mode line string, redisplay all mode lines.
(and appt-display-mode-line
@@ -453,8 +459,7 @@ separate appointment."
;; It repeatedly reminds you of the date?
;; It would make more sense if it was eg the time of the appointment.
;; Let's allow it to be a list or not independent of the other elements.
- (or (listp new-time)
- (setq new-time (list new-time)))
+ (setq new-time (ensure-list new-time))
;; FIXME Link to diary entry?
(calendar-set-mode-line
(format " %s. %s" (appt-mode-line min-to-app)
@@ -707,7 +712,7 @@ ARG is positive, otherwise off."
(not appt-active)))
(remove-hook 'write-file-functions #'appt-update-list)
(or global-mode-string (setq global-mode-string '("")))
- (delq 'appt-mode-string global-mode-string)
+ (setq global-mode-string (delq 'appt-mode-string global-mode-string))
(when appt-timer
(cancel-timer appt-timer)
(setq appt-timer nil))
diff --git a/lisp/calendar/cal-dst.el b/lisp/calendar/cal-dst.el
index 0bde82216df..b54738c464f 100644
--- a/lisp/calendar/cal-dst.el
+++ b/lisp/calendar/cal-dst.el
@@ -354,10 +354,10 @@ If the locale never uses daylight saving time, set this to 0."
(if calendar-current-time-zone-cache
(format-time-string
"%z" 0 (* 60 (car calendar-current-time-zone-cache)))
- "+0000")
- (or (nth 2 calendar-current-time-zone-cache) "EST"))
+ "-0000")
+ (or (nth 2 calendar-current-time-zone-cache) "UTC"))
"Abbreviated name of standard time zone at `calendar-location-name'.
-For example, \"EST\" in New York City, \"PST\" for Los Angeles."
+For example, \"-0500\" or \"EST\" in New York City."
:type 'string
:version "28.1"
:set-after '(calendar-time-zone-style)
@@ -368,10 +368,10 @@ For example, \"EST\" in New York City, \"PST\" for Los Angeles."
(if calendar-current-time-zone-cache
(format-time-string
"%z" 0 (* 60 (cadr calendar-current-time-zone-cache)))
- "+0000")
- (or (nth 3 calendar-current-time-zone-cache) "EDT"))
+ "-0000")
+ (or (nth 3 calendar-current-time-zone-cache) "UTC"))
"Abbreviated name of daylight saving time zone at `calendar-location-name'.
-For example, \"EDT\" in New York City, \"PDT\" for Los Angeles."
+For example, \"-0400\" or \"EDT\" in New York City."
:type 'string
:version "28.1"
:set-after '(calendar-time-zone-style)
diff --git a/lisp/calendar/cal-move.el b/lisp/calendar/cal-move.el
index ed42160b12b..4a486d1cde7 100644
--- a/lisp/calendar/cal-move.el
+++ b/lisp/calendar/cal-move.el
@@ -157,9 +157,9 @@ EVENT is an event like `last-nonmenu-event'."
(interactive (list (prefix-numeric-value current-prefix-arg)
last-nonmenu-event))
(unless arg (setq arg 1))
- (save-selected-window
- ;; Nil if called from menu-bar.
- (if (setq event (event-start event)) (select-window (posn-window event)))
+ (save-current-buffer
+ (when (event-start event)
+ (set-buffer (calendar-event-buffer event)))
(calendar-cursor-to-nearest-date)
(unless (zerop arg)
(let ((old-date (calendar-cursor-to-date))
diff --git a/lisp/calendar/calendar.el b/lisp/calendar/calendar.el
index 422a6ceaa7a..10c86571804 100644
--- a/lisp/calendar/calendar.el
+++ b/lisp/calendar/calendar.el
@@ -1554,6 +1554,15 @@ first INDENT characters on the line."
(when (window-live-p (get-buffer-window))
(set-window-point (get-buffer-window) (point))))))
+(defun calendar-event-buffer (event)
+ "Return the Calendar buffer where EVENT happened.
+If EVENT's start falls within a window, use that window's buffer.
+Otherwise, use the selected window of EVENT's frame."
+ (let ((window-or-frame (posn-window (event-start event))))
+ (if (windowp window-or-frame)
+ (window-buffer window-or-frame)
+ (window-buffer (frame-selected-window window-or-frame)))))
+
(defvar calendar-mode-map
(let ((map (make-keymap)))
(suppress-keymap map)
@@ -1916,10 +1925,13 @@ parameter ERROR is non-nil, otherwise just returns nil.
If EVENT is non-nil, it's an event indicating the buffer position to
use instead of point."
(with-current-buffer
- (if event (window-buffer (posn-window (event-start event)))
+ (if event (calendar-event-buffer event)
(current-buffer))
(save-excursion
(and event (setq event (event-start event))
+ ;; (posn-point event) can be `menu-bar' if this command is
+ ;; invoked from the menu bar.
+ (integerp (posn-point event))
(goto-char (posn-point event)))
(let* ((segment (calendar-column-to-segment))
(month (% (+ displayed-month (1- segment)) 12)))
@@ -2002,10 +2014,8 @@ handle dates in years BC."
EVENT is an event like `last-nonmenu-event'."
(interactive (let ((event (list last-nonmenu-event)))
(append (calendar-read-date 'noday) event)))
- (save-selected-window
- (and event
- (setq event (event-start event))
- (select-window (posn-window event)))
+ (with-current-buffer (or (and (not event) (current-buffer))
+ (calendar-event-buffer event))
(unless (and (= month displayed-month)
(= year displayed-year))
(let ((old-date (calendar-cursor-to-date))
@@ -2327,10 +2337,12 @@ returned is (month year)."
(defmon (aref month-array (1- (calendar-extract-month default-date))))
(completion-ignore-case t)
(month (cdr (assoc-string
- (completing-read
- (format-prompt "Month name" defmon)
- (append month-array nil)
- nil t nil nil defmon)
+ (let ((completion-extra-properties
+ '(:category calendar-month)))
+ (completing-read
+ (format-prompt "Month name" defmon)
+ (append month-array nil)
+ nil t nil nil defmon))
(calendar-make-alist month-array 1) t)))
(defday (calendar-extract-day default-date))
(last (calendar-last-day-of-month month year)))
diff --git a/lisp/calendar/diary-lib.el b/lisp/calendar/diary-lib.el
index c99144ebad0..63bbae4d8ed 100644
--- a/lisp/calendar/diary-lib.el
+++ b/lisp/calendar/diary-lib.el
@@ -167,8 +167,8 @@ form of ((MONTH DAY YEAR) STRING), where string is the diary
entry for the given date. This can be used, for example, to
produce a different buffer for display (perhaps combined with
holidays), or hard copy output."
- :type '(choice (const diary-fancy-display :tag "Fancy display")
- (const diary-simple-display :tag "Basic display")
+ :type '(choice (const :tag "Fancy display" diary-fancy-display)
+ (const :tag "Basic display" diary-simple-display)
(const :tag "No display" ignore)
(function :tag "User-specified function"))
:initialize 'custom-initialize-default
@@ -339,7 +339,7 @@ Returns a string using match elements 1-5, where:
(t "\\1 \\2 \\3"))) ; MDY
"\n \\4 %s, \\5")))
;; TODO Sometimes the time is in a different time-zone to the one you
-;; are in. Eg in PST, you might still get an email referring to:
+;; are in. E.g., in Los Angeles, you might still get an email referring to:
;; "7:00 PM-8:00 PM. Greenwich Standard Time".
;; Note that it doesn't use a standard abbreviation for the timezone,
;; or anything helpful like that.
diff --git a/lisp/calendar/holidays.el b/lisp/calendar/holidays.el
index 625130c30fa..c7499938c6a 100644
--- a/lisp/calendar/holidays.el
+++ b/lisp/calendar/holidays.el
@@ -359,7 +359,7 @@ use instead of point."
(interactive (list last-nonmenu-event))
;; If called from a menu, with the calendar window not selected.
(with-current-buffer
- (if event (window-buffer (posn-window (event-start event)))
+ (if event (calendar-event-buffer event)
(current-buffer))
(message "Looking up holidays...")
(let ((holiday-list (calendar-holiday-list))
@@ -590,7 +590,7 @@ use instead of point."
(interactive (list last-nonmenu-event))
;; If called from a menu, with the calendar window not selected.
(with-current-buffer
- (if event (window-buffer (posn-window (event-start event)))
+ (if event (calendar-event-buffer event)
(current-buffer))
(setq calendar-mark-holidays-flag t)
(message "Marking holidays...")
diff --git a/lisp/calendar/icalendar.el b/lisp/calendar/icalendar.el
index 53b109478f1..d7e62e1baf3 100644
--- a/lisp/calendar/icalendar.el
+++ b/lisp/calendar/icalendar.el
@@ -277,9 +277,9 @@ other sexp entries are enumerated in any case."
:value 10)
(set :tag "Alarm type"
(list :tag "Audio"
- (const audio :tag "Audio"))
+ (const :tag "Audio" audio))
(list :tag "Display"
- (const display :tag "Display"))
+ (const :tag "Display" display))
(list :tag "Email"
(const email)
(repeat :tag "Attendees"
diff --git a/lisp/calendar/iso8601.el b/lisp/calendar/iso8601.el
index 5a0c06fe8e3..a32b52564c9 100644
--- a/lisp/calendar/iso8601.el
+++ b/lisp/calendar/iso8601.el
@@ -129,7 +129,7 @@ well as variants like \"2008W32\" (week number) and
See `decode-time' for the meaning of FORM."
(if (not (iso8601-valid-p string))
- (signal 'wrong-type-argument string)
+ (signal 'wrong-type-argument (list string))
(let* ((date-string (match-string 1 string))
(time-string (match-string 2 string))
(zone-string (match-string 3 string))
@@ -217,7 +217,7 @@ See `decode-time' for the meaning of FORM."
((iso8601--match "---\\([0-9][0-9]\\)" string)
(iso8601--decoded-time :day (string-to-number (match-string 1 string))))
(t
- (signal 'wrong-type-argument string))))
+ (signal 'wrong-type-argument (list string)))))
(defun iso8601-parse-time (string &optional form)
"Parse STRING, which should be an ISO 8601 time string.
@@ -226,11 +226,11 @@ hour/minute/seconds/zone fields filled in.
See `decode-time' for the meaning of FORM."
(if (not (iso8601--match iso8601--full-time-match string))
- (signal 'wrong-type-argument string)
+ (signal 'wrong-type-argument (list string))
(let ((time (match-string 1 string))
(zone (match-string 2 string)))
(if (not (iso8601--match iso8601--time-match time))
- (signal 'wrong-type-argument string)
+ (signal 'wrong-type-argument (list string))
(let ((hour (string-to-number (match-string 1 time)))
(minute (and (match-string 2 time)
(string-to-number (match-string 2 time))))
@@ -274,7 +274,7 @@ See `decode-time' for the meaning of FORM."
"Parse STRING, which should be an ISO 8601 time zone.
Return the number of minutes."
(if (not (iso8601--match iso8601--zone-match string))
- (signal 'wrong-type-argument string)
+ (signal 'wrong-type-argument (list string))
(if (match-string 2 string)
;; HH:MM-ish.
(let ((hour (string-to-number (match-string 3 string)))
@@ -314,14 +314,14 @@ Return the number of minutes."
((iso8601--match iso8601--duration-combined-match string)
(iso8601-parse (substring string 1)))
(t
- (signal 'wrong-type-argument string))))
+ (signal 'wrong-type-argument (list string)))))
(defun iso8601-parse-interval (string)
"Parse ISO 8601 intervals."
(let ((bits (split-string string "/"))
start end duration)
(if (not (= (length bits) 2))
- (signal 'wrong-type-argument string)
+ (signal 'wrong-type-argument (list string))
;; The intervals may be an explicit start/end times, or either a
;; start or an end, and an accompanying duration.
(cond
@@ -338,7 +338,7 @@ Return the number of minutes."
(setq start (iso8601-parse (car bits))
end (iso8601-parse (cadr bits))))
(t
- (signal 'wrong-type-argument string))))
+ (signal 'wrong-type-argument (list string)))))
(unless end
(setq end (decoded-time-add start duration)))
(unless start
diff --git a/lisp/calendar/lunar.el b/lisp/calendar/lunar.el
index 94606525ed8..87c47304c24 100644
--- a/lisp/calendar/lunar.el
+++ b/lisp/calendar/lunar.el
@@ -94,7 +94,7 @@ remainder mod 4 gives the phase: 0 new moon, 1 first quarter, 2 full moon,
(* -0.0016528 time time)
(* -0.00000239 time time time))
360.0))
- (eclipse (eclipse-check moon-lat phase))
+ (eclipse (lunar-check-for-eclipse moon-lat phase))
(adjustment
(if (memq phase '(0 2))
(+ (* (- 0.1734 (* 0.000393 time))
@@ -154,26 +154,22 @@ remainder mod 4 gives the phase: 0 new moon, 1 first quarter, 2 full moon,
;; from "Astronomy with your Personal Computer", Subroutine Eclipse
;; Line 7000 Peter Duffett-Smith Cambridge University Press 1990
-(defun eclipse-check (moon-lat phase)
- (let* ((moon-lat (* (/ float-pi 180) moon-lat))
- ;; For positions near the ascending or descending node,
- ;; calculate the absolute angular distance from that node.
- (moon-lat (abs (- moon-lat (* (floor (/ moon-lat float-pi))
- float-pi))))
- (moon-lat (if (> moon-lat 0.37) ; FIXME (* 0.5 float-pi)
- (- float-pi moon-lat)
- moon-lat))
- (phase-name (cond ((= phase 0) "Solar")
- ((= phase 2) "Lunar")
- (t ""))))
- (cond ((string= phase-name "")
- "")
- ((< moon-lat 2.42600766e-1)
- (concat "** " phase-name " Eclipse **"))
- ((< moon-lat 0.37)
- (concat "** " phase-name " Eclipse possible **"))
- (t
- ""))))
+(defun lunar-check-for-eclipse (moon-lat phase)
+ "Check if a solar or lunar eclipse can occur for MOON-LAT and PHASE.
+MOON-LAT is the argument of latitude. PHASE is the lunar phase:
+0 new moon, 1 first quarter, 2 full moon, 3 last quarter.
+Return a string describing the eclipse (empty if no eclipse)."
+ (let* ((node-dist (mod moon-lat 180))
+ ;; Absolute angular distance from the ascending or descending
+ ;; node, whichever is nearer.
+ (node-dist (min node-dist (- 180 node-dist)))
+ (type (cond ((= phase 0) "Solar")
+ ((= phase 2) "Lunar"))))
+ (cond ((not type) "")
+ ;; Limits 13.9° and 21.0° from Meeus (1991), page 350.
+ ((< node-dist 13.9) (concat "** " type " Eclipse **"))
+ ((< node-dist 21.0) (concat "** " type " Eclipse possible **"))
+ (t ""))))
(defconst lunar-cycles-per-year 12.3685 ; 365.25/29.530588853
"Mean number of lunar cycles per 365.25 day year.")
@@ -230,7 +226,7 @@ use instead of point."
(interactive (list last-nonmenu-event))
;; If called from a menu, with the calendar window not selected.
(with-current-buffer
- (if event (window-buffer (posn-window (event-start event)))
+ (if event (calendar-event-buffer event)
(current-buffer))
(message "Computing phases of the moon...")
(let ((m1 displayed-month)
@@ -249,10 +245,11 @@ use instead of point."
(insert
(mapconcat
(lambda (x)
- (format "%s: %s %s %s" (calendar-date-string (car x))
- (lunar-phase-name (nth 2 x))
- (cadr x)
- (car (last x))))
+ (let ((eclipse (nth 3 x)))
+ (concat (calendar-date-string (car x)) ": "
+ (lunar-phase-name (nth 2 x)) " "
+ (cadr x) (unless (string-empty-p eclipse) " ")
+ eclipse)))
(lunar-phase-list m1 y1) "\n")))
(message "Computing phases of the moon...done"))))
@@ -287,9 +284,13 @@ use when highlighting the day in the calendar."
(while (calendar-date-compare phase (list date))
(setq index (1+ index)
phase (lunar-phase index)))
- (if (calendar-date-equal (car phase) date)
- (cons mark (concat (lunar-phase-name (nth 2 phase)) " "
- (cadr phase))))))
+ (and (calendar-date-equal (car phase) date)
+ (cons mark
+ (let ((eclipse (nth 3 phase)))
+ (concat (lunar-phase-name (nth 2 phase)) " "
+ (cadr phase)
+ (unless (string-empty-p eclipse) " ")
+ eclipse))))))
;; For the Chinese calendar the calculations for the new moon need to be more
;; accurate than those above, so we use more terms in the approximation.
diff --git a/lisp/calendar/solar.el b/lisp/calendar/solar.el
index 091f82ea47c..ecb3a47be71 100644
--- a/lisp/calendar/solar.el
+++ b/lisp/calendar/solar.el
@@ -839,12 +839,10 @@ This function is suitable for execution in an init file."
"E" "W"))))))
(calendar-standard-time-zone-name
(if (< arg 16) calendar-standard-time-zone-name
- (cond ((zerop calendar-time-zone)
- (if (eq calendar-time-zone-style 'numeric)
- "+0000" "UTC"))
- ((< calendar-time-zone 0)
- (format "UTC%dmin" calendar-time-zone))
- (t (format "UTC+%dmin" calendar-time-zone)))))
+ (if (and (zerop calendar-time-zone)
+ (not (eq calendar-time-zone-style 'numeric)))
+ "UTC"
+ (format-time-string "%z" 0 (* 60 calendar-time-zone)))))
(calendar-daylight-savings-starts
(if (< arg 16) calendar-daylight-savings-starts))
(calendar-daylight-savings-ends
diff --git a/lisp/calendar/time-date.el b/lisp/calendar/time-date.el
index ebb4404cde3..e96e2e7e2db 100644
--- a/lisp/calendar/time-date.el
+++ b/lisp/calendar/time-date.el
@@ -408,6 +408,7 @@ right of \"%x\", trailing zero units are not output."
"Formatting used by the function `seconds-to-string'.")
;;;###autoload
(defun seconds-to-string (delay)
+ ;; FIXME: There's a similar (tho fancier) function in mastodon.el!
"Convert the time interval in seconds to a short string."
(cond ((> 0 delay) (concat "-" (seconds-to-string (- delay))))
((= 0 delay) "0s")
diff --git a/lisp/calendar/todo-mode.el b/lisp/calendar/todo-mode.el
index 9ef473b1b43..12287299a7f 100644
--- a/lisp/calendar/todo-mode.el
+++ b/lisp/calendar/todo-mode.el
@@ -139,8 +139,8 @@ automatically recalculated when the window width changes. If the
string consists of more (or less) than one character, it will be
the value of `todo-done-separator'."
:type 'string
- :initialize 'custom-initialize-default
- :set 'todo-reset-done-separator-string
+ :initialize #'custom-initialize-default
+ :set #'todo-reset-done-separator-string
:group 'todo-display)
(defun todo-done-separator ()
@@ -170,8 +170,8 @@ have its intended effect. The second string is inserted after
the diary date."
:type '(list string string)
:group 'todo-edit
- :initialize 'custom-initialize-default
- :set 'todo-reset-nondiary-marker)
+ :initialize #'custom-initialize-default
+ :set #'todo-reset-nondiary-marker)
(defconst todo-nondiary-start (nth 0 todo-nondiary-marker)
"String inserted before item date to block diary inclusion.")
@@ -189,20 +189,53 @@ The final element is \"*\", indicating an unspecified month.")
"Array of abbreviated month names, in order.
The final element is \"*\", indicating an unspecified month.")
+(defconst todo--date-pattern-groups
+ (pcase calendar-date-style
+ ('american '((monthname . "6") (month . "7") (day . "8") (year . "9")))
+ ('european '((day . "6") (monthname . "7") (month . "8") (year . "9")))
+ ('iso '((year . "6") (monthname . "7") (month . "8") (day . "9"))))
+ "Alist for grouping date components in `todo-date-pattern'.")
+
(defconst todo-date-pattern
- (let ((dayname (diary-name-pattern calendar-day-name-array nil t)))
- (concat "\\(?4:\\(?5:" dayname "\\)\\|"
- (calendar-dlet
- ((dayname)
- (monthname (format "\\(?6:%s\\)" (diary-name-pattern
- todo-month-name-array
- todo-month-abbrev-array)))
- (month "\\(?7:[0-9]+\\|\\*\\)")
- (day "\\(?8:[0-9]+\\|\\*\\)")
- (year "-?\\(?9:[0-9]+\\|\\*\\)"))
- (mapconcat #'eval calendar-date-display-form ""))
- "\\)"))
- "Regular expression matching a todo item date header.")
+ (let* ((dayname (diary-name-pattern calendar-day-name-array nil t))
+ (d (concat "\\(?" (alist-get 'day todo--date-pattern-groups)
+ ":[0-9]+\\|\\*\\)"))
+ (mn (format (concat "\\(?" (alist-get 'monthname
+ todo--date-pattern-groups)
+ ":%s\\)")
+ (diary-name-pattern todo-month-name-array
+ todo-month-abbrev-array)))
+ (m (concat "\\(?" (alist-get 'month todo--date-pattern-groups)
+ ":[0-9]+\\|\\*\\)"))
+ (y (concat "\\(?" (alist-get 'year todo--date-pattern-groups)
+ ":[0-9]+\\|\\*\\)"))
+ (dd "1111111")
+ (mm "2222222")
+ (yy "3333333")
+ (s (concat "\\(?4:\\(?5:" dayname "\\)\\|"
+ (calendar-dlet
+ ((dayname)
+ (monthname mn)
+ (year yy)
+ (month mm)
+ (day dd))
+ (mapconcat #'eval calendar-date-display-form))
+ "\\)")))
+ ;; The default value of calendar-iso-date-display-form calls
+ ;; `string-to-number' on the values of `month' and `day', so we
+ ;; gave them placeholder values above and now replace these with
+ ;; the necessary regexps with appropriately numbered groups, because
+ ;; `todo-edit-item--header' uses these groups.
+ (when (string-match dd s nil t)
+ (setq s (string-replace dd d s)))
+ (when (string-match mm s nil t)
+ (setq s (string-replace mm m s)))
+ (when (string-match yy s nil t)
+ (setq s (string-replace yy y s)))
+ s)
+ "Regular expression matching a todo item date header.
+The value of `calendar-date-display-form' determines the form of
+the date header.")
;; By itself this matches anything, because of the `?'; however, it's only
;; used in the context of `todo-date-pattern' (but Emacs Lisp lacks
@@ -215,8 +248,8 @@ The final element is \"*\", indicating an unspecified month.")
(defcustom todo-done-string "DONE "
"Identifying string appended to the front of done todo items."
:type 'string
- :initialize 'custom-initialize-default
- :set 'todo-reset-done-string
+ :initialize #'custom-initialize-default
+ :set #'todo-reset-done-string
:group 'todo-edit)
(defconst todo-done-string-start
@@ -242,16 +275,16 @@ The final element is \"*\", indicating an unspecified month.")
(format-message
"Invalid value: must be distinct from `todo-item-mark'"))
widget)))
- :initialize 'custom-initialize-default
- :set 'todo-reset-prefix
+ :initialize #'custom-initialize-default
+ :set #'todo-reset-prefix
:group 'todo-display)
(defcustom todo-number-prefix t
"Non-nil to prefix items with consecutively increasing integers.
These reflect the priorities of the items in each category."
:type 'boolean
- :initialize 'custom-initialize-default
- :set 'todo-reset-prefix
+ :initialize #'custom-initialize-default
+ :set #'todo-reset-prefix
:group 'todo-display)
(defun todo-mode-line-control (cat)
@@ -273,8 +306,8 @@ todo category. The resulting control becomes the local value of
(defcustom todo-highlight-item nil
"Non-nil means highlight items at point."
:type 'boolean
- :initialize 'custom-initialize-default
- :set 'todo-reset-highlight-item
+ :initialize #'custom-initialize-default
+ :set #'todo-reset-highlight-item
:group 'todo-display)
(defcustom todo-wrap-lines t
@@ -572,8 +605,8 @@ This lacks the extension and directory components."
"Non-nil to make `todo-show' visit the current todo file.
Otherwise, `todo-show' always visits `todo-default-todo-file'."
:type 'boolean
- :initialize 'custom-initialize-default
- :set 'todo-set-show-current-file
+ :initialize #'custom-initialize-default
+ :set #'todo-set-show-current-file
:group 'todo)
(defcustom todo-show-first 'first
@@ -644,7 +677,7 @@ current (i.e., last displayed) category.
In Todo mode just the category's unfinished todo items are shown
by default. The done items are hidden, but typing
-`\\[todo-toggle-view-done-items]' displays them below the todo
+\\[todo-toggle-view-done-items] displays them below the todo
items. With non-nil user option `todo-show-with-done' both todo
and done items are always shown on visiting a category."
(interactive "P\np")
@@ -1206,7 +1239,7 @@ visiting the deleted files."
(let ((sexp (read (buffer-substring-no-properties
(line-beginning-position)
(line-end-position))))
- (buffer-read-only nil)
+ (inhibit-read-only t)
(print-length nil)
(print-level nil))
(mapc (lambda (x) (aset (cdr x) 3 0)) sexp)
@@ -1304,7 +1337,7 @@ return the new category number."
(widen)
(goto-char (point-max))
(save-excursion ; Save point for todo-category-select.
- (let ((buffer-read-only nil))
+ (let ((inhibit-read-only t))
(insert todo-category-beg cat "\n\n" todo-category-done "\n")))
(todo-update-categories-sexp)
;; If invoked by user, display the newly added category, if
@@ -1334,7 +1367,7 @@ category there as well."
(list archive)))))
(dolist (buf buffers)
(with-current-buffer (find-file-noselect buf)
- (let (buffer-read-only)
+ (let ((inhibit-read-only t))
(setq todo-categories (todo-set-categories))
(save-excursion
(save-restriction
@@ -1382,7 +1415,7 @@ todo or done items."
"\"" (and arg " and all its entries")
"? "))))
(widen)
- (let ((buffer-read-only)
+ (let ((inhibit-read-only t)
(beg (re-search-backward
(concat "^" (regexp-quote (concat todo-category-beg cat))
"\n")
@@ -1463,6 +1496,10 @@ the archive of the file moved to, creating it if it does not exist."
(point-max)))
(content (buffer-substring-no-properties beg end))
(counts (cdr (assoc cat todo-categories))))
+ ;; Restore display of selected category, so internal file
+ ;; structure is not visible if user is prompted to choose a new
+ ;; category name in target file.
+ (todo-category-select)
;; Move the category to the new file. Also update or create
;; archive file if necessary.
(with-current-buffer
@@ -1482,7 +1519,7 @@ the archive of the file moved to, creating it if it does not exist."
nfile-short)
(format "the category \"%s\";\n" cat)
"enter a new category name: "))
- (buffer-read-only nil)
+ (inhibit-read-only t)
(print-length nil)
(print-level nil))
(widen)
@@ -1524,8 +1561,9 @@ the archive of the file moved to, creating it if it does not exist."
;; Delete the category from the old file, and if that was the
;; last category, delete the file. Also handle archive file
;; if necessary.
- (let ((buffer-read-only nil))
- (remove-overlays beg end)
+ (let ((inhibit-read-only t))
+ (widen)
+ (remove-overlays beg end)
(delete-region beg end)
(goto-char (point-min))
;; Put point after todo-categories sexp.
@@ -1574,9 +1612,9 @@ archive file and the source category is deleted."
(garchive (concat (file-name-sans-extension gfile) ".toda"))
(archived-count (todo-get-count 'archived))
here)
- (with-current-buffer (get-buffer (find-file-noselect tfile))
+ (with-current-buffer (find-file-noselect tfile)
(widen)
- (let* ((buffer-read-only nil)
+ (let* ((inhibit-read-only t)
(cbeg (progn
(re-search-backward
(concat "^" (regexp-quote todo-category-beg)) nil t)
@@ -1600,11 +1638,11 @@ archive file and the source category is deleted."
(todo-count (todo-get-count 'todo cat))
(done-count (todo-get-count 'done cat)))
;; Merge into goal todo category.
- (with-current-buffer (get-buffer (find-file-noselect gfile))
+ (with-current-buffer (find-file-noselect gfile)
(unless (derived-mode-p 'todo-mode) (todo-mode))
(widen)
(goto-char (point-min))
- (let ((buffer-read-only nil))
+ (let ((inhibit-read-only t))
;; Merge any todo items.
(unless (zerop (length todo))
(re-search-forward
@@ -1639,10 +1677,10 @@ archive file and the source category is deleted."
(mapc (lambda (m) (set-marker m nil))
(list cbeg tbeg dbeg tend cend))))
(when (> archived-count 0)
- (with-current-buffer (get-buffer (find-file-noselect tarchive))
+ (with-current-buffer (find-file-noselect tarchive)
(widen)
(goto-char (point-min))
- (let* ((buffer-read-only nil)
+ (let* ((inhibit-read-only t)
(cbeg (progn
(when (re-search-forward
(concat "^" (regexp-quote
@@ -1659,7 +1697,7 @@ archive file and the source category is deleted."
(forward-line)
(buffer-substring-no-properties (point) cend))))
;; Merge into goal archive category, if it exists, else create it.
- (with-current-buffer (get-buffer (find-file-noselect garchive))
+ (with-current-buffer (find-file-noselect garchive)
(let ((gbeg (when (re-search-forward
(concat "^" (regexp-quote
(concat todo-category-beg goal))
@@ -1757,8 +1795,8 @@ only when no items are marked."
(defcustom todo-comment-string "COMMENT"
"String inserted before optional comment appended to done item."
:type 'string
- :initialize 'custom-initialize-default
- :set 'todo-reset-comment-string
+ :initialize #'custom-initialize-default
+ :set #'todo-reset-comment-string
:group 'todo-edit)
(defcustom todo-undo-item-omit-comment 'ask
@@ -1962,7 +2000,7 @@ their associated keys and their effects."
(setq todo-current-todo-file file)
(unless todo-global-current-todo-file
(setq todo-global-current-todo-file todo-current-todo-file))
- (let ((buffer-read-only nil)
+ (let ((inhibit-read-only t)
done-only item-added)
(unless copy
(setq new-item
@@ -2039,7 +2077,7 @@ their associated keys and their effects."
(todo-date-from-calendar
(let (calendar-view-diary-initially-flag)
(calendar)) ; *Calendar* is now current buffer.
- (define-key calendar-mode-map [remap newline] 'exit-recursive-edit)
+ (define-key calendar-mode-map [remap newline] #'exit-recursive-edit)
;; If user exits Calendar before choosing a date, clean up properly.
(define-key calendar-mode-map
[remap calendar-exit] (lambda ()
@@ -2074,7 +2112,7 @@ prompt for a todo file and then for a category in it."
(calendar-exit)
(todo-insert-item--basic arg nil todo-date-from-calendar))
-(define-key calendar-mode-map "it" 'todo-insert-item-from-calendar)
+(define-key calendar-mode-map "it" #'todo-insert-item-from-calendar)
(defun todo-delete-item ()
"Delete at least one item in this category.
@@ -2095,7 +2133,7 @@ the item at point."
(save-excursion (todo-item-end))))
(overlay-put ov 'face 'todo-search)
(todo-y-or-n-p "Permanently delete this item? "))))
- buffer-read-only)
+ (inhibit-read-only t))
(when answer
(and marked (goto-char (point-min)))
(catch 'done
@@ -2192,9 +2230,9 @@ the item at point."
end t)
(if comment-delete
(when (todo-y-or-n-p "Delete comment? ")
- (let ((buffer-read-only nil))
+ (let ((inhibit-read-only t))
(delete-region (match-beginning 0) (match-end 0))))
- (let ((buffer-read-only nil))
+ (let ((inhibit-read-only t))
(replace-match (save-match-data
(prog1 (let ((buffer-read-only t))
(read-string
@@ -2211,7 +2249,7 @@ the item at point."
nil nil nil 1)))
(if comment-delete
(user-error "There is no comment to delete")
- (let ((buffer-read-only nil))
+ (let ((inhibit-read-only t))
(insert " [" todo-comment-string ": "
(prog1 (let ((buffer-read-only t))
(read-string prompt))
@@ -2256,7 +2294,7 @@ the item at point."
(todo-category-number ocat)
(todo-category-select)
(goto-char opoint))
- (let ((buffer-read-only nil))
+ (let ((inhibit-read-only t))
(todo-remove-item)
(todo-insert-with-overlays new))
(move-to-column item-beg)))))))))
@@ -2345,10 +2383,18 @@ made in the number or names of categories."
(line-end-position) t)
(let* ((otime (match-string-no-properties 2))
(odayname (match-string-no-properties 5))
- (omonthname (match-string-no-properties 6))
- (omonth (match-string-no-properties 7))
- (oday (match-string-no-properties 8))
- (oyear (match-string-no-properties 9))
+ (mngroup (string-to-number
+ (alist-get 'monthname todo--date-pattern-groups)))
+ (omonthname (match-string-no-properties mngroup))
+ (mgroup (string-to-number
+ (alist-get 'month todo--date-pattern-groups)))
+ (omonth (match-string-no-properties mgroup))
+ (dgroup (string-to-number
+ (alist-get 'day todo--date-pattern-groups)))
+ (oday (match-string-no-properties dgroup))
+ (ygroup (string-to-number
+ (alist-get 'year todo--date-pattern-groups)))
+ (oyear (match-string-no-properties ygroup))
(tmn-array todo-month-name-array)
(mlist (append tmn-array nil))
(tma-array todo-month-abbrev-array)
@@ -2394,11 +2440,23 @@ made in the number or names of categories."
((eq what 'month)
(setf day oday
year oyear
- (if (memq 'month calendar-date-display-form)
+ ;; With default ISO style, 'month is in a
+ ;; sublist of c-d-d-f, so we flatten it.
+ (if (memq 'month (flatten-tree
+ calendar-date-display-form))
month
monthname)
(cond ((not current-prefix-arg)
- (todo-read-date 'month))
+ (let ((nmonth (todo-read-date 'month)))
+ ;; If old month is given as a number,
+ ;; have to convert new month name to
+ ;; the corresponding number.
+ (when omonth
+ (setq nmonth
+ (number-to-string
+ (1+ (seq-position tma-array
+ nmonth)))))
+ nmonth))
((or (string= omonth "*") (= mm 13))
(user-error "Cannot increment *"))
(t
@@ -2488,8 +2546,8 @@ made in the number or names of categories."
(month month)
(day day)
(dayname nil)) ;; dayname
- (mapconcat #'eval calendar-date-display-form "")))))
- (let ((buffer-read-only nil))
+ (mapconcat #'eval calendar-date-display-form)))))
+ (let ((inhibit-read-only t))
(when ndate (replace-match ndate nil nil nil 1))
;; Add new time string to the header, if it was supplied.
(when ntime
@@ -2508,7 +2566,7 @@ made in the number or names of categories."
(defun todo-edit-item--diary-inclusion (&optional nonmarking)
"Function providing diary marking facilities of `todo-edit-item'."
- (let ((buffer-read-only)
+ (let ((inhibit-read-only t)
(marked (assoc (todo-current-category) todo-categories-with-marks)))
(when marked (todo--user-error-if-marked-done-item))
(catch 'stop
@@ -2558,7 +2616,7 @@ items."
(goto-char (point-min))
(let ((todo-count (todo-get-count 'todo))
(diary-count (todo-get-count 'diary))
- (buffer-read-only))
+ (inhibit-read-only t))
(catch 'stop
(while (not (eobp))
(if (todo-done-item-p) ; We've gone too far.
@@ -2594,7 +2652,7 @@ items in this category."
(interactive "P")
(save-excursion
(goto-char (point-min))
- (let (buffer-read-only)
+ (let ((inhibit-read-only t))
(catch 'stop
(while (not (eobp))
(if (todo-done-item-p) ; We've gone too far.
@@ -2641,16 +2699,26 @@ meaning to raise or lower the item's priority by one."
(save-excursion
(re-search-forward regexp1 nil t)
(match-string-no-properties 1)))))))
- curnum
+ (count 1)
+ (curnum (save-excursion
+ (let ((curstart
+ ;; If point is in done items section or not on an
+ ;; item, use position of first todo item to avoid
+ ;; the while-loop.
+ (or (and (not (todo-done-item-section-p))
+ (todo-item-start))
+ (point-min))))
+ (goto-char (point-min))
+ (while (/= (point) curstart)
+ (setq count (1+ count))
+ (todo-forward-item))
+ count)))
(todo (cond ((or (memq arg '(raise lower))
(eq major-mode 'todo-filtered-items-mode))
(save-excursion
- (let ((curstart (todo-item-start))
- (count 0))
- (goto-char (point-min))
+ (let ((count curnum))
(while (looking-at todo-item-start)
(setq count (1+ count))
- (when (= (point) curstart) (setq curnum count))
(todo-forward-item))
count)))
((eq major-mode 'todo-mode)
@@ -2662,11 +2730,16 @@ meaning to raise or lower the item's priority by one."
((and (eq arg 'raise) (>= curnum 1))
(1- curnum))
((and (eq arg 'lower) (<= curnum maxnum))
- (1+ curnum))))
- candidate)
+ (1+ curnum)))))
+ (and (called-interactively-p 'any)
+ priority ; Check further only if arg or prefix arg was passed.
+ (or (< priority 1) (> priority maxnum))
+ (user-error (format "Priority must be an integer between 1 and %d"
+ maxnum)))
(unless (and priority
+ (/= priority curnum)
(or (and (eq arg 'raise) (zerop priority))
- (and (eq arg 'lower) (> priority maxnum))))
+ (and (eq arg 'lower) (>= priority maxnum))))
;; When moving item to another category, show the category before
;; prompting for its priority.
(unless (or arg (called-interactively-p 'any))
@@ -2682,16 +2755,34 @@ meaning to raise or lower the item's priority by one."
;; while setting priority.
(save-excursion (todo-category-select)))))
;; Prompt for priority only when the category has at least one
- ;; todo item.
- (when (> maxnum 1)
- (while (not priority)
- (setq candidate (read-number prompt
- (if (eq todo-default-priority 'first)
- 1 maxnum)))
- (setq prompt (when (or (< candidate 1) (> candidate maxnum))
- (format "Priority must be an integer between 1 and %d.\n"
- maxnum)))
- (unless prompt (setq priority candidate))))
+ ;; todo item or when passing the current priority as prefix arg.
+ (when (and (or (not priority) (= priority curnum))
+ (> maxnum 1))
+ (let* ((read-number-history (mapcar #'number-to-string
+ (if (eq todo-default-priority
+ 'first)
+ (number-sequence maxnum 1 -1)
+ (number-sequence 1 maxnum))))
+ (history-add-new-input nil)
+ (candidate (or priority
+ (read-number prompt
+ (if (eq todo-default-priority
+ 'first)
+ 1 maxnum))))
+ (success nil))
+ (while (not success)
+ (setq prompt
+ (cond
+ ((and (= candidate curnum)
+ ;; Allow same priority in a different category
+ ;; (only possible when called non-interactively).
+ (called-interactively-p 'any))
+ "New priority must be different from current priority: ")
+ (t (when (or (< candidate 1) (> candidate maxnum))
+ (format "Priority must be an integer between 1 and %d: "
+ maxnum)))))
+ (when prompt (setq candidate (read-number prompt)))
+ (unless prompt (setq priority candidate success t)))))
;; In Top Priorities buffer, an item's priority can be changed
;; wrt items in another category, but not wrt items in the same
;; category.
@@ -2716,7 +2807,7 @@ meaning to raise or lower the item's priority by one."
(when match
(user-error (concat "Cannot reprioritize items from the same "
"category in this mode, only in Todo mode")))))
- (let ((buffer-read-only nil))
+ (let ((inhibit-read-only t))
;; Interactively or with non-nil ARG, relocate the item within its
;; category.
(when (or arg (called-interactively-p 'any))
@@ -2839,7 +2930,7 @@ section in the category moved to."
(setq here (point))
(while todo-items
(todo-forward-item)
- (let ((buffer-read-only nil))
+ (let ((inhibit-read-only t))
(todo-insert-with-overlays (pop todo-items)))))
;; Move done items en bloc to top of done items section.
(when done-items
@@ -2854,9 +2945,10 @@ section in the category moved to."
(forward-line)
(unless here (setq here (point)))
(while done-items
- (let ((buffer-read-only nil))
+ (let ((inhibit-read-only t))
(todo-insert-with-overlays (pop done-items)))
- (todo-forward-item)))
+ (todo-item-end)
+ (forward-line)))
;; If only done items were moved, move point to the top
;; one, otherwise, move point to the top moved todo item.
(goto-char here)
@@ -2894,13 +2986,13 @@ section in the category moved to."
(goto-char beg)
(while (< (point) end)
(if (todo-marked-item-p)
- (let ((buffer-read-only nil))
+ (let ((inhibit-read-only t))
(todo-remove-item))
(todo-forward-item)))
(setq todo-categories-with-marks
(assq-delete-all cat1 todo-categories-with-marks)))
(if ov (delete-overlay ov))
- (let ((buffer-read-only nil))
+ (let ((inhibit-read-only t))
(todo-remove-item)))))
(when todo (todo-update-count 'todo (- todo) cat1))
(when diary (todo-update-count 'diary (- diary) cat1))
@@ -2960,7 +3052,7 @@ visible."
(show-done (save-excursion
(goto-char (point-min))
(re-search-forward todo-done-string-start nil t)))
- (buffer-read-only nil)
+ (inhibit-read-only t)
header item done-items
(opoint (point)))
;; Don't add empty comment to done item.
@@ -3092,7 +3184,7 @@ comments without asking."
(when ov (delete-overlay ov))
(if (not undone)
(goto-char opoint)
- (let ((buffer-read-only nil))
+ (let ((inhibit-read-only t))
(if marked
(progn
(setq item nil)
@@ -3230,13 +3322,14 @@ this category does not exist in the archive, it is created."
(with-current-buffer archive
(unless (derived-mode-p 'todo-archive-mode) (todo-archive-mode))
(let ((headers-hidden todo--item-headers-hidden)
- buffer-read-only)
+ (inhibit-read-only t))
(if headers-hidden (todo-toggle-item-header))
(widen)
(goto-char (point-min))
(if (and (re-search-forward
(concat "^" (regexp-quote
- (concat todo-category-beg cat)) "$")
+ (concat todo-category-beg cat))
+ "$")
nil t)
(re-search-forward (regexp-quote todo-category-done)
nil t))
@@ -3260,7 +3353,7 @@ this category does not exist in the archive, it is created."
(todo-archive-mode))
(if headers-hidden (todo-toggle-item-header))))
(with-current-buffer tbuf
- (let ((buffer-read-only nil))
+ (let ((inhibit-read-only t))
(cond
(all
(save-excursion
@@ -3328,7 +3421,7 @@ the only category in the archive, the archive file is deleted."
(item (concat (todo-item-string) "\n"))
(marked-count 0)
marked-items
- buffer-read-only)
+ (inhibit-read-only t))
(when marked
(save-excursion
(goto-char (point-min))
@@ -3340,7 +3433,7 @@ the only category in the archive, the archive file is deleted."
;; Restore items to top of category's done section and update counts.
(with-current-buffer tbuf
(let ((headers-hidden todo--item-headers-hidden)
- buffer-read-only newcat)
+ (inhibit-read-only t) newcat)
(if headers-hidden (todo-toggle-item-header))
(widen)
(goto-char (point-min))
@@ -3477,12 +3570,12 @@ categories display according to priority."
In the initial display the lines of the table are numbered,
indicating the current order of the categories when sequentially
-navigating through the todo file with `\\[todo-forward-category]'
-and `\\[todo-backward-category]'. You can reorder the lines, and
-hence the category sequence, by typing `\\[todo-raise-category]'
-or `\\[todo-lower-category]' to raise or lower the category at
-point, or by typing `\\[todo-set-category-number]' and entering a
-number at the prompt or by typing `\\[todo-set-category-number]'
+navigating through the todo file with \\[todo-forward-category]
+and \\[todo-backward-category]. You can reorder the lines, and
+hence the category sequence, by typing \\[todo-raise-category]
+or \\[todo-lower-category] to raise or lower the category at
+point, or by typing \\[todo-set-category-number] and entering a
+number at the prompt or by typing \\[todo-set-category-number]
with a numeric prefix. If you save the todo file after
reordering the categories, the new order persists in subsequent
Emacs sessions.
@@ -3491,8 +3584,8 @@ The labels above the category names and item counts are buttons,
and clicking these changes the display: sorted by category name
or by the respective item counts (alternately descending or
ascending). In these displays the categories are not numbered
-and `\\[todo-set-category-number]', `\\[todo-raise-category]' and
-`\\[todo-lower-category]' are disabled. (Programmatically, the
+and \\[todo-set-category-number], \\[todo-raise-category] and
+\\[todo-lower-category] are disabled. (Programmatically, the
sorting is triggered by passing a non-nil SORTKEY argument.)
In addition, the lines with the category names and item counts
@@ -3563,7 +3656,7 @@ decreasing or increasing its number."
;; Category's name and items counts list.
(catcons (nth (1- curnum) todo-categories))
(todo-categories (nconc head (list catcons) tail))
- (buffer-read-only nil)
+ (inhibit-read-only t)
newcats)
(when lower (setq todo-categories (nreverse todo-categories)))
(setq todo-categories (delete-dups todo-categories))
@@ -3784,8 +3877,7 @@ which is the value of the user option
(cons todo-categories-diary-label 'diary)
(cons todo-categories-done-label 'done)
(cons todo-categories-archived-label
- 'archived)))
- "")
+ 'archived))))
" ") ; Make highlighting on last column look better.
'face (if (and todo-skip-archived-categories
(zerop (todo-get-count 'todo cat))
@@ -3831,7 +3923,7 @@ which is the value of the user option
(kill-all-local-variables)
(todo-categories-mode)
(let ((archive (member todo-current-todo-file todo-archives))
- buffer-read-only)
+ (inhibit-read-only t))
(erase-buffer)
(insert (format (concat "Category counts for todo "
(if archive "archive" "file")
@@ -3870,7 +3962,7 @@ which is the value of the user option
(forward-line -2)
(goto-char (next-single-char-property-change
(point) 'face nil (line-end-position))))))
- (buffer-read-only))
+ (inhibit-read-only t))
(forward-line 2)
(delete-region (point) (point-max))
;; Fill in the table with buttonized lines, each showing a category and
@@ -3893,8 +3985,7 @@ which is the value of the user option
(list (cons todo-categories-todo-label 0)
(cons todo-categories-diary-label 1)
(cons todo-categories-done-label 2)
- (cons todo-categories-archived-label 3)))
- ""))
+ (cons todo-categories-archived-label 3)))))
;; Put cursor on Category button initially.
(if pt (goto-char pt))
(setq buffer-read-only t)))
@@ -3974,8 +4065,8 @@ face."
(defcustom todo-top-priorities-overrides nil
"List of rules specifying number of top priority items to show.
These rules override `todo-top-priorities' on invocations of
-`\\[todo-filter-top-priorities]' and
-`\\[todo-filter-top-priorities-multifile]'. Each rule is a list
+\\[todo-filter-top-priorities] and
+\\[todo-filter-top-priorities-multifile]. Each rule is a list
of the form (FILE NUM ALIST), where FILE is a member of
`todo-files', NUM is a number specifying the default number of
top priority items for each category in that file, and ALIST,
@@ -3984,8 +4075,8 @@ number specifying the default number of top priority items in
that category, which overrides NUM.
This variable should be set interactively by
-`\\[todo-set-top-priorities-in-file]' or
-`\\[todo-set-top-priorities-in-category]'."
+\\[todo-set-top-priorities-in-file] or
+\\[todo-set-top-priorities-in-category]."
:type 'sexp
:group 'todo-filtered)
@@ -4443,7 +4534,7 @@ the values of FILTER and FILE-LIST."
(widen)))
(setq bufstr (buffer-string))
(with-current-buffer buf
- (let (buffer-read-only)
+ (let ((inhibit-read-only t))
(insert bufstr)))))))
(set-window-buffer (selected-window) (set-buffer buf))
(todo-prefix-overlays)
@@ -4719,7 +4810,7 @@ Helper function for `todo-convert-legacy-files'."
(time (match-string 4))
dayname)
(replace-match "")
- (insert (mapconcat #'eval calendar-date-display-form "")
+ (insert (mapconcat #'eval calendar-date-display-form)
(when time (concat " " time)))))
(defun todo-convert-legacy-files ()
@@ -5073,7 +5164,7 @@ With nil or omitted CATEGORY, default to the current category."
(defun todo-update-categories-sexp ()
"Update the `todo-categories' sexp at the top of the file."
- (let ((buffer-read-only nil)
+ (let ((inhibit-read-only t)
(print-length nil)
(print-level nil))
(save-excursion
@@ -5301,21 +5392,7 @@ changes you have made in the order of the categories.
;; legitimate place to insert an item. But skip this space if
;; count > 1, since that should only stop on an item.
(when (and not-done (todo-done-item-p) (not count))
- ;; (if (or (not count) (= count 1))
- (re-search-backward "^$" start t))));)
- ;; The preceding sexp is insufficient when buffer is not narrowed,
- ;; since there could be no done items in this category, so the
- ;; search puts us on first todo item of next category. Does this
- ;; ever happen? If so:
- ;; (let ((opoint) (point))
- ;; (forward-line -1)
- ;; (when (or (not count) (= count 1))
- ;; (cond ((looking-at (concat "^" (regexp-quote todo-category-beg)))
- ;; (forward-line -2))
- ;; ((looking-at (concat "^" (regexp-quote todo-category-done)))
- ;; (forward-line -1))
- ;; (t
- ;; (goto-char opoint)))))))
+ (re-search-backward "^$" start t))))
(defun todo-backward-item (&optional count)
"Move point up to start of item with next higher priority.
@@ -5824,7 +5901,7 @@ Also return t if answer is \"Y\", but unlike `y-or-n-p', allow
SPC to affirm the question only if option `todo-y-with-space' is
non-nil."
(unless todo-y-with-space
- (define-key query-replace-map " " 'ignore))
+ (define-key query-replace-map " " #'ignore))
(prog1
(y-or-n-p prompt)
(define-key query-replace-map " " 'act)))
@@ -6160,7 +6237,7 @@ number of the last the day of the month."
(if (memq 'month calendar-date-display-form)
month
monthname)))
- (mapconcat #'eval calendar-date-display-form ""))))
+ (mapconcat #'eval calendar-date-display-form))))
(defun todo-read-dayname ()
"Choose name of a day of the week with completion and return it."
@@ -6257,7 +6334,7 @@ the empty string (i.e., no time string)."
(dolist (f files)
(let ((buf (find-buffer-visiting f)))
(with-current-buffer (find-file-noselect f)
- (let (buffer-read-only)
+ (let ((inhibit-read-only t))
(widen)
(goto-char (point-min))
(while (not (eobp))
@@ -6273,7 +6350,7 @@ the empty string (i.e., no time string)."
(replace-match (nth 1 value) t t nil 2))
(forward-line)))
(if buf
- (when (derived-mode-p 'todo-mode 'todo-archive-mode)
+ (when (derived-mode-p '(todo-mode todo-archive-mode))
(todo-category-select))
(save-buffer)
(kill-buffer)))))))))
@@ -6287,7 +6364,7 @@ the empty string (i.e., no time string)."
(when (not (equal value oldvalue))
(dolist (f files)
(with-current-buffer (find-file-noselect f)
- (let (buffer-read-only)
+ (let ((inhibit-read-only t))
(setq todo-done-separator (todo-done-separator))
(when (= 1 (length value))
(todo-reset-done-separator sep)))
@@ -6306,7 +6383,7 @@ the empty string (i.e., no time string)."
(dolist (f files)
(let ((buf (find-buffer-visiting f)))
(with-current-buffer (find-file-noselect f)
- (let (buffer-read-only)
+ (let ((inhibit-read-only t))
(widen)
(goto-char (point-min))
(while (not (eobp))
@@ -6317,7 +6394,7 @@ the empty string (i.e., no time string)."
(replace-match value t t nil 1)
(forward-line)))
(if buf
- (when (derived-mode-p 'todo-mode 'todo-archive-mode)
+ (when (derived-mode-p '(todo-mode todo-archive-mode))
(todo-category-select))
(save-buffer)
(kill-buffer)))))))))
@@ -6332,7 +6409,7 @@ the empty string (i.e., no time string)."
(dolist (f files)
(let ((buf (find-buffer-visiting f)))
(with-current-buffer (find-file-noselect f)
- (let (buffer-read-only)
+ (let ((inhibit-read-only t))
(widen)
(goto-char (point-min))
(while (not (eobp))
@@ -6343,7 +6420,7 @@ the empty string (i.e., no time string)."
(replace-match value t t nil 1)
(forward-line)))
(if buf
- (when (derived-mode-p 'todo-mode 'todo-archive-mode)
+ (when (derived-mode-p '(todo-mode todo-archive-mode))
(todo-category-select))
(save-buffer)
(kill-buffer)))))))))
@@ -6567,32 +6644,32 @@ Filtered Items mode following todo (not done) items."
(define-key map (nth 0 kb) (nth 1 kb)))
(dolist (kb todo-key-bindings-t+a)
(define-key map (nth 0 kb) (nth 1 kb)))
- (define-key map "a" 'todo-jump-to-archive-category)
- (define-key map "u" 'todo-unarchive-items)
+ (define-key map "a" #'todo-jump-to-archive-category)
+ (define-key map "u" #'todo-unarchive-items)
map)
"Todo Archive mode keymap.")
(defvar todo-edit-mode-map
(let ((map (make-sparse-keymap)))
- (define-key map "\C-x\C-q" 'todo-edit-quit)
+ (define-key map "\C-x\C-q" #'todo-edit-quit)
map)
"Todo Edit mode keymap.")
(defvar todo-categories-mode-map
(let ((map (make-sparse-keymap)))
- (define-key map "c" 'todo-sort-categories-alphabetically-or-numerically)
- (define-key map "t" 'todo-sort-categories-by-todo)
- (define-key map "y" 'todo-sort-categories-by-diary)
- (define-key map "d" 'todo-sort-categories-by-done)
- (define-key map "a" 'todo-sort-categories-by-archived)
- (define-key map "#" 'todo-set-category-number)
- (define-key map "l" 'todo-lower-category)
- (define-key map "r" 'todo-raise-category)
- (define-key map "n" 'todo-next-button)
- (define-key map "p" 'todo-previous-button)
- (define-key map [tab] 'todo-next-button)
- (define-key map [backtab] 'todo-previous-button)
- (define-key map "q" 'todo-quit)
+ (define-key map "c" #'todo-sort-categories-alphabetically-or-numerically)
+ (define-key map "t" #'todo-sort-categories-by-todo)
+ (define-key map "y" #'todo-sort-categories-by-diary)
+ (define-key map "d" #'todo-sort-categories-by-done)
+ (define-key map "a" #'todo-sort-categories-by-archived)
+ (define-key map "#" #'todo-set-category-number)
+ (define-key map "l" #'todo-lower-category)
+ (define-key map "r" #'todo-raise-category)
+ (define-key map "n" #'todo-next-button)
+ (define-key map "p" #'todo-previous-button)
+ (define-key map [tab] #'todo-next-button)
+ (define-key map [backtab] #'todo-previous-button)
+ (define-key map "q" #'todo-quit)
map)
"Todo Categories mode keymap.")
@@ -6602,8 +6679,8 @@ Filtered Items mode following todo (not done) items."
(define-key map (nth 0 kb) (nth 1 kb)))
(dolist (kb todo-key-bindings-t+f)
(define-key map (nth 0 kb) (nth 1 kb)))
- (define-key map "g" 'todo-go-to-source-item)
- (define-key map [remap newline] 'todo-go-to-source-item)
+ (define-key map "g" #'todo-go-to-source-item)
+ (define-key map [remap newline] #'todo-go-to-source-item)
map)
"Todo Filtered Items mode keymap.")
@@ -6759,13 +6836,9 @@ Added to `window-configuration-change-hook' in Todo mode."
;; (add-hook 'find-file-hook #'todo-display-as-todo-file nil t)
)
-(put 'todo-mode 'mode-class 'special)
-
;;;###autoload
(define-derived-mode todo-mode special-mode "Todo"
- "Major mode for displaying, navigating and editing todo lists.
-
-\\{todo-mode-map}"
+ "Major mode for displaying, navigating and editing todo lists."
(if (called-interactively-p 'any)
(message "%s"
(substitute-command-keys
@@ -6787,15 +6860,11 @@ Added to `window-configuration-change-hook' in Todo mode."
#'todo-reset-and-enable-done-separator nil t)
(add-hook 'kill-buffer-hook #'todo-reset-global-current-todo-file nil t)))
-(put 'todo-archive-mode 'mode-class 'special)
-
;; If todo-mode is parent, all todo-mode key bindings appear to be
;; available in todo-archive-mode (e.g. shown by C-h m).
;;;###autoload
(define-derived-mode todo-archive-mode special-mode "Todo-Arch"
- "Major mode for archived todo categories.
-
-\\{todo-archive-mode-map}"
+ "Major mode for archived todo categories."
(todo-modes-set-1)
(todo-modes-set-2)
(todo-modes-set-3)
@@ -6803,9 +6872,7 @@ Added to `window-configuration-change-hook' in Todo mode."
(setq-local todo-show-done-only t))
(define-derived-mode todo-edit-mode text-mode "Todo-Ed"
- "Major mode for editing multiline todo items.
-
-\\{todo-edit-mode-map}"
+ "Major mode for editing multiline todo items."
(todo-modes-set-1)
(setq-local indent-line-function #'todo-indent)
(if (> (buffer-size) (- (point-max) (point-min)))
@@ -6818,12 +6885,8 @@ Added to `window-configuration-change-hook' in Todo mode."
(setq-local todo-categories (todo-set-categories)))
(setq buffer-read-only nil))
-(put 'todo-categories-mode 'mode-class 'special)
-
(define-derived-mode todo-categories-mode special-mode "Todo-Cats"
- "Major mode for displaying and editing todo categories.
-
-\\{todo-categories-mode-map}"
+ "Major mode for displaying and editing todo categories."
(setq-local todo-current-todo-file todo-global-current-todo-file)
(setq-local todo-categories
;; Can't use find-buffer-visiting when
@@ -6834,13 +6897,9 @@ Added to `window-configuration-change-hook' in Todo mode."
todo-current-todo-file 'nowarn)
todo-categories)))
-(put 'todo-filtered-items-mode 'mode-class 'special)
-
;;;###autoload
(define-derived-mode todo-filtered-items-mode special-mode "Todo-Fltr"
- "Mode for displaying and reprioritizing top priority Todo.
-
-\\{todo-filtered-items-mode-map}"
+ "Mode for displaying and reprioritizing top priority Todo."
(todo-modes-set-1)
(todo-modes-set-2))
diff --git a/lisp/cedet/cedet-global.el b/lisp/cedet/cedet-global.el
index afe96c53fe7..3294a88d2c1 100644
--- a/lisp/cedet/cedet-global.el
+++ b/lisp/cedet/cedet-global.el
@@ -152,7 +152,14 @@ return nil."
nil)
(with-current-buffer b
(goto-char (point-min))
- (re-search-forward "(?GNU GLOBAL)? \\([0-9.]+\\)" nil t)
+ (re-search-forward
+ (rx (or
+ ;; global (Global) 6.6.10
+ "global (Global)"
+ (seq (opt "(") "GNU GLOBAL" (opt ")")))
+ " "
+ (group (one-or-more (any "0-9."))))
+ nil t)
(setq rev (match-string 1))
(if (version< rev cedet-global-min-version)
(if noerror
diff --git a/lisp/cedet/mode-local.el b/lisp/cedet/mode-local.el
index 053f06728b6..9f11b9707bd 100644
--- a/lisp/cedet/mode-local.el
+++ b/lisp/cedet/mode-local.el
@@ -1,6 +1,6 @@
;;; mode-local.el --- Support for mode local facilities -*- lexical-binding:t -*-
;;
-;; Copyright (C) 2004-2005, 2007-2024 Free Software Foundation, Inc.
+;; Copyright (C) 2004-2024 Free Software Foundation, Inc.
;;
;; Author: David Ponce <david@dponce.com>
;; Created: 27 Apr 2004
@@ -68,36 +68,23 @@ walk through. It defaults to `buffer-list'."
(when (or (not predicate) (funcall predicate))
(funcall function))))))
-(defsubst get-mode-local-parent (mode)
+(defun get-mode-local-parent (mode)
"Return the mode parent of the major mode MODE.
Return nil if MODE has no parent."
+ (declare (obsolete derived-mode-all-parents "30.1"))
(or (get mode 'mode-local-parent)
(get mode 'derived-mode-parent)))
-;; FIXME doc (and function name) seems wrong.
-;; Return a list of MODE and all its parent modes, if any.
-;; Lists parent modes first.
-(defun mode-local-equivalent-mode-p (mode)
- "Is the major-mode in the current buffer equivalent to a mode in MODES."
- (let ((modes nil))
- (while mode
- (setq modes (cons mode modes)
- mode (get-mode-local-parent mode)))
- modes))
+(define-obsolete-function-alias 'mode-local-equivalent-mode-p
+ #'derived-mode-all-parents "30.1")
(defun mode-local-map-mode-buffers (function modes)
"Run FUNCTION on every file buffer with major mode in MODES.
MODES can be a symbol or a list of symbols.
FUNCTION does not have arguments."
- (or (listp modes) (setq modes (list modes)))
+ (setq modes (ensure-list modes))
(mode-local-map-file-buffers
- function (lambda ()
- (let ((mm (mode-local-equivalent-mode-p major-mode))
- (ans nil))
- (while (and (not ans) mm)
- (setq ans (memq (car mm) modes)
- mm (cdr mm)) )
- ans))))
+ function (lambda () (derived-mode-p modes))))
;;; Hook machinery
;;
@@ -145,7 +132,8 @@ after changing the major mode."
"Set parent of major mode MODE to PARENT mode.
To work properly, this function should be called after PARENT mode
local variables have been defined."
- (put mode 'mode-local-parent parent)
+ (declare (obsolete derived-mode-add-parents "30.1"))
+ (derived-mode-add-parents mode (list parent))
;; Refresh mode bindings to get mode local variables inherited from
;; PARENT. To work properly, the following should be called after
;; PARENT mode local variables have been defined.
@@ -159,13 +147,8 @@ definition."
(declare (obsolete define-derived-mode "27.1") (indent 2))
`(mode-local--set-parent ',mode ',parent))
-(defun mode-local-use-bindings-p (this-mode desired-mode)
- "Return non-nil if THIS-MODE can use bindings of DESIRED-MODE."
- (let ((ans nil))
- (while (and (not ans) this-mode)
- (setq ans (eq this-mode desired-mode))
- (setq this-mode (get-mode-local-parent this-mode)))
- ans))
+(define-obsolete-function-alias 'mode-local-use-bindings-p
+ #'provided-mode-derived-p "30.1")
;;; Core bindings API
@@ -270,11 +253,13 @@ its parents."
(setq mode major-mode
bind (and mode-local-symbol-table
(intern-soft name mode-local-symbol-table))))
- (while (and mode (not bind))
- (or (and (get mode 'mode-local-symbol-table)
- (setq bind (intern-soft
- name (get mode 'mode-local-symbol-table))))
- (setq mode (get-mode-local-parent mode))))
+ (let ((parents (derived-mode-all-parents mode)))
+ (while (and parents (not bind))
+ (or (and (get (car parents) 'mode-local-symbol-table)
+ (setq bind (intern-soft
+ name (get (car parents)
+ 'mode-local-symbol-table))))
+ (setq parents (cdr parents)))))
bind))
(defsubst mode-local-symbol-value (symbol &optional mode property)
@@ -311,16 +296,12 @@ Elements are (SYMBOL . PREVIOUS-VALUE), describing one variable."
(mode-local-on-major-mode-change)
;; Do the normal thing.
- (let (modes table old-locals)
+ (let (table old-locals)
(unless mode
(setq-local mode-local--init-mode major-mode)
(setq mode major-mode))
- ;; Get MODE's parents & MODE in the right order.
- (while mode
- (setq modes (cons mode modes)
- mode (get-mode-local-parent mode)))
;; Activate mode bindings following parent modes order.
- (dolist (mode modes)
+ (dolist (mode (derived-mode-all-parents mode))
(when (setq table (get mode 'mode-local-symbol-table))
(mapatoms
(lambda (var)
@@ -345,14 +326,13 @@ If MODE is not specified it defaults to current `major-mode'."
(kill-local-variable 'mode-local--init-mode)
(setq mode major-mode))
(let (table)
- (while mode
+ (dolist (mode (derived-mode-all-parents mode))
(when (setq table (get mode 'mode-local-symbol-table))
(mapatoms
(lambda (var)
(when (get var 'mode-variable-flag)
(kill-local-variable (intern (symbol-name var)))))
- table))
- (setq mode (get-mode-local-parent mode)))))
+ table)))))
(defmacro with-mode-local-symbol (mode &rest body)
"With the local bindings of MODE symbol, evaluate BODY.
@@ -866,12 +846,11 @@ META-NAME is a cons (OVERLOADABLE-SYMBOL . MAJOR-MODE)."
(when table
(princ "\n- Buffer local\n")
(mode-local-print-bindings table))
- (while mode
+ (dolist (mode (derived-mode-all-parents mode))
(setq table (get mode 'mode-local-symbol-table))
(when table
(princ (format-message "\n- From `%s'\n" mode))
- (mode-local-print-bindings table))
- (setq mode (get-mode-local-parent mode)))))
+ (mode-local-print-bindings table)))))
(defun mode-local-describe-bindings-1 (buffer-or-mode &optional interactive-p)
"Display mode local bindings active in BUFFER-OR-MODE.
diff --git a/lisp/cedet/semantic.el b/lisp/cedet/semantic.el
index 47f807f12c3..3c3ae2ac160 100644
--- a/lisp/cedet/semantic.el
+++ b/lisp/cedet/semantic.el
@@ -618,21 +618,18 @@ Does nothing if the current buffer doesn't need reparsing."
(lexically-safe t)
)
- (unwind-protect
- ;; Perform the parsing.
- (progn
- (when (semantic-lex-catch-errors safe-refresh
- (save-excursion (semantic-fetch-tags))
- nil)
- ;; If we are here, it is because the lexical step failed,
- ;; probably due to unterminated lists or something like that.
-
- ;; We do nothing, and just wait for the next idle timer
- ;; to go off. In the meantime, remember this, and make sure
- ;; no other idle services can get executed.
- (setq lexically-safe nil))
- )
- )
+ ;; Perform the parsing.
+ (when (semantic-lex-catch-errors safe-refresh
+ (save-excursion (semantic-fetch-tags))
+ nil)
+ ;; If we are here, it is because the lexical step failed,
+ ;; probably due to unterminated lists or something like that.
+
+ ;; We do nothing, and just wait for the next idle timer
+ ;; to go off. In the meantime, remember this, and make sure
+ ;; no other idle services can get executed.
+ (setq lexically-safe nil))
+
;; Return if we are lexically safe
lexically-safe))))
diff --git a/lisp/cedet/semantic/complete.el b/lisp/cedet/semantic/complete.el
index 9dab73148c7..7adf9abfdcb 100644
--- a/lisp/cedet/semantic/complete.el
+++ b/lisp/cedet/semantic/complete.el
@@ -1731,7 +1731,7 @@ Display mechanism using tooltip for a list of possible completions.")
;; Add any tail info.
(setq msg (concat msg msg-tail))
;; Display tooltip.
- (when (not (eq msg ""))
+ (when (not (equal msg ""))
(semantic-displayer-tooltip-show msg)))))
;;; Compatibility
diff --git a/lisp/cedet/semantic/db-ebrowse.el b/lisp/cedet/semantic/db-ebrowse.el
index 657220c6455..3b387477850 100644
--- a/lisp/cedet/semantic/db-ebrowse.el
+++ b/lisp/cedet/semantic/db-ebrowse.el
@@ -158,7 +158,8 @@ is specified by `semanticdb-default-save-directory'."
;; Call the EBROWSE command.
(message "Creating ebrowse file: %s ..." savein)
(call-process-region (point-min) (point-max)
- "ebrowse" nil "*EBROWSE OUTPUT*" nil
+ ebrowse-program-name
+ nil "*EBROWSE OUTPUT*" nil
(concat "--output-file=" savein)
"--very-verbose")
)
diff --git a/lisp/cedet/semantic/db.el b/lisp/cedet/semantic/db.el
index 21ea4b86fb4..e4fbf28a64e 100644
--- a/lisp/cedet/semantic/db.el
+++ b/lisp/cedet/semantic/db.el
@@ -393,9 +393,7 @@ If a database for DIRECTORY has already been created, return it.
If DIRECTORY doesn't exist, create a new one."
(let ((db (semanticdb-directory-loaded-p directory)))
(unless db
- (setq db (semanticdb-project-database
- (file-name-nondirectory directory)
- :tables nil))
+ (setq db (semanticdb-project-database :tables nil))
;; Set this up here. We can't put it in the constructor because it
;; would be saved, and we want DB files to be portable.
(setf (slot-value db 'reference-directory) (file-truename directory)))
@@ -799,7 +797,7 @@ local variable."
(null (oref table major-mode))
;; nil means the same as major-mode
(and (not semantic-equivalent-major-modes)
- (mode-local-use-bindings-p major-mode (oref table major-mode)))
+ (provided-mode-derived-p major-mode (oref table major-mode)))
(and semantic-equivalent-major-modes
(member (oref table major-mode) semantic-equivalent-major-modes))
)
diff --git a/lisp/cedet/semantic/decorate/include.el b/lisp/cedet/semantic/decorate/include.el
index 0deb720c2c9..c4629b68bca 100644
--- a/lisp/cedet/semantic/decorate/include.el
+++ b/lisp/cedet/semantic/decorate/include.el
@@ -48,7 +48,7 @@
;;; Includes that are in a happy state!
;;
(defface semantic-decoration-on-includes
- nil
+ '((t (:inherit default)))
"Overlay Face used on includes that are not in some other state.
Used by the decoration style: `semantic-decoration-on-includes'."
:group 'semantic-faces)
@@ -790,9 +790,7 @@ any decorated referring includes.")
;; This is a hack. Add in something better?
(semanticdb-notify-references
table (lambda (tab _me)
- (semantic-decoration-unparsed-include-refrence-reset tab)
- ))
- ))
+ (semantic-decoration-unparsed-include-reference-reset tab)))))
(cl-defmethod semanticdb-partial-synchronize ((cache semantic-decoration-unparsed-include-cache)
new-tags)
@@ -805,7 +803,7 @@ any decorated referring includes.")
"Synchronize a CACHE with some NEW-TAGS."
(semantic-reset cache))
-(defun semantic-decoration-unparsed-include-refrence-reset (table)
+(defun semantic-decoration-unparsed-include-reference-reset (table)
"Refresh any highlighting in buffers referred to by TABLE.
If TABLE is not in a buffer, do nothing."
;; This cache removal may seem odd in that we are "creating one", but
@@ -835,6 +833,8 @@ If TABLE is not in a buffer, do nothing."
(semantic-decorate-add-decorations allinc)
))))
+(define-obsolete-function-alias 'semantic-decoration-unparsed-include-refrence-reset
+ #'semantic-decoration-unparsed-include-reference-reset "30.1")
(provide 'semantic/decorate/include)
diff --git a/lisp/cedet/semantic/fw.el b/lisp/cedet/semantic/fw.el
index 468c39ca3af..1a7af803a6b 100644
--- a/lisp/cedet/semantic/fw.el
+++ b/lisp/cedet/semantic/fw.el
@@ -434,9 +434,8 @@ FILE, NOWARN, RAWFILE, and WILDCARDS are passed into `find-file-noselect'."
;; ))
;; "Highlighted Semantic keywords.")
-;; (when (fboundp 'font-lock-add-keywords)
-;; (font-lock-add-keywords 'emacs-lisp-mode
-;; semantic-fw-font-lock-keywords))
+;; (font-lock-add-keywords 'emacs-lisp-mode
+;; semantic-fw-font-lock-keywords)
(provide 'semantic/fw)
diff --git a/lisp/cedet/semantic/grammar.el b/lisp/cedet/semantic/grammar.el
index 79a8ba863ff..54dc7807ef6 100644
--- a/lisp/cedet/semantic/grammar.el
+++ b/lisp/cedet/semantic/grammar.el
@@ -644,7 +644,7 @@ The symbols in the list are local variables in
(cond
(x (cdr x))
((symbolp S) (symbol-value S))))))
- template ""))
+ template))
(defun semantic-grammar-header ()
"Return text of a generated standard header."
@@ -1156,18 +1156,13 @@ END is the limit of the search."
("^\\(\\(\\sw\\|\\s_\\)+\\)[ \n\r\t]*:"
1 font-lock-function-name-face)
(semantic--grammar-macros-matcher
- 1 ,(if (boundp 'font-lock-builtin-face)
- 'font-lock-builtin-face
- 'font-lock-preprocessor-face))
+ 1 font-lock-builtin-face)
("\\$\\(\\sw\\|\\s_\\)*"
0 font-lock-variable-name-face)
("<\\(\\(\\sw\\|\\s_\\)+\\)>"
1 font-lock-type-face)
(,semantic-grammar-lex-c-char-re
- 0 ,(if (boundp 'font-lock-constant-face)
- 'font-lock-constant-face
- 'font-lock-string-face)
- t)
+ 0 font-lock-constant-face t)
;; Must highlight :keyword here, because ':' is a punctuation in
;; grammar mode!
("[\r\n\t ]+:\\sw+\\>"
diff --git a/lisp/cedet/semantic/imenu.el b/lisp/cedet/semantic/imenu.el
index e55368b3706..e13eec209ed 100644
--- a/lisp/cedet/semantic/imenu.el
+++ b/lisp/cedet/semantic/imenu.el
@@ -32,6 +32,8 @@
;; (setq imenu-create-index-function 'semantic-create-imenu-index)
;; ))
+;;; Code:
+
(require 'semantic)
(require 'semantic/format)
(require 'semantic/db)
@@ -134,7 +136,6 @@ Tags of those classes will be given submenu with children.
By default, a `type' has interesting children. In Texinfo, however, a
`section' has interesting children.")
-;;; Code:
(defun semantic-imenu-tag-overlay (tag)
"Return the overlay belonging to tag.
If TAG doesn't have an overlay, and instead as a vector of positions,
@@ -469,9 +470,8 @@ Clears all imenu menus that may be depending on the database."
;; buffer, there is a much more efficient way of doing this.
;; Advise `which-function' so that we optionally use semantic tags
;; instead, and get better stuff.
-(require 'advice)
-(defvar semantic-which-function 'semantic-default-which-function
+(defvar semantic-which-function #'semantic-default-which-function
"Function to convert semantic tags into `which-function' text.")
(defcustom semantic-which-function-use-color nil
diff --git a/lisp/cedet/semantic/lex-spp.el b/lisp/cedet/semantic/lex-spp.el
index aa1bc8e5af2..f63d316c1ac 100644
--- a/lisp/cedet/semantic/lex-spp.el
+++ b/lisp/cedet/semantic/lex-spp.el
@@ -153,13 +153,13 @@ The search priority is:
"Return the dynamic macro map for the current buffer."
(or semantic-lex-spp-dynamic-macro-symbol-obarray
(setq semantic-lex-spp-dynamic-macro-symbol-obarray
- (make-vector 13 0))))
+ (obarray-make 13))))
(defsubst semantic-lex-spp-dynamic-map-stack ()
"Return the dynamic macro map for the current buffer."
(or semantic-lex-spp-dynamic-macro-symbol-obarray-stack
(setq semantic-lex-spp-dynamic-macro-symbol-obarray-stack
- (make-vector 13 0))))
+ (obarray-make 13))))
(defun semantic-lex-spp-value-valid-p (value)
"Return non-nil if VALUE is valid."
@@ -260,7 +260,7 @@ NAME is the name of the spp macro symbol to define.
REPLACEMENT a string that would be substituted in for NAME."
;; Create the symbol hash table
- (let ((semantic-lex-spp-macro-symbol-obarray (make-vector 13 0))
+ (let ((semantic-lex-spp-macro-symbol-obarray (obarray-make 13))
spec)
;; fill it with stuff
(while specs
@@ -434,8 +434,7 @@ continue processing recursively."
(symbolp (car (car val))))
(mapconcat (lambda (subtok)
(semantic-lex-spp-one-token-to-txt subtok))
- val
- ""))
+ val))
;; If val is nil, that's probably wrong.
;; Found a system header case where this was true.
((null val) "")
@@ -699,8 +698,7 @@ be merged recursively."
(message "Invalid merge macro encountered; \
will return empty string instead.")
"")))
- txt
- ""))
+ txt))
(defun semantic-lex-spp-find-closing-macro ()
"Find next macro which closes a scope through a close-paren.
@@ -1243,7 +1241,7 @@ Finds the header file belonging to NAME, gets the macros
from that file, and then merge the macros with our current
symbol table."
(when semantic-lex-spp-use-headers-flag
- ;; @todo - do this someday, ok?
+ nil ; @todo - do this someday, ok?
))
(defmacro define-lex-spp-include-analyzer (name doc regexp tokidx
diff --git a/lisp/cedet/semantic/lex.el b/lisp/cedet/semantic/lex.el
index 9047dfcd281..f3d671ac312 100644
--- a/lisp/cedet/semantic/lex.el
+++ b/lisp/cedet/semantic/lex.el
@@ -259,7 +259,7 @@ If optional argument PROPSPECS is non-nil, then interpret it, and
apply those properties.
PROPSPECS must be a list of (NAME PROPERTY VALUE) elements."
;; Create the symbol hash table
- (let ((semantic-flex-keywords-obarray (make-vector 13 0))
+ (let ((semantic-flex-keywords-obarray (obarray-make 13))
spec)
;; fill it with stuff
(while specs
@@ -416,7 +416,7 @@ If optional argument PROPSPECS is non-nil, then interpret it, and
apply those properties.
PROPSPECS must be a list of (TYPE PROPERTY VALUE)."
;; Create the symbol hash table
- (let* ((semantic-lex-types-obarray (make-vector 13 0))
+ (let* ((semantic-lex-types-obarray (obarray-make 13))
spec type tokens token alist default)
;; fill it with stuff
(while specs
@@ -1108,7 +1108,7 @@ This can be done by using `semantic-lex-push-token'."
(semantic-lex-analysis-bounds (cons (point) (point-max)))
(semantic-lex-current-depth 0)
(semantic-lex-maximum-depth semantic-lex-depth))
- (when ,condition ,@forms)
+ (when ,condition nil ,@forms) ; `nil' avoids an empty-body warning.
semantic-lex-token-stream))))
(defmacro define-lex-regex-analyzer (name doc regexp &rest forms)
diff --git a/lisp/cedet/semantic/symref/grep.el b/lisp/cedet/semantic/symref/grep.el
index 83e3bc36073..cc4d1546c85 100644
--- a/lisp/cedet/semantic/symref/grep.el
+++ b/lisp/cedet/semantic/symref/grep.el
@@ -44,9 +44,7 @@ those hits returned.")
(defvar semantic-symref-filepattern-alist
'((c-mode "*.[ch]")
- (c-ts-mode "*.[ch]")
(c++-mode "*.[chCH]" "*.[ch]pp" "*.cc" "*.hh")
- (c++-ts-mode "*.[chCH]" "*.[ch]pp" "*.cc" "*.hh")
(html-mode "*.html" "*.shtml" "*.php")
(mhtml-mode "*.html" "*.shtml" "*.php") ; FIXME: remove
; duplication of
@@ -55,12 +53,8 @@ those hits returned.")
; major mode definition?
(ruby-mode "*.r[bu]" "*.rake" "*.gemspec" "*.erb" "*.haml"
"Rakefile" "Thorfile" "Capfile" "Guardfile" "Vagrantfile")
- (ruby-ts-mode "*.r[bu]" "*.rake" "*.gemspec" "*.erb" "*.haml"
- "Rakefile" "Thorfile" "Capfile" "Guardfile" "Vagrantfile")
(python-mode "*.py" "*.pyi" "*.pyw")
- (python-ts-mode "*.py" "*.pyi" "*.pyw")
(perl-mode "*.pl" "*.PL")
- (cperl-mode "*.pl" "*.PL")
(lisp-interaction-mode "*.el" "*.ede" ".emacs" "_emacs")
)
"List of major modes and file extension pattern.
diff --git a/lisp/cedet/semantic/tag.el b/lisp/cedet/semantic/tag.el
index 18a0b4caee2..a0843dd5df9 100644
--- a/lisp/cedet/semantic/tag.el
+++ b/lisp/cedet/semantic/tag.el
@@ -349,6 +349,9 @@ If TAG is unlinked, but has a :filename property, then that is used."
;; If an error occurs, then it most certainly is not a tag.
(error nil)))
+;; Used in `semantic-utest-ia.el'.
+(cl-deftype semantic-tag () `(satisfies semantic-tag-p))
+
(defsubst semantic-tag-of-class-p (tag class)
"Return non-nil if class of TAG is CLASS."
(eq (semantic-tag-class tag) class))
diff --git a/lisp/cedet/semantic/wisent/python.el b/lisp/cedet/semantic/wisent/python.el
index 43632261859..73f08beaa28 100644
--- a/lisp/cedet/semantic/wisent/python.el
+++ b/lisp/cedet/semantic/wisent/python.el
@@ -262,18 +262,19 @@ the indentation of the current line."
;; Loop lexer to handle tokens in current line.
t)
;; Indentation decreased
- ((progn
- ;; Pop items from indentation stack
- (while (< curr-indent last-indent)
- (pop wisent-python-indent-stack)
- (setq semantic-lex-current-depth (1- semantic-lex-current-depth)
- last-indent (car wisent-python-indent-stack))
- (semantic-lex-push-token
- (semantic-lex-token 'DEDENT last-pos (point))))
- (= last-pos (point)))
- ;; If pos did not change, then we must return nil so that
- ;; other lexical analyzers can be run.
- nil))))
+ (t
+ ;; Pop items from indentation stack
+ (while (< curr-indent last-indent)
+ (pop wisent-python-indent-stack)
+ (setq semantic-lex-current-depth (1- semantic-lex-current-depth)
+ last-indent (car wisent-python-indent-stack))
+ (semantic-lex-push-token
+ (semantic-lex-token 'DEDENT last-pos (point))))
+ ;; (if (= last-pos (point))
+ ;; ;; If pos did not change, then we must return nil so that
+ ;; ;; other lexical analyzers can be run.
+ ;; nil)
+ ))))
;; All the work was done in the above analyzer matching condition.
)
diff --git a/lisp/cedet/srecode/find.el b/lisp/cedet/srecode/find.el
index 5588c472c1f..41030aa6944 100644
--- a/lisp/cedet/srecode/find.el
+++ b/lisp/cedet/srecode/find.el
@@ -34,12 +34,12 @@
(defun srecode-table (&optional mode)
"Return the currently active Semantic Recoder table for this buffer.
Optional argument MODE specifies the mode table to use."
- (let* ((modeq (or mode major-mode))
- (table (srecode-get-mode-table modeq)))
+ (let ((modes (derived-mode-all-parents (or mode major-mode)))
+ (table nil))
;; If there isn't one, keep searching backwards for a table.
- (while (and (not table) (setq modeq (get-mode-local-parent modeq)))
- (setq table (srecode-get-mode-table modeq)))
+ (while (and modes (not (setq table (srecode-get-mode-table (car modes)))))
+ (setq modes (cdr modes)))
;; Last ditch effort.
(when (not table)
@@ -57,35 +57,23 @@ Templates are found in the SRecode Template Map.
See `srecode-get-maps' for more.
APPNAME is the name of an application. In this case,
all template files for that application will be loaded."
- (let ((files
- (apply #'append
- (mapcar
- (if appname
+ (dolist (mmode (cons 'default (reverse (derived-mode-all-parents mmode))))
+ (let ((files
+ (apply #'append
+ (mapcar
+ (if appname
+ (lambda (map)
+ (srecode-map-entries-for-app-and-mode map appname mmode))
(lambda (map)
- (srecode-map-entries-for-app-and-mode map appname mmode))
- (lambda (map)
- (srecode-map-entries-for-mode map mmode)))
- (srecode-get-maps))))
- )
- ;; Don't recurse if we are already the 'default state.
- (when (not (eq mmode 'default))
- ;; Are we a derived mode? If so, get the parent mode's
- ;; templates loaded too.
- (if (get-mode-local-parent mmode)
- (srecode-load-tables-for-mode (get-mode-local-parent mmode)
- appname)
- ;; No parent mode, all templates depend on the defaults being
- ;; loaded in, so get that in instead.
- (srecode-load-tables-for-mode 'default appname)))
+ (srecode-map-entries-for-mode map mmode)))
+ (srecode-get-maps)))))
- ;; Load in templates for our major mode.
- (dolist (f files)
- (let ((mt (srecode-get-mode-table mmode))
- )
- (when (or (not mt) (not (srecode-mode-table-find mt (car f))))
- (srecode-compile-file (car f)))
- ))
- ))
+ ;; Load in templates for our major mode.
+ (when files
+ (let ((mt (srecode-get-mode-table mmode)))
+ (dolist (f files)
+ (when (not (and mt (srecode-mode-table-find mt (car f))))
+ (srecode-compile-file (car f)))))))))
;;; PROJECT
;;
@@ -227,12 +215,12 @@ Optional argument MODE is the major mode to look for.
Optional argument HASH is the hash table to fill in.
Optional argument PREDICATE can be used to filter the returned
templates."
- (let* ((mhash (or hash (make-hash-table :test 'equal)))
- (mmode (or mode major-mode))
- (parent-mode (get-mode-local-parent mmode)))
- ;; Get the parent hash table filled into our current hash.
- (unless (eq mode 'default)
- (srecode-all-template-hash (or parent-mode 'default) mhash))
+ (let* ((mhash (or hash (make-hash-table :test 'equal))))
+ (dolist (mmode (cons 'default
+ ;; Get the parent hash table filled into our
+ ;; current hash.
+ (reverse (derived-mode-all-parents
+ (or mode major-mode)))))
;; Load up the hash table for our current mode.
(let* ((mt (srecode-get-mode-table mmode))
@@ -246,7 +234,7 @@ templates."
(funcall predicate temp))
(puthash key temp mhash)))
(oref tab namehash))))
- mhash)))
+ mhash))))
(defun srecode-calculate-default-template-string (hash)
"Calculate the name of the template to use as a DEFAULT.
diff --git a/lisp/cedet/srecode/map.el b/lisp/cedet/srecode/map.el
index deec604c94b..30f4c755e17 100644
--- a/lisp/cedet/srecode/map.el
+++ b/lisp/cedet/srecode/map.el
@@ -76,7 +76,7 @@ Each app keys to an alist of files and modes (as above.)")
"Return the entries in MAP for major MODE."
(let ((ans nil))
(dolist (f (oref map files))
- (when (mode-local-use-bindings-p mode (cdr f))
+ (when (provided-mode-derived-p mode (cdr f))
(setq ans (cons f ans))))
ans))
diff --git a/lisp/cedet/srecode/table.el b/lisp/cedet/srecode/table.el
index b33466138fe..8ac26c9bf01 100644
--- a/lisp/cedet/srecode/table.el
+++ b/lisp/cedet/srecode/table.el
@@ -137,41 +137,36 @@ Tracks all the template-tables for a specific major mode.")
"Get the SRecoder mode table for the major mode MODE.
This will find the mode table specific to MODE, and then
calculate all inherited templates from parent modes."
- (let ((table nil)
- (tmptable nil))
- (while mode
- (setq tmptable (eieio-instance-tracker-find
- mode 'major-mode 'srecode-mode-table-list)
- mode (get-mode-local-parent mode))
- (when tmptable
- (if (not table)
- (progn
- ;; If this is the first, update tables to have
- ;; all the mode specific tables in it.
- (setq table tmptable)
- (oset table tables (oref table modetables)))
- ;; If there already is a table, then reset the tables
- ;; slot to include all the tables belonging to this new child node.
- (oset table tables (append (oref table modetables)
- (oref tmptable modetables)))))
- )
+ (let ((table nil))
+ (dolist (mode (derived-mode-all-parents mode))
+ (let ((tmptable (eieio-instance-tracker-find
+ mode 'major-mode 'srecode-mode-table-list)))
+ (when tmptable
+ (if (not table)
+ (progn
+ ;; If this is the first, update tables to have
+ ;; all the mode specific tables in it.
+ (setq table tmptable)
+ (oset table tables (oref table modetables)))
+ ;; If there already is a table, then reset the tables
+ ;; slot to include all the tables belonging to this new child node.
+ (oset table tables (append (oref table modetables)
+ (oref tmptable modetables)))))
+ ))
table))
(defun srecode-make-mode-table (mode)
"Get the SRecoder mode table for the major mode MODE."
(let ((old (eieio-instance-tracker-find
mode 'major-mode 'srecode-mode-table-list)))
- (if old
- old
- (let* ((ms (if (stringp mode) mode (symbol-name mode)))
- (new (srecode-mode-table ms
- :major-mode mode
- :modetables nil
- :tables nil)))
- ;; Save this new mode table in that mode's variable.
- (eval `(setq-mode-local ,mode srecode-table ,new) t)
+ (or old
+ (let* ((new (srecode-mode-table :major-mode mode
+ :modetables nil
+ :tables nil)))
+ ;; Save this new mode table in that mode's variable.
+ (eval `(setq-mode-local ,mode srecode-table ,new) t)
- new))))
+ new))))
(cl-defmethod srecode-mode-table-find ((mt srecode-mode-table) file)
"Look in the mode table MT for a template table from FILE.
diff --git a/lisp/char-fold.el b/lisp/char-fold.el
index a620d4d8dc3..4d9644216d8 100644
--- a/lisp/char-fold.el
+++ b/lisp/char-fold.el
@@ -214,7 +214,7 @@
equiv))
equiv)))
-(defconst char-fold-table
+(defvar char-fold-table
(eval-when-compile
(char-fold--make-table))
"Used for folding characters of the same group during search.
diff --git a/lisp/comint.el b/lisp/comint.el
index 2c0102ef3c9..a8fe095e99c 100644
--- a/lisp/comint.el
+++ b/lisp/comint.el
@@ -254,10 +254,40 @@ This variable is buffer-local."
See also `comint-read-input-ring' and `comint-write-input-ring'.
`comint-mode' makes this a buffer-local variable. You probably want
to set this in a mode hook, rather than customize the default value."
- :type '(choice (const :tag "nil" nil)
+ :type '(choice (const :tag "Disable input history" nil)
file)
:group 'comint)
+(defcustom comint-pager nil
+ "If non-nil, the program to use for pagination of program output.
+If nil, use the default pager.
+
+Some programs produce large amounts of output, and have provision for
+pagination of their output through a filter program, commonly known as
+a \"pager\". The pager limits the amount of output produced and
+allows the user to interactively browse the output one page at a time.
+Some programs paginate their output by default, by always starting a
+pager. The program they use as the pager is specified by the
+environment variable PAGER; if that variable is not defined, they use
+some fixed default, such as \"less\".
+
+The interactive browsing aspects of pagination are not needed, and get
+in the way, when the output of the program is directed to an Emacs
+buffer, so in those cases pagination might need to be disabled.
+Disabling pagination means that some programs will produce large
+amounts of output, but most such programs have other ways to limit
+their output, such as additional arguments or Emacs interfaces.
+To disable pagination, this variable's value should be a string that
+names a program, such as \"cat\", which passes through all of the
+output without any filtering or delays. Comint will then set the
+PAGER variable to name that program, when it invokes external
+programs."
+ :version "30.1"
+ :type '(choice (const :tag "Use default PAGER" nil)
+ (const :tag "Don't do paging (PAGER=cat)" "cat")
+ (string :tag "Program name or absolute path of pager"))
+ :group 'comint)
+
(defvar comint-input-ring-file-prefix nil
"The prefix to skip when parsing the input ring file.
This is useful in Zsh when the extended_history option is on.")
@@ -383,7 +413,8 @@ This variable is buffer-local."
"\\(?:" (regexp-opt password-word-equivalents) "\\|Response\\)"
"\\(?:\\(?:, try\\)? *again\\| (empty for no passphrase)\\| (again)\\)?"
;; "[[:alpha:]]" used to be "for", which fails to match non-English.
- "\\(?: [[:alpha:]]+ .+\\)?[[:blank:]]*[::៖][[:space:]]*\\'"
+ "\\(?: [[:alpha:]]+ .+\\)?[[:blank:]]*"
+ "[" (apply #'string password-colon-equivalents) "][[:space:]]*\\'"
;; The ccrypt encryption dialog doesn't end with a colon, so
;; treat it specially.
"\\|^Enter encryption key: (repeat) *\\'"
@@ -693,6 +724,9 @@ Entry to this mode runs the hooks on `comint-mode-hook'."
(setq-local comint-last-input-start (point-min-marker))
(setq-local comint-last-input-end (point-min-marker))
(setq-local comint-last-output-start (make-marker))
+ ;; It is ok to let the input method edit prompt text, but RET must
+ ;; be processed by Emacs.
+ (setq text-conversion-style 'action)
(make-local-variable 'comint-last-prompt)
(make-local-variable 'comint-prompt-regexp) ; Don't set; default
(make-local-variable 'comint-input-ring-size) ; ...to global val.
@@ -864,6 +898,10 @@ series of processes in the same Comint buffer. The hook
(nconc
(comint-term-environment)
(list (format "INSIDE_EMACS=%s,comint" emacs-version))
+ (when comint-pager
+ (if (stringp comint-pager)
+ (list (format "PAGER=%s" comint-pager))
+ (error "comint-pager should be a string: %s" comint-pager)))
process-environment))
(default-directory
(if (file-accessible-directory-p default-directory)
@@ -1403,7 +1441,7 @@ actual side-effect."
(if dry-run (throw dry-run 'message))
(goto-char (match-end 0))
(message "Absolute reference cannot be expanded"))
- ((looking-at "!-\\([0-9]+\\)\\(:?[0-9^$*-]+\\)?")
+ ((looking-at "!-\\([0-9]+\\):?\\([0-9^$*-]+\\)?")
;; Just a number of args from `number' lines backward.
(if dry-run (throw dry-run 'history))
(let ((number (1- (string-to-number
@@ -1427,7 +1465,7 @@ actual side-effect."
t t)
(message "History item: previous"))
((looking-at
- "!\\??\\({\\(.+\\)}\\|\\(\\sw+\\)\\)\\(:?[0-9^$*-]+\\)?")
+ "!\\??\\({\\(.+\\)}\\|\\(\\sw+\\)\\):?\\([0-9^$*-]+\\)?")
;; Most recent input starting with or containing (possibly
;; protected) string, maybe just a number of args. Phew.
(if dry-run (throw dry-run 'expand))
@@ -2772,7 +2810,7 @@ If N is negative, find the previous or Nth previous match."
If `comint-use-prompt-regexp' is nil, then this means the beginning of
the Nth next `input' field, otherwise, it means the Nth occurrence of
text matching `comint-prompt-regexp'."
- (interactive "p")
+ (interactive "^p")
(if comint-use-prompt-regexp
;; Use comint-prompt-regexp
(let ((paragraph-start comint-prompt-regexp))
@@ -2809,7 +2847,7 @@ text matching `comint-prompt-regexp'."
If `comint-use-prompt-regexp' is nil, then this means the beginning of
the Nth previous `input' field, otherwise, it means the Nth occurrence of
text matching `comint-prompt-regexp'."
- (interactive "p")
+ (interactive "^p")
(comint-next-prompt (- n)))
;; State used by `comint-insert-previous-argument' when cycling.
@@ -2820,7 +2858,7 @@ text matching `comint-prompt-regexp'."
"If non-nil, `comint-insert-previous-argument' counts args from the end.
If this variable is nil, the default, `comint-insert-previous-argument'
counts the arguments from the beginning; if non-nil, it counts from
-the end instead. This allows to emulate the behavior of `ESC-NUM ESC-.'
+the end instead. This emulates the behavior of `ESC-NUM ESC-.'
in both Bash and zsh: in Bash, `number' counts from the
beginning (variable is nil), while in zsh, it counts from the end."
:type 'boolean
@@ -3472,7 +3510,7 @@ the completions."
;; Read the next key, to process SPC.
(let (key first)
- (if (with-current-buffer (get-buffer "*Completions*")
+ (if (with-current-buffer "*Completions*"
(setq-local comint-displayed-dynamic-completions
completions)
(setq key (read-key-sequence nil)
@@ -4121,9 +4159,15 @@ function called, or nil, if no function was called (if BEG = END)."
(save-restriction
(let ((beg2 beg1)
(end2 end1))
- (when (= beg2 beg)
+ (when (and (= beg2 beg)
+ (> beg2 (point-min))
+ (eq is-output
+ (eq (get-text-property (1- beg2) 'field) 'output)))
(setq beg2 (field-beginning beg2)))
- (when (= end2 end)
+ (when (and (= end2 end)
+ (< end2 (point-max))
+ (eq is-output
+ (eq (get-text-property (1+ end2) 'field) 'output)))
(setq end2 (field-end end2)))
;; Narrow to the whole field surrounding the region
(narrow-to-region beg2 end2))
diff --git a/lisp/completion-preview.el b/lisp/completion-preview.el
new file mode 100644
index 00000000000..e827da43a08
--- /dev/null
+++ b/lisp/completion-preview.el
@@ -0,0 +1,419 @@
+;;; completion-preview.el --- Preview completion with inline overlay -*- lexical-binding: t; -*-
+
+;; Copyright (C) 2023-2024 Free Software Foundation, Inc.
+
+;; Author: Eshel Yaron <me@eshelyaron.com>
+;; Maintainer: Eshel Yaron <me@eshelyaron.com>
+;; Keywords: abbrev convenience
+
+;; This program is free software; you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+
+;; This program is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with this program. If not, see <https://www.gnu.org/licenses/>.
+
+;;; Commentary:
+
+;; This library provides the Completion Preview mode. This minor mode
+;; displays a completion suggestion for the symbol at point in an
+;; overlay after point. Check out the customization group
+;; `completion-preview' for user options that you may want to tweak.
+;;
+;; To enable Completion Preview mode, use `completion-preview-mode'.
+;; To accept the completion suggestion, press TAB. If you want to
+;; ignore a completion suggestion, just go on editing or moving around
+;; the buffer. Completion Preview mode continues to update the
+;; suggestion as you type according to the text around point.
+;;
+;; The commands `completion-preview-next-candidate' and
+;; `completion-preview-prev-candidate' allow you to cycle the
+;; completion candidate that the preview suggests. These commands
+;; don't have a default keybinding, but you can bind them, for
+;; example, to M-n and M-p in `completion-preview-active-mode-map' to
+;; have them handy whenever the preview is visible.
+;;
+;; If you set the user option `completion-preview-exact-match-only' to
+;; non-nil, Completion Preview mode only suggests a completion
+;; candidate when its the only possible completion for the (partial)
+;; symbol at point. The user option `completion-preview-commands'
+;; says which commands should trigger the completion preview. The
+;; user option `completion-preview-minimum-symbol-length' specifies a
+;; minimum number of consecutive characters with word or symbol syntax
+;; that should appear around point for Emacs to suggest a completion.
+;; By default, this option is set to 3, so Emacs suggests a completion
+;; if you type "foo", but typing just "fo" doesn't show the preview.
+
+;;; Code:
+
+(require 'mwheel)
+
+(defgroup completion-preview nil
+ "In-buffer completion preview."
+ :group 'completion)
+
+(defcustom completion-preview-exact-match-only nil
+ "Whether to show completion preview only when there is an exact match.
+
+If this option is non-nil, Completion Preview mode only shows the
+preview when there is exactly one completion candidate that
+matches the symbol at point. Otherwise, if this option is nil,
+when there are multiple matching candidates the preview shows the
+first candidate, and you can cycle between the candidates with
+\\[completion-preview-next-candidate] and
+\\[completion-preview-prev-candidate]."
+ :type 'boolean
+ :version "30.1")
+
+(defcustom completion-preview-commands '(self-insert-command
+ insert-char
+ delete-backward-char
+ backward-delete-char-untabify
+ analyze-text-conversion)
+ "List of commands that should trigger completion preview."
+ :type '(repeat (function :tag "Command" :value self-insert-command))
+ :version "30.1")
+
+(defcustom completion-preview-minimum-symbol-length 3
+ "Minimum length of the symbol at point for showing completion preview."
+ :type 'natnum
+ :version "30.1")
+
+(defcustom completion-preview-message-format
+ "Completion suggestion %i out of %n"
+ "Message to show after cycling the completion preview suggestion.
+
+If the value is a string, `completion-preview-next-candidate' and
+`completion-preview-prev-candidate' display this string in the
+echo area, after substituting \"%i\" with the 1-based index of
+the completion suggestion that the preview is showing, and \"%n\"
+with the total number of available completion suggestions for the
+text around point.
+
+If this option is nil, these commands do not display any message."
+ :type '(choice (string :tag "Message format")
+ (const :tag "No message" nil))
+ :version "30.1")
+
+(defvar completion-preview-sort-function #'minibuffer--sort-by-length-alpha
+ "Sort function to use for choosing a completion candidate to preview.")
+
+(defface completion-preview
+ '((t :inherit shadow))
+ "Face for completion preview overlay."
+ :version "30.1")
+
+(defface completion-preview-exact
+ '((((supports :underline t))
+ :underline t :inherit completion-preview)
+ (((supports :weight bold))
+ :weight bold :inherit completion-preview)
+ (t :background "gray"))
+ "Face for exact completion preview overlay."
+ :version "30.1")
+
+(defface completion-preview-highlight
+ '((t :inherit highlight))
+ "Face for highlighting the completion preview when the mouse is over it."
+ :version "30.1")
+
+(defvar-keymap completion-preview-active-mode-map
+ :doc "Keymap for Completion Preview Active mode."
+ "C-i" #'completion-preview-insert
+ ;; "M-n" #'completion-preview-next-candidate
+ ;; "M-p" #'completion-preview-prev-candidate
+ )
+
+(defvar-keymap completion-preview--mouse-map
+ :doc "Keymap for mouse clicks on the completion preview."
+ "<down-mouse-1>" #'completion-preview-insert
+ "C-<down-mouse-1>" #'completion-at-point
+ "<down-mouse-2>" #'completion-at-point
+ ;; BEWARE: `mouse-wheel-UP-event' corresponds to `wheel-DOWN' events
+ ;; and vice versa!!
+ "<wheel-up>" #'completion-preview-prev-candidate
+ "<wheel-down>" #'completion-preview-next-candidate
+ (key-description (vector mouse-wheel-up-event))
+ #'completion-preview-next-candidate
+ (key-description (vector mouse-wheel-down-event))
+ #'completion-preview-prev-candidate)
+
+(defvar-local completion-preview--overlay nil)
+
+(defvar completion-preview--internal-commands
+ '(completion-preview-next-candidate
+ completion-preview-prev-candidate
+ ;; Don't dismiss or update the preview when the user scrolls.
+ mwheel-scroll)
+ "List of commands that manipulate the completion preview.
+
+Completion Preview mode avoids updating the preview after these commands.")
+
+(defsubst completion-preview--internal-command-p ()
+ "Return non-nil if `this-command' manipulates the completion preview."
+ (memq this-command completion-preview--internal-commands))
+
+(defsubst completion-preview-require-certain-commands ()
+ "Check if `this-command' is one of `completion-preview-commands'."
+ (or (completion-preview--internal-command-p)
+ (memq this-command completion-preview-commands)))
+
+(defun completion-preview-require-minimum-symbol-length ()
+ "Check if the length of symbol at point is at least above a certain threshold.
+`completion-preview-minimum-symbol-length' determines that threshold."
+ (let ((bounds (bounds-of-thing-at-point 'symbol)))
+ (and bounds (<= completion-preview-minimum-symbol-length
+ (- (cdr bounds) (car bounds))))))
+
+(defun completion-preview-hide ()
+ "Hide the completion preview."
+ (when completion-preview--overlay
+ (delete-overlay completion-preview--overlay)
+ (setq completion-preview--overlay nil)))
+
+(defun completion-preview--make-overlay (pos string)
+ "Make preview overlay showing STRING at POS, or move existing preview there."
+ (if completion-preview--overlay
+ (move-overlay completion-preview--overlay pos pos)
+ (setq completion-preview--overlay (make-overlay pos pos))
+ (overlay-put completion-preview--overlay 'window (selected-window)))
+ (let ((previous (overlay-get completion-preview--overlay 'after-string)))
+ (unless (and previous (string= previous string)
+ (eq (get-text-property 0 'face previous)
+ (get-text-property 0 'face string)))
+ (add-text-properties 0 1 '(cursor 1) string)
+ (overlay-put completion-preview--overlay 'after-string string))
+ completion-preview--overlay))
+
+(defsubst completion-preview--get (prop)
+ "Return property PROP of the completion preview overlay."
+ (overlay-get completion-preview--overlay prop))
+
+(defun completion-preview--window-selection-change (window)
+ "Hide completion preview in WINDOW after switching to another window.
+Completion Preview mode adds this function to
+`window-selection-change-functions', which see."
+ (unless (or (eq window (selected-window))
+ (eq window (minibuffer-selected-window)))
+ (with-current-buffer (window-buffer window)
+ (completion-preview-active-mode -1))))
+
+(define-minor-mode completion-preview-active-mode
+ "Mode for when the completion preview is shown."
+ :interactive nil
+ (if completion-preview-active-mode
+ (add-hook 'window-selection-change-functions
+ #'completion-preview--window-selection-change nil t)
+ (remove-hook 'window-selection-change-functions
+ #'completion-preview--window-selection-change t)
+ (completion-preview-hide)))
+
+(defun completion-preview--try-table (table beg end props)
+ "Check TABLE for a completion matching the text between BEG and END.
+
+PROPS is a property list with additional information about TABLE.
+See `completion-at-point-functions' for more details.
+
+If TABLE contains a matching completion, return a list
+\(PREVIEW BEG END ALL BASE EXIT-FN) where PREVIEW is the text to
+show in the completion preview, ALL is the list of all matching
+completion candidates, BASE is a common prefix that TABLE elided
+from the start of each candidate, and EXIT-FN is either a
+function to call after inserting PREVIEW or nil. If TABLE does
+not contain matching completions, or if there are multiple
+matching completions and `completion-preview-exact-match-only' is
+non-nil, return nil instead."
+ (let* ((pred (plist-get props :predicate))
+ (exit-fn (plist-get props :exit-function))
+ (string (buffer-substring beg end))
+ (md (completion-metadata string table pred))
+ (sort-fn (or (completion-metadata-get md 'cycle-sort-function)
+ (completion-metadata-get md 'display-sort-function)
+ completion-preview-sort-function))
+ (all (let ((completion-lazy-hilit t))
+ (completion-all-completions string table pred
+ (- (point) beg) md)))
+ (last (last all))
+ (base (or (cdr last) 0))
+ (prefix (substring string base)))
+ (when last
+ (setcdr last nil)
+ (when-let ((sorted (funcall sort-fn
+ (delete prefix (all-completions prefix all)))))
+ (unless (and (cdr sorted) completion-preview-exact-match-only)
+ (list (propertize (substring (car sorted) (length prefix))
+ 'face (if (cdr sorted)
+ 'completion-preview
+ 'completion-preview-exact)
+ 'mouse-face 'completion-preview-highlight
+ 'keymap completion-preview--mouse-map)
+ (+ beg base) end sorted
+ (substring string 0 base) exit-fn))))))
+
+(defun completion-preview--capf-wrapper (capf)
+ "Translate return value of CAPF to properties for completion preview overlay."
+ (let ((res (ignore-errors (funcall capf))))
+ (and (consp res)
+ (not (functionp res))
+ (seq-let (beg end table &rest plist) res
+ (or (completion-preview--try-table table beg end plist)
+ (unless (eq 'no (plist-get plist :exclusive))
+ ;; Return non-nil to exclude other capfs.
+ '(nil)))))))
+
+(defun completion-preview--update ()
+ "Update completion preview."
+ (seq-let (preview beg end all base exit-fn)
+ (run-hook-wrapped
+ 'completion-at-point-functions
+ #'completion-preview--capf-wrapper)
+ (when preview
+ (let ((ov (completion-preview--make-overlay end preview)))
+ (overlay-put ov 'completion-preview-beg beg)
+ (overlay-put ov 'completion-preview-end end)
+ (overlay-put ov 'completion-preview-index 0)
+ (overlay-put ov 'completion-preview-cands all)
+ (overlay-put ov 'completion-preview-base base)
+ (overlay-put ov 'completion-preview-exit-fn exit-fn)
+ (completion-preview-active-mode)))))
+
+(defun completion-preview--show ()
+ "Show a new completion preview.
+
+Call `completion-at-point-functions' in order to obtain and
+display a completion candidate for the text around point.
+
+If the preview is already shown, first check whether the
+suggested candidate remains a valid completion for the text at
+point. If so, update the preview according the new text at
+point, otherwise hide it."
+ (when completion-preview-active-mode
+ ;; We were already showing a preview before this command, so we
+ ;; check if the text before point is still a prefix of the
+ ;; candidate that the preview suggested, and if so we first update
+ ;; existing preview according to the changes made by this command,
+ ;; and only then try to get a new candidate. This ensures that we
+ ;; never display a stale preview and that the preview doesn't
+ ;; flicker, even with slow completion backends.
+ (let* ((beg (completion-preview--get 'completion-preview-beg))
+ (end (max (point) (overlay-start completion-preview--overlay)))
+ (cands (completion-preview--get 'completion-preview-cands))
+ (index (completion-preview--get 'completion-preview-index))
+ (cand (nth index cands))
+ (after (completion-preview--get 'after-string))
+ (face (get-text-property 0 'face after)))
+ (if (and (<= beg (point) end (1- (+ beg (length cand))))
+ (string-prefix-p (buffer-substring beg end) cand))
+ ;; The previous preview is still applicable, update it.
+ (overlay-put (completion-preview--make-overlay
+ end (propertize (substring cand (- end beg))
+ 'face face
+ 'mouse-face 'completion-preview-highlight
+ 'keymap completion-preview--mouse-map))
+ 'completion-preview-end end)
+ ;; The previous preview is no longer applicable, hide it.
+ (completion-preview-active-mode -1))))
+ ;; Run `completion-at-point-functions' to get a new candidate.
+ (while-no-input (completion-preview--update)))
+
+(defun completion-preview--post-command ()
+ "Create, update or delete completion preview post last command."
+ (if (and (completion-preview-require-certain-commands)
+ (completion-preview-require-minimum-symbol-length))
+ ;; We should show the preview.
+ (or
+ ;; If we're called after a command that itself updates the
+ ;; preview, don't do anything.
+ (completion-preview--internal-command-p)
+ ;; Otherwise, show the preview.
+ (completion-preview--show))
+ (completion-preview-active-mode -1)))
+
+(defun completion-preview-insert ()
+ "Insert the completion candidate that the preview is showing."
+ (interactive)
+ (if completion-preview-active-mode
+ (let* ((pre (completion-preview--get 'completion-preview-base))
+ (end (completion-preview--get 'completion-preview-end))
+ (ind (completion-preview--get 'completion-preview-index))
+ (all (completion-preview--get 'completion-preview-cands))
+ (efn (completion-preview--get 'completion-preview-exit-fn))
+ (aft (completion-preview--get 'after-string))
+ (str (concat pre (nth ind all))))
+ (completion-preview-active-mode -1)
+ (goto-char end)
+ (insert (substring-no-properties aft))
+ (when (functionp efn) (funcall efn str 'finished)))
+ (user-error "No current completion preview")))
+
+(defun completion-preview-prev-candidate ()
+ "Cycle the candidate that the preview is showing to the previous suggestion."
+ (interactive)
+ (completion-preview-next-candidate -1))
+
+(defun completion-preview-next-candidate (direction)
+ "Cycle the candidate that the preview is showing in direction DIRECTION.
+
+DIRECTION should be either 1 which means cycle forward, or -1
+which means cycle backward. Interactively, DIRECTION is the
+prefix argument and defaults to 1."
+ (interactive "p")
+ (when completion-preview-active-mode
+ (let* ((beg (completion-preview--get 'completion-preview-beg))
+ (end (completion-preview--get 'completion-preview-end))
+ (all (completion-preview--get 'completion-preview-cands))
+ (cur (completion-preview--get 'completion-preview-index))
+ (len (length all))
+ (new (mod (+ cur direction) len))
+ (str (nth new all)))
+ (while (or (<= (+ beg (length str)) end)
+ (not (string-prefix-p (buffer-substring beg end) str)))
+ (setq new (mod (+ new direction) len) str (nth new all)))
+ (let ((aft (propertize (substring str (- end beg))
+ 'face (if (< 1 len)
+ 'completion-preview
+ 'completion-preview-exact)
+ 'mouse-face 'completion-preview-highlight
+ 'keymap completion-preview--mouse-map)))
+ (add-text-properties 0 1 '(cursor 1) aft)
+ (overlay-put completion-preview--overlay 'completion-preview-index new)
+ (overlay-put completion-preview--overlay 'after-string aft))
+ (when completion-preview-message-format
+ (message (format-spec completion-preview-message-format
+ `((?i . ,(1+ new)) (?n . ,len))))))))
+
+(defun completion-preview--active-p (_symbol buffer)
+ "Check if the completion preview is currently shown in BUFFER."
+ (buffer-local-value 'completion-preview-active-mode buffer))
+
+(dolist (cmd '(completion-preview-insert
+ completion-preview-prev-candidate
+ completion-preview-next-candidate))
+ (put cmd 'completion-predicate #'completion-preview--active-p))
+
+;;;###autoload
+(define-minor-mode completion-preview-mode
+ "Show in-buffer completion suggestions in a preview as you type.
+
+This mode automatically shows and updates the completion preview
+according to the text around point.
+\\<completion-preview-active-mode-map>\
+When the preview is visible, \\[completion-preview-insert]
+accepts the completion suggestion,
+\\[completion-preview-next-candidate] cycles forward to the next
+completion suggestion, and \\[completion-preview-prev-candidate]
+cycles backward."
+ :lighter " CP"
+ (if completion-preview-mode
+ (add-hook 'post-command-hook #'completion-preview--post-command nil t)
+ (remove-hook 'post-command-hook #'completion-preview--post-command t)
+ (completion-preview-active-mode -1)))
+
+(provide 'completion-preview)
+;;; completion-preview.el ends here
diff --git a/lisp/completion.el b/lisp/completion.el
index ab7f2a7bc52..6c758e56eab 100644
--- a/lisp/completion.el
+++ b/lisp/completion.el
@@ -875,11 +875,11 @@ This is sensitive to `case-fold-search'."
;; GNU implements obarrays
(defconst cmpl-obarray-length 511)
-(defvar cmpl-prefix-obarray (make-vector cmpl-obarray-length 0)
+(defvar cmpl-prefix-obarray (obarray-make cmpl-obarray-length)
"An obarray used to store the downcased completion prefixes.
Each symbol is bound to a list of completion entries.")
-(defvar cmpl-obarray (make-vector cmpl-obarray-length 0)
+(defvar cmpl-obarray (obarray-make cmpl-obarray-length)
"An obarray used to store the downcased completions.
Each symbol is bound to a single completion entry.")
@@ -962,8 +962,8 @@ Each symbol is bound to a single completion entry.")
(defun clear-all-completions ()
"Initialize the completion storage. All existing completions are lost."
(interactive)
- (setq cmpl-prefix-obarray (make-vector cmpl-obarray-length 0))
- (setq cmpl-obarray (make-vector cmpl-obarray-length 0)))
+ (setq cmpl-prefix-obarray (obarray-make cmpl-obarray-length))
+ (setq cmpl-obarray (obarray-make cmpl-obarray-length)))
(defun list-all-completions ()
"Return a list of all the known completion entries."
diff --git a/lisp/composite.el b/lisp/composite.el
index e9214dd71ab..326e8f10aee 100644
--- a/lisp/composite.el
+++ b/lisp/composite.el
@@ -818,7 +818,7 @@ prepending a space before it."
(setq glyph (lgstring-glyph gstring i))
(lglyph-set-char glyph 32)
(lglyph-set-width glyph 1)
- (setq i (+ 2)))
+ (setq i (+ i 2)))
(let ((from (lglyph-from glyph))
(to (lglyph-to glyph))
(j (1+ i)))
diff --git a/lisp/cus-edit.el b/lisp/cus-edit.el
index 12eea0fa0e5..f004002333b 100644
--- a/lisp/cus-edit.el
+++ b/lisp/cus-edit.el
@@ -177,7 +177,7 @@
(defgroup wp nil
"Support for editing text files.
-Use group `text' for this instead. This group is deprecated."
+Use group `text' for this instead. This group is obsolete."
:group 'emacs)
(defgroup text nil
@@ -512,6 +512,13 @@ WIDGET is the widget to apply the filter entries of MENU on."
(push name result)))
(nreverse result)))
+(defun custom--editable-field-p (widget)
+ "Non-nil if WIDGET is an editable-field widget, or inherits from it."
+ (let ((type (widget-type widget)))
+ (while (and type (not (eq type 'editable-field)))
+ (setq type (widget-type (get type 'widget-type))))
+ type))
+
;;; Unlispify.
(defvar custom-prefix-list nil
@@ -903,9 +910,9 @@ This also shows the saved values in the buffer."
(defun custom-reset-standard-save-and-update ()
"Save settings and redraw after erasing customizations."
(when (or (and custom-reset-standard-variables-list
- (not (eq custom-reset-standard-variables-list '(t))))
+ (not (equal custom-reset-standard-variables-list '(t))))
(and custom-reset-standard-faces-list
- (not (eq custom-reset-standard-faces-list '(t)))))
+ (not (equal custom-reset-standard-faces-list '(t)))))
;; Save settings to file.
(custom-save-all)
;; Set state of and redraw variables.
@@ -973,8 +980,7 @@ it as the third element in the list."
(let ((prop (get var 'variable-interactive))
(type (get var 'custom-type))
(prompt (format prompt-val var)))
- (unless (listp type)
- (setq type (list type)))
+ (setq type (ensure-list type))
(cond (prop
;; Use VAR's `variable-interactive' property
;; as an interactive spec for prompting.
@@ -1153,14 +1159,15 @@ argument or if the current major mode has no known group, prompt
for the MODE to customize."
(interactive
(list
- (let ((completion-regexp-list '("-mode\\'"))
- (group (custom-group-of-mode major-mode)))
+ (let ((group (custom-group-of-mode major-mode)))
(if (and group (not current-prefix-arg))
major-mode
(intern
(completing-read (format-prompt "Mode" (and group major-mode))
obarray
- 'custom-group-of-mode
+ (lambda (s)
+ (and (string-match "-mode\\'" (symbol-name s))
+ (custom-group-of-mode s)))
t nil nil (if group (symbol-name major-mode))))))))
(customize-group (custom-group-of-mode mode)))
@@ -1222,6 +1229,41 @@ If OTHER-WINDOW is non-nil, display in another window."
(message "`%s' is an alias for `%s'" symbol basevar))))
;;;###autoload
+(defun customize-toggle-option (symbol)
+ "Toggle the value of boolean option SYMBOL for this session."
+ (interactive (let ((prompt "Toggle boolean option: ") opts)
+ (mapatoms
+ (lambda (sym)
+ (when (eq (get sym 'custom-type) 'boolean)
+ (push sym opts))))
+ (list (intern (completing-read prompt opts nil nil nil nil
+ (symbol-at-point))))))
+ (let* ((setter (or (get symbol 'custom-set) #'set-default))
+ (getter (or (get symbol 'custom-get) #'symbol-value))
+ (value (condition-case nil
+ (funcall getter symbol)
+ (void-variable (error "`%s' is not bound" symbol))))
+ (type (get symbol 'custom-type)))
+ (cond
+ ((eq type 'boolean))
+ ((and (null type)
+ (yes-or-no-p
+ (format "`%s' doesn't have a type, and has the value %S. \
+Proceed to toggle?" symbol value))))
+ ((yes-or-no-p
+ (format "`%s' is of type %s, and has the value %S. \
+Proceed to toggle?"
+ symbol type value)))
+ ((error "Abort toggling of option `%s'" symbol)))
+ (message "%s user options `%s'."
+ (if (funcall setter symbol (not value))
+ "Enabled" "Disabled")
+ symbol)))
+
+;;;###autoload
+(defalias 'toggle-option #'customize-toggle-option)
+
+;;;###autoload
(defalias 'customize-variable-other-window 'customize-option-other-window)
;;;###autoload
@@ -1238,7 +1280,7 @@ Show the buffer in another window, but don't select it."
(unless (eq symbol basevar)
(message "`%s' is an alias for `%s'" symbol basevar))))
-(defvar customize-changed-options-previous-release "28.2"
+(defvar customize-changed-options-previous-release "29.1"
"Version for `customize-changed' to refer back to by default.")
;; Packages will update this variable, so make it available.
@@ -2209,7 +2251,7 @@ and `face'."
;;; The `custom' Widget.
(defface custom-button
- '((((type x w32 ns haiku pgtk) (class color)) ; Like default mode line
+ '((((type x w32 ns haiku pgtk android) (class color)) ; Like default mode line
:box (:line-width 2 :style released-button)
:background "lightgrey" :foreground "black"))
"Face for custom buffer buttons if `custom-raised-buttons' is non-nil."
@@ -2217,7 +2259,7 @@ and `face'."
:group 'custom-faces)
(defface custom-button-mouse
- '((((type x w32 ns haiku pgtk) (class color))
+ '((((type x w32 ns haiku pgtk android) (class color))
:box (:line-width 2 :style released-button)
:background "grey90" :foreground "black")
(t
@@ -2242,7 +2284,7 @@ and `face'."
(if custom-raised-buttons 'custom-button-mouse 'highlight))
(defface custom-button-pressed
- '((((type x w32 ns haiku pgtk) (class color))
+ '((((type x w32 ns haiku pgtk android) (class color))
:box (:line-width 2 :style pressed-button)
:background "lightgrey" :foreground "black")
(t :inverse-video t))
@@ -2330,6 +2372,7 @@ and `face'."
(from (marker-position (widget-get widget :from)))
(to (marker-position (widget-get widget :to))))
(save-excursion
+ (custom-comment-preserve widget)
(widget-value-set widget (widget-value widget))
(custom-redraw-magic widget))
(when (and (>= pos from) (<= pos to))
@@ -2509,7 +2552,9 @@ If INITIAL-STRING is non-nil, use that rather than \"Parent groups:\"."
(let* ((null-comment (equal "" (widget-value widget))))
(if (or (widget-get (widget-get widget :parent) :comment-shown)
(not null-comment))
- (widget-default-create widget)
+ (progn
+ (widget-default-create widget)
+ (widget-put (widget-get widget :parent) :comment-shown t))
;; `widget-default-delete' expects markers in these slots --
;; maybe it shouldn't.
(widget-put widget :from (point-marker))
@@ -2542,6 +2587,14 @@ If INITIAL-STRING is non-nil, use that rather than \"Parent groups:\"."
(and (equal "" val)
(not (widget-get widget :comment-shown)))))
+;; This is useful when we want to redraw a widget, but we want to preserve
+;; edits made by the user in the comment widget. (See Bug#64649)
+(defun custom-comment-preserve (widget)
+ "Preserve the comment that belongs to WIDGET."
+ (when (widget-get widget :comment-shown)
+ (let ((comment-widget (widget-get widget :comment-widget)))
+ (widget-put comment-widget :value (widget-value comment-widget)))))
+
;;; The `custom-variable' Widget.
(defface custom-variable-obsolete
@@ -2821,12 +2874,16 @@ try matching its doc string against `custom-guess-doc-alist'."
;; The comment field
(unless (eq state 'hidden)
- (let* ((comment (get symbol 'variable-comment))
- (comment-widget
- (widget-create-child-and-convert
- widget 'custom-comment
- :parent widget
- :value (or comment ""))))
+ (let ((comment-widget
+ (widget-create-child-and-convert
+ widget 'custom-comment
+ :parent widget
+ :value (or
+ (and
+ (widget-get widget :comment-shown)
+ (widget-value (widget-get widget :comment-widget)))
+ (get symbol 'variable-comment)
+ ""))))
(widget-put widget :comment-widget comment-widget)
;; Don't push it !!! Custom assumes that the first child is the
;; value one.
@@ -3538,6 +3595,10 @@ Pure-GTK interface.")
:sibling-args (:help-echo "\
Haiku interface.")
haiku)
+ (const :format "Android "
+ :sibling-args (:help-echo "\
+Android interface.")
+ android)
(const :format "DOS "
:sibling-args (:help-echo "\
Plain MS-DOS.")
@@ -3721,7 +3782,8 @@ WIDGET should be a `custom-face' widget."
`((t ,(widget-value child)))
(widget-value child)))))
-(defun custom-face-get-current-spec (face)
+(defun custom-face-get-current-spec-unfiltered (face)
+ "Return the current spec for face FACE, without filtering it."
(let ((spec (or (get face 'customized-face)
(get face 'saved-face)
(get face 'face-defface-spec)
@@ -3731,8 +3793,12 @@ WIDGET should be a `custom-face' widget."
;; If the user has changed this face in some other way,
;; edit it as the user has specified it.
(if (not (face-spec-match-p face spec (selected-frame)))
- (setq spec `((t ,(face-attr-construct face (selected-frame))))))
- (custom-pre-filter-face-spec spec)))
+ (setq spec `((t ,(face-attr-construct face)))))
+ spec))
+
+(defun custom-face-get-current-spec (face)
+ "Return the current spec for face FACE, filtering it."
+ (custom-pre-filter-face-spec (custom-face-get-current-spec-unfiltered face)))
(defun custom-toggle-hide-face (visibility-widget &rest _ignore)
"Toggle the visibility of a `custom-face' parent widget.
@@ -3835,12 +3901,16 @@ the present value is saved to its :shown-value property instead."
widget :visibility-widget 'custom-visibility)
;; The comment field
(unless hiddenp
- (let* ((comment (get symbol 'face-comment))
- (comment-widget
- (widget-create-child-and-convert
- widget 'custom-comment
- :parent widget
- :value (or comment ""))))
+ (let ((comment-widget
+ (widget-create-child-and-convert
+ widget 'custom-comment
+ :parent widget
+ :value (or
+ (and
+ (widget-get widget :comment-shown)
+ (widget-value (widget-get widget :comment-widget)))
+ (get symbol 'face-comment)
+ ""))))
(widget-put widget :comment-widget comment-widget)
(push comment-widget children))))
@@ -3852,8 +3922,8 @@ the present value is saved to its :shown-value property instead."
(unless (widget-get widget :custom-form)
(widget-put widget :custom-form custom-face-default-form))
- (let* ((spec (or (widget-get widget :shown-value)
- (custom-face-get-current-spec symbol)))
+ (let* ((shown-value (widget-get widget :shown-value))
+ (spec (or shown-value (custom-face-get-current-spec symbol)))
(form (widget-get widget :custom-form))
(indent (widget-get widget :indent))
face-alist face-entry spec-default spec-match editor)
@@ -3894,7 +3964,7 @@ the present value is saved to its :shown-value property instead."
widget 'sexp :value spec))))
(push editor children)
(widget-put widget :children children)
- (custom-face-state-set widget))))))
+ (custom-face-state-set widget (not shown-value)))))))
(defun cus--face-link (widget _format)
(widget-create-child-and-convert
@@ -4014,13 +4084,18 @@ This is one of `set', `saved', `changed', `themed', or `rogue'."
'changed
state)))
-(defun custom-face-state-set (widget)
+(defun custom-face-state-set (widget &optional no-filter)
"Set the state of WIDGET, a custom-face widget.
If the user edited the widget, set the state to modified. If not, the new
-state is one of the return values of `custom-face-state'."
+state is one of the return values of `custom-face-state'.
+Optional argument NO-FILTER means to check against an unfiltered spec."
(let ((face (widget-value widget)))
(widget-put widget :custom-state
- (if (face-spec-match-p face (custom-face-widget-to-spec widget))
+ (if (face-spec-match-p
+ face
+ (if no-filter
+ (custom-face-get-current-spec-unfiltered face)
+ (custom-face-widget-to-spec widget)))
(custom-face-state face)
'modified))))
@@ -4116,7 +4191,10 @@ Optional EVENT is the location for the menu."
;; If recreating a widget that may have been edited by the user, remember
;; to always save the edited value into the :shown-value property, so
;; we use that value for the recreated widget. (Bug#44331)
- (widget-put widget :shown-value (custom-face-widget-to-spec widget))
+ (let ((child (car (widget-get widget :children))))
+ (if (eq (widget-type child) 'custom-face-edit)
+ (widget-put widget :shown-value `((t ,(widget-value child))))
+ (widget-put widget :shown-value (widget-value child))))
(custom-face-edit-all widget)
(widget-put widget :shown-value nil) ; Reset it after we used it.
(custom-face-mark-to-save widget)
@@ -5112,8 +5190,7 @@ This function does not save the buffer."
(defun custom-variable-menu-create (_widget symbol)
"Ignoring WIDGET, create a menu entry for customization variable SYMBOL."
(let ((type (get symbol 'custom-type)))
- (unless (listp type)
- (setq type (list type)))
+ (setq type (ensure-list type))
(if (and type (widget-get type :custom-menu))
(widget-apply type :custom-menu symbol)
(vector (custom-unlispify-menu-entry symbol)
@@ -5710,6 +5787,288 @@ This stores EXP (without evaluating it) as the saved spec for SYMBOL."
(prin1 value (current-buffer)))
(insert ")\n")))))
+;;; Directory Local Variables.
+;; The following code provides an Easy Customization interface to manage
+;; `.dir-locals.el' files.
+;; The main command is `customize-dirlocals'. It presents a Custom-like buffer
+;; but with a few tweaks. Variables are inserted in a repeat widget, and
+;; update its associated widget (the one for editing the value) upon the user
+;; hitting RET or TABbing out of it.
+;; This is unlike the `cus-theme.el' interface for editing themes, that prompts
+;; the user for the variable to then create the appropriate widget.
+(defvar-local custom-dirlocals-widget nil
+ "Widget that holds the dir-locals customizations.")
+
+(defvar-local custom-dirlocals-file-widget nil
+ "Widget that holds the name of the dir-locals file being customized.")
+
+(defvar-keymap custom-dirlocals-map
+ :doc "Keymap used in the \"*Customize Dirlocals*\" buffer."
+ :full t
+ :parent widget-keymap
+ "SPC" #'scroll-up-command
+ "S-SPC" #'scroll-down-command
+ "DEL" #'scroll-down-command
+ "C-x C-s" #'Custom-dirlocals-save
+ "q" #'Custom-buffer-done
+ "n" #'widget-forward
+ "p" #'widget-backward)
+
+(defvar custom-dirlocals-field-map
+ (let ((map (copy-keymap custom-field-keymap)))
+ (define-key map "\C-x\C-s" #'Custom-dirlocals-save)
+ (define-key map "\C-m" #'widget-field-activate)
+ map)
+ "Keymap for the editable fields in the \"*Customize Dirlocals*\" buffer .")
+
+(defvar custom-dirlocals-commands
+ '((" Save Settings " Custom-dirlocals-save t
+ "Save Settings to the dir-locals file." "save" "Save" t)
+ (" Undo Edits " Custom-dirlocals-revert-buffer t
+ "Revert buffer, undoing any editions."
+ "refresh" "Undo" t)
+ (" Help for Customize " Custom-help t "Get help for using Customize."
+ "help" "Help" t)
+ (" Exit " Custom-buffer-done t "Exit Customize." "exit" "Exit" t))
+ "Alist of specifications for Customize menu items, tool bar icons and buttons.
+See `custom-commands' for further explanation.")
+
+(easy-menu-define
+ Custom-dirlocals-menu (list custom-dirlocals-map
+ custom-dirlocals-field-map)
+ "Menu used in dirlocals customization buffers."
+ (nconc (list "Custom"
+ (customize-menu-create 'customize))
+ (mapcar (lambda (arg)
+ (let ((tag (nth 0 arg))
+ (command (nth 1 arg))
+ (visible (nth 2 arg))
+ (help (nth 3 arg))
+ (active (nth 6 arg)))
+ (vector tag command :visible (eval visible)
+ :active `(eq t ',active)
+ :help help)))
+ custom-dirlocals-commands)))
+
+(defvar custom-dirlocals-tool-bar-map nil
+ "Keymap for the toolbar in \"*Customize Dirlocals*\" buffer.")
+
+(define-widget 'custom-dirlocals-key 'menu-choice
+ "Menu to choose between possible keys in a dir-locals file.
+
+Possible values are nil, a symbol (standing for a major mode) or a directory
+name."
+ :tag "Specification"
+ :value nil
+ :help-echo "Select a key for the dir-locals specification."
+ :args '((const :tag "All modes" nil)
+ (symbol :tag "Major mode" fundamental-mode)
+ (directory :tag "Subdirectory")))
+
+(define-widget 'custom-dynamic-cons 'cons
+ "A cons widget that changes its 2nd type based on the 1st type."
+ :value-create #'custom-dynamic-cons-value-create)
+
+(defun custom-dynamic-cons-value-create (widget)
+ "Select an appropriate 2nd type for the cons WIDGET and create WIDGET.
+
+The appropriate types are:
+- A symbol, if the value to represent is a minor-mode.
+- A boolean, if the value to represent is either the unibyte value or the
+ subdirs value.
+- A widget type suitable for editing a variable, in case of specifying a
+ variable's value.
+- A sexp widget, if none of the above happens."
+ (let* ((args (widget-get widget :args))
+ (value (widget-get widget :value))
+ (val (car value)))
+ (cond
+ ((eq val 'mode) (setf (nth 1 args)
+ '(symbol :keymap custom-dirlocals-field-map
+ :tag "Minor mode")))
+ ((eq val 'unibyte) (setf (nth 1 args) '(boolean)))
+ ((eq val 'subdirs) (setf (nth 1 args) '(boolean)))
+ ((custom-variable-p val)
+ (let ((w (widget-convert (custom-variable-type val))))
+ (when (custom--editable-field-p w)
+ (widget-put w :keymap custom-dirlocals-field-map))
+ (setf (nth 1 args) w)))
+ (t (setf (nth 1 args) '(sexp :keymap custom-dirlocals-field-map))))
+ (widget-put (nth 0 args) :keymap custom-dirlocals-field-map)
+ (widget-group-value-create widget)))
+
+(defun custom-dirlocals-maybe-update-cons ()
+ "If focusing out from the first widget in a cons widget, update its value."
+ (when-let ((w (widget-at)))
+ (when (widget-get w :custom-dirlocals-symbol)
+ (widget-value-set (widget-get w :parent)
+ (cons (widget-value w) ""))
+ (widget-setup))))
+
+(define-widget 'custom-dirlocals 'editable-list
+ "An editable list to edit settings in a dir-locals file."
+ :entry-format "%i %d %v"
+ :insert-button-args '(:help-echo "Insert new specification here.")
+ :append-button-args '(:help-echo "Append new specification here.")
+ :delete-button-args '(:help-echo "Delete this specification.")
+ :args '((group :format "%v"
+ custom-dirlocals-key
+ (repeat
+ :tag "Settings"
+ :inline t
+ (custom-dynamic-cons
+ :tag "Setting"
+ (symbol :action custom-dirlocals-symbol-action
+ :custom-dirlocals-symbol t)
+ ;; Will change according to the option being customized.
+ (sexp :tag "Value"))))))
+
+(defun custom-dirlocals-symbol-action (widget &optional _event)
+ "Action for the symbol WIDGET.
+
+Sets the value of its parent, a cons widget, in order to create an
+appropriate widget to edit the value of WIDGET.
+
+Moves point into the widget that holds the value."
+ (setq widget (or widget (widget-at)))
+ (widget-value-set (widget-get widget :parent)
+ (cons (widget-value widget) ""))
+ (widget-setup)
+ (widget-forward 1))
+
+(defun custom-dirlocals-change-file (widget &optional _event)
+ "Switch to a buffer to customize the dir-locals file in WIDGET."
+ (customize-dirlocals (expand-file-name (widget-value widget))))
+
+(defun custom-dirlocals--set-widget-vars ()
+ "Set local variables for the Widget library."
+ (custom--initialize-widget-variables)
+ (add-hook 'widget-forward-hook #'custom-dirlocals-maybe-update-cons nil t))
+
+(defmacro custom-dirlocals-with-buffer (&rest body)
+ "Arrange to execute BODY in a \"*Customize Dirlocals*\" buffer."
+ ;; We don't use `custom-buffer-create' because the settings here
+ ;; don't go into the `custom-file'.
+ `(progn
+ (switch-to-buffer "*Customize Dirlocals*")
+ (kill-all-local-variables)
+ (let ((inhibit-read-only t))
+ (erase-buffer))
+ (remove-overlays)
+ (custom-dirlocals--set-widget-vars)
+ ,@body
+ (setq-local tool-bar-map
+ (or custom-dirlocals-tool-bar-map
+ ;; Set up `custom-dirlocals-tool-bar-map'.
+ (let ((map (make-sparse-keymap)))
+ (mapc
+ (lambda (arg)
+ (tool-bar-local-item-from-menu
+ (nth 1 arg) (nth 4 arg) map custom-dirlocals-map
+ :label (nth 5 arg)))
+ custom-dirlocals-commands)
+ (setq custom-dirlocals-tool-bar-map map))))
+ (setq-local revert-buffer-function #'Custom-dirlocals-revert-buffer)
+ (use-local-map custom-dirlocals-map)
+ (widget-setup)))
+
+(defun custom-dirlocals-get-options ()
+ "Return all options inside a custom-dirlocals widget."
+ (let* ((groups (widget-get custom-dirlocals-widget :children))
+ (repeats (mapcar (lambda (group)
+ (nth 1 (widget-get group :children)))
+ groups)))
+ (mapcan (lambda (repeat)
+ (mapcar (lambda (w)
+ (nth 1 (widget-get w :children)))
+ (widget-get repeat :children)))
+ repeats)))
+
+(defun custom-dirlocals-validate ()
+ "Non-nil if all customization options validate.
+
+If at least an option doesn't validate, signals an error and moves point
+to the widget with the invalid value."
+ (dolist (opt (custom-dirlocals-get-options))
+ (when-let ((w (widget-apply opt :validate)))
+ (goto-char (widget-get w :from))
+ (error "%s" (widget-get w :error))))
+ t)
+
+(defun Custom-dirlocals-revert-buffer (&rest _ignored)
+ "Revert the buffer for Directory Local Variables customization."
+ (interactive)
+ (customize-dirlocals (widget-get custom-dirlocals-file-widget :value)))
+
+(defun Custom-dirlocals-save (&rest _ignore)
+ "Save the settings to the dir-locals file being customized."
+ (interactive)
+ (when (custom-dirlocals-validate)
+ (let* ((file (widget-value custom-dirlocals-file-widget))
+ (old (widget-get custom-dirlocals-widget :value))
+ (dirlocals (widget-value custom-dirlocals-widget)))
+ (dolist (spec old)
+ (let ((mode (car spec))
+ (settings (cdr spec)))
+ (dolist (setting settings)
+ (delete-dir-local-variable mode (car setting) file))))
+ (dolist (spec dirlocals)
+ (let ((mode (car spec))
+ (settings (cdr spec)))
+ (dolist (setting (reverse settings))
+ (when (memq (car setting) '(mode eval))
+ (delete-dir-local-variable mode (car setting) file))
+ (add-dir-local-variable mode (car setting) (cdr setting) file)))))
+ ;; Write the dir-locals file and kill its buffer, to come back to
+ ;; our own buffer.
+ (write-file (expand-file-name buffer-file-name) nil)
+ (kill-buffer)))
+
+;;;###autoload
+(defun customize-dirlocals (&optional filename)
+ "Customize Directory Local Variables in the current directory.
+
+With optional argument FILENAME non-nil, customize the `.dir-locals.el' file
+that FILENAME specifies."
+ (interactive)
+ (let* ((file (or filename (expand-file-name ".dir-locals.el")))
+ (dirlocals (when (file-exists-p file)
+ (with-current-buffer (find-file-noselect file)
+ (goto-char (point-min))
+ (prog1
+ (condition-case _
+ (read (current-buffer))
+ (end-of-file nil))
+ (kill-buffer))))))
+ (custom-dirlocals-with-buffer
+ (widget-insert
+ "This buffer is for customizing the Directory Local Variables in:\n")
+ (setq custom-dirlocals-file-widget
+ (widget-create `(file :action ,#'custom-dirlocals-change-file
+ ,file)))
+ (widget-insert
+ (substitute-command-keys
+ "
+To select another file, edit the above field and hit RET.
+
+After you enter a user option name under the symbol field,
+be sure to press \\`RET' or \\`TAB', so that the field that holds the
+value changes to an appropriate field for the option.
+
+Type \\`C-x C-s' when you've finished editing it, to save the
+settings to the file."))
+ (widget-insert "\n\n\n")
+ (widget-create 'push-button :tag " Revert "
+ :action #'Custom-dirlocals-revert-buffer)
+ (widget-insert " ")
+ (widget-create 'push-button :tag " Save Settings "
+ :action #'Custom-dirlocals-save)
+ (widget-insert "\n\n")
+ (setq custom-dirlocals-widget
+ (widget-create 'custom-dirlocals :value dirlocals))
+ (setq default-directory (file-name-directory file))
+ (goto-char (point-min)))))
+
(provide 'cus-edit)
;;; cus-edit.el ends here
diff --git a/lisp/cus-face.el b/lisp/cus-face.el
index 0c8b6b0b97c..47afa841f5e 100644
--- a/lisp/cus-face.el
+++ b/lisp/cus-face.el
@@ -32,7 +32,7 @@
(defun custom-declare-face (face spec doc &rest args)
"Like `defface', but with FACE evaluated as a normal argument."
(when (and doc
- (not (stringp doc)))
+ (not (documentation-stringp doc)))
(error "Invalid (or missing) doc string %S" doc))
(unless (get face 'face-defface-spec)
(face-spec-set face (purecopy spec) 'face-defface-spec)
diff --git a/lisp/cus-start.el b/lisp/cus-start.el
index 6178b6d3819..165296d2242 100644
--- a/lisp/cus-start.el
+++ b/lisp/cus-start.el
@@ -231,6 +231,7 @@ Leaving \"Default\" unchecked is equivalent with specifying a default of
(inverse-video display boolean)
(visible-bell display boolean)
(no-redraw-on-reenter display boolean)
+ (mouse-prefer-closest-glyph display boolean)
;; doc.c
(text-quoting-style display
@@ -310,6 +311,7 @@ Leaving \"Default\" unchecked is equivalent with specifying a default of
(const :tag "Off" :value nil)
(const :tag "On" :value t)
(const :tag "Auto-raise" :value auto-raise)) "26.1")
+ (yes-or-no-prompt menu string "30.1")
;; fontset.c
;; FIXME nil is the initial value, fontset.el setqs it.
(vertical-centering-font-regexp display
@@ -369,6 +371,7 @@ Leaving \"Default\" unchecked is equivalent with specifying a default of
(auto-save-timeout auto-save (choice (const :tag "off" nil)
(integer :format "%v")))
(echo-keystrokes minibuffer number)
+ (echo-keystrokes-help minibuffer boolean "30.1")
(polling-period keyboard float)
(double-click-time mouse (restricted-sexp
:match-alternatives (integerp 'nil 't)))
@@ -604,6 +607,8 @@ This should only be chosen under exceptional circumstances,
since it could result in memory overflow and make Emacs crash."
nil))
"27.1")
+ ;; w32fns.c
+ (w32-follow-system-dark-mode display boolean "30.1")
;; window.c
(temp-buffer-show-function windows (choice (const nil) function))
(next-screen-context-lines windows integer)
@@ -841,6 +846,8 @@ since it could result in memory overflow and make Emacs crash."
(x-select-enable-clipboard-manager killing boolean "24.1")
;; xsettings.c
(font-use-system-font font-selection boolean "23.2")
+ ;; xwidget.c
+ (xwidget-webkit-disable-javascript xwidget boolean "30.1")
;; haikuterm.c
(haiku-debug-on-fatal-error debug boolean "29.1")
;; haikufns.c
@@ -901,6 +908,8 @@ since it could result in memory overflow and make Emacs crash."
(symbol-name symbol))
;; Any function from fontset.c will do.
(fboundp 'new-fontset))
+ ((string-match "xwidget-" (symbol-name symbol))
+ (boundp 'xwidget-internal))
(t t))))
(if (not (boundp symbol))
;; If variables are removed from C code, give an error here!
diff --git a/lisp/cus-theme.el b/lisp/cus-theme.el
index 3308e7ec07a..1aa995a1d91 100644
--- a/lisp/cus-theme.el
+++ b/lisp/cus-theme.el
@@ -490,6 +490,29 @@ It includes all faces in list FACES."
(with-current-buffer standard-output
(describe-theme-1 theme))))
+(defun describe-theme-from-file (theme &optional file short)
+ "Describe THEME from its FILE without loading it.
+
+If FILE is nil try to look in `custom-theme-load-path' for the
+theme's file using the theme's name.
+If SHORT is non-nil, show only the first line of thene's documentation."
+ (let ((file (or file
+ (locate-file (concat (symbol-name theme) "-theme.el")
+ (custom-theme--load-path)
+ '("" "c")))))
+ (with-temp-buffer
+ (insert-file-contents file)
+ (catch 'found
+ (let (sexp)
+ (while (setq sexp (let ((read-circle nil))
+ (condition-case nil
+ (read (current-buffer))
+ (end-of-file nil))))
+ (when (eq (car-safe sexp) 'deftheme)
+ (throw 'found (if short
+ (car (split-string (nth 2 sexp) "\n"))
+ (nth 2 sexp))))))))))
+
(defun describe-theme-1 (theme)
(prin1 theme)
(princ " is a custom theme")
@@ -510,16 +533,9 @@ It includes all faces in list FACES."
(princ "It is loaded but disabled."))
(setq doc (get theme 'theme-documentation)))
(princ "It is not loaded.")
- ;; Attempt to grab the theme documentation
+ ;; Attempt to grab the theme documentation from file.
(when fn
- (with-temp-buffer
- (insert-file-contents fn)
- (let ((sexp (let ((read-circle nil))
- (condition-case nil
- (read (current-buffer))
- (end-of-file nil)))))
- (and (eq (car-safe sexp) 'deftheme)
- (setq doc (nth 2 sexp)))))))
+ (setq doc (describe-theme-from-file theme fn))))
(princ "\n\nDocumentation:\n")
(princ (if (stringp doc)
(substitute-command-keys doc)
diff --git a/lisp/custom.el b/lisp/custom.el
index d807fb9031e..a19b14aaf8a 100644
--- a/lisp/custom.el
+++ b/lisp/custom.el
@@ -667,6 +667,7 @@ If NOSET is non-nil, don't bother autoloading LOAD when setting the variable."
A customizable variable is either (i) a variable whose property
list contains a non-nil `standard-value' or `custom-autoload'
property, or (ii) an alias for another customizable variable."
+ (declare (side-effect-free t))
(when (symbolp variable)
(setq variable (indirect-variable variable))
(or (get variable 'standard-value)
@@ -1207,7 +1208,7 @@ The command `customize-create-theme' writes theme files into this
directory. By default, Emacs searches for custom themes in this
directory first---see `custom-theme-load-path'."
:initialize #'custom-initialize-delay
- :type 'string
+ :type 'directory
:group 'customize
:version "22.1")
diff --git a/lisp/descr-text.el b/lisp/descr-text.el
index 91f8f646a9a..524a6474cd4 100644
--- a/lisp/descr-text.el
+++ b/lisp/descr-text.el
@@ -42,26 +42,6 @@
(insert-text-button
"(widget)Top" 'type 'help-info 'help-args '("(widget)Top")))
-(defun describe-text-sexp (sexp)
- "Insert a short description of SEXP in the current buffer."
- (let ((pp (condition-case signal
- (pp-to-string sexp)
- (error (prin1-to-string signal)))))
- (when (string-match-p "\n\\'" pp)
- (setq pp (substring pp 0 (1- (length pp)))))
-
- (if (and (not (string-search "\n" pp))
- (<= (length pp) (- (window-width) (current-column))))
- (insert pp)
- (insert-text-button
- "[Show]"
- 'follow-link t
- 'action (lambda (&rest _ignore)
- (with-output-to-temp-buffer
- "*Pp Eval Output*"
- (princ pp)))
- 'help-echo "mouse-2, RET: pretty print value in another buffer"))))
-
(defun describe-property-list (properties)
"Insert a description of PROPERTIES in the current buffer.
PROPERTIES should be a list of overlay or text properties.
@@ -92,7 +72,9 @@ into help buttons that call `describe-text-category' or
(format "%S" value)
'type 'help-face 'help-args (list value)))
(t
- (describe-text-sexp value))))
+ (require 'pp)
+ (declare-function pp-insert-short-sexp "pp" (sexp &optional width))
+ (pp-insert-short-sexp value))))
(insert "\n")))
;;; Describe-Text Commands.
@@ -366,7 +348,7 @@ This function is semi-obsolete. Use `get-char-code-property'."
;; description is added to the category name as a tooltip
(defsubst describe-char-categories (category-set)
(let ((mnemonics (category-set-mnemonics category-set)))
- (unless (eq mnemonics "")
+ (unless (equal mnemonics "")
(list (mapconcat
(lambda (x)
(let* ((c (category-docstring x))
@@ -522,24 +504,24 @@ The character information includes:
(setcar composition
(concat
" with the surrounding characters \""
- (mapconcat 'describe-char-padded-string
- (buffer-substring from pos) "")
+ (mapconcat #'describe-char-padded-string
+ (buffer-substring from pos))
"\" and \""
- (mapconcat 'describe-char-padded-string
- (buffer-substring (1+ pos) to) "")
+ (mapconcat #'describe-char-padded-string
+ (buffer-substring (1+ pos) to))
"\""))
(setcar composition
(concat
" with the preceding character(s) \""
- (mapconcat 'describe-char-padded-string
- (buffer-substring from pos) "")
+ (mapconcat #'describe-char-padded-string
+ (buffer-substring from pos))
"\"")))
(if (< (1+ pos) to)
(setcar composition
(concat
" with the following character(s) \""
- (mapconcat 'describe-char-padded-string
- (buffer-substring (1+ pos) to) "")
+ (mapconcat #'describe-char-padded-string
+ (buffer-substring (1+ pos) to))
"\""))
(setcar composition nil)))
(setcar (cdr composition)
@@ -568,7 +550,7 @@ The character information includes:
("character"
,(format "%s (displayed as %s) (codepoint %d, #o%o, #x%x)"
char-description
- (apply 'propertize char-description
+ (apply #'propertize char-description
(text-properties-at pos))
char char char))
("charset"
@@ -620,7 +602,7 @@ The character information includes:
(if (consp key-list)
(list "type"
(concat "\""
- (mapconcat 'identity
+ (mapconcat #'identity
key-list "\" or \"")
"\"")
"with"
@@ -721,7 +703,7 @@ The character information includes:
(let ((unicodedata (describe-char-unicode-data char)))
(if unicodedata
(cons (list "Unicode data" "") unicodedata))))))
- (setq max-width (apply 'max (mapcar (lambda (x)
+ (setq max-width (apply #'max (mapcar (lambda (x)
(if (cadr x) (length (car x)) 0))
item-list)))
(set-buffer src-buf)
@@ -736,7 +718,7 @@ The character information includes:
(dolist (clm (cdr elt))
(cond ((eq (car-safe clm) 'insert-text-button)
(insert " ")
- (eval clm))
+ (eval clm t))
((not (zerop (length clm)))
(insert " " clm))))
(insert "\n"))))
@@ -855,7 +837,7 @@ The character information includes:
(insert "\n")
(dolist (elt
(cond ((eq describe-char-unidata-list t)
- (nreverse (mapcar 'car char-code-property-alist)))
+ (nreverse (mapcar #'car char-code-property-alist)))
((< char 32)
;; Temporary fix (2016-05-22): The
;; decomposition item for \n corrupts the
@@ -898,7 +880,7 @@ characters."
(setq width (- width (length (car last)) 1)))
(let ((ellipsis (and (cdr last) "...")))
(setcdr last nil)
- (concat (mapconcat 'identity words " ") ellipsis)))
+ (concat (mapconcat #'identity words " ") ellipsis)))
"")))
(defun describe-char-eldoc--format (ch &optional width)
diff --git a/lisp/desktop.el b/lisp/desktop.el
index 9100d825547..3fa09ce6a41 100644
--- a/lisp/desktop.el
+++ b/lisp/desktop.el
@@ -406,7 +406,12 @@ or `desktop-modes-not-to-save'."
(defcustom desktop-files-not-to-save
"\\(\\`/[^/:]*:\\|(ftp)\\'\\)"
"Regexp identifying files whose buffers are to be excluded from saving.
-The default value excludes buffers visiting remote files."
+The default value excludes buffers visiting remote files.
+
+If you modify this such that buffers visiting remote files are not excluded,
+you may wish customizing `remote-file-name-access-timeout' to a non-nil
+value, to avoid hanging the desktop restoration because some remote
+host is off-line."
:type '(choice (const :tag "None" nil)
regexp)
:group 'desktop)
@@ -837,7 +842,7 @@ is nil, ask the user where to save the desktop."
;; If we own it, we don't anymore.
(when (eq (emacs-pid) (desktop-owner))
;; Allow exiting Emacs even if we can't delete the desktop file.
- (ignore-error 'file-error
+ (ignore-error file-error
(desktop-release-lock))))
;; ----------------------------------------------------------------------------
@@ -1508,6 +1513,11 @@ This function is called from `window-configuration-change-hook'."
(desktop-clear)
(desktop-read desktop-dirname))
+;; ----------------------------------------------------------------------------
+(defun desktop-access-file (filename)
+ "Check whether FILENAME is accessible."
+ (ignore-errors (not (access-file filename "Restoring desktop buffer"))))
+
(defvar desktop-buffer-major-mode)
(defvar desktop-buffer-locals)
(defvar auto-insert) ; from autoinsert.el
@@ -1517,8 +1527,8 @@ This function is called from `window-configuration-change-hook'."
_buffer-misc)
"Restore a file buffer."
(when buffer-filename
- (if (or (file-exists-p buffer-filename)
- (let ((msg (format "Desktop: File \"%s\" no longer exists."
+ (if (or (desktop-access-file buffer-filename)
+ (let ((msg (format "Desktop: File \"%s\" no longer accessible."
buffer-filename)))
(if desktop-missing-file-warning
(y-or-n-p (concat msg " Re-create buffer? "))
diff --git a/lisp/dired-aux.el b/lisp/dired-aux.el
index 0a3ce149474..a2ce3083cfe 100644
--- a/lisp/dired-aux.el
+++ b/lisp/dired-aux.el
@@ -264,7 +264,8 @@ the string of command switches used as the third argument of `diff'."
(read-string "Options for diff: "
(if (stringp diff-switches)
diff-switches
- (mapconcat #'identity diff-switches " ")))))))
+ (mapconcat #'identity diff-switches " "))))))
+ dired-mode)
(let ((current (dired-get-filename t)))
(when (or (equal (expand-file-name file)
(expand-file-name current))
@@ -290,7 +291,8 @@ With prefix arg, prompt for argument SWITCHES which is options for `diff'."
(if (stringp diff-switches)
diff-switches
(mapconcat #'identity diff-switches " "))))
- nil))
+ nil)
+ dired-mode)
(diff-backup (dired-get-filename) switches))
;;;###autoload
@@ -336,7 +338,8 @@ only in the active region if `dired-mark-region' is non-nil."
(read-directory-name (format "Compare %s with: "
(dired-current-directory))
target-dir target-dir t)))
- (read-from-minibuffer "Mark if (lisp expr or RET): " nil nil t nil "nil")))
+ (read-from-minibuffer "Mark if (lisp expr or RET): " nil nil t nil "nil"))
+ dired-mode)
(let* ((dir1 (dired-current-directory))
(file-alist1 (dired-files-attributes dir1))
(file-alist2 (dired-files-attributes dir2))
@@ -480,7 +483,8 @@ List has a form of (file-name full-file-name (attribute-list))."
(if failures
(dired-log-summary
(format "%s: error" operation)
- nil))))
+ nil)))
+ (dired-post-do-command))
;;;###autoload
(defun dired-do-chmod (&optional arg)
@@ -496,7 +500,7 @@ Alternatively, see the man page for \"chmod(1)\".
Note that on MS-Windows only the `w' (write) bit is meaningful:
resetting it makes the file read-only. Changing any other bit
has no effect on MS-Windows."
- (interactive "P")
+ (interactive "P" dired-mode)
(let* ((files (dired-get-marked-files t arg nil nil t))
;; The source of default file attributes is the file at point.
(default-file (dired-get-filename t t))
@@ -531,7 +535,8 @@ has no effect on MS-Windows."
(if num-modes num-modes
(file-modes-symbolic-to-number modes (file-modes file 'nofollow)))
'nofollow))
- (dired-do-redisplay arg)))
+ (dired-do-redisplay arg))
+ (dired-post-do-command))
;;;###autoload
(defun dired-do-chgrp (&optional arg)
@@ -539,7 +544,7 @@ has no effect on MS-Windows."
Type \\<minibuffer-local-completion-map>\\[next-history-element] \
to pull the file attributes of the file at point
into the minibuffer."
- (interactive "P")
+ (interactive "P" dired-mode)
(if (and (memq system-type '(ms-dos windows-nt))
(not (file-remote-p default-directory)))
(error "chgrp not supported on this system"))
@@ -551,7 +556,7 @@ into the minibuffer."
Type \\<minibuffer-local-completion-map>\\[next-history-element] \
to pull the file attributes of the file at point
into the minibuffer."
- (interactive "P")
+ (interactive "P" dired-mode)
(if (and (memq system-type '(ms-dos windows-nt))
(not (file-remote-p default-directory)))
(error "chown not supported on this system"))
@@ -564,7 +569,7 @@ This calls touch.
Type Type \\<minibuffer-local-completion-map>\\[next-history-element] \
to pull the file attributes of the file at point
into the minibuffer."
- (interactive "P")
+ (interactive "P" dired-mode)
(dired-do-chxxx "Timestamp" dired-touch-program 'touch arg))
;; Process all the files in FILES in batches of a convenient size,
@@ -616,7 +621,7 @@ into the minibuffer."
"Print the marked (or next ARG) files.
Uses the shell command coming from variables `lpr-command' and
`lpr-switches' as default."
- (interactive "P")
+ (interactive "P" dired-mode)
(require 'lpr)
(let* ((file-list (dired-get-marked-files t arg nil nil t))
(lpr-switches
@@ -634,7 +639,8 @@ Uses the shell command coming from variables `lpr-command' and
lpr-switches))
" ")
'print arg file-list)))
- (dired-run-shell-command (dired-shell-stuff-it command file-list nil))))
+ (dired-run-shell-command (dired-shell-stuff-it command file-list nil)))
+ (dired-post-do-command))
(defun dired-mark-read-string (prompt initial op-symbol arg files
&optional default-value collection)
@@ -671,7 +677,7 @@ Negative prefix arg KEEP overrides `kept-old-versions' with KEEP made positive.
To clear the flags on these files, you can use \\[dired-flag-backup-files]
with a prefix argument."
- (interactive "P")
+ (interactive "P" dired-mode)
(setq keep (if keep (prefix-numeric-value keep) dired-kept-versions))
(let ((early-retention (if (< keep 0) (- keep) kept-old-versions))
(late-retention (if (<= keep 0) dired-kept-versions keep))
@@ -757,22 +763,6 @@ with a prefix argument."
;;; Shell commands
-(declare-function mailcap-file-default-commands "mailcap" (files))
-
-(defvar dired-aux-files)
-
-(defun dired-minibuffer-default-add-shell-commands ()
- "Return a list of all commands associated with current Dired files.
-This function is used to add all related commands retrieved by `mailcap'
-to the end of the list of defaults just after the default value."
- (interactive)
- (let ((commands (and (boundp 'dired-aux-files)
- (require 'mailcap nil t)
- (mailcap-file-default-commands dired-aux-files))))
- (if (listp minibuffer-default)
- (append minibuffer-default commands)
- (cons minibuffer-default commands))))
-
;; This is an extra function so that you can redefine it, e.g., to use gmhist.
(defun dired-read-shell-command (prompt arg files)
"Read a Dired shell command.
@@ -783,14 +773,9 @@ file names. The result is used as the prompt.
Use `dired-guess-shell-command' to offer a smarter default choice
of shell command."
- (minibuffer-with-setup-hook
- (lambda ()
- (setq-local dired-aux-files files)
- (setq-local minibuffer-default-add-function
- #'dired-minibuffer-default-add-shell-commands))
- (setq prompt (format prompt (dired-mark-prompt arg files)))
- (dired-mark-pop-up nil 'shell files
- 'dired-guess-shell-command prompt files)))
+ (setq prompt (format prompt (dired-mark-prompt arg files)))
+ (dired-mark-pop-up nil 'shell files
+ 'dired-guess-shell-command prompt files))
;;;###autoload
(defcustom dired-confirm-shell-command t
@@ -825,7 +810,8 @@ Commands that are run asynchronously do not accept user input."
;; Want to give feedback whether this file or marked files are used:
(dired-read-shell-command "& on %s: " current-prefix-arg files)
current-prefix-arg
- files)))
+ files))
+ dired-mode)
(unless (string-match-p "&[ \t]*\\'" command)
(setq command (concat command " &")))
(dired-do-shell-command command arg file-list))
@@ -892,7 +878,8 @@ Also see the `dired-confirm-shell-command' variable."
;; Want to give feedback whether this file or marked files are used:
(dired-read-shell-command "! on %s: " current-prefix-arg files)
current-prefix-arg
- files)))
+ files))
+ dired-mode)
(let* ((on-each (not (dired--star-or-qmark-p command "*" 'keep)))
(no-subst (not (dired--star-or-qmark-p command "?" 'keep)))
(confirmations nil)
@@ -918,7 +905,8 @@ Also see the `dired-confirm-shell-command' variable."
nil file-list)
;; execute the shell command
(dired-run-shell-command
- (dired-shell-stuff-it command file-list nil arg)))))))
+ (dired-shell-stuff-it command file-list nil arg))))))
+ (dired-post-do-command))
;; Might use {,} for bash or csh:
(defvar dired-mark-prefix ""
@@ -957,7 +945,7 @@ Also see the `dired-confirm-shell-command' variable."
;; "&" instead.
(cmd-sep (if (and (or (not w32-shell) file-remote)
(not parallel-in-background))
- ";" "&"))
+ "; " "& "))
(stuff-it
(if (dired--star-or-qmark-p command nil 'keep)
(lambda (x)
@@ -988,7 +976,7 @@ Also see the `dired-confirm-shell-command' variable."
;; Add 'wait' to force those POSIX shells to wait until
;; all commands finish.
(or (and parallel-in-background (not w32-shell)
- " &wait")
+ " & wait")
"")))
(t
(let ((files (mapconcat #'shell-quote-argument
@@ -1000,9 +988,9 @@ Also see the `dired-confirm-shell-command' variable."
;; Be consistent in how we treat inputs to commands -- do
;; the same here as in the `on-each' case.
(if (and in-background (not w32-shell))
- " &wait"
+ " & wait"
"")))))
- (or (and in-background "&")
+ (or (and in-background "& ")
""))))
;; This is an extra function so that it can be redefined by ange-ftp.
@@ -1307,7 +1295,7 @@ See `dired-guess-shell-alist-user'."
;;;###autoload
(defun dired-guess-shell-command (prompt files)
"Ask user with PROMPT for a shell command, guessing a default from FILES."
- (let ((default (dired-guess-default files))
+ (let ((default (shell-command-guess files))
default-list val)
(if (null default)
;; Nothing to guess
@@ -1331,6 +1319,125 @@ See `dired-guess-shell-alist-user'."
;; If we got a return, then return default.
(if (equal val "") default val))))
+(defcustom shell-command-guess-functions
+ '(shell-command-guess-dired)
+ "List of functions that guess shell commands for files.
+Each function receives a list of commands and a list of file names
+and should return the same list of commands with changes
+such as added new commands."
+ :type '(repeat
+ (choice (function-item shell-command-guess-dired)
+ (function-item shell-command-guess-mailcap)
+ (function-item shell-command-guess-xdg)
+ (function-item shell-command-guess-open)
+ (function :tag "Custom function")))
+ :group 'dired
+ :version "30.1")
+
+(defun shell-command-guess (files)
+ "Return a list of shell commands, appropriate for FILES.
+The list is populated by calling functions from
+`shell-command-guess-functions'. Each function receives the list
+of commands and the list of file names and returns the same list
+after adding own commands to the composite list."
+ (let ((commands nil))
+ (run-hook-wrapped 'shell-command-guess-functions
+ (lambda (fun)
+ (setq commands (funcall fun commands files))
+ nil))
+ commands))
+
+(defun shell-command-guess-dired (commands files)
+ "Populate COMMANDS using `dired-guess-default'."
+ (append (ensure-list (dired-guess-default files)) commands))
+
+(declare-function mailcap-file-default-commands "mailcap" (files))
+
+(defun shell-command-guess-mailcap (commands files)
+ "Populate COMMANDS by MIME types of FILES."
+ (require 'mailcap)
+ (append (mailcap-file-default-commands files) commands))
+
+(declare-function xdg-mime-apps "xdg" (mime))
+(declare-function xdg-desktop-read-file "xdg" (filename &optional group))
+
+(defun shell-command-guess-xdg (commands files)
+ "Populate COMMANDS by XDG configuration for FILES."
+ (require 'xdg)
+ (let* ((xdg-mime (when (executable-find "xdg-mime")
+ (string-trim-right
+ (shell-command-to-string
+ (concat "xdg-mime query filetype "
+ (shell-quote-argument (car files)))))))
+ (xdg-mime-apps (unless (string-empty-p xdg-mime)
+ (xdg-mime-apps xdg-mime)))
+ (xdg-commands
+ (mapcar (lambda (desktop)
+ (setq desktop (xdg-desktop-read-file desktop))
+ (propertize
+ (replace-regexp-in-string
+ " .*" "" (gethash "Exec" desktop))
+ 'name (gethash "Name" desktop)))
+ xdg-mime-apps)))
+ (append xdg-commands commands)))
+
+(defcustom shell-command-guess-open
+ (cond
+ ((executable-find "xdg-open")
+ "xdg-open")
+ ((memq system-type '(gnu/linux darwin))
+ "open")
+ ((memq system-type '(windows-nt ms-dos))
+ "start")
+ ((eq system-type 'cygwin)
+ "cygstart")
+ ((executable-find "run-mailcap")
+ "run-mailcap"))
+ "A shell command to open a file externally."
+ :type 'string
+ :group 'dired
+ :version "30.1")
+
+(defun shell-command-guess-open (commands _files)
+ "Populate COMMANDS by the `open' command."
+ (append (ensure-list shell-command-guess-open) commands))
+
+(declare-function w32-shell-execute "w32fns.c")
+
+(defun dired-do-open (&optional arg)
+ "Open all marked (or next ARG) files using an external program.
+This \"opens\" the file(s) using the external command that is most
+appropriate for the file(s) according to the system conventions.
+If files are marked, run the command on each marked file. Otherwise,
+run it on the next ARG files, or on the file at mouse-click, or on the
+file at point. The appropriate command to \"open\" a file on each
+system is determined by `shell-command-guess-open'."
+ (interactive "P" dired-mode)
+ (let ((files (if (mouse-event-p last-nonmenu-event)
+ (save-excursion
+ (mouse-set-point last-nonmenu-event)
+ (dired-get-marked-files nil arg))
+ (dired-get-marked-files nil arg)))
+ (command shell-command-guess-open))
+ (when (and (memq system-type '(windows-nt))
+ (equal command "start"))
+ (setq command "open"))
+ (when command
+ (dolist (file files)
+ (cond
+ ((memq system-type '(gnu/linux))
+ (call-process command nil 0 nil file))
+ ((memq system-type '(ms-dos))
+ (shell-command (concat command " " (shell-quote-argument file))))
+ ((memq system-type '(windows-nt))
+ (w32-shell-execute command (convert-standard-filename file)))
+ ((memq system-type '(cygwin))
+ (call-process command nil nil nil file))
+ ((memq system-type '(darwin))
+ (start-process (concat command " " file) nil command file))
+ (t
+ (error "Open not supported on this system")))))))
+
;;; Commands that delete or redisplay part of the dired buffer
@@ -1338,7 +1445,7 @@ See `dired-guess-shell-alist-user'."
"Kill the current line (not the files).
With a prefix argument, kill that many lines starting with the current line.
(A negative argument kills backward.)"
- (interactive "P")
+ (interactive "P" dired-mode)
(setq arg (prefix-numeric-value arg))
(let (buffer-read-only file)
(while (/= 0 arg)
@@ -1360,7 +1467,7 @@ With a prefix argument, kill that many lines starting with the current line.
(defun dired-do-kill-lines (&optional arg fmt init-count)
"Remove all marked lines, or the next ARG lines.
The files or directories on those lines are _not_ deleted. Only the
-Dired listing is affected. To restore the removals, use `\\[revert-buffer]'.
+Dired listing is affected. To restore the removals, use \\[revert-buffer].
With a numeric prefix arg, remove that many lines going forward,
starting with the current line. (A negative prefix arg removes lines
@@ -1379,7 +1486,7 @@ lines removed by this invocation, for the reporting message.
A FMT of \"\" will suppress the messaging."
;; Returns count of killed lines.
- (interactive "P")
+ (interactive "P" dired-mode)
(if arg
(if (dired-get-subdir)
(dired-kill-subdir)
@@ -1516,7 +1623,7 @@ output file. %i path(s) are relative, while %o is absolute.")
Prompt for the archive file name.
Choose the archiving command based on the archive file-name extension
and `dired-compress-files-alist'."
- (interactive)
+ (interactive nil dired-mode)
(let* ((in-files (dired-get-marked-files nil nil nil nil t))
(out-file (expand-file-name (read-file-name "Compress to: ")))
(rule (cl-find-if
@@ -1547,7 +1654,8 @@ and `dired-compress-files-alist'."
"Compressed %d files to %s"
(length in-files))
(length in-files)
- (file-name-nondirectory out-file)))))))
+ (file-name-nondirectory out-file))))))
+ (dired-post-do-command))
;;;###autoload
(defun dired-compress-file (file)
@@ -1753,7 +1861,7 @@ the directory and all of its subdirectories, recursively,
into a .tar.gz archive.
If invoked on a .tar.gz or a .tgz or a .zip or a .7z archive,
uncompress and unpack all the files in the archive."
- (interactive "P")
+ (interactive "P" dired-mode)
(dired-map-over-marks-check #'dired-compress arg 'compress t))
@@ -1782,7 +1890,7 @@ uncompress and unpack all the files in the archive."
;;;###autoload
(defun dired-do-byte-compile (&optional arg)
"Byte compile marked (or next ARG) Emacs Lisp files."
- (interactive "P")
+ (interactive "P" dired-mode)
(dired-map-over-marks-check #'dired-byte-compile arg 'byte-compile t))
(defun dired-load ()
@@ -1799,7 +1907,7 @@ uncompress and unpack all the files in the archive."
;;;###autoload
(defun dired-do-load (&optional arg)
"Load the marked (or next ARG) Emacs Lisp files."
- (interactive "P")
+ (interactive "P" dired-mode)
(dired-map-over-marks-check #'dired-load arg 'load t))
;;;###autoload
@@ -1816,7 +1924,7 @@ You can reset all subdirectory switches to the default using
\\<dired-mode-map>\\[dired-reset-subdir-switches].
See Info node `(emacs)Subdir switches' for more details."
;; Moves point if the next ARG files are redisplayed.
- (interactive "P\np")
+ (interactive "P\np" dired-mode)
(if (and test-for-subdir (dired-get-subdir))
(let* ((dir (dired-get-subdir))
(switches (cdr (assoc-string dir dired-switches-alist))))
@@ -1846,7 +1954,7 @@ See Info node `(emacs)Subdir switches' for more details."
(defun dired-reset-subdir-switches ()
"Set `dired-switches-alist' to nil and revert Dired buffer."
- (interactive)
+ (interactive nil dired-mode)
(setq dired-switches-alist nil)
(revert-buffer))
@@ -2475,86 +2583,97 @@ Optional arg HOW-TO determines how to treat the target.
For any other return value, TARGET is treated as a directory."
(or op1 (setq op1 operation))
- (let* ((fn-list (dired-get-marked-files nil arg nil nil t))
- (rfn-list (mapcar #'dired-make-relative fn-list))
- (dired-one-file ; fluid variable inside dired-create-files
- (and (consp fn-list) (null (cdr fn-list)) (car fn-list)))
- (target-dir (dired-dwim-target-directory))
- (default (and dired-one-file
- (not dired-dwim-target) ; Bug#25609
- (expand-file-name (file-name-nondirectory (car fn-list))
- target-dir)))
- (defaults (dired-dwim-target-defaults fn-list target-dir))
- (target (expand-file-name ; fluid variable inside dired-create-files
- (minibuffer-with-setup-hook
- (lambda ()
- (setq-local minibuffer-default-add-function nil)
- (setq minibuffer-default defaults))
- (dired-mark-read-file-name
- (format "%s %%s %s: "
- (if dired-one-file op1 operation)
- (if (memq op-symbol '(symlink hardlink))
- ;; Linking operations create links
- ;; from the prompted file name; the
- ;; other operations copy (etc) to the
- ;; prompted file name.
- "from" "to"))
- target-dir op-symbol arg rfn-list default))))
- (into-dir
- (progn
- (when
- (or
- (not dired-one-file)
- (and dired-create-destination-dirs-on-trailing-dirsep
- (directory-name-p target)))
- (dired-maybe-create-dirs target))
- (cond ((null how-to)
- ;; Allow users to change the letter case of
- ;; a directory on a case-insensitive
- ;; filesystem. If we don't test these
- ;; conditions up front, file-directory-p
- ;; below will return t on a case-insensitive
- ;; filesystem, and Emacs will try to move
- ;; foo -> foo/foo, which fails.
- (if (and (file-name-case-insensitive-p (car fn-list))
- (eq op-symbol 'move)
- dired-one-file
- (string= (downcase
- (expand-file-name (car fn-list)))
- (downcase
- (expand-file-name target)))
- (not (string=
- (file-name-nondirectory (car fn-list))
- (file-name-nondirectory target))))
- nil
- (file-directory-p target)))
- ((eq how-to t) nil)
- (t (funcall how-to target))))))
- (if (and (consp into-dir) (functionp (car into-dir)))
- (apply (car into-dir) operation rfn-list fn-list target (cdr into-dir))
- (if (not (or dired-one-file into-dir))
- (error "Marked %s: target must be a directory: %s" operation target))
- (if (and (not (file-directory-p (car fn-list)))
- (not (file-directory-p target))
- (directory-name-p target))
- (error "%s: Target directory does not exist: %s" operation target))
- ;; rename-file bombs when moving directories unless we do this:
- (or into-dir (setq target (directory-file-name target)))
- (prog1
- (dired-create-files
- file-creator operation fn-list
- (if into-dir ; target is a directory
- ;; This function uses fluid variable target when called
- ;; inside dired-create-files:
- (lambda (from)
- (expand-file-name (file-name-nondirectory from) target))
- (lambda (_from) target))
- marker-char)
- (when (or (eq dired-do-revert-buffer t)
- (and (functionp dired-do-revert-buffer)
- (funcall dired-do-revert-buffer target)))
- (dired-fun-in-all-buffers (file-name-directory target) nil
- #'revert-buffer))))))
+ (let ((ret nil))
+ (let* ((fn-list (dired-get-marked-files nil arg nil nil t))
+ (rfn-list (mapcar #'dired-make-relative fn-list))
+ (dired-one-file ; fluid variable inside dired-create-files
+ (and (consp fn-list) (null (cdr fn-list)) (car fn-list)))
+ (target-dir (dired-dwim-target-directory))
+ (default (and dired-one-file
+ (not dired-dwim-target) ; Bug#25609
+ (expand-file-name (file-name-nondirectory
+ (car fn-list))
+ target-dir)))
+ (defaults (dired-dwim-target-defaults fn-list target-dir))
+ (target (expand-file-name ; fluid variable inside dired-create-files
+ (minibuffer-with-setup-hook
+ (lambda ()
+ (setq-local minibuffer-default-add-function nil)
+ (setq minibuffer-default defaults))
+ (dired-mark-read-file-name
+ (format "%s %%s %s: "
+ (if dired-one-file op1 operation)
+ (if (memq op-symbol '(symlink hardlink))
+ ;; Linking operations create links
+ ;; from the prompted file name; the
+ ;; other operations copy (etc) to the
+ ;; prompted file name.
+ "from" "to"))
+ target-dir op-symbol arg rfn-list default))))
+ (into-dir
+ (progn
+ (when
+ (or
+ (not dired-one-file)
+ (and dired-create-destination-dirs-on-trailing-dirsep
+ (directory-name-p target)))
+ (dired-maybe-create-dirs target))
+ (cond ((null how-to)
+ ;; Allow users to change the letter case of
+ ;; a directory on a case-insensitive
+ ;; filesystem. If we don't test these
+ ;; conditions up front, file-directory-p
+ ;; below will return t on a case-insensitive
+ ;; filesystem, and Emacs will try to move
+ ;; foo -> foo/foo, which fails.
+ (if (and (file-name-case-insensitive-p (car fn-list))
+ (eq op-symbol 'move)
+ dired-one-file
+ (string= (downcase
+ (expand-file-name (car fn-list)))
+ (downcase
+ (expand-file-name target)))
+ (not (string=
+ (file-name-nondirectory (car fn-list))
+ (file-name-nondirectory target))))
+ nil
+ (file-directory-p target)))
+ ((eq how-to t) nil)
+ (t (funcall how-to target))))))
+ (setq ret
+ (if (and (consp into-dir) (functionp (car into-dir)))
+ (apply (car into-dir) operation rfn-list fn-list target
+ (cdr into-dir))
+ (if (not (or dired-one-file into-dir))
+ (error "Marked %s: target must be a directory: %s"
+ operation target))
+ (if (and (not (file-directory-p (car fn-list)))
+ (not (file-directory-p target))
+ (directory-name-p target))
+ (error "%s: Target directory does not exist: %s"
+ operation target))
+ ;; rename-file bombs when moving directories unless we do this:
+ (or into-dir (setq target (directory-file-name target)))
+ (prog1
+ (dired-create-files
+ file-creator operation fn-list
+ (if into-dir ; target is a directory
+ ;; This function uses fluid variable target when called
+ ;; inside dired-create-files:
+ (lambda (from)
+ (expand-file-name (file-name-nondirectory from)
+ target))
+ (lambda (_from) target))
+ marker-char)
+ (when (or (eq dired-do-revert-buffer t)
+ (and (functionp dired-do-revert-buffer)
+ (funcall dired-do-revert-buffer target)))
+ (dired-fun-in-all-buffers (file-name-directory target) nil
+ #'revert-buffer))))))
+ (dired-post-do-command)
+ ;; The return value isn't very well defined but is used by
+ ;; `dired-test-bug30624'.
+ ret))
;; Read arguments for a marked-files command that wants a file name,
;; perhaps popping up the list of marked files.
@@ -2675,7 +2794,8 @@ FILENAME is a full file name."
Parent directories of DIRECTORY are created as needed.
If DIRECTORY already exists, signal an error."
(interactive
- (list (read-file-name "Create directory: " (dired-current-directory))))
+ (list (read-file-name "Create directory: " (dired-current-directory)))
+ dired-mode)
(let* ((expanded (directory-file-name (expand-file-name directory)))
new)
(if (file-exists-p expanded)
@@ -2692,7 +2812,7 @@ If DIRECTORY already exists, signal an error."
Add a new entry for the new file in the Dired buffer.
Parent directories of FILE are created as needed.
If FILE already exists, signal an error."
- (interactive (list (read-file-name "Create empty file: ")))
+ (interactive (list (read-file-name "Create empty file: ")) dired-mode)
(let* ((expanded (expand-file-name file))
new)
(if (file-exists-p expanded)
@@ -2751,11 +2871,11 @@ similar to the \"-d\" option for the \"cp\" shell command.
But if `dired-copy-dereference' is non-nil, the symbolic
links are dereferenced and then copied, similar to the \"-L\"
option for the \"cp\" shell command. If ARG is a cons with
-element 4 (`\\[universal-argument]'), the inverted value of
+element 4 (\\[universal-argument]), the inverted value of
`dired-copy-dereference' will be used.
Also see `dired-do-revert-buffer'."
- (interactive "P")
+ (interactive "P" dired-mode)
(let ((dired-recursive-copies dired-recursive-copies)
(dired-copy-dereference (if (equal arg '(4))
(not dired-copy-dereference)
@@ -2778,7 +2898,7 @@ suggested for the target directory depends on the value of
For relative symlinks, use \\[dired-do-relsymlink].
Also see `dired-do-revert-buffer'."
- (interactive "P")
+ (interactive "P" dired-mode)
(dired-do-create-files 'symlink #'make-symbolic-link
"Symlink" arg dired-keep-marker-symlink))
@@ -2795,7 +2915,7 @@ not absolute ones like
foo -> /ugly/file/name/that/may/change/any/day/bar/foo
For absolute symlinks, use \\[dired-do-symlink]."
- (interactive "P")
+ (interactive "P" dired-mode)
(dired-do-create-files 'relsymlink #'dired-make-relative-symlink
"RelSymLink" arg dired-keep-marker-relsymlink))
@@ -2860,7 +2980,7 @@ suggested for the target directory depends on the value of
`dired-dwim-target', which see.
Also see `dired-do-revert-buffer'."
- (interactive "P")
+ (interactive "P" dired-mode)
(dired-do-create-files 'hardlink #'dired-hardlink
"Hardlink" arg dired-keep-marker-hardlink))
@@ -2881,13 +3001,14 @@ The default suggested for the target directory depends on the value
of `dired-dwim-target', which see.
Also see `dired-do-revert-buffer'."
- (interactive "P")
+ (interactive "P" dired-mode)
(when (seq-find (lambda (file)
(member (file-name-nondirectory file) '("." "..")))
(dired-get-marked-files nil arg))
(user-error "Can't rename \".\" or \"..\" files"))
(dired-do-create-files 'move #'dired-rename-file
- "Move" arg dired-keep-marker-rename "Rename"))
+ "Move" arg dired-keep-marker-rename "Rename")
+ (dired-post-do-command))
;;; Operate on files matched by regexp
@@ -2979,7 +3100,7 @@ REGEXP defaults to the last regexp used.
With a zero prefix arg, renaming by regexp affects the absolute file name.
Normally, only the non-directory part of the file name is used and changed."
- (interactive (dired-mark-read-regexp "Rename"))
+ (interactive (dired-mark-read-regexp "Rename") dired-mode)
(dired-do-create-files-regexp
#'dired-rename-file
"Rename" arg regexp newname whole-name dired-keep-marker-rename))
@@ -2988,7 +3109,7 @@ Normally, only the non-directory part of the file name is used and changed."
(defun dired-do-copy-regexp (regexp newname &optional arg whole-name)
"Copy selected files whose names match REGEXP to NEWNAME.
See function `dired-do-rename-regexp' for more info."
- (interactive (dired-mark-read-regexp "Copy"))
+ (interactive (dired-mark-read-regexp "Copy") dired-mode)
(let ((dired-recursive-copies nil)) ; No recursive copies.
(dired-do-create-files-regexp
#'dired-copy-file
@@ -2999,7 +3120,7 @@ See function `dired-do-rename-regexp' for more info."
(defun dired-do-hardlink-regexp (regexp newname &optional arg whole-name)
"Hardlink selected files whose names match REGEXP to NEWNAME.
See function `dired-do-rename-regexp' for more info."
- (interactive (dired-mark-read-regexp "HardLink"))
+ (interactive (dired-mark-read-regexp "HardLink") dired-mode)
(dired-do-create-files-regexp
#'add-name-to-file
"HardLink" arg regexp newname whole-name dired-keep-marker-hardlink))
@@ -3008,7 +3129,7 @@ See function `dired-do-rename-regexp' for more info."
(defun dired-do-symlink-regexp (regexp newname &optional arg whole-name)
"Symlink selected files whose names match REGEXP to NEWNAME.
See function `dired-do-rename-regexp' for more info."
- (interactive (dired-mark-read-regexp "SymLink"))
+ (interactive (dired-mark-read-regexp "SymLink") dired-mode)
(dired-do-create-files-regexp
#'make-symbolic-link
"SymLink" arg regexp newname whole-name dired-keep-marker-symlink))
@@ -3018,7 +3139,7 @@ See function `dired-do-rename-regexp' for more info."
"RelSymlink all marked files containing REGEXP to NEWNAME.
See functions `dired-do-rename-regexp' and `dired-do-relsymlink'
for more info."
- (interactive (dired-mark-read-regexp "RelSymLink"))
+ (interactive (dired-mark-read-regexp "RelSymLink") dired-mode)
(dired-do-create-files-regexp
#'dired-make-relative-symlink
"RelSymLink" arg regexp newname whole-name dired-keep-marker-relsymlink))
@@ -3063,13 +3184,13 @@ Type \\`SPC' or \\`y' to %s one file, \\`DEL' or \\`n' to skip to next,
;;;###autoload
(defun dired-upcase (&optional arg)
"Rename all marked (or next ARG) files to upper case."
- (interactive "P")
+ (interactive "P" dired-mode)
(dired-rename-non-directory #'upcase "Rename upcase" arg))
;;;###autoload
(defun dired-downcase (&optional arg)
"Rename all marked (or next ARG) files to lower case."
- (interactive "P")
+ (interactive "P" dired-mode)
(dired-rename-non-directory #'downcase "Rename downcase" arg))
@@ -3097,7 +3218,8 @@ See Info node `(emacs)Subdir switches' for more details."
(list (dired-get-filename)
(if current-prefix-arg
(read-string "Switches for listing: "
- (or dired-subdir-switches dired-actual-switches)))))
+ (or dired-subdir-switches dired-actual-switches))))
+ dired-mode)
(let ((opoint (point)))
;; We don't need a marker for opoint as the subdir is always
;; inserted *after* opoint.
@@ -3129,7 +3251,8 @@ This function takes some pains to conform to `ls -lR' output."
(list (dired-get-filename)
(if current-prefix-arg
(read-string "Switches for listing: "
- (or dired-subdir-switches dired-actual-switches)))))
+ (or dired-subdir-switches dired-actual-switches))))
+ dired-mode)
(setq dirname (file-name-as-directory (expand-file-name dirname)))
(or no-error-if-not-dir-p
(file-directory-p dirname)
@@ -3206,7 +3329,7 @@ In interactive use, the command prompts for DIRNAME.
When called from Lisp, if REMEMBER-MARKS is non-nil, return an alist
of marked files. If KILL-ROOT is non-nil, kill DIRNAME as well."
- (interactive "DKill tree below directory: \ni\nP")
+ (interactive "DKill tree below directory: \ni\nP" dired-mode)
(setq dirname (file-name-as-directory (expand-file-name dirname)))
(let ((s-alist dired-subdir-alist) dir m-alist)
(while s-alist
@@ -3360,7 +3483,8 @@ When called interactively and not on a subdir line, go to this subdir's line."
(list (if current-prefix-arg
(prefix-numeric-value current-prefix-arg)
;; if on subdir start already, don't stay there!
- (if (dired-get-subdir) 1 0))))
+ (if (dired-get-subdir) 1 0)))
+ dired-mode)
(dired-next-subdir (- arg) no-error-if-not-found no-skip))
;;;###autoload
@@ -3393,7 +3517,7 @@ The next char is \\n."
"Mark all files except `.' and `..' in current subdirectory.
If the Dired buffer shows multiple directories, this command
marks the files listed in the subdirectory that point is in."
- (interactive)
+ (interactive nil dired-mode)
(let ((p-min (dired-subdir-min)))
(dired-mark-files-in-region p-min (dired-subdir-max))))
@@ -3402,7 +3526,7 @@ marks the files listed in the subdirectory that point is in."
"Remove all lines of current subdirectory.
Lower levels are unaffected."
;; With optional REMEMBER-MARKS, return a mark-alist.
- (interactive)
+ (interactive nil dired-mode)
(let* ((beg (dired-subdir-min))
(end (dired-subdir-max))
(modflag (buffer-modified-p))
@@ -3429,7 +3553,7 @@ Lower levels are unaffected."
;;;###autoload
(defun dired-tree-up (arg)
"Go up ARG levels in the Dired tree."
- (interactive "p")
+ (interactive "p" dired-mode)
(let ((dir (dired-current-directory)))
(while (>= arg 1)
(setq arg (1- arg)
@@ -3441,7 +3565,7 @@ Lower levels are unaffected."
;;;###autoload
(defun dired-tree-down ()
"Go down in the Dired tree."
- (interactive)
+ (interactive nil dired-mode)
(let ((dir (dired-current-directory)) ; has slash
pos case-fold-search) ; filenames are case sensitive
(let ((rest (reverse dired-subdir-alist)) elt)
@@ -3463,7 +3587,7 @@ Lower levels are unaffected."
"Hide or unhide the current subdirectory and move to next directory.
Optional prefix arg is a repeat factor.
Use \\[dired-hide-all] to (un)hide all directories."
- (interactive "p")
+ (interactive "p" dired-mode)
(with-silent-modifications
(while (>= (setq arg (1- arg)) 0)
(let* ((cur-dir (dired-current-directory))
@@ -3484,7 +3608,7 @@ Use \\[dired-hide-all] to (un)hide all directories."
"Hide all subdirectories, leaving only their header lines.
If there is already something hidden, make everything visible again.
Use \\[dired-hide-subdir] to (un)hide a particular subdirectory."
- (interactive "P")
+ (interactive "P" dired-mode)
(with-silent-modifications
(if (text-property-any (point-min) (point-max) 'invisible 'dired)
(dired--unhide (point-min) (point-max))
@@ -3560,14 +3684,14 @@ It's intended to override the default search function."
;;;###autoload
(defun dired-isearch-filenames ()
"Search for a string using Isearch only in file names in the Dired buffer."
- (interactive)
+ (interactive nil dired-mode)
(setq-local dired-isearch-filenames t)
(isearch-forward nil t))
;;;###autoload
(defun dired-isearch-filenames-regexp ()
"Search for a regexp using Isearch only in file names in the Dired buffer."
- (interactive)
+ (interactive nil dired-mode)
(setq-local dired-isearch-filenames t)
(isearch-forward-regexp nil t))
@@ -3577,16 +3701,20 @@ It's intended to override the default search function."
;;;###autoload
(defun dired-do-isearch ()
"Search for a string through all marked files using Isearch."
- (interactive)
+ (interactive nil dired-mode)
(multi-isearch-files
- (dired-get-marked-files nil nil #'dired-nondirectory-p nil t)))
+ (prog1 (dired-get-marked-files nil nil
+ #'dired-nondirectory-p nil t)
+ (dired-post-do-command))))
;;;###autoload
(defun dired-do-isearch-regexp ()
"Search for a regexp through all marked files using Isearch."
- (interactive)
- (multi-isearch-files-regexp
- (dired-get-marked-files nil nil 'dired-nondirectory-p nil t)))
+ (interactive nil dired-mode)
+ (prog1 (multi-isearch-files-regexp
+ (dired-get-marked-files nil nil
+ 'dired-nondirectory-p nil t))
+ (dired-post-do-command)))
(declare-function fileloop-continue "fileloop" ())
@@ -3598,11 +3726,12 @@ If no files are marked, search through the file under point.
Stops when a match is found.
To continue searching for next match, use command \\[fileloop-continue]."
- (interactive "sSearch marked files (regexp): ")
+ (interactive "sSearch marked files (regexp): " dired-mode)
(fileloop-initialize-search
regexp
(dired-get-marked-files nil nil #'dired-nondirectory-p)
'default)
+ (dired-post-do-command)
(fileloop-continue))
;;;###autoload
@@ -3620,18 +3749,36 @@ resume the query replace with the command \\[fileloop-continue]."
(let ((common
(query-replace-read-args
"Query replace regexp in marked files" t t)))
- (list (nth 0 common) (nth 1 common) (nth 2 common))))
+ (list (nth 0 common) (nth 1 common) (nth 2 common)))
+ dired-mode)
(dolist (file (dired-get-marked-files nil nil #'dired-nondirectory-p nil t))
(let ((buffer (get-file-buffer file)))
(if (and buffer (with-current-buffer buffer
buffer-read-only))
(error "File `%s' is visited read-only" file))))
+ (dired-post-do-command)
(fileloop-initialize-replace
from to (dired-get-marked-files nil nil #'dired-nondirectory-p)
(if (equal from (downcase from)) nil 'default)
delimited)
(fileloop-continue))
+;;;###autoload
+(defun dired-do-replace-regexp-as-diff (from to &optional delimited)
+ "Do `replace-regexp' of FROM with TO as diff, on all marked files.
+Third arg DELIMITED (prefix arg) means replace only word-delimited matches.
+The replacements are displayed in the buffer *replace-diff* that
+you can later apply as a patch after reviewing the changes."
+ (interactive
+ (let ((common
+ (query-replace-read-args
+ "Replace regexp as diff in marked files" t t)))
+ (list (nth 0 common) (nth 1 common) (nth 2 common))))
+ (dired-post-do-command)
+ (multi-file-replace-regexp-as-diff
+ (dired-get-marked-files nil nil #'dired-nondirectory-p)
+ from to delimited))
+
(declare-function xref-query-replace-in-results "xref")
(declare-function project--files-in-directory "project")
@@ -3647,7 +3794,7 @@ matching `grep-find-ignored-directories' are skipped in the marked
directories.
REGEXP should use constructs supported by your local `grep' command."
- (interactive "sSearch marked files (regexp): ")
+ (interactive "sSearch marked files (regexp): " dired-mode)
(require 'grep)
(require 'xref)
(defvar grep-find-ignored-files)
@@ -3675,6 +3822,7 @@ REGEXP should use constructs supported by your local `grep' command."
(user-error "No matches for: %s" regexp))
(message "Searching...done")
xrefs))))
+ (dired-post-do-command)
(xref-show-xrefs fetcher nil)))
;;;###autoload
@@ -3701,7 +3849,8 @@ function works."
(let ((common
(query-replace-read-args
"Query replace regexp in marked files" t t)))
- (list (nth 0 common) (nth 1 common))))
+ (list (nth 0 common) (nth 1 common)))
+ dired-mode)
(require 'xref)
(defvar xref-show-xrefs-function)
(defvar xref-auto-jump-to-first-xref)
@@ -3723,14 +3872,14 @@ function works."
If you give a prefix argument \\[universal-argument] to this command, and
FILE is a symbolic link, then the command will print the type
of the target of the link instead."
- (interactive (list (dired-get-filename t) current-prefix-arg))
+ (interactive (list (dired-get-filename t) current-prefix-arg) dired-mode)
(let (process-file-side-effects)
(with-temp-buffer
(if deref-symlinks
(process-file "file" nil t t "-L" "--" file)
(process-file "file" nil t t "--" file))
(when (bolp)
- (backward-delete-char 1))
+ (delete-char -1))
(message "%s" (buffer-string)))))
@@ -3756,7 +3905,7 @@ the same files/directories marked in the VC-Directory buffer that were
marked in the original Dired buffer. If the current directory doesn't
belong to a VCS repository, prompt for a repository directory. In this
case, the VERBOSE argument is ignored."
- (interactive "P")
+ (interactive "P" dired-mode)
(let* ((marked-files
(dired-get-marked-files nil nil nil nil t))
(mark-files
@@ -3767,6 +3916,7 @@ case, the VERBOSE argument is ignored."
(file-name-as-directory file)
file))
marked-files))))
+ (dired-post-do-command)
(if mark-files
(let ((transient-hook (make-symbol "vc-dir-mark-files")))
(fset transient-hook
@@ -3804,9 +3954,6 @@ case, the VERBOSE argument is ignored."
(setq model (vc-checkout-model backend only-files-list))))
(list backend files only-files-list state model)))
-(define-obsolete-function-alias 'minibuffer-default-add-dired-shell-commands
- #'dired-minibuffer-default-add-shell-commands "29.1")
-
(provide 'dired-aux)
diff --git a/lisp/dired-x.el b/lisp/dired-x.el
index 5a494569989..753d3054d2f 100644
--- a/lisp/dired-x.el
+++ b/lisp/dired-x.el
@@ -77,12 +77,17 @@ files not writable by you are visited read-only."
(other :tag "non-writable only" if-file-read-only))
:group 'dired-x)
-(defcustom dired-omit-size-limit 100000
- "Maximum size for the \"omitting\" feature.
+(defcustom dired-omit-size-limit 300000
+ "Maximum buffer size for `dired-omit-mode'.
+
+Omitting will be disabled if the directory listing exceeds this size in
+bytes. This variable is ignored when `dired-omit-mode' is called
+interactively.
+
If nil, there is no maximum size."
:type '(choice (const :tag "no maximum" nil) integer)
:group 'dired-x
- :version "29.1")
+ :version "30.1")
(defcustom dired-omit-case-fold 'filesystem
"Determine whether \"omitting\" patterns are case-sensitive.
@@ -299,9 +304,8 @@ Optional MARKER-CHAR is marker to use.
Interactively, ask for EXTENSION.
Prefixed with one \\[universal-argument], unmark files instead.
Prefixed with two \\[universal-argument]'s, prompt for MARKER-CHAR and mark files with it."
- (interactive (dired--mark-suffix-interactive-spec))
- (unless (listp extension)
- (setq extension (list extension)))
+ (interactive (dired--mark-suffix-interactive-spec) dired-mode)
+ (setq extension (ensure-list extension))
(dired-mark-files-regexp
(concat ".";; don't match names with nothing but an extension
"\\("
@@ -324,9 +328,8 @@ Optional MARKER-CHAR is marker to use.
Interactively, ask for SUFFIX.
Prefixed with one \\[universal-argument], unmark files instead.
Prefixed with two \\[universal-argument]'s, prompt for MARKER-CHAR and mark files with it."
- (interactive (dired--mark-suffix-interactive-spec))
- (unless (listp suffix)
- (setq suffix (list suffix)))
+ (interactive (dired--mark-suffix-interactive-spec) dired-mode)
+ (setq suffix (ensure-list suffix))
(dired-mark-files-regexp
(concat ".";; don't match names with nothing but an extension
"\\("
@@ -337,7 +340,7 @@ Prefixed with two \\[universal-argument]'s, prompt for MARKER-CHAR and mark file
(defun dired-flag-extension (extension)
"In Dired, flag all files with a certain EXTENSION for deletion.
A `.' is *not* automatically prepended to the string entered."
- (interactive "sFlagging extension: ")
+ (interactive "sFlagging extension: " dired-mode)
(dired-mark-extension extension dired-del-marker))
;; Define some unpopular file extensions. Used for cleaning and omitting.
@@ -366,7 +369,7 @@ A `.' is *not* automatically prepended to the string entered."
(defun dired-clean-patch ()
"Flag dispensable files created by patch for deletion.
See variable `dired-patch-unclean-extensions'."
- (interactive)
+ (interactive nil dired-mode)
(dired-flag-extension dired-patch-unclean-extensions))
(defun dired-clean-tex ()
@@ -374,7 +377,7 @@ See variable `dired-patch-unclean-extensions'."
See variables `dired-tex-unclean-extensions',
`dired-latex-unclean-extensions', `dired-bibtex-unclean-extensions' and
`dired-texinfo-unclean-extensions'."
- (interactive)
+ (interactive nil dired-mode)
(dired-flag-extension (append dired-texinfo-unclean-extensions
dired-latex-unclean-extensions
dired-bibtex-unclean-extensions
@@ -385,7 +388,7 @@ See variables `dired-tex-unclean-extensions',
See variables `dired-texinfo-unclean-extensions',
`dired-latex-unclean-extensions', `dired-bibtex-unclean-extensions' and
`dired-texinfo-unclean-extensions'."
- (interactive)
+ (interactive nil dired-mode)
(dired-flag-extension (append dired-texinfo-unclean-extensions
dired-latex-unclean-extensions
dired-bibtex-unclean-extensions
@@ -421,7 +424,7 @@ Should never be used as marker by the user or other packages.")
(defun dired-mark-omitted ()
"Mark files matching `dired-omit-files' and `dired-omit-extensions'."
- (interactive)
+ (interactive nil dired-mode)
(let ((dired-omit-mode nil)) (revert-buffer)) ;; Show omitted files
(dired-mark-unmarked-files (dired-omit-regexp) nil nil dired-omit-localp
(dired-omit-case-fold-p (if (stringp dired-directory)
@@ -457,7 +460,7 @@ if called from Lisp and buffer is bigger than `dired-omit-size-limit'.
Optional arg INIT-COUNT is an initial count tha'is added to the number
of lines omitted by this invocation of `dired-omit-expunge', in the
status message."
- (interactive "sOmit files (regexp): \nP")
+ (interactive "sOmit files (regexp): \nP" dired-mode)
;; Bind `dired-marker-char' to `dired-omit-marker-char',
;; then call `dired-do-kill-lines'.
(if (and dired-omit-mode
@@ -493,7 +496,11 @@ status message."
(setq count (+ count
(dired-do-kill-lines
nil
- (if dired-omit-verbose "Omitted %d line%s" "")
+ (if dired-omit-verbose
+ (format "Omitted %%d line%%s in %s"
+ (abbreviate-file-name
+ dired-directory))
+ "")
init-count)))
(force-mode-line-update))))
;; Try to preserve modified state, so `%*' doesn't appear in
@@ -504,14 +511,23 @@ status message."
(re-search-forward dired-re-mark nil t))))
count)))
+(defvar dired-omit--extension-regexp-cache
+ nil
+ "A cache of `regexp-opt' applied to `dired-omit-extensions'.
+
+This is a cons whose car is a list of strings and whose cdr is a
+regexp produced by `regexp-opt'.")
+
(defun dired-omit-regexp ()
+ (unless (equal dired-omit-extensions (car dired-omit--extension-regexp-cache))
+ (setq dired-omit--extension-regexp-cache
+ (cons dired-omit-extensions (regexp-opt dired-omit-extensions))))
(concat (if dired-omit-files (concat "\\(" dired-omit-files "\\)") "")
(if (and dired-omit-files dired-omit-extensions) "\\|" "")
(if dired-omit-extensions
(concat ".";; a non-extension part should exist
- "\\("
- (mapconcat 'regexp-quote dired-omit-extensions "\\|")
- "\\)$")
+ (cdr dired-omit--extension-regexp-cache)
+ "$")
"")))
;; Returns t if any work was done, nil otherwise.
@@ -529,7 +545,8 @@ files in the active region if `dired-mark-region' is non-nil."
(list (read-regexp
(format-prompt "Mark unmarked files matching regexp" "all")
nil 'dired-regexp-history)
- nil current-prefix-arg nil))
+ nil current-prefix-arg nil)
+ dired-mode)
(let ((dired-marker-char (if unflag-p ?\s dired-marker-char)))
(dired-mark-if
(and
@@ -610,7 +627,8 @@ you can relist single subdirs using \\[dired-do-redisplay]."
(insert " "
(directory-file-name (file-name-directory default-directory))
":\n"))
- (dired-mode dirname (or switches dired-listing-switches))
+ (dired-mode
+ dirname (or switches (connection-local-value dired-listing-switches)))
(setq mode-name "Virtual Dired"
revert-buffer-function 'dired-virtual-revert
dired-subdir-alist nil)
@@ -734,7 +752,7 @@ displayed this way is restricted by the height of the current window and
To keep Dired buffer displayed, type \\[split-window-below] first.
To display just marked files, type \\[delete-other-windows] first."
- (interactive "P")
+ (interactive "P" dired-mode)
(dired-simultaneous-find-file (dired-get-marked-files nil nil nil nil t)
noselect))
@@ -778,7 +796,7 @@ NOSELECT the files are merely found but not selected."
"Run VM on this file.
With optional prefix argument, visits the folder read-only.
Otherwise obeys the value of `dired-vm-read-only-folders'."
- (interactive "P")
+ (interactive "P" dired-mode)
(let ((dir (dired-current-directory))
(fil (dired-get-filename)))
(vm-visit-folder fil (or read-only
@@ -790,7 +808,7 @@ Otherwise obeys the value of `dired-vm-read-only-folders'."
(defun dired-rmail ()
"Run RMAIL on this file."
- (interactive)
+ (interactive nil dired-mode)
(rmail (dired-get-filename)))
(defun dired-do-run-mail ()
@@ -798,7 +816,7 @@ Otherwise obeys the value of `dired-vm-read-only-folders'."
Prompt for confirmation first; if the user says yes, call
`dired-vm' if `dired-bind-vm' is non-nil, `dired-rmail'
otherwise."
- (interactive)
+ (interactive nil dired-mode)
(let ((file (dired-get-filename t)))
(if dired-bind-vm
(if (y-or-n-p (format-message
@@ -816,7 +834,7 @@ otherwise."
(defun dired-x--string-to-number (str)
"Like `string-to-number' but recognize a trailing unit prefix.
For example, 2K is expanded to 2048.0. The caller should make
-sure that a trailing letter in STR is one of BKkMGTPEZY."
+sure that a trailing letter in STR is one of BKkMGTPEZYRQ."
(let* ((val (string-to-number str))
(u (unless (zerop val)
(aref str (1- (length str))))))
@@ -831,7 +849,7 @@ sure that a trailing letter in STR is one of BKkMGTPEZY."
(when (and u (> u ?9))
(when (= u ?k)
(setq u ?K))
- (let ((units '(?B ?K ?M ?G ?T ?P ?E ?Z ?Y)))
+ (let ((units '(?B ?K ?M ?G ?T ?P ?E ?Z ?Y ?R ?Q)))
(while (and units (/= (pop units) u))
(setq val (* 1024.0 val)))))
val)))
@@ -884,7 +902,8 @@ only in the active region if `dired-mark-region' is non-nil."
(if current-prefix-arg
"UNmark"
"Mark")))
- current-prefix-arg))
+ current-prefix-arg)
+ dired-mode)
(message "%s" predicate)
(let ((dired-marker-char (if unflag-p ?\040 dired-marker-char))
inode s mode nlink uid gid size time name sym)
@@ -904,7 +923,7 @@ only in the active region if `dired-mark-region' is non-nil."
;; GNU ls -hs suffixes the block count with a unit and
;; prints it as a float, FreeBSD does neither.
(dired-re-inode-size "\\=\\s *\\([0-9]+\\s +\\)?\
-\\(?:\\([0-9]+\\(?:\\.[0-9]*\\)?[BkKMGTPEZY]?\\)? ?\\)"))
+\\(?:\\([0-9]+\\(?:\\.[0-9]*\\)?[BkKMGTPEZYRQ]?\\)? ?\\)"))
(beginning-of-line)
(forward-char 2)
(search-forward-regexp dired-re-inode-size nil t)
@@ -1010,7 +1029,7 @@ is loaded then call \\[dired-x-bind-find-file]."
"Bind `dired-x-find-file' in place of `find-file' (or vice-versa).
Similarly for `dired-x-find-file-other-window' and `find-file-other-window'.
Binding direction based on `dired-x-hands-off-my-keys'."
- (interactive)
+ (interactive nil)
(if (called-interactively-p 'interactive)
(setq dired-x-hands-off-my-keys
(not (y-or-n-p (format-message
diff --git a/lisp/dired.el b/lisp/dired.el
index d9fbafb98c3..9e3b888df14 100644
--- a/lisp/dired.el
+++ b/lisp/dired.el
@@ -75,7 +75,9 @@ each option.
On systems such as MS-DOS and MS-Windows, which use `ls' emulation in Lisp,
some of the `ls' switches are not supported; see the doc string of
-`insert-directory' in `ls-lisp.el' for more details."
+`insert-directory' in `ls-lisp.el' for more details.
+
+For remote Dired buffers, this option supports connection-local values."
:type 'string
:group 'dired)
@@ -119,12 +121,11 @@ checks this alist to enable globstar in the shell subprocess.")
(defcustom dired-use-ls-dired 'unspecified
"Non-nil means Dired should pass the \"--dired\" option to \"ls\".
If nil, don't pass \"--dired\" to \"ls\".
-The special value of `unspecified' means to check whether \"ls\"
-supports the \"--dired\" option, and save the result in this
-variable. This is performed the first time `dired-insert-directory'
-is invoked. (If `ls-lisp' is used by default, the test is performed
-only if `ls-lisp-use-insert-directory-program' is non-nil, i.e., if
-Dired actually uses \"ls\".)
+The special value of `unspecified' means to check whether
+`insert-directory-program' supports the \"--dired\" option, and save
+the result in this variable.
+This is performed the first time `dired-insert-directory'
+invokes `insert-directory-program'.
Note that if you set this option to nil, either through choice or
because your \"ls\" program does not support \"--dired\", Dired
@@ -350,6 +351,7 @@ with the buffer narrowed to the listing."
(defcustom dired-make-directory-clickable t
"When non-nil, make the directory at the start of the dired buffer clickable."
:version "29.1"
+ :group 'dired
:type 'boolean)
(defcustom dired-initial-position-hook nil
@@ -429,6 +431,7 @@ is anywhere on its Dired line, except the beginning of the line."
(defcustom dired-kill-when-opening-new-dired-buffer nil
"If non-nil, kill the current buffer when selecting a new directory."
:type 'boolean
+ :group 'dired
:version "28.1")
(defcustom dired-guess-shell-case-fold-search t
@@ -497,6 +500,43 @@ to nil: a pipe using `zcat' or `gunzip -c' will be used."
(string :tag "Switches"))
:version "29.1")
+(defcustom dired-movement-style nil
+ "Non-nil means point skips empty lines when moving in Dired buffers.
+This affects only `dired-next-line', `dired-previous-line',
+`dired-next-dirline', `dired-prev-dirline'.
+
+Possible non-nil values:
+ * `cycle': when moving from the last/first visible line, cycle back
+ to the first/last visible line.
+ * `bounded': don't move up/down if the current line is the
+ first/last visible line."
+ :type '(choice (const :tag "Move to any line" nil)
+ (const :tag "Cycle through non-empty lines" cycle)
+ (const :tag "Stop on last/first non-empty line" bounded))
+ :group 'dired
+ :version "30.1")
+
+(defcustom dired-hide-details-preserved-columns nil
+ "List of columns which are not hidden in `dired-hide-details-mode'."
+ :type '(repeat integer)
+ :group 'dired
+ :version "30.1")
+
+(defcustom dired-filename-display-length nil
+ "If non-nil, restrict the display length of filenames.
+If the value is the symbol `window', the right edge of current
+window is used as the restriction. Otherwise, it should be an
+integer representing the maximum filename length.
+
+The middle part of filename whose length exceeds the restriction
+is hidden by using the `invisible' property and an ellipsis is
+displayed instead."
+ :type '(choice (const :tag "No restriction" nil)
+ (const :tag "Window" window)
+ (integer :tag "Integer"))
+ :group 'dired
+ :version "30.1")
+
;;; Internal variables
@@ -537,7 +577,7 @@ The directory name must be absolute, but need not be fully expanded.")
(put 'dired-actual-switches 'safe-local-variable 'dired-safe-switches-p)
-(defvar dired-re-inode-size "[0-9 \t]*[.,0-9]*[BkKMGTPEZY]?[ \t]*"
+(defvar dired-re-inode-size "[0-9 \t]*[.,0-9]*[BkKMGTPEZYRQ]?[ \t]*"
"Regexp for optional initial inode and file size as made by `ls -i -s'.")
;; These regexps must be tested at beginning-of-line, but are also
@@ -579,9 +619,6 @@ element, for the listed directory.")
"Keeps track of which switches to use for inserted subdirectories.
This is an alist of the form (SUBDIR . SWITCHES).")
-(defvaralias 'dired-move-to-filename-regexp
- 'directory-listing-before-filename-regexp)
-
(defvar dired-subdir-regexp "^. \\(.+\\)\\(:\\)\n"
"Regexp matching a maybe hidden subdirectory line in `ls -lR' output.
Subexpression 1 is the subdirectory proper, no trailing colon.
@@ -929,9 +966,9 @@ marked file, return (t FILENAME) instead of (FILENAME)."
(lambda ()
(if ,show-progress (sit-for 0))
(setq results (cons ,body results))))
- (if (< ,arg 0)
- (nreverse results)
- results))
+ (when (< ,arg 0)
+ (setq results (nreverse results)))
+ results)
;; non-nil, non-integer, non-marked ARG means use current file:
(list ,body))
(let ((regexp (dired-marker-regexp)) next-position)
@@ -1313,7 +1350,7 @@ The return value is the target column for the file names."
;; Note that buffer already is in dired-mode, if found.
(new-buffer-p (null buffer)))
(or buffer
- (setq buffer (create-file-buffer (directory-file-name dirname))))
+ (setq buffer (create-file-buffer dirname)))
(set-buffer buffer)
(if (not new-buffer-p) ; existing buffer ...
(cond (switches ; ... but new switches
@@ -1347,7 +1384,8 @@ The return value is the target column for the file names."
;; is passed in directory name syntax
;; if it was the name of a directory at all.
(file-name-directory dirname)))
- (or switches (setq switches dired-listing-switches))
+ (or switches
+ (setq switches (connection-local-value dired-listing-switches)))
(if mode (funcall mode)
(dired-mode dir-or-list switches))
;; default-directory and dired-actual-switches are set now
@@ -1485,18 +1523,21 @@ wildcards, erases the buffer, and builds the subdir-alist anew
(setq dir dired-directory
file-list nil))
(setq dir (expand-file-name dir))
- (if (and (equal "" (file-name-nondirectory dir))
- (not file-list))
- ;; If we are reading a whole single directory...
- (dired-insert-directory dir dired-actual-switches nil nil t)
- (if (and (not (insert-directory-wildcard-in-dir-p dir))
- (not (file-readable-p
- (directory-file-name (file-name-directory dir)))))
- (error "Directory %s inaccessible or nonexistent" dir))
+ (cond
+ ((and (equal "" (file-name-nondirectory dir))
+ (not file-list))
+ ;; If we are reading a whole single directory...
+ (dired-insert-directory dir dired-actual-switches nil
+ (not (file-directory-p dir)) t))
+ ((not (or (insert-directory-wildcard-in-dir-p dir)
+ (file-readable-p
+ (directory-file-name (file-name-directory dir)))))
+ (error "Directory %s inaccessible or nonexistent" dir))
+ (t
;; Else treat it as a wildcard spec
;; unless we have an explicit list of files.
(dired-insert-directory dir dired-actual-switches
- file-list (not file-list) t))))
+ file-list (not file-list) t)))))
(defun dired-align-file (beg end)
"Align the fields of a file to the ones of surrounding lines.
@@ -1505,7 +1546,7 @@ BEG..END is the line where the file info is located."
;; hold the largest element ("largest" in the current invocation, of
;; course). So when a single line is output, the size of each field is
;; just big enough for that one output. Thus when dired refreshes one
- ;; line, the alignment if this line w.r.t the rest is messed up because
+ ;; line, the alignment of this line w.r.t the rest is messed up because
;; the fields of that one line will generally be smaller.
;;
;; To work around this problem, we here add spaces to try and
@@ -1572,14 +1613,21 @@ BEG..END is the line where the file info is located."
;; the beginning or the end of the next field, depending on
;; whether this field is left or right aligned).
(align-pt-offset
- (save-excursion
- (goto-char other)
- (move-to-column curcol)
- (when (looking-at
- (concat
- (if (eq (char-before) ?\s) " *" "[^ ]* *")
- (if num-align "[0-9][^ ]*")))
- (- (match-end 0) (match-beginning 0)))))
+ ;; It is never TRT to realign the first column of
+ ;; file's data. But the code below does attempt to
+ ;; realign the first column if there's no whitespace
+ ;; before it, so we force it to let the first column
+ ;; alone.
+ (if (zerop curcol)
+ 0
+ (save-excursion
+ (goto-char other)
+ (move-to-column curcol)
+ (when (looking-at
+ (concat
+ (if (eq (char-before) ?\s) " *" "[^ ]* *")
+ (if num-align "[0-9][^ ]*")))
+ (- (match-end 0) (match-beginning 0))))))
;; Now, the number of spaces to insert is align-pt-offset
;; minus the distance to the equivalent point on the
;; current line.
@@ -1604,9 +1652,6 @@ BEG..END is the line where the file info is located."
(skip-chars-forward "^ ") (skip-chars-forward " "))
(set-marker file nil)))))
-
-(defvar ls-lisp-use-insert-directory-program)
-
(defun dired-check-switches (switches short &optional long)
"Return non-nil if the string SWITCHES matches LONG or SHORT format."
(let (case-fold-search)
@@ -1634,42 +1679,39 @@ In other cases, DIR should be a directory name or a directory filename.
If HDR is non-nil, insert a header line with the directory name."
(let ((opoint (point))
(process-environment (copy-sequence process-environment))
+ (remotep (file-remote-p dir))
end)
(if (and
- ;; Don't try to invoke `ls' if we are on DOS/Windows where
- ;; ls-lisp emulation is used, except if they want to use `ls'
- ;; as indicated by `ls-lisp-use-insert-directory-program'.
- (not (and (featurep 'ls-lisp)
- (null ls-lisp-use-insert-directory-program)))
+ ;; Don't try to invoke `ls' if ls-lisp emulation should be used.
+ (files--use-insert-directory-program-p)
;; FIXME: Big ugly hack for Eshell's eshell-ls-use-in-dired.
(not (bound-and-true-p eshell-ls-use-in-dired))
- (or (file-remote-p dir)
+ (or remotep
(if (eq dired-use-ls-dired 'unspecified)
;; Check whether "ls --dired" gives exit code 0, and
;; save the answer in `dired-use-ls-dired'.
(or (setq dired-use-ls-dired
(eq 0 (call-process insert-directory-program
- nil nil nil "--dired")))
+ nil nil nil "--dired" "-N")))
(progn
- (message "ls does not support --dired; \
+ (message "ls does not support --dired -N; \
see `dired-use-ls-dired' for more details.")
nil))
dired-use-ls-dired)))
- (setq switches (concat "--dired " switches)))
+ ;; Use -N with --dired, to countermand possible non-default
+ ;; quoting style, in particular via the environment variable
+ ;; QUOTING_STYLE.
+ (unless remotep
+ (setq switches (concat "--dired -N " switches))))
;; Expand directory wildcards and fill file-list.
- (let ((dir-wildcard (insert-directory-wildcard-in-dir-p dir)))
- (cond (dir-wildcard
+ (let ((dir-wildcard (and (null file-list) wildcard
+ (insert-directory-wildcard-in-dir-p dir))))
+ (cond ((and dir-wildcard (files--use-insert-directory-program-p))
(setq switches (concat "-d " switches))
- ;; We don't know whether the remote ls supports
- ;; "--dired", so we cannot add it to the `process-file'
- ;; call for wildcards.
- (when (file-remote-p dir)
- (setq switches (string-replace "--dired" "" switches)))
(let* ((default-directory (car dir-wildcard))
(script (format "%s %s %s"
insert-directory-program
switches (cdr dir-wildcard)))
- (remotep (file-remote-p dir))
(sh (or (and remotep "/bin/sh")
(executable-find shell-file-name)
(executable-find "sh")))
@@ -1687,78 +1729,81 @@ see `dired-use-ls-dired' for more details.")
(user-error
"%s: No files matching wildcard" (cdr dir-wildcard)))
(insert-directory-clean (point) switches)))
- (t
- ;; We used to specify the C locale here, to force English
- ;; month names; but this should not be necessary any
- ;; more, with the new value of
- ;; `directory-listing-before-filename-regexp'.
- (if file-list
- (dolist (f file-list)
- (let ((beg (point)))
- (insert-directory f switches nil nil)
- ;; Re-align fields, if necessary.
- (dired-align-file beg (point))))
- (insert-directory dir switches wildcard (not wildcard))))))
- ;; Quote certain characters, unless ls quoted them for us.
- (if (not (dired-switches-escape-p dired-actual-switches))
+ ;; We used to specify the C locale here, to force English
+ ;; month names; but this should not be necessary any
+ ;; more, with the new value of
+ ;; `directory-listing-before-filename-regexp'.
+ ((or file-list dir-wildcard)
+ (let ((default-directory
+ (or (car dir-wildcard) default-directory)))
+ (dolist (f (or file-list
+ (file-expand-wildcards (cdr dir-wildcard))))
+ (let ((beg (point)))
+ (insert-directory f switches nil nil)
+ ;; Re-align fields, if necessary.
+ (dired-align-file beg (point))))))
+ (t
+ (insert-directory dir switches wildcard (not wildcard))))
+ ;; Quote certain characters, unless ls quoted them for us.
+ (if (not (dired-switches-escape-p dired-actual-switches))
+ (save-excursion
+ (setq end (point-marker))
+ (goto-char opoint)
+ (while (search-forward "\\" end t)
+ (replace-match (apply #'propertize
+ "\\\\"
+ (text-properties-at (match-beginning 0)))
+ nil t))
+ (goto-char opoint)
+ (while (search-forward "\^m" end t)
+ (replace-match (apply #'propertize
+ "\\015"
+ (text-properties-at (match-beginning 0)))
+ nil t))
+ (set-marker end nil))
+ ;; Replace any newlines in DIR with literal "\n"s, for the sake
+ ;; of the header line. To disambiguate a literal "\n" in the
+ ;; actual dirname, we also replace "\" with "\\".
+ ;; Personally, I think this should always be done, irrespective
+ ;; of the value of dired-actual-switches, because:
+ ;; i) Dired simply does not work with an unescaped newline in
+ ;; the directory name used in the header (bug=10469#28), and
+ ;; ii) "\" is always replaced with "\\" in the listing, so doing
+ ;; it in the header as well makes things consistent.
+ ;; But at present it is only done if "-b" is in ls-switches,
+ ;; because newlines in dirnames are uncommon, and people may
+ ;; have gotten used to seeing unescaped "\" in the headers.
+ ;; Note: adjust dired-build-subdir-alist if you change this.
+ (setq dir (string-replace "\\" "\\\\" dir)
+ dir (string-replace "\n" "\\n" dir)))
+ ;; If we used --dired and it worked, the lines are already indented.
+ ;; Otherwise, indent them.
+ (unless (save-excursion
+ (goto-char opoint)
+ (looking-at-p " "))
+ (let ((indent-tabs-mode nil))
+ (indent-rigidly opoint (point) 2)))
+ ;; Insert text at the beginning to standardize things.
+ (let ((content-point opoint))
(save-excursion
- (setq end (point-marker))
(goto-char opoint)
- (while (search-forward "\\" end t)
- (replace-match (apply #'propertize
- "\\\\"
- (text-properties-at (match-beginning 0)))
- nil t))
- (goto-char opoint)
- (while (search-forward "\^m" end t)
- (replace-match (apply #'propertize
- "\\015"
- (text-properties-at (match-beginning 0)))
- nil t))
- (set-marker end nil))
- ;; Replace any newlines in DIR with literal "\n"s, for the sake
- ;; of the header line. To disambiguate a literal "\n" in the
- ;; actual dirname, we also replace "\" with "\\".
- ;; Personally, I think this should always be done, irrespective
- ;; of the value of dired-actual-switches, because:
- ;; i) Dired simply does not work with an unescaped newline in
- ;; the directory name used in the header (bug=10469#28), and
- ;; ii) "\" is always replaced with "\\" in the listing, so doing
- ;; it in the header as well makes things consistent.
- ;; But at present it is only done if "-b" is in ls-switches,
- ;; because newlines in dirnames are uncommon, and people may
- ;; have gotten used to seeing unescaped "\" in the headers.
- ;; Note: adjust dired-build-subdir-alist if you change this.
- (setq dir (string-replace "\\" "\\\\" dir)
- dir (string-replace "\n" "\\n" dir)))
- ;; If we used --dired and it worked, the lines are already indented.
- ;; Otherwise, indent them.
- (unless (save-excursion
- (goto-char opoint)
- (looking-at-p " "))
- (let ((indent-tabs-mode nil))
- (indent-rigidly opoint (point) 2)))
- ;; Insert text at the beginning to standardize things.
- (let ((content-point opoint))
- (save-excursion
- (goto-char opoint)
- (when (and (or hdr wildcard)
- (not (and (looking-at "^ \\(.*\\):$")
- (file-name-absolute-p (match-string 1)))))
- ;; Note that dired-build-subdir-alist will replace the name
- ;; by its expansion, so it does not matter whether what we insert
- ;; here is fully expanded, but it should be absolute.
- (insert " " (or (car-safe (insert-directory-wildcard-in-dir-p dir))
- (directory-file-name (file-name-directory dir)))
- ":\n")
- (setq content-point (point)))
- (when wildcard
- ;; Insert "wildcard" line where "total" line would be for a full dir.
- (insert " wildcard " (or (cdr-safe (insert-directory-wildcard-in-dir-p dir))
- (file-name-nondirectory dir))
- "\n"))
- (setq content-point (dired--insert-disk-space opoint dir)))
- (dired-insert-set-properties content-point (point)))))
+ (when (and (or hdr wildcard)
+ (not (and (looking-at "^ \\(.*\\):$")
+ (file-name-absolute-p (match-string 1)))))
+ ;; Note that dired-build-subdir-alist will replace the name
+ ;; by its expansion, so it does not matter whether what we insert
+ ;; here is fully expanded, but it should be absolute.
+ (insert " " (or (car-safe dir-wildcard)
+ (directory-file-name (file-name-directory dir)))
+ ":\n")
+ (setq content-point (point)))
+ (when wildcard
+ ;; Insert "wildcard" line where "total" line would be for a full dir.
+ (insert " wildcard " (or (cdr-safe (insert-directory-wildcard-in-dir-p dir))
+ (file-name-nondirectory dir))
+ "\n"))
+ (setq content-point (dired--insert-disk-space opoint dir)))
+ (dired-insert-set-properties content-point (point))))))
(defun dired--insert-disk-space (beg file)
;; Try to insert the amount of free space.
@@ -1807,7 +1852,7 @@ see `dired-use-ls-dired' for more details.")
"Begin a drag-and-drop operation for the file at EVENT.
If there are marked files and that file is marked, drag every
other marked file as well. Otherwise, unmark all files."
- (interactive "e")
+ (interactive "e" dired-mode)
(when mark-active
(deactivate-mark))
(let* ((modifiers (event-modifiers event))
@@ -1880,45 +1925,76 @@ other marked file as well. Otherwise, unmark all files."
keymap)
"Keymap applied to file names when `dired-mouse-drag-files' is enabled.")
+(defvar dired-click-to-select-mode)
+(defvar dired-click-to-select-map)
+
(defun dired-insert-set-properties (beg end)
- "Add various text properties to the lines in the region, from BEG to END."
+ "Add various text properties to the lines in the region, from BEG to END.
+Overlays could be added when some user options are enabled, e.g.,
+`dired-filename-display-length'."
+ (remove-overlays beg end 'invisible 'dired-filename-hide)
(save-excursion
(goto-char beg)
- (while (< (point) end)
- (ignore-errors
- (if (not (dired-move-to-filename))
- (unless (or (looking-at-p "^$")
- (looking-at-p dired-subdir-regexp))
- (put-text-property (line-beginning-position)
- (1+ (line-end-position))
- '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
- highlight
- dired-filename t
- help-echo ,(if (and dired-mouse-drag-files
- (fboundp 'x-begin-drag))
- "down-mouse-1: drag this file to another program
+ (let ((ell-len (dired--get-ellipsis-length)) maxlen filename-col)
+ (while (< (point) end)
+ (ignore-errors
+ (if (not (dired-move-to-filename))
+ (unless (or (looking-at-p "^$")
+ (looking-at-p dired-subdir-regexp))
+ (put-text-property (line-beginning-position)
+ (1+ (line-end-position))
+ 'invisible 'dired-hide-details-information))
+ (save-excursion
+ (let ((end (1- (point)))
+ (opoint (goto-char (1+ (pos-bol))))
+ (i 0))
+ (put-text-property opoint end 'invisible 'dired-hide-details-detail)
+ (while (re-search-forward "[^ ]+" end t)
+ (when (member (cl-incf i) dired-hide-details-preserved-columns)
+ (put-text-property opoint (point) 'invisible nil))
+ (setq opoint (point)))))
+ (let ((beg (point)) (end (save-excursion
+ (dired-move-to-end-of-filename)
+ (1- (point)))))
+ (if dired-click-to-select-mode
+ (put-text-property beg end 'keymap
+ dired-click-to-select-map)
+ (when (and dired-mouse-drag-files (fboundp 'x-begin-drag))
+ (put-text-property beg end 'keymap
+ dired-mouse-drag-files-map)))
+ (when dired-filename-display-length
+ (let ((len (string-width (buffer-substring beg (1+ end))))
+ ell-beg)
+ (or maxlen (setq maxlen (dired--get-filename-display-length)))
+ (when (and (integerp maxlen) (> len maxlen (+ ell-len 2)))
+ (or filename-col (setq filename-col (current-column)))
+ (move-to-column (+ filename-col (/ maxlen 2)))
+ (setq ell-beg (point))
+ (move-to-column (+ filename-col (/ maxlen 2)
+ (- len maxlen) ell-len))
+ ;; Here we use overlays because isearch by default
+ ;; doesn't support finding matches in hidden text
+ ;; made invisible via text properties.
+ (let ((ov (make-overlay ell-beg (point))))
+ (overlay-put ov 'invisible 'dired-filename-hide)
+ (overlay-put ov 'isearch-open-invisible #'delete-overlay)
+ (overlay-put ov 'evaporate t)))))
+ (add-text-properties
+ beg (1+ end)
+ `(mouse-face
+ highlight
+ dired-filename t
+ help-echo ,(if dired-click-to-select-mode
+ "mouse-2: mark or unmark this file"
+ (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))))
- (forward-line 1))))
+ "mouse-2: visit this file in other window"))))
+ (when (< (+ end 5) (line-end-position))
+ (put-text-property (+ end 5) (line-end-position)
+ 'invisible 'dired-hide-details-link)))))
+ (forward-line 1)))))
(defun dired--make-directory-clickable ()
(save-excursion
@@ -1963,6 +2039,28 @@ mouse-2: visit this file in other window"
"RET" click))))
(setq segment-start (point)))))))
+(defun dired--get-ellipsis-length ()
+ "Return length of ellipsis."
+ (let* ((dt (or (window-display-table)
+ buffer-display-table
+ standard-display-table))
+ (glyphs (and dt (display-table-slot dt 'selective-display)))
+ (vlen (length glyphs))
+ (char-glyphs (make-vector vlen nil)))
+ (dotimes (i vlen)
+ (aset char-glyphs i (glyph-char (aref glyphs i))))
+ (string-width (if glyphs (concat char-glyphs) "..."))))
+
+(defun dired--get-filename-display-length ()
+ "Return maximum display length of filename.
+When `dired-filename-display-length' is not an integer, the
+function actually returns the number of columns available for
+displaying the file names, and should be called with point at the
+first character of the file name."
+ (if (integerp dired-filename-display-length)
+ dired-filename-display-length
+ (- (window-max-chars-per-line) 1 (current-column))))
+
;;; Reverting a dired buffer
@@ -2301,7 +2399,9 @@ Do so according to the former subdir alist OLD-SUBDIR-ALIST."
": d" #'epa-dired-do-decrypt
": v" #'epa-dired-do-verify
": s" #'epa-dired-do-sign
- ": e" #'epa-dired-do-encrypt)
+ ": e" #'epa-dired-do-encrypt
+ ;; Click-to-select.
+ "<touchscreen-hold>" #'dired-enable-click-to-select-mode)
(put 'dired-find-file :advertised-binding (kbd "RET"))
@@ -2514,17 +2614,38 @@ Do so according to the former subdir alist OLD-SUBDIR-ALIST."
["Delete Image Tag..." image-dired-delete-tag
:help "Delete image tag from current or marked files"]))
+(declare-function shell-command-guess "dired-aux" (files))
+(defvar shell-command-guess-open)
+
(defun dired-context-menu (menu click)
"Populate MENU with Dired mode commands at CLICK."
(when (mouse-posn-property (event-start click) 'dired-filename)
(define-key menu [dired-separator] menu-bar-separator)
- (let ((easy-menu (make-sparse-keymap "Immediate")))
+ (let* ((filename (save-excursion
+ (mouse-set-point click)
+ (dired-get-filename nil t)))
+ (commands (shell-command-guess (list filename)))
+ (easy-menu (make-sparse-keymap "Immediate")))
(easy-menu-define nil easy-menu nil
- '("Immediate"
+ `("Immediate"
["Find This File" dired-mouse-find-file
:help "Edit file at mouse click"]
["Find in Other Window" dired-mouse-find-file-other-window
- :help "Edit file at mouse click in other window"]))
+ :help "Edit file at mouse click in other window"]
+ ,@(when shell-command-guess-open
+ '(["Open" dired-do-open
+ :help "Open externally"]))
+ ,@(when commands
+ (list (cons "Open With"
+ (append
+ (mapcar (lambda (command)
+ `[,(or (get-text-property 0 'name command)
+ command)
+ (lambda ()
+ (interactive)
+ (dired-do-async-shell-command
+ ,command nil (list ,filename)))])
+ commands)))))))
(dolist (item (reverse (lookup-key easy-menu [menu-bar immediate])))
(when (consp item)
(define-key menu (vector (car item)) (cdr item))))))
@@ -2602,6 +2723,7 @@ Keybindings:
mode-line-buffer-identification
(propertized-buffer-identification "%17b"))
(add-to-invisibility-spec '(dired . t))
+ (dired-filename-update-invisibility-spec)
;; Ignore dired-hide-details-* value of invisible text property by default.
(when (eq buffer-invisibility-spec t)
(setq buffer-invisibility-spec (list t)))
@@ -2615,7 +2737,8 @@ Keybindings:
(expand-file-name (if (listp dired-directory)
(car dired-directory)
dired-directory)))
- (setq-local dired-actual-switches (or switches dired-listing-switches))
+ (setq-local dired-actual-switches
+ (or switches (connection-local-value dired-listing-switches)))
(setq-local font-lock-defaults
'(dired-font-lock-keywords t nil nil beginning-of-line))
(setq-local desktop-save-buffer 'dired-desktop-buffer-misc-data)
@@ -2647,7 +2770,7 @@ Keybindings:
"Undo in a Dired buffer.
This doesn't recover lost files, it just undoes changes in the buffer itself.
You can use it to recover marks, killed lines or subdirs."
- (interactive)
+ (interactive nil dired-mode)
(let ((inhibit-read-only t))
(undo))
(dired-build-subdir-alist)
@@ -2659,7 +2782,7 @@ Actual changes in files cannot be undone by Emacs."))
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)
+ (interactive nil dired-mode)
(unless (file-exists-p default-directory)
(user-error "The current directory no longer exists"))
(when (and (not (file-writable-p default-directory))
@@ -2670,28 +2793,86 @@ Otherwise, toggle `read-only-mode'."
(wdired-change-to-wdired-mode)
(read-only-mode 'toggle)))
-(defun dired-next-line (arg)
- "Move down lines then position at filename.
-Optional prefix ARG says how many lines to move; default is one line."
- (interactive "^p")
+(defun dired--trivial-next-line (arg)
+ "Move down ARG lines, then position at filename."
(let ((line-move-visual)
- (goal-column))
+ (goal-column))
(line-move arg t))
;; We never want to move point into an invisible line.
(while (and (invisible-p (point))
- (not (if (and arg (< arg 0)) (bobp) (eobp))))
+ (not (if (and arg (< arg 0)) (bobp) (eobp))))
(forward-char (if (and arg (< arg 0)) -1 1)))
(dired-move-to-filename))
+(defun dired-next-line (arg)
+ "Move down ARG lines, then position at filename.
+The argument ARG (interactively, prefix argument) says how many lines
+to move; the default is one line.
+
+Whether to skip empty lines and how to move from last line
+is controlled by `dired-movement-style'."
+ (interactive "^p" dired-mode)
+ (if dired-movement-style
+ (dired--move-to-next-line arg #'dired--trivial-next-line)
+ (dired--trivial-next-line arg)))
+
+(defun dired--move-to-next-line (arg jumpfun)
+ (let ((wrapped nil)
+ (old-arg arg)
+ (old-position (progn
+ ;; It's always true that we should move
+ ;; to the filename when possible.
+ (dired-move-to-filename)
+ (point)))
+ ;; Up/Down indicates the direction.
+ (moving-down (if (cl-plusp arg)
+ 1 ; means Down.
+ -1))) ; means Up.
+ ;; Line by line in case we forget to skip empty lines.
+ (while (not (zerop arg))
+ (funcall jumpfun moving-down)
+ (when (= old-position (point))
+ ;; Now point is at beginning/end of movable area,
+ ;; but it still wants to move farther.
+ (cond
+ ;; `cycle': go to the other end.
+ ((eq dired-movement-style 'cycle)
+ ;; Argument not changing on the second wrap
+ ;; means infinite loop with no files found.
+ (if (and wrapped (eq old-arg arg))
+ (setq arg 0)
+ (goto-char (if (cl-plusp moving-down)
+ (point-min)
+ (point-max))))
+ (setq wrapped t))
+ ;; `bounded': go back to the last non-empty line.
+ ((eq dired-movement-style 'bounded)
+ (while (and (dired-between-files) (not (zerop arg)))
+ (funcall jumpfun (- moving-down))
+ ;; Point not moving means infinite loop.
+ (if (= old-position (point))
+ (setq arg 0)
+ (setq old-position (point))))
+ ;; Encountered a boundary, so let's stop movement.
+ (setq arg (if (dired-between-files) 0 moving-down)))))
+ (unless (dired-between-files)
+ ;; Has moved to a non-empty line. This movement does
+ ;; make sense.
+ (cl-decf arg moving-down))
+ (setq old-position (point)))))
+
(defun dired-previous-line (arg)
- "Move up lines then position at filename.
-Optional prefix ARG says how many lines to move; default is one line."
- (interactive "^p")
+ "Move up ARG lines, then position at filename.
+The argument ARG (interactively, prefix argument) says how many lines
+to move; the default is one line.
+
+Whether to skip empty lines and how to move from first line
+is controlled by `dired-movement-style'."
+ (interactive "^p" dired-mode)
(dired-next-line (- (or arg 1))))
-(defun dired-next-dirline (arg &optional opoint)
+(defun dired--trivial-next-dirline (arg &optional opoint)
"Goto ARGth next directory file line."
- (interactive "p")
(or opoint (setq opoint (point)))
(if (if (> arg 0)
(re-search-forward dired-re-dir nil t arg)
@@ -2699,11 +2880,25 @@ Optional prefix ARG says how many lines to move; default is one line."
(re-search-backward dired-re-dir nil t (- arg)))
(dired-move-to-filename) ; user may type `i' or `f'
(goto-char opoint)
- (error "No more subdirectories")))
+ (unless dired-movement-style
+ (error "No more subdirectories"))))
+
+(defun dired-next-dirline (arg &optional _opoint)
+ "Goto ARGth next directory file line.
+
+Whether to skip empty lines and how to move from last line
+is controlled by `dired-movement-style'."
+ (interactive "p" dired-mode)
+ (if dired-movement-style
+ (dired--move-to-next-line arg #'dired--trivial-next-dirline)
+ (dired--trivial-next-dirline arg)))
(defun dired-prev-dirline (arg)
- "Goto ARGth previous directory file line."
- (interactive "p")
+ "Goto ARGth previous directory file line.
+
+Whether to skip empty lines and how to move from last line
+is controlled by `dired-movement-style'."
+ (interactive "p" dired-mode)
(dired-next-dirline (- arg)))
(defun dired-up-directory (&optional other-window)
@@ -2712,7 +2907,7 @@ Find the parent directory either in this buffer or another buffer.
Creates a buffer if necessary.
If OTHER-WINDOW (the optional prefix arg), display the parent
directory in another window."
- (interactive "P")
+ (interactive "P" dired-mode)
(let* ((dir (dired-current-directory))
(up (file-name-directory (directory-file-name dir))))
(or (dired-goto-file (directory-file-name dir))
@@ -2727,7 +2922,7 @@ directory in another window."
(defun dired-get-file-for-visit ()
"Get the current line's file name, with an error if file does not exist."
- (interactive)
+ (interactive nil dired-mode)
;; We pass t for second arg so that we don't get error for `.' and `..'.
(let ((raw (dired-get-filename nil t))
file-name)
@@ -2747,7 +2942,7 @@ directory in another window."
#'dired-find-file "23.2")
(defun dired-find-file ()
"In Dired, visit the file or directory named on this line."
- (interactive)
+ (interactive nil dired-mode)
(dired--find-possibly-alternative-file (dired-get-file-for-visit)))
(defun dired--find-possibly-alternative-file (file)
@@ -2779,7 +2974,7 @@ directory in another window."
(defun dired-find-alternate-file ()
"In Dired, visit file or directory on current line via `find-alternate-file'.
This kills the Dired buffer, then visits the current line's file or directory."
- (interactive)
+ (interactive nil dired-mode)
(set-buffer-modified-p nil)
(find-alternate-file (dired-get-file-for-visit)))
;; Don't override the setting from .emacs.
@@ -2793,7 +2988,7 @@ omitted or nil, these arguments default to `find-file' and `dired',
respectively. If `dired-kill-when-opening-new-dired-buffer' is
non-nil, FIND-DIR-FUNC defaults to `find-alternate-file' instead,
so that the original Dired buffer is not kept."
- (interactive "e")
+ (interactive "e" dired-mode)
(or find-file-func (setq find-file-func 'find-file))
(let (window pos file)
(save-excursion
@@ -2821,19 +3016,19 @@ so that the original Dired buffer is not kept."
(defun dired-mouse-find-file-other-window (event)
"In Dired, visit the file or directory name you click on in another window."
- (interactive "e")
+ (interactive "e" dired-mode)
(dired-mouse-find-file event 'find-file-other-window 'dired-other-window))
(defun dired-mouse-find-file-other-frame (event)
"In Dired, visit the file or directory name you click on in another frame."
- (interactive "e")
+ (interactive "e" dired-mode)
(dired-mouse-find-file event 'find-file-other-frame 'dired-other-frame))
(defun dired-view-file ()
"In Dired, examine a file in view mode, returning to Dired when done.
When file is a directory, show it in this buffer if it is inserted.
Otherwise, display it in another buffer."
- (interactive)
+ (interactive nil dired-mode)
(let ((file (dired-get-file-for-visit)))
(if (file-directory-p file)
(or (and (cdr dired-subdir-alist)
@@ -2843,12 +3038,12 @@ Otherwise, display it in another buffer."
(defun dired-find-file-other-window ()
"In Dired, visit this file or directory in another window."
- (interactive)
+ (interactive nil dired-mode)
(dired--find-file #'find-file-other-window (dired-get-file-for-visit)))
(defun dired-display-file ()
"In Dired, display this file or directory in another window."
- (interactive)
+ (interactive nil dired-mode)
(display-buffer (find-file-noselect (dired-get-file-for-visit))
t))
@@ -3010,7 +3205,7 @@ permissions are hidden from view.
See options: `dired-hide-details-hide-symlink-targets' and
`dired-hide-details-hide-information-lines'."
:group 'dired
- (unless (derived-mode-p 'dired-mode 'wdired-mode)
+ (unless (derived-mode-p '(dired-mode wdired-mode))
(error "Not a Dired buffer"))
(dired-hide-details-update-invisibility-spec)
(if dired-hide-details-mode
@@ -3042,6 +3237,15 @@ See options: `dired-hide-details-hide-symlink-targets' and
;;; Functions to hide/unhide text
+(defun dired-filename-update-invisibility-spec ()
+ "Update `buffer-invisibility-spec' for filenames.
+Specifically, the filename invisibility spec is added in Dired
+buffers and removed in WDired buffers."
+ (funcall (if (derived-mode-p 'dired-mode)
+ 'add-to-invisibility-spec
+ 'remove-from-invisibility-spec)
+ '(dired-filename-hide . t)))
+
(defun dired--find-hidden-pos (start end)
(text-property-any start end 'invisible 'dired))
@@ -3185,7 +3389,7 @@ If on a subdir headerline, use absolute subdirname instead;
prefix arg and marked files are ignored in this case.
You can then feed the file name(s) to other commands with \\[yank]."
- (interactive "P")
+ (interactive "P" dired-mode)
(let* ((files
(or (ensure-list (dired-get-subdir))
(if arg
@@ -3371,7 +3575,7 @@ As a side effect, killed dired buffers for DIR are removed from
;; Use 0 arg to go to this directory's header line.
;; NO-SKIP prevents moving to end of header line, returning whatever
;; position was found in dired-subdir-alist.
- (interactive "p")
+ (interactive "p" dired-mode)
(let ((this-dir (dired-current-directory))
pos index)
;; nth with negative arg does not return nil but the first element
@@ -3392,7 +3596,7 @@ As a side effect, killed dired buffers for DIR are removed from
Returns the new value of the alist.
If optional arg SWITCHES is non-nil, use its value
instead of `dired-actual-switches'."
- (interactive)
+ (interactive nil dired-mode)
(dired-clear-alist)
(save-excursion
(let* ((count 0)
@@ -3496,7 +3700,8 @@ instead of `dired-actual-switches'."
(list (expand-file-name
(read-file-name "Goto file: "
(dired-current-directory))))
- (push-mark)))
+ (push-mark))
+ dired-mode)
(unless (file-name-absolute-p file)
(error "File name `%s' is not absolute" file))
(setq file (directory-file-name file)) ; does no harm if not a directory
@@ -3695,7 +3900,7 @@ If NOMESSAGE is non-nil, we don't display any message
if there are no flagged files.
`dired-recursive-deletes' controls whether deletion of
non-empty directories is allowed."
- (interactive)
+ (interactive nil dired-mode)
(let* ((dired-marker-char dired-del-marker)
(regexp (dired-marker-regexp))
case-fold-search markers)
@@ -3714,13 +3919,18 @@ non-empty directories is allowed."
(or nomessage
(message "(No deletions requested)")))))
+(defun dired-post-do-command ()
+ "Disable `dired-click-to-select-mode' after an operation."
+ (when dired-click-to-select-mode
+ (dired-click-to-select-mode -1)))
+
(defun dired-do-delete (&optional arg)
"Delete all marked (or next ARG) files.
`dired-recursive-deletes' controls whether deletion of
non-empty directories is allowed."
;; This is more consistent with the file marking feature than
;; dired-do-flagged-delete.
- (interactive "P")
+ (interactive "P" dired-mode)
(let (markers)
(dired-internal-do-deletions
(nreverse
@@ -3731,7 +3941,8 @@ non-empty directories is allowed."
m))
arg))
arg t)
- (dolist (m markers) (set-marker m nil))))
+ (dolist (m markers) (set-marker m nil)))
+ (dired-post-do-command))
(defvar dired-deletion-confirmer 'yes-or-no-p) ; or y-or-n-p?
@@ -4023,7 +4234,7 @@ marked file is found after this line.
Optional argument OPOINT specifies the buffer position to
return to if no ARGth marked file is found; it defaults to
the position where this command was invoked."
- (interactive "p\np")
+ (interactive "p\np" dired-mode)
(or opoint (setq opoint (point)));; return to where interactively started
(if (if (> arg 0)
(re-search-forward dired-re-mark nil t arg)
@@ -4044,7 +4255,7 @@ ARG is the numeric prefix argument and defaults to 1.
If WRAP is non-nil, which happens interactively, wrap around
to the end of the buffer and search backwards from there, if
no ARGth marked file is found before this line."
- (interactive "p\np")
+ (interactive "p\np" dired-mode)
(dired-next-marked-file (- arg) wrap))
(defun dired-file-marker (file)
@@ -4083,7 +4294,7 @@ If on a subdir headerline, mark all its files except `.' and `..'.
Use \\[dired-unmark-all-files] to remove all marks
and \\[dired-unmark] on a subdir to remove the marks in
this subdir."
- (interactive (list current-prefix-arg t))
+ (interactive (list current-prefix-arg t) dired-mode)
(cond
;; Mark files in the active region.
((and interactive dired-mark-region
@@ -4127,7 +4338,7 @@ Otherwise, with a prefix arg, unmark files on the next ARG lines.
If looking at a subdir, unmark all its files except `.' and `..'.
If the region is active in Transient Mark mode, unmark all files
in the active region."
- (interactive (list current-prefix-arg t))
+ (interactive (list current-prefix-arg t) dired-mode)
(let ((dired-marker-char ?\s))
(dired-mark arg interactive)))
@@ -4139,7 +4350,7 @@ Otherwise, with a prefix arg, flag files on the next ARG lines.
If on a subdir headerline, flag all its files except `.' and `..'.
If the region is active in Transient Mark mode, flag all files
in the active region."
- (interactive (list current-prefix-arg t))
+ (interactive (list current-prefix-arg t) dired-mode)
(let ((dired-marker-char dired-del-marker))
(dired-mark arg interactive)))
@@ -4149,7 +4360,7 @@ Optional prefix ARG says how many lines to unmark/unflag; default
is one line.
If the region is active in Transient Mark mode, unmark all files
in the active region."
- (interactive "p")
+ (interactive "p" dired-mode)
(dired-unmark (- arg) t))
(defun dired-toggle-marks ()
@@ -4161,7 +4372,7 @@ As always, hidden subdirs are not affected.
In Transient Mark mode, if the mark is active, operate on the contents
of the region if `dired-mark-region' is non-nil. Otherwise, operate
on the whole buffer."
- (interactive)
+ (interactive nil dired-mode)
(save-excursion
(let ((inhibit-read-only t)
(beg (dired-mark--region-beginning))
@@ -4212,7 +4423,8 @@ object files--just `.o' will mark more than you might think."
(dired-get-filename nil t) t))
"\\'"))))
'dired-regexp-history)
- (if current-prefix-arg ?\s)))
+ (if current-prefix-arg ?\s))
+ dired-mode)
(let ((dired-marker-char (or marker-char dired-marker-char)))
(dired-mark-if
(and (not (looking-at-p dired-re-dot))
@@ -4223,7 +4435,7 @@ object files--just `.o' will mark more than you might think."
(defun dired-number-of-marked-files ()
"Display the number and total size of the marked files."
- (interactive)
+ (interactive nil dired-mode)
(let* ((files (dired-get-marked-files nil nil nil t))
(nmarked
(cond ((null (cdr files))
@@ -4262,7 +4474,8 @@ since it was last visited."
(list (read-regexp (concat (if current-prefix-arg "Unmark" "Mark")
" files containing (regexp): ")
nil 'dired-regexp-history)
- (if current-prefix-arg ?\s)))
+ (if current-prefix-arg ?\s))
+ dired-mode)
(let ((dired-marker-char (or marker-char dired-marker-char)))
(dired-mark-if
(and (not (looking-at-p dired-re-dot))
@@ -4291,7 +4504,8 @@ The match is against the non-directory part of the filename. Use `^'
and `$' to anchor matches. Exclude subdirs by hiding them.
`.' and `..' are never flagged."
(interactive (list (read-regexp "Flag for deletion (regexp): "
- nil 'dired-regexp-history)))
+ nil 'dired-regexp-history))
+ dired-mode)
(dired-mark-files-regexp regexp dired-del-marker))
(defun dired-mark-symlinks (unflag-p)
@@ -4299,7 +4513,7 @@ The match is against the non-directory part of the filename. Use `^'
With prefix argument, unmark or unflag all those files.
If the region is active in Transient Mark mode, mark files
only in the active region if `dired-mark-region' is non-nil."
- (interactive "P")
+ (interactive "P" dired-mode)
(let ((dired-marker-char (if unflag-p ?\s dired-marker-char)))
(dired-mark-if (looking-at-p dired-re-sym) "symbolic link")))
@@ -4308,7 +4522,7 @@ only in the active region if `dired-mark-region' is non-nil."
With prefix argument, unmark or unflag all those files.
If the region is active in Transient Mark mode, mark files
only in the active region if `dired-mark-region' is non-nil."
- (interactive "P")
+ (interactive "P" dired-mode)
(let ((dired-marker-char (if unflag-p ?\s dired-marker-char)))
(dired-mark-if (and (looking-at-p dired-re-dir)
(not (looking-at-p dired-re-dot)))
@@ -4319,7 +4533,7 @@ only in the active region if `dired-mark-region' is non-nil."
With prefix argument, unmark or unflag all those files.
If the region is active in Transient Mark mode, mark files
only in the active region if `dired-mark-region' is non-nil."
- (interactive "P")
+ (interactive "P" dired-mode)
(let ((dired-marker-char (if unflag-p ?\s dired-marker-char)))
(dired-mark-if (looking-at-p dired-re-exe) "executable file")))
@@ -4331,7 +4545,7 @@ only in the active region if `dired-mark-region' is non-nil."
A prefix argument says to unmark or unflag those files instead.
If the region is active in Transient Mark mode, flag files
only in the active region if `dired-mark-region' is non-nil."
- (interactive "P")
+ (interactive "P" dired-mode)
(let ((dired-marker-char (if unflag-p ?\s dired-del-marker)))
(dired-mark-if
;; It is less than general to check for # here,
@@ -4365,7 +4579,7 @@ only in the active region if `dired-mark-region' is non-nil."
(defun dired-flag-garbage-files ()
"Flag for deletion all files that match `dired-garbage-files-regexp'."
- (interactive)
+ (interactive nil dired-mode)
(dired-flag-files-regexp dired-garbage-files-regexp))
(defun dired-flag-backup-files (&optional unflag-p)
@@ -4373,7 +4587,7 @@ only in the active region if `dired-mark-region' is non-nil."
With prefix argument, unmark or unflag these files.
If the region is active in Transient Mark mode, flag files
only in the active region if `dired-mark-region' is non-nil."
- (interactive "P")
+ (interactive "P" dired-mode)
(let ((dired-marker-char (if unflag-p ?\s dired-del-marker)))
(dired-mark-if
;; Don't call backup-file-name-p unless the last character looks like
@@ -4401,7 +4615,8 @@ OLD and NEW are both characters used to mark files."
(old (progn (message "Change (old mark): ") (read-char)))
(new (progn (message "Change %c marks to (new mark): " old)
(read-char))))
- (list old new)))
+ (list old new))
+ dired-mode)
(dolist (c (list new old))
(if (or (not (char-displayable-p c))
(eq c ?\r))
@@ -4420,7 +4635,7 @@ OLD and NEW are both characters used to mark files."
(defun dired-unmark-all-marks ()
"Remove all marks from all files in the Dired buffer."
- (interactive)
+ (interactive nil dired-mode)
(dired-unmark-all-files ?\r))
;; Bound in dired-unmark-all-files
@@ -4432,7 +4647,7 @@ After this command, type the mark character to remove,
or type RET to remove all marks.
With prefix arg, query for each marked file.
Type \\[help-command] at that time for help."
- (interactive "cRemove marks (RET means all): \nP")
+ (interactive "cRemove marks (RET means all): \nP" dired-mode)
(save-excursion
(let* ((count 0)
(inhibit-read-only t) case-fold-search
@@ -4609,7 +4824,7 @@ Possible values:
(defun dired-sort-toggle-or-edit (&optional arg)
"Toggle sorting by date, and refresh the Dired buffer.
With a prefix argument, edit the current listing switches instead."
- (interactive "P")
+ (interactive "P" dired-mode)
(when dired-sort-inhibit
(error "Cannot sort this Dired buffer"))
(if arg
@@ -4814,22 +5029,31 @@ Ask means pop up a menu for the user to select one of copy, move or link."
(eval-when-compile (require 'desktop))
(declare-function desktop-file-name "desktop" (filename dirname))
+(defun dired-desktop-save-p ()
+ "Should `dired-directory' be desktop saved?"
+ (or (null desktop-files-not-to-save)
+ (and (stringp desktop-files-not-to-save)
+ (if (consp dired-directory)
+ (not (string-match-p desktop-files-not-to-save (car dired-directory)))
+ (not (string-match-p desktop-files-not-to-save dired-directory))))))
+
(defun dired-desktop-buffer-misc-data (dirname)
"Auxiliary information to be saved in desktop file."
- (cons
- ;; Value of `dired-directory'.
- (if (consp dired-directory)
- ;; Directory name followed by list of files.
- (cons (desktop-file-name (car dired-directory) dirname)
- (cdr dired-directory))
- ;; Directory name, optionally with shell wildcard.
- (desktop-file-name dired-directory dirname))
- ;; Subdirectories in `dired-subdir-alist'.
- (cdr
- (nreverse
- (mapcar
- (lambda (f) (desktop-file-name (car f) dirname))
- dired-subdir-alist)))))
+ (when (dired-desktop-save-p)
+ (cons
+ ;; Value of `dired-directory'.
+ (if (consp dired-directory)
+ ;; Directory name followed by list of files.
+ (cons (desktop-file-name (car dired-directory) dirname)
+ (cdr dired-directory))
+ ;; Directory name, optionally with shell wildcard.
+ (desktop-file-name dired-directory dirname))
+ ;; Subdirectories in `dired-subdir-alist'.
+ (cdr
+ (nreverse
+ (mapcar
+ (lambda (f) (desktop-file-name (car f) dirname))
+ dired-subdir-alist))))))
(defun dired-restore-desktop-buffer (_file-name
_buffer-name
@@ -4935,6 +5159,7 @@ Interactively with prefix argument, read FILE-NAME."
;;; Miscellaneous commands
(declare-function Man-getpage-in-background "man" (topic))
+(defvar Man-support-remote-systems) ; from man.el
(defvar manual-program) ; from man.el
(defun dired-do-man ()
@@ -4942,10 +5167,11 @@ Interactively with prefix argument, read FILE-NAME."
(interactive nil dired-mode)
(require 'man)
(let* ((file (dired-get-file-for-visit))
+ (Man-support-remote-systems (file-remote-p file))
(manual-program (string-replace "*" "%s"
(dired-guess-shell-command
"Man command: " (list file)))))
- (Man-getpage-in-background file)))
+ (Man-getpage-in-background (file-local-name file))))
(defun dired-do-info ()
"In Dired, run `info' on this file."
@@ -4957,6 +5183,100 @@ Interactively with prefix argument, read FILE-NAME."
(interactive nil dired-mode)
(eww-open-file (dired-get-file-for-visit)))
+
+;;; Click-To-Select mode
+
+(defvar dired-click-to-select-map (make-sparse-keymap)
+ "Keymap placed on files under `dired-click-to-select' mode.")
+
+(define-key dired-click-to-select-map [mouse-2]
+ #'dired-mark-for-click)
+
+(defun dired-mark-for-click (event)
+ "Mark or unmark the file underneath the mouse click at EVENT.
+See `dired-click-to-select-mode' for more details."
+ (interactive "e" dired-mode)
+ (let ((posn (event-start event))
+ (inhibit-read-only t))
+ (with-selected-window (posn-window posn)
+ (goto-char (posn-point posn))
+ (save-excursion
+ (dired-repeat-over-lines
+ 1 (lambda ()
+ (let ((char (char-after)))
+ (when (or (not (looking-at-p dired-re-dot))
+ (not (equal dired-marker-char dired-del-marker)))
+ (delete-char 1)
+ (insert (if (eq char dired-marker-char)
+ ;; Insert a space to unmark the file if
+ ;; it's already marked.
+ ?\s
+ ;; Otherwise mark the file.
+ dired-marker-char))))))))))
+
+(defun dired-enable-click-to-select-mode (event)
+ "Enable `dired-click-to-select-mode' and mark the file under EVENT.
+If there is no file under EVENT, call `touch-screen-hold' with
+EVENT instead."
+ (interactive "e" dired-mode)
+ (let* ((posn (event-start event))
+ (window (posn-window posn))
+ (point (posn-point posn)))
+ (if (and window point
+ (get-text-property point 'dired-filename
+ (window-buffer window)))
+ (progn (beep)
+ (touch-screen-inhibit-drag)
+ (with-selected-window window
+ (goto-char point)
+ (save-excursion (dired-mark 1))
+ (dired-click-to-select-mode 1)))
+ (touch-screen-hold event))))
+
+(define-minor-mode dired-click-to-select-mode
+ "Toggle click-to-select inside this Dired buffer.
+When this minor mode is enabled, using `mouse-2' on a file name
+within a Dired buffer will toggle its mark instead of going to it
+within another window.
+
+Disabling this minor mode will unmark all files within the Dired
+buffer.
+
+`dired-click-to-select-mode' is automatically disabled after any
+Dired operation (command whose name starts with `dired-do')
+completes."
+ :group 'dired
+ :lighter " Click-To-Select"
+ (unless (derived-mode-p '(dired-mode wdired-mode))
+ (error "Not a Dired buffer"))
+ (if dired-click-to-select-mode
+ (setq-local tool-bar-map
+ `(keymap (exit-click-to-select menu-item
+ "Exit Click To Select Mode"
+ dired-click-to-select-mode
+ :help "Exit `dired-click-to-select-mode'."
+ :image ,(tool-bar--image-expression "close")
+ :enable t)))
+ ;; Reset the default tool bar.
+ (kill-local-variable 'tool-bar-map)
+ (dired-unmark-all-marks))
+ ;; Repropertize this Dired buffer.
+ (let ((inhibit-read-only t))
+ (remove-text-properties (point-min) (point-max)
+ '(invisible nil
+ keymap nil
+ dired-filename nil
+ help-echo nil
+ mouse-face nil))
+ (when dired-make-directory-clickable
+ (dired--make-directory-clickable))
+ (dired-insert-set-properties (point-min) (point-max)))
+ ;; Redisplay the tool bar.
+ (force-mode-line-update))
+
+(define-obsolete-variable-alias 'dired-move-to-filename-regexp
+ 'directory-listing-before-filename-regexp "30.1")
+
(provide 'dired)
(run-hooks 'dired-load-hook) ; for your customizations
diff --git a/lisp/dnd.el b/lisp/dnd.el
index 89652d32abf..1fc1ab45b84 100644
--- a/lisp/dnd.el
+++ b/lisp/dnd.el
@@ -42,23 +42,25 @@
;;;###autoload
(defcustom dnd-protocol-alist
- `((,(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 "^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 "^file:[^/]") . dnd-open-local-file) ; MS-Windows
+ (,(purecopy "^\\(https?\\|ftp\\|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'.
+This variable is used by `dnd-handle-multiple-urls'.
The list contains of (REGEXP . FUNCTION) pairs.
The functions shall take two arguments, URL, which is the URL dropped and
ACTION which is the action to be performed for the drop (move, copy, link,
private or ask).
+If a function's `dnd-multiple-handler' property is set, it is provided
+a list of each URI dropped instead.
If no match is found here, and the value of `browse-url-browser-function'
is a pair of (REGEXP . FUNCTION), those regexps are tried for a match.
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"
+ :version "30.1"
:type '(repeat (cons (regexp) (function)))
:group 'dnd)
@@ -159,7 +161,10 @@ If no match is found here, `browse-url-handlers' and
`browse-url-default-handlers' are searched for a match.
If no match is found, just call `dnd-insert-text'. WINDOW is
where the drop happened, ACTION is the action for the drop, URL
-is what has been dropped. Returns ACTION."
+is what has been dropped. Returns ACTION.
+
+This function has been obsolete since Emacs 30.1; it has been
+supplanted by `dnd-handle-multiple-urls'."
(let (ret)
(or
(catch 'done
@@ -180,6 +185,91 @@ is what has been dropped. Returns ACTION."
(setq ret 'private)))
ret))
+(make-obsolete 'dnd-handle-one-url 'dnd-handle-multiple-urls "30.1")
+
+(defun dnd-handle-multiple-urls (window urls action)
+ "Select a handler for, then open, each element of URLS.
+The argument ACTION is the action which must be taken, much as
+that to `dnd-begin-file-drag'.
+
+Assign and give each URL to one of the \"DND handler\" functions
+listed in the variable `dnd-protocol-alist'. When multiple
+handlers matching the same subset of URLs exist, give precedence
+to the handler assigned the greatest number of URLs.
+
+If a handler is a symbol with the property
+`dnd-multiple-handler', call it with ACTION and a list of every
+URL it is assigned. Otherwise, call it once for each URL
+assigned with ACTION and the URL in question.
+
+Subsequently open URLs that don't match any handlers opened with
+any handler selected by `browse-url-select-handler', and failing
+even that, insert them with `dnd-insert-text'.
+
+Return a symbol designating the actions taken by each DND handler
+called. If all DND handlers called return the same symbol,
+return that symbol; otherwise, or if no DND handlers are called,
+return `private'.
+
+Do not rely on the contents of URLS after calling this function,
+for it will be modified."
+ (let ((list nil) (return-value nil))
+ (with-selected-window window
+ (dolist (handler dnd-protocol-alist)
+ (let ((pattern (car handler))
+ (handler (cdr handler)))
+ (dolist (uri urls)
+ (when (string-match pattern uri)
+ (let ((cell (or (cdr (assq handler list))
+ (let ((cell (cons handler nil)))
+ (push cell list)
+ cell))))
+ (unless (memq uri cell)
+ (setcdr cell (cons uri (cdr cell)))))))))
+ (setq list (nreverse list))
+ ;; While unassessed handlers still exist...
+ (while list
+ ;; Sort list by the number of URLs assigned to each handler.
+ (setq list (sort list (lambda (first second)
+ (> (length (cdr first))
+ (length (cdr second))))))
+ ;; Call the handler in its car before removing each URL from
+ ;; URLs.
+ (let ((handler (caar list))
+ (entry-urls (cdar list)))
+ (setq list (cdr list))
+ (when entry-urls
+ (if (and (symbolp handler)
+ (get handler 'dnd-multiple-handler))
+ (progn
+ (let ((value (funcall handler entry-urls action)))
+ (if (or (not return-value)
+ (eq return-value value))
+ (setq return-value value)
+ (setq return-value 'private)))
+ (dolist (url entry-urls)
+ (setq urls (delq url urls))
+ ;; And each handler-URL list after this.
+ (dolist (item list)
+ (setcdr item (delq url (cdr item))))))
+ (dolist (url entry-urls)
+ (let ((value (funcall handler url action)))
+ (if (or (not return-value) (eq return-value value))
+ (setq return-value value)
+ (setq return-value 'private)))
+ (setq urls (delq url urls))
+ ;; And each handler-URL list after this.
+ (dolist (item list)
+ (setcdr item (delq url (cdr item)))))))))
+ ;; URLS should now incorporate only those which haven't been
+ ;; assigned their own handlers.
+ (dolist (leftover urls)
+ (setq return-value 'private)
+ (if-let ((handler (browse-url-select-handler leftover
+ 'internal)))
+ (funcall handler leftover action)
+ (dnd-insert-text window action leftover)))
+ (or return-value 'private))))
(defun dnd-get-local-file-uri (uri)
"Return an uri converted to file:/// syntax if uri is a local file.
@@ -201,6 +291,11 @@ Return nil if URI is not a local file."
(string-equal sysname-no-dot hostname)))
(concat "file://" (substring uri (+ 7 (length hostname))))))))
+(defvar dnd-unescape-file-uris t
+ "Whether to unescape file: URIs before they are opened.
+Bind this to nil when providing `dnd-get-local-file-name' with a
+file name that may incorporate URI escape sequences.")
+
(defun dnd--unescape-uri (uri)
;; Merge with corresponding code in URL library.
(replace-regexp-in-string
@@ -226,7 +321,10 @@ Return nil if URI is not a local file."
'utf-8
(or file-name-coding-system
default-file-name-coding-system))))
- (and f (setq f (decode-coding-string (dnd--unescape-uri f) coding)))
+ (and f (setq f (decode-coding-string
+ (if dnd-unescape-file-uris
+ (dnd--unescape-uri f) f)
+ coding)))
(when (and f must-exist (not (file-readable-p f)))
(setq f nil))
f))
@@ -355,7 +453,10 @@ on FRAME itself.
This function might return immediately if no mouse buttons are
currently being held down. It should only be called upon a
-`down-mouse-1' (or similar) event."
+`down-mouse-1' (or similar) event.
+
+This function is only supported on X Windows, macOS/GNUstep, and Haiku;
+on all other platforms it will signal an error."
(unless (fboundp 'x-begin-drag)
(error "Dragging text from Emacs is not supported by this window system"))
(gui-set-selection 'XdndSelection text)
@@ -415,7 +516,10 @@ nil, any drops on FRAME itself will be ignored.
This function might return immediately if no mouse buttons are
currently being held down. It should only be called upon a
-`down-mouse-1' (or similar) event."
+`down-mouse-1' (or similar) event.
+
+This function is only supported on X Windows, macOS/GNUstep, and Haiku;
+on all other platforms it will signal an error."
(unless (fboundp 'x-begin-drag)
(error "Dragging files from Emacs is not supported by this window system"))
(dnd-remove-last-dragged-remote-file)
@@ -482,7 +586,10 @@ FRAME, ACTION and ALLOW-SAME-FRAME mean the same as in
FILES is a list of files that will be dragged. If the drop
target doesn't support dropping multiple files, the first file in
-FILES will be dragged."
+FILES will be dragged.
+
+This function is only supported on X Windows, macOS/GNUstep, and Haiku;
+on all other platforms it will signal an error."
(unless (fboundp 'x-begin-drag)
(error "Dragging files from Emacs is not supported by this window system"))
(dnd-remove-last-dragged-remote-file)
diff --git a/lisp/doc-view.el b/lisp/doc-view.el
index 5c167d1ef24..c4b384c35c6 100644
--- a/lisp/doc-view.el
+++ b/lisp/doc-view.el
@@ -147,6 +147,8 @@
(require 'filenotify)
(eval-when-compile (require 'subr-x))
+(autoload 'imenu-unavailable-error "imenu")
+
;;;; Customization Options
(defgroup doc-view nil
@@ -174,7 +176,7 @@ are available (see Info node `(emacs)Document View')."
;; non-MikTeX apps. Was available under:
;; http://blog.miktex.org/post/2005/04/07/Starting-mgsexe-at-the-DOS-Prompt.aspx
((and (executable-find "mgs")
- (= 0 (shell-command "mgs -q -dNODISPLAY -c quit")))
+ (eql 0 (shell-command "mgs -q -dNODISPLAY -c quit")))
"mgs")))
(t "gs"))
"Program to convert PS and PDF files to PNG."
@@ -202,17 +204,17 @@ are available (see Info node `(emacs)Document View')."
#'doc-view-pdf->png-converter-ghostscript)
"Function to call to convert a PDF file into a PNG file."
:type '(radio
- (function-item doc-view-pdf->png-converter-ghostscript
- :doc "Use ghostscript")
- (function-item doc-view-pdf->png-converter-mupdf
- :doc "Use mupdf")
+ (function-item :doc "Use Ghostscript"
+ doc-view-pdf->png-converter-ghostscript)
+ (function-item :doc "Use MuPDF"
+ doc-view-pdf->png-converter-mupdf)
function)
:version "24.4")
-(defcustom doc-view-mupdf-use-svg nil
- "Whether to use SVG images for PDF files."
+(defcustom doc-view-mupdf-use-svg (image-type-available-p 'svg)
+ "Whether to use svg images for PDF files."
:type 'boolean
- :version "29.1")
+ :version "30.1")
(defcustom doc-view-imenu-enabled (and (executable-find "mutool") t)
"Whether to generate an imenu outline when \"mutool\" is available."
@@ -236,17 +238,14 @@ showing only titles and no page number."
:type 'boolean
:version "29.1")
-(defcustom doc-view-svg-background "white"
- "Background color for svg images.
+(defface doc-view-svg-face '((t :inherit default))
+ "Face used for SVG images. Only background and foreground colors
+are used.
See `doc-view-mupdf-use-svg'."
- :type 'color
- :version "29.1")
+ :version "30.1")
-(defcustom doc-view-svg-foreground "black"
- "Foreground color for svg images.
-See `doc-view-mupdf-use-svg'."
- :type 'color
- :version "29.1")
+(make-obsolete 'doc-view-svg-background 'doc-view-svg-face "30.1")
+(make-obsolete 'doc-view-svg-foreground 'doc-view-svg-face "30.1")
(defcustom doc-view-ghostscript-options
'("-dSAFER" ;; Avoid security problems when rendering files from untrusted
@@ -376,17 +375,15 @@ Needed for viewing OpenOffice.org (and MS Office) files."
:type 'file)
(defcustom doc-view-odf->pdf-converter-function
- (cond
- ((string-match "unoconv\\'" doc-view-odf->pdf-converter-program)
- #'doc-view-odf->pdf-converter-unoconv)
- ((string-match "soffice\\'" doc-view-odf->pdf-converter-program)
- #'doc-view-odf->pdf-converter-soffice))
- "Function to call to convert a ODF file into a PDF file."
+ (if (string-suffix-p "unoconv" doc-view-odf->pdf-converter-program)
+ #'doc-view-odf->pdf-converter-unoconv
+ #'doc-view-odf->pdf-converter-soffice)
+ "Function to call to convert an ODF file into a PDF file."
:type '(radio
- (function-item doc-view-odf->pdf-converter-unoconv
- :doc "Use unoconv")
- (function-item doc-view-odf->pdf-converter-soffice
- :doc "Use LibreOffice")
+ (function-item :doc "Use LibreOffice"
+ doc-view-odf->pdf-converter-soffice)
+ (function-item :doc "Use unoconv"
+ doc-view-odf->pdf-converter-unoconv)
function)
:version "24.4")
@@ -578,8 +575,8 @@ Typically \"page-%s.png\".")
;; file. (TODO: We'd like to have something like that also
;; for other types, at least PS, but I don't know a good way
;; to test if a PS file is complete.)
- (if (= 0 (call-process "pdfinfo" nil nil nil
- doc-view--buffer-file-name))
+ (if (eql 0 (call-process "pdfinfo" nil nil nil
+ doc-view--buffer-file-name))
(revert)
(when (called-interactively-p 'interactive)
(message "Can't revert right now because the file is corrupted.")))
@@ -646,7 +643,7 @@ Typically \"page-%s.png\".")
:help "Reset the current slice"
:enabled (image-mode-window-get 'slice)])
"---"
- ["New Search" (doc-view-search t)
+ ["New Search" doc-view-new-search
:help "Initiate a new search"]
["Search Forward" doc-view-search
:help "Jump to the next match or initiate a new search"]
@@ -664,11 +661,52 @@ Typically \"page-%s.png\".")
'("DocView (edit)"
("Toggle edit/display"
["Edit document" (lambda ()) ; ignore but show no keybinding
- :style radio :selected (eq major-mode 'doc-view--text-view-mode)]
+ ;; This is always selected since its menu is singular to the
+ ;; display minor mode.
+ :style radio :selected t]
["Display document" doc-view-toggle-display
:style radio :selected (eq major-mode 'doc-view-mode)])
["Exit DocView Mode" doc-view-minor-mode]))
+(defvar doc-view-tool-bar-map
+ (let ((map (make-sparse-keymap)))
+ ;; Most of these items are the same as in the default tool bar
+ ;; map, but with extraneous items removed, and with extra search
+ ;; and navigation items.
+ (tool-bar-local-item-from-menu 'find-file "new" map
+ nil :label "New File"
+ :vert-only t)
+ (tool-bar-local-item-from-menu 'menu-find-file-existing "open" map
+ nil :label "Open" :vert-only t)
+ (tool-bar-local-item-from-menu 'dired "diropen" map nil :vert-only t)
+ (tool-bar-local-item-from-menu 'kill-this-buffer "close" map nil
+ :vert-only t)
+ (define-key-after map [separator-1] menu-bar-separator)
+ (tool-bar-local-item-from-menu 'doc-view-new-search "search"
+ map doc-view-mode-map :vert-only t
+ :help "Start a new search query.")
+ (tool-bar-local-item-from-menu 'doc-view-search-backward "left-arrow"
+ map doc-view-mode-map
+ :vert-only t
+ :enable 'doc-view--current-search-matches
+ :help "Move to the last search result.")
+ (tool-bar-local-item-from-menu 'doc-view-search "right-arrow"
+ map doc-view-mode-map :vert-only t
+ :enable 'doc-view--current-search-matches
+ :help "Move to the next search result.")
+ (define-key-after map [separator-2] menu-bar-separator)
+ (tool-bar-local-item-from-menu 'doc-view-previous-page "last-page"
+ map doc-view-mode-map :vert-only t
+ :enable '(> (doc-view-current-page) 1)
+ :help "Move to the previous page.")
+ (tool-bar-local-item-from-menu 'doc-view-next-page "next-page"
+ map doc-view-mode-map :vert-only t
+ :enable '(< (doc-view-current-page)
+ (doc-view-last-page-number))
+ :help "Move to the next page.")
+ map)
+ "Like the default `tool-bar-map', but with additions for DocView.")
+
;;;; Navigation Commands
(defun doc-view-last-page-number ()
@@ -902,8 +940,7 @@ Document types are symbols like `dvi', `ps', `pdf', `epub',
(and doc-view-pdfdraw-program
(executable-find doc-view-pdfdraw-program)))))
((eq type 'odf)
- (and doc-view-odf->pdf-converter-program
- (executable-find doc-view-odf->pdf-converter-program)
+ (and (executable-find doc-view-odf->pdf-converter-program)
(doc-view-mode-p 'pdf)))
((eq type 'djvu)
(executable-find "ddjvu"))
@@ -1245,7 +1282,8 @@ The test is performed using `doc-view-pdfdraw-program'."
(expand-file-name
doc-view-epub-user-stylesheet)))))))
(doc-view-start-process
- "pdf->png" doc-view-pdfdraw-program
+ (concat "pdf->" (symbol-name doc-view--image-type))
+ doc-view-pdfdraw-program
`(,@(doc-view-pdfdraw-program-subcommand)
,@options
,pdf
@@ -1602,8 +1640,8 @@ ARGS is a list of image descriptors."
(unless (member :transform-smoothing args)
(setq args `(,@args :transform-smoothing t)))
(when (eq doc-view--image-type 'svg)
- (setq args `(,@args :background ,doc-view-svg-background
- :foreground ,doc-view-svg-foreground)))
+ (setq args `(,@args :background ,(face-background 'doc-view-svg-face)
+ :foreground ,(face-foreground 'doc-view-svg-face))))
(apply #'create-image file doc-view--image-type nil args))))
(slice (doc-view-current-slice))
(img-width (and image (car (image-size image))))
@@ -1866,7 +1904,16 @@ If BACKWARD is non-nil, jump to the previous match."
;; We must convert to TXT first!
(if doc-view--current-converter-processes
(message "DocView: please wait till conversion finished.")
- (doc-view-doc->txt txt (lambda () (doc-view-search nil))))))))
+ (doc-view-doc->txt txt (lambda () (doc-view-search nil))))))
+ ;; Update the tool bar items.
+ (force-mode-line-update)))
+
+(defun doc-view-new-search ()
+ "Initiate a new search query.
+Prompt for a string, then search for its appearances within
+the document text."
+ (interactive)
+ (doc-view-search t nil))
(defun doc-view-search-next-match (arg)
"Go to the ARGth next matching page."
@@ -1913,9 +1960,10 @@ structure is extracted by `doc-view--imenu-subtree'."
(let ((fn (or file-name (buffer-file-name))))
(when fn
(let ((outline nil)
- (fn (shell-quote-argument (expand-file-name fn))))
+ (fn (expand-file-name fn)))
(with-temp-buffer
- (insert (shell-command-to-string (format "mutool show %s outline" fn)))
+ (unless (eql 0 (call-process "mutool" nil (current-buffer) nil "show" fn "outline"))
+ (imenu-unavailable-error "Unable to create imenu index using `mutool'"))
(goto-char (point-min))
(while (re-search-forward doc-view--outline-rx nil t)
(push `((level . ,(length (match-string 1)))
@@ -1964,7 +2012,7 @@ GOTO-PAGE-FN other than `doc-view-goto-page'."
(defun doc-view-imenu-setup ()
"Set up local state in the current buffer for imenu, if needed."
- (when (and doc-view-imenu-enabled (executable-find "mutool"))
+ (when doc-view-imenu-enabled
(setq-local imenu-create-index-function #'doc-view-imenu-index
imenu-submenus-on-top nil
imenu-sort-function nil
@@ -2190,8 +2238,15 @@ toggle between displaying the document or editing it as text.
;; supposed to return nil for things like local files accessed
;; via `su' or via file://...
((let ((file-name-handler-alist nil))
- (not (and buffer-file-name
- (file-readable-p buffer-file-name))))
+ (or (not (and buffer-file-name
+ (file-readable-p buffer-file-name)))
+ ;; If the system is Android and the file name
+ ;; begins with /content or /assets, it's not
+ ;; readable by local processes.
+ (and (eq system-type 'android)
+ (string-match-p "/\\(content\\|assets\\)[/$]"
+ (expand-file-name
+ buffer-file-name)))))
;; FIXME: there's a risk of name conflicts here.
(expand-file-name
(if buffer-file-name
@@ -2239,8 +2294,13 @@ toggle between displaying the document or editing it as text.
(setq mode-name "DocView"
buffer-read-only t
major-mode 'doc-view-mode)
- (doc-view-imenu-setup)
+ (condition-case imenu-error
+ (doc-view-imenu-setup)
+ (imenu-unavailable (message "imenu support unavailable: %s"
+ (cadr imenu-error))))
(doc-view-initiate-display)
+ ;; Replace the tool bar map with `doc-view-tool-bar-map'.
+ (setq-local tool-bar-map doc-view-tool-bar-map)
;; Switch off view-mode explicitly, because doc-view-mode is the
;; canonical view mode for PDF/PS/DVI files. This could be
;; switched on automatically depending on the value of
diff --git a/lisp/dom.el b/lisp/dom.el
index f7043ba8252..b329379fdc3 100644
--- a/lisp/dom.el
+++ b/lisp/dom.el
@@ -288,7 +288,7 @@ If XML, generate XML instead of HTML."
(insert ">")
(dolist (child children)
(if (stringp child)
- (insert child)
+ (insert (url-insert-entities-in-string child))
(setq non-text t)
(when pretty
(insert "\n" (make-string (+ column 2) ?\s)))
diff --git a/lisp/dynamic-setting.el b/lisp/dynamic-setting.el
index 09b6e11c42e..e54dce11541 100644
--- a/lisp/dynamic-setting.el
+++ b/lisp/dynamic-setting.el
@@ -33,6 +33,7 @@
;;; Customizable variables
(declare-function font-get-system-font "xsettings.c" ())
+(declare-function reconsider-frame-font "frame.c" ())
(defvar font-use-system-font)
diff --git a/lisp/edmacro.el b/lisp/edmacro.el
index e87d271ecb2..abfc380d154 100644
--- a/lisp/edmacro.el
+++ b/lisp/edmacro.el
@@ -73,9 +73,19 @@ Default nil means to write characters above \\177 in octal notation."
:type 'boolean
:group 'kmacro)
+(defcustom edmacro-reverse-macro-lines nil
+ "If non-nil, `edit-kbd-macro' shows most recent line of key sequences first.
+
+This is useful when dealing with long lists of key sequences, such as
+from `kmacro-edit-lossage'."
+ :type 'boolean
+ :group 'kmacro
+ :version "30.1")
+
(defvar-keymap edmacro-mode-map
"C-c C-c" #'edmacro-finish-edit
- "C-c C-q" #'edmacro-insert-key)
+ "C-c C-q" #'edmacro-insert-key
+ "C-c C-r" #'edmacro-set-macro-to-region-lines)
(defface edmacro-label
'((default :inherit bold)
@@ -88,20 +98,23 @@ Default nil means to write characters above \\177 in octal notation."
:group 'kmacro)
(defvar edmacro-mode-font-lock-keywords
- `((,(rx bol (group (or "Command" "Key" "Macro") ":")) 0 'edmacro-label)
+ `((,(rx bol (group (or "Command" "Key"
+ (seq "Macro" (zero-or-one " (most recent line first)")))
+ ":"))
+ 0 'edmacro-label)
(,(rx bol
(group ";; Keyboard Macro Editor. Press ")
- (group (*? any))
+ (group (*? nonl))
(group " to finish; press "))
(1 'font-lock-comment-face)
(2 'help-key-binding)
(3 'font-lock-comment-face)
- (,(rx (group (*? any))
- (group " to cancel" (* any)))
+ (,(rx (group (*? nonl))
+ (group " to cancel" (* nonl)))
nil nil
(1 'help-key-binding)
(2 'font-lock-comment-face)))
- (,(rx (one-or-more ";") (zero-or-more any)) 0 'font-lock-comment-face)))
+ (,(rx (one-or-more ";") (zero-or-more nonl)) 0 'font-lock-comment-face)))
(defvar edmacro-store-hook)
(defvar edmacro-finish-hook)
@@ -111,9 +124,9 @@ Default nil means to write characters above \\177 in octal notation."
(defun edit-kbd-macro (keys &optional prefix finish-hook store-hook)
"Edit a keyboard macro.
At the prompt, type any key sequence which is bound to a keyboard macro.
-Or, type `\\[kmacro-end-and-call-macro]' or \\`RET' to edit the last
-keyboard macro, `\\[view-lossage]' to edit the last 300
-keystrokes as a keyboard macro, or `\\[execute-extended-command]'
+Or, type \\[kmacro-end-and-call-macro] or \\`RET' to edit the last
+keyboard macro, \\[view-lossage] to edit the last 300
+keystrokes as a keyboard macro, or \\[execute-extended-command]
to edit a macro by its command name.
With a prefix argument, format the macro in a more concise way."
(interactive
@@ -166,7 +179,13 @@ With a prefix argument, format the macro in a more concise way."
(let* ((oldbuf (current-buffer))
(mmac (edmacro-fix-menu-commands mac))
(fmt (edmacro-format-keys mmac 1))
- (fmtv (edmacro-format-keys mmac (not prefix)))
+ (fmtv (let ((fmtv (edmacro-format-keys mmac (not prefix))))
+ (if (not edmacro-reverse-macro-lines)
+ fmtv
+ (with-temp-buffer
+ (insert fmtv)
+ (reverse-region (point-min) (point-max))
+ (buffer-string)))))
(buf (get-buffer-create "*Edit Macro*")))
(message "Formatting keyboard macro...done")
(switch-to-buffer buf)
@@ -181,6 +200,9 @@ With a prefix argument, format the macro in a more concise way."
(setq-local font-lock-defaults
'(edmacro-mode-font-lock-keywords nil nil ((?\" . "w"))))
(setq font-lock-multiline nil)
+ ;; Make buffer-local so that the commands still work
+ ;; even if the default value changes.
+ (make-local-variable 'edmacro-reverse-macro-lines)
(erase-buffer)
(insert (substitute-command-keys
(concat
@@ -202,7 +224,9 @@ With a prefix argument, format the macro in a more concise way."
(insert "Key: none\n")))
(when (and mac-counter mac-format)
(insert (format "Counter: %d\nFormat: \"%s\"\n" mac-counter mac-format))))
- (insert "\nMacro:\n\n")
+ (insert (format "\nMacro%s:\n\n" (if edmacro-reverse-macro-lines
+ " (most recent line first)"
+ "")))
(save-excursion
(insert fmtv "\n"))
(recenter '(4))
@@ -255,6 +279,33 @@ or nil, use a compact 80-column format."
;;; Commands for *Edit Macro* buffer.
+(defvar edmacro--skip-line-regexp
+ "[ \t]*\\($\\|;;\\|REM[ \t\n]\\)"
+ "A regexp identifying lines that should be ignored.")
+
+(defvar edmacro--command-line-regexp
+ "Command:[ \t]*\\([^ \t\n]*\\)[ \t]*$"
+ "A regexp identifying the line containing the command name.")
+
+(defvar edmacro--key-line-regexp
+ "Key:\\(.*\\)$"
+ "A regexp identifying the line containing the bound key sequence.")
+
+(defvar edmacro--counter-line-regexp
+ "Counter:[ \t]*\\([^ \t\n]*\\)[ \t]*$"
+ "A regexp identifying the line containing the counter value.")
+
+(defvar edmacro--format-line-regexp
+ "Format:[ \t]*\"\\([^\n]*\\)\"[ \t]*$"
+ "A regexp identifying the line containing the counter format.")
+
+(defvar edmacro--macro-lines-regexp
+ (rx "Macro"
+ (zero-or-one " (most recent line first)")
+ ":"
+ (zero-or-more (any " \t\n")))
+ "A regexp identifying the lines that precede the macro's contents.")
+
(defun edmacro-finish-edit ()
(interactive nil edmacro-mode)
(unless (eq major-mode 'edmacro-mode)
@@ -266,9 +317,9 @@ or nil, use a compact 80-column format."
(top (point-min)))
(goto-char top)
(let ((case-fold-search nil))
- (while (cond ((looking-at "[ \t]*\\($\\|;;\\|REM[ \t\n]\\)")
+ (while (cond ((looking-at edmacro--skip-line-regexp)
t)
- ((looking-at "Command:[ \t]*\\([^ \t\n]*\\)[ \t]*$")
+ ((looking-at edmacro--command-line-regexp)
(when edmacro-store-hook
(error "\"Command\" line not allowed in this context"))
(let ((str (match-string 1)))
@@ -283,7 +334,7 @@ or nil, use a compact 80-column format."
cmd)))
(keyboard-quit))))
t)
- ((looking-at "Key:\\(.*\\)$")
+ ((looking-at edmacro--key-line-regexp)
(when edmacro-store-hook
(error "\"Key\" line not allowed in this context"))
(let ((key (kbd (match-string 1))))
@@ -303,21 +354,21 @@ or nil, use a compact 80-column format."
(edmacro-format-keys key 1))))
(keyboard-quit))))))
t)
- ((looking-at "Counter:[ \t]*\\([^ \t\n]*\\)[ \t]*$")
+ ((looking-at edmacro--counter-line-regexp)
(when edmacro-store-hook
(error "\"Counter\" line not allowed in this context"))
(let ((str (match-string 1)))
(unless (equal str "")
(setq mac-counter (string-to-number str))))
t)
- ((looking-at "Format:[ \t]*\"\\([^\n]*\\)\"[ \t]*$")
+ ((looking-at edmacro--format-line-regexp)
(when edmacro-store-hook
(error "\"Format\" line not allowed in this context"))
(let ((str (match-string 1)))
(unless (equal str "")
(setq mac-format str)))
t)
- ((looking-at "Macro:[ \t\n]*")
+ ((looking-at edmacro--macro-lines-regexp)
(goto-char (match-end 0))
nil)
((eobp) nil)
@@ -336,7 +387,13 @@ or nil, use a compact 80-column format."
(when (buffer-name obuf)
(set-buffer obuf))
(message "Compiling keyboard macro...")
- (let ((mac (edmacro-parse-keys str)))
+ (let ((mac (edmacro-parse-keys (if edmacro-reverse-macro-lines
+ (with-temp-buffer
+ (insert str)
+ (reverse-region (point-min)
+ (point-max))
+ (buffer-string))
+ str))))
(message "Compiling keyboard macro...done")
(if store-hook
(funcall store-hook mac)
@@ -372,6 +429,36 @@ or nil, use a compact 80-column format."
(insert (edmacro-format-keys key t) "\n")
(insert (edmacro-format-keys key) " ")))
+(defun edmacro-set-macro-to-region-lines (beg end)
+ "Set the macro text to lines of text in the buffer between BEG and END.
+
+Interactively, BEG and END are the beginning and end of the
+region. If the region does not begin at the start of a line or
+if it does not end at the end of a line, the region is extended
+to include complete lines. If the region ends at the beginning
+of a line, that final line is excluded."
+ (interactive "*r" edmacro-mode)
+ ;; Use `save-excursion' to restore region if there are any errors.
+ ;; If there are no errors, update the macro text, then go to the
+ ;; beginning of the macro text.
+ (let ((final-position))
+ (save-excursion
+ (goto-char beg)
+ (unless (bolp) (setq beg (pos-bol)))
+ (goto-char end)
+ (unless (or (bolp) (eolp)) (setq end (pos-eol)))
+ (let ((text (buffer-substring beg end)))
+ (goto-char (point-min))
+ (if (not (let ((case-fold-search nil))
+ (re-search-forward edmacro--macro-lines-regexp nil t)))
+ (user-error "\"Macro:\" line not found")
+ (delete-region (match-end 0)
+ (point-max))
+ (goto-char (point-max))
+ (insert text)
+ (setq final-position (match-beginning 0)))))
+ (goto-char final-position)))
+
(defun edmacro-mode ()
"\\<edmacro-mode-map>Keyboard Macro Editing mode. Press \
\\[edmacro-finish-edit] to save and exit.
@@ -393,6 +480,10 @@ or \"none\" for no key bindings.
You can edit these lines to change the places where the new macro
is stored.
+Press \\[edmacro-set-macro-to-region-lines] to replace the text following the \"Macro:\" line
+with the text of the lines overlapping the region of text between
+point and mark. If that region ends at the beginning of a line,
+that final line is excluded.
Format of keyboard macros during editing:
@@ -629,17 +720,15 @@ This function assumes that the events can be stored in a string."
(setf (aref seq i) (logand (aref seq i) 127)))
seq)
-;; These are needed in a --without-x build.
-(defvar mouse-wheel-down-event)
-(defvar mouse-wheel-up-event)
-(defvar mouse-wheel-right-event)
-(defvar mouse-wheel-left-event)
-
(defun edmacro-fix-menu-commands (macro &optional noerror)
(if (vectorp macro)
(let (result)
;; Not preloaded in a --without-x build.
(require 'mwheel)
+ (defvar mouse-wheel-down-event)
+ (defvar mouse-wheel-up-event)
+ (defvar mouse-wheel-right-event)
+ (defvar mouse-wheel-left-event)
;; Make a list of the elements.
(setq macro (append macro nil))
(dolist (ev macro)
@@ -655,9 +744,9 @@ This function assumes that the events can be stored in a string."
;; info is recorded in macros to make this possible.
((or (mouse-event-p ev) (mouse-movement-p ev)
(memq (event-basic-type ev)
- (list mouse-wheel-down-event mouse-wheel-up-event
- mouse-wheel-right-event
- mouse-wheel-left-event)))
+ `( ,mouse-wheel-down-event ,mouse-wheel-up-event
+ ,mouse-wheel-right-event ,mouse-wheel-left-event
+ wheel-down wheel-up wheel-left wheel-right)))
nil)
(noerror nil)
(t
diff --git a/lisp/elec-pair.el b/lisp/elec-pair.el
index 2346ee7e5d9..40618e9ef38 100644
--- a/lisp/elec-pair.el
+++ b/lisp/elec-pair.el
@@ -153,7 +153,7 @@ return value is considered instead."
:type '(choice (set (const :tag "Space" ?\s)
(const :tag "Tab" ?\t)
(const :tag "Newline" ?\n))
- (list character)))
+ (repeat (character :value " "))))
(defvar-local electric-pair-skip-whitespace-function
#'electric-pair--skip-whitespace
@@ -162,6 +162,20 @@ Before attempting a skip, if `electric-pair-skip-whitespace' is
non-nil, this function is called. It move point to a new buffer
position, presumably skipping only whitespace in between.")
+(defun electric-pair-analyze-conversion (string)
+ "Notice that STRING has been deleted by an input method.
+If the last character of STRING is an electric pair character,
+and the character after point is too, then delete that other
+character."
+ (let* ((prev (aref string (1- (length string))))
+ (next (char-after))
+ (syntax-info (electric-pair-syntax-info prev))
+ (syntax (car syntax-info))
+ (pair (cadr syntax-info)))
+ (when (and next pair (memq syntax '(?\( ?\" ?\$))
+ (eq pair next))
+ (delete-char 1))))
+
(defun electric-pair--skip-whitespace ()
"Skip whitespace forward, not crossing comment or string boundaries."
(let ((saved (point))
@@ -439,7 +453,9 @@ happened."
;; position some markers. The real fix would be to compute the
;; result without having to modify the buffer at all.
(atomic-change-group
- (delete-char -1)
+ ;; Don't use `delete-char'; that may modify the head of the
+ ;; undo list.
+ (delete-region (point) (1- (point)))
(throw
'done
(cond ((eq ?\( syntax)
diff --git a/lisp/electric.el b/lisp/electric.el
index fc27d0a1efe..fee0bf36d7f 100644
--- a/lisp/electric.el
+++ b/lisp/electric.el
@@ -409,9 +409,7 @@ If multiple rules match, only first one is executed.")
(goto-char pos)
(funcall probe last-command-event))))
(when res (throw 'done res))))))))))
- (when (and rule
- ;; Not in a string or comment.
- (not (nth 8 (save-excursion (syntax-ppss pos)))))
+ (when rule
(goto-char pos)
(when (functionp rule) (setq rule (funcall rule)))
(dolist (sym (if (symbolp rule) (list rule) rule))
diff --git a/lisp/elide-head.el b/lisp/elide-head.el
index 7e3a4142bd8..808bf55a05f 100644
--- a/lisp/elide-head.el
+++ b/lisp/elide-head.el
@@ -50,24 +50,41 @@
:group 'tools)
(defcustom elide-head-headers-to-hide
- `(;; GNU GPL
- ("is free software[:;] you can redistribute it" .
- ,(rx (or (seq "If not, see " (? "<")
- "http" (? "s") "://www.gnu.org/licenses"
- (? "/") (? ">") (? " "))
- (seq "Boston, MA " (? " ")
- "0211" (or "1-1307" "0-1301")
- (or " " ", ") "USA")
- "675 Mass Ave, Cambridge, MA 02139, USA")
- (? ".")))
- ;; FreeBSD license / Modified BSD license (3-clause)
- (,(rx (or "The Regents of the University of California. All rights reserved."
- "Redistribution and use in source and binary"))
- . "POSSIBILITY OF SUCH DAMAGE\\.")
- ;; X11 and Expat
- ("Permission is hereby granted, free of charge" .
- ,(rx (or "authorization from the X Consortium." ; X11
- "THE USE OR OTHER DEALINGS IN THE SOFTWARE.")))) ; Expat
+ (rx-let ((delim
+ ;; A line break could be in a non-standard place, and the
+ ;; license could be in a comment.
+ (or
+ ;; Either just some spaces:
+ (+ " ")
+ ;; Or a newline and some comment starter:
+ (: (* (in " \t"))
+ "\n"
+ (* (in " \t"))
+ (* (or (syntax comment-start) (in ";#*-")))
+ (* (in " \t"))))))
+ `(;; GNU GPL
+ ("is free software[:;] you can redistribute it" .
+ ,(rx (or (seq "If not, see " (? "<")
+ "http" (? "s") "://www.gnu.org/licenses"
+ (? "/") (? ">") (? " "))
+ (seq "Boston," delim "MA" delim
+ (or "02111-1307" "02110-1301" "02111-1301")
+ (? ",") delim
+ "USA")
+ "675 Mass Ave, Cambridge, MA 02139, USA")
+ (? ".")))
+ ;; FreeBSD license / Modified BSD license (3-clause)
+ (,(rx (or "The Regents of the University of California. All rights reserved."
+ "Redistribution and use in source and binary"))
+ . "POSSIBILITY OF SUCH DAMAGE\\.")
+ ;; X11 and Expat
+ ("Permission is hereby granted, free of charge" .
+ ,(rx (or "authorization from the X Consortium." ; X11
+ "THE USE OR OTHER DEALINGS IN THE SOFTWARE."))) ; Expat
+ ;; Apache
+ ("Licensed under the Apache License, Version 2.0" .
+ "limitations under the License.")
+ ))
"Alist of regexps defining start and end of text to elide.
The cars of elements of the list are searched for in order. Text is
@@ -78,7 +95,7 @@ cdr.
This affects `elide-head-mode'."
:type '(alist :key-type (regexp :tag "Start regexp")
:value-type (regexp :tag "End regexp"))
- :version "29.1")
+ :version "30.1")
(defvar-local elide-head-overlay nil)
diff --git a/lisp/emacs-lisp/advice.el b/lisp/emacs-lisp/advice.el
index d07081d1a8e..752660156b9 100644
--- a/lisp/emacs-lisp/advice.el
+++ b/lisp/emacs-lisp/advice.el
@@ -2042,8 +2042,6 @@ in that CLASS."
function class name)))
(error "ad-remove-advice: `%s' is not advised" function)))
-(declare-function comp-subr-trampoline-install "comp")
-
;;;###autoload
(defun ad-add-advice (function advice class position)
"Add a piece of ADVICE to FUNCTION's list of advices in CLASS.
@@ -2067,9 +2065,6 @@ mapped to the closest extremal position).
If FUNCTION was not advised already, its advice info will be
initialized. Redefining a piece of advice whose name is part of
the cache-id will clear the cache."
- (when (and (featurep 'native-compile)
- (subr-primitive-p (symbol-function function)))
- (comp-subr-trampoline-install function))
(cond ((not (ad-is-advised function))
(ad-initialize-advice-info function)
(ad-set-advice-info-field
@@ -3131,6 +3126,7 @@ usage: (defadvice FUNCTION (CLASS NAME [POSITION] [ARGLIST] FLAG...)
[DOCSTRING] [INTERACTIVE-FORM]
BODY...)"
(declare (doc-string 3) (indent 2)
+ (obsolete "use `advice-add' or `define-advice'" "30.1")
(debug (&define name ;; thing being advised.
(name ;; class is [&or "before" "around" "after"
;; "activation" "deactivation"]
diff --git a/lisp/emacs-lisp/backtrace.el b/lisp/emacs-lisp/backtrace.el
index b9b08aa1b49..e47e2662afa 100644
--- a/lisp/emacs-lisp/backtrace.el
+++ b/lisp/emacs-lisp/backtrace.el
@@ -135,8 +135,7 @@ frames before its nearest activation frame are discarded."
;; Font Locking support
(defconst backtrace--font-lock-keywords
- '((backtrace--match-ellipsis-in-string
- (1 'button prepend)))
+ '()
"Expressions to fontify in Backtrace mode.
Fontify these in addition to the expressions Emacs Lisp mode
fontifies.")
@@ -154,16 +153,6 @@ fontifies.")
backtrace--font-lock-keywords)
"Gaudy level highlighting for Backtrace mode.")
-(defun backtrace--match-ellipsis-in-string (bound)
- ;; Fontify ellipses within strings as buttons.
- ;; This is necessary because ellipses are text property buttons
- ;; instead of overlay buttons, which is done because there could
- ;; be a large number of them.
- (when (re-search-forward "\\(\\.\\.\\.\\)\"" bound t)
- (and (get-text-property (- (point) 2) 'cl-print-ellipsis)
- (get-text-property (- (point) 3) 'cl-print-ellipsis)
- (get-text-property (- (point) 4) 'cl-print-ellipsis))))
-
;;; Xref support
(defun backtrace--xref-backend () 'elisp)
@@ -424,12 +413,12 @@ the buffer."
(overlay-put o 'evaporate t))))
(defun backtrace--change-button-skip (beg end value)
- "Change the skip property on all buttons between BEG and END.
-Set it to VALUE unless the button is a `backtrace-ellipsis' button."
+ "Change the `skip' property on all buttons between BEG and END.
+Set it to VALUE unless the button is a `cl-print-ellipsis' button."
(let ((inhibit-read-only t))
(setq beg (next-button beg))
(while (and beg (< beg end))
- (unless (eq (button-type beg) 'backtrace-ellipsis)
+ (unless (eq (button-type beg) 'cl-print-ellipsis)
(button-put beg 'skip value))
(setq beg (next-button beg)))))
@@ -497,34 +486,15 @@ Reprint the frame with the new view plist."
`(backtrace-index ,index backtrace-view ,view))
(goto-char min)))
-(defun backtrace-expand-ellipsis (button)
- "Expand display of the elided form at BUTTON."
- (interactive)
- (goto-char (button-start button))
- (unless (get-text-property (point) 'cl-print-ellipsis)
- (if (and (> (point) (point-min))
- (get-text-property (1- (point)) 'cl-print-ellipsis))
- (backward-char)
- (user-error "No ellipsis to expand here")))
- (let* ((end (next-single-property-change (point) 'cl-print-ellipsis))
- (begin (previous-single-property-change end 'cl-print-ellipsis))
- (value (get-text-property begin 'cl-print-ellipsis))
- (props (backtrace-get-text-properties begin))
+(defun backtrace--expand-ellipsis (orig-fun begin end val _length &rest args)
+ "Wrapper to expand an ellipsis.
+For use on `cl-print-expand-ellipsis-function'."
+ (let* ((props (backtrace-get-text-properties begin))
(inhibit-read-only t))
(backtrace--with-output-variables (backtrace-get-view)
- (delete-region begin end)
- (insert (cl-print-to-string-with-limit #'cl-print-expand-ellipsis value
- backtrace-line-length))
- (setq end (point))
- (goto-char begin)
- (while (< (point) end)
- (let ((next (next-single-property-change (point) 'cl-print-ellipsis
- nil end)))
- (when (get-text-property (point) 'cl-print-ellipsis)
- (make-text-button (point) next :type 'backtrace-ellipsis))
- (goto-char next)))
- (goto-char begin)
- (add-text-properties begin end props))))
+ (let ((end (apply orig-fun begin end val backtrace-line-length args)))
+ (add-text-properties begin end props)
+ end))))
(defun backtrace-expand-ellipses (&optional no-limit)
"Expand display of all \"...\"s in the backtrace frame at point.
@@ -697,13 +667,6 @@ line and recenter window line accordingly."
(recenter window-line)))
(goto-char (point-min)))))
-;; Define button type used for ...'s.
-;; Set skip property so you don't have to TAB through 100 of them to
-;; get to the next function name.
-(define-button-type 'backtrace-ellipsis
- 'skip t 'action #'backtrace-expand-ellipsis
- 'help-echo "mouse-2, RET: expand this ellipsis")
-
(defun backtrace-print-to-string (obj &optional limit)
"Return a printed representation of OBJ formatted for backtraces.
Attempt to get the length of the returned string under LIMIT
@@ -720,15 +683,6 @@ characters with appropriate settings of `print-level' and
(insert (cl-print-to-string-with-limit #'backtrace--print sexp limit))
;; Add a unique backtrace-form property.
(put-text-property (point-min) (point) 'backtrace-form (gensym))
- ;; Make buttons from all the "..."s. Since there might be many of
- ;; them, use text property buttons.
- (goto-char (point-min))
- (while (< (point) (point-max))
- (let ((end (next-single-property-change (point) 'cl-print-ellipsis
- nil (point-max))))
- (when (get-text-property (point) 'cl-print-ellipsis)
- (make-text-button (point) end :type 'backtrace-ellipsis))
- (goto-char end)))
(buffer-string)))
(defun backtrace-print-frame (frame view)
@@ -919,6 +873,8 @@ followed by `backtrace-print-frame', once for each stack frame."
(setq-local filter-buffer-substring-function #'backtrace--filter-visible)
(setq-local indent-line-function 'lisp-indent-line)
(setq-local indent-region-function 'lisp-indent-region)
+ (add-function :around (local 'cl-print-expand-ellipsis-function)
+ #'backtrace--expand-ellipsis)
(add-hook 'xref-backend-functions #'backtrace--xref-backend nil t))
(put 'backtrace-mode 'mode-class 'special)
diff --git a/lisp/emacs-lisp/bindat.el b/lisp/emacs-lisp/bindat.el
index 73745e8c7ac..42ba89ba2c1 100644
--- a/lisp/emacs-lisp/bindat.el
+++ b/lisp/emacs-lisp/bindat.el
@@ -204,6 +204,9 @@
('str (bindat--unpack-str len))
('strz (bindat--unpack-strz len))
('vec
+ (when (> len (length bindat-raw))
+ (error "Vector length %d is greater than raw data length %d"
+ len (length bindat-raw)))
(let ((v (make-vector len 0)) (vlen 1))
(if (consp vectype)
(setq vlen (nth 1 vectype)
@@ -941,9 +944,13 @@ a bindat type expression."
(bindat-defmacro sint (bitlen le)
"Signed integer of size BITLEN.
Big-endian if LE is nil and little-endian if not."
+ (unless lexical-binding
+ (error "The `sint' type requires 'lexical-binding'"))
(let ((bl (make-symbol "bitlen"))
(max (make-symbol "max"))
(wrap (make-symbol "wrap")))
+ ;; FIXME: This `let*' around the `struct' results in code which the
+ ;; byte-compiler does not handle efficiently. 🙁
`(let* ((,bl ,bitlen)
(,max (ash 1 (1- ,bl)))
(,wrap (+ ,max ,max)))
diff --git a/lisp/emacs-lisp/byte-opt.el b/lisp/emacs-lisp/byte-opt.el
index b60bcda90b4..ea163723a3e 100644
--- a/lisp/emacs-lisp/byte-opt.el
+++ b/lisp/emacs-lisp/byte-opt.el
@@ -72,34 +72,40 @@
(require 'macroexp)
(eval-when-compile (require 'subr-x))
+(defun bytecomp--log-lap-arg (arg)
+ ;; Convert an argument that may be a LAP operation to something printable.
+ (cond
+ ;; Symbols are just stripped of their -byte prefix if any.
+ ((symbolp arg)
+ (intern (string-remove-prefix "byte-" (symbol-name arg))))
+ ;; Conses are assumed to be LAP ops or tags.
+ ((and (consp arg) (symbolp (car arg)))
+ (let* ((head (car arg))
+ (tail (cdr arg))
+ (op (intern (string-remove-prefix "byte-" (symbol-name head)))))
+ (cond
+ ((eq head 'TAG)
+ (format "%d:" (car tail)))
+ ((memq head byte-goto-ops)
+ (format "(%s %d)" op (cadr tail)))
+ ((memq head byte-constref-ops)
+ (format "(%s %s)"
+ (if (eq op 'constant) 'const op)
+ (if (numberp tail)
+ (format "<V%d>" tail) ; closure var reference
+ (format "%S" (car tail))))) ; actual constant
+ ;; Ops with an immediate argument.
+ ((memq op '( stack-ref stack-set call unbind
+ listN concatN insertN discardN discardN-preserve-tos))
+ (format "(%s %S)" op tail))
+ ;; Without immediate, print just the symbol.
+ (t op))))
+ ;; Anything else is printed as-is.
+ (t arg)))
+
(defun byte-compile-log-lap-1 (format &rest args)
(byte-compile-log-1
- (apply #'format-message format
- (let (c a)
- (mapcar (lambda (arg)
- (if (not (consp arg))
- (if (and (symbolp arg)
- (string-match "^byte-" (symbol-name arg)))
- (intern (substring (symbol-name arg) 5))
- arg)
- (if (integerp (setq c (car arg)))
- (error "Non-symbolic byte-op %s" c))
- (if (eq c 'TAG)
- (setq c arg)
- (setq a (cond ((memq c byte-goto-ops)
- (car (cdr (cdr arg))))
- ((memq c byte-constref-ops)
- (car (cdr arg)))
- (t (cdr arg))))
- (setq c (symbol-name c))
- (if (string-match "^byte-." c)
- (setq c (intern (substring c 5)))))
- (if (eq c 'constant) (setq c 'const))
- (if (and (eq (cdr arg) 0)
- (not (memq c '(unbind call const))))
- c
- (format "(%s %s)" c a))))
- args)))))
+ (apply #'format-message format (mapcar #'bytecomp--log-lap-arg args))))
(defmacro byte-compile-log-lap (format-string &rest args)
`(and (memq byte-optimize-log '(t byte))
@@ -161,8 +167,8 @@ Earlier variables shadow later ones with the same name.")
((or `(lambda . ,_) `(closure . ,_))
;; While byte-compile-unfold-bcf can inline dynbind byte-code into
;; letbind byte-code (or any other combination for that matter), we
- ;; can only inline dynbind source into dynbind source or letbind
- ;; source into letbind source.
+ ;; can only inline dynbind source into dynbind source or lexbind
+ ;; source into lexbind source.
;; When the function comes from another file, we byte-compile
;; the inlined function first, and then inline its byte-code.
;; This also has the advantage that the final code does not
@@ -170,7 +176,10 @@ Earlier variables shadow later ones with the same name.")
;; the build more reproducible.
(if (eq fn localfn)
;; From the same file => same mode.
- (macroexp--unfold-lambda `(,fn ,@(cdr form)))
+ (let* ((newform `(,fn ,@(cdr form)))
+ (unfolded (macroexp--unfold-lambda newform)))
+ ;; Use the newform only if it could be optimized.
+ (if (eq unfolded newform) form unfolded))
;; Since we are called from inside the optimizer, we need to make
;; sure not to propagate lexvar values.
(let ((byte-optimize--lexvars nil)
@@ -208,28 +217,24 @@ This indicates the loop discovery phase.")
(defvar byte-optimize--aliased-vars nil
"List of variables which may be aliased by other lexical variables.
-If an entry in `byte-optimize--lexvars' has another variable as its VALUE,
-then that other variable must be in this list.
-This variable thus carries no essential information but is maintained
-for speeding up processing.")
+Each element is (NAME . ALIAS) where NAME is the aliased variable
+and ALIAS the variable record (in the format described for
+`byte-optimize--lexvars') for an alias, which may have NAME as its VALUE.
+There can be multiple entries for the same NAME if it has several aliases.")
(defun byte-optimize--substitutable-p (expr)
"Whether EXPR is a constant that can be propagated."
- ;; Only consider numbers, symbols and strings to be values for substitution
- ;; purposes. Numbers and symbols are immutable, and mutating string
- ;; literals (or results from constant-evaluated string-returning functions)
- ;; can be considered undefined.
- ;; (What about other quoted values, like conses?)
(or (booleanp expr)
(numberp expr)
- (stringp expr)
- (and (consp expr)
- (or (and (memq (car expr) '(quote function))
- (symbolp (cadr expr)))
- ;; (internal-get-closed-var N) can be considered constant for
- ;; const-prop purposes.
- (and (eq (car expr) 'internal-get-closed-var)
- (integerp (cadr expr)))))
+ (arrayp expr)
+ (let ((head (car-safe expr)))
+ (cond ((eq head 'quote) t)
+ ;; Don't substitute #'(lambda ...) since that would enable
+ ;; uncontrolled inlining.
+ ((eq head 'function) (symbolp (cadr expr)))
+ ;; (internal-get-closed-var N) can be considered constant for
+ ;; const-prop purposes.
+ ((eq head 'internal-get-closed-var) (integerp (cadr expr)))))
(keywordp expr)))
(defmacro byte-optimize--pcase (exp &rest cases)
@@ -266,6 +271,14 @@ for speeding up processing.")
. ,(cdr case)))
cases)))
+(defsubst byte-opt--fget (f prop)
+ "Simpler and faster version of `function-get'."
+ (let ((val nil))
+ (while (and (symbolp f) f
+ (null (setq val (get f prop))))
+ (setq f (symbol-function f)))
+ val))
+
(defun byte-optimize-form-code-walker (form for-effect)
;;
;; For normal function calls, We can just mapcar the optimizer the cdr. But
@@ -410,7 +423,10 @@ for speeding up processing.")
(`(condition-case ,var ,exp . ,clauses)
`(,fn ,var ;Not evaluated.
- ,(byte-optimize-form exp for-effect)
+ ,(byte-optimize-form exp
+ (if (assq :success clauses)
+ (null var)
+ for-effect))
,@(mapcar (lambda (clause)
(let ((byte-optimize--lexvars
(and lexical-binding
@@ -422,40 +438,22 @@ for speeding up processing.")
(byte-optimize-body (cdr clause) for-effect))))
clauses)))
- ;; `unwind-protect' is a special form which here takes the shape
- ;; (unwind-protect EXPR :fun-body UNWIND-FUN).
- ;; We can treat it as if it were a plain function at this point,
- ;; although there are specific optimizations possible.
- ;; In particular, the return value of UNWIND-FUN is never used
- ;; so its body should really be compiled for-effect, but we
- ;; don't do that right now.
+ (`(unwind-protect ,protected-expr :fun-body ,unwind-fun)
+ ;; FIXME: The return value of UNWIND-FUN is never used so we
+ ;; could potentially optimize it for-effect, but we don't do
+ ;; that right no.
+ `(,fn ,(byte-optimize-form protected-expr for-effect)
+ :fun-body ,(byte-optimize-form unwind-fun)))
(`(catch ,tag . ,exps)
`(,fn ,(byte-optimize-form tag nil)
. ,(byte-optimize-body exps for-effect)))
;; Needed as long as we run byte-optimize-form after cconv.
- (`(internal-make-closure . ,_)
- (and (not for-effect)
- (progn
- ;; Look up free vars and mark them to be kept, so that they
- ;; won't be optimized away.
- (dolist (var (caddr form))
- (let ((lexvar (assq var byte-optimize--lexvars)))
- (when lexvar
- (setcar (cdr lexvar) t))))
- form)))
-
- (`((lambda . ,_) . ,_)
- (let ((newform (macroexp--unfold-lambda form)))
- (if (eq newform form)
- ;; Some error occurred, avoid infinite recursion.
- form
- (byte-optimize-form newform for-effect))))
-
- ;; FIXME: Strictly speaking, I think this is a bug: (closure...)
- ;; is a *value* and shouldn't appear in the car.
- (`((closure . ,_) . ,_) form)
+ (`(internal-make-closure ,vars ,env . ,rest)
+ (if for-effect
+ `(progn ,@(byte-optimize-body env t))
+ `(,fn ,vars ,(mapcar #'byte-optimize-form env) . ,rest)))
(`(setq ,var ,expr)
(let ((lexvar (assq var byte-optimize--lexvars))
@@ -464,13 +462,17 @@ for speeding up processing.")
(setcar (cdr lexvar) t) ; Mark variable to be kept.
(setcdr (cdr lexvar) nil) ; Inhibit further substitution.
- (when (memq var byte-optimize--aliased-vars)
- ;; Cancel aliasing of variables aliased to this one.
- (dolist (v byte-optimize--lexvars)
- (when (eq (nth 2 v) var)
- ;; V is bound to VAR but VAR is now mutated:
- ;; cancel aliasing.
- (setcdr (cdr v) nil)))))
+ ;; Cancel substitution of variables aliasing this one.
+ (let ((aliased-vars byte-optimize--aliased-vars))
+ (while
+ (let ((alias (assq var aliased-vars)))
+ (and alias
+ (progn
+ ;; Found a variable bound to VAR but VAR is
+ ;; now mutated; cancel aliasing.
+ (setcdr (cddr alias) nil)
+ (setq aliased-vars (cdr (memq alias aliased-vars)))
+ t))))))
`(,fn ,var ,value)))
(`(defvar ,(and (pred symbolp) name) . ,rest)
@@ -480,34 +482,19 @@ for speeding up processing.")
(push name byte-optimize--dynamic-vars)
`(,fn ,name . ,optimized-rest)))
- (`(,(pred byte-code-function-p) . ,exps)
- (cons fn (mapcar #'byte-optimize-form exps)))
-
- (`(,(pred (not symbolp)) . ,_)
- (byte-compile-warn-x fn "`%s' is a malformed function" fn)
- form)
-
((guard (when for-effect
- (if-let ((tmp (get fn 'side-effect-free)))
+ (if-let ((tmp (byte-opt--fget fn 'side-effect-free)))
(or byte-compile-delete-errors
- (eq tmp 'error-free)
- (progn
- (byte-compile-warn-x
- form
- "value returned from %s is unused"
- form)
- nil)))))
+ (eq tmp 'error-free)))))
(byte-compile-log " %s called for effect; deleted" fn)
- ;; appending a nil here might not be necessary, but it can't hurt.
- (byte-optimize-form
- (cons 'progn (append (cdr form) '(nil))) t))
+ (byte-optimize-form (cons 'progn (cdr form)) t))
(_
;; Otherwise, no args can be considered to be for-effect,
;; even if the called function is for-effect, because we
;; don't know anything about that function.
(let ((form (cons fn (mapcar #'byte-optimize-form (cdr form)))))
- (if (get fn 'pure)
+ (if (byte-opt--fget fn 'pure)
(byte-optimize-constant-args form)
form))))))
@@ -529,7 +516,7 @@ for speeding up processing.")
;; until a fixpoint has been reached.
(and (consp form)
(symbolp (car form))
- (let ((opt (function-get (car form) 'byte-optimizer)))
+ (let ((opt (byte-opt--fget (car form) 'byte-optimizer)))
(and opt
(let ((old form)
(new (funcall opt form)))
@@ -597,7 +584,6 @@ for speeding up processing.")
(let* ((byte-optimize--lexvars byte-optimize--lexvars)
(byte-optimize--aliased-vars byte-optimize--aliased-vars)
(new-lexvars nil)
- (new-aliased-vars nil)
(let-vars nil)
(body (cdr form))
(bindings (car form)))
@@ -607,7 +593,7 @@ for speeding up processing.")
(expr (byte-optimize-form (cadr binding) nil)))
(setq bindings (cdr bindings))
(when (and (eq head 'let*)
- (memq name byte-optimize--aliased-vars))
+ (assq name byte-optimize--aliased-vars))
;; New variable shadows an aliased variable -- α-rename
;; it in this and all subsequent bindings.
(let ((new-name (make-symbol (symbol-name name))))
@@ -620,14 +606,12 @@ for speeding up processing.")
bindings))
(setq body (byte-optimize--rename-var-body name new-name body))
(setq name new-name)))
- (let* ((aliased nil)
- (value (and
- (or (byte-optimize--substitutable-p expr)
- ;; Aliasing another lexvar.
- (setq aliased
- (and (symbolp expr)
- (assq expr byte-optimize--lexvars))))
- (list expr)))
+ (let* ((aliased
+ ;; Aliasing another lexvar.
+ (and (symbolp expr) (assq expr byte-optimize--lexvars)))
+ (value (and (or aliased
+ (byte-optimize--substitutable-p expr))
+ (list expr)))
(lexical (not (or (special-variable-p name)
(memq name byte-compile-bound-variables)
(memq name byte-optimize--dynamic-vars))))
@@ -636,20 +620,16 @@ for speeding up processing.")
(when lexinfo
(push lexinfo (if (eq head 'let*)
byte-optimize--lexvars
- new-lexvars)))
- (when aliased
- (push expr (if (eq head 'let*)
- byte-optimize--aliased-vars
- new-aliased-vars))))))
-
- (setq byte-optimize--aliased-vars
- (append new-aliased-vars byte-optimize--aliased-vars))
+ new-lexvars))
+ (when aliased
+ (push (cons expr lexinfo) byte-optimize--aliased-vars))))))
+
(when (and (eq head 'let) byte-optimize--aliased-vars)
;; Find new variables that shadow aliased variables.
(let ((shadowing-vars nil))
(dolist (lexvar new-lexvars)
(let ((name (car lexvar)))
- (when (and (memq name byte-optimize--aliased-vars)
+ (when (and (assq name byte-optimize--aliased-vars)
(not (memq name shadowing-vars)))
(push name shadowing-vars))))
;; α-rename them
@@ -755,7 +735,8 @@ for speeding up processing.")
((eq head 'list) (cdr form))
((memq head
;; FIXME: Replace this list with a function property?
- '( length safe-length cons lambda
+ '( lambda internal-make-closure
+ length safe-length cons
string unibyte-string make-string concat
format format-message
substring substring-no-properties string-replace
@@ -795,6 +776,17 @@ for speeding up processing.")
make-marker copy-marker point-marker mark-marker
set-marker
kbd key-description
+ skip-chars-forward skip-chars-backward
+ skip-syntax-forward skip-syntax-backward
+ current-column current-indentation
+ char-syntax syntax-class-to-char
+ parse-partial-sexp goto-char forward-line
+ next-window previous-window minibuffer-window
+ selected-frame selected-window
+ standard-case-table standard-syntax-table
+ syntax-table
+ frame-first-window frame-root-window
+ frame-selected-window
always))
t)
((eq head 'if)
@@ -815,8 +807,29 @@ for speeding up processing.")
(or (not form) ; assume (quote nil) always being normalized to nil
(and (consp form)
(let ((head (car form)))
- ;; FIXME: There are many other expressions that are statically nil.
- (cond ((memq head '(while ignore)) t)
+ (cond ((memq head
+ ;; Some forms that are statically nil.
+ ;; FIXME: Replace with a function property?
+ '( while ignore
+ insert insert-and-inherit insert-before-markers
+ insert-before-markers-and-inherit
+ insert-char insert-byte insert-buffer-substring
+ delete-region delete-char
+ widen narrow-to-region transpose-regions
+ forward-char backward-char
+ beginning-of-line end-of-line
+ erase-buffer buffer-swap-text
+ delete-overlay delete-all-overlays
+ remhash
+ maphash
+ map-charset-chars map-char-table
+ mapbacktrace
+ mapatoms
+ ding beep sleep-for
+ json-insert
+ set-match-data
+ ))
+ t)
((eq head 'if)
(and (byte-compile-nilconstp (nth 2 form))
(byte-compile-nilconstp (car (last (cdddr form))))))
@@ -878,7 +891,13 @@ for speeding up processing.")
(cons accum args))
(defun byte-optimize-plus (form)
- (let ((args (remq 0 (byte-opt--arith-reduce #'+ 0 (cdr form)))))
+ (let* ((not-0 (remq 0 (byte-opt--arith-reduce #'+ 0 (cdr form))))
+ (args (if (and (= (length not-0) 1)
+ (> (length form) 2))
+ ;; We removed numbers and only one arg remains: add a 0
+ ;; so that it isn't turned into (* X 1) later on.
+ (append not-0 '(0))
+ not-0)))
(cond
;; (+) -> 0
((null args) 0)
@@ -971,17 +990,52 @@ for speeding up processing.")
(t ;; Moving the constant to the end can enable some lapcode optimizations.
(list (car form) (nth 2 form) (nth 1 form)))))
+(defun byte-opt--nary-comparison (form)
+ "Optimize n-ary comparisons such as `=', `<' etc."
+ (let ((nargs (length (cdr form))))
+ (cond
+ ((= nargs 1)
+ `(progn ,(cadr form) t))
+ ((>= nargs 3)
+ ;; At least 3 arguments: transform to N-1 binary comparisons,
+ ;; since those have their own byte-ops which are particularly
+ ;; fast for fixnums.
+ (let* ((op (car form))
+ (bindings nil)
+ (rev-args nil))
+ (if (memq nil (mapcar #'macroexp-copyable-p (cddr form)))
+ ;; At least one arg beyond the first is non-constant non-variable:
+ ;; create temporaries for all args to guard against side-effects.
+ ;; The optimizer will eliminate trivial bindings later.
+ (let ((i 1))
+ (dolist (arg (cdr form))
+ (let ((var (make-symbol (format "arg%d" i))))
+ (push var rev-args)
+ (push (list var arg) bindings)
+ (setq i (1+ i)))))
+ ;; All args beyond the first are copyable: no temporary variables
+ ;; required.
+ (setq rev-args (reverse (cdr form))))
+ (let ((prev (car rev-args))
+ (exprs nil))
+ (dolist (arg (cdr rev-args))
+ (push (list op arg prev) exprs)
+ (setq prev arg))
+ (let ((and-expr (cons 'and exprs)))
+ (if bindings
+ (list 'let (nreverse bindings) and-expr)
+ and-expr)))))
+ (t form))))
+
(defun byte-optimize-constant-args (form)
- (let ((ok t)
- (rest (cdr form)))
- (while (and rest ok)
- (setq ok (macroexp-const-p (car rest))
- rest (cdr rest)))
- (if ok
- (condition-case ()
- (list 'quote (eval form))
- (error form))
- form)))
+ (let ((rest (cdr form)))
+ (while (and rest (macroexp-const-p (car rest)))
+ (setq rest (cdr rest)))
+ (if rest
+ form
+ (condition-case ()
+ (list 'quote (eval form t))
+ (error form)))))
(defun byte-optimize-identity (form)
(if (and (cdr form) (null (cdr (cdr form))))
@@ -989,8 +1043,19 @@ for speeding up processing.")
form))
(defun byte-optimize--constant-symbol-p (expr)
- "Whether EXPR is a constant symbol."
- (and (macroexp-const-p expr) (symbolp (eval expr))))
+ "Whether EXPR is a constant symbol, like (quote hello), nil, t, or :keyword."
+ (if (consp expr)
+ (and (memq (car expr) '(quote function))
+ (symbolp (cadr expr)))
+ (or (memq expr '(nil t))
+ (keywordp expr))))
+
+(defsubst byteopt--eval-const (expr)
+ "Evaluate EXPR which must be a constant (quoted or self-evaluating).
+Ie, (macroexp-const-p EXPR) must be true."
+ (if (consp expr)
+ (cadr expr) ; assumed to be 'VALUE or #'SYMBOL
+ expr))
(defun byte-optimize--fixnump (o)
"Return whether O is guaranteed to be a fixnum in all Emacsen.
@@ -998,23 +1063,26 @@ See Info node `(elisp) Integer Basics'."
(and (integerp o) (<= -536870912 o 536870911)))
(defun byte-optimize-equal (form)
- ;; Replace `equal' or `eql' with `eq' if at least one arg is a
- ;; symbol or fixnum.
- (byte-optimize-binary-predicate
- (if (= (length (cdr form)) 2)
- (if (or (byte-optimize--constant-symbol-p (nth 1 form))
- (byte-optimize--constant-symbol-p (nth 2 form))
- (byte-optimize--fixnump (nth 1 form))
- (byte-optimize--fixnump (nth 2 form)))
- (cons 'eq (cdr form))
- form)
- ;; Arity errors reported elsewhere.
- form)))
+ (cond ((/= (length (cdr form)) 2) form) ; Arity errors reported elsewhere.
+ ;; Anything is identical to itself.
+ ((and (eq (nth 1 form) (nth 2 form)) (symbolp (nth 1 form))) t)
+ ;; Replace `equal' or `eql' with `eq' if at least one arg is a
+ ;; symbol or fixnum.
+ ((or (byte-optimize--constant-symbol-p (nth 1 form))
+ (byte-optimize--constant-symbol-p (nth 2 form))
+ (byte-optimize--fixnump (nth 1 form))
+ (byte-optimize--fixnump (nth 2 form)))
+ (byte-optimize-binary-predicate (cons 'eq (cdr form))))
+ (t (byte-optimize-binary-predicate form))))
(defun byte-optimize-eq (form)
- (pcase (cdr form)
- ((or `(,x nil) `(nil ,x)) `(not ,x))
- (_ (byte-optimize-binary-predicate form))))
+ (cond ((/= (length (cdr form)) 2) form) ; arity error
+ ;; Anything is identical to itself.
+ ((and (eq (nth 1 form) (nth 2 form)) (symbolp (nth 1 form))) t)
+ ;; Strength-reduce comparison with `nil'.
+ ((null (nth 1 form)) `(not ,(nth 2 form)))
+ ((null (nth 2 form)) `(not ,(nth 1 form)))
+ (t (byte-optimize-binary-predicate form))))
(defun byte-optimize-member (form)
(cond
@@ -1027,7 +1095,7 @@ See Info node `(elisp) Integer Basics'."
(byte-optimize--fixnump (nth 1 form))
(let ((arg2 (nth 2 form)))
(and (macroexp-const-p arg2)
- (let ((listval (eval arg2)))
+ (let ((listval (byteopt--eval-const arg2)))
(and (listp listval)
(not (memq nil (mapcar
(lambda (o)
@@ -1076,21 +1144,31 @@ See Info node `(elisp) Integer Basics'."
form))
(defun byte-optimize-concat (form)
- "Merge adjacent constant arguments to `concat'."
+ "Merge adjacent constant arguments to `concat' and flatten nested forms."
(let ((args (cdr form))
(newargs nil))
(while args
- (let ((strings nil)
- val)
- (while (and args (macroexp-const-p (car args))
- (progn
- (setq val (eval (car args)))
- (and (or (stringp val)
- (and (or (listp val) (vectorp val))
- (not (memq nil
- (mapcar #'characterp val))))))))
- (push val strings)
- (setq args (cdr args)))
+ (let ((strings nil))
+ (while
+ (and args
+ (let ((arg (car args)))
+ (pcase arg
+ ;; Merge consecutive constant arguments.
+ ((pred macroexp-const-p)
+ (let ((val (byteopt--eval-const arg)))
+ (and (or (stringp val)
+ (and (or (listp val) (vectorp val))
+ (not (memq nil
+ (mapcar #'characterp val)))))
+ (progn
+ (push val strings)
+ (setq args (cdr args))
+ t))))
+ ;; Flatten nested `concat' form.
+ (`(concat . ,nested-args)
+ (setq args (append nested-args (cdr args)))
+ t)))))
+
(when strings
(let ((s (apply #'concat (nreverse strings))))
(when (not (zerop (length s)))
@@ -1126,13 +1204,18 @@ See Info node `(elisp) Integer Basics'."
(put 'max 'byte-optimizer #'byte-optimize-min-max)
(put 'min 'byte-optimizer #'byte-optimize-min-max)
-(put '= 'byte-optimizer #'byte-optimize-binary-predicate)
(put 'eq 'byte-optimizer #'byte-optimize-eq)
(put 'eql 'byte-optimizer #'byte-optimize-equal)
(put 'equal 'byte-optimizer #'byte-optimize-equal)
(put 'string= 'byte-optimizer #'byte-optimize-binary-predicate)
(put 'string-equal 'byte-optimizer #'byte-optimize-binary-predicate)
+(put '= 'byte-optimizer #'byte-opt--nary-comparison)
+(put '< 'byte-optimizer #'byte-opt--nary-comparison)
+(put '<= 'byte-optimizer #'byte-opt--nary-comparison)
+(put '> 'byte-optimizer #'byte-opt--nary-comparison)
+(put '>= 'byte-optimizer #'byte-opt--nary-comparison)
+
(put 'string-greaterp 'byte-optimizer #'byte-optimize-string-greaterp)
(put 'string> 'byte-optimizer #'byte-optimize-string-greaterp)
@@ -1297,11 +1380,8 @@ See Info node `(elisp) Integer Basics'."
(if else
`(progn ,condition ,@else)
condition))
- ;; (if X nil t) -> (not X)
- ((and (eq then nil) (eq else '(t)))
- `(not ,condition))
- ;; (if X t [nil]) -> (not (not X))
- ((and (eq then t) (or (null else) (eq else '(nil))))
+ ;; (if X t) -> (not (not X))
+ ((and (eq then t) (null else))
`(not ,(byte-opt--negate condition)))
;; (if VAR VAR X...) -> (or VAR (progn X...))
((and (symbolp condition) (eq condition then))
@@ -1353,16 +1433,20 @@ See Info node `(elisp) Integer Basics'."
(defun byte-optimize-funcall (form)
- ;; (funcall (lambda ...) ...) ==> ((lambda ...) ...)
- ;; (funcall foo ...) ==> (foo ...)
- (let ((fn (nth 1 form)))
- (if (memq (car-safe fn) '(quote function))
- (cons (nth 1 fn) (cdr (cdr form)))
- form)))
+ ;; (funcall #'(lambda ...) ...) -> (let ...)
+ ;; (funcall #'SYM ...) -> (SYM ...)
+ ;; (funcall 'SYM ...) -> (SYM ...)
+ (pcase form
+ (`(,_ #'(lambda . ,_) . ,_)
+ (macroexp--unfold-lambda form))
+ (`(,_ ,(or `#',f `',(and f (pred symbolp))) . ,actuals)
+ `(,f ,@actuals))
+ (_ form)))
(defun byte-optimize-apply (form)
(let ((len (length form)))
- (if (>= len 2)
+ ;; Single-arg `apply' is an abomination that we don't bother optimizing.
+ (if (> len 2)
(let ((fn (nth 1 form))
(last (nth (1- len) form)))
(cond
@@ -1379,6 +1463,9 @@ See Info node `(elisp) Integer Basics'."
;; (apply F ... (list X Y ...)) -> (funcall F ... X Y ...)
((eq (car-safe last) 'list)
`(funcall ,fn ,@(butlast (cddr form)) ,@(cdr last)))
+ ;; (apply F ... (cons X Y)) -> (apply F ... X Y)
+ ((eq (car-safe last) 'cons)
+ (append (butlast form) (cdr last)))
(t form)))
form)))
@@ -1390,7 +1477,7 @@ See Info node `(elisp) Integer Basics'."
(put 'let* 'byte-optimizer #'byte-optimize-letX)
(defun byte-optimize-letX (form)
(pcase form
- ;; No bindings.
+ ;; Bindings list is empty.
(`(,_ () . ,body)
`(progn . ,body))
@@ -1400,7 +1487,7 @@ See Info node `(elisp) Integer Basics'."
`(progn ,@(mapcar #'cadr bindings) ,const)
`(,head ,(butlast bindings) ,(cadar (last bindings)) ,const)))
- ;; Body is last variable.
+ ;; Body does nothing but return the last variable in bindings.
(`(,head ,(and bindings
(let last-var (caar (last bindings))))
,(and last-var ; non-linear pattern
@@ -1450,6 +1537,44 @@ See Info node `(elisp) Integer Basics'."
;; (list) -> nil
(and (cdr form) form))
+(put 'nconc 'byte-optimizer #'byte-optimize-nconc)
+(defun byte-optimize-nconc (form)
+ (pcase (cdr form)
+ ('nil nil) ; (nconc) -> nil
+ (`(,x) x) ; (nconc X) -> X
+ (_ (named-let loop ((args (cdr form)) (newargs nil))
+ (if args
+ (let ((arg (car args))
+ (prev (car newargs)))
+ (cond
+ ;; Elide null args.
+ ((and (null arg)
+ ;; Don't elide a terminal nil unless preceded by
+ ;; a nonempty proper list, since that will have
+ ;; its last cdr forced to nil.
+ (or (cdr args)
+ ;; FIXME: prove the 'nonempty proper list' property
+ ;; for more forms than just `list', such as
+ ;; `append', `mapcar' etc.
+ (eq 'list (car-safe (car newargs)))))
+ (loop (cdr args) newargs))
+ ;; Merge consecutive `list' args.
+ ((and (eq (car-safe arg) 'list)
+ (eq (car-safe prev) 'list))
+ (loop (cons (cons (car prev) (append (cdr prev) (cdr arg)))
+ (cdr args))
+ (cdr newargs)))
+ ;; (nconc ... (list A) B ...) -> (nconc ... (cons A B) ...)
+ ((and (eq (car-safe prev) 'list) (cdr prev) (null (cddr prev)))
+ (loop (cdr args)
+ (cons (list 'cons (cadr prev) arg)
+ (cdr newargs))))
+ (t (loop (cdr args) (cons arg newargs)))))
+ (let ((new-form (cons (car form) (nreverse newargs))))
+ (if (equal new-form form)
+ form
+ new-form)))))))
+
(put 'append 'byte-optimizer #'byte-optimize-append)
(defun byte-optimize-append (form)
;; There is (probably) too much code relying on `append' to return a
@@ -1476,7 +1601,7 @@ See Info node `(elisp) Integer Basics'."
(cond
((macroexp-const-p arg)
;; constant arg
- (let ((val (eval arg)))
+ (let ((val (byteopt--eval-const arg)))
(cond
;; Elide empty arguments (nil, empty string, etc).
((zerop (length val))
@@ -1486,7 +1611,7 @@ See Info node `(elisp) Integer Basics'."
(loop (cdr args)
(cons
(list 'quote
- (append (eval prev) val nil))
+ (append (byteopt--eval-const prev) val nil))
(cdr newargs))))
(t (loop (cdr args) (cons arg newargs))))))
@@ -1502,11 +1627,9 @@ See Info node `(elisp) Integer Basics'."
;; (append X) -> X
((null newargs) arg)
- ;; (append (list Xs...) nil) -> (list Xs...)
- ((and (null arg)
- newargs (null (cdr newargs))
- (consp prev) (eq (car prev) 'list))
- prev)
+ ;; (append ... (list Xs...) nil) -> (append ... (list Xs...))
+ ((and (null arg) (eq (car-safe prev) 'list))
+ (cons (car form) (nreverse newargs)))
;; (append '(X) Y) -> (cons 'X Y)
;; (append (list X) Y) -> (cons X Y)
@@ -1517,13 +1640,13 @@ See Info node `(elisp) Integer Basics'."
(= (length (cadr prev)) 1)))
((eq (car prev) 'list)
(= (length (cdr prev)) 1))))
- (list 'cons (if (eq (car prev) 'quote)
- (macroexp-quote (caadr prev))
- (cadr prev))
- arg))
+ `(cons ,(if (eq (car prev) 'quote)
+ (macroexp-quote (caadr prev))
+ (cadr prev))
+ ,arg))
(t
- (let ((new-form (cons 'append (nreverse (cons arg newargs)))))
+ (let ((new-form (cons (car form) (nreverse (cons arg newargs)))))
(if (equal new-form form)
form
new-form))))))))
@@ -1566,106 +1689,242 @@ See Info node `(elisp) Integer Basics'."
;; I wonder if I missed any :-\)
(let ((side-effect-free-fns
- '(% * + - / /= 1+ 1- < <= = > >= abs acos append aref ash asin atan
- assq
- base64-decode-string base64-encode-string base64url-encode-string
+ '(
+ ;; alloc.c
+ make-bool-vector make-byte-code make-list make-record make-string
+ make-symbol make-vector
+ ;; buffer.c
+ buffer-base-buffer buffer-chars-modified-tick buffer-file-name
+ buffer-local-value buffer-local-variables buffer-modified-p
+ buffer-modified-tick buffer-name get-buffer next-overlay-change
+ overlay-buffer overlay-end overlay-get overlay-properties
+ overlay-start overlays-at overlays-in previous-overlay-change
+ ;; callint.c
+ prefix-numeric-value
+ ;; casefiddle.c
+ capitalize downcase upcase upcase-initials
+ ;; category.c
+ category-docstring category-set-mnemonics char-category-set
+ copy-category-table get-unused-category make-category-set
+ ;; character.c
+ char-width get-byte multibyte-char-to-unibyte string string-width
+ unibyte-char-to-multibyte unibyte-string
+ ;; charset.c
+ decode-char encode-char
+ ;; chartab.c
+ make-char-table
+ ;; data.c
+ % * + - / /= 1+ 1- < <= = > >=
+ aref ash bare-symbol
bool-vector-count-consecutive bool-vector-count-population
bool-vector-subsetp
- boundp buffer-file-name buffer-local-variables buffer-modified-p
- buffer-substring byte-code-function-p
- capitalize car-less-than-car car cdr ceiling char-after char-before
- char-equal char-to-string char-width compare-strings
- window-configuration-equal-p concat coordinates-in-window-p
- copy-alist copy-sequence copy-marker copysign cos count-lines
- current-time-string current-time-zone
- decode-char
- decode-time default-boundp default-value documentation downcase
- elt encode-char exp expt encode-time error-message-string
- fboundp fceiling featurep ffloor
- file-directory-p file-exists-p file-locked-p file-name-absolute-p
- file-name-concat
- file-newer-than-file-p file-readable-p file-symlink-p file-writable-p
- float float-time floor format format-time-string frame-first-window
- frame-root-window frame-selected-window
- frame-visible-p fround ftruncate
- get gethash get-buffer get-buffer-window getenv get-file-buffer
- hash-table-count
- int-to-string intern-soft isnan
- keymap-parent
- lax-plist-get ldexp
- length length< length> length=
- line-beginning-position line-end-position pos-bol pos-eol
- local-variable-if-set-p local-variable-p locale-info
- log log10 logand logb logcount logior lognot logxor lsh
- make-byte-code make-list make-string make-symbol mark marker-buffer max
- match-beginning match-end
- member memq memql min minibuffer-selected-window minibuffer-window
- mod multibyte-char-to-unibyte next-window nth nthcdr number-to-string
- parse-colon-path
- prefix-numeric-value previous-window prin1-to-string propertize
- degrees-to-radians
- radians-to-degrees rassq rassoc read-from-string regexp-opt
- regexp-quote region-beginning region-end reverse round
- sin sqrt string string< string= string-equal string-lessp
- string> string-greaterp string-empty-p string-blank-p
- string-search string-to-char
- string-to-number string-to-syntax substring
- sxhash sxhash-equal sxhash-eq sxhash-eql
- symbol-function symbol-name symbol-plist symbol-value string-make-unibyte
- string-make-multibyte string-as-multibyte string-as-unibyte
- string-to-multibyte
- take tan time-convert truncate
- unibyte-char-to-multibyte upcase user-full-name
- user-login-name user-original-login-name custom-variable-p
- vconcat
- window-absolute-pixel-edges window-at window-body-height
- window-body-width window-buffer window-dedicated-p window-display-table
- window-combination-limit window-edges window-frame window-fringes
- window-height window-hscroll window-inside-edges
- window-inside-absolute-pixel-edges window-inside-pixel-edges
- window-left-child window-left-column window-margins window-minibuffer-p
- window-next-buffers window-next-sibling window-new-normal
- window-new-total window-normal-size window-parameter window-parameters
- window-parent window-pixel-edges window-point window-prev-buffers
- window-prev-sibling window-scroll-bars
- window-start window-text-height window-top-child window-top-line
- window-total-height window-total-width window-use-time window-vscroll
- window-width zerop))
+ boundp car cdr default-boundp default-value fboundp
+ get-variable-watchers indirect-variable
+ local-variable-if-set-p local-variable-p
+ logand logcount logior lognot logxor max min mod
+ number-to-string position-symbol string-to-number
+ subr-arity subr-name subr-native-lambda-list subr-type
+ symbol-function symbol-name symbol-plist symbol-value
+ symbol-with-pos-pos variable-binding-locus
+ ;; doc.c
+ documentation
+ ;; editfns.c
+ buffer-substring buffer-substring-no-properties
+ byte-to-position byte-to-string
+ char-after char-before char-equal char-to-string
+ compare-buffer-substrings
+ format format-message
+ group-name
+ line-beginning-position line-end-position ngettext pos-bol pos-eol
+ propertize region-beginning region-end string-to-char
+ user-full-name user-login-name
+ ;; eval.c
+ special-variable-p
+ ;; fileio.c
+ car-less-than-car directory-name-p file-directory-p file-exists-p
+ file-name-absolute-p file-name-concat file-newer-than-file-p
+ file-readable-p file-symlink-p file-writable-p
+ ;; filelock.c
+ file-locked-p
+ ;; floatfns.c
+ abs acos asin atan ceiling copysign cos exp expt fceiling ffloor
+ float floor frexp fround ftruncate isnan ldexp log logb round
+ sin sqrt tan
+ truncate
+ ;; fns.c
+ append assq
+ base64-decode-string base64-encode-string base64url-encode-string
+ buffer-hash buffer-line-statistics
+ compare-strings concat copy-alist copy-hash-table copy-sequence elt
+ equal equal-including-properties
+ featurep get
+ gethash hash-table-count hash-table-rehash-size
+ hash-table-rehash-threshold hash-table-size hash-table-test
+ hash-table-weakness
+ length length< length= length>
+ line-number-at-pos load-average locale-info make-hash-table md5
+ member memq memql nth nthcdr
+ object-intervals rassoc rassq reverse secure-hash
+ string-as-multibyte string-as-unibyte string-bytes
+ string-collate-equalp string-collate-lessp string-distance
+ string-equal string-lessp string-make-multibyte string-make-unibyte
+ string-search string-to-multibyte string-to-unibyte
+ string-version-lessp
+ substring substring-no-properties
+ sxhash-eq sxhash-eql sxhash-equal sxhash-equal-including-properties
+ take value< vconcat
+ ;; frame.c
+ frame-ancestor-p frame-bottom-divider-width frame-char-height
+ frame-char-width frame-child-frame-border-width frame-focus
+ frame-fringe-width frame-internal-border-width frame-native-height
+ frame-native-width frame-parameter frame-parameters frame-parent
+ frame-pointer-visible-p frame-position frame-right-divider-width
+ frame-scale-factor frame-scroll-bar-height frame-scroll-bar-width
+ frame-text-cols frame-text-height frame-text-lines frame-text-width
+ frame-total-cols frame-total-lines frame-visible-p
+ frame-window-state-change next-frame previous-frame
+ tool-bar-pixel-width window-system
+ ;; fringe.c
+ fringe-bitmaps-at-pos
+ ;; keyboard.c
+ posn-at-point posn-at-x-y
+ ;; keymap.c
+ copy-keymap keymap-parent keymap-prompt make-keymap make-sparse-keymap
+ ;; lread.c
+ intern-soft read-from-string
+ ;; marker.c
+ copy-marker marker-buffer marker-insertion-type marker-position
+ ;; minibuf.c
+ active-minibuffer-window assoc-string innermost-minibuffer-p
+ minibuffer-innermost-command-loop-p minibufferp
+ ;; print.c
+ error-message-string prin1-to-string
+ ;; process.c
+ format-network-address get-buffer-process get-process
+ process-buffer process-coding-system process-command process-filter
+ process-id process-inherit-coding-system-flag process-mark
+ process-name process-plist process-query-on-exit-flag
+ process-running-child-p process-sentinel process-thread
+ process-tty-name process-type
+ ;; search.c
+ match-beginning match-end regexp-quote
+ ;; sqlite.c
+ sqlite-columns sqlite-more-p sqlite-version
+ ;; syntax.c
+ char-syntax copy-syntax-table matching-paren string-to-syntax
+ syntax-class-to-char
+ ;; term.c
+ controlling-tty-p tty-display-color-cells tty-display-color-p
+ tty-top-frame tty-type
+ ;; terminal.c
+ frame-terminal terminal-list terminal-live-p terminal-name
+ terminal-parameter terminal-parameters
+ ;; textprop.c
+ get-char-property get-char-property-and-overlay get-text-property
+ next-char-property-change next-property-change
+ next-single-char-property-change next-single-property-change
+ previous-char-property-change previous-property-change
+ previous-single-char-property-change previous-single-property-change
+ text-properties-at text-property-any text-property-not-all
+ ;; thread.c
+ all-threads condition-mutex condition-name mutex-name thread-live-p
+ thread-name
+ ;; timefns.c
+ current-cpu-time
+ current-time-string current-time-zone decode-time encode-time
+ float-time format-time-string time-add time-convert time-equal-p
+ time-less-p time-subtract
+ ;; window.c
+ coordinates-in-window-p frame-first-window frame-root-window
+ frame-selected-window get-buffer-window minibuffer-selected-window
+ minibuffer-window next-window previous-window window-at
+ window-body-height window-body-width window-buffer
+ window-combination-limit window-configuration-equal-p
+ window-dedicated-p window-display-table window-frame window-fringes
+ window-hscroll window-left-child window-left-column window-margins
+ window-minibuffer-p window-new-normal window-new-total
+ window-next-buffers window-next-sibling window-normal-size
+ window-parameter window-parameters window-parent window-point
+ window-prev-buffers window-prev-sibling window-scroll-bars
+ window-start window-text-height window-top-child window-top-line
+ window-total-height window-total-width window-use-time window-vscroll
+ ;; xdisp.c
+ buffer-text-pixel-size current-bidi-paragraph-direction
+ get-display-property invisible-p line-pixel-height lookup-image-map
+ tab-bar-height tool-bar-height window-text-pixel-size
+ ))
(side-effect-and-error-free-fns
- '(always arrayp atom
- bignump bobp bolp bool-vector-p
- buffer-end buffer-list buffer-size buffer-string bufferp
- car-safe case-table-p cdr-safe char-or-string-p characterp
- charsetp commandp cons consp
- current-buffer current-global-map current-indentation
- current-local-map current-minor-mode-maps current-time
- eobp eolp eq equal eventp
- fixnump floatp following-char framep
- get-largest-window get-lru-window
- hash-table-p
- ;; `ignore' isn't here because we don't want calls to it elided;
- ;; see `byte-compile-ignore'.
- identity integerp integer-or-marker-p interactive-p
- invocation-directory invocation-name
- keymapp keywordp
- list listp
- make-marker mark-marker markerp max-char
- memory-limit
- mouse-movement-p
- natnump nlistp not null number-or-marker-p numberp
- one-window-p overlayp
- point point-marker point-min point-max preceding-char primary-charset
- processp proper-list-p
- recent-keys recursion-depth
- safe-length selected-frame selected-window sequencep
- standard-case-table standard-syntax-table stringp subrp symbolp
- syntax-table syntax-table-p
- this-command-keys this-command-keys-vector this-single-command-keys
- this-single-command-raw-keys type-of
- user-real-login-name user-real-uid user-uid
- vector vectorp visible-frame-list
- wholenump window-configuration-p window-live-p
- window-valid-p windowp)))
+ '(
+ ;; alloc.c
+ bool-vector cons list make-marker purecopy record vector
+ ;; buffer.c
+ buffer-list buffer-live-p current-buffer overlay-lists overlayp
+ ;; casetab.c
+ case-table-p current-case-table standard-case-table
+ ;; category.c
+ category-table category-table-p make-category-table
+ standard-category-table
+ ;; character.c
+ characterp max-char
+ ;; charset.c
+ charsetp
+ ;; data.c
+ arrayp atom bare-symbol-p bool-vector-p bufferp byte-code-function-p
+ byteorder car-safe cdr-safe char-or-string-p char-table-p
+ condition-variable-p consp eq floatp indirect-function
+ integer-or-marker-p integerp keywordp listp markerp
+ module-function-p multibyte-string-p mutexp natnump nlistp null
+ number-or-marker-p numberp recordp remove-pos-from-symbol
+ sequencep stringp subr-native-elisp-p subrp symbol-with-pos-p symbolp
+ threadp type-of user-ptrp vector-or-char-table-p vectorp wholenump
+ ;; editfns.c
+ bobp bolp buffer-size buffer-string current-message emacs-pid
+ eobp eolp following-char gap-position gap-size group-gid
+ group-real-gid mark-marker point point-marker point-max point-min
+ position-bytes preceding-char system-name
+ user-real-login-name user-real-uid user-uid
+ ;; emacs.c
+ invocation-directory invocation-name
+ ;; eval.c
+ commandp functionp
+ ;; fileio.c
+ default-file-modes
+ ;; fns.c
+ eql
+ hash-table-p identity proper-list-p safe-length
+ secure-hash-algorithms
+ ;; frame.c
+ frame-list frame-live-p framep last-nonminibuffer-frame
+ old-selected-frame selected-frame visible-frame-list
+ ;; image.c
+ imagep
+ ;; indent.c
+ current-column current-indentation
+ ;; keyboard.c
+ current-idle-time current-input-mode recent-keys recursion-depth
+ this-command-keys this-command-keys-vector this-single-command-keys
+ this-single-command-raw-keys
+ ;; keymap.c
+ current-global-map current-local-map current-minor-mode-maps keymapp
+ ;; minibuf.c
+ minibuffer-contents minibuffer-contents-no-properties minibuffer-depth
+ minibuffer-prompt minibuffer-prompt-end
+ ;; process.c
+ process-list processp signal-names waiting-for-user-input-p
+ ;; sqlite.c
+ sqlite-available-p sqlitep
+ ;; syntax.c
+ standard-syntax-table syntax-table syntax-table-p
+ ;; thread.c
+ current-thread
+ ;; timefns.c
+ current-time
+ ;; window.c
+ selected-window window-configuration-p window-live-p window-valid-p
+ windowp
+ ;; xdisp.c
+ long-line-optimizations-p
+ )))
(while side-effect-free-fns
(put (car side-effect-free-fns) 'side-effect-free t)
(setq side-effect-free-fns (cdr side-effect-free-fns)))
@@ -1690,43 +1949,35 @@ See Info node `(elisp) Integer Basics'."
;; values if a marker is moved.
(let ((pure-fns
- '(concat regexp-opt regexp-quote
- string-to-char string-to-syntax symbol-name
- eq eql
- = /= < <= >= > min max
- + - * / % mod abs ash 1+ 1- sqrt
- logand logior lognot logxor logcount
- copysign isnan ldexp float logb
- floor ceiling round truncate
- ffloor fceiling fround ftruncate
- string= string-equal string< string-lessp string> string-greaterp
- string-empty-p string-blank-p
- string-search
- consp atom listp nlistp proper-list-p
- sequencep arrayp vectorp stringp bool-vector-p hash-table-p
- null not
- numberp integerp floatp natnump characterp
- integer-or-marker-p number-or-marker-p char-or-string-p
- symbolp keywordp
- type-of
- identity ignore
-
- ;; The following functions are pure up to mutation of their
- ;; arguments. This is pure enough for the purposes of
- ;; constant folding, but not necessarily for all kinds of
- ;; code motion.
- car cdr car-safe cdr-safe nth nthcdr last take
- equal
- length safe-length
- memq memql member
- ;; `assoc' and `assoc-default' are excluded since they are
- ;; impure if the test function is (consider `string-match').
- assq rassq rassoc
- lax-plist-get
- aref elt
- base64-decode-string base64-encode-string base64url-encode-string
- bool-vector-subsetp
- bool-vector-count-population bool-vector-count-consecutive
+ '(
+ ;; character.c
+ characterp max-char
+ ;; data.c
+ % * + - / /= 1+ 1- < <= = > >= aref arrayp ash atom bare-symbol
+ bool-vector-count-consecutive bool-vector-count-population
+ bool-vector-p bool-vector-subsetp
+ bufferp car car-safe cdr cdr-safe char-or-string-p char-table-p
+ condition-variable-p consp eq floatp integer-or-marker-p integerp
+ keywordp listp logand logcount logior lognot logxor markerp max min
+ mod multibyte-string-p mutexp natnump nlistp null number-or-marker-p
+ numberp recordp remove-pos-from-symbol sequencep stringp symbol-name
+ symbolp threadp type-of vector-or-char-table-p vectorp
+ ;; editfns.c
+ string-to-char
+ ;; floatfns.c
+ abs ceiling copysign fceiling ffloor float floor fround ftruncate
+ isnan ldexp logb round sqrt truncate
+ ;; fns.c
+ assq base64-decode-string base64-encode-string base64url-encode-string
+ concat elt eql equal equal-including-properties
+ hash-table-p identity length length< length=
+ length> member memq memql nth nthcdr proper-list-p rassoc rassq
+ safe-length string-bytes string-distance string-equal string-lessp
+ string-search string-version-lessp take value<
+ ;; search.c
+ regexp-quote
+ ;; syntax.c
+ string-to-syntax
)))
(while pure-fns
(put (car pure-fns) 'pure t)
@@ -1904,8 +2155,9 @@ See Info node `(elisp) Integer Basics'."
(defconst byte-after-unbind-ops
'(byte-constant byte-dup byte-stack-ref byte-stack-set byte-discard
+ byte-discardN byte-discardN-preserve-tos
byte-symbolp byte-consp byte-stringp byte-listp byte-numberp byte-integerp
- byte-eq byte-not
+ byte-not
byte-cons byte-list1 byte-list2 byte-list3 byte-list4 byte-listN
byte-interactive-p)
;; How about other side-effect-free-ops? Is it safe to move an
@@ -1913,11 +2165,16 @@ See Info node `(elisp) Integer Basics'."
;; No, it is not, because the unwind-protect forms can alter
;; the inside of the object to which nth would apply.
;; For the same reason, byte-equal was deleted from this list.
+ ;;
+ ;; In particular, `byte-eq' isn't here despite `eq' being nominally
+ ;; pure because it is currently affected by `symbols-with-pos-enabled'
+ ;; and so cannot be sunk past an unwind op that might end a binding of
+ ;; that variable. Yes, this is unsatisfactory.
"Byte-codes that can be moved past an unbind.")
(defconst byte-compile-side-effect-and-error-free-ops
'(byte-constant byte-dup byte-symbolp byte-consp byte-stringp byte-listp
- byte-integerp byte-numberp byte-eq byte-equal byte-not byte-car-safe
+ byte-integerp byte-numberp byte-eq byte-not byte-car-safe
byte-cdr-safe byte-cons byte-list1 byte-list2 byte-list3 byte-list4
byte-listN byte-point byte-point-max
byte-point-min byte-following-char byte-preceding-char
@@ -1928,10 +2185,11 @@ See Info node `(elisp) Integer Basics'."
(append
'(byte-varref byte-nth byte-memq byte-car byte-cdr byte-length byte-aref
byte-symbol-value byte-get byte-concat2 byte-concat3 byte-sub1 byte-add1
- byte-eqlsign byte-gtr byte-lss byte-leq byte-geq byte-diff byte-negate
- byte-plus byte-max byte-min byte-mult byte-char-after byte-char-syntax
- byte-buffer-substring byte-string= byte-string< byte-nthcdr byte-elt
- byte-member byte-assq byte-quo byte-rem byte-substring)
+ byte-eqlsign byte-equal byte-gtr byte-lss byte-leq byte-geq byte-diff
+ byte-negate byte-plus byte-max byte-min byte-mult byte-char-after
+ byte-char-syntax byte-buffer-substring byte-string= byte-string<
+ byte-nthcdr byte-elt byte-member byte-assq byte-quo byte-rem
+ byte-substring)
byte-compile-side-effect-and-error-free-ops))
;; This crock is because of the way DEFVAR_BOOL variables work.
@@ -1967,574 +2225,800 @@ See Info node `(elisp) Integer Basics'."
(defun byte-optimize-lapcode (lap &optional _for-effect)
"Simple peephole optimizer. LAP is both modified and returned.
If FOR-EFFECT is non-nil, the return value is assumed to be of no importance."
- (let (lap0
- lap1
- lap2
- (keep-going 'first-time)
- (add-depth 0)
- rest tmp tmp2 tmp3
- (side-effect-free (if byte-compile-delete-errors
+ (let ((side-effect-free (if byte-compile-delete-errors
byte-compile-side-effect-free-ops
- byte-compile-side-effect-and-error-free-ops)))
+ byte-compile-side-effect-and-error-free-ops))
+ ;; Ops taking and produce a single value on the stack.
+ (unary-ops '( byte-not byte-length byte-list1 byte-nreverse
+ byte-car byte-cdr byte-car-safe byte-cdr-safe
+ byte-symbolp byte-consp byte-stringp
+ byte-listp byte-integerp byte-numberp
+ byte-add1 byte-sub1 byte-negate
+ ;; There are more of these but the list is
+ ;; getting long and the gain is typically small.
+ ))
+ ;; Ops producing a single result without looking at the stack.
+ (producer-ops '( byte-constant byte-varref
+ byte-point byte-point-max byte-point-min
+ byte-following-char byte-preceding-char
+ byte-current-column
+ byte-eolp byte-eobp byte-bolp byte-bobp
+ byte-current-buffer byte-widen))
+ (add-depth 0)
+ (keep-going 'first-time)
+ ;; Create a cons cell as head of the list so that removing the first
+ ;; element does not need special-casing: `setcdr' always works.
+ (lap-head (cons nil lap)))
(while keep-going
- (or (eq keep-going 'first-time)
- (byte-compile-log-lap " ---- next pass"))
- (setq rest lap
- keep-going nil)
- (while rest
- (setq lap0 (car rest)
- lap1 (nth 1 rest)
- lap2 (nth 2 rest))
-
- ;; You may notice that sequences like "dup varset discard" are
- ;; optimized but sequences like "dup varset TAG1: discard" are not.
- ;; You may be tempted to change this; resist that temptation.
- (cond
- ;; <side-effect-free> pop --> <deleted>
- ;; ...including:
- ;; const-X pop --> <deleted>
- ;; varref-X pop --> <deleted>
- ;; dup pop --> <deleted>
- ;;
- ((and (eq 'byte-discard (car lap1))
- (memq (car lap0) side-effect-free))
- (setq keep-going t)
- (setq tmp (aref byte-stack+-info (symbol-value (car lap0))))
- (setq rest (cdr rest))
- (cond ((eql tmp 1)
- (byte-compile-log-lap
- " %s discard\t-->\t<deleted>" lap0)
- (setq lap (delq lap0 (delq lap1 lap))))
- ((eql tmp 0)
- (byte-compile-log-lap
- " %s discard\t-->\t<deleted> discard" lap0)
- (setq lap (delq lap0 lap)))
- ((eql tmp -1)
- (byte-compile-log-lap
- " %s discard\t-->\tdiscard discard" lap0)
- (setcar lap0 'byte-discard)
- (setcdr lap0 0))
- (t (error "Optimizer error: too much on the stack"))))
- ;;
- ;; goto*-X X: --> X:
- ;;
- ((and (memq (car lap0) byte-goto-ops)
- (eq (cdr lap0) lap1))
- (cond ((eq (car lap0) 'byte-goto)
- (setq lap (delq lap0 lap))
- (setq tmp "<deleted>"))
- ((memq (car lap0) byte-goto-always-pop-ops)
- (setcar lap0 (setq tmp 'byte-discard))
- (setcdr lap0 0))
- ((error "Depth conflict at tag %d" (nth 2 lap0))))
- (and (memq byte-optimize-log '(t byte))
- (byte-compile-log " (goto %s) %s:\t-->\t%s %s:"
- (nth 1 lap1) (nth 1 lap1)
- tmp (nth 1 lap1)))
- (setq keep-going t))
- ;;
- ;; varset-X varref-X --> dup varset-X
- ;; varbind-X varref-X --> dup varbind-X
- ;; const/dup varset-X varref-X --> const/dup varset-X const/dup
- ;; const/dup varbind-X varref-X --> const/dup varbind-X const/dup
- ;; The latter two can enable other optimizations.
- ;;
- ;; For lexical variables, we could do the same
- ;; stack-set-X+1 stack-ref-X --> dup stack-set-X+2
- ;; but this is a very minor gain, since dup is stack-ref-0,
- ;; i.e. it's only better if X>5, and even then it comes
- ;; at the cost of an extra stack slot. Let's not bother.
- ((and (eq 'byte-varref (car lap2))
- (eq (cdr lap1) (cdr lap2))
- (memq (car lap1) '(byte-varset byte-varbind)))
- (if (and (setq tmp (memq (car (cdr lap2)) byte-boolean-vars))
- (not (eq (car lap0) 'byte-constant)))
- nil
- (setq keep-going t)
- (if (memq (car lap0) '(byte-constant byte-dup))
- (progn
- (setq tmp (if (or (not tmp)
- (macroexp--const-symbol-p
- (car (cdr lap0))))
- (cdr lap0)
- (byte-compile-get-constant t)))
- (byte-compile-log-lap " %s %s %s\t-->\t%s %s %s"
- lap0 lap1 lap2 lap0 lap1
- (cons (car lap0) tmp))
- (setcar lap2 (car lap0))
- (setcdr lap2 tmp))
- (byte-compile-log-lap " %s %s\t-->\tdup %s" lap1 lap2 lap1)
- (setcar lap2 (car lap1))
- (setcar lap1 'byte-dup)
- (setcdr lap1 0)
- ;; The stack depth gets locally increased, so we will
- ;; increase maxdepth in case depth = maxdepth here.
- ;; This can cause the third argument to byte-code to
- ;; be larger than necessary.
- (setq add-depth 1))))
- ;;
- ;; dup varset-X discard --> varset-X
- ;; dup varbind-X discard --> varbind-X
- ;; dup stack-set-X discard --> stack-set-X-1
- ;; (the varbind variant can emerge from other optimizations)
- ;;
- ((and (eq 'byte-dup (car lap0))
- (eq 'byte-discard (car lap2))
- (memq (car lap1) '(byte-varset byte-varbind
- byte-stack-set)))
- (byte-compile-log-lap " dup %s discard\t-->\t%s" lap1 lap1)
- (setq keep-going t
- rest (cdr rest))
- (if (eq 'byte-stack-set (car lap1)) (cl-decf (cdr lap1)))
- (setq lap (delq lap0 (delq lap2 lap))))
- ;;
- ;; not goto-X-if-nil --> goto-X-if-non-nil
- ;; not goto-X-if-non-nil --> goto-X-if-nil
- ;;
- ;; it is wrong to do the same thing for the -else-pop variants.
- ;;
- ((and (eq 'byte-not (car lap0))
- (memq (car lap1) '(byte-goto-if-nil byte-goto-if-not-nil)))
- (byte-compile-log-lap " not %s\t-->\t%s"
- lap1
- (cons
- (if (eq (car lap1) 'byte-goto-if-nil)
- 'byte-goto-if-not-nil
- 'byte-goto-if-nil)
- (cdr lap1)))
- (setcar lap1 (if (eq (car lap1) 'byte-goto-if-nil)
- 'byte-goto-if-not-nil
- 'byte-goto-if-nil))
- (setq lap (delq lap0 lap))
- (setq keep-going t))
- ;;
- ;; goto-X-if-nil goto-Y X: --> goto-Y-if-non-nil X:
- ;; goto-X-if-non-nil goto-Y X: --> goto-Y-if-nil X:
- ;;
- ;; it is wrong to do the same thing for the -else-pop variants.
- ;;
- ((and (memq (car lap0)
- '(byte-goto-if-nil byte-goto-if-not-nil)) ; gotoX
- (eq 'byte-goto (car lap1)) ; gotoY
- (eq (cdr lap0) lap2)) ; TAG X
- (let ((inverse (if (eq 'byte-goto-if-nil (car lap0))
- 'byte-goto-if-not-nil 'byte-goto-if-nil)))
- (byte-compile-log-lap " %s %s %s:\t-->\t%s %s:"
- lap0 lap1 lap2
- (cons inverse (cdr lap1)) lap2)
- (setq lap (delq lap0 lap))
- (setcar lap1 inverse)
- (setq keep-going t)))
- ;;
- ;; const goto-if-* --> whatever
- ;;
- ((and (eq 'byte-constant (car lap0))
- (memq (car lap1) byte-conditional-ops)
- ;; If the `byte-constant's cdr is not a cons cell, it has
- ;; to be an index into the constant pool); even though
- ;; it'll be a constant, that constant is not known yet
- ;; (it's typically a free variable of a closure, so will
- ;; only be known when the closure will be built at
- ;; run-time).
- (consp (cdr lap0)))
- (cond ((if (memq (car lap1) '(byte-goto-if-nil
- byte-goto-if-nil-else-pop))
- (car (cdr lap0))
- (not (car (cdr lap0))))
- (byte-compile-log-lap " %s %s\t-->\t<deleted>"
- lap0 lap1)
- (setq rest (cdr rest)
- lap (delq lap0 (delq lap1 lap))))
- (t
- (byte-compile-log-lap " %s %s\t-->\t%s"
- lap0 lap1
- (cons 'byte-goto (cdr lap1)))
- (when (memq (car lap1) byte-goto-always-pop-ops)
- (setq lap (delq lap0 lap)))
- (setcar lap1 'byte-goto)))
- (setq keep-going t))
- ;;
- ;; varref-X varref-X --> varref-X dup
- ;; varref-X [dup ...] varref-X --> varref-X [dup ...] dup
- ;; stackref-X [dup ...] stackref-X+N --> stackref-X [dup ...] dup
- ;; We don't optimize the const-X variations on this here,
- ;; because that would inhibit some goto optimizations; we
- ;; optimize the const-X case after all other optimizations.
- ;;
- ((and (memq (car lap0) '(byte-varref byte-stack-ref))
- (progn
- (setq tmp (cdr rest))
- (setq tmp2 0)
- (while (eq (car (car tmp)) 'byte-dup)
- (setq tmp2 (1+ tmp2))
- (setq tmp (cdr tmp)))
- t)
- (eq (if (eq 'byte-stack-ref (car lap0))
- (+ tmp2 1 (cdr lap0))
- (cdr lap0))
- (cdr (car tmp)))
- (eq (car lap0) (car (car tmp))))
- (if (memq byte-optimize-log '(t byte))
- (let ((str ""))
- (setq tmp2 (cdr rest))
- (while (not (eq tmp tmp2))
- (setq tmp2 (cdr tmp2)
- str (concat str " dup")))
- (byte-compile-log-lap " %s%s %s\t-->\t%s%s dup"
- lap0 str lap0 lap0 str)))
- (setq keep-going t)
- (setcar (car tmp) 'byte-dup)
- (setcdr (car tmp) 0)
- (setq rest tmp))
- ;;
- ;; TAG1: TAG2: --> TAG1: <deleted>
- ;; (and other references to TAG2 are replaced with TAG1)
- ;;
- ((and (eq (car lap0) 'TAG)
- (eq (car lap1) 'TAG))
- (and (memq byte-optimize-log '(t byte))
- (byte-compile-log " adjacent tags %d and %d merged"
- (nth 1 lap1) (nth 1 lap0)))
- (setq tmp3 lap)
- (while (setq tmp2 (rassq lap0 tmp3))
- (setcdr tmp2 lap1)
- (setq tmp3 (cdr (memq tmp2 tmp3))))
- (setq lap (delq lap0 lap)
- keep-going t)
- ;; replace references to tag in jump tables, if any
- (dolist (table byte-compile-jump-tables)
- (maphash #'(lambda (value tag)
- (when (equal tag lap0)
- (puthash value lap1 table)))
- table)))
- ;;
- ;; unused-TAG: --> <deleted>
- ;;
- ((and (eq 'TAG (car lap0))
- (not (rassq lap0 lap))
- ;; make sure this tag isn't used in a jump-table
- (cl-loop for table in byte-compile-jump-tables
- when (member lap0 (hash-table-values table))
- return nil finally return t))
- (and (memq byte-optimize-log '(t byte))
- (byte-compile-log " unused tag %d removed" (nth 1 lap0)))
- (setq lap (delq lap0 lap)
- keep-going t))
- ;;
- ;; goto ... --> goto <delete until TAG or end>
- ;; return ... --> return <delete until TAG or end>
- ;; (unless a jump-table is being used, where deleting may affect
- ;; other valid case bodies)
- ;;
- ((and (memq (car lap0) '(byte-goto byte-return))
- (not (memq (car lap1) '(TAG nil)))
- ;; FIXME: Instead of deferring simply when jump-tables are
- ;; being used, keep a list of tags used for switch tags and
- ;; use them instead (see `byte-compile-inline-lapcode').
- (not byte-compile-jump-tables))
- (setq tmp rest)
- (let ((i 0)
- (opt-p (memq byte-optimize-log '(t lap)))
- str deleted)
- (while (and (setq tmp (cdr tmp))
- (not (eq 'TAG (car (car tmp)))))
- (if opt-p (setq deleted (cons (car tmp) deleted)
- str (concat str " %s")
- i (1+ i))))
- (if opt-p
- (let ((tagstr
- (if (eq 'TAG (car (car tmp)))
- (format "%d:" (car (cdr (car tmp))))
- (or (car tmp) ""))))
- (if (< i 6)
- (apply 'byte-compile-log-lap-1
- (concat " %s" str
- " %s\t-->\t%s <deleted> %s")
- lap0
- (nconc (nreverse deleted)
- (list tagstr lap0 tagstr)))
- (byte-compile-log-lap
- " %s <%d unreachable op%s> %s\t-->\t%s <deleted> %s"
- lap0 i (if (= i 1) "" "s")
- tagstr lap0 tagstr))))
- (rplacd rest tmp))
- (setq keep-going t))
- ;;
- ;; <safe-op> unbind --> unbind <safe-op>
- ;; (this may enable other optimizations.)
- ;;
- ((and (eq 'byte-unbind (car lap1))
- (memq (car lap0) byte-after-unbind-ops))
- (byte-compile-log-lap " %s %s\t-->\t%s %s" lap0 lap1 lap1 lap0)
- (setcar rest lap1)
- (setcar (cdr rest) lap0)
- (setq keep-going t))
- ;;
- ;; varbind-X unbind-N --> discard unbind-(N-1)
- ;; save-excursion unbind-N --> unbind-(N-1)
- ;; save-restriction unbind-N --> unbind-(N-1)
- ;; save-current-buffer unbind-N --> unbind-(N-1)
- ;;
- ((and (eq 'byte-unbind (car lap1))
- (memq (car lap0) '(byte-varbind byte-save-excursion
- byte-save-restriction
- byte-save-current-buffer))
- (< 0 (cdr lap1)))
- (if (zerop (setcdr lap1 (1- (cdr lap1))))
- (delq lap1 rest))
- (if (eq (car lap0) 'byte-varbind)
- (setcar rest (cons 'byte-discard 0))
- (setq lap (delq lap0 lap)))
- (byte-compile-log-lap " %s %s\t-->\t%s %s"
- lap0 (cons (car lap1) (1+ (cdr lap1)))
- (if (eq (car lap0) 'byte-varbind)
- (car rest)
- (car (cdr rest)))
- (if (and (/= 0 (cdr lap1))
- (eq (car lap0) 'byte-varbind))
- (car (cdr rest))
- ""))
- (setq keep-going t))
- ;;
- ;; goto*-X ... X: goto-Y --> goto*-Y
- ;; goto-X ... X: return --> return
- ;;
- ((and (memq (car lap0) byte-goto-ops)
- (memq (car (setq tmp (nth 1 (memq (cdr lap0) lap))))
- '(byte-goto byte-return)))
- (cond ((and (or (eq (car lap0) 'byte-goto)
- (eq (car tmp) 'byte-goto))
- (not (eq (cdr tmp) (cdr lap0))))
- (byte-compile-log-lap " %s [%s]\t-->\t%s"
- (car lap0) tmp tmp)
- (if (eq (car tmp) 'byte-return)
- (setcar lap0 'byte-return))
- (setcdr lap0 (cdr tmp))
- (setq keep-going t))))
- ;;
- ;; goto-*-else-pop X ... X: goto-if-* --> whatever
- ;; goto-*-else-pop X ... X: discard --> whatever
- ;;
- ((and (memq (car lap0) '(byte-goto-if-nil-else-pop
- byte-goto-if-not-nil-else-pop))
- (memq (car (car (setq tmp (cdr (memq (cdr lap0) lap)))))
- (eval-when-compile
- (cons 'byte-discard byte-conditional-ops)))
- (not (eq lap0 (car tmp))))
- (setq tmp2 (car tmp))
- (setq tmp3 (assq (car lap0) '((byte-goto-if-nil-else-pop
- byte-goto-if-nil)
- (byte-goto-if-not-nil-else-pop
- byte-goto-if-not-nil))))
- (if (memq (car tmp2) tmp3)
- (progn (setcar lap0 (car tmp2))
- (setcdr lap0 (cdr tmp2))
- (byte-compile-log-lap " %s-else-pop [%s]\t-->\t%s"
- (car lap0) tmp2 lap0))
- ;; Get rid of the -else-pop's and jump one step further.
- (or (eq 'TAG (car (nth 1 tmp)))
- (setcdr tmp (cons (byte-compile-make-tag)
- (cdr tmp))))
- (byte-compile-log-lap " %s [%s]\t-->\t%s <skip>"
- (car lap0) tmp2 (nth 1 tmp3))
- (setcar lap0 (nth 1 tmp3))
- (setcdr lap0 (nth 1 tmp)))
- (setq keep-going t))
- ;;
- ;; const goto-X ... X: goto-if-* --> whatever
- ;; const goto-X ... X: discard --> whatever
- ;;
- ((and (eq (car lap0) 'byte-constant)
- (eq (car lap1) 'byte-goto)
- (memq (car (car (setq tmp (cdr (memq (cdr lap1) lap)))))
- (eval-when-compile
- (cons 'byte-discard byte-conditional-ops)))
- (not (eq lap1 (car tmp))))
- (setq tmp2 (car tmp))
- (cond ((when (consp (cdr lap0))
- (memq (car tmp2)
- (if (null (car (cdr lap0)))
- '(byte-goto-if-nil byte-goto-if-nil-else-pop)
- '(byte-goto-if-not-nil
- byte-goto-if-not-nil-else-pop))))
- (byte-compile-log-lap " %s goto [%s]\t-->\t%s %s"
- lap0 tmp2 lap0 tmp2)
- (setcar lap1 (car tmp2))
- (setcdr lap1 (cdr tmp2))
- ;; Let next step fix the (const,goto-if*) sequence.
- (setq rest (cons nil rest))
- (setq keep-going t))
- ((or (consp (cdr lap0))
- (eq (car tmp2) 'byte-discard))
- ;; Jump one step further
- (byte-compile-log-lap
- " %s goto [%s]\t-->\t<deleted> goto <skip>"
- lap0 tmp2)
- (or (eq 'TAG (car (nth 1 tmp)))
- (setcdr tmp (cons (byte-compile-make-tag)
- (cdr tmp))))
- (setcdr lap1 (car (cdr tmp)))
- (setq lap (delq lap0 lap))
- (setq keep-going t))))
- ;;
- ;; X: varref-Y ... varset-Y goto-X -->
- ;; X: varref-Y Z: ... dup varset-Y goto-Z
- ;; (varset-X goto-BACK, BACK: varref-X --> copy the varref down.)
- ;; (This is so usual for while loops that it is worth handling).
- ;;
- ;; Here again, we could do it for stack-ref/stack-set, but
- ;; that's replacing a stack-ref-Y with a stack-ref-0, which
- ;; is a very minor improvement (if any), at the cost of
- ;; more stack use and more byte-code. Let's not do it.
- ;;
- ((and (eq (car lap1) 'byte-varset)
- (eq (car lap2) 'byte-goto)
- (not (memq (cdr lap2) rest)) ;Backwards jump
- (eq (car (car (setq tmp (cdr (memq (cdr lap2) lap)))))
- 'byte-varref)
- (eq (cdr (car tmp)) (cdr lap1))
- (not (memq (car (cdr lap1)) byte-boolean-vars)))
- ;;(byte-compile-log-lap " Pulled %s to end of loop" (car tmp))
- (let ((newtag (byte-compile-make-tag)))
- (byte-compile-log-lap
- " %s: %s ... %s %s\t-->\t%s: %s %s: ... %s %s %s"
- (nth 1 (cdr lap2)) (car tmp)
- lap1 lap2
- (nth 1 (cdr lap2)) (car tmp)
- (nth 1 newtag) 'byte-dup lap1
- (cons 'byte-goto newtag)
- )
- (setcdr rest (cons (cons 'byte-dup 0) (cdr rest)))
- (setcdr tmp (cons (setcdr lap2 newtag) (cdr tmp))))
- (setq add-depth 1)
- (setq keep-going t))
- ;;
- ;; goto-X Y: ... X: goto-if*-Y --> goto-if-not-*-X+1 Y:
- ;; (This can pull the loop test to the end of the loop)
- ;;
- ((and (eq (car lap0) 'byte-goto)
- (eq (car lap1) 'TAG)
- (eq lap1
- (cdr (car (setq tmp (cdr (memq (cdr lap0) lap))))))
- (memq (car (car tmp))
- '(byte-goto byte-goto-if-nil byte-goto-if-not-nil
- byte-goto-if-nil-else-pop)))
- ;; (byte-compile-log-lap " %s %s, %s %s --> moved conditional"
- ;; lap0 lap1 (cdr lap0) (car tmp))
- (let ((newtag (byte-compile-make-tag)))
- (byte-compile-log-lap
- "%s %s: ... %s: %s\t-->\t%s ... %s:"
- lap0 (nth 1 lap1) (nth 1 (cdr lap0)) (car tmp)
- (cons (cdr (assq (car (car tmp))
- '((byte-goto-if-nil . byte-goto-if-not-nil)
- (byte-goto-if-not-nil . byte-goto-if-nil)
- (byte-goto-if-nil-else-pop .
- byte-goto-if-not-nil-else-pop)
- (byte-goto-if-not-nil-else-pop .
- byte-goto-if-nil-else-pop))))
- newtag)
-
- (nth 1 newtag)
- )
- (setcdr tmp (cons (setcdr lap0 newtag) (cdr tmp)))
- (if (eq (car (car tmp)) 'byte-goto-if-nil-else-pop)
- ;; We can handle this case but not the -if-not-nil case,
- ;; because we won't know which non-nil constant to push.
- (setcdr rest (cons (cons 'byte-constant
- (byte-compile-get-constant nil))
- (cdr rest))))
- (setcar lap0 (nth 1 (memq (car (car tmp))
- '(byte-goto-if-nil-else-pop
- byte-goto-if-not-nil
- byte-goto-if-nil
- byte-goto-if-not-nil
- byte-goto byte-goto))))
- )
- (setq keep-going t))
-
- ;;
- ;; stack-set-M [discard/discardN ...] --> discardN-preserve-tos
- ;; stack-set-M [discard/discardN ...] --> discardN
- ;;
- ((and (eq (car lap0) 'byte-stack-set)
- (memq (car lap1) '(byte-discard byte-discardN))
- (progn
- ;; See if enough discard operations follow to expose or
- ;; destroy the value stored by the stack-set.
- (setq tmp (cdr rest))
- (setq tmp2 (1- (cdr lap0)))
- (setq tmp3 0)
- (while (memq (car (car tmp)) '(byte-discard byte-discardN))
- (setq tmp3
- (+ tmp3 (if (eq (car (car tmp)) 'byte-discard)
- 1
- (cdr (car tmp)))))
- (setq tmp (cdr tmp)))
- (>= tmp3 tmp2)))
- ;; Do the optimization.
- (setq lap (delq lap0 lap))
- (setcar lap1
- (if (= tmp2 tmp3)
- ;; The value stored is the new TOS, so pop one more
- ;; value (to get rid of the old value) using the
- ;; TOS-preserving discard operator.
- 'byte-discardN-preserve-tos
- ;; Otherwise, the value stored is lost, so just use a
- ;; normal discard.
- 'byte-discardN))
- (setcdr lap1 (1+ tmp3))
- (setcdr (cdr rest) tmp)
- (byte-compile-log-lap " %s [discard/discardN]...\t-->\t%s"
- lap0 lap1))
-
- ;;
- ;; discardN-preserve-tos return --> return
- ;; dup return --> return
- ;; stack-set-N return --> return ; where N is TOS-1
- ;;
- ((and (eq (car lap1) 'byte-return)
- (or (memq (car lap0) '(byte-discardN-preserve-tos byte-dup))
- (and (eq (car lap0) 'byte-stack-set)
- (= (cdr lap0) 1))))
- (setq keep-going t)
- ;; The byte-code interpreter will pop the stack for us, so
- ;; we can just leave stuff on it.
- (setq lap (delq lap0 lap))
- (byte-compile-log-lap " %s %s\t-->\t%s" lap0 lap1 lap1))
-
- ;;
- ;; goto-X ... X: discard ==> discard goto-Y ... X: discard Y:
- ;;
- ((and (eq (car lap0) 'byte-goto)
- (setq tmp (cdr (memq (cdr lap0) lap)))
- (memq (caar tmp) '(byte-discard byte-discardN
- byte-discardN-preserve-tos)))
- (byte-compile-log-lap
- " goto-X .. X: \t-->\t%s goto-X.. X: %s Y:"
- (car tmp) (car tmp))
- (setq keep-going t)
- (let* ((newtag (byte-compile-make-tag))
- ;; Make a copy, since we sometimes modify insts in-place!
- (newdiscard (cons (caar tmp) (cdar tmp)))
- (newjmp (cons (car lap0) newtag)))
- (push newtag (cdr tmp)) ;Push new tag after the discard.
- (setcar rest newdiscard)
- (push newjmp (cdr rest))))
-
- ;;
- ;; const discardN-preserve-tos ==> discardN const
- ;;
- ((and (eq (car lap0) 'byte-constant)
- (eq (car lap1) 'byte-discardN-preserve-tos))
- (setq keep-going t)
- (let ((newdiscard (cons 'byte-discardN (cdr lap1))))
- (byte-compile-log-lap
- " %s %s\t-->\t%s %s" lap0 lap1 newdiscard lap0)
- (setf (car rest) newdiscard)
- (setf (cadr rest) lap0)))
- )
- (setq rest (cdr rest)))
- )
+ (byte-compile-log-lap " ---- %s pass"
+ (if (eq keep-going 'first-time) "first" "next"))
+ (setq keep-going nil)
+ (let ((prev lap-head))
+ (while (cdr prev)
+ (let* ((rest (cdr prev))
+ (lap0 (car rest))
+ (lap1 (nth 1 rest))
+ (lap2 (nth 2 rest)))
+
+ ;; You may notice that sequences like "dup varset discard" are
+ ;; optimized but sequences like "dup varset TAG1: discard" are not.
+ ;; You may be tempted to change this; resist that temptation.
+
+ ;; Each clause in this `cond' statement must keep `prev' the
+ ;; predecessor of the remainder of the list for inspection.
+ (cond
+ ;;
+ ;; PUSH(K) discard(N) --> <deleted> discard(N-K), N>K
+ ;; PUSH(K) discard(N) --> <deleted>, N=K
+ ;; where PUSH(K) is a side-effect-free op such as
+ ;; const, varref, dup
+ ;;
+ ((and (memq (car lap1) '(byte-discard byte-discardN))
+ (memq (car lap0) side-effect-free))
+ (setq keep-going t)
+ (let* ((pushes (aref byte-stack+-info (symbol-value (car lap0))))
+ (pops (if (eq (car lap1) 'byte-discardN) (cdr lap1) 1))
+ (net-pops (- pops pushes)))
+ (cond ((= net-pops 0)
+ (byte-compile-log-lap " %s %s\t-->\t<deleted>"
+ lap0 lap1)
+ (setcdr prev (cddr rest)))
+ ((> net-pops 0)
+ (byte-compile-log-lap
+ " %s %s\t-->\t<deleted> discard(%d)"
+ lap0 lap1 net-pops)
+ (setcar rest (if (eql net-pops 1)
+ (cons 'byte-discard nil)
+ (cons 'byte-discardN net-pops)))
+ (setcdr rest (cddr rest)))
+ (t (error "Optimizer error: too much on the stack")))))
+ ;;
+ ;; goto(X) X: --> X:
+ ;; goto-if-[not-]nil(X) X: --> discard X:
+ ;;
+ ((and (memq (car lap0) byte-goto-ops)
+ (eq (cdr lap0) lap1))
+ (cond ((eq (car lap0) 'byte-goto)
+ (byte-compile-log-lap " %s %s\t-->\t<deleted> %s"
+ lap0 lap1 lap1)
+ (setcdr prev (cdr rest)))
+ ((memq (car lap0) byte-goto-always-pop-ops)
+ (byte-compile-log-lap " %s %s\t-->\tdiscard %s"
+ lap0 lap1 lap1)
+ (setcar lap0 'byte-discard)
+ (setcdr lap0 0))
+ ;; goto-*-else-pop(X) cannot occur here because it would
+ ;; be a depth conflict.
+ (t (error "Depth conflict at tag %d" (nth 2 lap0))))
+ (setq keep-going t))
+ ;;
+ ;; varset-X varref-X --> dup varset-X
+ ;; varbind-X varref-X --> dup varbind-X
+ ;; const/dup varset-X varref-X --> const/dup varset-X const/dup
+ ;; const/dup varbind-X varref-X --> const/dup varbind-X const/dup
+ ;; The latter two can enable other optimizations.
+ ;;
+ ;; For lexical variables, we could do the same
+ ;; stack-set-X+1 stack-ref-X --> dup stack-set-X+2
+ ;; but this is a very minor gain, since dup is stack-ref-0,
+ ;; i.e. it's only better if X>5, and even then it comes
+ ;; at the cost of an extra stack slot. Let's not bother.
+ ((and (eq 'byte-varref (car lap2))
+ (eq (cdr lap1) (cdr lap2))
+ (memq (car lap1) '(byte-varset byte-varbind))
+ (let ((tmp (memq (car (cdr lap2)) byte-boolean-vars)))
+ (and
+ (not (and tmp (not (eq (car lap0) 'byte-constant))))
+ (progn
+ (setq keep-going t)
+ (if (memq (car lap0) '(byte-constant byte-dup))
+ (let ((tmp (if (or (not tmp)
+ (macroexp--const-symbol-p
+ (car (cdr lap0))))
+ (cdr lap0)
+ (byte-compile-get-constant t))))
+ (byte-compile-log-lap " %s %s %s\t-->\t%s %s %s"
+ lap0 lap1 lap2 lap0 lap1
+ (cons (car lap0) tmp))
+ (setcar lap2 (car lap0))
+ (setcdr lap2 tmp))
+ (byte-compile-log-lap " %s %s\t-->\tdup %s"
+ lap1 lap2 lap1)
+ (setcar lap2 (car lap1))
+ (setcar lap1 'byte-dup)
+ (setcdr lap1 0)
+ ;; The stack depth gets locally increased, so we will
+ ;; increase maxdepth in case depth = maxdepth here.
+ ;; This can cause the third argument to byte-code to
+ ;; be larger than necessary.
+ (setq add-depth 1))
+ t)))))
+ ;;
+ ;; dup varset discard(N) --> varset discard(N-1)
+ ;; dup varbind discard(N) --> varbind discard(N-1)
+ ;; dup stack-set(M) discard(N) --> stack-set(M-1) discard(N-1), M>1
+ ;; (the varbind variant can emerge from other optimizations)
+ ;;
+ ((and (eq 'byte-dup (car lap0))
+ (memq (car lap2) '(byte-discard byte-discardN))
+ (or (memq (car lap1) '(byte-varset byte-varbind))
+ (and (eq (car lap1) 'byte-stack-set)
+ (> (cdr lap1) 1))))
+ (setcdr prev (cdr rest)) ; remove dup
+ (let ((new1 (if (eq (car lap1) 'byte-stack-set)
+ (cons 'byte-stack-set (1- (cdr lap1)))
+ lap1))
+ (n (if (eq (car lap2) 'byte-discard) 1 (cdr lap2))))
+ (setcar (cdr rest) new1)
+ (cl-assert (> n 0))
+ (cond
+ ((> n 1)
+ (let ((new2 (if (> n 2)
+ (cons 'byte-discardN (1- n))
+ (cons 'byte-discard nil))))
+ (byte-compile-log-lap " %s %s %s\t-->\t%s %s"
+ lap0 lap1 lap2 new1 new2)
+ (setcar (cddr rest) new2)))
+ (t
+ (byte-compile-log-lap " %s %s %s\t-->\t%s"
+ lap0 lap1 lap2 new1)
+ ;; discard(0) = nop, remove
+ (setcdr (cdr rest) (cdddr rest)))))
+ (setq keep-going t))
+
+ ;;
+ ;; not goto-X-if-nil --> goto-X-if-non-nil
+ ;; not goto-X-if-non-nil --> goto-X-if-nil
+ ;;
+ ;; it is wrong to do the same thing for the -else-pop variants.
+ ;;
+ ((and (eq 'byte-not (car lap0))
+ (memq (car lap1) '(byte-goto-if-nil byte-goto-if-not-nil)))
+ (let ((not-goto (if (eq (car lap1) 'byte-goto-if-nil)
+ 'byte-goto-if-not-nil
+ 'byte-goto-if-nil)))
+ (byte-compile-log-lap " not %s\t-->\t%s"
+ lap1 (cons not-goto (cdr lap1)))
+ (setcar lap1 not-goto)
+ (setcdr prev (cdr rest)) ; delete not
+ (setq keep-going t)))
+ ;;
+ ;; goto-X-if-nil goto-Y X: --> goto-Y-if-non-nil X:
+ ;; goto-X-if-non-nil goto-Y X: --> goto-Y-if-nil X:
+ ;;
+ ;; it is wrong to do the same thing for the -else-pop variants.
+ ;;
+ ((and (memq (car lap0)
+ '(byte-goto-if-nil byte-goto-if-not-nil)) ; gotoX
+ (eq 'byte-goto (car lap1)) ; gotoY
+ (eq (cdr lap0) lap2)) ; TAG X
+ (let ((inverse (if (eq 'byte-goto-if-nil (car lap0))
+ 'byte-goto-if-not-nil 'byte-goto-if-nil)))
+ (byte-compile-log-lap " %s %s %s\t-->\t%s %s"
+ lap0 lap1 lap2
+ (cons inverse (cdr lap1)) lap2)
+ (setcdr prev (cdr rest))
+ (setcar lap1 inverse)
+ (setq keep-going t)))
+ ;;
+ ;; const goto-if-* --> whatever
+ ;;
+ ((and (eq 'byte-constant (car lap0))
+ (memq (car lap1) byte-conditional-ops)
+ ;; Must be an actual constant, not a closure variable.
+ (consp (cdr lap0)))
+ (cond ((if (memq (car lap1) '(byte-goto-if-nil
+ byte-goto-if-nil-else-pop))
+ (car (cdr lap0))
+ (not (car (cdr lap0))))
+ ;; Branch not taken.
+ (byte-compile-log-lap " %s %s\t-->\t<deleted>"
+ lap0 lap1)
+ (setcdr prev (cddr rest))) ; delete both
+ ((memq (car lap1) byte-goto-always-pop-ops)
+ ;; Always-pop branch taken.
+ (byte-compile-log-lap " %s %s\t-->\t%s"
+ lap0 lap1
+ (cons 'byte-goto (cdr lap1)))
+ (setcdr prev (cdr rest)) ; delete const
+ (setcar lap1 'byte-goto))
+ (t ; -else-pop branch taken: keep const
+ (byte-compile-log-lap " %s %s\t-->\t%s %s"
+ lap0 lap1
+ lap0 (cons 'byte-goto (cdr lap1)))
+ (setcar lap1 'byte-goto)))
+ (setq keep-going t))
+ ;;
+ ;; varref-X varref-X --> varref-X dup
+ ;; varref-X [dup ...] varref-X --> varref-X [dup ...] dup
+ ;; stackref-X [dup ...] stackref-X+N --> stackref-X [dup ...] dup
+ ;; We don't optimize the const-X variations on this here,
+ ;; because that would inhibit some goto optimizations; we
+ ;; optimize the const-X case after all other optimizations.
+ ;;
+ ((and (memq (car lap0) '(byte-varref byte-stack-ref))
+ (let ((tmp (cdr rest))
+ (tmp2 0))
+ (while (eq (car (car tmp)) 'byte-dup)
+ (setq tmp2 (1+ tmp2))
+ (setq tmp (cdr tmp)))
+ (and (eq (if (eq 'byte-stack-ref (car lap0))
+ (+ tmp2 1 (cdr lap0))
+ (cdr lap0))
+ (cdr (car tmp)))
+ (eq (car lap0) (car (car tmp)))
+ (progn
+ (when (memq byte-optimize-log '(t byte))
+ (let ((str "")
+ (tmp2 (cdr rest)))
+ (while (not (eq tmp tmp2))
+ (setq tmp2 (cdr tmp2))
+ (setq str (concat str " dup")))
+ (byte-compile-log-lap " %s%s %s\t-->\t%s%s dup"
+ lap0 str lap0 lap0 str)))
+ (setq keep-going t)
+ (setcar (car tmp) 'byte-dup)
+ (setcdr (car tmp) 0)
+ t)))))
+ ;;
+ ;; TAG1: TAG2: --> <deleted> TAG2:
+ ;; (and other references to TAG1 are replaced with TAG2)
+ ;;
+ ((and (eq (car lap0) 'TAG)
+ (eq (car lap1) 'TAG))
+ (byte-compile-log-lap " adjacent tags %d and %d merged"
+ (nth 1 lap1) (nth 1 lap0))
+ (let ((tmp3 (cdr lap-head)))
+ (while (let ((tmp2 (rassq lap0 tmp3)))
+ (and tmp2
+ (progn
+ (setcdr tmp2 lap1)
+ (setq tmp3 (cdr (memq tmp2 tmp3)))
+ t))))
+ (setcdr prev (cdr rest))
+ (setq keep-going t)
+ ;; replace references to tag in jump tables, if any
+ (dolist (table byte-compile-jump-tables)
+ (maphash #'(lambda (value tag)
+ (when (equal tag lap0)
+ (puthash value lap1 table)))
+ table))))
+ ;;
+ ;; unused-TAG: --> <deleted>
+ ;;
+ ((and (eq 'TAG (car lap0))
+ (not (rassq lap0 (cdr lap-head)))
+ ;; make sure this tag isn't used in a jump-table
+ (cl-loop for table in byte-compile-jump-tables
+ when (member lap0 (hash-table-values table))
+ return nil finally return t))
+ (byte-compile-log-lap " unused tag %d removed" (nth 1 lap0))
+ (setcdr prev (cdr rest))
+ (setq keep-going t))
+ ;;
+ ;; goto ... --> goto <delete until TAG or end>
+ ;; return ... --> return <delete until TAG or end>
+ ;;
+ ((and (memq (car lap0) '(byte-goto byte-return))
+ (not (memq (car lap1) '(TAG nil))))
+ (let ((i 0)
+ (tmp rest)
+ (opt-p (memq byte-optimize-log '(t byte)))
+ str deleted)
+ (while (and (setq tmp (cdr tmp))
+ (not (eq 'TAG (car (car tmp)))))
+ (if opt-p (setq deleted (cons (car tmp) deleted)
+ str (concat str " %s")
+ i (1+ i))))
+ (if opt-p
+ (let ((tagstr
+ (if (eq 'TAG (car (car tmp)))
+ (format "%d:" (car (cdr (car tmp))))
+ (or (car tmp) ""))))
+ (if (< i 6)
+ (apply 'byte-compile-log-lap-1
+ (concat " %s" str
+ " %s\t-->\t%s <deleted> %s")
+ lap0
+ (nconc (nreverse deleted)
+ (list tagstr lap0 tagstr)))
+ (byte-compile-log-lap
+ " %s <%d unreachable op%s> %s\t-->\t%s <deleted> %s"
+ lap0 i (if (= i 1) "" "s")
+ tagstr lap0 tagstr))))
+ (setcdr rest tmp)
+ (setq keep-going t)))
+ ;;
+ ;; <safe-op> unbind --> unbind <safe-op>
+ ;; (this may enable other optimizations.)
+ ;;
+ ((and (eq 'byte-unbind (car lap1))
+ (memq (car lap0) byte-after-unbind-ops))
+ (byte-compile-log-lap " %s %s\t-->\t%s %s" lap0 lap1 lap1 lap0)
+ (setcar rest lap1)
+ (setcar (cdr rest) lap0)
+ (setq keep-going t))
+ ;;
+ ;; varbind-X unbind-N --> discard unbind-(N-1)
+ ;; save-excursion unbind-N --> unbind-(N-1)
+ ;; save-restriction unbind-N --> unbind-(N-1)
+ ;; save-current-buffer unbind-N --> unbind-(N-1)
+ ;;
+ ((and (eq 'byte-unbind (car lap1))
+ (memq (car lap0) '(byte-varbind byte-save-excursion
+ byte-save-restriction
+ byte-save-current-buffer))
+ (< 0 (cdr lap1)))
+ (setcdr lap1 (1- (cdr lap1)))
+ (when (zerop (cdr lap1))
+ (setcdr rest (cddr rest)))
+ (if (eq (car lap0) 'byte-varbind)
+ (setcar rest (cons 'byte-discard 0))
+ (setcdr prev (cddr prev)))
+ (byte-compile-log-lap " %s %s\t-->\t%s %s"
+ lap0 (cons (car lap1) (1+ (cdr lap1)))
+ (if (eq (car lap0) 'byte-varbind)
+ (car rest)
+ (car (cdr rest)))
+ (if (and (/= 0 (cdr lap1))
+ (eq (car lap0) 'byte-varbind))
+ (car (cdr rest))
+ ""))
+ (setq keep-going t))
+ ;;
+ ;; goto*-X ... X: goto-Y --> goto*-Y
+ ;; goto-X ... X: return --> return
+ ;;
+ ((and (memq (car lap0) byte-goto-ops)
+ (let ((tmp (nth 1 (memq (cdr lap0) (cdr lap-head)))))
+ (and
+ (memq (car tmp) '(byte-goto byte-return))
+ (or (eq (car lap0) 'byte-goto)
+ (eq (car tmp) 'byte-goto))
+ (not (eq (cdr tmp) (cdr lap0)))
+ (progn
+ (byte-compile-log-lap " %s [%s]\t-->\t%s"
+ (car lap0) tmp
+ (if (eq (car tmp) 'byte-return)
+ tmp
+ (cons (car lap0) (cdr tmp))))
+ (when (eq (car tmp) 'byte-return)
+ (setcar lap0 'byte-return))
+ (setcdr lap0 (cdr tmp))
+ (setq keep-going t)
+ t)))))
+
+ ;;
+ ;; OP goto(X) Y: OP X: -> Y: OP X:
+ ;;
+ ((and (eq (car lap1) 'byte-goto)
+ (eq (car lap2) 'TAG)
+ (let ((lap3 (nth 3 rest)))
+ (and (eq (car lap0) (car lap3))
+ (eq (cdr lap0) (cdr lap3))
+ (eq (cdr lap1) (nth 4 rest)))))
+ (byte-compile-log-lap " %s %s %s %s %s\t-->\t%s %s %s"
+ lap0 lap1 lap2
+ (nth 3 rest) (nth 4 rest)
+ lap2 (nth 3 rest) (nth 4 rest))
+ (setcdr prev (cddr rest))
+ (setq keep-going t))
+
+ ;;
+ ;; NOEFFECT PRODUCER return --> PRODUCER return
+ ;; where NOEFFECT lacks effects beyond stack change,
+ ;; PRODUCER pushes a result without looking at the stack:
+ ;; const, varref, point etc.
+ ;;
+ ((and (eq (car (nth 2 rest)) 'byte-return)
+ (memq (car lap1) producer-ops)
+ (or (memq (car lap0) '( byte-discard byte-discardN
+ byte-discardN-preserve-tos
+ byte-stack-set))
+ (memq (car lap0) side-effect-free)))
+ (setq keep-going t)
+ (setq add-depth 1)
+ (setcdr prev (cdr rest))
+ (byte-compile-log-lap " %s %s %s\t-->\t%s %s"
+ lap0 lap1 (nth 2 rest) lap1 (nth 2 rest)))
+
+ ;;
+ ;; (discardN-preserve-tos|dup) UNARY return --> UNARY return
+ ;; where UNARY takes and produces a single value on the stack
+ ;;
+ ;; FIXME: ideally we should run this backwards, so that we could do
+ ;; discardN-preserve-tos OP1...OPn return -> OP1..OPn return
+ ;; but that would require a different approach.
+ ;;
+ ((and (eq (car (nth 2 rest)) 'byte-return)
+ (memq (car lap1) unary-ops)
+ (or (memq (car lap0) '(byte-discardN-preserve-tos byte-dup))
+ (and (eq (car lap0) 'byte-stack-set)
+ (eql (cdr lap0) 1))))
+ (setq keep-going t)
+ (setcdr prev (cdr rest)) ; eat lap0
+ (byte-compile-log-lap " %s %s %s\t-->\t%s %s"
+ lap0 lap1 (nth 2 rest) lap1 (nth 2 rest)))
+
+ ;;
+ ;; goto-*-else-pop X ... X: goto-if-* --> whatever
+ ;; goto-*-else-pop X ... X: discard --> whatever
+ ;;
+ ((and (memq (car lap0) '(byte-goto-if-nil-else-pop
+ byte-goto-if-not-nil-else-pop))
+ (let ((tmp (cdr (memq (cdr lap0) (cdr lap-head)))))
+ (and
+ (memq (caar tmp)
+ (eval-when-compile
+ (cons 'byte-discard byte-conditional-ops)))
+ (not (eq lap0 (car tmp)))
+ (let ((tmp2 (car tmp))
+ (tmp3 (assq (car lap0)
+ '((byte-goto-if-nil-else-pop
+ byte-goto-if-nil)
+ (byte-goto-if-not-nil-else-pop
+ byte-goto-if-not-nil)))))
+ (if (memq (car tmp2) tmp3)
+ (progn (setcar lap0 (car tmp2))
+ (setcdr lap0 (cdr tmp2))
+ (byte-compile-log-lap
+ " %s-else-pop [%s]\t-->\t%s"
+ (car lap0) tmp2 lap0))
+ ;; Get rid of the -else-pop's and jump one
+ ;; step further.
+ (or (eq 'TAG (car (nth 1 tmp)))
+ (setcdr tmp (cons (byte-compile-make-tag)
+ (cdr tmp))))
+ (byte-compile-log-lap " %s [%s]\t-->\t%s <skip>"
+ (car lap0) tmp2 (nth 1 tmp3))
+ (setcar lap0 (nth 1 tmp3))
+ (setcdr lap0 (nth 1 tmp)))
+ (setq keep-going t)
+ t)))))
+ ;;
+ ;; const goto-X ... X: goto-if-* --> whatever
+ ;; const goto-X ... X: discard --> whatever
+ ;;
+ ((and (eq (car lap0) 'byte-constant)
+ (eq (car lap1) 'byte-goto)
+ (let ((tmp (cdr (memq (cdr lap1) (cdr lap-head)))))
+ (and
+ (memq (caar tmp)
+ (eval-when-compile
+ (cons 'byte-discard byte-conditional-ops)))
+ (not (eq lap1 (car tmp)))
+ (let ((tmp2 (car tmp)))
+ (cond ((and (consp (cdr lap0))
+ (memq (car tmp2)
+ (if (null (car (cdr lap0)))
+ '(byte-goto-if-nil
+ byte-goto-if-nil-else-pop)
+ '(byte-goto-if-not-nil
+ byte-goto-if-not-nil-else-pop))))
+ (byte-compile-log-lap
+ " %s goto [%s]\t-->\t%s %s"
+ lap0 tmp2 lap0 tmp2)
+ (setcar lap1 (car tmp2))
+ (setcdr lap1 (cdr tmp2))
+ ;; Let next step fix the (const,goto-if*) seq.
+ (setq keep-going t))
+ ((or (consp (cdr lap0))
+ (eq (car tmp2) 'byte-discard))
+ ;; Jump one step further
+ (byte-compile-log-lap
+ " %s goto [%s]\t-->\t<deleted> goto <skip>"
+ lap0 tmp2)
+ (or (eq 'TAG (car (nth 1 tmp)))
+ (setcdr tmp (cons (byte-compile-make-tag)
+ (cdr tmp))))
+ (setcdr lap1 (car (cdr tmp)))
+ (setcdr prev (cdr rest))
+ (setq keep-going t))
+ (t
+ (setq prev (cdr prev))))
+ t)))))
+ ;;
+ ;; X: varref-Y ... varset-Y goto-X -->
+ ;; X: varref-Y Z: ... dup varset-Y goto-Z
+ ;; (varset-X goto-BACK, BACK: varref-X --> copy the varref down.)
+ ;; (This is so usual for while loops that it is worth handling).
+ ;;
+ ;; Here again, we could do it for stack-ref/stack-set, but
+ ;; that's replacing a stack-ref-Y with a stack-ref-0, which
+ ;; is a very minor improvement (if any), at the cost of
+ ;; more stack use and more byte-code. Let's not do it.
+ ;;
+ ((and (eq (car lap1) 'byte-varset)
+ (eq (car lap2) 'byte-goto)
+ (not (memq (cdr lap2) rest)) ;Backwards jump
+ (let ((tmp (cdr (memq (cdr lap2) (cdr lap-head)))))
+ (and
+ (eq (car (car tmp)) 'byte-varref)
+ (eq (cdr (car tmp)) (cdr lap1))
+ (not (memq (car (cdr lap1)) byte-boolean-vars))
+ (let ((newtag (byte-compile-make-tag)))
+ (byte-compile-log-lap
+ " %s: %s ... %s %s\t-->\t%s: %s %s: ... %s %s %s"
+ (nth 1 (cdr lap2)) (car tmp)
+ lap1 lap2
+ (nth 1 (cdr lap2)) (car tmp)
+ (nth 1 newtag) 'byte-dup lap1
+ (cons 'byte-goto newtag)
+ )
+ (setcdr rest (cons (cons 'byte-dup 0) (cdr rest)))
+ (setcdr tmp (cons (setcdr lap2 newtag) (cdr tmp)))
+ (setq add-depth 1)
+ (setq keep-going t)
+ t)))))
+ ;;
+ ;; goto-X Y: ... X: goto-if*-Y --> goto-if-not-*-X+1 Y:
+ ;; (This can pull the loop test to the end of the loop)
+ ;;
+ ((and (eq (car lap0) 'byte-goto)
+ (eq (car lap1) 'TAG)
+ (let ((tmp (cdr (memq (cdr lap0) (cdr lap-head)))))
+ (and
+ (eq lap1 (cdar tmp))
+ (memq (car (car tmp))
+ '( byte-goto byte-goto-if-nil byte-goto-if-not-nil
+ byte-goto-if-nil-else-pop))
+ (let ((newtag (byte-compile-make-tag)))
+ (byte-compile-log-lap
+ " %s %s ... %s %s\t-->\t%s ... %s"
+ lap0 lap1 (cdr lap0) (car tmp)
+ (cons (cdr (assq (car (car tmp))
+ '((byte-goto-if-nil
+ . byte-goto-if-not-nil)
+ (byte-goto-if-not-nil
+ . byte-goto-if-nil)
+ (byte-goto-if-nil-else-pop
+ . byte-goto-if-not-nil-else-pop)
+ (byte-goto-if-not-nil-else-pop
+ . byte-goto-if-nil-else-pop))))
+ newtag)
+ newtag)
+ (setcdr tmp (cons (setcdr lap0 newtag) (cdr tmp)))
+ (when (eq (car (car tmp)) 'byte-goto-if-nil-else-pop)
+ ;; We can handle this case but not the
+ ;; -if-not-nil case, because we won't know
+ ;; which non-nil constant to push.
+ (setcdr rest
+ (cons (cons 'byte-constant
+ (byte-compile-get-constant nil))
+ (cdr rest))))
+ (setcar lap0 (nth 1 (memq (car (car tmp))
+ '(byte-goto-if-nil-else-pop
+ byte-goto-if-not-nil
+ byte-goto-if-nil
+ byte-goto-if-not-nil
+ byte-goto byte-goto))))
+ (setq keep-going t)
+ t)))))
+
+ ;;
+ ;; discardN-preserve-tos(X) discardN-preserve-tos(Y)
+ ;; --> discardN-preserve-tos(X+Y)
+ ;; where stack-set(1) is accepted as discardN-preserve-tos(1)
+ ;;
+ ((and (or (eq (car lap0) 'byte-discardN-preserve-tos)
+ (and (eq (car lap0) 'byte-stack-set)
+ (eql (cdr lap0) 1)))
+ (or (eq (car lap1) 'byte-discardN-preserve-tos)
+ (and (eq (car lap1) 'byte-stack-set)
+ (eql (cdr lap1) 1))))
+ (setq keep-going t)
+ (let ((new-op (cons 'byte-discardN-preserve-tos
+ ;; This happens to work even when either
+ ;; op is stack-set(1).
+ (+ (cdr lap0) (cdr lap1)))))
+ (byte-compile-log-lap " %s %s\t-->\t%s" lap0 lap1 new-op)
+ (setcar rest new-op)
+ (setcdr rest (cddr rest))))
+
+ ;;
+ ;; stack-set-M [discard/discardN ...] --> discardN-preserve-tos
+ ;; stack-set-M [discard/discardN ...] --> discardN
+ ;;
+ ((and (eq (car lap0) 'byte-stack-set)
+ (memq (car lap1) '(byte-discard byte-discardN))
+ (let ((tmp2 (1- (cdr lap0)))
+ (tmp3 0)
+ (tmp (cdr rest)))
+ ;; See if enough discard operations follow to expose or
+ ;; destroy the value stored by the stack-set.
+ (while (memq (car (car tmp)) '(byte-discard byte-discardN))
+ (setq tmp3
+ (+ tmp3 (if (eq (car (car tmp)) 'byte-discard)
+ 1
+ (cdr (car tmp)))))
+ (setq tmp (cdr tmp)))
+ (and
+ (>= tmp3 tmp2)
+ (progn
+ ;; Do the optimization.
+ (setcdr prev (cdr rest))
+ (setcar lap1
+ (if (= tmp2 tmp3)
+ ;; The value stored is the new TOS, so pop
+ ;; one more value (to get rid of the old
+ ;; value) using TOS-preserving discard.
+ 'byte-discardN-preserve-tos
+ ;; Otherwise, the value stored is lost,
+ ;; so just use a normal discard.
+ 'byte-discardN))
+ (setcdr lap1 (1+ tmp3))
+ (setcdr (cdr rest) tmp)
+ (byte-compile-log-lap
+ " %s [discard/discardN]...\t-->\t%s" lap0 lap1)
+ (setq keep-going t)
+ t
+ )))))
+
+ ;;
+ ;; discardN-preserve-tos return --> return
+ ;; dup return --> return
+ ;; stack-set(1) return --> return
+ ;;
+ ((and (eq (car lap1) 'byte-return)
+ (or (memq (car lap0) '(byte-discardN-preserve-tos byte-dup))
+ (and (eq (car lap0) 'byte-stack-set)
+ (= (cdr lap0) 1))))
+ (setq keep-going t)
+ ;; The byte-code interpreter will pop the stack for us, so
+ ;; we can just leave stuff on it.
+ (setcdr prev (cdr rest))
+ (byte-compile-log-lap " %s %s\t-->\t%s" lap0 lap1 lap1))
+
+ ;;
+ ;; stack-ref(X) discardN-preserve-tos(Y)
+ ;; --> discard(Y) stack-ref(X-Y), X≥Y
+ ;; discard(X) discardN-preserve-tos(Y-X-1), X<Y
+ ;; where: stack-ref(0) = dup (works both ways)
+ ;; discard(0) = no-op
+ ;; discardN-preserve-tos(0) = no-op
+ ;;
+ ((and (memq (car lap0) '(byte-stack-ref byte-dup))
+ (or (eq (car lap1) 'byte-discardN-preserve-tos)
+ (and (eq (car lap1) 'byte-stack-set)
+ (eql (cdr lap1) 1)))
+ ;; Don't apply if immediately preceding a `return',
+ ;; since there are more effective rules for that case.
+ (not (eq (car lap2) 'byte-return)))
+ (let ((x (if (eq (car lap0) 'byte-dup) 0 (cdr lap0)))
+ (y (cdr lap1)))
+ (cl-assert (> y 0))
+ (cond
+ ((>= x y) ; --> discard(Y) stack-ref(X-Y)
+ (let ((new0 (if (= y 1)
+ (cons 'byte-discard nil)
+ (cons 'byte-discardN y)))
+ (new1 (if (= x y)
+ (cons 'byte-dup nil)
+ (cons 'byte-stack-ref (- x y)))))
+ (byte-compile-log-lap " %s %s\t-->\t%s %s"
+ lap0 lap1 new0 new1)
+ (setcar rest new0)
+ (setcar (cdr rest) new1)))
+ ((= x 0) ; --> discardN-preserve-tos(Y-1)
+ (setcdr prev (cdr rest)) ; eat lap0
+ (if (> y 1)
+ (let ((new (cons 'byte-discardN-preserve-tos (- y 1))))
+ (byte-compile-log-lap " %s %s\t-->\t%s"
+ lap0 lap1 new)
+ (setcar (cdr prev) new))
+ (byte-compile-log-lap " %s %s\t-->\t<deleted>" lap0 lap1)
+ (setcdr prev (cddr prev)))) ; eat lap1
+ ((= y (+ x 1)) ; --> discard(X)
+ (setcdr prev (cdr rest)) ; eat lap0
+ (let ((new (if (= x 1)
+ (cons 'byte-discard nil)
+ (cons 'byte-discardN x))))
+ (byte-compile-log-lap " %s %s\t-->\t%s" lap0 lap1 new)
+ (setcar (cdr prev) new)))
+ (t ; --> discard(X) discardN-preserve-tos(Y-X-1)
+ (let ((new0 (if (= x 1)
+ (cons 'byte-discard nil)
+ (cons 'byte-discardN x)))
+ (new1 (cons 'byte-discardN-preserve-tos (- y x 1))))
+ (byte-compile-log-lap " %s %s\t-->\t%s %s"
+ lap0 lap1 new0 new1)
+ (setcar rest new0)
+ (setcar (cdr rest) new1)))))
+ (setq keep-going t))
+
+ ;;
+ ;; goto-X ... X: discard ==> discard goto-Y ... X: discard Y:
+ ;;
+ ((and (eq (car lap0) 'byte-goto)
+ (let ((tmp (cdr (memq (cdr lap0) (cdr lap-head)))))
+ (and
+ tmp
+ (or (memq (caar tmp) '(byte-discard byte-discardN))
+ ;; Make sure we don't hoist a discardN-preserve-tos
+ ;; that really should be merged or deleted instead.
+ (and (or (eq (caar tmp) 'byte-discardN-preserve-tos)
+ (and (eq (caar tmp) 'byte-stack-set)
+ (eql (cdar tmp) 1)))
+ (let ((next (cadr tmp)))
+ (not (or (memq (car next)
+ '(byte-discardN-preserve-tos
+ byte-return))
+ (and (eq (car next) 'byte-stack-set)
+ (eql (cdr next) 1)))))))
+ (progn
+ (byte-compile-log-lap
+ " goto-X .. X: \t-->\t%s goto-X.. X: %s Y:"
+ (car tmp) (car tmp))
+ (setq keep-going t)
+ (let* ((newtag (byte-compile-make-tag))
+ ;; Make a copy, since we sometimes modify
+ ;; insts in-place!
+ (newdiscard (cons (caar tmp) (cdar tmp)))
+ (newjmp (cons (car lap0) newtag)))
+ ;; Push new tag after the discard.
+ (push newtag (cdr tmp))
+ (setcar rest newdiscard)
+ (push newjmp (cdr rest)))
+ t)))))
+
+ ;;
+ ;; UNARY discardN-preserve-tos --> discardN-preserve-tos UNARY
+ ;; where UNARY takes and produces a single value on the stack
+ ;;
+ ((and (memq (car lap0) unary-ops)
+ (or (eq (car lap1) 'byte-discardN-preserve-tos)
+ (and (eq (car lap1) 'byte-stack-set)
+ (eql (cdr lap1) 1)))
+ ;; unless followed by return (which will eat the discard)
+ (not (eq (car lap2) 'byte-return)))
+ (setq keep-going t)
+ (byte-compile-log-lap " %s %s\t-->\t%s %s" lap0 lap1 lap1 lap0)
+ (setcar rest lap1)
+ (setcar (cdr rest) lap0))
+
+ ;;
+ ;; PRODUCER discardN-preserve-tos(X) --> discard(X) PRODUCER
+ ;; where PRODUCER pushes a result without looking at the stack:
+ ;; const, varref, point etc.
+ ;;
+ ((and (memq (car lap0) producer-ops)
+ (or (eq (car lap1) 'byte-discardN-preserve-tos)
+ (and (eq (car lap1) 'byte-stack-set)
+ (eql (cdr lap1) 1)))
+ ;; unless followed by return (which will eat the discard)
+ (not (eq (car lap2) 'byte-return)))
+ (setq keep-going t)
+ (let ((newdiscard (if (eql (cdr lap1) 1)
+ (cons 'byte-discard nil)
+ (cons 'byte-discardN (cdr lap1)))))
+ (byte-compile-log-lap
+ " %s %s\t-->\t%s %s" lap0 lap1 newdiscard lap0)
+ (setf (car rest) newdiscard)
+ (setf (cadr rest) lap0)))
+
+ (t
+ ;; If no rule matched, advance and try again.
+ (setq prev (cdr prev))))))))
;; Cleanup stage:
;; Rebuild byte-compile-constants / byte-compile-variables.
;; Simple optimizations that would inhibit other optimizations if they
@@ -2542,90 +3026,84 @@ If FOR-EFFECT is non-nil, the return value is assumed to be of no importance."
;; need to do more than once.
(setq byte-compile-constants nil
byte-compile-variables nil)
- (setq rest lap)
(byte-compile-log-lap " ---- final pass")
- (while rest
- (setq lap0 (car rest)
- lap1 (nth 1 rest))
- (if (memq (car lap0) byte-constref-ops)
- (if (memq (car lap0) '(byte-constant byte-constant2))
- (unless (memq (cdr lap0) byte-compile-constants)
- (setq byte-compile-constants (cons (cdr lap0)
- byte-compile-constants)))
- (unless (memq (cdr lap0) byte-compile-variables)
- (setq byte-compile-variables (cons (cdr lap0)
- byte-compile-variables)))))
- (cond (;;
- ;; const-C varset-X const-C --> const-C dup varset-X
- ;; const-C varbind-X const-C --> const-C dup varbind-X
- ;;
- (and (eq (car lap0) 'byte-constant)
- (eq (car (nth 2 rest)) 'byte-constant)
- (eq (cdr lap0) (cdr (nth 2 rest)))
- (memq (car lap1) '(byte-varbind byte-varset)))
- (byte-compile-log-lap " %s %s %s\t-->\t%s dup %s"
- lap0 lap1 lap0 lap0 lap1)
- (setcar (cdr (cdr rest)) (cons (car lap1) (cdr lap1)))
- (setcar (cdr rest) (cons 'byte-dup 0))
- (setq add-depth 1))
- ;;
- ;; const-X [dup/const-X ...] --> const-X [dup ...] dup
- ;; varref-X [dup/varref-X ...] --> varref-X [dup ...] dup
- ;;
- ((memq (car lap0) '(byte-constant byte-varref))
- (setq tmp rest
- tmp2 nil)
- (while (progn
- (while (eq 'byte-dup (car (car (setq tmp (cdr tmp))))))
- (and (eq (cdr lap0) (cdr (car tmp)))
- (eq (car lap0) (car (car tmp)))))
- (setcar tmp (cons 'byte-dup 0))
- (setq tmp2 t))
- (if tmp2
- (byte-compile-log-lap
- " %s [dup/%s]...\t-->\t%s dup..." lap0 lap0 lap0)))
- ;;
- ;; unbind-N unbind-M --> unbind-(N+M)
- ;;
- ((and (eq 'byte-unbind (car lap0))
- (eq 'byte-unbind (car lap1)))
- (byte-compile-log-lap " %s %s\t-->\t%s" lap0 lap1
- (cons 'byte-unbind
- (+ (cdr lap0) (cdr lap1))))
- (setq lap (delq lap0 lap))
- (setcdr lap1 (+ (cdr lap1) (cdr lap0))))
-
- ;;
- ;; discard/discardN/discardN-preserve-tos-X discard/discardN-Y -->
- ;; discardN-(X+Y)
- ;;
- ((and (memq (car lap0)
- '(byte-discard byte-discardN
- byte-discardN-preserve-tos))
- (memq (car lap1) '(byte-discard byte-discardN)))
- (setq lap (delq lap0 lap))
- (byte-compile-log-lap
- " %s %s\t-->\t(discardN %s)"
- lap0 lap1
- (+ (if (eq (car lap0) 'byte-discard) 1 (cdr lap0))
- (if (eq (car lap1) 'byte-discard) 1 (cdr lap1))))
- (setcdr lap1 (+ (if (eq (car lap0) 'byte-discard) 1 (cdr lap0))
- (if (eq (car lap1) 'byte-discard) 1 (cdr lap1))))
- (setcar lap1 'byte-discardN))
-
- ;;
- ;; discardN-preserve-tos-X discardN-preserve-tos-Y -->
- ;; discardN-preserve-tos-(X+Y)
- ;;
- ((and (eq (car lap0) 'byte-discardN-preserve-tos)
- (eq (car lap1) 'byte-discardN-preserve-tos))
- (setq lap (delq lap0 lap))
- (setcdr lap1 (+ (cdr lap0) (cdr lap1)))
- (byte-compile-log-lap " %s %s\t-->\t%s" lap0 lap1 (car rest)))
- )
- (setq rest (cdr rest)))
- (setq byte-compile-maxdepth (+ byte-compile-maxdepth add-depth)))
- lap)
+ (let ((prev lap-head))
+ (while (cdr prev)
+ (let* ((rest (cdr prev))
+ (lap0 (car rest))
+ (lap1 (nth 1 rest)))
+ ;; FIXME: Would there ever be a `byte-constant2' op here?
+ (if (memq (car lap0) byte-constref-ops)
+ (if (memq (car lap0) '(byte-constant byte-constant2))
+ (unless (memq (cdr lap0) byte-compile-constants)
+ (setq byte-compile-constants (cons (cdr lap0)
+ byte-compile-constants)))
+ (unless (memq (cdr lap0) byte-compile-variables)
+ (setq byte-compile-variables (cons (cdr lap0)
+ byte-compile-variables)))))
+ (cond
+ ;;
+ ;; const-C varset-X const-C --> const-C dup varset-X
+ ;; const-C varbind-X const-C --> const-C dup varbind-X
+ ;;
+ ((and (eq (car lap0) 'byte-constant)
+ (eq (car (nth 2 rest)) 'byte-constant)
+ (eq (cdr lap0) (cdr (nth 2 rest)))
+ (memq (car lap1) '(byte-varbind byte-varset)))
+ (byte-compile-log-lap " %s %s %s\t-->\t%s dup %s"
+ lap0 lap1 lap0 lap0 lap1)
+ (setcar (cdr (cdr rest)) (cons (car lap1) (cdr lap1)))
+ (setcar (cdr rest) (cons 'byte-dup 0))
+ (setq add-depth 1))
+ ;;
+ ;; const-X [dup/const-X ...] --> const-X [dup ...] dup
+ ;; varref-X [dup/varref-X ...] --> varref-X [dup ...] dup
+ ;;
+ ((memq (car lap0) '(byte-constant byte-varref))
+ (let ((tmp rest)
+ (tmp2 nil))
+ (while (progn
+ (while (eq 'byte-dup (car (car (setq tmp (cdr tmp))))))
+ (and (eq (cdr lap0) (cdr (car tmp)))
+ (eq (car lap0) (car (car tmp)))))
+ (setcar tmp (cons 'byte-dup 0))
+ (setq tmp2 t))
+ (if tmp2
+ (byte-compile-log-lap
+ " %s [dup/%s]...\t-->\t%s dup..." lap0 lap0 lap0)
+ (setq prev (cdr prev)))))
+ ;;
+ ;; unbind-N unbind-M --> unbind-(N+M)
+ ;;
+ ((and (eq 'byte-unbind (car lap0))
+ (eq 'byte-unbind (car lap1)))
+ (byte-compile-log-lap " %s %s\t-->\t%s" lap0 lap1
+ (cons 'byte-unbind
+ (+ (cdr lap0) (cdr lap1))))
+ (setcdr prev (cdr rest))
+ (setcdr lap1 (+ (cdr lap1) (cdr lap0))))
+
+ ;;
+ ;; discard/discardN/discardN-preserve-tos-X discard/discardN-Y -->
+ ;; discardN-(X+Y)
+ ;;
+ ((and (memq (car lap0)
+ '(byte-discard byte-discardN
+ byte-discardN-preserve-tos))
+ (memq (car lap1) '(byte-discard byte-discardN)))
+ (setcdr prev (cdr rest))
+ (byte-compile-log-lap
+ " %s %s\t-->\t(discardN %s)"
+ lap0 lap1
+ (+ (if (eq (car lap0) 'byte-discard) 1 (cdr lap0))
+ (if (eq (car lap1) 'byte-discard) 1 (cdr lap1))))
+ (setcdr lap1 (+ (if (eq (car lap0) 'byte-discard) 1 (cdr lap0))
+ (if (eq (car lap1) 'byte-discard) 1 (cdr lap1))))
+ (setcar lap1 'byte-discardN))
+ (t
+ (setq prev (cdr prev)))))))
+ (setq byte-compile-maxdepth (+ byte-compile-maxdepth add-depth))
+ (cdr lap-head)))
(provide 'byte-opt)
@@ -2635,7 +3113,6 @@ If FOR-EFFECT is non-nil, the return value is assumed to be of no importance."
;;
(eval-when-compile
(or (compiled-function-p (symbol-function 'byte-optimize-form))
- (assq 'byte-code (symbol-function 'byte-optimize-form))
(let ((byte-optimize nil)
(byte-compile-warnings nil))
(mapc (lambda (x)
diff --git a/lisp/emacs-lisp/byte-run.el b/lisp/emacs-lisp/byte-run.el
index 6e04c4b9e72..cc176821026 100644
--- a/lisp/emacs-lisp/byte-run.el
+++ b/lisp/emacs-lisp/byte-run.el
@@ -145,6 +145,11 @@ So far, FUNCTION can only be a symbol, not a lambda expression."
(list 'function-put (list 'quote f)
''side-effect-free (list 'quote val))))
+(defalias 'byte-run--set-important-return-value
+ #'(lambda (f _args val)
+ (list 'function-put (list 'quote f)
+ ''important-return-value (list 'quote val))))
+
(put 'compiler-macro 'edebug-declaration-spec
'(&or symbolp ("lambda" &define lambda-list lambda-doc def-body)))
@@ -226,6 +231,8 @@ This may shift errors from run-time to compile-time.")
(list 'side-effect-free #'byte-run--set-side-effect-free
"If non-nil, calls can be ignored if their value is unused.
If `error-free', drop calls even if `byte-compile-delete-errors' is nil.")
+ (list 'important-return-value #'byte-run--set-important-return-value
+ "If non-nil, warn about calls not using the returned value.")
(list 'compiler-macro #'byte-run--set-compiler-macro)
(list 'doc-string #'byte-run--set-doc-string)
(list 'indent #'byte-run--set-indent)
@@ -262,7 +269,8 @@ This is used by `declare'.")
(interactive-form nil)
(warnings nil)
(warn #'(lambda (msg form)
- (push (macroexp-warn-and-return msg nil nil t form)
+ (push (macroexp-warn-and-return
+ (format-message msg) nil nil t form)
warnings))))
(while
(and body
@@ -486,6 +494,11 @@ convention was modified."
Return t if there isn't any."
(gethash function advertised-signature-table t))
+(defun byte-run--constant-obsolete-warning (obsolete-name)
+ (if (memq obsolete-name '(nil t))
+ (error "Can't make `%s' obsolete; did you forget a quote mark?"
+ obsolete-name)))
+
(defun make-obsolete (obsolete-name current-name when)
"Make the byte-compiler warn that function OBSOLETE-NAME is obsolete.
OBSOLETE-NAME should be a function name or macro name (a symbol).
@@ -495,6 +508,7 @@ If CURRENT-NAME is a string, that is the `use instead' message
\(it should end with a period, and not start with a capital).
WHEN should be a string indicating when the function
was first made obsolete, for example a date or a release number."
+ (byte-run--constant-obsolete-warning obsolete-name)
(put obsolete-name 'byte-obsolete-info
;; The second entry used to hold the `byte-compile' handler, but
;; is not used any more nowadays.
@@ -531,6 +545,7 @@ WHEN should be a string indicating when the variable
was first made obsolete, for example a date or a release number.
ACCESS-TYPE if non-nil should specify the kind of access that will trigger
obsolescence warnings; it can be either `get' or `set'."
+ (byte-run--constant-obsolete-warning obsolete-name)
(put obsolete-name 'byte-obsolete-variable
(purecopy (list current-name access-type when)))
obsolete-name)
@@ -649,11 +664,8 @@ in `byte-compile-warning-types'; see the variable
`byte-compile-warnings' for a fuller explanation of the warning
types. The types that can be suppressed with this macro are
`free-vars', `callargs', `redefine', `obsolete',
-`interactive-only', `lexical', `mapcar', `constants' and
-`suspicious'.
-
-For the `mapcar' case, only the `mapcar' function can be used in
-the symbol list. For `suspicious', only `set-buffer' and `lsh' can be used."
+`interactive-only', `lexical', `ignored-return-value', `constants',
+`suspicious', `empty-body' and `mutate-constant'."
;; Note: during compilation, this definition is overridden by the one in
;; byte-compile-initial-macro-environment.
(declare (debug (sexp body)) (indent 1))
@@ -679,11 +691,11 @@ Otherwise, return nil. For internal use only."
;; This is called from lread.c and therefore needs to be preloaded.
(if lread--unescaped-character-literals
(let ((sorted (sort lread--unescaped-character-literals #'<)))
- (format-message "unescaped character literals %s detected, %s expected!"
- (mapconcat (lambda (char) (format "`?%c'" char))
- sorted ", ")
- (mapconcat (lambda (char) (format "`?\\%c'" char))
- sorted ", ")))))
+ (format "unescaped character literals %s detected, %s expected!"
+ (mapconcat (lambda (char) (format-message "`?%c'" char))
+ sorted ", ")
+ (mapconcat (lambda (char) (format-message "`?\\%c'" char))
+ sorted ", ")))))
(defun byte-compile-info (string &optional message type)
"Format STRING in a way that looks pleasing in the compilation output.
diff --git a/lisp/emacs-lisp/bytecomp.el b/lisp/emacs-lisp/bytecomp.el
index 6e38e33688e..2b5eb34e571 100644
--- a/lisp/emacs-lisp/bytecomp.el
+++ b/lisp/emacs-lisp/bytecomp.el
@@ -231,17 +231,8 @@ This includes variable references and calls to functions such as `car'."
:type 'boolean)
(defvar byte-compile-dynamic nil
- "If non-nil, compile function bodies so they load lazily.
-They are hidden in comments in the compiled file,
-and each one is brought into core when the
-function is called.
-
-To enable this option, make it a file-local variable
-in the source file you want it to apply to.
-For example, add -*-byte-compile-dynamic: t;-*- on the first line.
-
-When this option is true, if you load the compiled file and then move it,
-the functions you loaded will not be able to run.")
+ "Formerly used to compile function bodies so they load lazily.
+This variable no longer has any effect.")
(make-obsolete-variable 'byte-compile-dynamic "not worthwhile any more." "27.1")
;;;###autoload(put 'byte-compile-dynamic 'safe-local-variable 'booleanp)
@@ -262,7 +253,7 @@ This option is enabled by default because it reduces Emacs memory usage."
:type 'boolean)
;;;###autoload(put 'byte-compile-dynamic-docstrings 'safe-local-variable 'booleanp)
-(defconst byte-compile-log-buffer "*Compile-Log*"
+(defvar byte-compile-log-buffer "*Compile-Log*"
"Name of the byte-compiler's log buffer.")
(defvar byte-compile--known-dynamic-vars nil
@@ -292,48 +283,63 @@ The information is logged to `byte-compile-log-buffer'."
;;;###autoload(put 'byte-compile-error-on-warn 'safe-local-variable 'booleanp)
(defconst byte-compile-warning-types
- '(redefine callargs free-vars unresolved
- obsolete noruntime interactive-only
- make-local mapcar constants suspicious lexical lexical-dynamic
- docstrings docstrings-non-ascii-quotes not-unused)
+ '( callargs constants
+ docstrings docstrings-non-ascii-quotes docstrings-wide
+ docstrings-control-chars
+ empty-body free-vars ignored-return-value interactive-only
+ lexical lexical-dynamic make-local
+ mapcar ; obsolete
+ mutate-constant noruntime not-unused obsolete redefine suspicious
+ unresolved)
"The list of warning types used when `byte-compile-warnings' is t.")
(defcustom byte-compile-warnings t
"List of warnings that the byte-compiler should issue (t for almost all).
Elements of the list may be:
- free-vars references to variables not in the current lexical scope.
- unresolved calls to unknown functions.
callargs function calls with args that don't match the definition.
- redefine function name redefined from a macro to ordinary function or vice
- versa, or redefined to take a different number of arguments.
- obsolete obsolete variables and functions.
- noruntime functions that may not be defined at runtime (typically
- defined only under `eval-when-compile').
+ constants let-binding of, or assignment to, constants/nonvariables.
+ docstrings various docstring stylistic issues, such as incorrect use
+ of single quotes
+ docstrings-non-ascii-quotes
+ docstrings that have non-ASCII quotes.
+ Only enabled when `docstrings' also is.
+ docstrings-wide
+ docstrings that are too wide, containing lines longer than both
+ `byte-compile-docstring-max-column' and `fill-column' characters.
+ Only enabled when `docstrings' also is.
+ docstrings-control-chars
+ docstrings that contain control characters other than NL and TAB
+ empty-body body argument to a special form or macro is empty.
+ free-vars references to variables not in the current lexical scope.
+ ignored-return-value
+ function called without using the return value where this
+ is likely to be a mistake.
interactive-only
commands that normally shouldn't be called from Lisp code.
lexical global/dynamic variables lacking a prefix.
lexical-dynamic
lexically bound variable declared dynamic elsewhere
make-local calls to `make-variable-buffer-local' that may be incorrect.
- mapcar mapcar called for effect.
+ mutate-constant
+ code that mutates program constants such as quoted lists.
+ noruntime functions that may not be defined at runtime (typically
+ defined only under `eval-when-compile').
not-unused warning about using variables with symbol names starting with _.
- constants let-binding of, or assignment to, constants/nonvariables.
- docstrings docstrings that are too wide (longer than
- `byte-compile-docstring-max-column' or
- `fill-column' characters, whichever is bigger) or
- have other stylistic issues.
- docstrings-non-ascii-quotes docstrings that have non-ASCII quotes.
- This depends on the `docstrings' warning type.
+ obsolete obsolete variables and functions.
+ redefine function name redefined from a macro to ordinary function or vice
+ versa, or redefined to take a different number of arguments.
suspicious constructs that usually don't do what the coder wanted.
+ unresolved calls to unknown functions.
If the list begins with `not', then the remaining elements specify warnings to
-suppress. For example, (not mapcar) will suppress warnings about mapcar.
+suppress. For example, (not free-vars) will suppress the `free-vars' warning.
The t value means \"all non experimental warning types\", and
excludes the types in `byte-compile--emacs-build-warning-types'.
A value of `all' really means all."
- :type `(choice (const :tag "All" t)
+ :type `(choice (const :tag "Default selection" t)
+ (const :tag "All" all)
(set :menu-tag "Some"
,@(mapcar (lambda (x) `(const ,x))
byte-compile-warning-types))))
@@ -342,7 +348,7 @@ A value of `all' really means all."
'(docstrings-non-ascii-quotes)
"List of warning types that are only enabled during Emacs builds.
This is typically either warning types that are being phased in
-(but shouldn't be enabled for packages yet), or that are only relevant
+\(but shouldn't be enabled for packages yet), or that are only relevant
for the Emacs build itself.")
(defvar byte-compile--suppressed-warnings nil
@@ -483,8 +489,7 @@ Return the compile-time value of FORM."
;; 3.2.3.1, "Processing of Top Level Forms". The semantics are very
;; subtle: see test/lisp/emacs-lisp/bytecomp-tests.el for interesting
;; cases.
- (let ((print-symbols-bare t)) ; Possibly redundant binding.
- (setf form (macroexp-macroexpand form byte-compile-macro-environment)))
+ (setf form (macroexp-macroexpand form byte-compile-macro-environment))
(if (eq (car-safe form) 'progn)
(cons (car form)
(mapcar (lambda (subform)
@@ -493,6 +498,42 @@ Return the compile-time value of FORM."
(cdr form)))
(funcall non-toplevel-case form)))
+
+(defvar bytecomp--copy-tree-seen)
+
+(defun bytecomp--copy-tree-1 (tree)
+ ;; TREE must be a cons.
+ (or (gethash tree bytecomp--copy-tree-seen)
+ (let* ((next (cdr tree))
+ (result (cons nil next))
+ (copy result))
+ (while (progn
+ (puthash tree copy bytecomp--copy-tree-seen)
+ (let ((a (car tree)))
+ (setcar copy (if (consp a)
+ (bytecomp--copy-tree-1 a)
+ a)))
+ (and (consp next)
+ (let ((tail (gethash next bytecomp--copy-tree-seen)))
+ (if tail
+ (progn (setcdr copy tail)
+ nil)
+ (setq tree next)
+ (setq next (cdr next))
+ (let ((prev copy))
+ (setq copy (cons nil next))
+ (setcdr prev copy)
+ t))))))
+ result)))
+
+(defun bytecomp--copy-tree (tree)
+ "Make a copy of TREE, preserving any circular structure therein.
+Only conses are traversed and duplicated, not arrays or any other structure."
+ (if (consp tree)
+ (let ((bytecomp--copy-tree-seen (make-hash-table :test #'eq)))
+ (bytecomp--copy-tree-1 tree))
+ tree))
+
(defconst byte-compile-initial-macro-environment
`(
;; (byte-compiler-options . (lambda (&rest forms)
@@ -526,13 +567,13 @@ Return the compile-time value of FORM."
;; Don't compile here, since we don't know
;; whether to compile as byte-compile-form
;; or byte-compile-file-form.
- (let* ((print-symbols-bare t) ; Possibly redundant binding.
- (expanded
- (byte-run-strip-symbol-positions
- (macroexpand--all-toplevel
- form
- macroexpand-all-environment))))
- (eval expanded lexical-binding)
+ (let ((expanded
+ (macroexpand--all-toplevel
+ form
+ macroexpand-all-environment)))
+ (eval (byte-run-strip-symbol-positions
+ (bytecomp--copy-tree expanded))
+ lexical-binding)
expanded)))))
(with-suppressed-warnings
. ,(lambda (warnings &rest body)
@@ -541,15 +582,19 @@ Return the compile-time value of FORM."
;; Later `internal--with-suppressed-warnings' binds it again, this
;; time in order to affect warnings emitted during the
;; compilation itself.
- (let ((byte-compile--suppressed-warnings
- (append warnings byte-compile--suppressed-warnings)))
- ;; This function doesn't exist, but is just a placeholder
- ;; symbol to hook up with the
- ;; `byte-hunk-handler'/`byte-defop-compiler-1' machinery.
- `(internal--with-suppressed-warnings
- ',warnings
- ,(macroexpand-all `(progn ,@body)
- macroexpand-all-environment))))))
+ (if body
+ (let ((byte-compile--suppressed-warnings
+ (append warnings byte-compile--suppressed-warnings)))
+ ;; This function doesn't exist, but is just a placeholder
+ ;; symbol to hook up with the
+ ;; `byte-hunk-handler'/`byte-defop-compiler-1' machinery.
+ `(internal--with-suppressed-warnings
+ ',warnings
+ ,(macroexpand-all `(progn ,@body)
+ macroexpand-all-environment)))
+ (macroexp-warn-and-return
+ (format-message "`with-suppressed-warnings' with empty body")
+ nil '(empty-body with-suppressed-warnings) t warnings)))))
"The default macro-environment passed to macroexpand by the compiler.
Placing a macro here will cause a macro to have different semantics when
expanded by the compiler as when expanded by the interpreter.")
@@ -1081,7 +1126,8 @@ Each function's symbol gets added to `byte-compile-noruntime-functions'."
;; we arguably should add it to b-c-noruntime-functions,
;; but it's not clear it's worth the trouble
;; trying to recognize that case.
- (unless (get f 'function-history)
+ (unless (or (get f 'function-history)
+ (assq f byte-compile-function-environment))
(push f byte-compile-noruntime-functions)))))))))))))
(defun byte-compile-eval-before-compile (form)
@@ -1569,61 +1615,9 @@ extra args."
"`%s' called with %d args to fill %d format field(s)" (car form)
nargs nfields)))))
-(dolist (elt '(format message error))
+(dolist (elt '(format message format-message error))
(put elt 'byte-compile-format-like t))
-(defun byte-compile--suspicious-defcustom-choice (type)
- "Say whether defcustom TYPE looks odd."
- ;; Check whether there's anything like (choice (const :tag "foo" ;; 'bar)).
- ;; We don't actually follow the syntax for defcustom types, but this
- ;; should be good enough.
- (catch 'found
- (if (and (consp type)
- (proper-list-p type))
- (if (memq (car type) '(const other))
- (when (assq 'quote type)
- (throw 'found t))
- (when (memq t (mapcar #'byte-compile--suspicious-defcustom-choice
- type))
- (throw 'found t)))
- nil)))
-
-;; Warn if a custom definition fails to specify :group, or :type.
-(defun byte-compile-nogroup-warn (form)
- (let ((keyword-args (cdr (cdr (cdr (cdr form)))))
- (name (cadr form)))
- (when (eq (car-safe name) 'quote)
- (when (eq (car form) 'custom-declare-variable)
- (let ((type (plist-get keyword-args :type)))
- (cond
- ((not type)
- (byte-compile-warn-x (cadr name)
- "defcustom for `%s' fails to specify type"
- (cadr name)))
- ((byte-compile--suspicious-defcustom-choice type)
- (byte-compile-warn-x
- (cadr name)
- "defcustom for `%s' has syntactically odd type `%s'"
- (cadr name) type)))))
- (if (and (memq (car form) '(custom-declare-face custom-declare-variable))
- byte-compile-current-group)
- ;; The group will be provided implicitly.
- nil
- (or (and (eq (car form) 'custom-declare-group)
- (equal name ''emacs))
- (plist-get keyword-args :group)
- (byte-compile-warn-x (cadr name)
- "%s for `%s' fails to specify containing group"
- (cdr (assq (car form)
- '((custom-declare-group . defgroup)
- (custom-declare-face . defface)
- (custom-declare-variable . defcustom))))
- (cadr name)))
- ;; Update the current group, if needed.
- (if (and byte-compile-current-file ;Only when compiling a whole file.
- (eq (car form) 'custom-declare-group))
- (setq byte-compile-current-group (cadr name)))))))
-
;; Warn if the function or macro is being redefined with a different
;; number of arguments.
(defun byte-compile-arglist-warn (name arglist macrop)
@@ -1674,110 +1668,175 @@ extra args."
(if (equal sig1 '(1 . 1)) "argument" "arguments")
(byte-compile-arglist-signature-string sig2)))))))
-(defvar byte-compile--wide-docstring-substitution-len 3
- "Substitution width used in `byte-compile--wide-docstring-p'.
-This is a heuristic for guessing the width of a documentation
-string: `byte-compile--wide-docstring-p' assumes that any
-`substitute-command-keys' command substitutions are this long.")
-
-(defun byte-compile--wide-docstring-p (docstring col)
- "Return t if string DOCSTRING is wider than COL.
+(defun bytecomp--docstring-line-width (str)
+ "An approximation of the displayed width of docstring line STR."
+ ;; For literal key sequence substitutions (e.g. "\\`C-h'"), just
+ ;; remove the markup as `substitute-command-keys' would.
+ (when (string-search "\\`" str)
+ (setq str (replace-regexp-in-string
+ (rx "\\`" (group (* (not "'"))) "'")
+ "\\1"
+ str t)))
+ ;; Heuristic: We can't reliably do `substitute-command-keys'
+ ;; substitutions, since the value of a keymap in general can't be
+ ;; known at compile time. So instead, we assume that these
+ ;; substitutions are of some constant length.
+ (when (string-search "\\[" str)
+ (setq str (replace-regexp-in-string
+ (rx "\\[" (* (not "]")) "]")
+ ;; We assume that substitutions have this length.
+ ;; To preserve the non-expansive property of the transform,
+ ;; it shouldn't be more than 3 characters long.
+ "xxx"
+ str t t)))
+ (setq str
+ (replace-regexp-in-string
+ (rx (or
+ ;; Ignore some URLs.
+ (seq "http" (? "s") "://" (* nonl))
+ ;; Ignore these `substitute-command-keys' substitutions.
+ (seq "\\" (or "="
+ (seq "<" (* (not ">")) ">")
+ (seq "{" (* (not "}")) "}")))
+ ;; Ignore the function signature that's stashed at the end of
+ ;; the doc string (in some circumstances).
+ (seq bol "(" (+ (any word "-/:[]&"))
+ ;; One or more arguments.
+ (+ " " (or
+ ;; Arguments.
+ (+ (or (syntax symbol)
+ (any word "-/:[]&=()<>.,?^\\#*'\"")))
+ ;; Argument that is a list.
+ (seq "(" (* (not ")")) ")")))
+ ")")))
+ "" str t t))
+ (length str))
+
+(defun byte-compile--wide-docstring-p (docstring max-width)
+ "Whether DOCSTRING contains a line wider than MAX-WIDTH.
Ignore all `substitute-command-keys' substitutions, except for
-the `\\\\=[command]' ones that are assumed to be of length
-`byte-compile--wide-docstring-substitution-len'. Also ignore
-URLs."
- (string-match
- (format "^.\\{%d,\\}$" (min (1+ col) #xffff)) ; Heed RE_DUP_MAX.
- (replace-regexp-in-string
- (rx (or
- ;; Ignore some URLs.
- (seq "http" (? "s") "://" (* nonl))
- ;; Ignore these `substitute-command-keys' substitutions.
- (seq "\\" (or "="
- (seq "<" (* (not ">")) ">")
- (seq "{" (* (not "}")) "}")))
- ;; Ignore the function signature that's stashed at the end of
- ;; the doc string (in some circumstances).
- (seq bol "(" (+ (any word "-/:[]&"))
- ;; One or more arguments.
- (+ " " (or
- ;; Arguments.
- (+ (or (syntax symbol)
- (any word "-/:[]&=()<>.,?^\\#*'\"")))
- ;; Argument that is a list.
- (seq "(" (* (not ")")) ")")))
- ")")))
- ""
- ;; Heuristic: We can't reliably do `substitute-command-keys'
- ;; substitutions, since the value of a keymap in general can't be
- ;; known at compile time. So instead, we assume that these
- ;; substitutions are of some length N.
- (replace-regexp-in-string
- (rx "\\[" (* (not "]")) "]")
- (make-string byte-compile--wide-docstring-substitution-len ?x)
- ;; For literal key sequence substitutions (e.g. "\\`C-h'"), just
- ;; remove the markup as `substitute-command-keys' would.
- (replace-regexp-in-string
- (rx "\\`" (group (* (not "'"))) "'")
- "\\1"
- docstring)))))
+the `\\\\=[command]' ones that are assumed to be of a fixed length.
+Also ignore URLs."
+ (let ((string-len (length docstring))
+ (start 0)
+ (too-wide nil))
+ (while (< start string-len)
+ (let ((eol (or (string-search "\n" docstring start)
+ string-len)))
+ ;; Since `bytecomp--docstring-line-width' is non-expansive,
+ ;; we can safely assume that if the raw length is
+ ;; within the allowed width, then so is the transformed width.
+ ;; This allows us to avoid the very expensive transformation in
+ ;; most cases.
+ (if (and (> (- eol start) max-width)
+ (> (bytecomp--docstring-line-width
+ (substring docstring start eol))
+ max-width))
+ (progn
+ (setq too-wide t)
+ (setq start string-len))
+ (setq start (1+ eol)))))
+ too-wide))
(defcustom byte-compile-docstring-max-column 80
"Recommended maximum width of doc string lines.
The byte-compiler will emit a warning for documentation strings
containing lines wider than this. If `fill-column' has a larger
value, it will override this variable."
- :group 'bytecomp
:type 'natnum
:safe #'natnump
:version "28.1")
-(define-obsolete-function-alias 'byte-compile-docstring-length-warn
- 'byte-compile-docstring-style-warn "29.1")
-
-(defun byte-compile-docstring-style-warn (form)
- "Warn if there are stylistic problems with the docstring in FORM.
-Warn if documentation string of FORM is too wide.
+(defun byte-compile--list-with-n (list n elem)
+ "Return LIST with its Nth element replaced by ELEM."
+ (if (eq elem (nth n list))
+ list
+ (nconc (take n list)
+ (list elem)
+ (nthcdr (1+ n) list))))
+
+(defun byte-compile--docstring-style-warn (docs kind name)
+ "Warn if there are stylistic problems in the docstring DOCS.
+Warn if documentation string is too wide.
It is too wide if it has any lines longer than the largest of
`fill-column' and `byte-compile-docstring-max-column'."
(when (byte-compile-warning-enabled-p 'docstrings)
- (let ((col (max byte-compile-docstring-max-column fill-column))
- kind name docs)
- (pcase (car form)
- ((or 'autoload 'custom-declare-variable 'defalias
- 'defconst 'define-abbrev-table
- 'defvar 'defvaralias
- 'custom-declare-face)
- (setq kind (nth 0 form))
- (setq name (nth 1 form))
- (setq docs (nth 3 form)))
- ('lambda
- (setq kind "") ; can't be "function", unfortunately
- (setq docs (and (stringp (nth 2 form))
- (nth 2 form)))))
- (when (and (consp name) (eq (car name) 'quote))
- (setq name (cadr name)))
- (setq name (if name (format " `%s' " name) ""))
- (when (and kind docs (stringp docs))
- (when (byte-compile--wide-docstring-p docs col)
+ (let* ((name (if (eq (car-safe name) 'quote) (cadr name) name))
+ (prefix (lambda ()
+ (format "%s%s"
+ kind
+ (if name (format-message " `%S' " name) "")))))
+ (let ((col (max byte-compile-docstring-max-column fill-column)))
+ (when (and (byte-compile-warning-enabled-p 'docstrings-wide)
+ (byte-compile--wide-docstring-p docs col))
(byte-compile-warn-x
name
- "%s%sdocstring wider than %s characters"
- kind name col))
- ;; There's a "naked" ' character before a symbol/list, so it
- ;; should probably be quoted with \=.
- (when (string-match-p "\\( [\"#]\\|[ \t]\\|^\\)'[a-z(]" docs)
+ "%sdocstring wider than %s characters" (funcall prefix) col)))
+
+ (when (byte-compile-warning-enabled-p 'docstrings-control-chars)
+ (let ((start 0)
+ (len (length docs)))
+ (while (and (< start len)
+ (string-match (rx (intersection (in (0 . 31) 127)
+ (not (in "\n\t"))))
+ docs start))
+ (let* ((ofs (match-beginning 0))
+ (c (aref docs ofs)))
+ ;; FIXME: it should be possible to use the exact source position
+ ;; of the control char in most cases, and it would be helpful
+ (byte-compile-warn-x
+ name
+ "%sdocstring contains control char #x%02x (position %d)"
+ (funcall prefix) c ofs)
+ (setq start (1+ ofs))))))
+
+ ;; There's a "naked" ' character before a symbol/list, so it
+ ;; should probably be quoted with \=.
+ (when (string-match-p (rx (| (in " \t") bol)
+ (? (in "\"#"))
+ "'"
+ (in "A-Za-z" "("))
+ docs)
+ (byte-compile-warn-x
+ name
+ (concat "%sdocstring has wrong usage of unescaped single quotes"
+ " (use \\=%c or different quoting such as %c...%c)")
+ (funcall prefix) ?' ?` ?'))
+ ;; There's a "Unicode quote" in the string -- it should probably
+ ;; be an ASCII one instead.
+ (when (byte-compile-warning-enabled-p 'docstrings-non-ascii-quotes)
+ (when (string-match-p (rx (| " \"" (in " \t") bol)
+ (in "‘’"))
+ docs)
(byte-compile-warn-x
- name "%s%sdocstring has wrong usage of unescaped single quotes (use \\= or different quoting)"
- kind name))
- ;; There's a "Unicode quote" in the string -- it should probably
- ;; be an ASCII one instead.
- (when (byte-compile-warning-enabled-p 'docstrings-non-ascii-quotes)
- (when (string-match-p "\\( \"\\|[ \t]\\|^\\)[‘’]" docs)
- (byte-compile-warn-x
- name "%s%sdocstring has wrong usage of \"fancy\" single quotation marks"
- kind name))))))
- form)
+ name
+ "%sdocstring uses curved single quotes; use %s instead of ‘...’"
+ (funcall prefix) "`...'"))))))
+
+(defvar byte-compile--\#$) ; Special value that will print as `#$'.
+(defvar byte-compile--docstrings nil "Table of already compiled docstrings.")
+
+(defun byte-compile--docstring (doc kind name &optional is-a-value)
+ (byte-compile--docstring-style-warn doc kind name)
+ ;; Make docstrings dynamic, when applicable.
+ (cond
+ ((and byte-compile-dynamic-docstrings
+ ;; The native compiler doesn't use those dynamic docstrings.
+ (not byte-native-compiling)
+ ;; Docstrings can only be dynamic when compiling a file.
+ byte-compile--\#$)
+ (let* ((byte-pos (with-memoization
+ ;; Reuse a previously written identical docstring.
+ ;; This is not done out of thriftiness but to try and
+ ;; make sure that "equal" functions remain `equal'.
+ ;; (Often those identical docstrings come from
+ ;; `help-add-fundoc-usage').
+ ;; Needed e.g. for `advice-tests-nadvice'.
+ (gethash doc byte-compile--docstrings)
+ (byte-compile-output-as-comment doc nil)))
+ (newdoc (cons byte-compile--\#$ byte-pos)))
+ (if is-a-value newdoc (macroexp-quote newdoc))))
+ (t doc)))
;; If we have compiled any calls to functions which are not known to be
;; defined, issue a warning enumerating them.
@@ -1812,6 +1871,8 @@ It is too wide if it has any lines longer than the largest of
;; macroenvironment.
(copy-alist byte-compile-initial-macro-environment))
(byte-compile--outbuffer nil)
+ (byte-compile--\#$ nil)
+ (byte-compile--docstrings (make-hash-table :test 'equal))
(overriding-plist-environment nil)
(byte-compile-function-environment nil)
(byte-compile-bound-variables nil)
@@ -1825,11 +1886,8 @@ It is too wide if it has any lines longer than the largest of
;;
(byte-compile-verbose byte-compile-verbose)
(byte-optimize byte-optimize)
- (byte-compile-dynamic byte-compile-dynamic)
(byte-compile-dynamic-docstrings
byte-compile-dynamic-docstrings)
- ;; (byte-compile-generate-emacs19-bytecodes
- ;; byte-compile-generate-emacs19-bytecodes)
(byte-compile-warnings byte-compile-warnings)
;; Indicate that we're not currently loading some file.
;; This is used in `macroexp-file-name' to make sure that
@@ -1843,37 +1901,44 @@ It is too wide if it has any lines longer than the largest of
(setq byte-to-native-plist-environment
overriding-plist-environment)))))
-(defmacro displaying-byte-compile-warnings (&rest body)
+(defmacro displaying-byte-compile-warnings (&rest body) ;FIXME: namespace!
(declare (debug (def-body)))
- `(let* ((--displaying-byte-compile-warnings-fn (lambda () ,@body))
- (warning-series-started
- (and (markerp warning-series)
- (eq (marker-buffer warning-series)
- (get-buffer byte-compile-log-buffer))))
- (byte-compile-form-stack byte-compile-form-stack))
- (if (or (eq warning-series 'byte-compile-warning-series)
- warning-series-started)
- ;; warning-series does come from compilation,
- ;; so don't bind it, but maybe do set it.
- (let (tem)
- ;; Log the file name. Record position of that text.
- (setq tem (byte-compile-log-file))
- (unless warning-series-started
- (setq warning-series (or tem 'byte-compile-warning-series)))
- (if byte-compile-debug
- (funcall --displaying-byte-compile-warnings-fn)
- (condition-case error-info
- (funcall --displaying-byte-compile-warnings-fn)
- (error (byte-compile-report-error error-info)))))
- ;; warning-series does not come from compilation, so bind it.
- (let ((warning-series
- ;; Log the file name. Record position of that text.
- (or (byte-compile-log-file) 'byte-compile-warning-series)))
- (if byte-compile-debug
- (funcall --displaying-byte-compile-warnings-fn)
- (condition-case error-info
- (funcall --displaying-byte-compile-warnings-fn)
- (error (byte-compile-report-error error-info))))))))
+ `(bytecomp--displaying-warnings (lambda () ,@body)))
+
+(defun bytecomp--displaying-warnings (body-fn)
+ (let* ((wrapped-body
+ (lambda ()
+ (if byte-compile-debug
+ (funcall body-fn)
+ ;; Use a `handler-bind' to remember the `byte-compile-form-stack'
+ ;; active at the time the error is signaled, so as to
+ ;; get more precise error locations.
+ (let ((form-stack nil))
+ (condition-case error-info
+ (handler-bind
+ ((error (lambda (_err)
+ (setq form-stack byte-compile-form-stack))))
+ (funcall body-fn))
+ (error (let ((byte-compile-form-stack form-stack))
+ (byte-compile-report-error error-info))))))))
+ (warning-series-started
+ (and (markerp warning-series)
+ (eq (marker-buffer warning-series)
+ (get-buffer byte-compile-log-buffer))))
+ (byte-compile-form-stack byte-compile-form-stack))
+ (if (or (eq warning-series #'byte-compile-warning-series)
+ warning-series-started)
+ ;; warning-series does come from compilation,
+ ;; so don't bind it, but maybe do set it.
+ (let ((tem (byte-compile-log-file))) ;; Log the file name.
+ (unless warning-series-started
+ (setq warning-series (or tem #'byte-compile-warning-series)))
+ (funcall wrapped-body))
+ ;; warning-series does not come from compilation, so bind it.
+ (let ((warning-series
+ ;; Log the file name. Record position of that text.
+ (or (byte-compile-log-file) #'byte-compile-warning-series)))
+ (funcall wrapped-body)))))
;;;###autoload
(defun byte-force-recompile (directory)
@@ -2170,6 +2235,11 @@ See also `emacs-lisp-byte-compile-and-load'."
filename buffer-file-name))
;; Don't inherit lexical-binding from caller (bug#12938).
(unless (local-variable-p 'lexical-binding)
+ (let ((byte-compile-current-buffer (current-buffer)))
+ (displaying-byte-compile-warnings
+ (byte-compile-warn-x
+ (position-symbol 'a (point-min))
+ "file has no `lexical-binding' directive on its first line")))
(setq-local lexical-binding nil))
;; Set the default directory, in case an eval-when-compile uses it.
(setq default-directory (file-name-directory filename)))
@@ -2330,7 +2400,12 @@ With argument ARG, insert value in current buffer after the form."
(setq case-fold-search nil))
(displaying-byte-compile-warnings
(with-current-buffer inbuffer
- (when byte-compile-current-file
+ (when byte-compile-dest-file
+ (setq byte-compile--\#$
+ (copy-sequence ;It needs to be a fresh new object.
+ ;; Also it stands for the `load-file-name' when the `.elc' will
+ ;; be loaded, so make it look like it.
+ byte-compile-dest-file))
(byte-compile-insert-header byte-compile-current-file
byte-compile--outbuffer)
;; Instruct native-comp to ignore this file.
@@ -2385,8 +2460,7 @@ With argument ARG, insert value in current buffer after the form."
(defun byte-compile-insert-header (_filename outbuffer)
"Insert a header at the start of OUTBUFFER.
Call from the source buffer."
- (let ((dynamic byte-compile-dynamic)
- (optimize byte-optimize))
+ (let ((optimize byte-optimize))
(with-current-buffer outbuffer
(goto-char (point-min))
;; The magic number of .elc files is ";ELC", or 0x3B454C43. After
@@ -2420,124 +2494,31 @@ Call from the source buffer."
((eq optimize 'byte) " byte-level optimization only")
(optimize " all optimizations")
(t "out optimization"))
- ".\n"
- (if dynamic ";;; Function definitions are lazy-loaded.\n"
- "")
- "\n\n"))))
+ ".\n\n\n"))))
(defun byte-compile-output-file-form (form)
;; Write the given form to the output buffer, being careful of docstrings
- ;; (for `byte-compile-dynamic-docstrings') in defvar, defvaralias,
- ;; defconst, autoload, and custom-declare-variable.
- ;; defalias calls are output directly by byte-compile-file-form-defmumble;
- ;; it does not pay to first build the defalias in defmumble and then parse
- ;; it here.
+ ;; (for `byte-compile-dynamic-docstrings').
(when byte-native-compiling
;; Spill output for the native compiler here
(push (make-byte-to-native-top-level :form form :lexical lexical-binding)
byte-to-native-top-level-forms))
- (let ((print-symbols-bare t) ; Possibly redundant binding.
- (print-escape-newlines t)
+ (let ((print-escape-newlines t)
(print-length nil)
(print-level nil)
(print-quoted t)
(print-gensym t)
- (print-circle t)) ; Handle circular data structures.
- (if (and (memq (car-safe form) '(defvar defvaralias defconst
- autoload custom-declare-variable))
- (stringp (nth 3 form)))
- (byte-compile-output-docform nil nil '("\n(" 3 ")") form nil
- (memq (car form)
- '(defvaralias autoload
- custom-declare-variable)))
- (princ "\n" byte-compile--outbuffer)
- (prin1 form byte-compile--outbuffer)
- nil)))
+ (print-circle t)
+ (print-continuous-numbering t)
+ (print-number-table (make-hash-table :test #'eq)))
+ (when byte-compile--\#$
+ (puthash byte-compile--\#$ "#$" print-number-table))
+ (princ "\n" byte-compile--outbuffer)
+ (prin1 form byte-compile--outbuffer)
+ nil))
(defvar byte-compile--for-effect)
-(defun byte-compile-output-docform (preface name info form specindex quoted)
- "Print a form with a doc string. INFO is (prefix doc-index postfix).
-If PREFACE and NAME are non-nil, print them too,
-before INFO and the FORM but after the doc string itself.
-If SPECINDEX is non-nil, it is the index in FORM
-of the function bytecode string. In that case,
-we output that argument and the following argument
-\(the constants vector) together, for lazy loading.
-QUOTED says that we have to put a quote before the
-list that represents a doc string reference.
-`defvaralias', `autoload' and `custom-declare-variable' need that."
- ;; We need to examine byte-compile-dynamic-docstrings
- ;; in the input buffer (now current), not in the output buffer.
- (let ((dynamic-docstrings byte-compile-dynamic-docstrings))
- (with-current-buffer byte-compile--outbuffer
- (let (position
- (print-symbols-bare t)) ; Possibly redundant binding.
- ;; Insert the doc string, and make it a comment with #@LENGTH.
- (when (and (>= (nth 1 info) 0) dynamic-docstrings)
- (setq position (byte-compile-output-as-comment
- (nth (nth 1 info) form) nil)))
-
- (let ((print-continuous-numbering t)
- print-number-table
- (index 0)
- ;; FIXME: The bindings below are only needed for when we're
- ;; called from ...-defmumble.
- (print-escape-newlines t)
- (print-length nil)
- (print-level nil)
- (print-quoted t)
- (print-gensym t)
- (print-circle t)) ; Handle circular data structures.
- (if preface
- (progn
- ;; FIXME: We don't handle uninterned names correctly.
- ;; E.g. if cl-define-compiler-macro uses uninterned name we get:
- ;; (defalias '#1=#:foo--cmacro #[514 ...])
- ;; (put 'foo 'compiler-macro '#:foo--cmacro)
- (insert preface)
- (prin1 name byte-compile--outbuffer)))
- (insert (car info))
- (prin1 (car form) byte-compile--outbuffer)
- (while (setq form (cdr form))
- (setq index (1+ index))
- (insert " ")
- (cond ((and (numberp specindex) (= index specindex)
- ;; Don't handle the definition dynamically
- ;; if it refers (or might refer)
- ;; to objects already output
- ;; (for instance, gensyms in the arg list).
- (let (non-nil)
- (when (hash-table-p print-number-table)
- (maphash (lambda (_k v) (if v (setq non-nil t)))
- print-number-table))
- (not non-nil)))
- ;; Output the byte code and constants specially
- ;; for lazy dynamic loading.
- (let ((position
- (byte-compile-output-as-comment
- (cons (car form) (nth 1 form))
- t)))
- (princ (format "(#$ . %d) nil" position)
- byte-compile--outbuffer)
- (setq form (cdr form))
- (setq index (1+ index))))
- ((= index (nth 1 info))
- (if position
- (princ (format (if quoted "'(#$ . %d)" "(#$ . %d)")
- position)
- byte-compile--outbuffer)
- (let ((print-escape-newlines nil))
- (goto-char (prog1 (1+ (point))
- (prin1 (car form)
- byte-compile--outbuffer)))
- (insert "\\\n")
- (goto-char (point-max)))))
- (t
- (prin1 (car form) byte-compile--outbuffer)))))
- (insert (nth 2 info)))))
- nil)
-
(defun byte-compile-keep-pending (form &optional handler)
(if (memq byte-optimize '(t source))
(setq form (byte-optimize-one-form form t)))
@@ -2557,7 +2538,7 @@ list that represents a doc string reference.
(if byte-compile-output
(let ((form (byte-compile-out-toplevel t 'file)))
(cond ((eq (car-safe form) 'progn)
- (mapc 'byte-compile-output-file-form (cdr form)))
+ (mapc #'byte-compile-output-file-form (cdr form)))
(form
(byte-compile-output-file-form form)))
(setq byte-compile-constants nil
@@ -2568,8 +2549,7 @@ list that represents a doc string reference.
byte-compile-jump-tables nil))))
(defun byte-compile-preprocess (form &optional _for-effect)
- (let ((print-symbols-bare t)) ; Possibly redundant binding.
- (setq form (macroexpand-all form byte-compile-macro-environment)))
+ (setq form (macroexpand-all form byte-compile-macro-environment))
;; FIXME: We should run byte-optimize-form here, but it currently does not
;; recurse through all the code, so we'd have to fix this first.
;; Maybe a good fix would be to merge byte-optimize-form into
@@ -2580,16 +2560,12 @@ list that represents a doc string reference.
;; byte-hunk-handlers cannot call this!
(defun byte-compile-toplevel-file-form (top-level-form)
- ;; (let ((byte-compile-form-stack
- ;; (cons top-level-form byte-compile-form-stack)))
- (push top-level-form byte-compile-form-stack)
- (prog1
- (byte-compile-recurse-toplevel
- top-level-form
- (lambda (form)
- (let ((byte-compile-current-form nil)) ; close over this for warnings.
- (byte-compile-file-form (byte-compile-preprocess form t)))))
- (pop byte-compile-form-stack)))
+ (macroexp--with-extended-form-stack top-level-form
+ (byte-compile-recurse-toplevel
+ top-level-form
+ (lambda (form)
+ (let ((byte-compile-current-form nil)) ; close over this for warnings.
+ (byte-compile-file-form (byte-compile-preprocess form t)))))))
;; byte-hunk-handlers can call this.
(defun byte-compile-file-form (form)
@@ -2637,12 +2613,12 @@ list that represents a doc string reference.
(setq byte-compile-unresolved-functions
(delq (assq funsym byte-compile-unresolved-functions)
byte-compile-unresolved-functions)))))
- (if (stringp (nth 3 form))
- (prog1
- form
- (byte-compile-docstring-style-warn form))
- ;; No doc string, so we can compile this as a normal form.
- (byte-compile-keep-pending form 'byte-compile-normal-call)))
+ (let* ((doc (nth 3 form))
+ (newdoc (if (not (stringp doc)) doc
+ (byte-compile--docstring
+ doc 'autoload (nth 1 form)))))
+ (byte-compile-keep-pending (byte-compile--list-with-n form 3 newdoc)
+ #'byte-compile-normal-call)))
(put 'defvar 'byte-hunk-handler 'byte-compile-file-form-defvar)
(put 'defconst 'byte-hunk-handler 'byte-compile-file-form-defvar)
@@ -2654,9 +2630,10 @@ list that represents a doc string reference.
(byte-compile-warn-x
sym "global/dynamic var `%s' lacks a prefix" sym)))
-(defun byte-compile--declare-var (sym)
+(defun byte-compile--declare-var (sym &optional not-toplevel)
(byte-compile--check-prefixed-var sym)
- (when (memq sym byte-compile-lexical-variables)
+ (when (and (not not-toplevel)
+ (memq sym byte-compile-lexical-variables))
(setq byte-compile-lexical-variables
(delq sym byte-compile-lexical-variables))
(when (byte-compile-warning-enabled-p 'lexical sym)
@@ -2665,19 +2642,7 @@ list that represents a doc string reference.
(push sym byte-compile--seen-defvars))
(defun byte-compile-file-form-defvar (form)
- (let ((sym (nth 1 form)))
- (byte-compile--declare-var sym)
- (if (eq (car form) 'defconst)
- (push sym byte-compile-const-variables)))
- (if (and (null (cddr form)) ;No `value' provided.
- (eq (car form) 'defvar)) ;Just a declaration.
- nil
- (byte-compile-docstring-style-warn form)
- (setq form (copy-sequence form))
- (when (consp (nth 2 form))
- (setcar (cdr (cdr form))
- (byte-compile-top-level (nth 2 form) nil 'file)))
- form))
+ (byte-compile-defvar form 'toplevel))
(put 'define-abbrev-table 'byte-hunk-handler
'byte-compile-file-form-defvar-function)
@@ -2685,26 +2650,37 @@ list that represents a doc string reference.
(defun byte-compile-file-form-defvar-function (form)
(pcase-let (((or `',name (let name nil)) (nth 1 form)))
- (if name (byte-compile--declare-var name)))
- ;; Variable aliases are better declared before the corresponding variable,
- ;; since it makes it more likely that only one of the two vars has a value
- ;; before the `defvaralias' gets executed, which avoids the need to
- ;; merge values.
- (pcase form
- (`(defvaralias ,_ ',newname . ,_)
- (when (memq newname byte-compile-bound-variables)
- (if (byte-compile-warning-enabled-p 'suspicious)
- (byte-compile-warn-x
- newname
- "Alias for `%S' should be declared before its referent" newname)))))
- (byte-compile-docstring-style-warn form)
- (byte-compile-keep-pending form))
+ (if name (byte-compile--declare-var name))
+ ;; Variable aliases are better declared before the corresponding variable,
+ ;; since it makes it more likely that only one of the two vars has a value
+ ;; before the `defvaralias' gets executed, which avoids the need to
+ ;; merge values.
+ (pcase form
+ (`(defvaralias ,_ ',newname . ,_)
+ (when (memq newname byte-compile-bound-variables)
+ (if (byte-compile-warning-enabled-p 'suspicious)
+ (byte-compile-warn-x
+ newname
+ "Alias for `%S' should be declared before its referent"
+ newname)))))
+ (let ((doc (nth 3 form)))
+ (when (stringp doc)
+ (setcar (nthcdr 3 form)
+ (byte-compile--docstring doc (nth 0 form) name))))
+ (byte-compile-keep-pending form)))
(put 'custom-declare-variable 'byte-hunk-handler
'byte-compile-file-form-defvar-function)
(put 'custom-declare-face 'byte-hunk-handler
- 'byte-compile-docstring-style-warn)
+ #'byte-compile--custom-declare-face)
+(defun byte-compile--custom-declare-face (form)
+ (let ((kind (nth 0 form)) (name (nth 1 form)) (docs (nth 3 form)))
+ (when (stringp docs)
+ (let ((newdocs (byte-compile--docstring docs kind name)))
+ (unless (eq docs newdocs)
+ (setq form (byte-compile--list-with-n form 3 newdocs)))))
+ form))
(put 'require 'byte-hunk-handler 'byte-compile-file-form-require)
(defun byte-compile-file-form-require (form)
@@ -2858,67 +2834,55 @@ not to take responsibility for the actual compilation of the code."
(cons (cons bare-name code)
(symbol-value this-kind))))
- (if rest
- ;; There are additional args to `defalias' (like maybe a docstring)
- ;; that the code below can't handle: punt!
- nil
- ;; Otherwise, we have a bona-fide defun/defmacro definition, and use
- ;; special code to allow dynamic docstrings and byte-code.
- (byte-compile-flush-pending)
- (let ((index
- ;; If there's no doc string, provide -1 as the "doc string
- ;; index" so that no element will be treated as a doc string.
- (if (not (stringp (documentation code t))) -1 4)))
- (when byte-native-compiling
- ;; Spill output for the native compiler here.
- (push
- (if macro
- (make-byte-to-native-top-level
- :form `(defalias ',name '(macro . ,code) nil)
- :lexical lexical-binding)
- (make-byte-to-native-func-def :name name
- :byte-func code))
- byte-to-native-top-level-forms))
- ;; Output the form by hand, that's much simpler than having
- ;; b-c-output-file-form analyze the defalias.
- (byte-compile-output-docform
- "\n(defalias '"
- bare-name
- (if macro `(" '(macro . #[" ,index "])") `(" #[" ,index "]"))
- (append code nil) ; Turn byte-code-function-p into list.
- (and (atom code) byte-compile-dynamic
- 1)
- nil))
- (princ ")" byte-compile--outbuffer)
- t)))))
+ (byte-compile-flush-pending)
+ (let ((newform `(defalias ',bare-name
+ ,(if macro `'(macro . ,code) code) ,@rest)))
+ (when byte-native-compiling
+ ;; Don't let `byte-compile-output-file-form' push the form to
+ ;; `byte-to-native-top-level-forms' because we want to use
+ ;; `make-byte-to-native-func-def' when possible.
+ (push
+ (if (or macro rest)
+ (make-byte-to-native-top-level
+ :form newform
+ :lexical lexical-binding)
+ (make-byte-to-native-func-def :name name
+ :byte-func code))
+ byte-to-native-top-level-forms))
+ (let ((byte-native-compiling nil))
+ (byte-compile-output-file-form newform)))
+ t))))
(defun byte-compile-output-as-comment (exp quoted)
- "Print Lisp object EXP in the output file, inside a comment.
-Return the file (byte) position it will have.
-If QUOTED is non-nil, print with quoting; otherwise, print without quoting."
+ "Print Lisp object EXP in the output file at point, inside a comment.
+Return the file (byte) position it will have. Leave point after
+the inserted text. If QUOTED is non-nil, print with quoting;
+otherwise, print without quoting."
(with-current-buffer byte-compile--outbuffer
- (let ((position (point)))
-
+ (let ((position (point)) end)
;; Insert EXP, and make it a comment with #@LENGTH.
(insert " ")
(if quoted
(prin1 exp byte-compile--outbuffer)
(princ exp byte-compile--outbuffer))
+ (setq end (point-marker))
+ (set-marker-insertion-type end t)
+
(goto-char position)
;; Quote certain special characters as needed.
;; get_doc_string in doc.c does the unquoting.
- (while (search-forward "\^A" nil t)
+ (while (search-forward "\^A" end t)
(replace-match "\^A\^A" t t))
(goto-char position)
- (while (search-forward "\000" nil t)
+ (while (search-forward "\000" end t)
(replace-match "\^A0" t t))
(goto-char position)
- (while (search-forward "\037" nil t)
+ (while (search-forward "\037" end t)
(replace-match "\^A_" t t))
- (goto-char (point-max))
+ (goto-char end)
(insert "\037")
(goto-char position)
- (insert "#@" (format "%d" (- (position-bytes (point-max))
+ (insert "#@" (format "%d" (- (position-bytes end)
(position-bytes position))))
;; Save the file position of the object.
@@ -2927,22 +2891,15 @@ If QUOTED is non-nil, print with quoting; otherwise, print without quoting."
;; position to a file position.
(prog1
(- (position-bytes (point)) (point-min) -1)
- (goto-char (point-max))))))
+ (goto-char end)
+ (set-marker end nil)))))
(defun byte-compile--reify-function (fun)
"Return an expression which will evaluate to a function value FUN.
-FUN should be either a `lambda' value or a `closure' value."
- (pcase-let* (((or (and `(lambda ,args . ,body) (let env nil))
- `(closure ,env ,args . ,body))
- fun)
- (preamble nil)
+FUN should be an interpreted closure."
+ (pcase-let* ((`(closure ,env ,args . ,body) fun)
+ (`(,preamble . ,body) (macroexp-parse-body body))
(renv ()))
- ;; Split docstring and `interactive' form from body.
- (when (stringp (car body))
- (push (pop body) preamble))
- (when (eq (car-safe (car body)) 'interactive)
- (push (pop body) preamble))
- (setq preamble (nreverse preamble))
;; Turn the function's closed vars (if any) into local let bindings.
(dolist (binding env)
(cond
@@ -2964,41 +2921,39 @@ If FORM is a lambda or a macro, byte-compile it as a function."
(fun (if (symbolp form)
(symbol-function form)
form))
- (macro (eq (car-safe fun) 'macro)))
- (if macro
- (setq fun (cdr fun)))
- (prog1
- (cond
- ;; Up until Emacs-24.1, byte-compile silently did nothing
- ;; when asked to compile something invalid. So let's tone
- ;; down the complaint from an error to a simple message for
- ;; the known case where signaling an error causes problems.
- ((compiled-function-p fun)
- (message "Function %s is already compiled"
- (if (symbolp form) form "provided"))
- fun)
- (t
- (let (final-eval)
- (when (or (symbolp form) (eq (car-safe fun) 'closure))
- ;; `fun' is a function *value*, so try to recover its corresponding
- ;; source code.
- (setq lexical-binding (eq (car fun) 'closure))
- (setq fun (byte-compile--reify-function fun))
- (setq final-eval t))
- ;; Expand macros.
- (setq fun (byte-compile-preprocess fun))
- (setq fun (byte-compile-top-level fun nil 'eval))
- (if (symbolp form)
- ;; byte-compile-top-level returns an *expression* equivalent to the
- ;; `fun' expression, so we need to evaluate it, tho normally
- ;; this is not needed because the expression is just a constant
- ;; byte-code object, which is self-evaluating.
- (setq fun (eval fun t)))
- (if final-eval
- (setq fun (eval fun t)))
- (if macro (push 'macro fun))
- (if (symbolp form) (fset form fun))
- fun))))))))
+ (macro (eq (car-safe fun) 'macro))
+ (need-a-value nil))
+ (when macro
+ (setq need-a-value t)
+ (setq fun (cdr fun)))
+ (cond
+ ;; Up until Emacs-24.1, byte-compile silently did nothing
+ ;; when asked to compile something invalid. So let's tone
+ ;; down the complaint from an error to a simple message for
+ ;; the known case where signaling an error causes problems.
+ ((compiled-function-p fun)
+ (message "Function %s is already compiled"
+ (if (symbolp form) form "provided"))
+ fun)
+ (t
+ (when (or (symbolp form) (eq (car-safe fun) 'closure))
+ ;; `fun' is a function *value*, so try to recover its
+ ;; corresponding source code.
+ (when (setq lexical-binding (eq (car-safe fun) 'closure))
+ (setq fun (byte-compile--reify-function fun)))
+ (setq need-a-value t))
+ ;; Expand macros.
+ (setq fun (byte-compile-preprocess fun))
+ (setq fun (byte-compile-top-level fun nil 'eval))
+ (when need-a-value
+ ;; `byte-compile-top-level' returns an *expression* equivalent to
+ ;; the `fun' expression, so we need to evaluate it, tho normally
+ ;; this is not needed because the expression is just a constant
+ ;; byte-code object, which is self-evaluating.
+ (setq fun (eval fun lexical-binding)))
+ (if macro (push 'macro fun))
+ (if (symbolp form) (fset form fun))
+ fun))))))
(defun byte-compile-sexp (sexp)
"Compile and return SEXP."
@@ -3030,6 +2985,14 @@ If FORM is a lambda or a macro, byte-compile it as a function."
(byte-compile-warn-x
arg "repeated variable %s in lambda-list" arg))
(t
+ (when (and lexical-binding
+ (cconv--not-lexical-var-p
+ arg byte-compile-bound-variables)
+ (byte-compile-warning-enabled-p 'lexical arg))
+ (byte-compile-warn-x
+ arg
+ "Lexical argument shadows the dynamic variable %S"
+ arg))
(push arg vars))))
(setq list (cdr list)))))
@@ -3089,27 +3052,32 @@ lambda-expression."
(setq fun (cons 'lambda fun))
(unless (eq 'lambda (car-safe fun))
(error "Not a lambda list: %S" fun)))
- (byte-compile-docstring-style-warn fun)
(byte-compile-check-lambda-list (nth 1 fun))
(let* ((arglist (nth 1 fun))
+ (bare-arglist (byte-run-strip-symbol-positions arglist)) ; for compile-defun.
(arglistvars (byte-run-strip-symbol-positions
(byte-compile-arglist-vars arglist)))
(byte-compile-bound-variables
(append (if (not lexical-binding) arglistvars)
byte-compile-bound-variables))
(body (cdr (cdr fun)))
- (doc (if (stringp (car body))
+ ;; Treat a final string literal as a value, not a doc string.
+ (doc (if (and (cdr body) (stringp (car body)))
(prog1 (car body)
- ;; Discard the doc string
- ;; unless it is the last element of the body.
- (if (cdr body)
- (setq body (cdr body))))))
+ ;; Discard the doc string from the body.
+ (setq body (cdr body)))))
(int (assq 'interactive body))
command-modes)
(when lexical-binding
+ (when arglist
+ ;; byte-compile-make-args-desc lost the args's names,
+ ;; so preserve them in the docstring.
+ (setq doc (help-add-fundoc-usage doc bare-arglist)))
(dolist (var arglistvars)
(when (assq var byte-compile--known-dynamic-vars)
(byte-compile--warn-lexical-dynamic var 'lambda))))
+ (when (stringp doc)
+ (setq doc (byte-compile--docstring doc "" nil 'is-a-value)))
;; Process the interactive spec.
(when int
;; Skip (interactive) if it is in front (the most usual location).
@@ -3153,8 +3121,7 @@ lambda-expression."
(and lexical-binding
(byte-compile-make-lambda-lexenv
arglistvars))
- reserved-csts))
- (bare-arglist (byte-run-strip-symbol-positions arglist))) ; for compile-defun.
+ reserved-csts)))
;; Build the actual byte-coded function.
(cl-assert (eq 'byte-code (car-safe compiled)))
(let ((out
@@ -3166,12 +3133,7 @@ lambda-expression."
;; byte-string, constants-vector, stack depth
(cdr compiled)
;; optionally, the doc string.
- (cond ((and lexical-binding arglist)
- ;; byte-compile-make-args-desc lost the args's names,
- ;; so preserve them in the docstring.
- (list (help-add-fundoc-usage doc bare-arglist)))
- ((or doc int)
- (list doc)))
+ (when (or doc int) (list doc))
;; optionally, the interactive spec (and the modes the
;; command applies to).
(cond
@@ -3393,92 +3355,269 @@ lambda-expression."
;;
(defun byte-compile-form (form &optional for-effect)
(let ((byte-compile--for-effect for-effect))
- (push form byte-compile-form-stack)
- (cond
- ((not (consp form))
- (cond ((or (not (symbolp form)) (macroexp--const-symbol-p form))
- (byte-compile-constant form))
- ((and byte-compile--for-effect byte-compile-delete-errors)
- (setq byte-compile--for-effect nil))
- (t (byte-compile-variable-ref form))))
- ((symbolp (car form))
- (let* ((fn (car form))
- (handler (get fn 'byte-compile))
- (interactive-only
- (or (get fn 'interactive-only)
- (memq fn byte-compile-interactive-only-functions))))
- (when (memq fn '(set symbol-value run-hooks ;; add-to-list
- add-hook remove-hook run-hook-with-args
- run-hook-with-args-until-success
- run-hook-with-args-until-failure))
- (pcase (cdr form)
- (`(',var . ,_)
- (when (memq var byte-compile-lexical-variables)
- (byte-compile-report-error
- (format-message "%s cannot use lexical var `%s'" fn var))))))
- ;; Warn about using obsolete hooks.
- (if (memq fn '(add-hook remove-hook))
- (let ((hook (car-safe (cdr form))))
- (if (eq (car-safe hook) 'quote)
- (byte-compile-check-variable (cadr hook) nil))))
- (when (and (byte-compile-warning-enabled-p 'suspicious)
- (macroexp--const-symbol-p fn))
- (byte-compile-warn-x fn "`%s' called as a function" fn))
- (when (and (byte-compile-warning-enabled-p 'interactive-only fn)
- interactive-only)
- (byte-compile-warn-x fn "`%s' is for interactive use only%s"
- fn
- (cond ((stringp interactive-only)
- (format "; %s"
- (substitute-command-keys
- interactive-only)))
- ((and (symbolp 'interactive-only)
- (not (eq interactive-only t)))
- (format-message "; use `%s' instead."
- interactive-only))
- (t "."))))
- (if (eq (car-safe (symbol-function (car form))) 'macro)
- (byte-compile-report-error
- (format "`%s' defined after use in %S (missing `require' of a library file?)"
- (car form) form)))
- (if (and handler
- ;; Make sure that function exists.
- (and (functionp handler)
- ;; Ignore obsolete byte-compile function used by former
- ;; CL code to handle compiler macros (we do it
- ;; differently now).
- (not (eq handler 'cl-byte-compile-compiler-macro))))
- (funcall handler form)
- (byte-compile-normal-call form))))
- ((and (byte-code-function-p (car form))
- (memq byte-optimize '(t lap)))
- (byte-compile-unfold-bcf form))
- ((and (eq (car-safe (car form)) 'lambda)
- ;; if the form comes out the same way it went in, that's
- ;; because it was malformed, and we couldn't unfold it.
- (not (eq form (setq form (macroexp--unfold-lambda form)))))
- (byte-compile-form form byte-compile--for-effect)
- (setq byte-compile--for-effect nil))
- ((byte-compile-normal-call form)))
- (if byte-compile--for-effect
- (byte-compile-discard))
- (pop byte-compile-form-stack)))
+ (macroexp--with-extended-form-stack form
+ (cond
+ ((not (consp form))
+ (cond ((or (not (symbolp form)) (macroexp--const-symbol-p form))
+ (byte-compile-constant form))
+ ((and byte-compile--for-effect byte-compile-delete-errors)
+ (setq byte-compile--for-effect nil))
+ (t (byte-compile-variable-ref form))))
+ ((symbolp (car form))
+ (let* ((fn (car form))
+ (handler (get fn 'byte-compile))
+ (interactive-only
+ (or (function-get fn 'interactive-only)
+ (memq fn byte-compile-interactive-only-functions))))
+ (when (memq fn '(set symbol-value run-hooks ;; add-to-list
+ add-hook remove-hook run-hook-with-args
+ run-hook-with-args-until-success
+ run-hook-with-args-until-failure))
+ (pcase (cdr form)
+ (`(',var . ,_)
+ (when (and (memq var byte-compile-lexical-variables)
+ (byte-compile-warning-enabled-p 'lexical var))
+ (byte-compile-warn
+ (format-message "%s cannot use lexical var `%s'" fn var))))))
+ ;; Warn about using obsolete hooks.
+ (if (memq fn '(add-hook remove-hook))
+ (let ((hook (car-safe (cdr form))))
+ (if (eq (car-safe hook) 'quote)
+ (byte-compile-check-variable (cadr hook) nil))))
+ (when (and (byte-compile-warning-enabled-p 'suspicious)
+ (macroexp--const-symbol-p fn))
+ (byte-compile-warn-x fn "`%s' called as a function" fn))
+ (when (and (byte-compile-warning-enabled-p 'interactive-only fn)
+ interactive-only)
+ (byte-compile-warn-x fn "`%s' is for interactive use only%s"
+ fn
+ (cond ((stringp interactive-only)
+ (format "; %s"
+ (substitute-command-keys
+ interactive-only)))
+ ((and (symbolp interactive-only)
+ (not (eq interactive-only t)))
+ (format-message "; use `%s' instead."
+ interactive-only))
+ (t "."))))
+ (let ((mutargs (function-get (car form) 'mutates-arguments)))
+ (when mutargs
+ (dolist (idx (if (eq mutargs 'all-but-last)
+ (number-sequence 1 (- (length form) 2))
+ mutargs))
+ (let ((arg (nth idx form)))
+ (when (and (or (and (eq (car-safe arg) 'quote)
+ (consp (nth 1 arg)))
+ (arrayp arg))
+ (byte-compile-warning-enabled-p
+ 'mutate-constant (car form)))
+ (byte-compile-warn-x form "`%s' on constant %s (arg %d)"
+ (car form)
+ (if (consp arg) "list" (type-of arg))
+ idx))))))
+
+ (let ((funargs (function-get (car form) 'funarg-positions)))
+ (dolist (funarg funargs)
+ (let ((arg (if (numberp funarg)
+ (nth funarg form)
+ (cadr (memq funarg form)))))
+ (when (and (eq 'quote (car-safe arg))
+ (eq 'lambda (car-safe (cadr arg))))
+ (byte-compile-warn-x
+ arg "(lambda %s ...) quoted with %s rather than with #%s"
+ (or (nth 1 (cadr arg)) "()")
+ "'" "'"))))) ; avoid styled quotes
+
+ (if (eq (car-safe (symbol-function (car form))) 'macro)
+ (byte-compile-report-error
+ (format-message "`%s' defined after use in %S (missing `require' of a library file?)"
+ (car form) form)))
+
+ (when byte-compile--for-effect
+ (let ((sef (function-get (car form) 'side-effect-free)))
+ (cond
+ ((and sef (or (eq sef 'error-free)
+ byte-compile-delete-errors))
+ ;; This transform is normally done in the Lisp optimizer,
+ ;; so maybe we don't need to bother about it here?
+ (setq form (cons 'progn (cdr form)))
+ (setq handler #'byte-compile-progn))
+ ((and (or sef (function-get (car form) 'important-return-value))
+ ;; Don't warn for arguments to `ignore'.
+ (not (eq byte-compile--for-effect 'for-effect-no-warn))
+ (bytecomp--actually-important-return-value-p form)
+ (byte-compile-warning-enabled-p
+ 'ignored-return-value (car form)))
+ (byte-compile-warn-x
+ (car form)
+ "value from call to `%s' is unused%s"
+ (car form)
+ (cond ((eq (car form) 'mapcar)
+ "; use `mapc' or `dolist' instead")
+ (t "")))))))
+
+ (if (and handler
+ ;; Make sure that function exists.
+ (and (functionp handler)
+ ;; Ignore obsolete byte-compile function used by former
+ ;; CL code to handle compiler macros (we do it
+ ;; differently now).
+ (not (eq handler 'cl-byte-compile-compiler-macro))))
+ (funcall handler form)
+ (byte-compile-normal-call form))))
+ ((and (byte-code-function-p (car form))
+ (memq byte-optimize '(t lap)))
+ (byte-compile-unfold-bcf form))
+ ((byte-compile-normal-call form)))
+ (if byte-compile--for-effect
+ (byte-compile-discard)))))
+
+(defun bytecomp--actually-important-return-value-p (form)
+ "Whether FORM is really a call with a return value that should not go unused.
+This assumes the function has the `important-return-value' property."
+ (cond ((eq (car form) 'sort)
+ ;; For `sort', we only care about non-destructive uses.
+ (and (zerop (% (length form) 2)) ; new-style call
+ (not (plist-get (cddr form) :in-place))))
+ (t t)))
+
+(let ((important-return-value-fns
+ '(
+ ;; These functions are side-effect-free except for the
+ ;; behavior of functions passed as argument.
+ mapcar mapcan mapconcat
+ assoc plist-get plist-member
+
+ ;; It's safe to ignore the value of `nreverse'
+ ;; when used on arrays, but most calls pass lists.
+ nreverse
+
+ sort ; special handling (non-destructive calls only)
+
+ match-data
+
+ ;; Warning about these functions causes some false positives that are
+ ;; laborious to eliminate; see bug#61730.
+ ;;delq delete
+ ;;nconc plist-put
+ )))
+ (dolist (fn important-return-value-fns)
+ (put fn 'important-return-value t)))
+
+(let ((mutating-fns
+ ;; FIXME: Should there be a function declaration for this?
+ ;;
+ ;; (FUNC . ARGS) means that FUNC mutates arguments whose indices are
+ ;; in the list ARGS, starting at 1, or all but the last argument if
+ ;; ARGS is `all-but-last'.
+ '(
+ (setcar 1) (setcdr 1) (aset 1)
+ (nreverse 1)
+ (nconc . all-but-last)
+ (nbutlast 1) (ntake 2)
+ (sort 1)
+ (delq 2) (delete 2)
+ (delete-dups 1) (delete-consecutive-dups 1)
+ (plist-put 1)
+ (assoc-delete-all 2) (assq-delete-all 2) (rassq-delete-all 2)
+ (fillarray 1)
+ (store-substring 1)
+ (clear-string 1)
+
+ (add-text-properties 4) (put-text-property 5) (set-text-properties 4)
+ (remove-text-properties 4) (remove-list-of-text-properties 4)
+ (alter-text-property 5)
+ (add-face-text-property 5) (add-display-text-property 5)
+
+ (cl-delete 2) (cl-delete-if 2) (cl-delete-if-not 2)
+ (cl-delete-duplicates 1)
+ (cl-nsubst 3) (cl-nsubst-if 3) (cl-nsubst-if-not 3)
+ (cl-nsubstitute 3) (cl-nsubstitute-if 3) (cl-nsubstitute-if-not 3)
+ (cl-nsublis 2)
+ (cl-nunion 1 2) (cl-nintersection 1 2) (cl-nset-difference 1 2)
+ (cl-nset-exclusive-or 1 2)
+ (cl-nreconc 1)
+ (cl-sort 1) (cl-stable-sort 1) (cl-merge 2 3)
+ )))
+ (dolist (entry mutating-fns)
+ (put (car entry) 'mutates-arguments (cdr entry))))
+
+;; Record which arguments expect functions, so we can warn when those
+;; are accidentally quoted with ' rather than with #'
+;; The value of the `funarg-positions' property is a list of function
+;; argument positions, starting with 1, and keywords.
+(dolist (f '( funcall apply mapcar mapatoms mapconcat mapc maphash
+ mapcan map-char-table map-keymap map-keymap-internal
+ functionp
+ seq-do seq-do-indexed seq-sort seq-sort-by seq-group-by
+ seq-find seq-count
+ seq-filter seq-reduce seq-remove seq-keep
+ seq-map seq-map-indexed seq-mapn seq-mapcat
+ seq-drop-while seq-take-while
+ seq-some seq-every-p
+ cl-every cl-some
+ cl-mapcar cl-mapcan cl-mapcon cl-mapc cl-mapl cl-maplist
+ ))
+ (put f 'funarg-positions '(1)))
+(dolist (f '( defalias fset sort
+ replace-regexp-in-string
+ add-hook remove-hook advice-remove advice--remove-function
+ global-set-key local-set-key keymap-global-set keymap-local-set
+ set-process-filter set-process-sentinel
+ ))
+ (put f 'funarg-positions '(2)))
+(dolist (f '( assoc assoc-default assoc-delete-all
+ plist-get plist-member
+ advice-add define-key keymap-set
+ run-at-time run-with-idle-timer run-with-timer
+ seq-contains seq-contains-p seq-set-equal-p
+ seq-position seq-positions seq-uniq
+ seq-union seq-intersection seq-difference))
+ (put f 'funarg-positions '(3)))
+(dolist (f '( cl-find cl-member cl-assoc cl-rassoc cl-position cl-count
+ cl-remove cl-delete
+ cl-subst cl-nsubst
+ cl-substitute cl-nsubstitute
+ cl-remove-duplicates cl-delete-duplicates
+ cl-union cl-nunion cl-intersection cl-nintersection
+ cl-set-difference cl-nset-difference
+ cl-set-exclusive-or cl-nset-exclusive-or
+ cl-nsublis
+ cl-search
+ ))
+ (put f 'funarg-positions '(:test :test-not :key)))
+(dolist (f '( cl-find-if cl-find-if-not cl-member-if cl-member-if-not
+ cl-assoc-if cl-assoc-if-not cl-rassoc-if cl-rassoc-if-not
+ cl-position-if cl-position-if-not cl-count-if cl-count-if-not
+ cl-remove-if cl-remove-if-not cl-delete-if cl-delete-if-not
+ cl-reduce cl-adjoin
+ cl-subsetp
+ ))
+ (put f 'funarg-positions '(1 :key)))
+(dolist (f '( cl-subst-if cl-subst-if-not cl-nsubst-if cl-nsubst-if-not
+ cl-substitute-if cl-substitute-if-not
+ cl-nsubstitute-if cl-nsubstitute-if-not
+ cl-sort cl-stable-sort
+ ))
+ (put f 'funarg-positions '(2 :key)))
+(dolist (fa '((plist-put 4) (alist-get 5) (add-to-list 5)
+ (cl-merge 4 :key)
+ (custom-declare-variable :set :get :initialize :safe)
+ (make-process :filter :sentinel)
+ (make-network-process :filter :sentinel)
+ (all-completions 2 3) (try-completion 2 3) (test-completion 2 3)
+ (completing-read 2 3)
+ ))
+ (put (car fa) 'funarg-positions (cdr fa)))
+
(defun byte-compile-normal-call (form)
(when (and (symbolp (car form))
(byte-compile-warning-enabled-p 'callargs (car form)))
- (if (memq (car form)
- '(custom-declare-group custom-declare-variable
- custom-declare-face))
- (byte-compile-nogroup-warn form))
(byte-compile-callargs-warn form))
(if byte-compile-generate-call-tree
(byte-compile-annotate-call-tree form))
- (when (and byte-compile--for-effect (eq (car form) 'mapcar)
- (byte-compile-warning-enabled-p 'mapcar 'mapcar))
- (byte-compile-warn-x
- (car form)
- "`mapcar' called for effect; use `mapc' or `dolist' instead"))
+
(byte-compile-push-constant (car form))
(mapc 'byte-compile-form (cdr form)) ; wasteful, but faster.
(byte-compile-out 'byte-call (length (cdr form))))
@@ -3560,7 +3699,6 @@ lambda-expression."
(alen (length (cdr form)))
(dynbinds ())
lap)
- (fetch-bytecode fun)
(setq lap (byte-decompile-bytecode-1 (aref fun 1) (aref fun 2) t))
;; optimized switch bytecode makes it impossible to guess the correct
;; `byte-compile-depth', which can result in incorrect inlined code.
@@ -3736,7 +3874,7 @@ If it is nil, then the handler is \"byte-compile-SYMBOL.\""
'((0 . byte-compile-no-args)
(1 . byte-compile-one-arg)
(2 . byte-compile-two-args)
- (2-and . byte-compile-and-folded)
+ (2-cmp . byte-compile-cmp)
(3 . byte-compile-three-args)
(0-1 . byte-compile-zero-or-one-arg)
(1-2 . byte-compile-one-or-two-args)
@@ -3815,11 +3953,12 @@ If it is nil, then the handler is \"byte-compile-SYMBOL.\""
(byte-defop-compiler cons 2)
(byte-defop-compiler aref 2)
(byte-defop-compiler set 2)
-(byte-defop-compiler (= byte-eqlsign) 2-and)
-(byte-defop-compiler (< byte-lss) 2-and)
-(byte-defop-compiler (> byte-gtr) 2-and)
-(byte-defop-compiler (<= byte-leq) 2-and)
-(byte-defop-compiler (>= byte-geq) 2-and)
+(byte-defop-compiler fset 2)
+(byte-defop-compiler (= byte-eqlsign) 2-cmp)
+(byte-defop-compiler (< byte-lss) 2-cmp)
+(byte-defop-compiler (> byte-gtr) 2-cmp)
+(byte-defop-compiler (<= byte-leq) 2-cmp)
+(byte-defop-compiler (>= byte-geq) 2-cmp)
(byte-defop-compiler get 2)
(byte-defop-compiler nth 2)
(byte-defop-compiler substring 1-3)
@@ -3883,18 +4022,20 @@ If it is nil, then the handler is \"byte-compile-SYMBOL.\""
(byte-compile-form (nth 2 form))
(byte-compile-out (get (car form) 'byte-opcode) 0)))
-(defun byte-compile-and-folded (form)
- "Compile calls to functions like `<='.
-These implicitly `and' together a bunch of two-arg bytecodes."
- (let ((l (length form)))
- (cond
- ((< l 3) (byte-compile-form `(progn ,(nth 1 form) t)))
- ((= l 3) (byte-compile-two-args form))
- ;; Don't use `cl-every' here (see comment where we require cl-lib).
- ((not (memq nil (mapcar #'macroexp-copyable-p (nthcdr 2 form))))
- (byte-compile-form `(and (,(car form) ,(nth 1 form) ,(nth 2 form))
- (,(car form) ,@(nthcdr 2 form)))))
- (t (byte-compile-normal-call form)))))
+(defun byte-compile-cmp (form)
+ "Compile calls to numeric comparisons such as `<', `=' etc."
+ ;; Lisp-level transforms should already have reduced valid calls to 2 args.
+ (if (not (= (length form) 3))
+ (byte-compile-subr-wrong-args form "1 or more")
+ (byte-compile-two-args
+ (if (macroexp-const-p (nth 1 form))
+ ;; First argument is constant: flip it so that the constant
+ ;; is last, which may allow more lapcode optimizations.
+ (let* ((op (car form))
+ (flipped-op (cdr (assq op '((< . >) (<= . >=)
+ (> . <) (>= . <=) (= . =))))))
+ (list flipped-op (nth 2 form) (nth 1 form)))
+ form))))
(defun byte-compile-three-args (form)
(if (not (= (length form) 4))
@@ -4049,9 +4190,15 @@ This function is never called when `lexical-binding' is nil."
(byte-compile-constant 1)
(byte-compile-out (get '* 'byte-opcode) 0))
(3
- (byte-compile-form (nth 1 form))
- (byte-compile-form (nth 2 form))
- (byte-compile-out (get (car form) 'byte-opcode) 0))
+ (let ((arg1 (nth 1 form))
+ (arg2 (nth 2 form)))
+ (when (and (memq (car form) '(+ *))
+ (macroexp-const-p arg1))
+ ;; Put constant argument last for better LAP optimization.
+ (cl-rotatef arg1 arg2))
+ (byte-compile-form arg1)
+ (byte-compile-form arg2)
+ (byte-compile-out (get (car form) 'byte-opcode) 0)))
(_
;; >2 args: compile as a single function call.
(byte-compile-normal-call form))))
@@ -4066,12 +4213,8 @@ This function is never called when `lexical-binding' is nil."
;; more complicated compiler macros
-(byte-defop-compiler char-before)
-(byte-defop-compiler backward-char)
-(byte-defop-compiler backward-word)
(byte-defop-compiler list)
(byte-defop-compiler concat)
-(byte-defop-compiler fset)
(byte-defop-compiler (indent-to-column byte-indent-to) byte-compile-indent-to)
(byte-defop-compiler indent-to)
(byte-defop-compiler insert)
@@ -4080,40 +4223,6 @@ This function is never called when `lexical-binding' is nil."
(byte-defop-compiler (/ byte-quo) byte-compile-quo)
(byte-defop-compiler nconc)
-;; Is this worth it? Both -before and -after are written in C.
-(defun byte-compile-char-before (form)
- (cond ((or (= 1 (length form))
- (and (= 2 (length form)) (not (nth 1 form))))
- (byte-compile-form '(char-after (1- (point)))))
- ((= 2 (length form))
- (byte-compile-form (list 'char-after (if (numberp (nth 1 form))
- (1- (nth 1 form))
- `(1- (or ,(nth 1 form)
- (point)))))))
- (t (byte-compile-subr-wrong-args form "0-1"))))
-
-;; backward-... ==> forward-... with negated argument.
-;; Is this worth it? Both -backward and -forward are written in C.
-(defun byte-compile-backward-char (form)
- (cond ((or (= 1 (length form))
- (and (= 2 (length form)) (not (nth 1 form))))
- (byte-compile-form '(forward-char -1)))
- ((= 2 (length form))
- (byte-compile-form (list 'forward-char (if (numberp (nth 1 form))
- (- (nth 1 form))
- `(- (or ,(nth 1 form) 1))))))
- (t (byte-compile-subr-wrong-args form "0-1"))))
-
-(defun byte-compile-backward-word (form)
- (cond ((or (= 1 (length form))
- (and (= 2 (length form)) (not (nth 1 form))))
- (byte-compile-form '(forward-word -1)))
- ((= 2 (length form))
- (byte-compile-form (list 'forward-word (if (numberp (nth 1 form))
- (- (nth 1 form))
- `(- (or ,(nth 1 form) 1))))))
- (t (byte-compile-subr-wrong-args form "0-1"))))
-
(defun byte-compile-list (form)
(let ((count (length (cdr form))))
(cond ((= count 0)
@@ -4168,26 +4277,6 @@ This function is never called when `lexical-binding' is nil."
(byte-compile-form (car form))
(byte-compile-out 'byte-nconc 0))))))
-(defun byte-compile-fset (form)
- ;; warn about forms like (fset 'foo '(lambda () ...))
- ;; (where the lambda expression is non-trivial...)
- (let ((fn (nth 2 form))
- body)
- (if (and (eq (car-safe fn) 'quote)
- (eq (car-safe (setq fn (nth 1 fn))) 'lambda))
- (progn
- (setq body (cdr (cdr fn)))
- (if (stringp (car body)) (setq body (cdr body)))
- (if (eq 'interactive (car-safe (car body))) (setq body (cdr body)))
- (if (and (consp (car body))
- (not (eq 'byte-code (car (car body)))))
- (byte-compile-warn-x
- (nth 2 form)
- "A quoted lambda form is the second argument of `fset'. This is probably
- not what you want, as that lambda cannot be compiled. Consider using
- the syntax #'(lambda (...) ...) instead.")))))
- (byte-compile-two-args form))
-
;; (function foo) must compile like 'foo, not like (symbol-function 'foo).
;; Otherwise it will be incompatible with the interpreter,
;; and (funcall (function foo)) will lose with autoloads.
@@ -4310,7 +4399,8 @@ This function is never called when `lexical-binding' is nil."
(defun byte-compile-ignore (form)
(dolist (arg (cdr form))
- (byte-compile-form arg t))
+ ;; Compile each argument for-effect but suppress unused-value warnings.
+ (byte-compile-form arg 'for-effect-no-warn))
(byte-compile-form nil))
;; Return the list of items in CONDITION-PARAM that match PRED-LIST.
@@ -4571,6 +4661,7 @@ Return (TAIL VAR TEST CASES), where:
(if switch-prefix
(progn
(byte-compile-cond-jump-table (cdr switch-prefix) donetag)
+ (setq clause nil)
(setq clauses (car switch-prefix)))
(setq clause (car clauses))
(cond ((or (eq (car clause) t)
@@ -4835,6 +4926,15 @@ binding slots have been popped."
(dolist (clause (reverse clauses))
(let ((condition (nth 1 clause)))
+ (when (and (eq (car-safe condition) 'quote)
+ (cdr condition) (null (cddr condition)))
+ (byte-compile-warn-x
+ condition "`condition-case' condition should not be quoted: %S"
+ condition))
+ (when (and (consp condition) (memq :success condition))
+ (byte-compile-warn-x
+ condition
+ "`:success' must be the first element of a `condition-case' handler"))
(unless (consp condition) (setq condition (list condition)))
(dolist (c condition)
(unless (and c (symbolp c))
@@ -4925,49 +5025,49 @@ binding slots have been popped."
(push (nth 1 (nth 1 form)) byte-compile-global-not-obsolete-vars))
(byte-compile-normal-call form))
-(defun byte-compile-defvar (form)
- ;; This is not used for file-level defvar/consts.
- (when (and (symbolp (nth 1 form))
- (not (string-match "[-*/:$]" (symbol-name (nth 1 form))))
- (byte-compile-warning-enabled-p 'lexical (nth 1 form)))
- (byte-compile-warn-x
- (nth 1 form)
- "global/dynamic var `%s' lacks a prefix"
- (nth 1 form)))
- (byte-compile-docstring-style-warn form)
- (let ((fun (nth 0 form))
- (var (nth 1 form))
- (value (nth 2 form))
- (string (nth 3 form)))
- (when (or (> (length form) 4)
- (and (eq fun 'defconst) (null (cddr form))))
- (let ((ncall (length (cdr form))))
- (byte-compile-warn-x
- fun
- "`%s' called with %d argument%s, but %s %s"
- fun ncall
- (if (= 1 ncall) "" "s")
- (if (< ncall 2) "requires" "accepts only")
- "2-3")))
- (push var byte-compile-bound-variables)
+(defun byte-compile-defvar (form &optional toplevel)
+ (let* ((fun (nth 0 form))
+ (var (nth 1 form))
+ (value (nth 2 form))
+ (string (nth 3 form)))
+ (byte-compile--declare-var var (not toplevel))
(if (eq fun 'defconst)
(push var byte-compile-const-variables))
- (when (and string (not (stringp string)))
+ (cond
+ ((stringp string)
+ (setq string (byte-compile--docstring string fun var 'is-a-value)))
+ (string
(byte-compile-warn-x
string
"third arg to `%s %s' is not a string: %s"
- fun var string))
- ;; Delegate the actual work to the function version of the
- ;; special form, named with a "-1" suffix.
- (byte-compile-form-do-effect
- (cond
- ((eq fun 'defconst) `(defconst-1 ',var ,@(nthcdr 2 form)))
- ((not (cddr form)) `',var) ; A simple (defvar foo) just returns foo.
- (t `(defvar-1 ',var
- ;; Don't eval `value' if `defvar' wouldn't eval it either.
- ,(if (macroexp-const-p value) value
- `(if (boundp ',var) nil ,value))
- ,@(nthcdr 3 form)))))))
+ fun var string)))
+ (if toplevel
+ ;; At top-level we emit calls to defvar/defconst.
+ (if (and (null (cddr form)) ;No `value' provided.
+ (eq (car form) 'defvar)) ;Just a declaration.
+ nil
+ (let ((tail (nthcdr 4 form)))
+ (when (or tail string) (push string tail))
+ (when (cddr form)
+ (push (if (not (consp value)) value
+ (byte-compile-top-level value nil 'file))
+ tail))
+ `(,fun ,var ,@tail)))
+ ;; At non-top-level, since there is no byte code for
+ ;; defvar/defconst, we delegate the actual work to the function
+ ;; version of the special form, named with a "-1" suffix.
+ (byte-compile-form-do-effect
+ (cond
+ ((eq fun 'defconst)
+ `(defconst-1 ',var ,@(byte-compile--list-with-n
+ (nthcdr 2 form) 1 (macroexp-quote string))))
+ ((not (cddr form)) `',var) ; A simple (defvar foo) just returns foo.
+ (t `(defvar-1 ',var
+ ;; Don't eval `value' if `defvar' wouldn't eval it either.
+ ,(if (macroexp-const-p value) value
+ `(if (boundp ',var) nil ,value))
+ ,@(byte-compile--list-with-n
+ (nthcdr 3 form) 0 (macroexp-quote string)))))))))
(defun byte-compile-autoload (form)
(and (macroexp-const-p (nth 1 form))
@@ -4993,14 +5093,6 @@ binding slots have been popped."
;; For the compilation itself, we could largely get rid of this hunk-handler,
;; if it weren't for the fact that we need to figure out when a defalias
;; defines a macro, so as to add it to byte-compile-macro-environment.
- ;;
- ;; FIXME: we also use this hunk-handler to implement the function's
- ;; dynamic docstring feature (via byte-compile-file-form-defmumble).
- ;; We should probably actually implement it (more elegantly) in
- ;; byte-compile-lambda so it applies to all lambdas. We did it here
- ;; so the resulting .elc format was recognizable by make-docfile,
- ;; but since then we stopped using DOC for the docstrings of
- ;; preloaded elc files so that obstacle is gone.
(let ((byte-compile-free-references nil)
(byte-compile-free-assignments nil))
(pcase form
@@ -5009,7 +5101,11 @@ binding slots have been popped."
;; - `arg' is the expression to which it is defined.
;; - `rest' is the rest of the arguments.
(`(,_ ',name ,arg . ,rest)
- (byte-compile-docstring-style-warn form)
+ (let ((doc (car rest)))
+ (when (stringp doc)
+ (setq rest (byte-compile--list-with-n
+ rest 0
+ (byte-compile--docstring doc (nth 0 form) name)))))
(pcase-let*
;; `macro' is non-nil if it defines a macro.
;; `fun' is the function part of `arg' (defaults to `arg').
@@ -5055,7 +5151,10 @@ binding slots have been popped."
(defun byte-compile-suppressed-warnings (form)
(let ((byte-compile--suppressed-warnings
(append (cadadr form) byte-compile--suppressed-warnings)))
- (byte-compile-form (macroexp-progn (cddr form)))))
+ ;; Propagate the for-effect mode explicitly so that warnings about
+ ;; ignored return values can be detected and suppressed correctly.
+ (byte-compile-form (macroexp-progn (cddr form)) byte-compile--for-effect)
+ (setq byte-compile--for-effect nil)))
;; Warn about misuses of make-variable-buffer-local.
(byte-defop-compiler-1 make-variable-buffer-local
@@ -5080,6 +5179,194 @@ binding slots have been popped."
(pcase form (`(,_ ',var) (byte-compile--declare-var var)))
(byte-compile-normal-call form))
+;; Warn about mistakes in `defcustom', `defface', `defgroup', `define-widget'
+
+(defvar bytecomp--cus-function)
+(defvar bytecomp--cus-name)
+
+(defun bytecomp--cus-warn (form format &rest args)
+ "Emit a warning about a `defcustom' type.
+FORM is used to provide location, `bytecomp--cus-function' and
+`bytecomp--cus-name' for context."
+ (let* ((actual-fun (or (cdr (assq bytecomp--cus-function
+ '((custom-declare-group . defgroup)
+ (custom-declare-face . defface)
+ (custom-declare-variable . defcustom))))
+ bytecomp--cus-function))
+ (prefix (format "in %s%s: "
+ actual-fun
+ (if bytecomp--cus-name
+ (format " for `%s'" bytecomp--cus-name)
+ ""))))
+ (apply #'byte-compile-warn-x form (concat prefix format) args)))
+
+(defun bytecomp--check-cus-type (type)
+ "Warn about common mistakes in the `defcustom' type TYPE."
+ (let ((invalid-types
+ '(
+ ;; Lisp type predicates, often confused with customization types:
+ functionp numberp integerp fixnump natnump floatp booleanp
+ characterp listp stringp consp vectorp symbolp keywordp
+ hash-table-p facep
+ ;; other mistakes occasionally seen (oh yes):
+ or and nil t
+ interger intger lits bool boolen constant filename
+ kbd any list-of auto
+ ;; from botched backquoting
+ \, \,@ \`
+ )))
+ (cond
+ ((consp type)
+ (let* ((head (car type))
+ (tail (cdr type)))
+ (while (and (keywordp (car tail)) (cdr tail))
+ (setq tail (cddr tail)))
+ (cond
+ ((plist-member (cdr type) :convert-widget) nil)
+ ((let ((tl tail))
+ (and (not (keywordp (car tail)))
+ (progn
+ (while (and tl (not (keywordp (car tl))))
+ (setq tl (cdr tl)))
+ (and tl
+ (progn
+ (bytecomp--cus-warn
+ tl "misplaced %s keyword in `%s' type" (car tl) head)
+ t))))))
+ ((memq head '(choice radio))
+ (unless tail
+ (bytecomp--cus-warn type "`%s' without any types inside" head))
+ (let ((clauses tail)
+ (constants nil)
+ (tags nil))
+ (while clauses
+ (let* ((ty (car clauses))
+ (ty-head (car-safe ty)))
+ (when (and (eq ty-head 'other) (cdr clauses))
+ (bytecomp--cus-warn ty "`other' not last in `%s'" head))
+ (when (memq ty-head '(const other))
+ (let ((ty-tail (cdr ty))
+ (val nil))
+ (while (and (keywordp (car ty-tail)) (cdr ty-tail))
+ (when (eq (car ty-tail) :value)
+ (setq val (cadr ty-tail)))
+ (setq ty-tail (cddr ty-tail)))
+ (when ty-tail
+ (setq val (car ty-tail)))
+ (when (member val constants)
+ (bytecomp--cus-warn
+ ty "duplicated value in `%s': `%S'" head val))
+ (push val constants)))
+ (let ((tag (and (consp ty) (plist-get (cdr ty) :tag))))
+ (when (stringp tag)
+ (when (member tag tags)
+ (bytecomp--cus-warn
+ ty "duplicated :tag string in `%s': %S" head tag))
+ (push tag tags)))
+ (bytecomp--check-cus-type ty))
+ (setq clauses (cdr clauses)))))
+ ((eq head 'cons)
+ (unless (= (length tail) 2)
+ (bytecomp--cus-warn
+ type "`cons' requires 2 type specs, found %d" (length tail)))
+ (dolist (ty tail)
+ (bytecomp--check-cus-type ty)))
+ ((memq head '(list group vector set repeat))
+ (unless tail
+ (bytecomp--cus-warn type "`%s' without type specs" head))
+ (dolist (ty tail)
+ (bytecomp--check-cus-type ty)))
+ ((memq head '(alist plist))
+ (let ((key-tag (memq :key-type (cdr type)))
+ (value-tag (memq :value-type (cdr type))))
+ (when key-tag
+ (bytecomp--check-cus-type (cadr key-tag)))
+ (when value-tag
+ (bytecomp--check-cus-type (cadr value-tag)))))
+ ((memq head '(const other))
+ (let* ((value-tag (memq :value (cdr type)))
+ (n (length tail))
+ (val (car tail)))
+ (cond
+ ((or (> n 1) (and value-tag tail))
+ (bytecomp--cus-warn type "`%s' with too many values" head))
+ (value-tag
+ (setq val (cadr value-tag)))
+ ;; ;; This is a useful check but it results in perhaps
+ ;; ;; a bit too many complaints.
+ ;; ((null tail)
+ ;; (bytecomp--cus-warn
+ ;; type "`%s' without value is implicitly nil" head))
+ )
+ (when (memq (car-safe val) '(quote function))
+ (bytecomp--cus-warn type "`%s' with quoted value: %S" head val))))
+ ((eq head 'quote)
+ (bytecomp--cus-warn type "type should not be quoted: %s" (cadr type)))
+ ((memq head invalid-types)
+ (bytecomp--cus-warn type "`%s' is not a valid type" head))
+ ((or (not (symbolp head)) (keywordp head))
+ (bytecomp--cus-warn type "irregular type `%S'" head))
+ )))
+ ((or (not (symbolp type)) (keywordp type))
+ (bytecomp--cus-warn type "irregular type `%S'" type))
+ ((memq type '( list cons group vector choice radio const other
+ function-item variable-item set repeat restricted-sexp))
+ (bytecomp--cus-warn type "`%s' without arguments" type))
+ ((memq type invalid-types)
+ (bytecomp--cus-warn type "`%s' is not a valid type" type))
+ )))
+
+;; Unified handler for multiple functions with similar arguments:
+;; (NAME SOMETHING DOC KEYWORD-ARGS...)
+(byte-defop-compiler-1 define-widget bytecomp--custom-declare)
+(byte-defop-compiler-1 custom-declare-group bytecomp--custom-declare)
+(byte-defop-compiler-1 custom-declare-face bytecomp--custom-declare)
+(byte-defop-compiler-1 custom-declare-variable bytecomp--custom-declare)
+(defun bytecomp--custom-declare (form)
+ (when (>= (length form) 4)
+ (let* ((name-arg (nth 1 form))
+ (name (and (eq (car-safe name-arg) 'quote)
+ (symbolp (nth 1 name-arg))
+ (nth 1 name-arg)))
+ (keyword-args (nthcdr 4 form))
+ (fun (car form))
+ (bytecomp--cus-function fun)
+ (bytecomp--cus-name name))
+
+ ;; Check :type
+ (when (memq fun '(custom-declare-variable define-widget))
+ (let ((type-tag (memq :type keyword-args)))
+ (if (null type-tag)
+ ;; :type only mandatory for `defcustom'
+ (when (eq fun 'custom-declare-variable)
+ (bytecomp--cus-warn form "missing :type keyword parameter"))
+ (let ((dup-type (memq :type (cdr type-tag))))
+ (when dup-type
+ (bytecomp--cus-warn
+ dup-type "duplicated :type keyword argument")))
+ (let ((type-arg (cadr type-tag)))
+ (when (or (null type-arg)
+ (eq (car-safe type-arg) 'quote))
+ (bytecomp--check-cus-type (cadr type-arg)))))))
+
+ ;; Check :group
+ (when (cond
+ ((memq fun '(custom-declare-variable custom-declare-face))
+ (not byte-compile-current-group))
+ ((eq fun 'custom-declare-group)
+ (not (eq name 'emacs))))
+ (unless (plist-get keyword-args :group)
+ (bytecomp--cus-warn form "fails to specify containing group")))
+
+ ;; Update current group
+ (when (and name
+ byte-compile-current-file ; only when compiling a whole file
+ (eq fun 'custom-declare-group))
+ (setq byte-compile-current-group name))))
+
+ (byte-compile-normal-call form))
+
+
(put 'function-put 'byte-hunk-handler 'byte-compile-define-symbol-prop)
(put 'define-symbol-prop 'byte-hunk-handler 'byte-compile-define-symbol-prop)
(defun byte-compile-define-symbol-prop (form)
@@ -5261,23 +5548,14 @@ invoked interactively."
(if (null f)
" <top level>";; shouldn't insert nil then, actually -sk
" <not defined>"))
- ((subrp (setq f (symbol-function f)))
- " <subr>")
- ((symbolp f)
+ ((symbolp (setq f (symbol-function f))) ;; An alias.
(format " ==> %s" f))
- ((byte-code-function-p f)
- "<compiled function>")
((not (consp f))
- "<malformed function>")
+ (format " <%s>" (type-of f)))
((eq 'macro (car f))
- (if (or (compiled-function-p (cdr f))
- ;; FIXME: Can this still happen?
- (assq 'byte-code (cdr (cdr (cdr f)))))
+ (if (compiled-function-p (cdr f))
" <compiled macro>"
" <macro>"))
- ((assq 'byte-code (cdr (cdr f)))
- ;; FIXME: Can this still happen?
- "<compiled lambda>")
((eq 'lambda (car f))
"<function>")
(t "???"))
@@ -5487,6 +5765,183 @@ and corresponding effects."
(eval form)
form)))
+;; Report comma operator used outside of backquote.
+;; Inside backquote, backquote will transform it before it gets here.
+
+(put '\, 'compiler-macro #'bytecomp--report-comma)
+(defun bytecomp--report-comma (form &rest _ignore)
+ (macroexp-warn-and-return
+ (format-message "`%s' called -- perhaps used not within backquote"
+ (car form))
+ form (list 'suspicious (car form)) t))
+
+;; Check for (in)comparable constant values in calls to `eq', `memq' etc.
+
+(defun bytecomp--dodgy-eq-arg-p (x number-ok)
+ "Whether X is a bad argument to `eq' (or `eql' if NUMBER-OK is non-nil)."
+ (pcase x
+ ((or `(quote ,(pred consp)) `(function (lambda . ,_))) t)
+ ((or (pred consp) (pred symbolp)) nil)
+ ((pred integerp)
+ (not (or (<= -536870912 x 536870911) number-ok)))
+ ((pred floatp) (not number-ok))
+ (_ t)))
+
+(defun bytecomp--value-type-description (x)
+ (cond
+ ((proper-list-p x) "list")
+ ((recordp x) "record")
+ (t (symbol-name (type-of x)))))
+
+(defun bytecomp--arg-type-description (x)
+ (pcase x
+ (`(function (lambda . ,_)) "function")
+ (`(quote . ,val) (bytecomp--value-type-description val))
+ (_ (bytecomp--value-type-description x))))
+
+(defun bytecomp--warn-dodgy-eq-arg (form type parenthesis)
+ (macroexp-warn-and-return
+ (format-message "`%s' called with literal %s that may never match (%s)"
+ (car form) type parenthesis)
+ form (list 'suspicious (car form)) t))
+
+(defun bytecomp--check-eq-args (form &optional a b &rest _ignore)
+ (let* ((number-ok (eq (car form) 'eql))
+ (bad-arg (cond ((bytecomp--dodgy-eq-arg-p a number-ok) 1)
+ ((bytecomp--dodgy-eq-arg-p b number-ok) 2))))
+ (if bad-arg
+ (bytecomp--warn-dodgy-eq-arg
+ form
+ (bytecomp--arg-type-description (nth bad-arg form))
+ (format "arg %d" bad-arg))
+ form)))
+
+(put 'eq 'compiler-macro #'bytecomp--check-eq-args)
+(put 'eql 'compiler-macro #'bytecomp--check-eq-args)
+
+(defun bytecomp--check-memq-args (form &optional elem list &rest _ignore)
+ (let* ((fn (car form))
+ (number-ok (eq fn 'memql)))
+ (cond
+ ((bytecomp--dodgy-eq-arg-p elem number-ok)
+ (bytecomp--warn-dodgy-eq-arg
+ form (bytecomp--arg-type-description elem) "arg 1"))
+ ((and (consp list) (eq (car list) 'quote)
+ (proper-list-p (cadr list)))
+ (named-let loop ((elts (cadr list)) (i 1))
+ (if elts
+ (let* ((elt (car elts))
+ (x (cond ((eq fn 'assq) (car-safe elt))
+ ((eq fn 'rassq) (cdr-safe elt))
+ (t elt))))
+ (if (or (symbolp x)
+ (and (integerp x)
+ (or (<= -536870912 x 536870911) number-ok))
+ (and (floatp x) number-ok))
+ (loop (cdr elts) (1+ i))
+ (bytecomp--warn-dodgy-eq-arg
+ form (bytecomp--value-type-description x)
+ (format "element %d of arg 2" i))))
+ form)))
+ (t form))))
+
+(put 'memq 'compiler-macro #'bytecomp--check-memq-args)
+(put 'memql 'compiler-macro #'bytecomp--check-memq-args)
+(put 'assq 'compiler-macro #'bytecomp--check-memq-args)
+(put 'rassq 'compiler-macro #'bytecomp--check-memq-args)
+(put 'remq 'compiler-macro #'bytecomp--check-memq-args)
+(put 'delq 'compiler-macro #'bytecomp--check-memq-args)
+
+;; Implement `char-before', `backward-char' and `backward-word' in
+;; terms of `char-after', `forward-char' and `forward-word' which have
+;; their own byte-ops.
+
+(put 'char-before 'compiler-macro #'bytecomp--char-before)
+(defun bytecomp--char-before (form &optional arg &rest junk-args)
+ (if junk-args
+ form ; arity error
+ `(char-after (1- (or ,arg (point))))))
+
+(put 'backward-char 'compiler-macro #'bytecomp--backward-char)
+(defun bytecomp--backward-char (form &optional arg &rest junk-args)
+ (if junk-args
+ form ; arity error
+ `(forward-char (- (or ,arg 1)))))
+
+(put 'backward-word 'compiler-macro #'bytecomp--backward-word)
+(defun bytecomp--backward-word (form &optional arg &rest junk-args)
+ (if junk-args
+ form ; arity error
+ `(forward-word (- (or ,arg 1)))))
+
+(defun bytecomp--check-keyword-args (form arglist allowed-keys required-keys)
+ (let ((fun (car form)))
+ (cl-flet ((missing (form keyword)
+ (byte-compile-warn-x
+ form
+ "`%S´ called without required keyword argument %S"
+ fun keyword))
+ (unrecognized (form keyword)
+ (byte-compile-warn-x
+ form
+ "`%S´ called with unknown keyword argument %S"
+ fun keyword))
+ (duplicate (form keyword)
+ (byte-compile-warn-x
+ form
+ "`%S´ called with repeated keyword argument %S"
+ fun keyword))
+ (missing-val (form keyword)
+ (byte-compile-warn-x
+ form
+ "missing value for keyword argument %S"
+ keyword)))
+ (let* ((seen '())
+ (l arglist))
+ (while (consp l)
+ (let ((key (car l)))
+ (cond ((and (keywordp key) (memq key allowed-keys))
+ (cond ((memq key seen)
+ (duplicate l key))
+ (t
+ (push key seen))))
+ (t (unrecognized l key)))
+ (when (null (cdr l))
+ (missing-val l key)))
+ (setq l (cddr l)))
+ (dolist (key required-keys)
+ (unless (memq key seen)
+ (missing form key))))))
+ form)
+
+(put 'make-process 'compiler-macro
+ #'(lambda (form &rest args)
+ (bytecomp--check-keyword-args
+ form args
+ '(:name
+ :buffer :command :coding :noquery :stop :connection-type
+ :filter :sentinel :stderr :file-handler)
+ '(:name :command))))
+
+(put 'make-pipe-process 'compiler-macro
+ #'(lambda (form &rest args)
+ (bytecomp--check-keyword-args
+ form args
+ '(:name :buffer :coding :noquery :stop :filter :sentinel)
+ '(:name))))
+
+(put 'make-network-process 'compiler-macro
+ #'(lambda (form &rest args)
+ (bytecomp--check-keyword-args
+ form args
+ '(:name
+ :buffer :host :service :type :family :local :remote :coding
+ :nowait :noquery :stop :filter :filter-multibyte :sentinel
+ :log :plist :tls-parameters :server :broadcast :dontroute
+ :keepalive :linger :oobinline :priority :reuseaddr :bindtodevice
+ :use-external-socket)
+ '(:name :service))))
+
(provide 'byte-compile)
(provide 'bytecomp)
diff --git a/lisp/emacs-lisp/cconv.el b/lisp/emacs-lisp/cconv.el
index cf29b13fc13..4ff47971351 100644
--- a/lisp/emacs-lisp/cconv.el
+++ b/lisp/emacs-lisp/cconv.el
@@ -236,9 +236,9 @@ Returns a form where all lambdas don't have any free variables."
(not (intern-soft var))
(eq ?_ (aref (symbol-name var) 0)))
(let ((suggestions (help-uni-confusable-suggestions (symbol-name var))))
- (format "Unused lexical %s `%S'%s"
- varkind (bare-symbol var)
- (if suggestions (concat "\n " suggestions) "")))))
+ (format-message "Unused lexical %s `%S'%s"
+ varkind (bare-symbol var)
+ (if suggestions (concat "\n " suggestions) "")))))
(define-inline cconv--var-classification (binder form)
(inline-quote
@@ -328,279 +328,313 @@ places where they originally did not directly appear."
;; to find the number of a specific variable in the environment vector,
;; so we never touch it(unless we enter to the other closure).
;;(if (listp form) (print (car form)) form)
- (pcase form
- (`(,(and letsym (or 'let* 'let)) ,binders . ,body)
+ (macroexp--with-extended-form-stack form
+ (pcase form
+ (`(,(and letsym (or 'let* 'let)) ,binders . ,body)
; let and let* special forms
- (let ((binders-new '())
- (new-env env)
- (new-extend extend))
-
- (dolist (binder binders)
- (let* ((value nil)
- (var (if (not (consp binder))
- (prog1 binder (setq binder (list binder)))
- (when (cddr binder)
- (byte-compile-warn-x
- binder
- "Malformed `%S' binding: %S"
- letsym binder))
- (setq value (cadr binder))
- (car binder))))
- (cond
- ;; Ignore bindings without a valid name.
- ((not (symbolp var))
- (byte-compile-warn-x var "attempt to let-bind nonvariable `%S'" var))
- ((or (booleanp var) (keywordp var))
- (byte-compile-warn-x var "attempt to let-bind constant `%S'" var))
- (t
- (let ((new-val
- (pcase (cconv--var-classification binder form)
- ;; Check if var is a candidate for lambda lifting.
- ((and :lambda-candidate
- (guard
- (progn
- (cl-assert (and (eq (car value) 'function)
- (eq (car (cadr value)) 'lambda)))
- (cl-assert (equal (cddr (cadr value))
- (caar cconv-freevars-alist)))
- ;; Peek at the freevars to decide whether
- ;; to λ-lift.
- (let* ((fvs (cdr (car cconv-freevars-alist)))
- (fun (cadr value))
- (funargs (cadr fun))
- (funcvars (append fvs funargs)))
+ (let ((binders-new '())
+ (new-env env)
+ (new-extend extend))
+
+ (dolist (binder binders)
+ (let* ((value nil)
+ (var (if (not (consp binder))
+ (prog1 binder (setq binder (list binder)))
+ (when (cddr binder)
+ (byte-compile-warn-x
+ binder
+ "Malformed `%S' binding: %S"
+ letsym binder))
+ (setq value (cadr binder))
+ (car binder))))
+ (cond
+ ;; Ignore bindings without a valid name.
+ ((not (symbolp var))
+ (byte-compile-warn-x
+ var "attempt to let-bind nonvariable `%S'" var))
+ ((or (booleanp var) (keywordp var))
+ (byte-compile-warn-x
+ var "attempt to let-bind constant `%S'" var))
+ (t
+ (let ((new-val
+ (pcase (cconv--var-classification binder form)
+ ;; Check if var is a candidate for lambda lifting.
+ ((and :lambda-candidate
+ (guard
+ (progn
+ (cl-assert
+ (and (eq (car value) 'function)
+ (eq (car (cadr value)) 'lambda)))
+ (cl-assert (equal (cddr (cadr value))
+ (caar cconv-freevars-alist)))
+ ;; Peek at the freevars to decide whether
+ ;; to λ-lift.
+ (let* ((fvs (cdr (car cconv-freevars-alist)))
+ (fun (cadr value))
+ (funargs (cadr fun))
+ (funcvars (append fvs funargs)))
; lambda lifting condition
- (and fvs (>= cconv-liftwhen
- (length funcvars)))))))
+ (and fvs (>= cconv-liftwhen
+ (length funcvars)))))))
; Lift.
- (let* ((fvs (cdr (pop cconv-freevars-alist)))
- (fun (cadr value))
- (funargs (cadr fun))
- (funcvars (append fvs funargs))
- (funcbody (cddr fun))
- (funcbody-env ()))
- (push `(,var . (apply-partially ,var . ,fvs)) new-env)
- (dolist (fv fvs)
- (cl-pushnew fv new-extend)
- (if (and (eq 'car-safe (car-safe
- (cdr (assq fv env))))
- (not (memq fv funargs)))
- (push `(,fv . (car-safe ,fv)) funcbody-env)))
- `(function (lambda ,funcvars .
- ,(cconv--convert-funcbody
- funargs funcbody funcbody-env value)))))
-
- ;; Check if it needs to be turned into a "ref-cell".
- (:captured+mutated
- ;; Declared variable is mutated and captured.
- (push `(,var . (car-safe ,var)) new-env)
- `(list ,(cconv-convert value env extend)))
-
- ;; Check if it needs to be turned into a "ref-cell".
- (:unused
- ;; Declared variable is unused.
- (if (assq var new-env)
- (push `(,var) new-env)) ;FIXME:Needed?
- (let* ((Ignore (if (symbol-with-pos-p var)
- (position-symbol 'ignore var)
- 'ignore))
- (newval `(,Ignore
- ,(cconv-convert value env extend)))
- (msg (cconv--warn-unused-msg var "variable")))
- (if (null msg) newval
- (macroexp--warn-wrap var msg newval 'lexical))))
-
- ;; Normal default case.
- (_
- (if (assq var new-env) (push `(,var) new-env))
- (cconv-convert value env extend)))))
-
- (when (and (eq letsym 'let*) (memq var new-extend))
- ;; One of the lambda-lifted vars is shadowed, so add
- ;; a reference to the outside binding and arrange to use
- ;; that reference.
- (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)))
-
- ;; We push the element after redefined free variables are
- ;; processed. This is important to avoid the bug when free
- ;; variable and the function have the same name.
- (push (list var new-val) binders-new)
-
- (when (eq letsym 'let*)
- (setq env new-env)
- (setq extend new-extend))))))
- ) ; end of dolist over binders
-
- (when (not (eq letsym 'let*))
- ;; We can't do the cconv--remap-llv at the same place for let and
- ;; let* because in the case of `let', the shadowing may occur
- ;; before we know that the var will be in `new-extend' (bug#24171).
- (dolist (binder binders-new)
- (when (memq (car-safe binder) new-extend)
- ;; One of the lambda-lifted vars is shadowed.
- (let* ((var (car-safe binder))
- (var-def (cconv--lifted-arg var env))
- (closedsym (make-symbol (format "closed-%s" var))))
- (setq new-env (cconv--remap-llv new-env var closedsym))
- (setq new-extend (cons closedsym (remq var new-extend)))
- (push `(,closedsym ,var-def) binders-new)))))
-
- `(,letsym ,(nreverse binders-new)
- . ,(mapcar (lambda (form)
- (cconv-convert
- form new-env new-extend))
- body))))
+ (let* ((fvs (cdr (pop cconv-freevars-alist)))
+ (fun (cadr value))
+ (funargs (cadr fun))
+ (funcvars (append fvs funargs))
+ (funcbody (cddr fun))
+ (funcbody-env ()))
+ (push `(,var . (apply-partially ,var . ,fvs))
+ new-env)
+ (dolist (fv fvs)
+ (cl-pushnew fv new-extend)
+ (if (and (eq 'car-safe (car-safe
+ (cdr (assq fv env))))
+ (not (memq fv funargs)))
+ (push `(,fv . (car-safe ,fv)) funcbody-env)))
+ `(function
+ (lambda ,funcvars
+ . ,(cconv--convert-funcbody
+ funargs funcbody funcbody-env value)))))
+
+ ;; Check if it needs to be turned into a "ref-cell".
+ (:captured+mutated
+ ;; Declared variable is mutated and captured.
+ (push `(,var . (car-safe ,var)) new-env)
+ `(list ,(cconv-convert value env extend)))
+
+ ;; Check if it needs to be turned into a "ref-cell".
+ (:unused
+ ;; Declared variable is unused.
+ (if (assq var new-env)
+ (push `(,var) new-env)) ;FIXME:Needed?
+ (let* ((Ignore (if (symbol-with-pos-p var)
+ (position-symbol 'ignore var)
+ 'ignore))
+ (newval `(,Ignore
+ ,(cconv-convert value env extend)))
+ (msg (cconv--warn-unused-msg var "variable")))
+ (if (null msg) newval
+ (macroexp--warn-wrap var msg newval 'lexical))))
+
+ ;; Normal default case.
+ (_
+ (if (assq var new-env) (push `(,var) new-env))
+ (cconv-convert value env extend)))))
+
+ (when (and (eq letsym 'let*) (memq var new-extend))
+ ;; One of the lambda-lifted vars is shadowed, so add
+ ;; a reference to the outside binding and arrange to use
+ ;; that reference.
+ (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)))
+
+ ;; We push the element after redefined free variables are
+ ;; processed. This is important to avoid the bug when free
+ ;; variable and the function have the same name.
+ (push (list var new-val) binders-new)
+
+ (when (eq letsym 'let*)
+ (setq env new-env)
+ (setq extend new-extend))))))
+ ) ; end of dolist over binders
+
+ (when (not (eq letsym 'let*))
+ ;; We can't do the cconv--remap-llv at the same place for let and
+ ;; let* because in the case of `let', the shadowing may occur
+ ;; before we know that the var will be in `new-extend' (bug#24171).
+ (dolist (binder binders-new)
+ (when (memq (car-safe binder) new-extend)
+ ;; One of the lambda-lifted vars is shadowed.
+ (let* ((var (car-safe binder))
+ (var-def (cconv--lifted-arg var env))
+ (closedsym (make-symbol (format "closed-%s" var))))
+ (setq new-env (cconv--remap-llv new-env var closedsym))
+ (setq new-extend (cons closedsym (remq var new-extend)))
+ (push `(,closedsym ,var-def) binders-new)))))
+
+ `(,letsym ,(nreverse binders-new)
+ . ,(mapcar (lambda (form)
+ (cconv-convert
+ form new-env new-extend))
+ body))))
;end of let let* forms
- ; first element is lambda expression
- (`(,(and `(lambda . ,_) fun) . ,args)
- ;; FIXME: it's silly to create a closure just to call it.
- ;; Running byte-optimize-form earlier will resolve this.
- `(funcall
- ,(cconv-convert `(function ,fun) env extend)
- ,@(mapcar (lambda (form)
- (cconv-convert form env extend))
- args)))
-
- (`(cond . ,cond-forms) ; cond special form
- `(,(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)))
- (cconv-convert (cadr (pop body)) env extend)))
- (bf (if (stringp (car body)) (cdr body) body))
- (if (when (eq 'interactive (car-safe (car bf)))
- (gethash form cconv--interactive-form-funs)))
- (cif (when if (cconv-convert if env extend)))
- (_ (pcase cif
- (`#'(lambda () ,form) (setf (cadr (car bf)) form) (setq cif nil))
- ('nil nil)
- ;; The interactive form needs special treatment, so the form
- ;; inside the `interactive' won't be used any further.
- (_ (setf (cadr (car bf)) nil))))
- (cf (cconv--convert-function args body env form docstring)))
- (if (not cif)
- ;; Normal case, the interactive form needs no special treatment.
- cf
- `(cconv--interactive-helper ,cf ,cif))))
-
- (`(internal-make-closure . ,_)
- (byte-compile-report-error
- "Internal error in compiler: cconv called twice?"))
-
- (`(quote . ,_) form)
- (`(function . ,_) form)
+ ; first element is lambda expression
+ (`(,(and `(lambda . ,_) fun) . ,args)
+ ;; FIXME: it's silly to create a closure just to call it.
+ ;; Running byte-optimize-form earlier would resolve this.
+ `(funcall
+ ,(cconv-convert `(function ,fun) env extend)
+ ,@(mapcar (lambda (form)
+ (cconv-convert form env extend))
+ args)))
+
+ (`(cond . ,cond-forms) ; cond special form
+ `(,(car form) . ,(mapcar (lambda (branch)
+ (mapcar (lambda (form)
+ (cconv-convert form env extend))
+ branch))
+ cond-forms)))
+
+ (`(function (lambda ,args . ,body) . ,rest)
+ (let* ((docstring (if (eq :documentation (car-safe (car body)))
+ (cconv-convert (cadr (pop body)) env extend)))
+ (bf (if (stringp (car body)) (cdr body) body))
+ (if (when (eq 'interactive (car-safe (car bf)))
+ (gethash form cconv--interactive-form-funs)))
+ (wrapped (pcase if (`#'(lambda (&rest _cconv--dummy) .,_) t)))
+ (cif (when if (cconv-convert if env extend)))
+ (cf nil))
+ ;; TODO: Because we need to non-destructively modify body, this code
+ ;; is particularly ugly. This should ideally be moved to
+ ;; cconv--convert-function.
+ (pcase cif
+ ('nil (setq bf nil))
+ (`#',f
+ (pcase-let ((`((,f1 . (,_ . ,f2)) . ,f3) bf))
+ (setq bf `((,f1 . (,(if wrapped (nth 2 f) cif) . ,f2)) . ,f3)))
+ (setq cif nil))
+ ;; The interactive form needs special treatment, so the form
+ ;; inside the `interactive' won't be used any further.
+ (_ (pcase-let ((`((,f1 . (,_ . ,f2)) . ,f3) bf))
+ (setq bf `((,f1 . (nil . ,f2)) . ,f3)))))
+ (when bf
+ ;; If we modified bf, re-build body and form as
+ ;; copies with the modified bits.
+ (setq body (if (stringp (car body))
+ (cons (car body) bf)
+ bf)
+ form `(function (lambda ,args . ,body) . ,rest))
+ ;; Also, remove the current old entry on the alist, replacing
+ ;; it with the new one.
+ (let ((entry (pop cconv-freevars-alist)))
+ (push (cons body (cdr entry)) cconv-freevars-alist)))
+ (setq cf (cconv--convert-function args body env form docstring))
+ (if (not cif)
+ ;; Normal case, the interactive form needs no special treatment.
+ cf
+ `(cconv--interactive-helper
+ ,cf ,(if wrapped cif `(list 'quote ,cif))))))
+
+ (`(internal-make-closure . ,_)
+ (byte-compile-report-error
+ "Internal error in compiler: cconv called twice?"))
+
+ (`(quote . ,_) form)
+ (`(function . ,_) form)
;defconst, defvar
- (`(,(and sym (or 'defconst 'defvar)) ,definedsymbol . ,forms)
- `(,sym ,definedsymbol
- . ,(when (consp forms)
- (cons (cconv-convert (car forms) env extend)
- ;; The rest (i.e. docstring, of any) is not evaluated,
- ;; and may be an invalid expression (e.g. ($# . 678)).
- (cdr forms)))))
+ (`(,(and sym (or 'defconst 'defvar)) ,definedsymbol . ,forms)
+ `(,sym ,definedsymbol
+ . ,(when (consp forms)
+ (cons (cconv-convert (car forms) env extend)
+ ;; The rest (i.e. docstring, of any) is not evaluated,
+ ;; and may be an invalid expression (e.g. ($# . 678)).
+ (cdr forms)))))
; condition-case
- (`(condition-case ,var ,protected-form . ,handlers)
- (let* ((class (and var (cconv--var-classification (list var) form)))
- (newenv
- (cond ((eq class :captured+mutated)
- (cons `(,var . (car-safe ,var)) env))
- ((assq var env) (cons `(,var) env))
- (t env)))
- (msg (when (eq class :unused)
- (cconv--warn-unused-msg var "variable")))
- (newprotform (cconv-convert protected-form env extend)))
- `(,(car form) ,var
- ,(if msg
- (macroexp--warn-wrap var msg newprotform 'lexical)
- newprotform)
- ,@(mapcar
- (lambda (handler)
- `(,(car handler)
- ,@(let ((body
- (mapcar (lambda (form)
- (cconv-convert form newenv extend))
- (cdr handler))))
- (if (not (eq class :captured+mutated))
- body
- `((let ((,var (list ,var))) ,@body))))))
- handlers))))
-
- (`(unwind-protect ,form1 . ,body)
- `(,(car form) ,(cconv-convert form1 env extend)
- :fun-body ,(cconv--convert-function () body env form1)))
-
- (`(setq ,var ,expr)
- (let ((var-new (or (cdr (assq var env)) var))
- (value (cconv-convert expr env extend)))
- (pcase var-new
- ((pred symbolp) `(,(car form) ,var-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'
- ;; on a closed-over variable, so just drop the setq.
- (_ ;; (byte-compile-report-error
- ;; (format "Internal error in cconv of (setq %s ..)"
- ;; sym-new))
- value))))
-
- (`(,(and (or 'funcall 'apply) callsym) ,fun . ,args)
- ;; These are not special forms but we treat them separately for the needs
- ;; of lambda lifting.
- (let ((mapping (cdr (assq fun env))))
- (pcase mapping
- (`(apply-partially ,_ . ,(and fvs `(,_ . ,_)))
- (cl-assert (eq (cadr mapping) fun))
- `(,callsym ,fun
- ,@(mapcar (lambda (fv)
- (let ((exp (or (cdr (assq fv env)) fv)))
- (pcase exp
- (`(car-safe ,iexp . ,_) iexp)
- (_ exp))))
- fvs)
- ,@(mapcar (lambda (arg)
- (cconv-convert arg env extend))
- args)))
- (_ `(,callsym ,@(mapcar (lambda (arg)
+ (`(condition-case ,var ,protected-form . ,handlers)
+ (let* ((class (and var (cconv--var-classification (list var) form)))
+ (newenv
+ (cond ((eq class :captured+mutated)
+ (cons `(,var . (car-safe ,var)) env))
+ ((assq var env) (cons `(,var) env))
+ (t env)))
+ (msg (when (eq class :unused)
+ (cconv--warn-unused-msg var "variable")))
+ (newprotform (cconv-convert protected-form env extend)))
+ `(,(car form) ,var
+ ,(if msg
+ (macroexp--warn-wrap var msg newprotform 'lexical)
+ newprotform)
+ ,@(mapcar
+ (lambda (handler)
+ `(,(car handler)
+ ,@(let ((body
+ (mapcar (lambda (form)
+ (cconv-convert form newenv extend))
+ (cdr handler))))
+ (if (not (eq class :captured+mutated))
+ body
+ `((let ((,var (list ,var))) ,@body))))))
+ handlers))))
+
+ (`(unwind-protect ,form1 . ,body)
+ `(,(car form) ,(cconv-convert form1 env extend)
+ :fun-body ,(cconv--convert-function () body env form1)))
+
+ (`(setq ,var ,expr)
+ (let ((var-new (or (cdr (assq var env)) var))
+ (value (cconv-convert expr env extend)))
+ (pcase var-new
+ ((pred symbolp) `(,(car form) ,var-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'
+ ;; on a closed-over variable, so just drop the setq.
+ (_ ;; (byte-compile-report-error
+ ;; (format "Internal error in cconv of (setq %s ..)"
+ ;; sym-new))
+ value))))
+
+ (`(,(and (or 'funcall 'apply) callsym) ,fun . ,args)
+ ;; These are not special forms but we treat them separately for the needs
+ ;; of lambda lifting.
+ (let ((mapping (cdr (assq fun env))))
+ (pcase mapping
+ (`(apply-partially ,_ . ,(and fvs `(,_ . ,_)))
+ (cl-assert (eq (cadr mapping) fun))
+ `(,callsym ,fun
+ ,@(mapcar (lambda (fv)
+ (let ((exp (or (cdr (assq fv env)) fv)))
+ (pcase exp
+ (`(car-safe ,iexp . ,_) iexp)
+ (_ exp))))
+ fvs)
+ ,@(mapcar (lambda (arg)
(cconv-convert arg env extend))
- (cons fun args)))))))
-
- ;; The form (if any) is converted beforehand as part of the `lambda' case.
- (`(interactive . ,_) form)
-
- ;; `declare' should now be macro-expanded away (and if they're not, we're
- ;; in trouble because they *can* contain code nowadays).
- ;; (`(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
- `(,func . ,(mapcar (lambda (form)
- (cconv-convert form env extend))
- forms)))
-
- (_ (or (cdr (assq form env)) form))))
+ args)))
+ (_ `(,callsym ,@(mapcar (lambda (arg)
+ (cconv-convert arg env extend))
+ (cons fun args)))))))
+
+ ;; The form (if any) is converted beforehand as part of the `lambda' case.
+ (`(interactive . ,_) form)
+
+ ;; `declare' should now be macro-expanded away (and if they're not, we're
+ ;; in trouble because they *can* contain code nowadays).
+ ;; (`(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)
+ (if (or (symbolp func) (functionp func))
+ ;; First element is function or whatever function-like forms are:
+ ;; or, and, if, catch, progn, prog1, while, until
+ (let ((args (mapcar (lambda (form) (cconv-convert form env extend))
+ forms)))
+ (unless (symbolp func)
+ (byte-compile-warn-x
+ form
+ "Use `funcall' instead of `%s' in the function position" func))
+ `(,func . ,args))
+ (byte-compile-warn-x form "Malformed function `%S'" func)
+ nil))
+
+ (_ (or (cdr (assq form env)) form)))))
(defvar byte-compile-lexical-variables)
@@ -661,11 +695,6 @@ FORM is the parent form that binds this var."
(when lexical-binding
(dolist (arg args)
(cond
- ((cconv--not-lexical-var-p arg cconv--dynbound-variables)
- (byte-compile-warn-x
- arg
- "Lexical argument shadows the dynamic variable %S"
- arg))
((eq ?& (aref (symbol-name arg) 0)) nil) ;Ignore &rest, &optional, ...
(t (let ((varstruct (list arg nil nil nil nil)))
(cl-pushnew arg byte-compile-lexical-variables)
@@ -742,7 +771,8 @@ This function does not return anything but instead fills the
(when (eq 'interactive (car-safe (car bf)))
(let ((if (cadr (car bf))))
(unless (macroexp-const-p if) ;Optimize this common case.
- (let ((f `#'(lambda () ,if)))
+ (let ((f (if (eq 'function (car-safe if)) if
+ `#'(lambda (&rest _cconv--dummy) ,if))))
(setf (gethash form cconv--interactive-form-funs) f)
(cconv-analyze-form f env))))))
(cconv--analyze-function vrs body-forms env form))
@@ -829,10 +859,13 @@ This function does not return anything but instead fills the
(define-obsolete-function-alias 'cconv-analyse-form #'cconv-analyze-form "25.1")
(defun cconv-fv (form lexvars dynvars)
- "Return the list of free variables in FORM.
-LEXVARS is the list of statically scoped vars in the context
-and DYNVARS is the list of dynamically scoped vars in the context.
-Returns a pair (LEXV . DYNV) of those vars actually used by FORM."
+ "Return the free variables used in FORM.
+FORM is usually a function #\\='(lambda ...), but may be any valid
+form. LEXVARS is a list of symbols, each of which is lexically
+bound in FORM's context. DYNVARS is a list of symbols, each of
+which is dynamically bound in FORM's context.
+Returns a cons (LEXV . DYNV), the car and cdr being lists of the
+lexically and dynamically bound symbols actually used by FORM."
(let* ((fun
;; Wrap FORM into a function because the analysis code we
;; have only computes freevars for functions.
@@ -870,11 +903,26 @@ Returns a pair (LEXV . DYNV) of those vars actually used by FORM."
(cons fvs dyns)))))
(defun cconv-make-interpreted-closure (fun env)
+ "Make a closure for the interpreter.
+This is intended to be called at runtime by the ELisp interpreter (when
+the code has not been compiled).
+FUN is the closure's source code, must be a lambda form.
+ENV is the runtime representation of the lexical environment,
+i.e. a list whose elements can be either plain symbols (which indicate
+that this symbol should use dynamic scoping) or pairs (SYMBOL . VALUE)
+for the lexical bindings."
(cl-assert (eq (car-safe fun) 'lambda))
(let ((lexvars (delq nil (mapcar #'car-safe env))))
- (if (null lexvars)
- ;; The lexical environment is empty, so there's no need to
- ;; look for free variables.
+ (if (or (null lexvars)
+ ;; Functions with a `:closure-dont-trim-context' marker
+ ;; should keep their whole context untrimmed (bug#59213).
+ (and (eq :closure-dont-trim-context (nth 2 fun))
+ ;; Check the function doesn't just return the magic keyword.
+ (nthcdr 3 fun)))
+ ;; The lexical environment is empty, or needs to be preserved,
+ ;; so there's no need to look for free variables.
+ ;; Attempting to replace ,(cdr fun) by a macroexpanded version
+ ;; causes bootstrap to fail.
`(closure ,env . ,(cdr fun))
;; We could try and cache the result of the macroexpansion and
;; `cconv-fv' analysis. Not sure it's worth the trouble.
diff --git a/lisp/emacs-lisp/check-declare.el b/lisp/emacs-lisp/check-declare.el
index 0362c7d2c24..faa7824c8bd 100644
--- a/lisp/emacs-lisp/check-declare.el
+++ b/lisp/emacs-lisp/check-declare.el
@@ -40,7 +40,7 @@
;;; Code:
-(defconst check-declare-warning-buffer "*Check Declarations Warnings*"
+(defvar check-declare-warning-buffer "*Check Declarations Warnings*"
"Name of buffer used to display any `check-declare' warnings.")
(defun check-declare-locate (file basefile)
@@ -85,6 +85,9 @@ don't know how to recognize (e.g. some macros)."
(let (alist)
(with-temp-buffer
(insert-file-contents file)
+ ;; Ensure shorthands available, as we will be `read'ing Elisp
+ ;; (bug#67523)
+ (let (enable-local-variables) (hack-local-variables))
;; FIXME we could theoretically be inside a string.
(while (re-search-forward "^[ \t]*\\((declare-function\\)[ \t\n]" nil t)
(let ((pos (match-beginning 1)))
@@ -145,64 +148,70 @@ is a string giving details of the error."
(if (file-regular-p fnfile)
(with-temp-buffer
(insert-file-contents fnfile)
+ (unless cflag
+ ;; If in Elisp, ensure syntax and shorthands available
+ ;; (bug#67523)
+ (set-syntax-table emacs-lisp-mode-syntax-table)
+ (let (enable-local-variables) (hack-local-variables)))
;; defsubst's don't _have_ to be known at compile time.
- (setq re (format (if cflag
- "^[ \t]*\\(DEFUN\\)[ \t]*([ \t]*\"%s\""
- "^[ \t]*(\\(fset[ \t]+'\\|\
+ (setq re (if cflag
+ (format "^[ \t]*\\(DEFUN\\)[ \t]*([ \t]*\"%s\""
+ (regexp-opt (mapcar 'cadr fnlist) t))
+ "^[ \t]*(\\(fset[ \t]+'\\|\
cl-def\\(?:generic\\|method\\|un\\)\\|\
def\\(?:un\\|subst\\|foo\\|method\\|class\\|\
ine-\\(?:derived\\|generic\\|\\(?:global\\(?:ized\\)?-\\)?minor\\)-mode\\|\
\\(?:ine-obsolete-function-\\)?alias[ \t]+'\\|\
ine-overloadable-function\\)\\)\
-[ \t]*%s\\([ \t;]+\\|$\\)")
- (regexp-opt (mapcar 'cadr fnlist) t)))
+[ \t]*\\(\\(?:\\sw\\|\\s_\\)+\\)\\([ \t;]+\\|$\\)"))
(while (re-search-forward re nil t)
(skip-chars-forward " \t\n")
- (setq fn (match-string 2)
- type (match-string 1)
- ;; (min . max) for a fixed number of arguments, or
- ;; arglists with optional elements.
- ;; (min) for arglists with &rest.
- ;; sig = 'err means we could not find an arglist.
- sig (cond (cflag
- (or
- (when (search-forward "," nil t 3)
- (skip-chars-forward " \t\n")
- ;; Assuming minargs and maxargs on same line.
- (when (looking-at "\\([0-9]+\\)[ \t]*,[ \t]*\
+ (setq fn (symbol-name (car (read-from-string (match-string 2)))))
+ (when (member fn (mapcar 'cadr fnlist))
+ (setq type (match-string 1)
+ ;; (min . max) for a fixed number of arguments, or
+ ;; arglists with optional elements.
+ ;; (min) for arglists with &rest.
+ ;; sig = 'err means we could not find an arglist.
+ sig (cond (cflag
+ (or
+ (when (search-forward "," nil t 3)
+ (skip-chars-forward " \t\n")
+ ;; Assuming minargs and maxargs on same line.
+ (when (looking-at "\\([0-9]+\\)[ \t]*,[ \t]*\
\\([0-9]+\\|MANY\\|UNEVALLED\\)")
- (setq minargs (string-to-number
- (match-string 1))
- maxargs (match-string 2))
- (cons minargs (unless (string-match "[^0-9]"
- maxargs)
- (string-to-number
- maxargs)))))
- 'err))
- ((string-match
- "\\`define-\\(derived\\|generic\\)-mode\\'"
- type)
- '(0 . 0))
- ((string-match
- "\\`define\\(-global\\(ized\\)?\\)?-minor-mode\\'"
- type)
- '(0 . 1))
- ;; Prompt to update.
- ((string-match
- "\\`define-obsolete-function-alias\\>"
- type)
- 'obsolete)
- ;; Can't easily check arguments in these cases.
- ((string-match "\\`\\(def\\(alias\\|class\\)\\|\
+ (setq minargs (string-to-number
+ (match-string 1))
+ maxargs (match-string 2))
+ (cons minargs (unless (string-match "[^0-9]"
+ maxargs)
+ (string-to-number
+ maxargs)))))
+ 'err))
+ ((string-match
+ "\\`define-\\(derived\\|generic\\)-mode\\'"
+ type)
+ '(0 . 0))
+ ((string-match
+ "\\`define\\(-global\\(ized\\)?\\)?-minor-mode\\'"
+ type)
+ '(0 . 1))
+ ;; Prompt to update.
+ ((string-match
+ "\\`define-obsolete-function-alias\\>"
+ type)
+ 'obsolete)
+ ;; Can't easily check arguments in these cases.
+ ((string-match "\\`\\(def\\(alias\\|class\\)\\|\
fset\\|\\(?:cl-\\)?defmethod\\)\\>" type)
- t)
- ((looking-at "\\((\\|nil\\)")
- (byte-compile-arglist-signature
- (read (current-buffer))))
- (t
- 'err))
- ;; alist of functions and arglist signatures.
- siglist (cons (cons fn sig) siglist)))))
+ t)
+ ((looking-at "\\((\\|nil\\)")
+ (byte-compile-arglist-signature
+ (read (current-buffer))))
+ (t
+ 'err))
+ ;; alist of functions and arglist signatures.
+ siglist (cons (cons fn sig) siglist))))))
(dolist (e fnlist)
(setq arglist (nth 2 e)
type
@@ -319,9 +328,14 @@ Returns non-nil if any false statements are found."
(setq root (directory-file-name (file-relative-name root)))
(or (file-directory-p root)
(error "Directory `%s' not found" root))
- (let ((files (directory-files-recursively root "\\.el\\'")))
- (when files
- (apply #'check-declare-files files))))
+ (when-let* ((files (directory-files-recursively root "\\.el\\'"))
+ (files (mapcan (lambda (file)
+ ;; Filter out lock files.
+ (and (not (string-prefix-p
+ ".#" (file-name-nondirectory file)))
+ (list file)))
+ files)))
+ (apply #'check-declare-files files)))
(provide 'check-declare)
diff --git a/lisp/emacs-lisp/checkdoc.el b/lisp/emacs-lisp/checkdoc.el
index ac51031832a..c22dfb2eb26 100644
--- a/lisp/emacs-lisp/checkdoc.el
+++ b/lisp/emacs-lisp/checkdoc.el
@@ -556,7 +556,8 @@ the users will view as each check is completed."
"Display and update the status buffer for the current checkdoc mode.
CHECK is a list of four strings stating the current status of each
test; the nth string describes the status of the nth test."
- (let (temp-buffer-setup-hook)
+ (let (temp-buffer-setup-hook
+ (temp-buffer-show-hook #'special-mode))
(with-output-to-temp-buffer "*Checkdoc Status*"
(mapc #'princ
(list "Buffer comments and tags: " (nth 0 check)
@@ -1611,8 +1612,11 @@ may require more formatting")
(let ((f nil) (m nil) (start (point))
;; Ignore the "A-" modifier: it is uncommon in practice,
;; and leads to false positives in regexp ranges.
- (re "[^`‘A-Za-z0-9_]\\([CMs]-[a-zA-Z]\\|\\(\\([CMs]-\\)?\
-mouse-[0-3]\\)\\)\\>"))
+ (re (rx (not (any "0-9A-Za-z_`‘-"))
+ (group (or (seq (any "CMs") "-" (any "A-Za-z"))
+ (group (opt (group (any "CMs") "-"))
+ "mouse-" (any "0-3"))))
+ eow)))
;; Find the first key sequence not in a sample
(while (and (not f) (setq m (re-search-forward re e t)))
(setq f (not (checkdoc-in-sample-code-p start e))))
@@ -1779,7 +1783,7 @@ function,command,variable,option or symbol." ms1))))))
(order (and (nth 3 fp) (car (nth 3 fp))))
(nocheck (append '("&optional" "&rest" "&key" "&aux"
"&context" "&environment" "&whole"
- "&body" "&allow-other-keys")
+ "&body" "&allow-other-keys" "nil")
(nth 3 fp)))
(inopts nil))
(while (and args found (> found last-pos))
@@ -1990,7 +1994,7 @@ from the comment."
(defun-depth (ppss-depth (syntax-ppss)))
(lst nil)
(ret nil)
- (oo (make-vector 3 0))) ;substitute obarray for `read'
+ (oo (obarray-make 3))) ;substitute obarray for `read'
(forward-char 1)
(forward-sexp 1)
(skip-chars-forward " \n\t")
@@ -2042,8 +2046,7 @@ from the comment."
(condition-case nil
(setq lst (read (current-buffer)))
(error (setq lst nil))) ; error in text
- (if (not (listp lst)) ; not a list of args
- (setq lst (list lst)))
+ (setq lst (ensure-list lst))
(if (and lst (not (symbolp (car lst)))) ;weird arg
(setq lst nil))
(while lst
@@ -2382,7 +2385,7 @@ Code:, and others referenced in the style guide."
err
(or
;; * Commentary Section
- (if (and (not (lm-commentary-mark))
+ (if (and (not (lm-commentary-start))
;; No need for a commentary section in test files.
(not (string-match
(rx (or (seq (or "-test.el" "-tests.el") string-end)
@@ -2419,10 +2422,10 @@ Code:, and others referenced in the style guide."
(if (or (not checkdoc-force-history-flag)
(file-exists-p "ChangeLog")
(file-exists-p "../ChangeLog")
- (lm-history-mark))
+ (lm-history-start))
nil
(progn
- (goto-char (or (lm-commentary-mark) (point-min)))
+ (goto-char (or (lm-commentary-start) (point-min)))
(cond
((re-search-forward
"write\\s-+to\\s-+the\\s-+Free Software Foundation, Inc."
@@ -2443,7 +2446,7 @@ Code:, and others referenced in the style guide."
err
(or
;; * Code section
- (if (not (lm-code-mark))
+ (if (not (lm-code-start))
(let ((cont t)
pos)
(goto-char (point-min))
@@ -2494,7 +2497,7 @@ Code:, and others referenced in the style guide."
;; Let's spellcheck the commentary section. This is the only
;; section that is easy to pick out, and it is also the most
;; visible section (with the finder).
- (let ((cm (lm-commentary-mark)))
+ (let ((cm (lm-commentary-start)))
(when cm
(save-excursion
(goto-char cm)
@@ -2546,11 +2549,11 @@ Argument END is the maximum bounds to search in."
(rx "("
(* (syntax whitespace))
(group
- (or (seq (* (group (or wordchar (syntax symbol))))
+ (or (seq (* (or wordchar (syntax symbol)))
"error")
- (seq (* (group (or wordchar (syntax symbol))))
+ (seq (* (or wordchar (syntax symbol)))
(or "y-or-n-p" "yes-or-no-p")
- (? (group "-with-timeout")))
+ (? "-with-timeout"))
"checkdoc-autofix-ask-replace"))
(+ (any "\n\t ")))
end t))
@@ -2791,7 +2794,7 @@ function called to create the messages."
": " msg)))
(if (string= checkdoc-diagnostic-buffer "*warn*")
(warn (apply #'concat text))
- (with-current-buffer (get-buffer checkdoc-diagnostic-buffer)
+ (with-current-buffer checkdoc-diagnostic-buffer
(let ((inhibit-read-only t)
(pt (point-max)))
(goto-char pt)
diff --git a/lisp/emacs-lisp/cl-extra.el b/lisp/emacs-lisp/cl-extra.el
index 7edf25969a3..437dea2d6a9 100644
--- a/lisp/emacs-lisp/cl-extra.el
+++ b/lisp/emacs-lisp/cl-extra.el
@@ -408,6 +408,7 @@ Other non-digit chars are considered junk.
RADIX is an integer between 2 and 36, the default is 10. Signal
an error if the substring between START and END cannot be parsed
as an integer unless JUNK-ALLOWED is non-nil."
+ (declare (side-effect-free t))
(cl-check-type string string)
(let* ((start (or start 0))
(len (length string))
@@ -569,6 +570,7 @@ too large if positive or too small if negative)."
;;;###autoload
(defun cl-revappend (x y)
"Equivalent to (append (reverse X) Y)."
+ (declare (side-effect-free t))
(nconc (reverse x) y))
;;;###autoload
@@ -636,13 +638,12 @@ PROPLIST is a list of the sort returned by `symbol-plist'.
(and (cdr p) (progn (setcdr p (cdr (cdr (cdr p)))) t))))
;;;###autoload
-(defun cl-remprop (sym tag)
- "Remove from SYMBOL's plist the property PROPNAME and its value.
-\n(fn SYMBOL PROPNAME)"
- (let ((plist (symbol-plist sym)))
- (if (and plist (eq tag (car plist)))
- (progn (setplist sym (cdr (cdr plist))) t)
- (cl--do-remf plist tag))))
+(defun cl-remprop (symbol propname)
+ "Remove from SYMBOL's plist the property PROPNAME and its value."
+ (let ((plist (symbol-plist symbol)))
+ (if (and plist (eq propname (car plist)))
+ (progn (setplist symbol (cdr (cdr plist))) t)
+ (cl--do-remf plist propname))))
;;; Streams.
@@ -710,11 +711,6 @@ PROPLIST is a list of the sort returned by `symbol-plist'.
(eval-when-compile (require 'cl-macs)) ;Explicitly, for cl--find-class.
(require 'help-mode)
-;; FIXME: We could go crazy and add another entry so describe-symbol can be
-;; used with the slot names of CL structs (and/or EIEIO objects).
-(add-to-list 'describe-symbol-backends
- `(nil ,#'cl-find-class ,(lambda (s _b _f) (cl-describe-type s))))
-
(defconst cl--typedef-regexp
(concat "(" (regexp-opt '("defclass" "defstruct" "cl-defstruct"
"cl-deftype" "deftype"))
@@ -724,11 +720,6 @@ PROPLIST is a list of the sort returned by `symbol-plist'.
(add-to-list 'find-function-regexp-alist
'(define-type . cl--typedef-regexp)))
-(define-button-type 'cl-help-type
- :supertype 'help-function-def
- 'help-function #'cl-describe-type
- 'help-echo (purecopy "mouse-2, RET: describe this type"))
-
(define-button-type 'cl-type-definition
:supertype 'help-function-def
'help-echo (purecopy "mouse-2, RET: find type definition"))
@@ -743,7 +734,7 @@ Call `cl--find-class' to get TYPE's propname `cl--class'"
(cl--find-class type))
;;;###autoload
-(defun cl-describe-type (type)
+(defun cl-describe-type (type &optional _buf _frame)
"Display the documentation for type TYPE (a symbol)."
(interactive
(let ((str (completing-read "Describe type: " obarray #'cl-find-class t)))
@@ -765,6 +756,15 @@ Call `cl--find-class' to get TYPE's propname `cl--class'"
;; Return the text we displayed.
(buffer-string)))))
+(defun cl--class-children (class)
+ (let ((children '()))
+ (mapatoms
+ (lambda (sym)
+ (let ((sym-class (cl--find-class sym)))
+ (and sym-class (memq class (cl--class-parents sym-class))
+ (push sym children)))))
+ children))
+
(defun cl--describe-class (type &optional class)
(unless class (setq class (cl--find-class type)))
(let ((location (find-lisp-object-file-name type 'define-type))
@@ -772,7 +772,7 @@ Call `cl--find-class' to get TYPE's propname `cl--class'"
(insert (symbol-name type)
(substitute-command-keys " is a type (of kind `"))
(help-insert-xref-button (symbol-name metatype)
- 'cl-help-type metatype)
+ 'help-type metatype)
(insert (substitute-command-keys "')"))
(when location
(insert (substitute-command-keys " in `"))
@@ -791,21 +791,19 @@ Call `cl--find-class' to get TYPE's propname `cl--class'"
(setq cur (cl--class-name cur))
(insert (substitute-quotes "`"))
(help-insert-xref-button (symbol-name cur)
- 'cl-help-type cur)
+ 'help-type cur)
(insert (substitute-command-keys (if pl "', " "'"))))
(insert ".\n")))
- ;; Children, if available. ¡For EIEIO!
- (let ((ch (condition-case nil
- (cl-struct-slot-value metatype 'children class)
- (cl-struct-unknown-slot nil)))
+ ;; Children.
+ (let ((ch (cl--class-children class))
cur)
(when ch
(insert " Children ")
(while (setq cur (pop ch))
(insert (substitute-quotes "`"))
(help-insert-xref-button (symbol-name cur)
- 'cl-help-type cur)
+ 'help-type cur)
(insert (substitute-command-keys (if ch "', " "'"))))
(insert ".\n")))
@@ -877,7 +875,7 @@ Call `cl--find-class' to get TYPE's propname `cl--class'"
"%s")
formats)
(cl-incf col (+ col-space (aref cols i))))
- (let ((format (mapconcat #'identity (nreverse formats) "")))
+ (let ((format (mapconcat #'identity (nreverse formats))))
(insert (apply #'format format
(mapcar (lambda (str) (propertize str 'face 'italic))
header))
@@ -902,22 +900,25 @@ Outputs to the current buffer."
(cslots (condition-case nil
(cl-struct-slot-value metatype 'class-slots class)
(cl-struct-unknown-slot nil))))
- (insert (propertize "Instance Allocated Slots:\n\n"
- 'face 'bold))
- (let* ((has-doc nil)
- (slots-strings
- (mapcar
- (lambda (slot)
- (list (cl-prin1-to-string (cl--slot-descriptor-name slot))
- (cl-prin1-to-string (cl--slot-descriptor-type slot))
- (cl-prin1-to-string (cl--slot-descriptor-initform slot))
- (let ((doc (alist-get :documentation
- (cl--slot-descriptor-props slot))))
- (if (not doc) ""
- (setq has-doc t)
- (substitute-command-keys doc)))))
- slots)))
- (cl--print-table `("Name" "Type" "Default") slots-strings has-doc))
+ (if (and (null slots) (eq metatype 'built-in-class))
+ (insert "This is a built-in type.\n")
+
+ (insert (propertize "Instance Allocated Slots:\n\n"
+ 'face 'bold))
+ (let* ((has-doc nil)
+ (slots-strings
+ (mapcar
+ (lambda (slot)
+ (list (cl-prin1-to-string (cl--slot-descriptor-name slot))
+ (cl-prin1-to-string (cl--slot-descriptor-type slot))
+ (cl-prin1-to-string (cl--slot-descriptor-initform slot))
+ (let ((doc (alist-get :documentation
+ (cl--slot-descriptor-props slot))))
+ (if (not doc) ""
+ (setq has-doc t)
+ (substitute-command-keys doc)))))
+ slots)))
+ (cl--print-table `("Name" "Type" "Default") slots-strings has-doc)))
(insert "\n")
(when (> (length cslots) 0)
(insert (propertize "\nClass Allocated Slots:\n\n" 'face 'bold))
diff --git a/lisp/emacs-lisp/cl-generic.el b/lisp/emacs-lisp/cl-generic.el
index bbead31659b..8bda857afdd 100644
--- a/lisp/emacs-lisp/cl-generic.el
+++ b/lisp/emacs-lisp/cl-generic.el
@@ -272,7 +272,7 @@ DEFAULT-BODY, if present, is used as the body of a default method.
(list
(macroexp-warn-and-return
(format "Non-symbol arguments to cl-defgeneric: %s"
- (mapconcat #'prin1-to-string nonsymargs ""))
+ (mapconcat #'prin1-to-string nonsymargs " "))
nil nil nil nonsymargs)))))
next-head)
(while (progn (setq next-head (car-safe (car options-and-methods)))
@@ -672,7 +672,7 @@ The set of acceptable TYPEs (also called \"specializers\") is defined
;; 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)))
+ (if (not (compiled-function-p (lambda (x) (+ x 1))))
(lambda (exp) (eval exp t))
;; But do byte-compile the dispatchers once bootstrap is passed:
;; the performance difference is substantial (like a 5x speedup on
@@ -1101,10 +1101,10 @@ MET-NAME is as returned by `cl--generic-load-hist-format'."
(qualifiers (cl--generic-method-qualifiers method))
(call-con (cl--generic-method-call-con method))
(function (cl--generic-method-function method))
- (args (help-function-arglist (if (not (eq call-con 'curried))
- function
- (funcall function #'ignore))
- 'names))
+ (function (if (not (eq call-con 'curried))
+ function
+ (funcall function #'ignore)))
+ (args (help-function-arglist function 'names))
(docstring (documentation function))
(qual-string
(if (null qualifiers) ""
@@ -1140,12 +1140,8 @@ MET-NAME is as returned by `cl--generic-load-hist-format'."
(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
- ;; this point.
- (declare-function help-fns-short-filename "help-fns" (filename))
(let ((generic (if (symbolp function) (cl--generic function))))
(when generic
- (require 'help-mode) ;Needed for `help-function-def' button!
(save-excursion
;; Ensure that we have two blank lines (but not more).
(unless (looking-back "\n\n" (- (point) 2))
@@ -1153,33 +1149,49 @@ MET-NAME is as returned by `cl--generic-load-hist-format'."
(insert "This is a generic function.\n\n")
(insert (propertize "Implementations:\n\n" 'face 'bold))
;; Loop over fanciful generics
- (dolist (method (cl--generic-method-table generic))
- (pcase-let*
- ((`(,qualifiers ,args ,doc) (cl--generic-method-info method)))
- ;; FIXME: Add hyperlinks for the types as well.
- (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)
- (cl--generic-method-specializers method)))
- (file (find-lisp-object-file-name met-name 'cl-defmethod)))
- (when file
- (insert (substitute-command-keys " in `"))
- (help-insert-xref-button (help-fns-short-filename file)
- 'help-function-def met-name file
- 'cl-defmethod)
- (insert (substitute-command-keys "'.\n"))))
- (insert "\n" (or doc "Undocumented") "\n\n")))))))
+ (cl--map-methods-documentation
+ function
+ (lambda (quals signature file doc)
+ (insert (format "%s%S%s\n\n%s\n\n"
+ quals signature
+ (if file (format-message " in `%s'." file) "")
+ (or doc "Undocumented")))))))))
+
+(defun cl--map-methods-documentation (funname metname-printer)
+ "Iterate on FUNNAME's methods documentation at point."
+ ;; Supposedly this is called from help-fns, so help-fns should be loaded at
+ ;; this point.
+ (require 'help-fns)
+ (declare-function help-fns-short-filename "help-fns" (filename))
+ (let ((generic (if (symbolp funname) (cl--generic funname))))
+ (when generic
+ (require 'help-mode) ;Needed for `help-function-def' button!
+ ;; Loop over fanciful generics
+ (dolist (method (cl--generic-method-table generic))
+ (pcase-let*
+ ((`(,qualifiers ,args ,doc) (cl--generic-method-info method))
+ ;; FIXME: Add hyperlinks for the types as well.
+ (quals (if (length> qualifiers 0)
+ (concat (substring qualifiers
+ 0 (string-match " *\\'"
+ qualifiers))
+ "\n")
+ ""))
+ (met-name (cl--generic-load-hist-format
+ funname
+ (cl--generic-method-qualifiers method)
+ (cl--generic-method-specializers method)))
+ (file (find-lisp-object-file-name met-name 'cl-defmethod)))
+ (funcall metname-printer
+ quals
+ (cons funname
+ (cl--generic-upcase-formal-args args))
+ (when file
+ (make-text-button (help-fns-short-filename file) nil
+ 'type 'help-function-def
+ 'help-args
+ (list met-name file 'cl-defmethod)))
+ doc))))))
(defun cl--generic-specializers-apply-to-type-p (specializers type)
"Return non-nil if a method with SPECIALIZERS applies to TYPE."
@@ -1318,67 +1330,38 @@ These match if the argument is `eql' to VAL."
(cl--generic-prefill-dispatchers (terminal-parameter nil 'xterm--set-selection)
(eql nil))
-;;; Support for cl-defstructs specializers.
+;;; Dispatch on "normal types".
-(defun cl--generic-struct-tag (name &rest _)
- ;; Use exactly the same code as for `typeof'.
- `(if ,name (type-of ,name) 'null))
-
-(defun cl--generic-struct-specializers (tag &rest _)
+(defun cl--generic-type-specializers (tag &rest _)
(and (symbolp tag)
- (let ((class (get tag 'cl--class)))
- (when (cl-typep class 'cl-structure-class)
+ (let ((class (cl--find-class tag)))
+ (when class
(cl--class-allparents class)))))
-(cl-generic-define-generalizer cl--generic-struct-generalizer
- 50 #'cl--generic-struct-tag
- #'cl--generic-struct-specializers)
-
-(cl-defmethod cl-generic-generalizers :extra "cl-struct" (type)
- "Support for dispatch on types defined by `cl-defstruct'."
- (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 'cl-structure-class)
- (or (null (cl--struct-class-type class))
- (error "Can't dispatch on cl-struct %S: type is %S"
- type (cl--struct-class-type class)))
- (progn (cl-assert (null (cl--struct-class-named class))) t)
- (list cl--generic-struct-generalizer))))
- (cl-call-next-method)))
-
-(cl--generic-prefill-dispatchers 0 cl--generic-generalizer)
-
-;;; Dispatch on "system types".
-
(cl-generic-define-generalizer cl--generic-typeof-generalizer
- ;; FIXME: We could also change `type-of' to return `null' for nil.
- 10 (lambda (name &rest _) `(if ,name (type-of ,name) 'null))
- (lambda (tag &rest _)
- (and (symbolp tag) (assq tag cl--typeof-types))))
+ 10 (lambda (name &rest _) `(cl-type-of ,name))
+ #'cl--generic-type-specializers)
(cl-defmethod cl-generic-generalizers :extra "typeof" (type)
- "Support for dispatch on builtin types.
-See the full list and their hierarchy in `cl--typeof-types'."
- ;; FIXME: Add support for other types accepted by `cl-typep' such
- ;; as `character', `face', `function', ...
+ "Support for dispatch on types.
+This currently works for built-in types and types built on top of records."
+ ;; FIXME: Add support for other "types" accepted by `cl-typep' such
+ ;; as `character', `face', `keyword', ...?
(or
- (and (memq type cl--all-builtin-types)
- (progn
- ;; FIXME: While this wrinkle in the semantics can be occasionally
- ;; problematic, this warning is more often annoying than helpful.
- ;;(if (memq type '(vector array sequence))
- ;; (message "`%S' also matches CL structs and EIEIO classes"
- ;; type))
- (list cl--generic-typeof-generalizer)))
+ (and (symbolp type)
+ (not (eq type t)) ;; Handled by the `t-generalizer'.
+ (let ((class (cl--find-class type)))
+ (memq (type-of class)
+ '(built-in-class cl-structure-class eieio--class)))
+ (list cl--generic-typeof-generalizer))
(cl-call-next-method)))
(cl--generic-prefill-dispatchers 0 integer)
(cl--generic-prefill-dispatchers 1 integer)
(cl--generic-prefill-dispatchers 0 cl--generic-generalizer integer)
+(cl--generic-prefill-dispatchers 0 (eql 'x) integer)
+
+(cl--generic-prefill-dispatchers 0 cl--generic-generalizer)
;;; Dispatch on major mode.
@@ -1391,11 +1374,8 @@ See the full list and their hierarchy in `cl--typeof-types'."
(defun cl--generic-derived-specializers (mode &rest _)
;; FIXME: Handle (derived-mode <mode1> ... <modeN>)
- (let ((specializers ()))
- (while mode
- (push `(derived-mode ,mode) specializers)
- (setq mode (get mode 'derived-mode-parent)))
- (nreverse specializers)))
+ (mapcar (lambda (mode) `(derived-mode ,mode))
+ (derived-mode-all-parents mode)))
(cl-generic-define-generalizer cl--generic-derived-generalizer
90 (lambda (name) `(and (symbolp ,name) (functionp ,name) ,name))
@@ -1420,19 +1400,13 @@ Used internally for the (major-mode MODE) context specializers."
(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--generic-type-specializers)
(cl-defmethod cl-generic-generalizers :extra "oclosure-struct" (type)
"Support for dispatch on types defined by `oclosure-define'."
diff --git a/lisp/emacs-lisp/cl-indent.el b/lisp/emacs-lisp/cl-indent.el
index 7697cb12429..f3d076772e3 100644
--- a/lisp/emacs-lisp/cl-indent.el
+++ b/lisp/emacs-lisp/cl-indent.el
@@ -192,7 +192,7 @@ the standard Lisp indent package."
(list
(cond ((not (lisp-extended-loop-p (elt state 1)))
(+ loop-indentation lisp-simple-loop-indentation))
- ((looking-at "^\\s-*\\(:?\\sw+\\|;\\)")
+ ((looking-at "^\\s-*\\(?::?\\sw+\\|;\\)")
(+ loop-indentation lisp-loop-keyword-indentation))
(t
(+ loop-indentation lisp-loop-forms-indentation)))
diff --git a/lisp/emacs-lisp/cl-lib.el b/lisp/emacs-lisp/cl-lib.el
index 87d0b936620..108dcd31f48 100644
--- a/lisp/emacs-lisp/cl-lib.el
+++ b/lisp/emacs-lisp/cl-lib.el
@@ -171,6 +171,17 @@ to an element already in the list stored in PLACE.
val
(and (< end (length str)) (substring str end))))
+(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)
+ (lambda (v)
+ (macroexp-let2 nil v v
+ `(progn
+ ,(funcall setter `(cl--set-substring
+ ,getter ,start ,end ,v))
+ ,v))))))))
;;; Blocks and exits.
@@ -204,7 +215,7 @@ should return.
Note that Emacs Lisp doesn't really support multiple values, so
all this function does is return LIST."
(unless (listp list)
- (signal 'wrong-type-argument list))
+ (signal 'wrong-type-argument (list list)))
list)
(defsubst cl-multiple-value-list (expression)
@@ -462,6 +473,7 @@ Thus, `(cl-list* A B C D)' is equivalent to `(nconc (list A B C) D)', or to
(defun cl-copy-list (list)
"Return a copy of LIST, which may be a dotted list.
The elements of LIST are not copied, just the list structure itself."
+ (declare (side-effect-free error-free))
(if (consp list)
(let ((res nil))
(while (consp list) (push (pop list) res))
@@ -524,7 +536,12 @@ If ALIST is non-nil, the new pairs are prepended to it."
(unless (load "cl-loaddefs" 'noerror 'quiet)
;; When bootstrapping, cl-loaddefs hasn't been built yet!
(require 'cl-macs)
- (require 'cl-seq))
+ (require 'cl-seq)
+ ;; FIXME: Arguably we should also load `cl-extra', except that this
+ ;; currently causes more bootstrap troubles, and `cl-extra' is
+ ;; rarely used, so instead we explicitly (require 'cl-extra) at
+ ;; those rare places where we do need it.
+ )
(defun cl--old-struct-type-of (orig-fun object)
(or (and (vectorp object) (> (length object) 0)
@@ -562,6 +579,7 @@ of record objects."
(advice-add 'type-of :around #'cl--old-struct-type-of))
(t
(advice-remove 'type-of #'cl--old-struct-type-of))))
+(make-obsolete 'cl-old-struct-compat-mode nil "30.1")
(defun cl-constantly (value)
"Return a function that takes any number of arguments, but returns VALUE."
diff --git a/lisp/emacs-lisp/cl-macs.el b/lisp/emacs-lisp/cl-macs.el
index 732deda618d..a84ef4a34b2 100644
--- a/lisp/emacs-lisp/cl-macs.el
+++ b/lisp/emacs-lisp/cl-macs.el
@@ -101,6 +101,7 @@
(and (> size 0) (1- size))))
(defun cl--simple-exprs-p (xs)
+ "Map `cl--simple-expr-p' to each element of list XS."
(while (and xs (cl--simple-expr-p (car xs)))
(setq xs (cdr xs)))
(not xs))
@@ -116,8 +117,10 @@
(while (and (setq x (cdr x)) (cl--safe-expr-p (car x))))
(null x)))))
-;;; Check if constant (i.e., no side effects or dependencies).
(defun cl--const-expr-p (x)
+ "Check if X is constant (i.e., no side effects or dependencies).
+
+See `macroexp-const-p' for similar functionality without cl-lib dependency."
(cond ((consp x)
(or (eq (car x) 'quote)
(and (memq (car x) '(function cl-function))
@@ -243,6 +246,29 @@ The name is made by appending a number to PREFIX, default \"T\"."
(defvar cl--bind-enquote) ;Non-nil if &cl-quote was in the formal arglist!
(defvar cl--bind-lets) (defvar cl--bind-forms)
+(defun cl--slet (bindings body &optional nowarn)
+ "Like `cl--slet*' but for \"parallel let\"."
+ (let ((dyns nil)) ;Vars declared as dynbound among the bindings?
+ (when lexical-binding
+ (dolist (binding bindings) ;; `seq-some' lead to bootstrap problems.
+ (when (macroexp--dynamic-variable-p (car binding))
+ (push (car binding) dyns))))
+ (cond
+ (dyns
+ (let ((form `(funcall (lambda (,@(mapcar #'car bindings))
+ ,@(macroexp-unprogn body))
+ ,@(mapcar #'cadr bindings))))
+ (if (not nowarn) form
+ `(with-suppressed-warnings ((lexical ,@dyns)) ,form))))
+ ((null (cdr bindings))
+ (macroexp-let* bindings body))
+ (t `(let ,bindings ,@(macroexp-unprogn body))))))
+
+(defun cl--slet* (bindings body)
+ "Like `macroexp-let*' but uses static scoping for all the BINDINGS."
+ (if (null bindings) body
+ (cl--slet `(,(car bindings)) (cl--slet* (cdr bindings) body))))
+
(defun cl--transform-lambda (form bind-block)
"Transform a function form FORM of name BIND-BLOCK.
BIND-BLOCK is the name of the symbol to which the function will be bound,
@@ -337,10 +363,11 @@ FORM is of the form (ARGS . BODY)."
(list '&rest (car (pop cl--bind-lets))))))))
`((,@(nreverse simple-args) ,@rest-args)
,@header
- ,(macroexp-let* cl--bind-lets
- (macroexp-progn
- `(,@(nreverse cl--bind-forms)
- ,@body)))))))
+ ;; Function arguments are unconditionally statically scoped (bug#47552).
+ ,(cl--slet* cl--bind-lets
+ (macroexp-progn
+ `(,@(nreverse cl--bind-forms)
+ ,@body)))))))
;;;###autoload
(defmacro cl-defun (name args &rest body)
@@ -365,7 +392,7 @@ more details.
\(fn NAME ARGLIST [DOCSTRING] BODY...)"
(declare (debug
;; Same as defun but use cl-lambda-list.
- (&define [&name sexp] ;Allow (setf ...) additionally to symbols.
+ (&define [&name symbolp]
cl-lambda-list
cl-declarations-or-string
[&optional ("interactive" interactive)]
@@ -1441,6 +1468,7 @@ For more details, see Info node `(cl)Loop Facility'.
(t (setq buf (cl--pop2 cl--loop-args)))))
(if (and (consp var) (symbolp (car var)) (symbolp (cdr var)))
(setq var1 (car var) var2 (cdr var))
+ (push (list var nil) loop-for-bindings)
(push (list var `(cons ,var1 ,var2)) loop-for-sets))
(cl--loop-set-iterator-function
'intervals (lambda (body)
@@ -2013,7 +2041,16 @@ a `let' form, except that the list of symbols can be computed at run-time."
;; *after* handling `function', but we want to stop macroexpansion from
;; being applied infinitely, so we use a cache to return the exact `form'
;; being expanded even though we don't receive it.
- ((eq f (car cl--labels-convert-cache)) (cdr cl--labels-convert-cache))
+ ;; In Common Lisp, we'd use the `&whole' arg instead (see
+ ;; "Macro Lambda Lists" in the CLHS).
+ ((let ((symbols-with-pos-enabled nil)) ;Don't rewrite #'<X@5> => #'<X@3>
+ (eq f (car cl--labels-convert-cache)))
+ ;; This value should be `eq' to the `&whole' form.
+ ;; If this is not the case, we have a bug.
+ (prog1 (cdr cl--labels-convert-cache)
+ ;; Drop it, so it can't accidentally interfere with some
+ ;; unrelated subsequent use of `function' with the same symbol.
+ (setq cl--labels-convert-cache nil)))
(t
(let* ((found (assq f macroexpand-all-environment))
(replacement (and found
@@ -2021,6 +2058,8 @@ a `let' form, except that the list of symbols can be computed at run-time."
(funcall (cdr found) cl--labels-magic)))))
(if (and replacement (eq cl--labels-magic (car replacement)))
(nth 1 replacement)
+ ;; FIXME: Here, we'd like to return the `&whole' form, but since ELisp
+ ;; doesn't have that, we approximate it via `cl--labels-convert-cache'.
(let ((res `(function ,f)))
(setq cl--labels-convert-cache (cons f res))
res))))))
@@ -2040,6 +2079,13 @@ info node `(cl) Function Bindings' for details.
\(fn ((FUNC ARGLIST BODY...) ...) FORM...)"
(declare (indent 1)
+ ;; The first (symbolp form) case doesn't use `&name' because
+ ;; it's hard to associate this name with the body of the function
+ ;; that `form' will return (bug#65344).
+ ;; We could try and use a `&name' for those cases where the
+ ;; body of the function can be found, (e.g. the form wraps
+ ;; some `prog1/progn/let' around the final `lambda'), but it's
+ ;; not clear it's worth the trouble.
(debug ((&rest [&or (symbolp form)
(&define [&name symbolp "@cl-flet@"]
[&name [] gensym] ;Make it unique!
@@ -2052,7 +2098,8 @@ info node `(cl) Function Bindings' for details.
(dolist (binding bindings)
(let ((var (make-symbol (format "--cl-%s--" (car binding))))
(args-and-body (cdr binding)))
- (if (and (= (length args-and-body) 1) (symbolp (car args-and-body)))
+ (if (and (= (length args-and-body) 1)
+ (macroexp-copyable-p (car args-and-body)))
;; Optimize (cl-flet ((fun var)) body).
(setq var (car args-and-body))
(push (list var (if (= (length args-and-body) 1)
@@ -2757,26 +2804,29 @@ Each PLACE may be a symbol, or any generalized variable allowed by `setf'.
;; Common-Lisp's `psetf' does the first, so we'll do the same.
(if (null bindings)
(if (and (null binds) (null simplebinds)) (macroexp-progn body)
+ (let ((body-form
+ (macroexp-progn
+ (append
+ (delq nil
+ (mapcar (lambda (x)
+ (pcase x
+ ;; If there's no vnew, do nothing.
+ (`(,_vold ,_getter ,setter ,vnew)
+ (funcall setter vnew))))
+ binds))
+ body))))
`(let* (,@(mapcar (lambda (x)
(pcase-let ((`(,vold ,getter ,_setter ,_vnew) x))
(list vold getter)))
binds)
,@simplebinds)
- (unwind-protect
- ,(macroexp-progn
- (append
- (delq nil
- (mapcar (lambda (x)
- (pcase x
- ;; If there's no vnew, do nothing.
- (`(,_vold ,_getter ,setter ,vnew)
- (funcall setter vnew))))
- binds))
- body))
- ,@(mapcar (lambda (x)
- (pcase-let ((`(,vold ,_getter ,setter ,_vnew) x))
- (funcall setter vold)))
- binds))))
+ ,(if binds
+ `(unwind-protect ,body-form
+ ,@(mapcar (lambda (x)
+ (pcase-let ((`(,vold ,_getter ,setter ,_vnew) x))
+ (funcall setter vold)))
+ binds))
+ body-form))))
(let* ((binding (car bindings))
(place (car binding)))
(gv-letplace (getter setter) place
@@ -2884,48 +2934,25 @@ The function's arguments should be treated as immutable.
,(if (memq '&key args)
`(&whole cl-whole &cl-quote ,@args)
(cons '&cl-quote args))
- ,(format "compiler-macro for inlining `%s'." name)
+ ;; NB. This will produce incorrect results in some
+ ;; cases, as our coding conventions says that the first
+ ;; line must be a full sentence. However, if we don't
+ ;; word wrap we will have byte-compiler warnings about
+ ;; overly long docstrings. So we can't have a perfect
+ ;; result here, and choose to avoid the byte-compiler
+ ;; warnings.
+ ,(internal--format-docstring-line "compiler-macro for `%s'." name)
(cl--defsubst-expand
',argns '(cl-block ,name ,@(cdr (macroexp-parse-body body)))
- ;; We used to pass `simple' as
- ;; (not (or unsafe (cl-expr-access-order pbody argns)))
- ;; But this is much too simplistic since it
- ;; does not pay attention to the argvs (and
- ;; cl-expr-access-order itself is also too naive).
nil
,(and (memq '&key args) 'cl-whole) nil ,@argns)))
(cl-defun ,name ,args ,@body))))
-(defun cl--defsubst-expand (argns body simple whole _unsafe &rest argvs)
- (if (and whole (not (cl--safe-expr-p (cons 'progn argvs)))) whole
- (if (cl--simple-exprs-p argvs) (setq simple t))
- (let* ((substs ())
- (lets (delq nil
- (cl-mapcar (lambda (argn argv)
- (if (or simple (macroexp-const-p argv))
- (progn (push (cons argn argv) substs)
- nil)
- (list argn argv)))
- argns argvs))))
- ;; FIXME: `sublis/subst' will happily substitute the symbol
- ;; `argn' in places where it's not used as a reference
- ;; to a variable.
- ;; FIXME: `sublis/subst' will happily copy `argv' to a different
- ;; scope, leading to name capture.
- (setq body (cond ((null substs) body)
- ((null (cdr substs))
- (cl-subst (cdar substs) (caar substs) body))
- (t (cl--sublis substs body))))
- (if lets `(let ,lets ,body) body))))
-
-(defun cl--sublis (alist tree)
- "Perform substitutions indicated by ALIST in TREE (non-destructively)."
- (let ((x (assq tree alist)))
- (cond
- (x (cdr x))
- ((consp tree)
- (cons (cl--sublis alist (car tree)) (cl--sublis alist (cdr tree))))
- (t tree))))
+(defun cl--defsubst-expand (argns body _simple whole _unsafe &rest argvs)
+ (if (and whole (not (cl--safe-expr-p (macroexp-progn argvs))))
+ whole
+ ;; Function arguments are unconditionally statically scoped (bug#47552).
+ (cl--slet (cl-mapcar #'list argns argvs) body 'nowarn)))
;;; Structures.
@@ -3017,6 +3044,7 @@ To see the documentation for a defined struct type, use
(defsym (if cl--struct-inline 'cl-defsubst 'defun))
(forms nil)
(docstring (if (stringp (car descs)) (pop descs)))
+ (dynbound-slotnames '())
pred-form pred-check)
;; Can't use `cl-check-type' yet.
(unless (cl--struct-name-p name)
@@ -3067,7 +3095,11 @@ To see the documentation for a defined struct type, use
descs)))
(t
(error "Structure option %s unrecognized" opt)))))
- (unless (or include-name type)
+ (unless (or include-name type
+ ;; Don't create a bogus parent to `cl-structure-object'
+ ;; while compiling the (cl-defstruct cl-structure-object ..)
+ ;; in `cl-preloaded.el'.
+ (eq name cl--struct-default-parent))
(setq include-name cl--struct-default-parent))
(when include-name (setq include (cl--struct-get-class include-name)))
(if print-func
@@ -3120,19 +3152,24 @@ To see the documentation for a defined struct type, use
(cons 'and (cdddr pred-form))
`(,predicate cl-x))))
(when pred-form
- (push `(,defsym ,predicate (cl-x)
+ (push `(eval-and-compile
+ ;; Define the predicate to be effective at compile time
+ ;; as native comp relies on `cl-typep' that relies on
+ ;; predicates to be defined as they are registered in
+ ;; cl-deftype-satisfies.
+ (,defsym ,predicate (cl-x)
(declare (side-effect-free error-free) (pure t))
,(if (eq (car pred-form) 'and)
(append pred-form '(t))
`(and ,pred-form t)))
- forms)
- (push `(eval-and-compile
(define-symbol-prop ',name 'cl-deftype-satisfies ',predicate))
forms))
(let ((pos 0) (descp descs))
(while descp
(let* ((desc (pop descp))
(slot (pop desc)))
+ (when (macroexp--dynamic-variable-p slot)
+ (push slot dynbound-slotnames))
(if (memq slot '(cl-tag-slot cl-skip-slot))
(progn
(push nil slots)
@@ -3157,26 +3194,39 @@ To see the documentation for a defined struct type, use
;; The arg "cl-x" is referenced by name in e.g. pred-form
;; and pred-check, so changing it is not straightforward.
(push `(,defsym ,accessor (cl-x)
- ,(concat
- ;; NB. This will produce incorrect results
- ;; in some cases, as our coding conventions
- ;; says that the first line must be a full
- ;; sentence. However, if we don't word wrap
- ;; we will have byte-compiler warnings about
- ;; overly long docstrings. So we can't have
- ;; a perfect result here, and choose to avoid
- ;; the byte-compiler warnings.
- (internal--format-docstring-line
- "Access slot \"%s\" of `%s' struct CL-X." slot name)
- (if doc (concat "\n" doc) ""))
+ ,(let ((long-docstring
+ (format "Access slot \"%s\" of `%s' struct CL-X." slot name)))
+ (concat
+ ;; NB. This will produce incorrect results
+ ;; in some cases, as our coding conventions
+ ;; says that the first line must be a full
+ ;; sentence. However, if we don't word
+ ;; wrap we will have byte-compiler warnings
+ ;; about overly long docstrings. So we
+ ;; can't have a perfect result here, and
+ ;; choose to avoid the byte-compiler
+ ;; warnings.
+ (if (>= (length long-docstring)
+ (or (bound-and-true-p
+ byte-compile-docstring-max-column)
+ 80))
+ (concat
+ (internal--format-docstring-line
+ "Access slot \"%s\" of CL-X." slot)
+ "\n"
+ (internal--format-docstring-line
+ "Struct CL-X is a `%s'." name))
+ (internal--format-docstring-line long-docstring))
+ (if doc (concat "\n" doc) "")))
(declare (side-effect-free t))
,access-body)
forms)
(when (cl-oddp (length desc))
(push
(macroexp-warn-and-return
- (format "Missing value for option `%S' of slot `%s' in struct %s!"
- (car (last desc)) slot name)
+ (format-message
+ "Missing value for option `%S' of slot `%s' in struct %s!"
+ (car (last desc)) slot name)
nil nil nil (car (last desc)))
forms)
(when (and (keywordp (car defaults))
@@ -3184,8 +3234,9 @@ To see the documentation for a defined struct type, use
(let ((kw (car defaults)))
(push
(macroexp-warn-and-return
- (format " I'll take `%s' to be an option rather than a default value."
- kw)
+ (format-message
+ " I'll take `%s' to be an option rather than a default value."
+ kw)
nil nil nil kw)
forms)
(push kw desc)
@@ -3238,22 +3289,20 @@ To see the documentation for a defined struct type, use
(let* ((anames (cl--arglist-args args))
(make (cl-mapcar (lambda (s d) (if (memq s anames) s d))
slots defaults))
- ;; `cl-defsubst' is fundamentally broken: it substitutes
- ;; its arguments into the body's `sexp' much too naively
- ;; when inlinling, which results in various problems.
- ;; For example it generates broken code if your
- ;; argument's name happens to be the same as some
- ;; function used within the body.
- ;; E.g. (cl-defsubst sm-foo (list) (list list))
- ;; will expand `(sm-foo 1)' to `(1 1)' rather than to `(list t)'!
- ;; Try to catch this known case!
- (con-fun (or type #'record))
- (unsafe-cl-defsubst
- (or (memq con-fun args) (assq con-fun args))))
- (push `(,(if unsafe-cl-defsubst 'cl-defun cldefsym) ,cname
+ (con-fun (or type #'record)))
+ (push `(,cldefsym ,cname
(&cl-defs (nil ,@descs) ,@args)
,(if (stringp doc) doc
- (format "Constructor for objects of type `%s'." name))
+ ;; NB. This will produce incorrect results in
+ ;; some cases, as our coding conventions says that
+ ;; the first line must be a full sentence.
+ ;; However, if we don't word wrap we will have
+ ;; byte-compiler warnings about overly long
+ ;; docstrings. So we can't have a perfect result
+ ;; here, and choose to avoid the byte-compiler
+ ;; warnings.
+ (internal--format-docstring-line
+ "Constructor for objects of type `%s'." name))
,@(if (cl--safe-expr-p `(progn ,@(mapcar #'cl-second descs)))
'((declare (side-effect-free t))))
(,con-fun ,@make))
@@ -3272,7 +3321,10 @@ To see the documentation for a defined struct type, use
;; forms))
`(progn
(defvar ,tag-symbol)
- ,@(nreverse forms)
+ ,@(if (null dynbound-slotnames)
+ (nreverse forms)
+ `((with-suppressed-warnings ((lexical . ,dynbound-slotnames))
+ ,@(nreverse forms))))
:autoload-end
;; Call cl-struct-define during compilation as well, so that
;; a subsequent cl-defstruct in the same file can correctly include this
@@ -3285,18 +3337,6 @@ To see the documentation for a defined struct type, use
;;; Add cl-struct support to pcase
-(defun cl--struct-all-parents (class)
- (when (cl--struct-class-p class)
- (let ((res ())
- (classes (list class)))
- ;; BFS precedence.
- (while (let ((class (pop classes)))
- (push class res)
- (setq classes
- (append classes
- (cl--class-parents class)))))
- (nreverse res))))
-
;;;###autoload
(pcase-defmacro cl-struct (type &rest fields)
"Pcase patterns that match cl-struct EXPVAL of type TYPE.
@@ -3304,14 +3344,14 @@ Elements of FIELDS can be of the form (NAME PAT) in which case the
contents of field NAME is matched against PAT, or they can be of
the form NAME which is a shorthand for (NAME NAME)."
(declare (debug (sexp &rest [&or (sexp pcase-PAT) sexp])))
- `(and (pred (pcase--flip cl-typep ',type))
+ `(and (pred (cl-typep _ ',type))
,@(mapcar
(lambda (field)
(let* ((name (if (consp field) (car field) field))
(pat (if (consp field) (cadr field) field)))
`(app ,(if (eq (cl-struct-sequence-type type) 'list)
`(nth ,(cl-struct-slot-offset type name))
- `(pcase--flip aref ,(cl-struct-slot-offset type name)))
+ `(aref _ ,(cl-struct-slot-offset type name)))
,pat)))
fields)))
@@ -3328,13 +3368,13 @@ the form NAME which is a shorthand for (NAME NAME)."
"Extra special cases for `cl-typep' predicates."
(let* ((x1 pred1) (x2 pred2)
(t1
- (and (eq 'pcase--flip (car-safe x1)) (setq x1 (cdr x1))
- (eq 'cl-typep (car-safe x1)) (setq x1 (cdr x1))
+ (and (eq 'cl-typep (car-safe x1)) (setq x1 (cdr x1))
+ (eq '_ (car-safe x1)) (setq x1 (cdr x1))
(null (cdr-safe x1)) (setq x1 (car x1))
(eq 'quote (car-safe x1)) (cadr x1)))
(t2
- (and (eq 'pcase--flip (car-safe x2)) (setq x2 (cdr x2))
- (eq 'cl-typep (car-safe x2)) (setq x2 (cdr x2))
+ (and (eq 'cl-typep (car-safe x2)) (setq x2 (cdr x2))
+ (eq '_ (car-safe x2)) (setq x2 (cdr x2))
(null (cdr-safe x2)) (setq x2 (car x2))
(eq 'quote (car-safe x2)) (cadr x2))))
(or
@@ -3342,8 +3382,8 @@ the form NAME which is a shorthand for (NAME NAME)."
(let ((c1 (cl--find-class t1))
(c2 (cl--find-class t2)))
(and c1 c2
- (not (or (memq c1 (cl--struct-all-parents c2))
- (memq c2 (cl--struct-all-parents c1)))))))
+ (not (or (memq t1 (cl--class-allparents c2))
+ (memq t2 (cl--class-allparents c1)))))))
(let ((c1 (and (symbolp t1) (cl--find-class t1))))
(and c1 (cl--struct-class-p c1)
(funcall orig (cl--defstruct-predicate t1)
@@ -3420,44 +3460,20 @@ Of course, we really can't know that for sure, so it's just a heuristic."
(or (cdr (assq sym byte-compile-function-environment))
(cdr (assq sym macroexpand-all-environment))))))
+;; Please keep it in sync with `comp-known-predicates'.
(pcase-dolist (`(,type . ,pred)
;; Mostly kept in alphabetical order.
- '((array . arrayp)
- (atom . atom)
- (base-char . characterp)
- (bignum . bignump)
- (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 . compiled-function-p)
- (hash-table . hash-table-p)
- (cons . consp)
- (fixnum . fixnump)
- (float . floatp)
- (frame . framep)
- (function . functionp)
- (integer . integerp)
- (keyword . keywordp)
+ ;; These aren't defined via `cl--define-built-in-type'.
+ '((base-char . characterp) ;Could be subtype of `fixnum'.
+ (character . natnump) ;Could be subtype of `fixnum'.
+ (command . commandp) ;Subtype of closure & subr.
+ (keyword . keywordp) ;Would need `keyword-with-pos`.
+ (natnum . natnump) ;Subtype of fixnum & bignum.
+ (real . numberp) ;Not clear where it would fit.
+ ;; This one is redundant, but we keep it to silence a
+ ;; warning during the early bootstrap when `cl-seq.el' gets
+ ;; loaded before `cl-preloaded.el' is defined.
(list . listp)
- (marker . markerp)
- (natnum . natnump)
- (number . numberp)
- (null . null)
- (overlay . overlayp)
- (process . processp)
- (real . numberp)
- (sequence . sequencep)
- (subr . subrp)
- (string . stringp)
- (symbol . symbolp)
- (vector . vectorp)
- (window . windowp)
- ;; FIXME: Do we really want to consider this a type?
- (integer-or-marker . integer-or-marker-p)
))
(put type 'cl-deftype-satisfies pred))
@@ -3575,7 +3591,8 @@ possible. Unlike regular macros, BODY can decide to \"punt\" and leave the
original function call alone by declaring an initial `&whole foo' parameter
and then returning foo."
;; Like `cl-defmacro', but with the `&whole' special case.
- (declare (debug (&define name cl-macro-list
+ (declare (debug (&define [&name symbolp "@cl-compiler-macro"]
+ cl-macro-list
cl-declarations-or-string def-body))
(indent 2))
(let ((p args) (res nil))
@@ -3680,18 +3697,57 @@ macro that returns its `&whole' argument."
;;; Things that are inline.
(cl-proclaim '(inline cl-acons cl-map cl-notany cl-notevery cl-revappend
- cl-nreconc gethash))
+ cl-nreconc))
;;; Things that are side-effect-free.
(mapc (lambda (x) (function-put x 'side-effect-free t))
- '(cl-oddp cl-evenp cl-signum last butlast cl-ldiff cl-pairlis cl-gcd
+ '(cl-oddp cl-evenp cl-signum cl-ldiff cl-pairlis cl-gcd
cl-lcm cl-isqrt cl-floor cl-ceiling cl-truncate cl-round cl-mod cl-rem
cl-subseq cl-list-length cl-get cl-getf))
;;; Things that are side-effect-and-error-free.
(mapc (lambda (x) (function-put x 'side-effect-free 'error-free))
- '(eql cl-list* cl-subst cl-acons cl-equalp
- cl-random-state-p copy-tree cl-sublis))
+ '(cl-list* cl-acons cl-equalp
+ cl-random-state-p copy-tree))
+
+;;; Things whose return value should probably be used.
+(mapc (lambda (x) (function-put x 'important-return-value t))
+ '(
+ ;; Functions that are side-effect-free except for the
+ ;; behavior of functions passed as argument.
+ cl-mapcar cl-mapcan cl-maplist cl-map cl-mapcon
+ cl-reduce
+ cl-assoc cl-assoc-if cl-assoc-if-not
+ cl-rassoc cl-rassoc-if cl-rassoc-if-not
+ cl-member cl-member-if cl-member-if-not
+ cl-adjoin
+ cl-mismatch cl-search
+ cl-find cl-find-if cl-find-if-not
+ cl-position cl-position-if cl-position-if-not
+ cl-count cl-count-if cl-count-if-not
+ cl-remove cl-remove-if cl-remove-if-not
+ cl-remove-duplicates
+ cl-subst cl-subst-if cl-subst-if-not
+ cl-substitute cl-substitute-if cl-substitute-if-not
+ cl-sublis
+ cl-union cl-intersection cl-set-difference cl-set-exclusive-or
+ cl-subsetp
+ cl-every cl-some cl-notevery cl-notany
+ cl-tree-equal
+
+ ;; Functions that mutate and return a list.
+ cl-delete cl-delete-if cl-delete-if-not
+ cl-delete-duplicates
+ cl-nsubst cl-nsubst-if cl-nsubst-if-not
+ cl-nsubstitute cl-nsubstitute-if cl-nsubstitute-if-not
+ cl-nunion cl-nintersection cl-nset-difference cl-nset-exclusive-or
+ cl-nreconc cl-nsublis
+ cl-merge
+ ;; It's safe to ignore the value of `cl-sort' and `cl-stable-sort'
+ ;; when used on arrays, but most calls pass lists.
+ cl-sort cl-stable-sort
+ ))
+
;;; Types and assertions.
@@ -3737,7 +3793,8 @@ STRUCT-TYPE and SLOT-NAME are symbols. INST is a structure instance."
(pcase-defmacro cl-type (type)
"Pcase pattern that matches objects of TYPE.
TYPE is a type descriptor as accepted by `cl-typep', which see."
- `(pred (pcase--flip cl-typep ',type)))
+ `(pred (cl-typep _ ',type)))
+
;; Local variables:
;; generated-autoload-file: "cl-loaddefs.el"
diff --git a/lisp/emacs-lisp/cl-preloaded.el b/lisp/emacs-lisp/cl-preloaded.el
index 7079adb8504..d23ad3972a9 100644
--- a/lisp/emacs-lisp/cl-preloaded.el
+++ b/lisp/emacs-lisp/cl-preloaded.el
@@ -50,51 +50,16 @@
(apply #'error string (append sargs args))
(signal 'cl-assertion-failed `(,form ,@sargs)))))
-(defconst cl--typeof-types
- ;; Hand made from the source code of `type-of'.
- '((integer number number-or-marker 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)
- ;; 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)
- (frame atom) (hash-table atom) (terminal atom)
- (thread atom) (mutex atom) (condvar atom)
- (font-spec atom) (font-entity atom) (font-object atom)
- (vector array sequence atom)
- (user-ptr atom)
- (tree-sitter-parser atom)
- (tree-sitter-node atom)
- (tree-sitter-compiled-query atom)
- ;; Plus, really hand made:
- (null symbol list sequence atom))
- "Alist of supertypes.
-Each element has the form (TYPE . SUPERTYPES) where TYPE is one of
-the symbols returned by `type-of', and SUPERTYPES is the list of its
-supertypes from the most specific to least specific.")
-
-(defconst cl--all-builtin-types
- (delete-dups (copy-sequence (apply #'append cl--typeof-types))))
+(defun cl--builtin-type-p (name)
+ (if (not (fboundp 'built-in-class-p)) ;; Early bootstrap
+ nil
+ (let ((class (and (symbolp name) (get name 'cl--class))))
+ (and class (built-in-class-p class)))))
(defun cl--struct-name-p (name)
"Return t if NAME is a valid structure name for `cl-defstruct'."
(and name (symbolp name) (not (keywordp name))
- (not (memq name cl--all-builtin-types))))
+ (not (cl--builtin-type-p name))))
;; When we load this (compiled) file during pre-loading, the cl--struct-class
;; code below will need to access the `cl-struct' info, since it's considered
@@ -113,6 +78,7 @@ supertypes from the most specific to least specific.")
(record 'cl-slot-descriptor
name initform type props)))
+;; In use by comp.el
(defun cl--struct-get-class (name)
(or (if (not (symbolp name)) name)
(cl--find-class name)
@@ -146,7 +112,7 @@ supertypes from the most specific to least specific.")
(defun cl--struct-register-child (parent tag)
;; Can't use (cl-typep parent 'cl-structure-class) at this stage
;; because `cl-structure-class' is defined later.
- (while (recordp parent)
+ (while (cl--struct-class-p parent)
(add-to-list (cl--struct-class-children-sym parent) tag)
;; Only register ourselves as a child of the leftmost parent since structs
;; can only have one parent.
@@ -158,10 +124,17 @@ supertypes from the most specific to least specific.")
(cl-check-type name (satisfies cl--struct-name-p))
(unless type
;; Legacy defstruct, using tagged vectors. Enable backward compatibility.
- (cl-old-struct-compat-mode 1))
- (if (eq type 'record)
- ;; Defstruct using record objects.
- (setq type nil))
+ (with-suppressed-warnings ((obsolete cl-old-struct-compat-mode))
+ (message "cl-old-struct-compat-mode is obsolete!")
+ (cl-old-struct-compat-mode 1)))
+ (when (eq type 'record)
+ ;; Defstruct using record objects.
+ (setq type nil)
+ ;; `cl-structure-class' and `cl-structure-object' are allowed to be
+ ;; defined without specifying the parent, because their parent
+ ;; doesn't exist yet when they're defined.
+ (cl-assert (or parent (memq name '(cl-structure-class
+ cl-structure-object)))))
(cl-assert (or type (not named)))
(if (boundp children-sym)
(add-to-list children-sym tag)
@@ -169,7 +142,9 @@ supertypes from the most specific to least specific.")
(and (null type) (eq (caar slots) 'cl-tag-slot)
;; Hide the tag slot from "standard" (i.e. non-`type'd) structs.
(setq slots (cdr slots)))
- (let* ((parent-class (when parent (cl--struct-get-class parent)))
+ (let* ((parent-class (if parent (cl--struct-get-class parent)
+ (cl--find-class (if (eq type 'list) 'cons
+ (or type 'record)))))
(n (length slots))
(index-table (make-hash-table :test 'eq :size n))
(vslots (let ((v (make-vector n nil))
@@ -192,7 +167,9 @@ supertypes from the most specific to least specific.")
name docstring
(unless (symbolp parent-class) (list parent-class))
type named vslots index-table children-sym tag print)))
- (unless (symbolp parent-class)
+ (cl-assert (or (not (symbolp parent-class))
+ (memq name '(cl-structure-class cl-structure-object))))
+ (when (cl--struct-class-p parent-class)
(let ((pslots (cl--struct-class-slots parent-class)))
(or (>= n (length pslots))
(let ((ok t))
@@ -283,7 +260,7 @@ supertypes from the most specific to least specific.")
(cl-defstruct (cl--class
(:constructor nil)
(:copier nil))
- "Type of descriptors for any kind of structure-like data."
+ "Abstract supertype of all type descriptors."
;; Intended to be shared between defstruct and defclass.
(name nil :type symbol) ;The type name.
(docstring nil :type string)
@@ -320,15 +297,174 @@ supertypes from the most specific to least specific.")
(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)))
+ (cons (cl--class-name class)
+ (merge-ordered-lists (mapcar #'cl--class-allparents
+ (cl--class-parents class)))))
+
+(cl-defstruct (built-in-class
+ (:include cl--class)
+ (:noinline t)
+ (:constructor nil)
+ (:constructor built-in-class--make (name docstring parents))
+ (:copier nil))
+ "Type descriptors for built-in types.
+The `slots' (and hence `index-table') are currently unused."
+ )
+
+(defmacro cl--define-built-in-type (name parents &optional docstring &rest slots)
+ ;; `slots' is currently unused, but we could make it take
+ ;; a list of "slot like properties" together with the corresponding
+ ;; accessor, and then we could maybe even make `slot-value' work
+ ;; on some built-in types :-)
+ (declare (indent 2) (doc-string 3))
+ (unless (listp parents) (setq parents (list parents)))
+ (unless (or parents (eq name t))
+ (error "Missing parents for %S: %S" name parents))
+ (let ((predicate (intern-soft (format
+ (if (string-match "-" (symbol-name name))
+ "%s-p" "%sp")
+ name))))
+ (unless (fboundp predicate) (setq predicate nil))
+ (while (keywordp (car slots))
+ (let ((kw (pop slots)) (val (pop slots)))
+ (pcase kw
+ (:predicate (setq predicate val))
+ (_ (error "Unknown keyword arg: %S" kw)))))
+ `(progn
+ ,(if predicate `(put ',name 'cl-deftype-satisfies #',predicate)
+ ;; (message "Missing predicate for: %S" name)
+ nil)
+ (put ',name 'cl--class
+ (built-in-class--make ',name ,docstring
+ (mapcar (lambda (type)
+ (let ((class (get type 'cl--class)))
+ (unless class
+ (error "Unknown type: %S" type))
+ class))
+ ',parents))))))
+
+;; FIXME: Our type DAG has various quirks:
+;; - Some `keyword's are also `symbol-with-pos' but that's not reflected
+;; in the DAG.
+;; - An OClosure can be an interpreted function or a `byte-code-function',
+;; so the DAG of OClosure types is "orthogonal" to the distinction
+;; between interpreted and compiled functions.
+
+(defun cl-functionp (object)
+ "Return non-nil if OBJECT is a member of type `function'.
+This is like `functionp' except that it returns nil for all lists and symbols,
+regardless if `funcall' would accept to call them."
+ (memq (cl-type-of object)
+ '(primitive-function subr-native-elisp module-function
+ interpreted-function byte-code-function)))
+
+(cl--define-built-in-type t nil "Abstract supertype of everything.")
+(cl--define-built-in-type atom t "Abstract supertype of anything but cons cells."
+ :predicate atom)
+
+(cl--define-built-in-type tree-sitter-compiled-query atom)
+(cl--define-built-in-type tree-sitter-node atom)
+(cl--define-built-in-type tree-sitter-parser atom)
+(when (fboundp 'user-ptrp)
+ (cl--define-built-in-type user-ptr atom nil
+ ;; FIXME: Shouldn't it be called `user-ptr-p'?
+ :predicate user-ptrp))
+(cl--define-built-in-type font-object atom)
+(cl--define-built-in-type font-entity atom)
+(cl--define-built-in-type font-spec atom)
+(cl--define-built-in-type condvar atom)
+(cl--define-built-in-type mutex atom)
+(cl--define-built-in-type thread atom)
+(cl--define-built-in-type terminal atom)
+(cl--define-built-in-type hash-table atom)
+(cl--define-built-in-type frame atom)
+(cl--define-built-in-type buffer atom)
+(cl--define-built-in-type window atom)
+(cl--define-built-in-type process atom)
+(cl--define-built-in-type finalizer atom)
+(cl--define-built-in-type window-configuration atom)
+(cl--define-built-in-type overlay atom)
+(cl--define-built-in-type number-or-marker atom
+ "Abstract supertype of both `number's and `marker's.")
+(cl--define-built-in-type symbol atom
+ "Type of symbols."
+ ;; Example of slots we could document. It would be desirable to
+ ;; have some way to extract this from the C code, or somehow keep it
+ ;; in sync (probably not for `cons' and `symbol' but for things like
+ ;; `font-entity').
+ (name symbol-name)
+ (value symbol-value)
+ (function symbol-function)
+ (plist symbol-plist))
+
+(cl--define-built-in-type obarray atom)
+(cl--define-built-in-type native-comp-unit atom)
+
+(cl--define-built-in-type sequence t "Abstract supertype of sequences.")
+(cl--define-built-in-type list sequence)
+(cl--define-built-in-type array (sequence atom) "Abstract supertype of arrays.")
+(cl--define-built-in-type number (number-or-marker)
+ "Abstract supertype of numbers.")
+(cl--define-built-in-type float (number))
+(cl--define-built-in-type integer-or-marker (number-or-marker)
+ "Abstract supertype of both `integer's and `marker's.")
+(cl--define-built-in-type integer (number integer-or-marker))
+(cl--define-built-in-type marker (integer-or-marker))
+(cl--define-built-in-type bignum (integer)
+ "Type of those integers too large to fit in a `fixnum'.")
+(cl--define-built-in-type fixnum (integer)
+ (format "Type of small (fixed-size) integers.
+The size depends on the Emacs version and compilation options.
+For this build of Emacs it's %dbit."
+ (1+ (logb (1+ most-positive-fixnum)))))
+(cl--define-built-in-type boolean (symbol)
+ "Type of the canonical boolean values, i.e. either nil or t.")
+(cl--define-built-in-type symbol-with-pos (symbol)
+ "Type of symbols augmented with source-position information.")
+(cl--define-built-in-type vector (array))
+(cl--define-built-in-type record (atom)
+ "Abstract type of objects with slots.")
+(cl--define-built-in-type bool-vector (array) "Type of bitvectors.")
+(cl--define-built-in-type char-table (array)
+ "Type of special arrays that are indexed by characters.")
+(cl--define-built-in-type string (array))
+(cl--define-built-in-type null (boolean list) ;FIXME: `atom' comes before `list'?
+ "Type of the nil value."
+ :predicate null)
+(cl--define-built-in-type cons (list)
+ "Type of cons cells."
+ ;; Example of slots we could document.
+ (car car) (cdr cdr))
+(cl--define-built-in-type function (atom)
+ "Abstract supertype of function values."
+ ;; FIXME: Historically, (cl-typep FOO 'function) called `functionp',
+ ;; so while `cl-functionp' would be the more correct predicate, it
+ ;; would breaks existing code :-(
+ ;; :predicate cl-functionp
+ )
+(cl--define-built-in-type compiled-function (function)
+ "Abstract type of functions that have been compiled.")
+(cl--define-built-in-type byte-code-function (compiled-function)
+ "Type of functions that have been byte-compiled.")
+(cl--define-built-in-type subr (atom)
+ "Abstract type of functions compiled to machine code.")
+(cl--define-built-in-type module-function (function)
+ "Type of functions provided via the module API.")
+(cl--define-built-in-type interpreted-function (function)
+ "Type of functions that have not been compiled.")
+(cl--define-built-in-type special-form (subr)
+ "Type of the core syntactic elements of the Emacs Lisp language.")
+(cl--define-built-in-type subr-native-elisp (subr compiled-function)
+ "Type of functions that have been compiled by the native compiler.")
+(cl--define-built-in-type primitive-function (subr compiled-function)
+ "Type of functions hand written in C.")
+
+(unless (cl--class-parents (cl--find-class 'cl-structure-object))
+ ;; When `cl-structure-object' is created, built-in classes didn't exist
+ ;; yet, so we couldn't put `record' as the parent.
+ ;; Fix it now to close the recursion.
+ (setf (cl--class-parents (cl--find-class 'cl-structure-object))
+ (list (cl--find-class 'record))))
;; 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
diff --git a/lisp/emacs-lisp/cl-print.el b/lisp/emacs-lisp/cl-print.el
index b9fee4d0888..5e5eee1da9e 100644
--- a/lisp/emacs-lisp/cl-print.el
+++ b/lisp/emacs-lisp/cl-print.el
@@ -54,9 +54,12 @@ call other entry points instead, such as `cl-prin1'."
(prin1 object stream))
(cl-defgeneric cl-print-object-contents (_object _start _stream)
- "Dispatcher to print the contents of OBJECT on STREAM.
-Print the contents starting with the item at START, without
-delimiters."
+ "Dispatcher to print partial contents of OBJECT on STREAM.
+This is used when replacing an ellipsis with the contents it
+represents. OBJECT is the object that has been partially printed
+and START represents the place at which the contents were
+replaced with an ellipsis.
+Print the contents hidden by the ellipsis to STREAM."
;; Every cl-print-object method which can print an ellipsis should
;; have a matching cl-print-object-contents method to expand an
;; ellipsis.
@@ -65,9 +68,8 @@ delimiters."
(cl-defmethod cl-print-object ((object cons) stream)
(if (and cl-print--depth (natnump print-level)
(> cl-print--depth print-level))
- (cl-print-insert-ellipsis object 0 stream)
- (let ((car (pop object))
- (count 1))
+ (cl-print-insert-ellipsis object nil stream)
+ (let ((car (pop object)))
(if (and print-quoted
(memq car '(\, quote function \` \,@ \,.))
(consp object)
@@ -80,26 +82,12 @@ delimiters."
stream)
(cl-print-object (car object) stream))
(princ "(" stream)
- (cl-print-object car stream)
- (while (and (consp object)
- (not (cond
- (cl-print--number-table
- (numberp (gethash object cl-print--number-table)))
- ((memq object cl-print--currently-printing))
- (t (push object cl-print--currently-printing)
- nil))))
- (princ " " stream)
- (if (or (not (natnump print-length)) (> print-length count))
- (cl-print-object (pop object) stream)
- (cl-print-insert-ellipsis object print-length stream)
- (setq object nil))
- (cl-incf count))
- (when object
- (princ " . " stream) (cl-print-object object stream))
+ (cl-print--cons-tail car object stream)
(princ ")" stream)))))
-(cl-defmethod cl-print-object-contents ((object cons) _start stream)
- (let ((count 0))
+(defun cl-print--cons-tail (car object stream)
+ (let ((count 1))
+ (cl-print-object car stream)
(while (and (consp object)
(not (cond
(cl-print--number-table
@@ -107,33 +95,27 @@ delimiters."
((memq object cl-print--currently-printing))
(t (push object cl-print--currently-printing)
nil))))
- (unless (zerop count)
- (princ " " stream))
+ (princ " " stream)
(if (or (not (natnump print-length)) (> print-length count))
(cl-print-object (pop object) stream)
- (cl-print-insert-ellipsis object print-length stream)
+ (cl-print-insert-ellipsis object t stream)
(setq object nil))
(cl-incf count))
(when object
(princ " . " stream) (cl-print-object object stream))))
+(cl-defmethod cl-print-object-contents ((object cons) _start stream)
+ (cl-print--cons-tail (car object) (cdr object) stream))
+
(cl-defmethod cl-print-object ((object vector) stream)
(if (and cl-print--depth (natnump print-level)
(> cl-print--depth print-level))
- (cl-print-insert-ellipsis object 0 stream)
+ (cl-print-insert-ellipsis object nil stream)
(princ "[" stream)
- (let* ((len (length object))
- (limit (if (natnump print-length)
- (min print-length len) len)))
- (dotimes (i limit)
- (unless (zerop i) (princ " " stream))
- (cl-print-object (aref object i) stream))
- (when (< limit len)
- (princ " " stream)
- (cl-print-insert-ellipsis object limit stream)))
+ (cl-print--vector-contents object 0 stream)
(princ "]" stream)))
-(cl-defmethod cl-print-object-contents ((object vector) start stream)
+(defun cl-print--vector-contents (object start stream)
(let* ((len (length object))
(limit (if (natnump print-length)
(min (+ start print-length) len) len))
@@ -146,16 +128,34 @@ delimiters."
(princ " " stream)
(cl-print-insert-ellipsis object limit stream))))
+(cl-defmethod cl-print-object-contents ((object vector) start stream)
+ (cl-print--vector-contents object start stream)) ;FIXME: η-redex!
+
(cl-defmethod cl-print-object ((object hash-table) stream)
+ ;; Make sure `pp-fill' can pretty print the result!
(princ "#<hash-table " stream)
(princ (hash-table-test object) stream)
(princ " " stream)
(princ (hash-table-count object) stream)
(princ "/" stream)
(princ (hash-table-size object) stream)
- (princ (format " %#x" (sxhash object)) stream)
+ (princ (format " %#x " (sxhash object)) stream)
+ (cl-print-insert-ellipsis object t stream)
(princ ">" stream))
+(cl-defmethod cl-print-object-contents ((object hash-table) _start stream)
+ ;; If we want to obey `print-length' here, it's not completely obvious
+ ;; what we should use as marker of "where we are" within the hash-table.
+ ;; We could use here a simple number or a set of keys already printed,
+ ;; but it still breaks down if elements get added/removed.
+ ;; Instead here we convert the hash-table to an alist once and for all.
+ (let ((alist nil))
+ (maphash (lambda (k v) (push (cons k v) alist)) object)
+ ;; While the order of elements seen by `maphash' is "arbitrary"
+ ;; it tends to be in the order objects have been added, which is
+ ;; sometimes handy, so it's nice to preserve this order here.
+ (cl-print-object (nreverse alist) stream)))
+
(define-button-type 'help-byte-code
'follow-link t
'action (lambda (button)
@@ -165,6 +165,7 @@ delimiters."
(defvar cl-print-compiled nil
"Control how to print byte-compiled functions.
Acceptable values include:
+- `raw' to print out the full contents of the function using `prin1'.
- `static' to print the vector of constants.
- `disassemble' to print the disassembly of the code.
- nil to skip printing any details about the code.")
@@ -176,6 +177,9 @@ into a button whose action shows the function's disassembly.")
(autoload 'disassemble-1 "disass")
+;; FIXME: Don't degenerate to `prin1' for the contents of char-tables
+;; and records!
+
(cl-defmethod cl-print-object ((object compiled-function) stream)
(unless stream (setq stream standard-output))
;; We use "#f(...)" rather than "#<...>" so that pp.el gives better results.
@@ -184,42 +188,54 @@ into a button whose action shows the function's disassembly.")
(if args
(prin1 args stream)
(princ "()" stream)))
- (pcase (help-split-fundoc (documentation object 'raw) object)
- ;; Drop args which `help-function-arglist' already printed.
- (`(,_usage . ,(and doc (guard (stringp doc))))
- (princ " " stream)
- (prin1 doc stream)))
- (let ((inter (interactive-form object)))
- (when inter
- (princ " " stream)
- (cl-print-object
- (if (eq 'byte-code (car-safe (cadr inter)))
- `(interactive ,(make-byte-code nil (nth 1 (cadr inter))
- (nth 2 (cadr inter))
- (nth 3 (cadr inter))))
- inter)
- stream)))
- (if (eq cl-print-compiled 'disassemble)
- (princ
- (with-temp-buffer
- (insert "\n")
- (disassemble-1 object 0)
- (buffer-string))
- stream)
- (princ " " stream)
- (let ((button-start (and cl-print-compiled-button
- (bufferp stream)
- (with-current-buffer stream (point)))))
- (princ (format "#<bytecode %#x>" (sxhash object)) stream)
- (when (eq cl-print-compiled 'static)
+ (if (eq cl-print-compiled 'raw)
+ (let ((button-start
+ (and cl-print-compiled-button
+ (bufferp stream)
+ (with-current-buffer stream (1+ (point))))))
+ (princ " " stream)
+ (prin1 object stream)
+ (when button-start
+ (with-current-buffer stream
+ (make-text-button button-start (point)
+ :type 'help-byte-code
+ 'byte-code-function object))))
+ (pcase (help-split-fundoc (documentation object 'raw) object)
+ ;; Drop args which `help-function-arglist' already printed.
+ (`(,_usage . ,(and doc (guard (stringp doc))))
+ (princ " " stream)
+ (prin1 doc stream)))
+ (let ((inter (interactive-form object)))
+ (when inter
(princ " " stream)
- (cl-print-object (aref object 2) stream))
- (when button-start
- (with-current-buffer stream
- (make-text-button button-start (point)
- :type 'help-byte-code
- 'byte-code-function object)))))
- (princ ")" stream))
+ (cl-print-object
+ (if (eq 'byte-code (car-safe (cadr inter)))
+ `(interactive ,(make-byte-code nil (nth 1 (cadr inter))
+ (nth 2 (cadr inter))
+ (nth 3 (cadr inter))))
+ inter)
+ stream)))
+ (if (eq cl-print-compiled 'disassemble)
+ (princ
+ (with-temp-buffer
+ (insert "\n")
+ (disassemble-1 object 0)
+ (buffer-string))
+ stream)
+ (princ " " stream)
+ (let ((button-start (and cl-print-compiled-button
+ (bufferp stream)
+ (with-current-buffer stream (point)))))
+ (princ (format "#<bytecode %#x>" (sxhash object)) stream)
+ (when (eq cl-print-compiled 'static)
+ (princ " " stream)
+ (cl-print-object (aref object 2) stream))
+ (when button-start
+ (with-current-buffer stream
+ (make-text-button button-start (point)
+ :type 'help-byte-code
+ 'byte-code-function object)))))
+ (princ ")" stream)))
;; This belongs in oclosure.el, of course, but some load-ordering issues make it
;; complicated.
@@ -230,26 +246,13 @@ into a button whose action shows the function's disassembly.")
(cl-defmethod cl-print-object ((object cl-structure-object) stream)
(if (and cl-print--depth (natnump print-level)
(> cl-print--depth print-level))
- (cl-print-insert-ellipsis object 0 stream)
+ (cl-print-insert-ellipsis object nil stream)
(princ "#s(" stream)
- (let* ((class (cl-find-class (type-of object)))
- (slots (cl--struct-class-slots class))
- (len (length slots))
- (limit (if (natnump print-length)
- (min print-length len) len)))
- (princ (cl--struct-class-name class) stream)
- (dotimes (i limit)
- (let ((slot (aref slots i)))
- (princ " :" stream)
- (princ (cl--slot-descriptor-name slot) stream)
- (princ " " stream)
- (cl-print-object (aref object (1+ i)) stream)))
- (when (< limit len)
- (princ " " stream)
- (cl-print-insert-ellipsis object limit stream)))
+ (princ (cl--struct-class-name (cl-find-class (type-of object))) stream)
+ (cl-print--struct-contents object 0 stream)
(princ ")" stream)))
-(cl-defmethod cl-print-object-contents ((object cl-structure-object) start stream)
+(defun cl-print--struct-contents (object start stream)
(let* ((class (cl-find-class (type-of object)))
(slots (cl--struct-class-slots class))
(len (length slots))
@@ -258,7 +261,7 @@ into a button whose action shows the function's disassembly.")
(i start))
(while (< i limit)
(let ((slot (aref slots i)))
- (unless (= i start) (princ " " stream))
+ (unless (and (= i start) (> i 0)) (princ " " stream))
(princ ":" stream)
(princ (cl--slot-descriptor-name slot) stream)
(princ " " stream)
@@ -268,17 +271,34 @@ into a button whose action shows the function's disassembly.")
(princ " " stream)
(cl-print-insert-ellipsis object limit stream))))
+(cl-defmethod cl-print-object-contents ((object cl-structure-object) start stream)
+ (cl-print--struct-contents object start stream)) ;FIXME: η-redex!
+
+(defvar cl-print-string-length nil
+ "Maximum length of string to print before abbreviating.
+A value of nil means no limit.
+
+When Emacs abbreviates a string, it prints the first
+`cl-print-string-length' characters of the string, followed by
+\"...\". You can type RET, or click on this ellipsis to expand
+the string.
+
+This variable has effect only in the `cl-prin*' functions, not in
+primitives such as `prin1'.")
+
(cl-defmethod cl-print-object ((object string) stream)
(unless stream (setq stream standard-output))
(let* ((has-properties (or (text-properties-at 0 object)
(next-property-change 0 object)))
(len (length object))
- (limit (if (natnump print-length) (min print-length len) len)))
+ (limit (if (natnump cl-print-string-length)
+ (min cl-print-string-length len)
+ len)))
(if (and has-properties
cl-print--depth
(natnump print-level)
(> cl-print--depth print-level))
- (cl-print-insert-ellipsis object 0 stream)
+ (cl-print-insert-ellipsis object nil stream)
;; Print all or part of the string
(when has-properties
(princ "#(" stream))
@@ -294,28 +314,36 @@ into a button whose action shows the function's disassembly.")
(- (point) 1) stream)))))
;; Print the property list.
(when has-properties
- (let* ((interval-limit (and (natnump print-length)
- (max 1 (/ print-length 3))))
- (interval-count 0)
- (start-pos (if (text-properties-at 0 object)
- 0 (next-property-change 0 object)))
- (end-pos (next-property-change start-pos object len)))
- (while (and (or (null interval-limit)
- (< interval-count interval-limit))
- (< start-pos len))
- (let ((props (text-properties-at start-pos object)))
- (when props
- (princ " " stream) (princ start-pos stream)
- (princ " " stream) (princ end-pos stream)
- (princ " " stream) (cl-print-object props stream)
- (cl-incf interval-count))
- (setq start-pos end-pos
- end-pos (next-property-change start-pos object len))))
- (when (< start-pos len)
- (princ " " stream)
- (cl-print-insert-ellipsis object (list start-pos) stream)))
+ (cl-print--string-props object 0 stream)
(princ ")" stream)))))
+(defun cl-print--string-props (object start stream)
+ (let* ((first (not (eq start 0)))
+ (len (length object))
+ (interval-limit (and (natnump print-length)
+ (max 1 (/ print-length 3))))
+ (interval-count 0)
+ (start-pos (if (text-properties-at start object)
+ start (next-property-change start object)))
+ (end-pos (next-property-change start-pos object len)))
+ (while (and (or (null interval-limit)
+ (< interval-count interval-limit))
+ (< start-pos len))
+ (let ((props (text-properties-at start-pos object)))
+ (when props
+ (if first
+ (setq first nil)
+ (princ " " stream))
+ (princ start-pos stream)
+ (princ " " stream) (princ end-pos stream)
+ (princ " " stream) (cl-print-object props stream)
+ (cl-incf interval-count))
+ (setq start-pos end-pos
+ end-pos (next-property-change start-pos object len))))
+ (when (< start-pos len)
+ (princ " " stream)
+ (cl-print-insert-ellipsis object (list start-pos) stream))))
+
(cl-defmethod cl-print-object-contents ((object string) start stream)
;; If START is an integer, it is an index into the string, and the
;; ellipsis that needs to be expanded is part of the string. If
@@ -324,39 +352,18 @@ into a button whose action shows the function's disassembly.")
(let* ((len (length object)))
(if (atom start)
;; Print part of the string.
- (let* ((limit (if (natnump print-length)
- (min (+ start print-length) len) len))
+ (let* ((limit (if (natnump cl-print-string-length)
+ (min (+ start cl-print-string-length) len)
+ len))
(substr (substring-no-properties object start limit))
(printed (prin1-to-string substr))
- (trimmed (substring printed 1 (1- (length printed)))))
- (princ trimmed)
+ (trimmed (substring printed 1 -1)))
+ (princ trimmed stream)
(when (< limit len)
(cl-print-insert-ellipsis object limit stream)))
;; Print part of the property list.
- (let* ((first t)
- (interval-limit (and (natnump print-length)
- (max 1 (/ print-length 3))))
- (interval-count 0)
- (start-pos (car start))
- (end-pos (next-property-change start-pos object len)))
- (while (and (or (null interval-limit)
- (< interval-count interval-limit))
- (< start-pos len))
- (let ((props (text-properties-at start-pos object)))
- (when props
- (if first
- (setq first nil)
- (princ " " stream))
- (princ start-pos stream)
- (princ " " stream) (princ end-pos stream)
- (princ " " stream) (cl-print-object props stream)
- (cl-incf interval-count))
- (setq start-pos end-pos
- end-pos (next-property-change start-pos object len))))
- (when (< start-pos len)
- (princ " " stream)
- (cl-print-insert-ellipsis object (list start-pos) stream))))))
+ (cl-print--string-props object (car start) stream))))
;;; Circularity and sharing.
@@ -367,6 +374,7 @@ into a button whose action shows the function's disassembly.")
(cl-defmethod cl-print-object :around (object stream)
;; FIXME: Only put such an :around method on types where it's relevant.
(let ((cl-print--depth (if cl-print--depth (1+ cl-print--depth) 1)))
+ ;; FIXME: Handle print-level here once and forall?
(cond
(print-circle
(let ((n (gethash object cl-print--number-table)))
@@ -436,17 +444,60 @@ into a button whose action shows the function's disassembly.")
(defun cl-print--preprocess (object)
(let ((print-number-table (make-hash-table :test 'eq :rehash-size 2.0)))
- (if (fboundp 'print--preprocess)
+ (if (fboundp 'print--preprocess) ;Emacs≥26
;; Use the predefined C version if available.
(print--preprocess object) ;Fill print-number-table!
(let ((cl-print--number-index 0))
(cl-print--find-sharing object print-number-table)))
print-number-table))
+(define-button-type 'cl-print-ellipsis
+ 'skip t 'action #'cl-print-expand-ellipsis
+ 'help-echo "mouse-2, RET: expand this ellipsis")
+
+(defvar cl-print-expand-ellipsis-function
+ #'cl-print--default-expand-ellipsis
+ "Function to tweak the way ellipses are expanded.
+The function is called with 3 arguments, BEG, END, and FUNC.
+BEG and END delimit the ellipsis that will be replaced.
+FUNC is the function that will do the expansion.
+It should be called with a single argument specifying the desired
+limit of the expansion's length, as used in `cl-print-to-string-with-limit'.
+FUNC will return the position of the end of the newly printed text.")
+
+(defun cl-print--default-expand-ellipsis (begin end value line-length)
+ (delete-region begin end)
+ (insert (cl-print-to-string-with-limit
+ #'cl-print--expand-ellipsis value line-length))
+ (point))
+
+
+(defun cl-print-expand-ellipsis (&optional button)
+ "Expand display of the elided form at BUTTON.
+BUTTON can also be a buffer position or nil (to mean point)."
+ (interactive)
+ (goto-char (cond
+ ((null button) (point))
+ (t (button-start button))))
+ (unless (get-text-property (point) 'cl-print-ellipsis)
+ (if (and (> (point) (point-min))
+ (get-text-property (1- (point)) 'cl-print-ellipsis))
+ (backward-char)
+ (user-error "No ellipsis to expand here")))
+ (let* ((end (next-single-property-change (point) 'cl-print-ellipsis))
+ (begin (previous-single-property-change end 'cl-print-ellipsis))
+ (value (get-text-property begin 'cl-print-ellipsis)))
+ ;; FIXME: Rather than `t' (i.e. reuse the print-length/level unchanged),
+ ;; I think it would make sense to increase the level by 1 and to
+ ;; double the length at each expansion step.
+ (funcall cl-print-expand-ellipsis-function
+ begin end value t)
+ (goto-char begin)))
+
(defun cl-print-insert-ellipsis (object start stream)
"Print \"...\" to STREAM with the `cl-print-ellipsis' text property.
Save state in the text property in order to print the elided part
-of OBJECT later. START should be 0 if the whole OBJECT is being
+of OBJECT later. START should be nil if the whole OBJECT is being
elided, otherwise it should be an index or other pointer into the
internals of OBJECT which can be passed to
`cl-print-object-contents' at a future time."
@@ -466,10 +517,10 @@ STREAM should be a buffer. OBJECT and START are as described in
(let ((value (list object start cl-print--number-table
cl-print--currently-printing)))
(with-current-buffer stream
- (put-text-property beg end 'cl-print-ellipsis value stream))))
+ (put-text-property beg end 'cl-print-ellipsis value stream)
+ (make-text-button beg end :type 'cl-print-ellipsis))))
-;;;###autoload
-(defun cl-print-expand-ellipsis (value stream)
+(defun cl-print--expand-ellipsis (value stream)
"Print the expansion of an ellipsis to STREAM.
VALUE should be the value of the `cl-print-ellipsis' text property
which was attached to the ellipsis by `cl-prin1'."
@@ -481,7 +532,7 @@ which was attached to the ellipsis by `cl-prin1'."
(cl-print--currently-printing (nth 3 value)))
(when (eq object (car cl-print--currently-printing))
(pop cl-print--currently-printing))
- (if (equal start 0)
+ (if (memq start '(0 nil))
(cl-print-object object stream)
(cl-print-object-contents object start stream))))
@@ -511,27 +562,35 @@ node `(elisp)Output Variables'."
(defun cl-print-to-string-with-limit (print-function value limit)
"Return a string containing a printed representation of VALUE.
Attempt to get the length of the returned string under LIMIT
-characters with appropriate settings of `print-level' and
-`print-length.' Use PRINT-FUNCTION to print, which should take
-the arguments VALUE and STREAM and which should respect
-`print-length' and `print-level'. LIMIT may be nil or zero in
-which case PRINT-FUNCTION will be called with `print-level' and
-`print-length' bound to nil.
+characters with appropriate settings of `print-level',
+`print-length', and `cl-print-string-length'. Use
+PRINT-FUNCTION to print, which should take the arguments VALUE
+and STREAM and which should respect `print-length',
+`print-level', and `cl-print-string-length'. LIMIT may be nil or
+zero in which case PRINT-FUNCTION will be called with these
+settings bound to nil, and it can also be t in which case
+PRINT-FUNCTION will be called with their current values.
Use this function with `cl-prin1' to print an object,
-abbreviating it with ellipses to fit within a size limit. Use
-this function with `cl-prin1-expand-ellipsis' to expand an
-ellipsis, abbreviating the expansion to stay within a size
-limit."
- (setq limit (and (natnump limit)
- (not (zerop limit))
- limit))
+abbreviating it with ellipses to fit within a size limit."
+ (setq limit (and (not (eq limit 0)) limit))
;; Since this is used by the debugger when stack space may be
;; limited, if you increase print-level here, add more depth in
;; call_debugger (bug#31919).
- (let* ((print-length (when limit (min limit 50)))
- (print-level (when limit (min 8 (truncate (log limit)))))
- (delta-length (when limit
+ (let* ((print-length (cond
+ ((eq limit t) print-length)
+ ((or (null limit) (zerop limit)) nil)
+ (t (min limit 50))))
+ (print-level (cond
+ ((eq limit t) print-level)
+ ((or (null limit) (zerop limit)) nil)
+ (t (min 8 (truncate (log limit))))))
+ (cl-print-string-length
+ (cond
+ ((eq limit t) cl-print-string-length)
+ ((or (null limit) (zerop limit)) nil)
+ (t (max 0 (- limit 3)))))
+ (delta-length (when (natnump limit)
(max 1 (truncate (/ print-length print-level))))))
(with-temp-buffer
(catch 'done
@@ -541,12 +600,15 @@ limit."
(let ((result (- (point-max) (point-min))))
;; Stop when either print-level is too low or the value is
;; successfully printed in the space allowed.
- (when (or (not limit) (< result limit) (<= print-level 2))
+ (when (or (not (natnump limit)) (< result limit) (<= print-level 2))
(throw 'done (buffer-string)))
(let* ((ratio (/ result limit))
(delta-level (max 1 (min (- print-level 2) ratio))))
(cl-decf print-level delta-level)
- (cl-decf print-length (* delta-length delta-level)))))))))
+ (cl-decf print-length (* delta-length delta-level))
+ (when cl-print-string-length
+ (cl-decf cl-print-string-length
+ (ceiling cl-print-string-length 4.0))))))))))
(provide 'cl-print)
;;; cl-print.el ends here
diff --git a/lisp/emacs-lisp/comp-common.el b/lisp/emacs-lisp/comp-common.el
new file mode 100644
index 00000000000..4edfe811586
--- /dev/null
+++ b/lisp/emacs-lisp/comp-common.el
@@ -0,0 +1,554 @@
+;;; comp-common.el --- common code -*- lexical-binding: t -*-
+
+;; Copyright (C) 2023-2024 Free Software Foundation, Inc.
+
+;; Author: Andrea Corallo <acorallo@gnu.org>
+;; Keywords: lisp
+;; Package: emacs
+
+;; This file is part of GNU Emacs.
+
+;; GNU Emacs is free software: you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+
+;; GNU Emacs is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>.
+
+;;; Commentary:
+
+;; This file holds common code required by comp.el and comp-run.el.
+
+;;; Code:
+
+(eval-when-compile (require 'cl-lib))
+
+;; These variables and functions are defined in comp.c
+(defvar comp-native-version-dir)
+(defvar native-comp-eln-load-path)
+
+(defgroup comp-common nil
+ "Emacs Lisp native compiler common code."
+ :group 'lisp)
+
+(defcustom native-comp-verbose 0
+ "Compiler verbosity for native compilation, a number between 0 and 3.
+This is intended for debugging the compiler itself.
+ 0 no logging.
+ 1 final LIMPLE is logged.
+ 2 LAP, final LIMPLE, and some pass info are logged.
+ 3 max verbosity."
+ :type 'natnum
+ :risky t
+ :version "28.1")
+
+(defcustom native-comp-never-optimize-functions
+ ;; We used to list those functions here that were advised during
+ ;; preload, but we now prefer to disallow preload advices in
+ ;; loadup.el (bug#67005).
+ '(eval)
+ "Primitive functions to exclude from trampoline optimization.
+
+Primitive functions included in this list will not be called
+directly by the natively-compiled code, which makes trampolines for
+those primitives unnecessary in case of function redefinition/advice."
+ :type '(repeat symbol)
+ :version "30.1")
+
+(defcustom native-comp-async-env-modifier-form nil
+ "Form evaluated before compilation by each asynchronous compilation subprocess.
+Used to modify the compiler environment."
+ :type 'sexp
+ :risky t
+ :version "28.1")
+
+(defconst comp-known-type-specifiers
+ `(
+ ;; Functions we can trust not to be redefined, or, if redefined,
+ ;; to expose the same type. The vast majority of these are
+ ;; either pure or primitive; the original list is the union of
+ ;; pure + side-effect-free-fns + side-effect-and-error-free-fns:
+ (% (function ((or number marker) (or number marker)) number))
+ (* (function (&rest (or number marker)) number))
+ (+ (function (&rest (or number marker)) number))
+ (- (function (&rest (or number marker)) number))
+ (/ (function ((or number marker) &rest (or number marker)) number))
+ (/= (function ((or number marker) (or number marker)) boolean))
+ (1+ (function ((or number marker)) number))
+ (1- (function ((or number marker)) number))
+ (< (function ((or number marker) &rest (or number marker)) boolean))
+ (<= (function ((or number marker) &rest (or number marker)) boolean))
+ (= (function ((or number marker) &rest (or number marker)) boolean))
+ (> (function ((or number marker) &rest (or number marker)) boolean))
+ (>= (function ((or number marker) &rest (or number marker)) boolean))
+ (abs (function (number) number))
+ (acos (function (number) float))
+ (append (function (&rest t) t))
+ (aref (function (t fixnum) t))
+ (arrayp (function (t) boolean))
+ (ash (function (integer integer) integer))
+ (asin (function (number) float))
+ (assq (function (t list) list))
+ (atan (function (number &optional number) float))
+ (atom (function (t) boolean))
+ (bignump (function (t) boolean))
+ (bobp (function () boolean))
+ (bolp (function () boolean))
+ (bool-vector-count-consecutive
+ (function (bool-vector boolean integer) fixnum))
+ (bool-vector-count-population (function (bool-vector) fixnum))
+ (bool-vector-not (function (bool-vector &optional bool-vector) bool-vector))
+ (bool-vector-p (function (t) boolean))
+ (bool-vector-subsetp (function (bool-vector bool-vector) boolean))
+ (boundp (function (symbol) boolean))
+ (buffer-end (function ((or number marker)) integer))
+ (buffer-file-name (function (&optional buffer) (or string null)))
+ (buffer-list (function (&optional frame) list))
+ (buffer-local-variables (function (&optional buffer) list))
+ (buffer-modified-p
+ (function (&optional buffer) (or boolean (member autosaved))))
+ (buffer-size (function (&optional buffer) integer))
+ (buffer-string (function () string))
+ (buffer-substring
+ (function ((or integer marker) (or integer marker)) string))
+ (bufferp (function (t) boolean))
+ (byte-code-function-p (function (t) boolean))
+ (capitalize (function ((or integer string)) (or integer string)))
+ (car (function (list) t))
+ (car-less-than-car (function (list list) boolean))
+ (car-safe (function (t) t))
+ (case-table-p (function (t) boolean))
+ (cdr (function (list) t))
+ (cdr-safe (function (t) t))
+ (ceiling (function (number &optional number) integer))
+ (char-after (function (&optional (or marker integer)) (or fixnum null)))
+ (char-before (function (&optional (or marker integer)) (or fixnum null)))
+ (char-equal (function (integer integer) boolean))
+ (char-or-string-p (function (t) boolean))
+ (char-to-string (function (fixnum) string))
+ (char-width (function (fixnum) fixnum))
+ (characterp (function (t &optional t) boolean))
+ (charsetp (function (t) boolean))
+ (commandp (function (t &optional t) boolean))
+ (compare-strings
+ (function (string (or integer marker null) (or integer marker null) string
+ (or integer marker null) (or integer marker null)
+ &optional t)
+ (or (member t) fixnum)))
+ (concat (function (&rest sequence) string))
+ (cons (function (t t) cons))
+ (consp (function (t) boolean))
+ (coordinates-in-window-p
+ (function (cons window)
+ (or cons null
+ (member bottom-divider right-divider mode-line header-line
+ tab-line left-fringe right-fringe vertical-line
+ left-margin right-margin))))
+ (copy-alist (function (list) list))
+ (copy-marker (function (&optional (or integer marker) boolean) marker))
+ (copy-sequence (function (sequence) sequence))
+ (copysign (function (float float) float))
+ (cos (function (number) float))
+ (count-lines
+ (function ((or integer marker) (or integer marker) &optional t) integer))
+ (current-buffer (function () buffer))
+ (current-global-map (function () cons))
+ (current-indentation (function () integer))
+ (current-local-map (function () (or cons null)))
+ (current-minor-mode-maps (function () (or cons null)))
+ (current-time (function () cons))
+ (current-time-string (function (&optional (or number list)
+ (or symbol string cons integer))
+ string))
+ (current-time-zone (function (&optional (or number list)
+ (or symbol string cons integer))
+ cons))
+ (custom-variable-p (function (symbol) t))
+ (decode-char (function (cons t) (or fixnum null)))
+ (decode-time (function (&optional (or number list)
+ (or symbol string cons integer)
+ symbol)
+ cons))
+ (default-boundp (function (symbol) boolean))
+ (default-value (function (symbol) t))
+ (degrees-to-radians (function (number) float))
+ (documentation
+ (function ((or function symbol subr) &optional t) (or null string)))
+ (downcase (function ((or fixnum string)) (or fixnum string)))
+ (elt (function (sequence integer) t))
+ (encode-char (function (fixnum symbol) (or fixnum null)))
+ (encode-time (function (cons &rest t) cons))
+ (eobp (function () boolean))
+ (eolp (function () boolean))
+ (eq (function (t t) boolean))
+ (eql (function (t t) boolean))
+ (equal (function (t t) boolean))
+ (error-message-string (function (list) string))
+ (eventp (function (t) boolean))
+ (exp (function (number) float))
+ (expt (function (number number) number))
+ (fboundp (function (symbol) boolean))
+ (fceiling (function (float) float))
+ (featurep (function (symbol &optional symbol) boolean))
+ (ffloor (function (float) float))
+ (file-directory-p (function (string) boolean))
+ (file-exists-p (function (string) boolean))
+ (file-locked-p (function (string) (or boolean string)))
+ (file-name-absolute-p (function (string) boolean))
+ (file-newer-than-file-p (function (string string) boolean))
+ (file-readable-p (function (string) boolean))
+ (file-symlink-p (function (string) (or boolean string)))
+ (file-writable-p (function (string) boolean))
+ (fixnump (function (t) boolean))
+ (float (function (number) float))
+ (float-time (function (&optional (or number list)) float))
+ (floatp (function (t) boolean))
+ (floor (function (number &optional number) integer))
+ (following-char (function () fixnum))
+ (format (function (string &rest t) string))
+ (format-time-string (function (string &optional (or number list)
+ (or symbol string cons integer))
+ string))
+ (frame-first-window (function ((or frame window)) window))
+ (frame-root-window (function (&optional (or frame window)) window))
+ (frame-selected-window (function (&optional (or frame window)) window))
+ (frame-visible-p (function (frame) (or boolean (member icon))))
+ (framep (function (t) symbol))
+ (fround (function (float) float))
+ (ftruncate (function (float) float))
+ (get (function (symbol symbol) t))
+ (get-buffer (function ((or buffer string)) (or buffer null)))
+ (get-buffer-window
+ (function (&optional (or buffer string) (or symbol (integer 0 0)))
+ (or null window)))
+ (get-file-buffer (function (string) (or null buffer)))
+ (get-largest-window (function (&optional t t t) (or window null)))
+ (get-lru-window (function (&optional t t t) (or window null)))
+ (getenv (function (string &optional frame) (or null string)))
+ (gethash (function (t hash-table &optional t) t))
+ (hash-table-count (function (hash-table) integer))
+ (hash-table-p (function (t) boolean))
+ (identity (function (t) t))
+ (ignore (function (&rest t) null))
+ (int-to-string (function (number) string))
+ (integer-or-marker-p (function (t) boolean))
+ (integerp (function (t) boolean))
+ (interactive-p (function () boolean))
+ (intern-soft (function ((or string symbol) &optional (or obarray vector))
+ symbol))
+ (invocation-directory (function () string))
+ (invocation-name (function () string))
+ (isnan (function (float) boolean))
+ (keymap-parent (function (cons) (or cons null)))
+ (keymapp (function (t) boolean))
+ (keywordp (function (t) boolean))
+ (last (function (list &optional integer) list))
+ (lax-plist-get (function (list t) t))
+ (ldexp (function (number integer) float))
+ (length (function (t) (integer 0 *)))
+ (length< (function (sequence fixnum) boolean))
+ (length= (function (sequence fixnum) boolean))
+ (length> (function (sequence fixnum) boolean))
+ (line-beginning-position (function (&optional integer) integer))
+ (line-end-position (function (&optional integer) integer))
+ (list (function (&rest t) list))
+ (listp (function (t) boolean))
+ (local-variable-if-set-p (function (symbol &optional buffer) boolean))
+ (local-variable-p (function (symbol &optional buffer) boolean))
+ (locale-info (function ((member codeset days months paper)) (or null string)))
+ (log (function (number number) float))
+ (log10 (function (number) float))
+ (logand (function (&rest (or integer marker)) integer))
+ (logb (function (number) integer))
+ (logcount (function (integer) integer))
+ (logior (function (&rest (or integer marker)) integer))
+ (lognot (function (integer) integer))
+ (logxor (function (&rest (or integer marker)) integer))
+ ;; (lsh (function ((integer ,most-negative-fixnum *) integer) integer)) ?
+ (lsh (function (integer integer) integer))
+ (make-byte-code
+ (function ((or fixnum list) string vector integer &optional string t
+ &rest t)
+ vector))
+ (make-list (function (integer t) list))
+ (make-marker (function () marker))
+ (make-string (function (integer fixnum &optional t) string))
+ (make-symbol (function (string) symbol))
+ (mark (function (&optional t) (or integer null)))
+ (mark-marker (function () marker))
+ (marker-buffer (function (marker) (or buffer null)))
+ (markerp (function (t) boolean))
+ (max (function ((or number marker) &rest (or number marker)) number))
+ (max-char (function (&optional t) fixnum))
+ (member (function (t list) list))
+ (memory-limit (function () integer))
+ (memq (function (t list) list))
+ (memql (function (t list) list))
+ (min (function ((or number marker) &rest (or number marker)) number))
+ (minibuffer-selected-window (function () (or window null)))
+ (minibuffer-window (function (&optional frame) window))
+ (mod
+ (function ((or number marker) (or number marker))
+ (or (integer 0 *) (float 0 *))))
+ (mouse-movement-p (function (t) boolean))
+ (multibyte-char-to-unibyte (function (fixnum) fixnum))
+ (natnump (function (t) boolean))
+ (next-window (function (&optional window t t) window))
+ (nlistp (function (t) boolean))
+ (not (function (t) boolean))
+ (nth (function (integer list) t))
+ (nthcdr (function (integer t) t))
+ (null (function (t) boolean))
+ (number-or-marker-p (function (t) boolean))
+ (number-to-string (function (number) string))
+ (numberp (function (t) boolean))
+ (one-window-p (function (&optional t t) boolean))
+ (overlayp (function (t) boolean))
+ (parse-colon-path (function (string) list))
+ (plist-get (function (list t &optional t) t))
+ (plist-member (function (list t &optional t) list))
+ (point (function () integer))
+ (point-marker (function () marker))
+ (point-max (function () integer))
+ (point-min (function () integer))
+ (preceding-char (function () fixnum))
+ (previous-window (function (&optional window t t) window))
+ (prin1-to-string (function (t &optional t t) string))
+ (processp (function (t) boolean))
+ (proper-list-p (function (t) (or fixnum null)))
+ (propertize (function (string &rest t) string))
+ (radians-to-degrees (function (number) float))
+ (rassoc (function (t list) list))
+ (rassq (function (t list) list))
+ (read-from-string (function (string &optional integer integer) cons))
+ (recent-keys (function (&optional (or cons null)) vector))
+ (recursion-depth (function () integer))
+ (regexp-opt (function (list) string))
+ (regexp-quote (function (string) string))
+ (region-beginning (function () integer))
+ (region-end (function () integer))
+ (reverse (function (sequence) sequence))
+ (round (function (number &optional number) integer))
+ (safe-length (function (t) integer))
+ (selected-frame (function () frame))
+ (selected-window (function () window))
+ (sequencep (function (t) boolean))
+ (sin (function (number) float))
+ (sqrt (function (number) float))
+ (standard-case-table (function () char-table))
+ (standard-syntax-table (function () char-table))
+ (string (function (&rest fixnum) string))
+ (string-as-multibyte (function (string) string))
+ (string-as-unibyte (function (string) string))
+ (string-equal (function ((or string symbol) (or string symbol)) boolean))
+ (string-lessp (function ((or string symbol) (or string symbol)) boolean))
+ (string-make-multibyte (function (string) string))
+ (string-make-unibyte (function (string) string))
+ (string-search (function (string string &optional integer) (or integer null)))
+ (string-to-char (function (string) fixnum))
+ (string-to-multibyte (function (string) string))
+ (string-to-number (function (string &optional integer) number))
+ (string-to-syntax (function (string) (or cons null)))
+ (string< (function ((or string symbol) (or string symbol)) boolean))
+ (string= (function ((or string symbol) (or string symbol)) boolean))
+ (stringp (function (t) boolean))
+ (subrp (function (t) boolean))
+ (substring
+ (function ((or string vector) &optional integer integer) (or string vector)))
+ (sxhash (function (t) integer))
+ (sxhash-eq (function (t) integer))
+ (sxhash-eql (function (t) integer))
+ (sxhash-equal (function (t) integer))
+ (symbol-function (function (symbol) t))
+ (symbol-name (function (symbol) string))
+ (symbol-plist (function (symbol) list))
+ (symbol-value (function (symbol) t))
+ (symbolp (function (t) boolean))
+ (syntax-table (function () char-table))
+ (syntax-table-p (function (t) boolean))
+ (tan (function (number) float))
+ (this-command-keys (function () string))
+ (this-command-keys-vector (function () vector))
+ (this-single-command-keys (function () vector))
+ (this-single-command-raw-keys (function () vector))
+ (time-convert (function ((or number list) &optional (or symbol integer))
+ (or cons number)))
+ (truncate (function (number &optional number) integer))
+ (type-of (function (t) symbol))
+ (unibyte-char-to-multibyte (function (fixnum) fixnum)) ;; byte is fixnum
+ (upcase (function ((or fixnum string)) (or fixnum string)))
+ (user-full-name (function (&optional integer) (or string null)))
+ (user-login-name (function (&optional integer) (or string null)))
+ (user-original-login-name (function (&optional integer) (or string null)))
+ (user-real-login-name (function () string))
+ (user-real-uid (function () integer))
+ (user-uid (function () integer))
+ (vconcat (function (&rest sequence) vector))
+ (vector (function (&rest t) vector))
+ (vectorp (function (t) boolean))
+ (visible-frame-list (function () list))
+ (wholenump (function (t) boolean))
+ (window-configuration-p (function (t) boolean))
+ (window-live-p (function (t) boolean))
+ (window-valid-p (function (t) boolean))
+ (windowp (function (t) boolean))
+ (zerop (function (number) boolean))
+ ;; Type hints
+ (comp-hint-fixnum (function (t) fixnum))
+ (comp-hint-cons (function (t) cons))
+ ;; Non returning functions
+ (throw (function (t t) nil))
+ (error (function (string &rest t) nil))
+ (signal (function (symbol t) nil)))
+ "Alist used for type propagation.")
+
+(defconst comp-limple-calls '(call
+ callref
+ direct-call
+ direct-callref)
+ "Limple operators used to call subrs.")
+
+(defconst comp-limple-sets '(set
+ setimm
+ set-par-to-local
+ set-args-to-local
+ set-rest-args-to-local)
+ "Limple set operators.")
+
+(defconst comp-limple-assignments `(assume
+ fetch-handler
+ ,@comp-limple-sets)
+ "Limple operators that clobber the first m-var argument.")
+
+(defconst comp-limple-branches '(jump cond-jump)
+ "Limple operators used for conditional and unconditional branches.")
+
+(defconst comp-limple-ops `(,@comp-limple-calls
+ ,@comp-limple-assignments
+ ,@comp-limple-branches
+ return)
+ "All Limple operators.")
+
+(defconst comp-limple-lock-keywords
+ `((,(rx bol "(comment" (1+ not-newline)) . font-lock-comment-face)
+ (,(rx "#(" (group-n 1 "mvar"))
+ (1 font-lock-function-name-face))
+ (,(rx bol "(" (group-n 1 "phi"))
+ (1 font-lock-variable-name-face))
+ (,(rx bol "(" (group-n 1 (or "return" "unreachable")))
+ (1 font-lock-warning-face))
+ (,(rx (group-n 1 (or "entry"
+ (seq (or "entry_" "entry_fallback_" "bb_")
+ (1+ num) (? (or "_latch"
+ (seq "_cstrs_" (1+ num))))))))
+ (1 font-lock-constant-face))
+ (,(rx-to-string
+ `(seq "(" (group-n 1 (or ,@(mapcar #'symbol-name comp-limple-ops)))))
+ (1 font-lock-keyword-face)))
+ "Highlights used by `native-comp-limple-mode'.")
+
+(defconst comp-log-buffer-name "*Native-compile-Log*"
+ "Name of the native-compiler log buffer.")
+
+(cl-defun comp-log (data &optional (level 1) quoted)
+ "Log DATA at LEVEL.
+LEVEL is a number from 1-3, and defaults to 1; if it is less
+than `native-comp-verbose', do nothing. If `noninteractive', log
+with `message'. Otherwise, log with `comp-log-to-buffer'."
+ (when (>= native-comp-verbose level)
+ (if noninteractive
+ (cl-typecase data
+ (atom (message "%s" data))
+ (t (dolist (elem data)
+ (message "%s" elem))))
+ (comp-log-to-buffer data quoted))))
+
+(define-derived-mode native-comp-limple-mode fundamental-mode "LIMPLE"
+ "Syntax-highlight LIMPLE IR."
+ (setf font-lock-defaults '(comp-limple-lock-keywords)))
+
+(cl-defun comp-log-to-buffer (data &optional quoted)
+ "Log DATA to `comp-log-buffer-name'."
+ (let* ((print-f (if quoted #'prin1 #'princ))
+ (log-buffer
+ (or (get-buffer comp-log-buffer-name)
+ (with-current-buffer (get-buffer-create comp-log-buffer-name)
+ (unless (derived-mode-p 'compilation-mode)
+ (emacs-lisp-compilation-mode))
+ (current-buffer))))
+ (log-window (get-buffer-window log-buffer))
+ (inhibit-read-only t)
+ at-end-p)
+ (with-current-buffer log-buffer
+ (unless (eq major-mode 'native-comp-limple-mode)
+ (native-comp-limple-mode))
+ (when (= (point) (point-max))
+ (setf at-end-p t))
+ (save-excursion
+ (goto-char (point-max))
+ (cl-typecase data
+ (atom (funcall print-f data log-buffer))
+ (t (dolist (elem data)
+ (funcall print-f elem log-buffer)
+ (insert "\n"))))
+ (insert "\n"))
+ (when (and at-end-p log-window)
+ ;; When log window's point is at the end, follow the tail.
+ (with-selected-window log-window
+ (goto-char (point-max)))))))
+
+(defun comp-ensure-native-compiler ()
+ "Make sure Emacs has native compiler support and libgccjit can be loaded.
+Signal an error otherwise.
+To be used by all entry points."
+ (cond
+ ((null (featurep 'native-compile))
+ (error "Emacs was not compiled with native compiler support (--with-native-compilation)"))
+ ((null (native-comp-available-p))
+ (error "Cannot find libgccjit library"))))
+
+(defun comp-trampoline-filename (subr-name)
+ "Given SUBR-NAME return the filename containing the trampoline."
+ (concat (comp-c-func-name subr-name "subr--trampoline-" t) ".eln"))
+
+(defun comp-eln-load-path-eff ()
+ "Return a list of effective eln load directories.
+Account for `native-comp-eln-load-path' and `comp-native-version-dir'."
+ (mapcar (lambda (dir)
+ (expand-file-name comp-native-version-dir
+ (file-name-as-directory
+ (expand-file-name dir invocation-directory))))
+ native-comp-eln-load-path))
+
+;;;###autoload
+(defun comp-function-type-spec (function)
+ "Return the type specifier of FUNCTION.
+
+This function returns a cons cell whose car is the function
+specifier, and cdr is a symbol, either `inferred' or `know'.
+If the symbol is `inferred', the type specifier is automatically
+inferred from the code itself by the native compiler; if it is
+`know', the type specifier comes from `comp-known-type-specifiers'."
+ (let ((kind 'know)
+ type-spec )
+ (when-let ((res (assoc function comp-known-type-specifiers)))
+ (setf type-spec (cadr res)))
+ (let ((f (and (symbolp function)
+ (symbol-function function))))
+ (when (and f
+ (null type-spec)
+ (subr-native-elisp-p f))
+ (setf kind 'inferred
+ type-spec (subr-type f))))
+ (when type-spec
+ (cons type-spec kind))))
+
+(provide 'comp-common)
+
+;;; comp-common.el ends here
diff --git a/lisp/emacs-lisp/comp-cstr.el b/lisp/emacs-lisp/comp-cstr.el
index ecbe6e38a1d..cbfb9540f03 100644
--- a/lisp/emacs-lisp/comp-cstr.el
+++ b/lisp/emacs-lisp/comp-cstr.el
@@ -36,14 +36,9 @@
;;; Code:
(require 'cl-lib)
+(require 'cl-extra) ;HACK: For `cl-find-class' when `cl-loaddefs' is missing.
-(defconst comp--typeof-builtin-types (mapcar (lambda (x)
- (append x '(t)))
- cl--typeof-types)
- ;; TODO can we just add t in `cl--typeof-types'?
- "Like `cl--typeof-types' but with t as common supertype.")
-
-(cl-defstruct (comp-cstr (:constructor comp-type-to-cstr
+(cl-defstruct (comp-cstr (:constructor comp--type-to-cstr
(type &aux
(null (eq type 'null))
(integer (eq type 'integer))
@@ -54,7 +49,7 @@
'(nil)))
(range (when integer
'((- . +))))))
- (:constructor comp-value-to-cstr
+ (:constructor comp--value-to-cstr
(value &aux
(integer (integerp value))
(valset (unless integer
@@ -62,7 +57,7 @@
(range (when integer
`((,value . ,value))))
(typeset ())))
- (:constructor comp-irange-to-cstr
+ (:constructor comp--irange-to-cstr
(irange &aux
(range (list irange))
(typeset ())))
@@ -86,14 +81,44 @@ Integer values are handled in the `range' slot.")
(ret nil :type (or comp-cstr comp-cstr-f)
:documentation "Returned value."))
+(defun comp--cl-class-hierarchy (x)
+ "Given a class name `x' return its hierarchy."
+ (cl--class-allparents (cl--find-class x)))
+
+(defun comp--all-classes ()
+ "Return all non built-in type names currently defined."
+ (let (res)
+ (mapatoms (lambda (x)
+ (when (cl-find-class x)
+ (push x res)))
+ obarray)
+ res))
+
+(defun comp--compute-typeof-types ()
+ (mapcar #'comp--cl-class-hierarchy (comp--all-classes)))
+
+(defun comp--compute--pred-type-h ()
+ (cl-loop with h = (make-hash-table :test #'eq)
+ for class-name in (comp--all-classes)
+ for pred = (get class-name 'cl-deftype-satisfies)
+ when pred
+ do (puthash pred (comp--type-to-cstr class-name) h)
+ finally return h))
+
(cl-defstruct comp-cstr-ctxt
+ (typeof-types (comp--compute-typeof-types)
+ :type list
+ :documentation "Type hierarchy.")
+ (pred-type-h (comp--compute--pred-type-h)
+ :type hash-table
+ :documentation "Hash pred -> type.")
(union-typesets-mem (make-hash-table :test #'equal) :type hash-table
:documentation "Serve memoization for
`comp-union-typesets'.")
;; TODO we should be able to just cons hash this.
(common-supertype-mem (make-hash-table :test #'equal) :type hash-table
:documentation "Serve memoization for
-`comp-common-supertype'.")
+`comp-ctxt-common-supertype-mem'.")
(subtype-p-mem (make-hash-table :test #'equal) :type hash-table
:documentation "Serve memoization for
`comp-cstr-ctxt-subtype-p-mem'.")
@@ -107,6 +132,15 @@ Integer values are handled in the `range' slot.")
:documentation "Serve memoization for
`intersection-mem'."))
+(defun comp-cstr-ctxt-update-type-slots (ctxt)
+ "Update the type related slots of CTXT.
+This must run after byte compilation in order to account for user
+defined types."
+ (setf (comp-cstr-ctxt-typeof-types ctxt)
+ (comp--compute-typeof-types))
+ (setf (comp-cstr-ctxt-pred-type-h ctxt)
+ (comp--compute--pred-type-h)))
+
(defmacro with-comp-cstr-accessors (&rest body)
"Define some quick accessor to reduce code vergosity in BODY."
(declare (debug (form body))
@@ -183,10 +217,10 @@ Return them as multiple value."
;; builds.
(defvar comp-ctxt nil)
-(defvar comp-cstr-one (comp-value-to-cstr 1)
+(defvar comp-cstr-one (comp--value-to-cstr 1)
"Represent the integer immediate one.")
-(defvar comp-cstr-t (comp-type-to-cstr t)
+(defvar comp-cstr-t (comp--type-to-cstr t)
"Represent the superclass t.")
@@ -220,69 +254,104 @@ Return them as multiple value."
;;; Type handling.
-(defun comp-normalize-typeset (typeset)
- "Sort TYPESET and return it."
- (cl-sort (cl-remove-duplicates typeset)
- (lambda (x y)
- (string-lessp (symbol-name x)
- (symbol-name y)))))
+(defun comp--sym-lessp (x y)
+ "Like `string-lessp' but for symbol names."
+ (string-lessp (symbol-name x)
+ (symbol-name y)))
-(defun comp-supertypes (type)
- "Return a list of pairs (supertype . hierarchy-level) for TYPE."
- (cl-loop
- named outer
- with found = nil
- for l in comp--typeof-builtin-types
- do (cl-loop
- for x in l
- for i from (length l) downto 0
- when (eq type x)
- do (setf found t)
- when found
- collect `(,x . ,i) into res
- finally (when found
- (cl-return-from outer res)))))
-
-(defun comp-common-supertype-2 (type1 type2)
- "Return the first common supertype of TYPE1 TYPE2."
- (when-let ((types (cl-intersection
- (comp-supertypes type1)
- (comp-supertypes type2)
- :key #'car)))
- (car (cl-reduce (lambda (x y)
- (if (> (cdr x) (cdr y)) x y))
- types))))
-
-(defun comp-common-supertype (&rest types)
- "Return the first common supertype of TYPES."
- (or (gethash types (comp-cstr-ctxt-common-supertype-mem comp-ctxt))
- (puthash types
- (cl-reduce #'comp-common-supertype-2 types)
- (comp-cstr-ctxt-common-supertype-mem comp-ctxt))))
+(defun comp--direct-supertypes (type)
+ (when (symbolp type) ;; FIXME: Can this test ever fail?
+ (let* ((class (cl--find-class type))
+ (parents (if class (cl--class-parents class))))
+ (mapcar #'cl--class-name parents))))
(defsubst comp-subtype-p (type1 type2)
"Return t if TYPE1 is a subtype of TYPE2 or nil otherwise."
(let ((types (cons type1 type2)))
(or (gethash types (comp-cstr-ctxt-subtype-p-mem comp-ctxt))
(puthash types
- (eq (comp-common-supertype-2 type1 type2) type2)
+ (memq type2 (comp-supertypes type1))
(comp-cstr-ctxt-subtype-p-mem comp-ctxt)))))
+(defun comp--normalize-typeset0 (typeset)
+ ;; For every type search its supertypes. If all the subtypes of a
+ ;; supertype are presents remove all of them, add the identified
+ ;; supertype and restart.
+ ;; FIXME: The intention is to return a 100% equivalent but simpler
+ ;; typeset, but this is only the case when the supertype is abstract
+ ;; and "final/closed" (i.e. can't have new subtypes).
+ (when typeset
+ (while (eq 'restart
+ (cl-loop
+ named main
+ for sup in (cl-remove-duplicates
+ (apply #'append
+ (mapcar #'comp--direct-supertypes typeset)))
+ for subs = (comp--direct-subtypes sup)
+ when (and (length> subs 1) ;; If there's only one sub do
+ ;; nothing as we want to
+ ;; return the most specific
+ ;; type.
+ (cl-every (lambda (sub)
+ (cl-some (lambda (type)
+ (comp-subtype-p sub type))
+ typeset))
+ subs))
+ do (progn
+ (setq typeset (cons sup (cl-set-difference typeset subs)))
+ (cl-return-from main 'restart)))))
+ typeset))
+
+(defun comp-normalize-typeset (typeset)
+ "Sort TYPESET and return it."
+ (cl-sort (comp--normalize-typeset0 (cl-remove-duplicates typeset)) #'comp--sym-lessp))
+
+(defun comp--direct-subtypes (type)
+ "Return all the direct subtypes of TYPE."
+ ;; TODO: memoize.
+ (let ((subtypes ()))
+ (dolist (j (comp-cstr-ctxt-typeof-types comp-ctxt))
+ (let ((occur (memq type j)))
+ (when occur
+ (while (not (eq j occur))
+ (let ((candidate (pop j)))
+ (when (and (not (memq candidate subtypes))
+ (memq type (comp--direct-supertypes candidate)))
+ (push candidate subtypes)))))))
+ (cl-sort subtypes #'comp--sym-lessp)))
+
+(defun comp--intersection (list1 list2)
+ "Like `cl-intersection` but preserves the order of one of its args."
+ (if (equal list1 list2) list1
+ (let ((res nil))
+ (while list2
+ (if (memq (car list2) list1)
+ (push (car list2) res))
+ (pop list2))
+ (nreverse res))))
+
+(defun comp-supertypes (type)
+ "Return the ordered list of supertypes of TYPE."
+ (or (assq type (comp-cstr-ctxt-typeof-types comp-ctxt))
+ (error "Type %S missing from typeof-types!" type)))
+
(defun comp-union-typesets (&rest typesets)
"Union types present into TYPESETS."
(or (gethash typesets (comp-cstr-ctxt-union-typesets-mem comp-ctxt))
(puthash typesets
(cl-loop
- with types = (apply #'append typesets)
+ ;; List of (TYPE . SUPERTYPES)", ordered from
+ ;; "most general" to "least general"
+ with typess = (sort (mapcar #'comp-supertypes
+ (apply #'append typesets))
+ (lambda (l1 l2)
+ (<= (length l1) (length l2))))
with res = '()
- for lane in comp--typeof-builtin-types
- do (cl-loop
- with last = nil
- for x in lane
- when (memq x types)
- do (setf last x)
- finally (when last
- (push last res)))
+ for types in typess
+ ;; Don't keep this type if it's a subtype of one of
+ ;; the other types.
+ unless (comp--intersection types res)
+ do (push (car types) res)
finally return (comp-normalize-typeset res))
(comp-cstr-ctxt-union-typesets-mem comp-ctxt))))
@@ -503,7 +572,7 @@ All SRCS constraints must be homogeneously negated or non-negated."
;; We propagate only values those types are not already
;; into typeset.
when (cl-notany (lambda (x)
- (comp-subtype-p (type-of v) x))
+ (comp-subtype-p (cl-type-of v) x))
(comp-cstr-typeset dst))
collect v)))
@@ -592,7 +661,7 @@ DST is returned."
;; Verify disjoint condition between positive types and
;; negative types coming from values, in case give-up.
- (let ((neg-value-types (nconc (mapcar #'type-of (valset neg))
+ (let ((neg-value-types (nconc (mapcar #'cl-type-of (valset neg))
(when (range neg)
'(integer)))))
(when (cl-some (lambda (x)
@@ -613,7 +682,7 @@ DST is returned."
((cl-some (lambda (x)
(cl-some (lambda (y)
(comp-subtype-p y x))
- (mapcar #'type-of (valset pos))))
+ (mapcar #'cl-type-of (valset pos))))
(typeset neg))
(give-up))
(t
@@ -776,7 +845,7 @@ Non memoized version of `comp-cstr-intersection-no-mem'."
(comp-subtype-p neg-type pos-type))
do (cl-loop
with found
- for (type . _) in (comp-supertypes neg-type)
+ for type in (comp-supertypes neg-type)
when found
collect type into res
when (eq type pos-type)
@@ -869,6 +938,23 @@ Non memoized version of `comp-cstr-intersection-no-mem'."
(null (neg cstr))
(equal (typeset cstr) '(cons)))))
+;; Move to comp.el?
+(defsubst comp-cstr-cl-tag-p (cstr)
+ "Return non-nil if CSTR is a CL tag."
+ (with-comp-cstr-accessors
+ (and (null (range cstr))
+ (null (neg cstr))
+ (null (typeset cstr))
+ (length= (valset cstr) 1)
+ (string-match (rx "cl-struct-" (group-n 1 (1+ not-newline)) "-tags")
+ (symbol-name (car (valset cstr)))))))
+
+(defsubst comp-cstr-cl-tag (cstr)
+ "If CSTR is a CL tag return its tag name."
+ (with-comp-cstr-accessors
+ (and (comp-cstr-cl-tag-p cstr)
+ (intern (match-string 1 (symbol-name (car (valset cstr))))))))
+
(defun comp-cstr-= (dst op1 op2)
"Constraint OP1 being = OP2 setting the result into DST."
(with-comp-cstr-accessors
@@ -1019,7 +1105,7 @@ DST is returned."
(cl-loop for v in (valset dst)
unless (symbolp v)
do (push v strip-values)
- (push (type-of v) strip-types))
+ (push (cl-type-of v) strip-types))
(when strip-values
(setf (typeset dst) (comp-union-typesets (typeset dst) strip-types)
(valset dst) (cl-set-difference (valset dst) strip-values)))
@@ -1088,14 +1174,14 @@ FN non-nil indicates we are parsing a function lambda list."
('nil
(make-comp-cstr :typeset ()))
('fixnum
- (comp-irange-to-cstr `(,most-negative-fixnum . ,most-positive-fixnum)))
+ (comp--irange-to-cstr `(,most-negative-fixnum . ,most-positive-fixnum)))
('boolean
(comp-type-spec-to-cstr '(member t nil)))
('integer
- (comp-irange-to-cstr '(- . +)))
- ('null (comp-value-to-cstr nil))
+ (comp--irange-to-cstr '(- . +)))
+ ('null (comp--value-to-cstr nil))
((pred atom)
- (comp-type-to-cstr type-spec))
+ (comp--type-to-cstr type-spec))
(`(or . ,rest)
(apply #'comp-cstr-union-make
(mapcar #'comp-type-spec-to-cstr rest)))
@@ -1105,16 +1191,16 @@ FN non-nil indicates we are parsing a function lambda list."
(`(not ,cstr)
(comp-cstr-negation-make (comp-type-spec-to-cstr cstr)))
(`(integer ,(and (pred integerp) l) ,(and (pred integerp) h))
- (comp-irange-to-cstr `(,l . ,h)))
+ (comp--irange-to-cstr `(,l . ,h)))
(`(integer * ,(and (pred integerp) h))
- (comp-irange-to-cstr `(- . ,h)))
+ (comp--irange-to-cstr `(- . ,h)))
(`(integer ,(and (pred integerp) l) *)
- (comp-irange-to-cstr `(,l . +)))
+ (comp--irange-to-cstr `(,l . +)))
(`(float ,(pred comp-star-or-num-p) ,(pred comp-star-or-num-p))
;; No float range support :/
- (comp-type-to-cstr 'float))
+ (comp--type-to-cstr 'float))
(`(member . ,rest)
- (apply #'comp-cstr-union-make (mapcar #'comp-value-to-cstr rest)))
+ (apply #'comp-cstr-union-make (mapcar #'comp--value-to-cstr rest)))
(`(function ,args ,ret)
(make-comp-cstr-f
:args (mapcar (lambda (x)
@@ -1123,8 +1209,8 @@ FN non-nil indicates we are parsing a function lambda list."
:ret (comp-type-spec-to-cstr ret)))
(_ (error "Invalid type specifier"))))
-(defun comp-cstr-to-type-spec (cstr)
- "Given CSTR return its type specifier."
+(defun comp--simple-cstr-to-type-spec (cstr)
+ "Given a non comp-cstr-f CSTR return its type specifier."
(let ((valset (comp-cstr-valset cstr))
(typeset (comp-cstr-typeset cstr))
(range (comp-cstr-range cstr))
@@ -1178,6 +1264,20 @@ FN non-nil indicates we are parsing a function lambda list."
`(not ,final)
final))))
+(defun comp-cstr-to-type-spec (cstr)
+ "Given CSTR return its type specifier."
+ (cl-etypecase cstr
+ (comp-cstr-f
+ `(function
+ ,(mapcar (lambda (x)
+ (cl-etypecase x
+ (comp-cstr (comp-cstr-to-type-spec x))
+ (symbol x)))
+ (comp-cstr-f-args cstr))
+ ,(comp--simple-cstr-to-type-spec (comp-cstr-f-ret cstr))))
+ (comp-cstr
+ (comp--simple-cstr-to-type-spec cstr))))
+
(provide 'comp-cstr)
;;; comp-cstr.el ends here
diff --git a/lisp/emacs-lisp/comp-run.el b/lisp/emacs-lisp/comp-run.el
new file mode 100644
index 00000000000..5cc61579030
--- /dev/null
+++ b/lisp/emacs-lisp/comp-run.el
@@ -0,0 +1,483 @@
+;;; comp-runtime.el --- runtime Lisp native compiler code -*- lexical-binding: t -*-
+
+;; Copyright (C) 2023-2024 Free Software Foundation, Inc.
+
+;; Author: Andrea Corallo <acorallo@gnu.org>
+;; Keywords: lisp
+;; Package: emacs
+
+;; This file is part of GNU Emacs.
+
+;; GNU Emacs is free software: you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+
+;; GNU Emacs is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>.
+
+;;; Commentary:
+
+;; While the main native compiler is implemented in comp.el, when
+;; commonly used as a jit compiler it is only loaded by Emacs sub
+;; processes performing async compilation. This file contains all
+;; the code needed to drive async compilations and any Lisp code
+;; needed at runtime to run native code.
+
+;;; Code:
+
+(eval-when-compile (require 'cl-lib))
+(require 'comp-common)
+(require 'bytecomp) ;; For `emacs-lisp-compilation-mode'.
+
+(defgroup comp-run nil
+ "Emacs Lisp native compiler runtime."
+ :group 'lisp)
+
+(defcustom native-comp-jit-compilation-deny-list
+ '()
+ "List of regexps to exclude matching files from deferred native compilation.
+Files whose names match any regexp are excluded from native compilation."
+ :type '(repeat regexp)
+ :version "28.1")
+
+(defcustom native-comp-async-jobs-number 0
+ "Default number of subprocesses used for async native compilation.
+Value of zero means to use half the number of the CPU's execution units,
+or one if there's just one execution unit."
+ :type 'natnum
+ :risky t
+ :version "28.1")
+
+(defcustom native-comp-async-report-warnings-errors t
+ "Whether to report warnings and errors from asynchronous native compilation.
+
+When native compilation happens asynchronously, it can produce
+warnings and errors, some of which might not be emitted by a
+byte-compilation. The typical case for that is native-compiling
+a file that is missing some `require' of a necessary feature,
+while having it already loaded into the environment when
+byte-compiling.
+
+As asynchronous native compilation always starts from a pristine
+environment, it is more sensitive to such omissions, and might be
+unable to compile such Lisp source files correctly.
+
+Set this variable to nil to suppress warnings altogether, or to
+the symbol `silent' to log warnings but not pop up the *Warnings*
+buffer."
+ :type '(choice
+ (const :tag "Do not report warnings/errors" nil)
+ (const :tag "Report and display warnings/errors" t)
+ (const :tag "Report but do not display warnings/errors" silent))
+ :version "28.1")
+
+(defcustom native-comp-async-warnings-errors-kind 'important
+ "Which kind of warnings and errors to report from async native compilation.
+
+Setting this variable to `important' (the default) will report
+only important warnings and all errors.
+Setting this variable to `all' will report all warnings and
+errors."
+ :type '(choice
+ (const :tag "Report all warnings/errors" all)
+ (const :tag "Report important warnings and all errors" important))
+ :version "30.1")
+
+(defcustom native-comp-always-compile nil
+ "Non-nil means unconditionally (re-)compile all files."
+ :type 'boolean
+ :version "28.1")
+
+(make-obsolete-variable 'native-comp-deferred-compilation-deny-list
+ 'native-comp-jit-compilation-deny-list
+ "29.1")
+
+(defcustom native-comp-async-cu-done-functions nil
+ "List of functions to call when asynchronous compilation of a file is done.
+Each function is called with one argument FILE, the filename whose
+compilation has completed."
+ :type 'hook
+ :version "28.1")
+
+(defcustom native-comp-async-all-done-hook nil
+ "Hook run after completing asynchronous compilation of all input files."
+ :type 'hook
+ :version "28.1")
+
+(defcustom native-comp-async-query-on-exit nil
+ "Whether to query the user about killing async compilations when exiting.
+If this is non-nil, Emacs will ask for confirmation to exit and kill the
+asynchronous native compilations if any are running. If nil, when you
+exit Emacs, it will silently kill those asynchronous compilations even
+if `confirm-kill-processes' is non-nil."
+ :type 'boolean
+ :version "28.1")
+
+(defconst comp-async-buffer-name "*Async-native-compile-log*"
+ "Name of the async compilation buffer log.")
+
+(defvar comp-no-spawn nil
+ "Non-nil don't spawn native compilation processes.")
+
+(defvar comp-async-compilations (make-hash-table :test #'equal)
+ "Hash table file-name -> async compilation process.")
+
+;; These variables and functions are defined in comp.c
+(defvar comp--no-native-compile)
+(defvar comp-deferred-pending-h)
+(defvar comp-installed-trampolines-h)
+(defvar native-comp-enable-subr-trampolines)
+
+(declare-function comp--install-trampoline "comp.c")
+(declare-function comp-el-to-eln-filename "comp.c")
+(declare-function native-elisp-load "comp.c")
+
+(defun native-compile-async-skip-p (file load selector)
+ "Return non-nil if FILE's compilation should be skipped.
+
+LOAD and SELECTOR work as described in `native--compile-async'."
+ ;; Make sure we are not already compiling `file' (bug#40838).
+ (or (gethash file comp-async-compilations)
+ (gethash (file-name-with-extension file "elc") comp--no-native-compile)
+ (cond
+ ((null selector) nil)
+ ((functionp selector) (not (funcall selector file)))
+ ((stringp selector) (not (string-match-p selector file)))
+ (t (error "SELECTOR must be a function a regexp or nil")))
+ ;; Also exclude files from deferred compilation if
+ ;; any of the regexps in
+ ;; `native-comp-jit-compilation-deny-list' matches.
+ (and (eq load 'late)
+ (seq-some (lambda (re)
+ (string-match-p re file))
+ native-comp-jit-compilation-deny-list))))
+
+(defvar comp-files-queue ()
+ "List of Emacs Lisp files to be compiled.")
+
+(defvar comp-async-compilations (make-hash-table :test #'equal)
+ "Hash table file-name -> async compilation process.")
+
+(defun comp-async-runnings ()
+ "Return the number of async compilations currently running.
+This function has the side effect of cleaning-up finished
+processes from `comp-async-compilations'"
+ (cl-loop
+ for file-name in (cl-loop
+ for file-name being each hash-key of comp-async-compilations
+ for prc = (gethash file-name comp-async-compilations)
+ unless (process-live-p prc)
+ collect file-name)
+ do (remhash file-name comp-async-compilations))
+ (hash-table-count comp-async-compilations))
+
+(defvar comp-num-cpus nil)
+(defun comp-effective-async-max-jobs ()
+ "Compute the effective number of async jobs."
+ (if (zerop native-comp-async-jobs-number)
+ (or comp-num-cpus
+ (setf comp-num-cpus
+ (max 1 (/ (num-processors) 2))))
+ native-comp-async-jobs-number))
+
+(defvar comp-last-scanned-async-output nil)
+(make-variable-buffer-local 'comp-last-scanned-async-output)
+;; From warnings.el
+(defvar warning-suppress-types)
+(defun comp-accept-and-process-async-output (process)
+ "Accept PROCESS output and check for diagnostic messages."
+ (if native-comp-async-report-warnings-errors
+ (let ((warning-suppress-types
+ (if (eq native-comp-async-report-warnings-errors 'silent)
+ (cons '(comp) warning-suppress-types)
+ warning-suppress-types))
+ (regexp (if (eq native-comp-async-warnings-errors-kind 'all)
+ "^.*?\\(?:Error\\|Warning\\): .*$"
+ (rx bol
+ (*? nonl)
+ (or
+ (seq "Error: " (*? nonl))
+ (seq "Warning: the function ‘" (1+ (not "’"))
+ "’ is not known to be defined."))
+ eol))))
+ (with-current-buffer (process-buffer process)
+ (save-excursion
+ (accept-process-output process)
+ (goto-char (or comp-last-scanned-async-output (point-min)))
+ (while (re-search-forward regexp nil t)
+ (display-warning 'comp (match-string 0)))
+ (setq comp-last-scanned-async-output (point-max)))))
+ (accept-process-output process)))
+
+(defconst comp-valid-source-re (rx ".el" (? ".gz") eos)
+ "Regexp to match filename of valid input source files.")
+
+(defun comp-run-async-workers ()
+ "Start compiling files from `comp-files-queue' asynchronously.
+When compilation is finished, run `native-comp-async-all-done-hook' and
+display a message."
+ (cl-assert (null comp-no-spawn))
+ (if (or comp-files-queue
+ (> (comp-async-runnings) 0))
+ (unless (>= (comp-async-runnings) (comp-effective-async-max-jobs))
+ (cl-loop
+ for (source-file . load) = (pop comp-files-queue)
+ while source-file
+ do (cl-assert (string-match-p comp-valid-source-re source-file) nil
+ "`comp-files-queue' should be \".el\" files: %s"
+ source-file)
+ when (or native-comp-always-compile
+ load ; Always compile when the compilation is
+ ; commanded for late load.
+ ;; Skip compilation if `comp-el-to-eln-filename' fails
+ ;; to find a writable directory.
+ (with-demoted-errors "Async compilation :%S"
+ (file-newer-than-file-p
+ source-file (comp-el-to-eln-filename source-file))))
+ do (let* ((expr `((require 'comp)
+ (setq comp-async-compilation t
+ warning-fill-column most-positive-fixnum)
+ ,(let ((set (list 'setq)))
+ (dolist (var '(comp-file-preloaded-p
+ native-compile-target-directory
+ native-comp-speed
+ native-comp-debug
+ native-comp-verbose
+ comp-libgccjit-reproducer
+ native-comp-eln-load-path
+ native-comp-compiler-options
+ native-comp-driver-options
+ load-path
+ backtrace-line-length
+ byte-compile-warnings
+ comp-sanitizer-emit
+ ;; package-load-list
+ ;; package-user-dir
+ ;; package-directory-list
+ ))
+ (when (boundp var)
+ (push var set)
+ (push `',(symbol-value var) set)))
+ (nreverse set))
+ ;; FIXME: Activating all packages would align the
+ ;; functionality offered with what is usually done
+ ;; for ELPA packages (and thus fix some compilation
+ ;; issues with some ELPA packages), but it's too
+ ;; blunt an instrument (e.g. we don't even know if
+ ;; we're compiling such an ELPA package at
+ ;; this point).
+ ;;(package-activate-all)
+ ,native-comp-async-env-modifier-form
+ (message "Compiling %s..." ,source-file)
+ (comp--native-compile ,source-file ,(and load t))))
+ (source-file1 source-file) ;; Make the closure works :/
+ (temp-file (make-temp-file
+ (concat "emacs-async-comp-"
+ (file-name-base source-file) "-")
+ nil ".el"))
+ (expr-strings (let ((print-length nil)
+ (print-level nil))
+ (mapcar #'prin1-to-string expr)))
+ (_ (progn
+ (with-temp-file temp-file
+ (mapc #'insert expr-strings))
+ (comp-log "\n")
+ (mapc #'comp-log expr-strings)))
+ (load1 load)
+ (default-directory invocation-directory)
+ (process (make-process
+ :name (concat "Compiling: " source-file)
+ :buffer (with-current-buffer
+ (get-buffer-create
+ comp-async-buffer-name)
+ (unless (derived-mode-p 'compilation-mode)
+ (emacs-lisp-compilation-mode))
+ (current-buffer))
+ :command (list
+ (expand-file-name invocation-name
+ invocation-directory)
+ "-no-comp-spawn" "-Q" "--batch"
+ "--eval"
+ ;; Suppress Abort dialogs on MS-Windows
+ "(setq w32-disable-abort-dialog t)"
+ "-l" temp-file)
+ :sentinel
+ (lambda (process _event)
+ (run-hook-with-args
+ 'native-comp-async-cu-done-functions
+ source-file)
+ (comp-accept-and-process-async-output process)
+ (ignore-errors (delete-file temp-file))
+ (let ((eln-file (comp-el-to-eln-filename
+ source-file1)))
+ (when (and load1
+ (zerop (process-exit-status
+ process))
+ (file-exists-p eln-file))
+ (native-elisp-load eln-file
+ (eq load1 'late))))
+ (comp-run-async-workers))
+ :noquery (not native-comp-async-query-on-exit))))
+ (puthash source-file process comp-async-compilations))
+ when (>= (comp-async-runnings) (comp-effective-async-max-jobs))
+ do (cl-return)))
+ ;; No files left to compile and all processes finished.
+ (run-hooks 'native-comp-async-all-done-hook)
+ (with-current-buffer (get-buffer-create comp-async-buffer-name)
+ (save-excursion
+ (unless (derived-mode-p 'compilation-mode)
+ (emacs-lisp-compilation-mode))
+ (let ((inhibit-read-only t))
+ (goto-char (point-max))
+ (insert "Compilation finished.\n"))))
+ ;; `comp-deferred-pending-h' should be empty at this stage.
+ ;; Reset it anyway.
+ (clrhash comp-deferred-pending-h)))
+
+(defconst comp-warn-primitives
+ '(null memq gethash and subrp not subr-native-elisp-p
+ comp--install-trampoline concat if symbolp symbol-name make-string
+ length aset aref length> mapcar expand-file-name
+ file-name-as-directory file-exists-p native-elisp-load)
+ "List of primitives we want to warn about in case of redefinition.
+This are essential for the trampoline machinery to work properly.")
+
+(defun comp-trampoline-search (subr-name)
+ "Search a trampoline file for SUBR-NAME.
+Return the trampoline if found or nil otherwise."
+ (cl-loop
+ with rel-filename = (comp-trampoline-filename subr-name)
+ for dir in (comp-eln-load-path-eff)
+ for filename = (expand-file-name rel-filename dir)
+ when (file-exists-p filename)
+ do (cl-return (native-elisp-load filename))))
+
+(declare-function comp-trampoline-compile "comp")
+;;;###autoload
+(defun comp-subr-trampoline-install (subr-name)
+ "Make SUBR-NAME effectively advice-able when called from native code."
+ (when (memq subr-name comp-warn-primitives)
+ (warn "Redefining `%s' might break native compilation of trampolines."
+ subr-name))
+ (let ((subr (symbol-function subr-name)))
+ (unless (or (not (string= subr-name (subr-name subr))) ;; (bug#69573)
+ (null native-comp-enable-subr-trampolines)
+ (memq subr-name native-comp-never-optimize-functions)
+ (gethash subr-name comp-installed-trampolines-h))
+ (cl-assert (subr-primitive-p subr))
+ (when-let ((trampoline (or (comp-trampoline-search subr-name)
+ (comp-trampoline-compile subr-name))))
+ (comp--install-trampoline subr-name trampoline)))))
+
+;;;###autoload
+(defun native--compile-async (files &optional recursively load selector)
+ ;; BEWARE, this function is also called directly from C.
+ "Compile FILES asynchronously.
+FILES is one filename or a list of filenames or directories.
+
+If optional argument RECURSIVELY is non-nil, recurse into
+subdirectories of given directories.
+
+If optional argument LOAD is non-nil, request to load the file
+after compiling.
+
+The optional argument SELECTOR has the following valid values:
+
+nil -- Select all files.
+a string -- A regular expression selecting files with matching names.
+a function -- A function selecting files with matching names.
+
+The variable `native-comp-async-jobs-number' specifies the number
+of (commands) to run simultaneously.
+
+LOAD can also be the symbol `late'. This is used internally if
+the byte code has already been loaded when this function is
+called. It means that we request the special kind of load
+necessary in that situation, called \"late\" loading.
+
+During a \"late\" load, instead of executing all top-level forms
+of the original files, only function definitions are
+loaded (paying attention to have these effective only if the
+bytecode definition was not changed in the meantime)."
+ (comp-ensure-native-compiler)
+ (unless (member load '(nil t late))
+ (error "LOAD must be nil, t or 'late"))
+ (unless (listp files)
+ (setf files (list files)))
+ (let ((added-something nil)
+ file-list)
+ (dolist (file-or-dir files)
+ (cond ((file-directory-p file-or-dir)
+ (dolist (file (if recursively
+ (directory-files-recursively
+ file-or-dir comp-valid-source-re)
+ (directory-files file-or-dir
+ t comp-valid-source-re)))
+ (push file file-list)))
+ ((file-exists-p file-or-dir) (push file-or-dir file-list))
+ (t (signal 'native-compiler-error
+ (list "Not a file nor directory" file-or-dir)))))
+ (dolist (file file-list)
+ (if-let ((entry (seq-find (lambda (x) (string= file (car x))) comp-files-queue)))
+ ;; Most likely the byte-compiler has requested a deferred
+ ;; compilation, so update `comp-files-queue' to reflect that.
+ (unless (or (null load)
+ (eq load (cdr entry)))
+ (setf comp-files-queue
+ (cl-loop for i in comp-files-queue
+ with old = (car entry)
+ if (string= (car i) old)
+ collect (cons file load)
+ else
+ collect i)))
+
+ (unless (native-compile-async-skip-p file load selector)
+ (let* ((out-filename (comp-el-to-eln-filename file))
+ (out-dir (file-name-directory out-filename)))
+ (unless (file-exists-p out-dir)
+ (make-directory out-dir t))
+ (if (file-writable-p out-filename)
+ (setf comp-files-queue
+ (append comp-files-queue `((,file . ,load)))
+ added-something t)
+ (display-warning 'comp
+ (format "No write access for %s skipping."
+ out-filename)))))))
+ ;; Perhaps nothing passed `native-compile-async-skip-p'?
+ (when (and added-something
+ ;; Don't start if there's one already running.
+ (zerop (comp-async-runnings)))
+ (comp-run-async-workers))))
+
+;;;###autoload
+(defun native-compile-async (files &optional recursively load selector)
+ "Compile FILES asynchronously.
+FILES is one file or a list of filenames or directories.
+
+If optional argument RECURSIVELY is non-nil, recurse into
+subdirectories of given directories.
+
+If optional argument LOAD is non-nil, request to load the file
+after compiling.
+
+The optional argument SELECTOR has the following valid values:
+
+nil -- Select all files.
+a string -- A regular expression selecting files with matching names.
+a function -- A function selecting files with matching names.
+
+The variable `native-comp-async-jobs-number' specifies the number
+of (commands) to run simultaneously."
+ ;; Normalize: we only want to pass t or nil, never e.g. `late'.
+ (let ((load (not (not load))))
+ (native--compile-async files recursively load selector)))
+
+(provide 'comp-run)
+
+;;; comp-run.el ends here
diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el
index 6b65a375ea0..2ec55ed98ee 100644
--- a/lisp/emacs-lisp/comp.el
+++ b/lisp/emacs-lisp/comp.el
@@ -29,16 +29,27 @@
;;; Code:
(require 'bytecomp)
-(require 'cl-extra)
(require 'cl-lib)
-(require 'cl-macs)
-(require 'cl-seq)
(require 'gv)
(require 'rx)
(require 'subr-x)
(require 'warnings)
+(require 'comp-common)
(require 'comp-cstr)
+;; These variables and functions are defined in comp.c
+(defvar comp-native-version-dir)
+(defvar comp-subr-arities-h)
+(defvar native-comp-eln-load-path)
+(defvar native-comp-enable-subr-trampolines)
+
+(declare-function comp--compile-ctxt-to-file0 "comp.c")
+(declare-function comp--init-ctxt "comp.c")
+(declare-function comp--release-ctxt "comp.c")
+(declare-function comp-el-to-eln-filename "comp.c")
+(declare-function comp-el-to-eln-rel-filename "comp.c")
+(declare-function native-elisp-load "comp.c")
+
(defgroup comp nil
"Emacs Lisp native compiler."
:group 'lisp)
@@ -57,7 +68,7 @@
:safe #'integerp
:version "28.1")
-(defcustom native-comp-debug 0
+(defcustom native-comp-debug 0
"Debug level for native compilation, a number between 0 and 3.
This is intended for debugging the compiler itself.
0 no debug output.
@@ -69,33 +80,6 @@ This is intended for debugging the compiler itself.
:safe #'natnump
:version "29.1")
-(defcustom native-comp-verbose 0
- "Compiler verbosity for native compilation, a number between 0 and 3.
-This is intended for debugging the compiler itself.
- 0 no logging.
- 1 final LIMPLE is logged.
- 2 LAP, final LIMPLE, and some pass info are logged.
- 3 max verbosity."
- :type 'natnum
- :risky t
- :version "28.1")
-
-(defcustom native-comp-always-compile nil
- "Non-nil means unconditionally (re-)compile all files."
- :type 'boolean
- :version "28.1")
-
-(defcustom native-comp-jit-compilation-deny-list
- '()
- "List of regexps to exclude matching files from deferred native compilation.
-Files whose names match any regexp are excluded from native compilation."
- :type '(repeat regexp)
- :version "28.1")
-
-(make-obsolete-variable 'native-comp-deferred-compilation-deny-list
- 'native-comp-jit-compilation-deny-list
- "29.1")
-
(defcustom native-comp-bootstrap-deny-list
'()
"List of regexps to exclude files from native compilation during bootstrap.
@@ -104,78 +88,6 @@ during bootstrap."
:type '(repeat regexp)
:version "28.1")
-(defcustom native-comp-never-optimize-functions
- '(;; The following two are mandatory for Emacs to be working
- ;; correctly (see comment in `advice--add-function'). DO NOT
- ;; REMOVE.
- macroexpand rename-buffer)
- "Primitive functions to exclude from trampoline optimization.
-
-Primitive functions included in this list will not be called
-directly by the natively-compiled code, which makes trampolines for
-those primitives unnecessary in case of function redefinition/advice."
- :type '(repeat symbol)
- :version "28.1")
-
-(defcustom native-comp-async-jobs-number 0
- "Default number of subprocesses used for async native compilation.
-Value of zero means to use half the number of the CPU's execution units,
-or one if there's just one execution unit."
- :type 'natnum
- :risky t
- :version "28.1")
-
-(defcustom native-comp-async-cu-done-functions nil
- "List of functions to call when asynchronous compilation of a file is done.
-Each function is called with one argument FILE, the filename whose
-compilation has completed."
- :type 'hook
- :version "28.1")
-
-(defcustom native-comp-async-all-done-hook nil
- "Hook run after completing asynchronous compilation of all input files."
- :type 'hook
- :version "28.1")
-
-(defcustom native-comp-async-env-modifier-form nil
- "Form evaluated before compilation by each asynchronous compilation subprocess.
-Used to modify the compiler environment."
- :type 'sexp
- :risky t
- :version "28.1")
-
-(defcustom native-comp-async-report-warnings-errors t
- "Whether to report warnings and errors from asynchronous native compilation.
-
-When native compilation happens asynchronously, it can produce
-warnings and errors, some of which might not be emitted by a
-byte-compilation. The typical case for that is native-compiling
-a file that is missing some `require' of a necessary feature,
-while having it already loaded into the environment when
-byte-compiling.
-
-As asynchronous native compilation always starts from a pristine
-environment, it is more sensitive to such omissions, and might be
-unable to compile such Lisp source files correctly.
-
-Set this variable to nil to suppress warnings altogether, or to
-the symbol `silent' to log warnings but not pop up the *Warnings*
-buffer."
- :type '(choice
- (const :tag "Do not report warnings" nil)
- (const :tag "Report and display warnings" t)
- (const :tag "Report but do not display warnings" silent))
- :version "28.1")
-
-(defcustom native-comp-async-query-on-exit nil
- "Whether to query the user about killing async compilations when exiting.
-If this is non-nil, Emacs will ask for confirmation to exit and kill the
-asynchronous native compilations if any are running. If nil, when you
-exit Emacs, it will silently kill those asynchronous compilations even
-if `confirm-kill-processes' is non-nil."
- :type 'boolean
- :version "28.1")
-
(defcustom native-comp-compiler-options nil
"Command line options passed verbatim to GCC compiler.
Note that not all options are meaningful and some options might even
@@ -186,8 +98,9 @@ and above."
:type '(repeat string)
:version "28.1")
-(defcustom native-comp-driver-options (when (eq system-type 'darwin)
- '("-Wl,-w"))
+(defcustom native-comp-driver-options
+ (cond ((eq system-type 'darwin) '("-Wl,-w"))
+ ((eq system-type 'cygwin) '("-Wl,-dynamicbase")))
"Options passed verbatim to the native compiler's back-end driver.
Note that not all options are meaningful; typically only the options
affecting the assembler and linker are likely to be useful.
@@ -230,15 +143,6 @@ Emacs Lisp file:
(defvar comp-dry-run nil
"If non-nil, run everything but the C back-end.")
-(defconst comp-valid-source-re (rx ".el" (? ".gz") eos)
- "Regexp to match filename of valid input source files.")
-
-(defconst comp-log-buffer-name "*Native-compile-Log*"
- "Name of the native-compiler log buffer.")
-
-(defconst comp-async-buffer-name "*Async-native-compile-log*"
- "Name of the async compilation buffer log.")
-
(defvar comp-native-compiling nil
"This gets bound to t during native compilation.
Intended to be used by code that needs to work differently when
@@ -251,17 +155,19 @@ native compilation runs.")
"Current allocation class.
Can be one of: `d-default', `d-impure' or `d-ephemeral'. See `comp-ctxt'.")
-(defconst comp-passes '(comp-spill-lap
- comp-limplify
- comp-fwprop
- comp-call-optim
- comp-ipa-pure
- comp-add-cstrs
- comp-fwprop
- comp-tco
- comp-fwprop
- comp-remove-type-hints
- comp-final)
+(defconst comp-passes '(comp--spill-lap
+ comp--limplify
+ comp--fwprop
+ comp--call-optim
+ comp--ipa-pure
+ comp--add-cstrs
+ comp--fwprop
+ comp--tco
+ comp--fwprop
+ comp--remove-type-hints
+ comp--sanitizer
+ comp--compute-function-types
+ comp--final)
"Passes to be executed in order.")
(defvar comp-disabled-passes '()
@@ -273,324 +179,6 @@ For internal use by the test suite only.")
Each function in FUNCTIONS is run after PASS.
Useful to hook into pass checkers.")
-;; FIXME this probably should not be here but... good for now.
-(defconst comp-known-type-specifiers
- `(
- ;; Functions we can trust not to be or if redefined should expose
- ;; the same type. Vast majority of these is either pure or
- ;; primitive, the original list is the union of pure +
- ;; side-effect-free-fns + side-effect-and-error-free-fns:
- (% (function ((or number marker) (or number marker)) number))
- (* (function (&rest (or number marker)) number))
- (+ (function (&rest (or number marker)) number))
- (- (function (&rest (or number marker)) number))
- (/ (function ((or number marker) &rest (or number marker)) number))
- (/= (function ((or number marker) (or number marker)) boolean))
- (1+ (function ((or number marker)) number))
- (1- (function ((or number marker)) number))
- (< (function ((or number marker) &rest (or number marker)) boolean))
- (<= (function ((or number marker) &rest (or number marker)) boolean))
- (= (function ((or number marker) &rest (or number marker)) boolean))
- (> (function ((or number marker) &rest (or number marker)) boolean))
- (>= (function ((or number marker) &rest (or number marker)) boolean))
- (abs (function (number) number))
- (acos (function (number) float))
- (append (function (&rest t) t))
- (aref (function (t fixnum) t))
- (arrayp (function (t) boolean))
- (ash (function (integer integer) integer))
- (asin (function (number) float))
- (assq (function (t list) list))
- (atan (function (number &optional number) float))
- (atom (function (t) boolean))
- (bignump (function (t) boolean))
- (bobp (function () boolean))
- (bolp (function () boolean))
- (bool-vector-count-consecutive (function (bool-vector boolean integer) fixnum))
- (bool-vector-count-population (function (bool-vector) fixnum))
- (bool-vector-not (function (bool-vector &optional bool-vector) bool-vector))
- (bool-vector-p (function (t) boolean))
- (bool-vector-subsetp (function (bool-vector bool-vector) boolean))
- (boundp (function (symbol) boolean))
- (buffer-end (function ((or number marker)) integer))
- (buffer-file-name (function (&optional buffer) (or string null)))
- (buffer-list (function (&optional frame) list))
- (buffer-local-variables (function (&optional buffer) list))
- (buffer-modified-p (function (&optional buffer) boolean))
- (buffer-size (function (&optional buffer) integer))
- (buffer-string (function () string))
- (buffer-substring (function ((or integer marker) (or integer marker)) string))
- (bufferp (function (t) boolean))
- (byte-code-function-p (function (t) boolean))
- (capitalize (function (or integer string) (or integer string)))
- (car (function (list) t))
- (car-less-than-car (function (list list) boolean))
- (car-safe (function (t) t))
- (case-table-p (function (t) boolean))
- (cdr (function (list) t))
- (cdr-safe (function (t) t))
- (ceiling (function (number &optional number) integer))
- (char-after (function (&optional (or marker integer)) (or fixnum null)))
- (char-before (function (&optional (or marker integer)) (or fixnum null)))
- (char-equal (function (integer integer) boolean))
- (char-or-string-p (function (t) boolean))
- (char-to-string (function (fixnum) string))
- (char-width (function (fixnum) fixnum))
- (characterp (function (t &optional t) boolean))
- (charsetp (function (t) boolean))
- (commandp (function (t &optional t) boolean))
- (compare-strings (function (string (or integer marker null) (or integer marker null) string (or integer marker null) (or integer marker null) &optional t) (or (member t) fixnum)))
- (concat (function (&rest sequence) string))
- (cons (function (t t) cons))
- (consp (function (t) boolean))
- (coordinates-in-window-p (function (cons window) boolean))
- (copy-alist (function (list) list))
- (copy-marker (function (&optional (or integer marker) boolean) marker))
- (copy-sequence (function (sequence) sequence))
- (copysign (function (float float) float))
- (cos (function (number) float))
- (count-lines (function ((or integer marker) (or integer marker) &optional t) integer))
- (current-buffer (function () buffer))
- (current-global-map (function () cons))
- (current-indentation (function () integer))
- (current-local-map (function () (or cons null)))
- (current-minor-mode-maps (function () (or cons null)))
- (current-time (function () cons))
- (current-time-string (function (&optional (or number list)
- (or symbol string cons integer))
- string))
- (current-time-zone (function (&optional (or number list)
- (or symbol string cons integer))
- cons))
- (custom-variable-p (function (symbol) boolean))
- (decode-char (function (cons t) (or fixnum null)))
- (decode-time (function (&optional (or number list)
- (or symbol string cons integer)
- symbol)
- cons))
- (default-boundp (function (symbol) boolean))
- (default-value (function (symbol) t))
- (degrees-to-radians (function (number) float))
- (documentation (function ((or function symbol subr) &optional t) (or null string)))
- (downcase (function ((or fixnum string)) (or fixnum string)))
- (elt (function (sequence integer) t))
- (encode-char (function (fixnum symbol) (or fixnum null)))
- (encode-time (function (cons &rest t) cons))
- (eobp (function () boolean))
- (eolp (function () boolean))
- (eq (function (t t) boolean))
- (eql (function (t t) boolean))
- (equal (function (t t) boolean))
- (error-message-string (function (list) string))
- (eventp (function (t) boolean))
- (exp (function (number) float))
- (expt (function (number number) float))
- (fboundp (function (symbol) boolean))
- (fceiling (function (float) float))
- (featurep (function (symbol &optional symbol) boolean))
- (ffloor (function (float) float))
- (file-directory-p (function (string) boolean))
- (file-exists-p (function (string) boolean))
- (file-locked-p (function (string) boolean))
- (file-name-absolute-p (function (string) boolean))
- (file-newer-than-file-p (function (string string) boolean))
- (file-readable-p (function (string) boolean))
- (file-symlink-p (function (string) boolean))
- (file-writable-p (function (string) boolean))
- (fixnump (function (t) boolean))
- (float (function (number) float))
- (float-time (function (&optional (or number list)) float))
- (floatp (function (t) boolean))
- (floor (function (number &optional number) integer))
- (following-char (function () fixnum))
- (format (function (string &rest t) string))
- (format-time-string (function (string &optional (or number list)
- (or symbol string cons integer))
- string))
- (frame-first-window (function ((or frame window)) window))
- (frame-root-window (function (&optional (or frame window)) window))
- (frame-selected-window (function (&optional (or frame window)) window))
- (frame-visible-p (function (frame) boolean))
- (framep (function (t) boolean))
- (fround (function (float) float))
- (ftruncate (function (float) float))
- (get (function (symbol symbol) t))
- (get-buffer (function ((or buffer string)) (or buffer null)))
- (get-buffer-window (function (&optional (or buffer string) (or symbol (integer 0 0))) (or null window)))
- (get-file-buffer (function (string) (or null buffer)))
- (get-largest-window (function (&optional t t t) (or window null)))
- (get-lru-window (function (&optional t t t) (or window null)))
- (getenv (function (string &optional frame) (or null string)))
- (gethash (function (t hash-table &optional t) t))
- (hash-table-count (function (hash-table) integer))
- (hash-table-p (function (t) boolean))
- (identity (function (t) t))
- (ignore (function (&rest t) null))
- (int-to-string (function (number) string))
- (integer-or-marker-p (function (t) boolean))
- (integerp (function (t) boolean))
- (interactive-p (function () boolean))
- (intern-soft (function ((or string symbol) &optional vector) symbol))
- (invocation-directory (function () string))
- (invocation-name (function () string))
- (isnan (function (float) boolean))
- (keymap-parent (function (cons) (or cons null)))
- (keymapp (function (t) boolean))
- (keywordp (function (t) boolean))
- (last (function (list &optional integer) list))
- (lax-plist-get (function (list t) t))
- (ldexp (function (number integer) float))
- (length (function (t) (integer 0 *)))
- (length< (function (sequence fixnum) boolean))
- (length= (function (sequence fixnum) boolean))
- (length> (function (sequence fixnum) boolean))
- (line-beginning-position (function (&optional integer) integer))
- (line-end-position (function (&optional integer) integer))
- (list (function (&rest t) list))
- (listp (function (t) boolean))
- (local-variable-if-set-p (function (symbol &optional buffer) boolean))
- (local-variable-p (function (symbol &optional buffer) boolean))
- (locale-info (function ((member codeset days months paper)) (or null string)))
- (log (function (number number) float))
- (log10 (function (number) float))
- (logand (function (&rest (or integer marker)) integer))
- (logb (function (number) integer))
- (logcount (function (integer) integer))
- (logior (function (&rest (or integer marker)) integer))
- (lognot (function (integer) integer))
- (logxor (function (&rest (or integer marker)) integer))
- ;; (lsh (function ((integer ,most-negative-fixnum *) integer) integer)) ?
- (lsh (function (integer integer) integer))
- (make-byte-code (function ((or fixnum list) string vector integer &optional string t &rest t) vector))
- (make-list (function (integer t) list))
- (make-marker (function () marker))
- (make-string (function (integer fixnum &optional t) string))
- (make-symbol (function (string) symbol))
- (mark (function (&optional t) (or integer null)))
- (mark-marker (function () marker))
- (marker-buffer (function (marker) (or buffer null)))
- (markerp (function (t) boolean))
- (max (function ((or number marker) &rest (or number marker)) number))
- (max-char (function (&optional t) fixnum))
- (member (function (t list) list))
- (memory-limit (function () integer))
- (memq (function (t list) list))
- (memql (function (t list) list))
- (min (function ((or number marker) &rest (or number marker)) number))
- (minibuffer-selected-window (function () (or window null)))
- (minibuffer-window (function (&optional frame) window))
- (mod (function ((or number marker) (or number marker)) (or (integer 0 *) (float 0 *))))
- (mouse-movement-p (function (t) boolean))
- (multibyte-char-to-unibyte (function (fixnum) fixnum))
- (natnump (function (t) boolean))
- (next-window (function (&optional window t t) window))
- (nlistp (function (t) boolean))
- (not (function (t) boolean))
- (nth (function (integer list) t))
- (nthcdr (function (integer t) t))
- (null (function (t) boolean))
- (number-or-marker-p (function (t) boolean))
- (number-to-string (function (number) string))
- (numberp (function (t) boolean))
- (one-window-p (function (&optional t t) boolean))
- (overlayp (function (t) boolean))
- (parse-colon-path (function (string) cons))
- (plist-get (function (list t &optional t) t))
- (plist-member (function (list t &optional t) list))
- (point (function () integer))
- (point-marker (function () marker))
- (point-max (function () integer))
- (point-min (function () integer))
- (preceding-char (function () fixnum))
- (previous-window (function (&optional window t t) window))
- (prin1-to-string (function (t &optional t t) string))
- (processp (function (t) boolean))
- (proper-list-p (function (t) boolean))
- (propertize (function (string &rest t) string))
- (radians-to-degrees (function (number) float))
- (rassoc (function (t list) list))
- (rassq (function (t list) list))
- (read-from-string (function (string &optional integer integer) cons))
- (recent-keys (function (&optional (or cons null)) vector))
- (recursion-depth (function () integer))
- (regexp-opt (function (list) string))
- (regexp-quote (function (string) string))
- (region-beginning (function () integer))
- (region-end (function () integer))
- (reverse (function (sequence) sequence))
- (round (function (number &optional number) integer))
- (safe-length (function (t) integer))
- (selected-frame (function () frame))
- (selected-window (function () window))
- (sequencep (function (t) boolean))
- (sin (function (number) float))
- (sqrt (function (number) float))
- (standard-case-table (function () char-table))
- (standard-syntax-table (function () char-table))
- (string (function (&rest fixnum) string))
- (string-as-multibyte (function (string) string))
- (string-as-unibyte (function (string) string))
- (string-equal (function ((or string symbol) (or string symbol)) boolean))
- (string-lessp (function ((or string symbol) (or string symbol)) boolean))
- (string-make-multibyte (function (string) string))
- (string-make-unibyte (function (string) string))
- (string-search (function (string string &optional integer) (or integer null)))
- (string-to-char (function (string) fixnum))
- (string-to-multibyte (function (string) string))
- (string-to-number (function (string &optional integer) number))
- (string-to-syntax (function (string) (or cons null)))
- (string< (function ((or string symbol) (or string symbol)) boolean))
- (string= (function ((or string symbol) (or string symbol)) boolean))
- (stringp (function (t) boolean))
- (subrp (function (t) boolean))
- (substring (function ((or string vector) &optional integer integer) (or string vector)))
- (sxhash (function (t) integer))
- (sxhash-eq (function (t) integer))
- (sxhash-eql (function (t) integer))
- (sxhash-equal (function (t) integer))
- (symbol-function (function (symbol) t))
- (symbol-name (function (symbol) string))
- (symbol-plist (function (symbol) list))
- (symbol-value (function (symbol) t))
- (symbolp (function (t) boolean))
- (syntax-table (function () char-table))
- (syntax-table-p (function (t) boolean))
- (tan (function (number) float))
- (this-command-keys (function () string))
- (this-command-keys-vector (function () vector))
- (this-single-command-keys (function () vector))
- (this-single-command-raw-keys (function () vector))
- (time-convert (function ((or number list) &optional (or symbol integer))
- (or cons number)))
- (truncate (function (number &optional number) integer))
- (type-of (function (t) symbol))
- (unibyte-char-to-multibyte (function (fixnum) fixnum)) ;; byte is fixnum
- (upcase (function ((or fixnum string)) (or fixnum string)))
- (user-full-name (function (&optional integer) (or string null)))
- (user-login-name (function (&optional integer) (or string null)))
- (user-original-login-name (function (&optional integer) (or string null)))
- (user-real-login-name (function () string))
- (user-real-uid (function () integer))
- (user-uid (function () integer))
- (vconcat (function (&rest sequence) vector))
- (vector (function (&rest t) vector))
- (vectorp (function (t) boolean))
- (visible-frame-list (function () list))
- (wholenump (function (t) boolean))
- (window-configuration-p (function (t) boolean))
- (window-live-p (function (t) boolean))
- (window-valid-p (function (t) boolean))
- (windowp (function (t) boolean))
- (zerop (function (number) boolean))
- ;; Type hints
- (comp-hint-fixnum (function (t) fixnum))
- (comp-hint-cons (function (t) cons))
- ;; Non returning functions
- (throw (function (t t) nil))
- (error (function (string &rest t) nil))
- (signal (function (symbol t) nil)))
- "Alist used for type propagation.")
-
(defconst comp-known-func-cstr-h
(cl-loop
with comp-ctxt = (make-comp-cstr-ctxt)
@@ -601,50 +189,72 @@ Useful to hook into pass checkers.")
finally return h)
"Hash table function -> `comp-constraint'.")
+;; Keep it in sync with the `cl-deftype-satisfies' property set in
+;; cl-macs.el. We can't use `cl-deftype-satisfies' directly as the
+;; relation type <-> predicate is not bijective (bug#45576).
(defconst comp-known-predicates
- '((arrayp . array)
- (atom . atom)
- (characterp . fixnum)
- (booleanp . boolean)
- (bool-vector-p . bool-vector)
- (bufferp . buffer)
- (natnump . (integer 0 *))
- (char-table-p . char-table)
- (hash-table-p . hash-table)
- (consp . cons)
- (integerp . integer)
- (floatp . float)
- (functionp . (or function symbol))
- (integerp . integer)
- (keywordp . keyword)
- (listp . list)
- (numberp . number)
- (null . null)
- (numberp . number)
- (sequencep . sequence)
- (stringp . string)
- (symbolp . symbol)
- (vectorp . vector)
- (integer-or-marker-p . integer-or-marker))
- "Alist predicate -> matched type specifier.")
+ ;; FIXME: Auto-generate (most of) it from `cl-deftype-satifies'?
+ '((arrayp array)
+ (atom atom)
+ (bool-vector-p bool-vector)
+ (booleanp boolean)
+ (bufferp buffer)
+ (char-table-p char-table)
+ (characterp fixnum t)
+ (consp cons)
+ (floatp float)
+ (framep frame)
+ (functionp (or function symbol cons) (not function))
+ (hash-table-p hash-table)
+ (integer-or-marker-p integer-or-marker)
+ (integerp integer)
+ (keywordp symbol t)
+ (listp list)
+ (markerp marker)
+ (natnump (integer 0 *))
+ (null null)
+ (number-or-marker-p number-or-marker)
+ (numberp number)
+ (obarrayp obarray)
+ (overlayp overlay)
+ (processp process)
+ (sequencep sequence)
+ (stringp string)
+ (subrp subr)
+ (symbol-with-pos-p symbol-with-pos)
+ (symbolp symbol)
+ (vectorp vector)
+ (windowp window))
+ "(PREDICATE TYPE-IF-SATISFIED ?TYPE-IF-NOT-SATISFIED).")
(defconst comp-known-predicates-h
(cl-loop
with comp-ctxt = (make-comp-cstr-ctxt)
with h = (make-hash-table :test #'eq)
- for (pred . type-spec) in comp-known-predicates
- for cstr = (comp-type-spec-to-cstr type-spec)
- do (puthash pred cstr h)
+ for (pred . type-specs) in comp-known-predicates
+ for pos-cstr = (comp-type-spec-to-cstr (car type-specs))
+ for neg-cstr = (if (length> type-specs 1)
+ (comp-type-spec-to-cstr (cl-second type-specs))
+ (comp-cstr-negation-make pos-cstr))
+ do (puthash pred (cons pos-cstr neg-cstr) h)
finally return h)
- "Hash table function -> `comp-constraint'.")
+ "Hash table FUNCTION -> (POS-CSTR . NEG-CSTR).")
-(defun comp-known-predicate-p (predicate)
+(defun comp--known-predicate-p (predicate)
"Return t if PREDICATE is known."
- (when (gethash predicate comp-known-predicates-h) t))
+ (when (or (gethash predicate comp-known-predicates-h)
+ (gethash predicate (comp-cstr-ctxt-pred-type-h comp-ctxt)))
+ t))
-(defun comp-pred-to-cstr (predicate)
- "Given PREDICATE, return the corresponding constraint."
- (gethash predicate comp-known-predicates-h))
+(defun comp--pred-to-pos-cstr (predicate)
+ "Given PREDICATE, return the corresponding positive constraint."
+ (or (car-safe (gethash predicate comp-known-predicates-h))
+ (gethash predicate (comp-cstr-ctxt-pred-type-h comp-ctxt))))
+
+(defun comp--pred-to-neg-cstr (predicate)
+ "Given PREDICATE, return the corresponding negative constraint."
+ (or (cdr-safe (gethash predicate comp-known-predicates-h))
+ (gethash predicate (comp-cstr-ctxt-pred-type-h comp-ctxt))))
(defconst comp-symbol-values-optimizable '(most-positive-fixnum
most-negative-fixnum)
@@ -654,33 +264,6 @@ Useful to hook into pass checkers.")
comp-hint-cons)
"List of fake functions used to give compiler hints.")
-(defconst comp-limple-sets '(set
- setimm
- set-par-to-local
- set-args-to-local
- set-rest-args-to-local)
- "Limple set operators.")
-
-(defconst comp-limple-assignments `(assume
- fetch-handler
- ,@comp-limple-sets)
- "Limple operators that clobber the first m-var argument.")
-
-(defconst comp-limple-calls '(call
- callref
- direct-call
- direct-callref)
- "Limple operators used to call subrs.")
-
-(defconst comp-limple-branches '(jump cond-jump)
- "Limple operators used for conditional and unconditional branches.")
-
-(defconst comp-limple-ops `(,@comp-limple-calls
- ,@comp-limple-assignments
- ,@comp-limple-branches
- return)
- "All Limple operators.")
-
(defvar comp-func nil
"Bound to the current function by most passes.")
@@ -698,30 +281,6 @@ Useful to hook into pass checkers.")
(defvar comp-no-spawn nil
"Non-nil don't spawn native compilation processes.")
-(defconst comp-warn-primitives
- '(null memq gethash and subrp not subr-native-elisp-p
- comp--install-trampoline concat if symbolp symbol-name make-string
- length aset aref length> mapcar expand-file-name
- file-name-as-directory file-exists-p native-elisp-load)
- "List of primitives we want to warn about in case of redefinition.
-This are essential for the trampoline machinery to work properly.")
-
-;; Moved early to avoid circularity when comp.el is loaded and
-;; `macroexpand' needs to be advised (bug#47049).
-;;;###autoload
-(defun comp-subr-trampoline-install (subr-name)
- "Make SUBR-NAME effectively advice-able when called from native code."
- (when (memq subr-name comp-warn-primitives)
- (warn "Redefining `%s' might break native compilation of trampolines."
- subr-name))
- (unless (or (null native-comp-enable-subr-trampolines)
- (memq subr-name native-comp-never-optimize-functions)
- (gethash subr-name comp-installed-trampolines-h))
- (cl-assert (subr-primitive-p (symbol-function subr-name)))
- (when-let ((trampoline (or (comp-trampoline-search subr-name)
- (comp-trampoline-compile subr-name))))
- (comp--install-trampoline subr-name trampoline))))
-
(cl-defstruct (comp-vec (:copier nil))
"A re-sizable vector like object."
@@ -850,7 +409,7 @@ This is typically for top-level forms other than defun.")
(closed nil :type boolean
:documentation "t if closed.")
;; All the following are for SSA and CGF analysis.
- ;; Keep in sync with `comp-clean-ssa'!!
+ ;; Keep in sync with `comp--clean-ssa'!!
(in-edges () :type list
:documentation "List of incoming edges.")
(out-edges () :type list
@@ -878,7 +437,7 @@ into it.")
:documentation "Start block LAP address.")
(non-ret-insn nil :type list
:documentation "Insn known to perform a non local exit.
-`comp-fwprop' may identify and store here basic blocks performing
+`comp--fwprop' may identify and store here basic blocks performing
non local exits and mark it rewrite it later.")
(no-ret nil :type boolean
:documentation "t when the block is known to perform a
@@ -892,7 +451,7 @@ non local exit (ends with an `unreachable' insn)."))
(:include comp-block))
"A basic block holding only constraints.")
-(cl-defstruct (comp-edge (:copier nil) (:constructor make--comp-edge))
+(cl-defstruct (comp-edge (:copier nil) (:constructor comp--edge-make0))
"An edge connecting two basic blocks."
(src nil :type (or null comp-block))
(dst nil :type (or null comp-block))
@@ -900,19 +459,19 @@ non local exit (ends with an `unreachable' insn)."))
:documentation "The index number corresponding to this edge in the
edge hash."))
-(defun make-comp-edge (&rest args)
+(defun comp--edge-make (&rest args)
"Create a `comp-edge' with basic blocks SRC and DST."
(let ((n (funcall (comp-func-edge-cnt-gen comp-func))))
(puthash
n
- (apply #'make--comp-edge :number n args)
+ (apply #'comp--edge-make0 :number n args)
(comp-func-edges-h comp-func))))
-(defun comp-block-preds (basic-block)
+(defun comp--block-preds (basic-block)
"Return the list of predecessors of BASIC-BLOCK."
(mapcar #'comp-edge-src (comp-block-in-edges basic-block)))
-(defun comp-gen-counter ()
+(defun comp--gen-counter ()
"Return a sequential number generator."
(let ((n -1))
(lambda ()
@@ -946,9 +505,9 @@ CFG is mutated by a pass.")
:documentation "LAP label -> LIMPLE basic block name.")
(edges-h (make-hash-table) :type hash-table
:documentation "Hash edge-num -> edge connecting basic two blocks.")
- (block-cnt-gen (funcall #'comp-gen-counter) :type function
+ (block-cnt-gen (funcall #'comp--gen-counter) :type function
:documentation "Generates block numbers.")
- (edge-cnt-gen (funcall #'comp-gen-counter) :type function
+ (edge-cnt-gen (funcall #'comp--gen-counter) :type function
:documentation "Generates edges numbers.")
(has-non-local nil :type boolean
:documentation "t if non local jumps are present.")
@@ -969,7 +528,7 @@ CFG is mutated by a pass.")
(lambda-list nil :type list
:documentation "Original lambda-list."))
-(cl-defstruct (comp-mvar (:constructor make--comp-mvar)
+(cl-defstruct (comp-mvar (:constructor make--comp-mvar0)
(:include comp-cstr))
"A meta-variable being a slot in the meta-stack."
(id nil :type (or null number)
@@ -978,6 +537,7 @@ CFG is mutated by a pass.")
:documentation "Slot number in the array if a number or
`scratch' for scratch slot."))
+;; In use by comp.c.
(defun comp-mvar-type-hint-match-p (mvar type-hint)
"Match MVAR against TYPE-HINT.
In use by the back-end."
@@ -987,49 +547,39 @@ In use by the back-end."
-(defun comp-ensure-native-compiler ()
- "Make sure Emacs has native compiler support and libgccjit can be loaded.
-Signal an error otherwise.
-To be used by all entry points."
- (cond
- ((null (featurep 'native-compile))
- (error "Emacs was not compiled with native compiler support (--with-native-compilation)"))
- ((null (native-comp-available-p))
- (error "Cannot find libgccjit library"))))
-
-(defun comp-equality-fun-p (function)
+(defun comp--equality-fun-p (function)
"Equality functions predicate for FUNCTION."
(when (memq function '(eq eql equal)) t))
-(defun comp-arithm-cmp-fun-p (function)
+(defun comp--arithm-cmp-fun-p (function)
"Predicate for arithmetic comparison functions."
(when (memq function '(= > < >= <=)) t))
-(defun comp-set-op-p (op)
+(defun comp--set-op-p (op)
"Assignment predicate for OP."
(when (memq op comp-limple-sets) t))
-(defun comp-assign-op-p (op)
+(defun comp--assign-op-p (op)
"Assignment predicate for OP."
(when (memq op comp-limple-assignments) t))
-(defun comp-call-op-p (op)
+(defun comp--call-op-p (op)
"Call predicate for OP."
(when (memq op comp-limple-calls) t))
-(defun comp-branch-op-p (op)
+(defun comp--branch-op-p (op)
"Branch predicate for OP."
(when (memq op comp-limple-branches) t))
-(defsubst comp-limple-insn-call-p (insn)
+(defsubst comp--limple-insn-call-p (insn)
"Limple INSN call predicate."
- (comp-call-op-p (car-safe insn)))
+ (comp--call-op-p (car-safe insn)))
-(defun comp-type-hint-p (func)
+(defun comp--type-hint-p (func)
"Type-hint predicate for function name FUNC."
(when (memq func comp-type-hints) t))
-(defun comp-func-unique-in-cu-p (func)
+(defun comp--func-unique-in-cu-p (func)
"Return t if FUNC is known to be unique in the current compilation unit."
(if (symbolp func)
(cl-loop with h = (make-hash-table :test #'eq)
@@ -1041,110 +591,45 @@ To be used by all entry points."
finally return t)
t))
-(defsubst comp-symbol-func-to-fun (symbol-funcion)
- "Given a function called SYMBOL-FUNCION return its `comp-func'."
- (gethash (gethash symbol-funcion (comp-ctxt-sym-to-c-name-h
- comp-ctxt))
+(defsubst comp--symbol-func-to-fun (symbol-func)
+ "Given a function called SYMBOL-FUNC return its `comp-func'."
+ (gethash (gethash symbol-func (comp-ctxt-sym-to-c-name-h comp-ctxt))
(comp-ctxt-funcs-h comp-ctxt)))
-(defun comp-function-pure-p (f)
+(defun comp--function-pure-p (f)
"Return t if F is pure."
(or (get f 'pure)
- (when-let ((func (comp-symbol-func-to-fun f)))
+ (when-let ((func (comp--symbol-func-to-fun f)))
(comp-func-pure func))))
-(defun comp-alloc-class-to-container (alloc-class)
+(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."
(cl-struct-slot-value 'comp-ctxt (or alloc-class 'd-default) comp-ctxt))
-(defsubst comp-add-const-to-relocs (obj)
+(defsubst comp--add-const-to-relocs (obj)
"Keep track of OBJ into the ctxt relocations."
- (puthash obj t (comp-data-container-idx (comp-alloc-class-to-container
+ (puthash obj t (comp-data-container-idx (comp--alloc-class-to-container
comp-curr-allocation-class))))
;;; Log routines.
-(defconst comp-limple-lock-keywords
- `((,(rx bol "(comment" (1+ not-newline)) . font-lock-comment-face)
- (,(rx "#(" (group-n 1 "mvar"))
- (1 font-lock-function-name-face))
- (,(rx bol "(" (group-n 1 "phi"))
- (1 font-lock-variable-name-face))
- (,(rx bol "(" (group-n 1 (or "return" "unreachable")))
- (1 font-lock-warning-face))
- (,(rx (group-n 1 (or "entry"
- (seq (or "entry_" "entry_fallback_" "bb_")
- (1+ num) (? (or "_latch"
- (seq "_cstrs_" (1+ num))))))))
- (1 font-lock-constant-face))
- (,(rx-to-string
- `(seq "(" (group-n 1 (or ,@(mapcar #'symbol-name comp-limple-ops)))))
- (1 font-lock-keyword-face)))
- "Highlights used by `native-comp-limple-mode'.")
-
-(define-derived-mode native-comp-limple-mode fundamental-mode "LIMPLE"
- "Syntax-highlight LIMPLE IR."
- (setf font-lock-defaults '(comp-limple-lock-keywords)))
-
-(cl-defun comp-log (data &optional (level 1) quoted)
- "Log DATA at LEVEL.
-LEVEL is a number from 1-3, and defaults to 1; if it is less
-than `native-comp-verbose', do nothing. If `noninteractive', log
-with `message'. Otherwise, log with `comp-log-to-buffer'."
- (when (>= native-comp-verbose level)
- (if noninteractive
- (cl-typecase data
- (atom (message "%s" data))
- (t (dolist (elem data)
- (message "%s" elem))))
- (comp-log-to-buffer data quoted))))
-
-(cl-defun comp-log-to-buffer (data &optional quoted)
- "Log DATA to `comp-log-buffer-name'."
- (let* ((print-f (if quoted #'prin1 #'princ))
- (log-buffer
- (or (get-buffer comp-log-buffer-name)
- (with-current-buffer (get-buffer-create comp-log-buffer-name)
- (setf buffer-read-only t)
- (current-buffer))))
- (log-window (get-buffer-window log-buffer))
- (inhibit-read-only t)
- at-end-p)
- (with-current-buffer log-buffer
- (unless (eq major-mode 'native-comp-limple-mode)
- (native-comp-limple-mode))
- (when (= (point) (point-max))
- (setf at-end-p t))
- (save-excursion
- (goto-char (point-max))
- (cl-typecase data
- (atom (funcall print-f data log-buffer))
- (t (dolist (elem data)
- (funcall print-f elem log-buffer)
- (insert "\n"))))
- (insert "\n"))
- (when (and at-end-p log-window)
- ;; When log window's point is at the end, follow the tail.
- (with-selected-window log-window
- (goto-char (point-max)))))))
-
-(defun comp-prettyformat-mvar (mvar)
+(defun comp--prettyformat-mvar (mvar)
(format "#(mvar %s %s %S)"
(comp-mvar-id mvar)
(comp-mvar-slot mvar)
(comp-cstr-to-type-spec mvar)))
-(defun comp-prettyformat-insn (insn)
+(defun comp--prettyformat-insn (insn)
(cond
((comp-mvar-p insn)
- (comp-prettyformat-mvar insn))
+ (comp--prettyformat-mvar insn))
((proper-list-p insn)
- (concat "(" (mapconcat #'comp-prettyformat-insn insn " ") ")"))
+ (concat "(" (mapconcat #'comp--prettyformat-insn insn " ") ")"))
(t (prin1-to-string insn))))
-(defun comp-log-func (func verbosity)
+(defun comp--log-func (func verbosity)
"Log function FUNC at VERBOSITY.
VERBOSITY is a number between 0 and 3."
(when (>= native-comp-verbose verbosity)
@@ -1155,9 +640,9 @@ VERBOSITY is a number between 0 and 3."
do (comp-log (concat "<" (symbol-name block-name) ">") verbosity)
(cl-loop
for insn in (comp-block-insns bb)
- do (comp-log (comp-prettyformat-insn insn) verbosity)))))
+ do (comp-log (comp--prettyformat-insn insn) verbosity)))))
-(defun comp-log-edges (func)
+(defun comp--log-edges (func)
"Log edges in FUNC."
(let ((edges (comp-func-edges-h func)))
(comp-log (format "\nEdges in function: %s\n"
@@ -1173,7 +658,7 @@ VERBOSITY is a number between 0 and 3."
-(defmacro comp-loop-insn-in-block (basic-block &rest body)
+(defmacro comp--loop-insn-in-block (basic-block &rest body)
"Loop over all insns in BASIC-BLOCK executing BODY.
Inside BODY, `insn' and `insn-cell'can be used to read or set the
current instruction or its cell."
@@ -1187,19 +672,19 @@ current instruction or its cell."
;;; spill-lap pass specific code.
-(defun comp-lex-byte-func-p (f)
+(defun comp--lex-byte-func-p (f)
"Return t if F is a lexically-scoped byte compiled function."
(and (byte-code-function-p f)
(fixnump (aref f 0))))
-(defun comp-spill-decl-spec (function-name spec)
+(defun comp--spill-decl-spec (function-name spec)
"Return the declared specifier SPEC for FUNCTION-NAME."
(plist-get (cdr (assq function-name byte-to-native-plist-environment))
spec))
-(defun comp-spill-speed (function-name)
+(defun comp--spill-speed (function-name)
"Return the speed for FUNCTION-NAME."
- (or (comp-spill-decl-spec function-name 'speed)
+ (or (comp--spill-decl-spec function-name 'speed)
(comp-ctxt-speed comp-ctxt)))
;; Autoloaded as might be used by `disassemble-internal'.
@@ -1238,10 +723,10 @@ clashes."
;; pick the first one.
(concat prefix crypted "_" human-readable "_0"))))
-(defun comp-decrypt-arg-list (x function-name)
+(defun comp--decrypt-arg-list (x function-name)
"Decrypt argument list X for FUNCTION-NAME."
(unless (fixnump x)
- (signal 'native-compiler-error-dyn-func function-name))
+ (signal 'native-compiler-error-dyn-func (list function-name)))
(let ((rest (not (= (logand x 128) 0)))
(mandatory (logand x 127))
(nonrest (ash x -8)))
@@ -1253,98 +738,55 @@ clashes."
:nonrest nonrest
:rest rest))))
-(defsubst comp-byte-frame-size (byte-compiled-func)
+(defsubst comp--byte-frame-size (byte-compiled-func)
"Return the frame size to be allocated for BYTE-COMPILED-FUNC."
(aref byte-compiled-func 3))
-(defun comp-add-func-to-ctxt (func)
+(defun comp--add-func-to-ctxt (func)
"Add FUNC to the current compiler context."
(let ((name (comp-func-name func))
(c-name (comp-func-c-name func)))
(puthash name c-name (comp-ctxt-sym-to-c-name-h comp-ctxt))
(puthash c-name func (comp-ctxt-funcs-h comp-ctxt))))
-(cl-defgeneric comp-spill-lap-function (input)
+(cl-defgeneric comp--spill-lap-function (input)
"Byte-compile INPUT and spill lap for further stages.")
-(cl-defmethod comp-spill-lap-function ((function-name symbol))
+(cl-defmethod comp--spill-lap-function ((function-name symbol))
"Byte-compile FUNCTION-NAME, spilling data from the byte compiler."
(unless (comp-ctxt-output comp-ctxt)
(setf (comp-ctxt-output comp-ctxt)
(make-temp-file (comp-c-func-name function-name "freefn-")
nil ".eln")))
(let* ((f (symbol-function function-name))
- (c-name (comp-c-func-name function-name "F"))
- (func (make-comp-func-l :name function-name
- :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))))
+ (byte-code (byte-compile function-name))
+ (c-name (comp-c-func-name function-name "F")))
(when (byte-code-function-p f)
(signal 'native-compiler-error
- "can't native compile an already byte-compiled function"))
- (setf (comp-func-byte-func func)
- (byte-compile (comp-func-name func)))
- (let ((lap (byte-to-native-lambda-lap
- (gethash (aref (comp-func-byte-func func) 1)
- byte-to-native-lambdas-h))))
- (cl-assert lap)
- (comp-log lap 2 t)
- (let ((arg-list (aref (comp-func-byte-func func) 0)))
- (setf (comp-func-l-args func)
- (comp-decrypt-arg-list arg-list function-name)
- (comp-func-lap func)
- lap
- (comp-func-frame-size func)
- (comp-byte-frame-size (comp-func-byte-func func))))
+ '("can't native compile an already byte-compiled function")))
(setf (comp-ctxt-top-level-forms comp-ctxt)
(list (make-byte-to-native-func-def :name function-name
- :c-name c-name)))
- (comp-add-func-to-ctxt func))))
+ :c-name c-name
+ :byte-func byte-code)))
+ (maphash #'comp--intern-func-in-ctxt byte-to-native-lambdas-h)))
-(cl-defmethod comp-spill-lap-function ((form list))
+(cl-defmethod comp--spill-lap-function ((form list))
"Byte-compile FORM, spilling data from the byte compiler."
- (unless (eq (car-safe form) 'lambda)
+ (unless (memq (car-safe form) '(lambda closure))
(signal 'native-compiler-error
- "Cannot native-compile, form is not a lambda"))
+ '("Cannot native-compile, form is not a lambda or closure")))
(unless (comp-ctxt-output comp-ctxt)
(setf (comp-ctxt-output comp-ctxt)
(make-temp-file "comp-lambda-" nil ".eln")))
(let* ((byte-code (byte-compile form))
- (c-name (comp-c-func-name "anonymous-lambda" "F"))
- (func (if (comp-lex-byte-func-p byte-code)
- (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)
- byte-to-native-lambdas-h))))
- (cl-assert lap)
- (comp-log lap 2 t)
- (if (comp-func-l-p func)
- (setf (comp-func-l-args func)
- (comp-decrypt-arg-list (aref byte-code 0) byte-code))
- (setf (comp-func-d-lambda-list func) (cadr form)))
- (setf (comp-func-lap func) lap
- (comp-func-frame-size func) (comp-byte-frame-size
- byte-code))
- (setf (comp-func-byte-func func) byte-code
- (comp-ctxt-top-level-forms comp-ctxt)
+ (c-name (comp-c-func-name "anonymous-lambda" "F")))
+ (setf (comp-ctxt-top-level-forms comp-ctxt)
(list (make-byte-to-native-func-def :name '--anonymous-lambda
- :c-name c-name)))
- (comp-add-func-to-ctxt func))))
+ :c-name c-name
+ :byte-func byte-code)))
+ (maphash #'comp--intern-func-in-ctxt byte-to-native-lambdas-h)))
-(defun comp-intern-func-in-ctxt (_ obj)
+(defun comp--intern-func-in-ctxt (_ obj)
"Given OBJ of type `byte-to-native-lambda', create a function in `comp-ctxt'."
(when-let ((byte-func (byte-to-native-lambda-byte-func obj)))
(let* ((lap (byte-to-native-lambda-lap obj))
@@ -1357,9 +799,9 @@ clashes."
(name (when top-l-form
(byte-to-native-func-def-name top-l-form)))
(c-name (comp-c-func-name (or name "anonymous-lambda") "F"))
- (func (if (comp-lex-byte-func-p byte-func)
+ (func (if (comp--lex-byte-func-p byte-func)
(make-comp-func-l
- :args (comp-decrypt-arg-list (aref byte-func 0)
+ :args (comp--decrypt-arg-list (aref byte-func 0)
name))
(make-comp-func-d :lambda-list (aref byte-func 0)))))
(setf (comp-func-name func) name
@@ -1369,9 +811,9 @@ clashes."
(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)
- (comp-func-speed func) (comp-spill-speed name)
- (comp-func-pure func) (comp-spill-decl-spec name 'pure))
+ (comp-func-frame-size func) (comp--byte-frame-size byte-func)
+ (comp-func-speed func) (comp--spill-speed name)
+ (comp-func-pure func) (comp--spill-decl-spec name 'pure))
;; Store the c-name to have it retrievable from
;; `comp-ctxt-top-level-forms'.
@@ -1379,18 +821,18 @@ clashes."
(setf (byte-to-native-func-def-c-name top-l-form) c-name))
(unless name
(puthash byte-func func (comp-ctxt-byte-func-to-func-h comp-ctxt)))
- (comp-add-func-to-ctxt func)
+ (comp--add-func-to-ctxt func)
(comp-log (format "Function %s:\n" name) 1)
(comp-log lap 1 t))))
-(cl-defmethod comp-spill-lap-function ((filename string))
+(cl-defmethod comp--spill-lap-function ((filename string))
"Byte-compile FILENAME, spilling data from the byte compiler."
(byte-compile-file filename)
(when (or (null byte-native-qualities)
(alist-get 'no-native-compile byte-native-qualities))
(throw 'no-native-compile nil))
(unless byte-to-native-top-level-forms
- (signal 'native-compiler-error-empty-byte filename))
+ (signal 'native-compiler-error-empty-byte (list filename)))
(unless (comp-ctxt-output comp-ctxt)
(setf (comp-ctxt-output comp-ctxt)
(comp-el-to-eln-filename filename native-compile-target-directory)))
@@ -1408,7 +850,7 @@ clashes."
collect
(if (and (byte-to-native-func-def-p form)
(eq -1
- (comp-spill-speed (byte-to-native-func-def-name form))))
+ (comp--spill-speed (byte-to-native-func-def-name form))))
(let ((byte-code (byte-to-native-func-def-byte-func form)))
(remhash byte-code byte-to-native-lambdas-h)
(make-byte-to-native-top-level
@@ -1416,19 +858,21 @@ clashes."
',(byte-to-native-func-def-name form)
,byte-code
nil)
- :lexical (comp-lex-byte-func-p byte-code)))
+ :lexical (comp--lex-byte-func-p byte-code)))
form)))
- (maphash #'comp-intern-func-in-ctxt byte-to-native-lambdas-h))
+ (maphash #'comp--intern-func-in-ctxt byte-to-native-lambdas-h))
-(defun comp-spill-lap (input)
+(defun comp--spill-lap (input)
"Byte-compile and spill the LAP representation for INPUT.
If INPUT is a symbol, it is the function-name to be compiled.
If INPUT is a string, it is the filename to be compiled."
- (let ((byte-native-compiling t)
- (byte-to-native-lambdas-h (make-hash-table :test #'eq))
- (byte-to-native-top-level-forms ())
- (byte-to-native-plist-environment ()))
- (comp-spill-lap-function input)))
+ (let* ((byte-native-compiling t)
+ (byte-to-native-lambdas-h (make-hash-table :test #'eq))
+ (byte-to-native-top-level-forms ())
+ (byte-to-native-plist-environment ())
+ (res (comp--spill-lap-function input)))
+ (comp-cstr-ctxt-update-type-slots comp-ctxt)
+ res))
;;; Limplification pass specific code.
@@ -1455,55 +899,55 @@ Points to the next slot to be filled.")
byte-switch byte-pushconditioncase)
"LAP end of basic blocks op codes.")
-(defun comp-lap-eob-p (inst)
+(defun comp--lap-eob-p (inst)
"Return t if INST closes the current basic blocks, nil otherwise."
(when (memq (car inst) comp-lap-eob-ops)
t))
-(defun comp-lap-fall-through-p (inst)
+(defun comp--lap-fall-through-p (inst)
"Return t if INST falls through, nil otherwise."
(when (not (memq (car inst) '(byte-goto byte-return)))
t))
-(defsubst comp-sp ()
+(defsubst comp--sp ()
"Current stack pointer."
(declare (gv-setter (lambda (val)
`(setf (comp-limplify-sp comp-pass) ,val))))
(comp-limplify-sp comp-pass))
-(defmacro comp-with-sp (sp &rest body)
+(defmacro comp--with-sp (sp &rest body)
"Execute BODY setting the stack pointer to SP.
Restore the original value afterwards."
(declare (debug (form body))
(indent defun))
(let ((sym (gensym)))
- `(let ((,sym (comp-sp)))
- (setf (comp-sp) ,sp)
+ `(let ((,sym (comp--sp)))
+ (setf (comp--sp) ,sp)
(progn ,@body)
- (setf (comp-sp) ,sym))))
+ (setf (comp--sp) ,sym))))
-(defsubst comp-slot-n (n)
+(defsubst comp--slot-n (n)
"Slot N into the meta-stack."
(comp-vec-aref (comp-limplify-frame comp-pass) n))
-(defsubst comp-slot ()
+(defsubst comp--slot ()
"Current slot into the meta-stack pointed by sp."
- (comp-slot-n (comp-sp)))
+ (comp--slot-n (comp--sp)))
-(defsubst comp-slot+1 ()
+(defsubst comp--slot+1 ()
"Slot into the meta-stack pointed by sp + 1."
- (comp-slot-n (1+ (comp-sp))))
+ (comp--slot-n (1+ (comp--sp))))
-(defsubst comp-label-to-addr (label)
+(defsubst comp--label-to-addr (label)
"Find the address of LABEL."
(or (gethash label (comp-limplify-label-to-addr comp-pass))
(signal 'native-ice (list "label not found" label))))
-(defsubst comp-mark-curr-bb-closed ()
+(defsubst comp--mark-curr-bb-closed ()
"Mark the current basic block as closed."
(setf (comp-block-closed (comp-limplify-curr-block comp-pass)) t))
-(defun comp-bb-maybe-add (lap-addr &optional sp)
+(defun comp--bb-maybe-add (lap-addr &optional sp)
"If necessary create a pending basic block for LAP-ADDR with stack depth SP.
The basic block is returned regardless it was already declared or not."
(let ((bb (or (cl-loop ; See if the block was already limplified.
@@ -1521,74 +965,76 @@ The basic block is returned regardless it was already declared or not."
(signal 'native-ice (list "incoherent stack pointers"
sp (comp-block-lap-sp bb))))
bb)
- (car (push (make--comp-block-lap lap-addr sp (comp-new-block-sym))
+ (car (push (make--comp-block-lap lap-addr sp (comp--new-block-sym))
(comp-limplify-pending-blocks comp-pass))))))
-(defsubst comp-call (func &rest args)
+(defsubst comp--call (func &rest args)
"Emit a call for function FUNC with ARGS."
`(call ,func ,@args))
-(defun comp-callref (func nargs stack-off)
+(defun comp--callref (func nargs stack-off)
"Emit a call using narg abi for FUNC.
NARGS is the number of arguments.
STACK-OFF is the index of the first slot frame involved."
`(callref ,func ,@(cl-loop repeat nargs
for sp from stack-off
- collect (comp-slot-n sp))))
+ collect (comp--slot-n sp))))
-(cl-defun make-comp-mvar (&key slot (constant nil const-vld) type)
+(cl-defun make--comp-mvar (&key slot (constant nil const-vld) type neg)
"`comp-mvar' initializer."
- (let ((mvar (make--comp-mvar :slot slot)))
+ (let ((mvar (make--comp-mvar0 :slot slot)))
(when const-vld
- (comp-add-const-to-relocs constant)
+ (comp--add-const-to-relocs constant)
(setf (comp-cstr-imm mvar) constant))
(when type
(setf (comp-mvar-typeset mvar) (list type)))
+ (when neg
+ (setf (comp-mvar-neg mvar) t))
mvar))
-(defun comp-new-frame (size vsize &optional ssa)
+(defun comp--new-frame (size vsize &optional ssa)
"Return a clean frame of meta variables of size SIZE and VSIZE.
If SSA is non-nil, populate it with m-var in ssa form."
(cl-loop with v = (make-comp-vec :beg (- vsize) :end size)
for i from (- vsize) below size
for mvar = (if ssa
- (make-comp-ssa-mvar :slot i)
- (make-comp-mvar :slot i))
+ (make--comp--ssa-mvar :slot i)
+ (make--comp-mvar :slot i))
do (setf (comp-vec-aref v i) mvar)
finally return v))
-(defun comp-emit (insn)
+(defun comp--emit (insn)
"Emit INSN into basic block BB."
(let ((bb (comp-limplify-curr-block comp-pass)))
(cl-assert (not (comp-block-closed bb)))
(push insn (comp-block-insns bb))))
-(defun comp-emit-set-call (call)
+(defun comp--emit-set-call (call)
"Emit CALL assigning the result to the current slot frame.
If the callee function is known to have a return type, propagate it."
(cl-assert call)
- (comp-emit (list 'set (comp-slot) call)))
+ (comp--emit (list 'set (comp--slot) call)))
-(defun comp-copy-slot (src-n &optional dst-n)
+(defun comp--copy-slot (src-n &optional dst-n)
"Set slot number DST-N to slot number SRC-N as source.
If DST-N is specified, use it; otherwise assume it to be the current slot."
- (comp-with-sp (or dst-n (comp-sp))
- (let ((src-slot (comp-slot-n src-n)))
+ (comp--with-sp (or dst-n (comp--sp))
+ (let ((src-slot (comp--slot-n src-n)))
(cl-assert src-slot)
- (comp-emit `(set ,(comp-slot) ,src-slot)))))
+ (comp--emit `(set ,(comp--slot) ,src-slot)))))
-(defsubst comp-emit-annotation (str)
+(defsubst comp--emit-annotation (str)
"Emit annotation STR."
- (comp-emit `(comment ,str)))
+ (comp--emit `(comment ,str)))
-(defsubst comp-emit-setimm (val)
+(defsubst comp--emit-setimm (val)
"Set constant VAL to current slot."
- (comp-add-const-to-relocs val)
+ (comp--add-const-to-relocs val)
;; Leave relocation index nil on purpose, will be fixed-up in final
;; by `comp-finalize-relocs'.
- (comp-emit `(setimm ,(comp-slot) ,val)))
+ (comp--emit `(setimm ,(comp--slot) ,val)))
-(defun comp-make-curr-block (block-name entry-sp &optional addr)
+(defun comp--make-curr-block (block-name entry-sp &optional addr)
"Create a basic block with BLOCK-NAME and set it as current block.
ENTRY-SP is the sp value when entering.
Add block to the current function and return it."
@@ -1600,104 +1046,104 @@ Add block to the current function and return it."
(puthash (comp-block-name bb) bb (comp-func-blocks comp-func))
bb))
-(defun comp-latch-make-fill (target)
+(defun comp--latch-make-fill (target)
"Create a latch pointing to TARGET and fill it.
Return the created latch."
- (let ((latch (make-comp-latch :name (comp-new-block-sym "latch")))
+ (let ((latch (make-comp-latch :name (comp--new-block-sym "latch")))
(curr-bb (comp-limplify-curr-block comp-pass)))
- ;; See `comp-make-curr-block'.
+ ;; See `comp--make-curr-block'.
(setf (comp-limplify-curr-block comp-pass) latch)
(when (< (comp-func-speed comp-func) 3)
;; At speed 3 the programmer is responsible to manually
;; place `comp-maybe-gc-or-quit'.
- (comp-emit '(call comp-maybe-gc-or-quit)))
- ;; See `comp-emit-uncond-jump'.
- (comp-emit `(jump ,(comp-block-name target)))
- (comp-mark-curr-bb-closed)
+ (comp--emit '(call comp-maybe-gc-or-quit)))
+ ;; See `comp--emit-uncond-jump'.
+ (comp--emit `(jump ,(comp-block-name target)))
+ (comp--mark-curr-bb-closed)
(puthash (comp-block-name latch) latch (comp-func-blocks comp-func))
(setf (comp-limplify-curr-block comp-pass) curr-bb)
latch))
-(defun comp-emit-uncond-jump (lap-label)
+(defun comp--emit-uncond-jump (lap-label)
"Emit an unconditional branch to LAP-LABEL."
(cl-destructuring-bind (label-num . stack-depth) lap-label
(when stack-depth
- (cl-assert (= (1- stack-depth) (comp-sp))))
- (let* ((target-addr (comp-label-to-addr label-num))
- (target (comp-bb-maybe-add target-addr
- (comp-sp)))
+ (cl-assert (= (1- stack-depth) (comp--sp))))
+ (let* ((target-addr (comp--label-to-addr label-num))
+ (target (comp--bb-maybe-add target-addr
+ (comp--sp)))
(latch (when (< target-addr (comp-limplify-pc comp-pass))
- (comp-latch-make-fill target)))
+ (comp--latch-make-fill target)))
(eff-target-name (comp-block-name (or latch target))))
- (comp-emit `(jump ,eff-target-name))
- (comp-mark-curr-bb-closed))))
+ (comp--emit `(jump ,eff-target-name))
+ (comp--mark-curr-bb-closed))))
-(defun comp-emit-cond-jump (a b target-offset lap-label negated)
+(defun comp--emit-cond-jump (a b target-offset lap-label negated)
"Emit a conditional jump to LAP-LABEL when A and B satisfy EQ.
TARGET-OFFSET is the positive offset on the SP when branching to the target
block.
If NEGATED is non null, negate the tested condition.
Return value is the fall-through block name."
(cl-destructuring-bind (label-num . label-sp) lap-label
- (let* ((bb (comp-block-name (comp-bb-maybe-add
+ (let* ((bb (comp-block-name (comp--bb-maybe-add
(1+ (comp-limplify-pc comp-pass))
- (comp-sp)))) ; Fall through block.
- (target-sp (+ target-offset (comp-sp)))
- (target-addr (comp-label-to-addr label-num))
- (target (comp-bb-maybe-add target-addr target-sp))
+ (comp--sp)))) ; Fall through block.
+ (target-sp (+ target-offset (comp--sp)))
+ (target-addr (comp--label-to-addr label-num))
+ (target (comp--bb-maybe-add target-addr target-sp))
(latch (when (< target-addr (comp-limplify-pc comp-pass))
- (comp-latch-make-fill target)))
+ (comp--latch-make-fill target)))
(eff-target-name (comp-block-name (or latch target))))
(when label-sp
- (cl-assert (= (1- label-sp) (+ target-offset (comp-sp)))))
- (comp-emit (if negated
+ (cl-assert (= (1- label-sp) (+ target-offset (comp--sp)))))
+ (comp--emit (if negated
(list 'cond-jump a b bb eff-target-name)
(list 'cond-jump a b eff-target-name bb)))
- (comp-mark-curr-bb-closed)
+ (comp--mark-curr-bb-closed)
bb)))
-(defun comp-emit-handler (lap-label handler-type)
+(defun comp--emit-handler (lap-label handler-type)
"Emit a nonlocal-exit handler to LAP-LABEL of type HANDLER-TYPE."
(cl-destructuring-bind (label-num . label-sp) lap-label
- (cl-assert (= (- label-sp 2) (comp-sp)))
+ (cl-assert (= (- label-sp 2) (comp--sp)))
(setf (comp-func-has-non-local comp-func) t)
- (let* ((guarded-bb (comp-bb-maybe-add (1+ (comp-limplify-pc comp-pass))
- (comp-sp)))
- (handler-bb (comp-bb-maybe-add (comp-label-to-addr label-num)
- (1+ (comp-sp))))
- (pop-bb (make--comp-block-lap nil (comp-sp) (comp-new-block-sym))))
- (comp-emit (list 'push-handler
+ (let* ((guarded-bb (comp--bb-maybe-add (1+ (comp-limplify-pc comp-pass))
+ (comp--sp)))
+ (handler-bb (comp--bb-maybe-add (comp--label-to-addr label-num)
+ (1+ (comp--sp))))
+ (pop-bb (make--comp-block-lap nil (comp--sp) (comp--new-block-sym))))
+ (comp--emit (list 'push-handler
handler-type
- (comp-slot+1)
+ (comp--slot+1)
(comp-block-name pop-bb)
(comp-block-name guarded-bb)))
- (comp-mark-curr-bb-closed)
+ (comp--mark-curr-bb-closed)
;; Emit the basic block to pop the handler if we got the non local.
(puthash (comp-block-name pop-bb) pop-bb (comp-func-blocks comp-func))
(setf (comp-limplify-curr-block comp-pass) pop-bb)
- (comp-emit `(fetch-handler ,(comp-slot+1)))
- (comp-emit `(jump ,(comp-block-name handler-bb)))
- (comp-mark-curr-bb-closed))))
+ (comp--emit `(fetch-handler ,(comp--slot+1)))
+ (comp--emit `(jump ,(comp-block-name handler-bb)))
+ (comp--mark-curr-bb-closed))))
-(defun comp-limplify-listn (n)
+(defun comp--limplify-listn (n)
"Limplify list N."
- (comp-with-sp (+ (comp-sp) n -1)
- (comp-emit-set-call (comp-call 'cons
- (comp-slot)
- (make-comp-mvar :constant nil))))
- (cl-loop for sp from (+ (comp-sp) n -2) downto (comp-sp)
- do (comp-with-sp sp
- (comp-emit-set-call (comp-call 'cons
- (comp-slot)
- (comp-slot+1))))))
-
-(defun comp-new-block-sym (&optional postfix)
+ (comp--with-sp (+ (comp--sp) n -1)
+ (comp--emit-set-call (comp--call 'cons
+ (comp--slot)
+ (make--comp-mvar :constant nil))))
+ (cl-loop for sp from (+ (comp--sp) n -2) downto (comp--sp)
+ do (comp--with-sp sp
+ (comp--emit-set-call (comp--call 'cons
+ (comp--slot)
+ (comp--slot+1))))))
+
+(defun comp--new-block-sym (&optional postfix)
"Return a unique symbol postfixing POSTFIX naming the next new basic block."
(intern (format (if postfix "bb_%s_%s" "bb_%s")
(funcall (comp-func-block-cnt-gen comp-func))
postfix)))
-(defun comp-fill-label-h ()
+(defun comp--fill-label-h ()
"Fill label-to-addr hash table for the current function."
(setf (comp-limplify-label-to-addr comp-pass) (make-hash-table :test 'eql))
(cl-loop for insn in (comp-func-lap comp-func)
@@ -1706,24 +1152,25 @@ Return value is the fall-through block name."
(`(TAG ,label . ,_)
(puthash label addr (comp-limplify-label-to-addr comp-pass))))))
-(defun comp-jump-table-optimizable (jmp-table)
+(defun comp--jump-table-optimizable (jmp-table)
"Return t if JMP-TABLE can be optimized out."
- (cl-loop
- with labels = (cl-loop for target-label being each hash-value of jmp-table
- collect target-label)
- with x = (car labels)
- for l in (cdr-safe labels)
- unless (= l x)
- return nil
- finally return t))
-
-(defun comp-emit-switch (var last-insn)
+ ;; Identify LAP sequences like:
+ ;; (byte-constant #s(hash-table test eq purecopy t data (created 126 deleted 126 changed 126)) . 24)
+ ;; (byte-switch)
+ ;; (TAG 126 . 10)
+ (let ((targets (hash-table-values jmp-table)))
+ (when (apply #'= targets)
+ (pcase (nth (1+ (comp-limplify-pc comp-pass)) (comp-func-lap comp-func))
+ (`(TAG ,target . ,_label-sp)
+ (= target (car targets)))))))
+
+(defun comp--emit-switch (var last-insn)
"Emit a Limple for a lap jump table given VAR and LAST-INSN."
;; FIXME this not efficient for big jump tables. We should have a second
;; strategy for this case.
(pcase last-insn
(`(setimm ,_ ,jmp-table)
- (unless (comp-jump-table-optimizable jmp-table)
+ (unless (comp--jump-table-optimizable jmp-table)
(cl-loop
for test being each hash-keys of jmp-table
using (hash-value target-label)
@@ -1731,34 +1178,34 @@ Return value is the fall-through block name."
with test-func = (hash-table-test jmp-table)
for n from 1
for last = (= n len)
- for m-test = (make-comp-mvar :constant test)
- for target-name = (comp-block-name (comp-bb-maybe-add
- (comp-label-to-addr target-label)
- (comp-sp)))
+ for m-test = (make--comp-mvar :constant test)
+ for target-name = (comp-block-name (comp--bb-maybe-add
+ (comp--label-to-addr target-label)
+ (comp--sp)))
for ff-bb = (if last
- (comp-bb-maybe-add (1+ (comp-limplify-pc comp-pass))
- (comp-sp))
+ (comp--bb-maybe-add (1+ (comp-limplify-pc comp-pass))
+ (comp--sp))
(make--comp-block-lap nil
- (comp-sp)
- (comp-new-block-sym)))
+ (comp--sp)
+ (comp--new-block-sym)))
for ff-bb-name = (comp-block-name ff-bb)
if (eq test-func 'eq)
- do (comp-emit (list 'cond-jump var m-test target-name ff-bb-name))
+ do (comp--emit (list 'cond-jump var m-test target-name ff-bb-name))
else
;; Store the result of the comparison into the scratch slot before
;; emitting the conditional jump.
- do (comp-emit (list 'set (make-comp-mvar :slot 'scratch)
- (comp-call test-func var m-test)))
- (comp-emit (list 'cond-jump
- (make-comp-mvar :slot 'scratch)
- (make-comp-mvar :constant nil)
+ do (comp--emit (list 'set (make--comp-mvar :slot 'scratch)
+ (comp--call test-func var m-test)))
+ (comp--emit (list 'cond-jump
+ (make--comp-mvar :slot 'scratch)
+ (make--comp-mvar :constant nil)
ff-bb-name target-name))
unless last
;; All fall through are artificially created here except the last one.
do (puthash ff-bb-name ff-bb (comp-func-blocks comp-func))
(setf (comp-limplify-curr-block comp-pass) ff-bb))))
(_ (signal 'native-ice
- "missing previous setimm while creating a switch"))))
+ '("missing previous setimm while creating a switch")))))
(defun comp--func-arity (subr-name)
"Like `func-arity' but invariant against primitive redefinitions.
@@ -1766,7 +1213,7 @@ SUBR-NAME is the name of function."
(or (gethash subr-name comp-subr-arities-h)
(func-arity subr-name)))
-(defun comp-emit-set-call-subr (subr-name sp-delta)
+(defun comp--emit-set-call-subr (subr-name sp-delta)
"Emit a call for SUBR-NAME.
SP-DELTA is the stack adjustment."
(let* ((nargs (1+ (- sp-delta)))
@@ -1777,39 +1224,39 @@ SP-DELTA is the stack adjustment."
(signal 'native-ice (list "subr contains unevalled args" subr-name)))
(if (eq maxarg 'many)
;; callref case.
- (comp-emit-set-call (comp-callref subr-name nargs (comp-sp)))
+ (comp--emit-set-call (comp--callref subr-name nargs (comp--sp)))
;; Normal call.
(unless (and (>= maxarg nargs) (<= minarg nargs))
(signal 'native-ice
(list "incoherent stack adjustment" nargs maxarg minarg)))
(let* ((subr-name subr-name)
(slots (cl-loop for i from 0 below maxarg
- collect (comp-slot-n (+ i (comp-sp))))))
- (comp-emit-set-call (apply #'comp-call (cons subr-name slots)))))))
+ collect (comp--slot-n (+ i (comp--sp))))))
+ (comp--emit-set-call (apply #'comp--call (cons subr-name slots)))))))
(eval-when-compile
- (defun comp-op-to-fun (x)
+ (defun comp--op-to-fun (x)
"Given the LAP op strip \"byte-\" to have the subr name."
- (intern (replace-regexp-in-string "byte-" "" x)))
+ (intern (string-replace "byte-" "" x)))
- (defun comp-body-eff (body op-name sp-delta)
+ (defun comp--body-eff (body op-name sp-delta)
"Given the original BODY, compute the effective one.
When BODY is `auto', guess function name from the LAP byte-code
name. Otherwise expect lname fnname."
(pcase (car body)
('auto
- `((comp-emit-set-call-subr ',(comp-op-to-fun op-name) ,sp-delta)))
+ `((comp--emit-set-call-subr ',(comp--op-to-fun op-name) ,sp-delta)))
((pred symbolp)
- `((comp-emit-set-call-subr ',(car body) ,sp-delta)))
+ `((comp--emit-set-call-subr ',(car body) ,sp-delta)))
(_ body))))
-(defmacro comp-op-case (&rest cases)
+(defmacro comp--op-case (&rest cases)
"Expand CASES into the corresponding `pcase' expansion.
This is responsible for generating the proper stack adjustment, when known,
and the annotation emission."
(declare (debug (body))
(indent defun))
- (declare-function comp-body-eff nil (body op-name sp-delta))
+ (declare-function comp--body-eff nil (body op-name sp-delta))
`(pcase op
,@(cl-loop for (op . body) in cases
for sp-delta = (gethash op comp-op-stack-info)
@@ -1818,55 +1265,55 @@ and the annotation emission."
collect `(',op
;; Log all LAP ops except the TAG one.
;; ,(unless (eq op 'TAG)
- ;; `(comp-emit-annotation
+ ;; `(comp--emit-annotation
;; ,(concat "LAP op " op-name)))
;; Emit the stack adjustment if present.
,(when (and sp-delta (not (eq 0 sp-delta)))
- `(cl-incf (comp-sp) ,sp-delta))
- ,@(comp-body-eff body op-name sp-delta))
+ `(cl-incf (comp--sp) ,sp-delta))
+ ,@(comp--body-eff body op-name sp-delta))
else
collect `(',op (signal 'native-ice
(list "unsupported LAP op" ',op-name))))
(_ (signal 'native-ice (list "unexpected LAP op" (symbol-name op))))))
-(defun comp-limplify-lap-inst (insn)
+(defun comp--limplify-lap-inst (insn)
"Limplify LAP instruction INSN pushing it in the proper basic block."
(let ((op (car insn))
(arg (if (consp (cdr insn))
(cadr insn)
(cdr insn))))
- (comp-op-case
+ (comp--op-case
(TAG
(cl-destructuring-bind (_TAG label-num . label-sp) insn
;; Paranoid?
(when label-sp
(cl-assert (= (1- label-sp) (comp-limplify-sp comp-pass))))
- (comp-emit-annotation (format "LAP TAG %d" label-num))))
+ (comp--emit-annotation (format "LAP TAG %d" label-num))))
(byte-stack-ref
- (comp-copy-slot (- (comp-sp) arg 1)))
+ (comp--copy-slot (- (comp--sp) arg 1)))
(byte-varref
- (comp-emit-set-call (comp-call 'symbol-value (make-comp-mvar
+ (comp--emit-set-call (comp--call 'symbol-value (make--comp-mvar
:constant arg))))
(byte-varset
- (comp-emit (comp-call 'set_internal
- (make-comp-mvar :constant arg)
- (comp-slot+1))))
+ (comp--emit (comp--call 'set_internal
+ (make--comp-mvar :constant arg)
+ (comp--slot+1))))
(byte-varbind ;; Verify
- (comp-emit (comp-call 'specbind
- (make-comp-mvar :constant arg)
- (comp-slot+1))))
+ (comp--emit (comp--call 'specbind
+ (make--comp-mvar :constant arg)
+ (comp--slot+1))))
(byte-call
- (cl-incf (comp-sp) (- arg))
- (comp-emit-set-call (comp-callref 'funcall (1+ arg) (comp-sp))))
+ (cl-incf (comp--sp) (- arg))
+ (comp--emit-set-call (comp--callref 'funcall (1+ arg) (comp--sp))))
(byte-unbind
- (comp-emit (comp-call 'helper_unbind_n
- (make-comp-mvar :constant arg))))
+ (comp--emit (comp--call 'helper_unbind_n
+ (make--comp-mvar :constant arg))))
(byte-pophandler
- (comp-emit '(pop-handler)))
+ (comp--emit '(pop-handler)))
(byte-pushconditioncase
- (comp-emit-handler (cddr insn) 'condition-case))
+ (comp--emit-handler (cddr insn) 'condition-case))
(byte-pushcatch
- (comp-emit-handler (cddr insn) 'catcher))
+ (comp--emit-handler (cddr insn) 'catcher))
(byte-nth auto)
(byte-symbolp auto)
(byte-consp auto)
@@ -1875,19 +1322,19 @@ and the annotation emission."
(byte-eq auto)
(byte-memq auto)
(byte-not
- (comp-emit-set-call (comp-call 'eq (comp-slot-n (comp-sp))
- (make-comp-mvar :constant nil))))
+ (comp--emit-set-call (comp--call 'eq (comp--slot-n (comp--sp))
+ (make--comp-mvar :constant nil))))
(byte-car auto)
(byte-cdr auto)
(byte-cons auto)
(byte-list1
- (comp-limplify-listn 1))
+ (comp--limplify-listn 1))
(byte-list2
- (comp-limplify-listn 2))
+ (comp--limplify-listn 2))
(byte-list3
- (comp-limplify-listn 3))
+ (comp--limplify-listn 3))
(byte-list4
- (comp-limplify-listn 4))
+ (comp--limplify-listn 4))
(byte-length auto)
(byte-aref auto)
(byte-aset auto)
@@ -1898,11 +1345,11 @@ and the annotation emission."
(byte-get auto)
(byte-substring auto)
(byte-concat2
- (comp-emit-set-call (comp-callref 'concat 2 (comp-sp))))
+ (comp--emit-set-call (comp--callref 'concat 2 (comp--sp))))
(byte-concat3
- (comp-emit-set-call (comp-callref 'concat 3 (comp-sp))))
+ (comp--emit-set-call (comp--callref 'concat 3 (comp--sp))))
(byte-concat4
- (comp-emit-set-call (comp-callref 'concat 4 (comp-sp))))
+ (comp--emit-set-call (comp--callref 'concat 4 (comp--sp))))
(byte-sub1 1-)
(byte-add1 1+)
(byte-eqlsign =)
@@ -1912,7 +1359,7 @@ and the annotation emission."
(byte-geq >=)
(byte-diff -)
(byte-negate
- (comp-emit-set-call (comp-call 'negate (comp-slot))))
+ (comp--emit-set-call (comp--call 'negate (comp--slot))))
(byte-plus +)
(byte-max auto)
(byte-min auto)
@@ -1927,9 +1374,9 @@ and the annotation emission."
(byte-preceding-char preceding-char)
(byte-current-column auto)
(byte-indent-to
- (comp-emit-set-call (comp-call 'indent-to
- (comp-slot)
- (make-comp-mvar :constant nil))))
+ (comp--emit-set-call (comp--call 'indent-to
+ (comp--slot)
+ (make--comp-mvar :constant nil))))
(byte-scan-buffer-OBSOLETE)
(byte-eolp auto)
(byte-eobp auto)
@@ -1938,7 +1385,7 @@ and the annotation emission."
(byte-current-buffer auto)
(byte-set-buffer auto)
(byte-save-current-buffer
- (comp-emit (comp-call 'record_unwind_current_buffer)))
+ (comp--emit (comp--call 'record_unwind_current_buffer)))
(byte-set-mark-OBSOLETE)
(byte-interactive-p-OBSOLETE)
(byte-forward-char auto)
@@ -1950,41 +1397,41 @@ and the annotation emission."
(byte-buffer-substring auto)
(byte-delete-region auto)
(byte-narrow-to-region
- (comp-emit-set-call (comp-call 'narrow-to-region
- (comp-slot)
- (comp-slot+1))))
+ (comp--emit-set-call (comp--call 'narrow-to-region
+ (comp--slot)
+ (comp--slot+1))))
(byte-widen
- (comp-emit-set-call (comp-call 'widen)))
+ (comp--emit-set-call (comp--call 'widen)))
(byte-end-of-line auto)
(byte-constant2) ; TODO
;; Branches.
(byte-goto
- (comp-emit-uncond-jump (cddr insn)))
+ (comp--emit-uncond-jump (cddr insn)))
(byte-goto-if-nil
- (comp-emit-cond-jump (comp-slot+1) (make-comp-mvar :constant nil) 0
+ (comp--emit-cond-jump (comp--slot+1) (make--comp-mvar :constant nil) 0
(cddr insn) nil))
(byte-goto-if-not-nil
- (comp-emit-cond-jump (comp-slot+1) (make-comp-mvar :constant nil) 0
+ (comp--emit-cond-jump (comp--slot+1) (make--comp-mvar :constant nil) 0
(cddr insn) t))
(byte-goto-if-nil-else-pop
- (comp-emit-cond-jump (comp-slot+1) (make-comp-mvar :constant nil) 1
+ (comp--emit-cond-jump (comp--slot+1) (make--comp-mvar :constant nil) 1
(cddr insn) nil))
(byte-goto-if-not-nil-else-pop
- (comp-emit-cond-jump (comp-slot+1) (make-comp-mvar :constant nil) 1
+ (comp--emit-cond-jump (comp--slot+1) (make--comp-mvar :constant nil) 1
(cddr insn) t))
(byte-return
- (comp-emit `(return ,(comp-slot+1))))
+ (comp--emit `(return ,(comp--slot+1))))
(byte-discard 'pass)
(byte-dup
- (comp-copy-slot (1- (comp-sp))))
+ (comp--copy-slot (1- (comp--sp))))
(byte-save-excursion
- (comp-emit (comp-call 'record_unwind_protect_excursion)))
+ (comp--emit (comp--call 'record_unwind_protect_excursion)))
(byte-save-window-excursion-OBSOLETE)
(byte-save-restriction
- (comp-emit (comp-call 'helper_save_restriction)))
+ (comp--emit (comp--call 'helper_save_restriction)))
(byte-catch) ;; Obsolete
(byte-unwind-protect
- (comp-emit (comp-call 'helper_unwind_protect (comp-slot+1))))
+ (comp--emit (comp--call 'helper_unwind_protect (comp--slot+1))))
(byte-condition-case) ;; Obsolete
(byte-temp-output-buffer-setup-OBSOLETE)
(byte-temp-output-buffer-show-OBSOLETE)
@@ -2011,111 +1458,111 @@ and the annotation emission."
(byte-numberp auto)
(byte-integerp auto)
(byte-listN
- (cl-incf (comp-sp) (- 1 arg))
- (comp-emit-set-call (comp-callref 'list arg (comp-sp))))
+ (cl-incf (comp--sp) (- 1 arg))
+ (comp--emit-set-call (comp--callref 'list arg (comp--sp))))
(byte-concatN
- (cl-incf (comp-sp) (- 1 arg))
- (comp-emit-set-call (comp-callref 'concat arg (comp-sp))))
+ (cl-incf (comp--sp) (- 1 arg))
+ (comp--emit-set-call (comp--callref 'concat arg (comp--sp))))
(byte-insertN
- (cl-incf (comp-sp) (- 1 arg))
- (comp-emit-set-call (comp-callref 'insert arg (comp-sp))))
+ (cl-incf (comp--sp) (- 1 arg))
+ (comp--emit-set-call (comp--callref 'insert arg (comp--sp))))
(byte-stack-set
- (comp-copy-slot (1+ (comp-sp)) (- (comp-sp) arg -1)))
+ (comp--copy-slot (1+ (comp--sp)) (- (comp--sp) arg -1)))
(byte-stack-set2 (cl-assert nil)) ;; TODO
(byte-discardN
- (cl-incf (comp-sp) (- arg)))
+ (cl-incf (comp--sp) (- arg)))
(byte-switch
;; Assume to follow the emission of a setimm.
- ;; This is checked into comp-emit-switch.
- (comp-emit-switch (comp-slot+1)
+ ;; This is checked into comp--emit-switch.
+ (comp--emit-switch (comp--slot+1)
(cl-first (comp-block-insns
(comp-limplify-curr-block comp-pass)))))
(byte-constant
- (comp-emit-setimm arg))
+ (comp--emit-setimm arg))
(byte-discardN-preserve-tos
- (cl-incf (comp-sp) (- arg))
- (comp-copy-slot (+ arg (comp-sp)))))))
+ (cl-incf (comp--sp) (- arg))
+ (comp--copy-slot (+ arg (comp--sp)))))))
-(defun comp-emit-narg-prologue (minarg nonrest rest)
+(defun comp--emit-narg-prologue (minarg nonrest rest)
"Emit the prologue for a narg function."
(cl-loop for i below minarg
- do (comp-emit `(set-args-to-local ,(comp-slot-n i)))
- (comp-emit '(inc-args)))
+ do (comp--emit `(set-args-to-local ,(comp--slot-n i)))
+ (comp--emit '(inc-args)))
(cl-loop for i from minarg below nonrest
for bb = (intern (format "entry_%s" i))
for fallback = (intern (format "entry_fallback_%s" i))
- do (comp-emit `(cond-jump-narg-leq ,i ,fallback ,bb))
- (comp-make-curr-block bb (comp-sp))
- (comp-emit `(set-args-to-local ,(comp-slot-n i)))
- (comp-emit '(inc-args))
- finally (comp-emit '(jump entry_rest_args)))
+ do (comp--emit `(cond-jump-narg-leq ,i ,fallback ,bb))
+ (comp--make-curr-block bb (comp--sp))
+ (comp--emit `(set-args-to-local ,(comp--slot-n i)))
+ (comp--emit '(inc-args))
+ finally (comp--emit '(jump entry_rest_args)))
(when (/= minarg nonrest)
(cl-loop for i from minarg below nonrest
for bb = (intern (format "entry_fallback_%s" i))
for next-bb = (if (= (1+ i) nonrest)
'entry_rest_args
(intern (format "entry_fallback_%s" (1+ i))))
- do (comp-with-sp i
- (comp-make-curr-block bb (comp-sp))
- (comp-emit-setimm nil)
- (comp-emit `(jump ,next-bb)))))
- (comp-make-curr-block 'entry_rest_args (comp-sp))
- (comp-emit `(set-rest-args-to-local ,(comp-slot-n nonrest)))
- (setf (comp-sp) nonrest)
+ do (comp--with-sp i
+ (comp--make-curr-block bb (comp--sp))
+ (comp--emit-setimm nil)
+ (comp--emit `(jump ,next-bb)))))
+ (comp--make-curr-block 'entry_rest_args (comp--sp))
+ (comp--emit `(set-rest-args-to-local ,(comp--slot-n nonrest)))
+ (setf (comp--sp) nonrest)
(when (and (> nonrest 8) (null rest))
- (cl-decf (comp-sp))))
+ (cl-decf (comp--sp))))
-(defun comp-limplify-finalize-function (func)
+(defun comp--limplify-finalize-function (func)
"Reverse insns into all basic blocks of FUNC."
(cl-loop for bb being the hash-value in (comp-func-blocks func)
do (setf (comp-block-insns bb)
(nreverse (comp-block-insns bb))))
- (comp-log-func func 2)
+ (comp--log-func func 2)
func)
-(cl-defgeneric comp-prepare-args-for-top-level (function)
+(cl-defgeneric comp--prepare-args-for-top-level (function)
"Given FUNCTION, return the two arguments for comp--register-...")
-(cl-defmethod comp-prepare-args-for-top-level ((function comp-func-l))
+(cl-defmethod comp--prepare-args-for-top-level ((function comp-func-l))
"Lexically-scoped FUNCTION."
(let ((args (comp-func-l-args function)))
- (cons (make-comp-mvar :constant (comp-args-base-min args))
- (make-comp-mvar :constant (cond
+ (cons (make--comp-mvar :constant (comp-args-base-min args))
+ (make--comp-mvar :constant (cond
((comp-args-p args) (comp-args-max args))
((comp-nargs-rest args) 'many)
(t (comp-nargs-nonrest args)))))))
-(cl-defmethod comp-prepare-args-for-top-level ((function comp-func-d))
+(cl-defmethod comp--prepare-args-for-top-level ((function comp-func-d))
"Dynamically scoped FUNCTION."
- (cons (make-comp-mvar :constant (func-arity (comp-func-byte-func function)))
+ (cons (make--comp-mvar :constant (func-arity (comp-func-byte-func function)))
(let ((comp-curr-allocation-class 'd-default))
;; Lambda-lists must stay in the same relocation class of
;; the object referenced by code to respect uninterned
;; symbols.
- (make-comp-mvar :constant (comp-func-d-lambda-list function)))))
+ (make--comp-mvar :constant (comp-func-d-lambda-list function)))))
-(cl-defgeneric comp-emit-for-top-level (form for-late-load)
+(cl-defgeneric comp--emit-for-top-level (form for-late-load)
"Emit the Limple code for top level FORM.")
-(cl-defmethod comp-emit-for-top-level ((form byte-to-native-func-def)
+(cl-defmethod comp--emit-for-top-level ((form byte-to-native-func-def)
for-late-load)
(let* ((name (byte-to-native-func-def-name form))
(c-name (byte-to-native-func-def-c-name form))
(f (gethash c-name (comp-ctxt-funcs-h comp-ctxt)))
- (args (comp-prepare-args-for-top-level f)))
+ (args (comp--prepare-args-for-top-level f)))
(cl-assert (and name f))
- (comp-emit
- `(set ,(make-comp-mvar :slot 1)
- ,(comp-call (if for-late-load
+ (comp--emit
+ `(set ,(make--comp-mvar :slot 1)
+ ,(comp--call (if for-late-load
'comp--late-register-subr
'comp--register-subr)
- (make-comp-mvar :constant name)
- (make-comp-mvar :constant c-name)
+ (make--comp-mvar :constant name)
+ (make--comp-mvar :constant c-name)
(car args)
(cdr args)
(setf (comp-func-type f)
- (make-comp-mvar :constant nil))
- (make-comp-mvar
+ (make--comp-mvar :constant nil))
+ (make--comp-mvar
:constant
(list
(let* ((h (comp-ctxt-function-docs comp-ctxt))
@@ -2126,40 +1573,40 @@ and the annotation emission."
(comp-func-command-modes f)))
;; This is the compilation unit it-self passed as
;; parameter.
- (make-comp-mvar :slot 0))))))
+ (make--comp-mvar :slot 0))))))
-(cl-defmethod comp-emit-for-top-level ((form byte-to-native-top-level)
+(cl-defmethod comp--emit-for-top-level ((form byte-to-native-top-level)
for-late-load)
(unless for-late-load
- (comp-emit
- (comp-call 'eval
+ (comp--emit
+ (comp--call 'eval
(let ((comp-curr-allocation-class 'd-impure))
- (make-comp-mvar :constant
+ (make--comp-mvar :constant
(byte-to-native-top-level-form form)))
- (make-comp-mvar :constant
+ (make--comp-mvar :constant
(byte-to-native-top-level-lexical form))))))
-(defun comp-emit-lambda-for-top-level (func)
+(defun comp--emit-lambda-for-top-level (func)
"Emit the creation of subrs for lambda FUNC.
These are stored in the reloc data array."
- (let ((args (comp-prepare-args-for-top-level func)))
+ (let ((args (comp--prepare-args-for-top-level func)))
(let ((comp-curr-allocation-class 'd-impure))
- (comp-add-const-to-relocs (comp-func-byte-func func)))
- (comp-emit
- (comp-call 'comp--register-lambda
+ (comp--add-const-to-relocs (comp-func-byte-func func)))
+ (comp--emit
+ (comp--call 'comp--register-lambda
;; mvar to be fixed-up when containers are
;; finalized.
(or (gethash (comp-func-byte-func func)
(comp-ctxt-lambda-fixups-h comp-ctxt))
(puthash (comp-func-byte-func func)
- (make-comp-mvar :constant nil)
+ (make--comp-mvar :constant nil)
(comp-ctxt-lambda-fixups-h comp-ctxt)))
- (make-comp-mvar :constant (comp-func-c-name func))
+ (make--comp-mvar :constant (comp-func-c-name func))
(car args)
(cdr args)
(setf (comp-func-type func)
- (make-comp-mvar :constant nil))
- (make-comp-mvar
+ (make--comp-mvar :constant nil))
+ (make--comp-mvar
:constant
(list
(let* ((h (comp-ctxt-function-docs comp-ctxt))
@@ -2170,9 +1617,9 @@ These are stored in the reloc data array."
(comp-func-command-modes func)))
;; This is the compilation unit it-self passed as
;; parameter.
- (make-comp-mvar :slot 0)))))
+ (make--comp-mvar :slot 0)))))
-(defun comp-limplify-top-level (for-late-load)
+(defun comp--limplify-top-level (for-late-load)
"Create a Limple function to modify the global environment at load.
When FOR-LATE-LOAD is non-nil, the emitted function modifies only
function definition.
@@ -2202,22 +1649,22 @@ into the C code forwarding the compilation unit."
(comp-func func)
(comp-pass (make-comp-limplify
:curr-block (make--comp-block-lap -1 0 'top-level)
- :frame (comp-new-frame 1 0))))
- (comp-make-curr-block 'entry (comp-sp))
- (comp-emit-annotation (if for-late-load
+ :frame (comp--new-frame 1 0))))
+ (comp--make-curr-block 'entry (comp--sp))
+ (comp--emit-annotation (if for-late-load
"Late top level"
"Top level"))
;; Assign the compilation unit incoming as parameter to the slot frame 0.
- (comp-emit `(set-par-to-local ,(comp-slot-n 0) 0))
+ (comp--emit `(set-par-to-local ,(comp--slot-n 0) 0))
(maphash (lambda (_ func)
- (comp-emit-lambda-for-top-level func))
+ (comp--emit-lambda-for-top-level func))
(comp-ctxt-byte-func-to-func-h comp-ctxt))
- (mapc (lambda (x) (comp-emit-for-top-level x for-late-load))
+ (mapc (lambda (x) (comp--emit-for-top-level x for-late-load))
(comp-ctxt-top-level-forms comp-ctxt))
- (comp-emit `(return ,(make-comp-mvar :slot 1)))
- (comp-limplify-finalize-function func)))
+ (comp--emit `(return ,(make--comp-mvar :slot 1)))
+ (comp--limplify-finalize-function func)))
-(defun comp-addr-to-bb-name (addr)
+(defun comp--addr-to-bb-name (addr)
"Search for a block starting at ADDR into pending or limplified blocks."
;; FIXME Actually we could have another hash for this.
(cl-flet ((pred (bb)
@@ -2229,7 +1676,7 @@ into the C code forwarding the compilation unit."
when (pred bb)
return (comp-block-name bb)))))
-(defun comp-limplify-block (bb)
+(defun comp--limplify-block (bb)
"Limplify basic-block BB and add it to the current function."
(setf (comp-limplify-curr-block comp-pass) bb
(comp-limplify-sp comp-pass) (comp-block-lap-sp bb)
@@ -2240,51 +1687,51 @@ into the C code forwarding the compilation unit."
(comp-func-lap comp-func))
for inst = (car inst-cell)
for next-inst = (car-safe (cdr inst-cell))
- do (comp-limplify-lap-inst inst)
+ do (comp--limplify-lap-inst inst)
(cl-incf (comp-limplify-pc comp-pass))
- when (comp-lap-fall-through-p inst)
+ when (comp--lap-fall-through-p inst)
do (pcase next-inst
(`(TAG ,_label . ,label-sp)
(when label-sp
- (cl-assert (= (1- label-sp) (comp-sp))))
+ (cl-assert (= (1- label-sp) (comp--sp))))
(let* ((stack-depth (if label-sp
(1- label-sp)
- (comp-sp)))
- (next-bb (comp-block-name (comp-bb-maybe-add
+ (comp--sp)))
+ (next-bb (comp-block-name (comp--bb-maybe-add
(comp-limplify-pc comp-pass)
stack-depth))))
(unless (comp-block-closed bb)
- (comp-emit `(jump ,next-bb))))
+ (comp--emit `(jump ,next-bb))))
(cl-return)))
- until (comp-lap-eob-p inst)))
+ until (comp--lap-eob-p inst)))
-(defun comp-limplify-function (func)
+(defun comp--limplify-function (func)
"Limplify a single function FUNC."
(let* ((frame-size (comp-func-frame-size func))
(comp-func func)
(comp-pass (make-comp-limplify
- :frame (comp-new-frame frame-size 0))))
- (comp-fill-label-h)
+ :frame (comp--new-frame frame-size 0))))
+ (comp--fill-label-h)
;; Prologue
- (comp-make-curr-block 'entry (comp-sp))
- (comp-emit-annotation (concat "Lisp function: "
+ (comp--make-curr-block 'entry (comp--sp))
+ (comp--emit-annotation (concat "Lisp function: "
(symbol-name (comp-func-name func))))
;; Dynamic functions have parameters bound by the trampoline.
(when (comp-func-l-p func)
(let ((args (comp-func-l-args func)))
(if (comp-args-p args)
(cl-loop for i below (comp-args-max args)
- do (cl-incf (comp-sp))
- (comp-emit `(set-par-to-local ,(comp-slot) ,i)))
- (comp-emit-narg-prologue (comp-args-base-min args)
+ do (cl-incf (comp--sp))
+ (comp--emit `(set-par-to-local ,(comp--slot) ,i)))
+ (comp--emit-narg-prologue (comp-args-base-min args)
(comp-nargs-nonrest args)
(comp-nargs-rest args)))))
- (comp-emit '(jump bb_0))
+ (comp--emit '(jump bb_0))
;; Body
- (comp-bb-maybe-add 0 (comp-sp))
+ (comp--bb-maybe-add 0 (comp--sp))
(cl-loop for next-bb = (pop (comp-limplify-pending-blocks comp-pass))
while next-bb
- do (comp-limplify-block next-bb))
+ do (comp--limplify-block next-bb))
;; Sanity check against block duplication.
(cl-loop with addr-h = (make-hash-table)
for bb being the hash-value in (comp-func-blocks func)
@@ -2293,15 +1740,15 @@ into the C code forwarding the compilation unit."
when addr
do (cl-assert (null (gethash addr addr-h)))
(puthash addr t addr-h))
- (comp-limplify-finalize-function func)))
+ (comp--limplify-finalize-function func)))
-(defun comp-limplify (_)
+(defun comp--limplify (_)
"Compute LIMPLE IR for forms in `comp-ctxt'."
- (maphash (lambda (_ f) (comp-limplify-function f))
+ (maphash (lambda (_ f) (comp--limplify-function f))
(comp-ctxt-funcs-h comp-ctxt))
- (comp-add-func-to-ctxt (comp-limplify-top-level nil))
+ (comp--add-func-to-ctxt (comp--limplify-top-level nil))
(when (comp-ctxt-with-late-load comp-ctxt)
- (comp-add-func-to-ctxt (comp-limplify-top-level t))))
+ (comp--add-func-to-ctxt (comp--limplify-top-level t))))
;;; add-cstrs pass specific code.
@@ -2325,34 +1772,36 @@ into the C code forwarding the compilation unit."
;; type specifier.
-(defsubst comp-mvar-used-p (mvar)
+(defsubst comp--mvar-used-p (mvar)
"Non-nil when MVAR is used as lhs in the current function."
(declare (gv-setter (lambda (val)
`(puthash ,mvar ,val comp-pass))))
(gethash mvar comp-pass))
-(defun comp-collect-mvars (form)
+(defun comp--collect-mvars (form)
"Add rhs m-var present in FORM into `comp-pass'."
(cl-loop for x in form
if (consp x)
- do (comp-collect-mvars x)
+ do (comp--collect-mvars x)
else
when (comp-mvar-p x)
- do (setf (comp-mvar-used-p x) t)))
+ do (setf (comp--mvar-used-p x) t)))
-(defun comp-collect-rhs ()
+(defun comp--collect-rhs ()
"Collect all lhs mvars into `comp-pass'."
(cl-loop
for b being each hash-value of (comp-func-blocks comp-func)
do (cl-loop
for insn in (comp-block-insns b)
for (op . args) = insn
- if (comp-assign-op-p op)
- do (comp-collect-mvars (cdr args))
+ if (comp--assign-op-p op)
+ do (comp--collect-mvars (if (eq op 'setimm)
+ (cl-first args)
+ (cdr args)))
else
- do (comp-collect-mvars args))))
+ do (comp--collect-mvars args))))
-(defun comp-negate-arithm-cmp-fun (function)
+(defun comp--negate-arithm-cmp-fun (function)
"Negate FUNCTION.
Return nil if we don't want to emit constraints for its negation."
(cl-ecase function
@@ -2362,7 +1811,7 @@ Return nil if we don't want to emit constraints for its negation."
(>= '<)
(<= '>)))
-(defun comp-reverse-arithm-fun (function)
+(defun comp--reverse-arithm-fun (function)
"Reverse FUNCTION."
(cl-case function
(= '=)
@@ -2372,7 +1821,7 @@ Return nil if we don't want to emit constraints for its negation."
(<= '>=)
(t function)))
-(defun comp-emit-assume (kind lhs rhs bb negated)
+(defun comp--emit-assume (kind lhs rhs bb negated)
"Emit an assume of kind KIND for mvar LHS being RHS.
When NEGATED is non-nil, the assumption is negated.
The assume is emitted at the beginning of the block BB."
@@ -2382,41 +1831,41 @@ The assume is emitted at the beginning of the block BB."
((or 'and 'and-nhc)
(if (comp-mvar-p rhs)
(let ((tmp-mvar (if negated
- (make-comp-mvar :slot (comp-mvar-slot rhs))
+ (make--comp-mvar :slot (comp-mvar-slot rhs))
rhs)))
- (push `(assume ,(make-comp-mvar :slot lhs-slot)
+ (push `(assume ,(make--comp-mvar :slot lhs-slot)
(,kind ,lhs ,tmp-mvar))
(comp-block-insns bb))
(if negated
(push `(assume ,tmp-mvar (not ,rhs))
(comp-block-insns bb))))
;; If is only a constraint we can negate it directly.
- (push `(assume ,(make-comp-mvar :slot lhs-slot)
+ (push `(assume ,(make--comp-mvar :slot lhs-slot)
(,kind ,lhs ,(if negated
(comp-cstr-negation-make rhs)
rhs)))
(comp-block-insns bb))))
- ((pred comp-arithm-cmp-fun-p)
+ ((pred comp--arithm-cmp-fun-p)
(when-let ((kind (if negated
- (comp-negate-arithm-cmp-fun kind)
+ (comp--negate-arithm-cmp-fun kind)
kind)))
- (push `(assume ,(make-comp-mvar :slot lhs-slot)
+ (push `(assume ,(make--comp-mvar :slot lhs-slot)
(,kind ,lhs
,(if-let* ((vld (comp-cstr-imm-vld-p rhs))
(val (comp-cstr-imm rhs))
(ok (and (integerp val)
(not (memq kind '(= !=))))))
val
- (make-comp-mvar :slot (comp-mvar-slot rhs)))))
+ (make--comp-mvar :slot (comp-mvar-slot rhs)))))
(comp-block-insns bb))))
(_ (cl-assert nil)))
(setf (comp-func-ssa-status comp-func) 'dirty)))
-(defun comp-maybe-add-vmvar (op cmp-res insns-seq)
+(defun comp--maybe-add-vmvar (op cmp-res insns-seq)
"If CMP-RES is clobbering OP emit a new constrained mvar and return it.
Return OP otherwise."
(if-let ((match (eql (comp-mvar-slot op) (comp-mvar-slot cmp-res)))
- (new-mvar (make-comp-mvar
+ (new-mvar (make--comp-mvar
:slot
(- (cl-incf (comp-func-vframe-size comp-func))))))
(progn
@@ -2424,12 +1873,12 @@ Return OP otherwise."
new-mvar)
op))
-(defun comp-add-new-block-between (bb-symbol bb-a bb-b)
+(defun comp--add-new-block-between (bb-symbol bb-a bb-b)
"Create a new basic-block named BB-SYMBOL and add it between BB-A and BB-B."
(cl-loop
with new-bb = (make-comp-block-cstr :name bb-symbol
:insns `((jump ,(comp-block-name bb-b))))
- with new-edge = (make-comp-edge :src bb-a :dst new-bb)
+ with new-edge = (comp--edge-make :src bb-a :dst new-bb)
for ed in (comp-block-in-edges bb-b)
when (eq (comp-edge-src ed) bb-a)
do
@@ -2447,7 +1896,7 @@ Return OP otherwise."
finally (cl-assert nil)))
;; Cheap substitute to a copy propagation pass...
-(defun comp-cond-cstrs-target-mvar (mvar exit-insn bb)
+(defun comp--cond-cstrs-target-mvar (mvar exit-insn bb)
"Given MVAR, search in BB the original mvar MVAR got assigned from.
Keep on searching till EXIT-INSN is encountered."
(cl-flet ((targetp (x)
@@ -2460,11 +1909,11 @@ Keep on searching till EXIT-INSN is encountered."
when (eq insn exit-insn)
do (cl-return (and (comp-mvar-p res) res))
do (pcase insn
- (`(,(pred comp-assign-op-p) ,(pred targetp) ,rhs)
+ (`(,(pred comp--assign-op-p) ,(pred targetp) ,rhs)
(setf res rhs)))
finally (cl-assert nil))))
-(defun comp-add-cond-cstrs-target-block (curr-bb target-bb-sym)
+(defun comp--add-cond-cstrs-target-block (curr-bb target-bb-sym)
"Return the appropriate basic block to add constraint assumptions into.
CURR-BB is the current basic block.
TARGET-BB-SYM is the symbol name of the target block."
@@ -2484,10 +1933,10 @@ TARGET-BB-SYM is the symbol name of the target block."
until (null (gethash new-name (comp-func-blocks comp-func)))
finally
;; Add it.
- (cl-return (comp-add-new-block-between new-name curr-bb target-bb))))))
+ (cl-return (comp--add-new-block-between new-name curr-bb target-bb))))))
-(defun comp-add-cond-cstrs-simple ()
- "`comp-add-cstrs' worker function for each selected function."
+(defun comp--add-cond-cstrs-simple ()
+ "`comp--add-cstrs' worker function for each selected function."
(cl-loop
for b being each hash-value of (comp-func-blocks comp-func)
do
@@ -2503,26 +1952,26 @@ TARGET-BB-SYM is the symbol name of the target block."
for branch-target-cell on blocks
for branch-target = (car branch-target-cell)
for negated in '(nil t)
- when (comp-mvar-used-p tmp-mvar)
+ when (comp--mvar-used-p tmp-mvar)
do
- (let ((block-target (comp-add-cond-cstrs-target-block b branch-target)))
+ (let ((block-target (comp--add-cond-cstrs-target-block b branch-target)))
(setf (car branch-target-cell) (comp-block-name block-target))
- (comp-emit-assume 'and tmp-mvar obj2 block-target negated))
+ (comp--emit-assume 'and tmp-mvar obj2 block-target negated))
finally (cl-return-from in-the-basic-block)))
(`((cond-jump ,obj1 ,obj2 . ,blocks))
(cl-loop
for branch-target-cell on blocks
for branch-target = (car branch-target-cell)
for negated in '(nil t)
- when (comp-mvar-used-p obj1)
+ when (comp--mvar-used-p obj1)
do
- (let ((block-target (comp-add-cond-cstrs-target-block b branch-target)))
+ (let ((block-target (comp--add-cond-cstrs-target-block b branch-target)))
(setf (car branch-target-cell) (comp-block-name block-target))
- (comp-emit-assume 'and obj1 obj2 block-target negated))
+ (comp--emit-assume 'and obj1 obj2 block-target negated))
finally (cl-return-from in-the-basic-block)))))))
-(defun comp-add-cond-cstrs ()
- "`comp-add-cstrs' worker function for each selected function."
+(defun comp--add-cond-cstrs ()
+ "`comp--add-cstrs' worker function for each selected function."
(cl-loop
for b being each hash-value of (comp-func-blocks comp-func)
do
@@ -2532,17 +1981,34 @@ TARGET-BB-SYM is the symbol name of the target block."
for insns-seq on (comp-block-insns b)
do
(pcase insns-seq
+ (`((set ,(and (pred comp-mvar-p) mvar-tested-copy)
+ ,(and (pred comp-mvar-p) mvar-tested))
+ (set ,(and (pred comp-mvar-p) mvar-1)
+ (call type-of ,(and (pred comp-mvar-p) mvar-tested-copy)))
+ (set ,(and (pred comp-mvar-p) mvar-2)
+ (call symbol-value ,(and (pred comp-cstr-cl-tag-p) mvar-tag)))
+ (set ,(and (pred comp-mvar-p) mvar-3)
+ (call memq ,(and (pred comp-mvar-p) mvar-1) ,(and (pred comp-mvar-p) mvar-2)))
+ (cond-jump ,(and (pred comp-mvar-p) mvar-3) ,(pred comp-mvar-p) ,bb1 ,bb2))
+ (comp--emit-assume 'and mvar-tested
+ (make--comp-mvar :type (comp-cstr-cl-tag mvar-tag))
+ (comp--add-cond-cstrs-target-block b bb2)
+ nil)
+ (comp--emit-assume 'and mvar-tested
+ (make--comp-mvar :type (comp-cstr-cl-tag mvar-tag))
+ (comp--add-cond-cstrs-target-block b bb1)
+ t))
(`((set ,(and (pred comp-mvar-p) cmp-res)
- (,(pred comp-call-op-p)
- ,(and (or (pred comp-equality-fun-p)
- (pred comp-arithm-cmp-fun-p))
+ (,(pred comp--call-op-p)
+ ,(and (or (pred comp--equality-fun-p)
+ (pred comp--arithm-cmp-fun-p))
fun)
,op1 ,op2))
;; (comment ,_comment-str)
(cond-jump ,cmp-res ,(pred comp-mvar-p) . ,blocks))
(cl-loop
- with target-mvar1 = (comp-cond-cstrs-target-mvar op1 (car insns-seq) b)
- with target-mvar2 = (comp-cond-cstrs-target-mvar op2 (car insns-seq) b)
+ with target-mvar1 = (comp--cond-cstrs-target-mvar op1 (car insns-seq) b)
+ with target-mvar2 = (comp--cond-cstrs-target-mvar op2 (car insns-seq) b)
for branch-target-cell on blocks
for branch-target = (car branch-target-cell)
for negated in '(t nil)
@@ -2551,61 +2017,51 @@ TARGET-BB-SYM is the symbol name of the target block."
(eql 'and-nhc)
(eq 'and)
(t fun))
- when (or (comp-mvar-used-p target-mvar1)
- (comp-mvar-used-p target-mvar2))
+ when (or (comp--mvar-used-p target-mvar1)
+ (comp--mvar-used-p target-mvar2))
do
- (let ((block-target (comp-add-cond-cstrs-target-block b branch-target)))
+ (let ((block-target (comp--add-cond-cstrs-target-block b branch-target)))
(setf (car branch-target-cell) (comp-block-name block-target))
- (when (comp-mvar-used-p target-mvar1)
- (comp-emit-assume kind target-mvar1
- (comp-maybe-add-vmvar op2 cmp-res prev-insns-seq)
+ (when (comp--mvar-used-p target-mvar1)
+ (comp--emit-assume kind target-mvar1
+ (comp--maybe-add-vmvar op2 cmp-res prev-insns-seq)
block-target negated))
- (when (comp-mvar-used-p target-mvar2)
- (comp-emit-assume (comp-reverse-arithm-fun kind)
+ (when (comp--mvar-used-p target-mvar2)
+ (comp--emit-assume (comp--reverse-arithm-fun kind)
target-mvar2
- (comp-maybe-add-vmvar op1 cmp-res prev-insns-seq)
+ (comp--maybe-add-vmvar op1 cmp-res prev-insns-seq)
block-target negated)))
finally (cl-return-from in-the-basic-block)))
(`((set ,(and (pred comp-mvar-p) cmp-res)
- (,(pred comp-call-op-p)
- ,(and (pred comp-known-predicate-p) fun)
- ,op))
- ;; (comment ,_comment-str)
- (cond-jump ,cmp-res ,(pred comp-mvar-p) . ,blocks))
- (cl-loop
- with target-mvar = (comp-cond-cstrs-target-mvar op (car insns-seq) b)
- with cstr = (comp-pred-to-cstr fun)
- for branch-target-cell on blocks
- for branch-target = (car branch-target-cell)
- for negated in '(t nil)
- when (comp-mvar-used-p target-mvar)
- do
- (let ((block-target (comp-add-cond-cstrs-target-block b branch-target)))
- (setf (car branch-target-cell) (comp-block-name block-target))
- (comp-emit-assume 'and target-mvar cstr block-target negated))
- finally (cl-return-from in-the-basic-block)))
- ;; Match predicate on the negated branch (unless).
- (`((set ,(and (pred comp-mvar-p) cmp-res)
- (,(pred comp-call-op-p)
- ,(and (pred comp-known-predicate-p) fun)
+ (,(pred comp--call-op-p)
+ ,(and (pred comp--known-predicate-p) fun)
,op))
- (set ,neg-cmp-res (call eq ,cmp-res ,(pred comp-cstr-null-p)))
- (cond-jump ,neg-cmp-res ,(pred comp-mvar-p) . ,blocks))
+ . ,(or
+ ;; (comment ,_comment-str)
+ (and `((cond-jump ,cmp-res ,(pred comp-mvar-p) . ,blocks))
+ (let negated-branch nil))
+ (and `((set ,neg-cmp-res
+ (call eq ,cmp-res ,(pred comp-cstr-null-p)))
+ (cond-jump ,neg-cmp-res ,(pred comp-mvar-p) . ,blocks))
+ (let negated-branch t))))
(cl-loop
- with target-mvar = (comp-cond-cstrs-target-mvar op (car insns-seq) b)
- with cstr = (comp-pred-to-cstr fun)
+ with target-mvar = (comp--cond-cstrs-target-mvar op (car insns-seq) b)
for branch-target-cell on blocks
for branch-target = (car branch-target-cell)
- for negated in '(nil t)
- when (comp-mvar-used-p target-mvar)
+ for negated in (if negated-branch '(nil t) '(t nil))
+ when (comp--mvar-used-p target-mvar)
do
- (let ((block-target (comp-add-cond-cstrs-target-block b branch-target)))
+ (let ((block-target (comp--add-cond-cstrs-target-block
+ b branch-target)))
(setf (car branch-target-cell) (comp-block-name block-target))
- (comp-emit-assume 'and target-mvar cstr block-target negated))
+ (comp--emit-assume 'and target-mvar (if negated
+ (comp--pred-to-neg-cstr fun)
+ (comp--pred-to-pos-cstr fun))
+ block-target nil))
finally (cl-return-from in-the-basic-block))))
(setf prev-insns-seq insns-seq))))
-(defsubst comp-insert-insn (insn insn-cell)
+(defsubst comp--insert-insn (insn insn-cell)
"Insert INSN as second insn of INSN-CELL."
(let ((next-cell (cdr insn-cell))
(new-cell `(,insn)))
@@ -2613,15 +2069,15 @@ TARGET-BB-SYM is the symbol name of the target block."
(cdr new-cell) next-cell
(comp-func-ssa-status comp-func) 'dirty)))
-(defun comp-emit-call-cstr (mvar call-cell cstr)
+(defun comp--emit-call-cstr (mvar call-cell cstr)
"Emit a constraint CSTR for MVAR after CALL-CELL."
- (let* ((new-mvar (make-comp-mvar :slot (comp-mvar-slot mvar)))
+ (let* ((new-mvar (make--comp-mvar :slot (comp-mvar-slot mvar)))
;; Have new-mvar as LHS *and* RHS to ensure monotonicity and
;; fwprop convergence!!
(insn `(assume ,new-mvar (and ,new-mvar ,mvar ,cstr))))
- (comp-insert-insn insn call-cell)))
+ (comp--insert-insn insn call-cell)))
-(defun comp-lambda-list-gen (lambda-list)
+(defun comp--lambda-list-gen (lambda-list)
"Return a generator to iterate over LAMBDA-LIST."
(lambda ()
(cl-case (car lambda-list)
@@ -2637,26 +2093,26 @@ TARGET-BB-SYM is the symbol name of the target block."
(car lambda-list)
(setf lambda-list (cdr lambda-list)))))))
-(defun comp-add-call-cstr ()
+(defun comp--add-call-cstr ()
"Add args assumptions for each function of which the type specifier is known."
(cl-loop
for bb being each hash-value of (comp-func-blocks comp-func)
do
- (comp-loop-insn-in-block bb
+ (comp--loop-insn-in-block bb
(when-let ((match
(pcase insn
- (`(set ,lhs (,(pred comp-call-op-p) ,f . ,args))
+ (`(set ,lhs (,(pred comp--call-op-p) ,f . ,args))
(when-let ((cstr-f (gethash f comp-known-func-cstr-h)))
(cl-values f cstr-f lhs args)))
- (`(,(pred comp-call-op-p) ,f . ,args)
+ (`(,(pred comp--call-op-p) ,f . ,args)
(when-let ((cstr-f (gethash f comp-known-func-cstr-h)))
(cl-values f cstr-f nil args))))))
(cl-multiple-value-bind (f cstr-f lhs args) match
(cl-loop
- with gen = (comp-lambda-list-gen (comp-cstr-f-args cstr-f))
+ with gen = (comp--lambda-list-gen (comp-cstr-f-args cstr-f))
for arg in args
for cstr = (funcall gen)
- for target = (comp-cond-cstrs-target-mvar arg insn bb)
+ for target = (comp--cond-cstrs-target-mvar arg insn bb)
unless (comp-cstr-p cstr)
do (signal 'native-ice
(list "Incoherent type specifier for function" f))
@@ -2667,9 +2123,9 @@ TARGET-BB-SYM is the symbol name of the target block."
(or (null lhs)
(not (eql (comp-mvar-slot lhs)
(comp-mvar-slot target)))))
- do (comp-emit-call-cstr target insn-cell cstr)))))))
+ do (comp--emit-call-cstr target insn-cell cstr)))))))
-(defun comp-add-cstrs (_)
+(defun comp--add-cstrs (_)
"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
@@ -2683,11 +2139,11 @@ blocks."
(not (comp-func-has-non-local f)))
(let ((comp-func f)
(comp-pass (make-hash-table :test #'eq)))
- (comp-collect-rhs)
- (comp-add-cond-cstrs-simple)
- (comp-add-cond-cstrs)
- (comp-add-call-cstr)
- (comp-log-func comp-func 3))))
+ (comp--collect-rhs)
+ (comp--add-cond-cstrs-simple)
+ (comp--add-cond-cstrs)
+ (comp--add-call-cstr)
+ (comp--log-func comp-func 3))))
(comp-ctxt-funcs-h comp-ctxt)))
@@ -2698,7 +2154,7 @@ blocks."
;; avoid optimizing-out functions and preventing their redefinition
;; being effective.
-(defun comp-collect-calls (f)
+(defun comp--collect-calls (f)
"Return a list with all the functions called by F."
(cl-loop
with h = (make-hash-table :test #'eq)
@@ -2706,9 +2162,9 @@ blocks."
do (cl-loop
for insn in (comp-block-insns b)
do (pcase insn
- (`(set ,_lval (,(pred comp-call-op-p) ,f . ,_rest))
+ (`(set ,_lval (,(pred comp--call-op-p) ,f . ,_rest))
(puthash f t h))
- (`(,(pred comp-call-op-p) ,f . ,_rest)
+ (`(,(pred comp--call-op-p) ,f . ,_rest)
(puthash f t h))))
finally return (cl-loop
for f being each hash-key of h
@@ -2718,17 +2174,17 @@ blocks."
(comp-ctxt-funcs-h comp-ctxt)))
f))))
-(defun comp-pure-infer-func (f)
+(defun comp--pure-infer-func (f)
"If all functions called by F are pure then F is pure too."
(when (and (cl-every (lambda (x)
- (or (comp-function-pure-p x)
+ (or (comp--function-pure-p x)
(eq x (comp-func-name f))))
- (comp-collect-calls f))
+ (comp--collect-calls f))
(not (eq (comp-func-pure f) t)))
(comp-log (format "%s inferred to be pure" (comp-func-name f)))
(setf (comp-func-pure f) t)))
-(defun comp-ipa-pure (_)
+(defun comp--ipa-pure (_)
"Infer function purity."
(cl-loop
with pure-n = 0
@@ -2741,7 +2197,7 @@ blocks."
when (and (>= (comp-func-speed f) 3)
(comp-func-l-p f)
(not (comp-func-pure f)))
- do (comp-pure-infer-func f)
+ do (comp--pure-infer-func f)
count (comp-func-pure f))))
finally (comp-log (format "ipa-pure iterated %d times" n))))
@@ -2755,13 +2211,13 @@ blocks."
;; this form is called 'minimal SSA form'.
;; This pass should be run every time basic blocks or m-var are shuffled.
-(cl-defun make-comp-ssa-mvar (&rest rest &key _slot _constant _type)
- "Same as `make-comp-mvar' but set the `id' slot."
- (let ((mvar (apply #'make-comp-mvar rest)))
+(cl-defun make--comp--ssa-mvar (&rest rest &key _slot _constant _type)
+ "Same as `make--comp-mvar' but set the `id' slot."
+ (let ((mvar (apply #'make--comp-mvar rest)))
(setf (comp-mvar-id mvar) (sxhash-eq mvar))
mvar))
-(defun comp-clean-ssa (f)
+(defun comp--clean-ssa (f)
"Clean-up SSA for function F."
(setf (comp-func-edges-h f) (make-hash-table))
(cl-loop
@@ -2777,7 +2233,7 @@ blocks."
unless (eq 'phi (car insn))
collect insn))))
-(defun comp-compute-edges ()
+(defun comp--compute-edges ()
"Compute the basic block edges for the current function."
(cl-loop with blocks = (comp-func-blocks comp-func)
for bb being each hash-value of blocks
@@ -2785,16 +2241,16 @@ blocks."
for (op first second third forth) = last-insn
do (cl-case op
(jump
- (make-comp-edge :src bb :dst (gethash first blocks)))
+ (comp--edge-make :src bb :dst (gethash first blocks)))
(cond-jump
- (make-comp-edge :src bb :dst (gethash third blocks))
- (make-comp-edge :src bb :dst (gethash forth blocks)))
+ (comp--edge-make :src bb :dst (gethash third blocks))
+ (comp--edge-make :src bb :dst (gethash forth blocks)))
(cond-jump-narg-leq
- (make-comp-edge :src bb :dst (gethash second blocks))
- (make-comp-edge :src bb :dst (gethash third blocks)))
+ (comp--edge-make :src bb :dst (gethash second blocks))
+ (comp--edge-make :src bb :dst (gethash third blocks)))
(push-handler
- (make-comp-edge :src bb :dst (gethash third blocks))
- (make-comp-edge :src bb :dst (gethash forth blocks)))
+ (comp--edge-make :src bb :dst (gethash third blocks))
+ (comp--edge-make :src bb :dst (gethash forth blocks)))
(return)
(unreachable)
(otherwise
@@ -2811,9 +2267,9 @@ blocks."
(comp-block-out-edges (comp-edge-src edge)))
(push edge
(comp-block-in-edges (comp-edge-dst edge))))
- (comp-log-edges comp-func)))
+ (comp--log-edges comp-func)))
-(defun comp-collect-rev-post-order (basic-block)
+(defun comp--collect-rev-post-order (basic-block)
"Walk BASIC-BLOCK children and return their name in reversed post-order."
(let ((visited (make-hash-table))
(acc ()))
@@ -2828,7 +2284,7 @@ blocks."
(collect-rec basic-block)
acc)))
-(defun comp-compute-dominator-tree ()
+(defun comp--compute-dominator-tree ()
"Compute immediate dominators for each basic block in current function."
;; Originally based on: "A Simple, Fast Dominance Algorithm"
;; Cooper, Keith D.; Harvey, Timothy J.; Kennedy, Ken (2001).
@@ -2844,16 +2300,16 @@ blocks."
finger2 (comp-block-post-num b2))))
b1))
(first-processed (l)
- (if-let ((p (cl-find-if (lambda (p) (comp-block-idom p)) l)))
+ (if-let ((p (cl-find-if #'comp-block-idom l)))
p
- (signal 'native-ice "can't find first preprocessed"))))
+ (signal 'native-ice '("can't find first preprocessed")))))
(when-let ((blocks (comp-func-blocks comp-func))
(entry (gethash 'entry blocks))
;; No point to go on if the only bb is 'entry'.
(bb0 (gethash 'bb_0 blocks)))
(cl-loop
- with rev-bb-list = (comp-collect-rev-post-order entry)
+ with rev-bb-list = (comp--collect-rev-post-order entry)
with changed = t
while changed
initially (progn
@@ -2867,7 +2323,7 @@ blocks."
do (cl-loop
for name in (cdr rev-bb-list)
for b = (gethash name blocks)
- for preds = (comp-block-preds b)
+ for preds = (comp--block-preds b)
for new-idom = (first-processed preds)
initially (setf changed nil)
do (cl-loop for p in (delq new-idom preds)
@@ -2880,14 +2336,14 @@ blocks."
new-idom)
changed t))))))
-(defun comp-compute-dominator-frontiers ()
+(defun comp--compute-dominator-frontiers ()
"Compute the dominator frontier for each basic block in `comp-func'."
;; Originally based on: "A Simple, Fast Dominance Algorithm"
;; Cooper, Keith D.; Harvey, Timothy J.; Kennedy, Ken (2001).
(cl-loop with blocks = (comp-func-blocks comp-func)
for b-name being each hash-keys of blocks
using (hash-value b)
- for preds = (comp-block-preds b)
+ for preds = (comp--block-preds b)
when (length> preds 1) ; All joins
do (cl-loop for p in preds
for runner = p
@@ -2895,7 +2351,7 @@ blocks."
(puthash b-name b (comp-block-df runner))
(setf runner (comp-block-idom runner))))))
-(defun comp-log-block-info ()
+(defun comp--log-block-info ()
"Log basic blocks info for the current function."
(maphash (lambda (name bb)
(let ((dom (comp-block-idom bb))
@@ -2908,7 +2364,7 @@ blocks."
3)))
(comp-func-blocks comp-func)))
-(defun comp-place-phis ()
+(defun comp--place-phis ()
"Place phi insns into the current function."
;; Originally based on: Static Single Assignment Book
;; Algorithm 3.1: Standard algorithm for inserting phi-functions
@@ -2919,7 +2375,7 @@ blocks."
;; Return t if a SLOT-N was assigned within BB.
(cl-loop for insn in (comp-block-insns bb)
for op = (car insn)
- when (or (and (comp-assign-op-p op)
+ when (or (and (comp--assign-op-p op)
(eql slot-n (comp-mvar-slot (cadr insn))))
;; fetch-handler is after a non local
;; therefore clobbers all frame!!!
@@ -2949,7 +2405,7 @@ blocks."
(unless (cl-find y defs-v)
(push y w))))))))
-(defun comp-dom-tree-walker (bb pre-lambda post-lambda)
+(defun comp--dom-tree-walker (bb pre-lambda post-lambda)
"Dominator tree walker function starting from basic block BB.
PRE-LAMBDA and POST-LAMBDA are called in pre or post-order if non-nil."
(when pre-lambda
@@ -2959,18 +2415,18 @@ PRE-LAMBDA and POST-LAMBDA are called in pre or post-order if non-nil."
for child = (comp-edge-dst ed)
when (eq bb (comp-block-idom child))
;; Current block is the immediate dominator then recur.
- do (comp-dom-tree-walker child pre-lambda post-lambda)))
+ do (comp--dom-tree-walker child pre-lambda post-lambda)))
(when post-lambda
(funcall post-lambda bb)))
-(cl-defstruct (comp-ssa (:copier nil))
+(cl-defstruct (comp--ssa (:copier nil))
"Support structure used while SSA renaming."
- (frame (comp-new-frame (comp-func-frame-size comp-func)
+ (frame (comp--new-frame (comp-func-frame-size comp-func)
(comp-func-vframe-size comp-func) t)
:type comp-vec
:documentation "`comp-vec' of m-vars."))
-(defun comp-ssa-rename-insn (insn frame)
+(defun comp--ssa-rename-insn (insn frame)
(cl-loop
for slot-n from (- (comp-func-vframe-size comp-func))
below (comp-func-frame-size comp-func)
@@ -2981,17 +2437,19 @@ PRE-LAMBDA and POST-LAMBDA are called in pre or post-order if non-nil."
(eql slot-n (comp-mvar-slot x))))
(new-lvalue ()
;; If is an assignment make a new mvar and put it as l-value.
- (let ((mvar (make-comp-ssa-mvar :slot slot-n)))
+ (let ((mvar (make--comp--ssa-mvar :slot slot-n)))
(setf (comp-vec-aref frame slot-n) mvar
(cadr insn) mvar))))
(pcase insn
- (`(,(pred comp-assign-op-p) ,(pred targetp) . ,_)
+ (`(setimm ,(pred targetp) ,_imm)
+ (new-lvalue))
+ (`(,(pred comp--assign-op-p) ,(pred targetp) . ,_)
(let ((mvar (comp-vec-aref frame slot-n)))
(setf (cddr insn) (cl-nsubst-if mvar #'targetp (cddr insn))))
(new-lvalue))
(`(fetch-handler . ,_)
;; Clobber all no matter what!
- (setf (comp-vec-aref frame slot-n) (make-comp-ssa-mvar :slot slot-n)))
+ (setf (comp-vec-aref frame slot-n) (make--comp--ssa-mvar :slot slot-n)))
(`(phi ,n)
(when (equal n slot-n)
(new-lvalue)))
@@ -2999,7 +2457,7 @@ PRE-LAMBDA and POST-LAMBDA are called in pre or post-order if non-nil."
(let ((mvar (comp-vec-aref frame slot-n)))
(setcdr insn (cl-nsubst-if mvar #'targetp (cdr insn)))))))))
-(defun comp-ssa-rename ()
+(defun comp--ssa-rename ()
"Entry point to rename into SSA within the current function."
(comp-log "Renaming\n" 2)
(let ((visited (make-hash-table)))
@@ -3007,7 +2465,7 @@ PRE-LAMBDA and POST-LAMBDA are called in pre or post-order if non-nil."
(unless (gethash bb visited)
(puthash bb t visited)
(cl-loop for insn in (comp-block-insns bb)
- do (comp-ssa-rename-insn insn in-frame))
+ do (comp--ssa-rename-insn insn in-frame))
(setf (comp-block-final-frame bb)
(copy-sequence in-frame))
(when-let ((out-edges (comp-block-out-edges bb)))
@@ -3018,11 +2476,11 @@ PRE-LAMBDA and POST-LAMBDA are called in pre or post-order if non-nil."
do (ssa-rename-rec child (comp-vec-copy in-frame)))))))
(ssa-rename-rec (gethash 'entry (comp-func-blocks comp-func))
- (comp-new-frame (comp-func-frame-size comp-func)
+ (comp--new-frame (comp-func-frame-size comp-func)
(comp-func-vframe-size comp-func)
t)))))
-(defun comp-finalize-phis ()
+(defun comp--finalize-phis ()
"Fixup r-values into phis in all basic blocks."
(cl-flet ((finalize-phi (args b)
;; Concatenate into args all incoming m-vars for this phi.
@@ -3039,7 +2497,7 @@ PRE-LAMBDA and POST-LAMBDA are called in pre or post-order if non-nil."
when (eq op 'phi)
do (finalize-phi args b)))))
-(defun comp-remove-unreachable-blocks ()
+(defun comp--remove-unreachable-blocks ()
"Remove unreachable basic blocks.
Return t when one or more block was removed, nil otherwise."
(cl-loop
@@ -3055,7 +2513,7 @@ Return t when one or more block was removed, nil otherwise."
ret t)
finally return ret))
-(defun comp-ssa ()
+(defun comp--ssa ()
"Port all functions into minimal SSA form."
(maphash (lambda (_ f)
(let* ((comp-func f)
@@ -3063,16 +2521,16 @@ Return t when one or more block was removed, nil otherwise."
(unless (eq ssa-status t)
(cl-loop
when (eq ssa-status 'dirty)
- do (comp-clean-ssa f)
- do (comp-compute-edges)
- (comp-compute-dominator-tree)
- until (null (comp-remove-unreachable-blocks)))
- (comp-compute-dominator-frontiers)
- (comp-log-block-info)
- (comp-place-phis)
- (comp-ssa-rename)
- (comp-finalize-phis)
- (comp-log-func comp-func 3)
+ do (comp--clean-ssa f)
+ do (comp--compute-edges)
+ (comp--compute-dominator-tree)
+ until (null (comp--remove-unreachable-blocks)))
+ (comp--compute-dominator-frontiers)
+ (comp--log-block-info)
+ (comp--place-phis)
+ (comp--ssa-rename)
+ (comp--finalize-phis)
+ (comp--log-func comp-func 3)
(setf (comp-func-ssa-status f) t))))
(comp-ctxt-funcs-h comp-ctxt)))
@@ -3083,12 +2541,12 @@ Return t when one or more block was removed, nil otherwise."
;; This is also responsible for removing function calls to pure functions if
;; possible.
-(defconst comp-fwprop-max-insns-scan 4500
+(defconst comp--fwprop-max-insns-scan 4500
;; Chosen as ~ the greatest required value for full convergence
;; native compiling all Emacs code-base.
"Max number of scanned insn before giving-up.")
-(defun comp-copy-insn (insn)
+(defun comp--copy-insn-rec (insn)
"Deep copy INSN."
;; Adapted from `copy-tree'.
(if (consp insn)
@@ -3096,16 +2554,23 @@ Return t when one or more block was removed, nil otherwise."
(while (consp insn)
(let ((newcar (car insn)))
(if (or (consp (car insn)) (comp-mvar-p (car insn)))
- (setf newcar (comp-copy-insn (car insn))))
+ (setf newcar (comp--copy-insn (car insn))))
(push newcar result))
(setf insn (cdr insn)))
(nconc (nreverse result)
- (if (comp-mvar-p insn) (comp-copy-insn insn) insn)))
+ (if (comp-mvar-p insn) (comp--copy-insn insn) insn)))
(if (comp-mvar-p insn)
(copy-comp-mvar insn)
insn)))
-(defmacro comp-apply-in-env (func &rest args)
+(defun comp--copy-insn (insn)
+ "Deep copy INSN."
+ (pcase insn
+ (`(setimm ,mvar ,imm)
+ `(setimm ,(copy-comp-mvar mvar) ,imm))
+ (_ (comp--copy-insn-rec insn))))
+
+(defmacro comp--apply-in-env (func &rest args)
"Apply FUNC to ARGS in the current compilation environment."
`(let ((env (cl-loop
for f being the hash-value in (comp-ctxt-funcs-h comp-ctxt)
@@ -3121,7 +2586,7 @@ Return t when one or more block was removed, nil otherwise."
for (func-name . def) in env
do (setf (symbol-function func-name) def)))))
-(defun comp-fwprop-prologue ()
+(defun comp--fwprop-prologue ()
"Prologue for the propagate pass.
Here goes everything that can be done not iteratively (read once).
Forward propagate immediate involed in assignments." ; FIXME: Typo. Involved or invoked?
@@ -3133,17 +2598,17 @@ Forward propagate immediate involed in assignments." ; FIXME: Typo. Involved or
(`(setimm ,lval ,v)
(setf (comp-cstr-imm lval) v))))))
-(defun comp-function-foldable-p (f args)
+(defun comp--function-foldable-p (f args)
"Given function F called with ARGS, return non-nil when optimizable."
- (and (comp-function-pure-p f)
+ (and (comp--function-pure-p f)
(cl-every #'comp-cstr-imm-vld-p args)))
-(defun comp-function-call-maybe-fold (insn f args)
+(defun comp--function-call-maybe-fold (insn f args)
"Given INSN, when F is pure if all ARGS are known, remove the function call.
Return non-nil if the function is folded successfully."
(cl-flet ((rewrite-insn-as-setimm (insn value)
- ;; See `comp-emit-setimm'.
- (comp-add-const-to-relocs value)
+ ;; See `comp--emit-setimm'.
+ (comp--add-const-to-relocs value)
(setf (car insn) 'setimm
(cddr insn) `(,value))))
(cond
@@ -3154,25 +2619,25 @@ Return non-nil if the function is folded successfully."
comp-symbol-values-optimizable)))
(rewrite-insn-as-setimm insn (symbol-value (comp-cstr-imm
(car args))))))
- ((comp-function-foldable-p f args)
+ ((comp--function-foldable-p f args)
(ignore-errors
;; No point to complain here in case of error because we
;; should do basic block pruning in order to be sure that this
;; is not dead-code. This is now left to gcc, to be
;; implemented only if we want a reliable diagnostic here.
- (let* ((f (if-let (f-in-ctxt (comp-symbol-func-to-fun f))
+ (let* ((f (if-let (f-in-ctxt (comp--symbol-func-to-fun f))
;; If the function is IN the compilation ctxt
;; and know to be pure.
(comp-func-byte-func f-in-ctxt)
f))
- (value (comp-apply-in-env f (mapcar #'comp-cstr-imm args))))
+ (value (comp--apply-in-env f (mapcar #'comp-cstr-imm args))))
(rewrite-insn-as-setimm insn value)))))))
-(defun comp-fwprop-call (insn lval f args)
+(defun comp--fwprop-call (insn lval f args)
"Propagate on a call INSN into LVAL.
F is the function being called with arguments ARGS.
Fold the call in case."
- (unless (comp-function-call-maybe-fold insn f args)
+ (unless (comp--function-call-maybe-fold insn f args)
(when (and (eq 'funcall f)
(comp-cstr-imm-vld-p (car args)))
(setf f (comp-cstr-imm (car args))
@@ -3187,21 +2652,27 @@ Fold the call in case."
(+ (comp-cstr-add lval args))
(- (comp-cstr-sub lval args))
(1+ (comp-cstr-add lval `(,(car args) ,comp-cstr-one)))
- (1- (comp-cstr-sub lval `(,(car args) ,comp-cstr-one))))))
+ (1- (comp-cstr-sub lval `(,(car args) ,comp-cstr-one)))
+ (record (when (comp-cstr-imm-vld-p (car args))
+ (comp-cstr-shallow-copy lval
+ (comp-type-spec-to-cstr
+ (comp-cstr-imm (car args)))))))))
-(defun comp-fwprop-insn (insn)
+(defun comp--fwprop-insn (insn)
"Propagate within INSN."
(pcase insn
(`(set ,lval ,rval)
(pcase rval
(`(,(or 'call 'callref) ,f . ,args)
- (comp-fwprop-call insn lval f args))
+ (comp--fwprop-call insn lval f args))
(`(,(or 'direct-call 'direct-callref) ,f . ,args)
(let ((f (comp-func-name (gethash f (comp-ctxt-funcs-h comp-ctxt)))))
- (comp-fwprop-call insn lval f args)))
+ (comp--fwprop-call insn lval f args)))
(_
(comp-cstr-shallow-copy lval rval))))
(`(assume ,lval ,(and (pred comp-mvar-p) rval))
+ ;; NOTE we should probably assert this case in the future when
+ ;; will be possible.
(comp-cstr-shallow-copy lval rval))
(`(assume ,lval (,kind . ,operands))
(cl-case kind
@@ -3233,7 +2704,7 @@ Fold the call in case."
(comp-func-blocks comp-func))))
(or (comp-latch-p bb)
(when (comp-block-cstr-p bb)
- (comp-latch-p (car (comp-block-preds bb)))))))
+ (comp-latch-p (car (comp--block-preds bb)))))))
rest))
(prop-fn (if from-latch
#'comp-cstr-union-no-range
@@ -3241,7 +2712,7 @@ Fold the call in case."
(rvals (mapcar #'car rest)))
(apply prop-fn lval rvals)))))
-(defun comp-fwprop* ()
+(defun comp--fwprop* ()
"Propagate for set* and phi operands.
Return t if something was changed."
(cl-loop named outer
@@ -3253,17 +2724,17 @@ Return t if something was changed."
for insn in (comp-block-insns b)
for orig-insn = (unless modified
;; Save consing after 1st change.
- (comp-copy-insn insn))
+ (comp--copy-insn insn))
do
- (comp-fwprop-insn insn)
+ (comp--fwprop-insn insn)
(cl-incf i)
when (and (null modified) (not (equal insn orig-insn)))
do (setf modified t))
- when (> i comp-fwprop-max-insns-scan)
+ when (> i comp--fwprop-max-insns-scan)
do (cl-return-from outer nil)
finally return modified))
-(defun comp-rewrite-non-locals ()
+(defun comp--rewrite-non-locals ()
"Make explicit in LIMPLE non-local exits if identified."
(cl-loop
for bb being each hash-value of (comp-func-blocks comp-func)
@@ -3280,27 +2751,27 @@ Return t if something was changed."
(cdr insn-seq) '((unreachable))
(comp-func-ssa-status comp-func) 'dirty))))
-(defun comp-fwprop (_)
+(defun comp--fwprop (_)
"Forward propagate types and consts within the lattice."
- (comp-ssa)
- (comp-dead-code)
+ (comp--ssa)
+ (comp--dead-code)
(maphash (lambda (_ f)
(when (and (>= (comp-func-speed f) 2)
;; FIXME remove the following condition when tested.
(not (comp-func-has-non-local f)))
(let ((comp-func f))
- (comp-fwprop-prologue)
+ (comp--fwprop-prologue)
(cl-loop
for i from 1 to 100
- while (comp-fwprop*)
+ while (comp--fwprop*)
finally
(when (= i 100)
(display-warning
'comp
(format "fwprop pass jammed into %s?" (comp-func-name f))))
(comp-log (format "Propagation run %d times\n" i) 2))
- (comp-rewrite-non-locals)
- (comp-log-func comp-func 3))))
+ (comp--rewrite-non-locals)
+ (comp--log-func comp-func 3))))
(comp-ctxt-funcs-h comp-ctxt)))
@@ -3319,19 +2790,19 @@ Return t if something was changed."
;; the full compilation unit.
;; For this reason this is triggered only at native-comp-speed == 3.
-(defun comp-func-in-unit (func)
+(defun comp--func-in-unit (func)
"Given FUNC return the `comp-fun' definition in the current context.
FUNCTION can be a function-name or byte compiled function."
(if (symbolp func)
- (comp-symbol-func-to-fun func)
+ (comp--symbol-func-to-fun func)
(cl-assert (byte-code-function-p func))
(gethash func (comp-ctxt-byte-func-to-func-h comp-ctxt))))
-(defun comp-call-optim-form-call (callee args)
+(defun comp--call-optim-form-call (callee args)
(cl-flet ((fill-args (args total)
;; Fill missing args to reach TOTAL
(append args (cl-loop repeat (- total (length args))
- collect (make-comp-mvar :constant nil)))))
+ collect (make--comp-mvar :constant nil)))))
(when (and callee
(or (symbolp callee)
(gethash callee (comp-ctxt-byte-func-to-func-h comp-ctxt)))
@@ -3340,8 +2811,16 @@ FUNCTION can be a function-name or byte compiled function."
(symbol-function callee)
(cl-assert (byte-code-function-p callee))
callee))
+ ;; Below call to `subrp' returns nil on an advised
+ ;; primitive F, so that we do not optimize calls to F
+ ;; with the funcall trampoline removal below. But if F
+ ;; is advised while we compile its call, it is very
+ ;; likely to be advised also when that call is executed.
+ ;; And in that case an "unoptimized" call to F is
+ ;; actually cheaper since it avoids the call to the
+ ;; intermediate native trampoline (bug#67005).
(subrp (subrp f))
- (comp-func-callee (comp-func-in-unit callee)))
+ (comp-func-callee (comp--func-in-unit callee)))
(cond
((and subrp (not (subr-native-elisp-p f)))
;; Trampoline removal.
@@ -3361,7 +2840,7 @@ FUNCTION can be a function-name or byte compiled function."
((and comp-func-callee
(comp-func-c-name comp-func-callee)
(or (and (>= (comp-func-speed comp-func) 3)
- (comp-func-unique-in-cu-p callee))
+ (comp--func-unique-in-cu-p callee))
(and (>= (comp-func-speed comp-func) 2)
;; Anonymous lambdas can't be redefined so are
;; always safe to optimize.
@@ -3373,33 +2852,33 @@ FUNCTION can be a function-name or byte compiled function."
args
(fill-args args (comp-args-max func-args)))))
`(,call-type ,(comp-func-c-name comp-func-callee) ,@args)))
- ((comp-type-hint-p callee)
+ ((comp--type-hint-p callee)
`(call ,callee ,@args)))))))
-(defun comp-call-optim-func ()
+(defun comp--call-optim-func ()
"Perform the trampoline call optimization for the current function."
(cl-loop
for b being each hash-value of (comp-func-blocks comp-func)
- do (comp-loop-insn-in-block b
+ do (comp--loop-insn-in-block b
(pcase insn
(`(set ,lval (callref funcall ,f . ,rest))
(when-let ((ok (comp-cstr-imm-vld-p f))
- (new-form (comp-call-optim-form-call
+ (new-form (comp--call-optim-form-call
(comp-cstr-imm f) rest)))
(setf insn `(set ,lval ,new-form))))
(`(callref funcall ,f . ,rest)
(when-let ((ok (comp-cstr-imm-vld-p f))
- (new-form (comp-call-optim-form-call
+ (new-form (comp--call-optim-form-call
(comp-cstr-imm f) rest)))
(setf insn new-form)))))))
-(defun comp-call-optim (_)
+(defun comp--call-optim (_)
"Try to optimize out funcall trampoline usage when possible."
(maphash (lambda (_ f)
(when (and (>= (comp-func-speed f) 2)
(comp-func-l-p f))
(let ((comp-func f))
- (comp-call-optim-func))))
+ (comp--call-optim-func))))
(comp-ctxt-funcs-h comp-ctxt)))
@@ -3410,16 +2889,16 @@ FUNCTION can be a function-name or byte compiled function."
;;
;; This pass can be run as last optim.
-(defun comp-collect-mvar-ids (insn)
+(defun comp--collect-mvar-ids (insn)
"Collect the m-var unique identifiers into INSN."
(cl-loop for x in insn
if (consp x)
- append (comp-collect-mvar-ids x)
+ append (comp--collect-mvar-ids x)
else
when (comp-mvar-p x)
collect (comp-mvar-id x)))
-(defun comp-dead-assignments-func ()
+(defun comp--dead-assignments-func ()
"Clean-up dead assignments into current function.
Return the list of m-var ids nuked."
(let ((l-vals ())
@@ -3430,11 +2909,12 @@ Return the list of m-var ids nuked."
do (cl-loop
for insn in (comp-block-insns b)
for (op arg0 . rest) = insn
- if (comp-assign-op-p op)
+ if (comp--assign-op-p op)
do (push (comp-mvar-id arg0) l-vals)
- (setf r-vals (nconc (comp-collect-mvar-ids rest) r-vals))
+ (unless (eq op 'setimm)
+ (setf r-vals (nconc (comp--collect-mvar-ids rest) r-vals)))
else
- do (setf r-vals (nconc (comp-collect-mvar-ids insn) r-vals))))
+ do (setf r-vals (nconc (comp--collect-mvar-ids insn) r-vals))))
;; Every l-value appearing that does not appear as r-value has no right to
;; exist and gets nuked.
(let ((nuke-list (cl-set-difference l-vals r-vals)))
@@ -3446,18 +2926,18 @@ Return the list of m-var ids nuked."
3)
(cl-loop
for b being each hash-value of (comp-func-blocks comp-func)
- do (comp-loop-insn-in-block b
+ do (comp--loop-insn-in-block b
(cl-destructuring-bind (op &optional arg0 arg1 &rest rest) insn
- (when (and (comp-assign-op-p op)
+ (when (and (comp--assign-op-p op)
(memq (comp-mvar-id arg0) nuke-list))
(setf insn
- (if (comp-limple-insn-call-p arg1)
+ (if (comp--limple-insn-call-p arg1)
arg1
`(comment ,(format "optimized out: %s"
insn))))))))
nuke-list)))
-(defun comp-dead-code ()
+(defun comp--dead-code ()
"Dead code elimination."
(maphash (lambda (_ f)
(when (and (>= (comp-func-speed f) 2)
@@ -3466,22 +2946,22 @@ Return the list of m-var ids nuked."
(cl-loop
for comp-func = f
for i from 1
- while (comp-dead-assignments-func)
+ while (comp--dead-assignments-func)
finally (comp-log (format "dead code rm run %d times\n" i) 2)
- (comp-log-func comp-func 3))))
+ (comp--log-func comp-func 3))))
(comp-ctxt-funcs-h comp-ctxt)))
;;; Tail Call Optimization pass specific code.
-(defun comp-form-tco-call-seq (args)
+(defun comp--form-tco-call-seq (args)
"Generate a TCO sequence for ARGS."
`(,@(cl-loop for arg in args
for i from 0
- collect `(set ,(make-comp-mvar :slot i) ,arg))
+ collect `(set ,(make--comp-mvar :slot i) ,arg))
(jump bb_0)))
-(defun comp-tco-func ()
+(defun comp--tco-func ()
"Try to pattern match and perform TCO within the current function."
(cl-loop
for b being each hash-value of (comp-func-blocks comp-func)
@@ -3494,21 +2974,21 @@ Return the list of m-var ids nuked."
(return ,ret-val))
(when (and (string= func (comp-func-c-name comp-func))
(eq l-val ret-val))
- (let ((tco-seq (comp-form-tco-call-seq args)))
+ (let ((tco-seq (comp--form-tco-call-seq args)))
(setf (car insns-seq) (car tco-seq)
(cdr insns-seq) (cdr tco-seq)
(comp-func-ssa-status comp-func) 'dirty)
(cl-return-from in-the-basic-block))))))))
-(defun comp-tco (_)
+(defun comp--tco (_)
"Simple peephole pass performing self TCO."
(maphash (lambda (_ f)
(when (and (>= (comp-func-speed f) 3)
(comp-func-l-p f)
(not (comp-func-has-non-local f)))
(let ((comp-func f))
- (comp-tco-func)
- (comp-log-func comp-func 3))))
+ (comp--tco-func)
+ (comp--log-func comp-func 3))))
(comp-ctxt-funcs-h comp-ctxt)))
@@ -3517,54 +2997,88 @@ Return the list of m-var ids nuked."
;; This must run after all SSA prop not to have the type hint
;; information overwritten.
-(defun comp-remove-type-hints-func ()
+(defun comp--remove-type-hints-func ()
"Remove type hints from the current function.
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
+ do (comp--loop-insn-in-block b
(pcase insn
- (`(set ,l-val (call ,(pred comp-type-hint-p) ,r-val))
+ (`(set ,l-val (call ,(pred comp--type-hint-p) ,r-val))
(setf insn `(set ,l-val ,r-val)))))))
-(defun comp-remove-type-hints (_)
+(defun comp--remove-type-hints (_)
"Dead code elimination."
(maphash (lambda (_ f)
(when (>= (comp-func-speed f) 2)
(let ((comp-func f))
- (comp-remove-type-hints-func)
- (comp-log-func comp-func 3))))
+ (comp--remove-type-hints-func)
+ (comp--log-func comp-func 3))))
(comp-ctxt-funcs-h comp-ctxt)))
-;;; Final pass specific code.
+;;; Sanitizer pass specific code.
-(defun comp-args-to-lambda-list (args)
- "Return a lambda list for ARGS."
- (cl-loop
- with res
- repeat (comp-args-base-min args)
- do (push t res)
- finally
- (if (comp-args-p args)
- (cl-loop
- with n = (- (comp-args-max args) (comp-args-min args))
- initially (unless (zerop n)
- (push '&optional res))
- repeat n
- do (push t res))
+;; This pass aims to verify compile-time value-type predictions during
+;; execution of the code.
+;; The sanitizer pass injects a call to 'helper_sanitizer_assert' before
+;; each conditional branch. 'helper_sanitizer_assert' will verify that
+;; the variable tested by the conditional branch is of the predicted
+;; value type, or signal an error otherwise.
+
+;;; Example:
+
+;; Assume we want to compile 'test.el' and test the function `foo'
+;; defined in it. Then:
+
+;; - Native-compile 'test.el' instrumenting it for sanitizer usage:
+;; (let ((comp-sanitizer-emit t))
+;; (load (native-compile "test.el")))
+
+;; - Run `foo' with the sanitizer active:
+;; (let ((comp-sanitizer-active t))
+;; (foo))
+
+(defvar comp-sanitizer-emit nil
+ "Gates the sanitizer pass.
+This is intended to be used only for development and verification of
+the native compiler.")
+
+(defun comp--sanitizer (_)
+ (when comp-sanitizer-emit
+ (cl-loop
+ for f being each hash-value of (comp-ctxt-funcs-h comp-ctxt)
+ for comp-func = f
+ unless (comp-func-has-non-local comp-func)
+ do
(cl-loop
- with n = (- (comp-nargs-nonrest args) (comp-nargs-min args))
- initially (unless (zerop n)
- (push '&optional res))
- repeat n
- do (push t res)
- finally (when (comp-nargs-rest args)
- (push '&rest res)
- (push 't res))))
- (cl-return (reverse res))))
+ for b being each hash-value of (comp-func-blocks f)
+ do
+ (cl-loop
+ named in-the-basic-block
+ for insns-seq on (comp-block-insns b)
+ do (pcase insns-seq
+ (`((cond-jump ,(and (pred comp-mvar-p) mvar-tested)
+ ,(pred comp-mvar-p) ,_bb1 ,_bb2))
+ (let ((type (comp-cstr-to-type-spec mvar-tested))
+ (insn (car insns-seq)))
+ ;; No need to check if type is t.
+ (unless (eq type t)
+ (comp--add-const-to-relocs type)
+ (setcar
+ insns-seq
+ (comp--call 'helper_sanitizer_assert
+ mvar-tested
+ (make--comp-mvar :constant type)))
+ (setcdr insns-seq (list insn)))
+ ;; (setf (comp-func-ssa-status comp-func) 'dirty)
+ (cl-return-from in-the-basic-block))))))
+ do (comp--log-func comp-func 3))))
-(defun comp-compute-function-type (_ func)
+
+;;; Function types pass specific code.
+
+(defun comp--compute-function-type (_ func)
"Compute type specifier for `comp-func' FUNC.
Set it into the `type' slot."
(when (and (comp-func-l-p func)
@@ -3584,13 +3098,45 @@ Set it into the `type' slot."
(`(return ,mvar)
(push mvar res))))
finally return res)))
- (type `(function ,(comp-args-to-lambda-list (comp-func-l-args func))
+ (type `(function ,(comp--args-to-lambda-list (comp-func-l-args func))
,(comp-cstr-to-type-spec res-mvar))))
- (comp-add-const-to-relocs type)
+ (comp--add-const-to-relocs type)
;; Fix it up.
(setf (comp-cstr-imm (comp-func-type func)) type))))
-(defun comp-finalize-container (cont)
+(defun comp--compute-function-types (_)
+ "Compute and store the type specifier for all functions."
+ (maphash #'comp--compute-function-type (comp-ctxt-funcs-h comp-ctxt)))
+
+
+;;; Final pass specific code.
+
+(defun comp--args-to-lambda-list (args)
+ "Return a lambda list for ARGS."
+ (cl-loop
+ with res
+ repeat (comp-args-base-min args)
+ do (push t res)
+ finally
+ (if (comp-args-p args)
+ (cl-loop
+ with n = (- (comp-args-max args) (comp-args-min args))
+ initially (unless (zerop n)
+ (push '&optional res))
+ repeat n
+ do (push t res))
+ (cl-loop
+ with n = (- (comp-nargs-nonrest args) (comp-nargs-min args))
+ initially (unless (zerop n)
+ (push '&optional res))
+ repeat n
+ do (push t res)
+ finally (when (comp-nargs-rest args)
+ (push '&rest res)
+ (push 't res))))
+ (cl-return (reverse res))))
+
+(defun comp--finalize-container (cont)
"Finalize data container CONT."
(setf (comp-data-container-l cont)
(cl-loop with h = (comp-data-container-idx cont)
@@ -3608,14 +3154,14 @@ Set it into the `type' slot."
'lambda-fixup
obj))))
-(defun comp-finalize-relocs ()
+(defun comp--finalize-relocs ()
"Finalize data containers for each relocation class.
Remove immediate duplicates within relocation classes.
Update all insn accordingly."
;; Symbols imported by C inlined functions. We do this here because
;; is better to add all objs to the relocation containers before we
;; compacting them.
- (mapc #'comp-add-const-to-relocs '(nil t consp listp symbol-with-pos-p))
+ (mapc #'comp--add-const-to-relocs '(nil t consp listp symbol-with-pos-p))
(let* ((d-default (comp-ctxt-d-default comp-ctxt))
(d-default-idx (comp-data-container-idx d-default))
@@ -3624,7 +3170,7 @@ Update all insn accordingly."
(d-ephemeral (comp-ctxt-d-ephemeral comp-ctxt))
(d-ephemeral-idx (comp-data-container-idx d-ephemeral)))
;; We never want compiled lambdas ending up in pure space. A copy must
- ;; be already present in impure (see `comp-emit-lambda-for-top-level').
+ ;; be already present in impure (see `comp--emit-lambda-for-top-level').
(cl-loop for obj being each hash-keys of d-default-idx
when (gethash obj (comp-ctxt-lambda-fixups-h comp-ctxt))
do (cl-assert (gethash obj d-impure-idx))
@@ -3640,7 +3186,7 @@ Update all insn accordingly."
do (remhash obj d-ephemeral-idx))
;; Fix-up indexes in each relocation class and fill corresponding
;; reloc lists.
- (mapc #'comp-finalize-container (list d-default d-impure d-ephemeral))
+ (mapc #'comp--finalize-container (list d-default d-impure d-ephemeral))
;; Make a vector from the function documentation hash table.
(cl-loop with h = (comp-ctxt-function-docs comp-ctxt)
with v = (make-vector (hash-table-count h) nil)
@@ -3664,28 +3210,25 @@ Update all insn accordingly."
(comp-mvar-range mvar) (list (cons idx idx)))
(puthash idx t reverse-h))))
-(defun comp-compile-ctxt-to-file (name)
+(defun comp--compile-ctxt-to-file (name)
"Compile as native code the current context naming it NAME.
Prepare every function for final compilation and drive the C back-end."
(let ((dir (file-name-directory name)))
- (comp-finalize-relocs)
+ (comp--finalize-relocs)
(maphash (lambda (_ f)
- (comp-log-func f 1))
+ (comp--log-func f 1))
(comp-ctxt-funcs-h comp-ctxt))
(unless (file-exists-p dir)
;; In case it's created in the meanwhile.
(ignore-error file-already-exists
(make-directory dir t)))
- (comp--compile-ctxt-to-file name)))
+ (comp--compile-ctxt-to-file0 name)))
-(defun comp-final1 ()
- (let (compile-result)
- (comp--init-ctxt)
- (unwind-protect
- (setf compile-result
- (comp-compile-ctxt-to-file (comp-ctxt-output comp-ctxt)))
- (and (comp--release-ctxt)
- compile-result))))
+(defun comp--final1 ()
+ (comp--init-ctxt)
+ (unwind-protect
+ (comp--compile-ctxt-to-file (comp-ctxt-output comp-ctxt))
+ (comp--release-ctxt)))
(defvar comp-async-compilation nil
"Non-nil while executing an asynchronous native compilation.")
@@ -3693,17 +3236,16 @@ Prepare every function for final compilation and drive the C back-end."
(defvar comp-running-batch-compilation nil
"Non-nil when compilation is driven by any `batch-*-compile' function.")
-(defun comp-final (_)
+(defun comp--final (_)
"Final pass driving the C back-end for code emission."
- (maphash #'comp-compute-function-type (comp-ctxt-funcs-h comp-ctxt))
(unless comp-dry-run
;; Always run the C side of the compilation as a sub-process
;; unless during bootstrap or async compilation (bug#45056). GCC
;; leaks memory but also interfere with the ability of Emacs to
;; detect when a sub-process completes (TODO understand why).
(if (or comp-running-batch-compilation comp-async-compilation)
- (comp-final1)
- ;; Call comp-final1 in a child process.
+ (comp--final1)
+ ;; Call comp--final1 in a child process.
(let* ((output (comp-ctxt-output comp-ctxt))
(print-escape-newlines t)
(print-length nil)
@@ -3725,7 +3267,7 @@ Prepare every function for final compilation and drive the C back-end."
load-path ',load-path)
,native-comp-async-env-modifier-form
(message "Compiling %s..." ',output)
- (comp-final1)))
+ (comp--final1)))
(temp-file (make-temp-file
(concat "emacs-int-comp-"
(file-name-base output) "-")
@@ -3746,7 +3288,7 @@ Prepare every function for final compilation and drive the C back-end."
(progn
(delete-file temp-file)
output)
- (signal 'native-compiler-error (buffer-string)))
+ (signal 'native-compiler-error (list (buffer-string))))
(comp-log-to-buffer (buffer-string))))))))
@@ -3769,20 +3311,7 @@ Prepare every function for final compilation and drive the C back-end."
;; Primitive function advice machinery
-(defun comp-eln-load-path-eff ()
- "Return a list of effective eln load directories.
-Account for `native-comp-eln-load-path' and `comp-native-version-dir'."
- (mapcar (lambda (dir)
- (expand-file-name comp-native-version-dir
- (file-name-as-directory
- (expand-file-name dir invocation-directory))))
- native-comp-eln-load-path))
-
-(defun comp-trampoline-filename (subr-name)
- "Given SUBR-NAME return the filename containing the trampoline."
- (concat (comp-c-func-name subr-name "subr--trampoline-" t) ".eln"))
-
-(defun comp-make-lambda-list-from-subr (subr)
+(defun comp--make-lambda-list-from-subr (subr)
"Given SUBR return the equivalent lambda-list."
(pcase-let ((`(,min . ,max) (subr-arity subr))
(lambda-list '()))
@@ -3797,16 +3326,6 @@ Account for `native-comp-eln-load-path' and `comp-native-version-dir'."
(push (gensym "arg") lambda-list))
(reverse lambda-list)))
-(defun comp-trampoline-search (subr-name)
- "Search a trampoline file for SUBR-NAME.
-Return the trampoline if found or nil otherwise."
- (cl-loop
- with rel-filename = (comp-trampoline-filename subr-name)
- for dir in (comp-eln-load-path-eff)
- for filename = (expand-file-name rel-filename dir)
- when (file-exists-p filename)
- do (cl-return (native-elisp-load filename))))
-
(defun comp--trampoline-abs-filename (subr-name)
"Return the absolute filename for a trampoline for SUBR-NAME."
(cl-loop
@@ -3832,9 +3351,11 @@ Return the trampoline if found or nil otherwise."
(make-temp-file (file-name-sans-extension rel-filename) nil ".eln"
nil))))
+;; Called from comp-run.el
+;;;###autoload
(defun comp-trampoline-compile (subr-name)
"Synthesize compile and return a trampoline for SUBR-NAME."
- (let* ((lambda-list (comp-make-lambda-list-from-subr
+ (let* ((lambda-list (comp--make-lambda-list-from-subr
(symbol-function subr-name)))
;; The synthesized trampoline must expose the exact same ABI of
;; the primitive we are replacing in the function reloc table.
@@ -3878,6 +3399,7 @@ filename (including FILE)."
do (ignore-error file-error
(comp-delete-or-replace-file f))))))
+;; In use by comp.c.
(defun comp-delete-or-replace-file (oldfile &optional newfile)
"Replace OLDFILE with NEWFILE.
When NEWFILE is nil just delete OLDFILE.
@@ -3906,174 +3428,9 @@ session."
;; Remove the old eln instead of copying the new one into it
;; to get a new inode and prevent crashes in case the old one
;; is currently loaded.
- (t (delete-file oldfile)
- (when newfile
- (rename-file newfile oldfile)))))
-
-(defvar comp-files-queue ()
- "List of Emacs Lisp files to be compiled.")
-
-(defvar comp-async-compilations (make-hash-table :test #'equal)
- "Hash table file-name -> async compilation process.")
-
-(defun comp-async-runnings ()
- "Return the number of async compilations currently running.
-This function has the side effect of cleaning-up finished
-processes from `comp-async-compilations'"
- (cl-loop
- for file-name in (cl-loop
- for file-name being each hash-key of comp-async-compilations
- for prc = (gethash file-name comp-async-compilations)
- unless (process-live-p prc)
- collect file-name)
- do (remhash file-name comp-async-compilations))
- (hash-table-count comp-async-compilations))
-
-(defvar comp-num-cpus nil)
-(defun comp-effective-async-max-jobs ()
- "Compute the effective number of async jobs."
- (if (zerop native-comp-async-jobs-number)
- (or comp-num-cpus
- (setf comp-num-cpus
- (max 1 (/ (num-processors) 2))))
- native-comp-async-jobs-number))
-
-(defvar comp-last-scanned-async-output nil)
-(make-variable-buffer-local 'comp-last-scanned-async-output)
-(defun comp-accept-and-process-async-output (process)
- "Accept PROCESS output and check for diagnostic messages."
- (if native-comp-async-report-warnings-errors
- (let ((warning-suppress-types
- (if (eq native-comp-async-report-warnings-errors 'silent)
- (cons '(comp) warning-suppress-types)
- warning-suppress-types)))
- (with-current-buffer (process-buffer process)
- (save-excursion
- (accept-process-output process)
- (goto-char (or comp-last-scanned-async-output (point-min)))
- (while (re-search-forward "^.*?\\(?:Error\\|Warning\\): .*$"
- nil t)
- (display-warning 'comp (match-string 0)))
- (setq comp-last-scanned-async-output (point-max)))))
- (accept-process-output process)))
-
-(defun comp-run-async-workers ()
- "Start compiling files from `comp-files-queue' asynchronously.
-When compilation is finished, run `native-comp-async-all-done-hook' and
-display a message."
- (cl-assert (null comp-no-spawn))
- (if (or comp-files-queue
- (> (comp-async-runnings) 0))
- (unless (>= (comp-async-runnings) (comp-effective-async-max-jobs))
- (cl-loop
- for (source-file . load) = (pop comp-files-queue)
- while source-file
- do (cl-assert (string-match-p comp-valid-source-re source-file) nil
- "`comp-files-queue' should be \".el\" files: %s"
- source-file)
- when (or native-comp-always-compile
- load ; Always compile when the compilation is
- ; commanded for late load.
- ;; Skip compilation if `comp-el-to-eln-filename' fails
- ;; to find a writable directory.
- (with-demoted-errors "Async compilation :%S"
- (file-newer-than-file-p
- source-file (comp-el-to-eln-filename source-file))))
- do (let* ((expr `((require 'comp)
- (setq comp-async-compilation t
- warning-fill-column most-positive-fixnum)
- ,(let ((set (list 'setq)))
- (dolist (var '(comp-file-preloaded-p
- native-compile-target-directory
- native-comp-speed
- native-comp-debug
- native-comp-verbose
- comp-libgccjit-reproducer
- native-comp-eln-load-path
- native-comp-compiler-options
- native-comp-driver-options
- load-path
- backtrace-line-length
- byte-compile-warnings
- ;; package-load-list
- ;; package-user-dir
- ;; package-directory-list
- ))
- (when (boundp var)
- (push var set)
- (push `',(symbol-value var) set)))
- (nreverse set))
- ;; FIXME: Activating all packages would align the
- ;; functionality offered with what is usually done
- ;; for ELPA packages (and thus fix some compilation
- ;; issues with some ELPA packages), but it's too
- ;; blunt an instrument (e.g. we don't even know if
- ;; we're compiling such an ELPA package at
- ;; this point).
- ;;(package-activate-all)
- ,native-comp-async-env-modifier-form
- (message "Compiling %s..." ,source-file)
- (comp--native-compile ,source-file ,(and load t))))
- (source-file1 source-file) ;; Make the closure works :/
- (temp-file (make-temp-file
- (concat "emacs-async-comp-"
- (file-name-base source-file) "-")
- nil ".el"))
- (expr-strings (let ((print-length nil)
- (print-level nil))
- (mapcar #'prin1-to-string expr)))
- (_ (progn
- (with-temp-file temp-file
- (mapc #'insert expr-strings))
- (comp-log "\n")
- (mapc #'comp-log expr-strings)))
- (load1 load)
- (default-directory invocation-directory)
- (process (make-process
- :name (concat "Compiling: " source-file)
- :buffer (with-current-buffer
- (get-buffer-create
- comp-async-buffer-name)
- (setf buffer-read-only t)
- (current-buffer))
- :command (list
- (expand-file-name invocation-name
- invocation-directory)
- "-no-comp-spawn" "-Q" "--batch"
- "--eval"
- ;; Suppress Abort dialogs on MS-Windows
- "(setq w32-disable-abort-dialog t)"
- "-l" temp-file)
- :sentinel
- (lambda (process _event)
- (run-hook-with-args
- 'native-comp-async-cu-done-functions
- source-file)
- (comp-accept-and-process-async-output process)
- (ignore-errors (delete-file temp-file))
- (let ((eln-file (comp-el-to-eln-filename
- source-file1)))
- (when (and load1
- (zerop (process-exit-status
- process))
- (file-exists-p eln-file))
- (native-elisp-load eln-file
- (eq load1 'late))))
- (comp-run-async-workers))
- :noquery (not native-comp-async-query-on-exit))))
- (puthash source-file process comp-async-compilations))
- when (>= (comp-async-runnings) (comp-effective-async-max-jobs))
- do (cl-return)))
- ;; No files left to compile and all processes finished.
- (run-hooks 'native-comp-async-all-done-hook)
- (with-current-buffer (get-buffer-create comp-async-buffer-name)
- (save-excursion
- (let ((inhibit-read-only t))
- (goto-char (point-max))
- (insert "Compilation finished.\n"))))
- ;; `comp-deferred-pending-h' should be empty at this stage.
- ;; Reset it anyway.
- (clrhash comp-deferred-pending-h)))
+ (t (if newfile
+ (rename-file newfile oldfile t)
+ (delete-file oldfile)))))
(defun comp--native-compile (function-or-file &optional with-late-load output)
"Compile FUNCTION-OR-FILE into native code.
@@ -4102,14 +3459,14 @@ the deferred compilation mechanism."
(comp-log "\n \n" 1)
(unwind-protect
(progn
- (condition-case err
+ (condition-case-unless-debug err
(cl-loop
with report = nil
for t0 = (current-time)
for pass in comp-passes
unless (memq pass comp-disabled-passes)
do
- (comp-log (format "(%s) Running pass %s:\n"
+ (comp-log (format "\n(%s) Running pass %s:\n"
function-or-file pass)
2)
(setf data (funcall pass data))
@@ -4121,7 +3478,8 @@ the deferred compilation mechanism."
(comp-log (format "Done compiling %s" data) 0)
(cl-loop for (pass . time) in (reverse report)
do (comp-log (format "Pass %s took: %fs."
- pass time) 0))))
+ pass time)
+ 0))))
(native-compiler-skip)
(t
(let ((err-val (cdr err)))
@@ -4130,16 +3488,18 @@ the deferred compilation mechanism."
(if (and comp-async-compilation
(not (eq (car err) 'native-compiler-error)))
(progn
- (message (if err-val
- "%s: Error: %s %s"
- "%s: Error %s")
+ (message "%s: Error %s"
function-or-file
- (get (car err) 'error-message)
- (car-safe err-val))
+ (error-message-string err))
(kill-emacs -1))
;; Otherwise re-signal it adding the compilation input.
+ ;; FIXME: We can't just insert arbitrary info in the
+ ;; error-data part of an error: the handler may expect
+ ;; specific data at specific positions!
(signal (car err) (if (consp err-val)
(cons function-or-file err-val)
+ ;; FIXME: `err-val' is supposed to be
+ ;; a list, so it can only be nil here!
(list function-or-file err-val)))))))
(if (stringp function-or-file)
data
@@ -4156,101 +3516,6 @@ the deferred compilation mechanism."
(ignore-errors (delete-file (comp-ctxt-output comp-ctxt))))
(t (delete-file (comp-ctxt-output comp-ctxt))))))))))
-(defun native-compile-async-skip-p (file load selector)
- "Return non-nil if FILE's compilation should be skipped.
-
-LOAD and SELECTOR work as described in `native--compile-async'."
- ;; Make sure we are not already compiling `file' (bug#40838).
- (or (gethash file comp-async-compilations)
- (gethash (file-name-with-extension file "elc") comp--no-native-compile)
- (cond
- ((null selector) nil)
- ((functionp selector) (not (funcall selector file)))
- ((stringp selector) (not (string-match-p selector file)))
- (t (error "SELECTOR must be a function a regexp or nil")))
- ;; Also exclude files from deferred compilation if
- ;; any of the regexps in
- ;; `native-comp-jit-compilation-deny-list' matches.
- (and (eq load 'late)
- (cl-some (lambda (re)
- (string-match-p re file))
- native-comp-jit-compilation-deny-list))))
-
-(defun native--compile-async (files &optional recursively load selector)
- ;; BEWARE, this function is also called directly from C.
- "Compile FILES asynchronously.
-FILES is one filename or a list of filenames or directories.
-
-If optional argument RECURSIVELY is non-nil, recurse into
-subdirectories of given directories.
-
-If optional argument LOAD is non-nil, request to load the file
-after compiling.
-
-The optional argument SELECTOR has the following valid values:
-
-nil -- Select all files.
-a string -- A regular expression selecting files with matching names.
-a function -- A function selecting files with matching names.
-
-The variable `native-comp-async-jobs-number' specifies the number
-of (commands) to run simultaneously.
-
-LOAD can also be the symbol `late'. This is used internally if
-the byte code has already been loaded when this function is
-called. It means that we request the special kind of load
-necessary in that situation, called \"late\" loading.
-
-During a \"late\" load, instead of executing all top-level forms
-of the original files, only function definitions are
-loaded (paying attention to have these effective only if the
-bytecode definition was not changed in the meantime)."
- (comp-ensure-native-compiler)
- (unless (member load '(nil t late))
- (error "LOAD must be nil, t or 'late"))
- (unless (listp files)
- (setf files (list files)))
- (let ((added-something nil)
- file-list)
- (dolist (file-or-dir files)
- (cond ((file-directory-p file-or-dir)
- (dolist (file (if recursively
- (directory-files-recursively
- file-or-dir comp-valid-source-re)
- (directory-files file-or-dir
- t comp-valid-source-re)))
- (push file file-list)))
- ((file-exists-p file-or-dir) (push file-or-dir file-list))
- (t (signal 'native-compiler-error
- (list "Not a file nor directory" file-or-dir)))))
- (dolist (file file-list)
- (if-let ((entry (cl-find file comp-files-queue :key #'car :test #'string=)))
- ;; Most likely the byte-compiler has requested a deferred
- ;; compilation, so update `comp-files-queue' to reflect that.
- (unless (or (null load)
- (eq load (cdr entry)))
- (setf comp-files-queue
- (cl-substitute (cons file load) (car entry) comp-files-queue
- :key #'car :test #'string=)))
-
- (unless (native-compile-async-skip-p file load selector)
- (let* ((out-filename (comp-el-to-eln-filename file))
- (out-dir (file-name-directory out-filename)))
- (unless (file-exists-p out-dir)
- (make-directory out-dir t))
- (if (file-writable-p out-filename)
- (setf comp-files-queue
- (append comp-files-queue `((,file . ,load)))
- added-something t)
- (display-warning 'comp
- (format "No write access for %s skipping."
- out-filename)))))))
- ;; Perhaps nothing passed `native-compile-async-skip-p'?
- (when (and added-something
- ;; Don't start if there's one already running.
- (zerop (comp-async-runnings)))
- (comp-run-async-workers))))
-
;;; Compiler entry points.
@@ -4318,7 +3583,8 @@ last directory in `native-comp-eln-load-path')."
else
collect (byte-compile-file file))))
-(defun comp-write-bytecode-file (eln-file)
+;; In use by elisp-mode.el
+(defun comp--write-bytecode-file (eln-file)
"After native compilation write the bytecode file for ELN-FILE.
Make sure that eln file is younger than byte-compiled one and
return the filename of this last.
@@ -4355,32 +3621,9 @@ variable \"NATIVE_DISABLED\" is set, only byte compile."
(car (last native-comp-eln-load-path)))
(byte-to-native-output-buffer-file nil)
(eln-file (car (batch-native-compile))))
- (comp-write-bytecode-file eln-file)
+ (comp--write-bytecode-file eln-file)
(setq command-line-args-left (cdr command-line-args-left)))))
-;;;###autoload
-(defun native-compile-async (files &optional recursively load selector)
- "Compile FILES asynchronously.
-FILES is one file or a list of filenames or directories.
-
-If optional argument RECURSIVELY is non-nil, recurse into
-subdirectories of given directories.
-
-If optional argument LOAD is non-nil, request to load the file
-after compiling.
-
-The optional argument SELECTOR has the following valid values:
-
-nil -- Select all files.
-a string -- A regular expression selecting files with matching names.
-a function -- A function selecting files with matching names.
-
-The variable `native-comp-async-jobs-number' specifies the number
-of (commands) to run simultaneously."
- ;; Normalize: we only want to pass t or nil, never e.g. `late'.
- (let ((load (not (not load))))
- (native--compile-async files recursively load selector)))
-
(defun native-compile-prune-cache ()
"Remove .eln files that aren't applicable to the current Emacs invocation."
(interactive)
diff --git a/lisp/emacs-lisp/compat.el b/lisp/emacs-lisp/compat.el
new file mode 100644
index 00000000000..f7037dc4101
--- /dev/null
+++ b/lisp/emacs-lisp/compat.el
@@ -0,0 +1,92 @@
+;;; compat.el --- Stub of the Compatibility Library -*- lexical-binding: t; -*-
+
+;; Copyright (C) 2021-2024 Free Software Foundation, Inc.
+
+;; Author: \
+;; Philip Kaludercic <philipk@posteo.net>, \
+;; Daniel Mendler <mail@daniel-mendler.de>
+;; Maintainer: \
+;; Daniel Mendler <mail@daniel-mendler.de>, \
+;; Compat Development <~pkal/compat-devel@lists.sr.ht>,
+;; emacs-devel@gnu.org
+;; URL: https://github.com/emacs-compat/compat
+;; Keywords: lisp, maint
+
+;; This program is free software; you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+
+;; This program is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with this program. If not, see <https://www.gnu.org/licenses/>.
+
+;;; Commentary:
+
+;; The Compat package on ELPA provides forward-compatibility
+;; definitions for other packages. While mostly transparent, a
+;; minimal API is necessary whenever core definitions change calling
+;; conventions (e.g. `plist-get' can be invoked with a predicate from
+;; Emacs 29.1 onward). For core packages on ELPA to be able to take
+;; advantage of this functionality, the macros `compat-function' and
+;; `compat-call' have to be available in the core, usable even if
+;; users do not have the Compat package installed, which this file
+;; ensures.
+
+;; A basic introduction to Compat is given in the Info node `(elisp)
+;; Forwards Compatibility'. Further details on Compat are documented
+;; in the Info node `(compat) Top' (installed along with the Compat
+;; package) or read the same manual online:
+;; https://elpa.gnu.org/packages/doc/compat.html.
+
+;;; Code:
+
+(defmacro compat-function (fun)
+ "Return compatibility function symbol for FUN.
+This is a pseudo-compatibility stub for core packages on ELPA,
+that depend on the Compat package, whenever the user doesn't have
+the package installed on their current system."
+ `#',fun)
+
+(defmacro compat-call (fun &rest args)
+ "Call compatibility function or macro FUN with ARGS.
+This is a pseudo-compatibility stub for core packages on ELPA,
+that depend on the Compat package, whenever the user doesn't have
+the package installed on their current system."
+ (cons fun args))
+
+;;;; Clever trick to avoid installing Compat if not necessary
+
+;; The versioning scheme of the Compat package follows that of Emacs,
+;; to indicate the version of Emacs, that functionality is being
+;; provided for. For example, the Compat version number 29.2.3.9
+;; would attempt to provide compatibility definitions up to Emacs
+;; 29.2, while also designating that this is the third major release
+;; and ninth minor release of Compat, for the specific Emacs release.
+
+;; The package version of this file is specified programmatically,
+;; instead of giving a fixed version in the header of this file. This
+;; is done to ensure that the version of compat.el provided by Emacs
+;; always corresponds to the current version of Emacs. In addition to
+;; the major-minor version, a large "major release" makes sure that
+;; the built-in version of Compat is always preferred over an external
+;; installation. This means that if a package specifies a dependency
+;; on Compat which matches the current or an older version of Emacs
+;; that is being used, no additional dependencies have to be
+;; downloaded.
+;;
+;; Further details and background on this file can be found in the
+;; bug#66554 discussion.
+
+;;;###autoload (push (list 'compat
+;;;###autoload emacs-major-version
+;;;###autoload emacs-minor-version
+;;;###autoload 9999)
+;;;###autoload package--builtin-versions)
+
+(provide 'compat)
+;;; compat.el ends here
diff --git a/lisp/emacs-lisp/debug-early.el b/lisp/emacs-lisp/debug-early.el
index f2eb8792bfa..8a0dddc2679 100644
--- a/lisp/emacs-lisp/debug-early.el
+++ b/lisp/emacs-lisp/debug-early.el
@@ -27,14 +27,17 @@
;; This file dumps a backtrace on stderr when an error is thrown. It
;; has no dependencies on any Lisp libraries and is thus used for
;; generating backtraces for bugs in the early parts of bootstrapping.
-;; It is also always used in batch model. It was introduced in Emacs
+;; It is also always used in batch mode. It was introduced in Emacs
;; 29, before which there was no backtrace available during early
;; bootstrap.
;;; Code:
+;; For bootstrap reasons, we cannot use any macros here since they're
+;; not defined yet.
+
(defalias 'debug-early-backtrace
- #'(lambda ()
+ #'(lambda (&optional base)
"Print a trace of Lisp function calls currently active.
The output stream used is the value of `standard-output'.
@@ -51,26 +54,39 @@ of the build process."
(require 'cl-print)
(error nil)))
#'cl-prin1
- #'prin1)))
+ #'prin1))
+ (first t))
(mapbacktrace
#'(lambda (evald func args _flags)
- (let ((args args))
- (if evald
+ (if first
+ ;; The first is the debug-early entry point itself.
+ (setq first nil)
+ (let ((args args))
+ (if evald
+ (progn
+ (princ " ")
+ (funcall prin1 func)
+ (princ "("))
(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
+ (princ " (")
+ (setq args (cons func args))))
+ (if args
+ (while (progn
+ (funcall prin1 (car args))
+ (setq args (cdr args)))
+ (princ " ")))
+ (princ ")\n"))))
+ base))))
+
+(defalias 'debug--early
+ #'(lambda (error base)
+ (princ "\nError: ")
+ (prin1 (car error)) ; The error symbol.
+ (princ " ")
+ (prin1 (cdr error)) ; The error data.
+ (debug-early-backtrace base)))
+
+(defalias 'debug-early ;Called from C.
#'(lambda (&rest args)
"Print an error message with a backtrace of active Lisp function calls.
The output stream used is the value of `standard-output'.
@@ -88,10 +104,31 @@ support the latter, except in batch mode which always uses
\(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.
- (princ " ")
- (prin1 (cdr (car (cdr args)))) ; The error data.
- (debug-early-backtrace)))
+ (debug--early (car (cdr args)) #'debug-early))) ; The error object.
+
+(defalias 'debug-early--handler ;Called from C.
+ #'(lambda (err)
+ (if backtrace-on-error-noninteractive
+ (debug--early err #'debug-early--handler))))
+
+(defalias 'debug-early--muted ;Called from C.
+ #'(lambda (err)
+ (save-current-buffer
+ (set-buffer (get-buffer-create "*Redisplay-trace*"))
+ (goto-char (point-max))
+ (if (bobp) nil
+ (let ((separator "\n\n\n\n"))
+ (save-excursion
+ ;; The C code tested `backtrace_yet', instead we
+ ;; keep a max of 10 backtraces.
+ (if (search-backward separator nil t 10)
+ (delete-region (point-min) (match-end 0))))
+ (insert separator)))
+ (insert "-- Caught at " (current-time-string) "\n")
+ (let ((standard-output (current-buffer)))
+ (debug--early err #'debug-early--muted))
+ (setq delayed-warnings-list
+ (cons '(error "Error in a redisplay Lisp hook. See buffer *Redisplay-trace*")
+ delayed-warnings-list)))))
;;; debug-early.el ends here.
diff --git a/lisp/emacs-lisp/debug.el b/lisp/emacs-lisp/debug.el
index 05a5e23609a..ec947c1215d 100644
--- a/lisp/emacs-lisp/debug.el
+++ b/lisp/emacs-lisp/debug.el
@@ -153,6 +153,12 @@ where CAUSE can be:
(insert (debugger--buffer-state-content state)))
(goto-char (debugger--buffer-state-pos state)))
+(defvar debugger--last-error nil)
+
+(defun debugger--duplicate-p (args)
+ (pcase args
+ (`(error ,err . ,_) (and (consp err) (eq err debugger--last-error)))))
+
;;;###autoload
(setq debugger 'debug)
;;;###autoload
@@ -175,9 +181,14 @@ first will be printed into the backtrace buffer.
If `inhibit-redisplay' is non-nil when this function is called,
the debugger will not be entered."
(interactive)
- (if inhibit-redisplay
- ;; Don't really try to enter debugger within an eval from redisplay.
+ (if (or inhibit-redisplay
+ (debugger--duplicate-p args))
+ ;; Don't really try to enter debugger within an eval from redisplay
+ ;; or if we already popper into the debugger for this error,
+ ;; which can happen when we have several nested `handler-bind's that
+ ;; want to invoke the debugger.
debugger-value
+ (setq debugger--last-error nil)
(let ((non-interactive-frame
(or noninteractive ;FIXME: Presumably redundant.
;; If we're in the initial-frame (where `message' just
@@ -200,7 +211,7 @@ the debugger will not be entered."
(let (debugger-value
(debugger-previous-state
(if (get-buffer "*Backtrace*")
- (with-current-buffer (get-buffer "*Backtrace*")
+ (with-current-buffer "*Backtrace*"
(debugger--save-buffer-state))))
(debugger-args args)
(debugger-buffer (get-buffer-create "*Backtrace*"))
@@ -237,12 +248,11 @@ the debugger will not be entered."
(unwind-protect
(save-excursion
(when (eq (car debugger-args) 'debug)
- ;; Skip the frames for backtrace-debug, byte-code,
- ;; debug--implement-debug-on-entry and the advice's `apply'.
- (backtrace-debug 4 t)
- ;; Place an extra debug-on-exit for macro's.
- (when (eq 'lambda (car-safe (cadr (backtrace-frame 4))))
- (backtrace-debug 5 t)))
+ (let ((base (debugger--backtrace-base)))
+ (backtrace-debug 1 t base) ;FIXME!
+ ;; Place an extra debug-on-exit for macro's.
+ (when (eq 'lambda (car-safe (cadr (backtrace-frame 1 base))))
+ (backtrace-debug 2 t base))))
(with-current-buffer debugger-buffer
(unless (derived-mode-p 'debugger-mode)
(debugger-mode))
@@ -319,6 +329,12 @@ the debugger will not be entered."
(backtrace-mode))))
(with-timeout-unsuspend debugger-with-timeout-suspend)
(set-match-data debugger-outer-match-data)))
+ (when (eq 'error (car-safe debugger-args))
+ ;; Remember the error we just debugged, to avoid re-entering
+ ;; the debugger if some higher-up `handler-bind' invokes us
+ ;; again, oblivious that the error was already debugged from
+ ;; a more deeply nested `handler-bind'.
+ (setq debugger--last-error (nth 1 debugger-args)))
(setq debug-on-next-call debugger-step-after-exit)
debugger-value))))
@@ -343,11 +359,10 @@ Make functions into cross-reference buttons if DO-XREFS is non-nil."
(defun debugger-setup-buffer (args)
"Initialize the `*Backtrace*' buffer for entry to the debugger.
That buffer should be current already and in `debugger-mode'."
- (setq backtrace-frames (nthcdr
- ;; Remove debug--implement-debug-on-entry and the
- ;; advice's `apply' frame.
- (if (eq (car args) 'debug) 3 1)
- (backtrace-get-frames 'debug)))
+ (setq backtrace-frames
+ ;; The `base' frame is the one that gets index 0 and it is the entry to
+ ;; the debugger, so drop it with `cdr'.
+ (cdr (backtrace-get-frames (debugger--backtrace-base))))
(when (eq (car-safe args) 'exit)
(setq debugger-value (nth 1 args))
(setf (cl-getf (backtrace-frame-flags (car backtrace-frames))
@@ -477,26 +492,29 @@ removes itself from that hook."
(setq debugger-jumping-flag nil)
(remove-hook 'post-command-hook 'debugger-reenable))
-(defun debugger-frame-number (&optional skip-base)
+(defun debugger-frame-number ()
"Return number of frames in backtrace before the one point points at."
- (let ((index (backtrace-get-index))
- (count 0))
+ (let ((index (backtrace-get-index)))
(unless index
(error "This line is not a function call"))
- (unless skip-base
- (while (not (eq (cadr (backtrace-frame count)) 'debug))
- (setq count (1+ count)))
- ;; Skip debug--implement-debug-on-entry frame.
- (when (eq 'debug--implement-debug-on-entry
- (cadr (backtrace-frame (1+ count))))
- (setq count (+ 2 count))))
- (+ count index)))
+ ;; We have 3 representations of the backtrace: the real in C in `specpdl',
+ ;; the one stored in `backtrace-frames' and the textual version in
+ ;; the buffer. Check here that the one from `backtrace-frames' is in sync
+ ;; with the one from `specpdl'.
+ (cl-assert (equal (backtrace-frame-fun (nth index backtrace-frames))
+ (nth 1 (backtrace-frame (1+ index)
+ (debugger--backtrace-base)))))
+ ;; The `base' frame is the one that gets index 0 and it is the entry to
+ ;; the debugger, so the first non-debugger frame is 1.
+ ;; This `+1' skips the same frame as the `cdr' in
+ ;; `debugger-setup-buffer'.
+ (1+ index)))
(defun debugger-frame ()
"Request entry to debugger when this frame exits.
Applies to the frame whose line point is on in the backtrace."
(interactive)
- (backtrace-debug (debugger-frame-number) t)
+ (backtrace-debug (debugger-frame-number) t (debugger--backtrace-base))
(setf
(cl-getf (backtrace-frame-flags (nth (backtrace-get-index) backtrace-frames))
:debug-on-exit)
@@ -507,7 +525,7 @@ Applies to the frame whose line point is on in the backtrace."
"Do not enter debugger when this frame exits.
Applies to the frame whose line point is on in the backtrace."
(interactive)
- (backtrace-debug (debugger-frame-number) nil)
+ (backtrace-debug (debugger-frame-number) nil (debugger--backtrace-base))
(setf
(cl-getf (backtrace-frame-flags (nth (backtrace-get-index) backtrace-frames))
:debug-on-exit)
@@ -526,10 +544,8 @@ Applies to the frame whose line point is on in the backtrace."
(defun debugger--backtrace-base ()
"Return the function name that marks the top of the backtrace.
See `backtrace-frame'."
- (cond ((eq 'debug--implement-debug-on-entry
- (cadr (backtrace-frame 1 'debug)))
- 'debug--implement-debug-on-entry)
- (t 'debug)))
+ (or (cadr (memq :backtrace-base debugger-args))
+ #'debug))
(defun debugger-eval-expression (exp &optional nframe)
"Eval an expression, in an environment like that outside the debugger.
@@ -537,7 +553,7 @@ The environment used is the one when entering the activation frame at point."
(interactive
(list (read--expression "Eval in stack frame: ")))
(let ((nframe (or nframe
- (condition-case nil (1+ (debugger-frame-number 'skip-base))
+ (condition-case nil (debugger-frame-number)
(error 0)))) ;; If on first line.
(base (debugger--backtrace-base)))
(debugger-env-macro
@@ -652,7 +668,7 @@ Complete list of commands:
(princ (debugger-eval-expression exp))
(terpri))
- (with-current-buffer (get-buffer debugger-record-buffer)
+ (with-current-buffer debugger-record-buffer
(message "%s"
(buffer-substring (line-beginning-position 0)
(line-end-position 0)))))
@@ -670,7 +686,10 @@ functions to break on entry."
(if (or inhibit-debug-on-entry debugger-jumping-flag)
nil
(let ((inhibit-debug-on-entry t))
- (funcall debugger 'debug))))
+ (funcall debugger 'debug :backtrace-base
+ ;; An offset of 1 because we need to skip the advice
+ ;; OClosure that called us.
+ '(1 . debug--implement-debug-on-entry)))))
;;;###autoload
(defun debug-on-entry (function)
diff --git a/lisp/emacs-lisp/derived.el b/lisp/emacs-lisp/derived.el
index 1af0c930ce6..2423426dca0 100644
--- a/lisp/emacs-lisp/derived.el
+++ b/lisp/emacs-lisp/derived.el
@@ -211,10 +211,10 @@ See Info node `(elisp)Derived Modes' for more details.
(defvar ,hook nil)
(unless (get ',hook 'variable-documentation)
(put ',hook 'variable-documentation
- ,(format "Hook run after entering %s mode.
+ ,(format "Hook run after entering `%S'.
No problems result if this variable is not bound.
`add-hook' automatically binds it. (This is true for all hook variables.)"
- name)))
+ child)))
(unless (boundp ',map)
(put ',map 'definition-name ',child))
(with-no-warnings (defvar ,map (make-sparse-keymap)))
@@ -240,7 +240,9 @@ No problems result if this variable is not bound.
(unless (get ',abbrev 'variable-documentation)
(put ',abbrev 'variable-documentation
(purecopy ,(format "Abbrev table for `%s'." child))))))
- (put ',child 'derived-mode-parent ',parent)
+ (if (fboundp 'derived-mode-set-parent) ;; Emacs≥30.1
+ (derived-mode-set-parent ',child ',parent)
+ (put ',child 'derived-mode-parent ',parent))
,(if group `(put ',child 'custom-mode-group ,group))
(defun ,child ()
@@ -363,137 +365,6 @@ which more-or-less shadow%s %s's corresponding table%s."
docstring))
-;;; OBSOLETE
-;; The functions below are only provided for backward compatibility with
-;; code byte-compiled with versions of derived.el prior to Emacs-21.
-
-(defsubst derived-mode-setup-function-name (mode)
- "Construct a setup-function name based on a MODE name."
- (declare (obsolete nil "28.1"))
- (intern (concat (symbol-name mode) "-setup")))
-
-
-;; Utility functions for defining a derived mode.
-
-;;;###autoload
-(defun derived-mode-init-mode-variables (mode)
- "Initialize variables for a new MODE.
-Right now, if they don't already exist, set up a blank keymap, an
-empty syntax table, and an empty abbrev table -- these will be merged
-the first time the mode is used."
-
- (if (boundp (derived-mode-map-name mode))
- t
- (eval `(defvar ,(derived-mode-map-name mode)
- (make-sparse-keymap)
- ,(format "Keymap for %s." mode)))
- (put (derived-mode-map-name mode) 'derived-mode-unmerged t))
-
- (if (boundp (derived-mode-syntax-table-name mode))
- t
- (eval `(defvar ,(derived-mode-syntax-table-name mode)
- ;; Make a syntax table which doesn't specify anything
- ;; for any char. Valid data will be merged in by
- ;; derived-mode-merge-syntax-tables.
- (make-char-table 'syntax-table nil)
- ,(format "Syntax table for %s." mode)))
- (put (derived-mode-syntax-table-name mode) 'derived-mode-unmerged t))
-
- (if (boundp (derived-mode-abbrev-table-name mode))
- t
- (eval `(defvar ,(derived-mode-abbrev-table-name mode)
- (progn
- (define-abbrev-table (derived-mode-abbrev-table-name ',mode) nil)
- (make-abbrev-table))
- ,(format "Abbrev table for %s." mode)))))
-
-;; Utility functions for running a derived mode.
-
-(defun derived-mode-set-keymap (mode)
- "Set the keymap of the new MODE, maybe merging with the parent."
- (let* ((map-name (derived-mode-map-name mode))
- (new-map (eval map-name))
- (old-map (current-local-map)))
- (and old-map
- (get map-name 'derived-mode-unmerged)
- (derived-mode-merge-keymaps old-map new-map))
- (put map-name 'derived-mode-unmerged nil)
- (use-local-map new-map)))
-
-(defun derived-mode-set-syntax-table (mode)
- "Set the syntax table of the new MODE, maybe merging with the parent."
- (let* ((table-name (derived-mode-syntax-table-name mode))
- (old-table (syntax-table))
- (new-table (eval table-name)))
- (if (get table-name 'derived-mode-unmerged)
- (derived-mode-merge-syntax-tables old-table new-table))
- (put table-name 'derived-mode-unmerged nil)
- (set-syntax-table new-table)))
-
-(defun derived-mode-set-abbrev-table (mode)
- "Set the abbrev table for MODE if it exists.
-Always merge its parent into it, since the merge is non-destructive."
- (let* ((table-name (derived-mode-abbrev-table-name mode))
- (old-table local-abbrev-table)
- (new-table (eval table-name)))
- (derived-mode-merge-abbrev-tables old-table new-table)
- (setq local-abbrev-table new-table)))
-
-(defun derived-mode-run-hooks (mode)
- "Run the mode hook for MODE."
- (let ((hooks-name (derived-mode-hook-name mode)))
- (if (boundp hooks-name)
- (run-hooks hooks-name))))
-
-;; Functions to merge maps and tables.
-
-(defun derived-mode-merge-keymaps (old new)
- "Merge an OLD keymap into a NEW one.
-The old keymap is set to be the last cdr of the new one, so that there will
-be automatic inheritance."
- ;; ?? Can this just use `set-keymap-parent'?
- (let ((tail new))
- ;; Scan the NEW map for prefix keys.
- (while (consp tail)
- (and (consp (car tail))
- (let* ((key (vector (car (car tail))))
- (subnew (lookup-key new key))
- (subold (lookup-key old key)))
- ;; If KEY is a prefix key in both OLD and NEW, merge them.
- (and (keymapp subnew) (keymapp subold)
- (derived-mode-merge-keymaps subold subnew))))
- (and (vectorp (car tail))
- ;; Search a vector of ASCII char bindings for prefix keys.
- (let ((i (1- (length (car tail)))))
- (while (>= i 0)
- (let* ((key (vector i))
- (subnew (lookup-key new key))
- (subold (lookup-key old key)))
- ;; If KEY is a prefix key in both OLD and NEW, merge them.
- (and (keymapp subnew) (keymapp subold)
- (derived-mode-merge-keymaps subold subnew)))
- (setq i (1- i)))))
- (setq tail (cdr tail))))
- (setcdr (nthcdr (1- (length new)) new) old))
-
-(defun derived-mode-merge-syntax-tables (old new)
- "Merge an OLD syntax table into a NEW one.
-Where the new table already has an entry, nothing is copied from the old one."
- (set-char-table-parent new old))
-
-;; Merge an old abbrev table into a new one.
-;; This function requires internal knowledge of how abbrev tables work,
-;; presuming that they are obarrays with the abbrev as the symbol, the expansion
-;; as the value of the symbol, and the hook as the function definition.
-(defun derived-mode-merge-abbrev-tables (old new)
- (if old
- (mapatoms
- (lambda (symbol)
- (or (intern-soft (symbol-name symbol) new)
- (define-abbrev new (symbol-name symbol)
- (symbol-value symbol) (symbol-function symbol))))
- old)))
-
(provide 'derived)
;;; derived.el ends here
diff --git a/lisp/emacs-lisp/disass.el b/lisp/emacs-lisp/disass.el
index 2ba31193710..850cc2085f7 100644
--- a/lisp/emacs-lisp/disass.el
+++ b/lisp/emacs-lisp/disass.el
@@ -54,7 +54,7 @@
(defun disassemble (object &optional buffer indent interactive-p)
"Print disassembled code for OBJECT in (optional) BUFFER.
OBJECT can be a symbol defined as a function, or a function itself
-\(a lambda expression or a compiled-function object).
+\(a lambda expression or a byte-code-function object).
If OBJECT is not already compiled, we compile it, but do not
redefine OBJECT if it is a symbol."
(interactive
@@ -63,16 +63,19 @@ redefine OBJECT if it is a symbol."
(list (intern (completing-read (format-prompt "Disassemble function" fn)
obarray 'fboundp t nil nil def))
nil 0 t)))
- (if (and (consp object) (not (functionp object)))
- (setq object `(lambda () ,object)))
- (or indent (setq indent 0)) ;Default indent to zero
- (save-excursion
- (if (or interactive-p (null buffer))
- (with-output-to-temp-buffer "*Disassemble*"
- (set-buffer "*Disassemble*")
- (disassemble-internal object indent (not interactive-p)))
- (set-buffer buffer)
- (disassemble-internal object indent nil)))
+ (let ((lb lexical-binding))
+ (if (and (consp object) (not (functionp object)))
+ (setq object `(lambda () ,object)))
+ (or indent (setq indent 0)) ;Default indent to zero
+ (save-excursion
+ (if (or interactive-p (null buffer))
+ (with-output-to-temp-buffer "*Disassemble*"
+ (set-buffer standard-output)
+ (let ((lexical-binding lb))
+ (disassemble-internal object indent (not interactive-p))))
+ (set-buffer buffer)
+ (let ((lexical-binding lb))
+ (disassemble-internal object indent nil)))))
nil)
(declare-function native-comp-unit-file "data.c")
@@ -188,8 +191,6 @@ OBJ should be a call to BYTE-CODE generated by the byte compiler."
(if (consp obj)
(setq bytes (car (cdr obj)) ;the byte code
constvec (car (cdr (cdr obj)))) ;constant vector
- ;; If it is lazy-loaded, load it now
- (fetch-bytecode obj)
(setq bytes (aref obj 1)
constvec (aref obj 2)))
(cl-assert (not (multibyte-string-p bytes)))
@@ -249,29 +250,22 @@ OBJ should be a call to BYTE-CODE generated by the byte compiler."
;; if the succeeding op is byte-switch, display the jump table
;; used
(cond ((eq (car-safe (car-safe (cdr lap))) 'byte-switch)
- (insert (format "<jump-table-%s (" (hash-table-test arg)))
- (let ((first-time t))
- (maphash #'(lambda (value tag)
- (if first-time
- (setq first-time nil)
- (insert " "))
- (insert (format "%s %s" value (cadr tag))))
- arg))
- (insert ")>"))
- ;; if the value of the constant is compiled code, then
- ;; recursively disassemble it.
- ((or (byte-code-function-p arg)
- (and (consp arg) (functionp arg)
- (assq 'byte-code arg))
+ (insert (format "<jump-table-%s (" (hash-table-test arg)))
+ (let ((first-time t))
+ (maphash #'(lambda (value tag)
+ (if first-time
+ (setq first-time nil)
+ (insert " "))
+ (insert (format "%s %s" value (cadr tag))))
+ arg))
+ (insert ")>"))
+ ;; if the value of the constant is compiled code, then
+ ;; recursively disassemble it.
+ ((or (byte-code-function-p arg)
(and (eq (car-safe arg) 'macro)
- (or (byte-code-function-p (cdr arg))
- (and (consp (cdr arg))
- (functionp (cdr arg))
- (assq 'byte-code (cdr arg))))))
+ (byte-code-function-p (cdr arg))))
(cond ((byte-code-function-p arg)
(insert "<compiled-function>\n"))
- ((functionp arg)
- (insert "<compiled lambda>"))
(t (insert "<compiled macro>\n")))
(disassemble-internal
arg
@@ -284,7 +278,7 @@ OBJ should be a call to BYTE-CODE generated by the byte compiler."
(+ indent disassemble-recursive-indent)))
((eq (car-safe (car-safe arg)) 'byte-code)
(insert "(<byte code>...)\n")
- (mapc ;recurse on list of byte-code objects
+ (mapc ;Recurse on list of byte-code objects.
(lambda (obj)
(disassemble-1
obj
@@ -298,6 +292,23 @@ OBJ should be a call to BYTE-CODE generated by the byte compiler."
(insert "\n")))))
nil)
+(defun re-disassemble (regexp &optional case-table)
+ "Describe the compiled form of REGEXP in a separate window.
+If CASE-TABLE is non-nil, use it as translation table for case-folding.
+
+This function is mainly intended for maintenance of Emacs itself
+and may change at any time. It requires Emacs to be built with
+`--enable-checking'."
+ (interactive "XRegexp (Lisp expression): ")
+ (let ((desc (with-temp-buffer
+ (when case-table
+ (set-case-table case-table))
+ (let ((case-fold-search (and case-table t)))
+ (re--describe-compiled regexp)))))
+ (with-output-to-temp-buffer "*Regexp-disassemble*"
+ (with-current-buffer standard-output
+ (insert desc)))))
+
(provide 'disass)
;;; disass.el ends here
diff --git a/lisp/emacs-lisp/easy-mmode.el b/lisp/emacs-lisp/easy-mmode.el
index da63a0db925..4fa05008dd8 100644
--- a/lisp/emacs-lisp/easy-mmode.el
+++ b/lisp/emacs-lisp/easy-mmode.el
@@ -132,7 +132,7 @@ it is disabled.")
(string-replace "'" "\\='" (format "%S" getter)))))
(let ((start (point)))
(insert argdoc)
- (when (fboundp 'fill-region)
+ (when (fboundp 'fill-region) ;Don't break bootstrap!
(fill-region start (point) 'left t))))
;; Finally, insert the keymap.
(when (and (boundp keymap-sym)
@@ -143,8 +143,6 @@ it is disabled.")
(buffer-string)))))
;;;###autoload
-(defalias 'easy-mmode-define-minor-mode #'define-minor-mode)
-;;;###autoload
(defmacro define-minor-mode (mode doc &rest body)
"Define a new minor mode MODE.
This defines the toggle command MODE and (by default) a control variable
@@ -250,7 +248,8 @@ INIT-VALUE LIGHTER KEYMAP.
(warnwrap (if (or (null body) (keywordp (car body))) #'identity
(lambda (exp)
(macroexp-warn-and-return
- "Use keywords rather than deprecated positional arguments to `define-minor-mode'"
+ (format-message
+ "Use keywords rather than deprecated positional arguments to `define-minor-mode'")
exp))))
keyw keymap-sym tmp)
@@ -417,6 +416,8 @@ No problems result if this variable is not bound.
`(defvar ,keymap-sym
(let ((m ,keymap))
(cond ((keymapp m) m)
+ ;; FIXME: `easy-mmode-define-keymap' is obsolete,
+ ;; so this form should also be obsolete somehow.
((listp m)
(with-suppressed-warnings ((obsolete
easy-mmode-define-keymap))
@@ -440,8 +441,6 @@ No problems result if this variable is not bound.
;;;
;;;###autoload
-(defalias 'easy-mmode-define-global-mode #'define-globalized-minor-mode)
-;;;###autoload
(defalias 'define-global-minor-mode #'define-globalized-minor-mode)
;;;###autoload
(defmacro define-globalized-minor-mode (global-mode mode turn-on &rest body)
@@ -662,7 +661,7 @@ list."
(throw 'found nil))
((and (consp elem)
(eq (car elem) 'not))
- (when (apply #'derived-mode-p (cdr elem))
+ (when (derived-mode-p (cdr elem))
(throw 'found nil)))
((symbolp elem)
(when (derived-mode-p elem)
@@ -693,6 +692,7 @@ Valid keywords and arguments are:
:group Ignored.
:suppress Non-nil to call `suppress-keymap' on keymap,
`nodigits' to suppress digits as prefix arguments."
+ (declare (obsolete define-keymap "29.1"))
(let (inherit dense suppress)
(while args
(let ((key (pop args))
@@ -733,9 +733,7 @@ The M, BS, and ARGS arguments are as per that function. DOC is
the constant's documentation.
This macro is deprecated; use `defvar-keymap' instead."
- ;; FIXME: Declare obsolete in favor of `defvar-keymap'. It is still
- ;; used for `gud-menu-map' and `gud-minor-mode-map', so fix that first.
- (declare (doc-string 3) (indent 1))
+ (declare (doc-string 3) (indent 1) (obsolete defvar-keymap "29.1"))
`(defconst ,m
(easy-mmode-define-keymap ,bs nil (if (boundp ',m) ,m) ,(cons 'list args))
,doc))
@@ -839,6 +837,12 @@ Interactively, COUNT is the prefix numeric argument, and defaults to 1."
,@body))
(put ',prev-sym 'definition-name ',base))))
+;; When deleting these two, also delete them from loaddefs-gen.el.
+;;;###autoload
+(define-obsolete-function-alias 'easy-mmode-define-minor-mode #'define-minor-mode "30.1")
+;;;###autoload
+(define-obsolete-function-alias 'easy-mmode-define-global-mode #'define-globalized-minor-mode "30.1")
+
(provide 'easy-mmode)
;;; easy-mmode.el ends here
diff --git a/lisp/emacs-lisp/edebug.el b/lisp/emacs-lisp/edebug.el
index 623b1c6a8c9..b27ffbca908 100644
--- a/lisp/emacs-lisp/edebug.el
+++ b/lisp/emacs-lisp/edebug.el
@@ -485,7 +485,7 @@ just FUNCTION is printed."
(edebug--eval-defun #'eval-defun edebug-it)))
;;;###autoload
-(defalias 'edebug-defun 'edebug-eval-top-level-form)
+(defalias 'edebug-defun #'edebug-eval-top-level-form)
;;;###autoload
(defun edebug-eval-top-level-form ()
@@ -1229,8 +1229,12 @@ purpose by adding an entry to this alist, and setting
;; But the list will just be reversed.
,@(nreverse edebug-def-args))
'nil)
- (function (lambda () ,@forms))
- ))
+ #'(lambda ()
+ ;; Mark the closure so we don't throw away unused vars (bug#59213).
+ :closure-dont-trim-context
+ ;; Make sure `forms' is not nil so we don't accidentally return
+ ;; the magic keyword.
+ ,@(or forms '(nil)))))
(defvar edebug-form-begin-marker) ; the mark for def being instrumented
@@ -1268,55 +1272,48 @@ Does not unwrap inside vectors, records, structures, or hash tables."
(pcase sexp
(`(edebug-after ,_before-form ,_after-index ,form)
form)
- (`(lambda ,args (edebug-enter ',_sym ,_arglist
- (function (lambda nil . ,body))))
- `(lambda ,args ,@body))
- (`(closure ,env ,args (edebug-enter ',_sym ,_arglist
- (function (lambda nil . ,body))))
- `(closure ,env ,args ,@body))
- (`(edebug-enter ',_sym ,_args (function (lambda nil . ,body)))
+ (`(edebug-enter ',_sym ,_args
+ #'(lambda nil :closure-dont-trim-context . ,body))
(macroexp-progn body))
(_ sexp)))
+(defconst edebug--unwrap-cache
+ (make-hash-table :test 'eq :weakness 'key)
+ "Hash-table containing the results of unwrapping cons cells.
+These results are reused to avoid redundant work but also to avoid
+infinite loops when the code/environment contains a circular object.")
+
(defun edebug-unwrap* (sexp)
"Return the SEXP recursively unwrapped."
- (let ((ht (make-hash-table :test 'eq)))
- (edebug--unwrap1 sexp ht)))
-
-(defun edebug--unwrap1 (sexp hash-table)
- "Unwrap SEXP using HASH-TABLE of things already unwrapped.
-HASH-TABLE contains the results of unwrapping cons cells within
-SEXP, which are reused to avoid infinite loops when SEXP is or
-contains a circular object."
- (let ((new-sexp (edebug-unwrap sexp)))
- (while (not (eq sexp new-sexp))
- (setq sexp new-sexp
- new-sexp (edebug-unwrap sexp)))
- (if (consp new-sexp)
- (let ((result (gethash new-sexp hash-table nil)))
- (unless result
- (let ((remainder new-sexp)
- current)
- (setq result (cons nil nil)
- current result)
- (while
- (progn
- (puthash remainder current hash-table)
- (setf (car current)
- (edebug--unwrap1 (car remainder) hash-table))
- (setq remainder (cdr remainder))
- (cond
- ((atom remainder)
- (setf (cdr current)
- (edebug--unwrap1 remainder hash-table))
- nil)
- ((gethash remainder hash-table nil)
- (setf (cdr current) (gethash remainder hash-table nil))
- nil)
- (t (setq current
- (setf (cdr current) (cons nil nil)))))))))
- result)
- new-sexp)))
+ (while (not (eq sexp (setq sexp (edebug-unwrap sexp)))))
+ (cond
+ ((consp sexp)
+ (or (gethash sexp edebug--unwrap-cache nil)
+ (let ((remainder sexp)
+ (current (cons nil nil)))
+ (prog1 current
+ (while
+ (progn
+ (puthash remainder current edebug--unwrap-cache)
+ (setf (car current)
+ (edebug-unwrap* (car remainder)))
+ (setq remainder (cdr remainder))
+ (cond
+ ((atom remainder)
+ (setf (cdr current)
+ (edebug-unwrap* remainder))
+ nil)
+ ((gethash remainder edebug--unwrap-cache nil)
+ (setf (cdr current) (gethash remainder edebug--unwrap-cache nil))
+ nil)
+ (t (setq current
+ (setf (cdr current) (cons nil nil)))))))))))
+ ((byte-code-function-p sexp)
+ (apply #'make-byte-code
+ (aref sexp 0) (aref sexp 1)
+ (vconcat (mapcar #'edebug-unwrap* (aref sexp 2)))
+ (nthcdr 3 (append sexp ()))))
+ (t sexp)))
(defun edebug-defining-form (cursor form-begin form-end speclist)
@@ -1546,9 +1543,7 @@ contains a circular object."
(defun edebug-list-form (cursor)
;; Return an instrumented form built from the list form.
;; The after offset will be left in the cursor after processing the form.
- (let ((head (edebug-top-element-required cursor "Expected elements"))
- ;; Prevent backtracking whenever instrumenting.
- (edebug-gate t))
+ (let ((head (edebug-top-element-required cursor "Expected elements")))
;; Skip the first offset.
(edebug-set-cursor cursor (edebug-cursor-expressions cursor)
(cdr (edebug-cursor-offsets cursor)))
@@ -1733,7 +1728,7 @@ contains a circular object."
(defun edebug-match-form (cursor)
(list (edebug-form cursor)))
-(defalias 'edebug-match-place 'edebug-match-form)
+(defalias 'edebug-match-place #'edebug-match-form)
;; Currently identical to edebug-match-form.
;; This is for common lisp setf-style place arguments.
@@ -2281,12 +2276,7 @@ only be active while Edebug is. It checks `debug-on-error' to see
whether it should call the debugger. When execution is resumed, the
error is signaled again."
(if (and (listp debug-on-error) (memq signal-name debug-on-error))
- (edebug 'error (cons signal-name signal-data)))
- ;; If we reach here without another non-local exit, then send signal again.
- ;; i.e. the signal is not continuable, yet.
- ;; Avoid infinite recursion.
- (let ((signal-hook-function nil))
- (signal signal-name signal-data)))
+ (edebug 'error (cons signal-name signal-data))))
;;; Entering Edebug
@@ -2330,6 +2320,12 @@ and run its entry function, and set up `edebug-before' and
(debug-on-error (or debug-on-error edebug-on-error))
(debug-on-quit edebug-on-quit))
(unwind-protect
+ ;; FIXME: We could replace this `signal-hook-function' with
+ ;; a cleaner `handler-bind' but then we wouldn't be able to
+ ;; install it here (i.e. once and for all when entering
+ ;; an Edebugged function), but instead it would have to
+ ;; be installed into a modified `edebug-after' which wraps
+ ;; the `handler-bind' around its argument(s). :-(
(let ((signal-hook-function #'edebug-signal))
(setq edebug-execution-mode (or edebug-next-execution-mode
edebug-initial-mode
@@ -2471,12 +2467,52 @@ MSG is printed after `::::} '."
(setf (cdr (assq 'edebug edebug-behavior-alist))
'(edebug-default-enter edebug-fast-before edebug-fast-after)))
-(defalias 'edebug-before nil
+;; The following versions of `edebug-before' and `edebug-after' exist
+;; to handle the error which occurs if either of them gets called
+;; without an enclosing `edebug-enter'. This can happen, for example,
+;; when a macro mistakenly has a `form' element in its edebug spec,
+;; and it additionally, at macro-expansion time, calls `eval',
+;; `apply', or `funcall' (etc.) on the corresponding argument. This
+;; is intended to fix bug#65620.
+
+(defun edebug-b/a-error (func)
+ "Throw an error for an invalid call of FUNC.
+FUNC is expected to be `edebug-before' or `edebug-after'."
+ (let (this-macro
+ (n 0)
+ bt-frame)
+ (while (and (setq bt-frame (backtrace-frame n))
+ (not (and (car bt-frame)
+ (memq (cadr bt-frame)
+ '(macroexpand macroexpand-1)))))
+ (setq n (1+ n)))
+ (when bt-frame
+ (setq this-macro (caaddr bt-frame)))
+
+ (error
+ (concat "Invalid call to `" (symbol-name func) "'"
+ (if this-macro
+ (concat ". Is the edebug spec for `"
+ (symbol-name this-macro)
+ "' correct?")
+ "" ; Not sure this case is possible (ACM, 2023-09-02)
+ )))))
+
+(defun edebug-before (_before-index)
"Function called by Edebug before a form is evaluated.
-See `edebug-behavior-alist' for implementations.")
-(defalias 'edebug-after nil
+See `edebug-behavior-alist' for other implementations. This
+version of `edebug-before' gets called when edebug is not yet set
+up. `edebug-enter' binds the function cell to a real function
+when edebug becomes active."
+ (edebug-b/a-error 'edebug-before))
+
+(defun edebug-after (_before-index _after-index _form)
"Function called by Edebug after a form is evaluated.
-See `edebug-behavior-alist' for implementations.")
+See `edebug-behavior-alist' for other implementations. This
+version of `edebug-after' gets called when edebug is not yet set
+up. `edebug-enter' binds the function cell to a real function
+when edebug becomes active."
+ (edebug-b/a-error 'edebug-after))
(defun edebug--update-coverage (after-index value)
(let ((old-result (aref edebug-coverage after-index)))
@@ -2855,81 +2891,81 @@ See `edebug-behavior-alist' for implementations.")
edebug-inside-windows
)
- (unwind-protect
- (let (
- ;; Declare global values local but using the same global value.
- ;; We could set these to the values for previous edebug call.
- (last-command last-command)
- (this-command this-command)
- (current-prefix-arg nil)
-
- (last-input-event nil)
- (last-command-event nil)
- (last-event-frame nil)
- (last-nonmenu-event nil)
- (track-mouse nil)
-
- (standard-output t)
- (standard-input t)
-
- ;; Don't keep reading from an executing kbd macro
- ;; within edebug unless edebug-continue-kbd-macro is
- ;; non-nil. Again, local binding may not be best.
- (executing-kbd-macro
- (if edebug-continue-kbd-macro executing-kbd-macro))
-
- ;; Don't get confused by the user's keymap changes.
- (overriding-local-map nil)
- (overriding-terminal-local-map nil)
- ;; Override other minor modes that may bind the keys
- ;; edebug uses.
- (minor-mode-overriding-map-alist
- (list (cons 'edebug-mode edebug-mode-map)))
-
- ;; Bind again to outside values.
- (debug-on-error edebug-outside-debug-on-error)
- (debug-on-quit edebug-outside-debug-on-quit)
-
- ;; Don't keep defining a kbd macro.
- (defining-kbd-macro
- (if edebug-continue-kbd-macro defining-kbd-macro))
-
- ;; others??
- )
-
- (if (and (eq edebug-execution-mode 'go)
- (not (memq arg-mode '(after error))))
- (message "Break"))
-
- (setq signal-hook-function nil)
- (edebug-mode 1)
- (unwind-protect
- (recursive-edit) ; <<<<<<<<<< Recursive edit
-
- ;; Do the following, even if quit occurs.
- (setq signal-hook-function #'edebug-signal)
- (if edebug-backtrace-buffer
- (kill-buffer edebug-backtrace-buffer))
-
- ;; Remember selected-window after recursive-edit.
- ;; (setq edebug-inside-window (selected-window))
-
- (set-match-data edebug-outside-match-data)
+ (let (
+ ;; Declare global values local but using the same global value.
+ ;; We could set these to the values for previous edebug call.
+ (last-command last-command)
+ (this-command this-command)
+ (current-prefix-arg nil)
+
+ (last-input-event nil)
+ (last-command-event nil)
+ (last-event-frame nil)
+ (last-nonmenu-event nil)
+ (track-mouse nil)
+
+ (standard-output t)
+ (standard-input t)
+
+ ;; Don't keep reading from an executing kbd macro
+ ;; within edebug unless edebug-continue-kbd-macro is
+ ;; non-nil. Again, local binding may not be best.
+ (executing-kbd-macro
+ (if edebug-continue-kbd-macro executing-kbd-macro))
+
+ ;; Don't get confused by the user's keymap changes.
+ (overriding-local-map nil)
+ (overriding-terminal-local-map nil)
+ ;; Override other minor modes that may bind the keys
+ ;; edebug uses.
+ (minor-mode-overriding-map-alist
+ (list (cons 'edebug-mode edebug-mode-map)))
+
+ ;; Bind again to outside values.
+ (debug-on-error edebug-outside-debug-on-error)
+ (debug-on-quit edebug-outside-debug-on-quit)
+
+ ;; Don't keep defining a kbd macro.
+ (defining-kbd-macro
+ (if edebug-continue-kbd-macro defining-kbd-macro))
+
+ ;; others??
+ )
- ;; Recursive edit may have changed buffers,
- ;; so set it back before exiting let.
- (if (buffer-name edebug-buffer) ; if it still exists
- (progn
- (set-buffer edebug-buffer)
- (when (memq edebug-execution-mode '(go Go-nonstop))
- (edebug-overlay-arrow)
- (sit-for 0))
- (edebug-mode -1))
- ;; gotta have a buffer to let its buffer local variables be set
- (get-buffer-create " bogus edebug buffer"))
- ));; inner let
- )))
+ (if (and (eq edebug-execution-mode 'go)
+ (not (memq arg-mode '(after error))))
+ (message "Break"))
+
+ (setq signal-hook-function nil)
+
+ (edebug-mode 1)
+ (unwind-protect
+ (recursive-edit) ; <<<<<<<<<< Recursive edit
+
+ ;; Do the following, even if quit occurs.
+ (setq signal-hook-function #'edebug-signal)
+ (if edebug-backtrace-buffer
+ (kill-buffer edebug-backtrace-buffer))
+
+ ;; Remember selected-window after recursive-edit.
+ ;; (setq edebug-inside-window (selected-window))
+
+ (set-match-data edebug-outside-match-data)
+
+ ;; Recursive edit may have changed buffers,
+ ;; so set it back before exiting let.
+ (if (buffer-name edebug-buffer) ; if it still exists
+ (progn
+ (set-buffer edebug-buffer)
+ (when (memq edebug-execution-mode '(go Go-nonstop))
+ (edebug-overlay-arrow)
+ (sit-for 0))
+ (edebug-mode -1))
+ ;; gotta have a buffer to let its buffer local variables be set
+ (get-buffer-create " bogus edebug buffer"))
+ ));; inner let
+ ))
;;; Display related functions
@@ -3312,7 +3348,7 @@ With prefix argument, make it a temporary breakpoint."
(message "%s" msg)))
-(defalias 'edebug-step-through-mode 'edebug-step-mode)
+(defalias 'edebug-step-through-mode #'edebug-step-mode)
(defun edebug-step-mode ()
"Proceed to next stop point."
@@ -3800,12 +3836,12 @@ be installed in `emacs-lisp-mode-map'.")
;; Global GUD bindings for all emacs-lisp-mode buffers.
(unless edebug-inhibit-emacs-lisp-mode-bindings
- (define-key emacs-lisp-mode-map "\C-x\C-a\C-s" 'edebug-step-mode)
- (define-key emacs-lisp-mode-map "\C-x\C-a\C-n" 'edebug-next-mode)
- (define-key emacs-lisp-mode-map "\C-x\C-a\C-c" 'edebug-go-mode)
- (define-key emacs-lisp-mode-map "\C-x\C-a\C-l" 'edebug-where)
+ (define-key emacs-lisp-mode-map "\C-x\C-a\C-s" #'edebug-step-mode)
+ (define-key emacs-lisp-mode-map "\C-x\C-a\C-n" #'edebug-next-mode)
+ (define-key emacs-lisp-mode-map "\C-x\C-a\C-c" #'edebug-go-mode)
+ (define-key emacs-lisp-mode-map "\C-x\C-a\C-l" #'edebug-where)
;; The following isn't a GUD binding.
- (define-key emacs-lisp-mode-map "\C-x\C-a\C-m" 'edebug-set-initial-mode))
+ (define-key emacs-lisp-mode-map "\C-x\C-a\C-m" #'edebug-set-initial-mode))
(defvar-keymap edebug-mode-map
:parent emacs-lisp-mode-map
@@ -4198,13 +4234,13 @@ Remove frames for Edebug's functions and the lambdas in
and after-index fields in both FRAMES and the returned list
of deinstrumented frames, for those frames where the source
code location is known."
- (let (skip-next-lambda def-name before-index after-index results
- (index (length frames)))
+ (let ((index (length frames))
+ skip-next-lambda def-name before-index after-index results)
(dolist (frame (reverse frames))
(let ((new-frame (copy-edebug--frame frame))
(fun (edebug--frame-fun frame))
(args (edebug--frame-args frame)))
- (cl-decf index)
+ (cl-decf index) ;; FIXME: Not used?
(pcase fun
('edebug-enter
(setq skip-next-lambda t
@@ -4214,38 +4250,46 @@ code location is known."
(nth 1 (nth 0 args))
(nth 0 args))
after-index (nth 1 args)))
- ((pred edebug--symbol-not-prefixed-p)
- (edebug--unwrap-frame new-frame)
- (edebug--add-source-info new-frame def-name before-index after-index)
- (edebug--add-source-info frame def-name before-index after-index)
- (push new-frame results)
- (setq before-index nil
- after-index nil))
- (`(,(or 'lambda 'closure) . ,_)
+ ;; Just skip all our own frames.
+ ((pred edebug--symbol-prefixed-p) nil)
+ (_
+ (when (and skip-next-lambda
+ (not (memq (car-safe fun) '(closure lambda))))
+ (warn "Edebug--strip-instrumentation expected an interpreted function:\n%S" fun))
(unless skip-next-lambda
(edebug--unwrap-frame new-frame)
- (edebug--add-source-info frame def-name before-index after-index)
(edebug--add-source-info new-frame def-name before-index after-index)
+ (edebug--add-source-info frame def-name before-index after-index)
(push new-frame results))
- (setq before-index nil
+ (setq before-index nil
after-index nil
skip-next-lambda nil)))))
results))
-(defun edebug--symbol-not-prefixed-p (sym)
- "Return non-nil if SYM is a symbol not prefixed by \"edebug-\"."
+(defun edebug--symbol-prefixed-p (sym)
+ "Return non-nil if SYM is a symbol prefixed by \"edebug-\"."
(and (symbolp sym)
- (not (string-prefix-p "edebug-" (symbol-name sym)))))
+ (string-prefix-p "edebug-" (symbol-name sym))))
(defun edebug--unwrap-frame (frame)
"Remove Edebug's instrumentation from FRAME.
Strip it from the function and any unevaluated arguments."
- (setf (edebug--frame-fun frame) (edebug-unwrap* (edebug--frame-fun frame)))
- (unless (edebug--frame-evald frame)
- (let (results)
- (dolist (arg (edebug--frame-args frame))
- (push (edebug-unwrap* arg) results))
- (setf (edebug--frame-args frame) (nreverse results)))))
+ (cl-callf edebug-unwrap* (edebug--frame-fun frame))
+ ;; We used to try to be careful to apply `edebug-unwrap' only to source
+ ;; expressions and not to values, so we did not apply unwrap to the arguments
+ ;; of the frame if they had already been evaluated.
+ ;; But this was not careful enough since `edebug-unwrap*' gleefully traverses
+ ;; its argument without paying attention to its syntactic structure so it
+ ;; also "mistakenly" descends into the values contained within the "source
+ ;; code". In practice this *very* rarely leads to undesired results.
+ ;; On the contrary, it's often useful to descend into values because they
+ ;; may contain interpreted closures and hence source code where we *do*
+ ;; want to apply `edebug-unwrap'.
+ ;; So based on this experience, we now also apply `edebug-unwrap*' to
+ ;; the already evaluated arguments.
+ ;;(unless (edebug--frame-evald frame)
+ (cl-callf (lambda (xs) (mapcar #'edebug-unwrap* xs))
+ (edebug--frame-args frame)))
(defun edebug--add-source-info (frame def-name before-index after-index)
"Update FRAME with the additional info needed by an edebug--frame.
diff --git a/lisp/emacs-lisp/eieio-core.el b/lisp/emacs-lisp/eieio-core.el
index d6188a8c238..cf8bd749f2a 100644
--- a/lisp/emacs-lisp/eieio-core.el
+++ b/lisp/emacs-lisp/eieio-core.el
@@ -191,7 +191,7 @@ Abstract classes cannot be instantiated."
;; We autoload this because it's used in `make-autoload'.
;;;###autoload
-(defun eieio-defclass-autoload (cname _superclasses filename doc)
+(defun eieio-defclass-autoload (cname superclasses filename doc)
"Create autoload symbols for the EIEIO class CNAME.
SUPERCLASSES are the superclasses that CNAME inherits from.
DOC is the docstring for CNAME.
@@ -199,15 +199,9 @@ This function creates a mock-class for CNAME and adds it into
SUPERCLASSES as children.
It creates an autoload function for CNAME's constructor."
;; Assume we've already debugged inputs.
-
- ;; We used to store the list of superclasses in the `parent' slot (as a list
- ;; of class names). But now this slot holds a list of class objects, and
- ;; those parents may not exist yet, so the corresponding class objects may
- ;; simply not exist yet. So instead we just don't store the list of parents
- ;; here in eieio-defclass-autoload at all, since it seems that they're just
- ;; not needed before the class is actually loaded.
(let* ((oldc (cl--find-class cname))
- (newc (eieio--class-make cname)))
+ (newc (eieio--class-make cname))
+ (parents (mapcar #'cl-find-class superclasses)))
(if (eieio--class-p oldc)
nil ;; Do nothing if we already have this class.
@@ -218,6 +212,12 @@ It creates an autoload function for CNAME's constructor."
use '%s or turn off `eieio-backward-compatibility' instead" cname)
"25.1"))
+ (when (memq nil parents)
+ ;; If some parents aren't yet fully defined, just ignore them for now.
+ (setq parents (delq nil parents)))
+ (unless parents
+ (setq parents (list (cl--find-class 'eieio-default-superclass))))
+ (setf (cl--class-parents newc) parents)
(setf (cl--find-class cname) newc)
;; Create an autoload on top of our constructor function.
@@ -293,8 +293,7 @@ See `defclass' for more information."
;; reloading the file that does the `defclass', we don't
;; want to create a new class object.
(eieio--class-make cname)))
- (groups nil) ;; list of groups id'd from slots
- (clearparent nil))
+ (groups nil)) ;; list of groups id'd from slots
;; If this class already existed, and we are updating its structure,
;; make sure we keep the old child list. This can cause bugs, but
@@ -317,6 +316,9 @@ See `defclass' for more information."
(setf (eieio--class-children newc) children)
(remhash cname eieio-defclass-autoload-map))))
+ (unless (or superclasses (eq cname 'eieio-default-superclass))
+ (setq superclasses '(eieio-default-superclass)))
+
(if superclasses
(progn
(dolist (p superclasses)
@@ -336,16 +338,13 @@ See `defclass' for more information."
(push c (eieio--class-parents newc))))))
;; Reverse the list of our parents so that they are prioritized in
;; the same order as specified in the code.
- (cl-callf nreverse (eieio--class-parents newc)))
- ;; If there is nothing to loop over, then inherit from the
- ;; default superclass.
- (unless (eq cname 'eieio-default-superclass)
- ;; adopt the default parent here, but clear it later...
- (setq clearparent t)
- ;; save new child in parent
- (cl-pushnew cname (eieio--class-children eieio-default-superclass))
- ;; save parent in child
- (setf (eieio--class-parents newc) (list eieio-default-superclass))))
+ (cl-callf nreverse (eieio--class-parents newc))
+ ;; Before adding new slots, let's add all the methods and classes
+ ;; in from the parent class.
+ (eieio-copy-parents-into-subclass newc))
+
+ (cl-assert (eq cname 'eieio-default-superclass))
+ (setf (eieio--class-parents newc) (list (cl--find-class 'record))))
;; turn this into a usable self-pointing symbol; FIXME: Why?
(when eieio-backward-compatibility
@@ -376,10 +375,6 @@ See `defclass' for more information."
cname)
"25.1")))
- ;; Before adding new slots, let's add all the methods and classes
- ;; in from the parent class.
- (eieio-copy-parents-into-subclass newc)
-
;; Store the new class vector definition into the symbol. We need to
;; do this first so that we can call defmethod for the accessor.
;; The vector will be updated by the following while loop and will not
@@ -512,10 +507,6 @@ See `defclass' for more information."
;; Set up the options we have collected.
(setf (eieio--class-options newc) options)
- ;; if this is a superclass, clear out parent (which was set to the
- ;; default superclass eieio-default-superclass)
- (if clearparent (setf (eieio--class-parents newc) nil))
-
;; Create the cached default object.
(let ((cache (make-record newc
(+ (length (eieio--class-slots newc))
@@ -951,7 +942,10 @@ not nil."
(let ((slots (eieio--class-slots (eieio--object-class obj))))
(dotimes (i (length slots))
(let* ((name (cl--slot-descriptor-name (aref slots i)))
- (df (eieio-oref-default obj name)))
+ ;; If the `:initform` signals an error, just skip it,
+ ;; since the error is intended to be signal'ed from
+ ;; `initialize-instance` rather than at the time of `defclass`.
+ (df (ignore-errors (eieio-oref-default obj name))))
(if (or df set-all)
(eieio-oset obj name df))))))
@@ -964,80 +958,31 @@ need be... May remove that later...)"
(cdr tuple)
nil)))
-;;;
-;; Method Invocation order: C3
-(defun eieio--c3-candidate (class remaining-inputs)
- "Return CLASS if it can go in the result now, otherwise nil."
- ;; Ensure CLASS is not in any position but the first in any of the
- ;; element lists of REMAINING-INPUTS.
- (and (not (let ((found nil))
- (while (and remaining-inputs (not found))
- (setq found (member class (cdr (car remaining-inputs)))
- remaining-inputs (cdr remaining-inputs)))
- found))
- class))
-
-(defun eieio--c3-merge-lists (reversed-partial-result remaining-inputs)
- "Try to merge REVERSED-PARTIAL-RESULT REMAINING-INPUTS in a consistent order.
-If a consistent order does not exist, signal an error."
- (setq remaining-inputs (delq nil remaining-inputs))
- (if (null remaining-inputs)
- ;; If all remaining inputs are empty lists, we are done.
- (nreverse reversed-partial-result)
- ;; Otherwise, we try to find the next element of the result. This
- ;; is achieved by considering the first element of each
- ;; (non-empty) input list and accepting a candidate if it is
- ;; consistent with the rests of the input lists.
- (let* ((found nil)
- (tail remaining-inputs)
- (next (progn
- (while (and tail (not found))
- (setq found (eieio--c3-candidate (caar tail)
- remaining-inputs)
- tail (cdr tail)))
- found)))
- (if next
- ;; The graph is consistent so far, add NEXT to result and
- ;; merge input lists, dropping NEXT from their heads where
- ;; applicable.
- (eieio--c3-merge-lists
- (cons next reversed-partial-result)
- (mapcar (lambda (l) (if (eq (cl-first l) next) (cl-rest l) l))
- remaining-inputs))
- ;; The graph is inconsistent, give up
- (signal 'inconsistent-class-hierarchy (list remaining-inputs))))))
-
-(defsubst eieio--class/struct-parents (class)
- (or (eieio--class-parents class)
- `(,eieio-default-superclass)))
-
(defun eieio--class-precedence-c3 (class)
"Return all parents of CLASS in c3 order."
- (let ((parents (eieio--class-parents class)))
- (eieio--c3-merge-lists
- (list class)
- (append
- (or
- (mapcar #'eieio--class-precedence-c3 parents)
- `((,eieio-default-superclass)))
- (list parents))))
- )
+ (let ((parents (cl--class-parents class)))
+ (cons class
+ (merge-ordered-lists
+ (append
+ (mapcar #'eieio--class-precedence-c3 parents)
+ (list parents))
+ (lambda (remaining-inputs)
+ (signal 'inconsistent-class-hierarchy
+ (list remaining-inputs)))))))
;;;
;; Method Invocation Order: Depth First
(defun eieio--class-precedence-dfs (class)
"Return all parents of CLASS in depth-first order."
- (let* ((parents (eieio--class-parents class))
+ (let* ((parents (cl--class-parents class))
(classes (copy-sequence
(apply #'append
(list class)
- (or
- (mapcar
- (lambda (parent)
- (cons parent
- (eieio--class-precedence-dfs parent)))
- parents)
- `((,eieio-default-superclass))))))
+ (mapcar
+ (lambda (parent)
+ (cons parent
+ (eieio--class-precedence-dfs parent)))
+ parents))))
(tail classes))
;; Remove duplicates.
(while tail
@@ -1050,13 +995,12 @@ If a consistent order does not exist, signal an error."
(defun eieio--class-precedence-bfs (class)
"Return all parents of CLASS in breadth-first order."
(let* ((result)
- (queue (eieio--class/struct-parents class)))
+ (queue (cl--class-parents class)))
(while queue
(let ((head (pop queue)))
(unless (member head result)
(push head result)
- (unless (eq head eieio-default-superclass)
- (setq queue (append queue (eieio--class/struct-parents head)))))))
+ (setq queue (append queue (cl--class-parents head))))))
(cons class (nreverse result)))
)
@@ -1096,6 +1040,14 @@ method invocation orders of the involved classes."
;;;; General support to dispatch based on the type of the argument.
+;; FIXME: We could almost use the typeof-generalizer (i.e. the same as
+;; used for cl-structs), except that that generalizer doesn't support
+;; `:method-invocation-order' :-(
+
+(defun cl--generic-struct-tag (name &rest _)
+ ;; Use exactly the same code as for `typeof'.
+ `(cl-type-of ,name))
+
(cl-generic-define-generalizer eieio--generic-generalizer
;; Use the exact same tagcode as for cl-struct, so that methods
;; that dispatch on both kinds of objects get to share this
@@ -1104,8 +1056,7 @@ method invocation orders of the involved classes."
(lambda (tag &rest _)
(let ((class (cl--find-class tag)))
(and (eieio--class-p class)
- (mapcar #'eieio--class-name
- (eieio--class-precedence-list class))))))
+ (cl--class-allparents class)))))
(cl-defmethod cl-generic-generalizers :extra "class" (specializer)
"Support for dispatch on types defined by EIEIO's `defclass'."
@@ -1127,10 +1078,11 @@ method invocation orders of the involved classes."
;; Instead, we add a new "subclass" specializer.
(defun eieio--generic-subclass-specializers (tag &rest _)
- (when (eieio--class-p tag)
- (mapcar (lambda (class)
- `(subclass ,(eieio--class-name class)))
- (eieio--class-precedence-list tag))))
+ (when (cl--class-p tag)
+ (when (eieio--class-p tag)
+ (setq tag (eieio--full-class-object tag))) ;Autoload, if applicable.
+ (mapcar (lambda (class) `(subclass ,class))
+ (cl--class-allparents tag))))
(cl-generic-define-generalizer eieio--generic-subclass-generalizer
60 (lambda (name &rest _) `(and (symbolp ,name) (cl--find-class ,name)))
diff --git a/lisp/emacs-lisp/eieio-opt.el b/lisp/emacs-lisp/eieio-opt.el
index 893f8cd7e7f..bf6be1690e4 100644
--- a/lisp/emacs-lisp/eieio-opt.el
+++ b/lisp/emacs-lisp/eieio-opt.el
@@ -50,7 +50,7 @@ variable `eieio-default-superclass'."
(if (not root-class) (setq root-class 'eieio-default-superclass))
(cl-check-type root-class class)
(display-buffer (get-buffer-create "*EIEIO OBJECT BROWSE*") t)
- (with-current-buffer (get-buffer "*EIEIO OBJECT BROWSE*")
+ (with-current-buffer "*EIEIO OBJECT BROWSE*"
(erase-buffer)
(goto-char 0)
(eieio-browse-tree root-class "" "")
diff --git a/lisp/emacs-lisp/eieio.el b/lisp/emacs-lisp/eieio.el
index edc0c34ad3a..74f5e21db7d 100644
--- a/lisp/emacs-lisp/eieio.el
+++ b/lisp/emacs-lisp/eieio.el
@@ -184,8 +184,9 @@ and reference them using the function `class-option'."
(when (and initarg (eq alloc :class))
(push
(cons sname
- (format "Meaningless :initarg for class allocated slot '%S'"
- sname))
+ (format-message
+ "Meaningless :initarg for class allocated slot `%S'"
+ sname))
warnings))
(let ((init (plist-get soptions :initform)))
@@ -212,9 +213,8 @@ and reference them using the function `class-option'."
,(internal--format-docstring-line
"Retrieve the slot `%S' from an object of class `%S'."
sname name)
- ;; FIXME: Why is this different from the :reader case?
- (if (slot-boundp this ',sname) (eieio-oref this ',sname)))
- accessors)
+ (slot-value this ',sname))
+ accessors)
(when (and eieio-backward-compatibility (eq alloc :class))
;; FIXME: How could I declare this *method* as obsolete.
(push `(cl-defmethod ,acces ((this (subclass ,name)))
@@ -387,9 +387,9 @@ contents of field NAME is matched against PAT, or they can be of
,@(mapcar (lambda (field)
(pcase-exhaustive field
(`(,name ,pat)
- `(app (pcase--flip eieio-oref ',name) ,pat))
+ `(app (eieio-oref _ ',name) ,pat))
((pred symbolp)
- `(app (pcase--flip eieio-oref ',field) ,field))))
+ `(app (eieio-oref _ ',field) ,field))))
fields)))
;;; Simple generators, and query functions. None of these would do
@@ -449,7 +449,12 @@ If EXTRA, include that in the string returned to represent the symbol."
(defun eieio-class-parents (class)
;; FIXME: What does "(overload of variable)" mean here?
"Return parent classes to CLASS. (overload of variable)."
- (eieio--class-parents (eieio--full-class-object class)))
+ ;; (declare (obsolete cl--class-parents "30.1"))
+ (let ((parents (eieio--class-parents (eieio--full-class-object class))))
+ (if (and (null (cdr parents))
+ (eq (car parents) (cl--find-class 'eieio-default-superclass)))
+ nil
+ parents)))
(define-obsolete-function-alias 'class-parents #'eieio-class-parents "24.4")
@@ -497,7 +502,7 @@ If EXTRA, include that in the string returned to represent the symbol."
(setq class (eieio--class-object class))
(cl-check-type class eieio--class)
(while (and child (not (eq child class)))
- (setq p (append p (eieio--class-parents child))
+ (setq p (append p (cl--class-parents child))
child (pop p)))
(if child t))))
@@ -648,8 +653,7 @@ If SLOT is unbound, bind it to the list containing ITEM."
(setq ov (list item))
(setq ov (eieio-oref object slot))
;; turn it into a list.
- (unless (listp ov)
- (setq ov (list ov)))
+ (setq ov (ensure-list ov))
;; Do the combination
(if (not (member item ov))
(setq ov
@@ -681,8 +685,7 @@ If SLOT is unbound, do nothing."
(defclass eieio-default-superclass nil
nil
"Default parent class for classes with no specified parent class.
-Its slots are automatically adopted by classes with no specified parents.
-This class is not stored in the `parent' slot of a class vector."
+Its slots are automatically adopted by classes with no specified parents."
:abstract t)
(setq eieio-default-superclass (cl--find-class 'eieio-default-superclass))
diff --git a/lisp/emacs-lisp/eldoc.el b/lisp/emacs-lisp/eldoc.el
index c3484491225..24afd03fbe6 100644
--- a/lisp/emacs-lisp/eldoc.el
+++ b/lisp/emacs-lisp/eldoc.el
@@ -5,7 +5,7 @@
;; Author: Noah Friedman <friedman@splode.com>
;; Keywords: extensions
;; Created: 1995-10-06
-;; Version: 1.13.0
+;; Version: 1.15.0
;; Package-Requires: ((emacs "26.3"))
;; This is a GNU ELPA :core package. Avoid functionality that is not
@@ -155,7 +155,7 @@ Remember to keep it a prime number to improve hash performance.")
(defvar eldoc-message-commands
;; Don't define as `defconst' since it would then go to (read-only) purespace.
- (make-vector eldoc-message-commands-table-size 0)
+ (obarray-make eldoc-message-commands-table-size)
"Commands after which it is appropriate to print in the echo area.
ElDoc does not try to print function arglists, etc., after just any command,
because some commands print their own messages in the echo area and these
@@ -191,7 +191,7 @@ It should receive the same arguments as `message'.")
When `eldoc-print-after-edit' is non-nil, ElDoc messages are only
printed after commands contained in this obarray."
- (let ((cmds (make-vector 31 0))
+ (let ((cmds (obarray-make 31))
(re (regexp-opt '("delete" "insert" "edit" "electric" "newline"))))
(mapatoms (lambda (s)
(and (commandp s)
@@ -300,13 +300,9 @@ reflect the change."
This function displays the message produced by formatting ARGS
with FORMAT-STRING on the mode line when the current buffer is a minibuffer.
Otherwise, it displays the message like `message' would."
- (if (minibufferp)
+ (if (or (bound-and-true-p edebug-mode) (minibufferp))
(progn
- (add-hook 'minibuffer-exit-hook
- (lambda () (setq eldoc-mode-line-string nil
- ;; https://debbugs.gnu.org/16920
- eldoc-last-message nil))
- nil t)
+ (add-hook 'post-command-hook #'eldoc-minibuffer--cleanup)
(with-current-buffer
(window-buffer
(or (window-in-direction 'above (minibuffer-window))
@@ -316,15 +312,24 @@ Otherwise, it displays the message like `message' would."
(not (and (listp mode-line-format)
(assq 'eldoc-mode-line-string mode-line-format))))
(setq mode-line-format
- (list "" '(eldoc-mode-line-string
- (" " eldoc-mode-line-string " "))
- mode-line-format)))
+ (funcall
+ (if (listp mode-line-format) #'append #'list)
+ (list "" '(eldoc-mode-line-string
+ (" " eldoc-mode-line-string " ")))
+ mode-line-format)))
(setq eldoc-mode-line-string
(when (stringp format-string)
(apply #'format-message format-string args)))
(force-mode-line-update)))
(apply #'message format-string args)))
+(defun eldoc-minibuffer--cleanup ()
+ (unless (or (bound-and-true-p edebug-mode) (minibufferp))
+ (setq eldoc-mode-line-string nil
+ ;; https://debbugs.gnu.org/16920
+ eldoc-last-message nil)
+ (remove-hook 'post-command-hook #'eldoc-minibuffer--cleanup)))
+
(make-obsolete
'eldoc-message "use `eldoc-documentation-functions' instead." "eldoc-1.1.0")
(defun eldoc-message (&optional string) (eldoc--message string))
@@ -392,7 +397,6 @@ Also store it in `eldoc-last-message' and return that value."
(defun eldoc-display-message-no-interference-p ()
"Return nil if displaying a message would cause interference."
(not (or executing-kbd-macro
- (bound-and-true-p edebug-active)
;; The following configuration shows "Matches..." in the
;; echo area when point is after a closing bracket, which
;; conflicts with eldoc.
@@ -439,7 +443,7 @@ documentation-producing backend to cooperate with specific
documentation-displaying frontends. For example, KEY can be:
* `:thing', VALUE being a short string or symbol designating what
- is being reported on. It can, for example be the name of the
+ DOCSTRING reports on. It can, for example be the name of the
function whose signature is being documented, or the name of
the variable whose docstring is being documented.
`eldoc-display-in-echo-area', a member of
@@ -450,6 +454,17 @@ documentation-displaying frontends. For example, KEY can be:
`eldoc-display-in-echo-area' and `eldoc-display-in-buffer' will
use when displaying `:thing''s value.
+* `:echo', controlling how `eldoc-display-in-echo-area' should
+ present this documentation item in the echo area, to save
+ space. If VALUE is a string, echo it instead of DOCSTRING. If
+ a number, only echo DOCSTRING up to that character position.
+ If `skip', don't echo DOCSTRING at all.
+
+The additional KEY `:origin' is always added by ElDoc, its VALUE
+being the member of `eldoc-documentation-functions' where
+DOCSTRING originated. `eldoc-display-functions' may use this
+information to organize display of multiple docstrings.
+
Finally, major modes should modify this hook locally, for
example:
(add-hook \\='eldoc-documentation-functions #\\='foo-mode-eldoc nil t)
@@ -473,8 +488,6 @@ directly from the user or from ElDoc's automatic mechanisms'.")
(defvar eldoc--doc-buffer nil "Buffer displaying latest ElDoc-produced docs.")
-(defvar eldoc--doc-buffer-docs nil "Documentation items in `eldoc--doc-buffer'.")
-
(defun eldoc-doc-buffer (&optional interactive)
"Get or display ElDoc documentation buffer.
@@ -492,46 +505,70 @@ If INTERACTIVE, display it. Else, return said buffer."
(display-buffer (current-buffer)))
(t (current-buffer)))))
+(defvar eldoc-doc-buffer-separator
+ (concat "\n" (propertize "\n" 'face '(:inherit separator-line :extend t)) "\n")
+ "String used to separate items in Eldoc documentation buffer.")
+
(defun eldoc--format-doc-buffer (docs)
"Ensure DOCS are displayed in an *eldoc* buffer."
(with-current-buffer (if (buffer-live-p eldoc--doc-buffer)
eldoc--doc-buffer
(setq eldoc--doc-buffer
(get-buffer-create " *eldoc*")))
- (unless (eq docs eldoc--doc-buffer-docs)
- (setq-local eldoc--doc-buffer-docs docs)
- (let ((inhibit-read-only t)
- (things-reported-on))
- (special-mode)
- (erase-buffer)
- (setq-local nobreak-char-display nil)
- (cl-loop for (docs . rest) on docs
- for (this-doc . plist) = docs
- for thing = (plist-get plist :thing)
- when thing do
- (cl-pushnew thing things-reported-on)
- (setq this-doc
- (concat
- (propertize (format "%s" thing)
- 'face (plist-get plist :face))
- ": "
- this-doc))
- do (insert this-doc)
- when rest do (insert "\n")
- finally (goto-char (point-min)))
- ;; Rename the buffer, taking into account whether it was
- ;; hidden or not
- (rename-buffer (format "%s*eldoc%s*"
- (if (string-match "^ " (buffer-name)) " " "")
- (if things-reported-on
- (format " for %s"
- (mapconcat
- (lambda (s) (format "%s" s))
- things-reported-on
- ", "))
- ""))))))
+ (let ((inhibit-read-only t)
+ (things-reported-on))
+ (special-mode)
+ (erase-buffer)
+ (setq-local nobreak-char-display nil)
+ (cl-loop for (docs . rest) on docs
+ for (this-doc . plist) = docs
+ for thing = (plist-get plist :thing)
+ when thing do
+ (cl-pushnew thing things-reported-on)
+ (setq this-doc
+ (concat
+ (propertize (format "%s" thing)
+ 'face (plist-get plist :face))
+ ": "
+ this-doc))
+ do (insert this-doc)
+ when rest do
+ (insert eldoc-doc-buffer-separator)
+ finally (goto-char (point-min)))
+ ;; Rename the buffer, taking into account whether it was
+ ;; hidden or not
+ (rename-buffer (format "%s*eldoc%s*"
+ (if (string-match "^ " (buffer-name)) " " "")
+ (if things-reported-on
+ (format " for %s"
+ (mapconcat
+ (lambda (s) (format "%s" s))
+ things-reported-on
+ ", "))
+ "")))))
eldoc--doc-buffer)
+(defun eldoc--echo-area-render (docs)
+ "Similar to `eldoc--format-doc-buffer', but for echo area.
+Helper for `eldoc-display-in-echo-area'."
+ (cl-loop for (item . rest) on docs
+ for (this-doc . plist) = item
+ for echo = (plist-get plist :echo)
+ for thing = (plist-get plist :thing)
+ unless (eq echo 'skip) do
+ (setq this-doc
+ (cond ((integerp echo) (substring this-doc 0 echo))
+ ((stringp echo) echo)
+ (t this-doc)))
+ (when thing (setq this-doc
+ (concat
+ (propertize (format "%s" thing)
+ 'face (plist-get plist :face))
+ ": "
+ this-doc)))
+ (insert this-doc)
+ (when rest (insert "\n"))))
+
(defun eldoc--echo-area-substring (available)
"Given AVAILABLE lines, get buffer substring to display in echo area.
Helper for `eldoc-display-in-echo-area'."
@@ -570,25 +607,29 @@ known to be truncated."
'maybe)))
(get-buffer-window eldoc--doc-buffer t)))
-(defun eldoc-display-in-echo-area (docs _interactive)
+(defun eldoc-display-in-echo-area (docs interactive)
"Display DOCS in echo area.
-Honor `eldoc-echo-area-use-multiline-p' and
+INTERACTIVE is non-nil if user explicitly invoked ElDoc. Honor
+`eldoc-echo-area-use-multiline-p' and
`eldoc-echo-area-prefer-doc-buffer'."
(cond
- (;; Check if we have permission to mess with echo area at all. For
- ;; example, if this-command is non-nil while running via an idle
- ;; timer, we're still in the middle of executing a command, e.g. a
- ;; query-replace where it would be annoying to overwrite the echo
- ;; area.
- (or
- (not (eldoc-display-message-no-interference-p))
- this-command
- (not (eldoc--message-command-p last-command))))
- (;; If we do but nothing to report, clear the echo area.
+ ((and (not interactive)
+ ;; When called non-interactively, check if we have permission
+ ;; to mess with echo area at all. For example, if
+ ;; this-command is non-nil while running via an idle timer,
+ ;; we're still in the middle of executing a command, e.g. a
+ ;; query-replace where it would be annoying to overwrite the
+ ;; echo area.
+ (or
+ (not (eldoc-display-message-no-interference-p))
+ this-command
+ (not (eldoc--message-command-p last-command)))))
+ (;; If nothing to report, clear the echo area.
(null docs)
(eldoc--message nil))
(t
- ;; Otherwise, establish some parameters.
+ ;; Otherwise, proceed to change the echo area. Start by
+ ;; establishing some parameters.
(let*
((width (1- (window-width (minibuffer-window))))
(val (if (and (symbolp eldoc-echo-area-use-multiline-p)
@@ -617,15 +658,15 @@ Honor `eldoc-echo-area-use-multiline-p' and
single-doc)
((and (numberp available)
(cl-plusp available))
- ;; Else, given a positive number of logical lines, we
- ;; format the *eldoc* buffer, using as most of its
- ;; contents as we know will fit.
- (with-current-buffer (eldoc--format-doc-buffer docs)
- (save-excursion
- (eldoc--echo-area-substring available))))
+ ;; Else, given a positive number of logical lines, grab
+ ;; as many as we can.
+ (with-temp-buffer
+ (eldoc--echo-area-render docs)
+ (eldoc--echo-area-substring available)))
(t ;; this is the "truncate brutally" situation
(let ((string
- (with-current-buffer (eldoc--format-doc-buffer docs)
+ (with-temp-buffer
+ (eldoc--echo-area-render docs)
(buffer-substring (goto-char (point-min))
(progn (end-of-visible-line)
(point))))))
@@ -646,38 +687,45 @@ If INTERACTIVE is t, also display the buffer."
(defun eldoc-documentation-default ()
"Show the first non-nil documentation string for item at point.
This is the default value for `eldoc-documentation-strategy'."
- (run-hook-with-args-until-success 'eldoc-documentation-functions
- (eldoc--make-callback :patient)))
-
-(defun eldoc--documentation-compose-1 (eagerlyp)
- "Helper function for composing multiple doc strings.
-If EAGERLYP is non-nil show documentation as soon as possible,
-else wait for all doc strings."
(run-hook-wrapped 'eldoc-documentation-functions
(lambda (f)
- (let* ((callback (eldoc--make-callback
- (if eagerlyp :eager :patient)))
- (str (funcall f callback)))
- (if (or (null str) (stringp str)) (funcall callback str))
- nil)))
- t)
+ (funcall f (eldoc--make-callback :eager f)))))
(defun eldoc-documentation-compose ()
"Show multiple documentation strings together after waiting for all of them.
This is meant to be used as a value for `eldoc-documentation-strategy'."
- (eldoc--documentation-compose-1 nil))
+ (let (fns-and-callbacks)
+ ;; Make all the callbacks, setting up state inside
+ ;; `eldoc--invoke-strategy' to know how many callbacks to wait for
+ ;; before displaying the result (bug#62816).
+ (run-hook-wrapped 'eldoc-documentation-functions
+ (lambda (f)
+ (push (cons f (eldoc--make-callback :patient f))
+ fns-and-callbacks)
+ nil))
+ ;; Now call them. The last one will trigger the display.
+ (cl-loop for (f . callback) in fns-and-callbacks
+ for str = (funcall f callback)
+ when (or (null str) (stringp str)) do (funcall callback str)))
+ t)
(defun eldoc-documentation-compose-eagerly ()
"Show multiple documentation strings one by one as soon as possible.
This is meant to be used as a value for `eldoc-documentation-strategy'."
- (eldoc--documentation-compose-1 t))
+ (run-hook-wrapped 'eldoc-documentation-functions
+ (lambda (f)
+ (let* ((callback (eldoc--make-callback :eager f))
+ (str (funcall f callback)))
+ (if (or (null str) (stringp str)) (funcall callback str))
+ nil)))
+ t)
(defun eldoc-documentation-enthusiast ()
"Show most important documentation string produced so far.
This is meant to be used as a value for `eldoc-documentation-strategy'."
(run-hook-wrapped 'eldoc-documentation-functions
(lambda (f)
- (let* ((callback (eldoc--make-callback :enthusiast))
+ (let* ((callback (eldoc--make-callback :enthusiast f))
(str (funcall f callback)))
(if (stringp str) (funcall callback str))
nil)))
@@ -782,7 +830,7 @@ before a higher priority one.")
;; `eldoc--invoke-strategy' could be moved to
;; `eldoc-documentation-strategy' or thereabouts if/when we decide to
;; extend or publish the `make-callback' protocol.
-(defun eldoc--make-callback (method)
+(defun eldoc--make-callback (method origin)
"Make callback suitable for `eldoc-documentation-functions'.
The return value is a function FN whose lambda list is (STRING
&rest PLIST) and can be called by those functions. Its
@@ -802,8 +850,11 @@ have the following values:
`eldoc-documentation-functions' have been collected;
- `:eager' says to display STRING along with all other competing
- strings so far, as soon as possible."
- (funcall eldoc--make-callback method))
+ strings so far, as soon as possible.
+
+ORIGIN is the member of `eldoc-documentation-functions' which
+will be responsible for eventually calling the FN."
+ (funcall eldoc--make-callback method origin))
(defun eldoc--invoke-strategy (interactive)
"Invoke `eldoc-documentation-strategy' function.
@@ -840,9 +891,10 @@ the docstrings eventually produced, using
(docs-registered '()))
(cl-labels
((register-doc
- (pos string plist)
+ (pos string plist origin)
(when (and string (> (length string) 0))
- (push (cons pos (cons string plist)) docs-registered)))
+ (push (cons pos (cons string `(:origin ,origin ,@plist)))
+ docs-registered)))
(display-doc
()
(run-hook-with-args
@@ -852,7 +904,7 @@ the docstrings eventually produced, using
(lambda (a b) (< (car a) (car b))))))
interactive))
(make-callback
- (method)
+ (method origin)
(let ((pos (prog1 howmany (cl-incf howmany))))
(cl-ecase method
(:enthusiast
@@ -860,7 +912,7 @@ the docstrings eventually produced, using
(when (and string (cl-loop for (p) in docs-registered
never (< p pos)))
(setq docs-registered '())
- (register-doc pos string plist))
+ (register-doc pos string plist origin))
(when (and (timerp eldoc--enthusiasm-curbing-timer)
(memq eldoc--enthusiasm-curbing-timer
timer-list))
@@ -872,19 +924,22 @@ the docstrings eventually produced, using
(:patient
(cl-incf want)
(lambda (string &rest plist)
- (register-doc pos string plist)
+ (register-doc pos string plist origin)
(when (zerop (cl-decf want)) (display-doc))
t))
(:eager
(lambda (string &rest plist)
- (register-doc pos string plist)
+ (register-doc pos string plist origin)
(display-doc)
t))))))
(let* ((eldoc--make-callback #'make-callback)
(res (funcall eldoc-documentation-strategy)))
;; Observe the old and the new protocol:
- (cond (;; Old protocol: got string, output immediately;
- (stringp res) (register-doc 0 res nil) (display-doc))
+ (cond (;; Old protocol: got string, e-d-strategy is itself the
+ ;; origin function, and we output immediately;
+ (stringp res)
+ (register-doc 0 res nil eldoc-documentation-strategy)
+ (display-doc))
(;; Old protocol: got nil, clear the echo area;
(null res) (eldoc--message nil))
(;; New protocol: trust callback will be called;
@@ -946,7 +1001,8 @@ the docstrings eventually produced, using
"mark-paragraph" "mouse-set-point" "move-" "move-beginning-of-"
"move-end-of-" "newline" "next-" "other-window" "pop-global-mark"
"previous-" "recenter" "right-" "scroll-" "self-insert-command"
- "split-window-" "up-list")
+ "split-window-" "up-list" "touch-screen-handle-touch"
+ "analyze-text-conversion")
(provide 'eldoc)
diff --git a/lisp/emacs-lisp/elint.el b/lisp/emacs-lisp/elint.el
index 1bb0a95078a..27c169cc657 100644
--- a/lisp/emacs-lisp/elint.el
+++ b/lisp/emacs-lisp/elint.el
@@ -80,16 +80,16 @@ are as follows, and suppress messages about the indicated features:
empty-let - let-bindings with empty variable lists"
:type '(choice (const :tag "Don't suppress any warnings" nil)
(repeat :tag "List of issues to ignore"
- (choice (const undefined-functions
- :tag "Calls to unknown functions")
- (const unbound-reference
- :tag "Reference to unknown variables")
- (const unbound-assignment
- :tag "Assignment to unknown variables")
- (const macro-expansion
- :tag "Failure to expand macros")
- (const empty-let
- :tag "Let-binding with empty varlist"))))
+ (choice (const :tag "Calls to unknown functions"
+ undefined-functions)
+ (const :tag "Reference to unknown variables"
+ unbound-reference)
+ (const :tag "Assignment to unknown variables"
+ unbound-assignment)
+ (const :tag "Failure to expand macros"
+ macro-expansion)
+ (const :tag "Let-binding with empty varlist"
+ empty-let))))
:safe (lambda (value) (or (null value)
(and (listp value)
(equal value
@@ -266,6 +266,7 @@ This environment can be passed to `macroexpand'."
(insert-file-contents file)
(let ((buffer-file-name file)
(max-lisp-eval-depth (max 1000 max-lisp-eval-depth)))
+ (hack-local-variables)
(with-syntax-table emacs-lisp-mode-syntax-table
(mapc 'elint-top-form (elint-update-env)))))
(elint-set-mode-line)
diff --git a/lisp/emacs-lisp/ert-font-lock.el b/lisp/emacs-lisp/ert-font-lock.el
new file mode 100644
index 00000000000..e77c8945dc3
--- /dev/null
+++ b/lisp/emacs-lisp/ert-font-lock.el
@@ -0,0 +1,407 @@
+;;; ert-font-lock.el --- ERT Font Lock -*- lexical-binding: t -*-
+
+;; Copyright (C) 2023-2024 Free Software Foundation, Inc.
+
+;; Author: Vladimir Kazanov
+;; Keywords: lisp, 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 <https://www.gnu.org/licenses/>.
+
+;;; Commentary:
+;;
+;; ERT Font Lock is an extension to the Emacs Lisp Regression Test
+;; library (ERT) providing a convenient way to check syntax
+;; highlighting provided by font-lock.
+;;
+;; ert-font-lock entry points are functions
+;; `ert-font-lock-test-string' and `ert-font-lock-test-file' and
+;; convenience macros: `ert-font-lock-deftest' and
+;; `ert-font-lock-deftest-file'.
+;;
+;; See unit tests in ert-font-lock-tests.el for usage examples.
+
+;;; Code:
+
+(require 'ert)
+(require 'newcomment)
+(require 'pcase)
+
+(defconst ert-font-lock--face-symbol-re
+ (rx (one-or-more (or alphanumeric "-" "_" ".")))
+ "A face symbol matching regex.")
+
+(defconst ert-font-lock--face-symbol-list-re
+ (rx "("
+ (* whitespace)
+ (one-or-more
+ (seq (regexp ert-font-lock--face-symbol-re)
+ (* whitespace)))
+ ")")
+ "A face symbol list matching regex.")
+
+(defconst ert-font-lock--assertion-line-re
+ (rx
+ ;; leading column assertion (arrow/caret)
+ (group (or "^" "<-"))
+ (zero-or-more whitespace)
+ ;; possible to have many carets on an assertion line
+ (group (zero-or-more (seq "^" (zero-or-more whitespace))))
+ ;; optional negation of the face specification
+ (group (optional "!"))
+ (zero-or-more whitespace)
+ ;; face symbol name or a list of symbols
+ (group (or (regexp ert-font-lock--face-symbol-re)
+ (regexp ert-font-lock--face-symbol-list-re))))
+ "An ert-font-lock assertion line regex.")
+
+(defun ert-font-lock--validate-major-mode (mode)
+ "Validate if MODE is a valid major mode."
+ (unless (functionp mode)
+ (error "Invalid major mode: %S. Please specify a valid major mode for
+ syntax highlighting tests" mode)))
+
+(defun ert-font-lock--test-body-str (mode str test-name)
+ "Run assertions from STR.
+Argument MODE - major mode to test.
+Argument TEST-NAME - name of the currently running ert test."
+ (ert-font-lock--validate-major-mode mode)
+ (with-temp-buffer
+ (insert str)
+ (funcall mode)
+ (font-lock-ensure)
+ (let ((tests (ert-font-lock--parse-comments)))
+ (ert-font-lock--check-faces tests)))
+ test-name)
+
+(defun ert-font-lock--test-body-file (mode file test-name)
+ "Run assertions from FILE.
+Argument MODE - major mode to test.
+Argument TEST-NAME - name of the currently running ert test."
+ (ert-font-lock--validate-major-mode mode)
+ (ert-font-lock-test-file file mode)
+ test-name)
+
+(defun ert-font-lock--parse-macro-args (doc-keys-mode-arg)
+ "Parse DOC-KEYS-MODE-ARG macro argument list."
+ (let (doc doc-p mode arg)
+
+ (when (stringp (car doc-keys-mode-arg))
+ (setq doc (pop doc-keys-mode-arg)
+ doc-p t))
+
+ (pcase-let
+ ((`(,keys ,mode-arg)
+ (ert--parse-keys-and-body doc-keys-mode-arg)))
+
+ (unless (symbolp (car mode-arg))
+ (error "A major mode symbol expected: %S" (car mode-arg)))
+ (setq mode (pop mode-arg))
+
+ (unless (stringp (car mode-arg))
+ (error "A string or file with assertions expected: %S" (car mode-arg)))
+ (setq arg (pop mode-arg))
+
+ (list doc doc-p keys mode arg))))
+
+;;;###autoload
+(defmacro ert-font-lock-deftest (name &rest docstring-keys-mode-and-str)
+ "Define test NAME (a symbol) using assertions from TEST-STR.
+
+Other than MAJOR-MODE and TEST-STR parameters, this macro accepts
+the same parameters and keywords as `ert-deftest' and is intended
+to be used through `ert'.
+
+\(fn NAME () [DOCSTRING] [:expected-result RESULT-TYPE] \
+[:tags \\='(TAG...)] MAJOR-MODE TEST-STR)"
+ (declare (debug (&define [&name "test@" symbolp]
+ sexp [&optional stringp]
+ [&rest keywordp sexp]
+ symbolp
+ stringp))
+ (doc-string 3)
+ (indent 2))
+ (pcase-let ((`(,documentation
+ ,documentation-supplied-p
+ ,keys ,mode ,arg)
+ (ert-font-lock--parse-macro-args docstring-keys-mode-and-str)))
+
+ `(ert-set-test ',name
+ (make-ert-test
+ :name ',name
+ ,@(when documentation-supplied-p
+ `(:documentation ,documentation))
+ ,@(when (map-contains-key keys :expected-result)
+ `(:expected-result-type ,(map-elt keys :expected-result)))
+ ,@(when (map-contains-key keys :tags)
+ `(:tags ,(map-elt keys :tags)))
+ :body (lambda () (ert-font-lock--test-body-str ',mode ,arg ',name))
+
+ :file-name ,(or (macroexp-file-name) buffer-file-name)))))
+
+;;;###autoload
+(defmacro ert-font-lock-deftest-file (name &rest docstring-keys-mode-and-file)
+ "Define test NAME (a symbol) using assertions from FILE.
+
+FILE - path to a file with assertions in ERT resource director as
+return by `ert-resource-directory'.
+
+Other than MAJOR-MODE and FILE parameters, this macro accepts the
+same parameters and keywords as `ert-deftest' and is intended to
+be used through `ert'.
+
+\(fn NAME () [DOCSTRING] [:expected-result RESULT-TYPE] \
+[:tags \\='(TAG...)] MAJOR-MODE FILE)"
+ (declare (debug (&define [&name "test@" symbolp]
+ sexp [&optional stringp]
+ [&rest keywordp sexp]
+ symbolp
+ stringp))
+ (doc-string 3)
+ (indent 2))
+
+ (pcase-let ((`(,documentation
+ ,documentation-supplied-p
+ ,keys ,mode ,arg)
+ (ert-font-lock--parse-macro-args docstring-keys-mode-and-file)))
+
+ `(ert-set-test ',name
+ (make-ert-test
+ :name ',name
+ ,@(when documentation-supplied-p
+ `(:documentation ,documentation))
+ ,@(when (map-contains-key keys :expected-result)
+ `(:expected-result-type ,(map-elt keys :expected-result)))
+ ,@(when (map-contains-key keys :tags)
+ `(:tags ,(map-elt keys :tags)))
+ :body (lambda () (ert-font-lock--test-body-file
+ ',mode (ert-resource-file ,arg) ',name))
+ :file-name ,(or (macroexp-file-name) buffer-file-name)))))
+
+(defun ert-font-lock--in-comment-p ()
+ "Check if the current point is inside a comment."
+ (nth 4 (syntax-ppss)))
+
+(defun ert-font-lock--comment-start-p ()
+ "Check if the current point starts a comment."
+ (or
+ ;; regexps use syntax tables so let's check that first
+ (looking-at "\\s<")
+
+ ;; check newcomment.el facilities
+ (and comment-start (looking-at (regexp-quote comment-start)))
+ (and comment-start-skip (looking-at comment-start-skip))
+
+ ;; sometimes comment syntax is just hardcoded
+ (and (derived-mode-p '(c-mode c++-mode java-mode))
+ (looking-at-p "//"))))
+
+(defun ert-font-lock--line-comment-p ()
+ "Return t if the current line is a comment-only line."
+ (syntax-ppss)
+ (save-excursion
+ (beginning-of-line)
+ (skip-syntax-forward " ")
+ ;; skip empty lines
+ (unless (eolp)
+ (or
+ ;; multiline comments
+ (ert-font-lock--in-comment-p)
+
+ ;; single line comments
+ (ert-font-lock--comment-start-p)))))
+
+(defun ert-font-lock--line-assertion-p ()
+ "Return t if the current line contains an assertion."
+ (syntax-ppss)
+ (save-excursion
+ (beginning-of-line)
+ (skip-syntax-forward " ")
+ (re-search-forward ert-font-lock--assertion-line-re
+ (line-end-position) t 1)))
+
+(defun ert-font-lock--goto-first-char ()
+ "Move the point to the first character."
+ (beginning-of-line)
+ (skip-syntax-forward " "))
+
+(defun ert-font-lock--get-first-char-column ()
+ "Get the position of the first non-empty char in the current line."
+ (save-excursion
+ (ert-font-lock--goto-first-char)
+ (- (point) (line-beginning-position))))
+
+(defun ert-font-lock--parse-comments ()
+ "Read test assertions from comments in the current buffer."
+ (let ((tests '())
+ (curline 1)
+ (linetocheck -1))
+
+ (goto-char (point-min))
+
+ ;; Go through all lines, for comments check if there are
+ ;; assertions. For non-comment and comment/non-assert lines
+ ;; remember the last line seen.
+ (while (not (eobp))
+ (catch 'nextline
+
+ ;; Not a comment? remember the line, move to the next one
+ (unless (ert-font-lock--line-comment-p)
+ (setq linetocheck curline)
+ (throw 'nextline t))
+
+ ;; A comment. Not an assertion? remember the line to be
+ ;; checked, move to the next line
+ (unless (ert-font-lock--line-assertion-p)
+ (setq linetocheck curline)
+ (throw 'nextline t))
+
+
+ ;; Collect the first line assertion (caret or arrow)
+ (when (re-search-forward ert-font-lock--assertion-line-re
+ (line-end-position) t 1)
+
+ (unless (> linetocheck -1)
+ (user-error "Invalid test comment syntax at line %d. Expected a line to test before the comment line" curline))
+
+ ;; construct a test
+ (let* (;; either comment start char column (for arrows) or
+ ;; caret column
+ (column-checked (if (equal (match-string-no-properties 1) "^")
+ (- (match-beginning 1) (line-beginning-position))
+ (ert-font-lock--get-first-char-column)))
+ ;; negate the face?
+ (negation (string-equal (match-string-no-properties 3) "!"))
+ ;; the face that is supposed to be in the position specified
+ (face (read (match-string-no-properties 4))))
+
+ ;; Collect the first assertion on the line
+ (push (list :line-checked linetocheck
+ :line-assert curline
+ :column-checked column-checked
+ :face face
+ :negation negation)
+ tests)
+
+ ;; Collect all the other line carets (if present)
+ (goto-char (match-beginning 2))
+ (while (equal (following-char) ?^)
+ (setq column-checked (- (point) (line-beginning-position)))
+ (push (list :line-checked linetocheck
+ :line-assert curline
+ :column-checked column-checked
+ :face face
+ :negation negation)
+ tests)
+ (forward-char)
+ (skip-syntax-forward " ")))))
+
+ ;; next line
+ (setq curline (1+ curline))
+ (forward-line 1))
+
+ (unless tests
+ (user-error "No test assertions found"))
+
+ (reverse tests)))
+
+(defun ert-font-lock--point-at-line-and-column (line column)
+ "Get the buffer position for LINE and COLUMN."
+ (save-excursion
+ (goto-char (point-min))
+ (forward-line (1- line))
+ (move-to-column column)
+ (point)))
+
+(defun ert-font-lock--get-line (line-number)
+ "Return the content of the line specified by LINE-NUMBER."
+ (save-excursion
+ (goto-char (point-min))
+ (forward-line (1- line-number))
+ (buffer-substring-no-properties (line-beginning-position) (line-end-position))))
+
+(defun ert-font-lock--check-faces (tests)
+ "Check if the current buffer is fontified correctly.
+TESTS - tests to run.
+
+The function is meant to be run from within an ERT test."
+ (dolist (test tests)
+ (let* ((line-checked (plist-get test :line-checked))
+ (line-assert (plist-get test :line-assert))
+ (column-checked (plist-get test :column-checked))
+ (expected-face (plist-get test :face))
+ (negation (plist-get test :negation))
+
+ (actual-face (get-text-property (ert-font-lock--point-at-line-and-column line-checked column-checked) 'face))
+ (line-str (ert-font-lock--get-line line-checked))
+ (line-assert-str (ert-font-lock--get-line line-assert)))
+
+ ;; normalize both expected and resulting face - these can be
+ ;; either symbols, nils or lists of symbols
+ (when (not (listp actual-face))
+ (setq actual-face (list actual-face)))
+ (when (not (listp expected-face))
+ (setq expected-face (list expected-face)))
+
+ ;; fail when lists are not 'equal and the assertion is *not negated*
+ (when (and (not negation) (not (equal actual-face expected-face)))
+ (ert-fail
+ (list (format "Expected face %S, got %S on line %d column %d"
+ expected-face actual-face line-checked column-checked)
+ :line line-str
+ :assert line-assert-str)))
+
+ ;; fail when lists are 'equal and the assertion is *negated*
+ (when (and negation (equal actual-face expected-face))
+ (ert-fail
+ (list (format "Did not expect face %S face on line %d, column %d"
+ actual-face line-checked column-checked)
+ :line line-str
+ :assert line-assert-str))))))
+
+;;;###autoload
+(defun ert-font-lock-test-string (test-string mode)
+ "Check font faces in TEST-STRING set by MODE.
+
+The function is meant to be run from within an ERT test."
+ (ert-font-lock--validate-major-mode mode)
+ (with-temp-buffer
+ (insert test-string)
+ (funcall mode)
+ (font-lock-ensure)
+
+ (ert-font-lock--check-faces (ert-font-lock--parse-comments)))
+
+ (ert-pass))
+
+;;;###autoload
+(defun ert-font-lock-test-file (filename mode)
+ "Check font faces in FILENAME set by MODE.
+
+The function is meant to be run from within an ERT test."
+ (ert-font-lock--validate-major-mode mode)
+ (with-temp-buffer
+ (insert-file-contents filename)
+ (funcall mode)
+ (font-lock-ensure)
+
+ (ert-font-lock--check-faces (ert-font-lock--parse-comments)))
+
+ (ert-pass))
+
+
+(provide 'ert-font-lock)
+
+;;; ert-font-lock.el ends here
diff --git a/lisp/emacs-lisp/ert-x.el b/lisp/emacs-lisp/ert-x.el
index 4de76321e80..cd60f9f457f 100644
--- a/lisp/emacs-lisp/ert-x.el
+++ b/lisp/emacs-lisp/ert-x.el
@@ -540,10 +540,10 @@ The same keyword arguments are supported as in
(when (and (featurep 'tramp) (getenv "EMACS_HYDRA_CI"))
(add-to-list 'tramp-remote-path 'tramp-own-remote-path))
-;; If this defconst is used in a test file, `tramp' shall be loaded
+;; If this defvar is used in a test file, `tramp' shall be loaded
;; prior `ert-x'. There is no default value on w32 systems, which
;; could work out of the box.
-(defconst ert-remote-temporary-file-directory
+(defvar ert-remote-temporary-file-directory
(when (featurep 'tramp)
(cond
((getenv "REMOTE_TEMPORARY_FILE_DIRECTORY"))
@@ -563,9 +563,9 @@ The same keyword arguments are supported as in
;; Emacs's Makefile sets $HOME to a nonexistent value. Needed
;; in batch mode only, therefore.
(when (and noninteractive (not (file-directory-p "~/")))
- (setenv "HOME" temporary-file-directory))
+ (setenv "HOME" (directory-file-name temporary-file-directory)))
(format "/mock::%s" temporary-file-directory))))
- "Temporary directory for remote file tests.")
+ "Temporary directory for remote file tests.")
(provide 'ert-x)
diff --git a/lisp/emacs-lisp/ert.el b/lisp/emacs-lisp/ert.el
index a265aa102e2..8ab57d2b238 100644
--- a/lisp/emacs-lisp/ert.el
+++ b/lisp/emacs-lisp/ert.el
@@ -34,17 +34,18 @@
;; `ert-run-tests-batch-and-exit' for non-interactive use.
;;
;; The body of `ert-deftest' forms resembles a function body, but the
-;; additional operators `should', `should-not', `should-error' and
-;; `skip-unless' are available. `should' is similar to cl's `assert',
-;; but signals a different error when its condition is violated that
-;; is caught and processed by ERT. In addition, it analyzes its
-;; argument form and records information that helps debugging
-;; (`cl-assert' tries to do something similar when its second argument
-;; SHOW-ARGS is true, but `should' is more sophisticated). For
-;; information on `should-not' and `should-error', see their
-;; docstrings. `skip-unless' skips the test immediately without
-;; processing further, this is useful for checking the test
-;; environment (like availability of features, external binaries, etc).
+;; additional operators `should', `should-not', `should-error',
+;; `skip-when' and `skip-unless' are available. `should' is similar
+;; to cl's `assert', but signals a different error when its condition
+;; is violated that is caught and processed by ERT. In addition, it
+;; analyzes its argument form and records information that helps
+;; debugging (`cl-assert' tries to do something similar when its
+;; second argument SHOW-ARGS is true, but `should' is more
+;; sophisticated). For information on `should-not' and
+;; `should-error', see their docstrings. The `skip-when' and
+;; `skip-unless' forms skip the test immediately, which is useful for
+;; checking the test environment (like availability of features,
+;; external binaries, etc).
;;
;; See ERT's Info manual `(ert) Top' as well as the docstrings for
;; more details. To see some examples of tests written in ERT, see
@@ -194,8 +195,8 @@ and the body."
BODY is evaluated as a `progn' when the test is run. It should
signal a condition on failure or just return if the test passes.
-`should', `should-not', `should-error' and `skip-unless' are
-useful for assertions in BODY.
+`should', `should-not', `should-error', `skip-when', and
+`skip-unless' are useful for assertions in BODY.
Use `ert' to run tests interactively.
@@ -227,7 +228,8 @@ in batch mode, an error is signaled.
(tags nil tags-supplied-p))
body)
(ert--parse-keys-and-body docstring-keys-and-body)
- `(cl-macrolet ((skip-unless (form) `(ert--skip-unless ,form)))
+ `(cl-macrolet ((skip-when (form) `(ert--skip-when ,form))
+ (skip-unless (form) `(ert--skip-unless ,form)))
(ert-set-test ',name
(make-ert-test
:name ',name
@@ -237,7 +239,9 @@ in batch mode, an error is signaled.
`(:expected-result-type ,expected-result))
,@(when tags-supplied-p
`(:tags ,tags))
- :body (lambda () ,@body)
+ ;; Add `nil' after the body to enable compiler warnings
+ ;; about unused computations at the end.
+ :body (lambda () ,@body nil)
:file-name ,(or (macroexp-file-name) buffer-file-name)))
',name))))
@@ -274,14 +278,6 @@ DATA is displayed to the user and should state the reason for skipping."
(when ert--should-execution-observer
(funcall ert--should-execution-observer form-description)))
-;; See Bug#24402 for why this exists
-(defun ert--should-signal-hook (error-symbol data)
- "Stupid hack to stop `condition-case' from catching ert signals.
-It should only be stopped when ran from inside `ert--run-test-internal'."
- (when (and (not (symbolp debugger)) ; only run on anonymous debugger
- (memq error-symbol '(ert-test-failed ert-test-skipped)))
- (funcall debugger 'error (cons error-symbol data))))
-
(defun ert--special-operator-p (thing)
"Return non-nil if THING is a symbol naming a special operator."
(and (symbolp thing)
@@ -320,8 +316,7 @@ It should only be stopped when ran from inside `ert--run-test-internal'."
(default-value (gensym "ert-form-evaluation-aborted-")))
`(let* ((,fn (function ,fn-name))
(,args (condition-case err
- (let ((signal-hook-function #'ert--should-signal-hook))
- (list ,@arg-forms))
+ (list ,@arg-forms)
(error (progn (setq ,fn #'signal)
(list (car err)
(cdr err)))))))
@@ -462,6 +457,15 @@ failed."
(list
:fail-reason "did not signal an error")))))))))
+(cl-defmacro ert--skip-when (form)
+ "Evaluate FORM. If it returns t, skip the current test.
+Errors during evaluation are caught and handled like t."
+ (declare (debug t))
+ (ert--expand-should `(skip-when ,form) form
+ (lambda (inner-form form-description-form _value-var)
+ `(when (condition-case nil ,inner-form (t t))
+ (ert-skip ,form-description-form)))))
+
(cl-defmacro ert--skip-unless (form)
"Evaluate FORM. If it returns nil, skip the current test.
Errors during evaluation are caught and handled like nil."
@@ -715,78 +719,68 @@ in front of the value of MESSAGE-FORM."
;; value and test execution should be terminated. Should not
;; return.
(exit-continuation (cl-assert nil))
- ;; The binding of `debugger' outside of the execution of the test.
- next-debugger
;; The binding of `ert-debug-on-error' that is in effect for the
;; execution of the current test. We store it to avoid being
;; affected by any new bindings the test itself may establish. (I
;; don't remember whether this feature is important.)
ert-debug-on-error)
-(defun ert--run-test-debugger (info args)
- "During a test run, `debugger' is bound to a closure that calls this function.
+(defun ert--run-test-debugger (info condition debugfun)
+ "Error handler used during the test run.
This function records failures and errors and either terminates
the test silently or calls the interactive debugger, as
appropriate.
-INFO is the ert--test-execution-info corresponding to this test
-run. ARGS are the arguments to `debugger'."
- (cl-destructuring-bind (first-debugger-arg &rest more-debugger-args)
- args
- (cl-ecase first-debugger-arg
- ((lambda debug t exit nil)
- (apply (ert--test-execution-info-next-debugger info) args))
- (error
- (let* ((condition (car more-debugger-args))
- (type (cl-case (car condition)
- ((quit) 'quit)
- ((ert-test-skipped) 'skipped)
- (otherwise 'failed)))
- ;; We store the backtrace in the result object for
- ;; `ert-results-pop-to-backtrace-for-test-at-point'.
- ;; This means we have to limit `print-level' and
- ;; `print-length' when printing result objects. That
- ;; might not be worth while when we can also use
- ;; `ert-results-rerun-test-at-point-debugging-errors',
- ;; (i.e., when running interactively) but having the
- ;; backtrace ready for printing is important for batch
- ;; use.
- ;;
- ;; Grab the frames above the debugger.
- (backtrace (cdr (backtrace-get-frames debugger)))
- (infos (reverse ert--infos)))
- (setf (ert--test-execution-info-result info)
- (cl-ecase type
- (quit
- (make-ert-test-quit :condition condition
- :backtrace backtrace
- :infos infos))
- (skipped
- (make-ert-test-skipped :condition condition
- :backtrace backtrace
- :infos infos))
- (failed
- (make-ert-test-failed :condition condition
- :backtrace backtrace
- :infos infos))))
- ;; Work around Emacs's heuristic (in eval.c) for detecting
- ;; errors in the debugger.
- (cl-incf num-nonmacro-input-events)
- ;; FIXME: We should probably implement more fine-grained
- ;; control a la non-t `debug-on-error' here.
- (cond
- ((ert--test-execution-info-ert-debug-on-error info)
- (apply (ert--test-execution-info-next-debugger info) args))
- (t))
- (funcall (ert--test-execution-info-exit-continuation info)))))))
+INFO is the `ert--test-execution-info' corresponding to this test run.
+ERR is the error object."
+ (let* ((type (cl-case (car condition)
+ ((quit) 'quit)
+ ((ert-test-skipped) 'skipped)
+ (otherwise 'failed)))
+ ;; We store the backtrace in the result object for
+ ;; `ert-results-pop-to-backtrace-for-test-at-point'.
+ ;; This means we have to limit `print-level' and
+ ;; `print-length' when printing result objects. That
+ ;; might not be worth while when we can also use
+ ;; `ert-results-rerun-test-at-point-debugging-errors',
+ ;; (i.e., when running interactively) but having the
+ ;; backtrace ready for printing is important for batch
+ ;; use.
+ ;;
+ ;; Grab the frames above ourselves.
+ (backtrace (cdr (backtrace-get-frames debugfun)))
+ (infos (reverse ert--infos)))
+ (setf (ert--test-execution-info-result info)
+ (cl-ecase type
+ (quit
+ (make-ert-test-quit :condition condition
+ :backtrace backtrace
+ :infos infos))
+ (skipped
+ (make-ert-test-skipped :condition condition
+ :backtrace backtrace
+ :infos infos))
+ (failed
+ (make-ert-test-failed :condition condition
+ :backtrace backtrace
+ :infos infos))))
+ ;; FIXME: We should probably implement more fine-grained
+ ;; control a la non-t `debug-on-error' here.
+ (cond
+ ((ert--test-execution-info-ert-debug-on-error info)
+ ;; The `debugfun' arg tells `debug' which backtrace frame starts
+ ;; the "entering the debugger" code so it can hide those frames
+ ;; from the backtrace.
+ (funcall debugger 'error condition :backtrace-base debugfun))
+ (t))
+ (funcall (ert--test-execution-info-exit-continuation info))))
(defun ert--run-test-internal (test-execution-info)
"Low-level function to run a test according to TEST-EXECUTION-INFO.
This mainly sets up debugger-related bindings."
- (setf (ert--test-execution-info-next-debugger test-execution-info) debugger
- (ert--test-execution-info-ert-debug-on-error test-execution-info)
+ (setf (ert--test-execution-info-ert-debug-on-error test-execution-info)
ert-debug-on-error)
(catch 'ert--pass
;; For now, each test gets its own temp buffer and its own
@@ -794,26 +788,14 @@ This mainly sets up debugger-related bindings."
;; too expensive, we can remove it.
(with-temp-buffer
(save-window-excursion
- ;; FIXME: Use `signal-hook-function' instead of `debugger' to
- ;; handle ert errors. Once that's done, remove
- ;; `ert--should-signal-hook'. See Bug#24402 and Bug#11218 for
- ;; details.
- (let ((lexical-binding t)
- (debugger (lambda (&rest args)
- (ert--run-test-debugger test-execution-info
- args)))
- (debug-on-error t)
- ;; Don't infloop if the error being called is erroring
- ;; out, and we have `debug-on-error' bound to nil inside
- ;; the test.
- (backtrace-on-error-noninteractive nil)
- (debug-on-quit t)
- ;; FIXME: Do we need to store the old binding of this
- ;; and consider it in `ert--run-test-debugger'?
- (debug-ignored-errors nil)
+ (let ((lexical-binding t) ;;FIXME: Why?
(ert--infos '()))
- (funcall (ert-test-body (ert--test-execution-info-test
- test-execution-info))))))
+ (letrec ((debugfun (lambda (err)
+ (ert--run-test-debugger test-execution-info
+ err debugfun))))
+ (handler-bind (((error quit) debugfun))
+ (funcall (ert-test-body (ert--test-execution-info-test
+ test-execution-info))))))))
(ert-pass))
(setf (ert--test-execution-info-result test-execution-info)
(make-ert-test-passed))
diff --git a/lisp/emacs-lisp/find-func.el b/lisp/emacs-lisp/find-func.el
index e5dceb5e4a3..411602ef166 100644
--- a/lisp/emacs-lisp/find-func.el
+++ b/lisp/emacs-lisp/find-func.el
@@ -42,8 +42,6 @@
;;; Code:
-(eval-when-compile (require 'cl-lib))
-
;;; User variables:
(defgroup find-function nil
@@ -62,6 +60,7 @@
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\\)\\|\
+transient-define-\\(?:prefix\\|suffix\\|infix\\|argument\\)\\|\
menu-bar-make-toggle\\|menu-bar-make-toggle-command\\)"
find-function-space-re
"\\('\\|(quote \\)?%s\\(\\s-\\|$\\|[()]\\)")
@@ -247,13 +246,19 @@ LIBRARY should be a string (the name of the library)."
;; LIBRARY may be "foo.el" or "foo".
(let ((load-re
(concat "\\(" (regexp-quote (file-name-sans-extension library)) "\\)"
- (regexp-opt (get-load-suffixes)) "\\'")))
- (cl-loop
- for (file . _) in load-history thereis
- (and (stringp file) (string-match load-re file)
- (let ((dir (substring file 0 (match-beginning 1)))
- (basename (match-string 1 file)))
- (locate-file basename (list dir) (find-library-suffixes)))))))
+ (regexp-opt (get-load-suffixes)) "\\'"))
+ (alist load-history)
+ elt file found)
+ (while (and alist (null found))
+ (setq elt (car alist)
+ alist (cdr alist)
+ file (car elt)
+ found (and (stringp file) (string-match load-re file)
+ (let ((dir (substring file 0 (match-beginning 1)))
+ (basename (match-string 1 file)))
+ (locate-file basename (list dir)
+ (find-library-suffixes))))))
+ found))
(defvar find-function-C-source-directory
(let ((dir (expand-file-name "src" source-directory)))
@@ -469,7 +474,8 @@ Return t if any PRED returns t."
((not (consp form)) nil)
((funcall pred form) t)
(t
- (cl-destructuring-bind (left-child . right-child) form
+ (let ((left-child (car form))
+ (right-child (cdr form)))
(or
(find-function--any-subform-p left-child pred)
(find-function--any-subform-p right-child pred))))))
@@ -591,7 +597,7 @@ otherwise uses `variable-at-point'."
(list (intern (completing-read
(format-prompt "Find %s" symb prompt-type)
obarray predicate
- t nil nil (and symb (symbol-name symb)))))))
+ 'lambda nil nil (and symb (symbol-name symb)))))))
(defun find-function-do-it (symbol type switch-fn)
"Find Emacs Lisp SYMBOL in a buffer and display it.
diff --git a/lisp/emacs-lisp/gv.el b/lisp/emacs-lisp/gv.el
index 5c91ea67b39..fa9b437fcfd 100644
--- a/lisp/emacs-lisp/gv.el
+++ b/lisp/emacs-lisp/gv.el
@@ -416,9 +416,9 @@ The return value is the last VAL in the list.
(lambda (do key alist &optional default remove testfn)
(macroexp-let2 macroexp-copyable-p k key
(gv-letplace (getter setter) alist
- (macroexp-let2 nil p `(if (and ,testfn (not (eq ,testfn 'eq)))
- (assoc ,k ,getter ,testfn)
- (assq ,k ,getter))
+ (macroexp-let2 nil p (if (member testfn '(nil 'eq #'eq))
+ `(assq ,k ,getter)
+ `(assoc ,k ,getter ,testfn))
(funcall do (if (null default) `(cdr ,p)
`(if ,p (cdr ,p) ,default))
(lambda (v)
@@ -638,6 +638,13 @@ REF must have been previously obtained with `gv-ref'."
;;; Generalized variables.
+;; You'd think no one would write `(setf (error ...) ..)' but it
+;; appears naturally as the result of macroexpansion of things like
+;; (setf (pcase-exhaustive ...)).
+;; We could generalize this to `throw' and `signal', but it seems
+;; preferable to wait until there's a concrete need.
+(gv-define-expander error (lambda (_do &rest args) `(error . ,args)))
+
;; Some Emacs-related place types.
(gv-define-simple-setter buffer-file-name set-visited-file-name t)
(make-obsolete-generalized-variable
@@ -814,17 +821,5 @@ REF must have been previously obtained with `gv-ref'."
((eq ,getter ,val) ,(funcall setter `(not ,val))))))))))
(make-obsolete-generalized-variable 'eq nil "29.1")
-(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)
- (lambda (v)
- (macroexp-let2 nil v v
- `(progn
- ,(funcall setter `(cl--set-substring
- ,getter ,start ,end ,v))
- ,v))))))))
-
(provide 'gv)
;;; gv.el ends here
diff --git a/lisp/emacs-lisp/inline.el b/lisp/emacs-lisp/inline.el
index c774296084e..ddbd6fdc017 100644
--- a/lisp/emacs-lisp/inline.el
+++ b/lisp/emacs-lisp/inline.el
@@ -80,7 +80,9 @@
(error "inline-const-p can only be used within define-inline"))
(defmacro inline-const-val (_exp)
- "Return the value of EXP."
+ "Return the value of EXP.
+During inlining, if the value of EXP is not yet known, this aborts the
+inlining and makes us revert to a non-inlined function call."
(declare (debug t))
(error "inline-const-val can only be used within define-inline"))
diff --git a/lisp/emacs-lisp/lisp-mnt.el b/lisp/emacs-lisp/lisp-mnt.el
index ec468c36e33..f111a77663c 100644
--- a/lisp/emacs-lisp/lisp-mnt.el
+++ b/lisp/emacs-lisp/lisp-mnt.el
@@ -3,7 +3,7 @@
;; Copyright (C) 1992, 1994, 1997, 2000-2024 Free Software Foundation,
;; Inc.
-;; Author: Eric S. Raymond <esr@snark.thyrsus.com>
+;; Author: Eric S. Raymond <esr@thyrsus.com>
;; Maintainer: emacs-devel@gnu.org
;; Created: 14 Jul 1992
;; Keywords: docs
@@ -52,7 +52,7 @@
;;
;; * Copyright line, which looks more or less like this:
;;
-;; ;; Copyright (C) 1999, 2000, 2001 Free Software Foundation, Inc.
+;; ;; Copyright (C) 1999-2001 Free Software Foundation, Inc.
;;
;; * A blank line
;;
@@ -68,7 +68,7 @@
;; ;; Noah Friedman <friedman@ai.mit.edu>
;; ;; Joe Wells <jbw@maverick.uswest.com>
;; ;; Dave Brennan <brennan@hal.com>
-;; ;; Eric Raymond <esr@snark.thyrsus.com>
+;; ;; Eric S. Raymond <esr@thyrsus.com>
;;
;; * Maintainer line --- should be a single name/address as in the Author
;; line, or an address only. If there is no maintainer
@@ -187,7 +187,6 @@ If the given section does not exist, return nil."
(goto-char (point-min))
(if (re-search-forward (lm-get-header-re header 'section) nil t)
(line-beginning-position (if after 2))))))
-(defalias 'lm-section-mark 'lm-section-start)
(defun lm-section-end (header)
"Return the buffer location of the end of a given section.
@@ -230,12 +229,10 @@ a section."
(defun lm-code-start ()
"Return the buffer location of the `Code' start marker."
(lm-section-start "Code"))
-(defalias 'lm-code-mark 'lm-code-start)
(defun lm-commentary-start ()
"Return the buffer location of the `Commentary' start marker."
(lm-section-start lm-commentary-header))
-(defalias 'lm-commentary-mark 'lm-commentary-start)
(defun lm-commentary-end ()
"Return the buffer location of the `Commentary' section end."
@@ -244,7 +241,6 @@ a section."
(defun lm-history-start ()
"Return the buffer location of the `History' start marker."
(lm-section-start lm-history-header))
-(defalias 'lm-history-mark 'lm-history-start)
(defun lm-copyright-mark ()
"Return the buffer location of the `Copyright' line."
@@ -258,7 +254,7 @@ a section."
"Return the contents of the header named HEADER."
(goto-char (point-min))
(let ((case-fold-search t))
- (when (and (re-search-forward (lm-get-header-re header) (lm-code-mark) t)
+ (when (and (re-search-forward (lm-get-header-re header) (lm-code-start) t)
;; RCS ident likes format "$identifier: data$"
(looking-at
(if (save-excursion
@@ -402,7 +398,7 @@ ISO-DATE non-nil means return the date in ISO 8601 format."
(when (progn (goto-char (point-min))
(re-search-forward
"\\$[I]d: [^ ]+ [^ ]+ \\([^/]+\\)/\\([^/]+\\)/\\([^ ]+\\) "
- (lm-code-mark) t))
+ (lm-code-start) t))
(let ((dd (match-string 3))
(mm (match-string 2))
(yyyy (match-string 1)))
@@ -420,7 +416,7 @@ ISO-DATE non-nil means return the date in ISO 8601 format."
This can be found in an RCS or SCCS header."
(lm-with-file file
(or (lm-header "version")
- (let ((header-max (lm-code-mark)))
+ (let ((header-max (lm-code-start)))
(goto-char (point-min))
(cond
;; Look for an RCS header
@@ -439,6 +435,38 @@ This can be found in an RCS or SCCS header."
header-max t)
(match-string-no-properties 1)))))))
+(defun lm--prepare-package-dependencies (deps)
+ "Turn DEPS into an acceptable list of dependencies.
+
+Any parts missing a version string get a default version string
+of \"0\" (meaning any version) and an appropriate level of lists
+is wrapped around any parts requiring it."
+ (cond
+ ((not (listp deps))
+ (error "Invalid requirement specifier: %S" deps))
+ (t (mapcar (lambda (dep)
+ (cond
+ ((symbolp dep) `(,dep "0"))
+ ((stringp dep)
+ (error "Invalid requirement specifier: %S" dep))
+ ((and (listp dep) (null (cdr dep)))
+ (list (car dep) "0"))
+ (t dep)))
+ deps))))
+
+(declare-function package-read-from-string "package" (str))
+
+(defun lm-package-requires (&optional file)
+ "Return dependencies listed in file FILE, or current buffer if FILE is nil.
+The return value is a list of elements of the form (PACKAGE VERSION)
+where PACKAGE is the package name (a symbol) and VERSION is the
+package version (a string)."
+ (require 'package)
+ (lm-with-file file
+ (and-let* ((require-lines (lm-header-multiline "package-requires")))
+ (lm--prepare-package-dependencies
+ (package-read-from-string (mapconcat #'identity require-lines " "))))))
+
(defun lm-keywords (&optional file)
"Return the keywords given in file FILE, or current buffer if FILE is nil.
The return is a `downcase'-ed string, or nil if no keywords
@@ -524,6 +552,7 @@ says display \"OK\" in temp buffer for files that have no problems.
Optional argument VERBOSE specifies verbosity level.
Optional argument NON-FSF-OK if non-nil means a non-FSF
copyright notice is allowed."
+ ;; FIXME: Make obsolete in favor of checkdoc?
(interactive (list nil nil t))
(let* ((ret (and verbose "Ok"))
name)
@@ -557,19 +586,18 @@ copyright notice is allowed."
"`Keywords:' tag missing")
((not (lm-keywords-finder-p))
"`Keywords:' has no valid finder keywords (see `finder-known-keywords')")
- ((not (lm-commentary-mark))
+ ((not (lm-commentary-start))
"Can't find a `Commentary' section marker")
- ((not (lm-history-mark))
+ ((not (lm-history-start))
"Can't find a `History' section marker")
- ((not (lm-code-mark))
+ ((not (lm-code-start))
"Can't find a `Code' section marker")
((progn
(goto-char (point-max))
(not
(re-search-backward
- (concat "^;;;[ \t]+" name "[ \t]+ends here[ \t]*$"
- "\\|^;;;[ \t]+ End of file[ \t]+" name)
- nil t)))
+ (rx bol ";;; " (regexp name) " ends here")
+ nil t)))
"Can't find the footer line")
((not (and (lm-copyright-mark) (lm-crack-copyright)))
"Can't find a valid copyright notice")
@@ -631,6 +659,11 @@ Prompts for bug subject TOPIC. Leaves you in a mail buffer."
(message "%s"
(substitute-command-keys "Type \\[mail-send] to send bug report."))))
+(define-obsolete-function-alias 'lm-section-mark #'lm-section-start "30.1")
+(define-obsolete-function-alias 'lm-code-mark #'lm-code-start "30.1")
+(define-obsolete-function-alias 'lm-commentary-mark #'lm-commentary-start "30.1")
+(define-obsolete-function-alias 'lm-history-mark #'lm-history-start "30.1")
+
(provide 'lisp-mnt)
;;; lisp-mnt.el ends here
diff --git a/lisp/emacs-lisp/lisp-mode.el b/lisp/emacs-lisp/lisp-mode.el
index 5ab9f8603fe..3475d944337 100644
--- a/lisp/emacs-lisp/lisp-mode.el
+++ b/lisp/emacs-lisp/lisp-mode.el
@@ -31,11 +31,6 @@
(eval-when-compile (require 'cl-lib))
(eval-when-compile (require 'subr-x))
-(defvar font-lock-comment-face)
-(defvar font-lock-doc-face)
-(defvar font-lock-keywords-case-fold-search)
-(defvar font-lock-string-face)
-
(define-abbrev-table 'lisp-mode-abbrev-table ()
"Abbrev table for Lisp mode.")
@@ -134,7 +129,7 @@
(purecopy (concat "^\\s-*("
(regexp-opt
'(;; Elisp
- "defconst" "defcustom"
+ "defconst" "defcustom" "defvar-keymap"
;; CL
"defconstant"
"defparameter" "define-symbol-macro")
@@ -348,7 +343,7 @@ This will generate compile-time constants from BINDINGS."
(lisp-vdefs '("defvar"))
(lisp-kw '("cond" "if" "while" "let" "let*" "progn" "prog1"
"prog2" "lambda" "unwind-protect" "condition-case"
- "when" "unless" "with-output-to-string"
+ "when" "unless" "with-output-to-string" "handler-bind"
"ignore-errors" "dotimes" "dolist" "declare"))
(lisp-errs '("warn" "error" "signal"))
;; Elisp constructs. Now they are update dynamically
@@ -361,7 +356,7 @@ This will generate compile-time constants from BINDINGS."
"define-globalized-minor-mode" "define-skeleton"
"define-widget" "ert-deftest"))
(el-vdefs '("defconst" "defcustom" "defvaralias" "defvar-local"
- "defface"))
+ "defface" "define-error"))
(el-tdefs '("defgroup" "deftheme"))
(el-errs '("user-error"))
;; Common-Lisp constructs supported by EIEIO. FIXME: namespace.
@@ -381,7 +376,7 @@ This will generate compile-time constants from BINDINGS."
(cl-kw '("block" "break" "case" "ccase" "compiler-let" "ctypecase"
"declaim" "destructuring-bind" "do" "do*"
"ecase" "etypecase" "eval-when" "flet" "flet*"
- "go" "handler-case" "handler-bind" "in-package" ;; "inline"
+ "go" "handler-case" "in-package" ;; "inline"
"labels" "letf" "locally" "loop"
"macrolet" "multiple-value-bind" "multiple-value-prog1"
"proclaim" "prog" "prog*" "progv"
@@ -876,7 +871,7 @@ complete sexp in the innermost containing list at position
2 (counting from 0). This is important for Lisp indentation."
(unless pos (setq pos (point)))
(let ((pss (syntax-ppss pos)))
- (if (nth 9 pss)
+ (if (and (not (nth 2 pss)) (nth 9 pss))
(let ((sexp-start (car (last (nth 9 pss)))))
(parse-partial-sexp sexp-start pos nil nil (syntax-ppss sexp-start)))
pss)))
@@ -1351,9 +1346,7 @@ Lisp function does not specify a special indentation."
(put 'catch 'lisp-indent-function 1)
(put 'condition-case 'lisp-indent-function 2)
(put 'handler-case 'lisp-indent-function 1) ;CL
-(put 'handler-bind 'lisp-indent-function 1) ;CL
(put 'unwind-protect 'lisp-indent-function 1)
-(put 'with-output-to-temp-buffer 'lisp-indent-function 1)
(put 'closure 'lisp-indent-function 2)
(defun indent-sexp (&optional endpos)
@@ -1426,14 +1419,15 @@ A prefix argument specifies pretty-printing."
;;;; Lisp paragraph filling commands.
-(defcustom emacs-lisp-docstring-fill-column 65
+(defcustom emacs-lisp-docstring-fill-column 72
"Value of `fill-column' to use when filling a docstring.
Any non-integer value means do not use a different value of
`fill-column' when filling docstrings."
:type '(choice (integer)
(const :tag "Use the current `fill-column'" t))
:safe (lambda (x) (or (eq x t) (integerp x)))
- :group 'lisp)
+ :group 'lisp
+ :version "30.1")
(defun lisp-fill-paragraph (&optional justify)
"Like \\[fill-paragraph], but handle Emacs Lisp comments and docstrings.
@@ -1453,7 +1447,7 @@ and initial semicolons."
;; are buffer-local, but we avoid changing them so that they can be set
;; to make `forward-paragraph' and friends do something the user wants.
;;
- ;; `paragraph-start': The `(' in the character alternative and the
+ ;; `paragraph-start': The `(' in the bracket expression and the
;; left-singlequote plus `(' sequence after the \\| alternative prevent
;; sexps and backquoted sexps that follow a docstring from being filled
;; with the docstring. This setting has the consequence of inhibiting
diff --git a/lisp/emacs-lisp/lisp.el b/lisp/emacs-lisp/lisp.el
index d87f350fd9c..c57b1357f63 100644
--- a/lisp/emacs-lisp/lisp.el
+++ b/lisp/emacs-lisp/lisp.el
@@ -422,7 +422,8 @@ of a defun, nil if it failed to find one."
"\\(?:" defun-prompt-regexp "\\)\\s(")
"^\\s(")
nil 'move arg))
- (nth 8 (syntax-ppss))))
+ (save-match-data
+ (nth 8 (syntax-ppss)))))
found)
(progn (goto-char (1- (match-end 0)))
t)))
@@ -529,6 +530,7 @@ major mode's decisions about context.")
"Return the \"far end\" position of the buffer, in direction ARG.
If ARG is positive, that's the end of the buffer.
Otherwise, that's the beginning of the buffer."
+ (declare (side-effect-free error-free))
(if (> arg 0) (point-max) (point-min)))
(defun end-of-defun (&optional arg interactive)
diff --git a/lisp/emacs-lisp/loaddefs-gen.el b/lisp/emacs-lisp/loaddefs-gen.el
index 570f297b0e0..581053f6304 100644
--- a/lisp/emacs-lisp/loaddefs-gen.el
+++ b/lisp/emacs-lisp/loaddefs-gen.el
@@ -48,6 +48,7 @@ Standard prefixes won't be registered anyway. I.e. if a file
\"foo.el\" defines variables or functions that use \"foo-\" as
prefix, that will not be registered. But all other prefixes will
be included.")
+;;;###autoload
(put 'autoload-compute-prefixes 'safe-local-variable #'booleanp)
(defvar no-update-autoloads nil
@@ -182,7 +183,9 @@ expression, in which case we want to handle forms differently."
(loaddefs-generate--shorten-autoload
`(autoload ,(nth 1 form) ,file ,doc ,interactive ,type))))
- ((and expansion (memq car '(progn prog1)))
+ ;; Look inside `progn', and `eval-and-compile', since these
+ ;; are often used in the expansion of things like `pcase-defmacro'.
+ ((and expansion (memq car '(progn prog1 eval-and-compile)))
(let ((end (memq :autoload-end form)))
(when end ;Cut-off anything after the :autoload-end marker.
(setq form (copy-sequence form))
@@ -198,8 +201,7 @@ expression, in which case we want to handle forms differently."
define-globalized-minor-mode defun defmacro
easy-mmode-define-minor-mode define-minor-mode
define-inline cl-defun cl-defmacro cl-defgeneric
- cl-defstruct pcase-defmacro iter-defun cl-iter-defun
- transient-define-prefix))
+ cl-defstruct pcase-defmacro iter-defun cl-iter-defun))
(macrop car)
(setq expand (let ((load-true-file-name file)
(load-file-name file))
@@ -215,13 +217,17 @@ expression, in which case we want to handle forms differently."
define-globalized-minor-mode
easy-mmode-define-minor-mode define-minor-mode
cl-defun defun* cl-defmacro defmacro*
- define-overloadable-function))
+ define-overloadable-function
+ transient-define-prefix transient-define-suffix
+ transient-define-infix transient-define-argument))
(let* ((macrop (memq car '(defmacro cl-defmacro defmacro*)))
(name (nth 1 form))
(args (pcase car
((or 'defun 'defmacro
'defun* 'defmacro* 'cl-defun 'cl-defmacro
- 'define-overloadable-function)
+ 'define-overloadable-function
+ 'transient-define-prefix 'transient-define-suffix
+ 'transient-define-infix 'transient-define-argument)
(nth 2 form))
('define-skeleton '(&optional str arg))
((or 'define-generic-mode 'define-derived-mode
@@ -243,7 +249,11 @@ expression, in which case we want to handle forms differently."
define-global-minor-mode
define-globalized-minor-mode
easy-mmode-define-minor-mode
- define-minor-mode))
+ define-minor-mode
+ transient-define-prefix
+ transient-define-suffix
+ transient-define-infix
+ transient-define-argument))
t)
(and (eq (car-safe (car body)) 'interactive)
;; List of modes or just t.
@@ -377,6 +387,7 @@ don't include."
(let ((defs nil)
(load-name (loaddefs-generate--file-load-name file main-outfile))
(compute-prefixes t)
+ read-symbol-shorthands
local-outfile inhibit-autoloads)
(with-temp-buffer
(insert-file-contents file)
@@ -398,7 +409,22 @@ don't include."
(setq inhibit-autoloads (read (current-buffer)))))
(save-excursion
(when (re-search-forward "autoload-compute-prefixes: *" nil t)
- (setq compute-prefixes (read (current-buffer))))))
+ (setq compute-prefixes (read (current-buffer)))))
+ (save-excursion
+ ;; Since we're "open-coding", we have to repeat more
+ ;; complicated logic in `hack-local-variables'.
+ (when-let ((beg
+ (re-search-forward "read-symbol-shorthands: *" nil t)))
+ ;; `read-symbol-shorthands' alist ends with two parens.
+ (let* ((end (re-search-forward ")[;\n\s]*)"))
+ (commentless (replace-regexp-in-string
+ "\n\\s-*;+" ""
+ (buffer-substring beg end)))
+ (unsorted-shorthands (car (read-from-string commentless))))
+ (setq read-symbol-shorthands
+ (sort unsorted-shorthands
+ (lambda (sh1 sh2)
+ (> (length (car sh1)) (length (car sh2))))))))))
;; We always return the package version (even for pre-dumped
;; files).
@@ -472,27 +498,35 @@ don't include."
(when (and autoload-compute-prefixes
compute-prefixes)
- (when-let ((form (loaddefs-generate--compute-prefixes load-name)))
- ;; This output needs to always go in the main loaddefs.el,
- ;; regardless of `generated-autoload-file'.
- (push (list main-outfile file form) defs)))))
+ (with-demoted-errors "%S"
+ (when-let
+ ((form (loaddefs-generate--compute-prefixes load-name)))
+ ;; This output needs to always go in the main loaddefs.el,
+ ;; regardless of `generated-autoload-file'.
+ (push (list main-outfile file form) defs))))))
defs))
(defun loaddefs-generate--compute-prefixes (load-name)
(goto-char (point-min))
- (let ((prefs nil))
+ (let ((prefs nil)
+ (temp-obarray (obarray-make)))
;; Avoid (defvar <foo>) by requiring a trailing space.
(while (re-search-forward
"^(\\(def[^ \t\n]+\\)[ \t\n]+['(]*\\([^' ()\"\n]+\\)[\n \t]" nil t)
(unless (member (match-string 1) autoload-ignored-definitions)
- (let ((name (match-string-no-properties 2)))
- (when (save-excursion
- (goto-char (match-beginning 0))
- (or (bobp)
- (progn
- (forward-line -1)
- (not (looking-at ";;;###autoload")))))
- (push name prefs)))))
+ (let* ((name (match-string-no-properties 2))
+ ;; Consider `read-symbol-shorthands'.
+ (probe (let ((obarray temp-obarray))
+ (car (read-from-string name)))))
+ (when (symbolp probe)
+ (setq name (symbol-name probe))
+ (when (save-excursion
+ (goto-char (match-beginning 0))
+ (or (bobp)
+ (progn
+ (forward-line -1)
+ (not (looking-at ";;;###autoload")))))
+ (push name prefs))))))
(loaddefs-generate--make-prefixes prefs load-name)))
(defun loaddefs-generate--rubric (file &optional type feature compile)
diff --git a/lisp/emacs-lisp/macroexp.el b/lisp/emacs-lisp/macroexp.el
index 0e24b1bc118..b87b749dd76 100644
--- a/lisp/emacs-lisp/macroexp.el
+++ b/lisp/emacs-lisp/macroexp.el
@@ -39,6 +39,12 @@ of `byte-compile-form', etc., and manually popped off at its end.
This is to preserve the data in it in the event of a
condition-case handling a signaled error.")
+(defmacro macroexp--with-extended-form-stack (expr &rest body)
+ "Evaluate BODY with EXPR pushed onto `byte-compile-form-stack'."
+ (declare (indent 1))
+ `(let ((byte-compile-form-stack (cons ,expr byte-compile-form-stack)))
+ ,@body))
+
;; Bound by the top-level `macroexpand-all', and modified to include any
;; macros defined by `defmacro'.
(defvar macroexpand-all-environment nil)
@@ -105,14 +111,21 @@ each clause."
(macroexp--all-forms clause skip)
clause)))
+(defvar macroexp-inhibit-compiler-macros nil
+ "Inhibit application of compiler macros if non-nil.")
+
(defun macroexp--compiler-macro (handler form)
- (condition-case-unless-debug err
- (let ((symbols-with-pos-enabled t))
- (apply handler form (cdr form)))
- (error
- (message "Warning: Optimization failure for %S: Handler: %S\n%S"
- (car form) handler err)
- form)))
+ "Apply compiler macro HANDLER to FORM and return the result.
+Unless `macroexp-inhibit-compiler-macros' is non-nil, in which
+case return FORM unchanged."
+ (if macroexp-inhibit-compiler-macros
+ form
+ (condition-case-unless-debug err
+ (apply handler form (cdr form))
+ (error
+ (message "Warning: Optimization failure for %S: Handler: %S\n%S"
+ (car form) handler err)
+ form))))
(defun macroexp--funcall-if-compiled (_form)
"Pseudo function used internally by macroexp to delay warnings.
@@ -227,84 +240,79 @@ It should normally be a symbol with position and it defaults to FORM."
(defun macroexp-macroexpand (form env)
"Like `macroexpand' but checking obsolescence."
(let* ((macroexpand-all-environment env)
- (new-form
- (macroexpand form env)))
- (if (and (not (eq form new-form)) ;It was a macro call.
- (car-safe form)
- (symbolp (car form))
- (get (car form) 'byte-obsolete-info))
- (let* ((fun (car form))
- (obsolete (get fun 'byte-obsolete-info)))
- (macroexp-warn-and-return
- (macroexp--obsolete-warning
- fun obsolete
- (if (symbolp (symbol-function fun))
- "alias" "macro"))
- new-form (list 'obsolete fun) nil fun))
- new-form)))
+ new-form)
+ (while (not (eq form (setq new-form (macroexpand-1 form env))))
+ (let ((fun (car-safe form)))
+ (setq form
+ (if (and fun (symbolp fun)
+ (get fun 'byte-obsolete-info))
+ (macroexp-warn-and-return
+ (macroexp--obsolete-warning
+ fun (get fun 'byte-obsolete-info)
+ (if (symbolp (symbol-function fun)) "alias" "macro"))
+ new-form (list 'obsolete fun) nil fun)
+ new-form))))
+ form))
(defun macroexp--unfold-lambda (form &optional name)
- ;; In lexical-binding mode, let and functions don't bind vars in the same way
- ;; (let obey special-variable-p, but functions don't). But luckily, this
- ;; doesn't matter here, because function's behavior is underspecified so it
- ;; can safely be turned into a `let', even though the reverse is not true.
(or name (setq name "anonymous lambda"))
- (let* ((lambda (car form))
- (values (cdr form))
- (arglist (nth 1 lambda))
- (body (cdr (cdr lambda)))
- optionalp restp
- bindings)
- (if (and (stringp (car body)) (cdr body))
- (setq body (cdr body)))
- (if (and (consp (car body)) (eq 'interactive (car (car body))))
- (setq body (cdr body)))
- ;; FIXME: The checks below do not belong in an optimization phase.
- (while arglist
- (cond ((eq (car arglist) '&optional)
- ;; ok, I'll let this slide because funcall_lambda() does...
- ;; (if optionalp (error "Multiple &optional keywords in %s" name))
- (if restp (error "&optional found after &rest in %s" name))
- (if (null (cdr arglist))
- (error "Nothing after &optional in %s" name))
- (setq optionalp t))
- ((eq (car arglist) '&rest)
- ;; ...but it is by no stretch of the imagination a reasonable
- ;; thing that funcall_lambda() allows (&rest x y) and
- ;; (&rest x &optional y) in arglists.
- (if (null (cdr arglist))
- (error "Nothing after &rest in %s" name))
- (if (cdr (cdr arglist))
- (error "Multiple vars after &rest in %s" name))
- (setq restp t))
- (restp
- (setq bindings (cons (list (car arglist)
- (and values (cons 'list values)))
- bindings)
- values nil))
- ((and (not optionalp) (null values))
- (setq arglist nil values 'too-few))
- (t
- (setq bindings (cons (list (car arglist) (car values))
- bindings)
- values (cdr values))))
- (setq arglist (cdr arglist)))
- (if values
- (macroexp-warn-and-return
- (format (if (eq values 'too-few)
- "attempt to open-code `%s' with too few arguments"
- "attempt to open-code `%s' with too many arguments")
- name)
- form nil nil arglist)
-
- ;; The following leads to infinite recursion when loading a
- ;; file containing `(defsubst f () (f))', and then trying to
- ;; byte-compile that file.
- ;;(setq body (mapcar 'byte-optimize-form body)))
-
- (if bindings
- `(let ,(nreverse bindings) . ,body)
- (macroexp-progn body)))))
+ (pcase form
+ ((or `(funcall (function ,lambda) . ,actuals) `(,lambda . ,actuals))
+ (let* ((formals (nth 1 lambda))
+ (body (cdr (macroexp-parse-body (cddr lambda))))
+ optionalp restp
+ (dynboundarg nil)
+ bindings)
+ ;; FIXME: The checks below do not belong in an optimization phase.
+ (while formals
+ (if (macroexp--dynamic-variable-p (car formals))
+ (setq dynboundarg t))
+ (cond ((eq (car formals) '&optional)
+ ;; ok, I'll let this slide because funcall_lambda() does...
+ ;; (if optionalp (error "Multiple &optional keywords in %s" name))
+ (if restp (error "&optional found after &rest in %s" name))
+ (if (null (cdr formals))
+ (error "Nothing after &optional in %s" name))
+ (setq optionalp t))
+ ((eq (car formals) '&rest)
+ ;; ...but it is by no stretch of the imagination a reasonable
+ ;; thing that funcall_lambda() allows (&rest x y) and
+ ;; (&rest x &optional y) in formalss.
+ (if (null (cdr formals))
+ (error "Nothing after &rest in %s" name))
+ (if (cdr (cdr formals))
+ (error "Multiple vars after &rest in %s" name))
+ (setq restp t))
+ (restp
+ (setq bindings (cons (list (car formals)
+ (and actuals (cons 'list actuals)))
+ bindings)
+ actuals nil))
+ ((and (not optionalp) (null actuals))
+ (setq formals nil actuals 'too-few))
+ (t
+ (setq bindings (cons (list (car formals) (car actuals))
+ bindings)
+ actuals (cdr actuals))))
+ (setq formals (cdr formals)))
+ (cond
+ (actuals
+ (macroexp-warn-and-return
+ (format-message
+ (if (eq actuals 'too-few)
+ "attempt to open-code `%s' with too few arguments"
+ "attempt to open-code `%s' with too many arguments")
+ name)
+ form nil nil formals))
+ ;; In lexical-binding mode, let and functions don't bind vars in
+ ;; the same way (let obey special-variable-p, but functions
+ ;; don't). So if one of the vars is declared as dynamically scoped, we
+ ;; can't just convert the call to `let'.
+ ;; FIXME: We should α-rename the affected args and then use `let'.
+ (dynboundarg form)
+ (bindings `(let ,(nreverse bindings) . ,body))
+ (t (macroexp-progn body)))))
+ (_ (error "Not an unfoldable form: %S" form))))
(defun macroexp--dynamic-variable-p (var)
"Whether the variable VAR is dynamically scoped.
@@ -320,8 +328,7 @@ Only valid during macro-expansion."
"Expand all macros in FORM.
This is an internal version of `macroexpand-all'.
Assumes the caller has bound `macroexpand-all-environment'."
- (push form byte-compile-form-stack)
- (prog1
+ (macroexp--with-extended-form-stack form
(if (eq (car-safe form) 'backquote-list*)
;; Special-case `backquote-list*', as it is normally a macro that
;; generates exceedingly deep expansions from relatively shallow input
@@ -336,16 +343,48 @@ Assumes the caller has bound `macroexpand-all-environment'."
(let ((fn (car-safe form)))
(pcase form
(`(cond . ,clauses)
- (macroexp--cons fn (macroexp--all-clauses clauses) form))
+ ;; Check for rubbish clauses at the end before macro-expansion,
+ ;; to avoid nuisance warnings from clauses that become
+ ;; unconditional through that process.
+ ;; FIXME: this strategy is defeated by forced `macroexpand-all',
+ ;; such as in `cl-flet'. Haven't seen that in the wild, though.
+ (let ((default-tail nil)
+ (n 0)
+ (rest clauses))
+ (while rest
+ (let ((c (car-safe (car rest))))
+ (when (cond ((consp c) (and (memq (car c) '(quote function))
+ (cadr c)))
+ ((symbolp c) (or (eq c t) (keywordp c)))
+ (t t))
+ ;; This is unquestionably a default clause.
+ (setq default-tail (cdr rest))
+ (setq clauses (take (1+ n) clauses)) ; trim the tail
+ (setq rest nil)))
+ (setq n (1+ n))
+ (setq rest (cdr rest)))
+ (let ((expanded-form
+ (macroexp--cons fn (macroexp--all-clauses clauses) form)))
+ (if default-tail
+ (macroexp-warn-and-return
+ (format-message
+ "Useless clause following default `cond' clause")
+ expanded-form '(suspicious cond) t default-tail)
+ expanded-form))))
(`(condition-case . ,(or `(,err ,body . ,handlers) pcase--dontcare))
- (macroexp--cons
- fn
- (macroexp--cons err
- (macroexp--cons (macroexp--expand-all body)
- (macroexp--all-clauses handlers 1)
- (cddr form))
- (cdr form))
- form))
+ (let ((exp-body (macroexp--expand-all body)))
+ (if handlers
+ (macroexp--cons fn
+ (macroexp--cons
+ err (macroexp--cons
+ exp-body
+ (macroexp--all-clauses handlers 1)
+ (cddr form))
+ (cdr form))
+ form)
+ (macroexp-warn-and-return
+ (format-message "`condition-case' without handlers")
+ exp-body (list 'suspicious 'condition-case) t form))))
(`(,(or 'defvar 'defconst) ,(and name (pred symbolp)) . ,_)
(push name macroexp--dynvars)
(macroexp--all-forms form 2))
@@ -367,16 +406,21 @@ Assumes the caller has bound `macroexpand-all-environment'."
(if (null body)
(macroexp-unprogn
(macroexp-warn-and-return
- (format "Empty %s body" fun)
- nil nil 'compile-only fun))
+ (format-message "`%s' with empty body" fun)
+ nil (list 'empty-body fun) 'compile-only fun))
(macroexp--all-forms body))
(cdr form))
form)))
(`(while)
(macroexp-warn-and-return
- "missing `while' condition"
+ (format-message "missing `while' condition")
`(signal 'wrong-number-of-arguments '(while 0))
nil 'compile-only form))
+ (`(unwind-protect ,expr)
+ (macroexp-warn-and-return
+ (format-message "`unwind-protect' without unwind forms")
+ (macroexp--expand-all expr)
+ (list 'suspicious 'unwind-protect) t form))
(`(setq ,(and var (pred symbolp)
(pred (not booleanp)) (pred (not keywordp)))
,expr)
@@ -392,7 +436,7 @@ Assumes the caller has bound `macroexpand-all-environment'."
(let ((nargs (length args)))
(if (/= (logand nargs 1) 0)
(macroexp-warn-and-return
- "odd number of arguments in `setq' form"
+ (format-message "odd number of arguments in `setq' form")
`(signal 'wrong-number-of-arguments '(setq ,nargs))
nil 'compile-only fn)
(let ((assignments nil))
@@ -426,50 +470,31 @@ Assumes the caller has bound `macroexpand-all-environment'."
(setq args (cddr args)))
(cons 'progn (nreverse assignments))))))
(`(,(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 (<args>) <body>). 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))))
+ (macroexp--cons (macroexp--all-forms fun 2)
+ (macroexp--all-forms args)
+ form))
(`(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
+ ;; Rewrite (funcall #'foo bar) to (foo bar), in case `foo'
+ ;; has a compiler-macro, or to unfold it.
((and `#',f
- (guard (not (or (special-form-p f) (macrop f))))) ;; bug#46636
+ (guard (and (symbolp f)
+ ;; bug#46636
+ (not (or (special-form-p f) (macrop f))))))
(macroexp--expand-all `(,f . ,eargs)))
- (_ `(funcall ,eexp . ,eargs)))))
+ (`#'(lambda . ,_)
+ (macroexp--unfold-lambda `(,fn ,eexp . ,eargs)))
+ (_ `(,fn ,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))))))
+ (let ((handler (function-get func 'compiler-macro)))
;; 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).
+ ;; No compiler macro. We just expand each argument.
(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.
@@ -486,23 +511,9 @@ Assumes the caller has bound `macroexpand-all-environment'."
(setq form (macroexp--compiler-macro handler newform))
(if (eq newform form)
newform
- (macroexp--expand-all newform)))
+ (macroexp--expand-all form)))
(macroexp--expand-all newform))))))
- (_ form))))
- (pop byte-compile-form-stack)))
-
-;; Record which arguments expect functions, so we can warn when those
-;; are accidentally quoted with ' rather than with #'
-(dolist (f '( funcall apply mapcar mapatoms mapconcat mapc cl-mapcar maphash
- map-char-table map-keymap map-keymap-internal))
- (put f 'funarg-positions '(1)))
-(dolist (f '( add-hook remove-hook advice-remove advice--remove-function
- defalias fset global-set-key run-after-idle-timeout
- set-process-filter set-process-sentinel sort))
- (put f 'funarg-positions '(2)))
-(dolist (f '( advice-add define-key
- run-at-time run-with-idle-timer run-with-timer ))
- (put f 'funarg-positions '(3)))
+ (_ form))))))
;;;###autoload
(defun macroexpand-all (form &optional environment)
@@ -526,11 +537,17 @@ definitions to shadow the loaded ones for use in file byte-compilation."
(defun macroexp-parse-body (body)
"Parse a function BODY into (DECLARATIONS . EXPS)."
(let ((decls ()))
- (while (and (cdr body)
- (let ((e (car body)))
- (or (stringp e)
- (memq (car-safe e)
- '(:documentation declare interactive cl-declare)))))
+ (while
+ (and body
+ (let ((e (car body)))
+ (or (and (stringp e)
+ ;; If there is only a string literal with
+ ;; nothing following, we consider this to be
+ ;; part of the body (the return value) rather
+ ;; than a declaration at this point.
+ (cdr body))
+ (memq (car-safe e)
+ '(:documentation declare interactive cl-declare)))))
(push (pop body) decls))
(cons (nreverse decls) body)))
@@ -787,40 +804,38 @@ test of free variables in the following ways:
(defun internal-macroexpand-for-load (form full-p)
;; Called from the eager-macroexpansion in readevalloop.
- (let ((symbols-with-pos-enabled t)
- (print-symbols-bare t))
- (cond
- ;; Don't repeat the same warning for every top-level element.
- ((eq 'skip (car macroexp--pending-eager-loads)) form)
- ;; If we detect a cycle, skip macro-expansion for now, and output a warning
- ;; with a trimmed backtrace.
- ((and load-file-name (member load-file-name macroexp--pending-eager-loads))
- (let* ((bt (delq nil
- (mapcar #'macroexp--trim-backtrace-frame
- (macroexp--backtrace))))
- (elem `(load ,(file-name-nondirectory load-file-name)))
- (tail (member elem (cdr (member elem bt)))))
- (if tail (setcdr tail (list '…)))
- (if (eq (car-safe (car bt)) 'macroexpand-all) (setq bt (cdr bt)))
- (if macroexp--debug-eager
- (debug 'eager-macroexp-cycle)
- (error "Eager macro-expansion skipped due to cycle:\n %s"
- (mapconcat #'prin1-to-string (nreverse bt) " => ")))
- (push 'skip macroexp--pending-eager-loads)
- form))
- (t
- (condition-case err
- (let ((macroexp--pending-eager-loads
- (cons load-file-name macroexp--pending-eager-loads)))
- (if full-p
- (macroexpand--all-toplevel form)
- (macroexpand form)))
- (error
- ;; Hopefully this shouldn't happen thanks to the cycle detection,
- ;; but in case it does happen, let's catch the error and give the
- ;; code a chance to macro-expand later.
- (error "Eager macro-expansion failure: %S" err)
- form))))))
+ (cond
+ ;; Don't repeat the same warning for every top-level element.
+ ((eq 'skip (car macroexp--pending-eager-loads)) form)
+ ;; If we detect a cycle, skip macro-expansion for now, and output a warning
+ ;; with a trimmed backtrace.
+ ((and load-file-name (member load-file-name macroexp--pending-eager-loads))
+ (let* ((bt (delq nil
+ (mapcar #'macroexp--trim-backtrace-frame
+ (macroexp--backtrace))))
+ (elem `(load ,(file-name-nondirectory load-file-name)))
+ (tail (member elem (cdr (member elem bt)))))
+ (if tail (setcdr tail (list '…)))
+ (if (eq (car-safe (car bt)) 'macroexpand-all) (setq bt (cdr bt)))
+ (if macroexp--debug-eager
+ (debug 'eager-macroexp-cycle)
+ (error "Eager macro-expansion skipped due to cycle:\n %s"
+ (mapconcat #'prin1-to-string (nreverse bt) " => ")))
+ (push 'skip macroexp--pending-eager-loads)
+ form))
+ (t
+ (condition-case err
+ (let ((macroexp--pending-eager-loads
+ (cons load-file-name macroexp--pending-eager-loads)))
+ (if full-p
+ (macroexpand--all-toplevel form)
+ (macroexpand form)))
+ ((debug error)
+ ;; Hopefully this shouldn't happen thanks to the cycle detection,
+ ;; but in case it does happen, let's catch the error and give the
+ ;; code a chance to macro-expand later.
+ (error "Eager macro-expansion failure: %S" err)
+ form)))))
;; ¡¡¡ Big Ugly Hack !!!
;; src/bootstrap-emacs is mostly used to compile .el files, so it needs
diff --git a/lisp/emacs-lisp/map-ynp.el b/lisp/emacs-lisp/map-ynp.el
index 2c0a3446773..b603f2e6d0b 100644
--- a/lisp/emacs-lisp/map-ynp.el
+++ b/lisp/emacs-lisp/map-ynp.el
@@ -168,16 +168,14 @@ The function's value is the number of actions taken."
(key-description (vector help-char)))
(if minibuffer-auto-raise
(raise-frame (window-frame (minibuffer-window))))
- (while (progn
- (setq char (read-event))
- ;; If we get -1, from end of keyboard
- ;; macro, try again.
- (equal char -1)))
+ (setq char (read-event))
;; Show the answer to the question.
(message "%s(y, n, !, ., q, %sor %s) %s"
prompt user-keys
(key-description (vector help-char))
- (single-key-description char)))
+ (if (equal char -1)
+ "[end-of-keyboard-macro]"
+ (single-key-description char))))
(setq def (lookup-key map (vector char))))
(cond ((eq def 'exit)
(setq next (lambda () nil)))
diff --git a/lisp/emacs-lisp/map.el b/lisp/emacs-lisp/map.el
index 8e545db8224..d3d71a36ee4 100644
--- a/lisp/emacs-lisp/map.el
+++ b/lisp/emacs-lisp/map.el
@@ -8,6 +8,9 @@
;; Version: 3.3.1
;; Package-Requires: ((emacs "26"))
+;; This is a GNU ELPA :core package. Avoid functionality that is not
+;; compatible with the version of Emacs recorded above.
+
;; This file is part of GNU Emacs.
;; GNU Emacs is free software: you can redistribute it and/or modify
@@ -50,18 +53,20 @@
ARGS is a list of elements to be matched in the map.
-Each element of ARGS can be of the form (KEY PAT), in which case KEY is
-evaluated and searched for in the map. The match fails if for any KEY
-found in the map, the corresponding PAT doesn't match the value
-associated with the KEY.
+Each element of ARGS can be of the form (KEY PAT [DEFAULT]),
+which looks up KEY in the map and matches the associated value
+against `pcase' pattern PAT. DEFAULT specifies the fallback
+value to use when KEY is not present in the map. If omitted, it
+defaults to nil. Both KEY and DEFAULT are evaluated.
Each element can also be a SYMBOL, which is an abbreviation of
a (KEY PAT) tuple of the form (\\='SYMBOL SYMBOL). When SYMBOL
is a keyword, it is an abbreviation of the form (:SYMBOL SYMBOL),
useful for binding plist values.
-Keys in ARGS not found in the map are ignored, and the match doesn't
-fail."
+An element of ARGS fails to match if PAT does not match the
+associated value or the default value. The overall pattern fails
+to match if any element of ARGS fails to match."
`(and (pred mapp)
,@(map--make-pcase-bindings args)))
@@ -71,12 +76,13 @@ fail."
KEYS can be a list of symbols, in which case each element will be
bound to the looked up value in MAP.
-KEYS can also be a list of (KEY VARNAME) pairs, in which case
-KEY is an unquoted form.
+KEYS can also be a list of (KEY VARNAME [DEFAULT]) sublists, in
+which case KEY and DEFAULT are unquoted forms.
MAP can be an alist, plist, hash-table, or array."
(declare (indent 2)
- (debug ((&rest &or symbolp ([form symbolp])) form body)))
+ (debug ((&rest &or symbolp ([form symbolp &optional form]))
+ form body)))
`(pcase-let ((,(map--make-pcase-patterns keys) ,map))
,@body))
@@ -595,15 +601,37 @@ Example:
(map-into \\='((1 . 3)) \\='(hash-table :test eql))"
(map--into-hash map (cdr type)))
+(defmacro map--pcase-map-elt (key default map)
+ "A macro to make MAP the last argument to `map-elt'.
+
+This allows using default values for `map-elt', which can't be
+done using `pcase--flip'.
+
+KEY is the key sought in the map. DEFAULT is the default value."
+ ;; It's obsolete in Emacs>29, but `map.el' is distributed via GNU ELPA
+ ;; for earlier Emacsen.
+ (declare (obsolete _ "30.1"))
+ `(map-elt ,map ,key ,default))
+
(defun map--make-pcase-bindings (args)
"Return a list of pcase bindings from ARGS to the elements of a map."
- (mapcar (lambda (elt)
- (cond ((consp elt)
- `(app (pcase--flip map-elt ,(car elt)) ,(cadr elt)))
- ((keywordp elt)
- (let ((var (intern (substring (symbol-name elt) 1))))
- `(app (pcase--flip map-elt ,elt) ,var)))
- (t `(app (pcase--flip map-elt ',elt) ,elt))))
+ (mapcar (if (< emacs-major-version 30)
+ (lambda (elt)
+ (cond ((consp elt)
+ `(app (map--pcase-map-elt ,(car elt) ,(caddr elt))
+ ,(cadr elt)))
+ ((keywordp elt)
+ (let ((var (intern (substring (symbol-name elt) 1))))
+ `(app (pcase--flip map-elt ,elt) ,var)))
+ (t `(app (pcase--flip map-elt ',elt) ,elt))))
+ (lambda (elt)
+ (cond ((consp elt)
+ `(app (map-elt _ ,(car elt) ,(caddr elt))
+ ,(cadr elt)))
+ ((keywordp elt)
+ (let ((var (intern (substring (symbol-name elt) 1))))
+ `(app (map-elt _ ,elt) ,var)))
+ (t `(app (map-elt _ ',elt) ,elt)))))
args))
(defun map--make-pcase-patterns (args)
diff --git a/lisp/emacs-lisp/nadvice.el b/lisp/emacs-lisp/nadvice.el
index 2b5568c1c94..5326c520601 100644
--- a/lisp/emacs-lisp/nadvice.el
+++ b/lisp/emacs-lisp/nadvice.el
@@ -165,6 +165,8 @@ DOC is a string where \"FUNCTION\" and \"OLDFUN\" are expected.")
(buffer-string))
usage))))
+;; FIXME: How about renaming this to just `eval-interactive-spec'?
+;; It's not specific to the advice system.
(defun advice-eval-interactive-spec (spec)
"Evaluate the interactive spec SPEC."
(cond
@@ -174,24 +176,44 @@ DOC is a string where \"FUNCTION\" and \"OLDFUN\" are expected.")
;; FIXME: Despite appearances, this is not faithful: SPEC and
;; (advice-eval-interactive-spec SPEC) will behave subtly differently w.r.t
;; command-history (and maybe a few other details).
- (call-interactively `(lambda (&rest args) (interactive ,spec) args)))
+ (call-interactively
+ ;; Sadly (lambda (&rest args) (interactive spec) args) doesn't work :-(
+ (cconv--interactive-helper (lambda (&rest args) args) spec)))
;; ((functionp spec) (funcall spec))
(t (eval spec))))
+(defun advice--interactive-form-1 (function)
+ "Like `interactive-form' but preserves the static context if needed."
+ (let ((if (interactive-form function)))
+ (if (or (null if) (not (eq 'closure (car-safe function))))
+ if
+ (cl-assert (eq 'interactive (car if)))
+ (let ((form (cadr if)))
+ (if (macroexp-const-p form) ;Common case: a string.
+ if
+ ;; The interactive is expected to be run in the static context
+ ;; that the function captured.
+ (let ((ctx (nth 1 function)))
+ `(interactive
+ ,(let* ((f (if (eq 'function (car-safe form)) (cadr form) form)))
+ ;; If the form jut returns a function, preserve the fact that
+ ;; it just returns a function, which is an info we use in
+ ;; `advice--make-interactive-form'.
+ (if (eq 'lambda (car-safe f))
+ `',(eval form ctx)
+ `(eval ',form ',ctx))))))))))
+
(defun advice--interactive-form (function)
"Like `interactive-form' but tries to avoid autoloading functions."
(if (not (and (symbolp function) (autoloadp (indirect-function function))))
- (interactive-form function)
+ (advice--interactive-form-1 function)
(when (commandp function)
`(interactive (advice-eval-interactive-spec
- (cadr (interactive-form ',function)))))))
+ (cadr (advice--interactive-form-1 ',function)))))))
(defun advice--make-interactive-form (iff ifm)
- ;; TODO: make it so that interactive spec can be a constant which
- ;; dynamically checks the advice--car/cdr to do its job.
- ;; For that, advice-eval-interactive-spec needs to be more faithful.
(let* ((fspec (cadr iff)))
- (when (eq 'function (car-safe fspec)) ;; Macroexpanded lambda?
+ (when (memq (car-safe fspec) '(function quote)) ;; Macroexpanded lambda?
(setq fspec (eval fspec t)))
(if (functionp fspec)
`(funcall ',fspec ',(cadr ifm))
@@ -270,14 +292,13 @@ HOW is a symbol to select an entry in `advice--how-alist'."
(equal function (cdr (assq 'name props))))
(list (advice--remove-function rest function)))))))
-(defvar advice--buffer-local-function-sample nil
- "Keeps an example of the special \"run the default value\" functions.
-These functions play the same role as t in buffer-local hooks, and to recognize
-them, we keep a sample here against which to compare. Each instance is
-different, but `function-equal' will hopefully ignore those differences.")
+(oclosure-define (advice--forward
+ (:predicate advice--forward-p))
+ "Redirect to the global value of a var.
+These functions act like the t special value in buffer-local hooks.")
(defun advice--set-buffer-local (var val)
- (if (function-equal val advice--buffer-local-function-sample)
+ (if (advice--forward-p val)
(kill-local-variable var)
(set (make-local-variable var) val)))
@@ -286,11 +307,10 @@ different, but `function-equal' will hopefully ignore those differences.")
"Buffer-local value of VAR, presumed to contain a function."
(declare (gv-setter advice--set-buffer-local))
(if (local-variable-p var) (symbol-value var)
- (setq advice--buffer-local-function-sample
- ;; This function acts like the t special value in buffer-local hooks.
- ;; FIXME: Provide an `advice-bottom' function that's like
- ;; `advice-cd*r' but also follows through this proxy.
- (lambda (&rest args) (apply (default-value var) args)))))
+ ;; FIXME: Provide an `advice-bottom' function that's like
+ ;; `advice--cd*r' but also follows through this proxy.
+ (oclosure-lambda (advice--forward) (&rest args)
+ (apply (default-value var) args))))
(eval-and-compile
(defun advice--normalize-place (place)
@@ -369,26 +389,8 @@ is also interactive. There are 3 cases:
`(advice--add-function ,how (gv-ref ,(advice--normalize-place place))
,function ,props))
-(declare-function comp-subr-trampoline-install "comp")
-
;;;###autoload
(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)))))
- ;; Requiring the native compiler to advice `macroexpand' cause a
- ;; circular dependency in eager macro expansion. uniquify is
- ;; advising `rename-buffer' while being loaded in loadup.el.
- ;; This would require the whole native compiler machinery but we
- ;; don't want to include it in the dump. Because these two
- ;; functions are already handled in
- ;; `native-comp-never-optimize-functions' we hack the problem
- ;; this way for now :/
- (unless (memq subr-name '(macroexpand rename-buffer))
- ;; Must require explicitly as during bootstrap we have no
- ;; autoloads.
- (require 'comp)
- (comp-subr-trampoline-install subr-name))))
(let* ((name (cdr (assq 'name props)))
(a (advice--member-p (or name function) (if name t) (gv-deref ref))))
(when a
@@ -507,8 +509,6 @@ HOW can be one of:
<<>>"
;; TODO:
;; - record the advice location, to display in describe-function.
- ;; - change all defadvice in lisp/**/*.el.
- ;; - obsolete advice.el.
(let* ((f (symbol-function symbol))
(nf (advice--normalize symbol f)))
(unless (eq f nf) (fset symbol nf))
@@ -539,6 +539,32 @@ Contrary to `remove-function', this also works when SYMBOL is a macro
or an autoload and it preserves `fboundp'.
Instead of the actual function to remove, FUNCTION can also be the `name'
of the piece of advice."
+ (interactive
+ (let* ((pred (lambda (sym) (advice--p (advice--symbol-function sym))))
+ (default (when-let* ((f (function-called-at-point))
+ ((funcall pred f)))
+ (symbol-name f)))
+ (prompt (format-prompt "Remove advice from function" default))
+ (symbol (intern (completing-read prompt obarray pred t nil nil default)))
+ advices)
+ (advice-mapc (lambda (f p)
+ (let ((k (or (alist-get 'name p) f)))
+ (push (cons
+ ;; "name" (string) and 'name (symbol) are
+ ;; considered different names so we use
+ ;; `prin1-to-string' even if the name is
+ ;; a string to distinguish between these
+ ;; two cases.
+ (prin1-to-string k)
+ ;; We use `k' here instead of `f' because
+ ;; the same advice can have multiple
+ ;; names.
+ k)
+ advices)))
+ symbol)
+ (list symbol (cdr (assoc-string
+ (completing-read "Advice to remove: " advices nil t)
+ advices)))))
(let ((f (symbol-function symbol)))
(remove-function (cond ;This is `advice--symbol-function' but as a "place".
((get symbol 'advice--pending)
@@ -559,8 +585,8 @@ of the piece of advice."
(defmacro define-advice (symbol args &rest body)
"Define an advice and add it to function named SYMBOL.
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'.
+arguments. If NAME is non-nil, the advice is named `SYMBOL@NAME'
+and installed with the name NAME; otherwise, the advice is anonymous.
\(fn SYMBOL (HOW LAMBDA-LIST &optional NAME DEPTH) &rest BODY)"
(declare (indent 2) (doc-string 3) (debug (sexp sexp def-body)))
@@ -571,7 +597,9 @@ otherwise it is named `SYMBOL@NAME'.
(lambda-list (nth 1 args))
(name (nth 2 args))
(depth (nth 3 args))
- (props (and depth `((depth . ,depth))))
+ (props (append
+ (and depth `((depth . ,depth)))
+ (and name `((name . ,name)))))
(advice (cond ((null name) `(lambda ,lambda-list ,@body))
((or (stringp name) (symbolp name))
(intern (format "%s@%s" symbol name)))
diff --git a/lisp/emacs-lisp/oclosure.el b/lisp/emacs-lisp/oclosure.el
index 19e0834ba05..4da8e61aaa7 100644
--- a/lisp/emacs-lisp/oclosure.el
+++ b/lisp/emacs-lisp/oclosure.el
@@ -51,7 +51,7 @@
;; - 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
+;; https://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)
@@ -139,12 +139,15 @@
(:include cl--class)
(:copier nil))
"Metaclass for OClosure classes."
+ ;; The `allparents' slot is used for the predicate that checks if a given
+ ;; object is an OClosure of a particular type.
(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)))
+ "The root parent of all OClosure types"
+ nil (list (cl--find-class 'function))
+ '(oclosure)))
(defun oclosure--p (oclosure)
(not (not (oclosure-type oclosure))))
@@ -350,6 +353,7 @@ 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)))
+ (cl-assert lexical-binding) ;Can't work in dynbind dialect.
;; 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
@@ -433,7 +437,7 @@ This has 2 uses:
- 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
+ ;; Actually, this should never happen since `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
@@ -569,7 +573,7 @@ This has 2 uses:
(defun cconv--interactive-helper (fun if)
"Add interactive \"form\" IF to FUN.
Returns a new command that otherwise behaves like FUN.
-IF should actually not be a form but a function of no arguments."
+IF can be an ELisp form to be interpreted or a function of no arguments."
(oclosure-lambda (cconv--interactive-helper (fun fun) (if if))
(&rest args)
(apply (if (called-interactively-p 'any)
diff --git a/lisp/emacs-lisp/package-vc.el b/lisp/emacs-lisp/package-vc.el
index 5c5486de290..ef056c7909b 100644
--- a/lisp/emacs-lisp/package-vc.el
+++ b/lisp/emacs-lisp/package-vc.el
@@ -62,6 +62,18 @@
(defconst package-vc--elpa-packages-version 1
"Version number of the package specification format understood by package-vc.")
+(defconst package-vc--backend-type
+ `(choice :convert-widget
+ ,(lambda (widget)
+ (let (opts)
+ (dolist (be vc-handled-backends)
+ (when (or (vc-find-backend-function be 'clone)
+ (alist-get 'clone (get be 'vc-functions)))
+ (push (widget-convert (list 'const be)) opts)))
+ (widget-put widget :args opts))
+ widget))
+ "The type of VC backends that support cloning package VCS repositories.")
+
(defcustom package-vc-heuristic-alist
`((,(rx bos "http" (? "s") "://"
(or (: (? "www.") "github.com"
@@ -94,24 +106,34 @@
(+ (or alnum "-" "." "_")) (? "/")))
eos)
. Bzr))
- "Heuristic mapping URL regular expressions to VC backends."
+ "Alist mapping repository URLs to VC backends.
+`package-vc-install' consults this alist to determine the VC
+backend from the repository URL when you call it without
+specifying a backend. Each element of the alist has the form
+\(URL-REGEXP . BACKEND). `package-vc-install' will use BACKEND of
+the first association for which the URL of the repository matches
+the URL-REGEXP of the association. If no match is found,
+`package-vc-install' uses `package-vc-default-backend' instead."
:type `(alist :key-type (regexp :tag "Regular expression matching URLs")
- :value-type (choice :tag "VC Backend"
- ,@(mapcar (lambda (b) `(const ,b))
- vc-handled-backends)))
+ :value-type ,package-vc--backend-type)
:version "29.1")
(defcustom package-vc-default-backend 'Git
- "Default VC backend used when cloning a package repository.
-If no repository type was specified or could be guessed by
-`package-vc-heuristic-alist', this is the default VC backend
-used as fallback. The value must be a member of
-`vc-handled-backends' and the named backend must implement
-the `clone' function."
- :type `(choice ,@(mapcar (lambda (b) (list 'const b))
- vc-handled-backends))
+ "Default VC backend to use for cloning package repositories.
+`package-vc-install' uses this backend when you specify neither
+the backend nor a repository URL that's recognized via
+`package-vc-heuristic-alist'.
+
+The value must be a member of `vc-handled-backends' that supports
+the `clone' VC function."
+ :type package-vc--backend-type
:version "29.1")
+(defcustom package-vc-register-as-project t
+ "Non-nil means that packages should be registered as projects."
+ :type 'boolean
+ :version "30.1")
+
(defvar package-vc-selected-packages) ; pacify byte-compiler
;;;###autoload
@@ -135,20 +157,21 @@ the `clone' function."
(package-desc-create :name name :kind 'vc))
spec)))))))
-(defcustom package-vc-selected-packages '()
- "List of packages that must be installed.
-Each member of the list is of the form (NAME . SPEC), where NAME
-is a symbol designating the package and SPEC is one of:
+
+(defcustom package-vc-selected-packages nil
+ "List of packages to install from their VCS repositories.
+Each element is of the form (NAME . SPEC), where NAME is a symbol
+designating the package and SPEC is one of:
- nil, if any package version can be installed;
- a version string, if that specific revision is to be installed;
-- a property list, describing a package specification. For more
- details, please consult the subsection \"Specifying Package
- Sources\" in the Info node `(emacs)Fetching Package Sources'.
+- a property list, describing a package specification. For possible
+ values, see the subsection \"Specifying Package Sources\" in the
+ Info node `(emacs)Fetching Package Sources'.
-This user option will be automatically updated to store package
-specifications for packages that are not specified in any
-archive."
+The command `package-vc-install' updates the value of this user
+option to store package specifications for packages that are not
+specified in any archive."
:type '(alist :tag "List of packages you want to be installed"
:key-type (symbol :tag "Package")
:value-type
@@ -339,6 +362,47 @@ asynchronously."
"\n")
nil pkg-file nil 'silent))))
+(defcustom package-vc-allow-build-commands nil
+ "Whether to run extra build commands when installing VC packages.
+
+Some packages specify \"make\" targets or other shell commands
+that should run prior to building the package, by including the
+:make or :shell-command keywords in their specification. By
+default, Emacs ignores these keywords when installing and
+upgrading VC packages, but if the value is a list of package
+names (symbols), the build commands will be run for those
+packages. If the value is t, always respect :make and
+:shell-command keywords.
+
+It may be necessary to run :make and :shell-command arguments in
+order to initialize a package or build its documentation, but
+please be careful when changing this option, as installing and
+updating a package can run potentially harmful code.
+
+This applies to package specifications that come from your
+configured package archives, as well as from entries in
+`package-vc-selected-packages' and specifications that you give
+to `package-vc-install' directly."
+ :type '(choice (const :tag "Run for all packages" t)
+ (repeat :tag "Run only for selected packages" (symbol :tag "Package name"))
+ (const :tag "Never run" nil))
+ :version "30.1")
+
+(defun package-vc--make (pkg-spec pkg-desc)
+ "Process :make and :shell-command in PKG-SPEC.
+PKG-DESC is the package descriptor for the package that is being
+prepared."
+ (let ((target (plist-get pkg-spec :make))
+ (cmd (plist-get pkg-spec :shell-command))
+ (buf (format " *package-vc make %s*" (package-desc-name pkg-desc))))
+ (when (or cmd target)
+ (with-current-buffer (get-buffer-create buf)
+ (erase-buffer)
+ (when (and cmd (/= 0 (call-process shell-file-name nil t nil shell-command-switch cmd)))
+ (warn "Failed to run %s, see buffer %S" cmd (buffer-name)))
+ (when (and target (/= 0 (apply #'call-process "make" nil t nil (if (consp target) target (list target)))))
+ (warn "Failed to make %s, see buffer %S" target (buffer-name)))))))
+
(declare-function org-export-to-file "ox" (backend file))
(defun package-vc--build-documentation (pkg-desc file)
@@ -349,42 +413,48 @@ otherwise it's assumed to be an Info file."
(default-directory (package-desc-dir pkg-desc))
(docs-directory (file-name-directory (expand-file-name file)))
(output (expand-file-name (format "%s.info" pkg-name)))
+ (log-buffer (get-buffer-create (format " *package-vc doc: %s*" pkg-name)))
clean-up)
- (when (string-match-p "\\.org\\'" file)
- (require 'ox)
- (require 'ox-texinfo)
- (with-temp-buffer
- (insert-file-contents file)
- (setq file (make-temp-file "ox-texinfo-"))
- (let ((default-directory docs-directory))
- (org-export-to-file 'texinfo file))
- (setq clean-up t)))
- (with-current-buffer (get-buffer-create " *package-vc doc*")
- (erase-buffer)
- (cond
- ((/= 0 (call-process "makeinfo" nil t nil
- "-I" docs-directory
- "--no-split" file
- "-o" output))
- (message "Failed to build manual %s, see buffer %S"
- file (buffer-name)))
- ((/= 0 (call-process "install-info" nil t nil
- output (expand-file-name "dir")))
- (message "Failed to install manual %s, see buffer %S"
- output (buffer-name)))
- ((kill-buffer))))
+ (with-current-buffer log-buffer
+ (erase-buffer))
+ (condition-case err
+ (progn
+ (when (string-match-p "\\.org\\'" file)
+ (require 'ox)
+ (require 'ox-texinfo)
+ (with-temp-buffer
+ (insert-file-contents file)
+ (setq file (make-temp-file "ox-texinfo-"))
+ (let ((default-directory docs-directory))
+ (org-export-to-file 'texinfo file))
+ (setq clean-up t)))
+ (cond
+ ((/= 0 (call-process "makeinfo" nil log-buffer nil
+ "-I" docs-directory
+ "--no-split" file
+ "-o" output))
+ (message "Failed to build manual %s, see buffer %S"
+ file (buffer-name)))
+ ((/= 0 (call-process "install-info" nil log-buffer nil
+ output (expand-file-name "dir")))
+ (message "Failed to install manual %s, see buffer %S"
+ output (buffer-name)))
+ ((kill-buffer log-buffer))))
+ (error (with-current-buffer log-buffer
+ (insert (error-message-string err)))
+ (message "Failed to export org manual for %s, see buffer %S" pkg-name log-buffer)))
(when clean-up
(delete-file file))))
-(defun package-vc-install-dependencies (requirements)
- "Install missing dependencies, and return missing ones.
-The return value will be nil if everything was found, or a list
-of (NAME VERSION) pairs of all packages that couldn't be found.
+(defun package-vc-install-dependencies (deps)
+ "Install missing dependencies according to DEPS.
+
+DEPS is a list of elements (PACKAGE VERSION-LIST), where
+PACKAGE is a package name and VERSION-LIST is the required
+version of that package.
-REQUIREMENTS should be a list of additional requirements; each
-element in this list should have the form (PACKAGE VERSION-LIST),
-where PACKAGE is a package name and VERSION-LIST is the required
-version of that package."
+Return a list of dependencies that couldn't be met (or nil, when
+this function successfully installs all given dependencies)."
(let ((to-install '()) (missing '()))
(cl-labels ((search (pkg)
"Attempt to find all dependencies for PKG."
@@ -418,7 +488,7 @@ version of that package."
(let ((desc-a (package-desc-name a))
(desc-b (package-desc-name b)))
(depends-on-p desc-a desc-b))))
- (mapc #'search requirements)
+ (mapc #'search deps)
(cl-callf sort to-install #'version-order)
(cl-callf seq-uniq to-install #'duplicate-p)
(cl-callf sort to-install #'dependent-order))
@@ -431,42 +501,51 @@ This includes downloading missing dependencies, generating
autoloads, generating a package description file (used to
identify a package as a VC package later on), building
documentation and marking the package as installed."
- (let (missing)
- ;; Remove any previous instance of PKG-DESC from `package-alist'
- (let ((pkgs (assq (package-desc-name pkg-desc) package-alist)))
- (when pkgs
- (setf (cdr pkgs) (seq-remove #'package-vc-p (cdr pkgs)))))
+ (let* ((pkg-spec (package-vc--desc->spec pkg-desc))
+ (lisp-dir (plist-get pkg-spec :lisp-dir))
+ (lisp-path (file-name-concat pkg-dir lisp-dir))
+ missing)
;; In case the package was installed directly from source, the
;; dependency list wasn't know beforehand, and they might have
;; to be installed explicitly.
- (let ((deps '()))
- (dolist (file (directory-files pkg-dir t "\\.el\\'" t))
- (with-temp-buffer
- (insert-file-contents file)
- (when-let* ((require-lines (lm-header-multiline "package-requires")))
- (thread-last
- (mapconcat #'identity require-lines " ")
- package-read-from-string
- package--prepare-dependencies
- (nconc deps)
- (setq deps)))))
+ (let ((ignored-files
+ (if (plist-get pkg-spec :ignored-files)
+ (mapconcat
+ (lambda (ignore)
+ (wildcard-to-regexp
+ (if (string-match-p "\\`/" ignore)
+ (concat pkg-dir ignore)
+ (concat "*/" ignore))))
+ (plist-get pkg-spec :ignored-files)
+ "\\|")
+ regexp-unmatchable))
+ (deps '()))
+ (dolist (file (directory-files lisp-path t "\\.el\\'" t))
+ (unless (string-match-p ignored-files file)
+ (with-temp-buffer
+ (insert-file-contents file)
+ (when-let* ((require-lines (lm-header-multiline "package-requires")))
+ (thread-last
+ (mapconcat #'identity require-lines " ")
+ package-read-from-string
+ lm--prepare-package-dependencies
+ (nconc deps)
+ (setq deps))))))
(dolist (dep deps)
(cl-callf version-to-list (cadr dep)))
+ (setf (package-desc-reqs pkg-desc) deps)
(setf missing (package-vc-install-dependencies (delete-dups deps)))
(setf missing (delq (assq (package-desc-name pkg-desc)
missing)
missing)))
(let ((default-directory (file-name-as-directory pkg-dir))
- (pkg-file (expand-file-name (package--description-file pkg-dir) pkg-dir))
- (pkg-spec (package-vc--desc->spec pkg-desc)))
+ (pkg-file (expand-file-name (package--description-file pkg-dir) pkg-dir)))
;; Generate autoloads
(let* ((name (package-desc-name pkg-desc))
- (auto-name (format "%s-autoloads.el" name))
- (lisp-dir (plist-get pkg-spec :lisp-dir)))
- (package-generate-autoloads
- name (file-name-concat pkg-dir lisp-dir))
+ (auto-name (format "%s-autoloads.el" name)))
+ (package-generate-autoloads name lisp-path)
(when lisp-dir
(write-region
(with-temp-buffer
@@ -483,11 +562,22 @@ documentation and marking the package as installed."
;; Generate package file
(package-vc--generate-description-file pkg-desc pkg-file)
+ ;; Process :make and :shell-command arguments before building documentation
+ (when (or (eq package-vc-allow-build-commands t)
+ (memq (package-desc-name pkg-desc)
+ package-vc-allow-build-commands))
+ (package-vc--make pkg-spec pkg-desc))
+
;; Detect a manual
(when (executable-find "install-info")
(dolist (doc-file (ensure-list (plist-get pkg-spec :doc)))
(package-vc--build-documentation pkg-desc doc-file))))
+ ;; Remove any previous instance of PKG-DESC from `package-alist'
+ (let ((pkgs (assq (package-desc-name pkg-desc) package-alist)))
+ (when pkgs
+ (setf (cdr pkgs) (seq-remove #'package-vc-p (cdr pkgs)))))
+
;; Update package-alist.
(let ((new-desc (package-load-descriptor pkg-dir)))
;; Activation has to be done before compilation, so that if we're
@@ -538,6 +628,8 @@ and return nil if it cannot reasonably guess."
(and url (alist-get url package-vc-heuristic-alist
nil nil #'string-match-p)))
+(declare-function project-remember-projects-under "project" (dir &optional recursive))
+
(defun package-vc--clone (pkg-desc pkg-spec dir rev)
"Clone the package PKG-DESC whose spec is PKG-SPEC into the directory DIR.
REV specifies a specific revision to checkout. This overrides the `:branch'
@@ -559,6 +651,11 @@ attribute in PKG-SPEC."
(or (and (not (eq rev :last-release)) rev) branch))
(error "Failed to clone %s from %s" name url))))
+ (when package-vc-register-as-project
+ (let ((default-directory dir))
+ (require 'project)
+ (project-remember-projects-under dir)))
+
;; Check out the latest release if requested
(when (eq rev :last-release)
(if-let ((release-rev (package-vc--release-rev pkg-desc)))
@@ -666,7 +763,10 @@ installed package."
;;;###autoload
(defun package-vc-upgrade-all ()
- "Attempt to upgrade all installed VC packages."
+ "Upgrade all installed VC packages.
+
+This may fail if the local VCS state of one of the packages
+conflicts with its remote repository state."
(interactive)
(dolist (package package-alist)
(dolist (pkg-desc (cdr package))
@@ -676,7 +776,10 @@ installed package."
;;;###autoload
(defun package-vc-upgrade (pkg-desc)
- "Attempt to upgrade the package PKG-DESC."
+ "Upgrade the package described by PKG-DESC from package's VC repository.
+
+This may fail if the local VCS state of the package conflicts
+with the remote repository state."
(interactive (list (package-vc--read-package-desc "Upgrade VC package: " t)))
;; HACK: To run `package-vc--unpack-1' after checking out the new
;; revision, we insert a hook into `vc-post-command-functions', and
@@ -739,34 +842,45 @@ If no such revision can be found, return nil."
;;;###autoload
(defun package-vc-install (package &optional rev backend name)
- "Fetch a PACKAGE and set it up for using with Emacs.
-
-If PACKAGE is a string containing an URL, download the package
-from the repository at that URL; the function will try to guess
-the name of the package from the URL. This can be overridden by
-passing the optional argument NAME. If PACKAGE is a cons-cell,
-it should have the form (NAME . SPEC), where NAME is a symbol
-indicating the package name and SPEC is a plist as described in
-`package-vc-selected-packages'. Otherwise PACKAGE should be a
-symbol whose name is the package name, and the URL for the
-package will be taken from the package's metadata.
+ "Fetch a package described by PACKAGE and set it up for use with Emacs.
+
+PACKAGE specifies which package to install, where to find its
+source repository and how to build it.
+
+If PACKAGE is a symbol, install the package with that name
+according to metadata that package archives provide for it. This
+is the simplest way to call this function, but it only works if
+the package you want to install is listed in a package archive
+you have configured.
+
+If PACKAGE is a string, it specifies the URL of the package
+repository. In this case, optional argument BACKEND specifies
+the VC backend to use for cloning the repository; if it's nil,
+this function tries to infer which backend to use according to
+the value of `package-vc-heuristic-alist' and if that fails it
+uses `package-vc-default-backend'. Optional argument NAME
+specifies the package name in this case; if it's nil, this
+package uses `file-name-base' on the URL to obtain the package
+name, otherwise NAME is the package name as a symbol.
+
+PACKAGE can also be a cons cell (PNAME . SPEC) where PNAME is the
+package name as a symbol, and SPEC is a plist that specifies how
+to fetch and build the package. For possible values, see the
+subsection \"Specifying Package Sources\" in the Info
+node `(emacs)Fetching Package Sources'.
By default, this function installs the last revision of the
package available from its repository. If REV is a string, it
-describes the revision to install, as interpreted by the VC
-backend. The special value `:last-release' (interactively, the
-prefix argument), will use the commit of the latest release, if
-it exists. The last release is the latest revision which changed
-the \"Version:\" header of the package's main Lisp file.
-
-Optional argument BACKEND specifies the VC backend to use for cloning
-the package's repository; this is only possible if NAME-OR-URL is a URL,
-a string. If BACKEND is omitted or nil, the function
-uses `package-vc-heuristic-alist' to guess the backend.
-Note that by default, a VC package will be prioritized over a
-regular package, but it will not remove a VC package.
-
-\(fn PACKAGE &optional REV BACKEND)"
+describes the revision to install, as interpreted by the relevant
+VC backend. The special value `:last-release' (interactively,
+the prefix argument), says to use the commit of the latest
+release, if it exists. The last release is the latest revision
+which changed the \"Version:\" header of the package's main Lisp
+file.
+
+If you use this function to install a package that you also have
+installed from a package archive, the version this function
+installs takes precedence."
(interactive
(progn
;; Initialize the package system to get the list of package
@@ -829,7 +943,6 @@ for the last released version of the package."
(lambda (dir) (or (not (file-exists-p dir))
(directory-empty-p dir))))
(and current-prefix-arg :last-release))))
- (setf directory (expand-file-name directory))
(package-vc--archives-initialize)
(let ((pkg-spec (or (package-vc--desc->spec pkg-desc)
(and-let* ((extras (package-desc-extras pkg-desc))
@@ -842,18 +955,19 @@ for the last released version of the package."
(find-file directory)))
;;;###autoload
-(defun package-vc-install-from-checkout (dir name)
- "Set up the package NAME in DIR by linking it into the ELPA directory.
+(defun package-vc-install-from-checkout (dir &optional name)
+ "Install the package NAME from its source directory DIR.
+NAME defaults to the base name of DIR.
Interactively, prompt the user for DIR, which should be a directory
under version control, typically one created by `package-vc-checkout'.
If invoked interactively with a prefix argument, prompt the user
-for the NAME of the package to set up. Otherwise infer the package
-name from the base name of DIR."
- (interactive (let ((dir (read-directory-name "Directory: ")))
- (list dir
- (if current-prefix-arg
- (read-string "Package name: ")
- (file-name-base (directory-file-name dir))))))
+for the NAME of the package to set up."
+ (interactive (let* ((dir (read-directory-name "Directory: "))
+ (base (file-name-base (directory-file-name dir))))
+ (list dir (and current-prefix-arg
+ (read-string
+ (format-prompt "Package name" base)
+ nil nil base)))))
(unless (vc-responsible-backend dir)
(user-error "Directory %S is not under version control" dir))
(package-vc--archives-initialize)
@@ -885,13 +999,17 @@ prompt for the name of the package to rebuild."
;;;###autoload
(defun package-vc-prepare-patch (pkg-desc subject revisions)
- "Send patch for REVISIONS to maintainer of the package PKG using SUBJECT.
-The function uses `vc-prepare-patch', passing SUBJECT and
-REVISIONS directly. PKG-DESC must be a package description.
+ "Email patches for REVISIONS to maintainer of package PKG-DESC using SUBJECT.
+
+PKG-DESC is a package descriptor and SUBJECT is the subject of
+the message.
+
Interactively, prompt for PKG-DESC, SUBJECT, and REVISIONS. When
invoked with a numerical prefix argument, use the last N
revisions. When invoked interactively in a Log View buffer with
-marked revisions, use those."
+marked revisions, use those.
+
+See also `vc-prepare-patch'."
(interactive
(list (package-vc--read-package-desc "Package to prepare a patch for: " t)
(and (not vc-prepare-patches-separately)
diff --git a/lisp/emacs-lisp/package.el b/lisp/emacs-lisp/package.el
index 608306c8254..ab1731aeb54 100644
--- a/lisp/emacs-lisp/package.el
+++ b/lisp/emacs-lisp/package.el
@@ -378,10 +378,8 @@ If so, and variable `package-check-signature' is
`allow-unsigned', return `allow-unsigned', otherwise return the
value of variable `package-check-signature'."
(if (eq package-check-signature 'allow-unsigned)
- (progn
- (require 'epg-config)
- (and (epg-find-configuration 'OpenPGP)
- 'allow-unsigned))
+ (and (epg-find-configuration 'OpenPGP)
+ 'allow-unsigned)
package-check-signature))
(defcustom package-unsigned-archives nil
@@ -611,7 +609,7 @@ package."
(package-archive-priority (package-desc-archive pkg-desc)))
(defun package--parse-elpaignore (pkg-desc)
- "Return the of regular expression to match files ignored by PKG-DESC."
+ "Return a list of regular expressions to match files ignored by PKG-DESC."
(let* ((pkg-dir (file-name-as-directory (package-desc-dir pkg-desc)))
(ignore (expand-file-name ".elpaignore" pkg-dir))
files)
@@ -903,13 +901,7 @@ correspond to previously loaded files."
(when reload
(package--reload-previously-loaded pkg-desc))
(with-demoted-errors "Error loading autoloads: %s"
- (load (package--autoloads-file-name pkg-desc) nil t))
- ;; FIXME: Since 2013 (commit 4fac34cee97a), the autoload files take
- ;; care of changing the `load-path', so maybe it's time to
- ;; remove this fallback code?
- (unless (or (member (file-name-as-directory pkg-dir) load-path)
- (member (directory-file-name pkg-dir) load-path))
- (add-to-list 'load-path pkg-dir)))
+ (load (package--autoloads-file-name pkg-desc) nil t)))
;; Add info node.
(when (file-exists-p (expand-file-name "dir" pkg-dir))
;; FIXME: not the friendliest, but simple.
@@ -970,7 +962,6 @@ Newer versions are always activated, regardless of FORCE."
"Untar the current buffer.
This uses `tar-untar-buffer' from Tar mode. All files should
untar into a directory named DIR; otherwise, signal an error."
- (require 'tar-mode)
(tar-mode)
;; Make sure everything extracts into DIR.
(let ((regexp (concat "\\`" (regexp-quote (expand-file-name dir)) "/"))
@@ -1158,27 +1149,8 @@ Signal an error if the entire string was not used."
(error "Can't read whole string"))
(end-of-file expr))))
-(defun package--prepare-dependencies (deps)
- "Turn DEPS into an acceptable list of dependencies.
-
-Any parts missing a version string get a default version string
-of \"0\" (meaning any version) and an appropriate level of lists
-is wrapped around any parts requiring it."
- (cond
- ((not (listp deps))
- (error "Invalid requirement specifier: %S" deps))
- (t (mapcar (lambda (dep)
- (cond
- ((symbolp dep) `(,dep "0"))
- ((stringp dep)
- (error "Invalid requirement specifier: %S" dep))
- ((and (listp dep) (null (cdr dep)))
- (list (car dep) "0"))
- (t dep)))
- deps))))
-
(declare-function lm-header "lisp-mnt" (header))
-(declare-function lm-header-multiline "lisp-mnt" (header))
+(declare-function lm-package-requires "lisp-mnt" (&optional file))
(declare-function lm-website "lisp-mnt" (&optional file))
(declare-function lm-keywords-list "lisp-mnt" (&optional file))
(declare-function lm-maintainers "lisp-mnt" (&optional file))
@@ -1200,9 +1172,15 @@ boundaries."
;; the earliest in version 31.1. The idea is to phase out the
;; requirement for a "footer line" without unduly impacting users
;; on earlier Emacs versions. See Bug#26490 for more details.
- (unless (search-forward (concat ";;; " file-name ".el ends here"))
- (lwarn '(package package-format) :warning
- "Package lacks a terminating comment"))
+ (unless (search-forward (concat ";;; " file-name ".el ends here") nil 'move)
+ ;; Starting in Emacs 30.1, avoid warning if the minimum Emacs
+ ;; version is specified as 30.1 or later.
+ (let ((min-emacs (cadar (seq-filter (lambda (x) (eq (car x) 'emacs))
+ (lm-package-requires)))))
+ (when (or (null min-emacs)
+ (version< min-emacs "30.1"))
+ (lwarn '(package package-format) :warning
+ "Package lacks a terminating comment"))))
;; Try to include a trailing newline.
(forward-line)
(narrow-to-region start (point))
@@ -1221,15 +1199,13 @@ boundaries."
(error "Package lacks a \"Version\" or \"Package-Version\" header")))
(package-desc-from-define
file-name pkg-version desc
- (and-let* ((require-lines (lm-header-multiline "package-requires")))
- (package--prepare-dependencies
- (package-read-from-string (mapconcat #'identity require-lines " "))))
+ (lm-package-requires)
:kind 'single
:url website
:keywords keywords
:maintainer
- ;; For backward compatibility, use a single string if there's only
- ;; one maintainer (the most common case).
+ ;; For backward compatibility, use a single cons-cell if
+ ;; there's only one maintainer (the most common case).
(let ((maints (lm-maintainers))) (if (cdr maints) maints (car maints)))
:authors (lm-authors)))))
@@ -1237,15 +1213,14 @@ boundaries."
"Read a `define-package' form in current buffer.
Return the pkg-desc, with desc-kind set to KIND."
(goto-char (point-min))
- (unwind-protect
- (let* ((pkg-def-parsed (read (current-buffer)))
- (pkg-desc
- (when (eq (car pkg-def-parsed) 'define-package)
- (apply #'package-desc-from-define
- (append (cdr pkg-def-parsed))))))
- (when pkg-desc
- (setf (package-desc-kind pkg-desc) kind)
- pkg-desc))))
+ (let* ((pkg-def-parsed (read (current-buffer)))
+ (pkg-desc
+ (when (eq (car pkg-def-parsed) 'define-package)
+ (apply #'package-desc-from-define
+ (append (cdr pkg-def-parsed))))))
+ (when pkg-desc
+ (setf (package-desc-kind pkg-desc) kind)
+ pkg-desc)))
(declare-function tar-get-file-descriptor "tar-mode" (file))
(declare-function tar--extract "tar-mode" (descriptor))
@@ -1730,18 +1705,26 @@ The variable `package-load-list' controls which packages to load."
package-quickstart-file))))
;; The quickstart file presumes that it has a blank slate,
;; so don't use it if we already activated some packages.
- (if (and qs (not (bound-and-true-p package-activated-list)))
- ;; Skip load-source-file-function which would slow us down by a factor
- ;; 2 when loading the .el file (this assumes we were careful to
- ;; save this file so it doesn't need any decoding).
- (let ((load-source-file-function nil))
- (unless (boundp 'package-activated-list)
- (setq package-activated-list nil))
- (load qs nil 'nomessage))
- (require 'package)
- (package--activate-all)))))
+ (or (and qs (not (bound-and-true-p package-activated-list))
+ ;; Skip `load-source-file-function' which would slow us down by
+ ;; a factor 2 when loading the .el file (this assumes we were
+ ;; careful to save this file so it doesn't need any decoding).
+ (with-demoted-errors "Error during quickstart: %S"
+ (let ((load-source-file-function nil))
+ (unless (boundp 'package-activated-list)
+ (setq package-activated-list nil))
+ (load qs nil 'nomessage)
+ t)))
+ (progn
+ (require 'package)
+ ;; Silence the "unknown function" warning when this is compiled
+ ;; inside `loaddefs.el'.
+ ;; FIXME: We use `with-no-warnings' because the effect of
+ ;; `declare-function' is currently not scoped, so if we use
+ ;; it here, we end up with a redefinition warning instead :-)
+ (with-no-warnings
+ (package--activate-all)))))))
-;;;###autoload
(defun package--activate-all ()
(dolist (elt (package--alist))
(condition-case err
@@ -1992,8 +1975,11 @@ Used to populate `package-selected-packages'."
(defun package--save-selected-packages (&optional value)
"Set and save `package-selected-packages' to VALUE."
- (when value
- (setq package-selected-packages value))
+ (when (or value after-init-time)
+ ;; It is valid to set it to nil, for example when the last package
+ ;; is uninstalled. But it shouldn't be done at init time, to
+ ;; avoid overwriting configurations that haven't yet been loaded.
+ (setq package-selected-packages (sort value #'string<)))
(if after-init-time
(customize-save-variable 'package-selected-packages package-selected-packages)
(add-hook 'after-init-hook #'package--save-selected-packages)))
@@ -2268,25 +2254,26 @@ had been enabled."
;;;###autoload
(defun package-upgrade (name)
- "Upgrade package NAME if a newer version exists.
-
-Currently, packages which are part of the Emacs distribution
-cannot be upgraded that way. To enable upgrades of such a
-package using this command, first upgrade the package to a
-newer version from ELPA by using `\\<package-menu-mode-map>\\[package-menu-mark-install]' after `\\[list-packages]'."
+ "Upgrade package NAME if a newer version exists."
(interactive
(list (completing-read
- "Upgrade package: " (package--upgradeable-packages) nil t)))
+ "Upgrade package: " (package--upgradeable-packages t) nil t)))
(let* ((package (if (symbolp name)
name
(intern name)))
- (pkg-desc (cadr (assq package package-alist))))
- (if (package-vc-p pkg-desc)
+ (pkg-desc (cadr (assq package package-alist)))
+ (package-install-upgrade-built-in (not pkg-desc)))
+ ;; `pkg-desc' will be nil when the package is an "active built-in".
+ (if (and pkg-desc (package-vc-p pkg-desc))
(package-vc-upgrade pkg-desc)
- (package-delete pkg-desc 'force 'dont-unselect)
- (package-install package 'dont-select))))
-
-(defun package--upgradeable-packages ()
+ (when pkg-desc
+ (package-delete pkg-desc 'force 'dont-unselect))
+ (package-install package
+ ;; An active built-in has never been "selected"
+ ;; before. Mark it as installed explicitly.
+ (and pkg-desc 'dont-select)))))
+
+(defun package--upgradeable-packages (&optional include-builtins)
;; Initialize the package system to get the list of package
;; symbols for completion.
(package--archives-initialize)
@@ -2297,11 +2284,21 @@ newer version from ELPA by using `\\<package-menu-mode-map>\\[package-menu-mark-
(or (let ((available
(assq (car elt) package-archive-contents)))
(and available
- (version-list-<
- (package-desc-version (cadr elt))
- (package-desc-version (cadr available)))))
- (package-vc-p (cadr (assq (car elt) package-alist)))))
- package-alist)))
+ (or (and
+ include-builtins
+ (not (package-desc-version (cadr elt))))
+ (version-list-<
+ (package-desc-version (cadr elt))
+ (package-desc-version (cadr available))))))
+ (package-vc-p (cadr elt))))
+ (if include-builtins
+ (append package-alist
+ (mapcan
+ (lambda (elt)
+ (when (not (assq (car elt) package-alist))
+ (list (list (car elt) (package--from-builtin elt)))))
+ package--builtins))
+ package-alist))))
;;;###autoload
(defun package-upgrade-all (&optional query)
@@ -2311,8 +2308,9 @@ interactively, QUERY is always true.
Currently, packages which are part of the Emacs distribution are
not upgraded by this command. To enable upgrading such a package
-using this command, first upgrade the package to a newer version
-from ELPA by using `\\<package-menu-mode-map>\\[package-menu-mark-install]' after `\\[list-packages]'."
+using this command, first upgrade the package to a newer version
+from ELPA by either using `\\[package-upgrade]' or
+`\\<package-menu-mode-map>\\[package-menu-mark-install]' after `\\[list-packages]'."
(interactive (list (not noninteractive)))
(package-refresh-contents)
(let ((upgradeable (package--upgradeable-packages)))
@@ -2328,12 +2326,25 @@ from ELPA by using `\\<package-menu-mode-map>\\[package-menu-mark-install]' afte
(mapc #'package-upgrade upgradeable))))
(defun package--dependencies (pkg)
- "Return a list of all dependencies PKG has.
-This is done recursively."
- ;; Can we have circular dependencies? Assume "nope".
- (when-let* ((desc (cadr (assq pkg package-archive-contents)))
- (deps (mapcar #'car (package-desc-reqs desc))))
- (delete-dups (apply #'nconc deps (mapcar #'package--dependencies deps)))))
+ "Return a list of all transitive dependencies of PKG.
+If PKG is a package descriptor, the return value is a list of
+package descriptors. If PKG is a symbol designating a package,
+the return value is a list of symbols designating packages."
+ (when-let* ((desc (if (package-desc-p pkg) pkg
+ (cadr (assq pkg package-archive-contents)))))
+ ;; Can we have circular dependencies? Assume "nope".
+ (let ((all (named-let more ((pkg-desc desc))
+ (let (deps)
+ (dolist (req (package-desc-reqs pkg-desc))
+ (setq deps (nconc
+ (catch 'found
+ (dolist (p (apply #'append (mapcar #'cdr (package--alist))))
+ (when (and (string= (car req) (package-desc-name p))
+ (version-list-<= (cadr req) (package-desc-version p)))
+ (throw 'found (more p)))))
+ deps)))
+ (delete-dups (cons pkg-desc deps))))))
+ (remq pkg (mapcar (if (package-desc-p pkg) #'identity #'package-desc-name) all)))))
(defun package-strip-rcs-id (str)
"Strip RCS version ID from the version string STR.
@@ -2469,7 +2480,9 @@ Clean-up the corresponding .eln files if Emacs is native
compiled."
(when (featurep 'native-compile)
(cl-loop
- for file in (directory-files-recursively dir "\\.el\\'")
+ for file in (directory-files-recursively dir
+ ;; Exclude lockfiles
+ (rx bos (or (and "." (not "#")) (not ".")) (* nonl) ".el" eos))
do (comp-clean-up-stale-eln (comp-el-to-eln-filename file))))
(if (file-symlink-p (directory-file-name dir))
(delete-file (directory-file-name dir))
@@ -2501,8 +2514,12 @@ If NOSAVE is non-nil, the package is not removed from
nil t)))
(list (cdr (assoc package-name package-table))
current-prefix-arg nil))))
- (let ((dir (package-desc-dir pkg-desc))
- (name (package-desc-name pkg-desc))
+ (let* ((dir (package-desc-dir pkg-desc))
+ (name (package-desc-name pkg-desc))
+ (new-package-alist (let ((pkgs (assq name package-alist)))
+ (if (null (remove pkg-desc (cdr pkgs)))
+ (remq pkgs package-alist)
+ package-alist)))
pkg-used-elsewhere-by)
;; If the user is trying to delete this package, they definitely
;; don't want it marked as selected, so we remove it from
@@ -2521,7 +2538,8 @@ If NOSAVE is non-nil, the package is not removed from
(package-desc-full-name pkg-desc)))
((and (null force)
(setq pkg-used-elsewhere-by
- (package--used-elsewhere-p pkg-desc)))
+ (let ((package-alist new-package-alist))
+ (package--used-elsewhere-p pkg-desc)))) ;See bug#65475
;; Don't delete packages used as dependency elsewhere.
(error "Package `%s' is used by `%s' as dependency, not deleting"
(package-desc-full-name pkg-desc)
@@ -2542,10 +2560,7 @@ If NOSAVE is non-nil, the package is not removed from
(when (file-exists-p file)
(delete-file file))))
;; Update package-alist.
- (let ((pkgs (assq name package-alist)))
- (delete pkg-desc pkgs)
- (unless (cdr pkgs)
- (setq package-alist (delq pkgs package-alist))))
+ (setq package-alist new-package-alist)
(package--quickstart-maybe-refresh)
(message "Package `%s' deleted."
(package-desc-full-name pkg-desc))))))
@@ -2595,7 +2610,8 @@ This is meant to be used only in the case the byte-compiled files
are invalid due to changed byte-code, macros or the like."
(interactive)
(pcase-dolist (`(_ ,pkg-desc) package-alist)
- (package-recompile pkg-desc)))
+ (with-demoted-errors "Error while recompiling: %S"
+ (package-recompile pkg-desc))))
;;;###autoload
(defun package-autoremove ()
@@ -2623,6 +2639,57 @@ will be deleted."
removable))
(message "Nothing to autoremove")))))
+(defun package-isolate (packages &optional temp-init)
+ "Start an uncustomised Emacs and only load a set of PACKAGES.
+If TEMP-INIT is non-nil, or when invoked with a prefix argument,
+the Emacs user directory is set to a temporary directory."
+ (interactive
+ (cl-loop for p in (cl-loop for p in (package--alist) append (cdr p))
+ unless (package-built-in-p p)
+ collect (cons (package-desc-full-name p) p) into table
+ finally return
+ (list (cl-loop for c in (completing-read-multiple
+ "Isolate packages: " table
+ nil t)
+ collect (alist-get c table nil nil #'string=))
+ current-prefix-arg)))
+ (let* ((name (concat "package-isolate-"
+ (mapconcat #'package-desc-full-name packages ",")))
+ (all-packages (delete-consecutive-dups
+ (sort (append packages (mapcan #'package--dependencies packages))
+ (lambda (p0 p1)
+ (string< (package-desc-name p0) (package-desc-name p1))))))
+ initial-scratch-message package-load-list)
+ (with-temp-buffer
+ (insert ";; This is an isolated testing environment, with these packages enabled:\n\n")
+ (dolist (package all-packages)
+ (push (list (package-desc-name package)
+ (package-version-join (package-desc-version package)))
+ package-load-list)
+ (insert ";; - " (package-desc-full-name package))
+ (unless (memq package packages)
+ (insert " (dependency)"))
+ (insert "\n"))
+ (insert "\n")
+ (setq initial-scratch-message (buffer-string)))
+ (apply #'start-process (concat "*" name "*") nil
+ (list (expand-file-name invocation-name invocation-directory)
+ "--quick" "--debug-init"
+ "--init-directory" (if temp-init
+ (make-temp-file name t)
+ user-emacs-directory)
+ (format "--eval=%S"
+ `(progn
+ (setq initial-scratch-message ,initial-scratch-message)
+
+ (require 'package)
+ ,@(mapcar
+ (lambda (dir)
+ `(add-to-list 'package-directory-list ,dir))
+ (cons package-user-dir package-directory-list))
+ (setq package-load-list ',package-load-list)
+ (package-initialize)))))))
+
;;;; Package description buffer.
@@ -2738,7 +2805,7 @@ Helper function for `describe-package'."
(status (if desc (package-desc-status desc) "orphan"))
(incompatible-reason (package--incompatible-p desc))
(signed (if desc (package-desc-signed desc)))
- (maintainer (cdr (assoc :maintainer extras)))
+ (maintainers (cdr (assoc :maintainer extras)))
(authors (cdr (assoc :authors extras)))
(news (and-let* (pkg-dir
((not built-in))
@@ -2873,19 +2940,21 @@ Helper function for `describe-package'."
'action 'package-keyword-button-action)
(insert " "))
(insert "\n"))
- (when maintainer
- (package--print-help-section "Maintainer")
- (package--print-email-button maintainer))
- (when authors
+ (when maintainers
+ (when (stringp (car maintainers))
+ (setq maintainers (list maintainers)))
(package--print-help-section
- (if (= (length authors) 1)
- "Author"
- "Authors"))
- (package--print-email-button (pop authors))
- ;; If there's more than one author, indent the rest correctly.
- (dolist (name authors)
- (insert (make-string 13 ?\s))
- (package--print-email-button name)))
+ (if (cdr maintainers) "Maintainers" "Maintainer"))
+ (dolist (maintainer maintainers)
+ (when (bolp)
+ (insert (make-string 13 ?\s)))
+ (package--print-email-button maintainer)))
+ (when authors
+ (package--print-help-section (if (cdr authors) "Authors" "Author"))
+ (dolist (author authors)
+ (when (bolp)
+ (insert (make-string 13 ?\s)))
+ (package--print-email-button author)))
(let* ((all-pkgs (append (cdr (assq name package-alist))
(cdr (assq name package-archive-contents))
(let ((bi (assq name package--builtins)))
@@ -3146,8 +3215,7 @@ The most useful commands here are:
`[("Package" ,package-name-column-width package-menu--name-predicate)
("Version" ,package-version-column-width package-menu--version-predicate)
("Status" ,package-status-column-width package-menu--status-predicate)
- ,@(if (cdr package-archives)
- `(("Archive" ,package-archive-column-width package-menu--archive-predicate)))
+ ("Archive" ,package-archive-column-width package-menu--archive-predicate)
("Description" 0 package-menu--description-predicate)])
(setq tabulated-list-padding 2)
(setq tabulated-list-sort-key (cons "Status" nil))
@@ -3587,9 +3655,8 @@ Return (PKG-DESC [NAME VERSION STATUS DOC])."
(package-desc-version pkg)))
'font-lock-face face)
,(propertize status 'font-lock-face face)
- ,@(if (cdr package-archives)
- (list (propertize (or (package-desc-archive pkg) "")
- 'font-lock-face face)))
+ ,(propertize (or (package-desc-archive pkg) "")
+ 'font-lock-face face)
,(propertize (package-desc-summary pkg)
'font-lock-face 'package-description)])))
@@ -4538,8 +4605,8 @@ activations need to be changed, such as when `package-load-list' is modified."
(let ((load-suffixes '(".el" ".elc")))
(locate-library (package--autoloads-file-name pkg))))
(pfile (prin1-to-string file)))
- (insert "(let ((load-true-file-name " pfile ")\
-\(load-file-name " pfile "))\n")
+ (insert "(let* ((load-file-name " pfile ")\
+\(load-true-file-name load-file-name))\n")
(insert-file-contents file)
;; Fixup the special #$ reader form and throw away comments.
(while (re-search-forward "#\\$\\|^;\\(.*\n\\)" nil 'move)
@@ -4632,19 +4699,25 @@ will be signaled in that case."
(let* ((name (package-desc-name pkg-desc))
(extras (package-desc-extras pkg-desc))
(maint (alist-get :maintainer extras)))
+ (unless (listp (cdr maint))
+ (setq maint (list maint)))
(cond
((and (null maint) (null no-error))
(user-error "Package `%s' has no explicit maintainer" name))
((and (not (progn
(require 'ietf-drums)
- (ietf-drums-parse-address (cdr maint))))
+ (ietf-drums-parse-address (cdar maint))))
(null no-error))
(user-error "Package `%s' has no maintainer address" name))
- ((not (null maint))
+ (t
(with-temp-buffer
- (package--print-email-button maint)
- (string-trim (substring-no-properties (buffer-string))))))))
+ (mapc #'package--print-email-button maint)
+ (replace-regexp-in-string
+ "\n" ", " (string-trim
+ (buffer-substring-no-properties
+ (point-min) (point-max)))))))))
+;;;###autoload
(defun package-report-bug (desc)
"Prepare a message to send to the maintainers of a package.
DESC must be a `package-desc' object."
@@ -4652,17 +4725,19 @@ DESC must be a `package-desc' object."
package-menu-mode)
(let ((maint (package-maintainers desc))
(name (symbol-name (package-desc-name desc)))
+ (pkgdir (package-desc-dir desc))
vars)
- (dolist-with-progress-reporter (group custom-current-group-alist)
- "Scanning for modified user options..."
- (when (and (car group)
- (file-in-directory-p (car group) (package-desc-dir desc)))
- (dolist (ent (get (cdr group) 'custom-group))
- (when (and (custom-variable-p (car ent))
- (boundp (car ent))
- (not (eq (custom--standard-value (car ent))
- (default-toplevel-value (car ent)))))
- (push (car ent) vars)))))
+ (when pkgdir
+ (dolist-with-progress-reporter (group custom-current-group-alist)
+ "Scanning for modified user options..."
+ (when (and (car group)
+ (file-in-directory-p (car group) pkgdir))
+ (dolist (ent (get (cdr group) 'custom-group))
+ (when (and (custom-variable-p (car ent))
+ (boundp (car ent))
+ (not (eq (custom--standard-value (car ent))
+ (default-toplevel-value (car ent)))))
+ (push (car ent) vars))))))
(dlet ((reporter-prompt-for-summary-p t))
(reporter-submit-bug-report maint name vars))))
diff --git a/lisp/emacs-lisp/pcase.el b/lisp/emacs-lisp/pcase.el
index ff68203eaea..23f1bac600c 100644
--- a/lisp/emacs-lisp/pcase.el
+++ b/lisp/emacs-lisp/pcase.el
@@ -42,6 +42,14 @@
;; - ideally we'd want (pcase s ((re RE1) E1) ((re RE2) E2)) to be able to
;; generate a lex-style DFA to decide whether to run E1 or E2.
+;; While the first version was written before I knew about Racket's `match'
+;; construct, the second version was significantly influenced by it,
+;; so a good presentation of the underlying ideas can be found at:
+;;
+;; Extensible Pattern Matching in an Extensible Language
+;; Sam Tobin-Hochstadt, 2010
+;; https://arxiv.org/abs/1106.2578
+
;;; Code:
(require 'macroexp)
@@ -123,6 +131,8 @@ FUN in `pred' and `app' can take one of the forms:
call it with one argument
(F ARG1 .. ARGn)
call F with ARG1..ARGn and EXPVAL as n+1'th argument
+ (F ARG1 .. _ .. ARGn)
+ call F, passing EXPVAL at the _ position.
FUN, BOOLEXP, and subsequent PAT can refer to variables
bound earlier in the pattern by a SYMBOL pattern.
@@ -155,8 +165,12 @@ Emacs Lisp manual for more information and examples."
;; (puthash (car cases) `(,exp ,cases ,@expansion) pcase--memoize-2)
expansion))))
-(declare-function help-fns--signature "help-fns"
- (function doc real-def real-function buffer))
+(defconst pcase--find-macro-def-regexp "(pcase-defmacro[\s\t\n]+%s[\s\t\n]*(")
+
+(with-eval-after-load 'find-func
+ (defvar find-function-regexp-alist)
+ (add-to-list 'find-function-regexp-alist
+ `(pcase-macro . pcase--find-macro-def-regexp)))
;; FIXME: Obviously, this will collide with nadvice's use of
;; function-documentation if we happen to advise `pcase'.
@@ -166,9 +180,10 @@ Emacs Lisp manual for more information and examples."
(defun pcase--make-docstring ()
(let* ((main (documentation (symbol-function 'pcase) 'raw))
(ud (help-split-fundoc main 'pcase)))
- ;; So that eg emacs -Q -l cl-lib --eval "(documentation 'pcase)" works,
- ;; where cl-lib is anything using pcase-defmacro.
(require 'help-fns)
+ (declare-function help-fns-short-filename "help-fns" (filename))
+ (declare-function help-fns--signature "help-fns"
+ (function doc real-def real-function buffer))
(with-temp-buffer
(insert (or (cdr ud) main))
;; Presentation Note: For conceptual continuity, we guarantee
@@ -189,11 +204,20 @@ Emacs Lisp manual for more information and examples."
(let* ((pair (pop more))
(symbol (car pair))
(me (cdr pair))
- (doc (documentation me 'raw)))
+ (doc (documentation me 'raw))
+ (filename (find-lisp-object-file-name me 'defun)))
(insert "\n\n-- ")
(setq doc (help-fns--signature symbol doc me
(indirect-function me)
nil))
+ (when filename
+ (save-excursion
+ (forward-char -1)
+ (insert (format-message " in `"))
+ (help-insert-xref-button (help-fns-short-filename filename)
+ 'help-function-def symbol filename
+ 'pcase-macro)
+ (insert (format-message "'."))))
(insert "\n" (or doc "Not documented.")))))
(let ((combined-doc (buffer-string)))
(if ud (help-add-fundoc-usage combined-doc (car ud)) combined-doc)))))
@@ -599,52 +623,84 @@ recording whether the var has been referenced by earlier parts of the match."
(defun pcase--and (match matches)
(if matches `(and ,match ,@matches) match))
-(defconst pcase-mutually-exclusive-predicates
- '((symbolp . integerp)
- (symbolp . numberp)
- (symbolp . consp)
- (symbolp . arrayp)
- (symbolp . vectorp)
- (symbolp . stringp)
- (symbolp . byte-code-function-p)
- (symbolp . compiled-function-p)
- (symbolp . recordp)
- (integerp . consp)
- (integerp . arrayp)
- (integerp . vectorp)
- (integerp . stringp)
- (integerp . byte-code-function-p)
- (integerp . compiled-function-p)
- (integerp . recordp)
- (numberp . consp)
- (numberp . arrayp)
- (numberp . vectorp)
- (numberp . stringp)
- (numberp . byte-code-function-p)
- (numberp . compiled-function-p)
- (numberp . recordp)
- (consp . arrayp)
- (consp . atom)
- (consp . vectorp)
- (consp . stringp)
- (consp . byte-code-function-p)
- (consp . compiled-function-p)
- (consp . recordp)
- (arrayp . byte-code-function-p)
- (arrayp . compiled-function-p)
- (vectorp . byte-code-function-p)
- (vectorp . compiled-function-p)
- (vectorp . recordp)
- (stringp . vectorp)
- (stringp . recordp)
- (stringp . byte-code-function-p)
- (stringp . compiled-function-p)))
-
+(defun pcase--subtype-bitsets ()
+ (let ((built-in-types ()))
+ (mapatoms (lambda (sym)
+ (let ((class (get sym 'cl--class)))
+ (when (and (built-in-class-p class)
+ (get sym 'cl-deftype-satisfies))
+ (push (list sym
+ (get sym 'cl-deftype-satisfies)
+ (cl--class-allparents class))
+ built-in-types)))))
+ ;; The "true" predicate for `function' type is `cl-functionp'.
+ (setcar (nthcdr 1 (assq 'function built-in-types)) 'cl-functionp)
+ ;; Sort the types from deepest in the hierarchy so all children
+ ;; are processed before their parent. It also gives lowest
+ ;; numbers to those types that are subtypes of the largest number
+ ;; of types, which minimize the need to use bignums.
+ (setq built-in-types (sort built-in-types
+ (lambda (x y)
+ (> (length (nth 2 x)) (length (nth 2 y))))))
+
+ (let ((bitsets (make-hash-table))
+ (i 1))
+ (dolist (x built-in-types)
+ ;; Don't dedicate any bit to those predicates which already
+ ;; have a bitset, since it means they're already represented
+ ;; by their subtypes.
+ (unless (and (nth 1 x) (gethash (nth 1 x) bitsets))
+ (dolist (parent (nth 2 x))
+ (let ((pred (nth 1 (assq parent built-in-types))))
+ (unless (or (eq parent t) (null pred))
+ (puthash pred (+ i (gethash pred bitsets 0))
+ bitsets))))
+ (setq i (+ i i))))
+
+ ;; Extra predicates that don't have matching types.
+ (dolist (pred-types '((functionp cl-functionp consp symbolp)
+ (keywordp symbolp)
+ (characterp fixnump)
+ (natnump integerp)
+ (facep symbolp stringp)
+ (plistp listp)
+ (cl-struct-p recordp)
+ ;; ;; FIXME: These aren't quite in the same
+ ;; ;; category since they'll signal errors.
+ (fboundp symbolp)
+ ))
+ (puthash (car pred-types)
+ (apply #'logior
+ (mapcar (lambda (pred)
+ (gethash pred bitsets))
+ (cdr pred-types)))
+ bitsets))
+ bitsets)))
+
+(defconst pcase--subtype-bitsets
+ (if (fboundp 'built-in-class-p)
+ (pcase--subtype-bitsets)
+ ;; Early bootstrap: we don't have the built-in classes yet, so just
+ ;; use an empty table for now.
+ (prog1 (make-hash-table)
+ ;; The empty table leads to significantly worse code, so upgrade
+ ;; to the real table as soon as possible (most importantly: before we
+ ;; start compiling code, and hence baking the result into files).
+ (with-eval-after-load 'cl-preloaded
+ (defconst pcase--subtype-bitsets (pcase--subtype-bitsets)))))
+ "Hash table mapping type predicates to their sets of types.
+The table maps each type predicate, such as `numberp' and `stringp',
+to the set of built-in types for which the predicate may return non-nil.
+The sets are represented as bitsets (integers) where each bit represents
+a specific leaf type. Which bit represents which type is unspecified.")
+
+;; Extra predicates
(defun pcase--mutually-exclusive-p (pred1 pred2)
- (or (member (cons pred1 pred2)
- pcase-mutually-exclusive-predicates)
- (member (cons pred2 pred1)
- pcase-mutually-exclusive-predicates)))
+ (let ((subtypes1 (gethash pred1 pcase--subtype-bitsets)))
+ (when subtypes1
+ (let ((subtypes2 (gethash pred2 pcase--subtype-bitsets)))
+ (when subtypes2
+ (zerop (logand subtypes1 subtypes2)))))))
(defun pcase--split-match (sym splitter match)
(cond
@@ -780,12 +836,13 @@ A and B can be one of:
((vectorp (cadr pat)) #'vectorp)
((compiled-function-p (cadr pat))
#'compiled-function-p))))
- (pcase--mutually-exclusive-p (cadr upat) otherpred))
+ (and otherpred
+ (pcase--mutually-exclusive-p (cadr upat) otherpred)))
'(:pcase--fail . nil))
- ;; Since we turn (or 'a 'b 'c) into (pred (pcase--flip (memq '(a b c))))
+ ;; Since we turn (or 'a 'b 'c) into (pred (memq _ '(a b c)))
;; try and preserve the info we get from that memq test.
- ((and (eq 'pcase--flip (car-safe (cadr upat)))
- (memq (cadr (cadr upat)) '(memq member memql))
+ ((and (memq (car-safe (cadr upat)) '(memq member memql))
+ (eq (cadr (cadr upat)) '_)
(eq 'quote (car-safe (nth 2 (cadr upat))))
(eq 'quote (car-safe pat)))
(let ((set (cadr (nth 2 (cadr upat)))))
@@ -833,7 +890,7 @@ A and B can be one of:
(defmacro pcase--flip (fun arg1 arg2)
"Helper function, used internally to avoid (funcall (lambda ...) ...)."
- (declare (debug (sexp body)))
+ (declare (debug (sexp body)) (obsolete _ "30.1"))
`(,fun ,arg2 ,arg1))
(defun pcase--funcall (fun arg vars)
@@ -854,9 +911,13 @@ A and B can be one of:
(let ((newsym (gensym "x")))
(push (list newsym arg) env)
(setq arg newsym)))
- (if (or (functionp fun) (not (consp fun)))
- `(funcall #',fun ,arg)
- `(,@fun ,arg)))))
+ (cond
+ ((or (functionp fun) (not (consp fun)))
+ `(funcall #',fun ,arg))
+ ((memq '_ fun)
+ (mapcar (lambda (x) (if (eq '_ x) arg x)) fun))
+ (t
+ `(,@fun ,arg))))))
(if (null env)
call
;; Let's not replace `vars' in `fun' since it's
@@ -917,7 +978,7 @@ Otherwise, it defers to REST which is a list of branches of the form
;; Yes, we can use `memql' (or `member')!
((> (length simples) 1)
(pcase--u1 (cons `(match ,var
- . (pred (pcase--flip ,mem-fun ',simples)))
+ . (pred (,mem-fun _ ',simples)))
(cdr matches))
code vars
(if (null others) rest
@@ -947,7 +1008,7 @@ Otherwise, it defers to REST which is a list of branches of the form
(let ((code (pcase--u1 matches code vars rest)))
(if (eq upat '_) code
(macroexp-warn-and-return
- "Pattern t is deprecated. Use `_' instead"
+ (format-message "Pattern t is deprecated. Use `_' instead")
code nil nil upat))))
((eq upat 'pcase--dontcare) :pcase--dontcare)
((memq (car-safe upat) '(guard pred))
@@ -1064,12 +1125,13 @@ The predicate is the logical-AND of:
(declare (debug (pcase-QPAT)))
(cond
((eq (car-safe qpat) '\,) (cadr qpat))
+ ((eq (car-safe qpat) '\,@) (error "Unsupported QPAT: %S" qpat))
((vectorp qpat)
`(and (pred vectorp)
(app length ,(length qpat))
,@(let ((upats nil))
(dotimes (i (length qpat))
- (push `(app (pcase--flip aref ,i) ,(list '\` (aref qpat i)))
+ (push `(app (aref _ ,i) ,(list '\` (aref qpat i)))
upats))
(nreverse upats))))
((consp qpat)
diff --git a/lisp/emacs-lisp/pp.el b/lisp/emacs-lisp/pp.el
index 448d02048a3..d586fc59939 100644
--- a/lisp/emacs-lisp/pp.el
+++ b/lisp/emacs-lisp/pp.el
@@ -25,7 +25,6 @@
;;; Code:
(require 'cl-lib)
-(defvar font-lock-verbose)
(defgroup pp nil
"Pretty printer for Emacs Lisp."
@@ -52,53 +51,253 @@ Note that this could slow down `pp' considerably when formatting
large lists."
:type 'boolean
:version "29.1")
+(make-obsolete-variable 'pp-use-max-width 'pp-default-function "30.1")
+
+(defcustom pp-default-function #'pp-fill
+ ;; FIXME: The best pretty printer to use depends on the use-case
+ ;; so maybe we should allow callers to specify what they want (maybe with
+ ;; options like `fast', `compact', `code', `data', ...) and these
+ ;; can then be mapped to actual pretty-printing algorithms.
+ ;; Then again, callers can just directly call the corresponding function.
+ "Function that `pp' should dispatch to for pretty printing.
+That function can be called in one of two ways:
+- with a single argument, which it should insert and pretty-print at point.
+- with two arguments which delimit a region containing Lisp sexps
+ which should be pretty-printed.
+In both cases, the function can presume that the buffer is setup for
+Lisp syntax."
+ :type '(choice
+ (const :tag "Fit within `fill-column'" pp-fill)
+ (const :tag "Emacs<29 algorithm, fast and good enough" pp-28)
+ (const :tag "Work hard for code (slow on large inputs)"
+ pp-emacs-lisp-code)
+ (const :tag "`pp-emacs-lisp-code' if `pp-use-max-width' else `pp-28'"
+ pp-29)
+ function)
+ :version "30.1")
(defvar pp--inhibit-function-formatting nil)
+;; There are basically two APIs for a pretty-printing function:
+;;
+;; - either the function takes an object (and prints it in addition to
+;; prettifying it).
+;; - or the function takes a region containing an already printed object
+;; and prettifies its content.
+;;
+;; `pp--object' and `pp--region' are helper functions to convert one
+;; API to the other.
+
+
+(defun pp--object (object region-function)
+ "Pretty-print OBJECT at point.
+The prettifying is done by REGION-FUNCTION which is
+called with two positions as arguments and should fold lines
+within that region. Returns the result as a string."
+ (let ((print-escape-newlines pp-escape-newlines)
+ (print-quoted t)
+ (beg (point)))
+ ;; FIXME: In many cases it would be preferable to use `cl-prin1' here.
+ (prin1 object (current-buffer))
+ (funcall region-function beg (point))))
+
+(defun pp--region (beg end object-function)
+ "Pretty-print the object(s) contained within BEG..END.
+OBJECT-FUNCTION is called with a single object as argument
+and should pretty print it at point into the current buffer."
+ (save-excursion
+ (with-restriction beg end
+ (goto-char (point-min))
+ (while
+ (progn
+ ;; We'll throw away all the comments within objects, but let's
+ ;; try at least to preserve the comments between objects.
+ (forward-comment (point-max))
+ (let ((beg (point))
+ (object (ignore-error end-of-buffer
+ (list (read (current-buffer))))))
+ (when (consp object)
+ (delete-region beg (point))
+ (funcall object-function (car object))
+ t)))))))
+
+(defun pp-29 (beg-or-sexp &optional end) ;FIXME: Better name?
+ "Prettify the current region with printed representation of a Lisp object.
+Uses the pretty-printing algorithm that was standard in Emacs-29,
+which, depending on `pp-use-max-width', will either use `pp-28'
+or `pp-emacs-lisp-code'."
+ (if pp-use-max-width
+ (let ((pp--inhibit-function-formatting t)) ;FIXME: Why?
+ (pp-emacs-lisp-code beg-or-sexp end))
+ (pp-28 beg-or-sexp end)))
+
;;;###autoload
-(defun pp-to-string (object)
+(defun pp-to-string (object &optional pp-function)
"Return a string containing the pretty-printed representation of OBJECT.
OBJECT can be any Lisp object. Quoting characters are used as needed
-to make output that `read' can handle, whenever this is possible."
- (if pp-use-max-width
- (let ((pp--inhibit-function-formatting t))
- (with-temp-buffer
- (pp-emacs-lisp-code object)
- (buffer-string)))
- (with-temp-buffer
- (lisp-mode-variables nil)
- (set-syntax-table emacs-lisp-mode-syntax-table)
- (let ((print-escape-newlines pp-escape-newlines)
- (print-quoted t))
- (prin1 object (current-buffer)))
- (pp-buffer)
- (buffer-string))))
+to make output that `read' can handle, whenever this is possible.
+Optional argument PP-FUNCTION overrides `pp-default-function'."
+ (with-temp-buffer
+ (lisp-mode-variables nil)
+ (set-syntax-table emacs-lisp-mode-syntax-table)
+ (funcall (or pp-function pp-default-function) object)
+ ;; Preserve old behavior of (usually) finishing with a newline.
+ (unless (bolp) (insert "\n"))
+ (buffer-string)))
+
+(defun pp--within-fill-column-p ()
+ "Return non-nil if point is within `fill-column'."
+ ;; Try and make it O(fill-column) rather than O(current-column),
+ ;; so as to avoid major slowdowns on long lines.
+ ;; FIXME: This doesn't account for invisible text or `display' properties :-(
+ (and (save-excursion
+ (re-search-backward
+ "^\\|\n" (max (point-min) (- (point) fill-column)) t))
+ (<= (current-column) fill-column)))
+
+(defun pp-fill (beg &optional end)
+ "Break lines in Lisp code between BEG and END so it fits within `fill-column'.
+Presumes the current buffer has syntax and indentation properly
+configured for that.
+Designed under the assumption that the region occupies a single line,
+tho it should also work if that's not the case.
+Can also be called with a single argument, in which case
+it inserts and pretty-prints that arg at point."
+ (interactive "r")
+ (if (null end) (pp--object beg #'pp-fill)
+ (goto-char beg)
+ (let* ((end (copy-marker end t))
+ (avoid-unbreakable
+ (lambda ()
+ (and (memq (char-before) '(?# ?s ?f))
+ (memq (char-after) '(?\[ ?\())
+ (looking-back "#[sf]?" (- (point) 2))
+ (goto-char (match-beginning 0)))))
+ (newline (lambda ()
+ (skip-chars-forward ")]}")
+ (unless (save-excursion (skip-chars-forward " \t") (eolp))
+ (funcall avoid-unbreakable)
+ (insert "\n")
+ (indent-according-to-mode)))))
+ (while (progn (forward-comment (point-max))
+ (< (point) end))
+ (let ((beg (point))
+ ;; Whether we're in front of an element with paired delimiters.
+ ;; Can be something funky like #'(lambda ..) or ,'#s(...)
+ ;; Or also #^[..].
+ (paired (when (looking-at "['`,#]*[[:alpha:]^]*\\([({[\"]\\)")
+ (match-beginning 1))))
+ ;; Go to the end of the sexp.
+ (goto-char (or (scan-sexps (or paired (point)) 1) end))
+ (unless
+ (and
+ ;; The sexp is all on a single line.
+ (save-excursion (not (search-backward "\n" beg t)))
+ ;; And its end is within `fill-column'.
+ (or (pp--within-fill-column-p)
+ ;; If the end of the sexp is beyond `fill-column',
+ ;; try to move the sexp to its own line.
+ (and
+ (save-excursion
+ (goto-char beg)
+ ;; We skip backward over open parens because cutting
+ ;; the line right after an open paren does not help
+ ;; reduce the indentation depth.
+ ;; Similarly, we prefer to cut before a "." than after
+ ;; it because it reduces the indentation depth.
+ (while
+ (progn
+ (funcall avoid-unbreakable)
+ (not (zerop (skip-chars-backward " \t({[',.")))))
+ (if (bolp)
+ ;; The sexp already starts on its own line.
+ (progn (goto-char beg) nil)
+ (setq beg (copy-marker beg t))
+ (if paired (setq paired (copy-marker paired t)))
+ ;; We could try to undo this insertion if it
+ ;; doesn't reduce the indentation depth, but I'm
+ ;; not sure it's worth the trouble.
+ (insert "\n") (indent-according-to-mode)
+ t))
+ ;; Check again if we moved the whole exp to a new line.
+ (pp--within-fill-column-p))))
+ ;; The sexp is spread over several lines, and/or its end is
+ ;; (still) beyond `fill-column'.
+ (when (and paired (not (eq ?\" (char-after paired))))
+ ;; The sexp has sub-parts, so let's try and spread
+ ;; them over several lines.
+ (save-excursion
+ (goto-char beg)
+ (when (looking-at "(\\([^][()\" \t\n;']+\\)")
+ ;; Inside an expression of the form (SYM ARG1
+ ;; ARG2 ... ARGn) where SYM has a `lisp-indent-function'
+ ;; property that's a number, insert a newline after
+ ;; the corresponding ARGi, because it tends to lead to
+ ;; more natural and less indented code.
+ (let* ((sym (intern-soft (match-string 1)))
+ (lif (and sym (get sym 'lisp-indent-function))))
+ (if (eq lif 'defun) (setq lif 2))
+ (when (natnump lif)
+ (goto-char (match-end 0))
+ ;; Do nothing if there aren't enough args.
+ (ignore-error scan-error
+ (forward-sexp lif)
+ (funcall newline))))))
+ (save-excursion
+ (pp-fill (1+ paired) (1- (point)))))
+ ;; Now the sexp either ends beyond `fill-column' or is
+ ;; spread over several lines (or both). Either way, the
+ ;; rest of the line should be moved to its own line.
+ (funcall newline)))))))
;;;###autoload
(defun pp-buffer ()
"Prettify the current buffer with printed representation of a Lisp object."
(interactive)
- (goto-char (point-min))
- (while (not (eobp))
- (cond
- ((ignore-errors (down-list 1) t)
- (save-excursion
- (backward-char 1)
- (skip-chars-backward "'`#^")
- (when (and (not (bobp)) (memq (char-before) '(?\s ?\t ?\n)))
+ ;; The old code used `indent-sexp' which mostly works "anywhere",
+ ;; so let's make sure we also work right in buffers that aren't
+ ;; setup specifically for Lisp.
+ (if (and (eq (syntax-table) emacs-lisp-mode-syntax-table)
+ (eq indent-line-function #'lisp-indent-line))
+ (funcall pp-default-function (point-min) (point-max))
+ (with-syntax-table emacs-lisp-mode-syntax-table
+ (let ((indent-line-function #'lisp-indent-line))
+ (funcall pp-default-function (point-min) (point-max)))))
+ ;; Preserve old behavior of (usually) finishing with a newline and
+ ;; with point at BOB.
+ (goto-char (point-max))
+ (unless (bolp) (insert "\n"))
+ (goto-char (point-min)))
+
+(defun pp-28 (beg &optional end) ;FIXME: Better name?
+ "Prettify the current region with printed representation of a Lisp object.
+Uses the pretty-printing algorithm that was standard before Emacs-30.
+Non-interactively can also be called with a single argument, in which
+case that argument will be inserted pretty-printed at point."
+ (interactive "r")
+ (if (null end) (pp--object beg #'pp-29)
+ (with-restriction beg end
+ (goto-char (point-min))
+ (while (not (eobp))
+ (cond
+ ((ignore-errors (down-list 1) t)
+ (save-excursion
+ (backward-char 1)
+ (skip-chars-backward "'`#^")
+ (when (and (not (bobp)) (memq (char-before) '(?\s ?\t ?\n)))
+ (delete-region
+ (point)
+ (progn (skip-chars-backward " \t\n") (point)))
+ (insert "\n"))))
+ ((ignore-errors (up-list 1) t)
+ (skip-syntax-forward ")")
(delete-region
(point)
- (progn (skip-chars-backward " \t\n") (point)))
- (insert "\n"))))
- ((ignore-errors (up-list 1) t)
- (skip-syntax-forward ")")
- (delete-region
- (point)
- (progn (skip-chars-forward " \t\n") (point)))
- (insert ?\n))
- (t (goto-char (point-max)))))
- (goto-char (point-min))
- (indent-sexp))
+ (progn (skip-chars-forward " \t\n") (point)))
+ (insert ?\n))
+ (t (goto-char (point-max)))))
+ (goto-char (point-min))
+ (indent-sexp))))
;;;###autoload
(defun pp (object &optional stream)
@@ -106,14 +305,20 @@ to make output that `read' can handle, whenever this is possible."
Quoting characters are printed as needed to make output that `read'
can handle, whenever this is possible.
-This function does not apply special formatting rules for Emacs
-Lisp code. See `pp-emacs-lisp-code' instead.
-
-By default, this function won't limit the line length of lists
-and vectors. Bind `pp-use-max-width' to a non-nil value to do so.
+Uses the pretty-printing code specified in `pp-default-function'.
Output stream is STREAM, or value of `standard-output' (which see)."
- (princ (pp-to-string object) (or stream standard-output)))
+ (cond
+ ((and (eq (or stream standard-output) (current-buffer))
+ ;; Make sure the current buffer is setup sanely.
+ (eq (syntax-table) emacs-lisp-mode-syntax-table)
+ (eq indent-line-function #'lisp-indent-line))
+ ;; Skip the buffer->string->buffer middle man.
+ (funcall pp-default-function object)
+ ;; Preserve old behavior of (usually) finishing with a newline.
+ (unless (bolp) (insert "\n")))
+ (t
+ (princ (pp-to-string object) (or stream standard-output)))))
;;;###autoload
(defun pp-display-expression (expression out-buffer-name &optional lisp)
@@ -155,6 +360,23 @@ after OUT-BUFFER-NAME."
(setq buffer-read-only nil)
(setq-local font-lock-verbose nil)))))
+(defun pp-insert-short-sexp (sexp &optional width)
+ "Insert a short description of SEXP in the current buffer.
+WIDTH is the maximum width to use for it and it defaults to the
+space available between point and the window margin."
+ (let ((printed (format "%S" sexp)))
+ (if (and (not (string-search "\n" printed))
+ (<= (string-width printed)
+ (or width (- (window-width) (current-column)))))
+ (insert printed)
+ (insert-text-button
+ "[Show]"
+ 'follow-link t
+ 'action (lambda (&rest _ignore)
+ ;; FIXME: Why "eval output"?
+ (pp-display-expression sexp "*Pp Eval Output*"))
+ 'help-echo "mouse-2, RET: pretty print value in another buffer"))))
+
;;;###autoload
(defun pp-eval-expression (expression)
"Evaluate EXPRESSION and pretty-print its value.
@@ -220,39 +442,52 @@ Ignores leading comment characters."
(pp-macroexpand-expression (pp-last-sexp))))
;;;###autoload
-(defun pp-emacs-lisp-code (sexp)
+(defun pp-emacs-lisp-code (sexp &optional end)
"Insert SEXP into the current buffer, formatted as Emacs Lisp code.
Use the `pp-max-width' variable to control the desired line length.
-Note that this could be slow for large SEXPs."
+Note that this could be slow for large SEXPs.
+Can also be called with two arguments, in which case they're taken to be
+the bounds of a region containing Lisp code to pretty-print."
(require 'edebug)
- (let ((obuf (current-buffer)))
- (with-temp-buffer
- (emacs-lisp-mode)
- (pp--insert-lisp sexp)
- (insert "\n")
- (goto-char (point-min))
- (indent-sexp)
- (while (re-search-forward " +$" nil t)
- (replace-match ""))
- (insert-into-buffer obuf))))
+ (if end (pp--region sexp end #'pp-emacs-lisp-code)
+ (let ((obuf (current-buffer)))
+ (with-temp-buffer
+ (emacs-lisp-mode)
+ (pp--insert-lisp sexp)
+ (insert "\n")
+ (goto-char (point-min))
+ (indent-sexp)
+ (while (re-search-forward " +$" nil t)
+ (replace-match ""))
+ (insert-into-buffer obuf)))))
+
+(defvar pp--quoting-syntaxes
+ `((quote . "'")
+ (function . "#'")
+ (,backquote-backquote-symbol . "`")
+ (,backquote-unquote-symbol . ",")
+ (,backquote-splice-symbol . ",@")))
+
+(defun pp--quoted-or-unquoted-form-p (cons)
+ ;; Return non-nil when CONS has one of the forms 'X, `X, ,X or ,@X
+ (let ((head (car cons)))
+ (and (symbolp head)
+ (assq head pp--quoting-syntaxes)
+ (let ((rest (cdr cons)))
+ (and (consp rest) (null (cdr rest)))))))
(defun pp--insert-lisp (sexp)
(cl-case (type-of sexp)
(vector (pp--format-vector sexp))
(cons (cond
((consp (cdr sexp))
- (if (and (length= sexp 2)
- (memq (car sexp) '(quote function)))
- (cond
- ((symbolp (cadr sexp))
- (let ((print-quoted t))
- (prin1 sexp (current-buffer))))
- ((consp (cadr sexp))
- (insert (if (eq (car sexp) 'quote)
- "'" "#'"))
- (pp--format-list (cadr sexp)
- (set-marker (make-marker) (1- (point))))))
- (pp--format-list sexp)))
+ (let ((head (car sexp)))
+ (if-let (((null (cddr sexp)))
+ (syntax-entry (assq head pp--quoting-syntaxes)))
+ (progn
+ (insert (cdr syntax-entry))
+ (pp--insert-lisp (cadr sexp)))
+ (pp--format-list sexp))))
(t
(prin1 sexp (current-buffer)))))
;; Print some of the smaller integers as characters, perhaps?
@@ -264,6 +499,8 @@ Note that this could be slow for large SEXPs."
(string
(let ((print-escape-newlines t))
(prin1 sexp (current-buffer))))
+ (symbol
+ (prin1 sexp (current-buffer)))
(otherwise (princ sexp (current-buffer)))))
(defun pp--format-vector (sexp)
@@ -274,15 +511,29 @@ Note that this could be slow for large SEXPs."
(insert "]"))
(defun pp--format-list (sexp &optional start)
- (if (and (symbolp (car sexp))
- (not pp--inhibit-function-formatting)
- (not (keywordp (car sexp))))
+ (if (not (let ((head (car sexp)))
+ (or pp--inhibit-function-formatting
+ (not (symbolp head))
+ (keywordp head)
+ (let ((l sexp))
+ (catch 'not-funcall
+ (while l
+ (when (or
+ (atom l) ; SEXP is a dotted list
+ ;; Does SEXP have a form like (ELT... . ,X) ?
+ (pp--quoted-or-unquoted-form-p l))
+ (throw 'not-funcall t))
+ (setq l (cdr l)))
+ nil)))))
(pp--format-function sexp)
(insert "(")
(pp--insert start (pop sexp))
(while sexp
(if (consp sexp)
- (pp--insert " " (pop sexp))
+ (if (not (pp--quoted-or-unquoted-form-p sexp))
+ (pp--insert " " (pop sexp))
+ (pp--insert " . " sexp)
+ (setq sexp nil))
(pp--insert " . " sexp)
(setq sexp nil)))
(insert ")")))
diff --git a/lisp/emacs-lisp/range.el b/lisp/emacs-lisp/range.el
index caa5a30a780..19a6da34acb 100644
--- a/lisp/emacs-lisp/range.el
+++ b/lisp/emacs-lisp/range.el
@@ -194,7 +194,7 @@ these ranges."
(nreverse result)))))
(defun range-add-list (ranges list)
- "Return a list of ranges that has all articles from both RANGES and LIST.
+ "Return a list of ranges that has all numbers from both RANGES and LIST.
Note: LIST has to be sorted over `<'."
(if (not ranges)
(range-compress-list list)
@@ -249,9 +249,9 @@ Note: LIST has to be sorted over `<'."
out)))
(defun range-remove (range1 range2)
- "Return a range that has all articles from RANGE2 removed from RANGE1.
+ "Return a range that has all numbers from RANGE2 removed from RANGE1.
The returned range is always a list. RANGE2 can also be a unsorted
-list of articles. RANGE1 is modified by side effects, RANGE2 is not
+list of numbers. RANGE1 is modified by side effects, RANGE2 is not
modified."
(if (or (null range1) (null range2))
range1
@@ -345,7 +345,7 @@ modified."
(defun range-list-intersection (list ranges)
"Return a list of numbers in LIST that are members of RANGES.
-oLIST is a sorted list."
+LIST is a sorted list."
(setq ranges (range-normalize ranges))
(let (number result)
(while (setq number (pop list))
diff --git a/lisp/emacs-lisp/re-builder.el b/lisp/emacs-lisp/re-builder.el
index 0a47cca0231..c5307f70d08 100644
--- a/lisp/emacs-lisp/re-builder.el
+++ b/lisp/emacs-lisp/re-builder.el
@@ -825,7 +825,7 @@ If SUBEXP is non-nil mark only the corresponding sub-expressions."
(defun reb-restart-font-lock ()
"Restart `font-lock-mode' to fit current regexp format."
- (with-current-buffer (get-buffer reb-buffer)
+ (with-current-buffer reb-buffer
(let ((font-lock-is-on font-lock-mode))
(font-lock-mode -1)
(kill-local-variable 'font-lock-set-defaults)
diff --git a/lisp/emacs-lisp/regexp-opt.el b/lisp/emacs-lisp/regexp-opt.el
index 427542a8dbd..59c1b7d8e10 100644
--- a/lisp/emacs-lisp/regexp-opt.el
+++ b/lisp/emacs-lisp/regexp-opt.el
@@ -130,6 +130,7 @@ usually more efficient than that of a simplified version:
(concat (car parens)
(mapconcat \\='regexp-quote strings \"\\\\|\")
(cdr parens))))"
+ (declare (pure t) (side-effect-free t))
(save-match-data
;; Recurse on the sorted list.
(let* ((max-lisp-eval-depth 10000)
@@ -153,6 +154,7 @@ usually more efficient than that of a simplified version:
"Return the depth of REGEXP.
This means the number of non-shy regexp grouping constructs
\(parenthesized expressions) in REGEXP."
+ (declare (pure t) (side-effect-free t))
(save-match-data
;; Hack to signal an error if REGEXP does not have balanced parentheses.
(string-match regexp "")
@@ -269,6 +271,7 @@ Merges keywords to avoid backtracking in Emacs's regexp matcher."
CHARS should be a list of characters.
If CHARS is the empty list, the return value is a regexp that
never matches anything."
+ (declare (pure t) (side-effect-free t))
;; The basic idea is to find character ranges. Also we take care in the
;; position of character set meta characters in the character set regexp.
;;
diff --git a/lisp/emacs-lisp/rmc.el b/lisp/emacs-lisp/rmc.el
index 6db47daac55..378687c0326 100644
--- a/lisp/emacs-lisp/rmc.el
+++ b/lisp/emacs-lisp/rmc.el
@@ -126,7 +126,8 @@
(defun read-multiple-choice (prompt choices &optional help-string show-help
long-form)
"Ask user to select an entry from CHOICES, prompting with PROMPT.
-This function allows to ask the user a multiple-choice question.
+This function is used to ask the user a question with multiple
+choices.
CHOICES should be a list of the form (KEY NAME [DESCRIPTION]).
KEY is a character the user should type to select the entry.
diff --git a/lisp/emacs-lisp/rx.el b/lisp/emacs-lisp/rx.el
index b20e5a90a36..246e41cff0b 100644
--- a/lisp/emacs-lisp/rx.el
+++ b/lisp/emacs-lisp/rx.el
@@ -26,7 +26,7 @@
;; The translation to string regexp is done by a macro and does not
;; incur any extra processing during run time. Example:
;;
-;; (rx bos (or (not (any "^"))
+;; (rx bos (or (not "^")
;; (seq "^" (or " *" "["))))
;;
;; => "\\`\\(?:[^^]\\|\\^\\(?: \\*\\|\\[\\)\\)"
@@ -35,8 +35,43 @@
;; Olin Shivers's SRE, with concessions to Emacs regexp peculiarities,
;; and the older Emacs package Sregex.
+;;; Legacy syntax still accepted by rx:
+;;
+;; These are constructs from earlier rx and sregex implementations
+;; that were mistakes, accidents or just not very good ideas in hindsight.
+
+;; Obsolete: accepted but not documented
+;;
+;; Obsolete Preferred
+;; --------------------------------------------------------
+;; (not word-boundary) not-word-boundary
+;; (not-syntax X) (not (syntax X))
+;; not-wordchar (not wordchar)
+;; (not-char ...) (not (any ...))
+;; any nonl, not-newline
+;; (repeat N FORM) (= N FORM)
+;; (syntax CHARACTER) (syntax NAME)
+;; (syntax CHAR-SYM) [1] (syntax NAME)
+;; (category chinse-two-byte) (category chinese-two-byte)
+;; unibyte ascii
+;; multibyte nonascii
+;; --------------------------------------------------------
+;; [1] where CHAR-SYM is a symbol with single-character name
+
+;; Obsolescent: accepted and documented but discouraged
+;;
+;; Obsolescent Preferred
+;; --------------------------------------------------------
+;; (and ...) (seq ...), (: ...), (sequence ...)
+;; anything anychar
+;; minimal-match, maximal-match lazy ops: ??, *?, +?
+
+;; FIXME: Prepare a phase-out by emitting compile-time warnings about
+;; at least some of the legacy constructs above.
+
;;; Code:
+
;; The `rx--translate...' functions below return (REGEXP . PRECEDENCE),
;; where REGEXP is a list of string expressions that will be
;; concatenated into a regexp, and PRECEDENCE is one of
@@ -126,27 +161,23 @@ Each entry is:
(or (cdr (assq name rx--local-definitions))
(get name 'rx-definition)))
-(defun rx--expand-def (form)
- "FORM expanded (once) if a user-defined construct; otherwise nil."
- (cond ((symbolp form)
- (let ((def (rx--lookup-def form)))
- (and def
- (if (cdr def)
- (error "Not an `rx' symbol definition: %s" form)
- (car def)))))
- ((and (consp form) (symbolp (car form)))
- (let* ((op (car form))
- (def (rx--lookup-def op)))
+(defun rx--expand-def-form (form)
+ "List FORM expanded (once) if a user-defined construct; otherwise nil."
+ (let ((op (car form)))
+ (and (symbolp op)
+ (let ((def (rx--lookup-def op)))
(and def
(if (cdr def)
- (rx--expand-template
- op (cdr form) (nth 0 def) (nth 1 def))
+ (rx--expand-template op (cdr form) (nth 0 def) (nth 1 def))
(error "Not an `rx' form definition: %s" op)))))))
-;; TODO: Additions to consider:
-;; - A construct like `or' but without the match order guarantee,
-;; maybe `unordered-or'. Useful for composition or generation of
-;; alternatives; permits more effective use of regexp-opt.
+(defun rx--expand-def-symbol (symbol)
+ "SYM expanded (once) if a user-defined name; otherwise nil."
+ (let ((def (rx--lookup-def symbol)))
+ (and def
+ (if (cdr def)
+ (error "Not an `rx' symbol definition: %s" symbol)
+ (car def)))))
(defun rx--translate-symbol (sym)
"Translate an rx symbol. Return (REGEXP . PRECEDENCE)."
@@ -167,28 +198,19 @@ Each entry is:
('not-word-boundary (cons (list "\\B") t))
('symbol-start (cons (list "\\_<") t))
('symbol-end (cons (list "\\_>") t))
- ('not-wordchar (cons (list "\\W") t))
+ ('not-wordchar (rx--translate '(not wordchar)))
(_
(cond
((let ((class (cdr (assq sym rx--char-classes))))
(and class (cons (list (concat "[[:" (symbol-name class) ":]]")) t))))
- ((let ((expanded (rx--expand-def sym)))
+ ((let ((expanded (rx--expand-def-symbol sym)))
(and expanded (rx--translate expanded))))
;; For compatibility with old rx.
((let ((entry (assq sym rx-constituents)))
- (and (progn
- (while (and entry (not (stringp (cdr entry))))
- (setq entry
- (if (symbolp (cdr entry))
- ;; Alias for another entry.
- (assq (cdr entry) rx-constituents)
- ;; Wrong type, try further down the list.
- (assq (car entry)
- (cdr (memq entry rx-constituents))))))
- entry)
- (cons (list (cdr entry)) nil))))
+ (and entry (rx--translate-compat-symbol-entry entry))))
+
(t (error "Unknown rx symbol `%s'" sym))))))
(defun rx--enclose (left-str rexp right-str)
@@ -254,83 +276,225 @@ Left-fold the list L, starting with X, by the binary function F."
(setq l (cdr l)))
x)
-(defun rx--normalise-or-arg (form)
- "Normalize the `or' argument FORM.
-Characters become strings, user-definitions and `eval' forms are expanded,
-and `or' forms are normalized recursively."
- (cond ((characterp form)
+;; FIXME: flatten nested `or' patterns when performing char-pattern combining.
+;; The only reason for not flattening is to ensure regexp-opt processing
+;; (which we do for entire `or' patterns, not subsequences), but we
+;; obviously want to translate
+;; (or "a" space (or "b" (+ nonl) word) "c")
+;; -> (or (in "ab" space) (+ nonl) (in "c" word))
+
+;; FIXME: normalise `seq', both the construct and implicit sequences,
+;; so that they are flattened, adjacent strings concatenated, and
+;; empty strings removed. That would give more opportunities for regexp-opt:
+;; (or "a" (seq "ab" (seq "c" "d") "")) -> (or "a" "abcd")
+
+;; FIXME: Since `rx--normalise-char-pattern' recurses through `or', `not' and
+;; `intersection', we may end up normalising subtrees multiple times
+;; which wastes time (but should be idempotent).
+;; One way to avoid this is to aggressively normalise the entire tree
+;; before translating anything at all, but we must then recurse through
+;; all constructs and probably copy them.
+;; Such normalisation could normalise synonyms, eliminate `minimal-match'
+;; and `maximal-match' and convert affected `1+' to either `+' or `+?' etc.
+;; We would also consolidate the user-def lookup, both modern and legacy,
+;; in one place.
+
+(defun rx--normalise-char-pattern (form)
+ "Normalize FORM as a pattern matching a single-character.
+Characters become strings, `any' forms and character classes become
+`rx--char-alt' forms, user-definitions and `eval' forms are expanded,
+and `or', `not' and `intersection' forms are normalized recursively.
+
+A `rx--char-alt' form is shaped (rx--char-alt INTERVALS . CLASSES)
+where INTERVALS is a sorted list of disjoint nonadjacent intervals,
+each a cons of characters, and CLASSES an unordered list of unique
+name-normalised character classes."
+ (defvar rx--builtin-forms)
+ (defvar rx--builtin-symbols)
+ (cond ((consp form)
+ (let ((op (car form))
+ (body (cdr form)))
+ (cond ((memq op '(or |))
+ ;; Normalise the constructor to `or' and the args recursively.
+ (cons 'or (mapcar #'rx--normalise-char-pattern body)))
+ ;; Convert `any' forms and char classes now so that we
+ ;; don't need to do it later on.
+ ((memq op '(any in char))
+ (cons 'rx--char-alt (rx--parse-any body)))
+ ((memq op '(not intersection))
+ (cons op (mapcar #'rx--normalise-char-pattern body)))
+ ((eq op 'eval)
+ (rx--normalise-char-pattern (rx--expand-eval body)))
+ ((memq op rx--builtin-forms) form)
+ ((let ((expanded (rx--expand-def-form form)))
+ (and expanded
+ (rx--normalise-char-pattern expanded))))
+ (t form))))
+ ;; FIXME: Should we expand legacy definitions from
+ ;; `rx-constituents' here as well?
+ ((symbolp form)
+ (cond ((let ((class (assq form rx--char-classes)))
+ (and class
+ `(rx--char-alt nil . (,(cdr class))))))
+ ((memq form rx--builtin-symbols) form)
+ ((let ((expanded (rx--expand-def-symbol form)))
+ (and expanded
+ (rx--normalise-char-pattern expanded))))
+ (t form)))
+ ((characterp form)
(char-to-string form))
- ((and (consp form) (memq (car form) '(or |)))
- (cons (car form) (mapcar #'rx--normalise-or-arg (cdr form))))
- ((and (consp form) (eq (car form) 'eval))
- (rx--normalise-or-arg (rx--expand-eval (cdr form))))
- (t
- (let ((expanded (rx--expand-def form)))
- (if expanded
- (rx--normalise-or-arg expanded)
- form)))))
-
-(defun rx--all-string-or-args (body)
- "If BODY only consists of strings or such `or' forms, return all the strings.
-Otherwise throw `rx--nonstring'."
+ (t form)))
+
+(defun rx--char-alt-union (a b)
+ "Union of the (INTERVALS . CLASSES) pairs A and B."
+ (let* ((a-cl (cdr a))
+ (b-cl (cdr b))
+ (classes (if (and a-cl b-cl)
+ (let ((acc a-cl))
+ (dolist (c b-cl)
+ (unless (memq c a-cl)
+ (push c acc)))
+ acc)
+ (or a-cl b-cl))))
+ (cons (rx--interval-set-union (car a) (car b)) classes)))
+
+(defun rx--intersection-intervals (forms)
+ "Intersection of the normalised FORMS, as an interval set."
+ (rx--foldl #'rx--interval-set-intersection '((0 . #x3fffff))
+ (mapcar (lambda (x)
+ (let ((char (rx--reduce-to-char-alt x)))
+ (if (and char (null (cdr char)))
+ (car char)
+ (error "Cannot be used in rx intersection: %S"
+ (rx--human-readable x)))))
+ forms)))
+
+(defun rx--reduce-to-char-alt (form)
+ "Transform FORM into (INTERVALS . CLASSES) or nil if not possible.
+Process `or', `intersection' and `not'.
+FORM must be normalised (from `rx--normalise-char-pattern')."
+ (cond
+ ((stringp form)
+ (and (= (length form) 1)
+ (let ((c (aref form 0)))
+ (list (list (cons c c))))))
+ ((consp form)
+ (let ((head (car form)))
+ (cond
+ ;; FIXME: Transform `digit', `xdigit', `cntrl', `ascii', `nonascii'
+ ;; to ranges? That would allow them to be negated and intersected.
+ ((eq head 'rx--char-alt) (cdr form))
+ ((eq head 'not)
+ (unless (= (length form) 2)
+ (error "rx `not' form takes exactly one argument"))
+ (let ((arg (rx--reduce-to-char-alt (cadr form))))
+ ;; Only interval sets without classes are closed under complement.
+ (and arg (null (cdr arg))
+ (list (rx--interval-set-complement (car arg))))))
+ ((eq head 'or)
+ (let ((args (cdr form)))
+ (let ((acc '(nil))) ; union identity
+ (while (and args
+ (let ((char (rx--reduce-to-char-alt (car args))))
+ (setq acc (and char (rx--char-alt-union acc char)))))
+ (setq args (cdr args)))
+ acc)))
+ ((eq head 'intersection)
+ (list (rx--intersection-intervals (cdr form))))
+ )))
+ ((memq form '(nonl not-newline any))
+ '(((0 . 9) (11 . #x3fffff))))
+ ((memq form '(anychar anything))
+ '(((0 . #x3fffff))))
+ ;; FIXME: A better handling of `unmatchable' would be:
+ ;; * (seq ... unmatchable ...) -> unmatchable
+ ;; * any or-pattern branch that is `unmatchable' is deleted
+ ;; * (REPEAT unmatchable) -> "", if REPEAT accepts 0 repetitions
+ ;; * (REPEAT unmatchable) -> unmatchable, otherwise
+ ;; if it's worth the trouble (probably not).
+ ((eq form 'unmatchable)
+ '(nil))
+ ))
+
+(defun rx--optimise-or-args (args)
+ "Optimise `or' arguments. Return a new rx form.
+Each element of ARGS should have been normalised using
+`rx--normalise-char-pattern'."
+ (if (null args)
+ ;; No arguments.
+ '(rx--char-alt nil . nil) ; FIXME: not `unmatchable'?
+ ;; Join consecutive single-char branches into a char alt where possible.
+ ;; Ideally we should collect all single-char branches but that might
+ ;; alter matching order in some cases.
+ (let ((branches nil)
+ (prev-char nil))
+ (while args
+ (let* ((item (car args))
+ (item-char (rx--reduce-to-char-alt item)))
+ (if item-char
+ (setq prev-char (if prev-char
+ (rx--char-alt-union prev-char item-char)
+ item-char))
+ (when prev-char
+ (push (cons 'rx--char-alt prev-char) branches)
+ (setq prev-char nil))
+ (push item branches)))
+ (setq args (cdr args)))
+ (when prev-char
+ (push (cons 'rx--char-alt prev-char) branches))
+ (if (cdr branches)
+ (cons 'or (nreverse branches))
+ (car branches)))))
+
+(defun rx--all-string-branches-p (forms)
+ "Whether FORMS are all strings or `or' forms with the same property."
+ (rx--every (lambda (x) (or (stringp x)
+ (and (eq (car-safe x) 'or)
+ (rx--all-string-branches-p (cdr x)))))
+ forms))
+
+(defun rx--collect-or-strings (forms)
+ "All strings from FORMS, which are strings or `or' forms."
(mapcan (lambda (form)
- (cond ((stringp form) (list form))
- ((and (consp form) (memq (car form) '(or |)))
- (rx--all-string-or-args (cdr form)))
- (t (throw 'rx--nonstring nil))))
- body))
+ (if (stringp form)
+ (list form)
+ ;; must be an `or' form
+ (rx--collect-or-strings (cdr form))))
+ forms))
+
+;; TODO: Write a more general rx-level factoriser to replace
+;; `regexp-opt' for our purposes. It would handle non-literals:
+;;
+;; (or "ab" (: "a" space) "bc" (: "b" (+ digit)))
+;; -> (or (: "a" (in "b" space)) (: "b" (or "c" (+ digit))))
+;;
+;; As a minor side benefit we would get less useless bracketing.
+;; The main problem is how to deal with matching order, which `regexp-opt'
+;; alters in its own way.
(defun rx--translate-or (body)
"Translate an or-pattern of zero or more rx items.
Return (REGEXP . PRECEDENCE)."
- ;; FIXME: Possible improvements:
- ;;
- ;; - Flatten sub-patterns first: (or (or A B) (or C D)) -> (or A B C D)
- ;; Then call regexp-opt on runs of string arguments. Example:
- ;; (or (+ digit) "CHARLIE" "CHAN" (+ blank))
- ;; -> (or (+ digit) (or "CHARLIE" "CHAN") (+ blank))
- ;;
- ;; - Optimize single-character alternatives better:
- ;; * classes: space, alpha, ...
- ;; * (syntax S), for some S (whitespace, word)
- ;; so that (or "@" "%" digit (any "A-Z" space) (syntax word))
- ;; -> (any "@" "%" digit "A-Z" space word)
- ;; -> "[A-Z@%[:digit:][:space:][:word:]]"
(cond
((null body) ; No items: a never-matching regexp.
(rx--empty))
((null (cdr body)) ; Single item.
(rx--translate (car body)))
(t
- (let* ((args (mapcar #'rx--normalise-or-arg body))
- (all-strings (catch 'rx--nonstring (rx--all-string-or-args args))))
- (cond
- (all-strings ; Only strings.
- (cons (list (regexp-opt all-strings nil))
- t))
- ((rx--every #'rx--charset-p args) ; All charsets.
- (rx--translate-union nil args))
- (t
- (cons (append (car (rx--translate (car args)))
- (mapcan (lambda (item)
- (cons "\\|" (car (rx--translate item))))
- (cdr args)))
- nil)))))))
-
-(defun rx--charset-p (form)
- "Whether FORM looks like a charset, only consisting of character intervals
-and set operations."
- (or (and (consp form)
- (or (and (memq (car form) '(any in char))
- (rx--every (lambda (x) (not (symbolp x))) (cdr form)))
- (and (memq (car form) '(not or | intersection))
- (rx--every #'rx--charset-p (cdr form)))))
- (characterp form)
- (and (stringp form) (= (length form) 1))
- (and (or (symbolp form) (consp form))
- (let ((expanded (rx--expand-def form)))
- (and expanded
- (rx--charset-p expanded))))))
+ (let ((args (mapcar #'rx--normalise-char-pattern body)))
+ (if (rx--all-string-branches-p args)
+ ;; All branches are strings: use `regexp-opt'.
+ (cons (list (regexp-opt (rx--collect-or-strings args) nil))
+ t)
+ (let ((form (rx--optimise-or-args args)))
+ (if (eq (car-safe form) 'or)
+ (let ((branches (cdr form)))
+ (cons (append (car (rx--translate (car branches)))
+ (mapcan (lambda (item)
+ (cons "\\|" (car (rx--translate item))))
+ (cdr branches)))
+ nil))
+ (rx--translate form))))))))
(defun rx--string-to-intervals (str)
"Decode STR as intervals: A-Z becomes (?A . ?Z), and the single
@@ -385,7 +549,7 @@ INTERVALS is a list of (START . END) with START ≤ END, sorted by START."
(defun rx--parse-any (body)
"Parse arguments of an (any ...) construct.
Return (INTERVALS . CLASSES), where INTERVALS is a sorted list of
-disjoint intervals (each a cons of chars), and CLASSES
+disjoint nonadjacent intervals (each a cons of chars), and CLASSES
a list of named character classes in the order they occur in BODY."
(let ((classes nil)
(strings nil)
@@ -412,112 +576,131 @@ a list of named character classes in the order they occur in BODY."
(sort (append conses
(mapcan #'rx--string-to-intervals strings))
#'car-less-than-car))
- (reverse classes))))
+ (nreverse classes))))
(defun rx--generate-alt (negated intervals classes)
"Generate a character alternative. Return (REGEXP . PRECEDENCE).
If NEGATED is non-nil, negate the result; INTERVALS is a sorted
list of disjoint intervals and CLASSES a list of named character
classes."
- (let ((items (append intervals classes)))
- ;; Move lone ] and range ]-x to the start.
- (let ((rbrac-l (assq ?\] items)))
- (when rbrac-l
- (setq items (cons rbrac-l (delq rbrac-l items)))))
-
- ;; Split x-] and move the lone ] to the start.
- (let ((rbrac-r (rassq ?\] items)))
- (when (and rbrac-r (not (eq (car rbrac-r) ?\])))
- (setcdr rbrac-r ?\\)
- (setq items (cons '(?\] . ?\]) items))))
-
- ;; Split ,-- (which would end up as ,- otherwise).
- (let ((dash-r (rassq ?- items)))
- (when (eq (car dash-r) ?,)
- (setcdr dash-r ?,)
- (setq items (nconc items '((?- . ?-))))))
-
- ;; Remove - (lone or at start of interval)
- (let ((dash-l (assq ?- items)))
- (when dash-l
- (if (eq (cdr dash-l) ?-)
- (setq items (delq dash-l items)) ; Remove lone -
- (setcar dash-l ?.)) ; Reduce --x to .-x
- (setq items (nconc items '((?- . ?-))))))
-
- ;; Deal with leading ^ and range ^-x in non-negated set.
- (when (and (eq (car-safe (car items)) ?^)
- (not negated))
- (if (eq (cdar items) ?^)
- ;; single leading ^
- (when (cdr items)
- ;; Move the ^ to second place.
- (setq items (cons (cadr items)
- (cons (car items) (cddr items)))))
- ;; Split ^-x to _-x^
- (setq items (cons (cons ?_ (cdar items))
- (cons '(?^ . ?^)
- (cdr items))))))
-
- (cond
- ;; Empty set: if negated, any char, otherwise match-nothing.
- ((null items)
+ ;; No, this is not pretty code. You try doing it in a way that is both
+ ;; elegant and efficient. Or just one of the two. I dare you.
+
+ ;; Detect whether the interval set is better described in
+ ;; complemented form. This is not just a matter of aesthetics: any
+ ;; range that straddles the char-raw boundary will be mutilated by the
+ ;; regexp engine. Ranges from ASCII to raw bytes will exclude the
+ ;; all non-ASCII non-raw bytes, and ranges from non-ASCII Unicode
+ ;; to raw bytes are ignored.
+ (unless (or classes
+ ;; Any interval set covering #x3fff7f should be negated.
+ (rx--every (lambda (iv) (not (<= (car iv) #x3fff7f (cdr iv))))
+ intervals))
+ (setq negated (not negated))
+ (setq intervals (rx--interval-set-complement intervals)))
+ (cond
+ ;; Single character.
+ ((and intervals (eq (caar intervals) (cdar intervals))
+ (null (cdr intervals))
+ (null classes))
+ (let ((ch (caar intervals)))
(if negated
- (rx--translate-symbol 'anything)
- (rx--empty)))
- ;; Single non-negated character.
- ((and (null (cdr items))
- (consp (car items))
- (eq (caar items) (cdar items))
- (not negated))
- (cons (list (regexp-quote (char-to-string (caar items))))
- t))
- ;; Negated newline.
- ((and (equal items '((?\n . ?\n)))
- negated)
- (rx--translate-symbol 'nonl))
- ;; At least one character or class, possibly negated.
- (t
+ (if (eq ch ?\n)
+ ;; Single negated newline.
+ (rx--translate-symbol 'nonl)
+ ;; Single negated character (other than newline).
+ (cons (list (string ?\[ ?^ ch ?\])) t))
+ ;; Single literal character.
+ (cons (list (regexp-quote (char-to-string ch))) t))))
+
+ ;; Empty set (or any char).
+ ((and (null intervals) (null classes))
+ (if negated
+ (rx--translate-symbol 'anychar)
+ (rx--empty)))
+
+ ;; More than one character, or at least one class.
+ (t
+ (let ((dash nil) (caret nil))
+ ;; Move ] and range ]-x to the start.
+ (let ((rbrac-l (assq ?\] intervals)))
+ (when rbrac-l
+ (setq intervals (cons rbrac-l (remq rbrac-l intervals)))))
+
+ ;; Split x-] and move the lone ] to the start.
+ (let ((rbrac-r (rassq ?\] intervals)))
+ (when (and rbrac-r (not (eq (car rbrac-r) ?\])))
+ (setcdr rbrac-r ?\\)
+ (setq intervals (cons '(?\] . ?\]) intervals))))
+
+ ;; Split ,-- (which would end up as ,- otherwise).
+ (let ((dash-r (rassq ?- intervals)))
+ (when (eq (car dash-r) ?,)
+ (setcdr dash-r ?,)
+ (setq dash "-")))
+
+ ;; Remove - (lone or at start of interval)
+ (let ((dash-l (assq ?- intervals)))
+ (when dash-l
+ (if (eq (cdr dash-l) ?-)
+ (setq intervals (remq dash-l intervals)) ; Remove lone -
+ (setcar dash-l ?.)) ; Reduce --x to .-x
+ (setq dash "-")))
+
+ ;; Deal with leading ^ and range ^-x in non-negated set.
+ (when (and (eq (caar intervals) ?^)
+ (not negated))
+ (if (eq (cdar intervals) ?^)
+ ;; single leading ^
+ (if (or (cdr intervals) classes)
+ ;; something else to put before the ^
+ (progn
+ (setq intervals (cdr intervals)) ; remove lone ^
+ (setq caret "^")) ; put ^ (almost) last
+ ;; nothing else but a lone -
+ (setq intervals (cons '(?- . ?-) intervals)) ; move - first
+ (setq dash nil))
+ ;; split ^-x to _-x^
+ (setq intervals `((?_ . ,(cdar intervals)) (?^ . ?^)
+ . ,(cdr intervals)))))
+
(cons
(list
(concat
"["
(and negated "^")
- (mapconcat (lambda (item)
- (cond ((symbolp item)
- (format "[:%s:]" item))
- ((eq (car item) (cdr item))
- (char-to-string (car item)))
- ((eq (1+ (car item)) (cdr item))
- (string (car item) (cdr item)))
+ (mapconcat (lambda (iv)
+ (cond ((eq (car iv) (cdr iv))
+ (char-to-string (car iv)))
+ ((eq (1+ (car iv)) (cdr iv))
+ (string (car iv) (cdr iv)))
+ ;; Ranges that go between normal chars and raw bytes
+ ;; must be split to avoid being mutilated
+ ;; by Emacs's regexp parser.
+ ((<= (car iv) #x3fff7f (cdr iv))
+ (string (car iv) ?- #x3fff7f
+ #x3fff80 ?- (cdr iv)))
(t
- (string (car item) ?- (cdr item)))))
- items nil)
+ (string (car iv) ?- (cdr iv)))))
+ intervals)
+ (mapconcat (lambda (cls) (format "[:%s:]" cls)) classes)
+ caret ; ^ or nothing
+ dash ; - or nothing
"]"))
t)))))
+(defun rx--translate-char-alt (negated body)
+ "Translate a (rx--char-alt ...) construct. Return (REGEXP . PRECEDENCE).
+If NEGATED, negate the sense."
+ (rx--generate-alt negated (car body) (cdr body)))
+
(defun rx--translate-any (negated body)
"Translate an (any ...) construct. Return (REGEXP . PRECEDENCE).
If NEGATED, negate the sense."
(let ((parsed (rx--parse-any body)))
(rx--generate-alt negated (car parsed) (cdr parsed))))
-(defun rx--intervals-to-alt (negated intervals)
- "Generate a character alternative from an interval set.
-Return (REGEXP . PRECEDENCE).
-INTERVALS is a sorted list of disjoint intervals.
-If NEGATED, negate the sense."
- ;; Detect whether the interval set is better described in
- ;; complemented form. This is not just a matter of aesthetics: any
- ;; range from ASCII to raw bytes will automatically exclude the
- ;; entire non-ASCII Unicode range by the regexp engine.
- (if (rx--every (lambda (iv) (not (<= (car iv) #x3ffeff (cdr iv))))
- intervals)
- (rx--generate-alt negated intervals nil)
- (rx--generate-alt
- (not negated) (rx--complement-intervals intervals) nil)))
-
-;; FIXME: Consider turning `not' into a variadic operator, following SRE:
+;; TODO: Consider turning `not' into a variadic operator, following SRE:
;; (not A B) = (not (or A B)) = (intersection (not A) (not B)), and
;; (not) = anychar.
;; Maybe allow singleton characters as arguments.
@@ -527,43 +710,27 @@ If NEGATED, negate the sense."
If NEGATED, negate the sense (thus making it positive)."
(unless (and body (null (cdr body)))
(error "rx `not' form takes exactly one argument"))
- (let ((arg (car body)))
- (cond
- ((and (consp arg)
- (pcase (car arg)
- ((or 'any 'in 'char)
- (rx--translate-any (not negated) (cdr arg)))
- ('syntax
- (rx--translate-syntax (not negated) (cdr arg)))
- ('category
- (rx--translate-category (not negated) (cdr arg)))
- ('not
- (rx--translate-not (not negated) (cdr arg)))
- ((or 'or '|)
- (rx--translate-union (not negated) (cdr arg)))
- ('intersection
- (rx--translate-intersection (not negated) (cdr arg))))))
- ((let ((class (cdr (assq arg rx--char-classes))))
- (and class
- (rx--generate-alt (not negated) nil (list class)))))
- ((eq arg 'word-boundary)
- (rx--translate-symbol
- (if negated 'word-boundary 'not-word-boundary)))
- ((characterp arg)
- (rx--generate-alt (not negated) (list (cons arg arg)) nil))
- ((and (stringp arg) (= (length arg) 1))
- (let ((char (string-to-char arg)))
- (rx--generate-alt (not negated) (list (cons char char)) nil)))
- ((let ((expanded (rx--expand-def arg)))
- (and expanded
- (rx--translate-not negated (list expanded)))))
- (t (error "Illegal argument to rx `not': %S" arg)))))
-
-(defun rx--complement-intervals (intervals)
- "Complement of the interval list INTERVALS."
+ (let ((arg (rx--normalise-char-pattern (car body))))
+ (pcase arg
+ (`(not . ,args)
+ (rx--translate-not (not negated) args))
+ (`(syntax . ,args)
+ (rx--translate-syntax (not negated) args))
+ (`(category . ,args)
+ (rx--translate-category (not negated) args))
+ ('word-boundary ; legacy syntax
+ (rx--translate-symbol (if negated 'word-boundary 'not-word-boundary)))
+ (_ (let ((char (rx--reduce-to-char-alt arg)))
+ (if char
+ (rx--generate-alt (not negated) (car char) (cdr char))
+ (error "Illegal argument to rx `not': %S"
+ (rx--human-readable arg))))))))
+
+(defun rx--interval-set-complement (ivs)
+ "Complement of the interval set IVS."
(let ((compl nil)
(c 0))
- (dolist (iv intervals)
+ (dolist (iv ivs)
(when (< c (car iv))
(push (cons c (1- (car iv))) compl))
(setq c (1+ (cdr iv))))
@@ -571,8 +738,8 @@ If NEGATED, negate the sense (thus making it positive)."
(push (cons c (max-char)) compl))
(nreverse compl)))
-(defun rx--intersect-intervals (ivs-a ivs-b)
- "Intersection of the interval lists IVS-A and IVS-B."
+(defun rx--interval-set-intersection (ivs-a ivs-b)
+ "Intersection of the interval sets IVS-A and IVS-B."
(let ((isect nil))
(while (and ivs-a ivs-b)
(let ((a (car ivs-a))
@@ -594,60 +761,91 @@ If NEGATED, negate the sense (thus making it positive)."
ivs-a)))))))
(nreverse isect)))
-(defun rx--union-intervals (ivs-a ivs-b)
- "Union of the interval lists IVS-A and IVS-B."
- (rx--complement-intervals
- (rx--intersect-intervals
- (rx--complement-intervals ivs-a)
- (rx--complement-intervals ivs-b))))
-
-(defun rx--charset-intervals (charset)
- "Return a sorted list of non-adjacent disjoint intervals from CHARSET.
-CHARSET is any expression allowed in a character set expression:
-characters, single-char strings, `any' forms (no classes permitted),
-or `not', `or' or `intersection' forms whose arguments are charsets."
- (pcase charset
- (`(,(or 'any 'in 'char) . ,body)
- (let ((parsed (rx--parse-any body)))
- (when (cdr parsed)
- (error
- "Character class not permitted in set operations: %S"
- (cadr parsed)))
- (car parsed)))
- (`(not ,x) (rx--complement-intervals (rx--charset-intervals x)))
- (`(,(or 'or '|) . ,body) (rx--charset-union body))
- (`(intersection . ,body) (rx--charset-intersection body))
- ((pred characterp)
- (list (cons charset charset)))
- ((guard (and (stringp charset) (= (length charset) 1)))
- (let ((char (string-to-char charset)))
- (list (cons char char))))
- (_ (let ((expanded (rx--expand-def charset)))
- (if expanded
- (rx--charset-intervals expanded)
- (error "Bad character set: %S" charset))))))
-
-(defun rx--charset-union (charsets)
- "Union of CHARSETS, as a set of intervals."
- (rx--foldl #'rx--union-intervals nil
- (mapcar #'rx--charset-intervals charsets)))
-
-(defconst rx--charset-all (list (cons 0 (max-char))))
-
-(defun rx--charset-intersection (charsets)
- "Intersection of CHARSETS, as a set of intervals."
- (rx--foldl #'rx--intersect-intervals rx--charset-all
- (mapcar #'rx--charset-intervals charsets)))
-
-(defun rx--translate-union (negated body)
- "Translate an (or ...) construct of charsets. Return (REGEXP . PRECEDENCE).
-If NEGATED, negate the sense."
- (rx--intervals-to-alt negated (rx--charset-union body)))
+(defun rx--interval-set-union (ivs-a ivs-b)
+ "Union of the interval sets IVS-A and IVS-B."
+ (let ((union nil))
+ (while (and ivs-a ivs-b)
+ (let ((a (car ivs-a))
+ (b (car ivs-b)))
+ (cond
+ ((< (1+ (cdr a)) (car b)) ; a before b, not adacent
+ (push a union)
+ (setq ivs-a (cdr ivs-a)))
+ ((< (1+ (cdr b)) (car a)) ; b before a, not adacent
+ (push b union)
+ (setq ivs-b (cdr ivs-b)))
+ (t ; a and b adjacent or overlap
+ (setq ivs-a (cdr ivs-a))
+ (setq ivs-b (cdr ivs-b))
+ (if (< (cdr a) (cdr b))
+ (push (cons (min (car a) (car b))
+ (cdr b))
+ ivs-b)
+ (push (cons (min (car a) (car b))
+ (cdr a))
+ ivs-a))))))
+ (nconc (nreverse union) (or ivs-a ivs-b))))
+
+(defun rx--human-readable (form)
+ "Turn FORM into something that is more human-readable, for error messages."
+ ;; FIXME: Should we produce a string instead?
+ ;; That way we wouldn't have problems with ? and ??, and we could escape
+ ;; single chars.
+ ;; We could steal `xr--rx-to-string' and just file off the serials.
+ (let ((recurse (lambda (op skip)
+ (cons op (append (take skip (cdr form))
+ (mapcar #'rx--human-readable
+ (nthcdr skip (cdr form))))))))
+ (pcase form
+ ;; strings are more readable than numbers for single chars
+ ((pred characterp) (char-to-string form))
+ ;; resugar `rx--char-alt'
+ (`(rx--char-alt ((,c . ,c)) . nil)
+ (char-to-string form))
+ (`(rx--char-alt nil . (,class))
+ class)
+ ;; TODO: render in complemented form if more readable that way?
+ (`(rx--char-alt ,ivs . ,classes)
+ (let ((strings (mapcan (lambda (iv)
+ (let ((beg (car iv))
+ (end (cdr iv)))
+ (cond
+ ;; single char
+ ((eq beg end)
+ (list (string beg)))
+ ;; two chars
+ ((eq end (1+ beg))
+ (list (string beg) (string end)))
+ ;; first char is hyphen
+ ((eq beg ?-)
+ (cons (string "-")
+ (if (eq end (+ ?- 2))
+ (list (string (1+ ?-) end))
+ (list (string (1+ ?-) ?- end)))))
+ ;; other range
+ (t (list (string beg ?- end))))))
+ ivs)))
+ `(any ,@strings ,@classes)))
+ ;; avoid numbers as ops
+ (`(? . ,_) (funcall recurse '\? 0))
+ (`(?? . ,_) (funcall recurse '\?? 0))
+ ;; recurse on arguments
+ (`(repeat ,_ ,_) (funcall recurse (car form) 1))
+ (`(,(or '** 'repeat) . ,_) (funcall recurse (car form) 2))
+ (`(,(or '= '>= 'group-n 'submatch-n) . ,_) (funcall recurse (car form) 1))
+ (`(,(or 'backref 'syntax 'not-syntax 'category
+ 'eval 'regex 'regexp 'literal)
+ . ,_)
+ form)
+ (`(,_ . ,_) (funcall recurse (car form) 0))
+ (_ form))))
(defun rx--translate-intersection (negated body)
"Translate an (intersection ...) construct. Return (REGEXP . PRECEDENCE).
If NEGATED, negate the sense."
- (rx--intervals-to-alt negated (rx--charset-intersection body)))
+ (rx--generate-alt negated (rx--intersection-intervals
+ (mapcar #'rx--normalise-char-pattern body))
+ nil))
(defun rx--atomic-regexp (item)
"ITEM is (REGEXP . PRECEDENCE); return a regexp of precedence t."
@@ -783,7 +981,10 @@ Return (REGEXP . PRECEDENCE)."
(setq syntax char)))))))
(unless syntax
(error "Unknown rx syntax name `%s'" sym)))
- (cons (list (string ?\\ (if negated ?S ?s) syntax))
+ ;; Produce \w and \W instead of \sw and \Sw, for smaller size.
+ (cons (list (if (eq syntax ?w)
+ (string ?\\ (if negated ?W ?w))
+ (string ?\\ (if negated ?S ?s) syntax)))
t)))
(defconst rx--categories
@@ -894,15 +1095,15 @@ Return (REGEXP . PRECEDENCE)."
(opt "^")
(opt "]")
(* (or (seq "[:" (+ (any "a-z")) ":]")
- (not (any "]"))))
+ (not "]")))
"]")
(not (any "*+?^$[\\"))
(seq "\\"
- (or anything
- (seq (any "sScC_") anything)
+ (or anychar
+ (seq (any "sScC_") anychar)
(seq "("
- (* (or (not (any "\\"))
- (seq "\\" (not (any ")")))))
+ (* (or (not "\\")
+ (seq "\\" (not ")"))))
"\\)"))))
eos)
t)))
@@ -934,6 +1135,36 @@ DEF is the definition tuple. Return (REGEXP . PRECEDENCE)."
(error "The `%s' form did not expand to a string" (car form)))
(cons (list regexp) nil))))
+(defun rx--translate-compat-symbol-entry (entry)
+ "Translate a compatibility symbol definition for ENTRY.
+Return (REGEXP . PRECEDENCE) or nil if none."
+ (and (progn
+ (while (and entry (not (stringp (cdr entry))))
+ (setq entry
+ (if (symbolp (cdr entry))
+ ;; Alias for another entry.
+ (assq (cdr entry) rx-constituents)
+ ;; Wrong type, try further down the list.
+ (assq (car entry)
+ (cdr (memq entry rx-constituents))))))
+ entry)
+ (cons (list (cdr entry)) nil)))
+
+(defun rx--translate-compat-form-entry (orig-form entry)
+ "Translate a compatibility ORIG-FORM definition for ENTRY.
+Return (REGEXP . PRECEDENCE) or nil if none."
+ (and (progn
+ (while (and entry (not (consp (cdr entry))))
+ (setq entry
+ (if (symbolp (cdr entry))
+ ;; Alias for another entry.
+ (assq (cdr entry) rx-constituents)
+ ;; Wrong type, try further down the list.
+ (assq (car entry)
+ (cdr (memq entry rx-constituents))))))
+ entry)
+ (rx--translate-compat-form (cdr entry) orig-form)))
+
(defun rx--substitute (bindings form)
"Substitute BINDINGS in FORM. BINDINGS is an alist of (NAME . VALUES)
where VALUES is a list to splice into FORM wherever NAME occurs.
@@ -1029,6 +1260,7 @@ can expand to any number of values."
((or 'seq : 'and 'sequence) (rx--translate-seq body))
((or 'or '|) (rx--translate-or body))
((or 'any 'in 'char) (rx--translate-any nil body))
+ ('rx--char-alt (rx--translate-char-alt nil body))
('not-char (rx--translate-any t body))
('not (rx--translate-not nil body))
('intersection (rx--translate-intersection nil body))
@@ -1069,23 +1301,13 @@ can expand to any number of values."
(cond
((not (symbolp op)) (error "Bad rx operator `%S'" op))
- ((let ((expanded (rx--expand-def form)))
+ ((let ((expanded (rx--expand-def-form form)))
(and expanded
(rx--translate expanded))))
;; For compatibility with old rx.
((let ((entry (assq op rx-constituents)))
- (and (progn
- (while (and entry (not (consp (cdr entry))))
- (setq entry
- (if (symbolp (cdr entry))
- ;; Alias for another entry.
- (assq (cdr entry) rx-constituents)
- ;; Wrong type, try further down the list.
- (assq (car entry)
- (cdr (memq entry rx-constituents))))))
- entry)
- (rx--translate-compat-form (cdr entry) form))))
+ (and entry (rx--translate-compat-form-entry form entry))))
(t (error "Unknown rx form `%s'" op)))))))
@@ -1150,6 +1372,7 @@ If NO-GROUP is non-nil, don't bracket the result in a non-capturing
group.
For extending the `rx' notation in FORM, use `rx-define' or `rx-let-eval'."
+ (declare (important-return-value t))
(let* ((item (rx--translate form))
(exprs (if no-group
(car item)
diff --git a/lisp/emacs-lisp/seq.el b/lisp/emacs-lisp/seq.el
index 6c71b145a6e..a20cff16982 100644
--- a/lisp/emacs-lisp/seq.el
+++ b/lisp/emacs-lisp/seq.el
@@ -38,9 +38,6 @@
;; the sequence as their second argument. All other functions take
;; the sequence as their first argument.
;;
-;; While seq.el version 1.8 is in GNU ELPA for convenience, seq.el
-;; version 2.0 requires Emacs>=25.1.
-;;
;; seq.el can be extended to support new type of sequences. Here are
;; the generic functions that must be implemented by new seq types:
;; - `seq-elt'
@@ -51,11 +48,17 @@
;; - `seq-into-sequence'
;; - `seq-copy'
;; - `seq-into'
-;;
-;; All functions are tested in test/lisp/emacs-lisp/seq-tests.el
;;; Code:
+;; Note regarding the `seq' package on GNU ELPA:
+;;
+;; It was decided not to bother upgrading seq beyond 2.24 on GNU ELPA.
+;; The main purpose of the GNU ELPA package was to encourage adoption
+;; and accommodate changes more easily, but it's mature enough that
+;; changes are fairly slow. Thus, we can now rely on "the usual"
+;; solutions to deal with compatibility issues. (Bug#60990)
+
(eval-when-compile (require 'cl-generic))
;; We used to use some sequence functions from cl-lib, but this
@@ -359,8 +362,7 @@ the result.
The result is a sequence of the same type as SEQUENCE."
(seq-concatenate
- (let ((type (type-of sequence)))
- (if (eq type 'cons) 'list type))
+ (if (listp sequence) 'list (type-of sequence))
(seq-subseq sequence 0 n)
(seq-subseq sequence (1+ n))))
@@ -616,12 +618,12 @@ SEQUENCE must be a sequence of numbers or markers."
(unless rest-marker
(pcase name
(`&rest
- (progn (push `(app (pcase--flip seq-drop ,index)
+ (progn (push `(app (seq-drop _ ,index)
,(seq--elt-safe args (1+ index)))
bindings)
(setq rest-marker t)))
(_
- (push `(app (pcase--flip seq--elt-safe ,index) ,name) bindings))))
+ (push `(app (seq--elt-safe _ ,index) ,name) bindings))))
(setq index (1+ index)))
bindings))
diff --git a/lisp/emacs-lisp/shortdoc.el b/lisp/emacs-lisp/shortdoc.el
index fdba6d32418..a1e49b50510 100644
--- a/lisp/emacs-lisp/shortdoc.el
+++ b/lisp/emacs-lisp/shortdoc.el
@@ -51,6 +51,17 @@
"Face used for a section.")
;;;###autoload
+(defun shortdoc--check (group functions)
+ (let ((keywords '( :no-manual :args :eval :no-eval :no-value :no-eval*
+ :result :result-string :eg-result :eg-result-string :doc)))
+ (dolist (f functions)
+ (when (consp f)
+ (dolist (x f)
+ (when (and (keywordp x) (not (memq x keywords)))
+ (error "Shortdoc %s function `%s': bad keyword `%s'"
+ group (car f) x)))))))
+
+;;;###autoload
(progn
(defvar shortdoc--groups nil)
@@ -118,6 +129,7 @@ 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))
+ (shortdoc--check group functions)
`(progn
(setq shortdoc--groups (delq (assq ',group shortdoc--groups)
shortdoc--groups))
@@ -137,11 +149,11 @@ A FUNC form can have any number of `:no-eval' (or `:no-value'),
:eval (assoc-string "foo" '(("foo" . "bar") ("zot" "baz"))))
"Manipulating Alists"
(assoc-delete-all
- :eval (assoc-delete-all "foo" '(("foo" . "bar") ("zot" . "baz")) #'equal))
+ :eval (assoc-delete-all "b" (list '("a" . a) '("b" . b) '("b" . c))))
(assq-delete-all
- :eval (assq-delete-all 'foo '((foo . bar) (zot . baz))))
+ :eval (assq-delete-all 2 (list '(1 . a) '(2 . b) '(2 . c))))
(rassq-delete-all
- :eval (rassq-delete-all 'bar '((foo . bar) (zot . baz))))
+ :eval (rassq-delete-all 'b (list '(1 . a) '(2 . b) '(2 . c))))
(alist-get
:eval (let ((foo '((bar . baz))))
(setf (alist-get 'bar foo) 'zot)
@@ -153,14 +165,14 @@ A FUNC form can have any number of `:no-eval' (or `:no-value'),
:eval (let* ((old '((foo . bar)))
(new (copy-alist old)))
(eq old new)))
- ;; FIXME: Outputs "\.rose" for the symbol `.rose'.
- ;; (let-alist
- ;; :eval (let ((colors '((rose . red)
- ;; (lily . white))))
- ;; (let-alist colors
- ;; (if (eq .rose 'red)
- ;; .lily))))
- )
+ ;; FIXME: Outputs "\.rose" for the symbol `.rose'. It would be
+ ;; better if that could be cleaned up.
+ (let-alist
+ :eval (let ((colors '((rose . red)
+ (lily . white))))
+ (let-alist colors
+ (if (eq .rose 'red)
+ .lily)))))
(define-short-documentation-group string
"Making Strings"
@@ -572,10 +584,7 @@ A FUNC form can have any number of `:no-eval' (or `:no-value'),
:result-string "#s(hash-table ...)")
(hash-table-count
:no-eval (hash-table-count table)
- :eg-result 15)
- (hash-table-size
- :no-eval (hash-table-size table)
- :eg-result 65))
+ :eg-result 15))
(define-short-documentation-group list
"Making Lists"
@@ -642,6 +651,8 @@ A FUNC form can have any number of `:no-eval' (or `:no-value'),
(delete
:eval (delete 2 (list 1 2 3 4))
:eval (delete "a" (list "a" "b" "c" "d")))
+ (remq
+ :eval (remq 'b '(a b c)))
(remove
:eval (remove 2 '(1 2 3 4))
:eval (remove "a" '("a" "b" "c" "d")))
@@ -686,8 +697,6 @@ A FUNC form can have any number of `:no-eval' (or `:no-value'),
(member
:eval (member 2 '(1 2 3))
:eval (member "b" '("a" "b" "c")))
- (remq
- :eval (remq 'b '(a b c)))
(member-ignore-case
:eval (member-ignore-case "foo" '("bar" "Foo" "zot")))
"Association Lists"
@@ -707,16 +716,18 @@ A FUNC form can have any number of `:no-eval' (or `:no-value'),
:eval (assoc-default 2 '((1 . a) (2 . b) #'=)))
(copy-alist
:eval (copy-alist '((1 . a) (2 . b))))
- (assq-delete-all
- :eval (assq-delete-all 2 (list '(1 . a) '(2 . b) '(2 . c))))
(assoc-delete-all
:eval (assoc-delete-all "b" (list '("a" . a) '("b" . b) '("b" . c))))
+ (assq-delete-all
+ :eval (assq-delete-all 2 (list '(1 . a) '(2 . b) '(2 . c))))
+ (rassq-delete-all
+ :eval (rassq-delete-all 'b (list '(1 . a) '(2 . b) '(2 . c))))
"Property Lists"
(plist-get
:eval (plist-get '(a 1 b 2 c 3) 'b))
(plist-put
:no-eval (setq plist (plist-put plist 'd 4))
- :eq-result (a 1 b 2 c 3 d 4))
+ :eg-result (a 1 b 2 c 3 d 4))
(plist-member
:eval (plist-member '(a 1 b 2 c 3) 'b))
"Data About Lists"
@@ -736,9 +747,13 @@ A FUNC form can have any number of `:no-eval' (or `:no-value'),
(intern
:eval (intern "abc"))
(intern-soft
+ :eval (intern-soft "list")
:eval (intern-soft "Phooey!"))
(make-symbol
:eval (make-symbol "abc"))
+ (gensym
+ :no-eval (gensym)
+ :eg-result g37)
"Comparing symbols"
(eq
:eval (eq 'abc 'abc)
@@ -749,7 +764,20 @@ A FUNC form can have any number of `:no-eval' (or `:no-value'),
:eval (equal 'abc 'abc))
"Name"
(symbol-name
- :eval (symbol-name 'abc)))
+ :eval (symbol-name 'abc))
+ "Obarrays"
+ (obarray-make
+ :eval (obarray-make))
+ (obarrayp
+ :eval (obarrayp (obarray-make))
+ :eval (obarrayp nil))
+ (unintern
+ :no-eval (unintern "abc" my-obarray)
+ :eg-result t)
+ (mapatoms
+ :no-eval (mapatoms (lambda (symbol) (print symbol)) my-obarray))
+ (obarray-clear
+ :no-eval (obarray-clear my-obarray)))
(define-short-documentation-group comparison
"General-purpose"
@@ -835,6 +863,8 @@ A FUNC form can have any number of `:no-eval' (or `:no-value'),
(seq-subseq
:eval (seq-subseq [1 2 3 4 5] 1 3)
:eval (seq-subseq [1 2 3 4 5] 1))
+ (copy-tree
+ :eval (copy-tree [1 (2 3) [4 5]] t))
"Mapping Over Vectors"
(mapcar
:eval (mapcar #'identity [1 2 3]))
@@ -1446,45 +1476,52 @@ If SAME-WINDOW, don't pop to a new window."
(setq group (intern group)))
(unless (assq group shortdoc--groups)
(error "No such documentation group %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)
- (shortdoc-mode)
- (button-mode)
- (mapc
- (lambda (data)
- (cond
- ((stringp data)
- (setq prev nil)
- (unless (bobp)
- (insert "\n"))
- (insert (propertize
- (substitute-command-keys data)
- 'face 'shortdoc-heading
- 'shortdoc-section t
- 'outline-level 1))
- (insert (propertize
- "\n\n"
- 'face 'shortdoc-heading
- 'shortdoc-section t)))
- ;; There may be functions not yet defined in the data.
- ((fboundp (car data))
- (when prev
- (insert (make-separator-line)
- ;; This helps with hidden outlines (bug#53981)
- (propertize "\n" 'face '(:height 0))))
- (setq prev t)
- (shortdoc--display-function data))))
- (cdr (assq group shortdoc--groups))))
+ (let ((buf (get-buffer-create (format "*Shortdoc %s*" group))))
+ (shortdoc--insert-group-in-buffer group buf)
+ (funcall (if same-window
+ #'pop-to-buffer-same-window
+ #'pop-to-buffer)
+ buf))
(goto-char (point-min))
(when function
(text-property-search-forward 'shortdoc-function function t)
(beginning-of-line)))
+(defun shortdoc--insert-group-in-buffer (group &optional buf)
+ "Insert a short documentation summary for functions in GROUP in buffer BUF.
+BUF defaults to the current buffer if nil or omitted."
+ (with-current-buffer (or buf (current-buffer))
+ (let ((inhibit-read-only t)
+ (prev nil))
+ (erase-buffer)
+ (shortdoc-mode)
+ (button-mode)
+ (mapc
+ (lambda (data)
+ (cond
+ ((stringp data)
+ (setq prev nil)
+ (unless (bobp)
+ (insert "\n"))
+ (insert (propertize
+ (substitute-command-keys data)
+ 'face 'shortdoc-heading
+ 'shortdoc-section t
+ 'outline-level 1))
+ (insert (propertize
+ "\n\n"
+ 'face 'shortdoc-heading
+ 'shortdoc-section t)))
+ ;; There may be functions not yet defined in the data.
+ ((fboundp (car data))
+ (when prev
+ (insert (make-separator-line)
+ ;; This helps with hidden outlines (bug#53981)
+ (propertize "\n" 'face '(:height 0))))
+ (setq prev t)
+ (shortdoc--display-function data))))
+ (cdr (assq group shortdoc--groups))))))
+
;;;###autoload
(defalias 'shortdoc #'shortdoc-display-group)
@@ -1524,7 +1561,8 @@ function's documentation in the Info manual"))
"=>"))
(single-arrow (if (char-displayable-p ?→)
"→"
- "->")))
+ "->"))
+ (start-example (point)))
(cl-loop for (type value) on data by #'cddr
do
(cl-case type
@@ -1575,7 +1613,8 @@ function's documentation in the Info manual"))
(:eg-result-string
(insert " e.g. " double-arrow " ")
(princ value (current-buffer))
- (insert "\n")))))
+ (insert "\n"))))
+ (add-text-properties start-example (point) `(shortdoc-example ,function)))
;; Insert the arglist after doing the evals, in case that's pulled
;; in the function definition.
(save-excursion
@@ -1585,6 +1624,73 @@ function's documentation in the Info manual"))
(insert " " (symbol-name param)))
(add-face-text-property arglist-start (point) 'shortdoc-section t))))
+(defun shortdoc-function-examples (function)
+ "Return all shortdoc examples for FUNCTION.
+The result is an alist with items of the form (GROUP . EXAMPLES),
+where GROUP is a shortdoc group where FUNCTION appears, and
+EXAMPLES is a string with the usage examples of FUNCTION defined
+in GROUP. Return nil if FUNCTION is not a function or if it
+doesn't has any shortdoc information."
+ (let ((groups (and (symbolp function)
+ (shortdoc-function-groups function)))
+ (examples nil))
+ (mapc
+ (lambda (group)
+ (with-temp-buffer
+ (shortdoc--insert-group-in-buffer group)
+ (goto-char (point-min))
+ (let ((match (text-property-search-forward
+ 'shortdoc-example function t)))
+ (push `(,group . ,(string-trim
+ (buffer-substring-no-properties
+ (prop-match-beginning match)
+ (prop-match-end match))))
+ examples))))
+ groups)
+ examples))
+
+(defun shortdoc-help-fns-examples-function (function)
+ "Insert Emacs Lisp examples for FUNCTION into the current buffer.
+You can add this function to the `help-fns-describe-function-functions'
+hook to show examples of using FUNCTION in *Help* buffers produced
+by \\[describe-function]."
+ (let* ((examples (shortdoc-function-examples function))
+ (num-examples (length examples))
+ (times 0))
+ (dolist (example examples)
+ (when (zerop times)
+ (if (> num-examples 1)
+ (insert "\n Examples:\n\n")
+ ;; Some functions have more than one example per group.
+ ;; Count the number of arrows to know if we need to
+ ;; pluralize "Example".
+ (let* ((text (cdr example))
+ (count 0)
+ (pos 0)
+ (end (length text))
+ (double-arrow (if (char-displayable-p ?⇒)
+ " ⇒"
+ " =>"))
+ (double-arrow-example (if (char-displayable-p ?⇒)
+ " e.g. ⇒"
+ " e.g. =>"))
+ (single-arrow (if (char-displayable-p ?→)
+ " →"
+ " ->")))
+ (while (and (< pos end)
+ (or (string-match double-arrow text pos)
+ (string-match double-arrow-example text pos)
+ (string-match single-arrow text pos)))
+ (setq count (1+ count)
+ pos (match-end 0)))
+ (if (> count 1)
+ (insert "\n Examples:\n\n")
+ (insert "\n Example:\n\n")))))
+ (setq times (1+ times))
+ (insert " ")
+ (insert (cdr example))
+ (insert "\n\n"))))
+
(defun shortdoc-function-groups (function)
"Return all shortdoc groups FUNCTION appears in."
(cl-loop for group in shortdoc--groups
diff --git a/lisp/emacs-lisp/shorthands.el b/lisp/emacs-lisp/shorthands.el
index b1d89ccc4b8..379fb0baec9 100644
--- a/lisp/emacs-lisp/shorthands.el
+++ b/lisp/emacs-lisp/shorthands.el
@@ -52,27 +52,26 @@
:version "28.1"
:group 'font-lock-faces)
-(defun shorthands--mismatch-from-end (str1 str2)
- (cl-loop with l1 = (length str1) with l2 = (length str2)
- for i from 1
- for i1 = (- l1 i) for i2 = (- l2 i)
- while (and (>= i1 0) (>= i2 0) (eq (aref str1 i1) (aref str2 i2)))
- finally (return (1- i))))
-
(defun shorthands-font-lock-shorthands (limit)
+ "Font lock until LIMIT considering `read-symbol-shorthands'."
(when read-symbol-shorthands
(while (re-search-forward
(concat "\\_<\\(" (rx lisp-mode-symbol) "\\)\\_>")
limit t)
(let* ((existing (get-text-property (match-beginning 1) 'face))
+ (print-name (match-string 1))
(probe (and (not (memq existing '(font-lock-comment-face
font-lock-string-face)))
- (intern-soft (match-string 1))))
- (sname (and probe (symbol-name probe)))
- (mm (and sname (shorthands--mismatch-from-end
- (match-string 1) sname))))
- (unless (or (null mm) (= mm (length sname)))
- (add-face-text-property (match-beginning 1) (1+ (- (match-end 1) mm))
+ (intern-soft print-name)))
+ (symbol-name (and probe (symbol-name probe)))
+ (prefix (and symbol-name
+ (not (string-equal print-name symbol-name))
+ (car (assoc print-name
+ read-symbol-shorthands
+ #'string-prefix-p)))))
+ (when prefix
+ (add-face-text-property (match-beginning 1)
+ (+ (match-beginning 1) (length prefix))
'elisp-shorthand-font-lock-face))))))
(font-lock-add-keywords 'emacs-lisp-mode '((shorthands-font-lock-shorthands)) t)
diff --git a/lisp/emacs-lisp/smie.el b/lisp/emacs-lisp/smie.el
index 178ce09df09..c5eea4b3427 100644
--- a/lisp/emacs-lisp/smie.el
+++ b/lisp/emacs-lisp/smie.el
@@ -56,8 +56,8 @@
;; which includes a kind of tutorial to get started with SMIE:
;;
;; SMIE: Weakness is Power! Auto-indentation with incomplete information
-;; Stefan Monnier, <Programming> Journal 2020, volume 5, issue 1.
-;; doi: 10.22152/programming-journal.org/2021/5/1
+;; Stefan Monnier, <Programming> Journal 2021, volume 5, issue 1.
+;; doi: https://doi.org/10.22152/programming-journal.org/2021/5/1
;; A good background to understand the development (especially the parts
;; building the 2D precedence tables and then computing the precedence levels
diff --git a/lisp/emacs-lisp/subr-x.el b/lisp/emacs-lisp/subr-x.el
index 3c3d7dd96c2..699be767ee7 100644
--- a/lisp/emacs-lisp/subr-x.el
+++ b/lisp/emacs-lisp/subr-x.el
@@ -81,18 +81,22 @@ Note how the single `-' got converted into a list before
threading."
(declare (indent 0) (debug thread-first))
`(internal--thread-argument nil ,@forms))
+
(defsubst hash-table-empty-p (hash-table)
"Check whether HASH-TABLE is empty (has 0 elements)."
+ (declare (side-effect-free t))
(zerop (hash-table-count hash-table)))
(defsubst hash-table-keys (hash-table)
"Return a list of keys in HASH-TABLE."
+ (declare (side-effect-free t))
(let ((keys nil))
(maphash (lambda (k _) (push k keys)) hash-table)
keys))
(defsubst hash-table-values (hash-table)
"Return a list of values in HASH-TABLE."
+ (declare (side-effect-free t))
(let ((values nil))
(maphash (lambda (_ v) (push v values)) hash-table)
values))
@@ -102,6 +106,7 @@ threading."
"Join all STRINGS using SEPARATOR.
Optional argument SEPARATOR must be a string, a vector, or a list of
characters; nil stands for the empty string."
+ (declare (pure t) (side-effect-free t))
(mapconcat #'identity strings separator))
(define-obsolete-function-alias 'string-reverse 'reverse "25.1")
@@ -112,6 +117,7 @@ characters; nil stands for the empty string."
When truncating, \"...\" is always prepended to the string, so
the resulting string may be longer than the original if LENGTH is
3 or smaller."
+ (declare (pure t) (side-effect-free t))
(let ((strlen (length string)))
(if (<= strlen length)
string
@@ -124,16 +130,19 @@ the resulting string may be longer than the original if LENGTH is
"Check whether STRING is either empty or only whitespace.
The following characters count as whitespace here: space, tab, newline and
carriage return."
+ (declare (pure t) (side-effect-free t))
(string-match-p "\\`[ \t\n\r]*\\'" string))
(defsubst string-remove-prefix (prefix string)
"Remove PREFIX from STRING if present."
+ (declare (pure t) (side-effect-free t))
(if (string-prefix-p prefix string)
(substring string (length prefix))
string))
(defsubst string-remove-suffix (suffix string)
"Remove SUFFIX from STRING if present."
+ (declare (pure t) (side-effect-free t))
(if (string-suffix-p suffix string)
(substring string 0 (- (length string) (length suffix)))
string))
@@ -144,6 +153,7 @@ carriage return."
All sequences of whitespaces in STRING are collapsed into a
single space character, and leading/trailing whitespace is
removed."
+ (declare (important-return-value t))
(let ((blank "[[:blank:]\r\n]+"))
(string-trim (replace-regexp-in-string blank " " string t t)
blank blank)))
@@ -153,6 +163,7 @@ removed."
Wrapping is done where there is whitespace. If there are
individual words in STRING that are longer than LENGTH, the
result will have lines that are longer than LENGTH."
+ (declare (important-return-value t))
(with-temp-buffer
(insert string)
(goto-char (point-min))
@@ -184,6 +195,7 @@ coding system that doesn't specify a BOM, like `utf-16le' or `utf-16be'.
When shortening strings for display purposes,
`truncate-string-to-width' is almost always a better alternative
than this function."
+ (declare (important-return-value t))
(unless (natnump length)
(signal 'wrong-type-argument (list 'natnump length)))
(if coding-system
@@ -252,6 +264,7 @@ is done.
If START is nil (or not present), the padding is done to the end
of the string, and if non-nil, padding is done to the start of
the string."
+ (declare (pure t) (side-effect-free t))
(unless (natnump length)
(signal 'wrong-type-argument (list 'natnump length)))
(let ((pad-length (- length (length string))))
@@ -261,6 +274,7 @@ the string."
(defun string-chop-newline (string)
"Remove the final newline (if any) from STRING."
+ (declare (pure t) (side-effect-free t))
(string-remove-suffix "\n" string))
(defun replace-region-contents (beg end replace-fn
@@ -298,9 +312,13 @@ it makes no sense to convert it to a string using
Like `let', bind variables in BINDINGS and then evaluate BODY,
but with the twist that BODY can evaluate itself recursively by
calling NAME, where the arguments passed to NAME are used
-as the new values of the bound variables in the recursive invocation."
+as the new values of the bound variables in the recursive invocation.
+
+This construct can only be used with lexical binding."
(declare (indent 2) (debug (symbolp (&rest (symbolp form)) body)))
(require 'cl-lib)
+ (unless lexical-binding
+ (error "`named-let' requires lexical binding"))
(let ((fargs (mapcar (lambda (b) (if (consp b) (car b) b)) bindings))
(aargs (mapcar (lambda (b) (if (consp b) (cadr b))) bindings)))
;; According to the Scheme semantics of named let, `name' is not in scope
@@ -317,6 +335,7 @@ as the new values of the bound variables in the recursive invocation."
;;;###autoload
(defun string-pixel-width (string)
"Return the width of STRING in pixels."
+ (declare (important-return-value t))
(if (zerop (length string))
0
;; Keeping a work buffer around is more efficient than creating a
@@ -339,6 +358,7 @@ This takes into account combining characters and grapheme clusters:
if compositions are enabled, each sequence of characters composed
on display into a single grapheme cluster is treated as a single
indivisible unit."
+ (declare (side-effect-free t))
(let ((result nil)
(start 0)
comp)
diff --git a/lisp/emacs-lisp/syntax.el b/lisp/emacs-lisp/syntax.el
index e09063b638a..e8eb8598fd0 100644
--- a/lisp/emacs-lisp/syntax.el
+++ b/lisp/emacs-lisp/syntax.el
@@ -248,12 +248,14 @@ some parts of the text or may be applied several times to other parts.
Note: There may be at most nine back-references in the REGEXPs of
all RULES in total."
- (declare (debug (&rest &or symbolp ;FIXME: edebug this eval step.
- (form &rest
- (numberp
- [&or stringp ;FIXME: Use &wrap
- ("prog1" [&or stringp def-form] def-body)
- def-form])))))
+ (declare
+ (debug (&rest &or symbolp ;FIXME: edebug this eval step.
+ (def-form ;; `def-' needed to debug during macroexpansion.
+ &rest (numberp
+ [&or stringp ;FIXME: Use &wrap
+ ;; `def-' because this is the body of a function.
+ ("prog1" [&or stringp def-form] def-body)
+ def-form])))))
(let ((newrules nil))
(while rules
(if (symbolp (car rules))
@@ -615,150 +617,150 @@ running the hook."
(syntax-propertize pos)
;;
(with-syntax-table (or syntax-ppss-table (syntax-table))
- (let* ((cell (syntax-ppss--data))
- (ppss-last (car cell))
- (ppss-cache (cdr cell))
- (old-ppss (cdr ppss-last))
- (old-pos (car ppss-last))
- (ppss nil)
- (pt-min (point-min)))
- (if (and old-pos (> old-pos pos)) (setq old-pos nil))
- ;; Use the OLD-POS if usable and close. Don't update the `last' cache.
- (condition-case nil
- (if (and old-pos (< (- pos old-pos)
- ;; The time to use syntax-begin-function and
- ;; find PPSS is assumed to be about 2 * distance.
- (let ((pair (aref syntax-ppss-stats 5)))
- (/ (* 2 (cdr pair)) (car pair)))))
- (progn
- (syntax-ppss--update-stats 0 old-pos pos)
- (parse-partial-sexp old-pos pos nil nil old-ppss))
-
- (cond
- ;; Use OLD-PPSS if possible and close enough.
- ((and (not old-pos) old-ppss
- ;; If `pt-min' is too far from `pos', we could try to use
- ;; other positions in (nth 9 old-ppss), but that doesn't
- ;; seem to happen in practice and it would complicate this
- ;; code (and the before-change-function code even more).
- ;; But maybe it would be useful in "degenerate" cases such
- ;; as when the whole file is wrapped in a set
- ;; of parentheses.
- (setq pt-min (or (syntax-ppss-toplevel-pos old-ppss)
- (nth 2 old-ppss)))
- (<= pt-min pos) (< (- pos pt-min) syntax-ppss-max-span))
- (syntax-ppss--update-stats 1 pt-min pos)
- (setq ppss (parse-partial-sexp pt-min pos)))
- ;; The OLD-* data can't be used. Consult the cache.
- (t
- (let ((cache-pred nil)
- (cache ppss-cache)
- (pt-min (point-min))
- ;; I differentiate between PT-MIN and PT-BEST because
- ;; I feel like it might be important to ensure that the
- ;; cache is only filled with 100% sure data (whereas
- ;; syntax-begin-function might return incorrect data).
- ;; Maybe that's just stupid.
- (pt-best (point-min))
- (ppss-best nil))
- ;; look for a usable cache entry.
- (while (and cache (< pos (caar cache)))
- (setq cache-pred cache)
- (setq cache (cdr cache)))
- (if cache (setq pt-min (caar cache) ppss (cdar cache)))
-
- ;; Setup the before-change function if necessary.
- (unless (or ppss-cache ppss-last)
- ;; Note: combine-change-calls-1 needs to be kept in sync
- ;; with this!
- (add-hook 'before-change-functions
- #'syntax-ppss-flush-cache
- ;; We should be either the very last function on
- ;; before-change-functions or the very first on
- ;; after-change-functions.
- 99 t))
-
- ;; Use the best of OLD-POS and CACHE.
- (if (or (not old-pos) (< old-pos pt-min))
- (setq pt-best pt-min ppss-best ppss)
- (syntax-ppss--update-stats 4 old-pos pos)
- (setq pt-best old-pos ppss-best old-ppss))
-
- ;; Use the `syntax-begin-function' if available.
- ;; We could try using that function earlier, but:
- ;; - The result might not be 100% reliable, so it's better to use
- ;; the cache if available.
- ;; - The function might be slow.
- ;; - If this function almost always finds a safe nearby spot,
- ;; the cache won't be populated, so consulting it is cheap.
- (when (and syntax-begin-function
- (progn (goto-char pos)
- (funcall syntax-begin-function)
- ;; Make sure it's better.
- (> (point) pt-best))
- ;; Simple sanity checks.
- (< (point) pos) ; backward-paragraph can fail here.
- (not (memq (get-text-property (point) 'face)
- '(font-lock-string-face font-lock-doc-face
- font-lock-comment-face))))
- (syntax-ppss--update-stats 5 (point) pos)
- (setq pt-best (point) ppss-best nil))
-
- (cond
- ;; Quick case when we found a nearby pos.
- ((< (- pos pt-best) syntax-ppss-max-span)
- (syntax-ppss--update-stats 2 pt-best pos)
- (setq ppss (parse-partial-sexp pt-best pos nil nil ppss-best)))
- ;; Slow case: compute the state from some known position and
- ;; populate the cache so we won't need to do it again soon.
- (t
- (syntax-ppss--update-stats 3 pt-min pos)
- (setq syntax-ppss--updated-cache t)
-
- ;; If `pt-min' is too far, add a few intermediate entries.
- (while (> (- pos pt-min) (* 2 syntax-ppss-max-span))
- (setq ppss (parse-partial-sexp
- pt-min (setq pt-min (/ (+ pt-min pos) 2))
- nil nil ppss))
- (push (cons pt-min ppss)
- (if cache-pred (cdr cache-pred) ppss-cache)))
-
- ;; Compute the actual return value.
- (setq ppss (parse-partial-sexp pt-min pos nil nil ppss))
-
- ;; Debugging check.
- ;; (let ((real-ppss (parse-partial-sexp (point-min) pos)))
- ;; (setcar (last ppss 4) 0)
- ;; (setcar (last real-ppss 4) 0)
- ;; (setcar (last ppss 8) nil)
- ;; (setcar (last real-ppss 8) nil)
- ;; (unless (equal ppss real-ppss)
- ;; (message "!!Syntax: %s != %s" ppss real-ppss)
- ;; (setq ppss real-ppss)))
-
- ;; Store it in the cache.
- (let ((pair (cons pos ppss)))
- (if cache-pred
- (if (> (- (caar cache-pred) pos) syntax-ppss-max-span)
- (push pair (cdr cache-pred))
- (setcar cache-pred pair))
- (if (or (null ppss-cache)
- (> (- (caar ppss-cache) pos)
- syntax-ppss-max-span))
- (push pair ppss-cache)
- (setcar ppss-cache pair)))))))))
-
- (setq syntax-ppss--updated-cache t)
- (setq ppss-last (cons pos ppss))
- (setcar cell ppss-last)
- (setcdr cell ppss-cache)
- ppss)
- (args-out-of-range
- ;; If the buffer is more narrowed than when we built the cache,
- ;; we may end up calling parse-partial-sexp with a position before
- ;; point-min. In that case, just parse from point-min assuming
- ;; a nil state.
- (parse-partial-sexp (point-min) pos))))))
+ (let* ((cell (syntax-ppss--data))
+ (ppss-last (car cell))
+ (ppss-cache (cdr cell))
+ (old-ppss (cdr ppss-last))
+ (old-pos (car ppss-last))
+ (ppss nil)
+ (pt-min (point-min)))
+ (if (and old-pos (> old-pos pos)) (setq old-pos nil))
+ ;; Use the OLD-POS if usable and close. Don't update the `last' cache.
+ (condition-case nil
+ (if (and old-pos (< (- pos old-pos)
+ ;; The time to use syntax-begin-function and
+ ;; find PPSS is assumed to be about 2 * distance.
+ (let ((pair (aref syntax-ppss-stats 5)))
+ (/ (* 2 (cdr pair)) (car pair)))))
+ (progn
+ (syntax-ppss--update-stats 0 old-pos pos)
+ (parse-partial-sexp old-pos pos nil nil old-ppss))
+
+ (cond
+ ;; Use OLD-PPSS if possible and close enough.
+ ((and (not old-pos) old-ppss
+ ;; If `pt-min' is too far from `pos', we could try to use
+ ;; other positions in (nth 9 old-ppss), but that doesn't
+ ;; seem to happen in practice and it would complicate this
+ ;; code (and the before-change-function code even more).
+ ;; But maybe it would be useful in "degenerate" cases such
+ ;; as when the whole file is wrapped in a set
+ ;; of parentheses.
+ (setq pt-min (or (syntax-ppss-toplevel-pos old-ppss)
+ (nth 2 old-ppss)))
+ (<= pt-min pos) (< (- pos pt-min) syntax-ppss-max-span))
+ (syntax-ppss--update-stats 1 pt-min pos)
+ (setq ppss (parse-partial-sexp pt-min pos)))
+ ;; The OLD-* data can't be used. Consult the cache.
+ (t
+ (let ((cache-pred nil)
+ (cache ppss-cache)
+ (pt-min (point-min))
+ ;; I differentiate between PT-MIN and PT-BEST because
+ ;; I feel like it might be important to ensure that the
+ ;; cache is only filled with 100% sure data (whereas
+ ;; syntax-begin-function might return incorrect data).
+ ;; Maybe that's just stupid.
+ (pt-best (point-min))
+ (ppss-best nil))
+ ;; look for a usable cache entry.
+ (while (and cache (< pos (caar cache)))
+ (setq cache-pred cache)
+ (setq cache (cdr cache)))
+ (if cache (setq pt-min (caar cache) ppss (cdar cache)))
+
+ ;; Setup the before-change function if necessary.
+ (unless (or ppss-cache ppss-last)
+ ;; Note: combine-change-calls-1 needs to be kept in sync
+ ;; with this!
+ (add-hook 'before-change-functions
+ #'syntax-ppss-flush-cache
+ ;; We should be either the very last function on
+ ;; before-change-functions or the very first on
+ ;; after-change-functions.
+ 99 t))
+
+ ;; Use the best of OLD-POS and CACHE.
+ (if (or (not old-pos) (< old-pos pt-min))
+ (setq pt-best pt-min ppss-best ppss)
+ (syntax-ppss--update-stats 4 old-pos pos)
+ (setq pt-best old-pos ppss-best old-ppss))
+
+ ;; Use the `syntax-begin-function' if available.
+ ;; We could try using that function earlier, but:
+ ;; - The result might not be 100% reliable, so it's better to use
+ ;; the cache if available.
+ ;; - The function might be slow.
+ ;; - If this function almost always finds a safe nearby spot,
+ ;; the cache won't be populated, so consulting it is cheap.
+ (when (and syntax-begin-function
+ (progn (goto-char pos)
+ (funcall syntax-begin-function)
+ ;; Make sure it's better.
+ (> (point) pt-best))
+ ;; Simple sanity checks.
+ (< (point) pos) ; backward-paragraph can fail here.
+ (not (memq (get-text-property (point) 'face)
+ '(font-lock-string-face font-lock-doc-face
+ font-lock-comment-face))))
+ (syntax-ppss--update-stats 5 (point) pos)
+ (setq pt-best (point) ppss-best nil))
+
+ (cond
+ ;; Quick case when we found a nearby pos.
+ ((< (- pos pt-best) syntax-ppss-max-span)
+ (syntax-ppss--update-stats 2 pt-best pos)
+ (setq ppss (parse-partial-sexp pt-best pos nil nil ppss-best)))
+ ;; Slow case: compute the state from some known position and
+ ;; populate the cache so we won't need to do it again soon.
+ (t
+ (syntax-ppss--update-stats 3 pt-min pos)
+ (setq syntax-ppss--updated-cache t)
+
+ ;; If `pt-min' is too far, add a few intermediate entries.
+ (while (> (- pos pt-min) (* 2 syntax-ppss-max-span))
+ (setq ppss (parse-partial-sexp
+ pt-min (setq pt-min (/ (+ pt-min pos) 2))
+ nil nil ppss))
+ (push (cons pt-min ppss)
+ (if cache-pred (cdr cache-pred) ppss-cache)))
+
+ ;; Compute the actual return value.
+ (setq ppss (parse-partial-sexp pt-min pos nil nil ppss))
+
+ ;; Debugging check.
+ ;; (let ((real-ppss (parse-partial-sexp (point-min) pos)))
+ ;; (setcar (last ppss 4) 0)
+ ;; (setcar (last real-ppss 4) 0)
+ ;; (setcar (last ppss 8) nil)
+ ;; (setcar (last real-ppss 8) nil)
+ ;; (unless (equal ppss real-ppss)
+ ;; (message "!!Syntax: %s != %s" ppss real-ppss)
+ ;; (setq ppss real-ppss)))
+
+ ;; Store it in the cache.
+ (let ((pair (cons pos ppss)))
+ (if cache-pred
+ (if (> (- (caar cache-pred) pos) syntax-ppss-max-span)
+ (push pair (cdr cache-pred))
+ (setcar cache-pred pair))
+ (if (or (null ppss-cache)
+ (> (- (caar ppss-cache) pos)
+ syntax-ppss-max-span))
+ (push pair ppss-cache)
+ (setcar ppss-cache pair)))))))))
+
+ (setq syntax-ppss--updated-cache t)
+ (setq ppss-last (cons pos ppss))
+ (setcar cell ppss-last)
+ (setcdr cell ppss-cache)
+ ppss)
+ (args-out-of-range
+ ;; If the buffer is more narrowed than when we built the cache,
+ ;; we may end up calling parse-partial-sexp with a position before
+ ;; point-min. In that case, just parse from point-min assuming
+ ;; a nil state.
+ (parse-partial-sexp (point-min) pos))))))
;; Debugging functions
diff --git a/lisp/emacs-lisp/tabulated-list.el b/lisp/emacs-lisp/tabulated-list.el
index 9884a2fc24b..c86e3f9c5df 100644
--- a/lisp/emacs-lisp/tabulated-list.el
+++ b/lisp/emacs-lisp/tabulated-list.el
@@ -139,6 +139,21 @@ If `tabulated-list-entries' is a function, it is called with no
arguments and must return a list of the above form.")
(put 'tabulated-list-entries 'permanent-local t)
+(defvar-local tabulated-list-groups nil
+ "Groups displayed in the current Tabulated List buffer.
+This should be either a function, or a list.
+If a list, each element has the form (GROUP-NAME ENTRIES),
+where:
+
+ - GROUP-NAME is a group name as a string, which is displayed
+ at the top line of each group.
+
+ - ENTRIES is a list described in `tabulated-list-entries'.
+
+If `tabulated-list-groups' is a function, it is called with no
+arguments and must return a list of the above form.")
+(put 'tabulated-list-groups 'permanent-local t)
+
(defvar-local tabulated-list-padding 0
"Number of characters preceding each Tabulated List mode entry.
By default, lines are padded with spaces, but you can use the
@@ -362,15 +377,17 @@ Do nothing if `tabulated-list--header-string' is nil."
(if tabulated-list--header-overlay
(move-overlay tabulated-list--header-overlay (point-min) (point))
(setq-local tabulated-list--header-overlay
- (make-overlay (point-min) (point))))
- (overlay-put tabulated-list--header-overlay
- 'face 'tabulated-list-fake-header))))
+ (make-overlay (point-min) (point)))
+ (overlay-put tabulated-list--header-overlay 'fake-header t)
+ (overlay-put tabulated-list--header-overlay
+ 'face 'tabulated-list-fake-header)))))
(defsubst tabulated-list-header-overlay-p (&optional pos)
"Return non-nil if there is a fake header.
Optional arg POS is a buffer position where to look for a fake header;
defaults to `point-min'."
- (overlays-at (or pos (point-min))))
+ (seq-find (lambda (o) (overlay-get o 'fake-header))
+ (overlays-at (or pos (point-min)))))
(defun tabulated-list-revert (&rest _ignored)
"The `revert-buffer-function' for `tabulated-list-mode'.
@@ -427,6 +444,9 @@ This sorts the `tabulated-list-entries' list if sorting is
specified by `tabulated-list-sort-key'. It then erases the
buffer and inserts the entries with `tabulated-list-printer'.
+If `tabulated-list-groups' is non-nil, each group of entries
+is printed and sorted separately.
+
Optional argument REMEMBER-POS, if non-nil, means to move point
to the entry with the same ID element as the current line.
@@ -437,6 +457,9 @@ be removed from entries that haven't changed (see
`tabulated-list-put-tag'). Don't use this immediately after
changing `tabulated-list-sort-key'."
(let ((inhibit-read-only t)
+ (groups (if (functionp tabulated-list-groups)
+ (funcall tabulated-list-groups)
+ tabulated-list-groups))
(entries (if (functionp tabulated-list-entries)
(funcall tabulated-list-entries)
tabulated-list-entries))
@@ -447,7 +470,14 @@ changing `tabulated-list-sort-key'."
(setq saved-col (current-column)))
;; Sort the entries, if necessary.
(when sorter
- (setq entries (sort entries sorter)))
+ (if groups
+ (setq groups
+ (mapcar (lambda (group)
+ (cons (car group) (sort (cdr group) sorter)))
+ groups))
+ (setq entries (sort entries sorter))))
+ (unless (functionp tabulated-list-groups)
+ (setq tabulated-list-groups groups))
(unless (functionp tabulated-list-entries)
(setq tabulated-list-entries entries))
;; Without a sorter, we have no way to just update.
@@ -459,6 +489,25 @@ changing `tabulated-list-sort-key'."
(unless tabulated-list-use-header-line
(tabulated-list-print-fake-header)))
;; Finally, print the resulting list.
+ (if groups
+ (dolist (group groups)
+ (insert (car group) ?\n)
+ (when-let ((saved-pt-new (tabulated-list-print-entries
+ (cdr group) sorter update entry-id)))
+ (setq saved-pt saved-pt-new)))
+ (setq saved-pt (tabulated-list-print-entries
+ entries sorter update entry-id)))
+ (when update
+ (delete-region (point) (point-max)))
+ (set-buffer-modified-p nil)
+ ;; If REMEMBER-POS was specified, move to the "old" location.
+ (if saved-pt
+ (progn (goto-char saved-pt)
+ (move-to-column saved-col))
+ (goto-char (point-min)))))
+
+(defun tabulated-list-print-entries (entries sorter update entry-id)
+ (let (saved-pt)
(while entries
(let* ((elt (car entries))
(tabulated-list--near-rows
@@ -495,14 +544,7 @@ changing `tabulated-list-sort-key'."
(forward-line 1)
(delete-region old (point))))))
(setq entries (cdr entries)))
- (when update
- (delete-region (point) (point-max)))
- (set-buffer-modified-p nil)
- ;; If REMEMBER-POS was specified, move to the "old" location.
- (if saved-pt
- (progn (goto-char saved-pt)
- (move-to-column saved-col))
- (goto-char (point-min)))))
+ saved-pt))
(defun tabulated-list-print-entry (id cols)
"Insert a Tabulated List entry at point.
diff --git a/lisp/emacs-lisp/timer.el b/lisp/emacs-lisp/timer.el
index f92078ef86f..f6f2a8d87c0 100644
--- a/lisp/emacs-lisp/timer.el
+++ b/lisp/emacs-lisp/timer.el
@@ -226,8 +226,6 @@ the time of the current timer. That's because the activated
timer will fire right away."
(timer--activate timer (not dont-wait) reuse-cell 'idle))
-(defalias 'disable-timeout #'cancel-timer)
-
(defun cancel-timer (timer)
"Remove TIMER from the list of active timers."
(timer--check timer)
@@ -348,7 +346,6 @@ This function is called, by name, directly by the C code."
(memq timer timer-list))
(setf (timer--triggered timer) nil))))))
-;; This function is incompatible with the one in levents.el.
(defun timeout-event-p (event)
"Non-nil if EVENT is a timeout event."
(and (listp event) (eq (car event) 'timer-event)))
@@ -448,6 +445,7 @@ If REPEAT is non-nil, repeat the timer every REPEAT seconds.
This function returns a timer object which you can use in `cancel-timer'.
This function is for compatibility; see also `run-with-timer'."
+ (declare (obsolete run-with-timer "30.1"))
(run-with-timer secs repeat function object))
(defun run-with-idle-timer (secs repeat function &rest args)
@@ -580,6 +578,9 @@ If the user does not answer after SECONDS seconds, return DEFAULT-VALUE."
(dolist (timer timer-idle-list)
(if (timerp timer) ;; FIXME: Why test?
(setf (timer--triggered timer) nil))))
+
+(define-obsolete-function-alias 'disable-timeout #'cancel-timer "30.1")
+
(provide 'timer)
diff --git a/lisp/emacs-lisp/trace.el b/lisp/emacs-lisp/trace.el
index 912387a41fd..1ed1528c6d5 100644
--- a/lisp/emacs-lisp/trace.el
+++ b/lisp/emacs-lisp/trace.el
@@ -128,6 +128,8 @@
;;; Code:
+(require 'cl-print)
+
(defgroup trace nil
"Tracing facility for Emacs Lisp functions."
:prefix "trace-"
@@ -154,44 +156,43 @@
(defun trace-values (&rest values)
"Helper function to get internal values.
You can call this function to add internal values in the trace buffer."
- (unless inhibit-trace
- (with-current-buffer (get-buffer-create trace-buffer)
- (goto-char (point-max))
- (insert
- (trace-entry-message
- 'trace-values trace-level values "")))))
+ (trace--entry-message
+ 'trace-values trace-level values (lambda () "")))
-(defun trace-entry-message (function level args context)
+(defun trace--entry-message (function level args context)
"Generate a string that describes that FUNCTION has been entered.
-LEVEL is the trace level, ARGS is the list of arguments passed to FUNCTION,
-and CONTEXT is a string describing the dynamic context (e.g. values of
-some global variables)."
- (let ((print-circle t)
- (print-escape-newlines t))
- (format "%s%s%d -> %S%s\n"
- (mapconcat #'char-to-string (make-string (max 0 (1- level)) ?|) " ")
- (if (> level 1) " " "")
- level
- ;; FIXME: Make it so we can click the function name to jump to its
- ;; definition and/or untrace it.
- (cons function args)
- context)))
-
-(defun trace-exit-message (function level value context)
+LEVEL is the trace level, ARGS is the list of arguments passed to FUNCTION."
+ (unless inhibit-trace
+ (trace--insert
+ (let ((ctx (funcall context))
+ (print-circle t)
+ (print-escape-newlines t))
+ (format "%s%s%d -> %s%s\n"
+ (mapconcat #'char-to-string
+ (make-string (max 0 (1- level)) ?|) " ")
+ (if (> level 1) " " "")
+ level
+ ;; FIXME: Make it so we can click the function name to
+ ;; jump to its definition and/or untrace it.
+ (cl-prin1-to-string (cons function args))
+ ctx)))))
+
+(defun trace--exit-message (function level value context)
"Generate a string that describes that FUNCTION has exited.
-LEVEL is the trace level, VALUE value returned by FUNCTION,
-and CONTEXT is a string describing the dynamic context (e.g. values of
-some global variables)."
- (let ((print-circle t)
- (print-escape-newlines t))
- (format "%s%s%d <- %s: %S%s\n"
- (mapconcat 'char-to-string (make-string (1- level) ?|) " ")
- (if (> level 1) " " "")
- level
- function
- ;; Do this so we'll see strings:
- value
- context)))
+LEVEL is the trace level, VALUE value returned by FUNCTION."
+ (unless inhibit-trace
+ (trace--insert
+ (let ((ctx (funcall context))
+ (print-circle t)
+ (print-escape-newlines t))
+ (format "%s%s%d <- %s: %s%s\n"
+ (mapconcat 'char-to-string (make-string (1- level) ?|) " ")
+ (if (> level 1) " " "")
+ level
+ function
+ ;; Do this so we'll see strings:
+ (cl-prin1-to-string value)
+ ctx)))))
(defvar trace--timer nil)
@@ -206,43 +207,40 @@ some global variables)."
(setq trace--timer nil)
(display-buffer buf nil 0))))))
+(defun trace--insert (msg)
+ (if noninteractive
+ (message "%s" (if (eq ?\n (aref msg (1- (length msg))))
+ (substring msg 0 -1) msg))
+ (with-current-buffer trace-buffer
+ (setq-local window-point-insertion-type t)
+ (goto-char (point-max))
+ (let ((deactivate-mark nil)) ;Protect deactivate-mark.
+ (insert msg)))))
(defun trace-make-advice (function buffer background context)
"Build the piece of advice to be added to trace FUNCTION.
FUNCTION is the name of the traced function.
BUFFER is the buffer where the trace should be printed.
BACKGROUND if nil means to display BUFFER.
-CONTEXT if non-nil should be a function that returns extra info that should
-be printed along with the arguments in the trace."
+CONTEXT should be a function that returns extra text that should
+be printed after the arguments in the trace."
(lambda (body &rest args)
(let ((trace-level (1+ trace-level))
- (trace-buffer (get-buffer-create buffer))
- (deactivate-mark nil) ;Protect deactivate-mark.
- (ctx (funcall context)))
+ (trace-buffer (get-buffer-create buffer)))
+ ;; Insert a separator from previous trace output:
(unless inhibit-trace
- (with-current-buffer trace-buffer
- (setq-local window-point-insertion-type t)
- (unless background (trace--display-buffer trace-buffer))
- (goto-char (point-max))
- ;; Insert a separator from previous trace output:
- (if (= trace-level 1) (insert trace-separator))
- (insert
- (trace-entry-message
- function trace-level args ctx))))
+ (unless background (trace--display-buffer trace-buffer))
+ (if (= trace-level 1) (trace--insert trace-separator)))
+ (trace--entry-message
+ function trace-level args context)
(let ((result))
(unwind-protect
(setq result (list (apply body args)))
- (unless inhibit-trace
- (let ((ctx (funcall context)))
- (with-current-buffer trace-buffer
- (unless background (trace--display-buffer trace-buffer))
- (goto-char (point-max))
- (insert
- (trace-exit-message
- function
- trace-level
- (if result (car result) '\!non-local\ exit\!)
- ctx))))))
+ (trace--exit-message
+ function
+ trace-level
+ (if result (car result) '\!non-local\ exit\!)
+ context))
(car result)))))
(defun trace-function-internal (function buffer background context)
diff --git a/lisp/emacs-lisp/unsafep.el b/lisp/emacs-lisp/unsafep.el
index 0235bf16a64..c64619e9b9e 100644
--- a/lisp/emacs-lisp/unsafep.el
+++ b/lisp/emacs-lisp/unsafep.el
@@ -237,7 +237,7 @@ Otherwise result is a reason code."
((eq (car-safe fun) 'lambda)
(unsafep fun unsafep-vars))
((not (and (symbolp fun)
- (or (get fun 'side-effect-free)
+ (or (function-get fun 'side-effect-free)
(eq (get fun 'safe-function) t)
(eq safe-functions t)
(memq fun safe-functions))))
diff --git a/lisp/emacs-lisp/vtable.el b/lisp/emacs-lisp/vtable.el
index fe608e0c265..d8e5136c666 100644
--- a/lisp/emacs-lisp/vtable.el
+++ b/lisp/emacs-lisp/vtable.el
@@ -240,13 +240,14 @@ See info node `(vtable)Top' for vtable documentation."
(defun vtable-beginning-of-table ()
"Go to the start of the current table."
- (if (text-property-search-backward 'vtable (vtable-current-table))
+ (if (or (text-property-search-backward 'vtable (vtable-current-table) #'eq)
+ (get-text-property (point) 'vtable))
(point)
(goto-char (point-min))))
(defun vtable-end-of-table ()
"Go to the end of the current table."
- (if (text-property-search-forward 'vtable (vtable-current-table))
+ (if (text-property-search-forward 'vtable (vtable-current-table) #'eq)
(point)
(goto-char (point-max))))
@@ -282,8 +283,16 @@ If it can't be found, return nil and don't move point."
(goto-char (prop-match-beginning match))
(end-of-line)))
-(defun vtable-update-object (table object old-object)
- "Replace OLD-OBJECT in TABLE with OBJECT."
+(defun vtable-update-object (table object &optional old-object)
+ "Update OBJECT's representation in TABLE.
+If OLD-OBJECT is non-nil, replace OLD-OBJECT with OBJECT and display it.
+In either case, if the existing object is not found in the table (being
+compared with `equal'), signal an error. Note a limitation: if TABLE's
+buffer is not in a visible window, or if its window has changed width
+since it was updated, updating the TABLE is not possible, and an error
+is signaled."
+ (unless old-object
+ (setq old-object object))
(let* ((objects (vtable-objects table))
(inhibit-read-only t))
;; First replace the object in the object storage.
@@ -299,26 +308,31 @@ 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-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)
- (setcdr line (vtable--compute-cached-line table object))
- ;; ... and redisplay the line in question.
- (save-excursion
- (vtable-goto-object old-object)
- (let ((keymap (get-text-property (point) 'keymap))
- (start (point)))
- (delete-line)
- (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))))
- ;; We may have inserted a non-numerical value into a previously
- ;; all-numerical table, so recompute.
- (vtable--recompute-numerical table (cdr line)))))
+ ;; FIXME: If the table's buffer has no visible window, or if its
+ ;; width has changed since the table was updated, the cache key will
+ ;; not match and the object can't be updated. (Bug #69837).
+ (if-let ((line-number (seq-position (car (vtable--cache table)) old-object
+ (lambda (a b)
+ (equal (car a) b))))
+ (line (elt (car (vtable--cache table)) line-number)))
+ (progn
+ (setcar line object)
+ (setcdr line (vtable--compute-cached-line table object))
+ ;; ... and redisplay the line in question.
+ (save-excursion
+ (vtable-goto-object old-object)
+ (let ((keymap (get-text-property (point) 'keymap))
+ (start (point)))
+ (delete-line)
+ (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))))
+ ;; We may have inserted a non-numerical value into a previously
+ ;; all-numerical table, so recompute.
+ (vtable--recompute-numerical table (cdr line)))
+ (error "Can't find cached object in vtable"))))
(defun vtable-remove-object (table object)
"Remove OBJECT from TABLE.
@@ -740,7 +754,7 @@ If NEXT, do the next column."
(seq-do-indexed
(lambda (elem index)
(when (and (vtable-column--numerical (elt columns index))
- (not (numberp elem)))
+ (not (numberp (car elem))))
(setq recompute t)))
line)
(when recompute
diff --git a/lisp/emacs-lisp/warnings.el b/lisp/emacs-lisp/warnings.el
index 61aa0a2fe22..6c62a56e99c 100644
--- a/lisp/emacs-lisp/warnings.el
+++ b/lisp/emacs-lisp/warnings.el
@@ -106,6 +106,7 @@ so only the element (FOO) will match it."
:type '(repeat (repeat symbol))
:version "22.1")
+;;;###autoload
(defcustom warning-suppress-types nil
"List of warning types not to display immediately.
If any element of this list matches the TYPE argument to `display-warning',
diff --git a/lisp/emulation/cua-base.el b/lisp/emulation/cua-base.el
index 4c2ba0c527c..fb6a8515d9e 100644
--- a/lisp/emulation/cua-base.el
+++ b/lisp/emulation/cua-base.el
@@ -1134,7 +1134,7 @@ If ARG is the atom `-', scroll upward by nearly full screen."
(defun cua--M/H-key (map key fct)
;; bind H-KEY or M-KEY to FCT in MAP
- (unless (listp key) (setq key (list key)))
+ (setq key (ensure-list key))
(define-key map (vector (cons cua--rectangle-modifier-key key)) fct))
(defun cua--self-insert-char-p (def)
diff --git a/lisp/emulation/viper-cmd.el b/lisp/emulation/viper-cmd.el
index 8ca8ee7190b..192eb99a570 100644
--- a/lisp/emulation/viper-cmd.el
+++ b/lisp/emulation/viper-cmd.el
@@ -194,9 +194,9 @@
viper-delete-backward-char
viper-join-lines
viper-delete-char))
- (memq (viper-event-key last-command-event)
- '(up down left right (meta f) (meta b)
- (control n) (control p) (control f) (control b)))))
+ (member (viper-event-key last-command-event)
+ '(up down left right (meta f) (meta b)
+ (control n) (control p) (control f) (control b)))))
(defsubst viper-insert-state-pre-command-sentinel ()
(or (viper-preserve-cursor-color)
@@ -466,6 +466,12 @@
;; Viper mode-changing commands and utilities
+(defcustom viper-enable-minibuffer-faces t
+ "If non-nil, viper uses distinct faces in the minibuffer."
+ :type 'boolean
+ :version "30.1"
+ :group 'viper-misc)
+
;; Modifies mode-line-buffer-identification.
(defun viper-refresh-mode-line ()
(setq-local viper-mode-string
@@ -561,14 +567,14 @@
))
;; minibuffer faces
- (if (viper-has-face-support-p)
+ (if (and (viper-has-face-support-p) viper-enable-minibuffer-faces)
(setq viper-minibuffer-current-face
(cond ((eq state 'emacs-state) viper-minibuffer-emacs-face)
((eq state 'vi-state) viper-minibuffer-vi-face)
((memq state '(insert-state replace-state))
viper-minibuffer-insert-face))))
- (if (viper-is-in-minibuffer)
+ (if (and (viper-is-in-minibuffer) viper-enable-minibuffer-faces)
(viper-set-minibuffer-overlay))
)
@@ -716,16 +722,12 @@ Vi's prefix argument will be used. Otherwise, the prefix argument passed to
(let (viper-vi-kbd-minor-mode
viper-insert-kbd-minor-mode
viper-emacs-kbd-minor-mode)
- (unwind-protect
- (progn
- (setq com
- (key-binding (setq key (read-key-sequence nil))))
- ;; In case of binding indirection--chase definitions.
- ;; Have to do it here because we execute this command under
- ;; different keymaps, so command-execute may not do the
- ;; right thing there
- (while (vectorp com) (setq com (key-binding com))))
- nil)
+ (setq com (key-binding (setq key (read-key-sequence nil))))
+ ;; In case of binding indirection--chase definitions.
+ ;; Have to do it here because we execute this command under
+ ;; different keymaps, so command-execute may not do the
+ ;; right thing there
+ (while (vectorp com) (setq com (key-binding com)))
;; Execute command com in the original Viper state, not in state
;; `state'. Otherwise, if we switch buffers while executing the
;; escaped to command, Viper's mode vars will remain those of
@@ -1705,8 +1707,8 @@ to in the global map, instead of cycling through the insertion ring."
(if (eq viper-current-state 'replace-state)
(undo 1)
(if viper-last-inserted-string-from-insertion-ring
- (backward-delete-char
- (length viper-last-inserted-string-from-insertion-ring))))
+ (delete-char
+ (- (length viper-last-inserted-string-from-insertion-ring)))))
)
;;first search through insertion history
(setq viper-temp-insertion-ring (ring-copy viper-insertion-ring)))
@@ -1944,16 +1946,16 @@ To turn this feature off, set this variable to nil."
(if found
()
(viper-tmp-insert-at-eob " [Please complete file name]")
- (unwind-protect
- (while (not (memq cmd
- '(exit-minibuffer viper-exit-minibuffer)))
- (setq cmd
- (key-binding (setq key (read-key-sequence nil))))
- (cond ((eq cmd 'self-insert-command)
- (insert key))
- ((memq cmd '(exit-minibuffer viper-exit-minibuffer))
- nil)
- (t (command-execute cmd))))))))))
+
+ (while (not (memq cmd
+ '(exit-minibuffer viper-exit-minibuffer)))
+ (setq cmd
+ (key-binding (setq key (read-key-sequence nil))))
+ (cond ((eq cmd 'self-insert-command)
+ (insert key))
+ ((memq cmd '(exit-minibuffer viper-exit-minibuffer))
+ nil)
+ (t (command-execute cmd)))))))))
(defun viper-minibuffer-trim-tail ()
@@ -4635,7 +4637,7 @@ sensitive for VI-style look-and-feel."
(insert (substitute-command-keys "
Please specify your level of familiarity with the venomous VI PERil
\(and the VI Plan for Emacs Rescue).
-You can change it at any time by typing `\\[viper-set-expert-level]'
+You can change it at any time by typing \\[viper-set-expert-level]
1 -- BEGINNER: Almost all Emacs features are suppressed.
Feels almost like straight Vi. File name completion and
@@ -4722,15 +4724,15 @@ Please, specify your level now: "))
(defun viper-submit-report ()
"Submit bug report on Viper."
(interactive)
- (defvar x-display-color-p)
+ (defvar display-color-p)
(defvar viper-frame-parameters)
(defvar viper-minibuffer-emacs-face)
(defvar viper-minibuffer-vi-face)
(defvar viper-minibuffer-insert-face)
(let ((reporter-prompt-for-summary-p t)
- (x-display-color-p (if (viper-window-display-p)
- (x-display-color-p)
- 'non-x))
+ (display-color-p (if (viper-window-display-p)
+ (display-color-p)
+ 'non-x))
(viper-frame-parameters (frame-parameters (selected-frame)))
(viper-minibuffer-emacs-face (if (viper-has-face-support-p)
(facep
@@ -4788,7 +4790,7 @@ Please, specify your level now: "))
'viper-expert-level
'major-mode
'window-system
- 'x-display-color-p
+ 'display-color-p
'viper-frame-parameters
'viper-minibuffer-vi-face
'viper-minibuffer-insert-face
diff --git a/lisp/emulation/viper-ex.el b/lisp/emulation/viper-ex.el
index 8674bd9f1f8..11e00aef33d 100644
--- a/lisp/emulation/viper-ex.el
+++ b/lisp/emulation/viper-ex.el
@@ -294,7 +294,8 @@
"\\|"
"bash$\\|bash.exe$"
"\\)")
- shell-file-name)))
+ shell-file-name)
+ t))
"Is the user using a unix-type shell under a non-OS?"
:type 'boolean)
diff --git a/lisp/emulation/viper-init.el b/lisp/emulation/viper-init.el
index cb52b60ee63..9f724551239 100644
--- a/lisp/emulation/viper-init.el
+++ b/lisp/emulation/viper-init.el
@@ -47,7 +47,8 @@
(defun viper-window-display-p ()
(and window-system (not (memq window-system '(tty stream pc)))))
-(defcustom viper-ms-style-os-p (memq system-type '(ms-dos windows-nt))
+(defcustom viper-ms-style-os-p
+ (not (not (memq system-type '(ms-dos windows-nt))))
"Non-nil if Emacs is running under an MS-style OS: MS-DOS, or MS-Windows."
:type 'boolean
:tag "Is it Microsoft-made OS?"
@@ -256,11 +257,11 @@ that deletes a file.")
(defvar viper-expert-level (if (boundp 'viper-expert-level) viper-expert-level 0)
"User's expert level.
-The minor mode viper-vi-diehard-minor-mode is in effect when
-viper-expert-level is 1 or 2 or when viper-want-emacs-keys-in-vi is t.
-The minor mode viper-insert-diehard-minor-mode is in effect when
-viper-expert-level is 1 or 2 or if viper-want-emacs-keys-in-insert is t.
-Use `\\[viper-set-expert-level]' to change this.")
+The minor mode `viper-vi-diehard-minor-mode' is in effect when
+`viper-expert-level' is 1 or 2 or when `viper-want-emacs-keys-in-vi' is t.
+The minor mode `viper-insert-diehard-minor-mode' is in effect when
+`viper-expert-level' is 1 or 2 or if `viper-want-emacs-keys-in-insert' is t.
+Use \\[viper-set-expert-level] to change this.")
;; Max expert level supported by Viper. This is NOT a user option.
;; It is here to make it hard for the user from resetting it.
diff --git a/lisp/emulation/viper.el b/lisp/emulation/viper.el
index e309d0076c7..287292a24dc 100644
--- a/lisp/emulation/viper.el
+++ b/lisp/emulation/viper.el
@@ -388,7 +388,6 @@ widget."
idl-mode
perl-mode
- cperl-mode
javascript-mode
tcl-mode
python-mode
@@ -593,8 +592,8 @@ This startup message appears whenever you load Viper, unless you type \\`y' now.
))
(viper-set-expert-level 'dont-change-unless)))
- (or (apply #'derived-mode-p viper-emacs-state-mode-list) ; don't switch to Vi
- (apply #'derived-mode-p viper-insert-state-mode-list) ; don't switch
+ (or (derived-mode-p viper-emacs-state-mode-list) ; don't switch to Vi
+ (derived-mode-p viper-insert-state-mode-list) ; don't switch
(viper-change-state-to-vi))
))
@@ -607,9 +606,9 @@ This startup message appears whenever you load Viper, unless you type \\`y' now.
;; that are not listed in viper-vi-state-mode-list
(defun viper-this-major-mode-requires-vi-state (mode)
(let ((major-mode mode))
- (cond ((apply #'derived-mode-p viper-vi-state-mode-list) t)
- ((apply #'derived-mode-p viper-emacs-state-mode-list) nil)
- ((apply #'derived-mode-p viper-insert-state-mode-list) nil)
+ (cond ((derived-mode-p viper-vi-state-mode-list) t)
+ ((derived-mode-p viper-emacs-state-mode-list) nil)
+ ((derived-mode-p viper-insert-state-mode-list) nil)
(t (and (eq (key-binding "a") 'self-insert-command)
(eq (key-binding " ") 'self-insert-command))))))
diff --git a/lisp/env.el b/lisp/env.el
index 0218e424d1a..e0a8df8476c 100644
--- a/lisp/env.el
+++ b/lisp/env.el
@@ -76,6 +76,7 @@ If it is non-nil and not a function, references to undefined variables are
left unchanged.
Use `$$' to insert a single dollar sign."
+ (declare (important-return-value t))
(let ((start 0))
(while (string-match env--substitute-vars-regexp string start)
(cond ((match-beginning 1)
@@ -94,6 +95,7 @@ Use `$$' to insert a single dollar sign."
string))
(defun substitute-env-in-file-name (filename)
+ (declare (important-return-value t))
(substitute-env-vars filename
;; How 'bout we lookup other tables than the env?
;; E.g. we could accept bookmark names as well!
@@ -104,6 +106,7 @@ Use `$$' to insert a single dollar sign."
(defun setenv-internal (env variable value keep-empty)
"Set VARIABLE to VALUE in ENV, adding empty entries if KEEP-EMPTY.
Changes ENV by side-effect, and returns its new value."
+ (declare (important-return-value t))
(let ((pattern (concat "\\`" (regexp-quote variable) "\\(=\\|\\'\\)"))
(case-fold-search nil)
(scan env)
@@ -204,6 +207,7 @@ parameter.
Otherwise, this function searches `process-environment' for
VARIABLE. If it is not found there, then it continues the search
in the environment list of the selected frame."
+ (declare (side-effect-free t))
(interactive (list (read-envvar-name "Get environment variable: " t)))
(let ((value (getenv-internal (if (multibyte-string-p variable)
(encode-coding-string
diff --git a/lisp/epa.el b/lisp/epa.el
index 53da3bf6cce..c29df18bb58 100644
--- a/lisp/epa.el
+++ b/lisp/epa.el
@@ -73,6 +73,17 @@ The command `epa-mail-encrypt' uses this."
:group 'epa
:version "24.4")
+(defcustom epa-keys-select-method 'buffer
+ "Method used to select keys in `epa-select-keys'.
+If the value is \\='buffer, the default, keys are selected via a
+pop-up buffer. If the value is \\='minibuffer, keys are selected
+via the minibuffer instead, using `completing-read-multiple'.
+Any other value is treated as \\='buffer."
+ :type '(choice (const :tag "Read keys from a pop-up buffer" buffer)
+ (const :tag "Read keys from minibuffer" minibuffer))
+ :group 'epa
+ :version "30.1")
+
;;; Faces
(defgroup epa-faces nil
@@ -450,6 +461,25 @@ q trust status questionable. - trust status unspecified.
(epa--marked-keys))
(kill-buffer epa-keys-buffer)))))
+(defun epa--select-keys-in-minibuffer (prompt keys)
+ (let* ((prompt (pcase-let ((`(,first ,second ,third)
+ (string-split prompt "\\."))
+ (hint "(separated by comma)"))
+ (if third
+ (format "%s %s. %s: " first hint second)
+ (format "%s %s: " first hint))))
+ (keys-alist
+ (seq-map
+ (lambda (key)
+ (cons (substring-no-properties
+ (epa--button-key-text key))
+ key))
+ keys))
+ (selected-keys (completing-read-multiple prompt keys-alist)))
+ (seq-map
+ (lambda (key) (cdr (assoc key keys-alist)))
+ selected-keys)))
+
;;;###autoload
(defun epa-select-keys (context prompt &optional names secret)
"Display a user's keyring and ask him to select keys.
@@ -459,7 +489,9 @@ NAMES is a list of strings to be matched with keys. If it is nil, all
the keys are listed.
If SECRET is non-nil, list secret keys instead of public keys."
(let ((keys (epg-list-keys context names secret)))
- (epa--select-keys prompt keys)))
+ (pcase epa-keys-select-method
+ ('minibuffer (epa--select-keys-in-minibuffer prompt keys))
+ (_ (epa--select-keys prompt keys)))))
;;;; Key Details
diff --git a/lisp/epg.el b/lisp/epg.el
index 84a4512b9ff..7bec91f616d 100644
--- a/lisp/epg.el
+++ b/lisp/epg.el
@@ -595,7 +595,12 @@ callback data (if any)."
(if (epg-context-textmode context) '("--textmode"))
(if (epg-context-output-file context)
(list "--output" (epg-context-output-file context)))
- (if (epg-context-pinentry-mode context)
+ (if (and (epg-context-pinentry-mode context)
+ (not
+ ;; loopback doesn't work with gpgsm
+ (and (eq (epg-context-protocol context) 'CMS)
+ (eq (epg-context-pinentry-mode context)
+ 'loopback))))
(list "--pinentry-mode"
(symbol-name (epg-context-pinentry-mode
context))))
@@ -1264,8 +1269,7 @@ callback data (if any)."
keys string field index)
(if name
(progn
- (unless (listp name)
- (setq name (list name)))
+ (setq name (ensure-list name))
(while name
(setq args (append args (list list-keys-option (car name)))
name (cdr name))))
diff --git a/lisp/erc/erc-backend.el b/lisp/erc/erc-backend.el
index af3470a56ea..9fc8a4d29f4 100644
--- a/lisp/erc/erc-backend.el
+++ b/lisp/erc/erc-backend.el
@@ -101,34 +101,27 @@
(eval-when-compile (require 'cl-lib))
(require 'erc-common)
+(defvar erc--display-context)
(defvar erc--target)
-(defvar erc-auto-query)
(defvar erc-channel-list)
-(defvar erc-channel-users)
+(defvar erc-channel-members)
(defvar erc-default-nicks)
(defvar erc-default-recipients)
-(defvar erc-format-nick-function)
-(defvar erc-format-query-as-channel-p)
+(defvar erc-ensure-target-buffer-on-privmsg)
(defvar erc-hide-prompt)
(defvar erc-input-marker)
(defvar erc-insert-marker)
-(defvar erc-invitation)
(defvar erc-join-buffer)
-(defvar erc-kill-buffer-on-part)
-(defvar erc-kill-server-buffer-on-quit)
-(defvar erc-log-p)
-(defvar erc-minibuffer-ignored)
(defvar erc-networks--id)
(defvar erc-nick)
(defvar erc-nick-change-attempt-count)
-(defvar erc-prompt-for-channel-key)
-(defvar erc-prompt-hidden)
-(defvar erc-reuse-buffers)
(defvar erc-verbose-server-ping)
-(defvar erc-whowas-on-nosuchnick)
+(declare-function erc--init-channel-modes "erc" (channel raw-args))
(declare-function erc--open-target "erc" (target))
+(declare-function erc--parse-nuh "erc" (string))
(declare-function erc--target-from-string "erc" (string))
+(declare-function erc--update-modes "erc" (raw-args))
(declare-function erc-active-buffer "erc" nil)
(declare-function erc-add-default-channel "erc" (channel))
(declare-function erc-banlist-update "erc" (proc parsed))
@@ -149,7 +142,6 @@
(declare-function erc-display-server-message "erc" (_proc parsed))
(declare-function erc-emacs-time-to-erc-time "erc" (&optional specified-time))
(declare-function erc-format-message "erc" (msg &rest args))
-(declare-function erc-format-privmessage "erc" (nick msg privp msgp))
(declare-function erc-get-buffer "erc" (target &optional proc))
(declare-function erc-handle-login "erc" nil)
(declare-function erc-handle-user-status-change "erc" (type nlh &optional l))
@@ -159,7 +151,6 @@
(declare-function erc-is-message-ctcp-p "erc" (message))
(declare-function erc-log-irc-protocol "erc" (string &optional outbound))
(declare-function erc-login "erc" nil)
-(declare-function erc-make-notice "erc" (message))
(declare-function erc-network "erc-networks" nil)
(declare-function erc-networks--id-given "erc-networks" (arg &rest args))
(declare-function erc-networks--id-reload "erc-networks" (arg &rest args))
@@ -167,7 +158,6 @@
(declare-function erc-parse-user "erc" (string))
(declare-function erc-process-away "erc" (proc away-p))
(declare-function erc-process-ctcp-query "erc" (proc parsed nick login host))
-(declare-function erc-query-buffer-p "erc" (&optional buffer))
(declare-function erc-remove-channel-member "erc" (channel nick))
(declare-function erc-remove-channel-users "erc" nil)
(declare-function erc-remove-user "erc" (nick))
@@ -175,13 +165,15 @@
(declare-function erc-server-buffer "erc" nil)
(declare-function erc-set-active-buffer "erc" (buffer))
(declare-function erc-set-current-nick "erc" (nick))
-(declare-function erc-set-modes "erc" (tgt mode-string))
(declare-function erc-time-diff "erc" (t1 t2))
(declare-function erc-trim-string "erc" (s))
(declare-function erc-update-mode-line "erc" (&optional buffer))
(declare-function erc-update-mode-line-buffer "erc" (buffer))
(declare-function erc-wash-quit-reason "erc" (reason nick login host))
+(declare-function erc--determine-speaker-message-format-args "erc"
+ (nick target message queryp privmsgp statusmsgp inputp
+ &optional prefix disp-nick))
(declare-function erc-display-message "erc"
(parsed type buffer msg &rest args))
(declare-function erc-get-buffer-create "erc"
@@ -190,8 +182,6 @@
(proc parsed nick login host msg))
(declare-function erc-update-channel-topic "erc"
(channel topic &optional modify))
-(declare-function erc-update-modes "erc"
- (tgt mode-string &optional _nick _host _login))
(declare-function erc-update-user-nick "erc"
(nick &optional new-nick host login full-name info))
(declare-function erc-open "erc"
@@ -263,6 +253,11 @@ Entries are of the form:
or
(PARAMETER) if no value is provided.
+where PARAMETER is a string and VALUE is a string or nil. For
+compatibility, a raw parameter of the form \"FOO=\" becomes
+(\"FOO\" . \"\") even though it's equivalent to the preferred
+canonical form \"FOO\" and its lisp representation (\"FOO\").
+
Some examples of possible parameters sent by servers:
CHANMODES=b,k,l,imnpst - list of supported channel modes
CHANNELLEN=50 - maximum length of channel names
@@ -282,7 +277,8 @@ WALLCHOPS - supports sending messages to all operators in a channel")
(defvar-local erc--isupport-params nil
"Hash map of \"ISUPPORT\" params.
Keys are symbols. Values are lists of zero or more strings with hex
-escapes removed.")
+escapes removed. ERC normalizes incoming parameters of the form
+\"FOO=\" to (FOO).")
;;; Server and connection state
@@ -297,6 +293,12 @@ function `erc-server-process-alive' instead.")
(defvar-local erc-server-reconnect-count 0
"Number of times we have failed to reconnect to the current server.")
+(defvar-local erc--server-reconnect-display-timer nil
+ "Timer that resets `erc--server-last-reconnect-count' to zero.
+Becomes non-nil in all server buffers when an IRC connection is
+first \"established\" and carries out its duties
+`erc-auto-reconnect-display-timeout' seconds later.")
+
(defvar-local erc--server-last-reconnect-count 0
"Snapshot of reconnect count when the connection was established.")
@@ -415,8 +417,12 @@ This only has an effect if `erc-server-auto-reconnect' is non-nil."
(defcustom erc-server-reconnect-timeout 1
"Number of seconds to wait between successive reconnect attempts.
-
-If a key is pressed while ERC is waiting, it will stop waiting."
+If this value is too low, servers may reject your initial nick
+request upon reconnecting because they haven't yet noticed that
+your previous connection is dead. If this happens, try setting
+this value to 120 or greater and/or exploring the option
+`erc-regain-services-alist', which may provide a more proactive
+means of handling this situation on some servers."
:type 'number)
(defcustom erc-server-reconnect-function 'erc-server-delayed-reconnect
@@ -427,11 +433,16 @@ dialing. Use `erc-schedule-reconnect' to instead try again later
and optionally alter the attempts tally."
:package-version '(ERC . "5.5")
:type '(choice (function-item erc-server-delayed-reconnect)
+ (function-item erc-server-delayed-check-reconnect)
function))
(defcustom erc-split-line-length 440
"The maximum length of a single message.
-If a message exceeds this size, it is broken into multiple ones.
+ERC normally splits chat input submitted at its prompt into
+multiple messages when the initial size exceeds this value in
+bytes. Modules can tell ERC to forgo splitting entirely by
+setting this to zero locally or, preferably, by binding it around
+a remapped `erc-send-current-line' command.
IRC allows for lines up to 512 bytes. Two of them are CR LF.
And a typical message looks like this:
@@ -495,7 +506,7 @@ It should take same arguments as `open-network-stream' does."
"Either nil or a list of strings.
Each string is a IRC message type, like PRIVMSG or NOTICE.
All Message types in that list of subjected to duplicate prevention."
- :type '(choice (const nil) (list string)))
+ :type '(repeat string))
(defcustom erc-server-duplicate-timeout 60
"The time allowed in seconds between duplicate messages.
@@ -559,6 +570,48 @@ If this is set to nil, never try to reconnect."
;;;; Helper functions
+(defvar erc--reject-unbreakable-lines nil
+ "Signal an error when a line exceeds `erc-split-line-length'.
+Sending such lines and hoping for the best is no longer supported
+in ERC 5.6. This internal var exists as a possibly temporary
+escape hatch for inhibiting their transmission.")
+
+(defun erc--split-line (longline)
+ (let* ((coding (erc-coding-system-for-target nil))
+ (original-window-buf (window-buffer (selected-window)))
+ out)
+ (when (consp coding)
+ (setq coding (car coding)))
+ (setq coding (coding-system-change-eol-conversion coding 'unix))
+ (unwind-protect
+ (with-temp-buffer
+ (set-window-buffer (selected-window) (current-buffer))
+ (insert longline)
+ (goto-char (point-min))
+ (while (not (eobp))
+ (let ((upper (filepos-to-bufferpos erc-split-line-length
+ 'exact coding)))
+ (goto-char (or upper (point-max)))
+ (unless (eobp)
+ (skip-chars-backward "^ \t"))
+ (when (bobp)
+ (when erc--reject-unbreakable-lines
+ (user-error
+ (substitute-command-keys
+ (concat "Unbreakable line encountered "
+ "(Recover input with \\[erc-previous-command])"))))
+ (goto-char upper))
+ (when-let ((cmp (find-composition (point) (1+ (point)))))
+ (if (= (car cmp) (point-min))
+ (goto-char (nth 1 cmp))
+ (goto-char (car cmp)))))
+ (when (= (point-min) (point))
+ (goto-char (point-max)))
+ (push (buffer-substring-no-properties (point-min) (point)) out)
+ (delete-region (point-min) (point)))
+ (or (nreverse out) (list "")))
+ (set-window-buffer (selected-window) original-window-buf))))
+
;; From Circe
(defun erc-split-line (longline)
"Return a list of lines which are not too long for IRC.
@@ -658,6 +711,30 @@ The current buffer is given by BUFFER."
(run-hooks 'erc--server-post-connect-hook)
(erc-login))
+(defvar erc--server-connect-function #'erc--server-propagate-failed-connection
+ "Function called one second after creating a server process.
+Called with the newly created process just before the opening IRC
+protocol exchange.")
+
+(defun erc--server-propagate-failed-connection (process)
+ "Ensure the PROCESS sentinel runs at least once on early failure.
+Act as a watchdog timer to force `erc-process-sentinel' and its
+finalizers, like `erc-disconnected-hook', to run when PROCESS has
+a status of `failed' after one second. But only do so when its
+error data is something ERC recognizes. Print an explanation to
+the server buffer in any case."
+ (when (eq (process-status process) 'failed)
+ (erc-display-message
+ nil '(notice error) (process-buffer process)
+ (format "Process exit status: %S" (process-exit-status process)))
+ (pcase (process-exit-status process)
+ (111
+ (erc-process-sentinel process "failed with code 111\n"))
+ (`(file-error . ,_)
+ (erc-process-sentinel process "failed with code -523\n"))
+ ((rx "tls" (+ nonl) "failed")
+ (erc-process-sentinel process "failed with code -525\n")))))
+
(defvar erc--server-connect-dumb-ipv6-regexp
;; Not for validation (gives false positives).
(rx bot "[" (group (+ (any xdigit digit ":.")) (? "%" (+ alnum))) "]" eot))
@@ -710,7 +787,9 @@ TLS (see `erc-session-client-certificate' for more details)."
;; MOTD line)
(if (eq (process-status process) 'connect)
;; waiting for a non-blocking connect - keep the user informed
- (erc-display-message nil nil buffer "Opening connection..\n")
+ (progn
+ (erc-display-message nil nil buffer "Opening connection..\n")
+ (run-at-time 1 nil erc--server-connect-function process))
(message "%s...done" msg)
(erc--register-connection))))
@@ -735,6 +814,7 @@ Make sure you are in an ERC buffer when running this."
nil nil nil erc-session-client-certificate
erc-session-username
(erc-networks--id-given erc-networks--id))
+ (defvar erc-reuse-buffers)
(unless (with-suppressed-warnings ((obsolete erc-reuse-buffers))
erc-reuse-buffers)
(cl-assert (not (eq buffer (current-buffer)))))))))
@@ -744,6 +824,78 @@ Make sure you are in an ERC buffer when running this."
(with-current-buffer buffer
(erc-server-reconnect))))
+(defvar-local erc--server-reconnect-timeout nil)
+(defvar-local erc--server-reconnect-timeout-check 10)
+(defvar-local erc--server-reconnect-timeout-scale-function
+ #'erc--server-reconnect-timeout-double)
+
+(defun erc--server-reconnect-timeout-double (existing)
+ "Double EXISTING timeout, but cap it at 5 minutes."
+ (min 300 (* existing 2)))
+
+;; This may appear to hang at various places. It's assumed that when
+;; *Messages* contains "Waiting for socket ..." or similar, progress
+;; will be made eventually.
+
+(defun erc-server-delayed-check-reconnect (buffer)
+ "Wait for internet connectivity before trying to reconnect.
+Expect BUFFER to be the server buffer for the current connection."
+ (when (buffer-live-p buffer)
+ (with-current-buffer buffer
+ (setq erc--server-reconnect-timeout
+ (funcall erc--server-reconnect-timeout-scale-function
+ (or erc--server-reconnect-timeout
+ erc-server-reconnect-timeout)))
+ (let* ((reschedule (lambda (proc)
+ (when (buffer-live-p buffer)
+ (with-current-buffer buffer
+ (let ((erc-server-reconnect-timeout
+ erc--server-reconnect-timeout))
+ (delete-process proc)
+ (erc-display-message nil 'error buffer
+ "Nobody home...")
+ (erc-schedule-reconnect buffer 0))))))
+ (conchk-exp (time-add erc--server-reconnect-timeout-check
+ (current-time)))
+ (conchk-timer nil)
+ (conchk (lambda (proc)
+ (let ((status (process-status proc))
+ (xprdp (time-less-p conchk-exp (current-time))))
+ (when (or (not (eq 'connect status)) xprdp)
+ (cancel-timer conchk-timer))
+ (when (buffer-live-p buffer)
+ (cond (xprdp (erc-display-message
+ nil 'error buffer
+ "Timed out while dialing...")
+ (delete-process proc)
+ (funcall reschedule proc))
+ ((eq 'failed status)
+ (funcall reschedule proc)))))))
+ (sentinel (lambda (proc event)
+ (pcase event
+ ("open\n"
+ (run-at-time nil nil #'send-string proc
+ (format "PING %d\r\n"
+ (time-convert nil 'integer))))
+ ((or "connection broken by remote peer\n"
+ (rx bot "failed"))
+ (funcall reschedule proc)))))
+ (filter (lambda (proc _)
+ (delete-process proc)
+ (with-current-buffer buffer
+ (setq erc--server-reconnect-timeout nil))
+ (run-at-time nil nil #'erc-server-delayed-reconnect
+ buffer))))
+ (condition-case _
+ (let ((proc (funcall erc-session-connector
+ "*erc-connectivity-check*" nil
+ erc-session-server erc-session-port
+ :nowait t)))
+ (setq conchk-timer (run-at-time 1 1 conchk proc))
+ (set-process-filter proc filter)
+ (set-process-sentinel proc sentinel))
+ (file-error (funcall reschedule nil)))))))
+
(defun erc-server-filter-function (process string)
"The process filter for the ERC server."
(with-current-buffer (process-buffer process)
@@ -798,6 +950,22 @@ EVENT is the message received from the closed connection process."
erc-server-reconnecting)
(erc--server-reconnect-p event)))
+(defun erc--server-last-reconnect-on-disconnect (&rest _)
+ (remove-hook 'erc-disconnected-hook
+ #'erc--server-last-reconnect-on-disconnect t)
+ (erc--server-last-reconnect-display-reset (current-buffer)))
+
+(defun erc--server-last-reconnect-display-reset (buffer)
+ "Deactivate `erc-auto-reconnect-display'."
+ (when (buffer-live-p buffer)
+ (with-current-buffer buffer
+ (when erc--server-reconnect-display-timer
+ (cancel-timer erc--server-reconnect-display-timer)
+ (remove-hook 'erc-disconnected-hook
+ #'erc--server-last-reconnect-display-reset t)
+ (setq erc--server-reconnect-display-timer nil
+ erc--server-last-reconnect-count 0)))))
+
(defconst erc--mode-line-process-reconnecting
'(:eval (erc-with-server-buffer
(and erc--server-reconnect-timer
@@ -823,11 +991,16 @@ When `erc-server-reconnect-attempts' is a number, increment
`erc-server-reconnect-count' by INCR unconditionally."
(let ((count (and (integerp erc-server-reconnect-attempts)
(- erc-server-reconnect-attempts
- (cl-incf erc-server-reconnect-count (or incr 1))))))
- (erc-display-message nil 'error (current-buffer) 'reconnecting
+ (cl-incf erc-server-reconnect-count (or incr 1)))))
+ (proc (buffer-local-value 'erc-server-process buffer)))
+ (erc-display-message nil '(notice error) buffer 'reconnecting
?m erc-server-reconnect-timeout
?i (if count erc-server-reconnect-count "N")
?n (if count erc-server-reconnect-attempts "A"))
+ (set-process-sentinel proc #'ignore)
+ (set-process-filter proc nil)
+ (delete-process proc)
+ (erc-update-mode-line)
(setq erc-server-reconnecting nil
erc--server-reconnect-timer
(run-at-time erc-server-reconnect-timeout nil
@@ -864,18 +1037,40 @@ Conditionally try to reconnect and take appropriate action."
(erc-update-mode-line)
;; Kill server buffer if user wants it
(set-buffer-modified-p nil)
+ (defvar erc-kill-server-buffer-on-quit)
(when erc-kill-server-buffer-on-quit
(kill-buffer (current-buffer))))
;; unexpected disconnect
(erc-process-sentinel-2 event buffer))))
+(defvar-local erc--hidden-prompt-overlay nil
+ "Overlay for hiding the prompt when disconnected.")
+
+(cl-defmethod erc--reveal-prompt ()
+ (when erc--hidden-prompt-overlay
+ (delete-overlay erc--hidden-prompt-overlay)
+ (setq erc--hidden-prompt-overlay nil)))
+
+(cl-defmethod erc--conceal-prompt ()
+ (when-let (((null erc--hidden-prompt-overlay))
+ (ov (make-overlay erc-insert-marker (1- erc-input-marker)
+ nil 'front-advance)))
+ (defvar erc-prompt-hidden)
+ (overlay-put ov 'display erc-prompt-hidden)
+ (setq erc--hidden-prompt-overlay ov)))
+
+(defun erc--prompt-hidden-p ()
+ (and (marker-position erc-insert-marker)
+ (eq (get-text-property erc-insert-marker 'erc-prompt) 'hidden)))
+
(defun erc--unhide-prompt ()
(remove-hook 'pre-command-hook #'erc--unhide-prompt-on-self-insert t)
(when (and (marker-position erc-insert-marker)
(marker-position erc-input-marker))
(with-silent-modifications
- (remove-text-properties erc-insert-marker erc-input-marker
- '(display nil)))))
+ (put-text-property erc-insert-marker (1- erc-input-marker) 'erc-prompt t)
+ (erc--reveal-prompt)
+ (run-hooks 'erc--refresh-prompt-hook))))
(defun erc--unhide-prompt-on-self-insert ()
(when (and (eq this-command #'self-insert-command)
@@ -883,6 +1078,8 @@ Conditionally try to reconnect and take appropriate action."
(erc--unhide-prompt)))
(defun erc--hide-prompt (proc)
+ "Hide prompt in all buffers of server.
+Change value of property `erc-prompt' from t to `hidden'."
(erc-with-all-buffers-of-server proc nil
(when (and erc-hide-prompt
(or (eq erc-hide-prompt t)
@@ -896,9 +1093,11 @@ Conditionally try to reconnect and take appropriate action."
(marker-position erc-input-marker)
(get-text-property erc-insert-marker 'erc-prompt))
(with-silent-modifications
- (add-text-properties erc-insert-marker (1- erc-input-marker)
- `(display ,erc-prompt-hidden)))
- (add-hook 'pre-command-hook #'erc--unhide-prompt-on-self-insert 91 t))))
+ (put-text-property erc-insert-marker (1- erc-input-marker)
+ 'erc-prompt 'hidden)
+ (erc--conceal-prompt)
+ (run-hooks 'erc--refresh-prompt-hook))
+ (add-hook 'pre-command-hook #'erc--unhide-prompt-on-self-insert 80 t))))
(defun erc-process-sentinel (cproc event)
"Sentinel function for ERC process."
@@ -913,15 +1112,16 @@ Conditionally try to reconnect and take appropriate action."
(erc--register-connection)
;; assume event is 'failed
(erc-with-all-buffers-of-server cproc nil
- (setq erc-server-connected nil))
+ (setq erc-server-connected nil))
(when erc-server-ping-handler
(progn (cancel-timer erc-server-ping-handler)
(setq erc-server-ping-handler nil)))
(run-hook-with-args 'erc-disconnected-hook
(erc-current-nick) (system-name) "")
- (dolist (buf (erc-buffer-filter (lambda () (boundp 'erc-channel-users)) cproc))
- (with-current-buffer buf
- (setq erc-channel-users (make-hash-table :test 'equal))))
+ (erc-with-all-buffers-of-server cproc (lambda () erc-channel-members)
+ (when (erc--target-channel-p erc--target)
+ (setf (erc--target-channel-joined-p erc--target) nil))
+ (clrhash erc-channel-members))
;; Hide the prompt
(erc--hide-prompt cproc)
;; Decide what to do with the buffer
@@ -979,7 +1179,7 @@ Use DISPLAY-FN to show the results."
When FORCE is non-nil, bypass flood protection so that STRING is
sent directly without modifying the queue. When FORCE is the
symbol `no-penalty', exempt this round from accumulating a
-timeout penalty.
+timeout penalty and schedule it to run ASAP instead of blocking.
If TARGET is specified, look up encoding information for that
channel in `erc-encoding-coding-alist' or
@@ -987,6 +1187,11 @@ channel in `erc-encoding-coding-alist' or
See `erc-server-flood-margin' for an explanation of the flood
protection algorithm."
+ (erc--server-send string force target))
+
+(cl-defmethod erc--server-send (string force target)
+ "Encode and send STRING to `erc-server-process'.
+Expect STRING, FORCE, and TARGET to originate from `erc-server-send'."
(erc-log (concat "erc-server-send: " string "(" (buffer-name) ")"))
(setq erc-server-last-sent-time (erc-current-time))
(let ((encoding (erc-coding-system-for-target target)))
@@ -1007,14 +1212,17 @@ protection algorithm."
(when (fboundp 'set-process-coding-system)
(set-process-coding-system erc-server-process
'raw-text encoding))
- (process-send-string erc-server-process str))
+ (if (and (eq force 'no-penalty))
+ (run-at-time nil nil #'process-send-string
+ erc-server-process str)
+ (process-send-string erc-server-process str)))
;; See `erc-server-send-queue' for full
;; explanation of why we need this condition-case
(error nil)))
(setq erc-server-flood-queue
(append erc-server-flood-queue
(list (cons str encoding))))
- (erc-server-send-queue (current-buffer))))
+ (run-at-time nil nil #'erc-server-send-queue (current-buffer))))
t)
(message "ERC: No process running")
nil)))
@@ -1084,8 +1292,10 @@ protection algorithm."
nil #'erc-server-send-queue buffer)))))))
(defun erc-message (message-command line &optional force)
- "Send LINE to the server as a privmsg or a notice.
-MESSAGE-COMMAND should be either \"PRIVMSG\" or \"NOTICE\".
+ "Send LINE, possibly expanding a target specifier beforehand.
+Expect MESSAGE-COMMAND to be an IRC command with a single
+positional target parameter followed by a trailing parameter.
+
If the target is \",\", the last person you've got a message from will
be used. If the target is \".\", the last person you've sent a message
to will be used."
@@ -1269,10 +1479,12 @@ for decoding."
(let ((args (erc-response.command-args parsed-response))
(decode-target nil)
(decoded-args ()))
+ ;; FIXME this should stop after the first match.
(dolist (arg args nil)
(when (string-match "^[#&].*" arg)
(setq decode-target arg)))
(when (stringp decode-target)
+ ;; FIXME `decode-target' should be passed as TARGET.
(setq decode-target (erc-decode-string-from-target decode-target nil)))
(setf (erc-response.unparsed parsed-response)
(erc-decode-string-from-target
@@ -1327,8 +1539,6 @@ Finds hooks by looking in the `erc-server-responses' hash table."
(erc-with-server-buffer
(run-hook-with-args 'erc-timer-hook (erc-current-time)))))
-(add-hook 'erc-default-server-functions #'erc-handle-unknown-server-response)
-
(defun erc-handle-unknown-server-response (proc parsed)
"Display unknown server response's message."
(let ((line (concat (erc-response.sender parsed)
@@ -1423,7 +1633,9 @@ Would expand to:
\(fn (NAME &rest ALIASES) &optional EXTRA-FN-DOC EXTRA-VAR-DOC &rest FN-BODY)"
(declare (debug (&define [&name "erc-response-handler@"
- (symbolp &rest symbolp)]
+ ;; No `def-edebug-elem-spec' in 27.
+ ([&or integerp symbolp]
+ &rest [&or integerp symbolp])]
&optional sexp sexp def-body))
(indent defun))
(if (numberp name) (setq name (intern (format "%03i" name))))
@@ -1506,12 +1718,19 @@ add things to `%s' instead."
(chnl (erc-response.contents parsed)))
(pcase-let ((`(,nick ,login ,host)
(erc-parse-user (erc-response.sender parsed))))
+ (defvar erc-invitation)
(setq erc-invitation chnl)
(when (string= target (erc-current-nick))
(erc-display-message
parsed 'notice 'active
'INVITE ?n nick ?u login ?h host ?c chnl)))))
+(cl-defmethod erc--server-determine-join-display-context (_channel alist)
+ "Determine `erc--display-context' for JOINs."
+ (if (assq 'erc-buffer-display alist)
+ alist
+ `((erc-buffer-display . JOIN) ,@alist)))
+
(define-erc-response-handler (JOIN)
"Handle join messages."
nil
@@ -1523,31 +1742,33 @@ add things to `%s' instead."
(if (string-match "^\\(.*\\)\^g.*$" chnl)
(setq chnl (match-string 1 chnl)))
(save-excursion
- (let* ((str (cond
+ (let ((args (cond
;; If I have joined a channel
((erc-current-nick-p nick)
- (when (setq buffer (erc--open-target chnl))
+ (let ((erc--display-context
+ (erc--server-determine-join-display-context
+ chnl erc--display-context)))
+ (setq buffer (erc--open-target chnl)))
+ (when buffer
(set-buffer buffer)
(with-suppressed-warnings
((obsolete erc-add-default-channel))
(erc-add-default-channel chnl))
+ (setf (erc--target-channel-joined-p erc--target) t)
(erc-server-send (format "MODE %s" chnl)))
(erc-with-buffer (chnl proc)
(erc-channel-begin-receiving-names))
(erc-update-mode-line)
(run-hooks 'erc-join-hook)
- (erc-make-notice
- (erc-format-message 'JOIN-you ?c chnl)))
+ (list 'JOIN-you ?c chnl))
(t
(setq buffer (erc-get-buffer chnl proc))
- (erc-make-notice
- (erc-format-message
- 'JOIN ?n nick ?u login ?h host ?c chnl))))))
+ (list 'JOIN ?n nick ?u login ?h host ?c chnl)))))
(when buffer (set-buffer buffer))
(erc-update-channel-member chnl nick nick t nil nil nil nil nil host login)
;; on join, we want to stay in the new channel buffer
;;(set-buffer ob)
- (erc-display-message parsed nil buffer str))))))
+ (apply #'erc-display-message parsed 'notice buffer args))))))
(define-erc-response-handler (KICK)
"Handle kick messages received from the server." nil
@@ -1594,7 +1815,7 @@ add things to `%s' instead."
(t (erc-get-buffer tgt)))))
(with-current-buffer (or buf
(current-buffer))
- (erc-update-modes tgt mode nick host login))
+ (erc--update-modes (cdr (erc-response.command-args parsed))))
(if (or (string= login "") (string= host ""))
(erc-display-message parsed 'notice buf
'MODE-nick ?n nick
@@ -1670,6 +1891,7 @@ add things to `%s' instead."
(with-suppressed-warnings ((obsolete erc-delete-default-channel))
(erc-delete-default-channel chnl buffer))
(erc-update-mode-line buffer)
+ (defvar erc-kill-buffer-on-part)
(when erc-kill-buffer-on-part
(kill-buffer buffer))))))
@@ -1697,16 +1919,80 @@ add things to `%s' instead."
?s (if (/= erc-server-lag 1) "s" "")))
(erc-update-mode-line))))
+(defun erc--statusmsg-target (target)
+ "Return actual target from given TARGET if it has a leading prefix char."
+ (and-let* ((erc-ensure-target-buffer-on-privmsg)
+ ((not (eq erc-ensure-target-buffer-on-privmsg 'status)))
+ ((not (erc-channel-p target)))
+ (chars (erc--get-isupport-entry 'STATUSMSG 'single))
+ ((string-search (string (aref target 0)) chars))
+ (trimmed (substring target 1))
+ ((erc-channel-p trimmed)))
+ trimmed))
+
+;; Moved to this file from erc.el in ERC 5.6.
+(defvar-local erc-current-message-catalog 'english
+ "Current language or context catalog for formatting inserted messages.
+See `erc-format-message'.")
+
+;; This variable can be made public if the current design proves
+;; sufficient.
+(defvar erc--message-speaker-catalog '-speaker
+ "The \"speaker\" catalog symbol used to format PRIVMSGs and NOTICEs.
+
+This symbol defines a \"catalog\" of variables and functions
+whose names reflect their membership via a corresponding CATALOG
+component, as in \"erc-message-CATALOG-KEY\". Here, KEY refers
+to a common set of interface members (variables or functions),
+that an implementer must define:
+
+- `statusmsg' and `statusmsg-input': PRIVMSGs whose target is a
+ status-prefixed channel; the latter is the \"echoed\" version
+
+- `chan-privmsg', `query-privmsg', `chan-notice', `query-notice':
+ standard chat messages traditionally prefixed by a <nickname>
+ indicating the message's \"speaker\"
+
+- `input-chan-privmsg', `input-query-privmsg', `input-query-notice',
+ `input-chan-notice': \"echoed\" versions of the above
+
+- `ctcp-action', `ctcp-action-input', `ctcp-action-statusmsg',
+ `ctcp-action-statusmsg-input': \"CTCP ACTION\" versions of the
+ above
+
+The other part of this interface is the per-key collection of
+`format-spec' parameters members must support. For simplicity,
+this catalog currently defines a common set for all keys, some of
+which may be assigned the empty string when not applicable:
+
+ %n - nickname
+ %m - message body
+ %p - nickname's status prefix (when applicable)
+ %s - current target's STATUSMSG prefix (when applicable)
+
+As an added means of communicating with various modules, if this
+catalog's symbol has the property `erc--msg-prop-overrides',
+consumers calling `erc-display-message' will see the value added
+to the `erc--msg-props' \"environment\" in modification hooks,
+like `erc-insert-modify-hook'.")
+
+(defvar erc--speaker-status-prefix-wanted-p (gensym "erc-")
+ "Sentinel to detect whether `erc-format-@nick' has just run.")
+
(define-erc-response-handler (PRIVMSG NOTICE)
"Handle private messages, including messages in channels." nil
(let ((sender-spec (erc-response.sender parsed))
(cmd (erc-response.command parsed))
(tgt (car (erc-response.command-args parsed)))
(msg (erc-response.contents parsed)))
- (if (or (erc-ignored-user-p sender-spec)
- (erc-ignored-reply-p msg tgt proc))
+ (defvar erc-minibuffer-ignored)
+ (defvar erc-ignore-list)
+ (defvar erc-ignore-reply-list)
+ (if (or (and erc-ignore-list (erc-ignored-user-p sender-spec))
+ (and erc-ignore-reply-list (erc-ignored-reply-p msg tgt proc)))
(when erc-minibuffer-ignored
(message "Ignored %s from %s to %s" cmd sender-spec tgt))
+ (defvar erc--msg-prop-overrides)
(let* ((sndr (erc-parse-user sender-spec))
(nick (nth 0 sndr))
(login (nth 1 sndr))
@@ -1714,20 +2000,40 @@ add things to `%s' instead."
(msgp (string= cmd "PRIVMSG"))
(noticep (string= cmd "NOTICE"))
;; S.B. downcase *both* tgt and current nick
- (privp (erc-current-nick-p tgt))
- s buffer
- fnick)
- (setf (erc-response.contents parsed) msg)
+ (medown (erc-downcase (erc-current-nick)))
+ (inputp (string= medown (erc-downcase nick)))
+ (privp (string= (erc-downcase tgt) medown))
+ (erc--display-context `((erc-buffer-display . ,(intern cmd))
+ ,@erc--display-context))
+ (erc--msg-prop-overrides `((erc--tmp) ,@erc--msg-prop-overrides))
+ (erc--speaker-status-prefix-wanted-p nil)
+ (erc-current-message-catalog erc--message-speaker-catalog)
+ ;;
+ buffer statusmsg cmem-prefix fnick)
(setq buffer (erc-get-buffer (if privp nick tgt) proc))
;; Even worth checking for empty target here? (invalid anyway)
(unless (or buffer noticep (string-empty-p tgt) (eq ?$ (aref tgt 0))
(erc-is-message-ctcp-and-not-action-p msg))
+ (defvar erc-receive-query-display)
+ (defvar erc-receive-query-display-defer)
(if privp
- (when erc-auto-query
- (let ((erc-join-buffer erc-auto-query))
- (setq buffer (erc--open-target nick))))
- ;; A channel buffer has been killed but is still joined
- (setq buffer (erc--open-target tgt))))
+ (when-let ((erc-join-buffer
+ (or (and (not erc-receive-query-display-defer)
+ erc-receive-query-display)
+ (and erc-ensure-target-buffer-on-privmsg
+ (or erc-receive-query-display
+ erc-join-buffer)))))
+ (push `(erc-receive-query-display . ,(intern cmd))
+ erc--display-context)
+ (setq buffer (erc--open-target nick)))
+ (cond
+ ;; Target is a channel and contains leading @+ chars.
+ ((and-let* ((trimmed(erc--statusmsg-target tgt)))
+ (setq buffer (erc-get-buffer trimmed proc)
+ statusmsg (and buffer (substring tgt 0 1)))))
+ ;; A channel buffer has been killed but is still joined.
+ (erc-ensure-target-buffer-on-privmsg
+ (setq buffer (erc--open-target tgt))))))
(when buffer
(with-current-buffer buffer
(when privp (erc--unhide-prompt))
@@ -1736,34 +2042,43 @@ add things to `%s' instead."
;; at this point.
(erc-update-channel-member (if privp nick tgt) nick nick
privp nil nil nil nil nil host login nil nil t)
- (let ((cdata (erc-get-channel-user nick)))
- (setq fnick (funcall erc-format-nick-function
- (car cdata) (cdr cdata))))))
- (cond
- ((erc-is-message-ctcp-p msg)
- (setq s (if msgp
- (erc-process-ctcp-query proc parsed nick login host)
- (erc-process-ctcp-reply proc parsed nick login host
- (match-string 1 msg)))))
- (t
+ (defvar erc--cmem-from-nick-function)
+ (defvar erc-format-nick-function)
+ (defvar erc-show-speaker-membership-status)
+ (defvar erc-speaker-from-channel-member-function)
+ (let ((cdata (funcall erc--cmem-from-nick-function
+ (erc-downcase nick) sndr parsed)))
+ (setq fnick (funcall erc-speaker-from-channel-member-function
+ (car cdata) (cdr cdata))
+ cmem-prefix (and (or erc--speaker-status-prefix-wanted-p
+ erc-show-speaker-membership-status
+ inputp)
+ (cdr cdata))))))
+ (if (erc-is-message-ctcp-p msg)
+ (if noticep
+ (erc-process-ctcp-reply proc parsed nick login host
+ (match-string 1 msg))
+ (setq parsed (erc--ctcp-response-from-parsed
+ :parsed parsed :buffer buffer :statusmsg statusmsg
+ :prefix cmem-prefix :dispname fnick))
+ (erc-process-ctcp-query proc parsed nick login host))
(setq erc-server-last-peers (cons nick (cdr erc-server-last-peers)))
- (setq s (erc-format-privmessage
- (or fnick nick) msg
- ;; If buffer is a query buffer,
- ;; format the nick as for a channel.
- (and (not (and buffer
- (erc-query-buffer-p buffer)
- erc-format-query-as-channel-p))
- privp)
- msgp))))
- (when s
- (if (and noticep privp)
- (progn
- (run-hook-with-args 'erc-echo-notice-always-hook
- s parsed buffer nick)
- (run-hook-with-args-until-success
- 'erc-echo-notice-hook s parsed buffer nick))
- (erc-display-message parsed nil buffer s)))))))
+ (with-current-buffer (or buffer (current-buffer))
+ ;; Re-bind in case either buffer has a local value.
+ (let ((erc-current-message-catalog erc--message-speaker-catalog)
+ (msg-args (erc--determine-speaker-message-format-args
+ nick msg privp msgp inputp statusmsg
+ cmem-prefix fnick)))
+ (if (or msgp (not privp))
+ ;; This is a PRIVMSG or a NOTICE to a channel.
+ (apply #'erc-display-message parsed nil buffer msg-args)
+ ;; This is a NOTICE directed at the client's current nick.
+ (push (cons 'erc--msg (car msg-args)) erc--msg-prop-overrides)
+ (let ((fmtmsg (apply #'erc-format-message msg-args)))
+ (run-hook-with-args 'erc-echo-notice-always-hook
+ fmtmsg parsed buffer nick)
+ (run-hook-with-args-until-success
+ 'erc-echo-notice-hook fmtmsg parsed buffer nick))))))))))
(define-erc-response-handler (QUIT)
"Another user has quit IRC." nil
@@ -1842,10 +2157,6 @@ Then display the welcome message."
;;
;; > The server SHOULD send "X", not "X="; this is the normalized form.
;;
- ;; Note: for now, assume the server will only send non-empty values,
- ;; possibly with printable ASCII escapes. Though in practice, the
- ;; only two escapes we're likely to see are backslash and space,
- ;; meaning the pattern is too liberal.
(let (case-fold-search)
(mapcar
(lambda (v)
@@ -1856,7 +2167,9 @@ Then display the welcome message."
(string-match "[\\]x[0-9A-F][0-9A-F]" v start))
(setq m (substring v (+ 2 (match-beginning 0)) (match-end 0))
c (string-to-number m 16))
- (if (<= ?\ c ?~)
+ ;; In practice, this range is too liberal. The only
+ ;; escapes we're likely to see are ?\\, ?=, and ?\s.
+ (if (<= ?\s c ?~)
(setq v (concat (substring v 0 (match-beginning 0))
(string c)
(substring v (match-end 0)))
@@ -1876,11 +2189,14 @@ ambiguous and only useful for tokens supporting a single
primitive value."
(if-let* ((table (or erc--isupport-params
(erc-with-server-buffer erc--isupport-params)))
- (value (erc-compat--with-memoization (gethash key table)
+ (value (with-memoization (gethash key table)
(when-let ((v (assoc (symbol-name key)
- erc-server-parameters)))
- (if (cdr v)
- (erc--parse-isupport-value (cdr v))
+ (or erc-server-parameters
+ (erc-with-server-buffer
+ erc-server-parameters)))))
+ (if-let ((val (cdr v))
+ ((not (string-empty-p val))))
+ (erc--parse-isupport-value val)
'--empty--)))))
(pcase value
('--empty-- (unless single (list key)))
@@ -1888,6 +2204,24 @@ primitive value."
(when table
(remhash key table))))
+;; While it's better to depend on interfaces than specific types,
+;; using `cl-struct-slot-value' or similar to extract a known slot at
+;; runtime would incur a small "ducktyping" tax, which should probably
+;; be avoided when running hundreds of times per incoming message.
+;; Instead of separate keys per data type, we could increment a
+;; counter whenever a new 005 arrives.
+(defmacro erc--with-isupport-data (param var &rest body)
+ "Return structured data stored in VAR for \"ISUPPORT\" PARAM.
+Expect VAR's value to be an instance of `erc--isupport-data'. If
+VAR is uninitialized or stale, evaluate BODY and assign the
+result to VAR."
+ (declare (indent defun))
+ `(erc-with-server-buffer
+ (pcase-let (((,@(list '\` (list param '\, 'key)))
+ (erc--get-isupport-entry ',param)))
+ (or (and ,var (eq key (erc--isupport-data-key ,var)) ,var)
+ (setq ,var (progn ,@body))))))
+
(define-erc-response-handler (005)
"Set the variable `erc-server-parameters' and display the received message.
@@ -1908,8 +2242,11 @@ A server may send more than one 005 message."
key
value
negated)
- (when (string-match "^\\([A-Z]+\\)=\\(.*\\)$\\|^\\(-\\)?\\([A-Z]+\\)$"
- section)
+ (when (string-match
+ (rx bot (| (: (group (+ (any "A-Z"))) "=" (group (* nonl)))
+ (: (? (group "-")) (group (+ (any "A-Z")))))
+ eot)
+ section)
(setq key (or (match-string 1 section) (match-string 4 section))
value (match-string 2 section)
negated (and (match-string 3 section) '-))
@@ -1924,7 +2261,7 @@ A server may send more than one 005 message."
(let* ((nick (car (erc-response.command-args parsed)))
(modes (mapconcat #'identity
(cdr (erc-response.command-args parsed)) " ")))
- (erc-set-modes nick modes)
+ (erc--update-modes (cdr (erc-response.command-args parsed)))
(erc-display-message parsed 'notice 'active 's221 ?n nick ?m modes)))
(define-erc-response-handler (252)
@@ -2090,7 +2427,7 @@ See `erc-display-server-message'." nil
(let ((channel (cadr (erc-response.command-args parsed)))
(modes (mapconcat #'identity (cddr (erc-response.command-args parsed))
" ")))
- (erc-set-modes channel modes)
+ (erc--init-channel-modes channel (cddr (erc-response.command-args parsed)))
(erc-display-message
parsed 'notice (erc-get-buffer channel proc)
's324 ?c channel ?m modes)))
@@ -2162,6 +2499,7 @@ See `erc-display-server-message'." nil
(erc-display-message parsed 'notice (erc-get-buffer channel proc)
's341 ?n nick ?c channel)))
+;; FIXME update or add server user instead when channel is "*".
(define-erc-response-handler (352)
"WHO notice." nil
(pcase-let ((`(,channel ,user ,host ,_server ,nick ,away-flag)
@@ -2227,15 +2565,39 @@ See `erc-display-server-message'." nil
's391 ?s (cadr (erc-response.command-args parsed))
?t (nth 2 (erc-response.command-args parsed))))
+;; https://defs.ircdocs.horse/defs/numerics.html#rpl-visiblehost-396
+;; As of ERC 5.6, if the client hasn't yet joined any channels,
+;; there's a good chance a server user for the current nick simply
+;; doesn't exist (and there's not enough info in this reply to create
+;; one). To fix this, ERC could WHO itself on 372 or similar if it
+;; hasn't yet received a 900.
+(define-erc-response-handler (396)
+ "RPL_VISIBLEHOST or RPL_YOURDISPLAYHOST or RPL_HOSTHIDDEN." nil
+ (pcase-let* ((userhost (cadr (erc-response.command-args parsed)))
+ ;; Behavior blindly copied from event_hosthidden in irssi 1.4.
+ (rejectrx (rx (| (: bot (in ?@ ?: ?-)) (in ?* ?? ?! ?# ?& ?\s)
+ (: ?- eot))))
+ (`(,_ ,user ,host) (and (not (string-match rejectrx userhost))
+ (erc--parse-nuh userhost))))
+ (when host
+ (erc-update-user-nick (erc-current-nick) nil host user)
+ (erc-display-message parsed 'notice 'active 's396 ?s userhost))))
+
(define-erc-response-handler (401)
"No such nick/channel." nil
(let ((nick/channel (cadr (erc-response.command-args parsed))))
+ (defvar erc-whowas-on-nosuchnick)
(when erc-whowas-on-nosuchnick
(erc-log (format "cmd: WHOWAS: %s" nick/channel))
(erc-server-send (format "WHOWAS %s 1" nick/channel)))
(erc-display-message parsed '(notice error) 'active
's401 ?n nick/channel)))
+(define-erc-response-handler (402)
+ "No such server." nil
+ (erc-display-message parsed '(notice error) 'active
+ 's402 ?c (cadr (erc-response.command-args parsed))))
+
(define-erc-response-handler (403)
"No such channel." nil
(erc-display-message parsed '(notice error) 'active
@@ -2303,6 +2665,17 @@ See `erc-display-server-message'." nil
parsed
(erc-response.contents parsed)))
+(define-erc-response-handler (471)
+ "ERR_CHANNELISFULL: channel full." nil
+ (erc-display-message parsed '(notice error) nil 's471
+ ?c (cadr (erc-response.command-args parsed))
+ ?s (erc-response.contents parsed)))
+
+(define-erc-response-handler (473)
+ "ERR_INVITEONLYCHAN: channel invitation only." nil
+ (erc-display-message parsed '(notice error) nil 's473
+ ?c (cadr (erc-response.command-args parsed))))
+
(define-erc-response-handler (474)
"Banned from channel errors." nil
(erc-display-message parsed '(notice error) nil
@@ -2314,8 +2687,11 @@ See `erc-display-server-message'." nil
"Channel key needed." nil
(erc-display-message parsed '(notice error) nil 's475
?c (cadr (erc-response.command-args parsed)))
+ (defvar erc-prompt-for-channel-key)
+ (defvar erc--called-as-input-p)
(when erc-prompt-for-channel-key
(let ((channel (cadr (erc-response.command-args parsed)))
+ (erc--called-as-input-p t)
(key (read-from-minibuffer
(format "Channel %s is mode +k. Enter key (RET to cancel): "
(cadr (erc-response.command-args parsed))))))
@@ -2383,8 +2759,8 @@ See `erc-display-error-notice'." nil
;; (define-erc-response-handler (323 364 365 381 382 392 393 394 395
;; 200 201 202 203 204 205 206 208 209 211 212 213
;; 214 215 216 217 218 219 241 242 243 244 249 261
-;; 262 302 342 351 402 407 409 411 413 414 415
-;; 423 424 436 441 443 444 467 471 472 473 KILL)
+;; 262 302 342 351 407 409 411 413 414 415
+;; 423 424 436 441 443 444 467 472 KILL)
;; nil nil
;; (ignore proc parsed))
diff --git a/lisp/erc/erc-button.el b/lisp/erc/erc-button.el
index 7f0507b69e6..4b4930e5bff 100644
--- a/lisp/erc/erc-button.el
+++ b/lisp/erc/erc-button.el
@@ -52,14 +52,17 @@
;;;###autoload(autoload 'erc-button-mode "erc-button" nil t)
(define-erc-module button nil
"This mode buttonizes all messages according to `erc-button-alist'."
- ((add-hook 'erc-insert-modify-hook #'erc-button-add-buttons 'append)
- (add-hook 'erc-send-modify-hook #'erc-button-add-buttons 'append)
- (add-hook 'erc-complete-functions #'erc-button-next-function)
- (add-hook 'erc-mode-hook #'erc-button-setup))
+ ((add-hook 'erc-insert-modify-hook #'erc-button-add-buttons 30)
+ (add-hook 'erc-send-modify-hook #'erc-button-add-buttons 30)
+ (add-hook 'erc-mode-hook #'erc-button-setup 91)
+ (unless erc--updating-modules-p (erc-buffer-do #'erc-button-setup))
+ (add-hook 'erc--tab-functions #'erc-button-next)
+ (erc--modify-local-map t "<backtab>" #'erc-button-previous))
((remove-hook 'erc-insert-modify-hook #'erc-button-add-buttons)
(remove-hook 'erc-send-modify-hook #'erc-button-add-buttons)
- (remove-hook 'erc-complete-functions #'erc-button-next-function)
- (remove-hook 'erc-mode-hook #'erc-button-setup)))
+ (remove-hook 'erc-mode-hook #'erc-button-setup)
+ (remove-hook 'erc--tab-functions #'erc-button-next)
+ (erc--modify-local-map nil "<backtab>" #'erc-button-previous)))
;;; Variables
@@ -67,6 +70,11 @@
"ERC button face."
:group 'erc-faces)
+(defface erc-button-nick-default-face '((t :inherit erc-nick-default-face))
+ "Default face for a buttonized nickname."
+ :package-version '(ERC . "5.6")
+ :group 'erc-faces)
+
(defcustom erc-button-face 'erc-button
"Face used for highlighting buttons in ERC buffers.
@@ -75,8 +83,9 @@ A button is a piece of text that you can activate by pressing
:type 'face
:group 'erc-faces)
-(defcustom erc-button-nickname-face 'erc-nick-default-face
+(defcustom erc-button-nickname-face 'erc-button-nick-default-face
"Face used for ERC nickname buttons."
+ :package-version '(ERC . "5.6")
:type 'face
:group 'erc-faces)
@@ -102,7 +111,10 @@ longer than `erc-fill-column'."
:type '(choice integer boolean))
(defcustom erc-button-buttonize-nicks t
- "Flag indicating whether nicks should be buttonized or not."
+ "Flag indicating whether nicks should be buttonized.
+Note that beginning in ERC 5.6, some functionality provided by
+other modules, such as `fill-wrap', may depend on this option
+being non-nil."
:type 'boolean)
(defcustom erc-button-rfc-url "https://tools.ietf.org/html/rfc%s"
@@ -125,15 +137,14 @@ longer than `erc-fill-column'."
;; a button, it makes no sense to optimize performance by
;; bytecompiling lambdas in this alist. On the other hand, it makes
;; things hard to maintain.
- '((nicknames 0 erc-button-buttonize-nicks erc-nick-popup 0)
- (erc-button-url-regexp 0 t browse-url-button-open-url 0)
- ("<URL: *\\([^<> ]+\\) *>" 0 t browse-url-button-open-url 1)
+ '((erc-button-url-regexp 0 t browse-url-button-open-url 0)
+ ;; ("<URL: *\\([^<> ]+\\) *>" 0 t browse-url-button-open-url 1)
;;; ("(\\(\\([^~\n \t@][^\n \t@]*\\)@\\([a-zA-Z0-9.:-]+\\)\\)" 1 t finger 2 3)
;; emacs internal
("[`‘]\\([a-zA-Z][-a-zA-Z_0-9!*<=>+]+\\)['’]"
1 t erc-button-describe-symbol 1)
;; pseudo links
- ("\\bInfo:[\"]\\([^\"]+\\)[\"]" 0 t Info-goto-node 1)
+ ("\\(?:\\bInfo: ?\\|(info \\)[\"]\\(([^\"]+\\)[\"])?" 0 t info 1)
("\\b\\(Ward\\|Wiki\\|WardsWiki\\|TheWiki\\):\\([A-Z][a-z]+\\([A-Z][a-z]+\\)+\\)"
0 t (lambda (page)
(browse-url (concat "http://c2.com/cgi-bin/wiki?" page)))
@@ -158,35 +169,45 @@ REGEXP is the string matching text around the button or a symbol
strings, or an alist with the strings in the car. Note that
entries in lists or alists are considered to be nicks or other
complete words. Therefore they are enclosed in \\< and \\>
- while searching. REGEXP can also be the symbol
- `nicknames', which matches the nickname of any user on the
- current server.
+ while searching. Also, use of the special symbol `nicknames'
+ for this slot was deprecated in ERC 5.6, but users can still
+ use `erc-button-buttonize-nicks' to control whether nicks get
+ buttonized. And because customizing a corresponding CALLBACK
+ is no longer possible, an escape hatch has been provided via
+ the variable `erc-button-nickname-callback-function'.
BUTTON is the number of the regexp grouping actually matching the
- button. This is ignored if REGEXP is `nicknames'.
-
-FORM is a Lisp expression which must eval to true for the button to
- be added.
+ button.
+
+FORM is either a boolean or a special variable whose value must
+ be non-nil for the button to be added. It can also be a
+ function to call in place of `erc-button-add-button' with the
+ exact same arguments. When FORM is also a special variable,
+ ERC disregards the variable and calls the function. Note that
+ arbitrary s-expressions were deprecated in ERC 5.6 and may not
+ be respected in the future. If necessary, users can instead
+ supply a function that calls `erc-button-add-button' when such
+ an expression is non-nil.
CALLBACK is the function to call when the user push this button.
CALLBACK can also be a symbol. Its variable value will be used
as the callback function.
PAR is a number of a regexp grouping whose text will be passed to
- CALLBACK. There can be several PAR arguments. If REGEXP is
- `nicknames', these are ignored, and CALLBACK will be called with
- the nickname matched as the argument."
- :package-version '(ERC . "5.5")
+ CALLBACK. There can be several PAR arguments."
+ :package-version '(ERC . "5.6")
:type '(repeat
(list :tag "Button"
(choice :tag "Matches"
regexp
(variable :tag "Variable containing regexp")
- (const :tag "Nicknames" nicknames))
+ (repeat :tag "List of words" string)
+ (alist :key-type string :value-type sexp))
(integer :tag "Number of the regexp section that matches")
(choice :tag "When to buttonize"
(const :tag "Always" t)
- (sexp :tag "Only when this evaluates to non-nil"))
+ (function :tag "Alternative buttonizing function")
+ (variable :tag "Var with value treated as boolean"))
(function :tag "Function to call when button is pressed")
(repeat :tag "Sections of regexp to send to the function"
:inline t
@@ -201,6 +222,9 @@ PAR is a number of a regexp grouping whose text will be passed to
"URL of the EmacsWiki ELisp area."
:type 'string)
+(defvar erc-button-highlight-nick-once '(QUIT PART JOIN)
+ "Messages for which to buttonize only the first nick occurrence.")
+
(defvar erc-button-keymap
(let ((map (make-sparse-keymap)))
(define-key map (kbd "RET") #'erc-button-press-button)
@@ -232,13 +256,45 @@ constituents.")
(defvar erc-button-keys-added nil
"Internal variable used to keep track of whether we've added the
global-level ERC button keys yet.")
+(make-obsolete-variable 'erc-button-keys-added "no longer relevant" "30.1")
+
+(defvar-local erc-button--has-nickname-entry nil
+ "Whether `erc-button-alist' contains a legacy `nicknames' entry.")
(defun erc-button-setup ()
- "Add ERC mode-level button movement keys. This is only done once."
- ;; Add keys.
- (unless erc-button-keys-added
- (define-key erc-mode-map (kbd "<backtab>") #'erc-button-previous)
- (setq erc-button-keys-added t)))
+ "Perform major-mode setup for ERC's button module.
+Note that prior to ERC 5.6, this function used to modify
+`erc-mode-map', but that's now handled by the mode toggles
+themselves."
+ (setq erc-button-keys-added t)
+ (cl-assert (derived-mode-p 'erc-mode))
+ ;; It would probably suffice to run this in server buffers alone,
+ ;; even though buttonizing happens in all ERC buffers and users have
+ ;; been known to set `erc-button-alist' locally.
+ (dolist (entry erc-button-alist)
+ (pcase entry
+ ((or `(nicknames ,_ ,sym . ,_) `('nicknames ,_ ,sym . ,_))
+ (setq erc-button--has-nickname-entry t)
+ (unless (eq sym 'erc-button-buttonize-nicks)
+ (erc--warn-once-before-connect 'erc-button-mode
+ "The legacy `nicknames' entry in `erc-button-alist'"
+ " is deprecated. See doc string for details.")))
+ ((and `(,_ ,_ ,form . ,_)
+ (guard (not (or (and (symbolp form)
+ (special-variable-p form))
+ (functionp form)))))
+ (erc--warn-once-before-connect 'erc-button-mode
+ "Arbitrary sexps for the third, FORM slot of `erc-button-alist'"
+ " entries are deprecated. Either use a variable or a function"
+ " that conditionally calls `erc-button-add-button'.")))))
+
+(defvar erc-button-nickname-callback-function #'erc-button--perform-nick-popup
+ "Escape hatch for users needing a non-standard nick-button callback.
+Value should be a function accepting a NICK and any number of
+trailing arguments that are as yet unspecified. Runs when
+clicking \\`<mouse-1>' or hitting \\`RET' atop a nickname button.")
+(make-obsolete-variable 'erc-button-nickname-callback-function
+ "default provides essential functionality" "30.1")
(defun erc-button-add-buttons ()
"Find external references in the current buffer and make buttons of them.
@@ -252,6 +308,11 @@ specified by `erc-button-alist'."
(alist erc-button-alist)
regexp)
(erc-button-remove-old-buttons)
+ (unless (or erc-button--has-nickname-entry
+ (not erc-button-buttonize-nicks))
+ (erc-button-add-nickname-buttons
+ `(_ _ erc-button--modify-nick-function
+ ,erc-button-nickname-callback-function)))
(dolist (entry alist)
(if (or (eq (car entry) 'nicknames)
;; Old form retained for backward compatibility.
@@ -275,35 +336,187 @@ specified by `erc-button-alist'."
(concat "\\<" (regexp-quote (car elem)) "\\>")
entry)))))))))))
+(defun erc-button--extract-form (form)
+ ;; If a special-variable is also a function, favor the function.
+ (cond ((eq t form) t)
+ ((functionp form) form)
+ ((and (symbolp form) (special-variable-p form))
+ (while (let ((val (symbol-value form)))
+ (prog1 (and (not (eq val form))
+ (symbolp val)
+ (special-variable-p val))
+ (setq form val))))
+ form)
+ (t (eval form t))))
+
+(cl-defstruct erc-button--nick
+ ( bounds nil :type cons
+ ;; Indicates the nick's position in the current message. BEG is
+ ;; normally also point.
+ :documentation "A cons of (BEG . END).")
+ ( data nil :type (or null cons)
+ ;; When non-nil, the CAR must be a non-casemapped nickname. For
+ ;; compatibility, the CDR should probably be nil, but this may
+ ;; have to change eventually. If non-nil, the entire cons should
+ ;; be mutated rather than replaced because it's used as a key in
+ ;; hash tables and text-property searches.
+ :documentation "A unique cons whose car is a nickname.")
+ ( downcased nil :type (or null string)
+ :documentation "The case-mapped nickname sans text properties.")
+ ( user nil :type (or null erc-server-user)
+ ;; Not necessarily present in `erc-server-users'.
+ :documentation "A possibly nil or spoofed `erc-server-user'.")
+ ( cusr nil :type (or null erc-channel-user)
+ ;; The CDR of a value from an `erc-channel-members' table.
+ :documentation "A possibly nil `erc-channel-user'.")
+ ( nickname-face erc-button-nickname-face :type symbol
+ :documentation "Temp `erc-button-nickname-face' while buttonizing.")
+ ( mouse-face erc-button-mouse-face :type symbol
+ :documentation "Function to return possibly cached face.")
+ ( face-cache nil :type (or null function)))
+
+;; This variable is intended to serve as a "core" to be wrapped by
+;; (built-in) modules during setup. It's unclear whether
+;; `add-function's practice of removing existing advice before
+;; re-adding it is desirable when integrating modules since we're
+;; mostly concerned with ensuring one "piece" precedes or follows
+;; another (specific piece), which may not yet (or ever) be present.
+
+(defvar erc-button--modify-nick-function #'identity
+ "Function to possibly modify aspects of nick being buttonized.
+Called with one argument, an `erc-button--nick' object, or nil.
+The function should return the same (or similar) object when
+buttonizing ought to proceed and nil otherwise. While running,
+all faces defined in `erc-button' are bound temporarily and can
+be updated at will.")
+
+(defvar-local erc-button--phantom-cmems nil)
+
+(defvar erc-button--fallback-cmem-function
+ #'erc-button--get-user-from-spkr-prop
+ "Function to determine channel member if not found in the usual places.
+Called with DOWNCASED-NICK, NICK, NICK-BOUNDS, and COUNT when
+`erc-button-add-nickname-buttons' cannot find a user object for
+DOWNCASED-NICK in `erc-channel-members' or `erc-server-users'.
+NICK-BOUNDS is a cons of buffer positions, and COUNT is a number
+incremented with each visit, starting at 1.")
+
+(defun erc-button--get-user-from-spkr-prop (_ _ _ count)
+ "Attempt to obtain an `erc-channel-user' from current \"msg props\".
+But only do so when COUNT is 1, meaning this is the first button
+candidate in the just-inserted message."
+ (and-let* (((= 1 count))
+ (nick (erc--check-msg-prop 'erc--spkr)))
+ (gethash nick erc-channel-members)))
+
+;; Historical or fictitious users. As long as these two structs
+;; remain superficial "subclasses" with the same slots and defaults,
+;; they can live here instead of in erc-common.el.
+(cl-defstruct (erc--phantom-channel-user (:include erc-channel-user)))
+(cl-defstruct (erc--phantom-server-user (:include erc-server-user)))
+
+(defun erc-button--add-phantom-speaker (downcased nuh _parsed)
+ (pcase-let* ((`(,nick ,login ,host) nuh)
+ (cmem (gethash downcased erc-button--phantom-cmems))
+ (user (or (car cmem)
+ (make-erc--phantom-server-user
+ :nickname nick
+ :host (and (not (string-empty-p host)) host)
+ :login (and (not (string-empty-p login)) login))))
+ (cuser (or (cdr cmem)
+ (make-erc--phantom-channel-user
+ :last-message-time (current-time)))))
+ (puthash downcased (cons user cuser) erc-button--phantom-cmems)
+ (cons user cuser)))
+
+(defun erc-button--get-phantom-cmem (down _word _bounds _count)
+ (gethash down erc-button--phantom-cmems))
+
+(define-minor-mode erc-button--phantom-users-mode
+ "Minor mode to recognize unknown speakers.
+Expect to be used by module setup code for creating placeholder
+users on the fly during history playback. Treat an unknown
+\"PRIVMSG\" speaker, like \"<bob>\", as if they previously
+appeared in a prior \"353\" message and are thus a known member
+of the channel. However, don't bother creating an actual
+`erc-channel-user' object because their status prefix is unknown.
+Instead, just spoof an `erc-server-user' and stash it during
+\"PRIVMSG\" handling via `erc--cmem-from-nick-function' and
+retrieve it during buttonizing via
+`erc-button--fallback-cmem-function'."
+ :interactive nil
+ (if erc-button--phantom-users-mode
+ (progn
+ (add-function :after-until (local 'erc--cmem-from-nick-function)
+ #'erc-button--add-phantom-speaker '((depth . 30)))
+ (add-function :after-until (local 'erc-button--fallback-cmem-function)
+ #'erc-button--get-phantom-cmem '((depth . 50)))
+ (setq erc-button--phantom-cmems (make-hash-table :test #'equal)))
+ (remove-function (local 'erc--cmem-from-nick-function)
+ #'erc-button--add-phantom-speaker)
+ (remove-function (local 'erc-button--fallback-cmem-function)
+ #'erc-button--get-phantom-cmem)
+ (kill-local-variable 'erc-button--phantom-cmems)))
+
(defun erc-button-add-nickname-buttons (entry)
"Search through the buffer for nicknames, and add buttons."
- (let ((form (nth 2 entry))
- (fun (nth 3 entry))
- bounds word)
- (when (or (eq t form)
- (eval form t))
- (goto-char (point-min))
- (while (erc-forward-word)
- (when (setq bounds (erc-bounds-of-word-at-point))
- (setq word (buffer-substring-no-properties
- (car bounds) (cdr bounds)))
- (when (or (and (erc-server-buffer-p) (erc-get-server-user word))
- (and erc-channel-users (erc-get-channel-user word)))
- (erc-button-add-button (car bounds) (cdr bounds)
- fun t (list word))))))))
+ (when-let ((form (nth 2 entry))
+ ;; Spoof `form' slot of default legacy `nicknames' entry
+ ;; so `erc-button--extract-form' sees a function value.
+ (form (let ((erc-button-buttonize-nicks
+ (and erc-button-buttonize-nicks
+ erc-button--modify-nick-function)))
+ (erc-button--extract-form form)))
+ (oncep (if-let ((erc-button-highlight-nick-once)
+ (c (erc--check-msg-prop 'erc--cmd))
+ ((memq c erc-button-highlight-nick-once)))
+ 1 0))
+ (seen 0))
+ (goto-char (point-min))
+ (while-let
+ (((or (zerop seen) (zerop oncep)))
+ ((erc-forward-word))
+ (bounds (or (and (= 1 (cl-incf seen)) (erc--get-speaker-bounds))
+ (erc-bounds-of-word-at-point)))
+ (word (buffer-substring-no-properties (car bounds) (cdr bounds)))
+ (down (erc-downcase word)))
+ (let* ((nick-obj t)
+ (cmem (and erc-channel-members
+ (or (gethash down erc-channel-members)
+ (funcall erc-button--fallback-cmem-function
+ down word bounds seen))))
+ (user (or (and cmem (car cmem))
+ (and erc-server-users (gethash down erc-server-users))))
+ (data (list word)))
+ (when (or (not (functionp form))
+ (and user
+ (setq nick-obj (funcall form (make-erc-button--nick
+ :bounds bounds :data data
+ :downcased down :user user
+ :cusr (cdr cmem)))
+ data (erc-button--nick-data nick-obj)
+ bounds (erc-button--nick-bounds nick-obj))))
+ (erc-button-add-button (car bounds) (cdr bounds) (nth 3 entry)
+ nick-obj data))))))
(defun erc-button-add-buttons-1 (regexp entry)
"Search through the buffer for matches to ENTRY and add buttons."
(goto-char (point-min))
- (while (re-search-forward regexp nil t)
- (let ((start (match-beginning (nth 1 entry)))
- (end (match-end (nth 1 entry)))
- (form (nth 2 entry))
- (fun (nth 3 entry))
- (data (mapcar #'match-string-no-properties (nthcdr 4 entry))))
- (when (or (eq t form)
- (eval form t))
- (erc-button-add-button start end fun nil data regexp)))))
+ (let (buttonizer)
+ (while
+ (and (re-search-forward regexp nil t)
+ (or buttonizer
+ (setq buttonizer
+ (and-let*
+ ((raw-form (nth 2 entry))
+ (res (or (eq t raw-form)
+ (erc-button--extract-form raw-form))))
+ (if (functionp res) res #'erc-button-add-button)))))
+ (let ((start (match-beginning (nth 1 entry)))
+ (end (match-end (nth 1 entry)))
+ (fun (nth 3 entry))
+ (data (mapcar #'match-string-no-properties (nthcdr 4 entry))))
+ (funcall buttonizer start end fun nil data regexp)))))
(defun erc-button-remove-old-buttons ()
"Remove all existing buttons.
@@ -315,7 +528,8 @@ that `erc-button-add-button' adds, except for the face."
'(erc-callback nil
erc-data nil
mouse-face nil
- keymap nil)))
+ keymap nil))
+ (erc--restore-important-text-props '(mouse-face)))
(defun erc-button-add-button (from to fun nick-p &optional data regexp)
"Create a button between FROM and TO with callback FUN and data DATA.
@@ -343,13 +557,20 @@ REGEXP is the regular expression which matched for this button."
(move-marker pos (point))))))
(if nick-p
(when erc-button-nickname-face
- (erc-button-add-face from to erc-button-nickname-face))
+ (erc--merge-prop from to 'font-lock-face
+ (if (erc-button--nick-p nick-p)
+ (erc-button--nick-nickname-face nick-p)
+ erc-button-nickname-face)
+ nil (and (erc-button--nick-p nick-p)
+ (erc-button--nick-face-cache nick-p))))
(when erc-button-face
- (erc-button-add-face from to erc-button-face)))
+ (erc--merge-prop from to 'font-lock-face erc-button-face)))
(add-text-properties
from to
- (nconc (and erc-button-mouse-face
- (list 'mouse-face erc-button-mouse-face))
+ (nconc (and-let* ((face (or (and (erc-button--nick-p nick-p)
+ (erc-button--nick-mouse-face nick-p))
+ erc-button-mouse-face)))
+ (list 'mouse-face face))
(list 'erc-callback fun)
(list 'keymap erc-button-keymap)
(list 'rear-nonsticky t)
@@ -405,6 +626,7 @@ call it with the value of the `erc-data' text property."
(defun erc-button-next-function ()
"Pseudo completion function that actually jumps to the next button.
For use on `completion-at-point-functions'."
+ (declare (obsolete erc-nickserv-identify "30.1"))
;; FIXME: This is an abuse of completion-at-point-functions.
(when (< (point) (erc-beg-of-input-line))
(let ((start (point)))
@@ -422,27 +644,71 @@ For use on `completion-at-point-functions'."
(error "No next button"))
t)))))
-(defun erc-button-next ()
- "Go to the next button in this buffer."
- (interactive)
- (let ((f (erc-button-next-function)))
- (if f (funcall f))))
-
-(defun erc-button-previous ()
- "Go to the previous button in this buffer."
- (interactive)
- (let ((here (point)))
- (when (< here (erc-beg-of-input-line))
- (while (and (get-text-property here 'erc-callback)
- (not (= here (point-min))))
- (setq here (1- here)))
- (while (and (not (get-text-property here 'erc-callback))
- (not (= here (point-min))))
- (setq here (1- here)))
- (if (> here (point-min))
- (goto-char here)
- (error "No previous button"))
- t)))
+(defvar erc-button--prev-next-predicate-functions
+ '(erc-button--end-of-button-p)
+ "Abnormal hook whose members can return non-nil to continue searching.
+Otherwise, if all members return nil, point will stay at the
+current button. Called with a single arg, a buffer position
+greater than `point-min' with a text property of `erc-callback'.")
+
+(defun erc-button--end-of-button-p (point)
+ (get-text-property (1- point) 'erc-callback))
+
+(defun erc--button-next (arg)
+ (let* ((nextp (prog1 (>= arg 1) (setq arg (max 1 (abs arg)))))
+ (search-fn (if nextp
+ #'next-single-char-property-change
+ #'previous-single-char-property-change))
+ (start (point))
+ (p start))
+ (while (progn
+ ;; Break out of current search context.
+ (when-let ((low (max (point-min) (1- (pos-bol))))
+ (high (min (point-max) (1+ (pos-eol))))
+ (prop (get-text-property p 'erc-callback))
+ (q (if nextp
+ (text-property-not-all p high
+ 'erc-callback prop)
+ (funcall search-fn p 'erc-callback nil low)))
+ ((< low q high)))
+ (setq p q))
+ ;; Assume that buttons occur frequently enough that
+ ;; omitting LIMIT is acceptable.
+ (while
+ (and (setq p (funcall search-fn p 'erc-callback))
+ (if nextp (< p erc-insert-marker) (/= p (point-min)))
+ (run-hook-with-args-until-success
+ 'erc-button--prev-next-predicate-functions p)))
+ (and arg
+ (< (point-min) p erc-insert-marker)
+ (goto-char p)
+ (not (zerop (cl-decf arg))))))
+ (when (= (point) start)
+ (user-error (if nextp "No next button" "No previous button")))
+ t))
+
+(defun erc-button-next (&optional arg)
+ "Go to the ARGth next button."
+ (declare (advertised-calling-convention (arg) "30.1"))
+ (interactive "p")
+ (erc--button-next (or arg 1)))
+
+(defun erc-button-previous (&optional arg)
+ "Go to ARGth previous button."
+ (declare (advertised-calling-convention (arg) "30.1"))
+ (interactive "p")
+ (erc--button-next (- (or arg 1))))
+
+(defun erc-button-previous-of-nick (arg)
+ "Go to ARGth previous button for nick at point."
+ (interactive "p")
+ (if-let* ((prop (get-text-property (point) 'erc-data))
+ (erc-button--prev-next-predicate-functions
+ (cons (lambda (p)
+ (not (equal (get-text-property p 'erc-data) prop)))
+ erc-button--prev-next-predicate-functions)))
+ (erc--button-next (- arg))
+ (user-error "No nick at point")))
(defun erc-browse-emacswiki (thing)
"Browse to THING in the emacs-wiki."
@@ -455,20 +721,20 @@ For use on `completion-at-point-functions'."
;;; Nickname buttons:
(defcustom erc-nick-popup-alist
- '(("DeOp" . (erc-cmd-DEOP nick))
- ("Kick" . (erc-cmd-KICK (concat nick " "
- (read-from-minibuffer
- (concat "Kick " nick ", reason: ")))))
- ("Msg" . (erc-cmd-MSG (concat nick " "
- (read-from-minibuffer
- (concat "Message to " nick ": ")))))
- ("Op" . (erc-cmd-OP nick))
- ("Query" . (erc-cmd-QUERY nick))
- ("Whois" . (erc-cmd-WHOIS nick))
- ("Lastlog" . (erc-cmd-LASTLOG nick)))
+ '(("DeOp" . erc-cmd-DEOP)
+ ("Kick" . erc-button-cmd-KICK)
+ ("Msg" . erc-button-cmd-MSG)
+ ("Op" . erc-cmd-OP)
+ ("Query" . erc-cmd-QUERY)
+ ("Whois" . erc-cmd-WHOIS)
+ ("Lastlog" . erc-cmd-LASTLOG))
"An alist of possible actions to take on a nickname.
-An entry looks like (\"Action\" . SEXP) where SEXP is evaluated with
-the variable `nick' bound to the nick in question.
+For all entries (ACTION . FUNC), ERC offers ACTION as a possible
+completion item and calls the selected entry's FUNC with the
+buttonized nickname at point as the only argument. For
+historical reasons, FUNC can also be an arbitrary sexp, in which
+case, ERC binds the nick in question to the variable `nick' and
+evaluates the expression.
Examples:
(\"DebianDB\" .
@@ -476,18 +742,52 @@ Examples:
(format
\"ldapsearch -x -P 2 -h db.debian.org -b dc=debian,dc=org ircnick=%s\"
nick)))"
+ :package-version '(ERC . "5.6")
:type '(repeat (cons (string :tag "Op")
- sexp)))
+ (choice function sexp))))
+
+(defun erc-button-cmd-KICK (nick)
+ "Prompt for a reason, then kick NICK via `erc-cmd-KICK'.
+In server buffers, also prompt for a channel."
+ (erc-cmd-KICK
+ (or (and erc--target (erc-default-target))
+ (let ((targets (mapcar (lambda (b)
+ (cons (erc--target-string
+ (buffer-local-value 'erc--target b))
+ b))
+ (erc-channel-list erc-server-process))))
+ (completing-read (format "Channel (%s): " (caar targets))
+ targets (pcase-lambda (`(,_ . ,buf))
+ (with-current-buffer buf
+ (erc-get-channel-user nick)))
+ t nil t (caar targets))))
+ nick
+ (read-string "Reason: ")))
+
+(defun erc-button-cmd-MSG (nick)
+ "Prompt for a message to NICK, and send it via `erc-cmd-MSG'."
+ (let ((msg (read-string (concat "Message to " nick ": "))))
+ (erc-cmd-MSG (concat nick " " msg))))
+
+(defvar-local erc-button--nick-popup-alist nil
+ "Internally controlled items for `erc-nick-popup-alist'.")
(defun erc-nick-popup (nick)
(let* ((completion-ignore-case t)
+ (alist (append erc-nick-popup-alist erc-button--nick-popup-alist))
(action (completing-read (format-message
"What action to take on `%s'? " nick)
- erc-nick-popup-alist))
- (code (cdr (assoc action erc-nick-popup-alist))))
+ alist))
+ (code (cdr (assoc action alist))))
(when code
(erc-set-active-buffer (current-buffer))
- (eval code `((nick . ,nick))))))
+ (if (functionp code)
+ (funcall code nick)
+ (eval code `((nick . ,nick)))))))
+
+(defun erc-button--perform-nick-popup (nick &rest _)
+ "Call `erc-nick-popup' with NICK."
+ (erc-nick-popup nick))
;;; Callback functions
(defun erc-button-describe-symbol (symbol-name)
@@ -511,6 +811,71 @@ and `apropos' for other symbols."
(message "@%s is %d:%02d local time"
beats hours minutes)))
+(defun erc-button--display-error-with-buttons
+ (from to fun nick-p &optional data regexp)
+ "Replace command in region with keys and return new bounds"
+ (let* ((o (buffer-substring from to))
+ (s (substitute-command-keys o))
+ (erc-button-face (and (equal o s) erc-button-face)))
+ (delete-region from to)
+ (insert s)
+ (erc-button-add-button from (point) fun nick-p data regexp)))
+
+;;;###autoload
+(defun erc-button--display-error-notice-with-keys (maybe-buffer &rest strings)
+ "Add help keys to STRINGS for configuration-related admonishments.
+Return inserted result. Expect MAYBE-BUFFER to be an ERC buffer,
+a string, or nil. When it's a buffer, specify the `buffer'
+argument when calling `erc-display-message'. Otherwise, add it
+to STRINGS. If STRINGS contains any trailing non-nil
+non-strings, concatenate leading string members before applying
+`format'. Otherwise, just concatenate everything."
+ (defvar erc-stamp--skip)
+ (let* ((buffer (if (bufferp maybe-buffer)
+ maybe-buffer
+ (when (stringp maybe-buffer)
+ (push maybe-buffer strings))
+ 'active))
+ (op (if (seq-every-p (lambda (o) (or (not o) (stringp o)))
+ (cdr strings))
+ #'concat
+ (let ((head (pop strings)))
+ (while (or (stringp (car strings))
+ (and strings (not (car strings))))
+ (setq head (concat head (pop strings))))
+ (push head strings))
+ #'format))
+ (string (apply op strings))
+ ;; Avoid timestamps unless left-sided.
+ (erc-stamp--skip (or (bound-and-true-p erc-stamp--display-margin-mode)
+ (not (fboundp 'erc-timestamp-offset))
+ (zerop (erc-timestamp-offset))))
+ (erc-insert-post-hook
+ (cons (lambda ()
+ (setq string (buffer-substring (point-min)
+ (1- (point-max)))))
+ erc-insert-post-hook))
+ (erc-button-alist
+ `((,(rx "\\[" (group (+ (not "]"))) "]") 0
+ erc-button--display-error-with-buttons
+ erc-button-describe-symbol 1)
+ ,@erc-button-alist)))
+ (erc-display-message nil '(t notice error) buffer string)
+ string))
+
+;;;###autoload
+(defun erc-button--display-error-notice-with-keys-and-warn (&rest args)
+ "Like `erc-button--display-error-notice-with-keys' but also warn."
+ (let ((string (apply #'erc-button--display-error-notice-with-keys args)))
+ (with-temp-buffer
+ (insert string)
+ (goto-char (point-min))
+ (with-syntax-table lisp-mode-syntax-table
+ (skip-syntax-forward "^-"))
+ (forward-char)
+ (erc--lwarn
+ 'erc :warning (buffer-substring-no-properties (point) (point-max))))))
+
(provide 'erc-button)
;;; erc-button.el ends here
diff --git a/lisp/erc/erc-capab.el b/lisp/erc/erc-capab.el
index 635ec9dd62a..ca86e88fccb 100644
--- a/lisp/erc/erc-capab.el
+++ b/lisp/erc/erc-capab.el
@@ -89,6 +89,7 @@ character not found in IRC nicknames to avoid confusion."
;;; Define module:
;;;###autoload(autoload 'erc-capab-identify-mode "erc-capab" nil t)
+(put 'capab-identify 'erc-group 'erc-capab)
(define-erc-module capab-identify nil
"Handle dancer-ircd's CAPAB IDENTIFY-MSG and IDENTIFY-CTCP."
;; append so that `erc-server-parameters' is already set by `erc-server-005'
diff --git a/lisp/erc/erc-common.el b/lisp/erc/erc-common.el
index 163da111624..8388efe062c 100644
--- a/lisp/erc/erc-common.el
+++ b/lisp/erc/erc-common.el
@@ -29,20 +29,54 @@
(defvar erc--casemapping-rfc1459)
(defvar erc--casemapping-rfc1459-strict)
(defvar erc-channel-users)
-(defvar erc-dbuf)
-(defvar erc-log-p)
+(defvar erc-insert-this)
+(defvar erc-modules)
+(defvar erc-send-this)
+(defvar erc-server-process)
(defvar erc-server-users)
(defvar erc-session-server)
(declare-function erc--get-isupport-entry "erc-backend" (key &optional single))
+(declare-function erc--init-cusr-fallback-status "erc" (v h o a q))
(declare-function erc-get-buffer "erc" (target &optional proc))
(declare-function erc-server-buffer "erc" nil)
+(declare-function widget-apply-action "wid-edit" (widget &optional event))
+(declare-function widget-at "wid-edit" (&optional pos))
+(declare-function widget-create-child-and-convert "wid-edit"
+ (parent type &rest args))
+(declare-function widget-default-format-handler "wid-edit" (widget escape))
+(declare-function widget-get-sibling "wid-edit" (widget))
+(declare-function widget-move "wid-edit" (arg &optional suppress-echo))
+(declare-function widget-type "wid-edit" (widget))
(cl-defstruct erc-input
- string insertp sendp)
-
-(cl-defstruct (erc--input-split (:include erc-input))
- lines cmdp)
+ "Object shared among members of `erc-pre-send-functions'.
+Any use outside of the hook is not supported."
+ ( string "" :type string
+ :documentation "String to send and, without `substxt', insert.
+ERC treats separate lines as separate messages.")
+ ( insertp nil :type boolean
+ :documentation "Whether to insert outgoing message.
+When nil, ERC still sends `string'.")
+ ( sendp nil :type boolean
+ :documentation "Whether to send and (for compat reasons) insert.
+To insert without sending, define a (slash) command.")
+ ( substxt nil :type (or function string null)
+ :documentation "Alternate string to insert without splitting.
+The function form is for internal use.")
+ ( refoldp nil :type boolean
+ :documentation "Whether to resplit a possibly overlong `string'.
+ERC only refolds `string', never `substxt'."))
+
+(cl-defstruct (erc--input-split (:include erc-input
+ (string "" :read-only t)
+ (insertp erc-insert-this)
+ (sendp (with-suppressed-warnings
+ ((obsolete erc-send-this))
+ erc-send-this))))
+ (lines nil :type (list-of string))
+ (abortp nil :type (list-of symbol))
+ (cmdp nil :type boolean))
(cl-defstruct (erc-server-user (:type vector) :named)
;; User data
@@ -50,8 +84,23 @@
;; Buffers
(buffers nil))
-(cl-defstruct (erc-channel-user (:type vector) :named)
- voice halfop op admin owner
+(cl-defstruct (erc-channel-user (:type vector)
+ (:constructor
+ erc-channel-user--make
+ (&key (status 0) (last-message-time nil)))
+ (:constructor
+ make-erc-channel-user
+ ( &key voice halfop op admin owner
+ last-message-time
+ &aux (status
+ (if (or voice halfop op admin owner)
+ (erc--init-cusr-fallback-status
+ voice halfop op admin owner)
+ 0))))
+ :named)
+ "Object containing channel-specific data for a single user."
+ ;; voice halfop op admin owner
+ (status 0 :type integer)
;; Last message time (in the form of the return value of
;; (current-time)
;;
@@ -62,16 +111,13 @@
(string "" :type string :documentation "Received name of target.")
(symbol nil :type symbol :documentation "Case-mapped name as symbol."))
-;; At some point, it may make sense to add a query type with an
-;; account field, which may help support reassociation across
-;; reconnects and nick changes (likely requires v3 extensions).
-;;
-;; These channel variants should probably take on a `joined' field to
-;; track "joinedness", which `erc-server-JOIN', `erc-server-PART',
-;; etc. should toggle. Functions like `erc--current-buffer-joined-p'
-;; may find it useful.
+;; At some point, it may make sense to add a separate query type,
+;; possibly with an account field to help reassociation across
+;; reconnects and nick changes.
+
+(cl-defstruct (erc--target-channel (:include erc--target))
+ (joined-p nil :type boolean :documentation "Whether channel is joined."))
-(cl-defstruct (erc--target-channel (:include erc--target)))
(cl-defstruct (erc--target-channel-local (:include erc--target-channel)))
;; Beginning in 5.5/29.1, the `tags' field may take on one of two
@@ -85,45 +131,90 @@
(contents "" :type string)
(tags '() :type list))
-;; TODO move goodies modules here after 29 is released.
-(defconst erc--features-to-modules
- '((erc-pcomplete completion pcomplete)
- (erc-capab capab-identify)
- (erc-join autojoin)
- (erc-page page ctcp-page)
- (erc-sound sound ctcp-sound)
- (erc-stamp stamp timestamp)
- (erc-services services nickserv))
- "Migration alist mapping a library feature to module names.
-Keys need not be unique: a library may define more than one
-module. Sometimes a module's downcased alias will be its
-canonical name.")
-
-(defconst erc--modules-to-features
- (let (pairs)
- (pcase-dolist (`(,feature . ,names) erc--features-to-modules)
- (dolist (name names)
- (push (cons name feature) pairs)))
- (nreverse pairs))
- "Migration alist mapping a module's name to its home library feature.")
-
-(defconst erc--module-name-migrations
- (let (pairs)
- (pcase-dolist (`(,_ ,canonical . ,rest) erc--features-to-modules)
- (dolist (obsolete rest)
- (push (cons obsolete canonical) pairs)))
- pairs)
- "Association list of obsolete module names to canonical names.")
-
+(cl-defstruct (erc--ctcp-response
+ (:include erc-response)
+ (:constructor
+ erc--ctcp-response-from-parsed
+ (&key parsed buffer statusmsg prefix dispname
+ &aux (unparsed (erc-response.unparsed parsed))
+ (sender (erc-response.sender parsed))
+ (command (erc-response.command parsed))
+ (command-args (erc-response.command-args parsed))
+ (contents (erc-response.contents parsed))
+ (tags (erc-response.tags parsed)))))
+ "Data for a processed CTCP query or reply."
+ (buffer nil :type (or buffer null))
+ (statusmsg nil :type (or null string))
+ (prefix nil :type (or erc-channel-user null))
+ (dispname nil :type (or string null)))
+
+(cl-defstruct erc--isupport-data
+ "Abstract \"class\" for parsed ISUPPORT data.
+For use with the macro `erc--with-isupport-data'."
+ (key nil :type (or null cons)))
+
+(cl-defstruct (erc--parsed-prefix (:include erc--isupport-data))
+ "Server-local data for recognized membership-status prefixes.
+Derived from the advertised \"PREFIX\" ISUPPORT parameter."
+ ( letters "vhoaq" :type string
+ :documentation "Status letters ranked lowest to highest.")
+ ( statuses "+%@&~" :type string
+ :documentation "Status prefixes ranked lowest to highest.")
+ ( alist nil :type (list-of cons)
+ :documentation "Alist of letters-prefix pairs."))
+
+(cl-defstruct (erc--channel-mode-types (:include erc--isupport-data))
+ "Server-local \"CHANMODES\" data."
+ (fallbackp nil :type boolean)
+ (table (make-char-table 'erc--channel-mode-types) :type char-table)
+ (shortargs (make-hash-table :test #'equal)))
+
+;; After dropping 28, we can use prefixed "erc-autoload" cookies.
(defun erc--normalize-module-symbol (symbol)
- "Return preferred SYMBOL for `erc-modules'."
- (setq symbol (intern (downcase (symbol-name symbol))))
- (or (cdr (assq symbol erc--module-name-migrations)) symbol))
+ "Return preferred SYMBOL for `erc--module'."
+ (while-let ((canonical (get symbol 'erc--module))
+ ((not (eq canonical symbol))))
+ (setq symbol canonical))
+ symbol)
+
+(defvar erc--inside-mode-toggle-p nil
+ "Non-nil when a module's mode toggle is updating module membership.
+This serves as a flag to inhibit the mutual recursion that would
+otherwise occur between an ERC-defined minor-mode function, such
+as `erc-services-mode', and the custom-set function for
+`erc-modules'. For historical reasons, the latter calls
+`erc-update-modules', which, in turn, enables the minor-mode
+functions for all member modules. Also non-nil when a mode's
+widget runs its set function.")
+
+(defun erc--favor-changed-reverted-modules-state (name op)
+ "Be more nuanced in displaying Custom state of `erc-modules'.
+When `customized-value' differs from `saved-value', allow widget
+to behave normally and show \"SET for current session\", as
+though `customize-set-variable' or similar had been applied.
+However, when `customized-value' and `standard-value' match but
+differ from `saved-value', prefer showing \"CHANGED outside
+Customize\" to prevent the widget from seeing a `standard'
+instead of a `set' state, which precludes any actual saving."
+ ;; Although the button "Apply and save" is fortunately grayed out,
+ ;; `Custom-save' doesn't actually save (users must click the magic
+ ;; state button instead). The default behavior described in the doc
+ ;; string is intentional and was introduced by bug#12864 "Make state
+ ;; button interaction less confusing". However, it is unfriendly to
+ ;; rogue libraries (like ours) that insist on mutating user options
+ ;; as a matter of course.
+ (custom-load-symbol 'erc-modules)
+ (funcall (get 'erc-modules 'custom-set) 'erc-modules
+ (funcall op (erc--normalize-module-symbol name) erc-modules))
+ (when (equal (pcase (get 'erc-modules 'saved-value)
+ (`((quote ,saved) saved)))
+ erc-modules)
+ (customize-mark-as-set 'erc-modules)))
(defun erc--assemble-toggle (localp name ablsym mode val body)
(let ((arg (make-symbol "arg")))
`(defun ,ablsym ,(if localp `(&optional ,arg) '())
- ,(concat
+ ,(erc--fill-module-docstring
(if val "Enable" "Disable")
" ERC " (symbol-name name) " mode."
(when localp
@@ -137,19 +228,154 @@ canonical name.")
(,ablsym))
(setq ,mode ,val)
,@body)))
- `(,(if val
- `(cl-pushnew ',(erc--normalize-module-symbol name)
- erc-modules)
- `(setq erc-modules (delq ',(erc--normalize-module-symbol name)
- erc-modules)))
+ ;; No need for `default-value', etc. because a buffer-local
+ ;; `erc-modules' only influences the next session and
+ ;; doesn't survive the major-mode reset that soon follows.
+ `((unless
+ (or erc--inside-mode-toggle-p
+ ,@(let ((v `(memq ',(erc--normalize-module-symbol name)
+ erc-modules)))
+ `(,(if val v `(not ,v)))))
+ (let ((erc--inside-mode-toggle-p t))
+ (erc--favor-changed-reverted-modules-state
+ ',name #',(if val 'cons 'delq))))
(setq ,mode ,val)
,@body)))))
+;; This is a migration helper that determines a module's `:group'
+;; keyword argument from its name or alias. A (global) module's minor
+;; mode variable appears under the group's Custom menu. Like
+;; `erc--normalize-module-symbol', it must run when the module's
+;; definition (rather than that of `define-erc-module') is expanded.
+;; For corner cases in which this fails or the catch-all of `erc' is
+;; more inappropriate, (global) modules can declare a top-level
+;;
+;; (put 'foo 'erc-group 'erc-bar)
+;;
+;; where `erc-bar' is the group and `foo' is the normalized module.
+;; Do this *before* the module's definition. If `define-erc-module'
+;; ever accepts arbitrary keywords, passing an explicit `:group' will
+;; obviously be preferable.
+
+(defun erc--find-group (&rest symbols)
+ (catch 'found
+ (dolist (s symbols)
+ (let* ((downed (downcase (symbol-name s)))
+ (known (intern-soft (concat "erc-" downed))))
+ (when (and known
+ (or (get known 'group-documentation)
+ (rassq known custom-current-group-alist)))
+ (throw 'found known))
+ (when (setq known (intern-soft (concat "erc-" downed "-mode")))
+ (when-let ((found (custom-group-of-mode known)))
+ (throw 'found found))))
+ (when-let ((found (get (erc--normalize-module-symbol s) 'erc-group)))
+ (throw 'found found)))
+ 'erc))
+
+;; This exists as a separate, top-level function to prevent the byte
+;; compiler from warning about widget-related dependencies not being
+;; loaded at runtime.
+
+(defun erc--tick-module-checkbox (name &rest _) ; `name' must be normalized
+ (customize-variable-other-window 'erc-modules)
+ ;; Move to `erc-modules' section.
+ (while (not (eq (widget-type (widget-at)) 'checkbox))
+ (widget-move 1 t))
+ ;; This search for a checkbox can fail when `name' refers to a
+ ;; third-party module that modifies `erc-modules' (improperly) on
+ ;; load.
+ (let (w)
+ (while (and (eq (widget-type (widget-at)) 'checkbox)
+ (not (and (setq w (widget-get-sibling (widget-at)))
+ (eq (widget-value w) name))))
+ (setq w nil)
+ (widget-move 1 t)) ; the `suppress-echo' arg exists in 27.2
+ (unless w
+ (error "Failed to find %s in `erc-modules' checklist" name))
+ (widget-apply-action (widget-at))
+ (message "Hit %s to apply or %s to apply and save."
+ (substitute-command-keys "\\[Custom-set]")
+ (substitute-command-keys "\\[Custom-save]"))))
+
+;; This stands apart to avoid needing forward declarations for
+;; `wid-edit' functions in every file requiring `erc-common'.
+(defun erc--make-show-me-widget (widget escape &rest plist)
+ (if (eq escape ?i)
+ (apply #'widget-create-child-and-convert widget 'push-button plist)
+ (widget-default-format-handler widget escape)))
+
+(defun erc--prepare-custom-module-type (name)
+ `(let* ((name (erc--normalize-module-symbol ',name))
+ (fmtd (format " `%s' " name)))
+ `(boolean
+ :format "%{%t%}: %i %[Deprecated Toggle%] %v \n%h\n"
+ :format-handler
+ ,(lambda (widget escape)
+ (erc--make-show-me-widget
+ widget escape
+ :button-face '(custom-variable-obsolete custom-button)
+ :tag "Show Me"
+ :action (apply-partially #'erc--tick-module-checkbox name)
+ :help-echo (lambda (_)
+ (let ((hasp (memq name erc-modules)))
+ (concat (if hasp "Remove" "Add") fmtd
+ (if hasp "from" "to")
+ " `erc-modules'.")))))
+ :action widget-toggle-action
+ :documentation-property
+ ,(lambda (_)
+ (let ((hasp (memq name erc-modules)))
+ (concat
+ "Setting a module's minor-mode variable is "
+ (propertize "ineffective" 'face 'error)
+ ".\nPlease " (if hasp "remove" "add") fmtd
+ (if hasp "from" "to") " `erc-modules' directly instead.\n"
+ "You can do so now by clicking "
+ (propertize "Show Me" 'face 'custom-variable-obsolete)
+ " above."))))))
+
+(defun erc--fill-module-docstring (&rest strings)
+ "Concatenate STRINGS and fill as a doc string."
+ ;; Perhaps it's better to mimic `internal--format-docstring-line'
+ ;; and use basic filling instead of applying a major mode?
+ (with-temp-buffer
+ (delay-mode-hooks
+ (if (fboundp 'lisp-data-mode) (lisp-data-mode) (emacs-lisp-mode)))
+ (insert (format "%S" (apply #'concat strings)))
+ (goto-char (point-min))
+ (forward-line)
+ (let ((fill-column 65)
+ (sentence-end-double-space t))
+ (fill-paragraph))
+ (goto-char (point-min))
+ (read (current-buffer))))
+
+(defmacro erc--find-feature (name alias)
+ ;; Don't use this outside of the file that defines NAME.
+ `(pcase (erc--find-group ',name ,(and alias (list 'quote alias)))
+ ('erc (and-let* ((file (or (macroexp-file-name) buffer-file-name)))
+ (intern (file-name-base file))))
+ (v v)))
+
+(defvar erc--module-toggle-prefix-arg nil
+ "The interpreted prefix arg of the minor-mode toggle.
+Non-nil inside an ERC module's activation (or deactivation)
+command, such as `erc-spelling-enable', when it's been called
+indirectly via the module's minor-mode toggle, i.e.,
+`erc-spelling-mode'. Nil otherwise. Its value is either the
+symbol `toggle' or an integer produced by `prefix-numeric-value'.
+See Info node `(elisp) Defining Minor Modes' for more.")
+
(defmacro define-erc-module (name alias doc enable-body disable-body
&optional local-p)
"Define a new minor mode using ERC conventions.
-Symbol NAME is the name of the module.
-Symbol ALIAS is the alias to use, or nil.
+Expect NAME to be the module's name and ALIAS, when non-nil, to
+be a retired name used only for compatibility purposes. In new
+code, assume NAME is the same symbol users should specify when
+customizing `erc-modules' (see info node `(erc) Module Loading'
+for more on naming).
+
DOC is the documentation string to use for the minor mode.
ENABLE-BODY is a list of expressions used to enable the mode.
DISABLE-BODY is a list of expressions used to disable the mode.
@@ -179,33 +405,30 @@ Example:
(declare (doc-string 3) (indent defun))
(let* ((sn (symbol-name name))
(mode (intern (format "erc-%s-mode" (downcase sn))))
- (group (intern (format "erc-%s" (downcase sn))))
(enable (intern (format "erc-%s-enable" (downcase sn))))
- (disable (intern (format "erc-%s-disable" (downcase sn)))))
+ (disable (intern (format "erc-%s-disable" (downcase sn))))
+ (nmodule (erc--normalize-module-symbol name))
+ (amod (and alias (intern (format "erc-%s-mode"
+ (downcase (symbol-name alias)))))))
`(progn
(define-minor-mode
,mode
- ,(format "Toggle ERC %S mode.
+ ,(erc--fill-module-docstring (format "Toggle ERC %s mode.
With a prefix argument ARG, enable %s if ARG is positive,
and disable it otherwise. If called from Lisp, enable the mode
if ARG is omitted or nil.
-%s" name name doc)
- ;; FIXME: We don't know if this group exists, so this `:group' may
- ;; actually just silence a valid warning about the fact that the var
- ;; is not associated with any group.
- :global ,(not local-p) :group (quote ,group)
- (if ,mode
- (,enable)
- (,disable)))
+\n%s" name name doc))
+ :global ,(not local-p)
+ :group (erc--find-group ',name ,(and alias (list 'quote alias)))
+ ,@(unless local-p `(:require ',(erc--find-feature name alias)))
+ ,@(unless local-p `(:type ,(erc--prepare-custom-module-type name)))
+ (let ((erc--module-toggle-prefix-arg arg))
+ (if ,mode (,enable) (,disable))))
,(erc--assemble-toggle local-p name enable mode t enable-body)
,(erc--assemble-toggle local-p name disable mode nil disable-body)
- ,@(and-let* ((alias)
- ((not (eq name alias)))
- (aname (intern (format "erc-%s-mode"
- (downcase (symbol-name alias))))))
- `((defalias ',aname #',mode)
- (put ',aname 'erc-module ',(erc--normalize-module-symbol name))))
- (put ',mode 'erc-module ',(erc--normalize-module-symbol name))
+ ,@(and amod `((defalias ',amod #',mode)
+ (put ',amod 'erc-module ',nmodule)))
+ (put ',mode 'erc-module ',nmodule)
;; For find-function and find-variable.
(put ',mode 'definition-name ',name)
(put ',enable 'definition-name ',name)
@@ -249,17 +472,22 @@ See also `with-current-buffer'.
"Execute BODY in the current ERC server buffer.
If no server buffer exists, return nil."
(declare (indent 0) (debug (body)))
- (let ((buffer (make-symbol "buffer")))
- `(let ((,buffer (erc-server-buffer)))
- (when (buffer-live-p ,buffer)
- (with-current-buffer ,buffer
- ,@body)))))
+ (let ((varp (and (symbolp (car body))
+ (not (cdr body))
+ (special-variable-p (car body))))
+ (buffer (make-symbol "buffer")))
+ `(when-let* (((processp erc-server-process))
+ (,buffer (process-buffer erc-server-process))
+ ((buffer-live-p ,buffer)))
+ ,(if varp
+ `(buffer-local-value ',(car body) ,buffer)
+ `(with-current-buffer ,buffer
+ ,@body)))))
(defmacro erc-with-all-buffers-of-server (process pred &rest forms)
- "Execute FORMS in all buffers which have same process as this server.
-FORMS will be evaluated in all buffers having the process PROCESS and
-where PRED matches or in all buffers of the server process if PRED is
-nil."
+ "Evaluate FORMS in all buffers of PROCESS in which PRED returns non-nil.
+When PROCESS is nil, do so in all ERC buffers. When PRED is nil,
+run FORMS unconditionally."
(declare (indent 2) (debug (form form body)))
(macroexp-let2 nil pred pred
`(erc-buffer-filter (lambda ()
@@ -267,6 +495,13 @@ nil."
,@forms))
,process)))
+(defvar-local erc--target nil
+ "A permanent `erc--target' struct instance in channel and query buffers.")
+
+(define-inline erc-target ()
+ "Return target of current buffer, if any, as a string."
+ (inline-quote (and erc--target (erc--target-string erc--target))))
+
(defun erc-log-aux (string)
"Do the debug logging of STRING."
(let ((cb (current-buffer))
@@ -276,6 +511,7 @@ nil."
(if session-buffer
(progn
(set-buffer session-buffer)
+ (defvar erc-dbuf)
(if (not (and erc-dbuf (bufferp erc-dbuf) (buffer-live-p erc-dbuf)))
(progn
(setq erc-dbuf (get-buffer-create
@@ -291,6 +527,9 @@ nil."
(set-buffer cb))
(message "ERC: ** %s" string))))
+(defvar erc-log-p nil
+ "When non-nil, generate debug messages in an \"*ERC-DEBUG*\" buffer.")
+
(define-inline erc-log (string)
"Logs STRING if logging is on (see `erc-log-p')."
(inline-quote
@@ -306,15 +545,96 @@ Use the CASEMAPPING ISUPPORT parameter to determine the style."
(_ erc--casemapping-rfc1459))
(downcase string)))
-(define-inline erc-get-channel-user (nick)
- "Find NICK in the current buffer's `erc-channel-users' hash table."
+(define-inline erc-get-channel-member (nick)
+ "Find NICK in the current buffer's `erc-channel-members' hash table."
(inline-quote (gethash (erc-downcase ,nick) erc-channel-users)))
+(defalias 'erc-get-channel-user #'erc-get-channel-member)
(define-inline erc-get-server-user (nick)
"Find NICK in the current server's `erc-server-users' hash table."
(inline-letevals (nick)
- (inline-quote (erc-with-server-buffer
- (gethash (erc-downcase ,nick) erc-server-users)))))
+ (inline-quote
+ (gethash (erc-downcase ,nick)
+ (erc-with-server-buffer erc-server-users)))))
+
+(defmacro erc--with-dependent-type-match (type &rest features)
+ "Massage Custom :type TYPE with :match function that pre-loads FEATURES."
+ `(backquote-list* ',(car type)
+ :match (lambda (w v)
+ ,@(mapcar (lambda (ft) `(require ',ft)) features)
+ (,(widget-get (widget-convert type) :match) w v))
+ ',(cdr type)))
+
+;; This internal variant exists as a transition aid to avoid
+;; immediately having to reflow lengthy definition lists, like the one
+;; in erc.el. These sites should switch to using the public macro
+;; when undergoing their next major edit.
+(defmacro erc--define-catalog (name entries)
+ "Define `erc-display-message' formatting templates for NAME, a symbol.
+
+See `erc-define-message-format-catalog' for the meaning of
+ENTRIES, an alist, and `erc-tests-common-pp-propertized-parts' in
+tests/lisp/erc/erc-tests.el for a convenience command to convert
+a literal string into a sequence of `propertize' forms, which are
+much easier to review and edit. When ENTRIES begins with a
+sequence of keyword-value pairs remove them and consider their
+evaluated values before processing the alist proper.
+
+Currently, the only recognized keyword is `:parent', which tells
+ERC to search recursively for a given template key using the
+keyword's associated value, another catalog symbol, if not found
+in catalog NAME."
+ (declare (indent 1))
+ (let (out)
+ (while (keywordp (car entries))
+ (push (pcase-exhaustive (pop entries)
+ (:parent `(put ',name 'erc--base-format-catalog
+ ,(pop entries))))
+ out))
+ (dolist (e entries (cons 'progn (nreverse out)))
+ (push `(defvar ,(intern (format "erc-message-%s-%s" name (car e)))
+ ,(cdr e)
+ ,(let* ((first (format "Message template for key `%s'" (car e)))
+ (last (format "catalog `%s'." name))
+ (combined (concat first " in " last)))
+ (if (< (length combined) 80)
+ combined
+ (concat first ".\nFor use with " last))))
+ out))))
+
+(defmacro erc-define-message-format-catalog (language &rest entries)
+ "Define message-formatting templates for LANGUAGE, a symbol.
+Expect ENTRIES to be pairs of (KEY . FORMAT), where KEY is a
+symbol, and FORMAT evaluates to a format string compatible with
+`format-spec'. Expect modules that only define a handful of
+entries to do so manually, instead of using this macro, so that
+the resulting variables will end up with more useful doc strings."
+ (declare (indent 1)
+ (debug (symbolp [&rest [keywordp form]] &rest (symbolp . form))))
+ `(erc--define-catalog ,language ,entries))
+
+(define-inline erc--strpos (char string)
+ "Return position of CHAR in STRING or nil if not found."
+ (inline-quote (string-search (string ,char) ,string)))
+
+(defmacro erc--doarray (spec &rest body)
+ "Map over ARRAY, running BODY with VAR bound to iteration element.
+Behave more or less like `seq-doseq', but tailor operations for
+arrays.
+
+\(fn (VAR ARRAY [RESULT]) BODY...)"
+ (declare (indent 1) (debug ((symbolp form &optional form) body)))
+ (let ((array (make-symbol "array"))
+ (len (make-symbol "len"))
+ (i (make-symbol "i")))
+ `(let* ((,array ,(nth 1 spec))
+ (,len (length ,array))
+ (,i 0))
+ (while-let (((< ,i ,len))
+ (,(car spec) (aref ,array ,i)))
+ ,@body
+ (cl-incf ,i))
+ ,(nth 2 spec))))
(provide 'erc-common)
diff --git a/lisp/erc/erc-compat.el b/lisp/erc/erc-compat.el
index 054df77d008..b5b8fbaf8ab 100644
--- a/lisp/erc/erc-compat.el
+++ b/lisp/erc/erc-compat.el
@@ -31,8 +31,11 @@
;;; Code:
-(require 'compat nil 'noerror)
-(eval-when-compile (require 'cl-lib) (require 'url-parse))
+(require 'compat)
+(eval-when-compile (require 'cl-lib))
+
+(define-obsolete-function-alias 'erc-compat-function #'compat-function "30.1")
+(define-obsolete-function-alias 'erc-compat-call #'compat-call "30.1")
;;;###autoload(autoload 'erc-define-minor-mode "erc-compat")
(define-obsolete-function-alias 'erc-define-minor-mode
@@ -59,7 +62,7 @@ See `erc-encoding-coding-alist'."
(defun erc-set-write-file-functions (new-val)
(declare (obsolete nil "28.1"))
- (set (make-local-variable 'write-file-functions) new-val))
+ (setq-local write-file-functions new-val))
(defvar erc-emacs-build-time
(if (or (stringp emacs-build-time) (not emacs-build-time))
@@ -368,22 +371,14 @@ If START or END is negative, it counts from the end."
;;;; Misc 29.1
-(defmacro erc-compat--with-memoization (table &rest forms)
- (declare (indent defun))
- (cond
- ((fboundp 'with-memoization)
- `(with-memoization ,table ,@forms)) ; 29.1
- ((fboundp 'cl--generic-with-memoization)
- `(cl--generic-with-memoization ,table ,@forms))
- (t `(progn ,@forms))))
-
(defvar url-irc-function)
+(declare-function url-type "url-parse" (cl-x))
(defun erc-compat--29-browse-url-irc (string &rest _)
(require 'url-irc)
(let* ((url (url-generic-parse-url string))
(url-irc-function
- (if (function-equal url-irc-function 'url-irc-erc)
+ (if (eq url-irc-function 'url-irc-erc)
(lambda (host port chan user pass)
(erc-handle-irc-url host port chan user pass (url-type url)))
url-irc-function)))
@@ -409,6 +404,42 @@ If START or END is negative, it counts from the end."
(cons '("\\`irc6?s?://" . erc-compat--29-browse-url-irc)
existing))))))
+;; We can't store (TICKS . HZ) style timestamps on 27 and 28 because
+;; `time-less-p' and friends do
+;;
+;; message("obsolete timestamp with cdr ...", ...)
+;; decode_lisp_time(_, WARN_OBSOLETE_TIMESTAMPS, ...)
+;; lisp_time_struct(...)
+;; time_cmp(...)
+;;
+;; which spams *Messages* (and stderr when running the test suite).
+(defmacro erc-compat--current-lisp-time ()
+ "Return `current-time' as a (TICKS . HZ) pair on 29+."
+ (if (>= emacs-major-version 29)
+ '(let (current-time-list) (current-time))
+ '(current-time)))
+
+(defmacro erc-compat--defer-format-spec-in-buffer (&rest spec)
+ "Transform SPEC forms into functions that run in the current buffer.
+For convenience, ensure function wrappers return \"\" as a
+fallback."
+ (cl-check-type (car spec) cons)
+ (let ((buffer (make-symbol "buffer")))
+ `(let ((,buffer (current-buffer)))
+ ,(list '\`
+ (mapcar
+ (pcase-lambda (`(,k . ,v))
+ (cons k
+ (list '\,(if (>= emacs-major-version 29)
+ `(lambda ()
+ (or (if (eq ,buffer (current-buffer))
+ ,v
+ (with-current-buffer ,buffer
+ ,v))
+ ""))
+ `(or ,v "")))))
+ spec)))))
+
(provide 'erc-compat)
;;; erc-compat.el ends here
diff --git a/lisp/erc/erc-dcc.el b/lisp/erc/erc-dcc.el
index 3a66a08aec4..b8e16df755b 100644
--- a/lisp/erc/erc-dcc.el
+++ b/lisp/erc/erc-dcc.el
@@ -43,7 +43,7 @@
;; /dcc chat nick - Either accept pending chat offer from nick, or offer
;; DCC chat to nick
;; /dcc close type [nick] - Close DCC connection (SEND/GET/CHAT) with nick
-;; /dcc get [-t][-s] nick [file] - Accept DCC offer from nick
+;; /dcc get [-t][-s] nick [--] file - Accept DCC offer from nick
;; /dcc list - List all DCC offers/connections
;; /dcc send nick file - Offer DCC SEND to nick
@@ -131,9 +131,8 @@ Looks like:
(open-network-stream procname buffer addr port
:type (and (plist-get entry :secure) 'tls))))
-(erc-define-catalog
- 'english
- '((dcc-chat-discarded
+(erc--define-catalog english
+ ((dcc-chat-discarded
. "DCC: previous chat request from %n (%u@%h) discarded")
(dcc-chat-ended . "DCC: chat with %n ended %t: %e")
(dcc-chat-no-request . "DCC: chat request from %n not found")
@@ -389,12 +388,18 @@ If this is nil, then the current value of `default-directory' is used."
:type '(choice (const :value nil :tag "Default directory") directory))
;;;###autoload
-(defun erc-cmd-DCC (cmd &rest args)
+(defun erc-cmd-DCC (line &rest compat-args)
"Parser for /dcc command.
This figures out the dcc subcommand and calls the appropriate routine to
handle it. The function dispatched should be named \"erc-dcc-do-FOO-command\",
where FOO is one of CLOSE, GET, SEND, LIST, CHAT, etc."
- (when cmd
+ (let (cmd args)
+ ;; Called as library function (i.e., not directly as /dcc)
+ (if compat-args
+ (setq cmd line
+ args compat-args)
+ (setq args (delete "" (erc--split-string-shell-cmd line))
+ cmd (pop args)))
(let ((fn (intern-soft (concat "erc-dcc-do-" (upcase cmd) "-command"))))
(if fn
(apply fn erc-server-process args)
@@ -404,8 +409,16 @@ where FOO is one of CLOSE, GET, SEND, LIST, CHAT, etc."
(apropos "erc-dcc-do-.*-command")
t))))
+(put 'erc-cmd-DCC 'do-not-parse-args t)
(autoload 'pcomplete-erc-all-nicks "erc-pcomplete")
+;;;###autoload(put 'erc-cmd-DCC 'erc--cmd-help 'erc-dcc--cmd-help)
+(defun erc-dcc--cmd-help (&rest args)
+ (describe-function
+ (or (and args (intern-soft (concat "erc-dcc-do-"
+ (upcase (car args)) "-command")))
+ 'erc-cmd-DCC)))
+
;;;###autoload
(defun pcomplete/erc-mode/DCC ()
"Provide completion for the /DCC command."
@@ -430,15 +443,20 @@ where FOO is one of CLOSE, GET, SEND, LIST, CHAT, etc."
(eq (plist-get elt :type) 'GET))
erc-dcc-list)))
('send (pcomplete-erc-all-nicks))))
+ (when (equal "get" (downcase (pcomplete-arg 'first 1)))
+ (pcomplete-opt "-"))
(pcomplete-here
(pcase (intern (downcase (pcomplete-arg 'first 1)))
- ('get (mapcar (lambda (elt) (plist-get elt :file))
+ ('get (mapcar (lambda (elt)
+ (combine-and-quote-strings (list (plist-get elt :file))))
(cl-remove-if-not
(lambda (elt)
(and (eq (plist-get elt :type) 'GET)
(erc-nick-equal-p (erc-extract-nick
(plist-get elt :nick))
- (pcomplete-arg 1))))
+ (pcase (pcomplete-arg 1)
+ ("--" (pcomplete-arg 2))
+ (v v)))))
erc-dcc-list)))
('close (mapcar #'erc-dcc-nick
(cl-remove-if-not
@@ -504,20 +522,33 @@ At least one of TYPE and NICK must be provided."
?n (erc-extract-nick (plist-get ret :nick))))))
t))
-(defun erc-dcc-do-GET-command (proc nick &rest file)
- "Do a DCC GET command. NICK is the person who is sending the file.
-FILE is the filename. If FILE is split into multiple arguments,
-re-join the arguments, separated by a space.
-PROC is the server process.
-
-WARNING: the /DCC GET command is bugged in ERC 5.5 (Emacs 29).
-File names containing the string \" -\" are not honored. If you
-need a fix immediately, see Info node `(erc) Upgrading'."
- (let* ((args (seq-group-by (lambda (s) (eq ?- (aref s 0))) (cons nick file)))
+(defun erc-dcc-do-GET-command (proc &rest args)
+ "Perform a DCC GET command.
+Recognize input conforming to the following usage syntax:
+
+ /DCC GET [-t|-s] nick [--] filename
+
+ nick The person who is sending the file.
+ filename The filename to be downloaded. Can be split into multiple
+ arguments that are then joined by a space.
+ flags \"-t\" sets `:turbo' in `erc-dcc-list'
+ \"-s\" sets `:secure' in `erc-dcc-list'
+ \"--\" indicates end of options
+ All of which are optional.
+
+Expect PROC to be the server process and ARGS to contain
+everything after the subcommand \"GET\" in the usage description
+above."
+ ;; Despite the advertised syntax above, we currently respect flags
+ ;; in these positions: [flag] nick [flag] filename [flag]
+ (let* ((trailing (and-let* ((trailing (member "--" args)))
+ (setq args (butlast args (length trailing)))
+ (cdr trailing)))
+ (args (seq-group-by (lambda (s) (eq ?- (aref s 0))) args))
(flags (prog1 (cdr (assq t args))
- (setq args (cdr (assq nil args))
- nick (pop args)
- file (and args (mapconcat #'identity args " ")))))
+ (setq args (nconc (cdr (assq nil args)) trailing))))
+ (nick (pop args))
+ (file (and args (mapconcat #'identity args " ")))
(elt (erc-dcc-member :nick nick :type 'GET :file file))
(filename (or file (plist-get elt :file) "unknown")))
(if elt
@@ -588,7 +619,7 @@ It lists the current state of `erc-dcc-list' in an easy to read manner."
(buffer-live-p (get-buffer (plist-get elt :file)))
(plist-member elt :size))
(let ((byte-count (with-current-buffer
- (get-buffer (plist-get elt :file))
+ (plist-get elt :file)
(+ (buffer-size) 0.0
erc-dcc-byte-count))))
(format " (%d%%)"
@@ -682,8 +713,8 @@ It extracts the information about the dcc request and adds it to
(port (match-string 4 query))
(size (match-string 5 query))
(sub (substring (match-string 6 query) 0 -4))
- (secure (seq-contains-p sub ?S #'eq))
- (turbo (seq-contains-p sub ?T #'eq)))
+ (secure (string-search "S" sub))
+ (turbo (string-search "T" sub)))
;; FIXME: a warning really should also be sent
;; if the ip address != the host the dcc sender is on.
(erc-display-message
@@ -1181,9 +1212,8 @@ other client."
erc-dcc-from nick
erc-dcc-entry-data entry
erc-dcc-unprocessed-output ""
- erc-insert-marker (point-max-marker)
erc-input-marker (make-marker))
- (erc-display-prompt buffer (point-max))
+ (erc--initialize-markers (point) nil)
(set-process-buffer proc buffer)
(add-hook 'kill-buffer-hook #'erc-dcc-chat-buffer-killed nil t)
(run-hook-with-args 'erc-dcc-chat-connect-hook proc))
@@ -1221,14 +1251,16 @@ other client."
(defun erc-dcc-chat-parse-output (proc str)
(save-match-data
(let ((posn 0)
+ (erc--msg-prop-overrides `((erc--spkr . ,erc-dcc-from)))
+ (nick (propertize (erc--speakerize-nick erc-dcc-from)
+ 'font-lock-face 'erc-nick-default-face))
line)
(while (string-match "\n" str posn)
(setq line (substring str posn (match-beginning 0)))
(setq posn (match-end 0))
(erc-display-message
nil nil proc
- 'dcc-chat-privmsg ?n (propertize erc-dcc-from 'font-lock-face
- 'erc-nick-default-face) ?m line))
+ 'dcc-chat-privmsg ?n nick ?m line))
(setq erc-dcc-unprocessed-output (substring str posn)))))
(defun erc-dcc-chat-buffer-killed ()
diff --git a/lisp/erc/erc-desktop-notifications.el b/lisp/erc/erc-desktop-notifications.el
index 2e905097f97..9bb89fbfc81 100644
--- a/lisp/erc/erc-desktop-notifications.el
+++ b/lisp/erc/erc-desktop-notifications.el
@@ -54,6 +54,9 @@
(defvar dbus-debug) ; used in the macroexpansion of dbus-ignore-errors
+(declare-function haiku-notifications-notify "haikuselect.c")
+(declare-function android-notifications-notify "androidselect.c")
+
(defun erc-notifications-notify (nick msg &optional privp)
"Notify that NICK send some MSG, where PRIVP should be non-nil for PRIVMSGs.
This will replace the last notification sent with this function."
@@ -64,14 +67,19 @@ This will replace the last notification sent with this function."
(let* ((channel (if privp (erc-get-buffer nick) (current-buffer)))
(title (format "%s in %s" (xml-escape-string nick t) channel))
(body (xml-escape-string (erc-controls-strip msg) t)))
- (notifications-notify :bus erc-notifications-bus
- :title title
- :body body
- :replaces-id erc-notifications-last-notification
- :app-icon erc-notifications-icon
- :actions '("default" "Switch to buffer")
- :on-action (lambda (&rest _)
- (pop-to-buffer channel)))))))
+ (funcall (cond ((featurep 'android)
+ #'android-notifications-notify)
+ ((featurep 'haiku)
+ #'haiku-notifications-notify)
+ (t #'notifications-notify))
+ :bus erc-notifications-bus
+ :title title
+ :body body
+ :replaces-id erc-notifications-last-notification
+ :app-icon erc-notifications-icon
+ :actions '("default" "Switch to buffer")
+ :on-action (lambda (&rest _)
+ (pop-to-buffer channel)))))))
(defun erc-notifications-PRIVMSG (_proc parsed)
(let ((nick (car (erc-parse-user (erc-response.sender parsed))))
diff --git a/lisp/erc/erc-fill.el b/lisp/erc/erc-fill.el
index 388c295eae8..aa12b807fbc 100644
--- a/lisp/erc/erc-fill.el
+++ b/lisp/erc/erc-fill.el
@@ -28,6 +28,9 @@
;; `erc-fill-mode' to switch it on. Customize `erc-fill-function' to
;; change the style.
+;; TODO: redo `erc-fill-wrap-nudge' using transient after ERC drops
+;; support for Emacs 27.
+
;;; Code:
(require 'erc)
@@ -38,30 +41,14 @@
:group 'erc)
;;;###autoload(autoload 'erc-fill-mode "erc-fill" nil t)
-(define-minor-mode erc-fill-mode
- "Toggle ERC fill mode.
-With a prefix argument ARG, enable ERC fill mode if ARG is
-positive, and disable it otherwise. If called from Lisp, enable
-the mode if ARG is omitted or nil.
-
+(define-erc-module fill nil
+ "Manage filling in ERC buffers.
ERC fill mode is a global minor mode. When enabled, messages in
-the channel buffers are filled."
- :global t
- (if erc-fill-mode
- (erc-fill-enable)
- (erc-fill-disable)))
-
-(defun erc-fill-enable ()
- "Setup hooks for `erc-fill-mode'."
- (interactive)
- (add-hook 'erc-insert-modify-hook #'erc-fill)
- (add-hook 'erc-send-modify-hook #'erc-fill))
-
-(defun erc-fill-disable ()
- "Cleanup hooks, disable `erc-fill-mode'."
- (interactive)
- (remove-hook 'erc-insert-modify-hook #'erc-fill)
- (remove-hook 'erc-send-modify-hook #'erc-fill))
+channel buffers are filled. See also `erc-fill-wrap-mode'."
+ ((add-hook 'erc-insert-modify-hook #'erc-fill 60)
+ (add-hook 'erc-send-modify-hook #'erc-fill 60))
+ ((remove-hook 'erc-insert-modify-hook #'erc-fill)
+ (remove-hook 'erc-send-modify-hook #'erc-fill)))
(defcustom erc-fill-prefix nil
"Values used as `fill-prefix' for `erc-fill-variable'.
@@ -91,56 +78,125 @@ Static Filling with `erc-fill-static-center' of 27:
These two styles are implemented using `erc-fill-variable' and
`erc-fill-static'. You can, of course, define your own filling
function. Narrowing to the region in question is in effect while your
-function is called."
+function is called.
+
+A third style resembles static filling but \"wraps\" instead of
+fills, thanks to `visual-line-mode' mode, which ERC automatically
+enables when this option is `erc-fill-wrap' or when the module
+`fill-wrap' is active. Use `erc-fill-static-center' to specify
+an initial \"prefix\" width and `erc-fill-wrap-margin-width'
+instead of `erc-fill-column' for influencing initial message
+width. For adjusting these during a session, see the commands
+`erc-fill-wrap-nudge' and `erc-fill-wrap-refill-buffer'. Read
+more about this style in the doc string for `erc-fill-wrap-mode'."
:type '(choice (const :tag "Variable Filling" erc-fill-variable)
(const :tag "Static Filling" erc-fill-static)
+ (const :tag "Dynamic word-wrap" erc-fill-wrap)
function))
(defcustom erc-fill-static-center 27
- "Column around which all statically filled messages will be centered.
-This column denotes the point where the ` ' character between
-<nickname> and the entered text will be put, thus aligning nick
-names right and text left."
+ "Number of columns to \"outdent\" the first line of a message.
+During early message handing, ERC prepends a span of
+non-whitespace characters to every message, such as a bracketed
+\"<nickname>\" or an `erc-notice-prefix'. The
+`erc-fill-function' variants `erc-fill-static' and
+`erc-fill-wrap' look to this option to determine the amount of
+padding to apply to that portion until the filled (or wrapped)
+message content aligns with the indicated column. See also
+https://en.wikipedia.org/wiki/Hanging_indent."
:type 'integer)
(defcustom erc-fill-variable-maximum-indentation 17
"Don't indent a line after a long nick more than this many characters.
Set to nil to disable."
- :type 'integer)
+ :type '(choice (const :tag "Disable" nil)
+ integer))
(defcustom erc-fill-column 78
"The column at which a filled paragraph is broken."
:type 'integer)
+(defcustom erc-fill-wrap-margin-width nil
+ "Starting width in columns of dedicated stamp margin.
+When nil, ERC normally pretends its value is one column greater
+than the `string-width' of the formatted `erc-timestamp-format'.
+However, when `erc-fill-wrap-margin-side' is `left' or
+\"resolves\" to `left', ERC uses the width of the prompt if it's
+wider on MOTD's end, which really only matters when `erc-prompt'
+is a function."
+ :package-version '(ERC . "5.6")
+ :type '(choice (const nil) integer))
+
+(defcustom erc-fill-wrap-margin-side nil
+ "Margin side to use with `erc-fill-wrap-mode'.
+A value of nil means ERC should decide based on the value of
+`erc-insert-timestamp-function', which does not work for
+user-defined functions."
+ :package-version '(ERC . "5.6")
+ :type '(choice (const nil) (const left) (const right)))
+
+(defcustom erc-fill-wrap-align-prompt nil
+ "Whether to align the prompt at the common `wrap-prefix'."
+ :package-version '(ERC . "5.6")
+ :type 'boolean)
+
+(defvar erc-fill-line-spacing nil
+ "Extra space between messages on graphical displays.
+Its value should probably be larger than that of the variable
+`line-spacing', if non-nil. When unsure, start with 1.0. Note
+that as of ERC 5.6, this feature doesn't combine well with the
+`scrolltobottom' module, which is de facto required when using
+the `fill-wrap' filling style. Users should therefore regard
+this variable as experimental for the time being.")
+
+(defvar-local erc-fill--function nil
+ "Internal copy of `erc-fill-function'.
+Takes precedence over the latter when non-nil.")
+
;;;###autoload
(defun erc-fill ()
"Fill a region using the function referenced in `erc-fill-function'.
You can put this on `erc-insert-modify-hook' and/or `erc-send-modify-hook'."
(unless (erc-string-invisible-p (buffer-substring (point-min) (point-max)))
- (when erc-fill-function
+ (when (or erc-fill--function erc-fill-function)
;; skip initial empty lines
(goto-char (point-min))
- (save-match-data
- (while (and (looking-at "[ \t\n]*$")
- (= (forward-line 1) 0))))
+ ;; Note the following search pattern was altered in 5.6 to adapt
+ ;; to a change in Emacs regexp behavior that turned out to be a
+ ;; regression (which has since been fixed). The patterns appear
+ ;; to be equivalent in practice, so this was left as is (wasn't
+ ;; reverted) to avoid additional git-blame(1)-related churn.
+ (while (and (looking-at (rx bol (* (in " \t")) eol))
+ (zerop (forward-line 1))))
(unless (eobp)
(save-restriction
(narrow-to-region (point) (point-max))
- (funcall erc-fill-function))))))
+ (funcall (or erc-fill--function erc-fill-function))
+ (when-let ((erc-fill-line-spacing)
+ (p (point-min)))
+ (widen)
+ (when (or (erc--check-msg-prop 'erc--spkr)
+ (save-excursion
+ (forward-line -1)
+ (erc--get-inserted-msg-prop 'erc--spkr)))
+ (put-text-property (1- p) p
+ 'line-spacing erc-fill-line-spacing))))))))
(defun erc-fill-static ()
"Fills a text such that messages start at column `erc-fill-static-center'."
- (save-match-data
+ (save-restriction
(goto-char (point-min))
- (looking-at "^\\(\\S-+\\)")
- (let ((nick (match-string 1)))
+ (when-let (((looking-at "^\\(\\S-+\\)"))
+ ((not (erc--check-msg-prop 'erc--msg 'datestamp)))
+ (nick (match-string 1)))
+ (progn
(let ((fill-column (- erc-fill-column (erc-timestamp-offset)))
(fill-prefix (make-string erc-fill-static-center 32)))
(insert (make-string (max 0 (- erc-fill-static-center
(length nick) 1))
32))
(erc-fill-regarding-timestamp))
- (erc-restore-text-properties))))
+ (erc-restore-text-properties)))))
(defun erc-fill-variable ()
"Fill from `point-min' to `point-max'."
@@ -167,6 +223,651 @@ You can put this on `erc-insert-modify-hook' and/or `erc-send-modify-hook'."
(erc-fill-regarding-timestamp))))
(erc-restore-text-properties)))
+(defvar-local erc-fill--wrap-value nil)
+(defvar-local erc-fill--wrap-visual-keys nil)
+
+(defvar erc-fill-wrap-use-pixels t
+ "Whether to calculate padding in pixels when possible.
+A value of nil means ERC should use columns, which may happen
+regardless, depending on the Emacs version. This option only
+matters when `erc-fill-wrap-mode' is enabled.")
+
+(defcustom erc-fill-wrap-visual-keys 'non-input
+ "Whether to retain keys defined by `visual-line-mode'.
+A value of t tells ERC to use movement commands defined by
+`visual-line-mode' everywhere in an ERC buffer along with visual
+editing commands in the input area. A value of nil means to
+never do so. A value of `non-input' tells ERC to act like the
+value is nil in the input area and t elsewhere. See related
+option `erc-fill-wrap-force-screen-line-movement' for behavior
+involving `next-line' and `previous-line'."
+ :package-version '(ERC . "5.6")
+ :type '(choice (const nil) (const t) (const non-input)))
+
+(defcustom erc-fill-wrap-force-screen-line-movement '(non-input)
+ "Exceptions for vertical movement by logical line.
+Including a symbol known to `erc-fill-wrap-visual-keys' in this
+set tells `next-line' and `previous-line' to move vertically by
+screen line even if the current `erc-fill-wrap-visual-keys' value
+would normally do otherwise. For example, setting this to
+\\='(nil non-input) disables logical-line movement regardless of
+the value of `erc-fill-wrap-visual-keys'."
+ :package-version '(ERC . "5.6")
+ :type '(set (const nil) (const non-input)))
+
+(defcustom erc-fill-wrap-merge t
+ "Whether to consolidate consecutive messages from the same speaker.
+When non-nil, ERC omits redundant speaker labels for subsequent
+messages less than a day apart. To help distinguish between
+merged messages, see option `erc-fill-wrap-merge-indicator'."
+ :package-version '(ERC . "5.6")
+ :type 'boolean)
+
+(defface erc-fill-wrap-merge-indicator-face
+ '((((min-colors 88) (background light)) :foreground "Gray")
+ (((min-colors 16) (background light)) :foreground "LightGray")
+ (((min-colors 16) (background dark)) :foreground "DimGray")
+ (t :inherit shadow))
+ "ERC `fill-wrap' merge-indicator face."
+ :group 'erc-faces)
+
+(defcustom erc-fill-wrap-merge-indicator nil
+ "Indicator to help distinguish between merged messages.
+Only matters when the option `erc-fill-wrap-merge' is enabled.
+If the first element is the symbol `pre', ERC uses this option to
+generate a replacement for the speaker's name tag. If the first
+element is `post', ERC affixes a short string to the end of the
+previous message. In either case, the second element should be a
+character, like ?>, and the last element a valid face. In
+special cases, you may also specify a cons of either
+aforementioned symbol and a string, which tells ERC not to manage
+the process for you. If unsure, try either of the first two
+presets, both of which replace a continued speaker's name with a
+dot-product-like character in a `shadow'-like face.
+
+Note that as of ERC 5.6, this option is still experimental, and
+changing its value mid-session is not yet supported (though, if
+you must, make sure to run \\[erc-fill-wrap-refill-buffer]
+afterward). Also note that users on versions of Emacs older than
+29.2 may experience a \"glitching\" effect when point resides on
+a \"merged\" message occupying the first or last line in a
+window. If that happens, try replacing `top' with the integer 1
+in the option `recenter-positions' while also maybe adjusting
+`scroll-margin' and/or `scroll-preserve-screen-position' to avoid
+\"dragging\" point when issuing a `scroll-up' or `scroll-down'
+command."
+ :package-version '(ERC . "5.6")
+ :type
+ '(choice (const nil)
+ (const :tag "Leading MIDDLE DOT (U+00B7) as speaker"
+ (pre #xb7 erc-fill-wrap-merge-indicator-face))
+ (const :tag "Leading MIDDLE DOT (U+00B7) sans gap"
+ (pre . #("\u00b7" 0 1 (font-lock-face
+ erc-fill-wrap-merge-indicator-face))))
+ (const :tag "Leading RIGHT-ANGLE BRACKET (>) as speaker"
+ (pre ?> erc-fill-wrap-merge-indicator-face))
+ (const :tag "Trailing PARAGRAPH SIGN (U+00B6)"
+ (post #xb6 erc-fill-wrap-merge-indicator-face))
+ (const :tag "Trailing TILDE (~)"
+ (post ?~ erc-fill-wrap-merge-indicator-face))
+ (cons :tag "User-provided string (advanced)"
+ (choice (const pre) (const post)) string)
+ (list :tag "User-provided character-face pairing"
+ (choice (const pre) (const post)) character face)))
+
+(defun erc-fill--wrap-move (normal-cmd visual-cmd &rest args)
+ (apply (pcase erc-fill--wrap-visual-keys
+ ('non-input
+ (if (>= (point) erc-input-marker) normal-cmd visual-cmd))
+ ('t visual-cmd)
+ (_ normal-cmd))
+ args))
+
+(defun erc-fill--wrap-kill-line (arg)
+ "Defer to `kill-line' or `kill-visual-line'."
+ (interactive "P")
+ ;; ERC buffers are read-only outside of the input area, but we run
+ ;; `kill-line' anyway so that users can see the error.
+ (erc-fill--wrap-move #'kill-line #'kill-visual-line arg))
+
+(defun erc-fill--wrap-escape-hidden-speaker ()
+ "Move to start of message text when left of speaker.
+Basically mimic what `move-beginning-of-line' does with invisible text."
+ (when-let ((erc-fill-wrap-merge)
+ (prop (get-text-property (point) 'display))
+ ((or (equal prop "") (eq 'margin (car-safe (car-safe prop))))))
+ (goto-char (text-property-not-all (point) (pos-eol) 'display prop))))
+
+(defun erc-fill--wrap-beginning-of-line (arg)
+ "Defer to `move-beginning-of-line' or `beginning-of-visual-line'."
+ (interactive "^p")
+ (let ((inhibit-field-text-motion t))
+ (erc-fill--wrap-move #'move-beginning-of-line
+ #'beginning-of-visual-line arg))
+ (if (get-text-property (point) 'erc-prompt)
+ (goto-char erc-input-marker)
+ ;; Mimic what `move-beginning-of-line' does with invisible text.
+ (erc-fill--wrap-escape-hidden-speaker)))
+
+(defun erc-fill--wrap-previous-line (&optional arg try-vscroll)
+ "Move to ARGth previous logical or screen line."
+ (interactive "^p\np")
+ ;; Return value seems undefined but preserve anyway just in case.
+ (prog1
+ (let ((visp (memq erc-fill--wrap-visual-keys
+ erc-fill-wrap-force-screen-line-movement)))
+ (erc-fill--wrap-move (if visp #'previous-line #'previous-logical-line)
+ #'previous-line
+ arg try-vscroll))
+ (erc-fill--wrap-escape-hidden-speaker)))
+
+(defun erc-fill--wrap-next-line (&optional arg try-vscroll)
+ "Move to ARGth next logical or screen line."
+ (interactive "^p\np")
+ (let ((visp (memq erc-fill--wrap-visual-keys
+ erc-fill-wrap-force-screen-line-movement)))
+ (erc-fill--wrap-move (if visp #'next-line #'next-logical-line)
+ #'next-line
+ arg try-vscroll)))
+
+(defun erc-fill--wrap-end-of-line (arg)
+ "Defer to `move-end-of-line' or `end-of-visual-line'."
+ (interactive "^p")
+ (erc-fill--wrap-move #'move-end-of-line #'end-of-visual-line arg))
+
+(defun erc-fill-wrap-cycle-visual-movement (arg)
+ "Cycle through `erc-fill-wrap-visual-keys' styles ARG times.
+Go from nil to t to `non-input' and back around, but set internal
+state instead of mutating `erc-fill-wrap-visual-keys'. When ARG
+is 0, reset to value of `erc-fill-wrap-visual-keys'."
+ (interactive "^p")
+ (when (zerop arg)
+ (setq erc-fill--wrap-visual-keys erc-fill-wrap-visual-keys))
+ (while (not (zerop arg))
+ (cl-incf arg (- (abs arg)))
+ (setq erc-fill--wrap-visual-keys (pcase erc-fill--wrap-visual-keys
+ ('nil t)
+ ('t 'non-input)
+ ('non-input nil))))
+ (message "erc-fill-wrap movement: %S" erc-fill--wrap-visual-keys))
+
+(defun erc-fill-wrap-toggle-truncate-lines (arg)
+ "Toggle `truncate-lines' and maybe reinstate `visual-line-mode'."
+ (interactive "P")
+ (let ((wantp (if arg
+ (natnump (prefix-numeric-value arg))
+ (not truncate-lines)))
+ (buffer (current-buffer)))
+ (if wantp
+ (setq truncate-lines t)
+ (walk-windows (lambda (window)
+ (when (eq buffer (window-buffer window))
+ (set-window-hscroll window 0)))
+ nil t)
+ (visual-line-mode +1)))
+ (force-mode-line-update))
+
+(defvar-keymap erc-fill-wrap-mode-map ; Compat 29
+ :doc "Keymap for ERC's `fill-wrap' module."
+ :parent visual-line-mode-map
+ "<remap> <kill-line>" #'erc-fill--wrap-kill-line
+ "<remap> <move-end-of-line>" #'erc-fill--wrap-end-of-line
+ "<remap> <move-beginning-of-line>" #'erc-fill--wrap-beginning-of-line
+ "<remap> <toggle-truncate-lines>" #'erc-fill-wrap-toggle-truncate-lines
+ "<remap> <next-line>" #'erc-fill--wrap-next-line
+ "<remap> <previous-line>" #'erc-fill--wrap-previous-line
+ "C-c a" #'erc-fill-wrap-cycle-visual-movement
+ ;; Not sure if this is problematic because `erc-bol' takes no args.
+ "<remap> <erc-bol>" #'erc-fill--wrap-beginning-of-line)
+
+(defvar erc-button-mode)
+(defvar erc-scrolltobottom-mode)
+(defvar erc-legacy-invisible-bounds-p)
+
+(defvar erc--fill-wrap-scrolltobottom-exempt-p nil)
+
+(defun erc-fill--wrap-ensure-dependencies ()
+ (with-suppressed-warnings ((obsolete erc-legacy-invisible-bounds-p))
+ (when erc-legacy-invisible-bounds-p
+ (erc--warn-once-before-connect 'erc-fill-wrap-mode
+ "Module `fill-wrap' is incompatible with the obsolete compatibility"
+ " flag `erc-legacy-invisible-bounds-p'. Disabling locally in %s."
+ (current-buffer))
+ (setq-local erc-legacy-invisible-bounds-p nil)))
+ (let (missing-deps)
+ (unless erc-fill-mode
+ (push 'fill missing-deps)
+ (erc-fill-mode +1))
+ (unless (or erc-scrolltobottom-mode erc--fill-wrap-scrolltobottom-exempt-p
+ (memq 'scrolltobottom erc-modules))
+ (push 'scrolltobottom missing-deps)
+ (erc-scrolltobottom-mode +1))
+ (when erc-fill-wrap-merge
+ (require 'erc-button)
+ (unless erc-button-mode
+ (push 'button missing-deps)
+ (erc-button-mode +1))
+ (require 'erc-stamp)
+ (unless erc-stamp-mode
+ (push 'stamp missing-deps)
+ (erc-stamp-mode +1)))
+ (when missing-deps
+ (erc--warn-once-before-connect 'erc-fill-wrap-mode
+ "Enabling missing global modules %s needed by local"
+ " module `fill-wrap'. This will impact \C-]all\C-] ERC"
+ " sessions. Add them to `erc-modules' to avoid this"
+ " warning. See Info:\"(erc) Modules\" for more."
+ (mapcar (lambda (s) (format "`%s'" s)) missing-deps)))))
+
+;;;###autoload(put 'fill-wrap 'erc--feature 'erc-fill)
+(define-erc-module fill-wrap nil
+ "Fill style leveraging `visual-line-mode'.
+
+This module displays nicks overhanging leftward to a common
+offset, as determined by the option `erc-fill-static-center'. It
+also \"wraps\" messages at a common width, as determined by the
+option `erc-fill-wrap-margin-width'. To use it, either include
+`fill-wrap' in `erc-modules' or set `erc-fill-function' to
+`erc-fill-wrap'.
+
+Once enabled, use \\[erc-fill-wrap-nudge] to adjust the width of
+the indent and the stamp margin. And For cycling between
+logical- and screen-line oriented command movement, see
+\\[erc-fill-wrap-toggle-truncate-lines]. Similarly, use
+\\[erc-fill-wrap-refill-buffer] to fix alignment problems after
+running certain commands, like `text-scale-adjust'. Also see
+related stylistic options `erc-fill-wrap-merge', and
+`erc-fill-wrap-merge-indicator'. (Hint: in narrow windows, try
+setting `erc-fill-static-center' to 1, and if you use
+`erc-fill-wrap-merge-indicator', choose \"Leading MIDDLE DOT sans
+gap\" or one of the \"trailing\" items from the Customize menu.)
+
+This module imposes various restrictions on the appearance of
+timestamps. Most notably, it insists on displaying them in the
+margins. Users preferring left-sided stamps may notice that ERC
+also displays the prompt in the left margin, possibly truncating
+or padding it to constrain it to the margin's width.
+Additionally, this module assumes that users providing their own
+`erc-insert-timestamp-function' have also customized the option
+`erc-fill-wrap-margin-side' to an explicit side. When stamps
+appear in the right margin, which they do by default, users may
+find that ERC actually appends them to copy-as-killed messages
+without an intervening space. This normally poses at most a
+minor inconvenience, however users of the `log' module may prefer
+a workaround provided by `erc-stamp-prefix-log-filter', which
+strips trailing stamps from logged messages and instead prepends
+them to every line.
+
+A so-called \"local\" module, `fill-wrap' depends on the global
+modules `fill', `stamp', `button', and `scrolltobottom'. It
+activates them as needed when initializing and leaves them
+enabled when shutting down. To opt out of `scrolltobottom'
+specifically, disable its minor mode, `erc-scrolltobottom-mode',
+via `erc-fill-wrap-mode-hook'."
+ ((erc-fill--wrap-ensure-dependencies)
+ (erc--restore-initialize-priors erc-fill-wrap-mode
+ erc-fill--wrap-visual-keys erc-fill-wrap-visual-keys
+ erc-fill--wrap-value erc-fill-static-center
+ erc-stamp--margin-width erc-fill-wrap-margin-width
+ left-margin-width left-margin-width
+ right-margin-width right-margin-width)
+ (setq erc-stamp--margin-left-p
+ (or (eq erc-fill-wrap-margin-side 'left)
+ (eq (default-value 'erc-insert-timestamp-function)
+ #'erc-insert-timestamp-left)))
+ (when erc-fill-wrap-align-prompt
+ (add-hook 'erc--refresh-prompt-hook
+ #'erc-fill--wrap-indent-prompt nil t))
+ (when erc-stamp--margin-left-p
+ (if erc-fill-wrap-align-prompt
+ (setq erc-stamp--skip-left-margin-prompt-p t)
+ (setq erc--inhibit-prompt-display-property-p t)))
+ (setq erc-fill--function #'erc-fill-wrap)
+ (when erc-fill-wrap-merge
+ (add-hook 'erc-button--prev-next-predicate-functions
+ #'erc-fill--wrap-merged-button-p nil t))
+ (erc-stamp--display-margin-mode +1)
+ (visual-line-mode +1))
+ ((visual-line-mode -1)
+ (erc-stamp--display-margin-mode -1)
+ (kill-local-variable 'erc-fill--wrap-value)
+ (kill-local-variable 'erc-fill--function)
+ (kill-local-variable 'erc-fill--wrap-visual-keys)
+ (kill-local-variable 'erc-fill--wrap-last-msg)
+ (kill-local-variable 'erc--inhibit-prompt-display-property-p)
+ (kill-local-variable 'erc-fill--wrap-merge-indicator-pre)
+ (kill-local-variable 'erc-fill--wrap-merge-indicator-post)
+ (remove-hook 'erc--refresh-prompt-hook
+ #'erc-fill--wrap-indent-prompt)
+ (remove-hook 'erc-button--prev-next-predicate-functions
+ #'erc-fill--wrap-merged-button-p t))
+ 'local)
+
+(defvar-local erc-fill--wrap-length-function nil
+ "Function to determine length of overhanging characters.
+It should return an EXPR as defined by the Info node `(elisp)
+Pixel Specification'. This value should represent the width of
+the overhang with all faces applied, including any enclosing
+brackets (which are not normally fontified) and a trailing space.
+It can also return nil to tell ERC to fall back to the default
+behavior of taking the length from the first \"word\". This
+variable can be converted to a public one if needed by third
+parties.")
+
+(defvar-local erc-fill--wrap-last-msg nil "Marker for merging speakers.")
+(defvar erc-fill--wrap-max-lull (* 24 60 60) "Max secs for merging speakers.")
+
+(defun erc-fill--wrap-continued-message-p ()
+ "Return non-nil when the current speaker hasn't changed.
+But only if the `erc--msg' text property also hasn't. That is,
+indicate whether the chat message just inserted is from the same
+person as the prior one and is formatted in the same manner. As
+a side effect, advance `erc-fill--wrap-last-msg' unless the
+message has been marked `erc--ephemeral'."
+ (and-let*
+ (((not (erc--check-msg-prop 'erc--ephemeral)))
+ ;; Always set/move `erc-fill--wrap-last-msg' from here on down.
+ (m (or (and erc-fill--wrap-last-msg
+ (prog1 (marker-position erc-fill--wrap-last-msg)
+ (set-marker erc-fill--wrap-last-msg (point-min))))
+ (ignore (setq erc-fill--wrap-last-msg (point-min-marker)))))
+ ((>= (point) 4)) ; skip the first message
+ (props (save-restriction
+ (widen)
+ (and-let* ((speaker (get-text-property m 'erc--spkr))
+ (type (get-text-property m 'erc--msg))
+ ((not (invisible-p m))))
+ (list (get-text-property m 'erc--ts) type speaker))))
+ (ts (nth 0 props))
+ (type (nth 1 props))
+ (speaker (nth 2 props))
+ ((not (time-less-p (erc-stamp--current-time) ts)))
+ ((time-less-p (time-subtract (erc-stamp--current-time) ts)
+ erc-fill--wrap-max-lull))
+ ((erc--check-msg-prop 'erc--msg type))
+ ((erc-nick-equal-p speaker (erc--check-msg-prop 'erc--spkr))))))
+
+(defun erc-fill--wrap-measure (beg end)
+ "Return display spec width for inserted region between BEG and END.
+Ignore any `invisible' props that may be present when figuring.
+Expect the target region to be free of `line-prefix' and
+`wrap-prefix' properties, and expect `display-line-numbers-mode'
+to be disabled."
+ (if (fboundp 'buffer-text-pixel-size)
+ ;; `buffer-text-pixel-size' can move point!
+ (save-excursion
+ (save-restriction
+ (narrow-to-region beg end)
+ (let* ((buffer-invisibility-spec)
+ (rv (car (buffer-text-pixel-size))))
+ (if erc-fill-wrap-use-pixels
+ (if (zerop rv) 0 (list rv))
+ (/ rv (frame-char-width))))))
+ (- end beg)))
+
+;; An escape hatch for third-party code expecting speakers of ACTION
+;; messages to be exempt from `line-prefix'. This could be converted
+;; into a user option if users feel similarly.
+(defvar erc-fill--wrap-action-dedent-p t
+ "Whether to dedent speakers in CTCP \"ACTION\" lines.")
+
+(defvar-local erc-fill--wrap-merge-indicator-pre nil)
+(defvar-local erc-fill--wrap-merge-indicator-post nil)
+
+;; To support `erc-fill-line-spacing' with the "post" variant, we'd
+;; need to use a new "replacing" `display' spec value for each
+;; insertion, and add a sentinel property alongside it atop every
+;; affected newline, e.g., (erc-fill-eol-display START-POS), where
+;; START-POS is the position of the newline in the replacing string.
+;; Then, upon spotting this sentinel in `erc-fill' (and maybe
+;; `erc-fill-wrap-refill-buffer'), we'd add `line-spacing' to the
+;; corresponding `display' replacement, starting at START-POS.
+(defun erc-fill--wrap-insert-merged-post ()
+ "Add `display' property at end of previous line."
+ (save-excursion
+ (goto-char (point-min))
+ (save-restriction
+ (widen)
+ (cl-assert (= ?\n (char-before (point))))
+ (unless erc-fill--wrap-merge-indicator-post
+ (let ((option (cdr erc-fill-wrap-merge-indicator)))
+ (setq erc-fill--wrap-merge-indicator-post
+ (if (stringp option)
+ (concat option
+ (and (not (string-suffix-p "\n" option)) "\n"))
+ (propertize (concat (string (car option)) "\n")
+ 'font-lock-face (cadr option))))))
+ (unless (eq (field-at-pos (- (point) 2)) 'erc-timestamp)
+ (put-text-property (1- (point)) (point)
+ 'display erc-fill--wrap-merge-indicator-post)))
+ 0))
+
+(defun erc-fill--wrap-insert-merged-pre ()
+ "Add `display' property in lieu of speaker."
+ (if erc-fill--wrap-merge-indicator-pre
+ (progn
+ (put-text-property (point-min) (point) 'display
+ (car erc-fill--wrap-merge-indicator-pre))
+ (cdr erc-fill--wrap-merge-indicator-pre))
+ (let* ((option (cdr erc-fill-wrap-merge-indicator))
+ (s (if (stringp option)
+ (concat option)
+ (concat (propertize (string (car option))
+ 'font-lock-face (cadr option))
+ " "))))
+ (put-text-property (point-min) (point) 'display s)
+ (cdr (setq erc-fill--wrap-merge-indicator-pre
+ (cons s (erc-fill--wrap-measure (point-min) (point))))))))
+
+(defun erc-fill-wrap ()
+ "Use text props to mimic the effect of `erc-fill-static'.
+See `erc-fill-wrap-mode' for details."
+ (unless erc-fill-wrap-mode
+ (erc-fill-wrap-mode +1))
+ (save-excursion
+ (goto-char (point-min))
+ (let ((len (or (and erc-fill--wrap-length-function
+ (funcall erc-fill--wrap-length-function))
+ (and-let* ((msg-prop (erc--check-msg-prop 'erc--msg))
+ ((not (eq msg-prop 'unknown))))
+ (when-let ((e (erc--get-speaker-bounds))
+ (b (pop e))
+ ((or erc-fill--wrap-action-dedent-p
+ (not (erc--check-msg-prop 'erc--ctcp
+ 'ACTION)))))
+ (goto-char e))
+ (skip-syntax-forward "^-")
+ (forward-char)
+ (cond ((eq msg-prop 'datestamp)
+ (when erc-fill--wrap-last-msg
+ (set-marker erc-fill--wrap-last-msg (point-min)))
+ (save-excursion
+ (goto-char (point-max))
+ (skip-chars-backward "\n")
+ (let ((beg (pos-bol)))
+ (insert " ")
+ (prog1 (erc-fill--wrap-measure beg (point))
+ (delete-region (1- (point)) (point))))))
+ ((and erc-fill-wrap-merge
+ (erc-fill--wrap-continued-message-p))
+ (put-text-property (point-min) (point)
+ 'display "")
+ (if erc-fill-wrap-merge-indicator
+ (pcase (car erc-fill-wrap-merge-indicator)
+ ('pre (erc-fill--wrap-insert-merged-pre))
+ ('post (erc-fill--wrap-insert-merged-post)))
+ 0))
+ (t
+ (erc-fill--wrap-measure (point-min) (point))))))))
+ (add-text-properties
+ (point-min) (1- (point-max)) ; exclude "\n"
+ `( line-prefix (space :width ,(if len
+ `(- erc-fill--wrap-value ,len)
+ 'erc-fill--wrap-value))
+ wrap-prefix (space :width erc-fill--wrap-value))))))
+
+(defun erc-fill--wrap-indent-prompt ()
+ "Recompute the `line-prefix' of the prompt."
+ ;; Clear an existing `line-prefix' before measuring (bug#64971).
+ (remove-text-properties erc-insert-marker erc-input-marker
+ '(line-prefix nil wrap-prefix nil))
+ ;; Restoring window configuration seems to prevent unwanted
+ ;; recentering reminiscent of `scrolltobottom'-related woes.
+ (let ((c (and (get-buffer-window) (current-window-configuration)))
+ (len (erc-fill--wrap-measure erc-insert-marker erc-input-marker)))
+ (when c
+ (set-window-configuration c))
+ (put-text-property erc-insert-marker erc-input-marker
+ 'line-prefix
+ `(space :width (- erc-fill--wrap-value ,len)))))
+
+(defvar erc-fill--wrap-rejigger-last-message nil
+ "Temporary working instance of `erc-fill--wrap-last-msg'.")
+
+(defun erc-fill--wrap-rejigger-region (start finish on-next repairp)
+ "Recalculate `line-prefix' from START to FINISH.
+After refilling each message, call ON-NEXT with no args. But
+stash and restore `erc-fill--wrap-last-msg' before doing so, in
+case this module's insert hooks run by way of the process filter.
+With REPAIRP, destructively fill gaps and re-merge speakers."
+ (goto-char start)
+ (cl-assert (null erc-fill--wrap-rejigger-last-message))
+ (setq erc-fill--wrap-merge-indicator-pre nil
+ erc-fill--wrap-merge-indicator-post nil)
+ (let (erc-fill--wrap-rejigger-last-message)
+ (while-let
+ (((< (point) finish))
+ (beg (if (get-text-property (point) 'line-prefix)
+ (point)
+ (next-single-property-change (point) 'line-prefix)))
+ (val (get-text-property beg 'line-prefix))
+ (end (text-property-not-all beg finish 'line-prefix val)))
+ ;; If this is a left-side stamp on its own line.
+ (remove-text-properties beg (1+ end) '(line-prefix nil wrap-prefix nil))
+ (when-let ((repairp)
+ (dbeg (text-property-not-all beg end 'display nil))
+ ((get-text-property (1+ dbeg) 'erc--speaker))
+ (dval (get-text-property dbeg 'display))
+ ((equal "" dval)))
+ (remove-text-properties
+ dbeg (text-property-not-all dbeg end 'display dval) '(display)))
+ ;; This "should" work w/o `front-sticky' and `rear-nonsticky'.
+ (let* ((pos (if-let (((eq 'erc-timestamp (field-at-pos beg)))
+ (b (field-beginning beg))
+ ((eq 'datestamp (get-text-property b 'erc--msg))))
+ b
+ beg))
+ (erc--msg-props (map-into (text-properties-at pos) 'hash-table))
+ (erc-stamp--current-time (gethash 'erc--ts erc--msg-props)))
+ (save-restriction
+ (narrow-to-region beg (1+ end))
+ (let ((erc-fill--wrap-last-msg erc-fill--wrap-rejigger-last-message))
+ (erc-fill-wrap)
+ (setq erc-fill--wrap-rejigger-last-message
+ erc-fill--wrap-last-msg))))
+ (when on-next
+ (funcall on-next))
+ ;; Skip to end of message upon encountering accidental gaps
+ ;; introduced by third parties (or bugs).
+ (if-let (((/= ?\n (char-after end)))
+ (next (erc--get-inserted-msg-end beg)))
+ (progn
+ (cl-assert (= ?\n (char-after next)))
+ (when repairp ; eol <= next
+ (put-text-property end (pos-eol) 'line-prefix val))
+ (goto-char next))
+ (goto-char end)))))
+
+(defun erc-fill-wrap-refill-buffer (repair)
+ "Recalculate all `fill-wrap' prefixes in the current buffer.
+With REPAIR, attempt to refresh \"speaker merges\", which may be
+necessary after revealing previously hidden text with commands
+like `erc-match-toggle-hidden-fools'."
+ (interactive "P")
+ (unless erc-fill-wrap-mode
+ (user-error "Module `fill-wrap' not active in current buffer."))
+ (save-excursion
+ (with-silent-modifications
+ (let* ((rep (make-progress-reporter
+ "Rewrap" 0 (line-number-at-pos erc-insert-marker) 1))
+ (seen 0)
+ (callback (lambda ()
+ (progress-reporter-update rep (cl-incf seen))
+ (accept-process-output nil 0.000001))))
+ (erc-fill--wrap-rejigger-region (point-min) erc-insert-marker
+ callback repair)
+ (progress-reporter-done rep)))))
+
+;; FIXME use own text property to avoid false positives.
+(defun erc-fill--wrap-merged-button-p (point)
+ (equal "" (get-text-property point 'display)))
+
+(defun erc-fill--wrap-nudge (arg)
+ (when (zerop arg)
+ (setq arg (- erc-fill-static-center erc-fill--wrap-value)))
+ (cl-incf erc-fill--wrap-value arg)
+ arg)
+
+(defun erc-fill-wrap-nudge (arg)
+ "Adjust `erc-fill-wrap' by ARG columns.
+Offer to repeat command in a manner similar to
+`text-scale-adjust'.
+
+ \\`=' Increase indentation by one column
+ \\`-' Decrease indentation by one column
+ \\`0' Reset indentation to the default
+ \\`+' Shift margin boundary rightward by one column
+ \\`_' Shift margin boundary leftward by one column
+ \\`)' Reset the right margin to the default
+
+Note that misalignment may occur when messages contain
+decorations applied by third-party modules."
+ (interactive "p")
+ (unless erc-fill--wrap-value
+ (cl-assert (not erc-fill-wrap-mode))
+ (user-error "Minor mode `erc-fill-wrap-mode' disabled"))
+ (unless (get-buffer-window)
+ (user-error "Command called in an undisplayed buffer"))
+ (let* ((total (erc-fill--wrap-nudge arg))
+ (leftp erc-stamp--margin-left-p)
+ ;; Anchor current line vertically.
+ (line (count-screen-lines (window-start) (window-point))))
+ (when (zerop arg)
+ (setq arg 1))
+ (compat-call
+ set-transient-map
+ (let ((map (make-sparse-keymap)))
+ (dolist (key '(?= ?- ?0))
+ (let ((a (pcase key
+ (?0 0)
+ (?- (- (abs arg)))
+ (_ (abs arg)))))
+ (define-key map (vector (list key))
+ (lambda ()
+ (interactive)
+ (cl-incf total (erc-fill--wrap-nudge a))
+ (recenter line)))))
+ (dolist (key '(?\) ?_ ?+))
+ (let ((a (pcase key
+ (?\) 0)
+ (?_ (if leftp (abs arg) (- (abs arg))))
+ (?+ (if leftp (- (abs arg)) (abs arg))))))
+ (define-key map (vector (list key))
+ (lambda ()
+ (interactive)
+ (erc-stamp--adjust-margin (- a) (zerop a))
+ (when leftp (erc-stamp--refresh-left-margin-prompt))
+ (recenter line)))))
+ map)
+ t
+ (lambda ()
+ (message "Fill prefix: %d (%+d col%s); Margin: %d"
+ erc-fill--wrap-value total (if (> (abs total) 1) "s" "")
+ (if leftp left-margin-width right-margin-width)))
+ "Use %k for further adjustment"
+ 1)
+ (recenter line)))
+
(defun erc-fill-regarding-timestamp ()
"Fills a text such that messages start at column `erc-fill-static-center'."
(fill-region (point-min) (point-max) t t)
@@ -178,6 +879,7 @@ You can put this on `erc-insert-modify-hook' and/or `erc-send-modify-hook'."
"Get length of timestamp if inserted left."
(if (and (boundp 'erc-timestamp-format)
erc-timestamp-format
+ ;; FIXME use a more robust test than symbol equivalence.
(eq erc-insert-timestamp-function 'erc-insert-timestamp-left)
(not erc-hide-timestamps))
(length (format-time-string erc-timestamp-format))
diff --git a/lisp/erc/erc-goodies.el b/lisp/erc/erc-goodies.el
index 6d1e7468aac..fe44c3bdfcb 100644
--- a/lisp/erc/erc-goodies.el
+++ b/lisp/erc/erc-goodies.el
@@ -29,30 +29,13 @@
;;; Code:
-;;; Imenu support
-
(eval-when-compile (require 'cl-lib))
-(require 'erc-common)
-
-(defvar erc-controls-highlight-regexp)
-(defvar erc-controls-remove-regexp)
-(defvar erc-input-marker)
-(defvar erc-insert-marker)
-(defvar erc-server-process)
-(defvar erc-modules)
-(defvar erc-log-p)
-
-(declare-function erc-buffer-list "erc" (&optional predicate proc))
-(declare-function erc-error "erc" (&rest args))
-(declare-function erc-extract-command-from-line "erc" (line))
-(declare-function erc-beg-of-input-line "erc" nil)
+(require 'erc)
-(defun erc-imenu-setup ()
- "Setup Imenu support in an ERC buffer."
- (setq-local imenu-create-index-function #'erc-create-imenu-index))
+(declare-function fringe-columns "fringe" (side &optional real))
+(declare-function pulse-available-p "pulse" nil)
+(declare-function pulse-momentary-highlight-overlay "pulse" (o &optional face))
-(add-hook 'erc-mode-hook #'erc-imenu-setup)
-(autoload 'erc-create-imenu-index "erc-imenu" "Imenu index creation function")
;;; Automatically scroll to bottom
(defcustom erc-input-line-position nil
@@ -61,43 +44,177 @@
This should be an integer specifying the line of the buffer on which
the input line should stay. A value of \"-1\" would keep the input
line positioned on the last line in the buffer. This is passed as an
-argument to `recenter'."
+argument to `recenter', unless `erc-scrolltobottom-all' is
+`relaxed', in which case, ERC interprets it as additional lines
+to scroll down by per message insertion (minus one for the
+prompt)."
:group 'erc-display
:type '(choice integer (const nil)))
+(defcustom erc-scrolltobottom-all nil
+ "Whether to scroll all windows or just the selected one.
+ERC expects this option to be configured before module
+initialization. A value of nil preserves pre-5.6 behavior, in
+which scrolling only affects the selected window. A value of t
+means ERC attempts to recenter all visible windows whose point
+resides in the input area.
+
+A value of `relaxed' tells ERC to forgo forcing prompt to the
+bottom of the window. When point is at the prompt, ERC scrolls
+the window up when inserting messages, making the prompt appear
+stationary. Users who find this effect too \"stagnant\" can
+adjust the option `erc-input-line-position', borrowed here to
+express a scroll step offset. Setting that value to zero lets
+the prompt drift toward the bottom by one line per message, which
+is generally slow enough not to distract while composing input.
+Of course, this doesn't apply when receiving a large influx of
+messages, such as after typing \"/msg NickServ help\".
+
+Note that users should consider this option's non-nil behavior to
+be experimental. It currently only works with Emacs 28+."
+ :group 'erc-display
+ :package-version '(ERC . "5.6")
+ :type '(choice boolean (const relaxed)))
+
+;;;###autoload(autoload 'erc-scrolltobottom-mode "erc-goodies" nil t)
(define-erc-module scrolltobottom nil
"This mode causes the prompt to stay at the end of the window."
- ((add-hook 'erc-mode-hook #'erc-add-scroll-to-bottom)
- (add-hook 'erc-insert-done-hook #'erc-possibly-scroll-to-bottom)
- (dolist (buffer (erc-buffer-list))
- (with-current-buffer buffer
- (erc-add-scroll-to-bottom))))
- ((remove-hook 'erc-mode-hook #'erc-add-scroll-to-bottom)
- (remove-hook 'erc-insert-done-hook #'erc-possibly-scroll-to-bottom)
- (dolist (buffer (erc-buffer-list))
- (with-current-buffer buffer
- (remove-hook 'post-command-hook #'erc-scroll-to-bottom t)))))
+ ((add-hook 'erc-mode-hook #'erc--scrolltobottom-setup)
+ (when (and erc-scrolltobottom-all (< emacs-major-version 28))
+ (erc-button--display-error-notice-with-keys
+ "Option `erc-scrolltobottom-all' requires Emacs 28+. Disabling.")
+ (setq erc-scrolltobottom-all nil))
+ (unless erc--updating-modules-p (erc-buffer-do #'erc--scrolltobottom-setup))
+ (if erc-scrolltobottom-all
+ (progn
+ (add-hook 'erc-insert-pre-hook #'erc--scrolltobottom-on-pre-insert 25)
+ (add-hook 'erc-pre-send-functions #'erc--scrolltobottom-on-pre-insert)
+ (add-hook 'erc-insert-done-hook #'erc--scrolltobottom-all)
+ (add-hook 'erc-send-completed-hook #'erc--scrolltobottom-all))
+ (add-hook 'erc-insert-done-hook #'erc-possibly-scroll-to-bottom)))
+ ((remove-hook 'erc-mode-hook #'erc--scrolltobottom-setup)
+ (erc-buffer-do #'erc--scrolltobottom-setup)
+ (remove-hook 'erc-insert-pre-hook #'erc--scrolltobottom-on-pre-insert)
+ (remove-hook 'erc-send-completed-hook #'erc--scrolltobottom-all)
+ (remove-hook 'erc-insert-done-hook #'erc--scrolltobottom-all)
+ (remove-hook 'erc-pre-send-functions #'erc--scrolltobottom-on-pre-insert)
+ (remove-hook 'erc-insert-done-hook #'erc-possibly-scroll-to-bottom)))
(defun erc-possibly-scroll-to-bottom ()
"Like `erc-add-scroll-to-bottom', but only if window is selected."
(when (eq (selected-window) (get-buffer-window))
(erc-scroll-to-bottom)))
+(defvar-local erc--scrolltobottom-window-info nil
+ "Alist with windows as keys and lists of window-related info as values.
+Values are lists containing the last window start position and
+the last \"window line\" of point. The \"window line\", which
+may be nil, is the number of lines between `window-start' and
+`window-point', inclusive.")
+
+;; FIXME treat `end-of-buffer' specially and always recenter -1.
+;; FIXME make this work when `erc-scrolltobottom-all' is set to
+;; `relaxed'.
+(defvar erc--scrolltobottom-post-ignore-commands '(text-scale-adjust)
+ "Commands to skip instead of force-scroll on `post-command-hook'.")
+
+(defun erc--scrolltobottom-on-post-command ()
+ "Scroll selected window unless `this-command' is exempted."
+ (when (eq (selected-window) (get-buffer-window))
+ (unless (memq this-command erc--scrolltobottom-post-ignore-commands)
+ (setq erc--scrolltobottom-window-info nil)
+ (erc--scrolltobottom-confirm))))
+
+;; It may be desirable to also restore the relative line position of
+;; window point after changing dimensions. Perhaps stashing the
+;; previous ratio of window line to body height and later recentering
+;; proportionally would achieve this.
+(defun erc--scrolltobottom-on-win-conf-change ()
+ "Scroll window to bottom when at prompt and using the minibuffer."
+ (setq erc--scrolltobottom-window-info nil)
+ (erc--scrolltobottom-confirm))
+
+(defun erc--scrolltobottom-all (&rest _)
+ "Maybe put prompt on last line in all windows displaying current buffer.
+Expect to run when narrowing is in effect, such as on insertion
+or send-related hooks. When recentering has not been performed,
+attempt to restore last `window-start', if known."
+ (dolist (window (get-buffer-window-list nil nil 'visible))
+ (with-selected-window window
+ (when-let
+ ((erc--scrolltobottom-window-info)
+ (found (assq window erc--scrolltobottom-window-info))
+ ((not (erc--scrolltobottom-confirm (nth 2 found)))))
+ (set-window-start window (cadr found) 'no-force))))
+ ;; Necessary unless we're sure `erc--scrolltobottom-on-pre-insert'
+ ;; always runs between calls to this function.
+ (setq erc--scrolltobottom-window-info nil))
+
(defun erc-add-scroll-to-bottom ()
"A hook function for `erc-mode-hook' to recenter output at bottom of window.
If you find that ERC hangs when using this function, try customizing
the value of `erc-input-line-position'.
-This works whenever scrolling happens, so it's added to
-`window-scroll-functions' rather than `erc-insert-post-hook'."
+Note that the prior suggestion comes from a time when this
+function used `window-scroll-functions', which was replaced by
+`post-command-hook' in ERC 5.3."
+ (declare (obsolete erc--scrolltobottom-setup "30.1"))
(add-hook 'post-command-hook #'erc-scroll-to-bottom nil t))
+(defun erc--scrolltobottom-setup ()
+ "Perform buffer-local setup for module `scrolltobottom'."
+ (if erc-scrolltobottom-mode
+ (if erc-scrolltobottom-all
+ (progn
+ (setq-local read-minibuffer-restore-windows nil)
+ (when (zerop scroll-conservatively)
+ (setq-local scroll-step 1))
+ (unless (eq erc-scrolltobottom-all 'relaxed)
+ (add-hook 'window-configuration-change-hook
+ #'erc--scrolltobottom-on-win-conf-change 50 t)
+ (add-hook 'post-command-hook
+ #'erc--scrolltobottom-on-post-command 50 t)))
+ (add-hook 'post-command-hook #'erc-scroll-to-bottom nil t))
+ (remove-hook 'post-command-hook #'erc-scroll-to-bottom t)
+ (remove-hook 'post-command-hook #'erc--scrolltobottom-on-post-command t)
+ (remove-hook 'window-configuration-change-hook
+ #'erc--scrolltobottom-on-win-conf-change t)
+ (kill-local-variable 'read-minibuffer-restore-windows)
+ (kill-local-variable 'scroll-step)
+ (kill-local-variable 'erc--scrolltobottom-window-info)))
+
+(defun erc--scrolltobottom-on-pre-insert (_)
+ "Remember `window-start' before inserting a message."
+ (setq erc--scrolltobottom-window-info
+ (mapcar (lambda (w)
+ (list w
+ (window-start w)
+ (and-let*
+ (((eq erc-scrolltobottom-all 'relaxed))
+ (c (count-screen-lines (window-start w)
+ (point-max) nil w)))
+ (if (= ?\n (char-before (point-max))) (1+ c) c))))
+ (get-buffer-window-list nil nil 'visible))))
+
+(defun erc--scrolltobottom-confirm (&optional scroll-to)
+ "Like `erc-scroll-to-bottom', but use `window-point'.
+Position current line (with `recenter') SCROLL-TO lines below
+window's top. Return nil if point is not in prompt area or if
+prompt isn't ready."
+ (when erc-insert-marker
+ (let ((resize-mini-windows nil))
+ (save-restriction
+ (widen)
+ (when (>= (window-point) erc-input-marker)
+ (save-excursion
+ (goto-char (point-max))
+ (recenter (+ (or scroll-to 0) (or erc-input-line-position -1)))
+ t))))))
+
(defun erc-scroll-to-bottom ()
"Recenter WINDOW so that `point' is on the last line.
-This is added to `window-scroll-functions' by `erc-add-scroll-to-bottom'.
-
You can control which line is recentered to by customizing the
variable `erc-input-line-position'."
;; Temporarily bind resize-mini-windows to nil so that users who have it
@@ -109,6 +226,7 @@ variable `erc-input-line-position'."
(save-restriction
(widen)
(when (and erc-insert-marker
+ (eq (current-buffer) (window-buffer))
;; we're editing a line. Scroll.
(> (point) erc-insert-marker))
(save-excursion
@@ -116,10 +234,11 @@ variable `erc-input-line-position'."
(recenter (or erc-input-line-position -1)))))))
;;; Make read only
+;;;###autoload(autoload 'erc-readonly-mode "erc-goodies" nil t)
(define-erc-module readonly nil
"This mode causes all inserted text to be read-only."
- ((add-hook 'erc-insert-post-hook #'erc-make-read-only)
- (add-hook 'erc-send-post-hook #'erc-make-read-only))
+ ((add-hook 'erc-insert-post-hook #'erc-make-read-only 70)
+ (add-hook 'erc-send-post-hook #'erc-make-read-only 70))
((remove-hook 'erc-insert-post-hook #'erc-make-read-only)
(remove-hook 'erc-send-post-hook #'erc-make-read-only)))
@@ -131,12 +250,11 @@ Put this function on `erc-insert-post-hook' and/or `erc-send-post-hook'."
(put-text-property (point-min) (point-max) 'rear-nonsticky t))
;;; Move to prompt when typing text
+;;;###autoload(autoload 'erc-move-to-prompt-mode "erc-goodies" nil t)
(define-erc-module move-to-prompt nil
"This mode causes the point to be moved to the prompt when typing text."
((add-hook 'erc-mode-hook #'erc-move-to-prompt-setup)
- (dolist (buffer (erc-buffer-list))
- (with-current-buffer buffer
- (erc-move-to-prompt-setup))))
+ (unless erc--updating-modules-p (erc-buffer-do #'erc-move-to-prompt-setup)))
((remove-hook 'erc-mode-hook #'erc-move-to-prompt-setup)
(dolist (buffer (erc-buffer-list))
(with-current-buffer buffer
@@ -152,14 +270,196 @@ Put this function on `erc-insert-post-hook' and/or `erc-send-post-hook'."
(defun erc-move-to-prompt-setup ()
"Initialize the move-to-prompt module."
- (add-hook 'pre-command-hook #'erc-move-to-prompt nil t))
+ (add-hook 'pre-command-hook #'erc-move-to-prompt 70 t))
;;; Keep place in unvisited channels
+;;;###autoload(autoload 'erc-keep-place-mode "erc-goodies" nil t)
(define-erc-module keep-place nil
"Leave point above un-viewed text in other channels."
- ((add-hook 'erc-insert-pre-hook #'erc-keep-place))
+ ((add-hook 'erc-insert-pre-hook #'erc-keep-place 65))
((remove-hook 'erc-insert-pre-hook #'erc-keep-place)))
+(defcustom erc-keep-place-indicator-style t
+ "Flavor of visual indicator applied to kept place.
+For use with the `keep-place-indicator' module. A value of `arrow'
+displays an arrow in the left fringe or margin. When it's
+`face', ERC adds the face `erc-keep-place-indicator-line' to the
+appropriate line. A value of t does both."
+ :group 'erc
+ :package-version '(ERC . "5.6")
+ :type '(choice (const :tag "Use arrow" arrow)
+ (const :tag "Use face" face)
+ (const :tag "Use both arrow and face" t)))
+
+(defcustom erc-keep-place-indicator-buffer-type t
+ "ERC buffer type in which to display `keep-place-indicator'.
+A value of t means \"all\" ERC buffers."
+ :group 'erc
+ :package-version '(ERC . "5.6")
+ :type '(choice (const t) (const server) (const target)))
+
+(defcustom erc-keep-place-indicator-follow nil
+ "Whether to sync visual kept place to window's top when reading.
+For use with `erc-keep-place-indicator-mode'. When enabled, the
+indicator updates when the last window displaying the same buffer
+switches away, but only if the indicator resides earlier in the
+buffer than the window's start."
+ :group 'erc
+ :package-version '(ERC . "5.6")
+ :type 'boolean)
+
+(defface erc-keep-place-indicator-line
+ '((((class color) (min-colors 88) (background light)
+ (supports :underline (:style wave)))
+ (:underline (:color "PaleGreen3" :style wave)))
+ (((class color) (min-colors 88) (background dark)
+ (supports :underline (:style wave)))
+ (:underline (:color "PaleGreen1" :style wave)))
+ (t :underline t))
+ "Face for option `erc-keep-place-indicator-style'."
+ :group 'erc-faces)
+
+(defface erc-keep-place-indicator-arrow
+ '((((class color) (min-colors 88) (background light))
+ (:foreground "PaleGreen3"))
+ (((class color) (min-colors 88) (background dark))
+ (:foreground "PaleGreen1"))
+ (t :inherit fringe))
+ "Face for arrow value of option `erc-keep-place-indicator-style'."
+ :group 'erc-faces)
+
+(defvar-local erc--keep-place-indicator-overlay nil
+ "Overlay for `erc-keep-place-indicator-mode'.")
+
+(defun erc--keep-place-indicator-on-window-buffer-change (_)
+ "Maybe sync `erc--keep-place-indicator-overlay'.
+Do so only when switching to a new buffer in the same window if
+the replaced buffer is no longer visible in another window and
+its `window-start' at the time of switching is strictly greater
+than the indicator's position."
+ (when-let ((erc-keep-place-indicator-follow)
+ (window (selected-window))
+ ((not (eq window (active-minibuffer-window))))
+ (old-buffer (window-old-buffer window))
+ ((buffer-live-p old-buffer))
+ ((not (eq old-buffer (current-buffer))))
+ (ov (buffer-local-value 'erc--keep-place-indicator-overlay
+ old-buffer))
+ ((not (get-buffer-window old-buffer 'visible)))
+ (prev (assq old-buffer (window-prev-buffers window)))
+ (old-start (nth 1 prev))
+ (old-inmkr (buffer-local-value 'erc-insert-marker old-buffer))
+ ((< (overlay-end ov) old-start old-inmkr)))
+ (with-current-buffer old-buffer
+ (erc-keep-place-move old-start))))
+
+;;;###autoload(put 'keep-place-indicator 'erc--feature 'erc-goodies)
+;;;###autoload(autoload 'erc-keep-place-indicator-mode "erc-goodies" nil t)
+(define-erc-module keep-place-indicator nil
+ "Buffer-local `keep-place' with fringe arrow and/or highlighted face.
+Play nice with global module `keep-place' but don't depend on it.
+Expect that users may want different combinations of `keep-place'
+and `keep-place-indicator' in different buffers."
+ ((cond (erc-keep-place-mode)
+ ((memq 'keep-place erc-modules)
+ (erc-keep-place-mode +1))
+ ;; Enable a local version of `keep-place-mode'.
+ (t (add-hook 'erc-insert-pre-hook #'erc-keep-place 65 t)))
+ (require 'fringe)
+ (add-hook 'window-buffer-change-functions
+ #'erc--keep-place-indicator-on-window-buffer-change 40)
+ (add-hook 'erc-keep-place-mode-hook
+ #'erc--keep-place-indicator-on-global-module 40)
+ (if (pcase erc-keep-place-indicator-buffer-type
+ ('target erc--target)
+ ('server (not erc--target))
+ ('t t))
+ (progn
+ (erc--restore-initialize-priors erc-keep-place-indicator-mode
+ erc--keep-place-indicator-overlay (make-overlay 0 0))
+ (when-let (((memq erc-keep-place-indicator-style '(t arrow)))
+ (ov-property (if (zerop (fringe-columns 'left))
+ 'after-string
+ 'before-string))
+ (display (if (zerop (fringe-columns 'left))
+ `((margin left-margin) ,overlay-arrow-string)
+ '(left-fringe right-triangle
+ erc-keep-place-indicator-arrow)))
+ (bef (propertize " " 'display display)))
+ (overlay-put erc--keep-place-indicator-overlay ov-property bef))
+ (when (memq erc-keep-place-indicator-style '(t face))
+ (overlay-put erc--keep-place-indicator-overlay 'face
+ 'erc-keep-place-indicator-line)))
+ (erc-keep-place-indicator-mode -1)))
+ ((when erc--keep-place-indicator-overlay
+ (delete-overlay erc--keep-place-indicator-overlay))
+ (let ((buffer (current-buffer)))
+ ;; Remove global hooks unless others exist with mode enabled.
+ (unless (erc-buffer-filter (lambda ()
+ (and (not (eq buffer (current-buffer)))
+ erc-keep-place-indicator-mode)))
+ (remove-hook 'erc-keep-place-mode-hook
+ #'erc--keep-place-indicator-on-global-module)
+ (remove-hook 'window-buffer-change-functions
+ #'erc--keep-place-indicator-on-window-buffer-change)))
+ (when (local-variable-p 'erc-insert-pre-hook)
+ (remove-hook 'erc-insert-pre-hook #'erc-keep-place t))
+ (remove-hook 'erc-keep-place-mode-hook
+ #'erc--keep-place-indicator-on-global-module t)
+ (kill-local-variable 'erc--keep-place-indicator-overlay))
+ 'local)
+
+(defun erc--keep-place-indicator-on-global-module ()
+ "Ensure `keep-place-indicator' survives toggling `erc-keep-place-mode'.
+Do this by simulating `keep-place' in all buffers where
+`keep-place-indicator' is enabled."
+ (erc-with-all-buffers-of-server nil (lambda () erc-keep-place-indicator-mode)
+ (if erc-keep-place-mode
+ (remove-hook 'erc-insert-pre-hook #'erc-keep-place t)
+ (add-hook 'erc-insert-pre-hook #'erc-keep-place 65 t))))
+
+(defun erc-keep-place-move (pos)
+ "Move keep-place indicator to current line or POS.
+For use with `keep-place-indicator' module. When called
+interactively, interpret POS as an offset. Specifically, when
+POS is a raw prefix arg, like (4), move the indicator to the
+window's last line. When it's the minus sign, put it on the
+window's first line. Interpret an integer as an offset in lines."
+ (interactive
+ (progn
+ (unless erc-keep-place-indicator-mode
+ (user-error "`erc-keep-place-indicator-mode' not enabled"))
+ (list (pcase current-prefix-arg
+ ((and (pred integerp) v)
+ (save-excursion
+ (let ((inhibit-field-text-motion t))
+ (forward-line v)
+ (point))))
+ (`(,_) (1- (min erc-insert-marker (window-end))))
+ ('- (min (1- erc-insert-marker) (window-start)))))))
+ (save-excursion
+ (let ((inhibit-field-text-motion t))
+ (when pos
+ (goto-char pos))
+ (move-overlay erc--keep-place-indicator-overlay
+ (line-beginning-position)
+ (line-end-position)))))
+
+(defun erc-keep-place-goto ()
+ "Jump to keep-place indicator.
+For use with `keep-place-indicator' module."
+ (interactive
+ (prog1 nil
+ (unless erc-keep-place-indicator-mode
+ (user-error "`erc-keep-place-indicator-mode' not enabled"))
+ (deactivate-mark)
+ (push-mark)))
+ (goto-char (overlay-start erc--keep-place-indicator-overlay))
+ (recenter (truncate (* (window-height) 0.25)) t)
+ (require 'pulse)
+ (when (pulse-available-p)
+ (pulse-momentary-highlight-overlay erc--keep-place-indicator-overlay)))
+
(defun erc-keep-place (_ignored)
"Move point away from the last line in a non-selected ERC buffer."
(when (and (not (eq (window-buffer (selected-window))
@@ -168,6 +468,10 @@ Put this function on `erc-insert-post-hook' and/or `erc-send-post-hook'."
(deactivate-mark)
(goto-char (erc-beg-of-input-line))
(forward-line -1)
+ (when erc-keep-place-indicator-mode
+ (unless (or (minibuffer-window-active-p (selected-window))
+ (get-buffer-window nil 'visible))
+ (erc-keep-place-move nil)))
;; if `switch-to-buffer-preserve-window-point' is set,
;; we cannot rely on point being saved, and must commit
;; it to window-prev-buffers.
@@ -186,19 +490,26 @@ Put this function on `erc-insert-post-hook' and/or `erc-send-post-hook'."
erc-cmd-COUNTRY
erc-cmd-SV
erc-cmd-SM
- erc-cmd-SMV
+ erc-cmd-SAY
erc-cmd-LASTLOG)
- "List of commands that are aliases for CTCP ACTION or for ERC messages.
-
-If a command's function symbol is in this list, the typed command
-does not appear in the ERC buffer after the user presses ENTER.")
+ "List of client \"slash commands\" that perform their own buffer I/O.
+The `command-indicator' module forgoes echoing these commands,
+most of which aren't actual interactive lisp commands.")
+;;;###autoload(autoload 'erc-noncommands-mode "erc-goodies" nil t)
(define-erc-module noncommands nil
- "This mode distinguishes non-commands.
-Commands listed in `erc-insert-this' know how to display
-themselves."
- ((add-hook 'erc-pre-send-functions #'erc-send-distinguish-noncommands))
- ((remove-hook 'erc-pre-send-functions #'erc-send-distinguish-noncommands)))
+ "Treat commands that display themselves specially.
+This module has been a no-op since ERC 5.3 and has likely only
+ever made sense in the context of `erc-command-indicator'. It
+was deprecated in ERC 5.6."
+ ((add-hook 'erc--input-review-functions #'erc-send-distinguish-noncommands))
+ ((remove-hook 'erc--input-review-functions
+ #'erc-send-distinguish-noncommands)))
+(make-obsolete-variable 'erc-noncommand-mode
+ 'erc-command-indicator-mode "30.1")
+(make-obsolete 'erc-noncommand-mode 'erc-command-indicator-mode "30.1")
+(make-obsolete 'erc-noncommand-enable 'erc-command-indicator-enable "30.1")
+(make-obsolete 'erc-noncommand-disable 'erc-command-indicator-disable "30.1")
(defun erc-send-distinguish-noncommands (state)
"If STR is an ERC non-command, set `insertp' in STATE to nil."
@@ -212,6 +523,151 @@ themselves."
;; Inhibit sending this string.
(setf (erc-input-insertp state) nil))))
+
+;;; Command-indicator
+
+(defface erc-command-indicator-face
+ '((t :inherit (erc-input-face fixed-pitch-serif)))
+ "Face for echoed command lines, including the prompt.
+See option `erc-command-indicator'."
+ :package-version '(ERC . "5.6") ; standard value, from bold
+ :group 'erc-faces)
+
+(defcustom erc-command-indicator 'erc-prompt
+ "Pseudo prompt for echoed command lines.
+An analog of the option `erc-prompt' that replaces the \"speaker
+label\" for echoed \"slash\" commands submitted at the prompt. A
+value of nil means ERC only inserts the command-line portion
+alone, without the prompt, which may trick certain modules, like
+`fill', into treating the leading slash command itself as the
+message's speaker."
+ :package-version '(ERC . "5.6")
+ :group 'erc-display
+ :type '(choice (const :tag "Defer to `erc-prompt'" erc-prompt)
+ (const :tag "Print command lines without a prompt" nil)
+ (string :tag "User-provided string")
+ (function :tag "User-provided function")))
+
+;;;###autoload(autoload 'erc-command-indicator-mode "erc-goodies" nil t)
+(define-erc-module command-indicator nil
+ "Echo command lines for \"slash commands,\" like /JOIN, /HELP, etc.
+Skip those appearing in `erc-noncommands-list'.
+
+Users can run \\[erc-command-indicator-toggle-hidden] to hide and
+reveal echoed command lines after they've been inserted."
+ ((add-hook 'erc--input-review-functions
+ #'erc--command-indicator-permit-insertion 80 t)
+ (erc-command-indicator-toggle-hidden -1))
+ ((remove-hook 'erc--input-review-functions
+ #'erc--command-indicator-permit-insertion t)
+ (erc-command-indicator-toggle-hidden +1))
+ 'local)
+
+(defun erc-command-indicator ()
+ "Return the command-indicator prompt as a string.
+Do nothing if the variable `erc-command-indicator' is nil."
+ (and erc-command-indicator
+ (let ((prompt (if (functionp erc-command-indicator)
+ (funcall erc-command-indicator)
+ erc-command-indicator)))
+ (concat prompt (and (not (string-empty-p prompt))
+ (not (string-suffix-p " " prompt))
+ " ")))))
+
+(defun erc-command-indicator-toggle-hidden (arg)
+ "Toggle whether echoed \"slash commands\" are visible."
+ (interactive "P")
+ (erc--toggle-hidden 'command-indicator arg))
+
+(defun erc--command-indicator-permit-insertion (state)
+ "Insert `erc-input' STATE's message if it's an echoed command."
+ (cl-assert erc-command-indicator-mode)
+ (when (erc--input-split-cmdp state)
+ (setf (erc--input-split-insertp state) t
+ (erc--input-split-substxt state) #'erc--command-indicator-display)
+ (erc-send-distinguish-noncommands state)))
+
+;; This function used to be called `erc-display-command'. It was
+;; neutered in ERC 5.3.x (Emacs 24.5), commented out in 5.4, removed
+;; in 5.5, and restored in 5.6.
+(defun erc--command-indicator-display (line &rest rest)
+ "Insert command LINE as echoed input resembling that of REPLs and shells."
+ (when erc-insert-this
+ (when rest
+ (setq line (string-join (cons line rest) "\n")))
+ (save-excursion
+ (erc--assert-input-bounds)
+ (let ((insert-position (marker-position (goto-char erc-insert-marker)))
+ (erc--msg-props (or erc--msg-props
+ (let ((ovs erc--msg-prop-overrides))
+ (map-into `((erc--msg . slash-cmd)
+ ,@(reverse ovs))
+ 'hash-table)))))
+ (when-let ((string (erc-command-indicator))
+ (erc-input-marker (copy-marker erc-input-marker)))
+ (erc-display-prompt nil nil string 'erc-command-indicator-face)
+ (remove-text-properties insert-position (point)
+ '(field nil erc-prompt nil))
+ (set-marker erc-input-marker nil))
+ (let ((beg (point)))
+ (insert line)
+ (erc-put-text-property beg (point)
+ 'font-lock-face 'erc-command-indicator-face)
+ (insert "\n"))
+ (save-restriction
+ (narrow-to-region insert-position (point))
+ (run-hooks 'erc-send-modify-hook)
+ (run-hooks 'erc-send-post-hook)
+ (cl-assert (> (- (point-max) (point-min)) 1))
+ (erc--hide-message 'command-indicator)
+ (add-text-properties (point-min) (1+ (point-min))
+ (erc--order-text-properties-from-hash
+ erc--msg-props))))
+ (erc--refresh-prompt))))
+
+;;;###autoload
+(defun erc-load-irc-script-lines (lines &optional force noexpand)
+ "Process a list of LINES as prompt input submissions.
+If optional NOEXPAND is non-nil, do not expand script-specific
+substitution sequences via `erc-process-script-line' and instead
+process LINES as literal prompt input. With FORCE, bypass flood
+protection."
+ ;; The various erc-cmd-CMDs were designed to return non-nil when
+ ;; their command line should be echoed. But at some point, these
+ ;; handlers began displaying their own output, which naturally
+ ;; appeared *above* the echoed command. This tries to intercept
+ ;; these insertions, deferring them until the command has returned
+ ;; and its command line has been printed.
+ (cl-assert (eq 'erc-mode major-mode))
+ (let ((args (and erc-script-args
+ (if (string-match "^ " erc-script-args)
+ (substring erc-script-args 1)
+ erc-script-args))))
+ (with-silent-modifications
+ (dolist (line lines)
+ (erc-log (concat "erc-load-script: CMD: " line))
+ (unless (string-match (rx bot (* (syntax whitespace)) eot) line)
+ (unless noexpand
+ (setq line (erc-process-script-line line args)))
+ (let ((erc--current-line-input-split (erc--make-input-split line))
+ calls insertp)
+ (add-function :around (local 'erc--send-message-nested-function)
+ (lambda (&rest args) (push args calls))
+ '((name . erc-script-lines-fn) (depth . -80)))
+ (add-function :around (local 'erc--send-action-function)
+ (lambda (&rest args) (push args calls))
+ '((name . erc-script-lines-fn) (depth . -80)))
+ (setq insertp
+ (unwind-protect (erc-process-input-line line force)
+ (remove-function (local 'erc--send-action-function)
+ 'erc-script-lines-fn)
+ (remove-function (local 'erc--send-message-nested-function)
+ 'erc-script-lines-fn)))
+ (when (and insertp erc-script-echo)
+ (erc--command-indicator-display line)
+ (dolist (call calls)
+ (apply (car call) (cdr call))))))))))
+
;;; IRC control character processing.
(defgroup erc-control-characters nil
"Dealing with control characters."
@@ -247,14 +703,20 @@ The value `erc-interpret-controls-p' must also be t for this to work."
:group 'erc-faces)
(defface erc-inverse-face
- '((t :foreground "White" :background "Black"))
+ '((t :inverse-video t))
"ERC inverse face."
:group 'erc-faces)
+(defface erc-spoiler-face '((t :inherit default))
+ "ERC spoiler face."
+ :group 'erc-faces)
+
(defface erc-underline-face '((t :underline t))
"ERC underline face."
:group 'erc-faces)
+;; FIXME rename these to something like `erc-control-color-N-fg',
+;; and deprecate the old names via `define-obsolete-face-alias'.
(defface fg:erc-color-face0 '((t :foreground "White"))
"ERC face."
:group 'erc-faces)
@@ -353,19 +815,38 @@ The value `erc-interpret-controls-p' must also be t for this to work."
"ERC face."
:group 'erc-faces)
+;; https://lists.gnu.org/archive/html/emacs-erc/2021-07/msg00005.html
+(defvar erc--controls-additional-colors
+ ["#470000" "#472100" "#474700" "#324700" "#004700" "#00472c"
+ "#004747" "#002747" "#000047" "#2e0047" "#470047" "#47002a"
+ "#740000" "#743a00" "#747400" "#517400" "#007400" "#007449"
+ "#007474" "#004074" "#000074" "#4b0074" "#740074" "#740045"
+ "#b50000" "#b56300" "#b5b500" "#7db500" "#00b500" "#00b571"
+ "#00b5b5" "#0063b5" "#0000b5" "#7500b5" "#b500b5" "#b5006b"
+ "#ff0000" "#ff8c00" "#ffff00" "#b2ff00" "#00ff00" "#00ffa0"
+ "#00ffff" "#008cff" "#0000ff" "#a500ff" "#ff00ff" "#ff0098"
+ "#ff5959" "#ffb459" "#ffff71" "#cfff60" "#6fff6f" "#65ffc9"
+ "#6dffff" "#59b4ff" "#5959ff" "#c459ff" "#ff66ff" "#ff59bc"
+ "#ff9c9c" "#ffd39c" "#ffff9c" "#e2ff9c" "#9cff9c" "#9cffdb"
+ "#9cffff" "#9cd3ff" "#9c9cff" "#dc9cff" "#ff9cff" "#ff94d3"
+ "#000000" "#131313" "#282828" "#363636" "#4d4d4d" "#656565"
+ "#818181" "#9f9f9f" "#bcbcbc" "#e2e2e2" "#ffffff"])
+
(defun erc-get-bg-color-face (n)
"Fetches the right face for background color N (0-15)."
(if (stringp n) (setq n (string-to-number n)))
(if (not (numberp n))
(prog1 'default
(erc-error "erc-get-bg-color-face: n is NaN: %S" n))
- (when (> n 16)
+ (when (> n 99)
(erc-log (format " Wrong color: %s" n))
(setq n (mod n 16)))
(cond
((and (>= n 0) (< n 16))
(intern (concat "bg:erc-color-face" (number-to-string n))))
- (t (erc-log (format " Wrong color: %s" n)) 'default))))
+ ((< 15 n 99)
+ (list :background (aref erc--controls-additional-colors (- n 16))))
+ (t (erc-log (format " Wrong color: %s" n)) nil))))
(defun erc-get-fg-color-face (n)
"Fetches the right face for foreground color N (0-15)."
@@ -373,20 +854,44 @@ The value `erc-interpret-controls-p' must also be t for this to work."
(if (not (numberp n))
(prog1 'default
(erc-error "erc-get-fg-color-face: n is NaN: %S" n))
- (when (> n 16)
+ (when (> n 99)
(erc-log (format " Wrong color: %s" n))
(setq n (mod n 16)))
(cond
((and (>= n 0) (< n 16))
(intern (concat "fg:erc-color-face" (number-to-string n))))
- (t (erc-log (format " Wrong color: %s" n)) 'default))))
+ ((< 15 n 99)
+ (list :foreground (aref erc--controls-additional-colors (- n 16))))
+ (t (erc-log (format " Wrong color: %s" n)) nil))))
+;;;###autoload(autoload 'erc-irccontrols-mode "erc-goodies" nil t)
(define-erc-module irccontrols nil
"This mode enables the interpretation of IRC control chars."
- ((add-hook 'erc-insert-modify-hook #'erc-controls-highlight)
- (add-hook 'erc-send-modify-hook #'erc-controls-highlight))
+ ((add-hook 'erc-insert-modify-hook #'erc-controls-highlight -50)
+ (add-hook 'erc-send-modify-hook #'erc-controls-highlight)
+ (erc--modify-local-map t "C-c C-c" #'erc-toggle-interpret-controls))
((remove-hook 'erc-insert-modify-hook #'erc-controls-highlight)
- (remove-hook 'erc-send-modify-hook #'erc-controls-highlight)))
+ (remove-hook 'erc-send-modify-hook #'erc-controls-highlight)
+ (erc--modify-local-map nil "C-c C-c" #'erc-toggle-interpret-controls)))
+
+;; These patterns were moved here to circumvent compiler warnings but
+;; otherwise translated verbatim from their original string-literal
+;; definitions (minus a small bug fix to satisfy newly added tests).
+(defvar erc-controls-remove-regexp
+ (rx (or ?\C-b ?\C-\] ?\C-_ ?\C-v ?\C-g ?\C-o
+ (: ?\C-c (? (any "0-9")) (? (any "0-9"))
+ (? (group ?, (any "0-9") (? (any "0-9")))))))
+ "Regular expression matching control characters to remove.")
+
+;; Before the change to `rx', group 3 used to be a sibling of group 2.
+;; This was assumed to be a bug. A few minor simplifications were
+;; also performed. If incorrect, please admonish.
+(defvar erc-controls-highlight-regexp
+ (rx (group (or ?\C-b ?\C-\] ?\C-v ?\C-_ ?\C-g ?\C-o
+ (: ?\C-c (? (group (** 1 2 (any "0-9")))
+ (? (group ?, (group (** 1 2 (any "0-9")))))))))
+ (group (* (not (any ?\C-b ?\C-c ?\C-g ?\n ?\C-o ?\C-v ?\C-\] ?\C-_)))))
+ "Regular expression matching control chars to highlight.")
(defun erc-controls-interpret (str)
"Return a copy of STR after dealing with IRC control characters.
@@ -412,7 +917,7 @@ See `erc-interpret-controls-p' and `erc-interpret-mirc-color' for options."
(setq s (replace-match "" nil nil s 1))
(cond ((and erc-interpret-mirc-color (or fg-color bg-color))
(setq fg fg-color)
- (setq bg bg-color))
+ (when bg-color (setq bg bg-color)))
((string= control "\C-b")
(setq boldp (not boldp)))
((string= control "\C-]")
@@ -440,6 +945,7 @@ See `erc-interpret-controls-p' and `erc-interpret-mirc-color' for options."
s))
(t s)))))
+;;;###autoload
(defun erc-controls-strip (str)
"Return a copy of STR with all IRC control characters removed."
(when str
@@ -448,16 +954,6 @@ See `erc-interpret-controls-p' and `erc-interpret-mirc-color' for options."
(setq s (replace-match "" nil nil s)))
s)))
-(defvar erc-controls-remove-regexp
- "\C-b\\|\C-]\\|\C-_\\|\C-v\\|\C-g\\|\C-o\\|\C-c[0-9]?[0-9]?\\(,[0-9][0-9]?\\)?"
- "Regular expression which matches control characters to remove.")
-
-(defvar erc-controls-highlight-regexp
- (concat "\\(\C-b\\|\C-]\\|\C-v\\|\C-_\\|\C-g\\|\C-o\\|"
- "\C-c\\([0-9][0-9]?\\)?\\(,\\([0-9][0-9]?\\)\\)?\\)"
- "\\([^\C-b\C-]\C-v\C-_\C-c\C-g\C-o\n]*\\)")
- "Regular expression which matches control chars and the text to highlight.")
-
(defun erc-controls-highlight ()
"Highlight IRC control chars in the buffer.
This is useful for `erc-insert-modify-hook' and `erc-send-modify-hook'.
@@ -482,7 +978,7 @@ Also see `erc-interpret-controls-p' and `erc-interpret-mirc-color'."
(replace-match "" nil nil nil 1)
(cond ((and erc-interpret-mirc-color (or fg-color bg-color))
(setq fg fg-color)
- (setq bg bg-color))
+ (when bg-color (setq bg bg-color)))
((string= control "\C-b")
(setq boldp (not boldp)))
((string= control "\C-]")
@@ -514,6 +1010,16 @@ Also see `erc-interpret-controls-p' and `erc-interpret-mirc-color'."
"Prepend properties from IRC control characters between FROM and TO.
If optional argument STR is provided, apply to STR, otherwise prepend properties
to a region in the current buffer."
+ (when (and fg bg (equal fg bg) (not (equal fg "99")))
+ (add-text-properties from to '( mouse-face erc-spoiler-face
+ cursor-face erc-spoiler-face)
+ str)
+ (erc--reserve-important-text-props from to
+ '( mouse-face erc-spoiler-face
+ cursor-face erc-spoiler-face)
+ str))
+ (when fg (setq fg (erc-get-fg-color-face fg)))
+ (when bg (setq bg (erc-get-bg-color-face bg)))
(font-lock-prepend-text-property
from
to
@@ -531,10 +1037,10 @@ to a region in the current buffer."
'(erc-underline-face)
nil)
(if fg
- (list (erc-get-fg-color-face fg))
+ (list fg)
nil)
(if bg
- (list (erc-get-bg-color-face bg))
+ (list bg)
nil))
str)
str)
@@ -553,6 +1059,7 @@ Else interpretation is turned off."
(if erc-interpret-controls-p "ON" "OFF")))
;; Smiley
+;;;###autoload(autoload 'erc-smiley-mode "erc-goodies" nil t)
(define-erc-module smiley nil
"This mode translates text-smileys such as :-) into pictures.
This requires the function `smiley-region', which is defined in
@@ -569,6 +1076,7 @@ This function should be used with `erc-insert-modify-hook'."
(smiley-region (point-min) (point-max))))
;; Unmorse
+;;;###autoload(autoload 'erc-unmorse-mode "erc-goodies" nil t)
(define-erc-module unmorse nil
"This mode causes morse code in the current channel to be unmorsed."
((add-hook 'erc-insert-modify-hook #'erc-unmorse))
@@ -604,10 +1112,12 @@ servers. If called from a program, PROC specifies the server process."
(list (read-string "Search for: ")
(if current-prefix-arg
nil erc-server-process)))
- (if (fboundp 'multi-occur)
- (multi-occur (erc-buffer-list nil proc) string)
- (error "`multi-occur' is not defined as a function")))
+ (multi-occur (erc-buffer-list nil proc) string))
(provide 'erc-goodies)
;;; erc-goodies.el ends here
+
+;; Local Variables:
+;; generated-autoload-file: "erc-loaddefs.el"
+;; End:
diff --git a/lisp/erc/erc-ibuffer.el b/lisp/erc/erc-ibuffer.el
index 21cd6e10ccc..6e8a196255b 100644
--- a/lisp/erc/erc-ibuffer.el
+++ b/lisp/erc/erc-ibuffer.el
@@ -27,11 +27,15 @@
;; needs work. Usage: Type / C-e C-h when in Ibuffer-mode to see new
;; limiting commands
+;; This library does not contain a module, but you can `require' it
+;; after loading `erc' to make use of its functionality.
+
;;; Code:
(require 'ibuffer)
(require 'ibuf-ext)
(require 'erc)
+(require 'erc-goodies) ; `erc-controls-interpret'
(defgroup erc-ibuffer nil
"The Ibuffer group for ERC."
@@ -117,11 +121,11 @@
(define-ibuffer-column
erc-members (:name "Users")
- (if (and (eq major-mode 'erc-mode)
- (boundp 'erc-channel-users)
- (hash-table-p erc-channel-users)
- (> (hash-table-size erc-channel-users) 0))
- (number-to-string (hash-table-size erc-channel-users))
+ (if-let ((table (or erc-channel-users erc-server-users))
+ ((hash-table-p table))
+ (count (hash-table-count table))
+ ((> count 0)))
+ (number-to-string count)
""))
(define-ibuffer-column erc-away (:name "A")
@@ -176,8 +180,7 @@
(defvar erc-ibuffer-limit-map nil
"Prefix keymap to use for ERC related limiting.")
(define-prefix-command 'erc-ibuffer-limit-map)
-;; FIXME: Where is `ibuffer-limit-by-erc-server' defined?
-(define-key 'erc-ibuffer-limit-map (kbd "s") 'ibuffer-limit-by-erc-server)
+(define-key 'erc-ibuffer-limit-map (kbd "s") #'ibuffer-filter-by-erc-server)
(define-key ibuffer-mode-map (kbd "/ \C-e") 'erc-ibuffer-limit-map)
(provide 'erc-ibuffer)
diff --git a/lisp/erc/erc-imenu.el b/lisp/erc/erc-imenu.el
index 7c1ee7d8a7a..4c9cbfc1580 100644
--- a/lisp/erc/erc-imenu.el
+++ b/lisp/erc/erc-imenu.el
@@ -41,6 +41,10 @@
(require 'erc)
(require 'imenu)
+(defgroup erc-imenu nil
+ "Imenu integration for ERC."
+ :group 'erc)
+
(defun erc-unfill-notice ()
"Return text from point to a computed end as a string unfilled.
Don't rely on this function, read it first!"
@@ -52,7 +56,8 @@ Don't rely on this function, read it first!"
(forward-line 1)
(looking-at " "))
(forward-line 1))
- (end-of-line) (point)))))
+ (end-of-line) (point))))
+ (inhibit-read-only t))
(with-temp-buffer
(insert str)
(goto-char (point-min))
@@ -124,6 +129,27 @@ Don't rely on this function, read it first!"
index-alist))
index-alist))
+(defvar-local erc-imenu--create-index-function nil
+ "Previous local value of `imenu-create-index-function', if any.")
+
+(defun erc-imenu-setup ()
+ "Wire up support for Imenu in an ERC buffer."
+ (when (and (local-variable-p 'imenu-create-index-function)
+ imenu-create-index-function)
+ (setq erc-imenu--create-index-function imenu-create-index-function))
+ (setq imenu-create-index-function #'erc-create-imenu-index))
+
+;;;###autoload(autoload 'erc-imenu-mode "erc-imenu" nil t)
+(define-erc-module imenu nil
+ "Simple Imenu integration for ERC."
+ ((add-hook 'erc-mode-hook #'erc-imenu-setup)
+ (unless erc--updating-modules-p (erc-buffer-do #'erc-imenu-setup)))
+ ((remove-hook 'erc-mode-hook #'erc-imenu-setup)
+ (erc-with-all-buffers-of-server nil nil
+ (when erc-imenu--create-index-function
+ (setq imenu-create-index-function erc-imenu--create-index-function)
+ (kill-local-variable 'erc-imenu--create-index-function)))))
+
(provide 'erc-imenu)
;;; erc-imenu.el ends here
diff --git a/lisp/erc/erc-join.el b/lisp/erc/erc-join.el
index 261c520b0cd..cb57d8a00a1 100644
--- a/lisp/erc/erc-join.el
+++ b/lisp/erc/erc-join.el
@@ -44,11 +44,23 @@
((add-hook 'erc-after-connect #'erc-autojoin-channels)
(add-hook 'erc-nickserv-identified-hook #'erc-autojoin-after-ident)
(add-hook 'erc-server-JOIN-functions #'erc-autojoin-add)
- (add-hook 'erc-server-PART-functions #'erc-autojoin-remove))
+ (add-hook 'erc-server-PART-functions #'erc-autojoin-remove)
+ (add-hook 'erc-server-405-functions #'erc-join--remove-requested-channel)
+ (add-hook 'erc-server-471-functions #'erc-join--remove-requested-channel)
+ (add-hook 'erc-server-473-functions #'erc-join--remove-requested-channel)
+ (add-hook 'erc-server-474-functions #'erc-join--remove-requested-channel)
+ (add-hook 'erc-server-475-functions #'erc-join--remove-requested-channel))
((remove-hook 'erc-after-connect #'erc-autojoin-channels)
(remove-hook 'erc-nickserv-identified-hook #'erc-autojoin-after-ident)
(remove-hook 'erc-server-JOIN-functions #'erc-autojoin-add)
- (remove-hook 'erc-server-PART-functions #'erc-autojoin-remove)))
+ (remove-hook 'erc-server-PART-functions #'erc-autojoin-remove)
+ (remove-hook 'erc-server-405-functions #'erc-join--remove-requested-channel)
+ (remove-hook 'erc-server-471-functions #'erc-join--remove-requested-channel)
+ (remove-hook 'erc-server-473-functions #'erc-join--remove-requested-channel)
+ (remove-hook 'erc-server-474-functions #'erc-join--remove-requested-channel)
+ (remove-hook 'erc-server-475-functions #'erc-join--remove-requested-channel)
+ (erc-buffer-do (lambda ()
+ (kill-local-variable 'erc-join--requested-channels)))))
(defcustom erc-autojoin-channels-alist nil
"Alist of channels to autojoin on IRC networks.
@@ -78,10 +90,11 @@ keeps track of what channels you are on, and will join them
again when you get disconnected. When you restart Emacs, however,
those changes are lost, and the customization you saved the last
time is used again."
- :type '(repeat (cons :tag "Server"
- (regexp :tag "Name")
- (repeat :tag "Channels"
- (string :tag "Name")))))
+ :type '(alist :options (Libera.Chat)
+ :key-type (choice :tag "Server"
+ (symbol :tag "Network")
+ (regexp :tag "Host or domain"))
+ :value-type (repeat :tag "Channels" (string :tag "Name"))))
(defcustom erc-autojoin-timing 'connect
"When ERC should attempt to autojoin a channel.
@@ -137,6 +150,28 @@ network or a network ID). Return nil on failure."
(string-match-p candidate (or erc-server-announced-name
erc-session-server)))))
+(defvar-local erc-join--requested-channels nil
+ "List of channels for which an outgoing JOIN was sent.")
+
+;; Assume users will update their `erc-autojoin-channels-alist' when
+;; encountering errors, like a 475 ERR_BADCHANNELKEY.
+(defun erc-join--remove-requested-channel (_ parsed)
+ "Remove channel from `erc-join--requested-channels'."
+ (when-let ((channel (cadr (erc-response.command-args parsed)))
+ ((member channel erc-join--requested-channels)))
+ (setq erc-join--requested-channels
+ (delete channel erc-join--requested-channels)))
+ nil)
+
+(cl-defmethod erc--server-determine-join-display-context
+ (channel alist &context (erc-autojoin-mode (eql t)))
+ "Add item to `erc-display-context' ALIST if CHANNEL was autojoined."
+ (when (member channel erc-join--requested-channels)
+ (setq erc-join--requested-channels
+ (delete channel erc-join--requested-channels))
+ (push (cons 'erc-autojoin-mode channel) alist))
+ (cl-call-next-method channel alist))
+
(defun erc-autojoin--join ()
;; This is called in the server buffer
(pcase-dolist (`(,name . ,channels) erc-autojoin-channels-alist)
@@ -145,6 +180,7 @@ network or a network ID). Return nil on failure."
(let ((buf (erc-get-buffer chan erc-server-process)))
(unless (and buf (with-current-buffer buf
(erc--current-buffer-joined-p)))
+ (push chan erc-join--requested-channels)
(erc-server-join-channel nil chan)))))))
(defun erc-autojoin-after-ident (_network _nick)
diff --git a/lisp/erc/erc-log.el b/lisp/erc/erc-log.el
index 88833fa59da..d5c56bcc2b3 100644
--- a/lisp/erc/erc-log.el
+++ b/lisp/erc/erc-log.el
@@ -124,6 +124,7 @@ custom function which returns the directory part and set
(defcustom erc-truncate-buffer-on-save nil
"Erase the contents of any ERC (channel, query, server) buffer when it is saved."
:type 'boolean)
+(make-obsolete 'erc-truncate-buffer-on-save 'erc-cmd-CLEAR "30.1")
(defcustom erc-enable-logging t
"If non-nil, ERC will log IRC conversations.
@@ -198,6 +199,7 @@ This should ideally, be a \"catch-all\" coding system, like
The function should take one argument, which is the text to filter."
:type '(choice (function "Function")
+ (function-item erc-stamp-prefix-log-filter)
(const :tag "No filtering" nil)))
@@ -229,8 +231,10 @@ also be a predicate function. To only log when you are not set away, use:
(add-hook 'erc-part-hook #'erc-conditional-save-buffer)
;; append, so that 'erc-initialize-log-marker runs first
(add-hook 'erc-connect-pre-hook #'erc-log-setup-logging 'append)
+ (add-hook 'erc--pre-clear-functions #'erc-save-buffer-in-logs 50)
(dolist (buffer (erc-buffer-list))
- (erc-log-setup-logging buffer)))
+ (erc-log-setup-logging buffer))
+ (erc--modify-local-map t "C-c C-l" #'erc-save-buffer-in-logs))
;; disable
((remove-hook 'erc-insert-post-hook #'erc-save-buffer-in-logs)
(remove-hook 'erc-send-post-hook #'erc-save-buffer-in-logs)
@@ -240,10 +244,10 @@ also be a predicate function. To only log when you are not set away, use:
(remove-hook 'erc-quit-hook #'erc-conditional-save-queries)
(remove-hook 'erc-part-hook #'erc-conditional-save-buffer)
(remove-hook 'erc-connect-pre-hook #'erc-log-setup-logging)
+ (remove-hook 'erc--pre-clear-functions #'erc-save-buffer-in-logs)
(dolist (buffer (erc-buffer-list))
- (erc-log-disable-logging buffer))))
-
-(define-key erc-mode-map "\C-c\C-l" #'erc-save-buffer-in-logs)
+ (erc-log-disable-logging buffer))
+ (erc--modify-local-map nil "C-c C-l" #'erc-save-buffer-in-logs)))
;;; functionality referenced from erc.el
(defun erc-log-setup-logging (buffer)
@@ -272,11 +276,11 @@ The current buffer is given by BUFFER."
(defun erc-log-all-but-server-buffers (buffer)
"Return t if logging should be enabled in BUFFER.
-Returns nil if `erc-server-buffer-p' returns t."
+Return nil if BUFFER is a server buffer."
(save-excursion
(save-window-excursion
(set-buffer buffer)
- (not (erc-server-buffer-p)))))
+ (not (erc--server-buffer-p)))))
(defun erc-save-query-buffers (process)
"Save all buffers of the given PROCESS."
@@ -300,6 +304,8 @@ Returns nil if `erc-server-buffer-p' returns t."
(dolist (buffer (erc-buffer-list))
(erc-save-buffer-in-logs buffer)))
+(defvar erc-log--save-in-progress-p nil)
+
;;;###autoload
(defun erc-logging-enabled (&optional buffer)
"Return non-nil if logging is enabled for BUFFER.
@@ -309,6 +315,7 @@ is writable (it will be created as necessary) and
`erc-enable-logging' returns a non-nil value."
(or buffer (setq buffer (current-buffer)))
(and erc-log-channels-directory
+ (not erc-log--save-in-progress-p)
(or (functionp erc-log-channels-directory)
(erc-directory-writable-p erc-log-channels-directory))
(if (functionp erc-enable-logging)
@@ -398,7 +405,7 @@ automatically.
You can save every individual message by putting this function on
`erc-insert-post-hook'."
(interactive)
- (or buffer (setq buffer (current-buffer)))
+ (unless (bufferp buffer) (setq buffer (current-buffer)))
(when (erc-logging-enabled buffer)
(let ((file (erc-current-logfile buffer))
(coding-system erc-log-file-coding-system))
@@ -422,10 +429,12 @@ You can save every individual message by putting this function on
(write-region start end file t 'nomessage))))
(if (and erc-truncate-buffer-on-save
(called-interactively-p 'interactive))
- (progn
- (let ((inhibit-read-only t)) (erase-buffer))
- (move-marker erc-last-saved-position (point-max))
- (erc-display-prompt))
+ (let ((erc-log--save-in-progress-p t))
+ (save-excursion (goto-char erc-insert-marker)
+ (erc-cmd-CLEAR))
+ (erc-button--display-error-notice-with-keys
+ (erc-server-buffer) "Option `%s' is deprecated."
+ " Use /CLEAR instead." 'erc-truncate-buffer-on-save))
(move-marker erc-last-saved-position
;; If we place erc-last-saved-position at
;; erc-insert-marker, because text gets
@@ -437,6 +446,15 @@ You can save every individual message by putting this function on
(set-buffer-modified-p nil))))))
t)
+;; This is a kludge to avoid littering erc-truncate.el with forward
+;; declarations needed only for a corner-case compatibility check.
+(defun erc-log--call-when-logging-enabled-sans-module (fn)
+ (when (and (erc-logging-enabled)
+ (not (or erc-log-mode (memq 'log erc-modules))))
+ (let ((dirfile (and (stringp erc-log-channels-directory)
+ erc-log-channels-directory)))
+ (funcall fn dirfile))))
+
(provide 'erc-log)
;;; erc-log.el ends here
diff --git a/lisp/erc/erc-match.el b/lisp/erc/erc-match.el
index a99c96beb7a..8497382a733 100644
--- a/lisp/erc/erc-match.el
+++ b/lisp/erc/erc-match.el
@@ -52,8 +52,16 @@ they are hidden or highlighted. This is controlled via the variables
`erc-current-nick-highlight-type'. For all these highlighting types,
you can decide whether the entire message or only the sending nick is
highlighted."
- ((add-hook 'erc-insert-modify-hook #'erc-match-message 'append))
- ((remove-hook 'erc-insert-modify-hook #'erc-match-message)))
+ ((add-hook 'erc-insert-modify-hook #'erc-match-message 50)
+ (add-hook 'erc-mode-hook #'erc-match--setup)
+ (unless erc--updating-modules-p (erc-buffer-do #'erc-match--setup))
+ (add-hook 'erc-insert-post-hook #'erc-match--on-insert-post 50)
+ (erc--modify-local-map t "C-c C-k" #'erc-go-to-log-matches-buffer))
+ ((remove-hook 'erc-insert-modify-hook #'erc-match-message)
+ (remove-hook 'erc-insert-post-hook #'erc-match--on-insert-post)
+ (remove-hook 'erc-mode-hook #'erc-match--setup)
+ (erc-buffer-do #'erc-match--setup)
+ (erc--modify-local-map nil "C-c C-k" #'erc-go-to-log-matches-buffer)))
;; Remaining customizations
@@ -226,10 +234,11 @@ for beeping to work."
(const :tag "Don't beep" nil)))
(defcustom erc-text-matched-hook '(erc-log-matches)
- "Hook run when text matches a given match-type.
-Functions in this hook are passed as arguments:
-\(match-type nick!user@host message) where MATCH-TYPE is a symbol of:
-current-nick, keyword, pal, dangerous-host, fool."
+ "Abnormal hook for visiting text matching a predefined \"type\".
+ERC calls members with the arguments (MATCH-TYPE NUH MESSAGE),
+where MATCH-TYPE is one of the symbols `current-nick', `keyword',
+`pal', `dangerous-host', `fool', and NUH is an `erc-response'
+sender, like bob!~bob@example.org."
:options '(erc-log-matches erc-hide-fools erc-beep-on-match)
:type 'hook)
@@ -482,7 +491,9 @@ Use this defun with `erc-insert-modify-hook'."
(message (buffer-substring message-beg (point-max))))
(when (and vector
(not (and erc-match-exclude-server-buffer
- (erc-server-buffer-p))))
+ ;; FIXME replace with `erc--server-buffer-p'
+ ;; or explain why that's unwise.
+ (erc-server-or-unjoined-channel-buffer-p))))
(mapc
(lambda (match-type)
(goto-char (point-min))
@@ -647,15 +658,23 @@ See `erc-log-match-format'."
(get-buffer (car buffer-cons))))))
(switch-to-buffer buffer-name)))
-(define-key erc-mode-map "\C-c\C-k" #'erc-go-to-log-matches-buffer)
-
(defun erc-hide-fools (match-type _nickuserhost _message)
- "Hide foolish comments.
-This function should be called from `erc-text-matched-hook'."
- (when (eq match-type 'fool)
- (erc-put-text-properties (point-min) (point-max)
- '(invisible intangible)
- (current-buffer))))
+ "Hide comments from designated fools."
+ (when (and erc--msg-props (eq match-type 'fool))
+ (puthash 'erc--invisible 'erc-match-fool erc--msg-props)))
+
+;; FIXME remove, make public, or only add locally.
+;;
+;; ERC modules typically don't add internal functions to public hooks
+;; globally. However, ERC 5.6 will likely include a general
+;; (internal) facility for adding invisible props, which will obviate
+;; the need for this function. IOW, leaving this internal for now is
+;; an attempt to avoid the hassle of the deprecation process.
+(defun erc-match--on-insert-post ()
+ "Hide messages marked with the `erc--invisible' prop."
+ (when (erc--check-msg-prop 'erc--invisible 'erc-match-fool)
+ (remhash 'erc--invisible erc--msg-props)
+ (erc--hide-message 'match-fools)))
(defun erc-beep-on-match (match-type _nickuserhost _message)
"Beep when text matches.
@@ -663,6 +682,21 @@ This function is meant to be called from `erc-text-matched-hook'."
(when (member match-type erc-beep-match-types)
(beep)))
+(defun erc-match--setup ()
+ "Add an `erc-match' property to the local spec."
+ ;; Hopefully, this will be extended to do the same for other
+ ;; invisible properties managed by this module.
+ (if erc-match-mode
+ (erc-match-toggle-hidden-fools +1)
+ (erc-match-toggle-hidden-fools -1)))
+
+(defun erc-match-toggle-hidden-fools (arg)
+ "Toggle fool visibility.
+Expect the function `erc-hide-fools' or similar to be present in
+`erc-text-matched-hook'."
+ (interactive "P")
+ (erc--toggle-hidden 'match-fools arg))
+
(provide 'erc-match)
;;; erc-match.el ends here
diff --git a/lisp/erc/erc-netsplit.el b/lisp/erc/erc-netsplit.el
index 7c699d3df49..15798793df8 100644
--- a/lisp/erc/erc-netsplit.el
+++ b/lisp/erc/erc-netsplit.el
@@ -41,7 +41,7 @@ netsplits, so that it can filter the JOIN messages on a netjoin too."
;;;###autoload(autoload 'erc-netsplit-mode "erc-netsplit")
(define-erc-module netsplit nil
"This mode hides quit/join messages if a netsplit occurs."
- ((erc-netsplit-install-message-catalogs)
+ ( ; FIXME delete newline on next edit
(add-hook 'erc-server-JOIN-functions #'erc-netsplit-JOIN)
(add-hook 'erc-server-MODE-functions #'erc-netsplit-MODE)
(add-hook 'erc-server-QUIT-functions #'erc-netsplit-QUIT)
@@ -85,13 +85,22 @@ where FIRST-JOIN is t or nil, depending on whether or not the first
join from that split has been detected or not.")
(defun erc-netsplit-install-message-catalogs ()
+ (declare (obsolete "defined at top level in erc-netsplit.el" "30.1"))
+ (with-suppressed-warnings ((obsolete erc-define-catalog)) ; indentation
(erc-define-catalog
'english
'((netsplit . "netsplit: %s")
(netjoin . "netjoin: %s, %N were split")
(netjoin-done . "netjoin: All lost souls are back!")
(netsplit-none . "No netsplits in progress")
- (netsplit-wholeft . "split: %s missing: %n %t"))))
+ (netsplit-wholeft . "split: %s missing: %n %t"))))) ; indentation
+
+(erc-define-message-format-catalog english
+ (netsplit . "netsplit: %s")
+ (netjoin . "netjoin: %s, %N were split")
+ (netjoin-done . "netjoin: All lost souls are back!")
+ (netsplit-none . "No netsplits in progress")
+ (netsplit-wholeft . "split: %s missing: %n %t"))
(defun erc-netsplit-JOIN (proc parsed)
"Show/don't show rejoins."
@@ -117,7 +126,9 @@ join from that split has been detected or not.")
parsed 'notice (process-buffer proc)
'netjoin-done ?s (car elt))
(setq erc-netsplit-list (delq elt erc-netsplit-list)))
- (delete nick elt))
+ ;; Avoid `ignored-return-value' warning for `delete'.
+ (let ((tail (nthcdr 2 elt))) ; (t n1 ... nN)
+ (setcdr tail (delete nick (cdr tail)))))
(setq no-next-hook t))))
no-next-hook))
diff --git a/lisp/erc/erc-networks.el b/lisp/erc/erc-networks.el
index e2893a9c9e0..1b26afa1164 100644
--- a/lisp/erc/erc-networks.el
+++ b/lisp/erc/erc-networks.el
@@ -29,8 +29,6 @@
;;
;; This is the "networks" module.
;;
-;; M-x erc-server-select provides an alternative way to connect to servers by
-;; choosing networks.
;; You can use (eq (erc-network) 'Network) if you'd like to set variables or do
;; certain actions according to which network you're connected to.
;; If a network you use is not listed in `erc-networks-alist', you can put
@@ -44,29 +42,25 @@
(defvar erc--target)
(defvar erc-insert-marker)
-(defvar erc-kill-buffer-hook)
-(defvar erc-kill-server-hook)
(defvar erc-modules)
(defvar erc-rename-buffers)
(defvar erc-reuse-buffers)
(defvar erc-server-announced-name)
(defvar erc-server-connected)
-(defvar erc-server-parameters)
(defvar erc-server-process)
-(defvar erc-session-server)
-(declare-function erc--default-target "erc" nil)
(declare-function erc--get-isupport-entry "erc-backend" (key &optional single))
(declare-function erc-buffer-filter "erc" (predicate &optional proc))
(declare-function erc-current-nick "erc" nil)
(declare-function erc-display-error-notice "erc" (parsed string))
(declare-function erc-display-message "erc" (parsed type buffer msg &rest args))
-(declare-function erc-error "erc" (&rest args))
(declare-function erc-get-buffer "erc" (target &optional proc))
-(declare-function erc-server-buffer "erc" nil)
(declare-function erc-server-process-alive "erc-backend" (&optional buffer))
(declare-function erc-set-active-buffer "erc" (buffer))
+(declare-function erc-button--display-error-notice-with-keys
+ (maybe-buffer &rest strings))
+
;; Variables
(defgroup erc-networks nil
@@ -255,6 +249,7 @@
("IRChat: Random server" IRChat "irc.irchat.net" ((6660 6669)))
("IrcLordz: Random server" IrcLordz "irc.irclordz.com" 6667)
("IrcMalta: Random server" IrcMalta "irc.ircmalta.org" ((6660 6667)))
+ ;; This one is dead but used in testing. Please retain.
("IRCnet: EU, FR, Random" IRCnet "irc.fr.ircnet.net" 6667)
("IRCnet: EU, IT, Random" IRCnet "irc.ircd.it" ((6665 6669)))
("IRCnet: AS, IL, Haifa" IRCnet "ircnet.netvision.net.il" ((6661 6668)))
@@ -315,13 +310,15 @@
("LagNet: Random server" LagNet "irc.lagnet.org.za" 6667)
("LagNet: AF, ZA, Cape Town" LagNet "reaper.lagnet.org.za" 6667)
("LagNet: AF, ZA, Johannesburg" LagNet "mystery.lagnet.org.za" 6667)
- ("Libera.Chat: Random server" Libera.Chat "irc.libera.chat" 6667)
- ("Libera.Chat: Random Europe server" Libera.Chat "irc.eu.libera.chat" 6667)
- ("Libera.Chat: Random US & Canada server" Libera.Chat "irc.us.libera.chat" 6667)
- ("Libera.Chat: Random Australia & New Zealand server" Libera.Chat "irc.au.libera.chat" 6667)
- ("Libera.Chat: Random East Asia server" Libera.Chat "irc.ea.libera.chat" 6667)
- ("Libera.Chat: IPv4 only server" Libera.Chat "irc.ipv4.libera.chat" 6667)
- ("Libera.Chat: IPv6 only server" Libera.Chat "irc.ipv6.libera.chat" 6667)
+ ("Libera.Chat: Random server" Libera.Chat "irc.libera.chat"
+ ((6665 6667) (8000 8002)) (6697 7000 7070))
+ ;; If not deprecating this option, use ^ for the rest of these servers.
+ ("Libera.Chat: Random Europe server" Libera.Chat "irc.eu.libera.chat" 6667 6697)
+ ("Libera.Chat: Random US & Canada server" Libera.Chat "irc.us.libera.chat" 6667 6697)
+ ("Libera.Chat: Random Australia & New Zealand server" Libera.Chat "irc.au.libera.chat" 6667 6697)
+ ("Libera.Chat: Random East Asia server" Libera.Chat "irc.ea.libera.chat" 6667 6697)
+ ("Libera.Chat: IPv4 only server" Libera.Chat "irc.ipv4.libera.chat" 6667 6697)
+ ("Libera.Chat: IPv6 only server" Libera.Chat "irc.ipv6.libera.chat" 6667 6697)
("Librenet: Random server" Librenet "irc.librenet.net" 6667)
("LinkNet: Random server" LinkNet "irc.link-net.org" ((6667 6669)))
("LinuxChix: Random server" LinuxChix "irc.linuxchix.org" 6667)
@@ -346,7 +343,7 @@
("Novernet: Random server" Novernet "irc.novernet.com" ((6665 6669) 7000 ))
("Nullrouted: Random server" Nullrouted "irc.nullrouted.org" ((6666 6669) 7000 ))
("NullusNet: Random server" NullusNet "irc.nullus.net" 6667)
- ("OFTC: Random server" OFTC "irc.oftc.net" ((6667 6670) 7000))
+ ("OFTC: Random server" OFTC "irc.oftc.net" ((6667 6670) 7000) (6697 9999))
("OpChat: Random server" OpChat "irc.opchat.org" ((6667 6669)))
("Othernet: Random server" Othernet "irc.othernet.org" 6667)
("Othernet: US, FL, Miami" Othernet "miami.fl.us.othernet.org" 6667)
@@ -469,12 +466,13 @@
("ZUHnet: Random server" ZUHnet "irc.zuh.net" 6667)
("Zurna: Random server" Zurna "irc.zurna.net" 6667))
"Alist of irc servers.
-Each server is a list (NAME NET HOST PORTS) where
+Each server is a list (NAME NET HOST PORTS TLS-PORTS) where
NAME is a name for that server,
NET is a symbol indicating to which network from `erc-networks-alist'
this server corresponds,
-HOST is the servers hostname and
-PORTS is either a number, a list of numbers, or a list of port ranges."
+HOST is the server's hostname, and (TLS-)PORTS is either a
+number, a list of numbers, or a list of port ranges."
+ :package-version '(ERC . "5.6")
:type '(alist :key-type (string :tag "Name")
:value-type
(group symbol (string :tag "Hostname")
@@ -483,7 +481,15 @@ PORTS is either a number, a list of numbers, or a list of port ranges."
(repeat :tag "List of ports or ranges"
(choice (integer :tag "Port number")
(list :tag "Port range"
- integer integer)))))))
+ integer integer))))
+ (choice :tag "TLS ports"
+ (integer :tag "TLS port number")
+ (repeat :tag "List of TLS ports or ranges"
+ (choice (integer :tag "TLS port number")
+ (list :tag "TLS port range"
+ integer integer)))))))
+(make-obsolete-variable 'erc-server-alist
+ "specify `:server' with `erc-tls'." "30.1")
(defcustom erc-networks-alist
'((4-irc "4-irc.com")
@@ -743,9 +749,8 @@ PORTS is either a number, a list of numbers, or a list of port ranges."
Each network is a list (NET MATCHER) where
NET is a symbol naming that IRC network and
MATCHER is used to find a corresponding network to a server while
- connected to it. If it is regexp, it's used to match against
- `erc-server-announced-name'. It can also be a function (predicate).
- Then it is executed with the server buffer as current buffer."
+connected to it. If it is a regexp, it's used to match against
+`erc-server-announced-name'."
:type '(repeat
(list :tag "Network"
(symbol :tag "Network name")
@@ -979,12 +984,11 @@ object."
(erc-networks--id-qualifying-len nid))
(erc-networks--rename-server-buffer (or proc erc-server-process) parsed)
(erc-networks--shrink-ids-and-buffer-names-any)
- (erc-with-all-buffers-of-server
- erc-server-process #'erc--default-target
- (when-let* ((new-name (erc-networks--reconcile-buffer-names erc--target
- nid))
- ((not (equal (buffer-name) new-name))))
- (rename-buffer new-name 'unique))))
+ (erc-with-all-buffers-of-server erc-server-process #'erc-target
+ (when-let
+ ((new-name (erc-networks--reconcile-buffer-names erc--target nid))
+ ((not (equal (buffer-name) new-name))))
+ (rename-buffer new-name 'unique))))
(cl-defgeneric erc-networks--id-ensure-comparable (self other)
"Take measures to ensure two net identities are in comparable states.")
@@ -1119,10 +1123,27 @@ TARGET to be an `erc--target' object."
(lambda ()
(when (and erc--target (eq (erc--target-symbol erc--target)
(erc--target-symbol target)))
- (let ((oursp (if (erc--target-channel-local-p target)
- (equal announced erc-server-announced-name)
- (erc-networks--id-equal-p identity erc-networks--id))))
- (funcall (if oursp on-dupe on-collision))))))))
+ ;; When a server sends administrative queries immediately
+ ;; after connection registration and before the session has a
+ ;; net-id, the buffer remains orphaned until reassociated
+ ;; here retroactively.
+ (unless erc-networks--id
+ (let ((id (erc-with-server-buffer erc-networks--id))
+ (server-buffer (process-buffer erc-server-process)))
+ (apply #'erc-button--display-error-notice-with-keys
+ server-buffer
+ (concat "Missing network session (ID) for %S. "
+ (if id "Using `%S' from %S." "Ignoring."))
+ (current-buffer)
+ (and id (list (erc-networks--id-symbol
+ (setq erc-networks--id id))
+ server-buffer)))))
+ (when erc-networks--id
+ (let ((oursp (if (erc--target-channel-local-p target)
+ (equal announced erc-server-announced-name)
+ (erc-networks--id-equal-p identity
+ erc-networks--id))))
+ (funcall (if oursp on-dupe on-collision)))))))))
(defconst erc-networks--qualified-sep "@"
"Separator used for naming a target buffer.")
@@ -1219,6 +1240,8 @@ Use the server parameter NETWORK if provided, otherwise parse the
server name and search for a match in `erc-networks-alist'."
;; The server made it easy for us and told us the name of the NETWORK
(declare (obsolete "maybe see `erc-networks--determine'" "29.1"))
+ (defvar erc-server-parameters)
+ (defvar erc-session-server)
(let ((network-name (cdr (assoc "NETWORK" erc-server-parameters))))
(if network-name
(intern network-name)
@@ -1282,18 +1305,16 @@ shutting down the connection."
erc-network)))
(erc-display-message parsed 'notice nil m)
nil)
- ((and
- (guard (eq erc-network erc-networks--name-missing-sentinel))
- ;; This can happen theoretically, e.g., when adjusting settings
- ;; on a proxy service that partially impersonates IRC but isn't
- ;; currently conveying anything through to a real network. The
- ;; service may send a 422 but no NETWORK param (or *any* 005s).
- (let m (concat "Failed to determine network. Please set entry for \""
- erc-server-announced-name "\" in `erc-networks-alist'"
- " or consider calling `erc-tls' with the keyword `:id'."
- " See Info:\"(erc) Network Identifier\" for more.")))
- (require 'info)
- (erc-display-error-notice parsed m)
+ ((guard (eq erc-network erc-networks--name-missing-sentinel))
+ ;; This can happen theoretically, e.g., when adjusting settings
+ ;; on a proxy service that partially impersonates IRC but isn't
+ ;; currently conveying anything through to a real network. The
+ ;; service may send a 422 but no NETWORK param (or *any* 005s).
+ (erc-button--display-error-notice-with-keys
+ "Failed to determine network. Please set entry for \""
+ erc-server-announced-name "\" in `erc-networks-alist' or consider"
+ " calling `erc-tls' with the keyword `:id'."
+ " See Info:\"(erc) Network Identifier\" for more.")
(if erc-networks--allow-unknown-network
(progn
(erc-display-error-notice
@@ -1311,12 +1332,11 @@ shutting down the connection."
Copy source (prefix) from MOTD-ish message as a last resort."
;; The 004 handler never ran; see 2004-03-10 Diane Murray in change log
(unless erc-server-announced-name
- (setq erc-server-announced-name (erc-response.sender parsed))
- (erc-display-error-notice
- parsed (concat "Failed to determine server name. Using \""
- erc-server-announced-name "\" instead."
- " If this was unexpected, consider reporting it via "
- (substitute-command-keys "\\[erc-bug]") ".")))
+ (require 'erc-button)
+ (erc-button--display-error-notice-with-keys
+ "Failed to determine server name. Using \""
+ (setq erc-server-announced-name (erc-response.sender parsed)) "\" instead"
+ ". If this was unexpected, consider reporting it via \\[erc-bug]."))
nil)
(defun erc-unset-network-name (_nick _ip _reason)
@@ -1374,6 +1394,8 @@ already been copied over to the current, replacement buffer.")
(defun erc-networks--copy-over-server-buffer-contents (existing name)
"Kill off existing server buffer after copying its contents.
Must be called from the replacement buffer."
+ (defvar erc-kill-buffer-hook)
+ (defvar erc-kill-server-hook)
;; ERC expects `erc-open' to be idempotent when setting up local
;; vars and other context properties for a new identity. Thus, it's
;; unlikely we'll have to copy anything else over besides text. And
@@ -1458,6 +1480,7 @@ to be a false alarm. If `erc-reuse-buffers' is nil, let
;; When this ends up being the current buffer, either we have
;; a "given" ID or the buffer was reused on reconnecting.
(existing (get-buffer name)))
+ (process-put new-proc 'erc-networks--id erc-networks--id)
(cond ((or (not existing)
(erc-networks--id-given erc-networks--id)
(eq existing (current-buffer)))
@@ -1494,12 +1517,9 @@ to be a false alarm. If `erc-reuse-buffers' is nil, let
(memq (erc--target-symbol erc--target)
erc-networks--bouncer-targets)))
proc)
- (let ((m (concat "Unexpected state detected. If you've just issued an"
- " /MOTD, please know that the command is bugged in ERC"
- " 5.5 (Emacs 29) but will be fixed in the next release."
- " Otherwise, please report this occurrence via"
- (substitute-command-keys " \\[erc-bug]."))))
- (erc-display-error-notice parsed m))))
+ (require 'erc-button)
+ (erc-button--display-error-notice-with-keys
+ "Unexpected state detected. Please report via \\[erc-bug].")))
;; For now, retain compatibility with erc-server-NNN-functions.
(or (erc-networks--ensure-announced proc parsed)
@@ -1517,7 +1537,6 @@ to be a false alarm. If `erc-reuse-buffers' is nil, let
"Emit warning when the `networks' module hasn't been loaded.
Ideally, do so upon opening the network process."
(unless (or erc--target erc-networks-mode)
- (require 'info nil t)
(let ((m (concat "Required module `networks' not loaded. If this "
" was unexpected, please add it to `erc-modules'.")))
;; Assume the server buffer has been marked as active.
@@ -1538,7 +1557,7 @@ As an example:
(erc-ports-list \\='((1 5))) => (1 2 3 4 5)
(erc-ports-list \\='(1 (3 5))) => (1 3 4 5)"
(let (result)
- (dolist (p ports)
+ (dolist (p (ensure-list ports))
(cond ((numberp p)
(push p result))
((listp p)
@@ -1547,31 +1566,32 @@ As an example:
result)))))
(nreverse result)))
-;;;###autoload
-(defun erc-server-select ()
- "Interactively select a server to connect to using `erc-server-alist'."
- (interactive)
+(defun erc-networks--server-select ()
+ "Prompt for a server in `erc-server-alist' and return its irc(s):// URL.
+Choose port at random if multiple candidates exist, but always
+prefer TLS without asking. When a port can't be determined,
+return the host alone sans URL formatting (for compatibility)."
(let* ((completion-ignore-case t)
(net (intern
(completing-read "Network: "
(delete-dups
(mapcar (lambda (x)
- (list (symbol-name (nth 1 x))))
+ (list (nth 1 x)))
erc-server-alist)))))
- (srv (assoc
- (completing-read "Server: "
- (delq nil
- (mapcar (lambda (x)
- (when (equal (nth 1 x) net)
- x))
- erc-server-alist)))
- erc-server-alist))
+ (s-choose (lambda (entry)
+ (and (equal (nth 1 entry) net)
+ (if-let ((b (string-search ": " (car entry))))
+ (cons (format "%s (%s)" (nth 2 entry)
+ (substring (car entry) (+ b 2)))
+ (cdr entry))
+ entry))))
+ (s-entries (delq nil (mapcar s-choose erc-server-alist)))
+ (srv (assoc (completing-read "Server: " s-entries) s-entries))
(host (nth 2 srv))
- (ports (if (listp (nth 3 srv))
- (erc-ports-list (nth 3 srv))
- (list (nth 3 srv))))
- (port (and ports (seq-random-elt ports))))
- (erc :server host :port port)))
+ (pspec (nthcdr 3 srv))
+ (ports (erc-ports-list (or (cadr pspec) (car pspec))))
+ (scheme (if (cdr pspec) "ircs" "irc")))
+ (if ports (format "%s://%s:%d" scheme host (seq-random-elt ports)) host)))
;;; The following experimental
;; It does not work yet, help me with it if you
@@ -1581,14 +1601,29 @@ As an example:
'((pals Libera.Chat ("kensanata" "shapr" "anti\\(fuchs\\|gone\\)"))
(format-nick-function (Libera.Chat "#emacs") erc-format-@nick))
"Experimental: Alist of configuration options.
+
+WARNING: this variable is a vestige from a long-abandoned
+experiment. ERC may redefine it using the same name for any
+purpose at any time.
+
The format is (VARNAME SCOPE VALUE) where
VARNAME is a symbol identifying the configuration option,
SCOPE is either a symbol which identifies an entry from
`erc-networks-alist' or a list (NET TARGET) where NET is a network symbol and
TARGET is a string identifying the channel/query target.
VALUE is the options value.")
+(make-obsolete-variable 'erc-settings
+ "temporarily deprecated for later repurposing" "30.1")
(defun erc-get (var &optional net target)
+ "Retrieve configuration values from `erc-settings'.
+
+WARNING: this function is a non-functioning remnant from a
+long-abandoned experiment. ERC may redefine it using the same
+name for any purpose at any time.
+
+\(fn &rest UNKNOWN)"
+ (declare (obsolete "temporarily deprecated for later repurposing" "30.1"))
(let ((items erc-settings)
elt val)
(while items
@@ -1608,7 +1643,7 @@ VALUE is the options value.")
items nil)))))
val))
-(erc-get 'pals 'Libera.Chat)
+;; (erc-get 'pals 'Libera.Chat)
(provide 'erc-networks)
diff --git a/lisp/erc/erc-nicks.el b/lisp/erc/erc-nicks.el
new file mode 100644
index 00000000000..64f9ec42783
--- /dev/null
+++ b/lisp/erc/erc-nicks.el
@@ -0,0 +1,774 @@
+;;; erc-nicks.el -- Nick colors for ERC -*- lexical-binding: t; -*-
+
+;; Copyright (C) 2023-2024 Free Software Foundation, Inc.
+
+;; Author: David Leatherman <leathekd@gmail.com>
+;; Andy Stewart <lazycat.manatee@gmail.com>
+
+;; This file is part of GNU Emacs.
+
+;; GNU Emacs is free software: you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published
+;; by the Free Software Foundation, either version 3 of the License,
+;; or (at your option) any later version.
+
+;; GNU Emacs is distributed in the hope that it will be useful, but
+;; WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+;; General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>.
+
+;;; Commentary:
+
+;; This file provides the `nicks' module for automatic nickname
+;; highlighting. Add `nicks' to `erc-modules' to get started.
+;;
+;; Use the command `erc-nicks-refresh' to review changes after
+;; adjusting an option, like `erc-nicks-contrast-range'. To change
+;; the color of a nickname in a target buffer, click on it and choose
+;; "Edit face" from the completion interface, and then perform your
+;; adjustments in the resulting Customize menu. Non-Customize users
+;; on Emacs 28+ can persist changes permanently by clicking on the
+;; face's "location" hyperlink and copying the generated code snippet
+;; (`defface' or `use-package') to their init.el. Customize users
+;; need only click "Apply and Save", as usual.
+
+;;; History:
+
+;; This module has enjoyed a number of contributors across several
+;; variants over the years, including:
+;;
+;; Thibault Polge <thibault@thb.lt>
+;; Jay Kamat <jaygkamat@gmail.com>
+;; Alex Kost <alezost@gmail.com>
+;; Antoine Levitt <antoine dot levitt at gmail>
+;; Adam Porter <adam@alphapapa.net>
+;;
+;; To those not mentioned, your efforts are no less appreciated.
+
+;; 2023/05 - erc-nicks
+;; Rewrite using internal API, and rebrand for ERC 5.6
+;; 2020/03 - erc-hl-nicks 1.3.4
+;; Final release, see [1] for intervening history
+;; 2014/05 - erc-highlight-nicknames.el
+;; Final release, see [2] for intervening history
+;; 2011/08 - erc-hl-nicks 1.0
+;; Initial release forked from erc-highlight-nicknames.el
+;; 2008/12 - erc-highlight-nicknames.el
+;; First release from Andy Stewart
+;; 2007/09 - erc-highlight-nicknames.el
+;; Initial release by by André Riemann
+
+;; [1] <https://www.github.com/leathekd/erc-hl-nicks>
+;; [2] <https://www.emacswiki.org/emacs/ErcHighlightNicknames>
+
+;;; Code:
+
+(require 'erc-button)
+(require 'color)
+
+(defgroup erc-nicks nil
+ "Colorize nicknames in ERC target buffers."
+ :package-version '(ERC . "5.6")
+ :group 'erc)
+
+(defcustom erc-nicks-ignore-chars ",`'_-"
+ "Trailing characters in a nick to ignore while highlighting.
+Value should be a string containing characters typically appended
+by IRC clients to secure a nickname after a rejection (see option
+`erc-nick-uniquifier'). A value of nil means don't trim
+anything."
+ :type '(choice (string :tag "Chars to trim")
+ (const :tag "Don't trim" nil)))
+
+(defcustom erc-nicks-skip-nicks nil
+ "Nicks to avoid highlighting.
+ERC only considers this option during module activation, so users
+should adjust it before connecting."
+ :type '(repeat string))
+
+(defcustom erc-nicks-skip-faces '( erc-notice-face erc-current-nick-face
+ erc-my-nick-face erc-pal-face erc-fool-face)
+ "Faces to avoid highlighting atop."
+ :type (erc--with-dependent-type-match (repeat face) erc-match))
+
+(defcustom erc-nicks-backing-face erc-button-nickname-face
+ "Face to mix with generated one for emphasizing non-speakers."
+ :type '(choice face (const nil)))
+
+(defcustom erc-nicks-bg-color
+ (frame-parameter (selected-frame) 'background-color)
+ "Background color for calculating contrast.
+Set this explicitly when the background color isn't discoverable,
+which may be the case in terminal Emacs. Even when automatically
+initialized, this value may need adjustment mid-session, such as
+after loading a new theme. Remember to run \\[erc-nicks-refresh]
+after doing so."
+ :type 'string)
+
+(defcustom erc-nicks-color-adjustments
+ '(erc-nicks-add-contrast erc-nicks-cap-contrast erc-nicks-ensaturate)
+ "Treatments applied to improve aesthetics or visibility.
+For example, the function `erc-nicks-invert' inverts a nick when
+it's too close to the background, and `erc-nicks-add-contrast'
+attempts to find a decent contrast ratio by brightening or
+darkening. When `erc-nicks-colors' is set to the symbol
+`defined' or a user-provided list of colors, ERC uses this option
+as a guide for culling any colors that don't fall within
+`erc-nicks-contrast-range' or `erc-nicks-saturation-range', as
+appropriate. For example, if `erc-nicks-cap-contrast' is present
+in this option's value, and a color's contrast exceeds the CDR of
+`erc-nicks-contrast-range', ERC will purge that color from its
+rolls when initializing this module. Specify a value of nil to
+inhibit this process."
+ :type '(repeat
+ (choice (function-item :tag "Invert" erc-nicks-invert)
+ (function-item :tag "Add contrast" erc-nicks-add-contrast)
+ (function-item :tag "Cap contrast" erc-nicks-cap-contrast)
+ (function-item :tag "Bound saturation" erc-nicks-ensaturate)
+ function)))
+
+(defcustom erc-nicks-contrast-range '(4.3 . 12.5)
+ "Desired range of contrast as a cons of (MIN . MAX).
+When `erc-nicks-add-contrast' and/or `erc-nicks-invert' appear in
+`erc-nicks-color-adjustments', MIN specifies the minimum amount
+of contrast allowed between a buffer's background and its
+foreground colors. Depending on the background, nicks may appear
+tinted in pastels or shaded with muted grays. MAX works
+similarly for reducing contrast, but only when
+`erc-nicks-cap-contrast' is active. Users with lighter
+backgrounds may want to lower MAX significantly. Either value
+can range from 1.0 to 21.0(:1) but may produce unsatisfactory
+results toward either extreme."
+ :type '(cons float float))
+
+(defcustom erc-nicks-saturation-range '(0.2 . 0.8)
+ "Desired range for constraining saturation.
+Expressed as a cons of decimal proportions. Only matters when
+`erc-nicks-ensaturate' appears in `erc-nicks-color-adjustments'."
+ :type '(cons float float))
+
+(defcustom erc-nicks-colors 'all
+ "Pool of colors.
+List of colors as strings (hex or named) or, alternatively, a
+single symbol representing a set of colors, like that produced by
+the function `defined-colors', which ERC associates with the
+symbol `defined'. Similarly, `all' tells ERC to use any 24-bit
+color. To change the value mid-session, try
+\\[erc-nicks-refresh]."
+ :type `(choice (const :tag "All 24-bit colors" all)
+ (const :tag "Defined terminal colors" defined)
+ (const :tag "Font Lock faces" font-lock)
+ (const :tag "ANSI color faces" ansi-color)
+ (repeat :tag "User-provided list" string)))
+
+(defcustom erc-nicks-key-suffix-format "@%n"
+ "Template for latter portion of keys to generate colors from.
+ERC passes this to `format-spec' with the following specifiers:
+%n for the current network and %m for your nickname (not the one
+being colorized). If you don't like the generated palette, try
+adding extra characters or padding, for example, with something
+like \"@%-012n\"."
+ :type 'string)
+
+(defcustom erc-nicks-track-faces 'prioritize
+ "Show nick faces in the `track' module's portion of the mode line.
+A value of nil means don't show nick faces at all. A value of
+`defer' means have `track' consider nick faces only after those
+ranked faces in `erc-track-faces-normal-list'. This has the
+effect of \"alternating\" between a ranked \"normal\" and a nick.
+The value `prioritize' means have `track' consider nick faces to
+be \"normal\" unless the current speaker is the same as the
+previous one, in which case pretend the value is `defer'. Like
+most options in this module, updating the value mid-session is
+not officially supported, although cycling \\[erc-nicks-mode] may
+be worth a shot."
+ :type '(choice (const nil) (const defer) (const prioritize)))
+
+(defvar erc-nicks--max-skip-search 3 ; make this an option?
+ "Max number of faces to visit when testing `erc-nicks-skip-faces'.")
+
+(defvar erc-nicks--colors-rejects nil)
+(defvar erc-nicks--custom-keywords '(:group erc-nicks :group erc-faces))
+(defvar erc-nicks--grad-steps 9)
+
+(defvar-local erc-nicks--face-table nil
+ "Hash table mapping nicks to unique, named faces.
+Keys are nonempty strings but need not be valid nicks.")
+
+(defvar-local erc-nicks--downcased-skip-nicks nil
+ "Case-mapped copy of `erc-nicks-skip-nicks'.")
+
+(defvar-local erc-nicks--bg-luminance nil)
+(defvar-local erc-nicks--bg-mode-value nil)
+(defvar-local erc-nicks--colors-len nil)
+(defvar-local erc-nicks--colors-pool nil)
+(defvar-local erc-nicks--fg-rgb nil)
+
+(defvar help-xref-stack)
+(defvar help-xref-stack-item)
+(defvar erc-track--normal-faces)
+
+;; https://stackoverflow.com/questions/596216#answer-56678483
+(defun erc-nicks--get-luminance (color)
+ "Return relative luminance of COLOR.
+COLOR can be a list of normalized values or a name. This is the
+same as the Y component returned by `color-srgb-to-xyz'."
+ (let ((out 0)
+ (coefficients '(0.2126 0.7152 0.0722))
+ (chnls (if (stringp color) (color-name-to-rgb color) color)))
+ (dolist (ch chnls out)
+ (cl-incf out (* (pop coefficients)
+ (if (<= ch 0.04045)
+ (/ ch 12.92)
+ (expt (/ (+ ch 0.055) 1.055) 2.4)))))))
+
+(defun erc-nicks--get-contrast (fg &optional bg)
+ "Return a float between 1 and 21 for colors FG and BG.
+If FG or BG are floats, interpret them as luminance values."
+ (let* ((lum-fg (if (numberp fg) fg (erc-nicks--get-luminance fg)))
+ (lum-bg (if bg
+ (if (numberp bg) bg (erc-nicks--get-luminance bg))
+ (or erc-nicks--bg-luminance
+ (setq erc-nicks--bg-luminance
+ (erc-nicks--get-luminance erc-nicks-bg-color))))))
+ (when (< lum-fg lum-bg) (cl-rotatef lum-fg lum-bg))
+ (/ (+ 0.05 lum-fg) (+ 0.05 lum-bg))))
+
+(defmacro erc-nicks--bg-mode ()
+ `(or erc-nicks--bg-mode-value
+ (setq erc-nicks--bg-mode-value
+ ,(cond ((fboundp 'frame--current-background-mode)
+ '(frame--current-background-mode (selected-frame)))
+ ((fboundp 'frame--current-backround-mode)
+ '(frame--current-backround-mode (selected-frame)))
+ (t
+ '(frame-parameter (selected-frame) 'background-mode))))))
+
+;; https://www.w3.org/TR/UNDERSTANDING-WCAG20/visual-audio-contrast-contrast.html
+(defun erc-nicks--adjust-contrast (color target &optional decrease)
+ (cl-assert erc-nicks--fg-rgb)
+ (let* ((lum-bg (or erc-nicks--bg-luminance
+ (setq erc-nicks--bg-luminance
+ (erc-nicks--get-luminance erc-nicks-bg-color))))
+ (stop (if decrease
+ (color-name-to-rgb erc-nicks-bg-color)
+ erc-nicks--fg-rgb))
+ ;; From `color-gradient' in color.el
+ (r (nth 0 color))
+ (g (nth 1 color))
+ (b (nth 2 color))
+ (interval (float (1+ (expt 2 erc-nicks--grad-steps))))
+ (r-step (/ (- (nth 0 stop) r) interval))
+ (g-step (/ (- (nth 1 stop) g) interval))
+ (b-step (/ (- (nth 2 stop) b) interval))
+ (maxtries erc-nicks--grad-steps)
+ started)
+ ;; FIXME stop when sufficiently close instead of exhausting.
+ (while (let* ((lum-fg (erc-nicks--get-luminance (list r g b)))
+ (darker (if (< lum-bg lum-fg) lum-bg lum-fg))
+ (lighter (if (= darker lum-bg) lum-fg lum-bg))
+ (cur (/ (+ 0.05 lighter) (+ 0.05 darker)))
+ (scale (expt 2 maxtries)))
+ (cond ((if decrease (> cur target) (< cur target))
+ (setq r (+ r (* r-step scale))
+ g (+ g (* g-step scale))
+ b (+ b (* b-step scale))))
+ (started
+ (setq r (- r (* r-step scale))
+ g (- g (* g-step scale))
+ b (- b (* b-step scale))))
+ (t (setq maxtries 1)))
+ (unless started
+ (setq started t))
+ (setq r (min 1.0 (max 0 r))
+ g (min 1.0 (max 0 g))
+ b (min 1.0 (max 0 b)))
+ (not (zerop (cl-decf maxtries)))))
+ (list r g b)))
+
+(defun erc-nicks-add-contrast (color)
+ "Increase COLOR's contrast by blending it with the foreground.
+Unless sufficient contrast exists between COLOR and the
+background, raise it to meet the lower bound of
+`erc-nicks-contrast-range'."
+ (erc-nicks--adjust-contrast color (car erc-nicks-contrast-range)))
+
+(defun erc-nicks-cap-contrast (color)
+ "Reduce COLOR's contrast by blending it with the background.
+If excessive contrast exists between COLOR and the background,
+lower it to the upper bound of `erc-nicks-contrast-range'."
+ (erc-nicks--adjust-contrast color (cdr erc-nicks-contrast-range) 'remove))
+
+(defun erc-nicks-invert (color)
+ "Invert COLOR based on the CAR of `erc-nicks-contrast-range'.
+Don't bother if the inverted color has less contrast than the
+input."
+ (if-let ((con-input (erc-nicks--get-contrast color))
+ ((< con-input (car erc-nicks-contrast-range)))
+ (flipped (mapcar (lambda (c) (- 1.0 c)) color))
+ ((> (erc-nicks--get-contrast flipped) con-input)))
+ flipped
+ color))
+
+(defun erc-nicks-ensaturate (color)
+ "Ensure COLOR falls within `erc-nicks-saturation-range'."
+ (pcase-let ((`(,min . ,max) erc-nicks-saturation-range)
+ (`(,h ,s ,l) (apply #'color-rgb-to-hsl color)))
+ (cond ((> s max) (setq color (color-hsl-to-rgb h max l)))
+ ((< s min) (setq color (color-hsl-to-rgb h min l)))))
+ color)
+
+;; From https://elpa.gnu.org/packages/ement. The bit depth has been
+;; scaled up to try and avoid components being exactly 0.0, which our
+;; contrast function doesn't seem to like.
+(defun erc-nicks--gen-color (string)
+ "Generate normalized RGB color from STRING."
+ (let* ((ratio (/ (float (abs (random string))) (float most-positive-fixnum)))
+ (color-num (round (* #xffffffffffff ratio))))
+ (list (/ (float (logand color-num #xffff)) #xffff)
+ (/ (float (ash (logand color-num #xffff0000) -16)) #xffff)
+ (/ (float (ash (logand color-num #xffff00000000) -32)) #xffff))))
+
+;; This doesn't add an entry to the face table because "@" faces are
+;; interned in the global `obarray' and thus easily accessible.
+(defun erc-nicks--revive (new-face old-face nick net)
+ (put new-face 'erc-nicks--custom-face t)
+ (put new-face 'erc-nicks--nick nick)
+ (put new-face 'erc-nicks--netid erc-networks--id)
+ (put old-face 'erc-nicks--key nil)
+ (apply #'custom-declare-face new-face (face-user-default-spec old-face)
+ (format "Persistent `erc-nicks' color for %s on %s." nick net)
+ erc-nicks--custom-keywords))
+
+(defun erc-nicks--create-defface-template (face)
+ (pop-to-buffer (get-buffer-create (format "*New face %s*" face)))
+ (erase-buffer)
+ (lisp-interaction-mode)
+ (insert ";; If you *don't* use Customize, put something like this in your\n"
+ (substitute-command-keys
+ ";; init.el and use \\[eval-last-sexp] to apply any edits.\n\n")
+ (format "(defface %s\n '%S\n %S"
+ face (face-user-default-spec face) (face-documentation face))
+ (cl-loop for (k v) on erc-nicks--custom-keywords by #'cddr
+ concat (format "\n %s %S" k (list 'quote v)))
+ ")\n\n;; Or, if you use use-package\n(use-package erc-nicks\n"
+ " :custom-face\n"
+ (format " (%s %S)" face (face-user-default-spec face))
+ ")\n"))
+
+(defun erc-nicks--redirect-face-widget-link (args)
+ (pcase args
+ (`(,widget face-link . ,plist)
+ (when-let ((face (widget-value widget))
+ ((get face 'erc-nicks--custom-face)))
+ (unless (symbol-file face)
+ (setf (plist-get plist :action)
+ (lambda (&rest _) (erc-nicks--create-defface-template face))))
+ (setf (plist-get plist :help-echo) "Create or edit `defface'."
+ (cddr args) plist))))
+ args)
+
+(defun erc-nicks--reduce (color)
+ "Fold adjustment strategies over COLOR, a string or normalized triple.
+Return a hex string."
+ (apply #'color-rgb-to-hex
+ (seq-reduce (lambda (color strategy) (funcall strategy color))
+ erc-nicks-color-adjustments
+ (if (stringp color) (color-name-to-rgb color) color))))
+
+(defvar erc-nicks--create-pool-function #'erc-nicks--create-coerced-pool
+ "Filter function for initializing the pool of colors.
+Takes a list of adjustment functions, such as those named in
+`erc-nicks-color-adjustments', and a list of colors. Returns
+another list whose members need not be among the original
+candidates. Users should note that this variable, along with its
+predefined function values, `erc-nicks--create-coerced-pool' and
+`erc-nicks--create-culled-pool', can be made public in a future
+version of this module, perhaps as a single user option, given
+sufficient demand.")
+
+(defun erc-nicks--create-coerced-pool (adjustments colors)
+ "Return COLORS that fall within parameters heeded by ADJUSTMENTS.
+Apply ADJUSTMENTS and dedupe after replacing adjusted values with
+those nearest defined for the terminal. Only perform one pass.
+That is, accept the nearest initially found as \"close enough,\"
+knowing that values may fall outside desired parameters and thus
+yield a larger pool than simple culling might produce. When
+debugging, add candidates to `erc-nicks--colors-rejects' that map
+to the same output color as some prior candidate."
+ (let* ((seen (make-hash-table :test #'equal))
+ (erc-nicks-color-adjustments adjustments)
+ pool)
+ (dolist (color colors)
+ (let ((quantized (car (tty-color-approximate
+ (color-values (erc-nicks--reduce color))))))
+ (if (gethash quantized seen)
+ (when erc-nicks--colors-rejects
+ (push color erc-nicks--colors-rejects))
+ (push quantized pool)
+ (puthash quantized color seen))))
+ (nreverse pool)))
+
+(defun erc-nicks--create-culled-pool (adjustments colors)
+ "Return COLORS that fall within parameters indicated by ADJUSTMENTS."
+ (let (addp capp satp pool)
+ (dolist (adjustment adjustments)
+ (pcase adjustment
+ ((or 'erc-nicks-invert 'erc-nicks-add-contrast) (setq addp t))
+ ('erc-nicks-cap-contrast (setq capp t))
+ ('erc-nicks-ensaturate (setq satp t))))
+ (dolist (color colors)
+ (let* ((rgb (color-name-to-rgb color))
+ (contrast (and (or addp capp) (erc-nicks--get-contrast rgb))))
+ (if (or (and addp (< contrast (car erc-nicks-contrast-range)))
+ (and capp (> contrast (cdr erc-nicks-contrast-range)))
+ (and-let* ((satp)
+ (s (cadr (apply #'color-rgb-to-hsl rgb))))
+ (or (< s (car erc-nicks-saturation-range))
+ (> s (cdr erc-nicks-saturation-range)))))
+ (when erc-nicks--colors-rejects
+ (push color erc-nicks--colors-rejects))
+ (push color pool))))
+ (nreverse pool)))
+
+(defun erc-nicks--init-pool ()
+ "Initialize colors and optionally display faces or color palette."
+ (unless (eq erc-nicks-colors 'all)
+ (let* ((colors (or (and (listp erc-nicks-colors) erc-nicks-colors)
+ (and (memq erc-nicks-colors '(font-lock ansi-color))
+ (erc-nicks--colors-from-faces
+ (format "%s-" erc-nicks-colors)))
+ (defined-colors)))
+ (pool (funcall erc-nicks--create-pool-function
+ erc-nicks-color-adjustments colors)))
+ (setq erc-nicks--colors-pool pool
+ erc-nicks--colors-len (length pool)))))
+
+(defun erc-nicks--determine-color (key)
+ (if (eq erc-nicks-colors 'all)
+ (erc-nicks--reduce (erc-nicks--gen-color key))
+ (let ((pool (erc-with-server-buffer erc-nicks--colors-pool))
+ (len (erc-with-server-buffer erc-nicks--colors-len)))
+ (nth (% (abs (random key)) len) pool))))
+
+(defun erc-nicks--get-face (nick key)
+ "Retrieve a face for trimmed and downcased NICK.
+If NICK is new, use KEY to derive color, and store under NICK.
+Favor a custom erc-nicks-NICK@NETWORK-face when defined."
+ (let ((table (erc-with-server-buffer erc-nicks--face-table)))
+ (or (gethash nick table)
+ (and-let* ((face (intern-soft (concat "erc-nicks-" nick "@"
+ (erc-network-name) "-face")))
+ ((or (and (facep face) face)
+ (erc-nicks--revive face face nick (erc-network))))))
+ (let ((color (erc-nicks--determine-color key))
+ (new-face (make-symbol (concat "erc-nicks-" nick "-face"))))
+ (put new-face 'erc-nicks--nick nick)
+ (put new-face 'erc-nicks--netid erc-networks--id)
+ (put new-face 'erc-nicks--key key)
+ (face-spec-set new-face `((t :foreground ,color
+ :inherit ,erc-nicks-backing-face))
+ 'face-defface-spec)
+ (set-face-documentation
+ new-face (format "Internal face for %s on %s." nick (erc-network)))
+ (puthash nick new-face table)))))
+
+(define-inline erc-nicks--anon-face-p (face)
+ (inline-quote (and (consp ,face) (pcase (car ,face)
+ ((pred keywordp) t)
+ ('foreground-color t)
+ ('background-color t)))))
+
+(defun erc-nicks--skip-p (prop option limit)
+ "Return non-nil if a face in PROP appears in OPTION.
+Abandon search after examining LIMIT faces."
+ (setq prop (if (erc-nicks--anon-face-p prop) (list prop) (ensure-list prop)))
+ (catch 'found
+ (while-let (((> limit 0))
+ (elem (pop prop)))
+ (while (and (consp elem) (not (erc-nicks--anon-face-p elem)))
+ (when (cdr elem)
+ (push (cdr elem) prop))
+ (setq elem (car elem)))
+ (when elem
+ (cl-decf limit)
+ (when (if (symbolp elem) (memq elem option) (member elem option))
+ (throw 'found elem))))))
+
+(defun erc-nicks--trim (nickname)
+ "Return downcased NICKNAME sans trailing `erc-nicks-ignore-chars'."
+ (erc-downcase
+ (if erc-nicks-ignore-chars
+ (string-trim-right nickname
+ (rx-to-string
+ `(: (+ (any ,erc-nicks-ignore-chars)) eot)))
+ nickname)))
+
+(defun erc-nicks--gen-key-from-format-spec (nickname)
+ "Generate key for NICKNAME according to `erc-nicks-key-suffix-format'."
+ (concat nickname (format-spec erc-nicks-key-suffix-format
+ `((?n . ,(erc-network))
+ (?m . ,(erc-current-nick))))))
+
+(defun erc-nicks--highlight (nickname &optional base-face)
+ "Return face for NICKNAME unless it or BASE-FACE is blacklisted."
+ (when-let ((trimmed (erc-nicks--trim nickname))
+ ((not (member trimmed erc-nicks--downcased-skip-nicks)))
+ ((not (and base-face
+ (erc-nicks--skip-p base-face erc-nicks-skip-faces
+ erc-nicks--max-skip-search))))
+ (key (erc-nicks--gen-key-from-format-spec trimmed)))
+ (erc-nicks--get-face trimmed key)))
+
+(defun erc-nicks--highlight-button (nick-object)
+ "Possibly add face to `erc-button--nick-user' NICK-OBJECT."
+ (when-let
+ ((nick-object)
+ (face (get-text-property (car (erc-button--nick-bounds nick-object))
+ 'font-lock-face))
+ (nick (erc-server-user-nickname (erc-button--nick-user nick-object)))
+ (out (erc-nicks--highlight nick face)))
+ (setf (erc-button--nick-nickname-face nick-object) out
+ ;;
+ (erc-button--nick-face-cache nick-object)
+ (and erc-nicks-track-faces
+ (bound-and-true-p erc-track--normal-faces)
+ #'erc-nicks--remember-face-for-track)))
+ nick-object)
+
+(define-erc-module nicks nil
+ "Uniquely colorize nicknames in target buffers."
+ ((if erc--target
+ (progn
+ (erc-with-server-buffer
+ (unless erc-nicks-mode
+ (erc--warn-once-before-connect 'erc-nicks-mode
+ "Module `nicks' must be enabled or disabled session-wide."
+ " Toggling it in individual target buffers is unsupported.")
+ (erc-nicks-mode +1))) ; but do it anyway
+ (setq erc-nicks--downcased-skip-nicks
+ (mapcar #'erc-downcase erc-nicks-skip-nicks)
+ erc-nicks--fg-rgb (erc-with-server-buffer erc-nicks--fg-rgb))
+ (add-function :filter-return (local 'erc-button--modify-nick-function)
+ #'erc-nicks--highlight-button '((depth . 80)))
+ (erc-button--phantom-users-mode +1))
+ (unless erc-button-mode
+ (unless (memq 'button erc-modules)
+ (erc--warn-once-before-connect 'erc-nicks-mode
+ "Enabling default global module `button' needed by local"
+ " module `nicks'. This will impact \C-]all\C-] ERC"
+ " sessions. Add `button' to `erc-modules' to avoid this"
+ " warning. See Info:\"(erc) Modules\" for more."))
+ (erc-button-mode +1))
+ (when (equal erc-nicks-bg-color "unspecified-bg")
+ (let ((temp (if (eq (erc-nicks--bg-mode) 'light) "white" "black")))
+ (erc-button--display-error-notice-with-keys
+ "Module `nicks' unable to determine background color. Setting to \""
+ temp "\" globally. Please see `erc-nicks-bg-color'.")
+ (custom-set-variables (list 'erc-nicks-bg-color temp))))
+ (setq erc-nicks--fg-rgb
+ (or (color-name-to-rgb
+ (face-foreground 'erc-default-face nil 'default))
+ (color-name-to-rgb
+ (readable-foreground-color erc-nicks-bg-color))))
+ (erc-nicks--init-pool)
+ (erc--restore-initialize-priors erc-nicks-mode
+ erc-nicks--face-table (make-hash-table :test #'equal)))
+ (setf (alist-get "Edit face" erc-button--nick-popup-alist nil nil #'equal)
+ #'erc-nicks-customize-face)
+ (erc-nicks--setup-track-integration)
+ (add-hook 'erc-track-mode #'erc-nicks--setup-track-integration 50 t)
+ (advice-add 'widget-create-child-and-convert :filter-args
+ #'erc-nicks--redirect-face-widget-link))
+ ((kill-local-variable 'erc-nicks--face-table)
+ (kill-local-variable 'erc-nicks--bg-mode-value)
+ (kill-local-variable 'erc-nicks--bg-luminance)
+ (kill-local-variable 'erc-nicks--fg-rgb)
+ (kill-local-variable 'erc-nicks--colors-len)
+ (kill-local-variable 'erc-nicks--colors-pool)
+ (kill-local-variable 'erc-nicks--downcased-skip-nicks)
+ (when (fboundp 'erc-button--phantom-users-mode)
+ (erc-button--phantom-users-mode -1))
+ (remove-function (local 'erc-track--face-reject-function)
+ #'erc-nicks--reject-uninterned-faces)
+ (remove-function (local 'erc-button--modify-nick-function)
+ #'erc-nicks--highlight-button)
+ (remove-function (local 'erc-track--alt-normals-function)
+ #'erc-nicks--check-normals)
+ (setf (alist-get "Edit face"
+ erc-button--nick-popup-alist nil 'remove #'equal)
+ nil)
+ (unless erc-button--nick-popup-alist
+ (kill-local-variable 'erc-button--nick-popup-alist)))
+ 'local)
+
+(defun erc-nicks-customize-face (nick)
+ "Customize or create persistent face for NICK."
+ (interactive (list (or (car (get-text-property (point) 'erc-data))
+ (completing-read "nick: " (or erc-channel-users
+ erc-server-users)))))
+ (setq nick (erc-nicks--trim (substring-no-properties nick)))
+ (let* ((net (erc-network))
+ (key (erc-nicks--gen-key-from-format-spec nick))
+ (old-face (erc-nicks--get-face nick key))
+ (new-face (intern (format "erc-nicks-%s@%s-face" nick net))))
+ (unless (eq new-face old-face)
+ (erc-nicks--revive new-face old-face nick net)
+ (set-face-attribute old-face nil :foreground 'unspecified)
+ (set-face-attribute old-face nil :inherit new-face))
+ (customize-face new-face)))
+
+(defun erc-nicks--list-faces-help-button-action (face)
+ (when-let (((or (get face 'erc-nicks--custom-face)
+ (y-or-n-p (format "Create new persistent face for %s?"
+ (get face 'erc-nicks--key)))))
+ (nid (get face 'erc-nicks--netid))
+ (foundp (lambda ()
+ (erc-networks--id-equal-p nid erc-networks--id)))
+ (server-buffer (car (erc-buffer-filter foundp))))
+ (with-current-buffer server-buffer
+ (erc-nicks-customize-face (get face 'erc-nicks--nick)))))
+
+(defun erc-nicks-list-faces ()
+ "Show faces owned by ERC-nicks in a help buffer."
+ (interactive)
+ (save-excursion
+ (list-faces-display (rx bot "erc-nicks-"))
+ (with-current-buffer "*Faces*"
+ (setq help-xref-stack nil
+ help-xref-stack-item '(erc-nicks-list-faces))
+ (with-silent-modifications
+ (goto-char (point-min))
+ (while (zerop (forward-line))
+ (when (and (get-text-property (point) 'button)
+ (facep (car (button-get (point) 'help-args))))
+ (button-put (point) 'help-function
+ #'erc-nicks--list-faces-help-button-action)
+ (if-let ((face (car (button-get (point) 'help-args)))
+ ((not (get face 'erc-nicks--custom-face)))
+ ((not (get face 'erc-nicks--key))))
+ (progn (delete-region (pos-bol) (1+ (pos-eol)))
+ (forward-line -1))
+ (when-let ((nid (get face 'erc-nicks--netid))
+ (net (symbol-name (erc-networks--id-symbol nid))))
+ (goto-char (button-end (point)))
+ (skip-syntax-forward "-")
+ (put-text-property (point) (1+ (point)) 'rear-nonsticky nil)
+ (forward-char)
+ (when (stringp (face-foreground face))
+ (setq net (format "%-13.13s %s" (substring-no-properties
+ (face-foreground face))
+ net)))
+ (insert-and-inherit net)
+ (delete-region (button-start (point))
+ (1+ (button-start (point))))
+ (delete-region (point) (pos-eol))))))))))
+
+(defun erc-nicks-refresh (debug)
+ "Recompute faces for all nicks on current network.
+With DEBUG, review affected faces or colors. Exactly which of
+the two depends on the value of `erc-nicks-colors'. Note that
+the list of rejected faces may include duplicates of accepted
+ones."
+ (interactive "P")
+ (unless (derived-mode-p 'erc-mode)
+ (user-error "Not an ERC buffer"))
+ (erc-with-server-buffer
+ (unless erc-nicks-mode (user-error "Module `nicks' disabled"))
+ (let ((erc-nicks--colors-rejects (and debug (list t))))
+ (erc-nicks--init-pool)
+ (unless erc-nicks--colors-pool
+ (user-error "Pool empty: all colors rejected"))
+ (dolist (nick (hash-table-keys erc-nicks--face-table))
+ ;; User-tuned faces do not have an `erc-nicks--key' property.
+ (when-let ((face (gethash nick erc-nicks--face-table))
+ (key (get face 'erc-nicks--key)))
+ (setq key (erc-nicks--gen-key-from-format-spec nick))
+ (put face 'erc-nicks--key key)
+ (set-face-foreground face (erc-nicks--determine-color key))))
+ (when debug
+ (if (eq erc-nicks-colors 'all)
+ (erc-nicks-list-faces)
+ (pcase-dolist (`(,name ,pool)
+ `(("*erc-nicks-pool*" ,erc-nicks--colors-pool)
+ ("*erc-nicks-rejects*"
+ ,(cdr (nreverse erc-nicks--colors-rejects)))))
+ (when (buffer-live-p (get-buffer name))
+ (kill-buffer name))
+ (when pool
+ (save-excursion
+ (list-colors-display
+ pool name
+ (lambda (c)
+ (message "contrast: %.3f :saturation: %.3f"
+ (erc-nicks--get-contrast c)
+ (cadr (apply #'color-rgb-to-hsl
+ (color-name-to-rgb c))))))))))))))
+
+(defun erc-nicks--colors-from-faces (prefix)
+ "Extract foregrounds from faces with PREFIX
+Expect PREFIX to be something like \"ansi-color-\" or \"font-lock-\"."
+ (let (out)
+ (dolist (face (face-list) (nreverse out))
+ (when-let (((string-prefix-p prefix (symbol-name face)))
+ (color (face-foreground face)))
+ (push color out)))))
+
+(defun erc-nicks--reject-uninterned-faces (candidate)
+ "Remove own faces from CANDIDATE if it's a combination of faces."
+ (while-let ((next (car-safe candidate))
+ ((facep next))
+ ((not (intern-soft next))))
+ (setq candidate (cdr candidate)))
+ (if (and (consp candidate) (not (cdr candidate))) (car candidate) candidate))
+
+(define-inline erc-nicks--oursp (face)
+ (inline-quote
+ (and-let* ((sym (car-safe ,face))
+ ((symbolp sym))
+ ((get sym 'erc-nicks--key)))
+ sym)))
+
+(defun erc-nicks--check-normals (current contender contenders normals)
+ "Return a viable `nicks'-owned face from NORMALS in CONTENDERS.
+But only do so if the CURRENT face is also one of ours and in
+NORMALS and if the highest ranked CONTENDER among new faces is
+`erc-default-face', the lowest ranking default priority face."
+ (and-let* (((eq contender 'erc-default-face))
+ ((or (null current) (gethash current normals)))
+ (spkr (or (null current) (erc-nicks--oursp current))))
+ (catch 'contender
+ (dolist (candidate (cdr contenders) contender)
+ (when-let (((not (equal candidate current)))
+ ((gethash candidate normals))
+ (s (erc-nicks--oursp candidate))
+ ((not (eq s spkr))))
+ (throw 'contender candidate))))))
+
+(defun erc-nicks--setup-track-integration ()
+ "Restore traditional \"alternating normal\" face functionality to mode-line."
+ (when (bound-and-true-p erc-track-mode)
+ (pcase erc-nicks-track-faces
+ ;; Variant `defer' is handled elsewhere.
+ ('prioritize
+ (add-function :override (local 'erc-track--alt-normals-function)
+ #'erc-nicks--check-normals))
+ ('nil
+ (add-function :override (local 'erc-track--face-reject-function)
+ #'erc-nicks--reject-uninterned-faces)))))
+
+(defun erc-nicks--remember-face-for-track (face)
+ "Add FACE to local hash table maintained by `track' module."
+ (or (gethash face erc-track--normal-faces)
+ (if-let ((sym (or (car-safe face) face))
+ ((symbolp sym))
+ ((get sym 'erc-nicks--key)))
+ (puthash face face erc-track--normal-faces)
+ face)))
+
+(provide 'erc-nicks)
+
+;;; erc-nicks.el ends here
diff --git a/lisp/erc/erc-notify.el b/lisp/erc/erc-notify.el
index b900fa28edc..45b0fb12c43 100644
--- a/lisp/erc/erc-notify.el
+++ b/lisp/erc/erc-notify.el
@@ -30,7 +30,6 @@
;;; Code:
(require 'erc)
-(require 'erc-networks)
(eval-when-compile (require 'pcomplete))
;;;; Customizable variables
@@ -78,12 +77,14 @@ strings."
;;;; Setup
(defun erc-notify-install-message-catalogs ()
- (erc-define-catalog
- 'english
- '((notify_current . "Notified people online: %l")
- (notify_list . "Current notify list: %l")
- (notify_on . "Detected %n on IRC network %m")
- (notify_off . "%n has left IRC network %m"))))
+ (declare (obsolete "defined at top level in erc-notify.el" "30.1"))
+ (with-suppressed-warnings ((obsolete erc-define-catalog))
+ (erc-define-catalog
+ 'english
+ '((notify-current . "Notified people online: %l")
+ (notify-list . "Current notify list: %l")
+ (notify-on . "Detected %n on IRC network %m")
+ (notify-off . "%n has left IRC network %m")))))
;;;###autoload(autoload 'erc-notify-mode "erc-notify" nil t)
(define-erc-module notify nil
@@ -119,14 +120,14 @@ changes."
(run-hook-with-args 'erc-notify-signon-hook server (car new-list))
(erc-display-message
parsed 'notice proc
- 'notify_on ?n (car new-list) ?m (erc-network-name)))
+ 'notify-on ?n (car new-list) ?m (erc-network-name)))
(setq new-list (cdr new-list)))
(while old-list
(when (not (erc-member-ignore-case (car old-list) ison-list))
(run-hook-with-args 'erc-notify-signoff-hook server (car old-list))
(erc-display-message
parsed 'notice proc
- 'notify_off ?n (car old-list) ?m (erc-network-name)))
+ 'notify-off ?n (car old-list) ?m (erc-network-name)))
(setq old-list (cdr old-list)))
(setq erc-last-ison ison-list)
t)))
@@ -136,8 +137,8 @@ changes."
(defun erc-notify-JOIN (proc parsed)
"Check if channel joiner is on `erc-notify-list' and not on `erc-last-ison'.
-If this condition is satisfied, produce a notify_on message and add the nick
-to `erc-last-ison' to prevent any further notifications."
+When that's the case, produce a `notify-on' message and add the
+nick to `erc-last-ison' to prevent any further notifications."
(let ((nick (erc-extract-nick (erc-response.sender parsed))))
(when (and (erc-member-ignore-case nick erc-notify-list)
(not (erc-member-ignore-case nick erc-last-ison)))
@@ -147,13 +148,13 @@ to `erc-last-ison' to prevent any further notifications."
nick)
(erc-display-message
parsed 'notice proc
- 'notify_on ?n nick ?m (erc-network-name)))
+ 'notify-on ?n nick ?m (erc-network-name)))
nil))
(defun erc-notify-NICK (proc parsed)
"Check if new nick is on `erc-notify-list' and not on `erc-last-ison'.
-If this condition is satisfied, produce a notify_on message and add the nick
-to `erc-last-ison' to prevent any further notifications."
+When that's the case, produce a `notify-on' message and add the
+nick to `erc-last-ison' to prevent any further notifications."
(let ((nick (erc-response.contents parsed)))
(when (and (erc-member-ignore-case nick erc-notify-list)
(not (erc-member-ignore-case nick erc-last-ison)))
@@ -163,13 +164,13 @@ to `erc-last-ison' to prevent any further notifications."
nick)
(erc-display-message
parsed 'notice proc
- 'notify_on ?n nick ?m (erc-network-name)))
+ 'notify-on ?n nick ?m (erc-network-name)))
nil))
(defun erc-notify-QUIT (proc parsed)
"Check if quitter is on `erc-notify-list' and on `erc-last-ison'.
-If this condition is satisfied, produce a notify_off message and remove the
-nick from `erc-last-ison' to prevent any further notifications."
+When that's the case, insert a `notify-off' message and remove
+the nick from `erc-last-ison' to prevent further notifications."
(let ((nick (erc-extract-nick (erc-response.sender parsed))))
(when (and (erc-member-ignore-case nick erc-notify-list)
(erc-member-ignore-case nick erc-last-ison))
@@ -183,7 +184,7 @@ nick from `erc-last-ison' to prevent any further notifications."
nick)
(erc-display-message
parsed 'notice proc
- 'notify_off ?n nick ?m (erc-network-name)))
+ 'notify-off ?n nick ?m (erc-network-name)))
nil))
;;;; User level command
@@ -193,6 +194,12 @@ nick from `erc-last-ison' to prevent any further notifications."
"Change `erc-notify-list' or list current notify-list members online.
Without args, list the current list of notified people online,
with args, toggle notify status of people."
+ (unless erc-notify-mode
+ (erc-notify-mode +1)
+ (erc-button--display-error-notice-with-keys
+ (current-buffer)
+ "Command /NOTIFY requires the `notify' module. Enabling now. Add `notify'"
+ " to `erc-modules' before next starting ERC to silence this message."))
(cond
((null args)
;; Print current notified people (online)
@@ -202,11 +209,12 @@ with args, toggle notify status of people."
nil 'notice 'active "No ison-list yet!")
(erc-display-message
nil 'notice 'active
- 'notify_current ?l ison))))
+ 'notify-current ?l ison))))
((string= (car args) "-l")
- (erc-display-message nil 'notice 'active
- 'notify_list ?l (mapconcat #'identity erc-notify-list
- " ")))
+ (let ((list (if erc-notify-list
+ (mapconcat #'identity erc-notify-list " ")
+ "(empty)")))
+ (erc-display-message nil 'notice 'active 'notify-list ?l list)))
(t
(while args
(if (erc-member-ignore-case (car args) erc-notify-list)
@@ -218,28 +226,41 @@ with args, toggle notify status of people."
;; from your notify list.
(dolist (buf (erc-buffer-list))
(with-current-buffer buf
- (if (erc-server-buffer-p)
+ ;; FIXME replace with `erc--server-buffer-p' or
+ ;; explain why that's unwise.
+ (if (erc-server-or-unjoined-channel-buffer-p)
(setq erc-last-ison (delete (car args) erc-last-ison))))))
(setq erc-notify-list (cons (erc-string-no-properties (car args))
erc-notify-list)))
(setq args (cdr args)))
- (erc-display-message
- nil 'notice 'active
- 'notify_list ?l (mapconcat #'identity erc-notify-list " "))))
+ (erc-cmd-NOTIFY "-l")))
t)
-(autoload 'pcomplete-erc-all-nicks "erc-pcomplete")
-
;; "--" is not a typo.
(declare-function pcomplete--here "pcomplete"
(&optional form stub paring form-only))
+(declare-function pcomplete-erc-all-nicks "erc-pcomplete"
+ (&optional postfix))
;;;###autoload
(defun pcomplete/erc-mode/NOTIFY ()
- (require 'pcomplete)
- (pcomplete-here (pcomplete-erc-all-nicks)))
-
-(erc-notify-install-message-catalogs)
+ (require 'erc-pcomplete)
+ (pcomplete-here (append erc-notify-list (pcomplete-erc-all-nicks))))
+
+(define-obsolete-variable-alias 'erc-message-english-notify_on
+ 'erc-message-english-notify-on "30.1")
+(define-obsolete-variable-alias 'erc-message-english-notify_off
+ 'erc-message-english-notify-off "30.1")
+(define-obsolete-variable-alias 'erc-message-english-notify_list
+ 'erc-message-english-notify-list "30.1")
+(define-obsolete-variable-alias 'erc-message-english-notify_current
+ 'erc-message-english-notify-current "30.1")
+
+(erc-define-message-format-catalog english
+ (notify-current . "Notified people online: %l")
+ (notify-list . "Current notify list: %l")
+ (notify-on . "Detected %n on IRC network %m")
+ (notify-off . "%n has left IRC network %m"))
(provide 'erc-notify)
diff --git a/lisp/erc/erc-page.el b/lisp/erc/erc-page.el
index c4cb0c3844b..7e777adfaf9 100644
--- a/lisp/erc/erc-page.el
+++ b/lisp/erc/erc-page.el
@@ -30,16 +30,20 @@
(require 'erc)
+(declare-function erc-controls-interpret "erc-goodies" (str))
+
(defgroup erc-page nil
"React to CTCP PAGE messages."
:group 'erc)
+;;;###autoload(put 'ctcp-page 'erc--module 'page)
;;;###autoload(autoload 'erc-page-mode "erc-page")
(define-erc-module page ctcp-page
"Process CTCP PAGE requests from IRC."
nil nil)
-(erc-define-catalog-entry 'english 'CTCP-PAGE "Page from %n (%u@%h): %m")
+(defvar erc-message-english-CTCP-PAGE "Page from %n (%u@%h): %m"
+ "English template for a CTCP PAGE message.")
(defcustom erc-page-function nil
"A function to process a \"page\" request.
@@ -69,6 +73,7 @@ SENDER and MSG, so that might be easier to use."
This will call `erc-page-function', if defined, or it will just print
a message and `beep'. In addition to that, the page message is also
inserted into the server buffer."
+ (require 'erc-goodies) ; for `erc-controls-interpret'
(when (and erc-page-mode
(string-match "PAGE\\(\\s-+.*\\)?$" msg))
(let* ((m (match-string 1 msg))
diff --git a/lisp/erc/erc-pcomplete.el b/lisp/erc/erc-pcomplete.el
index ecba7661e40..05cbaf3872f 100644
--- a/lisp/erc/erc-pcomplete.el
+++ b/lisp/erc/erc-pcomplete.el
@@ -56,7 +56,11 @@ add this string to nicks completed."
"If t, order nickname completions with the most recent speakers first."
:type 'boolean)
+;;;###autoload(put 'Completion 'erc--module 'completion)
+;;;###autoload(put 'pcomplete 'erc--module 'completion)
+;;;###autoload(put 'completion 'erc--feature 'erc-pcomplete)
;;;###autoload(autoload 'erc-completion-mode "erc-pcomplete" nil t)
+(put 'completion 'erc-group 'erc-pcomplete)
(define-erc-module pcomplete Completion
"In ERC Completion mode, the TAB key does completion whenever possible."
((add-hook 'erc-mode-hook #'pcomplete-erc-setup)
diff --git a/lisp/erc/erc-ring.el b/lisp/erc/erc-ring.el
index 7e934d7a27a..d05d44044ea 100644
--- a/lisp/erc/erc-ring.el
+++ b/lisp/erc/erc-ring.el
@@ -46,10 +46,10 @@
(define-erc-module ring nil
"Stores input in a ring so that previous commands and messages can
be recalled using M-p and M-n."
- ((add-hook 'erc-pre-send-functions #'erc-add-to-input-ring)
+ ((add-hook 'erc--input-review-functions #'erc-add-to-input-ring 90)
(define-key erc-mode-map "\M-p" #'erc-previous-command)
(define-key erc-mode-map "\M-n" #'erc-next-command))
- ((remove-hook 'erc-pre-send-functions #'erc-add-to-input-ring)
+ ((remove-hook 'erc--input-review-functions #'erc-add-to-input-ring)
(define-key erc-mode-map "\M-p" #'undefined)
(define-key erc-mode-map "\M-n" #'undefined)))
diff --git a/lisp/erc/erc-sasl.el b/lisp/erc/erc-sasl.el
index 32891d050f8..f1cc68e2620 100644
--- a/lisp/erc/erc-sasl.el
+++ b/lisp/erc/erc-sasl.el
@@ -137,12 +137,12 @@ that symbol is `:password', in which case, use a non-nil
`erc-session-password' instead. Otherwise, just defer to
`erc-auth-source-search' to pick a suitable `:host'. Expect
PLIST to contain keyword params known to `auth-source-search'."
- (when erc-sasl-password
- (when-let ((host (if (eq :password erc-sasl-password)
- (and (not (functionp erc-session-password))
- erc-session-password)
- erc-sasl-password)))
- (setq plist `(,@plist :host ,(format "%s" host)))))
+ (when-let* ((erc-sasl-password)
+ (host (if (eq :password erc-sasl-password)
+ (and (not (functionp erc-session-password))
+ erc-session-password)
+ erc-sasl-password)))
+ (setq plist `(,@plist :host ,(format "%s" host))))
(apply #'erc-auth-source-search plist))
(defun erc-sasl--read-password (prompt)
@@ -297,21 +297,6 @@ If necessary, pass PROMPT to `read-passwd'."
(sasl-client-set-property client 'ecdsa-keyfile keyfile)
client)))))
-;; This stands alone because it's also used by bug#49860.
-(defun erc-sasl--init ()
- (setq erc-sasl--state (make-erc-sasl--state))
- ;; If the previous attempt failed during registration, this may be
- ;; non-nil and contain erroneous values, but how can we detect that?
- ;; What if the server dropped the connection for some other reason?
- (setq erc-sasl--options
- (or (and erc--server-reconnecting
- (alist-get 'erc-sasl--options erc--server-reconnecting))
- `((user . ,erc-sasl-user)
- (password . ,erc-sasl-password)
- (mechanism . ,erc-sasl-mechanism)
- (authfn . ,erc-sasl-auth-source-function)
- (authzid . ,erc-sasl-authzid)))))
-
(defun erc-sasl--mechanism-offered-p (offered)
"Return non-nil when OFFERED appears among a list of mechanisms."
(string-match-p (rx-to-string
@@ -320,9 +305,8 @@ If necessary, pass PROMPT to `read-passwd'."
(| eot ",")))
(downcase offered)))
-(erc-define-catalog
- 'english
- '((s902 . "ERR_NICKLOCKED nick %n unavailable: %s")
+(erc--define-catalog english
+ ((s902 . "ERR_NICKLOCKED nick %n unavailable: %s")
(s904 . "ERR_SASLFAIL (authentication failed) %s")
(s905 . "ERR SASLTOOLONG (credentials too long) %s")
(s906 . "ERR_SASLABORTED (authentication aborted) %s")
@@ -334,13 +318,22 @@ If necessary, pass PROMPT to `read-passwd'."
This doesn't solicit or validate a suite of supported mechanisms."
;; See bug#49860 for a CAP 3.2-aware WIP implementation.
((unless erc--target
- (erc-sasl--init)
+ (setq erc-sasl--state (make-erc-sasl--state))
+ ;; If the previous attempt failed during registration, this may be
+ ;; non-nil and contain erroneous values, but how can we detect that?
+ ;; What if the server dropped the connection for some other reason?
+ (erc--restore-initialize-priors erc-sasl-mode
+ erc-sasl--options `((user . ,erc-sasl-user)
+ (password . ,erc-sasl-password)
+ (mechanism . ,erc-sasl-mechanism)
+ (authfn . ,erc-sasl-auth-source-function)
+ (authzid . ,erc-sasl-authzid)))
(let* ((mech (alist-get 'mechanism erc-sasl--options))
(client (erc-sasl--create-client mech)))
(unless client
(erc-display-error-notice
- nil (format "Unknown or unsupported SASL mechanism: %s" mech))
- (erc-error "Unknown or unsupported SASL mechanism: %s" mech))
+ nil (format "Unknown or unsupported SASL mechanism: `%s'" mech))
+ (error "Unknown or unsupported SASL mechanism: `%s'" mech))
(setf (erc-sasl--state-client erc-sasl--state) client))))
((kill-local-variable 'erc-sasl--state)
(kill-local-variable 'erc-sasl--options))
@@ -369,14 +362,18 @@ This doesn't solicit or validate a suite of supported mechanisms."
data (sasl-step-data step))
(when (string= data "")
(setq data nil))
- (when data
- (setq data (erc--unfun (base64-encode-string data t))))
- (erc-server-send (concat "AUTHENTICATE " (or data "+"))))))
+ (setq data (if data (erc--unfun (base64-encode-string data t)) "+"))
+ (while (not (string-empty-p data))
+ (let ((end (min 400 (length data))))
+ ;; For now, assume this is unlikely to block
+ (erc-server-send (concat "AUTHENTICATE " (substring data 0 end)))
+ (setq data (concat (substring data end) (and (= end 400) "+"))))))))
(defun erc-sasl--destroy (proc)
- (run-hook-with-args 'erc-quit-hook proc)
+ "Destroy process PROC and warn user that their settings are likely faulty."
(delete-process proc)
- (erc-error "Disconnected from %s; please review SASL settings" proc))
+ (erc--lwarn 'erc-sasl :error
+ "Disconnected from %s; please review SASL settings" proc))
(define-erc-response-handler (902)
"Handle an ERR_NICKLOCKED response." nil
diff --git a/lisp/erc/erc-services.el b/lisp/erc/erc-services.el
index 37e8338a23f..92cb9075b5e 100644
--- a/lisp/erc/erc-services.el
+++ b/lisp/erc/erc-services.el
@@ -102,6 +102,7 @@ You can also use \\[erc-nickserv-identify-mode] to change modes."
(when (featurep 'erc-services)
(erc-nickserv-identify-mode val))))
+;;;###autoload(put 'nickserv 'erc--module 'services)
;;;###autoload(autoload 'erc-services-mode "erc-services" nil t)
(define-erc-module services nickserv
"This mode automates communication with services."
@@ -512,6 +513,127 @@ Returns t if the identify message could be sent, nil otherwise."
nick)
nil))
+
+;;;; Regaining nicknames
+
+(defcustom erc-services-regain-alist nil
+ "Alist mapping networks to nickname-regaining functions.
+This option depends on the `services-regain' module being loaded.
+Keys can also be symbols for user-provided \"context IDs\" (see
+Info node `Network Identifier'). Functions run once, when first
+establishing a logical IRC connection. Although ERC currently
+calls them with one argument, the desired but rejected nickname,
+robust user implementations should leave room for later additions
+by defining an &rest _ parameter, as well.
+
+The simplest value is `erc-services-retry-nick-on-connect', which
+attempts to kill off stale connections without engaging services
+at all. Others, like `erc-services-issue-regain', and
+`erc-services-issue-ghost-and-retry-nick', only speak a
+particular flavor of NickServ. See their respective doc strings
+for details and use cases."
+ :package-version '(ERC . "5.6")
+ :group 'erc-hooks
+ :type '(alist :key-type (symbol :tag "Network")
+ :value-type
+ (choice :tag "Strategy function"
+ (function-item erc-services-retry-nick-on-connect)
+ (function-item erc-services-issue-regain)
+ (function-item erc-services-issue-ghost-and-retry-nick)
+ function)))
+
+(defun erc-services-retry-nick-on-connect (want)
+ "Try at most once to grab nickname WANT after reconnecting.
+Expect to be used when automatically reconnecting to servers
+that are slow to abandon the previous connection.
+
+Note that this strategy may only work under certain conditions,
+such as when a user's account name matches their nick."
+ (erc-cmd-NICK want))
+
+(defun erc-services-issue-regain (want)
+ "Ask NickServ to regain nickname WANT.
+Assume WANT belongs to the user and that the services suite
+offers a \"REGAIN\" sub-command."
+ (erc-cmd-MSG (concat "NickServ REGAIN " want)))
+
+(defun erc-services-issue-ghost-and-retry-nick (want)
+ "Ask NickServ to \"GHOST\" nickname WANT.
+After which, attempt to grab WANT before the contending party
+reconnects. Assume the ERC user owns WANT and that the server's
+services suite lacks a \"REGAIN\" command.
+
+Note that this function will only work for a specific services
+implementation and is meant primarily as an example for adapting
+as needed."
+ ;; While heuristics based on error text may seem brittle, consider
+ ;; the fact that \"is not online\" has been present in Atheme's
+ ;; \"GHOST\" responses since at least 2005.
+ (letrec ((attempts 3)
+ (on-notice
+ (lambda (_proc parsed)
+ (when-let ((nick (erc-extract-nick
+ (erc-response.sender parsed)))
+ ((erc-nick-equal-p nick "nickserv"))
+ (contents (erc-response.contents parsed))
+ (case-fold-search t)
+ ((string-match (rx (or "ghost" "is not online"))
+ contents)))
+ (setq attempts 1)
+ (erc-server-send (concat "NICK " want) 'force))
+ (when (zerop (cl-decf attempts))
+ (remove-hook 'erc-server-NOTICE-functions on-notice t))
+ nil)))
+ (add-hook 'erc-server-NOTICE-functions on-notice nil t)
+ (erc-message "PRIVMSG" (concat "NickServ GHOST " want))))
+
+;;;###autoload(put 'services-regain 'erc--feature 'erc-services)
+(define-erc-module services-regain nil
+ "Reacquire a nickname from your past self or some interloper.
+This module only concerns itself with initial nick rejections
+that occur during connection registration in response to an
+opening \"NICK\" command. More specifically, the following
+conditions must be met for ERC to activate this mechanism and
+consider its main option, `erc-services-regain-alist':
+
+ - the server must reject the opening \"NICK\" request
+ - ERC must request a temporary nickname
+ - the user must successfully authenticate
+
+In practical terms, this means that this module, which is still
+somewhat experimental, is likely only useful in conjunction with
+SASL authentication rather than the traditional approach provided
+by the `services' module it shares a library with (see Info
+node `(erc) SASL' for more)."
+ nil nil 'local)
+
+(cl-defmethod erc--nickname-in-use-make-request
+ ((want string) temp &context (erc-server-connected null)
+ (erc-services-regain-mode (eql t))
+ (erc-services-regain-alist cons))
+ "Schedule possible regain attempt upon establishing connection.
+Expect WANT to be the desired nickname and TEMP to be the current
+one."
+ (letrec
+ ((after-connect
+ (lambda (_ nick)
+ (remove-hook 'erc-after-connect after-connect t)
+ (when-let*
+ (((equal temp nick))
+ (conn (or (erc-networks--id-given erc-networks--id)
+ (erc-network)))
+ (found (alist-get conn erc-services-regain-alist)))
+ (funcall found want))))
+ (on-900
+ (lambda (_ parsed)
+ (remove-hook 'erc-server-900-functions on-900 t)
+ (unless erc-server-connected
+ (when (equal (car (erc-response.command-args parsed)) temp)
+ (add-hook 'erc-after-connect after-connect nil t)))
+ nil)))
+ (add-hook 'erc-server-900-functions on-900 nil t))
+ (cl-call-next-method))
+
(provide 'erc-services)
diff --git a/lisp/erc/erc-sound.el b/lisp/erc/erc-sound.el
index 9cc0514681d..f1c6601427f 100644
--- a/lisp/erc/erc-sound.el
+++ b/lisp/erc/erc-sound.el
@@ -47,6 +47,11 @@
(require 'erc)
+(defgroup erc-sound nil
+ "Make ERC play bells and whistles while chatting with people."
+ :group 'erc)
+
+;;;###autoload(put 'ctcp-sound 'erc--module 'sound)
;;;###autoload(autoload 'erc-sound-mode "erc-sound")
(define-erc-module sound ctcp-sound
"In ERC sound mode, the client will respond to CTCP SOUND requests
@@ -58,11 +63,8 @@ and play sound files as requested."
((remove-hook 'erc-ctcp-query-SOUND-hook #'erc-ctcp-query-SOUND)
(define-key erc-mode-map "\C-c\C-s" #'undefined)))
-(erc-define-catalog-entry 'english 'CTCP-SOUND "%n (%u@%h) plays %s:%m")
-
-(defgroup erc-sound nil
- "Make ERC play bells and whistles while chatting with people."
- :group 'erc)
+(defvar erc-message-english-CTCP-SOUND "%n (%u@%h) plays %s:%m"
+ "English template for a CTCP SOUND message.")
(defcustom erc-play-sound t
"Play sounds when you receive CTCP SOUND requests."
diff --git a/lisp/erc/erc-speedbar.el b/lisp/erc/erc-speedbar.el
index accfb8ac703..a81a3869436 100644
--- a/lisp/erc/erc-speedbar.el
+++ b/lisp/erc/erc-speedbar.el
@@ -32,19 +32,31 @@
;; update-channel, update-nick, remove-nick-from-channel, ...
;; * Use indicator-strings for op/voice
;; * Extract/convert face notes field from bbdb if available
+;; * Write tests that run in a term-mode subprocess
;;
;;; Code:
(require 'erc)
+(require 'erc-goodies)
+(require 'erc-button)
(require 'speedbar)
-(condition-case nil (require 'dframe) (error nil))
;;; Customization:
(defgroup erc-speedbar nil
- "Integration of ERC in the Speedbar."
+ "Speedbar integration for ERC.
+To open an ERC-flavored speedbar in a separate frame, run the
+command `erc-speedbar-browser'. To use a window-based proxy
+instead, run \\[erc-nickbar-mode] in a connected ERC buffer or
+put `nickbar' in `erc-modules' before connecting. See Info
+node `(speedbar) Top' for more about the underlying integration."
:group 'erc)
+(defcustom erc-speedbar-nicknames-window-width 18
+ "Default width of the nicknames sidebar (in columns)."
+ :package-version '(ERC . "5.6")
+ :type 'integer)
+
(defcustom erc-speedbar-sort-users-type 'activity
"How channel nicknames are sorted.
@@ -55,6 +67,23 @@ nil - Do not sort users"
(const :tag "Sort users alphabetically" alphabetical)
(const :tag "Do not sort users" nil)))
+(defcustom erc-speedbar-hide-mode-topic 'headerline
+ "Hide mode and topic lines."
+ :package-version '(ERC . "5.6")
+ :type '(choice (const :tag "Always show" nil)
+ (const :tag "Always hide" t)
+ (const :tag "Omit when headerline visible" headerline)))
+
+(defcustom erc-speedbar-my-nick-face t
+ "A face to use for your nickname.
+When the value is t, ERC uses `erc-current-nick-face' if
+`erc-match' has been loaded and `erc-my-nick-face' otherwise.
+When using the `nicks' module, you can see your nick as it
+appears to others by coordinating with the option
+`erc-nicks-skip-faces'."
+ :package-version '(ERC . "5.6")
+ :type '(choice face (const :tag "Current nick or own speaker face" t)))
+
(defvar erc-speedbar-key-map nil
"Keymap used when in erc display mode.")
@@ -87,10 +116,6 @@ nil - Do not sort users"
(looking-at "[0-9]+: *.-. "))])
"Additional menu-items to add to speedbar frame.")
-;; Make sure our special speedbar major mode is loaded
-(with-eval-after-load 'speedbar
- (erc-install-speedbar-variables))
-
;;; ERC hierarchy display method
;;;###autoload
(defun erc-speedbar-browser ()
@@ -98,6 +123,7 @@ nil - Do not sort users"
This will add a speedbar major display mode."
(interactive)
(require 'speedbar)
+ (erc-install-speedbar-variables)
;; Make sure that speedbar is active
(speedbar-frame-mode 1)
;; Now, throw us into Info mode on speedbar.
@@ -109,7 +135,15 @@ This will add a speedbar major display mode."
(erase-buffer)
(let (serverp chanp queryp)
(with-current-buffer buffer
- (setq serverp (erc-server-buffer-p))
+ ;; The function `dframe-help-echo' checks the default value of
+ ;; `dframe-help-echo-function' when deciding whether to visit
+ ;; the buffer and fire the callback. This works in normal
+ ;; speedbar frames because the event handler runs in the
+ ;; `window-buffer' of the active frame. But in our hacked
+ ;; version, where the frame is hidden, `speedbar-item-info'
+ ;; never runs without this workaround.
+ (setq-local dframe-help-echo-function #'ignore)
+ (setq serverp (erc--server-buffer-p))
(setq chanp (erc-channel-p (erc-default-target)))
(setq queryp (erc-query-buffer-p)))
(cond (serverp
@@ -168,18 +202,29 @@ This will add a speedbar major display mode."
t)))))
(defun erc-speedbar-insert-target (buffer depth)
- (if (with-current-buffer buffer
- (erc-channel-p (erc-default-target)))
- (speedbar-make-tag-line
- 'bracket ?+ 'erc-speedbar-expand-channel buffer
- (buffer-name buffer) 'erc-speedbar-goto-buffer buffer nil
- depth)
+ (if (erc--target-channel-p (buffer-local-value 'erc--target buffer))
+ (progn
+ (speedbar-make-tag-line
+ 'bracket ?+ 'erc-speedbar-expand-channel buffer
+ (erc--target-string (buffer-local-value 'erc--target buffer))
+ 'erc-speedbar-goto-buffer buffer nil
+ depth)
+ (save-excursion
+ (forward-line -1)
+ (let ((table (buffer-local-value 'erc-channel-users buffer)))
+ (speedbar-add-indicator (format "(%d)" (hash-table-count table)))
+ (rx "(" (+ (any "0-9")) ")"))))
;; Query target
(speedbar-make-tag-line
nil nil nil nil
(buffer-name buffer) 'erc-speedbar-goto-buffer buffer nil
depth)))
+(defconst erc-speedbar--fmt-sentinel (gensym "erc-speedbar-")
+ "Symbol for identifying a nonstandard `speedbar-token' text property.
+When encountered, ERC assumes the value's tail contains
+`format'-compatible args.")
+
(defun erc-speedbar-expand-channel (text channel indent)
"For the line matching TEXT, in CHANNEL, expand or contract a line.
INDENT is the current indentation level."
@@ -189,36 +234,25 @@ INDENT is the current indentation level."
(speedbar-with-writable
(save-excursion
(end-of-line) (forward-char 1)
- (let ((modes (with-current-buffer channel
- (concat (apply #'concat
- erc-channel-modes)
- (cond
- ((and erc-channel-user-limit
- erc-channel-key)
- (if erc-show-channel-key-p
- (format "lk %.0f %s"
- erc-channel-user-limit
- erc-channel-key)
- (format "kl %.0f" erc-channel-user-limit)))
- (erc-channel-user-limit
- ;; Emacs has no bignums
- (format "l %.0f" erc-channel-user-limit))
- (erc-channel-key
- (if erc-show-channel-key-p
- (format "k %s" erc-channel-key)
- "k"))
- (t "")))))
+ (let ((modes (buffer-local-value 'erc--mode-line-mode-string channel))
(topic (erc-controls-interpret
(with-current-buffer channel erc-channel-topic))))
- (speedbar-make-tag-line
- 'angle ?i nil nil
- (concat "Modes: +" modes) nil nil nil
- (1+ indent))
+ (when modes
+ (speedbar-make-tag-line
+ 'angle ?m nil (list erc-speedbar--fmt-sentinel "Mode: %s" modes)
+ modes nil nil 'erc-notice-face (1+ indent)))
(unless (string= topic "")
(speedbar-make-tag-line
- 'angle ?i nil nil
- (concat "Topic: " topic) nil nil nil
+ 'angle ?t nil (list erc-speedbar--fmt-sentinel "Topic: %s" topic)
+ topic nil nil 'erc-notice-face
(1+ indent)))
+ (unless (pcase erc-speedbar-hide-mode-topic
+ ('nil 'show)
+ ('headerline (null erc-header-line-format)))
+ (save-excursion
+ (goto-char (point-max))
+ (forward-line (if (string= topic "") -1 -2))
+ (put-text-property (pos-bol) (point-max) 'invisible t)))
(let ((names (cond ((eq erc-speedbar-sort-users-type 'alphabetical)
(erc-sort-channel-users-alphabetically
(with-current-buffer channel
@@ -232,17 +266,52 @@ INDENT is the current indentation level."
(when names
(speedbar-with-writable
(dolist (entry names)
- (erc-speedbar-insert-user entry ?+ (1+ indent))))))))))
+ (erc-speedbar-insert-user entry ?+ (1+ indent) channel)))))))))
((string-search "-" text)
(speedbar-change-expand-button-char ?+)
(speedbar-delete-subblock indent))
(t (error "Ooops... not sure what to do")))
(speedbar-center-buffer-smartly))
-(defun erc-speedbar-insert-user (entry exp-char indent)
+(defvar erc-speedbar--nick-face-function #'erc-speedbar--highlight-self-and-ops
+ "Function called when finding a face for fontifying nicks.
+Called with the proposed nick, the `erc-server-user', and the
+`erc-channel-user'. Should return any valid face, possibly
+composed or anonymous, or nil.")
+
+(defun erc-speedbar--highlight-self-and-ops (buffer user cuser)
+ "Highlight own nick and op'd users in the speedbar."
+ (with-current-buffer buffer
+ (if (erc-current-nick-p (erc-server-user-nickname user))
+ (pcase erc-speedbar-my-nick-face
+ ('t (if (facep 'erc-current-nick-face)
+ 'erc-current-nick-face
+ 'erc-my-nick-face))
+ (v v))
+ ;; FIXME overload `erc-channel-user-owner-p' and friends to
+ ;; accept an `erc-channel-user' object and replace this unrolled
+ ;; stuff with a single call to `erc-get-user-mode-prefix'.
+ (and cuser (or (erc-channel-user-owner cuser)
+ (erc-channel-user-admin cuser)
+ (erc-channel-user-op cuser)
+ (erc-channel-user-halfop cuser)
+ (erc-channel-user-voice cuser))
+ erc-button-nickname-face))))
+
+(defun erc-speedbar--on-click (nick sbtoken _indent)
+ ;; 0: finger, 1: name, 2: info, 3: buffer-name
+ (with-current-buffer (nth 3 sbtoken)
+ (erc-nick-popup (string-trim-left nick "[~&@%+]+"))))
+
+(defun erc-speedbar-insert-user (entry exp-char indent &optional buffer)
"Insert one user based on the channel member list ENTRY.
-EXP-CHAR is the expansion character to use.
-INDENT is the current indentation level."
+Expect EXP-CHAR to be the expansion character to use, INDENT the
+current indentation level, and BUFFER the associated channel or
+query buffer. Set the `speedbar-function' text property to
+`erc-speedbar--on-click', which is called with the formatted
+nick, a so-called \"token\", and the indent level. The token is
+a list of four items: the userhost, the GECOS, the current
+`erc-server-user' info slot, and the associated buffer."
(let* ((user (car entry))
(cuser (cdr entry))
(nick (erc-server-user-nickname user))
@@ -250,15 +319,16 @@ INDENT is the current indentation level."
(info (erc-server-user-info user))
(login (erc-server-user-login user))
(name (erc-server-user-full-name user))
- (voice (and cuser (erc-channel-user-voice cuser)))
- (op (and cuser (erc-channel-user-op cuser)))
- (nick-str (concat (if op "@" "") (if voice "+" "") nick))
+ (nick-str (concat (with-current-buffer (or buffer (current-buffer))
+ (erc-get-channel-membership-prefix cuser))
+ nick))
(finger (concat login (when (or login host) "@") host))
- (sbtoken (list finger name info)))
+ (sbtoken (list finger name info (buffer-name buffer))))
(if (or login host name info) ; we want to be expandable
(speedbar-make-tag-line
'bracket ?+ 'erc-speedbar-expand-user sbtoken
- nick-str nil sbtoken nil
+ nick-str #'erc-speedbar--on-click sbtoken
+ (funcall erc-speedbar--nick-face-function buffer user cuser)
indent)
(when (equal exp-char ?-)
(forward-line -1)
@@ -353,9 +423,251 @@ The INDENT level is ignored."
(message "%s: %s" txt (car data)))
((bufferp data)
(message "Channel: %s" txt))
+ ;; Print help if line has a non-standard ([-+?=]) button
+ ;; char and a `speedbar-token' property with a known CAR.
+ ((and-let* ((p (text-property-not-all (pos-bol) (pos-eol)
+ 'speedbar-token nil))
+ (v (get-text-property p 'speedbar-token))
+ ((eq erc-speedbar--fmt-sentinel (car v))))
+ (apply #'message (cdr v))))
(t
(message "%s" txt)))))
+
+;;;; Status-sidebar integration
+
+(defvar erc-track-mode)
+(defvar erc-track--switch-fallback-blockers)
+(defvar erc-status-sidebar-buffer-name)
+(declare-function erc-status-sidebar-set-window-preserve-size
+ "erc-status-sidebar" nil)
+
+(defvar erc-speedbar--buffer-options
+ '((speedbar-update-flag . t)
+ (speedbar-use-images . nil)
+ (speedbar-hide-button-brackets-flag . t)))
+
+(defvar erc-speedbar--hidden-speedbar-frame nil)
+
+(defun erc-speedbar--emulate-sidebar-set-window-preserve-size ()
+ (let ((erc-status-sidebar-buffer-name (buffer-name speedbar-buffer))
+ (display-buffer-overriding-action
+ `(display-buffer-in-side-window
+ . ((side . right)
+ (window-width . ,erc-speedbar-nicknames-window-width)))))
+ (erc-status-sidebar-set-window-preserve-size)))
+
+(defun erc-speedbar--status-sidebar-mode--unhook ()
+ "Remove hooks installed by `erc-status-sidebar-mode'."
+ (remove-hook 'window-configuration-change-hook
+ #'erc-speedbar--emulate-sidebar-set-window-preserve-size))
+
+(defun erc-speedbar--emulate-sidebar ()
+ (require 'erc-status-sidebar)
+ (cl-assert speedbar-frame)
+ (cl-assert (eq speedbar-buffer (current-buffer)))
+ (cl-assert (eq speedbar-frame (selected-frame)))
+ (setq erc-speedbar--hidden-speedbar-frame speedbar-frame
+ ;; In Emacs 27, this is not `local-variable-if-set-p'.
+ dframe-controlled #'erc-speedbar--dframe-controlled)
+ (add-hook 'window-configuration-change-hook
+ #'erc-speedbar--emulate-sidebar-set-window-preserve-size nil t)
+ (add-hook 'kill-buffer-hook
+ #'erc-speedbar--status-sidebar-mode--unhook nil t)
+ (with-current-buffer speedbar-buffer
+ (pcase-dolist (`(,var . ,val) erc-speedbar--buffer-options)
+ (set (make-local-variable var) val)))
+ (when (memq 'nicks erc-modules)
+ (with-current-buffer speedbar-buffer
+ (add-function :around (local 'erc-speedbar--nick-face-function)
+ #'erc-speedbar--compose-nicks-face))))
+
+(defun erc-speedbar--toggle-nicknames-sidebar (arg)
+ (let ((force (numberp arg)))
+ (if speedbar-buffer
+ (progn
+ (cl-assert (buffer-live-p speedbar-buffer))
+ (if (or (and force (< arg 0))
+ (and (not force) (get-buffer-window speedbar-buffer nil)))
+ ;; Close associated windows and stop updating but leave timer.
+ (progn
+ (dolist (window (get-buffer-window-list speedbar-buffer nil t))
+ (unless (frame-root-window-p window)
+ (when erc-speedbar--hidden-speedbar-frame
+ (cl-assert
+ (not (eq (window-frame window)
+ erc-speedbar--hidden-speedbar-frame))))
+ (delete-window window)))
+ (with-current-buffer speedbar-buffer
+ (setq speedbar-update-flag nil)
+ (speedbar-set-mode-line-format)))
+ (when (or (not force) (>= arg 0))
+ (with-selected-frame speedbar-frame
+ (erc-speedbar--emulate-sidebar-set-window-preserve-size)
+ (erc-speedbar-toggle-nicknames-window-lock -1)))))
+ (when-let (((or (not force) (>= arg 0)))
+ (speedbar-frame-parameters (backquote-list*
+ '(visibility . nil)
+ '(no-other-frame . t)
+ speedbar-frame-parameters))
+ (speedbar-after-create-hook #'erc-speedbar--emulate-sidebar))
+ (erc-install-speedbar-variables)
+ ;; Run before toggling mode to prevent timer from being
+ ;; created twice.
+ (speedbar-change-initial-expansion-list "ERC")
+ (speedbar-frame-mode 1)
+ ;; If we put the remaining parts in the "create hook" along
+ ;; with everything else, the frame with `window-main-window'
+ ;; gets raised and steals focus if you've switched away from
+ ;; Emacs in the meantime.
+ (make-frame-invisible speedbar-frame)
+ (select-frame (setq speedbar-frame (previous-frame)))
+ (erc-speedbar--emulate-sidebar-set-window-preserve-size)
+ (erc-speedbar-toggle-nicknames-window-lock -1))))
+ (cl-assert (not (cdr (erc-speedbar--get-timers))) t))
+
+(defun erc-speedbar--ensure (&optional force)
+ (when (or (erc-server-buffer) force)
+ (when erc-track-mode
+ (cl-pushnew '(derived-mode . speedbar-mode)
+ erc-track--switch-fallback-blockers :test #'equal))
+ (unless speedbar-update-flag
+ (erc-button--display-error-notice-with-keys
+ (erc-server-buffer)
+ "Module `nickbar' needs `speedbar-update-flag' to be non-nil"
+ (and (not (display-graphic-p)) " in text terminals")
+ ". Setting to t for the current Emacs session."
+ " Customize it permanently to avoid this message.")
+ (setq speedbar-update-flag t))
+ (erc-speedbar--toggle-nicknames-sidebar +1)
+ (with-current-buffer speedbar-buffer
+ (setq speedbar-update-flag t)
+ (speedbar-set-mode-line-format))))
+
+(defvar erc-speedbar--shutting-down-p nil)
+(defvar erc-speedbar--force-update-interval-secs 5 "Speedbar update period.")
+
+(defvar-local erc-speedbar--last-ran nil
+ "When non-nil, a lisp timestamp updated when the speedbar timer runs.")
+
+(defun erc-speedbar--run-timer-on-post-insert ()
+ "Refresh speedbar if idle for `erc-speedbar--force-update-interval-secs'."
+ (when speedbar-buffer
+ (with-current-buffer speedbar-buffer
+ (when-let
+ ((dframe-timer)
+ ((erc--check-msg-prop 'erc--cmd 'PRIVMSG))
+ (interval erc-speedbar--force-update-interval-secs)
+ ((or (null erc-speedbar--last-ran)
+ (time-less-p erc-speedbar--last-ran
+ (time-subtract (current-time) interval)))))
+ (run-at-time 0 nil #'dframe-timer-fn)))))
+
+(defun erc-speedbar--reset-last-ran-on-timer ()
+ "Reset `erc-speedbar--last-ran'."
+ (when speedbar-buffer
+ (with-suppressed-warnings ((obsolete buffer-local-value)) ; <=29
+ (setf (buffer-local-value 'erc-speedbar--last-ran speedbar-buffer)
+ (current-time)))))
+
+;;;###autoload(autoload 'erc-nickbar-mode "erc-speedbar" nil t)
+(define-erc-module nickbar nil
+ "Show nicknames for current target buffer in a side window.
+When enabling, create a speedbar session if one doesn't exist and
+show its buffer in an `erc-status-sidebar' window instead of a
+separate frame. When disabling, close the window or, with a
+negative prefix arg, destroy the session.
+
+WARNING: this module may produce unwanted side effects, like the
+raising of frames or the stealing of input focus. If you witness
+such a thing and can reproduce it, please file a bug report with
+\\[erc-bug]."
+ ((add-hook 'erc--setup-buffer-hook #'erc-speedbar--ensure)
+ (add-hook 'erc-insert-post-hook #'erc-speedbar--run-timer-on-post-insert)
+ (add-hook 'speedbar-timer-hook #'erc-speedbar--reset-last-ran-on-timer)
+ (erc-speedbar--ensure)
+ (unless (or erc--updating-modules-p
+ (and-let* ((speedbar-buffer)
+ (win (get-buffer-window speedbar-buffer 'all-frames))
+ ((eq speedbar-frame (window-frame win))))))
+ (when-let ((buf (or (and (derived-mode-p 'erc-mode) (current-buffer))
+ (car (erc-buffer-filter #'erc--server-buffer-p)))))
+ (with-current-buffer buf
+ (erc-speedbar--ensure 'force)))))
+ ((remove-hook 'erc--setup-buffer-hook #'erc-speedbar--ensure)
+ (remove-hook 'erc-insert-post-hook #'erc-speedbar--run-timer-on-post-insert)
+ (remove-hook 'speedbar-timer-hook #'erc-speedbar--reset-last-ran-on-timer)
+ (when erc-track-mode
+ (setq erc-track--switch-fallback-blockers
+ (remove '(derived-mode . speedbar-mode)
+ erc-track--switch-fallback-blockers)))
+ (erc-speedbar--toggle-nicknames-sidebar -1)
+ (when-let (((not erc-speedbar--shutting-down-p))
+ (arg erc--module-toggle-prefix-arg)
+ ((numberp arg))
+ ((< arg 0)))
+ (with-current-buffer speedbar-buffer
+ (dframe-close-frame)
+ (setq erc-speedbar--hidden-speedbar-frame nil)))))
+
+(defun erc-speedbar--get-timers ()
+ (cl-remove #'dframe-timer-fn timer-idle-list
+ :key #'timer--function
+ :test-not #'eq))
+
+(defun erc-speedbar--dframe-controlled (arg)
+ (when speedbar-buffer
+ (cl-assert (eq speedbar-buffer (current-buffer))))
+ (when (and erc-speedbar--hidden-speedbar-frame (numberp arg) (< arg 0))
+ (when erc-nickbar-mode
+ (let ((erc-speedbar--shutting-down-p t))
+ (erc-nickbar-mode -1)))
+ (setq speedbar-frame erc-speedbar--hidden-speedbar-frame
+ erc-speedbar--hidden-speedbar-frame nil)
+ ;; It's unknown whether leaving the frame invisible interferes
+ ;; with the upstream teardown sequence.
+ (when (display-graphic-p)
+ (make-frame-visible speedbar-frame))
+ (speedbar-frame-mode arg) ; -1
+ ;; As of Emacs 29, `dframe-set-timer' can't remove `dframe-timer'.
+ (cl-assert (= 1 (length (erc-speedbar--get-timers))) t)
+ (cancel-function-timers #'dframe-timer-fn)
+ ;; `dframe-close-frame' kills the buffer but no function in
+ ;; erc-speedbar.el resets this to nil.
+ (setq speedbar-buffer nil)))
+
+(defun erc-speedbar-toggle-nicknames-window-lock (arg)
+ "Toggle whether nicknames window is selectable with \\[other-window].
+When arg is a number, lock the window if non-negative, otherwise
+unlock."
+ (interactive "P")
+ (unless erc-nickbar-mode
+ (user-error "`erc-nickbar-mode' inactive"))
+ (when-let ((window (get-buffer-window speedbar-buffer)))
+ (let ((val (cond ((natnump arg) t)
+ ((integerp arg) nil)
+ (t (not (window-parameter window
+ 'no-other-window))))))
+ (set-window-parameter window 'no-other-window val)
+ (unless (numberp arg)
+ (message "nick-window: %s" (if val "protected" "selectable"))))))
+
+
+;;;; Nicks integration
+
+(declare-function erc-nicks--highlight "erc-nicks" (nickname &optional face))
+
+(defun erc-speedbar--compose-nicks-face (orig buffer user cuser)
+ (require 'erc-nicks)
+ (let ((rv (funcall orig buffer user cuser)))
+ (if-let ((nick (erc-server-user-nickname user))
+ (face (with-current-buffer buffer
+ (erc-nicks--highlight nick rv)))
+ ((not (eq face erc-button-nickname-face))))
+ (cons face (ensure-list rv))
+ rv)))
+
+
(provide 'erc-speedbar)
;;; erc-speedbar.el ends here
;;
diff --git a/lisp/erc/erc-spelling.el b/lisp/erc/erc-spelling.el
index f7162d54549..b2f565d71bf 100644
--- a/lisp/erc/erc-spelling.el
+++ b/lisp/erc/erc-spelling.el
@@ -33,14 +33,19 @@
(require 'erc)
(require 'flyspell)
+(defgroup erc-spelling nil
+ "Flyspell integration for ERC."
+ :group 'erc)
+
;;;###autoload(autoload 'erc-spelling-mode "erc-spelling" nil t)
(define-erc-module spelling nil
"Enable flyspell mode in ERC buffers."
;; Use erc-connect-pre-hook instead of erc-mode-hook as pre-hook is
;; called AFTER the server buffer is initialized.
((add-hook 'erc-connect-pre-hook #'erc-spelling-init)
- (dolist (buffer (erc-buffer-list))
- (erc-spelling-init buffer)))
+ (unless erc--updating-modules-p
+ (erc-with-all-buffers-of-server nil nil
+ (erc-spelling-init (current-buffer)))))
((remove-hook 'erc-connect-pre-hook #'erc-spelling-init)
(dolist (buffer (erc-buffer-list))
(with-current-buffer buffer (flyspell-mode 0)))))
diff --git a/lisp/erc/erc-stamp.el b/lisp/erc/erc-stamp.el
index ebee40364da..bcb9b4aafef 100644
--- a/lisp/erc/erc-stamp.el
+++ b/lisp/erc/erc-stamp.el
@@ -56,19 +56,24 @@ If nil, timestamping is turned off."
(string)))
(defcustom erc-timestamp-format-left "\n[%a %b %e %Y]\n"
- "If set to a string, messages will be timestamped.
-This string is processed using `format-time-string'.
-Good examples are \"%T\" and \"%H:%M\".
-
-This timestamp is used for timestamps on the left side of the
-screen when `erc-insert-timestamp-function' is set to
-`erc-insert-timestamp-left-and-right'.
-
-If nil, timestamping is turned off."
- :type '(choice (const nil)
- (string)))
+ "Format recognized by `format-time-string' for date stamps.
+Only considered when `erc-insert-timestamp-function' is set to
+`erc-insert-timestamp-left-and-right'. Used for displaying date
+stamps on their own line, between messages. ERC inserts this
+flavor of stamp as a separate \"pseudo message\", so a final
+newline isn't necessary. For compatibility, only additional
+trailing newlines beyond the first become empty lines. For
+example, the default value results in an empty line after the
+previous message, followed by the timestamp on its own line,
+followed immediately by the next message on the next line. ERC
+expects to display these stamps less frequently, so the
+formatting specifiers should reflect that. To omit these stamps
+entirely, use a different `erc-insert-timestamp-function', such
+as `erc-timestamp-format-right'. Note that changing this value
+during an ERC session requires cycling `erc-stamp-mode'."
+ :type 'string)
-(defcustom erc-timestamp-format-right " [%H:%M]"
+(defcustom erc-timestamp-format-right nil
"If set to a string, messages will be timestamped.
This string is processed using `format-time-string'.
Good examples are \"%T\" and \"%H:%M\".
@@ -77,9 +82,14 @@ This timestamp is used for timestamps on the right side of the
screen when `erc-insert-timestamp-function' is set to
`erc-insert-timestamp-left-and-right'.
-If nil, timestamping is turned off."
+Unlike `erc-timestamp-format' and `erc-timestamp-format-left', if
+the value of this option is nil, it falls back to using the value
+of `erc-timestamp-format'."
+ :package-version '(ERC . "5.6")
:type '(choice (const nil)
(string)))
+(make-obsolete-variable 'erc-timestamp-format-right
+ 'erc-timestamp-format "30.1")
(defcustom erc-insert-timestamp-function 'erc-insert-timestamp-left-and-right
"Function to use to insert timestamps.
@@ -128,14 +138,28 @@ hidden, they will still be present in the logs."
"If non-nil, print timestamp in the minibuffer when point is moved.
Using this variable, you can turn off normal timestamping,
and simply move point to an irc message to see its timestamp
-printed in the minibuffer."
+printed in the minibuffer. When attempting to enable this option
+after `erc-stamp-mode' is already active, you may need to run the
+command `erc-show-timestamps' (or `erc-hide-timestamps') in the
+appropriate ERC buffer before the change will take effect."
:type 'boolean)
(defcustom erc-echo-timestamp-format "Timestamped %A, %H:%M:%S"
"Format string to be used when `erc-echo-timestamps' is non-nil.
This string specifies the format of the timestamp being echoed in
the minibuffer."
- :type 'string)
+ :type '(choice (const :tag "Timestamped Monday, 15:04:05"
+ "Timestamped %A, %H:%M:%S")
+ (const :tag "2006-01-02 15:04:05 MST" "%F %T %Z")
+ string))
+
+(defcustom erc-echo-timestamp-zone nil
+ "Default timezone for the option `erc-echo-timestamps'.
+Also affects the command `erc-echo-timestamp' (singular). See
+the ZONE parameter of `format-time-string' for a description of
+acceptable value types."
+ :type '(choice boolean number (const wall) (list number string))
+ :package-version '(ERC . "5.6"))
(defcustom erc-timestamp-intangible nil
"Whether the timestamps should be intangible, i.e. prevent the point
@@ -147,39 +171,107 @@ from entering them and instead jump over them."
"ERC timestamp face."
:group 'erc-faces)
+;; New libraries should only autoload the minor mode for a module's
+;; preferred name (rather than its alias).
+
+;;;###autoload(put 'timestamp 'erc--module 'stamp)
;;;###autoload(autoload 'erc-timestamp-mode "erc-stamp" nil t)
(define-erc-module stamp timestamp
"This mode timestamps messages in the channel buffers."
- ((add-hook 'erc-mode-hook #'erc-munge-invisibility-spec)
- (add-hook 'erc-insert-modify-hook #'erc-add-timestamp t)
- (add-hook 'erc-send-modify-hook #'erc-add-timestamp t))
- ((remove-hook 'erc-mode-hook #'erc-munge-invisibility-spec)
+ ((add-hook 'erc-mode-hook #'erc-stamp--setup)
+ (add-hook 'erc-insert-modify-hook #'erc-add-timestamp 70)
+ (add-hook 'erc-send-modify-hook #'erc-add-timestamp 70)
+ (add-hook 'erc-mode-hook #'erc-stamp--recover-on-reconnect)
+ (add-hook 'erc--pre-clear-functions #'erc-stamp--reset-on-clear 40)
+ (unless erc--updating-modules-p (erc-buffer-do #'erc-stamp--setup)))
+ ((remove-hook 'erc-mode-hook #'erc-stamp--setup)
(remove-hook 'erc-insert-modify-hook #'erc-add-timestamp)
- (remove-hook 'erc-send-modify-hook #'erc-add-timestamp)))
+ (remove-hook 'erc-send-modify-hook #'erc-add-timestamp)
+ (remove-hook 'erc-mode-hook #'erc-stamp--recover-on-reconnect)
+ (remove-hook 'erc--pre-clear-functions #'erc-stamp--reset-on-clear)
+ (erc-buffer-do #'erc-stamp--setup)))
+
+(defvar erc-stamp--invisible-property nil
+ "Existing `invisible' property value and/or symbol `timestamp'.")
+
+(defvar erc-stamp--skip-when-invisible nil
+ "Escape hatch for omitting stamps when first char is invisible.")
+
+(defun erc-stamp--recover-on-reconnect ()
+ "Attempt to restore \"last-inserted\" snapshots from prior session."
+ (when-let ((priors (or erc--server-reconnecting erc--target-priors)))
+ (dolist (var '(erc-timestamp-last-inserted
+ erc-timestamp-last-inserted-left
+ erc-timestamp-last-inserted-right))
+ (when-let (existing (alist-get var priors))
+ (set var existing)))))
+
+(defvar erc-stamp--current-time nil
+ "The current time when calling `erc-insert-timestamp-function'.
+Specifically, this is the same lisp time object used to create
+the stamp passed to `erc-insert-timestamp-function'.")
+
+(cl-defgeneric erc-stamp--current-time ()
+ "Return a lisp time object to associate with an IRC message.
+This becomes the message's `erc--ts' text property."
+ (erc-compat--current-lisp-time))
+
+(cl-defmethod erc-stamp--current-time :around ()
+ (or erc-stamp--current-time (cl-call-next-method)))
+
+(defvar erc-stamp--skip nil
+ "Non-nil means inhibit `erc-add-timestamp' completely.")
+
+(defvar erc-stamp--allow-unmanaged nil
+ "Non-nil means run `erc-add-timestamp' almost unconditionally.
+This is an unofficial escape hatch for code wanting to use
+lower-level message-insertion functions, like `erc-insert-line',
+directly. Third parties needing such functionality should
+petition for it via \\[erc-bug].")
+
+(defvar erc-stamp--permanent-cursor-sensor-functions nil
+ "Non-nil means add `cursor-sensor-functions' unconditionally.
+This is an unofficial escape hatch for code wanting the text
+property `cursor-sensor-functions' to always be present,
+regardless of the option `erc-echo-timestamps'. Third parties
+needing such pre-5.6 behavior to stick around should make that
+known via \\[erc-bug].")
(defun erc-add-timestamp ()
"Add timestamp and text-properties to message.
This function is meant to be called from `erc-insert-modify-hook'
or `erc-send-modify-hook'."
- (unless (get-text-property (point) 'invisible)
- (let ((ct (current-time)))
- (if (fboundp erc-insert-timestamp-function)
- (funcall erc-insert-timestamp-function
- (erc-format-timestamp ct erc-timestamp-format))
- (error "Timestamp function unbound"))
- (when (and (fboundp erc-insert-away-timestamp-function)
- erc-away-timestamp-format
- (erc-away-time)
- (not erc-timestamp-format))
+ (unless (or erc-stamp--skip (and (not erc-stamp--allow-unmanaged)
+ (null erc--msg-props)))
+ (let* ((ct (erc-stamp--current-time))
+ (invisible (get-text-property (point-min) 'invisible))
+ (erc-stamp--invisible-property
+ ;; FIXME on major version bump, make this `erc-' prefixed.
+ (if invisible `(timestamp ,@(ensure-list invisible)) 'timestamp))
+ (skipp (or (and erc-stamp--skip-when-invisible invisible)
+ (erc--check-msg-prop 'erc--ephemeral)))
+ (erc-stamp--current-time ct))
+ (when erc--msg-props
+ (puthash 'erc--ts ct erc--msg-props))
+ (unless skipp
+ (funcall erc-insert-timestamp-function
+ (erc-format-timestamp ct erc-timestamp-format)))
+ ;; Check `erc-insert-away-timestamp-function' for historical
+ ;; reasons even though its Custom :type only allows functions.
+ (when (and (not (or skipp erc-timestamp-format))
+ erc-away-timestamp-format
+ (functionp erc-insert-away-timestamp-function)
+ (erc-away-time))
(funcall erc-insert-away-timestamp-function
(erc-format-timestamp ct erc-away-timestamp-format)))
- (add-text-properties (point-min) (point-max)
+ (when erc-stamp--permanent-cursor-sensor-functions
+ (add-text-properties (point-min) (max (point-min) (1- (point-max)))
;; It's important for the function to
;; be different on different entries (bug#22700).
(list 'cursor-sensor-functions
- (list (lambda (_window _before dir)
- (erc-echo-timestamp dir ct))))))))
+ ;; Regions are no longer contiguous ^
+ '(erc--echo-ts-csf) 'erc--ts ct))))))
(defvar-local erc-timestamp-last-window-width nil
"The width of the last window that showed the current buffer.
@@ -190,9 +282,11 @@ buffer is not shown in any window.")
"Last timestamp inserted into the buffer.")
(defvar-local erc-timestamp-last-inserted-left nil
- "Last timestamp inserted into the left side of the buffer.
-This is used when `erc-insert-timestamp-function' is set to
-`erc-timestamp-left-and-right'")
+ "Last \"date stamp\" inserted into the left side of the buffer.
+Used when `erc-insert-timestamp-function' is set to
+`erc-timestamp-left-and-right'. If the format string specified
+by `erc-timestamp-format-left' includes trailing newlines, this
+value omits the last one.")
(defvar-local erc-timestamp-last-inserted-right nil
"Last timestamp inserted into the right side of the buffer.
@@ -217,17 +311,213 @@ the correct column."
(integer :tag "Column number")
(const :tag "Unspecified" nil)))
-(defcustom erc-timestamp-use-align-to (eq window-system 'x)
+(defcustom erc-timestamp-use-align-to (and (display-graphic-p) t)
"If non-nil, use the :align-to display property to align the stamp.
This gives better results when variable-width characters (like
Asian language characters and math symbols) precede a timestamp.
-A side effect of enabling this is that there will only be one
-space before a right timestamp in any saved logs."
- :type 'boolean)
+This option only matters when `erc-insert-timestamp-function' is
+set to `erc-insert-timestamp-right' or that option's default,
+`erc-insert-timestamp-left-and-right'. If the value is a
+positive integer, alignment occurs that many columns from the
+right edge.
+
+Enabling this option produces a side effect in that stamps aren't
+indented in saved logs. When its value is an integer, this
+option adds a space after the end of a message if the stamp
+doesn't already start with one. And when its value is t, it adds
+a single space, unconditionally."
+ :type '(choice boolean integer)
+ :package-version '(ERC . "5.6"))
+
+(defvar-local erc-stamp--margin-width nil
+ "Width in columns of margin for `erc-stamp--display-margin-mode'.
+Only consulted when resetting or initializing margin.")
+
+(defvar-local erc-stamp--margin-left-p nil
+ "Whether `erc-stamp--display-margin-mode' uses the left margin.
+During initialization, the mode respects this variable's existing
+value if it already has a local binding. Otherwise, modules can
+bind this to any value while enabling the mode. If it's nil, ERC
+will check to see if `erc-insert-timestamp-function' is
+`erc-insert-timestamp-left', interpreting the latter as a non-nil
+value. It'll then coerce any non-nil value to t.")
+
+(defun erc-stamp--init-margins-on-connect (&rest _)
+ (let ((existing (if erc-stamp--margin-left-p
+ left-margin-width
+ right-margin-width)))
+ (erc-stamp--adjust-margin existing 'resetp)))
+
+(defun erc-stamp--adjust-margin (cols &optional resetp)
+ "Adjust managed margin by increment COLS.
+With RESETP, set margin's width to COLS. However, if COLS is
+zero, set the width to a non-nil `erc-stamp--margin-width'.
+Otherwise, go with the `string-width' of `erc-timestamp-format'.
+However, when `erc-stamp--margin-left-p' is non-nil and the
+prompt is wider, use its width instead."
+ (let* ((leftp erc-stamp--margin-left-p)
+ (width
+ (if resetp
+ (or (and (not (zerop cols)) cols)
+ erc-stamp--margin-width
+ (max (if leftp
+ (cond ((fboundp 'erc-fill--wrap-measure)
+ (let* ((b erc-insert-marker)
+ (e (1- erc-input-marker))
+ (w (erc-fill--wrap-measure b e)))
+ (/ (if (consp w) (car w) w)
+ (frame-char-width))))
+ ((fboundp 'string-pixel-width)
+ (/ (string-pixel-width (erc-prompt))
+ (frame-char-width)))
+ (t (string-width (erc-prompt))))
+ 0)
+ (1+ (string-width
+ (or (if leftp
+ erc-timestamp-last-inserted
+ erc-timestamp-last-inserted-right)
+ (erc-format-timestamp
+ (current-time) erc-timestamp-format))))))
+ (+ (if leftp left-margin-width right-margin-width) cols))))
+ (set (if leftp 'left-margin-width 'right-margin-width) width)
+ (when (eq (current-buffer) (window-buffer))
+ (set-window-margins nil
+ (if leftp width left-margin-width)
+ (if leftp right-margin-width width)))))
+
+;;;###autoload
+(defun erc-stamp-prefix-log-filter (text)
+ "Prefix every message in the buffer with a stamp.
+Remove trailing stamps as well. For now, hard code the format to
+\"ZNC\"-log style, which is [HH:MM:SS]. Expect to be used as a
+`erc-log-filter-function' when `erc-timestamp-use-align-to' is
+non-nil."
+ (insert text)
+ (goto-char (point-min))
+ (while
+ (progn
+ (when-let (((< (point) (pos-eol)))
+ (end (1- (pos-eol)))
+ ((eq 'erc-timestamp (field-at-pos end)))
+ (beg (field-beginning end))
+ ;; Skip a line that's just a timestamp.
+ ((> beg (point))))
+ (delete-region beg (1+ end)))
+ (when-let (time (erc--get-inserted-msg-prop 'erc--ts))
+ (insert (format-time-string "[%H:%M:%S] " time)))
+ (zerop (forward-line))))
+ "")
+
+;; These are currently extended manually, but we could also bind
+;; `text-property-default-nonsticky' and call `insert-and-inherit'
+;; instead of `insert', but we'd have to pair the props with differing
+;; boolean values for left and right stamps. Also, since this hook
+;; runs last, we can't expect overriding sticky props to be absent,
+;; even though, as of 5.6, `front-sticky' is only added by the
+;; `readonly' module after hooks run.
+(defvar erc-stamp--inherited-props '(line-prefix wrap-prefix)
+ "Extant properties at the start of a message inherited by the stamp.")
+
+(defvar-local erc-stamp--skip-left-margin-prompt-p nil
+ "Don't display prompt in left margin.")
+
+(declare-function erc--remove-text-properties "erc" (string))
+
+;; Currently, `erc-insert-timestamp-right' hard codes its display
+;; property to use `right-margin', and `erc-insert-timestamp-left'
+;; does the same for `left-margin'. However, there's no reason a
+;; trailing stamp couldn't be displayed on the left and vice versa.
+(define-minor-mode erc-stamp--display-margin-mode
+ "Internal minor mode for built-in modules integrating with `stamp'.
+Arranges for displaying stamps in a single margin, with the
+variable `erc-stamp--margin-left-p' controlling which one.
+Provides `erc-stamp--margin-width' and `erc-stamp--adjust-margin'
+to help manage the chosen margin's width. Also removes `display'
+properties in killed text to reveal stamps. The invoking module
+should set controlling variables, like `erc-stamp--margin-width'
+and `erc-stamp--margin-left-p', before activating the mode."
+ :interactive nil
+ (if erc-stamp--display-margin-mode
+ (progn
+ (setq fringes-outside-margins t)
+ (when (eq (current-buffer) (window-buffer))
+ (set-window-buffer (selected-window) (current-buffer)))
+ (setq erc-stamp--margin-left-p (and erc-stamp--margin-left-p t))
+ (if (or erc-server-connected (not (functionp erc-prompt)))
+ (erc-stamp--init-margins-on-connect)
+ (add-hook 'erc-after-connect
+ #'erc-stamp--init-margins-on-connect nil t))
+ (add-function :filter-return (local 'filter-buffer-substring-function)
+ #'erc--remove-text-properties)
+ (add-hook 'erc--setup-buffer-hook
+ #'erc-stamp--refresh-left-margin-prompt nil t)
+ (when (and erc-stamp--margin-left-p
+ (not erc-stamp--skip-left-margin-prompt-p))
+ (add-hook 'erc--refresh-prompt-hook
+ #'erc-stamp--display-prompt-in-left-margin nil t)))
+ (remove-function (local 'filter-buffer-substring-function)
+ #'erc--remove-text-properties)
+ (remove-hook 'erc-after-connect
+ #'erc-stamp--init-margins-on-connect t)
+ (remove-hook 'erc--refresh-prompt-hook
+ #'erc-stamp--display-prompt-in-left-margin t)
+ (remove-hook 'erc--setup-buffer-hook
+ #'erc-stamp--refresh-left-margin-prompt t)
+ (kill-local-variable (if erc-stamp--margin-left-p
+ 'left-margin-width
+ 'right-margin-width))
+ (kill-local-variable 'erc-stamp--skip-left-margin-prompt-p)
+ (kill-local-variable 'fringes-outside-margins)
+ (kill-local-variable 'erc-stamp--margin-left-p)
+ (kill-local-variable 'erc-stamp--margin-width)
+ (when (eq (current-buffer) (window-buffer))
+ (set-window-margins nil left-margin-width nil)
+ (set-window-buffer (selected-window) (current-buffer)))))
+
+(defvar-local erc-stamp--last-prompt nil)
+
+(defun erc-stamp--display-prompt-in-left-margin ()
+ "Show prompt in the left margin with padding."
+ (when (or (not erc-stamp--last-prompt) (functionp erc-prompt)
+ (> (string-width erc-stamp--last-prompt) left-margin-width))
+ (let ((s (buffer-substring erc-insert-marker (1- erc-input-marker))))
+ ;; Prevent #("abc" n m (display ((...) #("abc" p q (display...))))
+ (remove-text-properties 0 (length s) '(display nil) s)
+ (when (and erc-stamp--last-prompt
+ (>= (string-width erc-stamp--last-prompt) left-margin-width))
+ (let ((sm (truncate-string-to-width s (1- left-margin-width) 0 nil t)))
+ ;; This papers over a subtle off-by-1 bug here.
+ (unless (equal sm s)
+ (setq s (concat sm (substring s -1))))))
+ (setq erc-stamp--last-prompt (string-pad s left-margin-width nil t))))
+ (put-text-property erc-insert-marker (1- erc-input-marker)
+ 'display `((margin left-margin) ,erc-stamp--last-prompt))
+ erc-stamp--last-prompt)
+
+(defun erc-stamp--refresh-left-margin-prompt ()
+ "Forcefully-recompute display property of prompt in left margin."
+ (with-silent-modifications
+ (unless (functionp erc-prompt)
+ (setq erc-stamp--last-prompt nil))
+ (erc--refresh-prompt)))
+
+(cl-defmethod erc--conceal-prompt
+ (&context (erc-stamp--display-margin-mode (eql t))
+ (erc-stamp--margin-left-p (eql t))
+ (erc-stamp--skip-left-margin-prompt-p null))
+ (when-let (((null erc--hidden-prompt-overlay))
+ (prompt (string-pad erc-prompt-hidden left-margin-width nil 'start))
+ (ov (make-overlay erc-insert-marker (1- erc-input-marker)
+ nil 'front-advance)))
+ (overlay-put ov 'display `((margin left-margin) ,prompt))
+ (setq erc--hidden-prompt-overlay ov)))
(defun erc-insert-timestamp-left (string)
"Insert timestamps at the beginning of the line."
+ (erc--insert-timestamp-left string))
+
+(cl-defmethod erc--insert-timestamp-left (string)
(goto-char (point-min))
(let* ((ignore-p (and erc-timestamp-only-if-changed-flag
(string-equal string erc-timestamp-last-inserted)))
@@ -235,14 +525,30 @@ space before a right timestamp in any saved logs."
(s (if ignore-p (make-string len ? ) string)))
(unless ignore-p (setq erc-timestamp-last-inserted string))
(erc-put-text-property 0 len 'field 'erc-timestamp s)
- (erc-put-text-property 0 len 'invisible 'timestamp s)
+ (erc-put-text-property 0 len 'invisible erc-stamp--invisible-property s)
(insert s)))
+(cl-defmethod erc--insert-timestamp-left
+ (string &context (erc-stamp--display-margin-mode (eql t)))
+ (unless (and erc-timestamp-only-if-changed-flag
+ (string-equal string erc-timestamp-last-inserted))
+ (goto-char (point-min))
+ (insert-and-inherit (setq erc-timestamp-last-inserted string))
+ (dolist (p erc-stamp--inherited-props)
+ (when-let ((v (get-text-property (point) p)))
+ (put-text-property (point-min) (point) p v)))
+ (erc-put-text-property (point-min) (point) 'invisible
+ erc-stamp--invisible-property)
+ (put-text-property (point-min) (point) 'field 'erc-timestamp)
+ (put-text-property (point-min) (point)
+ 'display `((margin left-margin) ,string))))
+
(defun erc-insert-aligned (string pos)
"Insert STRING at the POSth column.
If `erc-timestamp-use-align-to' is t, use the :align-to display
property to get to the POSth column."
+ (declare (obsolete "inlined and removed from client code path" "30.1"))
(if (not erc-timestamp-use-align-to)
(indent-to pos)
(insert " ")
@@ -253,6 +559,12 @@ property to get to the POSth column."
;; Silence byte-compiler
(defvar erc-fill-column)
+(defvar erc-stamp--omit-properties-on-folded-lines nil
+ "Skip properties before right stamps occupying their own line.
+This escape hatch restores pre-5.6 behavior that left leading
+white space alone (unpropertized) for right-sided stamps folded
+onto their own line.")
+
(defun erc-insert-timestamp-right (string)
"Insert timestamp on the right side of the screen.
STRING is the timestamp to insert. This function is a possible
@@ -280,6 +592,7 @@ printed just after each line's text (no alignment)."
(goto-char (point-max))
(forward-char -1) ; before the last newline
(let* ((str-width (string-width string))
+ (buffer-invisibility-spec nil) ; `current-column' > 0
window ; used in computation of `pos' only
(pos (cond
(erc-timestamp-right-column erc-timestamp-right-column)
@@ -304,31 +617,200 @@ printed just after each line's text (no alignment)."
;; some margin of error if what is displayed on the line differs
;; from the number of characters on the line.
(setq col (+ col (ceiling (/ (- col (- (point) (line-beginning-position))) 1.6))))
- (if (< col pos)
- (erc-insert-aligned string pos)
- (newline)
- (indent-to pos)
- (setq from (point))
- (insert string))
+ ;; For compatibility reasons, the `erc-timestamp' field includes
+ ;; intervening white space unless a hard break is warranted.
+ (pcase erc-timestamp-use-align-to
+ ((guard erc-stamp--display-margin-mode)
+ (let ((s (propertize (substring-no-properties string)
+ 'invisible erc-stamp--invisible-property)))
+ (insert " ")
+ (put-text-property 0 (length string) 'display
+ `((margin right-margin) ,s)
+ string)))
+ ((and 't (guard (< col pos)))
+ (insert " ")
+ (put-text-property from (point) 'display `(space :align-to ,pos)))
+ ((pred integerp) ; (cl-type (integer 0 *))
+ (insert " ")
+ (when (eq ?\s (aref string 0))
+ (setq string (substring string 1)))
+ (let ((s (+ erc-timestamp-use-align-to (string-width string))))
+ (put-text-property from (point) 'display
+ `(space :align-to (- right ,s)))))
+ ((guard (>= col pos)) (newline) (indent-to pos)
+ (when erc-stamp--omit-properties-on-folded-lines (setq from (point))))
+ (_ (indent-to pos)))
+ (insert string)
+ (dolist (p erc-stamp--inherited-props)
+ (when-let ((v (get-text-property (1- from) p)))
+ (put-text-property from (point) p v)))
(erc-put-text-property from (point) 'field 'erc-timestamp)
(erc-put-text-property from (point) 'rear-nonsticky t)
+ (erc-put-text-property from (point) 'invisible
+ erc-stamp--invisible-property)
(when erc-timestamp-intangible
(erc-put-text-property from (1+ (point)) 'cursor-intangible t)))))
-(defun erc-insert-timestamp-left-and-right (_string)
- "This is another function that can be used with `erc-insert-timestamp-function'.
-If the date is changed, it will print a blank line, the date, and
-another blank line. If the time is changed, it will then print
-it off to the right."
- (let* ((ct (current-time))
- (ts-left (erc-format-timestamp ct erc-timestamp-format-left))
- (ts-right (erc-format-timestamp ct erc-timestamp-format-right)))
- ;; insert left timestamp
- (unless (string-equal ts-left erc-timestamp-last-inserted-left)
+(defvar erc-stamp--insert-date-hook nil
+ "Functions appended to send and modify hooks when inserting date stamp.")
+
+(defvar-local erc-stamp--date-format-end nil
+ "Tristate value indicating how and whether date stamps have been set up.
+A non-nil value means the buffer has been initialized to use date
+stamps. An integer marks the `substring' TO parameter for
+truncating `erc-timestamp-format-left' prior to rendering. A
+value of t means the option's value doesn't require trimming.")
+
+(defun erc-stamp--propertize-left-date-stamp ()
+ (add-text-properties (point-min) (1- (point-max)) '(field erc-timestamp))
+ (erc--hide-message 'timestamp)
+ (run-hooks 'erc-stamp--insert-date-hook))
+
+(defun erc-stamp--format-date-stamp (ct)
+ "Format left date stamp with `erc-timestamp-format-left'."
+ (unless erc-stamp--date-format-end
+ ;; Don't add text properties to the trailing newline.
+ (setq erc-stamp--date-format-end
+ (if (string-suffix-p "\n" erc-timestamp-format-left) -1 t)))
+ ;; Ignore existing `invisible' prop value because date stamps should
+ ;; never be hideable except via `timestamp'.
+ (let (erc-stamp--invisible-property)
+ (erc-format-timestamp ct (if (numberp erc-stamp--date-format-end)
+ (substring erc-timestamp-format-left
+ 0 erc-stamp--date-format-end)
+ erc-timestamp-format-left))))
+
+(defun erc-stamp-inserting-date-stamp-p ()
+ "Return non-nil if the narrowed buffer contains a date stamp.
+Expect to be called by members of `erc-insert-modify-hook' and
+`erc-insert-post-hook' to detect whether the message being
+inserted is a date stamp."
+ (erc--check-msg-prop 'erc--msg 'datestamp))
+
+;; Calling `erc-display-message' from within a hook it's currently
+;; running is roundabout, but it's a definite means of ensuring hooks
+;; can act on the date stamp as a standalone message to do things like
+;; adjust invisibility props.
+(defun erc-stamp--insert-date-stamp-as-phony-message (string)
+ (cl-assert (string-empty-p string))
+ (setq string erc-timestamp-last-inserted-left)
+ (let ((erc-stamp--skip t)
+ (erc-insert-modify-hook `(,@erc-insert-modify-hook
+ erc-stamp--propertize-left-date-stamp))
+ (erc--insert-line-function #'insert-before-markers)
+ ;; Don't run hooks that aren't expecting a narrowed buffer.
+ (erc-insert-pre-hook nil)
+ (erc-insert-done-hook nil))
+ (erc-display-message nil nil (current-buffer) string)))
+
+(defun erc-stamp--lr-date-on-pre-modify (_)
+ (when-let (((not erc-stamp--skip))
+ (ct (erc-stamp--current-time))
+ (rendered (erc-stamp--format-date-stamp ct))
+ ((not (string-equal rendered erc-timestamp-last-inserted-left)))
+ (erc-insert-timestamp-function
+ #'erc-stamp--insert-date-stamp-as-phony-message))
+ (save-excursion
+ (save-restriction
+ (narrow-to-region (or erc--insert-marker erc-insert-marker)
+ (or erc--insert-marker erc-insert-marker))
+ ;; Ensure all hooks, like `erc-stamp--insert-date-hook', only
+ ;; see the let-bound value below during `erc-add-timestamp'.
+ (setq erc-timestamp-last-inserted-left nil)
+ (let* ((aligned (erc-stamp--time-as-day ct))
+ (erc-stamp--current-time aligned)
+ ;; Forget current `erc--cmd', etc.
+ (erc--msg-props (map-into `((erc--msg . datestamp))
+ 'hash-table))
+ (erc-timestamp-last-inserted-left rendered)
+ erc-timestamp-format erc-away-timestamp-format)
+ (erc-add-timestamp))
+ (setq erc-timestamp-last-inserted-left rendered)))))
+
+;; This minor mode is just a placeholder and currently unhelpful for
+;; managing complexity. A useful version would leave a marker during
+;; post-modify hooks and then perform insertions (before markers)
+;; during "done" hooks. This would enable completely decoupling from
+;; and possibly deprecating `erc-insert-timestamp-left-and-right'.
+;; However, doing this would require expanding the internal API to
+;; include insertion and deletion handlers for twiddling and massaging
+;; text properties based on context immediately after modifying text
+;; earlier in a buffer (away from `erc-insert-marker'). Without such
+;; handlers, things like "merged" `fill-wrap' speakers and invisible
+;; messages may be damaged by buffer modifications.
+(define-minor-mode erc-stamp--date-mode
+ "Insert date stamps as standalone messages."
+ :interactive nil
+ (if erc-stamp--date-mode
+ (progn (add-hook 'erc-insert-pre-hook
+ #'erc-stamp--lr-date-on-pre-modify 10 t)
+ (add-hook 'erc-pre-send-functions
+ #'erc-stamp--lr-date-on-pre-modify 10 t))
+ (kill-local-variable 'erc-timestamp-last-inserted-left)
+ (remove-hook 'erc-insert-pre-hook
+ #'erc-stamp--lr-date-on-pre-modify t)
+ (remove-hook 'erc-pre-send-functions
+ #'erc-stamp--lr-date-on-pre-modify t)))
+
+(defvar erc-stamp-prepend-date-stamps-p nil
+ "When non-nil, date stamps are not independent messages.
+This flag restores pre-5.6 behavior in which date stamps formed
+the leading portion of affected messages. Beware that enabling
+this degrades the user experience by causing 5.6+ features, like
+`fill-wrap', dynamic invisibility, etc., to malfunction. When
+non-nil, none of the newline twiddling mentioned in the doc
+string for `erc-timestamp-format-left' occurs. That is, ERC does
+not append or remove trailing newlines.")
+(make-obsolete-variable 'erc-stamp-prepend-date-stamps-p
+ "unsupported legacy behavior" "30.1")
+
+(defun erc-insert-timestamp-left-and-right (string)
+ "Insert a stamp on either side when it changes.
+When the deprecated option `erc-timestamp-format-right' is nil,
+use STRING, which originates from `erc-timestamp-format', for the
+right-hand stamp. Use `erc-timestamp-format-left' for formatting
+the left-sided \"date stamp,\" and expect it to change less
+frequently. Include all but the final trailing newline present
+in the latter (if any) as part of the `erc-timestamp' field.
+Allow the stamp's `invisible' property to span that same interval
+but also cover the previous newline, in order to satisfy folding
+requirements related to `erc-legacy-invisible-bounds-p'.
+Additionally, ensure every date stamp is identifiable as such so
+that internal modules can easily distinguish between other
+left-sided stamps and date stamps inserted by this function."
+ (unless (or erc-stamp--date-format-end erc-stamp-prepend-date-stamps-p
+ (and (or (null erc-timestamp-format-left)
+ (string-empty-p ; compat
+ (string-trim erc-timestamp-format-left "\n")))
+ (always (erc-stamp--date-mode -1))
+ (setq erc-stamp-prepend-date-stamps-p t)))
+ (erc-stamp--date-mode +1)
+ ;; Hooks used by ^ are the preferred means of inserting date
+ ;; stamps. But they'll never see this inaugural message, so it
+ ;; must be handled specially.
+ (let ((erc--insert-marker (point-min-marker))
+ (end-marker (point-max-marker)))
+ (set-marker-insertion-type erc--insert-marker t)
+ (erc-stamp--lr-date-on-pre-modify nil)
+ (narrow-to-region erc--insert-marker end-marker)
+ (set-marker end-marker nil)
+ (set-marker erc--insert-marker nil)))
+ (let* ((ct (erc-stamp--current-time))
+ (ts-right (with-suppressed-warnings
+ ((obsolete erc-timestamp-format-right))
+ (if erc-timestamp-format-right
+ (erc-format-timestamp ct erc-timestamp-format-right)
+ string))))
+ ;; We should arguably be ensuring a trailing newline on legacy
+ ;; "prepended" date stamps as well. However, since this is a
+ ;; compatibility oriented code path, and pre-5.6 did no such
+ ;; thing, better to punt.
+ (when-let ((erc-stamp-prepend-date-stamps-p)
+ (ts-left (erc-format-timestamp ct erc-timestamp-format-left))
+ ((not (string= ts-left erc-timestamp-last-inserted-left))))
(goto-char (point-min))
(erc-put-text-property 0 (length ts-left) 'field 'erc-timestamp ts-left)
- (insert ts-left)
- (setq erc-timestamp-last-inserted-left ts-left))
+ (insert (setq erc-timestamp-last-inserted-left ts-left)))
;; insert right timestamp
(let ((erc-timestamp-only-if-changed-flag t)
(erc-timestamp-last-inserted erc-timestamp-last-inserted-right))
@@ -336,17 +818,36 @@ it off to the right."
(setq erc-timestamp-last-inserted-right ts-right))))
;; for testing: (setq erc-timestamp-only-if-changed-flag nil)
+(defvar erc-stamp--tz nil)
+
+;; Unfortunately, cursory measurements show that this function is 10x
+;; slower than `erc-format-timestamp', which is perhaps
+;; counterintuitive. Thus, we use the latter for our cache, and
+;; perform day alignments via this function only when needed.
+(defun erc-stamp--time-as-day (current-time)
+ "Discard hour, minute, and second info from timestamp CURRENT-TIME."
+ (defvar current-time-list) ; <=28
+ (let* ((current-time-list) ; flag
+ (decoded (decode-time current-time erc-stamp--tz)))
+ (setf (decoded-time-second decoded) 0
+ (decoded-time-minute decoded) 0
+ (decoded-time-hour decoded) 0
+ (decoded-time-dst decoded) -1
+ (decoded-time-weekday decoded) nil
+ (decoded-time-zone decoded)
+ (and erc-stamp--tz (car (current-time-zone nil erc-stamp--tz))))
+ (encode-time decoded))) ; may return an integer
(defun erc-format-timestamp (time format)
"Return TIME formatted as string according to FORMAT.
Return the empty string if FORMAT is nil."
(if format
- (let ((ts (format-time-string format time)))
+ (let ((ts (format-time-string format time erc-stamp--tz)))
(erc-put-text-property 0 (length ts)
'font-lock-face 'erc-timestamp-face ts)
- (erc-put-text-property 0 (length ts) 'invisible 'timestamp ts)
- (erc-put-text-property 0 (length ts)
- 'isearch-open-invisible 'timestamp ts)
+ (when erc-stamp--invisible-property
+ (erc-put-text-property 0 (length ts) 'invisible
+ erc-stamp--invisible-property ts))
;; N.B. Later use categories instead of this harmless, but
;; inelegant, hack. -- BPT
(and erc-timestamp-intangible
@@ -355,25 +856,81 @@ Return the empty string if FORMAT is nil."
ts)
""))
-;; This function is used to munge `buffer-invisibility-spec' to an
-;; appropriate value. Currently, it only handles timestamps, thus its
-;; location. If you add other features which affect invisibility,
-;; please modify this function and move it to a more appropriate
-;; location.
-(defun erc-munge-invisibility-spec ()
- (and erc-timestamp-intangible (not (bound-and-true-p cursor-intangible-mode))
- (cursor-intangible-mode 1))
- (and erc-echo-timestamps (not (bound-and-true-p cursor-sensor-mode))
- (cursor-sensor-mode 1))
+(defvar-local erc-stamp--csf-props-updated-p nil)
+
+(define-obsolete-function-alias 'erc-munge-invisibility-spec
+ #'erc-stamp--manage-local-options-state "30.1"
+ "Perform setup and teardown of `stamp'-owned options.
+
+Note that this function's role in practice has long defied its
+stated mandate as claimed in a now deleted comment, which
+envisioned it as evolving into a central toggle for modifying
+`buffer-invisibility-spec' on behalf of options and features
+ERC-wide.")
+(defun erc-stamp--manage-local-options-state ()
+ "Perform local setup and teardown for `stamp'-owned options.
+For `erc-timestamp-intangible', toggle `cursor-intangible-mode'.
+For `erc-echo-timestamps', integrate with `cursor-sensor-mode'.
+For `erc-hide-timestamps, modify `buffer-invisibility-spec'."
+ (if erc-timestamp-intangible
+ (cursor-intangible-mode +1) ; idempotent
+ (when (bound-and-true-p cursor-intangible-mode)
+ (cursor-intangible-mode -1)))
+ (if erc-echo-timestamps
+ (progn
+ (unless erc-stamp--permanent-cursor-sensor-functions
+ (dolist (hook '(erc-insert-post-hook erc-send-post-hook))
+ (add-hook hook #'erc-stamp--add-csf-on-post-modify nil t))
+ (setq erc-stamp--csf-props-updated-p
+ (alist-get 'erc-stamp--csf-props-updated-p
+ (or erc--server-reconnecting erc--target-priors)))
+ (unless erc-stamp--csf-props-updated-p
+ (setq erc-stamp--csf-props-updated-p t)
+ ;; Spoof `erc--ts' as being non-nil.
+ (let ((erc--msg-props (map-into '((erc--ts . t)) 'hash-table)))
+ (with-silent-modifications
+ (erc--traverse-inserted
+ (point-min) erc-insert-marker
+ #'erc-stamp--add-csf-on-post-modify)))))
+ (cursor-sensor-mode +1) ; idempotent
+ (when (>= emacs-major-version 29)
+ (add-function :before-until (local 'clear-message-function)
+ #'erc-stamp--on-clear-message)))
+ (dolist (hook '(erc-insert-post-hook erc-send-post-hook))
+ (remove-hook hook #'erc-stamp--add-csf-on-post-modify t))
+ (kill-local-variable 'erc-stamp--csf-props-updated-p)
+ (when (bound-and-true-p cursor-sensor-mode)
+ (cursor-sensor-mode -1))
+ (remove-function (local 'clear-message-function)
+ #'erc-stamp--on-clear-message))
(if erc-hide-timestamps
(add-to-invisibility-spec 'timestamp)
(remove-from-invisibility-spec 'timestamp)))
+(defun erc-stamp--add-csf-on-post-modify ()
+ "Add `cursor-sensor-functions' to narrowed buffer."
+ (when (erc--check-msg-prop 'erc--ts)
+ (put-text-property (point-min) (1- (point-max))
+ 'cursor-sensor-functions '(erc--echo-ts-csf))))
+
+(defun erc-stamp--setup ()
+ "Enable or disable buffer-local `erc-stamp-mode' modifications."
+ (if erc-stamp-mode
+ (erc-stamp--manage-local-options-state)
+ (let (erc-echo-timestamps erc-hide-timestamps erc-timestamp-intangible)
+ (erc-stamp--manage-local-options-state))
+ ;; Undo local mods from `erc-insert-timestamp-left-and-right'.
+ (erc-stamp--date-mode -1) ; kills `erc-timestamp-last-inserted-left'
+ (kill-local-variable 'erc-stamp--last-stamp)
+ (kill-local-variable 'erc-timestamp-last-inserted)
+ (kill-local-variable 'erc-timestamp-last-inserted-right)
+ (kill-local-variable 'erc-stamp--date-format-end)))
+
(defun erc-hide-timestamps ()
"Hide timestamp information from display."
(interactive)
(setq erc-hide-timestamps t)
- (erc-munge-invisibility-spec))
+ (erc-stamp--manage-local-options-state))
(defun erc-show-timestamps ()
"Show timestamp information on display.
@@ -381,7 +938,7 @@ This function only works if `erc-timestamp-format' was previously
set, and timestamping is already active."
(interactive)
(setq erc-hide-timestamps nil)
- (erc-munge-invisibility-spec))
+ (erc-stamp--manage-local-options-state))
(defun erc-toggle-timestamps ()
"Hide or show timestamps in ERC buffers.
@@ -395,15 +952,54 @@ enabled when the message was inserted."
(setq erc-hide-timestamps t))
(mapc (lambda (buffer)
(with-current-buffer buffer
- (erc-munge-invisibility-spec)))
+ (erc-stamp--manage-local-options-state)))
(erc-buffer-list)))
-(defun erc-echo-timestamp (dir stamp)
- "Print timestamp text-property of an IRC message."
- (when (and erc-echo-timestamps (eq 'entered dir))
- (when stamp
- (message "%s" (format-time-string erc-echo-timestamp-format
- stamp)))))
+(defvar-local erc-stamp--last-stamp nil)
+
+(defun erc-stamp--on-clear-message (&rest _)
+ "Return `dont-clear-message' when operating inside the same stamp."
+ (and erc-stamp--last-stamp erc-echo-timestamps
+ (eq (erc--get-inserted-msg-prop 'erc--ts) erc-stamp--last-stamp)
+ 'dont-clear-message))
+
+(defun erc-echo-timestamp (dir stamp &optional zone)
+ "Display timestamp of message at point in echo area.
+Interactively, interpret a numeric prefix as a ZONE offset in
+hours (or seconds, if its abs value is larger than 14), and
+interpret a \"raw\" prefix as UTC. To specify a zone for use
+with the option `erc-echo-timestamps', see the companion option
+`erc-echo-timestamp-zone'."
+ (interactive (list nil (erc--get-inserted-msg-prop 'erc--ts)
+ (pcase current-prefix-arg
+ ((and (pred numberp) v)
+ (if (<= (abs v) 14) (* v 3600) v))
+ (`(,_) t))))
+ (if (and stamp (or (null dir) (and erc-echo-timestamps (eq 'entered dir))))
+ (progn
+ (setq erc-stamp--last-stamp stamp)
+ (message (format-time-string erc-echo-timestamp-format
+ stamp (or zone erc-echo-timestamp-zone))))
+ (when (and erc-echo-timestamps (eq 'left dir))
+ (setq erc-stamp--last-stamp nil))))
+
+(defun erc--echo-ts-csf (_window _before dir)
+ (erc-echo-timestamp dir (erc--get-inserted-msg-prop 'erc--ts)))
+
+(defun erc-stamp--update-saved-position (&rest _)
+ (remove-hook 'erc-stamp--insert-date-hook
+ #'erc-stamp--update-saved-position t)
+ (move-marker erc-last-saved-position (1- (point-max))))
+
+(defun erc-stamp--reset-on-clear (pos)
+ "Forget last-inserted stamps when POS is at insert marker."
+ (when (= pos (1- erc-insert-marker))
+ (when erc-stamp--date-mode
+ (add-hook 'erc-stamp--insert-date-hook
+ #'erc-stamp--update-saved-position 0 t))
+ (setq erc-timestamp-last-inserted nil
+ erc-timestamp-last-inserted-left nil
+ erc-timestamp-last-inserted-right nil)))
(provide 'erc-stamp)
diff --git a/lisp/erc/erc-status-sidebar.el b/lisp/erc/erc-status-sidebar.el
index a0b5c9e8bc6..b7695651e4c 100644
--- a/lisp/erc/erc-status-sidebar.el
+++ b/lisp/erc/erc-status-sidebar.el
@@ -45,6 +45,13 @@
;; Use M-x erc-status-sidebar-kill RET to kill the sidebar buffer and
;; close the sidebar on all frames.
+;; In addition to the commands above, you can also try the all-in-one
+;; entry point `erc-bufbar-mode'. See its doc string for usage.
+
+;; If you want the status sidebar enabled whenever you use ERC, add
+;; `bufbar' to `erc-modules'. Note that this library also has a major
+;; mode, `erc-status-sidebar-mode', which is for internal use.
+
;;; Code:
(require 'erc)
@@ -53,8 +60,15 @@
(require 'seq)
(defgroup erc-status-sidebar nil
- "A sidebar for ERC channel status."
- :group 'convenience)
+ "A responsive side window listing all connected ERC buffers.
+More commonly known as a window list or \"buflist\", this side
+panel displays clickable buffer names for switching to with the
+mouse. By default, ERC highlights the name corresponding to the
+selected window's buffer, if any. In this context, \"connected\"
+just means associated with the same IRC session, even one that
+has ceased communicating with its server. For information on how
+the window itself works, see Info node `(elisp) Side Windows'."
+ :group 'erc)
(defcustom erc-status-sidebar-buffer-name "*ERC Status*"
"Name of the sidebar buffer."
@@ -80,9 +94,83 @@
(defcustom erc-status-sidebar-channel-format
'erc-status-sidebar-default-chan-format
- "Function used to format channel names for display in the sidebar."
+ "Function used to format channel names for display in the sidebar.
+Only consulted for certain values of `erc-status-sidebar-style'."
:type 'function)
+(defcustom erc-status-sidebar-highlight-active-buffer t
+ "Whether to highlight the selected window's buffer in the sidebar.
+ERC uses the same instance across all frames. May not be
+compatible with all values of `erc-status-sidebar-style'."
+ :package-version '(ERC . "5.6")
+ :type 'boolean)
+
+(defcustom erc-status-sidebar-style 'all-queries-first
+ "Preset style for rendering the sidebar.
+
+When set to `channels-only', ERC limits the items in the
+status bar to uniquified channels. It uses the options
+and functions
+
+ `erc-channel-list',
+ `erc-status-sidebar-channel-sort',
+ `erc-status-sidebar-get-channame',
+ `erc-status-sidebar-channel-format'
+ `erc-status-sidebar-default-insert'
+
+for selecting, formatting, naming, and inserting entries. When
+set to one of the various `all-*' values, such as `all-mixed',
+ERC shows channels and queries under their respective server
+buffers, using the functions
+
+ `erc-status-sidebar-all-target-buffers',
+ `erc-status-sidebar-default-allsort',
+ `erc-status-sidebar-prefer-target-as-name',
+ `erc-status-sidebar-default-chan-format',
+ `erc-status-sidebar-pad-hierarchy'
+
+for the above-mentioned purposes. ERC also accepts a list of
+functions to perform these roles a la carte. Since the members
+of the above sets aren't really interoperable, we don't offer
+them here as customization choices, but you can still specify
+them manually. See doc strings for a description of their
+expected arguments and return values."
+ :package-version '(ERC . "5.6")
+ :type '(choice (const channels-only)
+ (const all-mixed)
+ (const all-queries-first)
+ (const all-channels-first)
+ (list (function :tag "Buffer lister")
+ (function :tag "Buffer sorter")
+ (function :tag "Name extractor")
+ (function :tag "Name formatter")
+ (function :tag "Name inserter"))))
+
+(defcustom erc-status-sidebar-click-display-action t
+ "How to display a buffer when clicked.
+Values can be anything recognized by `display-buffer' for its
+ACTION parameter."
+ :package-version '(ERC . "5.6")
+ :type '(choice (const :tag "Always use/create other window" t)
+ (const :tag "Let `display-buffer' decide" nil)
+ (const :tag "Same window" (display-buffer-same-window
+ (inhibit-same-window . nil)))
+ (cons :tag "Action"
+ (choice function (repeat function))
+ (alist :tag "Action arguments"
+ :key-type symbol
+ :value-type (sexp :tag "Value")))))
+
+(defvar erc-status-sidebar--singular-p t
+ "Whether to restrict the sidebar to a single frame.
+This variable only affects `erc-bufbar-mode'. Disabling it does
+not arrange for automatically showing the sidebar in all frames.
+Rather, disabling it allows for displaying the sidebar in the
+selected frame even if it's already showing in some other frame.")
+
+(defvar hl-line-mode)
+(declare-function hl-line-highlight "hl-line" nil)
+
(defun erc-status-sidebar-display-window ()
"Display the status buffer in a side window. Return the new window."
(display-buffer
@@ -94,7 +182,8 @@
"Return the created/existing window displaying the status buffer.
If NO-CREATION is non-nil, the window is not created."
- (let ((sidebar-window (get-buffer-window erc-status-sidebar-buffer-name)))
+ (let ((sidebar-window (get-buffer-window erc-status-sidebar-buffer-name
+ erc-status-sidebar--singular-p)))
(unless (or sidebar-window no-creation)
(with-current-buffer (erc-status-sidebar-get-buffer)
(setq-local vertical-scroll-bar nil))
@@ -130,7 +219,7 @@ The erc-status-sidebar buffer is left alone, but the window
containing it on the current frame is closed. See
`erc-status-sidebar-kill'."
(interactive "P")
- (mapcar #'delete-window
+ (mapcar #'delete-window ; FIXME use `mapc'.
(get-buffer-window-list (erc-status-sidebar-get-buffer)
nil (if all-frames t))))
@@ -139,23 +228,63 @@ containing it on the current frame is closed. See
`(let ((buffer-read-only nil))
,@body))
+(defun erc-status-sidebar--open ()
+ "Maybe open the sidebar, respecting `erc-status-sidebar--singular-p'."
+ (save-excursion
+ (if (erc-status-sidebar-buffer-exists-p)
+ (erc-status-sidebar-get-window)
+ (with-current-buffer (erc-status-sidebar-get-buffer)
+ (erc-status-sidebar-mode)
+ (erc-status-sidebar-refresh)))))
+
+;;;###autoload(autoload 'erc-bufbar-mode "erc-status-sidebar" nil t)
+(define-erc-module bufbar nil
+ "Show `erc-track'-like activity in a side window.
+When enabling, show the sidebar immediately in the current frame
+if called from a connected ERC buffer. Otherwise, arrange for
+doing so on connect or whenever next displaying a new ERC buffer.
+When disabling, hide the status window in all frames. With a
+negative prefix arg, also shutdown the session. Normally, this
+module only allows one sidebar window in an Emacs session. To
+override this, use `erc-status-sidebar-open' to force creation
+and `erc-status-sidebar-close' to hide a single instance on the
+current frame only."
+ ((unless erc-track-mode
+ (unless (memq 'track erc-modules)
+ (erc--warn-once-before-connect 'erc-bufbar-mode
+ "Module `bufbar' needs global module `track'. Enabling now."
+ " This will affect \C-]all\C-] ERC sessions."
+ " Add `track' to `erc-modules' to silence this message."))
+ (erc-track-mode +1))
+ (add-hook 'erc--setup-buffer-hook #'erc-status-sidebar--open)
+ ;; Preserve side-window dimensions after `custom-buffer-done'.
+ (when-let (((not erc--updating-modules-p))
+ (buf (or (and (derived-mode-p 'erc-mode) (current-buffer))
+ (car (erc-buffer-filter
+ (lambda () erc-server-connected))))))
+ (with-current-buffer buf
+ (erc-status-sidebar--open))))
+ ((remove-hook 'erc--setup-buffer-hook #'erc-status-sidebar--open)
+ (erc-status-sidebar-close 'all-frames)
+ (when-let ((arg erc--module-toggle-prefix-arg)
+ ((numberp arg))
+ ((< arg 0)))
+ (erc-status-sidebar-kill))))
+
;;;###autoload
(defun erc-status-sidebar-open ()
- "Open or create a sidebar."
+ "Open or create a sidebar window in the current frame.
+When `erc-bufbar-mode' is active, do this even if one already
+exists in another frame."
(interactive)
- (save-excursion
- (let ((sidebar-exists (erc-status-sidebar-buffer-exists-p))
- (sidebar-buffer (erc-status-sidebar-get-buffer))
- ;; (sidebar-window (erc-status-sidebar-get-window))
- )
- (unless sidebar-exists
- (with-current-buffer sidebar-buffer
- (erc-status-sidebar-mode)
- (erc-status-sidebar-refresh))))))
+ (let ((erc-status-sidebar--singular-p (not erc-bufbar-mode)))
+ (erc-status-sidebar--open)))
;;;###autoload
(defun erc-status-sidebar-toggle ()
- "Toggle the sidebar open/closed on the current frame."
+ "Toggle the sidebar open/closed on the current frame.
+When opening, and `erc-bufbar-mode' is active, create a sidebar
+even if one already exists in another frame."
(interactive)
(if (get-buffer-window erc-status-sidebar-buffer-name nil)
(erc-status-sidebar-close)
@@ -174,6 +303,98 @@ containing it on the current frame is closed. See
(string< (erc-status-sidebar-get-channame x)
(erc-status-sidebar-get-channame y)))))
+(defvar erc-status-sidebar--trimpat nil)
+(defvar erc-status-sidebar--prechan nil)
+
+(defun erc-status-sidebar-prefer-target-as-name (buffer)
+ "Return some name to represent buffer in the sidebar."
+ (if-let ((target (buffer-local-value 'erc--target buffer)))
+ (cond ((and erc-status-sidebar--trimpat (erc--target-channel-p target))
+ (string-trim-left (erc--target-string target)
+ erc-status-sidebar--trimpat))
+ ((and erc-status-sidebar--prechan (erc--target-channel-p target))
+ (concat erc-status-sidebar--prechan
+ (erc--target-string target)))
+ (t (erc--target-string target)))
+ (buffer-name buffer)))
+
+;; This could be converted into an option if people want.
+(defvar erc-status-sidebar--show-disconnected t)
+
+(defun erc-status-sidebar-all-target-buffers (process)
+ (erc-buffer-filter (lambda ()
+ (and erc--target
+ (or erc-status-sidebar--show-disconnected
+ (erc-server-process-alive))))
+ process))
+
+;; FIXME profile this. Rebuilding the graph every time track updates
+;; seems wasteful for occasions where server messages are processed
+;; unthrottled, such as during history playback. If it's a problem,
+;; we should look into rewriting this using `ewoc' or some other
+;; solution that maintains a persistent model.
+(defun erc-status-sidebar-default-allsort (target-buffers)
+ "Return a list of servers interspersed with their targets."
+ (mapcan (pcase-lambda (`(,proc . ,chans))
+ (cons (process-buffer proc)
+ (let ((erc-status-sidebar--trimpat
+ (and (eq erc-status-sidebar-style 'all-mixed)
+ (with-current-buffer (process-buffer proc)
+ (when-let ((ch-pfxs (erc--get-isupport-entry
+ 'CHANTYPES 'single)))
+ (regexp-quote ch-pfxs)))))
+ (erc-status-sidebar--prechan
+ (and (eq erc-status-sidebar-style
+ 'all-queries-first)
+ "\C-?")))
+ (sort chans
+ (lambda (x y)
+ (string<
+ (erc-status-sidebar-prefer-target-as-name x)
+ (erc-status-sidebar-prefer-target-as-name y)))))))
+ (sort (seq-group-by (lambda (b)
+ (buffer-local-value 'erc-server-process b))
+ target-buffers)
+ (lambda (a b)
+ (string< (buffer-name (process-buffer (car a)))
+ (buffer-name (process-buffer (car b))))))))
+
+(defvar-local erc-status-sidebar--active-marker nil
+ "Marker indicating currently active buffer.")
+
+(defun erc-status-sidebar--set-active-line (erc-buffer)
+ (when (and erc-status-sidebar-highlight-active-buffer
+ (eq (window-buffer (and (minibuffer-window-active-p
+ (selected-window))
+ (minibuffer-selected-window)))
+ erc-buffer))
+ (set-marker erc-status-sidebar--active-marker (point))))
+
+(defun erc-status-sidebar-default-insert (channame chanbuf _chanlist)
+ "Insert CHANNAME followed by a newline.
+Maybe arrange to highlight line if CHANBUF is showing in the
+focused window."
+ (erc-status-sidebar--set-active-line chanbuf)
+ (insert channame "\n"))
+
+(defun erc-status-sidebar-pad-hierarchy (bufname buffer buflist)
+ "Prefix BUFNAME to emphasize BUFFER's role in BUFLIST."
+ (if (and (buffer-live-p buffer) (buffer-local-value 'erc--target buffer))
+ (insert " ")
+ (unless (eq buffer (car buflist))
+ (insert "\n"))) ; ^L
+ (when bufname
+ (erc-status-sidebar--set-active-line buffer))
+ (insert (or bufname
+ (and-let* (((not (buffer-live-p buffer)))
+ (next (cadr (member buffer buflist)))
+ ((buffer-live-p next))
+ (proc (buffer-local-value 'erc-server-process next))
+ (id (process-get proc 'erc-networks--id)))
+ (symbol-name (erc-networks--id-symbol id)))
+ "???")
+ "\n"))
+
(defun erc-status-sidebar-default-chan-format (channame
&optional num-messages erc-face)
"Format CHANNAME for display in the sidebar.
@@ -193,43 +414,109 @@ name stand out."
(defun erc-status-sidebar-refresh ()
"Update the content of the sidebar."
(interactive)
- (let ((chanlist (apply erc-status-sidebar-channel-sort
- (erc-channel-list nil) nil)))
+ (pcase-let* ((`(,list-fn ,sort-fn ,name-fn ,fmt-fn ,insert-fn)
+ (pcase erc-status-sidebar-style
+ ('channels-only (list #'erc-channel-list
+ erc-status-sidebar-channel-sort
+ #'erc-status-sidebar-get-channame
+ erc-status-sidebar-channel-format
+ #'erc-status-sidebar-default-insert))
+ ((or 'all-mixed 'all-queries-first 'all-channels-first)
+ '(erc-status-sidebar-all-target-buffers
+ erc-status-sidebar-default-allsort
+ erc-status-sidebar-prefer-target-as-name
+ erc-status-sidebar-default-chan-format
+ erc-status-sidebar-pad-hierarchy))
+ (v v)))
+ (chanlist (apply sort-fn (funcall list-fn nil) nil))
+ (windows nil))
(with-current-buffer (erc-status-sidebar-get-buffer)
+ (dolist (window (get-buffer-window-list nil nil t))
+ (push (cons window (window-start window)) windows))
(erc-status-sidebar-writable
(delete-region (point-min) (point-max))
(goto-char (point-min))
+ (if erc-status-sidebar--active-marker
+ (set-marker erc-status-sidebar--active-marker nil)
+ (setq erc-status-sidebar--active-marker (make-marker)))
(dolist (chanbuf chanlist)
(let* ((tup (seq-find (lambda (tup) (eq (car tup) chanbuf))
erc-modified-channels-alist))
(count (if tup (cadr tup)))
(face (if tup (cddr tup)))
- (channame (apply erc-status-sidebar-channel-format
- (buffer-name chanbuf) count face nil))
+ (face (if (or (not (buffer-live-p chanbuf))
+ (not (erc-server-process-alive chanbuf)))
+ `(shadow ,face)
+ face))
+ (channame (apply fmt-fn
+ (copy-sequence (funcall name-fn chanbuf))
+ count face nil))
(cnlen (length channame)))
(put-text-property 0 cnlen 'erc-buf chanbuf channame)
(put-text-property 0 cnlen 'mouse-face 'highlight channame)
(put-text-property
0 cnlen 'help-echo
"mouse-1: switch to buffer in other window" channame)
- (insert channame "\n")))))))
+ (funcall insert-fn channame chanbuf chanlist)))
+ (when windows
+ (map-apply #'set-window-start windows))
+ (when (and erc-status-sidebar-highlight-active-buffer
+ (marker-buffer erc-status-sidebar--active-marker))
+ (goto-char erc-status-sidebar--active-marker)
+ (require 'hl-line)
+ (unless hl-line-mode (hl-line-mode +1))
+ (hl-line-highlight))))))
(defun erc-status-sidebar-kill ()
"Close the ERC status sidebar and its buffer."
(interactive)
+ (when (and erc-bufbar-mode (not erc--module-toggle-prefix-arg))
+ (erc-bufbar-mode -1))
(ignore-errors (kill-buffer erc-status-sidebar-buffer-name)))
(defun erc-status-sidebar-click (event)
"Handle click EVENT in `erc-status-sidebar-mode-map'."
(interactive "e")
(save-excursion
- (let ((window (posn-window (event-end event)))
+ (let ((window (posn-window (event-start event)))
(pos (posn-point (event-end event))))
- (set-buffer (window-buffer window))
- (let ((buf (get-text-property pos 'erc-buf)))
- (when buf
- (select-window window)
- (switch-to-buffer-other-window buf))))))
+ ;; Current buffer is "ERC Status" and its window is selected
+ (cl-assert (eq major-mode 'erc-status-sidebar-mode))
+ (cl-assert (eq (selected-window) window))
+ (cl-assert (eq (window-buffer window) (current-buffer)))
+ (when-let ((buf (get-text-property pos 'erc-buf)))
+ ;; Option operates relative to last selected window
+ (select-window (get-mru-window nil nil 'not-selected))
+ (pop-to-buffer buf erc-status-sidebar-click-display-action)))))
+
+(defun erc-status-sidebar-scroll-up (lines)
+ "Scroll sidebar buffer's content LINES linse upward.
+If LINES is nil, scroll up a full screen's worth."
+ (interactive "P")
+ (let ((other-window-scroll-buffer (erc-status-sidebar-get-buffer)))
+ (scroll-other-window lines)))
+
+(defun erc-status-sidebar-scroll-down (lines)
+ "Scroll sidebar buffer's content LINES lines downward.
+If LINES is nil, scroll down a full screen's worth."
+ (interactive "P")
+ (let ((other-window-scroll-buffer (erc-status-sidebar-get-buffer)))
+ (scroll-other-window-down lines)))
+
+(defun erc-status-sidebar-recenter (arg)
+ "Recenter the status sidebar.
+Expect `erc-status-sidebar-highlight-active-buffer' to be non-nil
+and to be invoked in a buffer matching the line currently
+highlighted."
+ (interactive "P")
+ (let* ((buf (erc-status-sidebar-get-buffer))
+ (win (get-buffer-window buf)))
+ (with-current-buffer buf
+ (when (and erc-status-sidebar--active-marker
+ (marker-position erc-status-sidebar--active-marker))
+ (with-selected-window win
+ (goto-char erc-status-sidebar--active-marker)
+ (recenter arg t))))))
(defvar erc-status-sidebar-mode-map
(let ((map (make-sparse-keymap)))
@@ -246,14 +533,28 @@ name stand out."
erc-kill-server-hook
erc-kick-hook
erc-disconnected-hook
- erc-quit-hook))
+ erc-quit-hook)
+ "Hooks to refresh the sidebar on.
+This may be set locally in the status-sidebar buffer under
+various conditions, like when the option
+`erc-status-sidebar-highlight-active-buffer' is non-nil.")
+
+(defvar erc-status-sidebar--highlight-refresh-triggers
+ '(window-selection-change-functions)
+ "Triggers enabled with `erc-status-sidebar-highlight-active-buffer'.")
+
+(defun erc-status-sidebar--refresh-unless-input ()
+ "Run `erc-status-sidebar-refresh' unless there are unread commands.
+Also abstain when the user is interacting with the minibuffer."
+ (unless (or (input-pending-p) (minibuffer-window-active-p (selected-window)))
+ (erc-status-sidebar-refresh)))
(defun erc-status-sidebar--post-refresh (&rest _ignore)
"Schedule sidebar refresh for execution after command stack is cleared.
Ignore arguments in IGNORE, allowing this function to be added to
hooks that invoke it with arguments."
- (run-at-time 0 nil #'erc-status-sidebar-refresh))
+ (run-at-time 0 nil #'erc-status-sidebar--refresh-unless-input))
(defun erc-status-sidebar-mode--unhook ()
"Remove hooks installed by `erc-status-sidebar-mode'."
@@ -268,13 +569,17 @@ hooks that invoke it with arguments."
Note that preserve status needs to be reset when the window is
manually resized, so `erc-status-sidebar-mode' adds this function
to the `window-configuration-change-hook'."
- (when (and (eq (selected-window) (erc-status-sidebar-get-window))
+ (when (and (eq (selected-window) (let (erc-status-sidebar--singular-p)
+ (erc-status-sidebar-get-window)))
(fboundp 'window-preserve-size))
(unless (eq (window-total-width) (window-min-size nil t))
(apply #'window-preserve-size (selected-window) t t nil))))
(define-derived-mode erc-status-sidebar-mode special-mode "ERC Sidebar"
"Major mode for ERC status sidebar."
+ ;; Users invoking M-x erc-status-sidebar-mode most likely expect to
+ ;; summon the module's minor-mode, `erc-bufbar-mode'.
+ :interactive nil
;; Don't scroll the buffer horizontally, if a channel name is
;; obscured then the window can be resized.
(setq-local auto-hscroll-mode nil)
@@ -286,6 +591,10 @@ to the `window-configuration-change-hook'."
(add-hook 'window-configuration-change-hook
#'erc-status-sidebar-set-window-preserve-size nil t)
+ (when erc-status-sidebar-highlight-active-buffer
+ (setq-local erc-status-sidebar-refresh-triggers
+ `(,@erc-status-sidebar--highlight-refresh-triggers
+ ,@erc-status-sidebar-refresh-triggers)))
(dolist (hk erc-status-sidebar-refresh-triggers)
(add-hook hk #'erc-status-sidebar--post-refresh))
diff --git a/lisp/erc/erc-track.el b/lisp/erc/erc-track.el
index 6fcb60b0da6..04ee76a9349 100644
--- a/lisp/erc/erc-track.el
+++ b/lisp/erc/erc-track.el
@@ -161,32 +161,54 @@ The faces used are the same as used for text in the buffers.
\(e.g. `erc-pal-face' is used if a pal sent a message to that channel.)"
:type 'boolean)
+(defun erc-track--massage-nick-button-faces (sym val &optional set-fn)
+ "Transform VAL of face-list option SYM to have new defaults.
+Use `set'-compatible SET-FN when given. If an update was
+performed, set the symbol property `erc-track--obsolete-faces' of
+SYM to t."
+ (let* ((changedp nil)
+ (new (mapcar
+ (lambda (f)
+ (if (and (eq (car-safe f) 'erc-nick-default-face)
+ (equal f '(erc-nick-default-face erc-default-face)))
+ (progn
+ (setq changedp t)
+ (put sym 'erc-track--obsolete-faces t)
+ (cons 'erc-button-nick-default-face (cdr f)))
+ f))
+ val)))
+ (if set-fn
+ (funcall set-fn sym (if changedp new val))
+ (set-default sym (if changedp new val)))))
+
(defcustom erc-track-faces-priority-list
'(erc-error-face
- (erc-nick-default-face erc-current-nick-face)
erc-current-nick-face
erc-keyword-face
- (erc-nick-default-face erc-pal-face)
erc-pal-face
erc-nick-msg-face
erc-direct-msg-face
(erc-button erc-default-face)
- (erc-nick-default-face erc-dangerous-host-face)
erc-dangerous-host-face
erc-nick-default-face
- (erc-nick-default-face erc-default-face)
+ (erc-button-nick-default-face erc-default-face)
erc-default-face
erc-action-face
- (erc-nick-default-face erc-fool-face)
erc-fool-face
erc-notice-face
erc-input-face
erc-prompt-face)
"A list of faces used to highlight active buffer names in the mode line.
If a message contains one of the faces in this list, the buffer name will
-be highlighted using that face. The first matching face is used."
- :type '(repeat (choice face
- (repeat :tag "Combination" face))))
+be highlighted using that face. The first matching face is used.
+
+Note that ERC prioritizes certain faces reserved for critical
+messages regardless of this option's value."
+ :package-version '(ERC . "5.6")
+ :set #'erc-track--massage-nick-button-faces
+ :type (erc--with-dependent-type-match
+ (repeat (choice face (repeat :tag "Combination" face)))
+ erc-button))
(defcustom erc-track-priority-faces-only nil
"Only track text highlighted with a priority face.
@@ -205,10 +227,9 @@ setting this variable might not be very useful."
(defcustom erc-track-faces-normal-list
'((erc-button erc-default-face)
- (erc-nick-default-face erc-dangerous-host-face)
erc-dangerous-host-face
erc-nick-default-face
- (erc-nick-default-face erc-default-face)
+ (erc-button-nick-default-face erc-default-face)
erc-default-face
erc-action-face)
"A list of faces considered to be part of normal conversations.
@@ -220,9 +241,26 @@ the buffer name will be highlighted using the face from the
message. This gives a rough indication that active conversations
are occurring in these channels.
+Note that ERC makes a copy of this option when initializing the
+module. To see your changes reflected mid-session, cycle
+\\[erc-track-mode].
+
The effect may be disabled by setting this variable to nil."
- :type '(repeat (choice face
- (repeat :tag "Combination" face))))
+ :package-version '(ERC . "5.6")
+ :set #'erc-track--massage-nick-button-faces
+ :type (erc--with-dependent-type-match
+ (repeat (choice face (repeat :tag "Combination" face)))
+ erc-button))
+
+(defvar erc-track-ignore-normal-contenders-p nil
+ "Compatibility flag to promote only exclusively new \"normal\" faces.
+When non-nil, revert to pre-5.6 behavior in which only a current
+mode-line face that both outranks and is absent from the current
+message is eligible for replacement by a fellow face from
+`erc-track-faces-normal-list' that does appear in the message.
+By extension, when enabled, never replace the current, reigning
+mode-line face if it's present in the current message. May be
+incompatible with modules introduced after ERC 5.5.")
(defcustom erc-track-position-in-mode-line 'before-modes
"Where to show modified channel information in the mode-line.
@@ -309,6 +347,8 @@ important."
(const leastactive)
(const mostactive)))
+(defconst erc-track--attn-faces '((erc-error-face erc-notice-face))
+ "Faces whose presence always triggers mode-line inclusion.")
(defun erc-track-remove-from-mode-line ()
"Remove `erc-track-modified-channels' from the mode-line."
@@ -338,6 +378,37 @@ See `erc-track-position-in-mode-line' for possible values."
;;; Shortening of names
+(defvar erc-track--shortened-names nil
+ "A cons of the last novel name-shortening params and the result.
+The CAR is a hash of environmental inputs such as options and
+parameters passed to `erc-track-shorten-function'. Its effect is
+only really noticeable during batch processing.")
+
+(defvar erc-track--shortened-names-current-hash nil)
+
+(defun erc-track--shortened-names-set (_ shortened)
+ "Remember SHORTENED names with hash of contextual params."
+ (cl-assert erc-track--shortened-names-current-hash)
+ (setq erc-track--shortened-names
+ (cons erc-track--shortened-names-current-hash shortened)))
+
+(defun erc-track--shortened-names-get (channel-names)
+ "Cache CHANNEL-NAMES with various contextual parameters.
+For now, omit relevant options like `erc-track-shorten-start' and
+friends, even though they do affect the outcome, because they
+likely change too infrequently to matter over sub-second
+intervals and are unlikely to be let-bound or set locally."
+ (when-let ((hash (setq erc-track--shortened-names-current-hash
+ (sxhash-equal (list channel-names
+ (buffer-list)
+ erc-track-shorten-function))))
+ (erc-track--shortened-names)
+ ((= hash (car erc-track--shortened-names))))
+ (cdr erc-track--shortened-names)))
+
+(gv-define-simple-setter erc-track--shortened-names-get
+ erc-track--shortened-names-set)
+
(defun erc-track-shorten-names (channel-names)
"Call `erc-unique-channel-names' with the correct parameters.
This function is a good value for `erc-track-shorten-function'.
@@ -512,6 +583,9 @@ keybindings will not do anything useful."
(progn
(add-hook 'window-configuration-change-hook #'erc-user-is-active)
(add-hook 'erc-send-completed-hook #'erc-user-is-active)
+ ;; FIXME find out why this uses `erc-server-001-functions'.
+ ;; `erc-user-is-active' runs when `erc-server-connected' is
+ ;; non-nil. But this hook usually only runs when it's nil.
(add-hook 'erc-server-001-functions #'erc-user-is-active))
(erc-track-add-to-mode-line erc-track-position-in-mode-line)
(erc-update-mode-line)
@@ -522,6 +596,8 @@ keybindings will not do anything useful."
;; enable the tracking keybindings
(add-hook 'erc-connect-pre-hook #'erc-track-minor-mode-maybe)
(erc-track-minor-mode-maybe))
+ (add-hook 'erc-mode-hook #'erc-track--setup)
+ (unless erc--updating-modules-p (erc-buffer-do #'erc-track--setup))
(add-hook 'erc-networks--copy-server-buffer-functions
#'erc-track--replace-killed-buffer))
;; Disable:
@@ -533,6 +609,7 @@ keybindings will not do anything useful."
#'erc-user-is-active)
(remove-hook 'erc-send-completed-hook #'erc-user-is-active)
(remove-hook 'erc-server-001-functions #'erc-user-is-active)
+ ;; FIXME remove this if unused.
(remove-hook 'erc-timer-hook #'erc-user-is-active))
(remove-hook 'window-configuration-change-hook
#'erc-window-configuration-change)
@@ -542,9 +619,12 @@ keybindings will not do anything useful."
(remove-hook 'erc-connect-pre-hook #'erc-track-minor-mode-maybe)
(when erc-track-minor-mode
(erc-track-minor-mode -1)))
+ (remove-hook 'erc-mode-hook #'erc-track--setup)
+ (erc-buffer-do #'erc-track--setup)
(remove-hook 'erc-networks--copy-server-buffer-functions
#'erc-track--replace-killed-buffer)))
+;; FIXME move this above the module definition.
(defcustom erc-track-when-inactive nil
"Enable channel tracking even for visible buffers, if you are inactive."
:type 'boolean
@@ -556,6 +636,51 @@ keybindings will not do anything useful."
(erc-track-enable))
(set sym val))))
+(defvar-local erc-track--normal-faces nil
+ "Local copy of `erc-track-faces-normal-list' as a hash table.")
+
+(defun erc-track--setup ()
+ "Initialize a buffer for use with the `track' module.
+If this is a server buffer or `erc-track-faces-normal-list' is
+locally bound, create a new `erc-track--normal-faces' for the
+current buffer. Otherwise, set the local value to the server
+buffer's."
+ (if erc-track-mode
+ (let ((existing (erc-with-server-buffer erc-track--normal-faces))
+ (localp (and erc--target
+ (local-variable-p 'erc-track-faces-normal-list)))
+ (opts '(erc-track-faces-normal-list erc-track-faces-priority-list))
+ warnp table)
+ ;; Don't bother warning users who've disabled `button'.
+ (unless (or erc--target (not (or (bound-and-true-p erc-button-mode)
+ (memq 'button erc-modules))))
+ (when (or localp (local-variable-p 'erc-track-faces-priority-list))
+ (dolist (opt opts)
+ (erc-track--massage-nick-button-faces opt (symbol-value opt)
+ #'set)))
+ (dolist (opt opts)
+ (when (get opt 'erc-track--obsolete-faces)
+ (push opt warnp)
+ (put opt 'erc-track--obsolete-faces nil)))
+ (when warnp
+ (erc--warn-once-before-connect 'erc-track-mode
+ (if (cdr warnp) "Options " "Option ")
+ (mapconcat (lambda (o) (format "`%S'" o)) warnp " and ")
+ (if (cdr warnp) " contain" " contains")
+ " an obsolete item, %S, intended to match buttonized nicknames."
+ " ERC has changed it to %S for the current session."
+ " Please save the current value to silence this message."
+ '(erc-nick-default-face erc-default-face)
+ '(erc-button-nick-default-face erc-default-face))))
+ (when (or (null existing) localp)
+ (setq table (map-into (mapcar (lambda (f) (cons f f))
+ erc-track-faces-normal-list)
+ '(hash-table :test equal :weakness value))))
+ (setq erc-track--normal-faces (or table existing))
+ (unless (or localp existing)
+ (erc-with-server-buffer (setq erc-track--normal-faces table))))
+ (kill-local-variable 'erc-track--normal-faces)))
+
;;; Visibility
(defvar erc-buffer-activity nil
@@ -699,10 +824,13 @@ Use `erc-make-mode-line-buffer-name' to create buttons."
(or (buffer-name buf)
""))
buffers))
- (short-names (if (functionp erc-track-shorten-function)
- (funcall erc-track-shorten-function
- long-names)
- long-names))
+ (erc-track--shortened-names-current-hash nil)
+ (short-names
+ (if (functionp erc-track-shorten-function)
+ (with-memoization
+ (erc-track--shortened-names-get long-names)
+ (funcall erc-track-shorten-function long-names))
+ long-names))
strings)
(while buffers
(when (car short-names)
@@ -736,6 +864,9 @@ Use `erc-make-mode-line-buffer-name' to create buttons."
(declare (obsolete erc-track-select-mode-line-face "28.1"))
(erc-track-select-mode-line-face (car faces) (cdr faces)))
+;; Note that unless called by `erc-track-modified-channels',
+;; `erc-track-faces-priority-list' will not begin with
+;; `erc-track--attn-faces'.
(defun erc-track-select-mode-line-face (cur-face new-faces)
"Return the face to use in the mode line.
@@ -757,7 +888,12 @@ instead. This has the effect of allowing the current mode line
face, if a member of `erc-track-faces-normal-list', to be
replaced with another with lower priority face from NEW-FACES, if
that face with highest priority in NEW-FACES is also a member of
-`erc-track-faces-normal-list'."
+`erc-track-faces-normal-list'.
+
+To put it another way, when CUR-FACE outranks all NEW-FACES and
+doesn't appear among them, it's eligible to be replaced with a
+fellow \"normal\" from NEW-FACES. But if it does appear among
+them, it can't be replaced."
(let ((choice (catch 'face
(dolist (candidate erc-track-faces-priority-list)
(when (or (equal candidate cur-face)
@@ -776,6 +912,56 @@ that face with highest priority in NEW-FACES is also a member of
choice))
choice))))
+(defvar erc-track--alt-normals-function nil
+ "A function to possibly elect a \"normal\" face.
+Called with the current incumbent and the worthiest new contender
+followed by all new contending faces and so-called \"normal\"
+faces. See `erc-track--select-mode-line-face' for their meanings
+and expected types. This function should return a face or nil.")
+
+(defun erc-track--select-mode-line-face (cur-face new-faces ranks normals)
+ "Return CUR-FACE or a replacement for displaying in the mode-line, or nil.
+Expect RANKS to be a list of faces and both NORMALS and the car
+of NEW-FACES to be hash tables mapping faces to non-nil values.
+Assume the latter's makeup and that of RANKS to resemble
+`erc-track-faces-normal-list' and `erc-track-faces-priority-list'.
+If NEW-FACES has a cdr, expect it to be its car's contents
+ordered from most recently seen (later in the buffer) to
+earliest. In general, act like `erc-track-select-mode-line-face'
+except appeal to `erc-track--alt-normals-function' if it's
+non-nil, falling back on reconsidering NEW-FACES when CUR-FACE
+outranks all its members. That is, choose the first among RANKS
+in NEW-FACES not equal to CUR-FACE. Failing that, choose the
+first face in NEW-FACES that's also in NORMALS, assuming
+NEW-FACES has a cdr."
+ (cl-check-type erc-track-ignore-normal-contenders-p null)
+ (cl-check-type new-faces cons)
+ (when-let ((choice (catch 'face
+ (dolist (candidate ranks)
+ (when (or (equal candidate cur-face)
+ (gethash candidate (car new-faces)))
+ (throw 'face candidate))))))
+ (or (and erc-track--alt-normals-function
+ (funcall erc-track--alt-normals-function
+ cur-face choice new-faces normals))
+ (and (equal choice cur-face)
+ (gethash choice normals)
+ (catch 'face
+ (progn
+ (dolist (candidate ranks)
+ (when (and (not (equal candidate choice))
+ (gethash candidate (car new-faces))
+ (gethash choice normals))
+ (throw 'face candidate)))
+ (dolist (candidate (cdr new-faces))
+ (when (and (not (equal candidate choice))
+ (gethash candidate normals))
+ (throw 'face candidate))))))
+ choice)))
+
+(defvar erc-track--skipped-msgs '(datestamp)
+ "Values of `erc--msg' text prop to ignore.")
+
(defun erc-track-modified-channels ()
"Hook function for `erc-insert-post-hook'.
Check if the current buffer should be added to the mode line as a
@@ -786,11 +972,16 @@ the current buffer is in `erc-mode'."
(if (and (not (erc-buffer-visible (current-buffer)))
(not (member this-channel erc-track-exclude))
(not (and erc-track-exclude-server-buffer
- (erc-server-buffer-p)))
- (not (erc-message-type-member
- (or (erc-find-parsed-property)
- (point-min))
- erc-track-exclude-types)))
+ ;; FIXME either use `erc--server-buffer-p' or
+ ;; explain why that's unwise.
+ (erc-server-or-unjoined-channel-buffer-p)))
+ (not (let ((parsed (erc-find-parsed-property)))
+ (or (erc-message-type-member (or parsed (point-min))
+ erc-track-exclude-types)
+ ;; Skip certain non-server-sent messages.
+ (and (not parsed)
+ (erc--check-msg-prop 'erc--msg
+ erc-track--skipped-msgs))))))
;; If the active buffer is not visible (not shown in a
;; window), and not to be excluded, determine the kinds of
;; faces used in the current message, and unless the user
@@ -802,29 +993,43 @@ the current buffer is in `erc-mode'."
;; (in the car), change its face attribute (in the cddr) if
;; necessary. See `erc-modified-channels-alist' for the
;; exact data structure used.
- (let ((faces (erc-faces-in (buffer-string))))
- (unless (and
- (or (eq erc-track-priority-faces-only 'all)
- (member this-channel erc-track-priority-faces-only))
- (not (catch 'found
- (dolist (f faces)
- (when (member f erc-track-faces-priority-list)
- (throw 'found t))))))
+ (when-let
+ ((faces (if erc-track-ignore-normal-contenders-p
+ (erc-faces-in (buffer-string))
+ (erc-track--get-faces-in-current-message)))
+ (normals erc-track--normal-faces)
+ (erc-track-faces-priority-list
+ `(,@erc-track--attn-faces ,@erc-track-faces-priority-list))
+ (ranks erc-track-faces-priority-list)
+ ((not (and
+ (or (eq erc-track-priority-faces-only 'all)
+ (member this-channel erc-track-priority-faces-only))
+ (not (catch 'found
+ (dolist (f ranks)
+ (when (gethash f (or (car-safe faces) faces))
+ (throw 'found t)))))))))
+ (progn ; FIXME remove `progn' on next major edit
(if (not (assq (current-buffer) erc-modified-channels-alist))
;; Add buffer, faces and counts
(setq erc-modified-channels-alist
(cons (cons (current-buffer)
(cons
- 1 (erc-track-select-mode-line-face
- nil faces)))
+ 1 (if erc-track-ignore-normal-contenders-p
+ (erc-track-select-mode-line-face
+ nil faces)
+ (erc-track--select-mode-line-face
+ nil faces ranks normals))))
erc-modified-channels-alist))
;; Else modify the face for the buffer, if necessary.
(when faces
(let* ((cell (assq (current-buffer)
erc-modified-channels-alist))
(old-face (cddr cell))
- (new-face (erc-track-select-mode-line-face
- old-face faces)))
+ (new-face (if erc-track-ignore-normal-contenders-p
+ (erc-track-select-mode-line-face
+ old-face faces)
+ (erc-track--select-mode-line-face
+ old-face faces ranks normals))))
(setcdr cell (cons (1+ (cadr cell)) new-face)))))
;; And display it
(erc-modified-channels-display)))
@@ -853,6 +1058,30 @@ the current buffer is in `erc-mode'."
(push cur faces)))
faces))
+(defvar erc-track--face-reject-function nil
+ "Function called with face in current buffer to massage or reject.")
+
+(defun erc-track--get-faces-in-current-message ()
+ "Collect all faces in the narrowed buffer.
+Return a cons of a hash table and a list ordered from most
+recently seen to earliest seen."
+ (let ((i (text-property-not-all (point-min) (point-max) 'font-lock-face nil))
+ (seen (make-hash-table :test #'equal))
+ ;;
+ (rfaces ())
+ (faces (make-hash-table :test #'equal)))
+ (while-let ((i)
+ (cur (get-text-property i 'face)))
+ (unless (gethash cur seen)
+ (puthash cur t seen)
+ (when erc-track--face-reject-function
+ (setq cur (funcall erc-track--face-reject-function cur)))
+ (when cur
+ (push cur rfaces)
+ (puthash cur t faces)))
+ (setq i (next-single-property-change i 'font-lock-face)))
+ (cons faces rfaces)))
+
;;; Buffer switching
(defvar erc-track-last-non-erc-buffer nil
@@ -873,7 +1102,7 @@ If face is not in `erc-track-faces-priority-list', it will have a
higher number than any other face in that list."
(let ((count 0))
(catch 'done
- (dolist (item erc-track-faces-priority-list)
+ (dolist (item `(,@erc-track--attn-faces ,@erc-track-faces-priority-list))
(if (equal item face)
(throw 'done t)
(setq count (1+ count)))))
@@ -912,16 +1141,27 @@ is relative to `erc-track-switch-direction'."
(setq offset 0)))
(car (nth offset erc-modified-channels-alist))))
+(defvar erc-track--switch-fallback-blockers '((derived-mode . erc-mode))
+ "List of `buffer-match-p' conditions OR'd together.
+ERC sets `erc-track-last-non-erc-buffer' to the current buffer
+unless any passes.")
+
(defun erc-track--switch-buffer (fun arg)
(if (not erc-track-mode)
(message (concat "Enable the ERC track module if you want to use the"
" tracking minor mode"))
(cond (erc-modified-channels-alist
;; if we're not in erc-mode, set this buffer to return to
- (unless (eq major-mode 'erc-mode)
+ (unless (buffer-match-p (cons 'or
+ erc-track--switch-fallback-blockers)
+ (current-buffer))
(setq erc-track-last-non-erc-buffer (current-buffer)))
;; and jump to the next active channel
- (funcall fun (erc-track-get-active-buffer arg)))
+ (if-let ((buf (erc-track-get-active-buffer arg))
+ ((buffer-live-p buf)))
+ (funcall fun buf)
+ (erc-modified-channels-update)
+ (erc-track--switch-buffer fun arg)))
;; if no active channels, switch back to what we were doing before
((and erc-track-last-non-erc-buffer
erc-track-switch-from-erc
diff --git a/lisp/erc/erc-truncate.el b/lisp/erc/erc-truncate.el
index 0e50ae0d0cf..4b602074ebb 100644
--- a/lisp/erc/erc-truncate.el
+++ b/lisp/erc/erc-truncate.el
@@ -24,10 +24,8 @@
;;; Commentary:
-;; This implements buffer truncation (and optional log file writing
-;; support for the Emacs IRC client. Use `erc-truncate-mode' to switch
-;; on. Use `erc-enable-logging' to enable logging of the stuff which
-;; is getting truncated.
+;; This file implements buffer truncation through the `truncate'
+;; module, with optional `log' module integration.
;;; Code:
@@ -50,15 +48,41 @@ This prevents the query buffer from getting too large, which can
bring any grown Emacs to its knees after a few days worth of
tracking heavy-traffic channels."
;;enable
- ((add-hook 'erc-insert-post-hook #'erc-truncate-buffer))
+ ((add-hook 'erc-insert-done-hook #'erc-truncate-buffer)
+ (add-hook 'erc-connect-pre-hook #'erc-truncate--warn-about-logging))
;; disable
- ((remove-hook 'erc-insert-post-hook #'erc-truncate-buffer)))
+ ((remove-hook 'erc-insert-done-hook #'erc-truncate-buffer)
+ (remove-hook 'erc-connect-pre-hook #'erc-truncate--warn-about-logging)))
+
+(defun erc-truncate--warn-about-logging (&rest _)
+ (when (and (not erc--target)
+ (fboundp 'erc-log--call-when-logging-enabled-sans-module))
+ ;; We could also enable `erc-log-mode' here, but the risk of
+ ;; lasting damage is nonzero.
+ (erc-log--call-when-logging-enabled-sans-module
+ (lambda (dirfile)
+ ;; Emit a real Emacs warning because the message may be
+ ;; truncated away before it can be read if merely inserted.
+ (erc-button--display-error-notice-with-keys-and-warn
+ "The `truncate' module no longer enables logging implicitly."
+ " If you want ERC to write logs before truncating, add `log' to"
+ " `erc-modules' using something like \\[customize-option]."
+ " To silence this message, don't `require' `erc-log'."
+ (and dirfile " Alternatively, change the value of")
+ (and dirfile " `erc-log-channels-directory', or move ")
+ dirfile (and dirfile " elsewhere."))))))
;;;###autoload
(defun erc-truncate-buffer-to-size (size &optional buffer)
- "Truncates the buffer to the size SIZE.
-If BUFFER is not provided, the current buffer is assumed. The deleted
-region is logged if `erc-logging-enabled' returns non-nil."
+ "Truncate BUFFER or the current buffer to SIZE.
+Log the deleted region when the `log' module is active and
+`erc-logging-enabled' returns non-nil.
+
+Note that prior to ERC 5.6, whenever erc-log.el happened to be
+loaded and the option `erc-enable-logging' was left at its
+default value, this function would cause logging to commence
+regardless of whether `erc-log-mode' was enabled or `log' was
+present in `erc-modules'."
;; If buffer is non-nil, but get-buffer does not return anything,
;; then this is a bug. If buffer is a buffer name, get the buffer
;; object. If buffer is nil, use the current buffer.
@@ -75,9 +99,11 @@ region is logged if `erc-logging-enabled' returns non-nil."
(save-restriction
(widen)
(let ((end (- erc-insert-marker size)))
- ;; truncate at line boundaries
+ ;; Truncate at message boundary (formerly line boundary
+ ;; before 5.6).
(goto-char end)
- (beginning-of-line)
+ (goto-char (or (erc--get-inserted-msg-beg end)
+ (pos-bol)))
(setq end (point))
;; try to save the current buffer using
;; `erc-save-buffer-in-logs'. We use this, in case the
@@ -91,10 +117,10 @@ region is logged if `erc-logging-enabled' returns non-nil."
;; (not (memq 'erc-save-buffer-in-logs
;; erc-insert-post-hook))
;; Comments?
- (when (and (boundp 'erc-enable-logging)
- erc-enable-logging
- (erc-logging-enabled buffer))
- (erc-save-buffer-in-logs))
+ ;; The comments above concern pre-5.6 behavior and reflect
+ ;; an obsolete understanding of how `erc-logging-enabled'
+ ;; behaves in practice.
+ (run-hook-with-args 'erc--pre-clear-functions end)
;; disable undoing for the truncating
(buffer-disable-undo)
(let ((inhibit-read-only t))
@@ -103,10 +129,10 @@ region is logged if `erc-logging-enabled' returns non-nil."
;;;###autoload
(defun erc-truncate-buffer ()
- "Truncates the current buffer to `erc-max-buffer-size'.
-Meant to be used in hooks, like `erc-insert-post-hook'."
+ "Truncate current buffer to `erc-max-buffer-size'."
(interactive)
- (erc-truncate-buffer-to-size erc-max-buffer-size))
+ (save-excursion
+ (erc-truncate-buffer-to-size erc-max-buffer-size)))
(provide 'erc-truncate)
;;; erc-truncate.el ends here
diff --git a/lisp/erc/erc.el b/lisp/erc/erc.el
index 88e41e96a82..0750463a4e7 100644
--- a/lisp/erc/erc.el
+++ b/lisp/erc/erc.el
@@ -12,11 +12,14 @@
;; David Edmondson (dme@dme.org)
;; Michael Olson (mwolson@gnu.org)
;; Kelvin White (kwhite@gnu.org)
-;; Version: 5.5.0.29.1
-;; Package-Requires: ((emacs "27.1") (compat "29.1.3.4"))
+;; Version: 5.6-git
+;; Package-Requires: ((emacs "27.1") (compat "29.1.4.4"))
;; Keywords: IRC, chat, client, Internet
;; URL: https://www.gnu.org/software/emacs/erc.html
+;; This is a GNU ELPA :core package. Avoid functionality that is not
+;; compatible with the version of Emacs recorded above.
+
;; This file is part of GNU Emacs.
;; GNU Emacs is free software: you can redistribute it and/or modify
@@ -58,20 +61,16 @@
;;; Code:
-(load "erc-loaddefs" 'noerror 'nomessage)
+(eval-and-compile (load "erc-loaddefs" 'noerror 'nomessage))
(require 'erc-networks)
(require 'erc-backend)
(require 'cl-lib)
(require 'format-spec)
-(require 'pp)
-(require 'thingatpt)
(require 'auth-source)
-(require 'time-date)
-(require 'iso8601)
-(eval-when-compile (require 'subr-x) (require 'url-parse))
+(eval-when-compile (require 'subr-x))
-(defconst erc-version "5.5.0.29.1"
+(defconst erc-version "5.6-git"
"This version of ERC.")
(defvar erc-official-location
@@ -87,7 +86,8 @@
("5.3" . "23.1")
("5.4" . "28.1")
("5.4.1" . "29.1")
- ("5.5" . "29.1")))
+ ("5.5" . "29.1")
+ ("5.6" . "30.1")))
(defgroup erc nil
"Emacs Internet Relay Chat client."
@@ -101,7 +101,9 @@
:group 'erc)
(defgroup erc-display nil
- "Settings for how various things are displayed."
+ "Settings controlling how various things are displayed.
+See the customization group `erc-buffers' for display options
+concerning buffers."
:group 'erc)
(defgroup erc-mode-line-and-header nil
@@ -133,12 +135,82 @@
"Running scripts at startup and with /LOAD."
:group 'erc)
-;; Forward declarations
-(defvar erc-message-parsed)
+;; Add `custom-loads' features for group symbols missing from a
+;; supported Emacs version, possibly because they belong to a new ERC
+;; library. These groups all share their library's feature name.
+;;;###autoload(dolist (symbol '( erc-sasl erc-spelling ; 29
+;;;###autoload erc-imenu erc-nicks)) ; 30
+;;;###autoload (custom-add-load symbol symbol))
+
+(defvar erc-message-parsed) ; only known to this file
+
+(defvar erc--msg-props nil
+ "Hash table containing metadata properties for current message.
+Provided by the insertion functions `erc-display-message' and
+`erc-display-msg' while running their modification hooks.
+Initialized when null for each visitation round from function
+parameters and environmental factors, as well as the alist
+`erc--msg-prop-overrides'. Keys are symbols. Values are opaque
+objects, unless otherwise specified. Items present after running
+`erc-insert-post-hook' or `erc-send-post-hook' become text
+properties added to the first character of an inserted message.
+A given message therefore spans the interval extending from one
+set of such properties to the newline before the next (or
+`erc-insert-marker'). As of ERC 5.6, this forms the basis for
+visiting and editing inserted messages. Modules should align
+their markers accordingly. The following properties have meaning
+as of ERC 5.6:
+
+ - `erc--msg': a symbol, guaranteed present; possible values
+ include `unknown', a fallback used by `erc-display-message'; a
+ catalog key, such as `s401' or `finished'; an
+ `erc-display-message' TYPE parameter, like `notice'
+
+ - `erc--cmd': a message's associated IRC command, as read by
+ `erc--get-eq-comparable-cmd'; currently either a symbol, like
+ `PRIVMSG', or a number, like 5, which represents the numeric
+ \"005\"; absent on \"local\" messages, such as simple warnings
+ and help text, and on outgoing messages unless echoed back by
+ the server (assuming future support)
+
+ - `erc--spkr': a string, the nick of the person speaking
+
+ - `erc--ctcp': a CTCP command, like `ACTION'
+
+ - `erc--ts': a timestamp, possibly provided by the server; as of
+ 5.6, a ticks/hertz pair on Emacs 29 and above, and a \"list\"
+ type otherwise; managed by the `stamp' module
+
+ - `erc--ephemeral': a symbol prefixed by or matching a module
+ name; indicates to other modules and members of modification
+ hooks that the current message should not affect stateful
+ operations, such as recording a channel's most recent speaker
+
+This is an internal API, and the selection of related helper
+utilities is fluid and provisional. As of ERC 5.6, see the
+functions `erc--check-msg-prop' and `erc--get-inserted-msg-prop'.")
+
+(defvar erc--msg-prop-overrides nil
+ "Alist of \"message properties\" for populating `erc--msg-props'.
+These override any defaults normally shown to modification hooks
+by `erc-display-msg' and `erc-display-message'. Modules should
+accommodate existing overrides when applicable. Items toward the
+front shadow any that follow. Ignored when `erc--msg-props' is
+already non-nil.")
-(defvar tabbar--local-hlf)
-(defvar motif-version-string)
-(defvar gtk-version-string)
+;; Forward declarations
+(declare-function decoded-time-period "time-date" (time))
+(declare-function iso8601-parse-duration "iso8601" (string))
+(declare-function word-at-point "thingatpt" (&optional no-properties))
+(autoload 'word-at-point "thingatpt") ; for hl-nicks
+
+(declare-function gnutls-negotiate "gnutls" (&rest rest))
+(declare-function socks-open-network-stream "socks" (name buffer host service))
+(declare-function url-host "url-parse" (cl-x))
+(declare-function url-password "url-parse" (cl-x))
+(declare-function url-portspec "url-parse" (cl-x))
+(declare-function url-type "url-parse" (cl-x))
+(declare-function url-user "url-parse" (cl-x))
;; tunable connection and authentication parameters
@@ -237,7 +309,14 @@ node `(auth) Top' and Info node `(erc) auth-source'.")
:type 'boolean)
(defcustom erc-warn-about-blank-lines t
- "Warn the user if they attempt to send a blank line."
+ "Warn the user if they attempt to send a blank line.
+When non-nil, ERC signals a `user-error' upon encountering prompt
+input containing empty or whitespace-only lines. When nil, ERC
+still inhibits sending but does so silently. With the companion
+option `erc-send-whitespace-lines' enabled, ERC sends pending
+input and prints a message in the echo area indicating the amount
+of padding and/or stripping applied, if any. Setting this option
+to nil suppresses such reporting."
:group 'erc
:type 'boolean)
@@ -249,8 +328,8 @@ node `(auth) Top' and Info node `(erc) auth-source'.")
(defcustom erc-inhibit-multiline-input nil
"When non-nil, conditionally disallow input consisting of multiple lines.
Issue an error when the number of input lines submitted for
-sending exceeds this value. The value t means disallow more
-than 1 line of input."
+sending meets or exceeds this value. The value t is synonymous
+with a value of 2 and means disallow more than 1 line of input."
:package-version '(ERC . "5.5")
:group 'erc
:type '(choice integer boolean))
@@ -271,8 +350,13 @@ than 1 line of input."
"If non-nil, hide input prompt upon disconnecting.
To unhide, type something in the input area. Once revealed, a
prompt remains unhidden until the next disconnection. Channel
-prompts are unhidden upon rejoining. See
-`erc-unhide-query-prompt' for behavior concerning query prompts."
+prompts are unhidden upon rejoining. For behavior concerning
+query prompts, see `erc-unhide-query-prompt'. Longtime ERC users
+should note that this option was repurposed in ERC 5.5 because it
+had lain dormant for years after being sidelined in 5.3 when its
+only use in the interactive client was removed. Before then, its
+role was controlling whether `erc-command-indicator' would appear
+alongside echoed slash-command lines."
:package-version '(ERC . "5.5")
:group 'erc-display
:type '(choice (const :tag "Always hide prompt" t)
@@ -309,6 +393,16 @@ If nil, only \"> \" will be shown."
(const "PART")
(const "QUIT")
(const "MODE")
+ (const :tag "Away notices (RPL_AWAY 301)" "301")
+ (const :tag "Self back notice (REP_UNAWAY 305)" "305")
+ (const :tag "Self away notice (REP_NOWAWAY 306)" "306")
+ (const :tag "Channel modes on join (RPL_CHANNELMODEIS 324)" "324")
+ (const :tag "Channel creation time (RPL_CREATIONTIME 329)" "329")
+ (const :tag "Channel no-topic on join (RPL_NOTOPIC 331)" "331")
+ (const :tag "Channel topic on join (RPL_TOPIC 332)" "332")
+ (const :tag "Topic author and time on join (RPL_TOPICWHOTIME 333)" "333")
+ (const :tag "Invitation success notice (RPL_INVITING 341)" "341")
+ (const :tag "Channel member names (353 RPL_NAMEREPLY)" "353")
(repeat :inline t :tag "Others" (string :tag "IRC Message Type"))))
(defcustom erc-hide-list nil
@@ -344,7 +438,7 @@ simply because we do not necessarily receive the QUIT event."
:type 'hook)
(defcustom erc-complete-functions nil
- "These functions get called when the user hits TAB in ERC.
+ "These functions get called when the user hits \\`TAB' in ERC.
Each function in turn is called until one returns non-nil to
indicate it has handled the input."
:group 'erc-hooks
@@ -397,13 +491,14 @@ Functions are passed a buffer as the first argument."
:group 'erc-hooks
:type 'hook)
-
-(defvar-local erc-channel-users nil
+(defvaralias 'erc-channel-users 'erc-channel-members)
+(defvar-local erc-channel-members nil
"Hash table of members in the current channel.
-It associates nicknames with cons cells of the form:
-\(USER . MEMBER-DATA) where USER is a pointer to an
-erc-server-user struct, and MEMBER-DATA is a pointer to an
-erc-channel-user struct.")
+It associates nicknames with cons cells of the form
+\(SERVER-USER . MEMBER-DATA), where SERVER-USER is a
+`erc-server-user' object and MEMBER-DATA is a `erc-channel-user'
+object. Convenient abbreviations for these two components are
+`susr' and `cusr', along with `cmem' for the pair.")
(defvar-local erc-server-users nil
"Hash table of users on the current server.
@@ -510,6 +605,8 @@ See also: `erc-remove-server-user' and
Removes all users in the current channel. This is called by
`erc-server-PART' and `erc-server-QUIT'."
+ (when (erc--target-channel-p erc--target)
+ (setf (erc--target-channel-joined-p erc--target) nil))
(when (and erc-server-connected
(erc-server-process-alive)
(hash-table-p erc-channel-users))
@@ -518,6 +615,53 @@ Removes all users in the current channel. This is called by
erc-channel-users)
(clrhash erc-channel-users)))
+(defmacro erc--define-channel-user-status-compat-getter (name c d)
+ "Define a gv getter for historical `erc-channel-user' status slot NAME.
+Expect NAME to be a string, C to be its traditionally associated
+letter, and D to be its fallback power-of-2 integer for non-ERC
+buffers."
+ `(defun ,(intern (concat "erc-channel-user-" name)) (u)
+ ,(format "Get equivalent of pre-5.6 `%s' slot for `erc-channel-user'."
+ name)
+ (declare (gv-setter (lambda (v)
+ (macroexp-let2 nil v v
+ (,'\`(let ((val (erc-channel-user-status ,',u))
+ (n (or (erc--get-prefix-flag ,c) ,d)))
+ (setf (erc-channel-user-status ,',u)
+ (if ,',v
+ (logior val n)
+ (logand val (lognot n))))
+ ,',v))))))
+ (let ((n (or (erc--get-prefix-flag ,c) ,d)))
+ (= n (logand n (erc-channel-user-status u))))))
+
+(erc--define-channel-user-status-compat-getter "voice" ?v 1)
+(erc--define-channel-user-status-compat-getter "halfop" ?h 2)
+(erc--define-channel-user-status-compat-getter "op" ?o 4)
+(erc--define-channel-user-status-compat-getter "admin" ?a 8)
+(erc--define-channel-user-status-compat-getter "owner" ?q 16)
+
+;; This is a generalized version of the compat-oriented getters above.
+(defun erc--cusr-status-p (nick-or-cusr letter)
+ "Return non-nil if NICK-OR-CUSR has channel membership status LETTER."
+ (and-let* ((cusr (or (and (erc-channel-user-p nick-or-cusr) nick-or-cusr)
+ (cdr (erc-get-channel-member nick-or-cusr))))
+ (n (erc--get-prefix-flag letter)))
+ (= n (logand n (erc-channel-user-status cusr)))))
+
+(defun erc--cusr-change-status (nick-or-cusr letter enablep &optional resetp)
+ "Add or remove membership status associated with LETTER for NICK-OR-CUSR.
+With RESETP, clear the user's status info completely. If ENABLEP
+is non-nil, add the status value associated with LETTER."
+ (when-let ((cusr (or (and (erc-channel-user-p nick-or-cusr) nick-or-cusr)
+ (cdr (erc-get-channel-member nick-or-cusr))))
+ (n (erc--get-prefix-flag letter)))
+ (cl-callf (lambda (v)
+ (if resetp
+ (if enablep n 0)
+ (if enablep (logior v n) (logand v (lognot n)))))
+ (erc-channel-user-status cusr))))
+
(defun erc-channel-user-owner-p (nick)
"Return non-nil if NICK is an owner of the current channel."
(and nick
@@ -650,9 +794,9 @@ See also: `erc-get-channel-user-list'."
"A topic string for the channel. Should only be used in channel-buffers.")
(defvar-local erc-channel-modes nil
- "List of strings representing channel modes.
-E.g. (\"i\" \"m\" \"s\" \"b Quake!*@*\")
-\(not sure the ban list will be here, but why not)")
+ "List of letters, as strings, representing channel modes.
+For example, (\"i\" \"m\" \"s\"). Modes that take accompanying
+parameters are not included.")
(defvar-local erc-insert-marker nil
"The place where insertion of new text in erc buffers should happen.")
@@ -669,7 +813,74 @@ E.g. (\"i\" \"m\" \"s\" \"b Quake!*@*\")
(defcustom erc-prompt "ERC>"
"Prompt used by ERC. Trailing whitespace is not required."
:group 'erc-display
- :type '(choice string function))
+ :type '(choice string
+ (function-item :tag "Interpret format specifiers"
+ erc-prompt-format)
+ function))
+
+(defvar erc--prompt-format-face-example
+ #("%p%m%a\u00b7%b>"
+ 0 2 (font-lock-face erc-my-nick-prefix-face)
+ 2 4 (font-lock-face font-lock-keyword-face)
+ 4 6 (font-lock-face erc-error-face)
+ 6 7 (font-lock-face shadow)
+ 7 9 (font-lock-face font-lock-constant-face)
+ 9 10 (font-lock-face shadow))
+ "An example value for option `erc-prompt-format' with faces.")
+
+(defcustom erc-prompt-format erc--prompt-format-face-example
+ "Format string when `erc-prompt' is `erc-prompt-format'.
+ERC recognizes these substitution specifiers:
+
+ %a - away indicator
+ %b - buffer name
+ %t - channel or query target, server domain, or dialed address
+ %S - target@network or buffer name
+ %s - target@server or server
+ %N - current network, like Libera.Chat
+ %p - channel membership prefix, like @ or +
+ %n - current nickname
+ %c - channel modes with args for select modes
+ %C - channel modes with all args
+ %u - user modes
+ %m - channel modes sans args in channels, user modes elsewhere
+ %M - like %m but show nothing in query buffers
+
+To pick your own colors, do something like:
+
+ (setopt erc-prompt-format
+ (concat
+ (propertize \"%b\" \\='font-lock-face \\='erc-input-face)
+ (propertize \"%a\" \\='font-lock-face \\='erc-error-face)))
+
+Please remember that ERC ignores this option completely unless
+the \"parent\" option `erc-prompt' is set to `erc-prompt-format'."
+ :package-version '(ERC . "5.6")
+ :group 'erc-display
+ :type `(choice (const :tag "{Prefix}{Mode}{Away}{MIDDLE DOT}{Buffer}>"
+ ,erc--prompt-format-face-example)
+ string))
+
+(defun erc-prompt-format ()
+ "Make predefined `format-spec' substitutions.
+
+See option `erc-prompt-format' and option `erc-prompt'."
+ (format-spec erc-prompt-format
+ (erc-compat--defer-format-spec-in-buffer
+ (?C erc--channel-modes 3 ",")
+ (?M erc--format-modes 'no-query-p)
+ (?N erc-format-network)
+ (?S erc-format-target-and/or-network)
+ (?a erc--format-away-indicator)
+ (?b buffer-name)
+ (?c erc-format-channel-modes)
+ (?m erc--format-modes)
+ (?n erc-current-nick)
+ (?p erc--format-channel-status-prefix)
+ (?s erc-format-target-and/or-server)
+ (?t erc-format-target)
+ (?u erc--format-user-modes))
+ 'ignore-missing)) ; formerly `only-present'
(defun erc-prompt ()
"Return the input prompt as a string.
@@ -682,28 +893,6 @@ See also the variable `erc-prompt'."
(concat prompt " ")
prompt)))
-(defcustom erc-command-indicator nil
- "Indicator used by ERC for showing commands.
-
-If non-nil, this will be used in the ERC buffer to indicate
-commands (i.e., input starting with a `/').
-
-If nil, the prompt will be constructed from the variable `erc-prompt'."
- :group 'erc-display
- :type '(choice (const nil) string function))
-
-(defun erc-command-indicator ()
- "Return the command indicator prompt as a string.
-
-This only has any meaning if the variable `erc-command-indicator' is non-nil."
- (and erc-command-indicator
- (let ((prompt (if (functionp erc-command-indicator)
- (funcall erc-command-indicator)
- erc-command-indicator)))
- (if (> (length prompt) 0)
- (concat prompt " ")
- prompt))))
-
(defcustom erc-notice-prefix "*** "
"Prefix for all notices."
:group 'erc-display
@@ -881,6 +1070,9 @@ Flooding is sending too much information to the server in too
short of an interval, which may cause the server to terminate the
connection.
+Note that older code conflated rate limiting and line splitting.
+Starting in ERC 5.6, this option no longer influences the latter.
+
See `erc-server-flood-margin' for other flood-related parameters.")
;; Script parameters
@@ -1008,7 +1200,13 @@ user after \"/PART\"."
;; Hooks
(defgroup erc-hooks nil
- "Hook variables for fancy customizations of ERC."
+ "Hooks for ERC.
+Users of the interactive client should be aware that many of
+these hooks have names predating the modern convention of
+conveying abnormality via the \"-function\" suffix. Users should
+likewise be aware that built-in and third-party modules use these
+hooks as well, and some of their variables may be buffer-local in
+particular sessions and/or `let'-bound for spells."
:group 'erc)
(defcustom erc-mode-hook nil
@@ -1018,9 +1216,8 @@ user after \"/PART\"."
:options '(erc-add-scroll-to-bottom))
(defcustom erc-timer-hook nil
- "Put functions which should get called more or less periodically here.
-The idea is that servers always play ping pong with the client, and so there
-is no need for any idle-timer games with Emacs."
+ "Abnormal hook run after each response handler.
+Called with a float returned from `erc-current-time'."
:group 'erc-hooks
:type 'hook)
@@ -1055,41 +1252,54 @@ anyway."
(make-obsolete-variable 'erc-send-pre-hook 'erc-pre-send-functions "27.1")
(defcustom erc-pre-send-functions nil
- "Special hook run to possibly alter the string that is sent.
-The functions are called with one argument, an `erc-input' struct,
-and should alter that struct.
-
-The struct has three slots:
+ "Special hook to possibly alter the string to send and insert.
+ERC calls the member functions with one argument, an `erc-input'
+struct instance to modify as needed.
- `string': The current input string.
- `insertp': Whether the string should be inserted into the erc buffer.
- `sendp': Whether the string should be sent to the irc server."
- :group 'erc
- :type 'hook
- :version "27.1")
+The struct has five slots:
-;; This is being auditioned for possible exporting (as a custom hook
-;; option). Likewise for (public versions of) `erc--input-split' and
-;; `erc--discard-trailing-multiline-nulls'. If unneeded, we'll just
-;; run the latter on the input after `erc-pre-send-functions', and
-;; remove this hook and the struct completely. IOW, if you need this,
-;; please say so.
+ `string': String to send, originally from prompt input.
+ `insertp': Whether a string should be inserted in the buffer.
+ `sendp': Whether `string' should be sent to the IRC server.
+ `substxt': String to display (but not send) instead of `string'.
+ `refoldp': Whether to re-split `string' per protocol limits.
+
+This hook runs after protocol line splitting has taken place, so
+the value of `string' comes \"pre-split\" according to the option
+`erc-split-line-length'. If you need ERC to refill the entire
+payload before sending it, set the `refoldp' slot to a non-nil
+value. Note that this refilling is only a convenience, and
+modules with special needs, such as preserving \"preformatted\"
+text or encoding for subprotocol \"tunneling\", should handle
+splitting manually and possibly also specify replacement text to
+display via the `substxt' slot."
+ :package-version '(ERC . "5.3")
+ :group 'erc-hooks
+ :type 'hook)
-(defvar erc--pre-send-split-functions '(erc--discard-trailing-multiline-nulls)
- "Special hook for modifying individual lines in multiline prompt input.
-The functions are called with one argument, an `erc--input-split'
-struct, which they can optionally modify.
+(define-obsolete-variable-alias 'erc--pre-send-split-functions
+ 'erc--input-review-functions "30.1")
+(defvar erc--input-review-functions '(erc--split-lines
+ erc--run-input-validation-checks
+ erc--discard-trailing-multiline-nulls
+ erc--inhibit-slash-cmd-insertion)
+ "Special hook for reviewing and modifying prompt input.
+ERC runs this before clearing the prompt and before running any
+send-related hooks, such as `erc-pre-send-functions'. Thus, it's
+quite \"safe\" to bail out of this hook with a `user-error', if
+necessary. The hook's members are called with one argument, an
+`erc--input-split' struct, which they can optionally modify.
The struct has five slots:
- `string': the input string delivered by `erc-pre-send-functions'
- `insertp': whether to insert the lines into the buffer
- `sendp': whether the lines should be sent to the IRC server
+ `string': the original input as a read-only reference
+ `insertp': same as in `erc-pre-send-functions'
+ `sendp': same as in `erc-pre-send-functions'
+ `refoldp': same as in `erc-pre-send-functions'
`lines': a list of lines to be sent, each one a `string'
`cmdp': whether to interpret input as a command, like /ignore
-The `string' field is effectively read-only. When `cmdp' is
-non-nil, all but the first line will be discarded.")
+When `cmdp' is non-nil, all but the first line will be discarded.")
(defvar erc-insert-this t
"Insert the text into the target buffer or not.
@@ -1106,9 +1316,13 @@ if they wish to avoid sending of a particular string.")
"Insertion hook for functions that will change the text's appearance.
This hook is called just after `erc-insert-pre-hook' when the value
of `erc-insert-this' is t.
-While this hook is run, narrowing is in effect and `current-buffer' is
-the buffer where the text got inserted. One possible value to add here
-is `erc-fill'."
+
+ERC runs this hook with the buffer narrowed to the bounds of the
+inserted message plus a trailing newline. Built-in modules place
+their hook members in two depth ranges: the first between -80 and
+-20 and the second between 20 and 80. Use the functions
+`erc-find-parsed-property' and `erc-get-parsed-vector' to locate
+and extract the `erc-response' object for the inserted message."
:group 'erc-hooks
:type 'hook)
@@ -1131,8 +1345,8 @@ preserve point if needed."
(defcustom erc-send-modify-hook nil
"Sending hook for functions that will change the text's appearance.
-This hook is called just after `erc-send-pre-hook' when the values
-of `erc-send-this' and `erc-insert-this' are both t.
+ERC runs this just after `erc-pre-send-functions' if its shared
+`erc-input' object's `sendp' and `insertp' slots remain non-nil.
While this hook is run, narrowing is in effect and `current-buffer' is
the buffer where the text got inserted.
@@ -1189,7 +1403,6 @@ which the local user typed."
(define-key map [home] #'erc-bol)
(define-key map "\C-c\C-a" #'erc-bol)
(define-key map "\C-c\C-b" #'erc-switch-to-buffer)
- (define-key map "\C-c\C-c" #'erc-toggle-interpret-controls)
(define-key map "\C-c\C-d" #'erc-input-action)
(define-key map "\C-c\C-e" #'erc-toggle-ctcp-autoresponse)
(define-key map "\C-c\C-f" #'erc-toggle-flood-control)
@@ -1204,7 +1417,7 @@ which the local user typed."
(define-key map "\C-c\C-u" #'erc-kill-input)
(define-key map "\C-c\C-x" #'erc-quit-server)
(define-key map "\M-\t" #'ispell-complete-word)
- (define-key map "\t" #'completion-at-point)
+ (define-key map "\t" #'erc-tab)
;; Suppress `font-lock-fontify-block' key binding since it
;; destroys face properties.
@@ -1213,6 +1426,19 @@ which the local user typed."
map)
"ERC keymap.")
+(defun erc--modify-local-map (mode &rest bindings)
+ "Modify `erc-mode-map' on behalf of a global module.
+Add or remove `key-valid-p' BINDINGS when toggling MODE."
+ (declare (indent 1))
+ (while (pcase-let* ((`(,key ,def . ,rest) bindings)
+ (existing (keymap-lookup erc-mode-map key)))
+ (if mode
+ (when (or (not existing) (eq existing #'undefined))
+ (keymap-set erc-mode-map key def))
+ (when (eq existing def)
+ (keymap-unset erc-mode-map key t)))
+ (setq bindings rest))))
+
;; Faces
; Honestly, I have a horrible sense of color and the "defaults" below
@@ -1260,21 +1486,20 @@ This will only be used if `erc-header-line-face-method' is non-nil."
"ERC face for the prompt."
:group 'erc-faces)
-(defface erc-command-indicator-face
- '((t :weight bold))
- "ERC face for the command indicator.
-See the variable `erc-command-indicator'."
- :group 'erc-faces)
-
(defface erc-notice-face
'((default :weight bold)
+ (((class color) (min-colors 88) (supports :weight semi-bold))
+ :weight semi-bold :foreground "SlateBlue")
(((class color) (min-colors 88)) :foreground "SlateBlue")
(t :foreground "blue"))
"ERC face for notices."
+ :package-version '(ERC . "5.6")
:group 'erc-faces)
-(defface erc-action-face '((t :weight bold))
+(defface erc-action-face '((((supports :weight semi-bold)) :weight semi-bold)
+ (t :weight bold))
"ERC face for actions generated by /ME."
+ :package-version '(ERC . "5.6")
:group 'erc-faces)
(defface erc-error-face '((t :foreground "red"))
@@ -1297,9 +1522,8 @@ See also `erc-show-my-nick'."
;; Debugging support
-(defvar erc-log-p nil
- "When set to t, generate debug messages in a separate debug buffer.")
-
+;; FIXME if this variable plays some role, indicate that here.
+;; Otherwise, deprecate.
(defvar erc-debug-log-file (expand-file-name "ERC.debug")
"Debug log file name.")
@@ -1313,6 +1537,21 @@ See also `erc-show-my-nick'."
Bound to local variables from an existing (logical) session's
buffer during local-module setup and `erc-mode-hook' activation.")
+(defmacro erc--restore-initialize-priors (mode &rest vars)
+ "Restore local VARS for local minor MODE from a previous session."
+ (declare (indent 1))
+ (let ((priors (make-symbol "priors"))
+ (initp (make-symbol "initp"))
+ ;;
+ forms)
+ (while-let ((k (pop vars)))
+ (push `(,k (if ,initp (alist-get ',k ,priors) ,(pop vars))) forms))
+ `(let* ((,priors (or erc--server-reconnecting erc--target-priors))
+ (,initp (and ,priors (alist-get ',mode ,priors))))
+ (unless (local-variable-if-set-p ',mode)
+ (error "Not a local minor mode var: %s" ',mode))
+ (setq ,@(mapcan #'identity (nreverse forms))))))
+
(defun erc--target-from-string (string)
"Construct an `erc--target' variant from STRING."
(funcall (if (erc-channel-p string)
@@ -1322,16 +1561,6 @@ buffer during local-module setup and `erc-mode-hook' activation.")
#'make-erc--target)
:string string :symbol (intern (erc-downcase string))))
-(defvar-local erc--target nil
- "Info about a buffer's target, if any.")
-
-;; Temporary internal getter to ease transition to `erc--target'
-;; everywhere. Will be replaced by updated `erc-default-target'.
-(defun erc--default-target ()
- "Return target string or nil."
- (when erc--target
- (erc--target-string erc--target)))
-
(defun erc-once-with-server-event (event f)
"Run function F the next time EVENT occurs in the `current-buffer'.
@@ -1348,7 +1577,7 @@ Please be sure to use this function in server-buffers. In
channel-buffers it may not work at all, as it uses the LOCAL
argument of `add-hook' and `remove-hook' to ensure multiserver
capabilities."
- (unless (erc-server-buffer-p)
+ (unless (erc--server-buffer-p)
(error
"You should only run `erc-once-with-server-event' in a server buffer"))
(let ((fun (make-symbol "fun"))
@@ -1362,6 +1591,37 @@ capabilities."
(add-hook hook fun nil t)
fun))
+(defun erc--warn-once-before-connect (mode-var &rest args)
+ "Display an \"error notice\" once.
+Expect ARGS to be `erc-button--display-error-notice-with-keys'
+compatible parameters, except without any leading buffers or
+processes. If we're in an ERC buffer with a network process when
+called, print the notice immediately. Otherwise, if we're in a
+server buffer, arrange to do so after local modules have been set
+up and mode hooks have run. Otherwise, if MODE-VAR is a global
+module, try again at most once the next time `erc-mode-hook'
+runs."
+ (declare (indent 1))
+ (cl-assert (stringp (car args)))
+ (if (derived-mode-p 'erc-mode)
+ (unless (or (erc-with-server-buffer ; needs `erc-server-process'
+ (apply #'erc-button--display-error-notice-with-keys
+ (current-buffer) args)
+ t)
+ erc--target) ; unlikely
+ (let (hook)
+ (setq hook
+ (lambda (_)
+ (remove-hook 'erc-connect-pre-hook hook t)
+ (apply #'erc-button--display-error-notice-with-keys args)))
+ (add-hook 'erc-connect-pre-hook hook nil t)))
+ (when (custom-variable-p mode-var)
+ (let (hook)
+ (setq hook (lambda ()
+ (remove-hook 'erc-mode-hook hook)
+ (apply #'erc--warn-once-before-connect 'erc-fake args)))
+ (add-hook 'erc-mode-hook hook)))))
+
(defun erc-server-buffer ()
"Return the server buffer for the current buffer's process.
The buffer-local variable `erc-server-process' is used to find
@@ -1374,29 +1634,36 @@ the process buffer."
(and (processp erc-server-process)
(buffer-live-p (process-buffer erc-server-process))))
-(defun erc-server-buffer-p (&optional buffer)
+(define-obsolete-function-alias
+ 'erc-server-buffer-p 'erc-server-or-unjoined-channel-buffer-p "30.1")
+(defun erc-server-or-unjoined-channel-buffer-p (&optional buffer)
"Return non-nil if argument BUFFER is an ERC server buffer.
-
-If BUFFER is nil, the current buffer is used."
+If BUFFER is nil, use the current buffer. For historical
+reasons, also return non-nil for channel buffers the client has
+parted or from which it's been kicked."
(with-current-buffer (or buffer (current-buffer))
(and (eq major-mode 'erc-mode)
(null (erc-default-target)))))
+(defun erc--server-buffer-p (&optional buffer)
+ "Return non-nil if BUFFER is an ERC server buffer.
+Without BUFFER, use the current buffer."
+ (if buffer
+ (with-current-buffer buffer
+ (and (eq major-mode 'erc-mode) (null erc--target)))
+ (and (eq major-mode 'erc-mode) (null erc--target))))
+
(defun erc-open-server-buffer-p (&optional buffer)
"Return non-nil if BUFFER is an ERC server buffer with an open IRC process.
If BUFFER is nil, the current buffer is used."
- (and (erc-server-buffer-p buffer)
+ (and (erc--server-buffer-p buffer)
(erc-server-process-alive buffer)))
(defun erc-query-buffer-p (&optional buffer)
"Return non-nil if BUFFER is an ERC query buffer.
If BUFFER is nil, the current buffer is used."
- (with-current-buffer (or buffer (current-buffer))
- (let ((target (erc-default-target)))
- (and (eq major-mode 'erc-mode)
- target
- (not (memq (aref target 0) '(?# ?& ?+ ?!)))))))
+ (not (erc-channel-p (or buffer (current-buffer)))))
(defun erc-ison-p (nick)
"Return non-nil if NICK is online."
@@ -1454,6 +1721,7 @@ Defaults to the server buffer."
(setq-local paragraph-start
(concat "\\(" (regexp-quote (erc-prompt)) "\\)"))
(setq-local completion-ignore-case t)
+ (add-hook 'post-command-hook #'erc-check-text-conversion nil t)
(add-hook 'kill-buffer-hook #'erc-kill-buffer-function nil t)
(add-hook 'completion-at-point-functions #'erc-complete-word-at-point nil t))
@@ -1462,15 +1730,33 @@ Defaults to the server buffer."
(defconst erc-default-server "irc.libera.chat"
"IRC server to use if it cannot be detected otherwise.")
-(defconst erc-default-port 6667
+(defvar erc-default-port 6667
"IRC port to use if it cannot be detected otherwise.")
(defconst erc-default-port-tls 6697
"IRC port to use for encrypted connections if it cannot be \
detected otherwise.")
-(defcustom erc-join-buffer 'bury
- "Determines how to display a newly created IRC buffer.
+(defconst erc--buffer-display-choices
+ `(choice (const :tag "Use value of `erc-buffer-display'" nil)
+ (const :tag "Split window and select" window)
+ (const :tag "Split window but don't select" window-noselect)
+ (const :tag "New frame" frame)
+ (const :tag "Don't display" bury)
+ (const :tag "Use current window" buffer)
+ (choice :tag "Defer to a display function"
+ (function-item display-buffer)
+ (function-item pop-to-buffer)
+ (function :tag "User-defined")))
+ "Common choices for buffer-display options.")
+
+(defvaralias 'erc-join-buffer 'erc-buffer-display)
+(defcustom erc-buffer-display 'bury
+ "How to display a newly created ERC buffer.
+This determines ERC's baseline, \"catch-all\" buffer-display
+behavior. It takes a backseat to more specific options, like
+`erc-interactive-display', `erc-auto-reconnect-display', and
+`erc-receive-query-display'.
The available choices are:
@@ -1479,41 +1765,93 @@ The available choices are:
`frame' - in another frame,
`bury' - bury it in a new buffer,
`buffer' - in place of the current buffer,
- any other value - in place of the current buffer."
+ DISPLAY-FUNCTION - a `display-buffer'-like function
+
+Here, DISPLAY-FUNCTION should accept a buffer and an ACTION of
+the kind described by the Info node `(elisp) Choosing Window'.
+At times, ERC may add hints about the calling context to the
+ACTION's alist. Keys are symbols such as user options, like
+`erc-buffer-display', or module minor modes, like
+`erc-autojoin-mode'. Values are non-nil constants specific to
+each. For this particular option, possible values include the
+symbols
+
+ `JOIN', `PRIVMSG', `NOTICE', `erc', and `erc-tls'.
+
+The first three signify IRC commands received from the server and
+the rest entry-point commands responsible for the connection.
+When dealing with the latter two, users may prefer to set this
+option to `bury' and instead call DISPLAY-FUNCTION directly
+on (server) buffers returned by these entry points because the
+context leading to their creation is plainly obvious. For
+additional details, see the Info node `(erc) display-buffer'.
+
+Note that when the selected window already shows the current
+buffer, ERC pretends this option's value is `bury' unless the
+variable `erc-skip-displaying-selected-window-buffer' is nil or
+the value of this option is DISPLAY-FUNCTION."
:package-version '(ERC . "5.5")
:group 'erc-buffers
- :type '(choice (const :tag "Split window and select" window)
- (const :tag "Split window, don't select" window-noselect)
- (const :tag "New frame" frame)
- (const :tag "Bury in new buffer" bury)
- (const :tag "Use current buffer" buffer)
- (const :tag "Use current buffer" t)))
-
-(defcustom erc-reconnect-display nil
- "How (and whether) to display a channel buffer upon reconnecting.
-
-This only affects automatic reconnections and is ignored when
-issuing a /reconnect command or reinvoking `erc-tls' with the
-same args (assuming success, of course). See `erc-join-buffer'
-for a description of possible values.
-
-WARNING: this option is bugged in ERC 5.5 (Emacs 29). Setting it
-to anything other than nil results in the chosen value being
-permanently adopted by all other buffer-display options for the
-remainder of the ERC session. If you need this fixed
-immediately, see Info node `(erc) Upgrading'."
+ :type (cons 'choice (nthcdr 2 erc--buffer-display-choices)))
+
+(defvaralias 'erc-query-display 'erc-interactive-display)
+(defcustom erc-interactive-display 'window
+ "How to display buffers as a result of user interaction.
+This affects commands like /QUERY and /JOIN when issued
+interactively at the prompt. It does not apply when calling a
+handler for such a command, like `erc-cmd-JOIN', from lisp code.
+See `erc-buffer-display' for a full description of available
+values.
+
+When the value is a user-provided function, ERC may inject a hint
+about the invocation context as an extra item in the \"action
+alist\" included as part of the second argument. The item's key
+is the symbol `erc-interactive-display' and its value one of
+
+ `/QUERY', `/JOIN', `/RECONNECT', `url', `erc', or `erc-tls'.
+
+All are symbols indicating an inciting user action, such as the
+issuance of a slash command, the clicking of a URL hyperlink, or
+the invocation of an entry-point command. See Info node `(erc)
+display-buffer' for more."
+ :package-version '(ERC . "5.6")
+ :group 'erc-buffers
+ :type erc--buffer-display-choices)
+
+(defvaralias 'erc-reconnect-display 'erc-auto-reconnect-display)
+(defcustom erc-auto-reconnect-display nil
+ "How to display a channel buffer when automatically reconnecting.
+ERC ignores this option when a user issues a /RECONNECT or
+successfully reinvokes `erc-tls' with similar arguments to those
+from the prior connection. See `erc-buffer-display' for a
+description of possible values.
+
+When the value is function, ERC may inject a hint about the
+calling context as an extra item in the alist making up the tail
+of the second, \"action\" argument. The item's key is the symbol
+`erc-auto-reconnect-display' and its value something non-nil."
:package-version '(ERC . "5.5")
:group 'erc-buffers
- :set (lambda (sym val)
- (when (set sym val)
- (lwarn 'erc :warning "Setting `%s' to `%s' is currently bugged; %s"
- sym val "see doc string for more information.")))
- :type '(choice (const :tag "Use value of `erc-join-buffer'" nil)
- (const :tag "Split window and select" window)
- (const :tag "Split window, don't select" window-noselect)
- (const :tag "New frame" frame)
- (const :tag "Bury in new buffer" bury)
- (const :tag "Use current buffer" buffer)))
+ :type erc--buffer-display-choices)
+
+(defcustom erc-auto-reconnect-display-timeout 10
+ "Duration `erc-auto-reconnect-display' remains active.
+The countdown starts on MOTD and is canceled early by any
+\"slash\" command."
+ :package-version '(ERC . "5.6")
+ :type 'integer
+ :group 'erc-buffers)
+
+(defcustom erc-reconnect-display-server-buffers nil
+ "Apply buffer-display options to server buffers when reconnecting.
+By default, ERC does not consider `erc-auto-reconnect-display'
+for server buffers when automatically reconnecting, nor does it
+consider `erc-interactive-display' when users issue a /RECONNECT.
+Enabling this tells ERC to always display server buffers
+according to those options."
+ :package-version '(ERC . "5.6")
+ :type 'boolean
+ :group 'erc-buffers)
(defcustom erc-frame-alist nil
"Alist of frame parameters for creating erc frames.
@@ -1531,20 +1869,29 @@ This only has effect when `erc-join-buffer' is set to `frame'."
(defcustom erc-reuse-frames t
"Determines whether new frames are always created.
-Non-nil means that a new frame is not created to display an ERC
-buffer if there is already a window displaying it. This only has
-effect when `erc-join-buffer' is set to `frame'."
+Non-nil means only create a frame for undisplayed buffers. Nil
+means always create a new frame. Regardless of its value, ERC
+ignores this option unless `erc-join-buffer' is `frame'. And
+like most options in the `erc-buffer' customize group, this has
+no effect on server buffers while reconnecting because ERC always
+buries those."
:group 'erc-buffers
:type 'boolean)
-(defun erc-channel-p (channel)
- "Return non-nil if CHANNEL seems to be an IRC channel name."
- (cond ((stringp channel)
- (memq (aref channel 0) '(?# ?& ?+ ?!)))
- ((and (bufferp channel) (buffer-live-p channel))
- (with-current-buffer channel
- (erc-channel-p (erc-default-target))))
- (t nil)))
+(defvar erc--fallback-channel-prefixes "#&"
+ "Prefix chars for distinguishing channel targets when CHANTYPES is unknown.")
+
+(defun erc-channel-p (target)
+ "Return non-nil if TARGET is a valid channel name or a channel buffer."
+ (cond ((stringp target)
+ (and-let*
+ (((not (string-empty-p target)))
+ (value (let ((entry (erc--get-isupport-entry 'CHANTYPES)))
+ (if entry (cadr entry) erc--fallback-channel-prefixes)))
+ ((erc--strpos (aref target 0) value)))))
+ ((and-let* (((buffer-live-p target))
+ (target (buffer-local-value 'erc--target target))
+ ((erc--target-channel-p target)))))))
;; For the sake of compatibility, a historical quirk concerning this
;; option, when nil, has been preserved: all buffers are suffixed with
@@ -1680,7 +2027,10 @@ All strings are compared according to IRC protocol case rules, see
(defun erc-get-buffer (target &optional proc)
"Return the buffer matching TARGET in the process PROC.
-If PROC is not supplied, all processes are searched."
+Without PROC, search all ERC buffers. For historical reasons,
+skip buffers for channels the client has \"PART\"ed or from which
+it's been \"KICK\"ed. Expect users to use a different function
+for finding targets independent of \"JOIN\"edness."
(let ((downcased-target (erc-downcase target)))
(catch 'buffer
(erc-buffer-filter
@@ -1701,8 +2051,9 @@ If PROC is not supplied, all processes are searched."
(defun erc-buffer-filter (predicate &optional proc)
"Return a list of `erc-mode' buffers matching certain criteria.
-PREDICATE is a function executed with each buffer, if it returns t, that buffer
-is considered a valid match.
+Call PREDICATE without arguments in all ERC buffers or only those
+belonging to a non-nil PROC. Expect it to return non-nil in
+buffers that should be included in the returned list.
PROC is either an `erc-server-process', identifying a certain
server connection, or nil which means all open connections."
@@ -1714,15 +2065,20 @@ server connection, or nil which means all open connections."
(erc--buffer-p buf predicate proc)))
(buffer-list)))))
+(defalias 'erc-buffer-do 'erc-buffer-filter
+ "Call FUNCTION in all ERC buffers or only those for PROC.
+Expect to be preferred over `erc-buffer-filter' in cases where
+the return value goes unused.
+
+\(fn FUNCTION &optional PROC)")
+
(defun erc-buffer-list (&optional predicate proc)
"Return a list of ERC buffers.
PREDICATE is a function which executes with every buffer satisfying
the predicate. If PREDICATE is passed as nil, return a list of all ERC
buffers. If PROC is given, the buffers local variable `erc-server-process'
needs to match PROC."
- (unless predicate
- (setq predicate (lambda () t)))
- (erc-buffer-filter predicate proc))
+ (erc-buffer-filter (or predicate #'always) proc))
(define-obsolete-function-alias 'erc-iswitchb #'erc-switch-to-buffer "25.1")
(defun erc--switch-to-buffer (&optional arg)
@@ -1826,51 +2182,77 @@ buffer rather than a server buffer.")
;; each item is in the format '(old . new)
(delete-dups (mapcar #'erc--normalize-module-symbol mods)))
-(defcustom erc-modules '(netsplit fill button match track completion readonly
- networks ring autojoin noncommands irccontrols
- move-to-prompt stamp menu list)
- "A list of modules which ERC should enable.
-If you set the value of this without using `customize' remember to call
-\(erc-update-modules) after you change it. When using `customize', modules
-removed from the list will be disabled."
+(defun erc--sort-modules (modules)
+ "Return a copy of MODULES, deduped and led by sorted built-ins."
+ (let (built-in third-party)
+ (dolist (mod modules)
+ (setq mod (erc--normalize-module-symbol mod))
+ (cl-pushnew mod (if (get mod 'erc--module) built-in third-party)))
+ `(,@(sort built-in #'string-lessp) ,@(nreverse third-party))))
+
+;;;###autoload(custom-autoload 'erc-modules "erc")
+
+(defcustom erc-modules '( autojoin button completion fill imenu irccontrols
+ list match menu move-to-prompt netsplit
+ networks readonly ring stamp track)
+ "Modules to enable while connecting.
+When modifying this option in lisp code, use a Custom-friendly
+facilitator, like `setopt', or call `erc-update-modules'
+afterward. This ensures a consistent ordering and disables
+removed modules. It also gives packages access to the hook
+`erc-before-connect'."
:get (lambda (sym)
;; replace outdated names with their newer equivalents
(erc-migrate-modules (symbol-value sym)))
- :initialize #'custom-initialize-default
+ ;; Expect every built-in module to have the symbol property
+ ;; `erc--module' set to its canonical symbol (often itself).
+ :initialize (lambda (symbol exp)
+ ;; Use `cdddr' because (set :greedy t . ,entries)
+ (dolist (entry (cdddr (get 'erc-modules 'custom-type)))
+ (when-let* (((eq (car entry) 'const))
+ (s (cadddr entry))) ; (const :tag "..." ,s)
+ (put s 'erc--module s)))
+ (custom-initialize-reset symbol exp))
:set (lambda (sym val)
;; disable modules which have just been removed
(when (and (boundp 'erc-modules) erc-modules val)
(dolist (module erc-modules)
- (unless (member module val)
+ (unless (memq module val)
(let ((f (intern-soft (format "erc-%s-mode" module))))
(when (and (fboundp f) (boundp f))
(when (symbol-value f)
(message "Disabling `erc-%s'" module)
(funcall f 0))
+ ;; Disable local module in all ERC buffers.
(unless (or (custom-variable-p f)
(not (fboundp 'erc-buffer-filter)))
(erc-buffer-filter (lambda ()
(when (symbol-value f)
(funcall f 0))
(kill-local-variable f)))))))))
- (set sym val)
- ;; this test is for the case where erc hasn't been loaded yet
+ ;; Calling `set-default-toplevel-value' complicates testing.
+ (set sym (erc--sort-modules val))
+ ;; Don't initialize modules on load, even though the rare
+ ;; third-party module may need it.
(when (fboundp 'erc-update-modules)
- (erc-update-modules)))
+ (unless erc--inside-mode-toggle-p
+ (erc-update-modules))))
:type
'(set
:greedy t
(const :tag "autoaway: Set away status automatically" autoaway)
(const :tag "autojoin: Join channels automatically" autojoin)
+ (const :tag "bufbar: Show ERC buffers in a side window" bufbar)
(const :tag "button: Buttonize URLs, nicknames, and other text" button)
(const :tag "capab: Mark unidentified users on servers supporting CAPAB"
capab-identify)
+ (const :tag "command-indicator: Echo command lines." command-indicator)
(const :tag "completion: Complete nicknames and commands (programmable)"
completion)
- (const :tag "hecomplete: Complete nicknames and commands (obsolete, use \"completion\")" hecomplete)
(const :tag "dcc: Provide Direct Client-to-Client support" dcc)
(const :tag "fill: Wrap long lines" fill)
(const :tag "identd: Launch an identd server on port 8113" identd)
+ (const :tag "imenu: A simple Imenu integration" imenu)
(const :tag "irccontrols: Highlight or remove IRC control characters"
irccontrols)
(const :tag "keep-place: Leave point above un-viewed text" keep-place)
@@ -1882,13 +2264,15 @@ removed from the list will be disabled."
move-to-prompt)
(const :tag "netsplit: Detect netsplits" netsplit)
(const :tag "networks: Provide data about IRC networks" networks)
- (const :tag "noncommands: Don't display non-IRC commands after evaluation"
+ (const :tag "nickbar: Show nicknames in a dynamic side window" nickbar)
+ (const :tag "nicks: Uniquely colorize nicknames in target buffers" nicks)
+ (const :tag "noncommands: Deprecated. See module `command-indicator'."
noncommands)
+ (const :tag "notifications: Desktop alerts on PRIVMSG or mentions"
+ notifications)
(const :tag
"notify: Notify when the online status of certain users changes"
notify)
- (const :tag "notifications: Send notifications on PRIVMSG or nickname mentions"
- notifications)
(const :tag "page: Process CTCP PAGE requests from IRC" page)
(const :tag "readonly: Make displayed lines read-only" readonly)
(const :tag "replace: Replace text in messages" replace)
@@ -1901,40 +2285,130 @@ removed from the list will be disabled."
(const :tag "smiley: Convert smileys to pretty icons" smiley)
(const :tag "sound: Play sounds when you receive CTCP SOUND requests"
sound)
- (const :tag "stamp: Add timestamps to messages" stamp)
(const :tag "spelling: Check spelling" spelling)
+ (const :tag "stamp: Add timestamps to messages" stamp)
(const :tag "track: Track channel activity in the mode-line" track)
(const :tag "truncate: Truncate buffers to a certain size" truncate)
(const :tag "unmorse: Translate morse code in messages" unmorse)
(const :tag "xdcc: Act as an XDCC file-server" xdcc)
(repeat :tag "Others" :inline t symbol))
+ :package-version '(ERC . "5.6")
:group 'erc)
(defun erc-update-modules ()
"Enable minor mode for every module in `erc-modules'.
Except ignore all local modules, which were introduced in ERC 5.5."
- (erc--update-modules)
+ (erc--update-modules erc-modules)
nil)
-(defun erc--update-modules ()
+(defvar erc--aberrant-modules nil
+ "Modules suspected of being improperly loaded.")
+
+(defun erc--warn-about-aberrant-modules ()
+ (when (and erc--aberrant-modules (not erc--target))
+ (erc-button--display-error-notice-with-keys-and-warn
+ "The following modules likely engage in unfavorable loading practices: "
+ (mapconcat (lambda (s) (format "`%s'" s)) erc--aberrant-modules ", ")
+ ". Please contact ERC with \\[erc-bug] if you believe this to be untrue."
+ " See Info:\"(erc) Module Loading\" for more.")
+ (setq erc--aberrant-modules nil)))
+
+(defvar erc--requiring-module-mode-p nil
+ "Non-nil while doing (require \\='erc-mymod) for `mymod' in `erc-modules'.
+Used for inhibiting potentially recursive `erc-update-modules'
+invocations by third-party packages.")
+
+(defun erc--find-mode (sym)
+ (setq sym (erc--normalize-module-symbol sym))
+ (if-let ((mode (intern-soft (concat "erc-" (symbol-name sym) "-mode")))
+ ((and (fboundp mode)
+ (autoload-do-load (symbol-function mode) mode)))
+ ((or (get sym 'erc--module)
+ (symbol-file mode)
+ (ignore (cl-pushnew sym erc--aberrant-modules)))))
+ mode
+ (and (or (and erc--requiring-module-mode-p
+ ;; Also likely non-nil: (eq sym (car features))
+ (cl-pushnew sym erc--aberrant-modules))
+ (let ((erc--requiring-module-mode-p t))
+ (require (or (get sym 'erc--feature)
+ (intern (concat "erc-" (symbol-name sym))))
+ nil 'noerror))
+ (memq sym erc--aberrant-modules))
+ (or mode (setq mode (intern-soft (concat "erc-" (symbol-name sym)
+ "-mode"))))
+ (fboundp mode)
+ mode)))
+
+(defun erc--update-modules (modules)
(let (local-modes)
- (dolist (module erc-modules local-modes)
- (require (or (alist-get module erc--modules-to-features)
- (intern (concat "erc-" (symbol-name module))))
- nil 'noerror) ; some modules don't have a corresponding feature
- (let ((mode (intern-soft (concat "erc-" (symbol-name module) "-mode"))))
- (unless (and mode (fboundp mode))
- (error "`%s' is not a known ERC module" module))
- (if (custom-variable-p mode)
- (funcall mode 1)
- (push mode local-modes))))))
+ (dolist (module modules local-modes)
+ (if-let ((mode (erc--find-mode module)))
+ (if (custom-variable-p mode)
+ (funcall mode 1)
+ (push mode local-modes))
+ (error "`%s' is not a known ERC module" module)))))
+
+(defvar erc--updating-modules-p nil
+ "Non-nil when running `erc--update-modules' in `erc-open'.
+This allows global modules with known or likely dependents (or
+some other reason for activating after session initialization) to
+conditionally run setup code traditionally reserved for
+`erc-mode-hook' in the setup portion of their mode toggle. Note
+that being \"global\", they'll likely want to do so in all ERC
+buffers and ensure the code is idempotent. For example:
+
+ (add-hook \\='erc-mode-hook #\\='erc-foo-setup-fn)
+ (unless erc--updating-modules-p
+ (erc-with-all-buffers-of-server nil
+ (lambda () some-condition-p)
+ (erc-foo-setup-fn)))
+
+This means that when a dependent module is initializing and
+realizes it's missing some required module \"foo\", it can
+confidently call (erc-foo-mode 1) without having to learn
+anything about the dependency's implementation.")
+
+(defvar erc--setup-buffer-hook '(erc--warn-about-aberrant-modules)
+ "Internal hook for module setup involving windows and frames.")
+
+(defvar erc--display-context nil
+ "Extra action alist items passed to `display-buffer'.
+Non-nil when a user specifies a custom display action for certain
+buffer-display options, like `erc-auto-reconnect-display'. ERC
+pairs the option's symbol with a context-dependent value and adds
+the entry to the user-provided alist when calling `pop-to-buffer'
+or `display-buffer'.")
+
+(defvar erc-skip-displaying-selected-window-buffer t
+ "Whether to forgo showing a buffer that's already being displayed.
+But only in the selected window. This is intended as a crutch
+for non-user third-party code that might be slow to adopt the
+`display-buffer' function variant available to all buffer-display
+options starting in ERC 5.6. Users with rare requirements, like
+wanting to change the window buffer to something other than the
+one being processed, should see the Info node `(erc)
+display-buffer'.")
+(make-obsolete 'erc-show-already-displayed-buffer
+ "non-nil behavior to be made permanent" "30.1")
+
+(defvar-local erc--display-buffer-overriding-action nil
+ "The value of `display-buffer-overriding-action' when non-nil.
+Influences the displaying of new or reassociated ERC buffers.
+Reserved for use by built-in modules.")
(defun erc-setup-buffer (buffer)
"Consults `erc-join-buffer' to find out how to display `BUFFER'."
(pcase (if (zerop (erc-with-server-buffer
erc--server-last-reconnect-count))
erc-join-buffer
- (or erc-reconnect-display erc-join-buffer))
+ (or erc-auto-reconnect-display erc-join-buffer))
+ ((and (pred functionp) disp-fn (let context erc--display-context))
+ (unless (zerop erc--server-last-reconnect-count)
+ (push '(erc-auto-reconnect-display . t) context))
+ (funcall disp-fn buffer (cons nil context)))
+ ((guard (and erc-skip-displaying-selected-window-buffer
+ (eq (window-buffer) buffer))))
('window
(if (active-minibuffer-window)
(display-buffer buffer)
@@ -1977,30 +2451,55 @@ nil."
(cons (nreverse (car out)) (nreverse (cdr out))))
(list new-modes)))
+;; This function doubles as a convenient helper for use in unit tests.
+;; Prior to 5.6, its contents lived in `erc-open'.
+
+(defun erc--initialize-markers (old-point continued-session)
+ "Ensure prompt and its bounding markers have been initialized."
+ ;; FIXME erase assertions after code review and additional testing.
+ (setq erc-insert-marker (make-marker)
+ erc-input-marker (make-marker))
+ (if continued-session
+ (progn
+ ;; Trust existing markers.
+ (set-marker erc-insert-marker
+ (alist-get 'erc-insert-marker continued-session))
+ (set-marker erc-input-marker
+ (alist-get 'erc-input-marker continued-session))
+ (set-marker-insertion-type erc-insert-marker t)
+ (cl-assert (= (field-end erc-insert-marker) erc-input-marker))
+ (goto-char old-point)
+ (let ((erc--hidden-prompt-overlay
+ (alist-get 'erc--hidden-prompt-overlay continued-session)))
+ (erc--unhide-prompt)))
+ (cl-assert (not (get-text-property (point) 'erc-prompt)))
+ ;; In the original version from `erc-open', the snippet that
+ ;; handled these newline insertions appeared twice close in
+ ;; proximity, which was probably unintended. Nevertheless, we
+ ;; preserve the double newlines here for historical reasons.
+ (insert "\n\n")
+ (set-marker erc-insert-marker (point))
+ (erc-display-prompt)
+ (set-marker-insertion-type erc-insert-marker t)
+ (cl-assert (= (point) (point-max)))))
+
(defun erc-open (&optional server port nick full-name
- connect passwd tgt-list channel process
+ connect passwd _tgt-list channel process
client-certificate user id)
- "Connect to SERVER on PORT as NICK with USER and FULL-NAME.
-
-If CONNECT is non-nil, connect to the server. Otherwise assume
-already connected and just create a separate buffer for the new
-target given by CHANNEL, meaning these parameters are mutually
-exclusive. Note that CHANNEL may also be a query; its name has
-been retained for historical reasons.
-
-Use PASSWD as user password on the server. If TGT-LIST is
-non-nil, use it to initialize `erc-default-recipients'.
-
-CLIENT-CERTIFICATE, if non-nil, should either be a list where the
-first element is the file name of the private key corresponding
-to a client certificate and the second element is the file name
-of the client certificate itself to use when connecting over TLS,
-or t, which means that `auth-source' will be queried for the
-private key and the certificate.
-
-When non-nil, ID should be a symbol for identifying the connection.
-
-Returns the buffer for the given server or channel."
+ "Return a new or reinitialized server or target buffer.
+If CONNECT is non-nil, connect to SERVER and return its new or
+reassociated buffer. Otherwise, assume PROCESS is non-nil and belongs
+to an active session, and return a new or refurbished target buffer for
+CHANNEL, which may also be a query target (the parameter name remains
+for historical reasons). Pass SERVER, PORT, NICK, USER, FULL-NAME, and
+PASSWD to `erc-determine-parameters' for preserving as session-local
+variables. Do something similar for CLIENT-CERTIFICATE and ID, which
+should be as described by `erc-tls'.
+
+Note that ERC ignores TGT-LIST and initializes `erc-default-recipients'
+with CHANNEL as its only member. Note also that this function has the
+side effect of setting the current buffer to the one it returns. Use
+`with-current-buffer' or `save-excursion' to nullify this effect."
(let* ((target (and channel (erc--target-from-string channel)))
(buffer (erc-get-buffer-create server port nil target id))
(old-buffer (current-buffer))
@@ -2010,15 +2509,20 @@ Returns the buffer for the given server or channel."
(old-recon-count erc-server-reconnect-count)
(old-point nil)
(delayed-modules nil)
- (continued-session (and erc--server-reconnecting
- (with-suppressed-warnings
- ((obsolete erc-reuse-buffers))
- erc-reuse-buffers))))
+ (continued-session (or erc--server-reconnecting
+ erc--target-priors
+ (and-let* (((not target))
+ (m (buffer-local-value
+ 'erc-input-marker buffer))
+ ((marker-position m)))
+ (buffer-local-variables buffer)))))
(when connect (run-hook-with-args 'erc-before-connect server port nick))
(set-buffer buffer)
(setq old-point (point))
(setq delayed-modules
- (erc--merge-local-modes (erc--update-modules)
+ (erc--merge-local-modes (let ((erc--updating-modules-p t))
+ (erc--update-modules
+ (erc--sort-modules erc-modules)))
(or erc--server-reconnecting
erc--target-priors)))
@@ -2031,23 +2535,8 @@ Returns the buffer for the given server or channel."
(buffer-local-value 'erc-server-announced-name old-buffer)))
;; connection parameters
(setq erc-server-process process)
- (setq erc-insert-marker (make-marker))
- (setq erc-input-marker (make-marker))
- ;; go to the end of the buffer and open a new line
- ;; (the buffer may have existed)
- (goto-char (point-max))
- (forward-line 0)
- (when (or continued-session (get-text-property (point) 'erc-prompt))
- (setq continued-session t)
- (set-marker erc-input-marker
- (or (next-single-property-change (point) 'erc-prompt)
- (point-max))))
- (unless continued-session
- (goto-char (point-max))
- (insert "\n"))
- (set-marker erc-insert-marker (point))
;; stack of default recipients
- (setq erc-default-recipients tgt-list)
+ (when channel (setq erc-default-recipients (list channel)))
(when target
(setq erc--target target
erc-network (erc-network)))
@@ -2091,21 +2580,8 @@ Returns the buffer for the given server or channel."
(when erc-log-p
(get-buffer-create (concat "*ERC-DEBUG: " server "*"))))
+ (erc--initialize-markers old-point continued-session)
(erc-determine-parameters server port nick full-name user passwd)
-
- ;; FIXME consolidate this prompt-setup logic with the pass above.
-
- ;; set up prompt
- (unless continued-session
- (goto-char (point-max))
- (insert "\n"))
- (if continued-session
- (progn (goto-char old-point)
- (erc--unhide-prompt))
- (set-marker erc-insert-marker (point))
- (erc-display-prompt)
- (goto-char (point-max)))
-
(save-excursion (run-mode-hooks)
(dolist (mod (car delayed-modules)) (funcall mod +1))
(dolist (var (cdr delayed-modules)) (set var nil)))
@@ -2121,12 +2597,18 @@ Returns the buffer for the given server or channel."
(erc-update-mode-line))
;; Now display the buffer in a window as per user wishes.
- (unless (eq buffer old-buffer)
+ (when (eq buffer old-buffer) (cl-assert (and connect (not target))))
+ (unless (and (not erc-reconnect-display-server-buffers)
+ (eq buffer old-buffer))
(when erc-log-p
;; we can't log to debug buffer, it may not exist yet
(message "erc: old buffer %s, switching to %s"
old-buffer buffer))
- (erc-setup-buffer buffer))
+ (let ((display-buffer-overriding-action
+ (or erc--display-buffer-overriding-action
+ display-buffer-overriding-action)))
+ (erc-setup-buffer buffer)
+ (run-hooks 'erc--setup-buffer-hook)))
buffer))
@@ -2168,18 +2650,20 @@ in here get called with three parameters, SERVER, PORT and NICK."
:type '(repeat function))
(defcustom erc-after-connect nil
- "Functions called after connecting to a server.
-This functions in this variable gets executed when an end of MOTD
-has been received. All functions in here get called with the
-parameters SERVER and NICK."
+ "Abnormal hook run upon establishing a logical IRC connection.
+Runs on MOTD's end when `erc-server-connected' becomes non-nil.
+ERC calls members with `erc-server-announced-name', falling back
+to the 376/422 message's \"sender\", as well as the current nick,
+as given by the 376/422 message's \"target\" parameter, which is
+typically the same as that reported by `erc-current-nick'."
:group 'erc-hooks
:type '(repeat function))
(defun erc--ensure-url (input)
(unless (string-match (rx bot "irc" (? "6") (? "s") "://") input)
- (when (and (string-match (rx (? (+ any) "@")
- (or (group (* (not "[")) ":" (* any))
- (+ any))
+ (when (and (string-match (rx (? (+ nonl) "@")
+ (or (group (* (not "[")) ":" (* nonl))
+ (+ nonl))
":" (+ (not (any ":]"))) eot)
input)
(match-beginning 1))
@@ -2187,30 +2671,20 @@ parameters SERVER and NICK."
(setq input (concat "irc://" input)))
input)
-;; A temporary means of addressing the problem of ERC's namesake entry
-;; point defaulting to a non-TLS connection with its default server
-;; (bug#60428).
-(defun erc--warn-unencrypted ()
- ;; Remove unconditionally to avoid wrong context due to races from
- ;; simultaneous dialing or aborting (e.g., via `keyboard-quit').
- (remove-hook 'erc--server-post-connect-hook #'erc--warn-unencrypted)
- (when (and (process-contact erc-server-process :nowait)
- (equal erc-session-server erc-default-server)
- (eql erc-session-port erc-default-port))
- ;; FIXME use the autoloaded `info' instead of `Info-goto-node' in
- ;; `erc-button-alist'.
- (require 'info nil t)
- (erc-display-error-notice
- nil (concat "This connection is unencrypted. Please use `erc-tls'"
- " from now on. See Info:\"(erc) connecting\" for more."))))
+(defvar erc--prompt-for-server-function nil)
;;;###autoload
(defun erc-select-read-args ()
- "Prompt the user for values of nick, server, port, and password."
- (require 'url-parse)
+ "Prompt for connection parameters and return them in a plist.
+By default, collect `:server', `:port', `:nickname', and
+`:password'. With a non-nil prefix argument, also prompt for
+`:user' and `:full-name'. Also return various environmental
+properties needed by entry-point commands, like `erc-tls'."
(let* ((input (let ((d (erc-compute-server)))
- (read-string (format "Server (default is %S): " d)
- nil 'erc-server-history-list d)))
+ (if erc--prompt-for-server-function
+ (funcall erc--prompt-for-server-function)
+ (read-string (format-prompt "Server or URL" d)
+ nil 'erc-server-history-list d))))
;; For legacy reasons, also accept a URL without a scheme.
(url (url-generic-parse-url (erc--ensure-url input)))
(server (url-host url))
@@ -2218,29 +2692,66 @@ parameters SERVER and NICK."
(port (or (url-portspec url)
(erc-compute-port
(let ((d (erc-compute-port sp))) ; may be a string
- (read-string (format "Port (default is %s): " d)
+ (read-string (format-prompt "Port" d)
nil nil d)))))
;; Trust the user not to connect twice accidentally. We
;; can't use `erc-already-logged-in' to check for an existing
;; connection without modifying it to consider USER and PASS.
(nick (or (url-user url)
(let ((d (erc-compute-nick)))
- (read-string (format "Nickname (default is %S): " d)
+ (read-string (format-prompt "Nickname" d)
nil 'erc-nick-history-list d))))
+ (user (and current-prefix-arg
+ (let ((d (erc-compute-user (url-user url))))
+ (read-string (format-prompt "User" d)
+ nil nil d))))
+ (full (and current-prefix-arg
+ (let ((d (erc-compute-full-name (url-user url))))
+ (read-string (format-prompt "Full name" d)
+ nil nil d))))
(passwd (let* ((p (with-suppressed-warnings ((obsolete erc-password))
(or (url-password url) erc-password)))
(m (if p
- (format "Server password (default is %S): " p)
+ (format-prompt "Server password" p)
"Server password (optional): ")))
- (if erc-prompt-for-password (read-passwd m nil p) p))))
+ (if erc-prompt-for-password (read-passwd m nil p) p)))
+ (opener (and (or sp (eql port erc-default-port-tls)
+ (and (equal server erc-default-server)
+ (not (string-prefix-p "irc://" input))
+ (eql port erc-default-port)
+ (y-or-n-p "Connect using TLS instead? ")
+ (setq port erc-default-port-tls)))
+ #'erc-open-tls-stream))
+ env)
+ (when erc-interactive-display
+ (push `(erc-join-buffer . ,erc-interactive-display) env))
+ (when erc--display-context
+ (push `(erc--display-context . ,erc--display-context) env))
+ (when opener
+ (push `(erc-server-connect-function . ,opener) env))
(when (and passwd (string= "" passwd))
(setq passwd nil))
- (when (and (equal server erc-default-server)
- (eql port erc-default-port)
- (not (eql port erc-default-port-tls)) ; not `erc-tls'
- (not (string-prefix-p "irc://" input))) ; not yanked URL
- (add-hook 'erc--server-post-connect-hook #'erc--warn-unencrypted))
- (list :server server :port port :nick nick :password passwd)))
+ `( :server ,server :port ,port :nick ,nick ,@(and user `(:user ,user))
+ ,@(and passwd `(:password ,passwd)) ,@(and full `(:full-name ,full))
+ ,@(and env `(--interactive-env-- ,env)))))
+
+(defmacro erc--with-entrypoint-environment (env &rest body)
+ "Run BODY with bindings from ENV alist."
+ (declare (indent 1))
+ (let ((syms (make-symbol "syms"))
+ (vals (make-symbol "vals")))
+ `(let (,syms ,vals)
+ (pcase-dolist (`(,k . ,v) ,env) (push k ,syms) (push v ,vals))
+ (cl-progv ,syms ,vals
+ ,@body))))
+
+;;;###autoload
+(defun erc-server-select ()
+ "Interactively connect to a server from `erc-server-alist'."
+ (declare (obsolete erc-tls "30.1"))
+ (interactive)
+ (let ((erc--prompt-for-server-function #'erc-networks--server-select))
+ (call-interactively #'erc)))
;;;###autoload
(cl-defun erc (&key (server (erc-compute-server))
@@ -2249,32 +2760,53 @@ parameters SERVER and NICK."
(user (erc-compute-user))
password
(full-name (erc-compute-full-name))
- id)
- "ERC is a powerful, modular, and extensible IRC client.
-This function is the main entry point for ERC.
-
-It allows selecting connection parameters, and then starts ERC.
-
-Non-interactively, it takes the keyword arguments
- (server (erc-compute-server))
- (port (erc-compute-port))
- (nick (erc-compute-nick))
- (user (erc-compute-user))
- password
- (full-name (erc-compute-full-name))
- id
-
-That is, if called with
+ id
+ ;; Used by interactive form
+ ((--interactive-env-- --interactive-env--)))
+ "Connect to an Internet Relay Chat SERVER on a non-TLS PORT.
+Use NICK and USER, when non-nil, to inform the IRC commands of
+the same name, possibly factoring in a non-nil FULL-NAME as well.
+When PASSWORD is non-nil, also send an opening server password
+via the \"PASS\" command. Interactively, prompt for SERVER,
+PORT, NICK, and PASSWORD, along with USER and FULL-NAME when
+given a prefix argument. Non-interactively, expect the rarely
+needed ID parameter, when non-nil, to be a symbol or a string for
+naming the server buffer and identifying the connection
+unequivocally. Once connected, return the server buffer. (See
+Info node `(erc) Connecting' for details about all mentioned
+parameters.)
+
+Together with `erc-tls', this command serves as the main entry
+point for ERC, the powerful, modular, and extensible IRC client.
+Non-interactively, both commands accept the following keyword
+arguments, with their defaults supplied by the indicated
+\"compute\" functions:
+
+ :server `erc-compute-server'
+ :port `erc-compute-port'
+ :nick `erc-compute-nick'
+ :user `erc-compute-user'
+ :password N/A
+ :full-name `erc-compute-full-name'
+ :id' N/A
+
+For example, when called in the following manner
(erc :server \"irc.libera.chat\" :full-name \"J. Random Hacker\")
-then the server and full-name will be set to those values,
-whereas `erc-compute-port' and `erc-compute-nick' will be invoked
-for the values of the other parameters.
+ERC assigns SERVER and FULL-NAME the associated keyword values
+and defers to `erc-compute-port', `erc-compute-user', and
+`erc-compute-nick' for those respective parameters.
-See `erc-tls' for the meaning of ID."
- (interactive (erc-select-read-args))
- (erc-open server port nick full-name t password nil nil nil nil user id))
+\(fn &key SERVER PORT NICK USER PASSWORD FULL-NAME ID)"
+ (interactive (let ((erc--display-context `((erc-interactive-display . erc)
+ ,@erc--display-context)))
+ (erc-select-read-args)))
+ (unless (assq 'erc--display-context --interactive-env--)
+ (push '(erc--display-context . ((erc-buffer-display . erc)))
+ --interactive-env--))
+ (erc--with-entrypoint-environment --interactive-env--
+ (erc-open server port nick full-name t password nil nil nil nil user id)))
;;;###autoload
(defalias 'erc-select #'erc)
@@ -2288,54 +2820,47 @@ See `erc-tls' for the meaning of ID."
password
(full-name (erc-compute-full-name))
client-certificate
- id)
- "ERC is a powerful, modular, and extensible IRC client.
-This function is the main entry point for ERC over TLS.
-
-It allows selecting connection parameters, and then starts ERC
-over TLS.
-
-Non-interactively, it takes the keyword arguments
- (server (erc-compute-server))
- (port (erc-compute-port))
- (nick (erc-compute-nick))
- (user (erc-compute-user))
- password
- (full-name (erc-compute-full-name))
- client-certificate
- id
-
-That is, if called with
-
- (erc-tls :server \"irc.libera.chat\" :full-name \"J. Random Hacker\")
-
-then the server and full-name will be set to those values,
-whereas `erc-compute-port' and `erc-compute-nick' will be invoked
-for the values of their respective parameters.
-
-CLIENT-CERTIFICATE, if non-nil, should either be a list where the
-first element is the certificate key file name, and the second
-element is the certificate file name itself, or t, which means
-that `auth-source' will be queried for the key and the
-certificate. Authenticating using a TLS client certificate is
-also referred to as \"CertFP\" (Certificate Fingerprint)
-authentication by various IRC networks.
-
-Example usage:
+ id
+ ;; Used by interactive form
+ ((--interactive-env-- --interactive-env--)))
+ "Connect to an IRC server over a TLS-encrypted connection.
+Interactively, prompt for SERVER, PORT, NICK, and PASSWORD, along
+with USER and FULL-NAME when given a prefix argument.
+Non-interactively, also accept a CLIENT-CERTIFICATE, which should
+be a list containing the file name of the certificate's key
+followed by that of the certificate itself. Alternatively,
+accept a value of t instead of a list, to tell ERC to query
+`auth-source' for the certificate's details.
+
+Example client certificate (CertFP) usage:
(erc-tls :server \"irc.libera.chat\" :port 6697
:client-certificate
\\='(\"/home/bandali/my-cert.key\"
\"/home/bandali/my-cert.crt\"))
-When present, ID should be a symbol or a string to use for naming
-the server buffer and identifying the connection unequivocally.
-See Info node `(erc) Network Identifier' for details. Like USER
-and CLIENT-CERTIFICATE, this parameter cannot be specified
-interactively."
- (interactive (let ((erc-default-port erc-default-port-tls))
- (erc-select-read-args)))
- (let ((erc-server-connect-function 'erc-open-tls-stream))
+See the alternative entry-point command `erc' as well as Info
+node `(erc) Connecting' for a fuller description of the various
+parameters, like ID.
+
+\(fn &key SERVER PORT NICK USER PASSWORD FULL-NAME CLIENT-CERTIFICATE ID)"
+ (interactive
+ (let ((erc-default-port erc-default-port-tls)
+ (erc--display-context `((erc-interactive-display . erc-tls)
+ ,@erc--display-context)))
+ (erc-select-read-args)))
+ ;; Bind `erc-server-connect-function' to `erc-open-tls-stream'
+ ;; around `erc-open' when a non-default value hasn't been specified
+ ;; by the user or the interactive form. And don't bother checking
+ ;; for advice, indirect functions, autoloads, etc.
+ (unless (or (assq 'erc-server-connect-function --interactive-env--)
+ (not (eq erc-server-connect-function #'erc-open-network-stream)))
+ (push '(erc-server-connect-function . erc-open-tls-stream)
+ --interactive-env--))
+ (unless (assq 'erc--display-context --interactive-env--)
+ (push '(erc--display-context . ((erc-buffer-display . erc-tls)))
+ --interactive-env--))
+ (erc--with-entrypoint-environment --interactive-env--
(erc-open server port nick full-name t password
nil nil nil client-certificate user id)))
@@ -2352,6 +2877,25 @@ PARAMETERS should be a sequence of keywords and values, per
(setq args `(,name ,buffer ,host ,port ,@p))
(apply #'open-network-stream args)))
+(defun erc-open-socks-tls-stream (name buffer host service &rest parameters)
+ "Connect to an IRC server via SOCKS proxy over TLS.
+Defer to the `socks' and `gnutls' libraries to make the actual
+connection and perform TLS negotiation. Expect SERVICE to be a
+TLS port number and that the plist PARAMETERS contains a
+`:client-certificate' pair when necessary. Otherwise, assume the
+arguments NAME, BUFFER, and HOST to be acceptable to
+`open-network-stream' and that users know to check out
+`erc-server-connect-function' and Info node `(erc) SOCKS' for
+more info, including an important example of how to \"wrap\" this
+function with SOCKS credentials."
+ (require 'gnutls)
+ (require 'socks)
+ (let ((proc (socks-open-network-stream name buffer host service))
+ (cert-info (plist-get parameters :client-certificate)))
+ (gnutls-negotiate :process proc
+ :hostname host
+ :keylist (and cert-info (list cert-info)))))
+
;;; Displaying error messages
(defun erc-error (&rest args)
@@ -2363,6 +2907,15 @@ message instead, to make debugging easier."
(apply #'message args)
(beep)))
+(defvar erc--warnings-buffer-name nil
+ "Name of possibly existing alternate warnings buffer for unit tests.")
+
+(defun erc--lwarn (type level format-string &rest args)
+ "Issue a warning of TYPE and LEVEL with FORMAT-STRING and ARGS."
+ (let ((message (substitute-command-keys
+ (apply #'format-message format-string args))))
+ (display-warning type message level erc--warnings-buffer-name)))
+
;;; Debugging the protocol
(defvar erc-debug-irc-protocol-time-format "%FT%T.%6N%z "
@@ -2508,15 +3061,75 @@ If ARG is non-nil, show the *erc-protocol* buffer."
;; send interface
+(defvar erc--send-action-function #'erc--send-action
+ "Function to display and send an outgoing CTCP ACTION message.
+Called with three arguments: the submitted input, the current
+target, and an `erc-server-send' FORCE flag.")
+
(defun erc-send-action (tgt str &optional force)
"Send CTCP ACTION information described by STR to TGT."
- (erc-send-ctcp-message tgt (format "ACTION %s" str) force)
- (erc-display-message
- nil 'input (current-buffer)
- 'ACTION ?n (erc-current-nick) ?a str ?u "" ?h ""))
+ (funcall erc--send-action-function tgt str force))
+
+;; Sending and displaying are provided separately to afford modules
+;; more flexibility, e.g., to forgo displaying on the way out when
+;; expecting the server to echo messages back and/or to associate
+;; outgoing messages with IDs generated for `erc--ephemeral'
+;; placeholders.
+(defun erc--send-action-perform-ctcp (target string force)
+ "Send STRING to TARGET, possibly immediately, with FORCE."
+ (erc-send-ctcp-message target (format "ACTION %s" string) force))
+
+(defvar erc--use-language-catalog-for-ctcp-action-p nil
+ "When non-nil, use `ACTION' entry from language catalog for /ME's.
+Otherwise, use `ctcp-action' or `ctcp-action-input' from the
+internal `-speaker' catalog. This is an escape hatch to restore
+pre-5.6 behavior for the `font-lock-face' property of incoming
+and outgoing \"CTCP ACTION\" messages, whose pre-buttonized state
+was a single interval of `erc-input-face' or `erc-action-face'.
+Newer modules, like `fill-wrap' and `nicks', are incompatible with
+this format style. If you use this, please ask ERC to expose it
+as a public variable via \\[erc-bug] or similar.")
+
+(defun erc--send-action-display (string)
+ "Display STRING as an outgoing \"CTCP ACTION\" message.
+Propertize the message according to the compatibility flag
+`erc--use-language-catalog-for-ctcp-action-p'."
+ ;; Allow hooks acting on inserted PRIVMSG and NOTICES to process us.
+ (let ((erc--msg-prop-overrides `((erc--ctcp . ACTION)
+ ,@erc--msg-prop-overrides))
+ (nick (erc-current-nick)))
+ (if erc--use-language-catalog-for-ctcp-action-p
+ (progn (erc--ensure-spkr-prop nick)
+ (erc-display-message nil 'input (current-buffer) 'ACTION
+ ?n (propertize nick 'erc--speaker nick)
+ ?a string ?u "" ?h ""))
+ (let ((erc-current-message-catalog erc--message-speaker-catalog))
+ (erc-display-message nil nil (current-buffer) 'ctcp-action-input
+ ?p (erc-get-channel-membership-prefix nick)
+ ?n (erc--speakerize-nick nick) ?m string)))))
+
+(defun erc--send-action (target string force)
+ "Display STRING, then send to TARGET as a \"CTCP ACTION\" message."
+ (erc--send-action-display string)
+ (erc--send-action-perform-ctcp target string force))
;; Display interface
+(defun erc--ensure-spkr-prop (nick &optional overrides)
+ "Add NICK as `erc--spkr' to the current \"msg props\" environment.
+Prefer `erc--msg-props' over `erc--msg-prop-overrides' when both
+are available. Also include any members of the alist OVERRIDES,
+when present. Assume NICK itself to be free of any text props,
+and return it."
+ (cond (erc--msg-props
+ (puthash 'erc--spkr nick erc--msg-props)
+ (dolist (entry overrides)
+ (puthash (car entry) (cdr entry) erc--msg-props)))
+ (erc--msg-prop-overrides
+ (setq erc--msg-prop-overrides
+ `((erc--spkr . ,nick) ,@overrides ,@erc--msg-prop-overrides))))
+ nick)
+
(defun erc-string-invisible-p (string)
"Check whether STRING is invisible or not.
I.e. any char in it has the `invisible' property set."
@@ -2527,34 +3140,236 @@ I.e. any char in it has the `invisible' property set."
The default is to remove it, since it causes ERC to take up extra
memory. If you have code that relies on this property, then set
-this option to nil."
+this option to nil.
+
+Note that this option is deprecated because a value of nil is
+impractical in prolonged sessions with more than a few channels.
+Use `erc-insert-post-hook' or similar and the helper function
+`erc-find-parsed-property' and friends to stash the current
+`erc-response' object as needed. And instead of using this for
+debugging purposes, try `erc-debug-irc-protocol'."
:type 'boolean
:group 'erc)
-
-(defun erc-display-line-1 (string buffer)
- "Display STRING in `erc-mode' BUFFER.
-Auxiliary function used in `erc-display-line'. The line gets filtered to
-interpret the control characters. Then, `erc-insert-pre-hook' gets called.
-If `erc-insert-this' is still t, STRING gets inserted into the buffer.
-Afterwards, `erc-insert-modify' and `erc-insert-post-hook' get called.
-If STRING is nil, the function does nothing."
+(make-obsolete-variable 'erc-remove-parsed-property
+ "impractical when non-nil" "30.1")
+
+(define-inline erc--assert-input-bounds ()
+ (inline-quote
+ (progn (when (and (processp erc-server-process)
+ (eq (current-buffer) (process-buffer erc-server-process)))
+ ;; It's believed that these only need syncing immediately
+ ;; following the first two insertions in a server buffer.
+ (set-marker (process-mark erc-server-process) erc-insert-marker))
+ (cl-assert (< erc-insert-marker erc-input-marker))
+ (cl-assert (= (field-end erc-insert-marker) erc-input-marker)))))
+
+(defvar erc--merge-prop-behind-p nil
+ "When non-nil, put merged prop(s) behind existing.")
+
+(defvar erc--refresh-prompt-hook nil
+ "Hook called after refreshing the prompt in the affected buffer.")
+
+(defvar-local erc--inhibit-prompt-display-property-p nil
+ "Tell `erc-prompt' related functions to avoid the `display' text prop.
+Modules can enable this when needing to reserve the prompt's
+display property for some other purpose, such as displaying it
+elsewhere, abbreviating it, etc.")
+
+(defconst erc--prompt-properties '( rear-nonsticky t
+ erc-prompt t ; t or `hidden'
+ field erc-prompt
+ front-sticky t
+ read-only t)
+ "Mandatory text properties added to ERC's prompt.")
+
+(defvar erc--refresh-prompt-continue-request nil
+ "State flag for refreshing prompt in all buffers.
+When the value is zero, functions assigned to the variable
+`erc-prompt' can set this to run `erc--refresh-prompt-hook' (1)
+or `erc--refresh-prompt' (2) in all buffers of the server.")
+
+(defun erc--refresh-prompt-continue (&optional hooks-only-p)
+ "Ask ERC to refresh the prompt in all buffers.
+Functions assigned to `erc-prompt' can call this if needing to
+recreate the prompt in other buffers as well. With HOOKS-ONLY-P,
+run `erc--refresh-prompt-hook' in other buffers instead of doing
+a full refresh."
+ (when (and erc--refresh-prompt-continue-request
+ (zerop erc--refresh-prompt-continue-request))
+ (setq erc--refresh-prompt-continue-request (if hooks-only-p 1 2))))
+
+(defun erc--refresh-prompt ()
+ "Re-render ERC's prompt when the option `erc-prompt' is a function."
+ (erc--assert-input-bounds)
+ (unless (erc--prompt-hidden-p)
+ (let ((erc--refresh-prompt-continue-request
+ (or erc--refresh-prompt-continue-request 0)))
+ (when (functionp erc-prompt)
+ (save-excursion
+ (goto-char (1- erc-input-marker))
+ ;; Avoid `erc-prompt' (the named function), which appends a
+ ;; space, and `erc-display-prompt', which propertizes all
+ ;; but that space.
+ (let ((s (funcall erc-prompt))
+ (p (point))
+ (erc--merge-prop-behind-p t))
+ (erc--merge-prop 0 (length s) 'font-lock-face 'erc-prompt-face s)
+ (add-text-properties 0 (length s) erc--prompt-properties s)
+ (insert s)
+ (delete-region erc-insert-marker p))))
+ (run-hooks 'erc--refresh-prompt-hook)
+ (when-let (((> erc--refresh-prompt-continue-request 0))
+ (n erc--refresh-prompt-continue-request)
+ (erc--refresh-prompt-continue-request -1)
+ (b (current-buffer)))
+ (erc-with-all-buffers-of-server erc-server-process
+ (lambda () (not (eq b (current-buffer))))
+ (if (= n 1)
+ (run-hooks 'erc--refresh-prompt-hook)
+ (erc--refresh-prompt)))))))
+
+(defun erc--check-msg-prop (prop &optional val)
+ "Return PROP's value in `erc--msg-props' when populated.
+If VAL is a list, return non-nil if PROP appears in VAL. If VAL
+is otherwise non-nil, return non-nil if VAL compares `eq' to the
+stored value. Otherwise, return the stored value."
+ (and-let* ((erc--msg-props)
+ (v (gethash prop erc--msg-props)))
+ (if (consp val) (memq v val) (if val (eq v val) v))))
+
+(defmacro erc--get-inserted-msg-beg-at (point at-start-p)
+ (macroexp-let2* nil ((point point)
+ (at-start-p at-start-p))
+ `(or (and ,at-start-p ,point)
+ (and-let* ((p (previous-single-property-change ,point 'erc--msg)))
+ (if (and (= p (1- ,point)) (get-text-property p 'erc--msg))
+ p
+ (1- p))))))
+
+(defmacro erc--get-inserted-msg-end-at (point at-start-p)
+ (macroexp-let2 nil point point
+ `(1- (next-single-property-change (if ,at-start-p (1+ ,point) ,point)
+ 'erc--msg nil erc-insert-marker))))
+
+(defun erc--get-inserted-msg-beg (&optional point)
+ "Maybe return the start of message in an ERC buffer."
+ (erc--get-inserted-msg-beg-at (or point (setq point (point)))
+ (get-text-property point 'erc--msg)))
+
+(defun erc--get-inserted-msg-end (&optional point)
+ "Return the end of message in an ERC buffer.
+Include any trailing white space before final newline. Expect
+POINT to be less than `erc-insert-marker', and don't bother
+considering `erc--insert-marker', for now."
+ (erc--get-inserted-msg-end-at (or point (setq point (point)))
+ (get-text-property point 'erc--msg)))
+
+(defun erc--get-inserted-msg-bounds (&optional point)
+ "Return bounds of message at POINT in an ERC buffer when found.
+Search from POINT, when non-nil, instead of `point'. Return nil
+if not found."
+ (let ((at-start-p (get-text-property (or point (setq point (point)))
+ 'erc--msg)))
+ (and-let* ((b (erc--get-inserted-msg-beg-at point at-start-p)))
+ (cons b (erc--get-inserted-msg-end-at point at-start-p)))))
+
+(defun erc--get-inserted-msg-prop (prop)
+ "Return the value of text property PROP for some message at point."
+ (and-let* ((stack-pos (erc--get-inserted-msg-beg (point))))
+ (get-text-property stack-pos prop)))
+
+(defmacro erc--with-inserted-msg (&rest body)
+ "Simulate narrowing performed for send and insert hooks, and run BODY.
+Expect callers to know that this doesn't wrap BODY in
+`with-silent-modifications' or bind a temporary `erc--msg-props'."
+ `(when-let ((bounds (erc--get-inserted-msg-bounds)))
+ (save-restriction
+ (narrow-to-region (car bounds) (1+ (cdr bounds)))
+ ,@body)))
+
+(defun erc--traverse-inserted (beg end fn)
+ "Visit messages between BEG and END and run FN in narrowed buffer.
+If END is a marker, possibly update its position."
+ (unless (markerp end)
+ (setq end (set-marker (make-marker) (or end erc-insert-marker))))
+ (unless (eq end erc-insert-marker)
+ (set-marker end (min erc-insert-marker end)))
+ (save-excursion
+ (goto-char beg)
+ (let ((b (if (get-text-property (point) 'erc--msg)
+ (point)
+ (next-single-property-change (point) 'erc--msg nil end))))
+ (while-let ((b)
+ ((< b end))
+ (e (next-single-property-change (1+ b) 'erc--msg nil end)))
+ (save-restriction
+ (narrow-to-region b e)
+ (funcall fn))
+ (setq b e))))
+ (unless (eq end erc-insert-marker)
+ (set-marker end nil)))
+
+(defvar erc--insert-invisible-as-intangible-p nil
+ "When non-nil, ensure certain invisible messages are also intangible.
+That is, single out any message inserted via `erc-insert-line'
+that lacks a trailing newline but has a t-valued `invisible'
+property anywhere along its length, and ensure it's both
+`invisible' t and `intangible' t throughout. Note that this is
+merely an escape hatch for accessing aberrant pre-5.6 behavior
+that ERC considers a bug because it applies a practice described
+as obsolete in the manual, and it does so heavy-handedly. That
+the old behavior only acted when the input lacked a trailing
+newline was likely accidental but is ultimately incidental. See
+info node `(elisp) Special Properties' for specifics. Beware
+that this flag and the behavior it restores may disappear at any
+time, so if you need them, please let ERC know with \\[erc-bug].")
+
+(defvar erc--insert-line-function nil
+ "When non-nil, an alterntive to `insert' for inserting messages.")
+
+(defvar erc--insert-marker nil
+ "Internal override for `erc-insert-marker'.")
+
+(define-obsolete-function-alias 'erc-display-line-1 'erc-insert-line "30.1")
+(defun erc-insert-line (string buffer)
+ "Insert STRING in an `erc-mode' BUFFER.
+When STRING is nil, do nothing. Otherwise, start off by running
+`erc-insert-pre-hook' in BUFFER with `erc-insert-this' bound to
+t. If the latter remains non-nil afterward, insert STRING into
+BUFFER, ensuring a trailing newline. After that, narrow BUFFER
+around STRING, along with its final line ending, and run
+`erc-insert-modify' and `erc-insert-post-hook', respectively. In
+all cases, run `erc-insert-done-hook' unnarrowed before exiting,
+and update positions in `buffer-undo-list'.
+
+In general, expect to be called from a higher-level insertion
+function, like `erc-display-message', especially when modules
+should consider STRING as a candidate for formatting with
+enhancements like indentation, fontification, timestamping, etc.
+Otherwise, when called directly, allow built-in modules to ignore
+STRING, which may make it appear incongruous in situ (unless
+preformatted or anticipated by third-party members of the various
+modification hooks)."
(when string
(with-current-buffer (or buffer (process-buffer erc-server-process))
- (let ((insert-position (or (marker-position erc-insert-marker)
- (point-max))))
- (let ((string string) ;; FIXME! Can this be removed?
- (buffer-undo-list t)
+ (let (insert-position)
+ ;; Initialize ^ below to thwart rogue `erc-insert-pre-hook'
+ ;; members that dare to modify the buffer's length.
+ (let ((buffer-undo-list t)
(inhibit-read-only t))
- (unless (string-match "\n$" string)
+ (unless (string-suffix-p "\n" string)
(setq string (concat string "\n"))
- (when (erc-string-invisible-p string)
+ (when (and erc--insert-invisible-as-intangible-p
+ (erc-string-invisible-p string))
(erc-put-text-properties 0 (length string)
'(invisible intangible) string)))
- (erc-log (concat "erc-display-line: " string
+ (erc-log (concat "erc-display-message: " string
(format "(%S)" string) " in buffer "
(format "%s" buffer)))
(setq erc-insert-this t)
(run-hook-with-args 'erc-insert-pre-hook string)
+ (setq insert-position (marker-position (or erc--insert-marker
+ erc-insert-marker)))
(if (null erc-insert-this)
;; Leave erc-insert-this set to t as much as possible. Fran
;; Litterio <franl> has seen erc-insert-this set to nil while
@@ -2565,7 +3380,10 @@ If STRING is nil, the function does nothing."
(save-restriction
(widen)
(goto-char insert-position)
- (insert-before-markers string)
+ (if erc--insert-line-function
+ (funcall erc--insert-line-function string)
+ (insert string))
+ (erc--assert-input-bounds)
;; run insertion hook, with point at restored location
(save-restriction
(narrow-to-region insert-position (point))
@@ -2573,9 +3391,17 @@ If STRING is nil, the function does nothing."
(run-hooks 'erc-insert-post-hook)
(when erc-remove-parsed-property
(remove-text-properties (point-min) (point-max)
- '(erc-parsed nil))))))))
+ '(erc-parsed nil tags nil)))
+ (cl-assert (> (- (point-max) (point-min)) 1))
+ (let ((props (if erc--msg-props
+ (erc--order-text-properties-from-hash
+ erc--msg-props)
+ '(erc--msg unknown))))
+ (add-text-properties (point-min) (1+ (point-min)) props)))
+ (erc--refresh-prompt)))))
(run-hooks 'erc-insert-done-hook)
- (erc-update-undo-list (- (or (marker-position erc-insert-marker)
+ (erc-update-undo-list (- (or (marker-position (or erc--insert-marker
+ erc-insert-marker))
(point-max))
insert-position))))))
@@ -2609,37 +3435,211 @@ If STRING is nil, the function does nothing."
"Check if NICK is a valid IRC nickname."
(string-match (concat "\\`" erc-valid-nick-regexp "\\'") nick))
-(defun erc-display-line (string &optional buffer)
- "Display STRING in the ERC BUFFER.
-All screen output must be done through this function. If BUFFER is nil
-or omitted, the default ERC buffer for the `erc-session-server' is used.
-The BUFFER can be an actual buffer, a list of buffers, `all' or `active'.
-If BUFFER = `all', the string is displayed in all the ERC buffers for the
-current session. `active' means the current active buffer
-\(`erc-active-buffer'). If the buffer can't be resolved, the current
-buffer is used. `erc-display-line-1' is used to display STRING.
-
-If STRING is nil, the function does nothing."
- (let (new-bufs)
+(defun erc--route-insertion (string buffer)
+ "Insert STRING in BUFFER.
+See `erc-display-message' for acceptable BUFFER types."
+ (let (seen msg-props)
(dolist (buf (cond
((bufferp buffer) (list buffer))
- ((listp buffer) buffer)
+ ((consp buffer)
+ (setq msg-props erc--msg-props)
+ buffer)
((processp buffer) (list (process-buffer buffer)))
((eq 'all buffer)
;; Hmm, or all of the same session server?
(erc-buffer-list nil erc-server-process))
- ((and (eq 'active buffer) (erc-active-buffer))
- (list (erc-active-buffer)))
+ ((and-let* (((eq 'active buffer))
+ (b (erc-active-buffer)))
+ (list b)))
((erc-server-buffer-live-p)
(list (process-buffer erc-server-process)))
(t (list (current-buffer)))))
(when (buffer-live-p buf)
- (erc-display-line-1 string buf)
- (push buf new-bufs)))
- (when (null new-bufs)
- (erc-display-line-1 string (if (erc-server-buffer-live-p)
- (process-buffer erc-server-process)
- (current-buffer))))))
+ (when msg-props
+ (setq erc--msg-props (copy-hash-table msg-props)))
+ (erc-insert-line string buf)
+ (setq seen t)))
+ (unless (or seen (null buffer))
+ (erc--route-insertion string nil))))
+
+(defun erc-display-line (string &optional buffer)
+ "Insert STRING in BUFFER as a plain \"local\" message.
+Take pains to ensure modification hooks see messages created by
+the old pattern (erc-display-line (erc-make-notice) my-buffer) as
+being equivalent to a `erc-display-message' TYPE of `notice'."
+ (let ((erc--msg-prop-overrides erc--msg-prop-overrides))
+ (when (eq 'erc-notice-face (get-text-property 0 'font-lock-face string))
+ (unless (assq 'erc--msg erc--msg-prop-overrides)
+ (push '(erc--msg . notice) erc--msg-prop-overrides)))
+ (erc-display-message nil nil buffer string)))
+
+(defvar erc--merge-text-properties-p nil
+ "Non-nil when `erc-put-text-property' defers to `erc--merge-prop'.")
+
+;; To save space, we could maintain a map of all readable property
+;; values and optionally dispense archetypal constants in their place
+;; in order to ensure all occurrences of some list (a b) across all
+;; text-properties in all ERC buffers are actually the same object.
+(defun erc--merge-prop (from to prop val &optional object cache-fn)
+ "Combine existing PROP values with VAL between FROM and TO in OBJECT.
+For spans where PROP is non-nil, cons VAL onto the existing
+value, ensuring a proper list. Otherwise, just set PROP to VAL.
+When VAL is itself a list, prepend its members onto an existing
+value. Call CACHE-FN, when given, with the new value for prop.
+It must return a suitable replacement or the same value. See
+also `erc-button-add-face'."
+ (let ((old (get-text-property from prop object))
+ (pos from)
+ (end (next-single-property-change from prop object to))
+ new)
+ (while (< pos to)
+ (setq new (if old
+ ;; Can't `nconc' without more info.
+ (if erc--merge-prop-behind-p
+ `(,@(ensure-list old) ,@(ensure-list val))
+ (if (listp val)
+ (append val (ensure-list old))
+ (cons val (ensure-list old))))
+ val))
+ (when cache-fn
+ (setq new (funcall cache-fn new)))
+ (put-text-property pos end prop new object)
+ (setq pos end
+ old (get-text-property pos prop object)
+ end (next-single-property-change pos prop object to)))))
+
+(defun erc--remove-from-prop-value-list (from to prop val &optional object)
+ "Remove VAL from text prop value between FROM and TO.
+If current value is VAL itself, remove the property entirely.
+When VAL is a list, act as if this function were called
+repeatedly with VAL set to each of VAL's members."
+ (let ((old (get-text-property from prop object))
+ (pos from)
+ (end (next-single-property-change from prop object to))
+ new)
+ (while (< pos to)
+ (when old
+ (if (setq new (and (consp old) (if (consp val)
+ (seq-difference old val)
+ (remq val old))))
+ (put-text-property pos end prop
+ (if (cdr new) new (car new)) object)
+ (when (pcase val
+ ((pred consp) (or (consp old) (memq old val)))
+ (_ (if (consp old) (memq val old) (eq old val))))
+ (remove-text-properties pos end (list prop nil) object))))
+ (setq pos end
+ old (get-text-property pos prop object)
+ end (next-single-property-change pos prop object to)))))
+
+(defun erc--reserve-important-text-props (beg end plist &optional object)
+ "Record text-property pairs in PLIST as important between BEG and END.
+Also mark the message being inserted as containing these important props
+so modules performing destructive modifications can later restore them.
+Expect to run in a narrowed buffer at message-insertion time."
+ (when erc--msg-props
+ (let ((existing (erc--check-msg-prop 'erc--important-prop-names)))
+ (puthash 'erc--important-prop-names (cl-union existing (map-keys plist))
+ erc--msg-props)))
+ (erc--merge-prop beg end 'erc--important-props plist object))
+
+(defun erc--restore-important-text-props (props &optional beg end)
+ "Restore PROPS where recorded in the accessible portion of the buffer.
+Expect to run in a narrowed buffer at message-insertion time. Limit the
+effect to the region between buffer positions BEG and END, when non-nil.
+
+Callers should be aware that this function fails if the property
+`erc--important-props' has an empty value almost anywhere along the
+affected region. Use the function `erc--remove-from-prop-value-list' to
+ensure that props with empty values are excised completely."
+ (when-let ((registered (erc--check-msg-prop 'erc--important-prop-names))
+ (present (seq-intersection props registered))
+ (b (or beg (point-min)))
+ (e (or end (point-max))))
+ (while-let
+ (((setq b (text-property-not-all b e 'erc--important-props nil)))
+ (val (get-text-property b 'erc--important-props))
+ (q (next-single-property-change b 'erc--important-props nil e)))
+ (while-let ((k (pop val))
+ (v (pop val)))
+ (when (memq k present)
+ (put-text-property b q k v)))
+ (setq b q))))
+
+(defvar erc-legacy-invisible-bounds-p nil
+ "Whether to hide trailing rather than preceding newlines.
+Beginning in ERC 5.6, invisibility extends from a message's
+preceding newline to its last non-newline character.")
+(make-obsolete-variable 'erc-legacy-invisible-bounds-p
+ "decremented interval now permanent" "30.1")
+
+(defun erc--hide-message (value)
+ "Apply `invisible' text-property with VALUE to current message.
+Expect to run in a narrowed buffer during message insertion.
+Begin the invisible interval at the previous message's trailing
+newline and end before the current message's. If the preceding
+message ends in a double newline or there is no previous message,
+don't bother including the preceding newline."
+ (if erc-legacy-invisible-bounds-p
+ ;; Before ERC 5.6, this also used to add an `intangible'
+ ;; property, but the docs say it's now obsolete.
+ (erc--merge-prop (point-min) (point-max) 'invisible value)
+ (let ((beg (point-min))
+ (end (point-max)))
+ (save-restriction
+ (widen)
+ (when (or (<= beg 4) (= ?\n (char-before (- beg 2))))
+ (cl-incf beg))
+ (erc--merge-prop (1- beg) (1- end) 'invisible value)))))
+
+(defun erc--toggle-hidden (prop arg)
+ "Toggle invisibility for spec member PROP.
+Treat ARG in a manner similar to mode toggles defined by
+`define-minor-mode'."
+ (when arg
+ (setq arg (prefix-numeric-value arg)))
+ (if (memq prop (ensure-list buffer-invisibility-spec))
+ (unless (natnump arg)
+ (remove-from-invisibility-spec prop))
+ (when (or (not arg) (natnump arg))
+ (add-to-invisibility-spec prop))))
+
+(defun erc--delete-inserted-message (beg-or-point &optional end)
+ "Remove message between BEG and END.
+Expect BEG and END to match bounds as returned by the macro
+`erc--get-inserted-msg-bounds'. Ensure all markers residing at
+the start of the deleted message end up at the beginning of the
+subsequent message."
+ (let ((beg beg-or-point))
+ (save-restriction
+ (widen)
+ (unless end
+ (setq end (erc--get-inserted-msg-bounds beg-or-point)
+ beg (pop end)))
+ (with-silent-modifications
+ (if erc-legacy-invisible-bounds-p
+ (delete-region beg (1+ end))
+ (save-excursion
+ (goto-char beg)
+ (insert-before-markers
+ (substring (delete-and-extract-region (1- (point)) (1+ end))
+ -1))))))))
+
+(defvar erc--ranked-properties
+ '(erc--msg erc--spkr erc--ts erc--cmd erc--ctcp erc--ephemeral))
+
+(defun erc--order-text-properties-from-hash (table)
+ "Return a plist of text props from items in TABLE.
+Ensure props in `erc--ranked-properties' appear last and in
+reverse order so they end up sorted in buffer interval plists for
+retrieval by `text-properties-at' and friends."
+ (let (out)
+ (dolist (k erc--ranked-properties)
+ (when-let ((v (gethash k table)))
+ (remhash k table)
+ (setq out (nconc (list k v) out))))
+ (maphash (lambda (k v) (setq out (nconc (list k v) out))) table)
+ out))
(defun erc-display-message-highlight (type string)
"Highlight STRING according to TYPE, where erc-TYPE-face is an ERC face.
@@ -2652,7 +3652,7 @@ See also `erc-make-notice'."
0 (length string)
'font-lock-face (or (intern-soft
(concat "erc-" (symbol-name type) "-face"))
- "erc-default-face")
+ 'erc-default-face)
string)
string)))
@@ -2854,35 +3854,87 @@ returns non-nil."
(defun erc-display-message (parsed type buffer msg &rest args)
"Display MSG in BUFFER.
-ARGS, PARSED, and TYPE are used to format MSG sensibly.
-
-See also `erc-format-message' and `erc-display-line'."
- (let ((string (if (symbolp msg)
- (apply #'erc-format-message msg args)
- msg))
- (erc-message-parsed parsed))
+Insert MSG or text derived from MSG into an ERC buffer, possibly
+after applying formatting by way of either a `format-spec' known
+to a message-catalog entry or a TYPE known to a specialized
+string handler. Additionally, derive metadata, faces, and other
+text properties from the various overloaded parameters, such as
+PARSED, when it's an `erc-response' object, and MSG, when it's a
+key (symbol) for a \"message catalog\" entry. Expect ARGS, when
+applicable, to be `format-spec' args known to such an entry, and
+TYPE, when non-nil, to be a symbol handled by
+`erc-display-message-highlight' (necessarily accompanied by a
+string MSG). Expect BUFFER to be among the sort accepted by the
+function `erc-display-line'.
+
+When non-nil, expect BUFFER to be a live `erc-mode' buffer, a
+list of such buffers, or the symbols `all' or `active'. If
+`all', insert STRING in all buffers for the current session. If
+`active', defer to the function `erc-active-buffer', which may
+return the session's server buffer if the previously active
+buffer has been killed. If BUFFER is nil or a network process,
+pretend it's set to the appropriate server buffer. Otherwise,
+use the current buffer.
+
+When TYPE is a list of symbols, call handlers from left to right
+without influencing how they behave when encountering existing
+faces. As of ERC 5.6, expect a TYPE of (notice error) to insert
+MSG with `font-lock-face' as `erc-error-face' throughout.
+However, when the list of symbols begins with t, tell compatible
+handlers to compose rather than clobber faces. For example,
+expect a TYPE of (t notice error) to result in `font-lock-face'
+being (erc-error-face erc-notice-face) throughout MSG when
+`erc-notice-highlight-type' is left at its default, `all'.
+
+As of ERC 5.6, assume third-party code will use this function
+instead of lower-level ones, like `erc-insert-line', to insert
+arbitrary informative messages as if sent by the server. That
+is, tell modules to treat a \"local\" message for which PARSED is
+nil like any other server-sent message."
+ (let* ((erc--msg-props
+ (or erc--msg-props
+ (let ((table (make-hash-table))
+ (cmd (and parsed (erc--get-eq-comparable-cmd
+ (erc-response.command parsed)))))
+ (puthash 'erc--msg
+ (cond ((and msg (symbolp msg)) msg)
+ (type (pcase type
+ ((pred symbolp) type)
+ ((pred listp)
+ (intern (mapconcat #'prin1-to-string
+ type "-")))
+ (_ 'unknown)))
+ (t 'unknown))
+ table)
+ (when cmd
+ (puthash 'erc--cmd cmd table))
+ (when erc--msg-prop-overrides
+ (pcase-dolist (`(,k . ,v) (reverse erc--msg-prop-overrides))
+ (when v (puthash k v table))))
+ table)))
+ (erc-message-parsed parsed)
+ (string (if (symbolp msg) (apply #'erc-format-message msg args) msg)))
(setq string
(cond
((null type)
string)
((listp type)
- (mapc (lambda (type)
- (setq string
- (erc-display-message-highlight type string)))
- type)
+ (let ((erc--merge-text-properties-p
+ (and (eq (car type) t) (setq type (cdr type)))))
+ (dolist (type type)
+ (setq string (erc-display-message-highlight type string))))
string)
((symbolp type)
(erc-display-message-highlight type string))))
(if (not (erc-response-p parsed))
- (erc-display-line string buffer)
+ (erc--route-insertion string buffer)
(unless (erc-hide-current-message-p parsed)
(erc-put-text-property 0 (length string) 'erc-parsed parsed string)
- (erc-put-text-property 0 (length string) 'rear-sticky t string)
(when (erc-response.tags parsed)
(erc-put-text-property 0 (length string) 'tags (erc-response.tags parsed)
string))
- (erc-display-line string buffer)))))
+ (erc--route-insertion string buffer)))))
(defun erc-message-type-member (position list)
"Return non-nil if the erc-parsed text-property at POSITION is in LIST.
@@ -2892,17 +3944,39 @@ present."
(let ((prop-val (erc-get-parsed-vector position)))
(and prop-val (member (erc-response.command prop-val) list))))
-(defvar-local erc-send-input-line-function 'erc-send-input-line
- "Function for sending lines lacking a leading user command.
-When a line typed into a buffer contains an explicit command, like /msg,
-a corresponding handler (here, erc-cmd-MSG) is called. But lines typed
-into a channel or query buffer already have an implicit target and
-command (PRIVMSG). This function is called on such occasions and also
-for special purposes (see erc-dcc.el).")
+(defvar erc--called-as-input-p nil
+ "Non-nil when a user types a \"/slash\" command.
+Remains bound until `erc-cmd-SLASH' returns.")
+
+(defvar erc--current-line-input-split nil
+ "Current `erc--input-split' instance when processing user input.
+This is for special cases in which a \"slash\" command needs
+details about the input it's handling or needs to detect whether
+it's been dispatched by `erc-send-current-line'.")
+
+(defvar erc--allow-empty-outgoing-lines-p nil
+ "Flag to opt out of last-minute padding of empty lines.
+Useful to extensions, like `multiline', and for interop with
+IRC-adjacent protocols.")
+
+(defvar-local erc-send-input-line-function #'erc-send-input-line
+ "Function for sending lines lacking a leading \"slash\" command.
+When prompt input starts with a \"slash\" command, like \"/MSG\",
+ERC calls a corresponding handler, like `erc-cmd-MSG'. But
+normal \"chat\" input also needs processing, for example, to
+convert it into a proper IRC command. ERC calls this variable's
+value to perform that task, which, by default, simply involves
+constructing a \"PRIVMSG\" with the current channel or query
+partner as the target. Some libraries, like `erc-dcc', use this
+for other purposes.")
(defun erc-send-input-line (target line &optional force)
"Send LINE to TARGET."
- (when (string= line "\n")
+ (when-let ((target)
+ (cmem (erc-get-channel-member (erc-current-nick))))
+ (setf (erc-channel-user-last-message-time (cdr cmem))
+ (erc-compat--current-lisp-time)))
+ (when (and (not erc--allow-empty-outgoing-lines-p) (string= line "\n"))
(setq line " \n"))
(erc-message "PRIVMSG" (concat target " " line) force))
@@ -2930,22 +4004,26 @@ erc-cmd-FOO, this returns a string /FOO."
command-name)))
(defun erc-process-input-line (line &optional force no-command)
- "Translate LINE to an RFC1459 command and send it based.
-Returns non-nil if the command is actually sent to the server, and nil
-otherwise.
-
-If the command in the LINE is not bound as a function `erc-cmd-<COMMAND>',
-it is passed to `erc-cmd-default'. If LINE is not a command (i.e. doesn't
-start with /<COMMAND>) then it is sent as a message.
-
-An optional FORCE argument forces sending the line when flood
-protection is in effect. The optional NO-COMMAND argument prohibits
-this function from interpreting the line as a command."
+ "Dispatch a slash-command or chat-input handler from user-input LINE.
+If simplistic validation fails, print an error and return nil.
+Otherwise, defer to an appropriate handler. For \"slash\" commands,
+like \"/JOIN\", expect a handler, like `erc-cmd-JOIN', to return non-nil
+if LINE is fit for echoing as a command line when executing scripts.
+For normal chat input, expect a handler to return non-nil if a message
+was successfully processed as an outgoing \"PRIVMSG\". If LINE is a
+slash command, and ERC can't find a corresponding handler of the form
+`erc-cmd-<COMMAND>', pass LINE to `erc-cmd-default', treating it as a
+catch-all handler. Otherwise, for normal chat input, pass LINE and the
+boolean argument FORCE to `erc-send-input-line-function'. With a
+non-nil NO-COMMAND, always treat LINE as normal chat input rather than a
+slash command."
(let ((command-list (erc-extract-command-from-line line)))
(if (and command-list
(not no-command))
(let* ((cmd (nth 0 command-list))
- (args (nth 1 command-list)))
+ (args (nth 1 command-list))
+ (erc--called-as-input-p t))
+ (erc--server-last-reconnect-display-reset (erc-server-buffer))
(condition-case nil
(if (listp args)
(apply cmd args)
@@ -2961,23 +4039,85 @@ this function from interpreting the line as a command."
(let ((r (erc-default-target)))
(if r
(funcall erc-send-input-line-function r line force)
- (erc-display-message nil 'error (current-buffer) 'no-target)
+ (erc-display-message nil '(notice error) (current-buffer) 'no-target)
nil)))))
+(defconst erc--shell-parse-regexp
+ (rx (or (+ (not (any ?\s ?\t ?\n ?\\ ?\" ?' ?\;)))
+ (: ?' (group (* (not ?'))) (? ?'))
+ (: ?\" (group (* (or (not (any ?\" ?\\)) (: ?\\ nonl)))) (? ?\"))
+ (: ?\\ (group (? (or nonl ?\n)))))))
+
+(defun erc--split-string-shell-cmd (string)
+ "Parse whitespace-separated arguments in STRING."
+ ;; From `shell--parse-pcomplete-arguments' and friends. Quirk:
+ ;; backslash-escaped characters appearing within spans of double
+ ;; quotes are unescaped.
+ (with-temp-buffer
+ (insert string)
+ (let ((end (point))
+ args)
+ (goto-char (point-min))
+ (while (and (skip-chars-forward " \t") (< (point) end))
+ (let (arg)
+ (while (looking-at erc--shell-parse-regexp)
+ (goto-char (match-end 0))
+ (cond ((match-beginning 3) ; backslash escape
+ (push (if (= (match-beginning 3) (match-end 3))
+ "\\"
+ (match-string 3))
+ arg))
+ ((match-beginning 2) ; double quote
+ (push (replace-regexp-in-string (rx ?\\ (group nonl))
+ "\\1" (match-string 2))
+ arg))
+ ((match-beginning 1) ; single quote
+ (push (match-string 1) arg))
+ (t (push (match-string 0) arg))))
+ (push (string-join (nreverse arg)) args)))
+ (nreverse args))))
+
+
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Input commands handlers
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-(defun erc-cmd-AMSG (line)
- "Send LINE to all channels of the current server that you are on."
- (interactive "sSend to all channels you're on: ")
- (setq line (erc-trim-string line))
+(defun erc--connected-and-joined-p ()
+ (and (erc--current-buffer-joined-p)
+ erc-server-connected))
+
+(defun erc-cmd-GMSG (line)
+ "Send LINE to all channels on all networks you are on."
+ (setq line (string-remove-prefix " " line))
(erc-with-all-buffers-of-server nil
- (lambda ()
- (erc-channel-p (erc-default-target)))
+ #'erc--connected-and-joined-p
+ (erc-send-message line)))
+(put 'erc-cmd-GMSG 'do-not-parse-args t)
+
+(defun erc-cmd-AMSG (line)
+ "Send LINE to all channels of the current network.
+Interactively, prompt for the line of text to send."
+ (interactive "sSend to all channels on this network: ")
+ (setq line (string-remove-prefix " " line))
+ (erc-with-all-buffers-of-server erc-server-process
+ #'erc--connected-and-joined-p
(erc-send-message line)))
(put 'erc-cmd-AMSG 'do-not-parse-args t)
+(defun erc-cmd-GME (line)
+ "Send LINE as an action to all channels on all networks you are on."
+ (erc-with-all-buffers-of-server nil
+ #'erc--connected-and-joined-p
+ (erc-cmd-ME line)))
+(put 'erc-cmd-GME 'do-not-parse-args t)
+
+(defun erc-cmd-AME (line)
+ "Send LINE as an action to all channels on the current network."
+ (erc-with-all-buffers-of-server erc-server-process
+ #'erc--connected-and-joined-p
+ (erc-cmd-ME line)))
+(put 'erc-cmd-AME 'do-not-parse-args t)
+
(defun erc-cmd-SAY (line)
"Send LINE to the current query or channel as a message, not a command.
@@ -2987,9 +4127,7 @@ need this when pasting multiple lines of text."
(if (string-match "^\\s-*$" line)
nil
(string-match "^ ?\\(.*\\)" line)
- (let ((msg (match-string 1 line)))
- (erc-display-msg msg)
- (erc-process-input-line msg nil t))))
+ (erc-send-message (match-string 1 line) nil)))
(put 'erc-cmd-SAY 'do-not-parse-args t)
(defun erc-cmd-SET (line)
@@ -3064,6 +4202,8 @@ returns the time spec converted to a number of seconds."
(string-to-number period))
;; Parse as a time spec.
(t
+ (require 'time-date)
+ (require 'iso8601)
(let ((time (condition-case nil
(iso8601-parse-duration
(concat (cond
@@ -3100,16 +4240,14 @@ If no USER argument is specified, list the contents of `erc-ignore-list'."
(run-at-time timeout nil
(lambda ()
(erc--unignore-user user buffer))))
- (erc-display-line
- (erc-make-notice (format "Now ignoring %s" user))
- 'active)
+ (erc-display-message nil 'notice 'active
+ (format "Now ignoring %s" user))
(erc-with-server-buffer (add-to-list 'erc-ignore-list user))))
(if (null (erc-with-server-buffer erc-ignore-list))
- (erc-display-line (erc-make-notice "Ignore list is empty") 'active)
- (erc-display-line (erc-make-notice "Ignore list:") 'active)
+ (erc-display-message nil 'notice 'active "Ignore list is empty")
+ (erc-display-message nil 'notice 'active "Ignore list:")
(mapc (lambda (item)
- (erc-display-line (erc-make-notice item)
- 'active))
+ (erc-display-message nil 'notice 'active item))
(erc-with-server-buffer erc-ignore-list))))
t)
@@ -3123,9 +4261,8 @@ If no USER argument is specified, list the contents of `erc-ignore-list'."
(unless (y-or-n-p (format "Remove this regexp (%s)? "
ignored-nick))
(setq ignored-nick nil))
- (erc-display-line
- (erc-make-notice (format "%s is not currently ignored!" user))
- 'active)))
+ (erc-display-message nil 'notice 'active
+ (format "%s is not currently ignored!" user))))
(when ignored-nick
(erc--unignore-user user (current-buffer))))
t)
@@ -3133,16 +4270,26 @@ If no USER argument is specified, list the contents of `erc-ignore-list'."
(defun erc--unignore-user (user buffer)
(when (buffer-live-p buffer)
(with-current-buffer buffer
- (erc-display-line
- (erc-make-notice (format "No longer ignoring %s" user))
- 'active)
+ (erc-display-message nil 'notice 'active
+ (format "No longer ignoring %s" user))
(erc-with-server-buffer
(setq erc-ignore-list (delete user erc-ignore-list))))))
+(defvar erc--pre-clear-functions nil
+ "Abnormal hook run when truncating buffers.
+Called with position indicating boundary of interval to be excised.")
+
(defun erc-cmd-CLEAR ()
- "Clear the window content."
- (let ((inhibit-read-only t))
- (delete-region (point-min) (line-beginning-position)))
+ "Clear messages in current buffer after informing active modules.
+Expect modules to perform housekeeping tasks to withstand the
+disruption. When called from lisp code, only clear messages up
+to but not including the one occupying the current line."
+ (with-silent-modifications
+ (let ((max (if (>= (point) erc-insert-marker)
+ (1- erc-insert-marker)
+ (or (erc--get-inserted-msg-beg (point)) (pos-bol)))))
+ (run-hook-with-args 'erc--pre-clear-functions max)
+ (delete-region (point-min) max)))
t)
(put 'erc-cmd-CLEAR 'process-not-needed t)
@@ -3213,7 +4360,7 @@ VERSION and so on. It is called with ARGS."
(erc-send-ctcp-message nick str)
t))
-(defun erc-cmd-HELP (&optional func)
+(defun erc-cmd-HELP (&optional func &rest rest)
"Popup help information.
If FUNC contains a valid function or variable, help about that
@@ -3246,6 +4393,10 @@ For a list of user commands (/join /part, ...):
nil)))))
(if sym
(cond
+ ((get sym 'erc--cmd-help)
+ (when (autoloadp (symbol-function sym))
+ (autoload-do-load (symbol-function sym)))
+ (apply (get sym 'erc--cmd-help) rest))
((boundp sym) (describe-variable sym))
((fboundp sym) (describe-function sym))
(t nil))
@@ -3369,11 +4520,22 @@ the one with host foo would win."
(plist-get (car sorted) :secret))))
(defun erc-auth-source-search (&rest plist)
- "Call `auth-source-search', possibly with keyword params in PLIST."
+ "Call `auth-source-search', possibly with keyword params in PLIST.
+If the search signals an error before returning, `warn' the user
+and ask whether to continue connecting anyway."
;; These exist as separate helpers in case folks should find them
;; useful. If that's you, please request that they be exported.
- (apply #'erc--auth-source-search
- (apply #'erc--auth-source-determine-params-merge plist)))
+ (condition-case err
+ (apply #'erc--auth-source-search
+ (apply #'erc--auth-source-determine-params-merge plist))
+ (error
+ (erc--lwarn '(erc auth-source) :error
+ "Problem querying `auth-source': %S. See %S for more."
+ (error-message-string err)
+ '(info "(erc) auth-source Troubleshooting"))
+ (when (or noninteractive
+ (not (y-or-n-p "Ignore auth-source error and continue? ")))
+ (signal (car err) (cdr err))))))
(defun erc-server-join-channel (server channel &optional secret)
"Join CHANNEL, optionally with SECRET.
@@ -3412,7 +4574,24 @@ were most recently invited. See also `invitation'."
((with-current-buffer existing
(erc-get-channel-user (erc-current-nick)))))
(switch-to-buffer existing)
- (setq erc--server-last-reconnect-count 0)
+ (when-let* ; bind `erc-join-buffer' when /JOIN issued
+ ((erc--called-as-input-p)
+ (fn (lambda (proc parsed)
+ (when-let* ; `fn' wrapper already removed from hook
+ (((equal (car (erc-response.command-args parsed))
+ channel))
+ (sn (erc-extract-nick (erc-response.sender parsed)))
+ ((erc-nick-equal-p sn (erc-current-nick)))
+ (erc-join-buffer (or erc-interactive-display
+ erc-join-buffer))
+ (erc--display-context `((erc-interactive-display
+ . /JOIN)
+ ,@erc--display-context)))
+ (run-hook-with-args-until-success
+ 'erc-server-JOIN-functions proc parsed)
+ t))))
+ (erc-with-server-buffer
+ (erc-once-with-server-event "JOIN" fn)))
(erc-server-join-channel nil chnl key))))
t)
@@ -3592,12 +4771,10 @@ See `erc-cmd-WHOIS' for more details."
(string-to-number
(cl-third
(erc-response.command-args parsed)))))
- (erc-display-line
- (erc-make-notice
+ (erc-display-message nil 'notice origbuf
(format "%s has been idle for %s."
(erc-string-no-properties nick)
(erc-seconds-to-string idleseconds)))
- origbuf)
t)))
'erc-server-317-functions)
symlist)
@@ -3661,17 +4838,68 @@ the matching is case-sensitive."
(put 'erc-cmd-LASTLOG 'do-not-parse-args t)
(put 'erc-cmd-LASTLOG 'process-not-needed t)
+(defvar erc--send-message-nested-function #'erc--send-message-nested
+ "Function for inserting and sending slash-command generated text.
+When a command like /SV or /SAY modifies or replaces command-line
+input originally submitted at the prompt, `erc-send-message'
+performs additional processing to ensure said input is fit for
+inserting and sending given this \"nested\" meta context. This
+interface variable exists because modules extending fundamental
+insertion and sending operations need a say in this processing as
+well.")
+
(defun erc-send-message (line &optional force)
"Send LINE to the current channel or user and display it.
See also `erc-message' and `erc-display-line'."
- (erc-message "PRIVMSG" (concat (erc-default-target) " " line) force)
- (erc-display-line
- (concat (erc-format-my-nick) line)
- (current-buffer))
+ (if (erc--input-split-p erc--current-line-input-split)
+ (funcall erc--send-message-nested-function line force)
+ (erc--send-message-external line force)))
+
+(defun erc--send-message-external (line force)
+ "Send a \"PRIVMSG\" to the default target with optional FORCE.
+Expect caller to bind `erc-default-recipients' if needing to
+specify a status-prefixed target."
+ ;; Almost like an echoed message, but without the `erc--cmd'.
+ (let* ((erc-current-message-catalog erc--message-speaker-catalog)
+ (target (erc-default-target))
+ (erc--msg-prop-overrides `((erc--tmp) ,@erc--msg-prop-overrides))
+ ;; This util sets the `erc--spkr' property in ^.
+ (trimmed (erc--statusmsg-target target))
+ (stmsgindc (and trimmed (substring target 0 1)))
+ (queryp (and erc--target (not (erc--target-channel-p erc--target))))
+ (args (erc--determine-speaker-message-format-args
+ (erc-current-nick) line queryp 'privmsgp 'inputp
+ stmsgindc 'prefix)))
+ (erc-message "PRIVMSG" (concat target " " line) force)
+ (push (cons 'erc--msg (car args)) erc--msg-prop-overrides)
+ (apply #'erc-display-message nil nil (current-buffer) args))
;; FIXME - treat multiline, run hooks, or remove me?
+ ;; FIXME explain this ^ in more detail or remove.
+ t)
+
+(defun erc--send-message-nested (input-line force)
+ "Process string INPUT-LINE almost as if it's normal chat input.
+Expect INPUT-LINE to differ from the `string' slot of the calling
+context's `erc--current-line-input-split' object because the
+latter is likely a slash command invocation whose handler
+generated INPUT-LINE. Before inserting INPUT-LINE, split it and
+run `erc-send-modify-hook' and `erc-send-post-hook' on each
+actual outgoing line. Forgo input validation because this isn't
+interactive input, and skip `erc-send-completed-hook' because it
+will run just before the outer `erc-send-current-line' call
+returns."
+ (let* ((erc-flood-protect (not force))
+ (lines-obj (erc--make-input-split input-line)))
+ (setf (erc--input-split-refoldp lines-obj) t
+ (erc--input-split-cmdp lines-obj) nil)
+ (erc--send-input-lines (erc--run-send-hooks lines-obj)))
t)
+;; FIXME if the user types /MODE<RET>, LINE becomes "\n", which
+;; matches the pattern, so "\n" is sent to the server. Perhaps
+;; instead of `do-not-parse-args', this should just join &rest
+;; arguments.
(defun erc-cmd-MODE (line)
"Change or display the mode value of a channel or user.
The first word specifies the target. The rest is the mode string
@@ -3686,7 +4914,7 @@ A list of valid mode strings for Libera.Chat may be found at
((string-match "^\\s-\\(.*\\)$" line)
(let ((s (match-string 1 line)))
(erc-log (format "cmd: MODE: %s" s))
- (erc-server-send (concat "MODE " line)))
+ (erc-server-send (concat "MODE " s)))
t)
(t nil)))
(put 'erc-cmd-MODE 'do-not-parse-args t)
@@ -3711,6 +4939,7 @@ The rest of LINE is the message to send."
The rest of LINE is the message to send."
(erc-message "SQUERY" line))
+(put 'erc-cmd-SQUERY 'do-not-parse-args t)
(defun erc-cmd-NICK (nick)
"Change current nickname to NICK."
@@ -3753,7 +4982,7 @@ Otherwise leave the channel indicated by LINE."
(format "PART %s" ch)
(format "PART %s :%s" ch reason))
nil ch))
- (erc-display-message nil 'error (current-buffer) 'no-target)))
+ (erc-display-message nil '(notice error) (current-buffer) 'no-target)))
t)
(t nil)))
(put 'erc-cmd-PART 'do-not-parse-args t)
@@ -3776,27 +5005,10 @@ just as you provided it. Use this command with care!"
(t nil)))
(put 'erc-cmd-QUOTE 'do-not-parse-args t)
-(defcustom erc-query-display 'window
- "How to display query buffers when using the /QUERY command to talk to someone.
-
-The default behavior is to display the message in a new window
-and bring it to the front. See the documentation for
-`erc-join-buffer' for a description of the available choices.
-
-See also `erc-auto-query' to decide how private messages from
-other people should be displayed."
- :group 'erc-query
- :type '(choice (const :tag "Split window and select" window)
- (const :tag "Split window, don't select" window-noselect)
- (const :tag "New frame" frame)
- (const :tag "Bury in new buffer" bury)
- (const :tag "Use current buffer" buffer)
- (const :tag "Use current buffer" t)))
-
(defun erc-cmd-QUERY (&optional user)
"Open a query with USER.
How the query is displayed (in a new window, frame, etc.) depends
-on the value of `erc-query-display'."
+on the value of `erc-interactive-display'."
;; FIXME: The doc string used to say at the end:
;; "If USER is omitted, close the current query buffer if one exists
;; - except this is broken now ;-)"
@@ -3807,8 +5019,10 @@ on the value of `erc-query-display'."
(unless user
;; currently broken, evil hack to display help anyway
;(erc-delete-query))))
- (signal 'wrong-number-of-arguments ""))
- (let ((erc-join-buffer erc-query-display))
+ (signal 'wrong-number-of-arguments '(erc-cmd-QUERY 0)))
+ (let ((erc-join-buffer erc-interactive-display)
+ (erc--display-context `((erc-interactive-display . /QUERY)
+ ,@erc--display-context)))
(erc-with-server-buffer
(erc--open-target user))))
@@ -3916,10 +5130,7 @@ the message given by REASON."
;; kill them
(run-at-time
4 nil
- (lambda ()
- (dolist (buffer (erc-buffer-list (lambda (buf)
- (not (erc-server-buffer-p buf)))))
- (kill-buffer buffer)))))
+ #'erc-buffer-do (lambda () (when erc--target (kill-buffer)))))
t)
(defalias 'erc-cmd-GQ #'erc-cmd-GQUIT)
@@ -3928,6 +5139,9 @@ the message given by REASON."
(defun erc--cmd-reconnect ()
(let ((buffer (erc-server-buffer))
+ (erc-join-buffer erc-interactive-display)
+ (erc--display-context `((erc-interactive-display . /RECONNECT)
+ ,@erc--display-context))
(process nil))
(unless (buffer-live-p buffer)
(setq buffer (current-buffer)))
@@ -3962,6 +5176,8 @@ connection or, with -A, all applicable connections.
(put 'erc-cmd-RECONNECT 'process-not-needed t)
+;; FIXME use less speculative error message or lose `condition-case',
+;; since most connection failures don't signal anything.
(defun erc-cmd-SERVER (server)
"Connect to SERVER, leaving existing connection intact."
(erc-log (format "cmd: SERVER: %s" server))
@@ -3980,9 +5196,11 @@ connection or, with -A, all applicable connections.
system-configuration
(concat
(cond ((featurep 'motif)
+ (defvar motif-version-string)
(concat ", " (substring
motif-version-string 4)))
((featurep 'gtk)
+ (defvar gtk-version-string)
(concat ", GTK+ Version "
gtk-version-string))
((featurep 'x-toolkit) ", X toolkit")
@@ -4056,6 +5274,22 @@ means that the user has a +o flag in the channel's access list)."
(t (erc-server-send "TIME"))))
(defalias 'erc-cmd-DATE #'erc-cmd-TIME)
+(defun erc-cmd-MOTD (&optional target)
+ "Ask server to send the current MOTD.
+Some IRCds simply ignore TARGET."
+ (letrec ((oneoff (lambda (proc parsed)
+ (with-current-buffer (erc-server-buffer)
+ (cl-assert (eq (current-buffer) (process-buffer proc)))
+ (remove-hook 'erc-server-402-functions h402 t)
+ (remove-hook 'erc-server-376-functions h376 t)
+ (remove-hook 'erc-server-422-functions h422 t))
+ (erc-server-MOTD proc parsed)
+ t))
+ (h402 (erc-once-with-server-event 402 oneoff))
+ (h376 (erc-once-with-server-event 376 oneoff))
+ (h422 (erc-once-with-server-event 422 oneoff)))
+ (erc-server-send (concat "MOTD" (and target " ") target))))
+
(defun erc-cmd-TOPIC (topic)
"Set or request the topic for a channel.
LINE has the format: \"#CHANNEL TOPIC\", \"#CHANNEL\", \"TOPIC\"
@@ -4092,7 +5326,7 @@ be displayed."
(progn
(erc-log (format "cmd: TOPIC [%s]: %s" ch topic))
(erc-server-send (format "TOPIC %s :%s" ch topic) nil ch))
- (erc-display-message nil 'error (current-buffer) 'no-target)))
+ (erc-display-message nil '(notice error) (current-buffer) 'no-target)))
t)
(t nil)))
(defalias 'erc-cmd-T #'erc-cmd-TOPIC)
@@ -4142,8 +5376,7 @@ The ban list is fetched from the server if necessary."
(cond
((not (erc-channel-p chnl))
- (erc-display-line (erc-make-notice "You're not on a channel\n")
- 'active))
+ (erc-display-message nil 'notice 'active "You're not on a channel\n"))
((not (get 'erc-channel-banlist 'received-from-server))
(let ((old-367-hook erc-server-367-functions))
@@ -4162,9 +5395,8 @@ The ban list is fetched from the server if necessary."
(erc-server-send (format "MODE %s b" chnl)))))
((null erc-channel-banlist)
- (erc-display-line (erc-make-notice
- (format "No bans for channel: %s\n" chnl))
- 'active)
+ (erc-display-message nil 'notice 'active
+ (format "No bans for channel: %s\n" chnl))
(put 'erc-channel-banlist 'received-from-server nil))
(t
@@ -4178,10 +5410,9 @@ The ban list is fetched from the server if necessary."
"%-" (number-to-string (/ erc-fill-column 2)) "s"
"%" (number-to-string (/ erc-fill-column 2)) "s")))
- (erc-display-line
- (erc-make-notice (format "Ban list for channel: %s\n"
- (erc-default-target)))
- 'active)
+ (erc-display-message
+ nil 'notice 'active
+ (format "Ban list for channel: %s\n" (erc-default-target)))
(erc-display-line separator 'active)
(erc-display-line (format fmt "Ban Mask" "Banned By") 'active)
@@ -4198,8 +5429,7 @@ The ban list is fetched from the server if necessary."
'active))
erc-channel-banlist)
- (erc-display-line (erc-make-notice "End of Ban list")
- 'active)
+ (erc-display-message nil 'notice 'active "End of Ban list")
(put 'erc-channel-banlist 'received-from-server nil)))))
t)
@@ -4213,9 +5443,7 @@ Unban all currently banned users in the current channel."
(cond
((not (erc-channel-p chnl))
- (erc-display-line
- (erc-make-notice "You're not on a channel\n")
- 'active))
+ (erc-display-message nil 'notice 'active "You're not on a channel\n"))
((not (get 'erc-channel-banlist 'received-from-server))
(let ((old-367-hook erc-server-367-functions))
@@ -4256,6 +5484,32 @@ Eventually add a # in front of it, if that turns it into a valid channel name."
channel
(concat "#" channel)))
+(defvar erc--own-property-names
+ `( tags erc--speaker erc-parsed display ; core
+ ;; `erc--msg-props'
+ ,@erc--ranked-properties
+ ;; `erc-display-prompt'
+ rear-nonsticky erc-prompt field front-sticky read-only
+ ;; stamp
+ cursor-intangible cursor-sensor-functions isearch-open-invisible
+ ;; match
+ invisible intangible
+ ;; button
+ erc-callback erc-data mouse-face keymap
+ ;; fill-wrap
+ line-prefix wrap-prefix)
+ "Props added by ERC that should not survive killing.
+Among those left behind by default are `font-lock-face' and
+`erc-secret'.")
+
+(defun erc--remove-text-properties (string)
+ "Remove text properties in STRING added by ERC.
+Specifically, remove any that aren't members of
+`erc--own-property-names'."
+ (remove-list-of-text-properties 0 (length string)
+ erc--own-property-names string)
+ string)
+
(defun erc-grab-region (start end)
"Copy the region between START and END in a recreatable format.
@@ -4304,12 +5558,7 @@ If FACE is non-nil, it will be used to propertize the prompt. If it is nil,
;; Do not extend the text properties when typing at the end
;; of the prompt, but stuff typed in front of the prompt
;; shall remain part of the prompt.
- (setq prompt (propertize prompt
- 'rear-nonsticky t
- 'erc-prompt t
- 'field t
- 'front-sticky t
- 'read-only t))
+ (setq prompt (apply #'propertize prompt erc--prompt-properties))
(erc-put-text-property 0 (1- (length prompt))
'font-lock-face (or face 'erc-prompt-face)
prompt)
@@ -4443,6 +5692,19 @@ This places `point' just after the prompt, or at the beginning of the line."
(setq erc-input-ring-index nil))
(kill-line)))
+(defvar erc--tab-functions nil
+ "Functions to try when user hits \\`TAB' outside of input area.
+Called with a numeric prefix arg.")
+
+(defun erc-tab (arg)
+ "Call `completion-at-point' when typing in the input area.
+Otherwise call members of `erc--tab-functions' with a numeric
+prefix ARG until one of them returns non-nil."
+ (interactive "p")
+ (if (>= (point) erc-input-marker)
+ (completion-at-point)
+ (run-hook-with-args-until-success 'erc--tab-functions arg)))
+
(defun erc-complete-word-at-point ()
(run-hook-with-args-until-success 'erc-complete-functions))
@@ -4457,9 +5719,13 @@ This places `point' just after the prompt, or at the beginning of the line."
; Stolen from ZenIRC. I just wanna test this code, so here is
; experiment area.
-(defcustom erc-default-server-hook '(erc-debug-missing-hooks
- erc-default-server-handler)
- "Default for server messages which aren't covered by `erc-server-hooks'."
+;; This shouldn't be a user option but remains so for compatibility.
+(define-obsolete-variable-alias
+ 'erc-default-server-hook 'erc-default-server-functions "30.1")
+(defcustom erc-default-server-functions '(erc-handle-unknown-server-response)
+ "Abnormal hook for incoming messages without their own handlers.
+See `define-erc-response-handler' for more."
+ :package-version '(ERC . "5.6")
:group 'erc-server-hooks
:type 'hook)
@@ -4467,6 +5733,7 @@ This places `point' just after the prompt, or at the beginning of the line."
"Default server handler.
Displays PROC and PARSED appropriately using `erc-display-message'."
+ (declare (obsolete erc-handle-unknown-server-response "29.1"))
(erc-display-message
parsed 'notice proc
(mapconcat
@@ -4489,7 +5756,7 @@ See `erc-debug-missing-hooks'.")
"Add PARSED server message ERC does not yet handle to `erc-server-vectors'.
These vectors can be helpful when adding new server message handlers to ERC.
See `erc-default-server-hook'."
- (nconc erc-server-vectors (list parsed))
+ (setq erc-server-vectors `(,@erc-server-vectors ,parsed))
nil)
(defun erc--open-target (target)
@@ -4517,47 +5784,60 @@ To change how this query window is displayed, use `let' to bind
(with-current-buffer server-buffer
(erc--open-target target)))
-(defcustom erc-auto-query 'window-noselect
+(defvaralias 'erc-auto-query 'erc-receive-query-display)
+(defcustom erc-receive-query-display 'window-noselect
"If non-nil, create a query buffer each time you receive a private message.
If the buffer doesn't already exist, it is created.
This can be set to a symbol, to control how the new query window
should appear. The default behavior is to display the buffer in
-a new window, but not to select it. See the documentation for
-`erc-join-buffer' for a description of the available choices."
+a new window but not to select it. See the documentation for
+`erc-buffer-display' for a description of available values.
+
+Note that the legacy behavior of forgoing buffer creation
+entirely when this option is nil requires setting the
+compatibility flag `erc-receive-query-display-defer' to nil. Use
+`erc-ensure-target-buffer-on-privmsg' to achieve the same effect."
+ :package-version '(ERC . "5.6")
+ :group 'erc-buffers
:group 'erc-query
- :type '(choice (const :tag "Don't create query window" nil)
- (const :tag "Split window and select" window)
- (const :tag "Split window, don't select" window-noselect)
- (const :tag "New frame" frame)
- (const :tag "Bury in new buffer" bury)
- (const :tag "Use current buffer" buffer)
- (const :tag "Use current buffer" t)))
-
-(defcustom erc-query-on-unjoined-chan-privmsg t
- "If non-nil create query buffer on receiving any PRIVMSG at all.
+ :type erc--buffer-display-choices)
+
+(defvar erc-receive-query-display-defer t
+ "How to interpret a null `erc-receive-query-display'.
+When this variable is non-nil, ERC defers to `erc-buffer-display'
+upon seeing a nil value for `erc-receive-query-display', much
+like it does with other buffer-display options, like
+`erc-interactive-display'. Otherwise, when this option is nil,
+ERC retains the legacy behavior of not creating a new query
+buffer.")
+
+(defvaralias 'erc-query-on-unjoined-chan-privmsg
+ 'erc-ensure-target-buffer-on-privmsg)
+(defcustom erc-ensure-target-buffer-on-privmsg t
+ "When non-nil, create a target buffer upon receiving a PRIVMSG.
This includes PRIVMSGs directed to channels. If you are using an IRC
bouncer, such as dircproxy, to keep a log of channels when you are
disconnected, you should set this option to t.
-WARNING: this option was mistakenly removed from ERC 5.5's client
-code, so setting it to nil is temporarily ineffective. That is,
-ERC now always creates a buffer when receiving a PRIVMSG directed
-at a channel for which none exists. And despite this option's
-name and its doc string's use of \"query\" to refer to any
-conversation with a target, it did not previously allow for
-opting out of buffer creation for direct messages (at least not
-in Emacs 27 and 28). However, such behavior has always been and
-will continue to be available by setting `erc-auto-query' to nil.
-If needing to restore pre-5.5 functionality immediately, see Info
-node `(erc) Upgrading'."
+For queries (direct messages), this option's non-nil meaning is
+straightforward: if a buffer doesn't exist for the sender, create
+one. For channels, the use case is more niche and usually
+involves receiving playback (via commands like ZNC's
+\"PLAYBUFFER\") for channels to which your bouncer is joined but
+from which you've \"detached\".
+
+Note that this option was absent from ERC 5.5 because knowledge
+of its intended role was \"unavailable\" during a major
+refactoring involving buffer management. The option has since
+been restored in ERC 5.6 but now also affects queries in the
+manner implied above, which was lost sometime before ERC 5.4."
+ :package-version '(ERC . "5.6") ; revived
+ :group 'erc-buffers
:group 'erc-query
- :set (lambda (sym val)
- (unless (set sym val)
- (lwarn 'erc :warning
- "Setting `%s' to nil is currently ineffective; %s"
- sym "see doc string for details.")))
- :type 'boolean)
+ :type '(choice boolean
+ (choice :tag "Create pseudo queries for STATUSMSGs"
+ status)))
(defcustom erc-format-query-as-channel-p t
"If non-nil, format text from others in a query buffer like in a channel.
@@ -4596,6 +5876,10 @@ E.g. \"Read error to Nick [user@some.host]: 110\" would be shortened to
(match-string 1 reason))
reason))
+(cl-defmethod erc--nickname-in-use-make-request (_nick temp)
+ "Request nickname TEMP in place of rejected NICK."
+ (erc-cmd-NICK temp))
+
(defun erc-nickname-in-use (nick reason)
"If NICK is unavailable, tell the user the REASON.
@@ -4629,7 +5913,7 @@ See also `erc-display-error-notice'."
;; established a connection yet
(- 9 (length erc-nick-uniquifier))))
erc-nick-uniquifier)))
- (erc-cmd-NICK newnick)
+ (erc--nickname-in-use-make-request nick newnick)
(erc-display-error-notice
nil
(format "Nickname %s is %s, trying %s"
@@ -4637,6 +5921,9 @@ See also `erc-display-error-notice'."
;;; Server messages
+;; FIXME remove on next major version release. This group is all but
+;; unused because most `erc-server-FOO-functions' are plain variables
+;; and not user options as implied by this doc string.
(defgroup erc-server-hooks nil
"Server event callbacks.
Every server event - like numeric replies - has its own hook.
@@ -4684,57 +5971,318 @@ and as second argument the event parsed as a vector."
(and (erc-is-message-ctcp-p message)
(not (string-match "^\C-aACTION.*\C-a$" message))))
+(defun erc--get-speaker-bounds ()
+ "Return the bounds of `erc--speaker' text property when present.
+Assume buffer is narrowed to the confines of an inserted message."
+ (and-let* (((erc--check-msg-prop 'erc--spkr))
+ (beg (text-property-not-all (point-min) (point-max)
+ 'erc--speaker nil)))
+ (cons beg (next-single-property-change beg 'erc--speaker))))
+
+(defvar erc--cmem-from-nick-function #'erc--cmem-get-existing
+ "Function maybe returning a \"channel member\" cons from a nick.
+Must return either nil or a cons of an `erc-server-user' and an
+`erc-channel-user' (see `erc-channel-users') for use in
+formatting a user's nick prior to insertion. Called in the
+appropriate target buffer with the downcased nick, the parsed
+NUH, and the current `erc-response' object.")
+
+(defun erc--cmem-get-existing (downcased _nuh _parsed)
+ (and erc-channel-users (gethash downcased erc-channel-users)))
+
(defun erc-format-privmessage (nick msg privp msgp)
"Format a PRIVMSG in an insertable fashion."
(let* ((mark-s (if msgp (if privp "*" "<") "-"))
(mark-e (if msgp (if privp "*" ">") "-"))
(str (format "%s%s%s %s" mark-s nick mark-e msg))
(nick-face (if privp 'erc-nick-msg-face 'erc-nick-default-face))
+ (nick-prefix-face (get-text-property 0 'font-lock-face nick))
+ (prefix-len (or (and nick-prefix-face (text-property-not-all
+ 0 (length nick) 'font-lock-face
+ nick-prefix-face nick))
+ 0))
(msg-face (if privp 'erc-direct-msg-face 'erc-default-face)))
+ (erc--ensure-spkr-prop nick)
;; add text properties to text before the nick, the nick and after the nick
(erc-put-text-property 0 (length mark-s) 'font-lock-face msg-face str)
- (erc-put-text-property (length mark-s) (+ (length mark-s) (length nick))
- 'font-lock-face nick-face str)
+ (erc-put-text-properties (+ (length mark-s) prefix-len)
+ (+ (length mark-s) (length nick))
+ '(font-lock-face erc--speaker) str
+ (list nick-face
+ (substring-no-properties nick prefix-len)))
(erc-put-text-property (+ (length mark-s) (length nick)) (length str)
'font-lock-face msg-face str)
str))
-(defcustom erc-format-nick-function 'erc-format-nick
- "Function to format a nickname for message display."
+;; The format strings in the following `-speaker' catalog shouldn't
+;; contain any non-protocol words, so they make sense in any language.
+
+(defvar erc--message-speaker-statusmsg
+ #("(%p%n%s) %m"
+ 0 1 (font-lock-face erc-default-face)
+ 1 3 (font-lock-face erc-nick-prefix-face)
+ 3 5 (font-lock-face erc-nick-default-face)
+ 5 7 (font-lock-face erc-notice-face)
+ 7 11 (font-lock-face erc-default-face))
+ "Message template for in-channel status messages.")
+
+(defvar erc--message-speaker-statusmsg-input
+ #("(%p%n%s) %m"
+ 0 1 (font-lock-face erc-default-face)
+ 1 3 (font-lock-face erc-my-nick-prefix-face)
+ 3 5 (font-lock-face erc-my-nick-face)
+ 5 7 (font-lock-face erc-notice-face)
+ 7 8 (font-lock-face erc-default-face)
+ 8 11 (font-lock-face erc-input-face))
+ "Message template for echoed status messages.")
+
+(defvar erc--message-speaker-input-chan-privmsg
+ #("<%p%n> %m"
+ 0 1 (font-lock-face erc-default-face)
+ 1 3 (font-lock-face erc-my-nick-prefix-face)
+ 3 5 (font-lock-face erc-my-nick-face)
+ 5 7 (font-lock-face erc-default-face)
+ 7 9 (font-lock-face erc-input-face))
+ "Message template for prompt input or echoed PRIVMSG from own nick.")
+
+(defvar erc--message-speaker-input-query-privmsg
+ #("*%n* %m"
+ 0 1 (font-lock-face erc-direct-msg-face)
+ 1 3 (font-lock-face erc-my-nick-face)
+ 3 5 (font-lock-face erc-direct-msg-face)
+ 5 7 (font-lock-face erc-input-face))
+ "Message template for prompt input or echoed PRIVMSG query from own nick.")
+
+(defvar erc--message-speaker-input-query-notice
+ #("-%n- %m"
+ 0 1 (font-lock-face erc-direct-msg-face)
+ 1 3 (font-lock-face erc-my-nick-face)
+ 3 5 (font-lock-face erc-direct-msg-face)
+ 5 7 (font-lock-face erc-input-face))
+ "Message template for echoed or spoofed query NOTICE from own nick.")
+
+(defvar erc--message-speaker-input-chan-notice
+ #("-%p%n- %m"
+ 0 1 (font-lock-face erc-default-face)
+ 1 3 (font-lock-face erc-my-nick-prefix-face)
+ 3 5 (font-lock-face erc-my-nick-face)
+ 5 7 (font-lock-face erc-default-face)
+ 7 9 (font-lock-face erc-input-face))
+ "Message template for prompt input or echoed NOTICE from own nick.")
+
+(defvar erc--message-speaker-chan-privmsg
+ #("<%p%n> %m"
+ 0 1 (font-lock-face erc-default-face)
+ 1 3 (font-lock-face erc-nick-prefix-face)
+ 3 5 (font-lock-face erc-nick-default-face)
+ 5 9 (font-lock-face erc-default-face))
+ "Message template for a PRIVMSG in a channel.")
+
+(defvar erc--message-speaker-query-privmsg
+ #("*%n* %m"
+ 0 1 (font-lock-face erc-direct-msg-face)
+ 1 3 (font-lock-face erc-nick-msg-face)
+ 3 7 (font-lock-face erc-direct-msg-face))
+ "Message template for a PRIVMSG in query buffer.")
+
+(defvar erc--message-speaker-chan-notice
+ #("-%p%n- %m"
+ 0 1 (font-lock-face erc-default-face)
+ 1 3 (font-lock-face erc-nick-prefix-face)
+ 3 5 (font-lock-face erc-nick-default-face)
+ 5 9 (font-lock-face erc-default-face))
+ "Message template for a NOTICE in a channel.")
+
+(defvar erc--message-speaker-query-notice
+ #("-%n- %m"
+ 0 1 (font-lock-face erc-direct-msg-face)
+ 1 3 (font-lock-face erc-nick-msg-face)
+ 3 7 (font-lock-face erc-direct-msg-face))
+ "Message template for a NOTICE in a query buffer.")
+
+(defvar erc--message-speaker-ctcp-action
+ #("* %p%n %m"
+ 0 2 (font-lock-face erc-action-face)
+ 2 4 (font-lock-face (erc-nick-prefix-face erc-action-face))
+ 4 9 (font-lock-face erc-action-face))
+ "Message template for a CTCP ACTION from another user.")
+
+(defvar erc--message-speaker-ctcp-action-input
+ #("* %p%n %m"
+ 0 2 (font-lock-face #1=(erc-input-face erc-action-face))
+ 2 4 (font-lock-face (erc-my-nick-prefix-face . #1#))
+ 4 6 (font-lock-face (erc-my-nick-face . #1#))
+ 6 9 (font-lock-face #1#))
+ "Message template for a CTCP ACTION from current client.")
+
+(defvar erc--message-speaker-ctcp-action-statusmsg
+ #("* (%p%n%s) %m"
+ 0 3 (font-lock-face erc-action-face)
+ 3 5 (font-lock-face (erc-nick-prefix-face erc-action-face))
+ 5 7 (font-lock-face erc-action-face)
+ 7 9 (font-lock-face (erc-notice-face erc-action-face))
+ 9 13 (font-lock-face erc-action-face))
+ "Template for a CTCP ACTION status message from another chan op.")
+
+(defvar erc--message-speaker-ctcp-action-statusmsg-input
+ #("* (%p%n%s) %m"
+ 0 3 (font-lock-face #1=(erc-input-face erc-action-face))
+ 3 5 (font-lock-face (erc-my-nick-prefix-face . #1#))
+ 5 7 (font-lock-face (erc-my-nick-face . #1#))
+ 7 9 (font-lock-face (erc-notice-face . #1#))
+ 9 13 (font-lock-face #1#))
+ "Template for a CTCP ACTION status message from current client.")
+
+(defun erc--speakerize-nick (nick &optional disp)
+ "Propertize NICK with `erc--speaker' if not already present.
+Do so to DISP instead if it's non-nil. In either case, assign
+NICK, sans properties, as the `erc--speaker' value. As a side
+effect, pair the latter string (the same `eq'-able object) with
+the symbol `erc--spkr' in the \"msg prop\" environment for any
+imminent `erc-display-message' invocations. While doing so,
+include any overrides defined in `erc--message-speaker-catalog'."
+ (let ((plain-nick (substring-no-properties nick)))
+ (erc--ensure-spkr-prop plain-nick (get erc--message-speaker-catalog
+ 'erc--msg-prop-overrides))
+ (if (text-property-not-all 0 (length (or disp nick))
+ 'erc--speaker nil (or disp nick))
+ (or disp nick)
+ (propertize (or disp nick) 'erc--speaker plain-nick))))
+
+(defun erc--determine-speaker-message-format-args
+ (nick message queryp privmsgp inputp &optional statusmsg prefix disp-nick)
+ "Return a list consisting of a \"speaker\"-template key and spec args.
+Consider the three flags QUERYP, PRIVMSGP, and INPUTP, as well as
+the possibly null STATUSMSG string. (Combined, these describe
+the context of a newly arrived \"PRIVMSG\" or, when PRIVMSGP is
+nil, a \"NOTICE\"). Interpret QUERYP to mean that MESSAGE is
+directed at the ERC client itself (a direct message), and INPUTP
+to mean MESSAGE is an outgoing or echoed message originating from
+or meant to simulate prompt input. Interpret a non-nil STATUSMSG
+to mean MESSAGE should be formatted as a special channel message
+intended for privileged members of the same or greater status.
+
+After deciding on the template key for the current \"speaker\"
+catalog, use the remaining arguments, possibly along with
+STATUSMSG, to construct the appropriate spec-args plist forming
+the returned list's tail. In this plist, pair the char ?n with
+NICK, the nickname of the speaker and ?m with MESSAGE, the
+message body. When non-nil, assume DISP-NICK to be a possibly
+phony display name to take the place of NICK for ?n. When PREFIX
+is non-nil, look up NICK's channel-membership status, possibly
+using PREFIX itself if it's an `erc-channel-user' object, which
+it must be when called outside of a channel buffer. Pair the
+result with the ?p specifier. When STATUSMSG is non-nil, pair it
+with the ?s specifier. Ensure unused spec values are the empty
+string rather than nil."
+ (when prefix
+ (setq prefix (erc-get-channel-membership-prefix
+ (if (erc-channel-user-p prefix) prefix nick))))
+ (when (and queryp erc--target erc-format-query-as-channel-p
+ (not (erc--target-channel-p erc--target)))
+ (setq queryp nil))
+ (list (cond (statusmsg (if inputp 'statusmsg-input 'statusmsg))
+ (privmsgp (if queryp
+ (if inputp 'input-query-privmsg 'query-privmsg)
+ (if inputp 'input-chan-privmsg 'chan-privmsg)))
+ (t (if queryp
+ (if inputp 'input-query-notice 'query-notice)
+ (if inputp 'input-chan-notice 'chan-notice))))
+ ?p (or prefix "") ?n (erc--speakerize-nick nick disp-nick)
+ ?s (or statusmsg "") ?m message))
+
+(defcustom erc-show-speaker-membership-status nil
+ "Whether to prefix speakers with their channel status.
+For example, when this option is non-nil and some nick \"Alice\"
+has operator status in the current channel, ERC displays their
+leading \"speaker\" label as <@Alice> instead of <Alice>."
+ :package-version '(ERC . "5.6")
:group 'erc-display
- :type 'function)
+ :type 'boolean)
-(defun erc-format-nick (&optional user _channel-data)
- "Return the nickname of USER.
-See also `erc-format-nick-function'."
- (when user (erc-server-user-nickname user)))
+(define-obsolete-variable-alias 'erc-format-nick-function
+ 'erc-speaker-from-channel-member-function "30.1")
+(defcustom erc-speaker-from-channel-member-function
+ #'erc-determine-speaker-from-user
+ "Function to determine a message's displayed \"speaker\" label.
+Called with an `erc-server-user' object and an `erc-channel-user'
+object, both possibly nil. Use this option to do things like
+provide localized display names. To ask ERC to prepend
+channel-membership \"status\" prefixes, like \"@\", to the
+returned name, see `erc-show-speaker-membership-status'."
+ :package-version '(ERC . "5.6")
+ :group 'erc-display
+ :type '(choice (function-item erc-determine-speaker-from-user) function))
-(defun erc-get-user-mode-prefix (user)
- (when user
- (cond ((erc-channel-user-owner-p user)
- (propertize "~" 'help-echo "owner"))
- ((erc-channel-user-admin-p user)
- (propertize "&" 'help-echo "admin"))
- ((erc-channel-user-op-p user)
- (propertize "@" 'help-echo "operator"))
- ((erc-channel-user-halfop-p user)
- (propertize "%" 'help-echo "half-op"))
- ((erc-channel-user-voice-p user)
- (propertize "+" 'help-echo "voice"))
- (t ""))))
+(define-obsolete-function-alias 'erc-format-nick
+ #'erc-determine-speaker-from-user "30.1")
+(defun erc-determine-speaker-from-user (&optional user _channel-data)
+ "Return nickname slot of `erc-server-user' USER, when non-nil."
+ (when user (erc-server-user-nickname user)))
-(defun erc-format-@nick (&optional user _channel-data)
+(define-obsolete-function-alias 'erc-get-user-mode-prefix
+ #'erc-get-channel-membership-prefix "30.1")
+(defun erc-get-channel-membership-prefix (nick-or-cusr)
+ "Return channel membership prefix for NICK-OR-CUSR as a string.
+Ensure returned string has a `help-echo' text property with the
+corresponding verbose membership type, like \"voice\", as its
+value. Expect NICK-OR-CUSR to be an `erc-channel-user' object or
+a string nickname, not necessarily downcased. When called in a
+logically connected ERC buffer, use advertised prefix mappings.
+For compatibility reasons, don't error when NICK-OR-CUSR is null,
+but return nil instead of the empty string. Otherwise, always
+return a possibly empty string."
+ (when nick-or-cusr
+ (when (stringp nick-or-cusr)
+ (setq nick-or-cusr (and erc-channel-members
+ (cdr (erc-get-channel-member nick-or-cusr)))))
+ (cond
+ ((null nick-or-cusr) "")
+ ;; Special-case most common value.
+ ((zerop (erc-channel-user-status nick-or-cusr)) "")
+ ;; For compatibility, first check whether a parsed prefix exists.
+ ((and-let* ((pfx-obj (erc--parsed-prefix)))
+ (catch 'done
+ (pcase-dolist (`(,letter . ,pfx)
+ (erc--parsed-prefix-alist pfx-obj))
+ (when (erc--cusr-status-p nick-or-cusr letter)
+ (throw 'done
+ (pcase letter
+ (?q (propertize (string pfx) 'help-echo "owner"))
+ (?a (propertize (string pfx) 'help-echo "admin"))
+ (?o (propertize (string pfx) 'help-echo "operator"))
+ (?h (propertize (string pfx) 'help-echo "half-op"))
+ (?v (propertize (string pfx) 'help-echo "voice"))
+ (_ (string pfx))))))
+ "")))
+ (t
+ (cond ((erc-channel-user-owner nick-or-cusr)
+ (propertize "~" 'help-echo "owner"))
+ ((erc-channel-user-admin nick-or-cusr)
+ (propertize "&" 'help-echo "admin"))
+ ((erc-channel-user-op nick-or-cusr)
+ (propertize "@" 'help-echo "operator"))
+ ((erc-channel-user-halfop nick-or-cusr)
+ (propertize "%" 'help-echo "half-op"))
+ ((erc-channel-user-voice nick-or-cusr)
+ (propertize "+" 'help-echo "voice"))
+ (t ""))))))
+
+(defun erc-format-@nick (&optional user channel-data)
"Format the nickname of USER showing if USER has a voice, is an
operator, half-op, admin or owner. Owners have \"~\", admins have
\"&\", operators have \"@\" and users with voice have \"+\" as a
-prefix. Use CHANNEL-DATA to determine op and voice status. See
-also `erc-format-nick-function'."
+prefix. Use CHANNEL-DATA to determine op and voice status."
+ (declare (obsolete "see option `erc-show-speaker-membership-status'" "30.1"))
(when user
(let ((nick (erc-server-user-nickname user)))
- (concat (propertize
- (erc-get-user-mode-prefix nick)
- 'font-lock-face 'erc-nick-prefix-face)
- nick))))
+ (if (not erc--speaker-status-prefix-wanted-p)
+ (prog1 nick
+ (setq erc--speaker-status-prefix-wanted-p 'erc-format-@nick))
+ (concat (propertize
+ (erc-get-channel-membership-prefix channel-data)
+ 'font-lock-face 'erc-nick-prefix-face)
+ nick)))))
(defun erc-format-my-nick ()
"Return the beginning of this user's message, correctly propertized."
@@ -4742,15 +6290,42 @@ also `erc-format-nick-function'."
(let* ((open "<")
(close "> ")
(nick (erc-current-nick))
- (mode (erc-get-user-mode-prefix nick)))
+ (mode (erc-get-channel-membership-prefix nick)))
+ (erc--ensure-spkr-prop nick)
(concat
(propertize open 'font-lock-face 'erc-default-face)
(propertize mode 'font-lock-face 'erc-my-nick-prefix-face)
- (propertize nick 'font-lock-face 'erc-my-nick-face)
+ (propertize nick 'erc--speaker nick 'font-lock-face 'erc-my-nick-face)
(propertize close 'font-lock-face 'erc-default-face)))
(let ((prefix "> "))
(propertize prefix 'font-lock-face 'erc-default-face))))
+(defun erc--format-speaker-input-message (message)
+ "Assemble outgoing MESSAGE entered at the prompt for insertion.
+Intend \"input\" to refer to interactive prompt input as well as
+the group of associated message-format templates from the
+\"speaker\" catalog. Format the speaker portion in a manner
+similar to that performed by `erc-format-my-nick', but use either
+`erc--message-speaker-input-chan-privmsg' or
+`erc--message-speaker-input-query-privmsg' as a formatting
+template, with MESSAGE being the actual message body. Return a
+copy with possibly shared text-property values."
+ (if-let ((erc-show-my-nick)
+ (nick (erc-current-nick))
+ (pfx (erc-get-channel-membership-prefix nick))
+ (erc-current-message-catalog erc--message-speaker-catalog)
+ (key (if (or erc-format-query-as-channel-p
+ (erc--target-channel-p erc--target))
+ 'input-chan-privmsg
+ 'input-query-privmsg)))
+ (progn
+ (cond (erc--msg-props (puthash 'erc--msg key erc--msg-props))
+ (erc--msg-prop-overrides (push (cons 'erc--msg key)
+ erc--msg-prop-overrides)))
+ (erc-format-message key ?p pfx ?n (erc--speakerize-nick nick)
+ ?m message))
+ (propertize (concat "> " message) 'font-lock-face 'erc-input-face)))
+
(defun erc-echo-notice-in-default-buffer (s parsed buffer _sender)
"Echo a private notice in the default buffer, namely the
target buffer specified by BUFFER, or there is no target buffer,
@@ -4921,9 +6496,7 @@ See also: `erc-echo-notice-in-user-buffers',
(erc-load-script f)))))
(defun erc-connection-established (proc parsed)
- "Run just after connection.
-
-Set user modes and run `erc-after-connect' hook."
+ "Set user mode and run `erc-after-connect' hook in server buffer."
(with-current-buffer (process-buffer proc)
(unless erc-server-connected ; only once per session
(let ((server (or erc-server-announced-name
@@ -4933,26 +6506,39 @@ Set user modes and run `erc-after-connect' hook."
(setq erc-server-connected t)
(setq erc--server-last-reconnect-count erc-server-reconnect-count
erc-server-reconnect-count 0)
+ (setq erc--server-reconnect-display-timer
+ (run-at-time erc-auto-reconnect-display-timeout nil
+ #'erc--server-last-reconnect-display-reset
+ (current-buffer)))
+ (add-hook 'erc-disconnected-hook
+ #'erc--server-last-reconnect-on-disconnect nil t)
(erc-update-mode-line)
(erc-set-initial-user-mode nick buffer)
(erc-server-setup-periodical-ping buffer)
- (run-hook-with-args 'erc-after-connect server nick))))
-
- (when erc-unhide-query-prompt
- (erc-with-all-buffers-of-server proc
- nil ; FIXME use `erc--target' after bug#48598
- (when (and (erc-default-target)
- (not (erc-channel-p (car erc-default-recipients))))
- (erc--unhide-prompt)))))
+ (when erc-unhide-query-prompt
+ (erc-with-all-buffers-of-server erc-server-process nil
+ (when (and erc--target (not (erc--target-channel-p erc--target)))
+ (erc--unhide-prompt))))
+ (run-hook-with-args 'erc-after-connect server nick)))))
(defun erc-set-initial-user-mode (nick buffer)
"If `erc-user-mode' is non-nil for NICK, set the user modes.
The server buffer is given by BUFFER."
(with-current-buffer buffer
(when erc-user-mode
- (let ((mode (if (functionp erc-user-mode)
- (funcall erc-user-mode)
- erc-user-mode)))
+ (let* ((mode (if (functionp erc-user-mode)
+ (funcall erc-user-mode)
+ erc-user-mode))
+ (groups (erc--parse-user-modes mode (erc--user-modes) t))
+ (superfluous (last groups 2))
+ (redundant-want (car superfluous))
+ (redundant-drop (cadr superfluous)))
+ (when redundant-want
+ (erc-display-message nil 'notice buffer 'user-mode-redundant-add
+ ?m (apply #'string redundant-want)))
+ (when redundant-drop
+ (erc-display-message nil 'notice buffer 'user-mode-redundant-drop
+ ?m (apply #'string redundant-drop)))
(when (stringp mode)
(erc-log (format "changing mode for %s to %s" nick mode))
(erc-server-send (format "MODE %s %s" nick mode)))))))
@@ -4978,7 +6564,9 @@ See also `erc-display-message'."
'ctcp-empty ?n nick)
(while queries
(let* ((type (upcase (car (split-string (car queries)))))
- (hook (intern-soft (concat "erc-ctcp-query-" type "-hook"))))
+ (hook (intern-soft (concat "erc-ctcp-query-" type "-hook")))
+ (erc--msg-prop-overrides `((erc--ctcp . ,(intern type))
+ ,@erc--msg-prop-overrides)))
(if (and hook (boundp hook))
(if (string-equal type "ACTION")
(run-hook-with-args-until-success
@@ -5012,10 +6600,31 @@ See also `erc-display-message'."
(let ((s (match-string 1 msg))
(buf (or (erc-get-buffer to proc)
(erc-get-buffer nick proc)
- (process-buffer proc))))
- (erc-display-message
- parsed 'action buf
- 'ACTION ?n nick ?u login ?h host ?a s))))
+ (process-buffer proc)))
+ (selfp (erc-current-nick-p nick)))
+ (if erc--use-language-catalog-for-ctcp-action-p
+ (progn
+ (erc--ensure-spkr-prop nick)
+ (setq nick (propertize nick 'erc--speaker nick))
+ (erc-display-message parsed (if selfp 'input 'action) buf
+ 'ACTION ?n nick ?u login ?h host ?a s))
+ (let* ((obj (and (erc--ctcp-response-p parsed) parsed))
+ (buffer (and obj (erc--ctcp-response-buffer obj)))
+ (stsmsg (and obj (erc--ctcp-response-statusmsg obj)))
+ (prefix (and obj (erc--ctcp-response-prefix obj)))
+ (dispnm (and obj (erc--ctcp-response-dispname obj)))
+ (erc-current-message-catalog erc--message-speaker-catalog))
+ (erc-display-message
+ parsed nil (or buffer buf)
+ (if selfp
+ (if stsmsg 'ctcp-action-statusmsg-input 'ctcp-action-input)
+ (if stsmsg 'ctcp-action-statusmsg 'ctcp-action))
+ ?s (or stsmsg to)
+ ?p (or (and (erc-channel-user-p prefix)
+ (erc-get-channel-membership-prefix prefix))
+ "")
+ ?n (erc--speakerize-nick nick dispnm)
+ ?m s))))))
(defvar erc-ctcp-query-CLIENTINFO-hook '(erc-ctcp-query-CLIENTINFO))
@@ -5089,8 +6698,14 @@ See also `erc-display-message'."
(defun erc-process-ctcp-reply (proc parsed nick login host msg)
"Process MSG as a CTCP reply."
(let* ((type (car (split-string msg)))
- (hook (intern (concat "erc-ctcp-reply-" type "-hook"))))
- (if (boundp hook)
+ (hook (intern-soft (concat "erc-ctcp-reply-" type "-hook")))
+ ;; Help `erc-display-message' by ensuring subsequent
+ ;; insertions retain the necessary props.
+ (cmd (erc--get-eq-comparable-cmd (erc-response.command parsed)))
+ (erc--msg-prop-overrides `((erc--ctcp . ,(and hook (intern type)))
+ (erc--cmd . ,cmd)
+ ,@erc--msg-prop-overrides)))
+ (if (and hook (boundp hook))
(run-hook-with-args-until-success
hook proc nick login host
(car (erc-response.command-args parsed)) msg)
@@ -5224,22 +6839,78 @@ See also `erc-channel-begin-receiving-names'."
(defun erc-parse-prefix ()
"Return an alist of valid prefix character types and their representations.
-Example: (operator) o => @, (voiced) v => +."
- (let ((str (or (erc-with-server-buffer (erc--get-isupport-entry 'PREFIX t))
- ;; provide a sane default
- "(qaohv)~&@%+"))
- types chars)
- (when (string-match "^(\\([^)]+\\))\\(.+\\)$" str)
- (setq types (match-string 1 str)
- chars (match-string 2 str))
- (let ((len (min (length types) (length chars)))
- (i 0)
- (alist nil))
- (while (< i len)
- (setq alist (cons (cons (elt types i) (elt chars i))
- alist))
- (setq i (1+ i)))
- alist))))
+For example, if the current ISUPPORT \"PREFIX\" is \"(ov)@+\",
+return an alist `equal' to ((?v . ?+) (?o . ?@)). For historical
+reasons, ensure the ordering of the returned alist is opposite
+that of the advertised parameter."
+ (let* ((str (or (erc--get-isupport-entry 'PREFIX t) "(qaohv)~&@%+"))
+ (i 0)
+ (j (string-search ")" str))
+ collected)
+ (when j
+ (while-let ((u (aref str (cl-incf i)))
+ ((not (= ?\) u))))
+ (push (cons u (aref str (cl-incf j))) collected)))
+ collected))
+
+(defvar-local erc--parsed-prefix nil
+ "Possibly stale `erc--parsed-prefix' struct instance for the server.
+Use the \"getter\" function of the same name to obtain the current
+value.")
+
+(defun erc--parsed-prefix ()
+ "Return possibly cached `erc--parsed-prefix' object for the server.
+Ensure the returned value describes the most recent \"PREFIX\"
+parameter advertised by the current server, with the original
+ordering intact. If no such parameter has yet arrived, return a
+stand-in from the fallback value \"(qaohv)~&@%+\"."
+ (erc--with-isupport-data PREFIX erc--parsed-prefix
+ (let ((alist (erc-parse-prefix)))
+ (make-erc--parsed-prefix
+ :key key
+ :letters (apply #'string (map-keys alist))
+ :statuses (apply #'string (map-values alist))
+ :alist (nreverse alist)))))
+
+(defun erc--get-prefix-flag (char &optional parsed-prefix from-prefix-p)
+ "Return numeric rank for CHAR or nil if unknown.
+For example, given letters \"qaohv\" return 1 for ?v, 2 for ?h,
+and 4 for ?o, etc. If given, expect PARSED-PREFIX to be a
+`erc--parsed-prefix' object. With FROM-PREFIX-P, expect CHAR to
+be a prefix instead."
+ (and-let* ((obj (or parsed-prefix (erc--parsed-prefix)))
+ (pos (erc--strpos char (if from-prefix-p
+ (erc--parsed-prefix-statuses obj)
+ (erc--parsed-prefix-letters obj)))))
+ (ash 1 pos)))
+
+(defun erc--init-cusr-fallback-status (voice halfop op admin owner)
+ "Return channel-membership based on traditional status semantics.
+Massage boolean switches VOICE, HALFOP, OP, ADMIN, and OWNER into
+an internal numeric value suitable for the `status' slot of a new
+`erc-channel-user' object."
+ (let ((pfx (erc--parsed-prefix)))
+ (+ (if voice (if pfx (or (erc--get-prefix-flag ?v pfx) 0) 1) 0)
+ (if halfop (if pfx (or (erc--get-prefix-flag ?h pfx) 0) 2) 0)
+ (if op (if pfx (or (erc--get-prefix-flag ?o pfx) 0) 4) 0)
+ (if admin (if pfx (or (erc--get-prefix-flag ?a pfx) 0) 8) 0)
+ (if owner (if pfx (or (erc--get-prefix-flag ?q pfx) 0) 16) 0))))
+
+(defun erc--compute-cusr-fallback-status (current v h o a q)
+ "Return current channel membership after toggling V H O A Q as requested.
+Assume `erc--parsed-prefix' is non-nil in the current buffer.
+Expect status switches V, H, O, A, Q, when non-nil, to be the
+symbol `on' or `off'. Return an internal numeric value suitable
+for the `status' slot of an `erc-channel-user' object."
+ (let (on off)
+ (when v (push (or (erc--get-prefix-flag ?v) 0) (if (eq v 'on) on off)))
+ (when h (push (or (erc--get-prefix-flag ?h) 0) (if (eq h 'on) on off)))
+ (when o (push (or (erc--get-prefix-flag ?o) 0) (if (eq o 'on) on off)))
+ (when a (push (or (erc--get-prefix-flag ?a) 0) (if (eq a 'on) on off)))
+ (when q (push (or (erc--get-prefix-flag ?q) 0) (if (eq q 'on) on off)))
+ (when on (setq current (apply #'logior current on)))
+ (when off (setq current (apply #'logand current (mapcar #'lognot off)))))
+ current)
(defcustom erc-channel-members-changed-hook nil
"This hook is called every time the variable `channel-members' changes.
@@ -5247,48 +6918,40 @@ The buffer where the change happened is current while this hook is called."
:group 'erc-hooks
:type 'hook)
-(defun erc-channel-receive-names (names-string)
- "This function is for internal use only.
+(defun erc--partition-prefixed-names (name)
+ "From NAME, return a list of (STATUS NICK LOGIN HOST).
+Expect NAME to be a prefixed name, like @bob."
+ (unless (string-empty-p name)
+ (let* ((status (erc--get-prefix-flag (aref name 0) nil 'from-prefix-p))
+ (nick (if status (substring name 1) name)))
+ (unless (string-empty-p nick)
+ (list status nick nil nil)))))
-Update `erc-channel-users' according to NAMES-STRING.
-NAMES-STRING is a string listing some of the names on the
-channel."
- (let* ((prefix (erc-parse-prefix))
- (voice-ch (cdr (assq ?v prefix)))
- (op-ch (cdr (assq ?o prefix)))
- (hop-ch (cdr (assq ?h prefix)))
- (adm-ch (cdr (assq ?a prefix)))
- (own-ch (cdr (assq ?q prefix)))
- (names (delete "" (split-string names-string)))
- name op voice halfop admin owner)
- (let ((erc-channel-members-changed-hook nil))
- (dolist (item names)
- (let ((updatep t)
- (ch (aref item 0)))
- (setq name item op 'off voice 'off halfop 'off admin 'off owner 'off)
- (if (rassq ch prefix)
- (if (= (length item) 1)
- (setq updatep nil)
- (setq name (substring item 1))
- (setf (pcase ch
- ((pred (eq voice-ch)) voice)
- ((pred (eq hop-ch)) halfop)
- ((pred (eq op-ch)) op)
- ((pred (eq adm-ch)) admin)
- ((pred (eq own-ch)) owner)
- (_ (message "Unknown prefix char `%S'" ch) voice))
- 'on)))
- (when updatep
+(defun erc-channel-receive-names (names-string)
+ "Update `erc-channel-members' from NAMES-STRING.
+Expect NAMES-STRING to resemble the trailing argument of a 353
+RPL_NAMREPLY. Call internal handlers for parsing individual
+names, whose expected composition may differ depending on enabled
+extensions."
+ (let ((names (delete "" (split-string names-string)))
+ (erc-channel-members-changed-hook nil))
+ (dolist (name names)
+ (when-let ((args (erc--partition-prefixed-names name)))
+ (pcase-let* ((`(,status ,nick ,login ,host) args)
+ (cmem (erc-get-channel-user nick)))
+ (progn
;; If we didn't issue the NAMES request (consider two clients
;; talking to an IRC proxy), `erc-channel-begin-receiving-names'
;; will not have been called, so we have to do it here.
(unless erc-channel-new-member-names
(erc-channel-begin-receiving-names))
- (puthash (erc-downcase name) t
- erc-channel-new-member-names)
- (erc-update-current-channel-member
- name name t voice halfop op admin owner)))))
- (run-hooks 'erc-channel-members-changed-hook)))
+ (puthash (erc-downcase nick) t erc-channel-new-member-names)
+ (if cmem
+ (erc--update-current-channel-member cmem status nil
+ nick host login)
+ (erc--create-current-channel-member nick status nil
+ nick host login)))))))
+ (run-hooks 'erc-channel-members-changed-hook))
(defun erc-update-user-nick (nick &optional new-nick
host login full-name info)
@@ -5340,111 +7003,114 @@ which USER is a member, and t is returned."
(run-hooks 'erc-channel-members-changed-hook))))))
changed))
-(defun erc-update-current-channel-member
- (nick new-nick &optional add voice halfop op admin owner host login full-name info
- update-message-time)
- "Update the stored user information for the user with nickname NICK.
-`erc-update-user' is called to handle changes to nickname,
-HOST, LOGIN, FULL-NAME, and INFO. If VOICE HALFOP OP ADMIN or OWNER
-are non-nil, they must be equal to either `on' or `off', in which
-case the status of the user in the current channel is changed accordingly.
-If UPDATE-MESSAGE-TIME is non-nil, the last-message-time of the user
- in the current channel is set to (current-time).
-
-If ADD is non-nil, the user will be added with the specified
-information if it is not already present in the user or channel
-lists.
-
-If, and only if, changes are made, or the user is added,
-`erc-channel-members-changed-hook' is run, and t is returned.
-
-See also: `erc-update-user' and `erc-update-channel-member'."
- (let* (changed user-changed
- (channel-data (erc-get-channel-user nick))
- (cuser (cdr channel-data))
- (user (if channel-data (car channel-data)
- (erc-get-server-user nick))))
- (if cuser
+(defun erc--create-current-channel-member
+ (nick status timep &optional new-nick host login full-name info)
+ "Add an `erc-channel-member' entry for NICK.
+Create a new `erc-server-users' entry if necessary, and ensure
+`erc-channel-members-changed-hook' runs exactly once, regardless.
+Pass STATUS to the `erc-channel-user' constructor. With TIMEP,
+assume NICK has just spoken, and initialize `last-message-time'.
+Pass NEW-NICK, HOST, LOGIN, FULL-NAME, and INFO to
+`erc-update-user' if a server user exists and otherwise to the
+`erc-server-user' constructor."
+ (cl-assert (null (erc-get-channel-member nick)))
+ (let* ((user-changed-p nil)
+ (down (erc-downcase nick))
+ (user (gethash down (erc-with-server-buffer erc-server-users))))
+ (if user
(progn
- (erc-log (format "update-member: user = %S, cuser = %S" user cuser))
- (when (and voice
- (not (eq (erc-channel-user-voice cuser) voice)))
- (setq changed t)
- (setf (erc-channel-user-voice cuser)
- (cond ((eq voice 'on) t)
- ((eq voice 'off) nil)
- (t voice))))
- (when (and halfop
- (not (eq (erc-channel-user-halfop cuser) halfop)))
- (setq changed t)
- (setf (erc-channel-user-halfop cuser)
- (cond ((eq halfop 'on) t)
- ((eq halfop 'off) nil)
- (t halfop))))
- (when (and op
- (not (eq (erc-channel-user-op cuser) op)))
- (setq changed t)
- (setf (erc-channel-user-op cuser)
- (cond ((eq op 'on) t)
- ((eq op 'off) nil)
- (t op))))
- (when (and admin
- (not (eq (erc-channel-user-admin cuser) admin)))
- (setq changed t)
- (setf (erc-channel-user-admin cuser)
- (cond ((eq admin 'on) t)
- ((eq admin 'off) nil)
- (t admin))))
- (when (and owner
- (not (eq (erc-channel-user-owner cuser) owner)))
- (setq changed t)
- (setf (erc-channel-user-owner cuser)
- (cond ((eq owner 'on) t)
- ((eq owner 'off) nil)
- (t owner))))
- (when update-message-time
- (setf (erc-channel-user-last-message-time cuser) (current-time)))
- (setq user-changed
- (erc-update-user user new-nick
- host login full-name info)))
- (when add
- (if (null user)
- (progn
- (setq user (make-erc-server-user
- :nickname nick
- :host host
- :full-name full-name
- :login login
- :info info
- :buffers (list (current-buffer))))
- (erc-add-server-user nick user))
- (setf (erc-server-user-buffers user)
- (cons (current-buffer)
- (erc-server-user-buffers user))))
- (setq cuser (make-erc-channel-user
- :voice (cond ((eq voice 'on) t)
- ((eq voice 'off) nil)
- (t voice))
- :halfop (cond ((eq halfop 'on) t)
- ((eq halfop 'off) nil)
- (t halfop))
- :op (cond ((eq op 'on) t)
- ((eq op 'off) nil)
- (t op))
- :admin (cond ((eq admin 'on) t)
- ((eq admin 'off) nil)
- (t admin))
- :owner (cond ((eq owner 'on) t)
- ((eq owner 'off) nil)
- (t owner))
- :last-message-time
- (if update-message-time (current-time))))
- (puthash (erc-downcase nick) (cons user cuser)
- erc-channel-users)
- (setq changed t)))
- (when (and changed (null user-changed))
+ (cl-pushnew (current-buffer) (erc-server-user-buffers user))
+ ;; Update *after* ^ so hook has chance to run.
+ (setf user-changed-p (erc-update-user user new-nick host login
+ full-name info)))
+ (erc-add-server-user nick
+ (setq user (make-erc-server-user
+ :nickname (or new-nick nick)
+ :host host
+ :full-name full-name
+ :login login
+ :info nil
+ :buffers (list (current-buffer))))))
+ (let ((cusr (erc-channel-user--make
+ :status (or status 0)
+ :last-message-time (and timep
+ (erc-compat--current-lisp-time)))))
+ (puthash down (cons user cusr) erc-channel-users))
+ ;; An existing `cusr' was changed or a new one was added, and
+ ;; `user' was not updated, though possibly just created (since
+ ;; `erc-update-user' runs this same hook in all a user's buffers).
+ (unless user-changed-p
+ (run-hooks 'erc-channel-members-changed-hook))
+ t))
+
+(defun erc--update-current-channel-member (cmem status timep &rest user-args)
+ "Update existing `erc-channel-member' entry.
+Set the `status' slot of the entry's `erc-channel-user' side to
+STATUS and, with TIMEP, update its `last-message-time'. When
+actual changes are made, run `erc-channel-members-changed-hook',
+and return non-nil."
+ (cl-assert cmem)
+ (let ((cusr (cdr cmem))
+ (user (car cmem))
+ cusr-changed-p user-changed-p)
+ (when (and status (/= status (erc-channel-user-status cusr)))
+ (setf (erc-channel-user-status cusr) status
+ cusr-changed-p t))
+ (when timep
+ (setf (erc-channel-user-last-message-time cusr)
+ (erc-compat--current-lisp-time)))
+ ;; Ensure `erc-channel-members-changed-hook' runs on change.
+ (cl-assert (memq (current-buffer) (erc-server-user-buffers user)))
+ (setq user-changed-p (apply #'erc-update-user user user-args))
+ ;; An existing `cusr' was changed or a new one was added, and
+ ;; `user' was not updated, though possibly just created (since
+ ;; `erc-update-user' runs this same hook in all a user's buffers).
+ (when (and cusr-changed-p (null user-changed-p))
(run-hooks 'erc-channel-members-changed-hook))
- (or changed user-changed add)))
+ (erc-log (format "update-member: user = %S, cusr = %S" user cusr))
+ (or cusr-changed-p user-changed-p)))
+
+(defun erc-update-current-channel-member
+ (nick new-nick &optional addp voice halfop op admin owner host login
+ full-name info update-message-time)
+ "Update or create entry for NICK in current `erc-channel-members' table.
+With ADDP, ensure an entry exists. When an entry does exist or
+when ADDP is non-nil and an `erc-server-users' entry already
+exists, call `erc-update-user' with NEW-NICK, HOST, LOGIN,
+FULL-NAME, and INFO. Expect any non-nil membership
+status switches among VOICE, HALFOP, OP, ADMIN, and OWNER to be
+the symbol `on' or `off' when needing to influence a new or
+existing `erc-channel-user' object's `status' slot. Likewise,
+when UPDATE-MESSAGE-TIME is non-nil, update or initialize the
+`last-message-time' slot to the current-time. If changes occur,
+including creation, run `erc-channel-members-changed-hook'.
+Return non-nil when meaningful changes, including creation, have
+occurred.
+
+Without ADDP, do nothing unless a `erc-channel-members' entry
+exists. When it doesn't, assume the sender is a non-joined
+entity, like the server itself or a historical speaker, or assume
+the prior buffer for the channel was killed without parting."
+(let* ((cmem (erc-get-channel-member nick))
+ (status (and (or voice halfop op admin owner)
+ (if cmem
+ (erc--compute-cusr-fallback-status
+ (erc-channel-user-status (cdr cmem))
+ voice halfop op admin owner)
+ (erc--init-cusr-fallback-status
+ (and voice (eq voice 'on))
+ (and halfop (eq halfop 'on))
+ (and op (eq op 'on))
+ (and admin (eq admin 'on))
+ (and owner (eq owner 'on)))))))
+ (if cmem
+ (erc--update-current-channel-member cmem status update-message-time
+ new-nick host login
+ full-name info)
+ (when addp
+ (erc--create-current-channel-member nick status update-message-time
+ new-nick host login
+ full-name info)))))
(defun erc-update-channel-member (channel nick new-nick
&optional add voice halfop op admin owner host login
@@ -5489,7 +7155,9 @@ TOPIC string to the current topic."
(defun erc-set-modes (tgt mode-string)
"Set the modes for the TGT provided as MODE-STRING."
- (let* ((modes (erc-parse-modes mode-string))
+ (declare (obsolete "see comment atop `erc--update-modes'" "30.1"))
+ (let* ((modes (with-suppressed-warnings ((obsolete erc-parse-modes))
+ (erc-parse-modes mode-string)))
(add-modes (nth 0 modes))
;; list of triples: (mode-char 'on/'off argument)
(arg-modes (nth 2 modes)))
@@ -5535,6 +7203,7 @@ for modes without parameters to add and remove respectively. The
arg-modes is a list of triples of the form:
(MODE-CHAR ON/OFF ARGUMENT)."
+ (declare (obsolete "see comment atop `erc--update-modes'" "30.1"))
(if (string-match "^\\s-*\\(\\S-+\\)\\(\\s-.*$\\|$\\)" mode-string)
(let ((chars (mapcar #'char-to-string (match-string 1 mode-string)))
;; arguments in channel modes
@@ -5579,8 +7248,10 @@ arg-modes is a list of triples of the form:
"Update the mode information for TGT, provided as MODE-STRING.
Optional arguments: NICK, HOST and LOGIN - the attributes of the
person who changed the modes."
+ (declare (obsolete "see comment atop `erc--update-modes'" "30.1"))
;; FIXME: neither of nick, host, and login are used!
- (let* ((modes (erc-parse-modes mode-string))
+ (let* ((modes (with-suppressed-warnings ((obsolete erc-parse-modes))
+ (erc-parse-modes mode-string)))
(add-modes (nth 0 modes))
(remove-modes (nth 1 modes))
;; list of triples: (mode-char 'on/'off argument)
@@ -5629,9 +7300,255 @@ person who changed the modes."
;; nick modes - ignored at this point
(t nil))))
+(defvar-local erc--channel-modes nil
+ "When non-nil, a hash table of current channel modes.
+Keys are characters. Values are either a string, for types A-C,
+or t, for type D.")
+
+(defvar-local erc--channel-mode-types nil
+ "Possibly stale `erc--channel-mode-types' instance for the server.
+Use the getter of the same name to retrieve the current value.")
+
+(defvar-local erc--mode-line-mode-string nil
+ "Computed mode-line or header-line component for user/channel modes.")
+
+(defvar erc--mode-line-chanmodes-arg-len 10
+ "Max length at which to truncate channel-mode args in header line.")
+
+(defun erc--channel-mode-types ()
+ "Return variable `erc--channel-mode-types', possibly initializing it."
+ (erc--with-isupport-data CHANMODES erc--channel-mode-types
+ (let ((types (or key '(nil "Kk" "Ll" nil)))
+ (ct (make-char-table 'erc--channel-mode-types))
+ (type ?a))
+ (dolist (cs types)
+ (erc--doarray (c cs)
+ (aset ct c type))
+ (cl-incf type))
+ (make-erc--channel-mode-types :key key
+ :fallbackp (null key)
+ :table ct))))
+
+(defun erc--process-channel-modes (string args &optional status-letters)
+ "Parse channel \"MODE\" changes and call unary letter handlers.
+Update `erc-channel-modes' and `erc--channel-modes'. With
+STATUS-LETTERS, also update channel membership prefixes. Expect
+STRING to be the second argument from an incoming \"MODE\"
+command and ARGS to be the remaining arguments, which should
+complement relevant letters in STRING."
+ (cl-assert (erc--target-channel-p erc--target))
+ (let* ((obj (erc--channel-mode-types))
+ (table (erc--channel-mode-types-table obj))
+ (fallbackp (erc--channel-mode-types-fallbackp obj))
+ (+p t))
+ (erc--doarray (c string)
+ (cond ((= ?+ c) (setq +p t))
+ ((= ?- c) (setq +p nil))
+ ((and status-letters (string-search (string c) status-letters))
+ (erc--cusr-change-status (pop args) c +p))
+ ((and-let* ((group (or (aref table c) (and fallbackp ?d))))
+ (erc--handle-channel-mode group c +p
+ (and (/= group ?d)
+ (or (/= group ?c) +p)
+ (pop args)))
+ t))
+ ((not fallbackp)
+ (erc-display-message nil '(notice error) (erc-server-buffer)
+ (format "Unknown channel mode: %S" c)))))
+ (setq erc-channel-modes (sort erc-channel-modes #'string<))
+ (setq erc--mode-line-mode-string
+ (concat "+" (erc--channel-modes erc--mode-line-chanmodes-arg-len)))
+ (erc-update-mode-line (current-buffer))))
+
+(defvar-local erc--user-modes nil
+ "Sorted list of current user \"MODE\" letters.
+Analogous to `erc-channel-modes' but chars rather than strings.")
+
+(defun erc--user-modes (&optional as-type)
+ "Return user \"MODE\" letters in a form described by AS-TYPE.
+When AS-TYPE is the symbol `strings' (plural), return a list of
+strings. When it's `string' (singular), return the same list
+concatenated into a single string. When AS-TYPE is nil, return a
+list of chars."
+ (let ((modes (or erc--user-modes (erc-with-server-buffer erc--user-modes))))
+ (pcase as-type
+ ('strings (mapcar #'char-to-string modes))
+ ('string (apply #'string modes))
+ (_ modes))))
+
+(defun erc--channel-modes (&optional as-type sep)
+ "Return channel \"MODE\" settings in a form described by AS-TYPE.
+When AS-TYPE is the symbol `strings' (plural), return letter keys
+as a list of sorted string. When it's `string' (singular),
+return keys as a single string. When it's a number N, return a
+single string consisting of the concatenated and sorted keys
+followed by a space and then their corresponding args, each
+truncated to N chars max. ERC joins these args together with
+SEP, which defaults to a single space. Otherwise, return a
+sorted alist of letter and arg pairs. In all cases that include
+values, respect `erc-show-channel-key-p' and optionally omit the
+secret key associated with the letter k."
+ (and-let* ((modes erc--channel-modes)
+ (tobj (erc--channel-mode-types))
+ (types (erc--channel-mode-types-table tobj)))
+ (let (out)
+ (maphash (lambda (k v)
+ (unless (eq ?a (aref types k))
+ (push (cons k
+ (and (not (eq t v))
+ (not (and (eq k ?k)
+ (not (bound-and-true-p
+ erc-show-channel-key-p))))
+ v))
+ out)))
+ modes)
+ (setq out (cl-sort out #'< :key #'car))
+ (pcase as-type
+ ('strings (mapcar (lambda (o) (char-to-string (car o))) out))
+ ('string (apply #'string (mapcar #'car out)))
+ ((and (pred natnump) c)
+ (let (keys vals)
+ (pcase-dolist (`(,k . ,v) out)
+ (when v
+ (push (if (> (length v) c)
+ (with-memoization
+ (gethash (list c k v)
+ (erc--channel-mode-types-shortargs tobj))
+ (truncate-string-to-width v c 0 nil t))
+ v)
+ vals))
+ (push k keys))
+ (concat (apply #'string (nreverse keys)) (and vals " ")
+ (string-join (nreverse vals) (or sep " ")))))
+ (_ out)))))
+
+(defun erc--parse-user-modes (string &optional current extrap)
+ "Return lists of chars from STRING to add to and drop from CURRENT.
+Expect STRING to be a so-called \"modestring\", the second
+parameter of a \"MODE\" command, here containing only valid
+user-mode letters. Expect CURRENT to be a list of chars
+resembling those found in `erc--user-modes'. With EXTRAP, return
+two additional lists of chars: those that would be added were
+they not already present in CURRENT and those that would be
+dropped were they not already absent."
+ (let ((addp t)
+ ;;
+ redundant-add redundant-drop adding dropping)
+ (erc--doarray (c string)
+ (pcase c
+ (?+ (setq addp t))
+ (?- (setq addp nil))
+ (_ (push c (let ((hasp (and current (memq c current))))
+ (if addp
+ (if hasp redundant-add adding)
+ (if hasp dropping redundant-drop)))))))
+ (if extrap
+ (list (nreverse adding) (nreverse dropping)
+ (nreverse redundant-add) (nreverse redundant-drop))
+ (list (nreverse adding) (nreverse dropping)))))
+
+(defun erc--update-user-modes (string)
+ "Update `erc--user-modes' from \"MODE\" STRING.
+Return its value, a list of characters sorted by character code."
+ (prog1
+ (setq erc--user-modes
+ (pcase-let ((`(,adding ,dropping)
+ (erc--parse-user-modes string erc--user-modes)))
+ (sort (seq-difference (nconc erc--user-modes adding) dropping)
+ #'<)))
+ (setq erc--mode-line-mode-string
+ (concat "+" (erc--user-modes 'string)))))
+
+(defun erc--update-channel-modes (string &rest args)
+ "Update `erc-channel-modes' and call individual mode handlers.
+Also update membership prefixes, as needed. Expect STRING to be
+a \"modestring\" and ARGS to match mode-specific parameters."
+ (let ((status-letters (or (erc-with-server-buffer
+ (erc--parsed-prefix-letters
+ (erc--parsed-prefix)))
+ "qaovhbQAOVHB")))
+ (erc--process-channel-modes string args status-letters)))
+
+;; XXX this comment is referenced elsewhere (grep before deleting).
+;;
+;; The function `erc-update-modes' was deprecated in ERC 5.6 with no
+;; immediate public replacement. Third parties needing such a thing
+;; are encouraged to write to emacs-erc@gnu.org with ideas for a
+;; mode-handler API, possibly one incorporating letter-specific
+;; handlers, like `erc--handle-channel-mode' (below), which only
+;; handles mode types A-C.
+(defun erc--update-modes (raw-args)
+ "Handle user or channel \"MODE\" update from server.
+Expect RAW-ARGS be a list consisting of a \"modestring\" followed
+by mode-specific arguments."
+ (if (and erc--target (erc--target-channel-p erc--target))
+ (apply #'erc--update-channel-modes raw-args)
+ (erc--update-user-modes (car raw-args))))
+
+(defun erc--init-channel-modes (channel raw-args)
+ "Set CHANNEL modes from RAW-ARGS.
+Expect RAW-ARGS to be a \"modestring\" without any status-prefix
+chars, followed by applicable arguments."
+ (erc-with-buffer (channel)
+ (erc--process-channel-modes (car raw-args) (cdr raw-args))))
+
+(cl-defgeneric erc--handle-channel-mode (type letter state arg)
+ "Handle a STATE change for mode LETTER of TYPE with ARG.
+Expect to be called in the affected target buffer. Expect TYPE
+to be a character, like ?a, representing an advertised
+\"CHANMODES\" group. Expect LETTER to also be a character, and
+expect STATE to be a boolean and ARGUMENT either a string or nil."
+ (erc-log (format "Channel-mode %c (type %s, arg %S) %s"
+ letter type arg (if state 'enabled 'disabled))))
+
+(cl-defmethod erc--handle-channel-mode :before (type c state arg)
+ "Record STATE change for mode letter C.
+When STATE is non-nil, add or update C's mapping in
+`erc--channel-modes', associating it with ARG if C takes a
+parameter and t otherwise. When STATE is nil, forget the
+mapping. For type A, add up update a permanent mapping for C,
+associating it with an integer indicating a running total of
+STATE changes since joining the channel. In most cases, this
+won't match the number known to the server."
+ (unless erc--channel-modes
+ (cl-assert (erc--target-channel-p erc--target))
+ (setq erc--channel-modes (make-hash-table)))
+ (if (= type ?a)
+ (cl-callf (lambda (s) (+ (or s 0) (if state +1 -1)))
+ (gethash c erc--channel-modes))
+ (if state
+ (puthash c (or arg t) erc--channel-modes)
+ (remhash c erc--channel-modes))))
+
+(cl-defmethod erc--handle-channel-mode :before ((_ (eql ?d)) c state _)
+ "Update `erc-channel-modes' for any character C of nullary type D.
+Remember when STATE is non-nil and forget otherwise."
+ (setq erc-channel-modes
+ (if state
+ (cl-pushnew (char-to-string c) erc-channel-modes :test #'equal)
+ (delete (char-to-string c) erc-channel-modes))))
+
+;; We could specialize on type C, but that may be too brittle.
+(cl-defmethod erc--handle-channel-mode (_ (_ (eql ?l)) state arg)
+ "Update channel user limit, remembering ARG when STATE is non-nil."
+ (erc-update-channel-limit (erc--target-string erc--target)
+ (if state 'on 'off)
+ arg))
+
+;; We could specialize on type B, but that may be too brittle.
+(cl-defmethod erc--handle-channel-mode (_ (_ (eql ?k)) state arg)
+ "Update channel key, remembering ARG when state is non-nil."
+ ;; Mimic old parsing behavior in which an ARG of "*" was discarded
+ ;; even though `erc-update-channel-limit' checks STATE first.
+ (erc-update-channel-key (erc--target-string erc--target)
+ (if state 'on 'off)
+ (if (equal arg "*") nil arg)))
+
(defun erc-update-channel-limit (channel onoff n)
- ;; FIXME: what does ONOFF actually do? -- Lawrence 2004-01-08
- "Update CHANNEL's user limit to N."
+ "Update CHANNEL's user limit to N.
+Expect ONOFF to be `on' when the mode is being enabled and `off'
+otherwise. And because this mode is of \"type C\", expect N to
+be non-nil only when enabling."
(if (or (not (eq onoff 'on))
(and (stringp n) (string-match "^[0-9]+$" n)))
(erc-with-buffer
@@ -5703,20 +7620,28 @@ OBJECT is modified without being copied first.
You can redefine or `defadvice' this function in order to add
EmacsSpeak support."
- (put-text-property start end property value object))
+ (if erc--merge-text-properties-p
+ (erc--merge-prop start end property value object)
+ (put-text-property start end property value object)))
-(defun erc-list (thing)
- "Return THING if THING is a list, or a list with THING as its element."
- (if (listp thing)
- thing
- (list thing)))
+(defalias 'erc-list 'ensure-list)
+
+(defconst erc--parse-user-regexp-pedantic
+ (rx bot (? (? (group (+ (not (any "!@\r\n"))))) "!")
+ (? (? (group (+ nonl))) "@")
+ (? (group (+ nonl))) eot))
+
+(defconst erc--parse-user-regexp-legacy
+ "^\\([^!\n]*\\)!\\([^@\n]*\\)@\\(.*\\)$")
+
+(defvar erc--parse-user-regexp erc--parse-user-regexp-legacy)
(defun erc-parse-user (string)
"Parse STRING as a user specification (nick!login@host).
Return a list of the three separate tokens."
(cond
- ((string-match "^\\([^!\n]*\\)!\\([^@\n]*\\)@\\(.*\\)$" string)
+ ((string-match erc--parse-user-regexp string)
(list (match-string 1 string)
(match-string 2 string)
(match-string 3 string)))
@@ -5728,6 +7653,26 @@ Return a list of the three separate tokens."
(t
(list string "" ""))))
+(defun erc--parse-nuh (string)
+ "Match STRING against `erc--parse-user-regexp-pedantic'.
+Return nil or matching groups representing nick, login, and host,
+any of which may be nil. Expect STRING not to contain leading
+prefix chars. Return an empty nick component to indicate further
+processing is required based on context. Interpret a lone token
+lacking delimiters or one with only a leading \"!\" as a host.
+
+See associated unit test for precise behavior."
+ (when (string-match erc--parse-user-regexp-pedantic string)
+ (list (match-string 1 string)
+ (match-string 2 string)
+ (match-string 3 string))))
+
+(defun erc--shuffle-nuh-nickward (nick login host)
+ "Interpret results of `erc--parse-nuh', promoting loners to nicks."
+ (cond (nick (cl-assert (null login)) (list nick login host))
+ ((and (null login) host) (list host nil nil))
+ ((and login (null host)) (list login nil nil))))
+
(defun erc-extract-nick (string)
"Return the nick corresponding to a user specification STRING.
@@ -5771,76 +7716,200 @@ If that function has never been called, the value is 0.")
"Minimum time, in seconds, before sending new lines via IRC.
If the value is a number, `erc-send-current-line' signals an error
if its previous invocation was fewer than this many seconds ago.
-This is useful so that if you accidentally enter large amounts of text
-into the ERC buffer, that text is not sent to the IRC server.
-
If the value is nil, `erc-send-current-line' always considers any
-submitted line to be intentional."
+submitted line to be intentional.
+
+This option mainly prevents text accidentally entered into Emacs
+from being sent to the server. Offending sources include
+terminal multiplexers, desktop-automation scripts, and anything
+capable of rapidly submitting successive lines of prompt input.
+For example, if you could somehow manage to type \"one \\`RET'
+two \\`RET' three \\`RET'\" at the prompt in less than
+`erc-accidental-paste-threshold-seconds', ERC would send \"one\"
+to the server, leave \"two\" at the prompt, and insert \"three\"
+into an \"overflow\" buffer. See `erc-inhibit-multiline-input'
+and `erc-warn-about-blank-lines' for suppression involving input
+yanked from the clipboard or the kill ring, which is a related
+but separate concern.
+
+Users of terminal multiplexers, in particular, should look into
+support for \"bracketed pasting\", provided on the Emacs side by
+libraries like `xterm' (and usually enabled by default). When
+everything's working smoothly, Emacs transparently arranges for
+pasted text to appear on the kill ring, regardless of any
+read-only warnings you may encounter. And when point is in the
+prompt area, ERC automatically yanks that text for previewing but
+holds off on submitting it, for obvious reasons."
:group 'erc
:version "26.1"
:type '(choice number (other :tag "disabled" nil)))
(defvar erc--input-line-delim-regexp (rx (| (: (? ?\r) ?\n) ?\r)))
-(defun erc--blank-in-multiline-input-p (lines)
- "Detect whether LINES contains a blank line.
-When `erc-send-whitespace-lines' is in effect, return nil if
-LINES is multiline or the first line is non-empty. When
-`erc-send-whitespace-lines' is nil, return non-nil when any line
-is empty or consists of one or more spaces, tabs, or form-feeds."
- (catch 'return
- (let ((multilinep (cdr lines)))
- (dolist (line lines)
- (when (if erc-send-whitespace-lines
- (and (string-empty-p line) (not multilinep))
- (string-match (rx bot (* (in " \t\f")) eot) line))
- (throw 'return t))))))
+(defvar erc-command-regexp "^/\\([A-Za-z']+\\)\\(\\s-+.*\\|\\s-*\\)$"
+ "Regular expression used for matching commands in ERC.")
(defun erc--check-prompt-input-for-excess-lines (_ lines)
"Return non-nil when trying to send too many LINES."
(when erc-inhibit-multiline-input
- ;; Assume `erc--discard-trailing-multiline-nulls' is set to run
- (let ((reversed (seq-drop-while #'string-empty-p (reverse lines)))
- (max (if (eq erc-inhibit-multiline-input t)
+ (let ((max (if (eq erc-inhibit-multiline-input t)
2
erc-inhibit-multiline-input))
(seen 0)
- msg)
- (while (and (pop reversed) (< (cl-incf seen) max)))
+ last msg)
+ (while (and lines (setq last (pop lines)) (< (cl-incf seen) max)))
(when (= seen max)
- (setq msg (format "(exceeded by %d)" (1+ (length reversed))))
+ (push last lines)
+ (setq msg
+ (format "-- exceeded by %d (%d chars)"
+ (length lines)
+ (apply #'+ (mapcar #'length lines))))
(unless (and erc-ask-about-multiline-input
(y-or-n-p (concat "Send input " msg "?")))
(concat "Too many lines " msg))))))
-(defun erc--check-prompt-input-for-multiline-blanks (_ lines)
- "Return non-nil when multiline prompt input has blank LINES."
- (when (erc--blank-in-multiline-input-p lines)
+(defun erc--check-prompt-input-for-something (string _)
+ (when (string-empty-p string)
(if erc-warn-about-blank-lines
"Blank line - ignoring..."
'invalid)))
+(defun erc--count-blank-lines (lines)
+ "Report on the number of whitespace-only and empty LINES.
+Return a list of (BLANKS TO-PAD TO-STRIP). Expect caller to know
+that BLANKS includes non-empty whitespace-only lines and that no
+padding or stripping has yet occurred."
+ (let ((real 0) (total 0) (pad 0) (strip 0))
+ (dolist (line lines)
+ (if (string-match (rx bot (* (in " \t\f")) eot) line)
+ (progn
+ (cl-incf total)
+ (if (zerop (match-end 0))
+ (cl-incf strip)
+ (cl-incf pad strip)
+ (setq strip 0)))
+ (cl-incf real)
+ (unless (zerop strip)
+ (cl-incf pad strip)
+ (setq strip 0))))
+ (when (and (zerop real) (not (zerop total)) (= total (+ pad strip)))
+ (cl-incf strip (1- pad))
+ (setq pad 1))
+ (list total pad strip)))
+
+(defvar erc--check-prompt-explanation nil
+ "List of strings to print if no validator returns non-nil.")
+
+(defun erc--check-prompt-input-for-multiline-blanks (_ lines)
+ "Return non-nil when multiline prompt input has blank LINES.
+Consider newlines to be intervening delimiters, meaning the empty
+\"logical\" line between a trailing newline and `eob' constitutes
+a separate message."
+ (pcase-let ((`(,total ,pad ,strip)(erc--count-blank-lines lines)))
+ (cond ((zerop total) nil)
+ ((and erc-warn-about-blank-lines erc-send-whitespace-lines)
+ (let (msg args)
+ (unless (zerop strip)
+ (push "stripping (%d)" msg)
+ (push strip args))
+ (unless (zerop pad)
+ (when msg
+ (push "and" msg))
+ (push "padding (%d)" msg)
+ (push pad args))
+ (when msg
+ (push "blank" msg)
+ (push (if (> (apply #'+ args) 1) "lines" "line") msg))
+ (when msg
+ (setf msg (nreverse msg)
+ (car msg) (capitalize (car msg))))
+ (when msg
+ (push (apply #'format (string-join msg " ") (nreverse args))
+ erc--check-prompt-explanation)
+ nil)))
+ (erc-warn-about-blank-lines
+ (concat (if (= total 1)
+ (if (zerop strip) "Blank" "Trailing")
+ (if (= total strip)
+ (format "%d trailing" strip)
+ (format "%d blank" total)))
+ (and (> total 1) (/= total strip) (not (zerop strip))
+ (format " (%d trailing)" strip))
+ (if (= total 1) " line" " lines")
+ " detected (see `erc-send-whitespace-lines')"))
+ (erc-send-whitespace-lines nil)
+ (t 'invalid))))
+
(defun erc--check-prompt-input-for-point-in-bounds (_ _)
"Return non-nil when point is before prompt."
(when (< (point) (erc-beg-of-input-line))
"Point is not in the input area"))
+;; Originally, `erc-send-current-line' inhibited sends whenever a
+;; server buffer was missing. In 2007, this was narrowed to
+;; occurrences involving process-dependent commands. However, the
+;; accompanying error message, which was identical to that emitted by
+;; `erc-server-send', "ERC: No process running", was always inaccurate
+;; because a server buffer can be alive and its process dead.
(defun erc--check-prompt-input-for-running-process (string _)
- "Return non-nil unless in an active ERC server buffer."
- (unless (or (erc-server-buffer-live-p)
- (erc-command-no-process-p string))
- "ERC: No process running"))
+ "Return non-nil if STRING is a slash command missing a process.
+Also do so when the server buffer has been killed."
+ ;; Even if the server buffer has been killed, the user should still
+ ;; be able to /reconnect and recall previous commands.
+ (and (not (erc-command-no-process-p string))
+ (or (and (not (erc-server-buffer-live-p)) "Server buffer missing")
+ (and (not (erc-server-process-alive)) "Process not running"))))
+
+(defun erc--check-prompt-input-for-multiline-command (line lines)
+ "Return non-nil when non-blank lines follow a command line."
+ (when (and (cdr lines)
+ (string-match erc-command-regexp line)
+ (seq-drop-while #'string-empty-p (reverse (cdr lines))))
+ "Excess input after command line"))
(defvar erc--check-prompt-input-functions
'(erc--check-prompt-input-for-point-in-bounds
+ erc--check-prompt-input-for-something
+ erc--check-prompt-input-for-multiline-command
erc--check-prompt-input-for-multiline-blanks
erc--check-prompt-input-for-running-process
erc--check-prompt-input-for-excess-lines)
"Validators for user input typed at prompt.
-Called with latest input string submitted by user and the list of
-lines produced by splitting it. If any member function returns
-non-nil, processing is abandoned and input is left untouched.
-When the returned value is a string, pass it to `erc-error'.")
+Called with two arguments: the current input submitted by the
+user, as a string, along with the same input as a list of
+strings. If any member function returns non-nil, ERC abandons
+processing and leaves pending input untouched in the prompt area.
+When the returned value is a string, ERC passes it to
+`user-error'. Any other non-nil value tells ERC to abort
+silently. If all members return nil, and the variable
+`erc--check-prompt-explanation' is a nonempty list of strings,
+ERC prints them as a single message joined by newlines.")
+
+(defun erc--run-input-validation-checks (state)
+ "Run input checkers from STATE, an `erc--input-split' object."
+ (let* ((erc--check-prompt-explanation nil)
+ (msg (run-hook-with-args-until-success
+ 'erc--check-prompt-input-functions
+ (erc--input-split-string state)
+ (erc--input-split-lines state))))
+ (cond ((stringp msg) (user-error msg))
+ (msg (push msg (erc--input-split-abortp state)))
+ (erc--check-prompt-explanation
+ (message "%s" (string-join (nreverse erc--check-prompt-explanation)
+ "\n"))))))
+
+(defun erc--inhibit-slash-cmd-insertion (state)
+ "Don't insert STATE object's message if it's a \"slash\" command."
+ (when (erc--input-split-cmdp state)
+ (setf (erc--input-split-insertp state) nil)))
+
+(defun erc--make-input-split (string)
+ (make-erc--input-split
+ :string string
+ :insertp erc-insert-this
+ :sendp erc-send-this
+ :lines (split-string string erc--input-line-delim-regexp)
+ :cmdp (string-match erc-command-regexp string)))
(defun erc-send-current-line ()
"Parse current line and send it to IRC."
@@ -5855,32 +7924,25 @@ When the returned value is a string, pass it to `erc-error'.")
(eolp))
(expand-abbrev))
(widen)
- (if-let* ((str (erc-user-input))
- (msg (run-hook-with-args-until-success
- 'erc--check-prompt-input-functions str
- (split-string str erc--input-line-delim-regexp))))
- (when (stringp msg)
- (erc-error msg))
- (let ((inhibit-read-only t)
- (old-buf (current-buffer)))
+ (let* ((str (erc-user-input))
+ (state (erc--make-input-split str)))
+ (run-hook-with-args 'erc--input-review-functions state)
+ (when-let (((not (erc--input-split-abortp state)))
+ (inhibit-read-only t)
+ (erc--current-line-input-split state)
+ (old-buf (current-buffer)))
(progn ; unprogn this during next major surgery
(erc-set-active-buffer (current-buffer))
;; Kill the input and the prompt
- (delete-region (erc-beg-of-input-line)
- (erc-end-of-input-line))
+ (delete-region erc-input-marker (erc-end-of-input-line))
(unwind-protect
- (erc-send-input str 'skip-ws-chk)
+ (erc--send-input-lines (erc--run-send-hooks state))
;; Fix the buffer if the command didn't kill it
(when (buffer-live-p old-buf)
(with-current-buffer old-buf
(save-restriction
(widen)
- (goto-char (point-max))
- (when (processp erc-server-process)
- (set-marker (process-mark erc-server-process) (point)))
- (set-marker erc-insert-marker (point))
(let ((buffer-modified (buffer-modified-p)))
- (erc-display-prompt)
(set-buffer-modified-p buffer-modified))))))
;; Only when last hook has been run...
@@ -5896,19 +7958,81 @@ When the returned value is a string, pass it to `erc-error'.")
erc-input-marker
(erc-end-of-input-line)))
-(defvar erc-command-regexp "^/\\([A-Za-z']+\\)\\(\\s-+.*\\|\\s-*\\)$"
- "Regular expression used for matching commands in ERC.")
-
(defun erc--discard-trailing-multiline-nulls (state)
- "Ensure last line of STATE's string is non-null.
-But only when `erc-send-whitespace-lines' is non-nil. STATE is
-an `erc--input-split' object."
- (when (and erc-send-whitespace-lines (erc--input-split-lines state))
+ "Remove trailing empty lines from STATE, an `erc--input-split' object.
+When all lines are empty, remove all but the first."
+ (when (erc--input-split-lines state)
(let ((reversed (nreverse (erc--input-split-lines state))))
- (when (string-empty-p (car reversed))
- (pop reversed)
- (setf (erc--input-split-cmdp state) nil))
- (nreverse (seq-drop-while #'string-empty-p reversed)))))
+ (while (and (cdr reversed) (string-empty-p (car reversed)))
+ (setq reversed (cdr reversed)))
+ (setf (erc--input-split-lines state) (nreverse reversed)))))
+
+(defun erc--split-lines (state)
+ "Partition non-command input into lines of protocol-compliant length."
+ ;; Prior to ERC 5.6, line splitting used to be predicated on
+ ;; `erc-flood-protect' being non-nil.
+ (unless (or (zerop erc-split-line-length) (erc--input-split-cmdp state))
+ (setf (erc--input-split-lines state)
+ (mapcan #'erc--split-line (erc--input-split-lines state)))))
+
+(defun erc--run-send-hooks (lines-obj)
+ "Run send-related hooks that operate on the entire prompt input.
+Sequester some of the back and forth involved in honoring old
+interfaces, such as the reconstituting and re-splitting of
+multiline input. Optionally readjust lines to protocol length
+limits and pad empty ones, knowing full well that additional
+processing may still corrupt messages before they reach the send
+queue. Expect LINES-OBJ to be an `erc--input-split' object."
+ (progn ; FIXME remove `progn' after code review.
+ (with-suppressed-warnings ((lexical str) (obsolete erc-send-this))
+ (defvar str) ; see note in string `erc-send-input'.
+ (let* ((str (string-join (erc--input-split-lines lines-obj) "\n"))
+ (erc-send-this (erc--input-split-sendp lines-obj))
+ (erc-insert-this (erc--input-split-insertp lines-obj))
+ (state (progn
+ ;; This may change `str' and `erc-*-this'.
+ (run-hook-with-args 'erc-send-pre-hook str)
+ (make-erc-input
+ :string str
+ :insertp erc-insert-this
+ :sendp erc-send-this
+ :substxt (erc--input-split-substxt lines-obj)
+ :refoldp (erc--input-split-refoldp lines-obj)))))
+ (run-hook-with-args 'erc-pre-send-functions state)
+ (setf (erc--input-split-sendp lines-obj) (erc-input-sendp state)
+ (erc--input-split-insertp lines-obj) (erc-input-insertp state)
+ (erc--input-split-substxt lines-obj) (erc-input-substxt state)
+ (erc--input-split-refoldp lines-obj) (erc-input-refoldp state)
+ ;; See note in test of same name re trailing newlines.
+ (erc--input-split-lines lines-obj)
+ (let ((lines (split-string (erc-input-string state)
+ erc--input-line-delim-regexp)))
+ (if erc--allow-empty-outgoing-lines-p
+ lines
+ (cl-nsubst " " "" lines :test #'equal))))
+ (when (erc--input-split-refoldp lines-obj)
+ (erc--split-lines lines-obj)))))
+ (when (and (erc--input-split-cmdp lines-obj)
+ (cdr (erc--input-split-lines lines-obj)))
+ (user-error "Multiline command detected" ))
+ lines-obj)
+
+(defun erc--send-input-lines (lines-obj)
+ "Send lines in `erc--input-split-lines' object LINES-OBJ."
+ (when (erc--input-split-sendp lines-obj)
+ (let ((insertp (erc--input-split-insertp lines-obj))
+ (substxt (erc--input-split-substxt lines-obj)))
+ (when (and insertp substxt)
+ (setq insertp nil)
+ (if (functionp substxt)
+ (apply substxt (erc--input-split-lines lines-obj))
+ (erc-display-msg substxt)))
+ (dolist (line (erc--input-split-lines lines-obj))
+ (when insertp
+ (erc-display-msg line))
+ (erc-process-input-line (concat line "\n")
+ (null erc-flood-protect)
+ (not (erc--input-split-cmdp lines-obj)))))))
(defun erc-send-input (input &optional skip-ws-chk)
"Treat INPUT as typed in by the user.
@@ -5940,23 +8064,22 @@ Return non-nil only if we actually send anything."
:insertp erc-insert-this
:sendp erc-send-this))
(run-hook-with-args 'erc-pre-send-functions state)
- (setq state (make-erc--input-split
- :string (erc-input-string state)
- :insertp (erc-input-insertp state)
- :sendp (erc-input-sendp state)
- :lines (split-string (erc-input-string state)
- erc--input-line-delim-regexp)
- :cmdp (string-match erc-command-regexp
- (erc-input-string state))))
- (run-hook-with-args 'erc--pre-send-split-functions state)
(when (and (erc-input-sendp state)
erc-send-this)
- (let ((lines (erc--input-split-lines state)))
- (if (and (erc--input-split-cmdp state) (not (cdr lines)))
- (erc-process-input-line (concat (car lines) "\n") t nil)
+ (if-let* ((first (split-string (erc-input-string state)
+ erc--input-line-delim-regexp))
+ (split (mapcan #'erc--split-line first))
+ (lines (nreverse (seq-drop-while #'string-empty-p
+ (nreverse split))))
+ ((string-match erc-command-regexp (car lines))))
+ (progn
+ ;; Asking users what to do here might make more sense.
+ (cl-assert (not (cdr lines)))
+ ;; The `force' arg (here t) is ignored for command lines.
+ (erc-process-input-line (concat (car lines) "\n") t nil))
+ (progn ; temporarily preserve indentation
(dolist (line lines)
- (dolist (line (or (and erc-flood-protect (erc-split-line line))
- (list line)))
+ (progn ; temporarily preserve indentation
(when (erc-input-insertp state)
(erc-display-msg line))
(erc-process-input-line (concat line "\n")
@@ -5964,23 +8087,28 @@ Return non-nil only if we actually send anything."
t)))))
(defun erc-display-msg (line)
- "Display LINE as a message of the user to the current target at point."
+ "Insert LINE into current buffer and run \"send\" hooks.
+Treat LINE as input submitted interactively at the prompt, such
+as outgoing chat messages and echoed slash commands."
(when erc-insert-this
- (let ((insert-position (point)))
- (insert (erc-format-my-nick))
- (let ((beg (point)))
- (insert line)
- (erc-put-text-property beg (point)
- 'font-lock-face 'erc-input-face))
- (insert "\n")
- (when (processp erc-server-process)
- (set-marker (process-mark erc-server-process) (point)))
- (set-marker erc-insert-marker (point))
- (save-excursion
+ (save-excursion
+ (erc--assert-input-bounds)
+ (let ((insert-position (marker-position (goto-char erc-insert-marker)))
+ (erc--msg-props (or erc--msg-props
+ (let ((ovs (seq-filter
+ #'cdr erc--msg-prop-overrides)))
+ (map-into `((erc--msg . msg) ,@(reverse ovs))
+ 'hash-table)))))
+ (insert (erc--format-speaker-input-message line) "\n")
(save-restriction
(narrow-to-region insert-position (point))
(run-hooks 'erc-send-modify-hook)
- (run-hooks 'erc-send-post-hook))))))
+ (run-hooks 'erc-send-post-hook)
+ (cl-assert (> (- (point-max) (point-min)) 1))
+ (add-text-properties (point-min) (1+ (point-min))
+ (erc--order-text-properties-from-hash
+ erc--msg-props)))
+ (erc--refresh-prompt)))))
(defun erc-command-symbol (command)
"Return the ERC command symbol for COMMAND if it exists and is bound."
@@ -5988,9 +8116,18 @@ Return non-nil only if we actually send anything."
(when (fboundp cmd) cmd)))
(defun erc-extract-command-from-line (line)
- "Extract command and args from the input LINE.
-If no command was given, return nil. If command matches, return a
-list of the form: (command args) where both elements are strings."
+ "Extract a \"slash command\" and its args from a prompt-input LINE.
+If LINE doesn't start with a slash command, return nil. If it
+does, meaning the pattern `erc-command-regexp' matches, return a
+list of the form (COMMAND ARGS), where COMMAND is either a symbol
+for a known handler function or `erc-cmd-default' if unknown.
+When COMMAND has the symbol property `do-not-parse-args', return
+a string in place of ARGS: that is, either LINE itself, when LINE
+consists of only whitespace, or LINE stripped of any trailing
+whitespace, including a final newline. When COMMAND lacks the
+symbol property `do-not-parse-args', return a possibly empty list
+of non-whitespace tokens. Do not perform any shell-style parsing
+of quoted or escaped substrings."
(when (string-match erc-command-regexp line)
(let* ((cmd (erc-command-symbol (match-string 1 line)))
;; note: return is nil, we apply this simply for side effects
@@ -6060,28 +8197,15 @@ See also `erc-downcase'."
;; default target handling
(defun erc--current-buffer-joined-p ()
- "Return whether the current target buffer is joined."
- ;; This may be a reliable means of detecting subscription status,
- ;; but it's also roundabout and awkward. Perhaps it's worth
- ;; discussing adding a joined slot to `erc--target' for this.
- (cl-assert erc--target)
+ "Return non-nil if the current buffer is a channel and is joined."
(and (erc--target-channel-p erc--target)
- (erc-get-channel-user (erc-current-nick)) t))
-
-;; While `erc-default-target' happens to return nil in channel buffers
-;; you've parted or from which you've been kicked, using it to detect
-;; whether a channel is currently joined may become unreliable in the
-;; future. For now, third-party code can use
-;;
-;; (erc-get-channel-user (erc-current-nick))
-;;
-;; A predicate may be provided eventually. For retrieving a target's
-;; name regardless of subscription or connection status, new library
-;; code should use `erc--default-target'. Third-party code should
-;; continue to use `erc-default-target'.
+ (erc--target-channel-joined-p erc--target)
+ t))
(defun erc-default-target ()
- "Return the current default target (as a character string) or nil if none."
+ "Return the current channel or query target, if any.
+For historical reasons, return nil in channel buffers if not
+currently joined."
(let ((tgt (car erc-default-recipients)))
(cond
((not tgt) nil)
@@ -6128,6 +8252,8 @@ The previous default target of QUERY type gets removed."
(setq erc-default-recipients d2)
(error "Current target is not a QUERY"))))
+;; FIXME move all ignore-related functionality to its own module,
+;; required and enabled by default (until some major version change).
(defun erc-ignored-user-p (spec)
"Return non-nil if SPEC matches something in `erc-ignore-list'.
@@ -6388,7 +8514,8 @@ and so on."
((string-match "^%[Ss]$" esc) server)
((string-match "^%[Nn]$" esc) nick)
((string-match "^%\\(.\\)$" esc) (match-string 1 esc))
- (t (erc-log (format "BUG in erc-process-script-line: bad escape sequence: %S\n" esc))
+ (t (erc-log (format "Bad escape sequence in %s: %S\n"
+ 'erc-process-script-line esc))
(message "BUG IN ERC: esc=%S" esc)
"")))
(setq line tail)
@@ -6407,34 +8534,6 @@ and so on."
(buffer-string))))
(erc-load-irc-script-lines (erc-split-multiline-safe str) force)))
-(defun erc-load-irc-script-lines (lines &optional force noexpand)
- "Load IRC script LINES (a list of strings).
-
-If optional NOEXPAND is non-nil, do not expand script-specific
-sequences, process the lines verbatim. Use this for multiline
-user input."
- (let* ((cb (current-buffer))
- (s "")
- (sp (or (erc-command-indicator) (erc-prompt)))
- (args (and (boundp 'erc-script-args) erc-script-args)))
- (if (and args (string-match "^ " args))
- (setq args (substring args 1)))
- ;; prepare the prompt string for echo
- (erc-put-text-property 0 (length sp)
- 'font-lock-face 'erc-command-indicator-face sp)
- (while lines
- (setq s (car lines))
- (erc-log (concat "erc-load-script: CMD: " s))
- (unless (string-match "^\\s-*$" s)
- (let ((line (if noexpand s (erc-process-script-line s args))))
- (if (and (erc-process-input-line line force)
- erc-script-echo)
- (progn
- (erc-put-text-property 0 (length line)
- 'font-lock-face 'erc-input-face line)
- (erc-display-line (concat sp line) cb)))))
- (setq lines (cdr lines)))))
-
;; authentication
(defun erc--unfun (maybe-fn)
@@ -6643,15 +8742,14 @@ If it doesn't exist, create it."
(unless (file-attributes dir) (make-directory dir))
(or (file-accessible-directory-p dir) (error "Cannot access %s" dir)))
+;; FIXME make function obsolete or alias to something less confusing.
(defun erc-kill-query-buffers (process)
- "Kill all buffers of PROCESS.
-Does nothing if PROCESS is not a process object."
+ "Kill all target buffers of PROCESS, including channel buffers.
+Do nothing if PROCESS is not a process object."
;; here, we only want to match the channel buffers, to avoid
;; "selecting killed buffers" b0rkage.
(when (processp process)
- (erc-with-all-buffers-of-server process
- (lambda ()
- (not (erc-server-buffer-p)))
+ (erc-with-all-buffers-of-server process (lambda () erc--target)
(kill-buffer (current-buffer)))))
(defun erc-nick-at-point ()
@@ -6743,8 +8841,13 @@ See `erc-mode-line-format' for which characters are can be used."
:type '(choice (const :tag "Disabled" nil)
string))
+;; This should optionally support the built-in `tab-bar'.
(defcustom erc-header-line-uses-tabbar-p nil
- "Use tabbar mode instead of the header line to display the header."
+ "Use `tabbar-mode' integration instead of the header line.
+This concerns a historical integration with the external library
+`tabbar' <https://www.emacswiki.org/emacs/tabbar.el>, which
+shouldn't be confused with the built-in `tab-bar' described in
+Info node `(emacs) Tab Bars'."
:group 'erc-mode-line-and-header
:type 'boolean)
@@ -6835,6 +8938,62 @@ shortened server name instead."
(format-time-string erc-mode-line-away-status-format a)
"")))
+(defvar-local erc--away-indicator nil
+ "Cons containing an away indicator for the connection.")
+
+(defvar erc-away-status-indicator "A"
+ "String shown by various formatting facilities to indicate away status.
+Currently only used by the option `erc-prompt-format'.")
+
+(defun erc--format-away-indicator ()
+ "Return char with `display' property of `erc--away-indicator'."
+ (and-let* ((indicator (erc-with-server-buffer
+ (or erc--away-indicator
+ (setq erc--away-indicator (list "")))))
+ (newcar (if (erc-away-time) erc-away-status-indicator "")))
+ ;; Inform other buffers of the change when necessary.
+ (let ((dispp (not erc--inhibit-prompt-display-property-p)))
+ (unless (eq newcar (car indicator))
+ (erc--refresh-prompt-continue (and dispp 'hooks-only-p))
+ (setcar indicator newcar))
+ (if dispp
+ (propertize "(away?)" 'display indicator)
+ newcar))))
+
+(defvar-local erc--user-modes-indicator nil
+ "Cons containing connection-wide indicator for user modes.")
+
+;; If adding more of these functions, should factor out commonalities.
+;; As of ERC 5.6, this is identical to the away variant aside from
+;; the var names and `eq', which isn't important.
+(defun erc--format-user-modes ()
+ "Return server's user modes as a string"
+ (and-let* ((indicator (erc-with-server-buffer
+ (or erc--user-modes-indicator
+ (setq erc--user-modes-indicator (list "")))))
+ (newcar (erc--user-modes 'string)))
+ (let ((dispp (not erc--inhibit-prompt-display-property-p)))
+ (unless (string= newcar (car indicator))
+ (erc--refresh-prompt-continue (and dispp 'hooks-only-p))
+ (setcar indicator newcar))
+ (if dispp
+ (propertize "(user-modes?)" 'display indicator)
+ newcar))))
+
+(defun erc--format-channel-status-prefix ()
+ "Return the current channel membership prefix."
+ (and (erc--target-channel-p erc--target)
+ (erc-get-channel-membership-prefix (erc-current-nick))))
+
+(defun erc--format-modes (&optional no-query-p)
+ "Return a string of channel modes in channels and user modes elsewhere.
+With NO-QUERY-P, return nil instead of user modes in query
+buffers. Also return nil when mode information is unavailable."
+ (cond ((erc--target-channel-p erc--target)
+ (erc--channel-modes 'string))
+ ((not (and erc--target no-query-p))
+ (erc--format-user-modes))))
+
(defun erc-format-channel-modes ()
"Return the current channel's modes."
(concat (apply #'concat
@@ -6859,8 +9018,6 @@ shortened server name instead."
(cond (lag (format "lag:%.0f" lag))
(t ""))))
-;; erc-goodies is required at end of this file.
-
;; TODO when ERC drops Emacs 28, replace the expressions in the format
;; spec below with functions.
(defun erc-update-mode-line-buffer (buffer)
@@ -6868,7 +9025,7 @@ shortened server name instead."
(with-current-buffer buffer
(let ((spec `((?a . ,(erc-format-away-status))
(?l . ,(erc-format-lag-time))
- (?m . ,(erc-format-channel-modes))
+ (?m . ,(or erc--mode-line-mode-string ""))
(?n . ,(or (erc-current-nick) ""))
(?N . ,(erc-format-network))
(?o . ,(or (erc-controls-strip erc-channel-topic) ""))
@@ -6897,7 +9054,8 @@ shortened server name instead."
(format-spec erc-header-line-format spec)
nil)))
(cond (erc-header-line-uses-tabbar-p
- (setq-local tabbar--local-hlf header-line-format)
+ (when (boundp 'tabbar--local-hlf)
+ (setq-local tabbar--local-hlf header-line-format))
(kill-local-variable 'header-line-format))
((null header)
(setq header-line-format nil))
@@ -6940,6 +9098,54 @@ If BUFFER is nil, update the mode line in all ERC buffers."
(goto-char (point-min))
(insert "X-Debbugs-CC: emacs-erc@gnu.org\n")))
+(defconst erc--news-url
+ "https://git.savannah.gnu.org/cgit/emacs.git/plain/etc/ERC-NEWS")
+
+(defvar erc--news-temp-file nil)
+
+(defun erc-news (arg)
+ "Show ERC news in a manner similar to `view-emacs-news'.
+With ARG, download and display the latest revision, which may
+contain more up-to-date information, even for older versions."
+ (interactive "P")
+ (find-file
+ (or (and erc--news-temp-file
+ (time-less-p (current-time) (car erc--news-temp-file))
+ (not (and arg (y-or-n-p (format "Re-fetch? "))))
+ (cdr erc--news-temp-file))
+ (and arg
+ (with-current-buffer (url-retrieve-synchronously erc--news-url)
+ (goto-char (point-min))
+ (search-forward "200 OK" (pos-eol))
+ (search-forward "\n\n")
+ (delete-region (point-min) (point))
+ ;; May warn about file having changed on disk (unless
+ ;; `query-about-changed-file' is nil on 28+).
+ (let ((tempfile (or (cdr erc--news-temp-file)
+ (make-temp-file "erc-news."))))
+ (write-region (point-min) (point-max) tempfile)
+ (kill-buffer)
+ (cdr (setq erc--news-temp-file
+ (cons (time-add (current-time) (* 60 60 12))
+ tempfile))))))
+ (and-let* ((file (or (eval-when-compile (macroexp-file-name))
+ (locate-library "erc")))
+ (dir (file-name-directory file))
+ (adjacent (expand-file-name "ERC-NEWS" dir))
+ ((file-exists-p adjacent)))
+ adjacent)
+ (expand-file-name "ERC-NEWS" data-directory)))
+ (when (fboundp 'emacs-news-view-mode)
+ (emacs-news-view-mode))
+ (goto-char (point-min))
+ (let ((v (mapcar #'number-to-string
+ (seq-take-while #'natnump (version-to-list erc-version)))))
+ (while (and v (not (search-forward (concat "\014\n* Changes in ERC "
+ (string-join v "."))
+ nil t)))
+ (setq v (butlast v))))
+ (beginning-of-line))
+
(defun erc-port-to-string (p)
"Convert port P to a string.
P may be an integer or a service name."
@@ -6983,10 +9189,11 @@ If optional argument HERE is non-nil, insert version number at point."
(let (modes (case-fold-search nil))
(dolist (var (apropos-internal "^erc-.*mode$"))
(when (and (boundp var)
+ (get var 'erc-module)
(symbol-value var))
- (setq modes (cons (symbol-name var)
+ (setq modes (cons (concat "`" (symbol-name var) "'")
modes))))
- modes)
+ (sort modes #'string<))
", ")))
(if here
(insert string)
@@ -7042,24 +9249,38 @@ All windows are opened in the current frame."
;;; Message catalog
+(define-inline erc--make-message-variable-name (catalog key softp)
+ "Return variable name conforming to ERC's message-catalog interface.
+Given a CATALOG symbol `mycat' and format-string KEY `mykey',
+also a symbol, return the symbol `erc-message-mycat-mykey'. With
+SOFTP, only do so when defined as a variable."
+ (inline-quote
+ (let* ((catname (symbol-name ,catalog))
+ (prefix (if (eq ?- (aref catname 0)) "erc--message" "erc-message-"))
+ (name (concat prefix catname "-" (symbol-name ,key))))
+ (if ,softp
+ (and-let* ((s (intern-soft name)) ((boundp s))) s)
+ (intern name)))))
+
(defun erc-make-message-variable-name (catalog entry)
"Create a variable name corresponding to CATALOG's ENTRY."
- (intern (concat "erc-message-"
- (symbol-name catalog) "-" (symbol-name entry))))
+ (erc--make-message-variable-name catalog entry nil))
(defun erc-define-catalog-entry (catalog entry format-spec)
"Set CATALOG's ENTRY to FORMAT-SPEC."
+ (declare (obsolete "define manually using `defvar' instead" "30.1"))
(set (erc-make-message-variable-name catalog entry)
format-spec))
(defun erc-define-catalog (catalog entries)
"Define a CATALOG according to ENTRIES."
- (dolist (entry entries)
- (erc-define-catalog-entry catalog (car entry) (cdr entry))))
+ (declare (obsolete erc-define-message-format-catalog "30.1"))
+ (with-suppressed-warnings ((obsolete erc-define-catalog-entry))
+ (dolist (entry entries)
+ (erc-define-catalog-entry catalog (car entry) (cdr entry)))))
-(erc-define-catalog
- 'english
- '((bad-ping-response . "Unexpected PING response from %n (time %t)")
+(erc--define-catalog english
+ ((bad-ping-response . "Unexpected PING response from %n (time %t)")
(bad-syntax . "Error occurred - incorrect usage?\n%c %u\n%d")
(incorrect-args . "Incorrect arguments. Usage:\n%c %u\n%d")
(cannot-find-file . "Cannot find file %f")
@@ -7074,9 +9295,10 @@ All windows are opened in the current frame."
(flood-ctcp-off . "FLOOD PROTECTION: Automatic CTCP responses turned off.")
(flood-strict-mode
. "FLOOD PROTECTION: Switched to Strict Flood Control mode.")
- (disconnected . "\n\nConnection failed! Re-establishing connection...\n")
+ (disconnected
+ . "\n\n*** Connection failed! Re-establishing connection...\n")
(disconnected-noreconnect
- . "\n\nConnection failed! Not re-establishing connection.\n")
+ . "\n\n*** Connection failed! Not re-establishing connection.\n")
(reconnecting . "Reconnecting in %ms: attempt %i/%n ...")
(reconnect-canceled . "Canceled %u reconnect timer with %cs to go...")
(finished . "\n\n*** ERC finished ***\n")
@@ -7091,6 +9313,10 @@ All windows are opened in the current frame."
(ops . "%i operator%s: %o")
(ops-none . "No operators in this channel.")
(undefined-ctcp . "Undefined CTCP query received. Silently ignored")
+ (user-mode-redundant-add
+ . "Already have user mode(s): %m. Requesting again anyway.")
+ (user-mode-redundant-drop
+ . "Already without user mode(s): %m. Requesting removal anyway.")
(variable-not-bound . "Variable not bound!")
(ACTION . "* %n %a")
(CTCP-CLIENTINFO . "Client info for %n: %m")
@@ -7111,7 +9337,7 @@ All windows are opened in the current frame."
(MODE-nick . "%n has changed mode for %t to %m")
(NICK . "%n (%u@%h) is now known as %N")
(NICK-you . "Your new nickname is %N")
- (PART . erc-message-english-PART)
+ (PART . #'erc-message-english-PART)
(PING . "PING from server (last: %s sec. ago)")
(PONG . "PONG from %h (%i second%s)")
(QUIT . "%n (%u@%h) has quit: %r")
@@ -7153,7 +9379,9 @@ All windows are opened in the current frame."
(s368 . "Banlist of %c ends.")
(s379 . "%c: Forwarded to %f")
(s391 . "The time at %s is %t")
+ (s396 . "Your visible host has changed to %s")
(s401 . "%n: No such nick/channel")
+ (s402 . "%c: No such server")
(s403 . "%c: No such channel")
(s404 . "%c: Cannot send to channel")
(s405 . "%c: You have joined too many channels")
@@ -7171,6 +9399,8 @@ All windows are opened in the current frame."
(s463 . "Your host isn't among the privileged")
(s464 . "Password incorrect")
(s465 . "You are banned from this server")
+ (s471 . "Max occupancy for channel %c exceeded: %s")
+ (s473 . "Channel %c is invitation only")
(s474 . "You can't join %c because you're banned (+b)")
(s475 . "You must specify the correct channel key (+k) to join %c")
(s481 . "Permission Denied - You're not an IRC operator")
@@ -7202,22 +9432,26 @@ functions."
(string-replace "%" "%%" reason))
"")))))
-
-(defvar-local erc-current-message-catalog 'english)
-
-(defun erc-retrieve-catalog-entry (entry &optional catalog)
- "Retrieve ENTRY from CATALOG.
-
-If CATALOG is nil, `erc-current-message-catalog' is used.
-
-If ENTRY is nil in CATALOG, it is retrieved from the fallback,
-english, catalog."
+(defun erc-retrieve-catalog-entry (key &optional catalog)
+ "Retrieve `format-spec' entry for symbol KEY in CATALOG.
+Without symbol CATALOG, use `erc-current-message-catalog'. If
+lookup fails, try the latter's `default-toplevel-value' if it's
+not the same as CATALOG. Failing that, try the `english' catalog
+if yet untried."
(unless catalog (setq catalog erc-current-message-catalog))
- (let ((var (erc-make-message-variable-name catalog entry)))
- (if (boundp var)
- (symbol-value var)
- (when (boundp (erc-make-message-variable-name 'english entry))
- (symbol-value (erc-make-message-variable-name 'english entry))))))
+ (symbol-value
+ (or (erc--make-message-variable-name catalog key 'softp)
+ (let ((parent catalog)
+ last)
+ (while (and (setq parent (get parent 'erc--base-format-catalog))
+ (not (setq last (erc--make-message-variable-name
+ parent key 'softp)))))
+ last)
+ (let ((default (default-toplevel-value 'erc-current-message-catalog)))
+ (or (and (not (eq default catalog))
+ (erc--make-message-variable-name default key 'softp))
+ (and (not (memq 'english (list default catalog)))
+ (erc--make-message-variable-name 'english key 'softp)))))))
(defun erc-format-message (msg &rest args)
"Format MSG according to ARGS.
@@ -7260,6 +9494,7 @@ See also `kill-buffer'."
:group 'erc-hooks
:type 'hook)
+;; FIXME alias and deprecate current *-function suffixed name.
(defun erc-kill-buffer-function ()
"Function to call when an ERC buffer is killed.
This function should be on `kill-buffer-hook'.
@@ -7273,11 +9508,28 @@ or `erc-kill-buffer-hook' if any other buffer."
(cond
((eq (erc-server-buffer) (current-buffer))
(run-hooks 'erc-kill-server-hook))
- ((erc-channel-p (or (erc-default-target) (buffer-name)))
+ ((erc--target-channel-p erc--target)
(run-hooks 'erc-kill-channel-hook))
(t
(run-hooks 'erc-kill-buffer-hook)))))
+(declare-function set-text-conversion-style "textconv.c")
+
+(defun erc-check-text-conversion ()
+ "Check if point is within the ERC prompt and toggle text conversion.
+If `text-conversion-style' is not `action' if point is within the
+prompt or `nil' otherwise, set it to such a value, so as to
+guarantee that the input method functions properly for the
+purpose of typing within the ERC prompt."
+ (when (and (eq major-mode 'erc-mode)
+ (fboundp 'set-text-conversion-style))
+ (defvar text-conversion-style) ; avoid free variable warning on <=29
+ (if (>= (point) (erc-beg-of-input-line))
+ (unless (eq text-conversion-style 'action)
+ (set-text-conversion-style 'action))
+ (unless (not text-conversion-style)
+ (set-text-conversion-style nil)))))
+
(defun erc-kill-server ()
"Sends a QUIT command to the server when the server buffer is killed.
This function should be on `erc-kill-server-hook'."
@@ -7302,11 +9554,12 @@ This function should be on `erc-kill-channel-hook'."
(text-property-not-all (point-min) (point-max) 'erc-parsed nil))
(defun erc-restore-text-properties ()
- "Restore the property `erc-parsed' for the region."
- (let ((parsed-posn (erc-find-parsed-property)))
- (put-text-property
- (point-min) (point-max)
- 'erc-parsed (when parsed-posn (erc-get-parsed-vector parsed-posn)))))
+ "Ensure the `erc-parsed' and `tags' props cover the entire message."
+ (when-let ((parsed-posn (erc-find-parsed-property))
+ (found (erc-get-parsed-vector parsed-posn)))
+ (put-text-property (point-min) (point-max) 'erc-parsed found)
+ (when-let ((tags (get-text-property parsed-posn 'tags)))
+ (put-text-property (point-min) (point-max) 'tags tags))))
(defun erc-get-parsed-vector (point)
"Return the whole parsed vector on POINT."
@@ -7326,6 +9579,13 @@ This function should be on `erc-kill-channel-hook'."
(and vect
(erc-response.command vect)))
+(defun erc--get-eq-comparable-cmd (command)
+ "Return a symbol or a fixnum representing a message's COMMAND.
+See also `erc-message-type'."
+ ;; IRC numerics are three-digit numbers, possibly with leading 0s.
+ ;; To invert: (if (numberp o) (format "%03d" o) (symbol-name o))
+ (if-let ((n (string-to-number command)) ((zerop n))) (intern command) n))
+
;; Teach url.el how to open irc:// URLs with ERC.
;; To activate, customize `url-irc-function' to `url-irc-erc'.
@@ -7364,6 +9624,8 @@ Beginning with ERC 5.5, new connections require human intervention.
Customize `erc-url-connect-function' to override this."
(when (eql port 0) (setq port nil))
(let* ((net (erc-networks--determine host))
+ (erc--display-context `((erc-interactive-display . url)
+ ,@erc--display-context))
(server-buffer
;; Viable matches may slip through the cracks for unknown
;; networks. Additional passes could likely improve things.
@@ -7409,6 +9671,4 @@ Customize `erc-url-connect-function' to override this."
(provide 'erc)
-;; FIXME this is a temporary stopgap for Emacs 29.
-(require 'erc-goodies)
;;; erc.el ends here
diff --git a/lisp/eshell/em-alias.el b/lisp/eshell/em-alias.el
index fd4a4b34040..832e14418d0 100644
--- a/lisp/eshell/em-alias.el
+++ b/lisp/eshell/em-alias.el
@@ -183,7 +183,9 @@ file named by `eshell-aliases-file'.")
(pcomplete-here (eshell-alias-completions pcomplete-stub)))
(defun eshell-read-aliases-list ()
- "Read in an aliases list from `eshell-aliases-file'."
+ "Read in an aliases list from `eshell-aliases-file'.
+This is useful after manually editing the contents of the file."
+ (interactive)
(let ((file eshell-aliases-file))
(when (file-readable-p file)
(setq eshell-command-aliases-list
diff --git a/lisp/eshell/em-banner.el b/lisp/eshell/em-banner.el
index a39002266b3..e6dcbb24475 100644
--- a/lisp/eshell/em-banner.el
+++ b/lisp/eshell/em-banner.el
@@ -43,7 +43,6 @@
(require 'esh-util)
(require 'esh-mode)
-(require 'eshell)
;;;###autoload
(progn
diff --git a/lisp/eshell/em-basic.el b/lisp/eshell/em-basic.el
index eff36d6430e..6ec53ef9412 100644
--- a/lisp/eshell/em-basic.el
+++ b/lisp/eshell/em-basic.el
@@ -53,9 +53,10 @@
;;; Code:
-(require 'esh-util)
-(require 'eshell)
+(require 'esh-cmd)
+(require 'esh-io)
(require 'esh-opt)
+(require 'esh-util)
;;;###autoload
(progn
@@ -159,6 +160,18 @@ or `eshell-printn' for display."
:preserve-args
:usage "[-S] [mode]")
(cond
+ (args
+ (let* ((mask (car args))
+ (modes
+ (if (stringp mask)
+ (if (string-match (rx bos (+ (any "0-7")) eos) mask)
+ (- #o777 (string-to-number mask 8))
+ (file-modes-symbolic-to-number
+ mask (default-file-modes)))
+ (- #o777 mask))))
+ (set-default-file-modes modes)
+ (eshell-print
+ "Warning: umask changed for all new files created by Emacs.\n")))
(symbolic-p
(let ((mode (default-file-modes)))
(eshell-printn
@@ -172,21 +185,45 @@ or `eshell-printn' for display."
(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")))
+ (eshell-printn (format "%03o" (logand (lognot (default-file-modes))
+ #o777)))))
nil))
(put 'eshell/umask 'eshell-no-numeric-conversions t)
+(defun eshell/eshell-debug (&rest args)
+ "A command for toggling certain debug variables."
+ (eshell-eval-using-options
+ "eshell-debug" args
+ '((?h "help" nil nil "display this usage message")
+ :usage "[KIND]...
+This command is used to aid in debugging problems related to Eshell
+itself. It is not useful for anything else. The recognized `kinds'
+are:
+
+ error stops Eshell from trapping errors
+ form shows command form manipulation in `*eshell last cmd*'
+ process shows process events in `*eshell last cmd*'")
+ (if args
+ (dolist (kind args)
+ (if (equal kind "error")
+ (setq eshell-handle-errors (not eshell-handle-errors))
+ (let ((kind-sym (intern kind)))
+ (if (memq kind-sym eshell-debug-command)
+ (setq eshell-debug-command
+ (delq kind-sym eshell-debug-command))
+ (push kind-sym eshell-debug-command)))))
+ ;; Output the currently-enabled debug kinds.
+ (unless eshell-handle-errors
+ (eshell-print "errors\n"))
+ (dolist (kind eshell-debug-command)
+ (eshell-printn (symbol-name kind))))))
+
+(defun pcomplete/eshell-mode/eshell-debug ()
+ "Completion for the `debug' command."
+ (while (pcomplete-here '("error" "form" "process"))))
+
(provide 'em-basic)
;; Local Variables:
diff --git a/lisp/eshell/em-cmpl.el b/lisp/eshell/em-cmpl.el
index 0bdedab12ff..201beb5071d 100644
--- a/lisp/eshell/em-cmpl.el
+++ b/lisp/eshell/em-cmpl.el
@@ -74,9 +74,7 @@
(require 'esh-util)
(require 'em-dirs)
-(eval-when-compile
- (require 'cl-lib)
- (require 'eshell))
+(eval-when-compile (require 'cl-lib))
;;;###autoload
(progn
@@ -150,6 +148,10 @@ to writing a completion function."
(eshell-cmpl--custom-variable-docstring 'pcomplete-dir-ignore)
:type (get 'pcomplete-dir-ignore 'custom-type))
+(defcustom eshell-cmpl-remote-file-ignore nil
+ (eshell-cmpl--custom-variable-docstring 'pcomplete-remote-file-ignore)
+ :type (get 'pcomplete-remote-file-ignore 'custom-type))
+
(defcustom eshell-cmpl-ignore-case (eshell-under-windows-p)
(eshell-cmpl--custom-variable-docstring 'completion-ignore-case)
:type (get 'completion-ignore-case 'custom-type))
@@ -250,6 +252,8 @@ to writing a completion function."
eshell-cmpl-file-ignore)
(setq-local pcomplete-dir-ignore
eshell-cmpl-dir-ignore)
+ (setq-local pcomplete-remote-file-ignore
+ eshell-cmpl-remote-file-ignore)
(setq-local completion-ignore-case
eshell-cmpl-ignore-case)
(setq-local pcomplete-autolist
@@ -306,15 +310,44 @@ to writing a completion function."
(insert-and-inherit "\t")
(throw 'pcompleted t)))
+(defun eshell-complete--eval-argument-form (arg)
+ "Evaluate a single Eshell argument form ARG for the purposes of completion."
+ (condition-case err
+ (let* (;; Don't allow running commands; they could have
+ ;; arbitrary side effects, which we don't want when we're
+ ;; just performing completions!
+ (eshell-allow-commands)
+ ;; Handle errors ourselves so that we can properly catch
+ ;; `eshell-commands-forbidden'.
+ (eshell-handle-errors)
+ (result (eshell-do-eval `(eshell-commands ,arg) t)))
+ (cl-assert (eq (car result) 'quote))
+ (cadr result))
+ (eshell-commands-forbidden
+ (propertize "\0" 'eshell-argument-stub
+ (intern (format "%s-command" (cadr err)))))
+ (error
+ (lwarn 'eshell :error
+ "Failed to evaluate argument form during completion: %S" arg)
+ (propertize "\0" 'eshell-argument-stub 'error))))
+
+;; Code stolen from `eshell-plain-command'.
+(defun eshell-external-command-p (command)
+ "Whether an external command shall be called."
+ (let* ((esym (eshell-find-alias-function command))
+ (sym (or esym (intern-soft command))))
+ (not (and sym (fboundp sym)
+ (or esym eshell-prefer-lisp-functions
+ (not (eshell-search-path command)))))))
+
(defun eshell-complete-parse-arguments ()
"Parse the command line arguments for `pcomplete-argument'."
(when (and eshell-no-completion-during-jobs
- (eshell-interactive-process-p))
+ eshell-foreground-command)
(eshell--pcomplete-insert-tab))
(let ((end (point-marker))
- (begin (save-excursion (eshell-bol) (point)))
- (posns (list t))
- args delim)
+ (begin (save-excursion (beginning-of-line) (point)))
+ args posns delim incomplete-arg)
(when (and pcomplete-allow-modifications
(memq this-command '(pcomplete-expand
pcomplete-expand-and-complete)))
@@ -322,59 +355,97 @@ to writing a completion function."
(if (= begin end)
(end-of-line))
(setq end (point-marker)))
- (if (setq delim
- (catch 'eshell-incomplete
- (ignore
- (setq args (eshell-parse-arguments begin end)))))
- (cond ((memq (car delim) '(?\{ ?\<))
- (setq begin (1+ (cadr delim))
- args (eshell-parse-arguments begin end)))
- ((eq (car delim) ?\()
- (throw 'pcompleted (elisp-completion-at-point)))
- (t
- (eshell--pcomplete-insert-tab))))
- (when (get-text-property (1- end) 'comment)
+ ;; Don't expand globs when parsing arguments; we want to pass any
+ ;; globs to Pcomplete unaltered.
+ (declare-function eshell-parse-glob-chars "em-glob" ())
+ (let ((eshell-parse-argument-hook (remq #'eshell-parse-glob-chars
+ eshell-parse-argument-hook)))
+ (if (setq delim
+ (catch 'eshell-incomplete
+ (ignore
+ (setq args (eshell-parse-arguments begin end)))))
+ (cond ((member (car delim) '("{" "${" "$<"))
+ (setq begin (1+ (cadr delim))
+ args (eshell-parse-arguments begin end)))
+ ((member (car delim) '("$'" "$\"" "#<"))
+ ;; Add the (incomplete) argument to our arguments, and
+ ;; note its position.
+ (setq args (append (nth 2 delim) (list (car delim)))
+ incomplete-arg t)
+ (push (- (nth 1 delim) 2) posns))
+ ((member (car delim) '("(" "$("))
+ (throw 'pcompleted (elisp-completion-at-point)))
+ (t
+ (eshell--pcomplete-insert-tab)))))
+ (when (and (< begin end)
+ (get-text-property (1- end) 'comment))
(eshell--pcomplete-insert-tab))
- (let ((pos begin))
- (while (< pos end)
- (if (get-text-property pos 'arg-begin)
- (nconc posns (list pos)))
- (setq pos (1+ pos))))
- (setq posns (cdr posns))
+ (let ((pos (1- end)))
+ (while (>= pos begin)
+ (when (get-text-property pos 'arg-begin)
+ (push pos posns))
+ (setq pos (1- pos))))
(cl-assert (= (length args) (length posns)))
- (let ((a args)
- (i 0)
- l)
+ (let ((a args) (i 0) new-start)
(while a
- (if (and (consp (car a))
- (eq (caar a) 'eshell-operator))
- (setq l i))
- (setq a (cdr a) i (1+ i)))
- (and l
- (setq args (nthcdr (1+ l) args)
- posns (nthcdr (1+ l) posns))))
+ ;; If there's an unreplaced `eshell-operator' sigil, consider
+ ;; the token after it the new start of our arguments.
+ (when (and (consp (car a))
+ (eq (caar a) 'eshell-operator))
+ (setq new-start i))
+ (setq a (cdr a)
+ i (1+ i)))
+ (when new-start
+ (setq args (nthcdr (1+ new-start) args)
+ posns (nthcdr (1+ new-start) posns))))
(cl-assert (= (length args) (length posns)))
- (when (and args (eq (char-syntax (char-before end)) ? )
+ (when (and args (not incomplete-arg)
+ (eq (char-syntax (char-before end)) ? )
(not (eq (char-before (1- end)) ?\\)))
(nconc args (list ""))
(nconc posns (list (point))))
+ ;; Evaluate and expand Eshell forms.
+ (let (evaled-args evaled-posns)
+ (cl-mapc
+ (lambda (arg posn)
+ (pcase arg
+ (`(eshell-splice-args ,val)
+ (dolist (subarg (eshell-complete--eval-argument-form val))
+ (push subarg evaled-args)
+ (push posn evaled-posns)))
+ ((pred listp)
+ (push (eshell-complete--eval-argument-form arg) evaled-args)
+ (push posn evaled-posns))
+ (_
+ (push arg evaled-args)
+ (push posn evaled-posns))))
+ args posns)
+ (setq args (nreverse evaled-args)
+ posns (nreverse evaled-posns)))
+ ;; Determine, whether remote file names shall be completed. They
+ ;; shouldn't for external commands, or when in a pipe. Respect
+ ;; also `eshell-cmpl-remote-file-ignore', which could be set by
+ ;; the user.
+ (setq-local pcomplete-remote-file-ignore
+ (or eshell-cmpl-remote-file-ignore
+ eshell-in-pipeline-p ; does not work
+ (eshell-external-command-p (car args))))
+ ;; Convert arguments to forms that Pcomplete can understand.
(cons (mapcar
(lambda (arg)
- (let ((val
- (if (listp arg)
- (let ((result
- (eshell-do-eval
- (list 'eshell-commands arg) t)))
- (cl-assert (eq (car result) 'quote))
- (cadr result))
- arg)))
- (cond ((numberp val)
- (setq val (number-to-string val)))
- ;; expand .../ etc that only eshell understands to
- ;; standard ../../
- ((and (stringp val)) (string-match "\\.\\.\\.+/" val)
- (setq val (eshell-expand-multiple-dots val))))
- (or val "")))
+ (pcase arg
+ ;; Expand ".../" etc that only Eshell understands to
+ ;; the standard "../../".
+ ((rx ".." (+ ".") "/")
+ (propertize (eshell-expand-multiple-dots arg)
+ 'pcomplete-arg-value arg))
+ ((pred stringp)
+ arg)
+ ('nil
+ (propertize "" 'pcomplete-arg-value arg))
+ (_
+ (propertize (eshell-stringify arg)
+ 'pcomplete-arg-value arg))))
args)
posns)))
diff --git a/lisp/eshell/em-dirs.el b/lisp/eshell/em-dirs.el
index 9e14745db86..07063afc286 100644
--- a/lisp/eshell/em-dirs.el
+++ b/lisp/eshell/em-dirs.el
@@ -253,11 +253,20 @@ Thus, this does not include the current directory.")
(throw 'eshell-replace-command
(eshell-parse-command "cd" (flatten-tree args)))))
+(defun eshell-expand-user-reference (file)
+ "Expand a user reference in FILE to its real directory name."
+ (replace-regexp-in-string
+ (rx bos (group "~" (*? anychar)) (or "/" eos))
+ #'expand-file-name file))
+
(defun eshell-parse-user-reference ()
"An argument beginning with ~ is a filename to be expanded."
(when (and (not eshell-current-argument)
- (eq (char-after) ?~))
- (add-to-list 'eshell-current-modifiers 'expand-file-name)
+ (not eshell-current-quoted)
+ (eq (char-after) ?~))
+ ;; Apply this modifier fairly early so it happens before things
+ ;; like glob expansion.
+ (add-hook 'eshell-current-modifiers #'eshell-expand-user-reference -50)
(forward-char)
(char-to-string (char-before))))
@@ -281,17 +290,34 @@ Thus, this does not include the current directory.")
(let ((arg (pcomplete-actual-arg)))
(when (string-match "\\`~[a-z]*\\'" arg)
(setq pcomplete-stub (substring arg 1)
- pcomplete-last-completion-raw t)
- (throw 'pcomplete-completions
- (progn
- (eshell-read-user-names)
- (pcomplete-uniquify-list
- (mapcar
- (lambda (user)
- (file-name-as-directory (cdr user)))
- eshell-user-names)))))))
-
-(defun eshell/pwd (&rest _args)
+ pcomplete-last-completion-raw t)
+ (eshell-read-user-names)
+ (let ((names (pcomplete-uniquify-list
+ (mapcar (lambda (user)
+ (file-name-as-directory (cdr user)))
+ eshell-user-names))))
+ (throw 'pcomplete-completions
+ ;; Provide a programmed completion table. This works
+ ;; just like completing over the list of names, except
+ ;; it always returns the completed string for
+ ;; `try-completion', never `t'. That's because this is
+ ;; only completing a directory name, and so the
+ ;; completion isn't actually finished yet.
+ (lambda (string pred action)
+ (pcase action
+ ('nil ; try-completion
+ (let ((result (try-completion string names pred)))
+ (if (eq result t) string result)))
+ ('t ; all-completions
+ (all-completions string names pred))
+ ('lambda ; test-completion
+ (test-completion string names pred))
+ ('metadata
+ '(metadata (category . file)))
+ (`(boundaries . ,suffix)
+ `(boundaries 0 . ,(string-search "/" suffix))))))))))
+
+(defun eshell/pwd ()
"Change output from `pwd' to be cleaner."
(let* ((path default-directory)
(len (length path)))
@@ -397,9 +423,13 @@ in the minibuffer:
(and eshell-cd-shows-directory
(eshell-printn result)))
(run-hooks 'eshell-directory-change-hook)
- (if eshell-list-files-after-cd
- ;; Let-bind eshell-last-command around this?
- (eshell-plain-command "ls" (cdr args)))
+ (when eshell-list-files-after-cd
+ ;; Call "ls", but don't update the last-command information.
+ (let ((eshell-last-command-name)
+ (eshell-last-command-status)
+ (eshell-last-arguments))
+ (eshell-protect
+ (eshell-plain-command "ls" (cdr args)))))
nil))))
(put 'eshell/cd 'eshell-no-numeric-conversions t)
diff --git a/lisp/eshell/em-elecslash.el b/lisp/eshell/em-elecslash.el
index a2ec8400c5b..93eadcfe1ff 100644
--- a/lisp/eshell/em-elecslash.el
+++ b/lisp/eshell/em-elecslash.el
@@ -72,7 +72,7 @@ insertion."
(delete-char -1)
(let ((tilde-before (eq ?~ (char-before)))
(command (save-excursion
- (eshell-bol)
+ (beginning-of-line)
(skip-syntax-forward " ")
(thing-at-point 'sexp)))
(prefix (file-remote-p default-directory)))
diff --git a/lisp/eshell/em-extpipe.el b/lisp/eshell/em-extpipe.el
index dc753d379b7..057eead9297 100644
--- a/lisp/eshell/em-extpipe.el
+++ b/lisp/eshell/em-extpipe.el
@@ -36,6 +36,21 @@
(eval-when-compile (require 'files-x))
+;;;###autoload
+(progn
+(defgroup eshell-extpipe nil
+ "Native shell pipelines.
+
+This module lets you construct pipelines that use your operating
+system's shell instead of Eshell's own pipelining support. This
+is especially relevant when executing commands on a remote
+machine using Eshell's Tramp integration: using the remote
+shell's pipelining avoids copying the data which will flow
+through the pipeline to local Emacs buffers and then right back
+again."
+ :tag "External pipelines"
+ :group 'eshell-module))
+
;;; Functions:
(defun eshell-extpipe-initialize () ;Called from `eshell-mode' via intern-soft!
@@ -103,86 +118,87 @@ as though it were Eshell syntax."
;; other members of `eshell-parse-argument-hook'. We must avoid
;; misinterpreting a quoted `*|', `*<' or `*>' as indicating an
;; external pipeline, hence the structure of the loop in `findbeg1'.
- (cl-flet
- ((findbeg1 (pat &optional go (bound (point-max)))
- (let* ((start (point))
- (result
- (catch 'found
- (while (> bound (point))
- (let* ((found
- (save-excursion
- (re-search-forward
- "\\(?:#?'\\|\"\\|\\\\\\)" bound t)))
- (next (or (and found (match-beginning 0))
- bound)))
- (if (re-search-forward pat next t)
- (throw 'found (match-beginning 1))
- (goto-char next)
- (while (eshell-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))
- (forward-char 1))))))))
- (goto-char (if (and result go) (match-end 0) start))
- result)))
- (unless (or eshell-current-argument eshell-current-quoted)
- (let ((beg (point)) end
- (next-marked (findbeg1 "\\(?:\\=\\|\\s-\\)\\(\\*[|<>]\\)"))
- (next-unmarked
- (or (findbeg1 "\\(?:\\=\\|[^*]\\|\\S-\\*\\)\\(|\\)")
- (point-max))))
- (when (and next-marked (> next-unmarked next-marked)
- (or (> next-marked (point))
- (looking-back "\\`\\|\\s-" nil)))
- ;; Skip to the final segment of the external pipeline.
- (while (findbeg1 "\\(?:\\=\\|\\s-\\)\\(\\*|\\)" t))
- ;; Find output redirections.
- (while (findbeg1
- "\\([0-9]?>+&?[0-9]?\\s-*\\S-\\)" t next-unmarked)
- ;; Is the output redirection Eshell-specific? We have our
- ;; own logic, rather than calling `eshell-parse-argument',
- ;; to avoid specifying here all the possible cars of
- ;; parsed special references -- `get-buffer-create' etc.
- (forward-char -1)
- (let ((this-end
- (save-match-data
- (cond ((looking-at "#<")
- (forward-char 1)
- (1+ (eshell-find-delimiter ?\< ?\>)))
- ((and (looking-at "/\\S-+")
- (assoc (match-string 0)
- eshell-virtual-targets))
- (match-end 0))))))
- (cond ((and this-end end)
- (goto-char this-end))
- (this-end
- (goto-char this-end)
- (setq end (match-beginning 0)))
- (t
- (setq end nil)))))
- ;; We've moved past all Eshell-specific output redirections
- ;; we could find. If there is only whitespace left, then
- ;; `end' is right before redirections we should exclude;
- ;; otherwise, we must include everything.
- (unless (and end (skip-syntax-forward "\s" next-unmarked)
- (= next-unmarked (point)))
- (setq end next-unmarked))
- (let ((cmd (string-trim
- (buffer-substring-no-properties beg end))))
- (goto-char end)
- ;; We must now drop the asterisks, unless quoted/escaped.
- (with-temp-buffer
- (insert cmd)
- (goto-char (point-min))
- (cl-loop
- for next = (findbeg1 "\\(?:\\=\\|\\s-\\)\\(\\*[|<>]\\)" t)
- while next do (forward-char -2) (delete-char 1))
- (eshell-finish-arg
- `(eshell-external-pipeline ,(buffer-string))))))))))
+ (unless eshell-current-argument-plain
+ (cl-flet
+ ((findbeg1 (pat &optional go (bound (point-max)))
+ (let* ((start (point))
+ (result
+ (catch 'found
+ (while (> bound (point))
+ (let* ((found
+ (save-excursion
+ (re-search-forward
+ "\\(?:#?'\\|\"\\|\\\\\\)" bound t)))
+ (next (or (and found (match-beginning 0))
+ bound)))
+ (if (re-search-forward pat next t)
+ (throw 'found (match-beginning 1))
+ (goto-char next)
+ (while (eshell-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))
+ (forward-char 1))))))))
+ (goto-char (if (and result go) (match-end 0) start))
+ result)))
+ (unless (or eshell-current-argument eshell-current-quoted)
+ (let ((beg (point)) end
+ (next-marked (findbeg1 "\\(?:\\=\\|\\s-\\)\\(\\*[|<>]\\)"))
+ (next-unmarked
+ (or (findbeg1 "\\(?:\\=\\|[^*]\\|\\S-\\*\\)\\(|\\)")
+ (point-max))))
+ (when (and next-marked (> next-unmarked next-marked)
+ (or (> next-marked (point))
+ (looking-back "\\`\\|\\s-" nil)))
+ ;; Skip to the final segment of the external pipeline.
+ (while (findbeg1 "\\(?:\\=\\|\\s-\\)\\(\\*|\\)" t))
+ ;; Find output redirections.
+ (while (findbeg1
+ "\\([0-9]?>+&?[0-9]?\\s-*\\S-\\)" t next-unmarked)
+ ;; Is the output redirection Eshell-specific? We have our
+ ;; own logic, rather than calling `eshell-parse-argument',
+ ;; to avoid specifying here all the possible cars of
+ ;; parsed special references -- `get-buffer-create' etc.
+ (forward-char -1)
+ (let ((this-end
+ (save-match-data
+ (cond ((looking-at "#<")
+ (forward-char 1)
+ (1+ (eshell-find-delimiter ?\< ?\>)))
+ ((and (looking-at "/\\S-+")
+ (assoc (match-string 0)
+ eshell-virtual-targets))
+ (match-end 0))))))
+ (cond ((and this-end end)
+ (goto-char this-end))
+ (this-end
+ (goto-char this-end)
+ (setq end (match-beginning 0)))
+ (t
+ (setq end nil)))))
+ ;; We've moved past all Eshell-specific output redirections
+ ;; we could find. If there is only whitespace left, then
+ ;; `end' is right before redirections we should exclude;
+ ;; otherwise, we must include everything.
+ (unless (and end (skip-syntax-forward "\s" next-unmarked)
+ (= next-unmarked (point)))
+ (setq end next-unmarked))
+ (let ((cmd (string-trim
+ (buffer-substring-no-properties beg end))))
+ (goto-char end)
+ ;; We must now drop the asterisks, unless quoted/escaped.
+ (with-temp-buffer
+ (insert cmd)
+ (goto-char (point-min))
+ (cl-loop
+ for next = (findbeg1 "\\(?:\\=\\|\\s-\\)\\(\\*[|<>]\\)" t)
+ while next do (forward-char -2) (delete-char 1))
+ (eshell-finish-arg
+ `(eshell-external-pipeline ,(buffer-string)))))))))))
(defun eshell-rewrite-external-pipeline (terms)
"Rewrite an external pipeline in TERMS as parsed by
diff --git a/lisp/eshell/em-glob.el b/lisp/eshell/em-glob.el
index 02f2fffe94f..7fc6958a00f 100644
--- a/lisp/eshell/em-glob.el
+++ b/lisp/eshell/em-glob.el
@@ -49,8 +49,9 @@
;;; Code:
+(require 'esh-arg)
+(require 'esh-module)
(require 'esh-util)
-(eval-when-compile (require 'eshell))
;;;###autoload
(progn
@@ -68,6 +69,15 @@ by zsh for filename generation."
:type 'hook
:group 'eshell-glob)
+(defcustom eshell-glob-splice-results nil
+ "If non-nil, the results of glob patterns will be spliced in-place.
+When splicing, the resulting command is as though the user typed
+each result individually. Otherwise, the glob results a single
+argument as a list."
+ :version "30.1"
+ :type 'boolean
+ :group 'eshell-glob)
+
(defcustom eshell-glob-include-dot-files nil
"If non-nil, glob patterns will match files beginning with a dot."
:type 'boolean
@@ -78,7 +88,7 @@ by zsh for filename generation."
:type 'boolean
:group 'eshell-glob)
-(defcustom eshell-glob-case-insensitive (eshell-under-windows-p)
+(defcustom eshell-glob-case-insensitive (not (not (eshell-under-windows-p)))
"If non-nil, glob pattern matching will ignore case."
:type 'boolean
:group 'eshell-glob)
@@ -138,23 +148,16 @@ This mimics the behavior of zsh if non-nil, but bash if nil."
(defun eshell-no-command-globbing (terms)
"Don't glob the command argument. Reflect this by modifying TERMS."
(ignore
- (when (and (listp (car terms))
- (eq (caar terms) 'eshell-extended-glob))
- (setcar terms (cadr (car terms))))))
+ (pcase (car terms)
+ ((or `(eshell-extended-glob ,term)
+ `(eshell-splice-args (eshell-extended-glob ,term)))
+ (setcar terms term)))))
(defun eshell-add-glob-modifier ()
"Add `eshell-extended-glob' to the argument modifier list."
- (when (memq 'expand-file-name eshell-current-modifiers)
- (setq eshell-current-modifiers
- (delq 'expand-file-name eshell-current-modifiers))
- ;; if this is a glob pattern than needs to be expanded, then it
- ;; will need to expand each member of the resulting glob list
- (add-to-list 'eshell-current-modifiers
- (lambda (list)
- (if (listp list)
- (mapcar 'expand-file-name list)
- (expand-file-name list)))))
- (add-to-list 'eshell-current-modifiers 'eshell-extended-glob))
+ (when eshell-glob-splice-results
+ (add-hook 'eshell-current-modifiers #'eshell-splice-args 99))
+ (add-hook 'eshell-current-modifiers #'eshell-extended-glob))
(defun eshell-parse-glob-chars ()
"Parse a globbing delimiter.
@@ -170,7 +173,7 @@ interpretation."
(end (eshell-find-delimiter
delim (if (eq delim ?\[) ?\] ?\)))))
(if (not end)
- (throw 'eshell-incomplete delim)
+ (throw 'eshell-incomplete (char-to-string delim))
(if (and (eshell-using-module 'eshell-pred)
(eshell-arg-delimiter (1+ end)))
(ignore (goto-char here))
@@ -187,6 +190,12 @@ interpretation."
'(("**/" . recurse)
("***/" . recurse-symlink)))
+(defsubst eshell-glob-chars-regexp ()
+ "Return the lazily-created value for `eshell-glob-chars-regexp'."
+ (or eshell-glob-chars-regexp
+ (setq-local eshell-glob-chars-regexp
+ (format "[%s]+" (apply 'string eshell-glob-chars-list)))))
+
(defun eshell-glob-regexp (pattern)
"Convert glob-pattern PATTERN to a regular expression.
The basic syntax is:
@@ -207,11 +216,8 @@ set to true, then these characters will match themselves in the
resulting regular expression."
(let ((matched-in-pattern 0) ; How much of PATTERN handled
regexp)
- (while (string-match
- (or eshell-glob-chars-regexp
- (setq-local eshell-glob-chars-regexp
- (format "[%s]+" (apply 'string eshell-glob-chars-list))))
- pattern matched-in-pattern)
+ (while (string-match (eshell-glob-chars-regexp)
+ pattern matched-in-pattern)
(let* ((op-begin (match-beginning 0))
(op-char (aref pattern op-begin)))
(setq regexp
@@ -236,6 +242,10 @@ resulting regular expression."
(regexp-quote (substring pattern matched-in-pattern))
"\\'")))
+(defun eshell-glob-p (pattern)
+ "Return non-nil if PATTERN has any special glob characters."
+ (string-match (eshell-glob-chars-regexp) pattern))
+
(defun eshell-glob-convert-1 (glob &optional last)
"Convert a GLOB matching a single element of a file name to regexps.
If LAST is non-nil, this glob is the last element of a file name.
@@ -288,14 +298,13 @@ The result is a list of three elements:
symlinks.
3. A boolean indicating whether to match directories only."
- (let ((globs (eshell-split-path glob))
- (isdir (eq (aref glob (1- (length glob))) ?/))
+ (let ((globs (eshell-split-filename glob))
+ (isdir (string-suffix-p "/" glob))
start-dir result last-saw-recursion)
(if (and (cdr globs)
(file-name-absolute-p (car globs)))
- (setq start-dir (car globs)
- globs (cdr globs))
- (setq start-dir "."))
+ (setq start-dir (pop globs))
+ (setq start-dir (file-name-as-directory ".")))
(while globs
(if-let ((recurse (cdr (assoc (car globs)
eshell-glob-recursive-alist))))
@@ -303,11 +312,15 @@ The result is a list of three elements:
(setcar result recurse)
(push recurse result)
(setq last-saw-recursion t))
- (push (eshell-glob-convert-1 (car globs) (null (cdr globs)))
- result)
+ (if (or result (eshell-glob-p (car globs)))
+ (push (eshell-glob-convert-1 (car globs) (null (cdr globs)))
+ result)
+ ;; We haven't seen a glob yet, so instead append to the start
+ ;; directory.
+ (setq start-dir (file-name-concat start-dir (car globs))))
(setq last-saw-recursion nil))
(setq globs (cdr globs)))
- (list (file-name-as-directory start-dir)
+ (list start-dir
(nreverse result)
isdir)))
@@ -335,7 +348,9 @@ regular expressions, and these cannot support the above constructs."
(or (and eshell-glob-matches (sort eshell-glob-matches #'string<))
(if eshell-error-if-no-glob
(error "No matches found: %s" glob)
- glob))))
+ (if eshell-glob-splice-results
+ (list glob)
+ glob)))))
;; FIXME does this really need to abuse eshell-glob-matches, message-shown?
(defun eshell-glob-entries (path globs only-dirs)
diff --git a/lisp/eshell/em-hist.el b/lisp/eshell/em-hist.el
index 4081f2a7f85..21029eae1bc 100644
--- a/lisp/eshell/em-hist.el
+++ b/lisp/eshell/em-hist.el
@@ -59,8 +59,6 @@
(require 'ring)
(require 'esh-opt)
(require 'esh-mode)
-(require 'em-pred)
-(require 'eshell)
;;;###autoload
(progn
@@ -82,6 +80,7 @@
(remove-hook 'kill-emacs-hook 'eshell-save-some-history)))
"A hook that gets run when `eshell-hist' is unloaded."
:type 'hook)
+(make-obsolete-variable 'eshell-hist-unload-hook nil "30.1")
(defcustom eshell-history-file-name
(expand-file-name "history" eshell-directory-name)
@@ -117,6 +116,12 @@ If set to t, history will always be saved, silently."
(const :tag "Ask" ask)
(const :tag "Always save" t)))
+(defcustom eshell-history-append nil
+ "If non-nil, append new entries to the history file when saving history."
+ :type '(choice (const :tag "Overwrite history file" nil)
+ (const :tag "Append new entries to file" t))
+ :version "30.1")
+
(defcustom eshell-input-filter 'eshell-input-filter-default
"Predicate for filtering additions to input history.
Takes one argument, the input. If non-nil, the input may be saved on
@@ -196,6 +201,9 @@ element, regardless of any text on the command line. In that case,
(defvar eshell-history-index nil)
(defvar eshell-matching-input-from-input-string "")
(defvar eshell-save-history-index nil)
+(defvar eshell-hist--new-items nil
+ "The number of new history items that have not been written to
+file. This variable is local in each eshell buffer.")
(defvar-keymap eshell-isearch-map
:doc "Keymap used in isearch in Eshell."
@@ -284,6 +292,7 @@ Returns nil if INPUT is prepended by blank space, otherwise non-nil."
(make-local-variable 'eshell-history-index)
(make-local-variable 'eshell-save-history-index)
+ (setq-local eshell-hist--new-items 0)
(if (minibuffer-window-active-p (selected-window))
(setq-local eshell-save-history-on-exit nil)
@@ -291,17 +300,21 @@ Returns nil if INPUT is prepended by blank space, otherwise non-nil."
(if eshell-history-file-name
(eshell-read-history nil t))
- (add-hook 'eshell-exit-hook #'eshell-write-history nil t))
+ (add-hook 'eshell-exit-hook #'eshell--save-history nil t))
(unless eshell-history-ring
(setq eshell-history-ring (make-ring eshell-history-size)))
- (add-hook 'eshell-exit-hook #'eshell-write-history nil t)
+ (add-hook 'eshell-exit-hook #'eshell--save-history nil t)
(add-hook 'kill-emacs-query-functions #'eshell-save-some-history)
(add-hook 'eshell-input-filter-functions #'eshell-add-to-history nil t))
+(defun eshell--save-history ()
+ "Save the history for current Eshell buffer."
+ (eshell-write-history nil eshell-history-append))
+
(defun eshell-save-some-history ()
"Save the history for any open Eshell buffers."
(dolist (buf (buffer-list))
@@ -315,7 +328,7 @@ Returns nil if INPUT is prepended by blank space, otherwise non-nil."
(format-message
"Save input history for Eshell buffer `%s'? "
(buffer-name buf)))))
- (eshell-write-history)))))
+ (eshell--save-history)))))
t)
(defun eshell/history (&rest args)
@@ -324,11 +337,11 @@ Returns nil if INPUT is prepended by blank space, otherwise non-nil."
(eshell-eval-using-options
"history" args
'((?r "read" nil read-history
- "read from history file to current history list")
+ "clear current history list and read from history file to it")
(?w "write" nil write-history
"write current history list to history file")
(?a "append" nil append-history
- "append current history list to history file")
+ "append new history in current buffer to history file")
(?h "help" nil nil "display this usage message")
:usage "[n] [-rwa [filename]]"
:post-usage
@@ -382,20 +395,21 @@ Input is entered into the input history ring, if the value of
variable `eshell-input-filter' returns non-nil when called on the
input."
(when (and (funcall eshell-input-filter input)
- (if (eq eshell-hist-ignoredups 'erase)
- ;; Remove any old occurrences of the input, and put
- ;; the new one at the end.
- (unless (ring-empty-p eshell-history-ring)
- (ring-remove eshell-history-ring
- (ring-member eshell-history-ring input))
- t)
- ;; Always add...
- (or (null eshell-hist-ignoredups)
- ;; ... or add if it's not already present at the
- ;; end.
- (not (ring-p eshell-history-ring))
- (ring-empty-p eshell-history-ring)
- (not (string-equal (eshell-get-history 0) input)))))
+ (pcase eshell-hist-ignoredups
+ ('nil t) ; Always add to history
+ ('erase ; Add, removing any old occurrences
+ (when-let ((old-index (ring-member eshell-history-ring input)))
+ ;; Remove the old occurrence of this input so we can
+ ;; add it to the end. FIXME: Should we try to
+ ;; remove multiple old occurrences, e.g. if the user
+ ;; recently changed to using `erase'?
+ (ring-remove eshell-history-ring old-index))
+ t)
+ (_ ; Add if not already the latest entry
+ (or (ring-empty-p eshell-history-ring)
+ (not (string-equal (eshell-get-history 0) input))))))
+ (setq eshell-hist--new-items
+ (min eshell-history-size (1+ eshell-hist--new-items)))
(eshell-put-history input))
(setq eshell-save-history-index eshell-history-index)
(setq eshell-history-index nil))
@@ -457,21 +471,30 @@ line, with the most recent command last. See also
(re-search-backward "^[ \t]*\\([^#\n].*\\)[ \t]*$"
nil t))
(let ((history (match-string 1)))
- (if (or (null ignore-dups)
- (ring-empty-p ring)
- (not (string-equal (ring-ref ring 0) history)))
- (ring-insert-at-beginning
- ring (subst-char-in-string ?\177 ?\n history))))
- (setq count (1+ count))))
+ (when (or (ring-empty-p ring)
+ (null ignore-dups)
+ (and (not (string-equal
+ (ring-ref ring (1- (ring-length ring)))
+ history))
+ (not (and (eq ignore-dups 'erase)
+ (ring-member ring history)))))
+ (ring-insert-at-beginning
+ ring (subst-char-in-string ?\177 ?\n history))
+ (setq count (1+ count))))))
(setq eshell-history-ring ring
- eshell-history-index nil))))))
+ eshell-history-index nil
+ eshell-hist--new-items 0))))))
(defun eshell-write-history (&optional filename append)
"Writes the buffer's `eshell-history-ring' to a history file.
-The name of the file is given by the variable
-`eshell-history-file-name'. The original contents of the file are
-lost if `eshell-history-ring' is not empty. If
-`eshell-history-file-name' is nil this function does nothing.
+If the optional argument FILENAME is nil, the value of
+`eshell-history-file-name' is used. This function does nothing
+if the value resolves to nil.
+
+If the optional argument APPEND is non-nil, then append new
+history items to the history file. Otherwise, overwrite the
+contents of the file with `eshell-history-ring' (so long as it is
+not empty).
Useful within process sentinels.
@@ -482,13 +505,14 @@ See also `eshell-read-history'."
((or (null file)
(equal file "")
(null eshell-history-ring)
- (ring-empty-p eshell-history-ring))
+ (ring-empty-p eshell-history-ring)
+ (and append (= eshell-hist--new-items 0)))
nil)
((not (file-writable-p resolved-file))
(message "Cannot write history file %s" resolved-file))
(t
(let* ((ring eshell-history-ring)
- (index (ring-length ring)))
+ (index (if append eshell-hist--new-items (ring-length ring))))
;; Write it all out into a buffer first. Much faster, but
;; messier, than writing it one line at a time.
(with-temp-buffer
@@ -501,7 +525,8 @@ See also `eshell-read-history'."
(subst-char-in-region start (1- (point)) ?\n ?\177)))
(eshell-with-private-file-modes
(write-region (point-min) (point-max) resolved-file append
- 'no-message))))))))
+ 'no-message)))
+ (setq eshell-hist--new-items 0))))))
(defun eshell-list-history ()
"List in help buffer the buffer's input history."
@@ -535,7 +560,7 @@ See also `eshell-read-history'."
(forward-line 3)
(while (search-backward "completion" nil 'move)
(replace-match "history reference")))
- (eshell-redisplay)
+ (redisplay)
(message "Hit space to flush")
(let ((ch (read-event)))
(if (eq ch ?\ )
@@ -555,7 +580,7 @@ See also `eshell-read-history'."
(defun eshell-hist-parse-arguments (&optional b e)
"Parse current command arguments in a history-code-friendly way."
(let ((end (or e (point)))
- (begin (or b (save-excursion (eshell-bol) (point))))
+ (begin (or b (save-excursion (beginning-of-line) (point))))
(posb (list t))
(pose (list t))
(textargs (list t))
@@ -769,6 +794,8 @@ matched."
(defun eshell-hist-parse-modifier (hist reference)
"Parse a history modifier beginning for HIST in REFERENCE."
+ (cl-assert (eshell-using-module 'em-pred))
+ (declare-function eshell-parse-modifiers "em-pred" ())
(let ((here (point)))
(insert reference)
(prog1
@@ -913,7 +940,7 @@ If N is negative, search forwards for the -Nth following match."
eshell-next-matching-input-from-input)))
;; Starting a new search
(setq eshell-matching-input-from-input-string
- (buffer-substring (save-excursion (eshell-bol) (point))
+ (buffer-substring (save-excursion (beginning-of-line) (point))
(point))
eshell-history-index nil))
(eshell-previous-matching-input
@@ -933,7 +960,7 @@ If N is negative, search backwards for the -Nth previous match."
(if (get-text-property (point) 'history)
(progn (beginning-of-line) t)
(let ((before (point)))
- (eshell-bol)
+ (beginning-of-line)
(if (and (not (bolp))
(<= (point) before))
t
@@ -1037,6 +1064,9 @@ If N is negative, search backwards for the -Nth previous match."
(isearch-done)
(eshell-send-input))
+(defun em-hist-unload-function ()
+ (remove-hook 'kill-emacs-hook 'eshell-save-some-history))
+
(provide 'em-hist)
;; Local Variables:
diff --git a/lisp/eshell/em-ls.el b/lisp/eshell/em-ls.el
index d99a050422b..fd89a9f778e 100644
--- a/lisp/eshell/em-ls.el
+++ b/lisp/eshell/em-ls.el
@@ -62,24 +62,27 @@ This is useful for enabling human-readable format (-h), for example."
This is useful for enabling human-readable format (-h), for example."
:type '(repeat :tag "Arguments" string))
+(defun eshell-ls-enable-in-dired ()
+ "Use `eshell-ls' to read directories in Dired."
+ (require 'dired)
+ (advice-add 'insert-directory :around #'eshell-ls--insert-directory)
+ (advice-add 'dired :around #'eshell-ls--dired))
+
+(defun eshell-ls-disable-in-dired ()
+ "Stop using `eshell-ls' to read directories in Dired."
+ (advice-remove 'insert-directory #'eshell-ls--insert-directory)
+ (advice-remove 'dired #'eshell-ls--dired))
+
(defcustom eshell-ls-use-in-dired nil
"If non-nil, use `eshell-ls' to read directories in Dired.
Changing this without using customize has no effect."
:set (lambda (symbol value)
- (cond (value
- (require 'dired)
- (advice-add 'insert-directory :around
- #'eshell-ls--insert-directory)
- (advice-add 'dired :around #'eshell-ls--dired))
- (t
- (advice-remove 'insert-directory
- #'eshell-ls--insert-directory)
- (advice-remove 'dired #'eshell-ls--dired)))
+ (if value
+ (eshell-ls-enable-in-dired)
+ (eshell-ls-disable-in-dired))
(set symbol value))
:type 'boolean
:require 'em-ls)
-(add-hook 'eshell-ls-unload-hook #'eshell-ls-unload-function)
-
(defcustom eshell-ls-default-blocksize 1024
"The default blocksize to use when display file sizes with -s."
@@ -196,9 +199,9 @@ calling FUNC with FILE as an argument."
`(let ((owner (file-attribute-user-id ,attrs))
(modes (file-attribute-modes ,attrs)))
(cond ((cond ((numberp owner)
- (= owner (user-uid)))
+ (= owner (file-user-uid)))
((stringp owner)
- (or (string-equal owner (user-login-name))
+ (or (string-equal owner (eshell-user-login-name))
(member owner (eshell-current-ange-uids)))))
;; The user owns this file.
(not (eq (aref modes ,index) ?-)))
@@ -271,11 +274,7 @@ instead."
;; use the fancy highlighting in `eshell-ls' rather than font-lock
(when eshell-ls-use-colors
(font-lock-mode -1)
- (setq font-lock-defaults nil)
- (if (boundp 'font-lock-buffers)
- (setq font-lock-buffers
- (delq (current-buffer)
- (symbol-value 'font-lock-buffers)))))
+ (setq font-lock-defaults nil))
(require 'em-glob)
(let* ((insert-func 'insert)
(error-func 'insert)
@@ -916,7 +915,7 @@ to use, and each member of which is the width of that column
((not (eshell-ls-filetype-p (cdr file) ?-))
'eshell-ls-special)
- ((and (/= (user-uid) 0) ; root can execute anything
+ ((and (/= (file-user-uid) 0) ; root can execute anything
(eshell-ls-applicable (cdr file) 3
'file-executable-p (car file)))
'eshell-ls-executable)
@@ -954,10 +953,8 @@ to use, and each member of which is the width of that column
(car file)))))
(car file))
-(defun eshell-ls-unload-function ()
- (advice-remove 'insert-directory #'eshell-ls--insert-directory)
- (advice-remove 'dired #'eshell-ls--dired)
- nil)
+(defun em-ls-unload-function ()
+ (eshell-ls-disable-in-dired))
(provide 'em-ls)
diff --git a/lisp/eshell/em-pred.el b/lisp/eshell/em-pred.el
index 00aa28b2d85..c3997dc72c3 100644
--- a/lisp/eshell/em-pred.el
+++ b/lisp/eshell/em-pred.el
@@ -87,11 +87,11 @@ ordinary strings."
(?U . (lambda (file) ; owned by effective uid
(if (file-exists-p file)
(= (file-attribute-user-id (file-attributes file))
- (user-uid)))))
+ (file-user-uid)))))
(?G . (lambda (file) ; owned by effective gid
(if (file-exists-p file)
(= (file-attribute-group-id (file-attributes file))
- (group-gid)))))
+ (file-group-gid)))))
(?* . (lambda (file)
(and (file-regular-p file)
(not (file-symlink-p file))
@@ -293,7 +293,7 @@ This function is specially for adding onto `eshell-parse-argument-hook'."
(forward-char)
(let ((end (eshell-find-delimiter ?\( ?\))))
(if (not end)
- (throw 'eshell-incomplete ?\()
+ (throw 'eshell-incomplete "(")
(when (eshell-arg-delimiter (1+ end))
(save-restriction
(narrow-to-region (point) end)
@@ -301,16 +301,15 @@ This function is specially for adding onto `eshell-parse-argument-hook'."
(modifiers (eshell-parse-modifiers))
(preds (car modifiers))
(mods (cdr modifiers)))
- (if (or preds mods)
- ;; has to go at the end, which is only natural since
- ;; syntactically it can only occur at the end
- (setq eshell-current-modifiers
- (append
- eshell-current-modifiers
- (list
- (lambda (lst)
- (eshell-apply-modifiers
- lst preds mods modifier-string))))))))
+ (when (or preds mods)
+ ;; Has to go near the end (but before
+ ;; `eshell-splice-args'), which is only natural since
+ ;; syntactically it can only occur at the end.
+ (add-hook 'eshell-current-modifiers
+ (lambda (lst)
+ (eshell-apply-modifiers
+ lst preds mods modifier-string))
+ 90))))
(goto-char (1+ end))
(eshell-finish-arg))))))
diff --git a/lisp/eshell/em-prompt.el b/lisp/eshell/em-prompt.el
index cf71bb2986e..3662c1fa895 100644
--- a/lisp/eshell/em-prompt.el
+++ b/lisp/eshell/em-prompt.el
@@ -27,7 +27,7 @@
;;; Code:
(require 'esh-mode)
-(eval-when-compile (require 'eshell))
+(require 'text-property-search)
;;;###autoload
(progn
@@ -50,21 +50,18 @@ as is common with most shells."
(defcustom eshell-prompt-function
(lambda ()
(concat (abbreviate-file-name (eshell/pwd))
- (if (= (user-uid) 0) " # " " $ ")))
- "A function that returns the Eshell prompt string.
-Make sure to update `eshell-prompt-regexp' so that it will match your
-prompt."
+ (unless (eshell-exit-success-p)
+ (format " [%d]" eshell-last-command-status))
+ (if (= (file-user-uid) 0) " # " " $ ")))
+ "A function that returns the Eshell prompt string."
:type 'function
:group 'eshell-prompt)
(defcustom eshell-prompt-regexp "^[^#$\n]* [#$] "
- "A regexp which fully matches your eshell prompt.
-This setting is important, since it affects how eshell will interpret
-the lines that are passed to it.
-If this variable is changed, all Eshell buffers must be exited and
-re-entered for it to take effect."
+ "A regexp which fully matches your Eshell prompt."
:type 'regexp
:group 'eshell-prompt)
+(make-obsolete-variable 'eshell-prompt-regexp nil "30.1")
(defcustom eshell-highlight-prompt t
"If non-nil, Eshell should highlight the prompt."
@@ -97,8 +94,10 @@ arriving, or after."
:group 'eshell-prompt)
(defvar-keymap eshell-prompt-mode-map
- "C-c C-n" #'eshell-next-prompt
- "C-c C-p" #'eshell-previous-prompt)
+ "C-c C-n" #'eshell-next-prompt
+ "C-c C-p" #'eshell-previous-prompt
+ "<remap> <forward-paragraph>" #'eshell-forward-paragraph
+ "<remap> <backward-paragraph>" #'eshell-backward-paragraph)
(defvar-keymap eshell-prompt-repeat-map
:doc "Keymap to repeat eshell-prompt key sequences. Used in `repeat-mode'."
@@ -118,12 +117,6 @@ arriving, or after."
"Initialize the prompting code."
(unless eshell-non-interactive-p
(add-hook 'eshell-post-command-hook 'eshell-emit-prompt nil t)
-
- (make-local-variable 'eshell-prompt-regexp)
- (if eshell-prompt-regexp
- (setq-local paragraph-start eshell-prompt-regexp))
-
- (setq-local eshell-skip-prompt-function #'eshell-skip-prompt)
(eshell-prompt-mode)))
(defun eshell-emit-prompt ()
@@ -134,72 +127,109 @@ arriving, or after."
(if (not eshell-prompt-function)
(set-marker eshell-last-output-end (point))
(let ((prompt (funcall eshell-prompt-function)))
- (and eshell-highlight-prompt
- (add-text-properties 0 (length prompt)
- '(read-only t
- font-lock-face eshell-prompt
- front-sticky (font-lock-face read-only)
- rear-nonsticky (font-lock-face read-only))
- prompt))
- (eshell-interactive-print prompt)))
+ (add-text-properties
+ 0 (length prompt)
+ (if eshell-highlight-prompt
+ '( read-only t
+ field prompt
+ font-lock-face eshell-prompt
+ front-sticky (read-only field font-lock-face)
+ rear-nonsticky (read-only field font-lock-face))
+ '( field prompt
+ front-sticky (field)
+ rear-nonsticky (field)))
+ prompt)
+ (eshell-interactive-filter nil prompt)))
(run-hooks 'eshell-after-prompt-hook))
+(defun eshell-forward-matching-input (regexp arg)
+ "Search forward through buffer for command input that matches REGEXP.
+With prefix argument N, search for Nth next match. If N is
+negative, find the Nth previous match."
+ (interactive (eshell-regexp-arg "Forward input matching (regexp): "))
+ (let ((direction (if (> arg 0) 1 -1))
+ (count (abs arg)))
+ (unless (catch 'found
+ (while (> count 0)
+ (eshell-next-prompt direction)
+ (when (and (string-match regexp (field-string))
+ (= (setq count (1- count)) 0))
+ (throw 'found t))))
+ (message "Not found")
+ (ding))))
+
(defun eshell-backward-matching-input (regexp arg)
- "Search backward through buffer for match for REGEXP.
-Matches are searched for on lines that match `eshell-prompt-regexp'.
-With prefix argument N, search for Nth previous match.
-If N is negative, find the next or Nth next match."
+ "Search backward through buffer for command input that matches REGEXP.
+With prefix argument N, search for Nth previous match. If N is
+negative, find the Nth next match."
(interactive (eshell-regexp-arg "Backward input matching (regexp): "))
- (let* ((re (concat eshell-prompt-regexp ".*" regexp))
- (pos (save-excursion (end-of-line (if (> arg 0) 0 1))
- (if (re-search-backward re nil t arg)
- (point)))))
- (if (null pos)
- (progn (message "Not found")
- (ding))
- (goto-char pos)
- (eshell-bol))))
+ (eshell-forward-matching-input regexp (- arg)))
-(defun eshell-forward-matching-input (regexp arg)
- "Search forward through buffer for match for REGEXP.
-Matches are searched for on lines that match `eshell-prompt-regexp'.
-With prefix argument N, search for Nth following match.
-If N is negative, find the previous or Nth previous match."
- (interactive (eshell-regexp-arg "Forward input matching (regexp): "))
- (eshell-backward-matching-input regexp (- arg)))
+(defun eshell-forward-paragraph (&optional n)
+ "Move to the beginning of the Nth next prompt in the buffer.
+Like `forward-paragraph', but navigates using fields."
+ (interactive "p")
+ (eshell-next-prompt n)
+ (goto-char (field-beginning (point) t)))
-(defun eshell-next-prompt (n)
- "Move to end of Nth next prompt in the buffer.
-See `eshell-prompt-regexp'."
+(defun eshell-backward-paragraph (&optional n)
+ "Move to the beginning of the Nth previous prompt in the buffer.
+Like `backward-paragraph', but navigates using fields."
(interactive "p")
- (if eshell-highlight-prompt
- (progn
- (while (< n 0)
- (while (and (re-search-backward eshell-prompt-regexp nil t)
- (not (get-text-property (match-beginning 0) 'read-only))))
- (setq n (1+ n)))
- (while (> n 0)
- (while (and (re-search-forward eshell-prompt-regexp nil t)
- (not (get-text-property (match-beginning 0) 'read-only))))
- (setq n (1- n))))
- (re-search-forward eshell-prompt-regexp nil t n))
- (eshell-skip-prompt))
-
-(defun eshell-previous-prompt (n)
- "Move to end of Nth previous prompt in the buffer.
-See `eshell-prompt-regexp'."
+ (eshell-previous-prompt n)
+ (goto-char (field-beginning (point) t)))
+
+(defun eshell-next-prompt (&optional n)
+ "Move to end of Nth next prompt in the buffer."
(interactive "p")
- (forward-line 0) ; Don't count prompt on current line.
- (eshell-next-prompt (- n)))
+ (unless n (setq n 1))
+ ;; First, move point to our starting position: the end of the
+ ;; current prompt (aka the beginning of the input), if any. (The
+ ;; welcome message and output from commands don't count as having a
+ ;; current prompt.)
+ (pcase (get-text-property (point) 'field)
+ ('command-output)
+ ('prompt (goto-char (field-end)))
+ (_ (when-let ((match (text-property-search-backward 'field 'prompt t)))
+ (goto-char (prop-match-end match)))))
+ ;; Now, move forward/backward to our destination prompt.
+ (if (natnump n)
+ (while (and (> n 0)
+ (text-property-search-forward 'field 'prompt t))
+ (setq n (1- n)))
+ (let (match this-match)
+ ;; Go to the beginning of the current prompt.
+ (goto-char (field-beginning (point) t))
+ (while (and (< n 0)
+ (setq this-match (text-property-search-backward
+ 'field 'prompt t)))
+ (setq match this-match
+ n (1+ n)))
+ (when match
+ (goto-char (prop-match-end match))))))
+
+(defun eshell-previous-prompt (&optional n)
+ "Move to end of Nth previous prompt in the buffer."
+ (interactive "p")
+ (eshell-next-prompt (- (or n 1))))
(defun eshell-skip-prompt ()
"Skip past the text matching regexp `eshell-prompt-regexp'.
If this takes us past the end of the current line, don't skip at all."
+ (declare (obsolete nil "30.1"))
(let ((eol (line-end-position)))
(if (and (looking-at eshell-prompt-regexp)
(<= (match-end 0) eol))
(goto-char (match-end 0)))))
+(defun eshell-bol-ignoring-prompt (arg)
+ "Move point to the beginning of the current line, past the prompt (if any).
+With argument ARG not nil or 1, move forward ARG - 1 lines
+first (see `move-beginning-of-line' for more information)."
+ (interactive "^p")
+ (let ((inhibit-field-text-motion t))
+ (move-beginning-of-line arg)))
+
(provide 'em-prompt)
;; Local Variables:
diff --git a/lisp/eshell/em-rebind.el b/lisp/eshell/em-rebind.el
index fbff8c11950..c6ee1a329b6 100644
--- a/lisp/eshell/em-rebind.el
+++ b/lisp/eshell/em-rebind.el
@@ -24,20 +24,22 @@
;;; Code:
(require 'esh-mode)
-(eval-when-compile (require 'eshell))
;;;###autoload
(progn
(defgroup eshell-rebind nil
"This module allows for special keybindings that only take effect
-while the point is in a region of input text. By default, it binds
-C-a to move to the beginning of the input text (rather than just the
-beginning of the line), and C-p and C-n to move through the input
-history, C-u kills the current input text, etc. It also, if
-`eshell-confine-point-to-input' is non-nil, does not allow certain
-commands to cause the point to leave the input area, such as
-`backward-word', `previous-line', etc. This module intends to mimic
-the behavior of normal shells while the user editing new input text."
+while the point is in a region of input text. The default
+keybindings mimic the bindings used in other shells when the user
+is editing new input text.
+
+For example, it binds C-u to kill the current input text and C-w
+to `backward-kill-word'. If the history module is enabled, it
+also binds C-p and C-n to move through the input history, etc.
+
+If `eshell-confine-point-to-input' is non-nil, this module prevents
+certain commands from causing the point to leave the input area, such
+as `backward-word', `previous-line', etc."
:tag "Rebind keys at input"
:group 'eshell-module))
@@ -50,9 +52,7 @@ the behavior of normal shells while the user editing new input text."
:group 'eshell-rebind)
(defcustom eshell-rebind-keys-alist
- '(([(control ?a)] . eshell-bol)
- ([home] . eshell-bol)
- ([(control ?d)] . eshell-delchar-or-maybe-eof)
+ '(([(control ?d)] . eshell-delchar-or-maybe-eof)
([backspace] . eshell-delete-backward-char)
([delete] . eshell-delete-backward-char)
([(control ?w)] . backward-kill-word)
@@ -190,7 +190,7 @@ lock it at that."
(and eshell-remap-previous-input
(setq begin
(save-excursion
- (eshell-bol)
+ (beginning-of-line)
(and (not (bolp)) (point))))
(>= pos begin)
(<= pos (line-end-position))
diff --git a/lisp/eshell/em-script.el b/lisp/eshell/em-script.el
index a32954491f2..066063c4cc2 100644
--- a/lisp/eshell/em-script.el
+++ b/lisp/eshell/em-script.el
@@ -89,26 +89,18 @@ This includes when running `eshell-command'."
(defun eshell-source-file (file &optional args subcommand-p)
"Execute a series of Eshell commands in FILE, passing ARGS.
Comments begin with `#'."
- (let ((orig (point))
- (here (point-max)))
- (goto-char (point-max))
- (with-silent-modifications
- ;; FIXME: Why not use a temporary buffer and avoid this
- ;; "insert&delete" business? --Stef
- (insert-file-contents file)
- (goto-char (point-max))
- (throw 'eshell-replace-command
- (prog1
- (list 'let
- (list (list 'eshell-command-name (list 'quote file))
- (list 'eshell-command-arguments
- (list 'quote args)))
- (let ((cmd (eshell-parse-command (cons here (point)))))
- (if subcommand-p
- (setq cmd (list 'eshell-as-subcommand cmd)))
- cmd))
- (delete-region here (point))
- (goto-char orig))))))
+ (let ((cmd (eshell-parse-command `(:file . ,file))))
+ (when subcommand-p
+ (setq cmd `(eshell-as-subcommand ,cmd)))
+ (throw 'eshell-replace-command
+ `(let ((eshell-command-name ',file)
+ (eshell-command-arguments ',args)
+ ;; Don't print subjob messages by default.
+ ;; Otherwise, if this function was called as a
+ ;; subjob, then *all* commands in the script would
+ ;; print start/stop messages.
+ (eshell-subjob-messages nil))
+ ,cmd))))
(defun eshell/source (&rest args)
"Source a file in a subshell environment."
diff --git a/lisp/eshell/em-smart.el b/lisp/eshell/em-smart.el
index d0da8615cd4..91fe02e5545 100644
--- a/lisp/eshell/em-smart.el
+++ b/lisp/eshell/em-smart.el
@@ -69,7 +69,6 @@
;;; Code:
(require 'esh-mode)
-(eval-when-compile (require 'eshell))
;;;###autoload
(progn
@@ -96,10 +95,11 @@ it to get a real sense of how it works."
(list
(lambda ()
(remove-hook 'window-configuration-change-hook
- 'eshell-refresh-windows)))
+ 'eshell-smart-scroll)))
"A hook that gets run when `eshell-smart' is unloaded."
:type 'hook
:group 'eshell-smart)
+(make-obsolete-variable 'eshell-smart-unload-hook nil "30.1")
(defcustom eshell-review-quick-commands nil
"If t, always review commands.
@@ -159,9 +159,7 @@ The options are `begin', `after' or `end'."
;;; Internal Variables:
-(defvar eshell-smart-displayed nil)
(defvar eshell-smart-command-done nil)
-(defvar eshell-currently-handling-window nil)
;;; Functions:
@@ -174,10 +172,9 @@ The options are `begin', `after' or `end'."
(setq-local eshell-scroll-to-bottom-on-input nil)
(setq-local eshell-scroll-show-maximum-output t)
- (add-hook 'window-scroll-functions 'eshell-smart-scroll-window nil t)
- (add-hook 'window-configuration-change-hook 'eshell-refresh-windows)
+ (add-hook 'window-configuration-change-hook 'eshell-smart-scroll nil t)
- (add-hook 'eshell-output-filter-functions 'eshell-refresh-windows t t)
+ (add-hook 'eshell-output-filter-functions 'eshell-smart-scroll-windows 90 t)
(add-hook 'after-change-functions 'eshell-disable-after-change nil t)
@@ -193,28 +190,15 @@ The options are `begin', `after' or `end'."
(add-hook 'eshell-post-command-hook
'eshell-smart-maybe-jump-to-end nil t))))
-;; This is called by window-scroll-functions with two arguments.
-(defun eshell-smart-scroll-window (wind _start)
- "Scroll the given Eshell window WIND accordingly."
- (unless eshell-currently-handling-window
- (let ((eshell-currently-handling-window t))
- (with-selected-window wind
- (eshell-smart-redisplay)))))
-
-(defun eshell-refresh-windows (&optional frame)
- "Refresh all visible Eshell buffers."
- (let (affected)
- (walk-windows
- (lambda (wind)
- (with-current-buffer (window-buffer wind)
- (if eshell-mode
- (let (window-scroll-functions) ;;FIXME: Why?
- (eshell-smart-scroll-window wind (window-start))
- (setq affected t)))))
- 0 frame)
- (if affected
- (let (window-scroll-functions) ;;FIXME: Why?
- (eshell-redisplay)))))
+(defun eshell-smart-scroll-windows ()
+ "Scroll all eshell windows to display as much output as possible, smartly."
+ (walk-windows
+ (lambda (wind)
+ (with-current-buffer (window-buffer wind)
+ (if eshell-mode
+ (with-selected-window wind
+ (eshell-smart-scroll)))))
+ 0 t))
(defun eshell-smart-display-setup ()
"Set the point to somewhere in the beginning of the last command."
@@ -231,8 +215,7 @@ The options are `begin', `after' or `end'."
(t
(error "Invalid value for `eshell-where-to-jump'")))
(setq eshell-smart-command-done nil)
- (add-hook 'pre-command-hook 'eshell-smart-display-move nil t)
- (eshell-refresh-windows))
+ (add-hook 'pre-command-hook 'eshell-smart-display-move nil t))
;; Called from after-change-functions with 3 arguments.
(defun eshell-disable-after-change (_b _e _l)
@@ -254,28 +237,22 @@ and the end of the buffer are still visible."
(goto-char (point-max))
(remove-hook 'pre-command-hook 'eshell-smart-display-move t)))
-(defun eshell-smart-redisplay ()
- "Display as much output as possible, smartly."
- (if (eobp)
+(defun eshell-smart-scroll ()
+ "Scroll WINDOW to display as much output as possible, smartly."
+ (let ((top-point (point)))
+ (and (memq 'eshell-smart-display-move pre-command-hook)
+ (>= (point) eshell-last-input-start)
+ (< (point) eshell-last-input-end)
+ (set-window-start (selected-window)
+ (pos-bol) t))
+ (when (pos-visible-in-window-p (point-max) (selected-window))
(save-excursion
- (recenter -1)
- ;; trigger the redisplay now, so that we catch any attempted
- ;; point motion; this is to cover for a redisplay bug
- (eshell-redisplay))
- (let ((top-point (point)))
- (and (memq 'eshell-smart-display-move pre-command-hook)
- (>= (point) eshell-last-input-start)
- (< (point) eshell-last-input-end)
- (set-window-start (selected-window)
- (line-beginning-position) t))
- (if (pos-visible-in-window-p (point-max))
- (save-excursion
- (goto-char (point-max))
- (recenter -1)
- (unless (pos-visible-in-window-p top-point)
- (goto-char top-point)
- (set-window-start (selected-window)
- (line-beginning-position) t)))))))
+ (goto-char (point-max))
+ (recenter -1)
+ (unless (pos-visible-in-window-p top-point (selected-window))
+ (goto-char top-point)
+ (set-window-start (selected-window)
+ (pos-bol) t))))))
(defun eshell-smart-goto-end ()
"Like `end-of-buffer', but do not push a mark."
@@ -294,7 +271,7 @@ and the end of the buffer are still visible."
((eq this-command 'self-insert-command)
(if (eq last-command-event ? )
(if (and eshell-smart-space-goes-to-end
- eshell-current-command)
+ eshell-foreground-command)
(if (not (pos-visible-in-window-p (point-max)))
(setq this-command 'scroll-up)
(setq this-command 'eshell-smart-goto-end))
@@ -322,6 +299,9 @@ and the end of the buffer are still visible."
(if clear
(remove-hook 'pre-command-hook 'eshell-smart-display-move t))))
+(defun em-smart-unload-hook ()
+ (remove-hook 'window-configuration-change-hook #'eshell-smart-scroll))
+
(provide 'em-smart)
;; Local Variables:
diff --git a/lisp/eshell/em-term.el b/lisp/eshell/em-term.el
index 47beb79c294..8f29e2d8509 100644
--- a/lisp/eshell/em-term.el
+++ b/lisp/eshell/em-term.el
@@ -34,7 +34,6 @@
(require 'cl-lib)
(require 'esh-util)
(require 'esh-ext)
-(eval-when-compile (require 'eshell))
(require 'term)
;;;###autoload
@@ -56,10 +55,11 @@ which commands are considered visual in nature."
:type 'hook)
(defcustom eshell-visual-commands
- '("vi" "vim" ; what is going on??
+ '("vi" "vim" "nvim" ; what is going on??
"screen" "tmux" "top" "htop" ; ok, a valid program...
"less" "more" ; M-x view-file
"lynx" "links" "ncftp" ; eww, ange-ftp
+ "ncmpcpp" ; M-x mpc
"mutt" "pine" "tin" "trn" "elm") ; GNUS!!
"A list of commands that present their output in a visual fashion.
@@ -67,7 +67,7 @@ Commands listed here are run in a term buffer.
See also `eshell-visual-subcommands' and `eshell-visual-options'."
:type '(repeat string)
- :version "29.1")
+ :version "30.1")
(defcustom eshell-visual-subcommands
nil
diff --git a/lisp/eshell/em-tramp.el b/lisp/eshell/em-tramp.el
index 6da14fdfe7e..efb37225651 100644
--- a/lisp/eshell/em-tramp.el
+++ b/lisp/eshell/em-tramp.el
@@ -29,8 +29,7 @@
(require 'esh-cmd)
(eval-when-compile
- (require 'esh-mode)
- (require 'eshell))
+ (require 'esh-mode))
(require 'tramp)
@@ -122,12 +121,11 @@ Uses the system sudo through Tramp's sudo method."
:usage "[(-u | --user) USER] (-s | --shell) | COMMAND
Execute a COMMAND as the superuser or another USER.")
(let ((dir (eshell--method-wrap-directory default-directory "sudo" user)))
- (if shell
- (throw 'eshell-replace-command
- (eshell-parse-command "cd" (list dir)))
- (throw 'eshell-external
- (let ((default-directory dir))
- (eshell-named-command (car args) (cdr args))))))))
+ (throw 'eshell-replace-command
+ (if shell
+ (eshell-parse-command "cd" (list dir))
+ `(let ((default-directory ,dir))
+ (eshell-named-command ',(car args) ',(cdr args))))))))
(put 'eshell/sudo 'eshell-no-numeric-conversions t)
@@ -145,12 +143,11 @@ Uses the system doas through Tramp's doas method."
:usage "[(-u | --user) USER] (-s | --shell) | COMMAND
Execute a COMMAND as the superuser or another USER.")
(let ((dir (eshell--method-wrap-directory default-directory "doas" user)))
- (if shell
- (throw 'eshell-replace-command
- (eshell-parse-command "cd" (list dir)))
- (throw 'eshell-external
- (let ((default-directory dir))
- (eshell-named-command (car args) (cdr args))))))))
+ (throw 'eshell-replace-command
+ (if shell
+ (eshell-parse-command "cd" (list dir))
+ `(let ((default-directory ,dir))
+ (eshell-named-command ',(car args) ',(cdr args))))))))
(put 'eshell/doas 'eshell-no-numeric-conversions t)
diff --git a/lisp/eshell/em-unix.el b/lisp/eshell/em-unix.el
index 7c19a3e9759..751f13cc715 100644
--- a/lisp/eshell/em-unix.el
+++ b/lisp/eshell/em-unix.el
@@ -91,14 +91,29 @@ Otherwise, `rmdir' is required."
:type 'boolean
:group 'eshell-unix)
-(defcustom eshell-rm-interactive-query (= (user-uid) 0)
- "If non-nil, `rm' will query before removing anything."
- :type 'boolean
+(define-widget 'eshell-interactive-query 'radio
+ "When to interactively query the user about a particular operation.
+If t, always query. If nil, never query. If `root', query when
+the user is logged in as root (including when `default-directory'
+is remote with a root user)."
+ :args '((const :tag "Never" nil)
+ (const :tag "Always" t)
+ (const :tag "When root" root)))
+
+(defcustom eshell-rm-interactive-query 'root
+ "When `rm' should query before removing anything.
+If t, always query. If nil, never query. If `root', query when
+the user is logged in as root (including when `default-directory'
+is remote with a root user)."
+ :type 'eshell-interactive-query
:group 'eshell-unix)
-(defcustom eshell-mv-interactive-query (= (user-uid) 0)
- "If non-nil, `mv' will query before overwriting anything."
- :type 'boolean
+(defcustom eshell-mv-interactive-query 'root
+ "When `mv' should query before overwriting anything.
+If t, always query. If nil, never query. If `root', query when
+the user is logged in as root (including when `default-directory'
+is remote with a root user)."
+ :type 'eshell-interactive-query
:group 'eshell-unix)
(defcustom eshell-mv-overwrite-files t
@@ -106,9 +121,12 @@ Otherwise, `rmdir' is required."
:type 'boolean
:group 'eshell-unix)
-(defcustom eshell-cp-interactive-query (= (user-uid) 0)
- "If non-nil, `cp' will query before overwriting anything."
- :type 'boolean
+(defcustom eshell-cp-interactive-query 'root
+ "When `cp' should query before overwriting anything.
+If t, always query. If nil, never query. If `root', query when
+the user is logged in as root (including when `default-directory'
+is remote with a root user)."
+ :type 'eshell-interactive-query
:group 'eshell-unix)
(defcustom eshell-cp-overwrite-files t
@@ -116,9 +134,12 @@ Otherwise, `rmdir' is required."
:type 'boolean
:group 'eshell-unix)
-(defcustom eshell-ln-interactive-query (= (user-uid) 0)
- "If non-nil, `ln' will query before overwriting anything."
- :type 'boolean
+(defcustom eshell-ln-interactive-query 'root
+ "When `ln' should query before overwriting anything.
+If t, always query. If nil, never query. If `root', query when
+the user is logged in as root (including when `default-directory'
+is remote with a root user)."
+ :type 'eshell-interactive-query
:group 'eshell-unix)
(defcustom eshell-ln-overwrite-files nil
@@ -145,9 +166,10 @@ Otherwise, Emacs will attempt to use rsh to invoke du on the remote machine."
(add-hook 'pcomplete-try-first-hook
'eshell-complete-host-reference nil t))
(setq-local eshell-complex-commands
- (append '("grep" "egrep" "fgrep" "agrep" "glimpse" "locate"
- "cat" "time" "cp" "mv" "make" "du" "diff")
- eshell-complex-commands)))
+ (append '("compile" "grep" "egrep" "fgrep" "agrep"
+ "rgrep" "glimpse" "locate" "cat" "time" "cp"
+ "mv" "make" "du" "diff")
+ eshell-complex-commands)))
(defalias 'eshell/date 'current-time-string)
(defalias 'eshell/basename 'file-name-nondirectory)
@@ -158,6 +180,17 @@ Otherwise, Emacs will attempt to use rsh to invoke du on the remote machine."
(defvar em-recursive)
(defvar em-verbose)
+(defun eshell-interactive-query-p (value)
+ "Return non-nil if a command should query the user according to VALUE.
+If VALUE is nil, return nil (never query). If `root', return
+non-nil if the user is logged in as root (including when
+`default-directory' is remote with a root user; see
+`file-user-uid'). If VALUE is any other non-nil value, return
+non-nil (always query)."
+ (if (eq value 'root)
+ (= (file-user-uid) 0)
+ value))
+
(defun eshell/man (&rest args)
"Invoke man, flattening the arguments appropriately."
(funcall 'man (apply 'eshell-flatten-and-stringify args)))
@@ -248,7 +281,8 @@ argument."
:usage "[OPTION]... FILE...
Remove (unlink) the FILE(s).")
(unless em-interactive
- (setq em-interactive eshell-rm-interactive-query))
+ (setq em-interactive (eshell-interactive-query-p
+ eshell-rm-interactive-query)))
(if (and force-removal em-interactive)
(setq em-interactive nil))
(while args
@@ -522,7 +556,8 @@ Rename SOURCE to DEST, or move SOURCE(s) to DIRECTORY.
[OPTION] DIRECTORY...")
(let ((no-dereference t))
(eshell-mvcpln-template "mv" "moving" 'rename-file
- eshell-mv-interactive-query
+ (eshell-interactive-query-p
+ eshell-mv-interactive-query)
eshell-mv-overwrite-files))))
(put 'eshell/mv 'eshell-no-numeric-conversions t)
@@ -555,12 +590,13 @@ Rename SOURCE to DEST, or move SOURCE(s) to DIRECTORY.
:external "cp"
:show-usage
:usage "[OPTION]... SOURCE DEST
- or: cp [OPTION]... SOURCE... DIRECTORY
+ or: cp [OPTION]... SOURCE... DIRECTORY
Copy SOURCE to DEST, or multiple SOURCE(s) to DIRECTORY.")
(if archive
(setq preserve t no-dereference t em-recursive t))
(eshell-mvcpln-template "cp" "copying" 'copy-file
- eshell-cp-interactive-query
+ (eshell-interactive-query-p
+ eshell-cp-interactive-query)
eshell-cp-overwrite-files preserve)))
(put 'eshell/cp 'eshell-no-numeric-conversions t)
@@ -582,18 +618,19 @@ Copy SOURCE to DEST, or multiple SOURCE(s) to DIRECTORY.")
:preserve-args
:external "ln"
:show-usage
- :usage "[OPTION]... TARGET [LINK_NAME]
- or: ln [OPTION]... TARGET... DIRECTORY
-Create a link to the specified TARGET with optional LINK_NAME. If there is
-more than one TARGET, the last argument must be a directory; create links
-in DIRECTORY to each TARGET. Create hard links by default, symbolic links
+ :usage "[OPTION]... TARGET LINK_NAME
+ or: ln [OPTION]... TARGET... DIRECTORY
+Create a link to the specified TARGET with LINK_NAME. If there is more
+than one TARGET, the last argument must be a directory; create links in
+DIRECTORY to each TARGET. Create hard links by default, symbolic links
with `--symbolic'. When creating hard links, each TARGET must exist.")
(let ((no-dereference t))
(eshell-mvcpln-template "ln" "linking"
(if symbolic
'make-symbolic-link
'add-name-to-file)
- eshell-ln-interactive-query
+ (eshell-interactive-query-p
+ eshell-ln-interactive-query)
eshell-ln-overwrite-files))))
(put 'eshell/ln 'eshell-no-numeric-conversions t)
@@ -655,19 +692,56 @@ Concatenate FILE(s), or standard input, to standard output.")
;; special front-end functions for compilation-mode buffers
+(defun eshell-compile (command args &optional method mode)
+ "Run an external COMMAND with ARGS using a compilation buffer when possible.
+COMMAND should be a list of command-line arguments. By default,
+if the command is outputting to the screen and is not part of a
+pipeline or subcommand, open an compilation buffer to hold the
+results; otherwise, write the output on stdout.
+
+If METHOD is `interactive', always open a compilation buffer. If
+METHOD is `plain', always write to stdout.
+
+MODE, if specified, is the major mode to set in the compilation
+buffer (see `compilation-start')."
+ (if (and (not (eq method 'interactive))
+ (or (eq method 'plain)
+ eshell-in-pipeline-p
+ eshell-in-subcommand-p
+ (not (eshell-interactive-output-p))))
+ (throw 'eshell-replace-command
+ (eshell-parse-command (concat "*" command) args))
+ (compile
+ (mapconcat #'shell-quote-argument
+ (eshell-stringify-list (flatten-tree (cons command args)))
+ " ")
+ mode)))
+
+(defun eshell/compile (&rest args)
+ "Run an external COMMAND using a compilation buffer when possible.
+See `eshell-compile'."
+ (eshell-eval-using-options
+ "compile" args
+ '((?m "mode" t mode "the mode to set in the compilation buffer")
+ (?i "interactive" 'interactive method "always open a compilation buffer")
+ (?p "plain" 'plain method "always write to stdout")
+ :usage "[-p | -i] [-m MODE] COMMAND...
+Run COMMAND in a compilation buffer when outputting to the screen and
+not part of a pipeline or subcommand."
+ :parse-leading-options-only)
+ (when (stringp mode)
+ (setq mode (intern mode)))
+ (eshell-compile (car args) (cdr args) method mode)))
+
+(put 'eshell/compile 'eshell-no-numeric-conversions t)
+
(defun eshell/make (&rest args)
"Use `compile' to do background makes.
Fallback to standard make when called synchronously."
- (if (and eshell-current-subjob-p
- (eshell-interactive-output-p))
- (let ((compilation-process-setup-function
- (list 'lambda nil
- (list 'setq 'process-environment
- (list 'quote (eshell-copy-environment))))))
- (compile (concat "make " (eshell-flatten-and-stringify args))))
- (throw 'eshell-replace-command
- (eshell-parse-command "*make" (eshell-stringify-list
- (flatten-tree args))))))
+ (eshell-compile "make" args
+ ;; Use plain output unless we're executing in the
+ ;; background.
+ (unless eshell-current-subjob-p 'plain)))
(put 'eshell/make 'eshell-no-numeric-conversions t)
@@ -715,7 +789,7 @@ available..."
(ignore-errors
(occur (car args))))
(if (get-buffer "*Occur*")
- (with-current-buffer (get-buffer "*Occur*")
+ (with-current-buffer "*Occur*"
(setq string (buffer-string))
(kill-buffer (current-buffer)))))
(if string (insert string))
@@ -740,22 +814,10 @@ and if it's not part of a command pipeline. Otherwise, it calls the
external command."
(if (and maybe-use-occur eshell-no-grep-available)
(eshell-poor-mans-grep args)
- (if (or eshell-plain-grep-behavior
- (not (and (eshell-interactive-output-p)
- (not eshell-in-pipeline-p)
- (not eshell-in-subcommand-p))))
- (throw 'eshell-replace-command
- (eshell-parse-command (concat "*" command)
- (eshell-stringify-list
- (flatten-tree args))))
- (let* ((args (mapconcat 'identity
- (mapcar 'shell-quote-argument
- (eshell-stringify-list
- (flatten-tree args)))
- " "))
- (cmd (format "%s -n %s" command args))
- compilation-scroll-output)
- (grep cmd)))))
+ (eshell-compile command (cons "-n" args)
+ (and eshell-plain-grep-behavior
+ 'interactive)
+ #'grep-mode)))
(defun eshell/grep (&rest args)
"Use Emacs grep facility instead of calling external grep."
@@ -773,10 +835,13 @@ external command."
"Use Emacs grep facility instead of calling external agrep."
(eshell-grep "agrep" args))
+(defun eshell/rgrep (&rest args)
+ "Use Emacs grep facility instead of calling external rgrep."
+ (eshell-grep "grep" (append '("-rH") args) t))
+
(defun eshell/glimpse (&rest args)
"Use Emacs grep facility instead of calling external glimpse."
- (let (null-device)
- (eshell-grep "glimpse" (append '("-z" "-y") args))))
+ (eshell-grep "glimpse" (append '("-z" "-y") args)))
;; completions rules for some common UNIX commands
@@ -786,10 +851,14 @@ external command."
(defun eshell-complete-host-reference ()
"If there is a host reference, complete it."
- (let ((arg (pcomplete-actual-arg))
- index)
- (when (setq index (string-match "@[a-z.]*\\'" arg))
- (setq pcomplete-stub (substring arg (1+ index))
+ (let ((arg (pcomplete-actual-arg)))
+ (when (string-match
+ (rx ;; Match an "@", but not immediately following a "$".
+ (or string-start (not "$")) "@"
+ (group (* (any "a-z.")))
+ string-end)
+ arg)
+ (setq pcomplete-stub (substring arg (match-beginning 1))
pcomplete-last-completion-raw t)
(throw 'pcomplete-completions (pcomplete-read-host-names)))))
@@ -871,7 +940,7 @@ external command."
"display data only this many levels of data")
(?h "human-readable" 1024 human-readable
"print sizes in human readable format")
- (?H "is" 1000 human-readable
+ (?H "si" 1000 human-readable
"likewise, but use powers of 1000 not 1024")
(?k "kilobytes" 1024 block-size
"like --block-size 1024")
@@ -949,17 +1018,9 @@ Show wall-clock time elapsed during execution of COMMAND.")
(eshell-stringify-list
(flatten-tree (cdr time-args))))))))
-(defun eshell/whoami (&rest _args)
+(defun eshell/whoami ()
"Make \"whoami\" Tramp aware."
- (or (file-remote-p default-directory 'user) (user-login-name)))
-
-(defvar eshell-diff-window-config nil)
-
-(defun eshell-diff-quit ()
- "Restore the window configuration previous to diff'ing."
- (interactive)
- (if eshell-diff-window-config
- (set-window-configuration eshell-diff-window-config)))
+ (eshell-user-login-name))
(defun eshell-nil-blank-string (string)
"Return STRING, or nil if STRING contains only blank characters."
@@ -983,8 +1044,7 @@ Show wall-clock time elapsed during execution of COMMAND.")
(throw 'eshell-replace-command
(eshell-parse-command "*diff" orig-args)))
(let ((old (car (last args 2)))
- (new (car (last args)))
- (config (current-window-configuration)))
+ (new (car (last args))))
(if (= (length args) 2)
(setq args nil)
(setcdr (last args 3) nil))
@@ -996,18 +1056,6 @@ Show wall-clock time elapsed during execution of COMMAND.")
(error
(throw 'eshell-replace-command
(eshell-parse-command "*diff" orig-args))))
- (when (fboundp 'diff-mode)
- (add-hook
- 'compilation-finish-functions
- (lambda (buff _msg)
- (with-current-buffer buff
- (diff-mode)
- (setq-local eshell-diff-window-config config)
- (local-set-key [?q] #'eshell-diff-quit)
- (if (fboundp 'turn-on-font-lock-if-enabled)
- (turn-on-font-lock-if-enabled))
- (goto-char (point-min))))
- nil t))
(pop-to-buffer (current-buffer))))))
nil)
@@ -1043,6 +1091,9 @@ Show wall-clock time elapsed during execution of COMMAND.")
(put 'eshell/occur 'eshell-no-numeric-conversions t)
(define-obsolete-function-alias 'nil-blank-string #'eshell-nil-blank-string "29.1")
+(defvar eshell-diff-window-config nil)
+(make-obsolete-variable 'eshell-diff-window-config "no longer used." "30.1")
+(define-obsolete-function-alias 'eshell-diff-quit #'ignore "30.1")
(provide 'em-unix)
diff --git a/lisp/eshell/em-xtra.el b/lisp/eshell/em-xtra.el
index 9c27ef3b8d9..a62073e2183 100644
--- a/lisp/eshell/em-xtra.el
+++ b/lisp/eshell/em-xtra.el
@@ -25,8 +25,6 @@
(require 'cl-lib)
(require 'esh-util)
-(eval-when-compile
- (require 'eshell))
;; There are no items in this custom group, but eshell modules (ab)use
;; custom groups.
diff --git a/lisp/eshell/esh-arg.el b/lisp/eshell/esh-arg.el
index 637bde93235..78cf28d785a 100644
--- a/lisp/eshell/esh-arg.el
+++ b/lisp/eshell/esh-arg.el
@@ -28,6 +28,9 @@
;;; Code:
(require 'esh-util)
+(require 'esh-module)
+
+(require 'pcomplete)
(eval-when-compile
(require 'cl-lib))
@@ -46,6 +49,8 @@ yield the values intended."
(defvar eshell-arg-listified nil)
(defvar eshell-nested-argument nil)
(defvar eshell-current-quoted nil)
+(defvar eshell-current-argument-plain nil
+ "If non-nil, the current argument is \"plain\", and not part of a command.")
(defvar eshell-inside-quote-regexp nil)
(defvar eshell-outside-quote-regexp nil)
@@ -160,6 +165,43 @@ treated as a literal character."
:type 'hook
:group 'eshell-arg)
+(defvar eshell-special-ref-alist
+ '(("buffer"
+ (creation-function eshell-get-buffer)
+ (insertion-function eshell-insert-buffer-name)
+ (completion-function eshell-complete-buffer-ref))
+ ("marker"
+ (creation-function eshell-get-marker)
+ (insertion-function eshell-insert-marker)
+ (completion-function eshell-complete-marker-ref)))
+ "Alist of special reference types for Eshell.
+Each entry is a list of the form (TYPE (KEY VALUE)...). TYPE is
+the name of the special reference type, and each KEY/VALUE pair
+represents a parameter for the type. Eshell defines the
+following KEYs:
+
+* `creation-function'
+ A function taking any number of arguments that returns the Lisp
+ object for this special ref type.
+
+* `insertion-function'
+ An interactive function that returns the special reference in
+ string form. This string should look like \"#<TYPE ARG...>\";
+ Eshell will pass the ARGs to `creation-function'.
+
+* `completion-function'
+ A function using Pcomplete to perform completion on any
+ arguments necessary for creating this special reference type.")
+
+(defcustom eshell-special-ref-default "buffer"
+ "The default type for special references when the type keyword is omitted.
+This should be a key in `eshell-special-ref-alist' (which see).
+Eshell will expand special refs like \"#<ARG...>\" into
+\"#<`eshell-special-ref-default' ARG...>\"."
+ :version "30.1"
+ :type 'string
+ :group 'eshell-arg)
+
(defvar-keymap eshell-arg-mode-map
"C-c M-b" #'eshell-insert-buffer-name)
@@ -175,12 +217,11 @@ treated as a literal character."
"Initialize the argument parsing code."
(eshell-arg-mode)
(setq-local eshell-inside-quote-regexp nil)
- (setq-local eshell-outside-quote-regexp nil))
+ (setq-local eshell-outside-quote-regexp nil)
-(defun eshell-insert-buffer-name (buffer-name)
- "Insert BUFFER-NAME into the current buffer at point."
- (interactive "BName of buffer: ")
- (insert-and-inherit "#<buffer " buffer-name ">"))
+ (when (eshell-using-module 'eshell-cmpl)
+ (add-hook 'pcomplete-try-first-hook
+ #'eshell-complete-special-reference nil t)))
(defsubst eshell-escape-arg (string)
"Return STRING with the `escaped' property on it."
@@ -238,18 +279,61 @@ convert the result to a number as well."
(eshell-convert-to-number result)
result)))
+(defun eshell-concat-groups (quoted &rest args)
+ "Concatenate groups of arguments in ARGS and return the result.
+QUOTED is passed to `eshell-concat' (which see) and, if non-nil,
+allows values to be converted to numbers where appropriate.
+
+ARGS should be a list of lists of arguments, such as that
+produced by `eshell-prepare-splice'. \"Adjacent\" values of
+consecutive arguments will be passed to `eshell-concat'. For
+example, if ARGS is
+
+ ((list a) (list b) (list c d e) (list f g)),
+
+then the result will be:
+
+ ((eshell-concat QUOTED a b c)
+ d
+ (eshell-concat QUOTED e f)
+ g)."
+ (let (result current-arg)
+ (dolist (arg args)
+ (when arg
+ (push (car arg) current-arg)
+ (when (length> arg 1)
+ (push (apply #'eshell-concat quoted (nreverse current-arg))
+ result)
+ (dolist (inner (butlast (cdr arg)))
+ (push inner result))
+ (setq current-arg (list (car (last arg)))))))
+ (when current-arg
+ (push (apply #'eshell-concat quoted (nreverse current-arg))
+ result))
+ (nreverse 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
- (setq eshell-current-argument
- (append (list 'eshell-concat eshell-current-quoted)
- eshell-current-argument))
+ (if-let ((grouped-terms (eshell-prepare-splice
+ eshell-current-argument)))
+ (setq eshell-current-argument
+ `(eshell-splice-args
+ (eshell-concat-groups ,eshell-current-quoted
+ ,@grouped-terms)))
+ ;; If no terms are spliced, use a simpler command form.
+ (setq eshell-current-argument
+ (append (list 'eshell-concat eshell-current-quoted)
+ eshell-current-argument)))
(setq eshell-arg-listified nil))
- (while eshell-current-modifiers
+ (when eshell-current-modifiers
+ (eshell-debug-command 'form
+ "applying modifiers %S\n\n%s" eshell-current-modifiers
+ (eshell-stringify eshell-current-argument)))
+ (dolist (modifier eshell-current-modifiers)
(setq eshell-current-argument
- (list (car eshell-current-modifiers) eshell-current-argument)
- eshell-current-modifiers (cdr eshell-current-modifiers))))
+ (list modifier eshell-current-argument))))
(setq eshell-current-modifiers nil))
(defun eshell-finish-arg (&rest arguments)
@@ -261,7 +345,8 @@ argument list in place of the value of the current argument."
(setq eshell-current-argument (car arguments))
(cl-assert (and (not eshell-arg-listified)
(not eshell-current-modifiers)))
- (setq eshell-current-argument (cons 'eshell-flatten-args arguments))))
+ (setq eshell-current-argument
+ (cons 'eshell-splice-immediately arguments))))
(throw 'eshell-arg-done t))
(defun eshell-quote-argument (string)
@@ -302,7 +387,8 @@ Point is left at the end of the arguments."
(buffer-substring here (point-max))))
(when arg
(nconc args
- (if (eq (car-safe arg) 'eshell-flatten-args)
+ (if (eq (car-safe arg)
+ 'eshell-splice-immediately)
(cdr arg)
(list arg))))))))
(throw 'eshell-incomplete (if (listp delim)
@@ -348,8 +434,13 @@ Point is left at the end of the arguments."
"A stub function that generates an error if a floating operator is found."
(error "Unhandled operator in input text"))
+(defsubst eshell-splice-args (&rest _args)
+ "A stub function that generates an error if a floating splice is found."
+ (error "Splice operator is not permitted in this context"))
+
(defsubst eshell-looking-at-backslash-return (pos)
"Test whether a backslash-return sequence occurs at POS."
+ (declare (obsolete nil "30.1"))
(and (eq (char-after pos) ?\\)
(or (= (1+ pos) (point-max))
(and (eq (char-after (1+ pos)) ?\n)
@@ -374,30 +465,34 @@ backslash is ignored and the character after is returned. If the
backslash is in a quoted string, the backslash and the character
after are both returned."
(when (eq (char-after) ?\\)
- (when (eshell-looking-at-backslash-return (point))
- (throw 'eshell-incomplete ?\\))
+ (when (= (1+ (point)) (point-max))
+ (throw 'eshell-incomplete "\\"))
(forward-char 2) ; Move one char past the backslash.
- (if (eq (char-before) ?\n)
- ;; Escaped newlines are extra-special: they expand to an empty
- ;; token to allow for continuing Eshell commands across
- ;; multiple lines.
- 'eshell-empty-token
- ;; If the char is in a quote, backslash only has special meaning
- ;; if it is escaping a special char.
- (if eshell-current-quoted
- (if (memq (char-before) eshell-special-chars-inside-quoting)
- (list 'eshell-escape-arg (char-to-string (char-before)))
- (concat "\\" (char-to-string (char-before))))
- (if (memq (char-before) eshell-special-chars-outside-quoting)
- (list 'eshell-escape-arg (char-to-string (char-before)))
- (char-to-string (char-before)))))))
+ (let ((special-chars (if eshell-current-quoted
+ eshell-special-chars-inside-quoting
+ eshell-special-chars-outside-quoting)))
+ (cond
+ ;; Escaped newlines are extra-special: they expand to an empty
+ ;; token to allow for continuing Eshell commands across
+ ;; multiple lines.
+ ((eq (char-before) ?\n)
+ 'eshell-empty-token)
+ ((memq (char-before) special-chars)
+ (list 'eshell-escape-arg (char-to-string (char-before))))
+ ;; If the char is in a quote, backslash only has special
+ ;; meaning if it is escaping a special char. Otherwise, the
+ ;; result is the literal string "\c".
+ (eshell-current-quoted
+ (concat "\\" (char-to-string (char-before))))
+ (t
+ (char-to-string (char-before)))))))
(defun eshell-parse-literal-quote ()
"Parse a literally quoted string. Nothing has special meaning!"
(if (eq (char-after) ?\')
(let ((end (eshell-find-delimiter ?\' ?\')))
(if (not end)
- (throw 'eshell-incomplete ?\')
+ (throw 'eshell-incomplete "'")
(let ((string (buffer-substring-no-properties (1+ (point)) end)))
(goto-char (1+ end))
(while (string-match "''" string)
@@ -410,7 +505,7 @@ after are both returned."
(let* ((end (eshell-find-delimiter ?\" ?\" nil nil t))
(eshell-current-quoted t))
(if (not end)
- (throw 'eshell-incomplete ?\")
+ (throw 'eshell-incomplete "\"")
(prog1
(save-restriction
(forward-char)
@@ -445,39 +540,10 @@ leaves point where it was."
(goto-char bound)
(apply #'concat (nreverse strings))))))
-(defun eshell-parse-special-reference ()
- "Parse a special syntax reference, of the form `#<args>'.
-
-args := `type' `whitespace' `arbitrary-args' | `arbitrary-args'
-type := \"buffer\" or \"process\"
-arbitrary-args := any string of characters.
-
-If the form has no `type', the syntax is parsed as if `type' were
-\"buffer\"."
- (when (and (not eshell-current-argument)
- (not eshell-current-quoted)
- (looking-at "#<\\(\\(buffer\\|process\\)\\s-\\)?"))
- (let ((here (point)))
- (goto-char (match-end 0)) ;; Go to the end of the match.
- (let ((buffer-p (if (match-string 1)
- (string= (match-string 2) "buffer")
- t)) ;; buffer-p is non-nil by default.
- (end (eshell-find-delimiter ?\< ?\>)))
- (when (not end)
- (throw 'eshell-incomplete ?\<))
- (if (eshell-arg-delimiter (1+ end))
- (prog1
- (list (if buffer-p 'get-buffer-create 'get-process)
- (replace-regexp-in-string
- (rx "\\" (group (or "\\" "<" ">"))) "\\1"
- (buffer-substring-no-properties (point) end)))
- (goto-char (1+ end)))
- (ignore (goto-char here)))))))
-
(defun eshell-parse-delimiter ()
"Parse an argument delimiter, which is essentially a command operator."
;; this `eshell-operator' keyword gets parsed out by
- ;; `eshell-separate-commands'. Right now the only possibility for
+ ;; `eshell-split-commands'. Right now the only possibility for
;; error is an incorrect output redirection specifier.
(when (looking-at "[&|;\n]\\s-*")
(let ((end (match-end 0)))
@@ -496,5 +562,186 @@ If the form has no `type', the syntax is parsed as if `type' were
(char-to-string (char-after)))))
(goto-char end)))))))
+(defun eshell-prepare-splice (args)
+ "Prepare a list of ARGS for splicing, if any arg requested a splice.
+This looks for `eshell-splice-args' as the CAR of each argument,
+and if found, returns a grouped list like:
+
+ ((list arg-1) (list arg-2) spliced-arg-3 ...)
+
+This allows callers of this function to build the final spliced
+list by concatenating each element together, e.g. with
+
+ (apply #\\='append grouped-list)
+
+If no argument requested a splice, return nil."
+ (let* ((splicep nil)
+ ;; Group each arg like ((list arg-1) (list arg-2) ...),
+ ;; splicing in `eshell-splice-args' args. This lets us
+ ;; apply spliced args correctly elsewhere.
+ (grouped-args
+ (mapcar (lambda (i)
+ (if (eq (car-safe i) 'eshell-splice-args)
+ (progn
+ (setq splicep t)
+ (cadr i))
+ `(list ,i)))
+ args)))
+ (when splicep
+ grouped-args)))
+
+;;; Special references
+
+(defsubst eshell--special-ref-function (type function)
+ "Get the specified FUNCTION for a particular special ref TYPE.
+If TYPE is nil, get the FUNCTION for the `eshell-special-ref-default'."
+ (cadr (assq function (assoc (or type eshell-special-ref-default)
+ eshell-special-ref-alist))))
+
+(defun eshell-parse-special-reference ()
+ "Parse a special syntax reference, of the form `#<args>'.
+
+args := `type' `whitespace' `arbitrary-args' | `arbitrary-args'
+type := one of the keys in `eshell-special-ref-alist'
+arbitrary-args := any number of Eshell arguments
+
+If the form has no `type', the syntax is parsed as if `type' were
+`eshell-special-ref-default'."
+ (let ((here (point))
+ (special-ref-types (mapcar #'car eshell-special-ref-alist)))
+ (when (and (not eshell-current-argument)
+ (not eshell-current-quoted)
+ (looking-at (rx-to-string
+ `(seq "#<" (? (group (or ,@special-ref-types))
+ (+ space)))
+ t)))
+ (goto-char (match-end 0)) ; Go to the end of the match.
+ (let ((end (eshell-find-delimiter ?\< ?\>))
+ (creation-fun (eshell--special-ref-function
+ (match-string 1) 'creation-function)))
+ (unless end
+ (when (match-beginning 1)
+ (goto-char (match-beginning 1)))
+ (throw 'eshell-incomplete "#<"))
+ (if (eshell-arg-delimiter (1+ end))
+ (prog1
+ (cons creation-fun
+ (let ((eshell-current-argument-plain t))
+ (eshell-parse-arguments (point) end)))
+ (goto-char (1+ end)))
+ (ignore (goto-char here)))))))
+
+(defun eshell-insert-special-reference (type &rest args)
+ "Insert a special reference of the specified TYPE.
+ARGS is a list of arguments to pass to the insertion function for
+TYPE (see `eshell-special-ref-alist')."
+ (interactive
+ (let* ((type (completing-read
+ (format-prompt "Type" eshell-special-ref-default)
+ (mapcar #'car eshell-special-ref-alist)
+ nil 'require-match nil nil eshell-special-ref-default))
+ (insertion-fun (eshell--special-ref-function
+ type 'insertion-function)))
+ (list :interactive (call-interactively insertion-fun))))
+ (if (eq type :interactive)
+ (car args)
+ (apply (eshell--special-ref-function type 'insertion-function) args)))
+
+(defun eshell-complete-special-reference ()
+ "If there is a special reference, complete it."
+ (when (string-prefix-p "#<" (pcomplete-actual-arg))
+ (let ((special-ref-types (mapcar #'car eshell-special-ref-alist))
+ num-args explicit-type)
+ ;; When finished with completion, add a trailing ">" when
+ ;; appropriate.
+ (add-function
+ :around (var pcomplete-exit-function)
+ (lambda (oldfun value status)
+ (when (eq status 'finished)
+ ;; Don't count the special reference type (e.g. "buffer").
+ (when (or explicit-type
+ (and (= num-args 1)
+ (member value special-ref-types)))
+ (setq num-args (1- num-args)))
+ (let ((creation-fun (eshell--special-ref-function
+ explicit-type 'creation-function)))
+ ;; Check if we already have the maximum number of
+ ;; arguments for this special ref type. If so, finish
+ ;; the ref with ">". Otherwise, insert a space and set
+ ;; the completion status to `sole'.
+ (if (eq (cdr (func-arity creation-fun)) num-args)
+ (if (looking-at ">")
+ (goto-char (match-end 0))
+ (insert ">"))
+ (pcomplete-default-exit-function value status)
+ (setq status 'sole))
+ (funcall oldfun value status)))))
+ ;; Parse the arguments to this special reference and call the
+ ;; appropriate completion function.
+ (save-excursion
+ (eshell-with-temp-command (cons (+ 2 (pcomplete-begin)) (point))
+ (goto-char (point-max))
+ (let (pcomplete-args pcomplete-last pcomplete-index pcomplete-begins)
+ (when (let ((eshell-current-argument-plain t))
+ (pcomplete-parse-arguments
+ pcomplete-expand-before-complete))
+ (setq num-args (length pcomplete-args))
+ (if (= pcomplete-index pcomplete-last)
+ ;; Call the default special ref completion function,
+ ;; and also add the known special ref types as
+ ;; possible completions.
+ (throw 'pcomplete-completions
+ (nconc
+ (mapcar #'car eshell-special-ref-alist)
+ (catch 'pcomplete-completions
+ (funcall (eshell--special-ref-function
+ nil 'completion-function)))))
+ ;; Get the special ref type and call its completion
+ ;; function.
+ (let ((first (pcomplete-arg 'first)))
+ (when (member first special-ref-types)
+ ;; "Complete" the ref type (which we already
+ ;; completed above).
+ (pcomplete-here)
+ (setq explicit-type first)))
+ (funcall (eshell--special-ref-function
+ explicit-type 'completion-function))))))))))
+
+(defun eshell-get-buffer (buffer-or-name)
+ "Return the buffer specified by BUFFER-OR-NAME, creating a new one if needed.
+This is equivalent to `get-buffer-create', but only accepts a
+single argument."
+ (get-buffer-create buffer-or-name))
+
+(defun eshell-insert-buffer-name (buffer-name)
+ "Insert BUFFER-NAME into the current buffer at point."
+ (interactive "BName of buffer: ")
+ (insert-and-inherit "#<buffer " (eshell-quote-argument buffer-name) ">"))
+
+(defun eshell-complete-buffer-ref ()
+ "Perform completion for buffer references."
+ (pcomplete-here (mapcar #'buffer-name (buffer-list))))
+
+(defun eshell-get-marker (position buffer-or-name)
+ "Return the marker for character number POSITION in BUFFER-OR-NAME.
+BUFFER-OR-NAME can be a buffer or a string. If a string and a
+live buffer with that name exists, use that buffer. If no such
+buffer exists, create a new buffer with that name and use it."
+ (let ((marker (make-marker)))
+ (set-marker marker (string-to-number position)
+ (get-buffer-create buffer-or-name))))
+
+(defun eshell-insert-marker (position buffer-name)
+ "Insert a marker into the current buffer at point.
+This marker will point to POSITION in BUFFER-NAME."
+ (interactive "nPosition: \nBName of buffer: ")
+ (insert-and-inherit "#<marker " (number-to-string position) " "
+ (eshell-quote-argument buffer-name) ">"))
+
+(defun eshell-complete-marker-ref ()
+ "Perform completion for marker references."
+ (pcomplete-here)
+ (pcomplete-here (mapcar #'buffer-name (buffer-list))))
+
(provide 'esh-arg)
;;; esh-arg.el ends here
diff --git a/lisp/eshell/esh-cmd.el b/lisp/eshell/esh-cmd.el
index 319ee6b79b3..30494bafb48 100644
--- a/lisp/eshell/esh-cmd.el
+++ b/lisp/eshell/esh-cmd.el
@@ -237,17 +237,6 @@ return non-nil if the command is complex."
:version "24.1" ; removed eshell-cmd-initialize
:type 'hook)
-(defcustom eshell-debug-command nil
- "If non-nil, enable Eshell debugging code.
-This is slow, and only useful for debugging problems with Eshell.
-If you change this without using customize after Eshell has loaded,
-you must re-load `esh-cmd.el'."
- :initialize 'custom-initialize-default
- :set (lambda (symbol value)
- (set symbol value)
- (load "esh-cmd"))
- :type 'boolean)
-
(defcustom eshell-deferrable-commands
'(eshell-named-command
eshell-lisp-command
@@ -274,7 +263,24 @@ command line.")
;;; Internal Variables:
-(defvar eshell-current-command nil)
+;; These variables have been merged into `eshell-foreground-command'.
+;; Outside of this file, the most-common use for them is to check
+;; whether they're nil.
+(define-obsolete-variable-alias 'eshell-last-async-procs
+ 'eshell-foreground-command "30.1")
+(define-obsolete-variable-alias 'eshell-current-command
+ 'eshell-foreground-command "30.1")
+
+(defvar eshell-foreground-command nil
+ "The currently-running foreground command, if any.
+This is a list of the form (FORM PROCESSES). FORM is the Eshell
+command form. PROCESSES is a list of processes that deferred the
+command.")
+(defvar eshell-background-commands nil
+ "A list of currently-running deferred commands.
+Each element is of the form (FORM PROCESSES), as with
+`eshell-foreground-command' (which see).")
+
(defvar eshell-command-name nil)
(defvar eshell-command-arguments nil)
(defvar eshell-in-pipeline-p nil
@@ -284,55 +290,48 @@ otherwise t.")
(defvar eshell-in-subcommand-p nil)
(defvar eshell-last-arguments nil)
(defvar eshell-last-command-name nil)
-(defvar eshell-last-async-procs nil
- "The currently-running foreground process(es).
-When executing a pipeline, this is a cons cell whose CAR is the
-first process (usually reading from stdin) and whose CDR is the
-last process (usually writing to stdout). Otherwise, the CAR and
-CDR are the same process.
-When the process in the CDR completes, resume command evaluation.")
+(defvar eshell-allow-commands t
+ "If non-nil, allow evaluating command forms (including Lisp forms).
+If you want to forbid command forms, you can let-bind this to a
+non-nil value before calling `eshell-do-eval'. Then, any command
+forms will signal `eshell-commands-forbidden'. This is useful
+if, for example, you want to evaluate simple expressions like
+variable expansions, but not fully-evaluate the command. See
+also `eshell-complete-parse-arguments'.")
+
+(define-error 'eshell-commands-forbidden "Commands forbidden")
;;; Functions:
(defsubst eshell-interactive-process-p ()
"Return non-nil if there is a currently running command process."
- eshell-last-async-procs)
+ (declare (obsolete 'eshell-foreground-command "30.1"))
+ eshell-foreground-command)
(defsubst eshell-head-process ()
"Return the currently running process at the head of any pipeline.
This only returns external (non-Lisp) processes."
- (car-safe eshell-last-async-procs))
+ (caadr eshell-foreground-command))
(defsubst eshell-tail-process ()
"Return the currently running process at the tail of any pipeline.
This only returns external (non-Lisp) processes."
- (cdr-safe eshell-last-async-procs))
+ (car (last (cadr eshell-foreground-command))))
(define-obsolete-function-alias 'eshell-interactive-process
'eshell-tail-process "29.1")
(defun eshell-cmd-initialize () ;Called from `eshell-mode' via intern-soft!
"Initialize the Eshell command processing module."
- (setq-local eshell-current-command nil)
+ (setq-local eshell-foreground-command nil)
+ (setq-local eshell-background-commands nil)
(setq-local eshell-command-name nil)
(setq-local eshell-command-arguments nil)
(setq-local eshell-last-arguments nil)
(setq-local eshell-last-command-name nil)
- (setq-local eshell-last-async-procs nil)
(add-hook 'eshell-kill-hook #'eshell-resume-command nil t)
-
- ;; make sure that if a command is over, and no process is being
- ;; waited for, that `eshell-current-command' is set to nil. This
- ;; situation can occur, for example, if a Lisp function results in
- ;; `debug' being called, and the user then types \\[top-level]
- (add-hook 'eshell-post-command-hook
- (lambda ()
- (setq eshell-current-command nil
- eshell-last-async-procs nil))
- nil t)
-
(add-hook 'eshell-parse-argument-hook
#'eshell-parse-subcommand-argument nil t)
(add-hook 'eshell-parse-argument-hook
@@ -343,7 +342,7 @@ This only returns external (non-Lisp) processes."
#'eshell-complete-lisp-symbols nil t)))
(defun eshell-complete-lisp-symbols ()
- "If there is a user reference, complete it."
+ "If there is a Lisp symbol, complete it."
(let ((arg (pcomplete-actual-arg)))
(when (string-match (concat "\\`" eshell-lisp-regexp) arg)
(setq pcomplete-stub (substring arg (match-end 0))
@@ -351,99 +350,97 @@ This only returns external (non-Lisp) processes."
(throw 'pcomplete-completions
(all-completions pcomplete-stub obarray 'boundp)))))
-;; Command parsing
+;; Current command management
+
+(defun eshell-add-command (form &optional background)
+ "Add a command FORM to our list of known commands and return the new entry.
+If non-nil, BACKGROUND indicates that this is a command running
+in the background. The result is a command entry in the
+form (BACKGROUND FORM PROCESSES), where PROCESSES is initially
+nil."
+ (cons (when background 'background)
+ (if background
+ (car (push (list form nil) eshell-background-commands))
+ (cl-assert (null eshell-foreground-command))
+ (setq eshell-foreground-command (list form nil)))))
+
+(defun eshell-remove-command (command)
+ "Remove COMMAND from our list of known commands.
+COMMAND should be a list of the form (BACKGROUND FORM PROCESSES),
+as returned by `eshell-add-command' (which see)."
+ (let ((background (car command))
+ (entry (cdr command)))
+ (if background
+ (setq eshell-background-commands
+ (delq entry eshell-background-commands))
+ (cl-assert (eq eshell-foreground-command entry))
+ (setq eshell-foreground-command nil))))
+
+(defun eshell-commands-for-process (process)
+ "Return all commands associated with a PROCESS.
+Each element will have the form (BACKGROUND FORM PROCESSES), as
+returned by `eshell-add-command' (which see).
+
+Usually, there should only be one element in this list, but it's
+theoretically possible to have more than one associated command
+for a given process."
+ (nconc (when (memq process (cadr eshell-foreground-command))
+ (list (cons nil eshell-foreground-command)))
+ (seq-keep (lambda (cmd)
+ (when (memq process (cadr cmd))
+ (cons 'background cmd)))
+ eshell-background-commands)))
-(defvar eshell--sep-terms)
-
-(defmacro eshell-with-temp-command (region &rest body)
- "Narrow the buffer to REGION and execute the forms in BODY.
-
-REGION is a cons cell (START . END) that specifies the region to
-which to narrow the buffer. REGION can also be a string, in
-which case the macro temporarily inserts it into the buffer at
-point, and narrows the buffer to the inserted string. Before
-executing BODY, point is set to the beginning of the narrowed
-REGION.
-
-The value returned is the last form in BODY."
- (declare (indent 1))
- `(let ((reg ,region))
- (if (stringp reg)
- ;; Since parsing relies partly on buffer-local state
- ;; (e.g. that of `eshell-parse-argument-hook'), we need to
- ;; perform the parsing in the Eshell buffer.
- (let ((begin (point)) end)
- (with-silent-modifications
- (insert reg)
- (setq end (point))
- (unwind-protect
- (save-restriction
- (narrow-to-region begin end)
- (goto-char begin)
- ,@body)
- (delete-region begin end))))
- (save-restriction
- (narrow-to-region (car reg) (cdr reg))
- (goto-char (car reg))
- ,@body))))
+;; Command parsing
(defun eshell-parse-command (command &optional args toplevel)
"Parse the COMMAND, adding ARGS if given.
-COMMAND can either be a string, or a cons cell demarcating a buffer
-region. TOPLEVEL, if non-nil, means that the outermost command (the
-user's input command) is being parsed, and that pre and post command
-hooks should be run before and after the command."
- (let* (eshell--sep-terms
- (terms
- (append
- (if (consp command)
- (eshell-parse-arguments (car command) (cdr command))
- (eshell-with-temp-command command
- (goto-char (point-max))
- (eshell-parse-arguments (point-min) (point-max))))
- args))
- (commands
- (mapcar
- (lambda (cmd)
- (setq cmd
- (if (or (not (car eshell--sep-terms))
- (string= (car eshell--sep-terms) ";"))
- (eshell-parse-pipeline cmd)
- `(eshell-do-subjob
- (list ,(eshell-parse-pipeline cmd)))))
- (setq eshell--sep-terms (cdr eshell--sep-terms))
- (if eshell-in-pipeline-p
- cmd
- `(eshell-trap-errors ,cmd)))
- (eshell-separate-commands terms "[&;]" nil 'eshell--sep-terms))))
- (let ((cmd commands))
- (while cmd
- (if (cdr cmd)
- (setcar cmd `(eshell-commands ,(car cmd))))
- (setq cmd (cdr cmd))))
+COMMAND can be a string, a cons cell (START . END) demarcating a
+buffer region, or (:file . FILENAME) to parse the contents of
+FILENAME.
+
+TOPLEVEL, if non-nil, means that the outermost command (the
+user's input command) is being parsed, and that pre and post
+command hooks should be run before and after the command."
+ (pcase-let*
+ ((terms
+ (append
+ (if (eshell--region-p command)
+ (eshell-parse-arguments (car command) (cdr command))
+ (eshell-with-temp-command command
+ (goto-char (point-max))
+ (eshell-parse-arguments (point-min) (point-max))))
+ args))
+ (`(,sub-chains . ,sep-terms)
+ (eshell-split-commands terms "[&;]" nil t))
+ (commands
+ (mapcar
+ (lambda (cmd)
+ (let ((sep (pop sep-terms)))
+ (setq cmd (eshell-parse-pipeline cmd))
+ (unless eshell-in-pipeline-p
+ (setq cmd `(eshell-trap-errors ,cmd)))
+ ;; Copy I/O handles so each full statement can manipulate
+ ;; them if they like. Steal the handles for the last
+ ;; command in the list; we won't use the originals again
+ ;; anyway.
+ (setq cmd `(eshell-with-copied-handles ,cmd ,(not sep)))
+ (when (equal sep "&")
+ (setq cmd `(eshell-do-subjob ,cmd)))
+ cmd))
+ sub-chains)))
(if toplevel
`(eshell-commands (progn
(run-hooks 'eshell-pre-command-hook)
- (catch 'top-level (progn ,@commands))
- (run-hooks 'eshell-post-command-hook)))
+ (unwind-protect
+ (progn ,@commands)
+ (run-hooks 'eshell-post-command-hook))))
(macroexp-progn commands))))
-(defun eshell-debug-command (tag subform)
- "Output a debugging message to `*eshell last cmd*'."
- (let ((buf (get-buffer-create "*eshell last cmd*"))
- (text (eshell-stringify eshell-current-command)))
- (with-current-buffer buf
- (if (not tag)
- (erase-buffer)
- (insert "\n\C-l\n" tag "\n\n" text
- (if subform
- (concat "\n\n" (eshell-stringify subform)) ""))))))
-
(defun eshell-debug-show-parsed-args (terms)
"Display parsed arguments in the debug buffer."
- (ignore
- (if eshell-debug-command
- (eshell-debug-command "parsed arguments" terms))))
+ (ignore (eshell-debug-command 'form
+ "parsed arguments\n\n%s" (eshell-stringify terms))))
(defun eshell-no-command-conversion (terms)
"Don't convert the command argument."
@@ -480,14 +477,19 @@ hooks should be run before and after the command."
(let ((sym (if eshell-in-pipeline-p
'eshell-named-command*
'eshell-named-command))
- (cmd (car terms))
- (args (cdr terms)))
- (if args
- (list sym cmd `(list ,@(cdr terms)))
- (list sym cmd))))
-
-(defvar eshell-command-body)
-(defvar eshell-test-body)
+ (grouped-terms (eshell-prepare-splice terms)))
+ (cond
+ (grouped-terms
+ `(let ((terms (nconc ,@grouped-terms)))
+ (,sym (car terms) (cdr terms))))
+ ;; If no terms are spliced, use a simpler command form.
+ ((cdr terms)
+ (list sym (car terms) `(list ,@(cdr terms))))
+ (t
+ (list sym (car terms))))))
+
+(defvar eshell--command-body)
+(defvar eshell--test-body)
(defsubst eshell-invokify-arg (arg &optional share-output silent)
"Change ARG so it can be invoked from a structured command.
@@ -523,27 +525,24 @@ of its argument (i.e., use of a Lisp special form), it must be
implemented via rewriting, rather than as a function."
(if (and (equal (car terms) "for")
(equal (nth 2 terms) "in"))
- (let ((body (car (last terms))))
+ (let ((for-items (make-symbol "for-items"))
+ (body (car (last terms))))
(setcdr (last terms 2) nil)
- `(let ((for-items
- (copy-tree
- (append
- ,@(mapcar
- (lambda (elem)
- (if (listp elem)
- elem
- `(list ,elem)))
- (cdr (cddr terms))))))
- (eshell-command-body '(nil))
- (eshell-test-body '(nil)))
- (while (car for-items)
- (let ((,(intern (cadr terms)) (car for-items))
+ `(let ((,for-items
+ (append
+ ,@(mapcar
+ (lambda (elem)
+ (if (listp elem)
+ elem
+ `(list ,elem)))
+ (nthcdr 3 terms)))))
+ (while ,for-items
+ (let ((,(intern (cadr terms)) (car ,for-items))
(eshell--local-vars (cons ',(intern (cadr terms))
- eshell--local-vars)))
+ eshell--local-vars)))
(eshell-protect
,(eshell-invokify-arg body t)))
- (setcar for-items (cadr for-items))
- (setcdr for-items (cddr for-items)))
+ (setq ,for-items (cdr ,for-items)))
(eshell-close-handles)))))
(defun eshell-structure-basic-command (func names keyword test body
@@ -573,8 +572,7 @@ function."
;; finally, create the form that represents this structured
;; command
- `(let ((eshell-command-body '(nil))
- (eshell-test-body '(nil)))
+ `(progn
(,func ,test ,body ,else)
(eshell-close-handles)))
@@ -619,49 +617,40 @@ This means an exit code of 0."
(defun eshell-parse-pipeline (terms)
"Parse a pipeline from TERMS, return the appropriate Lisp forms."
- (let* (eshell--sep-terms
- (bigpieces (eshell-separate-commands terms "\\(&&\\|||\\)"
- nil 'eshell--sep-terms))
- (bp bigpieces)
- (results (list t))
- final)
- (while bp
- (let ((subterms (car bp)))
- (let* ((pieces (eshell-separate-commands subterms "|"))
- (p pieces))
- (while p
- (let ((cmd (car p)))
- (run-hook-with-args 'eshell-pre-rewrite-command-hook cmd)
- (setq cmd (run-hook-with-args-until-success
- 'eshell-rewrite-command-hook cmd))
- (let ((eshell--cmd cmd))
- (run-hook-with-args 'eshell-post-rewrite-command-hook
- 'eshell--cmd)
- (setq cmd eshell--cmd))
- (setcar p (funcall eshell-post-rewrite-command-function cmd)))
- (setq p (cdr p)))
- (nconc results
- (list
- (if (<= (length pieces) 1)
- (car pieces)
- (cl-assert (not eshell-in-pipeline-p))
- `(eshell-execute-pipeline (quote ,pieces))))))
- (setq bp (cdr bp))))
+ (pcase-let*
+ ((`(,bigpieces . ,sep-terms)
+ (eshell-split-commands terms "\\(&&\\|||\\)" nil t))
+ (results) (final))
+ (dolist (subterms bigpieces)
+ (let* ((pieces (eshell-split-commands subterms "|"))
+ (p pieces))
+ (while p
+ (let ((cmd (car p)))
+ (run-hook-with-args 'eshell-pre-rewrite-command-hook cmd)
+ (setq cmd (run-hook-with-args-until-success
+ 'eshell-rewrite-command-hook cmd))
+ (let ((eshell--cmd cmd))
+ (run-hook-with-args 'eshell-post-rewrite-command-hook
+ 'eshell--cmd)
+ (setq cmd eshell--cmd))
+ (setcar p (funcall eshell-post-rewrite-command-function cmd)))
+ (setq p (cdr p)))
+ (push (if (<= (length pieces) 1)
+ (car pieces)
+ (cl-assert (not eshell-in-pipeline-p))
+ `(eshell-execute-pipeline (quote ,pieces)))
+ results)))
;; `results' might be empty; this happens in the case of
;; multi-line input
- (setq results (cdr results)
- results (nreverse results)
- final (car results)
- results (cdr results)
- eshell--sep-terms (nreverse eshell--sep-terms))
+ (setq final (car results)
+ results (cdr results)
+ sep-terms (nreverse sep-terms))
(while results
- (cl-assert (car eshell--sep-terms))
+ (cl-assert (car sep-terms))
(setq final (eshell-structure-basic-command
- 'if (string= (car eshell--sep-terms) "&&") "if"
- `(eshell-protect ,(car results))
- `(eshell-protect ,final))
- results (cdr results)
- eshell--sep-terms (cdr eshell--sep-terms)))
+ 'if (string= (pop sep-terms) "&&") "if"
+ `(eshell-protect ,(pop results))
+ `(eshell-protect ,final))))
final))
(defun eshell-parse-subcommand-argument ()
@@ -672,13 +661,13 @@ This means an exit code of 0."
(or (= (point-max) (1+ (point)))
(not (eq (char-after (1+ (point))) ?\}))))
(let ((end (eshell-find-delimiter ?\{ ?\})))
- (if (not end)
- (throw 'eshell-incomplete ?\{)
- (when (eshell-arg-delimiter (1+ end))
- (prog1
- `(eshell-as-subcommand
- ,(eshell-parse-command (cons (1+ (point)) end)))
- (goto-char (1+ end))))))))
+ (unless end
+ (throw 'eshell-incomplete "{"))
+ (when (eshell-arg-delimiter (1+ end))
+ (prog1
+ `(eshell-as-subcommand
+ ,(eshell-parse-command (cons (1+ (point)) end)))
+ (goto-char (1+ end)))))))
(defun eshell-parse-lisp-argument ()
"Parse a Lisp expression which is specified as an argument."
@@ -690,12 +679,40 @@ This means an exit code of 0."
(condition-case nil
(read (current-buffer))
(end-of-file
- (throw 'eshell-incomplete ?\()))))
+ (throw 'eshell-incomplete "(")))))
(if (eshell-arg-delimiter)
`(eshell-command-to-value
(eshell-lisp-command (quote ,obj)))
(ignore (goto-char here))))))
+(defun eshell-split-commands (terms separator &optional
+ reversed return-seps)
+ "Split TERMS using SEPARATOR.
+If REVERSED is non-nil, the list of separated term groups will be
+returned in reverse order.
+
+If RETURN-SEPS is nil, return just the separated terms as a list;
+otherwise, return both the separated terms and their separators
+as a pair of lists."
+ (let (sub-chains sub-terms sep-terms)
+ (dolist (term terms)
+ (if (and (eq (car-safe term) 'eshell-operator)
+ (string-match (concat "^" separator "$")
+ (nth 1 term)))
+ (progn
+ (push (nth 1 term) sep-terms)
+ (push (nreverse sub-terms) sub-chains)
+ (setq sub-terms nil))
+ (push term sub-terms)))
+ (when sub-terms
+ (push (nreverse sub-terms) sub-chains))
+ (unless reversed
+ (setq sub-chains (nreverse sub-chains)
+ sep-terms (nreverse sep-terms)))
+ (if return-seps
+ (cons sub-chains sep-terms)
+ sub-chains)))
+
(defun eshell-separate-commands (terms separator &optional
reversed last-terms-sym)
"Separate TERMS using SEPARATOR.
@@ -703,55 +720,44 @@ If REVERSED is non-nil, the list of separated term groups will be
returned in reverse order. If LAST-TERMS-SYM is a symbol, its value
will be set to a list of all the separator operators found (or (nil)
if none)."
- (let ((sub-terms (list t))
- (eshell-sep-terms (list t))
- subchains)
- (while terms
- (if (and (consp (car terms))
- (eq (caar terms) 'eshell-operator)
- (string-match (concat "^" separator "$")
- (nth 1 (car terms))))
- (progn
- (nconc eshell-sep-terms (list (nth 1 (car terms))))
- (setq subchains (cons (cdr sub-terms) subchains)
- sub-terms (list t)))
- (nconc sub-terms (list (car terms))))
- (setq terms (cdr terms)))
- (if (> (length sub-terms) 1)
- (setq subchains (cons (cdr sub-terms) subchains)))
- (if reversed
- (progn
- (if last-terms-sym
- (set last-terms-sym (reverse (cdr eshell-sep-terms))))
- subchains) ; already reversed
- (if last-terms-sym
- (set last-terms-sym (cdr eshell-sep-terms)))
- (nreverse subchains))))
+ (declare (obsolete eshell-split-commands "30.1"))
+ (let ((split-terms (eshell-split-commands terms separator reversed
+ last-terms-sym)))
+ (if last-terms-sym
+ (progn
+ (set last-terms-sym (cdr split-terms))
+ (car split-terms))
+ split-terms)))
;;_* Command evaluation macros
;;
;; The structure of the following macros is very important to
;; `eshell-do-eval' [Iterative evaluation]:
;;
-;; @ Don't use forms that conditionally evaluate their arguments, such
-;; as `setq', `if', `while', `let*', etc. The only special forms
-;; that can be used are `let', `condition-case' and
-;; `unwind-protect'.
-;;
-;; @ The main body of a `let' can contain only one form. Use `progn'
-;; if necessary.
+;; @ Don't use special forms that conditionally evaluate their
+;; arguments, such as `let*', unless Eshell explicitly supports
+;; them. Eshell supports the following special forms: `catch',
+;; `condition-case', `if', `let', `prog1', `progn', `quote', `setq',
+;; `unwind-protect', and `while'.
;;
;; @ The two `special' variables are `eshell-current-handles' and
;; `eshell-current-subjob-p'. Bind them locally with a `let' if you
;; need to change them. Change them directly only if your intention
;; is to change the calling environment.
+;;
+;; These rules likewise apply to any other code that generates forms
+;; that `eshell-do-eval' will evaluated, such as command rewriting
+;; hooks (see `eshell-rewrite-command-hook' and friends).
(defmacro eshell-do-subjob (object)
"Evaluate a command OBJECT as a subjob.
-We indicate that the process was run in the background by returning it
-ensconced in a list."
- `(let ((eshell-current-subjob-p t))
- ,object))
+We indicate that the process was run in the background by
+returning it as (:eshell-background . PROCESSES)."
+ `(let ((eshell-current-subjob-p t)
+ ;; Print subjob messages. This could have been cleared
+ ;; (e.g. by `eshell-source-file', which see).
+ (eshell-subjob-messages t))
+ (eshell-resume-eval (eshell-add-command ',object 'background))))
(defmacro eshell-commands (object &optional silent)
"Place a valid set of handles, and context, around command OBJECT."
@@ -770,143 +776,141 @@ to this hook using `nconc', and *not* `add-hook'.
Someday, when Scheme will become the dominant Emacs language, all of
this grossness will be made to disappear by using `call/cc'..."
- `(let ((eshell-this-command-hook '(ignore)))
- (eshell-condition-case err
- (prog1
- ,object
- (mapc #'funcall eshell-this-command-hook))
- (error
- (mapc #'funcall eshell-this-command-hook)
- (eshell-errorn (error-message-string err))
- (eshell-close-handles 1)))))
+ `(eshell-condition-case err
+ (let ((eshell-this-command-hook '(ignore)))
+ (unwind-protect
+ ,object
+ (mapc #'funcall eshell-this-command-hook)))
+ (error
+ (eshell-errorn (error-message-string err))
+ (eshell-close-handles 1))))
(defvar eshell-output-handle) ;Defined in esh-io.el.
(defvar eshell-error-handle) ;Defined in esh-io.el.
-(defmacro eshell-copy-handles (object)
- "Duplicate current I/O handles, so OBJECT works with its own copy."
+(defmacro eshell-with-copied-handles (object &optional steal-p)
+ "Duplicate current I/O handles, so OBJECT works with its own copy.
+If STEAL-P is non-nil, these new handles will be stolen from the
+current ones (see `eshell-duplicate-handles')."
`(let ((eshell-current-handles
- (eshell-create-handles
- (car (aref eshell-current-handles
- eshell-output-handle)) nil
- (car (aref eshell-current-handles
- eshell-error-handle)) nil)))
+ (eshell-duplicate-handles eshell-current-handles ,steal-p)))
,object))
+(define-obsolete-function-alias 'eshell-copy-handles
+ #'eshell-with-copied-handles "30.1")
+
(defmacro eshell-protect (object)
"Protect I/O handles, so they aren't get closed after eval'ing OBJECT."
`(progn
(eshell-protect-handles eshell-current-handles)
,object))
+(defun eshell--unmark-deferrable (command)
+ "If COMMAND is (or ends with) a deferrable command, unmark it as such.
+This changes COMMAND in-place by converting function calls listed
+in `eshell-deferrable-commands' to their non-deferrable forms so
+that Eshell doesn't erroneously allow deferring it. For example,
+`eshell-named-command' becomes `eshell-named-command*', "
+ (let ((cmd command))
+ (when (memq (car cmd) '(let progn))
+ (setq cmd (car (last cmd))))
+ (when (memq (car cmd) eshell-deferrable-commands)
+ (setcar cmd (intern-soft
+ (concat (symbol-name (car cmd)) "*"))))
+ command))
+
(defmacro eshell-do-pipelines (pipeline &optional notfirst)
"Execute the commands in PIPELINE, connecting each to one another.
+Returns a list of the processes in the pipeline.
+
This macro calls itself recursively, with NOTFIRST non-nil."
(when (setq pipeline (cadr pipeline))
- `(eshell-copy-handles
- (progn
- ,(when (cdr pipeline)
- `(let ((nextproc
- (eshell-do-pipelines (quote ,(cdr pipeline)) t)))
- (eshell-set-output-handle ,eshell-output-handle
- 'append nextproc)))
- ,(let ((head (car pipeline)))
- (if (memq (car head) '(let progn))
- (setq head (car (last head))))
- (when (memq (car head) eshell-deferrable-commands)
- (ignore
- (setcar head
- (intern-soft
- (concat (symbol-name (car head)) "*"))))))
- ;; First and last elements in a pipeline may need special treatment.
- ;; (Currently only eshell-ls-files uses 'last.)
- ;; Affects process-connection-type in eshell-gather-process-output.
- (let ((eshell-in-pipeline-p
- ,(cond ((not notfirst) (quote 'first))
- ((cdr pipeline) t)
- (t (quote 'last)))))
- (let ((proc ,(car pipeline)))
- (set headproc (or proc (symbol-value headproc)))
- (set tailproc (or (symbol-value tailproc) proc))
- proc))))))
+ (eshell--unmark-deferrable (car pipeline))
+ `(eshell-with-copied-handles
+ (let ((next-procs
+ ,(when (cdr pipeline)
+ `(eshell-do-pipelines (quote ,(cdr pipeline)) t)))
+ ;; First and last elements in a pipeline may need special
+ ;; treatment (currently only `eshell-ls-files' uses
+ ;; `last'). Affects `process-connection-type' in
+ ;; `eshell-gather-process-output'.
+ (eshell-in-pipeline-p
+ ,(cond ((not notfirst) (quote 'first))
+ ((cdr pipeline) t)
+ (t (quote 'last)))))
+ ,(when (cdr pipeline)
+ `(eshell-set-output-handle ,eshell-output-handle
+ 'append (car next-procs)))
+ (let ((proc ,(car pipeline)))
+ (cons proc next-procs)))
+ ;; Steal handles if this is the last item in the pipeline.
+ ,(null (cdr pipeline)))))
(defmacro eshell-do-pipelines-synchronously (pipeline)
"Execute the commands in PIPELINE in sequence synchronously.
-Output of each command is passed as input to the next one in the pipeline.
-This is used on systems where async subprocesses are not supported."
+This collects the output of each command in turn, passing it as
+input to the next one in the pipeline. Returns the result of the
+first command invocation in the pipeline (usually t or nil).
+
+This is used on systems where async subprocesses are not
+supported."
(when (setq pipeline (cadr pipeline))
- `(progn
+ ;; FIXME: is deferrable significant here?
+ (eshell--unmark-deferrable (car pipeline))
+ `(prog1
+ (eshell-with-copied-handles
+ (progn
+ ,(when (cdr pipeline)
+ `(let ((output-marker ,(point-marker)))
+ (eshell-set-output-handle ,eshell-output-handle
+ 'append output-marker)))
+ (let (;; XXX: `eshell-in-pipeline-p' has a different
+ ;; meaning for synchronous processes: it's non-nil
+ ;; only when piping *to* a process.
+ (eshell-in-pipeline-p ,(and (cdr pipeline) t)))
+ ,(car pipeline)))
+ ;; Steal handles if this is the last item in the pipeline.
+ ,(null (cdr pipeline)))
,(when (cdr pipeline)
- `(let ((output-marker ,(point-marker)))
- (eshell-set-output-handle ,eshell-output-handle
- 'append output-marker)))
- ,(let ((head (car pipeline)))
- (if (memq (car head) '(let progn))
- (setq head (car (last head))))
- ;; FIXME: is deferrable significant here?
- (when (memq (car head) eshell-deferrable-commands)
- (ignore
- (setcar head
- (intern-soft
- (concat (symbol-name (car head)) "*"))))))
- ;; The last process in the pipe should get its handles
- ;; redirected as we found them before running the pipe.
- ,(if (null (cdr pipeline))
- '(progn
- (setq eshell-current-handles tail-handles)
- (setq eshell-in-pipeline-p nil)))
- (let ((result ,(car pipeline)))
- ;; tailproc gets the result of the last successful process in
- ;; the pipeline.
- (set tailproc (or result (symbol-value tailproc)))
- ,(if (cdr pipeline)
- `(eshell-do-pipelines-synchronously (quote ,(cdr pipeline))))
- result))))
+ `(eshell-do-pipelines-synchronously (quote ,(cdr pipeline)))))))
(defalias 'eshell-process-identity 'identity)
(defmacro eshell-execute-pipeline (pipeline)
"Execute the commands in PIPELINE, connecting each to one another."
- `(let ((eshell-in-pipeline-p t)
- (headproc (make-symbol "headproc"))
- (tailproc (make-symbol "tailproc")))
- (set headproc nil)
- (set tailproc nil)
- (progn
- ,(if (fboundp 'make-process)
- `(eshell-do-pipelines ,pipeline)
- `(let ((tail-handles (eshell-create-handles
- (car (aref eshell-current-handles
- ,eshell-output-handle)) nil
- (car (aref eshell-current-handles
- ,eshell-error-handle)) nil)))
- (eshell-do-pipelines-synchronously ,pipeline)))
- (eshell-process-identity (cons (symbol-value headproc)
- (symbol-value tailproc))))))
+ `(eshell-process-identity
+ ,(if eshell-supports-asynchronous-processes
+ `(remove nil (eshell-do-pipelines ,pipeline))
+ `(eshell-do-pipelines-synchronously ,pipeline))))
(defmacro eshell-as-subcommand (command)
- "Execute COMMAND using a temp buffer.
-This is used so that certain Lisp commands, such as `cd', when
-executed in a subshell, do not disturb the environment of the main
-Eshell buffer."
+ "Execute COMMAND as a subcommand.
+A subcommand creates a local environment so that any changes to
+the environment don't propagate outside of the subcommand's
+scope. This lets you use commands like `cd' within a subcommand
+without changing the current directory of the main Eshell
+buffer."
`(let ,eshell-subcommand-bindings
,command))
(defmacro eshell-do-command-to-value (object)
"Run a subcommand prepared by `eshell-command-to-value'.
This avoids the need to use `let*'."
+ (declare (obsolete nil "30.1"))
`(let ((eshell-current-handles
(eshell-create-handles value 'overwrite)))
(progn
,object
(symbol-value value))))
-(defmacro eshell-command-to-value (object)
- "Run OBJECT synchronously, returning its result as a string.
-Returns a string comprising the output from the command."
- `(let ((value (make-symbol "eshell-temp"))
- (eshell-in-pipeline-p nil))
- (eshell-do-command-to-value ,object)))
+(defmacro eshell-command-to-value (command)
+ "Run an Eshell COMMAND synchronously, returning its output."
+ (let ((value (make-symbol "eshell-temp")))
+ `(let ((eshell-in-pipeline-p nil)
+ (eshell-current-handles
+ (eshell-create-handles ',value 'overwrite)))
+ ,command
+ ,value)))
;;;_* Iterative evaluation
;;
@@ -923,38 +927,6 @@ Returns a string comprising the output from the command."
;; finishes, it will resume the evaluation using the remainder of the
;; command tree.
-(defun eshell/eshell-debug (&rest args)
- "A command for toggling certain debug variables."
- (ignore
- (cond
- ((not args)
- (if eshell-handle-errors
- (eshell-print "errors\n"))
- (if eshell-debug-command
- (eshell-print "commands\n")))
- ((member (car args) '("-h" "--help"))
- (eshell-print "usage: eshell-debug [kinds]
-
-This command is used to aid in debugging problems related to Eshell
-itself. It is not useful for anything else. The recognized `kinds'
-at the moment are:
-
- errors stops Eshell from trapping errors
- commands shows command execution progress in `*eshell last cmd*'
-"))
- (t
- (while args
- (cond
- ((string= (car args) "errors")
- (setq eshell-handle-errors (not eshell-handle-errors)))
- ((string= (car args) "commands")
- (setq eshell-debug-command (not eshell-debug-command))))
- (setq args (cdr args)))))))
-
-(defun pcomplete/eshell-mode/eshell-debug ()
- "Completion for the `debug' command."
- (while (pcomplete-here '("errors" "commands"))))
-
(iter-defun eshell--find-subcommands (haystack)
"Recursively search for subcommand forms in HAYSTACK.
This yields the SUBCOMMANDs when found in forms like
@@ -962,48 +934,52 @@ This yields the SUBCOMMANDs when found in forms like
(dolist (elem haystack)
(cond
((eq (car-safe elem) 'eshell-as-subcommand)
- (iter-yield (cdr elem)))
+ (iter-yield (cadr elem)))
((listp elem)
(iter-yield-from (eshell--find-subcommands elem))))))
-(defun eshell--invoke-command-directly (command)
+(defun eshell--invoke-command-directly-p (command)
"Determine whether the given COMMAND can be invoked directly.
COMMAND should be a non-top-level Eshell command in parsed form.
A command can be invoked directly if all of the following are true:
* The command is of the form
- \"(eshell-trap-errors (eshell-named-command NAME ARGS))\",
- where ARGS is optional.
+ (eshell-with-copied-handles
+ (eshell-trap-errors (eshell-named-command NAME [ARGS])) _).
* NAME is a string referring to an alias function and isn't a
complex command (see `eshell-complex-commands').
* Any subcommands in ARGS can also be invoked directly."
- (when (and (eq (car command) 'eshell-trap-errors)
- (eq (car (cadr command)) 'eshell-named-command))
- (let ((name (cadr (cadr command)))
- (args (cdr-safe (nth 2 (cadr command)))))
- (and name (stringp name)
- (not (member name eshell-complex-commands))
- (catch 'simple
- (dolist (pred eshell-complex-commands t)
- (when (and (functionp pred)
- (funcall pred name))
- (throw 'simple nil))))
- (eshell-find-alias-function name)
- (catch 'indirect-subcommand
- (iter-do (subcommand (eshell--find-subcommands args))
- (unless (eshell--invoke-command-directly subcommand)
- (throw 'indirect-subcommand nil)))
- t)))))
-
-(defun eshell-invoke-directly (command)
+ (pcase command
+ (`(eshell-with-copied-handles
+ (eshell-trap-errors (eshell-named-command ,name . ,args))
+ ,_)
+ (and name (stringp name)
+ (not (member name eshell-complex-commands))
+ (catch 'simple
+ (dolist (pred eshell-complex-commands t)
+ (when (and (functionp pred)
+ (funcall pred name))
+ (throw 'simple nil))))
+ (eshell-find-alias-function name)
+ (catch 'indirect-subcommand
+ (iter-do (subcommand (eshell--find-subcommands (car args)))
+ (unless (eshell--invoke-command-directly-p subcommand)
+ (throw 'indirect-subcommand nil)))
+ t)))))
+
+(defun eshell-invoke-directly-p (command)
"Determine whether the given COMMAND can be invoked directly.
COMMAND should be a top-level Eshell command in parsed form, as
produced by `eshell-parse-command'."
- (let ((base (cadr (nth 2 (nth 2 (cadr command))))))
- (eshell--invoke-command-directly base)))
+ (pcase command
+ (`(eshell-commands (progn ,_ (unwind-protect (progn ,base) . ,_)))
+ (eshell--invoke-command-directly-p base))))
+
+(define-obsolete-function-alias 'eshell-invoke-directly
+ 'eshell-invoke-directly-p "30.1")
(defun eshell-eval-argument (argument)
"Evaluate a single Eshell ARGUMENT and return the result."
@@ -1014,82 +990,107 @@ produced by `eshell-parse-command'."
(cadr result)))
(defun eshell-eval-command (command &optional input)
- "Evaluate the given COMMAND iteratively."
- (if eshell-current-command
- ;; We can just stick the new command at the end of the current
- ;; one, and everything will happen as it should.
- (setcdr (last (cdr eshell-current-command))
- (list `(let ((here (and (eobp) (point))))
- ,(and input
- `(insert-and-inherit ,(concat input "\n")))
- (if here
- (eshell-update-markers here))
- (eshell-do-eval ',command))))
- (and eshell-debug-command
- (with-current-buffer (get-buffer-create "*eshell last cmd*")
- (erase-buffer)
- (insert "command: \"" input "\"\n")))
- (setq eshell-current-command command)
- (let* ((delim (catch 'eshell-incomplete
- (eshell-resume-eval)))
- (val (car-safe delim))
- (val-is-process (or (eshell-processp val)
- (eshell-process-pair-p val))))
- ;; If the return value of `eshell-resume-eval' is wrapped in a
- ;; list, it indicates that the command was run asynchronously.
- ;; In that case, unwrap the value before checking the delimiter
- ;; value.
- (if (and val
- (not val-is-process)
- (not (eq val t)))
- (error "Unmatched delimiter: %S" val)
- ;; Eshell-command expect a list like (<process>) to know if the
- ;; command should be async or not.
- (or (and val-is-process delim) val)))))
+ "Evaluate the given COMMAND iteratively.
+Return the process (or head and tail processes) created by
+COMMAND, if any. If COMMAND is a background command, return the
+process(es) in a cons cell like:
+
+ (:eshell-background . PROCESSES)"
+ (if eshell-foreground-command
+ (progn
+ ;; We can just stick the new command at the end of the current
+ ;; one, and everything will happen as it should.
+ (setcdr (last (cdar eshell-foreground-command))
+ (list `(let ((here (and (eobp) (point))))
+ ,(and input
+ `(insert-and-inherit ,(concat input "\n")))
+ (if here
+ (eshell-update-markers here))
+ (eshell-do-eval ',command))))
+ (eshell-debug-command 'form
+ "enqueued command form for %S\n\n%s"
+ (or input "<no string>")
+ (eshell-stringify (car eshell-foreground-command))))
+ (eshell-debug-command-start input)
+ (let* (result
+ (delim (catch 'eshell-incomplete
+ (ignore (setq result (eshell-resume-eval
+ (eshell-add-command command)))))))
+ (when delim
+ (error "Unmatched delimiter: %S" delim))
+ result)))
(defun eshell-resume-command (proc status)
- "Resume the current command when a process ends."
+ "Resume the current command when a pipeline ends.
+PROC is the process that invoked this from its sentinel, and
+STATUS is its status."
(when proc
- (unless (or (not (stringp status))
- (string= "stopped" status)
- (string-match eshell-reset-signals status))
- (if (eq proc (eshell-tail-process))
- (eshell-resume-eval)))))
-
-(defun eshell-resume-eval ()
- "Destructively evaluate a form which may need to be deferred."
+ (dolist (command (eshell-commands-for-process proc))
+ (unless (seq-some #'eshell-process-active-p (nth 2 command))
+ (setf (nth 2 command) nil) ; Clear processes from command.
+ (if (and ;; Check STATUS to determine whether we want to resume or
+ ;; abort the command.
+ (stringp status)
+ (not (string= "stopped" status))
+ (not (string-match eshell-reset-signals status)))
+ (eshell-resume-eval command)
+ (eshell-remove-command command)
+ (declare-function eshell-reset "esh-mode" (&optional no-hooks))
+ (eshell-reset))))))
+
+(defun eshell-resume-eval (command)
+ "Destructively evaluate a COMMAND which may need to be deferred.
+COMMAND is a command entry of the form (BACKGROUND FORM
+PROCESSES) (see `eshell-add-command').
+
+Return the result of COMMAND's FORM if it wasn't deferred. If
+BACKGROUND is non-nil and Eshell defers COMMAND, return a list of
+the form (:eshell-background . PROCESSES)."
(eshell-condition-case err
- (progn
- (setq eshell-last-async-procs nil)
- (when eshell-current-command
- (let* (retval
- (procs (catch 'eshell-defer
- (ignore
- (setq retval
- (eshell-do-eval
- eshell-current-command))))))
- (if (eshell-process-pair-p procs)
- (ignore (setq eshell-last-async-procs procs))
- (cadr retval)))))
+ (let (retval procs)
+ (unwind-protect
+ (progn
+ (setq procs
+ (catch 'eshell-defer
+ (ignore (setq retval (eshell-do-eval (cadr command))))))
+ (cond
+ (retval (cadr retval))
+ ((car command) (cons :eshell-background procs))))
+ (if procs
+ (setf (nth 2 command) procs)
+ ;; If we didn't defer this command, clear it out. This
+ ;; applies both when the command has finished normally,
+ ;; and when a signal or thrown value causes us to unwind.
+ (eshell-remove-command command))))
(error
(error (error-message-string err)))))
-(defmacro eshell-manipulate (tag &rest commands)
- "Manipulate a COMMAND form, with TAG as a debug identifier."
- (declare (indent 1))
- ;; Check `bound'ness since at compile time the code until here has not
- ;; executed yet.
- (if (not (and (boundp 'eshell-debug-command) eshell-debug-command))
- `(progn ,@commands)
- `(progn
- (eshell-debug-command ,(eval tag) form)
- ,@commands
- (eshell-debug-command ,(concat "done " (eval tag)) form))))
+(defmacro eshell-manipulate (form tag &rest body)
+ "Manipulate a command FORM with BODY, using TAG as a debug identifier."
+ (declare (indent 2))
+ (let ((tag-symbol (make-symbol "tag")))
+ `(if (not (memq 'form eshell-debug-command))
+ (progn ,@body)
+ (let ((,tag-symbol ,tag))
+ (eshell-always-debug-command 'form
+ "%s\n\n%s" ,tag-symbol (eshell-stringify ,form))
+ (unwind-protect
+ (progn ,@body)
+ (eshell-always-debug-command 'form
+ "done %s\n\n%s" ,tag-symbol (eshell-stringify ,form)))))))
(defun eshell-do-eval (form &optional synchronous-p)
- "Evaluate form, simplifying it as we go.
+ "Evaluate FORM, simplifying it as we go.
Unless SYNCHRONOUS-P is non-nil, throws `eshell-defer' if it needs to
-be finished later after the completion of an asynchronous subprocess."
+be finished later after the completion of an asynchronous subprocess.
+
+As this function evaluates FORM, it will gradually replace
+subforms with the (quoted) result of evaluating them. For
+example, a function call is replaced with the result of the call.
+This allows us to resume evaluation of FORM after something
+inside throws `eshell-defer' simply by calling this function
+again. Any forms preceding one that throw `eshell-defer' will
+have been replaced by constants."
(cond
((not (listp form))
(list 'quote (eval form)))
@@ -1103,49 +1104,58 @@ be finished later after the completion of an asynchronous subprocess."
;; we can modify any `let' forms to evaluate only once.
(if (macrop (car form))
(let ((exp (copy-tree (macroexpand form))))
- (eshell-manipulate (format-message "expanding macro `%s'"
- (symbol-name (car form)))
+ (eshell-manipulate form
+ (format-message "expanding macro `%s'" (symbol-name (car form)))
(setcar form (car exp))
(setcdr form (cdr exp)))))
(let ((args (cdr form)))
(cond
((eq (car form) 'while)
+ ;; Wrap the `while' form with let-bindings for the command and
+ ;; test bodies. This helps us resume evaluation midway
+ ;; through the loop.
+ (let ((new-form (copy-tree `(let ((eshell--command-body nil)
+ (eshell--test-body nil))
+ (eshell--wrapped-while ,@args)))))
+ (eshell-manipulate form "modifying while form"
+ (setcar form (car new-form))
+ (setcdr form (cdr new-form)))
+ (eshell-do-eval form synchronous-p)))
+ ((eq (car form) 'eshell--wrapped-while)
+ (when eshell--command-body
+ (cl-assert (not synchronous-p))
+ (eshell-do-eval eshell--command-body)
+ (setq eshell--command-body nil
+ eshell--test-body nil))
;; `copy-tree' is needed here so that the test argument
- ;; doesn't get modified and thus always yield the same result.
- (when (car eshell-command-body)
- (cl-assert (not synchronous-p))
- (eshell-do-eval (car eshell-command-body))
- (setcar eshell-command-body nil)
- (setcar eshell-test-body nil))
- (unless (car eshell-test-body)
- (setcar eshell-test-body (copy-tree (car args))))
- (while (cadr (eshell-do-eval (car eshell-test-body) synchronous-p))
- (setcar eshell-command-body
- (if (cddr args)
- `(progn ,@(copy-tree (cdr args)))
- (copy-tree (cadr args))))
- (eshell-do-eval (car eshell-command-body) synchronous-p)
- (setcar eshell-command-body nil)
- (setcar eshell-test-body (copy-tree (car args))))
- (setcar eshell-command-body nil))
+ ;; doesn't get modified and thus always yield the same result.
+ (unless eshell--test-body
+ (setq eshell--test-body (copy-tree (car args))))
+ (while (cadr (eshell-do-eval eshell--test-body synchronous-p))
+ (setq eshell--command-body
+ (if (cddr args)
+ `(progn ,@(copy-tree (cdr args)))
+ (copy-tree (cadr args))))
+ (eshell-do-eval eshell--command-body synchronous-p)
+ (setq eshell--command-body nil
+ eshell--test-body (copy-tree (car args)))))
((eq (car form) 'if)
- ;; `copy-tree' is needed here so that the test argument
- ;; doesn't get modified and thus always yield the same result.
- (if (car eshell-command-body)
- (progn
- (cl-assert (not synchronous-p))
- (eshell-do-eval (car eshell-command-body)))
- (unless (car eshell-test-body)
- (setcar eshell-test-body (copy-tree (car args))))
- (setcar eshell-command-body
- (copy-tree
- (if (cadr (eshell-do-eval (car eshell-test-body)
- synchronous-p))
- (cadr args)
- (car (cddr args)))))
- (eshell-do-eval (car eshell-command-body) synchronous-p))
- (setcar eshell-command-body nil)
- (setcar eshell-test-body nil))
+ (eshell-manipulate form "evaluating if condition"
+ ;; Evaluate the condition and replace our `if' form with
+ ;; THEN or ELSE as appropriate.
+ (let ((new-form
+ (cond
+ ((cadr (eshell-do-eval (car args) synchronous-p))
+ (cadr args)) ; COND is non-nil
+ ((cdddr args)
+ `(progn ,@(cddr args))) ; Multiple ELSE forms
+ (t
+ (caddr args))))) ; Zero or one ELSE forms
+ (unless (consp new-form)
+ (setq new-form (cons 'progn new-form)))
+ (setcar form (car new-form))
+ (setcdr form (cdr new-form))))
+ (eshell-do-eval form synchronous-p))
((eq (car form) 'setcar)
(setcar (cdr args) (eshell-do-eval (cadr args) synchronous-p))
(eval form))
@@ -1153,45 +1163,92 @@ be finished later after the completion of an asynchronous subprocess."
(setcar (cdr args) (eshell-do-eval (cadr args) synchronous-p))
(eval form))
((eq (car form) 'let)
- (if (not (eq (car (cadr args)) 'eshell-do-eval))
- (eshell-manipulate "evaluating let args"
- (dolist (letarg (car args))
- (if (and (listp letarg)
- (not (eq (cadr letarg) 'quote)))
- (setcdr letarg
- (list (eshell-do-eval
- (cadr letarg) synchronous-p)))))))
+ (unless (eq (car-safe (cadr args)) 'eshell-do-eval)
+ (eshell-manipulate form "evaluating let args"
+ (dolist (letarg (car args))
+ (when (and (listp letarg)
+ (not (eq (cadr letarg) 'quote)))
+ (setcdr letarg
+ (list (eshell-do-eval
+ (cadr letarg) synchronous-p)))))))
(cl-progv
- (mapcar (lambda (binding) (if (consp binding) (car binding) binding))
+ (mapcar (lambda (binding)
+ (if (consp binding) (car binding) binding))
(car args))
;; These expressions should all be constants now.
- (mapcar (lambda (binding) (if (consp binding) (eval (cadr binding))))
+ (mapcar (lambda (binding)
+ (when (consp binding) (eval (cadr binding))))
(car args))
- (eshell-do-eval (macroexp-progn (cdr args)) synchronous-p)))
- ((memq (car form) '(catch condition-case unwind-protect))
- ;; `condition-case' and `unwind-protect' have to be
- ;; handled specially, because we only want to call
- ;; `eshell-do-eval' on their first form.
+ (let (deferred result)
+ ;; Evaluate the `let' body, catching `eshell-defer' so we
+ ;; can handle it below.
+ (setq deferred
+ (catch 'eshell-defer
+ (ignore (setq result (eshell-do-eval
+ (macroexp-progn (cdr args))
+ synchronous-p)))))
+ ;; If something threw `eshell-defer', we need to update
+ ;; the let-bindings' values so that those values are
+ ;; correct when we resume evaluation of this form.
+ (when deferred
+ (eshell-manipulate form "rebinding let args after `eshell-defer'"
+ (let ((bindings (car args)))
+ (while bindings
+ (let ((binding (if (consp (car bindings))
+ (caar bindings)
+ (car bindings))))
+ (setcar bindings
+ (list binding
+ (list 'quote (symbol-value binding)))))
+ (pop bindings))))
+ (throw 'eshell-defer deferred))
+ ;; If we get here, there was no `eshell-defer' thrown, so
+ ;; just return the `let' body's result.
+ result)))
+ ((memq (car form) '(catch condition-case))
+ ;; `catch' and `condition-case' have to be handled specially,
+ ;; because we only want to call `eshell-do-eval' on their
+ ;; second forms.
;;
;; NOTE: This requires obedience by all forms which this
;; function might encounter, that they do not contain
;; other special forms.
- (unless (eq (car form) 'unwind-protect)
- (setq args (cdr args)))
+ (setq args (cdr args))
(unless (eq (caar args) 'eshell-do-eval)
- (eshell-manipulate "handling special form"
+ (eshell-manipulate form "handling special form"
(setcar args `(eshell-do-eval ',(car args) ,synchronous-p))))
(eval form))
+ ((eq (car form) 'unwind-protect)
+ ;; `unwind-protect' has to be handled specially, because we
+ ;; only want to call `eshell-do-eval' on its first form, and
+ ;; we need to ensure we let `eshell-defer' through without
+ ;; evaluating the unwind forms.
+ (let (deferred)
+ (unwind-protect
+ (eshell-manipulate form "handling `unwind-protect' body form"
+ (setq deferred
+ (catch 'eshell-defer
+ (ignore
+ (setcar args (eshell-do-eval
+ (car args) synchronous-p)))))
+ (car args))
+ (if deferred
+ (throw 'eshell-defer deferred)
+ (eshell-manipulate form "handling `unwind-protect' unwind forms"
+ (pop args)
+ (while args
+ (setcar args (eshell-do-eval (car args) synchronous-p))
+ (pop args)))))))
((eq (car form) 'setq)
(if (cddr args) (error "Unsupported form (setq X1 E1 X2 E2..)"))
- (eshell-manipulate "evaluating arguments to setq"
+ (eshell-manipulate form "evaluating arguments to setq"
(setcar (cdr args) (eshell-do-eval (cadr args) synchronous-p)))
(list 'quote (eval form)))
(t
(if (and args (not (memq (car form) '(run-hooks))))
- (eshell-manipulate
+ (eshell-manipulate form
(format-message "evaluating arguments to `%s'"
- (symbol-name (car form)))
+ (car form))
(while args
(setcar args (eshell-do-eval (car args) synchronous-p))
(setq args (cdr args)))))
@@ -1230,16 +1287,15 @@ be finished later after the completion of an asynchronous subprocess."
(setq result (eval form))))))
(if new-form
(progn
- (eshell-manipulate "substituting replacement form"
+ (eshell-manipulate form "substituting replacement form"
(setcar form (car new-form))
(setcdr form (cdr new-form)))
(eshell-do-eval form synchronous-p))
(if-let (((memq (car form) eshell-deferrable-commands))
- ((not eshell-current-subjob-p))
- (procs (eshell-make-process-pair result)))
+ (procs (eshell-make-process-list result)))
(if synchronous-p
- (eshell/wait (cdr procs))
- (eshell-manipulate "inserting ignore form"
+ (apply #'eshell/wait procs)
+ (eshell-manipulate form "inserting ignore form"
(setcar form 'ignore)
(setcdr form nil))
(throw 'eshell-defer procs))
@@ -1286,16 +1342,26 @@ be finished later after the completion of an asynchronous subprocess."
(defun eshell-named-command (command &optional args)
"Insert output from a plain COMMAND, using ARGS.
COMMAND may result in an alias being executed, or a plain command."
+ (unless eshell-allow-commands
+ (signal 'eshell-commands-forbidden '(named)))
+ ;; Strip off any leading nil values. This can only happen if a
+ ;; variable evaluates to nil, such as "$var x", where `var' is nil.
+ ;; In that case, the command name becomes `x', for compatibility
+ ;; with most regular shells (the difference is that they do an
+ ;; interpolation pass before the argument parsing pass, but Eshell
+ ;; does both at the same time).
+ (while (and (not command) args)
+ (setq command (pop args)))
(setq eshell-last-arguments args
- eshell-last-command-name (eshell-stringify command))
+ eshell-last-command-name (eshell-stringify command))
(run-hook-with-args 'eshell-prepare-command-hook)
(cl-assert (stringp eshell-last-command-name))
- (if eshell-last-command-name
- (or (run-hook-with-args-until-success
- 'eshell-named-command-hook eshell-last-command-name
- eshell-last-arguments)
- (eshell-plain-command eshell-last-command-name
- eshell-last-arguments))))
+ (when eshell-last-command-name
+ (or (run-hook-with-args-until-success
+ 'eshell-named-command-hook eshell-last-command-name
+ eshell-last-arguments)
+ (eshell-plain-command eshell-last-command-name
+ eshell-last-arguments))))
(defalias 'eshell-named-command* 'eshell-named-command)
@@ -1423,6 +1489,8 @@ via `eshell-errorn'."
(defun eshell-lisp-command (object &optional args)
"Insert Lisp OBJECT, using ARGS if a function."
+ (unless eshell-allow-commands
+ (signal 'eshell-commands-forbidden '(lisp)))
(catch 'eshell-external ; deferred to an external command
(setq eshell-last-command-status 0
eshell-last-arguments args)
diff --git a/lisp/eshell/esh-ext.el b/lisp/eshell/esh-ext.el
index 9da76c14f7c..44861c222b8 100644
--- a/lisp/eshell/esh-ext.el
+++ b/lisp/eshell/esh-ext.el
@@ -168,11 +168,23 @@ external version."
:type 'character
:group 'eshell-ext)
+(defcustom eshell-explicit-remote-commands t
+ "If non-nil, support explicitly-remote commands.
+These are commands with a full remote file name, such as
+\"/ssh:host:whoami\". If this is enabled, you can also run
+explicitly-local commands by using a quoted file name, like
+\"/:whoami\"."
+ :type 'boolean
+ :group 'eshell-ext)
+
;;; Functions:
(defun eshell-ext-initialize () ;Called from `eshell-mode' via intern-soft!
"Initialize the external command handling code."
- (add-hook 'eshell-named-command-hook #'eshell-explicit-command nil t))
+ (add-hook 'eshell-named-command-hook #'eshell-explicit-command nil t)
+ (when eshell-explicit-remote-commands
+ (add-hook 'eshell-named-command-hook
+ #'eshell-handle-remote-command nil t)))
(defun eshell-explicit-command (command args)
"If a command name begins with `*', call it externally always.
@@ -186,30 +198,36 @@ This bypasses all Lisp functions and aliases."
(error "%s: external command not found"
(substring command 1))))))
+(defun eshell-handle-remote-command (command args)
+ "Handle remote (or quoted) COMMAND names, using ARGS.
+This calls the appropriate function for commands that aren't on
+the connection associated with `default-directory'. (See
+`eshell-explicit-remote-commands'.)"
+ (if (file-name-quoted-p command)
+ (let ((default-directory (if (file-remote-p default-directory)
+ (expand-file-name "~")
+ default-directory)))
+ (eshell-external-command (file-name-unquote command) args))
+ (when (file-remote-p command)
+ (eshell-remote-command command args))))
+
(defun eshell-remote-command (command args)
"Insert output from a remote COMMAND, using ARGS.
A remote command is something that executes on a different machine.
-An external command simply means external to Emacs.
-
-Note that this function is very crude at the moment. It gathers up
-all the output from the remote command, and sends it all at once,
-causing the user to wonder if anything's really going on..."
- (let ((outbuf (generate-new-buffer " *eshell remote output*"))
- (errbuf (generate-new-buffer " *eshell remote error*"))
- (command (file-local-name command))
- (exitcode 1))
- (unwind-protect
- (progn
- (setq exitcode
- (shell-command
- (mapconcat #'shell-quote-argument
- (append (list command) args) " ")
- outbuf errbuf))
- (eshell-print (with-current-buffer outbuf (buffer-string)))
- (eshell-error (with-current-buffer errbuf (buffer-string))))
- (eshell-close-handles exitcode 'nil)
- (kill-buffer outbuf)
- (kill-buffer errbuf))))
+An external command simply means external to Emacs."
+ (let* ((cwd-connection (file-remote-p default-directory))
+ (command-connection (file-remote-p command))
+ (default-directory (if (equal cwd-connection command-connection)
+ default-directory
+ command-connection))
+ ;; Never use the remote connection here. We don't want to
+ ;; expand the local name! Instead, we want it as the user
+ ;; typed, so that if COMMAND is "/ssh:host:cat", we just get
+ ;; "cat" as the result.
+ (command-localname (file-remote-p command 'localname 'never)))
+ (unless command-connection
+ (error "%s: not a remote command" command))
+ (eshell-external-command command-localname args)))
(defun eshell-external-command (command args)
"Insert output from an external COMMAND, using ARGS."
@@ -235,10 +253,10 @@ causing the user to wonder if anything's really going on..."
"Add a set of paths to PATH."
(eshell-eval-using-options
"addpath" args
- '((?b "begin" nil prepend "add path element at beginning")
+ '((?b "begin" nil prepend "add to beginning of $PATH")
(?h "help" nil nil "display this usage message")
- :usage "[-b] PATH
-Adds the given PATH to $PATH.")
+ :usage "[-b] DIR...
+Adds the given DIR to $PATH.")
(let ((path (eshell-get-path t)))
(if args
(progn
diff --git a/lisp/eshell/esh-io.el b/lisp/eshell/esh-io.el
index 1c3262aa49d..4487389bf26 100644
--- a/lisp/eshell/esh-io.el
+++ b/lisp/eshell/esh-io.el
@@ -74,6 +74,8 @@
(eval-when-compile
(require 'cl-lib))
+(declare-function eshell-interactive-print "esh-mode" (string))
+
(defgroup eshell-io nil
"Eshell's I/O management code provides a scheme for treating many
different kinds of objects -- symbols, files, buffers, etc. -- as
@@ -116,16 +118,22 @@ from executing while Emacs is redisplaying."
:group 'eshell-io)
(defcustom eshell-virtual-targets
- '(("/dev/eshell" eshell-interactive-print nil)
+ '(;; The literal string "/dev/null" is intentional here. It just
+ ;; provides compatibility so that users can redirect to
+ ;; "/dev/null" no matter the actual value of `null-device'.
+ ("/dev/null" (lambda (_mode) (throw 'eshell-null-device t)) t)
+ ("/dev/eshell" eshell-interactive-print nil)
("/dev/kill" (lambda (mode)
- (if (eq mode 'overwrite)
- (kill-new ""))
- 'eshell-kill-append) t)
+ (when (eq mode 'overwrite)
+ (kill-new ""))
+ #'eshell-kill-append)
+ t)
("/dev/clip" (lambda (mode)
- (if (eq mode 'overwrite)
- (let ((select-enable-clipboard t))
- (kill-new "")))
- 'eshell-clipboard-append) t))
+ (when (eq mode 'overwrite)
+ (let ((select-enable-clipboard t))
+ (kill-new "")))
+ #'eshell-clipboard-append)
+ t))
"Map virtual devices name to Emacs Lisp functions.
If the user specifies any of the filenames above as a redirection
target, the function in the second element will be called.
@@ -138,10 +146,8 @@ function.
The output function is then called repeatedly with single strings,
which represents successive pieces of the output of the command, until nil
-is passed, meaning EOF.
-
-NOTE: /dev/null is handled specially as a virtual target, and should
-not be added to this variable."
+is passed, meaning EOF."
+ :version "30.1"
:type '(repeat
(list (string :tag "Target")
function
@@ -164,7 +170,7 @@ describing the mode, e.g. for using with `eshell-get-target'.")
(defvar eshell-current-handles nil)
-(defvar eshell-last-command-status 0
+(defvar-local eshell-last-command-status 0
"The exit code from the last command. 0 if successful.")
(defvar eshell-last-command-result nil
@@ -190,7 +196,8 @@ describing the mode, e.g. for using with `eshell-get-target'.")
(defun eshell-parse-redirection ()
"Parse an output redirection, such as `2>' or `>&'."
- (when (not eshell-current-quoted)
+ (unless (or eshell-current-quoted
+ eshell-current-argument-plain)
(cond
;; Copying a handle (e.g. `2>&1').
((looking-at (rx (? (group digit))
@@ -291,25 +298,58 @@ describing the mode, e.g. for using with `eshell-get-target'.")
(defun eshell-create-handles
(stdout output-mode &optional stderr error-mode)
"Create a new set of file handles for a command.
-The default location for standard output and standard error will go to
-STDOUT and STDERR, respectively.
-OUTPUT-MODE and ERROR-MODE are either `overwrite', `append' or `insert';
-a nil value of mode defaults to `insert'."
+The default target for standard output and standard error will
+go to STDOUT and STDERR, respectively. OUTPUT-MODE and
+ERROR-MODE are either `overwrite', `append' or `insert'; a nil
+value of mode defaults to `insert'.
+
+The result is a vector of file handles. Each handle is of the form:
+
+ ((TARGETS . REF-COUNT) DEFAULT)
+
+TARGETS is a list of destinations for output. REF-COUNT is the
+number of references to this handle (initially 1); see
+`eshell-protect-handles' and `eshell-close-handles'. DEFAULT is
+non-nil if handle has its initial default value (always t after
+calling this function)."
(let* ((handles (make-vector eshell-number-of-handles nil))
- (output-target (eshell-get-target stdout output-mode))
- (error-target (if stderr
- (eshell-get-target stderr error-mode)
- output-target)))
- (aset handles eshell-output-handle (cons output-target 1))
- (aset handles eshell-error-handle (cons error-target 1))
+ (output-target
+ (let ((target (eshell-get-target stdout output-mode)))
+ (cons (when target (list target)) 1)))
+ (error-target
+ (if stderr
+ (let ((target (eshell-get-target stderr error-mode)))
+ (cons (when target (list target)) 1))
+ (cl-incf (cdr output-target))
+ output-target)))
+ (aset handles eshell-output-handle (list output-target t))
+ (aset handles eshell-error-handle (list error-target t))
handles))
+(defun eshell-duplicate-handles (handles &optional steal-p)
+ "Create a duplicate of the file handles in HANDLES.
+This uses the targets of each handle in HANDLES, incrementing its
+reference count by one (unless STEAL-P is non-nil). These
+targets are shared between the original set of handles and the
+new one, so the targets are only closed when the reference count
+drops to 0 (see `eshell-close-handles').
+
+This function also sets the DEFAULT field for each handle to
+t (see `eshell-create-handles'). Unlike the targets, this value
+is not shared with the original handles."
+ (let ((dup-handles (make-vector eshell-number-of-handles nil)))
+ (dotimes (idx eshell-number-of-handles)
+ (when-let ((handle (aref handles idx)))
+ (unless steal-p
+ (cl-incf (cdar handle)))
+ (aset dup-handles idx (list (car handle) t))))
+ dup-handles))
+
(defun eshell-protect-handles (handles)
"Protect the handles in HANDLES from a being closed."
(dotimes (idx eshell-number-of-handles)
- (when (aref handles idx)
- (setcdr (aref handles idx)
- (1+ (cdr (aref handles idx))))))
+ (when-let ((handle (aref handles idx)))
+ (cl-incf (cdar handle))))
handles)
(defun eshell-close-handles (&optional exit-code result handles)
@@ -327,46 +367,56 @@ the value already set in `eshell-last-command-result'."
(when result
(cl-assert (eq (car result) 'quote))
(setq eshell-last-command-result (cadr result)))
- (let ((handles (or handles eshell-current-handles)))
+ (let ((handles (or handles eshell-current-handles))
+ (succeeded (= eshell-last-command-status 0)))
(dotimes (idx eshell-number-of-handles)
- (when-let ((handle (aref handles idx)))
- (setcdr handle (1- (cdr handle)))
- (when (= (cdr handle) 0)
- (dolist (target (ensure-list (car (aref handles idx))))
- (eshell-close-target target (= eshell-last-command-status 0)))
- (setcar handle nil))))))
+ (eshell-close-handle (aref handles idx) succeeded))))
+
+(defun eshell-close-handle (handle status)
+ "Close a single HANDLE, taking refcounts into account.
+This will pass STATUS to each target for the handle, which should
+be a non-nil value on successful termination."
+ (when handle
+ (cl-assert (> (cdar handle) 0)
+ "Attempted to close a handle with 0 references")
+ (when (and (> (cdar handle) 0)
+ (= (cl-decf (cdar handle)) 0))
+ (dolist (target (caar handle))
+ (eshell-close-target target status))
+ (setcar (car handle) nil))))
(defun eshell-set-output-handle (index mode &optional target handles)
"Set handle INDEX for the current HANDLES to point to TARGET using MODE.
-If HANDLES is nil, use `eshell-current-handles'."
+If HANDLES is nil, use `eshell-current-handles'.
+
+If the handle is currently set to its default value (see
+`eshell-create-handles'), this will overwrite the targets with
+the new target. Otherwise, it will append the new target to the
+current list of targets."
(when target
- (let ((handles (or handles eshell-current-handles)))
- (if (and (stringp target)
- ;; The literal string "/dev/null" is intentional here.
- ;; It just provides compatibility so that users can
- ;; redirect to "/dev/null" no matter the actual value
- ;; of `null-device'.
- (string= target "/dev/null"))
- (aset handles index nil)
- (let ((where (eshell-get-target target mode))
- (current (car (aref handles index))))
- (if (listp current)
- (unless (member where current)
- (setq current (append current (list where))))
- (setq current (list where)))
- (if (not (aref handles index))
- (aset handles index (cons nil 1)))
- (setcar (aref handles index) current))))))
+ (let* ((handles (or handles eshell-current-handles))
+ (handle (or (aref handles index)
+ (aset handles index (list (cons nil 1) nil))))
+ (defaultp (cadr handle)))
+ (when defaultp
+ (cl-decf (cdar handle))
+ (setcar handle (cons nil 1)))
+ (catch 'eshell-null-device
+ (let ((current (caar handle))
+ (where (eshell-get-target target mode)))
+ (unless (member where current)
+ (setcar (car handle) (append current (list where))))))
+ (setcar (cdr handle) nil))))
(defun eshell-copy-output-handle (index index-to-copy &optional handles)
"Copy the handle INDEX-TO-COPY to INDEX for the current HANDLES.
If HANDLES is nil, use `eshell-current-handles'."
(let* ((handles (or handles eshell-current-handles))
(handle-to-copy (car (aref handles index-to-copy))))
- (setcar (aref handles index)
- (if (listp handle-to-copy)
- (copy-sequence handle-to-copy)
- handle-to-copy))))
+ (when handle-to-copy
+ (cl-incf (cdr handle-to-copy)))
+ (eshell-close-handle (aref handles index) nil)
+ (setcar (aref handles index) handle-to-copy)))
(defun eshell-set-all-output-handles (mode &optional target handles)
"Set output and error HANDLES to point to TARGET using MODE.
@@ -374,57 +424,6 @@ If HANDLES is nil, use `eshell-current-handles'."
(eshell-set-output-handle eshell-output-handle mode target handles)
(eshell-copy-output-handle eshell-error-handle eshell-output-handle handles))
-(defun eshell-close-target (target status)
- "Close an output TARGET, passing STATUS as the result.
-STATUS should be non-nil on successful termination of the output."
- (cond
- ((symbolp target) nil)
-
- ;; If we were redirecting to a file, save the file and close the
- ;; buffer.
- ((markerp target)
- (let ((buf (marker-buffer target)))
- (when buf ; somebody's already killed it!
- (save-current-buffer
- (set-buffer buf)
- (when eshell-output-file-buffer
- (save-buffer)
- (when (eq eshell-output-file-buffer t)
- (or status (set-buffer-modified-p nil))
- (kill-buffer buf)))))))
-
- ;; If we're redirecting to a process (via a pipe, or process
- ;; redirection), send it EOF so that it knows we're finished.
- ((eshell-processp target)
- ;; According to POSIX.1-2017, section 11.1.9, when communicating
- ;; via terminal, sending EOF causes all bytes waiting to be read
- ;; to be sent to the process immediately. Thus, if there are any
- ;; bytes waiting, we need to send EOF twice: once to flush the
- ;; buffer, and a second time to cause the next read() to return a
- ;; size of 0, indicating end-of-file to the reading process.
- ;; However, some platforms (e.g. Solaris) actually require sending
- ;; a *third* EOF. Since sending extra EOFs while the process is
- ;; running are a no-op, we'll just send the maximum we'd ever
- ;; need. See bug#56025 for further details.
- (let ((i 0)
- ;; Only call `process-send-eof' once if communicating via a
- ;; pipe (in truth, this just closes the pipe).
- (max-attempts (if (process-tty-name target 'stdin) 3 1)))
- (while (and (<= (cl-incf i) max-attempts)
- (eq (process-status target) 'run))
- (process-send-eof target))))
-
- ;; A plain function redirection needs no additional arguments
- ;; passed.
- ((functionp target)
- (funcall target status))
-
- ;; But a more complicated function redirection (which can only
- ;; happen with aliases at the moment) has arguments that need to be
- ;; passed along with it.
- ((consp target)
- (apply (car target) status (cdr target)))))
-
(defun eshell-kill-append (string)
"Call `kill-append' with STRING, if it is indeed a string."
(if (stringp string)
@@ -436,56 +435,6 @@ STATUS should be non-nil on successful termination of the output."
(let ((select-enable-clipboard t))
(kill-append string nil))))
-(defun eshell-get-target (target &optional mode)
- "Convert TARGET, which is a raw argument, into a valid output target.
-MODE is either `overwrite', `append' or `insert'; if it is omitted or nil,
-it defaults to `insert'."
- (setq mode (or mode 'insert))
- (cond
- ((stringp target)
- (let ((redir (assoc target eshell-virtual-targets)))
- (if redir
- (if (nth 2 redir)
- (funcall (nth 1 redir) mode)
- (nth 1 redir))
- (let* ((exists (get-file-buffer target))
- (buf (find-file-noselect target t)))
- (with-current-buffer buf
- (if buffer-file-read-only
- (error "Cannot write to read-only file `%s'" target))
- (setq buffer-read-only nil)
- (setq-local eshell-output-file-buffer
- (if (eq exists buf) 0 t))
- (cond ((eq mode 'overwrite)
- (erase-buffer))
- ((eq mode 'append)
- (goto-char (point-max))))
- (point-marker))))))
-
-
- ((bufferp target)
- (with-current-buffer target
- (cond ((eq mode 'overwrite)
- (erase-buffer))
- ((eq mode 'append)
- (goto-char (point-max))))
- (point-marker)))
-
- ((functionp target) nil)
-
- ((symbolp target)
- (if (eq mode 'overwrite)
- (set target nil))
- target)
-
- ((or (eshell-processp target)
- (markerp target))
- target)
-
- (t
- (error "Invalid redirection target: %s"
- (eshell-stringify target)))))
-
(defun eshell-interactive-output-p (&optional index handles)
"Return non-nil if the specified handle is bound for interactive display.
HANDLES is the set of handles to check; if nil, use
@@ -497,9 +446,9 @@ INDEX is the handle index to check. If nil, check
(let ((handles (or handles eshell-current-handles))
(index (or index eshell-output-handle)))
(if (eq index 'all)
- (and (eq (car (aref handles eshell-output-handle)) t)
- (eq (car (aref handles eshell-error-handle)) t))
- (eq (car (aref handles index)) t))))
+ (and (equal (caar (aref handles eshell-output-handle)) '(t))
+ (equal (caar (aref handles eshell-error-handle)) '(t)))
+ (equal (caar (aref handles index)) '(t)))))
(defvar eshell-print-queue nil)
(defvar eshell-print-queue-count -1)
@@ -550,71 +499,180 @@ after all printing is over with no argument."
(eshell-print object)
(eshell-print "\n"))
-(autoload 'eshell-output-filter "esh-mode")
-
-(defun eshell-output-object-to-target (object target)
- "Insert OBJECT into TARGET.
-Returns what was actually sent, or nil if nothing was sent."
- (cond
- ((functionp target)
- (funcall target object))
-
- ((symbolp target)
- (if (eq target t) ; means "print to display"
- (eshell-output-filter nil (eshell-stringify object))
- (if (not (symbol-value target))
- (set target object)
- (setq object (eshell-stringify object))
- (if (not (stringp (symbol-value target)))
- (set target (eshell-stringify
- (symbol-value target))))
- (set target (concat (symbol-value target) object)))))
-
- ((markerp target)
- (if (buffer-live-p (marker-buffer target))
- (with-current-buffer (marker-buffer target)
- (let ((moving (= (point) target)))
- (save-excursion
- (goto-char target)
- (unless (stringp object)
- (setq object (eshell-stringify object)))
- (insert-and-inherit object)
- (set-marker target (point-marker)))
- (if moving
- (goto-char target))))))
-
- ((eshell-processp target)
- (unless (stringp object)
- (setq object (eshell-stringify object)))
- (condition-case err
- (process-send-string target object)
- (error
- ;; If `process-send-string' raises an error and the process has
- ;; finished, treat it as a broken pipe. Otherwise, just
- ;; re-throw the signal.
- (if (memq (process-status target)
- '(run stop open closed))
- (signal (car err) (cdr err))
- (signal 'eshell-pipe-broken (list target))))))
-
- ((consp target)
- (apply (car target) object (cdr target))))
+(cl-defstruct (eshell-virtual-target
+ (:constructor nil)
+ (:constructor eshell-virtual-target-create (output-function)))
+ "A virtual target (see `eshell-virtual-targets')."
+ output-function)
+
+(cl-defgeneric eshell-get-target (raw-target &optional _mode)
+ "Convert RAW-TARGET, which is a raw argument, into a valid output target.
+MODE is either `overwrite', `append' or `insert'; if it is omitted or nil,
+it defaults to `insert'."
+ (error "Invalid redirection target: %s" (eshell-stringify raw-target)))
+
+(cl-defmethod eshell-get-target ((raw-target string) &optional mode)
+ "Convert a string RAW-TARGET into a valid output target using MODE.
+If TARGET is a virtual target (see `eshell-virtual-targets'),
+return an `eshell-virtual-target' instance; otherwise, return a
+marker for a file named TARGET."
+ (setq mode (or mode 'insert))
+ (if-let ((redir (assoc raw-target eshell-virtual-targets)))
+ (eshell-virtual-target-create
+ (if (nth 2 redir)
+ (funcall (nth 1 redir) mode)
+ (nth 1 redir)))
+ (let ((exists (get-file-buffer raw-target))
+ (buf (find-file-noselect raw-target t)))
+ (with-current-buffer buf
+ (when buffer-file-read-only
+ (error "Cannot write to read-only file `%s'" raw-target))
+ (setq buffer-read-only nil)
+ (setq-local eshell-output-file-buffer
+ (if (eq exists buf) 0 t))
+ (cond ((eq mode 'overwrite)
+ (erase-buffer))
+ ((eq mode 'append)
+ (goto-char (point-max))))
+ (point-marker)))))
+
+(cl-defmethod eshell-get-target ((raw-target buffer) &optional mode)
+ "Convert a buffer RAW-TARGET into a valid output target using MODE.
+This returns a marker for that buffer."
+ (with-current-buffer raw-target
+ (cond ((eq mode 'overwrite)
+ (erase-buffer))
+ ((eq mode 'append)
+ (goto-char (point-max))))
+ (point-marker)))
+
+(cl-defmethod eshell-get-target ((raw-target symbol) &optional mode)
+ "Convert a symbol RAW-TARGET into a valid output target using MODE.
+This returns RAW-TARGET, with its value initialized to nil if MODE is
+`overwrite'."
+ (when (eq mode 'overwrite)
+ (set raw-target nil))
+ raw-target)
+
+(cl-defmethod eshell-get-target ((raw-target process) &optional _mode)
+ "Convert a process RAW-TARGET into a valid output target.
+This just returns RAW-TARGET."
+ raw-target)
+
+(cl-defmethod eshell-get-target ((raw-target marker) &optional _mode)
+ "Convert a marker RAW-TARGET into a valid output target.
+This just returns RAW-TARGET."
+ raw-target)
+
+(cl-defgeneric eshell-close-target (target status)
+ "Close an output TARGET, passing STATUS as the result.
+STATUS should be non-nil on successful termination of the output.")
+
+(cl-defmethod eshell-close-target ((_target symbol) _status)
+ "Close a symbol TARGET."
+ nil)
+
+(cl-defmethod eshell-close-target ((target marker) status)
+ "Close a marker TARGET.
+If TARGET was created from a file name, save and kill the buffer.
+If status is nil, prompt before killing."
+ (when (buffer-live-p (marker-buffer target))
+ (with-current-buffer (marker-buffer target)
+ (when eshell-output-file-buffer
+ (save-buffer)
+ (when (eq eshell-output-file-buffer t)
+ (or status (set-buffer-modified-p nil))
+ (kill-buffer))))))
+
+(cl-defmethod eshell-close-target ((target process) _status)
+ "Close a process TARGET."
+ ;; According to POSIX.1-2017, section 11.1.9, when communicating via
+ ;; terminal, sending EOF causes all bytes waiting to be read to be
+ ;; sent to the process immediately. Thus, if there are any bytes
+ ;; waiting, we need to send EOF twice: once to flush the buffer, and
+ ;; a second time to cause the next read() to return a size of 0,
+ ;; indicating end-of-file to the reading process. However, some
+ ;; platforms (e.g. Solaris) actually require sending a *third* EOF.
+ ;; Since sending extra EOFs to a running process is a no-op, we'll
+ ;; just send the maximum we'd ever need. See bug#56025 for further
+ ;; details.
+ (catch 'done
+ (dotimes (_ (if (process-tty-name target 'stdin) 3 1))
+ (unless (process-live-p target)
+ (throw 'done nil))
+ (process-send-eof target))))
+
+(cl-defmethod eshell-close-target ((_target eshell-virtual-target) _status)
+ "Close a virtual TARGET."
+ nil)
+
+(cl-defgeneric eshell-output-object-to-target (object target)
+ "Output OBJECT to TARGET.
+Returns what was actually sent, or nil if nothing was sent.")
+
+(cl-defmethod eshell-output-object-to-target (object (_target (eql t)))
+ "Output OBJECT to the display."
+ (setq object (eshell-stringify object))
+ (eshell-interactive-print object))
+
+(cl-defmethod eshell-output-object-to-target (object (target symbol))
+ "Output OBJECT to the value of the symbol TARGET."
+ (if (not (symbol-value target))
+ (set target object)
+ (setq object (eshell-stringify object))
+ (if (not (stringp (symbol-value target)))
+ (set target (eshell-stringify
+ (symbol-value target))))
+ (set target (concat (symbol-value target) object)))
+ object)
+
+(cl-defmethod eshell-output-object-to-target (object (target marker))
+ "Output OBJECT to the marker TARGET."
+ (when (buffer-live-p (marker-buffer target))
+ (with-current-buffer (marker-buffer target)
+ (let ((moving (= (point) target)))
+ (save-excursion
+ (goto-char target)
+ (unless (stringp object)
+ (setq object (eshell-stringify object)))
+ (insert-and-inherit object)
+ (set-marker target (point-marker)))
+ (when moving
+ (goto-char target)))))
object)
+(cl-defmethod eshell-output-object-to-target (object (target process))
+ "Output OBJECT to the process TARGET."
+ (unless (stringp object)
+ (setq object (eshell-stringify object)))
+ (condition-case err
+ (process-send-string target object)
+ (error
+ ;; If `process-send-string' raises an error and the process has
+ ;; finished, treat it as a broken pipe. Otherwise, just re-raise
+ ;; the signal. NOTE: When running Emacs in batch mode
+ ;; (e.g. during regression tests), Emacs can abort due to SIGPIPE
+ ;; here. Maybe `process-send-string' should handle SIGPIPE even
+ ;; in batch mode (bug#66186).
+ (if (process-live-p target)
+ (signal (car err) (cdr err))
+ (signal 'eshell-pipe-broken (list target)))))
+ object)
+
+(cl-defmethod eshell-output-object-to-target (object
+ (target eshell-virtual-target))
+ "Output OBJECT to the virtual TARGET."
+ (funcall (eshell-virtual-target-output-function target) object))
+
(defun eshell-output-object (object &optional handle-index handles)
"Insert OBJECT, using HANDLE-INDEX specifically.
If HANDLE-INDEX is nil, output to `eshell-output-handle'.
HANDLES is the set of file handles to use; if nil, use
`eshell-current-handles'."
- (let ((target (car (aref (or handles eshell-current-handles)
- (or handle-index eshell-output-handle)))))
- (if (listp target)
- (while target
- (eshell-output-object-to-target object (car target))
- (setq target (cdr target)))
- (eshell-output-object-to-target object target)
- ;; Explicitly return nil to match the list case above.
- nil)))
+ (let ((targets (caar (aref (or handles eshell-current-handles)
+ (or handle-index eshell-output-handle)))))
+ (dolist (target targets)
+ (eshell-output-object-to-target object target))))
(provide 'esh-io)
;;; esh-io.el ends here
diff --git a/lisp/eshell/esh-mode.el b/lisp/eshell/esh-mode.el
index 34910126063..b15f99a0359 100644
--- a/lisp/eshell/esh-mode.el
+++ b/lisp/eshell/esh-mode.el
@@ -58,10 +58,16 @@
;;; Code:
-(require 'esh-util)
-(require 'esh-module)
+;; Load the core Eshell modules; we'll call their initialization
+;; functions below in `eshell-mode'.
+(require 'esh-arg)
(require 'esh-cmd)
-(require 'esh-arg) ;For eshell-parse-arguments
+(require 'esh-ext)
+(require 'esh-io)
+(require 'esh-module)
+(require 'esh-proc)
+(require 'esh-util)
+(require 'esh-var)
(defgroup eshell-mode nil
"This module contains code for handling input from the user."
@@ -73,6 +79,7 @@
(defcustom eshell-mode-unload-hook nil
"A hook that gets run when `eshell-mode' is unloaded."
:type 'hook)
+(make-obsolete-variable 'eshell-mode-unload-hook nil "30.1")
(defcustom eshell-mode-hook nil
"A hook that gets run when `eshell-mode' is entered."
@@ -155,7 +162,8 @@ number, if the function `eshell-truncate-buffer' is on
eshell-watch-for-password-prompt)
"Functions to call before output is displayed.
These functions are only called for output that is displayed
-interactively, and not for output which is redirected."
+interactively (see `eshell-interactive-filter'), and not for
+output which is redirected."
:type 'hook)
(defcustom eshell-preoutput-filter-functions nil
@@ -165,7 +173,10 @@ inserted. They return the string as it should be inserted."
:type 'hook)
(defcustom eshell-password-prompt-regexp
- (format "\\(%s\\)[^::៖]*[::៖]\\s *\\'" (regexp-opt password-word-equivalents))
+ (format "%s[^%s]*[%s]\\s *\\'"
+ (regexp-opt password-word-equivalents t)
+ (apply #'string password-colon-equivalents)
+ (apply #'string password-colon-equivalents))
"Regexp matching prompts for passwords in the inferior process.
This is used by `eshell-watch-for-password-prompt'."
:type 'regexp
@@ -175,6 +186,8 @@ This is used by `eshell-watch-for-password-prompt'."
"A function called from beginning of line to skip the prompt."
:type '(choice (const nil) function))
+(make-obsolete-variable 'eshell-skip-prompt-function nil "30.1")
+
(defcustom eshell-status-in-mode-line t
"If non-nil, let the user know a command is running in the mode line."
:type 'boolean)
@@ -188,6 +201,11 @@ This is used by `eshell-watch-for-password-prompt'."
(defvar eshell-first-time-p t
"A variable which is non-nil the first time Eshell is loaded.")
+(defvar eshell-non-interactive-p nil
+ "A variable which is non-nil when Eshell is not running interactively.
+Modules should use this variable so that they don't clutter
+non-interactive sessions, such as when using `eshell-command'.")
+
;; Internal Variables:
;; these are only set to nil initially for the sake of the
@@ -261,19 +279,18 @@ This is used by `eshell-watch-for-password-prompt'."
"C-c" 'eshell-command-map
"RET" #'eshell-send-input
"M-RET" #'eshell-queue-input
- "C-M-l" #'eshell-show-output
- "C-a" #'eshell-bol)
+ "C-M-l" #'eshell-show-output)
(defvar-keymap eshell-command-map
:prefix 'eshell-command-map
"M-o" #'eshell-mark-output
"M-d" #'eshell-toggle-direct-send
- "C-a" #'eshell-bol
+ "C-a" #'move-beginning-of-line
"C-b" #'eshell-backward-argument
"C-e" #'eshell-show-maximum-output
"C-f" #'eshell-forward-argument
"C-m" #'eshell-copy-old-input
- "C-o" #'eshell-kill-output
+ "C-o" #'eshell-delete-output
"C-r" #'eshell-show-output
"C-t" #'eshell-truncate-buffer
"C-u" #'eshell-kill-input
@@ -344,6 +361,9 @@ and the hook `eshell-exit-hook'."
(setq-local eshell-last-output-end (point-marker))
(setq-local eshell-last-output-block-begin (point))
+ (add-function :filter-return (local 'filter-buffer-substring-function)
+ #'eshell--unmark-string-as-output)
+
(let ((modules-list (copy-sequence eshell-modules-list)))
(setq-local eshell-modules-list modules-list))
@@ -436,7 +456,7 @@ and the hook `eshell-exit-hook'."
last-command-event))))
(defun eshell-intercept-commands ()
- (when (and (eshell-interactive-process-p)
+ (when (and eshell-foreground-command
(not (and (integerp last-input-event)
(memq last-input-event '(?\C-x ?\C-c)))))
(let ((possible-events (where-is-internal this-command))
@@ -471,7 +491,7 @@ and the hook `eshell-exit-hook'."
(defun eshell-move-argument (limit func property arg)
"Move forward ARG arguments."
(catch 'eshell-incomplete
- (eshell-parse-arguments (save-excursion (eshell-bol) (point))
+ (eshell-parse-arguments (save-excursion (beginning-of-line) (point))
(line-end-position)))
(let ((pos (save-excursion
(funcall func 1)
@@ -504,12 +524,7 @@ and the hook `eshell-exit-hook'."
(kill-ring-save begin (point))
(yank)))
-(defun eshell-bol ()
- "Go to the beginning of line, then skip past the prompt, if any."
- (interactive)
- (beginning-of-line)
- (and eshell-skip-prompt-function
- (funcall eshell-skip-prompt-function)))
+(define-obsolete-function-alias 'eshell-bol #'beginning-of-line "30.1")
(defsubst eshell-push-command-mark ()
"Push a mark at the end of the last input text."
@@ -525,9 +540,11 @@ Putting this function on `eshell-pre-command-hook' will mimic Plan 9's
(custom-add-option 'eshell-pre-command-hook #'eshell-goto-input-start)
-(defsubst eshell-interactive-print (string)
+(defun eshell-interactive-print (string)
"Print STRING to the eshell display buffer."
- (eshell-output-filter nil string))
+ (when string
+ (eshell--mark-as-output 0 (length string) string)
+ (eshell-interactive-filter nil string)))
(defsubst eshell-begin-on-new-line ()
"This function outputs a newline if not at beginning of line."
@@ -566,7 +583,7 @@ will return the parsed command."
(setq command (eshell-parse-command (cons beg end)
args t)))))
(ignore
- (message "Expecting completion of delimiter %c ..."
+ (message "Expecting completion of delimiter %s ..."
(if (listp delim)
(car delim)
delim)))
@@ -602,14 +619,14 @@ If NO-NEWLINE is non-nil, the input is sent without an implied final
newline."
(interactive "P")
;; Note that the input string does not include its terminal newline.
- (let ((proc-running-p (and (eshell-head-process)
- (not queue-p)))
- (inhibit-modification-hooks t))
- (unless (and proc-running-p
+ (let* ((proc-running-p (eshell-head-process))
+ (send-to-process-p (and proc-running-p (not queue-p)))
+ (inhibit-modification-hooks t))
+ (unless (and send-to-process-p
(not (eq (process-status
(eshell-head-process))
'run)))
- (if (or proc-running-p
+ (if (or send-to-process-p
(>= (point) eshell-last-output-end))
(goto-char (point-max))
(let ((copy (eshell-get-old-input use-region)))
@@ -617,7 +634,7 @@ newline."
(insert-and-inherit copy)))
(unless (or no-newline
(and eshell-send-direct-to-subprocesses
- proc-running-p))
+ send-to-process-p))
(insert-before-markers-and-inherit ?\n))
;; Delete and reinsert input. This seems like a no-op, except
;; for the resulting entries in the undo list: undoing this
@@ -627,7 +644,7 @@ newline."
(inhibit-read-only t))
(delete-region eshell-last-output-end (point))
(insert text))
- (if proc-running-p
+ (if send-to-process-p
(progn
(eshell-update-markers eshell-last-output-end)
(if (or eshell-send-direct-to-subprocesses
@@ -656,7 +673,8 @@ newline."
(run-hooks 'eshell-input-filter-functions)
(and (catch 'eshell-terminal
(ignore
- (if (eshell-invoke-directly cmd)
+ (if (and (not proc-running-p)
+ (eshell-invoke-directly-p cmd))
(eval cmd)
(eshell-eval-command cmd input))))
(eshell-life-is-too-much)))))
@@ -687,14 +705,14 @@ newline."
(custom-add-option 'eshell-input-filter-functions 'eshell-kill-new)
-(defun eshell-output-filter (process string)
- "Send the output from PROCESS (STRING) to the interactive display.
+(defun eshell-interactive-filter (buffer string)
+ "Send output (STRING) to the interactive display, using BUFFER.
This is done after all necessary filtering has been done."
- (let ((oprocbuf (if process (process-buffer process)
- (current-buffer)))
- (inhibit-modification-hooks t))
- (when (and string oprocbuf (buffer-name oprocbuf))
- (with-current-buffer oprocbuf
+ (unless buffer
+ (setq buffer (current-buffer)))
+ (when (and string (buffer-live-p buffer))
+ (let ((inhibit-modification-hooks t))
+ (with-current-buffer buffer
(let ((functions eshell-preoutput-filter-functions))
(while (and functions string)
(setq string (funcall (car functions) string))
@@ -814,15 +832,23 @@ This function should be in the list `eshell-output-filter-functions'."
eshell-last-output-start
eshell-last-output-end))
-(defun eshell-kill-output ()
- "Kill all output from interpreter since last input.
-Does not delete the prompt."
- (interactive)
+(defun eshell-delete-output (&optional kill)
+ "Delete all output from interpreter since last input.
+If KILL is non-nil (interactively, the prefix), save the killed text in
+the kill ring.
+
+This command does not delete the prompt."
+ (interactive "P")
(save-excursion
(goto-char (eshell-beginning-of-output))
(insert "*** output flushed ***\n")
+ (when kill
+ (copy-region-as-kill (point) (eshell-end-of-output)))
(delete-region (point) (eshell-end-of-output))))
+(define-obsolete-function-alias 'eshell-kill-output
+ #'eshell-delete-output "30.1")
+
(defun eshell-show-output (&optional arg)
"Display start of this batch of interpreter output at top of window.
Sets mark to the value of point when this command is run.
@@ -851,7 +877,7 @@ With a prefix argument, narrows region to last command output."
(if (> (point) eshell-last-output-end)
(kill-region eshell-last-output-end (point))
(let ((here (point)))
- (eshell-bol)
+ (beginning-of-line)
(kill-region (point) here))))
(defun eshell-show-maximum-output (&optional interactive)
@@ -879,17 +905,18 @@ If SCROLLBACK is non-nil, clear the scrollback contents."
(erase-buffer)))
(defun eshell-get-old-input (&optional use-current-region)
- "Return the command input on the current line."
+ "Return the command input on the current line.
+If USE-CURRENT-REGION is non-nil, return the current region."
(if use-current-region
(buffer-substring (min (point) (mark))
(max (point) (mark)))
(save-excursion
- (beginning-of-line)
- (and eshell-skip-prompt-function
- (funcall eshell-skip-prompt-function))
- (let ((beg (point)))
- (end-of-line)
- (buffer-substring beg (point))))))
+ (let ((inhibit-field-text-motion t))
+ (end-of-line))
+ (let ((inhibit-field-text-motion)
+ (end (point)))
+ (beginning-of-line)
+ (buffer-substring-no-properties (point) end)))))
(defun eshell-copy-old-input ()
"Insert after prompt old input at point as new input to be edited."
@@ -952,7 +979,7 @@ buffer's process if STRING contains a password prompt defined by
`eshell-password-prompt-regexp'.
This function could be in the list `eshell-output-filter-functions'."
- (when (eshell-interactive-process-p)
+ (when eshell-foreground-command
(save-excursion
(let ((case-fold-search t))
(goto-char eshell-last-output-block-begin)
diff --git a/lisp/eshell/esh-module.el b/lisp/eshell/esh-module.el
index 545f91d1d02..fbd5ae4b9b8 100644
--- a/lisp/eshell/esh-module.el
+++ b/lisp/eshell/esh-module.el
@@ -47,6 +47,7 @@ customizing the variable `eshell-modules-list'."
"A hook run when `eshell-module' is unloaded."
:type 'hook
:group 'eshell-module)
+(make-obsolete-variable 'eshell-module-unload-hook nil "30.1")
(defcustom eshell-modules-list
'(eshell-alias
@@ -85,20 +86,37 @@ Changes will only take effect in future Eshell buffers."
;;; Code:
+(defsubst eshell-module--feature-name (module &optional kind)
+ "Get the feature name for the specified Eshell MODULE."
+ (let ((module-name (symbol-name module))
+ (prefix (cond ((eq kind 'core) "esh-")
+ ((memq kind '(extension nil)) "em-")
+ (t (error "unknown module kind %s" kind)))))
+ (if (string-match "^eshell-\\(.*\\)" module-name)
+ (concat prefix (match-string 1 module-name))
+ (error "Invalid Eshell module name: %s" module))))
+
(defsubst eshell-using-module (module)
"Return non-nil if a certain Eshell MODULE is in use.
The MODULE should be a symbol corresponding to that module's
customization group. Example: `eshell-cmpl' for that module."
(memq module eshell-modules-list))
+(defun eshell-unload-modules (modules &optional kind)
+ "Try to unload the specified Eshell MODULES."
+ (dolist (module modules)
+ (let ((module-feature (intern (eshell-module--feature-name module kind))))
+ (when (featurep module-feature)
+ (message "Unloading %s..." (symbol-name module))
+ (condition-case-unless-debug _
+ (progn
+ (unload-feature module-feature)
+ (message "Unloading %s...done" (symbol-name module)))
+ (error (message "Unloading %s...failed" (symbol-name module))))))))
+
(defun eshell-unload-extension-modules ()
- "Unload any memory resident extension modules."
- (dolist (module (eshell-subgroups 'eshell-module))
- (if (featurep module)
- (ignore-errors
- (message "Unloading %s..." (symbol-name module))
- (unload-feature module)
- (message "Unloading %s...done" (symbol-name module))))))
+ "Try to unload all currently-loaded Eshell extension modules."
+ (eshell-unload-modules (eshell-subgroups 'eshell-module)))
(provide 'esh-module)
;;; esh-module.el ends here
diff --git a/lisp/eshell/esh-opt.el b/lisp/eshell/esh-opt.el
index 5551ed6dbe3..e6f5fc9629a 100644
--- a/lisp/eshell/esh-opt.el
+++ b/lisp/eshell/esh-opt.el
@@ -29,6 +29,11 @@
;; defined in esh-util.
(require 'esh-util)
+(defgroup eshell-opt nil
+ "Functions for argument parsing in Eshell commands."
+ :tag "Option parsing"
+ :group 'eshell)
+
(defmacro eshell-eval-using-options (name macro-args options &rest body-forms)
"Process NAME's MACRO-ARGS using a set of command line OPTIONS.
After doing so, stores settings in local symbols as declared by OPTIONS;
@@ -95,29 +100,37 @@ the new process for its value.
Lastly, any remaining arguments will be available in the locally
let-bound variable `args'."
(declare (debug (form form sexp body)))
- `(let* ((temp-args
- ,(if (memq ':preserve-args (cadr options))
- (list 'copy-tree macro-args)
- (list 'eshell-stringify-list
- (list 'flatten-tree macro-args))))
- (processed-args (eshell--do-opts ,name ,options temp-args ,macro-args))
- ,@(delete-dups
- (delq nil (mapcar (lambda (opt)
- (and (listp opt) (nth 3 opt)
- `(,(nth 3 opt) (pop processed-args))))
- ;; `options' is of the form (quote OPTS).
- (cadr options))))
- (args processed-args))
- ;; Silence unused lexical variable warning if body does not use `args'.
- (ignore args)
- ,@body-forms))
+ (let ((option-syms (eshell--get-option-symbols
+ ;; `options' is of the form (quote OPTS).
+ (cadr options))))
+ `(let* ((temp-args
+ ,(if (memq ':preserve-args (cadr options))
+ (list 'copy-tree macro-args)
+ (list 'eshell-stringify-list
+ (list 'flatten-tree macro-args))))
+ (args (eshell--do-opts ,name temp-args ,macro-args
+ ,options ',option-syms))
+ ;; Bind all the option variables. When done, `args' will
+ ;; contain any remaining positional arguments.
+ ,@(mapcar (lambda (sym) `(,sym (pop args))) option-syms))
+ ;; Silence unused lexical variable warning if body does not use `args'.
+ (ignore args)
+ ,@body-forms)))
;;; Internal Functions:
;; Documented part of the interface; see eshell-eval-using-options.
(defvar eshell--args)
-(defun eshell--do-opts (name options args orig-args)
+(defun eshell--get-option-symbols (options)
+ "Get a list of symbols for the specified OPTIONS.
+OPTIONS is a list of command-line options from
+`eshell-eval-using-options' (which see)."
+ (delete-dups
+ (delq nil (mapcar (lambda (opt) (and (listp opt) (nth 3 opt)))
+ options))))
+
+(defun eshell--do-opts (name args orig-args options option-syms)
"Helper function for `eshell-eval-using-options'.
This code doesn't really need to be macro expanded everywhere."
(require 'esh-ext)
@@ -129,10 +142,11 @@ This code doesn't really need to be macro expanded everywhere."
(if (and (= (length args) 0)
(memq ':show-usage options))
(eshell-show-usage name options)
- (setq args (eshell--process-args name args options))
+ (setq args (eshell--process-args name args options
+ option-syms))
nil))))
(when usage-msg
- (error "%s" usage-msg))))))
+ (user-error "%s" usage-msg))))))
(if ext-command
(throw 'eshell-external
(eshell-external-command ext-command orig-args))
@@ -237,7 +251,7 @@ remaining characters in SWITCH to be processed later as further short
options.
If no matching handler is found, and an :external command is defined
-(and available), it will be called; otherwise, an error will be
+\(and available), it will be called; otherwise, an error will be
triggered to say that the switch is unrecognized."
(let ((switch (eshell--split-switch switch kind))
(opts options)
@@ -264,16 +278,13 @@ triggered to say that the switch is unrecognized."
"%s: unrecognized option --%s")
name (car switch)))))))
-(defun eshell--process-args (name args options)
- "Process the given ARGS using OPTIONS."
- (let* ((seen ())
- (opt-vals (delq nil (mapcar (lambda (opt)
- (when (listp opt)
- (let ((sym (nth 3 opt)))
- (when (and sym (not (memq sym seen)))
- (push sym seen)
- (list sym)))))
- options)))
+(defun eshell--process-args (name args options option-syms)
+ "Process the given ARGS for the command NAME using OPTIONS.
+OPTION-SYMS is a list of symbols that will hold the processed arguments.
+
+Return a list of values corresponding to each element in OPTION-SYMS,
+followed by any additional positional arguments."
+ (let* ((opt-vals (mapcar #'list option-syms))
(ai 0) arg
(eshell--args args)
(pos-argument-found nil))
diff --git a/lisp/eshell/esh-proc.el b/lisp/eshell/esh-proc.el
index 5be3dec10a4..35c81f6a4b2 100644
--- a/lisp/eshell/esh-proc.el
+++ b/lisp/eshell/esh-proc.el
@@ -23,7 +23,9 @@
;;; Code:
+(require 'esh-arg)
(require 'esh-io)
+(require 'esh-util)
(defgroup eshell-proc nil
"When Eshell invokes external commands, it always does so
@@ -39,13 +41,22 @@ finish."
:version "24.1" ; removed eshell-proc-initialize
:type 'hook)
+(defcustom eshell-process-wait-time 0.05
+ "The number of seconds to delay waiting for a synchronous process."
+ :version "30.1"
+ :type 'number)
+
(defcustom eshell-process-wait-seconds 0
"The number of seconds to delay waiting for a synchronous process."
:type 'integer)
+(make-obsolete-variable 'eshell-process-wait-seconds
+ 'eshell-process-wait-time "30.1")
(defcustom eshell-process-wait-milliseconds 50
"The number of milliseconds to delay waiting for a synchronous process."
:type 'integer)
+(make-obsolete-variable 'eshell-process-wait-milliseconds
+ 'eshell-process-wait-time "30.1")
(defcustom eshell-done-messages-in-minibuffer t
"If non-nil, subjob \"Done\" messages will display in minibuffer."
@@ -96,6 +107,11 @@ information, for example."
;;; Internal Variables:
+(defvar eshell-supports-asynchronous-processes (fboundp 'make-process)
+ "Non-nil if Eshell can create asynchronous processes.")
+
+(defvar eshell-subjob-messages t
+ "Non-nil if we should print process start/end messages for subjobs.")
(defvar eshell-current-subjob-p nil)
(defvar eshell-process-list nil
@@ -107,7 +123,9 @@ subjob.
To add or remove elements of this list, see
`eshell-record-process-object' and `eshell-remove-process-entry'.")
+(declare-function eshell-reset "esh-mode" (&optional no-hooks))
(declare-function eshell-send-eof-to-process "esh-mode")
+(declare-function eshell-interactive-filter "esh-mode" (buffer string))
(declare-function eshell-tail-process "esh-cmd")
(defvar-keymap eshell-proc-mode-map
@@ -124,6 +142,7 @@ To add or remove elements of this list, see
"Function run when killing a process.
Runs `eshell-reset-after-proc' and `eshell-kill-hook', passing arguments
PROC and STATUS to functions on the latter."
+ (declare (obsolete nil "30.1"))
;; Was there till 24.1, but it is not optional.
(remove-hook 'eshell-kill-hook #'eshell-reset-after-proc)
;; Only reset the prompt if this process is running interactively.
@@ -140,34 +159,41 @@ PROC and STATUS to functions on the latter."
(defun eshell-proc-initialize () ;Called from `eshell-mode' via intern-soft!
"Initialize the process handling code."
(make-local-variable 'eshell-process-list)
+ (setq-local eshell-special-ref-alist
+ (cons
+ `("process"
+ (creation-function get-process)
+ (insertion-function eshell-insert-process)
+ (completion-function eshell-complete-process-ref))
+ eshell-special-ref-alist))
+
(eshell-proc-mode))
-(defun eshell-reset-after-proc (status)
- "Reset the command input location after a process terminates.
-The signals which will cause this to happen are matched by
-`eshell-reset-signals'."
- (when (and (stringp status)
- (string-match eshell-reset-signals status))
- (require 'esh-mode)
- (declare-function eshell-reset "esh-mode" (&optional no-hooks))
- (eshell-reset)))
+(define-obsolete-function-alias 'eshell-reset-after-proc
+ 'eshell--reset-after-signal "30.1")
+
+(defun eshell-process-active-p (process)
+ "Return non-nil if PROCESS is active.
+This is like `process-live-p', but additionally checks whether
+`eshell-sentinel' has finished all of its work yet."
+ (or (process-live-p process)
+ ;; If we have handles, this is an Eshell-managed
+ ;; process. Wait until we're 100% done and have
+ ;; cleared out the handles (see `eshell-sentinel').
+ (process-get process :eshell-handles)))
(defun eshell-wait-for-process (&rest procs)
- "Wait until PROC has successfully completed."
- (while procs
- (let ((proc (car procs)))
- (when (eshell-processp proc)
- ;; NYI: If the process gets stopped here, that's bad.
- (while (assq proc eshell-process-list)
- (if (input-pending-p)
- (discard-input))
- (sit-for eshell-process-wait-seconds
- eshell-process-wait-milliseconds))))
- (setq procs (cdr procs))))
+ "Wait until PROCS have successfully completed."
+ (dolist (proc procs)
+ (when (eshell-processp proc)
+ (while (eshell-process-active-p proc)
+ (when (input-pending-p)
+ (discard-input))
+ (sit-for eshell-process-wait-time)))))
(defalias 'eshell/wait #'eshell-wait-for-process)
-(defun eshell/jobs (&rest _args)
+(defun eshell/jobs ()
"List processes, if there are any."
(and (fboundp 'process-list)
(process-list)
@@ -210,27 +236,11 @@ and signal names."
(put 'eshell/kill 'eshell-no-numeric-conversions t)
-(defun eshell-read-process-name (prompt)
- "Read the name of a process from the minibuffer, using completion.
-The prompt will be set to PROMPT."
- (completing-read prompt
- (mapcar
- (lambda (proc)
- (cons (process-name proc) t))
- (process-list))
- nil t))
-
-(defun eshell-insert-process (process)
- "Insert the name of PROCESS into the current buffer at point."
- (interactive
- (list (get-process
- (eshell-read-process-name "Name of process: "))))
- (insert-and-inherit "#<process " (process-name process) ">"))
-
(defsubst eshell-record-process-object (object)
"Record OBJECT as now running."
- (when (and (eshell-processp object)
- eshell-current-subjob-p)
+ (when (and eshell-subjob-messages
+ eshell-current-subjob-p
+ (eshell-processp object))
(require 'esh-mode)
(declare-function eshell-interactive-print "esh-mode" (string))
(eshell-interactive-print
@@ -239,11 +249,12 @@ The prompt will be set to PROMPT."
(defun eshell-remove-process-entry (entry)
"Record the process ENTRY as fully completed."
- (if (and (eshell-processp (car entry))
- (cdr entry)
- eshell-done-messages-in-minibuffer)
- (message "[%s]+ Done %s" (process-name (car entry))
- (process-command (car entry))))
+ (when (and eshell-subjob-messages
+ eshell-done-messages-in-minibuffer
+ (eshell-processp (car entry))
+ (cdr entry))
+ (message "[%s]+ Done %s" (process-name (car entry))
+ (process-command (car entry))))
(setq eshell-process-list
(delq entry eshell-process-list)))
@@ -309,7 +320,7 @@ Used only on systems which do not support async subprocesses.")
(coding-system-change-eol-conversion locale-coding-system
'unix))))
(cond
- ((fboundp 'make-process)
+ (eshell-supports-asynchronous-processes
(unless (or ;; FIXME: It's not currently possible to use a
;; stderr process for remote files.
(file-remote-p default-directory)
@@ -323,7 +334,7 @@ Used only on systems which do not support async subprocesses.")
:name (concat (file-name-nondirectory command) "-stderr")
:buffer (current-buffer)
:filter (if (eshell-interactive-output-p eshell-error-handle)
- #'eshell-output-filter
+ #'eshell-interactive-process-filter
#'eshell-insertion-filter)
:sentinel #'eshell-sentinel))
(eshell-record-process-properties stderr-proc eshell-error-handle))
@@ -339,14 +350,25 @@ Used only on systems which do not support async subprocesses.")
:buffer (current-buffer)
:command (cons command args)
:filter (if (eshell-interactive-output-p)
- #'eshell-output-filter
+ #'eshell-interactive-process-filter
#'eshell-insertion-filter)
:sentinel #'eshell-sentinel
:connection-type conn-type
:stderr stderr-proc
:file-handler t)))
+ (eshell-debug-command 'process
+ "started external process `%s'\n\n%s" proc
+ (mapconcat (lambda (i) (shell-quote-argument i 'posix))
+ (process-command proc) " "))
(eshell-record-process-object proc)
(eshell-record-process-properties proc)
+ (when stderr-proc
+ ;; Provide a shared flag between the primary and stderr
+ ;; processes. This lets the primary process wait to clean up
+ ;; until stderr is totally finished (see `eshell-sentinel').
+ (let ((stderr-live (list t)))
+ (process-put proc :eshell-stderr-live stderr-live)
+ (process-put stderr-proc :eshell-stderr-live stderr-live)))
(run-hook-with-args 'eshell-exec-hook proc)
(when (fboundp 'process-coding-system)
(let ((coding-systems (process-coding-system proc)))
@@ -380,6 +402,8 @@ Used only on systems which do not support async subprocesses.")
(erase-buffer)
(set-buffer oldbuf)
(run-hook-with-args 'eshell-exec-hook command)
+ ;; XXX: This doesn't support sending stdout and stderr to
+ ;; separate places.
(setq exit-status
(apply #'call-process-region
(append (list eshell-last-sync-output-start (point)
@@ -400,20 +424,16 @@ Used only on systems which do not support async subprocesses.")
line (buffer-substring-no-properties lbeg lend))
(set-buffer oldbuf)
(if interact-p
- (eshell-output-filter nil line)
+ (eshell-interactive-process-filter nil line)
(eshell-output-object line))
(setq lbeg lend)
(set-buffer proc-buf))
(set-buffer oldbuf))
- (require 'esh-mode)
- (declare-function eshell-update-markers "esh-mode" (pmark))
- (defvar eshell-last-output-end) ;Defined in esh-mode.el.
- (eshell-update-markers eshell-last-output-end)
;; Simulate the effect of eshell-sentinel.
(eshell-close-handles
(if (numberp exit-status) exit-status -1)
(list 'quote (and (numberp exit-status) (= exit-status 0))))
- (eshell-kill-process-function command exit-status)
+ (run-hook-with-args 'eshell-kill-hook command exit-status)
(or (bound-and-true-p eshell-in-pipeline-p)
(setq eshell-last-sync-output-start nil))
(if (not (numberp exit-status))
@@ -421,23 +441,41 @@ Used only on systems which do not support async subprocesses.")
(setq proc t))))
proc))
+(defun eshell-interactive-process-filter (process string)
+ "Send the output from PROCESS (STRING) to the interactive display.
+This is done after all necessary filtering has been done."
+ (when string
+ (eshell-debug-command 'process
+ "received output from process `%s'\n\n%s" process string)
+ (eshell--mark-as-output 0 (length string) string)
+ (eshell-interactive-filter (if process (process-buffer process)
+ (current-buffer))
+ string)))
+
+(define-obsolete-function-alias 'eshell-output-filter
+ #'eshell-interactive-process-filter "30.1")
+
(defun eshell-insertion-filter (proc string)
"Insert a string into the eshell buffer, or a process/file/buffer.
PROC is the process for which we're inserting output. STRING is the
output."
+ (eshell-debug-command 'process
+ "received output from process `%s'\n\n%s" proc string)
(when (buffer-live-p (process-buffer proc))
(with-current-buffer (process-buffer proc)
(process-put proc :eshell-pending
(concat (process-get proc :eshell-pending)
string))
- (unless (process-get proc :eshell-busy) ; Already being handled?
- (while (process-get proc :eshell-pending)
- (let ((handles (process-get proc :eshell-handles))
- (index (process-get proc :eshell-handle-index))
- (data (process-get proc :eshell-pending)))
- (process-put proc :eshell-pending nil)
- (process-put proc :eshell-busy t)
- (unwind-protect
+ (if (process-get proc :eshell-busy)
+ (eshell-debug-command 'process "i/o busy for process `%s'" proc)
+ (unwind-protect
+ (let ((handles (process-get proc :eshell-handles))
+ (index (process-get proc :eshell-handle-index))
+ data)
+ (while (setq data (process-get proc :eshell-pending))
+ (process-put proc :eshell-pending nil)
+ (eshell-debug-command 'process
+ "forwarding output from process `%s'\n\n%s" proc data)
(condition-case nil
(eshell-output-object data index handles)
;; FIXME: We want to send SIGPIPE to the process
@@ -455,48 +493,67 @@ output."
(if (or (process-get proc 'remote-pid)
(eq system-type 'windows-nt))
(delete-process proc)
- (signal-process proc 'SIGPIPE))))
- (process-put proc :eshell-busy nil))))))))
+ (signal-process proc 'SIGPIPE))))))
+ (process-put proc :eshell-busy nil))))))
(defun eshell-sentinel (proc string)
"Generic sentinel for command processes. Reports only signals.
PROC is the process that's exiting. STRING is the exit message."
- (when (buffer-live-p (process-buffer proc))
+ (eshell-debug-command 'process
+ "sentinel for external process `%s': %S" proc string)
+ (when (and (buffer-live-p (process-buffer proc))
+ (not (string= string "run")))
(with-current-buffer (process-buffer proc)
(unwind-protect
- (unless (string= string "run")
- ;; Write the exit message if the status is abnormal and
- ;; the process is already writing to the terminal.
+ (let* ((handles (process-get proc :eshell-handles))
+ (index (process-get proc :eshell-handle-index))
+ (primary (= index eshell-output-handle))
+ (data (process-get proc :eshell-pending))
+ ;; Only get the status for the primary subprocess,
+ ;; not the pipe process (if any).
+ (status (when primary (process-exit-status proc)))
+ (stderr-live (process-get proc :eshell-stderr-live)))
+ ;; Write the exit message for the last process in the
+ ;; foreground pipeline if its status is abnormal and
+ ;; stderr is already writing to the terminal.
(when (and (eq proc (eshell-tail-process))
+ (eshell-interactive-output-p eshell-error-handle handles)
(not (string-match "^\\(finished\\|exited\\)"
string)))
- (funcall (process-filter proc) proc string))
- (let* ((handles (process-get proc :eshell-handles))
- (index (process-get proc :eshell-handle-index))
- (data (process-get proc :eshell-pending))
- ;; Only get the status for the primary subprocess,
- ;; not the pipe process (if any).
- (status (when (= index eshell-output-handle)
- (process-exit-status proc))))
- (process-put proc :eshell-pending nil)
- ;; If we're in the middle of handling output from this
- ;; process then schedule the EOF for later.
- (letrec ((finish-io
- (lambda ()
- (if (process-get proc :eshell-busy)
- (run-at-time 0 nil finish-io)
- (when data
- (ignore-error 'eshell-pipe-broken
- (eshell-output-object
- data index handles)))
- (eshell-close-handles
- status
- (when status (list 'quote (= status 0)))
- handles)))))
- (funcall finish-io))))
+ (eshell--mark-as-output 0 (length string) string)
+ (eshell-interactive-filter (process-buffer proc) string))
+ (process-put proc :eshell-pending nil)
+ ;; If we're in the middle of handling output from this
+ ;; process then schedule the EOF for later.
+ (letrec ((wait-for-stderr (and primary
+ (not (process-live-p proc))))
+ (finish-io
+ (lambda ()
+ (if (or (process-get proc :eshell-busy)
+ (and wait-for-stderr (car stderr-live)))
+ (progn
+ (eshell-debug-command 'process
+ "i/o busy for process `%s'" proc)
+ (run-at-time 0 nil finish-io))
+ (when data
+ (ignore-error eshell-pipe-broken
+ (eshell-output-object
+ data index handles)))
+ (eshell-close-handles
+ status
+ (when status (list 'quote (= status 0)))
+ handles)
+ ;; Clear the handles to mark that we're 100%
+ ;; finished with the I/O for this process.
+ (process-put proc :eshell-handles nil)
+ (eshell-debug-command 'process
+ "finished external process `%s'" proc)
+ (if primary
+ (run-hook-with-args 'eshell-kill-hook proc string)
+ (setcar stderr-live nil))))))
+ (funcall finish-io)))
(when-let ((entry (assq proc eshell-process-list)))
- (eshell-remove-process-entry entry))
- (eshell-kill-process-function proc string)))))
+ (eshell-remove-process-entry entry))))))
(defun eshell-process-interact (func &optional all query)
"Interact with a process, using PROMPT if more than one, via FUNC.
@@ -504,16 +561,14 @@ If ALL is non-nil, background processes will be interacted with as well.
If QUERY is non-nil, query the user with QUERY before calling FUNC."
(let (defunct result)
(dolist (entry eshell-process-list)
- (if (and (memq (process-status (car entry))
- '(run stop open closed))
+ (if (and (process-live-p (car entry))
(or all
(not (cdr entry)))
(or (not query)
(y-or-n-p (format-message query
(process-name (car entry))))))
(setq result (funcall func (car entry))))
- (unless (memq (process-status (car entry))
- '(run stop open closed))
+ (unless (process-live-p (car entry))
(setq defunct (cons entry defunct))))
;; clean up the process list; this can get dirty if an error
;; occurred that brought the user into the debugger, and then they
@@ -524,7 +579,7 @@ If QUERY is non-nil, query the user with QUERY before calling FUNC."
(defcustom eshell-kill-process-wait-time 5
"Seconds to wait between sending termination signals to a subprocess."
- :type 'integer)
+ :type 'number)
(defcustom eshell-kill-process-signals '(SIGINT SIGQUIT SIGKILL)
"Signals used to kill processes when an Eshell buffer exits.
@@ -587,29 +642,41 @@ See the variable `eshell-kill-processes-on-exit'."
(kill-buffer buf)))
(message nil))))
+(defun eshell--reset-after-signal (status)
+ "Reset the prompt after a signal when necessary.
+STATUS is the status associated with the signal; if
+`eshell-reset-signals' matches status, reset the prompt.
+
+This is really only useful when \"signaling\" while there's no
+foreground process. Otherwise, `eshell-resume-command' handles
+everything."
+ (when (and (stringp status)
+ (string-match eshell-reset-signals status))
+ (eshell-reset)))
+
(defun eshell-interrupt-process ()
"Interrupt a process."
(interactive)
(unless (eshell-process-interact 'interrupt-process)
- (eshell-kill-process-function nil "interrupt")))
+ (eshell--reset-after-signal "interrupt\n")))
(defun eshell-kill-process ()
"Kill a process."
(interactive)
(unless (eshell-process-interact 'kill-process)
- (eshell-kill-process-function nil "killed")))
+ (eshell--reset-after-signal "killed\n")))
(defun eshell-quit-process ()
"Send quit signal to process."
(interactive)
(unless (eshell-process-interact 'quit-process)
- (eshell-kill-process-function nil "quit")))
+ (eshell--reset-after-signal "quit\n")))
;(defun eshell-stop-process ()
; "Send STOP signal to process."
; (interactive)
; (unless (eshell-process-interact 'stop-process)
-; (eshell-kill-process-function nil "stopped")))
+; (eshell--reset-after-signal "stopped\n")))
;(defun eshell-continue-process ()
; "Send CONTINUE signal to process."
@@ -618,7 +685,32 @@ See the variable `eshell-kill-processes-on-exit'."
; ;; jww (1999-09-17): this signal is not dealt with yet. For
; ;; example, `eshell-reset' will be called, and so will
; ;; `eshell-resume-eval'.
-; (eshell-kill-process-function nil "continue")))
+; (eshell--reset-after-signal "continue\n")))
+
+;;; Special references
+
+(defun eshell-read-process-name (prompt)
+ "Read the name of a process from the minibuffer, using completion.
+The prompt will be set to PROMPT."
+ (completing-read prompt
+ (mapcar
+ (lambda (proc)
+ (cons (process-name proc) t))
+ (process-list))
+ nil t))
+
+(defun eshell-insert-process (process)
+ "Insert the name of PROCESS into the current buffer at point."
+ (interactive
+ (list (get-process
+ (eshell-read-process-name "Name of process: "))))
+ (insert-and-inherit "#<process "
+ (eshell-quote-argument (process-name process))
+ ">"))
+
+(defun eshell-complete-process-ref ()
+ "Perform completion for process references."
+ (pcomplete-here (mapcar #'process-name (process-list))))
(provide 'esh-proc)
;;; esh-proc.el ends here
diff --git a/lisp/eshell/esh-util.el b/lisp/eshell/esh-util.el
index 163577f5d08..129134814e3 100644
--- a/lisp/eshell/esh-util.el
+++ b/lisp/eshell/esh-util.el
@@ -94,13 +94,6 @@ a non-nil value, will be passed strings, not numbers, even when an
argument matches `eshell-number-regexp'."
:type 'boolean)
-(defcustom eshell-number-regexp "-?\\([0-9]*\\.\\)?[0-9]+\\(e[-0-9.]+\\)?"
- "Regular expression used to match numeric arguments.
-If `eshell-convert-numeric-arguments' is non-nil, and an argument
-matches this regexp, it will be converted to a Lisp number, using the
-function `string-to-number'."
- :type 'regexp)
-
(defcustom eshell-ange-ls-uids nil
"List of user/host/id strings, used to determine remote ownership."
:type '(repeat (cons :tag "Host for User/UID map"
@@ -109,8 +102,34 @@ function `string-to-number'."
(string :tag "Username")
(repeat :tag "UIDs" string))))))
+(defcustom eshell-debug-command nil
+ "A list of debug features to enable when running Eshell commands.
+Possible entries are `form', to log the manipulation of Eshell
+command forms, and `process', to log external process operations.
+
+If nil, don't debug commands at all."
+ :version "30.1"
+ :type '(set (const :tag "Form manipulation" form)
+ (const :tag "Process operations" process)))
+
;;; Internal Variables:
+(defvar eshell-number-regexp
+ (rx (? "-")
+ (or (seq (+ digit) (? "." (* digit)))
+ (seq (* digit) "." (+ digit)))
+ ;; Optional exponent
+ (? (or "e" "E")
+ (or "+INF" "+NaN"
+ (seq (? (or "+" "-")) (+ digit)))))
+ "Regular expression used to match numeric arguments.
+If `eshell-convert-numeric-arguments' is non-nil, and an argument
+matches this regexp, it will be converted to a Lisp number, using the
+function `string-to-number'.")
+
+(defvar eshell-integer-regexp (rx (? "-") (+ digit))
+ "Regular expression used to match integer arguments.")
+
(defvar eshell-group-names nil
"A cache to hold the names of groups.")
@@ -123,6 +142,22 @@ function `string-to-number'."
(defvar eshell-user-timestamp nil
"A timestamp of when the user file was read.")
+(defvar eshell-command-output-properties
+ `( field command-output
+ front-sticky (field)
+ rear-nonsticky (field)
+ ;; Text inserted by a user in the middle of process output
+ ;; should be marked as output. This is needed for commands
+ ;; such as `yank' or `just-one-space' which don't use
+ ;; `insert-and-inherit' and thus bypass default text property
+ ;; inheritance.
+ insert-in-front-hooks (,#'eshell--mark-as-output
+ ,#'eshell--mark-yanked-as-output))
+ "A list of text properties to apply to command output.")
+
+(defvar eshell-debug-command-buffer "*eshell last cmd*"
+ "The name of the buffer to log debug messages about command invocation.")
+
;;; Obsolete variables:
(define-obsolete-variable-alias 'eshell-host-names
@@ -142,11 +177,113 @@ function `string-to-number'."
"If `eshell-handle-errors' is non-nil, this is `condition-case'.
Otherwise, evaluates FORM with no error handling."
(declare (indent 2) (debug (sexp form &rest form)))
- (if eshell-handle-errors
- `(condition-case-unless-debug ,tag
- ,form
- ,@handlers)
- form))
+ `(if eshell-handle-errors
+ (condition-case-unless-debug ,tag
+ ,form
+ ,@handlers)
+ ,form))
+
+(defun eshell-debug-command-start (command)
+ "Start debugging output for the command string COMMAND.
+If debugging is enabled (see `eshell-debug-command'), this will
+start logging to `*eshell last cmd*'."
+ (when eshell-debug-command
+ (with-current-buffer (get-buffer-create eshell-debug-command-buffer)
+ (erase-buffer)
+ (insert "command: \"" command "\"\n"))))
+
+(defun eshell-always-debug-command (kind string &rest objects)
+ "Output a debugging message to `*eshell last cmd*'.
+KIND is the kind of message to log. STRING and OBJECTS are as
+`format-message' (which see)."
+ (declare (indent 1))
+ (with-current-buffer (get-buffer-create eshell-debug-command-buffer)
+ (insert "\n\C-l\n[" (symbol-name kind) "] "
+ (apply #'format-message string objects))))
+
+(defmacro eshell-debug-command (kind string &rest objects)
+ "Output a debugging message to `*eshell last cmd*' if debugging is enabled.
+KIND is the kind of message to log (either `form' or `process'). If
+present in `eshell-debug-command', output this message; otherwise, ignore it.
+
+STRING and OBJECTS are as `format-message' (which see)."
+ (declare (indent 1))
+ (let ((kind-sym (make-symbol "kind")))
+ `(let ((,kind-sym ,kind))
+ (when (memq ,kind-sym eshell-debug-command)
+ (eshell-always-debug-command ,kind-sym ,string ,@objects)))))
+
+(defun eshell--mark-as-output (start end &optional object)
+ "Mark the text from START to END as Eshell output.
+OBJECT can be a buffer or string. If nil, mark the text in the
+current buffer."
+ (with-silent-modifications
+ (add-text-properties start end eshell-command-output-properties
+ object)))
+
+(defun eshell--mark-yanked-as-output (start end)
+ "Mark yanked text from START to END as Eshell output."
+ ;; `yank' removes the field text property from the text it inserts
+ ;; due to `yank-excluded-properties', so arrange for this text
+ ;; property to be reapplied in the `after-change-functions'.
+ (letrec ((hook
+ (lambda (start1 end1 _len1)
+ (remove-hook 'after-change-functions hook t)
+ (when (and (= start start1)
+ (= end end1))
+ (eshell--mark-as-output start1 end1)))))
+ (add-hook 'after-change-functions hook nil t)))
+
+(defun eshell--unmark-string-as-output (string)
+ "Unmark STRING as Eshell output."
+ (remove-list-of-text-properties
+ 0 (length string)
+ '(rear-nonsticky front-sticky field insert-in-front-hooks)
+ string)
+ string)
+
+(defsubst eshell--region-p (object)
+ "Return non-nil if OBJECT is a pair of numbers or markers."
+ (and (consp object)
+ (number-or-marker-p (car object))
+ (number-or-marker-p (cdr object))))
+
+(defmacro eshell-with-temp-command (command &rest body)
+ "Temporarily insert COMMAND into the buffer and execute the forms in BODY.
+
+COMMAND can be a string to insert, a cons cell (START . END)
+specifying a region in the current buffer, or (:file . FILENAME)
+to temporarily insert the contents of FILENAME.
+
+Before executing BODY, narrow the buffer to the text for COMMAND
+and and set point to the beginning of the narrowed region.
+
+The value returned is the last form in BODY."
+ (declare (indent 1))
+ (let ((command-sym (make-symbol "command"))
+ (begin-sym (make-symbol "begin"))
+ (end-sym (make-symbol "end")))
+ `(let ((,command-sym ,command))
+ (if (eshell--region-p ,command-sym)
+ (save-restriction
+ (narrow-to-region (car ,command-sym) (cdr ,command-sym))
+ (goto-char (car ,command-sym))
+ ,@body)
+ ;; Since parsing relies partly on buffer-local state
+ ;; (e.g. that of `eshell-parse-argument-hook'), we need to
+ ;; perform the parsing in the Eshell buffer.
+ (let ((,begin-sym (point)) ,end-sym)
+ (with-silent-modifications
+ (if (stringp ,command-sym)
+ (insert ,command-sym)
+ (forward-char (cadr (insert-file-contents (cdr ,command-sym)))))
+ (setq ,end-sym (point))
+ (unwind-protect
+ (save-restriction
+ (narrow-to-region ,begin-sym ,end-sym)
+ (goto-char ,begin-sym)
+ ,@body)
+ (delete-region ,begin-sym ,end-sym))))))))
(defun eshell-find-delimiter
(open close &optional bound reverse-p backslash-p)
@@ -310,29 +447,34 @@ Prepend remote identification of `default-directory', if any."
(parse-colon-path path-env))
(parse-colon-path path-env))))
-(defun eshell-split-path (path)
- "Split a path into multiple subparts."
- (let ((len (length path))
- (i 0) (li 0)
- parts)
- (if (and (eshell-under-windows-p)
- (> len 2)
- (eq (aref path 0) ?/)
- (eq (aref path 1) ?/))
- (setq i 2))
- (while (< i len)
- (if (and (eq (aref path i) ?/)
- (not (get-text-property i 'escaped path)))
- (setq parts (cons (if (= li i) "/"
- (substring path li (1+ i))) parts)
- li (1+ i)))
- (setq i (1+ i)))
- (if (< li i)
- (setq parts (cons (substring path li i) parts)))
- (if (and (eshell-under-windows-p)
- (string-match "\\`[A-Za-z]:\\'" (car (last parts))))
- (setcar (last parts) (concat (car (last parts)) "/")))
- (nreverse parts)))
+(defun eshell-split-filename (filename)
+ "Split a FILENAME into a list of file/directory components."
+ (let* ((remote (file-remote-p filename))
+ (filename (file-local-name filename))
+ (len (length filename))
+ (index 0) (curr-start 0)
+ parts)
+ (when (and (eshell-under-windows-p)
+ (string-prefix-p "//" filename))
+ (setq index 2))
+ (while (< index len)
+ (when (and (eq (aref filename index) ?/)
+ (not (get-text-property index 'escaped filename)))
+ (push (if (= curr-start index) "/"
+ (substring filename curr-start (1+ index)))
+ parts)
+ (setq curr-start (1+ index)))
+ (setq index (1+ index)))
+ (when (< curr-start len)
+ (push (substring filename curr-start) parts))
+ (setq parts (nreverse parts))
+ (when (and (eshell-under-windows-p)
+ (string-match "\\`[A-Za-z]:\\'" (car parts)))
+ (setcar parts (concat (car parts) "/")))
+ (if remote (cons remote parts) parts)))
+
+(define-obsolete-function-alias 'eshell-split-path
+ 'eshell-split-filename "30.1")
(defun eshell-to-flat-string (value)
"Make value a string. If separated by newlines change them to spaces."
@@ -362,9 +504,13 @@ Prepend remote identification of `default-directory', if any."
"Convert each element of ARGS into a string value."
(mapcar #'eshell-stringify args))
+(defsubst eshell-list-to-string (list)
+ "Convert LIST into a single string separated by spaces."
+ (mapconcat #'eshell-stringify list " "))
+
(defsubst eshell-flatten-and-stringify (&rest args)
"Flatten and stringify all of the ARGS into a single string."
- (mapconcat #'eshell-stringify (flatten-tree args) " "))
+ (eshell-list-to-string (flatten-tree args)))
(defsubst eshell-directory-files (regexp &optional directory)
"Return a list of files in the given DIRECTORY matching REGEXP."
@@ -386,37 +532,21 @@ Prepend remote identification of `default-directory', if any."
(defun eshell-printable-size (filesize &optional human-readable
block-size use-colors)
"Return a printable FILESIZE."
+ (when (and human-readable
+ (not (= human-readable 1000))
+ (not (= human-readable 1024)))
+ (error "human-readable must be 1000 or 1024"))
(let ((size (float (or filesize 0))))
(if human-readable
- (if (< size human-readable)
- (if (= (round size) 0)
- "0"
- (if block-size
- "1.0k"
- (format "%.0f" size)))
- (setq size (/ size human-readable))
- (if (< size human-readable)
- (if (<= size 9.94)
- (format "%.1fk" size)
- (format "%.0fk" size))
- (setq size (/ size human-readable))
- (if (< size human-readable)
- (let ((str (if (<= size 9.94)
- (format "%.1fM" size)
- (format "%.0fM" size))))
- (if use-colors
- (put-text-property 0 (length str)
- 'face 'bold str))
- str)
- (setq size (/ size human-readable))
- (if (< size human-readable)
- (let ((str (if (<= size 9.94)
- (format "%.1fG" size)
- (format "%.0fG" size))))
- (if use-colors
- (put-text-property 0 (length str)
- 'face 'bold-italic str))
- str)))))
+ (let* ((flavor (and (= human-readable 1000) 'si))
+ (str (file-size-human-readable size flavor)))
+ (if (not use-colors)
+ str
+ (cond ((> size (expt human-readable 3))
+ (propertize str 'face 'bold-italic))
+ ((> size (expt human-readable 2))
+ (propertize str 'face 'bold))
+ (t str))))
(if block-size
(setq size (/ size block-size)))
(format "%.0f" size))))
@@ -445,15 +575,10 @@ list."
(cadr flist)
(cdr flist))))
-(defsubst eshell-redisplay ()
- "Allow Emacs to redisplay buffers."
- ;; for some strange reason, Emacs 21 is prone to trigger an
- ;; "args out of range" error in `sit-for', if this function
- ;; runs while point is in the minibuffer and the users attempt
- ;; to use completion. Don't ask me.
- (condition-case nil
- (sit-for 0)
- (error nil)))
+(defun eshell-user-login-name ()
+ "Return the connection-aware value of the user's login name.
+See also `user-login-name'."
+ (or (file-remote-p default-directory 'user) (user-login-name)))
(defun eshell-read-passwd-file (file)
"Return an alist correlating gids to group names in FILE."
@@ -576,8 +701,6 @@ list."
(setq host-users (cdr host-users))
(cdr (assoc user host-users))))))
-(autoload 'parse-time-string "parse-time")
-
(eval-when-compile
(require 'ange-ftp)) ; ange-ftp-parse-filename
@@ -671,19 +794,18 @@ gid format. Valid values are `string' and `integer', defaulting to
"If the `processp' function does not exist, PROC is not a process."
(and (fboundp 'processp) (processp proc)))
-(defun eshell-process-pair-p (procs)
- "Return non-nil if PROCS is a pair of process objects."
- (and (consp procs)
- (eshell-processp (car procs))
- (eshell-processp (cdr procs))))
+(defun eshell-process-list-p (procs)
+ "Return non-nil if PROCS is a list of process objects."
+ (and (listp procs)
+ (seq-every-p #'eshell-processp procs)))
-(defun eshell-make-process-pair (procs)
- "Make a pair of process objects from PROCS if possible.
-This represents the head and tail of a pipeline of processes,
-where the head and tail may be the same process."
+(defun eshell-make-process-list (procs)
+ "Make a list of process objects from PROCS if possible.
+PROCS can be a single process or a list thereof. If PROCS is
+anything else, return nil instead."
(pcase procs
- ((pred eshell-processp) (cons procs procs))
- ((pred eshell-process-pair-p) procs)))
+ ((pred eshell-processp) (list procs))
+ ((pred eshell-process-list-p) procs)))
;; (defun eshell-copy-file
;; (file newname &optional ok-if-already-exists keep-date)
@@ -761,6 +883,8 @@ If N or M is nil, it means the end of the list."
(declare (obsolete seq-subseq "28.1"))
(seq-subseq l n (1+ m)))
+(define-obsolete-function-alias 'eshell-redisplay #'redisplay "30.1")
+
(provide 'esh-util)
;;; esh-util.el ends here
diff --git a/lisp/eshell/esh-var.el b/lisp/eshell/esh-var.el
index 55552843c88..02b5c785625 100644
--- a/lisp/eshell/esh-var.el
+++ b/lisp/eshell/esh-var.el
@@ -86,6 +86,13 @@
;; Returns the length of the value of $EXPR. This could also be
;; done using the `length' Lisp function.
;;
+;; $@EXPR
+;;
+;; Splices the value of $EXPR in-place into the current list of
+;; arguments. This is analogous to the `,@' token in Elisp
+;; backquotes, and works as if the user typed '$EXPR[0] $EXPR[1]
+;; ... $EXPR[N]'.
+;;
;; There are also a few special variables defined by Eshell. '$$' is
;; the value of the last command (t or nil, in the case of an external
;; command). This makes it possible to chain results:
@@ -155,6 +162,15 @@ if they are quoted with a backslash."
("COLUMNS" ,(lambda () (window-body-width nil 'remap)) t t)
("LINES" ,(lambda () (window-body-height nil 'remap)) t t)
("INSIDE_EMACS" eshell-inside-emacs t)
+ ("PAGER" (,(lambda () (or comint-pager (getenv "PAGER")))
+ . ,(lambda (_ value)
+ ;; When unsetting PAGER, be sure to clear its value
+ ;; from `process-environment' too.
+ (unless value (setenv "PAGER"))
+ (setq comint-pager value)))
+ t t)
+ ("UID" ,(lambda () (file-user-uid)) nil t)
+ ("GID" ,(lambda () (file-group-gid)) nil t)
;; for esh-ext.el
("PATH" (,(lambda () (string-join (eshell-get-path t) (path-separator)))
@@ -239,6 +255,20 @@ copied (a.k.a. \"exported\") to the environment of created subprocesses."
(defvar-keymap eshell-var-mode-map
"C-c M-v" #'eshell-insert-envvar)
+;;; Internal Variables:
+
+(defvar eshell-in-local-scope-p nil
+ "Non-nil if the current command has a local variable scope.
+This is set to t in `eshell-local-variable-bindings' (which see).")
+
+(defvar eshell-local-variable-bindings
+ '((eshell-in-local-scope-p t)
+ (process-environment (eshell-copy-environment))
+ (eshell-variable-aliases-list eshell-variable-aliases-list)
+ (eshell-path-env-list eshell-path-env-list)
+ (comint-pager comint-pager))
+ "A list of `let' bindings for local variable (and subcommand) environments.")
+
;;; Functions:
(define-minor-mode eshell-var-mode
@@ -253,12 +283,12 @@ copied (a.k.a. \"exported\") to the environment of created subprocesses."
;; changing a variable will affect all of Emacs.
(unless eshell-modify-global-environment
(setq-local process-environment (eshell-copy-environment)))
+ (make-local-variable 'comint-pager)
(setq-local eshell-subcommand-bindings
- (append
- '((process-environment (eshell-copy-environment))
- (eshell-variable-aliases-list eshell-variable-aliases-list)
- (eshell-path-env-list eshell-path-env-list))
- eshell-subcommand-bindings))
+ (append eshell-local-variable-bindings
+ eshell-subcommand-bindings))
+ (setq-local eshell-complex-commands
+ (append '("env") eshell-complex-commands))
(setq-local eshell-special-chars-inside-quoting
(append eshell-special-chars-inside-quoting '(?$)))
@@ -276,54 +306,44 @@ copied (a.k.a. \"exported\") to the environment of created subprocesses."
(add-hook 'pcomplete-try-first-hook
#'eshell-complete-variable-assignment nil t)))
+(defun eshell-parse-local-variables (args)
+ "Parse a list of ARGS, looking for variable assignments.
+Variable assignments are of the form \"VAR=value\". If ARGS
+begins with any such assignments, throw `eshell-replace-command'
+with a form that will temporarily set those variables.
+Otherwise, return nil."
+ ;; Handle local variable settings by let-binding the entries in
+ ;; `eshell-local-variable-bindings' and calling `eshell-set-variable'
+ ;; for each variable before the command is invoked.
+ (let ((setvar "\\`\\([A-Za-z_][A-Za-z0-9_]*\\)=\\(.*\\)\\'")
+ (head (car args))
+ (rest (cdr args)))
+ (when (and (stringp head) (string-match setvar head))
+ (throw 'eshell-replace-command
+ `(let ,eshell-local-variable-bindings
+ ,@(let (locals)
+ (while (and (stringp head)
+ (string-match setvar head))
+ (push `(eshell-set-variable
+ ,(match-string 1 head)
+ ,(match-string 2 head))
+ locals)
+ (setq head (pop rest)))
+ (nreverse locals))
+ (eshell-named-command ,head ',rest))))))
+
(defun eshell-handle-local-variables ()
"Allow for the syntax `VAR=val <command> <args>'."
- ;; strip off any null commands, which can only happen if a variable
- ;; evaluates to nil, such as "$var x", where `var' is nil. The
- ;; command name in that case becomes `x', for compatibility with
- ;; most regular shells (the difference is that they do an
- ;; interpolation pass before the argument parsing pass, but Eshell
- ;; does both at the same time).
- (while (and (not eshell-last-command-name)
- eshell-last-arguments)
- (setq eshell-last-command-name (car eshell-last-arguments)
- eshell-last-arguments (cdr eshell-last-arguments)))
- (let ((setvar "\\`\\([A-Za-z_][A-Za-z0-9_]*\\)=\\(.*\\)\\'")
- (command (eshell-stringify eshell-last-command-name))
- (args eshell-last-arguments))
- ;; local variable settings (such as 'CFLAGS=-O2 make') are handled
- ;; by making the whole command into a subcommand, and calling
- ;; setenv immediately before the command is invoked. This means
- ;; that 'BLAH=x cd blah' won't work exactly as expected, but that
- ;; is by no means a typical use of local environment variables.
- (if (and command (string-match setvar command))
- (throw
- 'eshell-replace-command
- (list
- 'eshell-as-subcommand
- (append
- (list 'progn)
- (let ((l (list t)))
- (while (string-match setvar command)
- (nconc
- l (list
- (list 'eshell-set-variable
- (match-string 1 command)
- (match-string 2 command))))
- (setq command (eshell-stringify (car args))
- args (cdr args)))
- (cdr l))
- (list (list 'eshell-named-command
- command (list 'quote args)))))))))
+ (eshell-parse-local-variables (cons eshell-last-command-name
+ eshell-last-arguments)))
(defun eshell-interpolate-variable ()
"Parse a variable interpolation.
This function is explicit for adding to `eshell-parse-argument-hook'."
(when (and (eq (char-after) ?$)
- (/= (1+ (point)) (point-max)))
+ (/= (1+ (point)) (point-max)))
(forward-char)
- (list 'eshell-escape-arg
- (eshell-parse-variable))))
+ (eshell-parse-variable)))
(defun eshell/define (var-alias definition)
"Define a VAR-ALIAS using DEFINITION."
@@ -405,19 +425,22 @@ the values of nil for each."
obarray #'boundp))
(pcomplete-here))))
-;; FIXME the real "env" command does more than this, it runs a program
-;; in a modified environment.
(defun eshell/env (&rest args)
"Implementation of `env' in Lisp."
- (eshell-init-print-buffer)
(eshell-eval-using-options
"env" args
- '((?h "help" nil nil "show this usage screen")
+ '(;; FIXME: Support more "env" options, like "--unset".
+ (?h "help" nil nil "show this usage screen")
:external "env"
- :usage "<no arguments>")
- (dolist (setting (sort (eshell-environment-variables) 'string-lessp))
- (eshell-buffered-print setting "\n"))
- (eshell-flush)))
+ :parse-leading-options-only
+ :usage "[NAME=VALUE]... [COMMAND]...")
+ (if args
+ (or (eshell-parse-local-variables args)
+ (eshell-named-command (car args) (cdr args)))
+ (eshell-init-print-buffer)
+ (dolist (setting (sort (eshell-environment-variables) 'string-lessp))
+ (eshell-buffered-print setting "\n"))
+ (eshell-flush))))
(defun eshell-insert-envvar (envvar-name)
"Insert ENVVAR-NAME into the current buffer at point."
@@ -427,9 +450,14 @@ the values of nil for each."
(defun eshell-envvar-names (&optional environment)
"Return a list of currently visible environment variable names."
- (mapcar (lambda (x)
- (substring x 0 (string-search "=" x)))
- (or environment process-environment)))
+ (delete-dups
+ (append
+ ;; Real environment variables
+ (mapcar (lambda (x)
+ (substring x 0 (string-search "=" x)))
+ (or environment process-environment))
+ ;; Eshell variable aliases
+ (mapcar #'car eshell-variable-aliases-list))))
(defun eshell-environment-variables ()
"Return a `process-environment', fully updated.
@@ -453,18 +481,24 @@ Its purpose is to call `eshell-parse-variable-ref', and then to
process any indices that come after the variable reference."
(let* ((get-len (when (eq (char-after) ?#)
(forward-char) t))
+ (splice (when (eq (char-after) ?@)
+ (forward-char) t))
value indices)
(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))
+ value `(let ((indices ,(eshell-prepare-indices indices))) ,value))
(when get-len
(setq value `(length ,value)))
(when eshell-current-quoted
- (setq value `(eshell-stringify ,value)))
+ (if splice
+ (setq value `(eshell-list-to-string ,value)
+ splice nil)
+ (setq value `(eshell-stringify ,value))))
+ (setq value `(eshell-escape-arg ,value))
+ (when splice
+ (setq value `(eshell-splice-args ,value)))
value))
(defun eshell-parse-variable-ref (&optional modifier-p)
@@ -481,7 +515,7 @@ 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
<COMMAND> write the output of command to a temporary file;
@@ -489,55 +523,56 @@ Possible variable references are:
(cond
((eq (char-after) ?{)
(let ((end (eshell-find-delimiter ?\{ ?\})))
- (if (not end)
- (throw 'eshell-incomplete ?\{)
- (forward-char)
- (prog1
- `(eshell-apply-indices
- (eshell-convert
- (eshell-command-to-value
- (eshell-as-subcommand
- ,(let ((subcmd (or (eshell-unescape-inner-double-quote end)
- (cons (point) end)))
- (eshell-current-quoted nil))
- (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))))))
+ (unless end
+ (throw 'eshell-incomplete "${"))
+ (forward-char)
+ (prog1
+ `(eshell-apply-indices
+ (eshell-convert
+ (eshell-command-to-value
+ (eshell-as-subcommand
+ ,(let ((subcmd (or (eshell-unescape-inner-double-quote end)
+ (cons (point) end)))
+ (eshell-current-quoted nil))
+ (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 ?\< ?\>)))
- (if (not end)
- (throw 'eshell-incomplete ?\<)
- (let* ((temp (make-temp-file temporary-file-directory))
- (cmd (concat (buffer-substring (1+ (point)) end)
- " > " temp)))
- (prog1
- `(let ((eshell-current-handles
- (eshell-create-handles ,temp 'overwrite)))
- (progn
- (eshell-as-subcommand
- ,(let ((eshell-current-quoted nil))
- (eshell-parse-command cmd)))
- (ignore
- (nconc eshell-this-command-hook
- ;; Quote this lambda; it will be evaluated
- ;; by `eshell-do-eval', which requires very
- ;; particular forms in order to work
- ;; properly. See bug#54190.
- (list (function
- (lambda ()
- (delete-file ,temp)
- (when-let ((buffer (get-file-buffer ,temp)))
- (kill-buffer buffer)))))))
- (eshell-apply-indices ,temp indices ,eshell-current-quoted)))
- (goto-char (1+ end)))))))
+ (unless end
+ (throw 'eshell-incomplete "$<"))
+ (forward-char)
+ (let* ((temp (make-temp-file temporary-file-directory))
+ (subcmd (or (eshell-unescape-inner-double-quote end)
+ (cons (point) end))))
+ (prog1
+ `(let ((eshell-current-handles
+ (eshell-create-handles ,temp 'overwrite)))
+ (progn
+ (eshell-as-subcommand
+ ,(let ((eshell-current-quoted nil))
+ (eshell-parse-command subcmd)))
+ (ignore
+ (nconc eshell-this-command-hook
+ ;; Quote this lambda; it will be evaluated by
+ ;; `eshell-do-eval', which requires very
+ ;; particular forms in order to work
+ ;; properly. See bug#54190.
+ (list (function
+ (lambda ()
+ (delete-file ,temp)
+ (when-let ((buffer (get-file-buffer ,temp)))
+ (kill-buffer buffer)))))))
+ (eshell-apply-indices ,temp indices ,eshell-current-quoted)))
+ (goto-char (1+ end))))))
((eq (char-after) ?\()
(condition-case nil
`(eshell-apply-indices
@@ -547,15 +582,19 @@ Possible variable references are:
(current-buffer)))))
indices ,eshell-current-quoted)
(end-of-file
- (throw 'eshell-incomplete ?\())))
+ (throw 'eshell-incomplete "$("))))
((looking-at (rx-to-string
`(or "'" ,(if eshell-current-quoted "\\\"" "\""))))
(eshell-with-temp-command
(or (eshell-unescape-inner-double-quote (point-max))
(cons (point) (point-max)))
- (let ((name (if (eq (char-after) ?\')
- (eshell-parse-literal-quote)
- (eshell-parse-double-quote))))
+ (let (name)
+ (when-let ((delim
+ (catch 'eshell-incomplete
+ (ignore (setq name (if (eq (char-after) ?\')
+ (eshell-parse-literal-quote)
+ (eshell-parse-double-quote)))))))
+ (throw 'eshell-incomplete (concat "$" delim)))
(when name
`(eshell-get-variable ,(eval name) indices ,eshell-current-quoted)))))
((assoc (char-to-string (char-after))
@@ -574,14 +613,17 @@ Possible variable references are:
(defun eshell-parse-indices ()
"Parse and return a list of index-lists.
+This produces a series of Lisp forms to be processed by
+`eshell-prepare-indices' and ultimately evaluated by
+`eshell-do-eval'.
For example, \"[0 1][2]\" becomes:
- ((\"0\" \"1\") (\"2\")."
+ ((\"0\" \"1\") (\"2\"))."
(let (indices)
(while (eq (char-after) ?\[)
(let ((end (eshell-find-delimiter ?\[ ?\])))
(if (not end)
- (throw 'eshell-incomplete ?\[)
+ (throw 'eshell-incomplete "[")
(forward-char)
(eshell-with-temp-command (or (eshell-unescape-inner-double-quote end)
(cons (point) end))
@@ -592,10 +634,46 @@ For example, \"[0 1][2]\" becomes:
(goto-char (1+ end)))))
(nreverse indices)))
+(defun eshell-parse-index (index)
+ "Parse a single INDEX in string form.
+If INDEX looks like a number, return that number.
+
+If INDEX looks like \"[BEGIN]..[END]\", where BEGIN and END look
+like integers, return a cons cell of BEGIN and END as numbers;
+BEGIN and/or END can be omitted here, in which case their value
+in the cons is nil.
+
+Otherwise (including if INDEX is not a string), return
+the original value of INDEX."
+ (save-match-data
+ (cond
+ ((and (stringp index) (get-text-property 0 'number index))
+ (string-to-number index))
+ ((and (stringp index)
+ (not (text-property-any 0 (length index) 'escaped t index))
+ (string-match (rx string-start
+ (group-n 1 (? (regexp eshell-integer-regexp)))
+ ".."
+ (group-n 2 (? (regexp eshell-integer-regexp)))
+ string-end)
+ index))
+ (let ((begin (match-string 1 index))
+ (end (match-string 2 index)))
+ (cons (unless (string-empty-p begin) (string-to-number begin))
+ (unless (string-empty-p end) (string-to-number end)))))
+ (t
+ index))))
+
(defun eshell-eval-indices (indices)
"Evaluate INDICES, a list of index-lists generated by `eshell-parse-indices'."
+ (declare (obsolete eshell-prepare-indices "30.1"))
(mapcar (lambda (i) (mapcar #'eval i)) indices))
+(defun eshell-prepare-indices (indices)
+ "Prepare INDICES to be evaluated by Eshell.
+INDICES is a list of index-lists generated by `eshell-parse-indices'."
+ `(list ,@(mapcar (lambda (idx-list) (cons 'list idx-list)) indices)))
+
(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').
@@ -650,7 +728,7 @@ to a Lisp variable)."
((functionp target)
(funcall target nil value))
((null target)
- (unless eshell-in-subcommand-p
+ (unless eshell-in-local-scope-p
(error "Variable `%s' is not settable" (eshell-stringify name)))
(push `(,name ,(lambda () value) t t)
eshell-variable-aliases-list)
@@ -697,98 +775,123 @@ For example, to retrieve the second element of a user's record in
'/etc/passwd', the variable reference would look like:
${grep johnw /etc/passwd}[: 2]"
- (while indices
- (let ((refs (car indices)))
- (when (stringp value)
- (let (separator (index (caar indices)))
- (when (and (stringp index)
- (not (get-text-property 0 'number index)))
- (setq separator index
- refs (cdr refs)))
- (setq value (split-string value separator))
- (unless quoted
- (setq value (mapcar #'eshell-convert-to-number value)))))
- (cond
- ((< (length refs) 0)
- (error "Invalid array variable index: %s"
- (eshell-stringify refs)))
- ((= (length refs) 1)
- (setq value (eshell-index-value value (car refs))))
- (t
- (let ((new-value (list t)))
- (while refs
- (nconc new-value
- (list (eshell-index-value value
- (car refs))))
- (setq refs (cdr refs)))
- (setq value (cdr new-value))))))
- (setq indices (cdr indices)))
- value)
+ (dolist (refs indices value)
+ ;; For string values, check if the first index looks like a
+ ;; regexp, and if so, use that to split the string.
+ (when (stringp value)
+ (let (separator (first (car refs)))
+ (when (stringp (eshell-parse-index first))
+ (setq separator first
+ refs (cdr refs)))
+ (setq value (split-string value separator))
+ (unless quoted
+ (setq value (mapcar #'eshell-convert-to-number value)))))
+ (cond
+ ((< (length refs) 0)
+ (error "Invalid array variable index: %s"
+ (eshell-stringify refs)))
+ ((= (length refs) 1)
+ (setq value (eshell-index-value value (car refs))))
+ (t
+ (let (new-value)
+ (dolist (ref refs)
+ (push (eshell-index-value value ref) new-value))
+ (setq value (nreverse new-value)))))))
+
+(pcase-defmacro eshell-index-range (start end)
+ "A pattern that matches an Eshell index range.
+EXPVAL should be a cons cell, with each slot containing either an
+integer or nil. If this matches, bind the values of the sltos to
+START and END."
+ (list '\` (cons (list '\, `(and (or (pred integerp) (pred null)) ,start))
+ (list '\, `(and (or (pred integerp) (pred null)) ,end)))))
(defun eshell-index-value (value index)
"Reference VALUE using the given INDEX."
- (when (and (stringp index) (get-text-property 0 'number index))
- (setq index (string-to-number index)))
- (if (integerp index)
- (cond
- ((ring-p value)
- (if (> index (ring-length value))
- (error "Index exceeds length of ring")
- (ring-ref value index)))
- ((listp value)
- (if (> index (length value))
- (error "Index exceeds length of list")
- (nth index value)))
- ((vectorp value)
- (if (> index (length value))
- (error "Index exceeds length of vector")
- (aref value index)))
- (t
- (error "Invalid data type for indexing")))
- ;; INDEX is some non-integer value, so treat VALUE as an alist.
- (cdr (assoc index value))))
+ (let ((parsed-index (eshell-parse-index index)))
+ (if (ring-p value)
+ (pcase parsed-index
+ ((pred integerp)
+ (ring-ref value parsed-index))
+ ((eshell-index-range start end)
+ (let* ((len (ring-length value))
+ (real-start (mod (or start 0) len))
+ (real-end (mod (or end len) len)))
+ (when (and (eq real-end 0)
+ (not (eq end 0)))
+ (setq real-end len))
+ (ring-convert-sequence-to-ring
+ (seq-subseq (ring-elements value) real-start real-end))))
+ (_
+ (error "Invalid index for ring: %s" index)))
+ (pcase parsed-index
+ ((pred integerp)
+ (when (< parsed-index 0)
+ (setq parsed-index (+ parsed-index (length value))))
+ (seq-elt value parsed-index))
+ ((eshell-index-range start end)
+ (seq-subseq value (or start 0) end))
+ (_
+ ;; INDEX is some non-integer value, so treat VALUE as an alist.
+ (cdr (assoc parsed-index value)))))))
;;;_* Variable name completion
(defun eshell-complete-variable-reference ()
"If there is a variable reference, complete it."
- (let ((arg (pcomplete-actual-arg)) index)
- (when (setq index
- (string-match
- (concat "\\$\\(" eshell-variable-name-regexp
- "\\)?\\'") arg))
- (setq pcomplete-stub (substring arg (1+ index)))
+ (let ((arg (pcomplete-actual-arg)))
+ (when (string-match
+ (rx "$" (? (or "#" "@"))
+ (? (or (group-n 1 (regexp eshell-variable-name-regexp)
+ string-end)
+ (seq (group-n 2 (or "'" "\""))
+ (group-n 1 (+ anychar))))))
+ arg)
+ (setq pcomplete-stub (substring arg (match-beginning 1)))
+ (let ((delimiter (match-string 2 arg)))
+ ;; When finished with completion, insert the trailing
+ ;; delimiter, if any, and add a trailing slash if the variable
+ ;; refers to a directory.
+ (add-function
+ :before-until (var pcomplete-exit-function)
+ (lambda (variable status)
+ (when (eq status 'finished)
+ (when delimiter
+ (if (looking-at (regexp-quote delimiter))
+ (goto-char (match-end 0))
+ (insert delimiter)))
+ (let ((non-essential t)
+ (value (eshell-get-variable variable)))
+ (when (and (stringp value) (file-directory-p value))
+ (insert "/")
+ ;; Tell Pcomplete not to insert its own termination
+ ;; string.
+ t))))))
(throw 'pcomplete-completions (eshell-variables-list)))))
(defun eshell-variables-list ()
"Generate list of applicable variables."
- (let ((argname pcomplete-stub)
- completions)
- (dolist (alias eshell-variable-aliases-list)
- (if (string-match (concat "^" argname) (car alias))
- (setq completions (cons (car alias) completions))))
+ (let ((argname pcomplete-stub))
(sort
- (append
- (mapcar
- (lambda (varname)
- (let ((value (eshell-get-variable varname)))
- (if (and value
- (stringp value)
- (file-directory-p value))
- (concat varname "/")
- varname)))
- (eshell-envvar-names (eshell-environment-variables)))
- (all-completions argname obarray 'boundp)
- completions)
- 'string-lessp)))
+ (append (eshell-envvar-names)
+ (all-completions argname obarray #'boundp))
+ #'string-lessp)))
(defun eshell-complete-variable-assignment ()
"If there is a variable assignment, allow completion of entries."
- (let ((arg (pcomplete-actual-arg)) pos)
- (when (string-match (concat "\\`" eshell-variable-name-regexp "=") arg)
- (setq pos (match-end 0))
- (if (string-match "\\(:\\)[^:]*\\'" arg)
- (setq pos (match-end 1)))
+ (catch 'not-assignment
+ ;; The current argument can only be a variable assignment if all
+ ;; arguments leading up to it are also variable assignments. See
+ ;; `eshell-handle-local-variables'.
+ (dotimes (offset (1+ pcomplete-index))
+ (unless (string-match (concat "\\`" eshell-variable-name-regexp "=")
+ (pcomplete-actual-arg 'first offset))
+ (throw 'not-assignment nil)))
+ ;; We have a variable assignment. Handle it.
+ (let ((arg (pcomplete-actual-arg))
+ (pos (match-end 0)))
+ (when (string-match "\\(:\\)[^:]*\\'" arg)
+ (setq pos (match-end 1)))
(setq pcomplete-stub (substring arg pos))
(throw 'pcomplete-completions (pcomplete-entries)))))
diff --git a/lisp/eshell/eshell.el b/lisp/eshell/eshell.el
index 12074024739..7d374587dc4 100644
--- a/lisp/eshell/eshell.el
+++ b/lisp/eshell/eshell.el
@@ -199,10 +199,11 @@ shells such as bash, zsh, rc, 4dos."
:type 'hook
:group 'eshell)
-(defcustom eshell-unload-hook '(eshell-unload-all-modules)
+(defcustom eshell-unload-hook nil
"A hook run when Eshell is unloaded from memory."
:type 'hook
:group 'eshell)
+(make-obsolete-variable 'eshell-unload-hook nil "30.1")
(defcustom eshell-buffer-name "*eshell*"
"The basename used for Eshell buffers.
@@ -267,50 +268,43 @@ information on Eshell, see Info node `(eshell)Top'."
(define-obsolete-function-alias 'eshell-return-exits-minibuffer
#'eshell-command-mode "28.1")
-(defvar eshell-non-interactive-p nil
- "A variable which is non-nil when Eshell is not running interactively.
-Modules should use this variable so that they don't clutter
-non-interactive sessions, such as when using `eshell-command'.")
+(defvar eshell-non-interactive-p) ; Defined in esh-mode.el.
(declare-function eshell-add-input-to-history "em-hist" (input))
-;;;###autoload
-(defun eshell-command (&optional command arg)
- "Execute the Eshell command string COMMAND.
-With prefix ARG, insert output into the current buffer at point."
- (interactive)
- (unless arg
- (setq arg current-prefix-arg))
- (let ((eshell-non-interactive-p t))
+(defun eshell-read-command (&optional prompt)
+ "Read an Eshell command from the minibuffer, prompting with PROMPT."
+ (let ((prompt (or prompt "Emacs shell command: "))
+ (eshell-non-interactive-p t))
;; Enable `eshell-mode' only in this minibuffer.
(minibuffer-with-setup-hook (lambda ()
(eshell-mode)
(eshell-command-mode +1))
- (unless command
- (setq command (read-from-minibuffer "Emacs shell command: "))
- (if (eshell-using-module 'eshell-hist)
- (eshell-add-input-to-history command)))))
- (unless command
- (error "No command specified!"))
- ;; redirection into the current buffer is achieved by adding an
- ;; output redirection to the end of the command, of the form
- ;; 'COMMAND >>> #<buffer BUFFER>'. This will not interfere with
- ;; other redirections, since multiple redirections merely cause the
- ;; output to be copied to multiple target locations
- (if arg
- (setq command
- (concat command
- (format " >>> #<buffer %s>"
- (buffer-name (current-buffer))))))
+ (let ((command (read-from-minibuffer prompt)))
+ (when (eshell-using-module 'eshell-hist)
+ (eshell-add-input-to-history command))
+ command))))
+
+;;;###autoload
+(defun eshell-command (command &optional to-current-buffer)
+ "Execute the Eshell command string COMMAND.
+If TO-CURRENT-BUFFER is non-nil (interactively, with the prefix
+argument), then insert output into the current buffer at point."
+ (interactive (list (eshell-read-command)
+ current-prefix-arg))
(save-excursion
- (let ((buf (set-buffer (generate-new-buffer " *eshell cmd*")))
+ (let ((stdout (if to-current-buffer (current-buffer) t))
+ (buf (set-buffer (generate-new-buffer " *eshell cmd*")))
(eshell-non-interactive-p t))
(eshell-mode)
(let* ((proc (eshell-eval-command
- (list 'eshell-commands
- (eshell-parse-command command))))
+ `(let ((eshell-current-handles
+ (eshell-create-handles ,stdout 'insert))
+ (eshell-current-subjob-p))
+ ,(eshell-parse-command command))
+ command))
intr
- (bufname (if (and proc (listp proc))
+ (bufname (if (eq (car-safe proc) :eshell-background)
"*Eshell Async Command Output*"
(setq intr t)
"*Eshell Command Output*")))
@@ -321,14 +315,13 @@ With prefix ARG, insert output into the current buffer at point."
;; make the output as attractive as possible, with no
;; extraneous newlines
(when intr
- (if (eshell-interactive-process-p)
- (eshell-wait-for-process (eshell-tail-process)))
- (cl-assert (not (eshell-interactive-process-p)))
+ (apply #'eshell-wait-for-process (cadr eshell-foreground-command))
+ (cl-assert (not eshell-foreground-command))
(goto-char (point-max))
(while (and (bolp) (not (bobp)))
(delete-char -1)))
(cl-assert (and buf (buffer-live-p buf)))
- (unless arg
+ (unless to-current-buffer
(let ((len (if (not intr) 2
(count-lines (point-min) (point-max)))))
(cond
@@ -363,6 +356,7 @@ corresponding to a successful execution."
(with-temp-buffer
(let ((eshell-non-interactive-p t))
(eshell-mode)
+ (eshell-debug-command-start command)
(let ((result (eshell-do-eval
(list 'eshell-commands
(list 'eshell-command-to-value
@@ -373,28 +367,14 @@ corresponding to a successful execution."
(set status-var eshell-last-command-status))
(cadr result))))))
-;;; Code:
-
-(defun eshell-unload-all-modules ()
- "Unload all modules that were loaded by Eshell, if possible.
-If the user has require'd in any of the modules, or customized a
-variable with a :require tag (such as `eshell-prefer-to-shell'), it
-will be impossible to unload Eshell completely without restarting
-Emacs."
- ;; if the user set `eshell-prefer-to-shell' to t, but never loaded
- ;; Eshell, then `eshell-subgroups' will be unbound
- (when (fboundp 'eshell-subgroups)
- (dolist (module (eshell-subgroups 'eshell))
- ;; this really only unloads as many modules as possible,
- ;; since other `require' references (such as by customizing
- ;; `eshell-prefer-to-shell' to a non-nil value) might make it
- ;; impossible to unload Eshell completely
- (if (featurep module)
- (ignore-errors
- (message "Unloading %s..." (symbol-name module))
- (unload-feature module)
- (message "Unloading %s...done" (symbol-name module)))))
- (message "Unloading eshell...done")))
+(defun eshell-unload-function ()
+ (eshell-unload-extension-modules)
+ ;; Wait to unload core modules until after `eshell' has finished
+ ;; unloading. `eshell' depends on several of them, so they can't be
+ ;; unloaded immediately.
+ (run-at-time 0 nil #'eshell-unload-modules
+ (reverse (eshell-subgroups 'eshell)) 'core)
+ nil)
(run-hooks 'eshell-load-hook)
diff --git a/lisp/external-completion.el b/lisp/external-completion.el
index deaf65fbe77..b171e27014c 100644
--- a/lisp/external-completion.el
+++ b/lisp/external-completion.el
@@ -7,6 +7,9 @@
;; Maintainer: João Távora <joaotavora@gmail.com>
;; Keywords:
+;; This is a GNU ELPA :core package. Avoid functionality that is not
+;; compatible with the version of Emacs recorded above.
+
;; This file is part of GNU Emacs.
;; GNU Emacs is free software: you can redistribute it and/or modify
diff --git a/lisp/faces.el b/lisp/faces.el
index ecaaae31b9e..c3a54a08a3d 100644
--- a/lisp/faces.el
+++ b/lisp/faces.el
@@ -651,11 +651,11 @@ Optional argument INHERIT is passed to `face-attribute'."
If FACE is a face-alias, get the documentation for the target face."
(let ((alias (get face 'face-alias)))
(if alias
- (let ((doc (get alias 'face-documentation)))
+ (let ((doc (documentation-property alias 'face-documentation)))
(format "%s is an alias for the face `%s'.%s" face alias
(if doc (format "\n%s" doc)
"")))
- (get face 'face-documentation))))
+ (documentation-property face 'face-documentation))))
(defun set-face-documentation (face string)
@@ -1118,8 +1118,7 @@ element of DEFAULT is returned. If DEFAULT isn't a list, but
MULTIPLE is non-nil, a one-element list containing DEFAULT is
returned. Otherwise, DEFAULT is returned verbatim."
(let (defaults)
- (unless (listp default)
- (setq default (list default)))
+ (setq default (ensure-list default))
(when default
(setq default
(if multiple
@@ -1146,16 +1145,16 @@ returned. Otherwise, DEFAULT is returned verbatim."
(format-prompt prompt default)
(format "%s: " prompt)))
(completion-extra-properties
- '(:affixation-function
- (lambda (faces)
- (mapcar
- (lambda (face)
- (list face
- (concat (propertize read-face-name-sample-text
- 'face face)
- "\t")
- ""))
- faces))))
+ `(:affixation-function
+ ,(lambda (faces)
+ (mapcar
+ (lambda (face)
+ (list face
+ (concat (propertize read-face-name-sample-text
+ 'face face)
+ "\t")
+ ""))
+ faces))))
aliasfaces nonaliasfaces faces)
;; Build up the completion tables.
(mapatoms (lambda (s)
@@ -1340,10 +1339,11 @@ of a global face. Value is the new attribute value."
(format "%s" old-value))))
(setq new-value
(if (memq attribute '(:foreground :background))
- (let ((color
- (read-color
- (format-prompt "%s for face `%s'"
- default attribute-name face))))
+ (let* ((prompt (format-prompt
+ "%s for face `%s'"
+ default attribute-name face))
+ (fg (eq attribute ':foreground))
+ (color (read-color prompt nil nil nil fg face)))
(if (equal (string-trim color) "")
default
color))
@@ -1539,15 +1539,12 @@ argument, prompt for a regular expression using `read-regexp'."
;;; Face specifications (defface).
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;; Parameter FRAME Is kept for call compatibility to with previous
-;; face implementation.
-
(defun face-attr-construct (face &optional _frame)
"Return a `defface'-style attribute list for FACE.
Value is a property list of pairs ATTRIBUTE VALUE for all specified
face attributes of FACE where ATTRIBUTE is the attribute name and
-VALUE is the specified value of that attribute.
-Argument FRAME is ignored and retained for compatibility."
+VALUE is the specified value of that attribute."
+ (declare (advertised-calling-convention (face) "30.1"))
(let (result)
(dolist (entry face-attribute-name-alist result)
(let* ((attribute (car entry))
@@ -1849,7 +1846,6 @@ If there is neither a user setting nor a default for FACE, return nil."
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Frame-type independent color support.
-;;; We keep the old x-* names as aliases for back-compatibility.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun defined-colors (&optional frame)
@@ -1861,7 +1857,6 @@ If FRAME is nil, that stands for the selected frame."
(if (display-graphic-p frame)
(xw-defined-colors frame)
(mapcar 'car (tty-color-alist frame))))
-(defalias 'x-defined-colors 'defined-colors)
(defun defined-colors-with-face-attributes (&optional frame foreground)
"Return a list of colors supported for a particular FRAME.
@@ -1870,15 +1865,26 @@ to `defined-colors' the elements of the returned list are color
strings with text properties, that make the color names render
with the color they represent as background color (if FOREGROUND
is nil; otherwise use the foreground color)."
- (mapcar
- (lambda (color-name)
- (let ((color (copy-sequence color-name)))
- (propertize color 'face
- (if foreground
- (list :foreground color)
- (list :foreground (readable-foreground-color color-name)
- :background color)))))
- (defined-colors frame)))
+ (mapcar (lambda (color-name)
+ (faces--string-with-color color-name color-name foreground))
+ (defined-colors frame)))
+
+(defun faces--string-with-color (string color &optional foreground face)
+ "Return a copy of STRING with face attributes for COLOR.
+Set the :background or :foreground attribute to COLOR, depending
+on the argument FOREGROUND.
+
+The optional FACE argument determines the values of other face
+attributes."
+ (let* ((defaults (if face (list face) '()))
+ (colors (cond (foreground
+ (list :foreground color))
+ (face
+ (list :background color))
+ (t
+ (list :foreground (readable-foreground-color color)
+ :background color)))))
+ (propertize string 'face (cons colors defaults))))
(defun readable-foreground-color (color)
"Return a readable foreground color for background COLOR.
@@ -1934,7 +1940,6 @@ If FRAME is omitted or nil, use the selected frame."
(if (display-graphic-p frame)
(xw-color-defined-p color frame)
(numberp (tty-color-translate color frame)))))
-(defalias 'x-color-defined-p 'color-defined-p)
(declare-function xw-color-values "xfns.c" (color &optional frame))
@@ -1962,8 +1967,6 @@ return value is nil."
(t
(tty-color-values color frame))))
-(defalias 'x-color-values 'color-values)
-
(declare-function xw-display-color-p "xfns.c" (&optional terminal))
(defun display-color-p (&optional display)
@@ -1974,7 +1977,6 @@ If omitted or nil, that stands for the selected frame's display."
(if (display-graphic-p display)
(xw-display-color-p display)
(tty-display-color-p display)))
-(defalias 'x-display-color-p 'display-color-p)
(declare-function x-display-grayscale-p "xfns.c" (&optional terminal))
@@ -1987,7 +1989,7 @@ If omitted or nil, that stands for the selected frame's display."
(> (tty-color-gray-shades display) 2)))
(defun read-color (&optional prompt convert-to-RGB allow-empty-name msg
- foreground)
+ foreground face)
"Read a color name or RGB triplet.
Completion is available for color names, but not for RGB triplets.
@@ -2016,17 +2018,25 @@ to enter an empty color name (the empty string).
Interactively, or with optional arg MSG non-nil, print the
resulting color name in the echo area.
-Interactively, displays a list of colored completions. If optional
-argument FOREGROUND is non-nil, shows them as foregrounds, otherwise
-as backgrounds."
+Interactively, provides completion for selecting the color. If
+the optional argument FOREGROUND is non-nil, shows the completion
+candidates with their foregound color changed to be the color of
+the candidate, otherwise changes the background color of the
+candidates. The optional argument FACE determines the other
+face attributes of the candidates on display."
(interactive "i\np\ni\np") ; Always convert to RGB interactively.
(let* ((completion-ignore-case t)
- (colors (append '("foreground at point" "background at point")
- (if allow-empty-name '(""))
- (if (display-color-p)
- (defined-colors-with-face-attributes
- nil foreground)
- (defined-colors))))
+ (color-alist
+ `(("foreground at point" . ,(foreground-color-at-point))
+ ("background at point" . ,(background-color-at-point))
+ ,@(if allow-empty-name '(("" . unspecified)))
+ ,@(mapcar (lambda (c) (cons c c)) (defined-colors))))
+ (colors (mapcar (lambda (pair)
+ (let* ((name (car pair))
+ (color (cdr pair)))
+ (faces--string-with-color name color
+ foreground face)))
+ color-alist))
(color (completing-read
(or prompt "Color (name or #RGB triplet): ")
;; Completing function for reading colors, accepting
@@ -2430,7 +2440,10 @@ If you set `term-file-prefix' to nil, this function does nothing."
'((((supports :slant italic))
:slant italic)
(((supports :underline t))
- :underline t)
+ ;; Include italic, even if it isn't supported by the default
+ ;; font, because this face could be merged with another face
+ ;; which uses font that does have an italic variant.
+ :underline t :slant italic)
(t
;; Default to italic, even if it doesn't appear to be supported,
;; because in some cases the display engine will do its own
@@ -2447,7 +2460,9 @@ If you set `term-file-prefix' to nil, this function does nothing."
(defface underline
'((((supports :underline t))
:underline t)
- (((supports :weight bold))
+ ;; Include underline, for when this face is merged with another
+ ;; whose font does support underline.
+ (((supports :weight bold :underline t))
:weight bold)
(t :underline t))
"Basic underlined face."
@@ -2702,7 +2717,7 @@ non-nil."
:version "22.1")
(defface mode-line
- '((((class color) (min-colors 88))
+ '((((class color grayscale) (min-colors 88))
:box (:line-width -1 :style released-button)
:background "grey75" :foreground "black")
(t
@@ -2725,11 +2740,11 @@ This inherits from the `mode-line' face."
(defface mode-line-inactive
'((default
:inherit mode-line)
- (((class color) (min-colors 88) (background light))
+ (((class color grayscale) (min-colors 88) (background light))
:weight light
:box (:line-width -1 :color "grey75" :style nil)
:foreground "grey20" :background "grey90")
- (((class color) (min-colors 88) (background dark) )
+ (((class color grayscale) (min-colors 88) (background dark) )
:weight light
:box (:line-width -1 :color "grey40" :style nil)
:foreground "grey80" :background "grey30"))
@@ -2739,7 +2754,7 @@ This inherits from the `mode-line' face."
:group 'basic-faces)
(defface mode-line-highlight
- '((((supports :box t) (class color) (min-colors 88))
+ '((((supports :box t) (class color grayscale) (min-colors 88))
:box (:line-width 2 :color "grey40" :style released-button))
(t
:inherit highlight))
@@ -2926,7 +2941,7 @@ Note: Other faces cannot inherit from the cursor face."
(((type haiku))
:foreground "B_MENU_ITEM_TEXT_COLOR"
:background "B_MENU_BACKGROUND_COLOR")
- (((type x w32 ns pgtk) (class color))
+ (((type x w32 ns pgtk android) (class color))
:background "grey75")
(((type x) (class mono))
:background "grey"))
@@ -3201,6 +3216,10 @@ also the same size as FACE on FRAME, or fail."
(define-obsolete-function-alias 'face-background-pixmap #'face-stipple "29.1")
(define-obsolete-function-alias 'set-face-background-pixmap #'set-face-stipple "29.1")
+(define-obsolete-function-alias 'x-defined-colors #'defined-colors "30.1")
+(define-obsolete-function-alias 'x-color-defined-p #'color-defined-p "30.1")
+(define-obsolete-function-alias 'x-color-values #'color-values "30.1")
+(define-obsolete-function-alias 'x-display-color-p #'display-color-p "30.1")
(provide 'faces)
diff --git a/lisp/ffap.el b/lisp/ffap.el
index e3fae177460..b2b681b7c44 100644
--- a/lisp/ffap.el
+++ b/lisp/ffap.el
@@ -152,15 +152,15 @@ schemes (e.g. \"ftp\"); in that case, only convert those URLs."
:group 'ffap
:version "24.3")
-(defcustom ffap-lax-url t
+(defcustom ffap-lax-url nil
"If non-nil, allow lax URL matching.
The default non-nil value might produce false URLs in C++ code
with symbols like \"std::find\". On the other hand, setting
this to nil will disable recognition of URLs that are not
-well-formed, such as \"user@host\" or \"<user@host>\"."
+well-formed."
:type 'boolean
:group 'ffap
- :version "25.2") ; nil -> t
+ :version "30.1")
(defcustom ffap-ftp-default-user "anonymous"
"User name in FTP file names generated by `ffap-host-to-filename'.
@@ -554,15 +554,11 @@ Looks at `ffap-ftp-default-user', returns \"\" for \"localhost\"."
(concat "gopher://" mach "/"))
;; www.ncsa.uiuc.edu
((and (string-match "\\`w\\(ww\\|eb\\)[-.]" mach))
- (concat "http://" mach "/"))
+ (concat "https://" mach "/"))
;; More cases?
(ffap-ftp-regexp (ffap-host-to-filename mach))
))
-(defvaralias 'ffap-newsgroup-regexp 'thing-at-point-newsgroup-regexp)
-(defvaralias 'ffap-newsgroup-heads 'thing-at-point-newsgroup-heads)
-(defalias 'ffap-newsgroup-p 'thing-at-point-newsgroup-p)
-
(defun ffap-url-p (string)
"If STRING looks like an URL, return it (maybe improved), else nil."
(when (and (stringp string) ffap-url-regexp)
@@ -613,6 +609,13 @@ Looks at `ffap-ftp-default-user', returns \"\" for \"localhost\"."
((and ffap-url-unwrap-remote (ffap-url-unwrap-remote url)))
(url)))
+(defun ffap-fixup-email (email)
+ "Clean up EMAIL and return it as a mailto: URL."
+ (when (stringp email)
+ (if (string-prefix-p "mailto:" email)
+ email
+ (concat "mailto:" email))))
+
;;; File Name Handling:
@@ -734,6 +737,7 @@ This uses `ffap-file-exists-string', which may try adding suffixes from
(defvar ffap-alist
'(
("" . ffap-completable) ; completion, slow on some systems
+ ("" . ffap-in-project) ; maybe in the root of the project
("\\.info\\'" . ffap-info) ; gzip.info
("\\`info/" . ffap-info-2) ; info/emacs
("\\`[-[:lower:]]+\\'" . ffap-info-3) ; (emacs)Top [only in the parentheses]
@@ -797,6 +801,11 @@ to extract substrings.")
(cmp (file-name-completion (file-name-nondirectory name) dir)))
(and cmp (concat dir cmp))))
+(declare-function project-root "project" (project))
+(defun ffap-in-project (name)
+ (when-let (project (project-current))
+ (file-name-concat (project-root project) name)))
+
(defun ffap-home (name) (ffap-locate-file name t '("~")))
(defun ffap-info (name)
@@ -1056,6 +1065,9 @@ If a given RFC isn't in these then `ffap-rfc-path' is offered."
;; (La)TeX: don't allow braces
(latex-mode "--:\\\\$+<>@-Z_[:alpha:]~*?" "<@" "@>;.,!:")
(tex-mode "--:\\\\$+<>@-Z_[:alpha:]~*?" "<@" "@>;.,!:")
+ ;; XML: don't allow angle brackets
+ (xml-mode "--:\\\\${}+@-Z_[:alpha:]~*?#" "{<@" "@>;.,!:}")
+ (nxml-mode "--:\\\\${}+@-Z_[:alpha:]~*?#" "{<@" "@>;.,!:}")
)
"Alist of (MODE CHARS BEG END), where MODE is a symbol.
This is possibly a major-mode name, or one of the symbols
@@ -1089,12 +1101,12 @@ Suppose the cursor is somewhere that might be near end of file,
the guessing would position point before punctuation (like comma)
after the file extension:
- C:\temp\file.log, which contain ....
+ C:\\temp\\file.log, which contain ....
=============================== (before)
---------------- (after)
- C:\temp\file.log on Windows or /tmp/file.log on Unix
+ C:\\temp\\file.log on Windows or /tmp/file.log on Unix
=============================== (before)
---------------- (after)
@@ -1569,6 +1581,7 @@ Uses the face `ffap' if it is defined, or else `highlight'."
(ffap-fixup-url (or (ffap-url-at-point)
(ffap-gopher-at-point))))
(ffap-file-at-point) ; may yield url!
+ (ffap-fixup-email (thing-at-point 'email))
(ffap-fixup-machine (ffap-machine-at-point))))
(defun ffap-prompter (&optional guess suffix)
@@ -2145,6 +2158,10 @@ Of course if you do not like these bindings, just roll your own!")
(interactive)
(eval (cons 'progn ffap-bindings)))
+(define-obsolete-variable-alias 'ffap-newsgroup-regexp 'thing-at-point-newsgroup-regexp "30.1")
+(define-obsolete-variable-alias 'ffap-newsgroup-heads 'thing-at-point-newsgroup-heads "30.1")
+(define-obsolete-function-alias 'ffap-newsgroup-p #'thing-at-point-newsgroup-p "30.1")
+
(provide 'ffap)
diff --git a/lisp/filecache.el b/lisp/filecache.el
index 3f37839424f..86d5e65df06 100644
--- a/lisp/filecache.el
+++ b/lisp/filecache.el
@@ -213,7 +213,7 @@ Defaults to the value of `case-fold-search'."
:type 'boolean)
(defcustom file-cache-ignore-case
- (memq system-type '(ms-dos windows-nt cygwin))
+ (not (not (memq system-type '(ms-dos windows-nt cygwin))))
"Non-nil means ignore case when checking completions in the file cache.
Defaults to nil on DOS and Windows, and t on other systems."
:type 'boolean)
diff --git a/lisp/filenotify.el b/lisp/filenotify.el
index bc643f57b0f..4e289d564c9 100644
--- a/lisp/filenotify.el
+++ b/lisp/filenotify.el
@@ -138,7 +138,7 @@ It is nil or a `file-notify--rename' defstruct where the cookie can be nil.")
((memq action '(delete delete-self move-self)) 'deleted)
((eq action 'moved-from) 'renamed-from)
((eq action 'moved-to) 'renamed-to)
- ((eq action 'ignored) 'stopped)))
+ ((memq action '(ignored unmount)) 'stopped)))
actions))
file file1-or-cookie))
@@ -153,7 +153,8 @@ It is nil or a `file-notify--rename' defstruct where the cookie can be nil.")
((eq action 'write) 'changed)
((memq action '(attrib link)) 'attribute-changed)
((eq action 'delete) 'deleted)
- ((eq action 'rename) 'renamed)))
+ ((eq action 'rename) 'renamed)
+ ((eq action 'revoke) 'stopped)))
actions))
file file1-or-cookie))
@@ -179,7 +180,8 @@ It is nil or a `file-notify--rename' defstruct where the cookie can be nil.")
((memq action
'(created changed attribute-changed deleted))
action)
- ((eq action 'moved) 'renamed)))
+ ((eq action 'moved) 'renamed)
+ ((eq action 'unmounted) 'stopped)))
(if (consp actions) actions (list actions))))
file file1-or-cookie))
@@ -195,6 +197,7 @@ It is nil or a `file-notify--rename' defstruct where the cookie can be nil.")
((memq action '(created changed attribute-changed deleted))
action)
((eq action 'moved) 'renamed)
+ ((eq action 'unmounted) 'stopped)
;; inotify actions:
((eq action 'create) 'created)
((eq action 'modify) 'changed)
@@ -202,7 +205,7 @@ It is nil or a `file-notify--rename' defstruct where the cookie can be nil.")
((memq action '(delete delete-self move-self)) 'deleted)
((eq action 'moved-from) 'renamed-from)
((eq action 'moved-to) 'renamed-to)
- ((eq action 'ignored) 'stopped)))
+ ((memq action '(ignored unmount)) 'stopped)))
(if (consp actions) actions (list actions))))
file file1-or-cookie))
@@ -339,7 +342,7 @@ DESC is the back-end descriptor. ACTIONS is a list of:
"Add a watch for FILE in DIR with FLAGS, using inotify."
(inotify-add-watch dir
(append
- '(dont-follow)
+ '(dont-follow ignored unmount)
(and (memq 'change flags)
'(create delete delete-self modify move-self move))
(and (memq 'attribute-change flags)
@@ -352,6 +355,7 @@ DESC is the back-end descriptor. ACTIONS is a list of:
;; directories, so we watch each file directly.
(kqueue-add-watch file
(append
+ '(revoke)
(and (memq 'change flags)
'(create delete write extend rename))
(and (memq 'attribute-change flags)
diff --git a/lisp/files-x.el b/lisp/files-x.el
index 7bd560ebaed..f70be5f7ff3 100644
--- a/lisp/files-x.el
+++ b/lisp/files-x.el
@@ -31,6 +31,8 @@
;;; Code:
(eval-when-compile (require 'subr-x)) ; for string-trim-right
+(declare-function dosified-file-name "dos-fns" (file-name))
+(declare-function project-root "project" (project))
;;; Commands to add/delete file-local/directory-local variables.
@@ -136,7 +138,10 @@ Intended to be used in the `interactive' spec of
(eq new-value not-value)
(not (equal old-value new-value)))
(message "%s" (substitute-command-keys
- "For this change to take effect revisit file using \\[revert-buffer]")))))
+ (if (and (stringp buffer-file-name)
+ (file-exists-p buffer-file-name))
+ "For this change to take effect revisit file using \\[revert-buffer]"
+ "For this change to take effect use \\[normal-mode]"))))))
(defun modify-file-local-variable (variable value op &optional interactive)
"Modify file-local VARIABLE in Local Variables depending on operation OP.
@@ -407,7 +412,7 @@ then this function adds it."
(defvar auto-insert) ; from autoinsert.el
-(defun modify-dir-local-variable (mode variable value op)
+(defun modify-dir-local-variable (mode variable value op &optional file)
"Modify directory-local VARIABLE in .dir-locals.el depending on operation OP.
If OP is `add-or-replace' then delete all existing settings of
@@ -419,28 +424,37 @@ If .dir-locals.el was not found and OP is not `delete' then create
this file in the current directory.
If OP is `delete' then delete all existing settings of VARIABLE
-from the MODE alist ignoring the input argument VALUE."
+from the MODE alist ignoring the input argument VALUE.
+
+Optional argument FILE, when non-nil, specifies what file to modify. It
+should be an expanded filename."
(catch 'exit
(unless enable-local-variables
(throw 'exit (message "Directory-local variables are disabled")))
- (let* ((dir-or-cache (and (buffer-file-name)
- (not (file-remote-p (buffer-file-name)))
- (dir-locals-find-file (buffer-file-name))))
- (variables-file
- ;; If there are several .dir-locals, the user probably
- ;; wants to edit the last one (the highest priority).
- (cond ((stringp dir-or-cache)
- (car (last (dir-locals--all-files dir-or-cache))))
- ((consp dir-or-cache) ; result from cache
- ;; If cache element has an mtime, assume it came
- ;; from a file. Otherwise, assume it was set
- ;; directly.
- (if (nth 2 dir-or-cache)
- (car (last (dir-locals--all-files (car dir-or-cache))))
- (cadr dir-or-cache)))
- ;; Try to make a proper file-name.
- (t (expand-file-name dir-locals-file))))
- variables)
+ (let ((variables-file
+ (if (stringp file)
+ file
+ (let ((dir-or-cache
+ (and (buffer-file-name)
+ (not (file-remote-p (buffer-file-name)))
+ (dir-locals-find-file (buffer-file-name)))))
+ ;; If there are several .dir-locals, the user probably
+ ;; wants to edit the last one (the highest priority).
+ (cond
+ ((stringp dir-or-cache)
+ (car (last (dir-locals--all-files dir-or-cache))))
+ ((consp dir-or-cache) ; result from cache
+ ;; If cache element has an mtime, assume it came
+ ;; from a file. Otherwise, assume it was set
+ ;; directly.
+ (if (nth 2 dir-or-cache)
+ (car (last (dir-locals--all-files (car dir-or-cache))))
+ (cadr dir-or-cache)))
+ ;; Try to make a proper file-name.
+ (t (expand-file-name (if (eq system-type 'ms-dos)
+ (dosified-file-name dir-locals-file)
+ dir-locals-file)))))))
+ variables)
;; I can't be bothered to handle this case right now.
;; Dir locals were set directly from a class. You need to
;; directly modify the class in dir-locals-class-alist.
@@ -524,33 +538,75 @@ from the MODE alist ignoring the input argument VALUE."
(cdr mode-variables) "\n"))))
variables "\n")))
+(defun read-dir-locals-file ()
+ "Read a dir-locals filename using completion.
+Intended to be used in the `interactive' spec of `add-dir-local-variable',
+`delete-dir-local-variable' and `copy-file-locals-to-dir-locals'.
+
+Returns the filename, expanded."
+ (let* ((pri dir-locals-file)
+ (sec (replace-regexp-in-string ".el$" "-2.el" dir-locals-file))
+ (dir (or (locate-dominating-file default-directory pri)
+ (locate-dominating-file default-directory sec))))
+ (expand-file-name
+ (read-file-name
+ "File: "
+ (cond (dir)
+ ((when-let ((proj (and (featurep 'project) (project-current))))
+ (project-root proj))))
+ nil
+ (lambda (fname)
+ (member (file-name-nondirectory fname) (list pri sec)))
+ dir-locals-file))))
+
;;;###autoload
-(defun add-dir-local-variable (mode variable value)
- "Add directory-local VARIABLE with its VALUE and MODE to .dir-locals.el."
+(defun add-dir-local-variable (mode variable value &optional file)
+ "Add directory-local VARIABLE with its VALUE and MODE to .dir-locals.el.
+
+With a prefix argument, prompt for the file to modify.
+
+When called from Lisp, FILE may be the expanded name of the dir-locals file
+where to add VARIABLE."
(interactive
(let (variable)
(list
(read-file-local-variable-mode)
(setq variable (read-file-local-variable "Add directory-local variable"))
- (read-file-local-variable-value variable))))
- (modify-dir-local-variable mode variable value 'add-or-replace))
+ (read-file-local-variable-value variable)
+ (when current-prefix-arg
+ (read-dir-locals-file)))))
+ (modify-dir-local-variable mode variable value 'add-or-replace file))
;;;###autoload
-(defun delete-dir-local-variable (mode variable)
- "Delete all MODE settings of file-local VARIABLE from .dir-locals.el."
+(defun delete-dir-local-variable (mode variable &optional file)
+ "Delete all MODE settings of dir-local VARIABLE from .dir-locals.el.
+
+With a prefix argument, prompt for the file to modify.
+
+When called from Lisp, FILE may be the expanded name of the dir-locals file
+from where to delete VARIABLE."
(interactive
(list
(read-file-local-variable-mode)
- (read-file-local-variable "Delete directory-local variable")))
- (modify-dir-local-variable mode variable nil 'delete))
+ (read-file-local-variable "Delete directory-local variable")
+ (when current-prefix-arg
+ (read-dir-locals-file))))
+ (modify-dir-local-variable mode variable nil 'delete file))
;;;###autoload
-(defun copy-file-locals-to-dir-locals ()
- "Copy file-local variables to .dir-locals.el."
- (interactive)
+(defun copy-file-locals-to-dir-locals (&optional file)
+ "Copy file-local variables to .dir-locals.el.
+
+With a prefix argument, prompt for the file to modify.
+
+When called from Lisp, FILE may be the expanded name of the dir-locals file
+where to copy the file-local variables."
+ (interactive
+ (list (when current-prefix-arg
+ (read-dir-locals-file))))
(dolist (elt file-local-variables-alist)
(unless (assq (car elt) dir-local-variables-alist)
- (add-dir-local-variable major-mode (car elt) (cdr elt)))))
+ (add-dir-local-variable major-mode (car elt) (cdr elt) file))))
;;;###autoload
(defun copy-dir-locals-to-file-locals ()
@@ -735,6 +791,7 @@ definitions that aren't listed in VARIABLES."
(setq variables (nreverse existing-variables)))
(connection-local-set-profile-variables profile variables))
+;;;###autoload
(defun hack-connection-local-variables (criteria)
"Read connection-local variables according to CRITERIA.
Store the connection-local variables in buffer local
@@ -870,17 +927,53 @@ earlier in the `setq-connection-local'. The return value of the
connection-local-profile-name-for-setq)))))
;;;###autoload
+(defmacro connection-local-p (variable &optional application)
+ "Non-nil if VARIABLE has a connection-local binding in `default-directory'.
+`default-directory' must be a remote file name.
+If APPLICATION is nil, the value of
+`connection-local-default-application' is used."
+ (declare (debug (symbolp &optional form)))
+ (unless (symbolp variable)
+ (signal 'wrong-type-argument (list 'symbolp variable)))
+ `(let ((criteria
+ (connection-local-criteria-for-default-directory ,application))
+ connection-local-variables-alist file-local-variables-alist)
+ (when criteria
+ (hack-connection-local-variables criteria)
+ (and (assq ',variable connection-local-variables-alist) t))))
+
+;;;###autoload
+(defmacro connection-local-value (variable &optional application)
+ "Return connection-local VARIABLE for APPLICATION in `default-directory'.
+`default-directory' must be a remote file name.
+If APPLICATION is nil, the value of
+`connection-local-default-application' is used.
+If VARIABLE does not have a connection-local binding, the return
+value is the default binding of the variable."
+ (declare (debug (symbolp &optional form)))
+ (unless (symbolp variable)
+ (signal 'wrong-type-argument (list 'symbolp variable)))
+ `(let ((criteria
+ (connection-local-criteria-for-default-directory ,application))
+ connection-local-variables-alist file-local-variables-alist)
+ (if (not criteria)
+ ,variable
+ (hack-connection-local-variables criteria)
+ (if-let ((result (assq ',variable connection-local-variables-alist)))
+ (cdr result)
+ ,variable))))
+
+;;;###autoload
(defun path-separator ()
"The connection-local value of `path-separator'."
- (with-connection-local-variables path-separator))
+ (connection-local-value path-separator))
;;;###autoload
(defun null-device ()
"The connection-local value of `null-device'."
- (with-connection-local-variables null-device))
+ (connection-local-value null-device))
-
(provide 'files-x)
;;; files-x.el ends here
diff --git a/lisp/files.el b/lisp/files.el
index 5536af014f6..20d63d33fef 100644
--- a/lisp/files.el
+++ b/lisp/files.el
@@ -228,7 +228,7 @@ If non-nil, this directory is used instead of `temporary-file-directory'
by programs that create small temporary files. This is for systems that
have fast storage with limited space, such as a RAM disk."
:group 'files
- :initialize 'custom-initialize-delay
+ :initialize #'custom-initialize-delay
:type '(choice (const nil) directory))
;; The system null device. (Should reference NULL_DEVICE from C.)
@@ -434,7 +434,7 @@ ignored."
,@(mapcar (lambda (algo)
(list 'const algo))
(secure-hash-algorithms)))))
- :initialize 'custom-initialize-delay
+ :initialize #'custom-initialize-delay
:version "21.1")
(defvar auto-save--timer nil "Timer for `auto-save-visited-mode'.")
@@ -482,6 +482,7 @@ non-nil."
"When nil, `auto-save-visited-mode' will auto-save remote files.
Any other value means that it will not."
:group 'auto-save
+ :group 'tramp
:type 'boolean
:version "29.1")
@@ -555,8 +556,9 @@ using a transform that puts the lock files on a local file system."
:version "28.1")
(defcustom remote-file-name-inhibit-locks nil
- "Whether to use file locks for remote files."
+ "Whether to create file locks for remote files."
:group 'files
+ :group 'tramp
:version "28.1"
:type 'boolean)
@@ -681,7 +683,8 @@ The command \\[normal-mode], when used interactively,
always obeys file local variable specifications and the -*- line,
and ignores this variable.
-Also see the `permanently-enabled-local-variables' variable."
+Also see the `permanently-enabled-local-variables' and
+`safe-local-variable-directories' variables."
:risky t
:type '(choice (const :tag "Query Unsafe" t)
(const :tag "Safe Only" :safe)
@@ -1140,9 +1143,11 @@ the function needs to examine, starting with FILE."
(while (not (or root
(null file)
(string-match locate-dominating-stop-dir-regexp file)))
- (setq try (if (stringp name)
- (and (file-directory-p file)
- (file-exists-p (expand-file-name name file)))
+ (setq file (if (file-directory-p file)
+ file
+ (file-name-directory file))
+ try (if (stringp name)
+ (file-exists-p (expand-file-name name file))
(funcall name file)))
(cond (try (setq root file))
((equal file (setq file (file-name-directory
@@ -1249,6 +1254,29 @@ See `load-file' for a different interface to `load'."
(interactive (list (read-library-name)))
(load library))
+(defun require-with-check (feature &optional filename noerror)
+ "If FEATURE is not already loaded, load it from FILENAME.
+This is like `require' except if FEATURE is already a member of the list
+`features’, then we check if this was provided by a different file than the
+one that we would load now (presumably because `load-path' has been
+changed since the file was loaded).
+If it's the case, we either signal an error (the default), or forcibly reload
+the new file (if NOERROR is equal to `reload'), or otherwise emit a warning."
+ (let ((lh load-history)
+ (res (require feature filename (if (eq noerror 'reload) nil noerror))))
+ ;; If the `feature' was not yet provided, `require' just loaded the right
+ ;; file, so we're done.
+ (when (eq lh load-history)
+ ;; If `require' did nothing, we need to make sure that was warranted.
+ (let ((fn (locate-file (or filename (symbol-name feature))
+ load-path (get-load-suffixes))))
+ (cond
+ ((assoc fn load-history) nil) ;We loaded the right file.
+ ((eq noerror 'reload) (load fn nil 'nomessage))
+ (t (funcall (if noerror #'warn #'error)
+ "Feature provided by other file: %S" feature)))))
+ res))
+
(defun file-remote-p (file &optional identification connected)
"Test whether FILE specifies a location on a remote system.
A file is considered remote if accessing it is likely to
@@ -1275,7 +1303,9 @@ there is an existing connection.
If CONNECTED is non-nil, return an identification only if FILE is
located on a remote system and a connection is established to
-that remote system.
+that remote system. If CONNECTED is `never', never use an
+existing connection to return the identification (this is
+otherwise like a value of nil).
Tip: You can use this expansion of remote identifier components
to derive a new remote file name from an existing one. For
@@ -1286,10 +1316,8 @@ Tip: You can use this expansion of remote identifier components
returns a remote file name for file \"/bin/sh\" that has the
same remote identifier as FILE but expanded; a name such as
\"/sudo:root@myhost:/bin/sh\"."
- (let ((handler (find-file-name-handler file 'file-remote-p)))
- (if handler
- (funcall handler 'file-remote-p file identification connected)
- nil)))
+ (when-let ((handler (find-file-name-handler file 'file-remote-p)))
+ (funcall handler 'file-remote-p file identification connected)))
;; Probably this entire variable should be obsolete now, in favor of
;; something Tramp-related (?). It is not used in many places.
@@ -1299,7 +1327,7 @@ Tip: You can use this expansion of remote identifier components
(defcustom remote-shell-program (or (executable-find "ssh") "ssh")
"Program to use to execute commands on a remote host (i.e. ssh)."
:version "29.1"
- :initialize 'custom-initialize-delay
+ :initialize #'custom-initialize-delay
:group 'environment
:type 'file)
@@ -1324,6 +1352,7 @@ consecutive checks. For example:
(< 0 (file-attribute-size
(file-attributes (file-chase-links file)))))))"
:group 'files
+ :group 'tramp
:version "24.1"
:type '(choice
(const :tag "Do not cache remote file attributes" t)
@@ -1332,6 +1361,22 @@ consecutive checks. For example:
:format "Cache expiry in seconds: %v"
:value 10)))
+(defcustom remote-file-name-access-timeout nil
+ "Timeout (in seconds) for `access-file'.
+This timeout limits the time to check, whether a remote file is
+accessible. `access-file' returns an error after that time. If
+the value is 0 or nil, no timeout is used.
+
+This applies only when there isn't time spent for other actions,
+like reading passwords."
+ :group 'files
+ :group 'tramp
+ :version "30.1"
+ ;;:type '(choice :tag "Timeout (seconds)" natnum (const nil)))
+ :type '(choice
+ (natnum :tag "Timeout (seconds)")
+ (const :tag "Do not use timeout" nil)))
+
(defun file-local-name (file)
"Return the local name component of FILE.
This function removes from FILE the specification of the remote host
@@ -1984,6 +2029,8 @@ INHIBIT-BUFFER-HOOKS non-nil.
Note: Be careful with let-binding this hook considering it is
frequently used for cleanup.")
+(defvar find-alternate-file-dont-kill-client nil
+ "If non-nil, `server-buffer-done' should not delete the client.")
(defun find-alternate-file (filename &optional wildcards)
"Find file FILENAME, select its buffer, kill previous buffer.
If the current buffer now contains an empty file that you just visited
@@ -2030,7 +2077,8 @@ killed."
;; save a modified buffer visiting a file. Rather, `kill-buffer'
;; asks that itself. Thus, there's no need to temporarily do
;; `(set-buffer-modified-p nil)' before running this hook.
- (run-hooks 'kill-buffer-hook)
+ (let ((find-alternate-file-dont-kill-client 'dont-kill-client))
+ (run-hooks 'kill-buffer-hook))
;; Okay, now we can end-of-life the old buffer.
(if (get-buffer " **lose**")
(kill-buffer " **lose**"))
@@ -2070,22 +2118,32 @@ killed."
(kill-buffer obuf))))))
;; FIXME we really need to fold the uniquify stuff in here by default,
-;; not using advice, and add it to the doc string.
(defun create-file-buffer (filename)
"Create a suitably named buffer for visiting FILENAME, and return it.
FILENAME (sans directory) is used unchanged if that name is free;
-otherwise a string <2> or <3> or ... is appended to get an unused name.
+otherwise the buffer is renamed according to
+`uniquify-buffer-name-style' to get an unused name.
Emacs treats buffers whose names begin with a space as internal buffers.
To avoid confusion when visiting a file whose name begins with a space,
this function prepends a \"|\" to the final result if necessary."
- (let* ((lastname (file-name-nondirectory filename))
- (lastname (if (string= lastname "")
- filename lastname))
- (buf (generate-new-buffer (if (string-prefix-p " " lastname)
- (concat "|" lastname)
- lastname))))
- (uniquify--create-file-buffer-advice buf filename)
+ (let* ((lastname (file-name-nondirectory (directory-file-name filename)))
+ (lastname (if (string= lastname "") ; FILENAME is a root directory
+ filename lastname))
+ (lastname (cond
+ ((not (and uniquify-trailing-separator-p
+ (file-directory-p filename)))
+ lastname)
+ ((eq uniquify-buffer-name-style 'forward)
+ (file-name-as-directory lastname))
+ ((eq uniquify-buffer-name-style 'reverse)
+ (concat (or uniquify-separator "\\") lastname))
+ (t lastname)))
+ (basename (if (string-prefix-p " " lastname)
+ (concat "|" lastname)
+ lastname))
+ (buf (generate-new-buffer basename)))
+ (uniquify--create-file-buffer-advice buf filename basename)
buf))
(defvar abbreviated-home-dir nil
@@ -2158,37 +2216,33 @@ and others are ignored. PREDICATE is called with the buffer as
the only argument, but not with the buffer as the current buffer.
If there is no such live buffer, return nil."
- (let ((predicate (or predicate #'identity))
- (truename (abbreviate-file-name (file-truename filename))))
- (or (let ((buf (get-file-buffer filename)))
- (when (and buf (funcall predicate buf)) buf))
- (let ((list (buffer-list)) found)
- (while (and (not found) list)
- (with-current-buffer (car list)
- (if (and buffer-file-name
- (string= buffer-file-truename truename)
- (funcall predicate (current-buffer)))
- (setq found (car list))))
- (setq list (cdr list)))
- found)
- (let* ((attributes (file-attributes truename))
- (number (file-attribute-file-identifier attributes))
- (list (buffer-list)) found)
- (and buffer-file-numbers-unique
- (car-safe number) ;Make sure the inode is not just nil.
- (while (and (not found) list)
- (with-current-buffer (car list)
- (if (and buffer-file-name
- (equal buffer-file-number number)
- ;; Verify this buffer's file number
- ;; still belongs to its file.
- (file-exists-p buffer-file-name)
- (equal (file-attributes buffer-file-truename)
- attributes)
- (funcall predicate (current-buffer)))
- (setq found (car list))))
- (setq list (cdr list))))
- found))))
+ (or (let ((buf (get-file-buffer filename)))
+ (when (and buf (or (not predicate) (funcall predicate buf))) buf))
+ (let ((truename (abbreviate-file-name (file-truename filename))))
+ (or
+ (let ((buf (get-truename-buffer truename)))
+ (when (and buf (buffer-local-value 'buffer-file-name buf)
+ (or (not predicate) (funcall predicate buf)))
+ buf))
+ (let* ((attributes (file-attributes truename))
+ (number (file-attribute-file-identifier attributes)))
+ (and buffer-file-numbers-unique
+ (car-safe number) ;Make sure the inode is not just nil.
+ (let* ((buf (find-buffer 'buffer-file-number number))
+ (buf-file-name
+ (and buf (buffer-local-value 'buffer-file-name buf))))
+ (when (and buf-file-name
+ ;; Verify this buffer's file number
+ ;; still belongs to its file.
+ (file-exists-p buf-file-name)
+ (equal (file-attributes
+ (buffer-local-value
+ 'buffer-file-truename buf))
+ attributes)
+ (or (not predicate)
+ (funcall predicate buf)))
+ buf))))))))
+
(defcustom find-file-wildcards t
"Non-nil means file-visiting commands should handle wildcards.
@@ -2701,6 +2755,10 @@ Fifth arg NOMODES non-nil means don't alter the file's modes.
Finishes by calling the functions in `find-file-hook'
unless NOMODES is non-nil."
(setq buffer-read-only (not (file-writable-p buffer-file-name)))
+ ;; The above is sufficiently like turning on read-only-mode, so run
+ ;; the mode hook here by hand.
+ (if buffer-read-only
+ (run-hooks 'read-only-mode-hook))
(if noninteractive
nil
(let* (not-serious
@@ -3013,7 +3071,7 @@ ARC\\|ZIP\\|LZH\\|LHA\\|ZOO\\|[JEW]AR\\|XPI\\|RAR\\|CBR\\|7Z\\|SQUASHFS\\)\\'" .
("\\.docbook\\'" . sgml-mode)
("\\.com\\'" . dcl-mode)
("/config\\.\\(?:bat\\|log\\)\\'" . fundamental-mode)
- ("/\\.\\(authinfo\\|netrc\\)\\'" . authinfo-mode)
+ ("/\\.?\\(authinfo\\|netrc\\)\\'" . authinfo-mode)
;; Windows candidates may be opened case sensitively on Unix
("\\.\\(?:[iI][nN][iI]\\|[lL][sS][tT]\\|[rR][eE][gG]\\|[sS][yY][sS]\\)\\'" . conf-mode)
("\\.la\\'" . conf-unix-mode)
@@ -3218,8 +3276,25 @@ and `inhibit-local-variables-suffixes'. If
temp))
(defvar auto-mode-interpreter-regexp
- (purecopy "#![ \t]?\\([^ \t\n]*\
-/bin/env[ \t]\\)?\\([^ \t\n]+\\)")
+ (purecopy
+ (concat
+ "#![ \t]*"
+ ;; Optional group 1: env(1) invocation.
+ "\\("
+ "[^ \t\n]*/bin/env[ \t]*"
+ ;; Within group 1: possible -S/--split-string and environment
+ ;; adjustments.
+ "\\(?:"
+ ;; -S/--split-string
+ "\\(?:-[0a-z]*S[ \t]*\\|--split-string=\\)"
+ ;; More env arguments.
+ "\\(?:-[^ \t\n]+[ \t]+\\)*"
+ ;; Interpreter environment modifications.
+ "\\(?:[^ \t\n]+=[^ \t\n]*[ \t]+\\)*"
+ "\\)?"
+ "\\)?"
+ ;; Group 2: interpreter.
+ "\\([^ \t\n]+\\)"))
"Regexp matching interpreters, for file mode determination.
This regular expression is matched against the first line of a file
to determine the file's mode in `set-auto-mode'. If it matches, the file
@@ -3346,7 +3421,7 @@ checks if it uses an interpreter listed in `interpreter-mode-alist',
matches the buffer beginning against `magic-mode-alist',
compares the file name against the entries in `auto-mode-alist',
then matches the buffer beginning against `magic-fallback-mode-alist'.
-It also obeys `major-mode-remap-alist'.
+It also obeys `major-mode-remap-alist' and `major-mode-remap-defaults'.
If `enable-local-variables' is nil, or if the file name matches
`inhibit-local-variables-regexps', this function does not check
@@ -3358,7 +3433,7 @@ set the major mode only if that would change it. In other words
we don't actually set it to the same mode the buffer already has."
;; Look for -*-MODENAME-*- or -*- ... mode: MODENAME; ... -*-
(let ((try-locals (not (inhibit-local-variables-p)))
- end done mode modes)
+ end modes)
;; Once we drop the deprecated feature where mode: is also allowed to
;; specify minor-modes (ie, there can be more than one "mode:"), we can
;; remove this section and just let (hack-local-variables t) handle it.
@@ -3389,100 +3464,96 @@ we don't actually set it to the same mode the buffer already has."
(push (intern (concat (downcase (buffer-substring (point) end))
"-mode"))
modes))))
- ;; If we found modes to use, invoke them now, outside the save-excursion.
- (if modes
- (catch 'nop
- (dolist (mode (nreverse modes))
- (if (not (functionp mode))
- (message "Ignoring unknown mode `%s'" mode)
- (setq done t)
- (or (set-auto-mode-0 mode keep-mode-if-same)
- ;; continuing would call minor modes again, toggling them off
- (throw 'nop nil))))))
- ;; Check for auto-mode-alist entry in dir-locals.
- (unless done
- (with-demoted-errors "Directory-local variables error: %s"
- ;; Note this is a no-op if enable-local-variables is nil.
- (let* ((mode-alist (cdr (hack-dir-local--get-variables
- (lambda (key) (eq key 'auto-mode-alist))))))
- (setq done (set-auto-mode--apply-alist mode-alist
- keep-mode-if-same t)))))
- (and (not done)
- (setq mode (hack-local-variables t (not try-locals)))
- (not (memq mode modes)) ; already tried and failed
- (if (not (functionp mode))
- (message "Ignoring unknown mode `%s'" mode)
- (setq done t)
- (set-auto-mode-0 mode keep-mode-if-same)))
- ;; If we didn't, look for an interpreter specified in the first line.
- ;; As a special case, allow for things like "#!/bin/env perl", which
- ;; finds the interpreter anywhere in $PATH.
- (and (not done)
- (setq mode (save-excursion
- (goto-char (point-min))
- (if (looking-at auto-mode-interpreter-regexp)
- (match-string 2))))
- ;; Map interpreter name to a mode, signaling we're done at the
- ;; same time.
- (setq done (assoc-default
- (file-name-nondirectory mode)
- (mapcar (lambda (e)
- (cons
- (format "\\`%s\\'" (car e))
- (cdr e)))
- interpreter-mode-alist)
- #'string-match-p))
- ;; If we found an interpreter mode to use, invoke it now.
- (set-auto-mode-0 done keep-mode-if-same))
- ;; Next try matching the buffer beginning against magic-mode-alist.
- (unless done
- (if (setq done (save-excursion
- (goto-char (point-min))
- (save-restriction
- (narrow-to-region (point-min)
- (min (point-max)
- (+ (point-min) magic-mode-regexp-match-limit)))
- (assoc-default
- nil magic-mode-alist
- (lambda (re _dummy)
- (cond
- ((functionp re)
- (funcall re))
- ((stringp re)
- (let ((case-fold-search nil))
- (looking-at re)))
- (t
- (error
- "Problem in magic-mode-alist with element %s"
- re))))))))
- (set-auto-mode-0 done keep-mode-if-same)))
- ;; Next compare the filename against the entries in auto-mode-alist.
- (unless done
- (setq done (set-auto-mode--apply-alist auto-mode-alist
- keep-mode-if-same nil)))
- ;; Next try matching the buffer beginning against magic-fallback-mode-alist.
- (unless done
- (if (setq done (save-excursion
- (goto-char (point-min))
- (save-restriction
- (narrow-to-region (point-min)
- (min (point-max)
- (+ (point-min) magic-mode-regexp-match-limit)))
- (assoc-default nil magic-fallback-mode-alist
- (lambda (re _dummy)
- (cond
- ((functionp re)
- (funcall re))
- ((stringp re)
- (let ((case-fold-search nil))
- (looking-at re)))
- (t
- (error
- "Problem with magic-fallback-mode-alist element: %s"
- re))))))))
- (set-auto-mode-0 done keep-mode-if-same)))
- (unless done
- (set-buffer-major-mode (current-buffer)))))
+ (or
+ ;; If we found modes to use, invoke them now, outside the save-excursion.
+ ;; Presume `modes' holds a major mode followed by minor modes.
+ (let ((done ()))
+ (dolist (mode (nreverse modes))
+ (if (eq done :keep)
+ ;; `keep-mode-if-same' is set and the (major) mode
+ ;; was already set. Refrain from calling the following
+ ;; minor modes since they have already been set.
+ ;; It was especially important in the past when calling
+ ;; minor modes without an arg would toggle them, but it's
+ ;; still preferable to avoid re-enabling them,
+ nil
+ (let ((res (set-auto-mode-0 mode keep-mode-if-same)))
+ (setq done (or res done)))))
+ done)
+ ;; Check for auto-mode-alist entry in dir-locals.
+ (with-demoted-errors "Directory-local variables error: %s"
+ ;; Note this is a no-op if enable-local-variables is nil.
+ (let* ((mode-alist (cdr (hack-dir-local--get-variables
+ (lambda (key) (eq key 'auto-mode-alist))))))
+ (set-auto-mode--apply-alist mode-alist keep-mode-if-same t)))
+ (let ((mode (hack-local-variables t (not try-locals))))
+ (unless (memq mode modes) ; already tried and failed
+ (set-auto-mode-0 mode keep-mode-if-same)))
+ ;; If we didn't, look for an interpreter specified in the first line.
+ ;; As a special case, allow for things like "#!/bin/env perl", which
+ ;; finds the interpreter anywhere in $PATH.
+ (when-let
+ ((interp (save-excursion
+ (goto-char (point-min))
+ (if (looking-at auto-mode-interpreter-regexp)
+ (match-string 2))))
+ ;; Map interpreter name to a mode, signaling we're done at the
+ ;; same time.
+ (mode (assoc-default
+ (file-name-nondirectory interp)
+ (mapcar (lambda (e)
+ (cons
+ (format "\\`%s\\'" (car e))
+ (cdr e)))
+ interpreter-mode-alist)
+ #'string-match-p)))
+ ;; If we found an interpreter mode to use, invoke it now.
+ (set-auto-mode-0 mode keep-mode-if-same))
+ ;; Next try matching the buffer beginning against magic-mode-alist.
+ (let ((mode (save-excursion
+ (goto-char (point-min))
+ (save-restriction
+ (narrow-to-region (point-min)
+ (min (point-max)
+ (+ (point-min) magic-mode-regexp-match-limit)))
+ (assoc-default
+ nil magic-mode-alist
+ (lambda (re _dummy)
+ (cond
+ ((functionp re)
+ (funcall re))
+ ((stringp re)
+ (let ((case-fold-search nil))
+ (looking-at re)))
+ (t
+ (error
+ "Problem in magic-mode-alist with element %s"
+ re)))))))))
+ (set-auto-mode-0 mode keep-mode-if-same))
+ ;; Next compare the filename against the entries in auto-mode-alist.
+ (set-auto-mode--apply-alist auto-mode-alist
+ keep-mode-if-same nil)
+ ;; Next try matching the buffer beginning against magic-fallback-mode-alist.
+ (let ((mode (save-excursion
+ (goto-char (point-min))
+ (save-restriction
+ (narrow-to-region (point-min)
+ (min (point-max)
+ (+ (point-min) magic-mode-regexp-match-limit)))
+ (assoc-default nil magic-fallback-mode-alist
+ (lambda (re _dummy)
+ (cond
+ ((functionp re)
+ (funcall re))
+ ((stringp re)
+ (let ((case-fold-search nil))
+ (looking-at re)))
+ (t
+ (error
+ "Problem with magic-fallback-mode-alist element: %s"
+ re)))))))))
+ (set-auto-mode-0 mode keep-mode-if-same))
+ (set-buffer-major-mode (current-buffer)))))
(defvar-local set-auto-mode--last nil
"Remember the mode we have set via `set-auto-mode-0'.")
@@ -3492,9 +3563,22 @@ we don't actually set it to the same mode the buffer already has."
Every entry is of the form (MODE . FUNCTION) which means that in order
to activate the major mode MODE (specified via something like
`auto-mode-alist', file-local variables, ...) we should actually call
-FUNCTION instead."
+FUNCTION instead.
+FUNCTION can be nil to hide other entries (either in this var or in
+`major-mode-remap-defaults') and means that we should call MODE."
:type '(alist (symbol) (function)))
+(defvar major-mode-remap-defaults nil
+ "Alist mapping file-specified mode to actual mode.
+This works like `major-mode-remap-alist' except it has lower priority
+and it is meant to be modified by packages rather than users.")
+
+(defun major-mode-remap (mode)
+ "Return the function to use to enable MODE."
+ (or (cdr (or (assq mode major-mode-remap-alist)
+ (assq mode major-mode-remap-defaults)))
+ mode))
+
;; When `keep-mode-if-same' is set, we are working on behalf of
;; set-visited-file-name. In that case, if the major mode specified is the
;; same one we already have, don't actually reset it. We don't want to lose
@@ -3503,18 +3587,29 @@ FUNCTION instead."
"Apply MODE and return it.
If optional arg KEEP-MODE-IF-SAME is non-nil, MODE is chased of
any aliases and compared to current major mode. If they are the
-same, do nothing and return nil."
- (unless (and keep-mode-if-same
- (or (eq (indirect-function mode)
- (indirect-function major-mode))
- (and set-auto-mode--last
- (eq mode (car set-auto-mode--last))
- (eq major-mode (cdr set-auto-mode--last)))))
- (when mode
- (funcall (alist-get mode major-mode-remap-alist mode))
- (unless (eq mode major-mode)
- (setq set-auto-mode--last (cons mode major-mode)))
- mode)))
+same, do nothing and return `:keep'.
+Return nil if MODE could not be applied."
+ (when mode
+ (if (and keep-mode-if-same
+ (or (eq (indirect-function mode)
+ (indirect-function major-mode))
+ (and set-auto-mode--last
+ (eq mode (car set-auto-mode--last))
+ (eq major-mode (cdr set-auto-mode--last)))))
+ :keep
+ (let ((modefun (major-mode-remap mode)))
+ (if (not (functionp modefun))
+ (progn
+ (message "Ignoring unknown mode `%s'%s" mode
+ (if (eq mode modefun) ""
+ (format " (remapped to `%S')" modefun)))
+ nil)
+ (funcall modefun)
+ (unless (or (eq mode major-mode) ;`set-auto-mode--last' is overkill.
+ ;; `modefun' is something like a minor mode.
+ (local-variable-p 'set-auto-mode--last))
+ (setq set-auto-mode--last (cons mode major-mode)))
+ mode)))))
(defvar file-auto-mode-skip "^\\(#!\\|'\\\\\"\\)"
"Regexp of lines to skip when looking for file-local settings.
@@ -3700,10 +3795,23 @@ function is allowed to change the contents of this alist.
This hook is called only if there is at least one file-local
variable to set.")
-(defvar permanently-enabled-local-variables '(lexical-binding)
+(defvar permanently-enabled-local-variables
+ '(lexical-binding read-symbol-shorthands)
"A list of file-local variables that are always enabled.
This overrides any `enable-local-variables' setting.")
+(defcustom safe-local-variable-directories '()
+ "A list of directories where local variables are always enabled.
+Directory-local variables loaded from these directories, such as the
+variables in .dir-locals.el, will be enabled even if they are risky.
+The names of the directories in the list must be absolute, and must
+end in a slash. Remote directories can be included if the
+variable `enable-remote-dir-locals' is non-nil."
+ :version "30.1"
+ :type '(repeat string)
+ :risky t
+ :group 'find-file)
+
(defun hack-local-variables-confirm (all-vars unsafe-vars risky-vars dir-name)
"Get confirmation before setting up local variable values.
ALL-VARS is the list of all variables to be set up.
@@ -3742,7 +3850,11 @@ n -- to ignore the local variables list.")
! -- to apply the local variables list, and permanently mark these
values (*) as safe (in the future, they will be set automatically.)
i -- to ignore the local variables list, and permanently mark these
- values (*) as ignored\n\n")
+ values (*) as ignored"
+ (if dir-name "
++ -- to apply the local variables list, and trust all directory-local
+ variables in this directory\n\n"
+ "\n\n"))
(insert "\n\n"))
(dolist (elt all-vars)
(cond ((member elt unsafe-vars)
@@ -3766,7 +3878,11 @@ i -- to ignore the local variables list, and permanently mark these
(pop-to-buffer buf '(display-buffer--maybe-at-bottom))
(let* ((exit-chars '(?y ?n ?\s))
(prompt (format "Please type %s%s: "
- (if offer-save "y, n, ! or i" "y or n")
+ (if offer-save
+ (if dir-name
+ "y, n, !, i, +"
+ "y, n, !, i")
+ "y or n")
(if (< (line-number-at-pos (point-max))
(window-body-height))
""
@@ -3774,8 +3890,13 @@ i -- to ignore the local variables list, and permanently mark these
char)
(when offer-save
(push ?i exit-chars)
- (push ?! exit-chars))
+ (push ?! exit-chars)
+ (when dir-name
+ (push ?+ exit-chars)))
(setq char (read-char-choice prompt exit-chars))
+ (when (and offer-save dir-name (= char ?+))
+ (customize-push-and-save 'safe-local-variable-directories
+ (list dir-name)))
(when (and offer-save
(or (= char ?!) (= char ?i))
unsafe-vars)
@@ -3784,7 +3905,7 @@ i -- to ignore the local variables list, and permanently mark these
'safe-local-variable-values
'ignored-local-variable-values)
unsafe-vars))
- (prog1 (memq char '(?! ?\s ?y))
+ (prog1 (memq char '(?! ?\s ?y ?+))
(quit-window t)))))))
(defconst hack-local-variable-regexp
@@ -3916,6 +4037,10 @@ DIR-NAME is the name of the associated directory. Otherwise it is nil."
(null unsafe-vars)
(null risky-vars))
(memq enable-local-variables '(:all :safe))
+ (delq nil (mapcar (lambda (dir)
+ (and dir-name dir
+ (file-equal-p dir dir-name)))
+ safe-local-variable-directories))
(hack-local-variables-confirm all-vars unsafe-vars
risky-vars dir-name))
(dolist (elt all-vars)
@@ -4033,6 +4158,7 @@ major-mode."
(forward-line 1)
(let ((startpos (point))
endpos
+ (selective-p (eq selective-display t))
(thisbuf (current-buffer)))
(save-excursion
(unless (let ((case-fold-search t))
@@ -4049,7 +4175,8 @@ major-mode."
(with-temp-buffer
(insert-buffer-substring thisbuf startpos endpos)
(goto-char (point-min))
- (subst-char-in-region (point) (point-max) ?\^m ?\n)
+ (if selective-p
+ (subst-char-in-region (point) (point-max) ?\r ?\n))
(while (not (eobp))
;; Discard the prefix.
(if (looking-at prefix)
@@ -4089,8 +4216,9 @@ major-mode."
(not (string-match
"-minor\\'"
(setq val2 (downcase (symbol-name val)))))
- ;; Allow several mode: elements.
- (push (intern (concat val2 "-mode")) result))
+ (let ((mode (intern (concat val2 "-mode"))))
+ (when (fboundp (major-mode-remap mode))
+ (setq result mode))))
(cond ((eq var 'coding))
((eq var 'lexical-binding)
(unless hack-local-variables--warned-lexical
@@ -4105,6 +4233,13 @@ major-mode."
;; to use 'thisbuf's name in the
;; warning message.
(or (buffer-file-name thisbuf) ""))))))
+ ((eq var 'read-symbol-shorthands)
+ ;; Sort automatically by shorthand length
+ ;; in descending order.
+ (setq val (sort val
+ (lambda (sh1 sh2) (> (length (car sh1))
+ (length (car sh2))))))
+ (push (cons 'read-symbol-shorthands val) result))
((and (eq var 'mode) handle-mode))
(t
(ignore-errors
@@ -4114,10 +4249,7 @@ major-mode."
val)
result))))))
(forward-line 1)))))))
- (if (eq handle-mode t)
- ;; Return the final mode: setting that's defined.
- (car (seq-filter #'fboundp result))
- result)))
+ result))
(defun hack-local-variables-apply ()
"Apply the elements of `file-local-variables-alist'.
@@ -4327,6 +4459,12 @@ to see whether it should be considered."
(funcall predicate key)
(or (not key)
(derived-mode-p key)))
+ ;; If KEY is an extra parent it may remain not loaded
+ ;; (hence with some of its mode-specific vars missing their
+ ;; `safe-local-variable' property), leading to spurious
+ ;; prompts about unsafe vars (bug#68246).
+ (if (and (symbolp key) (autoloadp (indirect-function key)))
+ (ignore-errors (autoload-do-load (indirect-function key))))
(let* ((alist (cdr entry))
(subdirs (assq 'subdirs alist)))
(if (or (not subdirs)
@@ -4525,12 +4663,7 @@ applied in order then that means the more specific modes will
variables will override modes."
(let ((key (car node)))
(cond ((null key) -1)
- ((symbolp key)
- (let ((mode key)
- (depth 0))
- (while (setq mode (get mode 'derived-mode-parent))
- (setq depth (1+ depth)))
- depth))
+ ((symbolp key) (length (derived-mode-all-parents key)))
((stringp key)
(+ 1000 (length key)))
(t -2))))
@@ -5738,9 +5871,14 @@ Before and after saving the buffer, this function runs
(run-hook-with-args-until-success 'write-file-functions)
;; If a hook returned t, file is already "written".
;; Otherwise, write it the usual way now.
- (let ((dir (file-name-directory
+ (let ((file (buffer-file-name))
+ (dir (file-name-directory
(expand-file-name buffer-file-name))))
- (unless (file-exists-p dir)
+ ;; Some systems have directories (like /content on
+ ;; Android) in which files can exist without a
+ ;; corresponding parent directory.
+ (unless (or (file-exists-p file)
+ (file-exists-p dir))
(if (y-or-n-p
(format-message
"Directory `%s' does not exist; create? " dir))
@@ -5809,8 +5947,10 @@ Before and after saving the buffer, this function runs
buffer-file-name)))
(setq tempsetmodes t)
(error "Attempt to save to a file that you aren't allowed to write"))))))
- (or buffer-backed-up
- (setq setmodes (backup-buffer)))
+ (with-demoted-errors
+ "Backing up buffer: %s"
+ (or buffer-backed-up
+ (setq setmodes (backup-buffer))))
(let* ((dir (file-name-directory buffer-file-name))
(dir-writable (file-writable-p dir)))
(if (or (and file-precious-flag dir-writable)
@@ -5868,9 +6008,11 @@ Before and after saving the buffer, this function runs
buffer-file-name)
t))
;; If file not writable, see if we can make it writable
- ;; temporarily while we write it.
- ;; But no need to do so if we have just backed it up
- ;; (setmodes is set) because that says we're superseding.
+ ;; temporarily while we write it (its original modes will be
+ ;; restored in 'basic-save-buffer' or, in case of an error, in
+ ;; the `unwind-protect' below). But no need to do so if we
+ ;; have just backed it up (setmodes is set) because that says
+ ;; we're superseding.
(cond ((and tempsetmodes (not setmodes))
;; Change the mode back, after writing.
(setq setmodes
@@ -5879,12 +6021,17 @@ Before and after saving the buffer, this function runs
"Error getting extended attributes: %s"
(file-extended-attributes buffer-file-name))
buffer-file-name))
- ;; If set-file-extended-attributes fails, fall back on
- ;; set-file-modes.
- (unless
- (with-demoted-errors "Error setting attributes: %s"
- (set-file-extended-attributes buffer-file-name
- (nth 1 setmodes)))
+ ;; If set-file-extended-attributes fails to make the
+ ;; file writable, fall back on set-file-modes. Calling
+ ;; set-file-extended-attributes here may or may not be
+ ;; actually necessary. However, since its exact
+ ;; behavior is highly port-specific, since calling it
+ ;; does not do any harm, and since the call has a long
+ ;; history, we decided to leave it in (bug#66546).
+ (with-demoted-errors "Error setting attributes: %s"
+ (set-file-extended-attributes buffer-file-name
+ (nth 1 setmodes)))
+ (unless (file-writable-p buffer-file-name)
(set-file-modes buffer-file-name
(logior (car setmodes) 128)))))
(let (success)
@@ -5897,12 +6044,22 @@ Before and after saving the buffer, this function runs
buffer-file-name nil t buffer-file-truename)
(when save-silently (message nil))
(setq success t))
- ;; If we get an error writing the new file, and we made
- ;; the backup by renaming, undo the backing-up.
- (and setmodes (not success)
- (progn
- (rename-file (nth 2 setmodes) buffer-file-name t)
- (setq buffer-backed-up nil)))))))
+ (cond
+ ;; If we get an error writing the file, and there is no
+ ;; backup file, then we (most likely) made that file
+ ;; writable above. Attempt to undo the write-access.
+ ((and setmodes (not success)
+ (equal (nth 2 setmodes) buffer-file-name))
+ (with-demoted-errors "Error setting file modes: %S"
+ (set-file-modes buffer-file-name (car setmodes)))
+ (with-demoted-errors "Error setting attributes: %s"
+ (set-file-extended-attributes buffer-file-name
+ (nth 1 setmodes))))
+ ;; If we get an error writing the new file, and we made
+ ;; the backup by renaming, undo the backing-up.
+ ((and setmodes (not success))
+ (rename-file (nth 2 setmodes) buffer-file-name t)
+ (setq buffer-backed-up nil)))))))
setmodes))
(declare-function diff-no-select "diff"
@@ -6217,11 +6374,11 @@ instance of such commands."
(rename-buffer (generate-new-buffer-name base-name))
(force-mode-line-update))))
-(defun files--ensure-directory (mkdir dir)
- "Use function MKDIR to make directory DIR if it is not already a directory.
+(defun files--ensure-directory (dir)
+ "Make directory DIR if it is not already a directory.
Return non-nil if DIR is already a directory."
(condition-case err
- (funcall mkdir dir)
+ (make-directory-internal dir)
(error
(or (file-directory-p dir)
(signal (car err) (cdr err))))))
@@ -6247,32 +6404,27 @@ Signal an error if unsuccessful."
;; If default-directory is a remote directory,
;; make sure we find its make-directory handler.
(setq dir (expand-file-name dir))
- (let ((mkdir (if-let ((handler (find-file-name-handler dir 'make-directory)))
- #'(lambda (dir)
- ;; Use 'ignore' since the handler might be designed for
- ;; Emacs 28-, so it might return an (undocumented)
- ;; non-nil value, whereas the Emacs 29+ convention is
- ;; to return nil here.
- (ignore (funcall handler 'make-directory dir)))
- #'make-directory-internal)))
- (if (not parents)
- (funcall mkdir dir)
- (let ((dir (directory-file-name (expand-file-name dir)))
- already-dir create-list parent)
- (while (progn
- (setq parent (directory-file-name
- (file-name-directory dir)))
- (condition-case ()
- (ignore (setq already-dir
- (files--ensure-directory mkdir dir)))
- (error
- ;; Do not loop if root does not exist (Bug#2309).
- (not (string= dir parent)))))
- (setq create-list (cons dir create-list)
- dir parent))
- (dolist (dir create-list)
- (setq already-dir (files--ensure-directory mkdir dir)))
- already-dir))))
+ (let ((handler (find-file-name-handler dir 'make-directory)))
+ (if handler
+ (funcall handler 'make-directory dir parents)
+ (if (not parents)
+ (make-directory-internal dir)
+ (let ((dir (directory-file-name (expand-file-name dir)))
+ already-dir create-list parent)
+ (while (progn
+ (setq parent (directory-file-name
+ (file-name-directory dir)))
+ (condition-case ()
+ (ignore (setq already-dir
+ (files--ensure-directory dir)))
+ (error
+ ;; Do not loop if root does not exist (Bug#2309).
+ (not (string= dir parent)))))
+ (setq create-list (cons dir create-list)
+ dir parent))
+ (dolist (dir create-list)
+ (setq already-dir (files--ensure-directory dir)))
+ already-dir)))))
(defun make-empty-file (filename &optional parents)
"Create an empty file FILENAME.
@@ -6304,6 +6456,27 @@ non-nil and if FN fails due to a missing file or directory."
(apply fn args)
(file-missing (or no-such (signal (car err) (cdr err))))))
+(defun delete-file (filename &optional trash)
+ "Delete file named FILENAME. If it is a symlink, remove the symlink.
+If file has multiple names, it continues to exist with the other names.
+TRASH non-nil means to trash the file instead of deleting, provided
+`delete-by-moving-to-trash' is non-nil.
+
+When called interactively, TRASH is t if no prefix argument is given.
+With a prefix argument, TRASH is nil."
+ (interactive (list (read-file-name
+ (if (and delete-by-moving-to-trash (null current-prefix-arg))
+ "Move file to trash: " "Delete file: ")
+ nil default-directory (confirm-nonexistent-file-or-buffer))
+ (null current-prefix-arg)))
+ (if (and (file-directory-p filename) (not (file-symlink-p filename)))
+ (signal 'file-error (list "Removing old name: is a directory" filename)))
+ (let* ((filename (expand-file-name filename))
+ (handler (find-file-name-handler filename 'delete-file)))
+ (cond (handler (funcall handler 'delete-file filename trash))
+ ((and delete-by-moving-to-trash trash) (move-file-to-trash filename))
+ (t (delete-file-internal filename)))))
+
(defun delete-directory (directory &optional recursive trash)
"Delete the directory named DIRECTORY. Does not follow symlinks.
If RECURSIVE is non-nil, delete files in DIRECTORY as well, with
@@ -6365,6 +6538,14 @@ RECURSIVE if DIRECTORY is nonempty."
directory-exists))
(files--force recursive #'delete-directory-internal directory))))))
+(defcustom remote-file-name-inhibit-delete-by-moving-to-trash nil
+ "Whether remote files shall be moved to the Trash.
+This overrules any setting of `delete-by-moving-to-trash'."
+ :version "30.1"
+ :group 'files
+ :group 'tramp
+ :type 'boolean)
+
(defun file-equal-p (file1 file2)
"Return non-nil if files FILE1 and FILE2 name the same file.
If FILE1 or FILE2 does not exist, the return value is unspecified."
@@ -6537,7 +6718,15 @@ into NEWNAME instead."
(file-attributes directory))))
(follow-flag (unless follow 'nofollow)))
(if modes (set-file-modes newname modes follow-flag))
- (if times (set-file-times newname times follow-flag)))))))
+ (when times
+ ;; When built for an Android GUI build, don't attempt to
+ ;; set file times for a file within /content, as the
+ ;; Android VFS layer does not provide means to change file
+ ;; timestamps.
+ (when (or (not (and (eq system-type 'android)
+ (featurep 'android)))
+ (not (string-prefix-p "/content/" newname)))
+ (set-file-times newname times follow-flag))))))))
;; At time of writing, only info uses this.
@@ -6819,9 +7008,9 @@ an auto-save file."
(if revert-buffer-preserve-modes
(let ((buffer-file-format buffer-file-format))
(insert-file-contents file-name (not auto-save-p)
- nil nil t))
+ nil nil 'if-regular))
(insert-file-contents file-name (not auto-save-p)
- nil nil t))))))
+ nil nil 'if-regular))))))
(defvar revert-buffer-with-fine-grain-max-seconds 2.0
"Maximum time that `revert-buffer-with-fine-grain' should use.
@@ -6964,11 +7153,19 @@ auto-save file, if that is more recent than the visited file."
#'(lambda (window _value)
(with-selected-window window
(unwind-protect
- (yes-or-no-p (format "Recover auto save file %s? " file-name))
+ (let ((prompt (format "Recover auto save file %s? " file-name))
+ (choices
+ '(("yes" ?y "recover auto save file")
+ ("no" ?n "don't recover auto save file")
+ ("diff" ?= "show changes between auto save file and current file")))
+ ans)
+ (while (equal "diff" (setq ans (read-answer prompt choices)))
+ (diff file file-name))
+ (equal ans "yes"))
(when (window-live-p window)
(quit-restore-window window 'kill)))))
(with-current-buffer standard-output
- (let ((switches dired-listing-switches))
+ (let ((switches (connection-local-value dired-listing-switches)))
(if (file-symlink-p file)
(setq switches (concat switches " -L")))
;; Use insert-directory-safely, not insert-directory,
@@ -7020,7 +7217,7 @@ Then you'll be asked about a number of files to recover."
;; hook.
(dired-mode-hook (delete 'dired-omit-mode dired-mode-hook)))
(dired (concat auto-save-list-file-prefix "*")
- (concat dired-listing-switches " -t")))
+ (concat (connection-local-value dired-listing-switches) " -t")))
(use-local-map (nconc (make-sparse-keymap) (current-local-map)))
(define-key (current-local-map) "\C-c\C-c" 'recover-session-finish)
(save-excursion
@@ -7134,10 +7331,11 @@ specifies the list of buffers to kill, asking for approval for each one."
(setq list (cdr list))))
(defun kill-matching-buffers (regexp &optional internal-too no-ask)
- "Kill buffers whose name matches the specified REGEXP.
-Ignores buffers whose name starts with a space, unless optional
-prefix argument INTERNAL-TOO is non-nil. Asks before killing
-each buffer, unless NO-ASK is non-nil."
+ "Kill buffers whose names match the regular expression REGEXP.
+Interactively, prompt for REGEXP.
+Ignores buffers whose names start with a space, unless optional
+prefix argument INTERNAL-TOO(interactively, the prefix argument)
+is non-nil. Asks before killing each buffer, unless NO-ASK is non-nil."
(interactive "sKill buffers matching this regular expression: \nP")
(dolist (buffer (buffer-list))
(let ((name (buffer-name buffer)))
@@ -7146,6 +7344,17 @@ each buffer, unless NO-ASK is non-nil."
(string-match regexp name))
(funcall (if no-ask 'kill-buffer 'kill-buffer-ask) buffer)))))
+(defun kill-matching-buffers-no-ask (regexp &optional internal-too)
+ "Kill buffers whose names match the regular expression REGEXP.
+Interactively, prompt for REGEXP.
+Like `kill-matching-buffers', but doesn't ask for confirmation
+before killing each buffer.
+Ignores buffers whose names start with a space, unless the
+optional argument INTERNAL-TOO (interactively, the prefix argument)
+is non-nil."
+ (interactive "sKill buffers matching this regular expression: \nP")
+ (kill-matching-buffers regexp internal-too t))
+
(defun rename-auto-save-file ()
"Adjust current buffer's auto save file name for current conditions.
@@ -7408,35 +7617,42 @@ default directory. However, if FULL is non-nil, they are absolute."
;; if DIRPART contains wildcards.
(dirs (if (and dirpart
(string-match "[[*?]" (file-local-name dirpart)))
- (mapcar 'file-name-as-directory
+ (mapcar #'file-name-as-directory
(file-expand-wildcards
(directory-file-name dirpart) nil regexp))
(list dirpart)))
contents)
- (dolist (dir dirs)
+ (dolist (dir (nreverse dirs))
(when (or (null dir) ; Possible if DIRPART is not wild.
(file-accessible-directory-p dir))
- (let ((this-dir-contents
- ;; Filter out "." and ".."
- (delq nil
- (mapcar (lambda (name)
- (unless (string-match "\\`\\.\\.?\\'"
- (file-name-nondirectory name))
- name))
- (directory-files
- (or dir ".") full
- (if regexp
- ;; We're matching each file name
- ;; element separately.
- (concat "\\`" nondir "\\'")
- (wildcard-to-regexp nondir)))))))
- (setq contents
- (nconc
- (if (and dir (not full))
- (mapcar (lambda (name) (concat dir name))
- this-dir-contents)
- this-dir-contents)
- contents)))))
+ (if (equal "" nondir)
+ ;; `nondir' is "" when the pattern ends in "/". Basically ""
+ ;; refers to the directory itself, like ".", but it's not
+ ;; among the names returned by `directory-files', so we have
+ ;; to special-case it.
+ (push (or dir nondir) contents)
+ (let ((this-dir-contents
+ ;; Filter out "." and ".."
+ (delq nil
+ (mapcar (lambda (name)
+ (unless (string-match "\\`\\.\\.?\\'"
+ (file-name-nondirectory
+ name))
+ name))
+ (directory-files
+ (or dir ".") full
+ (if regexp
+ ;; We're matching each file name
+ ;; element separately.
+ (concat "\\`" nondir "\\'")
+ (wildcard-to-regexp nondir)))))))
+ (setq contents
+ (nconc
+ (if (and dir (not full))
+ (mapcar (lambda (name) (concat dir name))
+ this-dir-contents)
+ this-dir-contents)
+ contents))))))
contents)))
(defcustom find-sibling-rules nil
@@ -7463,7 +7679,8 @@ files, you could say something like:
In this example, if you're in \"src/emacs/emacs-27/lisp/abbrev.el\",
and a \"src/emacs/emacs-28/lisp/abbrev.el\" file exists, it's now
defined as a sibling."
- :type 'sexp
+ :type '(alist :key-type (regexp :tag "Match")
+ :value-type (repeat (string :tag "Expansion")))
:version "29.1")
(defun find-sibling-file (file)
@@ -7618,10 +7835,38 @@ need to be passed verbatim to shell commands."
pattern))))
-(defvar insert-directory-program (purecopy "ls")
+(defcustom insert-directory-program
+ (if (and (memq system-type '(berkeley-unix darwin))
+ (executable-find "gls"))
+ (purecopy "gls")
+ (purecopy "ls"))
"Absolute or relative name of the `ls'-like program.
This is used by `insert-directory' and `dired-insert-directory'
-\(thus, also by `dired').")
+\(thus, also by `dired'). For Dired, this should ideally point to
+GNU ls, or another version of ls that supports the \"--dired\"
+flag. See `dired-use-ls-dired'.
+
+On GNU/Linux and other capable systems, the default is \"ls\".
+
+On *BSD and macOS systems, the default \"ls\" does not support
+the \"--dired\" flag. Therefore, the default is to use the
+\"gls\" executable on such machines, if it exists. This means
+that there should normally be no need to customize this when
+installing GNU coreutils using something like ports or Homebrew."
+ :group 'dired
+ :type 'string
+ :initialize #'custom-initialize-delay
+ :version "30.1")
+
+(defun files--use-insert-directory-program-p ()
+ "Return non-nil if we should use `insert-directory-program'.
+Return nil if we should prefer `ls-lisp' instead."
+ ;; FIXME: Should we also check `file-accessible-directory-p' so we
+ ;; automatically redirect to ls-lisp when operating on magic file names?
+ (and (if (boundp 'ls-lisp-use-insert-directory-program)
+ ls-lisp-use-insert-directory-program
+ t)
+ insert-directory-program))
(defcustom directory-free-space-program (purecopy "df")
"Program to get the amount of free space on a file system.
@@ -7653,7 +7898,6 @@ If DIR's free space cannot be obtained, this function returns nil."
(if avail
(funcall byte-count-to-string-function avail)))))
-;; The following expression replaces `dired-move-to-filename-regexp'.
(defvar directory-listing-before-filename-regexp
(let* ((l "\\([A-Za-z]\\|[^\0-\177]\\)")
(l-or-quote "\\([A-Za-z']\\|[^\0-\177]\\)")
@@ -7691,7 +7935,7 @@ If DIR's free space cannot be obtained, this function returns nil."
;; This avoids recognizing `1 may 1997' as a date in the line:
;; -r--r--r-- 1 may 1997 1168 Oct 19 16:49 README
- ;; The "[BkKMGTPEZY]?" below supports "ls -alh" output.
+ ;; The "[BkKMGTPEZYRQ]?" below supports "ls -alh" output.
;; For non-iso date formats, we add the ".*" in order to find
;; the last possible match. This avoids recognizing
@@ -7703,8 +7947,8 @@ If DIR's free space cannot be obtained, this function returns nil."
;; parentheses:
;; -rw-r--r-- (modified) 2005-10-22 21:25 files.el
;; This is not supported yet.
- (purecopy (concat "\\([0-9][BkKMGTPEZY]? " iso
- "\\|.*[0-9][BkKMGTPEZY]? "
+ (purecopy (concat "\\([0-9][BkKMGTPEZYRQ]? " iso
+ "\\|.*[0-9][BkKMGTPEZYRQ]? "
"\\(" western "\\|" western-comma
"\\|" DD-MMM-YYYY "\\|" east-asian "\\)"
"\\) +")))
@@ -7816,9 +8060,11 @@ Optional third arg WILDCARD means treat FILE as shell wildcard.
Optional fourth arg FULL-DIRECTORY-P means file is a directory and
switches do not contain `d', so that a full listing is expected.
-This works by running a directory listing program
-whose name is in the variable `insert-directory-program'.
-If WILDCARD, it also runs the shell specified by `shell-file-name'.
+Depending on the value of `ls-lisp-use-insert-directory-program'
+this works either using a Lisp emulation of the \"ls\" program
+or by running a directory listing program
+whose name is in the variable `insert-directory-program'
+\(and if WILDCARD, it also runs the shell specified by `shell-file-name').
When SWITCHES contains the long `--dired' option, this function
treats it specially, for the sake of dired. However, the
@@ -7827,184 +8073,191 @@ normally equivalent short `-D' option is just passed on to
;; We need the directory in order to find the right handler.
(let ((handler (find-file-name-handler (expand-file-name file)
'insert-directory)))
- (if handler
- (funcall handler 'insert-directory file switches
- wildcard full-directory-p)
- (let (result (beg (point)))
-
- ;; Read the actual directory using `insert-directory-program'.
- ;; RESULT gets the status code.
- (let* (;; We at first read by no-conversion, then after
- ;; putting text property `dired-filename, decode one
- ;; bunch by one to preserve that property.
- (coding-system-for-read 'no-conversion)
- ;; This is to control encoding the arguments in call-process.
- (coding-system-for-write
- (and enable-multibyte-characters
- (or file-name-coding-system
- default-file-name-coding-system))))
- (setq result
- (if wildcard
- ;; If the wildcard is just in the file part, then run ls in
- ;; the directory part of the file pattern using the last
- ;; component as argument. Otherwise, run ls in the longest
- ;; subdirectory of the directory part free of wildcards; use
- ;; the remaining of the file pattern as argument.
- (let* ((dir-wildcard (insert-directory-wildcard-in-dir-p file))
- (default-directory
- (cond (dir-wildcard (car dir-wildcard))
- (t
- (if (file-name-absolute-p file)
- (file-name-directory file)
- (file-name-directory (expand-file-name file))))))
- (pattern (if dir-wildcard (cdr dir-wildcard) (file-name-nondirectory file))))
- ;; NB since switches is passed to the shell, be
- ;; careful of malicious values, eg "-l;reboot".
- ;; See eg dired-safe-switches-p.
- (call-process
- shell-file-name nil t nil
- shell-command-switch
- (concat (if (memq system-type '(ms-dos windows-nt))
- ""
- "\\") ; Disregard Unix shell aliases!
- insert-directory-program
- " -d "
- (if (stringp switches)
- switches
- (mapconcat 'identity switches " "))
- " -- "
- ;; Quote some characters that have
- ;; special meanings in shells; but
- ;; don't quote the wildcards--we want
- ;; them to be special. We also
- ;; currently don't quote the quoting
- ;; characters in case people want to
- ;; use them explicitly to quote
- ;; wildcard characters.
- (shell-quote-wildcard-pattern pattern))))
- ;; SunOS 4.1.3, SVr4 and others need the "." to list the
- ;; directory if FILE is a symbolic link.
- (unless full-directory-p
- (setq switches
- (cond
- ((stringp switches) (concat switches " -d"))
- ((member "-d" switches) switches)
- (t (append switches '("-d"))))))
- (if (string-match "\\`~" file)
- (setq file (expand-file-name file)))
- (apply 'call-process
- insert-directory-program nil t nil
- (append
- (if (listp switches) switches
- (unless (equal switches "")
- ;; Split the switches at any spaces so we can
- ;; pass separate options as separate args.
- (split-string-and-unquote switches)))
- ;; Avoid lossage if FILE starts with `-'.
- '("--")
- (list file))))))
-
- ;; If we got "//DIRED//" in the output, it means we got a real
- ;; directory listing, even if `ls' returned nonzero.
- ;; So ignore any errors.
- (when (if (stringp switches)
- (string-match "--dired\\>" switches)
- (member "--dired" switches))
- (save-excursion
- (forward-line -2)
- (when (looking-at "//SUBDIRED//")
- (forward-line -1))
- (if (looking-at "//DIRED//")
- (setq result 0))))
-
- (when (and (not (eq 0 result))
- (eq insert-directory-ls-version 'unknown))
- ;; The first time ls returns an error,
- ;; find the version numbers of ls,
- ;; and set insert-directory-ls-version
- ;; to > if it is more than 5.2.1, < if it is less, nil if it
- ;; is equal or if the info cannot be obtained.
- ;; (That can mean it isn't GNU ls.)
- (let ((version-out
- (with-temp-buffer
- (call-process "ls" nil t nil "--version")
- (buffer-string))))
- (if (string-match "ls (.*utils) \\([0-9.]*\\)$" version-out)
- (let* ((version (match-string 1 version-out))
- (split (split-string version "[.]"))
- (numbers (mapcar 'string-to-number split))
- (min '(5 2 1))
- comparison)
- (while (and (not comparison) (or numbers min))
- (cond ((null min)
- (setq comparison '>))
- ((null numbers)
- (setq comparison '<))
- ((> (car numbers) (car min))
- (setq comparison '>))
- ((< (car numbers) (car min))
- (setq comparison '<))
- (t
- (setq numbers (cdr numbers)
- min (cdr min)))))
- (setq insert-directory-ls-version (or comparison '=)))
- (setq insert-directory-ls-version nil))))
-
- ;; For GNU ls versions 5.2.2 and up, ignore minor errors.
- (when (and (eq 1 result) (eq insert-directory-ls-version '>))
- (setq result 0))
-
- ;; If `insert-directory-program' failed, signal an error.
- (unless (eq 0 result)
- ;; Delete the error message it may have output.
- (delete-region beg (point))
- ;; On non-Posix systems, we cannot open a directory, so
- ;; don't even try, because that will always result in
- ;; the ubiquitous "Access denied". Instead, show the
- ;; command line so the user can try to guess what went wrong.
- (if (and (file-directory-p file)
- (memq system-type '(ms-dos windows-nt)))
- (error
- "Reading directory: \"%s %s -- %s\" exited with status %s"
- insert-directory-program
- (if (listp switches) (concat switches) switches)
- file result)
- ;; Unix. Access the file to get a suitable error.
- (access-file file "Reading directory")
- (error "Listing directory failed but `access-file' worked")))
- (insert-directory-clean beg switches)
- ;; Now decode what read if necessary.
- (let ((coding (or coding-system-for-read
- file-name-coding-system
- default-file-name-coding-system
- 'undecided))
- coding-no-eol
- val pos)
- (when (and enable-multibyte-characters
- (not (memq (coding-system-base coding)
- '(raw-text no-conversion))))
- ;; If no coding system is specified or detection is
- ;; requested, detect the coding.
- (if (eq (coding-system-base coding) 'undecided)
- (setq coding (detect-coding-region beg (point) t)))
- (if (not (eq (coding-system-base coding) 'undecided))
- (save-restriction
- (setq coding-no-eol
- (coding-system-change-eol-conversion coding 'unix))
- (narrow-to-region beg (point))
- (goto-char (point-min))
- (while (not (eobp))
- (setq pos (point)
- val (get-text-property (point) 'dired-filename))
- (goto-char (next-single-property-change
- (point) 'dired-filename nil (point-max)))
- ;; Force no eol conversion on a file name, so
- ;; that CR is preserved.
- (decode-coding-region pos (point)
- (if val coding-no-eol coding))
- (if val
- (put-text-property pos (point)
- 'dired-filename t)))))))))))
+ (cond
+ (handler
+ (funcall handler 'insert-directory file switches
+ wildcard full-directory-p))
+ ((not (files--use-insert-directory-program-p))
+ (require 'ls-lisp)
+ (declare-function ls-lisp--insert-directory "ls-lisp")
+ (ls-lisp--insert-directory file switches wildcard full-directory-p))
+ (t
+ (let (result (beg (point)))
+
+ ;; Read the actual directory using `insert-directory-program'.
+ ;; RESULT gets the status code.
+ (let* (;; We at first read by no-conversion, then after
+ ;; putting text property `dired-filename, decode one
+ ;; bunch by one to preserve that property.
+ (coding-system-for-read 'no-conversion)
+ ;; This is to control encoding the arguments in call-process.
+ (coding-system-for-write
+ (and enable-multibyte-characters
+ (or file-name-coding-system
+ default-file-name-coding-system))))
+ (setq result
+ (if wildcard
+ ;; If the wildcard is just in the file part, then run ls in
+ ;; the directory part of the file pattern using the last
+ ;; component as argument. Otherwise, run ls in the longest
+ ;; subdirectory of the directory part free of wildcards; use
+ ;; the remaining of the file pattern as argument.
+ (let* ((dir-wildcard (insert-directory-wildcard-in-dir-p file))
+ (default-directory
+ (cond (dir-wildcard (car dir-wildcard))
+ (t
+ (if (file-name-absolute-p file)
+ (file-name-directory file)
+ (file-name-directory (expand-file-name file))))))
+ (pattern (if dir-wildcard (cdr dir-wildcard) (file-name-nondirectory file))))
+ ;; NB since switches is passed to the shell, be
+ ;; careful of malicious values, eg "-l;reboot".
+ ;; See eg dired-safe-switches-p.
+ (call-process
+ shell-file-name nil t nil
+ shell-command-switch
+ (concat (if (memq system-type '(ms-dos windows-nt))
+ ""
+ "\\") ; Disregard Unix shell aliases!
+ insert-directory-program
+ " -d "
+ (if (stringp switches)
+ switches
+ (mapconcat #'identity switches " "))
+ " -- "
+ ;; Quote some characters that have
+ ;; special meanings in shells; but
+ ;; don't quote the wildcards--we want
+ ;; them to be special. We also
+ ;; currently don't quote the quoting
+ ;; characters in case people want to
+ ;; use them explicitly to quote
+ ;; wildcard characters.
+ (shell-quote-wildcard-pattern pattern))))
+ ;; SunOS 4.1.3, SVr4 and others need the "." to list the
+ ;; directory if FILE is a symbolic link.
+ (unless full-directory-p
+ (setq switches
+ (cond
+ ((stringp switches) (concat switches " -d"))
+ ((member "-d" switches) switches)
+ (t (append switches '("-d"))))))
+ (if (string-match "\\`~" file)
+ (setq file (expand-file-name file)))
+ (apply #'call-process
+ insert-directory-program nil t nil
+ (append
+ (if (listp switches) switches
+ (unless (equal switches "")
+ ;; Split the switches at any spaces so we can
+ ;; pass separate options as separate args.
+ (split-string-and-unquote switches)))
+ ;; Avoid lossage if FILE starts with `-'.
+ '("--")
+ (list file))))))
+
+ ;; If we got "//DIRED//" in the output, it means we got a real
+ ;; directory listing, even if `ls' returned nonzero.
+ ;; So ignore any errors.
+ (when (if (stringp switches)
+ (string-match "--dired\\>" switches)
+ (member "--dired" switches))
+ (save-excursion
+ (forward-line -2)
+ (when (looking-at "//SUBDIRED//")
+ (forward-line -1))
+ (if (looking-at "//DIRED//")
+ (setq result 0))))
+
+ (when (and (not (eq 0 result))
+ (eq insert-directory-ls-version 'unknown))
+ ;; The first time ls returns an error,
+ ;; find the version numbers of ls,
+ ;; and set insert-directory-ls-version
+ ;; to > if it is more than 5.2.1, < if it is less, nil if it
+ ;; is equal or if the info cannot be obtained.
+ ;; (That can mean it isn't GNU ls.)
+ (let ((version-out
+ (with-temp-buffer
+ (call-process "ls" nil t nil "--version")
+ (buffer-string))))
+ (setq insert-directory-ls-version
+ (if (string-match "ls (.*utils) \\([0-9.]*\\)$" version-out)
+ (let* ((version (match-string 1 version-out))
+ (split (split-string version "[.]"))
+ (numbers (mapcar #'string-to-number split))
+ (min '(5 2 1))
+ comparison)
+ (while (and (not comparison) (or numbers min))
+ (cond ((null min)
+ (setq comparison #'>))
+ ((null numbers)
+ (setq comparison #'<))
+ ((> (car numbers) (car min))
+ (setq comparison #'>))
+ ((< (car numbers) (car min))
+ (setq comparison #'<))
+ (t
+ (setq numbers (cdr numbers)
+ min (cdr min)))))
+ (or comparison #'=))
+ nil))))
+
+ ;; For GNU ls versions 5.2.2 and up, ignore minor errors.
+ (when (and (eq 1 result) (eq insert-directory-ls-version #'>))
+ (setq result 0))
+
+ ;; If `insert-directory-program' failed, signal an error.
+ (unless (eq 0 result)
+ ;; Delete the error message it may have output.
+ (delete-region beg (point))
+ ;; On non-Posix systems, we cannot open a directory, so
+ ;; don't even try, because that will always result in
+ ;; the ubiquitous "Access denied". Instead, show the
+ ;; command line so the user can try to guess what went wrong.
+ (if (and (file-directory-p file)
+ (memq system-type '(ms-dos windows-nt)))
+ (error
+ "Reading directory: \"%s %s -- %s\" exited with status %s"
+ insert-directory-program
+ (if (listp switches) (concat switches) switches)
+ file result)
+ ;; Unix. Access the file to get a suitable error.
+ (access-file file "Reading directory")
+ (error "Listing directory failed but `access-file' worked")))
+ (insert-directory-clean beg switches)
+ ;; Now decode what read if necessary.
+ (let ((coding (or coding-system-for-read
+ file-name-coding-system
+ default-file-name-coding-system
+ 'undecided))
+ coding-no-eol
+ val pos)
+ (when (and enable-multibyte-characters
+ (not (memq (coding-system-base coding)
+ '(raw-text no-conversion))))
+ ;; If no coding system is specified or detection is
+ ;; requested, detect the coding.
+ (if (eq (coding-system-base coding) 'undecided)
+ (setq coding (detect-coding-region beg (point) t)))
+ (if (not (eq (coding-system-base coding) 'undecided))
+ (save-restriction
+ (setq coding-no-eol
+ (coding-system-change-eol-conversion coding 'unix))
+ (narrow-to-region beg (point))
+ (goto-char (point-min))
+ (while (not (eobp))
+ (setq pos (point)
+ val (get-text-property (point) 'dired-filename))
+ (goto-char (next-single-property-change
+ (point) 'dired-filename nil (point-max)))
+ ;; Force no eol conversion on a file name, so
+ ;; that CR is preserved.
+ (decode-coding-region pos (point)
+ (if val coding-no-eol coding))
+ (if val
+ (put-text-property pos (point)
+ 'dired-filename t))))))))))))
(defun insert-directory-adj-pos (pos error-lines)
"Convert `ls --dired' file name position value POS to a buffer position.
@@ -8465,7 +8718,7 @@ the leading `-' character."
(defun file-modes-symbolic-to-number (modes &optional from)
"Convert symbolic file modes to numeric file modes.
MODES is the string to convert, it should match
-\"[ugoa]*([+-=][rwxXstugo]*)+,...\".
+\"[ugoa]*([+=-][rwxXstugo]*)+,...\".
See Info node `(coreutils)File permissions' for more information on this
notation.
FROM (or 0 if nil) gives the mode bits on which to base permissions if
diff --git a/lisp/filesets.el b/lisp/filesets.el
index 0b97bd4c518..68133ba2255 100644
--- a/lisp/filesets.el
+++ b/lisp/filesets.el
@@ -161,18 +161,9 @@ COND-FN takes one argument: the current element."
(define-obsolete-function-alias 'filesets-member #'cl-member "28.1")
(define-obsolete-function-alias 'filesets-sublist #'seq-subseq "28.1")
-(defun filesets-select-command (cmd-list)
- "Select one command from CMD-LIST -- a string with space separated names."
- (let ((this (shell-command-to-string
- (format "which --skip-alias %s 2> %s | head -n 1"
- cmd-list null-device))))
- (if (equal this "")
- nil
- (file-name-nondirectory (substring this 0 (- (length this) 1))))))
-
(defun filesets-which-command (cmd)
"Call \"which CMD\"."
- (shell-command-to-string (format "which %s" cmd)))
+ (shell-command-to-string (format "which %s" (shell-quote-argument cmd))))
(defun filesets-which-command-p (cmd)
"Call \"which CMD\" and return non-nil if the command was found."
@@ -286,7 +277,7 @@ See `easy-menu-add-item' for documentation."
)
(defcustom filesets-menu-in-menu nil
- "Use that instead of `current-menubar' as the menu to change.
+ "Use that instead of `current-global-map' as the menu to change.
See `easy-menu-add-item' for documentation."
:set #'filesets-set-default
:type 'sexp)
@@ -413,15 +404,14 @@ directory's name.
Note: You have to manually rebuild the menu if you change this value."
:set #'filesets-set-default
- :type '(choice :tag "Function:"
+ :type '(choice :tag "Function"
(const :tag "dired"
:value dired)
(list :tag "Command"
:value ("" "%s")
(string :tag "Name")
(string :tag "Arguments"))
- (function :tag "Function"
- :value nil)))
+ (function :tag "Function")))
(defcustom filesets-open-file-function #'filesets-find-or-display-file
"The function used for opening files.
@@ -437,23 +427,21 @@ readable, will not be opened.
Caveat: Changes will take effect only after rebuilding the menu."
:set #'filesets-set-default
- :type '(choice :tag "Function:"
+ :type '(choice :tag "Function"
(const :tag "filesets-find-or-display-file"
:value filesets-find-or-display-file)
(const :tag "filesets-find-file"
:value filesets-find-file)
- (function :tag "Function"
- :value nil)))
+ (function :tag "Function")))
(defcustom filesets-save-buffer-function #'save-buffer
"The function used to save a buffer.
Caveat: Changes will take effect after rebuilding the menu."
:set #'filesets-set-default
- :type '(choice :tag "Function:"
+ :type '(choice :tag "Function"
(const :tag "save-buffer"
:value save-buffer)
- (function :tag "Function"
- :value nil)))
+ (function :tag "Function")))
(defcustom filesets-find-file-delay
(if (and (featurep 'xemacs) gutter-buffers-tab-visible-p)
@@ -535,7 +523,7 @@ the filename."
:type '(repeat :tag "Commands"
(list :tag "Definition" :value ("")
(string "Name")
- (choice :tag "Command"
+ (choice :tag "Command" :value ""
(string :tag "String")
(function :tag "Function"))
(repeat :tag "Argument List"
@@ -546,21 +534,10 @@ the filename."
:value "<file-name>")
(string :tag "Quoted File Name"
:value "<<file-name>>")
- (function :tag "Function"
- :value nil))))))
+ (function :tag "Function"))))))
(defcustom filesets-external-viewers
(let
- ;; ((ps-cmd (or (and (boundp 'my-ps-viewer) my-ps-viewer)
- ;; (filesets-select-command "ggv gv")))
- ;; (pdf-cmd (or (and (boundp 'my-ps-viewer) my-pdf-viewer)
- ;; (filesets-select-command "xpdf acroread")))
- ;; (dvi-cmd (or (and (boundp 'my-ps-viewer) my-dvi-viewer)
- ;; (filesets-select-command "xdvi tkdvi")))
- ;; (doc-cmd (or (and (boundp 'my-ps-viewer) my-doc-viewer)
- ;; (filesets-select-command "antiword")))
- ;; (pic-cmd (or (and (boundp 'my-ps-viewer) my-pic-viewer)
- ;; (filesets-select-command "gqview ee display"))))
((ps-cmd "ggv")
(pdf-cmd "xpdf")
(dvi-cmd "xdvi")
@@ -647,12 +624,12 @@ In order to view pdf or rtf files in an Emacs buffer, you could use these:
(repeat :tag "Properties"
(choice
(list :tag ":constraintp"
- :value (:constraintp)
+ :value (:constraintp ignore)
(const :format ""
:value :constraintp)
(function :tag "Function"))
(list :tag ":constraint-flag (obsolete)"
- :value (:constraint-flag)
+ :value (:constraint-flag nil)
(const :format ""
:value :constraint-flag)
(sexp :tag "Symbol"))
@@ -667,7 +644,7 @@ In order to view pdf or rtf files in an Emacs buffer, you could use these:
:value :ignore-on-read-text)
(boolean :tag "Boolean"))
(list :tag ":args"
- :value (:args)
+ :value (:args nil)
(const :format ""
:value :args)
(repeat :tag "List"
@@ -676,10 +653,9 @@ In order to view pdf or rtf files in an Emacs buffer, you could use these:
:value "")
(symbol :tag "Symbol"
:value nil)
- (function :tag "Function"
- :value nil))))
+ (function :tag "Function"))))
(list :tag ":open-hook"
- :value (:open-hook)
+ :value (:open-hook nil)
(const :format ""
:value :open-hook)
(hook :tag "Hook"))
@@ -1089,10 +1065,6 @@ Return full path if FULL-FLAG is non-nil."
(t
(error "Filesets: %s does not exist" dir))))
-(defun filesets-quote (txt)
- "Return TXT in quotes."
- (concat "\"" txt "\""))
-
(defun filesets-get-selection ()
"Get the text between mark and point -- i.e. the selection or region."
(let ((m (mark))
@@ -1103,7 +1075,7 @@ Return full path if FULL-FLAG is non-nil."
(defun filesets-get-quoted-selection ()
"Return the currently selected text in quotes."
- (filesets-quote (filesets-get-selection)))
+ (shell-quote-argument (filesets-get-selection)))
(defun filesets-get-shortcut (n)
"Create menu shortcuts based on number N."
@@ -1250,12 +1222,13 @@ Use the viewer defined in EV-ENTRY (a valid element of
(if fmt
(mapconcat
(lambda (this)
- (if (stringp this) (format this file)
- (format "%S" (if (functionp this)
- (funcall this)
- this))))
+ (if (stringp this)
+ (format this (shell-quote-argument file))
+ (shell-quote-argument (if (functionp this)
+ (funcall this)
+ this))))
fmt "")
- (format "%S" file))))
+ (shell-quote-argument file))))
(output
(cond
((and (functionp vwr) co-flag)
@@ -1264,7 +1237,7 @@ Use the viewer defined in EV-ENTRY (a valid element of
(funcall vwr file)
nil)
(co-flag
- (shell-command-to-string (format "%s %s" vwr args)))
+ (shell-command-to-string (format "%s %s" vwr args)))
(t
(shell-command (format "%s %s&" vwr args))
nil))))
@@ -1772,7 +1745,7 @@ If no fileset name is provided, prompt for NAME."
(add-to-list 'filesets-data (list name '(:files)))
(message
(substitute-command-keys
- "Fileset %s created. Call `\\[filesets-save-config]' to save.")
+ "Fileset %s created. Call \\[filesets-save-config] to save.")
name)
(car filesets-data))))))
(if entry
@@ -1817,7 +1790,6 @@ If no fileset name is provided, prompt for NAME."
(defun filesets-convert-patterns (name)
"Change fileset NAME's mode from :pattern to :files."
- (interactive)
(let ((entry (assoc name filesets-data)))
(if entry
(let ((pattern (filesets-entry-get-pattern entry))
@@ -2489,11 +2461,15 @@ Set up hooks, load the cache file -- if existing -- and build the menu."
(setq filesets-menu-use-cached-flag t)))
(filesets-build-menu)))
+;;; obsolete
+
(defun filesets-error (_class &rest args)
"`error' wrapper."
(declare (obsolete error "28.1"))
(error "%s" (mapconcat #'identity args " ")))
+(define-obsolete-function-alias 'filesets-quote #'shell-quote-argument "30.1")
+
(provide 'filesets)
;;; filesets.el ends here
diff --git a/lisp/find-dired.el b/lisp/find-dired.el
index 5f5a25abf8b..41581cc7900 100644
--- a/lisp/find-dired.el
+++ b/lisp/find-dired.el
@@ -50,10 +50,13 @@ than the latter."
:group 'find-dired
:type 'string)
+(defvar find-gnu-find-p
+ (eq 0 (ignore-errors
+ (process-file find-program nil nil nil null-device "--version")))
+ "Non-nil if `find-program' is a GNU Find, nil otherwise.")
+
(defvar find-ls-option-default-ls
- (cons "-ls" (if (memq system-type '(berkeley-unix darwin))
- "-dgils"
- "-dilsb")))
+ (cons "-ls" (if find-gnu-find-p "-dilsb" "-dgils")))
(defvar find-ls-option-default-exec
(cons (format "-exec ls -ld {} %s" find-exec-terminator) "-ld"))
diff --git a/lisp/finder.el b/lisp/finder.el
index 2124b7064c4..1cf607c03c0 100644
--- a/lisp/finder.el
+++ b/lisp/finder.el
@@ -2,7 +2,7 @@
;; Copyright (C) 1992-2024 Free Software Foundation, Inc.
-;; Author: Eric S. Raymond <esr@snark.thyrsus.com>
+;; Author: Eric S. Raymond <esr@thyrsus.com>
;; Created: 16 Jun 1992
;; Keywords: help
@@ -68,10 +68,11 @@
(processes . "processes, subshells, and compilation")
(terminals . "text terminals (ttys)")
(tex . "the TeX document formatter")
+ (text . "editing text files")
(tools . "programming tools")
(unix . "UNIX feature interfaces and emulators")
(vc . "version control")
- (wp . "word processing"))
+ (wp . "use keyword `text' instead; this keyword is obsolete"))
"Association list of the standard \"Keywords:\" headers.
Each element has the form (KEYWORD . DESCRIPTION).")
@@ -166,6 +167,7 @@ would otherwise be.")
("org" . org)
("srecode" . srecode)
("term" . emacs)
+ ("use-package" . use-package)
("url" . url))
"Alist of built-in package directories.
Each element should have the form (DIR . PACKAGE), where DIR is a
diff --git a/lisp/foldout.el b/lisp/foldout.el
index 3d8e67951d5..495ce4339f7 100644
--- a/lisp/foldout.el
+++ b/lisp/foldout.el
@@ -229,7 +229,7 @@ An end marker of nil means the fold ends after (point-max).")
(error "Can't find outline-minor-mode in minor-mode-alist"))
;; slip our fold announcement into the list
- (setcdr outl-entry (nconc foldout-entry (cdr outl-entry)))))
+ (setcdr outl-entry (append foldout-entry (cdr outl-entry)))))
diff --git a/lisp/follow.el b/lisp/follow.el
index 316c85b1629..874e546bd6d 100644
--- a/lisp/follow.el
+++ b/lisp/follow.el
@@ -413,8 +413,8 @@ being able to use 144 or 216 lines instead of the normal 72... (your
mileage may vary).
To split one large window into two side-by-side windows, the commands
-`\\[split-window-right]' or \
-`\\[follow-delete-other-windows-and-split]' can be used.
+\\[split-window-right] or \
+\\[follow-delete-other-windows-and-split] can be used.
Only windows displayed in the same frame follow each other.
@@ -874,6 +874,7 @@ from the bottom."
(when (< dest win-s)
(setq follow-internal-force-redisplay t))))))
+(put 'follow-recenter 'isearch-scroll t)
(defun follow-redraw ()
"Arrange windows displaying the same buffer in successor order.
diff --git a/lisp/font-lock.el b/lisp/font-lock.el
index e8072718dd1..7b077a826bf 100644
--- a/lisp/font-lock.el
+++ b/lisp/font-lock.el
@@ -299,8 +299,8 @@ that match at least one applicable CONDITION are disabled."
"If non-nil, means show status messages for buffer fontification.
If a number, only buffers greater than this size have fontification messages."
:type '(choice (const :tag "never" nil)
- (other :tag "always" t)
- (integer :tag "size"))
+ (integer :tag "size")
+ (other :tag "always" t))
:group 'font-lock
:version "24.1")
diff --git a/lisp/format.el b/lisp/format.el
index afe2b47fb65..34bd30e83a5 100644
--- a/lisp/format.el
+++ b/lisp/format.el
@@ -87,11 +87,16 @@
rot13-region rot13-region t nil)
(duden ,(purecopy "Duden Ersatzdarstellung")
nil
- ,(purecopy "diac") iso-iso2duden t nil)
+ ;; FROM-FN used to call the "diac" command which is not widely
+ ;; available and apparently not under a free software license:
+ ;; https://nm.wu-wien.ac.at/nm/download/file/diac4.tar.gz
+ ;; Reliable round-trip conversion is not possible anyway
+ ;; and would be by heuristic method, so use nil for now.
+ nil iso-iso2duden t nil)
(de646 ,(purecopy "German ASCII (ISO 646)")
nil
- ,(purecopy "recode -f iso646-ge:latin1")
- ,(purecopy "recode -f latin1:iso646-ge") t nil)
+ ,(purecopy "iconv -f iso646-de -t utf-8")
+ ,(purecopy "iconv -f utf-8 -t iso646-de") t nil)
(denet ,(purecopy "net German")
nil
iso-german iso-cvt-read-only t nil)
@@ -290,7 +295,7 @@ For most purposes, consider using `format-decode-region' instead."
(setq try format-alist))
(setq try (cdr try))))))
;; Deal with given format(s)
- (or (listp format) (setq format (list format)))
+ (setq format (ensure-list format))
(let ((do format) f)
(while do
(or (setq f (assq (car do) format-alist))
diff --git a/lisp/forms.el b/lisp/forms.el
index e38fa7ae873..3a3160a0c8b 100644
--- a/lisp/forms.el
+++ b/lisp/forms.el
@@ -343,7 +343,7 @@ suitable for forms processing.")
(defvar forms-write-file-filter nil
"The name of a function that is called before writing the data file.
-This can be used to undo the effects of `form-read-file-hook'.")
+This can be used to undo the effects of `forms-read-file-filter'.")
(defvar forms-new-record-filter nil
"The name of a function that is called when a new record is created.")
diff --git a/lisp/frame.el b/lisp/frame.el
index bf770f3126d..d2376f1e339 100644
--- a/lisp/frame.el
+++ b/lisp/frame.el
@@ -239,7 +239,8 @@ that's not the whole story: see `after-focus-change-function'."
This function runs the abnormal hook `move-frame-functions'."
(interactive "e")
(let ((frame (posn-window (event-start event))))
- (run-hook-with-args 'move-frame-functions frame)))
+ (when (frame-live-p frame) ;Experience shows it can die in the meantime.
+ (run-hook-with-args 'move-frame-functions frame))))
;;;; Arrangement of frames at startup
@@ -1193,7 +1194,7 @@ e.g. (mapc \\='frame-set-background-mode (frame-list))."
(defvar inhibit-frame-set-background-mode nil)
-(defun frame--current-backround-mode (frame)
+(defun frame--current-background-mode (frame)
(let* ((frame-default-bg-mode (frame-terminal-default-bg-mode frame))
(bg-color (frame-parameter frame 'background-color))
(tty-type (tty-type frame))
@@ -1223,7 +1224,7 @@ If optional arg KEEP-FACE-SPECS is non-nil, don't recalculate
face specs for the new background mode."
(unless inhibit-frame-set-background-mode
(let* ((bg-mode
- (frame--current-backround-mode frame))
+ (frame--current-background-mode frame))
(display-type
(cond ((null (window-system frame))
(if (tty-display-color-p frame) 'color 'mono))
@@ -1302,7 +1303,7 @@ the `background-mode' terminal parameter."
;; :global t
;; :group 'faces
;; (when (eq dark-mode
-;; (eq 'light (frame--current-backround-mode (selected-frame))))
+;; (eq 'light (frame--current-background-mode (selected-frame))))
;; ;; FIXME: Change the face's SPEC instead?
;; (set-face-attribute 'default nil
;; :foreground (face-attribute 'default :background)
@@ -1652,6 +1653,7 @@ live frame and defaults to the selected one."
(declare-function ns-frame-geometry "nsfns.m" (&optional frame))
(declare-function pgtk-frame-geometry "pgtkfns.c" (&optional frame))
(declare-function haiku-frame-geometry "haikufns.c" (&optional frame))
+(declare-function android-frame-geometry "androidfns.c" (&optional frame))
(defun frame-geometry (&optional frame)
"Return geometric attributes of FRAME.
@@ -1705,6 +1707,8 @@ and width values are in pixels.
(pgtk-frame-geometry frame))
((eq frame-type 'haiku)
(haiku-frame-geometry frame))
+ ((eq frame-type 'android)
+ (android-frame-geometry frame))
(t
(list
'(outer-position 0 . 0)
@@ -1831,6 +1835,7 @@ of frames like calls to map a frame or change its visibility."
(declare-function ns-frame-edges "nsfns.m" (&optional frame type))
(declare-function pgtk-frame-edges "pgtkfns.c" (&optional frame type))
(declare-function haiku-frame-edges "haikufns.c" (&optional frame type))
+(declare-function android-frame-edges "androidfns.c" (&optional frame type))
(defun frame-edges (&optional frame type)
"Return coordinates of FRAME's edges.
@@ -1858,6 +1863,8 @@ FRAME."
(pgtk-frame-edges frame type))
((eq frame-type 'haiku)
(haiku-frame-edges frame type))
+ ((eq frame-type 'android)
+ (android-frame-edges frame type))
(t
(list 0 0 (frame-width frame) (frame-height frame))))))
@@ -1866,6 +1873,7 @@ FRAME."
(declare-function ns-mouse-absolute-pixel-position "nsfns.m")
(declare-function pgtk-mouse-absolute-pixel-position "pgtkfns.c")
(declare-function haiku-mouse-absolute-pixel-position "haikufns.c")
+(declare-function android-mouse-absolute-pixel-position "androidfns.c")
(defun mouse-absolute-pixel-position ()
"Return absolute position of mouse cursor in pixels.
@@ -1884,6 +1892,8 @@ position (0, 0) of the selected frame's terminal."
(pgtk-mouse-absolute-pixel-position))
((eq frame-type 'haiku)
(haiku-mouse-absolute-pixel-position))
+ ((eq frame-type 'android)
+ (android-mouse-absolute-pixel-position))
(t
(cons 0 0)))))
@@ -1892,6 +1902,8 @@ position (0, 0) of the selected frame's terminal."
(declare-function w32-set-mouse-absolute-pixel-position "w32fns.c" (x y))
(declare-function x-set-mouse-absolute-pixel-position "xfns.c" (x y))
(declare-function haiku-set-mouse-absolute-pixel-position "haikufns.c" (x y))
+(declare-function android-set-mouse-absolute-pixel-position
+ "androidfns.c" (x y))
(defun set-mouse-absolute-pixel-position (x y)
"Move mouse pointer to absolute pixel position (X, Y).
@@ -1908,7 +1920,9 @@ position (0, 0) of the selected frame's terminal."
((eq frame-type 'w32)
(w32-set-mouse-absolute-pixel-position x y))
((eq frame-type 'haiku)
- (haiku-set-mouse-absolute-pixel-position x y)))))
+ (haiku-set-mouse-absolute-pixel-position x y))
+ ((eq frame-type 'android)
+ (android-set-mouse-absolute-pixel-position x y)))))
(defun frame-monitor-attributes (&optional frame)
"Return the attributes of the physical monitor dominating FRAME.
@@ -2004,6 +2018,7 @@ workarea attribute."
;; TODO: implement this on PGTK.
;; (declare-function pgtk-frame-list-z-order "pgtkfns.c" (&optional display))
(declare-function haiku-frame-list-z-order "haikufns.c" (&optional display))
+(declare-function android-frame-list-z-order "androidfns.c" (&optional display))
(defun frame-list-z-order (&optional display)
"Return list of Emacs' frames, in Z (stacking) order.
@@ -2029,13 +2044,17 @@ Return nil if DISPLAY contains no Emacs frame."
;; (pgtk-frame-list-z-order display)
nil)
((eq frame-type 'haiku)
- (haiku-frame-list-z-order display)))))
+ (haiku-frame-list-z-order display))
+ ((eq frame-type 'android)
+ (android-frame-list-z-order display)))))
(declare-function x-frame-restack "xfns.c" (frame1 frame2 &optional above))
(declare-function w32-frame-restack "w32fns.c" (frame1 frame2 &optional above))
(declare-function ns-frame-restack "nsfns.m" (frame1 frame2 &optional above))
(declare-function pgtk-frame-restack "pgtkfns.c" (frame1 frame2 &optional above))
(declare-function haiku-frame-restack "haikufns.c" (frame1 frame2 &optional above))
+(declare-function android-frame-restack "androidfns.c" (frame1 frame2
+ &optional above))
(defun frame-restack (frame1 frame2 &optional above)
"Restack FRAME1 below FRAME2.
@@ -2069,7 +2088,9 @@ Some window managers may refuse to restack windows."
((eq frame-type 'haiku)
(haiku-frame-restack frame1 frame2 above))
((eq frame-type 'pgtk)
- (pgtk-frame-restack frame1 frame2 above))))
+ (pgtk-frame-restack frame1 frame2 above))
+ ((eq frame-type 'android)
+ (android-frame-restack frame1 frame2 above))))
(error "Cannot restack frames")))
(defun frame-size-changed-p (&optional frame)
@@ -2104,6 +2125,7 @@ for FRAME."
;; or in https://debbugs.gnu.org/cgi/bugreport.cgi?bug=35058#17.
(declare-function msdos-mouse-p "dosfns.c")
+(declare-function android-detect-mouse "androidfns.c")
(defun display-mouse-p (&optional display)
"Return non-nil if DISPLAY has a mouse available.
@@ -2118,6 +2140,8 @@ frame's display)."
(> w32-num-mouse-buttons 0)))
((memq frame-type '(x ns haiku pgtk))
t) ;; We assume X, NeXTstep, GTK, and Haiku *always* have a pointing device
+ ((eq frame-type 'android)
+ (android-detect-mouse))
(t
(or (and (featurep 'xt-mouse)
xterm-mouse-mode)
@@ -2133,8 +2157,12 @@ frame's display)."
"Return non-nil if popup menus are supported on DISPLAY.
DISPLAY can be a display name, a frame, or nil (meaning the selected
frame's display).
-Support for popup menus requires that the mouse be available."
- (display-mouse-p display))
+Support for popup menus requires that a suitable pointing device
+be available."
+ ;; Android menus work fine with touch screens as well, and one must
+ ;; be present.
+ (or (eq (framep-on-display display) 'android)
+ (display-mouse-p display)))
(defun display-graphic-p (&optional display)
"Return non-nil if DISPLAY is a graphic display.
@@ -2143,7 +2171,8 @@ frames and several different fonts at once. This is true for displays
that use a window system such as X, and false for text-only terminals.
DISPLAY can be a display name, a frame, or nil (meaning the selected
frame's display)."
- (not (null (memq (framep-on-display display) '(x w32 ns pgtk haiku)))))
+ (not (null (memq (framep-on-display display) '(x w32 ns pgtk haiku
+ android)))))
(defun display-images-p (&optional display)
"Return non-nil if DISPLAY can display images.
@@ -2195,7 +2224,7 @@ frame's display)."
This means that, for example, DISPLAY can differentiate between
the keybinding RET and [return]."
(let ((frame-type (framep-on-display display)))
- (or (memq frame-type '(x w32 ns pc pgtk haiku))
+ (or (memq frame-type '(x w32 ns pc pgtk haiku android))
;; MS-DOS and MS-Windows terminals have built-in support for
;; function (symbol) keys
(memq system-type '(ms-dos windows-nt)))))
@@ -2208,7 +2237,7 @@ DISPLAY should be either a frame or a display name (a string).
If DISPLAY is omitted or nil, it defaults to the selected frame's display."
(let ((frame-type (framep-on-display display)))
(cond
- ((memq frame-type '(x w32 ns haiku pgtk))
+ ((memq frame-type '(x w32 ns haiku pgtk android))
(x-display-screens display))
(t
1))))
@@ -2228,7 +2257,7 @@ with DISPLAY. To get information for each physical monitor, use
`display-monitor-attributes-list'."
(let ((frame-type (framep-on-display display)))
(cond
- ((memq frame-type '(x w32 ns haiku pgtk))
+ ((memq frame-type '(x w32 ns haiku pgtk android))
(x-display-pixel-height display))
(t
(frame-height (if (framep display) display (selected-frame)))))))
@@ -2248,7 +2277,7 @@ with DISPLAY. To get information for each physical monitor, use
`display-monitor-attributes-list'."
(let ((frame-type (framep-on-display display)))
(cond
- ((memq frame-type '(x w32 ns haiku pgtk))
+ ((memq frame-type '(x w32 ns haiku pgtk android))
(x-display-pixel-width display))
(t
(frame-width (if (framep display) display (selected-frame)))))))
@@ -2286,7 +2315,7 @@ For graphical terminals, note that on \"multi-monitor\" setups this
refers to the height in millimeters for all physical monitors
associated with DISPLAY. To get information for each physical
monitor, use `display-monitor-attributes-list'."
- (and (memq (framep-on-display display) '(x w32 ns haiku pgtk))
+ (and (memq (framep-on-display display) '(x w32 ns haiku pgtk android))
(or (cddr (assoc (or display (frame-parameter nil 'display))
display-mm-dimensions-alist))
(cddr (assoc t display-mm-dimensions-alist))
@@ -2307,7 +2336,7 @@ For graphical terminals, note that on \"multi-monitor\" setups this
refers to the width in millimeters for all physical monitors
associated with DISPLAY. To get information for each physical
monitor, use `display-monitor-attributes-list'."
- (and (memq (framep-on-display display) '(x w32 ns haiku pgtk))
+ (and (memq (framep-on-display display) '(x w32 ns haiku pgtk android))
(or (cadr (assoc (or display (frame-parameter nil 'display))
display-mm-dimensions-alist))
(cadr (assoc t display-mm-dimensions-alist))
@@ -2325,7 +2354,7 @@ DISPLAY can be a display name or a frame.
If DISPLAY is omitted or nil, it defaults to the selected frame's display."
(let ((frame-type (framep-on-display display)))
(cond
- ((memq frame-type '(x w32 ns haiku pgtk))
+ ((memq frame-type '(x w32 ns haiku pgtk android))
(x-display-backing-store display))
(t
'not-useful))))
@@ -2338,7 +2367,7 @@ DISPLAY can be a display name or a frame.
If DISPLAY is omitted or nil, it defaults to the selected frame's display."
(let ((frame-type (framep-on-display display)))
(cond
- ((memq frame-type '(x w32 ns haiku pgtk))
+ ((memq frame-type '(x w32 ns haiku pgtk android))
(x-display-save-under display))
(t
'not-useful))))
@@ -2351,7 +2380,7 @@ DISPLAY can be a display name or a frame.
If DISPLAY is omitted or nil, it defaults to the selected frame's display."
(let ((frame-type (framep-on-display display)))
(cond
- ((memq frame-type '(x w32 ns haiku pgtk))
+ ((memq frame-type '(x w32 ns haiku pgtk android))
(x-display-planes display))
((eq frame-type 'pc)
4)
@@ -2366,7 +2395,7 @@ DISPLAY can be a display name or a frame.
If DISPLAY is omitted or nil, it defaults to the selected frame's display."
(let ((frame-type (framep-on-display display)))
(cond
- ((memq frame-type '(x w32 ns haiku pgtk))
+ ((memq frame-type '(x w32 ns haiku pgtk android))
(x-display-color-cells display))
((eq frame-type 'pc)
16)
@@ -2383,7 +2412,7 @@ DISPLAY can be a display name or a frame.
If DISPLAY is omitted or nil, it defaults to the selected frame's display."
(let ((frame-type (framep-on-display display)))
(cond
- ((memq frame-type '(x w32 ns haiku pgtk))
+ ((memq frame-type '(x w32 ns haiku pgtk android))
(x-display-visual-class display))
((and (memq frame-type '(pc t))
(tty-display-color-p display))
@@ -2401,6 +2430,8 @@ If DISPLAY is omitted or nil, it defaults to the selected frame's display."
(&optional terminal))
(declare-function haiku-display-monitor-attributes-list "haikufns.c"
(&optional terminal))
+(declare-function android-display-monitor-attributes-list "androidfns.c"
+ (&optional terminal))
(defun display-monitor-attributes-list (&optional display)
"Return a list of physical monitor attributes on DISPLAY.
@@ -2454,6 +2485,8 @@ monitors."
(pgtk-display-monitor-attributes-list display))
((eq frame-type 'haiku)
(haiku-display-monitor-attributes-list display))
+ ((eq frame-type 'android)
+ (android-display-monitor-attributes-list display))
(t
(let ((geometry (list 0 0 (display-pixel-width display)
(display-pixel-height display))))
@@ -2529,6 +2562,28 @@ symbols."
'core-keyboard))))))
+;;;; On-screen keyboard management.
+
+(declare-function android-toggle-on-screen-keyboard "androidfns.c")
+
+(defun frame-toggle-on-screen-keyboard (frame hide)
+ "Display or hide the on-screen keyboard.
+On systems with an on-screen keyboard, display the on screen
+keyboard on behalf of the frame FRAME if HIDE is nil. Else, hide
+the on screen keyboard.
+
+Return whether or not the on screen keyboard may have been
+displayed; that is, return t on systems with an on screen
+keyboard, and nil on those without.
+
+FRAME must already have the input focus for this to work
+ reliably."
+ (let ((frame-type (framep-on-display frame)))
+ (cond ((eq frame-type 'android)
+ (android-toggle-on-screen-keyboard frame hide) t)
+ (t nil))))
+
+
;;;; Frame geometry values
(defun frame-geom-value-cons (type value &optional frame)
@@ -3111,6 +3166,9 @@ If FRAME isn't maximized, show the title bar."
frame 'undecorated
(eq (alist-get 'fullscreen (frame-parameters frame)) 'maximized)))
+(define-obsolete-function-alias 'frame--current-backround-mode
+ #'frame--current-background-mode "30.1")
+
(provide 'frame)
;;; frame.el ends here
diff --git a/lisp/gnus/gmm-utils.el b/lisp/gnus/gmm-utils.el
index e3296f10850..516758c0082 100644
--- a/lisp/gnus/gmm-utils.el
+++ b/lisp/gnus/gmm-utils.el
@@ -200,7 +200,8 @@ DEFAULT-MAP specifies the default key map for ICON-LIST."
"Create function NAME.
If FUNCTION exists, then NAME becomes an alias for FUNCTION.
Otherwise, create function NAME with ARG-LIST and BODY."
- (declare (indent defun))
+ (declare (obsolete nil "30.1")
+ (indent defun))
(let ((defined-p (fboundp function)))
(if defined-p
`(defalias ',name ',function)
diff --git a/lisp/gnus/gnus-agent.el b/lisp/gnus/gnus-agent.el
index 3ee93031119..0928b179787 100644
--- a/lisp/gnus/gnus-agent.el
+++ b/lisp/gnus/gnus-agent.el
@@ -2910,13 +2910,9 @@ The following commands are available:
(car func)
(gnus-byte-compile `(lambda () ,func)))))
-(defun gnus-agent-true ()
- "Return t."
- t)
+(defalias 'gnus-agent-true #'always)
-(defun gnus-agent-false ()
- "Return nil."
- nil)
+(defalias 'gnus-agent-false #'ignore)
(defun gnus-category-make-function-1 (predicate)
"Make a function from PREDICATE."
@@ -2924,8 +2920,9 @@ The following commands are available:
;; Functions are just returned as is.
((or (symbolp predicate)
(functionp predicate))
- `(,(or (cdr (assq predicate gnus-category-predicate-alist))
- predicate)))
+ (let ((fun (or (cdr (assq predicate gnus-category-predicate-alist))
+ predicate)))
+ (if (symbolp fun) `(,fun) `(funcall ',fun))))
;; More complex predicate.
((consp predicate)
`(,(cond
diff --git a/lisp/gnus/gnus-art.el b/lisp/gnus/gnus-art.el
index a12ec2c2feb..9f313108089 100644
--- a/lisp/gnus/gnus-art.el
+++ b/lisp/gnus/gnus-art.el
@@ -694,7 +694,7 @@ used as possible file names."
(defcustom gnus-page-delimiter "^\^L"
"Regexp describing what to use as article page delimiters.
-The default value is \"^\^L\", which is a form linefeed at the
+The default value is \"^\\^L\", which is a form linefeed at the
beginning of a line."
:type 'regexp
:group 'gnus-article-various)
@@ -2871,12 +2871,15 @@ Return file name relative to the parent of DIRECTORY."
cid handle directory))
(throw 'found file)))
((equal (concat "<" cid ">") (mm-handle-id handle))
- (setq file (or (mm-handle-filename handle)
- (concat
- (make-temp-name "cid")
- (car (rassoc (car (mm-handle-type handle))
- mailcap-mime-extensions))))
- afile (expand-file-name file directory))
+ ;; Randomize filenames: declared filenames may not be unique.
+ (setq file (format "cid-%d-%s"
+ (random 99)
+ (or (mm-handle-filename handle)
+ (concat
+ (make-temp-name "cid")
+ (car (rassoc (car (mm-handle-type handle))
+ mailcap-mime-extensions)))))
+ afile (expand-file-name file directory))
(mm-save-part-to-file handle afile)
(throw 'found (concat (file-name-nondirectory
(directory-file-name directory))
@@ -7391,6 +7394,7 @@ This is an extended text-mode.
\\{gnus-article-edit-mode-map}"
(make-local-variable 'gnus-article-edit-done-function)
(make-local-variable 'gnus-prev-winconf)
+ (make-local-variable 'gnus-prev-cwc)
(setq-local font-lock-defaults '(message-font-lock-keywords t))
(setq-local mail-header-separator "")
(setq-local gnus-article-edit-mode t)
@@ -7421,7 +7425,8 @@ groups."
(defun gnus-article-edit-article (start-func exit-func &optional quiet)
"Start editing the contents of the current article buffer."
- (let ((winconf (current-window-configuration)))
+ (let ((winconf (current-window-configuration))
+ (cwc gnus-current-window-configuration))
(set-buffer gnus-article-buffer)
(let ((message-auto-save-directory
;; Don't associate the article buffer with a draft file.
@@ -7432,6 +7437,7 @@ groups."
(gnus-configure-windows 'edit-article)
(setq gnus-article-edit-done-function exit-func)
(setq gnus-prev-winconf winconf)
+ (setq gnus-prev-cwc cwc)
(unless quiet
(gnus-message 6 "C-c C-c to end edits"))))
@@ -7441,7 +7447,8 @@ groups."
(let ((func gnus-article-edit-done-function)
(buf (current-buffer))
(start (window-start))
- (winconf gnus-prev-winconf))
+ (winconf gnus-prev-winconf)
+ (cwc gnus-prev-cwc))
(widen) ;; Widen it in case that users narrowed the buffer.
(funcall func arg)
(set-buffer buf)
@@ -7459,6 +7466,7 @@ groups."
(set-text-properties (point-min) (point-max) nil)
(gnus-article-mode)
(set-window-configuration winconf)
+ (setq gnus-current-window-configuration cwc)
(set-buffer buf)
(set-window-start (get-buffer-window buf) start)
(set-window-point (get-buffer-window buf) (point)))
@@ -7480,10 +7488,12 @@ groups."
(erase-buffer)
(if (gnus-buffer-live-p gnus-original-article-buffer)
(insert-buffer-substring gnus-original-article-buffer))
- (let ((winconf gnus-prev-winconf))
+ (let ((winconf gnus-prev-winconf)
+ (cwc gnus-prev-cwc))
(kill-all-local-variables)
(gnus-article-mode)
(set-window-configuration winconf)
+ (setq gnus-current-window-configuration cwc)
;; Tippy-toe some to make sure that point remains where it was.
(with-current-buffer curbuf
(set-window-start (get-buffer-window (current-buffer)) window-start)
@@ -8326,11 +8336,10 @@ url is put as the `gnus-button-url' overlay property on the button."
(when (looking-at "\\([A-Za-z]+\\):")
(setq scheme (match-string 1))
(goto-char (match-end 0)))
- (when (looking-at "//\\([^:/]+\\)\\(:?\\)\\([0-9]+\\)?/")
+ (when (looking-at "//\\([^:/]+\\):?\\([0-9]+\\)?/")
(setq server (match-string 1))
- (setq port (if (stringp (match-string 3))
- (string-to-number (match-string 3))
- (match-string 3)))
+ (setq port (and (match-beginning 2)
+ (string-to-number (match-string 2))))
(goto-char (match-end 0)))
(cond
diff --git a/lisp/gnus/gnus-cite.el b/lisp/gnus/gnus-cite.el
index ae497a072bc..3fde9baa0fe 100644
--- a/lisp/gnus/gnus-cite.el
+++ b/lisp/gnus/gnus-cite.el
@@ -1117,42 +1117,22 @@ Returns nil if there is no such line before LIMIT, t otherwise."
(setq count (1+ count)))))) ;;
"Keywords for highlighting different levels of message citations.")
-(defvar font-lock-defaults-computed)
-(defvar font-lock-keywords)
-(defvar font-lock-set-defaults)
-
-(autoload 'font-lock-set-defaults "font-lock")
-
(define-minor-mode gnus-message-citation-mode
"Minor mode providing more font-lock support for nested citations.
When enabled, it automatically turns on `font-lock-mode'."
:lighter ""
(when (derived-mode-p 'message-mode)
- ;; FIXME: Use font-lock-add-keywords!
- (let ((defaults (car font-lock-defaults))
- default) ;; keywords
- (while defaults
- (setq default (if (consp defaults)
- (pop defaults)
- (prog1
- defaults
- (setq defaults nil))))
- (if gnus-message-citation-mode
- ;; `gnus-message-citation-keywords' should be the last
- ;; elements of the keywords because the others are unlikely
- ;; to have the OVERRIDE flags -- XEmacs applies a keyword
- ;; having no OVERRIDE flag to matched text even if it has
- ;; already other faces, while Emacs doesn't.
- (set (make-local-variable default)
- (append (default-value default)
- gnus-message-citation-keywords))
- (kill-local-variable default))))
- ;; Force `font-lock-set-defaults' to update `font-lock-keywords'.
- (setq font-lock-set-defaults nil)
- (font-lock-set-defaults)
- (if font-lock-mode
- (font-lock-flush)
- (gnus-message-citation-mode (font-lock-mode 1)))))
+ (if (not font-lock-mode)
+ (gnus-message-citation-mode (font-lock-mode 1))
+ (if gnus-message-citation-mode
+ ;; `gnus-message-citation-keywords' should be the last
+ ;; elements of the keywords because the others are unlikely
+ ;; to have the OVERRIDE flags -- XEmacs applies a keyword
+ ;; having no OVERRIDE flag to matched text even if it has
+ ;; already other faces, while Emacs doesn't.
+ (font-lock-add-keywords nil gnus-message-citation-keywords t)
+ (font-lock-remove-keywords nil gnus-message-citation-keywords))
+ (font-lock-flush))))
(defun turn-on-gnus-message-citation-mode ()
"Turn on `gnus-message-citation-mode'."
diff --git a/lisp/gnus/gnus-cloud.el b/lisp/gnus/gnus-cloud.el
index ed8a6c11a3a..af5f42b1c3b 100644
--- a/lisp/gnus/gnus-cloud.el
+++ b/lisp/gnus/gnus-cloud.el
@@ -148,6 +148,7 @@ easy interactive way to set this from the Server buffer."
(defun gnus-cloud-decode-data ()
(cond
+ ;; FIXME: Duplicated value in ‘cond’: base64-gzip.
((memq gnus-cloud-storage-method '(base64 base64-gzip))
(base64-decode-region (point-min) (point-max)))
diff --git a/lisp/gnus/gnus-dired.el b/lisp/gnus/gnus-dired.el
index 48c1aef968b..f33c5f7f2e5 100644
--- a/lisp/gnus/gnus-dired.el
+++ b/lisp/gnus/gnus-dired.el
@@ -111,6 +111,12 @@ See `mail-user-agent' for more information."
(autoload 'gnus-completing-read "gnus-util")
+(defcustom gnus-dired-attach-at-end t
+ "Non-nil means that files should be attached at the end of a buffer."
+ :group 'mail ;; dired?
+ :version "30.1"
+ :type 'boolean)
+
;; Method to attach files to a mail composition.
(defun gnus-dired-attach (files-to-attach)
"Attach dired's marked files to a gnus message composition.
@@ -161,7 +167,8 @@ filenames."
;; set buffer to destination buffer, and attach files
(set-buffer destination)
- (goto-char (point-max)) ;attach at end of buffer
+ (when gnus-dired-attach-at-end
+ (goto-char (point-max))) ;attach at end of buffer
(while files-to-attach
(mml-attach-file (car files-to-attach)
(or (mm-default-file-type (car files-to-attach))
diff --git a/lisp/gnus/gnus-eform.el b/lisp/gnus/gnus-eform.el
index 060049f3d2b..ca76c714caa 100644
--- a/lisp/gnus/gnus-eform.el
+++ b/lisp/gnus/gnus-eform.el
@@ -70,17 +70,20 @@ It is a slightly enhanced `lisp-data-mode'.
(when (gnus-visual-p 'group-menu 'menu)
(gnus-edit-form-make-menu-bar))
(make-local-variable 'gnus-edit-form-done-function)
- (make-local-variable 'gnus-prev-winconf))
+ (make-local-variable 'gnus-prev-winconf)
+ (make-local-variable 'gnus-prev-cwc))
(defun gnus-edit-form (form documentation exit-func &optional layout)
"Edit FORM in a new buffer.
Call EXIT-FUNC on exit. Display DOCUMENTATION in the beginning
of the buffer.
The optional LAYOUT overrides the `edit-form' window layout."
- (let ((winconf (current-window-configuration)))
+ (let ((winconf (current-window-configuration))
+ (cwc gnus-current-window-configuration))
(set-buffer (gnus-get-buffer-create gnus-edit-form-buffer))
(gnus-configure-windows (or layout 'edit-form))
(gnus-edit-form-mode)
+ (setq gnus-prev-cwc cwc)
(setq gnus-prev-winconf winconf)
(setq gnus-edit-form-done-function exit-func)
(erase-buffer)
@@ -113,9 +116,11 @@ The optional LAYOUT overrides the `edit-form' window layout."
(defun gnus-edit-form-exit ()
"Kill the current buffer."
(interactive nil gnus-edit-form-mode)
- (let ((winconf gnus-prev-winconf))
+ (let ((winconf gnus-prev-winconf)
+ (cwc gnus-prev-cwc))
(kill-buffer (current-buffer))
- (set-window-configuration winconf)))
+ (set-window-configuration winconf)
+ (setq gnus-current-window-configuration cwc)))
(provide 'gnus-eform)
diff --git a/lisp/gnus/gnus-group.el b/lisp/gnus/gnus-group.el
index d4df2c8585d..71bfaa639fa 100644
--- a/lisp/gnus/gnus-group.el
+++ b/lisp/gnus/gnus-group.el
@@ -1064,11 +1064,11 @@ When FORCE, rebuild the tool bar."
All normal editing commands are switched off.
\\<gnus-group-mode-map>
The group buffer lists (some of) the groups available. For instance,
-`\\[gnus-group-list-groups]' will list all subscribed groups with unread articles, while `\\[gnus-group-list-zombies]'
+\\[gnus-group-list-groups] will list all subscribed groups with unread articles, while \\[gnus-group-list-zombies]
lists all zombie groups.
-Groups that are displayed can be entered with `\\[gnus-group-read-group]'. To subscribe
-to a group not displayed, type `\\[gnus-group-toggle-subscription]'.
+Groups that are displayed can be entered with \\[gnus-group-read-group]. To subscribe
+to a group not displayed, type \\[gnus-group-toggle-subscription].
For more in-depth information on this mode, read the manual (`\\[gnus-info-find-node]').
@@ -1745,17 +1745,17 @@ already. If INFO-UNCHANGED is non-nil, dribble buffer is not updated."
gnus-level-killed))
(defun gnus-group-search-forward (&optional backward all level first-too)
- "Find the next newsgroup with unread articles.
-If BACKWARD is non-nil, find the previous newsgroup instead.
-If ALL is non-nil, just find any newsgroup.
-If LEVEL is non-nil, find group with level LEVEL, or higher if no such
-group exists.
-If FIRST-TOO, the current line is also eligible as a target."
+ "Move point to the next newsgroup with unread articles.
+If BACKWARD is non-nil, move to the previous newsgroup instead.
+If ALL is non-nil, consider any newsgroup, not only those with
+unread articles. If LEVEL is non-nil, find group with level
+LEVEL, or higher if no such group exists. If FIRST-TOO, the
+current line is also eligible as a target."
(let ((way (if backward -1 1))
(low gnus-level-killed)
(beg (point))
pos found lev)
- (if (and backward (progn (beginning-of-line)) (bobp))
+ (if (and backward (progn (beginning-of-line) (bobp)))
nil
(unless first-too
(forward-line way))
@@ -4189,7 +4189,8 @@ If DONT-SCAN is non-nil, scan non-activated groups as well."
(let ((info (gnus-get-info group))
(active (gnus-active group)))
(when info
- (gnus-request-update-info info method))
+ (gnus-request-update-info info method)
+ (setq active (gnus-active group)))
(gnus-get-unread-articles-in-group info active)
(unless (gnus-virtual-group-p group)
(gnus-close-group group))
@@ -4637,7 +4638,7 @@ and the second element is the address."
"Mark ARTICLE in GROUP with MARK, whether the group is displayed or not."
(let ((buffer (gnus-summary-buffer-name group)))
(if (gnus-buffer-live-p buffer)
- (with-current-buffer (get-buffer buffer)
+ (with-current-buffer buffer
(gnus-summary-add-mark article mark))
(gnus-add-marked-articles group (cdr (assq mark gnus-article-mark-lists))
(list article)))))
diff --git a/lisp/gnus/gnus-icalendar.el b/lisp/gnus/gnus-icalendar.el
index 7343130d0eb..af7284b88e8 100644
--- a/lisp/gnus/gnus-icalendar.el
+++ b/lisp/gnus/gnus-icalendar.el
@@ -165,7 +165,7 @@
(icalendar--get-event-property-attributes
event field) zone-map))
(dtdate-dec (icalendar--decode-isodatetime dtdate nil dtdate-zone)))
- (encode-time dtdate-dec)))
+ (when dtdate-dec (encode-time dtdate-dec))))
(defun gnus-icalendar-event--find-attendee (ical name-or-email)
(let* ((event (car (icalendar--all-events ical)))
@@ -642,16 +642,16 @@ is searched."
(delete-region (point) entry-end))
;; put new event description in the entry body
- (when description
- (save-restriction
- (narrow-to-region (point) (point))
- (insert "\n"
- (gnus-icalendar-event:org-timestamp event)
- "\n\n"
- (replace-regexp-in-string "[\n]+$" "\n" description)
- "\n")
- (indent-region (point-min) (point-max) (1+ entry-outline-level))
- (fill-region (point-min) (point-max))))
+ (save-restriction
+ (narrow-to-region (point) (point))
+ (insert "\n"
+ (gnus-icalendar-event:org-timestamp event)
+ "\n\n"
+ (replace-regexp-in-string "[\n]+$" "\n"
+ (or description "No description"))
+ "\n")
+ (indent-region (point-min) (point-max) (1+ entry-outline-level))
+ (fill-region (point-min) (point-max)))
;; update entry properties
(cl-labels
diff --git a/lisp/gnus/gnus-logic.el b/lisp/gnus/gnus-logic.el
index eea410a9cb0..3652b02672b 100644
--- a/lisp/gnus/gnus-logic.el
+++ b/lisp/gnus/gnus-logic.el
@@ -71,11 +71,11 @@
(+ (cdr score) new-score))
(push (cons (mail-header-number gnus-advanced-headers)
new-score)
- gnus-newsgroup-scored)
- (when trace
- (push (cons "A file" rule)
- ;; Must be synced with `gnus-score-edit-file-at-point'.
- gnus-score-trace)))))))
+ gnus-newsgroup-scored))
+ (when trace
+ (push (cons "A file" rule)
+ ;; Must be synced with `gnus-score-edit-file-at-point'.
+ gnus-score-trace))))))
(defun gnus-advanced-score-rule (rule)
"Apply RULE to `gnus-advanced-headers'."
diff --git a/lisp/gnus/gnus-msg.el b/lisp/gnus/gnus-msg.el
index cf7d1ba14b6..b18ede58fbf 100644
--- a/lisp/gnus/gnus-msg.el
+++ b/lisp/gnus/gnus-msg.el
@@ -1104,12 +1104,12 @@ If VERY-WIDE, make a very wide reply."
(setq headers (concat headers (buffer-string)))))))
(set-buffer (gnus-copy-article-buffer))
(gnus-msg-treat-broken-reply-to gnus-msg-force-broken-reply-to)
- (save-restriction
- (message-narrow-to-head)
- (when very-wide
- (erase-buffer)
- (insert headers))
- (goto-char (point-max)))
+ (when very-wide
+ (save-restriction
+ (message-narrow-to-head)
+ (delete-region (point-min) (point-max))
+ (insert headers)
+ (goto-char (point-max))))
(mml-quote-region (point) (point-max))
(message-reply nil wide)
(when yank
@@ -1189,12 +1189,12 @@ Uses the process/prefix convention.
The reply will include all From/Cc headers from the original
messages as the To/Cc headers.
-If prefix argument YANK is non-nil, the original article(s) will
+If prefix argument YANK is non-nil, the original article will
be yanked automatically."
(interactive (list (and current-prefix-arg
(gnus-summary-work-articles 1)))
gnus-summary-mode)
- (gnus-summary-reply yank t (gnus-summary-work-articles yank)))
+ (gnus-summary-reply yank t (gnus-summary-work-articles current-prefix-arg)))
(defun gnus-summary-very-wide-reply-with-original (n)
"Start composing a very wide reply mail a set of messages.
@@ -1209,7 +1209,7 @@ The original article(s) will be yanked."
(gnus-summary-reply
(gnus-summary-work-articles n) t (gnus-summary-work-articles n)))
-(defun gnus-summary-mail-forward (&optional arg post)
+(defun gnus-summary-mail-forward (&optional arg all-headers post)
"Forward the current message(s) to another user.
If process marks exist, forward all marked messages;
if ARG is nil, see `message-forward-as-mime' and `message-forward-show-mml';
@@ -1217,17 +1217,25 @@ if ARG is 1, decode the message and forward directly inline;
if ARG is 2, forward message as an rfc822 MIME section;
if ARG is 3, decode message and forward as an rfc822 MIME section;
if ARG is 4, forward message directly inline;
-otherwise, use flipped `message-forward-as-mime'.
+otherwise, use negated `message-forward-as-mime'.
If POST, post instead of mail.
-For the \"inline\" alternatives, also see the variable
-`message-forward-ignored-headers'."
- (interactive "P" gnus-summary-mode)
+If symbolic prefix ALL-HEADERS is the symbol `a', include all
+original headers in the forwarded message, except those matching
+`message-forward-ignored-headers'. Otherwise, include headers
+based on the options `message-forward-included-headers',
+`message-forward-ignored-headers', and potentially
+`message-forward-included-mime-headers'."
+ (interactive (gnus-interactive "P\ny") gnus-summary-mode)
(if (cdr (gnus-summary-work-articles nil))
;; Process marks are given.
(gnus-uu-digest-mail-forward nil post)
;; No process marks.
(let ((message-forward-as-mime message-forward-as-mime)
- (message-forward-show-mml message-forward-show-mml))
+ (message-forward-show-mml message-forward-show-mml)
+ (message-forward-included-headers
+ (if (eq all-headers 'a)
+ nil
+ message-forward-included-headers)))
(cond
((null arg))
((eq arg 1)
@@ -1380,11 +1388,11 @@ composing a new message."
(forward-char 1))
(widen)))))
-(defun gnus-summary-post-forward (&optional arg)
+(defun gnus-summary-post-forward (&optional arg all-headers)
"Forward the current article to a newsgroup.
See `gnus-summary-mail-forward' for ARG."
- (interactive "P" gnus-summary-mode)
- (gnus-summary-mail-forward arg t))
+ (interactive (gnus-interactive "P\ny") gnus-summary-mode)
+ (gnus-summary-mail-forward arg all-headers t))
(defun gnus-summary-mail-crosspost-complaint (n)
"Send a complaint about crossposting to the current article(s)."
diff --git a/lisp/gnus/gnus-notifications.el b/lisp/gnus/gnus-notifications.el
index f34f5ea0e26..e4c3d2c0381 100644
--- a/lisp/gnus/gnus-notifications.el
+++ b/lisp/gnus/gnus-notifications.el
@@ -75,35 +75,55 @@ not get notifications."
(when group-article
(let ((group (cadr group-article))
(article (nth 2 group-article)))
- (cond ((string= key "read")
+ (cond ((or (equal key "read")
+ (equal key "default"))
(gnus-fetch-group group (list article))
(select-frame-set-input-focus (selected-frame)))
- ((string= key "mark-read")
+ ((equal key "mark-read")
(gnus-update-read-articles
group
(delq article (gnus-list-of-unread-articles group)))
;; gnus-group-refresh-group
- (gnus-group-update-group group)))))))
+ (gnus-group-update-group group))))))
+ ;; Notifications are removed unless otherwise specified once they (or
+ ;; an action of theirs) are selected
+ (assoc-delete-all id gnus-notifications-id-to-msg))
+
+(defun gnus-notifications-close (id _reason)
+ "Remove ID from the alist of notification identifiers to messages.
+REASON is ignored."
+ (assoc-delete-all id gnus-notifications-id-to-msg))
(defun gnus-notifications-notify (from subject photo-file)
"Send a notification about a new mail.
Return a notification id if any, or t on success."
- (if (fboundp 'notifications-notify)
+ (if (featurep 'android)
(gnus-funcall-no-warning
- 'notifications-notify
+ 'android-notifications-notify
:title from
:body subject
:actions '("read" "Read" "mark-read" "Mark As Read")
:on-action 'gnus-notifications-action
- :app-icon (gnus-funcall-no-warning
- 'image-search-load-path "gnus/gnus.png")
- :image-path photo-file
- :app-name "Gnus"
- :category "email.arrived"
+ :on-close 'gnus-notifications-close
+ :group "Email arrivals"
:timeout gnus-notifications-timeout)
- (message "New message from %s: %s" from subject)
- ;; Don't return an id
- t))
+ (if (fboundp 'notifications-notify)
+ (gnus-funcall-no-warning
+ 'notifications-notify
+ :title from
+ :body subject
+ :actions '("read" "Read" "mark-read" "Mark As Read")
+ :on-action 'gnus-notifications-action
+ :on-close 'gnus-notifications-close
+ :app-icon (gnus-funcall-no-warning
+ 'image-search-load-path "gnus/gnus.png")
+ :image-path photo-file
+ :app-name "Gnus"
+ :category "email.arrived"
+ :timeout gnus-notifications-timeout)
+ (message "New message from %s: %s" from subject)
+ ;; Don't return an id
+ t)))
(declare-function gravatar-retrieve-synchronously "gravatar.el"
(mail-address))
diff --git a/lisp/gnus/gnus-registry.el b/lisp/gnus/gnus-registry.el
index 8e778c7afd9..0881bfce03c 100644
--- a/lisp/gnus/gnus-registry.el
+++ b/lisp/gnus/gnus-registry.el
@@ -394,7 +394,7 @@ This is not required after changing `gnus-registry-cache-file'."
(with-no-warnings
(eieio-persistent-read file 'registry-db))
;; Older EIEIO versions do not check the class name.
- ('wrong-number-of-arguments
+ (wrong-number-of-arguments
(eieio-persistent-read file)))))
(gnus-message 5 "Reading Gnus registry from %s...done" file))
diff --git a/lisp/gnus/gnus-score.el b/lisp/gnus/gnus-score.el
index 695556a491d..479b7496cf1 100644
--- a/lisp/gnus/gnus-score.el
+++ b/lisp/gnus/gnus-score.el
@@ -517,6 +517,35 @@ of the last successful match.")
"t" #'gnus-score-find-trace
"w" #'gnus-score-find-favorite-words))
+
+
+;; Touch screen ``character reading'' routines for
+;; `gnus-summary-increase-score' and friends.
+
+(defun gnus-read-char (prompt options)
+ "Read a character from the keyboard.
+
+On Android, if `use-dialog-box-p' returns non-nil, display a
+dialog box containing PROMPT, with buttons representing each of
+item in the list of characters OPTIONS instead.
+
+Value is the character read, as with `read-char', or nil upon
+failure."
+ (if (and (display-graphic-p) (featurep 'android)
+ (use-dialog-box-p))
+ ;; Set up the dialog box.
+ (let ((dialog (cons prompt ; Message displayed in dialog box.
+ (mapcar (lambda (arg)
+ (cons (char-to-string arg)
+ arg))
+ options))))
+ ;; Display the dialog box.
+ (x-popup-dialog t dialog))
+ ;; Fall back to read-char.
+ (read-char)))
+
+
+
;; Summary score file commands
;; Much modification of the kill (ahem, score) code and lots of the
@@ -588,21 +617,23 @@ current score file."
(aref (symbol-name gnus-score-default-type) 0)))
(pchar (and gnus-score-default-duration
(aref (symbol-name gnus-score-default-duration) 0)))
- entry temporary type match extra)
+ entry temporary type match extra header-string)
(unwind-protect
(progn
-
+ (setq header-string
+ (format "%s header (%s?): " (if increase "Increase" "Lower")
+ (mapconcat (lambda (s) (char-to-string (car s)))
+ char-to-header "")))
;; First we read the header to score.
(while (not hchar)
(if mimic
(progn
(sit-for 1)
(message "%c-" prefix))
- (message "%s header (%s?): " (if increase "Increase" "Lower")
- (mapconcat (lambda (s) (char-to-string (car s)))
- char-to-header "")))
- (setq hchar (read-char))
+ (message header-string))
+ (setq hchar (gnus-read-char header-string
+ (mapcar #'car char-to-header)))
(when (or (= hchar ??) (= hchar ?\C-h))
(setq hchar nil)
(gnus-score-insert-help "Match on header" char-to-header 1)))
@@ -625,17 +656,20 @@ current score file."
(nth 3 s))
s nil))
char-to-type))))
+ (setq header-string
+ (format "%s header `%s' with match type (%s?): "
+ (if increase "Increase" "Lower")
+ (nth 1 entry)
+ (mapconcat (lambda (s) (char-to-string (car s)))
+ legal-types "")))
;; We continue reading - the type.
(while (not tchar)
(if mimic
(progn
(sit-for 1) (message "%c %c-" prefix hchar))
- (message "%s header `%s' with match type (%s?): "
- (if increase "Increase" "Lower")
- (nth 1 entry)
- (mapconcat (lambda (s) (char-to-string (car s)))
- legal-types "")))
- (setq tchar (read-char))
+ (message header-string))
+ (setq tchar (gnus-read-char header-string
+ (mapcar #'car legal-types)))
(when (or (= tchar ??) (= tchar ?\C-h))
(setq tchar nil)
(gnus-score-insert-help "Match type" legal-types 2)))
@@ -651,15 +685,19 @@ current score file."
(message ""))
(setq pchar (or pchar ?t)))
+ (setq header-string
+ (format "%s permanence (%s?): " (if increase "Increase" "Lower")
+ (mapconcat (lambda (s) (char-to-string (car s)))
+ char-to-perm "")))
+
;; We continue reading.
(while (not pchar)
(if mimic
(progn
(sit-for 1) (message "%c %c %c-" prefix hchar tchar))
- (message "%s permanence (%s?): " (if increase "Increase" "Lower")
- (mapconcat (lambda (s) (char-to-string (car s)))
- char-to-perm "")))
- (setq pchar (read-char))
+ (message header-string))
+ (setq pchar (gnus-read-char header-string
+ (mapcar #'car char-to-perm)))
(when (or (= pchar ??) (= pchar ?\C-h))
(setq pchar nil)
(gnus-score-insert-help "Match permanence" char-to-perm 2)))
@@ -855,9 +893,14 @@ If optional argument `EXTRA' is non-nil, it's a non-standard overview header."
(t "permanent"))
header
(if (< score 0) "lower" "raise"))
- (if (numberp match)
- (int-to-string match)
- match))))
+ (cond ((numberp match) (int-to-string match))
+ ((string= header "date")
+ (int-to-string
+ (-
+ (/ (car (time-convert (current-time) 1)) 86400)
+ (/ (car (time-convert (gnus-date-get-time match) 1))
+ 86400))))
+ (t match)))))
;; If this is an integer comparison, we transform from string to int.
(if (eq (nth 2 (assoc header gnus-header-index)) 'gnus-score-integer)
@@ -2956,10 +2999,7 @@ The list is determined from the variable `gnus-score-file-alist'."
(group (or group gnus-newsgroup-name))
score-files)
(when group
- ;; Make sure funcs is a list.
- (and funcs
- (not (listp funcs))
- (setq funcs (list funcs)))
+ (setq funcs (ensure-list funcs))
(when gnus-score-use-all-scores
;; Get the initial score files for this group.
(when funcs
@@ -3066,12 +3106,8 @@ The list is determined from the variable `gnus-score-file-alist'."
(defun gnus-home-score-file (group &optional adapt)
"Return the home score file for GROUP.
If ADAPT, return the home adaptive file instead."
- (let ((list (if adapt gnus-home-adapt-file gnus-home-score-file))
+ (let ((list (ensure-list (if adapt gnus-home-adapt-file gnus-home-score-file)))
elem found)
- ;; Make sure we have a list.
- (unless (listp list)
- (setq list (list list)))
- ;; Go through the list and look for matches.
(while (and (not found)
(setq elem (pop list)))
(setq found
diff --git a/lisp/gnus/gnus-search.el b/lisp/gnus/gnus-search.el
index ab9cd09c9b7..a967d6d71da 100644
--- a/lisp/gnus/gnus-search.el
+++ b/lisp/gnus/gnus-search.el
@@ -1066,7 +1066,9 @@ Responsible for handling and, or, and parenthetical expressions.")
_srv query-spec groups)
(let ((artlist []))
(dolist (group groups)
- (let* ((gnus-newsgroup-selection (nnselect-get-artlist group))
+ (let* ((gnus-newsgroup-selection
+ (or
+ (nnselect-get-artlist group) (nnselect-generate-artlist group)))
(group-spec
(nnselect-categorize
(mapcar 'car
@@ -1330,9 +1332,10 @@ elements are present."
(1- nyear)
nyear))
(setq dmonth 1))))
- (format-time-string
- "%e-%b-%Y"
- (encode-time 0 0 0 dday dmonth dyear))))
+ (with-locale-environment "C"
+ (format-time-string
+ "%e-%b-%Y"
+ (encode-time 0 0 0 dday dmonth dyear)))))
(cl-defmethod gnus-search-imap-handle-string ((engine gnus-search-imap)
(str string))
@@ -1431,6 +1434,9 @@ Returns a list of [group article score] vectors."
""))
(groups (mapcar #'gnus-group-short-name groups))
artlist article group)
+ (when (>= gnus-verbose 7)
+ (gnus-message 7 "Search engine returned %d results"
+ (car (buffer-line-statistics))))
(goto-char (point-min))
;; Prep prefix, we want to at least be removing the root
;; filesystem separator.
@@ -1482,6 +1488,10 @@ Returns a list of [group article score] vectors."
;; Are we running an additional grep query?
(when-let ((grep-reg (alist-get 'grep query)))
(setq artlist (gnus-search-grep-search engine artlist grep-reg)))
+
+ (when (>= gnus-verbose 7)
+ (gnus-message 7 "Gnus search returning %d results"
+ (length artlist)))
;; Munge into the list of vectors expected by nnselect.
(mapcar (pcase-lambda (`(,_ ,article ,group ,score))
(vector
@@ -2173,37 +2183,80 @@ remaining string, then adds all that to the top-level spec."
(declare-function gnus-registry-get-id-key "gnus-registry" (id key))
-(defun gnus-search-thread (header)
- "Make an nnselect group based on the thread containing the article
-header. The current server will be searched. If the registry is
-installed, the server that the registry reports the current
-article came from is also searched."
- (let* ((ids (cons (mail-header-id header)
- (split-string
- (or (mail-header-references header)
- ""))))
- (query
- (list (cons 'query (mapconcat (lambda (i)
- (format "id:%s" i))
- ids " or "))
- (cons 'thread t)))
- (server
- (list (list (gnus-method-to-server
- (gnus-find-method-for-group gnus-newsgroup-name)))))
- (registry-group (and
- (bound-and-true-p gnus-registry-enabled)
- (car (gnus-registry-get-id-key
- (mail-header-id header) 'group))))
- (registry-server
- (and registry-group
- (gnus-method-to-server
- (gnus-find-method-for-group registry-group)))))
- (when registry-server
- (cl-pushnew (list registry-server) server :test #'equal))
- (gnus-group-make-search-group nil (list
- (cons 'search-query-spec query)
- (cons 'search-group-spec server)))
- (gnus-summary-goto-subject (gnus-id-to-article (mail-header-id header)))))
+(defun gnus-search-thread (header &optional group server)
+ "Find articles in the thread containing HEADER from GROUP on SERVER.
+If gnus-refer-thread-use-search is nil only the current group is
+checked for articles; if t all groups on the server containing
+the article's group will be searched; if a list then all servers
+in this list will be searched. If possible the newly found
+articles are added to the summary buffer; otherwise the full
+thread along with the original articles are displayed in a new
+ephemeral nnselect buffer."
+ (let* ((group (or group gnus-newsgroup-name))
+ (server (or server (gnus-group-server group)))
+ (query
+ (list
+ (cons 'query
+ (mapconcat (lambda (i) (format "id:%s" i))
+ (cons (mail-header-id header)
+ (split-string
+ (or (mail-header-references header) "")))
+ " or "))
+ (cons 'thread t)))
+ (gnus-search-use-parsed-queries t))
+ (if (not gnus-refer-thread-use-search)
+ ;; Search only the current group and send the headers back to
+ ;; the caller to add to the summary buffer.
+ (gnus-fetch-headers
+ (sort
+ (mapcar (lambda (x) (elt x 1))
+ (gnus-search-run-query
+ (list (cons 'search-query-spec query)
+ (cons 'search-group-spec
+ (list (list server group))))))
+ #'<) nil t)
+ ;; Otherwise create an ephemeral search group: record the
+ ;; current summary contents; exit the current group (so that
+ ;; changes are saved); then create a new ephemeral group with
+ ;; the original articles plus those of the thread.
+ (let ((selection (seq-map (lambda (x) (vector group x 100))
+ gnus-newsgroup-articles))
+ (thread (gnus-search-run-query
+ (list (cons 'search-query-spec query)
+ (cons 'search-group-spec
+ (if (listp gnus-refer-thread-use-search)
+ gnus-refer-thread-use-search
+ (list (list server))))))))
+ (if (< (nnselect-artlist-length thread) 2)
+ (message "No other articles in thread")
+ (setq selection
+ (seq-into
+ (seq-union selection thread
+ (lambda (x y)
+ (and (equal (nnselect-artitem-group x)
+ (nnselect-artitem-group y))
+ (eql (nnselect-artitem-number x)
+ (nnselect-artitem-number y)))))
+ 'vector))
+ (gnus-summary-exit)
+ (gnus-group-read-ephemeral-group
+ (concat "nnselect-" (message-unique-id))
+ (list 'nnselect "nnselect")
+ nil
+ (cons (current-buffer) gnus-current-window-configuration)
+ nil nil
+ (list
+ (cons 'nnselect-specs
+ (list
+ (cons 'nnselect-function 'identity)
+ (cons 'nnselect-args
+ selection)))
+ (cons 'nnselect-artlist nil))
+ (nnselect-artlist-length selection))
+ (if (gnus-id-to-article (mail-header-id header))
+ (gnus-summary-goto-subject
+ (gnus-id-to-article (mail-header-id header)))
+ (message "Thread search failed")))))))
(defun gnus-search-get-active (srv)
(let ((method (gnus-server-to-method srv))
diff --git a/lisp/gnus/gnus-start.el b/lisp/gnus/gnus-start.el
index edab065067f..05ad4303b5c 100644
--- a/lisp/gnus/gnus-start.el
+++ b/lisp/gnus/gnus-start.el
@@ -1490,7 +1490,8 @@ backend check whether the group actually exists."
(gnus-request-update-info
info (inline (gnus-find-method-for-group
(gnus-info-group info)))))
- (gnus-activate-group (gnus-info-group info) nil t))
+ (gnus-activate-group (gnus-info-group info) nil t)
+ (setq active (gnus-active (gnus-info-group info))))
(let* ((range (gnus-info-read info))
(num 0))
@@ -2284,14 +2285,16 @@ If FORCE is non-nil, the .newsrc file is read."
;; doesn't change with each release) and the
;; function that must be applied to convert the
;; previous version into the current version.
- '(("September Gnus v0.1" nil
- gnus-convert-old-ticks)
- ("Oort Gnus v0.08" "legacy-gnus-agent"
- gnus-agent-convert-to-compressed-agentview)
- ("Gnus v5.10.7" "legacy-gnus-agent"
- gnus-agent-unlist-expire-days)
- ("Gnus v5.10.7" "legacy-gnus-agent"
- gnus-agent-unhook-expire-days)))
+ '(;;These all date back to 2004 or earlier!
+ ;; ("September Gnus v0.1" nil
+ ;; gnus-convert-old-ticks)
+ ;; ("Oort Gnus v0.08" "legacy-gnus-agent"
+ ;; gnus-agent-convert-to-compressed-agentview)
+ ;; ("Gnus v5.10.7" "legacy-gnus-agent"
+ ;; gnus-agent-unlist-expire-days)
+ ;; ("Gnus v5.10.7" "legacy-gnus-agent"
+ ;; gnus-agent-unhook-expire-days)
+ ))
#'car-less-than-car)))
;; Skip converters older than the file version
(while (and converters (>= fcv (caar converters)))
diff --git a/lisp/gnus/gnus-sum.el b/lisp/gnus/gnus-sum.el
index 9d5426e28e1..dc66e1375ab 100644
--- a/lisp/gnus/gnus-sum.el
+++ b/lisp/gnus/gnus-sum.el
@@ -80,6 +80,8 @@
(autoload 'nnselect-article-rsv "nnselect" nil nil)
(autoload 'nnselect-article-group "nnselect" nil nil)
(autoload 'gnus-nnselect-group-p "nnselect" nil nil)
+(autoload 'gnus-search-thread "gnus-search" nil nil)
+(autoload 'gnus-search-server-to-engine "gnus-search" nil nil)
(defcustom gnus-kill-summary-on-exit t
"If non-nil, kill the summary buffer when you exit from it.
@@ -141,12 +143,17 @@ If t, fetch all the available old headers."
'gnus-refer-thread-use-search "28.1")
(defcustom gnus-refer-thread-use-search nil
- "Search an entire server when referring threads.
-A nil value will only search for thread-related articles in the
-current group."
+ "Specify where to find articles when referring threads.
+A nil value restricts searches for thread-related articles to the
+current group; a value of t searches all groups on the server; a
+list of servers and groups (where each element is a list whose
+car is the server and whose cdr is a list of groups on this
+server or nil to search the entire server) searches these
+server/groups. This may usefully be set as a group parameter."
:version "28.1"
:group 'gnus-thread
- :type 'boolean)
+ :type '(restricted-sexp :match-alternatives
+ (listp 't 'nil)))
(defcustom gnus-refer-thread-limit-to-thread nil
"If non-nil referring a thread will limit the summary buffer to
@@ -1409,6 +1416,7 @@ the normal Gnus MIME machinery."
(defvar gnus-newsgroup-adaptive-score-file nil)
(defvar gnus-current-score-file nil)
(defvar gnus-current-move-group nil)
+(defvar gnus-current-move-article nil)
(defvar gnus-current-copy-group nil)
(defvar gnus-current-crosspost-group nil)
(defvar gnus-newsgroup-display nil)
@@ -3054,17 +3062,17 @@ the summary mode hooks are run.")
"Major mode for reading articles.
\\<gnus-summary-mode-map>
Each line in this buffer represents one article. To read an
-article, you can, for instance, type `\\[gnus-summary-next-page]'. To move forwards
-and backwards while displaying articles, type `\\[gnus-summary-next-unread-article]' and `\\[gnus-summary-prev-unread-article]',
+article, you can, for instance, type \\[gnus-summary-next-page]. To move forwards
+and backwards while displaying articles, type \\[gnus-summary-next-unread-article] and \\[gnus-summary-prev-unread-article],
respectively.
You can also post articles and send mail from this buffer. To
-follow up an article, type `\\[gnus-summary-followup]'. To mail a reply to the author
-of an article, type `\\[gnus-summary-reply]'.
+follow up an article, type \\[gnus-summary-followup]. To mail a reply to the author
+of an article, type \\[gnus-summary-reply].
There are approximately one gazillion commands you can execute in
this buffer; read the Info manual for more
-information (`\\[gnus-info-find-node]').
+information (\\[gnus-info-find-node]).
The following commands are available:
@@ -8324,39 +8332,29 @@ articles."
(defun gnus-summary-limit-to-age (age &optional younger-p)
"Limit the summary buffer to articles that are older than (or equal) AGE days.
-If YOUNGER-P (the prefix) is non-nil, limit the summary buffer to
-articles that are younger than AGE days."
+Days are counted from midnight to midnight, and now to the
+previous midnight counts as day one. If YOUNGER-P (the prefix)
+is non-nil, limit the summary buffer to articles that are younger
+than AGE days."
(interactive
- (let ((younger current-prefix-arg)
- (days-got nil)
- days)
- (while (not days-got)
- (setq days (if younger
- (read-string "Limit to articles younger than (in days, older when negative): ")
- (read-string
- "Limit to articles older than (in days, younger when negative): ")))
- (when (> (length days) 0)
- (setq days (read days)))
- (if (numberp days)
- (progn
- (setq days-got t)
- (when (< days 0)
- (setq younger (not younger))
- (setq days (* days -1))))
- (message "Please enter a number.")
- (sleep-for 1)))
+ (let* ((younger current-prefix-arg)
+ (days (read-number
+ (if younger "Limit to articles younger than days: "
+ "Limit to articles older than days: "))))
(list days younger))
gnus-summary-mode)
(prog1
- (let ((data gnus-newsgroup-data)
- (cutoff (days-to-time age))
- articles d date is-younger)
+ (let* ((data gnus-newsgroup-data)
+ (now (append '(0 0 0) (cdddr (decode-time))))
+ (delta (make-decoded-time :day (* -1 (- age 1))))
+ (cutoff (encode-time (decoded-time-add now delta)))
+ articles d date is-younger)
(while (setq d (pop data))
(when (and (mail-header-p (gnus-data-header d))
(setq date (mail-header-date (gnus-data-header d))))
(setq is-younger (time-less-p
- (time-since (gnus-date-get-time date))
- cutoff))
+ cutoff
+ (gnus-date-get-time date)))
(when (if younger-p
is-younger
(not is-younger))
@@ -8501,7 +8499,15 @@ If UNREPLIED (the prefix), limit to unreplied articles."
If REVERSE, limit the summary buffer to articles that are marked
with MARKS. MARKS can either be a string of marks or a list of marks.
Returns how many articles were removed."
- (interactive "sMarks: " gnus-summary-mode)
+ (interactive
+ (list
+ (completing-read "Marks:"
+ (let ((mark-list '()))
+ (mapc (lambda (datum)
+ (cl-pushnew (gnus-data-mark datum) mark-list))
+ gnus-newsgroup-data)
+ (mapcar 'char-to-string mark-list)))
+ current-prefix-arg) gnus-summary-mode)
(gnus-summary-limit-to-marks marks t))
(defun gnus-summary-limit-to-marks (marks &optional reverse)
@@ -8510,7 +8516,15 @@ If REVERSE (the prefix), limit the summary buffer to articles that are
not marked with MARKS. MARKS can either be a string of marks or a
list of marks.
Returns how many articles were removed."
- (interactive "sMarks: \nP" gnus-summary-mode)
+ (interactive
+ (list
+ (completing-read "Marks:"
+ (let ((mark-list '()))
+ (mapc (lambda (datum)
+ (cl-pushnew (gnus-data-mark datum) mark-list))
+ gnus-newsgroup-data)
+ (mapcar 'char-to-string mark-list)))
+ current-prefix-arg) gnus-summary-mode)
(prog1
(let ((data gnus-newsgroup-data)
(marks (if (listp marks) marks
@@ -8993,65 +9007,73 @@ Return the number of articles fetched."
(defun gnus-summary-refer-thread (&optional limit)
"Fetch all articles in the current thread.
-For backends that know how to search for threads (currently only
-`nnimap') a non-numeric prefix arg will search the entire server;
-without a prefix arg only the current group is searched. If the
-variable `gnus-refer-thread-use-search' is non-nil the prefix arg
-has the reverse meaning. If no backend-specific `request-thread'
-function is available fetch LIMIT (the numerical prefix) old
-headers. If LIMIT is non-numeric or nil fetch the number
-specified by the `gnus-refer-thread-limit' variable."
+A non-numeric prefix arg will search the entire server; without a
+prefix arg only the current group is searched. If the variable
+`gnus-refer-thread-use-search' is t the prefix arg has the
+reverse meaning. If searching is not enabled for the current
+group, fetch LIMIT (the numerical prefix) old headers. If LIMIT
+is non-numeric or nil fetch the number specified by the
+`gnus-refer-thread-limit' variable."
(interactive "P" gnus-summary-mode)
- (let* ((header (gnus-summary-article-header))
- (id (mail-header-id header))
- (gnus-inhibit-demon t)
- (gnus-summary-ignore-duplicates t)
- (gnus-read-all-available-headers t)
- (gnus-refer-thread-use-search
- (if (and (not (null limit)) (listp limit))
- (not gnus-refer-thread-use-search) gnus-refer-thread-use-search))
- (new-headers
- (if (gnus-check-backend-function
- 'request-thread gnus-newsgroup-name)
- (gnus-request-thread header gnus-newsgroup-name)
- (let* ((limit (if (numberp limit) (prefix-numeric-value limit)
- gnus-refer-thread-limit))
- (last (if (numberp limit)
- (min (+ (mail-header-number header)
- limit)
- gnus-newsgroup-highest)
- gnus-newsgroup-highest))
- (subject (gnus-simplify-subject
- (mail-header-subject header)))
- (refs (split-string (or (mail-header-references header)
- "")))
- (gnus-parse-headers-hook
+ (let* ((group gnus-newsgroup-name)
+ (header (gnus-summary-article-header))
+ (id (mail-header-id header))
+ (gnus-inhibit-demon t)
+ (gnus-summary-ignore-duplicates t)
+ (gnus-refer-thread-use-search
+ (if (or (null limit) (numberp limit))
+ gnus-refer-thread-use-search
+ (if (booleanp gnus-refer-thread-use-search)
+ (not gnus-refer-thread-use-search)
+ gnus-refer-thread-use-search)))
+ article-ids new-unreads
+ (new-headers
+ (cond
+ ;; If there is a backend-specific method, use it.
+ ((gnus-check-backend-function
+ 'request-thread group)
+ (gnus-request-thread header group))
+ ;; If a search engine is configured, use it.
+ ((ignore-errors
+ (gnus-search-server-to-engine (gnus-group-server group)))
+ (gnus-search-thread header))
+ ;; Otherwise just retrieve some headers.
+ (t
+ (let* ((gnus-read-all-available-headers t)
+ (limit (if (numberp limit)
+ limit
+ gnus-refer-thread-limit))
+ (last (if (numberp limit)
+ (min (+ (mail-header-number header) limit)
+ gnus-newsgroup-highest)
+ gnus-newsgroup-highest))
+ (subject (gnus-simplify-subject
+ (mail-header-subject header)))
+ (refs (split-string
+ (or (mail-header-references header) "")))
+ (gnus-parse-headers-hook
(let ((refs (append refs (list id subject))))
- (lambda ()
- (goto-char (point-min))
- (keep-lines (regexp-opt refs))))))
- (gnus-fetch-headers (list last) (if (numberp limit)
- (* 2 limit) limit)
- t))))
- article-ids new-unreads)
+ (lambda () (goto-char (point-min))
+ (keep-lines (regexp-opt refs))))))
+ (gnus-fetch-headers
+ (list last) (if (numberp limit) (* 2 limit) limit) t))))))
(when (listp new-headers)
(dolist (header new-headers)
- (push (mail-header-number header) article-ids))
+ (push (mail-header-number header) article-ids))
(setq article-ids (nreverse article-ids))
(setq new-unreads
- (gnus-sorted-intersection gnus-newsgroup-unselected article-ids))
+ (gnus-sorted-intersection gnus-newsgroup-unselected article-ids))
(setq gnus-newsgroup-unselected
- (gnus-sorted-ndifference gnus-newsgroup-unselected new-unreads))
+ (gnus-sorted-ndifference gnus-newsgroup-unselected new-unreads))
(setq gnus-newsgroup-unreads
- (gnus-sorted-nunion gnus-newsgroup-unreads new-unreads))
+ (gnus-sorted-nunion gnus-newsgroup-unreads new-unreads))
(setq gnus-newsgroup-headers
(gnus-delete-duplicate-headers
- (cl-merge
- 'list gnus-newsgroup-headers new-headers
- 'gnus-article-sort-by-number)))
+ (cl-merge 'list gnus-newsgroup-headers new-headers
+ 'gnus-article-sort-by-number)))
(setq gnus-newsgroup-articles
- (gnus-sorted-nunion gnus-newsgroup-articles article-ids))
- (gnus-summary-limit-include-thread id gnus-refer-thread-limit-to-thread)))
+ (gnus-sorted-nunion gnus-newsgroup-articles article-ids)))
+ (gnus-summary-limit-include-thread id gnus-refer-thread-limit-to-thread))
(gnus-summary-show-thread))
(defun gnus-summary-open-group-with-article (message-id)
@@ -10249,6 +10271,7 @@ ACTION can be either `move' (the default), `crosspost' or `copy'."
article gnus-newsgroup-name (current-buffer) t)))
;; run the move/copy/crosspost/respool hook
+ (setq gnus-current-move-article (cdr art-group))
(run-hook-with-args 'gnus-summary-article-move-hook
action
(gnus-data-header (gnus-data-find article))
diff --git a/lisp/gnus/gnus-util.el b/lisp/gnus/gnus-util.el
index 65e3d8d28c6..0b0a9bbfc1d 100644
--- a/lisp/gnus/gnus-util.el
+++ b/lisp/gnus/gnus-util.el
@@ -343,10 +343,10 @@ Symbols are also allowed; their print names are used instead."
(yes-or-no-p prompt)
(message "")))
-;; By Frank Schmitt <ich@Frank-Schmitt.net>. Allows to have
-;; age-depending date representations. (e.g. just the time if it's
-;; from today, the day of the week if it's within the last 7 days and
-;; the full date if it's older)
+;; By Frank Schmitt <ich@Frank-Schmitt.net>. Enables age-dependent
+;; date representations. (e.g. just the time if it's from today, the
+;; day of the week if it's within the last 7 days and the full date if
+;; it's older)
(defun gnus-seconds-today ()
"Return the integer number of seconds passed today."
@@ -1113,8 +1113,7 @@ sure of changing the value of `foo'."
(setq gnus-info-buffer (current-buffer))
(gnus-configure-windows 'info)))
-(defun gnus-not-ignore (&rest _args)
- t)
+(defalias 'gnus-not-ignore #'always)
(defvar gnus-directory-sep-char-regexp "/"
"The regexp of directory separator character.
diff --git a/lisp/gnus/gnus-uu.el b/lisp/gnus/gnus-uu.el
index b3236995289..95236a167fc 100644
--- a/lisp/gnus/gnus-uu.el
+++ b/lisp/gnus/gnus-uu.el
@@ -1371,8 +1371,7 @@ When called interactively, prompt for REGEXP."
;; Allow user-defined functions to be run on this file.
(when gnus-uu-grabbed-file-functions
(let ((funcs gnus-uu-grabbed-file-functions))
- (unless (listp funcs)
- (setq funcs (list funcs)))
+ (setq funcs (ensure-list funcs))
(while funcs
(funcall (pop funcs) result-file))))
(setq result-file nil)
diff --git a/lisp/gnus/gnus.el b/lisp/gnus/gnus.el
index 5ab6b2978ff..dab66b60205 100644
--- a/lisp/gnus/gnus.el
+++ b/lisp/gnus/gnus.el
@@ -309,30 +309,47 @@ be set in `.emacs' instead."
:group 'gnus-start
:type 'boolean)
+(defcustom gnus-mode-line-logo
+ '((:type svg :file "gnus-pointer.svg" :ascent center)
+ (:type xpm :file "gnus-pointer.xpm" :ascent center)
+ (:type xbm :file "gnus-pointer.xbm" :ascent center))
+ "Image spec for the Gnus logo to be displayed in mode-line.
+
+If non-nil, it should be a list of image specifications to be passed
+as the first argument to `find-image', which see. Then, if the display
+is capable of showing images, the Gnus logo will be displayed as part of
+the buffer-identification in the mode-line of Gnus-buffers.
+
+If nil, there will be no Gnus logo in the mode-line."
+ :group 'gnus-visual
+ :type '(choice
+ (repeat :tag "List of Gnus logo image specifications" (plist))
+ (const :tag "Don't display Gnus logo" nil))
+ :version "30.1")
+
(defun gnus-mode-line-buffer-identification (line)
(let* ((str (car-safe line))
(str (if (stringp str)
(car (propertized-buffer-identification str))
str)))
- (if (or (not (fboundp 'find-image))
+ (if (or (not gnus-mode-line-logo)
+ (not (fboundp 'find-image))
(not (display-graphic-p))
(not (stringp str))
(not (string-match "^Gnus:" str)))
(list str)
- (let ((load-path (append (mm-image-load-path) load-path)))
+ (let ((load-path (append (mm-image-load-path) load-path))
+ (gnus-emacs-version (gnus-emacs-version)))
;; Add the Gnus logo.
(add-text-properties
0 5
(list 'display
- (find-image
- '((:type xpm :file "gnus-pointer.xpm"
- :ascent center)
- (:type xbm :file "gnus-pointer.xbm"
- :ascent center))
- t)
- 'help-echo (format
- "This is %s, %s."
- gnus-version (gnus-emacs-version)))
+ (find-image gnus-mode-line-logo t)
+ 'help-echo (if gnus-emacs-version
+ (format
+ "This is %s, %s."
+ gnus-version gnus-emacs-version)
+ (format "This is %s." gnus-version)))
str)
(list str)))))
@@ -2445,6 +2462,7 @@ are always t.")
;; Save window configuration.
(defvar gnus-prev-winconf nil)
+(defvar gnus-prev-cwc nil)
(defvar gnus-reffed-article-number nil)
diff --git a/lisp/gnus/legacy-gnus-agent.el b/lisp/gnus/legacy-gnus-agent.el
deleted file mode 100644
index d4f08c72de8..00000000000
--- a/lisp/gnus/legacy-gnus-agent.el
+++ /dev/null
@@ -1,260 +0,0 @@
-;;; legacy-gnus-agent.el --- Legacy unplugged support for Gnus -*- lexical-binding: t; -*-
-
-;; Copyright (C) 2004-2024 Free Software Foundation, Inc.
-
-;; Author: Kevin Greiner <kgreiner@xpediantsolutions.com>
-;; Keywords: news
-
-;; This file is part of GNU Emacs.
-
-;; GNU Emacs is free software: you can redistribute it and/or modify
-;; it under the terms of the GNU General Public License as published by
-;; the Free Software Foundation, either version 3 of the License, or
-;; (at your option) any later version.
-
-;; GNU Emacs is distributed in the hope that it will be useful,
-;; but WITHOUT ANY WARRANTY; without even the implied warranty of
-;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-;; GNU General Public License for more details.
-
-;; You should have received a copy of the GNU General Public License
-;; along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>.
-
-;;; Commentary:
-
-;; Conversion functions for the Agent.
-
-;;; Code:
-(require 'gnus-start)
-(require 'gnus-util)
-(require 'gnus-range)
-(require 'gnus-agent)
-
-;; Oort Gnus v0.08 - This release updated agent to no longer use
-;; history file and to support a compressed alist.
-
-(defvar gnus-agent-compressed-agentview-search-only nil)
-
-(defun gnus-agent-convert-to-compressed-agentview (converting-to)
- "Iterates over all agentview files to ensure that they have been
-converted to the compressed format."
-
- (let ((search-in (list gnus-agent-directory))
- here
- members
- member
- converted-something)
- (while (setq here (pop search-in))
- (setq members (directory-files here t))
- (while (setq member (pop members))
- (cond ((string-match "/\\.\\.?$" member)
- nil)
- ((file-directory-p member)
- (push member search-in))
- ((equal (file-name-nondirectory member) ".agentview")
- (setq converted-something
- (or (gnus-agent-convert-agentview member)
- converted-something))))))
-
- (if converted-something
- (gnus-message 4 "Successfully converted Gnus %s offline (agent) files to %s" gnus-newsrc-file-version converting-to))))
-
-(defun gnus-agent-convert-to-compressed-agentview-prompt ()
- (catch 'found-file-to-convert
- (let ((gnus-agent-compressed-agentview-search-only t))
- (gnus-agent-convert-to-compressed-agentview nil))))
-
-(gnus-convert-mark-converter-prompt 'gnus-agent-convert-to-compressed-agentview 'gnus-agent-convert-to-compressed-agentview-prompt)
-
-(defun gnus-agent-convert-agentview (file)
- "Load FILE and do a `read' there."
- (with-temp-buffer
- (nnheader-insert-file-contents file)
- (goto-char (point-min))
- (let ((inhibit-quit t)
- (alist (read (current-buffer)))
- (version (condition-case nil (read (current-buffer))
- (end-of-file 0)))
- changed-version
- history-file)
-
- (cond
- ((= version 0)
- (let (entry
- (gnus-command-method nil))
- (mm-disable-multibyte) ;; everything is binary
- (erase-buffer)
- (insert "\n")
- (let ((file (concat (file-name-directory file) "/history")))
- (when (file-exists-p file)
- (nnheader-insert-file-contents file)
- (setq history-file file)))
-
- (goto-char (point-min))
- (while (not (eobp))
- (if (and (looking-at
- "[^\t\n]+\t\\([0-9]+\\)\t\\([^ \n]+\\) \\([0-9]+\\)")
- (string= (gnus-agent-article-name ".agentview" (match-string 2))
- file)
- (setq entry (assoc (string-to-number (match-string 3)) alist)))
- (setcdr entry (string-to-number (match-string 1))))
- (forward-line 1))
- (setq changed-version t)))
- ((= version 1)
- (setq changed-version t)))
-
- (when changed-version
- (when gnus-agent-compressed-agentview-search-only
- (throw 'found-file-to-convert t))
-
- (erase-buffer)
- (let (article-id day-of-download comp-list compressed)
- (while alist
- (setq article-id (caar alist)
- day-of-download (cdar alist)
- comp-list (assq day-of-download compressed)
- alist (cdr alist))
- (if comp-list
- (setcdr comp-list (cons article-id (cdr comp-list)))
- (push (list day-of-download article-id) compressed)))
- (setq alist compressed)
- (while alist
- (setq comp-list (pop alist))
- (setcdr comp-list
- (gnus-compress-sequence (nreverse (cdr comp-list)))))
- (princ compressed (current-buffer)))
- (insert "\n2\n")
- (write-file file)
- (when history-file
- (delete-file history-file))
- t))))
-
-;; End of Oort Gnus v0.08 updates
-
-;; No Gnus v0.3 - This release provides a mechanism for upgrading gnus
-;; from previous versions. Therefore, the previous
-;; hacks to handle a gnus-agent-expire-days that
-;; specifies a list of values can be removed.
-
-(defun gnus-agent-unlist-expire-days (converting-to)
- (when (listp gnus-agent-expire-days)
- (let (buffer)
- (unwind-protect
- (save-window-excursion
- (setq buffer (gnus-get-buffer-create " *Gnus agent upgrade*"))
- (set-buffer buffer)
- (erase-buffer)
- (insert "The definition of gnus-agent-expire-days has been changed.\nYou currently have it set to the list:\n ")
- (gnus-pp gnus-agent-expire-days)
-
- (insert
- (format-message
- "\nIn order to use version `%s' of gnus, you will need to set\n"
- converting-to))
- (insert "gnus-agent-expire-days to an integer. If you still wish to set different\n")
- (insert "expiration days to individual groups, you must instead set the\n")
- (insert (format-message
- "`agent-days-until-old' group and/or topic parameter.\n"))
- (insert "\n")
- (insert "If you would like, gnus can iterate over every group comparing its name to the\n")
- (insert "regular expressions that you currently have in gnus-agent-expire-days. When\n")
- (insert (format-message
- "gnus finds a match, it will update that group's `agent-days-until-old' group\n"))
- (insert "parameter to the value associated with the regular expression.\n")
- (insert "\n")
- (insert "Whether gnus assigns group parameters, or not, gnus will terminate with an\n")
- (insert "ERROR as soon as this function completes. The reason is that you must\n")
- (insert "manually edit your configuration to either not set gnus-agent-expire-days or\n")
- (insert "to set it to an integer before gnus can be used.\n")
- (insert "\n")
- (insert "Once you have successfully edited gnus-agent-expire-days, gnus will be able to\n")
- (insert "execute past this function.\n")
- (insert "\n")
- (insert "Should gnus use gnus-agent-expire-days to assign\n")
- (insert "agent-days-until-old parameters to individual groups? (Y/N)")
-
- (switch-to-buffer buffer)
- (beep)
- (beep)
-
- (let ((echo-keystrokes 0)
- c)
- (while (progn (setq c (read-char-exclusive))
- (cond ((or (eq c ?y) (eq c ?Y))
- (save-excursion
- (let ((groups (gnus-group-listed-groups)))
- (while groups
- (let* ((group (pop groups))
- (days gnus-agent-expire-days)
- (day (catch 'found
- (while days
- (when (eq 0 (string-match
- (caar days)
- group))
- (throw 'found (cadr (car days))))
- (setq days (cdr days)))
- nil)))
- (when day
- (gnus-group-set-parameter group 'agent-days-until-old
- day))))))
- nil
- )
- ((or (eq c ?n) (eq c ?N))
- nil)
- (t
- t))))))
- (kill-buffer buffer))
- (error "Change gnus-agent-expire-days to an integer for gnus to start"))))
-
-;; The gnus-agent-unlist-expire-days has its own conversion prompt.
-;; Therefore, hide the default prompt.
-(gnus-convert-mark-converter-prompt 'gnus-agent-unlist-expire-days t)
-
-(defun gnus-agent-unhook-expire-days (_converting-to)
- "Remove every lambda from `gnus-group-prepare-hook' that mention the
-symbol `gnus-agent-do-once' in their definition. This should NOT be
-necessary as gnus-agent.el no longer adds them. However, it is
-possible that the hook was persistently saved."
- (let ((h t)) ; Iterate from bgn of hook.
- (while h
- (let ((func (progn (when (eq h t)
- ;; Init h to list of functions.
- (setq h (cond ((listp gnus-group-prepare-hook)
- gnus-group-prepare-hook)
- ((boundp 'gnus-group-prepare-hook)
- (list gnus-group-prepare-hook)))))
- (pop h))))
-
- (when (cond ((byte-code-function-p func)
- ;; Search def. of compiled function for
- ;; gnus-agent-do-once string.
- (let* (definition
- print-level
- print-length
- (standard-output
- (lambda (char)
- (setq definition (cons char definition)))))
- (princ func) ; Populates definition with reversed list
- ; of characters.
- (let* ((i (length definition))
- (s (make-string i 0)))
- (while definition
- (aset s (setq i (1- i)) (pop definition)))
-
- (string-match "\\bgnus-agent-do-once\\b" s))))
- ((listp func)
- (eq (cadr (nth 2 func)) 'gnus-agent-do-once) ; Handles eval'd lambda.
- ))
-
- (remove-hook 'gnus-group-prepare-hook func)
- ;; I don't what remove-hook is going to actually do to the
- ;; hook list so start over from the beginning.
- (setq h t))))))
-
-;; gnus-agent-unhook-expire-days is safe in that it does not modify
-;; the .newsrc.eld file.
-(gnus-convert-mark-converter-prompt 'gnus-agent-unhook-expire-days t)
-
-(provide 'legacy-gnus-agent)
-
-;;; legacy-gnus-agent.el ends here
diff --git a/lisp/gnus/mail-source.el b/lisp/gnus/mail-source.el
index cf39c246fca..fdafc29f7e8 100644
--- a/lisp/gnus/mail-source.el
+++ b/lisp/gnus/mail-source.el
@@ -285,7 +285,7 @@ number."
"Number of idle seconds to wait before checking for new mail."
:type 'number)
-(defcustom mail-source-movemail-program "movemail"
+(defcustom mail-source-movemail-program movemail-program-name
"If non-nil, name of program for fetching new mail."
:version "26.2"
:type '(choice (const nil) string))
@@ -658,50 +658,49 @@ Deleting old (> %s day(s)) incoming mail file `%s'." diff bfile)
;; If getting from mail spool directory, use movemail to move
;; rather than just renaming, so as to interlock with the
;; mailer.
- (unwind-protect
- (save-excursion
- (setq errors (generate-new-buffer " *mail source loss*"))
- (let ((default-directory "/"))
- (setq result
- ;; call-process looks in exec-path, which
- ;; contains exec-directory, so will find
- ;; Mailutils movemail if it exists, else it will
- ;; find "our" movemail in exec-directory.
- ;; Bug#31737
- (apply
- #'call-process
- (append
- (list
- mail-source-movemail-program
- nil errors nil from to)))))
- (when (file-exists-p to)
- (set-file-modes to mail-source-default-file-modes 'nofollow))
- (if (and (or (not (buffer-modified-p errors))
- (zerop (buffer-size errors)))
- (and (numberp result)
- (zerop result)))
- ;; No output => movemail won.
- t
- (set-buffer errors)
- ;; There may be a warning about older revisions. We
- ;; ignore that.
- (goto-char (point-min))
- (if (search-forward "older revision" nil t)
- t
- ;; Probably a real error.
- (subst-char-in-region (point-min) (point-max) ?\n ?\ )
- (goto-char (point-max))
- (skip-chars-backward " \t")
- (delete-region (point) (point-max))
- (goto-char (point-min))
- (when (looking-at "movemail: ")
- (delete-region (point-min) (match-end 0)))
- ;; Result may be a signal description string.
- (unless (yes-or-no-p
- (format "movemail: %s (%s return). Continue? "
- (buffer-string) result))
- (error "%s" (buffer-string)))
- (setq to nil)))))))
+ (save-excursion
+ (setq errors (generate-new-buffer " *mail source loss*"))
+ (let ((default-directory "/"))
+ (setq result
+ ;; call-process looks in exec-path, which
+ ;; contains exec-directory, so will find
+ ;; Mailutils movemail if it exists, else it will
+ ;; find "our" movemail in exec-directory.
+ ;; Bug#31737
+ (apply
+ #'call-process
+ (append
+ (list
+ mail-source-movemail-program
+ nil errors nil from to)))))
+ (when (file-exists-p to)
+ (set-file-modes to mail-source-default-file-modes 'nofollow))
+ (if (and (or (not (buffer-modified-p errors))
+ (zerop (buffer-size errors)))
+ (and (numberp result)
+ (zerop result)))
+ ;; No output => movemail won.
+ t
+ (set-buffer errors)
+ ;; There may be a warning about older revisions. We
+ ;; ignore that.
+ (goto-char (point-min))
+ (if (search-forward "older revision" nil t)
+ t
+ ;; Probably a real error.
+ (subst-char-in-region (point-min) (point-max) ?\n ?\ )
+ (goto-char (point-max))
+ (skip-chars-backward " \t")
+ (delete-region (point) (point-max))
+ (goto-char (point-min))
+ (when (looking-at "movemail: ")
+ (delete-region (point-min) (match-end 0)))
+ ;; Result may be a signal description string.
+ (unless (yes-or-no-p
+ (format "movemail: %s (%s return). Continue? "
+ (buffer-string) result))
+ (error "%s" (buffer-string)))
+ (setq to nil))))))
(when (buffer-live-p errors)
(kill-buffer errors))
;; Return whether we moved successfully or not.
diff --git a/lisp/gnus/message.el b/lisp/gnus/message.el
index 69f025f48ed..979d2fecf56 100644
--- a/lisp/gnus/message.el
+++ b/lisp/gnus/message.el
@@ -154,7 +154,7 @@ If this variable is nil, no such courtesy message will be added."
:type '(radio string (const nil)))
(defcustom message-ignored-bounced-headers
- "^\\(Received\\|Return-Path\\|Delivered-To\\):"
+ "^\\(Received\\|Return-Path\\|Delivered-To\\|DKIM-Signature\\|X-Hashcash\\):"
"Regexp that matches headers to be removed in resent bounced mail."
:group 'message-interface
:type 'regexp)
@@ -747,16 +747,14 @@ default is system dependent and determined by the function
`message-send-mail-function'.
See also `send-mail-function'."
- :type '(radio (function-item message--default-send-mail-function
- :tag "Use send-mail-function")
+ :type '(radio (function-item message--default-send-mail-function)
(function-item message-send-mail-with-sendmail)
(function-item message-send-mail-with-mh)
(function-item message-send-mail-with-qmail)
(function-item message-smtpmail-send-it)
- (function-item smtpmail-send-it)
+ (function-item :doc "Use SMTPmail package." smtpmail-send-it)
(function-item feedmail-send-it)
- (function-item message-send-mail-with-mailclient
- :tag "Use Mailclient package")
+ (function-item message-send-mail-with-mailclient)
(function :tag "Other"))
:group 'message-sending
:version "27.1"
@@ -2847,11 +2845,11 @@ will not be inserted."
(const :tag "No ID" nil))
(choice (string :tag "Key")
(const :tag "No Key" nil))
- (choice (other :tag "None" nil)
- (const :tag "Unprotected" "unprotected")
+ (choice (const :tag "Unprotected" "unprotected")
(const :tag "Sign" "sign")
(const :tag "Encrypt" "encrypt")
- (const :tag "Sign and Encrypt" "signencrypt"))))
+ (const :tag "Sign and Encrypt" "signencrypt")
+ (other :tag "None" nil))))
:version "28.1")
(defun message-add-openpgp-header ()
@@ -5018,30 +5016,34 @@ Each line should be no more than 79 characters long."
"Send the current buffer to `message-send-mail-function'.
Or, if there's a header that specifies a different method, use
that instead."
- (let ((method (message-field-value "X-Message-SMTP-Method")))
+ (let ((method (message-field-value "X-Message-SMTP-Method"))
+ send-function)
(if (not method)
- (funcall message-send-mail-function)
+ (funcall message-send-mail-function)
(message-remove-header "X-Message-SMTP-Method")
(setq method (split-string method))
+ (setq send-function
+ (symbol-function
+ (intern-soft (format "message-send-mail-with-%s" (car method)))))
(cond
- ((equal (car method) "sendmail")
- (message-send-mail-with-sendmail))
((equal (car method) "smtp")
- (require 'smtpmail)
- (let* ((smtpmail-store-queue-variables t)
+ (require 'smtpmail)
+ (let* ((smtpmail-store-queue-variables t)
(smtpmail-smtp-server (nth 1 method))
- (service (nth 2 method))
- (port (string-to-number service))
- ;; If we're talking to the TLS SMTP port, then force a
- ;; TLS connection.
- (smtpmail-stream-type (if (= port 465)
- 'tls
- smtpmail-stream-type))
- (smtpmail-smtp-service (if (> port 0) port service))
- (smtpmail-smtp-user (or (nth 3 method) smtpmail-smtp-user)))
- (message-smtpmail-send-it)))
+ (service (nth 2 method))
+ (port (string-to-number service))
+ ;; If we're talking to the TLS SMTP port, then force a
+ ;; TLS connection.
+ (smtpmail-stream-type (if (= port 465)
+ 'tls
+ smtpmail-stream-type))
+ (smtpmail-smtp-service (if (> port 0) port service))
+ (smtpmail-smtp-user (or (nth 3 method) smtpmail-smtp-user)))
+ (message-smtpmail-send-it)))
+ (send-function
+ (funcall send-function))
(t
- (error "Unknown method %s" method))))))
+ (error "Unknown mail method %s" method))))))
(defun message-send-mail-with-sendmail ()
"Send off the prepared buffer with sendmail."
@@ -6598,8 +6600,8 @@ they are."
(widen)
(forward-line 1)
(unless (looking-at "$")
- (forward-line 2)))
- (sit-for 0)))
+ (forward-line 2))))
+ (sit-for 0))
(defcustom message-beginning-of-line t
"Whether \\<message-mode-map>\\[message-beginning-of-line]\
@@ -6873,10 +6875,9 @@ are not included."
(defun message-setup-1 (headers &optional yank-action actions return-action)
(dolist (action actions)
- (condition-case nil
- ;; FIXME: Use functions rather than expressions!
- (add-to-list 'message-send-actions
- `(apply #',(car action) ',(cdr action)))))
+ ;; FIXME: Use functions rather than expressions!
+ (add-to-list 'message-send-actions
+ `(apply #',(car action) ',(cdr action))))
(setq message-return-action return-action)
(setq message-reply-buffer
(if (and (consp yank-action)
@@ -7713,10 +7714,7 @@ the message."
""))
(when message-wash-forwarded-subjects
(setq subject (message-wash-subject subject)))
- ;; Make sure funcs is a list.
- (and funcs
- (not (listp funcs))
- (setq funcs (list funcs)))
+ (setq funcs (ensure-list funcs))
;; Apply funcs in order, passing subject generated by previous
;; func to the next one.
(dolist (func funcs)
@@ -8217,7 +8215,6 @@ which specify the range to operate on."
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"
@@ -8981,32 +8978,61 @@ used to take the screenshot."
retval))
;;;###autoload
-(defun message-mailto (&optional url)
+(defun message-mailto (&optional url subject body file-attachments)
"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\")'
+
+To facilitate the use of this function within window systems that
+provide message subject, body and attachments independent of URL
+itself, the arguments SUBJECT, BODY and FILE-ATTACHMENTS may also
+provide alternative message subject and body text, which is
+inserted in lieu of nothing if URL does not incorporate such
+information itself, and a list of files to insert as attachments
+to the E-mail."
(interactive)
;; <a href="mailto:someone@example.com?subject=This%20is%20the%20subject&cc=someone_else@example.com&body=This%20is%20the%20body">Send email</a>
(message-mail)
- (message-mailto-1 (or url (pop command-line-args-left))))
+ (message-mailto-1 (or url (pop command-line-args-left))
+ subject body file-attachments))
-(defun message-mailto-1 (url)
- (let ((args (message-parse-mailto-url url)))
+(defun message-mailto-1 (url &optional subject body file-attachments)
+ (let ((args (message-parse-mailto-url url))
+ (need-body nil) (need-subject nil))
(dolist (arg args)
(unless (equal (car arg) "body")
(message-position-on-field (capitalize (car arg)))
(insert (string-replace
"\r\n" "\n"
(mapconcat #'identity (reverse (cdr arg)) ", ")))))
- (when (assoc "body" args)
- (message-goto-body)
- (dolist (body (cdr (assoc "body" args)))
- (insert body "\n")))
+ (if (assoc "body" args)
+ (progn
+ (message-goto-body)
+ (dolist (body (cdr (assoc "body" args)))
+ (insert body "\n")))
+
+ (setq need-body t))
(if (assoc "subject" args)
(message-goto-body)
- (message-goto-subject))))
+ (setq need-subject t)
+ (message-goto-subject))
+ ;; If either one of need-subject and need-body is non-nil then
+ ;; attempt to insert the absent information from an external
+ ;; SUBJECT or BODY.
+ (when (or need-body need-subject)
+ (when (and need-body body)
+ (message-goto-body)
+ (insert body))
+ (when (and need-subject subject)
+ (message-goto-subject)
+ (insert subject)
+ (message-goto-body)))
+ ;; Subsequently insert each attachment enumerated within
+ ;; FILE-ATTACHMENTS.
+ (dolist (file file-attachments)
+ (mml-attach-file file nil 'attachment))))
(provide 'message)
diff --git a/lisp/gnus/mm-decode.el b/lisp/gnus/mm-decode.el
index c8f610f0537..f91755e967b 100644
--- a/lisp/gnus/mm-decode.el
+++ b/lisp/gnus/mm-decode.el
@@ -119,7 +119,7 @@
((executable-find "links") 'links)
((executable-find "lynx") 'lynx)
(t 'shr))
- "Render of HTML contents.
+ "Renderer of HTML contents.
It is one of defined renderer types, or a rendering function.
The defined renderer types are:
`shr': use the built-in Gnus HTML renderer;
@@ -131,8 +131,8 @@ The defined renderer types are:
:version "29.1"
:type '(choice (const shr)
(const gnus-w3m)
- (const w3m :tag "emacs-w3m")
- (const w3m-standalone :tag "standalone w3m" )
+ (const :tag "emacs-w3m" w3m)
+ (const :tag "standalone w3m" w3m-standalone)
(const links)
(const lynx)
(function))
diff --git a/lisp/gnus/mm-view.el b/lisp/gnus/mm-view.el
index 5f234e5c006..109b6c17c2c 100644
--- a/lisp/gnus/mm-view.el
+++ b/lisp/gnus/mm-view.el
@@ -487,8 +487,6 @@ after inserting the part."
(let ((inhibit-read-only t))
(delete-region beg end)))))))))
-;; Shut up byte-compiler.
-(defvar font-lock-mode-hook)
(defun mm-display-inline-fontify (handle &optional mode)
"Insert HANDLE inline fontifying with MODE.
If MODE is not set, try to find mode automatically."
diff --git a/lisp/gnus/mml.el b/lisp/gnus/mml.el
index 84f895e7e8f..edb3c286242 100644
--- a/lisp/gnus/mml.el
+++ b/lisp/gnus/mml.el
@@ -1369,9 +1369,9 @@ If not set, `default-directory' will be used."
;;; Attachment functions.
(defcustom mml-dnd-protocol-alist
- '(("^file:///" . mml-dnd-attach-file)
- ("^file://" . dnd-open-file)
- ("^file:" . mml-dnd-attach-file))
+ '(("^file:///" . mml-dnd-attach-file) ; GNOME, KDE, and suchlike.
+ ("^file:/[^/]" . mml-dnd-attach-file) ; Motif, other systems.
+ ("^file:[^/]" . mml-dnd-attach-file)) ; MS-Windows.
"The functions to call when a drop in `mml-mode' is made.
See `dnd-protocol-alist' for more information. When nil, behave
as in other buffers."
@@ -1460,34 +1460,43 @@ will be computed and used."
(file-name-nondirectory file)))
(goto-char at-end))))
-(defun mml-dnd-attach-file (uri _action)
- "Attach a drag and drop file.
-
-Ask for type, description or disposition according to
-`mml-dnd-attach-options'."
- (let ((file (dnd-get-local-file-name uri t)))
- (when (and file (file-regular-p file))
- (let ((mml-dnd-attach-options mml-dnd-attach-options)
- type description disposition)
- (setq mml-dnd-attach-options
- (when (and (eq mml-dnd-attach-options t)
- (not
- (y-or-n-p
- "Use default type, disposition and description? ")))
- '(type description disposition)))
- (when (or (memq 'type mml-dnd-attach-options)
- (memq 'disposition mml-dnd-attach-options))
- (setq type (mml-minibuffer-read-type file)))
- (when (memq 'description mml-dnd-attach-options)
- (setq description (mml-minibuffer-read-description)))
- (when (memq 'disposition mml-dnd-attach-options)
- (setq disposition (mml-minibuffer-read-disposition type nil file)))
- (mml-attach-file file type description disposition)))))
-
-(defun mml-attach-buffer (buffer &optional type description disposition)
+(defun mml-dnd-attach-file (uris _action)
+ "Attach a drag and drop URIS, a list of local file URIs.
+
+Query whether to use the types, dispositions and descriptions
+default for each URL, subject to `mml-dnd-attach-options'.
+
+Return the action `private', communicating to the drop source
+that the file has been attached."
+ (let (file (mml-dnd-attach-options mml-dnd-attach-options))
+ (setq mml-dnd-attach-options
+ (when (and (eq mml-dnd-attach-options t)
+ (not
+ (y-or-n-p
+ "Use default type, disposition and description? ")))
+ '(type description disposition)))
+ (dolist (uri uris)
+ (setq file (dnd-get-local-file-name uri t))
+ (when (and file (file-regular-p file))
+ (let (type description disposition)
+ (when (or (memq 'type mml-dnd-attach-options)
+ (memq 'disposition mml-dnd-attach-options))
+ (setq type (mml-minibuffer-read-type file)))
+ (when (memq 'description mml-dnd-attach-options)
+ (setq description (mml-minibuffer-read-description)))
+ (when (memq 'disposition mml-dnd-attach-options)
+ (setq disposition (mml-minibuffer-read-disposition type nil file)))
+ (mml-attach-file file type description disposition)))))
+ 'private)
+
+(put 'mml-dnd-attach-file 'dnd-multiple-handler t)
+
+(defun mml-attach-buffer (buffer &optional type description disposition filename)
"Attach a buffer to the outgoing MIME message.
BUFFER is the name of the buffer to attach. See
-`mml-attach-file' for details of operation."
+`mml-attach-file' regarding TYPE, DESCRIPTION and DISPOSITION.
+FILENAME is a suggested file name for the attachment should a
+recipient wish to save a copy separate from the message."
(interactive
(let* ((buffer (read-buffer "Attach buffer: "))
(type (mml-minibuffer-read-type buffer "text/plain"))
@@ -1497,9 +1506,10 @@ BUFFER is the name of the buffer to attach. See
;; If in the message header, attach at the end and leave point unchanged.
(let ((head (unless (message-in-body-p) (point))))
(if head (goto-char (point-max)))
- (mml-insert-empty-tag 'part 'type type 'buffer buffer
- 'disposition disposition
- 'description description)
+ (apply #'mml-insert-empty-tag
+ 'part 'type type 'buffer buffer
+ 'disposition disposition 'description description
+ (and filename `(filename ,filename)))
;; When using Mail mode, make sure it does the mime encoding
;; when you send the message.
(or (eq mail-user-agent 'message-user-agent)
diff --git a/lisp/gnus/mml2015.el b/lisp/gnus/mml2015.el
index 4c0b965b5a2..602a4baa73d 100644
--- a/lisp/gnus/mml2015.el
+++ b/lisp/gnus/mml2015.el
@@ -752,7 +752,7 @@ If set, it overrides the setting of `mml2015-sign-with-sender'."
(if (not key-image)
""
(condition-case nil
- (let ((result " "))
+ (let ((result (copy-sequence " ")))
(put-text-property
1 2 'display
(gnus-rescale-image key-image
diff --git a/lisp/gnus/nndiary.el b/lisp/gnus/nndiary.el
index 9dbdc9c7cd3..b6f423ee2f8 100644
--- a/lisp/gnus/nndiary.el
+++ b/lisp/gnus/nndiary.el
@@ -339,8 +339,15 @@ all. This may very well take some time.")
;; for this header) or one list (specifying all the possible values for this
;; header). In the latter case, the list does NOT include the unspecified
;; spec (*).
+
;; For time zone values, we have symbolic time zone names associated with
;; the (relative) number of seconds ahead GMT.
+ ;; The list of time zone values is obsolescent, and new code should
+ ;; not rely on it. Many of the time zone abbreviations are wrong;
+ ;; in particular, all single-letter abbreviations other than "Z" have
+ ;; been wrong since Internet RFC 2822 (2001). However, the
+ ;; abbreviations have not been changed due to backward compatibility
+ ;; concerns.
)
(defsubst nndiary-schedule ()
@@ -1366,10 +1373,10 @@ all. This may very well take some time.")
(setq day (+ 7 day))))
;; Finally, if we have some days, they are valid
(when days
- (sort days #'>)
(throw 'found
(encode-time 0 minute hour
- (car days) month year time-zone)))
+ (apply #'max days)
+ month year time-zone)))
)))))
;; There's an upper limit, but we didn't find any last occurrence.
;; This means that the schedule is undecidable. This can happen if
diff --git a/lisp/gnus/nnheader.el b/lisp/gnus/nnheader.el
index 97821894b48..ea679759f3e 100644
--- a/lisp/gnus/nnheader.el
+++ b/lisp/gnus/nnheader.el
@@ -1016,7 +1016,7 @@ See `find-file-noselect' for the arguments."
(nnheader-skeleton-replace from to t))
(defun nnheader-strip-cr ()
- "Strip all \r's from the current buffer."
+ "Strip all \\r's from the current buffer."
(nnheader-skeleton-replace "\r"))
(define-obsolete-function-alias 'nnheader-cancel-timer 'cancel-timer "27.1")
diff --git a/lisp/gnus/nnimap.el b/lisp/gnus/nnimap.el
index 1ef8f60de00..17a55f988c9 100644
--- a/lisp/gnus/nnimap.el
+++ b/lisp/gnus/nnimap.el
@@ -1908,19 +1908,7 @@ If LIMIT, first try to limit the search to the N last articles."
(autoload 'nnselect-search-thread "nnselect")
-(deffoo nnimap-request-thread (header &optional group server)
- (if gnus-refer-thread-use-search
- (nnselect-search-thread header)
- (when (nnimap-change-group group server)
- (let* ((cmd (nnimap-make-thread-query header))
- (result (with-current-buffer (nnimap-buffer)
- (nnimap-command "UID SEARCH %s" cmd))))
- (when result
- (gnus-fetch-headers
- (and (car result)
- (delete 0 (mapcar #'string-to-number
- (cdr (assoc "SEARCH" (cdr result))))))
- nil t))))))
+(make-obsolete 'nnimap-request-thread 'gnus-search-thread "29.1")
(defun nnimap-change-group (group &optional server no-reconnect read-only)
"Change group to GROUP if non-nil.
diff --git a/lisp/gnus/nnmairix.el b/lisp/gnus/nnmairix.el
index 847f39ae461..c517f85db9b 100644
--- a/lisp/gnus/nnmairix.el
+++ b/lisp/gnus/nnmairix.el
@@ -741,8 +741,7 @@ called interactively, user will be asked for parameters."
(when (and (stringp query)
(string-match "\\s-" query))
(setq query (split-string query)))
- (when (not (listp query))
- (setq query (list query)))
+ (setq query (ensure-list query))
(when (and server group query)
(let ((groupname (gnus-group-prefixed-name group server))
) ;; info
diff --git a/lisp/gnus/nnrss.el b/lisp/gnus/nnrss.el
index 632f3b834fe..fe2d0df5f3f 100644
--- a/lisp/gnus/nnrss.el
+++ b/lisp/gnus/nnrss.el
@@ -629,7 +629,7 @@ which RSS 2.0 allows."
(assoc 'href
(nnrss-discover-feed
(read-string
- (format "URL to search for %s: " group) "http://")))))
+ (format "URL to search for %s: " group) "https://")))))
(let ((pair (assoc-string group nnrss-server-data)))
(if pair
(setcdr (cdr pair) (list url))
diff --git a/lisp/gnus/nnselect.el b/lisp/gnus/nnselect.el
index 3658b4189bb..c6a1c0a9342 100644
--- a/lisp/gnus/nnselect.el
+++ b/lisp/gnus/nnselect.el
@@ -64,6 +64,7 @@
(defvar gnus-inhibit-demon)
(defvar gnus-message-group-art)
+(defvar gnus-search-use-parsed-queries)
;; For future use
(defvoo nnselect-directory gnus-directory
@@ -85,14 +86,14 @@
(let (selection)
(pcase-dolist (`(,artgroup . ,arts)
(nnselect-categorize artlist #'nnselect-artitem-group))
- (let (list)
+ (let (list)
(pcase-dolist (`(,rsv . ,articles)
- (nnselect-categorize
+ (nnselect-categorize
arts #'nnselect-artitem-rsv #'nnselect-artitem-number))
(push (cons rsv (gnus-compress-sequence (sort articles #'<)))
list))
- (push (cons artgroup list) selection)))
- selection)))
+ (push (cons artgroup (sort list 'car-less-than-car)) selection)))
+ (sort selection (lambda (x y) (string< (car x) (car y)))))))
(defun nnselect-uncompress-artlist (artlist)
"Uncompress ARTLIST."
@@ -100,17 +101,20 @@
artlist
(let (selection)
(pcase-dolist (`(,artgroup . ,list) artlist)
- (pcase-dolist (`(,artrsv . ,artseq) list)
- (setq selection
- (vconcat
- (cl-map 'vector
- (lambda (art)
- (vector artgroup art artrsv))
- (gnus-uncompress-sequence artseq)) selection))))
- selection)))
+ (pcase-dolist (`(,artrsv . ,artseq) list)
+ (setq selection
+ (vconcat selection
+ (cl-map 'vector
+ (lambda (art)
+ (vector artgroup art artrsv))
+ (gnus-uncompress-sequence artseq))))))
+ (sort selection
+ (lambda (x y)
+ (< (nnselect-artitem-rsv x) (nnselect-artitem-rsv y)))))))
(make-obsolete 'nnselect-group-server 'gnus-group-server "28.1")
(make-obsolete 'nnselect-run 'nnselect-generate-artlist "29.1")
+(make-obsolete 'nnselect-search-thread 'gnus-search-thread "29.1")
;; Data type article list.
@@ -267,45 +271,23 @@ 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
+ "Get the stored 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."
+non-nil, return nil to regenerate the artlist; otherwise retrieve
+the stored artlist from the group parameters."
`(when (gnus-nnselect-group-p ,group)
(let ((override (gnus-group-get-parameter
- ,group
- 'nnselect-get-artlist-override-function)))
+ ,group
+ 'nnselect-get-artlist-override-function)))
(cond
(override (funcall override ,group))
((gnus-group-get-parameter ,group 'nnselect-always-regenerate)
- (nnselect-generate-artlist ,group))
+ nil)
(t
- (nnselect-uncompress-artlist
+ (nnselect-uncompress-artlist
(gnus-group-get-parameter ,group 'nnselect-artlist t)))))))
(defmacro nnselect-store-artlist (group artlist)
@@ -313,17 +295,65 @@ directly from the group parameters."
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."
+artlist; otherwise store the ARTLIST in the group parameters.
+The active range is also stored."
`(let ((override (gnus-group-get-parameter
- ,group
- 'nnselect-store-artlist-override-function)))
+ ,group
+ 'nnselect-store-artlist-override-function)))
+ (gnus-group-set-parameter ,group 'active
+ (cons 1 (nnselect-artlist-length ,artlist)))
(cond
(override (funcall override ,group ,artlist))
- ((gnus-group-get-parameter ,group 'nnselect-always-regenerate) t)
+ ((gnus-group-get-parameter ,group 'nnselect-always-regenerate)
+ (gnus-group-remove-parameter ,group 'nnselect-artlist))
(t
(gnus-group-set-parameter ,group 'nnselect-artlist
(nnselect-compress-artlist ,artlist))))))
+(defun nnselect-generate-artlist (group &optional specs info)
+ "Generate and return the artlist for GROUP using SPECS.
+The artlist is sorted by rsv, lexically over groups, and by
+article number. 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. If INFO update the
+group info."
+ (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
+ (progn
+ (let ((gnus-newsgroup-selection
+ (sort
+ (funcall function args)
+ (lambda (x y)
+ (let ((xgroup (nnselect-artitem-group x))
+ (ygroup (nnselect-artitem-group y))
+ (xrsv (nnselect-artitem-rsv x))
+ (yrsv (nnselect-artitem-rsv y)))
+ (or (< xrsv yrsv)
+ (and (eql xrsv yrsv)
+ (or (string< xgroup ygroup)
+ (and (string= xgroup ygroup)
+ (< (nnselect-artitem-number x)
+ (nnselect-artitem-number y)))))))))))
+ (when info
+ (if gnus-newsgroup-selection
+ (nnselect-request-update-info group info)
+ (gnus-set-active group '(1 . 0))))
+ (nnselect-store-artlist group gnus-newsgroup-selection)
+ gnus-newsgroup-selection))
+ ;; 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)
+ []))))
+
;; Gnus backend interface functions.
(deffoo nnselect-open-server (server &optional definitions)
@@ -344,85 +374,82 @@ artlist; otherwise store the ARTLIST in the group parameters."
(deffoo nnselect-request-group (group &optional _server _dont-check info)
(let* ((group (nnselect-add-prefix group))
- (nnselect-artlist (nnselect-get-artlist group))
- length)
- ;; Check for cached select result or run the selection and cache
- ;; the result.
- (unless nnselect-artlist
- (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)))
- (progn
- (nnheader-report 'nnselect "Selection produced empty results.")
- (when (gnus-ephemeral-group-p group)
- (gnus-kill-ephemeral-group group)
- (setq gnus-ephemeral-servers
- (assq-delete-all 'nnselect gnus-ephemeral-servers)))
- (nnheader-insert ""))
+ (length (cdr (gnus-group-get-parameter group 'active t))))
+ (when (or (null length)
+ (gnus-group-get-parameter group 'nnselect-always-regenerate))
+ (setq length (nnselect-artlist-length
+ (nnselect-generate-artlist group nil info))))
+ (if (and (zerop length) (gnus-ephemeral-group-p group))
+ (progn
+ (nnheader-report 'nnselect "Selection produced empty results.")
+ (gnus-kill-ephemeral-group group)
+ (setq gnus-ephemeral-servers
+ (assq-delete-all 'nnselect gnus-ephemeral-servers))
+ (nnheader-insert ""))
(with-current-buffer nntp-server-buffer
- (nnheader-insert "211 %d %d %d %s\n"
- length ; total #
- 1 ; first #
- length ; last #
- group))) ; group name
- nnselect-artlist))
-
+ (nnheader-insert "211 %d %d %d %s\n"
+ length ; total #
+ (if (zerop length) 0 1) ; first #
+ length ; last #
+ group))))) ; group name
(deffoo nnselect-retrieve-headers (articles group &optional _server fetch-old)
- (let ((group (nnselect-add-prefix group)))
+ (let ((group (nnselect-add-prefix group))
+ (gnus-inhibit-demon t))
(with-current-buffer (gnus-summary-buffer-name group)
- (setq gnus-newsgroup-selection (or gnus-newsgroup-selection
- (nnselect-get-artlist group)))
- (let ((gnus-inhibit-demon t)
- (gartids (ids-by-group articles))
- headers)
- (with-current-buffer nntp-server-buffer
- (pcase-dolist (`(,artgroup . ,artids) gartids)
- (let ((artlist (sort (mapcar #'cdr artids) #'<))
- (gnus-override-method (gnus-find-method-for-group artgroup))
- (fetch-old
- (or
- (car-safe
- (gnus-group-find-parameter artgroup
- 'gnus-fetch-old-headers t))
- fetch-old)))
+ (setq gnus-newsgroup-selection
+ (or gnus-newsgroup-selection
+ (nnselect-get-artlist group)
+ ;; maybe don't need to update the info?
+ ;; (nnselect-generate-artlist group nil (gnus-get-info group))))
+ (nnselect-generate-artlist group)))
+ (let ((gartids (ids-by-group articles))
+ headers)
+ (with-current-buffer nntp-server-buffer
+ (pcase-dolist (`(,artgroup . ,artids) gartids)
+ (let ((artlist (sort (mapcar #'cdr artids) #'<))
+ (gnus-override-method (gnus-find-method-for-group artgroup))
+ (fetch-old
+ (or
+ (car-safe
+ (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
- (and
- nnselect-retrieve-headers-override-function
- (funcall
- nnselect-retrieve-headers-override-function
- artlist artgroup))
- (gnus-retrieve-headers
- artlist artgroup fetch-old)))
- ('nov
- (goto-char (point-min))
- (while (not (eobp))
- (nnselect-add-novitem
- (nnheader-parse-nov))
- (forward-line 1)))
- ('headers
- (gnus-run-hooks 'gnus-parse-headers-hook)
- (let ((nnmail-extra-headers gnus-extra-headers))
- (goto-char (point-min))
- (while (not (eobp))
- (nnselect-add-novitem
- (nnheader-parse-head))
- (forward-line 1))))
- ((pred listp)
- (dolist (novitem gnus-headers-retrieved-by)
- (nnselect-add-novitem novitem)))
- (_ (error "Unknown header type %s while requesting articles \
- of group %s" gnus-headers-retrieved-by artgroup)))))
- (setq headers
- (sort
- headers
- (lambda (x y)
- (< (mail-header-number x) (mail-header-number y))))))))))
+ (erase-buffer)
+ (pcase (setq gnus-headers-retrieved-by
+ (or
+ (and
+ nnselect-retrieve-headers-override-function
+ (funcall
+ nnselect-retrieve-headers-override-function
+ artlist artgroup))
+ (gnus-retrieve-headers
+ artlist artgroup fetch-old)))
+ ('nov
+ (goto-char (point-min))
+ (while (not (eobp))
+ (nnselect-add-novitem
+ (nnheader-parse-nov))
+ (forward-line 1)))
+ ('headers
+ (gnus-run-hooks 'gnus-parse-headers-hook)
+ (let ((nnmail-extra-headers gnus-extra-headers))
+ (goto-char (point-min))
+ (while (not (eobp))
+ (nnselect-add-novitem
+ (nnheader-parse-head))
+ (forward-line 1))))
+ ((pred listp)
+ (dolist (novitem gnus-headers-retrieved-by)
+ (nnselect-add-novitem novitem)))
+ (_ (error "Unknown header type %s while requesting articles \
+ of group %s" gnus-headers-retrieved-by artgroup)))))
+ (setq headers
+ (sort
+ headers
+ (lambda (x y)
+ (< (mail-header-number x) (mail-header-number y))))))))))
(deffoo nnselect-request-article (article &optional _group server to-buffer)
@@ -439,7 +466,7 @@ artlist; otherwise store the ARTLIST in the group parameters."
(if (eq 'nnselect (car (gnus-server-to-method server)))
(with-current-buffer gnus-summary-buffer
(let ((thread (gnus-id-to-thread article)))
- (when thread
+ (when (car thread)
(mapc
(lambda (x)
(when (and x (> x 0))
@@ -477,7 +504,8 @@ artlist; otherwise store the ARTLIST in the group parameters."
(deffoo nnselect-request-move-article
(article _group _server accept-form &optional last _internal-move-group)
- (let* ((artgroup (nnselect-article-group article))
+ (let* ((nnimap-expunge 'immediately)
+ (artgroup (nnselect-article-group article))
(artnumber (nnselect-article-number article))
(to-newsgroup (nth 1 accept-form))
(to-method (gnus-find-method-for-group to-newsgroup))
@@ -565,9 +593,9 @@ artlist; otherwise store the ARTLIST in the group parameters."
(artnumber (nnselect-article-number article))
(gmark (gnus-request-update-mark artgroup artnumber mark)))
(when (and artnumber
- (memq mark gnus-auto-expirable-marks)
- (= mark gmark)
- (gnus-group-auto-expirable-p artgroup))
+ (memq mark gnus-auto-expirable-marks)
+ (= mark gmark)
+ (gnus-group-auto-expirable-p artgroup))
(setq gmark gnus-expirable-mark))
gmark))
@@ -593,116 +621,109 @@ artlist; otherwise store the ARTLIST in the group parameters."
(gnus-newsgroup-selection
(or gnus-newsgroup-selection (nnselect-get-artlist group)))
newmarks)
- (gnus-info-set-marks info nil)
- (setf (gnus-info-read info) nil)
- (pcase-dolist (`(,artgroup . ,nartids)
- (ids-by-group
- (number-sequence 1 (nnselect-artlist-length
- gnus-newsgroup-selection))))
- (let* ((gnus-newsgroup-active nil)
- (idmap (make-hash-table :test 'eql))
- (gactive (sort (mapcar 'cdr nartids) '<))
- (group-info (gnus-get-info artgroup))
- (marks (gnus-info-marks group-info)))
- (pcase-dolist (`(,val . ,key) nartids)
- (puthash key val idmap))
- (setf (gnus-info-read info)
- (range-add-list
- (gnus-info-read info)
- (sort (mapcar (lambda (art) (gethash art idmap))
- (gnus-sorted-intersection
- gactive
- (range-uncompress (gnus-info-read group-info))))
- '<)))
- (pcase-dolist (`(,type . ,mark-list) marks)
- (let ((mark-type (gnus-article-mark-to-type type)) new)
- (when
- (setq new
- (if (not mark-list) nil
- (cond
- ((eq mark-type 'tuple)
- (delq nil
- (mapcar
- (lambda (mark)
- (let ((id (gethash (car mark) idmap)))
- (when id (cons id (cdr mark)))))
- mark-list)))
- (t
- (mapcar (lambda (art) (gethash art idmap))
- (gnus-sorted-intersection
- gactive (range-uncompress mark-list)))))))
- (let ((previous (alist-get type newmarks)))
- (if previous
- (nconc previous new)
- (push (cons type new) newmarks))))))))
-
- ;; Clean up the marks: compress lists;
- (pcase-dolist (`(,type . ,mark-list) newmarks)
- (let ((mark-type (gnus-article-mark-to-type type)))
- (unless (eq mark-type 'tuple)
- (setf (alist-get type newmarks)
- (gnus-compress-sequence (sort mark-list '<))))))
- ;; and ensure an unexist key.
- (unless (assq 'unexist newmarks)
- (push (cons 'unexist nil) newmarks))
-
- (gnus-info-set-marks info newmarks)
- (gnus-set-active group (cons 1 (nnselect-artlist-length
- gnus-newsgroup-selection)))))
+ (when gnus-newsgroup-selection
+ (gnus-info-set-marks info nil)
+ (setf (gnus-info-read info) nil)
+ (pcase-dolist (`(,artgroup . ,nartids)
+ (ids-by-group
+ (number-sequence 1 (nnselect-artlist-length
+ gnus-newsgroup-selection))))
+ (let* ((gnus-newsgroup-active nil)
+ (idmap (make-hash-table :test 'eql))
+ (gactive (sort (mapcar 'cdr nartids) #'<))
+ (group-info (gnus-get-info artgroup))
+ (marks (gnus-info-marks group-info)))
+ (pcase-dolist (`(,val . ,key) nartids)
+ (puthash key val idmap))
+ (setf (gnus-info-read info)
+ (range-add-list
+ (gnus-info-read info)
+ (sort (mapcar (lambda (art) (gethash art idmap))
+ (gnus-sorted-intersection
+ gactive
+ (range-uncompress (gnus-info-read group-info))))
+ #'<)))
+ (pcase-dolist (`(,type . ,mark-list) marks)
+ (let ((mark-type (gnus-article-mark-to-type type)) new)
+ (when
+ (setq new
+ (if (not mark-list) nil
+ (cond
+ ((eq mark-type 'tuple)
+ (delq nil
+ (mapcar
+ (lambda (mark)
+ (let ((id (gethash (car mark) idmap)))
+ (when id (cons id (cdr mark)))))
+ mark-list)))
+ (t
+ (mapcar (lambda (art) (gethash art idmap))
+ (gnus-sorted-intersection
+ gactive (range-uncompress mark-list)))))))
+ (let ((previous (alist-get type newmarks)))
+ (if previous
+ (nconc previous new)
+ (push (cons type new) newmarks))))))))
+
+ ;; Clean up the marks: compress lists;
+ (pcase-dolist (`(,type . ,mark-list) newmarks)
+ (let ((mark-type (gnus-article-mark-to-type type)))
+ (unless (eq mark-type 'tuple)
+ (setf (alist-get type newmarks)
+ (gnus-compress-sequence (sort mark-list #'<))))))
+ ;; and ensure an unexist key.
+ (unless (assq 'unexist newmarks)
+ (push (cons 'unexist nil) newmarks))
+
+ (gnus-info-set-marks info newmarks)
+ (gnus-set-active group (cons 1 (nnselect-artlist-length
+ gnus-newsgroup-selection))))))
(deffoo nnselect-request-thread (header &optional group server)
(with-current-buffer gnus-summary-buffer
- (let ((group (nnselect-add-prefix group))
- ;; find the best group for the originating article. if its a
- ;; pseudo-article look for real articles in the same thread
- ;; and see where they come from.
- (artgroup (nnselect-article-group
- (if (> (mail-header-number header) 0)
- (mail-header-number header)
- (if (> (gnus-summary-article-number) 0)
- (gnus-summary-article-number)
- (let ((thread
- (gnus-id-to-thread (mail-header-id header))))
- (when thread
- (cl-some (lambda (x)
- (when (and x (> x 0)) x))
- (gnus-articles-in-thread thread)))))))))
- ;; Check if search-based thread referral is permitted, and
- ;; available.
- (if (and gnus-refer-thread-use-search
- (gnus-search-server-to-engine
- (gnus-method-to-server
- (gnus-find-method-for-group artgroup))))
- ;; If so we perform the query, massage the result, and return
- ;; the new headers back to the caller to incorporate into the
- ;; current summary buffer.
- (let* ((group-spec
- (list (delq nil (list
- (or server (gnus-group-server artgroup))
- (unless gnus-refer-thread-use-search
- artgroup)))))
- (ids (cons (mail-header-id header)
- (split-string
- (or (mail-header-references header)
- ""))))
- (query-spec
- (list (cons 'query (mapconcat (lambda (i)
- (format "id:%s" i))
- ids " or "))
- (cons 'thread t)))
- (last (nnselect-artlist-length gnus-newsgroup-selection))
- (first (1+ last))
- (new-nnselect-artlist
- (gnus-search-run-query
- (list (cons 'search-query-spec query-spec)
- (cons 'search-group-spec group-spec))))
- old-arts seq
- headers)
- (mapc
+ (let* ((group (nnselect-add-prefix group))
+ ;; Find the best group for the originating article. If its
+ ;; a pseudo-article check for real articles in the same
+ ;; thread to see where they come from.
+ (artgroup
+ (nnselect-article-group
+ (cond
+ ((> (mail-header-number header) 0)
+ (mail-header-number header))
+ ((> (gnus-summary-article-number) 0)
+ (gnus-summary-article-number))
+ (t (cl-some
+ (lambda (x) (when (and x (> x 0)) x))
+ (gnus-articles-in-thread
+ (gnus-id-to-thread (mail-header-id header))))))))
+ (server (or server (gnus-group-server artgroup))))
+ ;; Check if search-based thread referral is available.
+ (if (ignore-errors (gnus-search-server-to-engine server))
+ ;; We perform the query, massage the result, and return
+ ;; the new headers back to the caller to incorporate into
+ ;; the current summary buffer.
+ (let* ((gnus-search-use-parsed-queries t)
+ (group-spec
+ (if (not gnus-refer-thread-use-search)
+ (list (list server artgroup))
+ (if (listp gnus-refer-thread-use-search)
+ gnus-refer-thread-use-search
+ (list (list server)))))
+ (ids (cons (mail-header-id header)
+ (split-string
+ (or (mail-header-references header)
+ ""))))
+ (query-spec
+ (list (cons 'query
+ (mapconcat (lambda (i) (format "id:%s" i))
+ ids " or ")) (cons 'thread t)))
+ (last (nnselect-artlist-length gnus-newsgroup-selection))
+ (first (1+ last))
+ old-arts seq headers)
+ (mapc
(lambda (article)
- (if
- (setq seq
+ (if (setq seq
(cl-position
article
gnus-newsgroup-selection
@@ -710,54 +731,68 @@ artlist; otherwise store the ARTLIST in the group parameters."
(lambda (x y)
(and (equal (nnselect-artitem-group x)
(nnselect-artitem-group y))
- (eql (nnselect-artitem-number x)
+ (eql (nnselect-artitem-number x)
(nnselect-artitem-number y))))))
(push (1+ seq) old-arts)
(setq gnus-newsgroup-selection
(vconcat gnus-newsgroup-selection (vector article)))
(cl-incf last)))
- new-nnselect-artlist)
- (setq headers
- (gnus-fetch-headers
- (append (sort old-arts #'<)
- (number-sequence first last))
- nil t))
- (nnselect-store-artlist group gnus-newsgroup-selection)
- (when (>= last first)
- (let (new-marks)
- (pcase-dolist (`(,artgroup . ,artids)
- (ids-by-group (number-sequence first last)))
- (pcase-dolist (`(,type . ,marked)
- (gnus-info-marks (gnus-get-info artgroup)))
- (setq marked (gnus-uncompress-sequence marked))
- (when (setq new-marks
- (delq nil
- (mapcar
+ (gnus-search-run-query
+ (list (cons 'search-query-spec query-spec)
+ (cons 'search-group-spec group-spec))))
+ (setq headers
+ (gnus-fetch-headers
+ (append (sort old-arts #'<) (number-sequence first last))
+ nil t))
+ (nnselect-store-artlist group gnus-newsgroup-selection)
+ (when (>= last first)
+ (let (new-marks)
+ (pcase-dolist (`(,artgroup . ,artids)
+ (ids-by-group (number-sequence first last)))
+ (pcase-dolist (`(,type . ,marked)
+ (gnus-info-marks (gnus-get-info artgroup)))
+ (when
+ (setq new-marks
+ (delq nil
+ (if (eq (gnus-article-mark-to-type type)
+ 'tuple)
+ (mapcar
+ (lambda (art)
+ (let ((mtup
+ (assq (cdr art) marked)))
+ (when mtup
+ (cons (car art) (cdr mtup)))))
+ artids)
+ (setq marked
+ (gnus-uncompress-sequence marked))
+ (mapcar
(lambda (art)
(when (memq (cdr art) marked)
(car art)))
- artids)))
- (nconc
- (symbol-value
- (intern
- (format "gnus-newsgroup-%s"
- (car (rassq type gnus-article-mark-lists)))))
- new-marks)))))
- (setq gnus-newsgroup-active
- (cons 1 (nnselect-artlist-length gnus-newsgroup-selection)))
- (gnus-set-active
- group
- (cons 1 (nnselect-artlist-length gnus-newsgroup-selection))))
- headers)
- ;; If we can't or won't use search, just warp to the original
- ;; group and punt back to gnus-summary-refer-thread.
- (and (gnus-warp-to-article) (gnus-summary-refer-thread))))))
+ artids))))
+ (nconc
+ (symbol-value
+ (intern
+ (format "gnus-newsgroup-%s"
+ (car
+ (rassq type gnus-article-mark-lists)))))
+ new-marks)))))
+ (gnus-set-active
+ group
+ (setq
+ gnus-newsgroup-active
+ (cons 1 (nnselect-artlist-length gnus-newsgroup-selection)))))
+ headers)
+ ;; If we can't use search, just warp to the original group and
+ ;; punt back to gnus-summary-refer-thread.
+ (and (gnus-warp-to-article) (gnus-summary-refer-thread))))))
(deffoo nnselect-close-group (group &optional _server)
(let ((group (nnselect-add-prefix group)))
(unless gnus-group-is-exiting-without-update-p
- (nnselect-push-info group))
+ (when gnus-newsgroup-selection
+ (nnselect-push-info group)))
(setq gnus-newsgroup-selection nil)
(when (gnus-ephemeral-group-p group)
(gnus-kill-ephemeral-group group)
@@ -769,23 +804,23 @@ artlist; otherwise store the ARTLIST in the group parameters."
(message "Creating nnselect group %s" group)
(let* ((group (gnus-group-prefixed-name group '(nnselect "nnselect")))
(specs (assq 'nnselect-specs args))
+ (artlist (alist-get 'nnselect-artlist args))
(otherargs (assq-delete-all 'nnselect-specs args))
(function-spec
(or (alist-get 'nnselect-function specs)
- (intern (completing-read "Function: " obarray #'functionp))))
+ (intern (completing-read "Function: " obarray #'functionp))))
(args-spec
(or (alist-get 'nnselect-args specs)
(read-from-minibuffer "Args: " nil nil t nil "nil")))
(nnselect-specs (list (cons 'nnselect-function function-spec)
- (cons 'nnselect-args args-spec))))
+ (cons 'nnselect-args args-spec))))
(gnus-group-set-parameter group 'nnselect-specs 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)))
+ (if artlist
+ (nnselect-store-artlist group artlist)
+ (nnselect-generate-artlist group nnselect-specs
+ (gnus-get-info group))))
t)
@@ -815,11 +850,12 @@ artlist; otherwise store the ARTLIST in the group parameters."
(deffoo nnselect-request-group-scan (group &optional _server _info)
- (let* ((group (nnselect-add-prefix group))
- (artlist (nnselect-generate-artlist group)))
- (gnus-set-active group (cons 1 (nnselect-artlist-length
- artlist)))
- (nnselect-store-artlist group artlist)))
+ (let ((group (nnselect-add-prefix group)))
+ (unless (gnus-group-find-parameter group 'nnselect-always-regenerate)
+ (let ((artlist (nnselect-generate-artlist group)))
+ (gnus-set-active group (cons 1 (nnselect-artlist-length
+ artlist))))))
+ t)
;; Add any undefined required backend functions
@@ -883,133 +919,136 @@ article came from is also searched."
(defun nnselect-push-info (group)
"Copy mark-lists from GROUP to the originating groups."
(let ((select-unreads (numbers-by-group gnus-newsgroup-unreads))
- (select-reads (numbers-by-group
- (gnus-info-read (gnus-get-info group)) 'range))
- (select-unseen (numbers-by-group gnus-newsgroup-unseen))
- (gnus-newsgroup-active nil) mark-list)
+ (select-reads (numbers-by-group
+ (gnus-sorted-difference gnus-newsgroup-articles
+ gnus-newsgroup-unreads)))
+ (select-unseen (numbers-by-group gnus-newsgroup-unseen))
+ (quit-config (gnus-group-quit-config group))
+ (gnus-newsgroup-active nil) mark-list)
;; collect the set of marked article lists categorized by
;; originating groups
(pcase-dolist (`(,mark . ,type) gnus-article-mark-lists)
- (let (type-list)
- (when (setq type-list
- (symbol-value (intern (format "gnus-newsgroup-%s" mark))))
- (push (cons
- type
- (numbers-by-group type-list (gnus-article-mark-to-type type)))
- mark-list))))
+ (let ((mark-type (gnus-article-mark-to-type type))
+ (type-list (symbol-value
+ (intern (format "gnus-newsgroup-%s" mark)))))
+ (when type-list
+ (unless (eq 'tuple mark-type)
+ (setq type-list (range-list-intersection
+ gnus-newsgroup-articles type-list)))
+ (push (cons type (numbers-by-group type-list mark-type))
+ mark-list))))
;; now work on each originating group one at a time
(pcase-dolist (`(,artgroup . ,artlist)
- (numbers-by-group gnus-newsgroup-articles))
- (let* ((group-info (gnus-get-info artgroup))
- (old-unread (gnus-list-of-unread-articles artgroup))
- newmarked delta-marks)
- (when group-info
- ;; iterate over mark lists for this group
- (pcase-dolist (`(,_mark . ,type) gnus-article-mark-lists)
- (let ((list (cdr (assoc artgroup (alist-get type mark-list))))
- (mark-type (gnus-article-mark-to-type type)))
-
- ;; 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))))
- (del (range-remove (copy-tree old) list))
- (add (range-remove (copy-tree list) old)))
- (when add (push (list add 'add (list type)) delta-marks))
- (when del
- ;; Don't delete marks from outside the active range.
- ;; 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))))
-
- ;; Marked sets are of mark-type 'tuple, 'list, or
- ;; 'range. We merge the lists with what is already in
- ;; the original info to get full list of new marks. We
- ;; do this by removing all the articles we retrieved
- ;; from the full list, and then add back in the newly
- ;; marked ones.
- (cond
- ((eq mark-type 'tuple)
- ;; Get rid of the entries that have the default
- ;; score.
- (when (and list (eq type 'score) gnus-save-score)
- (let* ((arts list)
- (prev (cons nil list))
- (all prev))
- (while arts
- (if (or (not (consp (car arts)))
- (= (cdar arts) gnus-summary-default-score))
- (setcdr prev (cdr arts))
- (setq prev arts))
- (setq arts (cdr arts)))
- (setq list (cdr all))))
- ;; now merge with the original list and sort just to
- ;; make sure
- (setq
- list (sort
+ (numbers-by-group gnus-newsgroup-articles))
+ (setq artlist (sort artlist #'<))
+ (let ((group-info (gnus-get-info artgroup))
+ (old-unread (gnus-list-of-unread-articles artgroup))
+ (rsm (gnus-check-backend-function 'request-set-mark artgroup))
+ newmarked delta-marks)
+ (when group-info
+ ;; iterate over mark lists for this group
+ (pcase-dolist (`(,_mark . ,type) gnus-article-mark-lists)
+ (let ((list (cdr (assoc artgroup (alist-get type mark-list))))
+ (mark-type (gnus-article-mark-to-type type))
+ (group-marks (alist-get type (gnus-info-marks group-info))))
+
+ ;; When the backend can store marks we collect any
+ ;; changes. Unlike a normal group the mark lists only
+ ;; include marks for articles we retrieved. If there is
+ ;; no quit-config then gnus-update-marks has already
+ ;; been called to handle this.
+ (when (and quit-config rsm
+ (not (gnus-article-unpropagatable-p type)))
+ (let* ((old (range-list-intersection
+ artlist group-marks))
+ (del (range-remove (copy-tree old) list))
+ (add (range-remove (copy-tree list) old)))
+ (when add (push (list add 'add (list type)) delta-marks))
+ (when del
+ ;; Don't delete marks from outside the active range.
+ ;; 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))))
+
+ ;; Marked sets are of mark-type 'tuple, 'list, or
+ ;; 'range. We merge the lists with what is already in
+ ;; the original info to get full list of new marks. We
+ ;; do this by removing all the articles we retrieved
+ ;; from the full list, and then add back in the newly
+ ;; marked ones.
+ (cond
+ ((eq mark-type 'tuple)
+ ;; Get rid of the entries that have the default
+ ;; score.
+ (when (and list (eq type 'score) gnus-save-score)
+ (let* ((arts list)
+ (prev (cons nil list))
+ (all prev))
+ (while arts
+ (if (or (not (consp (car arts)))
+ (= (cdar arts) gnus-summary-default-score))
+ (setcdr prev (cdr arts))
+ (setq prev arts))
+ (setq arts (cdr arts)))
+ (setq list (cdr all))))
+ ;; now merge with the original list and sort just to
+ ;; make sure
+ (setq list
+ (sort
(map-merge
- 'alist list
+ 'alist list
(delq nil
(mapcar
(lambda (x) (unless (memq (car x) artlist) x))
- (alist-get type (gnus-info-marks group-info)))))
+ group-marks)))
'car-less-than-car)))
- (t
- (setq list
- (range-compress-list
- (gnus-sorted-union
- (gnus-sorted-difference
- (gnus-uncompress-sequence
- (alist-get type (gnus-info-marks group-info)))
- artlist)
- (sort list #'<)))))
-
- ;; When exiting the group, everything that's previously been
- ;; unseen is now seen.
- (when (eq type 'seen)
- (setq list (range-concat
- list (cdr (assoc artgroup select-unseen))))))
-
- (when (or list (eq type 'unexist))
- (push (cons type list) newmarked)))) ;; end of mark-type loop
-
- (when delta-marks
- (unless (gnus-check-group artgroup)
- (error "Can't open server for %s" artgroup))
- (gnus-request-set-mark artgroup delta-marks))
-
- (gnus-atomic-progn
- (gnus-info-set-marks group-info newmarked)
- ;; Cut off the end of the info if there's nothing else there.
- (let ((i 5))
- (while (and (> i 2)
- (not (nth i group-info)))
- (when (nthcdr (cl-decf i) group-info)
- (setcdr (nthcdr i group-info) nil))))
-
- ;; update read and unread
- (gnus-update-read-articles
- artgroup
- (range-uncompress
- (range-add-list
- (range-remove
- old-unread
- (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
- (equal group-info
- (setq group-info (copy-sequence (gnus-get-info artgroup))
- group-info
- (delq (gnus-info-params group-info) group-info)))))))))
+ (t
+ (setq list
+ (range-compress-list
+ (gnus-sorted-union
+ (gnus-sorted-difference
+ (gnus-uncompress-sequence group-marks)
+ artlist)
+ (sort list #'<))))
+
+ ;; When exiting the group, everything that's previously been
+ ;; unseen is now seen.
+ (when (eq type 'seen)
+ (setq list (range-concat
+ list (cdr (assoc artgroup select-unseen)))))))
+
+ (when (or list (eq type 'unexist))
+ (push (cons type list) newmarked)))) ;; end of mark-type loop
+ (when delta-marks
+ (unless (gnus-check-group artgroup)
+ (error "Can't open server for %s" artgroup))
+ (gnus-request-set-mark artgroup delta-marks))
+ (gnus-atomic-progn
+ (gnus-info-set-marks group-info newmarked)
+ ;; Cut off the end of the info if there's nothing else there.
+ (let ((i 5))
+ (while (and (> i 2)
+ (not (nth i group-info)))
+ (when (nthcdr (cl-decf i) group-info)
+ (setcdr (nthcdr i group-info) nil))))
+
+ ;; update read and unread
+ (gnus-update-read-articles
+ artgroup
+ (range-uncompress
+ (range-add-list
+ (range-remove
+ old-unread
+ (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
+ (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/nnspool.el b/lisp/gnus/nnspool.el
index d23351806f2..ce0aea8dd57 100644
--- a/lisp/gnus/nnspool.el
+++ b/lisp/gnus/nnspool.el
@@ -35,7 +35,7 @@
;; It's only used to init nnspool-spool-directory, so why not just
;; set that variable's default directly?
(eval-and-compile
- (defvaralias 'news-path 'news-directory)
+ (define-obsolete-variable-alias 'news-path 'news-directory "30.1")
(defvar news-directory (if (file-exists-p "/usr/spool/news/")
"/usr/spool/news/"
"/var/spool/news/")
@@ -62,9 +62,7 @@ This is most commonly `inews' or `injnews'.")
If you are using Cnews, you probably should set this variable to nil.")
(defvoo nnspool-spool-directory
- (file-name-as-directory (if (boundp 'news-directory)
- (symbol-value 'news-directory)
- news-path))
+ (file-name-as-directory news-directory)
"Local news spool directory.")
(defvoo nnspool-nov-directory (concat nnspool-spool-directory "over.view/")
diff --git a/lisp/gnus/nntp.el b/lisp/gnus/nntp.el
index e009981da06..fe165662988 100644
--- a/lisp/gnus/nntp.el
+++ b/lisp/gnus/nntp.el
@@ -645,8 +645,7 @@ connection timeouts (which may be several minutes) or
`nntp-with-open-group', opens a new connection then re-issues the NNTP
command whose response triggered the error."
(declare (indent 2) (debug (form form [&optional symbolp] def-body)))
- (when (and (listp connectionless)
- (not (eq connectionless nil)))
+ (when (consp connectionless)
(setq forms (cons connectionless forms)
connectionless nil))
`(nntp-with-open-group-function ,group ,server ,connectionless
diff --git a/lisp/gnus/nnweb.el b/lisp/gnus/nnweb.el
index 72fc2d74454..c8a21792662 100644
--- a/lisp/gnus/nnweb.el
+++ b/lisp/gnus/nnweb.el
@@ -42,37 +42,30 @@
(defvoo nnweb-type 'google
"What search engine type is being used.
-Valid types include `google', `dejanews', and `gmane'.")
+Valid types include `google' and `dejanews'.")
(defvar nnweb-type-definition
'((google
- (id . "http://www.google.com/groups?as_umsgid=%s&hl=en&dmode=source")
- (result . "http://groups.google.com/group/%s/msg/%s?dmode=source")
+ (id . "https://www.google.com/groups?as_umsgid=%s&hl=en&dmode=source")
+ (result . "https://groups.google.com/group/%s/msg/%s?dmode=source")
(article . nnweb-google-wash-article)
(reference . identity)
(map . nnweb-google-create-mapping)
(search . nnweb-google-search)
- (address . "http://groups.google.com/groups")
- (base . "http://groups.google.com")
+ (address . "https://groups.google.com/groups")
+ (base . "https://groups.google.com")
(identifier . nnweb-google-identity))
+ ;; FIXME: Make obsolete?
(dejanews ;; alias of google
- (id . "http://www.google.com/groups?as_umsgid=%s&hl=en&dmode=source")
- (result . "http://groups.google.com/group/%s/msg/%s?dmode=source")
+ (id . "https://www.google.com/groups?as_umsgid=%s&hl=en&dmode=source")
+ (result . "https://groups.google.com/group/%s/msg/%s?dmode=source")
(article . nnweb-google-wash-article)
(reference . identity)
(map . nnweb-google-create-mapping)
(search . nnweb-google-search)
- (address . "http://groups.google.com/groups")
- (base . "http://groups.google.com")
- (identifier . nnweb-google-identity))
- (gmane
- (article . nnweb-gmane-wash-article)
- (id . "http://gmane.org/view.php?group=%s")
- (reference . identity)
- (map . nnweb-gmane-create-mapping)
- (search . nnweb-gmane-search)
- (address . "http://search.gmane.org/nov.php")
- (identifier . nnweb-gmane-identity)))
+ (address . "https://groups.google.com/groups")
+ (base . "https://groups.google.com")
+ (identifier . nnweb-google-identity)))
"Type-definition alist.")
(defvoo nnweb-search nil
@@ -254,6 +247,8 @@ Valid types include `google', `dejanews', and `gmane'.")
(defun nnweb-definition (type &optional noerror)
"Return the definition of TYPE."
+ (when (eq nnweb-type 'gmane)
+ (user-error "`gmane' is no longer a valid value for `nnweb-type'"))
(let ((def (cdr (assq type (assq nnweb-type nnweb-type-definition)))))
(when (and (not def)
(not noerror))
@@ -277,6 +272,8 @@ Valid types include `google', `dejanews', and `gmane'.")
(unless (gnus-buffer-live-p nnweb-buffer)
(setq nnweb-buffer
(save-current-buffer
+ (when (eq nnweb-type 'gmane)
+ (user-error "`gmane' is no longer a valid value for `nnweb-type'"))
(nnheader-set-temp-buffer
(format " *nnweb %s %s %s*"
nnweb-type nnweb-search server))
@@ -437,10 +434,11 @@ Valid types include `google', `dejanews', and `gmane'.")
url))
;;;
-;;; gmane.org
+;;; gmane.org -- now obsolete as the gmane.org web interface is gone
;;;
(defun nnweb-gmane-create-mapping ()
"Perform the search and create a number-to-url alist."
+ (declare (obsolete nil "30.1"))
(with-current-buffer nnweb-buffer
(let ((case-fold-search t)
(active (or (cadr (assoc nnweb-group nnweb-group-alist))
@@ -484,6 +482,7 @@ Valid types include `google', `dejanews', and `gmane'.")
(sort (nconc nnweb-articles map) #'car-less-than-car)))))
(defun nnweb-gmane-wash-article ()
+ (declare (obsolete nil "30.1"))
(let ((case-fold-search t))
(goto-char (point-min))
(when (search-forward "<!--X-Head-of-Message-->" nil t)
@@ -495,6 +494,7 @@ Valid types include `google', `dejanews', and `gmane'.")
(mm-url-remove-markup))))
(defun nnweb-gmane-search (search)
+ (declare (obsolete nil "30.1"))
(mm-url-insert
(concat
(nnweb-definition 'address)
@@ -511,6 +511,7 @@ Valid types include `google', `dejanews', and `gmane'.")
(defun nnweb-gmane-identity (url)
"Return a unique identifier based on URL."
+ (declare (obsolete nil "30.1"))
(if (string-match "group=\\(.+\\)" url)
(match-string 1 url)
url))
diff --git a/lisp/gnus/spam.el b/lisp/gnus/spam.el
index 003bfe11329..1ae214ea4fa 100644
--- a/lisp/gnus/spam.el
+++ b/lisp/gnus/spam.el
@@ -1375,8 +1375,7 @@ In the case of mover backends, checks the setting of
(when (and (car-safe groups) (listp (car-safe groups)))
(setq groups (pop groups)))
- (unless (listp groups)
- (setq groups (list groups)))
+ (setq groups (ensure-list groups))
;; remove the current process mark
(gnus-summary-kill-process-mark)
diff --git a/lisp/help-fns.el b/lisp/help-fns.el
index 46107daf639..a291893e9a2 100644
--- a/lisp/help-fns.el
+++ b/lisp/help-fns.el
@@ -152,6 +152,17 @@ edited even if this option is enabled."
:group 'help
:version "28.1")
+(defcustom help-display-function-type t
+ "Whether to display type specifiers of functions in \"*Help*\" buffers.
+
+The type specifier of a function is returned by `comp-function-type-spec',
+which see. When this variable is non-nil, \\[describe-function] will \
+display the function's
+type specifier when available."
+ :type 'boolean
+ :group 'help
+ :version "30.1")
+
(defun help--symbol-class (s)
"Return symbol class characters for symbol S."
(when (stringp s)
@@ -229,11 +240,11 @@ interactive command."
(lambda (f) (if want-command
(commandp f)
(or (fboundp f) (get f 'function-documentation))))
- ;; We use 'confirm' here, unlike in other describe-*
- ;; commands, for cases like a function that is advised
- ;; but not yet defined (e.g., if 'advice-add' is called
- ;; before defining the function).
- 'confirm nil nil
+ ;; We used `confirm' for a while because we may want to see the
+ ;; meta-info about a function even if the function itself is not
+ ;; defined, but this use case is too marginal and rarely tested,
+ ;; not worth the trouble (bug#64902).
+ t nil nil
(and fn (symbol-name fn)))))
(unless (equal val "")
(setq fn (intern val)))
@@ -358,7 +369,8 @@ if the variable `help-downcase-arguments' is non-nil."
(setq doc (replace-regexp-in-string
;; This is heuristic, but covers all common cases
;; except ARG1-ARG2
- (concat "\\<" ; beginning of word
+ (concat "([^ ]+ .*" ; skip function name
+ "\\<" ; beginning of word
"\\(?:[a-z-]*-\\)?" ; for xxx-ARG
"\\("
(regexp-quote arg)
@@ -714,23 +726,43 @@ the C sources, too."
(high-doc (cdr high)))
(unless (and (symbolp function)
(get function 'reader-construct))
- (insert high-usage "\n"))
+ (insert high-usage "\n")
+ (when-let* ((gate help-display-function-type)
+ (res (comp-function-type-spec function))
+ (type-spec (car res))
+ (kind (cdr res)))
+ (insert (format
+ (if (eq kind 'inferred)
+ "\nInferred type: %s\n"
+ "\nType: %s\n")
+ type-spec))))
(fill-region fill-begin (point))
high-doc)))))
(defun help-fns--parent-mode (function)
;; If this is a derived mode, link to the parent.
- (let ((parent-mode (and (symbolp function)
- (get function
- 'derived-mode-parent))))
+ (when (symbolp function)
+ (let ((parent-mode (get function 'derived-mode-parent))
+ (extra-parents (get function 'derived-mode-extra-parents)))
(when parent-mode
(insert (substitute-quotes " Parent mode: `"))
(let ((beg (point)))
- (insert (format "%s" parent-mode))
+ (insert (format "%S" parent-mode))
(make-text-button beg (point)
'type 'help-function
'help-args (list parent-mode)))
- (insert (substitute-quotes "'.\n")))))
+ (insert (substitute-quotes "'.\n")))
+ (when extra-parents
+ (insert (format " Extra parent mode%s:" (if (cdr extra-parents) "s" "")))
+ (dolist (parent extra-parents)
+ (insert (substitute-quotes " `"))
+ (let ((beg (point)))
+ (insert (format "%S" parent))
+ (make-text-button beg (point)
+ 'type 'help-function
+ 'help-args (list parent)))
+ (insert (substitute-quotes "'")))
+ (insert ".\n")))))
(defun help-fns--obsolete (function)
;; Ignore lambda constructs, keyboard macros, etc.
@@ -746,7 +778,7 @@ the C sources, too."
" is obsolete")
(when (nth 2 obsolete)
(insert (format " since %s" (nth 2 obsolete))))
- (insert (cond ((stringp use) (concat "; " use))
+ (insert (cond ((stringp use) (concat "; " (substitute-quotes use)))
(use (format-message "; use `%s' instead." use))
(t "."))
"\n")
@@ -772,7 +804,7 @@ the C sources, too."
(and (symbolp function)
(not (eq (car-safe (symbol-function function)) 'macro))
(let* ((interactive-only
- (or (get function 'interactive-only)
+ (or (function-get function 'interactive-only)
(if (boundp 'byte-compile-interactive-only-functions)
(memq function
byte-compile-interactive-only-functions)))))
@@ -781,7 +813,7 @@ the C sources, too."
;; Cf byte-compile-form.
(cond ((stringp interactive-only)
(format ";\n in Lisp code %s" interactive-only))
- ((and (symbolp 'interactive-only)
+ ((and (symbolp interactive-only)
(not (eq interactive-only t)))
(format-message ";\n in Lisp code use `%s' instead."
interactive-only))
@@ -999,7 +1031,7 @@ Returns a list of the form (REAL-FUNCTION DEF ALIASED REAL-DEF)."
(symbol-name function)))))))
(real-def (cond
((and aliased (not (subrp def)))
- (or (car (function-alias-p real-function t))
+ (or (car (function-alias-p real-function))
real-function))
((subrp def) (intern (subr-name def)))
(t def))))
@@ -1029,10 +1061,10 @@ Returns a list of the form (REAL-FUNCTION DEF ALIASED REAL-DEF)."
(concat
"an autoloaded " (if (commandp def)
"interactive "))
- (if (commandp def) "an interactive " "a "))))
-
- ;; Print what kind of function-like object FUNCTION is.
- (princ (cond ((or (stringp def) (vectorp def))
+ (if (commandp def) "an interactive " "a ")))
+ ;; Print what kind of function-like object FUNCTION is.
+ (description
+ (cond ((or (stringp def) (vectorp def))
"a keyboard macro")
((and (symbolp function)
(get function 'reader-construct))
@@ -1041,12 +1073,6 @@ Returns a list of the form (REAL-FUNCTION DEF ALIASED REAL-DEF)."
;; aliases before functions.
(aliased
(format-message "an alias for `%s'" real-def))
- ((subr-native-elisp-p def)
- (concat beg "native-compiled Lisp function"))
- ((subrp def)
- (concat beg (if (eq 'unevalled (cdr (subr-arity def)))
- "special form"
- "built-in function")))
((autoloadp def)
(format "an autoloaded %s"
(cond
@@ -1060,14 +1086,13 @@ Returns a list of the form (REAL-FUNCTION DEF ALIASED REAL-DEF)."
;; need to check macros before functions.
(macrop function))
(concat beg "Lisp macro"))
- ((byte-code-function-p def)
- (concat beg "byte-compiled Lisp function"))
- ((module-function-p def)
- (concat beg "module function"))
- ((eq (car-safe def) 'lambda)
- (concat beg "Lisp function"))
- ((eq (car-safe def) 'closure)
- (concat beg "Lisp closure"))
+ ((atom def)
+ (let ((type (or (oclosure-type def) (cl-type-of def))))
+ (concat beg (format "%s"
+ (make-text-button
+ (symbol-name type) nil
+ 'type 'help-type
+ 'help-args (list type))))))
((keymapp def)
(let ((is-full nil)
(elts (cdr-safe def)))
@@ -1077,7 +1102,9 @@ Returns a list of the form (REAL-FUNCTION DEF ALIASED REAL-DEF)."
elts nil))
(setq elts (cdr-safe elts)))
(concat beg (if is-full "keymap" "sparse keymap"))))
- (t "")))
+ (t ""))))
+ (with-current-buffer standard-output
+ (insert description))
(if (and aliased (not (fboundp real-def)))
(princ ",\nwhich is not defined.")
@@ -1142,7 +1169,7 @@ Returns a list of the form (REAL-FUNCTION DEF ALIASED REAL-DEF)."
;; key substitution constructs, load the library.
(and (autoloadp real-def) doc-raw
help-enable-autoload
- (string-match "\\([^\\]=\\|[^=]\\|\\`\\)\\\\[[{<]" doc-raw)
+ (string-match "\\([^\\]=\\|[^=]\\|\\`\\)\\\\[[{<]\\|`.*'" doc-raw)
(autoload-do-load real-def))
(help-fns--key-bindings function)
@@ -1731,8 +1758,7 @@ If FRAME is omitted or nil, use the selected frame."
(called-interactively-p 'interactive))
(unless face
(setq face 'default))
- (if (not (listp face))
- (setq face (list face)))
+ (setq face (ensure-list face))
(with-help-window (help-buffer)
(with-current-buffer standard-output
(dolist (f face (buffer-string))
@@ -1770,9 +1796,8 @@ If FRAME is omitted or nil, use the selected frame."
alias)
""))))
(insert "\nDocumentation:\n"
- (substitute-command-keys
- (or (face-documentation face)
- "Not documented as a face."))
+ (or (face-documentation face)
+ "Not documented as a face.")
"\n\n"))
(with-current-buffer standard-output
(save-excursion
@@ -2008,8 +2033,8 @@ variable with value KEYMAP."
(mapatoms (lambda (symb)
(when (and (boundp symb)
(eq (symbol-value symb) keymap)
- (not (eq symb 'keymap))
- (throw 'found-keymap symb)))))
+ (not (eq symb 'keymap)))
+ (throw 'found-keymap symb))))
nil)))
;; Follow aliasing.
(or (ignore-errors (indirect-variable name)) name))))
@@ -2063,11 +2088,9 @@ keymap value."
(if (symbolp keymap)
(error "Not a keymap variable: %S" keymap)
(error "Not a keymap")))
- (let ((sym nil))
- (unless sym
- (setq sym (cl-gentemp "KEYMAP OBJECT (no variable) "))
- (setq used-gentemp t)
- (set sym keymap))
+ (let ((sym (cl-gentemp "KEYMAP OBJECT (no variable) ")))
+ (setq used-gentemp t)
+ (set sym keymap)
(setq keymap sym)))
;; Follow aliasing.
(setq keymap (or (ignore-errors (indirect-variable keymap)) keymap))
@@ -2107,6 +2130,12 @@ keymap value."
(when used-gentemp
(makunbound keymap))))
+(defcustom describe-mode-outline t
+ "Non-nil enables outlines in the output buffer of `describe-mode'."
+ :type 'boolean
+ :group 'help
+ :version "30.1")
+
;;;###autoload
(defun describe-mode (&optional buffer)
"Display documentation of current major mode and minor modes.
@@ -2119,7 +2148,10 @@ variable \(listed in `minor-mode-alist') must also be a function
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."
+documentation for the major and minor modes of that buffer.
+
+When `describe-mode-outline' is non-nil, Outline minor mode
+is enabled in the Help buffer."
(interactive "@")
(unless buffer
(setq buffer (current-buffer)))
@@ -2133,13 +2165,20 @@ documentation for the major and minor modes of that buffer."
(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" "")))
+ (unless describe-mode-outline
+ (insert (format "Minor mode%s enabled in this buffer:"
+ (if (length> local-minors 1)
+ "s" ""))))
(describe-mode--minor-modes local-minors))
;; Document the major mode.
(let ((major (buffer-local-value 'major-mode buffer)))
+ (when describe-mode-outline
+ (goto-char (point-min))
+ (put-text-property
+ (point) (progn (insert (format "Major mode %S" major)) (point))
+ 'outline-level 1)
+ (insert "\n\n"))
(insert "The major mode is "
(buttonize
(propertize (format-mode-line
@@ -2163,36 +2202,56 @@ documentation for the major and minor modes of that buffer."
;; 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)))
+ (unless describe-mode-outline
+ (insert (format "Global minor mode%s enabled:"
+ (if (length> global-minor-modes 1)
+ "s" ""))))
+ (describe-mode--minor-modes global-minor-modes t)
+ (unless describe-mode-outline
+ (when (re-search-forward "^\f")
+ (beginning-of-line)
+ (ensure-empty-lines 1))))
+
+ (when describe-mode-outline
+ (setq-local outline-search-function #'outline-search-level)
+ (setq-local outline-level (lambda () 1))
+ (setq-local outline-minor-mode-cycle t
+ outline-minor-mode-highlight t
+ outline-minor-mode-use-buttons 'insert)
+ (outline-minor-mode 1))
+
;; For the sake of IELM and maybe others
nil)))))
-(defun describe-mode--minor-modes (modes)
+(defun describe-mode--minor-modes (modes &optional global)
(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))
+ (if (not describe-mode-outline)
+ (insert
+ " "
+ (buttonize
+ pretty-minor-mode
+ (lambda (mode)
+ (goto-char (point-min))
+ (text-property-search-forward
+ 'help-minor-mode mode t)
+ (beginning-of-line))
+ mode))
+ (goto-char (point-max))
+ (put-text-property
+ (point) (progn (insert (if global "Global" "Local")
+ (format " minor mode %S" mode))
+ (point))
+ 'outline-level 1)
+ (insert "\n\n"))
(save-excursion
- (goto-char (point-max))
- (insert "\n\n\f\n")
+ (unless describe-mode-outline
+ (goto-char (point-max))
+ (insert "\n\n\f\n"))
;; Document the minor modes fully.
(insert (buttonize
(propertize pretty-minor-mode 'help-minor-mode mode)
@@ -2206,11 +2265,14 @@ documentation for the major and minor modes of that buffer."
(format "indicator%s"
indicator)))))
(insert (or (help-split-fundoc (documentation mode) nil 'doc)
- "No docstring")))))
- (forward-line -1)
- (fill-paragraph nil)
- (forward-paragraph 1)
- (ensure-empty-lines 1))
+ "No docstring"))
+ (when describe-mode-outline
+ (insert "\n\n")))))
+ (unless describe-mode-outline
+ (forward-line -1)
+ (fill-paragraph nil)
+ (forward-paragraph 1)
+ (ensure-empty-lines 1)))
(defun help-fns--list-local-commands ()
(let ((functions nil))
@@ -2223,7 +2285,7 @@ documentation for the major and minor modes of that buffer."
(not (get sym 'byte-obsolete-info))
;; Ignore everything bound.
(not (where-is-internal sym nil t))
- (apply #'derived-mode-p (command-modes sym)))
+ (derived-mode-p (command-modes sym)))
(push sym functions))))
(with-temp-buffer
(when functions
@@ -2383,6 +2445,81 @@ one of them returns non-nil."
(setq buffer-undo-list nil)
(texinfo-mode)))
+(defconst help-fns--function-numbers
+ (make-hash-table :test 'equal :weakness 'value))
+(defconst help-fns--function-names (make-hash-table :weakness 'key))
+
+(defun help-fns--display-function (function)
+ (cond
+ ((subr-primitive-p function)
+ (describe-function function))
+ ((and (compiled-function-p function)
+ (not (and (fboundp 'kmacro-p) (kmacro-p function))))
+ (disassemble function))
+ (t
+ ;; FIXME: Use cl-print!
+ (pp-display-expression function "*Help Source*" (consp function)))))
+
+;;;###autoload
+(defun help-fns-function-name (function)
+ "Return a short buttonized string representing FUNCTION.
+The string is propertized with a button; clicking on that
+provides further details about FUNCTION.
+FUNCTION can be a function, a built-in, a keyboard macro,
+or a compile function.
+This function is intended to be used to display various
+callable symbols in buffers in a way that allows the user
+to find out more details about the symbols."
+ ;; FIXME: For kmacros, should we print the key-sequence?
+ (cond
+ ((symbolp function)
+ (let ((name (if (eq (intern-soft (symbol-name function)) function)
+ (symbol-name function)
+ (concat "#:" (symbol-name function)))))
+ (if (not (fboundp function))
+ name
+ (make-text-button name nil
+ 'type 'help-function
+ 'help-args (list function)))))
+ ((gethash function help-fns--function-names))
+ ((subrp function)
+ (let ((name (subr-name function)))
+ ;; FIXME: For native-elisp-functions, should we use `help-function'
+ ;; or `disassemble'?
+ (format "#<%s %s>"
+ (cl-type-of function)
+ (make-text-button name nil
+ 'type 'help-function
+ ;; Let's hope the subr hasn't been redefined!
+ 'help-args (list (intern name))))))
+ (t
+ (let ((type (or (oclosure-type function)
+ (if (consp function)
+ (car function) (cl-type-of function))))
+ (hash (sxhash-eq function))
+ ;; Use 3 digits minimum.
+ (mask #xfff)
+ name)
+ (while
+ (let* ((hex (format (concat "%0"
+ (number-to-string (1+ (/ (logb mask) 4)))
+ "X")
+ (logand mask hash)))
+ ;; FIXME: For kmacros, we don't want to `disassemble'!
+ (button (buttonize
+ hex #'help-fns--display-function function
+ ;; FIXME: Shouldn't `buttonize' add
+ ;; the "mouse-2, RET:" prefix?
+ "mouse-2, RET: Display the function's body")))
+ (setq name (format "#<%s %s>" type button))
+ (and (< mask (abs hash)) ; We can add more digits.
+ (gethash name help-fns--function-numbers)))
+ ;; Add a digit.
+ (setq mask (+ (ash mask 4) #x0f)))
+ (puthash name function help-fns--function-numbers)
+ (puthash function name help-fns--function-names)
+ name))))
+
(provide 'help-fns)
;;; help-fns.el ends here
diff --git a/lisp/help-macro.el b/lisp/help-macro.el
index 14d2a45f5f2..8a16e85a329 100644
--- a/lisp/help-macro.el
+++ b/lisp/help-macro.el
@@ -92,134 +92,146 @@ and then returns."
`(defun ,fname ()
"Help command."
(interactive)
- (let ((line-prompt
- (substitute-command-keys ,help-line))
- (help-buffer-under-preparation t))
- (when three-step-help
- (message "%s" line-prompt))
- (let* ((help-screen ,help-text)
- ;; We bind overriding-local-map for very small
- ;; sections, *excluding* where we switch buffers
- ;; and where we execute the chosen help command.
- (local-map (make-sparse-keymap))
- (new-minor-mode-map-alist minor-mode-map-alist)
- (prev-frame (selected-frame))
- config new-frame key char)
- (when (string-match "%THIS-KEY%" help-screen)
- (setq help-screen
- (replace-match (help--key-description-fontified
- (substring (this-command-keys) 0 -1))
- t t help-screen)))
- (unwind-protect
- (let ((minor-mode-map-alist nil))
- (setcdr local-map ,helped-map)
- (define-key local-map [t] 'undefined)
- ;; Make the scroll bar keep working normally.
- (define-key local-map [vertical-scroll-bar]
- (lookup-key global-map [vertical-scroll-bar]))
- (if three-step-help
- (progn
- (setq key (let ((overriding-local-map local-map))
- (read-key-sequence nil)))
- ;; Make the HELP key translate to C-h.
- (if (lookup-key function-key-map key)
- (setq key (lookup-key function-key-map key)))
- (setq char (aref key 0)))
- (setq char ??))
- (when (or (eq char ??) (eq char help-char)
- (memq char help-event-list))
- (setq config (current-window-configuration))
- (pop-to-buffer (or ,buffer-name " *Metahelp*") nil t)
- (and (fboundp 'make-frame)
- (not (eq (window-frame)
- prev-frame))
- (setq new-frame (window-frame)
- config nil))
- (setq buffer-read-only nil)
- (let ((inhibit-read-only t))
- (erase-buffer)
- (insert (substitute-command-keys help-screen)))
- (let ((minor-mode-map-alist new-minor-mode-map-alist))
- (help-mode)
- (variable-pitch-mode)
- (setq new-minor-mode-map-alist minor-mode-map-alist))
- (goto-char (point-min))
- (while (or (memq char (append help-event-list
- (cons help-char '( ?? ?\C-v ?\s ?\177 ?\M-v ?\S-\s
- deletechar backspace vertical-scroll-bar
- home end next prior up down))))
- (eq (car-safe char) 'switch-frame)
- (equal key "\M-v"))
- (condition-case nil
- (cond
- ((eq (car-safe char) 'switch-frame)
- (handle-switch-frame char))
- ((memq char '(?\C-v ?\s next end))
- (scroll-up))
- ((or (memq char '(?\177 ?\M-v ?\S-\s deletechar backspace prior home))
- (equal key "\M-v"))
- (scroll-down))
- ((memq char '(down))
- (scroll-up 1))
- ((memq char '(up))
- (scroll-down 1)))
- (error nil))
- (let ((cursor-in-echo-area t)
- (overriding-local-map local-map))
- (setq key (read-key-sequence
- (format "Type one of listed options%s: "
- (if (pos-visible-in-window-p
- (point-max))
- ""
- (concat ", or "
- (help--key-description-fontified (kbd "<PageDown>"))
- "/"
- (help--key-description-fontified (kbd "<PageUp>"))
- "/"
- (help--key-description-fontified (kbd "SPC"))
- "/"
- (help--key-description-fontified (kbd "DEL"))
- " to scroll"))))
- char (aref key 0)))
-
- ;; If this is a scroll bar command, just run it.
- (when (eq char 'vertical-scroll-bar)
- (command-execute (lookup-key local-map key) nil key))))
- ;; We don't need the prompt any more.
- (message "")
- ;; Mouse clicks are not part of the help feature,
- ;; so reexecute them in the standard environment.
- (if (listp char)
- (setq unread-command-events
- (cons char unread-command-events)
- config nil)
- (let ((defn (lookup-key local-map key)))
- (if defn
- (progn
- (when config
- (set-window-configuration config)
- (setq config nil))
- ;; Temporarily rebind `minor-mode-map-alist'
- ;; to `new-minor-mode-map-alist' (Bug#10454).
- (let ((minor-mode-map-alist new-minor-mode-map-alist))
- ;; `defn' must make sure that its frame is
- ;; selected, so we won't iconify it below.
- (call-interactively defn))
- (when new-frame
- ;; Do not iconify the selected frame.
- (unless (eq new-frame (selected-frame))
- (iconify-frame new-frame))
- (setq new-frame nil)))
- (unless (equal (key-description key) "C-g")
- (message (substitute-command-keys
- (format "No help command is bound to `\\`%s''"
- (key-description key))))
- (ding))))))
- (when config
- (set-window-configuration config))
- (when new-frame
- (iconify-frame new-frame))
- (setq minor-mode-map-alist new-minor-mode-map-alist))))))
+ (help--help-screen ,help-line ,help-text ,helped-map ,buffer-name)))
+
+
+;;;###autoload
+(defun help--help-screen (help-line help-text helped-map buffer-name)
+ (let ((line-prompt
+ (substitute-command-keys help-line))
+ (help-buffer-under-preparation t))
+ (when three-step-help
+ (message "%s" line-prompt))
+ (let* ((help-screen help-text)
+ ;; We bind overriding-local-map for very small
+ ;; sections, *excluding* where we switch buffers
+ ;; and where we execute the chosen help command.
+ (local-map (make-sparse-keymap))
+ (new-minor-mode-map-alist minor-mode-map-alist)
+ (prev-frame (selected-frame))
+ config new-frame key char)
+ (when (string-match "%THIS-KEY%" help-screen)
+ (setq help-screen
+ (replace-match (help--key-description-fontified
+ (substring (this-command-keys) 0 -1))
+ t t help-screen)))
+ (unwind-protect
+ (let ((minor-mode-map-alist nil))
+ (setcdr local-map helped-map)
+ (define-key local-map [t] #'undefined)
+ ;; Make the scroll bar keep working normally.
+ (define-key local-map [vertical-scroll-bar]
+ (lookup-key global-map [vertical-scroll-bar]))
+ (if three-step-help
+ (progn
+ (setq key (let ((overriding-local-map local-map))
+ (read-key-sequence nil)))
+ ;; Make the HELP key translate to C-h.
+ (if (lookup-key function-key-map key)
+ (setq key (lookup-key function-key-map key)))
+ (setq char (aref key 0)))
+ (setq char ??))
+ (when (or (eq char ??) (eq char help-char)
+ (memq char help-event-list))
+ (setq config (current-window-configuration))
+ (pop-to-buffer (or buffer-name " *Metahelp*") nil t)
+ (and (fboundp 'make-frame)
+ (not (eq (window-frame)
+ prev-frame))
+ (setq new-frame (window-frame)
+ config nil))
+ (setq buffer-read-only nil)
+ (let ((inhibit-read-only t))
+ (erase-buffer)
+ (insert (substitute-command-keys help-screen)))
+ (let ((minor-mode-map-alist new-minor-mode-map-alist))
+ (help-mode)
+ (variable-pitch-mode)
+ (setq new-minor-mode-map-alist minor-mode-map-alist))
+ (goto-char (point-min))
+ (while (or (memq char (append help-event-list
+ (cons help-char '( ?? ?\C-v ?\s ?\177 ?\M-v ?\S-\s
+ deletechar backspace vertical-scroll-bar
+ home end next prior up down))))
+ (eq (car-safe char) 'switch-frame)
+ (equal key "\M-v"))
+ (condition-case nil
+ (cond
+ ((eq (car-safe char) 'switch-frame)
+ (handle-switch-frame char))
+ ((memq char '(?\C-v ?\s next end))
+ (scroll-up))
+ ((or (memq char '(?\177 ?\M-v ?\S-\s deletechar backspace prior home))
+ (equal key "\M-v"))
+ (scroll-down))
+ ((memq char '(down))
+ (scroll-up 1))
+ ((memq char '(up))
+ (scroll-down 1)))
+ (error nil))
+ (let ((cursor-in-echo-area t)
+ (overriding-local-map local-map))
+ (frame-toggle-on-screen-keyboard (selected-frame) nil)
+ (setq key (read-key-sequence
+ (format "Type one of listed options%s: "
+ (if (pos-visible-in-window-p
+ (point-max))
+ ""
+ (concat ", or "
+ (help--key-description-fontified (kbd "<PageDown>"))
+ "/"
+ (help--key-description-fontified (kbd "<PageUp>"))
+ "/"
+ (help--key-description-fontified (kbd "SPC"))
+ "/"
+ (help--key-description-fontified (kbd "DEL"))
+ " to scroll")))
+ nil nil nil nil
+ ;; Disable ``text conversion''. OS
+ ;; input methods might otherwise chose
+ ;; to insert user input directly into
+ ;; a buffer.
+ t)
+ char (aref key 0)))
+
+ ;; If this is a scroll bar command, just run it.
+ (when (eq char 'vertical-scroll-bar)
+ (command-execute (lookup-key local-map key) nil key))))
+ ;; We don't need the prompt any more.
+ (message "")
+ ;; Mouse clicks are not part of the help feature,
+ ;; so reexecute them in the standard environment.
+ (if (listp char)
+ (setq unread-command-events
+ (cons char unread-command-events)
+ config nil)
+ (let ((defn (lookup-key local-map key)))
+ (if defn
+ (progn
+ (when config
+ (set-window-configuration config)
+ (setq config nil))
+ ;; Temporarily rebind `minor-mode-map-alist'
+ ;; to `new-minor-mode-map-alist' (Bug#10454).
+ (let ((minor-mode-map-alist new-minor-mode-map-alist))
+ ;; `defn' must make sure that its frame is
+ ;; selected, so we won't iconify it below.
+ (call-interactively defn))
+ (when new-frame
+ ;; Do not iconify the selected frame.
+ (unless (eq new-frame (selected-frame))
+ (iconify-frame new-frame))
+ (setq new-frame nil)))
+ (unless (equal (key-description key) "C-g")
+ (message (substitute-command-keys
+ (format "No help command is bound to `\\`%s''"
+ (key-description key))))
+ (ding))))))
+ (when config
+ (set-window-configuration config))
+ (when new-frame
+ (iconify-frame new-frame))
+ (setq minor-mode-map-alist new-minor-mode-map-alist)))))
(provide 'help-macro)
diff --git a/lisp/help-mode.el b/lisp/help-mode.el
index 624b855f2c7..48433d899ab 100644
--- a/lisp/help-mode.el
+++ b/lisp/help-mode.el
@@ -177,6 +177,11 @@ The format is (FUNCTION ARGS...).")
'help-function 'describe-variable
'help-echo (purecopy "mouse-2, RET: describe this variable"))
+(define-button-type 'help-type
+ :supertype 'help-xref
+ 'help-function #'cl-describe-type
+ 'help-echo (purecopy "mouse-2, RET: describe this type"))
+
(define-button-type 'help-face
:supertype 'help-xref
'help-function 'describe-face
@@ -498,6 +503,20 @@ This should be called very early, before the output buffer is cleared,
because we want to record the \"previous\" position of point so we can
restore it properly when going back."
(with-current-buffer (help-buffer)
+ ;; Disable `outline-minor-mode' in a reused Help buffer
+ ;; created by `describe-bindings' that enables this mode.
+ (when (bound-and-true-p outline-minor-mode)
+ (outline-minor-mode -1)
+ (mapc #'kill-local-variable
+ '(outline-search-function
+ outline-regexp
+ outline-heading-end-regexp
+ outline-level
+ outline-minor-mode-cycle
+ outline-minor-mode-highlight
+ outline-minor-mode-use-buttons
+ outline-default-state
+ outline-default-rules)))
(when help-xref-stack-item
(push (cons (point) help-xref-stack-item) help-xref-stack)
(setq help-xref-forward-stack nil))
@@ -531,6 +550,9 @@ it does not already exist."
(or (and (boundp symbol) (not (keywordp symbol)))
(get symbol 'variable-documentation)))
,#'describe-variable)
+ ;; FIXME: We could go crazy and add another entry so describe-symbol can be
+ ;; used with the slot names of CL structs (and/or EIEIO objects).
+ ("type" ,#'cl-find-class ,#'cl-describe-type)
("face" ,#'facep ,(lambda (s _b _f) (describe-face s))))
"List of providers of information about symbols.
Each element has the form (NAME TESTFUN DESCFUN) where:
diff --git a/lisp/help.el b/lisp/help.el
index 24e4b9890a7..1ef46e394f3 100644
--- a/lisp/help.el
+++ b/lisp/help.el
@@ -203,7 +203,7 @@ the documentation of the command bound to that key sequence."
max-key-len (max (length key) max-key-len))
(push (list key (cdr ent) (car ent)) keys))))
(when keys
- (let ((fmt (format "%%-%ds %%-%ds%s" max-key-len max-cmd-len
+ (let ((fmt (format "%%s %%-%ds%s" max-cmd-len
(make-string padding ?\s)))
(width (+ max-key-len 1 max-cmd-len padding)))
(push `(,width
@@ -214,10 +214,12 @@ the documentation of the command bound to that key sequence."
'face 'bold)
,@(mapcar (lambda (ent)
(format fmt
- (propertize
- (car ent)
- 'quick-help-cmd
- (caddr ent))
+ (concat
+ (propertize
+ (car ent)
+ 'quick-help-cmd
+ (caddr ent))
+ (make-string (- max-key-len (length (car ent))) ?\s))
(cadr ent)))
keys))
blocks)))))
@@ -299,6 +301,8 @@ Do not call this in the scope of `with-help-window'."
(let ((first-message
(cond ((or
pop-up-frames
+ ;; FIXME: `special-display-p' is obsolete since
+ ;; the vars on which it depends are obsolete!
(special-display-p (buffer-name standard-output)))
(setq help-return-method (cons (selected-window) t))
;; If the help output buffer is a special display buffer,
@@ -380,9 +384,9 @@ Do not call this in the scope of `with-help-window'."
(propertize title 'face 'help-for-help-header)
"\n\n"
(help--for-help-make-commands commands))))
- sections ""))
+ sections))
-(defalias 'help 'help-for-help)
+(defalias 'help #'help-for-help)
(make-help-screen help-for-help
(purecopy "Type a help option: [abcCdefFgiIkKlLmnprstvw.] C-[cdefmnoptw] or ?")
(concat
@@ -742,6 +746,21 @@ Return nil if KEYS is nil."
:group 'help
:version "29.1")
+(defcustom describe-bindings-outline-rules '((match-regexp . "Key translations"))
+ "Visibility rules for outline sections of `describe-bindings'.
+This is used as the value of `outline-default-rules' in the
+output buffer of `describe-bindings' when
+`describe-bindings-outline' is non-nil, otherwise this option
+doesn't have any effect."
+ :type '(choice (const :tag "Hide unconditionally" nil)
+ (set :tag "Show section unless"
+ (cons :tag "Heading matches regexp"
+ (const match-regexp) string)
+ (cons :tag "Custom function to show/hide sections"
+ (const custom-function) function)))
+ :group 'help
+ :version "30.1")
+
(declare-function outline-hide-subtree "outline")
(defun describe-bindings (&optional prefix buffer)
@@ -771,8 +790,7 @@ or a buffer name."
outline-minor-mode-use-buttons 'insert
;; Hide the longest body.
outline-default-state 1
- outline-default-rules
- '((match-regexp . "Key translations")))
+ outline-default-rules describe-bindings-outline-rules)
(outline-minor-mode 1)
(save-excursion
(goto-char (point-min))
@@ -860,7 +878,7 @@ If INSERT (the prefix arg) is non-nil, insert the message in the buffer."
(format "%s (translated from %s)" string otherstring))))))
(defun help--binding-undefined-p (defn)
- (or (null defn) (integerp defn) (equal defn 'undefined)))
+ (or (null defn) (integerp defn) (equal defn #'undefined)))
(defun help--analyze-key (key untranslated &optional buffer)
"Get information about KEY its corresponding UNTRANSLATED events.
@@ -908,7 +926,9 @@ in the selected window."
(let ((key-desc (help-key-description key untranslated)))
(if (help--binding-undefined-p defn)
(format "%s%s is undefined" key-desc mouse-msg)
- (format "%s%s runs the command %S" key-desc mouse-msg defn)))
+ (format "%s%s runs the command %s" key-desc mouse-msg
+ (if (symbolp defn) (prin1-to-string defn)
+ (help-fns-function-name defn)))))
defn event mouse-msg)))
(defun help--filter-info-list (info-list i)
@@ -1205,7 +1225,7 @@ appeared on the mode-line."
(defun describe-minor-mode-completion-table-for-symbol ()
;; In order to list up all minor modes, minor-mode-list
;; is used here instead of minor-mode-alist.
- (delq nil (mapcar 'symbol-name minor-mode-list)))
+ (delq nil (mapcar #'symbol-name minor-mode-list)))
(defun describe-minor-mode-from-symbol (symbol)
"Display documentation of a minor mode given as a symbol, SYMBOL."
@@ -1231,15 +1251,60 @@ appeared on the mode-line."
i))))
minor-mode-alist)))
-(defun describe-minor-mode-from-indicator (indicator)
+(defun describe-minor-mode-from-indicator (indicator &optional event)
"Display documentation of a minor mode specified by INDICATOR.
If you call this function interactively, you can give indicator which
-is currently activated with completion."
+is currently activated with completion.
+
+If non-nil, EVENT is a mouse event used to establish which minor
+mode lighter was clicked."
(interactive (list
(completing-read
"Minor mode indicator: "
(describe-minor-mode-completion-table-for-indicator))))
- (let ((minor-mode (lookup-minor-mode-from-indicator indicator)))
+ (when (and event mode-line-compact)
+ (let* ((event-start (event-start event))
+ (window (posn-window event-start)))
+ ;; If INDICATOR is a string object, WINDOW is set, and
+ ;; `mode-line-compact' might be enabled, find a string in
+ ;; `minor-mode-alist' that is present within the INDICATOR and
+ ;; whose extents within INDICATOR contain the position of the
+ ;; object within the string.
+ (when (windowp window)
+ (setq indicator (posn-object event-start))
+ (catch 'found
+ (with-selected-window window
+ (let ((alist minor-mode-alist) string position)
+ (when (consp indicator)
+ (with-temp-buffer
+ (insert (car indicator))
+ (dolist (menu alist)
+ ;; If this is a valid minor mode menu entry,
+ (when (and (consp menu)
+ (setq string (format-mode-line (cadr menu)
+ nil window))
+ (> (length string) 0))
+ ;; Start searching for an appearance of (cdr
+ ;; menu).
+ (goto-char (point-min))
+ (while (search-forward string nil 0)
+ ;; If the position of the string object is
+ ;; contained within, set indicator to the
+ ;; minor mode in question.
+ (setq position (1+ (cdr indicator)))
+ (and (>= position (match-beginning 0))
+ (<= position (match-end 0))
+ (setq indicator (car menu))
+ (throw 'found nil)))))))))))))
+ ;; If INDICATOR is still a cons, use its car.
+ (when (consp indicator)
+ (setq indicator (car indicator)))
+ (let ((minor-mode (if (symbolp indicator)
+ ;; indicator being set to a symbol means that
+ ;; the loop above has already found a
+ ;; matching minor mode.
+ indicator
+ (lookup-minor-mode-from-indicator indicator))))
(if minor-mode
(describe-minor-mode-from-symbol minor-mode)
(error "Cannot find minor mode for `%s'" indicator))))
@@ -1424,7 +1489,7 @@ Otherwise, return a new string."
;; in case it is a local variable.
(with-current-buffer orig-buf
;; This is for computing the SHADOWS arg for
- ;; describe-map-tree.
+ ;; help--describe-map-tree.
(setq active-maps (current-active-maps))
(when (boundp name)
(setq this-keymap (and (keymapp (symbol-value name))
@@ -1445,9 +1510,10 @@ Otherwise, return a new string."
;; If this one's not active, get nil.
(let ((earlier-maps
(cdr (memq this-keymap (reverse active-maps)))))
- (describe-map-tree this-keymap t (nreverse earlier-maps)
- nil nil (not include-menus)
- nil nil t))))))))
+ (help--describe-map-tree this-keymap t
+ (nreverse earlier-maps)
+ nil nil (not include-menus)
+ nil nil t))))))))
;; 2. Handle quotes.
((and (eq (text-quoting-style) 'curve)
(or (and (= (following-char) ?\`)
@@ -1477,9 +1543,9 @@ quote characters to use is determined by the variable
(t string)))
(defvar help--keymaps-seen nil)
-(defun describe-map-tree (startmap &optional partial shadow prefix title
- no-menu transl always-title mention-shadow
- buffer)
+(defun help--describe-map-tree (startmap &optional partial shadow prefix title
+ 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.
@@ -1582,34 +1648,14 @@ Return nil if the key sequence is too long."
(t value))))
(defun help--describe-command (definition &optional translation)
- (cond ((symbolp definition)
- (if (and (fboundp definition)
- help-buffer-under-preparation)
- (insert-text-button (symbol-name definition)
- 'type 'help-function
- 'help-args (list definition))
- (insert (symbol-name definition)))
- (insert "\n"))
- ((or (stringp definition) (vectorp definition))
+ (cond ((or (stringp definition) (vectorp definition))
(if translation
(insert (key-description definition nil) "\n")
+ ;; These should be rare nowadays, replaced by `kmacro's.
(insert "Keyboard Macro\n")))
((keymapp definition)
(insert "Prefix Command\n"))
- ((byte-code-function-p definition)
- (insert (format "[%s]\n"
- (buttonize "byte-code" #'disassemble definition))))
- ((and (consp definition)
- (memq (car definition) '(closure lambda)))
- (insert (format "[%s]\n"
- (buttonize
- (symbol-name (car definition))
- (lambda (_)
- (pp-display-expression
- definition "*Help Source*" t))
- nil "View definition"))))
- (t
- (insert "??\n"))))
+ (t (insert (help-fns-function-name definition) "\n"))))
(define-obsolete-function-alias 'help--describe-translation
#'help--describe-command "29.1")
@@ -1633,7 +1679,7 @@ Assume that this keymap itself is reached by the sequence of
prefix keys PREFIX (a string or vector).
TRANSL, PARTIAL, SHADOW, NOMENU, MENTION-SHADOW and BUFFER are as
-in `describe-map-tree'."
+in `help--describe-map-tree'."
;; Converted from describe_map in keymap.c.
(let* ((map (keymap-canonicalize map))
(tail map)
@@ -1949,8 +1995,8 @@ and some others."
(if temp-buffer-resize-mode
;; `help-make-xrefs' may add a `back' button and thus increase the
;; text size, so `resize-temp-buffer-window' must be run *after* it.
- (add-hook 'temp-buffer-show-hook 'resize-temp-buffer-window 'append)
- (remove-hook 'temp-buffer-show-hook 'resize-temp-buffer-window)))
+ (add-hook 'temp-buffer-show-hook #'resize-temp-buffer-window 'append)
+ (remove-hook 'temp-buffer-show-hook #'resize-temp-buffer-window)))
(defvar resize-temp-buffer-window-inhibit nil
"Non-nil means `resize-temp-buffer-window' should not resize.")
@@ -2194,11 +2240,32 @@ The `temp-buffer-window-setup-hook' hook is called."
;; Don't print to *Help*; that would clobber Help history.
(defun help-form-show ()
"Display the output of a non-nil `help-form'."
- (let ((msg (eval help-form)))
+ (let ((msg (eval help-form t)))
(if (stringp msg)
(with-output-to-temp-buffer " *Char Help*"
(princ msg)))))
+(defun help--append-keystrokes-help (str)
+ (let* ((keys (this-single-command-keys))
+ (bindings (delete nil
+ (mapcar (lambda (map) (lookup-key map keys t))
+ (current-active-maps t)))))
+ (catch 'res
+ (dolist (val help-event-list)
+ (let ((key (vector (if (eql val 'help)
+ help-char
+ val))))
+ (unless (seq-find (lambda (map) (and (keymapp map) (lookup-key map key)))
+ bindings)
+ (throw 'res
+ (concat
+ str
+ (substitute-command-keys
+ (format
+ " (\\`%s' for help)"
+ (key-description key))))))))
+ str)))
+
(defun help--docstring-quote (string)
"Return a doc string that represents STRING.
@@ -2286,7 +2353,7 @@ the same names as used in the original source code, when possible."
((or (and (byte-code-function-p def) (integerp (aref def 0)))
(subrp def) (module-function-p def))
(or (when preserve-names
- (let* ((doc (condition-case nil (documentation def) (error nil)))
+ (let* ((doc (condition-case nil (documentation def 'raw) (error nil)))
(docargs (if doc (car (help-split-fundoc doc nil))))
(arglist (if docargs
(cdar (read-from-string (downcase docargs)))))
@@ -2338,7 +2405,7 @@ the same names as used in the original source code, when possible."
(t arg)))
arglist)))
-(define-obsolete-function-alias 'help-make-usage 'help--make-usage "25.1")
+(define-obsolete-function-alias 'help-make-usage #'help--make-usage "25.1")
(defun help--make-usage-docstring (fn arglist)
(let ((print-escape-newlines t))
@@ -2408,6 +2475,7 @@ the suggested string to use instead. See
#'help-command-error-confusable-suggestions))
(define-obsolete-function-alias 'help-for-help-internal #'help-for-help "28.1")
+(define-obsolete-function-alias 'describe-map-tree #'help--describe-map-tree "30.1")
(provide 'help)
diff --git a/lisp/hexl.el b/lisp/hexl.el
index 0395e6b90a6..1288cf4d7fb 100644
--- a/lisp/hexl.el
+++ b/lisp/hexl.el
@@ -60,7 +60,7 @@
(const 64))
:version "24.3")
-(defcustom hexl-program "hexl"
+(defcustom hexl-program hexl-program-name
"The program that will hexlify and dehexlify its stdin.
`hexl-program' will always be concatenated with `hexl-options'
and \"-de\" when dehexlifying a buffer."
diff --git a/lisp/htmlfontify.el b/lisp/htmlfontify.el
index 4bf31d58b7a..89c2bee2204 100644
--- a/lisp/htmlfontify.el
+++ b/lisp/htmlfontify.el
@@ -308,13 +308,14 @@ done;")
:tag "etags-cmd-alist"
:type '(alist :key-type (string) :value-type (string)))
-(defcustom hfy-etags-bin "etags"
+(defcustom hfy-etags-bin etags-program-name
"Location of etags binary (we begin by assuming it's in your path).
Note that if etags is not in your path, you will need to alter the shell
commands in `hfy-etags-cmd-alist'."
:tag "etags-bin"
- :type '(file))
+ :type '(file)
+ :version "30.1")
(defcustom hfy-shell-file-name "/bin/sh"
"Shell (Bourne or compatible) to invoke for complex shell operations."
@@ -585,6 +586,7 @@ If a window system is unavailable, calls `hfy-fallback-color-values'."
(defvar hfy-cperl-mode-kludged-p nil)
(defun hfy-kludge-cperl-mode ()
+ ;; FIXME: Still?
"CPerl mode does its damnedest not to do some of its fontification when not
in a windowing system - try to trick it..."
(declare (obsolete nil "28.1"))
diff --git a/lisp/ibuf-ext.el b/lisp/ibuf-ext.el
index b824a26971d..95ff014aa5b 100644
--- a/lisp/ibuf-ext.el
+++ b/lisp/ibuf-ext.el
@@ -143,10 +143,10 @@ Returns (OLD-FORMAT-DETECTED . UPDATED-SAVED-FILTERS-LIST)."
(mode . bibtex-mode)))
("web"
(or (derived-mode . sgml-mode)
- (derived-mode . css-mode)
- (mode . javascript-mode)
+ (derived-mode . css-base-mode)
+ (derived-mode . js-base-mode)
+ (derived-mode . typescript-ts-base-mode)
(mode . js2-mode)
- (mode . scss-mode)
(derived-mode . haml-mode)
(mode . sass-mode)))
("gnus"
@@ -400,9 +400,9 @@ format. See `ibuffer-update-saved-filters-format' and
(error "This buffer is not in Ibuffer mode"))
(cond (ibuffer-auto-mode
(frame-or-buffer-changed-p 'ibuffer-auto-buffers-changed) ; Initialize state vector
- (add-hook 'post-command-hook 'ibuffer-auto-update-changed))
+ (add-hook 'post-command-hook #'ibuffer-auto-update-changed))
(t
- (remove-hook 'post-command-hook 'ibuffer-auto-update-changed))))
+ (remove-hook 'post-command-hook #'ibuffer-auto-update-changed))))
(defun ibuffer-auto-update-changed ()
(when (frame-or-buffer-changed-p 'ibuffer-auto-buffers-changed)
@@ -557,7 +557,7 @@ See `ibuffer-do-view-and-eval' for that."
(list (read--expression "Eval in buffers (form): "))
:opstring "evaluated in"
:modifier-p :maybe)
- (eval form))
+ (eval form t))
;;;###autoload (autoload 'ibuffer-do-view-and-eval "ibuf-ext")
(define-ibuffer-op view-and-eval (form)
@@ -575,7 +575,7 @@ To evaluate a form without viewing the buffer, see `ibuffer-do-eval'."
(unwind-protect
(progn
(switch-to-buffer buf)
- (eval form))
+ (eval form t))
(switch-to-buffer ibuffer-buf))))
;;;###autoload (autoload 'ibuffer-do-rename-uniquely "ibuf-ext")
@@ -1185,10 +1185,12 @@ Interactively, prompt for NAME, and use the current filters."
(concat " [filter: " (cdr qualifier) "]"))
('or
(concat " [OR" (mapconcat #'ibuffer-format-qualifier
- (cdr qualifier) "") "]"))
+ (cdr qualifier))
+ "]"))
('and
(concat " [AND" (mapconcat #'ibuffer-format-qualifier
- (cdr qualifier) "") "]"))
+ (cdr qualifier))
+ "]"))
(_
(let ((type (assq (car qualifier) ibuffer-filtering-alist)))
(unless qualifier
@@ -1202,11 +1204,12 @@ Interactively, prompt for NAME, and use the current filters."
If INCLUDE-PARENTS is non-nil then include parent modes."
(let ((modes))
(dolist (buf (buffer-list))
- (let ((this-mode (buffer-local-value 'major-mode buf)))
- (while (and this-mode (not (memq this-mode modes)))
- (push this-mode modes)
- (setq this-mode (and include-parents
- (get this-mode 'derived-mode-parent))))))
+ (let ((this-modes (derived-mode-all-parents
+ (buffer-local-value 'major-mode buf))))
+ (while (and this-modes (not (memq (car this-modes) modes)))
+ (push (car this-modes) modes)
+ (setq this-modes (and include-parents
+ (cdr this-modes))))))
(mapcar #'symbol-name modes)))
@@ -1391,7 +1394,7 @@ matches against the value of `default-directory' in that buffer."
(:description "predicate"
:reader (read-minibuffer "Filter by predicate (form): "))
(with-current-buffer buf
- (eval qualifier)))
+ (eval qualifier t)))
;;;###autoload (autoload 'ibuffer-filter-chosen-by-completion "ibuf-ext")
(defun ibuffer-filter-chosen-by-completion ()
@@ -1508,7 +1511,7 @@ Ordering is lexicographic."
"Emulate `bs-show' from the bs.el package."
(interactive)
(ibuffer t "*Ibuffer-bs*" '((filename . ".*")) nil t)
- (define-key (current-local-map) "a" 'ibuffer-bs-toggle-all))
+ (define-key (current-local-map) "a" #'ibuffer-bs-toggle-all))
(defun ibuffer-bs-toggle-all ()
"Emulate `bs-toggle-show-all' from the bs.el package."
@@ -1650,68 +1653,67 @@ a prefix argument reverses the meaning of that variable."
(error "No buffer with name %s" name)
(goto-char buf-point)))))
+(declare-function diff-check-labels "diff" (&optional force))
+(declare-function diff-file-local-copy "diff" (file-or-buf))
(declare-function diff-sentinel "diff"
(code &optional old-temp-file new-temp-file))
(defun ibuffer-diff-buffer-with-file-1 (buffer)
- (let ((bufferfile (buffer-local-value 'buffer-file-name buffer))
- (tempfile (make-temp-file "buffer-content-")))
- (when bufferfile
- (unwind-protect
- (progn
- (with-current-buffer buffer
- (write-region nil nil tempfile nil 'nomessage))
- (let* ((old (expand-file-name bufferfile))
- (new (expand-file-name tempfile))
- (oldtmp (file-local-copy old))
- (newtmp (file-local-copy new))
- (switches diff-switches)
- (command
- (mapconcat
- 'identity
- `(,diff-command
- ;; Use explicitly specified switches
- ,@(if (listp switches) switches (list switches))
- ,@(if (or old new)
- (list "-L" (shell-quote-argument old)
- "-L" (shell-quote-argument
- (format "Buffer %s" (buffer-name buffer)))))
- ,(shell-quote-argument (or oldtmp old))
- ,(shell-quote-argument (or newtmp new)))
- " ")))
- (let ((inhibit-read-only t))
- (insert command "\n")
- (diff-sentinel
- (call-process shell-file-name nil
- (current-buffer) nil
- shell-command-switch command))
- (insert "\n")))))
- (sit-for 0)
- (when (file-exists-p tempfile)
- (delete-file tempfile)))))
+ "Compare BUFFER with its associated file, if any.
+Unlike `diff-no-select', insert output into current buffer
+without erasing it."
+ (when-let ((old (buffer-file-name buffer)))
+ (defvar diff-use-labels)
+ (let* ((new buffer)
+ (oldtmp (diff-file-local-copy old))
+ (newtmp (diff-file-local-copy new))
+ (switches diff-switches)
+ (command
+ (string-join
+ `(,diff-command
+ ,@(if (listp switches) switches (list switches))
+ ,@(and (eq diff-use-labels t)
+ (list "--label" (shell-quote-argument old)
+ "--label" (shell-quote-argument (format "%S" new))))
+ ,(shell-quote-argument (or oldtmp old))
+ ,(shell-quote-argument (or newtmp new)))
+ " "))
+ (inhibit-read-only t))
+ (insert ?\n command ?\n)
+ (diff-sentinel (call-process shell-file-name nil t nil
+ shell-command-switch command)
+ oldtmp newtmp)
+ (goto-char (point-max)))
+ (redisplay)))
;;;###autoload
(defun ibuffer-diff-with-file ()
"View the differences between marked buffers and their associated files.
If no buffers are marked, use buffer at point.
-This requires the external program \"diff\" to be in your `exec-path'."
+This requires the external program `diff-command' to be in your
+`exec-path'."
(interactive)
(require 'diff)
- (let ((marked-bufs (ibuffer-get-marked-buffers)))
- (when (null marked-bufs)
- (setq marked-bufs (list (ibuffer-current-buffer t))))
- (with-current-buffer (get-buffer-create "*Ibuffer Diff*")
- (setq buffer-read-only nil)
- (buffer-disable-undo (current-buffer))
- (erase-buffer)
- (buffer-enable-undo (current-buffer))
+ (let ((marked-bufs (or (ibuffer-get-marked-buffers)
+ (list (ibuffer-current-buffer t))))
+ (diff-buf (get-buffer-create "*Ibuffer Diff*")))
+ (with-current-buffer diff-buf
+ (setq buffer-read-only t)
+ (buffer-disable-undo)
+ (let ((inhibit-read-only t))
+ (erase-buffer))
+ (buffer-enable-undo)
(diff-mode)
+ (diff-check-labels)
(dolist (buf marked-bufs)
(unless (buffer-live-p buf)
(error "Buffer %s has been killed" buf))
- (ibuffer-diff-buffer-with-file-1 buf))
- (setq buffer-read-only t)))
- (switch-to-buffer "*Ibuffer Diff*"))
+ (ibuffer-diff-buffer-with-file-1 buf))
+ (goto-char (point-min))
+ (when (= (following-char) ?\n)
+ (let ((inhibit-read-only t))
+ (delete-char 1))))
+ (pop-to-buffer-same-window diff-buf)))
;;;###autoload
(defun ibuffer-copy-filename-as-kill (&optional arg)
@@ -1747,7 +1749,7 @@ You can then feed the file name(s) to other commands with \\[yank]."
(t (file-name-nondirectory name))))))
buffers))
(string
- (mapconcat 'identity (delete "" file-names) " ")))
+ (mapconcat #'identity (delete "" file-names) " ")))
(unless (string= string "")
(if (eq last-command 'kill-region)
(kill-append string nil)
diff --git a/lisp/ibuf-macs.el b/lisp/ibuf-macs.el
index a2553e9e23a..1fd94967836 100644
--- a/lisp/ibuf-macs.el
+++ b/lisp/ibuf-macs.el
@@ -230,6 +230,9 @@ buffer object.
(_
'ibuffer-marked-buffer-names)))))
(when (null marked-names)
+ (cl-assert (get-text-property (line-beginning-position)
+ 'ibuffer-properties)
+ nil "No buffer on this line")
(setq marked-names (list (buffer-name (ibuffer-current-buffer))))
(ibuffer-set-mark ,(pcase mark
(:deletion
@@ -243,7 +246,9 @@ buffer object.
())
(and after `(,after)) ; post-operation form.
`((ibuffer-redisplay t)
- (message ,(concat "Operation finished; " opstring " %s buffers") count))))
+ (message ,(concat "Operation finished; " opstring
+ " %s %s")
+ count (ngettext "buffer" "buffers" count)))))
(inner-body (if complex
`(progn ,@body)
`(progn
@@ -310,7 +315,7 @@ bound to the current value of the filter.
(,qualifier-str qualifier))
,(when accept-list
`(progn
- (unless (listp qualifier) (setq qualifier (list qualifier)))
+ (setq qualifier (ensure-list qualifier))
;; Reject equivalent filters: (or f1 f2) is same as (or f2 f1).
(setq qualifier (sort (delete-dups qualifier) #'string-lessp))
(setq ,filter (cons ',name (car qualifier)))
diff --git a/lisp/ibuffer.el b/lisp/ibuffer.el
index 26358bd5ff9..c65213f5bde 100644
--- a/lisp/ibuffer.el
+++ b/lisp/ibuffer.el
@@ -1872,7 +1872,8 @@ the buffer object itself and the current mark symbol."
(let ((result
(if (buffer-live-p (ibuffer-current-buffer))
(when (or (null group)
- (when-let ((it (get-text-property (point) 'ibuffer-filter-group)))
+ (when-let ((it (get-text-property
+ (point) 'ibuffer-filter-group)))
(equal group it)))
(save-excursion
(funcall function
@@ -1897,7 +1898,19 @@ the buffer object itself and the current mark symbol."
(t
(cl-incf ibuffer-map-lines-count)
(forward-line 1)))))
- ibuffer-map-lines-count)
+ ;; With `ibuffer-auto-mode' enabled, `ibuffer-expert' nil
+ ;; and more than one marked buffer lines, the preceding loop
+ ;; counts the automatically popped up (and hence not
+ ;; user-marked) buffer "*Ibuffer confirmation*". Since
+ ;; Ibuffer reports how many marked buffers lines were acted
+ ;; upon, and in this case the reported count would be too
+ ;; high by one, we decrement the count to avoid the
+ ;; confusing message (see bug#64230).
+ (if (and (featurep 'ibuf-ext) ibuffer-auto-mode
+ (> ibuffer-map-lines-count 1)
+ (not ibuffer-expert))
+ (1- ibuffer-map-lines-count)
+ ibuffer-map-lines-count))
(progn
(setq buffer-read-only t)
(unless nomodify
@@ -2363,135 +2376,135 @@ particular subset of them, and sorting by various criteria.
Operations on marked buffers:
\\<ibuffer-mode-map>
- `\\[ibuffer-do-save]' - Save the marked buffers.
- `\\[ibuffer-do-view]' - View the marked buffers in the selected frame.
- `\\[ibuffer-do-view-other-frame]' - View the marked buffers in another frame.
- `\\[ibuffer-do-revert]' - Revert the marked buffers.
- `\\[ibuffer-do-toggle-read-only]' - Toggle read-only state of marked buffers.
- `\\[ibuffer-do-toggle-lock]' - Toggle lock state of marked buffers.
- `\\[ibuffer-do-delete]' - Kill the marked buffers.
- `\\[ibuffer-do-isearch]' - Do incremental search in the marked buffers.
- `\\[ibuffer-do-isearch-regexp]' - Isearch for regexp in the marked buffers.
- `\\[ibuffer-do-replace-regexp]' - Replace by regexp in each of the marked
- buffers.
- `\\[ibuffer-do-query-replace]' - Query replace in each of the marked buffers.
- `\\[ibuffer-do-query-replace-regexp]' - As above, with a regular expression.
- `\\[ibuffer-do-print]' - Print the marked buffers.
- `\\[ibuffer-do-occur]' - List lines in all marked buffers which match
- a given regexp (like the function `occur').
- `\\[ibuffer-do-shell-command-pipe]' - Pipe the contents of the marked
- buffers to a shell command.
- `\\[ibuffer-do-shell-command-pipe-replace]' - Replace the contents of the marked
- buffers with the output of a shell command.
- `\\[ibuffer-do-shell-command-file]' - Run a shell command with the
- buffer's file as an argument.
- `\\[ibuffer-do-eval]' - Evaluate a form in each of the marked buffers. This
- is a very flexible command. For example, if you want to make all
- of the marked buffers read-only, try using (read-only-mode 1) as
- the input form.
- `\\[ibuffer-do-view-and-eval]' - As above, but view each buffer while the form
- is evaluated.
- `\\[ibuffer-do-kill-lines]' - Remove the marked lines from the *Ibuffer* buffer,
- but don't kill the associated buffer.
- `\\[ibuffer-do-kill-on-deletion-marks]' - Kill all buffers marked for deletion.
+ \\[ibuffer-do-save] - Save the marked buffers.
+ \\[ibuffer-do-view] - View the marked buffers in the selected frame.
+ \\[ibuffer-do-view-other-frame] - View the marked buffers in another frame.
+ \\[ibuffer-do-revert] - Revert the marked buffers.
+ \\[ibuffer-do-toggle-read-only] - Toggle read-only state of marked buffers.
+ \\[ibuffer-do-toggle-lock] - Toggle lock state of marked buffers.
+ \\[ibuffer-do-delete] - Kill the marked buffers.
+ \\[ibuffer-do-isearch] - Do incremental search in the marked buffers.
+ \\[ibuffer-do-isearch-regexp] - Isearch for regexp in the marked buffers.
+ \\[ibuffer-do-replace-regexp] - Replace by regexp in each of the marked
+ buffers.
+ \\[ibuffer-do-query-replace] - Query replace in each of the marked buffers.
+ \\[ibuffer-do-query-replace-regexp] - As above, with a regular expression.
+ \\[ibuffer-do-print] - Print the marked buffers.
+ \\[ibuffer-do-occur] - List lines in all marked buffers which match
+ a given regexp (like the function `occur').
+ \\[ibuffer-do-shell-command-pipe] - Pipe the contents of the marked
+ buffers to a shell command.
+ \\[ibuffer-do-shell-command-pipe-replace] - Replace the contents of the marked
+ buffers with the output of a shell command.
+ \\[ibuffer-do-shell-command-file] - Run a shell command with the
+ buffer's file as an argument.
+ \\[ibuffer-do-eval] - Evaluate a form in each of the marked buffers. This
+ is a very flexible command. For example, if you want to make all
+ of the marked buffers read-only, try using (read-only-mode 1) as
+ the input form.
+ \\[ibuffer-do-view-and-eval] - As above, but view each buffer while the form
+ is evaluated.
+ \\[ibuffer-do-kill-lines] - Remove the marked lines from the *Ibuffer* buffer,
+ but don't kill the associated buffer.
+ \\[ibuffer-do-kill-on-deletion-marks] - Kill all buffers marked for deletion.
Marking commands:
- `\\[ibuffer-mark-forward]' - Mark the buffer at point.
- `\\[ibuffer-toggle-marks]' - Unmark all currently marked buffers, and mark
- all unmarked buffers.
- `\\[ibuffer-change-marks]' - Change the mark used on marked buffers.
- `\\[ibuffer-unmark-forward]' - Unmark the buffer at point.
- `\\[ibuffer-unmark-backward]' - Unmark the previous buffer.
- `\\[ibuffer-unmark-all]' - Unmark buffers marked with MARK.
- `\\[ibuffer-unmark-all-marks]' - Unmark all marked buffers.
- `\\[ibuffer-mark-by-mode]' - Mark buffers by major mode.
- `\\[ibuffer-mark-unsaved-buffers]' - Mark all \"unsaved\" buffers.
- This means that the buffer is modified, and has an associated file.
- `\\[ibuffer-mark-modified-buffers]' - Mark all modified buffers,
- regardless of whether they have an associated file.
- `\\[ibuffer-mark-special-buffers]' - Mark all buffers whose name begins and
- ends with `*'.
- `\\[ibuffer-mark-dissociated-buffers]' - Mark all buffers which have
- an associated file, but that file doesn't currently exist.
- `\\[ibuffer-mark-read-only-buffers]' - Mark all read-only buffers.
- `\\[ibuffer-mark-dired-buffers]' - Mark buffers in `dired-mode'.
- `\\[ibuffer-mark-help-buffers]' - Mark buffers in `help-mode', `apropos-mode', etc.
- `\\[ibuffer-mark-old-buffers]' - Mark buffers older than `ibuffer-old-time'.
- `\\[ibuffer-mark-for-delete]' - Mark the buffer at point for deletion.
- `\\[ibuffer-mark-by-name-regexp]' - Mark buffers by their name, using a regexp.
- `\\[ibuffer-mark-by-mode-regexp]' - Mark buffers by their major mode, using a regexp.
- `\\[ibuffer-mark-by-file-name-regexp]' - Mark buffers by their filename, using a regexp.
- `\\[ibuffer-mark-by-content-regexp]' - Mark buffers by their content, using a regexp.
- `\\[ibuffer-mark-by-locked]' - Mark all locked buffers.
+ \\[ibuffer-mark-forward] - Mark the buffer at point.
+ \\[ibuffer-toggle-marks] - Unmark all currently marked buffers, and mark
+ all unmarked buffers.
+ \\[ibuffer-change-marks] - Change the mark used on marked buffers.
+ \\[ibuffer-unmark-forward] - Unmark the buffer at point.
+ \\[ibuffer-unmark-backward] - Unmark the previous buffer.
+ \\[ibuffer-unmark-all] - Unmark buffers marked with MARK.
+ \\[ibuffer-unmark-all-marks] - Unmark all marked buffers.
+ \\[ibuffer-mark-by-mode] - Mark buffers by major mode.
+ \\[ibuffer-mark-unsaved-buffers] - Mark all \"unsaved\" buffers.
+ This means that the buffer is modified, and has an associated file.
+ \\[ibuffer-mark-modified-buffers] - Mark all modified buffers,
+ regardless of whether they have an associated file.
+ \\[ibuffer-mark-special-buffers] - Mark all buffers whose name begins and
+ ends with `*'.
+ \\[ibuffer-mark-dissociated-buffers] - Mark all buffers which have
+ an associated file, but that file doesn't currently exist.
+ \\[ibuffer-mark-read-only-buffers] - Mark all read-only buffers.
+ \\[ibuffer-mark-dired-buffers] - Mark buffers in `dired-mode'.
+ \\[ibuffer-mark-help-buffers] - Mark buffers in `help-mode', `apropos-mode', etc.
+ \\[ibuffer-mark-old-buffers] - Mark buffers older than `ibuffer-old-time'.
+ \\[ibuffer-mark-for-delete] - Mark the buffer at point for deletion.
+ \\[ibuffer-mark-by-name-regexp] - Mark buffers by their name, using a regexp.
+ \\[ibuffer-mark-by-mode-regexp] - Mark buffers by their major mode, using a regexp.
+ \\[ibuffer-mark-by-file-name-regexp] - Mark buffers by their filename, using a regexp.
+ \\[ibuffer-mark-by-content-regexp] - Mark buffers by their content, using a regexp.
+ \\[ibuffer-mark-by-locked] - Mark all locked buffers.
Filtering commands:
- `\\[ibuffer-filter-chosen-by-completion]' - Select and apply filter chosen by completion.
- `\\[ibuffer-filter-by-mode]' - Add a filter by any major mode.
- `\\[ibuffer-filter-by-used-mode]' - Add a filter by a major mode now in use.
- `\\[ibuffer-filter-by-derived-mode]' - Add a filter by derived mode.
- `\\[ibuffer-filter-by-name]' - Add a filter by buffer name.
- `\\[ibuffer-filter-by-content]' - Add a filter by buffer content.
- `\\[ibuffer-filter-by-basename]' - Add a filter by basename.
- `\\[ibuffer-filter-by-directory]' - Add a filter by directory name.
- `\\[ibuffer-filter-by-filename]' - Add a filter by filename.
- `\\[ibuffer-filter-by-file-extension]' - Add a filter by file extension.
- `\\[ibuffer-filter-by-modified]' - Add a filter by modified buffers.
- `\\[ibuffer-filter-by-predicate]' - Add a filter by an arbitrary Lisp predicate.
- `\\[ibuffer-filter-by-size-gt]' - Add a filter by buffer size.
- `\\[ibuffer-filter-by-size-lt]' - Add a filter by buffer size.
- `\\[ibuffer-filter-by-starred-name]' - Add a filter by special buffers.
- `\\[ibuffer-filter-by-visiting-file]' - Add a filter by buffers visiting files.
- `\\[ibuffer-save-filters]' - Save the current filters with a name.
- `\\[ibuffer-switch-to-saved-filters]' - Switch to previously saved filters.
- `\\[ibuffer-add-saved-filters]' - Add saved filters to current filters.
- `\\[ibuffer-and-filter]' - Replace the top two filters with their logical AND.
- `\\[ibuffer-or-filter]' - Replace the top two filters with their logical OR.
- `\\[ibuffer-pop-filter]' - Remove the top filter.
- `\\[ibuffer-negate-filter]' - Invert the logical sense of the top filter.
- `\\[ibuffer-decompose-filter]' - Break down the topmost filter.
- `\\[ibuffer-filter-disable]' - Remove all filtering currently in effect.
+ \\[ibuffer-filter-chosen-by-completion] - Select and apply filter chosen by completion.
+ \\[ibuffer-filter-by-mode] - Add a filter by any major mode.
+ \\[ibuffer-filter-by-used-mode] - Add a filter by a major mode now in use.
+ \\[ibuffer-filter-by-derived-mode] - Add a filter by derived mode.
+ \\[ibuffer-filter-by-name] - Add a filter by buffer name.
+ \\[ibuffer-filter-by-content] - Add a filter by buffer content.
+ \\[ibuffer-filter-by-basename] - Add a filter by basename.
+ \\[ibuffer-filter-by-directory] - Add a filter by directory name.
+ \\[ibuffer-filter-by-filename] - Add a filter by filename.
+ \\[ibuffer-filter-by-file-extension] - Add a filter by file extension.
+ \\[ibuffer-filter-by-modified] - Add a filter by modified buffers.
+ \\[ibuffer-filter-by-predicate] - Add a filter by an arbitrary Lisp predicate.
+ \\[ibuffer-filter-by-size-gt] - Add a filter by buffer size.
+ \\[ibuffer-filter-by-size-lt] - Add a filter by buffer size.
+ \\[ibuffer-filter-by-starred-name] - Add a filter by special buffers.
+ \\[ibuffer-filter-by-visiting-file] - Add a filter by buffers visiting files.
+ \\[ibuffer-save-filters] - Save the current filters with a name.
+ \\[ibuffer-switch-to-saved-filters] - Switch to previously saved filters.
+ \\[ibuffer-add-saved-filters] - Add saved filters to current filters.
+ \\[ibuffer-and-filter] - Replace the top two filters with their logical AND.
+ \\[ibuffer-or-filter] - Replace the top two filters with their logical OR.
+ \\[ibuffer-pop-filter] - Remove the top filter.
+ \\[ibuffer-negate-filter] - Invert the logical sense of the top filter.
+ \\[ibuffer-decompose-filter] - Break down the topmost filter.
+ \\[ibuffer-filter-disable] - Remove all filtering currently in effect.
Filter group commands:
- `\\[ibuffer-filters-to-filter-group]' - Create filter group from filters.
- `\\[ibuffer-pop-filter-group]' - Remove top filter group.
- `\\[ibuffer-forward-filter-group]' - Move to the next filter group.
- `\\[ibuffer-backward-filter-group]' - Move to the previous filter group.
- `\\[ibuffer-clear-filter-groups]' - Remove all active filter groups.
- `\\[ibuffer-save-filter-groups]' - Save the current groups with a name.
- `\\[ibuffer-switch-to-saved-filter-groups]' - Restore previously saved groups.
- `\\[ibuffer-delete-saved-filter-groups]' - Delete previously saved groups.
+ \\[ibuffer-filters-to-filter-group] - Create filter group from filters.
+ \\[ibuffer-pop-filter-group] - Remove top filter group.
+ \\[ibuffer-forward-filter-group] - Move to the next filter group.
+ \\[ibuffer-backward-filter-group] - Move to the previous filter group.
+ \\[ibuffer-clear-filter-groups] - Remove all active filter groups.
+ \\[ibuffer-save-filter-groups] - Save the current groups with a name.
+ \\[ibuffer-switch-to-saved-filter-groups] - Restore previously saved groups.
+ \\[ibuffer-delete-saved-filter-groups] - Delete previously saved groups.
Sorting commands:
- `\\[ibuffer-toggle-sorting-mode]' - Rotate between the various sorting modes.
- `\\[ibuffer-invert-sorting]' - Reverse the current sorting order.
- `\\[ibuffer-do-sort-by-alphabetic]' - Sort the buffers lexicographically.
- `\\[ibuffer-do-sort-by-filename/process]' - Sort the buffers by the file name.
- `\\[ibuffer-do-sort-by-recency]' - Sort the buffers by last viewing time.
- `\\[ibuffer-do-sort-by-size]' - Sort the buffers by size.
- `\\[ibuffer-do-sort-by-major-mode]' - Sort the buffers by major mode.
+ \\[ibuffer-toggle-sorting-mode] - Rotate between the various sorting modes.
+ \\[ibuffer-invert-sorting] - Reverse the current sorting order.
+ \\[ibuffer-do-sort-by-alphabetic] - Sort the buffers lexicographically.
+ \\[ibuffer-do-sort-by-filename/process] - Sort the buffers by the file name.
+ \\[ibuffer-do-sort-by-recency] - Sort the buffers by last viewing time.
+ \\[ibuffer-do-sort-by-size] - Sort the buffers by size.
+ \\[ibuffer-do-sort-by-major-mode] - Sort the buffers by major mode.
Other commands:
- `\\[ibuffer-update]' - Regenerate the list of all buffers.
- Prefix arg means to toggle whether buffers that match
- `ibuffer-maybe-show-predicates' should be displayed.
- `\\[ibuffer-auto-mode]' - Toggle automatic updates.
-
- `\\[ibuffer-switch-format]' - Change the current display format.
- `\\[forward-line]' - Move point to the next line.
- `\\[previous-line]' - Move point to the previous line.
- `\\[describe-mode]' - This help.
- `\\[ibuffer-diff-with-file]' - View the differences between this buffer
- and its associated file.
- `\\[ibuffer-visit-buffer]' - View the buffer on this line.
- `\\[ibuffer-visit-buffer-other-window]' - As above, but in another window.
- `\\[ibuffer-visit-buffer-other-window-noselect]' - As both above, but don't select
- the new window.
- `\\[ibuffer-bury-buffer]' - Bury (not kill!) the buffer on this line.
+ \\[ibuffer-update] - Regenerate the list of all buffers.
+ Prefix arg means to toggle whether buffers that match
+ `ibuffer-maybe-show-predicates' should be displayed.
+ \\[ibuffer-auto-mode] - Toggle automatic updates.
+
+ \\[ibuffer-switch-format] - Change the current display format.
+ \\[forward-line] - Move point to the next line.
+ \\[previous-line] - Move point to the previous line.
+ \\[describe-mode] - This help.
+ \\[ibuffer-diff-with-file] - View the differences between this buffer
+ and its associated file.
+ \\[ibuffer-visit-buffer] - View the buffer on this line.
+ \\[ibuffer-visit-buffer-other-window] - As above, but in another window.
+ \\[ibuffer-visit-buffer-other-window-noselect] - As both above, but don't select
+ the new window.
+ \\[ibuffer-bury-buffer] - Bury (not kill!) the buffer on this line.
** Information on Filtering:
@@ -2512,7 +2525,7 @@ with \"gnus\". You can accomplish this via:
\\[ibuffer-filter-by-name] ^gnus RET
Additionally, you can OR the top two filters together with
-`\\[ibuffer-or-filters]'. To see all buffers in either
+\\[ibuffer-or-filters]. To see all buffers in either
`emacs-lisp-mode' or `lisp-interaction-mode', type:
\\[ibuffer-filter-by-mode] emacs-lisp-mode RET
@@ -2522,9 +2535,9 @@ Additionally, you can OR the top two filters together with
Filters can also be saved and restored using mnemonic names: see the
functions `ibuffer-save-filters' and `ibuffer-switch-to-saved-filters'.
-To remove the top filter on the stack, use `\\[ibuffer-pop-filter]', and
+To remove the top filter on the stack, use \\[ibuffer-pop-filter], and
to disable all filtering currently in effect, use
-`\\[ibuffer-filter-disable]'.
+\\[ibuffer-filter-disable].
** Filter Groups:
@@ -2532,7 +2545,7 @@ Once one has mastered filters, the next logical step up is \"filter
groups\". A filter group is basically a named group of buffers which
match a filter, which are displayed together in an Ibuffer buffer. To
create a filter group, simply use the regular functions to create a
-filter, and then type `\\[ibuffer-filters-to-filter-group]'.
+filter, and then type \\[ibuffer-filters-to-filter-group].
A quick example will make things clearer. Suppose that one wants to
group all of one's Emacs Lisp buffers together. To do this, type:
@@ -2550,7 +2563,7 @@ multiple filter groups; instead, the first filter group is used. The
filter groups are displayed in this order of precedence.
You may rearrange filter groups by using the usual pair
-`\\[ibuffer-kill-line]' and `\\[ibuffer-yank]'. Yanked groups
+\\[ibuffer-kill-line] and \\[ibuffer-yank]. Yanked groups
will be inserted before the group at point."
;; Include state info next to the mode name.
(setq-local mode-line-process
diff --git a/lisp/icomplete.el b/lisp/icomplete.el
index b4db4524a7b..aa3c5680a7e 100644
--- a/lisp/icomplete.el
+++ b/lisp/icomplete.el
@@ -69,11 +69,12 @@ When nil, show candidates in full."
:type 'boolean
:version "24.4")
-(defvar icomplete-tidy-shadowed-file-names nil
+(defcustom icomplete-tidy-shadowed-file-names nil
"If non-nil, automatically delete superfluous parts of file names.
For example, if the user types ~/ after a long path name,
everything preceding the ~/ is discarded so the interactive
-selection process starts again from the user's $HOME.")
+selection process starts again from the user's $HOME."
+ :type 'boolean)
(defcustom icomplete-show-matches-on-no-input nil
"When non-nil, show completions when first prompting for input.
@@ -137,10 +138,11 @@ See `icomplete-delay-completions-threshold'."
"Maximum number of initial chars to apply `icomplete-compute-delay'."
:type 'integer)
-(defvar icomplete-in-buffer nil
+(defcustom icomplete-in-buffer nil
"If non-nil, also use Icomplete when completing in non-mini buffers.
This affects commands like `completion-in-region', but not commands
-that use their own completions setup.")
+that use their own completions setup."
+ :type 'boolean)
(defcustom icomplete-minibuffer-setup-hook nil
"Icomplete-specific customization of minibuffer setup.
@@ -717,11 +719,14 @@ If it's on, just add the vertical display."
Should be run via minibuffer `post-command-hook'.
See `icomplete-mode' and `minibuffer-setup-hook'."
(when (and icomplete-mode
+ ;; Check if still in the right buffer (bug#61308)
+ (or (window-minibuffer-p) completion-in-region--data)
(icomplete-simple-completing-p)) ;Shouldn't be necessary.
- (let ((saved-point (point)))
+ (let ((saved-point (point))
+ (completion-lazy-hilit t))
(save-excursion
(goto-char (icomplete--field-end))
- ; Insert the match-status information:
+ ;; Insert the match-status information:
(when (and (or icomplete-show-matches-on-no-input
(not (equal (icomplete--field-string)
icomplete--initial-input)))
@@ -784,10 +789,8 @@ and SUFFIX, if non-nil, are obtained from `affixation-function' or
`group-function'. Consecutive `equal' sections are avoided.
COMP is the element in PROSPECTS or a transformation also given
by `group-function''s second \"transformation\" protocol."
- (let* ((aff-fun (or (completion-metadata-get md 'affixation-function)
- (plist-get completion-extra-properties :affixation-function)))
- (ann-fun (or (completion-metadata-get md 'annotation-function)
- (plist-get completion-extra-properties :annotation-function)))
+ (let* ((aff-fun (completion-metadata-get md 'affixation-function))
+ (ann-fun (completion-metadata-get md 'annotation-function))
(grp-fun (and completions-group
(completion-metadata-get md 'group-function)))
(annotated
@@ -897,7 +900,7 @@ by `group-function''s second \"transformation\" protocol."
'icomplete-selected-match 'append comp)
collect (concat prefix
(make-string (- max-prefix-len (length prefix)) ? )
- comp
+ (completion-lazy-hilit comp)
(make-string (- max-comp-len (length comp)) ? )
suffix)
into lines-aux
@@ -1063,7 +1066,8 @@ matches exist."
(if (< prospects-len prospects-max)
(push comp prospects)
(setq limit t)))
- (setq prospects (nreverse prospects))
+ (setq prospects
+ (nreverse (mapcar #'completion-lazy-hilit prospects)))
;; Decorate first of the prospects.
(when prospects
(let ((first (copy-sequence (pop prospects))))
diff --git a/lisp/ido.el b/lisp/ido.el
index d2ce98b4bae..6e51dc67196 100644
--- a/lisp/ido.el
+++ b/lisp/ido.el
@@ -565,11 +565,12 @@ the `ido-work-directory-list' list."
(defcustom ido-use-filename-at-point nil
"Non-nil means that Ido shall look for a filename at point.
-May use `ffap-guesser' to guess whether text at point is a filename.
-If found, use that as the starting point for filename selection."
+Value `guess' means use `ffap-guesser' to guess whether text at
+point is a filename. If found, use that as the starting point
+for filename selection."
:type '(choice
(const :tag "Disabled" nil)
- (const :tag "Guess filename" guess)
+ (const :tag "Guess filename using ffap-guesser" guess)
(other :tag "Use literal filename" t)))
@@ -2325,7 +2326,7 @@ If cursor is not at the end of the user input, move to end of input."
(if (eq ido-use-filename-at-point 'guess)
(ffap-guesser)
(ffap-string-at-point))))
- (not (string-match "\\`http:/" fn)))
+ (not (string-match (rx bos "http" (? "s") ":/") fn)))
(let ((absolute-fn (expand-file-name fn)))
(cond
((file-directory-p absolute-fn)
diff --git a/lisp/ielm.el b/lisp/ielm.el
index eaee1055591..e583e0fe32c 100644
--- a/lisp/ielm.el
+++ b/lisp/ielm.el
@@ -110,6 +110,13 @@ This gives more frame width for large indented sexps, and allows functions
such as `edebug-defun' to work with such inputs."
:type 'boolean)
+(defcustom ielm-history-file-name
+ (locate-user-emacs-file "ielm-history.eld")
+ "If non-nil, name of the file to read/write IELM input history."
+ :type '(choice (const :tag "Disable input history" nil)
+ file)
+ :version "30.1")
+
(defvaralias 'inferior-emacs-lisp-mode-hook 'ielm-mode-hook)
(defcustom ielm-mode-hook nil
"Hooks to be run when IELM (`inferior-emacs-lisp-mode') is started."
@@ -498,6 +505,22 @@ behavior of the indirect buffer."
"Run `ielm-indirect-setup-hook'."
(run-hooks 'ielm-indirect-setup-hook))
+(defun ielm--expand-ellipsis (orig-fun beg &rest args)
+ (let ((end (copy-marker (apply orig-fun beg args) t)))
+ (funcall pp-default-function beg end)
+ end))
+
+;;; Input history
+
+(defvar ielm--exit nil
+ "Function to call when Emacs is killed.")
+
+(defun ielm--input-history-writer (buf)
+ "Return a function writing IELM input history to BUF."
+ (lambda ()
+ (with-current-buffer buf
+ (comint-write-input-ring))))
+
;;; Major mode
(define-derived-mode inferior-emacs-lisp-mode comint-mode "IELM"
@@ -580,6 +603,8 @@ Customized bindings may be defined in `ielm-map', which currently contains:
(setq-local comment-use-syntax t)
(setq-local lexical-binding t)
+ (add-function :around (local 'cl-print-expand-ellipsis-function)
+ #'ielm--expand-ellipsis)
(setq-local indent-line-function #'ielm-indent-line)
(setq-local ielm-working-buffer (current-buffer))
(setq-local fill-paragraph-function #'lisp-fill-paragraph)
@@ -598,12 +623,23 @@ Customized bindings may be defined in `ielm-map', which currently contains:
#'ielm-indirect-setup-hook 'append t)
(setq comint-indirect-setup-function #'emacs-lisp-mode)
+ ;; Input history
+ (setq-local comint-input-ring-file-name ielm-history-file-name)
+ (setq-local ielm--exit (ielm--input-history-writer (current-buffer)))
+ (setq-local kill-buffer-hook
+ (lambda ()
+ (funcall ielm--exit)
+ (remove-hook 'kill-emacs-hook ielm--exit)))
+ (unless noninteractive
+ (add-hook 'kill-emacs-hook ielm--exit))
+ (comint-read-input-ring t)
+
;; A dummy process to keep comint happy. It will never get any input
(unless (comint-check-proc (current-buffer))
;; Was cat, but on non-Unix platforms that might not exist, so
;; use hexl instead, which is part of the Emacs distribution.
(condition-case nil
- (start-process "ielm" (current-buffer) "hexl")
+ (start-process "ielm" (current-buffer) hexl-program-name)
(file-error (start-process "ielm" (current-buffer) "cat")))
(set-process-query-on-exit-flag (ielm-process) nil)
(goto-char (point-max))
diff --git a/lisp/iimage.el b/lisp/iimage.el
index 205141577c9..0f2297465fe 100644
--- a/lisp/iimage.el
+++ b/lisp/iimage.el
@@ -134,6 +134,7 @@ Examples of image filename patterns to match:
:max-width (- (nth 2 edges) (nth 0 edges))
:max-height (- (nth 3 edges) (nth 1 edges)))
keymap ,image-map
+ context-menu-functions (image-context-menu)
modification-hooks
(iimage-modification-hook)))
(remove-list-of-text-properties
diff --git a/lisp/image-mode.el b/lisp/image-mode.el
index b34ecd20c36..fa64f1ac03e 100644
--- a/lisp/image-mode.el
+++ b/lisp/image-mode.el
@@ -69,8 +69,8 @@ Its value should be one of the following:
Resizing will always preserve the aspect ratio of the image."
:type '(choice (const :tag "No resizing" nil)
(const :tag "Fit to window" fit-window)
- (other :tag "Scale down to fit window" t)
- (number :tag "Scale factor" 1))
+ (number :tag "Scale factor" 1)
+ (other :tag "Scale down to fit window" t))
:version "29.1"
:group 'image)
@@ -654,8 +654,9 @@ Key bindings:
(unless (display-images-p)
(error "Display does not support images"))
- (major-mode-suspend)
- (setq major-mode 'image-mode)
+ (unless (eq major-mode 'image-mode)
+ (major-mode-suspend)
+ (setq major-mode 'image-mode))
(setq image-transform-resize image-auto-resize)
;; Bail out early if we have no image data.
@@ -1085,7 +1086,7 @@ Otherwise, display the image by calling `image-mode'."
(unwind-protect
(progn
(setq-local image-fit-to-window-lock t)
- (ignore-error 'remote-file-error
+ (ignore-error remote-file-error
(image-toggle-display-image)))
(setq image-fit-to-window-lock nil)))))))))))
diff --git a/lisp/image.el b/lisp/image.el
index 4e50f678433..d7496485aca 100644
--- a/lisp/image.el
+++ b/lisp/image.el
@@ -193,6 +193,29 @@ or \"ffmpeg\") is installed."
"h" #'image-flip-horizontally
"v" #'image-flip-vertically))
+(defun image-context-menu (menu click)
+ "Populate MENU with image-related commands at CLICK."
+ (when (mouse-posn-property (event-start click) 'display)
+ (define-key menu [image-separator] menu-bar-separator)
+ (let ((easy-menu (make-sparse-keymap "Image")))
+ (easy-menu-define nil easy-menu nil
+ '("Image"
+ ["Zoom In" image-increase-size
+ :help "Enlarge the image"]
+ ["Zoom Out" image-decrease-size
+ :help "Shrink the image"]
+ ["Rotate Clockwise" image-rotate
+ :help "Rotate the image"]
+ ["Flip horizontally" image-flip-horizontally
+ :help "Flip horizontally"]
+ ["Flip vertically" image-flip-vertically
+ :help "Flip vertically"]))
+ (dolist (item (reverse (lookup-key easy-menu [menu-bar image])))
+ (when (consp item)
+ (define-key menu (vector (car item)) (cdr item))))))
+
+ menu)
+
(defun image-load-path-for-library (library image &optional path no-error)
"Return a suitable search path for images used by LIBRARY.
@@ -449,7 +472,7 @@ type if we can't otherwise guess it."
(require 'image-converter)
(image-convert-p source))))))
(unless type
- (signal 'unknown-image-type "Cannot determine image type")))
+ (signal 'unknown-image-type '("Cannot determine image type"))))
(when (and (not (eq type 'image-convert))
(not (memq type (and (boundp 'image-types) image-types))))
(error "Invalid image type `%s'" type))
@@ -537,6 +560,16 @@ Images should not be larger than specified by `max-image-size'."
('t t)
('nil nil)
(func (funcall func image)))))))
+ ;; Add original map from map.
+ (when (and (plist-get props :map)
+ (not (plist-get props :original-map)))
+ (setq image (nconc image (list :original-map
+ (image--compute-original-map image)))))
+ ;; Add map from original map.
+ (when (and (plist-get props :original-map)
+ (not (plist-get props :map)))
+ (setq image (nconc image (list :map
+ (image--compute-map image)))))
image)))
(defun image--default-smoothing (image)
@@ -628,6 +661,7 @@ means display it in the right marginal area."
(overlay-put overlay 'put-image t)
(overlay-put overlay 'before-string string)
(overlay-put overlay 'keymap image-map)
+ (overlay-put overlay 'context-menu-functions '(image-context-menu))
overlay)))
@@ -680,8 +714,9 @@ is non-nil, this is inhibited."
inhibit-isearch ,inhibit-isearch
keymap ,(if slice
image-slice-map
- image-map)))))
-
+ image-map)
+ context-menu-functions
+ (image-context-menu)))))
;;;###autoload
(defun insert-sliced-image (image &optional string area rows cols)
@@ -717,7 +752,9 @@ The image is automatically split into ROWS x COLS slices."
(add-text-properties start (point)
`(display ,(list (list 'slice x y dx dy) image)
rear-nonsticky (display keymap)
- keymap ,image-slice-map))
+ keymap ,image-slice-map
+ context-menu-functions
+ (image-context-menu)))
(setq x (+ x dx))))
(setq x 0.0
y (+ y dy))
@@ -767,21 +804,25 @@ BUFFER nil or omitted means use the current buffer."
;;;###autoload
(defun find-image (specs &optional cache)
- "Find an image, choosing one of a list of image specifications.
+ "Find an image that satisfies one of a list of image specifications.
SPECS is a list of image specifications.
-Each image specification in SPECS is a property list. The contents of
-a specification are image type dependent. All specifications must at
-least contain either the property `:file FILE' or `:data DATA',
-where FILE is the file to load the image from, and DATA is a string
-containing the actual image data. If the property `:type TYPE' is
-omitted or nil, try to determine the image type from its first few
+Each image specification in SPECS is a property list. The
+contents of a specification are image type dependent; see the
+info node `(elisp)Image Descriptors' for details. All specifications
+must at least contain either the property `:file FILE' or `:data DATA',
+where FILE is the file from which to load the image, and DATA is a
+string containing the actual image data. If the property `:type TYPE'
+is omitted or nil, try to determine the image type from its first few
bytes of image data. If that doesn't work, and the property `:file
-FILE' provide a file name, use its file extension as image type.
-If `:type TYPE' is provided, it must match the actual type
-determined for FILE or DATA by `create-image'. Return nil if no
-specification is satisfied.
+FILE' provide a file name, use its file extension as idication of the
+image type. If `:type TYPE' is provided, it must match the actual type
+determined for FILE or DATA by `create-image'.
+
+The function returns the image specification for the first specification
+in the list whose TYPE is supported and FILE, if specified, exists. It
+returns nil if no specification in the list can be satisfied.
If CACHE is non-nil, results are cached and returned on subsequent calls.
@@ -1177,7 +1218,10 @@ has no effect."
If N is 3, then the image size will be increased by 30%. More
generally, the image size is multiplied by 1 plus N divided by 10.
N defaults to 2, which increases the image size by 20%.
-POSITION can be a buffer position or a marker, and defaults to point."
+POSITION can be a buffer position or a marker, and defaults to point.
+
+When user option `image-recompute-map-p' is non-nil, the image's `:map'
+is recomputed to fit the newly transformed image."
(interactive "P")
(image--delayed-change-size (if n
(1+ (/ (prefix-numeric-value n) 10.0))
@@ -1189,7 +1233,7 @@ POSITION can be a buffer position or a marker, and defaults to point."
(defun image--delayed-change-size (size position)
;; Wait for a bit of idle-time before actually performing the change,
;; so as to batch together sequences of closely consecutive size changes.
- ;; `image--change-size' just changes one value in a plist. The actual
+ ;; `image--change-size' just changes two values in a plist. The actual
;; image resizing happens later during redisplay. So if those
;; consecutive calls happen without any redisplay between them,
;; the costly operation of image resizing should happen only once.
@@ -1200,7 +1244,10 @@ POSITION can be a buffer position or a marker, and defaults to point."
If N is 3, then the image size will be decreased by 30%. More
generally, the image size is multiplied by 1 minus N divided by 10.
N defaults to 2, which decreases the image size by 20%.
-POSITION can be a buffer position or a marker, and defaults to point."
+POSITION can be a buffer position or a marker, and defaults to point.
+
+When user option `image-recompute-map-p' is non-nil, the image's `:map'
+is recomputed to fit the newly transformed image."
(interactive "P")
(image--delayed-change-size (if n
(- 1 (/ (prefix-numeric-value n) 10.0))
@@ -1212,7 +1259,10 @@ POSITION can be a buffer position or a marker, and defaults to point."
(defun image-mouse-increase-size (&optional event)
"Increase the image size using the mouse-gesture EVENT.
This increases the size of the image at the position specified by
-EVENT, if any, by the default factor used by `image-increase-size'."
+EVENT, if any, by the default factor used by `image-increase-size'.
+
+When user option `image-recompute-map-p' is non-nil, the image's `:map'
+is recomputed to fit the newly transformed image."
(interactive "e")
(when (listp event)
(save-window-excursion
@@ -1222,7 +1272,10 @@ EVENT, if any, by the default factor used by `image-increase-size'."
(defun image-mouse-decrease-size (&optional event)
"Decrease the image size using the mouse-gesture EVENT.
This decreases the size of the image at the position specified by
-EVENT, if any, by the default factor used by `image-decrease-size'."
+EVENT, if any, by the default factor used by `image-decrease-size'.
+
+When user option `image-recompute-map-p' is non-nil, the image's `:map'
+is recomputed to fit the newly transformed image."
(interactive "e")
(when (listp event)
(save-window-excursion
@@ -1273,7 +1326,9 @@ POSITION can be a buffer position or a marker, and defaults to point."
(new-image (image--image-without-parameters image))
(scale (image--current-scaling image new-image)))
(setcdr image (cdr new-image))
- (plist-put (cdr image) :scale (* scale factor))))
+ (plist-put (cdr image) :scale (* scale factor))
+ (when (and (image-property image :original-map) image-recompute-map-p)
+ (setf (image-property image :map) (image--compute-map image)))))
(defun image--image-without-parameters (image)
(cons (pop image)
@@ -1300,7 +1355,10 @@ POSITION can be a buffer position or a marker, and defaults to point."
If nil, ANGLE defaults to 90. Interactively, rotate the image 90
degrees clockwise with no prefix argument, and counter-clockwise
with a prefix argument. Note that most image types support
-rotations by only multiples of 90 degrees."
+rotations by only multiples of 90 degrees.
+
+When user option `image-recompute-map-p' is non-nil, the image's `:map'
+is recomputed to fit the newly transformed image."
(interactive (and current-prefix-arg '(-90)))
(let ((image (image--get-imagemagick-and-warn)))
(setf (image-property image :rotation)
@@ -1308,7 +1366,9 @@ rotations by only multiples of 90 degrees."
(or angle 90))
;; We don't want to exceed 360 degrees rotation,
;; because it's not seen as valid in Exif data.
- 360))))
+ 360)))
+ (when (and (image-property image :original-map) image-recompute-map-p)
+ (setf (image-property image :map) (image--compute-map image))))
(set-transient-map image--repeat-map nil nil
"Use %k for further adjustments"))
@@ -1329,23 +1389,190 @@ changing the displayed image size does not affect the saved image."
(read-file-name "Write image to file: ")))))
(defun image-flip-horizontally ()
- "Horizontally flip the image under point."
+ "Horizontally flip the image under point.
+
+When user option `image-recompute-map-p' is non-nil, the image's `:map'
+is recomputed to fit the newly transformed image."
(interactive)
(let ((image (image--get-image)))
(image-flush image)
(setf (image-property image :flip)
- (not (image-property image :flip)))))
+ (not (image-property image :flip)))
+ (when (and (image-property image :original-map) image-recompute-map-p)
+ (setf (image-property image :map) (image--compute-map image)))))
(defun image-flip-vertically ()
- "Vertically flip the image under point."
+ "Vertically flip the image under point.
+
+When user option `image-recompute-map-p' is non-nil, the image's `:map'
+is recomputed to fit the newly transformed image."
(interactive)
(let ((image (image--get-image)))
(image-rotate 180)
(setf (image-property image :flip)
- (not (image-property image :flip)))))
+ (not (image-property image :flip)))
+ (when (and (image-property image :original-map) image-recompute-map-p)
+ (setf (image-property image :map) (image--compute-map image)))))
(define-obsolete-function-alias 'image-refresh #'image-flush "29.1")
+;;; Map transformation
+
+(defcustom image-recompute-map-p t
+ "Recompute image map when scaling, rotating, or flipping an image."
+ :type 'boolean
+ :version "30.1")
+
+(defun image--compute-map (image)
+ "Compute map for IMAGE suitable to be used as its :map property.
+Return a copy of :original-image transformed based on IMAGE's :scale,
+:rotation, and :flip. When IMAGE's :original-map is nil, return nil.
+When :rotation is not a multiple of 90, return copy of :original-map."
+ (pcase-let* ((original-map (image-property image :original-map))
+ (map (copy-tree original-map t))
+ (scale (or (image-property image :scale) 1))
+ (rotation (or (image-property image :rotation) 0))
+ (flip (image-property image :flip))
+ ((and size `(,width . ,height)) (image-size image t)))
+ (when (and ; Handle only 90-degree rotations
+ (zerop (mod rotation 1))
+ (zerop (% (truncate rotation) 90)))
+ ;; SIZE fits MAP after transformations. Scale MAP before
+ ;; flip and rotate operations, since both need MAP to fit SIZE.
+ (image--scale-map map scale)
+ ;; In rendered images, rotation is always applied before flip.
+ (image--rotate-map
+ map rotation (if (or (= 90 rotation) (= 270 rotation))
+ ;; If rotated ±90°, swap width and height.
+ (cons height width)
+ size))
+ ;; After rotation, there's no need to swap width and height.
+ (image--flip-map map flip size))
+ map))
+
+(defun image--compute-original-map (image)
+ "Return original map for IMAGE.
+If IMAGE lacks :map property, return nil.
+When :rotation is not a multiple of 90, return copy of :map."
+ (when (image-property image :map)
+ (let* ((original-map (copy-tree (image-property image :map) t))
+ (scale (or (image-property image :scale) 1))
+ (rotation (or (image-property image :rotation) 0))
+ (flip (image-property image :flip))
+ (size (image-size image t)))
+ (when (and ; Handle only 90-degree rotations
+ (zerop (mod rotation 1))
+ (zerop (% (truncate rotation) 90)))
+ ;; In rendered images, rotation is always applied before flip.
+ ;; To undo the transformation, flip before rotating. SIZE fits
+ ;; ORIGINAL-MAP before transformations are applied. Therefore,
+ ;; scale ORIGINAL-MAP after flip and rotate operations, since
+ ;; both need ORIGINAL-MAP to fit SIZE.
+ (image--flip-map original-map flip size)
+ (image--rotate-map original-map (- rotation) size)
+ (image--scale-map original-map (/ 1.0 scale)))
+ original-map)))
+
+(defun image--scale-map (map scale)
+ "Scale MAP according to SCALE.
+Destructively modifies and returns MAP."
+ (unless (= 1 scale)
+ (pcase-dolist (`(,`(,type . ,coords) ,_id ,_plist) map)
+ (pcase-exhaustive type
+ ('rect
+ (setf (caar coords) (round (* (caar coords) scale)))
+ (setf (cdar coords) (round (* (cdar coords) scale)))
+ (setf (cadr coords) (round (* (cadr coords) scale)))
+ (setf (cddr coords) (round (* (cddr coords) scale))))
+ ('circle
+ (setf (caar coords) (round (* (caar coords) scale)))
+ (setf (cdar coords) (round (* (cdar coords) scale)))
+ (setcdr coords (round (* (cdr coords) scale))))
+ ('poly
+ (dotimes (i (length coords))
+ (aset coords i
+ (round (* (aref coords i) scale))))))))
+ map)
+
+(defun image--rotate-map (map rotation size)
+ "Rotate MAP according to ROTATION and SIZE.
+Destructively modifies and returns MAP."
+ (unless (zerop rotation)
+ (pcase-dolist (`(,`(,type . ,coords) ,_id ,_plist) map)
+ (pcase-exhaustive type
+ ('rect
+ (let ( x0 y0 ; New upper left corner
+ x1 y1) ; New bottom right corner
+ (pcase (truncate (mod rotation 360)) ; Set new corners to...
+ (90 ; ...old bottom left and upper right
+ (setq x0 (caar coords) y0 (cddr coords)
+ x1 (cadr coords) y1 (cdar coords)))
+ (180 ; ...old bottom right and upper left
+ (setq x0 (cadr coords) y0 (cddr coords)
+ x1 (caar coords) y1 (cdar coords)))
+ (270 ; ...old upper right and bottom left
+ (setq x0 (cadr coords) y0 (cdar coords)
+ x1 (caar coords) y1 (cddr coords))))
+ (setcar coords (image--rotate-coord x0 y0 rotation size))
+ (setcdr coords (image--rotate-coord x1 y1 rotation size))))
+ ('circle
+ (setcar coords (image--rotate-coord
+ (caar coords) (cdar coords) rotation size)))
+ ('poly
+ (dotimes (i (length coords))
+ (when (= 0 (% i 2))
+ (pcase-let ((`(,x . ,y)
+ (image--rotate-coord
+ (aref coords i) (aref coords (1+ i)) rotation size)))
+ (aset coords i x)
+ (aset coords (1+ i) y))))))))
+ map)
+
+(defun image--rotate-coord (x y angle size)
+ "Rotate coordinates X and Y by ANGLE in image of SIZE.
+ANGLE must be a multiple of 90. Returns a cons cell of rounded
+coordinates (X1 Y1)."
+ (pcase-let* ((radian (* (/ angle 180.0) float-pi))
+ (`(,width . ,height) size)
+ ;; y is positive, but we are in the bottom-right quadrant
+ (y (- y))
+ ;; Rotate clockwise
+ (x1 (+ (* (sin radian) y) (* (cos radian) x)))
+ (y1 (- (* (cos radian) y) (* (sin radian) x)))
+ ;; Translate image back into bottom-right quadrant
+ (`(,x1 . ,y1)
+ (pcase (truncate (mod angle 360))
+ (90 ; Translate right by height
+ (cons (+ x1 height) y1))
+ (180 ; Translate right by width and down by height
+ (cons (+ x1 width) (- y1 height)))
+ (270 ; Translate down by width
+ (cons x1 (- y1 width)))))
+ ;; Invert y1 to make both x1 and y1 positive
+ (y1 (- y1)))
+ (cons (round x1) (round y1))))
+
+(defun image--flip-map (map flip size)
+ "Horizontally flip MAP according to FLIP and SIZE.
+Destructively modifies and returns MAP."
+ (when flip
+ (pcase-dolist (`(,`(,type . ,coords) ,_id ,_plist) map)
+ (pcase-exhaustive type
+ ('rect
+ (let ((x0 (- (car size) (cadr coords)))
+ (y0 (cdar coords))
+ (x1 (- (car size) (caar coords)))
+ (y1 (cddr coords)))
+ (setcar coords (cons x0 y0))
+ (setcdr coords (cons x1 y1))))
+ ('circle
+ (setf (caar coords) (- (car size) (caar coords))))
+ ('poly
+ (dotimes (i (length coords))
+ (when (= 0 (% i 2))
+ (aset coords i (- (car size) (aref coords i)))))))))
+ map)
+
(provide 'image)
;;; image.el ends here
diff --git a/lisp/image/exif.el b/lisp/image/exif.el
index ad5a69dc179..2c1c4850bef 100644
--- a/lisp/image/exif.el
+++ b/lisp/image/exif.el
@@ -151,7 +151,7 @@ If the orientation isn't present in the data, return nil."
(defun exif--parse-jpeg ()
(unless (= (exif--read-number-be 2) #xffd8) ; SOI (start of image)
- (signal 'exif-error "Not a valid JPEG file"))
+ (signal 'exif-error '("Not a valid JPEG file")))
(cl-loop for segment = (exif--read-number-be 2)
for size = (exif--read-number-be 2)
;; Stop parsing when we get to SOS (start of stream);
@@ -168,7 +168,7 @@ If the orientation isn't present in the data, return nil."
;; The Exif data is in the APP1 JPEG chunk and starts with
;; "Exif\0\0".
(unless (equal (exif--read-chunk 6) (string ?E ?x ?i ?f ?\0 ?\0))
- (signal 'exif-error "Not a valid Exif chunk"))
+ (signal 'exif-error '("Not a valid Exif chunk")))
(delete-region (point-min) (point))
(let* ((endian-marker (exif--read-chunk 2))
(le (cond
@@ -180,14 +180,15 @@ If the orientation isn't present in the data, return nil."
t)
(t
(signal 'exif-error
- (format "Invalid endian-ness %s" endian-marker))))))
+ (list (format "Invalid endian-ness %s"
+ endian-marker)))))))
;; Another magical number.
(unless (= (exif--read-number 2 le) #x002a)
- (signal 'exif-error "Invalid TIFF header length"))
+ (signal 'exif-error '("Invalid TIFF header length")))
(let ((offset (exif--read-number 4 le)))
;; Jump to where the IFD (directory) starts and parse it.
(when (> (1+ offset) (point-max))
- (signal 'exif-error "Invalid IFD (directory) offset"))
+ (signal 'exif-error '("Invalid IFD (directory) offset")))
(goto-char (1+ offset))
(exif--parse-directory le)))))
@@ -230,7 +231,7 @@ If the orientation isn't present in the data, return nil."
(when (> (+ (1+ value) length)
(point-max))
(signal 'exif-error
- "Premature end of file"))
+ '("Premature end of file")))
(buffer-substring
(1+ value)
(+ (1+ value) length)))
@@ -248,7 +249,7 @@ If the orientation isn't present in the data, return nil."
;; keep parsing.
(progn
(when (> (1+ next) (point-max))
- (signal 'exif-error "Invalid IFD (directory) next-offset"))
+ (signal 'exif-error '("Invalid IFD (directory) next-offset")))
(goto-char (1+ next))
(nconc dir (exif--parse-directory le)))
;; We've reached the end of the directories.
@@ -287,7 +288,7 @@ VALUE is little-endian, otherwise it is big-endian."
"Return BYTES octets from the current buffer and advance point that much.
This function assumes that the current buffer is unibyte."
(when (> (+ (point) bytes) (point-max))
- (signal 'exif-error "Premature end of file"))
+ (signal 'exif-error '("Premature end of file")))
(prog1
(buffer-substring (point) (+ (point) bytes))
(forward-char bytes)))
@@ -297,7 +298,7 @@ This function assumes that the current buffer is unibyte."
Advance point to after the read bytes.
This function assumes that the current buffer is unibyte."
(when (> (+ (point) bytes) (point-max))
- (signal 'exif-error "Premature end of file"))
+ (signal 'exif-error '("Premature end of file")))
(let ((sum 0))
(dotimes (_ bytes)
(setq sum (+ (* sum 256) (following-char)))
@@ -309,7 +310,7 @@ This function assumes that the current buffer is unibyte."
Advance point to after the read bytes.
This function assumes that the current buffer is unibyte."
(when (> (+ (point) bytes) (point-max))
- (signal 'exif-error "Premature end of file"))
+ (signal 'exif-error '("Premature end of file")))
(let ((sum 0))
(dotimes (i bytes)
(setq sum (+ (* (following-char) (expt 256 i)) sum))
diff --git a/lisp/image/image-dired-dired.el b/lisp/image/image-dired-dired.el
index f4778d8e121..7219a106ca8 100644
--- a/lisp/image/image-dired-dired.el
+++ b/lisp/image/image-dired-dired.el
@@ -383,7 +383,7 @@ matching tag will be marked in the Dired buffer."
(file-name-directory curr-file)))
(setq curr-file (file-name-nondirectory curr-file))
(goto-char (point-min))
- (when (search-forward-regexp (format "\\s %s$" curr-file) nil t)
+ (when (search-forward-regexp (format "\\s %s[*@]?$" curr-file) nil t)
(setq hits (+ hits 1))
(dired-mark 1))))
(message "%d files with matching tag marked" hits)))
diff --git a/lisp/image/image-dired-external.el b/lisp/image/image-dired-external.el
index b92dfbaa6e8..8a73f518e6b 100644
--- a/lisp/image/image-dired-external.el
+++ b/lisp/image/image-dired-external.el
@@ -406,7 +406,8 @@ The new file will be named THUMBNAIL-FILE."
(not image-dired-rotate-original-ask-before-overwrite))
(progn
(copy-file image-dired-temp-rotate-image-file file t)
- (image-dired-refresh-thumb))
+ (image-dired-refresh-thumb)
+ (image-dired-update-thumbnail-at-point))
(image-dired-display-image file))))))
diff --git a/lisp/image/image-dired-util.el b/lisp/image/image-dired-util.el
index f589d44d8cb..c3860cb0b0a 100644
--- a/lisp/image/image-dired-util.el
+++ b/lisp/image/image-dired-util.el
@@ -31,6 +31,7 @@
(eval-when-compile (require 'cl-lib))
(defvar image-dired-dir)
+(defvar image-dired-thumb-naming)
(defvar image-dired-thumbnail-storage)
(defconst image-dired--thumbnail-standard-sizes
@@ -58,42 +59,59 @@ Create the thumbnail directory if it does not exist."
(message "Thumbnail directory created: %s" image-dired-dir))
image-dired-dir))
+(defun image-dired-contents-sha1 (filename)
+ "Compute the SHA-1 of the first 4KiB of FILENAME's contents."
+ (with-temp-buffer
+ (insert-file-contents-literally filename nil 0 4096)
+ (sha1 (current-buffer))))
+
(defun image-dired-thumb-name (file)
"Return absolute file name for thumbnail FILE.
-Depending on the value of `image-dired-thumbnail-storage', the
-file name of the thumbnail will vary:
-- For `use-image-dired-dir', make a SHA1-hash of the image file's
- directory name and add that to make the thumbnail file name
- unique.
-- For `per-directory' storage, just add a subdirectory.
-- For `standard' storage, produce the file name according to the
- Thumbnail Managing Standard. Among other things, an MD5-hash
- of the image file's directory name will be added to the
- filename.
-See also `image-dired-thumbnail-storage'."
+Depending on the value of `image-dired-thumbnail-storage' and
+`image-dired-thumb-naming', the file name of the thumbnail will
+vary:
+
+- If `image-dired-thumbnail-storage' is set to one of the value
+ of `image-dired--thumbnail-standard-sizes', produce the file
+ name according to the Thumbnail Managing Standard. Among other
+ things, an MD5-hash of the image file's directory name will be
+ added to the file name.
+
+- Otherwise `image-dired-thumbnail-storage' is used to set the
+ directory where to store the thumbnail. In this latter case,
+ if `image-dired-thumbnail-storage' is set to `image-dired' the
+ file name given to the thumbnail depends on the value of
+ `image-dired-thumb-naming'.
+
+See also `image-dired-thumbnail-storage' and
+`image-dired-thumb-naming'."
(let ((file (expand-file-name file)))
- (cond ((memq image-dired-thumbnail-storage
- image-dired--thumbnail-standard-sizes)
- (let ((thumbdir (cl-case image-dired-thumbnail-storage
- (standard "thumbnails/normal")
- (standard-large "thumbnails/large")
- (standard-x-large "thumbnails/x-large")
- (standard-xx-large "thumbnails/xx-large"))))
- (expand-file-name
- ;; MD5 is mandated by the Thumbnail Managing Standard.
- (concat (md5 (concat "file://" file)) ".png")
- (expand-file-name thumbdir (xdg-cache-home)))))
- ((or (eq 'image-dired image-dired-thumbnail-storage)
- ;; Maintained for backwards compatibility:
- (eq 'use-image-dired-dir image-dired-thumbnail-storage))
- (expand-file-name (format "%s.jpg" (sha1 file))
- (image-dired-dir)))
- ((eq 'per-directory image-dired-thumbnail-storage)
- (expand-file-name (format "%s.thumb.jpg"
- (file-name-nondirectory file))
- (expand-file-name
- ".image-dired"
- (file-name-directory file)))))))
+ (if (memq image-dired-thumbnail-storage
+ image-dired--thumbnail-standard-sizes)
+ (let ((thumbdir (cl-case image-dired-thumbnail-storage
+ (standard "thumbnails/normal")
+ (standard-large "thumbnails/large")
+ (standard-x-large "thumbnails/x-large")
+ (standard-xx-large "thumbnails/xx-large"))))
+ (expand-file-name
+ ;; MD5 and PNG is mandated by the Thumbnail Managing
+ ;; Standard.
+ (concat (md5 (concat "file://" file)) ".png")
+ (expand-file-name thumbdir (xdg-cache-home))))
+ (let ((name (if (eq 'sha1-contents image-dired-thumb-naming)
+ (image-dired-contents-sha1 file)
+ ;; Defaults to SHA-1 of file name
+ (sha1 file))))
+ (cond ((or (eq 'image-dired image-dired-thumbnail-storage)
+ ;; Maintained for backwards compatibility:
+ (eq 'use-image-dired-dir image-dired-thumbnail-storage))
+ (expand-file-name (format "%s.jpg" name) (image-dired-dir)))
+ ((eq 'per-directory image-dired-thumbnail-storage)
+ (expand-file-name (format "%s.thumb.jpg"
+ (file-name-nondirectory file))
+ (expand-file-name
+ ".image-dired"
+ (file-name-directory file)))))))))
(defvar image-dired-thumbnail-buffer "*image-dired*"
"Image-Dired's thumbnail buffer.")
@@ -173,6 +191,23 @@ Should be used by commands in `image-dired-thumbnail-mode'."
"Return non-nil if there is an `image-dired' thumbnail at point."
(get-text-property (point) 'image-dired-thumbnail))
+(defun image-dired-update-thumbnail-at-point ()
+ "Update the thumbnail at point if the original image file has been modified.
+This function uncaches and removes the thumbnail file under the old name."
+ (when (image-dired-image-at-point-p)
+ (let* ((file (image-dired-original-file-name))
+ (thumb (expand-file-name (image-dired-thumb-name file)))
+ (image (get-text-property (point) 'display)))
+ (when image
+ (let ((old-thumb (plist-get (cdr image) :file)))
+ ;; When 'image-dired-thumb-naming' is set to
+ ;; 'sha1-contents', 'thumb' and 'old-thumb' could be
+ ;; different file names. Update the thumbnail then.
+ (unless (string= thumb old-thumb)
+ (setf (plist-get (cdr image) :file) thumb)
+ (clear-image-cache old-thumb)
+ (delete-file old-thumb)))))))
+
(defun image-dired-window-width-pixels (window)
"Calculate WINDOW width in pixels."
(declare (obsolete window-body-width "29.1"))
diff --git a/lisp/image/image-dired.el b/lisp/image/image-dired.el
index 26d5811f159..9eb68e240fe 100644
--- a/lisp/image/image-dired.el
+++ b/lisp/image/image-dired.el
@@ -162,8 +162,27 @@ to use the Thumbnail Managing Standard; they will be saved in
`image-dired-thumbnail-storage'."
:type 'directory)
+(defcustom image-dired-thumb-naming 'sha1-filename
+ "How `image-dired' names thumbnail files.
+When set to `sha1-filename' the name of thumbnail is built by
+computing the SHA-1 of the full file name of the image.
+
+When set to `sha1-contents' the name of thumbnail is built by
+computing the SHA-1 of first 4KiB of the image contents (See
+`image-dired-contents-sha1').
+
+In both case, a \"jpg\" extension is appended to save as JPEG.
+
+The value of this option is ignored if Image-Dired is customized
+to use the Thumbnail Managing Standard or the per-directory
+thumbnails setting. See `image-dired-thumbnail-storage'."
+ :type '(choice :tag "How to name thumbnail files"
+ (const :tag "SHA-1 of the image file name" sha1-filename)
+ (const :tag "SHA-1 of the image contents" sha1-contents))
+ :version "30.1")
+
(defcustom image-dired-thumbnail-storage 'image-dired
- "How `image-dired' stores thumbnail files.
+ "Where `image-dired' stores thumbnail files.
There are three ways that Image-Dired can store and generate
thumbnails:
@@ -189,6 +208,9 @@ thumbnails:
Set this user option to `per-directory'.
+To control the naming of thumbnails for alternative (2) above,
+customize the value of `image-dired-thumb-naming'.
+
To control the default size of thumbnails for alternatives (2)
and (3) above, customize the value of `image-dired-thumb-size'.
@@ -197,7 +219,7 @@ format, as mandated by that standard; otherwise save them as JPEG.
For more information on the Thumbnail Managing Standard, see:
https://specifications.freedesktop.org/thumbnail-spec/thumbnail-spec-latest.html"
- :type '(choice :tag "How to store thumbnail files"
+ :type '(choice :tag "Where to store thumbnail files"
(const :tag "Use image-dired-dir" image-dired)
(const :tag "Thumbnail Managing Standard (normal 128x128)"
standard)
@@ -424,11 +446,10 @@ This affects the following commands:
(file-name-nondirectory thumb-file)))
thumb-file))
-(defun image-dired-insert-thumbnail ( file original-file-name
- associated-dired-buffer image-number)
+(defun image-dired-insert-thumbnail (file original-file-name
+ associated-dired-buffer)
"Insert thumbnail image FILE.
-Add text properties ORIGINAL-FILE-NAME, ASSOCIATED-DIRED-BUFFER
-and IMAGE-NUMBER."
+Add text properties ORIGINAL-FILE-NAME, ASSOCIATED-DIRED-BUFFER."
(let (beg end)
(setq beg (point))
(image-dired-insert-image
@@ -452,7 +473,6 @@ and IMAGE-NUMBER."
'keymap nil
'original-file-name original-file-name
'associated-dired-buffer associated-dired-buffer
- 'image-number image-number
'tags (image-dired-list-tags original-file-name)
'mouse-face 'highlight
'comment (image-dired-get-comment original-file-name)))))
@@ -570,7 +590,7 @@ used or not. If non-nil, use `display-buffer' instead of
`image-dired-previous-line-and-display' where we do not want the
thumbnail buffer to be selected."
(interactive "P" nil dired-mode)
- (setq image-dired--generate-thumbs-start (current-time))
+ (setq image-dired--generate-thumbs-start (current-time))
(let ((buf (image-dired-create-thumbnail-buffer))
files dired-buf)
(if arg
@@ -587,8 +607,8 @@ thumbnail buffer to be selected."
(dolist (file files)
(when (string-match-p (image-dired--file-name-regexp) file)
(image-dired-insert-thumbnail
- (image-dired--get-create-thumbnail-file file) file dired-buf
- (cl-incf image-dired--number-of-thumbnails)))))
+ (image-dired--get-create-thumbnail-file file) file dired-buf)
+ (cl-incf image-dired--number-of-thumbnails))))
(if (> image-dired--number-of-thumbnails 0)
(if do-not-pop
(display-buffer buf)
@@ -704,21 +724,22 @@ On reaching end or beginning of buffer, stop and show a message."
(not (if reverse (bobp) (eobp))))
(forward-char (if reverse -1 1))))
-(defmacro image-dired--movement-command (to &optional reverse)
- `(progn
- (goto-char ,to)
- (image-dired--movement-ensure-point-pos ,reverse)
- (when image-dired-track-movement
- (image-dired-track-original-file))
- (image-dired--update-header-line)))
-
-(defmacro image-dired--movement-command-line (&optional reverse)
- `(image-dired--movement-command
- (let ((goal-column (current-column)))
- (forward-line ,(if reverse -1 1))
- (move-to-column goal-column)
- (point))
- ,reverse))
+(defun image-dired--update-after-move (reverse)
+ "Book-keeping after move."
+ (image-dired--movement-ensure-point-pos reverse)
+ (when image-dired-track-movement
+ (image-dired-track-original-file))
+ (image-dired--update-header-line))
+
+(defun image-dired--movement-command (to &optional reverse)
+ (goto-char to)
+ (image-dired--update-after-move reverse))
+
+(defun image-dired--movement-command-line (&optional reverse)
+ (let ((goal-column (current-column)))
+ (forward-line (if reverse -1 1))
+ (move-to-column goal-column)
+ (image-dired--update-after-move reverse)))
(defun image-dired-next-line ()
"Move to next line in the thumbnail buffer."
@@ -750,6 +771,21 @@ On reaching end or beginning of buffer, stop and show a message."
(interactive nil image-dired-thumbnail-mode)
(image-dired--movement-command (pos-eol) 'reverse))
+(defun image-dired-scroll (&optional down)
+ "Scroll in the thumbnail buffer."
+ (let ((goal-column (current-column)))
+ (if down (scroll-down) (scroll-up))
+ (move-to-column goal-column)
+ (image-dired--update-after-move down)))
+
+(defun image-dired-scroll-up ()
+ (interactive nil image-dired-thumbnail-mode)
+ (image-dired-scroll))
+
+(defun image-dired-scroll-down ()
+ (interactive nil image-dired-thumbnail-mode)
+ (image-dired-scroll 'down))
+
;;; Header line
@@ -789,7 +825,10 @@ comment."
(let ((file-name (image-dired-original-file-name))
(dired-buf (buffer-name (image-dired-associated-dired-buffer)))
(image-count (format "%s/%s"
- (get-text-property (point) 'image-number)
+ ;; Line-up adds one space between two
+ ;; images: this formula takes this into
+ ;; account.
+ (1+ (/ (point) 2))
image-dired--number-of-thumbnails))
(props (string-join (get-text-property (point) 'tags) ", "))
(comment (get-text-property (point) 'comment))
@@ -957,6 +996,8 @@ You probably want to use this together with
"<remap> <end-of-buffer>" #'image-dired-end-of-buffer
"<remap> <move-beginning-of-line>" #'image-dired-move-beginning-of-line
"<remap> <move-end-of-line>" #'image-dired-move-end-of-line
+ "<remap> <scroll-up-command>" #'image-dired-scroll-up
+ "<remap> <scroll-down-command>" #'image-dired-scroll-down
:menu
'("Image-Dired"
@@ -1127,10 +1168,12 @@ With a negative prefix argument, prompt user for the delay."
"Remove current thumbnail from thumbnail buffer and line up."
(interactive nil image-dired-thumbnail-mode)
(let ((inhibit-read-only t))
- (delete-char 1))
+ (delete-char 1)
+ (cl-decf image-dired--number-of-thumbnails))
(let ((pos (point)))
(image-dired--line-up-with-method)
- (goto-char pos)))
+ (goto-char pos)
+ (image-dired--update-header-line)))
(defun image-dired-line-up ()
"Line up thumbnails according to `image-dired-thumbs-per-row'.
@@ -1880,8 +1923,8 @@ when using per-directory thumbnail file storage"))
(if (file-exists-p image-dired-gallery-dir)
(if (not (file-directory-p image-dired-gallery-dir))
(error "Variable image-dired-gallery-dir is not a directory"))
- ;; FIXME: Should we set umask to 077 here, as we do for thumbnails?
- (make-directory image-dired-gallery-dir))
+ (with-file-modes #o700
+ (make-directory image-dired-gallery-dir)))
;; Open index file
(with-temp-file index-file
(if (file-exists-p index-file)
diff --git a/lisp/image/wallpaper.el b/lisp/image/wallpaper.el
index 34130c4f677..79682e921b0 100644
--- a/lisp/image/wallpaper.el
+++ b/lisp/image/wallpaper.el
@@ -432,6 +432,8 @@ See also `wallpaper-default-width'.")
;;; wallpaper-set
+(declare-function x-open-connection "xfns.c")
+
(defun wallpaper--x-monitor-name ()
"Get the monitor name for `wallpaper-set'.
On a graphical display, try using the same monitor as the current
diff --git a/lisp/imenu.el b/lisp/imenu.el
index 443a443faa1..f628936cedc 100644
--- a/lisp/imenu.el
+++ b/lisp/imenu.el
@@ -674,8 +674,8 @@ depending on PATTERNS."
(cons item (cdr menu)))))
;; Go to the start of the match, to make sure we
;; keep making progress backwards.
- (goto-char start))))
- (set-syntax-table old-table)))
+ (goto-char start)))))
+ (set-syntax-table old-table))
;; Sort each submenu by position.
;; This is in case one submenu gets items from two different regexps.
(dolist (item index-alist)
@@ -756,9 +756,11 @@ Returns t for rescan and otherwise an element or subelement of INDEX-ALIST."
(setq index-alist (imenu--split-submenus index-alist))
(let* ((menu (imenu--split-menu index-alist (or title (buffer-name))))
(map (imenu--create-keymap (car menu)
- (cdr (if (< 1 (length (cdr menu)))
- menu
- (car (cdr menu)))))))
+ (cdr (if (and (null (cddr menu))
+ (stringp (caadr menu))
+ (consp (cdadr menu)))
+ (cadr menu)
+ menu)))))
(popup-menu map event)))
(defun imenu-choose-buffer-index (&optional prompt alist)
@@ -854,13 +856,12 @@ A trivial interface to `imenu-add-to-menubar' suitable for use in a hook."
(buffer-name)))
(menu1 (imenu--create-keymap
(car menu)
- (cdr (if (or (< 1 (length (cdr menu)))
- ;; Have we a non-nested single entry?
- (atom (cdadr menu))
- (atom (cadadr menu)))
- menu
- (car (cdr menu))))
- 'imenu--menubar-select)))
+ (cdr (if (and (null (cddr menu))
+ (stringp (caadr menu))
+ (consp (cdadr menu)))
+ (cadr menu)
+ menu))
+ 'imenu--menubar-select)))
(setcdr imenu--menubar-keymap (cdr menu1)))))))
(defun imenu--menubar-select (item)
diff --git a/lisp/indent-aux.el b/lisp/indent-aux.el
new file mode 100644
index 00000000000..edcc6ffc22d
--- /dev/null
+++ b/lisp/indent-aux.el
@@ -0,0 +1,76 @@
+;;; indent-aux.el --- Autoloaded indentation commands for Emacs -*- lexical-binding:t -*-
+
+;; Copyright (C) 2023-2024 Free Software Foundation, Inc.
+
+;; Maintainer: emacs-devel@gnu.org
+;; Package: emacs
+
+;; This file is part of GNU Emacs.
+
+;; GNU Emacs is free software: you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+
+;; GNU Emacs is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>.
+
+;;; Commentary:
+
+;; Autoloaded commands for making and changing indentation in text and
+;; killed text
+
+;;; Code:
+
+
+
+;; Indent Filter mode. When enabled, this minor mode filters all
+;; killed text to remove leading indentation.
+
+(defun kill-ring-deindent-buffer-substring-function (beg end delete)
+ "Save the text within BEG and END to kill-ring, decreasing indentation.
+Delete the saved text if DELETE is non-nil.
+
+In the saved copy of the text, remove some of the indentation, such
+that the buffer position at BEG will be at column zero when the text
+is yanked."
+ (let ((a beg)
+ (b end))
+ (setq beg (min a b)
+ end (max a b)))
+ (let ((indentation (save-excursion (goto-char beg)
+ (current-column)))
+ (text (if delete
+ (delete-and-extract-region beg end)
+ (buffer-substring beg end))))
+ (with-temp-buffer
+ (insert text)
+ (indent-rigidly (point-min) (point-max)
+ (- indentation))
+ (buffer-string))))
+
+;;;###autoload
+(define-minor-mode kill-ring-deindent-mode
+ "Toggle removal of indentation from text saved to the kill ring.
+
+When this minor mode is enabled, text saved into the kill ring is
+indented towards the left by the column number at the start of
+that text."
+ :global 't
+ :group 'killing
+ (if kill-ring-deindent-mode
+ (add-function :override filter-buffer-substring-function
+ #'kill-ring-deindent-buffer-substring-function
+ '(:depth 100))
+ (remove-function filter-buffer-substring-function
+ #'kill-ring-deindent-buffer-substring-function)))
+
+
+
+(provide 'indent-aux)
+;;; indent-aux.el ends here.
diff --git a/lisp/indent.el b/lisp/indent.el
index 2f7c13368e5..74ef9183d95 100644
--- a/lisp/indent.el
+++ b/lisp/indent.el
@@ -190,7 +190,7 @@ prefix argument is ignored."
('nil t)
('eol (eolp))
('word (not (eql 2 syn)))
- ('word-or-paren (not (memql syn '(2 4 5))))
+ ('word-or-paren (not (memq syn '(2 4 5))))
('word-or-paren-or-punct (not (memq syn '(2 4 5 1))))))))
(completion-at-point))
diff --git a/lisp/info-look.el b/lisp/info-look.el
index b76150ecf78..cd59fdf17d7 100644
--- a/lisp/info-look.el
+++ b/lisp/info-look.el
@@ -1,5 +1,4 @@
;;; info-look.el --- major-mode-sensitive Info index lookup facility -*- lexical-binding: t -*-
-;; An older version of this was known as libc.el.
;; Copyright (C) 1995-1999, 2001-2024 Free Software Foundation, Inc.
@@ -28,11 +27,9 @@
;; Some additional sources of (Tex)info files for non-GNU packages:
;;
-;; Scheme: <URL:http://groups.csail.mit.edu/mac/ftpdir/scm/r5rs.info.tar.gz>
-;; LaTeX:
-;; <URL:http://ctan.tug.org/tex-archive/info/latex2e-help-texinfo/latex2e.texi>
+;; Scheme: https://groups.csail.mit.edu/mac/ftpdir/scm/r5rs.info.tar.gz
+;; LaTeX: https://mirrors.ctan.org/info/latex2e-help-texinfo/latex2e.texi
;; (or CTAN mirrors)
-;; Perl: <URL:http://ftp.cpan.org/pub/CPAN/doc/manual/texinfo/> (or CPAN mirrors)
;; Traditionally, makeinfo quoted `like this', but version 5 and later
;; quotes 'like this' or ‘like this’. Doc specs with patterns
@@ -56,13 +53,13 @@ Automatically becomes buffer local when set in any fashion.")
(make-variable-buffer-local 'info-lookup-mode)
(defcustom info-lookup-other-window-flag t
- "Non-nil means pop up the Info buffer in another window."
- :group 'info-lookup :type 'boolean)
+ "Non-nil means pop up the Info buffer in another window."
+ :type 'boolean)
(defcustom info-lookup-highlight-face 'match
"Face for highlighting looked up help items.
Setting this variable to nil disables highlighting."
- :group 'info-lookup :type 'face)
+ :type 'face)
(defvar info-lookup-highlight-overlay nil
"Overlay object used for highlighting.")
@@ -76,7 +73,7 @@ List elements are cons cells of the form
If a file name matches REGEXP, then use help mode MODE instead of the
buffer's major mode."
- :group 'info-lookup :type '(repeat (cons (regexp :tag "Regexp")
+ :type '(repeat (cons (regexp :tag "Regexp")
(symbol :tag "Mode"))))
(defvar info-lookup-history nil
@@ -170,13 +167,13 @@ the value of `:mode' as HELP-MODE, etc..
If no topic or mode option has been specified, then the help topic defaults
to `symbol', and the help mode defaults to the current major mode."
- (apply 'info-lookup-add-help* nil arg))
+ (apply #'info-lookup-add-help* nil arg))
(defun info-lookup-maybe-add-help (&rest arg)
"Add a help specification if none is defined.
See the documentation of the function `info-lookup-add-help'
for more details."
- (apply 'info-lookup-add-help* t arg))
+ (apply #'info-lookup-add-help* t arg))
(defun info-lookup-add-help* (maybe &rest arg)
(let (topic mode regexp ignore-case doc-spec
@@ -352,18 +349,18 @@ If optional argument QUERY is non-nil, query for the help mode."
(setq file-name-alist (cdr file-name-alist)))))
;; If major-mode has no setups in info-lookup-alist, under any topic, then
- ;; search up through derived-mode-parent to find a parent mode which does
- ;; have some setups. This means that a `define-derived-mode' with no
+ ;; search up through `derived-mode-all-parents' to find a parent mode which
+ ;; does have some setups. This means that a `define-derived-mode' with no
;; setups of its own will select its parent mode for lookups, if one of
;; its parents has some setups. Good for example on `makefile-gmake-mode'
;; and similar derivatives of `makefile-mode'.
;;
- (let ((mode major-mode)) ;; Look for `mode' with some setups.
- (while (and mode (not info-lookup-mode))
+ (let ((modes (derived-mode-all-parents major-mode))) ;; Look for `mode' with some setups.
+ (while (and modes (not info-lookup-mode))
(dolist (topic-cell info-lookup-alist) ;; Usually only two topics here.
- (if (info-lookup->mode-value (car topic-cell) mode)
- (setq info-lookup-mode mode)))
- (setq mode (get mode 'derived-mode-parent))))
+ (if (info-lookup->mode-value (car topic-cell) (car modes))
+ (setq info-lookup-mode (car modes))))
+ (setq modes (cdr modes))))
(or info-lookup-mode (setq info-lookup-mode major-mode)))
@@ -529,7 +526,7 @@ different window."
(nconc (condition-case nil
(info-lookup-make-completions topic mode)
(error nil))
- (apply 'append
+ (apply #'append
(mapcar (lambda (arg)
(info-lookup->completions topic arg))
refer-modes))))
@@ -988,9 +985,8 @@ Return nil if there is nothing appropriate in the buffer near point."
finally return "(python)Index")))))
(info-lookup-maybe-add-help
- :mode 'cperl-mode
- :regexp "[$@%][^a-zA-Z]\\|\\$\\^[A-Z]\\|[$@%]?[a-zA-Z][_a-zA-Z0-9]*"
- :other-modes '(perl-mode))
+ :mode 'perl-mode
+ :regexp "[$@%][^a-zA-Z]\\|\\$\\^[A-Z]\\|[$@%]?[a-zA-Z][_a-zA-Z0-9]*")
(info-lookup-maybe-add-help
:mode 'latex-mode
diff --git a/lisp/info-xref.el b/lisp/info-xref.el
index 7887909037b..95e9a1e55f7 100644
--- a/lisp/info-xref.el
+++ b/lisp/info-xref.el
@@ -79,9 +79,11 @@ If removing the last \"-<NUM>\" from the filename gives a file
which exists, then consider FILENAME a subfile. This is an
imperfect test, probably ought to open up the purported top file
and see what subfiles it says."
- (and (string-match "\\`\\(\\([^-]*-\\)*[^-]*\\)-[0-9]+\\(.*\\)\\'" filename)
- (file-exists-p (concat (match-string 1 filename)
- (match-string 3 filename)))))
+ (let ((nondir (file-name-nondirectory filename)))
+ (and (string-match "\\`\\(\\([^-]*-\\)*[^-]*\\)-[0-9]+\\(.*\\)\\'" nondir)
+ (file-exists-p (concat (file-name-directory filename)
+ (match-string 1 nondir)
+ (match-string 3 nondir))))))
(defmacro info-xref-with-file (filename &rest body)
;; checkdoc-params: (filename body)
diff --git a/lisp/info.el b/lisp/info.el
index 1c6df9a6ee5..176bc9c0033 100644
--- a/lisp/info.el
+++ b/lisp/info.el
@@ -213,6 +213,54 @@ a version of Emacs without installing it.")
These directories are searched after those in `Info-directory-list'."
:type '(repeat directory))
+(defcustom Info-url-alist
+ '((("auth" "autotype" "bovine" "calc" "ccmode" "cl" "dbus" "dired-x"
+ "ebrowse" "ede" "ediff" "edt" "efaq" "efaq-w32" "eglot" "eieio"
+ "eintr" "elisp" "emacs" "emacs-gnutls" "emacs-mime" "epa" "erc"
+ "ert" "eshell" "eudc" "eww" "flymake" "forms" "gnus"
+ "htmlfontify" "idlwave" "ido" "info" "mairix-el" "message"
+ "mh-e" "modus-themes" "newsticker" "nxml-mode" "octave-mode"
+ "org" "pcl-cvs" "pgg" "rcirc" "reftex" "remember" "sasl" "sc"
+ "semantic" "ses" "sieve" "smtpmail" "speedbar" "srecode"
+ "todo-mode" "tramp" "transient" "url" "use-package" "vhdl-mode"
+ "vip" "viper" "vtable" "widget" "wisent" "woman") .
+ "https://www.gnu.org/software/emacs/manual/html_node/%m/%e"))
+ "Alist telling `Info-mode' where manuals are accessible online.
+
+Each element of this list has the form (MANUALs . URL-SPEC).
+MANUALs represents the name of one or more manuals. It can
+either be a string or a list of strings. URL-SPEC can be a
+string in which the substring \"%m\" will be expanded to the
+manual-name and \"%n\" to the node-name. \"%e\" will expand to
+the URL-encoded node-name, including the `.html' extension; in
+case of the Top node, it will expand to the empty string. (The
+URL-encoding of the node-name mimics GNU Texinfo, as documented
+at Info node `(texinfo)HTML Xref Node Name Expansion'.)
+Alternatively, URL-SPEC can be a function which is given
+manual-name, node-name and URL-encoded node-name as arguments,
+and is expected to return the corresponding URL as a string.
+
+This variable particularly affects the command
+`Info-goto-node-web', which see.
+
+The default value of this variable refers to the official,
+HTTPS-accessible HTML-representations of all manuals that Emacs
+includes. These URLs refer to the most recently released version
+of Emacs, disregarding the version of the running Emacs. In
+other words, the content of your local Info node and the
+associated online node may differ. The resource represented by
+the generated URL may even be not found by the gnu.org server."
+ :version "30.1"
+ :type '(alist
+ :tag "Mapping from manual-name(s) to URL-specification"
+ :key-type (choice
+ (string :tag "A single manual-name")
+ (repeat :tag "List of manual-names" string))
+ :value-type (choice
+ (string :tag "URL-specification string")
+ (function
+ :tag "URL-specification function"))))
+
(defcustom Info-scroll-prefer-subnodes nil
"If non-nil, \\<Info-mode-map>\\[Info-scroll-up] in a menu visits subnodes.
@@ -452,6 +500,7 @@ or `Info-virtual-nodes'."
(".info.bz2" . ("bzip2" "-dc"))
(".info.xz" . "unxz")
(".info.zst" . ("zstd" "-dc"))
+ (".info.lz" . ("lzip" "-dc"))
(".info" . nil)
("-info.Z" . "uncompress")
("-info.Y" . "unyabba")
@@ -460,6 +509,7 @@ or `Info-virtual-nodes'."
("-info.z" . "gunzip")
("-info.xz" . "unxz")
("-info.zst" . ("zstd" "-dc"))
+ ("-info.lz" . ("lzip" "-dc"))
("-info" . nil)
("/index.Z" . "uncompress")
("/index.Y" . "unyabba")
@@ -468,6 +518,7 @@ or `Info-virtual-nodes'."
("/index.bz2" . ("bzip2" "-dc"))
("/index.xz" . "unxz")
("/index.zst" . ("zstd" "-dc"))
+ ("/index.lz" . ("lzip" "-dc"))
("/index" . nil)
(".Z" . "uncompress")
(".Y" . "unyabba")
@@ -476,6 +527,7 @@ or `Info-virtual-nodes'."
(".bz2" . ("bzip2" "-dc"))
(".xz" . "unxz")
(".zst" . ("zstd" "-dc"))
+ (".lz" . ("lzip" "-dc"))
("" . nil)))
"List of file name suffixes and associated decoding commands.
Each entry should be (SUFFIX . STRING); the file is given to
@@ -732,8 +784,53 @@ in `Info-file-supports-index-cookies-list'."
(read-file-name "Info file name: " nil nil t))
(if (numberp current-prefix-arg)
(format "*info*<%s>" current-prefix-arg))))
- (info-setup file-or-node
- (switch-to-buffer-other-window (or buffer "*info*"))))
+ (info-pop-to-buffer file-or-node buffer t))
+
+(defun info-pop-to-buffer (&optional file-or-node buffer-or-name other-window)
+ "Put Info node FILE-OR-NODE in specified buffer and display it.
+Optional argument FILE-OR-NODE is as for `info'.
+
+If the optional argument BUFFER-OR-NAME is a buffer, use that
+buffer. If it is a string, use that string as the name of the
+buffer, creating it if it does not exist. Otherwise, use a
+buffer with the name `*info*', creating it if it does not exist.
+
+Optional argument OTHER-WINDOW nil means to prefer the selected
+window. OTHER-WINDOW non-nil means to prefer another window.
+Select the window used, if it has been made."
+ (let ((buffer (cond
+ ((bufferp buffer-or-name)
+ buffer-or-name)
+ ((stringp buffer-or-name)
+ (get-buffer-create buffer-or-name))
+ (t
+ (get-buffer-create "*info*")))))
+ (with-current-buffer buffer
+ (unless (derived-mode-p 'Info-mode)
+ (Info-mode)))
+
+ (let* ((window
+ (display-buffer buffer
+ (if other-window
+ '(nil (inhibit-same-window . t))
+ '(display-buffer-same-window)))))
+ (with-current-buffer buffer
+ (if file-or-node
+ ;; If argument already contains parentheses, don't add another set
+ ;; since the argument will then be parsed improperly. This also
+ ;; has the added benefit of allowing node names to be included
+ ;; following the parenthesized filename.
+ (Info-goto-node
+ (if (and (stringp file-or-node) (string-match "(.*)" file-or-node))
+ file-or-node
+ (concat "(" file-or-node ")")))
+ (if (and (zerop (buffer-size))
+ (null Info-history))
+ ;; If we just created the Info buffer, go to the directory.
+ (Info-directory))))
+
+ (when window
+ (select-window window)))))
;;;###autoload (put 'info 'info-file (purecopy "emacs"))
;;;###autoload
@@ -768,8 +865,8 @@ See a list of available Info commands in `Info-mode'."
;; of names that might have been wrapped (in emails, etc.).
(setq file-or-node
(string-replace "\n" " " file-or-node)))
- (info-setup file-or-node
- (pop-to-buffer-same-window (or buffer "*info*"))))
+
+ (info-pop-to-buffer file-or-node buffer))
(defun info-setup (file-or-node buffer)
"Display Info node FILE-OR-NODE in BUFFER."
@@ -789,6 +886,8 @@ See a list of available Info commands in `Info-mode'."
;; If we just created the Info buffer, go to the directory.
(Info-directory))))
+(make-obsolete 'info-setup "use `info-pop-to-buffer' instead" "30.1")
+
;;;###autoload
(defun info-emacs-manual ()
"Display the Emacs manual in Info mode."
@@ -927,7 +1026,7 @@ If NOERROR, inhibit error messages when we can't find the node."
(setq nodename (info--node-canonicalize-whitespace nodename))
(setq filename (Info-find-file filename noerror))
;; Go into Info buffer.
- (or (derived-mode-p 'Info-mode) (switch-to-buffer "*info*"))
+ (or (derived-mode-p 'Info-mode) (info-pop-to-buffer filename))
;; Record the node we are leaving, if we were in one.
(and (not no-going-back)
Info-current-file
@@ -957,7 +1056,7 @@ otherwise, that defaults to `Top'."
"Go to an Info node FILENAME and NODENAME, re-reading disk contents.
When *info* is already displaying FILENAME and NODENAME, the window position
is preserved, if possible."
- (or (derived-mode-p 'Info-mode) (switch-to-buffer "*info*"))
+ (or (derived-mode-p 'Info-mode) (info-pop-to-buffer filename))
(let ((old-filename Info-current-file)
(old-nodename Info-current-node)
(window-selected (eq (selected-window) (get-buffer-window)))
@@ -1587,7 +1686,7 @@ escaped (\\\",\\\\)."
(let ((start 0)
(parameter-alist))
(while (string-match
- "\\s *\\([^=]+\\)=\\(?:\\([^\\s \"]+\\)\\|\\(?:\"\\(\\(?:[^\\\"]\\|\\\\[\\\"]\\)*\\)\"\\)\\)"
+ "\\s *\\([^=]+\\)=\\(?:\\([^\"[:space:]]+\\)\\|\\(?:\"\\(\\(?:[^\\\"]\\|\\\\[\\\"]\\)*\\)\"\\)\\)"
parameter-string start)
(setq start (match-end 0))
(push (cons (match-string 1 parameter-string)
@@ -1807,33 +1906,52 @@ By default, go to the current Info node."
(Info-url-for-node (format "(%s)%s" filename node)))))
(defun Info-url-for-node (node)
- "Return a URL for NODE, a node in the GNU Emacs or Elisp manual.
-NODE should be a string on the form \"(manual)Node\". Only emacs
-and elisp manuals are supported."
- (unless (string-match "\\`(\\(.+\\))\\(.+\\)\\'" node)
- (error "Invalid node name %s" node))
- (let ((manual (match-string 1 node))
- (node (match-string 2 node)))
- (unless (member manual '("emacs" "elisp"))
- (error "Only emacs/elisp manuals are supported"))
- ;; Encode a bunch of characters the way that makeinfo does.
- (setq node
- (mapconcat (lambda (ch)
- (if (or (< ch 32) ; ^@^A-^Z^[^\^]^^^-
- (<= 33 ch 47) ; !"#$%&'()*+,-./
- (<= 58 ch 64) ; :;<=>?@
- (<= 91 ch 96) ; [\]_`
- (<= 123 ch 127)) ; {|}~ DEL
- (format "_00%x" ch)
- (char-to-string ch)))
- node
- ""))
- (concat "https://www.gnu.org/software/emacs/manual/html_node/"
- manual "/"
- (and (not (equal node "Top"))
+ "Return the URL corresponding to NODE.
+
+NODE should be a string of the form \"(manual)Node\"."
+ ;; GNU Texinfo skips whitespaces and newlines between the closing
+ ;; parenthesis and the node-name, i.e. space, tab, line feed and
+ ;; carriage return.
+ (unless (string-match "\\`(\\(.+\\))[ \t\n\r]*\\(.+\\)\\'" node)
+ (error "Invalid node-name %s" node))
+ ;; Use `if-let*' instead of `let*' so we check if an association was
+ ;; found.
+ (if-let* ((manual (match-string 1 node))
+ (node (match-string 2 node))
+ (association (seq-find
+ (lambda (pair)
+ (seq-contains-p (ensure-list (car pair))
+ manual #'string-equal-ignore-case))
+ Info-url-alist))
+ (url-spec (cdr association))
+ (encoded-node
+ ;; Reproduce GNU Texinfo's way of URL-encoding.
+ ;; (info "(texinfo) HTML Xref Node Name Expansion")
+ (if (equal node "Top")
+ ""
(concat
- (url-hexify-string (string-replace " " "-" node))
- ".html")))))
+ (url-hexify-string
+ (string-replace " " "-"
+ (mapconcat
+ (lambda (ch)
+ (if (or (< ch 32) ; ^@^A-^Z^[^\^]^^^-
+ (<= 33 ch 47) ; !"#$%&'()*+,-./
+ (<= 58 ch 64) ; :;<=>?@
+ (<= 91 ch 96) ; [\]_`
+ (<= 123 ch 127)) ; {|}~ DEL
+ (format "_00%x" ch)
+ (char-to-string ch)))
+ node "")))
+ ".html"))))
+ (cond
+ ((stringp url-spec)
+ (format-spec url-spec
+ `((?m . ,manual) (?n . ,node) (?e . ,encoded-node))))
+ ((functionp url-spec)
+ (funcall url-spec manual node encoded-node))
+ (t (error "URL-specification neither string nor function")))
+ (error "No URL-specification associated with manual-name `%s'"
+ manual)))
(defvar Info-read-node-completion-table)
@@ -2290,7 +2408,7 @@ This command doesn't descend into sub-nodes, like \\<Info-mode-map>\\[Info-forwa
(interactive nil Info-mode)
;; In case another window is currently selected
(save-window-excursion
- (or (derived-mode-p 'Info-mode) (switch-to-buffer "*info*"))
+ (or (derived-mode-p 'Info-mode) (info-pop-to-buffer))
(Info-goto-node (Info-extract-pointer "next"))))
(defun Info-prev ()
@@ -2299,7 +2417,7 @@ This command doesn't go up to the parent node, like \\<Info-mode-map>\\[Info-bac
(interactive nil Info-mode)
;; In case another window is currently selected
(save-window-excursion
- (or (derived-mode-p 'Info-mode) (switch-to-buffer "*info*"))
+ (or (derived-mode-p 'Info-mode) (info-pop-to-buffer))
(Info-goto-node (Info-extract-pointer "prev[ious]*" "previous"))))
(defun Info-up (&optional same-file)
@@ -2308,7 +2426,7 @@ If SAME-FILE is non-nil, do not move to a different Info file."
(interactive nil Info-mode)
;; In case another window is currently selected
(save-window-excursion
- (or (derived-mode-p 'Info-mode) (switch-to-buffer "*info*"))
+ (or (derived-mode-p 'Info-mode) (info-pop-to-buffer))
(let ((old-node Info-current-node)
(old-file Info-current-file)
(node (Info-extract-pointer "up")) p)
@@ -4686,8 +4804,14 @@ the variable `Info-file-list-for-emacs'."
(eq command 'execute-extended-command))
(Info-goto-emacs-command-node
(read-command "Find documentation for command: ")))
+ ((symbolp command)
+ (Info-goto-emacs-command-node command))
(t
- (Info-goto-emacs-command-node command)))))
+ (message
+ (substitute-command-keys
+ (format
+ "\\`%s' invokes an anonymous command defined with `lambda'"
+ (key-description key))))))))
(defvar Info-link-keymap
(let ((keymap (make-sparse-keymap)))
@@ -5485,7 +5609,7 @@ completion alternatives to currently visited manuals."
(raise-frame (window-frame window))
(select-frame-set-input-focus (window-frame window))
(select-window window))
- (switch-to-buffer found)))
+ (info-pop-to-buffer nil found)))
;; The buffer doesn't exist; create it.
(info-initialize)
(info (Info-find-file manual)
diff --git a/lisp/international/characters.el b/lisp/international/characters.el
index c45ef3cb7db..1e5963f89f3 100644
--- a/lisp/international/characters.el
+++ b/lisp/international/characters.el
@@ -1303,12 +1303,13 @@ with L, LRE, or LRO Unicode bidi character type.")
(#x2E80 . #x2E99)
(#x2E9B . #x2EF3)
(#x2F00 . #x2FD5)
- (#x2FF0 . #x2FFB)
+ (#x2FF0 . #x2FFF)
(#x3000 . #x303E)
(#x3041 . #x3096)
(#x3099 . #x30FF)
(#x3105 . #x312F)
(#x3131 . #x31E3)
+ (#x31EF . #x31EF)
(#x31F0 . #x3247)
(#x3250 . #x4DBF)
(#x4E00 . #xA48C)
@@ -1394,6 +1395,174 @@ with L, LRE, or LRO Unicode bidi character type.")
(dolist (elt l)
(set-char-table-range char-width-table elt 2)))
+;; A: East Asian "Ambiguous" characters.
+(let ((l '((#x00A1 . #x00A1)
+ (#x00A4 . #x00A4)
+ (#x00A7 . #x00A8)
+ (#x00AA . #x00AA)
+ (#x00AD . #x00AE)
+ (#x00B0 . #x00B4)
+ (#x00B6 . #x00BA)
+ (#x00BC . #x00BF)
+ (#x00C6 . #x00C6)
+ (#x00D0 . #x00D0)
+ (#x00D7 . #x00D8)
+ (#x00E0 . #x00E1)
+ (#x00E6 . #x00E6)
+ (#x00E8 . #x00EA)
+ (#x00EC . #x00ED)
+ (#x00F0 . #x00F0)
+ (#x00F2 . #x00F3)
+ (#x00F7 . #x00FA)
+ (#x00FC . #x00FC)
+ (#x00FE . #x00FE)
+ (#x0101 . #x0101)
+ (#x0111 . #x0111)
+ (#x0113 . #x0113)
+ (#x011B . #x011B)
+ (#x0126 . #x0127)
+ (#x012B . #x012B)
+ (#x0131 . #x0133)
+ (#x0138 . #x0138)
+ (#x013F . #x0142)
+ (#x0144 . #x0144)
+ (#x0148 . #x014B)
+ (#x014D . #x014D)
+ (#x0152 . #x0153)
+ (#x0166 . #x0167)
+ (#x016B . #x016B)
+ (#x01CE . #x01CE)
+ (#x01D0 . #x01D0)
+ (#x01D2 . #x01D2)
+ (#x01D4 . #x01D4)
+ (#x01D6 . #x01D6)
+ (#x01D8 . #x01D8)
+ (#x01DA . #x01DA)
+ (#x01DC . #x01DC)
+ (#x0251 . #x0251)
+ (#x0261 . #x0261)
+ (#x02C4 . #x02C4)
+ (#x02C7 . #x02C7)
+ (#x02C9 . #x02CB)
+ (#x02CD . #x02CD)
+ (#x02D0 . #x02D0)
+ (#x02D8 . #x02DB)
+ (#x02DD . #x02DD)
+ (#x02DF . #x02DF)
+ (#x0300 . #x036F)
+ (#x0391 . #x03A1)
+ (#x03A3 . #x03A9)
+ (#x03B1 . #x03C1)
+ (#x03C3 . #x03C9)
+ (#x0401 . #x0401)
+ (#x0410 . #x044F)
+ (#x0451 . #x0451)
+ (#x2010 . #x2010)
+ (#x2013 . #x2016)
+ (#x2018 . #x2019)
+ (#x201C . #x201D)
+ (#x2020 . #x2022)
+ (#x2024 . #x2027)
+ (#x2030 . #x2030)
+ (#x2032 . #x2033)
+ (#x2035 . #x2035)
+ (#x203E . #x203E)
+ (#x2074 . #x2074)
+ (#x207F . #x207F)
+ (#x2081 . #x2084)
+ (#x20AC . #x20AC)
+ (#x2103 . #x2103)
+ (#x2105 . #x2105)
+ (#x2109 . #x2109)
+ (#x2113 . #x2113)
+ (#x2116 . #x2116)
+ (#x2121 . #x2122)
+ (#x2126 . #x2126)
+ (#x212B . #x212B)
+ (#x2153 . #x2154)
+ (#x215B . #x215E)
+ (#x2160 . #x216B)
+ (#x2170 . #x2179)
+ (#x2189 . #x2189)
+ (#x2190 . #x2199)
+ (#x21B8 . #x21B9)
+ (#x21D2 . #x21D2)
+ (#x21D4 . #x21D4)
+ (#x21E7 . #x21E7)
+ (#x2200 . #x2200)
+ (#x2202 . #x2203)
+ (#x2207 . #x2208)
+ (#x220B . #x220B)
+ (#x220F . #x220F)
+ (#x2211 . #x2211)
+ (#x2215 . #x2215)
+ (#x221A . #x221A)
+ (#x221D . #x2220)
+ (#x2223 . #x2223)
+ (#x2225 . #x2225)
+ (#x2227 . #x222C)
+ (#x222E . #x222E)
+ (#x2234 . #x2237)
+ (#x223C . #x223D)
+ (#x2248 . #x2248)
+ (#x224C . #x224C)
+ (#x2252 . #x2252)
+ (#x2260 . #x2261)
+ (#x2264 . #x2267)
+ (#x226A . #x226B)
+ (#x226E . #x226F)
+ (#x2282 . #x2283)
+ (#x2286 . #x2287)
+ (#x2295 . #x2295)
+ (#x2299 . #x2299)
+ (#x22A5 . #x22A5)
+ (#x22BF . #x22BF)
+ (#x2312 . #x2312)
+ (#x2460 . #x24E9)
+ (#x24EB . #x254B)
+ (#x2550 . #x2573)
+ (#x2580 . #x258F)
+ (#x2592 . #x2595)
+ (#x25A0 . #x25A1)
+ (#x25A3 . #x25A9)
+ (#x25B2 . #x25B3)
+ (#x25B6 . #x25B7)
+ (#x25BC . #x25BD)
+ (#x25C0 . #x25C1)
+ (#x25C6 . #x25C8)
+ (#x25CE . #x25D1)
+ (#x25E2 . #x25E5)
+ (#x25EF . #x25EF)
+ (#x2605 . #x2606)
+ (#x260E . #x260F)
+ (#x261C . #x261C)
+ (#x261E . #x261E)
+ (#x2640 . #x2640)
+ (#x2642 . #x2642)
+ (#x2660 . #x2661)
+ (#x2663 . #x2665)
+ (#x2667 . #x266A)
+ (#x266C . #x266D)
+ (#x266F . #x266F)
+ (#x269E . #x269F)
+ (#x26BF . #x26BF)
+ (#x26C6 . #x26CD)
+ (#x26CF . #x26D3)
+ (#x26D5 . #x26E1)
+ (#x26E3 . #x26E3)
+ (#x26E8 . #x26E9)
+ (#x26EB . #x26F1)
+ (#x26F4 . #x26F4)
+ (#x26F6 . #x26F9)
+ (#x26FB . #x26FC)
+ (#x26FE . #x26FF)
+ (#x273D . #x273D)
+ (#x2776 . #x277F)
+ (#x2B56 . #x2B59)
+ (#x3248 . #x324F))))
+ (dolist (elt l)
+ (set-char-table-range ambiguous-width-chars elt t)))
+
;; Other double width
;;(map-charset-chars
;; (lambda (range ignore) (set-char-table-range char-width-table range 2))
@@ -1427,6 +1596,45 @@ with L, LRE, or LRO Unicode bidi character type.")
(chinese-cns11643-1 (#x2121 . #x427E)))
(ko_KR nil (korean-ksc5601 (#x2121 . #x2C7E)))))
+(defun update-cjk-ambiguous-char-widths (locale-name)
+ "Update character widths for LOCALE-NAME using `ambiguous-width-chars'.
+LOCALE-NAME is the symbol of a CJK locale, such as \\='zh_CN."
+ (let ((slot (assq locale-name cjk-char-width-table-list)))
+ (or slot (error "Unknown locale for CJK language environment: %s"
+ locale-name))
+ ;; Force recomputation of child table in 'use-cjk-char-width-table'.
+ (setcar (cdr slot) nil)
+ (use-cjk-char-width-table locale-name)))
+
+
+(defcustom cjk-ambiguous-chars-are-wide t
+ "Whether the \"ambiguous-width\" characters take 2 columns on display.
+
+Some of the characters are defined by Unicode as being of \"ambiguous\"
+width: the actual width, either 1 column or 2 columns, should be
+determined at display time, depending on the language context.
+If this variable is non-nil, Emacs will consider these characters as
+full-width, i.e. taking 2 columns; otherwise they are narrow characters
+taking 1 column on display. Which value is correct depends on the
+fonts being used. In some CJK locales the fonts are set so that
+these characters are displayed as full-width. This setting is most
+important for text-mode frames, because there Emacs cannot access the
+metrics of the fonts used by the console or the terminal emulator.
+
+Do not set this directly via `setq'; instead, use `setopt' or the
+Customize commands. Alternatively, call `update-cjk-ambiguous-char-widths'
+passing it the symbol of the current locale environment, after changing
+the value of the variable with `setq'."
+ :type 'boolean
+ :set (lambda (symbol value)
+ (set-default symbol value)
+ (let ((locsym (get-language-info current-language-environment
+ 'cjk-locale-symbol)))
+ (when locsym
+ (update-cjk-ambiguous-char-widths locsym))))
+ :version "30.1"
+ :group 'display)
+
;; Internal use only.
;; Setup char-width-table appropriate for a language environment
;; corresponding to LOCALE-NAME (symbol).
@@ -1448,7 +1656,15 @@ with L, LRE, or LRO Unicode bidi character type.")
(car code-range) (cdr code-range)))))
(optimize-char-table table)
(set-char-table-parent table char-width-table)
- (setcar (cdr slot) table)))
+ (let ((tbl (make-char-table nil)))
+ (map-char-table
+ (lambda (range _val)
+ (set-char-table-range tbl range
+ (if cjk-ambiguous-chars-are-wide 2 1)))
+ ambiguous-width-chars)
+ (optimize-char-table tbl)
+ (set-char-table-parent tbl table)
+ (setcar (cdr slot) tbl))))
(setq char-width-table (nth 1 slot))))
(defun use-default-char-width-table ()
diff --git a/lisp/international/emoji.el b/lisp/international/emoji.el
index 3bb5c36e4c7..4f3aab5a6be 100644
--- a/lisp/international/emoji.el
+++ b/lisp/international/emoji.el
@@ -68,38 +68,91 @@ representing names. For instance:
(defvar emoji--all-bases nil)
(defvar emoji--derived nil)
(defvar emoji--names (make-hash-table :test #'equal))
-(defvar emoji--done-derived nil)
(define-multisession-variable emoji--recent (list "😀" "😖"))
(defvar emoji--insert-buffer)
-;;;###autoload
-(defun emoji-insert ()
+;;;###autoload (autoload 'emoji-insert "emoji" nil t)
+(transient-define-prefix emoji-insert ()
"Choose and insert an emoji glyph."
+ :variable-pitch t
+ [:class transient-columns
+ :setup-children emoji--setup-suffixes
+ :description emoji--group-description]
(interactive "*")
(emoji--init)
- (unless (fboundp 'emoji--command-Emoji)
- (emoji--define-transient))
- (funcall (intern "emoji--command-Emoji")))
+ (emoji--setup-prefix 'emoji-insert "Emoji" nil
+ `(("Recent" ,@(multisession-value emoji--recent))
+ ,@emoji--labels)))
-;;;###autoload
-(defun emoji-recent ()
+;;;###autoload (autoload 'emoji-recent "emoji" nil t)
+(transient-define-prefix emoji-recent ()
"Choose and insert one of the recently-used emoji glyphs."
+ :variable-pitch t
+ [:class transient-columns
+ :setup-children emoji--setup-suffixes
+ :description emoji--group-description]
(interactive "*")
(emoji--init)
- (unless (fboundp 'emoji--command-Emoji)
- (emoji--define-transient))
- (funcall (emoji--define-transient
- (cons "Recent" (multisession-value emoji--recent)) t)))
+ (emoji--setup-prefix 'emoji-recent "Recent" t
+ (multisession-value emoji--recent)))
-;;;###autoload
-(defun emoji-search ()
+;;;###autoload (autoload 'emoji-search "emoji" nil t)
+(transient-define-prefix emoji-search (glyph derived)
"Choose and insert an emoji glyph by typing its Unicode name.
This command prompts for an emoji name, with completion, and
inserts it. It recognizes the Unicode Standard names of emoji,
and also consults the `emoji-alternate-names' alist."
- (interactive "*")
- (emoji--init)
- (emoji--choose-emoji))
+ :variable-pitch t
+ [:class transient-columns
+ :setup-children emoji--setup-suffixes
+ :description emoji--group-description]
+ (interactive
+ (progn (barf-if-buffer-read-only)
+ (emoji--init)
+ (let ((cons (emoji--read-emoji)))
+ (list (car cons) (cdr cons)))))
+ (if derived
+ (emoji--setup-prefix 'emoji-search "Choose Emoji"
+ (list glyph)
+ (cons glyph derived))
+ (emoji--add-recent glyph)
+ (insert glyph)))
+
+(defclass emoji--narrow (transient-suffix)
+ ((title :initarg :title)
+ (done-derived :initarg :done-derived)
+ (children :initarg :children)))
+
+(defun emoji--setup-prefix (command title done-derived spec)
+ (transient-setup
+ command nil nil
+ :scope (if (eq transient-current-command command)
+ (cons (oref (transient-suffix-object) title)
+ (oref (transient-suffix-object) done-derived))
+ (cons title done-derived))
+ :value (if (eq transient-current-command command)
+ (oref (transient-suffix-object) children)
+ spec)))
+
+(defun emoji--setup-suffixes (_)
+ (transient-parse-suffixes
+ (oref transient--prefix command)
+ (pcase-let ((`(,title . ,done-derived) (oref transient--prefix scope)))
+ (emoji--layout (oref transient--prefix command) title
+ (oref transient--prefix value) done-derived))))
+
+(defun emoji--group-description ()
+ (car (oref transient--prefix scope)))
+
+(transient-define-suffix emoji-insert-glyph (glyph)
+ "Insert the emoji you selected."
+ (interactive
+ (list (if (string-prefix-p "emoji-" (symbol-name transient-current-command))
+ (oref (transient-suffix-object) description)
+ (car (multisession-value emoji--recent))))
+ not-a-mode)
+ (emoji--add-recent glyph)
+ (insert glyph))
;;;###autoload
(defun emoji-list ()
@@ -179,11 +232,10 @@ the name is not known."
'help-echo (emoji--name glyph))))
(insert "\n\n"))))
-(defun emoji--fontify-glyph (glyph &optional inhibit-derived)
+(defun emoji--fontify-glyph (glyph &optional done-derived)
(propertize glyph 'face
- (if (and (not inhibit-derived)
- (or (null emoji--done-derived)
- (not (gethash glyph emoji--done-derived)))
+ (if (and (not (or (eq done-derived t)
+ (member glyph done-derived)))
(gethash glyph emoji--derived))
;; If this emoji has derivations, use a special face
;; to tell the user.
@@ -206,35 +258,32 @@ the name is not known."
:interactive nil
(setq-local truncate-lines t))
-(defun emoji-list-select (event)
+;;;###autoload (autoload 'emoji-list-select "emoji" nil t)
+(transient-define-prefix emoji-list-select (event)
"Select the emoji under point."
+ :variable-pitch t
+ [:class transient-columns
+ :setup-children emoji--setup-suffixes
+ :description emoji--group-description]
(interactive (list last-nonmenu-event) emoji-list-mode)
(mouse-set-point event)
(let ((glyph (get-text-property (point) 'emoji-glyph)))
(unless glyph
(error "No emoji under point"))
- (let ((derived (gethash glyph emoji--derived))
- (end-func
- (lambda ()
- (let ((buf emoji--insert-buffer))
- (quit-window)
- (if (buffer-live-p buf)
- (progn
- (switch-to-buffer buf)
- (barf-if-buffer-read-only))
- (error "Buffer disappeared"))))))
- (if (not derived)
- ;; Glyph without derivations.
+ (let ((buf emoji--insert-buffer))
+ (quit-window)
+ (if (buffer-live-p buf)
(progn
- (emoji--add-recent glyph)
- (funcall end-func)
- (insert glyph))
- ;; Pop up a transient to choose between derivations.
- (let ((emoji--done-derived (make-hash-table :test #'equal)))
- (setf (gethash glyph emoji--done-derived) t)
- (funcall
- (emoji--define-transient (cons "Choose Emoji" (cons glyph derived))
- nil end-func)))))))
+ (switch-to-buffer buf)
+ (barf-if-buffer-read-only))
+ (error "Buffer disappeared")))
+ (let ((derived (gethash glyph emoji--derived)))
+ (if derived
+ (emoji--setup-prefix 'emoji-list-select "Choose Emoji"
+ (list glyph)
+ (cons glyph derived))
+ (emoji--add-recent glyph)
+ (insert glyph)))))
(defun emoji-list-help ()
"Display the name of the emoji at point."
@@ -478,97 +527,51 @@ the name is not known."
(setq parent elem))
(nconc elem (list glyph)))))
-(defun emoji--define-transient (&optional alist inhibit-derived
- end-function)
- (unless alist
- (setq alist (cons "Emoji" emoji--labels)))
- (let* ((mname (pop alist))
- (name (intern (format "emoji--command-%s" mname)))
- (emoji--done-derived (or emoji--done-derived
- (make-hash-table :test #'equal)))
- (has-subs (consp (cadr alist)))
- (layout
- (if has-subs
- ;; Define sub-maps.
- (cl-loop for entry in
- (emoji--compute-prefix
- (if (equal mname "Emoji")
- (cons (list "Recent") alist)
- alist))
- collect (list
- (car entry)
- (emoji--compute-name (cdr entry))
- (if (equal (cadr entry) "Recent")
- (emoji--recent-transient end-function)
- (emoji--define-transient
- (cons (concat mname " > " (cadr entry))
- (cddr entry))))))
- ;; Insert an emoji.
- (cl-loop for glyph in alist
- for i in (append (number-sequence ?a ?z)
- (number-sequence ?A ?Z)
- (number-sequence ?0 ?9)
- (number-sequence ?! ?/))
- collect (let ((this-glyph glyph))
- (list
- (string i)
- (emoji--fontify-glyph
- glyph inhibit-derived)
- (let ((derived
- (and (not inhibit-derived)
- (not (gethash glyph
- emoji--done-derived))
- (gethash glyph emoji--derived))))
- (if derived
- ;; We have a derived glyph, so add
- ;; another level.
- (progn
- (setf (gethash glyph
- emoji--done-derived)
- t)
- (emoji--define-transient
- (cons (concat mname " " glyph)
- (cons glyph derived))
- t end-function))
- ;; Insert the emoji.
- (lambda ()
- (interactive nil not-a-mode)
- ;; Allow switching to the correct
- ;; buffer.
- (when end-function
- (funcall end-function))
- (emoji--add-recent this-glyph)
- (insert this-glyph)))))))))
- (args (apply #'vector mname
- (emoji--columnize layout
- (if has-subs 2 8)))))
- ;; There's probably a better way to do this...
- (setf (symbol-function name)
- (lambda ()
- (interactive nil not-a-mode)
- (transient-setup name)))
- (pcase-let ((`(,class ,slots ,suffixes ,docstr ,_body)
- (transient--expand-define-args (list args))))
- (put name 'interactive-only t)
- (put name 'function-documentation docstr)
- (put name 'transient--prefix
- (apply (or class 'transient-prefix) :command name
- (cons :variable-pitch (cons t slots))))
- (put name 'transient--layout
- (transient-parse-suffixes name suffixes)))
- name))
-
-(defun emoji--recent-transient (end-function)
- "Create a function to display a dynamically generated menu."
- (lambda ()
- (interactive)
- (funcall (emoji--define-transient
- (cons "Recent" (multisession-value emoji--recent))
- t end-function))))
+(defun emoji--layout (command title spec done-derived)
+ (let ((has-subs (consp (cadr spec))))
+ (emoji--columnize
+ (if has-subs
+ (cl-loop for (key desc . glyphs) in (emoji--compute-prefix spec)
+ collect
+ (list key
+ (emoji--compute-name (cons desc glyphs))
+ command
+ :class 'emoji--narrow
+ :title (concat title " > " desc)
+ :done-derived (or (string-suffix-p "Recent" desc)
+ done-derived)
+ :children glyphs))
+ (cl-loop for glyph in spec
+ for char in (emoji--char-sequence)
+ for key = (string char)
+ for derived = (and (not (or (eq done-derived t)
+ (member glyph done-derived)))
+ (gethash glyph emoji--derived))
+ collect
+ (if derived
+ (list key
+ (emoji--fontify-glyph glyph done-derived)
+ command
+ :class 'emoji--narrow
+ :title (concat title " " glyph)
+ :done-derived (or (eq done-derived t)
+ (cons glyph done-derived))
+ :children (cons glyph derived))
+ (list key
+ (emoji--fontify-glyph glyph done-derived)
+ 'emoji-insert-glyph))))
+ (if has-subs 2 8))))
+
+(defun emoji--char-sequence ()
+ (append (number-sequence ?a ?z)
+ (number-sequence ?A ?Z)
+ (number-sequence ?0 ?9)
+ (number-sequence ?! ?/)))
(defun emoji--add-recent (glyph)
"Add GLYPH to the set of recently used emojis."
(let ((recent (multisession-value emoji--recent)))
+ (set-text-properties 0 (length glyph) nil glyph)
(setq recent (delete glyph recent))
(push glyph recent)
;; Shorten the list.
@@ -687,20 +690,6 @@ We prefer the earliest unique letter."
(cons glyph (gethash glyph emoji--derived)))
(user-error "You didn't specify an emoji"))))
-(defun emoji--choose-emoji ()
- (pcase-let ((`(,glyph . ,derived) (emoji--read-emoji)))
- (if (not derived)
- ;; Simple glyph with no derivations.
- (progn
- (emoji--add-recent glyph)
- (insert glyph))
- ;; Choose a derived version.
- (let ((emoji--done-derived (make-hash-table :test #'equal)))
- (setf (gethash glyph emoji--done-derived) t)
- (funcall
- (emoji--define-transient
- (cons "Choose Emoji" (cons glyph derived))))))))
-
(defvar-keymap emoji-zoom-map
"+" #'emoji-zoom-increase
"-" #'emoji-zoom-decrease
diff --git a/lisp/international/fontset.el b/lisp/international/fontset.el
index eff7165f791..33e444507c4 100644
--- a/lisp/international/fontset.el
+++ b/lisp/international/fontset.el
@@ -200,7 +200,10 @@
(symbol . [#x201C #x2200 #x2500])
(braille #x2800)
(ideographic-description #x2FF0)
- (cjk-misc #x300E)
+ ;; Noto Sans Phags Pa is broken and reuses the CJK misc code
+ ;; points for some of its own characters. Add one actual CJK
+ ;; character to prevent finding such broken fonts.
+ (cjk-misc #x300E #xff0c #x300a #xff09 #x5b50)
(kana #x304B)
(bopomofo #x3105)
(kanbun #x319D)
@@ -642,8 +645,14 @@
(nil . "microsoft-cp1251")
(nil . "koi8-r"))
- (arabic ,(font-spec :registry "iso10646-1"
- :otf '(arab nil (init medi fina liga)))
+ (arabic ,(if (featurep 'android)
+ ;; The Android font driver does not support the
+ ;; detection of OTF tags but all fonts installed on
+ ;; Android with Arabic characters provide shaping
+ ;; information required for displaying Arabic text.
+ (font-spec :registry "iso10646-1" :script 'arabic)
+ (font-spec :registry "iso10646-1"
+ :otf '(arab nil (init medi fina liga))))
(nil . "MuleArabic-0")
(nil . "MuleArabic-1")
(nil . "MuleArabic-2")
@@ -654,7 +663,9 @@
(hebrew ,(font-spec :registry "iso10646-1" :script 'hebrew)
(nil . "ISO8859-8"))
- (khmer ,(font-spec :registry "iso10646-1" :otf '(khmr nil (pres))))
+ (khmer ,(if (featurep 'android)
+ (font-spec :registry "iso10646-1" :script 'khmer)
+ (font-spec :registry "iso10646-1" :otf '(khmr nil (pres)))))
(kana (nil . "JISX0208*")
(nil . "GB2312.1980-0")
@@ -685,7 +696,11 @@
(nil . "JISX0213.2000-2")
(nil . "JISX0213.2004-1")
,(font-spec :registry "iso10646-1" :lang 'ja)
- ,(font-spec :registry "iso10646-1" :lang 'zh))
+ ,(font-spec :registry "iso10646-1" :lang 'zh)
+ ;; This is required, as otherwise many TrueType fonts with
+ ;; CJK characters but no corresponding ``design language''
+ ;; declaration can't be found.
+ ,(font-spec :registry "iso10646-1" :script 'han))
(cjk-misc (nil . "GB2312.1980-0")
(nil . "JISX0208*")
@@ -704,7 +719,11 @@
(nil . "JISX0213.2000-1")
(nil . "JISX0213.2000-2")
,(font-spec :registry "iso10646-1" :lang 'ja)
- ,(font-spec :registry "iso10646-1" :lang 'zh))
+ ,(font-spec :registry "iso10646-1" :lang 'zh)
+ ;; This is required, as otherwise many TrueType fonts
+ ;; with CJK characters but no corresponding ``design
+ ;; language'' declaration can't be found.
+ ,(font-spec :registry "iso10646-1" :script 'cjk-misc))
(hangul (nil . "KSC5601.1987-0")
,(font-spec :registry "iso10646-1" :lang 'ko))
@@ -1196,7 +1215,8 @@ Internal use only. Should be called at startup time."
(list (cons (purecopy "-cdac$") 1.3)))
(defvar x-font-name-charset-alist nil
- "This variable has no meaning now. Just kept for backward compatibility.")
+ "This variable has no meaning starting with Emacs 22.1.")
+(make-obsolete-variable 'x-font-name-charset-alist nil "30.1")
;;; XLFD (X Logical Font Description) format handler.
@@ -1262,9 +1282,8 @@ Return nil if PATTERN doesn't conform to XLFD."
(defun x-compose-font-name (fields &optional _reduce)
"Compose X fontname from FIELDS.
FIELDS is a vector of XLFD fields, of length 12.
-If a field is nil, wild-card letter `*' is embedded.
-Optional argument REDUCE exists just for backward compatibility,
-and is always ignored."
+If a field is nil, wild-card letter `*' is embedded."
+ (declare (advertised-calling-convention (fields) "30.1"))
(concat "-" (mapconcat (lambda (x) (or x "*")) fields "-")))
diff --git a/lisp/international/iso-transl.el b/lisp/international/iso-transl.el
index 52fbfd671a3..67659f7c265 100644
--- a/lisp/international/iso-transl.el
+++ b/lisp/international/iso-transl.el
@@ -293,6 +293,8 @@
("a<" . [?←])
("a>" . [?→])
("a=" . [?↔])
+ ("ae" . [?æ])
+ ("AE" . [?Æ])
("_-" . [?−])
("~=" . [?≈])
("/=" . [?≠])
diff --git a/lisp/international/ja-dic-cnv.el b/lisp/international/ja-dic-cnv.el
index c12e419125c..6f3a0c929c5 100644
--- a/lisp/international/ja-dic-cnv.el
+++ b/lisp/international/ja-dic-cnv.el
@@ -486,7 +486,7 @@ To get complete usage, invoke:
(defmacro skkdic-set-postfix (&rest entries)
`(defconst skkdic-postfix
',(let ((l entries)
- (map '(nil))
+ (map (list nil))
(longest 1)
len entry)
(while l
@@ -509,7 +509,7 @@ To get complete usage, invoke:
(defmacro skkdic-set-prefix (&rest entries)
`(defconst skkdic-prefix
',(let ((l entries)
- (map '(nil))
+ (map (list nil))
(longest 1)
len entry)
(while l
diff --git a/lisp/international/mule-cmds.el b/lisp/international/mule-cmds.el
index 2aa7e5b2e02..e80c42f523a 100644
--- a/lisp/international/mule-cmds.el
+++ b/lisp/international/mule-cmds.el
@@ -88,7 +88,8 @@
(bindings--define-key map [separator-3] menu-bar-separator)
(bindings--define-key map [set-terminal-coding-system]
'(menu-item "For Terminal" set-terminal-coding-system
- :enable (null (memq initial-window-system '(x w32 ns haiku pgtk)))
+ :enable (null (memq initial-window-system '(x w32 ns haiku pgtk
+ android)))
:help "How to encode terminal output"))
(bindings--define-key map [set-keyboard-coding-system]
'(menu-item "For Keyboard" set-keyboard-coding-system
@@ -349,9 +350,10 @@ This also sets the following values:
if CODING-SYSTEM is ASCII-compatible"
(check-coding-system coding-system)
(setq-default buffer-file-coding-system coding-system)
-
- (if (eq system-type 'darwin)
- ;; The file-name coding system on Darwin systems is always utf-8.
+ (if (or (eq system-type 'darwin)
+ (eq system-type 'android))
+ ;; The file-name coding system on Darwin and Android systems is
+ ;; always UTF-8.
(setq default-file-name-coding-system 'utf-8-unix)
(if (and (or (not coding-system)
(coding-system-get coding-system 'ascii-compatible-p)))
@@ -867,8 +869,7 @@ overrides ACCEPT-DEFAULT-P.
Kludgy feature: if FROM is a string, the string is the target text,
and TO is ignored."
- (if (not (listp default-coding-system))
- (setq default-coding-system (list default-coding-system)))
+ (setq default-coding-system (ensure-list default-coding-system))
(let ((no-other-defaults nil)
auto-cs)
@@ -2159,7 +2160,9 @@ See `set-language-info-alist' for use in programs."
(interactive
(list (read-language-name
'documentation
- (format-prompt "Describe language environment" current-language-environment))))
+ (format-prompt "Describe language environment"
+ current-language-environment)
+ current-language-environment)))
(let ((help-buffer-under-preparation t))
(if (null language-name)
(setq language-name current-language-environment))
diff --git a/lisp/international/mule-conf.el b/lisp/international/mule-conf.el
index d968906f2d0..1a58e9b7068 100644
--- a/lisp/international/mule-conf.el
+++ b/lisp/international/mule-conf.el
@@ -1600,7 +1600,7 @@ for decoding and encoding files, process I/O, etc."
(define-coding-system 'utf-7
"UTF-7 encoding of Unicode (RFC 2152)."
:coding-type 'utf-8
- :mnemonic ?U
+ :mnemonic ?u
:mime-charset 'utf-7
:charset-list '(unicode)
:pre-write-conversion 'utf-7-pre-write-conversion
@@ -1734,6 +1734,20 @@ included; callers should bind `case-fold-search' to t."
:version "27.1"
:group 'processes)
+;; (describe-char-fold-equivalences ?:)
+;; The last entry is taken from history.
+(defcustom password-colon-equivalents
+ '(?\u003a ; ?\N{COLON}
+ ?\uff1a ; ?\N{FULLWIDTH COLON}
+ ?\ufe55 ; ?\N{SMALL COLON}
+ ?\ufe13 ; ?\N{PRESENTATION FORM FOR VERTICAL COLON}
+ ?\u17d6 ; ?\N{KHMER SIGN CAMNUC PII KUUH}
+ )
+ "List of characters equivalent to trailing colon in \"password\" prompts."
+ :type '(repeat character)
+ :version "30.1"
+ :group 'processes)
+
;; The old code-pages library is obsoleted by coding systems based on
;; the charsets defined in this file but might be required by user
;; code.
diff --git a/lisp/international/ogonek.el b/lisp/international/ogonek.el
index 13feaee405a..4fddd2701d5 100644
--- a/lisp/international/ogonek.el
+++ b/lisp/international/ogonek.el
@@ -75,7 +75,7 @@ The codes are given in the following order:
Je/sli czytasz ten tekst, to albo przegl/adasz plik /xr/od/lowy
biblioteki `ogonek.el', albo wywo/la/le/s polecenie `ogonek-jak'.
W drugim przypadku mo/zesz usun/a/c tekst z ekranu, stosuj/ac
-polecenie `\\[kill-buffer]'.
+polecenie \\[kill-buffer].
Niniejsza biblioteka dostarcza funkcji do zmiany kodowania polskich
znak/ow diakrytycznych. Funkcje te mo/zna pogrupowa/c nast/epuj/aco.
@@ -174,7 +174,7 @@ znak/ow diakrytycznych. Funkcje te mo/zna pogrupowa/c nast/epuj/aco.
If you read this text then you are either looking at the library's
source text or you have called the `ogonek-how' command. In the
-latter case you may remove this text using `\\[kill-buffer]'.
+latter case you may remove this text using \\[kill-buffer].
The library provides functions for changing the encoding of Polish
diacritic characters, the ones with an `ogonek' below or above them.
diff --git a/lisp/international/quail.el b/lisp/international/quail.el
index b2f4adce4a3..48d2ccb8828 100644
--- a/lisp/international/quail.el
+++ b/lisp/international/quail.el
@@ -804,13 +804,12 @@ The format of KBD-LAYOUT is the same as `quail-keyboard-layout'."
(setq i (1+ i)))
(let ((pos (point))
- (bar "|")
+ (bar (propertize "|" 'face 'bold))
lower upper row)
;; Make table without horizontal lines. Each column for a key
;; has the form "| LU |" where L is for lower key and U is
;; for a upper key. If width of L (U) is greater than 1,
;; preceding (following) space is not inserted.
- (put-text-property 0 1 'face 'bold bar)
(setq i 0)
(while (< i quail-keyboard-layout-len)
(when (= (% i 30) 0)
@@ -1325,9 +1324,11 @@ If STR has `advice' text property, append the following special event:
;; binding in `universal-argument-map' just return
;; (list KEY), otherwise act as if there was no
;; overriding map.
- (or (not (eq (cadr overriding-terminal-local-map)
- universal-argument-map))
- (lookup-key overriding-terminal-local-map (vector key))))
+ ;; We used to do that only for `universal-argument-map',
+ ;; but according to bug#68338 this should also apply to
+ ;; other transient maps. Let's hope it's OK to apply it
+ ;; to all `overriding-terminal-local-map's.
+ (lookup-key overriding-terminal-local-map (vector key)))
overriding-local-map)
(list key)
(quail-setup-overlays (quail-conversion-keymap))
diff --git a/lisp/international/textsec.el b/lisp/international/textsec.el
index 41ff5b9a4bc..86429f15f7c 100644
--- a/lisp/international/textsec.el
+++ b/lisp/international/textsec.el
@@ -320,7 +320,8 @@ affected by bidi controls in STRING."
;; state at end of STRING which could then affect the following
;; text.
(insert string "a1א:!")
- (let ((pos (bidi-find-overridden-directionality 1 (point-max) nil)))
+ (let ((pos (bidi-find-overridden-directionality
+ (point-min) (point-max) nil)))
(and (fixnump pos)
(1- pos)))))
diff --git a/lisp/international/titdic-cnv.el b/lisp/international/titdic-cnv.el
index c4706e061e3..42584f6548c 100644
--- a/lisp/international/titdic-cnv.el
+++ b/lisp/international/titdic-cnv.el
@@ -31,12 +31,12 @@
;; Convert cxterm dictionary (of TIT format) to quail-package.
;;
;; Usage (within Emacs):
-;; M-x titdic-convert<CR>CXTERM-DICTIONARY-NAME<CR>
+;; M-x tit-dic-convert<CR>CXTERM-DICTIONARY-NAME<CR>
;; Usage (from shell):
-;; % emacs -batch -l titdic-cnv -f batch-titdic-convert\
+;; % emacs -batch -l titdic-cnv -f batch-tit-dic-convert\
;; [-dir DIR] [DIR | FILE] ...
;;
-;; When you run titdic-convert within Emacs, you have a chance to
+;; When you run `tit-dic-convert' within Emacs, you have a chance to
;; modify arguments of `quail-define-package' before saving the
;; converted file. For instance, you are likely to modify TITLE,
;; DOCSTRING, and KEY-BINDINGS.
@@ -90,7 +90,8 @@
;; \<quail-translation-docstring> is replaced by a description about
;; how to select a translation from a list of candidates.
-(defvar quail-cxterm-package-ext-info
+(define-obsolete-variable-alias 'quail-cxterm-package-ext-info 'tit-quail-cxterm-package-ext-info "30.1")
+(defvar tit-quail-cxterm-package-ext-info
'(("chinese-4corner" "四角")
("chinese-array30" "30")
("chinese-ccdospy" "缩拼"
@@ -277,7 +278,7 @@ SPC, 6, 3, 4, or 7 specifying a tone (SPC:陰平, 6:陽平, 3:上聲, 4:去聲,
(tit-moveleft ",<")
(tit-keyprompt nil))
- (generate-lisp-file-heading filename 'titdic-convert :code nil)
+ (generate-lisp-file-heading filename 'tit-dic-convert :code nil)
(princ ";; Quail package `")
(princ package)
(princ "\n")
@@ -354,7 +355,7 @@ SPC, 6, 3, 4, or 7 specifying a tone (SPC:陰平, 6:陽平, 3:上聲, 4:去聲,
(princ "(quail-define-package ")
;; Args NAME, LANGUAGE, TITLE
- (let ((title (nth 1 (assoc package quail-cxterm-package-ext-info))))
+ (let ((title (nth 1 (assoc package tit-quail-cxterm-package-ext-info))))
(princ "\"")
(princ package)
(princ "\" \"")
@@ -383,7 +384,7 @@ SPC, 6, 3, 4, or 7 specifying a tone (SPC:陰平, 6:陽平, 3:上聲, 4:去聲,
(let ((doc (concat tit-prompt "\n"))
(comments (if tit-comments
(mapconcat #'identity (nreverse tit-comments) "\n")))
- (doc-ext (nth 2 (assoc package quail-cxterm-package-ext-info))))
+ (doc-ext (nth 2 (assoc package tit-quail-cxterm-package-ext-info))))
(if comments
(setq doc (concat doc "\n" comments "\n")))
(if doc-ext
@@ -476,6 +477,9 @@ SPC, 6, 3, 4, or 7 specifying a tone (SPC:陰平, 6:陽平, 3:上聲, 4:去聲,
;;;###autoload
(defun titdic-convert (filename &optional dirname)
+ (declare (obsolete tit-dic-convert "30.1"))
+ (tit-dic-convert filename dirname))
+(defun tit-dic-convert (filename &optional dirname)
"Convert a TIT dictionary of FILENAME into a Quail package.
Optional argument DIRNAME if specified is the directory name under which
the generated Quail package is saved."
@@ -531,21 +535,24 @@ the generated Quail package is saved."
;;;###autoload
(defun batch-titdic-convert (&optional force)
- "Run `titdic-convert' on the files remaining on the command line.
+ (declare (obsolete batch-tit-dic-convert "30.1"))
+ (batch-tit-dic-convert force))
+(defun batch-tit-dic-convert (&optional force)
+ "Run `tit-dic-convert' on the files remaining on the command line.
Use this from the command line, with `-batch';
it won't work in an interactive Emacs.
-For example, invoke \"emacs -batch -f batch-titdic-convert XXX.tit\" to
+For example, invoke \"emacs -batch -f batch-tit-dic-convert XXX.tit\" to
generate Quail package file \"xxx.el\" from TIT dictionary file \"XXX.tit\".
-To get complete usage, invoke \"emacs -batch -f batch-titdic-convert -h\"."
+To get complete usage, invoke \"emacs -batch -f batch-tit-dic-convert -h\"."
(defvar command-line-args-left) ; Avoid compiler warning.
(if (not noninteractive)
- (error "`batch-titdic-convert' should be used only with -batch"))
+ (error "`batch-tit-dic-convert' should be used only with -batch"))
(if (string= (car command-line-args-left) "-h")
(progn
(message "To convert XXX.tit and YYY.tit into xxx.el and yyy.el:")
- (message " %% emacs -batch -l titdic-cnv -f batch-titdic-convert XXX.tit YYY.tit")
+ (message " %% emacs -batch -l titdic-cnv -f batch-tit-dic-convert XXX.tit YYY.tit")
(message "To convert XXX.tit into DIR/xxx.el:")
- (message " %% emacs -batch -l titdic-cnv -f batch-titdic-convert -dir DIR XXX.tit"))
+ (message " %% emacs -batch -l titdic-cnv -f batch-tit-dic-convert -dir DIR XXX.tit"))
(let (targetdir filename files file)
(if (string= (car command-line-args-left) "-dir")
(progn
@@ -564,7 +571,7 @@ To get complete usage, invoke \"emacs -batch -f batch-titdic-convert -h\"."
(when (or force
(file-newer-than-file-p
file (tit-make-quail-package-file-name file targetdir)))
- (titdic-convert file targetdir))
+ (tit-dic-convert file targetdir))
(setq files (cdr files)))
(setq command-line-args-left (cdr command-line-args-left)))))
(kill-emacs 0))
@@ -583,10 +590,11 @@ To get complete usage, invoke \"emacs -batch -f batch-titdic-convert -h\"."
;; COPYRIGHT-NOTICE ;; Copyright notice of the source dictionary.
;; )
-(defvar quail-misc-package-ext-info
+(define-obsolete-variable-alias 'quail-misc-package-ext-info 'tit-quail-misc-package-ext-info "30.1")
+(defvar tit-quail-misc-package-ext-info
'(("chinese-b5-tsangchi" "倉B"
"cangjie-table.b5" big5 "tsang-b5.el"
- tsang-b5-converter
+ tit--tsang-b5-converter
"\
;; # Copyright 2001 Christian Wittern <wittern@iis.sinica.edu.tw>
;; #
@@ -596,7 +604,7 @@ To get complete usage, invoke \"emacs -batch -f batch-titdic-convert -h\"."
("chinese-b5-quick" "簡B"
"cangjie-table.b5" big5 "quick-b5.el"
- quick-b5-converter
+ tit--quick-b5-converter
"\
;; # Copyright 2001 Christian Wittern <wittern@iis.sinica.edu.tw>
;; #
@@ -606,7 +614,7 @@ To get complete usage, invoke \"emacs -batch -f batch-titdic-convert -h\"."
("chinese-cns-tsangchi" "倉C"
"cangjie-table.cns" iso-2022-cn-ext "tsang-cns.el"
- tsang-cns-converter
+ tit--tsang-cns-converter
"\
;; # Copyright 2001 Christian Wittern <wittern@iis.sinica.edu.tw>
;; #
@@ -616,7 +624,7 @@ To get complete usage, invoke \"emacs -batch -f batch-titdic-convert -h\"."
("chinese-cns-quick" "簡C"
"cangjie-table.cns" iso-2022-cn-ext "quick-cns.el"
- quick-cns-converter
+ tit--quick-cns-converter
"\
;; # Copyright 2001 Christian Wittern <wittern@iis.sinica.edu.tw>
;; #
@@ -626,7 +634,7 @@ To get complete usage, invoke \"emacs -batch -f batch-titdic-convert -h\"."
("chinese-py" "拼G"
"pinyin.map" cn-gb-2312 "PY.el"
- py-converter
+ tit--py-converter
"\
;; \"pinyin.map\" is included in a free package called CCE. It is
;; available at: [link needs updating -- SK 2021-09-27]
@@ -654,7 +662,7 @@ To get complete usage, invoke \"emacs -batch -f batch-titdic-convert -h\"."
("chinese-ziranma" "自然"
"ziranma.cin" cn-gb-2312 "ZIRANMA.el"
- ziranma-converter
+ tit--ziranma-converter
"\
;; \"ziranma.cin\" is included in a free package called CCE. It is
;; available at: [link needs updating -- SK 2021-09-27]
@@ -682,7 +690,7 @@ To get complete usage, invoke \"emacs -batch -f batch-titdic-convert -h\"."
("chinese-ctlau" "刘粤"
"CTLau.html" cn-gb-2312 "CTLau.el"
- ctlau-gb-converter
+ tit--ctlau-gb-converter
"\
;; \"CTLau.html\" is available at:
;;
@@ -707,7 +715,7 @@ To get complete usage, invoke \"emacs -batch -f batch-titdic-convert -h\"."
("chinese-ctlaub" "劉粵"
"CTLau-b5.html" big5 "CTLau-b5.el"
- ctlau-b5-converter
+ tit--ctlau-b5-converter
"\
;; \"CTLau-b5.html\" is available at:
;;
@@ -740,7 +748,8 @@ To get complete usage, invoke \"emacs -batch -f batch-titdic-convert -h\"."
;; input method is for inputting Big5 characters. Otherwise the input
;; method is for inputting CNS characters.
-(defun tsang-quick-converter (dicbuf tsang-p big5-p)
+(define-obsolete-function-alias 'tsang-quick-converter #'tit--tsang-quick-converter "30.1")
+(defun tit--tsang-quick-converter (dicbuf tsang-p big5-p)
(let ((fulltitle (if tsang-p "倉頡" "簡易"))
dic)
(goto-char (point-max))
@@ -822,23 +831,28 @@ To get complete usage, invoke \"emacs -batch -f batch-titdic-convert -h\"."
(if big5-p (nth 1 elt) (nth 2 elt))))))
(insert ")\n")))
-(defun tsang-b5-converter (dicbuf)
- (tsang-quick-converter dicbuf t t))
+(define-obsolete-function-alias 'tsang-b5-converter #'tit--tsang-b5-converter "30.1")
+(defun tit--tsang-b5-converter (dicbuf)
+ (tit--tsang-quick-converter dicbuf t t))
-(defun quick-b5-converter (dicbuf)
- (tsang-quick-converter dicbuf nil t))
+(define-obsolete-function-alias 'quick-b5-converter #'tit--quick-b5-converter "30.1")
+(defun tit--quick-b5-converter (dicbuf)
+ (tit--tsang-quick-converter dicbuf nil t))
-(defun tsang-cns-converter (dicbuf)
- (tsang-quick-converter dicbuf t nil))
+(define-obsolete-function-alias 'tsang-cns-converter #'tit--tsang-cns-converter "30.1")
+(defun tit--tsang-cns-converter (dicbuf)
+ (tit--tsang-quick-converter dicbuf t nil))
-(defun quick-cns-converter (dicbuf)
- (tsang-quick-converter dicbuf nil nil))
+(define-obsolete-function-alias 'quick-cns-converter #'tit--quick-cns-converter "30.1")
+(defun tit--quick-cns-converter (dicbuf)
+ (tit--tsang-quick-converter dicbuf nil nil))
;; Generate a code of a Quail package in the current buffer from
;; Pinyin dictionary in the buffer DICBUF. The input method name of
;; the Quail package is NAME, and the title string is TITLE.
-(defun py-converter (dicbuf)
+(define-obsolete-function-alias 'py-converter #'tit--py-converter "30.1")
+(defun tit--py-converter (dicbuf)
(goto-char (point-max))
(insert (format "%S\n" "汉字输入∷拼音∷
@@ -913,7 +927,8 @@ method `chinese-tonepy' with which you must specify tones by digits
;; Ziranma dictionary in the buffer DICBUF. The input method name of
;; the Quail package is NAME, and the title string is TITLE.
-(defun ziranma-converter (dicbuf)
+(define-obsolete-function-alias 'ziranma-converter #'tit--ziranma-converter "30.1")
+(defun tit--ziranma-converter (dicbuf)
(let (dic)
(with-current-buffer dicbuf
(goto-char (point-min))
@@ -1022,7 +1037,8 @@ To input symbols and punctuation, type `/' followed by one of `a' to
;; method name of the Quail package is NAME, and the title string is
;; TITLE. DESCRIPTION is the string shown by describe-input-method.
-(defun ctlau-converter (dicbuf description)
+(define-obsolete-function-alias 'ctlau-converter #'tit--ctlau-converter "30.1")
+(defun tit--ctlau-converter (dicbuf description)
(goto-char (point-max))
(insert (format "%S\n" description))
(insert " '((\"\C-?\" . quail-delete-last-char)
@@ -1071,8 +1087,9 @@ To input symbols and punctuation, type `/' followed by one of `a' to
(forward-line 1)))
(insert ")\n"))
-(defun ctlau-gb-converter (dicbuf)
- (ctlau-converter dicbuf
+(define-obsolete-function-alias 'ctlau-gb-converter #'tit--ctlau-gb-converter "30.1")
+(defun tit--ctlau-gb-converter (dicbuf)
+ (tit--ctlau-converter dicbuf
"汉字输入∷刘锡祥式粤音∷
刘锡祥式粤语注音方案
@@ -1085,8 +1102,9 @@ To input symbols and punctuation, type `/' followed by one of `a' to
Some infrequent GB characters are accessed by typing \\, followed by
the Cantonese romanization of the respective radical (部首)."))
-(defun ctlau-b5-converter (dicbuf)
- (ctlau-converter dicbuf
+(define-obsolete-function-alias 'ctlau-b5-converter #'tit--ctlau-b5-converter "30.1")
+(defun tit--ctlau-b5-converter (dicbuf)
+ (tit--ctlau-converter dicbuf
"漢字輸入:劉錫祥式粵音:
劉錫祥式粵語注音方案
@@ -1101,14 +1119,15 @@ To input symbols and punctuation, type `/' followed by one of `a' to
(declare-function dos-8+3-filename "dos-fns.el" (filename))
-(defun miscdic-convert (filename &optional dirname)
+(define-obsolete-function-alias 'miscdic-convert #'tit-miscdic-convert "30.1")
+(defun tit-miscdic-convert (filename &optional dirname)
"Convert a dictionary file FILENAME into a Quail package.
Optional argument DIRNAME if specified is the directory name under which
the generated Quail package is saved."
(interactive "FInput method dictionary file: ")
(or (file-readable-p filename)
(error "%s does not exist" filename))
- (let ((tail quail-misc-package-ext-info)
+ (let ((tail tit-quail-misc-package-ext-info)
coding-system-for-write
slot
name title dicfile coding quailfile converter copyright)
@@ -1137,7 +1156,7 @@ the generated Quail package is saved."
;; Explicitly set eol format to `unix'.
(setq coding-system-for-write 'utf-8-unix)
(with-temp-file (expand-file-name quailfile dirname)
- (generate-lisp-file-heading quailfile 'miscdic-convert)
+ (generate-lisp-file-heading quailfile 'tit-miscdic-convert)
(insert (format-message ";; Quail package `%s'\n" name))
(insert ";; Source dictionary file: " dicfile "\n")
(insert ";; Copyright notice of the source file\n")
@@ -1164,15 +1183,17 @@ the generated Quail package is saved."
quailfile :inhibit-provide t :compile t :coding nil)))
(setq tail (cdr tail)))))
-(defun batch-miscdic-convert ()
- "Run `miscdic-convert' on the files remaining on the command line.
+;; Used in `Makefile.in'.
+(define-obsolete-function-alias 'batch-miscdic-convert #'batch-tit-miscdic-convert "30.1")
+(defun batch-tit-miscdic-convert ()
+ "Run `tit-miscdic-convert' on the files remaining on the command line.
Use this from the command line, with `-batch';
it won't work in an interactive Emacs.
If there's an argument \"-dir\", the next argument specifies a directory
to store generated Quail packages."
(defvar command-line-args-left) ; Avoid compiler warning.
(if (not noninteractive)
- (error "`batch-miscdic-convert' should be used only with -batch"))
+ (error "`batch-tit-miscdic-convert' should be used only with -batch"))
(let ((dir default-directory)
filename)
(while command-line-args-left
@@ -1186,11 +1207,13 @@ to store generated Quail packages."
(if (file-directory-p filename)
(dolist (file (directory-files filename t nil t))
(or (file-directory-p file)
- (miscdic-convert file dir)))
- (miscdic-convert filename dir))))
+ (tit-miscdic-convert file dir)))
+ (tit-miscdic-convert filename dir))))
(kill-emacs 0))
-(defun pinyin-convert ()
+;; Used in `Makefile.in'.
+(define-obsolete-function-alias 'pinyin-convert #'tit-pinyin-convert "30.1")
+(defun tit-pinyin-convert ()
"Convert text file pinyin.map into an elisp library.
The library is named pinyin.el, and contains the constant
`pinyin-character-map'."
diff --git a/lisp/isearch.el b/lisp/isearch.el
index f753a5377ca..a139a6fb84e 100644
--- a/lisp/isearch.el
+++ b/lisp/isearch.el
@@ -244,6 +244,10 @@ If you use `add-function' to modify this variable, you can use the
`isearch-message-prefix' advice property to specify the prefix string
displayed in the search message.")
+(defvar isearch-text-conversion-style nil
+ "Value of `text-conversion-style' before Isearch mode
+was enabled in this buffer.")
+
;; Search ring.
(defvar search-ring nil
@@ -278,13 +282,13 @@ Value is nil, t, or a function.
If nil, default to literal searches (note that `case-fold-search'
and `isearch-lax-whitespace' may still be applied).\\<isearch-mode-map>
-If t, default to regexp searches (as if typing `\\[isearch-toggle-regexp]' during
+If t, default to regexp searches (as if typing \\[isearch-toggle-regexp] during
isearch).
If a function, use that function as an `isearch-regexp-function'.
Example functions (and the keys to toggle them during isearch)
-are `word-search-regexp' \(`\\[isearch-toggle-word]'), `isearch-symbol-regexp'
-\(`\\[isearch-toggle-symbol]'), and `char-fold-to-regexp' \(`\\[isearch-toggle-char-fold]')."
+are `word-search-regexp' \(\\[isearch-toggle-word]), `isearch-symbol-regexp'
+\(\\[isearch-toggle-symbol]), and `char-fold-to-regexp' \(\\[isearch-toggle-char-fold])."
;; :type is set below by `isearch-define-mode-toggle'.
:type '(choice (const :tag "Literal search" nil)
(const :tag "Regexp search" t)
@@ -1221,6 +1225,8 @@ active region is added to the search string."
;; isearch-forward-regexp isearch-backward-regexp)
;; "List of commands for which isearch-mode does not recursive-edit.")
+(declare-function set-text-conversion-style "textconv.c")
+
(defun isearch-mode (forward &optional regexp op-fun recursive-edit regexp-function)
"Start Isearch minor mode.
It is called by the function `isearch-forward' and other related functions.
@@ -1237,6 +1243,8 @@ does not return to the calling function until the search is completed.
To behave this way it enters a recursive edit and exits it when done
isearching.
+Also display the on-screen keyboard if necessary.
+
The arg REGEXP-FUNCTION, if non-nil, should be a function. It is
used to set the value of `isearch-regexp-function'."
@@ -1332,6 +1340,25 @@ used to set the value of `isearch-regexp-function'."
(add-hook 'mouse-leave-buffer-hook 'isearch-mouse-leave-buffer)
(add-hook 'kbd-macro-termination-hook 'isearch-done)
+ ;; If the keyboard is not up and the last event did not come from
+ ;; a keyboard, bring it up so that the user can type.
+ ;;
+ ;; last-event-frame may be `macro', since people apparently make use
+ ;; of I-search in keyboard macros. (bug#65175)
+ (when (and (not (eq last-event-frame 'macro))
+ (or (not last-event-frame)
+ (not (eq (device-class last-event-frame
+ last-event-device)
+ 'keyboard))))
+ (frame-toggle-on-screen-keyboard (selected-frame) nil))
+
+ ;; Disable text conversion so that isearch can behave correctly.
+
+ (when (fboundp 'set-text-conversion-style)
+ (setq isearch-text-conversion-style
+ text-conversion-style)
+ (set-text-conversion-style nil))
+
;; isearch-mode can be made modal (in the sense of not returning to
;; the calling function until searching is completed) by entering
;; a recursive-edit and exiting it when done isearching.
@@ -1465,6 +1492,10 @@ NOPUSH is t and EDIT is t."
(setq isearch-tool-bar-old-map nil))
(kill-local-variable 'tool-bar-map))
+ ;; Restore the previous text conversion style.
+ (when (fboundp 'set-text-conversion-style)
+ (set-text-conversion-style isearch-text-conversion-style))
+
(force-mode-line-update)
;; If we ended in the middle of some intangible text,
@@ -4024,6 +4055,7 @@ since they have special meaning in a regexp."
(defvar isearch-lazy-highlight-point-max nil)
(defvar isearch-lazy-highlight-buffer nil)
(defvar isearch-lazy-highlight-case-fold-search nil)
+(defvar isearch-lazy-highlight-invisible nil)
(defvar isearch-lazy-highlight-regexp nil)
(defvar isearch-lazy-highlight-lax-whitespace nil)
(defvar isearch-lazy-highlight-regexp-lax-whitespace nil)
@@ -4069,6 +4101,8 @@ by other Emacs features."
isearch-lazy-highlight-window-group))
(not (eq isearch-lazy-highlight-case-fold-search
isearch-case-fold-search))
+ (not (eq isearch-lazy-highlight-invisible
+ isearch-invisible))
(not (eq isearch-lazy-highlight-regexp
isearch-regexp))
(not (eq isearch-lazy-highlight-regexp-function
@@ -4147,6 +4181,7 @@ by other Emacs features."
isearch-lazy-highlight-wrapped nil
isearch-lazy-highlight-last-string isearch-string
isearch-lazy-highlight-case-fold-search isearch-case-fold-search
+ isearch-lazy-highlight-invisible isearch-invisible
isearch-lazy-highlight-regexp isearch-regexp
isearch-lazy-highlight-lax-whitespace isearch-lax-whitespace
isearch-lazy-highlight-regexp-lax-whitespace isearch-regexp-lax-whitespace
@@ -4196,8 +4231,10 @@ Attempt to do the search exactly the way the pending Isearch would."
(isearch-forward isearch-lazy-highlight-forward)
;; Count all invisible matches, but highlight only
;; matches that can be opened by visiting them later
- (search-invisible (or (not (null isearch-lazy-count))
- 'can-be-opened))
+ (search-invisible
+ (or (not (null isearch-lazy-count))
+ (and (eq isearch-lazy-highlight-invisible 'open)
+ 'can-be-opened)))
(retry t)
(success nil))
;; Use a loop like in `isearch-search'.
@@ -4217,7 +4254,9 @@ Attempt to do the search exactly the way the pending Isearch would."
(when (or (not isearch-lazy-count)
;; Recheck the match that possibly was intended
;; for counting only, but not for highlighting
- (let ((search-invisible 'can-be-opened))
+ (let ((search-invisible
+ (and (eq isearch-lazy-highlight-invisible 'open)
+ 'can-be-opened)))
(funcall isearch-filter-predicate mb me)))
(let ((ov (make-overlay mb me)))
(push ov isearch-lazy-highlight-overlays)
@@ -4366,9 +4405,9 @@ Attempt to do the search exactly the way the pending Isearch would."
;; value `open' since then lazy-highlight
;; will open all overlays with matches.
(if (not (let ((search-invisible
- (if (eq search-invisible 'open)
+ (if (eq isearch-lazy-highlight-invisible 'open)
'can-be-opened
- search-invisible)))
+ isearch-lazy-highlight-invisible)))
(funcall isearch-filter-predicate mb me)))
(setq isearch-lazy-count-invisible
(1+ (or isearch-lazy-count-invisible 0)))
@@ -4641,6 +4680,7 @@ CASE-FOLD non-nil means the search was case-insensitive."
isearch-message message
isearch-case-fold-search case-fold)
(isearch-search)
+ (isearch-push-state)
(isearch-update))
diff --git a/lisp/jit-lock.el b/lisp/jit-lock.el
index 0779f64034b..05c0bd847b3 100644
--- a/lisp/jit-lock.el
+++ b/lisp/jit-lock.el
@@ -90,7 +90,8 @@ See also `jit-lock-stealth-nice'."
:type 'boolean)
-(defvaralias 'jit-lock-defer-contextually 'jit-lock-contextually)
+(define-obsolete-variable-alias 'jit-lock-defer-contextually
+ 'jit-lock-contextually "30.1")
(defcustom jit-lock-contextually 'syntax-driven
"If non-nil, fontification should be syntactically true.
If nil, refontification occurs only on lines that were modified. This
@@ -499,6 +500,7 @@ This applies to the buffer associated with marker START."
(setq start (point-min) end (max start end)))
;; Don't cause refontification (it's already been done), but just do
;; some random buffer change, so as to force redisplay.
+ (put-text-property start end 'fontified nil)
(put-text-property start end 'fontified t)))))
;;; Stealth fontification.
diff --git a/lisp/jsonrpc.el b/lisp/jsonrpc.el
index f2060d3faa1..5037d8c5b2b 100644
--- a/lisp/jsonrpc.el
+++ b/lisp/jsonrpc.el
@@ -4,7 +4,7 @@
;; Author: João Távora <joaotavora@gmail.com>
;; Keywords: processes, languages, extensions
-;; Version: 1.0.16
+;; Version: 1.0.25
;; Package-Requires: ((emacs "25.2"))
;; This is a GNU ELPA :core package. Avoid functionality that is not
@@ -43,7 +43,6 @@
(eval-when-compile (require 'subr-x))
(require 'warnings)
(require 'pcase)
-(require 'ert) ; to escape a `condition-case-unless-debug'
;;; Public API
@@ -52,6 +51,7 @@
(defclass jsonrpc-connection ()
((name
:accessor jsonrpc-name
+ :initform "anonymous"
:initarg :name
:documentation "A name for the connection")
(-request-dispatcher
@@ -65,31 +65,39 @@
:initarg :notification-dispatcher
:documentation "Dispatcher for remotely invoked notifications.")
(last-error
+ :initform nil
:accessor jsonrpc-last-error
:documentation "Last JSONRPC error message received from endpoint.")
- (-request-continuations
- :initform (make-hash-table)
- :accessor jsonrpc--request-continuations
- :documentation "A hash table of request ID to continuation lambdas.")
+ (-continuations
+ :initform nil
+ :accessor jsonrpc--continuations
+ :documentation "An alist of request IDs to continuation specs.")
(-events-buffer
+ :initform nil
:accessor jsonrpc--events-buffer
:documentation "A buffer pretty-printing the JSONRPC events")
- (-events-buffer-scrollback-size
- :initarg :events-buffer-scrollback-size
- :accessor jsonrpc--events-buffer-scrollback-size
- :documentation "Max size of events buffer. 0 disables, nil means infinite.")
+ (-events-buffer-config
+ :initform '(:size nil :format full)
+ :initarg :events-buffer-config
+ :documentation "Plist configuring the events buffer functions.")
(-deferred-actions
:initform (make-hash-table :test #'equal)
:accessor jsonrpc--deferred-actions
:documentation "Map (DEFERRED BUF) to (FN TIMER ID). FN is\
a saved DEFERRED `async-request' from BUF, to be sent not later\
than TIMER as ID.")
+ (-sync-request-alist ; bug#67945
+ :initform nil
+ :accessor jsonrpc--sync-request-alist
+ :documentation "List of ((ID [ANXIOUS...])) where ID refers \
+to a sync `jsonrpc-request' and each ANXIOUS to another completed\
+request that is higher up in the stack but couldn't run.")
(-next-request-id
:initform 0
:accessor jsonrpc--next-request-id
:documentation "Next number used for a request"))
:documentation "Base class representing a JSONRPC connection.
-The following initargs are accepted:
+The following keyword argument initargs are accepted:
:NAME (mandatory), a string naming the connection
@@ -103,7 +111,33 @@ RESULT) or signal an error of type `jsonrpc-error'.
:NOTIFICATION-DISPATCHER (optional), a function of three
arguments (CONN METHOD PARAMS) for handling JSONRPC
notifications. CONN, METHOD and PARAMS are the same as in
-:REQUEST-DISPATCHER.")
+:REQUEST-DISPATCHER.
+
+:EVENTS-BUFFER-CONFIG is a plist. Its `:size' stipulates the
+size of the log buffer (0 disables, nil means infinite). The
+`:format' property is a symbol for choosing the log entry format.")
+
+(cl-defmethod initialize-instance :after
+ ((c jsonrpc-connection) ((&key (events-buffer-scrollback-size
+ nil
+ e-b-s-s-supplied-p)
+ &allow-other-keys)
+ t))
+ (when e-b-s-s-supplied-p
+ (warn
+ "`:events-buffer-scrollback-size' deprecated. Use `events-buffer-config'.")
+ (with-slots ((plist -events-buffer-config)) c
+ (setf plist (copy-sequence plist)
+ plist (plist-put plist :size events-buffer-scrollback-size)))))
+
+(cl-defmethod slot-missing ((_c jsonrpc-connection)
+ (_n (eql :events-buffer-scrollback-size))
+ (_op (eql oset))
+ _)
+ ;; Yuck! But this just coerces EIEIO to backward-compatibly accept
+ ;; the :e-b-s-s initarg that is no longer associated with a slot
+ ;; #pineForCLOS..
+ )
;;; API mandatory
(cl-defgeneric jsonrpc-connection-send (conn &key id method params result error)
@@ -130,6 +164,41 @@ immediately."
(:method (_s _what) ;; by default all connections are ready
t))
+;;; API optional
+(cl-defgeneric jsonrpc-convert-to-endpoint (connection message subtype)
+ "Convert MESSAGE to JSONRPCesque message accepted by endpoint.
+MESSAGE is a plist, jsonrpc.el's internal representation of a
+JSONRPC message. SUBTYPE is one of `request', `reply' or
+`notification'.
+
+Return a plist to be serialized to JSON with `json-serialize' and
+transmitted to endpoint."
+ ;; TODO: describe representations and serialization in manual and
+ ;; link here.
+ (:method (_s message subtype)
+ `(:jsonrpc "2.0"
+ ,@(if (eq subtype 'reply)
+ ;; true JSONRPC doesn't have `method'
+ ;; fields in responses.
+ (cl-loop for (k v) on message by #'cddr
+ unless (eq k :method)
+ collect k and collect v)
+ message))))
+
+;;; API optional
+(cl-defgeneric jsonrpc-convert-from-endpoint (connection remote-message)
+ "Convert JSONRPC-esque REMOTE-MESSAGE to a plist.
+REMOTE-MESSAGE is a plist read with `json-parse'.
+
+Return a plist of jsonrpc.el's internal representation of a
+JSONRPC message."
+ ;; TODO: describe representations and serialization in manual and
+ ;; link here.
+ (:method (_s remote-message)
+ (cl-loop for (k v) on remote-message by #'cddr
+ unless (eq k :jsonrpc-json)
+ collect k and collect v)))
+
;;; Convenience
;;;
@@ -152,49 +221,107 @@ immediately."
(defun jsonrpc-forget-pending-continuations (connection)
"Stop waiting for responses from the current JSONRPC CONNECTION."
- (clrhash (jsonrpc--request-continuations connection)))
+ (setf (jsonrpc--continuations connection) nil))
+
+(defvar jsonrpc-inhibit-debug-on-error nil
+ "Inhibit `debug-on-error' when answering requests.
+Some extensions, notably ert.el, set `debug-on-error' to non-nil,
+which makes it hard to test the behavior of catching the Elisp
+error and replying to the endpoint with an JSONRPC-error. This
+variable can be set around calls like `jsonrpc-request' to
+circumvent that.")
-(defun jsonrpc-connection-receive (connection message)
- "Process MESSAGE just received from CONNECTION.
+(defun jsonrpc-connection-receive (conn foreign-message)
+ "Process FOREIGN-MESSAGE just received from CONN.
This function will destructure MESSAGE and call the appropriate
-dispatcher in CONNECTION."
- (cl-destructuring-bind (&key method id error params result _jsonrpc)
- message
- (let (continuations)
- (jsonrpc--log-event connection message 'server)
- (setf (jsonrpc-last-error connection) error)
- (cond
- (;; A remote request
- (and method id)
- (let* ((debug-on-error (and debug-on-error (not (ert-running-test))))
- (reply
- (condition-case-unless-debug _ignore
- (condition-case oops
- `(:result ,(funcall (jsonrpc--request-dispatcher connection)
- connection (intern method) params))
- (jsonrpc-error
- `(:error
- (:code
- ,(or (alist-get 'jsonrpc-error-code (cdr oops)) -32603)
- :message ,(or (alist-get 'jsonrpc-error-message
- (cdr oops))
- "Internal error")))))
- (error
- '(:error (:code -32603 :message "Internal error"))))))
- (apply #'jsonrpc--reply connection id reply)))
- (;; A remote notification
- method
- (funcall (jsonrpc--notification-dispatcher connection)
- connection (intern method) params))
- (;; A remote response
- (setq continuations
- (and id (gethash id (jsonrpc--request-continuations connection))))
- (let ((timer (nth 2 continuations)))
- (when timer (cancel-timer timer)))
- (remhash id (jsonrpc--request-continuations connection))
- (if error (funcall (nth 1 continuations) error)
- (funcall (nth 0 continuations) result))))
- (jsonrpc--call-deferred connection))))
+dispatcher in CONN."
+ (cl-destructuring-bind (&rest whole &key method id error params result _jsonrpc)
+ (jsonrpc-convert-from-endpoint conn foreign-message)
+ (unwind-protect
+ (let* ((log-plist (list :json (plist-get foreign-message :jsonrpc-json)
+ :kind (cond ((and method id) 'request)
+ (method 'notification)
+ (id 'reply))
+ :message whole
+ :foreign-message foreign-message))
+ (response-p (and (null method) id))
+ (cont (and response-p (jsonrpc--remove conn id))))
+ (cl-remf foreign-message :jsonrpc-json)
+ ;; Do this pre-processing of the response so we can always
+ ;; log richer information _before_ any non-local calls
+ ;; further ahead. Putting the `jsonrpc--event' as
+ ;; an unwind-form would make us log after the fact.
+ (when cont
+ (pcase-let ((`(,_ ,method ,_ ,_ ,_) cont))
+ (if (keywordp method)
+ (setq method (substring (symbol-name method) 1)))
+ ;; TODO: also set the depth
+ (setq whole (plist-put whole :method method))))
+
+ ;; Do the logging
+ (apply #'jsonrpc--event conn 'server log-plist)
+ (with-slots (last-error
+ (rdispatcher -request-dispatcher)
+ (ndispatcher -notification-dispatcher)
+ (sr-alist -sync-request-alist))
+ conn
+ (setf last-error error)
+ (cond
+ (;; A remote response whose request has been canceled
+ ;; (i.e. timeout or C-g)
+ ;;
+ (and response-p (null cont))
+ (jsonrpc--event
+ conn 'internal
+ :log-text
+ (format "Response to request %s which has been canceled"
+ id)
+ :id id)
+ ;; TODO: food for thought: this seems to be also where
+ ;; notifying the server of the cancellation would come
+ ;; in.
+ )
+ (;; A remote response that can't run yet (bug#67945)
+ (and response-p
+ (and sr-alist (not (eq id (caar sr-alist)))))
+ (jsonrpc--event
+ conn 'internal
+ :log-text
+ (format "anxious continuation to %s can't run, held up by %s"
+ id
+ (mapcar #'car sr-alist)))
+ (push (cons cont (list result error))
+ (cdr (car sr-alist))))
+ (;; A remote response that can continue now
+ response-p
+ (jsonrpc--continue conn id cont result error))
+ (;; A remote request
+ (and method id)
+ (let* ((debug-on-error (and debug-on-error
+ (not jsonrpc-inhibit-debug-on-error)))
+ (reply
+ (condition-case-unless-debug _ignore
+ (condition-case oops
+ `(:result ,(funcall rdispatcher conn (intern method)
+ params))
+ (jsonrpc-error
+ `(:error
+ (:code
+ ,(or (alist-get 'jsonrpc-error-code (cdr oops))
+ -32603)
+ :message ,(or (alist-get 'jsonrpc-error-message
+ (cdr oops))
+ "Internal error")))))
+ (error
+ '(:error (:code -32603 :message "Internal error"))))))
+ (apply #'jsonrpc--reply conn id method reply)))
+ (;; A remote notification
+ method
+ (funcall ndispatcher conn (intern method) params))
+ (t
+ (jsonrpc--event conn 'internal
+ :log-text "Malformed message" )))))
+ (jsonrpc--call-deferred conn))))
;;; Contacting the remote endpoint
@@ -215,7 +342,7 @@ object, using the keywords `:code', `:message' and `:data'."
(apply #'format-message (car args) (cdr args))))
(signal 'jsonrpc-error
`(,msg
- (jsonrpc-error-code . ,32603)
+ (jsonrpc-error-code . -32603)
(jsonrpc-error-message . ,msg))))
(cl-destructuring-bind (&key code message data) args
(signal 'jsonrpc-error
@@ -278,6 +405,7 @@ CANCEL-ON-INPUT-RETVAL. Any future replies (normal or error) are
ignored."
(let* ((tag (cl-gensym "jsonrpc-request-catch-tag")) id-and-timer
canceled
+ (throw-on-input nil)
(retval
(unwind-protect
(catch tag
@@ -286,6 +414,7 @@ ignored."
(apply
#'jsonrpc--async-request-1
connection method params
+ :sync-request t
:success-fn (lambda (result)
(unless canceled
(throw tag `(done ,result))))
@@ -308,15 +437,19 @@ ignored."
(setq canceled t))
`(canceled ,cancel-on-input-retval))
(t (while t (accept-process-output nil 30)))))
- ;; In normal operation, cancellation is handled by the
- ;; timeout function and response filter, but we still have
- ;; to protect against user-quit (C-g) or the
- ;; `cancel-on-input' case.
- (pcase-let* ((`(,id ,timer) id-and-timer))
- (remhash id (jsonrpc--request-continuations connection))
- (remhash (list deferred (current-buffer))
- (jsonrpc--deferred-actions connection))
- (when timer (cancel-timer timer))))))
+ ;; In normal operation, continuations for error/success is
+ ;; handled by `jsonrpc--continue'. Timeouts also remove
+ ;; the continuation...
+ (pcase-let* ((`(,id ,_) id-and-timer))
+ ;; ...but we still have to guard against exist explicit
+ ;; user-quit (C-g) or the `cancel-on-input' case, so
+ ;; discard the continuation.
+ (jsonrpc--remove connection id (list deferred (current-buffer)))
+ ;; ...finally, whatever may have happened to this sync
+ ;; request, it might have been holding up any outer
+ ;; "anxious" continuations. The following ensures we
+ ;; cll them.
+ (jsonrpc--continue connection id)))))
(when (eq 'error (car retval))
(signal 'jsonrpc-error
(cons
@@ -345,28 +478,32 @@ ignored."
:initarg :process :accessor jsonrpc--process
:documentation "Process object wrapped by the this connection.")
(-expected-bytes
+ :initform nil
:accessor jsonrpc--expected-bytes
:documentation "How many bytes declared by server.")
(-on-shutdown
:accessor jsonrpc--on-shutdown
:initform #'ignore
:initarg :on-shutdown
- :documentation "Function run when the process dies."))
+ :documentation "Function run when the process dies.")
+ (-autoport-inferior
+ :initform nil
+ :documentation "Used by `jsonrpc-autoport-bootstrap'."))
:documentation "A JSONRPC connection over an Emacs process.
The following initargs are accepted:
:PROCESS (mandatory), a live running Emacs process object or a
-function of no arguments producing one such object. The process
-represents either a pipe connection to locally running process or
-a stream connection to a network host. The remote endpoint is
-expected to understand JSONRPC messages with basic HTTP-style
-enveloping headers such as \"Content-Length:\".
+function producing one such object. If a function, it is passed
+the `jsonrpc-process-connection' object. The process represents
+either a pipe connection to locally running process or a stream
+connection to a network host. The remote endpoint is expected to
+understand JSONRPC messages with basic HTTP-style enveloping
+headers such as \"Content-Length:\".
:ON-SHUTDOWN (optional), a function of one argument, the
connection object, called when the process dies.")
-(cl-defmethod initialize-instance ((conn jsonrpc-process-connection) slots)
- (cl-call-next-method)
+(cl-defmethod initialize-instance :after ((conn jsonrpc-process-connection) slots)
(cl-destructuring-bind (&key ((:process proc)) name &allow-other-keys) slots
;; FIXME: notice the undocumented bad coupling in the stderr
;; buffer name, it must be named exactly like this we expect when
@@ -375,37 +512,22 @@ connection object, called when the process dies.")
;; could use a pipe with a process filter instead of
;; `after-change-functions'. Alternatively, we need a new initarg
;; (but maybe not a slot).
- (let ((calling-buffer (current-buffer)))
- (with-current-buffer (get-buffer-create (format "*%s stderr*" name))
- (let ((inhibit-read-only t)
- (hidden-name (concat " " (buffer-name))))
- (erase-buffer)
- (buffer-disable-undo)
- (add-hook
- 'after-change-functions
- (lambda (beg _end _pre-change-len)
- (cl-loop initially (goto-char beg)
- do (forward-line)
- when (bolp)
- for line = (buffer-substring
- (line-beginning-position 0)
- (line-end-position 0))
- do (with-current-buffer (jsonrpc-events-buffer conn)
- (goto-char (point-max))
- (let ((inhibit-read-only t))
- (insert (format "[stderr] %s\n" line))))
- until (eobp)))
- nil t)
- ;; If we are correctly coupled to the client, the process
- ;; now created should pick up the current stderr buffer,
- ;; which we immediately rename
- (setq proc (if (functionp proc)
- (with-current-buffer calling-buffer (funcall proc))
- proc))
- (ignore-errors (kill-buffer hidden-name))
- (rename-buffer hidden-name)
- (process-put proc 'jsonrpc-stderr (current-buffer))
- (setq buffer-read-only t))))
+ (let* ((stderr-buffer-name (format "*%s stderr*" name))
+ (stderr-buffer (jsonrpc--forwarding-buffer stderr-buffer-name "[stderr] " conn))
+ (hidden-name (concat " " stderr-buffer-name)))
+ ;; If we are correctly coupled to the client, the process now
+ ;; created should pick up the `stderr-buffer' just created, which
+ ;; we immediately rename
+ (setq proc (if (functionp proc)
+ (if (zerop (cdr (func-arity proc)))
+ (funcall proc)
+ (funcall proc conn))
+ proc))
+ (with-current-buffer stderr-buffer
+ (ignore-errors (kill-buffer hidden-name))
+ (rename-buffer hidden-name)
+ (setq buffer-read-only t))
+ (process-put proc 'jsonrpc-stderr stderr-buffer))
(setf (jsonrpc--process conn) proc)
(set-process-buffer proc (get-buffer-create (format " *%s output*" name)))
(set-process-filter proc #'jsonrpc--process-filter)
@@ -421,29 +543,42 @@ connection object, called when the process dies.")
(cl-defmethod jsonrpc-connection-send ((connection jsonrpc-process-connection)
&rest args
&key
- _id
+ id
method
_params
- _result
- _error
+ (_result nil result-supplied-p)
+ error
_partial)
"Send MESSAGE, a JSON object, to CONNECTION."
(when method
- (plist-put args :method
- (cond ((keywordp method) (substring (symbol-name method) 1))
- ((and method (symbolp method)) (symbol-name method)))))
- (let* ( (message `(:jsonrpc "2.0" ,@args))
- (json (jsonrpc--json-encode message))
- (headers
- `(("Content-Length" . ,(format "%d" (string-bytes json)))
- ;; ("Content-Type" . "application/vscode-jsonrpc; charset=utf-8")
- )))
+ ;; sanitize method into a string
+ (setq args
+ (plist-put args :method
+ (cond ((keywordp method) (substring (symbol-name method) 1))
+ ((symbolp method) (symbol-name method))
+ ((stringp method) method)
+ (t (error "[jsonrpc] invalid method %s" method))))))
+ (let* ((kind (cond ((or result-supplied-p error) 'reply)
+ (id 'request)
+ (method 'notification)))
+ (converted (jsonrpc-convert-to-endpoint connection args kind))
+ (json (jsonrpc--json-encode converted))
+ (headers
+ `(("Content-Length" . ,(format "%d" (string-bytes json)))
+ ;; ("Content-Type" . "application/vscode-jsonrpc; charset=utf-8")
+ )))
(process-send-string
(jsonrpc--process connection)
(cl-loop for (header . value) in headers
concat (concat header ": " value "\r\n") into header-section
finally return (format "%s\r\n%s" header-section json)))
- (jsonrpc--log-event connection message 'client)))
+ (jsonrpc--event
+ connection
+ 'client
+ :json json
+ :kind kind
+ :message args
+ :foreign-message converted)))
(defun jsonrpc-process-type (conn)
"Return the `process-type' of JSONRPC connection CONN."
@@ -510,42 +645,48 @@ With optional CLEANUP, kill any associated buffers."
"Encode OBJECT into a JSON string.")
(cl-defun jsonrpc--reply
- (connection id &key (result nil result-supplied-p) (error nil error-supplied-p))
+ (connection id method &key (result nil result-supplied-p) (error nil error-supplied-p))
"Reply to CONNECTION's request ID with RESULT or ERROR."
(apply #'jsonrpc-connection-send connection
`(:id ,id
,@(and result-supplied-p `(:result ,result))
- ,@(and error-supplied-p `(:error ,error)))))
+ ,@(and error-supplied-p `(:error ,error))
+ :method ,method)))
(defun jsonrpc--call-deferred (connection)
"Call CONNECTION's deferred actions, who may again defer themselves."
(when-let ((actions (hash-table-values (jsonrpc--deferred-actions connection))))
- (jsonrpc--debug connection `(:maybe-run-deferred
- ,(mapcar (apply-partially #'nth 2) actions)))
+ (jsonrpc--event
+ connection 'internal
+ :log-text (format "re-attempting deferred requests %s"
+ (mapcar (apply-partially #'nth 2) actions)))
(mapc #'funcall (mapcar #'car actions))))
(defun jsonrpc--process-sentinel (proc change)
"Called when PROC undergoes CHANGE."
(let ((connection (process-get proc 'jsonrpc-connection)))
- (jsonrpc--debug connection `(:message "Connection state changed" :change ,change))
+ (jsonrpc--debug connection "Connection state change: `%s'" change)
(when (not (process-live-p proc))
(with-current-buffer (jsonrpc-events-buffer connection)
(let ((inhibit-read-only t))
(insert "\n----------b---y---e---b---y---e----------\n")))
;; Cancel outstanding timers
- (maphash (lambda (_id triplet)
- (pcase-let ((`(,_success ,_error ,timeout) triplet))
- (when timeout (cancel-timer timeout))))
- (jsonrpc--request-continuations connection))
+ (mapc (jsonrpc-lambda (_id _method _success-fn _error-fn timer)
+ (when timer (cancel-timer timer)))
+ (jsonrpc--continuations connection))
+ (maphash (lambda (_ triplet)
+ (pcase-let ((`(,_ ,timer ,_) triplet))
+ (when timer (cancel-timer timer))))
+ (jsonrpc--deferred-actions connection))
(process-put proc 'jsonrpc-sentinel-cleanup-started t)
(unwind-protect
;; Call all outstanding error handlers
- (maphash (lambda (_id triplet)
- (pcase-let ((`(,_success ,error ,_timeout) triplet))
- (funcall error '(:code -1 :message "Server died"))))
- (jsonrpc--request-continuations connection))
+ (mapc (jsonrpc-lambda (_id _method _success-fn error-fn _timer)
+ (funcall error-fn '(:code -1 :message "Server died")))
+ (jsonrpc--continuations connection))
(jsonrpc--message "Server exited with status %s" (process-exit-status proc))
(delete-process proc)
+ (when-let (p (slot-value connection '-autoport-inferior)) (delete-process p))
(funcall (jsonrpc--on-shutdown connection) connection)))))
(defvar jsonrpc--in-process-filter nil
@@ -566,9 +707,8 @@ With optional CLEANUP, kill any associated buffers."
(cl-return-from jsonrpc--process-filter))
(when (buffer-live-p (process-buffer proc))
(with-current-buffer (process-buffer proc)
- (let* ((jsonrpc--in-process-filter t)
- (connection (process-get proc 'jsonrpc-connection))
- (expected-bytes (jsonrpc--expected-bytes connection)))
+ (let* ((conn (process-get proc 'jsonrpc-connection))
+ (expected-bytes (jsonrpc--expected-bytes conn)))
;; Insert the text, advancing the process marker.
;;
(save-excursion
@@ -603,24 +743,28 @@ With optional CLEANUP, kill any associated buffers."
expected-bytes)
(let* ((message-end (byte-to-position
(+ (position-bytes (point))
- expected-bytes))))
+ expected-bytes)))
+ message
+ )
(unwind-protect
(save-restriction
(narrow-to-region (point) message-end)
- (let* ((json-message
- (condition-case-unless-debug oops
- (jsonrpc--json-read)
- (error
- (jsonrpc--warn "Invalid JSON: %s %s"
- (cdr oops) (buffer-string))
- nil))))
- (when json-message
- ;; Process content in another
- ;; buffer, shielding proc buffer from
- ;; tamper
- (with-temp-buffer
- (jsonrpc-connection-receive connection
- json-message)))))
+ (setq message
+ (condition-case-unless-debug oops
+ (jsonrpc--json-read)
+ (error
+ (jsonrpc--warn "Invalid JSON: %s %s"
+ (cdr oops) (buffer-string))
+ nil)))
+ (when message
+ (setq message
+ (plist-put message :jsonrpc-json
+ (buffer-string)))
+ ;; Put new messages at the front of the queue,
+ ;; this is correct as the order is reversed
+ ;; before putting the timers on `timer-list'.
+ (push message
+ (process-get proc 'jsonrpc-mqueue))))
(goto-char message-end)
(let ((inhibit-read-only t))
(delete-region (point-min) (point)))
@@ -629,9 +773,82 @@ With optional CLEANUP, kill any associated buffers."
;; Message is still incomplete
;;
(setq done :waiting-for-more-bytes-in-this-message))))))))
- ;; Saved parsing state for next visit to this filter
+ ;; Saved parsing state for next visit to this filter, which
+ ;; may well be a recursive one stemming from the tail call
+ ;; to `jsonrpc-connection-receive' below (bug#60088).
;;
- (setf (jsonrpc--expected-bytes connection) expected-bytes))))))
+ (setf (jsonrpc--expected-bytes conn) expected-bytes)
+ ;; Now, time to notify user code of one or more messages in
+ ;; order. Very often `jsonrpc-connection-receive' will exit
+ ;; non-locally (typically the reply to a request), so do
+ ;; this all this processing in top-level loops timer.
+ (cl-loop
+ ;; `timer-activate' orders timers by time, which is an
+ ;; very expensive operation when jsonrpc-mqueue is large,
+ ;; therefore the time object is reused for each timer
+ ;; created.
+ with time = (current-time)
+ for msg = (pop (process-get proc 'jsonrpc-mqueue)) while msg
+ do (let ((timer (timer-create)))
+ (timer-set-time timer time)
+ (timer-set-function timer
+ (lambda (conn msg)
+ (with-temp-buffer
+ (jsonrpc-connection-receive conn msg)))
+ (list conn msg))
+ (timer-activate timer))))))))
+
+(defun jsonrpc--remove (conn id &optional deferred-spec)
+ "Cancel CONN's continuations for ID, including its timer, if it exists.
+Also cancel \"deferred actions\" if DEFERRED-SPEC.
+Return the full continuation (ID SUCCESS-FN ERROR-FN TIMER)"
+ (with-slots ((conts -continuations) (defs -deferred-actions)) conn
+ (if deferred-spec (remhash deferred-spec defs))
+ (when-let ((ass (assq id conts)))
+ (cl-destructuring-bind (_ _ _ _ timer) ass
+ (when timer (cancel-timer timer)))
+ (setf conts (delete ass conts))
+ ass)))
+
+(defun jsonrpc--schedule (conn id method success-fn error-fn timer)
+ (push (list id method success-fn error-fn timer)
+ (jsonrpc--continuations conn)))
+
+(defun jsonrpc--continue (conn id &optional cont result error)
+ (pcase-let* ((`(,cont-id ,_method ,success-fn ,error-fn ,_timer)
+ cont)
+ (head (pop (jsonrpc--sync-request-alist conn)))
+ (anxious (cdr head)))
+ (cond
+ (anxious
+ (when (not (= (car head) id)) ; sanity check
+ (error "internal error: please report this bug"))
+ ;; If there are "anxious" `jsonrpc-request' continuations
+ ;; that should already have been run, they should run now.
+ ;; The main continuation -- if it exists -- should run
+ ;; before them. This order is important to preserve the
+ ;; throw to the catch tags in `jsonrpc-request' in
+ ;; order (bug#67945).
+ (cl-flet ((later (f arg) (run-at-time 0 nil f arg)))
+ (when cont-id
+ (if error (later error-fn error)
+ (later success-fn result)))
+ (cl-loop
+ for (acont ares aerr) in anxious
+ for (anx-id _method success-fn error-fn) = acont
+ do (jsonrpc--event
+ conn 'internal
+ :log-text (format "anxious continuation to %s running now" anx-id))
+ if aerr do (later error-fn aerr)
+ else do (later success-fn ares))))
+ (cont-id
+ ;; Else, just run the normal one, with plain funcall.
+ (if error (funcall error-fn error)
+ (funcall success-fn result)))
+ (t
+ ;; For clarity. This happens if the `jsonrpc-request' was
+ ;; canceled
+ ))))
(cl-defun jsonrpc--async-request-1 (connection
method
@@ -639,8 +856,9 @@ With optional CLEANUP, kill any associated buffers."
&rest args
&key success-fn error-fn timeout-fn
(timeout jsonrpc-default-request-timeout)
- (deferred nil))
- "Does actual work for `jsonrpc-async-request'.
+ (deferred nil)
+ (sync-request nil))
+ "Helper for `jsonrpc-request' and `jsonrpc-async-request'.
Return a list (ID TIMER). ID is the new request's ID, or nil if
the request was deferred. TIMER is a timer object set (or nil, if
@@ -650,60 +868,69 @@ TIMEOUT is nil)."
(and deferred (gethash (list deferred buf)
(jsonrpc--deferred-actions connection))))
(id (or old-id (cl-incf (jsonrpc--next-request-id connection))))
- (make-timer
- (lambda ( )
+ (maybe-timer
+ (lambda ()
(when timeout
- (run-with-timer
- timeout nil
- (lambda ()
- (remhash id (jsonrpc--request-continuations connection))
- (remhash (list deferred buf)
- (jsonrpc--deferred-actions connection))
- (if timeout-fn (funcall timeout-fn)
- (jsonrpc--debug
- connection `(:timed-out ,method :id ,id
- :params ,params)))))))))
+ (or timer
+ (setq
+ timer
+ (run-with-timer
+ timeout nil
+ (lambda ()
+ (jsonrpc--remove connection id (list deferred buf))
+ (jsonrpc--event
+ connection 'internal
+ :log-text (format "timed-out request '%s'" method)
+ :id id)
+ (when timeout-fn (funcall timeout-fn))))))))))
(when deferred
(if (jsonrpc-connection-ready-p connection deferred)
;; Server is ready, we jump below and send it immediately.
(remhash (list deferred buf) (jsonrpc--deferred-actions connection))
;; Otherwise, save in `jsonrpc--deferred-actions' and exit non-locally
(unless old-id
- (jsonrpc--debug connection `(:deferring ,method :id ,id :params
- ,params)))
+ (jsonrpc--event
+ connection 'internal
+ :log-text (format "deferring request '%s'" method)
+ :id id))
(puthash (list deferred buf)
(list (lambda ()
(when (buffer-live-p buf)
(with-current-buffer buf
(save-excursion (goto-char point)
- (apply #'jsonrpc-async-request
+ (apply #'jsonrpc--async-request-1
connection
method params args)))))
- (or timer (setq timer (funcall make-timer))) id)
+ (funcall maybe-timer) id)
(jsonrpc--deferred-actions connection))
(cl-return-from jsonrpc--async-request-1 (list id timer))))
- ;; Really send it
+ ;; Really send it thru the wire
;;
(jsonrpc-connection-send connection
:id id
:method method
:params params)
- (puthash id
- (list (or success-fn
- (jsonrpc-lambda (&rest _ignored)
- (jsonrpc--debug
- connection (list :message "success ignored"
- :id id))))
- (or error-fn
- (jsonrpc-lambda (&key code message &allow-other-keys)
- (jsonrpc--debug
- connection (list
- :message
- (format "error ignored, status set (%s)"
- message)
- :id id :error code))))
- (setq timer (funcall make-timer)))
- (jsonrpc--request-continuations connection))
+ ;; Setup some control structures
+ ;;
+ (when sync-request
+ (push (list id) (jsonrpc--sync-request-alist connection)))
+
+ (jsonrpc--schedule
+ connection id method
+ (or success-fn
+ (lambda (&rest _ignored)
+ (jsonrpc--event
+ connection 'internal
+ :log-text (format "success ignored")
+ :id id)))
+ (or error-fn
+ (jsonrpc-lambda (&key code message &allow-other-keys)
+ (jsonrpc--event
+ connection 'internal
+ :log-text (format "error %s ignored: %s ignored"
+ code message)
+ :id id)))
+ (funcall maybe-timer))
(list id timer)))
(defun jsonrpc--message (format &rest args)
@@ -712,10 +939,11 @@ TIMEOUT is nil)."
(defun jsonrpc--debug (server format &rest args)
"Debug message for SERVER with FORMAT and ARGS."
- (jsonrpc--log-event
- server (if (stringp format)
- `(:message ,(apply #'format format args))
- format)))
+ (with-current-buffer (jsonrpc-events-buffer server)
+ (jsonrpc--log-event
+ server 'internal
+ :log-text (apply #'format format args)
+ :type 'debug)))
(defun jsonrpc--warn (format &rest args)
"Warning message with FORMAT and ARGS."
@@ -725,44 +953,216 @@ TIMEOUT is nil)."
(apply #'format format args)
:warning)))
-(defun jsonrpc--log-event (connection message &optional type)
- "Log a JSONRPC-related event.
-CONNECTION is the current connection. MESSAGE is a JSON-like
-plist. TYPE is a symbol saying if this is a client or server
-originated."
- (let ((max (jsonrpc--events-buffer-scrollback-size connection)))
+(cl-defun jsonrpc--event (connection
+ origin
+ &rest plist
+ &key _kind _json _message _foreign-message _log-text
+ &allow-other-keys)
+ (with-current-buffer (jsonrpc-events-buffer connection)
+ (run-hook-wrapped 'jsonrpc-event-hook
+ (lambda (fn)
+ (condition-case oops
+ (apply fn connection origin plist)
+ (error
+ (jsonrpc--message "event hook '%s' errored (%s). Removing it"
+ fn oops)
+ (remove-hook 'jsonrpc-event-hook fn)))))))
+
+(defvar jsonrpc-event-hook (list #'jsonrpc--log-event)
+ "Hook run when JSON-RPC events are emitted.
+This hooks runs in the events buffer of every `jsonrpc-connection'
+when an event is originated by either endpoint. Each hook function
+is passed the arguments described by the lambda list:
+
+ (CONNECTION ORIGIN &key JSON KIND MESSAGE FOREIGN-MESSAGE LOG-TEXT
+ &allow-other-keys)
+
+ CONNECTION the `jsonrpc-connection' instance.
+ ORIGIN one of the symbols `client' ,`server'.
+ JSON the raw JSON string content.
+ KIND one of the symbols `request' ,`notification',
+ `reply'.
+ MESSAGE a plist representing the exchanged message in
+ jsonrpc.el's internal format
+ FOREIGN-MESSAGE a plist representing the exchanged message in
+ the remote endpoint's format.
+ LOG-TEXT text used for events of `internal' origin.
+ ID id of a message that this event refers to.
+ TYPE `error', `debug' or the default `info'.
+
+Except for CONNECTION and ORIGIN all other keys are optional.
+Unlisted keys may appear in the plist.
+
+Do not use this hook to write JSON-RPC protocols, use other parts
+of the API instead.")
+
+(cl-defun jsonrpc--log-event (connection origin
+ &key _kind message
+ foreign-message log-text json
+ type ((:id ref-id))
+ &allow-other-keys)
+ "Log a JSONRPC-related event. Installed in `jsonrpc-event-hook'."
+ (let* ((props (slot-value connection '-events-buffer-config))
+ (max (plist-get props :size))
+ (format (plist-get props :format)))
(when (or (null max) (cl-plusp max))
- (with-current-buffer (jsonrpc-events-buffer connection)
- (cl-destructuring-bind (&key method id error &allow-other-keys) message
- (let* ((inhibit-read-only t)
- (subtype (cond ((and method id) 'request)
- (method 'notification)
- (id 'reply)
- (t 'message)))
- (type
- (concat (format "%s" (or type 'internal))
- (if type
- (format "-%s" subtype)))))
- (goto-char (point-max))
- (prog1
- (let ((msg (format "[%s]%s%s %s:\n%s"
- type
- (if id (format " (id:%s)" id) "")
- (if error " ERROR" "")
- (current-time-string)
- (pp-to-string message))))
- (when error
- (setq msg (propertize msg 'face 'error)))
- (insert-before-markers msg))
- ;; Trim the buffer if it's too large
- (when max
- (save-excursion
- (goto-char (point-min))
- (while (> (buffer-size) max)
- (delete-region (point) (progn (forward-line 1)
- (forward-sexp 1)
- (forward-line 2)
- (point)))))))))))))
+ (cl-destructuring-bind (&key method id error &allow-other-keys) message
+ (let* ((inhibit-read-only t)
+ (depth (length
+ (jsonrpc--sync-request-alist connection)))
+ (preamble (format "[jsonrpc] %s[%s]%s "
+ (pcase type ('error "E") ('debug "D")
+ (_ (pcase origin
+ ('internal "i")
+ (_ "e"))))
+ (format-time-string "%H:%M:%S.%3N")
+ (if (eq origin 'internal)
+ (if ref-id (format " [%s]" ref-id) "")
+ (format " %s%s %s%s"
+ (make-string (* 2 depth) ? )
+ (pcase origin
+ ('client "-->")
+ ('server "<--")
+ (_ ""))
+ (or method "")
+ (if id (format "[%s]" id) "")))))
+ (msg
+ (pcase format
+ ('full (format "%s%s\n" preamble (or json log-text)))
+ ('short (format "%s%s\n" preamble (or log-text "")))
+ (_
+ (format "%s%s" preamble
+ (or (and foreign-message
+ (let ((lisp-indent-function ;bug#68072
+ #'lisp-indent-function))
+ (concat "\n" (pp-to-string
+ foreign-message))))
+ (concat log-text "\n")))))))
+ (goto-char (point-max))
+ ;; XXX: could use `run-at-time' to delay server logs
+ ;; slightly to play nice with verbose servers' stderr.
+ (when error
+ (setq msg (propertize msg 'face 'error)))
+ (insert-before-markers msg)
+ ;; Trim the buffer if it's too large
+ (when max
+ (save-excursion
+ (goto-char (point-min))
+ (while (> (buffer-size) max)
+ (delete-region (point) (progn (forward-line 1)
+ (forward-sexp 1)
+ (forward-line 2)
+ (point)))))))))))
+
+(defun jsonrpc--forwarding-buffer (name prefix conn)
+ "Helper for `jsonrpc-process-connection' helpers.
+Make a stderr buffer named NAME, forwarding lines prefixed by
+PREFIX to CONN's events buffer."
+ (with-current-buffer (get-buffer-create name)
+ (let ((inhibit-read-only t))
+ (fundamental-mode)
+ (erase-buffer)
+ (buffer-disable-undo)
+ (add-hook
+ 'after-change-functions
+ (lambda (beg _end _pre-change-len)
+ (cl-loop initially (goto-char beg)
+ do (forward-line)
+ when (bolp)
+ for line = (buffer-substring
+ (line-beginning-position 0)
+ (line-end-position 0))
+ do (with-current-buffer (jsonrpc-events-buffer conn)
+ (goto-char (point-max))
+ (let ((inhibit-read-only t))
+ (insert
+ (propertize (format "%s %s\n" prefix line)
+ 'face 'shadow))))
+ until (eobp)))
+ nil t))
+ (current-buffer)))
+
+
+;;;; More convenience utils
+(cl-defun jsonrpc-autoport-bootstrap (name contact
+ &key connect-args)
+ "Use CONTACT to start network server, then connect to it.
+
+Return function suitable for the :PROCESS initarg of
+`jsonrpc-process-connection' (which see).
+
+CONTACT is a list where all the elements are strings except for
+one, which is usuallky the keyword `:autoport'.
+
+When the returned function is called it will start a program
+using a command based on CONTACT, where `:autoport' is
+substituted by a locally free network port. Thereafter, a
+network is made to this port.
+
+Instead of the keyword `:autoport', a cons cell (:autoport
+FORMAT-FN) is also accepted. In that case FORMAT-FN is passed
+the port number and should return a string used for the
+substitution.
+
+The internal processes and control buffers are named after NAME.
+
+CONNECT-ARGS are passed as additional arguments to
+`open-network-stream'."
+ (lambda (conn)
+ (let* ((port-probe (make-network-process :name "jsonrpc-port-probe-dummy"
+ :server t
+ :host "localhost"
+ :service 0))
+ (port-number (unwind-protect
+ (process-contact port-probe :service)
+ (delete-process port-probe)))
+ (inferior-buffer (jsonrpc--forwarding-buffer
+ (format " *%s inferior output*" name)
+ "[inferior]"
+ conn))
+ (cmd (cl-loop for e in contact
+ if (eq e :autoport) collect (format "%s" port-number)
+ else if (eq (car-safe e) :autoport)
+ collect (funcall (cdr e) port-number)
+ else collect e))
+ inferior np)
+ (unwind-protect
+ (progn
+ (message "[jsonrpc] Attempting to start `%s'"
+ (string-join cmd " "))
+ (setq inferior
+ (make-process
+ :name (format "inferior (%s)" name)
+ :buffer inferior-buffer
+ :noquery t
+ :command cmd))
+ (setq np
+ (cl-loop
+ repeat 10 for i from 0
+ do (accept-process-output nil 0.5)
+ while (process-live-p inferior)
+ do (message
+ "[jsonrpc] %sTrying to connect to localhost:%s (attempt %s)"
+ (if (zerop i) "Started. " "")
+ port-number (1+ i))
+ thereis (ignore-errors
+ (apply #'open-network-stream
+ (format "autostart (%s)" name)
+ nil
+ "localhost" port-number connect-args))))
+ (setf (slot-value conn '-autoport-inferior) inferior)
+ np)
+ (cond ((and (process-live-p np)
+ (process-live-p inferior))
+ (message "[jsonrpc] Done, connected to %s!" port-number))
+ (t
+ (when inferior (delete-process inferior))
+ (when np (delete-process np))
+ (error "[jsonrpc] Could not start and/or connect")))))))
+
+(defun jsonrpc-continuation-count (conn)
+ "Number of outstanding continuations for CONN."
+ (length (jsonrpc--continuations conn)))
(provide 'jsonrpc)
;;; jsonrpc.el ends here
diff --git a/lisp/keymap.el b/lisp/keymap.el
index 4bdf65d39fa..b2b475c7d71 100644
--- a/lisp/keymap.el
+++ b/lisp/keymap.el
@@ -577,9 +577,15 @@ should be a MENU form as accepted by `easy-menu-define'.
(let ((def (pop definitions)))
(if (eq key :menu)
(easy-menu-define nil keymap "" def)
- (if (member key seen-keys)
- (error "Duplicate definition for key: %S %s" key keymap)
- (push key seen-keys))
+ (when (member key seen-keys)
+ ;; Since the keys can be computed dynamically, it can
+ ;; very well happen that we get duplicate definitions
+ ;; due to some unfortunate configuration rather than
+ ;; due to an actual bug. While such duplicates are
+ ;; not desirable, they shouldn't prevent the users
+ ;; from getting their job done.
+ (message "Duplicate definition for key: %S %s" key keymap))
+ (push key seen-keys)
(keymap-set keymap key def)))))
keymap)))
diff --git a/lisp/kmacro.el b/lisp/kmacro.el
index ca5d5ced398..897ebf14330 100644
--- a/lisp/kmacro.el
+++ b/lisp/kmacro.el
@@ -376,14 +376,22 @@ and `kmacro-counter-format'.")
(defvar kmacro-view-last-item nil)
(defvar kmacro-view-item-no 0)
+(defun kmacro--to-vector (object)
+ "Normalize an old-style key sequence to the vector form."
+ (if (not (stringp object))
+ object
+ (let ((vec (string-to-vector object)))
+ (unless (multibyte-string-p object)
+ (dotimes (i (length vec))
+ (let ((k (aref vec i)))
+ (when (> k 127)
+ (setf (aref vec i) (+ k ?\M-\C-@ -128))))))
+ vec)))
-(autoload 'macro--string-to-vector "macros")
(defun kmacro-ring-head ()
"Return pseudo head element in macro ring."
(and last-kbd-macro
- (kmacro (if (stringp last-kbd-macro)
- (macro--string-to-vector last-kbd-macro)
- last-kbd-macro)
+ (kmacro (kmacro--to-vector last-kbd-macro)
kmacro-counter kmacro-counter-format-start)))
@@ -496,8 +504,9 @@ 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")
+ "Execute second keyboard macro in macro ring.
+With numeric argument ARG, execute the macro that many times."
+ (interactive "p")
(unless (kmacro-ring-empty-p)
(funcall (car kmacro-ring) arg)))
@@ -506,7 +515,7 @@ ARG is the number of times to execute the item.")
"Execute second keyboard macro in macro ring.
This is like `kmacro-call-ring-2nd', but allows repeating macro commands
without repeating the prefix."
- (interactive "P")
+ (interactive "p")
(let ((keys (kmacro-get-repeat-prefix)))
(kmacro-call-ring-2nd arg)
(if (and kmacro-ring keys)
@@ -642,10 +651,10 @@ The macro is now available for use via \\[kmacro-call-macro],
or it can be given a name with \\[kmacro-name-last-macro] and then invoked
under that name.
-With numeric arg, repeat macro now that many times,
+With numeric ARG, repeat the macro that many times,
counting the definition just completed as the first repetition.
An argument of zero means repeat until error."
- (interactive "P")
+ (interactive "p")
;; Isearch may push the kmacro-end-macro key sequence onto the macro.
;; Just ignore it when executing the macro.
(unless executing-kbd-macro
@@ -779,7 +788,7 @@ Zero argument means repeat until there is an error.
To give a macro a name, so you can call it even after defining other
macros, use \\[kmacro-name-last-macro]."
- (interactive "P")
+ (interactive "p")
(if defining-kbd-macro
(kmacro-end-macro nil))
(kmacro-call-macro arg no-repeat))
@@ -843,10 +852,8 @@ KEYS should be a vector or a string that obeys `key-valid-p'."
(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'.
- (setq mac (macro--string-to-vector mac)))
- (kmacro mac counter format)))
+ ;; `kmacro' interprets a string according to `key-parse'.
+ (kmacro (kmacro--to-vector mac) counter format)))
(defun kmacro-extract-lambda (mac)
"Extract kmacro from a kmacro lambda form."
@@ -862,8 +869,6 @@ KEYS should be a vector or a string that obeys `key-valid-p'."
(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)))
@@ -945,20 +950,15 @@ Such a \"function\" cannot be called from Lisp, but it is a valid editor command
(put symbol 'kmacro t))
-(cl-defstruct (kmacro-register
- (:constructor nil)
- (:constructor kmacro-make-register (macro)))
- macro)
-
-(cl-defmethod register-val-jump-to ((data kmacro-register) _arg)
- (kmacro-call-macro current-prefix-arg nil nil (kmacro-register-macro data)))
+(cl-defmethod register-val-jump-to ((km kmacro) arg)
+ (funcall km arg)) ;FIXME: η-reduce?
-(cl-defmethod register-val-describe ((data kmacro-register) _verbose)
- (princ (format "a keyboard macro:\n %s"
- (key-description (kmacro-register-macro data)))))
+(cl-defmethod register-val-describe ((km kmacro) _verbose)
+ (princ (format "a keyboard macro:\n %s"
+ (key-description (kmacro--keys km)))))
-(cl-defmethod register-val-insert ((data kmacro-register))
- (insert (format-kbd-macro (kmacro-register-macro data))))
+(cl-defmethod register-val-insert ((km kmacro))
+ (insert (key-description (kmacro--keys km))))
(defun kmacro-to-register (r)
"Store the last keyboard macro in register R.
@@ -968,7 +968,7 @@ Interactively, reads the register using `register-read-with-preview'."
(progn
(or last-kbd-macro (error "No keyboard macro defined"))
(list (register-read-with-preview "Save to register: "))))
- (set-register r (kmacro-make-register last-kbd-macro)))
+ (set-register r (kmacro-ring-head)))
(defun kmacro-view-macro (&optional _arg)
@@ -1189,7 +1189,10 @@ following additional answers: `insert', `insert-1', `replace', `replace-1',
(setq act (lookup-key kmacro-step-edit-map
(vector (with-current-buffer (current-buffer) (read-event))))))))
- ;; Resume macro execution and perform the action
+ ;; Resume macro execution and perform the action.
+ ;; Suffixing executing-kbd-macro with `dummy-event'
+ ;; is done when pre-command-hook must be called
+ ;; again as part of this keyboard macro's execution.
(cond
((cond
((eq act 'act)
@@ -1220,18 +1223,21 @@ following additional answers: `insert', `insert-1', `replace', `replace-1',
((member act '(replace-1 replace))
(setq kmacro-step-edit-inserting (if (eq act 'replace-1) 1 t))
(if (= executing-kbd-macro-index (length executing-kbd-macro))
- (setq executing-kbd-macro (vconcat executing-kbd-macro [nil])
+ (setq executing-kbd-macro (vconcat executing-kbd-macro
+ [dummy-event])
kmacro-step-edit-appending t))
nil)
((eq act 'append)
(setq kmacro-step-edit-inserting t)
(if (= executing-kbd-macro-index (length executing-kbd-macro))
- (setq executing-kbd-macro (vconcat executing-kbd-macro [nil])
+ (setq executing-kbd-macro (vconcat executing-kbd-macro
+ [dummy-event])
kmacro-step-edit-appending t))
t)
((eq act 'append-end)
(if (= executing-kbd-macro-index (length executing-kbd-macro))
- (setq executing-kbd-macro (vconcat executing-kbd-macro [nil])
+ (setq executing-kbd-macro (vconcat executing-kbd-macro
+ [dummy-event])
kmacro-step-edit-inserting t
kmacro-step-edit-appending t)
(setq kmacro-step-edit-active 'append-end))
@@ -1314,7 +1320,8 @@ following additional answers: `insert', `insert-1', `replace', `replace-1',
(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])
+ (setq executing-kbd-macro (vconcat executing-kbd-macro
+ [dummy-event])
kmacro-step-edit-inserting t
kmacro-step-edit-appending t
kmacro-step-edit-active t)))
diff --git a/lisp/language/chinese.el b/lisp/language/chinese.el
index 290c354d9bb..97a8257db7e 100644
--- a/lisp/language/chinese.el
+++ b/lisp/language/chinese.el
@@ -111,6 +111,7 @@
(set-language-info-alist
"Chinese-GB" '((charset chinese-gb2312 chinese-sisheng)
(iso639-language . zh)
+ (cjk-locale-symbol . zh_CN)
(setup-function . (lambda ()
(use-cjk-char-width-table 'zh_CN)))
(exit-function . use-default-char-width-table)
@@ -142,6 +143,7 @@
(set-language-info-alist
"Chinese-BIG5" '((charset chinese-big5-1 chinese-big5-2)
(iso639-language . zh)
+ (cjk-locale-symbol . zh_HK)
(setup-function . (lambda ()
(use-cjk-char-width-table 'zh_HK)))
(exit-function . use-default-char-width-table)
@@ -198,6 +200,7 @@
chinese-cns11643-5 chinese-cns11643-6
chinese-cns11643-7)
(iso639-language . zh)
+ (cjk-locale-symbol . zh_TW)
(setup-function . (lambda ()
(use-cjk-char-width-table 'zh_TW)))
(exit-function . use-default-char-width-table)
@@ -218,6 +221,7 @@ accepts Big5 for input also (which is then converted to CNS)."))
chinese-cns11643-5 chinese-cns11643-6
chinese-cns11643-7 chinese-big5-1 chinese-big5-2)
(iso639-language . zh)
+ (cjk-locale-symbol . zh_TW)
(setup-function . (lambda ()
(use-cjk-char-width-table 'zh_TW)))
(exit-function . use-default-char-width-table)
@@ -248,6 +252,7 @@ converted to CNS)."))
(set-language-info-alist
"Chinese-GBK" '((charset chinese-gbk)
(iso639-language . zh)
+ (cjk-locale-symbol . zh_CN)
(setup-function . (lambda ()
(use-cjk-char-width-table 'zh_CN)))
(exit-function . use-default-char-width-table)
diff --git a/lisp/language/cyrillic.el b/lisp/language/cyrillic.el
index b3c1dcab079..87a67915878 100644
--- a/lisp/language/cyrillic.el
+++ b/lisp/language/cyrillic.el
@@ -126,7 +126,8 @@ Support for Russian using koi8-r and the russian-computer input method.")
(define-coding-system 'koi8-u
"KOI8-U 8-bit encoding for Cyrillic (MIME: KOI8-U)"
:coding-type 'charset
- :mnemonic ?U
+ ;; This used to be ?U which collided with UTF-8.
+ :mnemonic ?У ; CYRILLIC CAPITAL LETTER U
:charset-list '(koi8-u)
:mime-charset 'koi8-u)
diff --git a/lisp/language/hanja-util.el b/lisp/language/hanja-util.el
index a01b8534cb5..c47ceb5fc88 100644
--- a/lisp/language/hanja-util.el
+++ b/lisp/language/hanja-util.el
@@ -6479,11 +6479,7 @@ character. This variable is initialized by `hanja-init-load'.")
map)
"Keymap for Hanja (Korean Hanja Converter).")
-(defun hanja-filter (condp lst)
- "Construct a list from the elements of LST for which CONDP returns true."
- (delq
- nil
- (mapcar (lambda (x) (and (funcall condp x) x)) lst)))
+(define-obsolete-function-alias 'hanja-filter #'seq-filter "30.1")
(defun hanja-list-prev-group ()
"Select the previous group of hangul->hanja conversions."
@@ -6570,12 +6566,12 @@ The value is a hanja character that is selected interactively."
0 0
;; Filter characters that can not be decoded.
;; Maybe it can not represent characters in current terminal coding.
- (hanja-filter (lambda (x) (car x))
- (mapcar (lambda (c)
- (if (listp c)
- (cons (car c) (cdr c))
- (list c)))
- (aref hanja-table char)))))
+ (seq-filter #'car
+ (mapcar (lambda (c)
+ (if (listp c)
+ (cons (car c) (cdr c))
+ (list c)))
+ (aref hanja-table char)))))
(unwind-protect
(when (aref hanja-conversions 2)
(catch 'exit-input-loop
diff --git a/lisp/language/japan-util.el b/lisp/language/japan-util.el
index 93e8ab24971..b058eab7029 100644
--- a/lisp/language/japan-util.el
+++ b/lisp/language/japan-util.el
@@ -29,8 +29,8 @@
;;;###autoload
(defun setup-japanese-environment-internal ()
- (prefer-coding-system (if (memq system-type '(windows-nt ms-dos cygwin))
- 'japanese-shift-jis
+ (prefer-coding-system (if (memq system-type '(windows-nt ms-dos))
+ 'japanese-cp932
'utf-8))
(use-cjk-char-width-table 'ja_JP))
diff --git a/lisp/language/japanese.el b/lisp/language/japanese.el
index 94099b98e58..8957d1a49af 100644
--- a/lisp/language/japanese.el
+++ b/lisp/language/japanese.el
@@ -79,7 +79,7 @@
(#x00A2 . #xFFE0) ; CENT SIGN FULLWIDTH CENT SIGN
(#x00A3 . #xFFE1) ; POUND SIGN FULLWIDTH POUND SIGN
(#x00AC . #xFFE2) ; NOT SIGN FULLWIDTH NOT SIGN
- (#x00A6 . #xFFE4) ; BROKEN LINE FULLWIDTH BROKEN LINE
+ (#x00A6 . #xFFE4) ; BROKEN BAR FULLWIDTH BROKEN BAR
)))
(define-translation-table 'japanese-ucs-jis-to-cp932-map map)
(setq map (mapcar (lambda (x) (cons (cdr x) (car x))) map))
@@ -208,6 +208,7 @@ eucJP-ms is defined in <http://www.opengroup.or.jp/jvc/cde/appendix.html>."
"Japanese" '((setup-function . setup-japanese-environment-internal)
(exit-function . use-default-char-width-table)
(iso639-language . ja)
+ (cjk-locale-symbol . ja_JP)
(tutorial . "TUTORIAL.ja")
(charset japanese-jisx0208
japanese-jisx0212 latin-jisx0201 katakana-jisx0201
diff --git a/lisp/language/korean.el b/lisp/language/korean.el
index a93b988cc56..9b04de3c6ca 100644
--- a/lisp/language/korean.el
+++ b/lisp/language/korean.el
@@ -68,6 +68,7 @@
(set-language-info-alist
"Korean" '((setup-function . setup-korean-environment-internal)
(exit-function . exit-korean-environment)
+ (cjk-locale-symbol . ko_KR)
(iso639-language . ko)
(tutorial . "TUTORIAL.ko")
(charset korean-ksc5601 cp949)
diff --git a/lisp/language/lao-util.el b/lisp/language/lao-util.el
index 981c603d901..8bb767ba78f 100644
--- a/lisp/language/lao-util.el
+++ b/lisp/language/lao-util.el
@@ -301,25 +301,6 @@
(defconst lao-transcription-pattern
(concat
"\\("
- (mapconcat 'car lao-transcription-consonant-alist "\\|")
- "\\)\\("
- (mapconcat 'car lao-transcription-semi-vowel-alist "\\|")
- "\\)?\\(\\("
- (mapconcat 'car lao-transcription-vowel-alist "\\|")
- "\\)\\("
- (mapconcat 'car lao-transcription-maa-sakod-alist "\\|")
- "\\)?\\("
- (mapconcat (lambda (x) (regexp-quote (car x)))
- lao-transcription-tone-alist "\\|")
- "\\)?\\)?\\|"
- (mapconcat (lambda (x) (regexp-quote (car x)))
- lao-transcription-punctuation-alist "\\|")
- )
- "Regexp of Roman transcription pattern for one Lao syllable.")
-
-(defconst lao-transcription-pattern
- (concat
- "\\("
(regexp-opt (mapcar 'car lao-transcription-consonant-alist))
"\\)\\("
(regexp-opt (mapcar 'car lao-transcription-semi-vowel-alist))
diff --git a/lisp/language/tibetan.el b/lisp/language/tibetan.el
index 4f18dbb9d38..28f8c229d3d 100644
--- a/lisp/language/tibetan.el
+++ b/lisp/language/tibetan.el
@@ -126,6 +126,7 @@
;;; Definitions of conversion data.
;;;
+(eval-and-compile
;;; alists for tibetan char <-> transcription conversion
;;; longer transcription should come first
@@ -333,6 +334,7 @@
(defconst tibetan-subjoined-transcription-alist
+ (eval-when-compile
(sort
(copy-sequence
'(("+k" . "ྐ")
@@ -381,7 +383,7 @@
("+Y" . "ྻ") ;; fixed form subscribed YA
("+R" . "ྼ") ;; fixed form subscribed RA
))
- (lambda (x y) (> (length (car x)) (length (car y))))))
+ (lambda (x y) (> (length (car x)) (length (car y)))))))
;;;
;;; alist for Tibetan base consonant <-> subjoined consonant conversion.
@@ -557,49 +559,34 @@
("སྦ" . "")
("སྨ" . "")))
+) ; eval-and-compile
+
(defconst tibetan-regexp
- (let (pattern)
- (dolist (alist (list tibetan-precomposed-transcription-alist
- tibetan-consonant-transcription-alist
- tibetan-vowel-transcription-alist
- tibetan-modifier-transcription-alist
- tibetan-subjoined-transcription-alist)
- (apply #'concat (nreverse (cdr pattern))))
- (dolist (key-val alist)
- (setq pattern (cons "\\|" (cons (regexp-quote (car key-val))
- pattern))))))
+ (eval-when-compile
+ (regexp-opt (mapcar #'car
+ (append tibetan-precomposed-transcription-alist
+ tibetan-consonant-transcription-alist
+ tibetan-vowel-transcription-alist
+ tibetan-modifier-transcription-alist
+ tibetan-subjoined-transcription-alist))))
"Regexp matching a Tibetan transcription of a composable Tibetan sequence.
The result of matching is to be used for indexing alists at conversion
from a roman transcription to the corresponding Tibetan character.")
(defvar tibetan-precomposed-regexp
(purecopy
- (let ((l tibetan-precomposed-transcription-alist)
- temp)
- (setq temp "^\\(")
- (setq temp
- (concat temp (car (car l))))
- (setq l (cdr l))
- (while l
- (setq temp
- (concat temp "\\|" (car (car l))))
- (setq l (cdr l)))
- (concat temp "\\)")))
+ (eval-when-compile
+ (concat "^"
+ (regexp-opt (mapcar #'car tibetan-precomposed-transcription-alist)
+ t))))
"Regexp string to match a romanized Tibetan complex consonant.
The result of matching is to be used for indexing alists when the input key
from an input method is converted to the corresponding precomposed glyph.")
(defvar tibetan-precomposition-rule-regexp
(purecopy
- (let ((l tibetan-precomposition-rule-alist)
- temp)
- (setq temp "\\(")
- (setq temp (concat temp (car (car l))))
- (setq l (cdr l))
- (while l
- (setq temp (concat temp "\\|" (car (car l))))
- (setq l (cdr l)))
- (concat temp "\\)")))
+ (eval-when-compile
+ (regexp-opt (mapcar #'car tibetan-precomposition-rule-alist) t)))
"Regexp string to match a sequence of Tibetan consonantic components.
That is, one base consonant and one or more subjoined consonants.
The result of matching is to be used for indexing alist when the component
diff --git a/lisp/language/vietnamese.el b/lisp/language/vietnamese.el
index c1800c642a0..460a4d18246 100644
--- a/lisp/language/vietnamese.el
+++ b/lisp/language/vietnamese.el
@@ -28,8 +28,8 @@
;;; Commentary:
-;; For Vietnamese, the character sets VISCII, VSCII and TCVN-5712 are
-;; supported.
+;; For Vietnamese, the coding systems VISCII, VSCII-1 (TCVN-5712),
+;; VIQR and windows-1258 are supported.
;;; Code:
@@ -44,13 +44,16 @@
(define-coding-system-alias 'viscii 'vietnamese-viscii)
(define-coding-system 'vietnamese-vscii
- "8-bit encoding for Vietnamese VSCII-1."
+ "8-bit encoding for Vietnamese VSCII-1 (TCVN-5712)."
:coding-type 'charset
:mnemonic ?v
:charset-list '(vscii)
:suitable-for-file-name t)
(define-coding-system-alias 'vscii 'vietnamese-vscii)
+(define-coding-system-alias 'vietnamese-tcvn 'vietnamese-vscii)
+(define-coding-system-alias 'tcvn 'vietnamese-vscii)
+(define-coding-system-alias 'tcvn-5712 'vietnamese-vscii)
;; (make-coding-system
;; 'vietnamese-vps 4 ?p
@@ -74,7 +77,7 @@
(set-language-info-alist
"Vietnamese" '((charset viscii)
(coding-system vietnamese-viscii vietnamese-vscii
- vietnamese-tcvn vietnamese-viqr windows-1258)
+ vietnamese-viqr windows-1258)
(nonascii-translation . viscii)
(coding-priority vietnamese-viscii)
(input-method . "vietnamese-viqr")
@@ -83,12 +86,12 @@
(sample-text . "Vietnamese (Tiếng Việt) Chào bạn")
(documentation . "\
For Vietnamese, Emacs uses special charsets internally.
-They can be decoded from and encoded to VISCII, VSCII, TCVN-5712, VIQR
-and windows-1258. VSCII is deprecated in favor of TCVN-5712. The
-Current setting gives higher priority to the coding system VISCII than
-TCVN-5712. If you prefer TCVN-5712, please do: (prefer-coding-system
-'vietnamese-tcvn). There are two Vietnamese input methods: VIQR and
-Telex, VIQR is the default setting.")))
+They can be decoded from and encoded to VISCII, VSCII-1 (TCVN-5712),
+VIQR and windows-1258. The current setting gives higher priority
+to the coding system VISCII than VSCII-1. If you prefer VSCII-1,
+please do: (prefer-coding-system 'vietnamese-vscii). There are
+two Vietnamese input methods: VIQR and Telex, VIQR is the default
+setting.")))
(define-coding-system 'windows-1258
"windows-1258 encoding for Vietnamese (MIME: WINDOWS-1258)"
@@ -98,15 +101,6 @@ Telex, VIQR is the default setting.")))
:mime-charset 'windows-1258)
(define-coding-system-alias 'cp1258 'windows-1258)
-(define-coding-system 'vietnamese-tcvn
- "8-bit encoding for Vietnamese TCVN-5712"
- :coding-type 'charset
- :mnemonic ?t
- :charset-list '(tcvn-5712)
- :suitable-for-file-name t)
-(define-coding-system-alias 'tcvn 'vietnamese-tcvn)
-(define-coding-system-alias 'tcvn-5712 'vietnamese-tcvn)
-
(provide 'vietnamese)
;;; vietnamese.el ends here
diff --git a/lisp/ldefs-boot.el b/lisp/ldefs-boot.el
index 60e7f6811bc..b434ee0e37f 100644
--- a/lisp/ldefs-boot.el
+++ b/lisp/ldefs-boot.el
@@ -302,6 +302,7 @@ usage: (defadvice FUNCTION (CLASS NAME [POSITION] [ARGLIST] FLAG...)
(fn FUNCTION ARGS &rest BODY)" nil t)
(function-put 'defadvice 'doc-string-elt 3)
(function-put 'defadvice 'lisp-indent-function 2)
+(make-obsolete 'defadvice '"use `advice-add' or `define-advice'" "30.1")
(register-definition-prefixes "advice" '("ad-"))
@@ -728,19 +729,19 @@ 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.
+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.
+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.
+The mode's hook is called both when the mode is enabled and when it is
+disabled.
(fn &optional ARG)" t)
(define-obsolete-function-alias 'outlinify-sticky #'allout-outlinify-sticky "29.1")
@@ -802,18 +803,18 @@ 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.
+`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.
+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.
+The mode's hook is called both when the mode is enabled and when it is
+disabled.
(fn &optional ARG)" t)
(register-definition-prefixes "allout-widgets" '("allout-"))
@@ -1388,19 +1389,19 @@ 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.
+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.
+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.
+The mode's hook is called both when the mode is enabled and when it is
+disabled.
(fn &optional ARG)" t)
(register-definition-prefixes "artist" '("artist-"))
@@ -1533,18 +1534,18 @@ 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.
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.
+`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.
+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.
+The mode's hook is called both when the mode is enabled and when it is
+disabled.
(fn &optional ARG)" t)
(register-definition-prefixes "autoinsert" '("auto-insert"))
@@ -1570,19 +1571,19 @@ 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.
+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.
+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.
+The mode's hook is called both when the mode is enabled and when it is
+disabled.
(fn &optional ARG)" t)
(autoload 'turn-on-auto-revert-mode "autorevert" "\
@@ -1609,19 +1610,18 @@ 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.
+`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.
+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.
+The mode's hook is called both when the mode is enabled and when it is
+disabled.
(fn &optional ARG)" t)
(autoload 'turn-on-auto-revert-tail-mode "autorevert" "\
@@ -1658,19 +1658,18 @@ 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.
+`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.
+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.
+The mode's hook is called both when the mode is enabled and when it is
+disabled.
(fn &optional ARG)" t)
(register-definition-prefixes "autorevert" '("auto-revert-" "global-auto-revert-"))
@@ -1773,18 +1772,18 @@ functions in `battery-update-functions', which can be used to
trigger actions based on battery-related events.
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.
+`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.
+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 mode's hook is called both when the mode is enabled and when it is
+disabled.
(fn &optional ARG)" t)
(register-definition-prefixes "battery" '("battery-"))
@@ -1945,9 +1944,13 @@ Major mode for editing BibTeX style files.
(register-definition-prefixes "bibtex-style" '("bibtex-style-"))
-;;; Generated autoloads from use-package/bind-key.el
+;;; Generated autoloads from bind-key.el
(push (purecopy '(bind-key 2 4 1)) package--builtin-versions)
+(defvar personal-keybindings nil "\
+List of bindings performed by `bind-key'.
+
+Elements have the form ((KEY . [MAP]) CMD ORIGINAL-CMD)")
(autoload 'bind-key "bind-key" "\
Bind KEY-NAME to COMMAND in KEYMAP (`global-map' if not passed).
@@ -2021,7 +2024,7 @@ other modes. See `override-global-mode'.
(fn &rest ARGS)" nil t)
(autoload 'describe-personal-keybindings "bind-key" "\
Display all the personal keybindings defined by `bind-key'." t)
-(register-definition-prefixes "bind-key" '("bind-key" "compare-keybindings" "get-binding-description" "override-global-m" "personal-keybindings"))
+(register-definition-prefixes "bind-key" '("bind-key" "override-global-m"))
;;; Generated autoloads from emacs-lisp/bindat.el
@@ -2545,6 +2548,13 @@ Browse URL with the system default browser.
Default to the URL around or before point.
(fn URL &optional NEW-WINDOW)" t)
+(autoload 'browse-url-default-android-browser "browse-url" "\
+Browse URL with the system default browser.
+If `browse-url-android-share' is non-nil, try to share URL using
+an external program instead. Default to the URL around or before
+point.
+
+(fn URL &optional NEW-WINDOW)" t)
(autoload 'browse-url-emacs "browse-url" "\
Ask Emacs to load URL into a buffer and show it in another window.
Optional argument SAME-WINDOW non-nil means show the URL in the
@@ -2600,7 +2610,7 @@ used instead of `browse-url-new-window-flag'.
(fn URL &optional NEW-WINDOW)" t)
(make-obsolete 'browse-url-w3 'nil "29.1")
(autoload 'browse-url-w3-gnudoit "browse-url" "\
-Ask another Emacs running gnuserv to load the URL using the W3 browser.
+Ask another Emacs running emacsclient to load the URL using the W3 browser.
The `browse-url-gnudoit-program' program is used with options given by
`browse-url-gnudoit-args'. Default to the URL around or before point.
@@ -2747,37 +2757,36 @@ 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)
(autoload 'bug-reference-prog-mode "bug-reference" "\
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)
(register-definition-prefixes "bug-reference" '("bug-reference-"))
@@ -2785,7 +2794,7 @@ it is disabled.
;;; Generated autoloads from emacs-lisp/byte-opt.el
-(register-definition-prefixes "byte-opt" '("byte-" "disassemble-offset"))
+(register-definition-prefixes "byte-opt" '("byte" "disassemble-offset"))
;;; Generated autoloads from emacs-lisp/bytecomp.el
@@ -2931,12 +2940,6 @@ and corresponding effects.
;;; Generated autoloads from progmodes/c-ts-mode.el
-(autoload 'c-ts-base-mode "c-ts-mode" "\
-Major mode for editing C, powered by tree-sitter.
-
-\\{c-ts-base-mode-map}
-
-(fn)" t)
(autoload 'c-ts-mode "c-ts-mode" "\
Major mode for editing C, powered by tree-sitter.
@@ -2986,6 +2989,7 @@ should be used.
This function attempts to use file contents to determine whether
the code is C or C++ and based on that chooses whether to enable
`c-ts-mode' or `c++-ts-mode'." t)
+(make-obsolete 'c-or-c++-ts-mode 'c-or-c++-mode "30.1")
(register-definition-prefixes "c-ts-mode" '("c-ts-"))
@@ -4372,19 +4376,19 @@ 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.
+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.
+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.
+The mode's hook is called both when the mode is enabled and when it is
+disabled.
(fn &optional ARG)" t)
(autoload 'checkdoc-package-keywords "checkdoc" "\
@@ -4470,19 +4474,18 @@ or call the function `cl-font-lock-built-in-mode'.")
Highlight built-in functions, variables, and types in `lisp-mode'.
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.
+`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.
-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)
(register-definition-prefixes "cl-font-lock" '("cl-font-lock-"))
@@ -4612,19 +4615,18 @@ macro-expansion of `cl-defstruct' that used vectors objects instead
of record objects.
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.
+`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)
(register-definition-prefixes "cl-lib" '("cl-"))
@@ -4645,12 +4647,6 @@ But if you just want to print something, don't call this directly:
call other entry points instead, such as `cl-prin1'.
(fn OBJECT STREAM)")
-(autoload 'cl-print-expand-ellipsis "cl-print" "\
-Print the expansion of an ellipsis to STREAM.
-VALUE should be the value of the `cl-print-ellipsis' text property
-which was attached to the ellipsis by `cl-prin1'.
-
-(fn VALUE STREAM)")
(autoload 'cl-prin1 "cl-print" "\
Print OBJECT on STREAM according to its type.
Output is further controlled by the variables
@@ -4666,18 +4662,17 @@ Return a string containing the `cl-prin1'-printed representation of OBJECT.
(autoload 'cl-print-to-string-with-limit "cl-print" "\
Return a string containing a printed representation of VALUE.
Attempt to get the length of the returned string under LIMIT
-characters with appropriate settings of `print-level' and
-`print-length.' Use PRINT-FUNCTION to print, which should take
-the arguments VALUE and STREAM and which should respect
-`print-length' and `print-level'. LIMIT may be nil or zero in
-which case PRINT-FUNCTION will be called with `print-level' and
-`print-length' bound to nil.
+characters with appropriate settings of `print-level',
+`print-length', and `cl-print-string-length'. Use
+PRINT-FUNCTION to print, which should take the arguments VALUE
+and STREAM and which should respect `print-length',
+`print-level', and `cl-print-string-length'. LIMIT may be nil or
+zero in which case PRINT-FUNCTION will be called with these
+settings bound to nil, and it can also be t in which case
+PRINT-FUNCTION will be called with their current values.
Use this function with `cl-prin1' to print an object,
-abbreviating it with ellipses to fit within a size limit. Use
-this function with `cl-prin1-expand-ellipsis' to expand an
-ellipsis, abbreviating the expansion to stay within a size
-limit.
+abbreviating it with ellipses to fit within a size limit.
(fn PRINT-FUNCTION VALUE LIMIT)")
(register-definition-prefixes "cl-print" '("cl-print-" "help-byte-code"))
@@ -4856,10 +4851,6 @@ REGEXP-GROUP is the regular expression group in REGEXP to use.
;;; Generated autoloads from emacs-lisp/comp.el
(put 'no-native-compile 'safe-local-variable 'booleanp)
-(autoload 'comp-subr-trampoline-install "comp" "\
-Make SUBR-NAME effectively advice-able when called from native code.
-
-(fn SUBR-NAME)")
(autoload 'comp-c-func-name "comp" "\
Given NAME, return a name suitable for the native code.
Add PREFIX in front of it. If FIRST is not nil, pick the first
@@ -4867,6 +4858,10 @@ available name ignoring compilation context and potential name
clashes.
(fn NAME PREFIX &optional FIRST)")
+(autoload 'comp-trampoline-compile "comp" "\
+Synthesize compile and return a trampoline for SUBR-NAME.
+
+(fn SUBR-NAME)")
(autoload 'comp-clean-up-stale-eln "comp" "\
Remove all FILE*.eln* files found in `native-comp-eln-load-path'.
The files to be removed are those produced from the original source
@@ -4909,9 +4904,43 @@ 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.")
-(autoload 'native-compile-async "comp" "\
+(register-definition-prefixes "comp" '("comp-" "native-comp" "no-native-compile"))
+
+
+;;; Generated autoloads from cedet/semantic/wisent/comp.el
+
+(register-definition-prefixes "semantic/wisent/comp" '("wisent-"))
+
+
+;;; Generated autoloads from emacs-lisp/comp-common.el
+
+(autoload 'comp-function-type-spec "comp-common" "\
+Return the type specifier of FUNCTION.
+
+This function returns a cons cell whose car is the function
+specifier, and cdr is a symbol, either `inferred' or `know'.
+If the symbol is `inferred', the type specifier is automatically
+inferred from the code itself by the native compiler; if it is
+`know', the type specifier comes from `comp-known-type-specifiers'.
+
+(fn FUNCTION)")
+(register-definition-prefixes "comp-common" '("comp-" "native-comp-"))
+
+
+;;; Generated autoloads from emacs-lisp/comp-cstr.el
+
+(register-definition-prefixes "comp-cstr" '("comp-" "with-comp-cstr-accessors"))
+
+
+;;; Generated autoloads from emacs-lisp/comp-run.el
+
+(autoload 'comp-subr-trampoline-install "comp-run" "\
+Make SUBR-NAME effectively advice-able when called from native code.
+
+(fn SUBR-NAME)")
+(autoload 'native--compile-async "comp-run" "\
Compile FILES asynchronously.
-FILES is one file or a list of filenames or directories.
+FILES is one filename or a list of filenames or directories.
If optional argument RECURSIVELY is non-nil, recurse into
subdirectories of given directories.
@@ -4928,18 +4957,38 @@ a function -- A function selecting files with matching names.
The variable `native-comp-async-jobs-number' specifies the number
of (commands) to run simultaneously.
+LOAD can also be the symbol `late'. This is used internally if
+the byte code has already been loaded when this function is
+called. It means that we request the special kind of load
+necessary in that situation, called \"late\" loading.
+
+During a \"late\" load, instead of executing all top-level forms
+of the original files, only function definitions are
+loaded (paying attention to have these effective only if the
+bytecode definition was not changed in the meantime).
+
(fn FILES &optional RECURSIVELY LOAD SELECTOR)")
-(register-definition-prefixes "comp" '("comp-" "make-comp-edge" "native-" "no-native-compile"))
+(autoload 'native-compile-async "comp-run" "\
+Compile FILES asynchronously.
+FILES is one file or a list of filenames or directories.
-
-;;; Generated autoloads from cedet/semantic/wisent/comp.el
+If optional argument RECURSIVELY is non-nil, recurse into
+subdirectories of given directories.
-(register-definition-prefixes "semantic/wisent/comp" '("wisent-"))
+If optional argument LOAD is non-nil, request to load the file
+after compiling.
-
-;;; Generated autoloads from emacs-lisp/comp-cstr.el
+The optional argument SELECTOR has the following valid values:
-(register-definition-prefixes "comp-cstr" '("comp-" "with-comp-cstr-accessors"))
+nil -- Select all files.
+a string -- A regular expression selecting files with matching names.
+a function -- A function selecting files with matching names.
+
+The variable `native-comp-async-jobs-number' specifies the number
+of (commands) to run simultaneously.
+
+(fn FILES &optional RECURSIVELY LOAD SELECTOR)")
+(register-definition-prefixes "comp-run" '("comp-" "native-comp"))
;;; Generated autoloads from vc/compare-w.el
@@ -4977,6 +5026,16 @@ on third call it again advances points to the next difference and so on.
(register-definition-prefixes "compare-w" '("compare-"))
+;;; Generated autoloads from emacs-lisp/compat.el
+
+ (push (list 'compat
+ emacs-major-version
+ emacs-minor-version
+ 9999)
+ package--builtin-versions)
+(register-definition-prefixes "compat" '("compat-"))
+
+
;;; Generated autoloads from image/compface.el
(register-definition-prefixes "compface" '("uncompface"))
@@ -5125,20 +5184,18 @@ 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.
+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 `compilation-shell-minor-mode'.
-The mode's hook is called both when the mode is enabled and when
-it is disabled.
-
-\\{compilation-shell-minor-mode-map}
+The mode's hook is called both when the mode is enabled and when it is
+disabled.
(fn &optional ARG)" t)
(autoload 'compilation-minor-mode "compile" "\
@@ -5148,22 +5205,19 @@ When Compilation minor mode is enabled, all the error-parsing
commands of Compilation major mode are available. See
`compilation-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.
+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.
+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.
-
-\\{compilation-minor-mode-map}
+The mode's hook is called both when the mode is enabled and when it is
+disabled.
(fn &optional ARG)" t)
(autoload 'compilation-next-error-function "compile" "\
@@ -5221,24 +5275,54 @@ this mode: `enable-completion', `save-completions-flag', and
options can be found in the `completion' group.
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.
+`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)
(register-definition-prefixes "completion" '("*c-def-regexp*" "*lisp-def-regexp*" "accept-completion" "add-" "cdabbrev-" "check-completion-length" "clear-all-completions" "cmpl-" "complet" "current-completion-source" "delete-completion" "enable-completion" "find-" "inside-locate-completion-entry" "interactive-completion-string-reader" "kill-" "list-all-completions" "load-completions-from-file" "make-c" "next-cdabbrev" "num-cmpl-sources" "reset-cdabbrev" "save" "set-c" "symbol-" "use-completion-"))
+;;; Generated autoloads from completion-preview.el
+
+(autoload 'completion-preview-mode "completion-preview" "\
+Show in-buffer completion suggestions in a preview as you type.
+
+This mode automatically shows and updates the completion preview
+according to the text around point.
+\\<completion-preview-active-mode-map>When the preview is visible, \\[completion-preview-insert]
+accepts the completion suggestion,
+\\[completion-preview-next-candidate] cycles forward to the next
+completion suggestion, and \\[completion-preview-prev-candidate]
+cycles backward.
+
+This is a minor mode. If called interactively, toggle the
+`Completion-Preview 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 `completion-preview-mode'.
+
+The mode's hook is called both when the mode is enabled and when it is
+disabled.
+
+(fn &optional ARG)" t)
+(register-definition-prefixes "completion-preview" '("completion-preview-"))
+
+
;;; Generated autoloads from textmodes/conf-mode.el
(autoload 'conf-mode "conf-mode" "\
@@ -5460,6 +5544,7 @@ If FIX is non-nil, run `copyright-fix-years' instead.
;;; Generated autoloads from progmodes/cperl-mode.el
+(put 'cperl-file-style 'safe-local-variable 'stringp)
(put 'cperl-indent-level 'safe-local-variable 'integerp)
(put 'cperl-brace-offset 'safe-local-variable 'integerp)
(put 'cperl-continued-brace-offset 'safe-local-variable 'integerp)
@@ -5467,7 +5552,6 @@ If FIX is non-nil, run `copyright-fix-years' instead.
(put 'cperl-continued-statement-offset 'safe-local-variable 'integerp)
(put 'cperl-extra-newline-before-brace 'safe-local-variable 'booleanp)
(put 'cperl-merge-trailing-else 'safe-local-variable 'booleanp)
-(put 'cperl-file-style 'safe-local-variable 'stringp)
(autoload 'cperl-mode "cperl-mode" "\
Major mode for editing Perl code.
Expression and list commands understand all C brackets.
@@ -5536,30 +5620,21 @@ into
\\{cperl-mode-map}
-Setting the variable `cperl-font-lock' to t switches on `font-lock-mode'
-(even with older Emacsen), `cperl-electric-lbrace-space' to t switches
-on electric space between $ and {, `cperl-electric-parens-string' is
-the string that contains parentheses that should be electric in CPerl
-(see also `cperl-electric-parens-mark' and `cperl-electric-parens'),
-setting `cperl-electric-keywords' enables electric expansion of
-control structures in CPerl. `cperl-electric-linefeed' governs which
-one of two linefeed behavior is preferable. You can enable all these
-options simultaneously (recommended mode of use) by setting
-`cperl-hairy' to t. In this case you can switch separate options off
-by setting them to `null'. Note that one may undo the extra
-whitespace inserted by semis and braces in `auto-newline'-mode by
-consequent \\[cperl-electric-backspace].
-
-If your site has perl5 documentation in info format, you can use commands
-\\[cperl-info-on-current-command] and \\[cperl-info-on-command] to access it.
-These keys run commands `cperl-info-on-current-command' and
-`cperl-info-on-command', which one is which is controlled by variable
-`cperl-info-on-command-no-prompt' and `cperl-clobber-lisp-bindings'
-(in turn affected by `cperl-hairy').
-
-Even if you have no info-format documentation, short one-liner-style
-help is available on \\[cperl-get-help], and one can run perldoc or
-man via menu.
+Setting the variable `cperl-font-lock' to t switches on `font-lock-mode',
+`cperl-electric-lbrace-space' to t switches on electric space between $
+and {, `cperl-electric-parens-string' is the string that contains
+parentheses that should be electric in CPerl (see also
+`cperl-electric-parens-mark' and `cperl-electric-parens'), setting
+`cperl-electric-keywords' enables electric expansion of control
+structures in CPerl. `cperl-electric-linefeed' governs which one of two
+linefeed behavior is preferable. You can enable all these options
+simultaneously by setting `cperl-hairy' to t. In this case you can
+switch separate options off by setting them to `null'. Note that one may
+undo the extra whitespace inserted by semis and braces in
+`auto-newline'-mode by consequent \\[cperl-electric-backspace].
+
+Short one-liner-style help is available on \\[cperl-get-help],
+and one can run perldoc or man via menu.
It is possible to show this help automatically after some idle time.
This is regulated by variable `cperl-lazy-help-time'. Default with
@@ -5829,19 +5904,19 @@ 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.
+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.
+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.
+The mode's hook is called both when the mode is enabled and when it is
+disabled.
(fn &optional ARG)" t)
(autoload 'cua-selection-mode "cua-base" "\
@@ -5864,19 +5939,18 @@ 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)
(register-definition-prefixes "cua-rect" '("cua-"))
@@ -5892,19 +5966,18 @@ 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)
(autoload 'cursor-sensor-mode "cursor-sensor" "\
@@ -5917,18 +5990,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)
(register-definition-prefixes "cursor-sensor" '("cursor-sensor-"))
@@ -6041,6 +6114,11 @@ Customize GROUP, which must be a customization group, in another window.
Customize SYMBOL, which must be a user option.
(fn SYMBOL)" t)
+(autoload 'customize-toggle-option "cus-edit" "\
+Toggle the value of boolean option SYMBOL for this session.
+
+(fn SYMBOL)" t)
+(defalias 'toggle-option #'customize-toggle-option)
(defalias 'customize-variable-other-window 'customize-option-other-window)
(autoload 'customize-option-other-window "cus-edit" "\
Customize SYMBOL, which must be a user option.
@@ -6230,6 +6308,13 @@ This stores EXP (without evaluating it) as the saved spec for SYMBOL.
(fn &rest ARGS)")
(autoload 'custom-save-icons "cus-edit" "\
Save all customized icons in `custom-file'.")
+(autoload 'customize-dirlocals "cus-edit" "\
+Customize Directory Local Variables in the current directory.
+
+With optional argument FILENAME non-nil, customize the `.dir-locals.el' file
+that FILENAME specifies.
+
+(fn &optional FILENAME)" t)
(register-definition-prefixes "cus-edit" '("Custom-" "cus" "widget-"))
@@ -6259,7 +6344,7 @@ When called from Lisp, BUFFER should be the buffer to use; if
omitted, a buffer named *Custom Themes* is used.
(fn &optional BUFFER)" t)
-(register-definition-prefixes "cus-theme" '("custom-" "describe-theme-1"))
+(register-definition-prefixes "cus-theme" '("custom-" "describe-theme-"))
;;; Generated autoloads from cedet/ede/custom.el
@@ -6287,19 +6372,19 @@ 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.
+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.
+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.
+The mode's hook is called both when the mode is enabled and when it is
+disabled.
(fn &optional ARG)" t)
(put 'global-cwarn-mode 'globalized-minor-mode t)
@@ -6790,19 +6875,18 @@ 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.
+`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.
+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.
+The mode's hook is called both when the mode is enabled and when it is
+disabled.
(fn &optional ARG)" t)
(autoload 'delete-active-region "delsel" "\
@@ -6883,13 +6967,6 @@ See Info node `(elisp)Derived Modes' for more details.
(fn CHILD PARENT NAME [DOCSTRING] [KEYWORD-ARGS...] &rest BODY)" nil t)
(function-put 'define-derived-mode 'doc-string-elt 4)
(function-put 'define-derived-mode 'lisp-indent-function 'defun)
-(autoload 'derived-mode-init-mode-variables "derived" "\
-Initialize variables for a new MODE.
-Right now, if they don't already exist, set up a blank keymap, an
-empty syntax table, and an empty abbrev table -- these will be merged
-the first time the mode is used.
-
-(fn MODE)")
(register-definition-prefixes "derived" '("derived-mode-"))
@@ -6986,18 +7063,18 @@ 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.
+`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.
+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.
+The mode's hook is called both when the mode is enabled and when it is
+disabled.
(fn &optional ARG)" t)
(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) "\
@@ -7258,29 +7335,36 @@ Major mode for editing the diary file.
(autoload 'dictionary-mode "dictionary" "\
Mode for searching a dictionary.
+
This is a mode for searching a dictionary server implementing the
protocol defined in RFC 2229.
This is a quick reference to this mode describing the default key bindings:
\\<dictionary-mode-map>
-* \\[dictionary-close] close the dictionary buffer
-* \\[describe-mode] display this help information
-* \\[dictionary-search] ask for a new word to search
-* \\[dictionary-lookup-definition] search the word at point
-* \\[forward-button] or TAB place point to the next link
-* \\[backward-button] or S-TAB place point to the prev link
-
-* \\[dictionary-match-words] ask for a pattern and list all matching words.
-* \\[dictionary-select-dictionary] select the default dictionary
-* \\[dictionary-select-strategy] select the default search strategy
-
-* \\`RET' or \\`<mouse-2>' visit that link")
+ \\[dictionary-close] close the dictionary buffer
+ \\[describe-mode] display this help
+ \\[dictionary-search] ask for a new word to search
+ \\[dictionary-lookup-definition] search for word at point
+ \\[forward-button] or \\`TAB' move point to the next link
+ \\[backward-button] or \\`S-TAB' move point to the previous link
+
+ \\[dictionary-match-words] ask for a pattern and list all matching words
+ \\[dictionary-select-dictionary] select the default dictionary
+ \\[dictionary-select-strategy] select the default search strategy
+
+ \\`RET' visit link at point
+ \\`<mouse-2>' visit clicked link
+
+(fn)" t)
(autoload 'dictionary "dictionary" "\
Create a new dictionary buffer and install `dictionary-mode'." t)
(autoload 'dictionary-search "dictionary" "\
-Search the WORD in DICTIONARY if given or in all if nil.
-It presents the selection or word at point as default input and
-allows editing it.
+Search for WORD in all the known dictionaries.
+Interactively, prompt for WORD, and offer the word at point as default.
+
+Optional argument DICTIONARY means restrict the search to only
+that one dictionary. Interactively, with prefix argument,
+prompt for DICTIONARY.
(fn WORD &optional DICTIONARY)" t)
(autoload 'dictionary-lookup-definition "dictionary" "\
@@ -7322,7 +7406,7 @@ the context menu will contain an item that searches
the word at mouse click.
(fn MENU CLICK)")
-(register-definition-prefixes "dictionary" '("dictionary-" "global-dictionary-tooltip-mode"))
+(register-definition-prefixes "dictionary" '("dictionary-" "global-dictionary-tooltip-mode" "help-word"))
;;; Generated autoloads from cedet/srecode/dictionary.el
@@ -7424,19 +7508,19 @@ Toggle Diff minor mode.
\\{diff-minor-mode-map}
-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.
+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.
+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.
+The mode's hook is called both when the mode is enabled and when it is
+disabled.
(fn &optional ARG)" t)
(defvar diff-add-log-use-relative-names nil "\
@@ -7488,7 +7572,9 @@ each option.
On systems such as MS-DOS and MS-Windows, which use `ls' emulation in Lisp,
some of the `ls' switches are not supported; see the doc string of
-`insert-directory' in `ls-lisp.el' for more details.")
+`insert-directory' in `ls-lisp.el' for more details.
+
+For remote Dired buffers, this option supports connection-local values.")
(custom-autoload 'dired-listing-switches "dired" t)
(defvar-local dired-directory nil "\
The directory name or wildcard spec that this Dired directory lists.
@@ -7617,7 +7703,7 @@ Like \\[dired-jump] (`dired-jump') but in other window.
;;; Generated autoloads from dired-aux.el
-(register-definition-prefixes "dired-aux" '("dired-"))
+(register-definition-prefixes "dired-aux" '("dired-" "shell-command-guess"))
;;; Generated autoloads from dired-x.el
@@ -7638,19 +7724,19 @@ 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.
+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.
+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.
+The mode's hook is called both when the mode is enabled and when it is
+disabled.
(fn &optional ARG)" t)
(autoload 'dirtrack "dirtrack" "\
@@ -7669,12 +7755,12 @@ from `default-directory'.
(autoload 'disassemble "disass" "\
Print disassembled code for OBJECT in (optional) BUFFER.
OBJECT can be a symbol defined as a function, or a function itself
-(a lambda expression or a compiled-function object).
+(a lambda expression or a byte-code-function object).
If OBJECT is not already compiled, we compile it, but do not
redefine OBJECT if it is a symbol.
(fn OBJECT &optional BUFFER INDENT INTERACTIVE-P)" t)
-(register-definition-prefixes "disass" '("disassemble-"))
+(register-definition-prefixes "disass" '("disassemble-" "re-disassemble"))
;;; Generated autoloads from disp-table.el
@@ -7824,19 +7910,19 @@ not appear aligned.
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.
+`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.
+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.
+The mode's hook is called both when the mode is enabled and when it is
+disabled.
(fn &optional ARG)" t)
(put 'global-display-fill-column-indicator-mode 'globalized-minor-mode t)
@@ -7896,19 +7982,18 @@ 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.
+`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.
+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.
+The mode's hook is called both when the mode is enabled and when it is
+disabled.
(fn &optional ARG)" t)
(put 'global-display-line-numbers-mode 'globalized-minor-mode t)
@@ -7985,19 +8070,18 @@ of `header-line-format', like this:
See also `line-number-display-width'.
This is a minor mode. If called interactively, toggle the
-`Header-Line-Indent mode' mode. If the prefix argument is
-positive, enable the mode, and if it is zero or negative, disable
-the mode.
+`Header-Line-Indent 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 `header-line-indent-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)
(register-definition-prefixes "display-line-numbers" '("display-line-numbers-" "header-line-indent--"))
@@ -8019,13 +8103,15 @@ Default is 2.
;;; Generated autoloads from dnd.el
-(defvar dnd-protocol-alist `((,(purecopy "^file:///") . dnd-open-local-file) (,(purecopy "^file://") . dnd-open-file) (,(purecopy "^file:") . dnd-open-local-file) (,(purecopy "^\\(https?\\|ftp\\|file\\|nfs\\)://") . dnd-open-file)) "\
+(defvar dnd-protocol-alist `((,(purecopy "^file:///") . dnd-open-local-file) (,(purecopy "^file://[^/]") . dnd-open-file) (,(purecopy "^file:/[^/]") . dnd-open-local-file) (,(purecopy "^file:[^/]") . dnd-open-local-file) (,(purecopy "^\\(https?\\|ftp\\|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'.
+This variable is used by `dnd-handle-multiple-urls'.
The list contains of (REGEXP . FUNCTION) pairs.
The functions shall take two arguments, URL, which is the URL dropped and
ACTION which is the action to be performed for the drop (move, copy, link,
private or ask).
+If a function's `dnd-multiple-handler' property is set, it is provided
+a list of each URI dropped instead.
If no match is found here, and the value of `browse-url-browser-function'
is a pair of (REGEXP . FUNCTION), those regexps are tried for a match.
If no match is found, the URL is inserted as text by calling `dnd-insert-text'.
@@ -8096,19 +8182,19 @@ Toggle displaying buffer via Doc View (Doc View minor mode).
See the command `doc-view-mode' for more information on this 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.
+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.
+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.
+The mode's hook is called both when the mode is enabled and when it is
+disabled.
(fn &optional ARG)" t)
(autoload 'doc-view-bookmark-jump "doc-view" "\
@@ -8167,19 +8253,19 @@ Toggle special insertion on double keypresses (Double mode).
When Double mode is enabled, some keys will insert different
strings when pressed twice. See `double-map' for details.
-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.
+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.
+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.
+The mode's hook is called both when the mode is enabled and when it is
+disabled.
(fn &optional ARG)" t)
(register-definition-prefixes "double" '("double-"))
@@ -8199,7 +8285,6 @@ Switch to *dungeon* buffer and start game." t)
;;; Generated autoloads from emacs-lisp/easy-mmode.el
-(defalias 'easy-mmode-define-minor-mode #'define-minor-mode)
(autoload 'define-minor-mode "easy-mmode" "\
Define a new minor mode MODE.
This defines the toggle command MODE and (by default) a control variable
@@ -8274,7 +8359,6 @@ INIT-VALUE LIGHTER KEYMAP.
(fn MODE DOC [KEYWORD VAL ... &rest BODY])" nil t)
(function-put 'define-minor-mode 'doc-string-elt 2)
(function-put 'define-minor-mode 'lisp-indent-function 'defun)
-(defalias 'easy-mmode-define-global-mode #'define-globalized-minor-mode)
(defalias 'define-global-minor-mode #'define-globalized-minor-mode)
(autoload 'define-globalized-minor-mode "easy-mmode" "\
Make a global mode GLOBAL-MODE corresponding to buffer-local minor MODE.
@@ -8337,6 +8421,7 @@ Valid keywords and arguments are:
`nodigits' to suppress digits as prefix arguments.
(fn BS &optional NAME M ARGS)")
+(make-obsolete 'easy-mmode-define-keymap 'define-keymap "29.1")
(autoload 'easy-mmode-defmap "easy-mmode" "\
Define a constant M whose value is the result of `easy-mmode-define-keymap'.
The M, BS, and ARGS arguments are as per that function. DOC is
@@ -8347,6 +8432,7 @@ This macro is deprecated; use `defvar-keymap' instead.
(fn M BS DOC &rest ARGS)" nil t)
(function-put 'easy-mmode-defmap 'doc-string-elt 3)
(function-put 'easy-mmode-defmap 'lisp-indent-function 1)
+(make-obsolete 'easy-mmode-defmap 'defvar-keymap "29.1")
(autoload 'easy-mmode-defsyntax "easy-mmode" "\
Define variable ST as a syntax-table.
CSS contains a list of syntax specifications of the form (CHAR . SYNTAX).
@@ -8354,6 +8440,8 @@ CSS contains a list of syntax specifications of the form (CHAR . SYNTAX).
(fn ST CSS DOC &rest ARGS)" nil t)
(function-put 'easy-mmode-defsyntax 'doc-string-elt 3)
(function-put 'easy-mmode-defsyntax 'lisp-indent-function 1)
+(define-obsolete-function-alias 'easy-mmode-define-minor-mode #'define-minor-mode "30.1")
+(define-obsolete-function-alias 'easy-mmode-define-global-mode #'define-globalized-minor-mode "30.1")
(register-definition-prefixes "easy-mmode" '("easy-mmode-"))
@@ -8662,7 +8750,7 @@ A second call of this function without changing point inserts the next match.
A call with prefix PREFIX reads the symbol to insert from the minibuffer with
completion.
-(fn PREFIX)" t)
+(fn PREFIX)" '("P"))
(autoload 'ebrowse-tags-loop-continue "ebrowse" "\
Repeat last operation on files in tree.
FIRST-TIME non-nil means this is not a repetition, but the first time.
@@ -8785,18 +8873,18 @@ This global minor mode enables `ede-minor-mode' in all buffers in
an EDE controlled project.
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.
+`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.
+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.
+The mode's hook is called both when the mode is enabled and when it is
+disabled.
(fn &optional ARG)" t)
(register-definition-prefixes "ede" '("ede" "global-ede-mode-map" "project-try-ede"))
@@ -8834,7 +8922,7 @@ An extant spec symbol is a symbol that is not a function and has a
`edebug-form-spec' property.
(fn SPEC)")
-(defalias 'edebug-defun 'edebug-eval-top-level-form)
+(defalias 'edebug-defun #'edebug-eval-top-level-form)
(autoload 'edebug-eval-top-level-form "edebug" "\
Evaluate the top level form point is in, stepping through with Edebug.
This is like `eval-defun' except that it steps the code for Edebug
@@ -9200,9 +9288,9 @@ To change the default, set the variable `ediff-use-toolbar-p', which see." t)
(autoload 'edit-kbd-macro "edmacro" "\
Edit a keyboard macro.
At the prompt, type any key sequence which is bound to a keyboard macro.
-Or, type `\\[kmacro-end-and-call-macro]' or \\`RET' to edit the last
-keyboard macro, `\\[view-lossage]' to edit the last 300
-keystrokes as a keyboard macro, or `\\[execute-extended-command]'
+Or, type \\[kmacro-end-and-call-macro] or \\`RET' to edit the last
+keyboard macro, \\[view-lossage] to edit the last 300
+keystrokes as a keyboard macro, or \\[execute-extended-command]
to edit a macro by its command name.
With a prefix argument, format the macro in a more concise way.
@@ -9274,24 +9362,26 @@ Turn on EDT Emulation." t)
;;; Generated autoloads from progmodes/eglot.el
-(push (purecopy '(eglot 1 12 29)) package--builtin-versions)
+(push (purecopy '(eglot 1 17)) package--builtin-versions)
+(define-obsolete-function-alias 'eglot-update #'eglot-upgrade-eglot "29.1")
(autoload 'eglot "eglot" "\
-Start LSP server in support of PROJECT's buffers under MANAGED-MAJOR-MODE.
+Start LSP server for PROJECT's buffers under MANAGED-MAJOR-MODES.
-This starts a Language Server Protocol (LSP) server suitable for the
-buffers of PROJECT whose `major-mode' is MANAGED-MAJOR-MODE.
-CLASS is the class of the LSP server to start and CONTACT specifies
-how to connect to the server.
+This starts a Language Server Protocol (LSP) server suitable for
+the buffers of PROJECT whose `major-mode' is among
+MANAGED-MAJOR-MODES. CLASS is the class of the LSP server to
+start and CONTACT specifies how to connect to the server.
-Interactively, the command attempts to guess MANAGED-MAJOR-MODE
-from the current buffer's `major-mode', CLASS and CONTACT from
-`eglot-server-programs' looked up by the major mode, and PROJECT from
-`project-find-functions'. The search for active projects in this
-context binds `eglot-lsp-context' (which see).
+Interactively, the command attempts to guess MANAGED-MAJOR-MODES,
+CLASS, CONTACT, and LANGUAGE-IDS from `eglot-server-programs',
+according to the current buffer's `major-mode'. PROJECT is
+guessed from `project-find-functions'. The search for active
+projects in this context binds `eglot-lsp-context' (which see).
-If it can't guess, it prompts the user for the mode and the server.
-With a single \\[universal-argument] prefix arg, it always prompts for COMMAND.
-With two \\[universal-argument], it also always prompts for MANAGED-MAJOR-MODE.
+If it can't guess, it prompts the user for the mode and the
+server. With a single \\[universal-argument] prefix arg, it
+always prompts for COMMAND. With two \\[universal-argument], it
+also always prompts for MANAGED-MAJOR-MODE.
The LSP server of CLASS is started (or contacted) via CONTACT.
If this operation is successful, current *and future* file
@@ -9309,20 +9399,30 @@ CONTACT specifies how to contact the server. It is a
keyword-value plist used to initialize CLASS or a plain list as
described in `eglot-server-programs', which see.
-LANGUAGE-ID is the language ID string to send to the server for
-MANAGED-MAJOR-MODE, which matters to a minority of servers.
+LANGUAGE-IDS is a list of language ID string to send to the
+server for each element in MANAGED-MAJOR-MODES.
INTERACTIVE is ignored and provided for backward compatibility.
-(fn MANAGED-MAJOR-MODE PROJECT CLASS CONTACT LANGUAGE-ID &optional INTERACTIVE)" t)
+(fn MANAGED-MAJOR-MODES PROJECT CLASS CONTACT LANGUAGE-IDS &optional INTERACTIVE)" t)
(autoload 'eglot-ensure "eglot" "\
-Start Eglot session for current buffer if there isn't one.")
+Start Eglot session for current buffer if there isn't one.
+
+Only use this function (in major mode hooks, etc) if you are
+confident that Eglot can be started safely and efficiently for
+*every* buffer visited where these hooks may execute.
+
+Since it is difficult to establish this confidence fully, it's
+often wise to use the interactive command `eglot' instead. This
+command only needs to be invoked once per project, as all other
+files of a given major mode visited within the same project will
+automatically become managed with no further user intervention
+needed.")
(autoload 'eglot-upgrade-eglot "eglot" "\
Update Eglot to latest version.
(fn &rest _)" t)
-(define-obsolete-function-alias 'eglot-update 'eglot-upgrade-eglot "29.1")
-(put 'eglot-workspace-configuration 'safe-local-variable 'listp)
+(put 'eglot-workspace-configuration 'safe-local-variable #'listp)
(put 'eglot--debbugs-or-github-bug-uri 'bug-reference-url-format t)
(defun eglot--debbugs-or-github-bug-uri nil (format (if (string= (match-string 2) "github") "https://github.com/joaotavora/eglot/issues/%s" "https://debbugs.gnu.org/%s") (match-string 3)))
(register-definition-prefixes "eglot" '("eglot-"))
@@ -9397,7 +9497,7 @@ SUPERCLASSES as children.
It creates an autoload function for CNAME's constructor.
(fn CNAME SUPERCLASSES FILENAME DOC)")
-(register-definition-prefixes "eieio-core" '("class-" "eieio-" "inconsistent-class-hierarchy" "invalid-slot-" "unbound-slot"))
+(register-definition-prefixes "eieio-core" '("cl--generic-struct-tag" "class-" "eieio-" "inconsistent-class-hierarchy" "invalid-slot-" "unbound-slot"))
;;; Generated autoloads from emacs-lisp/eieio-custom.el
@@ -9449,7 +9549,7 @@ Describe CTR if it is a class constructor.
;;; Generated autoloads from emacs-lisp/eldoc.el
-(push (purecopy '(eldoc 1 13 0)) package--builtin-versions)
+(push (purecopy '(eldoc 1 15 0)) package--builtin-versions)
;;; Generated autoloads from elec-pair.el
@@ -9474,37 +9574,36 @@ 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.
+`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.
+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.
+The mode's hook is called both when the mode is enabled and when it is
+disabled.
(fn &optional ARG)" t)
(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 `electric-pair-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)
(register-definition-prefixes "elec-pair" '("electric-pair-"))
@@ -9521,19 +9620,19 @@ 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.
+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.
+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.
+The mode's hook is called both when the mode is enabled and when it is
+disabled.
(fn &optional ARG)" t)
(autoload 'elide-head "elide-head" "\
@@ -9576,6 +9675,15 @@ optional prefix argument REINIT is non-nil.
(register-definition-prefixes "elint" '("elint-"))
+;;; Generated autoloads from progmodes/elixir-ts-mode.el
+
+(autoload 'elixir-ts-mode "elixir-ts-mode" "\
+Major mode for editing Elixir, powered by tree-sitter.
+
+(fn)" t)
+(register-definition-prefixes "elixir-ts-mode" '("elixir-ts-"))
+
+
;;; Generated autoloads from emacs-lisp/elp.el
(autoload 'elp-instrument-function "elp" "\
@@ -9622,7 +9730,7 @@ displayed." t)
;;; Generated autoloads from eshell/em-basic.el
-(register-definition-prefixes "em-basic" '("eshell"))
+(register-definition-prefixes "em-basic" '("eshell" "pcomplete/eshell-mode/eshell-debug"))
;;; Generated autoloads from eshell/em-cmpl.el
@@ -9642,6 +9750,16 @@ displayed." t)
;;; Generated autoloads from eshell/em-extpipe.el
+(defgroup eshell-extpipe nil "\
+Native shell pipelines.
+
+This module lets you construct pipelines that use your operating
+system's shell instead of Eshell's own pipelining support. This
+is especially relevant when executing commands on a remote
+machine using Eshell's Tramp integration: using the remote
+shell's pipelining avoids copying the data which will flow
+through the pipeline to local Emacs buffers and then right back
+again." :tag "External pipelines" :group 'eshell-module)
(register-definition-prefixes "em-extpipe" '("eshell-"))
@@ -9652,12 +9770,12 @@ displayed." t)
;;; Generated autoloads from eshell/em-hist.el
-(register-definition-prefixes "em-hist" '("eshell"))
+(register-definition-prefixes "em-hist" '("em-hist-unload-function" "eshell"))
;;; Generated autoloads from eshell/em-ls.el
-(register-definition-prefixes "em-ls" '("eshell"))
+(register-definition-prefixes "em-ls" '("em-ls-unload-function" "eshell"))
;;; Generated autoloads from eshell/em-pred.el
@@ -9682,7 +9800,7 @@ displayed." t)
;;; Generated autoloads from eshell/em-smart.el
-(register-definition-prefixes "em-smart" '("eshell-"))
+(register-definition-prefixes "em-smart" '("em-smart-unload-hook" "eshell-"))
;;; Generated autoloads from eshell/em-term.el
@@ -9830,15 +9948,9 @@ Emerge two RCS revisions of a file, with another revision as ancestor.
;;; Generated autoloads from international/emoji.el
-(autoload 'emoji-insert "emoji" "\
-Choose and insert an emoji glyph." t)
-(autoload 'emoji-recent "emoji" "\
-Choose and insert one of the recently-used emoji glyphs." t)
-(autoload 'emoji-search "emoji" "\
-Choose and insert an emoji glyph by typing its Unicode name.
-This command prompts for an emoji name, with completion, and
-inserts it. It recognizes the Unicode Standard names of emoji,
-and also consults the `emoji-alternate-names' alist." t)
+ (autoload 'emoji-insert "emoji" nil t)
+ (autoload 'emoji-recent "emoji" nil t)
+ (autoload 'emoji-search "emoji" nil t)
(autoload 'emoji-list "emoji" "\
List emojis and allow selecting and inserting one of them.
Select the emoji by typing \\<emoji-list-mode-map>\\[emoji-list-select] on its picture.
@@ -9854,6 +9966,7 @@ If called from Lisp, return the name as a string; return nil if
the name is not known.
(fn GLYPH &optional INTERACTIVE)" t)
+ (autoload 'emoji-list-select "emoji" nil t)
(autoload 'emoji--init "emoji" "\
@@ -9887,19 +10000,19 @@ 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.
+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.
+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.
+The mode's hook is called both when the mode is enabled and when it is
+disabled.
(fn &optional ARG)" t)
(autoload 'enriched-encode "enriched" "\
@@ -10120,19 +10233,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)
(autoload 'epa-mail-decrypt "epa-mail" "\
@@ -10182,18 +10295,18 @@ or call the function `epa-global-mail-mode'.")
Minor mode to hook EasyPG into Mail mode.
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.
+`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)
(register-definition-prefixes "epa-mail" '("epa-mail-"))
@@ -10244,83 +10357,80 @@ Look at CONFIG and try to expand GROUP.
;;; Generated autoloads from erc/erc.el
-(push (purecopy '(erc 5 5 0 29 1)) package--builtin-versions)
+(push (purecopy '(erc 5 6 -4)) package--builtin-versions)
+(dolist (symbol '( erc-sasl erc-spelling ; 29
+ erc-imenu erc-nicks)) ; 30
+ (custom-add-load symbol symbol))
+(custom-autoload 'erc-modules "erc")
(autoload 'erc-select-read-args "erc" "\
-Prompt the user for values of nick, server, port, and password.")
+Prompt for connection parameters and return them in a plist.
+By default, collect `:server', `:port', `:nickname', and
+`:password'. With a non-nil prefix argument, also prompt for
+`:user' and `:full-name'. Also return various environmental
+properties needed by entry-point commands, like `erc-tls'.")
+(autoload 'erc-server-select "erc" "\
+Interactively connect to a server from `erc-server-alist'." t)
+(make-obsolete 'erc-server-select 'erc-tls "30.1")
(autoload 'erc "erc" "\
-ERC is a powerful, modular, and extensible IRC client.
-This function is the main entry point for ERC.
-
-It allows selecting connection parameters, and then starts ERC.
-
-Non-interactively, it takes the keyword arguments
- (server (erc-compute-server))
- (port (erc-compute-port))
- (nick (erc-compute-nick))
- (user (erc-compute-user))
- password
- (full-name (erc-compute-full-name))
- id
-
-That is, if called with
+Connect to an Internet Relay Chat SERVER on a non-TLS PORT.
+Use NICK and USER, when non-nil, to inform the IRC commands of
+the same name, possibly factoring in a non-nil FULL-NAME as well.
+When PASSWORD is non-nil, also send an opening server password
+via the \"PASS\" command. Interactively, prompt for SERVER,
+PORT, NICK, and PASSWORD, along with USER and FULL-NAME when
+given a prefix argument. Non-interactively, expect the rarely
+needed ID parameter, when non-nil, to be a symbol or a string for
+naming the server buffer and identifying the connection
+unequivocally. Once connected, return the server buffer. (See
+Info node `(erc) Connecting' for details about all mentioned
+parameters.)
+
+Together with `erc-tls', this command serves as the main entry
+point for ERC, the powerful, modular, and extensible IRC client.
+Non-interactively, both commands accept the following keyword
+arguments, with their defaults supplied by the indicated
+\"compute\" functions:
+
+ :server `erc-compute-server'
+ :port `erc-compute-port'
+ :nick `erc-compute-nick'
+ :user `erc-compute-user'
+ :password N/A
+ :full-name `erc-compute-full-name'
+ :id' N/A
+
+For example, when called in the following manner
(erc :server \"irc.libera.chat\" :full-name \"J. Random Hacker\")
-then the server and full-name will be set to those values,
-whereas `erc-compute-port' and `erc-compute-nick' will be invoked
-for the values of the other parameters.
-
-See `erc-tls' for the meaning of ID.
+ERC assigns SERVER and FULL-NAME the associated keyword values
+and defers to `erc-compute-port', `erc-compute-user', and
+`erc-compute-nick' for those respective parameters.
-(fn &key (SERVER (erc-compute-server)) (PORT (erc-compute-port)) (NICK (erc-compute-nick)) (USER (erc-compute-user)) PASSWORD (FULL-NAME (erc-compute-full-name)) ID)" t)
+(fn &key SERVER PORT NICK USER PASSWORD FULL-NAME ID)" '((let ((erc--display-context `((erc-interactive-display . erc) ,@erc--display-context))) (erc-select-read-args))))
(defalias 'erc-select #'erc)
(autoload 'erc-tls "erc" "\
-ERC is a powerful, modular, and extensible IRC client.
-This function is the main entry point for ERC over TLS.
-
-It allows selecting connection parameters, and then starts ERC
-over TLS.
-
-Non-interactively, it takes the keyword arguments
- (server (erc-compute-server))
- (port (erc-compute-port))
- (nick (erc-compute-nick))
- (user (erc-compute-user))
- password
- (full-name (erc-compute-full-name))
- client-certificate
- id
-
-That is, if called with
+Connect to an IRC server over a TLS-encrypted connection.
+Interactively, prompt for SERVER, PORT, NICK, and PASSWORD, along
+with USER and FULL-NAME when given a prefix argument.
+Non-interactively, also accept a CLIENT-CERTIFICATE, which should
+be a list containing the file name of the certificate's key
+followed by that of the certificate itself. Alternatively,
+accept a value of t instead of a list, to tell ERC to query
+`auth-source' for the certificate's details.
- (erc-tls :server \"irc.libera.chat\" :full-name \"J. Random Hacker\")
-
-then the server and full-name will be set to those values,
-whereas `erc-compute-port' and `erc-compute-nick' will be invoked
-for the values of their respective parameters.
-
-CLIENT-CERTIFICATE, if non-nil, should either be a list where the
-first element is the certificate key file name, and the second
-element is the certificate file name itself, or t, which means
-that `auth-source' will be queried for the key and the
-certificate. Authenticating using a TLS client certificate is
-also referred to as \"CertFP\" (Certificate Fingerprint)
-authentication by various IRC networks.
-
-Example usage:
+Example client certificate (CertFP) usage:
(erc-tls :server \"irc.libera.chat\" :port 6697
:client-certificate
\\='(\"/home/bandali/my-cert.key\"
\"/home/bandali/my-cert.crt\"))
-When present, ID should be a symbol or a string to use for naming
-the server buffer and identifying the connection unequivocally.
-See Info node `(erc) Network Identifier' for details. Like USER
-and CLIENT-CERTIFICATE, this parameter cannot be specified
-interactively.
+See the alternative entry-point command `erc' as well as Info
+node `(erc) Connecting' for a fuller description of the various
+parameters, like ID.
-(fn &key (SERVER (erc-compute-server)) (PORT (erc-compute-port \\='ircs-u)) (NICK (erc-compute-nick)) (USER (erc-compute-user)) PASSWORD (FULL-NAME (erc-compute-full-name)) CLIENT-CERTIFICATE ID)" t)
+(fn &key SERVER PORT NICK USER PASSWORD FULL-NAME CLIENT-CERTIFICATE ID)" '((let ((erc-default-port erc-default-port-tls) (erc--display-context `((erc-interactive-display . erc-tls) ,@erc--display-context))) (erc-select-read-args))))
(autoload 'erc-handle-irc-url "erc" "\
Use ERC to IRC on HOST:PORT in CHANNEL.
If ERC is already connected to HOST:PORT, simply /join CHANNEL.
@@ -10400,7 +10510,7 @@ Customize `erc-url-connect-function' to override this.
;;; Generated autoloads from erc/erc-imenu.el
-(register-definition-prefixes "erc-imenu" '("erc-unfill-notice"))
+(register-definition-prefixes "erc-imenu" '("erc-"))
;;; Generated autoloads from erc/erc-join.el
@@ -10445,11 +10555,14 @@ Return the name of the network or \"Unknown\" as a symbol.
Use the server parameter NETWORK if provided, otherwise parse the
server name and search for a match in `erc-networks-alist'.")
(make-obsolete 'erc-determine-network '"maybe see `erc-networks--determine'" "29.1")
-(autoload 'erc-server-select "erc-networks" "\
-Interactively select a server to connect to using `erc-server-alist'." t)
(register-definition-prefixes "erc-networks" '("erc-"))
+;;; Generated autoloads from erc/erc-nicks.el
+
+(register-definition-prefixes "erc-nicks" '("erc-nicks-"))
+
+
;;; Generated autoloads from erc/erc-notify.el
(register-definition-prefixes "erc-notify" '("erc-"))
@@ -10517,7 +10630,7 @@ Interactively select a server to connect to using `erc-server-alist'." t)
;;; Generated autoloads from erc/erc-truncate.el
-(register-definition-prefixes "erc-truncate" '("erc-max-buffer-size"))
+(register-definition-prefixes "erc-truncate" '("erc-"))
;;; Generated autoloads from erc/erc-xdcc.el
@@ -10533,8 +10646,8 @@ Define NAME (a symbol) as a test.
BODY is evaluated as a `progn' when the test is run. It should
signal a condition on failure or just return if the test passes.
-`should', `should-not', `should-error' and `skip-unless' are
-useful for assertions in BODY.
+`should', `should-not', `should-error', `skip-when', and
+`skip-unless' are useful for assertions in BODY.
Use `ert' to run tests interactively.
@@ -10549,9 +10662,7 @@ it has to be wrapped in `(eval (quote ...))'.
If NAME is already defined as a test and Emacs is running
in batch mode, an error is signaled.
-(fn NAME () [DOCSTRING] [:expected-result RESULT-TYPE] [:tags \\='(TAG...)] BODY...)" nil t)
-(function-put 'ert-deftest 'doc-string-elt 3)
-(function-put 'ert-deftest 'lisp-indent-function 2)
+(fn NAME () [DOCSTRING] [:expected-result RESULT-TYPE] [:tags \\='(TAG...)] BODY...)" nil 'macro)
(autoload 'ert-run-tests-batch "ert" "\
Run the tests specified by SELECTOR, printing results to the terminal.
@@ -10586,6 +10697,46 @@ Display the documentation for TEST-OR-TEST-NAME (a symbol or ert-test).
(register-definition-prefixes "ert" '("ert-"))
+;;; Generated autoloads from emacs-lisp/ert-font-lock.el
+
+(autoload 'ert-font-lock-deftest "ert-font-lock" "\
+Define test NAME (a symbol) using assertions from TEST-STR.
+
+Other than MAJOR-MODE and TEST-STR parameters, this macro accepts
+the same parameters and keywords as `ert-deftest' and is intended
+to be used through `ert'.
+
+(fn NAME () [DOCSTRING] [:expected-result RESULT-TYPE] [:tags \\='(TAG...)] MAJOR-MODE TEST-STR)" nil t)
+(function-put 'ert-font-lock-deftest 'doc-string-elt 3)
+(function-put 'ert-font-lock-deftest 'lisp-indent-function 2)
+(autoload 'ert-font-lock-deftest-file "ert-font-lock" "\
+Define test NAME (a symbol) using assertions from FILE.
+
+FILE - path to a file with assertions in ERT resource director as
+return by `ert-resource-directory'.
+
+Other than MAJOR-MODE and FILE parameters, this macro accepts the
+same parameters and keywords as `ert-deftest' and is intended to
+be used through `ert'.
+
+(fn NAME () [DOCSTRING] [:expected-result RESULT-TYPE] [:tags \\='(TAG...)] MAJOR-MODE FILE)" nil t)
+(function-put 'ert-font-lock-deftest-file 'doc-string-elt 3)
+(function-put 'ert-font-lock-deftest-file 'lisp-indent-function 2)
+(autoload 'ert-font-lock-test-string "ert-font-lock" "\
+Check font faces in TEST-STRING set by MODE.
+
+The function is meant to be run from within an ERT test.
+
+(fn TEST-STRING MODE)")
+(autoload 'ert-font-lock-test-file "ert-font-lock" "\
+Check font faces in FILENAME set by MODE.
+
+The function is meant to be run from within an ERT test.
+
+(fn FILENAME MODE)")
+(register-definition-prefixes "ert-font-lock" '("ert-font-lock--"))
+
+
;;; Generated autoloads from emacs-lisp/ert-x.el
(autoload 'ert-kill-all-test-buffers "ert-x" "\
@@ -10612,7 +10763,7 @@ This mode mainly provides some font locking.
;;; Generated autoloads from eshell/esh-cmd.el
-(register-definition-prefixes "esh-cmd" '("eshell" "pcomplete/eshell-mode/eshell-debug"))
+(register-definition-prefixes "esh-cmd" '("eshell"))
;;; Generated autoloads from eshell/esh-ext.el
@@ -10686,9 +10837,10 @@ information on Eshell, see Info node `(eshell)Top'.
(fn &optional ARG)" t)
(autoload 'eshell-command "eshell" "\
Execute the Eshell command string COMMAND.
-With prefix ARG, insert output into the current buffer at point.
+If TO-CURRENT-BUFFER is non-nil (interactively, with the prefix
+argument), then insert output into the current buffer at point.
-(fn &optional COMMAND ARG)" t)
+(fn COMMAND &optional TO-CURRENT-BUFFER)" t)
(autoload 'eshell-command-result "eshell" "\
Execute the given Eshell COMMAND, and return the result.
The result might be any Lisp object.
@@ -10775,6 +10927,8 @@ which is important if that buffer has a local value of `tags-file-name'.
Returns t if it visits a tags table, or nil if there are no more in the list.
(fn &optional CONT CBUF)")
+(autoload 'tags-reset-tags-tables "etags" "\
+Reset tags state to cancel effect of any previous \\[visit-tags-table] or \\[find-tag]." t)
(autoload 'tags-table-files "etags" "\
Return a list of files in the current tags table.
Assumes the tags table is the current buffer. The file names are returned
@@ -10968,6 +11122,49 @@ for \\[find-tag] (which see)." t)
(register-definition-prefixes "etags" '("default-tags-table-function" "etags-" "file-of-tag" "find-tag-" "goto-tag-location-function" "initialize-new-tags-table" "last-tag" "list-tags-function" "select-tags-table-" "snarf-tag-function" "tag" "verify-tags-table-function"))
+;;; Generated autoloads from progmodes/etags-regen.el
+
+(put 'etags-regen-regexp-alist 'safe-local-variable (lambda (value) (and (listp value) (seq-every-p (lambda (group) (and (consp group) (listp (car group)) (listp (cdr group)) (seq-every-p #'stringp (car group)) (seq-every-p #'stringp (cdr group)))) value))))
+(put 'etags-regen-file-extensions 'safe-local-variable (lambda (value) (and (listp value) (seq-every-p #'stringp value))))
+(put 'etags-regen-ignores 'safe-local-variable (lambda (value) (and (listp value) (seq-every-p #'stringp value))))
+(defvar etags-regen-mode nil "\
+Non-nil if Etags-Regen mode is enabled.
+See the `etags-regen-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 `etags-regen-mode'.")
+(custom-autoload 'etags-regen-mode "etags-regen" nil)
+(autoload 'etags-regen-mode "etags-regen" "\
+Minor mode to automatically generate and update tags tables.
+
+This minor mode generates the tags table automatically based on
+the current project configuration, and later updates it as you
+edit the files and save the changes.
+
+If you select a tags table manually (for example, using
+\\[visit-tags-table]), then this mode will be effectively
+disabled for the entire session. Use \\[tags-reset-tags-tables]
+to countermand the effect of a previous \\[visit-tags-table].
+
+This is a global minor mode. If called interactively, toggle the
+`Etags-Regen 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 \\='etags-regen-mode)'.
+
+The mode's hook is called both when the mode is enabled and when it is
+disabled.
+
+(fn &optional ARG)" t)
+(register-definition-prefixes "etags-regen" '("etags-regen-"))
+
+
;;; Generated autoloads from language/ethio-util.el
(autoload 'setup-ethiopic-environment-internal "ethio-util")
@@ -11375,7 +11572,7 @@ fourth arg NOSEP non-nil inhibits this.
;;; Generated autoloads from net/eww.el
-(defvar eww-suggest-uris '(eww-links-at-point thing-at-point-url-at-point eww-current-url) "\
+(defvar eww-suggest-uris '(eww-links-at-point thing-at-point-url-at-point eww-current-url eww-bookmark-urls) "\
List of functions called to form the list of default URIs for `eww'.
Each of the elements is a function returning either a string or a list
of strings. The results will be joined into a single list with
@@ -11412,8 +11609,10 @@ For more information, see Info node `(eww) Top'.
(defalias 'browse-web 'eww)
(autoload 'eww-open-file "eww" "\
Render FILE using EWW.
+If NEW-BUFFER is non-nil (interactively, the prefix arg), use a
+new buffer instead of reusing the default EWW buffer.
-(fn FILE)" t)
+(fn FILE &optional NEW-BUFFER)" t)
(autoload 'eww-search-words "eww" "\
Search the web for the text in the region.
If region is active (and not whitespace), search the web for
@@ -11771,19 +11970,19 @@ Minor mode for a buffer-specific default face.
When enabled, the face specified by the variable
`buffer-face-mode-face' is used to display the buffer text.
-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.
+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.
+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.
+The mode's hook is called both when the mode is enabled and when it is
+disabled.
(fn &optional ARG)" t)
(autoload 'buffer-face-set "face-remap" "\
@@ -12135,13 +12334,30 @@ Delete all settings of file-local VARIABLE from the -*- line.
(autoload 'add-dir-local-variable "files-x" "\
Add directory-local VARIABLE with its VALUE and MODE to .dir-locals.el.
-(fn MODE VARIABLE VALUE)" t)
+With a prefix argument, prompt for the file to modify.
+
+When called from Lisp, FILE may be the expanded name of the dir-locals file
+where to add VARIABLE.
+
+(fn MODE VARIABLE VALUE &optional FILE)" t)
(autoload 'delete-dir-local-variable "files-x" "\
-Delete all MODE settings of file-local VARIABLE from .dir-locals.el.
+Delete all MODE settings of dir-local VARIABLE from .dir-locals.el.
-(fn MODE VARIABLE)" t)
+With a prefix argument, prompt for the file to modify.
+
+When called from Lisp, FILE may be the expanded name of the dir-locals file
+from where to delete VARIABLE.
+
+(fn MODE VARIABLE &optional FILE)" t)
(autoload 'copy-file-locals-to-dir-locals "files-x" "\
-Copy file-local variables to .dir-locals.el." t)
+Copy file-local variables to .dir-locals.el.
+
+With a prefix argument, prompt for the file to modify.
+
+When called from Lisp, FILE may be the expanded name of the dir-locals file
+where to copy the file-local variables.
+
+(fn &optional FILE)" t)
(autoload 'copy-dir-locals-to-file-locals "files-x" "\
Copy directory-local variables to the Local Variables list." t)
(autoload 'copy-dir-locals-to-file-locals-prop-line "files-x" "\
@@ -12186,6 +12402,14 @@ function preserves the values of any existing variable
definitions that aren't listed in VARIABLES.
(fn PROFILE VARIABLES)")
+(autoload 'hack-connection-local-variables "files-x" "\
+Read connection-local variables according to CRITERIA.
+Store the connection-local variables in buffer local
+variable `connection-local-variables-alist'.
+
+This does nothing if `enable-connection-local-variables' is nil.
+
+(fn CRITERIA)")
(autoload 'hack-connection-local-variables-apply "files-x" "\
Apply connection-local variables identified by CRITERIA.
Other local variables, like file-local and dir-local variables,
@@ -12229,11 +12453,27 @@ earlier in the `setq-connection-local'. The return value of the
`setq-connection-local' form is the value of the last VALUE.
(fn [VARIABLE VALUE]...)" nil t)
+(autoload 'connection-local-p "files-x" "\
+Non-nil if VARIABLE has a connection-local binding in `default-directory'.
+`default-directory' must be a remote file name.
+If APPLICATION is nil, the value of
+`connection-local-default-application' is used.
+
+(fn VARIABLE &optional APPLICATION)" nil t)
+(autoload 'connection-local-value "files-x" "\
+Return connection-local VARIABLE for APPLICATION in `default-directory'.
+`default-directory' must be a remote file name.
+If APPLICATION is nil, the value of
+`connection-local-default-application' is used.
+If VARIABLE does not have a connection-local binding, the return
+value is the default binding of the variable.
+
+(fn VARIABLE &optional APPLICATION)" nil t)
(autoload 'path-separator "files-x" "\
The connection-local value of `path-separator'.")
(autoload 'null-device "files-x" "\
The connection-local value of `null-device'.")
-(register-definition-prefixes "files-x" '("connection-local-" "dir-locals-to-string" "hack-connection-local-variables" "modify-" "read-file-local-variable"))
+(register-definition-prefixes "files-x" '("connection-local-" "dir-locals-to-string" "modify-" "read-"))
;;; Generated autoloads from filesets.el
@@ -12655,7 +12895,7 @@ lines.
;;; Generated autoloads from progmodes/flymake.el
-(push (purecopy '(flymake 1 2 2)) package--builtin-versions)
+(push (purecopy '(flymake 1 3 7)) package--builtin-versions)
(autoload 'flymake-log "flymake" "\
Log, at level LEVEL, the message MSG formatted with ARGS.
LEVEL is passed to `display-warning', which is used to display
@@ -12740,21 +12980,19 @@ 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.
+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.
+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-mode-map}
+The mode's hook is called both when the mode is enabled and when it is
+disabled.
(fn &optional ARG)" t)
(autoload 'flymake-mode-on "flymake" "\
@@ -12819,26 +13057,26 @@ 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.
+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.
+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.
+The mode's hook is called both when the mode is enabled and when it is
+disabled.
(fn &optional ARG)" t)
(autoload 'turn-on-flyspell "flyspell" "\
Unconditionally turn on Flyspell mode.")
(autoload 'turn-off-flyspell "flyspell" "\
Unconditionally turn off Flyspell mode.")
-(autoload 'flyspell-mode-off "flyspell" "\
+(autoload 'flyspell--mode-off "flyspell" "\
Turn Flyspell mode off.")
(autoload 'flyspell-region "flyspell" "\
Flyspell text between BEG and END.
@@ -12887,7 +13125,7 @@ being able to use 144 or 216 lines instead of the normal 72... (your
mileage may vary).
To split one large window into two side-by-side windows, the commands
-`\\[split-window-right]' or `\\[follow-delete-other-windows-and-split]' can be used.
+\\[split-window-right] or \\[follow-delete-other-windows-and-split] can be used.
Only windows displayed in the same frame follow each other.
@@ -12896,19 +13134,19 @@ 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.
+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.
+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.
+The mode's hook is called both when the mode is enabled and when it is
+disabled.
(fn &optional ARG)" t)
(autoload 'follow-scroll-up-window "follow" "\
@@ -12994,19 +13232,19 @@ 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.
+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.
+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.
+The mode's hook is called both when the mode is enabled and when it is
+disabled.
(fn &optional ARG)" t)
(register-definition-prefixes "footnote" '("footnote-"))
@@ -13032,7 +13270,7 @@ For instance:
(?l . \"ls\")))
Each %-spec may contain optional flag, width, and precision
-specifiers, as follows:
+modifiers, as follows:
%<flags><width><precision>character
@@ -13045,7 +13283,7 @@ The following flags are allowed:
* ^: Convert to upper case.
* _: Convert to lower case.
-The width and precision specifiers behave like the corresponding
+The width and truncation modifiers behave like the corresponding
ones in `format' when applied to %s.
For example, \"%<010b\" means \"substitute into the output the
@@ -13460,19 +13698,18 @@ being transferred. This list may grow up to a size of
the list) is deleted every time a new one is added (at the front).
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.
+`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)
(autoload 'gdb "gdb-mi" "\
@@ -13636,19 +13873,19 @@ Minor mode for making identifiers likeThis readable.
When this mode is active, it tries to add virtual
separators (like underscores) at places they belong to.
-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.
+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.
+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.
+The mode's hook is called both when the mode is enabled and when it is
+disabled.
(fn &optional ARG)" t)
(register-definition-prefixes "glasses" '("glasses-"))
@@ -13668,19 +13905,18 @@ 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)
(register-definition-prefixes "glyphless-mode" '("glyphless-mode-"))
@@ -14161,19 +14397,18 @@ Minor mode for providing mailing-list commands.
\\{gnus-mailing-list-mode-map}
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' 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 `gnus-mailing-list-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)
(register-definition-prefixes "gnus-ml" '("gnus-mailing-list-"))
@@ -14499,6 +14734,8 @@ Add the window configuration CONF to `gnus-buffer-configuration'.
(autoload 'go-ts-mode "go-ts-mode" "\
Major mode for editing Go, powered by tree-sitter.
+\\{go-ts-mode-map}
+
(fn)" t)
(autoload 'go-mod-ts-mode "go-ts-mode" "\
Major mode for editing go.mod files, powered by tree-sitter.
@@ -14558,19 +14795,19 @@ Also fontifies the buffer appropriately (see `goto-address-fontify-p' and
(autoload 'goto-address-mode "goto-addr" "\
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.
+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.
-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)
(put 'global-goto-address-mode 'globalized-minor-mode t)
@@ -14601,19 +14838,18 @@ 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)
(register-definition-prefixes "goto-addr" '("goto-addr"))
@@ -14969,20 +15205,43 @@ or call the function `gud-tooltip-mode'.")
Toggle the display of GUD tooltips.
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.
+`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)
+(autoload 'lldb "gud" "\
+Run LLDB passing it COMMAND-LINE as arguments.
+If COMMAND-LINE names a program FILE to debug, LLDB will run in
+a buffer named *gud-FILE*, and the directory containing FILE
+becomes the initial working directory and source-file directory
+for the debug session. If you don't want `default-directory' to
+change to the directory of FILE, specify FILE without leading
+directories, in which case FILE should reside either in the
+directory of the buffer from which this command is invoked, or
+it can be found by searching PATH.
+
+If COMMAND-LINE requests that LLDB attaches to a process PID, LLDB
+will run in *gud-PID*, otherwise it will run in *gud*; in these
+cases the initial working directory is the `default-directory' of
+the buffer in which this command was invoked.
+
+Please note that completion framework that complete while you
+type, like Corfu, do not work well with this mode. You should
+consider to turn them off in this mode.
+
+This command runs functions from `lldb-mode-hook'.
+
+(fn COMMAND-LINE)" t)
(register-definition-prefixes "gud" '("gdb-" "gud-"))
@@ -15160,6 +15419,15 @@ Prefix arg sets default accept amount temporarily.
(register-definition-prefixes "hashcash" '("hashcash-"))
+;;; Generated autoloads from progmodes/heex-ts-mode.el
+
+(autoload 'heex-ts-mode "heex-ts-mode" "\
+Major mode for editing HEEx, powered by tree-sitter.
+
+(fn)" t)
+(register-definition-prefixes "heex-ts-mode" '("heex-ts-"))
+
+
;;; Generated autoloads from help-at-pt.el
(autoload 'help-at-pt-string "help-at-pt" "\
@@ -15390,6 +15658,9 @@ 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.
+When `describe-mode-outline' is non-nil, Outline minor mode
+is enabled in the Help buffer.
+
(fn &optional BUFFER)" t)
(autoload 'describe-widget "help-fns" "\
Display a buffer with information about a widget.
@@ -15715,19 +15986,19 @@ 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.
+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.
+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.
+The mode's hook is called both when the mode is enabled and when it is
+disabled.
(fn &optional ARG)" t)
(put 'global-hi-lock-mode 'globalized-minor-mode t)
@@ -15891,27 +16162,27 @@ 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.
+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.
+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.
+The mode's hook is called both when the mode is enabled and when it is
+disabled.
(fn &optional ARG)" t)
-(register-definition-prefixes "hideif" '("backward-ifdef" "down-ifdef" "forward-ifdef" "hide-ifdef" "hif-" "intern-safe" "next-ifdef" "previous-ifdef" "show-ifdef" "up-ifdef"))
+(register-definition-prefixes "hideif" '("backward-ifdef" "down-ifdef" "forward-ifdef" "hide-ifdef" "hif-" "next-ifdef" "previous-ifdef" "show-ifdef" "up-ifdef"))
;;; Generated autoloads from progmodes/hideshow.el
-(defvar hs-special-modes-alist (mapcar #'purecopy '((c-mode "{" "}" "/[*/]" nil nil) (c-ts-mode "{" "}" "/[*/]" nil nil) (c++-mode "{" "}" "/[*/]" nil nil) (c++-ts-mode "{" "}" "/[*/]" nil nil) (bibtex-mode ("@\\S(*\\(\\s(\\)" 1)) (java-mode "{" "}" "/[*/]" nil nil) (java-ts-mode "{" "}" "/[*/]" nil nil) (js-mode "{" "}" "/[*/]" nil) (js-ts-mode "{" "}" "/[*/]" nil) (mhtml-mode "{\\|<[^/>]*?" "}\\|</[^/>]*[^/]>" "<!--" mhtml-forward nil))) "\
+(defvar hs-special-modes-alist (mapcar #'purecopy '((c-mode "{" "}" "/[*/]" nil nil) (c-ts-mode "{" "}" "/[*/]" nil nil) (c++-mode "{" "}" "/[*/]" nil nil) (c++-ts-mode "{" "}" "/[*/]" nil nil) (bibtex-mode ("@\\S(*\\(\\s(\\)" 1)) (java-mode "{" "}" "/[*/]" nil nil) (java-ts-mode "{" "}" "/[*/]" nil nil) (js-mode "{" "}" "/[*/]" nil) (js-ts-mode "{" "}" "/[*/]" nil) (lua-ts-mode "{\\|\\[\\[" "}\\|\\]\\]" "--" nil) (mhtml-mode "{\\|<[^/>]*?" "}\\|</[^/>]*[^/]>" "<!--" mhtml-forward nil))) "\
Alist for initializing the hideshow variables for different modes.
Each element has the form
(MODE START END COMMENT-START FORWARD-SEXP-FUNC ADJUST-BEG-FUNC
@@ -15968,19 +16239,19 @@ 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.
+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.
+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.
+The mode's hook is called both when the mode is enabled and when it is
+disabled.
(fn &optional ARG)" t)
(autoload 'turn-off-hideshow "hideshow" "\
@@ -16014,19 +16285,18 @@ 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.
+`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.
+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.
+The mode's hook is called both when the mode is enabled and when it is
+disabled.
(fn &optional ARG)" t)
(autoload 'highlight-changes-visible-mode "hilit-chg" "\
@@ -16043,18 +16313,18 @@ 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.
+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 `highlight-changes-visible-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)
(autoload 'highlight-changes-remove-highlight "hilit-chg" "\
@@ -16180,19 +16450,19 @@ 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.
+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.
+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.
+The mode's hook is called both when the mode is enabled and when it is
+disabled.
(fn &optional ARG)" t)
(defvar global-hl-line-mode nil "\
@@ -16214,18 +16484,18 @@ 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.
+`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.
+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.
+The mode's hook is called both when the mode is enabled and when it is
+disabled.
(fn &optional ARG)" t)
(register-definition-prefixes "hl-line" '("global-hl-line-" "hl-line-"))
@@ -16330,6 +16600,15 @@ values.
(register-definition-prefixes "semantic/html" '("semantic-"))
+;;; Generated autoloads from textmodes/html-ts-mode.el
+
+(autoload 'html-ts-mode "html-ts-mode" "\
+Major mode for editing Html, powered by tree-sitter.
+
+(fn)" t)
+(register-definition-prefixes "html-ts-mode" '("html-ts-mode-"))
+
+
;;; Generated autoloads from htmlfontify.el
(push (purecopy '(htmlfontify 0 21)) package--builtin-versions)
@@ -16402,8 +16681,7 @@ inlined into the compiled format versions. This means that if you
change its definition, you should explicitly call
`ibuffer-recompile-formats'.
-(fn SYMBOL (&key NAME INLINE PROPS SUMMARIZER) &rest BODY)" nil t)
-(function-put 'define-ibuffer-column 'lisp-indent-function 'defun)
+(fn SYMBOL (&key NAME INLINE PROPS SUMMARIZER) &rest BODY)" nil 'macro)
(autoload 'define-ibuffer-sorter "ibuf-macs" "\
Define a method of sorting named NAME.
DOCUMENTATION is the documentation of the function, which will be called
@@ -16414,9 +16692,7 @@ For sorting, the forms in BODY will be evaluated with `a' bound to one
buffer object, and `b' bound to another. BODY should return a non-nil
value if and only if `a' is \"less than\" `b'.
-(fn NAME DOCUMENTATION (&key DESCRIPTION) &rest BODY)" nil t)
-(function-put 'define-ibuffer-sorter 'lisp-indent-function 1)
-(function-put 'define-ibuffer-sorter 'doc-string-elt 2)
+(fn NAME DOCUMENTATION (&key DESCRIPTION) &rest BODY)" nil 'macro)
(autoload 'define-ibuffer-op "ibuf-macs" "\
Generate a function which operates on a buffer.
OP becomes the name of the function; if it doesn't begin with
@@ -16455,9 +16731,7 @@ BODY define the operation; they are forms to evaluate per each
marked buffer. BODY is evaluated with `buf' bound to the
buffer object.
-(fn OP ARGS DOCUMENTATION (&key INTERACTIVE MARK MODIFIER-P DANGEROUS OPSTRING ACTIVE-OPSTRING BEFORE AFTER COMPLEX) &rest BODY)" nil t)
-(function-put 'define-ibuffer-op 'lisp-indent-function 2)
-(function-put 'define-ibuffer-op 'doc-string-elt 3)
+(fn OP ARGS DOCUMENTATION (&key INTERACTIVE MARK MODIFIER-P DANGEROUS OPSTRING ACTIVE-OPSTRING BEFORE AFTER COMPLEX) &rest BODY)" nil 'macro)
(autoload 'define-ibuffer-filter "ibuf-macs" "\
Define a filter named NAME.
DOCUMENTATION is the documentation of the function.
@@ -16472,9 +16746,7 @@ not a particular buffer should be displayed or not. The forms in BODY
will be evaluated with BUF bound to the buffer object, and QUALIFIER
bound to the current value of the filter.
-(fn NAME DOCUMENTATION (&key READER DESCRIPTION) &rest BODY)" nil t)
-(function-put 'define-ibuffer-filter 'lisp-indent-function 2)
-(function-put 'define-ibuffer-filter 'doc-string-elt 2)
+(fn NAME DOCUMENTATION (&key READER DESCRIPTION) &rest BODY)" nil 'macro)
(register-definition-prefixes "ibuf-macs" '("ibuffer-"))
@@ -16583,19 +16855,19 @@ An enhanced `icomplete-mode' that emulates `ido-mode'.
This global minor mode makes minibuffer completion behave
more like `ido-mode' than regular `icomplete-mode'.
-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.
+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.
+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.
+The mode's hook is called both when the mode is enabled and when it is
+disabled.
(fn &optional ARG)" t)
(defvar icomplete-mode nil "\
@@ -16623,18 +16895,18 @@ 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.
+`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.
+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.
+The mode's hook is called both when the mode is enabled and when it is
+disabled.
(fn &optional ARG)" t)
(defvar icomplete-vertical-mode nil "\
@@ -16655,19 +16927,18 @@ 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.
+`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.
+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.
+The mode's hook is called both when the mode is enabled and when it is
+disabled.
(fn &optional ARG)" t)
(defvar fido-vertical-mode nil "\
@@ -16685,18 +16956,18 @@ 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 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.
+`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)
(when (locate-library "obsolete/iswitchb")
@@ -17186,19 +17457,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.
+The mode's hook is called both when the mode is enabled and when it is
+disabled.
(fn &optional ARG)" t)
(register-definition-prefixes "iimage" '("iimage-" "turn-off-iimage-mode"))
@@ -17341,21 +17612,25 @@ BUFFER nil or omitted means use the current buffer.
(fn START END &optional BUFFER)")
(autoload 'find-image "image" "\
-Find an image, choosing one of a list of image specifications.
+Find an image that satisfies one of a list of image specifications.
SPECS is a list of image specifications.
-Each image specification in SPECS is a property list. The contents of
-a specification are image type dependent. All specifications must at
-least contain either the property `:file FILE' or `:data DATA',
-where FILE is the file to load the image from, and DATA is a string
-containing the actual image data. If the property `:type TYPE' is
-omitted or nil, try to determine the image type from its first few
+Each image specification in SPECS is a property list. The
+contents of a specification are image type dependent; see the
+info node `(elisp)Image Descriptors' for details. All specifications
+must at least contain either the property `:file FILE' or `:data DATA',
+where FILE is the file from which to load the image, and DATA is a
+string containing the actual image data. If the property `:type TYPE'
+is omitted or nil, try to determine the image type from its first few
bytes of image data. If that doesn't work, and the property `:file
-FILE' provide a file name, use its file extension as image type.
-If `:type TYPE' is provided, it must match the actual type
-determined for FILE or DATA by `create-image'. Return nil if no
-specification is satisfied.
+FILE' provide a file name, use its file extension as idication of the
+image type. If `:type TYPE' is provided, it must match the actual type
+determined for FILE or DATA by `create-image'.
+
+The function returns the image specification for the first specification
+in the list whose TYPE is supported and FILE, if specified, exists. It
+returns nil if no specification in the list can be satisfied.
If CACHE is non-nil, results are cached and returned on subsequent calls.
@@ -17572,20 +17847,19 @@ are always available in Dired:
\\[image-dired-dired-toggle-marked-thumbs] Toggle thumbnails in front of file names.
\\[image-dired-dired-edit-comment-and-tags] Edit comment and tags of marked images.
-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.
+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.
-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)
(autoload 'image-dired-display-thumbs-append "image-dired-dired" "\
@@ -17691,18 +17965,18 @@ An image file is one whose name has an extension 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.
+`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.
+The mode's hook is called both when the mode is enabled and when it is
+disabled.
(fn &optional ARG)" t)
(register-definition-prefixes "image-file" '("image-file-"))
@@ -17723,19 +17997,19 @@ Toggle Image minor mode in this buffer.
Image minor mode provides the key \\<image-mode-map>\\[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.
+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.
+The mode's hook is called both when the mode is enabled and when it is
+disabled.
(fn &optional ARG)" t)
(autoload 'image-mode-to-text "image-mode" "\
@@ -17918,6 +18192,41 @@ Convert old Emacs Devanagari characters to UCS.
(register-definition-prefixes "ind-util" '("combinatorial" "indian-" "is13194-"))
+;;; Generated autoloads from indent-aux.el
+
+(defvar kill-ring-deindent-mode nil "\
+Non-nil if Kill-Ring-Deindent mode is enabled.
+See the `kill-ring-deindent-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 `kill-ring-deindent-mode'.")
+(custom-autoload 'kill-ring-deindent-mode "indent-aux" nil)
+(autoload 'kill-ring-deindent-mode "indent-aux" "\
+Toggle removal of indentation from text saved to the kill ring.
+
+When this minor mode is enabled, text saved into the kill ring is
+indented towards the left by the column number at the start of
+that text.
+
+This is a global minor mode. If called interactively, toggle the
+`Kill-Ring-Deindent 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 \\='kill-ring-deindent-mode)'.
+
+The mode's hook is called both when the mode is enabled and when it is
+disabled.
+
+(fn &optional ARG)" t)
+(register-definition-prefixes "indent-aux" '("kill-ring-deindent-buffer-substring-function"))
+
+
;;; Generated autoloads from leim/quail/indian.el
(register-definition-prefixes "quail/indian" '("indian-mlm-mozhi-u" "inscript-" "quail-" "tamil"))
@@ -18565,6 +18874,8 @@ If APPEND is non-nil, don't erase previous debugging output.
(fn &optional APPEND)" t)
(autoload 'ispell-continue "ispell" "\
Continue a halted spelling session beginning with the current word." t)
+(autoload 'ispell-completion-at-point "ispell" "\
+Word completion function for use in `completion-at-point-functions'.")
(autoload 'ispell-complete-word "ispell" "\
Try to complete the word before or at point.
If optional INTERIOR-FRAG is non-nil, then the word may be a character
@@ -18603,19 +18914,19 @@ 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.
+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.
+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.
+The mode's hook is called both when the mode is enabled and when it is
+disabled.
(fn &optional ARG)" t)
(autoload 'ispell-message "ispell" "\
@@ -18821,7 +19132,7 @@ Major mode for editing JSON, powered by tree-sitter.
;;; Generated autoloads from jsonrpc.el
-(push (purecopy '(jsonrpc 1 0 16)) package--builtin-versions)
+(push (purecopy '(jsonrpc 1 0 24)) package--builtin-versions)
(register-definition-prefixes "jsonrpc" '("jsonrpc-"))
@@ -18957,7 +19268,7 @@ The macro is now available for use via \\[kmacro-call-macro],
or it can be given a name with \\[kmacro-name-last-macro] and then invoked
under that name.
-With numeric arg, repeat macro now that many times,
+With numeric ARG, repeat the macro that many times,
counting the definition just completed as the first repetition.
An argument of zero means repeat until error.
@@ -19182,7 +19493,7 @@ A major mode to edit GNU ld script files.
(put 'less-css-input-file-name 'safe-local-variable #'stringp)
(add-to-list 'auto-mode-alist '("\\.less\\'" . less-css-mode))
(autoload 'less-css-mode "less-css-mode" "\
-Major mode for editing Less files (http://lesscss.org/).
+Major mode for editing Less files (https://lesscss.org/).
Special commands:
\\{less-css-mode-map}
@@ -19277,6 +19588,7 @@ sleep in seconds.
;;; Generated autoloads from emacs-lisp/loaddefs-gen.el
+(put 'autoload-compute-prefixes 'safe-local-variable #'booleanp)
(put 'generated-autoload-file 'safe-local-variable 'stringp)
(put 'generated-autoload-load-name 'safe-local-variable 'stringp)
(autoload 'loaddefs-generate "loaddefs-gen" "\
@@ -19342,7 +19654,7 @@ remove symbols from it in the event that the package has done
something strange, such as redefining an Emacs function.
(fn FEATURE &optional FORCE)" t)
-(register-definition-prefixes "loadhist" '("feature-" "file-" "loadhist-" "read-feature" "unload-"))
+(register-definition-prefixes "loadhist" '("feature-" "file-" "loadhist-unload-filename" "read-feature" "unload-"))
;;; Generated autoloads from cedet/ede/locate.el
@@ -19532,6 +19844,19 @@ Otherwise they are treated as Emacs regexps (for backward compatibility).")
(register-definition-prefixes "ls-lisp" '("ls-lisp-"))
+;;; Generated autoloads from progmodes/lua-ts-mode.el
+
+(autoload 'lua-ts-inferior-lua "lua-ts-mode" "\
+Run a Lua interpreter in an inferior process." t)
+(autoload 'lua-ts-mode "lua-ts-mode" "\
+Major mode for editing Lua files, powered by tree-sitter.
+
+\\{lua-ts-mode-map}
+
+(fn)" t)
+(register-definition-prefixes "lua-ts-mode" '("lua-ts-"))
+
+
;;; Generated autoloads from calendar/lunar.el
(autoload 'lunar-phases "lunar" "\
@@ -19540,7 +19865,7 @@ If called with an optional prefix argument ARG, prompts for month and year.
This function is suitable for execution in an init file.
(fn &optional ARG)" t)
-(register-definition-prefixes "lunar" '("calendar-lunar-phases" "diary-lunar-phases" "eclipse-check" "lunar-"))
+(register-definition-prefixes "lunar" '("calendar-lunar-phases" "diary-lunar-phases" "lunar-"))
;;; Generated autoloads from progmodes/m4-mode.el
@@ -19607,7 +19932,7 @@ For example, in Usenet articles, sections of text quoted from another
author are indented, or have each line start with `>'. To quote a
section of text, define a keyboard macro which inserts `>', put point
and mark at opposite ends of the quoted section, and use
-`\\[apply-macro-to-region-lines]' to mark the entire section.
+\\[apply-macro-to-region-lines] to mark the entire section.
Suppose you wanted to build a keyword table in C where each entry
looked like this:
@@ -19629,11 +19954,11 @@ and write a macro to massage a word into a table entry:
\\C-x )
and then select the region of un-tablified names and use
-`\\[apply-macro-to-region-lines]' to build the table from the names.
+\\[apply-macro-to-region-lines] to build the table from the names.
(fn TOP BOTTOM &optional MACRO)" t)
(define-key ctl-x-map "q" 'kbd-macro-query)
-(register-definition-prefixes "macros" '("macro"))
+(register-definition-prefixes "macros" '("macros--insert-vector-macro"))
;;; Generated autoloads from mail/mail-extr.el
@@ -19791,18 +20116,18 @@ 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.
+`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.
+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.
+The mode's hook is called both when the mode is enabled and when it is
+disabled.
(fn &optional ARG)" t)
(autoload 'mail-abbrevs-setup "mailabbrev" "\
@@ -19955,15 +20280,8 @@ dependency, despite the colon.
\\{makefile-mode-map}
-In the browser, use the following keys:
-
-\\{makefile-browser-map}
-
Makefile mode can be configured by modifying the following variables:
-`makefile-browser-buffer-name':
- Name of the macro- and target browser buffer.
-
`makefile-target-colon':
The string that gets appended to all target names
inserted by `makefile-insert-target'.
@@ -19981,24 +20299,6 @@ Makefile mode can be configured by modifying the following variables:
If you want a TAB (instead of a space) to be appended after the
target colon, then set this to a non-nil value.
-`makefile-browser-leftmost-column':
- Number of blanks to the left of the browser selection mark.
-
-`makefile-browser-cursor-column':
- Column in which the cursor is positioned when it moves
- up or down in the browser.
-
-`makefile-browser-selected-mark':
- String used to mark selected entries in the browser.
-
-`makefile-browser-unselected-mark':
- String used to mark unselected entries in the browser.
-
-`makefile-browser-auto-advance-after-selection-p':
- If this variable is set to a non-nil value the cursor
- will automagically advance to the next line after an item
- has been selected in the browser.
-
`makefile-pickup-everything-picks-up-filenames-p':
If this variable is set to a non-nil value then
`makefile-pickup-everything' also picks up filenames as targets
@@ -20014,10 +20314,6 @@ Makefile mode can be configured by modifying the following variables:
IMPORTANT: Please note that enabling this option causes Makefile mode
to MODIFY A FILE WITHOUT YOUR CONFIRMATION when \"it seems necessary\".
-`makefile-browser-hook':
- A function or list of functions to be called just before the
- browser is entered. This is executed in the makefile buffer.
-
`makefile-special-targets-list':
List of special targets. You will be offered to complete
on one of those in the minibuffer whenever you enter a `.'.
@@ -20101,6 +20397,11 @@ Note that in some cases you will need to use \\[quoted-insert] to quote the
SPC character in the above examples, because this command attempts
to auto-complete your input based on the installed manual pages.
+If `default-directory' is remote, and `Man-support-remote-systems'
+is non-nil, this command formats the man page on the remote system.
+A prefix argument reverses the value of `Man-support-remote-systems'
+for the current invocation.
+
(fn MAN-ARGS)" t)
(autoload 'man-follow "man" "\
Get a Un*x manual page of the item under point and put it in a buffer.
@@ -20142,19 +20443,19 @@ 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.
+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.
+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.
+The mode's hook is called both when the mode is enabled and when it is
+disabled.
(fn &optional ARG)" t)
(register-definition-prefixes "master" '("master-"))
@@ -20180,18 +20481,18 @@ recursion depth in the minibuffer prompt. This is only useful if
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.
+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 \\='minibuffer-depth-indicate-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)
(register-definition-prefixes "mb-depth" '("minibuffer-depth-"))
@@ -20319,7 +20620,15 @@ 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\")'
-(fn &optional URL)" t)
+To facilitate the use of this function within window systems that
+provide message subject, body and attachments independent of URL
+itself, the arguments SUBJECT, BODY and FILE-ATTACHMENTS may also
+provide alternative message subject and body text, which is
+inserted in lieu of nothing if URL does not incorporate such
+information itself, and a list of files to insert as attachments
+to the E-mail.
+
+(fn &optional URL SUBJECT BODY FILE-ATTACHMENTS)" t)
(register-definition-prefixes "message" '("message-"))
@@ -20339,7 +20648,7 @@ Major mode for editing MetaPost sources.
;;; Generated autoloads from mh-e/mh-acros.el
-(register-definition-prefixes "mh-acros" '("defmacro-mh" "defun-mh" "mh-" "with-mh-folder-updating"))
+(register-definition-prefixes "mh-acros" '("mh-" "with-mh-folder-updating"))
;;; Generated autoloads from mh-e/mh-alias.el
@@ -20629,18 +20938,18 @@ or call the function `midnight-mode'.")
Non-nil means run `midnight-hook' at midnight.
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.
+`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)
(autoload 'clean-buffer-list "midnight" "\
@@ -20684,19 +20993,19 @@ 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.
+`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.
+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.
+The mode's hook is called both when the mode is enabled and when it is
+disabled.
(fn &optional ARG)" t)
(register-definition-prefixes "minibuf-eldef" '("minibuf"))
@@ -20727,6 +21036,9 @@ If the region is inactive, duplicate the current line (like `duplicate-line').
Otherwise, duplicate the region, which remains active afterwards.
If the region is rectangular, duplicate on its right-hand side.
Interactively, N is the prefix numeric argument, and defaults to 1.
+The variables `duplicate-line-final-position' and
+`duplicate-region-final-position' control the position of point
+and the region after the duplication.
(fn &optional N)" t)
(autoload 'zap-up-to-char "misc" "\
@@ -20748,15 +21060,17 @@ Uppercasify ARG chars starting from point. Point doesn't move.
(fn ARG)" t)
(autoload 'forward-to-word "misc" "\
-Move forward until encountering the beginning of a word.
-With argument, do this that many times.
+Move forward until encountering the beginning of the ARGth word.
+ARG defaults to 1. When called interactively, ARG is the prefix
+numeric argument.
-(fn ARG)" t)
+(fn &optional ARG)" t)
(autoload 'backward-to-word "misc" "\
-Move backward until encountering the end of a word.
-With argument, do this that many times.
+Move backward until encountering the end of the ARGth word.
+ARG defaults to 1. When called interactively, ARG is the prefix
+numeric argument.
-(fn ARG)" t)
+(fn &optional ARG)" t)
(autoload 'butterfly "misc" "\
Use butterflies to flip the desired bit on the drive platter.
Open hands and let the delicate wings flap once. The disturbance
@@ -20776,7 +21090,7 @@ Optional argument BUFFER specifies a buffer to use, instead of
The return value is always nil.
(fn &optional LOADED-ONLY-P BUFFER)" t)
-(register-definition-prefixes "misc" '("duplicate-line-final-position" "list-dynamic-libraries--"))
+(register-definition-prefixes "misc" '("duplicate-" "list-dynamic-libraries--"))
;;; Generated autoloads from misearch.el
@@ -20854,7 +21168,21 @@ With a prefix argument, ask for a wildcard, and search in file buffers
whose file names match the specified wildcard.
(fn FILES)" t)
-(register-definition-prefixes "misearch" '("misearch-unload-function" "multi-isearch-"))
+(autoload 'multi-file-replace-regexp-as-diff "misearch" "\
+Show as diffs replacements of REGEXP with TO-STRING in FILES.
+DELIMITED has the same meaning as in `replace-regexp'.
+The replacements are displayed in the buffer *replace-diff* that
+you can later apply as a patch after reviewing the changes.
+
+(fn FILES REGEXP TO-STRING &optional DELIMITED)" t)
+(autoload 'replace-regexp-as-diff "misearch" "\
+Show as diffs replacements of REGEXP with TO-STRING in the current buffer.
+DELIMITED has the same meaning as in `replace-regexp'.
+The replacements are displayed in the buffer *replace-diff* that
+you can later apply as a patch after reviewing the changes.
+
+(fn REGEXP TO-STRING &optional DELIMITED)" t)
+(register-definition-prefixes "misearch" '("misearch-unload-function" "multi-"))
;;; Generated autoloads from progmodes/mixal-mode.el
@@ -21195,19 +21523,19 @@ Toggle Msb mode.
This mode overrides the binding(s) of `mouse-buffer-menu' to provide a
different buffer menu using the function `msb'.
-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.
+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.
+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.
+The mode's hook is called both when the mode is enabled and when it is
+disabled.
(fn &optional ARG)" t)
(register-definition-prefixes "msb" '("mouse-select-buffer" "msb"))
@@ -21496,18 +21824,18 @@ or call the function `mouse-wheel-mode'.")
Toggle mouse wheel support (Mouse Wheel 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.
+`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)
(register-definition-prefixes "mwheel" '("mouse-wheel-" "mwheel-"))
@@ -23250,19 +23578,19 @@ Toggle Outline minor mode.
See the command `outline-mode' for more information on this 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.
+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.
+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.
+The mode's hook is called both when the mode is enabled and when it is
+disabled.
(fn &optional ARG)" t)
(autoload 'outline-search-level "outline" "\
@@ -23484,8 +23812,7 @@ that code in the early init-file.
(fn &optional NO-ACTIVATE)" t)
(defun package-activate-all nil "\
Activate all installed packages.
-The variable `package-load-list' controls which packages to load." (setq package--activated t) (let* ((elc (concat package-quickstart-file "c")) (qs (if (file-readable-p elc) elc (if (file-readable-p package-quickstart-file) package-quickstart-file)))) (if (and qs (not (bound-and-true-p package-activated-list))) (let ((load-source-file-function nil)) (unless (boundp 'package-activated-list) (setq package-activated-list nil)) (load qs nil 'nomessage)) (require 'package) (package--activate-all))))
-(autoload 'package--activate-all "package")
+The variable `package-load-list' controls which packages to load." (setq package--activated t) (let* ((elc (concat package-quickstart-file "c")) (qs (if (file-readable-p elc) elc (if (file-readable-p package-quickstart-file) package-quickstart-file)))) (or (and qs (not (bound-and-true-p package-activated-list)) (with-demoted-errors "Error during quickstart: %S" (let ((load-source-file-function nil)) (unless (boundp 'package-activated-list) (setq package-activated-list nil)) (load qs nil 'nomessage) t))) (progn (require 'package) (with-no-warnings (package--activate-all))))))
(autoload 'package-import-keyring "package" "\
Import keys from FILE.
@@ -23530,11 +23857,6 @@ had been enabled.
(autoload 'package-upgrade "package" "\
Upgrade package NAME if a newer version exists.
-Currently, packages which are part of the Emacs distribution
-cannot be upgraded that way. To enable upgrades of such a
-package using this command, first upgrade the package to a
-newer version from ELPA by using `\\<package-menu-mode-map>\\[package-menu-mark-install]' after `\\[list-packages]'.
-
(fn NAME)" t)
(autoload 'package-upgrade-all "package" "\
Refresh package list and upgrade all packages.
@@ -23543,8 +23865,9 @@ interactively, QUERY is always true.
Currently, packages which are part of the Emacs distribution are
not upgraded by this command. To enable upgrading such a package
-using this command, first upgrade the package to a newer version
-from ELPA by using `\\<package-menu-mode-map>\\[package-menu-mark-install]' after `\\[list-packages]'.
+using this command, first upgrade the package to a newer version
+from ELPA by either using `\\[package-upgrade]' or
+`\\<package-menu-mode-map>\\[package-menu-mark-install]' after `\\[list-packages]'.
(fn &optional QUERY)" t)
(autoload 'package-install-from-buffer "package" "\
@@ -23618,6 +23941,11 @@ the `Version:' header.")
(defcustom package-quickstart-file (locate-user-emacs-file "package-quickstart.el") "\
Location of the file used to speed up activation of packages at startup." :type 'file :group 'applications :initialize #'custom-initialize-delay :version "27.1")
(custom-autoload 'package-quickstart-file "package" t)
+(autoload 'package-report-bug "package" "\
+Prepare a message to send to the maintainers of a package.
+DESC must be a `package-desc' object.
+
+(fn DESC)" '(package-menu-mode))
(register-definition-prefixes "package" '("bad-signature" "define-package" "describe-package-1" "package-"))
@@ -23626,40 +23954,59 @@ Location of the file used to speed up activation of packages at startup." :type
(autoload 'package-vc-install-selected-packages "package-vc" "\
Ensure packages specified in `package-vc-selected-packages' are installed." t)
(autoload 'package-vc-upgrade-all "package-vc" "\
-Attempt to upgrade all installed VC packages." t)
+Upgrade all installed VC packages.
+
+This may fail if the local VCS state of one of the packages
+conflicts with its remote repository state." t)
(autoload 'package-vc-upgrade "package-vc" "\
-Attempt to upgrade the package PKG-DESC.
+Upgrade the package described by PKG-DESC from package's VC repository.
+
+This may fail if the local VCS state of the package conflicts
+with the remote repository state.
(fn PKG-DESC)" t)
(autoload 'package-vc-install "package-vc" "\
-Fetch a PACKAGE and set it up for using with Emacs.
-
-If PACKAGE is a string containing an URL, download the package
-from the repository at that URL; the function will try to guess
-the name of the package from the URL. This can be overridden by
-passing the optional argument NAME. If PACKAGE is a cons-cell,
-it should have the form (NAME . SPEC), where NAME is a symbol
-indicating the package name and SPEC is a plist as described in
-`package-vc-selected-packages'. Otherwise PACKAGE should be a
-symbol whose name is the package name, and the URL for the
-package will be taken from the package's metadata.
+Fetch a package described by PACKAGE and set it up for use with Emacs.
+
+PACKAGE specifies which package to install, where to find its
+source repository and how to build it.
+
+If PACKAGE is a symbol, install the package with that name
+according to metadata that package archives provide for it. This
+is the simplest way to call this function, but it only works if
+the package you want to install is listed in a package archive
+you have configured.
+
+If PACKAGE is a string, it specifies the URL of the package
+repository. In this case, optional argument BACKEND specifies
+the VC backend to use for cloning the repository; if it's nil,
+this function tries to infer which backend to use according to
+the value of `package-vc-heuristic-alist' and if that fails it
+uses `package-vc-default-backend'. Optional argument NAME
+specifies the package name in this case; if it's nil, this
+package uses `file-name-base' on the URL to obtain the package
+name, otherwise NAME is the package name as a symbol.
+
+PACKAGE can also be a cons cell (PNAME . SPEC) where PNAME is the
+package name as a symbol, and SPEC is a plist that specifies how
+to fetch and build the package. For possible values, see the
+subsection \"Specifying Package Sources\" in the Info
+node `(emacs)Fetching Package Sources'.
By default, this function installs the last revision of the
package available from its repository. If REV is a string, it
-describes the revision to install, as interpreted by the VC
-backend. The special value `:last-release' (interactively, the
-prefix argument), will use the commit of the latest release, if
-it exists. The last release is the latest revision which changed
-the \"Version:\" header of the package's main Lisp file.
-
-Optional argument BACKEND specifies the VC backend to use for cloning
-the package's repository; this is only possible if NAME-OR-URL is a URL,
-a string. If BACKEND is omitted or nil, the function
-uses `package-vc-heuristic-alist' to guess the backend.
-Note that by default, a VC package will be prioritized over a
-regular package, but it will not remove a VC package.
-
-(fn PACKAGE &optional REV BACKEND)" t)
+describes the revision to install, as interpreted by the relevant
+VC backend. The special value `:last-release' (interactively,
+the prefix argument), says to use the commit of the latest
+release, if it exists. The last release is the latest revision
+which changed the \"Version:\" header of the package's main Lisp
+file.
+
+If you use this function to install a package that you also have
+installed from a package archive, the version this function
+installs takes precedence.
+
+(fn PACKAGE &optional REV BACKEND NAME)" t)
(autoload 'package-vc-checkout "package-vc" "\
Clone the sources for PKG-DESC into DIRECTORY and visit that directory.
Unlike `package-vc-install', this does not yet set up the package
@@ -23673,14 +24020,14 @@ for the last released version of the package.
(fn PKG-DESC DIRECTORY &optional REV)" t)
(autoload 'package-vc-install-from-checkout "package-vc" "\
-Set up the package NAME in DIR by linking it into the ELPA directory.
+Install the package NAME from its source directory DIR.
+NAME defaults to the base name of DIR.
Interactively, prompt the user for DIR, which should be a directory
under version control, typically one created by `package-vc-checkout'.
If invoked interactively with a prefix argument, prompt the user
-for the NAME of the package to set up. Otherwise infer the package
-name from the base name of DIR.
+for the NAME of the package to set up.
-(fn DIR NAME)" t)
+(fn DIR &optional NAME)" t)
(autoload 'package-vc-rebuild "package-vc" "\
Rebuild the installation for package given by PKG-DESC.
Rebuilding an installation means scraping for new autoload
@@ -23692,14 +24039,18 @@ prompt for the name of the package to rebuild.
(fn PKG-DESC)" t)
(autoload 'package-vc-prepare-patch "package-vc" "\
-Send patch for REVISIONS to maintainer of the package PKG using SUBJECT.
-The function uses `vc-prepare-patch', passing SUBJECT and
-REVISIONS directly. PKG-DESC must be a package description.
+Email patches for REVISIONS to maintainer of package PKG-DESC using SUBJECT.
+
+PKG-DESC is a package descriptor and SUBJECT is the subject of
+the message.
+
Interactively, prompt for PKG-DESC, SUBJECT, and REVISIONS. When
invoked with a numerical prefix argument, use the last N
revisions. When invoked interactively in a Log View buffer with
marked revisions, use those.
+See also `vc-prepare-patch'.
+
(fn PKG-DESC SUBJECT REVISIONS)" t)
(register-definition-prefixes "package-vc" '("package-vc-"))
@@ -23728,6 +24079,11 @@ archive).
(register-definition-prefixes "page-ext" '("pages-"))
+;;; Generated autoloads from leim/quail/pakistan.el
+
+(register-definition-prefixes "quail/pakistan" '("pakistan-"))
+
+
;;; Generated autoloads from calendar/parse-time.el
(put 'parse-time-rules 'risky-local-variable t)
@@ -23845,6 +24201,8 @@ FUN in `pred' and `app' can take one of the forms:
call it with one argument
(F ARG1 .. ARGn)
call F with ARG1..ARGn and EXPVAL as n+1'th argument
+ (F ARG1 .. _ .. ARGn)
+ call F, passing EXPVAL at the _ position.
FUN, BOOLEXP, and subsequent PAT can refer to variables
bound earlier in the pattern by a SYMBOL pattern.
@@ -24061,7 +24419,7 @@ Completion for checksum commands.")
(defalias 'pcomplete/sha224sum 'pcomplete/md5sum)
(defalias 'pcomplete/sha256sum 'pcomplete/md5sum)
(defalias 'pcomplete/sha384sum 'pcomplete/md5sum)
-(defalias 'pcomplete/sha521sum 'pcomplete/md5sum)
+(defalias 'pcomplete/sha512sum 'pcomplete/md5sum)
(autoload 'pcomplete/sort "pcmpl-unix" "\
Completion for the `sort' command.")
(autoload 'pcomplete/shuf "pcmpl-unix" "\
@@ -24190,6 +24548,8 @@ Includes files as well as host names followed by a colon.")
(autoload 'pcomplete/telnet "pcmpl-unix")
(autoload 'pcomplete/sudo "pcmpl-unix" "\
Completion for the `sudo' command.")
+(autoload 'pcomplete/doas "pcmpl-unix" "\
+Completion for the `doas' command.")
(register-definition-prefixes "pcmpl-unix" '("pcmpl-" "pcomplete/"))
@@ -24517,20 +24877,32 @@ or call the function `pixel-scroll-mode'.")
A minor mode to scroll text pixel-by-pixel.
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.
+`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)
+(autoload 'pixel-scroll-precision-scroll-down-page "pixel-scroll" "\
+Scroll the current window down by DELTA pixels.
+Note that this function doesn't work if DELTA is larger than
+the height of the current window.
+
+(fn DELTA)")
+(autoload 'pixel-scroll-precision-scroll-up-page "pixel-scroll" "\
+Scroll the current window up by DELTA pixels.
+Note that this function doesn't work if DELTA is larger than
+the height of the current window.
+
+(fn DELTA)")
(defvar pixel-scroll-precision-mode nil "\
Non-nil if Pixel-Scroll-Precision mode is enabled.
See the `pixel-scroll-precision-mode' command
@@ -24542,23 +24914,22 @@ 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
+When enabled, this minor mode allows you to scroll the display
precisely, according to the turning of the mouse wheel.
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.
+`Pixel-Scroll-Precision 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-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)
(register-definition-prefixes "pixel-scroll" '("pixel-"))
@@ -24622,8 +24993,9 @@ Use streaming commands.
Return a string containing the pretty-printed representation of OBJECT.
OBJECT can be any Lisp object. Quoting characters are used as needed
to make output that `read' can handle, whenever this is possible.
+Optional argument PP-FUNCTION overrides `pp-default-function'.
-(fn OBJECT)")
+(fn OBJECT &optional PP-FUNCTION)")
(autoload 'pp-buffer "pp" "\
Prettify the current buffer with printed representation of a Lisp object." t)
(autoload 'pp "pp" "\
@@ -24631,11 +25003,7 @@ Output the pretty-printed representation of OBJECT, any Lisp object.
Quoting characters are printed as needed to make output that `read'
can handle, whenever this is possible.
-This function does not apply special formatting rules for Emacs
-Lisp code. See `pp-emacs-lisp-code' instead.
-
-By default, this function won't limit the line length of lists
-and vectors. Bind `pp-use-max-width' to a non-nil value to do so.
+Uses the pretty-printing code specified in `pp-default-function'.
Output stream is STREAM, or value of `standard-output' (which see).
@@ -24673,8 +25041,10 @@ Ignores leading comment characters.
Insert SEXP into the current buffer, formatted as Emacs Lisp code.
Use the `pp-max-width' variable to control the desired line length.
Note that this could be slow for large SEXPs.
+Can also be called with two arguments, in which case they're taken to be
+the bounds of a region containing Lisp code to pretty-print.
-(fn SEXP)")
+(fn SEXP &optional END)")
(register-definition-prefixes "pp" '("pp-"))
@@ -25259,14 +25629,16 @@ Open profile FILENAME.
;;; Generated autoloads from progmodes/project.el
-(push (purecopy '(project 0 9 8)) package--builtin-versions)
+(push (purecopy '(project 0 10 0)) package--builtin-versions)
(autoload 'project-current "project" "\
Return the project instance in DIRECTORY, defaulting to `default-directory'.
When no project is found in that directory, the result depends on
the value of MAYBE-PROMPT: if it is nil or omitted, return nil,
-else ask the user for a directory in which to look for the
-project, and if no project is found there, return a \"transient\"
+else prompt the user for the project to use. To prompt for a
+project, call the function specified by `project-prompter', which
+returns the directory in which to look for the project. If no
+project is found in that directory, return a \"transient\"
project instance.
The \"transient\" project instance is a special kind of value
@@ -25278,12 +25650,12 @@ See the doc string of `project-find-functions' for the general form
of the project instance object.
(fn &optional MAYBE-PROMPT DIRECTORY)")
-(put 'project-vc-ignores 'safe-local-variable #'listp)
+(put 'project-vc-ignores 'safe-local-variable (lambda (val) (and (listp val) (not (memq nil (mapcar #'stringp val))))))
(put 'project-vc-merge-submodules 'safe-local-variable #'booleanp)
(put 'project-vc-include-untracked 'safe-local-variable #'booleanp)
(put 'project-vc-name 'safe-local-variable #'stringp)
(put 'project-vc-extra-root-markers 'safe-local-variable (lambda (val) (and (listp val) (not (memq nil (mapcar #'stringp val))))))
-(defvar project-prefix-map (let ((map (make-sparse-keymap))) (define-key map "!" 'project-shell-command) (define-key map "&" 'project-async-shell-command) (define-key map "f" 'project-find-file) (define-key map "F" 'project-or-external-find-file) (define-key map "b" 'project-switch-to-buffer) (define-key map "s" 'project-shell) (define-key map "d" 'project-find-dir) (define-key map "D" 'project-dired) (define-key map "v" 'project-vc-dir) (define-key map "c" 'project-compile) (define-key map "e" 'project-eshell) (define-key map "k" 'project-kill-buffers) (define-key map "p" 'project-switch-project) (define-key map "g" 'project-find-regexp) (define-key map "G" 'project-or-external-find-regexp) (define-key map "r" 'project-query-replace-regexp) (define-key map "x" 'project-execute-extended-command) (define-key map "\2" 'project-list-buffers) map) "\
+(defvar project-prefix-map (let ((map (make-sparse-keymap))) (define-key map "!" 'project-shell-command) (define-key map "&" 'project-async-shell-command) (define-key map "f" 'project-find-file) (define-key map "F" 'project-or-external-find-file) (define-key map "b" 'project-switch-to-buffer) (define-key map "s" 'project-shell) (define-key map "d" 'project-find-dir) (define-key map "D" 'project-dired) (define-key map "v" 'project-vc-dir) (define-key map "c" 'project-compile) (define-key map "e" 'project-eshell) (define-key map "k" 'project-kill-buffers) (define-key map "p" 'project-switch-project) (define-key map "g" 'project-find-regexp) (define-key map "G" 'project-or-external-find-regexp) (define-key map "r" 'project-query-replace-regexp) (define-key map "x" 'project-execute-extended-command) (define-key map "o" 'project-any-command) (define-key map "\2" 'project-list-buffers) map) "\
Keymap for project commands.")
(define-key ctl-x-map "p" project-prefix-map)
(autoload 'project-other-window-command "project" "\
@@ -25321,15 +25693,14 @@ requires quoting, e.g. `\\[quoted-insert]<space>'.
(fn REGEXP)" t)
(autoload 'project-or-external-find-regexp "project" "\
Find all matches for REGEXP in the project roots or external roots.
-With \\[universal-argument] prefix, you can specify the file name
-pattern to search for.
(fn REGEXP)" t)
(autoload 'project-find-file "project" "\
Visit a file (with completion) in the current project.
The filename at point (determined by `thing-at-point'), if any,
-is available as part of \"future history\".
+is available as part of \"future history\". If none, the current
+buffer's file name is used.
If INCLUDE-ALL is non-nil, or with prefix argument when called
interactively, include all files under the project root, except
@@ -25340,7 +25711,8 @@ for VCS directories listed in `vc-directory-exclusion-list'.
Visit a file (with completion) in the current project or external roots.
The filename at point (determined by `thing-at-point'), if any,
-is available as part of \"future history\".
+is available as part of \"future history\". If none, the current
+buffer's file name is used.
If INCLUDE-ALL is non-nil, or with prefix argument when called
interactively, include all files under the project root, except
@@ -25348,7 +25720,10 @@ for VCS directories listed in `vc-directory-exclusion-list'.
(fn &optional INCLUDE-ALL)" t)
(autoload 'project-find-dir "project" "\
-Start Dired in a directory inside the current project." t)
+Start Dired in a directory inside the current project.
+
+The current buffer's `default-directory' is available as part of
+\"future history\"." t)
(autoload 'project-dired "project" "\
Start Dired in the current project's root." t)
(autoload 'project-vc-dir "project" "\
@@ -25463,6 +25838,24 @@ Return the list of root directories of all known projects.")
(autoload 'project-execute-extended-command "project" "\
Execute an extended command in project root." t)
(function-put 'project-execute-extended-command 'interactive-only 'command-execute)
+(autoload 'project-any-command "project" "\
+Run the next command in the current project.
+
+If the command name starts with `project-', or its symbol has
+property `project-aware', it gets passed the project to use
+with the variable `project-current-directory-override'.
+Otherwise, `default-directory' is temporarily set to the current
+project's root.
+
+If OVERRIDING-MAP is non-nil, it will be used as
+`overriding-terminal-local-map' to provide shorter bindings
+from that map which will take priority over the global ones.
+
+(fn &optional OVERRIDING-MAP PROMPT-FORMAT)" t)
+(autoload 'project-prefix-or-any-command "project" "\
+Run the next command in the current project.
+Works like `project-any-command', but also mixes in the shorter
+bindings from `project-prefix-map'." t)
(autoload 'project-switch-project "project" "\
\"Switch\" to another project by running an Emacs command.
The available commands are presented as a dispatch menu
@@ -25472,6 +25865,21 @@ When called in a program, it will use the project corresponding
to directory DIR.
(fn DIR)" t)
+(autoload 'project-uniquify-dirname-transform "project" "\
+Uniquify name of directory DIRNAME using `project-name', if in a project.
+
+If you set `uniquify-dirname-transform' to this function,
+slash-separated components from `project-name' will be appended to
+the buffer's directory name when buffers from two different projects
+would otherwise have the same name.
+
+(fn DIRNAME)")
+(defvar project-mode-line nil "\
+Whether to show current project name and Project menu on the mode line.
+This feature requires the presence of the following item in
+`mode-line-format': `(project-mode-line project-mode-line-format)'; it
+is part of the default mode line beginning with Emacs 30.")
+(custom-autoload 'project-mode-line "project" t)
(register-definition-prefixes "project" '("project-"))
@@ -25491,7 +25899,7 @@ line and comments can also be enclosed in /* ... */.
If an optional argument SYSTEM is non-nil, set up mode for the given system.
To find out what version of Prolog mode you are running, enter
-`\\[prolog-mode-version]'.
+\\[prolog-mode-version].
Commands:
\\{prolog-mode-map}
@@ -25836,6 +26244,7 @@ Major mode for editing Python files, using tree-sitter library.
\\{python-ts-mode-map}
(fn)" t)
+(add-to-list 'auto-mode-alist '("/\\(?:Pipfile\\|\\.?flake8\\)\\'" . conf-mode))
(register-definition-prefixes "python" '("inferior-python-mode" "python-" "run-python-internal"))
@@ -26120,19 +26529,18 @@ or call the function `rcirc-track-minor-mode'.")
Global minor mode for tracking activity in rcirc buffers.
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.
+`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)
(register-definition-prefixes "rcirc" '("rcirc-" "with-rcirc-"))
@@ -26195,18 +26603,18 @@ buffers you switch to a lot, you can say something like the following:
(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.
+`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.
+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.
+The mode's hook is called both when the mode is enabled and when it is
+disabled.
(fn &optional ARG)" t)
(register-definition-prefixes "recentf" '("recentf-"))
@@ -26337,20 +26745,18 @@ 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.
+`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.
-
-\\{rectangle-mark-mode-map}
+The mode's hook is called both when the mode is enabled and when it is
+disabled.
(fn &optional ARG)" t)
(register-definition-prefixes "rect" '("apply-on-rectangle" "clear-rectangle-line" "delete-" "extract-rectangle-" "killed-rectangle" "ope" "rectangle-" "spaces-string" "string-rectangle-"))
@@ -26378,19 +26784,19 @@ 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.
+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.
+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.
+The mode's hook is called both when the mode is enabled and when it is
+disabled.
(fn &optional ARG)" t)
(register-definition-prefixes "refill" '("refill-"))
@@ -26440,19 +26846,19 @@ 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.
+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.
+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.
+The mode's hook is called both when the mode is enabled and when it is
+disabled.
(fn &optional ARG)" t)
(autoload 'reftex-reset-scanning-information "reftex" "\
@@ -26511,7 +26917,7 @@ This enforces rescanning the buffer on next use.")
(put 'reftex-vref-is-default 'safe-local-variable (lambda (x) (or (stringp x) (symbolp x))))
(put 'reftex-fref-is-default 'safe-local-variable (lambda (x) (or (stringp x) (symbolp x))))
(put 'reftex-level-indent 'safe-local-variable 'integerp)
-(put 'reftex-guess-label-type 'safe-local-variable (lambda (x) (memq x '(nil t))))
+(put 'reftex-guess-label-type 'safe-local-variable #'booleanp)
(register-definition-prefixes "reftex-vars" '("reftex-"))
@@ -26565,12 +26971,16 @@ usually more efficient than that of a simplified version:
(cdr parens))))
(fn STRINGS &optional PAREN)")
+(function-put 'regexp-opt 'pure 't)
+(function-put 'regexp-opt 'side-effect-free 't)
(autoload 'regexp-opt-depth "regexp-opt" "\
Return the depth of REGEXP.
This means the number of non-shy regexp grouping constructs
(parenthesized expressions) in REGEXP.
(fn REGEXP)")
+(function-put 'regexp-opt-depth 'pure 't)
+(function-put 'regexp-opt-depth 'side-effect-free 't)
(register-definition-prefixes "regexp-opt" '("regexp-opt-"))
@@ -26670,18 +27080,18 @@ keys for repeating.
See `describe-repeat-maps' for a list of all repeatable commands.
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.
+`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)
(autoload 'repeat-exit "repeat" "\
@@ -26757,19 +27167,19 @@ 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.
+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.
+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.
+The mode's hook is called both when the mode is enabled and when it is
+disabled.
(fn &optional ARG)" t)
(defvar global-reveal-mode nil "\
@@ -26786,18 +27196,18 @@ Toggle Reveal mode in all buffers (Global Reveal mode).
Reveal mode renders invisible text around point visible again.
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.
+`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)
(register-definition-prefixes "reveal" '("reveal-"))
@@ -27340,19 +27750,19 @@ 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.
+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.
+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.
+The mode's hook is called both when the mode is enabled and when it is
+disabled.
(fn &optional ARG)" t)
(register-definition-prefixes "rng-valid" '("rng-"))
@@ -27466,19 +27876,19 @@ 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.
-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.
+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.
+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.
+The mode's hook is called both when the mode is enabled and when it is
+disabled.
(fn &optional ARG)" t)
(register-definition-prefixes "rst" '("rst-"))
@@ -27503,8 +27913,8 @@ Currently there are `ruby-mode' and `ruby-ts-mode'.
Major mode for editing Ruby code.
(fn)" t)
-(add-to-list 'auto-mode-alist (cons (purecopy (concat "\\(?:\\.\\(?:" "rbw?\\|ru\\|rake\\|thor" "\\|jbuilder\\|rabl\\|gemspec\\|podspec" "\\)" "\\|/" "\\(?:Gem\\|Rake\\|Cap\\|Thor" "\\|Puppet\\|Berks\\|Brew" "\\|Vagrant\\|Guard\\|Pod\\)file" "\\)\\'")) 'ruby-mode))
-(dolist (name (list "ruby" "rbx" "jruby" "ruby1.9" "ruby1.8")) (add-to-list 'interpreter-mode-alist (cons (purecopy name) 'ruby-mode)))
+(add-to-list 'auto-mode-alist (cons (purecopy (concat "\\(?:\\.\\(?:" "rbw?\\|ru\\|rake\\|thor\\|axlsx" "\\|jbuilder\\|rabl\\|gemspec\\|podspec" "\\)" "\\|/" "\\(?:Gem\\|Rake\\|Cap\\|Thor" "\\|Puppet\\|Berks\\|Brew\\|Fast" "\\|Vagrant\\|Guard\\|Pod\\)file" "\\)\\'")) 'ruby-mode))
+(dolist (name (list "ruby" "rbx" "jruby" "j?ruby\\(?:[0-9.]+\\)")) (add-to-list 'interpreter-mode-alist (cons (purecopy name) 'ruby-mode)))
(register-definition-prefixes "ruby-mode" '("ruby-"))
@@ -27526,19 +27936,19 @@ Use the command `ruler-mode' to change this variable.")
(autoload 'ruler-mode "ruler-mode" "\
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.
+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.
-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)
(register-definition-prefixes "ruler-mode" '("ruler-"))
@@ -27565,6 +27975,7 @@ group.
For extending the `rx' notation in FORM, use `rx-define' or `rx-let-eval'.
(fn FORM &optional NO-GROUP)")
+(function-put 'rx-to-string 'important-return-value 't)
(autoload 'rx "rx" "\
Translate regular expressions REGEXPS in sexp form to a regexp string.
Each argument is one of the forms below; RX is a subform, and RX... stands
@@ -27735,7 +28146,8 @@ For more details, see Info node `(elisp) Extending Rx'.
(fn NAME [(ARGS...)] RX)" nil t)
(function-put 'rx-define 'lisp-indent-function 'defun)
-(eval-and-compile (defun rx--pcase-macroexpander (&rest regexps) "A pattern that matches strings against `rx' REGEXPS in sexp form.
+(autoload 'rx--pcase-macroexpander "rx" "\
+A pattern that matches strings against `rx' REGEXPS in sexp form.
REGEXPS are interpreted as in `rx'. The pattern matches any
string that is a match for REGEXPS, as if by `string-match'.
@@ -27749,7 +28161,9 @@ following constructs:
(backref REF) matches whatever the submatch REF matched.
REF can be a number, as usual, or a name
introduced by a previous (let REF ...)
- construct." (rx--pcase-expand regexps)))
+ construct.
+
+(fn &rest REGEXPS)")
(define-symbol-prop 'rx--pcase-macroexpander 'edebug-form-spec 'nil)
(define-symbol-prop 'rx 'pcase-macroexpander #'rx--pcase-macroexpander)
(autoload 'rx--pcase-expand "rx" "\
@@ -27829,18 +28243,18 @@ 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.
+`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.
+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.
+The mode's hook is called both when the mode is enabled and when it is
+disabled.
(fn &optional ARG)" t)
(register-definition-prefixes "savehist" '("savehist-"))
@@ -27863,18 +28277,18 @@ 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 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.
+`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)
(autoload 'save-place-local-mode "saveplace" "\
@@ -27890,19 +28304,18 @@ 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.
+`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.
+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.
+The mode's hook is called both when the mode is enabled and when it is
+disabled.
(fn &optional ARG)" t)
(register-definition-prefixes "saveplace" '("save-place"))
@@ -27989,18 +28402,18 @@ When Scroll-All mode is enabled, scrolling commands invoked in
one window apply to all visible windows in the same frame.
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.
+`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.
+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.
+The mode's hook is called both when the mode is enabled and when it is
+disabled.
(fn &optional ARG)" t)
(register-definition-prefixes "scroll-all" '("scroll-all-"))
@@ -28024,19 +28437,19 @@ boundaries during scrolling.
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.
+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.
+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.
+The mode's hook is called both when the mode is enabled and when it is
+disabled.
(fn &optional ARG)" t)
(register-definition-prefixes "scroll-lock" '("scroll-lock-"))
@@ -28100,18 +28513,18 @@ 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.
+`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.
+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.
+The mode's hook is called both when the mode is enabled and when it is
+disabled.
(fn &optional ARG)" t)
(register-definition-prefixes "semantic" '("bovinate" "semantic-"))
@@ -28420,18 +28833,18 @@ Server mode runs a process that accepts commands from the
`server-start' for details.
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.
+`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.
+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.
+The mode's hook is called both when the mode is enabled and when it is
+disabled.
(fn &optional ARG)" t)
(autoload 'server-save-buffers-kill-terminal "server" "\
@@ -28441,29 +28854,17 @@ With ARG non-nil, silently save all file-visiting buffers, then kill.
If emacsclient was started with a list of filenames to edit, then
only these files will be asked to be saved.
+When running Emacs as a daemon and with
+`server-stop-automatically' (which see) set to `kill-terminal' or
+`delete-frame', this function may call `save-buffers-kill-emacs'
+if there are no other active clients.
+
(fn ARG)")
(autoload 'server-stop-automatically "server" "\
-Automatically stop server as specified by ARG.
-
-If ARG is the symbol `empty', stop the server when it has no
-remaining clients, no remaining unsaved file-visiting buffers,
-and no running processes with a `query-on-exit' flag.
-
-If ARG is the symbol `delete-frame', ask the user when the last
-frame is deleted whether each unsaved file-visiting buffer must
-be saved and each running process with a `query-on-exit' flag
-can be stopped, and if so, stop the server itself.
-
-If ARG is the symbol `kill-terminal', ask the user when the
-terminal is killed with \\[save-buffers-kill-terminal] whether each unsaved file-visiting
-buffer must be saved and each running process with a `query-on-exit'
-flag can be stopped, and if so, stop the server itself.
-
-Any other value of ARG will cause this function to signal an error.
-
-This function is meant to be called from the user init file.
+Automatically stop the Emacs server as specified by VALUE.
+This sets the variable `server-stop-automatically' (which see).
-(fn ARG)")
+(fn VALUE)")
(register-definition-prefixes "server" '("server-"))
@@ -28784,6 +29185,10 @@ Make the shell buffer the current buffer, and return it.
;;; Generated autoloads from emacs-lisp/shortdoc.el
+(autoload 'shortdoc--check "shortdoc" "\
+
+
+(fn GROUP FUNCTIONS)")
(defvar shortdoc--groups nil)
(defmacro define-short-documentation-group (group &rest functions) "\
Add GROUP to the list of defined documentation groups.
@@ -28847,7 +29252,7 @@ execution of the documented form depends on some conditions.
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) shortdoc--groups)) (push (cons ',group ',functions) shortdoc--groups)))
+`:eg-result-string' properties." (declare (indent defun)) (shortdoc--check group functions) `(progn (setq shortdoc--groups (delq (assq ',group shortdoc--groups) shortdoc--groups)) (push (cons ',group ',functions) shortdoc--groups)))
(autoload 'shortdoc-display-group "shortdoc" "\
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).
@@ -29112,19 +29517,19 @@ Minor mode to simplify editing output from the diff3 program.
\\{smerge-mode-map}
-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.
+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.
+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.
+The mode's hook is called both when the mode is enabled and when it is
+disabled.
(fn &optional ARG)" t)
(autoload 'smerge-start-session "smerge-mode" "\
@@ -29227,19 +29632,19 @@ 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.
+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.
+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.
+The mode's hook is called both when the mode is enabled and when it is
+disabled.
(fn &optional ARG)" t)
(autoload 'so-long-mode "so-long" "\
@@ -29317,18 +29722,18 @@ Use \\[so-long-customize] to open the customization group `so-long' to
configure the behavior.
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.
+`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.
+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.
+The mode's hook is called both when the mode is enabled and when it is
+disabled.
(fn &optional ARG)" t)
(register-definition-prefixes "so-long" '("so-long-" "turn-o"))
@@ -29336,7 +29741,7 @@ it is disabled.
;;; Generated autoloads from net/soap-client.el
-(push (purecopy '(soap-client 3 2 1)) package--builtin-versions)
+(push (purecopy '(soap-client 3 2 3)) package--builtin-versions)
(register-definition-prefixes "soap-client" '("soap-"))
@@ -29565,6 +29970,24 @@ For example: to sort lines in the region by the first word on each line
RECORD-REGEXP would be \"^.*$\" and KEY would be \"\\\\=\\<f\\\\w*\\\\>\"
(fn REVERSE RECORD-REGEXP KEY-REGEXP BEG END)" t)
+(autoload 'sort-on "sort" "\
+Sort SEQUENCE by calling PREDICATE on sort keys produced by ACCESSOR.
+SEQUENCE should be the input sequence to sort.
+Elements of SEQUENCE are sorted by keys which are obtained by
+calling ACCESSOR on each element. ACCESSOR should be a function of
+one argument, an element of SEQUENCE, and should return the key
+value to be compared by PREDICATE for sorting the element.
+PREDICATE is the function for comparing keys; it is called with two
+arguments, the keys to compare, and should return non-nil if the
+first key should sort before the second key.
+The return value is always a new list.
+This function has the performance advantage of evaluating
+ACCESSOR only once for each element in the input SEQUENCE, and is
+therefore appropriate when computing the key by ACCESSOR is an
+expensive operation. This is known as the \"decorate-sort-undecorate\"
+paradigm, or the Schwartzian transform.
+
+(fn SEQUENCE PREDICATE ACCESSOR)")
(autoload 'sort-columns "sort" "\
Sort lines in region alphabetically by a certain range of columns.
For the purpose of this command, the region BEG...END includes
@@ -30344,18 +30767,18 @@ 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.
+`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.
+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.
+The mode's hook is called both when the mode is enabled and when it is
+disabled.
(fn &optional ARG)" t)
(autoload 'strokes-decode-buffer "strokes" "\
@@ -30388,7 +30811,7 @@ Studlify-case the current buffer." t)
(defsubst string-join (strings &optional separator) "\
Join all STRINGS using SEPARATOR.
Optional argument SEPARATOR must be a string, a vector, or a list of
-characters; nil stands for the empty string." (mapconcat #'identity strings separator))
+characters; nil stands for the empty string." (declare (pure t) (side-effect-free t)) (mapconcat #'identity strings separator))
(autoload 'string-truncate-left "subr-x" "\
If STRING is longer than LENGTH, return a truncated version.
When truncating, \"...\" is always prepended to the string, so
@@ -30396,10 +30819,12 @@ the resulting string may be longer than the original if LENGTH is
3 or smaller.
(fn STRING LENGTH)")
+(function-put 'string-truncate-left 'pure 't)
+(function-put 'string-truncate-left 'side-effect-free 't)
(defsubst string-blank-p (string) "\
Check whether STRING is either empty or only whitespace.
The following characters count as whitespace here: space, tab, newline and
-carriage return." (string-match-p "\\`[ \11\n\15]*\\'" string))
+carriage return." (declare (pure t) (side-effect-free t)) (string-match-p "\\`[ \11\n\15]*\\'" string))
(autoload 'string-clean-whitespace "subr-x" "\
Clean up whitespace in STRING.
All sequences of whitespaces in STRING are collapsed into a
@@ -30407,6 +30832,7 @@ single space character, and leading/trailing whitespace is
removed.
(fn STRING)")
+(function-put 'string-clean-whitespace 'important-return-value 't)
(autoload 'named-let "subr-x" "\
Looping construct taken from Scheme.
Like `let', bind variables in BINDINGS and then evaluate BODY,
@@ -30414,12 +30840,15 @@ but with the twist that BODY can evaluate itself recursively by
calling NAME, where the arguments passed to NAME are used
as the new values of the bound variables in the recursive invocation.
+This construct can only be used with lexical binding.
+
(fn NAME BINDINGS &rest BODY)" nil t)
(function-put 'named-let 'lisp-indent-function 2)
(autoload 'string-pixel-width "subr-x" "\
Return the width of STRING in pixels.
(fn STRING)")
+(function-put 'string-pixel-width 'important-return-value 't)
(autoload 'string-glyph-split "subr-x" "\
Split STRING into a list of strings representing separate glyphs.
This takes into account combining characters and grapheme clusters:
@@ -30428,6 +30857,7 @@ on display into a single grapheme cluster is treated as a single
indivisible unit.
(fn STRING)")
+(function-put 'string-glyph-split 'side-effect-free 't)
(autoload 'add-display-text-property "subr-x" "\
Add display property PROP with VALUE to the text from START to END.
If any text in the region has a non-nil `display' property, those
@@ -30468,19 +30898,19 @@ 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.
+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.
+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.
+The mode's hook is called both when the mode is enabled and when it is
+disabled.
(fn &optional ARG)" t)
(put 'global-subword-mode 'globalized-minor-mode t)
@@ -30517,19 +30947,19 @@ syntax are treated as parts of words: e.g., in `superword-mode',
\\{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.
+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.
+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.
+The mode's hook is called both when the mode is enabled and when it is
+disabled.
(fn &optional ARG)" t)
(put 'global-superword-mode 'globalized-minor-mode t)
@@ -30621,18 +31051,18 @@ 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.
+`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.
+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.
+The mode's hook is called both when the mode is enabled and when it is
+disabled.
(fn &optional ARG)" t)
(register-definition-prefixes "t-mouse" '("gpm-mouse-"))
@@ -30643,19 +31073,19 @@ it is disabled.
(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)
(defvar-local tab-line-exclude nil)
@@ -30727,19 +31157,18 @@ 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)
(autoload 'table-insert "table" "\
@@ -31315,7 +31744,7 @@ See also: variables `tar-update-datestamp' and `tar-anal-blocksize'.
\\{tar-mode-map}
(fn)" t)
-(register-definition-prefixes "tar-mode" '("tar-"))
+(register-definition-prefixes "tar-mode" '("pax-" "tar-"))
;;; Generated autoloads from progmodes/tcl.el
@@ -31596,6 +32025,9 @@ such as if there are no commands in the file, the value of `tex-default-mode'
says which mode to use.
(fn)" t)
+ (add-to-list 'major-mode-remap-defaults '(TeX-mode . tex-mode))
+ (add-to-list 'major-mode-remap-defaults '(plain-TeX-mode . plain-tex-mode))
+ (add-to-list 'major-mode-remap-defaults '(LaTeX-mode . latex-mode))
(defalias 'TeX-mode #'tex-mode)
(defalias 'plain-TeX-mode #'plain-tex-mode)
(defalias 'LaTeX-mode #'latex-mode)
@@ -32145,19 +32577,19 @@ 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.
+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.
+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.
+The mode's hook is called both when the mode is enabled and when it is
+disabled.
(fn &optional ARG)" t)
(register-definition-prefixes "tildify" '("tildify-"))
@@ -32193,25 +32625,25 @@ 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.
+`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.
+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.
+The mode's hook is called both when the mode is enabled and when it is
+disabled.
(fn &optional ARG)" t)
(define-obsolete-function-alias 'display-time-world #'world-clock "28.1")
(autoload 'world-clock "time" "\
Display a world clock buffer with times in various time zones.
The variable `world-clock-list' specifies which time zones to use.
-To turn off the world time display, go to the window and type `\\[quit-window]'." t)
+To turn off the world time display, go to the window and type \\[quit-window]." t)
(autoload 'emacs-uptime "time" "\
Return a string giving the uptime of this instance of Emacs.
FORMAT is a string to format the result, using `format-seconds'.
@@ -32492,21 +32924,16 @@ List all timers in a buffer.
;;; Generated autoloads from international/titdic-cnv.el
(autoload 'titdic-convert "titdic-cnv" "\
-Convert a TIT dictionary of FILENAME into a Quail package.
-Optional argument DIRNAME if specified is the directory name under which
-the generated Quail package is saved.
-(fn FILENAME &optional DIRNAME)" t)
+
+(fn FILENAME &optional DIRNAME)")
+(make-obsolete 'titdic-convert 'tit-dic-convert "30.1")
(autoload 'batch-titdic-convert "titdic-cnv" "\
-Run `titdic-convert' on the files remaining on the command line.
-Use this from the command line, with `-batch';
-it won't work in an interactive Emacs.
-For example, invoke \"emacs -batch -f batch-titdic-convert XXX.tit\" to
- generate Quail package file \"xxx.el\" from TIT dictionary file \"XXX.tit\".
-To get complete usage, invoke \"emacs -batch -f batch-titdic-convert -h\".
+
(fn &optional FORCE)")
-(register-definition-prefixes "titdic-cnv" '("batch-miscdic-convert" "ctlau-" "miscdic-convert" "pinyin-convert" "py-converter" "quail-" "quick-" "tit-" "tsang-" "ziranma-converter"))
+(make-obsolete 'batch-titdic-convert 'batch-tit-dic-convert "30.1")
+(register-definition-prefixes "titdic-cnv" '("batch-tit-" "tit-"))
;;; Generated autoloads from tmm.el
@@ -32584,7 +33011,7 @@ current (i.e., last displayed) category.
In Todo mode just the category's unfinished todo items are shown
by default. The done items are hidden, but typing
-`\\[todo-toggle-view-done-items]' displays them below the todo
+\\[todo-toggle-view-done-items] displays them below the todo
items. With non-nil user option `todo-show-with-done' both todo
and done items are always shown on visiting a category.
@@ -32592,20 +33019,14 @@ and done items are always shown on visiting a category.
(autoload 'todo-mode "todo-mode" "\
Major mode for displaying, navigating and editing todo lists.
-\\{todo-mode-map}
-
(fn)" t)
(autoload 'todo-archive-mode "todo-mode" "\
Major mode for archived todo categories.
-\\{todo-archive-mode-map}
-
(fn)" t)
(autoload 'todo-filtered-items-mode "todo-mode" "\
Mode for displaying and reprioritizing top priority Todo.
-\\{todo-filtered-items-mode-map}
-
(fn)" t)
(register-definition-prefixes "todo-mode" '("todo-"))
@@ -32681,7 +33102,7 @@ FROM-MAP must contain appropriate binding for `[menu-bar]' which
holds a keymap.
(fn COMMAND ICON IN-MAP &optional FROM-MAP &rest PROPS)")
-(register-definition-prefixes "tool-bar" '("toggle-tool-bar-mode-from-frame" "tool-bar-"))
+(register-definition-prefixes "tool-bar" '("modifier-bar-" "secondary-tool-bar-map" "toggle-tool-bar-mode-from-frame" "tool-bar-"))
;;; Generated autoloads from tooltip.el
@@ -32689,6 +33110,61 @@ holds a keymap.
(register-definition-prefixes "tooltip" '("tooltip-"))
+;;; Generated autoloads from touch-screen.el
+
+(autoload 'touch-screen-hold "touch-screen" "\
+Handle a long press EVENT.
+Ding and select the window at EVENT, then activate the mark. If
+`touch-screen-word-select' is enabled, try to select the whole
+word around EVENT; otherwise, set point to the location of EVENT.
+
+(fn EVENT)" t)
+(autoload 'touch-screen-track-tap "touch-screen" "\
+Track a single tap starting from EVENT.
+EVENT should be a `touchscreen-begin' event.
+
+Read touch screen events until a `touchscreen-end' event is
+received with the same ID as in EVENT. If UPDATE is non-nil and
+a `touchscreen-update' event is received in the mean time and
+contains a touch point with the same ID as in EVENT, call UPDATE
+with that event and DATA.
+
+If THRESHOLD is non-nil, enforce a threshold of movement that is
+either itself or 10 pixels when it is not a number. If the
+aforementioned touch point moves beyond that threshold on any
+axis, return nil immediately, and further resume mouse event
+translation for the touch point at hand.
+
+Return nil immediately if any other kind of event is received;
+otherwise, return t once the `touchscreen-end' event arrives.
+
+(fn EVENT &optional UPDATE DATA THRESHOLD)")
+(autoload 'touch-screen-track-drag "touch-screen" "\
+Track a single drag starting from EVENT.
+EVENT should be a `touchscreen-begin' event.
+
+Read touch screen events until a `touchscreen-end' event is
+received with the same ID as in EVENT. For each
+`touchscreen-update' event received in the mean time containing a
+touch point with the same ID as in EVENT, call UPDATE with the
+touch point in event and DATA, once the touch point has moved
+significantly by at least 5 pixels from where it was in EVENT.
+
+Return nil immediately if any other kind of event is received;
+otherwise, return either t or `no-drag' once the
+`touchscreen-end' event arrives; return `no-drag' returned if the
+touch point in EVENT did not move significantly, and t otherwise.
+
+(fn EVENT UPDATE &optional DATA)")
+(autoload 'touch-screen-inhibit-drag "touch-screen" "\
+Inhibit subsequent `touchscreen-drag' events from being sent.
+Prevent `touchscreen-drag' and translated mouse events from being
+sent until the touch sequence currently being translated ends.
+Must be called from a command bound to a `touchscreen-hold' or
+`touchscreen-drag' event.")
+(register-definition-prefixes "touch-screen" '("touch-screen-"))
+
+
;;; Generated autoloads from emacs-lisp/tq.el
(autoload 'tq-create "tq" "\
@@ -32782,6 +33258,11 @@ Add Tramp file name handlers to `file-name-handler-alist' during autoload." (unl
(tramp-register-autoload-file-name-handlers)
(defun tramp-unload-file-name-handlers nil "\
Unload Tramp file name handlers from `file-name-handler-alist'." (dolist (fnh file-name-handler-alist) (when (and (symbolp (cdr fnh)) (string-prefix-p "tramp-" (symbol-name (cdr fnh)))) (setq file-name-handler-alist (delq fnh file-name-handler-alist)))))
+(defun inhibit-remote-files nil "\
+Deactivate remote file names." (interactive) (when (fboundp 'tramp-cleanup-all-connections) (funcall 'tramp-cleanup-all-connections)) (tramp-unload-file-name-handlers) (setq tramp-mode nil))
+(defmacro without-remote-files (&rest body) "\
+Deactivate remote file names temporarily.
+Run BODY." (declare (indent 0) (debug ((form body) body))) `(let ((file-name-handler-alist (copy-tree file-name-handler-alist)) tramp-mode) (tramp-unload-file-name-handlers) ,@body))
(defun tramp-unload-tramp nil "\
Discard Tramp from loading remote files." (interactive) (ignore-errors (unload-feature 'tramp 'force)))
(register-definition-prefixes "tramp" '("tramp-" "with-"))
@@ -32803,7 +33284,7 @@ It must be supported by libarchive(3).")
List of suffixes which indicate a compressed file.
It must be supported by libarchive(3).")
(defmacro tramp-archive-autoload-file-name-regexp nil "\
-Regular expression matching archive file names." (if (<= emacs-major-version 26) '(concat "\\`" "\\(" ".+" "\\." (regexp-opt tramp-archive-suffixes) "\\(?:" "\\." (regexp-opt tramp-archive-compression-suffixes) "\\)*" "\\)" "\\(" "/" ".*" "\\)" "\\'") `(rx bos (group (+ nonl) "." (| ,@tramp-archive-suffixes) (32 "." (| ,@tramp-archive-compression-suffixes))) (group "/" (* nonl)) eos)))
+Regular expression matching archive file names." `(rx bos (group (+ nonl) "." (| ,@tramp-archive-suffixes) (32 "." (| ,@tramp-archive-compression-suffixes))) (group "/" (* nonl)) eos))
(defun tramp-archive-autoload-file-name-handler (operation &rest 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-autoload-file-name-handler nil "\
@@ -32825,7 +33306,6 @@ Add archive file name handler to `file-name-handler-alist'." (when (and tramp-ar
;;; Generated autoloads from net/tramp-compat.el
- (defalias 'tramp-compat-rx #'rx)
(register-definition-prefixes "tramp-compat" '("tramp-"))
@@ -32859,6 +33339,11 @@ Add archive file name handler to `file-name-handler-alist'." (when (and tramp-ar
(register-definition-prefixes "tramp-integration" '("tramp-"))
+;;; Generated autoloads from net/tramp-message.el
+
+(register-definition-prefixes "tramp-message" '("tramp-" "with-tramp-debug-message"))
+
+
;;; Generated autoloads from net/tramp-rclone.el
(register-definition-prefixes "tramp-rclone" '("tramp-rclone-"))
@@ -32891,54 +33376,13 @@ Add archive file name handler to `file-name-handler-alist'." (when (and tramp-ar
;;; Generated autoloads from net/trampver.el
-(push (purecopy '(tramp 2 6 3 -1)) package--builtin-versions)
+(push (purecopy '(tramp 2 7 1 -1)) package--builtin-versions)
(register-definition-prefixes "trampver" '("tramp-"))
;;; Generated autoloads from transient.el
-(autoload 'transient-define-prefix "transient" "\
-Define NAME as a transient prefix command.
-
-ARGLIST are the arguments that command takes.
-DOCSTRING is the documentation string and is optional.
-
-These arguments can optionally be followed by key-value pairs.
-Each key has to be a keyword symbol, either `:class' or a keyword
-argument supported by the constructor of that class. The
-`transient-prefix' class is used if the class is not specified
-explicitly.
-
-GROUPs add key bindings for infix and suffix commands and specify
-how these bindings are presented in the popup buffer. At least
-one GROUP has to be specified. See info node `(transient)Binding
-Suffix and Infix Commands'.
-
-The BODY is optional. If it is omitted, then ARGLIST is also
-ignored and the function definition becomes:
-
- (lambda ()
- (interactive)
- (transient-setup \\='NAME))
-
-If BODY is specified, then it must begin with an `interactive'
-form that matches ARGLIST, and it must call `transient-setup'.
-It may however call that function only when some condition is
-satisfied; that is one of the reason why you might want to use
-an explicit BODY.
-
-All transients have a (possibly nil) value, which is exported
-when suffix commands are called, so that they can consume that
-value. For some transients it might be necessary to have a sort
-of secondary value, called a scope. Such a scope would usually
-be set in the commands `interactive' form and has to be passed
-to the setup function:
-
- (transient-setup \\='NAME nil nil :scope SCOPE)
-
-(fn NAME ARGLIST [DOCSTRING] [KEYWORD VALUE]... GROUP... [BODY...])" nil t)
-(function-put 'transient-define-prefix 'lisp-indent-function 'defun)
-(function-put 'transient-define-prefix 'doc-string-elt 3)
+(push (purecopy '(transient 0 5 2)) package--builtin-versions)
(autoload 'transient-insert-suffix "transient" "\
Insert a SUFFIX into PREFIX before LOC.
PREFIX is a prefix command, a symbol.
@@ -32989,7 +33433,7 @@ See info node `(transient)Modifying Existing Transients'.
(fn PREFIX LOC)")
(function-put 'transient-remove-suffix 'lisp-indent-function 'defun)
-(register-definition-prefixes "transient" '("transient"))
+(register-definition-prefixes "transient" '("static-if" "transient"))
;;; Generated autoloads from tree-widget.el
@@ -33015,7 +33459,12 @@ recipe for LANG exists in `treesit-language-source-alist'.
See `exec-path' for the current path where Emacs looks for
executable programs, such as the C/C++ compiler and linker.
-(fn LANG)" t)
+Interactively, prompt for the directory in which to install the
+compiled grammar files. Non-interactively, use OUT-DIR; if it's
+nil, the grammar is installed to the standard location, the
+\"tree-sitter\" directory under `user-emacs-directory'.
+
+(fn LANG &optional OUT-DIR)" t)
(register-definition-prefixes "treesit" '("treesit-"))
@@ -33178,18 +33627,18 @@ 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.
+`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.
+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.
+The mode's hook is called both when the mode is enabled and when it is
+disabled.
(fn &optional ARG)" t)
(autoload 'type-break "type-break" "\
@@ -33538,6 +33987,7 @@ Handle file: and ftp: URLs.
Attempt to resolve the given HOST using nslookup if possible.
(fn HOST)" t)
+(make-obsolete 'url-gateway-nslookup-host 'nil "30.1")
(autoload 'url-open-stream "url-gw" "\
Open a stream to HOST, possibly via a gateway.
Args per `open-network-stream'.
@@ -33574,18 +34024,18 @@ 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.
+`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.
+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.
+The mode's hook is called both when the mode is enabled and when it is
+disabled.
(fn &optional ARG)" t)
(autoload 'url-file-handler "url-handlers" "\
@@ -33672,10 +34122,7 @@ URL can be a URL string, or a URL record of the type returned by
;;; Generated autoloads from url/url-mailto.el
-(autoload 'url-mail "url-mailto" "\
-
-
-(fn &rest ARGS)" t)
+(defalias 'url-mail #'message-mail)
(autoload 'url-mailto "url-mailto" "\
Handle the mailto: URL syntax.
@@ -34089,6 +34536,8 @@ Usage:
:custom-face Call `custom-set-faces' with each face definition.
:ensure Loads the package using package.el if necessary.
:pin Pin the package to an archive.
+:vc Install the package directly from a version control system
+ (using `package-vc.el').
(fn NAME &rest ARGS)" nil t)
(function-put 'use-package 'lisp-indent-function 'defun)
@@ -34644,7 +35093,7 @@ On a non-distributed version control system, this signals an error.
It also signals an error in a Bazaar bound branch.
(fn &optional ARG)" t)
-(autoload 'vc-switch-backend "vc" "\
+(autoload 'vc-change-backend "vc" "\
Make BACKEND the current version control system for FILE.
FILE must already be registered in BACKEND. The change is not
permanent, only for the current session. This function only changes
@@ -34653,7 +35102,6 @@ By default, this command cycles through the registered backends.
To get a prompt, use a prefix argument.
(fn FILE BACKEND)" t)
-(make-obsolete 'vc-switch-backend 'nil "28.1")
(autoload 'vc-transfer-file "vc" "\
Transfer FILE to another version control system NEW-BACKEND.
If NEW-BACKEND has a higher precedence than FILE's current backend
@@ -34706,10 +35154,10 @@ revision, with SUBJECT derived from each revision subject.
When invoked with a numerical prefix argument, use the last N
revisions.
When invoked interactively in a Log View buffer with
-marked revisions, use those these.
+marked revisions, use those.
(fn ADDRESSEE SUBJECT REVISIONS)" t)
-(register-definition-prefixes "vc" '("vc-" "with-vc-properties"))
+(register-definition-prefixes "vc" '("log-view-vc-prev-" "vc-" "with-vc-properties"))
;;; Generated autoloads from vc/vc-annotate.el
@@ -34850,6 +35298,25 @@ case, and the process object in the asynchronous case.
(progn
(load "vc-git" nil t)
(vc-git-registered file))))
+(autoload 'vc-git-grep "vc-git" "\
+Run git grep, searching for REGEXP in FILES in directory DIR.
+The search is limited to file names matching shell pattern FILES.
+FILES may use abbreviations defined in `grep-files-aliases', e.g.
+entering `ch' is equivalent to `*.[ch]'. As whitespace triggers
+completion when entering a pattern, including it requires
+quoting, e.g. `\\[quoted-insert]<space>'.
+
+With \\[universal-argument] prefix, you can edit the constructed shell command line
+before it is executed.
+With two \\[universal-argument] prefixes, directly edit and run `grep-command'.
+
+Collect output in a buffer. While git grep runs asynchronously, you
+can use \\[next-error] (`next-error'), or \\<grep-mode-map>\\[compile-goto-error] in the grep output buffer,
+to go to the lines where grep found matches.
+
+This command shares argument histories with \\[rgrep] and \\[grep].
+
+(fn REGEXP &optional FILES DIR)" t)
(register-definition-prefixes "vc-git" '("vc-"))
@@ -34975,7 +35442,7 @@ Key bindings:
;;; Generated autoloads from progmodes/verilog-mode.el
-(push (purecopy '(verilog-mode 2021 10 14 127365406)) package--builtin-versions)
+(push (purecopy '(verilog-mode 2024 3 1 121933719)) package--builtin-versions)
(autoload 'verilog-mode "verilog-mode" "\
Major mode for editing Verilog code.
\\<verilog-mode-map>
@@ -35009,6 +35476,11 @@ Variables controlling indentation/edit style:
function keyword.
`verilog-indent-level-directive' (default 1)
Indentation of \\=`ifdef/\\=`endif blocks.
+ `verilog-indent-ignore-multiline-defines' (default t)
+ Non-nil means ignore indentation on lines that are part of a multiline
+ define.
+ `verilog-indent-ignore-regexp' (default nil
+ Regexp that matches lines that should be ignored for indentation.
`verilog-cexp-indent' (default 1)
Indentation of Verilog statements broken across lines i.e.:
if (a)
@@ -35032,6 +35504,9 @@ Variables controlling indentation/edit style:
otherwise you get:
if (a)
begin
+ `verilog-indent-class-inside-pkg' (default t)
+ Non-nil means indent classes inside packages.
+ Otherwise, classes have zero indentation.
`verilog-auto-endcomments' (default t)
Non-nil means a comment /* ... */ is set after the ends which ends
cases, tasks, functions and modules.
@@ -35041,6 +35516,17 @@ Variables controlling indentation/edit style:
will be inserted. Setting this variable to zero results in every
end acquiring a comment; the default avoids too many redundant
comments in tight quarters.
+ `verilog-align-decl-expr-comments' (default t)
+ Non-nil means align declaration and expressions comments.
+ `verilog-align-comment-distance' (default 1)
+ Distance (in spaces) between longest declaration and comments.
+ Only works if `verilog-align-decl-expr-comments' is non-nil.
+ `verilog-align-assign-expr' (default nil)
+ Non-nil means align expressions of continuous assignments.
+ `verilog-align-typedef-regexp' (default nil)
+ Regexp that matches user typedefs for declaration alignment.
+ `verilog-align-typedef-words' (default nil)
+ List of words that match user typedefs for declaration alignment.
`verilog-auto-lineup' (default `declarations')
List of contexts where auto lineup of code should be done.
@@ -35064,17 +35550,20 @@ Some other functions are:
\\[verilog-mark-defun] Mark function.
\\[verilog-beg-of-defun] Move to beginning of current function.
\\[verilog-end-of-defun] Move to end of current function.
- \\[verilog-label-be] Label matching begin ... end, fork ... join, etc statements.
+ \\[verilog-label-be] Label matching begin ... end, fork ... join, etc
+ statements.
\\[verilog-comment-region] Put marked area in a comment.
- \\[verilog-uncomment-region] Uncomment an area commented with \\[verilog-comment-region].
+ \\[verilog-uncomment-region] Uncomment an area commented with
+ \\[verilog-comment-region].
\\[verilog-insert-block] Insert begin ... end.
\\[verilog-star-comment] Insert /* ... */.
\\[verilog-sk-always] Insert an always @(AS) begin .. end block.
\\[verilog-sk-begin] Insert a begin .. end block.
\\[verilog-sk-case] Insert a case block, prompting for details.
- \\[verilog-sk-for] Insert a for (...) begin .. end block, prompting for details.
+ \\[verilog-sk-for] Insert a for (...) begin .. end block, prompting for
+ details.
\\[verilog-sk-generate] Insert a generate .. endgenerate block.
\\[verilog-sk-header] Insert a header block at the top of file.
\\[verilog-sk-initial] Insert an initial begin .. end block.
@@ -35097,14 +35586,17 @@ Some other functions are:
\\[verilog-sk-else-if] Insert an else if (..) begin .. end block.
\\[verilog-sk-comment] Insert a comment block.
\\[verilog-sk-assign] Insert an assign .. = ..; statement.
- \\[verilog-sk-function] Insert a function .. begin .. end endfunction block.
+ \\[verilog-sk-function] Insert a function .. begin .. end endfunction
+ block.
\\[verilog-sk-input] Insert an input declaration, prompting for details.
\\[verilog-sk-output] Insert an output declaration, prompting for details.
- \\[verilog-sk-state-machine] Insert a state machine definition, prompting for details.
+ \\[verilog-sk-state-machine] Insert a state machine definition, prompting
+ for details.
\\[verilog-sk-inout] Insert an inout declaration, prompting for details.
\\[verilog-sk-wire] Insert a wire declaration, prompting for details.
\\[verilog-sk-reg] Insert a register declaration, prompting for details.
- \\[verilog-sk-define-signal] Define signal under point as a register at the top of the module.
+ \\[verilog-sk-define-signal] Define signal under point as a register at
+ the top of the module.
All key bindings can be seen in a Verilog-buffer with \\[describe-bindings].
Key bindings specific to `verilog-mode-map' are:
@@ -35225,7 +35717,7 @@ Usage:
according to option `vhdl-argument-list-indent'.
If option `vhdl-indent-tabs-mode' is nil, spaces are used instead of
- tabs. `\\[tabify]' and `\\[untabify]' allow the conversion of spaces to
+ tabs. \\[tabify] and \\[untabify] allow the conversion of spaces to
tabs and vice versa.
Syntax-based indentation can be very slow in large files. Option
@@ -35536,7 +36028,7 @@ Usage:
`vhdl-highlight-translate-off' is non-nil.
For documentation and customization of the used colors see
- customization group `vhdl-highlight-faces' (`\\[customize-group]'). For
+ customization group `vhdl-highlight-faces' (\\[customize-group]). For
highlighting of matching parenthesis, see customization group
`paren-showing'. Automatic buffer highlighting is turned on/off by
option `global-font-lock-mode' (`font-lock-auto-fontify' in XEmacs).
@@ -35596,14 +36088,14 @@ Usage:
sessions using the \"Save Options\" menu entry.
Options and their detailed descriptions can also be accessed by using
- the \"Customize\" menu entry or the command `\\[customize-option]'
- (`\\[customize-group]' for groups). Some customizations only take effect
+ the \"Customize\" menu entry or the command \\[customize-option]
+ (\\[customize-group] for groups). Some customizations only take effect
after some action (read the NOTE in the option documentation).
Customization can also be done globally (i.e. site-wide, read the
INSTALL file).
Not all options are described in this documentation, so go and see
- what other useful user options there are (`\\[vhdl-customize]' or menu)!
+ what other useful user options there are (\\[vhdl-customize] or menu)!
FILE EXTENSIONS:
@@ -35632,7 +36124,7 @@ Usage:
Maintenance:
------------
-To submit a bug report, enter `\\[vhdl-submit-bug-report]' within VHDL Mode.
+To submit a bug report, enter \\[vhdl-submit-bug-report] within VHDL Mode.
Add a description of the problem and include a reproducible test case.
Questions and enhancement requests can be sent to <reto@gnu.org>.
@@ -35897,19 +36389,19 @@ 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.
+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.
+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.
+The mode's hook is called both when the mode is enabled and when it is
+disabled.
(fn &optional ARG)" t)
(autoload 'view-mode-enter "view" "\
@@ -35984,6 +36476,57 @@ Turn on Viper emulation of Vi in Emacs. See Info node `(viper)Top'." t)
(register-definition-prefixes "quail/viqr" '("viet-quail-define-rules"))
+;;; Generated autoloads from visual-wrap.el
+
+(autoload 'visual-wrap-prefix-mode "visual-wrap" "\
+Display continuation lines with prefixes from surrounding context.
+
+To enable this minor mode across all buffers, enable
+`global-visual-wrap-prefix-mode'.
+
+This is a minor mode. If called interactively, toggle the
+`Visual-Wrap-Prefix 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 `visual-wrap-prefix-mode'.
+
+The mode's hook is called both when the mode is enabled and when it is
+disabled.
+
+(fn &optional ARG)" t)
+(put 'global-visual-wrap-prefix-mode 'globalized-minor-mode t)
+(defvar global-visual-wrap-prefix-mode nil "\
+Non-nil if Global Visual-Wrap-Prefix mode is enabled.
+See the `global-visual-wrap-prefix-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-visual-wrap-prefix-mode'.")
+(custom-autoload 'global-visual-wrap-prefix-mode "visual-wrap" nil)
+(autoload 'global-visual-wrap-prefix-mode "visual-wrap" "\
+Toggle Visual-Wrap-Prefix mode in all buffers.
+With prefix ARG, enable Global Visual-Wrap-Prefix 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.
+
+Visual-Wrap-Prefix mode is enabled in all buffers where
+`visual-wrap-prefix-mode' would do it.
+
+See `visual-wrap-prefix-mode' for more information on
+Visual-Wrap-Prefix mode.
+
+(fn &optional ARG)" t)
+(register-definition-prefixes "visual-wrap" '("visual-wrap-"))
+
+
;;; Generated autoloads from emacs-lisp/vtable.el
(register-definition-prefixes "vtable" '("vtable"))
@@ -36019,6 +36562,18 @@ so the value of `wallpaper-commands' is ignored.
;;; Generated autoloads from emacs-lisp/warnings.el
+(defvar warning-suppress-types nil "\
+List of warning types not to display immediately.
+If any element of this list matches the TYPE argument to `display-warning',
+the warning is logged nonetheless, but the warnings buffer is
+not immediately displayed.
+The element must match an initial segment of the list TYPE.
+Thus, (foo bar) as an element matches (foo bar)
+or (foo bar ANYTHING...) as TYPE.
+If TYPE is a symbol FOO, that is equivalent to the list (FOO),
+so only the element (FOO) will match it.
+See also `warning-suppress-log-types'.")
+(custom-autoload 'warning-suppress-types "warnings" t)
(defvar warning-prefix-function nil "\
Function to generate warning prefixes.
This function, if non-nil, is called with two arguments,
@@ -36153,18 +36708,18 @@ 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.
+`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.
+The mode's hook is called both when the mode is enabled and when it is
+disabled.
(fn &optional ARG)" t)
(register-definition-prefixes "which-func" '("which-func"))
@@ -36182,19 +36737,19 @@ See also `whitespace-style', `whitespace-newline' and
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.
+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.
+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.
+The mode's hook is called both when the mode is enabled and when it is
+disabled.
(fn &optional ARG)" t)
(autoload 'whitespace-newline-mode "whitespace" "\
@@ -36208,21 +36763,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.
+`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.
+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.
+The mode's hook is called both when the mode is enabled and when it is
+disabled.
(fn &optional ARG)" t)
+(put 'global-whitespace-mode 'globalized-minor-mode t)
(defvar global-whitespace-mode nil "\
Non-nil if Global Whitespace mode is enabled.
See the `global-whitespace-mode' command
@@ -36232,25 +36787,18 @@ either customize it (see the info node `Easy Customization')
or call the function `global-whitespace-mode'.")
(custom-autoload 'global-whitespace-mode "whitespace" nil)
(autoload 'global-whitespace-mode "whitespace" "\
-Toggle whitespace visualization globally (Global Whitespace mode).
-
-See also `whitespace-style', `whitespace-newline' and
-`whitespace-display-mappings'.
-
-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.
+Toggle Whitespace mode in all buffers.
+With prefix ARG, enable Global 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.
+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)'.
+Whitespace mode is enabled in all buffers where
+`whitespace-turn-on-if-enabled' would do it.
-The mode's hook is called both when the mode is enabled and when
-it is disabled.
+See `whitespace-mode' for more information on Whitespace mode.
(fn &optional ARG)" t)
(defvar global-whitespace-newline-mode nil "\
@@ -36273,18 +36821,18 @@ 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.
+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-whitespace-newline-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)
(autoload 'whitespace-toggle-options "whitespace" "\
@@ -36588,19 +37136,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)
(register-definition-prefixes "wid-browse" '("widget-"))
@@ -36635,7 +37183,7 @@ The optional ARGS are additional keyword arguments.
Call `insert' with ARGS even if surrounding text is read only.
(fn &rest ARGS)")
-(defvar widget-keymap (let ((map (make-sparse-keymap))) (define-key map "\11" 'widget-forward) (define-key map "\33\11" 'widget-backward) (define-key map [(shift tab)] 'widget-backward) (put 'widget-backward :advertised-binding [(shift tab)]) (define-key map [backtab] 'widget-backward) (define-key map [down-mouse-2] 'widget-button-click) (define-key map [down-mouse-1] 'widget-button-click) (define-key map [(control 109)] 'widget-button-press) map) "\
+(defvar widget-keymap (let ((map (make-sparse-keymap))) (define-key map "\11" 'widget-forward) (define-key map "\33\11" 'widget-backward) (define-key map [(shift tab)] 'widget-backward) (put 'widget-backward :advertised-binding [(shift tab)]) (define-key map [backtab] 'widget-backward) (define-key map [down-mouse-2] 'widget-button-click) (define-key map [down-mouse-1] 'widget-button-click) (define-key map [touchscreen-begin] 'widget-button-click) (define-key map [(control 109)] 'widget-button-press) map) "\
Keymap containing useful binding for buffers containing widgets.
Recommended as a parent keymap for modes using widgets.
Note that such modes will need to require wid-edit.")
@@ -36695,18 +37243,18 @@ for a description of this minor mode.")
Global minor mode for default windmove commands.
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.
+`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)
(autoload 'windmove-default-keybindings "windmove" "\
@@ -36842,18 +37390,18 @@ sequence \\`C-c <left>'. If you change your mind (while undoing),
you can press \\`C-c <right>' (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.
+`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.
+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.
+The mode's hook is called both when the mode is enabled and when it is
+disabled.
(fn &optional ARG)" t)
(register-definition-prefixes "winner" '("winner-"))
@@ -36921,19 +37469,18 @@ 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.
+`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.
+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.
+The mode's hook is called both when the mode is enabled and when it is
+disabled.
(fn &optional ARG)" t)
(put 'global-word-wrap-whitespace-mode 'globalized-minor-mode t)
@@ -37184,18 +37731,18 @@ 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.
+`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.
+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.
+The mode's hook is called both when the mode is enabled and when it is
+disabled.
(fn &optional ARG)" t)
(register-definition-prefixes "xt-mouse" '("turn-o" "xt-mouse-epoch" "xterm-mouse-"))
@@ -37277,6 +37824,12 @@ run a specific program. The program must be a member of
(fn &optional PGM)" t)
(register-definition-prefixes "zone" '("zone-"))
+
+
+;;; Generated autoloads from net/tramp-androidsu.el
+
+(register-definition-prefixes "tramp-androidsu" '("tramp-androidsu-"))
+
;;; End of scraped data
@@ -37285,8 +37838,8 @@ run a specific program. The program must be a member of
;; Local Variables:
;; version-control: never
;; no-update-autoloads: t
-;; no-byte-compile: t
;; no-native-compile: t
+;; no-byte-compile: t
;; coding: utf-8-emacs-unix
;; End:
diff --git a/lisp/leim/quail/hangul.el b/lisp/leim/quail/hangul.el
index c614229f7ac..79526fa5aa8 100644
--- a/lisp/leim/quail/hangul.el
+++ b/lisp/leim/quail/hangul.el
@@ -146,21 +146,34 @@ Setup `quail-overlay' to the last character."
(progn
(delete-region (region-beginning) (region-end))
(deactivate-mark)))
- (quail-delete-region)
- (let ((first (car queues)))
- (insert
- (hangul-character
- (+ (aref first 0) (hangul-djamo 'cho (aref first 0) (aref first 1)))
- (+ (aref first 2) (hangul-djamo 'jung (aref first 2) (aref first 3)))
- (+ (aref first 4) (hangul-djamo 'jong (aref first 4) (aref first 5))))))
- (move-overlay quail-overlay (overlay-start quail-overlay) (point))
- (dolist (queue (cdr queues))
- (insert
- (hangul-character
- (+ (aref queue 0) (hangul-djamo 'cho (aref queue 0) (aref queue 1)))
- (+ (aref queue 2) (hangul-djamo 'jung (aref queue 2) (aref queue 3)))
- (+ (aref queue 4) (hangul-djamo 'jong (aref queue 4) (aref queue 5)))))
- (move-overlay quail-overlay (1+ (overlay-start quail-overlay)) (point))))
+ (let* ((chars-to-insert
+ (with-temp-buffer
+ (dolist (queue queues (mapcar #'identity (buffer-string)))
+ (insert
+ (hangul-character
+ (+ (aref queue 0) (hangul-djamo 'cho (aref queue 0) (aref queue 1)))
+ (+ (aref queue 2) (hangul-djamo 'jung (aref queue 2) (aref queue 3)))
+ (+ (aref queue 4) (hangul-djamo 'jong (aref queue 4) (aref queue 5))))))))
+ (overwrite-maybe
+ (or
+ ;; If the overlay isn't showing (i.e. it has 0 length) then
+ ;; we may want to insert char overwriting (iff overwrite-mode is
+ ;; non-nil, of course)
+ (= (overlay-start quail-overlay) (overlay-end quail-overlay))
+ ;; Likewise we want to do it if there is more then one
+ ;; character that were combined.
+ (cdr chars-to-insert))))
+ (quail-delete-region) ; this empties the overlay
+ (dolist (c chars-to-insert)
+ (let ((last-command-event c)
+ (overwrite-mode (and overwrite-mode
+ overwrite-maybe
+ overwrite-mode)))
+ (self-insert-command 1)
+ ;; For chars other than fhe first, no more overwrites desired
+ (setq overwrite-maybe nil)))
+ ; this shows the overlay again (TODO: do we really always revive?)
+ (move-overlay quail-overlay (1- (point)) (point))))
(defun hangul-djamo (jamo char1 char2)
"Return the double Jamo index calculated from the arguments.
diff --git a/lisp/leim/quail/indian.el b/lisp/leim/quail/indian.el
index d2be7f40bb0..9ea23ec087c 100644
--- a/lisp/leim/quail/indian.el
+++ b/lisp/leim/quail/indian.el
@@ -154,8 +154,8 @@ strings that describe how to insert CONSONANT."
(setq consonants
(sort consonants
(lambda (x y)
- (or (seq-position (car x) quail-tamil-itrans--consonant-order) 1000)
- (or (seq-position (car y) quail-tamil-itrans--consonant-order) 1000))))
+ (< (or (seq-position quail-tamil-itrans--consonant-order (car x)) 1000)
+ (or (seq-position quail-tamil-itrans--consonant-order (car y)) 1000)))))
(let ((virama #x0BCD)
clm)
(with-temp-buffer
@@ -476,7 +476,7 @@ Full key sequences are listed below:"
(defgroup tamil-input nil
"Translation rules for the Tamil input method."
:prefix "tamil-"
- :group 'leim)
+ :group 'quail)
(defcustom tamil-translation-rules
;; Vowels.
diff --git a/lisp/leim/quail/latin-ltx.el b/lisp/leim/quail/latin-ltx.el
index ca3163b09b7..54c3121873e 100644
--- a/lisp/leim/quail/latin-ltx.el
+++ b/lisp/leim/quail/latin-ltx.el
@@ -244,7 +244,8 @@ system, including many technical ones. Examples:
;; (which is \varphi) are reversed in `ucs-names', so we define
;; them manually. Also ignore "GREEK SMALL LETTER EPSILON" and
;; add the correct value for \epsilon manually.
- (unless (string-match-p "\\<\\(?:PHI\\|GREEK SMALL LETTER EPSILON\\)\\>" name)
+ (unless (string-match-p "\\<GREEK SMALL LETTER \\(?:EPSILON\\|PHI\\)\\>"
+ name)
(concat "\\" (funcall (if (match-end 1) #' capitalize #'downcase)
(match-string 2 name)))))
"\\`GREEK \\(?:SMALL\\|CAPITA\\(L\\)\\) LETTER \\([^- ]+\\)\\'")
diff --git a/lisp/leim/quail/latin-post.el b/lisp/leim/quail/latin-post.el
index 0d2c1888426..25e7c4a64a8 100644
--- a/lisp/leim/quail/latin-post.el
+++ b/lisp/leim/quail/latin-post.el
@@ -1616,6 +1616,7 @@ Doubling the postfix separates the letter and postfix: e.g. a^^ -> a^
;; Italian (itln)
;; Spanish (spnsh)
;; Dvorak (dvorak)
+;; Colemak (colemak)
;;
;;; 92.12.15 created for Mule Ver.0.9.6 by Takahashi N. <ntakahas@etl.go.jp>
;;; 92.12.29 modified by Takahashi N. <ntakahas@etl.go.jp>
@@ -2224,6 +2225,55 @@ Dead accent is right to æ." nil t t t t nil nil nil nil nil t)
("?" ?Z)
)
+;;
+(quail-define-package
+ "english-colemak" "English" "CM@" t
+ "English (ASCII) input method simulating Colemak keyboard"
+ nil t t t t nil nil nil nil nil t)
+
+;; 1! 2@ 3# 4$ 5% 6^ 7& 8* 9( 0) -_ =+ `~
+;; qQ wW fF pP gG jJ lL uU yY ;: [{ ]}
+;; aA rR sS tT dD hH nN eE iI oO '" \|
+;; zZ xX cC vV bB kK mM ,< .> /?
+
+(quail-define-rules
+ ("e" ?f)
+ ("r" ?p)
+ ("t" ?g)
+ ("y" ?j)
+ ("u" ?l)
+ ("i" ?u)
+ ("o" ?y)
+ ("p" ?\;)
+ ("s" ?r)
+ ("d" ?s)
+ ("f" ?t)
+ ("g" ?d)
+ ("j" ?n)
+ ("k" ?e)
+ ("l" ?i)
+ (";" ?o)
+ ("n" ?k)
+
+ ("E" ?F)
+ ("R" ?P)
+ ("T" ?G)
+ ("Y" ?J)
+ ("U" ?L)
+ ("I" ?U)
+ ("O" ?Y)
+ ("P" ?\:)
+ ("S" ?R)
+ ("D" ?S)
+ ("F" ?T)
+ ("G" ?D)
+ ("J" ?N)
+ ("K" ?E)
+ ("L" ?I)
+ (":" ?O)
+ ("N" ?K)
+ )
+
(quail-define-package
"latin-postfix" "Latin" "L<" t
"Latin character input method with postfix modifiers.
diff --git a/lisp/leim/quail/latin-pre.el b/lisp/leim/quail/latin-pre.el
index f1b318c90a7..91164df0c72 100644
--- a/lisp/leim/quail/latin-pre.el
+++ b/lisp/leim/quail/latin-pre.el
@@ -789,9 +789,9 @@ and Silesian (both Steuer and Ślabikŏrzowy szrajbōnek) scripts."
("'Z" ?Ź)
(".z" ?ż)
(".Z" ?Ż)
- ;; Explicit input of prefix characters. Normally, to input a prefix
- ;; character itself, one needs to press <Tab>. Definitions below
- ;; allow to input those characters by entering them twice.
+ ;; Explicit input of prefix characters. Normally, to input a prefix
+ ;; character itself, one needs to press <Tab>. Definitions below
+ ;; allow inputting those characters by entering them twice.
("//" ?/)
("\\\\" ?\\)
("~~" ?~)
diff --git a/lisp/leim/quail/pakistan.el b/lisp/leim/quail/pakistan.el
new file mode 100644
index 00000000000..7cde2fde3aa
--- /dev/null
+++ b/lisp/leim/quail/pakistan.el
@@ -0,0 +1,726 @@
+;;; pakistan.el --- Input methods for some languages from Pakistan -*- lexical-binding: t; -*-
+;;
+;; Copyright (C) 2023-2024 Free Software Foundation, Inc.
+
+;; Author: Rahguzar <rahguzar@zohomail.eu>
+;; Keywords: convenience, multilingual, input method, Urdu, Balochi, Pashto, Sindhi, Hindko, Brahui
+;;
+;; This file is part of GNU Emacs.
+
+;; GNU Emacs is free software: you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+
+;; GNU Emacs is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>.
+;;
+;;; Commentary:
+;; Provides a semi-phonetic input method for Urdu
+;;
+;;; Code:
+(require 'quail)
+
+;;;; Urdu Input Methods
+;;;;; Keyboard
+;; Layout taken from https://www.branah.com/urdu
+(quail-define-package
+ "urdu-keyboard" "Urdu" "ات" t
+ "Input method for Urdu.
+Uses keyboard layout from https://www.branah.com/urdu"
+ nil t t t t nil nil nil nil nil t)
+
+(quail-define-rules
+ ("q" ?ط)
+ ("w" ?ص)
+ ("e" ?ھ)
+ ("r" ?د)
+ ("t" ?ٹ)
+ ("y" ?پ)
+ ("u" ?ت)
+ ("i" ?ب)
+ ("o" ?ج)
+ ("p" ?ح)
+ ("a" ?م)
+ ("s" ?و)
+ ("d" ?ر)
+ ("f" ?ن)
+ ("g" ?ل)
+ ("h" ?ہ)
+ ("j" ?ا)
+ ("k" ?ک)
+ ("l" ?ی)
+ ("z" ?ق)
+ ("x" ?ف)
+ ("c" ?ے)
+ ("v" ?س)
+ ("b" ?ش)
+ ("n" ?غ)
+ ("m" ?ع)
+ ("Q" ?ظ)
+ ("W" ?ض)
+ ("E" ?ذ)
+ ("R" ?ڈ)
+ ("T" ?ث)
+ ("Y" ?ّ)
+ ("U" ?ۃ)
+ ("I" ?ـ)
+ ("O" ?چ)
+ ("P" ?خ)
+ ("A" ?ژ)
+ ("S" ?ز)
+ ("D" ?ڑ)
+ ("F" ?ں)
+ ("G" ?ۂ)
+ ("H" ?ء)
+ ("J" ?آ)
+ ("K" ?گ)
+ ("L" ?ي)
+ ("C" ?ۓ)
+ ("B" ?ؤ)
+ ("N" ?ئ)
+ ("[" ?\])
+ ("]" ?\[)
+ ("{" ?})
+ ("}" ?{)
+ (";" ?؛)
+ ("." ?۔)
+ ("," ?،)
+ ("?" ?؟))
+
+;;;;; Phonetic Keyboard
+(quail-define-package
+ "urdu-phonetic-keyboard" "Urdu" "اص" t
+ "Input method for Urdu.
+Uses phonetic keyboard layout from https://www.branah.com/urdu"
+ nil t t t t nil nil nil nil nil t)
+
+(quail-define-rules
+ ("q" ?ق)
+ ("w" ?و)
+ ("e" ?ع)
+ ("r" ?ر)
+ ("t" ?ت)
+ ("y" ?ے)
+ ("u" ?ء)
+ ("i" ?ی)
+ ("o" ?ہ)
+ ("p" ?پ)
+ ("a" ?ا)
+ ("s" ?س)
+ ("d" ?د)
+ ("f" ?ف)
+ ("g" ?گ)
+ ("h" ?ح)
+ ("j" ?ج)
+ ("k" ?ک)
+ ("l" ?ل)
+ ("z" ?ز)
+ ("x" ?ش)
+ ("c" ?چ)
+ ("v" ?ط)
+ ("b" ?ب)
+ ("n" ?ن)
+ ("m" ?م)
+ ("Q" ?ْ)
+ ("W" ?ٔ)
+ ("E" ?ٰ)
+ ("R" ?ڑ)
+ ("T" ?ٹ)
+ ("Y" ?َ)
+ ("U" ?ئ)
+ ("I" ?ِ)
+ ("O" ?ۃ)
+ ("P" ?ُ)
+ ("A" ?آ)
+ ("S" ?ص)
+ ("D" ?ڈ)
+ ("F" ?أ)
+ ("G" ?غ)
+ ("H" ?ھ)
+ ("J" ?ض)
+ ("K" ?خ)
+ ("L" ?ٖ)
+ ("Z" ?ذ)
+ ("X" ?ژ)
+ ("C" ?ث)
+ ("V" ?ظ)
+ ("B" ?ً)
+ ("N" ?ں)
+ ("M" ?ّ)
+ ("1" ?۱)
+ ("2" ?۲)
+ ("3" ?۳)
+ ("4" ?۴)
+ ("5" ?۵)
+ ("6" ?٦)
+ ("7" ?۷)
+ ("8" ?۸)
+ ("9" ?۹)
+ ("0" ?۰)
+ ("`" ?؏)
+ ("#" ?ؔ)
+ ("$" ?ؒ)
+ ("%" ?٪)
+ ("^" ?ؓ)
+ ("&" ?ؑ)
+ ("*" ?ؐ)
+ ("(" ?\))
+ (")" ?\()
+ ("=" ?+)
+ (";" ?؛)
+ ("\\" ?÷)
+ ("|" ?x)
+ ("," ?،)
+ ("." ?۔)
+ ("<" ?ٗ)
+ (">" ?.)
+ ("?" ?؟)
+ ("[" ?﷽)
+ ("]" ?ﷲ)
+ ("{" ?ﷺ))
+
+;;;;; Customizable Input Method
+;;;;;; Variable declarations
+;; We define these variables now so that byte-compiler does not complain.
+;; Later they will be changed to custom variables. Their value must be void
+;; here as otherwise cutsom will not initialize them to their standard value.
+(defvar pakistan-urdu-prefixes)
+(defvar pakistan-urdu-translations)
+(defvar pakistan-urdu-diacritics-and-other-symbols)
+(defvar pakistan-urdu-poetic-symbols)
+(defvar pakistan-urdu-religious-symbols)
+(defvar pakistan-urdu-use-roman-digits)
+(defvar pakistan-extra-balochi-brahui-translations)
+(defvar pakistan-extra-pashto-translations)
+(defvar pakistan-extra-saraiki-hindko-translations)
+(defvar pakistan-extra-sindhi-translations)
+
+;;;;;; Helper functions
+(defun pakistan--define-quail-rules (rules &optional prefix package)
+ "Define translations for `urdu-custom' input method as determined by RULES.
+PACKAGE determines the input method and defaults to `urdu-custom'. RULES is
+the list of rules to define, see `quail-defrule' for details. If non-nil
+PREFIX is a string that is prefixed to each string in RULES. PREFIX can be a
+symbol in which case it is looked up in `pakistan-urdu-prefixes' to obtain the
+string."
+ (setq package (or package "urdu-custom"))
+ (when (and prefix (symbolp prefix))
+ (setq prefix (car (alist-get prefix pakistan-urdu-prefixes))))
+ (dolist (rule rules)
+ (quail-defrule (concat prefix (car rule)) (cadr rule) package)))
+
+(defun pakistan--define-numeral-translations (&optional package)
+ "Define translations to translate digits to arabic digits.
+Translations are for PACKAGE which defaults to `urdu-custom'."
+ (pakistan--define-quail-rules
+ '(("0" ?۰)
+ ("1" ?۱)
+ ("2" ?۲)
+ ("3" ?۳)
+ ("4" ?۴)
+ ("5" ?۵)
+ ("6" ?۶)
+ ("7" ?۷)
+ ("8" ?۸)
+ ("9" ?۹)
+ ("%" ?٪))
+ nil package))
+
+(defun pakistan--set-numeral-translations (var val)
+ "VAR should be `pakistan-urdu-use-roman-digits' and VAL its value.
+This is a setter function for the custom-variable."
+ (set-default-toplevel-value var val)
+ (if val
+ (pakistan--regenerate-translations)
+ (pakistan--define-numeral-translations)))
+
+(defun pakistan--regenerate-translations ()
+ "Regenerate the translations for urdu-custom input method."
+ (quail-select-package "urdu-custom")
+ (quail-install-map (list nil))
+ (pakistan--define-quail-rules pakistan-urdu-translations)
+ (unless pakistan-urdu-use-roman-digits
+ (pakistan--define-numeral-translations))
+ (pakistan--define-quail-rules
+ pakistan-urdu-diacritics-and-other-symbols 'diacritics)
+ (pakistan--define-quail-rules pakistan-urdu-poetic-symbols 'poetic)
+ (pakistan--define-quail-rules pakistan-urdu-religious-symbols 'religious)
+ (pakistan--define-quail-rules
+ pakistan-extra-balochi-brahui-translations 'balochi-brahui)
+ (pakistan--define-quail-rules pakistan-extra-pashto-translations 'pashto)
+ (pakistan--define-quail-rules
+ pakistan-extra-saraiki-hindko-translations 'saraiki-hindko)
+ (pakistan--define-quail-rules pakistan-extra-sindhi-translations 'sindhi))
+
+(defun pakistan--set-prefixes (var val)
+ "VAR should be `pakistan-urdu-prefixes' and VAL is the value to be set.
+Setter function for `pakistan-urdu-prefixes'."
+ (set-default-toplevel-value var val)
+ (when (boundp 'pakistan-urdu-use-roman-digits)
+ (pakistan--regenerate-translations)))
+
+(defun pakistan--make-setter (&optional prefix)
+ "Return the setter function.
+The function adds rules to `urdu-custom' with PREFIX."
+ (lambda (var val)
+ (set-default-toplevel-value var val)
+ (if (boundp 'pakistan-urdu-use-roman-digits)
+ (pakistan--regenerate-translations)
+ (pakistan--define-quail-rules val prefix))))
+
+;;;;;; Package definition
+(quail-define-package
+ "urdu-custom" "Urdu" "اا" t
+ "Intuitive and customizable transl input method for Urdu.
+By default this input method doesn't try to follow the common romanization of
+Urdu very closely. The reason for this is allow to for input efficiency. It
+works as follows:
+
+1) All lower case letters on QWERTY keyboard are translated to an urdu
+character. When more than one Urdu letter corresponds to the same Roman
+letter, the most common Urdu letter has been chosen. The frequency analysis
+was done on the basis of Urdu word list at
+https://github.com/urduhack/urdu-words/blob/master/words.txt As a result some
+of the translations are:
+h → ہ
+s → س , c → ص
+z → ز
+
+2) For the next common letter the uppercase English letter is used, e.g.
+r → ر , R → ڑ
+n → ن , N → ں
+
+3) The letter x is used for postfix completions. There are two subcases:
+3a) When more than two urdu letter map to the same roman letter,
+e.g.
+t → ت, T → ٹ , tx → ط , Tx → ۃ
+h → ہ , H → ھ , hx → ح , Hx → ۂ
+s → س , c → ص , sx → ش , S → ث , cx → چ
+z → ز , Z → ض, zx → ذ , Zx → ظ
+3b) The urdu letters that are commonly romanized by a English letter + h
+can be obtained by the same English letter + x i.e.
+gx → غ , cx → چ, kx → خ , sx → ش
+
+4) Y → ژ is somewhat of an abberation. All four of z, Z, zx and Zx are
+used by more common letters. Y is used for ژ because it is sometimes
+pronounced close to Y for some European languages.
+
+These translations can be changed by customizing `pakistan-urdu-translations'.
+
+5) o is used for prefix completion of diacrtics or اعر۱ب as well as some
+poetic and religious symbols. The most common three diacritics are mapped to
+oa → zabr (a for above)
+ob → zer (b for below)
+oo → pesh (o for the circle in pesh)
+
+6) The poetic symbols are also available under G (for غزل), while religious
+symbols are also available under M (for مزہب).
+
+7) Characters from Balochi, Brahui Pashto, Saraiki and Sindhi which are not
+part of Urdu alphabet can also be input. Each set of these sets correspond to
+a different prefixes. See `pakistan-urdu-prefixes' for the prefixes.
+
+The translations and the prefixes described above can be customized. Various
+customization options can be found under the customization group
+`pakistan-urdu-input'."
+ nil t t t t nil nil nil nil nil t)
+
+;;;;;; Customizations
+(defgroup pakistan-urdu-input nil
+ "Customization group for Urdu input methods."
+ :group 'quail)
+
+(defcustom pakistan-urdu-prefixes
+ '((diacritics "o")
+ (poetic "G")
+ (religious "M")
+ (balochi-brahui "B")
+ (pashto "P")
+ (sindhi "C")
+ (saraiki-hindko "X"))
+ "Prefixes for `urdu-custom' input method."
+ :set #'pakistan--set-prefixes
+ :type '(repeat (list symbol string))
+ :version "30.1")
+
+(defcustom pakistan-urdu-translations
+ '(("a" ?ا)
+ ("y" ?ی)
+ ("r" ?ر)
+ ("n" ?ن)
+ ("v" ?و)
+ ("m" ?م)
+ ("t" ?ت)
+ ("l" ?ل)
+ ("k" ?ک)
+ ("b" ?ب)
+ ("d" ?د)
+ ("h" ?ہ)
+ ("s" ?س)
+ ("H" ?ھ)
+ ("p" ?پ)
+ ("N" ?ں)
+ ("g" ?گ)
+ ("sx" ?ش)
+ ("j" ?ج)
+ ("T" ?ٹ)
+ ("f" ?ف)
+ ("cx" ?چ)
+ ("z" ?ز)
+ ("u" ?ع)
+ ("q" ?ق)
+ ("kx" ?خ)
+ ("e" ?ے)
+ ("E" ?ۓ)
+ ("hx" ?ح)
+ ("i" ?ئ)
+ ("R" ?ڑ)
+ ("tx" ?ط)
+ ("c" ?ص)
+ ("D" ?ڈ)
+ ("gx" ?غ)
+ ("A" ?آ)
+ ("Z" ?ض)
+ ("V" ?ؤ)
+ ("zx" ?ذ)
+ ("S" ?ث)
+ ("Zx" ?ظ)
+ ("Hx" ?ۂ)
+ ("ix" ?ء)
+ ("Tx" ?ۃ)
+ ("Y" ?ژ)
+ ("ax" ?أ)
+ ("." ?۔)
+ ("," ?،)
+ (";" ?؛)
+ ("?" ?؟))
+ "Translations for Urdu characters and common punctuations."
+ :set (pakistan--make-setter)
+ :type '(repeat (list string character))
+ :version "30.1")
+
+(defcustom pakistan-urdu-diacritics-and-other-symbols
+ '(("a" ?َ) ;; zabar زبر
+ ("b" ?ِ) ;; zer زير
+ ("o" ?ُ) ;; pesh پيش
+ ("j" ?ْ) ;; jazam جزم
+ ("S" ?ّ) ;; tashdid تشدید
+ ("k" ?ٰ) ;; khari zabar کھڑی زبر
+ ("u" ?٘) ;; ulti jazm الٹی جزم
+ ("s" ?؎)
+ ("m" ?؏)
+ ("t" ?ؔ)
+ ("c" ?ؐ)
+ ("r" ?ؒ)
+ ("R" ?ؓ)
+ ("A" ?ؑ))
+ "Translations to input Urdu diacrtics.
+These are available under the prefix specified in `pakistan-urdu-prefixes'."
+ :set (pakistan--make-setter 'diacritics)
+ :type '(repeat (list string character))
+ :version "30.1")
+
+(defcustom pakistan-urdu-poetic-symbols
+ '(("s" ?؎)
+ ("m" ?؏)
+ ("t" ?ؔ))
+ "Translation to input Urdu peotic symbols.
+These are available under the prefix specified in `pakistan-urdu-prefixes'."
+ :set (pakistan--make-setter 'poetic)
+ :type '(repeat (list string character))
+ :version "30.1")
+
+(defcustom pakistan-urdu-religious-symbols
+ '(("s" ?ؐ)
+ ("r" ?ؒ)
+ ("R" ?ؓ)
+ ("a" ?ؑ)
+ ("A" ?ﷲ)
+ ("S" ?ﷺ))
+ "Translation to input Urdu peotic symbols.
+These are available under the prefix specified in `pakistan-urdu-prefixes'."
+ :set (pakistan--make-setter 'religious)
+ :type '(repeat (list string character))
+ :version "30.1")
+
+;; I don't understand how many of these letters are pronounced.
+;; So better translations are welcome.
+(defcustom pakistan-extra-balochi-brahui-translations
+ '(("v" ?ۏ)
+ ("y" ?ݔ)
+;; Brahui
+ ("l" ?ڷ))
+ "Translations to input Balochi and Brahui letters not found in Urdu.
+These are available under the prefix specified in `pakistan-urdu-prefixes'."
+ :set (pakistan--make-setter 'balochi-brahui)
+ :type '(repeat (list string character))
+ :version "30.1")
+
+(defcustom pakistan-extra-pashto-translations
+ '(("t" ?ټ)
+ ("d" ?ډ)
+ ("r" ?ړ)
+ ("n" ?ڼ)
+ ("s" ?ښ)
+ ("R" ?ږ)
+ ("h" ?څ)
+ ("H" ?ځ))
+ "Translations to input Pashto letters not found in Urdu.
+These are available under the prefix specified in `pakistan-urdu-prefixes'."
+ :set (pakistan--make-setter 'pashto)
+ :type '(repeat (list string character))
+ :version "30.1")
+
+(defcustom pakistan-extra-sindhi-translations
+ '(("k" ?ڪ)
+ ("j" ?ڄ)
+ ("t" ?ٺ)
+ ("T" ?ٽ)
+ ("tx" ?ٿ)
+ ("b" ?ٻ)
+ ("B" ?ڀ)
+ ("r" ?ڙ)
+ ("d" ?ڌ)
+ ("D" ?ڏ)
+ ("dx" ?ڊ)
+ ("Dx" ?ڍ)
+ ("h" ?ڃ)
+ ("c" ?ڇ)
+ ("p" ?ڦ)
+ ("n" ?ڻ)
+ ("g" ?ڳ)
+ ("G" ?ڱ))
+ "Translations to input Sindhi letters not found in Urdu.
+These are available under the prefix specified in `pakistan-urdu-prefixes'."
+ :set (pakistan--make-setter 'sindhi)
+ :type '(repeat (list string character))
+ :version "30.1")
+
+(defcustom pakistan-extra-saraiki-hindko-translations
+ '(("b" ?ٻ)
+ ("h" ?ڄ)
+ ("g" ?ڳ)
+ ("d" ?ݙ)
+ ("n" ?ݨ)
+;; Hindko
+ ("r" ?ݬ)
+ ("v" ?ڨ)
+ ("N" ?ݩ)
+ ("V" ?ٷ))
+"Translations to input Saraiki letters not found in Urdu.
+These are available under the prefix specified in `pakistan-urdu-prefixes'."
+ :set (pakistan--make-setter 'saraiki-hindko)
+ :type '(repeat (list string character))
+ :version "30.1")
+
+(defcustom pakistan-urdu-use-roman-digits
+ nil
+ "Whether urdu-custom input method should use roman digits."
+ :set #'pakistan--set-numeral-translations
+ :type 'boolean
+ :version "30.1")
+
+;;;; Sindhi Input Methods
+;;;;; Keyboard
+;; Layout taken from https://www.branah.com/sindhi
+(quail-define-package
+ "sindhi-keyboard" "Sindhi" "سِ" t
+ "Input method for Sindhi.
+Uses keyboard layout from https://www.branah.com/sindhi ."
+ nil t t t t nil nil nil nil nil t)
+
+(quail-define-rules
+ ("q" ?ق)
+ ("w" ?ص)
+ ("e" ?ي)
+ ("r" ?ر)
+ ("t" ?ت)
+ ("y" ?ٿ)
+ ("u" ?ع)
+ ("i" ?ڳ)
+ ("o" ?و)
+ ("p" ?پ)
+ ("a" ?ا)
+ ("s" ?س)
+ ("d" ?د)
+ ("f" ?ف)
+ ("g" ?گ)
+ ("h" ?ه)
+ ("j" ?ج)
+ ("k" ?ڪ)
+ ("l" ?ل)
+ ("z" ?ز)
+ ("x" ?خ)
+ ("c" ?ط)
+ ("v" ?ڀ)
+ ("b" ?ب)
+ ("n" ?ن)
+ ("m" ?م)
+ ("Q" ?َ)
+ ("W" ?ض)
+ ("E" ?ِ)
+ ("R" ?ڙ)
+ ("T" ?ٽ)
+ ("Y" ?ث)
+ ("U" ?غ)
+ ("I" ?ھ)
+ ("O" ?ُ)
+ ("P" ?ڦ)
+ ("A" ?آ)
+ ("S" ?ش)
+ ("D" ?ڊ)
+ ("F" ?ڦ)
+ ("G" ?ً)
+ ("H" ?ح)
+ ("J" ?ٍ)
+ ("K" ?ۡ)
+ ("L" ?:)
+ ("Z" ?ذ)
+ ("X" ?ّ)
+ ("C" ?ظ)
+ ("V" ?ء)
+ ("B" ?ٻ)
+ ("N" ?ڻ)
+ ("M" ?۾)
+ ("1" ?۱)
+ ("2" ?۲)
+ ("3" ?۳)
+ ("4" ?۴)
+ ("5" ?۵)
+ ("6" ?٦)
+ ("7" ?۷)
+ ("8" ?۸)
+ ("9" ?۹)
+ ("0" ?۰)
+ ("`" ?’)
+ ("-" ?ڏ)
+ ("=" ?ڌ)
+ ("~" ?‘)
+ ("@" ?ى)
+ ("#" ?ؔ)
+ ("$" ?ؒ)
+ ("%" ?٪)
+ ("^" ?ؓ)
+ ("&" ?۽)
+ ("*" ?ؤ)
+ ("(" ?\))
+ (")" ?\()
+ ("[" ?ڇ)
+ ("]" ?چ)
+ ("{" ?ڃ)
+ ("}" ?ڄ)
+ (";" ?ک)
+ ("'" ?ڱ)
+ ("\\" ?ڍ)
+ (":" ?؛)
+ ("|" ?ٺ)
+ ("," ?،)
+ ("/" ?ئ)
+ ("<" ?“)
+ (">" ?”)
+ ("?" ?؟))
+
+
+;;;; Pashto Input Methods
+;;;;; Keyboard
+(quail-define-package
+ "pashto-keyboard" "Pashto" "پ" t
+ "Input method for Pashto.
+Uses keyboard layout from https://www.branah.com/pashto ."
+ nil t t t t nil nil nil nil nil t)
+
+(quail-define-rules
+ ("q" ?ض)
+ ("w" ?ص)
+ ("e" ?ث)
+ ("r" ?ق)
+ ("t" ?ف)
+ ("y" ?غ)
+ ("u" ?ع)
+ ("i" ?ه)
+ ("o" ?خ)
+ ("p" ?ح)
+ ("a" ?ش)
+ ("s" ?س)
+ ("d" ?ی)
+ ("f" ?ب)
+ ("g" ?ل)
+ ("h" ?ا)
+ ("j" ?ت)
+ ("k" ?ن)
+ ("l" ?م)
+ ("z" ?ۍ)
+ ("x" ?ې)
+ ("c" ?ز)
+ ("v" ?ر)
+ ("b" ?ذ)
+ ("n" ?د)
+ ("m" ?ړ)
+ ("Q" ?ْ)
+ ("W" ?ٌ)
+ ("E" ?ٍ)
+ ("R" ?ً)
+ ("T" ?ُ)
+ ("Y" ?ِ)
+ ("U" ?َ)
+ ("I" ?ّ)
+ ("O" ?څ)
+ ("P" ?ځ)
+ ("A" ?ښ)
+ ("S" ?ﺉ)
+ ("D" ?ي)
+ ("F" ?پ)
+ ("G" ?أ)
+ ("H" ?آ)
+ ("J" ?ټ)
+ ("K" ?ڼ)
+ ("L" ?ة)
+ ("Z" ?ظ)
+ ("X" ?ط)
+ ("C" ?ژ)
+ ("V" ?ء)
+ ("B" ?‌)
+ ("N" ?ډ)
+ ("M" ?ؤ)
+ ("1" ?۱)
+ ("2" ?۲)
+ ("3" ?۳)
+ ("4" ?۴)
+ ("5" ?۵)
+ ("6" ?۶)
+ ("7" ?۷)
+ ("8" ?۸)
+ ("9" ?۹)
+ ("0" ?۰)
+ ("`" ?‍)
+ ("~" ?÷)
+ ("@" ?٬)
+ ("#" ?٫)
+ ("%" ?٪)
+ ("^" ?×)
+ ("&" ?«)
+ ("*" ?»)
+ ("_" ?ـ)
+ ("[" ?ج)
+ ("]" ?چ)
+ ("{" ?\[)
+ ("}" ?\])
+ (";" ?ک)
+ ("'" ?ګ)
+ ("\"" ?؛)
+ ("|" ?٭)
+ ("," ?و)
+ ("." ?ږ)
+ ("<" ?،)
+ (">" ?.)
+ ("?" ?؟))
+
+;;; End Matter
+(provide 'pakistan)
+;;; pakistan.el ends here
diff --git a/lisp/leim/quail/persian.el b/lisp/leim/quail/persian.el
index de61481d7f1..676b3ab5c2e 100644
--- a/lisp/leim/quail/persian.el
+++ b/lisp/leim/quail/persian.el
@@ -500,7 +500,7 @@
;; RIGHT-TO-LEFT EMBEDDING (sets base dir to RTL but allows embedded text)
("&rle;" ?\u202B) ;; (ucs-insert #x202B) named: زیرمتنِ راست‌به‌چپ
;; POP DIRECTIONAL FORMATTING (used for RLE or LRE and RLO or LRO)
- ;; EMACS ANOMOLY --- Why does &pdf not show up in (describe-input-method 'farsi-transliterate-banan)
+ ;; EMACS ANOMALY --- Why does &pdf not show up in (describe-input-method 'farsi-transliterate-banan)
("&pdf;" ?\u202C) ;; (ucs-insert #x202C) named: پایانِ زیرمتن
("P" ?\u202C)
;; LEFT-TO-RIGHT OVERRIDE (overrides the bidirectional algorithm, display LTR)
diff --git a/lisp/loadhist.el b/lisp/loadhist.el
index 40ac8722ac2..ece95ed619b 100644
--- a/lisp/loadhist.el
+++ b/lisp/loadhist.el
@@ -2,7 +2,7 @@
;; Copyright (C) 1995, 1998, 2000-2024 Free Software Foundation, Inc.
-;; Author: Eric S. Raymond <esr@snark.thyrsus.com>
+;; Author: Eric S. Raymond <esr@thyrsus.com>
;; Maintainer: emacs-devel@gnu.org
;; Keywords: internal
@@ -108,7 +108,8 @@ from a file."
features))
features)))))
-(defvaralias 'loadhist-hook-functions 'unload-feature-special-hooks)
+(define-obsolete-variable-alias 'loadhist-hook-functions
+ 'unload-feature-special-hooks "30.1")
(defvar unload-feature-special-hooks
'(after-change-functions after-insert-file-functions
after-make-frame-functions auto-coding-functions
@@ -148,14 +149,14 @@ documentation of `unload-feature' for details.")
(save-current-buffer
(dolist (buffer (buffer-list))
(set-buffer buffer)
- (let ((proposed major-mode))
+ (let ((proposed (derived-mode-all-parents major-mode)))
;; Look for a predecessor mode not defined in the feature we're processing
- (while (and proposed (rassq proposed unload-function-defs-list))
- (setq proposed (get proposed 'derived-mode-parent)))
- (unless (eq proposed major-mode)
+ (while (and proposed (rassq (car proposed) unload-function-defs-list))
+ (setq proposed (cdr proposed)))
+ (unless (eq (car proposed) major-mode)
;; Two cases: either proposed is nil, and we want to switch to fundamental
;; mode, or proposed is not nil and not major-mode, and so we use it.
- (funcall (or proposed 'fundamental-mode)))))))
+ (funcall (or (car proposed) 'fundamental-mode)))))))
(defvar loadhist-unload-filename nil)
diff --git a/lisp/loadup.el b/lisp/loadup.el
index 7c6dc4bfea1..c6a8dcbb909 100644
--- a/lisp/loadup.el
+++ b/lisp/loadup.el
@@ -103,7 +103,7 @@
;; During bootstrapping the byte-compiler is run interpreted
;; when compiling itself, which uses a lot more stack
;; than usual.
- (setq max-lisp-eval-depth 2200)))
+ (setq max-lisp-eval-depth (max max-lisp-eval-depth 3400))))
(if (eq t purify-flag)
;; Hash consing saved around 11% of pure space in my tests.
@@ -248,7 +248,7 @@
(load "simple")
(load "emacs-lisp/seq")
(load "emacs-lisp/nadvice")
-(load "minibuffer") ;Needs cl-generic (and define-minor-mode).
+(load "minibuffer") ; Needs cl-generic, seq (and define-minor-mode).
(load "frame")
(load "startup")
(load "term/tty-colors")
@@ -258,6 +258,9 @@
(load "jit-lock")
(load "mouse")
+;; This loading happens on Android despite scroll bars being
+;; unsupported, because scroll-bar-mode (the variable) must be
+;; defined.
(if (boundp 'x-toolkit-scroll-bars)
(load "scroll-bar"))
(load "select")
@@ -297,6 +300,7 @@
(if (featurep 'x)
(progn
+ (load "touch-screen")
(load "x-dnd")
(load "term/common-win")
(load "term/x-win")))
@@ -306,6 +310,13 @@
(load "term/common-win")
(load "term/haiku-win")))
+(if (featurep 'android)
+ (progn
+ (load "ls-lisp")
+ (load "touch-screen")
+ (load "term/common-win")
+ (load "term/android-win")))
+
(if (or (eq system-type 'windows-nt)
(featurep 'w32))
(progn
@@ -376,6 +387,9 @@
(load "tooltip"))
(load "international/iso-transl") ; Binds Alt-[ and friends.
+;; Used by `kill-buffer', for instance.
+(load "emacs-lisp/rmc")
+
;; This file doesn't exist when building a development version of Emacs
;; from the repository. It is generated just after temacs is built.
(load "leim/leim-list.el" t)
@@ -395,8 +409,17 @@
(message "Warning: Change in load-path due to site-load will be \
lost after dumping")))
-;; Used by `kill-buffer', for instance.
-(load "emacs-lisp/rmc")
+;; Actively check for advised functions during preload since:
+;; - advices in Emacs's core are generally considered bad style;
+;; - `Snarf-documentation' looses docstrings of primitives advised
+;; during preload (bug#66032#20).
+(mapatoms
+ (lambda (f)
+ (and (advice--p (symbol-function f))
+ ;; Don't make it an error because it's not serious enough and
+ ;; it can be annoying during development. Also there are still
+ ;; circumstances where we use advice on preloaded functions.
+ (message "Warning: Advice installed on preloaded function %S" f))))
;; Make sure default-directory is unibyte when dumping. This is
;; because we cannot decode and encode it correctly (since the locale
@@ -429,6 +452,13 @@ lost after dumping")))
(defconst emacs-build-number
(if versions (1+ (apply #'max versions)) 1))))
+;; Just set the repository branch during initial dumping on Android.
+(if (and (eq system-type 'android)
+ (not (pdumper-stats)))
+ (setq emacs-repository-version
+ (ignore-errors (emacs-repository-get-version))
+ emacs-repository-branch
+ (ignore-errors (emacs-repository-get-branch))))
(message "Finding pointers to doc strings...")
(if (and (or (and (fboundp 'dump-emacs)
@@ -476,23 +506,23 @@ lost after dumping")))
;; At this point, we're ready to resume undo recording for scratch.
(buffer-enable-undo "*scratch*")
-(defvar comp-subr-arities-h)
-(when (featurep 'native-compile)
- ;; Save the arity for all primitives so the compiler can always
- ;; retrieve it even in case of redefinition.
- (mapatoms (lambda (f)
- (when (subr-primitive-p (symbol-function f))
- (puthash f (func-arity f) comp-subr-arities-h))))
- ;; Fix the compilation unit filename to have it working when
- ;; installed or if the source directory got moved. This is set to be
- ;; a pair in the form of:
- ;; (rel-filename-from-install-bin . rel-filename-from-local-bin).
- (let ((bin-dest-dir (cadr (member "--bin-dest" command-line-args)))
- (eln-dest-dir (cadr (member "--eln-dest" command-line-args))))
- (when (and bin-dest-dir eln-dest-dir)
+(defvar load--bin-dest-dir nil
+ "Store the original value passed by \"--bin-dest\" during dump.
+Internal use only.")
+(defvar load--eln-dest-dir nil
+ "Store the original value passed by \"--eln-dest\" during dump.
+Internal use only.")
+
+(defun load--fixup-all-elns ()
+ "Fix all compilation unit filename.
+This to have it working when installed or if Emacs source
+directory got moved. This is set to be a pair in the form of:
+\(rel-filename-from-install-bin . rel-filename-from-local-bin)."
+ (when (and load--bin-dest-dir load--eln-dest-dir)
(setq eln-dest-dir
- (concat eln-dest-dir "native-lisp/" comp-native-version-dir "/"))
+ (concat load--eln-dest-dir "native-lisp/" comp-native-version-dir "/"))
(maphash (lambda (_ cu)
+ (when (stringp (native-comp-unit-file cu))
(let* ((file (native-comp-unit-file cu))
(preloaded (equal (substring (file-name-directory file)
-10 -1)
@@ -509,10 +539,20 @@ lost after dumping")))
(file-name-nondirectory
file)
eln-dest-dir-eff)
- bin-dest-dir)
+ load--bin-dest-dir)
;; Relative filename from the built uninstalled binary.
- (file-relative-name file invocation-directory)))))
- comp-loaded-comp-units-h)))
+ (file-relative-name file invocation-directory))))))
+ comp-loaded-comp-units-h)))
+
+(defvar comp-subr-arities-h)
+(when (featurep 'native-compile)
+ ;; Save the arity for all primitives so the compiler can always
+ ;; retrieve it even in case of redefinition.
+ (mapatoms (lambda (f)
+ (when (subr-primitive-p (symbol-function f))
+ (puthash f (func-arity f) comp-subr-arities-h))))
+ (setq load--bin-dest-dir (cadr (member "--bin-dest" command-line-args)))
+ (setq load--eln-dest-dir (cadr (member "--eln-dest" command-line-args)))
;; Set up the mechanism to allow inhibiting native-comp via
;; file-local variables.
(defvar comp--no-native-compile (make-hash-table :test #'equal)))
@@ -546,66 +586,104 @@ lost after dumping")))
-(if dump-mode
- (let ((output (cond ((equal dump-mode "pdump") "emacs.pdmp")
- ((equal dump-mode "dump") "emacs")
- ((equal dump-mode "bootstrap") "emacs")
- ((equal dump-mode "pbootstrap") "bootstrap-emacs.pdmp")
- (t (error "Unrecognized dump mode %s" dump-mode)))))
- (when (and (featurep 'native-compile)
- (equal dump-mode "pdump"))
- ;; Don't enable this before bootstrap is completed, as the
- ;; compiler infrastructure may not be usable yet.
- (setq native-comp-enable-subr-trampolines t))
- (message "Dumping under the name %s" output)
- (condition-case ()
- (delete-file output)
- (file-error nil))
- ;; On MS-Windows, the current directory is not necessarily the
- ;; same as invocation-directory.
- (let (success)
- (unwind-protect
- (let ((tmp-dump-mode dump-mode)
- (dump-mode nil)
- (lexical-binding nil))
- (if (member tmp-dump-mode '("pdump" "pbootstrap"))
- (dump-emacs-portable (expand-file-name output invocation-directory))
- (dump-emacs output (if (eq system-type 'ms-dos)
- "temacs.exe"
- "temacs"))
- (message "%d pure bytes used" pure-bytes-used))
- (setq success t))
- (unless success
- (ignore-errors
- (delete-file output)))))
- ;; Recompute NAME now, so that it isn't set when we dump.
- (if (not (or (eq system-type 'ms-dos)
- (eq system-type 'haiku) ;; BFS doesn't support hard links
- ;; Don't bother adding another name if we're just
- ;; building bootstrap-emacs.
- (member dump-mode '("pbootstrap" "bootstrap"))))
- (let ((name (format "emacs-%s.%d" emacs-version emacs-build-number))
- (exe (if (eq system-type 'windows-nt) ".exe" "")))
- (while (string-match "[^-+_.a-zA-Z0-9]+" name)
- (setq name (concat (downcase (substring name 0 (match-beginning 0)))
- "-"
- (substring name (match-end 0)))))
- (message "Adding name %s" (concat name exe))
- ;; When this runs on Windows, invocation-directory is not
- ;; necessarily the current directory.
- (add-name-to-file (expand-file-name (concat "emacs" exe)
- invocation-directory)
- (expand-file-name (concat name exe)
- invocation-directory)
- t)
- (when (equal dump-mode "pdump")
- (message "Adding name %s" (concat name ".pdmp"))
- (add-name-to-file (expand-file-name "emacs.pdmp"
+(if (and (eq system-type 'android)
+ (featurep 'android))
+ (progn
+ ;; Dumping Emacs on Android works slightly differently from
+ ;; everywhere else. The first time Emacs starts, Emacs dumps
+ ;; itself to "emacs-%s.pdump", and then proceeds with loadup,
+ ;; where %s is replaced by the dump fingerprint.
+ ;; EmacsApplication.java removes any pdump files with a
+ ;; different build fingerprint upon being created, which happens
+ ;; the moment the Android system starts Emacs. Then, it passes
+ ;; the appropriate "--dump-file" to libemacs.so as it starts.
+ (when (not noninteractive)
+ (let ((temp-dir (getenv "TEMP"))
+ (dump-file-name (format "%semacs-%s.pdmp"
+ (file-name-as-directory "~")
+ pdumper-fingerprint))
+ (dump-temp-file-name (format "%s~emacs-%s.pdmp"
+ (file-name-as-directory "~")
+ pdumper-fingerprint)))
+ (unless (pdumper-stats)
+ (condition-case ()
+ (progn
+ (dump-emacs-portable dump-temp-file-name)
+ ;; Move the dumped file to the actual dump file name.
+ (rename-file dump-temp-file-name dump-file-name)
+ ;; Continue with loadup.
+ nil)
+ (error nil))))))
+ (if dump-mode
+ (let ((output (cond ((equal dump-mode "pdump") "emacs.pdmp")
+ ((equal dump-mode "dump") "emacs")
+ ((equal dump-mode "bootstrap") "emacs")
+ ((equal dump-mode "pbootstrap") "bootstrap-emacs.pdmp")
+ (t (error "Unrecognized dump mode %s" dump-mode)))))
+ (when (and (featurep 'native-compile)
+ (equal dump-mode "pdump"))
+ ;; Don't enable this before bootstrap is completed, as the
+ ;; compiler infrastructure may not be usable yet.
+ (setq native-comp-enable-subr-trampolines t))
+ (message "Dumping under the name %s" output)
+ (condition-case ()
+ (delete-file output)
+ (file-error nil))
+ ;; On MS-Windows, the current directory is not necessarily the
+ ;; same as invocation-directory.
+ (let (success)
+ (unwind-protect
+ (let ((tmp-dump-mode dump-mode)
+ (dump-mode nil)
+ ;; Set `lexical-binding' to nil by default
+ ;; in the dumped Emacs.
+ (lexical-binding nil))
+ (if (member tmp-dump-mode '("pdump" "pbootstrap"))
+ (dump-emacs-portable (expand-file-name output invocation-directory))
+ (dump-emacs output (if (eq system-type 'ms-dos)
+ "temacs.exe"
+ "temacs"))
+ (message "%d pure bytes used" pure-bytes-used))
+ (setq success t))
+ (unless success
+ (ignore-errors
+ (delete-file output)))))
+ ;; Recompute NAME now, so that it isn't set when we dump.
+ (if (not (or (eq system-type 'ms-dos)
+ (eq system-type 'haiku) ;; BFS doesn't support hard links
+ ;; There's no point keeping old dumps around for
+ ;; the binary used to build Lisp on the build
+ ;; machine.
+ (or (featurep 'android)
+ ;; And if this branch is reached with
+ ;; `system-type' set to Android, this is a
+ ;; regular Emacs TTY build. (bug#65339)
+ (eq system-type 'android))
+ ;; Don't bother adding another name if we're just
+ ;; building bootstrap-emacs.
+ (member dump-mode '("pbootstrap" "bootstrap"))))
+ (let ((name (format "emacs-%s.%d" emacs-version emacs-build-number))
+ (exe (if (eq system-type 'windows-nt) ".exe" "")))
+ (while (string-match "[^-+_.a-zA-Z0-9]+" name)
+ (setq name (concat (downcase (substring name 0 (match-beginning 0)))
+ "-"
+ (substring name (match-end 0)))))
+ (message "Adding name %s" (concat name exe))
+ ;; When this runs on Windows, invocation-directory is not
+ ;; necessarily the current directory.
+ (add-name-to-file (expand-file-name (concat "emacs" exe)
invocation-directory)
- (expand-file-name (concat name ".pdmp")
+ (expand-file-name (concat name exe)
invocation-directory)
- t))))
- (kill-emacs)))
+ t)
+ (when (equal dump-mode "pdump")
+ (message "Adding name %s" (concat name ".pdmp"))
+ (add-name-to-file (expand-file-name "emacs.pdmp"
+ invocation-directory)
+ (expand-file-name (concat name ".pdmp")
+ invocation-directory)
+ t))))
+ (kill-emacs))))
;; This file must be loaded each time Emacs is run from scratch, e.g., temacs.
;; So run the startup code now. First, remove `-l loadup' from args.
@@ -621,6 +699,13 @@ lost after dumping")))
(setq load-file-name nil)
(eval top-level t)
+;; loadup.el is loaded at startup, but clobbers current-load-list.
+;; Set current-load-list to a list containing no definitions and only
+;; its name, to prevent invalid entries from ending up in
+;; Vload_history when running temacs interactively.
+
+(setq current-load-list (list "loadup.el"))
+
;; Local Variables:
;; no-byte-compile: t
diff --git a/lisp/locate.el b/lisp/locate.el
index 723d054406a..70328d5184e 100644
--- a/lisp/locate.el
+++ b/lisp/locate.el
@@ -141,13 +141,11 @@ system, or of all files that you have access to. Consult the
documentation of that program for the details about how it determines
which file names match SEARCH-STRING. (Those details vary highly with
the version.)"
- :type 'string
- :group 'locate)
+ :type 'string)
(defcustom locate-post-command-hook nil
"List of hook functions run after `locate' (see `run-hooks')."
- :type 'hook
- :group 'locate)
+ :type 'hook)
(defvar locate-history-list nil
"The history list used by the \\[locate] command.")
@@ -162,13 +160,11 @@ This function should take one argument, a string (the name to find)
and return a list of strings. The first element of the list should be
the name of a command to be executed by a shell, the remaining elements
should be the arguments to that command (including the name to find)."
- :type 'function
- :group 'locate)
+ :type 'function)
(defcustom locate-buffer-name "*Locate*"
"Name of the buffer to show results from the \\[locate] command."
- :type 'string
- :group 'locate)
+ :type 'string)
(defcustom locate-fcodes-file nil
"File name for the database of file names used by `locate'.
@@ -179,20 +175,17 @@ Just setting this variable does not actually change the database
that `locate' searches. The executive program that the Emacs
function `locate' uses, as given by the variables `locate-command'
or `locate-make-command-line', determines the database."
- :type '(choice (const :tag "None" nil) file)
- :group 'locate)
+ :type '(choice (const :tag "None" nil) file))
(defcustom locate-header-face nil
"Face used to highlight the locate header."
- :type '(choice (const :tag "None" nil) face)
- :group 'locate)
+ :type '(choice (const :tag "None" nil) face))
;;;###autoload
(defcustom locate-ls-subdir-switches (purecopy "-al")
"`ls' switches for inserting subdirectories in `*Locate*' buffers.
This should contain the \"-l\" switch, but not the \"-F\" or \"-b\" switches."
:type 'string
- :group 'locate
:version "22.1")
(defcustom locate-update-when-revert nil
@@ -202,13 +195,11 @@ If non-nil, offer to update the locate database when reverting that buffer.
option `locate-update-path'.)
If nil, reverting does not update the locate database."
:type 'boolean
- :group 'locate
:version "22.1")
(defcustom locate-update-command "updatedb"
"The executable program used to update the locate database."
- :type 'string
- :group 'locate)
+ :type 'string)
(defcustom locate-update-path "/"
"The default directory from where `locate-update-command' is called.
@@ -218,7 +209,6 @@ can be achieved by setting this option to \"/su::\" or \"/sudo::\"
permissions are sufficient to run the command, you can set this
option to \"/\"."
:type 'string
- :group 'locate
:version "22.1")
(defcustom locate-prompt-for-command nil
@@ -227,13 +217,11 @@ Otherwise, that behavior is invoked via a prefix argument.
Setting this option non-nil actually inverts the meaning of a prefix arg;
that is, with a prefix arg, you get the default behavior."
- :group 'locate
:type 'boolean)
(defcustom locate-mode-hook nil
"List of hook functions run by `locate-mode' (see `run-mode-hooks')."
- :type 'hook
- :group 'locate)
+ :type 'hook)
;; Functions
@@ -371,17 +359,17 @@ except that FILTER is not optional."
(defvar locate-mode-map
(let ((map (copy-keymap dired-mode-map)))
;; Undefine Useless Dired Menu bars
- (define-key map [menu-bar Dired] 'undefined)
- (define-key map [menu-bar subdir] 'undefined)
- (define-key map [menu-bar mark executables] 'undefined)
- (define-key map [menu-bar mark directory] 'undefined)
- (define-key map [menu-bar mark directories] 'undefined)
- (define-key map [menu-bar mark symlinks] 'undefined)
- (define-key map [M-mouse-2] 'locate-mouse-view-file)
- (define-key map "\C-c\C-t" 'locate-tags)
- (define-key map "l" 'locate-do-redisplay)
- (define-key map "U" 'dired-unmark-all-files)
- (define-key map "V" 'locate-find-directory)
+ (define-key map [menu-bar Dired] #'undefined)
+ (define-key map [menu-bar subdir] #'undefined)
+ (define-key map [menu-bar mark executables] #'undefined)
+ (define-key map [menu-bar mark directory] #'undefined)
+ (define-key map [menu-bar mark directories] #'undefined)
+ (define-key map [menu-bar mark symlinks] #'undefined)
+ (define-key map [M-mouse-2] #'locate-mouse-view-file)
+ (define-key map "\C-c\C-t" #'locate-tags)
+ (define-key map "l" #'locate-do-redisplay)
+ (define-key map "U" #'dired-unmark-all-files)
+ (define-key map "V" #'locate-find-directory)
map)
"Local keymap for Locate mode buffers.")
@@ -486,7 +474,7 @@ do not work in subdirectories.
(setq-local revert-buffer-function #'locate-update)
(setq-local page-delimiter "\n\n"))
-(put 'locate-mode 'derived-mode-parent 'dired-mode)
+(derived-mode-add-parents 'locate-mode '(dired-mode special-mode))
(defun locate-do-setup (search-string)
(goto-char (point-min))
@@ -571,7 +559,7 @@ do not work in subdirectories.
(defun locate-tags ()
"Visit a tags table in `*Locate*' mode."
- (interactive)
+ (interactive nil locate-mode)
(if (locate-main-listing-line-p)
(let ((tags-table (locate-get-filename)))
(and (y-or-n-p (format "Visit tags table %s? " tags-table))
@@ -601,7 +589,7 @@ locate database using the shell command in `locate-update-command'."
(defun locate-find-directory ()
"Visit the directory of the file mentioned on this line."
- (interactive)
+ (interactive nil locate-mode)
(if (locate-main-listing-line-p)
(let ((directory-name (locate-get-dirname)))
(if (file-directory-p directory-name)
@@ -613,7 +601,7 @@ locate database using the shell command in `locate-update-command'."
(defun locate-find-directory-other-window ()
"Visit the directory of the file named on this line in other window."
- (interactive)
+ (interactive nil locate-mode)
(if (locate-main-listing-line-p)
(find-file-other-window (locate-get-dirname))
(message "This command only works inside main listing.")))
diff --git a/lisp/lpr.el b/lisp/lpr.el
index 0c1295d4331..c860c633b73 100644
--- a/lisp/lpr.el
+++ b/lisp/lpr.el
@@ -73,7 +73,8 @@ switch on this list.
See `lpr-command'."
:type '(repeat (string :tag "Argument")))
-(defcustom lpr-add-switches (memq system-type '(berkeley-unix gnu/linux))
+(defcustom lpr-add-switches
+ (not (not (memq system-type '(berkeley-unix gnu/linux))))
"Non-nil means construct `-T' and `-J' options for the printer program.
These are made assuming that the program is `lpr';
if you are using some other incompatible printer program,
diff --git a/lisp/ls-lisp.el b/lisp/ls-lisp.el
index 7674009351f..89f0238cf74 100644
--- a/lisp/ls-lisp.el
+++ b/lisp/ls-lisp.el
@@ -101,7 +101,7 @@ update the dependent variables."
:group 'ls-lisp)
(defcustom ls-lisp-ignore-case
- (memq ls-lisp-emulation '(MS-Windows MacOS))
+ (not (not (memq ls-lisp-emulation '(MS-Windows MacOS))))
"Non-nil causes ls-lisp alphabetic sorting to ignore case."
:set-after '(ls-lisp-emulation)
:type 'boolean
@@ -161,15 +161,15 @@ systems, set your locale instead."
((eq ls-lisp-emulation 'MS-Windows)
(if (and (fboundp 'w32-using-nt) (w32-using-nt))
'(links))) ; distinguish NT/2K from 9x
- ((eq ls-lisp-emulation 'UNIX) '(links uid)) ; UNIX ls
- (t '(links uid gid))) ; GNU ls
+ ((eq ls-lisp-emulation 'UNIX) '(links uid modes)) ; UNIX ls
+ (t '(links uid gid modes))) ; GNU ls
"A list of optional file attributes that ls-lisp should display.
It should contain none or more of the symbols: links, uid, gid.
A value of nil (or an empty list) means display none of them.
Concepts come from UNIX: `links' means count of names associated with
the file; `uid' means user (owner) identifier; `gid' means group
-identifier.
+identifier; `modes' means Unix-style permission bits (drwxrwxrwx).
If emulation is MacOS then default is nil;
if emulation is MS-Windows then default is `(links)' if platform is
@@ -180,11 +180,12 @@ if emulation is GNU then default is `(links uid gid)'."
;; Functionality suggested by Howard Melman <howard@silverstream.com>
:type '(set (const :tag "Show Link Count" links)
(const :tag "Show User" uid)
- (const :tag "Show Group" gid))
+ (const :tag "Show Group" gid)
+ (const :tag "Show Modes" modes))
:group 'ls-lisp)
(defcustom ls-lisp-use-insert-directory-program
- (not (memq system-type '(ms-dos windows-nt)))
+ (not (memq system-type '(ms-dos windows-nt android)))
"Non-nil causes ls-lisp to revert back to using `insert-directory-program'.
This is useful on platforms where ls-lisp is dumped into Emacs, such as
Microsoft Windows, but you would still like to use a program to list
@@ -248,89 +249,69 @@ to fail to line up, e.g. if month names are not all of the same length."
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-(defun ls-lisp--insert-directory (orig-fun file switches &optional wildcard full-directory-p)
+(defun ls-lisp--insert-directory (file switches wildcard full-directory-p)
"Insert directory listing for FILE, formatted according to SWITCHES.
-Leaves point after the inserted text.
-SWITCHES may be a string of options, or a list of strings.
-Optional third arg WILDCARD means treat FILE as shell wildcard.
-Optional fourth arg FULL-DIRECTORY-P means file is a directory and
-switches do not contain `d', so that a full listing is expected.
-
-This version of the function comes from `ls-lisp.el'.
-If the value of `ls-lisp-use-insert-directory-program' is non-nil then
-this advice just delegates the work to ORIG-FUN (the normal `insert-directory'
-function from `files.el').
-But if the value of `ls-lisp-use-insert-directory-program' is nil
-then it runs a Lisp emulation.
-
-The Lisp emulation does not run any external programs or shells. It
-supports ordinary shell wildcards if `ls-lisp-support-shell-wildcards'
+This implementation of `insert-directory' works using Lisp functions rather
+than `insert-directory-program'.
+
+This Lisp emulation does not run any external programs or shells.
+ It supports ordinary shell wildcards if `ls-lisp-support-shell-wildcards'
is non-nil; otherwise, it interprets wildcards as regular expressions
to match file names. It does not support all `ls' switches -- those
that work are: A a B C c F G g h i n R r S s t U u v X. The l switch
is assumed to be always present and cannot be turned off.
Long variants of the above switches, as documented for GNU `ls',
are also supported; unsupported long options are silently ignored."
- (if ls-lisp-use-insert-directory-program
- (funcall orig-fun
- file switches wildcard full-directory-p)
- ;; We need the directory in order to find the right handler.
- (setq switches (or switches ""))
- (let ((handler (find-file-name-handler (expand-file-name file)
- 'insert-directory))
- (orig-file file)
- wildcard-regexp
- (ls-lisp-dirs-first
- (or ls-lisp-dirs-first
- (string-match "--group-directories-first" switches))))
- (if handler
- (funcall handler 'insert-directory file switches
- wildcard full-directory-p)
- (when (string-match "--group-directories-first" switches)
- ;; if ls-lisp-dirs-first is nil, dirs are grouped but come out in
- ;; reverse order:
- (setq ls-lisp-dirs-first t)
- (setq switches (replace-match "" nil nil switches)))
- ;; Remove unrecognized long options, and convert the
- ;; recognized ones to their short variants.
- (setq switches (ls-lisp--sanitize-switches switches))
- ;; Convert SWITCHES to a list of characters.
- (setq switches (delete ?\ (delete ?- (append switches nil))))
- ;; Sometimes we get ".../foo*/" as FILE. While the shell and
- ;; `ls' don't mind, we certainly do, because it makes us think
- ;; there is no wildcard, only a directory name.
- (if (and ls-lisp-support-shell-wildcards
- (string-match "[[?*]" file)
- ;; Prefer an existing file to wildcards, like
- ;; dired-noselect does.
- (not (file-exists-p file)))
- (progn
- (or (not (eq (aref file (1- (length file))) ?/))
- (setq file (substring file 0 (1- (length file)))))
- (setq wildcard t)))
- (if wildcard
- (setq wildcard-regexp
- (if ls-lisp-support-shell-wildcards
- (wildcard-to-regexp (file-name-nondirectory file))
- (file-name-nondirectory file))
- file (file-name-directory file))
- (if (memq ?B switches) (setq wildcard-regexp "[^~]\\'")))
- (condition-case err
- (ls-lisp-insert-directory
- file switches (ls-lisp-time-index switches)
- wildcard-regexp full-directory-p)
- (invalid-regexp
- ;; Maybe they wanted a literal file that just happens to
- ;; use characters special to shell wildcards.
- (if (equal (cadr err) "Unmatched [ or [^")
- (progn
- (setq wildcard-regexp (if (memq ?B switches) "[^~]\\'")
- file (file-relative-name orig-file))
- (ls-lisp-insert-directory
- file switches (ls-lisp-time-index switches)
- nil full-directory-p))
- (signal (car err) (cdr err)))))))))
-(advice-add 'insert-directory :around #'ls-lisp--insert-directory)
+ (setq switches (or switches ""))
+ (let ((orig-file file)
+ wildcard-regexp
+ (ls-lisp-dirs-first
+ (or ls-lisp-dirs-first
+ (string-match "--group-directories-first" switches))))
+ (when (string-match "--group-directories-first" switches)
+ ;; if ls-lisp-dirs-first is nil, dirs are grouped but come out in
+ ;; reverse order:
+ (setq ls-lisp-dirs-first t)
+ (setq switches (replace-match "" nil nil switches)))
+ ;; Remove unrecognized long options, and convert the
+ ;; recognized ones to their short variants.
+ (setq switches (ls-lisp--sanitize-switches switches))
+ ;; Convert SWITCHES to a list of characters.
+ (setq switches (delete ?\ (delete ?- (append switches nil))))
+ ;; Sometimes we get ".../foo*/" as FILE. While the shell and
+ ;; `ls' don't mind, we certainly do, because it makes us think
+ ;; there is no wildcard, only a directory name.
+ (if (and ls-lisp-support-shell-wildcards
+ (string-match "[[?*]" file)
+ ;; Prefer an existing file to wildcards, like
+ ;; dired-noselect does.
+ (not (file-exists-p file)))
+ (progn
+ (or (not (eq (aref file (1- (length file))) ?/))
+ (setq file (substring file 0 (1- (length file)))))
+ (setq wildcard t)))
+ (if wildcard
+ (setq wildcard-regexp
+ (if ls-lisp-support-shell-wildcards
+ (wildcard-to-regexp (file-name-nondirectory file))
+ (file-name-nondirectory file))
+ file (file-name-directory file))
+ (if (memq ?B switches) (setq wildcard-regexp "[^~]\\'")))
+ (condition-case err
+ (ls-lisp-insert-directory
+ file switches (ls-lisp-time-index switches)
+ wildcard-regexp full-directory-p)
+ (invalid-regexp
+ ;; Maybe they wanted a literal file that just happens to
+ ;; use characters special to shell wildcards.
+ (if (equal (cadr err) "Unmatched [ or [^")
+ (progn
+ (setq wildcard-regexp (if (memq ?B switches) "[^~]\\'")
+ file (file-relative-name orig-file))
+ (ls-lisp-insert-directory
+ file switches (ls-lisp-time-index switches)
+ nil full-directory-p))
+ (signal (car err) (cdr err)))))))
(defun ls-lisp-insert-directory
(file switches time-index wildcard-regexp full-directory-p)
@@ -468,50 +449,6 @@ not contain `d', so that a full listing is expected."
"Directory doesn't exist or is inaccessible"
file))))))
-(declare-function dired-read-dir-and-switches "dired" (str))
-(declare-function dired-goto-next-file "dired" ())
-
-(defun ls-lisp--dired (orig-fun dir-or-list &optional switches)
- (interactive (dired-read-dir-and-switches ""))
- (unless dir-or-list
- (setq dir-or-list default-directory))
- (if (consp dir-or-list)
- (funcall orig-fun dir-or-list switches)
- (let ((dir-wildcard (insert-directory-wildcard-in-dir-p
- (expand-file-name dir-or-list))))
- (if (not dir-wildcard)
- (funcall orig-fun dir-or-list switches)
- (let* ((default-directory (car dir-wildcard))
- (wildcard (cdr dir-wildcard))
- (files (file-expand-wildcards wildcard))
- (dir (car dir-wildcard)))
- ;; When the wildcard ends in a slash, file-expand-wildcards
- ;; returns nil; fix that by treating the wildcards as
- ;; specifying only directories whose names match the
- ;; widlcard.
- (if (and (null files)
- (directory-name-p wildcard))
- (setq files
- (delq nil
- (mapcar (lambda (fname)
- (if (file-accessible-directory-p fname)
- fname))
- (file-expand-wildcards
- (directory-file-name wildcard))))))
- (if files
- (let ((inhibit-read-only t)
- (buf
- (apply orig-fun (nconc (list dir) files) (and switches (list switches)))))
- (with-current-buffer buf
- (save-excursion
- (goto-char (point-min))
- (dired-goto-next-file)
- (forward-line 0)
- (insert " wildcard " (cdr dir-wildcard) "\n"))))
- (user-error "No files matching wildcard")))))))
-
-(advice-add 'dired :around #'ls-lisp--dired)
-
(defun ls-lisp-sanitize (file-alist)
"Sanitize the elements in FILE-ALIST.
Fixes any elements in the alist for directory entries whose file
@@ -808,7 +745,9 @@ SWITCHES and TIME-INDEX give the full switch list and time data."
(* 1024.0 (fceiling (/ file-size 1024.0)))))
(format ls-lisp-filesize-b-fmt
(fceiling (/ file-size 1024.0)))))
- drwxrwxrwx ; attribute string
+ (if (memq 'modes ls-lisp-verbosity)
+ drwxrwxrwx ; modes string
+ (substring drwxrwxrwx 0 4)) ; "d" or "-" for directory vs file
(if (memq 'links ls-lisp-verbosity)
(format "%3d" (file-attribute-link-number file-attr)))
;; Numeric uid/gid are more confusing than helpful;
@@ -897,13 +836,6 @@ All ls time options, namely c, t and u, are handled."
file-size)
(format " %7s" (file-size-human-readable file-size))))
-(defun ls-lisp-unload-function ()
- "Unload ls-lisp library."
- (advice-remove 'insert-directory #'ls-lisp--insert-directory)
- (advice-remove 'dired #'ls-lisp--dired)
- ;; Continue standard unloading.
- nil)
-
(defun ls-lisp--sanitize-switches (switches)
"Convert long options of GNU \"ls\" to their short form.
Conversion is done only for flags supported by ls-lisp.
diff --git a/lisp/macros.el b/lisp/macros.el
index adba734fe5a..7108a027ca6 100644
--- a/lisp/macros.el
+++ b/lisp/macros.el
@@ -46,16 +46,6 @@
" ")
?\]))
-(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.
@@ -88,10 +78,8 @@ use this command, and then save the file."
(insert "(defalias '"))
(prin1 macroname (current-buffer))
(insert "\n ")
- (when (stringp definition)
- (setq definition (macro--string-to-vector definition)))
- (if (vectorp definition)
- (setq definition (kmacro definition)))
+ (when (or (stringp definition) (vectorp definition))
+ (setq definition (kmacro (kmacro--to-vector definition))))
(if (kmacro-p definition)
(let ((vecdef (kmacro--keys definition))
(counter (kmacro--counter definition))
@@ -209,7 +197,7 @@ For example, in Usenet articles, sections of text quoted from another
author are indented, or have each line start with `>'. To quote a
section of text, define a keyboard macro which inserts `>', put point
and mark at opposite ends of the quoted section, and use
-`\\[apply-macro-to-region-lines]' to mark the entire section.
+\\[apply-macro-to-region-lines] to mark the entire section.
Suppose you wanted to build a keyword table in C where each entry
looked like this:
@@ -231,7 +219,7 @@ and write a macro to massage a word into a table entry:
\\C-x )
and then select the region of un-tablified names and use
-`\\[apply-macro-to-region-lines]' to build the table from the names."
+\\[apply-macro-to-region-lines] to build the table from the names."
(interactive "r")
(or macro
(progn
diff --git a/lisp/mail/binhex.el b/lisp/mail/binhex.el
index af24b3194e7..2eac5dacc77 100644
--- a/lisp/mail/binhex.el
+++ b/lisp/mail/binhex.el
@@ -49,7 +49,7 @@ input and write the converted data to its standard output."
:type '(repeat string))
(defcustom binhex-use-external
- (executable-find binhex-decoder-program)
+ (not (not (executable-find binhex-decoder-program)))
"Use external binhex program."
:version "22.1"
:type 'boolean)
diff --git a/lisp/mail/emacsbug.el b/lisp/mail/emacsbug.el
index 7d5cda130a4..e89e66cc7cb 100644
--- a/lisp/mail/emacsbug.el
+++ b/lisp/mail/emacsbug.el
@@ -144,6 +144,10 @@ This requires either the macOS \"open\" command, or the freedesktop
(goto-char (point-min))
(buffer-substring (line-beginning-position)
(line-end-position))))))
+ ((eq system-type 'android)
+ ;; This is a short string containing the Android version,
+ ;; build number, and window system distributor.
+ (symbol-value 'android-build-fingerprint))
;; TODO Cygwin, Solaris (usg-unix-v).
(t
(or (let ((file "/etc/os-release"))
@@ -229,9 +233,11 @@ Already submitted bugs can be found in the Emacs bug tracker:
(set-frame-parameter nil 'unsplittable nil))
(error nil))
(compose-mail report-emacs-bug-address topic)
+ (rfc822-goto-eoh)
+ (insert "X-Debbugs-Cc: \n")
;; The rest of this does not execute if the user was asked to
;; confirm and said no.
- (when (eq major-mode 'message-mode)
+ (when (derived-mode-p 'message-mode)
;; Message-mode sorts the headers before sending. We sort now so
;; that report-emacs-bug-orig-text remains valid. (Bug#5178)
(message-sort-headers)
@@ -505,7 +511,7 @@ Message buffer where you can explain more about the patch."
(list (read-string (format-prompt "This patch is about" guess)
nil nil guess)
file)))
- (switch-to-buffer "*Patch Help*")
+ (pop-to-buffer-same-window "*Patch Help*")
(let ((inhibit-read-only t))
(erase-buffer)
(insert "Thank you for considering submitting a patch to the Emacs project.\n\n"
diff --git a/lisp/mail/feedmail.el b/lisp/mail/feedmail.el
index 97d20cca151..165aafae1f7 100644
--- a/lisp/mail/feedmail.el
+++ b/lisp/mail/feedmail.el
@@ -2511,22 +2511,20 @@ mapped to mostly alphanumerics for safety."
feedmail-force-binary-write)
'no-conversion
coding-system-for-write)))
- (unwind-protect
- (progn
- (insert fcc)
- (unless feedmail-nuke-bcc-in-fcc
- (if bcc-holder (insert bcc-holder))
- (if resent-bcc-holder
- (insert resent-bcc-holder)))
-
- (run-hooks 'feedmail-before-fcc-hook)
-
- (when feedmail-nuke-body-in-fcc
- (goto-char eoh-marker)
- (if (natnump feedmail-nuke-body-in-fcc)
- (forward-line feedmail-nuke-body-in-fcc))
- (delete-region (point) (point-max)))
- (mail-do-fcc eoh-marker))))))
+ (insert fcc)
+ (unless feedmail-nuke-bcc-in-fcc
+ (if bcc-holder (insert bcc-holder))
+ (if resent-bcc-holder
+ (insert resent-bcc-holder)))
+
+ (run-hooks 'feedmail-before-fcc-hook)
+
+ (when feedmail-nuke-body-in-fcc
+ (goto-char eoh-marker)
+ (if (natnump feedmail-nuke-body-in-fcc)
+ (forward-line feedmail-nuke-body-in-fcc))
+ (delete-region (point) (point-max)))
+ (mail-do-fcc eoh-marker))))
;; User bailed out of one-last-look.
(if feedmail-queue-runner-is-active
(throw 'skip-me-q 'skip-me-q)
@@ -3046,30 +3044,30 @@ been weeded out."
(address-blob)
(this-line)
(this-line-end))
- (unwind-protect
- (with-current-buffer (get-buffer-create " *FQM scratch*")
- (erase-buffer)
- (insert-buffer-substring message-buffer header-start header-end)
- (goto-char (point-min))
- (let ((case-fold-search t))
- (while (re-search-forward addr-regexp (point-max) t)
- (replace-match "")
- (setq this-line (match-beginning 0))
- (forward-line 1)
- ;; get any continuation lines
- (while (and (looking-at "^[ \t]+") (< (point) (point-max)))
- (forward-line 1))
- (setq this-line-end (point-marker))
- ;; only keep if we don't have it already
- (setq address-blob
- (mail-strip-quoted-names (buffer-substring-no-properties this-line this-line-end)))
- (while (string-match "\\([, \t\n\r]*\\)\\([^, \t\n\r]+\\)" address-blob)
- (setq simple-address (substring address-blob (match-beginning 2) (match-end 2)))
- (setq address-blob (replace-match "" t t address-blob))
- (if (not (member simple-address address-list))
- (push simple-address address-list)))
- ))
- (kill-buffer nil)))
+
+ (with-current-buffer (get-buffer-create " *FQM scratch*")
+ (erase-buffer)
+ (insert-buffer-substring message-buffer header-start header-end)
+ (goto-char (point-min))
+ (let ((case-fold-search t))
+ (while (re-search-forward addr-regexp (point-max) t)
+ (replace-match "")
+ (setq this-line (match-beginning 0))
+ (forward-line 1)
+ ;; get any continuation lines
+ (while (and (looking-at "^[ \t]+") (< (point) (point-max)))
+ (forward-line 1))
+ (setq this-line-end (point-marker))
+ ;; only keep if we don't have it already
+ (setq address-blob
+ (mail-strip-quoted-names (buffer-substring-no-properties this-line this-line-end)))
+ (while (string-match "\\([, \t\n\r]*\\)\\([^, \t\n\r]+\\)" address-blob)
+ (setq simple-address (substring address-blob (match-beginning 2) (match-end 2)))
+ (setq address-blob (replace-match "" t t address-blob))
+ (if (not (member simple-address address-list))
+ (push simple-address address-list)))
+ ))
+ (kill-buffer nil))
(identity address-list)))
diff --git a/lisp/mail/footnote.el b/lisp/mail/footnote.el
index 79878e6676d..dda099ac013 100644
--- a/lisp/mail/footnote.el
+++ b/lisp/mail/footnote.el
@@ -347,10 +347,11 @@ Use Unicode characters for footnoting."
("ק" "ר" "ש" "ת" "תק" "תר" "תש" "תת" "תתק")))
(defconst footnote-hebrew-numeric-regex
- (let ((numchars (string-to-list
- (apply #'concat (apply #'append footnote-hebrew-numeric)))))
+ (let ((numchars
+ (delete-dups
+ (string-to-list
+ (apply #'concat (apply #'append footnote-hebrew-numeric))))))
(rx-to-string `(1+ (in ?' ,@numchars)))))
-;; (defconst footnote-hebrew-numeric-regex "\\([אבגדהוזחט]'\\)?\\(ת\\)?\\(ת\\)?\\([קרשת]\\)?\\([טיכלמנסעפצ]\\)?\\([אבגדהוזחט]\\)?")
(defun footnote--hebrew-numeric (n)
"Supports 9999 footnotes, then rolls over."
diff --git a/lisp/mail/ietf-drums.el b/lisp/mail/ietf-drums.el
index 83de19fdc9e..eaccbff0b13 100644
--- a/lisp/mail/ietf-drums.el
+++ b/lisp/mail/ietf-drums.el
@@ -272,6 +272,21 @@ a list of address strings."
(while (not (eobp))
(setq c (char-after))
(cond
+ ((eq c ?:)
+ (setq beg (1+ (point)))
+ (skip-chars-forward "^;")
+ (when-let ((address
+ (condition-case nil
+ (ietf-drums-parse-addresses
+ (buffer-substring beg (point)) rawp)
+ (error nil))))
+ (if (listp address)
+ (setq pairs (append address pairs))
+ (push address pairs)))
+ (condition-case nil
+ (forward-char 1)
+ (error nil))
+ (setq beg (point)))
((memq c '(?\" ?< ?\())
(condition-case nil
(forward-sexp 1)
@@ -285,10 +300,12 @@ a list of address strings."
(ietf-drums-parse-address
(buffer-substring beg (point)))
(error nil))))
- (if address (push address pairs))
+ (when (or (consp address)
+ (and (stringp address) (< 0 (length address))))
+ (push address pairs))
(forward-char 1)
(setq beg (point)))
- (t
+ ((not (eobp))
(forward-char 1))))
(setq address
(if rawp
@@ -297,7 +314,9 @@ a list of address strings."
(ietf-drums-parse-address
(buffer-substring beg (point)))
(error nil))))
- (if address (push address pairs))
+ (when (or (consp address)
+ (and (stringp address) (< 0 (length address))))
+ (push address pairs))
(nreverse pairs)))))
(defun ietf-drums-unfold-fws ()
diff --git a/lisp/mail/mail-extr.el b/lisp/mail/mail-extr.el
index 668cae05521..cfdbc1b2509 100644
--- a/lisp/mail/mail-extr.el
+++ b/lisp/mail/mail-extr.el
@@ -1845,7 +1845,7 @@ place. It affects how `mail-extract-address-components' works."
;; https://en.wikipedia.org/wiki/List_of_Internet_top-level_domains
(defconst mail-extr-all-top-level-domains
- (let ((ob (make-vector 739 0)))
+ (let ((ob (obarray-make 739)))
(mapc
(lambda (x)
(put (intern (downcase (car x)) ob)
diff --git a/lisp/mail/mailabbrev.el b/lisp/mail/mailabbrev.el
index 68d325ea261..c8006294a7d 100644
--- a/lisp/mail/mailabbrev.el
+++ b/lisp/mail/mailabbrev.el
@@ -171,7 +171,7 @@ no aliases, which is represented by this being a table with no entries.)")
;;;###autoload
(defun mail-abbrevs-setup ()
"Initialize use of the `mailabbrev' package."
- (if (and (not (vectorp mail-abbrevs))
+ (if (and (not (obarrayp mail-abbrevs))
(file-exists-p mail-personal-alias-file))
(progn
(setq mail-abbrev-modtime
@@ -196,7 +196,7 @@ no aliases, which is represented by this being a table with no entries.)")
"Read mail aliases from personal mail alias file and set `mail-abbrevs'.
By default this is the file specified by `mail-personal-alias-file'."
(setq file (expand-file-name (or file mail-personal-alias-file)))
- (if (vectorp mail-abbrevs)
+ (if (obarrayp mail-abbrevs)
nil
(setq mail-abbrevs nil)
(define-abbrev-table 'mail-abbrevs '()))
@@ -278,7 +278,7 @@ double-quotes."
;; true, and we do some evil space->comma hacking like /bin/mail does.
(interactive "sDefine mail alias: \nsDefine %s as mail alias for: ")
;; Read the defaults first, if we have not done so.
- (unless (vectorp mail-abbrevs) (build-mail-abbrevs))
+ (unless (obarrayp mail-abbrevs) (build-mail-abbrevs))
;; strip garbage from front and end
(if (string-match "\\`[ \t\n,]+" definition)
(setq definition (substring definition (match-end 0))))
@@ -355,7 +355,7 @@ double-quotes."
(if mail-abbrev-aliases-need-to-be-resolved
(progn
;; (message "Resolving mail aliases...")
- (if (vectorp mail-abbrevs)
+ (if (obarrayp mail-abbrevs)
(mapatoms (function mail-resolve-all-aliases-1) mail-abbrevs))
(setq mail-abbrev-aliases-need-to-be-resolved nil)
;; (message "Resolving mail aliases... done.")
@@ -555,9 +555,9 @@ of a mail alias. The value is set up, buffer-local, when first needed.")
(defun mail-abbrev-insert-alias (&optional alias)
"Prompt for and insert a mail alias."
(interactive (progn
- (if (not (vectorp mail-abbrevs)) (mail-abbrevs-setup))
+ (if (not (obarrayp mail-abbrevs)) (mail-abbrevs-setup))
(list (completing-read "Expand alias: " mail-abbrevs nil t))))
- (if (not (vectorp mail-abbrevs)) (mail-abbrevs-setup))
+ (if (not (obarrayp mail-abbrevs)) (mail-abbrevs-setup))
(insert (or (and alias (symbol-value (intern-soft alias mail-abbrevs))) ""))
(mail-abbrev-expand-hook))
diff --git a/lisp/mail/mailclient.el b/lisp/mail/mailclient.el
index 888554c277e..1233d9ace95 100644
--- a/lisp/mail/mailclient.el
+++ b/lisp/mail/mailclient.el
@@ -111,104 +111,103 @@ The mail client is taken to be the handler of mailto URLs."
(let ((case-fold-search nil)
delimline
(mailbuf (current-buffer)))
- (unwind-protect
- (with-temp-buffer
- (insert-buffer-substring mailbuf)
- ;; Move to header delimiter
- (mail-sendmail-undelimit-header)
- (setq delimline (point-marker))
- (if mail-aliases
- (expand-mail-aliases (point-min) delimline))
- (goto-char (point-min))
- ;; ignore any blank lines in the header
- (while (and (re-search-forward "\n\n\n*" delimline t)
- (< (point) delimline))
- (replace-match "\n"))
- (let ((case-fold-search t)
- (mime-charset-pattern
- (concat
- "^content-type:[ \t]*text/plain;"
- "\\(?:[ \t\n]*\\(?:format\\|delsp\\)=\"?[-a-z0-9]+\"?;\\)*"
- "[ \t\n]*charset=\"?\\([^ \t\n\";]+\\)\"?"))
- coding-system
- character-coding
- ;; Use the external browser function to send the
- ;; message.
- (browse-url-default-handlers nil))
- ;; initialize limiter
- (setq mailclient-delim-static "?")
- ;; construct and call up mailto URL
- (browse-url
+ (with-temp-buffer
+ (insert-buffer-substring mailbuf)
+ ;; Move to header delimiter
+ (mail-sendmail-undelimit-header)
+ (setq delimline (point-marker))
+ (if mail-aliases
+ (expand-mail-aliases (point-min) delimline))
+ (goto-char (point-min))
+ ;; ignore any blank lines in the header
+ (while (and (re-search-forward "\n\n\n*" delimline t)
+ (< (point) delimline))
+ (replace-match "\n"))
+ (let ((case-fold-search t)
+ (mime-charset-pattern
(concat
- (save-excursion
- (narrow-to-region (point-min) delimline)
- ;; We can't send multipart/* messages (i. e. with
- ;; attachments or the like) via this method.
- (when-let ((type (mail-fetch-field "content-type")))
- (when (and (string-match "multipart"
- (car (mail-header-parse-content-type
- type)))
- (not (y-or-n-p "Message with attachments can't be sent via mailclient; continue anyway?")))
- (error "Choose a different `send-mail-function' to send attachments")))
- (goto-char (point-min))
- (setq coding-system
- (if (re-search-forward mime-charset-pattern nil t)
- (coding-system-from-name (match-string 1))
- 'undecided))
- (setq character-coding
- (mail-fetch-field "content-transfer-encoding"))
- (when character-coding
- (setq character-coding (downcase character-coding)))
- (concat
- "mailto:"
- ;; Some of the headers according to RFC 822 (or later).
- (mailclient-gather-addresses "To"
- 'drop-first-name)
- (mailclient-gather-addresses "cc" )
- (mailclient-gather-addresses "bcc" )
- (mailclient-gather-addresses "Resent-To" )
- (mailclient-gather-addresses "Resent-cc" )
- (mailclient-gather-addresses "Resent-bcc" )
- (mailclient-gather-addresses "Reply-To" )
- ;; The From field is not honored for now: it's
- ;; not necessarily configured. The mail client
- ;; knows the user's address(es)
- ;; (mailclient-gather-addresses "From" )
- ;; subject line
- (let ((subj (mail-fetch-field "Subject" nil t)))
- (widen) ;; so we can read the body later on
- (if subj ;; if non-blank
- ;; the mail client will deal with
- ;; warning the user etc.
- (concat (mailclient-url-delim) "subject="
- (mailclient-encode-string-as-url subj))
- ""))))
- ;; body
- (mailclient-url-delim) "body="
- (progn
- (delete-region (point-min) delimline)
- (unless (null character-coding)
- ;; mailto: and clipboard need UTF-8 and cannot deal with
- ;; Content-Transfer-Encoding or Content-Type.
- ;; FIXME: There is code duplication here with rmail.el.
- (set-buffer-multibyte nil)
- (cond
- ((string= character-coding "base64")
- (base64-decode-region (point-min) (point-max)))
- ((string= character-coding "quoted-printable")
- (mail-unquote-printable-region (point-min) (point-max)
- nil nil t))
- (t (error "Unsupported Content-Transfer-Encoding: %s"
- character-coding)))
- (decode-coding-region (point-min) (point-max) coding-system))
- (mailclient-encode-string-as-url
- (if mailclient-place-body-on-clipboard-flag
- (progn
- (clipboard-kill-ring-save (point-min) (point-max))
- (concat
- "*** E-Mail body has been placed on clipboard, "
- "please paste it here! ***"))
- (buffer-string)))))))))))
+ "^content-type:[ \t]*text/plain;"
+ "\\(?:[ \t\n]*\\(?:format\\|delsp\\)=\"?[-a-z0-9]+\"?;\\)*"
+ "[ \t\n]*charset=\"?\\([^ \t\n\";]+\\)\"?"))
+ coding-system
+ character-coding
+ ;; Use the external browser function to send the
+ ;; message.
+ (browse-url-default-handlers nil))
+ ;; initialize limiter
+ (setq mailclient-delim-static "?")
+ ;; construct and call up mailto URL
+ (browse-url
+ (concat
+ (save-excursion
+ (narrow-to-region (point-min) delimline)
+ ;; We can't send multipart/* messages (i. e. with
+ ;; attachments or the like) via this method.
+ (when-let ((type (mail-fetch-field "content-type")))
+ (when (and (string-match "multipart"
+ (car (mail-header-parse-content-type
+ type)))
+ (not (y-or-n-p "Message with attachments can't be sent via mailclient; continue anyway?")))
+ (error "Choose a different `send-mail-function' to send attachments")))
+ (goto-char (point-min))
+ (setq coding-system
+ (if (re-search-forward mime-charset-pattern nil t)
+ (coding-system-from-name (match-string 1))
+ 'undecided))
+ (setq character-coding
+ (mail-fetch-field "content-transfer-encoding"))
+ (when character-coding
+ (setq character-coding (downcase character-coding)))
+ (concat
+ "mailto:"
+ ;; Some of the headers according to RFC 822 (or later).
+ (mailclient-gather-addresses "To"
+ 'drop-first-name)
+ (mailclient-gather-addresses "cc" )
+ (mailclient-gather-addresses "bcc" )
+ (mailclient-gather-addresses "Resent-To" )
+ (mailclient-gather-addresses "Resent-cc" )
+ (mailclient-gather-addresses "Resent-bcc" )
+ (mailclient-gather-addresses "Reply-To" )
+ ;; The From field is not honored for now: it's
+ ;; not necessarily configured. The mail client
+ ;; knows the user's address(es)
+ ;; (mailclient-gather-addresses "From" )
+ ;; subject line
+ (let ((subj (mail-fetch-field "Subject" nil t)))
+ (widen) ;; so we can read the body later on
+ (if subj ;; if non-blank
+ ;; the mail client will deal with
+ ;; warning the user etc.
+ (concat (mailclient-url-delim) "subject="
+ (mailclient-encode-string-as-url subj))
+ ""))))
+ ;; body
+ (mailclient-url-delim) "body="
+ (progn
+ (delete-region (point-min) delimline)
+ (unless (null character-coding)
+ ;; mailto: and clipboard need UTF-8 and cannot deal with
+ ;; Content-Transfer-Encoding or Content-Type.
+ ;; FIXME: There is code duplication here with rmail.el.
+ (set-buffer-multibyte nil)
+ (cond
+ ((string= character-coding "base64")
+ (base64-decode-region (point-min) (point-max)))
+ ((string= character-coding "quoted-printable")
+ (mail-unquote-printable-region (point-min) (point-max)
+ nil nil t))
+ (t (error "Unsupported Content-Transfer-Encoding: %s"
+ character-coding)))
+ (decode-coding-region (point-min) (point-max) coding-system))
+ (mailclient-encode-string-as-url
+ (if mailclient-place-body-on-clipboard-flag
+ (progn
+ (clipboard-kill-ring-save (point-min) (point-max))
+ (concat
+ "*** E-Mail body has been placed on clipboard, "
+ "please paste it here! ***"))
+ (buffer-string))))))))))
(provide 'mailclient)
diff --git a/lisp/mail/rmail.el b/lisp/mail/rmail.el
index 5747091c498..d422383acdf 100644
--- a/lisp/mail/rmail.el
+++ b/lisp/mail/rmail.el
@@ -40,6 +40,7 @@
(require 'mail-utils)
(require 'rfc2047)
(require 'auth-source)
+(require 'rfc6068)
(declare-function compilation--message->loc "compile" (cl-x) t)
(declare-function epa--find-coding-system-for-mime-charset "epa" (mime-charset))
@@ -89,7 +90,6 @@
its character representation and its display representation.")
(defvar deleted-head)
-(defvar font-lock-fontified)
(defvar mail-abbrev-syntax-table)
(defvar mail-abbrevs)
(defvar messages-head)
@@ -263,7 +263,7 @@ Otherwise, look for `movemail' in the directories in
;; assuming it would work.
;; https://lists.gnu.org/r/bug-gnu-emacs/2008-02/msg00087.html
(let ((progname (expand-file-name
- (concat "movemail"
+ (concat movemail-program-name
(if (memq system-type '(ms-dos windows-nt))
".exe")) dir)))
(when (and (not (file-directory-p progname))
@@ -805,8 +805,8 @@ that knows the exact ordering of the \\( \\) subexpressions.")
"\\(" cite-chars "[ \t]*\\)\\)+\\)"
"\\(.*\\)")
(beginning-of-line) (end-of-line)
- (1 font-lock-comment-delimiter-face nil t)
- (5 font-lock-comment-face nil t)))
+ (1 'font-lock-comment-delimiter-face nil t)
+ (5 'font-lock-comment-face nil t)))
'("^\\(X-[a-z0-9-]+\\|In-Reply-To\\|Date\\):.*\\(\n[ \t]+.*\\)*$"
. 'rmail-header-name))))
"Additional expressions to highlight in Rmail mode.")
@@ -815,7 +815,7 @@ that knows the exact ordering of the \\( \\) subexpressions.")
(defun rmail-pop-to-buffer (&rest args)
"Like `pop-to-buffer', but with `split-width-threshold' set to nil."
(let (split-width-threshold)
- (apply 'pop-to-buffer args)))
+ (apply #'pop-to-buffer args)))
;; Perform BODY in the summary buffer
;; in such a way that its cursor is properly updated in its own window.
@@ -1008,66 +1008,66 @@ The buffer is expected to be narrowed to just the header of the message."
(defvar rmail-mode-map
(let ((map (make-keymap)))
(suppress-keymap map)
- (define-key map "a" 'rmail-add-label)
- (define-key map "b" 'rmail-bury)
- (define-key map "c" 'rmail-continue)
- (define-key map "d" 'rmail-delete-forward)
- (define-key map "\C-d" 'rmail-delete-backward)
- (define-key map "e" 'rmail-edit-current-message)
+ (define-key map "a" #'rmail-add-label)
+ (define-key map "b" #'rmail-bury)
+ (define-key map "c" #'rmail-continue)
+ (define-key map "d" #'rmail-delete-forward)
+ (define-key map "\C-d" #'rmail-delete-backward)
+ (define-key map "e" #'rmail-edit-current-message)
;; If you change this, change the rmail-resend menu-item's :keys.
- (define-key map "f" 'rmail-forward)
- (define-key map "g" 'rmail-get-new-mail)
- (define-key map "h" 'rmail-summary)
- (define-key map "i" 'rmail-input)
- (define-key map "j" 'rmail-show-message)
- (define-key map "k" 'rmail-kill-label)
- (define-key map "l" 'rmail-summary-by-labels)
- (define-key map "\e\C-h" 'rmail-summary)
- (define-key map "\e\C-l" 'rmail-summary-by-labels)
- (define-key map "\e\C-r" 'rmail-summary-by-recipients)
- (define-key map "\e\C-s" 'rmail-summary-by-regexp)
- (define-key map "\e\C-f" 'rmail-summary-by-senders)
- (define-key map "\e\C-t" 'rmail-summary-by-topic)
- (define-key map "m" 'rmail-mail)
- (define-key map "\em" 'rmail-retry-failure)
- (define-key map "n" 'rmail-next-undeleted-message)
- (define-key map "\en" 'rmail-next-message)
- (define-key map "\e\C-n" 'rmail-next-labeled-message)
- (define-key map "o" 'rmail-output)
- (define-key map "\C-o" 'rmail-output-as-seen)
- (define-key map "p" 'rmail-previous-undeleted-message)
- (define-key map "\ep" 'rmail-previous-message)
- (define-key map "\e\C-p" 'rmail-previous-labeled-message)
- (define-key map "q" 'rmail-quit)
- (define-key map "r" 'rmail-reply)
+ (define-key map "f" #'rmail-forward)
+ (define-key map "g" #'rmail-get-new-mail)
+ (define-key map "h" #'rmail-summary)
+ (define-key map "i" #'rmail-input)
+ (define-key map "j" #'rmail-show-message)
+ (define-key map "k" #'rmail-kill-label)
+ (define-key map "l" #'rmail-summary-by-labels)
+ (define-key map "\e\C-h" #'rmail-summary)
+ (define-key map "\e\C-l" #'rmail-summary-by-labels)
+ (define-key map "\e\C-r" #'rmail-summary-by-recipients)
+ (define-key map "\e\C-s" #'rmail-summary-by-regexp)
+ (define-key map "\e\C-f" #'rmail-summary-by-senders)
+ (define-key map "\e\C-t" #'rmail-summary-by-topic)
+ (define-key map "m" #'rmail-mail)
+ (define-key map "\em" #'rmail-retry-failure)
+ (define-key map "n" #'rmail-next-undeleted-message)
+ (define-key map "\en" #'rmail-next-message)
+ (define-key map "\e\C-n" #'rmail-next-labeled-message)
+ (define-key map "o" #'rmail-output)
+ (define-key map "\C-o" #'rmail-output-as-seen)
+ (define-key map "p" #'rmail-previous-undeleted-message)
+ (define-key map "\ep" #'rmail-previous-message)
+ (define-key map "\e\C-p" #'rmail-previous-labeled-message)
+ (define-key map "q" #'rmail-quit)
+ (define-key map "r" #'rmail-reply)
;; I find I can't live without the default M-r command -- rms.
- ;; (define-key rmail-mode-map "\er" 'rmail-search-backwards)
- (define-key map "s" 'rmail-expunge-and-save)
- (define-key map "\es" 'rmail-search)
- (define-key map "t" 'rmail-toggle-header)
- (define-key map "u" 'rmail-undelete-previous-message)
- (define-key map "v" 'rmail-mime)
- (define-key map "w" 'rmail-output-body-to-file)
- (define-key map "\C-c\C-w" 'rmail-widen)
- (define-key map "x" 'rmail-expunge)
- (define-key map "." 'rmail-beginning-of-message)
- (define-key map "/" 'rmail-end-of-message)
- (define-key map "<" 'rmail-first-message)
- (define-key map ">" 'rmail-last-message)
- (define-key map " " 'scroll-up-command)
- (define-key map [?\S-\ ] 'scroll-down-command)
- (define-key map "\177" 'scroll-down-command)
- (define-key map "?" 'describe-mode)
- (define-key map "\C-c\C-d" 'rmail-epa-decrypt)
- (define-key map "\C-c\C-s\C-d" 'rmail-sort-by-date)
- (define-key map "\C-c\C-s\C-s" 'rmail-sort-by-subject)
- (define-key map "\C-c\C-s\C-a" 'rmail-sort-by-author)
- (define-key map "\C-c\C-s\C-r" 'rmail-sort-by-recipient)
- (define-key map "\C-c\C-s\C-c" 'rmail-sort-by-correspondent)
- (define-key map "\C-c\C-s\C-l" 'rmail-sort-by-lines)
- (define-key map "\C-c\C-s\C-k" 'rmail-sort-by-labels)
- (define-key map "\C-c\C-n" 'rmail-next-same-subject)
- (define-key map "\C-c\C-p" 'rmail-previous-same-subject)
+ ;; (define-key rmail-mode-map "\er" #'rmail-search-backwards)
+ (define-key map "s" #'rmail-expunge-and-save)
+ (define-key map "\es" #'rmail-search)
+ (define-key map "t" #'rmail-toggle-header)
+ (define-key map "u" #'rmail-undelete-previous-message)
+ (define-key map "v" #'rmail-mime)
+ (define-key map "w" #'rmail-output-body-to-file)
+ (define-key map "\C-c\C-w" #'rmail-widen)
+ (define-key map "x" #'rmail-expunge)
+ (define-key map "." #'rmail-beginning-of-message)
+ (define-key map "/" #'rmail-end-of-message)
+ (define-key map "<" #'rmail-first-message)
+ (define-key map ">" #'rmail-last-message)
+ (define-key map " " #'scroll-up-command)
+ (define-key map [?\S-\ ] #'scroll-down-command)
+ (define-key map "\177" #'scroll-down-command)
+ (define-key map "?" #'describe-mode)
+ (define-key map "\C-c\C-d" #'rmail-epa-decrypt)
+ (define-key map "\C-c\C-s\C-d" #'rmail-sort-by-date)
+ (define-key map "\C-c\C-s\C-s" #'rmail-sort-by-subject)
+ (define-key map "\C-c\C-s\C-a" #'rmail-sort-by-author)
+ (define-key map "\C-c\C-s\C-r" #'rmail-sort-by-recipient)
+ (define-key map "\C-c\C-s\C-c" #'rmail-sort-by-correspondent)
+ (define-key map "\C-c\C-s\C-l" #'rmail-sort-by-lines)
+ (define-key map "\C-c\C-s\C-k" #'rmail-sort-by-labels)
+ (define-key map "\C-c\C-n" #'rmail-next-same-subject)
+ (define-key map "\C-c\C-p" #'rmail-previous-same-subject)
(define-key map [menu-bar] (make-sparse-keymap))
@@ -1120,10 +1120,36 @@ The buffer is expected to be narrowed to just the header of the message."
(define-key map [menu-bar mail]
(cons "Mail" (make-sparse-keymap "Mail")))
+ (define-key map [menu-bar mail mailing-list]
+ (cons "Mailing List" (make-sparse-keymap "Mailing List")))
+
+ (define-key map [menu-bar mail mailing-list list-help]
+ '(menu-item "Mailing List Help" rmail-mailing-list-help
+ :enable (rmail-get-header "List-Help")
+ :help "Compose email requesting help about this mailing list"))
+
+ (define-key map [menu-bar mail mailing-list list-archive]
+ '(menu-item "Mailing List Archive" rmail-mailing-list-archive
+ :enable (rmail-get-header "List-Archive")
+ :help "Browse the archive of this mailing list"))
+
+ (define-key map [menu-bar mail mailing-list list-unsubscribe]
+ '(menu-item "Unsubscribe From List" rmail-mailing-list-unsubscribe
+ :enable (rmail-get-header "List-Unsubscribe")
+ :help "Compose email to unsubscribe from this mailing list"))
+
+ (define-key map [menu-bar mail mailing-list list-post]
+ '(menu-item "Post To List" rmail-mailing-list-post
+ :enable (rmail-get-header "List-Post")
+ :help "Compose email to post to this mailing list"))
+
+ (define-key map [menu-bar mail lambda1]
+ '("----"))
+
(define-key map [menu-bar mail rmail-get-new-mail]
'("Get New Mail" . rmail-get-new-mail))
- (define-key map [menu-bar mail lambda]
+ (define-key map [menu-bar mail lambda2]
'("----"))
(define-key map [menu-bar mail continue]
@@ -1318,9 +1344,9 @@ Instead, these commands are available:
(setq local-abbrev-table text-mode-abbrev-table)
;; Functions to support buffer swapping:
(add-hook 'write-region-annotate-functions
- 'rmail-write-region-annotate nil t)
- (add-hook 'kill-buffer-hook 'rmail-mode-kill-buffer-hook nil t)
- (add-hook 'change-major-mode-hook 'rmail-change-major-mode-hook nil t))
+ #'rmail-write-region-annotate nil t)
+ (add-hook 'kill-buffer-hook #'rmail-mode-kill-buffer-hook nil t)
+ (add-hook 'change-major-mode-hook #'rmail-change-major-mode-hook nil t))
(defun rmail-generate-viewer-buffer ()
"Return a reusable buffer suitable for viewing messages.
@@ -1337,7 +1363,7 @@ Create the buffer if necessary."
(file-name-nondirectory
(or buffer-file-name (buffer-name)))))))
(with-current-buffer newbuf
- (add-hook 'kill-buffer-hook 'rmail-view-buffer-kill-buffer-hook nil t))
+ (add-hook 'kill-buffer-hook #'rmail-view-buffer-kill-buffer-hook nil t))
newbuf)))
(defun rmail-swap-buffers ()
@@ -1453,7 +1479,7 @@ If so restore the actual mbox message collection."
;; Don't turn off auto-saving based on the size of the buffer
;; because that code does not understand buffer-swapping.
(setq-local auto-save-include-big-deletions t)
- (setq-local revert-buffer-function 'rmail-revert)
+ (setq-local revert-buffer-function #'rmail-revert)
(setq-local font-lock-defaults
'(rmail-font-lock-keywords
t t nil nil
@@ -1464,7 +1490,7 @@ If so restore the actual mbox message collection."
(setq-local file-precious-flag t)
(setq-local desktop-save-buffer t)
(setq-local save-buffer-coding-system 'no-conversion)
- (setq next-error-move-function 'rmail-next-error-move))
+ (setq next-error-move-function #'rmail-next-error-move))
;; Handle M-x revert-buffer done in an rmail-mode buffer.
(defun rmail-revert (arg noconfirm)
@@ -1580,7 +1606,7 @@ The duplicate copy goes into the Rmail file just after the original."
(files (directory-files start t rmail-secondary-file-regexp)))
;; Sort here instead of in directory-files
;; because this list is usually much shorter.
- (sort files 'string<))))
+ (sort files #'string<))))
(defun rmail-list-to-menu (menu-name l action &optional full-name)
(let ((menu (make-sparse-keymap menu-name))
@@ -1989,7 +2015,9 @@ Value is the size of the newly read mail after conversion."
(buffer-disable-undo errors)
(let ((args
(append
- (list (or rmail-movemail-program "movemail") nil errors nil)
+ (list (or rmail-movemail-program
+ movemail-program-name)
+ nil errors nil)
(if rmail-preserve-inbox
(list "-p")
nil)
@@ -1998,7 +2026,7 @@ Value is the size of the newly read mail after conversion."
rmail-movemail-flags)
(list file tofile)
(if password (list password) nil))))
- (apply 'call-process args))
+ (apply #'call-process args))
(if (not (buffer-modified-p errors))
;; No output => movemail won
nil
@@ -2285,7 +2313,7 @@ significant attribute change was made."
(insert value)))
;; Otherwise add a header line to record the attributes and set
;; all but this one to no.
- (let ((header-value "--------"))
+ (let ((header-value (copy-sequence "--------")))
(aset header-value attr value)
(goto-char (if limit (1- limit) (point-max)))
(setq altered (/= value ?-))
@@ -2490,7 +2518,7 @@ Output a helpful message unless NOMSG is non-nil."
;; which will never be used.
(push nil messages-head)
(push ?0 deleted-head)
- (setq rmail-message-vector (apply 'vector messages-head)
+ (setq rmail-message-vector (apply #'vector messages-head)
rmail-deleted-vector (concat deleted-head))
(setq rmail-summary-vector (make-vector rmail-total-messages nil)
@@ -3577,10 +3605,10 @@ If `rmail-confirm-expunge' is non-nil, ask user to confirm."
(cons (aref messages number) nil)))
(setq rmail-current-message new-message-number
rmail-total-messages counter
- rmail-message-vector (apply 'vector messages-head)
+ rmail-message-vector (apply #'vector messages-head)
rmail-deleted-vector (make-string (1+ counter) ?\s)
rmail-summary-vector (vconcat (nreverse new-summary))
- rmail-msgref-vector (apply 'vector (nreverse new-msgref))
+ rmail-msgref-vector (apply #'vector (nreverse new-msgref))
win t)))
(message "Expunging deleted messages...done")
(if (not win)
@@ -3863,7 +3891,7 @@ use \\[mail-yank-original] to yank the original message into it."
(if (or references message-id)
(list (cons "References" (if references
(concat
- (mapconcat 'identity references " ")
+ (mapconcat #'identity references " ")
" " message-id)
message-id)))))))
@@ -4061,26 +4089,24 @@ typically for purposes of moderating a list."
(insert "Resent-Bcc: " (user-login-name) "\n"))
(insert "Resent-To: " (if (stringp address)
address
- (mapconcat 'identity address ",\n\t"))
+ (mapconcat #'identity address ",\n\t"))
"\n")
;; Expand abbrevs in the recipients.
(save-excursion
(if (featurep 'mailabbrev)
(let ((end (point-marker))
- (local-abbrev-table mail-abbrevs)
- (old-syntax-table (syntax-table)))
- (if (and (not (vectorp mail-abbrevs))
+ (local-abbrev-table mail-abbrevs))
+ (if (and (not (obarrayp mail-abbrevs))
(file-exists-p mail-personal-alias-file))
(build-mail-abbrevs))
(unless mail-abbrev-syntax-table
(mail-abbrev-make-syntax-table))
- (set-syntax-table mail-abbrev-syntax-table)
- (goto-char before)
- (while (and (< (point) end)
- (progn (forward-word-strictly 1)
- (<= (point) end)))
- (expand-abbrev))
- (set-syntax-table old-syntax-table))
+ (with-syntax-table mail-abbrev-syntax-table
+ (goto-char before)
+ (while (and (< (point) end)
+ (progn (forward-word-strictly 1)
+ (<= (point) end)))
+ (expand-abbrev))))
(expand-mail-aliases before (point)))))
;;>> Set up comment, if any.
(if (and (sequencep comment) (not (zerop (length comment))))
@@ -4307,7 +4333,7 @@ This has an effect only if a summary buffer exists."
(defun rmail-fontify-buffer-function ()
;; This function's symbol is bound to font-lock-fontify-buffer-function.
- (add-hook 'rmail-show-message-hook 'rmail-fontify-message nil t)
+ (add-hook 'rmail-show-message-hook #'rmail-fontify-message nil t)
;; If we're already showing a message, fontify it now.
(if rmail-current-message (rmail-fontify-message))
;; Prevent Font Lock mode from kicking in.
@@ -4318,7 +4344,7 @@ This has an effect only if a summary buffer exists."
(with-silent-modifications
(save-restriction
(widen)
- (remove-hook 'rmail-show-message-hook 'rmail-fontify-message t)
+ (remove-hook 'rmail-show-message-hook #'rmail-fontify-message t)
(remove-text-properties (point-min) (point-max) '(rmail-fontified nil))
(font-lock-default-unfontify-buffer))))
@@ -4353,11 +4379,12 @@ browsing, and moving of messages."
"Install those variables used by speedbar to enhance rmail."
(unless rmail-speedbar-key-map
(setq rmail-speedbar-key-map (speedbar-make-specialized-keymap))
- (define-key rmail-speedbar-key-map "e" 'speedbar-edit-line)
- (define-key rmail-speedbar-key-map "r" 'speedbar-edit-line)
- (define-key rmail-speedbar-key-map "\C-m" 'speedbar-edit-line)
+ (declare-function speedbar-edit-line "speedbar")
+ (define-key rmail-speedbar-key-map "e" #'speedbar-edit-line)
+ (define-key rmail-speedbar-key-map "r" #'speedbar-edit-line)
+ (define-key rmail-speedbar-key-map "\C-m" #'speedbar-edit-line)
(define-key rmail-speedbar-key-map "M"
- 'rmail-speedbar-move-message-to-folder-on-line)))
+ #'rmail-speedbar-move-message-to-folder-on-line)))
;; Mouse-3.
(defvar rmail-speedbar-menu-items
@@ -4582,6 +4609,19 @@ Argument MIME is non-nil if this is a mime message."
(current-buffer))))
(error nil))
+ ;; Decode any base64-encoded material in what we just decrypted.
+ (rmail-epa-decode armor-start after-end)
+
+ ;; If this is in a MIME part, convert CRLF into just LF (newline)
+ (when mime
+ (save-restriction
+ (narrow-to-region armor-start (- (point-max) after-end))
+ (goto-char (point-min))
+ (let ((inhibit-read-only t))
+ (while (search-forward "\r\n" nil t)
+ (delete-region (- (point) 2) (- (point) 1)))))
+ )
+
(list armor-start (- (point-max) after-end) mime
armor-end-regexp
(buffer-substring armor-start (- (point-max) after-end)))))
@@ -4624,11 +4664,34 @@ Argument MIME is non-nil if this is a mime message."
"> ")
(push (rmail-epa-decrypt-1 mime) decrypts))))
- ;; Decode any base64-encoded mime sections.
- (rmail-epa-decode)
-
(when (and decrypts (rmail-buffers-swapped-p))
- (when (y-or-n-p "Replace the original message? ")
+ (if (not (y-or-n-p "Replace the original message? "))
+ ;; User wants to decrypt only temporarily.
+ ;; Find, in the view buffer, the armors
+ ;; that we made decrypts for, and replace each one
+ ;; with its decrypt. In a mime part, replace CRLF with NL.
+ (dolist (d decrypts)
+ (if (re-search-forward "-----BEGIN PGP MESSAGE-----$" nil t)
+ (let (armor-start armor-end armor-end-regexp)
+ (setq armor-start (match-beginning 0)
+ armor-end-regexp (nth 3 d)
+ armor-end (re-search-forward
+ armor-end-regexp
+ nil t))
+
+ ;; Found as expected -- now replace it with the decrypt.
+ (when armor-end
+ (if (null (nth 2 d))
+ nil
+ ;; In a mime part --
+ ;; replace CRLF with NL in it.
+ (save-restriction
+ (narrow-to-region armor-start armor-end)
+ (goto-char (point-min))
+ (while (search-forward "\r\n" nil t)
+ (delete-region (- (point) 2) (- (point) 1))))))
+ )))
+ ;; User wants to decrypt the message permanently.
(when (eq major-mode 'rmail-mode)
(rmail-add-label "decrypt"))
(setq decrypts (nreverse decrypts))
@@ -4691,12 +4754,14 @@ Argument MIME is non-nil if this is a mime message."
(unless decrypts
(error "Nothing to decrypt")))))
-;; Decode all base64-encoded mime sections, so that this change
-;; is made in the Rmail file, not just in the viewing buffer.
-(defun rmail-epa-decode ()
+;; Decode all base64-encoded mime sections from BEG to (Z - BACK-FROM-END),
+;; so that we save the decoding permanently in the Rmail buffer
+;; if we permanently save the decryption.
+(defun rmail-epa-decode (beg back-from-end)
(save-excursion
- (goto-char (point-min))
- (while (re-search-forward "--------------[0-9a-zA-Z]+\n" nil t)
+ (goto-char beg)
+ (while (re-search-forward "--------------[0-9a-zA-Z]+\n"
+ (- (point-max) back-from-end) t)
;; The ending delimiter is a start delimiter if another section follows.
;; Otherwise it is an end delimiter, with -- affixed.
(let ((delim (concat (substring (match-string 0) 0 -1) "\\(\\|--\\)\n")))
@@ -4763,8 +4828,72 @@ Content-Transfer-Encoding: base64\n")
(with-current-buffer
(if (rmail-buffers-swapped-p) rmail-buffer rmail-view-buffer)
(setq buffer-file-coding-system rmail-message-encoding))))
-(add-hook 'after-save-hook 'rmail-after-save-hook)
+;; FIXME: Don't do it globally!!
+(add-hook 'after-save-hook #'rmail-after-save-hook)
+
+;;; Mailing list support
+(defun rmail--mailing-list-message (which)
+ "Send a message to mailing list whose purpose is identified by WHICH.
+WHICH is a symbol, one of `help', `unsubscribe', or `post'."
+ (let ((header
+ (cond ((eq which 'help) "List-Help")
+ ((eq which 'unsubscribe) "List-Unsubscribe")
+ ((eq which 'post) "List-Post")))
+ (msg
+ (cond ((eq which 'post)
+ "Write Subject and body, then type \\[%s] to send the message.")
+ (t
+ "Type \\[%s] to send the message.")))
+ address header-list to subject)
+ (setq address (rmail-get-header header))
+ (cond ((and address (string-match "<\\(mailto:[^>]*\\)>" address))
+ (setq address (match-string 1 address))
+ (setq header-list (rfc6068-parse-mailto-url address)
+ to (cdr (assoc-string "To" header-list t))
+ subject (or (cdr (assoc-string "Subject" header-list t)) ""))
+ (rmail-start-mail nil to subject nil nil rmail-buffer)
+ (message (substitute-command-keys
+ (format msg (get mail-user-agent 'sendfunc)))))
+ (t
+ (user-error "This message does not specify \"%s\" address"
+ header)))))
+
+(defun rmail-mailing-list-help ()
+ "Send Help request to the mailing list which delivered the current message.
+This command starts composing an email message to the mailing list
+requesting help about the list. When the message is ready, send it
+as usual, via your MUA's send-email command."
+ (interactive nil rmail-mode)
+ (rmail--mailing-list-message 'help))
+
+(defun rmail-mailing-list-post ()
+ "Post a message to the mailing list which delivered the current message.
+This command starts composing an email message to the mailing list.
+Fill the Subject and the body of the message. When the message is
+ready, send it as usual, via your MUA's send-email command."
+ (interactive nil rmail-mode)
+ (rmail--mailing-list-message 'post))
+
+(defun rmail-mailing-list-unsubscribe ()
+ "Send unsubscribe request to the mailing list which delivered current message.
+This command starts composing an email message to the mailing list
+requesting to unsubscribe you from the list. When the message is
+ready, send it as usual, via your MUA's send-email command."
+ (interactive nil rmail-mode)
+ (rmail--mailing-list-message 'unsubscribe))
+
+(defun rmail-mailing-list-archive ()
+ "Browse the archive of the mailing list which delivered the current message."
+ (interactive nil rmail-mode)
+ (let* ((header (rmail-get-header "List-Archive"))
+ (url (and (stringp header)
+ (string-match " *<\\([^>]*\\)>" header)
+ (match-string 1 header))))
+ (if url
+ (browse-url url)
+ (user-error
+ "This message does not specify a valid \"List-Archive\" URL"))))
(provide 'rmail)
diff --git a/lisp/mail/rmailkwd.el b/lisp/mail/rmailkwd.el
index d9c4cb8cfee..a13c42edb5c 100644
--- a/lisp/mail/rmailkwd.el
+++ b/lisp/mail/rmailkwd.el
@@ -31,7 +31,7 @@
;; Global to all RMAIL buffers. It exists for the sake of completion.
;; It is better to use strings with the label functions and let them
;; worry about making the label.
-(defvar rmail-label-obarray (make-vector 47 0)
+(defvar rmail-label-obarray (obarray-make 47)
"Obarray of labels used by Rmail.
`rmail-read-label' uses this to offer completion.")
diff --git a/lisp/mail/rmailout.el b/lisp/mail/rmailout.el
index 654e38f3bad..1aa430c18c9 100644
--- a/lisp/mail/rmailout.el
+++ b/lisp/mail/rmailout.el
@@ -327,15 +327,14 @@ Replaces the From line with a \"Mail-from\" header. Adds \"Date\" and
"Date: \\2, \\4 \\3 \\9 \\5 "
;; The timezone could be matched by group 7 or group 10.
- ;; If neither of them matched, assume EST, since only
- ;; Easterners would be so sloppy.
+ ;; If neither matched, use "-0000" for an unknown zone.
;; It's a shame the substitution can't use "\\10".
(cond
((/= (match-beginning 7) (match-end 7)) "\\7")
((/= (match-beginning 10) (match-end 10))
(buffer-substring (match-beginning 10)
(match-end 10)))
- (t "EST"))
+ (t "-0000"))
"\n"))
;; Keep and reformat the sender if we don't
;; have a From: field.
diff --git a/lisp/mail/rmailsum.el b/lisp/mail/rmailsum.el
index cccd702dae2..48c5cb70b33 100644
--- a/lisp/mail/rmailsum.el
+++ b/lisp/mail/rmailsum.el
@@ -52,7 +52,7 @@ Setting this option to nil might speed up the generation of summaries."
(defcustom rmail-summary-progressively-narrow nil
"Non-nil means progressively narrow the set of messages produced by summary.
-This allows to apply the summary criteria on top one another,
+This enables you to apply the summary criteria on top one another,
thus progressively narrowing the selection of the messages produced
by each summary criteria.
For example, applying `rmail-summary-by-senders' on top
@@ -742,13 +742,14 @@ message."
(setq rmail-summary-buffer nil)))
(save-excursion
(let ((rbuf (current-buffer))
- (total rmail-total-messages))
+ (total 0))
(set-buffer sumbuf)
;; Set up the summary buffer's contents.
(let ((buffer-read-only nil))
(erase-buffer)
(while summary-msgs
(princ (cdr (car summary-msgs)) sumbuf)
+ (setq total (1+ total))
(setq summary-msgs (cdr summary-msgs)))
(goto-char (point-min)))
;; Set up the rest of its state and local variables.
diff --git a/lisp/mail/sendmail.el b/lisp/mail/sendmail.el
index 0c0fe6d9f5b..d54fb51dfd3 100644
--- a/lisp/mail/sendmail.el
+++ b/lisp/mail/sendmail.el
@@ -151,11 +151,11 @@ not a valid RFC 822 (or later) header or continuation line,
that matches the variable `mail-header-separator'.
This is used by the default mail-sending commands. See also
`message-send-mail-function' for use with the Message package."
- :type '(radio (function-item sendmail-send-it :tag "Use Sendmail package")
- (function-item sendmail-query-once :tag "Query the user")
- (function-item smtpmail-send-it :tag "Use SMTPmail package")
- (function-item feedmail-send-it :tag "Use Feedmail package")
- (function-item mailclient-send-it :tag "Use Mailclient package")
+ :type '(radio (function-item sendmail-send-it)
+ (function-item sendmail-query-once)
+ (function-item :doc "Use SMTPmail package." smtpmail-send-it)
+ (function-item feedmail-send-it)
+ (function-item mailclient-send-it)
function)
:version "24.1")
@@ -269,7 +269,6 @@ The default value matches citations like `foo-bar>' plus whitespace."
(defvar mail-abbrevs-loaded nil)
(defvar mail-mode-map
(let ((map (make-sparse-keymap)))
- (define-key map "\M-\t" 'completion-at-point)
(define-key map "\C-c?" 'describe-mode)
(define-key map "\C-c\C-f\C-t" 'mail-to)
(define-key map "\C-c\C-f\C-b" 'mail-bcc)
diff --git a/lisp/mail/smtpmail.el b/lisp/mail/smtpmail.el
index b85a39b030b..ed21e777b28 100644
--- a/lisp/mail/smtpmail.el
+++ b/lisp/mail/smtpmail.el
@@ -1057,8 +1057,8 @@ Returns an error if the server cannot be contacted."
(while data-continue
(with-current-buffer buffer
(progress-reporter-update pr (point))
- (setq sending-data (buffer-substring (line-beginning-position)
- (line-end-position)))
+ (setq sending-data (buffer-substring-no-properties (line-beginning-position)
+ (line-end-position)))
(end-of-line 2)
(setq data-continue (not (eobp))))
(smtpmail-send-data-1 process sending-data))
@@ -1068,52 +1068,51 @@ Returns an error if the server cannot be contacted."
(defun smtpmail-deduce-address-list (smtpmail-text-buffer header-start header-end)
"Get address list suitable for smtp RCPT TO: <address>."
- (unwind-protect
- (with-current-buffer smtpmail-address-buffer
- (erase-buffer)
- (let ((case-fold-search t)
- (simple-address-list "")
- this-line
- this-line-end
- addr-regexp)
- (insert-buffer-substring smtpmail-text-buffer header-start header-end)
- (goto-char (point-min))
- ;; RESENT-* fields should stop processing of regular fields.
- (save-excursion
- (setq addr-regexp
- (if (re-search-forward "^Resent-\\(To\\|Cc\\|Bcc\\):"
- header-end t)
- "^Resent-\\(To\\|Cc\\|Bcc\\):"
- "^\\(To:\\|Cc:\\|Bcc:\\)")))
-
- (while (re-search-forward addr-regexp header-end t)
- (replace-match "")
- (setq this-line (match-beginning 0))
- (forward-line 1)
- ;; get any continuation lines
- (while (and (looking-at "^[ \t]+") (< (point) header-end))
- (forward-line 1))
- (setq this-line-end (point-marker))
- (setq simple-address-list
- (concat simple-address-list " "
- (mail-strip-quoted-names (buffer-substring this-line this-line-end)))))
- (erase-buffer)
- (insert " " simple-address-list "\n")
- (subst-char-in-region (point-min) (point-max) 10 ? t) ; newline --> blank
- (subst-char-in-region (point-min) (point-max) ?, ? t) ; comma --> blank
- (subst-char-in-region (point-min) (point-max) 9 ? t) ; tab --> blank
+ (with-current-buffer smtpmail-address-buffer
+ (erase-buffer)
+ (let ((case-fold-search t)
+ (simple-address-list "")
+ this-line
+ this-line-end
+ addr-regexp)
+ (insert-buffer-substring smtpmail-text-buffer header-start header-end)
+ (goto-char (point-min))
+ ;; RESENT-* fields should stop processing of regular fields.
+ (save-excursion
+ (setq addr-regexp
+ (if (re-search-forward "^Resent-\\(To\\|Cc\\|Bcc\\):"
+ header-end t)
+ "^Resent-\\(To\\|Cc\\|Bcc\\):"
+ "^\\(To:\\|Cc:\\|Bcc:\\)")))
+
+ (while (re-search-forward addr-regexp header-end t)
+ (replace-match "")
+ (setq this-line (match-beginning 0))
+ (forward-line 1)
+ ;; get any continuation lines
+ (while (and (looking-at "^[ \t]+") (< (point) header-end))
+ (forward-line 1))
+ (setq this-line-end (point-marker))
+ (setq simple-address-list
+ (concat simple-address-list " "
+ (mail-strip-quoted-names (buffer-substring this-line this-line-end)))))
+ (erase-buffer)
+ (insert " " simple-address-list "\n")
+ (subst-char-in-region (point-min) (point-max) 10 ? t) ; newline --> blank
+ (subst-char-in-region (point-min) (point-max) ?, ? t) ; comma --> blank
+ (subst-char-in-region (point-min) (point-max) 9 ? t) ; tab --> blank
- (goto-char (point-min))
- ;; tidiness in case hook is not robust when it looks at this
- (while (re-search-forward "[ \t]+" header-end t) (replace-match " "))
+ (goto-char (point-min))
+ ;; tidiness in case hook is not robust when it looks at this
+ (while (re-search-forward "[ \t]+" header-end t) (replace-match " "))
- (goto-char (point-min))
- (let (recipient-address-list)
- (while (re-search-forward " \\([^ ]+\\) " (point-max) t)
- (backward-char 1)
- (setq recipient-address-list (cons (buffer-substring (match-beginning 1) (match-end 1))
- recipient-address-list)))
- (setq smtpmail-recipient-address-list recipient-address-list))))))
+ (goto-char (point-min))
+ (let (recipient-address-list)
+ (while (re-search-forward " \\([^ ]+\\) " (point-max) t)
+ (backward-char 1)
+ (setq recipient-address-list (cons (buffer-substring (match-beginning 1) (match-end 1))
+ recipient-address-list)))
+ (setq smtpmail-recipient-address-list recipient-address-list)))))
(defun smtpmail-do-bcc (header-end)
"Delete [Resent-]Bcc: and their continuation lines from the header area.
diff --git a/lisp/mail/supercite.el b/lisp/mail/supercite.el
index 38a3d09e403..9104feb6219 100644
--- a/lisp/mail/supercite.el
+++ b/lisp/mail/supercite.el
@@ -620,9 +620,6 @@ the list should be unique."
((setq elt (rassq char alist))
(message "%s%s" p (car elt))
(setq p (cdr elt)))
- ((if (fboundp 'button-release-event-p)
- (button-release-event-p event)) ; ignore them
- nil)
(t
(message "%s%s" p (single-key-description event))
(ding)
@@ -820,7 +817,7 @@ If there was no mail header with FIELD as its key, return the value of
(defun sc-mail-field-query (arg)
"View the value of a mail field.
-With `\\[universal-argument]', prompts for action on mail field.
+With \\[universal-argument], prompts for action on mail field.
Action can be one of: View, Modify, Add, or Delete."
(interactive "P")
(let* ((alist '(("view" . ?v) ("modify" . ?m) ("add" . ?a) ("delete" . ?d)))
@@ -1713,7 +1710,7 @@ Numeric ARG indicates which header style from `sc-rewrite-header-list'
to use when rewriting the header. No supplied ARG indicates use of
`sc-preferred-header-style'.
-With just `\\[universal-argument]', electric reference insert mode is
+With just \\[universal-argument], electric reference insert mode is
entered, regardless of the value of `sc-electric-references-p'. See
`sc-electric-mode' for more information."
(interactive "P")
@@ -1933,7 +1930,7 @@ With numeric ARG, inserts that many new lines."
(defun sc-insert-citation (arg)
"Insert citation string at beginning of current line if not already cited.
-With `\\[universal-argument]' insert citation even if line is already
+With \\[universal-argument] insert citation even if line is already
cited."
(interactive "P")
(save-excursion
diff --git a/lisp/mail/uudecode.el b/lisp/mail/uudecode.el
index efe49f6005f..dd717a161d1 100644
--- a/lisp/mail/uudecode.el
+++ b/lisp/mail/uudecode.el
@@ -40,7 +40,7 @@ input and write the converted data to its standard output."
:type '(repeat string))
(defcustom uudecode-use-external
- (executable-find uudecode-decoder-program)
+ (not (not (executable-find uudecode-decoder-program)))
"Use external uudecode program."
:version "22.1"
:type 'boolean)
diff --git a/lisp/mail/yenc.el b/lisp/mail/yenc.el
index 1e7e0098a25..e7aac0a10d8 100644
--- a/lisp/mail/yenc.el
+++ b/lisp/mail/yenc.el
@@ -111,8 +111,8 @@
(message "Warning: Size mismatch while decoding."))
(goto-char start)
(delete-region start end)
- (insert-buffer-substring work-buffer))))
- (and work-buffer (kill-buffer work-buffer))))))
+ (insert-buffer-substring work-buffer)))))
+ (and work-buffer (kill-buffer work-buffer)))))
;;;###autoload
(defun yenc-extract-filename ()
diff --git a/lisp/man.el b/lisp/man.el
index 25dbd83600f..d96396483d3 100644
--- a/lisp/man.el
+++ b/lisp/man.el
@@ -97,6 +97,21 @@
:group 'external
:group 'help)
+(defcustom Man-prefer-synchronous-call nil
+ "Whether to call the Un*x \"man\" program synchronously.
+When this is non-nil, call the \"man\" program synchronously
+(rather than asynchronously, which is the default behavior)."
+ :type 'boolean
+ :group 'man
+ :version "30.1")
+
+(defcustom Man-support-remote-systems nil
+ "Whether to call the Un*x \"man\" program on remote systems.
+When this is non-nil, call the \"man\" program on the remote
+system determined by `default-directory'."
+ :type 'boolean
+ :version "30.1")
+
(defcustom Man-filter-list nil
"Manpage cleaning filter command phrases.
This variable contains a list of the following form:
@@ -307,7 +322,7 @@ If this is nil, `man' will use `locale-coding-system'."
:type 'hook
:group 'man)
-(defvar Man-name-regexp "[-[:alnum:]_­+][-[:alnum:]_.:­+]*"
+(defvar Man-name-regexp "[-[:alnum:]_­+[@][-[:alnum:]_.:­+]*"
"Regular expression describing the name of a manpage (without section).")
(defvar Man-section-regexp "[0-9][a-zA-Z0-9+]*\\|[LNln]"
@@ -523,8 +538,9 @@ Otherwise, the value is whatever the function
(define-button-type 'Man-xref-normal-file
'action (lambda (button)
- (let ((f (substitute-in-file-name
- (button-get button 'Man-target-string))))
+ (let ((f (concat (file-remote-p default-directory)
+ (substitute-in-file-name
+ (button-get button 'Man-target-string)))))
(if (file-exists-p f)
(if (file-readable-p f)
(view-file f)
@@ -537,6 +553,65 @@ Otherwise, the value is whatever the function
;; ======================================================================
;; utilities
+(defun Man-default-directory ()
+ "Return a default directory according to `Man-support-remote-systems'."
+ ;; Ensure that `default-directory' exists and is readable.
+ ;; We assume, that this function is always called inside the `man'
+ ;; command, so that we can check `current-prefix-arg' for reverting
+ ;; `Man-support-remote-systems'.
+ (let ((result default-directory)
+ (remote (if current-prefix-arg
+ (not Man-support-remote-systems)
+ Man-support-remote-systems)))
+
+ ;; Use a local directory if remote isn't possible.
+ (when (and (file-remote-p default-directory)
+ (not (and remote
+ ;; TODO:: Test that remote processes are supported.
+ )))
+ (setq result (expand-file-name "~/")))
+
+ ;; Check, whether the directory is accessible.
+ (if (file-accessible-directory-p result)
+ result
+ (expand-file-name (concat (file-remote-p result) "~/")))))
+
+(defun Man-shell-file-name ()
+ "Return a proper shell file name, respecting remote directories."
+ (or ; This works also in the local case.
+ (connection-local-value shell-file-name)
+ "/bin/sh"))
+
+(defun Man-header-file-path ()
+ "Return the C header file search path that Man should use.
+Normally, this is the value of the user option `Man-header-file-path',
+but when the man page is formatted on a remote system (see
+`Man-support-remote-systems'), this function tries to figure out the
+list of directories where the remote system has the C header files."
+ (let ((remote-id (file-remote-p default-directory)))
+ (if (null remote-id)
+ ;; The local case.
+ Man-header-file-path
+ ;; The remote case. Use connection-local variables.
+ (mapcar
+ (lambda (elt) (concat remote-id elt))
+ (with-connection-local-variables
+ (or (and (local-variable-p 'Man-header-file-path (current-buffer))
+ Man-header-file-path)
+ (setq-connection-local
+ Man-header-file-path
+ (let ((arch (with-temp-buffer
+ (when (zerop (ignore-errors
+ (process-file "gcc" nil '(t nil) nil
+ "-print-multiarch")))
+ (goto-char (point-min))
+ (buffer-substring (point) (line-end-position)))))
+ (base '("/usr/include" "/usr/local/include")))
+ (if (zerop (length arch))
+ base
+ (append
+ base (list (expand-file-name arch "/usr/include"))))))))))))
+
(defun Man-init-defvars ()
"Used for initializing variables based on display's color support.
This is necessary if one wants to dump man.el with Emacs."
@@ -575,7 +650,9 @@ This is necessary if one wants to dump man.el with Emacs."
(if Man-sed-script
(concat "-e '" Man-sed-script "'")
"")
- "-e '/^[\001-\032][\001-\032]*$/d'"
+ ;; Use octal numbers. Otherwise, \032 (Ctrl-Z) would
+ ;; suspend remote connections.
+ "-e '/^[\\o001-\\o032][\\o001-\\o032]*$/d'"
"-e '/\e[789]/s///g'"
"-e '/Reformatting page. Wait/d'"
"-e '/Reformatting entry. Wait/d'"
@@ -684,7 +761,11 @@ and the `Man-section-translations-alist' variables)."
(setq name (match-string 2 ref)
section (match-string 1 ref))))
(if (string= name "")
- ref ; Return the reference as is
+ ;; see Bug#66390
+ (mapconcat 'identity
+ (mapcar #'shell-quote-argument
+ (split-string ref "\\s-+"))
+ " ") ; Return the reference as is
(if Man-downcase-section-letters-flag
(setq section (downcase section)))
(while slist
@@ -709,22 +790,23 @@ program has no such option, but interprets any name containing
a \"/\" as a local filename. The function returns either `man-db'
`man', or nil."
(if (eq Man-support-local-filenames 'auto-detect)
- (setq Man-support-local-filenames
- (with-temp-buffer
- (let ((default-directory
- ;; Ensure that `default-directory' exists and is readable.
- (if (file-accessible-directory-p default-directory)
- default-directory
- (expand-file-name "~/"))))
- (ignore-errors
- (call-process manual-program nil t nil "--help")))
- (cond ((search-backward "--local-file" nil 'move)
- 'man-db)
- ;; This feature seems to be present in at least ver 1.4f,
- ;; which is about 20 years old.
- ;; I don't know if this version has an official name?
- ((looking-at "^man, versione? [1-9]")
- 'man))))
+ (with-connection-local-variables
+ (or (and (local-variable-p 'Man-support-local-filenames (current-buffer))
+ Man-support-local-filenames)
+ (setq-connection-local
+ Man-support-local-filenames
+ (with-temp-buffer
+ (let ((default-directory (Man-default-directory)))
+ (ignore-errors
+ (process-file manual-program nil t nil "--help")))
+ (cond ((search-backward "--local-file" nil 'move)
+ 'man-db)
+ ;; This feature seems to be present in at least
+ ;; ver 1.4f, which is about 20 years old. I
+ ;; don't know if this version has an official
+ ;; name?
+ ((looking-at "^man, versione? [1-9]")
+ 'man))))))
Man-support-local-filenames))
@@ -910,7 +992,8 @@ foo(sec)[, bar(sec) [, ...]] [other stuff] - description"
(unless (and Man-completion-cache
(string-prefix-p (car Man-completion-cache) prefix))
(with-temp-buffer
- (setq default-directory "/") ;; in case inherited doesn't exist
+ ;; In case inherited doesn't exist.
+ (setq default-directory (Man-default-directory))
;; Actually for my `man' the arg is a regexp.
;; POSIX says it must be ERE and "man-db" seems to agree,
;; whereas under macOS it seems to be BRE-style and doesn't
@@ -924,12 +1007,21 @@ foo(sec)[, bar(sec) [, ...]] [other stuff] - description"
;; error later.
(when (eq 0
(ignore-errors
- (call-process
+ (process-file
manual-program nil '(t nil) nil
"-k" (concat (when (or Man-man-k-use-anchor
(string-equal prefix ""))
"^")
- prefix))))
+ (if (string-equal prefix "")
+ prefix
+ ;; FIXME: shell-quote-argument
+ ;; is not entirely
+ ;; appropriate: we actually
+ ;; need to quote ERE here.
+ ;; But we don't have that, and
+ ;; shell-quote-argument does
+ ;; the job...
+ (shell-quote-argument prefix))))))
(setq table (Man-parse-man-k)))))
;; Cache the table for later reuse.
(when table
@@ -999,7 +1091,12 @@ names or descriptions. The pattern argument is usually an
Note that in some cases you will need to use \\[quoted-insert] to quote the
SPC character in the above examples, because this command attempts
-to auto-complete your input based on the installed manual pages."
+to auto-complete your input based on the installed manual pages.
+
+If `default-directory' is remote, and `Man-support-remote-systems'
+is non-nil, this command formats the man page on the remote system.
+A prefix argument reverses the value of `Man-support-remote-systems'
+for the current invocation."
(interactive
(list (let* ((default-entry (Man-default-man-entry))
@@ -1065,12 +1162,7 @@ to auto-complete your input based on the installed manual pages."
Man-coding-system
locale-coding-system))
;; Avoid possible error by using a directory that always exists.
- (default-directory
- (if (and (file-directory-p default-directory)
- (not (find-file-name-handler default-directory
- 'file-directory-p)))
- default-directory
- "/")))
+ (default-directory (Man-default-directory)))
;; Prevent any attempt to use display terminal fanciness.
(setenv "TERM" "dumb")
;; In Debian Woody, at least, we get overlong lines under X
@@ -1099,9 +1191,13 @@ to auto-complete your input based on the installed manual pages."
(defun Man-getpage-in-background (topic)
"Use TOPIC to build and fire off the manpage and cleaning command.
Return the buffer in which the manpage will appear."
- (let* ((man-args topic)
- (bufname (concat "*Man " man-args "*"))
- (buffer (get-buffer bufname)))
+ (let* ((default-directory (Man-default-directory))
+ (man-args topic)
+ (bufname
+ (if (file-remote-p default-directory)
+ (format "*Man %s %s*" (file-remote-p default-directory) man-args)
+ (format "*Man %s*" man-args)))
+ (buffer (get-buffer bufname)))
(if buffer
(Man-notify-when-ready buffer)
(message "Invoking %s %s in the background" manual-program man-args)
@@ -1118,21 +1214,21 @@ Return the buffer in which the manpage will appear."
"[cleaning...]")
'face 'mode-line-emphasis)))
(Man-start-calling
- (if (fboundp 'make-process)
- (let ((proc (start-process
+ (if (and (fboundp 'make-process)
+ (not Man-prefer-synchronous-call))
+ (let ((proc (start-file-process
manual-program buffer
- (if (memq system-type '(cygwin windows-nt))
- shell-file-name
- "sh")
+ (Man-shell-file-name)
shell-command-switch
(format (Man-build-man-command) man-args))))
(set-process-sentinel proc 'Man-bgproc-sentinel)
(set-process-filter proc 'Man-bgproc-filter))
(let* ((inhibit-read-only t)
(exit-status
- (call-process shell-file-name nil (list buffer nil) nil
- shell-command-switch
- (format (Man-build-man-command) man-args)))
+ (process-file
+ (Man-shell-file-name) nil (list buffer nil) nil
+ shell-command-switch
+ (format (Man-build-man-command) man-args)))
(msg ""))
(or (and (numberp exit-status)
(= exit-status 0))
@@ -1160,9 +1256,10 @@ Return the buffer in which the manpage will appear."
(buffer-read-only nil))
(erase-buffer)
(Man-start-calling
- (call-process shell-file-name nil (list (current-buffer) nil) nil
- shell-command-switch
- (format (Man-build-man-command) Man-arguments)))
+ (process-file
+ (Man-shell-file-name) nil (list (current-buffer) nil) nil
+ shell-command-switch
+ (format (Man-build-man-command) Man-arguments)))
(if Man-fontify-manpage-flag
(Man-fontify-manpage)
(Man-cleanup-manpage))
@@ -1262,21 +1359,21 @@ Same for the ANSI bold and normal escape sequences."
(progn
(goto-char (point-min))
(while (and (search-forward "__\b\b" nil t) (not (eobp)))
- (backward-delete-char 4)
+ (delete-char -4)
(put-text-property (point) (1+ (point))
'font-lock-face 'Man-underline))
(goto-char (point-min))
(while (search-forward "\b\b__" nil t)
- (backward-delete-char 4)
+ (delete-char -4)
(put-text-property (1- (point)) (point)
'font-lock-face 'Man-underline))))
(goto-char (point-min))
(while (and (search-forward "_\b" nil t) (not (eobp)))
- (backward-delete-char 2)
+ (delete-char -2)
(put-text-property (point) (1+ (point)) 'font-lock-face 'Man-underline))
(goto-char (point-min))
(while (search-forward "\b_" nil t)
- (backward-delete-char 2)
+ (delete-char -2)
(put-text-property (1- (point)) (point) 'font-lock-face 'Man-underline))
(goto-char (point-min))
(while (re-search-forward "\\(.\\)\\(\b+\\1\\)+" nil t)
@@ -1294,7 +1391,7 @@ Same for the ANSI bold and normal escape sequences."
;; condense it to a shorter line interspersed with ^H. Remove ^H with
;; their preceding chars (but don't put Man-overstrike). (Bug#5566)
(goto-char (point-min))
- (while (re-search-forward ".\b" nil t) (backward-delete-char 2))
+ (while (re-search-forward ".\b" nil t) (delete-char -2))
(goto-char (point-min))
;; Try to recognize common forms of cross references.
(Man-highlight-references)
@@ -1375,9 +1472,9 @@ script would have done them."
(if (or interactive (not Man-sed-script))
(progn
(goto-char (point-min))
- (while (search-forward "_\b" nil t) (backward-delete-char 2))
+ (while (search-forward "_\b" nil t) (delete-char -2))
(goto-char (point-min))
- (while (search-forward "\b_" nil t) (backward-delete-char 2))
+ (while (search-forward "\b_" nil t) (delete-char -2))
(goto-char (point-min))
(while (re-search-forward "\\(.\\)\\(\b\\1\\)+" nil t)
(replace-match "\\1"))
@@ -1392,7 +1489,7 @@ script would have done them."
;; condense it to a shorter line interspersed with ^H. Remove ^H with
;; their preceding chars (but don't put Man-overstrike). (Bug#5566)
(goto-char (point-min))
- (while (re-search-forward ".\b" nil t) (backward-delete-char 2))
+ (while (re-search-forward ".\b" nil t) (delete-char -2))
(Man-softhyphen-to-minus))
(defun Man-bgproc-filter (process string)
@@ -1926,7 +2023,7 @@ Specify which REFERENCE to use; default is based on word at point."
;; Header file support
(defun Man-view-header-file (file)
"View a header file specified by FILE from `Man-header-file-path'."
- (let ((path Man-header-file-path)
+ (let ((path (Man-header-file-path))
complete-path)
(while path
(setq complete-path (expand-file-name file (car path))
diff --git a/lisp/menu-bar.el b/lisp/menu-bar.el
index bcfa83cf8e4..320fabb54cf 100644
--- a/lisp/menu-bar.el
+++ b/lisp/menu-bar.el
@@ -79,6 +79,14 @@
:help "Print current buffer with page headings"))
menu))
+(defcustom menu-bar-close-window nil
+ "Whether or not to close the current window from the menu bar.
+If non-nil, selecting Close from the File menu or clicking Close
+in the tool bar will close the current window where possible."
+ :type 'boolean
+ :group 'menu
+ :version "30.1")
+
(defvar menu-bar-file-menu
(let ((menu (make-sparse-keymap "File")))
@@ -486,6 +494,11 @@
(defvar menu-bar-edit-menu
(let ((menu (make-sparse-keymap "Edit")))
+ (bindings--define-key menu [execute-extended-command]
+ '(menu-item "Execute Command" execute-extended-command
+ :enable t
+ :help "Read a command name, its arguments, then call it."))
+
;; ns-win.el said: Add spell for platform consistency.
(if (featurep 'ns)
(bindings--define-key menu [spell]
@@ -686,10 +699,10 @@ Do the same for the keys of the same name."
menu-bar-separator)
(bindings--define-key menu [customize-browse]
'(menu-item "Browse Customization Groups" customize-browse
- :help "Browse all customization groups"))
+ :help "Tree-like browser of all the groups of customizable options"))
(bindings--define-key menu [customize]
- '(menu-item "Top-level Customization Group" customize
- :help "The master group called `Emacs'"))
+ '(menu-item "Top-level Emacs Customization Group" customize
+ :help "Top-level groups of customizable options, and their descriptions"))
(bindings--define-key menu [customize-themes]
'(menu-item "Custom Themes" customize-themes
:help "Choose a pre-defined customization theme"))
@@ -1340,6 +1353,15 @@ mail status in mode line"))
(frame-visible-p
(symbol-value 'speedbar-frame))))))
+ (bindings--define-key menu [showhide-outline-minor-mode]
+ '(menu-item "Outlines" outline-minor-mode
+ :help "Turn outline-minor-mode on/off"
+ :visible (seq-some #'local-variable-p
+ '(outline-search-function
+ outline-regexp outline-level))
+ :button (:toggle . (and (boundp 'outline-minor-mode)
+ outline-minor-mode))))
+
(bindings--define-key menu [showhide-tab-line-mode]
'(menu-item "Window Tab Line" global-tab-line-mode
:help "Turn window-local tab-lines on/off"
@@ -1425,6 +1447,14 @@ mail status in mode line"))
(defvar menu-bar-line-wrapping-menu
(let ((menu (make-sparse-keymap "Line Wrapping")))
+ (bindings--define-key menu [visual-wrap]
+ '(menu-item "Visual Wrap Prefix mode" visual-wrap-prefix-mode
+ :help "Display continuation lines with visual context-dependent prefix"
+ :visible (menu-bar-menu-frame-live-and-visible-p)
+ :button (:toggle
+ . (bound-and-true-p visual-wrap-prefix-mode))
+ :enable t))
+
(bindings--define-key menu [word-wrap]
'(menu-item "Word Wrap (Visual Line mode)"
menu-bar--visual-line-mode-enable
@@ -1464,30 +1494,30 @@ mail status in mode line"))
(word-search-regexp "Whole Words" "Whole word")))
(bindings--define-key menu (vector (nth 0 x))
`(menu-item ,(nth 1 x)
- (lambda ()
- (interactive)
- (setq search-default-mode #',(nth 0 x))
- (message ,(format "%s search enabled" (nth 2 x))))
+ ,(lambda ()
+ (interactive)
+ (setq search-default-mode (nth 0 x))
+ (message "%s search enabled" (nth 2 x)))
:help ,(format "Enable %s search" (downcase (nth 2 x)))
:button (:radio . (eq search-default-mode #',(nth 0 x))))))
(bindings--define-key menu [regexp-search]
- '(menu-item "Regular Expression"
- (lambda ()
- (interactive)
- (setq search-default-mode t)
- (message "Regular-expression search enabled"))
+ `(menu-item "Regular Expression"
+ ,(lambda ()
+ (interactive)
+ (setq search-default-mode t)
+ (message "Regular-expression search enabled"))
:help "Enable regular-expression search"
:button (:radio . (eq search-default-mode t))))
(bindings--define-key menu [regular-search]
- '(menu-item "Literal Search"
- (lambda ()
- (interactive)
- (when search-default-mode
- (setq search-default-mode nil)
- (when (symbolp search-default-mode)
- (message "Literal search enabled"))))
+ `(menu-item "Literal Search"
+ ,(lambda ()
+ (interactive)
+ (when search-default-mode
+ (setq search-default-mode nil)
+ (when (symbolp search-default-mode)
+ (message "Literal search enabled"))))
:help "Disable special search modes"
:button (:radio . (not search-default-mode))))
@@ -1791,7 +1821,7 @@ mail status in mode line"))
(bindings--define-key menu [project-find-regexp] '(menu-item "Find Regexp..." project-find-regexp :help "Search for a regexp in files belonging to current project"))
(bindings--define-key menu [separator-project-search] menu-bar-separator)
(bindings--define-key menu [project-kill-buffers] '(menu-item "Kill Buffers..." project-kill-buffers :help "Kill the buffers belonging to the current project"))
- (bindings--define-key menu [project-list-buffers] '(menu-item "List Buffers..." project-list-buffers :help "Pop up a window listing all Emacs buffers belonging to current project"))
+ (bindings--define-key menu [project-list-buffers] '(menu-item "List Buffers" project-list-buffers :help "Pop up a window listing all Emacs buffers belonging to current project"))
(bindings--define-key menu [project-switch-to-buffer] '(menu-item "Switch To Buffer..." project-switch-to-buffer :help "Prompt for a buffer belonging to current project, and switch to it"))
(bindings--define-key menu [separator-project-buffers] menu-bar-separator)
(bindings--define-key menu [project-async-shell-command] '(menu-item "Async Shell Command..." project-async-shell-command :help "Invoke a shell command in project root asynchronously in background"))
@@ -1801,13 +1831,16 @@ mail status in mode line"))
(bindings--define-key menu [project-compile] '(menu-item "Compile..." project-compile :help "Invoke compiler or Make for current project, view errors"))
(bindings--define-key menu [separator-project-programs] menu-bar-separator)
(bindings--define-key menu [project-switch-project] '(menu-item "Switch Project..." project-switch-project :help "Switch to another project and then run a command"))
- (bindings--define-key menu [project-vc-dir] '(menu-item "VC Dir..." project-vc-dir :help "Show the VC status of the project repository"))
+ (bindings--define-key menu [project-vc-dir] '(menu-item "VC Dir" project-vc-dir :help "Show the VC status of the project repository"))
(bindings--define-key menu [project-dired] '(menu-item "Open Project Root" project-dired :help "Read the root directory of the current project, to operate on its files"))
(bindings--define-key menu [project-find-dir] '(menu-item "Open Directory..." project-find-dir :help "Open existing directory that belongs to current project"))
(bindings--define-key menu [project-or-external-find-file] '(menu-item "Open File Including External Roots..." project-or-external-find-file :help "Open existing file that belongs to current project or its external roots"))
(bindings--define-key menu [project-open-file] '(menu-item "Open File..." project-find-file :help "Open an existing file that belongs to current project"))
menu))
+(defvar menu-bar-project-item
+ `(menu-item "Project" ,menu-bar-project-menu))
+
(defun menu-bar-read-mail ()
"Read mail using `read-mail-command'."
(interactive)
@@ -1895,7 +1928,7 @@ mail status in mode line"))
:help "Start language server suitable for this buffer's major-mode"))
(bindings--define-key menu [project]
- `(menu-item "Project" ,menu-bar-project-menu))
+ menu-bar-project-item)
(bindings--define-key menu [ede]
'(menu-item "Project Support (EDE)"
@@ -2213,12 +2246,19 @@ otherwise it could decide to silently do nothing."
;; (Bug#8184).
((not (menu-bar-menu-frame-live-and-visible-p)))
((menu-bar-non-minibuffer-window-p)
- (kill-buffer (current-buffer)))
+ (kill-buffer (current-buffer))
+ ;; Also close the current window if `menu-bar-close-window' is
+ ;; set.
+ (when menu-bar-close-window
+ (ignore-errors (delete-window))))
(t
(abort-recursive-edit))))
(defun kill-this-buffer-enabled-p ()
- "Return non-nil if the `kill-this-buffer' menu item should be enabled."
+ "Return non-nil if the `kill-this-buffer' menu item should be enabled.
+It should be enabled there is at least one non-hidden buffer, or if
+`menu-bar-close-window' is non-nil and there is more than one window on
+this frame."
(or (not (menu-bar-non-minibuffer-window-p))
(let (found-1)
;; Instead of looping over entire buffer list, stop once we've
@@ -2228,7 +2268,9 @@ otherwise it could decide to silently do nothing."
(unless (string-match-p "^ " (buffer-name buffer))
(if (not found-1)
(setq found-1 t)
- (throw 'found-2 t))))))))
+ (throw 'found-2 t))))))
+ (and menu-bar-close-window
+ (window-parent (selected-window)))))
(put 'dired 'menu-enable '(menu-bar-non-minibuffer-window-p))
@@ -2292,14 +2334,16 @@ The menu shows all the killed text sequences stored in `kill-ring'."
;;; Buffers Menu
-(defcustom buffers-menu-max-size 10
+;; Increasing this more might be problematic on TTY frames. See Bug#64398.
+(defcustom buffers-menu-max-size 15
"Maximum number of entries which may appear on the Buffers menu.
-If this is 10, then only the ten most-recently-selected buffers are shown.
-If this is nil, then all buffers are shown.
-A large number or nil slows down menu responsiveness."
- :type '(choice integer
- (const :tag "All" nil))
- :group 'menu)
+If this is a number, only that many most-recently-selected
+buffers are shown.
+If this is nil, all buffers are shown."
+ :type '(choice natnum
+ (const :tag "All" nil))
+ :group 'menu
+ :version "30.1")
(defcustom buffers-menu-buffer-name-length 30
"Maximum length of the buffer name on the Buffers menu.
@@ -2708,20 +2752,25 @@ FROM-MENU-BAR, if non-nil, means we are dropping one of menu-bar's menus."
POSITION can be an event, a posn- value, a value having the
form ((XOFFSET YOFFSET) WINDOW), or nil.
If nil, the current mouse position is used, or nil if there is no mouse."
- (pcase position
+ (cond
;; nil -> mouse cursor position
- ('nil
+ ((eq position nil)
(let ((mp (mouse-pixel-position)))
(list (list (cadr mp) (cddr mp)) (car mp))))
;; Value returned from `event-end' or `posn-at-point'.
- ((pred posnp)
+ ((posnp position)
(let ((xy (posn-x-y position)))
(list (list (car xy) (cdr xy))
(posn-window position))))
+ ;; `touchscreen-begin' or `touchscreen-end' event.
+ ((or (eq (car-safe position) 'touchscreen-begin)
+ (eq (car-safe position) 'touchscreen-end))
+ position)
;; Event.
- ((pred eventp)
+ ((eventp position)
(popup-menu-normalize-position (event-end position)))
- (_ position)))
+ ;; Some other value.
+ (t position)))
(defcustom tty-menu-open-use-tmm nil
"If non-nil, \\[menu-bar-open] on a TTY will invoke `tmm-menubar'.
diff --git a/lisp/mh-e/mh-acros.el b/lisp/mh-e/mh-acros.el
index 3942783ec5a..8f582df128d 100644
--- a/lisp/mh-e/mh-acros.el
+++ b/lisp/mh-e/mh-acros.el
@@ -42,82 +42,9 @@
-;;; Compatibility
-
-;;;###mh-autoload
-(defmacro mh-do-in-gnu-emacs (&rest body)
- "Execute BODY if in GNU Emacs."
- (declare (obsolete progn "29.1") (debug t) (indent defun))
- (unless (featurep 'xemacs) `(progn ,@body)))
-
-;;;###mh-autoload
-(defmacro mh-do-in-xemacs (&rest body)
- "Execute BODY if in XEmacs."
- (declare (obsolete ignore "29.1") (debug t) (indent defun))
- (when (featurep 'xemacs) `(progn ,@body)))
-
-;;;###mh-autoload
-(defmacro mh-funcall-if-exists (function &rest args)
- "Call FUNCTION with ARGS as parameters if it exists."
- (declare (obsolete "use `(when (fboundp 'foo) (foo))' instead." "29.1")
- (debug (symbolp body)))
- ;; FIXME: Not clear when this should be used. If the function happens
- ;; not to exist at compile-time (e.g. because the corresponding package
- ;; wasn't loaded), then it won't ever be used :-(
- (when (fboundp function)
- `(when (fboundp ',function)
- (funcall ',function ,@args))))
-
-;;;###mh-autoload
-(defmacro defun-mh (name function arg-list &rest body)
- "Create function NAME.
-If FUNCTION exists, then NAME becomes an alias for FUNCTION.
-Otherwise, create function NAME with ARG-LIST and BODY."
- (declare (obsolete defun "29.1")
- (indent defun) (doc-string 4)
- (debug (&define name symbolp sexp def-body)))
- `(defalias ',name
- (if (fboundp ',function)
- ',function
- (lambda ,arg-list ,@body))))
-
-;;;###mh-autoload
-(defmacro defmacro-mh (name macro arg-list &rest body)
- "Create macro NAME.
-If MACRO exists, then NAME becomes an alias for MACRO.
-Otherwise, create macro NAME with ARG-LIST and BODY."
- (declare (obsolete defmacro "29.1")
- (indent defun) (doc-string 4)
- (debug (&define name symbolp sexp def-body)))
- (let ((defined-p (fboundp macro)))
- (if defined-p
- `(defalias ',name ',macro)
- `(defmacro ,name ,arg-list ,@body))))
-
-
;;; Miscellaneous
;;;###mh-autoload
-(defmacro mh-make-local-hook (hook)
- "Make HOOK local if needed.
-XEmacs and versions of GNU Emacs before 21.1 require
-`make-local-hook' to be called."
- (declare (obsolete nil "29.1"))
- (when (and (fboundp 'make-local-hook)
- (not (get 'make-local-hook 'byte-obsolete-info)))
- `(make-local-hook ,hook)))
-
-;;;###mh-autoload
-(defmacro mh-mark-active-p (check-transient-mark-mode-flag)
- "If CHECK-TRANSIENT-MARK-MODE-FLAG is non-nil then check if
-variable `transient-mark-mode' is active."
- (declare (obsolete nil "29.1"))
- (cond ((not check-transient-mark-mode-flag)
- 'mark-active)
- (t
- '(and transient-mark-mode mark-active))))
-
-;;;###mh-autoload
(defmacro with-mh-folder-updating (save-modification-flag &rest body)
"Format is (with-mh-folder-updating (SAVE-MODIFICATION-FLAG) &body BODY).
Execute BODY, which can modify the folder buffer without having to
diff --git a/lisp/mh-e/mh-folder.el b/lisp/mh-e/mh-folder.el
index 4c29929e5bb..1dae9a600fd 100644
--- a/lisp/mh-e/mh-folder.el
+++ b/lisp/mh-e/mh-folder.el
@@ -1293,8 +1293,9 @@ The message at the cursor is used for \"cur\"."
(if new-cur
(let ((seq-entry (mh-find-seq 'cur)))
(mh-remove-cur-notation)
- (setcdr seq-entry
- (list new-cur)) ;delete-seq-locally, add-msgs-to-seq
+ (if seq-entry
+ (setcdr seq-entry (list new-cur))
+ (mh-add-msgs-to-seq (list new-cur) 'cur))
(mh-define-sequence 'cur (list new-cur))
(beginning-of-line)
(if (looking-at mh-scan-good-msg-regexp)
diff --git a/lisp/mh-e/mh-identity.el b/lisp/mh-e/mh-identity.el
index 9221d399b5a..bfd0a1c0277 100644
--- a/lisp/mh-e/mh-identity.el
+++ b/lisp/mh-e/mh-identity.el
@@ -141,7 +141,7 @@ See `mh-identity-list'."
(cons '("None")
(mapcar #'list (mapcar #'car mh-identity-list)))
nil t default nil default))
- (if (eq identity "None")
+ (if (equal identity "None")
nil
identity)))
diff --git a/lisp/mh-e/mh-mime.el b/lisp/mh-e/mh-mime.el
index 347500f1135..b0920d524a7 100644
--- a/lisp/mh-e/mh-mime.el
+++ b/lisp/mh-e/mh-mime.el
@@ -1355,6 +1355,7 @@ See also \\[mh-mh-to-mime]."
("ftp") ; RFC2046 File Transfer Protocol
("gopher") ; RFC1738 The Gopher Protocol
("http") ; RFC1738 Hypertext Transfer Protocol
+ ("https") ; RFC2818 HTTP Over TLS
("local-file") ; RFC2046 Local file access
("mail-server") ; RFC2046 mail-server Electronic mail address
("mailto") ; RFC1738 Electronic mail address
diff --git a/lisp/mh-e/mh-print.el b/lisp/mh-e/mh-print.el
index 9253587ae2c..b7c07d4239c 100644
--- a/lisp/mh-e/mh-print.el
+++ b/lisp/mh-e/mh-print.el
@@ -79,8 +79,7 @@ commands \\[mh-ps-print-toggle-color] and
This is the function that actually does the work.
If FILE is nil, then the messages are spooled to the printer."
(mh-iterate-on-range msg range
- (unwind-protect
- (mh-ps-spool-msg msg))
+ (mh-ps-spool-msg msg)
(mh-notate msg mh-note-printed mh-cmd-note))
(ps-despool file))
diff --git a/lisp/mh-e/mh-show.el b/lisp/mh-e/mh-show.el
index b3e9e7ca934..0f90fd6f057 100644
--- a/lisp/mh-e/mh-show.el
+++ b/lisp/mh-e/mh-show.el
@@ -29,6 +29,7 @@
;;; Code:
(require 'mh-e)
+(require 'mh-mime)
(require 'mh-scan)
;; Dynamically-created function not found in mh-loaddefs.el.
diff --git a/lisp/minibuffer.el b/lisp/minibuffer.el
index a9e3ec937f9..0a844c538b4 100644
--- a/lisp/minibuffer.el
+++ b/lisp/minibuffer.el
@@ -150,21 +150,29 @@ The metadata of a completion table should be constant between two boundaries."
minibuffer-completion-table
minibuffer-completion-predicate))
+(defun completion--metadata-get-1 (metadata prop)
+ (or (alist-get prop metadata)
+ (plist-get completion-extra-properties
+ ;; Cache the keyword
+ (or (get prop 'completion-extra-properties--keyword)
+ (put prop 'completion-extra-properties--keyword
+ (intern (concat ":" (symbol-name prop))))))))
+
(defun completion-metadata-get (metadata prop)
- (cdr (assq prop metadata)))
-
-(defun completion--some (fun xs)
- "Apply FUN to each element of XS in turn.
-Return the first non-nil returned value.
-Like CL's `some'."
- (let ((firsterror nil)
- res)
- (while (and (not res) xs)
- (condition-case-unless-debug err
- (setq res (funcall fun (pop xs)))
- (error (unless firsterror (setq firsterror err)) nil)))
- (or res
- (if firsterror (signal (car firsterror) (cdr firsterror))))))
+ "Get property PROP from completion METADATA.
+If the metadata specifies a completion category, the variables
+`completion-category-overrides' and
+`completion-category-defaults' take precedence for
+category-specific overrides. If the completion metadata does not
+specify the property, the `completion-extra-properties' plist is
+consulted. Note that the keys of the
+`completion-extra-properties' plist are keyword symbols, not
+plain symbols."
+ (if-let (((not (eq prop 'category)))
+ (cat (completion--metadata-get-1 metadata 'category))
+ (over (completion--category-override cat prop)))
+ (cdr over)
+ (completion--metadata-get-1 metadata prop)))
(defun complete-with-action (action collection string predicate)
"Perform completion according to ACTION.
@@ -313,7 +321,7 @@ the form (concat S2 S)."
;; Predicates are called differently depending on the nature of
;; the completion table :-(
(cond
- ((vectorp table) ;Obarray.
+ ((obarrayp table)
(lambda (sym) (funcall pred (concat prefix (symbol-name sym)))))
((hash-table-p table)
(lambda (s _v) (funcall pred (concat prefix s))))
@@ -426,9 +434,9 @@ obeys predicates."
;; is returned by TABLE2 (because TABLE1 returned an empty list).
;; Same potential problem if any of the tables use quoting.
(lambda (string pred action)
- (completion--some (lambda (table)
- (complete-with-action action table string pred))
- tables)))
+ (seq-some (lambda (table)
+ (complete-with-action action table string pred))
+ tables)))
(defun completion-table-merge (&rest tables)
"Create a completion table that collects completions from all TABLES."
@@ -451,9 +459,9 @@ obeys predicates."
(all-completions string table pred))
tables)))
(t
- (completion--some (lambda (table)
- (complete-with-action action table string pred))
- tables)))))
+ (seq-some (lambda (table)
+ (complete-with-action action table string pred))
+ tables)))))
(defun completion-table-with-quoting (table unquote requote)
;; A difficult part of completion-with-quoting is to map positions in the
@@ -690,6 +698,17 @@ for use at QPOS."
'completions-common-part)
qprefix))))
(qcompletion (concat qprefix qnew)))
+ ;; Some completion tables (including this one) pass
+ ;; along necessary information as text properties
+ ;; on the first character of the completion. Make
+ ;; sure the quoted completion has these properties
+ ;; too.
+ (add-text-properties 0 1 (text-properties-at 0 completion)
+ qcompletion)
+ ;; Attach unquoted completion string, which is needed
+ ;; to score the completion in `completion--flex-score'.
+ (put-text-property 0 1 'completion--unquoted
+ completion qcompletion)
;; FIXME: Similarly here, Cygwin's mapping trips this
;; assertion.
;;(cl-assert
@@ -963,6 +982,8 @@ is at its default value `grow-only'."
(reverse multi-message-list)
multi-message-separator)))
+(defvar touch-screen-current-tool)
+
(defun clear-minibuffer-message ()
"Clear message temporarily shown in the minibuffer.
Intended to be called via `clear-message-function'."
@@ -973,10 +994,16 @@ Intended to be called via `clear-message-function'."
(when (overlayp minibuffer-message-overlay)
(delete-overlay minibuffer-message-overlay)
(setq minibuffer-message-overlay nil)))
-
- ;; Return nil telling the caller that the message
- ;; should be also handled by the caller.
- nil)
+ ;; Don't clear the message if touch screen drag-to-select is in
+ ;; progress, because a preview message might currently be displayed
+ ;; in the echo area. FIXME: find some way to place this in
+ ;; touch-screen.el.
+ (if (and (bound-and-true-p touch-screen-preview-select)
+ (eq (nth 3 touch-screen-current-tool) 'drag))
+ 'dont-clear-message
+ ;; Return nil telling the caller that the message
+ ;; should be also handled by the caller.
+ nil))
(setq clear-message-function 'clear-minibuffer-message)
@@ -1117,11 +1144,7 @@ and DOC describes the way this style of completion works.")
The available styles are listed in `completion-styles-alist'.
Note that `completion-category-overrides' may override these
-styles for specific categories, such as files, buffers, etc.
-
-Note that Tramp host name completion (e.g., \"/ssh:ho<TAB>\")
-currently doesn't work if this list doesn't contain at least one
-of `basic', `emacs22' or `emacs21'."
+styles for specific categories, such as files, buffers, etc."
:type completion--styles-type
:version "23.1")
@@ -1133,23 +1156,42 @@ of `basic', `emacs22' or `emacs21'."
(project-file (styles . (substring)))
(xref-location (styles . (substring)))
(info-menu (styles . (basic substring)))
- (symbol-help (styles . (basic shorthand substring))))
+ (symbol-help (styles . (basic shorthand substring)))
+ (calendar-month (display-sort-function . identity)))
"Default settings for specific completion categories.
+
Each entry has the shape (CATEGORY . ALIST) where ALIST is
an association list that can specify properties such as:
- `styles': the list of `completion-styles' to use for that category.
- `cycle': the `completion-cycle-threshold' to use for that category.
+- `cycle-sort-function': function to sort entries when cycling.
+- `display-sort-function': function to sort entries in *Completions*.
+- `group-function': function for grouping the completion candidates.
+- `annotation-function': function to add annotations in *Completions*.
+- `affixation-function': function to prepend/append a prefix/suffix.
+
Categories are symbols such as `buffer' and `file', used when
completing buffer and file names, respectively.
Also see `completion-category-overrides'.")
(defcustom completion-category-overrides nil
- "List of category-specific user overrides for completion styles.
+ "List of category-specific user overrides for completion metadata.
+
Each override has the shape (CATEGORY . ALIST) where ALIST is
an association list that can specify properties such as:
- `styles': the list of `completion-styles' to use for that category.
- `cycle': the `completion-cycle-threshold' to use for that category.
+- `cycle-sort-function': function to sort entries when cycling.
+- `display-sort-function': nil means to use either the sorting
+function from metadata, or if that is nil, fall back to `completions-sort';
+`identity' disables sorting and keeps the original order; and other
+possible values are the same as in `completions-sort'.
+- `group-function': function for grouping the completion candidates.
+- `annotation-function': function to add annotations in *Completions*.
+- `affixation-function': function to prepend/append a prefix/suffix.
+See more description of metadata in `completion-metadata'.
+
Categories are symbols such as `buffer' and `file', used when
completing buffer and file names, respectively.
@@ -1169,7 +1211,33 @@ overrides the default specified in `completion-category-defaults'."
,completion--styles-type)
(cons :tag "Completion Cycling"
(const :tag "Select one value from the menu." cycle)
- ,completion--cycling-threshold-type))))
+ ,completion--cycling-threshold-type)
+ (cons :tag "Cycle Sorting"
+ (const :tag "Select one value from the menu."
+ cycle-sort-function)
+ (choice (function :tag "Custom function")))
+ (cons :tag "Completion Sorting"
+ (const :tag "Select one value from the menu."
+ display-sort-function)
+ (choice (const :tag "Use default" nil)
+ (const :tag "No sorting" identity)
+ (const :tag "Alphabetical sorting"
+ minibuffer-sort-alphabetically)
+ (const :tag "Historical sorting"
+ minibuffer-sort-by-history)
+ (function :tag "Custom function")))
+ (cons :tag "Completion Groups"
+ (const :tag "Select one value from the menu."
+ group-function)
+ (choice (function :tag "Custom function")))
+ (cons :tag "Completion Annotation"
+ (const :tag "Select one value from the menu."
+ annotation-function)
+ (choice (function :tag "Custom function")))
+ (cons :tag "Completion Affixation"
+ (const :tag "Select one value from the menu."
+ affixation-function)
+ (choice (function :tag "Custom function"))))))
(defun completion--category-override (category tag)
(or (assq tag (cdr (assq category completion-category-overrides)))
@@ -1214,7 +1282,7 @@ overrides the default specified in `completion-category-defaults'."
(cl-assert (<= point (length string)))
(pop new))))
(result-and-style
- (completion--some
+ (seq-some
(lambda (style)
(let ((probe (funcall
(or (nth n (assq style completion-styles-alist))
@@ -1245,6 +1313,7 @@ Only the elements of table that satisfy predicate PRED are considered.
POINT is the position of point within STRING.
The return value is a list of completions and may contain the base-size
in the last `cdr'."
+ (setq completion-lazy-hilit-fn nil)
;; FIXME: We need to additionally return the info needed for the
;; second part of completion-base-position.
(completion--nth-completion 2 string table pred point metadata))
@@ -1313,14 +1382,29 @@ completion candidates than this number."
(defcustom completions-sort 'alphabetical
"Sort candidates in the *Completions* buffer.
-The value can be nil to disable sorting, `alphabetical' for
-alphabetical sorting or a custom sorting function. The sorting
-function takes and returns a list of completion candidate
-strings."
+Completion candidates in the *Completions* buffer are sorted
+depending on the value.
+
+If it's nil, sorting is disabled.
+If it's the symbol `alphabetical', candidates are sorted by
+`minibuffer-sort-alphabetically'.
+If it's the symbol `historical', candidates are sorted by
+`minibuffer-sort-by-history', which first sorts alphabetically,
+and then rearranges the order according to the order of the
+candidates in the minibuffer history.
+If it's a function, the function is called to sort the candidates.
+The sorting function takes a list of completion candidate
+strings, which it may modify; it should return a sorted list,
+which may be the same.
+
+If the completion-specific metadata provides a
+`display-sort-function', that function overrides the value of
+this variable."
:type '(choice (const :tag "No sorting" nil)
(const :tag "Alphabetical sorting" alphabetical)
+ (const :tag "Historical sorting" historical)
(function :tag "Custom function"))
- :version "29.1")
+ :version "30.1")
(defcustom completions-group nil
"Enable grouping of completion candidates in the *Completions* buffer.
@@ -1567,11 +1651,12 @@ scroll the window of possible completions."
(t (prog1 (pcase (completion--do-completion beg end)
(#b000 nil)
(_ t))
- (when (and (eq completion-auto-select t)
- (window-live-p minibuffer-scroll-window)
- (eq t (frame-visible-p (window-frame minibuffer-scroll-window))))
- ;; When the completion list window was displayed, select it.
- (switch-to-completions))))))
+ (if (window-live-p minibuffer-scroll-window)
+ (and (eq completion-auto-select t)
+ (eq t (frame-visible-p (window-frame minibuffer-scroll-window)))
+ ;; When the completion list window was displayed, select it.
+ (switch-to-completions))
+ (completion-in-region-mode -1))))))
(defun completion--cache-all-sorted-completions (beg end comps)
(add-hook 'after-change-functions
@@ -1645,6 +1730,44 @@ Remove completion BASE prefix string from history elements."
(substring c base-size)))
hist)))))
+(defun minibuffer-sort-alphabetically (completions)
+ "Sort COMPLETIONS alphabetically.
+
+COMPLETIONS are sorted alphabetically by `string-lessp'.
+
+This is a suitable function to use for `completions-sort' or to
+include as `display-sort-function' in completion metadata."
+ (sort completions #'string-lessp))
+
+(defvar minibuffer-completion-base nil
+ "The base for the current completion.
+
+This is the part of the current minibuffer input which comes
+before the current completion field, as determined by
+`completion-boundaries'. This is primarily relevant for file
+names, where this is the directory component of the file name.")
+
+(defun minibuffer-sort-by-history (completions)
+ "Sort COMPLETIONS by their position in `minibuffer-history-variable'.
+
+COMPLETIONS are sorted first by `minibuffer-sort-alphbetically',
+then any elements occurring in the minibuffer history list are
+moved to the front based on the chronological order they occur in
+the history. If a history variable hasn't been specified for
+this call of `completing-read', COMPLETIONS are sorted only by
+`minibuffer-sort-alphbetically'.
+
+This is a suitable function to use for `completions-sort' or to
+include as `display-sort-function' in completion metadata."
+ (let ((alphabetized (sort completions #'string-lessp)))
+ ;; Only use history when it's specific to these completions.
+ (if (eq minibuffer-history-variable
+ (default-value minibuffer-history-variable))
+ alphabetized
+ (minibuffer--sort-by-position
+ (minibuffer--sort-preprocess-history minibuffer-completion-base)
+ alphabetized))))
+
(defun minibuffer--group-by (group-fun sort-fun elems)
"Group ELEMS by GROUP-FUN and sort groups by SORT-FUN."
(let ((groups))
@@ -2311,8 +2434,11 @@ candidates."
(with-current-buffer standard-output
(goto-char (point-max))
- (when completions-header-format
- (insert (format completions-header-format (length completions))))
+ (if completions-header-format
+ (insert (format completions-header-format (length completions)))
+ (unless completion-show-help
+ ;; Ensure beginning-of-buffer isn't a completion.
+ (insert (propertize "\n" 'face '(:height 0)))))
(completion--insert-strings completions group-fun)))
(run-hooks 'completion-setup-hook)
@@ -2322,6 +2448,9 @@ candidates."
"Property list of extra properties of the current completion job.
These include:
+`:category': the kind of objects returned by `all-completions'.
+ Used by `completion-category-overrides'.
+
`:annotation-function': Function to annotate the completions buffer.
The function must accept one argument, a completion string,
and return either nil or a string which is to be displayed
@@ -2337,6 +2466,15 @@ These include:
`:annotation-function' when both are provided, so only this
function is used.
+`:group-function': Function for grouping the completion candidates.
+
+`:display-sort-function': Function to sort entries in *Completions*.
+
+`:cycle-sort-function': Function to sort entries when cycling.
+
+See more information about these functions above
+in `completion-metadata'.
+
`:exit-function': Function to run after completion is performed.
The function must accept two arguments, STRING and STATUS.
@@ -2379,6 +2517,36 @@ These include:
(resize-temp-buffer-window win))
(fit-window-to-buffer win completions-max-height)))
+(defcustom completion-auto-deselect t
+ "If non-nil, deselect current completion candidate when you type in minibuffer.
+
+A non-nil value means that after typing at the minibuffer prompt,
+any completion candidate highlighted in *Completions* window (to
+indicate that it is the selected candidate) will be un-highlighted,
+and point in the *Completions* window will be moved off such a candidate.
+This means that `RET' (`minibuffer-choose-completion-or-exit') will exit
+the minubuffer with the minibuffer's current contents, instead of the
+selected completion candidate."
+ :type '(choice (const :tag "Candidates in *Completions* stay selected as you type" nil)
+ (const :tag "Typing deselects any completion candidate in *Completions*" t))
+ :version "30.1")
+
+(defun completions--deselect ()
+ "If point is in a completion candidate, move to just after the end of it.
+
+The candidate will still be chosen by `choose-completion' unless
+`choose-completion-deselect-if-after' is non-nil."
+ (when (get-text-property (point) 'completion--string)
+ (goto-char (or (next-single-property-change (point) 'completion--string)
+ (point-max)))))
+
+(defun completions--after-change (_start _end _old-len)
+ "Update displayed *Completions* buffer after change in buffer contents."
+ (when completion-auto-deselect
+ (when-let (window (get-buffer-window "*Completions*" 0))
+ (with-selected-window window
+ (completions--deselect)))))
+
(defun minibuffer-completion-help (&optional start end)
"Display a list of possible completions of the current minibuffer contents."
(interactive)
@@ -2401,6 +2569,7 @@ These include:
;; If there are no completions, or if the current input is already
;; the sole completion, then hide (previous&stale) completions.
(minibuffer-hide-completions)
+ (remove-hook 'after-change-functions #'completions--after-change t)
(if completions
(completion--message "Sole completion")
(unless completion-fail-discreetly
@@ -2410,20 +2579,26 @@ These include:
(let* ((last (last completions))
(base-size (or (cdr last) 0))
(prefix (unless (zerop base-size) (substring string 0 base-size)))
+ (minibuffer-completion-base (substring string 0 base-size))
(base-prefix (buffer-substring (minibuffer--completion-prompt-end)
(+ start base-size)))
- (base-suffix (buffer-substring (point) (point-max)))
+ (base-suffix
+ (if (or (eq (alist-get 'category (cdr md)) 'file)
+ completion-in-region-mode-predicate)
+ (buffer-substring
+ (save-excursion
+ (if completion-in-region-mode-predicate
+ (point)
+ (or (search-forward "/" nil t) (point-max))))
+ (point-max))
+ ""))
(all-md (completion--metadata (buffer-substring-no-properties
start (point))
base-size md
minibuffer-completion-table
minibuffer-completion-predicate))
- (ann-fun (or (completion-metadata-get all-md 'annotation-function)
- (plist-get completion-extra-properties
- :annotation-function)))
- (aff-fun (or (completion-metadata-get all-md 'affixation-function)
- (plist-get completion-extra-properties
- :affixation-function)))
+ (ann-fun (completion-metadata-get all-md 'annotation-function))
+ (aff-fun (completion-metadata-get all-md 'affixation-function))
(sort-fun (completion-metadata-get all-md 'display-sort-function))
(group-fun (completion-metadata-get all-md 'group-function))
(mainbuf (current-buffer))
@@ -2452,6 +2627,8 @@ These include:
(body-function
. ,#'(lambda (_window)
(with-current-buffer mainbuf
+ (when completion-auto-deselect
+ (add-hook 'after-change-functions #'completions--after-change nil t))
;; Remove the base-size tail because `sort' requires a properly
;; nil-terminated list.
(when last (setcdr last nil))
@@ -2465,7 +2642,8 @@ These include:
(funcall sort-fun completions)
(pcase completions-sort
('nil completions)
- ('alphabetical (sort completions #'string-lessp))
+ ('alphabetical (minibuffer-sort-alphabetically completions))
+ ('historical (minibuffer-sort-by-history completions))
(_ (funcall completions-sort completions)))))
;; After sorting, group the candidates using the
@@ -2717,8 +2895,14 @@ Also respects the obsolete wrapper hook `completion-in-region-functions'.
completion-in-region-mode-predicate)
(setq-local minibuffer-completion-auto-choose nil)
(add-hook 'post-command-hook #'completion-in-region--postch)
- (push `(completion-in-region-mode . ,completion-in-region-mode-map)
- minor-mode-overriding-map-alist)))
+ (let* ((keymap completion-in-region-mode-map)
+ (keymap (if minibuffer-visible-completions
+ (make-composed-keymap
+ (list minibuffer-visible-completions-map
+ keymap))
+ keymap)))
+ (push `(completion-in-region-mode . ,keymap)
+ minor-mode-overriding-map-alist))))
;; Define-minor-mode added our keymap to minor-mode-map-alist, but we want it
;; on minor-mode-overriding-map-alist instead.
@@ -2960,8 +3144,59 @@ For customizing this mode, it is better to use
`minibuffer-setup-hook' and `minibuffer-exit-hook' rather than
the mode hook of this mode."
:syntax-table nil
- :interactive nil)
-
+ :interactive nil
+ ;; Enable text conversion, but always make sure `RET' does
+ ;; something.
+ (setq text-conversion-style 'action)
+ (when minibuffer-visible-completions
+ (setq-local minibuffer-completion-auto-choose nil)))
+
+(defcustom minibuffer-visible-completions nil
+ "Whether candidates shown in *Completions* can be navigated from minibuffer.
+When non-nil, if the *Completions* buffer is displayed in a window,
+you can use the arrow keys in the minibuffer to move the cursor in
+the window showing the *Completions* buffer. Typing `RET' selects
+the highlighted completion candidate.
+If the *Completions* buffer is not displayed on the screen, or this
+variable is nil, the arrow keys move point in the minibuffer as usual,
+and `RET' accepts the input typed into the minibuffer."
+ :type 'boolean
+ :version "30.1")
+
+(defvar minibuffer-visible-completions--always-bind nil
+ "If non-nil, force the `minibuffer-visible-completions' bindings on.")
+
+(defun minibuffer-visible-completions--filter (cmd)
+ "Return CMD if `minibuffer-visible-completions' bindings should be active."
+ (if minibuffer-visible-completions--always-bind
+ cmd
+ (when-let ((window (get-buffer-window "*Completions*" 0)))
+ (when (and (eq (buffer-local-value 'completion-reference-buffer
+ (window-buffer window))
+ (window-buffer (active-minibuffer-window)))
+ (if (eq cmd #'minibuffer-choose-completion-or-exit)
+ (with-current-buffer (window-buffer window)
+ (get-text-property (point) 'completion--string))
+ t))
+ cmd))))
+
+(defun minibuffer-visible-completions-bind (binding)
+ "Use BINDING when completions are visible.
+Return an item that is enabled only when a window
+displaying the *Completions* buffer exists."
+ `(menu-item
+ "" ,binding
+ :filter ,#'minibuffer-visible-completions--filter))
+
+(defvar-keymap minibuffer-visible-completions-map
+ :doc "Local keymap for minibuffer input with visible completions."
+ "<left>" (minibuffer-visible-completions-bind #'minibuffer-previous-completion)
+ "<right>" (minibuffer-visible-completions-bind #'minibuffer-next-completion)
+ "<up>" (minibuffer-visible-completions-bind #'minibuffer-previous-line-completion)
+ "<down>" (minibuffer-visible-completions-bind #'minibuffer-next-line-completion)
+ "RET" (minibuffer-visible-completions-bind #'minibuffer-choose-completion-or-exit)
+ "C-g" (minibuffer-visible-completions-bind #'minibuffer-hide-completions))
+
;;; Completion tables.
(defun minibuffer--double-dollars (str)
@@ -3490,8 +3725,13 @@ Like `internal-complete-buffer', but removes BUFFER from the completion list."
(defun completion-emacs22-try-completion (string table pred point)
(let ((suffix (substring string point))
(completion (try-completion (substring string 0 point) table pred)))
- (if (not (stringp completion))
- completion
+ (cond
+ ((eq completion t)
+ (if (equal "" suffix)
+ t
+ (cons string point)))
+ ((not (stringp completion)) completion)
+ (t
;; Merge a trailing / in completion with a / after point.
;; We used to only do it for word completion, but it seems to make
;; sense for all completions.
@@ -3505,7 +3745,7 @@ Like `internal-complete-buffer', but removes BUFFER from the completion list."
(eq ?/ (aref suffix 0)))
;; This leaves point after the / .
(setq suffix (substring suffix 1)))
- (cons (concat completion suffix) (length completion)))))
+ (cons (concat completion suffix) (length completion))))))
(defun completion-emacs22-all-completions (string table pred point)
(let ((beforepoint (substring string 0 point)))
@@ -3763,108 +4003,202 @@ one large \"hole\" and a clumped-together \"oo\" match) higher
than the latter (which has two \"holes\" and three
one-letter-long matches).")
+(defvar completion-lazy-hilit nil
+ "If non-nil, request lazy highlighting of completion candidates.
+
+Lisp programs (a.k.a. \"front ends\") that present completion
+candidates may opt to bind this variable to a non-nil value when
+calling functions (such as `completion-all-completions') which
+produce completion candidates. This tells the underlying
+completion styles that they do not need to fontify (i.e.,
+propertize with the `face' property) completion candidates in a
+way that highlights the matching parts. Then it is the front end
+which presents the candidates that becomes responsible for this
+fontification. The front end does that by calling the function
+`completion-lazy-hilit' on each completion candidate that is to be
+displayed to the user.
+
+Note that only some completion styles take advantage of this
+variable for optimization purposes. Other styles will ignore the
+hint and fontify eagerly as usual. It is still safe for a
+front end to call `completion-lazy-hilit' in these situations.
+
+To author a completion style that takes advantage of this variable,
+see `completion-lazy-hilit-fn' and `completion-pcm--hilit-commonality'.")
+
+(defvar completion-lazy-hilit-fn nil
+ "Fontification function set by lazy-highlighting completions styles.
+When a given style wants to enable support for `completion-lazy-hilit'
+\(which see), that style should set this variable to a function of one
+argument. It will be called with each completion candidate, a string, to
+be displayed to the user, and should destructively propertize these
+strings with the `face' property.")
+
+(defun completion-lazy-hilit (str)
+ "Return a copy of completion candidate STR that is `face'-propertized.
+See documentation of the variable `completion-lazy-hilit' for more
+details."
+ (if (and completion-lazy-hilit completion-lazy-hilit-fn)
+ (funcall completion-lazy-hilit-fn (copy-sequence str))
+ str))
+
+(defun completion--hilit-from-re (string regexp &optional point-idx)
+ "Fontify STRING using REGEXP POINT-IDX.
+`completions-common-part' and `completions-first-difference' are
+used. POINT-IDX is the position of point in the presumed \"PCM\"
+pattern that was used to generate derive REGEXP from."
+(let* ((md (and regexp (string-match regexp string) (cddr (match-data t))))
+ (pos (if point-idx (match-beginning point-idx) (match-end 0)))
+ (me (and md (match-end 0)))
+ (from 0))
+ (while md
+ (add-face-text-property from (pop md) 'completions-common-part nil string)
+ (setq from (pop md)))
+ (if (> (length string) pos)
+ (add-face-text-property
+ pos (1+ pos)
+ 'completions-first-difference
+ nil string))
+ (unless (or (not me) (= from me))
+ (add-face-text-property from me 'completions-common-part nil string))
+ string))
+
+(defun completion--flex-score-1 (md-groups match-end len)
+ "Compute matching score of completion.
+The score lies in the range between 0 and 1, where 1 corresponds to
+the full match.
+MD-GROUPS is the \"group\" part of the match data.
+MATCH-END is the end of the match.
+LEN is the length of the completion string."
+ (let* ((from 0)
+ ;; To understand how this works, consider these simple
+ ;; ascii diagrams showing how the pattern "foo"
+ ;; flex-matches "fabrobazo", "fbarbazoo" and
+ ;; "barfoobaz":
+
+ ;; f abr o baz o
+ ;; + --- + --- +
+
+ ;; f barbaz oo
+ ;; + ------ ++
+
+ ;; bar foo baz
+ ;; +++
+
+ ;; "+" indicates parts where the pattern matched. A
+ ;; "hole" in the middle of the string is indicated by
+ ;; "-". Note that there are no "holes" near the edges
+ ;; of the string. The completion score is a number
+ ;; bound by (0..1] (i.e., larger than (but not equal
+ ;; to) zero, and smaller or equal to one): the higher
+ ;; the better and only a perfect match (pattern equals
+ ;; string) will have score 1. The formula takes the
+ ;; form of a quotient. For the numerator, we use the
+ ;; number of +, i.e. the length of the pattern. For
+ ;; the denominator, it first computes
+ ;;
+ ;; hole_i_contrib = 1 + (Li-1)^(1/tightness)
+ ;;
+ ;; , for each hole "i" of length "Li", where tightness
+ ;; is given by `flex-score-match-tightness'. The
+ ;; final value for the denominator is then given by:
+ ;;
+ ;; (SUM_across_i(hole_i_contrib) + 1) * len
+ ;;
+ ;; , where "len" is the string's length.
+ (score-numerator 0)
+ (score-denominator 0)
+ (last-b 0))
+ (while (and md-groups (car md-groups))
+ (let ((a from)
+ (b (pop md-groups)))
+ (setq
+ score-numerator (+ score-numerator (- b a)))
+ (unless (or (= a last-b)
+ (zerop last-b)
+ (= a len))
+ (setq
+ score-denominator (+ score-denominator
+ 1
+ (expt (- a last-b 1)
+ (/ 1.0
+ flex-score-match-tightness)))))
+ (setq
+ last-b b))
+ (setq from (pop md-groups)))
+ ;; If `pattern' doesn't have an explicit trailing any, the
+ ;; regex `re' won't produce match data representing the
+ ;; region after the match. We need to account to account
+ ;; for that extra bit of match (bug#42149).
+ (unless (= from match-end)
+ (let ((a from)
+ (b match-end))
+ (setq
+ score-numerator (+ score-numerator (- b a)))
+ (unless (or (= a last-b)
+ (zerop last-b)
+ (= a len))
+ (setq
+ score-denominator (+ score-denominator
+ 1
+ (expt (- a last-b 1)
+ (/ 1.0
+ flex-score-match-tightness)))))
+ (setq
+ last-b b)))
+ (/ score-numerator (* len (1+ score-denominator)) 1.0)))
+
+(defvar completion--flex-score-last-md nil
+ "Helper variable for `completion--flex-score'.")
+
+(defun completion--flex-score (str re &optional dont-error)
+ "Compute flex score of completion STR based on RE.
+If DONT-ERROR, just return nil if RE doesn't match STR."
+ (let ((case-fold-search completion-ignore-case))
+ (cond ((string-match re str)
+ (let* ((match-end (match-end 0))
+ (md (cddr
+ (setq
+ completion--flex-score-last-md
+ (match-data t completion--flex-score-last-md)))))
+ (completion--flex-score-1 md match-end (length str))))
+ ((not dont-error)
+ (error "Internal error: %s does not match %s" re str)))))
+
+(defvar completion-pcm--regexp nil
+ "Regexp from PCM pattern in `completion-pcm--hilit-commonality'.")
+
(defun completion-pcm--hilit-commonality (pattern completions)
"Show where and how well PATTERN matches COMPLETIONS.
PATTERN, a list of symbols and strings as seen
`completion-pcm--merge-completions', is assumed to match every
-string in COMPLETIONS. Return a deep copy of COMPLETIONS where
-each string is propertized with `completion-score', a number
-between 0 and 1, and with faces `completions-common-part',
-`completions-first-difference' in the relevant segments."
+string in COMPLETIONS.
+
+If `completion-lazy-hilit' is nil, return a deep copy of
+COMPLETIONS where each string is propertized with
+`completion-score', a number between 0 and 1, and with faces
+`completions-common-part', `completions-first-difference' in the
+relevant segments.
+
+Else, if `completion-lazy-hilit' is t, return COMPLETIONS
+unchanged, but setup a suitable `completion-lazy-hilit-fn' (which
+see) for later lazy highlighting."
+ (setq completion-pcm--regexp nil
+ completion-lazy-hilit-fn nil)
(cond
((and completions (cl-loop for e in pattern thereis (stringp e)))
(let* ((re (completion-pcm--pattern->regex pattern 'group))
- (point-idx (completion-pcm--pattern-point-idx pattern))
- (case-fold-search completion-ignore-case)
- last-md)
- (mapcar
- (lambda (str)
- ;; Don't modify the string itself.
- (setq str (copy-sequence str))
- (unless (string-match re str)
- (error "Internal error: %s does not match %s" re str))
- (let* ((pos (if point-idx (match-beginning point-idx) (match-end 0)))
- (match-end (match-end 0))
- (md (cddr (setq last-md (match-data t last-md))))
- (from 0)
- (end (length str))
- ;; To understand how this works, consider these simple
- ;; ascii diagrams showing how the pattern "foo"
- ;; flex-matches "fabrobazo", "fbarbazoo" and
- ;; "barfoobaz":
-
- ;; f abr o baz o
- ;; + --- + --- +
-
- ;; f barbaz oo
- ;; + ------ ++
-
- ;; bar foo baz
- ;; +++
-
- ;; "+" indicates parts where the pattern matched. A
- ;; "hole" in the middle of the string is indicated by
- ;; "-". Note that there are no "holes" near the edges
- ;; of the string. The completion score is a number
- ;; bound by (0..1] (i.e., larger than (but not equal
- ;; to) zero, and smaller or equal to one): the higher
- ;; the better and only a perfect match (pattern equals
- ;; string) will have score 1. The formula takes the
- ;; form of a quotient. For the numerator, we use the
- ;; number of +, i.e. the length of the pattern. For
- ;; the denominator, it first computes
- ;;
- ;; hole_i_contrib = 1 + (Li-1)^(1/tightness)
- ;;
- ;; , for each hole "i" of length "Li", where tightness
- ;; is given by `flex-score-match-tightness'. The
- ;; final value for the denominator is then given by:
- ;;
- ;; (SUM_across_i(hole_i_contrib) + 1) * len
- ;;
- ;; , where "len" is the string's length.
- (score-numerator 0)
- (score-denominator 0)
- (last-b 0)
- (update-score-and-face
- (lambda (a b)
- "Update score and face given match range (A B)."
- (add-face-text-property a b
- 'completions-common-part
- nil str)
- (setq
- score-numerator (+ score-numerator (- b a)))
- (unless (or (= a last-b)
- (zerop last-b)
- (= a (length str)))
- (setq
- score-denominator (+ score-denominator
- 1
- (expt (- a last-b 1)
- (/ 1.0
- flex-score-match-tightness)))))
- (setq
- last-b b))))
- (while md
- (funcall update-score-and-face from (pop md))
- (setq from (pop md)))
- ;; If `pattern' doesn't have an explicit trailing any, the
- ;; regex `re' won't produce match data representing the
- ;; region after the match. We need to account to account
- ;; for that extra bit of match (bug#42149).
- (unless (= from match-end)
- (funcall update-score-and-face from match-end))
- (if (> (length str) pos)
- (add-face-text-property
- pos (1+ pos)
- 'completions-first-difference
- nil str))
- (unless (zerop (length str))
- (put-text-property
- 0 1 'completion-score
- (/ score-numerator (* end (1+ score-denominator)) 1.0) str)))
- str)
- completions)))
+ (point-idx (completion-pcm--pattern-point-idx pattern)))
+ (setq completion-pcm--regexp re)
+ (cond (completion-lazy-hilit
+ (setq completion-lazy-hilit-fn
+ (lambda (str) (completion--hilit-from-re str re point-idx)))
+ completions)
+ (t
+ (mapcar
+ (lambda (str)
+ (completion--hilit-from-re (copy-sequence str) re point-idx))
+ completions)))))
(t completions)))
(defun completion-pcm--find-all-completions (string table pred point
@@ -4039,7 +4373,9 @@ the same set of elements."
(unique (or (and (eq prefix t) (setq prefix fixed))
(and (stringp prefix)
(eq t (try-completion prefix comps))))))
- (unless (or (eq elem 'prefix)
+ ;; if the common prefix is unique, it also is a common
+ ;; suffix, so we should add it for `prefix' elements
+ (unless (or (and (eq elem 'prefix) (not unique))
(equal prefix ""))
(push prefix res))
;; If there's only one completion, `elem' is not useful
@@ -4199,36 +4535,39 @@ that is non-nil."
(defun completion--flex-adjust-metadata (metadata)
"If `flex' is actually doing filtering, adjust sorting."
- (let ((flex-is-filtering-p
- ;; JT@2019-12-23: FIXME: this is kinda wrong. What we need
- ;; to test here is "some input that actually leads/led to
- ;; flex filtering", not "something after the minibuffer
- ;; prompt". E.g. The latter is always true for file
- ;; searches, meaning we'll be doing extra work when we
- ;; needn't.
- (or (not (window-minibuffer-p))
- (> (point-max) (minibuffer-prompt-end))))
+ (let ((flex-is-filtering-p completion-pcm--regexp)
(existing-dsf
(completion-metadata-get metadata 'display-sort-function))
(existing-csf
(completion-metadata-get metadata 'cycle-sort-function)))
(cl-flet
- ((compose-flex-sort-fn
- (existing-sort-fn) ; wish `cl-flet' had proper indentation...
- (lambda (completions)
- (sort
- (funcall existing-sort-fn completions)
- (lambda (c1 c2)
- (let ((s1 (get-text-property 0 'completion-score c1))
- (s2 (get-text-property 0 'completion-score c2)))
- (> (or s1 0) (or s2 0))))))))
+ ((compose-flex-sort-fn (existing-sort-fn)
+ (lambda (completions)
+ (let* ((sorted (sort
+ (mapcar
+ (lambda (str)
+ (cons
+ (- (completion--flex-score
+ (or (get-text-property
+ 0 'completion--unquoted str)
+ str)
+ completion-pcm--regexp))
+ str))
+ (if existing-sort-fn
+ (funcall existing-sort-fn completions)
+ completions))
+ #'car-less-than-car))
+ (cell sorted))
+ ;; Reuse the list
+ (while cell
+ (setcar cell (cdar cell))
+ (pop cell))
+ sorted))))
`(metadata
,@(and flex-is-filtering-p
- `((display-sort-function
- . ,(compose-flex-sort-fn (or existing-dsf #'identity)))))
+ `((display-sort-function . ,(compose-flex-sort-fn existing-dsf))))
,@(and flex-is-filtering-p
- `((cycle-sort-function
- . ,(compose-flex-sort-fn (or existing-csf #'identity)))))
+ `((cycle-sort-function . ,(compose-flex-sort-fn existing-csf))))
,@(cdr metadata)))))
(defun completion-flex--make-flex-pattern (pattern)
@@ -4382,6 +4721,11 @@ See `completing-read' for the meaning of the arguments."
;; in minibuffer-local-filename-completion-map can
;; override bindings in base-keymap.
base-keymap)))
+ (keymap (if minibuffer-visible-completions
+ (make-composed-keymap
+ (list minibuffer-visible-completions-map
+ keymap))
+ keymap))
(buffer (current-buffer))
(c-i-c completion-ignore-case)
(result
@@ -4501,61 +4845,74 @@ selected by these commands to the minibuffer."
:type 'boolean
:version "29.1")
-(defun minibuffer-next-completion (&optional n)
+(defun minibuffer-next-completion (&optional n vertical)
"Move to the next item in its completions window from the minibuffer.
+When the optional argument VERTICAL is non-nil, move vertically
+to the next item on the next line using `next-line-completion'.
+Otherwise, move to the next item horizontally using `next-completion'.
When `minibuffer-completion-auto-choose' is non-nil, then also
-insert the selected completion to the minibuffer."
+insert the selected completion candidate to the minibuffer."
(interactive "p")
- (let ((auto-choose minibuffer-completion-auto-choose)
- (buf (current-buffer)))
+ (let ((auto-choose minibuffer-completion-auto-choose))
(with-minibuffer-completions-window
(when completions-highlight-face
(setq-local cursor-face-highlight-nonselected-window t))
- (next-completion (or n 1))
+ (if vertical
+ (next-line-completion (or n 1))
+ (next-completion (or n 1)))
(when auto-choose
- (let* ((completion-use-base-affixes t)
- ;; Backported fix for bug#62700
- (md
- (with-current-buffer buf
- (completion--field-metadata (minibuffer--completion-prompt-end))))
- (base-suffix
- (if (eq (alist-get 'category (cdr md)) 'file)
- (with-current-buffer buf
- (buffer-substring
- (save-excursion (or (search-forward "/" nil t) (point-max)))
- (point-max)))
- ""))
- (completion-base-affixes (list (car completion-base-affixes) base-suffix)))
+ (let ((completion-use-base-affixes t)
+ (completion-auto-deselect nil))
(choose-completion nil t t))))))
(defun minibuffer-previous-completion (&optional n)
"Move to the previous item in its completions window from the minibuffer.
When `minibuffer-completion-auto-choose' is non-nil, then also
-insert the selected completion to the minibuffer."
+insert the selected completion candidate to the minibuffer."
(interactive "p")
(minibuffer-next-completion (- (or n 1))))
+(defun minibuffer-next-line-completion (&optional n)
+ "Move to the next completion line from the minibuffer.
+This means to move to the completion candidate on the next line
+in the *Completions* buffer while point stays in the minibuffer.
+When `minibuffer-completion-auto-choose' is non-nil, then also
+insert the selected completion candidate to the minibuffer."
+ (interactive "p")
+ (minibuffer-next-completion (or n 1) t))
+
+(defun minibuffer-previous-line-completion (&optional n)
+ "Move to the previous completion line from the minibuffer.
+This means to move to the completion candidate on the previous line
+in the *Completions* buffer while point stays in the minibuffer.
+When `minibuffer-completion-auto-choose' is non-nil, then also
+insert the selected completion candidate to the minibuffer."
+ (interactive "p")
+ (minibuffer-next-completion (- (or n 1)) 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
+With prefix argument NO-EXIT, insert the completion candidate 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
+If NO-QUIT is non-nil, insert the completion candidate at point to the
minibuffer, but don't quit the completions window."
(interactive "P")
- ;; Backported fix for bug#62700
- (let* ((md (completion--field-metadata (minibuffer--completion-prompt-end)))
- (base-suffix
- (if (eq (alist-get 'category (cdr md)) 'file)
- (buffer-substring
- (save-excursion (or (search-forward "/" nil t) (point-max)))
- (point-max))
- "")))
- (with-minibuffer-completions-window
- (let ((completion-use-base-affixes t)
- (completion-base-affixes (list (car completion-base-affixes) base-suffix)))
- (choose-completion nil no-exit no-quit)))))
+ (with-minibuffer-completions-window
+ (let ((completion-use-base-affixes t))
+ (choose-completion nil no-exit no-quit))))
+
+(defun minibuffer-choose-completion-or-exit (&optional no-exit no-quit)
+ "Choose the completion from the minibuffer or exit the minibuffer.
+When `minibuffer-choose-completion' can't find a completion candidate
+in the completions window, then exit the minibuffer using its present
+contents."
+ (interactive "P")
+ (condition-case nil
+ (let ((choose-completion-deselect-if-after t))
+ (minibuffer-choose-completion no-exit no-quit))
+ (error (minibuffer-complete-and-exit))))
(defun minibuffer-complete-history ()
"Complete the minibuffer history as far as possible.
@@ -4572,13 +4929,15 @@ instead of the default completion table."
history)
(user-error "No history available"))))
;; FIXME: Can we make it work for CRM?
- (completion-in-region
- (minibuffer--completion-prompt-end) (point-max)
- (lambda (string pred action)
- (if (eq action 'metadata)
- '(metadata (display-sort-function . identity)
- (cycle-sort-function . identity))
- (complete-with-action action completions string pred))))))
+ (let ((completion-in-region-mode-predicate
+ (lambda () (get-buffer-window "*Completions*" 0))))
+ (completion-in-region
+ (minibuffer--completion-prompt-end) (point-max)
+ (lambda (string pred action)
+ (if (eq action 'metadata)
+ '(metadata (display-sort-function . identity)
+ (cycle-sort-function . identity))
+ (complete-with-action action completions string pred)))))))
(defun minibuffer-complete-defaults ()
"Complete minibuffer defaults as far as possible.
@@ -4589,7 +4948,9 @@ instead of the completion table."
(functionp minibuffer-default-add-function))
(setq minibuffer-default-add-done t
minibuffer-default (funcall minibuffer-default-add-function)))
- (let ((completions (ensure-list minibuffer-default)))
+ (let ((completions (ensure-list minibuffer-default))
+ (completion-in-region-mode-predicate
+ (lambda () (get-buffer-window "*Completions*" 0))))
(completion-in-region
(minibuffer--completion-prompt-end) (point-max)
(lambda (string pred action)
@@ -4644,6 +5005,232 @@ is included in the return value."
default)))
": "))
+
+;;; On screen keyboard support.
+;; Try to display the on screen keyboard whenever entering the
+;; mini-buffer, and hide it whenever leaving.
+
+(defvar minibuffer-on-screen-keyboard-timer nil
+ "Timer run upon exiting the minibuffer.
+It will hide the on screen keyboard when necessary.")
+
+(defvar minibuffer-on-screen-keyboard-displayed nil
+ "Whether or not the on-screen keyboard has been displayed.
+Set inside `minibuffer-setup-on-screen-keyboard'.")
+
+(defun minibuffer-setup-on-screen-keyboard ()
+ "Maybe display the on-screen keyboard in the current frame.
+Display the on-screen keyboard in the current frame if the
+last device to have sent an input event is not a keyboard.
+This is run upon minibuffer setup."
+ ;; Don't hide the on screen keyboard later on.
+ (when minibuffer-on-screen-keyboard-timer
+ (cancel-timer minibuffer-on-screen-keyboard-timer)
+ (setq minibuffer-on-screen-keyboard-timer nil))
+ (setq minibuffer-on-screen-keyboard-displayed nil)
+ (when (and (framep last-event-frame)
+ (not (memq (device-class last-event-frame
+ last-event-device)
+ '(keyboard core-keyboard))))
+ (setq minibuffer-on-screen-keyboard-displayed
+ (frame-toggle-on-screen-keyboard (selected-frame) nil))))
+
+(defun minibuffer-exit-on-screen-keyboard ()
+ "Hide the on-screen keyboard if it was displayed.
+Hide the on-screen keyboard in a timer set to run in 0.1 seconds.
+It will be canceled if the minibuffer is displayed again within
+that timeframe.
+
+Do not hide the on screen keyboard inside a recursive edit.
+Likewise, do not hide the on screen keyboard if point in the
+window that will be selected after exiting the minibuffer is not
+on read-only text.
+
+The latter is implemented in `touch-screen.el'."
+ (unless (or (not minibuffer-on-screen-keyboard-displayed)
+ (> (recursion-depth) 1))
+ (when minibuffer-on-screen-keyboard-timer
+ (cancel-timer minibuffer-on-screen-keyboard-timer))
+ (setq minibuffer-on-screen-keyboard-timer
+ (run-with-timer 0.1 nil #'frame-toggle-on-screen-keyboard
+ (selected-frame) t))))
+
+(add-hook 'minibuffer-setup-hook #'minibuffer-setup-on-screen-keyboard)
+(add-hook 'minibuffer-exit-hook #'minibuffer-exit-on-screen-keyboard)
+
+(defvar minibuffer-regexp-mode)
+
+(defun minibuffer--regexp-propertize ()
+ "In current minibuffer propertize parens and slashes in regexps.
+Put punctuation `syntax-table' property on selected paren and
+backslash characters in current buffer to make `show-paren-mode'
+and `blink-matching-paren' more user-friendly."
+ (let (in-char-alt-p)
+ (save-excursion
+ (with-silent-modifications
+ (remove-text-properties (point-min) (point-max) '(syntax-table nil))
+ (goto-char (point-min))
+ (while (re-search-forward
+ (rx (| (group "\\\\")
+ (: "\\" (| (group (in "(){}"))
+ (group "[")
+ (group "]")))
+ (group "[:" (+ (in "A-Za-z")) ":]")
+ (group "[")
+ (group "]")
+ (group (in "(){}"))))
+ (point-max) 'noerror)
+ (cond
+ ((match-beginning 1)) ; \\, skip
+ ((match-beginning 2) ; \( \) \{ \}
+ (if in-char-alt-p
+ ;; Within character alternative, set symbol syntax for
+ ;; paren only.
+ (put-text-property (1- (point)) (point) 'syntax-table '(3))
+ ;; Not within character alternative, set symbol syntax for
+ ;; backslash only.
+ (put-text-property (- (point) 2) (1- (point)) 'syntax-table '(3))))
+ ((match-beginning 3) ; \[
+ (if in-char-alt-p
+ (progn
+ ;; Set symbol syntax for backslash.
+ (put-text-property (- (point) 2) (1- (point)) 'syntax-table '(3))
+ ;; Re-read bracket we might be before a character class.
+ (backward-char))
+ ;; Set symbol syntax for bracket.
+ (put-text-property (1- (point)) (point) 'syntax-table '(3))))
+ ((match-beginning 4) ; \]
+ (if in-char-alt-p
+ (progn
+ ;; Within character alternative, set symbol syntax for
+ ;; backslash, exit alternative.
+ (put-text-property (- (point) 2) (1- (point)) 'syntax-table '(3))
+ (setq in-char-alt-p nil))
+ ;; Not within character alternative, set symbol syntax for
+ ;; bracket.
+ (put-text-property (1- (point)) (point) 'syntax-table '(3))))
+ ((match-beginning 5)) ; POSIX character class, skip
+ ((match-beginning 6) ; [
+ (if in-char-alt-p
+ ;; Within character alternative, set symbol syntax.
+ (put-text-property (1- (point)) (point) 'syntax-table '(3))
+ ;; Start new character alternative.
+ (setq in-char-alt-p t)
+ ;; Looking for immediately following non-closing ].
+ (when (looking-at "\\^?\\]")
+ ;; Non-special right bracket, set symbol syntax.
+ (goto-char (match-end 0))
+ (put-text-property (1- (point)) (point) 'syntax-table '(3)))))
+ ((match-beginning 7) ; ]
+ (if in-char-alt-p
+ (setq in-char-alt-p nil)
+ ;; The only warning we can emit before RET.
+ (message "Not in character alternative")))
+ ((match-beginning 8) ; (){}
+ ;; Plain parenthesis or brace, set symbol syntax.
+ (put-text-property (1- (point)) (point) 'syntax-table '(3)))))))))
+
+;; The following variable is set by 'minibuffer--regexp-before-change'.
+;; If non-nil, either 'minibuffer--regexp-post-self-insert' or
+;; 'minibuffer--regexp-after-change', whichever comes next, will
+;; propertize the minibuffer via 'minibuffer--regexp-propertize' and
+;; reset this variable to nil, avoiding to propertize the buffer twice.
+(defvar-local minibuffer--regexp-primed nil
+ "Non-nil when minibuffer contents change.")
+
+(defun minibuffer--regexp-before-change (_a _b)
+ "`minibuffer-regexp-mode' function on `before-change-functions'."
+ (setq minibuffer--regexp-primed t))
+
+(defun minibuffer--regexp-after-change (_a _b _c)
+ "`minibuffer-regexp-mode' function on `after-change-functions'."
+ (when minibuffer--regexp-primed
+ (setq minibuffer--regexp-primed nil)
+ (minibuffer--regexp-propertize)))
+
+(defun minibuffer--regexp-post-self-insert ()
+ "`minibuffer-regexp-mode' function on `post-self-insert-hook'."
+ (when minibuffer--regexp-primed
+ (setq minibuffer--regexp-primed nil)
+ (minibuffer--regexp-propertize)))
+
+(defvar minibuffer--regexp-prompt-regexp
+ "\\(?:Posix search\\|RE search\\|Search for regexp\\|Query replace regexp\\)"
+ "Regular expression compiled from `minibuffer-regexp-prompts'.")
+
+(defcustom minibuffer-regexp-prompts
+ '("Posix search" "RE search" "Search for regexp" "Query replace regexp")
+ "List of regular expressions that trigger `minibuffer-regexp-mode' features.
+The features of `minibuffer-regexp-mode' will be activated in a minibuffer
+interaction if and only if a prompt matching some regexp in this list
+appears at the beginning of the minibuffer.
+
+Setting this variable directly with `setq' has no effect; instead,
+either use \\[customize-option] interactively or use `setopt'."
+ :type '(repeat (string :tag "Prompt"))
+ :set (lambda (sym val)
+ (set-default sym val)
+ (when val
+ (setq minibuffer--regexp-prompt-regexp
+ (concat "\\(?:" (mapconcat 'regexp-quote val "\\|") "\\)"))))
+ :version "30.1")
+
+(defun minibuffer--regexp-setup ()
+ "Function to activate`minibuffer-regexp-mode' in current buffer.
+Run by `minibuffer-setup-hook'."
+ (if (and minibuffer-regexp-mode
+ (save-excursion
+ (goto-char (point-min))
+ (looking-at minibuffer--regexp-prompt-regexp)))
+ (progn
+ (setq-local parse-sexp-lookup-properties t)
+ (add-hook 'before-change-functions #'minibuffer--regexp-before-change nil t)
+ (add-hook 'after-change-functions #'minibuffer--regexp-after-change nil t)
+ (add-hook 'post-self-insert-hook #'minibuffer--regexp-post-self-insert nil t))
+ ;; Make sure.
+ (minibuffer--regexp-exit)))
+
+(defun minibuffer--regexp-exit ()
+ "Function to deactivate `minibuffer-regexp-mode' in current buffer.
+Run by `minibuffer-exit-hook'."
+ (with-silent-modifications
+ (remove-text-properties (point-min) (point-max) '(syntax-table nil)))
+ (setq-local parse-sexp-lookup-properties nil)
+ (remove-hook 'before-change-functions #'minibuffer--regexp-before-change t)
+ (remove-hook 'after-change-functions #'minibuffer--regexp-after-change t)
+ (remove-hook 'post-self-insert-hook #'minibuffer--regexp-post-self-insert t))
+
+(define-minor-mode minibuffer-regexp-mode
+ "Minor mode for editing regular expressions in the minibuffer.
+Highlight parens via `show-paren-mode' and `blink-matching-paren'
+in a user-friendly way, avoid reporting alleged paren mismatches
+and make sexp navigation more intuitive.
+
+The list of prompts activating this mode in specific minibuffer
+interactions is customizable via `minibuffer-regexp-prompts'."
+ :global t
+ :initialize 'custom-initialize-delay
+ :init-value t
+ (if minibuffer-regexp-mode
+ (progn
+ (add-hook 'minibuffer-setup-hook #'minibuffer--regexp-setup)
+ (add-hook 'minibuffer-exit-hook #'minibuffer--regexp-exit))
+ ;; Clean up - why is Vminibuffer_list not available in Lisp?
+ (dolist (buffer (buffer-list))
+ (when (and (minibufferp)
+ parse-sexp-lookup-properties
+ (with-current-buffer buffer
+ (save-excursion
+ (goto-char (point-min))
+ (looking-at minibuffer--regexp-prompt-regexp))))
+ (with-current-buffer buffer
+ (with-silent-modifications
+ (remove-text-properties
+ (point-min) (point-max) '(syntax-table nil)))
+ (setq-local parse-sexp-lookup-properties t))))
+ (remove-hook 'minibuffer-setup-hook #'minibuffer--regexp-setup)
+ (remove-hook 'minibuffer-exit-hook #'minibuffer--regexp-exit)))
+
(provide 'minibuffer)
;;; minibuffer.el ends here
diff --git a/lisp/misc.el b/lisp/misc.el
index b36ca6416d9..fb40d1c16a3 100644
--- a/lisp/misc.el
+++ b/lisp/misc.el
@@ -76,6 +76,10 @@ The same column is preserved after moving to a new line."
:group 'editing
:version "29.1")
+(defun duplicate--insert-copies (n string)
+ "Insert N copies of STRING at point."
+ (insert (mapconcat #'identity (make-list n string))))
+
;;;###autoload
(defun duplicate-line (&optional n)
"Duplicate the current line N times.
@@ -86,21 +90,33 @@ Also see the `copy-from-above-command' command."
(interactive "p")
(unless n
(setq n 1))
- (let ((line (buffer-substring (line-beginning-position) (line-end-position)))
+ (let ((line (concat (buffer-substring (line-beginning-position)
+ (line-end-position))
+ "\n"))
(pos (point))
(col (current-column)))
(forward-line 1)
(unless (bolp)
(insert "\n"))
- (dotimes (_ n)
- (insert line "\n"))
+ (duplicate--insert-copies n line)
(unless (< duplicate-line-final-position 0)
(goto-char pos))
(unless (eq duplicate-line-final-position 0)
(forward-line duplicate-line-final-position)
(move-to-column col))))
-(declare-function rectangle--duplicate-right "rect" (n))
+(defcustom duplicate-region-final-position 0
+ "Where the region ends up after duplicating a region with `duplicate-dwim'.
+When 0, leave the region in place.
+When 1, put the region around the first copy.
+When -1, put the region around the last copy."
+ :type '(choice (const :tag "Leave region in place" 0)
+ (const :tag "Put region around first copy" 1)
+ (const :tag "Put region around last copy" -1))
+ :group 'editing
+ :version "30.1")
+
+(declare-function rectangle--duplicate-right "rect" (n displacement))
;; `duplicate-dwim' preserves an active region and changes the buffer
;; outside of it: disregard the region when immediately undoing the
@@ -113,25 +129,40 @@ Also see the `copy-from-above-command' command."
If the region is inactive, duplicate the current line (like `duplicate-line').
Otherwise, duplicate the region, which remains active afterwards.
If the region is rectangular, duplicate on its right-hand side.
-Interactively, N is the prefix numeric argument, and defaults to 1."
+Interactively, N is the prefix numeric argument, and defaults to 1.
+The variables `duplicate-line-final-position' and
+`duplicate-region-final-position' control the position of point
+and the region after the duplication."
(interactive "p")
(unless n
(setq n 1))
(cond
+ ((<= n 0) nil)
;; Duplicate rectangle.
((bound-and-true-p rectangle-mark-mode)
- (rectangle--duplicate-right n)
+ (rectangle--duplicate-right n
+ (if (< duplicate-region-final-position 0)
+ n
+ duplicate-region-final-position))
(setq deactivate-mark nil))
;; Duplicate (contiguous) region.
((use-region-p)
(let* ((beg (region-beginning))
(end (region-end))
- (text (buffer-substring beg end)))
+ (text (buffer-substring beg end))
+ (pt (point))
+ (mk (mark)))
(save-excursion
(goto-char end)
- (dotimes (_ n)
- (insert text))))
+ (duplicate--insert-copies n text))
+ (let* ((displace (if (< duplicate-region-final-position 0)
+ n
+ duplicate-region-final-position))
+ (d (* displace (- end beg))))
+ (unless (zerop d)
+ (push-mark (+ mk d))
+ (goto-char (+ pt d)))))
(setq deactivate-mark nil))
;; Duplicate line.
@@ -187,18 +218,22 @@ is an upper-case character."
(upcase-region (point) (progn (forward-char arg) (point)))))
;;;###autoload
-(defun forward-to-word (arg)
- "Move forward until encountering the beginning of a word.
-With argument, do this that many times."
+(defun forward-to-word (&optional arg)
+ "Move forward until encountering the beginning of the ARGth word.
+ARG defaults to 1. When called interactively, ARG is the prefix
+numeric argument."
(interactive "^p")
+ (unless arg (setq arg 1))
(or (re-search-forward (if (> arg 0) "\\W\\b" "\\b\\W") nil t arg)
(goto-char (if (> arg 0) (point-max) (point-min)))))
;;;###autoload
-(defun backward-to-word (arg)
- "Move backward until encountering the end of a word.
-With argument, do this that many times."
+(defun backward-to-word (&optional arg)
+ "Move backward until encountering the end of the ARGth word.
+ARG defaults to 1. When called interactively, ARG is the prefix
+numeric argument."
(interactive "^p")
+ (unless arg (setq arg 1))
(forward-to-word (- arg)))
;;;###autoload
diff --git a/lisp/misearch.el b/lisp/misearch.el
index 56877ceb5d3..f53acae472e 100644
--- a/lisp/misearch.el
+++ b/lisp/misearch.el
@@ -387,6 +387,157 @@ whose file names match the specified wildcard."
(goto-char (if isearch-forward (point-min) (point-max)))
(isearch-forward-regexp nil t)))
+
+;;; Global multi-file replacements as diff
+
+(defcustom multi-file-diff-unsaved 'save-buffers
+ "What to do with unsaved edits when showing multi-file replacements as diffs.
+If the value is `save-buffers', save unsaved buffers before creating diff.
+If the value is `use-file', use text from the file even when the
+file-visiting buffer is modified.
+If the value is `use-modified-buffer', use text from the file-visiting
+modified buffer to be able to use unsaved changes."
+ :type '(choice
+ (const :tag "Save buffers" save-buffers)
+ (const :tag "Use file" use-file)
+ (const :tag "Use modified buffer" use-modified-buffer))
+ :version "30.1")
+
+(declare-function diff-setup-whitespace "diff-mode" ())
+(declare-function diff-setup-buffer-type "diff-mode" ())
+
+(defun multi-file-replace-as-diff (files from-string replacements regexp-flag delimited-flag)
+ "Show as diffs replacements of FROM-STRING with REPLACEMENTS.
+FILES is a list of file names. REGEXP-FLAG and DELIMITED-FLAG have
+the same meaning as in `perform-replace'."
+ (require 'diff)
+ (let ((inhibit-message t)
+ (diff-buffer (get-buffer-create "*replace-diff*")))
+ (when (eq multi-file-diff-unsaved 'save-buffers)
+ (save-some-buffers t (lambda ()
+ (seq-some (lambda (f-or-b)
+ (equal f-or-b buffer-file-name))
+ files))))
+ (with-current-buffer diff-buffer
+ (buffer-disable-undo (current-buffer))
+ (let ((inhibit-read-only t))
+ (erase-buffer))
+ ;; Make the *vc-diff* buffer read only, the diff-mode key
+ ;; bindings are nicer for read only buffers.
+ (setq buffer-read-only t)
+ (diff-mode))
+ (dolist (file-name files)
+ (let* ((file-exists (file-exists-p file-name))
+ (file-buffer
+ (when (or (not file-exists)
+ (eq multi-file-diff-unsaved 'use-modified-buffer))
+ (find-buffer-visiting file-name))))
+ (when file-name
+ (with-temp-buffer
+ (if (and file-buffer
+ (or (not file-exists)
+ (buffer-modified-p file-buffer)))
+ (insert-buffer-substring file-buffer)
+ (insert-file-contents file-name))
+ (goto-char (point-min))
+ (perform-replace from-string replacements nil regexp-flag delimited-flag)
+ (multi-file-diff-no-select
+ (if file-exists file-name file-buffer)
+ (current-buffer) nil diff-buffer
+ (concat file-name "~") file-name)))))
+ (with-current-buffer diff-buffer
+ (diff-setup-whitespace)
+ (diff-setup-buffer-type)
+ (buffer-enable-undo (current-buffer))
+ (setq-local revert-buffer-function
+ (lambda (_ignore-auto _noconfirm)
+ (multi-file-replace-as-diff
+ files from-string replacements regexp-flag delimited-flag)))
+ (goto-char (point-min)))
+ (pop-to-buffer diff-buffer)))
+
+;;;###autoload
+(defun multi-file-replace-regexp-as-diff (files regexp to-string &optional delimited)
+ "Show as diffs replacements of REGEXP with TO-STRING in FILES.
+DELIMITED has the same meaning as in `replace-regexp'.
+The replacements are displayed in the buffer *replace-diff* that
+you can later apply as a patch after reviewing the changes."
+ (interactive
+ (let ((files (multi-isearch-read-files))
+ (common
+ (query-replace-read-args
+ (concat "Replace"
+ (if current-prefix-arg " word" "")
+ " regexp as diff in files")
+ t t)))
+ (list files (nth 0 common) (nth 1 common) (nth 2 common))))
+ (multi-file-replace-as-diff files regexp to-string t delimited))
+
+;;;###autoload
+(defun replace-regexp-as-diff (regexp to-string &optional delimited)
+ "Show as diffs replacements of REGEXP with TO-STRING in the current buffer.
+DELIMITED has the same meaning as in `replace-regexp'.
+The replacements are displayed in the buffer *replace-diff* that
+you can later apply as a patch after reviewing the changes."
+ (interactive
+ (let ((common
+ (query-replace-read-args
+ (concat "Replace"
+ (if current-prefix-arg " word" "")
+ " regexp as diff")
+ t t)))
+ (list (nth 0 common) (nth 1 common) (nth 2 common))))
+ (multi-file-replace-as-diff
+ (list buffer-file-name) regexp to-string t delimited))
+
+(defvar diff-use-labels)
+(declare-function diff-check-labels "diff" (&optional force))
+(declare-function diff-file-local-copy "diff" (file-or-buf))
+
+(defun multi-file-diff-no-select (old new &optional switches buf label-old label-new)
+ ;; Based on `diff-no-select' tailored to multi-file diffs.
+ "Compare the OLD and NEW file/buffer.
+If the optional SWITCHES is nil, the switches specified in the
+variable `diff-switches' are passed to the diff command,
+otherwise SWITCHES is used. SWITCHES can be a string or a list
+of strings. BUF should be non-nil. LABEL-OLD and LABEL-NEW
+specify labels to use for file names."
+ (unless (bufferp new) (setq new (expand-file-name new)))
+ (unless (bufferp old) (setq old (expand-file-name old)))
+ (or switches (setq switches diff-switches)) ; If not specified, use default.
+ (setq switches (ensure-list switches))
+ (diff-check-labels)
+ (let* ((old-alt (diff-file-local-copy old))
+ (new-alt (diff-file-local-copy new))
+ (command
+ (mapconcat #'identity
+ `(,diff-command
+ ;; Use explicitly specified switches
+ ,@switches
+ ,@(mapcar #'shell-quote-argument
+ (nconc
+ (and (or old-alt new-alt)
+ (eq diff-use-labels t)
+ (list "--label"
+ (cond ((stringp label-old) label-old)
+ ((stringp old) old)
+ ((prin1-to-string old)))
+ "--label"
+ (cond ((stringp label-new) label-new)
+ ((stringp new) new)
+ ((prin1-to-string new)))))
+ (list (or old-alt old)
+ (or new-alt new)))))
+ " ")))
+ (with-current-buffer buf
+ (let ((inhibit-read-only t))
+ (insert command "\n")
+ (call-process shell-file-name nil buf nil
+ shell-command-switch command))
+ (if old-alt (delete-file old-alt))
+ (if new-alt (delete-file new-alt)))))
+
+
(defvar unload-function-defs-list)
(defun multi-isearch-unload-function ()
diff --git a/lisp/mouse.el b/lisp/mouse.el
index 357cdc48f1b..cef88dede8a 100644
--- a/lisp/mouse.el
+++ b/lisp/mouse.el
@@ -35,7 +35,7 @@
(put 'track-mouse 'lisp-indent-function 0)
(defgroup mouse nil
- "Input from the mouse." ;; "Mouse support."
+ "Input from the mouse."
:group 'environment
:group 'editing)
@@ -105,6 +105,15 @@ point at the click position."
:type 'boolean
:version "22.1")
+(defcustom mouse-1-double-click-prefer-symbols nil
+ "If non-nil, double-clicking Mouse-1 attempts to select the symbol at click.
+
+If nil, the default, double-clicking Mouse-1 on a word-constituent
+character will select only the word at click location, which could
+select fewer characters than the symbol at click."
+ :type 'boolean
+ :version "30.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
@@ -197,8 +206,16 @@ always return a positive integer or zero."
;; Provide a mode-specific menu on a mouse button.
-(defun minor-mode-menu-from-indicator (indicator)
+(defun minor-mode-menu-from-indicator (indicator &optional window event)
"Show menu for minor mode specified by INDICATOR.
+
+INDICATOR is either a string object returned by `posn-object' or
+the car of such an object. WINDOW may be the window whose mode
+line is being displayed.
+
+EVENT may be the mouse event that is causing this menu to be
+displayed.
+
Interactively, INDICATOR is read using completion.
If there is no menu defined for the minor mode, then create one with
items `Turn Off' and `Help'."
@@ -206,7 +223,44 @@ items `Turn Off' and `Help'."
(list (completing-read
"Minor mode indicator: "
(describe-minor-mode-completion-table-for-indicator))))
- (let* ((minor-mode (lookup-minor-mode-from-indicator indicator))
+ ;; If INDICATOR is a string object, WINDOW is set, and
+ ;; `mode-line-compact' might be enabled, find a string in
+ ;; `minor-mode-alist' that is present within the INDICATOR and whose
+ ;; extents within INDICATOR contain the position of the object
+ ;; within the string.
+ (when window
+ (catch 'found
+ (with-selected-window window
+ (let ((alist minor-mode-alist) string position)
+ (when (and (consp indicator) mode-line-compact)
+ (with-temp-buffer
+ (insert (car indicator))
+ (dolist (menu alist)
+ ;; If this is a valid minor mode menu entry,
+ (when (and (consp menu)
+ (setq string (format-mode-line (cadr menu)
+ nil window))
+ (> (length string) 0))
+ ;; Start searching for an appearance of (cdr menu).
+ (goto-char (point-min))
+ (while (search-forward string nil 0)
+ ;; If the position of the string object is
+ ;; contained within, set indicator to the minor
+ ;; mode in question.
+ (setq position (1+ (cdr indicator)))
+ (and (>= position (match-beginning 0))
+ (<= position (match-end 0))
+ (setq indicator (car menu))
+ (throw 'found nil)))))))))))
+ ;; If INDICATOR is still a cons, use its car.
+ (when (consp indicator)
+ (setq indicator (car indicator)))
+ (let* ((minor-mode (if (symbolp indicator)
+ ;; indicator being set to a symbol means that
+ ;; the loop above has already found a
+ ;; matching minor mode.
+ indicator
+ (lookup-minor-mode-from-indicator indicator)))
(mm-fun (or (get minor-mode :minor-mode-function) minor-mode)))
(unless minor-mode (error "Cannot find minor mode for `%s'" indicator))
(let* ((map (cdr-safe (assq minor-mode minor-mode-map-alist)))
@@ -225,14 +279,19 @@ items `Turn Off' and `Help'."
,(lambda () (interactive)
(describe-function mm-fun)))))))
(if menu
- (popup-menu menu)
+ (popup-menu menu event)
(message "No menu available")))))
(defun mouse-minor-mode-menu (event)
"Show minor-mode menu for EVENT on minor modes area of the mode line."
(interactive "@e")
- (let ((indicator (car (nth 4 (car (cdr event))))))
- (minor-mode-menu-from-indicator indicator)))
+ (let* ((posn (event-start event))
+ (indicator (posn-object posn))
+ (window (posn-window posn)))
+ (minor-mode-menu-from-indicator indicator window event)))
+
+;; See (elisp)Touchscreen Events.
+(put 'mouse-minor-mode-menu 'mouse-1-menu-command t)
(defun mouse-menu-major-mode-map ()
(run-hooks 'activate-menubar-hook 'menu-bar-update-hook)
@@ -334,6 +393,7 @@ and should return the same menu with changes such as added new menu items."
(function-item context-menu-local)
(function-item context-menu-minor)
(function-item context-menu-buffers)
+ (function-item context-menu-project)
(function-item context-menu-vc)
(function-item context-menu-ffap)
(function-item hi-lock-context-menu)
@@ -355,13 +415,17 @@ Each function receives the menu and the mouse click event
and returns the same menu after adding own menu items to the composite menu.
When there is a text property `context-menu-function' at CLICK,
it overrides all functions from `context-menu-functions'.
+Whereas the property `context-menu-functions' doesn't override
+the variable `context-menu-functions', but adds menus from the
+list in the property after adding menus from the variable.
At the end, it's possible to modify the final menu by specifying
the function `context-menu-filter-function'."
(let* ((menu (make-sparse-keymap (propertize "Context Menu" 'hide t)))
(click (or click last-input-event))
- (window (posn-window (event-start click)))
- (fun (mouse-posn-property (event-start click)
- 'context-menu-function)))
+ (start (event-start click))
+ (window (posn-window start))
+ (fun (mouse-posn-property start 'context-menu-function))
+ (funs (mouse-posn-property start 'context-menu-functions)))
(unless (eq (selected-window) window)
(select-window window))
@@ -371,7 +435,9 @@ the function `context-menu-filter-function'."
(run-hook-wrapped 'context-menu-functions
(lambda (fun)
(setq menu (funcall fun menu click))
- nil)))
+ nil))
+ (dolist (fun funs)
+ (setq menu (funcall fun menu click))))
;; Remove duplicate separators as well as ones at the beginning or
;; end of the menu.
@@ -468,6 +534,12 @@ Some context functions add menu items below the separator."
(mouse-buffer-menu-keymap))
menu)
+(defun context-menu-project (menu _click)
+ "Populate MENU with project commands."
+ (define-key-after menu [separator-project] menu-bar-separator)
+ (define-key-after menu [project-menu] menu-bar-project-item)
+ menu)
+
(defun context-menu-vc (menu _click)
"Populate MENU with Version Control commands."
(define-key-after menu [separator-vc] menu-bar-separator)
@@ -1770,10 +1842,11 @@ The region will be defined with mark and point."
map)
t (lambda ()
(funcall cleanup)
- ;; Don't deactivate the mark when the context menu was invoked
- ;; by down-mouse-3 immediately after down-mouse-1 and without
- ;; releasing the mouse button with mouse-1. This allows to use
- ;; region-related context menu to operate on the selected region.
+ ;; Don't deactivate the mark when the context menu was
+ ;; invoked by down-mouse-3 immediately after
+ ;; down-mouse-1 and without releasing the mouse button
+ ;; with mouse-1. This enables region-related context
+ ;; menu to operate on the selected region.
(unless (and context-menu-mode
(eq (car-safe (aref (this-command-keys-vector) 0))
'down-mouse-3))
@@ -1801,10 +1874,17 @@ The region will be defined with mark and point."
;; Commands to handle xterm-style multiple clicks.
(defun mouse-skip-word (dir)
"Skip over word, over whitespace, or over identical punctuation.
+If `mouse-1-double-click-prefer-symbols' is non-nil, skip over symbol.
If DIR is positive skip forward; if negative, skip backward."
(let* ((char (following-char))
- (syntax (char-to-string (char-syntax char))))
- (cond ((string= syntax "w")
+ (syntax (char-to-string (char-syntax char)))
+ sym)
+ (cond ((and mouse-1-double-click-prefer-symbols
+ (setq sym (bounds-of-thing-at-point 'symbol)))
+ (goto-char (if (< dir 0)
+ (car sym)
+ (cdr sym))))
+ ((string= syntax "w")
;; Here, we can't use skip-syntax-forward/backward because
;; they don't pay attention to word-separating-categories,
;; and thus they will skip over a true word boundary. So,
diff --git a/lisp/mpc.el b/lisp/mpc.el
index 9577e0f2f42..768c70c2e3a 100644
--- a/lisp/mpc.el
+++ b/lisp/mpc.el
@@ -1867,11 +1867,14 @@ A value of t means the main playlist.")
(defvar mpc-volume nil) (put 'mpc-volume 'risky-local-variable t)
(defun mpc-volume-refresh ()
- ;; Maintain the volume.
- (setq mpc-volume
- (mpc-volume-widget
- (string-to-number (cdr (assq 'volume mpc-status)))))
- (let ((status-buf (mpc-proc-buffer (mpc-proc) 'status)))
+ "Maintain the volume."
+ (let ((status-buf (mpc-proc-buffer (mpc-proc) 'status))
+ (status-vol (cdr (assq 'volume mpc-status))))
+ ;; If MPD is paused or stopped the volume is nil.
+ (when status-vol
+ (setq mpc-volume
+ (mpc-volume-widget
+ (string-to-number status-vol))))
(when (buffer-live-p status-buf)
(with-current-buffer status-buf (force-mode-line-update)))))
diff --git a/lisp/mwheel.el b/lisp/mwheel.el
index 639e457cf37..66a1fa1a706 100644
--- a/lisp/mwheel.el
+++ b/lisp/mwheel.el
@@ -34,8 +34,8 @@
;; Implementation note:
;;
;; I for one would prefer some way of converting the mouse-4/mouse-5
-;; events into different event types, like 'mwheel-up' or
-;; 'mwheel-down', but I cannot find a way to do this very easily (or
+;; events into different event types, like 'wheel-up' or
+;; 'wheel-down', but I cannot find a way to do this very easily (or
;; portably), so for now I just live with it.
(require 'timer)
@@ -56,47 +56,24 @@
(bound-and-true-p mouse-wheel-mode))
(mouse-wheel-mode 1)))
+(defvar mouse-wheel-obey-old-style-wheel-buttons t
+ "If non-nil, treat mouse-4/5/6/7 events as mouse wheel events.
+These are the event names used historically in X11 before XInput2.
+They are sometimes generated by things like text-terminals as well.")
+
(defcustom mouse-wheel-down-event
- (if (or (featurep 'w32-win) (featurep 'ns-win)
- (featurep 'haiku-win) (featurep 'pgtk-win))
- 'wheel-up
- 'mouse-4)
- "Event used for scrolling down."
- :group 'mouse
- :type 'symbol
- :set 'mouse-wheel-change-button)
-
-(defcustom mouse-wheel-down-alternate-event
- (if (featurep 'xinput2)
- 'wheel-up
- (unless (featurep 'x)
- 'mouse-4))
- "Alternative wheel down event to consider."
+ (if mouse-wheel-obey-old-style-wheel-buttons 'mouse-4)
+ "Event used for scrolling down, beside `wheel-up', if any."
:group 'mouse
:type 'symbol
- :version "29.1"
- :set 'mouse-wheel-change-button)
+ :set #'mouse-wheel-change-button)
(defcustom mouse-wheel-up-event
- (if (or (featurep 'w32-win) (featurep 'ns-win)
- (featurep 'haiku-win) (featurep 'pgtk-win))
- 'wheel-down
- 'mouse-5)
- "Event used for scrolling up."
+ (if mouse-wheel-obey-old-style-wheel-buttons 'mouse-5)
+ "Event used for scrolling up, beside `wheel-down', if any."
:group 'mouse
:type 'symbol
- :set 'mouse-wheel-change-button)
-
-(defcustom mouse-wheel-up-alternate-event
- (if (featurep 'xinput2)
- 'wheel-down
- (unless (featurep 'x)
- 'mouse-5))
- "Alternative wheel up event to consider."
- :group 'mouse
- :type 'symbol
- :version "29.1"
- :set 'mouse-wheel-change-button)
+ :set #'mouse-wheel-change-button)
(defcustom mouse-wheel-click-event 'mouse-2
"Event that should be temporarily inhibited after mouse scrolling.
@@ -106,7 +83,7 @@ scrolling with the mouse wheel. To prevent that, this variable can be
set to the event sent when clicking on the mouse wheel button."
:group 'mouse
:type 'symbol
- :set 'mouse-wheel-change-button)
+ :set #'mouse-wheel-change-button)
(defcustom mouse-wheel-inhibit-click-time 0.35
"Time in seconds to inhibit clicking on mouse wheel button after scroll."
@@ -163,7 +140,7 @@ information, see `text-scale-adjust' and `global-text-scale-adjust'."
(const :tag "Scroll horizontally" :value hscroll)
(const :tag "Change buffer face size" :value text-scale)
(const :tag "Change global face size" :value global-text-scale)))))
- :set 'mouse-wheel-change-button
+ :set #'mouse-wheel-change-button
:version "28.1")
(defcustom mouse-wheel-progressive-speed t
@@ -214,15 +191,9 @@ Also see `mouse-wheel-tilt-scroll'."
:type 'boolean
:version "26.1")
-(defun mwheel-event-button (event)
- (let ((x (event-basic-type event)))
- ;; Map mouse-wheel events to appropriate buttons
- (if (eq 'mouse-wheel x)
- (let ((amount (car (cdr (cdr (cdr event))))))
- (if (< amount 0)
- mouse-wheel-up-event
- mouse-wheel-down-event))
- x)))
+;; This function used to handle the `mouse-wheel` event which was
+;; removed in 2003 by commit 9eb28007fb27, thus making it obsolete.
+(define-obsolete-function-alias 'mwheel-event-button #'event-basic-type "30.1")
(defun mwheel-event-window (event)
(posn-window (event-start event)))
@@ -253,32 +224,12 @@ Also see `mouse-wheel-tilt-scroll'."
"Function that does the job of scrolling right.")
(defvar mouse-wheel-left-event
- (if (or (featurep 'w32-win) (featurep 'ns-win)
- (featurep 'haiku-win) (featurep 'pgtk-win))
- 'wheel-left
- 'mouse-6)
- "Event used for scrolling left.")
-
-(defvar mouse-wheel-left-alternate-event
- (if (featurep 'xinput2)
- 'wheel-left
- (unless (featurep 'x)
- 'mouse-6))
- "Alternative wheel left event to consider.")
+ (if mouse-wheel-obey-old-style-wheel-buttons 'mouse-6)
+ "Event used for scrolling left, beside `wheel-left', if any.")
(defvar mouse-wheel-right-event
- (if (or (featurep 'w32-win) (featurep 'ns-win)
- (featurep 'haiku-win) (featurep 'pgtk-win))
- 'wheel-right
- 'mouse-7)
- "Event used for scrolling right.")
-
-(defvar mouse-wheel-right-alternate-event
- (if (featurep 'xinput2)
- 'wheel-right
- (unless (featurep 'x)
- 'mouse-7))
- "Alternative wheel right event to consider.")
+ (if mouse-wheel-obey-old-style-wheel-buttons 'mouse-7)
+ "Event used for scrolling right, beside `wheel-right', if any.")
(defun mouse-wheel--get-scroll-window (event)
"Return window for mouse wheel event EVENT.
@@ -307,6 +258,23 @@ active window."
frame nil t)))))
(mwheel-event-window event)))
+(defmacro mwheel--is-dir-p (dir button)
+ (declare (debug (sexp form)))
+ (let ((custom-var (intern (format "mouse-wheel-%s-event" dir)))
+ ;; N.B. that the direction `down' in a wheel event refers to
+ ;; the movement of the section of the buffer the window is
+ ;; displaying, that is to say, the direction `scroll-up' moves
+ ;; it in.
+ (event (intern (format "wheel-%s" (cond ((eq dir 'up)
+ 'down)
+ ((eq dir 'down)
+ 'up)
+ (t dir))))))
+ (macroexp-let2 nil butsym button
+ `(or (eq ,butsym ',event)
+ ;; We presume here `button' is never nil.
+ (eq ,butsym ,custom-var)))))
+
(defun mwheel-scroll (event &optional arg)
"Scroll up or down according to the EVENT.
This should be bound only to mouse buttons 4, 5, 6, and 7 on
@@ -343,18 +311,17 @@ value of ARG, and the command uses it in subsequent scrolls."
(when (numberp amt) (setq amt (* amt (event-line-count event))))
(condition-case nil
(unwind-protect
- (let ((button (mwheel-event-button event)))
- (cond ((and (eq amt 'hscroll) (memq button (list mouse-wheel-down-event
- mouse-wheel-down-alternate-event)))
+ (let ((button (event-basic-type event)))
+ (cond ((and (eq amt 'hscroll) (mwheel--is-dir-p down button))
(when (and (natnump arg) (> arg 0))
(setq mouse-wheel-scroll-amount-horizontal arg))
(funcall (if mouse-wheel-flip-direction
mwheel-scroll-left-function
mwheel-scroll-right-function)
mouse-wheel-scroll-amount-horizontal))
- ((memq button (list mouse-wheel-down-event
- mouse-wheel-down-alternate-event))
- (condition-case nil (funcall mwheel-scroll-down-function amt)
+ ((mwheel--is-dir-p down button)
+ (condition-case nil
+ (funcall mwheel-scroll-down-function amt)
;; Make sure we do indeed scroll to the beginning of
;; the buffer.
(beginning-of-buffer
@@ -368,31 +335,30 @@ value of ARG, and the command uses it in subsequent scrolls."
;; for a reason that escapes me. This problem seems
;; to only affect scroll-down. --Stef
(set-window-start (selected-window) (point-min))))))
- ((and (eq amt 'hscroll) (memq button (list mouse-wheel-up-event
- mouse-wheel-up-alternate-event)))
+ ((and (eq amt 'hscroll) (mwheel--is-dir-p up button))
(when (and (natnump arg) (> arg 0))
(setq mouse-wheel-scroll-amount-horizontal arg))
(funcall (if mouse-wheel-flip-direction
mwheel-scroll-right-function
mwheel-scroll-left-function)
mouse-wheel-scroll-amount-horizontal))
- ((memq button (list mouse-wheel-up-event
- mouse-wheel-up-alternate-event))
+ ((mwheel--is-dir-p up button)
(condition-case nil (funcall mwheel-scroll-up-function amt)
;; Make sure we do indeed scroll to the end of the buffer.
- (end-of-buffer (while t (funcall mwheel-scroll-up-function)))))
- ((memq button (list mouse-wheel-left-event
- mouse-wheel-left-alternate-event)) ; for tilt scroll
+ (end-of-buffer
+ (while t (funcall mwheel-scroll-up-function)))))
+ ((mwheel--is-dir-p left button) ; for tilt scroll
(when mouse-wheel-tilt-scroll
(funcall (if mouse-wheel-flip-direction
mwheel-scroll-right-function
- mwheel-scroll-left-function) amt)))
- ((memq button (list mouse-wheel-right-event
- mouse-wheel-right-alternate-event)) ; for tilt scroll
+ mwheel-scroll-left-function)
+ amt)))
+ ((mwheel--is-dir-p right button) ; for tilt scroll
(when mouse-wheel-tilt-scroll
(funcall (if mouse-wheel-flip-direction
mwheel-scroll-left-function
- mwheel-scroll-right-function) amt)))
+ mwheel-scroll-right-function)
+ amt)))
(t (error "Bad binding in mwheel-scroll"))))
(if (eq scroll-window selected-window)
;; If there is a temporarily active region, deactivate it if
@@ -430,14 +396,12 @@ See also `text-scale-adjust'."
(interactive (list last-input-event))
(let ((selected-window (selected-window))
(scroll-window (mouse-wheel--get-scroll-window event))
- (button (mwheel-event-button event)))
+ (button (event-basic-type event)))
(select-window scroll-window 'mark-for-redisplay)
(unwind-protect
- (cond ((memq button (list mouse-wheel-down-event
- mouse-wheel-down-alternate-event))
+ (cond ((mwheel--is-dir-p down button)
(text-scale-increase 1))
- ((memq button (list mouse-wheel-up-event
- mouse-wheel-up-alternate-event))
+ ((mwheel--is-dir-p up button)
(text-scale-decrease 1)))
(select-window selected-window))))
@@ -446,14 +410,11 @@ See also `text-scale-adjust'."
"Increase or decrease the global font size according to the EVENT.
This invokes `global-text-scale-adjust', which see."
(interactive (list last-input-event))
- (let ((button (mwheel-event-button event)))
- (unwind-protect
- (cond ((memq button (list mouse-wheel-down-event
- mouse-wheel-down-alternate-event))
- (global-text-scale-adjust 1))
- ((memq button (list mouse-wheel-up-event
- mouse-wheel-up-alternate-event))
- (global-text-scale-adjust -1))))))
+ (let ((button (event-basic-type event)))
+ (cond ((mwheel--is-dir-p down button)
+ (global-text-scale-adjust 1))
+ ((mwheel--is-dir-p up button)
+ (global-text-scale-adjust -1)))))
(defun mouse-wheel--add-binding (key fun)
"Bind mouse wheel button KEY to function FUN.
@@ -504,15 +465,13 @@ an event used for scrolling, such as `mouse-wheel-down-event'."
;; Bindings for changing font size.
((and (consp binding) (eq (cdr binding) 'text-scale))
(dolist (event (list mouse-wheel-down-event mouse-wheel-up-event
- mouse-wheel-down-alternate-event
- mouse-wheel-up-alternate-event))
+ 'wheel-down 'wheel-up))
(when event
(mouse-wheel--add-binding `[,(append (car binding) (list event))]
'mouse-wheel-text-scale))))
((and (consp binding) (eq (cdr binding) 'global-text-scale))
(dolist (event (list mouse-wheel-down-event mouse-wheel-up-event
- mouse-wheel-down-alternate-event
- mouse-wheel-up-alternate-event))
+ 'wheel-down 'wheel-up))
(when event
(mouse-wheel--add-binding `[,(append (car binding) (list event))]
'mouse-wheel-global-text-scale))))
@@ -520,10 +479,7 @@ an event used for scrolling, such as `mouse-wheel-down-event'."
(t
(dolist (event (list mouse-wheel-down-event mouse-wheel-up-event
mouse-wheel-left-event mouse-wheel-right-event
- mouse-wheel-down-alternate-event
- mouse-wheel-up-alternate-event
- mouse-wheel-left-alternate-event
- mouse-wheel-right-alternate-event))
+ 'wheel-down 'wheel-up 'wheel-left 'wheel-right))
(when event
(dolist (key (mouse-wheel--create-scroll-keys binding event))
(mouse-wheel--add-binding key 'mwheel-scroll))))))))
diff --git a/lisp/net/ange-ftp.el b/lisp/net/ange-ftp.el
index c701a189265..fb723fb8878 100644
--- a/lisp/net/ange-ftp.el
+++ b/lisp/net/ange-ftp.el
@@ -2850,7 +2850,8 @@ NO-ERROR, if a listing for DIRECTORY cannot be obtained."
(ange-ftp-switches-ok dired-actual-switches))
(and (boundp 'dired-listing-switches)
(ange-ftp-switches-ok
- dired-listing-switches))
+ (connection-local-value
+ dired-listing-switches)))
"-al")
t no-error)
(gethash directory ange-ftp-files-hashtable)))))
@@ -3534,7 +3535,8 @@ system TYPE.")
(setq file (expand-file-name file))
(let ((parsed (ange-ftp-ftp-name file)))
(if parsed
- (if (and delete-by-moving-to-trash trash)
+ (if (and delete-by-moving-to-trash trash
+ (not remote-file-name-inhibit-delete-by-moving-to-trash))
(move-file-to-trash file)
(let* ((host (nth 0 parsed))
(user (nth 1 parsed))
@@ -4129,7 +4131,7 @@ directory, so that Emacs will know its current contents."
(or (file-exists-p parent)
(ange-ftp-make-directory parent parents))))
(if (file-exists-p dir)
- (unless parents
+ (if parents t
(signal
'file-already-exists
(list "Cannot make directory: file already exists" dir)))
@@ -4158,7 +4160,8 @@ directory, so that Emacs will know its current contents."
(format "Could not make directory %s: %s"
dir
(cdr result))))
- (ange-ftp-add-file-entry dir t))
+ (ange-ftp-add-file-entry dir t)
+ nil)
(ange-ftp-real-make-directory dir)))))
(defun ange-ftp-delete-directory (dir &optional recursive trash)
@@ -4231,7 +4234,7 @@ directory, so that Emacs will know its current contents."
(host (nth 0 parsed))
(user (nth 1 parsed))
(localname (nth 2 parsed)))
- (and (or (not connected)
+ (and (or (memq connected '(nil never))
(let ((proc (get-process (ange-ftp-ftp-process-buffer host user))))
(and proc (processp proc)
(memq (process-status proc) '(run open)))))
@@ -4240,6 +4243,7 @@ directory, so that Emacs will know its current contents."
((eq identification 'user) user)
((eq identification 'host) host)
((eq identification 'localname) localname)
+ ((eq identification 'hop) nil)
(t (ange-ftp-replace-name-component file ""))))))
(defun ange-ftp-load (file &optional noerror nomessage nosuffix must-suffix)
@@ -4377,6 +4381,14 @@ NEWNAME should be the name to give the new compressed or uncompressed file.")
;; or return nil meaning don't make a backup.
(if ange-ftp-make-backup-files
(ange-ftp-real-find-backup-file-name fn)))
+
+(defun ange-ftp-file-user-uid ()
+ ;; Return "don't know" value.
+ -1)
+
+(defun ange-ftp-file-group-gid ()
+ ;; Return "don't know" value.
+ -1)
;;; Define the handler for special file names
;;; that causes ange-ftp to be invoked.
@@ -4392,40 +4404,6 @@ NEWNAME should be the name to give the new compressed or uncompressed file.")
(error (signal (car err) (cdr err))))
(ange-ftp-run-real-handler operation args))))
-;; The following code is commented out because Tramp now deals with
-;; Ange-FTP filenames, too.
-
-;;-;;; This regexp takes care of real ange-ftp file names (with a slash
-;;-;;; and colon).
-;;-;;; Don't allow the host name to end in a period--some systems use /.:
-;;-;;;###autoload
-;;-(or (assoc "^/[^/:]*[^/:.]:" file-name-handler-alist)
-;;- (setq file-name-handler-alist
-;;- (cons '("^/[^/:]*[^/:.]:" . ange-ftp-hook-function)
-;;- file-name-handler-alist)))
-;;-
-;;-;;; This regexp recognizes absolute filenames with only one component,
-;;-;;; for the sake of hostname completion.
-;;-;;;###autoload
-;;-(or (assoc "^/[^/:]*\\'" file-name-handler-alist)
-;;- (setq file-name-handler-alist
-;;- (cons '("^/[^/:]*\\'" . ange-ftp-completion-hook-function)
-;;- file-name-handler-alist)))
-;;-
-;;-;;; This regexp recognizes absolute filenames with only one component
-;;-;;; on Windows, for the sake of hostname completion.
-;;-;;; NB. Do not mark this as autoload, because it is very common to
-;;-;;; do completions in the root directory of drives on Windows.
-;;-(and (memq system-type '(ms-dos windows-nt))
-;;- (or (assoc "^[a-zA-Z]:/[^/:]*\\'" file-name-handler-alist)
-;;- (setq file-name-handler-alist
-;;- (cons '("^[a-zA-Z]:/[^/:]*\\'" .
-;;- ange-ftp-completion-hook-function)
-;;- file-name-handler-alist))))
-
-;;; The above two forms are sufficient to cause this file to be loaded
-;;; if the user ever uses a file name with a colon in it.
-
;;; This sets the mode
(add-hook 'find-file-hook 'ange-ftp-set-buffer-mode)
@@ -4498,6 +4476,29 @@ NEWNAME should be the name to give the new compressed or uncompressed file.")
(put 'process-file 'ange-ftp 'ange-ftp-process-file)
(put 'start-file-process 'ange-ftp 'ignore)
(put 'shell-command 'ange-ftp 'ange-ftp-shell-command)
+
+;; Do not execute system information functions.
+(put 'file-system-info 'ange-ftp 'ignore)
+(put 'list-system-processes 'ange-ftp 'ignore)
+(put 'memory-info 'ange-ftp 'ignore)
+(put 'process-attributes 'ange-ftp 'ignore)
+
+;; There aren't ACLs. `file-selinux-context' shall return '(nil nil
+;; nil nil) if the file is nonexistent, so we let the default file
+;; name handler do the job.
+(put 'file-acl 'ange-ftp 'ignore)
+;; (put 'file-selinux-context 'ange-ftp 'ignore)
+(put 'set-file-acl 'ange-ftp 'ignore)
+(put 'set-file-selinux-context 'ange-ftp 'ignore)
+
+;; There aren't file notifications.
+(put 'file-notify-add-watch 'ange-ftp 'ignore)
+(put 'file-notify-rm-watch 'ange-ftp 'ignore)
+(put 'file-notify-valid-p 'ange-ftp 'ignore)
+
+;; Return the "don't know" value for remote user uid and group gid.
+(put 'file-user-uid 'ange-ftp 'ange-ftp-file-user-uid)
+(put 'file-group-gid 'ange-ftp 'ange-ftp-file-group-gid)
;;; Define ways of getting at unmodified Emacs primitives,
;;; turning off our handler.
diff --git a/lisp/net/browse-url.el b/lisp/net/browse-url.el
index 5c86067b06b..f22aa19f5e3 100644
--- a/lisp/net/browse-url.el
+++ b/lisp/net/browse-url.el
@@ -52,6 +52,7 @@
;; browse-url-xdg-open freedesktop.org xdg-open
;; browse-url-kde KDE konqueror (kfm)
;; browse-url-elinks Elinks Don't know (tried with 0.12.GIT)
+;; browse-url-default-android-browser Android 2.3.3 (should work on 2.2 too)
;; eww-browse-url Emacs Web Wowser
;; Browsers can cache web pages so it may be necessary to tell them to
@@ -173,6 +174,9 @@
,@(when (eq system-type 'darwin)
(list '(function-item :tag "Default macOS browser"
:value browse-url-default-macosx-browser)))
+ ,@(when (eq system-type 'android)
+ (list '(function-item :tag "Default Android browser"
+ :value browse-url-default-android-browser)))
(function-item :tag "Default browser"
:value browse-url-default-browser)
(function :tag "Your own function")
@@ -232,7 +236,7 @@ be used instead."
(defcustom browse-url-button-regexp
(concat
- "\\b\\(\\(www\\.\\|\\(s?https?\\|ftp\\|file\\|gopher\\|gemini\\|"
+ "\\b\\(\\(www\\.\\|\\(s?https?\\|ftps?\\|file\\|gophers?\\|gemini\\|"
"nntp\\|news\\|telnet\\|wais\\|mailto\\|info\\):\\)"
"\\(//[-a-z0-9_.]+:[0-9]*\\)?"
(let ((chars "-a-z0-9_=#$@~%&*+\\/[:word:]")
@@ -676,14 +680,18 @@ For example, when point is on an URL fragment like
Note that if you set this to \"https\", websites that do not yet
support HTTPS may not load correctly in your web browser. Such
websites are increasingly rare, but they do still exist."
- :type 'string
+ :type '(choice (const :tag "HTTP" "http")
+ (const :tag "HTTPS" "https")
+ (string :tag "Something else" "https"))
:version "29.1")
(defun browse-url-url-at-point ()
(or (thing-at-point 'url t)
;; assume that the user is pointing at something like gnu.org/gnu
- (let ((f (thing-at-point 'filename t)))
- (and f (concat browse-url-default-scheme "://" f)))))
+ (when-let ((f (thing-at-point 'filename t)))
+ (if (string-match-p browse-url-button-regexp f)
+ f
+ (concat browse-url-default-scheme "://" f)))))
;; Having this as a separate function called by the browser-specific
;; functions allows them to be stand-alone commands, making it easier
@@ -696,8 +704,10 @@ it defaults to the current region, else to the URL at or before
point. If invoked with a mouse button, it moves point to the
position clicked before acting.
-This function returns a list (URL NEW-WINDOW-FLAG)
-for use in `interactive'."
+This function returns a list (URL NEW-WINDOW-FLAG) for use in
+`interactive'. NEW-WINDOW-FLAG is the prefix arg; if
+`browse-url-new-window-flag' is non-nil, invert the prefix arg
+instead."
(let ((event (elt (this-command-keys) 0)))
(mouse-set-point event))
(list (read-string prompt (or (and transient-mark-mode mark-active
@@ -707,8 +717,7 @@ for use in `interactive'."
(buffer-substring-no-properties
(region-beginning) (region-end))))
(browse-url-url-at-point)))
- (not (eq (null browse-url-new-window-flag)
- (null current-prefix-arg)))))
+ (xor browse-url-new-window-flag current-prefix-arg)))
;; called-interactive-p needs to be called at a function's top-level, hence
;; this macro. We use that rather than interactive-p because
@@ -871,8 +880,8 @@ The variables `browse-url-browser-function',
`browse-url-handlers', and `browse-url-default-handlers'
determine which browser function to use.
-This command prompts for a URL, defaulting to the URL at or
-before point.
+Interactively, this command prompts for a URL, defaulting to the
+URL at or before point.
The additional ARGS are passed to the browser function. See the
doc strings of the actual functions, starting with
@@ -880,7 +889,9 @@ doc strings of the actual functions, starting with
significance of ARGS (most of the functions ignore it).
If ARGS are omitted, the default is to pass
-`browse-url-new-window-flag' as ARGS."
+`browse-url-new-window-flag' as ARGS. Interactively, pass the
+prefix arg as ARGS; if `browse-url-new-window-flag' is non-nil,
+invert the prefix arg instead."
(interactive (browse-url-interactive-arg "URL: "))
(unless (called-interactively-p 'interactive)
(setq args (or args (list browse-url-new-window-flag))))
@@ -910,6 +921,11 @@ If ARGS are omitted, the default is to pass
;; (setenv "WAYLAND_DISPLAY" dpy)
)
(setenv "DISPLAY" dpy)))
+ ((featurep 'android)
+ ;; Avoid modifying the DISPLAY environment variable here,
+ ;; which interferes with any X server the user may have
+ ;; expressly set.
+ nil)
(t
(setenv "DISPLAY" dpy)))))
(if (functionp function)
@@ -1064,6 +1080,8 @@ instead of `browse-url-new-window-flag'."
'browse-url-default-macosx-browser)
((featurep 'haiku)
'browse-url-default-haiku-browser)
+ ((eq system-type 'android)
+ 'browse-url-default-android-browser)
((browse-url-can-use-xdg-open) 'browse-url-xdg-open)
;;; ((executable-find browse-url-gnome-moz-program) 'browse-url-gnome-moz)
((executable-find browse-url-firefox-program) 'browse-url-firefox)
@@ -1294,13 +1312,42 @@ Default to the URL around or before point."
(let* ((scheme (save-match-data
(if (string-match "\\(.+\\):/" url)
(match-string 1 url)
- "http")))
+ browse-url-default-scheme)))
(mime (concat "application/x-vnd.Be.URL." scheme)))
(haiku-roster-launch mime (vector url))))
(function-put 'browse-url-default-haiku-browser
'browse-url-browser-kind 'external)
+(defcustom browse-url-android-share nil
+ "If non-nil, share URLs instead of opening them.
+When non-nil, `browse-url-default-android-browser' will try to
+share the URL being browsed through programs such as mail clients
+and instant messengers instead of opening it in a web browser."
+ :type 'boolean
+ :version "30.1")
+
+(declare-function android-browse-url "../term/android-win")
+
+;;;###autoload
+(defun browse-url-default-android-browser (url &optional _new-window)
+ "Browse URL with the system default browser.
+If `browse-url-android-share' is non-nil, try to share URL using
+an external program instead. Default to the URL around or before
+point."
+ (interactive (browse-url-interactive-arg "URL: "))
+ (unless browse-url-android-share
+ ;; The URL shouldn't be encoded if it's being shared through
+ ;; another program.
+ (setq url (browse-url-encode-url url)))
+ ;; Make sure the URL starts with an appropriate scheme.
+ (unless (string-match "\\(.+\\):/" url)
+ (setq url (concat browse-url-default-scheme "://" url)))
+ (android-browse-url url browse-url-android-share))
+
+(function-put 'browse-url-default-android-browser
+ 'browse-url-browser-kind 'external)
+
;;;###autoload
(defun browse-url-emacs (url &optional same-window)
"Ask Emacs to load URL into a buffer and show it in another window.
@@ -1422,8 +1469,7 @@ used instead of `browse-url-new-window-flag'."
;;;###autoload
(defun browse-url-w3-gnudoit (url &optional _new-window)
- ;; new-window ignored
- "Ask another Emacs running gnuserv to load the URL using the W3 browser.
+ "Ask another Emacs running emacsclient to load the URL using the W3 browser.
The `browse-url-gnudoit-program' program is used with options given by
`browse-url-gnudoit-args'. Default to the URL around or before point."
(declare (obsolete nil "25.1"))
diff --git a/lisp/net/dictionary.el b/lisp/net/dictionary.el
index ace84725939..d4dfa33716c 100644
--- a/lisp/net/dictionary.el
+++ b/lisp/net/dictionary.el
@@ -23,21 +23,23 @@
;;; Commentary:
;; dictionary allows you to interact with dictionary servers.
-;; Use M-x customize-group dictionary to modify user settings.
+;;
+;; Use `M-x customize-group RET dictionary RET' to modify user settings.
;;
;; Main commands for interaction are:
-;; M-x dictionary - opens a new dictionary buffer
-;; M-x dictionary-search - search for the definition of a word
+;; `M-x dictionary' - open a new dictionary buffer
+;; `M-x dictionary-search' - search for the definition of a word
;;
;; You can find more information in the README file of the GitHub
;; repository https://github.com/myrkr/dictionary-el
;;; Code:
-(require 'cl-lib)
(require 'custom)
(require 'dictionary-connection)
(require 'button)
+(require 'help-mode)
+(require 'external-completion)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Stuff for customizing.
@@ -247,13 +249,72 @@ is utf-8"
)))
:version "28.1")
+(defcustom dictionary-read-word-prompt "Search word"
+ "Prompt string to use when prompting for a word."
+ :type 'string
+ :version "30.1")
+
+(defcustom dictionary-display-definition-function nil
+ "Function to use for displaying dictionary definitions.
+It is called with three string arguments: the word being defined,
+the dictionary name, and the full definition."
+ :type '(choice (const :tag "Dictionary buffer" nil)
+ (const :tag "Help buffer"
+ dictionary-display-definition-in-help-buffer)
+ (function :tag "Custom function"))
+ :version "30.1")
+
+(defcustom dictionary-read-word-function #'dictionary-read-word-default
+ "Function to use for prompting for a word.
+It is called with one string argument, the name of the dictionary to use, and
+must return a string."
+ :type '(choice (const :tag "Default" dictionary-read-word-default)
+ (const :tag "Dictionary-based completion"
+ dictionary-completing-read-word)
+ (function :tag "Custom function"))
+ :version "30.1")
+
+(defcustom dictionary-read-dictionary-function
+ #'dictionary-read-dictionary-default
+ "Function to use for prompting for a dictionary.
+It is called with no arguments and must return a string."
+ :type '(choice (const :tag "Default" dictionary-read-dictionary-default)
+ (const :tag "Choose among server-provided dictionaries"
+ dictionary-completing-read-dictionary)
+ (function :tag "Custom function"))
+ :version "30.1")
+
+(defcustom dictionary-search-interface nil
+ "Controls how `dictionary-search' prompts for words and displays definitions.
+
+When set to `help', `dictionary-search' displays definitions in a *Help* buffer,
+and provides completion for word selection based on dictionary matches.
+
+Otherwise, `dictionary-search' displays definitions in a *Dictionary* buffer."
+ :type '(choice (const :tag "Dictionary buffer" nil)
+ (const :tag "Help buffer" help))
+ :set (lambda (symbol value)
+ (let ((vals (pcase value
+ ('help '(dictionary-display-definition-in-help-buffer
+ dictionary-completing-read-word
+ dictionary-completing-read-dictionary))
+ (_ '(nil
+ dictionary-read-word-default
+ dictionary-read-dictionary-default)))))
+ (seq-setq (dictionary-display-definition-function
+ dictionary-read-word-function
+ dictionary-read-dictionary-function)
+ vals))
+ (set-default-toplevel-value symbol value))
+ :version "30.1")
+
(defface dictionary-word-definition-face
-'((((supports (:family "DejaVu Serif")))
- (:family "DejaVu Serif"))
- (((type x))
- (:font "Sans Serif"))
- (t
- (:font "default")))
+ '((((supports (:family "DejaVu Serif")))
+ (:family "DejaVu Serif"))
+ (((type x))
+ (:font "Sans Serif"))
+ (t
+ (:font "default")))
"The face that is used for displaying the definition of the word."
:group 'dictionary
:version "28.1")
@@ -344,74 +405,96 @@ is utf-8"
"M-SPC" #'scroll-down-command
"DEL" #'scroll-down-command)
+(easy-menu-define dictionary-mode-menu dictionary-mode-map
+ "Menu for the Dictionary mode."
+ '("Dictionary"
+ ["Search Definition" dictionary-search
+ :help "Look up a new word"]
+ ["List Matching Words" dictionary-match-words
+ :help "List all words matching a pattern"]
+ ["Lookup Word At Point" dictionary-lookup-definition
+ :help "Look up the word at point"]
+ ["Select Dictionary" dictionary-select-dictionary
+ :help "Select one or more dictionaries to search within"]
+ ["Select Match Strategy" dictionary-select-strategy
+ :help "Select the algorithm to match queries and entries with"]
+ ["Back" dictionary-previous
+ :help "Return to the previous match or location"]))
+
(defvar dictionary-connection
nil
"The current network connection.")
-(defvar dictionary-instances
- 0
- "The number of open dictionary buffers.")
-
(defvar dictionary-marker
nil
"Stores the point position while buffer display.")
-(defvar dictionary-color-support
- (condition-case nil
- (display-color-p)
- (error nil))
- "Determines if the Emacs has support to display color.")
-
(defvar dictionary-word-history
'()
"History list of searched word.")
+(defvar dictionary--last-match nil)
+
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Basic function providing startup actions
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+(defvar dictionary-tool-bar-map
+ (let ((map (make-sparse-keymap)))
+ ;; Most of these items are the same as in the default tool bar
+ ;; map, but with extraneous items removed, and with extra search
+ ;; and navigation items.
+ (tool-bar-local-item-from-menu 'find-file "new" map
+ nil :label "New File"
+ :vert-only t)
+ (tool-bar-local-item-from-menu 'menu-find-file-existing "open" map
+ nil :label "Open" :vert-only t)
+ (tool-bar-local-item-from-menu 'dired "diropen" map nil :vert-only t)
+ (tool-bar-local-item-from-menu 'kill-this-buffer "close" map nil
+ :vert-only t)
+ (define-key-after map [separator-1] menu-bar-separator)
+ (tool-bar-local-item-from-menu 'dictionary-search "search"
+ map dictionary-mode-map :vert-only t
+ :help "Start a new search query.")
+ (tool-bar-local-item-from-menu 'dictionary-previous "left-arrow"
+ map dictionary-mode-map
+ :vert-only t
+ :help "Go backwards in history.")
+ map)
+ "Like the default `tool-bar-map', but with additions for Dictionary mode")
+
;;;###autoload
-(defun dictionary-mode ()
- ;; FIXME: Use define-derived-mode.
+(define-derived-mode dictionary-mode special-mode "Dictionary"
"Mode for searching a dictionary.
+
This is a mode for searching a dictionary server implementing the
protocol defined in RFC 2229.
This is a quick reference to this mode describing the default key bindings:
\\<dictionary-mode-map>
-* \\[dictionary-close] close the dictionary buffer
-* \\[describe-mode] display this help information
-* \\[dictionary-search] ask for a new word to search
-* \\[dictionary-lookup-definition] search the word at point
-* \\[forward-button] or TAB place point to the next link
-* \\[backward-button] or S-TAB place point to the prev link
-
-* \\[dictionary-match-words] ask for a pattern and list all matching words.
-* \\[dictionary-select-dictionary] select the default dictionary
-* \\[dictionary-select-strategy] select the default search strategy
-
-* \\`RET' or \\`<mouse-2>' visit that link"
-
- (unless (eq major-mode 'dictionary-mode)
- (cl-incf dictionary-instances))
-
- (kill-all-local-variables)
+ \\[dictionary-close] close the dictionary buffer
+ \\[describe-mode] display this help
+ \\[dictionary-search] ask for a new word to search
+ \\[dictionary-lookup-definition] search for word at point
+ \\[forward-button] or \\`TAB' move point to the next link
+ \\[backward-button] or \\`S-TAB' move point to the previous link
+
+ \\[dictionary-match-words] ask for a pattern and list all matching words
+ \\[dictionary-select-dictionary] select the default dictionary
+ \\[dictionary-select-strategy] select the default search strategy
+
+ \\`RET' visit link at point
+ \\`<mouse-2>' visit clicked link"
(buffer-disable-undo)
- (use-local-map dictionary-mode-map)
- (setq major-mode 'dictionary-mode)
- (setq mode-name "Dictionary")
-
(setq-local dictionary-data-stack nil)
(setq-local dictionary-position-stack nil)
-
(make-local-variable 'dictionary-current-data)
(make-local-variable 'dictionary-positions)
-
(make-local-variable 'dictionary-default-dictionary)
(make-local-variable 'dictionary-default-strategy)
-
- (add-hook 'kill-buffer-hook #'dictionary-close t t)
- (run-hooks 'dictionary-mode-hook))
+ ;; Replace the tool bar map with `dictionary-tool-bar-map'.
+ (setq-local tool-bar-map dictionary-tool-bar-map)
+ (add-hook 'kill-buffer-hook #'dictionary-close t t))
;;;###autoload
(defun dictionary ()
@@ -535,16 +618,15 @@ The connection takes the proxy setting in customization group
(defun dictionary-close (&rest _ignored)
"Close the current dictionary buffer and its connection."
(interactive)
- (if (eq major-mode 'dictionary-mode)
- (progn
- (setq major-mode nil)
- (if (<= (cl-decf dictionary-instances) 0)
- (dictionary-connection-close dictionary-connection))
- (let ((configuration dictionary-window-configuration)
- (selected-window dictionary-selected-window))
- (kill-buffer (current-buffer))
- (set-window-configuration configuration)
- (select-window selected-window)))))
+ (when (derived-mode-p 'dictionary-mode)
+ (setq major-mode nil)
+ (if (<= (length (match-buffers '(derived-mode . dictionary-mode))) 0)
+ (dictionary-connection-close dictionary-connection))
+ (let ((configuration dictionary-window-configuration)
+ (selected-window dictionary-selected-window))
+ (kill-buffer (current-buffer))
+ (set-window-configuration configuration)
+ (select-window selected-window))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Helpful functions
@@ -683,7 +765,6 @@ previous state."
"Save the current state and start a new search based on ARGS.
The parameter ARGS is a cons cell where car is the word to search
and cdr is the dictionary where to search the word in."
- (interactive)
(dictionary-store-positions)
(let ((word (car args))
(dictionary (cdr args)))
@@ -706,7 +787,7 @@ FUNCTION is the callback which is called for each search result."
Optional argument NOMATCHING controls whether to suppress the display
of matching words."
- (message "Searching for %s in %s" word dictionary)
+ (insert (format-message "Searching for `%s' in `%s'\n" word dictionary))
(dictionary-send-command (concat "define "
(dictionary-encode-charset dictionary "")
" \""
@@ -718,13 +799,13 @@ of matching words."
(if (dictionary-check-reply reply 552)
(progn
(unless nomatching
- (insert "Word not found")
+ (insert (format-message "Word `%s' not found\n" word))
(dictionary-do-matching
word
dictionary
"."
(lambda (reply)
- (insert ", maybe you are looking for one of these words\n\n")
+ (insert "Maybe you are looking for one of these words\n")
(dictionary-display-only-match-result reply)))
(dictionary-post-buffer)))
(if (dictionary-check-reply reply 550)
@@ -838,7 +919,7 @@ them with buttons to perform a new search."
(if (search-forward-regexp regexp nil t)
(let ((match-start (match-beginning 2))
(match-end (match-end 2)))
- (if dictionary-color-support
+ (if (display-color-p)
;; Compensate for the replacement
(let ((brace-match-length (- (match-end 1)
(match-beginning 1))))
@@ -1035,20 +1116,26 @@ If PATTERN is omitted, it defaults to \"[ \\f\\t\\n\\r\\v]+\"."
(defun dictionary-new-matching (word)
"Run a new matching search on WORD."
- (dictionary-ensure-buffer)
(dictionary-store-positions)
- (dictionary-do-matching word dictionary-default-dictionary
- dictionary-default-strategy
- 'dictionary-display-match-result)
- (dictionary-store-state 'dictionary-do-matching
+ (dictionary-ensure-buffer)
+ (dictionary-new-matching-internal word dictionary-default-dictionary
+ dictionary-default-strategy
+ 'dictionary-display-match-result)
+ (dictionary-store-state 'dictionary-new-matching-internal
(list word dictionary-default-dictionary
dictionary-default-strategy
'dictionary-display-match-result)))
+(defun dictionary-new-matching-internal (word dictionary strategy function)
+ "Start a new matching for WORD in DICTIONARY after preparing the buffer.
+FUNCTION is the callback which is called for each search result."
+ (dictionary-pre-buffer)
+ (dictionary-do-matching word dictionary strategy function))
+
(defun dictionary-do-matching (word dictionary strategy function)
"Search for WORD with STRATEGY in DICTIONARY and display them with FUNCTION."
- (message "Lookup matching words for %s in %s using %s"
- word dictionary strategy)
+ (insert (format-message "Lookup matching words for `%s' in `%s' using `%s'\n"
+ word dictionary strategy))
(dictionary-send-command
(concat "match " (dictionary-encode-charset dictionary "") " "
(dictionary-encode-charset strategy "") " \""
@@ -1060,10 +1147,13 @@ If PATTERN is omitted, it defaults to \"[ \\f\\t\\n\\r\\v]+\"."
(if (dictionary-check-reply reply 551)
(error "Strategy \"%s\" is invalid" strategy))
(if (dictionary-check-reply reply 552)
- (error (concat
- "No match for \"%s\" with strategy \"%s\" in "
- "dictionary \"%s\".")
- word strategy dictionary))
+ (let ((errmsg (format-message
+ (concat
+ "No match for `%s' with strategy `%s' in "
+ "dictionary `%s'.")
+ word strategy dictionary)))
+ (insert errmsg "\n")
+ (user-error errmsg)))
(unless (dictionary-check-reply reply 152)
(error "Unknown server answer: %s" (dictionary-reply reply)))
(funcall function reply)))
@@ -1091,8 +1181,6 @@ If PATTERN is omitted, it defaults to \"[ \\f\\t\\n\\r\\v]+\"."
(defun dictionary-display-match-result (reply)
"Display the results in REPLY from a match operation."
- (dictionary-pre-buffer)
-
(let ((number (nth 1 (dictionary-reply-list reply)))
(list (dictionary-simple-split-string (dictionary-read-answer) "\n+")))
(insert number " matching word" (if (equal number "1") "" "s")
@@ -1140,33 +1228,49 @@ If PATTERN is omitted, it defaults to \"[ \\f\\t\\n\\r\\v]+\"."
((car (get-char-property (point) 'data)))
(t (current-word t))))
+(defun dictionary-read-dictionary-default ()
+ "Prompt for a dictionary name."
+ (read-string (if dictionary-default-dictionary
+ (format "Dictionary (%s): "
+ dictionary-default-dictionary)
+ "Dictionary: ")
+ nil nil dictionary-default-dictionary))
+
+(defun dictionary-read-word-default (_dictionary)
+ "Prompt for a word to search in the dictionary."
+ (let ((default (dictionary-search-default)))
+ (read-string (format-prompt dictionary-read-word-prompt default)
+ nil 'dictionary-word-history default)))
+
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; User callable commands
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;###autoload
(defun dictionary-search (word &optional dictionary)
- "Search the WORD in DICTIONARY if given or in all if nil.
-It presents the selection or word at point as default input and
-allows editing it."
+ "Search for WORD in all the known dictionaries.
+Interactively, prompt for WORD, and offer the word at point as default.
+
+Optional argument DICTIONARY means restrict the search to only
+that one dictionary. Interactively, with prefix argument,
+prompt for DICTIONARY."
(interactive
- (list (let ((default (dictionary-search-default)))
- (read-string (format-prompt "Search word" default)
- nil 'dictionary-word-history default))
- (if current-prefix-arg
- (read-string (if dictionary-default-dictionary
- (format "Dictionary (%s): " dictionary-default-dictionary)
- "Dictionary: ")
- nil nil dictionary-default-dictionary)
- dictionary-default-dictionary)))
-
- ;; if called by pressing the button
- (unless word
- (setq word (read-string "Search word: " nil 'dictionary-word-history)))
- ;; just in case non-interactively called
+ (let ((dict
+ (if current-prefix-arg
+ (funcall dictionary-read-dictionary-function)
+ dictionary-default-dictionary)))
+ (list (funcall dictionary-read-word-function dict) dict)))
(unless dictionary
(setq dictionary dictionary-default-dictionary))
- (dictionary-new-search (cons word dictionary)))
+ (if dictionary-display-definition-function
+ (if-let ((definition (dictionary-define-word word dictionary)))
+ (funcall dictionary-display-definition-function word dictionary definition)
+ (user-error "No definition found for \"%s\"" word))
+ ;; if called by pressing the button
+ (unless word
+ (setq word (read-string "Search word: " nil 'dictionary-word-history)))
+ ;; just in case non-interactively called
+ (dictionary-new-search (cons word dictionary))))
;;;###autoload
(defun dictionary-lookup-definition ()
@@ -1174,7 +1278,7 @@ allows editing it."
(interactive)
(let ((word (current-word)))
(unless word
- (error "No word at point"))
+ (user-error "No word at point"))
(dictionary-new-search (cons word dictionary-default-dictionary))))
(defun dictionary-previous ()
@@ -1214,7 +1318,8 @@ allows editing it."
(defun dictionary-popup-matching-words (&optional word)
"Display entries matching WORD or the current word if not given."
(interactive)
- (dictionary-do-matching (or word (current-word) (error "Nothing to search for"))
+ (dictionary-do-matching (or word (current-word)
+ (user-error "Nothing to search for"))
dictionary-default-dictionary
dictionary-default-popup-strategy
'dictionary-process-popup-replies))
@@ -1258,7 +1363,6 @@ allows editing it."
:version "28.1")
(defun dictionary-definition (word &optional dictionary)
- (interactive)
(unwind-protect
(let ((dictionary (or dictionary dictionary-default-dictionary)))
(dictionary-do-search word dictionary 'dictionary-read-definition t))
@@ -1315,7 +1419,6 @@ tooltip mode. The hook function will check the value of the
variable `dictionary-tooltip-mode' to decide if some action must be
taken. When disabling the tooltip mode the value of this variable
will be set to nil."
- (interactive)
(tooltip-mode on)
(if on
(add-hook 'tooltip-functions #'dictionary-display-tooltip)
@@ -1389,5 +1492,106 @@ the word at mouse click."
'dictionary-separator))
menu)
+(defun dictionary-define-word (word dictionary)
+ "Return the definition of WORD in DICTIONARY, or nil if not found."
+ (dictionary-send-command
+ (format "define %s \"%s\"" dictionary word))
+ (when (and (= (read (dictionary-read-reply)) 150)
+ (= (read (dictionary-read-reply)) 151))
+ (dictionary-read-answer)))
+
+(defun dictionary-match-word (word &rest _)
+ "Return dictionary matches for WORD as a list of strings.
+Further arguments are currently ignored."
+ (unless (string-empty-p word)
+ (if (string= (car dictionary--last-match) word)
+ (cdr dictionary--last-match)
+ (dictionary-send-command
+ (format "match %s %s \"%s\""
+ dictionary-default-dictionary
+ dictionary-default-strategy
+ word))
+ (when (and (= (read (dictionary-read-reply)) 152))
+ (with-temp-buffer
+ (insert (dictionary-read-answer))
+ (goto-char (point-min))
+ (let ((result nil))
+ (while (not (eobp))
+ (search-forward " " nil t)
+ (push (read (current-buffer)) result)
+ (search-forward "\n" nil t))
+ (setq result (reverse result))
+ (setq dictionary--last-match (cons word result))
+ result))))))
+
+(defun dictionary-completing-read-word (dictionary)
+ "Prompt for a word with completion based on matches in DICTIONARY."
+ (let* ((completion-ignore-case t)
+ (dictionary-default-dictionary dictionary)
+ (word-at-point (thing-at-point 'word t))
+ (default (dictionary-match-word word-at-point)))
+ (completing-read (format-prompt dictionary-read-word-prompt default)
+ (external-completion-table 'dictionary-definition
+ #'dictionary-match-word)
+ nil t nil 'dictionary-word-history default t)))
+
+(defun dictionary-dictionaries ()
+ "Return the list of dictionaries the server supports."
+ (dictionary-send-command "show db")
+ (when (and (= (read (dictionary-read-reply)) 110))
+ (with-temp-buffer
+ (insert (dictionary-read-answer))
+ (goto-char (point-min))
+ (let ((result '(("!" . "First matching dictionary")
+ ("*" . "All dictionaries"))))
+ (while (not (eobp))
+ (push (cons (buffer-substring
+ (search-forward "\n" nil t)
+ (1- (search-forward " " nil t)))
+ (read (current-buffer)))
+ result))
+ (reverse result)))))
+
+(defun dictionary-completing-read-dictionary ()
+ "Prompt for a dictionary the server supports."
+ (let* ((dicts (dictionary-dictionaries))
+ (len (apply #'max (mapcar #'length (mapcar #'car dicts))))
+ (completion-extra-properties
+ (list :annotation-function
+ (lambda (key)
+ (concat (make-string (1+ (- len (length key))) ?\s)
+ (alist-get key dicts nil nil #'string=))))))
+ (completing-read (format-prompt "Select dictionary"
+ dictionary-default-dictionary)
+ dicts nil t nil nil dictionary-default-dictionary)))
+
+(define-button-type 'help-word
+ :supertype 'help-xref
+ 'help-function 'dictionary-search
+ 'help-echo "mouse-2, RET: describe this word")
+
+(defun dictionary-display-definition-in-help-buffer (word dictionary definition)
+ "Display DEFINITION, the definition of WORD in DICTIONARY."
+ (let ((help-buffer-under-preparation t))
+ (help-setup-xref (list #'dictionary-search word dictionary)
+ (called-interactively-p 'interactive))
+ (with-help-window (help-buffer)
+ (with-current-buffer (help-buffer)
+ (insert definition)
+ ;; Buttonize references to other definitions. These appear as
+ ;; words enclosed with curly braces.
+ (goto-char (point-min))
+ (while (re-search-forward (rx "{"
+ (group-n 1 (* (not (any ?}))))
+ "}")
+ nil t)
+ (help-xref-button 1 'help-word
+ (match-string 1)
+ dictionary))))))
+
+(defvar dictionary-color-support (display-color-p)
+ "Determines if the Emacs has support to display color.")
+(make-obsolete-variable 'dictionary-color-support 'display-color-p "30.1")
+
(provide 'dictionary)
;;; dictionary.el ends here
diff --git a/lisp/net/dns.el b/lisp/net/dns.el
index 70d271e39e8..54f4d227a49 100644
--- a/lisp/net/dns.el
+++ b/lisp/net/dns.el
@@ -212,7 +212,7 @@ If TCP-P, the first two bytes of the packet will be the length field."
spec))
(push (list 'authoritative-p (if (zerop (logand byte (ash 1 2)))
nil t)) spec)
- (push (list 'truncated-p (if (zerop (logand byte (ash 1 2))) nil t))
+ (push (list 'truncated-p (if (zerop (logand byte (ash 1 1))) nil t))
spec)
(push (list 'recursion-desired-p
(if (zerop (logand byte (ash 1 0))) nil t)) spec))
@@ -359,7 +359,7 @@ Parses \"/etc/resolv.conf\" or calls \"nslookup\"."
result))
;;; Interface functions.
-(defvar dns-cache (make-vector 4096 0))
+(defvar dns-cache (obarray-make 4096))
(defun dns-query-cached (name &optional type fullp reversep)
(let* ((key (format "%s:%s:%s:%s" name type fullp reversep))
diff --git a/lisp/net/eudc-vars.el b/lisp/net/eudc-vars.el
index 2fe03e946d4..240385b2acf 100644
--- a/lisp/net/eudc-vars.el
+++ b/lisp/net/eudc-vars.el
@@ -441,7 +441,12 @@ BBDB fields. SPECs are sexps which are evaluated:
"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."
+objectclass in Active Directory servers.
+
+You may not want functions like `eudc-query-form' and
+`eudc-expand-inline' to do LDAP wildcard expansion by default on
+certain fields. If so, add the relevant symbol to this list, for
+example `mail' for the \"E-Mail\" field."
:type '(repeat (symbol :tag "Directory attribute")))
diff --git a/lisp/net/eudcb-mab.el b/lisp/net/eudcb-mab.el
index e28f7c2b177..2f4d210d01e 100644
--- a/lisp/net/eudcb-mab.el
+++ b/lisp/net/eudcb-mab.el
@@ -86,7 +86,8 @@ RETURN-ATTRS is a list of attributes to return, defaulting to
((eq (car term) 'email)
(unless (string= (cdr term) mail)
(setq matched nil)))
- ((eq (car term) 'phone))))
+ ;; ((eq (car term) 'phone))
+ ))
(when matched
(setq result
diff --git a/lisp/net/eww.el b/lisp/net/eww.el
index 7be65dc1e82..39ea964d47a 100644
--- a/lisp/net/eww.el
+++ b/lisp/net/eww.el
@@ -94,17 +94,19 @@ no parameters) that returns a directory name."
(defcustom eww-suggest-uris
'(eww-links-at-point
thing-at-point-url-at-point
- eww-current-url)
+ eww-current-url
+ eww-bookmark-urls)
"List of functions called to form the list of default URIs for `eww'.
Each of the elements is a function returning either a string or a list
of strings. The results will be joined into a single list with
duplicate entries (if any) removed."
- :version "27.1"
+ :version "30.1"
:group 'eww
:type 'hook
:options '(eww-links-at-point
thing-at-point-url-at-point
- eww-current-url))
+ eww-current-url
+ eww-bookmark-urls))
(defcustom eww-bookmarks-directory user-emacs-directory
"Directory where bookmark files will be stored."
@@ -180,6 +182,33 @@ the tab bar is enabled."
(const :tag "Open new tab when tab bar is enabled" tab-bar)
(const :tag "Never open URL in new tab" nil)))
+(defcustom eww-before-browse-history-function #'eww-delete-future-history
+ "A function to call to update history before browsing to a new page.
+EWW provides the following values for this option:
+
+* `eww-delete-future-history': Delete any history entries after the
+ currently-shown one. This is the default behavior, and works the same
+ as in most other web browsers.
+
+* `eww-clone-previous-history': Clone and prepend any history entries up
+ to the currently-shown one. This is like `eww-delete-future-history',
+ except that it preserves the previous contents of the history list at
+ the end.
+
+* `ignore': Preserve the current history unchanged. This will result in
+ the new page simply being prepended to the existing history list.
+
+You can also set this to any other function you wish."
+ :version "30.1"
+ :group 'eww
+ :type '(choice (function-item :tag "Delete future history"
+ eww-delete-future-history)
+ (function-item :tag "Clone previous history"
+ eww-clone-previous-history)
+ (function-item :tag "Preserve history"
+ ignore)
+ (function :tag "Custom function")))
+
(defcustom eww-after-render-hook nil
"A hook called after eww has finished rendering the buffer."
:version "25.1"
@@ -246,8 +275,29 @@ parameter, and should return the (possibly) transformed URL."
:type '(repeat function)
:version "29.1")
+(defcustom eww-readable-urls nil
+ "A list of regexps matching URLs to display in readable mode by default.
+EWW will display matching URLs using `eww-readable' (which see).
+
+Each element can be one of the following forms: a regular expression in
+string form or a cons cell of the form (REGEXP . READABILITY). If
+READABILITY is non-nil, this behaves the same as the string form;
+otherwise, URLs matching REGEXP will never be displayed in readable mode
+by default."
+ :type '(repeat (choice (string :tag "Readable URL")
+ (cons :tag "URL and Readability"
+ (string :tag "URL")
+ (radio (const :tag "Readable" t)
+ (const :tag "Non-readable" nil)))))
+ :version "30.1")
+
+(defcustom eww-readable-adds-to-history t
+ "If non-nil, calling `eww-readable' adds a new entry to the history."
+ :type 'boolean
+ :version "30.1")
+
(defface eww-form-submit
- '((((type x w32 ns haiku pgtk) (class color)) ; Like default mode line
+ '((((type x w32 ns haiku pgtk android) (class color)) ; Like default mode line
:box (:line-width 2 :style released-button)
:background "#808080" :foreground "black"))
"Face for eww buffer buttons."
@@ -255,7 +305,7 @@ parameter, and should return the (possibly) transformed URL."
:group 'eww)
(defface eww-form-file
- '((((type x w32 ns haiku pgtk) (class color)) ; Like default mode line
+ '((((type x w32 ns haiku pgtk android) (class color)) ; Like default mode line
:box (:line-width 2 :style released-button)
:background "#808080" :foreground "black"))
"Face for eww buffer buttons."
@@ -263,7 +313,7 @@ parameter, and should return the (possibly) transformed URL."
:group 'eww)
(defface eww-form-checkbox
- '((((type x w32 ns haiku pgtk) (class color)) ; Like default mode line
+ '((((type x w32 ns haiku pgtk android) (class color)) ; Like default mode line
:box (:line-width 2 :style released-button)
:background "lightgrey" :foreground "black"))
"Face for eww buffer buttons."
@@ -271,7 +321,7 @@ parameter, and should return the (possibly) transformed URL."
:group 'eww)
(defface eww-form-select
- '((((type x w32 ns haiku pgtk) (class color)) ; Like default mode line
+ '((((type x w32 ns haiku pgtk android) (class color)) ; Like default mode line
:box (:line-width 2 :style released-button)
:background "lightgrey" :foreground "black"))
"Face for eww buffer buttons."
@@ -310,7 +360,10 @@ parameter, and should return the (possibly) transformed URL."
(defvar eww-data nil)
(defvar eww-history nil)
-(defvar eww-history-position 0)
+(defvar eww-history-position 0
+ "The 1-indexed position in `eww-history'.
+If zero, EWW is at the newest page, which isn't yet present in
+`eww-history'.")
(defvar eww-prompt-history nil)
(defvar eww-local-regex "localhost"
@@ -329,10 +382,16 @@ parameter, and should return the (possibly) transformed URL."
:parent shr-image-map
"RET" #'eww-follow-link)
+(defvar-keymap eww-minibuffer-url-keymap
+ :doc "Keymap used in the minibuffer prompt for URLs or keywords."
+ :parent minibuffer-local-completion-map
+ "SPC" #'self-insert-command
+ "?" #'self-insert-command)
+
(defun eww-suggested-uris nil
"Return the list of URIs to suggest at the `eww' prompt.
This list can be customized via `eww-suggest-uris'."
- (let ((obseen (make-vector 42 0))
+ (let ((obseen (obarray-make 42))
(uris nil))
(dolist (fun eww-suggest-uris)
(let ((ret (funcall fun)))
@@ -377,10 +436,12 @@ killed after rendering.
For more information, see Info node `(eww) Top'."
(interactive
- (let ((uris (eww-suggested-uris)))
- (list (read-string (format-prompt "Enter URL or keywords"
- (and uris (car uris)))
- nil 'eww-prompt-history uris)
+ (let ((uris (eww-suggested-uris))
+ (minibuffer-local-completion-map eww-minibuffer-url-keymap))
+ (list (completing-read (format-prompt "Enter URL or keywords"
+ (and uris (car uris)))
+ (seq-uniq (append eww-prompt-history uris))
+ nil nil nil 'eww-prompt-history uris)
current-prefix-arg)))
(setq url (eww--dwim-expand-url url))
(pop-to-buffer-same-window
@@ -392,6 +453,7 @@ For more information, see Info node `(eww) Top'."
(t
(get-buffer-create "*eww*"))))
(eww-setup-buffer)
+ (eww--before-browse)
;; Check whether the domain only uses "Highly Restricted" Unicode
;; IDNA characters. If not, transform to punycode to indicate that
;; there may be funny business going on.
@@ -423,11 +485,11 @@ For more information, see Info node `(eww) Top'."
(defun eww-retrieve (url callback cbargs)
(cond
((null eww-retrieve-command)
- (url-retrieve url #'eww-render cbargs))
+ (url-retrieve url callback cbargs))
((eq eww-retrieve-command 'sync)
(let ((data-buffer (url-retrieve-synchronously url)))
(with-current-buffer data-buffer
- (apply #'eww-render nil cbargs))))
+ (apply callback nil cbargs))))
(t
(let ((buffer (generate-new-buffer " *eww retrieve*"))
(error-buffer (generate-new-buffer " *eww error*")))
@@ -495,14 +557,17 @@ For more information, see Info node `(eww) Top'."
;;;###autoload (defalias 'browse-web 'eww)
;;;###autoload
-(defun eww-open-file (file)
- "Render FILE using EWW."
- (interactive "fFile: ")
+(defun eww-open-file (file &optional new-buffer)
+ "Render FILE using EWW.
+If NEW-BUFFER is non-nil (interactively, the prefix arg), use a
+new buffer instead of reusing the default EWW buffer."
+ (interactive "fFile: \nP")
(let ((url-allow-non-local-files t))
(eww (concat "file://"
(and (memq system-type '(windows-nt ms-dos))
"/")
- (expand-file-name file)))))
+ (expand-file-name file))
+ new-buffer)))
(defun eww--file-buffer (file)
(with-current-buffer (generate-new-buffer " *eww file*")
@@ -529,24 +594,35 @@ for the search engine used."
(call-interactively #'eww)))
(call-interactively #'eww)))
-(defun eww-open-in-new-buffer ()
- "Fetch link at point in a new EWW buffer."
- (interactive)
- (let ((url (eww-suggested-uris)))
- (if (null url) (user-error "No link at point")
- (when (or (eq eww-browse-url-new-window-is-tab t)
- (and (eq eww-browse-url-new-window-is-tab 'tab-bar)
- tab-bar-mode))
- (let ((tab-bar-new-tab-choice t))
- (tab-new)))
- ;; clone useful to keep history, but
- ;; should not clone from non-eww buffer
- (with-current-buffer
- (if (eq major-mode 'eww-mode) (clone-buffer)
- (generate-new-buffer "*eww*"))
- (unless (equal url (eww-current-url))
- (eww-mode)
- (eww (if (consp url) (car url) url)))))))
+(defun eww--open-url-in-new-buffer (url)
+ "Open the URL in a new EWW buffer."
+ ;; Clone is useful to keep history, but we
+ ;; should not clone from a non-eww buffer.
+ (with-current-buffer
+ (if (eq major-mode 'eww-mode) (clone-buffer)
+ (generate-new-buffer "*eww*"))
+ (unless (equal url (eww-current-url))
+ (eww-mode)
+ (eww (if (consp url) (car url) url)))))
+
+(defun eww-open-in-new-buffer (&optional no-select url)
+ "Fetch URL (interactively, the link at point) into a new EWW buffer.
+
+NO-SELECT non-nil means do not make the new buffer the current buffer."
+ (interactive "P")
+ (if-let ((url (or url (eww-suggested-uris))))
+ (if (or (eq eww-browse-url-new-window-is-tab t)
+ (and (eq eww-browse-url-new-window-is-tab 'tab-bar)
+ tab-bar-mode))
+ (let ((tab-bar-new-tab-choice t))
+ (tab-new)
+ (eww--open-url-in-new-buffer url)
+ (when no-select
+ (tab-bar-switch-to-recent-tab)))
+ (if no-select
+ (save-window-excursion (eww--open-url-in-new-buffer url))
+ (eww--open-url-in-new-buffer url)))
+ (user-error "No link at point")))
(defun eww-html-p (content-type)
"Return non-nil if CONTENT-TYPE designates an HTML content type.
@@ -596,46 +672,50 @@ The renaming scheme is performed in accordance with
(let ((redirect (plist-get status :redirect)))
(when redirect
(setq url redirect)))
- (with-current-buffer buffer
- ;; Save the https peer status.
- (plist-put eww-data :peer (plist-get status :peer))
- ;; Make buffer listings more informative.
- (setq list-buffers-directory url)
- ;; Let the URL library have a handle to the current URL for
- ;; referer purposes.
- (setq url-current-lastloc (url-generic-parse-url url)))
- (unwind-protect
- (progn
- (cond
- ((and eww-use-external-browser-for-content-type
- (string-match-p eww-use-external-browser-for-content-type
- (car content-type)))
- (erase-buffer)
- (insert "<title>Unsupported content type</title>")
- (insert (format "<h1>Content-type %s is unsupported</h1>"
- (car content-type)))
- (insert (format "<a href=%S>Direct link to the document</a>"
- url))
- (goto-char (point-min))
- (eww-display-html charset url nil point buffer encode))
- ((eww-html-p (car content-type))
- (eww-display-html charset url nil point buffer encode))
- ((equal (car content-type) "application/pdf")
- (eww-display-pdf))
- ((string-match-p "\\`image/" (car content-type))
- (eww-display-image buffer))
- (t
- (eww-display-raw buffer (or encode charset 'utf-8))))
- (with-current-buffer buffer
- (plist-put eww-data :url url)
- (eww--after-page-change)
- (setq eww-history-position 0)
- (and last-coding-system-used
- (set-buffer-file-coding-system last-coding-system-used))
- (run-hooks 'eww-after-render-hook)
- ;; Enable undo again so that undo works in text input
- ;; boxes.
- (setq buffer-undo-list nil)))
+ (when (buffer-live-p buffer)
+ (with-current-buffer buffer
+ ;; Save the https peer status.
+ (plist-put eww-data :peer (plist-get status :peer))
+ ;; Make buffer listings more informative.
+ (setq list-buffers-directory url)
+ ;; Let the URL library have a handle to the current URL for
+ ;; referer purposes.
+ (setq url-current-lastloc (url-generic-parse-url url)))
+ (unwind-protect
+ (progn
+ (cond
+ ((and eww-use-external-browser-for-content-type
+ (string-match-p eww-use-external-browser-for-content-type
+ (car content-type)))
+ (erase-buffer)
+ (insert "<title>Unsupported content type</title>")
+ (insert (format "<h1>Content-type %s is unsupported</h1>"
+ (car content-type)))
+ (insert (format "<a href=%S>Direct link to the document</a>"
+ url))
+ (goto-char (point-min))
+ (eww-display-html (or encode charset) url nil point buffer))
+ ((eww-html-p (car content-type))
+ (eww-display-html (or encode charset) url nil point buffer))
+ ((equal (car content-type) "application/pdf")
+ (eww-display-pdf))
+ ((string-match-p "\\`image/" (car content-type))
+ (eww-display-image buffer))
+ (t
+ (eww-display-raw buffer (or encode charset 'utf-8))))
+ (with-current-buffer buffer
+ (plist-put eww-data :url url)
+ (eww--after-page-change)
+ (and last-coding-system-used
+ (set-buffer-file-coding-system last-coding-system-used))
+ (unless shr-fill-text
+ (visual-line-mode))
+ (run-hooks 'eww-after-render-hook)
+ ;; Enable undo again so that undo works in text input
+ ;; boxes.
+ (setq buffer-undo-list nil)))
+ (kill-buffer data-buffer)))
+ (unless (buffer-live-p buffer)
(kill-buffer data-buffer))))
(defun eww-parse-headers ()
@@ -667,34 +747,40 @@ The renaming scheme is performed in accordance with
(declare-function libxml-parse-html-region "xml.c"
(start end &optional base-url discard-comments))
-(defun eww-display-html (charset url &optional document point buffer encode)
+(defun eww--parse-html-region (start end &optional coding-system)
+ "Parse the HTML between START and END, returning the DOM as an S-expression.
+Use CODING-SYSTEM to decode the region; if nil, decode as UTF-8.
+
+This replaces the region with the preprocessed HTML."
+ (setq coding-system (or coding-system 'utf-8))
+ (with-restriction start end
+ (condition-case nil
+ (decode-coding-region (point-min) (point-max) coding-system)
+ (coding-system-error nil))
+ ;; Remove CRLF and replace NUL with &#0; before parsing.
+ (while (re-search-forward "\\(\r$\\)\\|\0" nil t)
+ (replace-match (if (match-beginning 1) "" "&#0;") t t))
+ (eww--preprocess-html (point-min) (point-max))
+ (libxml-parse-html-region (point-min) (point-max))))
+
+(defsubst eww-document-base (url dom)
+ `(base ((href . ,url)) ,dom))
+
+(defun eww-display-document (document &optional point buffer)
(unless (fboundp 'libxml-parse-html-region)
(error "This function requires Emacs to be compiled with libxml2"))
+ (setq buffer (or buffer (current-buffer)))
(unless (buffer-live-p buffer)
(error "Buffer %s doesn't exist" buffer))
;; There should be a better way to abort loading images
;; asynchronously.
(setq url-queue nil)
- (let ((document
- (or document
- (list
- 'base (list (cons 'href url))
- (progn
- (setq encode (or encode charset 'utf-8))
- (condition-case nil
- (decode-coding-region (point) (point-max) encode)
- (coding-system-error nil))
- (save-excursion
- ;; Remove CRLF and replace NUL with &#0; before parsing.
- (while (re-search-forward "\\(\r$\\)\\|\0" nil t)
- (replace-match (if (match-beginning 1) "" "&#0;") t t)))
- (eww--preprocess-html (point) (point-max))
- (libxml-parse-html-region (point) (point-max))))))
- (source (and (null document)
- (buffer-substring (point) (point-max)))))
+ (let ((url (when (eq (car document) 'base)
+ (alist-get 'href (cadr document)))))
+ (unless url
+ (error "Document is missing base URL"))
(with-current-buffer buffer
(setq bidi-paragraph-direction nil)
- (plist-put eww-data :source source)
(plist-put eww-data :dom document)
(let ((inhibit-read-only t)
(inhibit-modification-hooks t)
@@ -735,6 +821,20 @@ The renaming scheme is performed in accordance with
(forward-line 1)))))
(eww-size-text-inputs))))
+(defun eww-display-html (charset url &optional document point buffer)
+ (let ((source (buffer-substring (point) (point-max))))
+ (with-current-buffer buffer
+ (plist-put eww-data :source source)))
+ (unless document
+ (let ((dom (eww--parse-html-region (point) (point-max) charset)))
+ (when (eww-default-readable-p url)
+ (eww-score-readability dom)
+ (setq dom (eww-highest-readability dom))
+ (with-current-buffer buffer
+ (plist-put eww-data :readable t)))
+ (setq document (eww-document-base url dom))))
+ (eww-display-document document point buffer))
+
(defun eww-handle-link (dom)
(let* ((rel (dom-attr dom 'rel))
(href (dom-attr dom 'href))
@@ -876,6 +976,11 @@ The renaming scheme is performed in accordance with
`((?u . ,(or url ""))
(?t . ,title))))))))
+(defun eww--before-browse ()
+ (funcall eww-before-browse-history-function)
+ (setq eww-history-position 0
+ eww-data (list :title "")))
+
(defun eww--after-page-change ()
(eww-update-header-line-format)
(eww--rename-buffer))
@@ -991,29 +1096,47 @@ The renaming scheme is performed in accordance with
"automatic"
bidi-paragraph-direction)))
-(defun eww-readable ()
- "View the main \"readable\" parts of the current web page.
+(defun eww-readable (&optional arg)
+ "Toggle display of only the main \"readable\" parts of the current web page.
This command uses heuristics to find the parts of the web page that
-contains the main textual portion, leaving out navigation menus and
-the like."
- (interactive nil eww-mode)
+contain the main textual portion, leaving out navigation menus and the
+like.
+
+If called interactively, toggle the display of the readable parts. If
+the prefix argument is positive, display the readable parts, and if it
+is zero or negative, display the full page.
+
+If called from Lisp, toggle the display of the readable parts if ARG is
+`toggle'. Display the readable parts if ARG is nil, omitted, or is a
+positive number. Display the full page if ARG is a negative number.
+
+When `eww-readable-adds-to-history' is non-nil, calling this function
+adds a new entry to `eww-history'."
+ (interactive (list (if current-prefix-arg
+ (prefix-numeric-value current-prefix-arg)
+ 'toggle))
+ eww-mode)
(let* ((old-data eww-data)
- (dom (with-temp-buffer
+ (make-readable (cond
+ ((eq arg 'toggle)
+ (not (plist-get old-data :readable)))
+ ((and (numberp arg) (< arg 1))
+ nil)
+ (t t)))
+ (dom (with-temp-buffer
(insert (plist-get old-data :source))
- (condition-case nil
- (decode-coding-region (point-min) (point-max) 'utf-8)
- (coding-system-error nil))
- (eww--preprocess-html (point-min) (point-max))
- (libxml-parse-html-region (point-min) (point-max))))
+ (eww--parse-html-region (point-min) (point-max))))
(base (plist-get eww-data :url)))
- (eww-score-readability dom)
- (eww-save-history)
- (eww-display-html nil nil
- (list 'base (list (cons 'href base))
- (eww-highest-readability dom))
- nil (current-buffer))
- (dolist (elem '(:source :url :title :next :previous :up :peer))
- (plist-put eww-data elem (plist-get old-data elem)))
+ (when make-readable
+ (eww-score-readability dom)
+ (setq dom (eww-highest-readability dom)))
+ (when eww-readable-adds-to-history
+ (eww-save-history)
+ (eww--before-browse)
+ (dolist (elem '(:source :url :title :next :previous :up :peer))
+ (plist-put eww-data elem (plist-get old-data elem))))
+ (eww-display-document (eww-document-base base dom))
+ (plist-put eww-data :readable make-readable)
(eww--after-page-change)))
(defun eww-score-readability (node)
@@ -1056,6 +1179,19 @@ the like."
(setq result highest))))
result))
+(defun eww-default-readable-p (url)
+ "Return non-nil if URL should be displayed in readable mode by default.
+This consults the entries in `eww-readable-urls' (which see)."
+ (catch 'found
+ (let (result)
+ (dolist (regexp eww-readable-urls)
+ (if (consp regexp)
+ (setq result (cdr regexp)
+ regexp (car regexp))
+ (setq result t))
+ (when (string-match regexp url)
+ (throw 'found result))))))
+
(defvar-keymap eww-mode-map
"g" #'eww-reload ;FIXME: revert-buffer-function instead!
"G" #'eww
@@ -1073,6 +1209,7 @@ the like."
"&" #'eww-browse-with-external-browser
"d" #'eww-download
"w" #'eww-copy-page-url
+ "A" #'eww-copy-alternate-url
"C" #'url-cookie-list
"v" #'eww-view-source
"R" #'eww-readable
@@ -1099,9 +1236,9 @@ the like."
["Reload" eww-reload t]
["Follow URL in new buffer" eww-open-in-new-buffer]
["Back to previous page" eww-back-url
- :active (not (zerop (length eww-history)))]
+ :active (< eww-history-position (length eww-history))]
["Forward to next page" eww-forward-url
- :active (not (zerop eww-history-position))]
+ :active (> eww-history-position 1)]
["Browse with external browser" eww-browse-with-external-browser t]
["Download" eww-download t]
["View page source" eww-view-source]
@@ -1125,9 +1262,9 @@ the like."
(easy-menu-define nil easy-menu nil
'("Eww"
["Back to previous page" eww-back-url
- :visible (not (zerop (length eww-history)))]
+ :active (< eww-history-position (length eww-history))]
["Forward to next page" eww-forward-url
- :visible (not (zerop eww-history-position))]
+ :active (> eww-history-position 1)]
["Reload" eww-reload t]))
(dolist (item (reverse (lookup-key easy-menu [menu-bar eww])))
(when (consp item)
@@ -1189,6 +1326,8 @@ the like."
(setq-local shr-url-transformer #'eww--transform-url)
;; Also rescale images when rescaling the text.
(add-hook 'text-scale-mode-hook #'eww--rescale-images nil t)
+ (setq-local outline-search-function 'shr-outline-search
+ outline-level 'shr-outline-level)
(setq buffer-read-only t))
(defvar text-scale-mode)
@@ -1248,16 +1387,20 @@ instead of `browse-url-new-window-flag'."
(interactive nil eww-mode)
(when (>= eww-history-position (length eww-history))
(user-error "No previous page"))
- (eww-save-history)
- (setq eww-history-position (+ eww-history-position 2))
+ (if (eww-save-history)
+ ;; We were at the latest page (which was just added to the
+ ;; history), so go back two entries.
+ (setq eww-history-position 2)
+ (setq eww-history-position (1+ eww-history-position)))
(eww-restore-history (elt eww-history (1- eww-history-position))))
(defun eww-forward-url ()
"Go to the next displayed page."
(interactive nil eww-mode)
- (when (zerop eww-history-position)
+ (when (<= eww-history-position 1)
(user-error "No next page"))
(eww-save-history)
+ (setq eww-history-position (1- eww-history-position))
(eww-restore-history (elt eww-history (1- eww-history-position))))
(defun eww-restore-history (elem)
@@ -1326,8 +1469,7 @@ just re-display the HTML already fetched."
(if local
(if (null (plist-get eww-data :dom))
(error "No current HTML data")
- (eww-display-html 'utf-8 url (plist-get eww-data :dom)
- (point) (current-buffer)))
+ (eww-display-document (plist-get eww-data :dom) (point)))
(let ((parsed (url-generic-parse-url url)))
(if (equal (url-type parsed) "file")
;; Use Tramp instead of url.el for files (since url.el
@@ -1927,6 +2069,7 @@ If EXTERNAL is double prefix, browse in new buffer."
(eww-same-page-p url (plist-get eww-data :url)))
(let ((point (point)))
(eww-save-history)
+ (eww--before-browse)
(plist-put eww-data :url url)
(goto-char (point-min))
(if-let ((match (text-property-search-forward 'shr-target-id target #'member)))
@@ -2032,9 +2175,11 @@ If CHARSET is nil then use UTF-8."
"Prompt for an EWW buffer to display in the selected window."
(interactive nil eww-mode)
(let ((completion-extra-properties
- '(:annotation-function (lambda (buf)
- (with-current-buffer buf
- (format " %s" (eww-current-url)))))))
+ `(:annotation-function
+ ,(lambda (buf)
+ (with-current-buffer buf
+ (format " %s" (eww-current-url))))))
+ (curbuf (current-buffer)))
(pop-to-buffer-same-window
(read-buffer "Switch to EWW buffer: "
(cl-loop for buf in (nreverse (buffer-list))
@@ -2042,9 +2187,10 @@ If CHARSET is nil then use UTF-8."
return buf)
t
(lambda (bufn)
- (with-current-buffer
- (if (consp bufn) (cdr bufn) (get-buffer bufn))
- (derived-mode-p 'eww-mode)))))))
+ (setq bufn (if (consp bufn) (cdr bufn) (get-buffer bufn)))
+ (and (with-current-buffer bufn
+ (derived-mode-p 'eww-mode))
+ (not (eq bufn curbuf))))))))
(defun eww-toggle-fonts ()
"Toggle whether to use monospaced or font-enabled layouts."
@@ -2191,7 +2337,7 @@ If ERROR-OUT, signal user-error if there are no bookmarks."
(setq first t)
(eww-read-bookmarks t)
(eww-bookmark-prepare))
- (with-current-buffer (get-buffer "*eww bookmarks*")
+ (with-current-buffer "*eww bookmarks*"
(when (and (not first)
(not (eobp)))
(forward-line 1))
@@ -2210,7 +2356,7 @@ If ERROR-OUT, signal user-error if there are no bookmarks."
(setq first t)
(eww-read-bookmarks t)
(eww-bookmark-prepare))
- (with-current-buffer (get-buffer "*eww bookmarks*")
+ (with-current-buffer "*eww bookmarks*"
(if first
(goto-char (point-max))
(beginning-of-line))
@@ -2224,6 +2370,12 @@ If ERROR-OUT, signal user-error if there are no bookmarks."
'eww-bookmark)))
(eww-browse-url (plist-get bookmark :url))))
+(defun eww-bookmark-urls ()
+ "Get the URLs from the current list of bookmarks."
+ (interactive nil eww-boomark-mode)
+ (eww-read-bookmarks)
+ (mapcar (lambda (x) (plist-get x :url)) eww-bookmarks))
+
(defvar-keymap eww-bookmark-mode-map
"C-k" #'eww-bookmark-kill
"C-y" #'eww-bookmark-yank
@@ -2248,11 +2400,69 @@ If ERROR-OUT, signal user-error if there are no bookmarks."
;;; History code
(defun eww-save-history ()
+ "Save the current page's data to the history.
+If the current page is a historial one loaded from
+`eww-history' (e.g. by calling `eww-back-url'), this will update the
+page's entry in `eww-history' and return nil. Otherwise, add a new
+entry to `eww-history' and return t."
(plist-put eww-data :point (point))
(plist-put eww-data :text (buffer-string))
- (let ((history-delete-duplicates nil))
- (add-to-history 'eww-history eww-data eww-history-limit t))
- (setq eww-data (list :title "")))
+ (if (zerop eww-history-position)
+ (let ((history-delete-duplicates nil))
+ (add-to-history 'eww-history eww-data eww-history-limit t)
+ (setq eww-history-position 1)
+ t)
+ (setf (elt eww-history (1- eww-history-position)) eww-data)
+ nil))
+
+(defun eww-delete-future-history ()
+ "Remove any entries in `eww-history' after the currently-shown one.
+This is useful for `eww-before-browse-history-function' to make EWW's
+navigation to a new page from a historical one work like other web
+browsers: it will delete any \"future\" history elements before adding
+the new page to the end of the history.
+
+For example, if `eww-history' looks like this (going from newest to
+oldest, with \"*\" marking the current page):
+
+ E D C* B A
+
+then calling this function updates `eww-history' to:
+
+ C* B A"
+ (when (> eww-history-position 1)
+ (setq eww-history (nthcdr (1- eww-history-position) eww-history)
+ ;; We don't really need to set this since `eww--before-browse'
+ ;; sets it too, but this ensures that other callers can use
+ ;; this function and get the expected results.
+ eww-history-position 1)))
+
+(defun eww-clone-previous-history ()
+ "Clone and prepend entries in `eww-history' up to the currently-shown one.
+These cloned entries get added to the beginning of `eww-history' so that
+it's possible to navigate back to the very first page for this EWW
+without deleting any history entries.
+
+For example, if `eww-history' looks like this (going from newest to
+oldest, with \"*\" marking the current page):
+
+ E D C* B A
+
+then calling this function updates `eww-history' to:
+
+ C* B A E D C B A
+
+This is useful for setting `eww-before-browse-history-function' (which
+see)."
+ (when (> eww-history-position 1)
+ (setq eww-history (take eww-history-limit
+ (append (nthcdr (1- eww-history-position)
+ eww-history)
+ eww-history))
+ ;; As with `eww-delete-future-history', we don't really need
+ ;; to set this since `eww--before-browse' sets it too, but
+ ;; let's be thorough.
+ eww-history-position 1)))
(defvar eww-current-buffer)
@@ -2505,10 +2715,10 @@ Otherwise, the restored buffer will contain a prompt to do so by using
(when (plist-get eww-data :url)
(cl-case eww-restore-desktop
((t auto) (eww (plist-get eww-data :url)))
- ((zerop (buffer-size))
- (let ((inhibit-read-only t))
- (insert (substitute-command-keys
- eww-restore-reload-prompt)))))))
+ ((nil) (when (zerop (buffer-size))
+ (let ((inhibit-read-only t))
+ (insert (substitute-command-keys
+ eww-restore-reload-prompt))))))))
;; .
(current-buffer)))
@@ -2557,4 +2767,83 @@ Otherwise, the restored buffer will contain a prompt to do so by using
(provide 'eww)
+;;; Alternate links (RSS and Atom feeds, etc.)
+
+(defun eww--alternate-urls (dom &optional base)
+ "Return an alist of alternate links in DOM.
+
+Each element is a list of the form (URL TYPE TITLE) where URL is
+the href attribute of the link expanded relative to BASE, TYPE is
+its type attribute, and TITLE is its title attribute. If any of
+these attributes is absent, the corresponding element is nil."
+ (let ((alternates
+ (seq-filter
+ (lambda (attrs) (string= (alist-get 'rel attrs)
+ "alternate"))
+ (mapcar #'dom-attributes (dom-by-tag dom 'link)))))
+ (mapcar (lambda (alternate)
+ (list (url-expand-file-name (alist-get 'href alternate)
+ base)
+ (alist-get 'type alternate)
+ (alist-get 'title alternate)))
+ alternates)))
+
+(defun eww-read-alternate-url ()
+ "Get the URL of an alternate link of this page.
+
+If there is just one alternate link, return its URL. If there
+are multiple alternate links, prompt for one in the minibuffer
+with completion. If there are none, return nil."
+ (when-let ((alternates (eww--alternate-urls
+ (plist-get eww-data :dom)
+ (plist-get eww-data :url))))
+ (let ((url-max-width
+ (seq-max (mapcar #'string-pixel-width
+ (mapcar #'car alternates))))
+ (title-max-width
+ (seq-max (mapcar #'string-pixel-width
+ (mapcar #'caddr alternates))))
+ (sep-width (string-pixel-width " ")))
+ (if (cdr alternates)
+ (let ((completion-extra-properties
+ (list :annotation-function
+ (lambda (feed)
+ (let* ((attrs (alist-get feed
+ alternates
+ nil
+ nil
+ #'string=))
+ (type (car attrs))
+ (title (cadr attrs)))
+ (concat
+ (propertize " " 'display
+ `(space :align-to
+ (,(+ sep-width
+ url-max-width))))
+ title
+ (when type
+ (concat
+ (propertize " " 'display
+ `(space :align-to
+ (,(+ (* 2 sep-width)
+ url-max-width
+ title-max-width))))
+ "[" type "]"))))))))
+ (completing-read "Alternate URL: " alternates nil t))
+ (caar alternates)))))
+
+(defun eww-copy-alternate-url ()
+ "Copy the alternate URL of the current page into the kill ring.
+If there are multiple alternate links on the current page, prompt
+for one in the minibuffer, with completion.
+Alternate links are references that an HTML page may include to
+point to its alternative representations, such as a translated
+version or an RSS feed."
+ (interactive nil eww-mode)
+ (if-let ((url (eww-read-alternate-url)))
+ (progn
+ (kill-new url)
+ (message "Copied %s to kill ring" url))
+ (user-error "No alternate links found on this page!")))
+
;;; eww.el ends here
diff --git a/lisp/net/gnutls.el b/lisp/net/gnutls.el
index aee5dbd01e2..b0c3dcb9a70 100644
--- a/lisp/net/gnutls.el
+++ b/lisp/net/gnutls.el
@@ -96,7 +96,7 @@ Security'."
(repeat :tag "List of hostname regexps with flags for each"
(list
(choice :tag "Hostname"
- (const ".*" :tag "Any hostname")
+ (const :tag "Any hostname" ".*")
regexp)
(set (const :trustfiles)
(const :hostname))))))
@@ -262,6 +262,7 @@ For the meaning of the rest of the parameters, see `gnutls-boot-parameters'."
&key type hostname priority-string
trustfiles crlfiles keylist min-prime-bits
verify-flags verify-error verify-hostname-error
+ pass flags
&allow-other-keys)
"Return a keyword list of parameters suitable for passing to `gnutls-boot'.
@@ -278,6 +279,13 @@ default.
VERIFY-HOSTNAME-ERROR is a backwards compatibility option for
putting `:hostname' in VERIFY-ERROR.
+PASS is a string, the password of the key. It may also be nil,
+for a NULL password.
+
+FLAGS is a list of symbols corresponding to the equivalent ORed
+bitflag of the gnutls_pkcs_encrypt_flags_t enum of GnuTLS. The
+empty list corresponds to the bitflag with value 0.
+
When VERIFY-ERROR is t or a list containing `:trustfiles', an
error will be raised when the peer certificate verification fails
as per GnuTLS' gnutls_certificate_verify_peers2. Otherwise, only
@@ -355,6 +363,8 @@ defaults to GNUTLS_VERIFY_ALLOW_X509_V1_CA_CRT."
:keylist ,keylist
:verify-flags ,verify-flags
:verify-error ,verify-error
+ :pass ,pass
+ :flags ,flags
:callbacks nil)))
(defun gnutls--get-files (files)
diff --git a/lisp/net/imap.el b/lisp/net/imap.el
index 3268badab76..a06740528e9 100644
--- a/lisp/net/imap.el
+++ b/lisp/net/imap.el
@@ -1057,7 +1057,7 @@ necessary. If nil, the buffer name is generated."
(setq imap-capability nil)
(setq streams nil))))))
(when (imap-opened buffer)
- (setq imap-mailbox-data (make-vector imap-mailbox-prime 0)))
+ (setq imap-mailbox-data (obarray-make imap-mailbox-prime)))
;; (debug "opened+state+auth+buffer" (imap-opened buffer) imap-state imap-auth buffer)
(when imap-stream
buffer))))
@@ -1280,7 +1280,7 @@ If EXAMINE is non-nil, do a read-only select."
(concat (if examine "EXAMINE" "SELECT") " \""
mailbox "\"")))
(progn
- (setq imap-message-data (make-vector imap-message-prime 0)
+ (setq imap-message-data (obarray-make imap-message-prime)
imap-state (if examine 'examine 'selected))
imap-current-mailbox)
;; Failed SELECT/EXAMINE unselects current mailbox
@@ -1722,7 +1722,7 @@ See `imap-enable-exchange-bug-workaround'."
(string-to-number (nth 2 (imap-mailbox-get-1 'copyuid mailbox))))
(let ((old-mailbox imap-current-mailbox)
(state imap-state)
- (imap-message-data (make-vector 2 0)))
+ (imap-message-data (obarray-make 2)))
(when (imap-mailbox-examine-1 mailbox)
(prog1
(and (imap-fetch-safe '("*" . "*:*") "UID")
@@ -1768,7 +1768,7 @@ first element. The rest of list contains the saved articles' UIDs."
(imap-mailbox-get-1 'appenduid mailbox)
(let ((old-mailbox imap-current-mailbox)
(state imap-state)
- (imap-message-data (make-vector 2 0)))
+ (imap-message-data (obarray-make 2)))
(when (imap-mailbox-examine-1 mailbox)
(prog1
(and (imap-fetch-safe '("*" . "*:*") "UID")
@@ -1833,7 +1833,7 @@ on failure."
(defun imap-send-command (command &optional buffer)
(with-current-buffer (or buffer (current-buffer))
- (if (not (listp command)) (setq command (list command)))
+ (setq command (ensure-list command))
(let ((tag (setq imap-tag (1+ imap-tag)))
cmd cmdstr)
(setq cmdstr (concat (number-to-string imap-tag) " "))
diff --git a/lisp/net/ldap.el b/lisp/net/ldap.el
index 2ef61f5283b..2ec3f927a40 100644
--- a/lisp/net/ldap.el
+++ b/lisp/net/ldap.el
@@ -472,7 +472,8 @@ the associated values.
If WITHDN is non-nil, each entry in the result will be prepended with
its distinguished name WITHDN.
Additional search parameters can be specified through
-`ldap-host-parameters-alist', which see."
+`ldap-host-parameters-alist', which see.
+See `ldap-search-internal' for the description of return value."
(interactive "sFilter:")
(or host
(setq host ldap-default-host)
@@ -487,7 +488,9 @@ Additional search parameters can be specified through
(if ldap-ignore-attribute-codings
result
(mapcar (lambda (record)
- (mapcar #'ldap-decode-attribute record))
+ (append (and withdn (list (car record)))
+ (mapcar #'ldap-decode-attribute
+ (if withdn (cdr record) record))))
result))))
(defun ldap-password-read (host)
@@ -570,8 +573,13 @@ RFC 1779 syntax).
`sizelimit' is the maximum number of matches to return.
`withdn' if non-nil each entry in the result will be prepended with
its distinguished name DN.
-The function returns a list of matching entries. Each entry is itself
-an alist of attribute/value pairs."
+
+The function returns a list of matching entries. Each entry is
+itself a list ATTRS of (ATTR VALUE) pairs; `dn' attribute is not
+included.
+When `withdn' is non-nil the result is instead an alist with
+elements (DN . ATTRS), where DN is a string value and ATTRS is
+same as above."
(let* ((buf (get-buffer-create " *ldap-search*"))
(bufval (get-buffer-create " *ldap-value*"))
(host (or (plist-get search-plist 'host)
@@ -703,35 +711,42 @@ an alist of attribute/value pairs."
(while (progn
(skip-chars-forward " \t\n")
(not (eobp)))
- (setq dn (buffer-substring (point) (line-end-position)))
- (forward-line 1)
(while (looking-at "^\\([A-Za-z][-A-Za-z0-9]*\
\\|[0-9]+\\(?:\\.[0-9]+\\)*\\)\\(;[-A-Za-z0-9]+\\)*[=:\t ]+\
\\(<[\t ]*file://\\)?\\(.*\\)$")
(setq name (match-string 1)
value (match-string 4))
- ;; Need to handle file:///D:/... as generated by OpenLDAP
- ;; on DOS/Windows as local files.
- (if (and (memq system-type '(windows-nt ms-dos))
- (eq (string-match "/\\(.:.*\\)$" value) 0))
- (setq value (match-string 1 value)))
- ;; Do not try to open non-existent files
- (if (match-string 3)
- (with-current-buffer bufval
- (erase-buffer)
- (set-buffer-multibyte nil)
- (insert-file-contents-literally value)
- (delete-file value)
- (setq value (buffer-string)))
- (setq value " "))
- (setq record (cons (list name value)
- record))
+ (when (memq system-type '(windows-nt ms-dos))
+ ;; Need to handle file:///D:/... as generated by
+ ;; OpenLDAP on DOS/Windows as local files.
+ (save-match-data
+ (when (eq (string-match "/\\(.:.*\\)$" value) 0)
+ (setq value (match-string 1 value)))))
+ (cond ((match-string 3) ;normal value written to a file
+ (with-current-buffer bufval
+ (erase-buffer)
+ (set-buffer-multibyte nil)
+ (insert-file-contents-literally value)
+ (delete-file value)
+ (setq value (buffer-string))))
+ (;; dn is output inline
+ (string-equal-ignore-case name "dn")
+ (setq dn value
+ name nil
+ value nil))
+ (t (setq value " ")))
+ (and name value
+ (setq record (cons (list name value)
+ record)))
(forward-line 1))
- (cond (withdn
- (push (cons dn (nreverse record)) result))
- (record
- (push (nreverse record) result)))
- (setq record nil)
+ (when dn
+ (cond (withdn
+ (push (cons dn (nreverse record))
+ result))
+ (record
+ (push (nreverse record) result))))
+ (setq record nil
+ dn nil)
(message "Parsing results... %d" numres)
(setq numres (1+ numres)))
(message "Parsing results... done")
diff --git a/lisp/net/mailcap.el b/lisp/net/mailcap.el
index d7559717081..5ff75deb4e6 100644
--- a/lisp/net/mailcap.el
+++ b/lisp/net/mailcap.el
@@ -510,7 +510,7 @@ If SOURCE, mark the entry with this as the source."
(skip-chars-forward "^;\n")
;; skip \;
(while (eq (char-before) ?\\)
- (backward-delete-char 1)
+ (delete-char -1)
(forward-char)
(skip-chars-forward "^;\n"))
(if (eq (or (char-after save-pos) 0) ?')
@@ -689,9 +689,9 @@ to supply to the test."
status cache result)
(cond ((not (or (stringp viewer) (fboundp viewer)))
nil) ; Non-existent Lisp function
+ ((null test-info) t) ; No test clause
((setq cache (assoc test mailcap-viewer-test-cache))
(cadr cache))
- ((not test-info) t) ; No test clause
(t
(setq
result
diff --git a/lisp/net/mairix.el b/lisp/net/mairix.el
index b50644b0c62..9557d1a5760 100644
--- a/lisp/net/mairix.el
+++ b/lisp/net/mairix.el
@@ -60,8 +60,7 @@
;;; History:
-;; 07/28/2008: version 0.2. Added VM interface, written by Ulrich
-;; Mueller.
+;; 07/28/2008: version 0.2. Added VM interface, written by Ulrich Müller.
;; 07/14/2008: Initial release
@@ -288,7 +287,7 @@ Currently there are `threads' and `flags'.")
(message-field-value field)))
;;; VM
-;;; written by Ulrich Mueller
+;;; written by Ulrich Müller
(declare-function vm-quit "ext:vm-folder" (&optional no-change))
(declare-function vm-visit-folder "ext:vm-startup"
diff --git a/lisp/net/net-utils.el b/lisp/net/net-utils.el
index 127efd4aeb9..83842cd6788 100644
--- a/lisp/net/net-utils.el
+++ b/lisp/net/net-utils.el
@@ -774,11 +774,11 @@ and `network-connection-service-alist', which see."
(process-name (concat "Finger [" user-and-host "]"))
(regexps finger-X.500-host-regexps)
) ;; found
- (and regexps
- (while (not (string-match (car regexps) host))
- (setq regexps (cdr regexps)))
- (when regexps
- (setq user-and-host user)))
+ (when regexps
+ (while (not (string-match (car regexps) host))
+ (setq regexps (cdr regexps)))
+ (when regexps
+ (setq user-and-host user)))
(run-network-program
process-name
host
diff --git a/lisp/net/newst-backend.el b/lisp/net/newst-backend.el
index 32190563d4d..920111f2134 100644
--- a/lisp/net/newst-backend.el
+++ b/lisp/net/newst-backend.el
@@ -81,15 +81,15 @@ considered to be running if the newsticker timer list is not empty."
("The Register"
"https://www.theregister.co.uk/headlines.rss")
("slashdot"
- "http://rss.slashdot.org/Slashdot/slashdot"
+ "https://rss.slashdot.org/Slashdot/slashdot"
nil
3600) ;/. will ban you if under 3600 seconds!
("Wired News"
"https://www.wired.com/feed/rss")
("Heise News (german)"
- "http://www.heise.de/newsticker/heise.rdf")
+ "https://www.heise.de/newsticker/heise.rdf")
("Tagesschau (german)"
- "http://www.tagesschau.de/newsticker.rdf"
+ "https://www.tagesschau.de/newsticker.rdf"
nil
1800))
"Default URL list in raw form.
@@ -618,13 +618,13 @@ If URL is nil it is searched at point."
(end-of-line)
(and
(re-search-backward
- "http://"
+ (rx "http" (? "s") "://")
(if (> (point) (+ (point-min) 100))
(- (point) 100)
(point-min))
t)
(re-search-forward
- "http://[-a-zA-Z0-9&/_.]*"
+ (rx "http" (? "s") "://" (zero-or-more (any "-a-zA-Z0-9&/_.")))
(if (< (point) (- (point-max) 200))
(+ (point) 200)
(point-max))
@@ -1168,7 +1168,7 @@ URL `http://www.atompub.org/2005/08/17/draft-ietf-atompub-format-11.html'"
;; allows for integrating (x)html into the atom
;; structure but we need the raw html string.
;; e.g. https://www.heise.de/open/news/news-atom.xml
- ;; http://feeds.feedburner.com/ru_nix_blogs
+ ;; https://feeds.feedburner.com/ru_nix_blogs
(or (newsticker--unxml
(car (xml-node-children
(car (xml-get-children node 'content)))))
@@ -1302,7 +1302,7 @@ For the RSS 0.92 specification see URL `http://backend.userland.com/rss092'."
Return value as well as arguments NAME, TIME, and TOPNODE are the
same as in `newsticker--parse-atom-1.0'.
-For the RSS 1.0 specification see URL `http://web.resource.org/rss/1.0/spec'."
+For the RSS 1.0 specification see URL `https://web.resource.org/rss/1.0/spec'."
(newsticker--debug-msg "Parsing RSS 1.0 feed %s" name)
(let* ((channelnode (car (xml-get-children topnode 'channel)))
is-new-feed has-new-items)
@@ -1361,7 +1361,7 @@ For the RSS 1.0 specification see URL `http://web.resource.org/rss/1.0/spec'."
Return value as well as arguments NAME, TIME, and TOPNODE are the
same as in `newsticker--parse-atom-1.0'.
-For the RSS 2.0 specification see URL `http://blogs.law.harvard.edu/tech/rss'."
+For the RSS 2.0 specification see URL `https://cyber.harvard.edu/rss/'."
(newsticker--debug-msg "Parsing RSS 2.0 feed %s" name)
(let* ((channelnode (car (xml-get-children topnode 'channel)))
is-new-feed has-new-items)
@@ -1623,7 +1623,7 @@ Sat, 07 Sep 2002 00:00:01 GMT
":\\([0-9]\\{2\\}\\)"
;; second
"\\(:\\([0-9]\\{2\\}\\)\\)?"
- ;; zone -- fixme
+ ;; zone
"\\(\\s-+\\("
"UT\\|GMT\\|EST\\|EDT\\|CST\\|CDT\\|MST\\|MDT\\|PST\\|PDT"
"\\|\\([-+]\\)\\([0-9]\\{2\\}\\)\\([0-9]\\{2\\}\\)"
@@ -1642,16 +1642,26 @@ Sat, 07 Sep 2002 00:00:01 GMT
(offset-hour (read (or (match-string 14 rfc822-string)
"0")))
(offset-minute (read (or (match-string 15 rfc822-string)
- "0")))
- ;;FIXME
- )
+ "0"))))
(when zone
(cond ((string= sign "+")
(setq hour (- hour offset-hour))
(setq minute (- minute offset-minute)))
((string= sign "-")
(setq hour (+ hour offset-hour))
- (setq minute (+ minute offset-minute)))))
+ (setq minute (+ minute offset-minute)))
+ ((or (string= zone "UT") (string= zone "GMT"))
+ nil)
+ ((string= zone "EDT")
+ (setq hour (+ hour 4)))
+ ((or (string= zone "EST") (string= zone "CDT"))
+ (setq hour (+ hour 5)))
+ ((or (string= zone "CST") (string= zone "MDT"))
+ (setq hour (+ hour 6)))
+ ((or (string= zone "MST") (string= zone "PDT"))
+ (setq hour (+ hour 7)))
+ ((string= zone "PST")
+ (setq hour (+ hour 8)))))
(condition-case error-data
(let ((i 1))
(dolist (m '("Jan" "Feb" "Mar" "Apr" "May" "Jun" "Jul" "Aug"
@@ -1666,15 +1676,6 @@ Sat, 07 Sep 2002 00:00:01 GMT
nil))))
nil))
-;; FIXME: Can this be replaced by seq-intersection?
-(defun newsticker--lists-intersect-p (list1 list2)
- "Return t if LIST1 and LIST2 share elements."
- (let ((result nil))
- (dolist (elt list1)
- (if (memq elt list2)
- (setq result t)))
- result))
-
(defun newsticker--update-process-ids ()
"Update list of ids of active newsticker processes.
Checks list of active processes against list of newsticker processes."
diff --git a/lisp/net/newst-plainview.el b/lisp/net/newst-plainview.el
index 18c47391a1c..6b7050a9ff0 100644
--- a/lisp/net/newst-plainview.el
+++ b/lisp/net/newst-plainview.el
@@ -573,14 +573,10 @@ calls `w3m-toggle-inline-image'. It works only if
(when pos
(goto-char pos)
(when (get-text-property pos 'w3m-image)
- (let ((invis (newsticker--lists-intersect-p
- (get-text-property (1- (point))
- 'invisible)
- buffer-invisibility-spec)))
- (unless (car (get-text-property (1- (point))
- 'display))
- (unless invis
- (w3m-toggle-inline-image t)))))))))))))
+ (unless (car (get-text-property (1- (point))
+ 'display))
+ (unless (invisible-p (1- (point)))
+ (w3m-toggle-inline-image t))))))))))))
;; ======================================================================
;;; Keymap stuff
@@ -606,9 +602,7 @@ is non-nil."
(goto-char (point-min))
(newsticker-next-new-item t))
(setq go-ahead nil))
- (unless (newsticker--lists-intersect-p
- (get-text-property (point) 'invisible)
- buffer-invisibility-spec)
+ (unless (invisible-p (point))
;; this item is invisible -- continue search
(setq go-ahead nil))))
(run-hooks 'newsticker-select-item-hook)
@@ -627,9 +621,7 @@ is non-nil."
(unless do-not-wrap-at-bob
(goto-char (point-max))
(newsticker--buffer-goto '(item) 'new t)))
- (unless (newsticker--lists-intersect-p
- (get-text-property (point) 'invisible)
- buffer-invisibility-spec)
+ (unless (invisible-p (point))
(setq go-ahead nil))))
(run-hooks 'newsticker-select-item-hook)
(point))
@@ -652,9 +644,7 @@ non-nil."
(unless do-not-wrap-at-eob
(goto-char (point-min)))
(setq go-ahead nil))
- (unless (newsticker--lists-intersect-p
- (get-text-property (point) 'invisible)
- buffer-invisibility-spec)
+ (unless (invisible-p (point))
(setq go-ahead nil))))
(run-hooks 'newsticker-select-item-hook)
(force-mode-line-update)
@@ -673,9 +663,7 @@ auto-narrow-to-item is enabled, nil is returned."
(while go-ahead
(unless (newsticker--buffer-goto '(item))
(setq go-ahead nil))
- (unless (newsticker--lists-intersect-p
- (get-text-property (point) 'invisible)
- buffer-invisibility-spec)
+ (unless (invisible-p (point))
(setq go-ahead nil)))
(if (and (> (point) current-pos)
(< (point) end-of-feed))
@@ -700,9 +688,7 @@ is non-nil."
(goto-char (point-max))))
(while go-ahead
(if (newsticker--buffer-goto search-list nil t)
- (unless (newsticker--lists-intersect-p
- (get-text-property (point) 'invisible)
- buffer-invisibility-spec)
+ (unless (invisible-p (point))
(setq go-ahead nil))
(goto-char (point-min))
(setq go-ahead nil))))
@@ -1079,9 +1065,7 @@ If VALUE is nil, auto-narrowing is turned off, otherwise it is turned on."
(while (< (point) (point-max))
(unless (newsticker--buffer-goto '(item))
(throw 'result nil))
- (unless (newsticker--lists-intersect-p
- (get-text-property (point) 'invisible)
- buffer-invisibility-spec)
+ (unless (invisible-p (point))
(throw 'result t))))))
(defun newsticker-previous-item-available-p ()
@@ -1091,9 +1075,7 @@ If VALUE is nil, auto-narrowing is turned off, otherwise it is turned on."
(while (> (point) (point-min))
(unless (newsticker--buffer-goto '(item) nil t)
(throw 'result nil))
- (unless (newsticker--lists-intersect-p
- (get-text-property (point) 'invisible)
- buffer-invisibility-spec)
+ (unless (invisible-p (point))
(throw 'result t))))))
(defun newsticker-item-not-old-p ()
@@ -1175,9 +1157,7 @@ The mode-line is changed accordingly."
(defun newsticker--buffer-redraw ()
"Redraw the newsticker window."
- (if (fboundp 'force-window-update)
- (force-window-update (current-buffer))
- (redraw-frame))
+ (force-window-update (current-buffer))
(run-hooks 'newsticker-buffer-change-hook)
(sit-for 0))
diff --git a/lisp/net/newst-reader.el b/lisp/net/newst-reader.el
index 1349e23b493..130e01a0deb 100644
--- a/lisp/net/newst-reader.el
+++ b/lisp/net/newst-reader.el
@@ -237,7 +237,8 @@ for formatting."
(cond ((listp contents)
(mapc (lambda (i)
(if (and (stringp i)
- (string-match "^http://.*" i))
+ (string-match
+ (rx bol "http" (? "s") "://" (* nonl)) i))
(let ((pos (point)))
(insert i " ") ; avoid self-reference from the
; nt-link thing
@@ -248,7 +249,7 @@ for formatting."
'help-echo
(format "mouse-2: visit (%s)" i)
'keymap keymap)))
- (insert (format "%s" i))))
+ (insert (format "%s" i))))
contents))
(t
(insert (format "%s" contents))))
diff --git a/lisp/net/newst-ticker.el b/lisp/net/newst-ticker.el
index 8b86ae9359d..cd0ecd4b868 100644
--- a/lisp/net/newst-ticker.el
+++ b/lisp/net/newst-ticker.el
@@ -44,8 +44,10 @@
"Last message that the newsticker displayed.")
(defvar newsticker--scrollable-text ""
"The text which is scrolled smoothly in the echo area.")
+(defvar newsticker--ticker-period-timer nil
+ "Timer for newsticker ticker display.")
(defvar newsticker--ticker-timer nil
- "Timer for newsticker ticker.")
+ "Timer for newsticker ticker scrolling.")
;;;###autoload
(defun newsticker-ticker-running-p ()
@@ -77,7 +79,7 @@ value effective."
(defcustom newsticker-ticker-interval
0.3
- "Time interval for displaying news items in the echo area (seconds).
+ "Time interval for scrolling news items in the echo area (seconds).
If equal or less than 0 no messages are shown in the echo area. For
smooth display (see `newsticker-scroll-smoothly') a value of 0.3 seems
reasonable. For non-smooth display a value of 10 is a good starting
@@ -86,6 +88,17 @@ point."
:set #'newsticker--set-customvar-ticker
:group 'newsticker-ticker)
+(defcustom newsticker-ticker-period
+ 0
+ "Time interval for displaying news items in the echo area (seconds).
+If equal or less than 0 messages are shown continuously. In order not
+to miss new items, a value of equal or less than the shortest feed
+retrieval interval (or the global `newsticker-retrieval-interval`) is
+recommended."
+ :type 'number
+ :set #'newsticker--set-customvar-ticker
+ :group 'newsticker-ticker)
+
(defcustom newsticker-scroll-smoothly
t
"Decides whether to flash or scroll news items.
@@ -129,9 +142,16 @@ If t the echo area will not show obsolete items. See also
"Called from the display timer.
This function calls a display function, according to the variable
`newsticker-scroll-smoothly'."
- (if newsticker-scroll-smoothly
- (newsticker--display-scroll)
- (newsticker--display-jump)))
+ (when (not newsticker--ticker-timer)
+ (if newsticker-scroll-smoothly
+ (setq newsticker--ticker-timer
+ (run-at-time 1
+ newsticker-ticker-interval
+ #'newsticker--display-scroll))
+ (setq newsticker--ticker-timer
+ (run-at-time nil
+ newsticker-ticker-interval
+ #'newsticker--display-jump)))))
(defsubst newsticker--echo-area-clean-p ()
"Check whether somebody is using the echo area / minibuffer.
@@ -149,7 +169,12 @@ there is another message displayed or the minibuffer is active."
(when (newsticker--echo-area-clean-p)
(setq newsticker--item-position (1+ newsticker--item-position))
(when (>= newsticker--item-position (length newsticker--item-list))
- (setq newsticker--item-position 0))
+ (setq newsticker--item-position 0)
+ (when (> newsticker-ticker-period 0)
+ (cancel-timer newsticker--ticker-timer)
+ (setq newsticker--ticker-timer nil)
+ (run-at-time newsticker-ticker-interval nil
+ (lambda () (message "")))))
(setq newsticker--prev-message
(nth newsticker--item-position newsticker--item-list))
(message "%s" newsticker--prev-message))))
@@ -192,7 +217,12 @@ there is another message displayed or the minibuffer is active."
(setq newsticker--prev-message subtext)
(setq newsticker--item-position (1+ i))
(when (>= newsticker--item-position l)
- (setq newsticker--item-position 0))))))
+ (setq newsticker--item-position 0)
+ (when (> newsticker-ticker-period 0)
+ (cancel-timer newsticker--ticker-timer)
+ (setq newsticker--ticker-timer nil)
+ (run-at-time newsticker-ticker-interval nil
+ (lambda () (message "")))))))))
;;;###autoload
(defun newsticker-start-ticker ()
@@ -200,19 +230,26 @@ there is another message displayed or the minibuffer is active."
Start display timer for the actual ticker if wanted and not
running already."
(interactive)
- (if (and (> newsticker-ticker-interval 0)
- (not newsticker--ticker-timer))
- (setq newsticker--ticker-timer
- (run-at-time newsticker-ticker-interval
- newsticker-ticker-interval
- #'newsticker--display-tick))))
+ (when (and (> newsticker-ticker-interval 0)
+ (not newsticker--ticker-period-timer)
+ (not newsticker--ticker-timer))
+ (if (> newsticker-ticker-period 0)
+ (setq newsticker--ticker-period-timer
+ (run-at-time nil
+ newsticker-ticker-period
+ #'newsticker--display-tick))
+ (newsticker--display-tick))))
(defun newsticker-stop-ticker ()
"Stop newsticker's ticker (but not the news retrieval)."
(interactive)
- (when newsticker--ticker-timer
- (cancel-timer newsticker--ticker-timer)
- (setq newsticker--ticker-timer nil)))
+ (progn
+ (when newsticker--ticker-timer
+ (cancel-timer newsticker--ticker-timer)
+ (setq newsticker--ticker-timer nil))
+ (when newsticker--ticker-period-timer
+ (cancel-timer newsticker--ticker-period-timer)
+ (setq newsticker--ticker-period-timer nil))))
;; ======================================================================
;;; Manipulation of ticker text
diff --git a/lisp/net/newsticker.el b/lisp/net/newsticker.el
index 1fca950d188..b34c0268941 100644
--- a/lisp/net/newsticker.el
+++ b/lisp/net/newsticker.el
@@ -47,9 +47,9 @@
;; * RSS 0.92
;; (see http://backend.userland.com/rss092)
;; * RSS 1.0
-;; (see http://purl.org/rss/1.0/spec)
+;; (see https://web.resource.org/rss/1.0/spec)
;; * RSS 2.0
-;; (see http://blogs.law.harvard.edu/tech/rss)
+;; (see https://cyber.harvard.edu/rss/)
;; as well as the following Atom formats:
;; * Atom 0.3
;; * Atom 1.0
diff --git a/lisp/net/nsm.el b/lisp/net/nsm.el
index 436a1879c1d..830dc9372ab 100644
--- a/lisp/net/nsm.el
+++ b/lisp/net/nsm.el
@@ -149,10 +149,11 @@ unencrypted."
(dhe-prime-kx medium)
(sha1-sig medium)
(ecdsa-cbc-cipher medium)
+ ;; Deprecated by NIST from 2016/2023 (see also CVE-2016-2183).
+ (3des-cipher medium)
;; Towards TLS 1.3
(dhe-kx high)
(rsa-kx high)
- (3des-cipher high)
(cbc-cipher high))
"This variable specifies what TLS connection checks to perform.
It's an alist where the key is the name of the check, and the
@@ -169,13 +170,13 @@ otherwise.
See also: `nsm-check-tls-connection', `nsm-save-host-names',
`nsm-settings-file'"
- :version "27.1"
:type '(repeat (list (symbol :tag "Check function")
(choice :tag "Level"
:value medium
(const :tag "Low" low)
(const :tag "Medium" medium)
- (const :tag "High" high)))))
+ (const :tag "High" high))))
+ :version "30.1")
(defun nsm-save-fingerprint-maybe (host port status &rest _)
"Save the certificate's fingerprint.
@@ -386,12 +387,11 @@ between the user and the server, to downgrade vulnerable TLS
connections to insecure 512-bit export grade cryptography.
The Logjam paper suggests using 1024-bit prime on the client to
-mitigate some effects of this attack, and upgrade to 2048-bit as
-soon as server configurations allow. According to SSLLabs' SSL
-Pulse tracker, only about 75% of server support 2048-bit key
-exchange in June 2018[2]. To provide a balance between
-compatibility and security, this function only checks for a
-minimum key strength of 1024-bit.
+mitigate some effects of this attack, and upgrading to 2048-bit
+as soon as server configurations allow. According to SSLLabs'
+SSL Pulse tracker the overwhelming majority of servers support
+2048-bit key exchange in October 2023[2]. This function
+therefore checks for a minimum key strength of 2048 bits.
See also: `nsm-protocol-check--dhe-kx'
@@ -403,10 +403,10 @@ Diffie-Hellman Fails in Practice\", `https://weakdh.org/'
`https://www.ssllabs.com/ssl-pulse/'"
(let ((prime-bits (plist-get status :diffie-hellman-prime-bits)))
(if (and (string-match "^\\bDHE\\b" (plist-get status :key-exchange))
- (< prime-bits 1024))
+ (< prime-bits 2048))
(format-message
"Diffie-Hellman key strength (%s bits) too weak (%s bits)"
- prime-bits 1024))))
+ prime-bits 2048))))
(defun nsm-protocol-check--dhe-kx (_host _port status &optional _settings)
"Check for existence of DH key exchange based on integer factorization.
@@ -484,7 +484,7 @@ because of MAC-then-encrypt. This construction is vulnerable to
padding oracle attacks[1].
Since GnuTLS 3.4.0, the TLS encrypt-then-MAC extension[2] has
-been enabled by default[3]. If encrypt-then-MAC is negotiated,
+been enabled by default[3]. If encrypt-then-MAC is negotiated,
this check has no effect.
Reference:
@@ -1030,10 +1030,14 @@ protocol."
" Hostname:"
(nsm-certificate-part (plist-get cert :subject) "CN" t) "\n")
(when (and (plist-get cert :public-key-algorithm)
- (plist-get cert :signature-algorithm))
+ (plist-get cert :signature-algorithm)
+ (or (plist-get cert :public-key-id-sha256)
+ (plist-get cert :public-key-id)))
(insert
" Public key:" (plist-get cert :public-key-algorithm)
- ", signature: " (plist-get cert :signature-algorithm) "\n"))
+ ", signature: " (plist-get cert :signature-algorithm) "\n"
+ " Public key ID:" (or (plist-get cert :public-key-id-sha256)
+ (plist-get cert :public-key-id)) "\n"))
(when (and (plist-get status :key-exchange)
(plist-get status :cipher)
(plist-get status :mac)
diff --git a/lisp/net/ntlm.el b/lisp/net/ntlm.el
index 8089ddacce0..e753fe39602 100644
--- a/lisp/net/ntlm.el
+++ b/lisp/net/ntlm.el
@@ -8,6 +8,9 @@
;; Version: 2.1.0
;; Created: February 2001
+;; This is a GNU ELPA :core package. Avoid functionality that is not
+;; compatible with the version of Emacs recorded above.
+
;; This file is part of GNU Emacs.
;; GNU Emacs is free software: you can redistribute it and/or modify
@@ -98,7 +101,6 @@ USER is a string representing a user name to be authenticated and
DOMAIN is a NT domain. USER can include a NT domain part as in
user@domain where the string after @ is used as the domain if DOMAIN
is not given."
- (interactive)
(let ((request-ident (concat "NTLMSSP" (make-string 1 0)))
(request-msgType (concat (make-string 1 1) (make-string 3 0)))
;0x01 0x00 0x00 0x00
diff --git a/lisp/net/rcirc.el b/lisp/net/rcirc.el
index 4f536071003..0835d25460c 100644
--- a/lisp/net/rcirc.el
+++ b/lisp/net/rcirc.el
@@ -229,6 +229,12 @@ Uninteresting lines are those whose responses are listed in
Used as the first arg to `format-time-string'."
:type 'string)
+(defcustom rcirc-log-time-format "%d-%b %H:%M "
+ "Describes how timestamps are printed in the log files.
+Used as the first arg to `format-time-string'."
+ :version "30.1"
+ :type 'string )
+
(defcustom rcirc-input-ring-size 1024
"Size of input history ring."
:type 'integer)
@@ -392,8 +398,9 @@ and the cdr part is used for encoding."
(cons (coding-system :tag "Decode")
(coding-system :tag "Encode")))))
-(defcustom rcirc-multiline-major-mode 'fundamental-mode
+(defcustom rcirc-multiline-major-mode #'text-mode
"Major-mode function to use in multiline edit buffers."
+ :version "30.1"
:type 'function)
(defcustom rcirc-nick-completion-format "%s: "
@@ -1397,10 +1404,10 @@ inserted."
(interactive "P")
(rcirc-format "\^_" replace))
-(defun rcirc-format-strike-trough (replace)
- "Insert strike-trough formatting.
+(defun rcirc-format-strike-through (replace)
+ "Insert strike-through formatting.
If REPLACE is non-nil or a prefix argument is given, any prior
-formatting will be replaced before the strike-trough formatting
+formatting will be replaced before the strike-through formatting
is inserted."
(interactive "P")
(rcirc-format "\^^" replace))
@@ -1422,7 +1429,7 @@ inserted."
"C-c C-f C-b" #'rcirc-format-bold
"C-c C-f C-i" #'rcirc-format-italic
"C-c C-f C-u" #'rcirc-format-underline
- "C-c C-f C-s" #'rcirc-format-strike-trough
+ "C-c C-f C-s" #'rcirc-format-strike-through
"C-c C-f C-f" #'rcirc-format-fixed-width
"C-c C-f C-t" #'rcirc-format-fixed-width ;as in AucTeX
"C-c C-f C-d" #'rcirc-unformat
@@ -1808,7 +1815,7 @@ extracted."
"C-c C-f C-b" #'rcirc-format-bold
"C-c C-f C-i" #'rcirc-format-italic
"C-c C-f C-u" #'rcirc-format-underline
- "C-c C-f C-s" #'rcirc-format-strike-trough
+ "C-c C-f C-s" #'rcirc-format-strike-through
"C-c C-f C-f" #'rcirc-format-fixed-width
"C-c C-f C-t" #'rcirc-format-fixed-width ;as in AucTeX
"C-c C-f C-d" #'rcirc-unformat
@@ -2208,7 +2215,7 @@ disk. PROCESS is the process object for the current connection."
(parse-iso8601-time-string time t))))
(unless (null filename)
(let ((cell (assoc-string filename rcirc-log-alist))
- (line (concat (format-time-string rcirc-time-format time)
+ (line (concat (format-time-string rcirc-log-time-format time)
(substring-no-properties
(rcirc-format-response-string process sender
response target text))
@@ -2371,9 +2378,11 @@ This function does not alter the INPUT string."
"C-c C-@" #'rcirc-next-active-buffer
"C-c C-SPC" #'rcirc-next-active-buffer)
-(defcustom rcirc-track-abbrevate-flag t
+(define-obsolete-variable-alias 'rcirc-track-abbrevate-flag
+ 'rcirc-track-abbreviate-flag "30.1")
+(defcustom rcirc-track-abbreviate-flag t
"Non-nil means `rcirc-track-minor-mode' should abbreviate names."
- :version "28.1"
+ :version "30.1"
:type 'boolean)
;;;###autoload
@@ -2559,7 +2568,7 @@ activity. Only run if the buffer is not visible and
(funcall rcirc-channel-filter
(replace-regexp-in-string
"@.*?\\'" ""
- (or (and rcirc-track-abbrevate-flag
+ (or (and rcirc-track-abbreviate-flag
rcirc-short-buffer-name)
(buffer-name))))))
@@ -2971,20 +2980,13 @@ keywords when no KEYWORD is given."
browse-url-button-regexp)
"Regexp matching URLs. Set to nil to disable URL features in rcirc.")
-;; cf cl-remove-if-not
-(defun rcirc-condition-filter (condp lst)
- "Remove all items not satisfying condition CONDP in list LST.
-CONDP is a function that takes a list element as argument and returns
-non-nil if that element should be included. Returns a new list."
- (delq nil (mapcar (lambda (x) (and (funcall condp x) x)) lst)))
-
(defun rcirc-browse-url (&optional arg)
"Prompt for URL to browse based on URLs in buffer before point.
If ARG is given, opens the URL in a new browser window."
(interactive "P")
(let* ((point (point))
- (filtered (rcirc-condition-filter
+ (filtered (seq-filter
(lambda (x) (>= point (cdr x)))
rcirc-urls))
(completions (mapcar (lambda (x) (car x)) filtered))
@@ -4002,6 +4004,11 @@ PROCESS is the process object for the current connection."
(string-equal (downcase (car setting)) parameter))
return (cadr setting)))
+(define-obsolete-function-alias 'rcirc-format-strike-trough
+ 'rcirc-format-strike-through "30.1")
+
+(define-obsolete-function-alias 'rcirc-condition-filter #'seq-filter "30.1")
+
(provide 'rcirc)
;;; rcirc.el ends here
diff --git a/lisp/net/secrets.el b/lisp/net/secrets.el
index 32659adebcd..c1a670fde8c 100644
--- a/lisp/net/secrets.el
+++ b/lisp/net/secrets.el
@@ -687,13 +687,38 @@ ITEM can also be an object path, which is returned if contained in COLLECTION."
item (secrets-get-item-property item-path "Label"))
(throw 'item-found item-path)))))))
+(defun secrets-lock-item (collection item)
+ "Lock collection item labeled ITEM in COLLECTION.
+If successful, return the object path of the item. Does not lock
+the collection."
+ (let ((item-path (secrets-item-path collection item)))
+ (unless (secrets-empty-path item-path)
+ (secrets-prompt
+ (cadr
+ (dbus-call-method
+ :session secrets-service secrets-path secrets-interface-service
+ "Lock" `(:array :object-path ,item-path)))))
+ item-path))
+
+(defun secrets-unlock-item (collection item)
+ "Unlock item labeled ITEM from collection labeled COLLECTION.
+If successful, return the object path of the item."
+ (let ((item-path (secrets-item-path collection item)))
+ (unless (secrets-empty-path item-path)
+ (secrets-prompt
+ (cadr
+ (dbus-call-method
+ :session secrets-service secrets-path secrets-interface-service
+ "Unlock" `(:array :object-path ,item-path)))))
+ item-path))
+
(defun secrets-get-secret (collection item)
"Return the secret of item labeled ITEM in COLLECTION.
If there are several items labeled ITEM, it is undefined which
one is returned. If there is no such item, return nil.
ITEM can also be an object path, which is used if contained in COLLECTION."
- (let ((item-path (secrets-item-path collection item)))
+ (let ((item-path (secrets-unlock-item collection item)))
(unless (secrets-empty-path item-path)
(dbus-byte-array-to-string
(nth 2
diff --git a/lisp/net/shr.el b/lisp/net/shr.el
index 86b96b50502..09df5f5a9bb 100644
--- a/lisp/net/shr.el
+++ b/lisp/net/shr.el
@@ -163,6 +163,48 @@ the specpdl size. If nil, just give up."
:version "28.1"
:type 'boolean)
+(defcustom shr-fill-text t
+ "Non-nil means to fill the text according to the width of the window.
+If nil, text is not filled, and `visual-line-mode' can be used to reflow text."
+ :version "30.1"
+ :type 'boolean)
+
+
+(defcustom shr-sup-raise-factor 0.2
+ "The value of raise property for superscripts.
+Should be a non-negative float number between 0 and 1."
+ :version "30.1"
+ :type 'float)
+
+(defcustom shr-sub-raise-factor -0.2
+ "The value of raise property for subscripts.
+Should be a non-positive float number between 0 and 1."
+ :version "30.1"
+ :type 'float)
+
+(defcustom shr-image-ascent 100
+ "The value to be used for :ascent property when inserting images."
+ :version "30.1"
+ :type 'integer)
+
+(defcustom shr-max-inline-image-size nil
+ "If non-nil, determines when the images can be displayed inline.
+If nil, images are never displayed inline.
+
+It non-nil, it should be cons (WIDTH . HEIGHT).
+
+WIDTH can be an integer which is interpreted as number of pixels. If the width
+of an image exceeds this amount, the image is displayed on a separate line.
+WIDTH can also be floating point number, in which case the image is displayed
+inline if it occupies less than this fraction of window width.
+
+HEIGHT can be also be an integer or a floating point number. If it is an
+integer and the pixel height of an image exceeds it, the image image is
+displayed on a separate line. If it is a float number , the limit is
+interpreted as a multiple of the height of default font."
+ :version "30.1"
+ :type '(choice (const nil) (cons number number)))
+
(defvar shr-content-function nil
"If bound, this should be a function that will return the content.
This is used for cid: URLs, and the function is called with the
@@ -216,15 +258,18 @@ temporarily blinks with this face."
"Face for <h3> elements."
:version "28.1")
-(defface shr-h4 nil
+(defface shr-h4
+ '((t (:inherit default)))
"Face for <h4> elements."
:version "28.1")
-(defface shr-h5 nil
+(defface shr-h5
+ '((t (:inherit default)))
"Face for <h5> elements."
:version "28.1")
-(defface shr-h6 nil
+(defface shr-h6
+ '((t (:inherit default)))
"Face for <h6> elements."
:version "28.1")
@@ -694,7 +739,8 @@ size, and full-buffer size."
(replace-match " " t t)))
(defun shr-insert (text)
- (when (and (not (bolp))
+ (when (and (not shr-max-inline-image-size)
+ (not (bolp))
(get-text-property (1- (point)) 'image-url))
(insert "\n"))
(cond
@@ -738,8 +784,9 @@ size, and full-buffer size."
(or shr-current-font 'shr-text)))))))))
(defun shr-fill-lines (start end)
- (if (<= shr-internal-width 0)
- nil
+ "Indent and fill text from START to END.
+When `shr-fill-text' is nil, only indent."
+ (unless (<= shr-internal-width 0)
(save-restriction
(narrow-to-region start end)
(goto-char start)
@@ -761,6 +808,8 @@ size, and full-buffer size."
(forward-char 1))))
(defun shr-fill-line ()
+ "Indent and fill the current line.
+When `shr-fill-text' is nil, only indent."
(let ((shr-indentation (or (get-text-property (point) 'shr-indentation)
shr-indentation))
(continuation (get-text-property
@@ -775,9 +824,11 @@ size, and full-buffer size."
`,(shr-face-background face))))
(setq start (point))
(setq shr-indentation (or continuation shr-indentation))
- ;; If we have an indentation that's wider than the width we're
- ;; trying to fill to, then just give up and don't do any filling.
- (when (< shr-indentation shr-internal-width)
+ ;; Fill the current line, unless `shr-fill-text' is unset, or we
+ ;; have an indentation that's wider than the width we're trying to
+ ;; fill to.
+ (when (and shr-fill-text
+ (< shr-indentation shr-internal-width))
(shr-vertical-motion shr-internal-width)
(when (looking-at " $")
(delete-region (point) (line-end-position)))
@@ -1046,6 +1097,19 @@ the mouse click event."
(declare-function image-size "image.c" (spec &optional pixels frame))
(declare-function image-animate "image" (image &optional index limit position))
+(defun shr--inline-image-p (image)
+ "Return non-nil if IMAGE should be displayed inline."
+ (when shr-max-inline-image-size
+ (let ((size (image-size image t))
+ (max-width (car shr-max-inline-image-size))
+ (max-height (cdr shr-max-inline-image-size)))
+ (unless (integerp max-width)
+ (setq max-width (* max-width (window-width nil t))))
+ (unless (integerp max-height)
+ (setq max-height (* max-height (frame-char-height))))
+ (and (< (car size) max-width)
+ (< (cdr size) max-height)))))
+
(defun shr-put-image (spec alt &optional flags)
"Insert image SPEC with a string ALT. Return image.
SPEC is either an image data blob, or a list where the first
@@ -1060,11 +1124,11 @@ element is the data blob and the second element is the content-type."
(start (point))
(image (cond
((eq size 'original)
- (create-image data nil t :ascent 100
+ (create-image data nil t :ascent shr-image-ascent
:format content-type))
((eq content-type 'image/svg+xml)
(when (image-type-available-p 'svg)
- (create-image data 'svg t :ascent 100)))
+ (create-image data 'svg t :ascent shr-image-ascent)))
((eq size 'full)
(ignore-errors
(shr-rescale-image data content-type
@@ -1076,19 +1140,27 @@ element is the data blob and the second element is the content-type."
(plist-get flags :width)
(plist-get flags :height)))))))
(when image
+ ;; The trailing space can confuse shr-insert into not
+ ;; putting any space after inline images.
+ ;; ALT may be nil when visiting image URLs in eww
+ ;; (bug#67764).
+ (setq alt (if alt (string-trim alt) "*"))
;; When inserting big-ish pictures, put them at the
;; beginning of the line.
- (when (and (> (current-column) 0)
- (> (car (image-size image t)) 400))
- (insert "\n"))
- (let ((image-pos (point)))
- (if (eq size 'original)
- (insert-sliced-image image (or alt "*") nil 20 1)
- (insert-image image (or alt "*")))
- (put-text-property start (point) 'image-size size)
- (when (and shr-image-animate
- (cdr (image-multi-frame-p image)))
- (image-animate image nil 60 image-pos))))
+ (let ((inline (shr--inline-image-p image)))
+ (when (and (> (current-column) 0)
+ (not inline))
+ (insert "\n"))
+ (let ((image-pos (point)))
+ (if (eq size 'original)
+ (insert-sliced-image image alt nil 20 1)
+ (insert-image image alt))
+ (put-text-property start (point) 'image-size size)
+ (when (and (not inline) shr-max-inline-image-size)
+ (insert "\n"))
+ (when (and shr-image-animate
+ (cdr (image-multi-frame-p image)))
+ (image-animate image nil 60 image-pos)))))
image)
(insert (or alt ""))))
@@ -1111,7 +1183,7 @@ The size of the displayed image will not exceed
MAX-WIDTH/MAX-HEIGHT. If not given, use the current window
width/height instead."
(if (not (get-buffer-window (current-buffer) t))
- (create-image data nil t :ascent 100)
+ (create-image data nil t :ascent shr-image-ascent)
(let* ((edges (window-inside-pixel-edges
(get-buffer-window (current-buffer))))
(max-width (truncate (* shr-max-image-proportion
@@ -1132,13 +1204,13 @@ width/height instead."
(< (* height scaling) max-height))
(create-image
data (shr--image-type) t
- :ascent 100
+ :ascent shr-image-ascent
:width width
:height height
:format content-type)
(create-image
data (shr--image-type) t
- :ascent 100
+ :ascent shr-image-ascent
:max-width max-width
:max-height max-height
:format content-type)))))
@@ -1207,7 +1279,11 @@ START, and END. Note that START and END should be markers."
(defun shr-heading (dom &rest types)
(shr-ensure-paragraph)
- (apply #'shr-fontize-dom dom types)
+ (let ((start (point))
+ (level (string-to-number
+ (string-remove-prefix "shr-h" (symbol-name (car types))))))
+ (apply #'shr-fontize-dom dom types)
+ (put-text-property start (pos-eol) 'outline-level level))
(shr-ensure-paragraph))
(defun shr-urlify (start url &optional title)
@@ -1366,25 +1442,104 @@ ones, in case fg and bg are nil."
(shr-dom-print elem)))))
(insert (format "</%s>" (dom-tag dom))))
+(defconst shr-correct-attribute-case
+ '((attributename . attributeName)
+ (attributetype . attributeType)
+ (basefrequency . baseFrequency)
+ (baseprofile . baseProfile)
+ (calcmode . calcMode)
+ (clippathunits . clipPathUnits)
+ (diffuseconstant . diffuseConstant)
+ (edgemode . edgeMode)
+ (filterunits . filterUnits)
+ (glyphref . glyphRef)
+ (gradienttransform . gradientTransform)
+ (gradientunits . gradientUnits)
+ (kernelmatrix . kernelMatrix)
+ (kernelunitlength . kernelUnitLength)
+ (keypoints . keyPoints)
+ (keysplines . keySplines)
+ (keytimes . keyTimes)
+ (lengthadjust . lengthAdjust)
+ (limitingconeangle . limitingConeAngle)
+ (markerheight . markerHeight)
+ (markerunits . markerUnits)
+ (markerwidth . markerWidth)
+ (maskcontentunits . maskContentUnits)
+ (maskunits . maskUnits)
+ (numoctaves . numOctaves)
+ (pathlength . pathLength)
+ (patterncontentunits . patternContentUnits)
+ (patterntransform . patternTransform)
+ (patternunits . patternUnits)
+ (pointsatx . pointsAtX)
+ (pointsaty . pointsAtY)
+ (pointsatz . pointsAtZ)
+ (preservealpha . preserveAlpha)
+ (preserveaspectratio . preserveAspectRatio)
+ (primitiveunits . primitiveUnits)
+ (refx . refX)
+ (refy . refY)
+ (repeatcount . repeatCount)
+ (repeatdur . repeatDur)
+ (requiredextensions . requiredExtensions)
+ (requiredfeatures . requiredFeatures)
+ (specularconstant . specularConstant)
+ (specularexponent . specularExponent)
+ (spreadmethod . spreadMethod)
+ (startoffset . startOffset)
+ (stddeviation . stdDeviation)
+ (stitchtiles . stitchTiles)
+ (surfacescale . surfaceScale)
+ (systemlanguage . systemLanguage)
+ (tablevalues . tableValues)
+ (targetx . targetX)
+ (targety . targetY)
+ (textlength . textLength)
+ (viewbox . viewBox)
+ (viewtarget . viewTarget)
+ (xchannelselector . xChannelSelector)
+ (ychannelselector . yChannelSelector)
+ (zoomandpan . zoomAndPan))
+ "Attributes for correcting the case in SVG and MathML.
+Based on https://html.spec.whatwg.org/multipage/parsing.html#parsing-main-inforeign .")
+
+(defun shr-correct-dom-case (dom)
+ "Correct the case for SVG segments."
+ (dolist (attr (dom-attributes dom))
+ (when-let ((rep (assoc-default (car attr) shr-correct-attribute-case)))
+ (setcar attr rep)))
+ (dolist (child (dom-children dom))
+ (shr-correct-dom-case child))
+ dom)
+
(defun shr-tag-svg (dom)
(when (and (image-type-available-p 'svg)
(not shr-inhibit-images)
(dom-attr dom 'width)
(dom-attr dom 'height))
- (funcall shr-put-image-function (list (shr-dom-to-xml dom 'utf-8)
- 'image/svg+xml)
+ (funcall shr-put-image-function
+ (list (shr-dom-to-xml (shr-correct-dom-case dom) 'utf-8)
+ 'image/svg+xml)
"SVG Image")))
(defun shr-tag-sup (dom)
(let ((start (point)))
(shr-generic dom)
- (put-text-property start (point) 'display '(raise 0.2))
+ (put-text-property start (point) 'display `(raise ,shr-sup-raise-factor))
(add-face-text-property start (point) 'shr-sup)))
(defun shr-tag-sub (dom)
+ ;; Why would a subscript be at the beginning of a line? It does
+ ;; happen sometimes because of a <br> tag and the intent seems to be
+ ;; alignment of subscript and superscript but I don't think that is
+ ;; possible in Emacs. So we remove the newline in that case.
+ (when (bolp)
+ (forward-char -1)
+ (delete-char 1))
(let ((start (point)))
(shr-generic dom)
- (put-text-property start (point) 'display '(raise -0.2))
+ (put-text-property start (point) 'display `(raise ,shr-sub-raise-factor))
(add-face-text-property start (point) 'shr-sup)))
(defun shr-tag-p (dom)
@@ -1649,7 +1804,8 @@ The preference is a float determined from `shr-prefer-media-type'."
(and dom
(or (> (length (dom-attr dom 'src)) 0)
(> (length (dom-attr dom 'srcset)) 0))))
- (when (> (current-column) 0)
+ (when (and (not shr-max-inline-image-size)
+ (> (current-column) 0))
(insert "\n"))
(let ((alt (dom-attr dom 'alt))
(width (shr-string-number (dom-attr dom 'width)))
@@ -1700,8 +1856,14 @@ The preference is a float determined from `shr-prefer-media-type'."
(when (image-type-available-p 'svg)
(insert-image
(shr-make-placeholder-image dom)
- (or alt "")))
- (insert " ")
+ (or (string-trim alt) "")))
+ ;; Paradoxically this space causes shr not to insert spaces after
+ ;; inline images. Since the image is temporary it seem like there
+ ;; should be no downside to not inserting it but since I don't
+ ;; understand the code well and for the sake of backward compatibility
+ ;; we preserve it unless user has set `shr-max-inline-image-size'.
+ (unless shr-max-inline-image-size
+ (insert " "))
(url-queue-retrieve
url #'shr-image-fetched
(list (current-buffer) start (set-marker (make-marker) (point))
@@ -1837,7 +1999,7 @@ BASE is the URL of the HTML being rendered."
(svg-rectangle svg 0 0 width height :gradient "background"
:stroke-width 2 :stroke-color "black")
(let ((image (svg-image svg :scale 1)))
- (setf (image-property image :ascent) 100)
+ (setf (image-property image :ascent) shr-image-ascent)
image)))
(defun shr-tag-pre (dom)
@@ -1997,6 +2159,41 @@ BASE is the URL of the HTML being rendered."
(shr-generic dom)
(insert ?\N{POP DIRECTIONAL ISOLATE}))
+;;; Outline Support
+(defun shr-outline-search (&optional bound move backward looking-at)
+ "A function that can be used as `outline-search-function' for rendered html.
+See `outline-search-function' for BOUND, MOVE, BACKWARD and LOOKING-AT."
+ (if looking-at
+ (get-text-property (point) 'outline-level)
+ (let ((heading-found nil)
+ (bound (or bound
+ (if backward (point-min) (point-max)))))
+ (save-excursion
+ (when (and (not (bolp))
+ (get-text-property (point) 'outline-level))
+ (forward-line (if backward -1 1)))
+ (if backward
+ (unless (get-text-property (point) 'outline-level)
+ (goto-char (or (previous-single-property-change
+ (point) 'outline-level nil bound)
+ bound)))
+ (goto-char (or (text-property-not-all (point) bound 'outline-level nil)
+ bound)))
+ (goto-char (pos-bol))
+ (when (get-text-property (point) 'outline-level)
+ (setq heading-found (point))))
+ (if heading-found
+ (progn
+ (set-match-data (list heading-found heading-found))
+ (goto-char heading-found))
+ (when move
+ (goto-char bound)
+ nil)))))
+
+(defun shr-outline-level ()
+ "Function to be used as `outline-level' with `shr-outline-search'."
+ (get-text-property (point) 'outline-level))
+
;;; Table rendering algorithm.
;; Table rendering is the only complicated thing here. We do this by
@@ -2530,7 +2727,7 @@ flags that control whether to collect or render objects."
(setq natural-width
(or (dom-attr dom 'shr-td-cache-natural)
(let ((natural (max (shr-pixel-buffer-width)
- (shr-dom-max-natural-width dom 0))))
+ (shr-dom-max-natural-width dom))))
(dom-set-attribute dom 'shr-td-cache-natural natural)
natural))))
(if (and natural-width
@@ -2559,22 +2756,18 @@ flags that control whether to collect or render objects."
(cdr (assq 'color shr-stylesheet))
(cdr (assq 'background-color shr-stylesheet))))))
-(defun shr-dom-max-natural-width (dom max)
- (if (eq (dom-tag dom) 'table)
- (max max (or
- (cl-loop
- for line in (dom-attr dom 'shr-suggested-widths)
- maximize (+
- shr-table-separator-length
- (cl-loop for elem in line
- summing
- (+ (cdr elem)
- (* 2 shr-table-separator-length)))))
- 0))
- (dolist (child (dom-children dom))
- (unless (stringp child)
- (setq max (max (shr-dom-max-natural-width child max)))))
- max))
+(defun shr-dom-max-natural-width (dom)
+ (or (if (eq (dom-tag dom) 'table)
+ (cl-loop for line in (dom-attr dom 'shr-suggested-widths)
+ maximize (+ shr-table-separator-length
+ (cl-loop for elem in line
+ summing
+ (+ (cdr elem)
+ (* 2 shr-table-separator-length)))))
+ (cl-loop for child in (dom-children dom)
+ unless (stringp child)
+ maximize (shr-dom-max-natural-width child)))
+ 0))
(defun shr-buffer-width ()
(goto-char (point-min))
@@ -2618,11 +2811,12 @@ flags that control whether to collect or render objects."
columns))
(defun shr-count (dom elem)
+ ;; This is faster than `seq-count', and shr can use it.
(let ((i 0))
(dolist (sub (dom-children dom))
(when (and (not (stringp sub))
- (eq (dom-tag sub) elem))
- (setq i (1+ i))))
+ (eq (dom-tag sub) elem))
+ (setq i (1+ i))))
i))
(defun shr-max-columns (dom)
diff --git a/lisp/net/sieve-manage.el b/lisp/net/sieve-manage.el
index c95672f2c8d..0faeb02bcfd 100644
--- a/lisp/net/sieve-manage.el
+++ b/lisp/net/sieve-manage.el
@@ -168,25 +168,19 @@ Valid states are `closed', `initial', `nonauth', and `auth'.")
;; Internal utility functions
(defun sieve-manage--append-to-log (&rest args)
- "Append ARGS to `sieve-manage-log' buffer.
+ "Append ARGS to sieve-manage log buffer.
ARGS can be a string or a list of strings.
The buffer to use for logging is specified via `sieve-manage-log'.
-If it is nil, logging is disabled.
-
-When the `sieve-manage-log' buffer doesn't exist, it gets created (and
-configured with some initial settings)."
+If it is nil, logging is disabled."
(when sieve-manage-log
- (let* ((existing-log-buffer (get-buffer sieve-manage-log))
- (log-buffer (or existing-log-buffer
- (get-buffer-create sieve-manage-log))))
- (with-current-buffer log-buffer
- (unless existing-log-buffer
- ;; Do this only once, when creating the log buffer.
- (set-buffer-multibyte nil)
- (buffer-disable-undo))
- (goto-char (point-max))
- (apply #'insert args)))))
+ (with-current-buffer (or (get-buffer sieve-manage-log)
+ (with-current-buffer
+ (get-buffer-create sieve-manage-log)
+ (set-buffer-multibyte nil)
+ (buffer-disable-undo)))
+ (goto-char (point-max))
+ (apply #'insert args))))
(defun sieve-manage--message (format-string &rest args)
"Wrapper around `message' which also logs to sieve manage log.
@@ -517,7 +511,7 @@ If NAME is nil, return the full server list of capabilities."
(while (not pos)
(setq pos (search-forward-regexp pattern nil t))
(goto-char (point-min))
- (sleep-for 0 50))
+ (sleep-for 0.05))
pos))
(defun sieve-manage-drop-next-answer ()
diff --git a/lisp/net/sieve-mode.el b/lisp/net/sieve-mode.el
index 7ef11eb965a..4fbdd183973 100644
--- a/lisp/net/sieve-mode.el
+++ b/lisp/net/sieve-mode.el
@@ -55,39 +55,19 @@
;; Font-lock
(defface sieve-control-commands
- '((((type tty) (class color)) (:foreground "blue" :weight light))
- (((class grayscale) (background light)) (:foreground "LightGray" :bold t))
- (((class grayscale) (background dark)) (:foreground "DimGray" :bold t))
- (((class color) (background light)) (:foreground "Orchid"))
- (((class color) (background dark)) (:foreground "LightSteelBlue"))
- (t (:bold t)))
+ '((t :inherit font-lock-builtin-face))
"Face used for Sieve Control Commands.")
(defface sieve-action-commands
- '((((type tty) (class color)) (:foreground "blue" :weight bold))
- (((class color) (background light)) (:foreground "Blue"))
- (((class color) (background dark)) (:foreground "LightSkyBlue"))
- (t (:inverse-video t :bold t)))
+ '((t :inherit font-lock-function-name-face))
"Face used for Sieve Action Commands.")
(defface sieve-test-commands
- '((((type tty) (class color)) (:foreground "magenta"))
- (((class grayscale) (background light))
- (:foreground "LightGray" :bold t :underline t))
- (((class grayscale) (background dark))
- (:foreground "Gray50" :bold t :underline t))
- (((class color) (background light)) (:foreground "CadetBlue"))
- (((class color) (background dark)) (:foreground "Aquamarine"))
- (t (:bold t :underline t)))
+ '((t :inherit font-lock-constant-face))
"Face used for Sieve Test Commands.")
(defface sieve-tagged-arguments
- '((((type tty) (class color)) (:foreground "cyan" :weight bold))
- (((class grayscale) (background light)) (:foreground "LightGray" :bold t))
- (((class grayscale) (background dark)) (:foreground "DimGray" :bold t))
- (((class color) (background light)) (:foreground "Purple"))
- (((class color) (background dark)) (:foreground "Cyan"))
- (t (:bold t)))
+ '((t :inherit font-lock-keyword face))
"Face used for Sieve Tagged Arguments.")
diff --git a/lisp/net/sieve.el b/lisp/net/sieve.el
index fddc6e21bcc..a6ba556e7ae 100644
--- a/lisp/net/sieve.el
+++ b/lisp/net/sieve.el
@@ -354,7 +354,7 @@ Used to bracket operations which move point in the sieve-buffer."
(let ((script (buffer-string))
(script-name (file-name-sans-extension (buffer-name)))
err)
- (with-current-buffer (get-buffer sieve-buffer)
+ (with-current-buffer sieve-buffer
(setq err (sieve-manage-putscript
(or name sieve-buffer-script-name script-name)
script sieve-manage-buffer))
diff --git a/lisp/net/soap-client.el b/lisp/net/soap-client.el
index e36b34fc542..de04d58ed18 100644
--- a/lisp/net/soap-client.el
+++ b/lisp/net/soap-client.el
@@ -5,12 +5,15 @@
;; Author: Alexandru Harsanyi <AlexHarsanyi@gmail.com>
;; Author: Thomas Fitzsimmons <fitzsim@fitzsim.org>
;; Created: December, 2009
-;; Version: 3.2.1
+;; Version: 3.2.3
;; Keywords: soap, web-services, comm, hypermedia
;; Package: soap-client
;; URL: https://github.com/alex-hhh/emacs-soap-client
;; Package-Requires: ((emacs "24.1") (cl-lib "0.6.1"))
+;; This is a GNU ELPA :core package. Avoid functionality that is not
+;; compatible with the version of Emacs recorded above.
+
;; This file is part of GNU Emacs.
;; GNU Emacs is free software: you can redistribute it and/or modify
@@ -717,9 +720,9 @@ representing leap seconds."
second)
minute hour day month year second-fraction datatype time-zone)
(let ((time
- (encode-time (list
- (if new-decode-time new-decode-time-second second)
- minute hour day month year nil nil time-zone))))
+ ;; Call encode-time the old way, for Emacs<27.
+ (encode-time (if new-decode-time new-decode-time-second second)
+ minute hour day month year time-zone)))
(if new-decode-time
(with-no-warnings (decode-time time nil t))
(decode-time time))))))
@@ -946,7 +949,7 @@ This is a specialization of `soap-encode-attributes' for
(t nil)))
(defun soap-type-is-array? (type)
- "Return t if TYPE defines an ARRAY."
+ "Return t if TYPE is an ARRAY."
(and (soap-xs-complex-type-p type)
(eq (soap-xs-complex-type-indicator type) 'array)))
@@ -1317,7 +1320,7 @@ See also `soap-wsdl-resolve-references'."
"Validate VALUE against the basic type TYPE."
(let* ((kind (soap-xs-basic-type-kind type)))
(cl-case kind
- ((anyType Array byte[])
+ ((anyType Array byte\[\])
value)
(t
(let ((convert (get kind 'rng-xsd-convert)))
diff --git a/lisp/net/socks.el b/lisp/net/socks.el
index 01f20907557..ecbac7e2345 100644
--- a/lisp/net/socks.el
+++ b/lisp/net/socks.el
@@ -162,6 +162,7 @@
(radio-button-choice :tag "SOCKS Version"
:format "%t: %v"
(const :tag "SOCKS v4 " :format "%t" :value 4)
+ (const :tag "SOCKS v4a" :format "%t" :value 4a)
(const :tag "SOCKS v5" :format "%t" :value 5))))
@@ -202,6 +203,12 @@
"Command not supported"
"Address type not supported"))
+(defconst socks--errors-4
+ '("Granted"
+ "Rejected or failed"
+ "Cannot connect to identd on the client"
+ "Client and identd report differing user IDs"))
+
;; The socks v5 address types
(defconst socks-address-type-v4 1)
(defconst socks-address-type-name 3)
@@ -309,7 +316,8 @@
((pred (= socks-address-type-name))
(if (< (length string) 5)
255
- (+ 1 (aref string 4)))))))
+ (+ 1 (aref string 4))))
+ (0 0))))
(if (< (length string) desired-len)
nil ; Need to spin some more
(process-put proc 'socks-state socks-state-connected)
@@ -328,7 +336,6 @@
(advice-add 'open-network-stream :around #'socks--open-network-stream))
(defun socks-open-connection (server-info)
- (interactive)
(save-excursion
(let ((proc
(let ((socks-override-functions nil))
@@ -400,6 +407,7 @@ When ATYPE indicates an IP, param ADDRESS must be given as raw bytes."
(format "%c%s" (length address) address))
(t
(error "Unknown address type: %d" atype))))
+ trailing
request version)
(or (process-get proc 'socks)
(error "socks-send-command called on non-SOCKS connection %S" proc))
@@ -416,6 +424,12 @@ When ATYPE indicates an IP, param ADDRESS must be given as raw bytes."
(t
(error "Unsupported address type for HTTP: %d" atype)))
port)))
+ ((and (eq version '4a)
+ (setf addr "\0\0\0\1"
+ trailing (concat address "\0")
+ version 4 ; become version 4
+ (process-get proc 'socks-server-protocol) 4)
+ nil)) ; fall through
((equal version 4)
(setq request (concat
(unibyte-string
@@ -424,8 +438,9 @@ When ATYPE indicates an IP, param ADDRESS must be given as raw bytes."
(ash port -8) ; port, high byte
(logand port #xff)) ; port, low byte
addr ; address
- (user-full-name) ; username
- "\0"))) ; terminate username
+ socks-username ; username
+ "\0" ; terminate username
+ trailing))) ; optional host to look up
((equal version 5)
(setq request (concat
(unibyte-string
@@ -446,7 +461,13 @@ When ATYPE indicates an IP, param ADDRESS must be given as raw bytes."
nil ; Sweet sweet success!
(delete-process proc)
(error "SOCKS: %s"
- (nth (or (process-get proc 'socks-reply) 1) socks-errors)))
+ (let ((err (process-get proc 'socks-reply)))
+ (if (eql version 5)
+ (nth (or err 1) socks-errors)
+ ;; The defined error codes for v4 range from
+ ;; 90-93, but we store them in a simple list.
+ (nth (pcase err (90 0) (92 2) (93 3) (_ 1))
+ socks--errors-4)))))
proc))
diff --git a/lisp/net/tramp-adb.el b/lisp/net/tramp-adb.el
index f2c50983a32..da23d062c2e 100644
--- a/lisp/net/tramp-adb.el
+++ b/lisp/net/tramp-adb.el
@@ -71,14 +71,14 @@ It is used for TCP/IP devices."
"Regexp for date time format in ls output."))
(defconst tramp-adb-ls-date-regexp
- (tramp-compat-rx
+ (rx
blank (regexp tramp-adb-ls-date-year-regexp)
blank (regexp tramp-adb-ls-date-time-regexp)
blank)
"Regexp for date format in ls output.")
(defconst tramp-adb-ls-toolbox-regexp
- (tramp-compat-rx
+ (rx
bol (* blank) (group (+ (any ".-" alpha))) ; \1 permissions
(? (+ blank) (+ digit)) ; links (Android 7/toybox)
(* blank) (group (+ (not blank))) ; \2 username
@@ -130,6 +130,7 @@ It is used for TCP/IP devices."
(file-equal-p . tramp-handle-file-equal-p)
(file-executable-p . tramp-adb-handle-file-executable-p)
(file-exists-p . tramp-adb-handle-file-exists-p)
+ (file-group-gid . tramp-handle-file-group-gid)
(file-in-directory-p . tramp-handle-file-in-directory-p)
(file-local-copy . tramp-adb-handle-file-local-copy)
(file-locked-p . tramp-handle-file-locked-p)
@@ -153,6 +154,7 @@ It is used for TCP/IP devices."
(file-symlink-p . tramp-handle-file-symlink-p)
(file-system-info . tramp-adb-handle-file-system-info)
(file-truename . tramp-handle-file-truename)
+ (file-user-uid . tramp-handle-file-user-uid)
(file-writable-p . tramp-adb-handle-file-writable-p)
(find-backup-file-name . tramp-handle-find-backup-file-name)
;; `get-file-buffer' performed by default handler.
@@ -207,8 +209,10 @@ It is used for TCP/IP devices."
First arg specifies the OPERATION, second arg is a list of
arguments to pass to the OPERATION."
(if-let ((fn (assoc operation tramp-adb-file-name-handler-alist)))
- (save-match-data (apply (cdr fn) args))
- (tramp-run-real-handler operation args)))
+ (prog1 (save-match-data (apply (cdr fn) args))
+ (setq tramp-debug-message-fnh-function (cdr fn)))
+ (prog1 (tramp-run-real-handler operation args)
+ (setq tramp-debug-message-fnh-function operation))))
;;;###tramp-autoload
(tramp--with-startup
@@ -259,9 +263,10 @@ arguments to pass to the OPERATION."
(tramp-convert-file-attributes v localname id-format
(and
(tramp-adb-send-command-and-check
- v (format "%s -d -l %s | cat"
+ v (format "(%s -d -l %s; echo tramp_exit_status $?) | cat"
(tramp-adb-get-ls-command v)
- (tramp-shell-quote-argument localname)))
+ (tramp-shell-quote-argument localname))
+ nil t)
(with-current-buffer (tramp-get-buffer v)
(tramp-adb-sh-fix-ls-output)
(cdar (tramp-do-parse-file-attributes-with-ls v)))))))
@@ -271,7 +276,7 @@ arguments to pass to the OPERATION."
(with-current-buffer (tramp-get-buffer vec)
(goto-char (point-min))
(let (file-properties)
- (while (re-search-forward tramp-adb-ls-toolbox-regexp nil t)
+ (while (search-forward-regexp tramp-adb-ls-toolbox-regexp nil t)
(let* ((mod-string (match-string 1))
(is-dir (eq ?d (aref mod-string 0)))
(is-symlink (eq ?l (aref mod-string 0)))
@@ -312,12 +317,13 @@ arguments to pass to the OPERATION."
directory full match nosort id-format count
(with-current-buffer (tramp-get-buffer v)
(when (tramp-adb-send-command-and-check
- v (format "%s -a -l %s | cat"
+ v (format "(%s -a -l %s; echo tramp_exit_status $?) | cat"
(tramp-adb-get-ls-command v)
- (tramp-shell-quote-argument localname)))
+ (tramp-shell-quote-argument localname))
+ nil t)
;; We insert also filename/. and filename/.., because "ls"
;; doesn't on some file systems, like "sdcard".
- (unless (re-search-backward (rx "." eol) nil t)
+ (unless (search-backward-regexp (rx "." eol) nil t)
(narrow-to-region (point-max) (point-max))
(tramp-adb-send-command
v (format "%s -d -a -l %s %s | cat"
@@ -327,8 +333,7 @@ arguments to pass to the OPERATION."
(tramp-shell-quote-argument
(tramp-compat-file-name-concat localname ".."))))
(tramp-compat-replace-regexp-in-region
- (tramp-compat-rx (literal (tramp-compat-file-name-unquote
- (file-name-as-directory localname))))
+ (rx (literal (file-name-unquote (file-name-as-directory localname))))
"" (point-min))
(widen)))
(tramp-adb-sh-fix-ls-output)
@@ -366,14 +371,12 @@ Emacs dired can't find files."
(goto-char (point-min))
(while
(search-forward-regexp
- (tramp-compat-rx
- blank (group blank (regexp tramp-adb-ls-date-year-regexp) blank))
+ (rx blank (group blank (regexp tramp-adb-ls-date-year-regexp) blank))
nil t)
(replace-match "0\\1" "\\1" nil)
;; Insert missing "/".
(when (looking-at-p
- (tramp-compat-rx
- (regexp tramp-adb-ls-date-time-regexp) (+ blank) eol))
+ (rx (regexp tramp-adb-ls-date-time-regexp) (+ blank) eol))
(end-of-line)
(insert "/")))
;; Sort entries.
@@ -393,12 +396,10 @@ Emacs dired can't find files."
(defun tramp-adb-ls-output-time-less-p (a b)
"Sort \"ls\" output by time, descending."
(let (time-a time-b)
- ;; Once we can assume Emacs 27 or later, the two calls
- ;; (apply #'encode-time X) can be replaced by (encode-time X).
(string-match tramp-adb-ls-date-regexp a)
- (setq time-a (apply #'encode-time (parse-time-string (match-string 0 a))))
+ (setq time-a (encode-time (parse-time-string (match-string 0 a))))
(string-match tramp-adb-ls-date-regexp b)
- (setq time-b (apply #'encode-time (parse-time-string (match-string 0 b))))
+ (setq time-b (encode-time (parse-time-string (match-string 0 b))))
(time-less-p time-b time-a)))
(defun tramp-adb-ls-output-name-less-p (a b)
@@ -411,20 +412,11 @@ Emacs dired can't find files."
(defun tramp-adb-handle-make-directory (dir &optional parents)
"Like `make-directory' for Tramp files."
- (setq dir (expand-file-name dir))
- (with-parsed-tramp-file-name dir nil
- (when (and (null parents) (file-exists-p dir))
- (tramp-error v 'file-already-exists dir))
- (when parents
- (let ((par (expand-file-name ".." dir)))
- (unless (file-directory-p par)
- (make-directory par parents))))
- (tramp-flush-directory-properties v localname)
- (unless (or (tramp-adb-send-command-and-check
- v (format "mkdir -m %#o %s"
- (default-file-modes)
- (tramp-shell-quote-argument localname)))
- (and parents (file-directory-p dir)))
+ (tramp-skeleton-make-directory dir parents
+ (unless (tramp-adb-send-command-and-check
+ v (format "mkdir -m %#o %s"
+ (default-file-modes)
+ (tramp-shell-quote-argument localname)))
(tramp-error v 'file-error "Couldn't make directory %s" dir))))
(defun tramp-adb-handle-delete-directory (directory &optional recursive trash)
@@ -438,14 +430,10 @@ Emacs dired can't find files."
(defun tramp-adb-handle-delete-file (filename &optional trash)
"Like `delete-file' for Tramp files."
- (setq filename (expand-file-name filename))
- (with-parsed-tramp-file-name filename nil
- (tramp-flush-file-properties v localname)
- (if (and delete-by-moving-to-trash trash)
- (move-file-to-trash filename)
- (tramp-adb-barf-unless-okay
- v (format "rm %s" (tramp-shell-quote-argument localname))
- "Couldn't delete %s" filename))))
+ (tramp-skeleton-delete-file filename trash
+ (tramp-adb-barf-unless-okay
+ v (format "rm %s" (tramp-shell-quote-argument localname))
+ "Couldn't delete %s" filename)))
(defun tramp-adb-handle-file-name-all-completions (filename directory)
"Like `file-name-all-completions' for Tramp files."
@@ -454,10 +442,12 @@ Emacs dired can't find files."
filename
(with-parsed-tramp-file-name (expand-file-name directory) nil
(with-tramp-file-property v localname "file-name-all-completions"
- (tramp-adb-send-command
- v (format "%s -a %s | cat"
- (tramp-adb-get-ls-command v)
- (tramp-shell-quote-argument localname)))
+ (unless (tramp-adb-send-command-and-check
+ v (format "(%s -a %s; echo tramp_exit_status $?) | cat"
+ (tramp-adb-get-ls-command v)
+ (tramp-shell-quote-argument localname))
+ nil t)
+ (erase-buffer))
(mapcar
(lambda (f)
(if (file-directory-p (expand-file-name f directory))
@@ -477,7 +467,7 @@ Emacs dired can't find files."
;; "adb pull ..." does not always return an error code.
(unless
(and (tramp-adb-execute-adb-command
- v "pull" (tramp-compat-file-name-unquote localname) tmpfile)
+ v "pull" (file-name-unquote localname) tmpfile)
(file-exists-p tmpfile))
(ignore-errors (delete-file tmpfile))
(tramp-error
@@ -518,12 +508,11 @@ Emacs dired can't find files."
(with-parsed-tramp-file-name (expand-file-name filename) nil
(with-tramp-file-property v localname "file-writable-p"
(if (file-exists-p filename)
- (if (tramp-file-property-p v localname "file-attributes")
- ;; Examine `file-attributes' cache to see if request can
- ;; be satisfied without remote operation.
- (tramp-check-cached-permissions v ?w)
- (tramp-adb-send-command-and-check
- v (format "test -w %s" (tramp-shell-quote-argument localname))))
+ ;; The file-attributes cache is unreliable since its
+ ;; information does not take partition writability into
+ ;; account, so a call to test must never be skipped.
+ (tramp-adb-send-command-and-check
+ v (format "test -w %s" (tramp-shell-quote-argument localname)))
;; If file doesn't exist, check if directory is writable.
(and
(file-directory-p (file-name-directory filename))
@@ -552,8 +541,7 @@ Emacs dired can't find files."
"Moving tmp file `%s' to `%s'" tmpfile filename)
(unwind-protect
(unless (tramp-adb-execute-adb-command
- v "push" tmpfile
- (tramp-compat-file-name-unquote localname))
+ v "push" tmpfile (file-name-unquote localname))
(tramp-error v 'file-error "Cannot write: `%s'" filename))
(delete-file tmpfile)))))))
@@ -568,11 +556,7 @@ Emacs dired can't find files."
(defun tramp-adb-handle-set-file-times (filename &optional time flag)
"Like `set-file-times' for Tramp files."
(tramp-skeleton-set-file-modes-times-uid-gid filename
- (let ((time (if (or (null time)
- (tramp-compat-time-equal-p time tramp-time-doesnt-exist)
- (tramp-compat-time-equal-p time tramp-time-dont-know))
- (current-time)
- time))
+ (let ((time (tramp-defined-time time))
(nofollow (if (eq flag 'nofollow) "-h" ""))
(quoted-name (tramp-shell-quote-argument localname)))
;; Older versions of toybox 'touch' mishandle nanoseconds and/or
@@ -658,8 +642,8 @@ PRESERVE-UID-GID and PRESERVE-EXTENDED-ATTRIBUTES are completely ignored."
(tramp-flush-file-properties v localname)
(unless (tramp-adb-execute-adb-command
v "push"
- (tramp-compat-file-name-unquote filename)
- (tramp-compat-file-name-unquote localname))
+ (file-name-unquote filename)
+ (file-name-unquote localname))
(tramp-error
v 'file-error
"Cannot copy `%s' `%s'" filename newname)))))))))
@@ -725,11 +709,6 @@ PRESERVE-UID-GID and PRESERVE-EXTENDED-ATTRIBUTES are completely ignored."
"Strings to return by `process-file' in case of signals."
(with-tramp-connection-property vec "signal-strings"
(let ((default-directory (tramp-make-tramp-file-name vec 'noloc))
- ;; `shell-file-name' and `shell-command-switch' are needed
- ;; for Emacs < 27.1, which doesn't support connection-local
- ;; variables in `shell-command'.
- (shell-file-name "/system/bin/sh")
- (shell-command-switch "-c")
process-file-return-signal-string signals result)
(dotimes (i 128) (push (format "Signal %d" i) result))
(setq result (reverse result)
@@ -762,7 +741,7 @@ PRESERVE-UID-GID and PRESERVE-EXTENDED-ATTRIBUTES are completely ignored."
;; Determine input.
(if (null infile)
(setq input (tramp-get-remote-null-device v))
- (setq infile (tramp-compat-file-name-unquote (expand-file-name infile)))
+ (setq infile (file-name-unquote (expand-file-name infile)))
(if (tramp-equal-remote default-directory infile)
;; INFILE is on the same remote host.
(setq input (tramp-unquote-file-local-name infile))
@@ -938,9 +917,9 @@ implementation will be used."
(i 0)
p)
- (when (string-match-p (tramp-compat-rx multibyte) command)
+ (when (string-match-p (rx multibyte) command)
(tramp-error
- v 'file-error "Cannot apply multi-byte command `%s'" command))
+ v 'file-error "Cannot apply multibyte command `%s'" command))
(while (get-process name1)
;; NAME must be unique as process name.
@@ -1022,6 +1001,7 @@ implementation will be used."
;; deleted.
(when (bufferp stderr)
(ignore-errors
+ (tramp-taint-remote-process-buffer stderr)
(with-current-buffer stderr
(insert-file-contents-literally
remote-tmpstderr 'visit)))
@@ -1133,7 +1113,7 @@ error and non-nil on success."
(defun tramp-adb-send-command (vec command &optional neveropen nooutput)
"Send the COMMAND to connection VEC."
- (if (string-match-p (tramp-compat-rx multibyte) command)
+ (if (string-match-p (rx multibyte) command)
;; Multibyte codepoints with four bytes are not supported at
;; least by toybox.
@@ -1157,25 +1137,31 @@ error and non-nil on success."
;; We can't use stty to disable echo of command. stty is said
;; to be added to toybox 0.7.6. busybox shall have it, but this
;; isn't used any longer for Android.
- (delete-matching-lines (tramp-compat-rx bol (literal command) eol))
+ (delete-matching-lines (rx bol (literal command) eol))
;; When the local machine is W32, there are still trailing ^M.
;; There must be a better solution by setting the correct coding
;; system, but this requires changes in core Tramp.
(goto-char (point-min))
- (while (re-search-forward (rx (+ "\r") eol) nil t)
+ (while (search-forward-regexp (rx (+ "\r") eol) nil t)
(replace-match "" nil nil)))))))
-(defun tramp-adb-send-command-and-check (vec command &optional exit-status)
+(defun tramp-adb-send-command-and-check
+ (vec command &optional exit-status command-augmented-p)
"Run COMMAND and check its exit status.
Sends `echo $?' along with the COMMAND for checking the exit
status. If COMMAND is nil, just sends `echo $?'. Returns nil if
the exit status is not equal 0, and t otherwise.
+If COMMAND-AUGMENTED-P, COMMAND is already configured to print exit
+status upon completion and need not be modified.
+
Optional argument EXIT-STATUS, if non-nil, triggers the return of
the exit status."
(tramp-adb-send-command
vec (if command
- (format "%s; echo tramp_exit_status $?" command)
+ (if command-augmented-p
+ command
+ (format "%s; echo tramp_exit_status $?" command))
"echo tramp_exit_status $?"))
(with-current-buffer (tramp-get-connection-buffer vec)
(unless (tramp-search-regexp (rx "tramp_exit_status " (+ digit)))
@@ -1206,12 +1192,12 @@ FMT and ARGS are passed to `error'."
(let ((inhibit-read-only t))
(goto-char (point-min))
;; ADB terminal sends "^H" sequences.
- (when (re-search-forward (rx "<" (+ "\b")) (line-end-position) t)
+ (when (search-forward-regexp (rx "<" (+ "\b")) (line-end-position) t)
(forward-line 1)
(delete-region (point-min) (point)))
;; Delete the prompt.
(goto-char (point-min))
- (when (re-search-forward prompt (line-end-position) t)
+ (when (search-forward-regexp prompt (line-end-position) t)
(forward-line 1)
(delete-region (point-min) (point)))
(when (tramp-search-regexp prompt)
@@ -1231,108 +1217,109 @@ connection if a previous connection has died for some reason."
(unless (tramp-connectable-p vec)
(throw 'non-essential 'non-essential))
- (let* ((buf (tramp-get-connection-buffer vec))
- (p (get-buffer-process buf))
- (host (tramp-file-name-host vec))
- (user (tramp-file-name-user vec))
- (device (tramp-adb-get-device vec)))
-
- ;; Maybe we know already that "su" is not supported. We cannot
- ;; use a connection property, because we have not checked yet
- ;; whether it is still the same device.
- (when (and user (not (tramp-get-file-property vec "/" "su-command-p" t)))
- (tramp-error vec 'file-error "Cannot switch to user `%s'" user))
-
- (unless (process-live-p p)
- (save-match-data
- (when (and p (processp p)) (delete-process p))
- (if (tramp-string-empty-or-nil-p device)
- (tramp-error vec 'file-error "Device %s not connected" host))
- (with-tramp-progress-reporter vec 3 "Opening adb shell connection"
- (let* ((coding-system-for-read 'utf-8-dos) ; Is this correct?
- (process-connection-type tramp-process-connection-type)
- (args (tramp-expand-args
- vec 'tramp-login-args ?d (or device "")))
- (p (let ((default-directory
- tramp-compat-temporary-file-directory))
- (apply #'start-process (tramp-get-connection-name vec) buf
- tramp-adb-program args)))
- (prompt (md5 (concat (prin1-to-string process-environment)
- (current-time-string)))))
- (tramp-message
- vec 6 "%s" (string-join (process-command p) " "))
- ;; Wait for initial prompt. On some devices, it needs an
- ;; initial RET, in order to get it.
- (sleep-for 0.1)
- (tramp-send-string vec tramp-rsh-end-of-line)
- (tramp-adb-wait-for-output p 30)
- (unless (process-live-p p)
- (tramp-error vec 'file-error "Terminated!"))
-
- ;; Set sentinel and query flag. Initialize variables.
- (set-process-sentinel p #'tramp-process-sentinel)
- (process-put p 'tramp-vector vec)
- (process-put p 'adjust-window-size-function #'ignore)
- (set-process-query-on-exit-flag p nil)
-
- ;; Set connection-local variables.
- (tramp-set-connection-local-variables vec)
-
- ;; Change prompt.
- (tramp-set-connection-property
- p "prompt" (tramp-compat-rx "///" (literal prompt) "#$"))
- (tramp-adb-send-command
- vec (format "PS1=\"///\"\"%s\"\"#$\"" prompt))
-
- ;; Disable line editing.
- (tramp-adb-send-command
- vec "set +o vi +o vi-esccomplete +o vi-tabcomplete +o emacs")
-
- ;; Dump option settings in the traces.
- (when (>= tramp-verbose 9)
- (tramp-adb-send-command vec "set -o"))
-
- ;; Check whether the properties have been changed. If
- ;; yes, this is a strong indication that we must expire all
- ;; connection properties. We start again.
- (tramp-message vec 5 "Checking system information")
- (tramp-adb-send-command
- vec
- (concat
- "echo \\\"`getprop ro.product.model` "
- "`getprop ro.product.version` "
- "`getprop ro.build.version.release`\\\""))
- (let ((old-getprop (tramp-get-connection-property vec "getprop"))
- (new-getprop
- (tramp-set-connection-property
- vec "getprop"
- (with-current-buffer (tramp-get-connection-buffer vec)
- ;; Read the expression.
- (goto-char (point-min))
- (read (current-buffer))))))
- (when (and (stringp old-getprop)
- (not (string-equal old-getprop new-getprop)))
- (tramp-message
- vec 3
- "Connection reset, because remote host changed from `%s' to `%s'"
- old-getprop new-getprop)
- (tramp-cleanup-connection vec t)
- (tramp-adb-maybe-open-connection vec)))
-
- ;; Change user if indicated.
- (when user
- (tramp-adb-send-command vec (format "su %s" user))
- (unless (tramp-adb-send-command-and-check vec nil)
- (delete-process p)
- ;; Do not flush, we need the nil value.
- (tramp-set-file-property vec "/" "su-command-p" nil)
- (tramp-error
- vec 'file-error "Cannot switch to user `%s'" user)))
-
- ;; Mark it as connected.
- (tramp-set-connection-property p "connected" t)))))))
+ (with-tramp-debug-message vec "Opening connection"
+ (let* ((buf (tramp-get-connection-buffer vec))
+ (p (get-buffer-process buf))
+ (host (tramp-file-name-host vec))
+ (user (tramp-file-name-user vec))
+ (device (tramp-adb-get-device vec)))
+
+ ;; Maybe we know already that "su" is not supported. We cannot
+ ;; use a connection property, because we have not checked yet
+ ;; whether it is still the same device.
+ (when (and user (not (tramp-get-file-property vec "/" "su-command-p" t)))
+ (tramp-error vec 'file-error "Cannot switch to user `%s'" user))
+
+ (unless (process-live-p p)
+ (save-match-data
+ (when (and p (processp p)) (delete-process p))
+ (if (tramp-string-empty-or-nil-p device)
+ (tramp-error vec 'file-error "Device %s not connected" host))
+ (with-tramp-progress-reporter vec 3 "Opening adb shell connection"
+ (let* ((coding-system-for-read 'utf-8-dos) ; Is this correct?
+ (process-connection-type tramp-process-connection-type)
+ (args (tramp-expand-args
+ vec 'tramp-login-args nil ?d (or device "")))
+ (p (let ((default-directory
+ tramp-compat-temporary-file-directory))
+ (apply
+ #'start-process (tramp-get-connection-name vec) buf
+ tramp-adb-program args)))
+ (prompt (md5 (concat (prin1-to-string process-environment)
+ (current-time-string)))))
+ ;; Wait for initial prompt. On some devices, it needs
+ ;; an initial RET, in order to get it.
+ (sleep-for 0.1)
+ (tramp-send-string vec tramp-rsh-end-of-line)
+ (tramp-adb-wait-for-output p 30)
+ (unless (process-live-p p)
+ (tramp-error vec 'file-error "Terminated!"))
+
+ ;; Set sentinel. Initialize variables.
+ (set-process-sentinel p #'tramp-process-sentinel)
+ (tramp-post-process-creation p vec)
+
+ ;; Set connection-local variables.
+ (tramp-set-connection-local-variables vec)
+
+ ;; Change prompt.
+ (tramp-set-connection-property
+ p "prompt" (rx "///" (literal prompt) "#$"))
+ (tramp-adb-send-command
+ vec (format "PS1=\"///\"\"%s\"\"#$\" PS2=''" prompt))
+
+ ;; Disable line editing.
+ (tramp-adb-send-command
+ vec "set +o vi +o vi-esccomplete +o vi-tabcomplete +o emacs")
+
+ ;; Dump option settings in the traces.
+ (when (>= tramp-verbose 9)
+ (tramp-adb-send-command vec "set -o"))
+
+ ;; Check whether the properties have been changed. If
+ ;; yes, this is a strong indication that we must expire
+ ;; all connection properties. We start again.
+ (tramp-message vec 5 "Checking system information")
+ (tramp-adb-send-command
+ vec
+ (concat
+ "echo \\\"`getprop ro.product.model` "
+ "`getprop ro.product.version` "
+ "`getprop ro.build.version.release`\\\""))
+ (let ((old-getprop (tramp-get-connection-property vec "getprop"))
+ (new-getprop
+ (tramp-set-connection-property
+ vec "getprop"
+ (with-current-buffer (tramp-get-connection-buffer vec)
+ ;; Read the expression.
+ (goto-char (point-min))
+ (read (current-buffer))))))
+ (when (and (stringp old-getprop)
+ (not (string-equal old-getprop new-getprop)))
+ (tramp-message
+ vec 3
+ (concat
+ "Connection reset, because remote host changed "
+ "from `%s' to `%s'")
+ old-getprop new-getprop)
+ (tramp-cleanup-connection vec t)
+ (tramp-adb-maybe-open-connection vec)))
+
+ ;; Change user if indicated.
+ (when user
+ (tramp-adb-send-command vec (format "su %s" user))
+ (unless (tramp-adb-send-command-and-check vec nil)
+ (delete-process p)
+ ;; Do not flush, we need the nil value.
+ (tramp-set-file-property vec "/" "su-command-p" nil)
+ (tramp-error
+ vec 'file-error "Cannot switch to user `%s'" user)))
+
+ ;; Mark it as connected.
+ (tramp-set-connection-property p "connected" t))))))))
;;; Default connection-local variables for Tramp.
+
(defconst tramp-adb-connection-local-default-shell-variables
'((shell-file-name . "/system/bin/sh")
(shell-command-switch . "-c"))
diff --git a/lisp/net/tramp-androidsu.el b/lisp/net/tramp-androidsu.el
new file mode 100644
index 00000000000..09bee323f5e
--- /dev/null
+++ b/lisp/net/tramp-androidsu.el
@@ -0,0 +1,561 @@
+;;; tramp-androidsu.el --- Tramp method for Android superuser shells -*- lexical-binding:t -*-
+
+;; Copyright (C) 2024 Free Software Foundation, Inc.
+
+;; Author: Po Lu
+;; Keywords: comm, processes
+;; Package: tramp
+
+;; This file is part of GNU Emacs.
+
+;; GNU Emacs is free software: you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+
+;; GNU Emacs is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>.
+
+;;; Commentary:
+
+;; `su' method implementation for Android.
+;;
+;; The `su' method struggles (as do other shell-based methods) with the
+;; crippled versions of many Unix utilities installed on Android,
+;; workarounds for which are implemented in the `adb' method. This
+;; method defines a shell-based method that is identical in function to
+;; and replaces if connecting to a local Android machine `su', but
+;; reuses such code from the `adb' method where applicable and also
+;; provides for certain mannerisms of popular Android `su'
+;; implementations.
+
+;;; Code:
+
+(require 'tramp)
+(require 'tramp-adb)
+(require 'tramp-sh)
+
+;;;###tramp-autoload
+(defconst tramp-androidsu-method "androidsu"
+ "When this method name is used, forward all calls to su.")
+
+;;;###tramp-autoload
+(defcustom tramp-androidsu-mount-global-namespace t
+ "When non-nil, browse files from within the global mount namespace.
+On systems that assign each application a unique view of the
+filesystem by executing them within individual mount namespaces
+and thus conceal each application's data directories from
+others, invoke `su' with the option `-mm' in order for the shell
+launched to run within the global mount namespace, so that Tramp
+may edit files belonging to any and all applications."
+ :group 'tramp
+ :version "30.1"
+ :type 'boolean)
+
+;;;###tramp-autoload
+(defcustom tramp-androidsu-remote-path '("/system/bin"
+ "/system/xbin")
+ "Directories in which to search for transfer programs and the like."
+ :group 'tramp
+ :version "30.1"
+ :type '(list string))
+
+(defvar tramp-androidsu-su-mm-supported 'unknown
+ "Whether `su -mm' is supported on this system.")
+
+;;;###tramp-autoload
+(defconst tramp-androidsu-local-shell-name "/system/bin/sh"
+ "Name of the local shell on Android.")
+
+;;;###tramp-autoload
+(defconst tramp-androidsu-local-tmp-directory "/data/local/tmp"
+ "Name of the local temporary directory on Android.")
+
+;;;###tramp-autoload
+(tramp--with-startup
+ (add-to-list 'tramp-methods
+ `(,tramp-androidsu-method
+ (tramp-login-program "su")
+ (tramp-login-args (("-") ("%u")))
+ (tramp-remote-shell ,tramp-androidsu-local-shell-name)
+ (tramp-remote-shell-login ("-l"))
+ (tramp-remote-shell-args ("-c"))
+ (tramp-tmpdir ,tramp-androidsu-local-tmp-directory)
+ (tramp-connection-timeout 10)
+ (tramp-shell-name ,tramp-androidsu-local-shell-name)))
+ (add-to-list 'tramp-default-user-alist
+ `(,tramp-androidsu-method nil ,tramp-root-id-string)))
+
+(defvar android-use-exec-loader) ; androidfns.c.
+
+(defun tramp-androidsu-maybe-open-connection (vec)
+ "Open a connection VEC if not already open.
+Mostly identical to `tramp-adb-maybe-open-connection', but also disables
+multibyte mode and waits for the shell prompt to appear."
+ ;; During completion, don't reopen a new connection.
+ (unless (tramp-connectable-p vec)
+ (throw 'non-essential 'non-essential))
+
+ (with-tramp-debug-message vec "Opening connection"
+ (let ((p (tramp-get-connection-process vec))
+ (process-name (tramp-get-connection-property vec "process-name"))
+ (process-environment (copy-sequence process-environment)))
+ ;; Open a new connection.
+ (condition-case err
+ (unless (process-live-p p)
+ (with-tramp-progress-reporter
+ vec 3
+ (if (tramp-string-empty-or-nil-p (tramp-file-name-user vec))
+ (format "Opening connection %s for %s using %s"
+ process-name
+ (tramp-file-name-host vec)
+ (tramp-file-name-method vec))
+ (format "Opening connection %s for %s@%s using %s"
+ process-name
+ (tramp-file-name-user vec)
+ (tramp-file-name-host vec)
+ (tramp-file-name-method vec)))
+ (let* ((coding-system-for-read 'utf-8-unix)
+ (process-connection-type tramp-process-connection-type)
+ ;; The executable loader cannot execute setuid
+ ;; binaries, such as su.
+ (android-use-exec-loader nil)
+ (p (start-process (tramp-get-connection-name vec)
+ (tramp-get-connection-buffer vec)
+ ;; Disregard
+ ;; `tramp-encoding-shell', as
+ ;; there's no guarantee that it's
+ ;; possible to execute it with
+ ;; `android-use-exec-loader' off.
+ tramp-androidsu-local-shell-name "-i"))
+ (user (tramp-file-name-user vec))
+ command)
+ ;; Set sentinel. Initialize variables.
+ (set-process-sentinel p #'tramp-process-sentinel)
+ (tramp-post-process-creation p vec)
+ ;; Replace `login-args' place holders.
+ (setq command (format "exec su - %s || exit" user))
+ ;; Attempt to execute the shell inside the global mount
+ ;; namespace if requested.
+ (when tramp-androidsu-mount-global-namespace
+ (progn
+ (when (eq tramp-androidsu-su-mm-supported 'unknown)
+ ;; Change the prompt in advance so that
+ ;; `tramp-adb-send-command-and-check' can call
+ ;; `tramp-search-regexp'.
+ (tramp-adb-send-command
+ vec (format "PS1=%s PS2=''"
+ (tramp-shell-quote-argument
+ tramp-end-of-output)))
+ (setq tramp-androidsu-su-mm-supported
+ ;; Detect support for `su -mm'.
+ (tramp-adb-send-command-and-check
+ vec "su -mm -c 'exit 24'" 24)))
+ (when tramp-androidsu-su-mm-supported
+ (tramp-set-connection-property
+ vec "remote-namespace" t)
+ (setq command (format "exec su -mm - %s || exit"
+ user)))))
+ ;; Send the command.
+ (tramp-message vec 3 "Sending command `%s'" command)
+ (tramp-adb-send-command vec command t t)
+ ;; Android su binaries contact a background service to
+ ;; obtain authentication; during this process, input
+ ;; received is discarded, so input cannot be
+ ;; guaranteed to reach the root shell until its prompt
+ ;; is displayed.
+ (with-current-buffer (process-buffer p)
+ (tramp-wait-for-regexp p tramp-connection-timeout
+ "#[[:space:]]*$"))
+ ;; Set connection-local variables.
+ (tramp-set-connection-local-variables vec)
+ ;; Change prompt.
+ (tramp-adb-send-command
+ vec (format "PS1=%s PS2=''"
+ (tramp-shell-quote-argument tramp-end-of-output)))
+ ;; Disable line editing.
+ (tramp-adb-send-command
+ vec "set +o vi +o vi-esccomplete +o vi-tabcomplete +o emacs")
+ ;; Disable Unicode, for otherwise Unicode filenames will
+ ;; not be decoded correctly.
+ (tramp-adb-send-command vec "set +U")
+ ;; Dump option settings in the traces.
+ (when (>= tramp-verbose 9)
+ (tramp-adb-send-command vec "set -o"))
+ ;; Disable echo expansion.
+ (tramp-adb-send-command
+ vec "stty -inlcr -onlcr -echo kill '^U' erase '^H'" t)
+ ;; Check whether the echo has really been disabled.
+ ;; Some implementations, like busybox, don't support
+ ;; disabling.
+ (tramp-adb-send-command vec "echo foo" t)
+ (with-current-buffer (process-buffer p)
+ (goto-char (point-min))
+ (when (looking-at-p "echo foo")
+ (tramp-set-connection-property p "remote-echo" t)
+ (tramp-message vec 5 "Remote echo still on. Ok.")
+ ;; Make sure backspaces and their echo are enabled
+ ;; and no line width magic interferes with them.
+ (tramp-adb-send-command
+ vec "stty icanon erase ^H cols 32767" t)))
+ ;; Mark it as connected.
+ (tramp-set-connection-property p "connected" t))))
+ ;; Cleanup, and propagate the signal.
+ ((error quit)
+ (tramp-cleanup-connection vec t)
+ (signal (car err) (cdr err)))))))
+
+(defun tramp-androidsu-generate-wrapper (function)
+ "Return connection wrapper function for FUNCTION.
+Return a function which temporarily substitutes local replacements for
+the `adb' method's connection management functions around a call to
+FUNCTION."
+ (lambda (&rest args)
+ (let ((tramp-adb-wait-for-output
+ (symbol-function #'tramp-adb-wait-for-output))
+ (tramp-adb-maybe-open-connection
+ (symbol-function #'tramp-adb-maybe-open-connection)))
+ (unwind-protect
+ (progn
+ ;; `tramp-adb-wait-for-output' addresses problems introduced
+ ;; by the adb utility itself, not Android utilities, so
+ ;; replace it with the regular Tramp function.
+ (fset 'tramp-adb-wait-for-output #'tramp-wait-for-output)
+ ;; Likewise, except some special treatment is necessary on
+ ;; account of flaws in Android's su implementation.
+ (fset 'tramp-adb-maybe-open-connection
+ #'tramp-androidsu-maybe-open-connection)
+ (apply function args))
+ ;; Restore the original definitions of the functions overridden
+ ;; above.
+ (fset 'tramp-adb-wait-for-output tramp-adb-wait-for-output)
+ (fset 'tramp-adb-maybe-open-connection
+ tramp-adb-maybe-open-connection)))))
+
+(defalias 'tramp-androidsu-handle-copy-file #'tramp-sh-handle-copy-file)
+
+(defalias 'tramp-androidsu-handle-delete-directory
+ (tramp-androidsu-generate-wrapper #'tramp-adb-handle-delete-directory))
+
+(defalias 'tramp-androidsu-handle-delete-file
+ (tramp-androidsu-generate-wrapper #'tramp-adb-handle-delete-file))
+
+(defalias 'tramp-androidsu-handle-directory-files-and-attributes
+ (tramp-androidsu-generate-wrapper
+ #'tramp-adb-handle-directory-files-and-attributes))
+
+(defalias 'tramp-androidsu-handle-exec-path
+ (tramp-androidsu-generate-wrapper #'tramp-adb-handle-exec-path))
+
+(defalias 'tramp-androidsu-handle-file-attributes
+ (tramp-androidsu-generate-wrapper #'tramp-adb-handle-file-attributes))
+
+(defalias 'tramp-androidsu-handle-file-executable-p
+ (tramp-androidsu-generate-wrapper #'tramp-adb-handle-file-executable-p))
+
+(defalias 'tramp-androidsu-handle-file-exists-p
+ (tramp-androidsu-generate-wrapper #'tramp-adb-handle-file-exists-p))
+
+(defalias 'tramp-androidsu-handle-file-local-copy
+ #'tramp-sh-handle-file-local-copy)
+
+(defalias 'tramp-androidsu-handle-file-name-all-completions
+ (tramp-androidsu-generate-wrapper
+ #'tramp-adb-handle-file-name-all-completions))
+
+(defalias 'tramp-androidsu-handle-file-readable-p
+ (tramp-androidsu-generate-wrapper #'tramp-adb-handle-file-readable-p))
+
+(defalias 'tramp-androidsu-handle-file-system-info
+ (tramp-androidsu-generate-wrapper #'tramp-adb-handle-file-system-info))
+
+(defalias 'tramp-androidsu-handle-file-writable-p
+ (tramp-androidsu-generate-wrapper #'tramp-adb-handle-file-writable-p))
+
+(defalias 'tramp-androidsu-handle-make-directory
+ (tramp-androidsu-generate-wrapper #'tramp-adb-handle-make-directory))
+
+(defun tramp-androidsu-handle-make-process (&rest args)
+ "Like `tramp-handle-make-process', but modified for Android."
+ (when args
+ (with-parsed-tramp-file-name (expand-file-name default-directory) nil
+ (let ((default-directory tramp-compat-temporary-file-directory)
+ (name (plist-get args :name))
+ (buffer (plist-get args :buffer))
+ (command (plist-get args :command))
+ (coding (plist-get args :coding))
+ (noquery (plist-get args :noquery))
+ (connection-type
+ (or (plist-get args :connection-type) process-connection-type))
+ (filter (plist-get args :filter))
+ (sentinel (plist-get args :sentinel))
+ (stderr (plist-get args :stderr)))
+ (unless (stringp name)
+ (signal 'wrong-type-argument (list #'stringp name)))
+ (unless (or (bufferp buffer) (string-or-null-p buffer))
+ (signal 'wrong-type-argument (list #'bufferp buffer)))
+ (unless (consp command)
+ (signal 'wrong-type-argument (list #'consp command)))
+ (unless (or (null coding)
+ (and (symbolp coding) (memq coding coding-system-list))
+ (and (consp coding)
+ (memq (car coding) coding-system-list)
+ (memq (cdr coding) coding-system-list)))
+ (signal 'wrong-type-argument (list #'symbolp coding)))
+ (when (eq connection-type t)
+ (setq connection-type 'pty))
+ (unless (or (and (consp connection-type)
+ (memq (car connection-type) '(nil pipe pty))
+ (memq (cdr connection-type) '(nil pipe pty)))
+ (memq connection-type '(nil pipe pty)))
+ (signal 'wrong-type-argument (list #'symbolp connection-type)))
+ (unless (or (null filter) (eq filter t) (functionp filter))
+ (signal 'wrong-type-argument (list #'functionp filter)))
+ (unless (or (null sentinel) (functionp sentinel))
+ (signal 'wrong-type-argument (list #'functionp sentinel)))
+ (unless (or (null stderr) (bufferp stderr))
+ (signal 'wrong-type-argument (list #'bufferp stderr)))
+ (let* ((buffer
+ (if buffer
+ (get-buffer-create buffer)
+ ;; BUFFER can be nil. We use a temporary buffer.
+ (generate-new-buffer tramp-temp-buffer-name)))
+ (orig-command command)
+ (env (mapcar
+ (lambda (elt)
+ (when (tramp-compat-string-search "=" elt) elt))
+ tramp-remote-process-environment))
+ ;; We use as environment the difference to toplevel
+ ;; `process-environment'.
+ (env (dolist (elt process-environment env)
+ (when
+ (and
+ (tramp-compat-string-search "=" elt)
+ (not
+ (member
+ elt (default-toplevel-value 'process-environment))))
+ (setq env (cons elt env)))))
+ ;; Add remote path if exists.
+ (env (let ((remote-path
+ (string-join (tramp-get-remote-path v) ":")))
+ (setenv-internal env "PATH" remote-path 'keep)))
+ (env (setenv-internal
+ env "INSIDE_EMACS" (tramp-inside-emacs) 'keep))
+ (env (mapcar #'tramp-shell-quote-argument (delq nil env)))
+ ;; Quote command.
+ (command (mapconcat #'tramp-shell-quote-argument command " "))
+ ;; Set cwd and environment variables.
+ (command
+ (append
+ `("cd" ,(tramp-shell-quote-argument localname) "&&" "(" "env")
+ env `(,command ")")))
+ ;; Add remote shell if needed.
+ (command
+ (if (consp (tramp-get-method-parameter v 'tramp-direct-async))
+ (append
+ (tramp-get-method-parameter v 'tramp-direct-async)
+ `(,(string-join command " ")))
+ command))
+ p)
+ ;; Generate a command to start the process using `su' with
+ ;; suitable options for specifying the mount namespace and
+ ;; suchlike.
+ (setq
+ p (make-process
+ :name name :buffer buffer
+ :command (if (tramp-get-connection-property v "remote-namespace")
+ (append (list "su" "-mm" "-" user "-c") command)
+ (append (list "su" "-" user "-c") command))
+ :coding coding :noquery noquery :connection-type connection-type
+ :sentinel sentinel :stderr stderr))
+ ;; Set filter. Prior Emacs 29.1, it doesn't work reliably
+ ;; to provide it as `make-process' argument when filter is
+ ;; t. See Bug#51177.
+ (when filter
+ (set-process-filter p filter))
+ (tramp-post-process-creation p v)
+ ;; Query flag is overwritten in `tramp-post-process-creation',
+ ;; so we reset it.
+ (set-process-query-on-exit-flag p (null noquery))
+ ;; This is needed for ssh or PuTTY based processes, and
+ ;; only if the respective options are set. Perhaps, the
+ ;; setting could be more fine-grained.
+ ;; (process-put p 'tramp-shared-socket t)
+ (process-put p 'remote-command orig-command)
+ (tramp-set-connection-property p "remote-command" orig-command)
+ (when (bufferp stderr)
+ (tramp-taint-remote-process-buffer stderr))
+ p)))))
+
+(defalias 'tramp-androidsu-handle-make-symbolic-link
+ #'tramp-sh-handle-make-symbolic-link)
+
+(defalias 'tramp-androidsu-handle-process-file
+ (tramp-androidsu-generate-wrapper #'tramp-adb-handle-process-file))
+
+(defalias 'tramp-androidsu-handle-rename-file #'tramp-sh-handle-rename-file)
+
+(defalias 'tramp-androidsu-handle-set-file-modes
+ (tramp-androidsu-generate-wrapper #'tramp-adb-handle-set-file-modes))
+
+(defalias 'tramp-androidsu-handle-set-file-times
+ (tramp-androidsu-generate-wrapper #'tramp-adb-handle-set-file-times))
+
+(defalias 'tramp-androidsu-handle-get-remote-gid
+ (tramp-androidsu-generate-wrapper #'tramp-adb-handle-get-remote-gid))
+
+(defalias 'tramp-androidsu-handle-get-remote-groups
+ (tramp-androidsu-generate-wrapper #'tramp-adb-handle-get-remote-groups))
+
+(defalias 'tramp-androidsu-handle-get-remote-uid
+ (tramp-androidsu-generate-wrapper #'tramp-adb-handle-get-remote-uid))
+
+(defalias 'tramp-androidsu-handle-write-region #'tramp-sh-handle-write-region)
+
+;;;###tramp-autoload
+(defconst tramp-androidsu-file-name-handler-alist
+ '(;; `abbreviate-file-name' performed by default handler.
+ (access-file . tramp-handle-access-file)
+ (add-name-to-file . tramp-handle-add-name-to-file)
+ ;; `byte-compiler-base-file-name' performed by default handler.
+ (copy-directory . tramp-handle-copy-directory)
+ (copy-file . tramp-androidsu-handle-copy-file)
+ (delete-directory . tramp-androidsu-handle-delete-directory)
+ (delete-file . tramp-androidsu-handle-delete-file)
+ ;; `diff-latest-backup-file' performed by default handler.
+ (directory-file-name . tramp-handle-directory-file-name)
+ (directory-files . tramp-handle-directory-files)
+ (directory-files-and-attributes
+ . tramp-androidsu-handle-directory-files-and-attributes)
+ (dired-compress-file . ignore)
+ (dired-uncache . tramp-handle-dired-uncache)
+ (exec-path . tramp-androidsu-handle-exec-path)
+ (expand-file-name . tramp-handle-expand-file-name)
+ (file-accessible-directory-p . tramp-handle-file-accessible-directory-p)
+ (file-acl . ignore)
+ (file-attributes . tramp-androidsu-handle-file-attributes)
+ (file-directory-p . tramp-handle-file-directory-p)
+ (file-equal-p . tramp-handle-file-equal-p)
+ (file-executable-p . tramp-androidsu-handle-file-executable-p)
+ (file-exists-p . tramp-androidsu-handle-file-exists-p)
+ (file-group-gid . tramp-handle-file-group-gid)
+ (file-in-directory-p . tramp-handle-file-in-directory-p)
+ (file-local-copy . tramp-androidsu-handle-file-local-copy)
+ (file-locked-p . tramp-handle-file-locked-p)
+ (file-modes . tramp-handle-file-modes)
+ (file-name-all-completions
+ . tramp-androidsu-handle-file-name-all-completions)
+ (file-name-as-directory . tramp-handle-file-name-as-directory)
+ (file-name-case-insensitive-p . tramp-handle-file-name-case-insensitive-p)
+ (file-name-completion . tramp-handle-file-name-completion)
+ (file-name-directory . tramp-handle-file-name-directory)
+ (file-name-nondirectory . tramp-handle-file-name-nondirectory)
+ ;; `file-name-sans-versions' performed by default handler.
+ (file-newer-than-file-p . tramp-handle-file-newer-than-file-p)
+ (file-notify-add-watch . tramp-handle-file-notify-add-watch)
+ (file-notify-rm-watch . tramp-handle-file-notify-rm-watch)
+ (file-notify-valid-p . tramp-handle-file-notify-valid-p)
+ (file-ownership-preserved-p . ignore)
+ (file-readable-p . tramp-androidsu-handle-file-readable-p)
+ (file-regular-p . tramp-handle-file-regular-p)
+ (file-remote-p . tramp-handle-file-remote-p)
+ (file-selinux-context . tramp-handle-file-selinux-context)
+ (file-symlink-p . tramp-handle-file-symlink-p)
+ (file-system-info . tramp-androidsu-handle-file-system-info)
+ (file-truename . tramp-handle-file-truename)
+ (file-user-uid . tramp-handle-file-user-uid)
+ (file-writable-p . tramp-androidsu-handle-file-writable-p)
+ (find-backup-file-name . tramp-handle-find-backup-file-name)
+ ;; `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)
+ (make-directory . tramp-androidsu-handle-make-directory)
+ (make-directory-internal . ignore)
+ (make-lock-file-name . tramp-handle-make-lock-file-name)
+ (make-nearby-temp-file . tramp-handle-make-nearby-temp-file)
+ (make-process . tramp-androidsu-handle-make-process)
+ (make-symbolic-link . tramp-androidsu-handle-make-symbolic-link)
+ (memory-info . tramp-handle-memory-info)
+ (process-attributes . tramp-handle-process-attributes)
+ (process-file . tramp-androidsu-handle-process-file)
+ (rename-file . tramp-androidsu-handle-rename-file)
+ (set-file-acl . ignore)
+ (set-file-modes . tramp-androidsu-handle-set-file-modes)
+ (set-file-selinux-context . ignore)
+ (set-file-times . tramp-androidsu-handle-set-file-times)
+ (set-visited-file-modtime . tramp-handle-set-visited-file-modtime)
+ (shell-command . tramp-handle-shell-command)
+ (start-file-process . tramp-handle-start-file-process)
+ (substitute-in-file-name . tramp-handle-substitute-in-file-name)
+ (temporary-file-directory . tramp-handle-temporary-file-directory)
+ (tramp-get-home-directory . ignore)
+ (tramp-get-remote-gid . tramp-androidsu-handle-get-remote-gid)
+ (tramp-get-remote-groups . tramp-androidsu-handle-get-remote-groups)
+ (tramp-get-remote-uid . tramp-androidsu-handle-get-remote-uid)
+ (tramp-set-file-uid-gid . ignore)
+ (unhandled-file-name-directory . ignore)
+ (unlock-file . tramp-handle-unlock-file)
+ (vc-registered . ignore)
+ (verify-visited-file-modtime . tramp-handle-verify-visited-file-modtime)
+ (write-region . tramp-androidsu-handle-write-region))
+ "Alist of Tramp handler functions for superuser sessions on Android.")
+
+;; It must be a `defsubst' in order to push the whole code into
+;; tramp-loaddefs.el. Otherwise, there would be recursive autoloading.
+;;;###tramp-autoload
+(defsubst tramp-androidsu-file-name-p (vec-or-filename)
+ "Check whether VEC-OR-FILENAME is for the `androidsu' method."
+ (when-let* ((vec (tramp-ensure-dissected-file-name vec-or-filename)))
+ (equal (tramp-file-name-method vec) tramp-androidsu-method)))
+
+;;;###tramp-autoload
+(defun tramp-androidsu-file-name-handler (operation &rest args)
+ "Invoke the `androidsu' handler for OPERATION.
+First arg specifies the OPERATION, second arg is a list of
+arguments to pass to the OPERATION."
+ (if-let ((fn (assoc operation tramp-androidsu-file-name-handler-alist)))
+ (prog1 (save-match-data (apply (cdr fn) args))
+ (setq tramp-debug-message-fnh-function (cdr fn)))
+ (prog1 (tramp-run-real-handler operation args)
+ (setq tramp-debug-message-fnh-function operation))))
+
+;;;###tramp-autoload
+(tramp--with-startup
+ (tramp-register-foreign-file-name-handler
+ #'tramp-androidsu-file-name-p #'tramp-androidsu-file-name-handler))
+
+;;; Default connection-local variables for Tramp.
+
+(defconst tramp-androidsu-connection-local-default-variables
+ `((tramp-remote-path . ,tramp-androidsu-remote-path))
+ "Default connection-local variables for remote androidsu connections.")
+
+(connection-local-set-profile-variables
+ 'tramp-androidsu-connection-local-default-profile
+ tramp-androidsu-connection-local-default-variables)
+
+(connection-local-set-profiles
+ `(:application tramp :protocol ,tramp-androidsu-method)
+ 'tramp-androidsu-connection-local-default-profile)
+
+(with-eval-after-load 'shell
+ (connection-local-set-profiles
+ `(:application tramp :protocol ,tramp-androidsu-method)
+ 'tramp-adb-connection-local-default-shell-profile
+ 'tramp-adb-connection-local-default-ps-profile))
+
+(add-hook 'tramp-unload-hook
+ (lambda ()
+ (unload-feature 'tramp-androidsu 'force)))
+
+(provide 'tramp-androidsu)
+;;; tramp-androidsu.el ends here
diff --git a/lisp/net/tramp-archive.el b/lisp/net/tramp-archive.el
index 44ca0e26333..59c4223794c 100644
--- a/lisp/net/tramp-archive.el
+++ b/lisp/net/tramp-archive.el
@@ -110,12 +110,7 @@
;;; Code:
(eval-when-compile (require 'cl-lib))
-;; Sometimes, compilation fails with "Variable binding depth exceeds
-;; max-specpdl-size". Shall be fixed in Emacs 27.
-(with-no-warnings ;; max-specpdl-size
- (eval-and-compile
- (let ((max-specpdl-size (* 2 max-specpdl-size)))
- (require 'tramp-gvfs))))
+(require 'tramp-gvfs)
(autoload 'dired-uncache "dired")
(autoload 'url-tramp-convert-url-to-tramp "url-tramp")
@@ -183,20 +178,9 @@ It must be supported by libarchive(3).")
;; The definition of `tramp-archive-file-name-regexp' contains calls
;; to `regexp-opt', which cannot be autoloaded while loading
;; loaddefs.el. So we use a macro, which is evaluated only when needed.
-;; Emacs 26 and earlier cannot use the autoload form
-;; `tramp-compat-rx'. So we refrain from using `rx'.
;;;###autoload
(progn (defmacro tramp-archive-autoload-file-name-regexp ()
"Regular expression matching archive file names."
- (if (<= emacs-major-version 26)
- '(concat
- "\\`" "\\(" ".+" "\\."
- ;; Default suffixes ...
- (regexp-opt tramp-archive-suffixes)
- ;; ... with compression.
- "\\(?:" "\\." (regexp-opt tramp-archive-compression-suffixes) "\\)*"
- "\\)" ;; \1
- "\\(" "/" ".*" "\\)" "\\'") ;; \2
`(rx
bos
;; This group is used in `tramp-archive-file-name-archive'.
@@ -208,13 +192,10 @@ It must be supported by libarchive(3).")
(? "." (| ,@tramp-archive-compression-suffixes)))
;; This group is used in `tramp-archive-file-name-localname'.
(group "/" (* nonl))
- eos))))
+ eos)))
(put #'tramp-archive-autoload-file-name-regexp 'tramp-autoload t)
-;; In older Emacs (prior 27.1), `tramp-archive-autoload-file-name-regexp'
-;; is not autoloaded. So we cannot expect it to be known in
-;; tramp-loaddefs.el. But it exists, when tramp-archive.el is loaded.
;; We must wrap it into `eval-when-compile'. Otherwise, there could
;; be an "Eager macro-expansion failure" when unloading/reloading Tramp.
;;;###tramp-autoload
@@ -222,11 +203,6 @@ It must be supported by libarchive(3).")
(eval-when-compile (ignore-errors (tramp-archive-autoload-file-name-regexp)))
"Regular expression matching archive file names.")
-;; The value above is nil for Emacs 26. Set it now.
-(if (<= emacs-major-version 26)
- (setq tramp-archive-file-name-regexp
- (ignore-errors (tramp-archive-autoload-file-name-regexp))))
-
;;;###tramp-autoload
(defconst tramp-archive-method "archive"
"Method name for archives in GVFS.")
@@ -266,6 +242,7 @@ It must be supported by libarchive(3).")
(file-equal-p . tramp-handle-file-equal-p)
(file-executable-p . tramp-archive-handle-file-executable-p)
(file-exists-p . tramp-archive-handle-file-exists-p)
+ (file-group-gid . tramp-archive-handle-file-group-gid)
(file-in-directory-p . tramp-handle-file-in-directory-p)
(file-local-copy . tramp-archive-handle-file-local-copy)
(file-locked-p . ignore)
@@ -286,9 +263,10 @@ It must be supported by libarchive(3).")
(file-regular-p . tramp-handle-file-regular-p)
;; `file-remote-p' performed by default handler.
(file-selinux-context . tramp-handle-file-selinux-context)
- (file-symlink-p . tramp-handle-file-symlink-p)
+ (file-symlink-p . tramp-archive-handle-file-symlink-p)
(file-system-info . tramp-archive-handle-file-system-info)
(file-truename . tramp-archive-handle-file-truename)
+ (file-user-uid . tramp-archive-handle-file-user-uid)
(file-writable-p . ignore)
(find-backup-file-name . ignore)
;; `get-file-buffer' performed by default handler.
@@ -299,7 +277,7 @@ It must be supported by libarchive(3).")
(lock-file . ignore)
(make-auto-save-file-name . ignore)
(make-directory . tramp-archive-handle-not-implemented)
- (make-directory-internal . tramp-archive-handle-not-implemented)
+ (make-directory-internal . ignore)
(make-lock-file-name . ignore)
(make-nearby-temp-file . tramp-handle-make-nearby-temp-file)
(make-process . ignore)
@@ -360,13 +338,9 @@ arguments to pass to the OPERATION."
(tramp-register-file-name-handlers)
(tramp-archive-run-real-handler operation args))
- (with-no-warnings ;; max-specpdl-size
(let* ((filename (apply #'tramp-archive-file-name-for-operation
operation args))
- (archive (tramp-archive-file-name-archive filename))
- ;; Sometimes, it fails with "Variable binding depth exceeds
- ;; max-specpdl-size". Shall be fixed in Emacs 27.
- (max-specpdl-size (* 2 max-specpdl-size)))
+ (archive (tramp-archive-file-name-archive filename)))
;; `filename' could be a quoted file name. Or the file
;; archive could be a directory, see Bug#30293.
@@ -394,7 +368,7 @@ arguments to pass to the OPERATION."
(setq args (cons operation args)))
(if fn
(save-match-data (apply (cdr fn) args))
- (tramp-archive-run-real-handler operation args))))))))
+ (tramp-archive-run-real-handler operation args)))))))
;;;###autoload
(progn (defun tramp-archive-autoload-file-name-handler (operation &rest args)
@@ -413,6 +387,8 @@ arguments to pass to the OPERATION."
;;;###autoload
(progn (defun tramp-register-archive-autoload-file-name-handler ()
"Add archive file name handler to `file-name-handler-alist'."
+ ;; Do not use read syntax #' for `tramp-archive-file-name-handler', it
+ ;; isn't autoloaded.
(when (and tramp-archive-enabled
(not
(rassq 'tramp-archive-file-name-handler file-name-handler-alist)))
@@ -432,10 +408,6 @@ arguments to pass to the OPERATION."
(remove-hook
'after-init-hook #'tramp-register-archive-autoload-file-name-handler))))
-;; In older Emacsen (prior 27.1), the autoload above does not exist.
-;; So we call it again; it doesn't hurt.
-(tramp-register-archive-autoload-file-name-handler)
-
;; Mark `operations' the handler is responsible for.
(put #'tramp-archive-file-name-handler 'operations
(mapcar #'car tramp-archive-file-name-handler-alist))
@@ -458,7 +430,7 @@ arguments to pass to the OPERATION."
"Return t if NAME is a string with archive file name syntax."
(and (stringp name)
;; `tramp-archive-file-name-regexp' does not suppress quoted file names.
- (not (tramp-compat-file-name-quoted-p name t))
+ (not (file-name-quoted-p name t))
;; We cannot use `string-match-p', the matches are used.
(string-match tramp-archive-file-name-regexp name)
t))
@@ -473,7 +445,7 @@ arguments to pass to the OPERATION."
(and (tramp-archive-file-name-p name)
(match-string 2 name)))
-(defvar tramp-archive-hash (make-hash-table :test 'equal)
+(defvar tramp-archive-hash (make-hash-table :test #'equal)
"Hash table for archive local copies.
The hash key is the archive name. The value is a cons of the
used `tramp-file-name' structure for tramp-gvfs, and the file
@@ -511,7 +483,6 @@ name is kept in slot `hop'"
;; http://...
((and url-handler-mode
- tramp-compat-use-url-tramp-p
(string-match-p url-handler-regexp archive)
(string-match-p
"https?" (url-type (url-generic-parse-url archive))))
@@ -676,13 +647,20 @@ offered."
"Like `file-exists-p' for file archives."
(file-exists-p (tramp-archive-gvfs-file-name filename)))
+(defun tramp-archive-handle-file-group-gid ()
+ "Like `file-group-gid' for file archives."
+ (with-parsed-tramp-archive-file-name default-directory nil
+ (let ((default-directory (file-name-directory archive)))
+ ;; `file-group-gid' exists since Emacs 30.1.
+ (tramp-compat-funcall 'file-group-gid))))
+
(defun tramp-archive-handle-file-local-copy (filename)
"Like `file-local-copy' for file archives."
(file-local-copy (tramp-archive-gvfs-file-name filename)))
(defun tramp-archive-handle-file-name-all-completions (filename directory)
"Like `file-name-all-completions' for file archives."
- (tramp-compat-ignore-error file-missing
+ (ignore-error file-missing
(file-name-all-completions
filename (tramp-archive-gvfs-file-name directory))))
@@ -690,6 +668,10 @@ offered."
"Like `file-readable-p' for file archives."
(file-readable-p (tramp-archive-gvfs-file-name filename)))
+(defun tramp-archive-handle-file-symlink-p (filename)
+ "Like `file-symlink-p' for file archives."
+ (file-symlink-p (tramp-archive-gvfs-file-name filename)))
+
(defun tramp-archive-handle-file-system-info (filename)
"Like `file-system-info' for file archives."
(with-parsed-tramp-archive-file-name filename nil
@@ -703,6 +685,13 @@ offered."
(setq local (expand-file-name local (file-name-directory localname))))
(concat (file-truename archive) local))))
+(defun tramp-archive-handle-file-user-uid ()
+ "Like `file-user-uid' for file archives."
+ (with-parsed-tramp-archive-file-name default-directory nil
+ (let ((default-directory (file-name-directory archive)))
+ ;; `file-user-uid' exists since Emacs 30.1.
+ (tramp-compat-funcall 'file-user-uid))))
+
(defun tramp-archive-handle-insert-directory
(filename switches &optional wildcard full-directory-p)
"Like `insert-directory' for file archives."
diff --git a/lisp/net/tramp-cache.el b/lisp/net/tramp-cache.el
index fe6aeca6eb0..225a26ad1cd 100644
--- a/lisp/net/tramp-cache.el
+++ b/lisp/net/tramp-cache.el
@@ -28,8 +28,8 @@
;; An implementation of information caching for remote files.
;; Each connection, identified by a `tramp-file-name' structure or by
-;; a process, has a unique cache. We distinguish 6 kind of caches,
-;; depending on the key:
+;; a process, has a unique cache. We distinguish several kinds of
+;; caches, depending on the key:
;;
;; - localname is nil. These are reusable properties. Examples:
;; "remote-shell" identifies the POSIX shell to be called on the
@@ -50,11 +50,14 @@
;; definitions already sent to the remote shell, "last-cmd-time" is
;; the timestamp a command has been sent to the remote process.
;;
-;; - The key is nil. These are temporary properties related to the
-;; local machine. Examples: "parse-passwd" and "parse-group" keep
-;; the results of parsing "/etc/passwd" and "/etc/group",
+;; - The key is `tramp-null-hop' or nil. These are temporary
+;; properties related to the local machine. If the key is nil, it
+;; is silently converted into `tramp-null-hop'.
+;; Examples: "parse-passwd" and "parse-group" keep the results of
+;; parsing "/etc/passwd" and "/etc/group",
;; "{uid,gid}-{integer,string}" are the local uid and gid, and
-;; "locale" is the used shell locale.
+;; "locale" is the used shell locale. "user-host-completions" keeps
+;; the reachable hosts for the commands in tramp-container.el.
;;
;; - The key is `tramp-cache-version'. It keeps the Tramp version the
;; cache data was produced with. If the cache is read by another
@@ -80,7 +83,6 @@
;;; Code:
(require 'tramp-compat)
-(require 'tramp-loaddefs)
(require 'time-stamp)
;;; -- Cache --
@@ -125,6 +127,7 @@ details see the info pages."
If it doesn't exist yet, it is created and initialized with
matching entries of `tramp-connection-properties'.
If KEY is `tramp-cache-undefined', don't create anything, and return nil."
+ (declare (tramp-suppress-trace t))
(unless (eq key tramp-cache-undefined)
(or (gethash key tramp-cache-data)
(let ((hash
@@ -141,7 +144,6 @@ If KEY is `tramp-cache-undefined', don't create anything, and return nil."
(defun tramp-get-file-property (key file property &optional default)
"Get the PROPERTY of FILE from the cache context of KEY.
Return DEFAULT if not set."
- ;; Unify localname. Remove hop from `tramp-file-name' structure.
(setq key (tramp-file-name-unify key file))
(if (eq key tramp-cache-undefined) default
(let* ((hash (tramp-get-hash-table key))
@@ -188,7 +190,6 @@ Return DEFAULT if not set."
(defun tramp-set-file-property (key file property value)
"Set the PROPERTY of FILE to VALUE, in the cache context of KEY.
Return VALUE."
- ;; Unify localname. Remove hop from `tramp-file-name' structure.
(setq key (tramp-file-name-unify key file))
(if (eq key tramp-cache-undefined) value
(let ((hash (tramp-get-hash-table key)))
@@ -221,7 +222,6 @@ Return VALUE."
;;;###tramp-autoload
(defun tramp-flush-file-property (key file property)
"Remove PROPERTY of FILE in the cache context of KEY."
- ;; Unify localname. Remove hop from `tramp-file-name' structure.
(setq key (tramp-file-name-unify key file))
(unless (eq key tramp-cache-undefined)
(remhash property (tramp-get-hash-table key))
@@ -236,7 +236,6 @@ Return VALUE."
;; `file-name-directory' can return nil, for example for "~".
(when-let ((file (file-name-directory file))
(file (directory-file-name file)))
- ;; Unify localname. Remove hop from `tramp-file-name' structure.
(setq key (tramp-file-name-unify key file))
(unless (eq key tramp-cache-undefined)
(dolist (property (hash-table-keys (tramp-get-hash-table key)))
@@ -251,7 +250,6 @@ Return VALUE."
(defun tramp-flush-file-properties (key file)
"Remove all properties of FILE in the cache context of KEY."
(let ((truename (tramp-get-file-property key file "file-truename")))
- ;; Unify localname. Remove hop from `tramp-file-name' structure.
(setq key (tramp-file-name-unify key file))
(unless (eq key tramp-cache-undefined)
(tramp-message key 8 "%s" (tramp-file-name-localname key))
@@ -267,8 +265,7 @@ Return VALUE."
(defun tramp-flush-directory-properties (key directory)
"Remove all properties of DIRECTORY in the cache context of KEY.
Remove also properties of all files in subdirectories."
- (let* ((directory
- (directory-file-name (tramp-compat-file-name-unquote directory)))
+ (let* ((directory (directory-file-name (file-name-unquote directory)))
(truename (tramp-get-file-property key directory "file-truename")))
(tramp-message key 8 "%s" directory)
(dolist (key (hash-table-keys tramp-cache-data))
@@ -336,17 +333,15 @@ FILE must be a local file name on a connection identified via KEY."
"Save PROPERTY, run BODY, reset PROPERTY.
Preserve timestamps."
(declare (indent 3) (debug t))
- `(progn
- ;; Unify localname. Remove hop from `tramp-file-name' structure.
- (setf ,key (tramp-file-name-unify ,key ,file))
- (let* ((hash (tramp-get-hash-table ,key))
- (cached (and (hash-table-p hash) (gethash ,property hash))))
- (unwind-protect (progn ,@body)
- ;; Reset PROPERTY. Recompute hash, it could have been flushed.
- (setq hash (tramp-get-hash-table ,key))
- (if (consp cached)
- (puthash ,property cached hash)
- (remhash ,property hash))))))
+ `(let* ((key (tramp-file-name-unify ,key ,file))
+ (hash (tramp-get-hash-table key))
+ (cached (and (hash-table-p hash) (gethash ,property hash))))
+ (unwind-protect (progn ,@body)
+ ;; Reset PROPERTY. Recompute hash, it could have been flushed.
+ (setq hash (tramp-get-hash-table key))
+ (if (consp cached)
+ (puthash ,property cached hash)
+ (remhash ,property hash)))))
;;;###tramp-autoload
(defmacro with-tramp-saved-file-properties (key file properties &rest body)
@@ -354,22 +349,20 @@ Preserve timestamps."
PROPERTIES is a list of file properties (strings).
Preserve timestamps."
(declare (indent 3) (debug t))
- `(progn
- ;; Unify localname. Remove hop from `tramp-file-name' structure.
- (setf ,key (tramp-file-name-unify ,key ,file))
- (let* ((hash (tramp-get-hash-table ,key))
- (values
- (and (hash-table-p hash)
- (mapcar
- (lambda (property) (cons property (gethash property hash)))
- ,properties))))
- (unwind-protect (progn ,@body)
- ;; Reset PROPERTIES. Recompute hash, it could have been flushed.
- (setq hash (tramp-get-hash-table ,key))
- (dolist (value values)
- (if (consp (cdr value))
- (puthash (car value) (cdr value) hash)
- (remhash (car value) hash)))))))
+ `(let* ((key (tramp-file-name-unify ,key ,file))
+ (hash (tramp-get-hash-table key))
+ (values
+ (and (hash-table-p hash)
+ (mapcar
+ (lambda (property) (cons property (gethash property hash)))
+ ,properties))))
+ (unwind-protect (progn ,@body)
+ ;; Reset PROPERTIES. Recompute hash, it could have been flushed.
+ (setq hash (tramp-get-hash-table key))
+ (dolist (value values)
+ (if (consp (cdr value))
+ (puthash (car value) (cdr value) hash)
+ (remhash (car value) hash))))))
;;; -- Properties --
@@ -471,42 +464,41 @@ used to cache connection properties of the local machine."
(defmacro with-tramp-saved-connection-property (key property &rest body)
"Save PROPERTY, run BODY, reset PROPERTY."
(declare (indent 2) (debug t))
- `(progn
- (setf ,key (tramp-file-name-unify ,key))
- (let* ((hash (tramp-get-hash-table ,key))
- (cached (and (hash-table-p hash)
- (gethash ,property hash tramp-cache-undefined))))
- (unwind-protect (progn ,@body)
- ;; Reset PROPERTY. Recompute hash, it could have been flushed.
- (setq hash (tramp-get-hash-table ,key))
- (if (not (eq cached tramp-cache-undefined))
- (puthash ,property cached hash)
- (remhash ,property hash))))))
+ `(let* ((key (tramp-file-name-unify ,key))
+ (hash (tramp-get-hash-table key))
+ (cached (and (hash-table-p hash)
+ (gethash ,property hash tramp-cache-undefined))))
+ (unwind-protect (progn ,@body)
+ ;; Reset PROPERTY. Recompute hash, it could have been flushed.
+ (setq hash (tramp-get-hash-table key))
+ (if (not (eq cached tramp-cache-undefined))
+ (puthash ,property cached hash)
+ (remhash ,property hash)))))
;;;###tramp-autoload
(defmacro with-tramp-saved-connection-properties (key properties &rest body)
"Save PROPERTIES, run BODY, reset PROPERTIES.
PROPERTIES is a list of file properties (strings)."
(declare (indent 2) (debug t))
- `(progn
- (setf ,key (tramp-file-name-unify ,key))
- (let* ((hash (tramp-get-hash-table ,key))
- (values
- (mapcar
- (lambda (property)
- (cons property (gethash property hash tramp-cache-undefined)))
- ,properties)))
- (unwind-protect (progn ,@body)
+ `(let* ((key (tramp-file-name-unify ,key))
+ (hash (tramp-get-hash-table key))
+ (values
+ (mapcar
+ (lambda (property)
+ (cons property (gethash property hash tramp-cache-undefined)))
+ ,properties)))
+ (unwind-protect (progn ,@body)
;; Reset PROPERTIES. Recompute hash, it could have been flushed.
- (setq hash (tramp-get-hash-table ,key))
+ (setq hash (tramp-get-hash-table key))
(dolist (value values)
(if (not (eq (cdr value) tramp-cache-undefined))
(puthash (car value) (cdr value) hash)
- (remhash (car value) hash)))))))
+ (remhash (car value) hash))))))
;;;###tramp-autoload
(defun tramp-cache-print (table)
"Print hash table TABLE."
+ ;; (declare (tramp-suppress-trace t))
(when (hash-table-p table)
(let (result)
(maphash
@@ -539,6 +531,11 @@ PROPERTIES is a list of file properties (strings)."
table)
result)))
+;; We cannot use the `declare' form for `tramp-suppress-trace' in
+;; autoloaded functions, because the tramp-loaddefs.el generation
+;; would fail.
+(function-put #'tramp-cache-print 'tramp-suppress-trace t)
+
;;;###tramp-autoload
(defun tramp-list-connections ()
"Return all active `tramp-file-name' structs according to `tramp-cache-data'."
@@ -554,6 +551,7 @@ PROPERTIES is a list of file properties (strings)."
(defun tramp-dump-connection-properties ()
"Write persistent connection properties into file \
`tramp-persistency-file-name'."
+ (declare (tramp-suppress-trace t))
;; We shouldn't fail, otherwise Emacs might not be able to be closed.
(ignore-errors
(when (and (hash-table-p tramp-cache-data)
@@ -562,6 +560,8 @@ PROPERTIES is a list of file properties (strings)."
(stringp tramp-persistency-file-name))
(let ((cache (copy-hash-table tramp-cache-data))
print-length print-level)
+ ;; Remove `tramp-null-hop'.
+ (remhash tramp-null-hop cache)
;; Remove temporary data. If there is the key "login-as", we
;; don't save either, because all other properties might
;; depend on the login name, and we want to give the
@@ -677,4 +677,8 @@ for all methods. Resulting data are derived from connection history."
(provide 'tramp-cache)
+;;; TODO:
+;;
+;; * Use multisession.el, starting with Emacs 29.1.
+
;;; tramp-cache.el ends here
diff --git a/lisp/net/tramp-cmds.el b/lisp/net/tramp-cmds.el
index 8e07f013480..d3af7a009ec 100644
--- a/lisp/net/tramp-cmds.el
+++ b/lisp/net/tramp-cmds.el
@@ -31,6 +31,8 @@
(require 'tramp)
;; Pacify byte-compiler.
+(declare-function dired-advertise "dired")
+(declare-function dired-unadvertise "dired")
(declare-function mml-mode "mml")
(declare-function mml-insert-empty-tag "mml")
(declare-function reporter-dump-variable "reporter")
@@ -52,6 +54,7 @@ SYNTAX can be one of the symbols `default' (default),
(when syntax
(customize-set-variable 'tramp-syntax syntax)))
+;; Use `match-buffers' starting with Emacs 29.1.
;;;###tramp-autoload
(defun tramp-list-tramp-buffers ()
"Return a list of all Tramp connection buffers."
@@ -63,6 +66,7 @@ SYNTAX can be one of the symbols `default' (default),
(all-completions
"*trace tramp" (mapcar #'list (mapcar #'buffer-name (buffer-list))))))
+;; Use `match-buffers' starting with Emacs 29.1.
;;;###tramp-autoload
(defun tramp-list-remote-buffers ()
"Return a list of all buffers with remote `default-directory'."
@@ -73,6 +77,8 @@ SYNTAX can be one of the symbols `default' (default),
(when (tramp-tramp-file-p (tramp-get-default-directory x)) x))
(buffer-list))))
+;;; Cleanup
+
;;;###tramp-autoload
(defvar tramp-cleanup-connection-hook nil
"List of functions to be called after Tramp connection is cleaned up.
@@ -207,17 +213,86 @@ This includes password cache, file cache, connection cache, buffers."
;; The end.
(run-hooks 'tramp-cleanup-all-connections-hook))
+(defcustom tramp-cleanup-some-buffers-hook nil
+ "Hook for `tramp-cleanup-some-buffers'.
+The functions determine which buffers shall be killed. This
+happens when at least one of the functions returns non-nil. The
+functions are called with `current-buffer' set."
+ :group 'tramp
+ :version "30.1"
+ :type 'hook)
+
+(add-hook 'tramp-cleanup-some-buffers-hook
+ #'buffer-file-name)
+
+(defun tramp-dired-buffer-p ()
+ "Return t if current buffer runs `dired-mode'."
+ (declare (tramp-suppress-trace t))
+ (derived-mode-p 'dired-mode))
+
+(add-hook 'tramp-cleanup-some-buffers-hook
+ #'tramp-dired-buffer-p)
+
+(defvar tramp-tainted-remote-process-buffers nil
+ "List of process buffers to be cleaned up.")
+
+(defun tramp-delete-tainted-remote-process-buffer-function ()
+ "Delete current buffer from `tramp-tainted-remote-process-buffers'."
+ (declare (tramp-suppress-trace t))
+ (setq tramp-tainted-remote-process-buffers
+ (delete (current-buffer) tramp-tainted-remote-process-buffers)))
+
;;;###tramp-autoload
-(defun tramp-cleanup-all-buffers ()
- "Kill all remote buffers."
+(defun tramp-taint-remote-process-buffer (buffer)
+ "Mark buffer as related to remote processes."
+ ;; (declare (tramp-suppress-trace t))
+ (add-to-list 'tramp-tainted-remote-process-buffers buffer))
+
+;; We cannot use the `declare' form for `tramp-suppress-trace' in
+;; autoloaded functions, because the tramp-loaddefs.el generation
+;; would fail.
+(function-put #'tramp-taint-remote-process-buffer 'tramp-suppress-trace t)
+
+(add-hook 'kill-buffer-hook
+ #'tramp-delete-tainted-remote-process-buffer-function)
+(add-hook 'tramp-unload-hook
+ (lambda ()
+ (remove-hook 'kill-buffer-hook
+ #'tramp-delete-tainted-remote-process-buffer-function)))
+
+(defun tramp-remote-process-p ()
+ "Return t if current buffer belongs to a remote process."
+ (memq (current-buffer) tramp-tainted-remote-process-buffers))
+
+(add-hook 'tramp-cleanup-some-buffers-hook
+ #'tramp-remote-process-p)
+
+;;;###tramp-autoload
+(defun tramp-cleanup-some-buffers ()
+ "Kill some remote buffers.
+A buffer is killed when it has a remote `default-directory', and
+one of the functions in `tramp-cleanup-some-buffers-hook' returns
+non-nil."
(interactive)
;; Remove all Tramp related connections.
(tramp-cleanup-all-connections)
- ;; Remove all buffers with a remote default-directory.
+ ;; Remove all buffers with a remote default-directory which fit the hook.
(dolist (name (tramp-list-remote-buffers))
- (when (bufferp (get-buffer name)) (kill-buffer name))))
+ (and (buffer-live-p (get-buffer name))
+ (with-current-buffer name
+ (run-hook-with-args-until-success 'tramp-cleanup-some-buffers-hook))
+ (kill-buffer name))))
+
+;;;###tramp-autoload
+(defun tramp-cleanup-all-buffers ()
+ "Kill all remote buffers."
+ (interactive)
+ (let ((tramp-cleanup-some-buffers-hook '(tramp-compat-always)))
+ (tramp-cleanup-some-buffers)))
+
+;;; Rename
(defcustom tramp-default-rename-alist nil
"Default target for renaming remote buffer file names.
@@ -359,7 +434,7 @@ The remote connection identified by SOURCE is flushed by
(dir (tramp-rename-read-file-name-dir default))
(init (tramp-rename-read-file-name-init default))
(tramp-ignored-file-name-regexp
- (tramp-compat-rx (literal (file-remote-p source)))))
+ (rx (literal (file-remote-p source)))))
(read-file-name-default
"Enter new Tramp connection: "
dir default 'confirm init #'file-directory-p)))))
@@ -470,7 +545,7 @@ For details, see `tramp-rename-files'."
(dir (tramp-rename-read-file-name-dir default))
(init (tramp-rename-read-file-name-init default))
(tramp-ignored-file-name-regexp
- (tramp-compat-rx (literal (file-remote-p source)))))
+ (rx (literal (file-remote-p source)))))
(read-file-name-default
(format "Change Tramp connection `%s': " source)
dir default 'confirm init #'file-directory-p)))))
@@ -483,6 +558,73 @@ For details, see `tramp-rename-files'."
(function-put
#'tramp-rename-these-files 'completion-predicate #'tramp-command-completion-p)
+;;; Run as sudo
+
+(defcustom tramp-file-name-with-method "sudo"
+ "Which method to be used in `tramp-file-name-with-sudo'."
+ :group 'tramp
+ :version "30.1"
+ :type '(choice (const "su")
+ (const "sudo")
+ (const "doas")
+ (const "ksu")))
+
+(defun tramp-file-name-with-sudo (filename)
+ "Convert FILENAME into a multi-hop file name with \"sudo\".
+An alternative method could be chosen with `tramp-file-name-with-method'."
+ (setq filename (expand-file-name filename))
+ (if (tramp-tramp-file-p filename)
+ (with-parsed-tramp-file-name filename nil
+ (cond
+ ;; Remote file with proper method.
+ ((string-equal method tramp-file-name-with-method)
+ filename)
+ ;; Remote file on the local host.
+ ((and
+ (stringp tramp-local-host-regexp) (stringp host)
+ (string-match-p tramp-local-host-regexp host))
+ (tramp-make-tramp-file-name
+ (make-tramp-file-name
+ :method tramp-file-name-with-method :localname localname)))
+ ;; Remote file with multi-hop capable method..
+ ((tramp-multi-hop-p v)
+ (tramp-make-tramp-file-name
+ (make-tramp-file-name
+ :method (tramp-find-method tramp-file-name-with-method nil host)
+ :user (tramp-find-user tramp-file-name-with-method nil host)
+ :host (tramp-find-host tramp-file-name-with-method nil host)
+ :localname localname :hop (tramp-make-tramp-hop-name v))))
+ ;; Other remote file.
+ (t (tramp-user-error v "Multi-hop with `%s' not applicable" method))))
+ ;; Local file.
+ (tramp-make-tramp-file-name
+ (make-tramp-file-name
+ :method tramp-file-name-with-method :localname filename))))
+
+;;;###tramp-autoload
+(defun tramp-revert-buffer-with-sudo ()
+ "Revert current buffer to visit with \"sudo\" permissions.
+An alternative method could be chosen with `tramp-file-name-with-method'.
+If the buffer visits a file, the file is replaced.
+If the buffer runs `dired', the buffer is reverted."
+ (interactive)
+ (cond
+ ((buffer-file-name)
+ (find-alternate-file (tramp-file-name-with-sudo (buffer-file-name))))
+ ((tramp-dired-buffer-p)
+ (dired-unadvertise (expand-file-name default-directory))
+ (setq default-directory (tramp-file-name-with-sudo default-directory)
+ list-buffers-directory
+ (tramp-file-name-with-sudo list-buffers-directory))
+ (if (consp dired-directory)
+ (setcar
+ dired-directory (tramp-file-name-with-sudo (car dired-directory)))
+ (setq dired-directory (tramp-file-name-with-sudo dired-directory)))
+ (dired-advertise)
+ (revert-buffer))))
+
+;;; Recompile on ELPA
+
;; This function takes action since Emacs 28.1, when
;; `read-extended-command-predicate' is set to
;; `command-completion-default-include-p'.
@@ -625,7 +767,7 @@ buffer in your bug report.
(unless (hash-table-p val)
;; Remove string quotation.
(when (looking-at
- (tramp-compat-rx
+ (rx
bol (group (* anychar)) "\"" ;; \1 "
(group "(base64-decode-string ") "\\" ;; \2 \
(group "\"" (* anychar)) "\\" ;; \3 \
@@ -679,7 +821,7 @@ buffer in your bug report.
;; Beautify encoded values.
(goto-char (point-min))
- (while (re-search-forward
+ (while (search-forward-regexp
(rx "'" (group "(decode-coding-string")) nil 'noerror)
(replace-match "\\1"))
(goto-char (point-max))
@@ -707,7 +849,7 @@ buffer in your bug report.
(setq buffer-read-only nil)
(goto-char (point-min))
(while (not (eobp))
- (if (re-search-forward tramp-buf-regexp (line-end-position) t)
+ (if (search-forward-regexp tramp-buf-regexp (line-end-position) t)
(forward-line 1)
(forward-line 0)
(let ((start (point)))
diff --git a/lisp/net/tramp-compat.el b/lisp/net/tramp-compat.el
index 43de5509081..98de0dba7ff 100644
--- a/lisp/net/tramp-compat.el
+++ b/lisp/net/tramp-compat.el
@@ -23,24 +23,22 @@
;;; Commentary:
-;; Tramp's main Emacs version for development is Emacs 29. This
-;; package provides compatibility functions for Emacs 26, Emacs 27 and
-;; Emacs 28.
+;; Tramp's main Emacs version for development is Emacs 30. This
+;; package provides compatibility functions for Emacs 27, Emacs 28 and
+;; Emacs 29.
;;; Code:
+(require 'tramp-loaddefs)
(require 'ansi-color)
(require 'auth-source)
(require 'format-spec)
(require 'parse-time)
(require 'shell)
-(require 'subr-x)
+(require 'xdg)
-(declare-function tramp-compat-rx "tramp")
-(declare-function tramp-error "tramp")
-(declare-function tramp-file-name-handler "tramp")
+(declare-function tramp-error "tramp-message")
(declare-function tramp-tramp-file-p "tramp")
-(defvar tramp-syntax)
(defvar tramp-temp-name-prefix)
(defconst tramp-compat-emacs-compiled-version (eval-when-compile emacs-version)
@@ -68,10 +66,17 @@
(with-no-warnings (funcall ,function ,@arguments))))
;; We must use a local directory. If it is remote, we could run into
-;; an infloop.
+;; an infloop. We try to follow the XDG specification, for security reasons.
(defconst tramp-compat-temporary-file-directory
- (eval (car (get 'temporary-file-directory 'standard-value)) t)
- "The default value of `temporary-file-directory'.")
+ (file-name-as-directory
+ (if-let ((xdg (xdg-cache-home))
+ ((file-directory-p xdg))
+ ((file-writable-p xdg)))
+ ;; We can use `file-name-concat' starting with Emacs 28.1.
+ (prog1 (setq xdg (concat (file-name-as-directory xdg) "emacs"))
+ (make-directory xdg t))
+ (eval (car (get 'temporary-file-directory 'standard-value)) t)))
+ "The default value of `temporary-file-directory' for Tramp.")
(defsubst tramp-compat-make-temp-name ()
"Generate a local temporary file name (compat function)."
@@ -87,153 +92,6 @@ Add the extension of F, if existing."
tramp-temp-name-prefix tramp-compat-temporary-file-directory)
dir-flag (file-name-extension f t)))
-;; `file-name-quoted-p', `file-name-quote' and `file-name-unquote' got
-;; a second argument in Emacs 27.1.
-;;;###tramp-autoload
-(defalias 'tramp-compat-file-name-quoted-p
- (if (equal (func-arity #'file-name-quoted-p) '(1 . 2))
- #'file-name-quoted-p
- (lambda (name &optional top)
- "Whether NAME is quoted with prefix \"/:\".
-If NAME is a remote file name and TOP is nil, check the local part of NAME."
- (let ((file-name-handler-alist (unless top file-name-handler-alist)))
- (string-prefix-p "/:" (file-local-name name))))))
-
-(defalias 'tramp-compat-file-name-quote
- (if (equal (func-arity #'file-name-quote) '(1 . 2))
- #'file-name-quote
- (lambda (name &optional top)
- "Add the quotation prefix \"/:\" to file NAME.
-If NAME is a remote file name and TOP is nil, the local part of NAME is quoted."
- (let ((file-name-handler-alist (unless top file-name-handler-alist)))
- (if (tramp-compat-file-name-quoted-p name top)
- name
- (concat (file-remote-p name) "/:" (file-local-name name)))))))
-
-(defalias 'tramp-compat-file-name-unquote
- (if (equal (func-arity #'file-name-unquote) '(1 . 2))
- #'file-name-unquote
- (lambda (name &optional top)
- "Remove quotation prefix \"/:\" from file NAME.
-If NAME is a remote file name and TOP is nil, the local part of
-NAME is unquoted."
- (let* ((file-name-handler-alist (unless top file-name-handler-alist))
- (localname (file-local-name name)))
- (when (tramp-compat-file-name-quoted-p localname top)
- (setq
- localname
- (if (tramp-compat-length= localname 2) "/" (substring localname 2))))
- (concat (file-remote-p name) localname)))))
-
-;; `tramp-syntax' has changed its meaning in Emacs 26.1. We still
-;; support old settings.
-(defsubst tramp-compat-tramp-syntax ()
- "Return proper value of `tramp-syntax'."
- (cond ((eq tramp-syntax 'ftp) 'default)
- ((eq tramp-syntax 'sep) 'separate)
- (t tramp-syntax)))
-
-;; The signature of `tramp-make-tramp-file-name' has been changed.
-;; Therefore, we cannot use `url-tramp-convert-url-to-tramp' prior
-;; Emacs 26.1. We use `temporary-file-directory' as indicator.
-(defconst tramp-compat-use-url-tramp-p (fboundp 'temporary-file-directory)
- "Whether to use url-tramp.el.")
-
-;; `exec-path' is new in Emacs 27.1.
-(defalias 'tramp-compat-exec-path
- (if (fboundp 'exec-path)
- #'exec-path
- (lambda ()
- "List of directories to search programs to run in remote subprocesses."
- (if (tramp-tramp-file-p default-directory)
- (tramp-file-name-handler 'exec-path)
- exec-path))))
-
-;; `time-equal-p' has appeared in Emacs 27.1.
-(defalias 'tramp-compat-time-equal-p
- (if (fboundp 'time-equal-p)
- #'time-equal-p
- (lambda (t1 t2)
- "Return non-nil if time value T1 is equal to time value T2.
-A nil value for either argument stands for the current time."
- (equal (or t1 (current-time)) (or t2 (current-time))))))
-
-;; `flatten-tree' has appeared in Emacs 27.1.
-(defalias 'tramp-compat-flatten-tree
- (if (fboundp 'flatten-tree)
- #'flatten-tree
- (lambda (tree)
- "Take TREE and \"flatten\" it."
- (let (elems)
- (setq tree (list tree))
- (while (let ((elem (pop tree)))
- (cond ((consp elem)
- (setq tree (cons (car elem) (cons (cdr elem) tree))))
- (elem
- (push elem elems)))
- tree))
- (nreverse elems)))))
-
-;; `progress-reporter-update' got argument SUFFIX in Emacs 27.1.
-(defalias 'tramp-compat-progress-reporter-update
- (if (equal (func-arity #'progress-reporter-update) '(1 . 3))
- #'progress-reporter-update
- (lambda (reporter &optional value _suffix)
- (progress-reporter-update reporter value))))
-
-;; `ignore-error' is new in Emacs 27.1.
-(defmacro tramp-compat-ignore-error (condition &rest body)
- "Execute BODY; if the error CONDITION occurs, return nil.
-Otherwise, return result of last form in BODY.
-
-CONDITION can also be a list of error conditions."
- (declare (debug t) (indent 1))
- `(condition-case nil (progn ,@body) (,condition nil)))
-
-;; `rx' in Emacs 26 doesn't know the `literal', `anychar' and
-;; `multibyte' constructs. The `not' construct requires an `any'
-;; construct as argument. The `regexp' construct requires a literal
-;; string.
-(defvar tramp-compat-rx--runtime-params)
-
-(defun tramp-compat-rx--transform-items (items)
- (mapcar #'tramp-compat-rx--transform-item items))
-
-;; There is an error in Emacs 26. `(rx "a" (? ""))' => "a?".
-;; We must protect the string in regexp and literal, therefore.
-(defun tramp-compat-rx--transform-item (item)
- (pcase item
- ('anychar 'anything)
- ('multibyte 'nonascii)
- (`(not ,expr)
- (if (consp expr) item (list 'not (list 'any expr))))
- (`(regexp ,expr)
- (setq tramp-compat-rx--runtime-params t)
- `(regexp ,(list '\, `(concat "\\(?:" ,expr "\\)"))))
- (`(literal ,expr)
- (setq tramp-compat-rx--runtime-params t)
- `(regexp ,(list '\, `(concat "\\(?:" (regexp-quote ,expr) "\\)"))))
- (`(eval . ,_) item)
- (`(,head . ,rest) (cons head (tramp-compat-rx--transform-items rest)))
- (_ item)))
-
-(defun tramp-compat-rx--transform (items)
- (let* ((tramp-compat-rx--runtime-params nil)
- (new-rx (cons ': (tramp-compat-rx--transform-items items))))
- (if tramp-compat-rx--runtime-params
- `(rx-to-string ,(list '\` new-rx) t)
- (rx-to-string new-rx t))))
-
-(if (ignore-errors (rx-to-string '(literal "a"))) ;; Emacs 27+.
- (defalias 'tramp-compat-rx #'rx)
- (defmacro tramp-compat-rx (&rest items)
- (tramp-compat-rx--transform items)))
-
-;; This is needed for compilation in the Emacs source tree.
-;;;###autoload (defalias 'tramp-compat-rx #'rx)
-
-(put #'tramp-compat-rx 'tramp-autoload t)
-
;; `file-modes', `set-file-modes' and `set-file-times' got argument
;; FLAG in Emacs 28.1.
(defalias 'tramp-compat-file-modes
@@ -345,7 +203,7 @@ CONDITION can also be a list of error conditions."
(let ((matches 0)
(case-fold-search nil))
(goto-char start)
- (while (re-search-forward regexp end t)
+ (while (search-forward-regexp regexp end t)
(replace-match replacement t)
(setq matches (1+ matches)))
(and (not (zerop matches))
@@ -370,6 +228,16 @@ CONDITION can also be a list of error conditions."
(lambda (sequence length)
(= (length sequence) length))))
+;; `always' is introduced with Emacs 28.1.
+(defalias 'tramp-compat-always
+ (if (fboundp 'always)
+ #'always
+ (lambda (&rest _arguments)
+ "Do nothing and return t.
+This function accepts any number of ARGUMENTS, but ignores them.
+Also see `ignore'."
+ t)))
+
;; `permission-denied' is introduced in Emacs 29.1.
(defconst tramp-permission-denied
(if (get 'permission-denied 'error-conditions) 'permission-denied 'file-error)
@@ -426,8 +294,31 @@ CONDITION can also be a list of error conditions."
(autoload 'netrc-parse "netrc")
(netrc-parse file))))
+;; User option `password-colon-equivalents' is new in Emacs 30.1.
+(if (boundp 'password-colon-equivalents)
+ (defvaralias
+ 'tramp-compat-password-colon-equivalents
+ 'password-colon-equivalents)
+ (defvar tramp-compat-password-colon-equivalents
+ '(?\N{COLON}
+ ?\N{FULLWIDTH COLON}
+ ?\N{SMALL COLON}
+ ?\N{PRESENTATION FORM FOR VERTICAL COLON}
+ ?\N{KHMER SIGN CAMNUC PII KUUH})
+ "List of characters equivalent to trailing colon in \"password\" prompts."))
+
+;; Macro `connection-local-p' is new in Emacs 30.1.
+(if (macrop 'connection-local-p)
+ (defalias 'tramp-compat-connection-local-p 'connection-local-p)
+ (defmacro tramp-compat-connection-local-p (variable)
+ "Non-nil if VARIABLE has a connection-local binding in `default-directory'."
+ `(let (connection-local-variables-alist file-local-variables-alist)
+ (hack-connection-local-variables
+ (connection-local-criteria-for-default-directory))
+ (and (assq ',variable connection-local-variables-alist) t))))
+
(dolist (elt (all-completions "tramp-compat-" obarray 'functionp))
- (put (intern elt) 'tramp-suppress-trace t))
+ (function-put (intern elt) 'tramp-suppress-trace t))
(add-hook 'tramp-unload-hook
(lambda ()
@@ -439,9 +330,18 @@ CONDITION can also be a list of error conditions."
;;; TODO:
;;
;; * Starting with Emacs 27.1, there's no need to escape open
-;; parentheses with a backslash in docstrings anymore.
+;; parentheses with a backslash in docstrings anymore. However,
+;; `outline-minor-mode' has still problems with this. Since there
+;; are developers using `outline-minor-mode' in Lisp files, we still
+;; keep this quoting.
+;;
+;; * Starting with Emacs 29.1, use `buffer-match-p'.
+;;
+;; * Starting with Emacs 29.1, use `string-split'.
;;
-;; * Starting with Emacs 27.1, there's `make-empty-file'. Could be
-;; used instead of `(write-region "" ...)'.
+;; * Starting with Emacs 30.1, there is `handler-bind'. Use it
+;; instead of `condition-case' when the origin of an error shall be
+;; kept, for example when the HANDLER propagates the error with
+;; `(signal (car err) (cdr err)'.
;;; tramp-compat.el ends here
diff --git a/lisp/net/tramp-container.el b/lisp/net/tramp-container.el
index 6e63a8b55ec..30639cbeb85 100644
--- a/lisp/net/tramp-container.el
+++ b/lisp/net/tramp-container.el
@@ -31,29 +31,58 @@
;; Open a file on a running Docker container:
;;
;; C-x C-f /docker:USER@CONTAINER:/path/to/file
+;; C-x C-f /dockercp:USER@CONTAINER:/path/to/file
;;
;; or Podman:
;;
;; C-x C-f /podman:USER@CONTAINER:/path/to/file
+;; C-x C-f /podmancp:USER@CONTAINER:/path/to/file
;;
;; Where:
-;; USER is the user on the container to connect as (optional)
-;; CONTAINER is the container to connect to
+;; USER is the user on the container to connect as (optional).
+;; CONTAINER is the container to connect to.
+;;
+;; "docker" and "podman" are inline methods, "dockercp" and "podmancp"
+;; are out-of-band methods.
+;;
;;
;;
;; Open file in a Kubernetes container:
;;
-;; C-x C-f /kubernetes:POD:/path/to/file
+;; C-x C-f /kubernetes:[CONTAINER.]POD:/path/to/file
;;
;; Where:
-;; POD is the pod to connect to.
-;; By default, the first container in that pod will be
-;; used.
+;; POD is the pod to connect to.
+;; CONTAINER is the container to connect to (optional).
+;; By default, the first container in that pod will
+;; be used.
;;
;; Completion for POD and accessing it operate in the current
;; namespace, use this command to change it:
;;
;; "kubectl config set-context --current --namespace=<name>"
+;;
+;;
+;;
+;; Open a file on an existing Toolbox container:
+;;
+;; C-x C-f /toolbox:CONTAINER:/path/to/file
+;;
+;; Where:
+;; CONTAINER is the container to connect to (optional).
+;;
+;; If the container is not running, it is started. If no container is
+;; specified, the default Toolbox container is used.
+;;
+;;
+;;
+;; Open a file on a running Flatpak sandbox:
+;;
+;; C-x C-f /flatpak:SANDBOX:/path/to/file
+;;
+;; Where:
+;; SANDBOX is the running sandbox to connect to.
+;; It could be an application ID, an instance ID, or a PID.
;;; Code:
@@ -83,73 +112,268 @@
:type '(choice (const "kubectl")
(string)))
+(defcustom tramp-kubernetes-context nil
+ "Context of Kubernetes.
+If it is nil, the default context will be used."
+ :group 'tramp
+ :version "30.1"
+ :type '(choice (const :tag "Use default" nil)
+ (string)))
+
+(defcustom tramp-kubernetes-namespace "default"
+ "Namespace of Kubernetes."
+ :group 'tramp
+ :version "30.1"
+ :type 'string)
+
+;;;###tramp-autoload
+(defcustom tramp-toolbox-program "toolbox"
+ "Name of the Toolbox client program."
+ :group 'tramp
+ :version "30.1"
+ :type '(choice (const "toolbox")
+ (string)))
+
+;;;###tramp-autoload
+(defcustom tramp-flatpak-program "flatpak"
+ "Name of the Flatpak client program."
+ :group 'tramp
+ :version "30.1"
+ :type '(choice (const "flatpak")
+ (string)))
+
;;;###tramp-autoload
(defconst tramp-docker-method "docker"
"Tramp method name to use to connect to Docker containers.")
;;;###tramp-autoload
+(defconst tramp-dockercp-method "dockercp"
+ "Tramp method name to use to connect to Docker containers.
+This is for out-of-band connections.")
+
+;;;###tramp-autoload
(defconst tramp-podman-method "podman"
"Tramp method name to use to connect to Podman containers.")
;;;###tramp-autoload
+(defconst tramp-podmancp-method "podmancp"
+ "Tramp method name to use to connect to Podman containers.
+This is for out-of-band connections.")
+
+;;;###tramp-autoload
(defconst tramp-kubernetes-method "kubernetes"
"Tramp method name to use to connect to Kubernetes containers.")
;;;###tramp-autoload
-(defun tramp-container--completion-function (program)
+(defconst tramp-toolbox-method "toolbox"
+ "Tramp method name to use to connect to Toolbox containers.")
+
+;;;###tramp-autoload
+(defconst tramp-flatpak-method "flatpak"
+ "Tramp method name to use to connect to Flatpak sandboxes.")
+
+;;;###tramp-autoload
+(defmacro tramp-skeleton-completion-function (method &rest body)
+ "Skeleton for `tramp-*-completion-function' with multi-hop support.
+BODY is the backend specific code."
+ (declare (indent 1) (debug t))
+ `(let* ((default-directory
+ (or (and (member ,method tramp-completion-multi-hop-methods)
+ tramp--last-hop-directory)
+ tramp-compat-temporary-file-directory))
+ (program (let ((tramp-verbose 0))
+ (tramp-get-method-parameter
+ (make-tramp-file-name :method ,method)
+ 'tramp-login-program)))
+ (vec (when (tramp-tramp-file-p default-directory)
+ (tramp-dissect-file-name default-directory)))
+ non-essential)
+ ;; We don't use connection properties, because this information
+ ;; shouldn't be kept persistently.
+ (with-tramp-file-property
+ vec (concat "/" ,method ":") "user-host-completions"
+ ,@body)))
+
+;;;###tramp-autoload
+(defun tramp-container--completion-function (method)
"List running containers available for connection.
-PROGRAM is the program to be run for \"ps\", either
-`tramp-docker-program' or `tramp-podman-program'.
+METHOD is the Tramp method to be used for \"ps\", either
+`tramp-docker-method', `tramp-dockercp-method', `tramp-podman-method',
+or `tramp-podmancp-method'.
This function is used by `tramp-set-completion-function', please
see its function help for a description of the format."
- (when-let ((default-directory tramp-compat-temporary-file-directory)
- (raw-list (shell-command-to-string
- (concat program " ps --format '{{.ID}}\t{{.Names}}'")))
- (lines (split-string raw-list "\n" 'omit))
- (names (mapcar
- (lambda (line)
- (when (string-match
- (rx bol (group (1+ nonl))
- "\t" (? (group (1+ nonl))) eol)
- line)
- (or (match-string 2 line) (match-string 1 line))))
- lines)))
- (mapcar (lambda (name) (list nil name)) (delq nil names))))
-
-;;;###tramp-autoload
-(defun tramp-kubernetes--completion-function (&rest _args)
+ (tramp-skeleton-completion-function method
+ (when-let ((raw-list
+ (shell-command-to-string
+ (concat program " ps --format '{{.ID}}\t{{.Names}}'")))
+ (lines (split-string raw-list "\n" 'omit))
+ (names
+ (mapcar
+ (lambda (line)
+ (when (string-match
+ (rx bol (group (1+ nonl))
+ "\t" (? (group (1+ nonl))) eol)
+ line)
+ (or (match-string 2 line) (match-string 1 line))))
+ lines)))
+ (mapcar (lambda (name) (list nil name)) (delq nil names)))))
+
+;;;###tramp-autoload
+(defun tramp-kubernetes--completion-function (method)
"List Kubernetes pods available for connection.
This function is used by `tramp-set-completion-function', please
see its function help for a description of the format."
- (when-let ((default-directory tramp-compat-temporary-file-directory)
- (raw-list (shell-command-to-string
- (concat tramp-kubernetes-program
- " get pods --no-headers "
- "-o custom-columns=NAME:.metadata.name")))
- (names (split-string raw-list "\n" 'omit)))
- (mapcar (lambda (name) (list nil name)) names)))
+ (tramp-skeleton-completion-function method
+ (when-let ((raw-list
+ (shell-command-to-string
+ (concat
+ program " "
+ (tramp-kubernetes--context-namespace vec)
+ " get pods --no-headers"
+ ;; We separate pods by "|". Inside a pod, its name
+ ;; is separated from the containers by ":".
+ ;; Containers are separated by ",".
+ " -o jsonpath='{range .items[*]}{\"|\"}{.metadata.name}"
+ "{\":\"}{range .spec.containers[*]}{.name}{\",\"}"
+ "{end}{end}'")))
+ (lines (split-string raw-list "|" 'omit)))
+ (let (names)
+ (dolist (line lines)
+ (setq line (split-string line ":" 'omit))
+ ;; Pod name.
+ (push (car line) names)
+ ;; Container names.
+ (dolist (elt (split-string (cadr line) "," 'omit))
+ (push (concat elt "." (car line)) names)))
+ (mapcar (lambda (name) (list nil name)) (delq nil names))))))
+
+(defconst tramp-kubernetes--host-name-regexp
+ (rx (? (group (regexp tramp-host-regexp)) ".")
+ (group (regexp tramp-host-regexp)))
+ "The CONTAINER.POD syntax of kubernetes host names in Tramp.")
+
+;;;###tramp-autoload
+(defun tramp-kubernetes--container (vec)
+ "Extract the container name from a kubernetes host name in VEC."
+ (or (let ((host (tramp-file-name-host vec)))
+ (and (string-match tramp-kubernetes--host-name-regexp host)
+ (match-string 1 host)))
+ ""))
+
+;;;###tramp-autoload
+(defun tramp-kubernetes--pod (vec)
+ "Extract the pod name from a kubernetes host name in VEC."
+ (or (let ((host (tramp-file-name-host vec)))
+ (and (string-match tramp-kubernetes--host-name-regexp host)
+ (match-string 2 host)))
+ ""))
+
+;; We must change `vec' and `default-directory' to the previous hop,
+;; in order to run `process-file' in a proper environment.
+(defmacro tramp-skeleton-kubernetes-vector (vec &rest body)
+ "Skeleton for `tramp-kubernetes--current-context*' with multi-hop support.
+BODY is the backend specific code."
+ (declare (indent 1) (debug t))
+ `(let* ((vec
+ (cond
+ ((null ,vec) tramp-null-hop)
+ ((equal (tramp-file-name-method ,vec) tramp-kubernetes-method)
+ (if (tramp-file-name-hop ,vec)
+ (tramp-dissect-hop-name (tramp-file-name-hop ,vec))
+ tramp-null-hop))
+ (t ,vec)))
+ (default-directory
+ (if (equal vec tramp-null-hop)
+ tramp-compat-temporary-file-directory
+ (tramp-make-tramp-file-name vec "/"))))
+ ,@body))
+
+(defun tramp-kubernetes--current-context (vec)
+ "Return Kubernetes current context.
+Obey `tramp-kubernetes-context'"
+ (or tramp-kubernetes-context
+ (tramp-skeleton-kubernetes-vector vec
+ (with-tramp-file-property
+ vec (concat "/" tramp-kubernetes-method ":") "current-context"
+ (with-temp-buffer
+ (when (zerop
+ (process-file
+ tramp-kubernetes-program nil t nil
+ "config" "current-context"))
+ (goto-char (point-min))
+ (buffer-substring (point) (line-end-position))))))))
(defun tramp-kubernetes--current-context-data (vec)
"Return Kubernetes current context data as JSON string."
- (with-temp-buffer
- (when (zerop
- (tramp-call-process
- vec tramp-kubernetes-program nil t nil
- "config" "current-context"))
- (goto-char (point-min))
- (let ((current-context (buffer-substring (point) (line-end-position))))
- (erase-buffer)
+ (when-let ((current-context (tramp-kubernetes--current-context vec)))
+ (tramp-skeleton-kubernetes-vector vec
+ (with-temp-buffer
(when (zerop
- (tramp-call-process
- vec tramp-kubernetes-program nil t nil
+ (process-file
+ tramp-kubernetes-program nil t nil
"config" "view" "-o"
(format
"jsonpath='{.contexts[?(@.name == \"%s\")]}'" current-context)))
(buffer-string))))))
;;;###tramp-autoload
+(defun tramp-kubernetes--context-namespace (vec)
+ "The kubectl options for context and namespace as string."
+ (mapconcat
+ #'identity
+ `(,(when-let ((context (tramp-kubernetes--current-context vec)))
+ (format "--context=%s" context))
+ ,(when tramp-kubernetes-namespace
+ (format "--namespace=%s" tramp-kubernetes-namespace)))
+ " "))
+
+;;;###tramp-autoload
+(defun tramp-toolbox--completion-function (method)
+ "List Toolbox containers available for connection.
+
+This function is used by `tramp-set-completion-function', please
+see its function help for a description of the format."
+ (tramp-skeleton-completion-function method
+ (when-let ((raw-list (shell-command-to-string (concat program " list -c")))
+ ;; Ignore header line.
+ (lines (cdr (split-string raw-list "\n" 'omit)))
+ (names (mapcar
+ (lambda (line)
+ (when (string-match
+ (rx bol (1+ (not space))
+ (1+ space) (group (1+ (not space))) space)
+ line)
+ (match-string 1 line)))
+ lines)))
+ (mapcar (lambda (name) (list nil name)) (delq nil names)))))
+
+;;;###tramp-autoload
+(defun tramp-flatpak--completion-function (method)
+ "List Flatpak sandboxes available for connection.
+It returns application IDs or, in case there is no application
+ID, instance IDs.
+
+This function is used by `tramp-set-completion-function', please
+see its function help for a description of the format."
+ (tramp-skeleton-completion-function method
+ (when-let ((raw-list
+ (shell-command-to-string
+ ;; Ignore header line.
+ (concat program " ps --columns=instance,application | cat -")))
+ (lines (split-string raw-list "\n" 'omit))
+ (names (mapcar
+ (lambda (line)
+ (when (string-match
+ (rx bol (* space) (group (+ (not space)))
+ (? (+ space) (group (+ (not space)))) eol)
+ line)
+ (or (match-string 2 line) (match-string 1 line))))
+ lines)))
+ (mapcar (lambda (name) (list nil name)) (delq nil names)))))
+
+;;;###tramp-autoload
(defvar tramp-default-remote-shell) ;; Silence byte compiler.
;;;###tramp-autoload
@@ -168,6 +392,23 @@ see its function help for a description of the format."
(tramp-remote-shell-args ("-i" "-c"))))
(add-to-list 'tramp-methods
+ `(,tramp-dockercp-method
+ (tramp-login-program ,tramp-docker-program)
+ (tramp-login-args (("exec")
+ ("-it")
+ ("-u" "%u")
+ ("%h")
+ ("%l")))
+ (tramp-direct-async (,tramp-default-remote-shell "-c"))
+ (tramp-remote-shell ,tramp-default-remote-shell)
+ (tramp-remote-shell-login ("-l"))
+ (tramp-remote-shell-args ("-i" "-c"))
+ (tramp-copy-program ,tramp-docker-program)
+ (tramp-copy-args (("cp")))
+ (tramp-copy-file-name (("%h" ":") ("%f")))
+ (tramp-copy-recursive t)))
+
+ (add-to-list 'tramp-methods
`(,tramp-podman-method
(tramp-login-program ,tramp-podman-program)
(tramp-login-args (("exec")
@@ -181,32 +422,126 @@ see its function help for a description of the format."
(tramp-remote-shell-args ("-i" "-c"))))
(add-to-list 'tramp-methods
+ `(,tramp-podmancp-method
+ (tramp-login-program ,tramp-podman-program)
+ (tramp-login-args (("exec")
+ ("-it")
+ ("-u" "%u")
+ ("%h")
+ ("%l")))
+ (tramp-direct-async (,tramp-default-remote-shell "-c"))
+ (tramp-remote-shell ,tramp-default-remote-shell)
+ (tramp-remote-shell-login ("-l"))
+ (tramp-remote-shell-args ("-i" "-c"))
+ (tramp-copy-program ,tramp-podman-program)
+ (tramp-copy-args (("cp")))
+ (tramp-copy-file-name (("%h" ":") ("%f")))
+ (tramp-copy-recursive t)))
+
+ (add-to-list 'tramp-methods
`(,tramp-kubernetes-method
(tramp-login-program ,tramp-kubernetes-program)
- (tramp-login-args (("exec")
+ (tramp-login-args (("%x") ; context and namespace.
+ ("exec")
+ ("-c" "%a") ; container.
("%h")
("-it")
("--")
("%l")))
- (tramp-config-check tramp-kubernetes--current-context-data)
(tramp-direct-async (,tramp-default-remote-shell "-c"))
(tramp-remote-shell ,tramp-default-remote-shell)
(tramp-remote-shell-login ("-l"))
(tramp-remote-shell-args ("-i" "-c"))))
+ (add-to-list 'tramp-methods
+ `(,tramp-toolbox-method
+ (tramp-login-program ,tramp-toolbox-program)
+ (tramp-login-args (("run")
+ ("-c" "%h")
+ ("%l")))
+ (tramp-direct-async (,tramp-default-remote-shell "-c"))
+ (tramp-remote-shell ,tramp-default-remote-shell)
+ (tramp-remote-shell-login ("-l"))
+ (tramp-remote-shell-args ("-c"))))
+
+ (add-to-list 'tramp-default-host-alist `(,tramp-toolbox-method nil ""))
+
+ (add-to-list 'tramp-methods
+ `(,tramp-flatpak-method
+ (tramp-login-program ,tramp-flatpak-program)
+ (tramp-login-args (("enter")
+ ("%h")
+ ("%l")))
+ (tramp-direct-async (,tramp-default-remote-shell "-c"))
+ (tramp-remote-shell ,tramp-default-remote-shell)
+ (tramp-remote-shell-login ("-l"))
+ (tramp-remote-shell-args ("-c"))))
+
(tramp-set-completion-function
tramp-docker-method
- `((tramp-container--completion-function
- ,(executable-find tramp-docker-program))))
+ `((tramp-container--completion-function ,tramp-docker-method)))
+
+ (tramp-set-completion-function
+ tramp-dockercp-method
+ `((tramp-container--completion-function ,tramp-dockercp-method)))
(tramp-set-completion-function
tramp-podman-method
- `((tramp-container--completion-function
- ,(executable-find tramp-podman-program))))
+ `((tramp-container--completion-function ,tramp-podman-method)))
+
+ (tramp-set-completion-function
+ tramp-podmancp-method
+ `((tramp-container--completion-function ,tramp-podmancp-method)))
(tramp-set-completion-function
tramp-kubernetes-method
- '((tramp-kubernetes--completion-function ""))))
+ `((tramp-kubernetes--completion-function ,tramp-kubernetes-method)))
+
+ (tramp-set-completion-function
+ tramp-toolbox-method
+ `((tramp-toolbox--completion-function ,tramp-toolbox-method)))
+
+ (tramp-set-completion-function
+ tramp-flatpak-method
+ `((tramp-flatpak--completion-function ,tramp-flatpak-method)))
+
+ (add-to-list 'tramp-completion-multi-hop-methods tramp-docker-method)
+ (add-to-list 'tramp-completion-multi-hop-methods tramp-podman-method)
+ (add-to-list 'tramp-completion-multi-hop-methods tramp-kubernetes-method)
+ (add-to-list 'tramp-completion-multi-hop-methods tramp-toolbox-method)
+ (add-to-list 'tramp-completion-multi-hop-methods tramp-flatpak-method)
+
+ ;; Default connection-local variables for Tramp.
+
+ (defconst tramp-kubernetes-connection-local-default-variables
+ '((tramp-config-check . tramp-kubernetes--current-context-data)
+ ;; This variable will be eval'ed in `tramp-expand-args'.
+ (tramp-extra-expand-args
+ . (?a (tramp-kubernetes--container (car tramp-current-connection))
+ ?h (tramp-kubernetes--pod (car tramp-current-connection))
+ ?x (tramp-kubernetes--context-namespace
+ (car tramp-current-connection)))))
+ "Default connection-local variables for remote kubernetes connections.")
+
+ (connection-local-set-profile-variables
+ 'tramp-kubernetes-connection-local-default-profile
+ tramp-kubernetes-connection-local-default-variables)
+
+ (connection-local-set-profiles
+ `(:application tramp :protocol ,tramp-kubernetes-method)
+ 'tramp-kubernetes-connection-local-default-profile)
+
+ (defconst tramp-flatpak-connection-local-default-variables
+ `((tramp-remote-path . ,(cons "/app/bin" tramp-remote-path)))
+ "Default connection-local variables for remote flatpak connections.")
+
+ (connection-local-set-profile-variables
+ 'tramp-flatpak-connection-local-default-profile
+ tramp-flatpak-connection-local-default-variables)
+
+ (connection-local-set-profiles
+ `(:application tramp :protocol ,tramp-flatpak-method)
+ 'tramp-flatpak-connection-local-default-profile))
(add-hook 'tramp-unload-hook
(lambda ()
diff --git a/lisp/net/tramp-crypt.el b/lisp/net/tramp-crypt.el
index 9f30cdef069..a7af64bff5c 100644
--- a/lisp/net/tramp-crypt.el
+++ b/lisp/net/tramp-crypt.el
@@ -146,7 +146,7 @@ They are completed by \"M-x TAB\" only when encryption support is enabled."
If NAME doesn't belong to an encrypted remote directory, return nil."
(catch 'crypt-file-name-p
(and tramp-crypt-enabled (stringp name)
- (not (tramp-compat-file-name-quoted-p name))
+ (not (file-name-quoted-p name))
(not (string-suffix-p tramp-crypt-encfs-config name))
;; No lock file name.
(not (string-prefix-p ".#" (file-name-nondirectory name)))
@@ -183,6 +183,7 @@ If NAME doesn't belong to an encrypted remote directory, return nil."
(file-equal-p . tramp-handle-file-equal-p)
(file-executable-p . tramp-crypt-handle-file-executable-p)
(file-exists-p . tramp-crypt-handle-file-exists-p)
+ ;; `file-group-gid' performed by default-handler.
(file-in-directory-p . tramp-handle-file-in-directory-p)
(file-local-copy . tramp-handle-file-local-copy)
(file-locked-p . tramp-crypt-handle-file-locked-p)
@@ -206,6 +207,7 @@ If NAME doesn't belong to an encrypted remote directory, return nil."
(file-symlink-p . tramp-handle-file-symlink-p)
(file-system-info . tramp-crypt-handle-file-system-info)
;; `file-truename' performed by default handler.
+ ;; `file-user-uid' performed by default-handler.
(file-writable-p . tramp-crypt-handle-file-writable-p)
(find-backup-file-name . tramp-handle-find-backup-file-name)
;; `get-file-buffer' performed by default handler.
@@ -279,8 +281,10 @@ arguments to pass to the OPERATION."
(apply #'tramp-crypt-file-name-for-operation operation args))
(fn (and (tramp-crypt-file-name-p filename)
(assoc operation tramp-crypt-file-name-handler-alist))))
- (save-match-data (apply (cdr fn) args))
- (tramp-crypt-run-real-handler operation args)))
+ (prog1 (save-match-data (apply (cdr fn) args))
+ (setq tramp-debug-message-fnh-function (cdr fn)))
+ (prog1 (tramp-crypt-run-real-handler operation args)
+ (setq tramp-debug-message-fnh-function operation))))
;;;###tramp-autoload
(progn (defun tramp-register-crypt-file-name-handler ()
@@ -312,74 +316,75 @@ connection if a previous connection has died for some reason."
;; For password handling, we need a process bound to the connection
;; buffer. Therefore, we create a dummy process. Maybe there is a
;; better solution?
- (unless (get-buffer-process (tramp-get-connection-buffer vec))
- (let ((p (make-network-process
- :name (tramp-get-connection-name vec)
- :buffer (tramp-get-connection-buffer vec)
- :server t :host 'local :service t :noquery t)))
- (process-put p 'tramp-vector vec)
- (set-process-query-on-exit-flag p nil)))
-
- ;; The following operations must be performed without
- ;; `tramp-crypt-file-name-handler'.
- (let* (tramp-crypt-enabled
- ;; Don't check for a proper method.
- (non-essential t)
- (remote-config
- (expand-file-name
- tramp-crypt-encfs-config (tramp-crypt-get-remote-dir vec)))
- (local-config (tramp-crypt-config-file-name vec)))
- ;; There is no local encfs6 config file.
- (unless (file-exists-p local-config)
- (if (and tramp-crypt-save-encfs-config-remote
- (file-exists-p remote-config))
- ;; Copy remote encfs6 config file if possible.
- (copy-file remote-config local-config 'ok 'keep)
-
- ;; Create local encfs6 config file otherwise.
- (let* ((default-directory tramp-compat-temporary-file-directory)
- (tmpdir1 (file-name-as-directory
- (tramp-compat-make-temp-file " .crypt" 'dir-flag)))
- (tmpdir2 (file-name-as-directory
- (tramp-compat-make-temp-file " .nocrypt" 'dir-flag))))
- ;; Enable `auth-source', unless "emacs -Q" has been called.
- (tramp-set-connection-property
- vec "first-password-request" tramp-cache-read-persistent-data)
- (with-temp-buffer
- (insert
- (tramp-read-passwd
- (tramp-get-connection-process vec)
- (format
- "New EncFS Password for %s " (tramp-crypt-get-remote-dir vec))))
- (when
- (zerop
- (tramp-call-process-region
- vec (point-min) (point-max)
- tramp-crypt-encfs-program nil (tramp-get-connection-buffer vec)
- nil tramp-crypt-encfs-option "--extpass=cat" tmpdir1 tmpdir2))
- ;; Save the password.
- (ignore-errors
- (and (functionp tramp-password-save-function)
- (funcall tramp-password-save-function)))))
-
- ;; Write local config file. Suppress file name IV chaining mode.
- (with-temp-file local-config
- (insert-file-contents
- (expand-file-name tramp-crypt-encfs-config tmpdir1))
- (when (search-forward
- "<chainedNameIV>1</chainedNameIV>" nil 'noerror)
- (replace-match "<chainedNameIV>0</chainedNameIV>")))
-
- ;; Unmount encfs. Delete temporary directories.
- (tramp-call-process
- vec tramp-crypt-encfs-program nil nil nil
- "--unmount" tmpdir1 tmpdir2)
- (delete-directory tmpdir1 'recursive)
- (delete-directory tmpdir2)
-
- ;; Copy local encfs6 config file to remote.
- (when tramp-crypt-save-encfs-config-remote
- (copy-file local-config remote-config 'ok 'keep)))))))
+ (with-tramp-debug-message vec "Opening connection"
+ (unless (get-buffer-process (tramp-get-connection-buffer vec))
+ (let ((p (make-network-process
+ :name (tramp-get-connection-name vec)
+ :buffer (tramp-get-connection-buffer vec)
+ :server t :host 'local :service t :noquery t)))
+ (tramp-post-process-creation p vec)))
+
+ ;; The following operations must be performed without
+ ;; `tramp-crypt-file-name-handler'.
+ (let* (tramp-crypt-enabled
+ ;; Don't check for a proper method.
+ (non-essential t)
+ (remote-config
+ (expand-file-name
+ tramp-crypt-encfs-config (tramp-crypt-get-remote-dir vec)))
+ (local-config (tramp-crypt-config-file-name vec)))
+ ;; There is no local encfs6 config file.
+ (unless (file-exists-p local-config)
+ (if (and tramp-crypt-save-encfs-config-remote
+ (file-exists-p remote-config))
+ ;; Copy remote encfs6 config file if possible.
+ (copy-file remote-config local-config 'ok 'keep)
+
+ ;; Create local encfs6 config file otherwise.
+ (let* ((default-directory tramp-compat-temporary-file-directory)
+ (tmpdir1 (file-name-as-directory
+ (tramp-compat-make-temp-file " .crypt" 'dir-flag)))
+ (tmpdir2 (file-name-as-directory
+ (tramp-compat-make-temp-file " .nocrypt" 'dir-flag))))
+ ;; Enable `auth-source', unless "emacs -Q" has been called.
+ (tramp-set-connection-property
+ vec "first-password-request" tramp-cache-read-persistent-data)
+ (with-temp-buffer
+ (insert
+ (tramp-read-passwd
+ (tramp-get-connection-process vec)
+ (format
+ "New EncFS Password for %s " (tramp-crypt-get-remote-dir vec))))
+ (when
+ (zerop
+ (tramp-call-process-region
+ vec (point-min) (point-max)
+ tramp-crypt-encfs-program nil
+ (tramp-get-connection-buffer vec) nil
+ tramp-crypt-encfs-option "--extpass=cat" tmpdir1 tmpdir2))
+ ;; Save the password.
+ (ignore-errors
+ (and (functionp tramp-password-save-function)
+ (funcall tramp-password-save-function)))))
+
+ ;; Write local config file. Suppress file name IV chaining mode.
+ (with-temp-file local-config
+ (insert-file-contents
+ (expand-file-name tramp-crypt-encfs-config tmpdir1))
+ (when (search-forward
+ "<chainedNameIV>1</chainedNameIV>" nil 'noerror)
+ (replace-match "<chainedNameIV>0</chainedNameIV>")))
+
+ ;; Unmount encfs. Delete temporary directories.
+ (tramp-call-process
+ vec tramp-crypt-encfs-program nil nil nil
+ "--unmount" tmpdir1 tmpdir2)
+ (delete-directory tmpdir1 'recursive)
+ (delete-directory tmpdir2)
+
+ ;; Copy local encfs6 config file to remote.
+ (when tramp-crypt-save-encfs-config-remote
+ (copy-file local-config remote-config 'ok 'keep))))))))
(defun tramp-crypt-send-command (vec &rest args)
"Send encfsctl command to connection VEC.
@@ -499,7 +504,7 @@ directory. File names will be also encrypted."
(tramp-user-error nil "Feature is not enabled"))
(unless (and (tramp-tramp-file-p name) (file-directory-p name))
(tramp-user-error nil "%s must be an existing remote directory" name))
- (when (tramp-compat-file-name-quoted-p name)
+ (when (file-name-quoted-p name)
(tramp-user-error nil "%s must not be quoted" name))
(setq name (file-name-as-directory (expand-file-name name)))
(unless (member name tramp-crypt-directories)
@@ -558,7 +563,7 @@ localname."
(defun tramp-crypt-handle-access-file (filename string)
"Like `access-file' for Tramp files."
(let* ((encrypt-filename (tramp-crypt-encrypt-file-name filename))
- (encrypt-regexp (tramp-compat-rx (literal encrypt-filename) eos))
+ (encrypt-regexp (rx (literal encrypt-filename) eos))
tramp-crypt-enabled)
(condition-case err
(access-file encrypt-filename string)
@@ -691,17 +696,17 @@ absolute file names."
(directory &optional recursive _trash)
"Like `delete-directory' for Tramp files."
(with-parsed-tramp-file-name (expand-file-name directory) nil
- (tramp-flush-directory-properties v localname)
(let (tramp-crypt-enabled)
- (delete-directory (tramp-crypt-encrypt-file-name directory) recursive))))
+ (delete-directory (tramp-crypt-encrypt-file-name directory) recursive))
+ (tramp-flush-directory-properties v localname)))
;; Encrypted files won't be trashed.
(defun tramp-crypt-handle-delete-file (filename &optional _trash)
"Like `delete-file' for Tramp files."
(with-parsed-tramp-file-name (expand-file-name filename) nil
- (tramp-flush-file-properties v localname)
(let (tramp-crypt-enabled)
- (delete-file (tramp-crypt-encrypt-file-name filename)))))
+ (delete-file (tramp-crypt-encrypt-file-name filename)))
+ (tramp-flush-file-properties v localname)))
(defun tramp-crypt-handle-directory-files
(directory &optional full match nosort count)
@@ -711,8 +716,7 @@ absolute file names."
(mapcar
(lambda (x)
(replace-regexp-in-string
- (tramp-compat-rx bos (literal directory)) ""
- (tramp-crypt-decrypt-file-name x)))
+ (rx bos (literal directory)) "" (tramp-crypt-decrypt-file-name x)))
(directory-files (tramp-crypt-encrypt-file-name directory) 'full)))))
(defun tramp-crypt-handle-file-attributes (filename &optional id-format)
@@ -764,9 +768,7 @@ absolute file names."
(defun tramp-crypt-handle-file-system-info (filename)
"Like `file-system-info' for Tramp files."
(let (tramp-crypt-enabled)
- ;; `file-system-info' exists since Emacs 27.1.
- (tramp-compat-funcall
- 'file-system-info (tramp-crypt-encrypt-file-name filename))))
+ (file-system-info (tramp-crypt-encrypt-file-name filename))))
(defun tramp-crypt-handle-file-writable-p (filename)
"Like `file-writable-p' for Tramp files."
@@ -777,27 +779,26 @@ absolute file names."
(filename switches &optional wildcard full-directory-p)
"Like `insert-directory' for Tramp files.
WILDCARD is not supported."
- ;; This package has been added to Emacs 27.1.
- (when (load "text-property-search" 'noerror 'nomessage)
- (let (tramp-crypt-enabled)
- (tramp-handle-insert-directory
- (tramp-crypt-encrypt-file-name filename)
- switches wildcard full-directory-p)
- (let* ((filename (file-name-as-directory filename))
- (enc (tramp-crypt-encrypt-file-name filename))
- match string)
- (goto-char (point-min))
- (while (setq match (text-property-search-forward 'dired-filename t t))
- (setq string
- (buffer-substring
- (prop-match-beginning match) (prop-match-end match))
- string (if (file-name-absolute-p string)
- (tramp-crypt-decrypt-file-name string)
- (substring
- (tramp-crypt-decrypt-file-name (concat enc string))
- (length filename))))
- (delete-region (prop-match-beginning match) (prop-match-end match))
- (insert (propertize string 'dired-filename t)))))))
+ (require 'text-property-search)
+ (let (tramp-crypt-enabled)
+ (tramp-handle-insert-directory
+ (tramp-crypt-encrypt-file-name filename)
+ switches wildcard full-directory-p)
+ (let* ((filename (file-name-as-directory filename))
+ (enc (tramp-crypt-encrypt-file-name filename))
+ match string)
+ (goto-char (point-min))
+ (while (setq match (text-property-search-forward 'dired-filename t t))
+ (setq string
+ (buffer-substring
+ (prop-match-beginning match) (prop-match-end match))
+ string (if (file-name-absolute-p string)
+ (tramp-crypt-decrypt-file-name string)
+ (substring
+ (tramp-crypt-decrypt-file-name (concat enc string))
+ (length filename))))
+ (delete-region (prop-match-beginning match) (prop-match-end match))
+ (insert (propertize string 'dired-filename t))))))
(defun tramp-crypt-handle-lock-file (filename)
"Like `lock-file' for Tramp files."
@@ -808,16 +809,9 @@ WILDCARD is not supported."
(defun tramp-crypt-handle-make-directory (dir &optional parents)
"Like `make-directory' for Tramp files."
- (with-parsed-tramp-file-name (expand-file-name dir) nil
- (when (and (null parents) (file-exists-p dir))
- (tramp-error v 'file-already-exists dir))
+ (tramp-skeleton-make-directory dir parents
(let (tramp-crypt-enabled)
- (make-directory (tramp-crypt-encrypt-file-name dir) parents))
- ;; When PARENTS is non-nil, DIR could be a chain of non-existent
- ;; directories a/b/c/... Instead of checking, we simply flush the
- ;; whole cache.
- (tramp-flush-directory-properties
- v (if parents "/" (file-name-directory localname)))))
+ (make-directory (tramp-crypt-encrypt-file-name dir) parents))))
(defun tramp-crypt-handle-rename-file
(filename newname &optional ok-if-already-exists)
@@ -865,7 +859,8 @@ WILDCARD is not supported."
"Cleanup crypt resources determined by VEC."
(let ((tramp-cleanup-connection-hook
(remove
- #'tramp-crypt-cleanup-connection tramp-cleanup-connection-hook)))
+ #'tramp-crypt-cleanup-connection tramp-cleanup-connection-hook))
+ (tramp-crypt-enabled t))
(dolist (dir tramp-crypt-directories)
(when (tramp-file-name-equal-p vec (tramp-dissect-file-name dir))
(tramp-cleanup-connection (tramp-crypt-dissect-file-name dir))))))
diff --git a/lisp/net/tramp-fuse.el b/lisp/net/tramp-fuse.el
index 47870c05911..3d42948043c 100644
--- a/lisp/net/tramp-fuse.el
+++ b/lisp/net/tramp-fuse.el
@@ -34,15 +34,13 @@
(defun tramp-fuse-handle-delete-directory
(directory &optional recursive trash)
"Like `delete-directory' for Tramp files."
- (with-parsed-tramp-file-name (expand-file-name directory) nil
- (tramp-flush-directory-properties v localname)
+ (tramp-skeleton-delete-directory directory recursive trash
(delete-directory (tramp-fuse-local-file-name directory) recursive trash)))
(defun tramp-fuse-handle-delete-file (filename &optional trash)
"Like `delete-file' for Tramp files."
- (with-parsed-tramp-file-name (expand-file-name filename) nil
- (delete-file (tramp-fuse-local-file-name filename) trash)
- (tramp-flush-file-properties v localname)))
+ (tramp-skeleton-delete-file filename trash
+ (delete-file (tramp-fuse-local-file-name filename) trash)))
(defvar tramp-fuse-remove-hidden-files nil
"Remove hidden files from directory listings.")
@@ -69,15 +67,15 @@
(tramp-fuse-local-file-name directory))))))))
(if full
;; Massage the result.
- (let ((local (tramp-compat-rx
+ (let ((local (rx
bol
(literal
(tramp-fuse-mount-point
(tramp-dissect-file-name directory)))))
(remote (directory-file-name
(funcall
- (if (tramp-compat-file-name-quoted-p directory)
- #'tramp-compat-file-name-quote #'identity)
+ (if (file-name-quoted-p directory)
+ #'file-name-quote #'identity)
(file-remote-p directory)))))
(mapcar
(lambda (x) (replace-regexp-in-string local remote x))
@@ -123,14 +121,8 @@
(defun tramp-fuse-handle-make-directory (dir &optional parents)
"Like `make-directory' for Tramp files."
- (with-parsed-tramp-file-name (expand-file-name dir) nil
- (make-directory (tramp-fuse-local-file-name dir) parents)
- ;; When PARENTS is non-nil, DIR could be a chain of non-existent
- ;; directories a/b/c/... Instead of checking, we simply flush the
- ;; whole file cache.
- (tramp-flush-file-properties v localname)
- (tramp-flush-directory-properties
- v (if parents "/" (file-name-directory localname)))))
+ (tramp-skeleton-make-directory dir parents
+ (make-directory (tramp-fuse-local-file-name dir) parents)))
;; File name helper functions.
@@ -180,16 +172,14 @@ It has the same meaning as `remote-file-name-inhibit-cache'.")
;; mounts of type "memory" or "gdrive". Make it optional.
(setq mount-spec
(if (cdr mount-spec)
- (tramp-compat-rx
- (literal (car mount-spec))
- ":" (? (literal (cadr mount-spec))))
+ (rx (literal (car mount-spec))
+ ":" (? (literal (cadr mount-spec))))
(car mount-spec)))
(tramp-set-file-property
vec "/" "mounted"
(when (string-match
- (tramp-compat-rx
- bol (group (regexp mount-spec))
- " on " (group (+ (not blank))) blank)
+ (rx bol (group (regexp mount-spec))
+ " on " (group (+ (not blank))) blank)
mount)
(tramp-set-file-property
vec "/" "mount-point" (match-string 2 mount))
@@ -222,7 +212,7 @@ It has the same meaning as `remote-file-name-inhibit-cache'.")
(defun tramp-fuse-local-file-name (filename)
"Return local mount name of FILENAME."
- (setq filename (tramp-compat-file-name-unquote (expand-file-name filename)))
+ (setq filename (file-name-unquote (expand-file-name filename)))
(with-parsed-tramp-file-name filename nil
;; As long as we call `tramp-*-maybe-open-connection' here,
;; we cache the result.
@@ -231,10 +221,10 @@ It has the same meaning as `remote-file-name-inhibit-cache'.")
(intern
(format "tramp-%s-maybe-open-connection" (tramp-file-name-method v)))
v)
- (let ((quoted (tramp-compat-file-name-quoted-p localname))
- (localname (tramp-compat-file-name-unquote localname)))
+ (let ((quoted (file-name-quoted-p localname))
+ (localname (file-name-unquote localname)))
(funcall
- (if quoted #'tramp-compat-file-name-quote #'identity)
+ (if quoted #'file-name-quote #'identity)
(expand-file-name
(if (file-name-absolute-p localname)
(substring localname 1) localname)
diff --git a/lisp/net/tramp-gvfs.el b/lisp/net/tramp-gvfs.el
index 2ccba85c238..93071ed7350 100644
--- a/lisp/net/tramp-gvfs.el
+++ b/lisp/net/tramp-gvfs.el
@@ -120,8 +120,6 @@
(defconst tramp-gvfs-enabled
(ignore-errors
(and (featurep 'dbusbind)
- (autoload 'zeroconf-init "zeroconf")
- (tramp-compat-funcall 'dbus-get-unique-name :system)
(tramp-compat-funcall 'dbus-get-unique-name :session)
(or (tramp-process-running-p "gvfs-fuse-daemon")
(tramp-process-running-p "gvfsd-fuse"))))
@@ -211,6 +209,27 @@ They are checked during start up via
tramp-gvfs-interface-mounttracker))
"The list of supported methods of the mount tracking interface.")
+(defconst tramp-gvfs-listmountableinfo
+ (if (member "ListMountableInfo" tramp-gvfs-methods-mounttracker)
+ "ListMountableInfo"
+ "listMountableInfo")
+ "The name of the \"listMountableInfo\" method.
+It has been changed in GVFS 1.14.")
+
+(defconst tramp-gvfs-listmounttypes
+ (if (member "ListMountTypes" tramp-gvfs-methods-mounttracker)
+ "ListMountTypes"
+ "listMountTypes")
+ "The name of the \"listMountTypes\" method.
+It has been changed in GVFS 1.14.")
+
+(defconst tramp-gvfs-mounttypes
+ (and tramp-gvfs-enabled
+ (dbus-call-method
+ :session tramp-gvfs-service-daemon tramp-gvfs-path-mounttracker
+ tramp-gvfs-interface-mounttracker tramp-gvfs-listmounttypes))
+ "The list of supported mount types of the mount tracking interface.")
+
(defconst tramp-gvfs-listmounts
(if (member "ListMounts" tramp-gvfs-methods-mounttracker)
"ListMounts"
@@ -234,6 +253,12 @@ It has been changed in GVFS 1.14.")
It has been changed in GVFS 1.14.")
;; <interface name='org.gtk.vfs.MountTracker'>
+;; <method name='listMountableInfo'>
+;; <arg name='mountables' type='a(ssasib)' direction='out'/>
+;; </method>
+;; <method name='listMountTypes'>
+;; <arg name='mount_types' type='as' direction='out'/>
+;; </method>
;; <method name='listMounts'>
;; <arg name='mount_info_list'
;; type='a{sosssssbay{aya{say}}ay}'
@@ -254,6 +279,13 @@ It has been changed in GVFS 1.14.")
;; </signal>
;; </interface>
;;
+;; STRUCT mountable
+;; STRING type
+;; STRING scheme
+;; ARRAY STRING scheme_aliases
+;; INT32 default_port
+;; BOOLEAN host_is_inet
+;;
;; STRUCT mount_info
;; STRING dbus_id
;; OBJECT_PATH object_path
@@ -415,7 +447,7 @@ It has been changed in GVFS 1.14.")
;; </interface>
(defconst tramp-goa-identity-regexp
- (tramp-compat-rx
+ (rx
bol (? (group (regexp tramp-user-regexp)))
"@" (? (group (regexp tramp-host-regexp)))
(? ":" (group (regexp tramp-port-regexp))))
@@ -717,13 +749,13 @@ It has been changed in GVFS 1.14.")
"GVFS file attributes."))
(defconst tramp-gvfs-file-attributes-with-gvfs-ls-regexp
- (tramp-compat-rx
+ (rx
blank (group (regexp (regexp-opt tramp-gvfs-file-attributes)))
"=" (group (+? nonl)))
"Regexp to parse GVFS file attributes with `gvfs-ls'.")
(defconst tramp-gvfs-file-attributes-with-gvfs-info-regexp
- (tramp-compat-rx
+ (rx
bol (* blank) (group (regexp (regexp-opt tramp-gvfs-file-attributes)))
":" (+ blank) (group (* nonl)) eol)
"Regexp to parse GVFS file attributes with `gvfs-info'.")
@@ -735,7 +767,7 @@ It has been changed in GVFS 1.14.")
"GVFS file system attributes.")
(defconst tramp-gvfs-file-system-attributes-regexp
- (tramp-compat-rx
+ (rx
bol (* blank)
(group (regexp (regexp-opt tramp-gvfs-file-system-attributes)))
":" (+ blank) (group (* nonl)) eol)
@@ -745,7 +777,7 @@ It has been changed in GVFS 1.14.")
"Default prefix for owncloud / nextcloud methods.")
(defconst tramp-gvfs-nextcloud-default-prefix-regexp
- (tramp-compat-rx (literal tramp-gvfs-nextcloud-default-prefix) eol)
+ (rx (literal tramp-gvfs-nextcloud-default-prefix) eol)
"Regexp of default prefix for owncloud / nextcloud methods.")
@@ -776,6 +808,7 @@ It has been changed in GVFS 1.14.")
(file-equal-p . tramp-handle-file-equal-p)
(file-executable-p . tramp-gvfs-handle-file-executable-p)
(file-exists-p . tramp-handle-file-exists-p)
+ (file-group-gid . tramp-handle-file-group-gid)
(file-in-directory-p . tramp-handle-file-in-directory-p)
(file-local-copy . tramp-handle-file-local-copy)
(file-locked-p . tramp-handle-file-locked-p)
@@ -799,6 +832,7 @@ It has been changed in GVFS 1.14.")
(file-symlink-p . tramp-handle-file-symlink-p)
(file-system-info . tramp-gvfs-handle-file-system-info)
(file-truename . tramp-handle-file-truename)
+ (file-user-uid . tramp-handle-file-user-uid)
(file-writable-p . tramp-handle-file-writable-p)
(find-backup-file-name . tramp-handle-find-backup-file-name)
;; `get-file-buffer' performed by default handler.
@@ -854,15 +888,18 @@ Operations not mentioned here will be handled by the default Emacs primitives.")
"Invoke the GVFS related OPERATION and ARGS.
First arg specifies the OPERATION, second arg is a list of
arguments to pass to the OPERATION."
- (unless tramp-gvfs-enabled
+ ;; `file-remote-p' must not return an error. (Bug#68976)
+ (unless (or tramp-gvfs-enabled (eq operation 'file-remote-p))
(tramp-user-error nil "Package `tramp-gvfs' not supported"))
(if-let ((filename (apply #'tramp-file-name-for-operation operation args))
(tramp-gvfs-dbus-event-vector
(and (tramp-tramp-file-p filename)
(tramp-dissect-file-name filename)))
(fn (assoc operation tramp-gvfs-file-name-handler-alist)))
- (save-match-data (apply (cdr fn) args))
- (tramp-run-real-handler operation args)))
+ (prog1 (save-match-data (apply (cdr fn) args))
+ (setq tramp-debug-message-fnh-function (cdr fn)))
+ (prog1 (tramp-run-real-handler operation args)
+ (setq tramp-debug-message-fnh-function operation))))
;;;###tramp-autoload
(when (featurep 'dbusbind)
@@ -915,14 +952,13 @@ Return nil for null BYTE-ARRAY."
(defun tramp-dbus-function (vec func args)
"Apply a D-Bus function FUNC from dbus.el.
The call will be traced by Tramp with trace level 6."
+ (declare (tramp-suppress-trace t))
(let (result)
(tramp-message vec 6 "%s" (cons func args))
(setq result (apply func args))
(tramp-message vec 6 "%s" (tramp-gvfs-stringify-dbus-message result))
result))
-(put #'tramp-dbus-function 'tramp-suppress-trace t)
-
(defmacro with-tramp-dbus-call-method
(vec synchronous bus service path interface method &rest args)
"Apply a D-Bus call on bus BUS.
@@ -945,8 +981,8 @@ or `dbus-call-method-asynchronously'."
(vec bus service path interface)
"Return all properties of INTERFACE.
The call will be traced by Tramp with trace level 6."
- ;; Check, that interface exists at object path. Retrieve properties.
(declare (indent 1) (debug t))
+ ;; Check, that interface exists at object path. Retrieve properties.
`(when (member
,interface
(tramp-dbus-function
@@ -1148,18 +1184,15 @@ file names."
(defun tramp-gvfs-handle-delete-file (filename &optional trash)
"Like `delete-file' for Tramp files."
- (with-parsed-tramp-file-name (expand-file-name filename) nil
- (tramp-flush-file-properties v localname)
- (if (and delete-by-moving-to-trash trash)
- (move-file-to-trash filename)
- (unless (and (tramp-gvfs-send-command
- v "gvfs-rm" (tramp-gvfs-url-file-name filename))
- (not (tramp-gvfs-info filename)))
- ;; Propagate the error.
- (with-current-buffer (tramp-get-connection-buffer v)
- (goto-char (point-min))
- (tramp-error-with-buffer
- nil v 'file-error "Couldn't delete %s" filename))))))
+ (tramp-skeleton-delete-file filename trash
+ (unless (and (tramp-gvfs-send-command
+ v "gvfs-rm" (tramp-gvfs-url-file-name filename))
+ (not (tramp-gvfs-info filename)))
+ ;; Propagate the error.
+ (with-current-buffer (tramp-get-connection-buffer v)
+ (goto-char (point-min))
+ (tramp-error-with-buffer
+ nil v 'file-error "Couldn't delete %s" filename)))))
(defun tramp-gvfs-handle-expand-file-name (name &optional dir)
"Like `expand-file-name' for Tramp files."
@@ -1181,8 +1214,7 @@ file names."
(setq localname (file-name-unquote localname)))
;; If there is a default location, expand tilde.
(when (string-match
- (tramp-compat-rx bos "~" (group (* (not "/"))) (group (* nonl)) eos)
- localname)
+ (rx bos "~" (group (* (not "/"))) (group (* nonl)) eos) localname)
(let ((uname (match-string 1 localname))
(fname (match-string 2 localname))
hname)
@@ -1199,8 +1231,7 @@ file names."
;; We do not pass "/..".
(if (string-match-p (rx bos (| "afp" (: "dav" (? "s")) "smb") eos) method)
(when (string-match
- (tramp-compat-rx bos "/" (+ (not "/")) (group "/.." (? "/")))
- localname)
+ (rx bos "/" (+ (not "/")) (group "/.." (? "/"))) localname)
(setq localname (replace-match "/" t t localname 1)))
(when (string-match (rx bol "/.." (? "/")) localname)
(setq localname (replace-match "/" t t localname))))
@@ -1235,7 +1266,7 @@ file names."
(with-current-buffer (tramp-get-connection-buffer v)
(goto-char (point-min))
(while (looking-at
- (tramp-compat-rx
+ (rx
bol (group (+ nonl)) blank
(group (+ digit)) blank
"(" (group (+? nonl)) ")"
@@ -1245,7 +1276,7 @@ file names."
(cons "name" (match-string 1)))))
(goto-char (1+ (match-end 3)))
(while (looking-at
- (tramp-compat-rx
+ (rx
(regexp tramp-gvfs-file-attributes-with-gvfs-ls-regexp)
(group
(| (regexp
@@ -1282,7 +1313,7 @@ If FILE-SYSTEM is non-nil, return file system attributes."
;; Parse output.
(with-current-buffer (tramp-get-connection-buffer v)
(goto-char (point-min))
- (while (re-search-forward
+ (while (search-forward-regexp
(if file-system
tramp-gvfs-file-system-attributes-regexp
tramp-gvfs-file-attributes-with-gvfs-info-regexp)
@@ -1294,11 +1325,10 @@ If FILE-SYSTEM is non-nil, return file system attributes."
"Return GVFS attributes association list of FILENAME."
(setq filename (directory-file-name (expand-file-name filename)))
(with-parsed-tramp-file-name filename nil
- (setq localname (tramp-compat-file-name-unquote localname))
+ (setq localname (file-name-unquote localname))
(if (or (and (string-match-p
(rx bol (| "afp" (: "dav" (? "s")) "smb") eol) method)
- (string-match-p
- (tramp-compat-rx bol (? "/") (+ (not "/")) eol) localname))
+ (string-match-p (rx bol (? "/") (+ (not "/")) eol) localname))
(string-equal localname "/"))
(tramp-gvfs-get-root-attributes filename)
(assoc
@@ -1464,10 +1494,10 @@ If FILE-SYSTEM is non-nil, return file system attributes."
(cond
((and (memq 'change flags) (memq 'attribute-change flags))
'(created changed changes-done-hint moved deleted
- attribute-changed))
+ attribute-changed unmounted))
((memq 'change flags)
- '(created changed changes-done-hint moved deleted))
- ((memq 'attribute-change flags) '(attribute-changed))))
+ '(created changed changes-done-hint moved deleted unmounted))
+ ((memq 'attribute-change flags) '(attribute-changed unmounted))))
(p (apply
#'start-process
"gvfs-monitor" (generate-new-buffer " *gvfs-monitor*")
@@ -1475,15 +1505,11 @@ If FILE-SYSTEM is non-nil, return file system attributes."
(if (not (processp p))
(tramp-error
v 'file-notify-error "Monitoring not supported for `%s'" file-name)
- (tramp-message
- v 6 "Run `%s', %S" (string-join (process-command p) " ") p)
- (process-put p 'tramp-vector v)
(process-put p 'tramp-events events)
(process-put p 'tramp-watch-name localname)
- (process-put p 'adjust-window-size-function #'ignore)
- (set-process-query-on-exit-flag p nil)
(set-process-filter p #'tramp-gvfs-monitor-process-filter)
(set-process-sentinel p #'tramp-file-notify-process-sentinel)
+ (tramp-post-process-creation p v)
;; There might be an error if the monitor is not supported.
;; Give the filter a chance to read the output.
(while (tramp-accept-process-output p))
@@ -1501,7 +1527,7 @@ If FILE-SYSTEM is non-nil, return file system attributes."
(let* ((events (process-get proc 'tramp-events))
(rest-string (process-get proc 'tramp-rest-string))
(dd (tramp-get-default-directory (process-buffer proc)))
- (ddu (tramp-compat-rx (literal (tramp-gvfs-url-file-name dd)))))
+ (ddu (rx (literal (tramp-gvfs-url-file-name dd)))))
(when rest-string
(tramp-message proc 10 "Previous string:\n%s" rest-string))
(tramp-message proc 6 "%S\n%s" proc string)
@@ -1520,7 +1546,7 @@ If FILE-SYSTEM is non-nil, return file system attributes."
(delete-process proc))
(while (string-match
- (tramp-compat-rx
+ (rx
bol (+ nonl) ":"
blank (group (+ nonl)) ":"
blank (group (regexp (regexp-opt tramp-gio-events)))
@@ -1576,27 +1602,13 @@ If FILE-SYSTEM is non-nil, return file system attributes."
(defun tramp-gvfs-handle-make-directory (dir &optional parents)
"Like `make-directory' for Tramp files."
- (setq dir (directory-file-name (expand-file-name dir)))
- (with-parsed-tramp-file-name dir nil
- (when (and (null parents) (file-exists-p dir))
- (tramp-error v 'file-already-exists dir))
- (tramp-flush-directory-properties v localname)
+ (tramp-skeleton-make-directory dir parents
(save-match-data
- (let ((ldir (file-name-directory dir)))
- ;; Make missing directory parts. "gvfs-mkdir -p ..." does not
- ;; work robust.
- (when (and parents (not (file-directory-p ldir)))
- (make-directory ldir parents))
- ;; Just do it.
- (or (when-let ((mkdir-succeeded
- (and
- (tramp-gvfs-send-command
- v "gvfs-mkdir" (tramp-gvfs-url-file-name dir))
- (tramp-gvfs-info dir))))
- (set-file-modes dir (default-file-modes))
- mkdir-succeeded)
- (and parents (file-directory-p dir))
- (tramp-error v 'file-error "Couldn't make directory %s" dir))))))
+ (if (and (tramp-gvfs-send-command
+ v "gvfs-mkdir" (tramp-gvfs-url-file-name dir))
+ (tramp-gvfs-info dir))
+ (set-file-modes dir (default-file-modes))
+ (tramp-error v 'file-error "Couldn't make directory %s" dir)))))
(defun tramp-gvfs-handle-rename-file
(filename newname &optional ok-if-already-exists)
@@ -1637,12 +1649,7 @@ If FILE-SYSTEM is non-nil, return file system attributes."
(tramp-gvfs-set-attribute
v (if (eq flag 'nofollow) "-nt" "-t") "uint64"
(tramp-gvfs-url-file-name filename) "time::modified"
- (format-time-string
- "%s" (if (or (null time)
- (tramp-compat-time-equal-p time tramp-time-doesnt-exist)
- (tramp-compat-time-equal-p time tramp-time-dont-know))
- nil
- time)))))
+ (format-time-string "%s" (tramp-defined-time time)))))
(defun tramp-gvfs-handle-get-home-directory (vec &optional _user)
"The remote home directory for connection VEC as local file name.
@@ -1735,7 +1742,7 @@ ID-FORMAT valid values are `string' and `integer'."
(defun tramp-gvfs-url-file-name (filename)
"Return FILENAME in URL syntax."
- (setq filename (tramp-compat-file-name-unquote filename))
+ (setq filename (file-name-unquote filename))
(let* (;; "/" must NOT be hexified.
(url-unreserved-chars (cons ?/ url-unreserved-chars))
(result
@@ -1755,8 +1762,7 @@ ID-FORMAT valid values are `string' and `integer'."
"Retrieve file name from D-Bus OBJECT-PATH."
(dbus-unescape-from-identifier
(replace-regexp-in-string
- (tramp-compat-rx bol (* nonl) "/" (group (+ (not "/"))) eol) "\\1"
- object-path)))
+ (rx bol (* nonl) "/" (group (+ (not "/"))) eol) "\\1" object-path)))
(defun tramp-gvfs-url-host (url)
"Return the host name part of URL, a string.
@@ -2032,7 +2038,7 @@ Their full names are \"org.gtk.vfs.MountTracker.mounted\" and
(string-equal host (tramp-file-name-host vec))
(string-equal port (tramp-file-name-port vec))
(string-match-p
- (tramp-compat-rx bol "/" (literal (or share "")))
+ (rx bol "/" (literal (or share "")))
(tramp-file-name-unquote-localname vec)))
;; Set mountpoint and location.
(tramp-set-file-property vec "/" "fuse-mountpoint" fuse-mountpoint)
@@ -2077,8 +2083,7 @@ It was \"a(say)\", but has changed to \"a{sv})\"."
(tramp-media-device-port media) (tramp-file-name-port vec)))
(localname (tramp-file-name-unquote-localname vec))
(share (when (string-match
- (tramp-compat-rx bol (? "/") (group (+ (not "/"))))
- localname)
+ (rx bol (? "/") (group (+ (not "/")))) localname)
(match-string 1 localname)))
(ssl (if (string-match-p (rx bol (| "davs" "nextcloud")) method)
"true" "false"))
@@ -2121,8 +2126,7 @@ It was \"a(say)\", but has changed to \"a{sv})\"."
(list (tramp-gvfs-mount-spec-entry "port" port)))))
(mount-pref
(if (and (string-match-p (rx bol "dav") method)
- (string-match
- (tramp-compat-rx bol (? "/") (+ (not "/"))) localname))
+ (string-match (rx bol (? "/") (+ (not "/"))) localname))
(match-string 0 localname)
(tramp-gvfs-get-remote-prefix vec))))
@@ -2183,125 +2187,139 @@ connection if a previous connection has died for some reason."
(unless (tramp-connectable-p vec)
(throw 'non-essential 'non-essential))
- ;; For password handling, we need a process bound to the connection
- ;; buffer. Therefore, we create a dummy process. Maybe there is a
- ;; better solution?
- (unless (get-buffer-process (tramp-get-connection-buffer vec))
- (let ((p (make-network-process
- :name (tramp-get-connection-name vec)
- :buffer (tramp-get-connection-buffer vec)
- :server t :host 'local :service t :noquery t)))
- (process-put p 'tramp-vector vec)
- (set-process-query-on-exit-flag p nil)
-
- ;; Set connection-local variables.
- (tramp-set-connection-local-variables vec)))
-
- (unless (tramp-gvfs-connection-mounted-p vec)
- (let ((method (tramp-file-name-method vec))
- (user (tramp-file-name-user vec))
- (host (tramp-file-name-host vec))
- (localname (tramp-file-name-unquote-localname vec))
- (object-path
- (tramp-gvfs-object-path (tramp-make-tramp-file-name vec 'noloc))))
-
- (when (and (string-equal method "afp")
- (string-equal localname "/"))
- (tramp-user-error vec "Filename must contain an AFP volume"))
-
- (when (and (string-match-p (rx "dav" (? "s")) method)
- (string-equal localname "/"))
- (tramp-user-error vec "Filename must contain a WebDAV share"))
-
- (when (and (string-equal method "smb")
- (string-equal localname "/"))
- (tramp-user-error vec "Filename must contain a Windows share"))
-
- (when (member method tramp-goa-methods)
- ;; Ensure that GNOME Online Accounts are cached.
- (tramp-get-goa-accounts vec)
- (when (tramp-get-connection-property
- (tramp-get-goa-account vec) "FilesDisabled" t)
- (tramp-user-error
- vec "There is no Online Account `%s'"
- (tramp-make-tramp-file-name vec 'noloc))))
-
- (with-tramp-progress-reporter
- vec 3
- (if (tramp-string-empty-or-nil-p user)
- (format "Opening connection for %s using %s" host method)
- (format "Opening connection for %s@%s using %s" user host method))
-
- ;; Enable `auth-source'.
- (tramp-set-connection-property
- vec "first-password-request" tramp-cache-read-persistent-data)
-
- ;; There will be a callback of "askPassword" when a password is needed.
- (dbus-register-method
- :session dbus-service-emacs object-path
- tramp-gvfs-interface-mountoperation "askPassword"
- #'tramp-gvfs-handler-askpassword)
- (dbus-register-method
- :session dbus-service-emacs object-path
- tramp-gvfs-interface-mountoperation "AskPassword"
- #'tramp-gvfs-handler-askpassword)
-
- ;; There could be a callback of "askQuestion" when adding
- ;; fingerprints or checking certificates.
- (dbus-register-method
- :session dbus-service-emacs object-path
- tramp-gvfs-interface-mountoperation "askQuestion"
- #'tramp-gvfs-handler-askquestion)
- (dbus-register-method
- :session dbus-service-emacs object-path
- tramp-gvfs-interface-mountoperation "AskQuestion"
- #'tramp-gvfs-handler-askquestion)
-
- ;; The call must be asynchronously, because of the "askPassword"
- ;; or "askQuestion" callbacks.
- (if (string-match-p (rx "(so)" eol) tramp-gvfs-mountlocation-signature)
+ (with-tramp-debug-message vec "Opening connection"
+ ;; Sanity check.
+ (let ((method (tramp-file-name-method vec)))
+ (unless (member
+ (or (assoc-default
+ method '(("smb" . "smb-share")
+ ("davs" . "dav")
+ ("nextcloud" . "dav")
+ ("afp". "afp-volume")
+ ("gdrive" . "google-drive")))
+ method)
+ tramp-gvfs-mounttypes)
+ (tramp-error
+ vec 'file-error "Method `%s' not supported by GVFS" method)))
+
+ ;; For password handling, we need a process bound to the
+ ;; connection buffer. Therefore, we create a dummy process.
+ ;; Maybe there is a better solution?
+ (unless (get-buffer-process (tramp-get-connection-buffer vec))
+ (let ((p (make-network-process
+ :name (tramp-get-connection-name vec)
+ :buffer (tramp-get-connection-buffer vec)
+ :server t :host 'local :service t :noquery t)))
+ (tramp-post-process-creation p vec)
+
+ ;; Set connection-local variables.
+ (tramp-set-connection-local-variables vec)))
+
+ (unless (tramp-gvfs-connection-mounted-p vec)
+ (let ((method (tramp-file-name-method vec))
+ (user (tramp-file-name-user vec))
+ (host (tramp-file-name-host vec))
+ (localname (tramp-file-name-unquote-localname vec))
+ (object-path
+ (tramp-gvfs-object-path (tramp-make-tramp-file-name vec 'noloc))))
+
+ (when (and (string-equal method "afp")
+ (string-equal localname "/"))
+ (tramp-user-error vec "Filename must contain an AFP volume"))
+
+ (when (and (string-match-p (rx "dav" (? "s")) method)
+ (string-equal localname "/"))
+ (tramp-user-error vec "Filename must contain a WebDAV share"))
+
+ (when (and (string-equal method "smb")
+ (string-equal localname "/"))
+ (tramp-user-error vec "Filename must contain a Windows share"))
+
+ (when (member method tramp-goa-methods)
+ ;; Ensure that GNOME Online Accounts are cached.
+ (tramp-get-goa-accounts vec)
+ (when (tramp-get-connection-property
+ (tramp-get-goa-account vec) "FilesDisabled" t)
+ (tramp-user-error
+ vec "There is no Online Account `%s'"
+ (tramp-make-tramp-file-name vec 'noloc))))
+
+ (with-tramp-progress-reporter
+ vec 3
+ (if (tramp-string-empty-or-nil-p user)
+ (format "Opening connection for %s using %s" host method)
+ (format "Opening connection for %s@%s using %s" user host method))
+
+ ;; Enable `auth-source'.
+ (tramp-set-connection-property
+ vec "first-password-request" tramp-cache-read-persistent-data)
+
+ ;; There will be a callback of "askPassword" when a password is needed.
+ (dbus-register-method
+ :session dbus-service-emacs object-path
+ tramp-gvfs-interface-mountoperation "askPassword"
+ #'tramp-gvfs-handler-askpassword)
+ (dbus-register-method
+ :session dbus-service-emacs object-path
+ tramp-gvfs-interface-mountoperation "AskPassword"
+ #'tramp-gvfs-handler-askpassword)
+
+ ;; There could be a callback of "askQuestion" when adding
+ ;; fingerprints or checking certificates.
+ (dbus-register-method
+ :session dbus-service-emacs object-path
+ tramp-gvfs-interface-mountoperation "askQuestion"
+ #'tramp-gvfs-handler-askquestion)
+ (dbus-register-method
+ :session dbus-service-emacs object-path
+ tramp-gvfs-interface-mountoperation "AskQuestion"
+ #'tramp-gvfs-handler-askquestion)
+
+ ;; The call must be asynchronously, because of the
+ ;; "askPassword" or "askQuestion" callbacks.
+ (if (string-match-p (rx "(so)" eol) tramp-gvfs-mountlocation-signature)
+ (with-tramp-dbus-call-method vec nil
+ :session tramp-gvfs-service-daemon tramp-gvfs-path-mounttracker
+ tramp-gvfs-interface-mounttracker tramp-gvfs-mountlocation
+ (tramp-gvfs-mount-spec vec)
+ `(:struct :string ,(dbus-get-unique-name :session)
+ :object-path ,object-path))
(with-tramp-dbus-call-method vec nil
:session tramp-gvfs-service-daemon tramp-gvfs-path-mounttracker
tramp-gvfs-interface-mounttracker tramp-gvfs-mountlocation
(tramp-gvfs-mount-spec vec)
- `(:struct :string ,(dbus-get-unique-name :session)
- :object-path ,object-path))
- (with-tramp-dbus-call-method vec nil
- :session tramp-gvfs-service-daemon tramp-gvfs-path-mounttracker
- tramp-gvfs-interface-mounttracker tramp-gvfs-mountlocation
- (tramp-gvfs-mount-spec vec)
- :string (dbus-get-unique-name :session) :object-path object-path))
-
- ;; We must wait, until the mount is applied. This will be
- ;; indicated by the "mounted" signal, i.e. the "fuse-mountpoint"
- ;; file property.
- (with-timeout
- ((or (tramp-get-method-parameter vec 'tramp-connection-timeout)
- tramp-connection-timeout)
- (if (tramp-string-empty-or-nil-p (tramp-file-name-user vec))
+ :string (dbus-get-unique-name :session) :object-path object-path))
+
+ ;; We must wait, until the mount is applied. This will be
+ ;; indicated by the "mounted" signal, i.e. the
+ ;; "fuse-mountpoint" file property.
+ (with-timeout
+ ((tramp-get-method-parameter
+ vec 'tramp-connection-timeout tramp-connection-timeout)
+ (if (tramp-string-empty-or-nil-p (tramp-file-name-user vec))
+ (tramp-error
+ vec 'file-error
+ "Timeout reached mounting %s using %s" host method)
(tramp-error
vec 'file-error
- "Timeout reached mounting %s using %s" host method)
- (tramp-error
- vec 'file-error
- "Timeout reached mounting %s@%s using %s" user host method)))
- (while (not (tramp-get-file-property vec "/" "fuse-mountpoint"))
- (read-event nil nil 0.1)))
-
- ;; If `tramp-gvfs-handler-askquestion' has returned "No", it
- ;; is marked with the fuse-mountpoint "/". We shall react.
- (when (string-equal
- (tramp-get-file-property vec "/" "fuse-mountpoint" "") "/")
- (tramp-error vec 'file-error "FUSE mount denied"))
-
- ;; Save the password.
- (ignore-errors
- (and (functionp tramp-password-save-function)
- (funcall tramp-password-save-function)))
+ "Timeout reached mounting %s@%s using %s" user host method)))
+ (while (not (tramp-get-file-property vec "/" "fuse-mountpoint"))
+ (read-event nil nil 0.1)))
- ;; Mark it as connected.
- (tramp-set-connection-property
- (tramp-get-connection-process vec) "connected" t)))))
+ ;; If `tramp-gvfs-handler-askquestion' has returned "No", it
+ ;; is marked with the fuse-mountpoint "/". We shall react.
+ (when (string-equal
+ (tramp-get-file-property vec "/" "fuse-mountpoint" "") "/")
+ (tramp-error vec 'file-error "FUSE mount denied"))
+
+ ;; Save the password.
+ (ignore-errors
+ (and (functionp tramp-password-save-function)
+ (funcall tramp-password-save-function)))
+
+ ;; Mark it as connected.
+ (tramp-set-connection-property
+ (tramp-get-connection-process vec) "connected" t))))))
(defun tramp-gvfs-gio-tool-p (vec)
"Check, whether the gio tool is available."
@@ -2523,50 +2541,49 @@ This uses \"avahi-browse\" in case D-Bus is not enabled in Avahi."
result))))
(when tramp-gvfs-enabled
- (with-no-warnings ;; max-specpdl-size
;; Suppress D-Bus error messages and Tramp traces.
- (let (;; Sometimes, it fails with "Variable binding depth exceeds
- ;; max-specpdl-size". Shall be fixed in Emacs 27.
- (max-specpdl-size (* 2 max-specpdl-size))
- (tramp-verbose 0)
+ (let ((tramp-verbose 0)
tramp-gvfs-dbus-event-vector fun)
- ;; Add completion functions for services announced by DNS-SD.
- ;; See <http://www.dns-sd.org/ServiceTypes.html> for valid service types.
- (zeroconf-init tramp-gvfs-zeroconf-domain)
- (when (setq fun (or (and (zeroconf-list-service-types)
- #'tramp-zeroconf-parse-device-names)
- (and (executable-find "avahi-browse")
- #'tramp-gvfs-parse-device-names)))
- (when (member "afp" tramp-gvfs-methods)
- (tramp-set-completion-function
- "afp" `((,fun "_afpovertcp._tcp"))))
- (when (member "dav" tramp-gvfs-methods)
- (tramp-set-completion-function
- "dav" `((,fun "_webdav._tcp")
- (,fun "_webdavs._tcp"))))
- (when (member "davs" tramp-gvfs-methods)
- (tramp-set-completion-function
- "davs" `((,fun "_webdav._tcp")
- (,fun "_webdavs._tcp"))))
- (when (member "ftp" tramp-gvfs-methods)
- (tramp-set-completion-function
- "ftp" `((,fun "_ftp._tcp"))))
- (when (member "http" tramp-gvfs-methods)
- (tramp-set-completion-function
- "http" `((,fun "_http._tcp")
- (,fun "_https._tcp"))))
- (when (member "https" tramp-gvfs-methods)
- (tramp-set-completion-function
- "https" `((,fun "_http._tcp")
- (,fun "_https._tcp"))))
- (when (member "sftp" tramp-gvfs-methods)
- (tramp-set-completion-function
- "sftp" `((,fun "_sftp-ssh._tcp")
- (,fun "_ssh._tcp")
- (,fun "_workstation._tcp"))))
- (when (member "smb" tramp-gvfs-methods)
- (tramp-set-completion-function
- "smb" `((,fun "_smb._tcp")))))
+ (when (and (autoload 'zeroconf-init "zeroconf")
+ (ignore-error dbus-error
+ (tramp-compat-funcall 'dbus-get-unique-name :system)))
+ ;; Add completion functions for services announced by DNS-SD.
+ ;; See <http://www.dns-sd.org/ServiceTypes.html> for valid service types.
+ (zeroconf-init tramp-gvfs-zeroconf-domain)
+ (when (setq fun (or (and (zeroconf-list-service-types)
+ #'tramp-zeroconf-parse-device-names)
+ (and (executable-find "avahi-browse")
+ #'tramp-gvfs-parse-device-names)))
+ (when (member "afp" tramp-gvfs-methods)
+ (tramp-set-completion-function
+ "afp" `((,fun "_afpovertcp._tcp"))))
+ (when (member "dav" tramp-gvfs-methods)
+ (tramp-set-completion-function
+ "dav" `((,fun "_webdav._tcp")
+ (,fun "_webdavs._tcp"))))
+ (when (member "davs" tramp-gvfs-methods)
+ (tramp-set-completion-function
+ "davs" `((,fun "_webdav._tcp")
+ (,fun "_webdavs._tcp"))))
+ (when (member "ftp" tramp-gvfs-methods)
+ (tramp-set-completion-function
+ "ftp" `((,fun "_ftp._tcp"))))
+ (when (member "http" tramp-gvfs-methods)
+ (tramp-set-completion-function
+ "http" `((,fun "_http._tcp")
+ (,fun "_https._tcp"))))
+ (when (member "https" tramp-gvfs-methods)
+ (tramp-set-completion-function
+ "https" `((,fun "_http._tcp")
+ (,fun "_https._tcp"))))
+ (when (member "sftp" tramp-gvfs-methods)
+ (tramp-set-completion-function
+ "sftp" `((,fun "_sftp-ssh._tcp")
+ (,fun "_ssh._tcp")
+ (,fun "_workstation._tcp"))))
+ (when (member "smb" tramp-gvfs-methods)
+ (tramp-set-completion-function
+ "smb" `((,fun "_smb._tcp"))))))
;; Add completion functions for GNOME Online Accounts.
(tramp-get-goa-accounts nil)
@@ -2581,7 +2598,7 @@ This uses \"avahi-browse\" in case D-Bus is not enabled in Avahi."
"mtp"
(mapcar
(lambda (method) `(tramp-parse-media-names ,(format "_%s._tcp" method)))
- tramp-media-methods)))))
+ tramp-media-methods))))
(add-hook 'tramp-unload-hook
(lambda ()
@@ -2596,9 +2613,9 @@ This uses \"avahi-browse\" in case D-Bus is not enabled in Avahi."
;; * Host name completion for existing mount points (afp-server,
;; smb-server) or via smb-network or network.
;;
+;; * What's up with the other types in `tramp-gvfs-mounttypes'?
+;;
;; * Check, how two shares of the same SMB server can be mounted in
;; parallel.
-;;
-;; * What's up with ftps dns-sd afc admin computer?
;;; tramp-gvfs.el ends here
diff --git a/lisp/net/tramp-integration.el b/lisp/net/tramp-integration.el
index 2738429c88b..e1f0b2a3495 100644
--- a/lisp/net/tramp-integration.el
+++ b/lisp/net/tramp-integration.el
@@ -42,9 +42,10 @@
(declare-function shortdoc-add-function "shortdoc")
(declare-function tramp-dissect-file-name "tramp")
(declare-function tramp-file-name-equal-p "tramp")
-(declare-function tramp-tramp-file-p "tramp")
(declare-function tramp-rename-files "tramp-cmds")
(declare-function tramp-rename-these-files "tramp-cmds")
+(declare-function tramp-set-connection-local-variables-for-buffer "tramp")
+(declare-function tramp-tramp-file-p "tramp")
(defvar eshell-path-env)
(defvar ido-read-file-name-non-ido)
(defvar info-lookup-alist)
@@ -53,7 +54,7 @@
(defvar shortdoc--groups)
(defvar tramp-current-connection)
(defvar tramp-postfix-host-format)
-(defvar tramp-use-ssh-controlmaster-options)
+(defvar tramp-use-connection-share)
;;; Fontification of `read-file-name':
@@ -64,10 +65,11 @@
"Set up a minibuffer for `file-name-shadow-mode'.
Adds another overlay hiding filename parts according to Tramp's
special handling of `substitute-in-file-name'."
+ (declare (tramp-suppress-trace t))
(when minibuffer-completing-file-name
(setq tramp-rfn-eshadow-overlay
(make-overlay (minibuffer-prompt-end) (minibuffer-prompt-end)))
- ;; Copy rfn-eshadow-overlay properties.
+ ;; Copy `rfn-eshadow-overlay' properties.
(let ((props (overlay-properties rfn-eshadow-overlay)))
(while props
;; The `field' property prevents correct minibuffer
@@ -85,6 +87,7 @@ special handling of `substitute-in-file-name'."
(defun tramp-rfn-eshadow-update-overlay-regexp ()
"An overlay covering the shadowed part of the filename."
+ (declare (tramp-suppress-trace t))
(rx-to-string
`(: (* (not (any ,tramp-postfix-host-format "/~"))) (| "/" "~"))))
@@ -93,6 +96,7 @@ special handling of `substitute-in-file-name'."
This is intended to be used as a minibuffer `post-command-hook' for
`file-name-shadow-mode'; the minibuffer should have already
been set up by `rfn-eshadow-setup-minibuffer'."
+ (declare (tramp-suppress-trace t))
;; In remote files name, there is a shadowing just for the local part.
(ignore-errors
(let ((end (or (overlay-end rfn-eshadow-overlay)
@@ -132,9 +136,8 @@ been set up by `rfn-eshadow-setup-minibuffer'."
;; Remove last element of `(exec-path)', which is `exec-directory'.
;; Use `path-separator' as it does eshell.
(setq eshell-path-env
- (if (file-remote-p default-directory)
- (mapconcat
- #'identity (butlast (tramp-compat-exec-path)) path-separator)
+ (if (tramp-tramp-file-p default-directory)
+ (string-join (butlast (exec-path)) path-separator)
(getenv "PATH"))))
(with-eval-after-load 'esh-util
@@ -155,7 +158,7 @@ been set up by `rfn-eshadow-setup-minibuffer'."
(defun tramp-recentf-exclude-predicate (name)
"Predicate to exclude a remote file name from recentf.
NAME must be equal to `tramp-current-connection'."
- (when (file-remote-p name)
+ (when (tramp-tramp-file-p name)
(tramp-file-name-equal-p
(tramp-dissect-file-name name) (car tramp-current-connection))))
@@ -303,7 +306,7 @@ NAME must be equal to `tramp-current-connection'."
;; Bug#45518. So we don't use ssh ControlMaster options.
(defun tramp-compile-disable-ssh-controlmaster-options ()
"Don't allow ssh ControlMaster while compiling."
- (setq-local tramp-use-ssh-controlmaster-options nil))
+ (setq-local tramp-use-connection-share 'suppress))
(with-eval-after-load 'compile
(add-hook 'compilation-mode-hook
@@ -346,8 +349,7 @@ NAME must be equal to `tramp-current-connection'."
(defconst tramp-bsd-process-attributes-ps-args
`("-acxww"
"-o"
- ,(mapconcat
- #'identity
+ ,(string-join
'("pid"
"euid"
"user"
@@ -356,8 +358,7 @@ NAME must be equal to `tramp-current-connection'."
"comm=abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ")
",")
"-o"
- ,(mapconcat
- #'identity
+ ,(string-join
'("state"
"ppid"
"pgid"
@@ -420,8 +421,7 @@ See `tramp-process-attributes-ps-format'.")
;; Tested with BusyBox v1.24.1.
(defconst tramp-busybox-process-attributes-ps-args
`("-o"
- ,(mapconcat
- #'identity
+ ,(string-join
'("pid"
"user"
"group"
@@ -429,8 +429,7 @@ See `tramp-process-attributes-ps-format'.")
",")
"-o" "stat=abcde"
"-o"
- ,(mapconcat
- #'identity
+ ,(string-join
'("ppid"
"pgid"
"tty"
@@ -473,8 +472,7 @@ See `tramp-process-attributes-ps-format'.")
(defconst tramp-darwin-process-attributes-ps-args
`("-acxww"
"-o"
- ,(mapconcat
- #'identity
+ ,(string-join
'("pid"
"uid"
"user"
@@ -483,8 +481,7 @@ See `tramp-process-attributes-ps-format'.")
",")
"-o" "state=abcde"
"-o"
- ,(mapconcat
- #'identity
+ ,(string-join
'("ppid"
"pgid"
"sess"
@@ -556,6 +553,14 @@ See `tramp-process-attributes-ps-format'.")
'(:application tramp :machine "localhost")
local-profile))
+;; Set connection-local variables for buffers visiting a file.
+
+(add-hook 'find-file-hook #'tramp-set-connection-local-variables-for-buffer -50)
+(add-hook 'tramp-unload-hook
+ (lambda ()
+ (remove-hook
+ 'find-file-hook #'tramp-set-connection-local-variables-for-buffer)))
+
(add-hook 'tramp-unload-hook
(lambda () (unload-feature 'tramp-integration 'force)))
diff --git a/lisp/net/tramp-message.el b/lisp/net/tramp-message.el
new file mode 100644
index 00000000000..97e94a51e7a
--- /dev/null
+++ b/lisp/net/tramp-message.el
@@ -0,0 +1,587 @@
+;;; tramp-message.el --- Tramp messages -*- lexical-binding:t -*-
+
+;; Copyright (C) 2023-2024 Free Software Foundation, Inc.
+
+;; Author: Michael Albinus <michael.albinus@gmx.de>
+;; Keywords: comm, processes
+;; Package: tramp
+
+;; This file is part of GNU Emacs.
+
+;; GNU Emacs is free software: you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+
+;; GNU Emacs is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>.
+
+;;; Commentary:
+
+;; This package collects all Tramp functions to trace. This is driven
+;; by the user option `tramp-verbose'. The following buffers are
+;; created:
+;;
+;; - *debug tramp/method user@host*
+;;
+;; This buffer is created when `tramp-verbose' is greater than or
+;; equal 4. It contains all messages with a level up to `tramp-verbose'.
+;;
+;; When `tramp-debug-command-messages' is non-nil, the buffer
+;; contains all messages with level 6 and the entry/exit messages of
+;; `tramp-file-name-handler'. This is intended to analyze which
+;; remote commands are sent for a given file name operation.
+;;
+;; - *trace tramp/method user@host*
+;;
+;; This buffer is created by the trace.el package when
+;; `tramp-verbose' is is greater than or equal 11. It traces all
+;; functions with suffix "tramp-" except those function with the
+;; property `tramp-suppress-trace'.
+
+;;; Code:
+
+(require 'tramp-compat)
+(require 'help-mode)
+
+(declare-function tramp-file-name-equal-p "tramp")
+(declare-function tramp-file-name-host-port "tramp")
+(declare-function tramp-file-name-user-domain "tramp")
+(declare-function tramp-get-default-directory "tramp")
+
+;;;###tramp-autoload
+(defcustom tramp-verbose 3
+ "Verbosity level for Tramp messages.
+Any level x includes messages for all levels 1 .. x-1. The levels are
+
+ 0 silent (no tramp messages at all)
+ 1 errors
+ 2 warnings
+ 3 connection to remote hosts (default level)
+ 4 activities
+ 5 internal
+ 6 sent and received strings
+ 7 connection properties
+ 8 file caching
+ 9 test commands
+10 traces (huge)
+11 call traces (maintainer only)."
+ :group 'tramp
+ :type 'integer)
+
+(defcustom tramp-debug-to-file nil
+ "Whether Tramp debug messages shall be saved to file.
+The debug file has the same name as the debug buffer, written to
+`tramp-compat-temporary-file-directory'."
+ :group 'tramp
+ :version "28.1"
+ :type 'boolean)
+
+(defcustom tramp-debug-command-messages nil
+ "Whether to write only command messages to the debug buffer.
+This increases `tramp-verbose' to 6 if necessary."
+ :group 'tramp
+ :version "30.1"
+ :type 'boolean)
+
+(defconst tramp-debug-outline-regexp
+ (rx ;; Timestamp.
+ (+ digit) ":" (+ digit) ":" (+ digit) "." (+ digit) blank
+ ;; Thread.
+ (? (group "#<thread " (+ nonl) ">") blank)
+ ;; Function name, verbosity.
+ (group (+ (any "-" alnum))) " (" (group (+ digit)) ") #")
+ "Used for highlighting Tramp debug buffers in `outline-mode'.
+When it is used for regexp matching, the regexp groups are
+
+ 1 for the thread name (optional)
+ 2 for the function name
+ 3 for the verbosity level.")
+
+(defconst tramp-debug-font-lock-keywords
+ ;; FIXME: Make it a function instead of an ELisp expression, so you
+ ;; can evaluate it with `funcall' rather than `eval'!
+ ;; Also, in `font-lock-defaults' you can specify a function name for
+ ;; the "KEYWORDS" part, so font-lock calls it to get the actual keywords!
+ '(list
+ (rx bol (regexp tramp-debug-outline-regexp) (+ nonl))
+ '(1 font-lock-warning-face t t)
+ '(0 (outline-font-lock-face) keep t))
+ "Used for highlighting Tramp debug buffers in `outline-mode'.")
+
+(defun tramp-debug-outline-level ()
+ "Return the depth to which a statement is nested in the outline.
+Point must be at the beginning of a header line.
+
+The outline level is equal to the verbosity of the Tramp message."
+ (declare (tramp-suppress-trace t))
+ (1+ (string-to-number (match-string 3))))
+
+;; This function takes action since Emacs 28.1, when
+;; `read-extended-command-predicate' is set to
+;; `command-completion-default-include-p'.
+(defun tramp-debug-buffer-command-completion-p (_symbol buffer)
+ "A predicate for Tramp interactive commands.
+They are completed by \"M-x TAB\" only in Tramp debug buffers."
+ (declare (tramp-suppress-trace t))
+ (with-current-buffer buffer
+ (string-equal
+ (buffer-substring (point-min) (min (+ (point-min) 10) (point-max)))
+ ";; Emacs:")))
+
+(defun tramp-setup-debug-buffer ()
+ "Function to setup debug buffers."
+ (declare (tramp-suppress-trace t))
+ ;; (declare (completion tramp-debug-buffer-command-completion-p)
+ ;; (tramp-suppress-trace t))
+ (interactive)
+ (set-buffer-file-coding-system 'utf-8)
+ (setq buffer-undo-list t)
+ ;; Activate `outline-mode'. This runs `text-mode-hook' and
+ ;; `outline-mode-hook'. We must prevent that local processes die.
+ ;; Yes: I've seen `flyspell-mode', which starts "ispell".
+ ;; `(custom-declare-variable outline-minor-mode-prefix ...)' raises
+ ;; on error in `(outline-mode)', we don't want to see it in the
+ ;; traces.
+ (let ((default-directory tramp-compat-temporary-file-directory))
+ (outline-mode))
+ (setq-local outline-level 'tramp-debug-outline-level)
+ (setq-local font-lock-keywords
+ ;; FIXME: This `(t FOO . BAR)' representation in
+ ;; `font-lock-keywords' is supposed to be an internal
+ ;; implementation "detail". Don't abuse it here!
+ `(t (eval ,tramp-debug-font-lock-keywords t)
+ ,(eval tramp-debug-font-lock-keywords t)))
+ ;; Do not edit the debug buffer.
+ (use-local-map special-mode-map)
+ (set-buffer-modified-p nil)
+ ;; For debugging purposes.
+ (local-set-key "\M-n" 'clone-buffer)
+ (add-hook 'clone-buffer-hook #'tramp-setup-debug-buffer nil 'local))
+
+(function-put
+ #'tramp-setup-debug-buffer 'completion-predicate
+ #'tramp-debug-buffer-command-completion-p)
+
+(defun tramp-debug-buffer-name (vec)
+ "A name for the debug buffer of VEC."
+ (declare (tramp-suppress-trace t))
+ (let ((method (tramp-file-name-method vec))
+ (user-domain (tramp-file-name-user-domain vec))
+ (host-port (tramp-file-name-host-port vec)))
+ (if (tramp-string-empty-or-nil-p user-domain)
+ (format "*debug tramp/%s %s*" method host-port)
+ (format "*debug tramp/%s %s@%s*" method user-domain host-port))))
+
+(defun tramp-get-debug-buffer (vec)
+ "Get the debug buffer of VEC."
+ (declare (tramp-suppress-trace t))
+ (with-current-buffer (get-buffer-create (tramp-debug-buffer-name vec))
+ (when (bobp)
+ (tramp-setup-debug-buffer))
+ (current-buffer)))
+
+(defun tramp-get-debug-file-name (vec)
+ "Get the debug file name for VEC."
+ (declare (tramp-suppress-trace t))
+ (expand-file-name
+ (tramp-compat-string-replace "/" " " (tramp-debug-buffer-name vec))
+ tramp-compat-temporary-file-directory))
+
+(defun tramp-trace-buffer-name (vec)
+ "A name for the trace buffer for VEC."
+ (declare (tramp-suppress-trace t))
+ (tramp-compat-string-replace "*debug" "*trace" (tramp-debug-buffer-name vec)))
+
+(defvar tramp-trace-functions nil
+ "A list of non-Tramp functions to be traced with `tramp-verbose' > 10.")
+
+(defun tramp-debug-message (vec fmt-string &rest arguments)
+ "Append message to debug buffer of VEC.
+Message is formatted with FMT-STRING as control string and the remaining
+ARGUMENTS to actually emit the message (if applicable)."
+ (declare (tramp-suppress-trace t))
+ (let ((inhibit-message t)
+ create-lockfiles file-name-handler-alist message-log-max
+ signal-hook-function)
+ (with-current-buffer (tramp-get-debug-buffer vec)
+ (goto-char (point-max))
+ (let ((point (point)))
+ (when (bobp)
+ ;; Headline.
+ (insert
+ (format
+ ";; Emacs: %s Tramp: %s -*- mode: outline; coding: utf-8; -*-"
+ emacs-version tramp-version))
+ (when (>= tramp-verbose 10)
+ (let ((tramp-verbose 0))
+ (insert
+ (format
+ "\n;; Location: %s Git: %s/%s"
+ (locate-library "tramp")
+ (or tramp-repository-branch "")
+ (or tramp-repository-version "")))))
+ ;; Traces.
+ (when (>= tramp-verbose 11)
+ (dolist
+ (elt
+ (append
+ (mapcar
+ #'intern (all-completions "tramp-" obarray #'functionp))
+ tramp-trace-functions))
+ (unless (get elt 'tramp-suppress-trace)
+ (trace-function-background elt (tramp-trace-buffer-name vec)))))
+ ;; Delete debug file. Announce its further existence.
+ (when (and tramp-debug-to-file (tramp-get-debug-file-name vec))
+ (ignore-errors (delete-file (tramp-get-debug-file-name vec)))
+ (let ((message-log-max t))
+ (message
+ "Tramp debug file is %s" (tramp-get-debug-file-name vec)))))
+ (unless (bolp)
+ (insert "\n"))
+ ;; Timestamp.
+ (insert (format-time-string "%T.%6N "))
+ ;; Threads. `current-thread' might not exist when Emacs is
+ ;; configured --without-threads.
+ ;; (unless (eq (tramp-compat-funcall 'current-thread) main-thread)
+ ;; (insert (format "%s " (tramp-compat-funcall 'current-thread))))
+ ;; Calling Tramp function. We suppress compat and trace
+ ;; functions from being displayed.
+ (let ((frames (backtrace-frames))
+ btf fn)
+ (while (not fn)
+ (setq btf (cadadr frames))
+ (if (not btf)
+ (setq fn "")
+ (and (symbolp btf) (setq fn (symbol-name btf))
+ (or (not (string-prefix-p "tramp" fn))
+ (get btf 'tramp-suppress-trace))
+ (setq fn nil))
+ (setq frames (cdr frames))))
+ ;; The following code inserts filename and line number.
+ ;; Should be inactive by default, because it is time consuming.
+ ;; (let ((ffn (find-function-noselect (intern fn))))
+ ;; (insert
+ ;; (format
+ ;; "%s:%d: "
+ ;; (file-name-nondirectory (buffer-file-name (car ffn)))
+ ;; (with-current-buffer (car ffn)
+ ;; (1+ (count-lines (point-min) (cdr ffn)))))))
+ (insert (format "%s " fn)))
+ ;; The message.
+ (insert (apply #'format-message fmt-string arguments))
+ (if tramp-debug-command-messages
+ ;; Add help function.
+ (tramp-debug-message-buttonize point)
+ ;; Write message to debug file.
+ (when tramp-debug-to-file
+ (ignore-errors
+ (write-region
+ point (point-max) (tramp-get-debug-file-name vec) 'append))))))))
+
+;;;###tramp-autoload
+(defun tramp-message (vec-or-proc level fmt-string &rest arguments)
+ "Emit a message depending on verbosity level.
+VEC-OR-PROC identifies the Tramp buffer to use. It can be either a
+vector or a process. LEVEL says to be quiet if `tramp-verbose' is
+less than LEVEL. The message is emitted only if `tramp-verbose' is
+greater than or equal to LEVEL.
+
+The message is also logged into the debug buffer when `tramp-verbose'
+is greater than or equal 4.
+
+Calls functions `message' and `tramp-debug-message' with FMT-STRING as
+control string and the remaining ARGUMENTS to actually emit the message (if
+applicable)."
+ ;; (declare (tramp-suppress-trace t))
+ (ignore-errors
+ (let ((tramp-verbose
+ (if tramp-debug-command-messages
+ (max tramp-verbose 6) tramp-verbose)))
+ (when (<= level tramp-verbose)
+ ;; Log only when there is a minimum level.
+ (when (>= tramp-verbose 4)
+ (let ((tramp-verbose 0))
+ ;; Append connection buffer for error messages, if exists.
+ (when (= level 1)
+ (ignore-errors
+ (setq fmt-string (concat fmt-string "\n%s")
+ arguments
+ (append
+ arguments
+ `(,(tramp-get-buffer-string
+ (if (processp vec-or-proc)
+ (process-buffer vec-or-proc)
+ (tramp-get-connection-buffer
+ vec-or-proc 'dont-create))))))))
+ ;; Translate proc to vec. Handle nil vec.
+ (when (processp vec-or-proc)
+ (setq vec-or-proc (process-get vec-or-proc 'tramp-vector)))
+ (setq vec-or-proc (tramp-file-name-unify vec-or-proc)))
+ ;; Do it.
+ (when (and (tramp-file-name-p vec-or-proc)
+ (or (null tramp-debug-command-messages) (= level 6)))
+ (apply #'tramp-debug-message
+ vec-or-proc
+ (concat (format "(%d) # " level) fmt-string)
+ arguments)))
+ ;; Display only when there is a minimum level, and the
+ ;; progress reporter doesn't suppress further messages.
+ (when (and (<= level 3) (null tramp-inhibit-progress-reporter))
+ (apply #'message
+ (concat
+ (cond
+ ((= level 0) "")
+ ((= level 1) "")
+ ((= level 2) "Warning: ")
+ (t "Tramp: "))
+ fmt-string)
+ arguments))))))
+
+;; We cannot use the `declare' form for `tramp-suppress-trace' in
+;; autoloaded functions, because the tramp-loaddefs.el generation
+;; would fail.
+(function-put #'tramp-message 'tramp-suppress-trace t)
+
+(defsubst tramp-backtrace (&optional vec-or-proc force)
+ "Dump a backtrace into the debug buffer.
+If VEC-OR-PROC is nil, the buffer *debug tramp* is used. FORCE
+forces the backtrace even if `tramp-verbose' is less than 10.
+This function is meant for debugging purposes."
+ (declare (tramp-suppress-trace t))
+ (let ((tramp-verbose (if force 10 tramp-verbose)))
+ (when (>= tramp-verbose 10)
+ (tramp-message
+ vec-or-proc 10 "\n%s" (with-output-to-string (backtrace))))))
+
+(defsubst tramp-error (vec-or-proc signal fmt-string &rest arguments)
+ "Emit an error.
+VEC-OR-PROC identifies the connection to use, SIGNAL is the
+signal identifier to be raised, remaining arguments passed to
+`tramp-message'. Finally, signal SIGNAL is raised with
+FMT-STRING and ARGUMENTS."
+ (declare (tramp-suppress-trace t))
+ (let (signal-hook-function)
+ (tramp-backtrace vec-or-proc)
+ (unless arguments
+ ;; FMT-STRING could be just a file name, as in
+ ;; `file-already-exists' errors. It could contain the ?\%
+ ;; character, as in smb domain spec.
+ (setq arguments (list fmt-string)
+ fmt-string "%s"))
+ (tramp-message
+ vec-or-proc 1 "%s"
+ (error-message-string
+ (list signal
+ (get signal 'error-message)
+ (apply #'format-message fmt-string arguments))))
+ (signal signal (list (substring-no-properties
+ (apply #'format-message fmt-string arguments))))))
+
+(defvar tramp-error-show-message-timeout 30
+ "Time to show the Tramp buffer in case of an error.
+If it is bound to nil, the buffer is not shown. This is used in
+tramp-tests.el.")
+
+(defsubst tramp-error-with-buffer
+ (buf vec-or-proc signal fmt-string &rest arguments)
+ "Emit an error, and show BUF.
+If BUF is nil, show the connection buf. Wait for 30\", or until
+an input event arrives. The other arguments are passed to `tramp-error'."
+ (declare (tramp-suppress-trace t))
+ (save-window-excursion
+ (let* ((buf (or (and (bufferp buf) buf)
+ (and (processp vec-or-proc) (process-buffer vec-or-proc))
+ (and (tramp-file-name-p vec-or-proc)
+ (tramp-get-connection-buffer vec-or-proc))))
+ (vec (or (and (tramp-file-name-p vec-or-proc) vec-or-proc)
+ (and buf (tramp-dissect-file-name
+ (tramp-get-default-directory buf))))))
+ (unwind-protect
+ (apply #'tramp-error vec-or-proc signal fmt-string arguments)
+ ;; Save exit.
+ (when (and buf
+ (natnump tramp-error-show-message-timeout)
+ (not (zerop tramp-verbose))
+ ;; Do not show when flagged from outside.
+ (not non-essential)
+ ;; Show only when Emacs has started already.
+ (current-message))
+ (let ((enable-recursive-minibuffers t)
+ inhibit-message)
+ ;; `tramp-error' does not show messages. So we must do it
+ ;; ourselves.
+ (apply #'message fmt-string arguments)
+ ;; Show buffer.
+ (pop-to-buffer buf)
+ (discard-input)
+ (sit-for tramp-error-show-message-timeout)))
+ ;; Reset timestamp. It would be wrong after waiting for a while.
+ (when (tramp-file-name-equal-p vec (car tramp-current-connection))
+ (setcdr tramp-current-connection (current-time)))))))
+
+(defsubst tramp-user-error (vec-or-proc fmt-string &rest arguments)
+ "Signal a user error (or \"pilot error\")."
+ (declare (tramp-suppress-trace t))
+ (unwind-protect
+ (apply #'tramp-error vec-or-proc 'user-error fmt-string arguments)
+ ;; Save exit.
+ (when (and (natnump tramp-error-show-message-timeout)
+ (not (zerop tramp-verbose))
+ ;; Do not show when flagged from outside.
+ (not non-essential)
+ ;; Show only when Emacs has started already.
+ (current-message))
+ (let ((enable-recursive-minibuffers t)
+ inhibit-message)
+ ;; `tramp-error' does not show messages. So we must do it ourselves.
+ (apply #'message fmt-string arguments)
+ (discard-input)
+ (sit-for tramp-error-show-message-timeout)
+ ;; Reset timestamp. It would be wrong after waiting for a while.
+ (when
+ (tramp-file-name-equal-p vec-or-proc (car tramp-current-connection))
+ (setcdr tramp-current-connection (current-time)))))))
+
+(defmacro tramp-with-demoted-errors (vec-or-proc format &rest body)
+ "Execute BODY while redirecting the error message to `tramp-message'.
+BODY is executed like wrapped by `with-demoted-errors'. FORMAT
+is a format-string containing a %-sequence meaning to substitute
+the resulting error message."
+ (declare (indent 2) (debug (symbolp form body)))
+ (let ((err (make-symbol "err")))
+ `(condition-case-unless-debug ,err
+ (progn ,@body)
+ (error (tramp-message ,vec-or-proc 3 ,format ,err) nil))))
+
+(defun tramp-test-message (fmt-string &rest arguments)
+ "Emit a Tramp message according `default-directory'."
+ (declare (tramp-suppress-trace t))
+ (cond
+ ((tramp-tramp-file-p default-directory)
+ (apply #'tramp-message
+ (tramp-dissect-file-name default-directory) 0 fmt-string arguments))
+ ((tramp-file-name-p (car tramp-current-connection))
+ (apply #'tramp-message
+ (car tramp-current-connection) 0 fmt-string arguments))
+ (t (apply #'message fmt-string arguments))))
+
+(defun tramp-debug-button-action (button)
+ "Goto the linked message in debug buffer at place."
+ (declare (tramp-suppress-trace t))
+ (when (mouse-event-p last-input-event) (mouse-set-point last-input-event))
+ (when-let ((point (button-get button 'position)))
+ (goto-char point)))
+
+(define-button-type 'tramp-debug-button-type
+ 'follow-link t
+ 'mouse-face 'highlight
+ 'action #'tramp-debug-button-action)
+
+(defun tramp-debug-link-messages (pos1 pos2)
+ "Set links for two messages in current buffer.
+The link buttons are in the verbositiy level substrings."
+ (declare (tramp-suppress-trace t))
+ (save-excursion
+ (let (beg1 end1 beg2 end2)
+ (goto-char pos1)
+ ;; Find positions.
+ (while (not (search-forward-regexp
+ tramp-debug-outline-regexp (line-end-position) t))
+ (forward-line))
+ (setq beg1 (1- (match-beginning 3)) end1 (1+ (match-end 3)))
+ (goto-char pos2)
+ (while (not (search-forward-regexp
+ tramp-debug-outline-regexp (line-end-position) t))
+ (forward-line))
+ (setq beg2 (1- (match-beginning 3)) end2 (1+ (match-end 3)))
+ ;; Create text buttons.
+ (make-text-button
+ beg1 end1 :type 'tramp-debug-button-type
+ 'position (set-marker (make-marker) beg2)
+ 'help-echo "mouse-2, RET: goto exit message")
+ (make-text-button
+ beg2 end2 :type 'tramp-debug-button-type
+ 'position (set-marker (make-marker) beg1)
+ 'help-echo "mouse-2, RET: goto entry message"))))
+
+(defvar tramp-debug-nesting ""
+ "Indicator for debug messages nested level.
+This shouldn't be changed globally, but let-bind where needed.")
+
+(defvar tramp-debug-message-fnh-function nil
+ "The used file name handler operation.
+Bound in `tramp-*-file-name-handler' functions.")
+
+(defun tramp-debug-message-buttonize (position)
+ "Buttonize function in current buffer, at next line starting after POSITION."
+ (declare (tramp-suppress-trace t))
+ (save-excursion
+ (goto-char position)
+ (while (not (search-forward-regexp
+ tramp-debug-outline-regexp (line-end-position) t))
+ (forward-line))
+ (let ((fun (intern (match-string 2))))
+ (make-text-button
+ (match-beginning 2) (match-end 2)
+ :type 'help-function-def
+ 'help-args (list fun (symbol-file fun))))))
+
+;; This is used in `tramp-file-name-handler' and `tramp-*-maybe-open-connection'.
+(defmacro with-tramp-debug-message (vec message &rest body)
+ "Execute BODY, embedded with MESSAGE in the debug buffer of VEC.
+If BODY does not raise a debug message, MESSAGE is ignored."
+ (declare (indent 2) (debug t))
+ (let ((result (make-symbol "result")))
+ `(if tramp-debug-command-messages
+ (save-match-data
+ (let ((tramp-debug-nesting
+ (concat tramp-debug-nesting "#"))
+ (buf (tramp-get-debug-buffer ,vec))
+ beg end ,result)
+ ;; Insert entry message.
+ (with-current-buffer buf
+ (setq beg (point))
+ (tramp-debug-message
+ ,vec "(4) %s %s ..." tramp-debug-nesting ,message)
+ (setq end (point)))
+ (unwind-protect
+ ;; Run BODY.
+ (setq tramp-debug-message-fnh-function nil
+ ,result (progn ,@body))
+ (with-current-buffer buf
+ (if (= end (point-max))
+ (progn
+ (delete-region beg end)
+ (when (bobp) (kill-buffer)))
+ ;; Insert exit message.
+ (tramp-debug-message
+ ,vec "(5) %s %s ... %s" tramp-debug-nesting ,message ,result)
+ ;; Adapt file name handler function.
+ (dolist (pos (list (point-max) end))
+ (goto-char pos)
+ (when (and tramp-debug-message-fnh-function
+ (search-backward
+ "tramp-file-name-handler"
+ (line-beginning-position) t))
+ (replace-match
+ (symbol-name tramp-debug-message-fnh-function))
+ (tramp-debug-message-buttonize
+ (line-beginning-position))))
+ ;; Link related messages.
+ (goto-char (point-max))
+ (tramp-debug-link-messages beg (line-beginning-position)))))))
+
+ ;; No special messages.
+ ,@body)))
+
+(add-hook 'tramp-unload-hook
+ (lambda ()
+ (unload-feature 'tramp-message 'force)))
+
+(provide 'tramp-message)
diff --git a/lisp/net/tramp-rclone.el b/lisp/net/tramp-rclone.el
index 6ebd17db5e9..ced3c1b5aa8 100644
--- a/lisp/net/tramp-rclone.el
+++ b/lisp/net/tramp-rclone.el
@@ -95,6 +95,7 @@
(file-equal-p . tramp-handle-file-equal-p)
(file-executable-p . tramp-fuse-handle-file-executable-p)
(file-exists-p . tramp-handle-file-exists-p)
+ (file-group-gid . tramp-handle-file-group-gid)
(file-in-directory-p . tramp-handle-file-in-directory-p)
(file-local-copy . tramp-handle-file-local-copy)
(file-locked-p . tramp-handle-file-locked-p)
@@ -118,6 +119,7 @@
(file-symlink-p . tramp-handle-file-symlink-p)
(file-system-info . tramp-rclone-handle-file-system-info)
(file-truename . tramp-handle-file-truename)
+ (file-user-uid . tramp-handle-file-user-uid)
(file-writable-p . tramp-handle-file-writable-p)
(find-backup-file-name . tramp-handle-find-backup-file-name)
;; `get-file-buffer' performed by default handler.
@@ -173,8 +175,10 @@ Operations not mentioned here will be handled by the default Emacs primitives.")
First arg specifies the OPERATION, second arg is a list of
arguments to pass to the OPERATION."
(if-let ((fn (assoc operation tramp-rclone-file-name-handler-alist)))
- (save-match-data (apply (cdr fn) args))
- (tramp-run-real-handler operation args)))
+ (prog1 (save-match-data (apply (cdr fn) args))
+ (setq tramp-debug-message-fnh-function (cdr fn)))
+ (prog1 (tramp-run-real-handler operation args)
+ (setq tramp-debug-message-fnh-function operation))))
;;;###tramp-autoload
(tramp--with-startup
@@ -353,7 +357,7 @@ file names."
(defun tramp-rclone-remote-file-name (filename)
"Return FILENAME as used in the `rclone' command."
- (setq filename (tramp-compat-file-name-unquote (expand-file-name filename)))
+ (setq filename (file-name-unquote (expand-file-name filename)))
(if (tramp-rclone-file-name-p filename)
(with-parsed-tramp-file-name filename nil
;; As long as we call `tramp-rclone-maybe-open-connection' here,
@@ -375,54 +379,55 @@ connection if a previous connection has died for some reason."
(unless (tramp-connectable-p vec)
(throw 'non-essential 'non-essential))
- (let ((host (tramp-file-name-host vec)))
- (when (rassoc `(,host) (tramp-rclone-parse-device-names nil))
- (if (tramp-string-empty-or-nil-p host)
- (tramp-error vec 'file-error "Storage %s not connected" host))
- ;; We need a process bound to the connection buffer. Therefore,
- ;; we create a dummy process. Maybe there is a better solution?
- (unless (get-buffer-process (tramp-get-connection-buffer vec))
- (let ((p (make-network-process
- :name (tramp-get-connection-name vec)
- :buffer (tramp-get-connection-buffer vec)
- :server t :host 'local :service t :noquery t)))
- (process-put p 'tramp-vector vec)
- (set-process-query-on-exit-flag p nil)
-
- ;; Set connection-local variables.
- (tramp-set-connection-local-variables vec)))
-
- ;; Create directory.
- (unless (file-directory-p (tramp-fuse-mount-point vec))
- (make-directory (tramp-fuse-mount-point vec) 'parents))
-
- ;; Mount. This command does not return, so we use 0 as
- ;; DESTINATION of `tramp-call-process'.
- (unless (tramp-fuse-mounted-p vec)
- (apply
- #'tramp-call-process
- vec tramp-rclone-program nil 0 nil
- "mount" (tramp-fuse-mount-spec vec)
- (tramp-fuse-mount-point vec)
- (tramp-get-method-parameter vec 'tramp-mount-args))
- (while (not (file-exists-p (tramp-make-tramp-file-name vec 'noloc)))
- (tramp-cleanup-connection vec 'keep-debug 'keep-password))
-
- ;; Mark it as connected.
- (add-to-list 'tramp-fuse-mount-points (tramp-file-name-unify vec))
- (tramp-set-connection-property
- (tramp-get-connection-process vec) "connected" t))))
-
- ;; In `tramp-check-cached-permissions', the connection properties
- ;; "{uid,gid}-{integer,string}" are used. We set them to proper values.
- (with-tramp-connection-property
- vec "uid-integer" (tramp-get-local-uid 'integer))
- (with-tramp-connection-property
- vec "gid-integer" (tramp-get-local-gid 'integer))
- (with-tramp-connection-property
- vec "uid-string" (tramp-get-local-uid 'string))
- (with-tramp-connection-property
- vec "gid-string" (tramp-get-local-gid 'string)))
+ (with-tramp-debug-message vec "Opening connection"
+ (let ((host (tramp-file-name-host vec)))
+ (when (rassoc `(,host) (tramp-rclone-parse-device-names nil))
+ (if (tramp-string-empty-or-nil-p host)
+ (tramp-error vec 'file-error "Storage %s not connected" host))
+ ;; We need a process bound to the connection buffer.
+ ;; Therefore, we create a dummy process. Maybe there is a
+ ;; better solution?
+ (unless (get-buffer-process (tramp-get-connection-buffer vec))
+ (let ((p (make-network-process
+ :name (tramp-get-connection-name vec)
+ :buffer (tramp-get-connection-buffer vec)
+ :server t :host 'local :service t :noquery t)))
+ (tramp-post-process-creation p vec)
+
+ ;; Set connection-local variables.
+ (tramp-set-connection-local-variables vec)))
+
+ ;; Create directory.
+ (unless (file-directory-p (tramp-fuse-mount-point vec))
+ (make-directory (tramp-fuse-mount-point vec) 'parents))
+
+ ;; Mount. This command does not return, so we use 0 as
+ ;; DESTINATION of `tramp-call-process'.
+ (unless (tramp-fuse-mounted-p vec)
+ (apply
+ #'tramp-call-process
+ vec tramp-rclone-program nil 0 nil
+ "mount" (tramp-fuse-mount-spec vec)
+ (tramp-fuse-mount-point vec)
+ (tramp-get-method-parameter vec 'tramp-mount-args))
+ (while (not (file-exists-p (tramp-make-tramp-file-name vec 'noloc)))
+ (tramp-cleanup-connection vec 'keep-debug 'keep-password))
+
+ ;; Mark it as connected.
+ (add-to-list 'tramp-fuse-mount-points (tramp-file-name-unify vec))
+ (tramp-set-connection-property
+ (tramp-get-connection-process vec) "connected" t))))
+
+ ;; In `tramp-check-cached-permissions', the connection properties
+ ;; "{uid,gid}-{integer,string}" are used. We set them to proper values.
+ (with-tramp-connection-property
+ vec "uid-integer" (tramp-get-local-uid 'integer))
+ (with-tramp-connection-property
+ vec "gid-integer" (tramp-get-local-gid 'integer))
+ (with-tramp-connection-property
+ vec "uid-string" (tramp-get-local-uid 'string))
+ (with-tramp-connection-property
+ vec "gid-string" (tramp-get-local-gid 'string))))
(defun tramp-rclone-send-command (vec &rest args)
"Send a command to connection VEC.
diff --git a/lisp/net/tramp-sh.el b/lisp/net/tramp-sh.el
index 3e6fb384a8f..66e648624b2 100644
--- a/lisp/net/tramp-sh.el
+++ b/lisp/net/tramp-sh.el
@@ -31,14 +31,13 @@
;;; Code:
-(eval-when-compile (require 'cl-lib))
+(require 'cl-lib)
(require 'tramp)
;; `dired-*' declarations can be removed, starting with Emacs 29.1.
(declare-function dired-compress-file "dired-aux")
(declare-function dired-remove-file "dired-aux")
(defvar dired-compress-file-suffixes)
-(defvar ls-lisp-use-insert-directory-program)
;; Added in Emacs 28.1.
(defvar process-file-return-signal-string)
(defvar vc-handled-backends)
@@ -100,19 +99,23 @@ detected as prompt when being sent on echoing hosts, therefore.")
(defconst tramp-end-of-heredoc (md5 tramp-end-of-output)
"String used to recognize end of heredoc strings.")
-(defcustom tramp-use-ssh-controlmaster-options (not (eq system-type 'windows-nt))
- "Whether to use `tramp-ssh-controlmaster-options'.
-Set it to t, if you want Tramp to apply these options.
+(define-obsolete-variable-alias
+ 'tramp-use-ssh-controlmaster-options 'tramp-use-connection-share "30.1")
+
+(defcustom tramp-use-connection-share (not (eq system-type 'windows-nt))
+ "Whether to use connection share in ssh or PuTTY.
+Set it to t, if you want Tramp to apply respective options. These
+are `tramp-ssh-controlmaster-options' for ssh, and \"-share\" for PuTTY.
Set it to nil, if you use Control* or Proxy* options in your ssh
configuration.
Set it to `suppress' if you want to disable settings in your
-\"~/.ssh/config¸\"."
+\"~/.ssh/config\" file or in your PuTTY session."
:group 'tramp
- :version "29.2"
+ :version "30.1"
:type '(choice (const :tag "Set ControlMaster" t)
(const :tag "Don't set ControlMaster" nil)
(const :tag "Suppress ControlMaster" suppress))
- ;; Check with (safe-local-variable-p 'tramp-use-ssh-controlmaster-options 'suppress)
+ ;; Check with (safe-local-variable-p 'tramp-use-connection-share 'suppress)
:safe (lambda (val) (and (memq val '(t nil suppress)) t)))
(defvar tramp-ssh-controlmaster-options nil
@@ -124,8 +127,8 @@ If it is a string, it should have the form
spec must be doubled, because the string is used as format string.
Otherwise, it will be auto-detected by Tramp, if
-`tramp-use-ssh-controlmaster-options' is t. The value depends on
-the installed local ssh version.
+`tramp-use-connection-share' is t. The value depends on the
+installed local ssh version.
The string is used in `tramp-methods'.")
@@ -279,6 +282,7 @@ The string is used in `tramp-methods'.")
(tramp-copy-program "nc")
;; We use "-v" for better error tracking.
(tramp-copy-args (("-w" "1") ("-v") ("%h") ("%r")))
+ (tramp-copy-file-name (("%f")))
(tramp-remote-copy-program "nc")
;; We use "-p" as required for newer busyboxes. For older
;; busybox/nc versions, the value must be (("-l") ("%r")). This
@@ -342,7 +346,7 @@ The string is used in `tramp-methods'.")
(add-to-list 'tramp-methods
`("plink"
(tramp-login-program "plink")
- (tramp-login-args (("-l" "%u") ("-P" "%p") ("-ssh")
+ (tramp-login-args (("-l" "%u") ("-P" "%p") ("-ssh") ("%c")
("-t") ("%h") ("\"")
(,(format
"env 'TERM=%s' 'PROMPT_COMMAND=' 'PS1=%s'"
@@ -355,7 +359,7 @@ The string is used in `tramp-methods'.")
(add-to-list 'tramp-methods
`("plinkx"
(tramp-login-program "plink")
- (tramp-login-args (("-load") ("%h") ("-t") ("\"")
+ (tramp-login-args (("-load") ("%h") ("%c") ("-t") ("\"")
(,(format
"env 'TERM=%s' 'PROMPT_COMMAND=' 'PS1=%s'"
tramp-terminal-type
@@ -367,7 +371,7 @@ The string is used in `tramp-methods'.")
(add-to-list 'tramp-methods
`("pscp"
(tramp-login-program "plink")
- (tramp-login-args (("-l" "%u") ("-P" "%p") ("-ssh")
+ (tramp-login-args (("-l" "%u") ("-P" "%p") ("-ssh") ("%c")
("-t") ("%h") ("\"")
(,(format
"env 'TERM=%s' 'PROMPT_COMMAND=' 'PS1=%s'"
@@ -385,7 +389,7 @@ The string is used in `tramp-methods'.")
(add-to-list 'tramp-methods
`("psftp"
(tramp-login-program "plink")
- (tramp-login-args (("-l" "%u") ("-P" "%p") ("-ssh")
+ (tramp-login-args (("-l" "%u") ("-P" "%p") ("-ssh") ("%c")
("-t") ("%h") ("\"")
(,(format
"env 'TERM=%s' 'PROMPT_COMMAND=' 'PS1=%s'"
@@ -397,7 +401,7 @@ The string is used in `tramp-methods'.")
(tramp-remote-shell-args ("-c"))
(tramp-copy-program "pscp")
(tramp-copy-args (("-l" "%u") ("-P" "%p") ("-sftp")
- ("-p" "%k") ("-q")))
+ ("-p" "%k")))
(tramp-copy-keep-date t)))
(add-to-list 'tramp-methods
`("fcp"
@@ -412,7 +416,7 @@ The string is used in `tramp-methods'.")
(add-to-list 'tramp-default-method-alist
`(,tramp-local-host-regexp
- ,(tramp-compat-rx bos (literal tramp-root-id-string) eos) "su"))
+ ,(rx bos (literal tramp-root-id-string) eos) "su"))
(add-to-list 'tramp-default-user-alist
`(,(rx bos (| "su" "sudo" "doas" "ksu") eos)
@@ -425,6 +429,9 @@ The string is used in `tramp-methods'.")
eos)
nil ,(user-login-name))))
+(defconst tramp-default-copy-file-name '(("%u" "@") ("%h" ":") ("%f"))
+ "Default `tramp-copy-file-name' entry for out-of-band methods.")
+
;;;###tramp-autoload
(defconst tramp-completion-function-alist-rsh
'((tramp-parse-rhosts "/etc/hosts.equiv")
@@ -517,8 +524,8 @@ The string is used in `tramp-methods'.")
(tramp-set-completion-function "fcp" tramp-completion-function-alist-ssh))
(defcustom tramp-sh-extra-args
- `((,(rx "/bash" eos) . "-noediting -norc -noprofile")
- (,(rx "/zsh" eos) . "-f +Z -V"))
+ `((,(rx (| bos "/") "bash" eos) . "-noediting -norc -noprofile")
+ (,(rx (| bos "/") "zsh" eos) . "-f +Z -V"))
"Alist specifying extra arguments to pass to the remote shell.
Entries are (REGEXP . ARGS) where REGEXP is a regular expression
matching the shell file name and ARGS is a string specifying the
@@ -529,7 +536,7 @@ This variable is only used when Tramp needs to start up another shell
for tilde expansion. The extra arguments should typically prevent the
shell from reading its init file."
:group 'tramp
- :version "27.1"
+ :version "30.1"
:type '(alist :key-type regexp :value-type string))
(defconst tramp-actions-before-shell
@@ -616,6 +623,13 @@ if (!$result) {
$result = File::Spec->catpath($vol, File::Spec->catdir(@dirs), \"\");
}
+if (-l $ARGV[0]) {
+ print \"t\\n\";
+ }
+else {
+ print \"nil\\n\";
+ }
+
$result =~ s/\"/\\\\\"/g;
print \"\\\"$result\\\"\\n\";
' \"$1\" %n"
@@ -626,16 +640,23 @@ characters need to be doubled.")
(defconst tramp-perl-file-name-all-completions
"%p -e '
-opendir(d, $ARGV[0]) || die(\"$ARGV[0]: $!\\nfail\\n\");
+$dir = $ARGV[0];
+if ($dir ne \"/\") {
+ $dir =~ s#/+$##;
+}
+opendir(d, $dir) || die(\"$dir: $!\\nfail\\n\");
@files = readdir(d); closedir(d);
+print \"(\\n\";
foreach $f (@files) {
- if (-d \"$ARGV[0]/$f\") {
- print \"$f/\\n\";
- }
- else {
- print \"$f\\n\";
- }
+ ($p = $f) =~ s/\\\"/\\\\\\\"/g;
+ ($q = \"$dir/$f\") =~ s/\\\"/\\\\\\\"/g;
+ print \"(\",
+ ((-d \"$q\") ? \"\\\"$p/\\\" \\\"$q\\\" t\" : \"\\\"$p\\\" \\\"$q\\\" nil\"),
+ ((-e \"$q\") ? \" t\" : \" nil\"),
+ ((-r \"$q\") ? \" t\" : \" nil\"),
+ \")\\n\";
}
+print \")\\n\";
' \"$1\" %n"
"Perl script to produce output suitable for use with
`file-name-all-completions' on the remote file system.
@@ -699,11 +720,37 @@ characters need to be doubled.")
" '((%s%%%%N%s) %%%%h (%s%%%%U%s . %%%%u) (%s%%%%G%s . %%%%g)"
" %%%%X %%%%Y %%%%Z %%%%s %s%%%%A%s t %%%%i -1)' \"$1\" %%n || echo nil) |"
" sed -e 's/\"/\\\\\"/g' -e 's/%s/\"/g'")
- tramp-stat-marker tramp-stat-marker ; %%N
- tramp-stat-marker tramp-stat-marker ; %%U
- tramp-stat-marker tramp-stat-marker ; %%G
- tramp-stat-marker tramp-stat-marker ; %%A
- tramp-stat-quoted-marker)
+ tramp-stat-marker tramp-stat-marker ; %%N
+ tramp-stat-marker tramp-stat-marker ; %%U
+ tramp-stat-marker tramp-stat-marker ; %%G
+ tramp-stat-marker tramp-stat-marker ; %%A
+ tramp-stat-quoted-marker)
+ "Shell function to produce output suitable for use with `file-attributes'
+on the remote file system.
+Format specifiers are replaced by `tramp-expand-script', percent
+characters need to be doubled.")
+
+(defconst tramp-stat-file-attributes-with-selinux
+ (format
+ (concat
+ "(%%s -c"
+ " '((%s%%%%N%s) %%%%h (%s%%%%U%s . %%%%u) (%s%%%%G%s . %%%%g)"
+ " %%%%X %%%%Y %%%%Z %%%%s %s%%%%A%s t %%%%i -1 %s%%%%C%s)'"
+ " \"$1\" %%n || echo nil) |"
+ " sed -e 's/\"/\\\\\"/g' -e 's/%s/\"/g'")
+ tramp-stat-marker tramp-stat-marker ; %%N
+ tramp-stat-marker tramp-stat-marker ; %%U
+ tramp-stat-marker tramp-stat-marker ; %%G
+ tramp-stat-marker tramp-stat-marker ; %%A
+ tramp-stat-marker tramp-stat-marker ; %%C
+ tramp-stat-quoted-marker)
+ "Shell function to produce output suitable for use with `file-attributes'
+on the remote file system, including SELinux context.
+Format specifiers are replaced by `tramp-expand-script', percent
+characters need to be doubled.")
+
+(defconst tramp-ls-file-attributes
+ "%s -ild %s \"$1\" || return\n%s -lnd%s %s \"$1\""
"Shell function to produce output suitable for use with `file-attributes'
on the remote file system.
Format specifiers are replaced by `tramp-expand-script', percent
@@ -787,6 +834,33 @@ characters need to be doubled.")
Format specifiers are replaced by `tramp-expand-script', percent
characters need to be doubled.")
+(defconst tramp-stat-directory-files-and-attributes-with-selinux
+ (format
+ (concat
+ ;; We must care about file names with spaces, or starting with
+ ;; "-"; this would confuse xargs. "ls -aQ" might be a solution,
+ ;; but it does not work on all remote systems. Therefore, we use
+ ;; \000 as file separator. `tramp-sh--quoting-style-options' do
+ ;; not work for file names with spaces piped to "xargs".
+ ;; Apostrophes in the stat output are masked as
+ ;; `tramp-stat-marker', in order to make a proper shell escape of
+ ;; them in file names.
+ "cd \"$1\" && echo \"(\"; (%%l -a | tr '\\n\\r' '\\000\\000' |"
+ " xargs -0 %%s -c"
+ " '(%s%%%%n%s (%s%%%%N%s) %%%%h (%s%%%%U%s . %%%%u) (%s%%%%G%s . %%%%g) %%%%X %%%%Y %%%%Z %%%%s %s%%%%A%s t %%%%i -1 %s%%%%C%s)'"
+ " -- %%n | sed -e 's/\"/\\\\\"/g' -e 's/%s/\"/g'); echo \")\"")
+ tramp-stat-marker tramp-stat-marker ; %n
+ tramp-stat-marker tramp-stat-marker ; %N
+ tramp-stat-marker tramp-stat-marker ; %U
+ tramp-stat-marker tramp-stat-marker ; %G
+ tramp-stat-marker tramp-stat-marker ; %A
+ tramp-stat-marker tramp-stat-marker ; %C
+ tramp-stat-quoted-marker)
+ "Shell function implementing `directory-files-and-attributes' as Lisp
+`read'able output, including SELinux context.
+Format specifiers are replaced by `tramp-expand-script', percent
+characters need to be doubled.")
+
(defconst tramp-perl-id
"%p -e '
use strict;
@@ -1015,28 +1089,23 @@ BEGIN {
Format specifiers are replaced by `tramp-expand-script', percent
characters need to be doubled.")
-(defconst tramp-vc-registered-read-file-names
+(defconst tramp-bundle-read-file-names
"echo \"(\"
while read file; do
quoted=`echo \"$file\" | sed -e \"s/\\\"/\\\\\\\\\\\\\\\\\\\"/\"`
- if %s \"$file\"; then
- echo \"(\\\"$quoted\\\" \\\"file-exists-p\\\" t)\"
- else
- echo \"(\\\"$quoted\\\" \\\"file-exists-p\\\" nil)\"
- fi
- if %s \"$file\"; then
- echo \"(\\\"$quoted\\\" \\\"file-readable-p\\\" t)\"
- else
- echo \"(\\\"$quoted\\\" \\\"file-readable-p\\\" nil)\"
- fi
+ printf \"(%%b\" \"\\\"$quoted\\\"\"
+ if %s \"$file\"; then printf \" %%b\" t; else printf \" %%b\" nil; fi
+ if %s \"$file\"; then printf \" %%b\" t; else printf \" %%b\" nil; fi
+ if %s \"$file\"; then printf \" %%b)\n\" t; else printf \" %%b)\n\" nil; fi
done
echo \")\""
- "Script to check existence of VC related files.
-It must be send formatted with two strings; the tests for file
-existence, and file readability. Input shall be read via
-here-document, otherwise the command could exceed maximum length
-of command line.
-Format specifiers \"%s\" are replaced before the script is used.")
+ "Script to check file attributes of a bundle of files.
+It must be sent formatted with three strings; the tests for file
+existence, file readability, and file directory. Input shall be
+read via here-document, otherwise the command could exceed
+maximum length of command line.
+Format specifiers \"%s\" are replaced before the script is used,
+percent characters need to be doubled.")
;; New handlers should be added here.
;;;###tramp-autoload
@@ -1067,6 +1136,7 @@ Format specifiers \"%s\" are replaced before the script is used.")
(file-equal-p . tramp-handle-file-equal-p)
(file-executable-p . tramp-sh-handle-file-executable-p)
(file-exists-p . tramp-sh-handle-file-exists-p)
+ (file-group-gid . tramp-handle-file-group-gid)
(file-in-directory-p . tramp-handle-file-in-directory-p)
(file-local-copy . tramp-sh-handle-file-local-copy)
(file-locked-p . tramp-handle-file-locked-p)
@@ -1090,6 +1160,7 @@ Format specifiers \"%s\" are replaced before the script is used.")
(file-symlink-p . tramp-handle-file-symlink-p)
(file-system-info . tramp-sh-handle-file-system-info)
(file-truename . tramp-sh-handle-file-truename)
+ (file-user-uid . tramp-handle-file-user-uid)
(file-writable-p . tramp-sh-handle-file-writable-p)
(find-backup-file-name . tramp-handle-find-backup-file-name)
;; `get-file-buffer' performed by default handler.
@@ -1135,121 +1206,65 @@ Operations not mentioned here will be handled by the normal Emacs functions.")
(defun tramp-sh-handle-make-symbolic-link
(target linkname &optional ok-if-already-exists)
- "Like `make-symbolic-link' for Tramp files.
-If TARGET is a non-Tramp file, it is used verbatim as the target
-of the symlink. If TARGET is a Tramp file, only the localname
-component is used as the target of the symlink."
- (with-parsed-tramp-file-name (expand-file-name linkname) nil
- ;; If TARGET is a Tramp name, use just the localname component.
- ;; Don't check for a proper method.
- (let ((non-essential t))
- (when (and (tramp-tramp-file-p target)
- (tramp-file-name-equal-p v (tramp-dissect-file-name target)))
- (setq target (tramp-file-local-name (expand-file-name target))))
- ;; There could be a cyclic link.
- (tramp-flush-file-properties
- v (expand-file-name target (tramp-file-local-name default-directory))))
-
- ;; If TARGET is still remote, quote it.
- (if (tramp-tramp-file-p target)
- (make-symbolic-link
- (tramp-compat-file-name-quote target 'top)
- linkname ok-if-already-exists)
-
- (let ((ln (tramp-get-remote-ln v))
- (cwd (tramp-run-real-handler
- #'file-name-directory (list localname))))
- (unless ln
- (tramp-error
- v 'file-error
- (concat "Making a symbolic link: "
- "ln(1) does not exist on the remote host")))
+ "Like `make-symbolic-link' for Tramp files."
+ (let ((v (tramp-dissect-file-name (expand-file-name linkname))))
+ (unless (tramp-get-remote-ln v)
+ (tramp-error
+ v 'file-error
+ (concat "Making a symbolic link: "
+ "ln(1) does not exist on the remote host"))))
- ;; Do the 'confirm if exists' thing.
- (when (file-exists-p linkname)
- ;; What to do?
- (if (or (null ok-if-already-exists) ; not allowed to exist
- (and (numberp ok-if-already-exists)
- (not
- (yes-or-no-p
- (format
- "File %s already exists; make it a link anyway?"
- localname)))))
- (tramp-error v 'file-already-exists localname)
- (delete-file linkname)))
-
- (tramp-flush-file-properties v localname)
-
- ;; Right, they are on the same host, regardless of user,
- ;; method, etc. We now make the link on the remote machine.
- ;; This will occur as the user that TARGET belongs to.
- (and (tramp-send-command-and-check
- v (format "cd %s" (tramp-shell-quote-argument cwd)))
- (tramp-send-command-and-check
- v (format
- "%s -sf %s %s" ln
- (tramp-shell-quote-argument target)
- ;; The command could exceed PATH_MAX, so we use
- ;; relative file names. However, relative file names
- ;; could start with "-".
- ;; `tramp-shell-quote-argument' does not handle this,
- ;; we must do it ourselves.
- (tramp-shell-quote-argument
- (concat "./" (file-name-nondirectory localname))))))))))
+ (tramp-skeleton-make-symbolic-link target linkname ok-if-already-exists
+ (tramp-send-command-and-check
+ v (format
+ "cd %s && %s -sf %s %s"
+ (tramp-shell-quote-argument (file-name-directory localname))
+ (tramp-get-remote-ln v)
+ (tramp-shell-quote-argument target)
+ ;; The command could exceed PATH_MAX, so we use relative
+ ;; file names.
+ (tramp-shell-quote-argument
+ (concat "./" (file-name-nondirectory localname)))))))
(defun tramp-sh-handle-file-truename (filename)
"Like `file-truename' for Tramp files."
- ;; Preserve trailing "/".
- (funcall
- (if (directory-name-p filename) #'file-name-as-directory #'identity)
- ;; Quote properly.
- (funcall
- (if (tramp-compat-file-name-quoted-p filename)
- #'tramp-compat-file-name-quote #'identity)
- (with-parsed-tramp-file-name
- (tramp-compat-file-name-unquote (expand-file-name filename)) nil
- (tramp-make-tramp-file-name
- v
- (with-tramp-file-property v localname "file-truename"
- (tramp-message v 4 "Finding true name for `%s'" filename)
- (let ((result
- (cond
- ;; Use GNU readlink --canonicalize-missing where available.
- ((tramp-get-remote-readlink v)
- (tramp-send-command-and-check
- v (format "%s --canonicalize-missing %s"
- (tramp-get-remote-readlink v)
- (tramp-shell-quote-argument localname)))
- (with-current-buffer (tramp-get-connection-buffer v)
- (goto-char (point-min))
- (buffer-substring (point-min) (line-end-position))))
-
- ;; Use Perl implementation.
- ((and (tramp-get-remote-perl v)
- (tramp-get-connection-property v "perl-file-spec")
- (tramp-get-connection-property v "perl-cwd-realpath"))
- (tramp-maybe-send-script
- v tramp-perl-file-truename "tramp_perl_file_truename")
- (tramp-send-command-and-read
- v (format "tramp_perl_file_truename %s"
- (tramp-shell-quote-argument localname))))
-
- ;; Do it yourself.
- (t (tramp-file-local-name
- (tramp-handle-file-truename filename))))))
-
- ;; Detect cycle.
- (when (and (file-symlink-p filename)
- (string-equal result localname))
- (tramp-error
- v 'file-error
- "Apparent cycle of symbolic links for %s" filename))
- ;; If the resulting localname looks remote, we must quote it
- ;; for security reasons.
- (when (file-remote-p result)
- (setq result (tramp-compat-file-name-quote result 'top)))
- (tramp-message v 4 "True name of `%s' is `%s'" localname result)
- result)))))))
+ (tramp-skeleton-file-truename filename
+ (cond
+ ;; Use GNU readlink --canonicalize-missing where available.
+ ((tramp-get-remote-readlink v)
+ (tramp-send-command-and-check
+ v (format
+ (concat
+ "(if %s -h \"%s\"; then echo t; else echo nil; fi) && "
+ "%s --canonicalize-missing %s")
+ (tramp-get-test-command v)
+ (tramp-shell-quote-argument localname)
+ (tramp-get-remote-readlink v)
+ (tramp-shell-quote-argument localname)))
+ (with-current-buffer (tramp-get-connection-buffer v)
+ (goto-char (point-min))
+ (tramp-set-file-property v localname "file-symlink-marker" (read (current-buffer)))
+ ;; We cannot call `read', the file name isn't quoted.
+ (forward-line)
+ (buffer-substring (point) (line-end-position))))
+
+ ;; Use Perl implementation.
+ ((and (tramp-get-remote-perl v)
+ (tramp-get-connection-property v "perl-file-spec")
+ (tramp-get-connection-property v "perl-cwd-realpath"))
+ (tramp-maybe-send-script
+ v tramp-perl-file-truename "tramp_perl_file_truename")
+ (tramp-send-command-and-check
+ v (format "tramp_perl_file_truename %s"
+ (tramp-shell-quote-argument localname)))
+ (with-current-buffer (tramp-get-connection-buffer v)
+ (goto-char (point-min))
+ (tramp-set-file-property v localname "file-symlink-marker" (read (current-buffer)))
+ (read (current-buffer))))
+
+ ;; Do it yourself.
+ (t (tramp-file-local-name
+ (tramp-handle-file-truename filename))))))
;; Basic functions.
@@ -1280,6 +1295,9 @@ component is used as the target of the symlink."
(defconst tramp-sunos-unames (rx (| "SunOS 5.10" "SunOS 5.11"))
"Regexp to determine remote SunOS.")
+(defconst tramp-bsd-unames (rx (| "BSD" "DragonFly" "Darwin"))
+ "Regexp to determine remote *BSD and macOS.")
+
(defun tramp-sh--quoting-style-options (vec)
"Quoting style options to be used for VEC."
(or
@@ -1293,42 +1311,25 @@ component is used as the target of the symlink."
(defun tramp-do-file-attributes-with-ls (vec localname)
"Implement `file-attributes' for Tramp files using the ls(1) command."
- (let (symlinkp dirp
+ (tramp-message vec 5 "file attributes with ls: %s" localname)
+ (let ((tramp-ls-file-attributes
+ (format tramp-ls-file-attributes
+ (tramp-get-ls-command vec)
+ ;; On systems which have no quoting style, file
+ ;; names with special characters could fail.
+ (tramp-sh--quoting-style-options vec)
+ (tramp-get-ls-command vec)
+ (if (tramp-remote-selinux-p vec) "Z" "")
+ (tramp-sh--quoting-style-options vec)))
+ symlinkp dirp
res-inode res-filemodes res-numlinks
res-uid-string res-gid-string res-uid-integer res-gid-integer
- res-size res-symlink-target)
- (tramp-message vec 5 "file attributes with ls: %s" localname)
- ;; We cannot send all three commands combined, it could exceed
- ;; NAME_MAX or PATH_MAX. Happened on macOS, for example.
+ res-size res-symlink-target res-context)
+ (tramp-maybe-send-script
+ vec tramp-ls-file-attributes "tramp_ls_file_attributes")
(when (tramp-send-command-and-check
- vec
- (format "cd %s && (%s %s || %s -h %s)"
- (tramp-shell-quote-argument
- (tramp-run-real-handler
- #'file-name-directory (list localname)))
- (tramp-get-file-exists-command vec)
- (if (string-empty-p (file-name-nondirectory localname))
- "."
- (tramp-shell-quote-argument
- (file-name-nondirectory localname)))
- (tramp-get-test-command vec)
- (if (string-empty-p (file-name-nondirectory localname))
- "."
- (tramp-shell-quote-argument
- (file-name-nondirectory localname)))))
- (tramp-send-command
- vec
- (format "%s -ild %s %s; %s -lnd %s %s"
- (tramp-get-ls-command vec)
- ;; On systems which have no quoting style, file names
- ;; with special characters could fail.
- (tramp-sh--quoting-style-options vec)
- (tramp-shell-quote-argument localname)
- (tramp-get-ls-command vec)
- ;; On systems which have no quoting style, file names
- ;; with special characters could fail.
- (tramp-sh--quoting-style-options vec)
- (tramp-shell-quote-argument localname)))
+ vec (format "tramp_ls_file_attributes %s"
+ (tramp-shell-quote-argument localname)))
;; Parse `ls -l' output ...
(with-current-buffer (tramp-get-buffer vec)
(when (> (buffer-size) 0)
@@ -1374,6 +1375,10 @@ component is used as the target of the symlink."
(setq res-uid-integer tramp-unknown-id-integer))
(unless (numberp res-gid-integer)
(setq res-gid-integer tramp-unknown-id-integer))
+ ;; ... SELinux context
+ (when (tramp-remote-selinux-p vec)
+ (setq res-context (read (current-buffer))
+ res-context (symbol-name res-context)))
;; Return data gathered.
(list
@@ -1400,7 +1405,10 @@ component is used as the target of the symlink."
;; 10. Inode number.
res-inode
;; 11. Device number. Will be replaced by a virtual device number.
- -1))))))
+ -1
+ ;; 12. SELinux context. Will be extracted in
+ ;; `tramp-convert-file-attributes'.
+ res-context))))))
(defun tramp-do-file-attributes-with-perl (vec localname)
"Implement `file-attributes' for Tramp files using a Perl script."
@@ -1414,11 +1422,20 @@ component is used as the target of the symlink."
(defun tramp-do-file-attributes-with-stat (vec localname)
"Implement `file-attributes' for Tramp files using stat(1) command."
(tramp-message vec 5 "file attributes with stat: %s" localname)
- (tramp-maybe-send-script
- vec tramp-stat-file-attributes "tramp_stat_file_attributes")
- (tramp-send-command-and-read
- vec (format "tramp_stat_file_attributes %s"
- (tramp-shell-quote-argument localname))))
+ (cond
+ ((tramp-remote-selinux-p vec)
+ (tramp-maybe-send-script
+ vec tramp-stat-file-attributes-with-selinux
+ "tramp_stat_file_attributes_with_selinux")
+ (tramp-send-command-and-read
+ vec (format "tramp_stat_file_attributes_with_selinux %s"
+ (tramp-shell-quote-argument localname))))
+ (t
+ (tramp-maybe-send-script
+ vec tramp-stat-file-attributes "tramp_stat_file_attributes")
+ (tramp-send-command-and-read
+ vec (format "tramp_stat_file_attributes %s"
+ (tramp-shell-quote-argument localname))))))
(defun tramp-sh-handle-set-visited-file-modtime (&optional time-list)
"Like `set-visited-file-modtime' for Tramp files."
@@ -1435,7 +1452,7 @@ component is used as the target of the symlink."
(modtime (or (file-attribute-modification-time attr)
tramp-time-doesnt-exist)))
(setq coding-system-used last-coding-system-used)
- (if (not (tramp-compat-time-equal-p modtime tramp-time-dont-know))
+ (if (not (time-equal-p modtime tramp-time-dont-know))
(tramp-run-real-handler #'set-visited-file-modtime (list modtime))
(progn
(tramp-send-command
@@ -1475,9 +1492,7 @@ of."
(cond
;; File exists, and has a known modtime.
- ((and attr
- (not
- (tramp-compat-time-equal-p modtime tramp-time-dont-know)))
+ ((and attr (not (time-equal-p modtime tramp-time-dont-know)))
(< (abs (tramp-time-diff modtime mt)) 2))
;; Modtime has the don't know value.
(attr
@@ -1494,7 +1509,7 @@ of."
v localname "visited-file-modtime-ild" "")))
;; If file does not exist, say it is not modified if and
;; only if that agrees with the buffer's record.
- (t (tramp-compat-time-equal-p mt tramp-time-doesnt-exist)))))))))
+ (t (time-equal-p mt tramp-time-doesnt-exist)))))))))
(defun tramp-sh-handle-set-file-modes (filename mode &optional flag)
"Like `set-file-modes' for Tramp files."
@@ -1516,21 +1531,17 @@ of."
"Like `set-file-times' for Tramp files."
(tramp-skeleton-set-file-modes-times-uid-gid filename
(when (tramp-get-remote-touch v)
- (let ((time
- (if (or (null time)
- (tramp-compat-time-equal-p time tramp-time-doesnt-exist)
- (tramp-compat-time-equal-p time tramp-time-dont-know))
- nil
- time)))
- (tramp-send-command-and-check
- v (format
- "env TZ=UTC0 %s %s %s %s"
- (tramp-get-remote-touch v)
- (if (tramp-get-connection-property v "touch-t")
- (format "-t %s" (format-time-string "%Y%m%d%H%M.%S" time t))
- "")
- (if (eq flag 'nofollow) "-h" "")
- (tramp-shell-quote-argument localname)))))))
+ (tramp-send-command-and-check
+ v (format
+ "env TZ=UTC0 %s %s %s %s"
+ (tramp-get-remote-touch v)
+ (if (tramp-get-connection-property v "touch-t")
+ (format
+ "-t %s"
+ (format-time-string "%Y%m%d%H%M.%S" (tramp-defined-time time) t))
+ "")
+ (if (eq flag 'nofollow) "-h" "")
+ (tramp-shell-quote-argument localname))))))
(defun tramp-sh-handle-get-home-directory (vec &optional user)
"The remote home directory for connection VEC as local file name.
@@ -1619,7 +1630,7 @@ ID-FORMAT valid values are `string' and `integer'."
(tramp-shell-quote-argument localname))))))))
(defun tramp-remote-selinux-p (vec)
- "Check, whether SELINUX is enabled on the remote host."
+ "Check, whether SELinux is enabled on the remote host."
(with-tramp-connection-property (tramp-get-process vec) "selinux-p"
(tramp-send-command-and-check vec "selinuxenabled")))
@@ -1628,7 +1639,7 @@ ID-FORMAT valid values are `string' and `integer'."
(with-parsed-tramp-file-name (expand-file-name filename) nil
(with-tramp-file-property v localname "file-selinux-context"
(let ((context '(nil nil nil nil))
- (regexp (tramp-compat-rx
+ (regexp (rx
(group (+ (any "_" alnum))) ":"
(group (+ (any "_" alnum))) ":"
(group (+ (any "_" alnum))) ":"
@@ -1641,7 +1652,7 @@ ID-FORMAT valid values are `string' and `integer'."
(tramp-shell-quote-argument localname))))
(with-current-buffer (tramp-get-connection-buffer v)
(goto-char (point-min))
- (when (re-search-forward regexp (line-end-position) t)
+ (when (search-forward-regexp regexp (line-end-position) t)
(setq context (list (match-string 1) (match-string 2)
(match-string 3) (match-string 4))))))
;; Return the context.
@@ -1745,8 +1756,8 @@ ID-FORMAT valid values are `string' and `integer'."
(with-tramp-file-property v localname "file-directory-p"
(if-let
((truename (tramp-get-file-property v localname "file-truename"))
- (attr-p (tramp-file-property-p
- v (tramp-file-local-name truename) "file-attributes")))
+ ((tramp-file-property-p
+ v (tramp-file-local-name truename) "file-attributes")))
(eq (file-attribute-type
(tramp-get-file-property
v (tramp-file-local-name truename) "file-attributes"))
@@ -1758,9 +1769,9 @@ ID-FORMAT valid values are `string' and `integer'."
(with-parsed-tramp-file-name (expand-file-name filename) nil
(with-tramp-file-property v localname "file-writable-p"
(if (file-exists-p filename)
+ ;; Examine `file-attributes' cache to see if request can be
+ ;; satisfied without remote operation.
(if (tramp-file-property-p v localname "file-attributes")
- ;; Examine `file-attributes' cache to see if request can
- ;; be satisfied without remote operation.
(tramp-check-cached-permissions v ?w)
(tramp-run-test v "-w" localname))
;; If file doesn't exist, check if directory is writable.
@@ -1785,7 +1796,7 @@ ID-FORMAT valid values are `string' and `integer'."
;; On BSD-derived systems files always inherit the
;; parent directory's group, so skip the group-gid
;; test.
- (tramp-check-remote-uname v (rx (| "BSD" "DragonFly" "Darwin")))
+ (tramp-check-remote-uname v tramp-bsd-unames)
(= (file-attribute-group-id attributes)
(tramp-get-remote-gid v 'integer)))))))))
@@ -1822,12 +1833,21 @@ ID-FORMAT valid values are `string' and `integer'."
(defun tramp-do-directory-files-and-attributes-with-stat (vec localname)
"Implement `directory-files-and-attributes' for Tramp files with stat(1) command."
(tramp-message vec 5 "directory-files-and-attributes with stat: %s" localname)
- (tramp-maybe-send-script
- vec tramp-stat-directory-files-and-attributes
- "tramp_stat_directory_files_and_attributes")
- (tramp-send-command-and-read
- vec (format "tramp_stat_directory_files_and_attributes %s"
- (tramp-shell-quote-argument localname))))
+ (cond
+ ((tramp-remote-selinux-p vec)
+ (tramp-maybe-send-script
+ vec tramp-stat-directory-files-and-attributes-with-selinux
+ "tramp_stat_directory_files_and_attributes_with_selinux")
+ (tramp-send-command-and-read
+ vec (format "tramp_stat_directory_files_and_attributes_with_selinux %s"
+ (tramp-shell-quote-argument localname))))
+ (t
+ (tramp-maybe-send-script
+ vec tramp-stat-directory-files-and-attributes
+ "tramp_stat_directory_files_and_attributes")
+ (tramp-send-command-and-read
+ vec (format "tramp_stat_directory_files_and_attributes %s"
+ (tramp-shell-quote-argument localname))))))
;; This function should return "foo/" for directories and "bar" for
;; files.
@@ -1845,35 +1865,48 @@ ID-FORMAT valid values are `string' and `integer'."
;; Get a list of directories and files, including
;; reliably tagging the directories with a trailing "/".
;; Because I rock. --daniel@danann.net
- (when (tramp-send-command-and-check
- v
- (if (tramp-get-remote-perl v)
- (progn
- (tramp-maybe-send-script
- v tramp-perl-file-name-all-completions
- "tramp_perl_file_name_all_completions")
- (format "tramp_perl_file_name_all_completions %s"
- (tramp-shell-quote-argument localname)))
-
- (format (concat
- "cd %s 2>&1 && %s -a 2>%s"
- " | while IFS= read f; do"
- " if %s -d \"$f\" 2>%s;"
- " then \\echo \"$f/\"; else \\echo \"$f\"; fi;"
- " done")
- (tramp-shell-quote-argument localname)
- (tramp-get-ls-command v)
- (tramp-get-remote-null-device v)
- (tramp-get-test-command v)
- (tramp-get-remote-null-device v))))
-
- ;; Now grab the output.
- (with-current-buffer (tramp-get-buffer v)
- (goto-char (point-max))
- (while (zerop (forward-line -1))
- (push
- (buffer-substring (point) (line-end-position)) result)))
- result)))))))))
+ (if (tramp-get-remote-perl v)
+ (progn
+ (tramp-maybe-send-script
+ v tramp-perl-file-name-all-completions
+ "tramp_perl_file_name_all_completions")
+ (setq result
+ (tramp-send-command-and-read
+ v (format "tramp_perl_file_name_all_completions %s"
+ (tramp-shell-quote-argument localname))
+ 'noerror))
+ ;; Cached values.
+ (dolist (elt result)
+ (tramp-set-file-property
+ v (cadr elt) "file-directory-p" (nth 2 elt))
+ (tramp-set-file-property
+ v (cadr elt) "file-exists-p" (nth 3 elt))
+ (tramp-set-file-property
+ v (cadr elt) "file-readable-p" (nth 4 elt)))
+ ;; Result.
+ (mapcar #'car result))
+
+ ;; Do it with ls.
+ (when (tramp-send-command-and-check
+ v (format (concat
+ "cd %s 2>&1 && %s -a 2>%s"
+ " | while IFS= read f; do"
+ " if %s -d \"$f\" 2>%s;"
+ " then echo \"$f/\"; else echo \"$f\"; fi;"
+ " done")
+ (tramp-shell-quote-argument localname)
+ (tramp-get-ls-command v)
+ (tramp-get-remote-null-device v)
+ (tramp-get-test-command v)
+ (tramp-get-remote-null-device v)))
+
+ ;; Now grab the output.
+ (with-current-buffer (tramp-get-buffer v)
+ (goto-char (point-max))
+ (while (zerop (forward-line -1))
+ (push
+ (buffer-substring (point) (line-end-position)) result)))
+ result))))))))))
;; cp, mv and ln
@@ -1982,7 +2015,7 @@ ID-FORMAT valid values are `string' and `integer'."
#'copy-directory
(list dirname newname keep-date parents copy-contents))))
- ;; When newname did exist, we have wrong cached values.
+ ;; NEWNAME has wrong cached values.
(when t2
(with-parsed-tramp-file-name (expand-file-name newname) nil
(tramp-flush-file-properties v localname)))))))
@@ -2014,7 +2047,7 @@ OK-IF-ALREADY-EXISTS means don't barf if NEWNAME exists already.
KEEP-DATE means to make sure that NEWNAME has the same timestamp
as FILENAME. PRESERVE-UID-GID, when non-nil, instructs to keep
the uid and gid if both files are on the same host.
-PRESERVE-EXTENDED-ATTRIBUTES activates selinux and acl commands.
+PRESERVE-EXTENDED-ATTRIBUTES activates SELinux and ACL commands.
This function is invoked by `tramp-sh-handle-copy-file' and
`tramp-sh-handle-rename-file'. It is an error if OP is neither
@@ -2037,7 +2070,11 @@ file names."
(t2 (tramp-tramp-file-p newname))
(length (file-attribute-size
(file-attributes (file-truename filename))))
- (msg-operation (if (eq op 'copy) "Copying" "Renaming")))
+ (file-times (file-attribute-modification-time
+ (file-attributes filename)))
+ (file-modes (tramp-default-file-modes filename))
+ (msg-operation (if (eq op 'copy) "Copying" "Renaming"))
+ copy-keep-date)
(with-parsed-tramp-file-name (if t1 filename newname) nil
(unless length
@@ -2062,6 +2099,8 @@ file names."
;; both files, we invoke `cp' or `mv' on the remote
;; host directly.
((tramp-equal-remote filename newname)
+ (setq copy-keep-date
+ (or (eq op 'rename) keep-date preserve-uid-gid))
(tramp-do-copy-or-rename-file-directly
op filename newname
ok-if-already-exists keep-date preserve-uid-gid))
@@ -2070,6 +2109,8 @@ file names."
((and
(tramp-method-out-of-band-p v1 length)
(tramp-method-out-of-band-p v2 length))
+ (setq copy-keep-date
+ (tramp-get-method-parameter v 'tramp-copy-keep-date))
(tramp-do-copy-or-rename-file-out-of-band
op filename newname ok-if-already-exists keep-date))
@@ -2091,6 +2132,8 @@ file names."
(cond
;; Fast track on local machine.
((tramp-local-host-p v)
+ (setq copy-keep-date
+ (or (eq op 'rename) keep-date preserve-uid-gid))
(tramp-do-copy-or-rename-file-directly
op filename newname
ok-if-already-exists keep-date preserve-uid-gid))
@@ -2098,6 +2141,8 @@ file names."
;; If the Tramp file has an out-of-band method, the
;; corresponding copy-program can be invoked.
((tramp-method-out-of-band-p v length)
+ (setq copy-keep-date
+ (tramp-get-method-parameter v 'tramp-copy-keep-date))
(tramp-do-copy-or-rename-file-out-of-band
op filename newname ok-if-already-exists keep-date))
@@ -2109,6 +2154,16 @@ file names."
;; One of them must be a Tramp file.
(error "Tramp implementation says this cannot happen")))
+ ;; In case of `rename', we must flush the cache of the source file.
+ (when (and t1 (eq op 'rename))
+ (with-parsed-tramp-file-name filename v1
+ (tramp-flush-file-properties v1 v1-localname)))
+
+ ;; NEWNAME has wrong cached values.
+ (when t2
+ (with-parsed-tramp-file-name newname v2
+ (tramp-flush-file-properties v2 v2-localname)))
+
;; Handle `preserve-extended-attributes'. We ignore
;; possible errors, because ACL strings could be
;; incompatible.
@@ -2117,18 +2172,17 @@ file names."
(ignore-errors
(set-file-extended-attributes newname attributes)))
- ;; In case of `rename', we must flush the cache of the source file.
- (when (and t1 (eq op 'rename))
- (with-parsed-tramp-file-name filename v1
- (tramp-flush-file-properties v1 v1-localname)))
+ ;; KEEP-DATE handling.
+ (when (and keep-date (not copy-keep-date))
+ (tramp-compat-set-file-times
+ newname file-times (unless ok-if-already-exists 'nofollow)))
- ;; When newname did exist, we have wrong cached values.
- (when t2
- (with-parsed-tramp-file-name newname v2
- (tramp-flush-file-properties v2 v2-localname)))))))))
+ ;; Set the mode.
+ (unless (and keep-date copy-keep-date)
+ (set-file-modes newname file-modes))))))))
(defun tramp-do-copy-or-rename-file-via-buffer
- (op filename newname ok-if-already-exists keep-date)
+ (op filename newname _ok-if-already-exists _keep-date)
"Use an Emacs buffer to copy or rename a file.
First arg OP is either `copy' or `rename' and indicates the operation.
FILENAME is the source file, NEWNAME the target file.
@@ -2155,14 +2209,7 @@ KEEP-DATE is non-nil if NEWNAME should have the same timestamp as FILENAME."
(with-temp-file newname
(set-buffer-multibyte nil)
(insert-file-contents-literally filename)))
- ;; KEEP-DATE handling.
- (when keep-date
- (tramp-compat-set-file-times
- newname
- (file-attribute-modification-time (file-attributes filename))
- (unless ok-if-already-exists 'nofollow)))
- ;; Set the mode.
- (set-file-modes newname (tramp-default-file-modes filename))
+
;; If the operation was `rename', delete the original file.
(unless (eq op 'copy) (delete-file filename)))
@@ -2178,12 +2225,10 @@ as FILENAME. PRESERVE-UID-GID, when non-nil, instructs to keep
the uid and gid from FILENAME."
;; FILENAME and NEWNAME are already expanded.
(let ((t1 (tramp-tramp-file-p filename))
- (t2 (tramp-tramp-file-p newname))
- (file-times (file-attribute-modification-time
- (file-attributes filename)))
- (file-modes (tramp-default-file-modes filename)))
+ (t2 (tramp-tramp-file-p newname)))
(with-parsed-tramp-file-name (if t1 filename newname) nil
- (let* ((cmd (cond ((and (eq op 'copy) preserve-uid-gid) "cp -f -p")
+ (let* ((cmd (cond ((and (eq op 'copy) (or keep-date preserve-uid-gid))
+ "cp -f -p")
((eq op 'copy) "cp -f")
((eq op 'rename) "mv -f")
(t (tramp-error
@@ -2211,7 +2256,7 @@ the uid and gid from FILENAME."
(or
(and keep-date
;; Mask cp -f error.
- (re-search-forward
+ (search-forward-regexp
tramp-operation-not-permitted-regexp nil t))
cmd-result)
(tramp-error-with-buffer
@@ -2312,19 +2357,7 @@ the uid and gid from FILENAME."
(list tmpfile localname2 ok-if-already-exists)))))
;; Save exit.
- (ignore-errors (delete-file tmpfile)))))))))
-
- ;; When newname did exist, we have wrong cached values.
- (when t2
- (with-parsed-tramp-file-name newname v2
- (tramp-flush-file-properties v2 v2-localname)))
-
- ;; Set the time and mode. Mask possible errors.
- (ignore-errors
- (when keep-date
- (tramp-compat-set-file-times
- newname file-times (unless ok-if-already-exists 'nofollow))
- (set-file-modes newname file-modes))))))
+ (ignore-errors (delete-file tmpfile))))))))))))
(defun tramp-do-copy-or-rename-file-out-of-band
(op filename newname ok-if-already-exists keep-date)
@@ -2336,7 +2369,7 @@ The method used must be an out-of-band method."
(v2 (and (tramp-tramp-file-p newname)
(tramp-dissect-file-name newname)))
(v (or v1 v2))
- copy-program copy-args copy-env copy-keep-date listener spec
+ copy-program copy-args copy-env listener spec
options source target remote-copy-program remote-copy-args p)
(if (and v1 v2 (string-empty-p (tramp-scp-direct-remote-copying v1 v2)))
@@ -2370,11 +2403,11 @@ The method used must be an out-of-band method."
#'file-name-as-directory
#'identity)
(if v1
- (tramp-make-copy-program-file-name v1)
- (tramp-compat-file-name-unquote filename)))
+ (tramp-make-copy-file-name v1)
+ (file-name-unquote filename)))
target (if v2
- (tramp-make-copy-program-file-name v2)
- (tramp-compat-file-name-unquote newname)))
+ (tramp-make-copy-file-name v2)
+ (file-name-unquote newname)))
;; Check for listener port.
(when (tramp-get-method-parameter v 'tramp-remote-copy-args)
@@ -2408,26 +2441,24 @@ The method used must be an out-of-band method."
?y (tramp-scp-force-scp-protocol v)
?z (tramp-scp-direct-remote-copying v1 v2))
copy-program (tramp-get-method-parameter v 'tramp-copy-program)
- copy-keep-date (tramp-get-method-parameter
- v 'tramp-copy-keep-date)
copy-args
;; " " has either been a replacement of "%k" (when
- ;; keep-date argument is non-nil), or a replacement for
+ ;; KEEP-DATE argument is non-nil), or a replacement for
;; the whole keep-date sublist.
- (delete " " (apply #'tramp-expand-args v 'tramp-copy-args spec))
+ (delete " " (apply #'tramp-expand-args v 'tramp-copy-args nil spec))
;; `tramp-ssh-controlmaster-options' is a string instead
;; of a list. Unflatten it.
copy-args
- (tramp-compat-flatten-tree
+ (flatten-tree
(mapcar
(lambda (x) (if (tramp-compat-string-search " " x)
(split-string x) x))
copy-args))
- copy-env (apply #'tramp-expand-args v 'tramp-copy-env spec)
+ copy-env (apply #'tramp-expand-args v 'tramp-copy-env nil spec)
remote-copy-program
(tramp-get-method-parameter v 'tramp-remote-copy-program)
remote-copy-args
- (apply #'tramp-expand-args v 'tramp-remote-copy-args spec))
+ (apply #'tramp-expand-args v 'tramp-remote-copy-args nil spec))
;; Check for local copy program.
(unless (executable-find copy-program)
@@ -2445,8 +2476,7 @@ The method used must be an out-of-band method."
v 'file-error
"Cannot find remote listener: %s" remote-copy-program))
(setq remote-copy-program
- (mapconcat
- #'identity
+ (string-join
(append
(list remote-copy-program) remote-copy-args
(list (if v1 (concat "<" source) (concat ">" target)) "&"))
@@ -2498,14 +2528,11 @@ The method used must be an out-of-band method."
(tramp-get-connection-name v)
(tramp-get-connection-buffer v)
copy-program copy-args)))
- (tramp-message v 6 "%s" (string-join (process-command p) " "))
- (process-put p 'tramp-vector v)
;; This is needed for ssh or PuTTY based processes, and
;; only if the respective options are set. Perhaps,
;; the setting could be more fine-grained.
;; (process-put p 'tramp-shared-socket t)
- (process-put p 'adjust-window-size-function #'ignore)
- (set-process-query-on-exit-flag p nil)
+ (tramp-post-process-creation p v)
;; We must adapt `tramp-local-end-of-line' for sending
;; the password. Also, we indicate that perhaps
@@ -2521,25 +2548,7 @@ The method used must be an out-of-band method."
;; Houston, we have a problem! Likely, the listener is
;; still running, so let's clear everything (but the
;; cached password).
- (tramp-cleanup-connection v 'keep-debug 'keep-password))))
-
- ;; The cached file properties might be wrong if NEWNAME didn't
- ;; exist. Flush them.
- (when v2
- (with-parsed-tramp-file-name newname v2
- (tramp-flush-file-properties v2 v2-localname)))
-
- ;; Handle KEEP-DATE argument.
- (when (and keep-date (not copy-keep-date))
- (tramp-compat-set-file-times
- newname
- (file-attribute-modification-time (file-attributes filename))
- (unless ok-if-already-exists 'nofollow)))
-
- ;; Set the mode.
- (unless (and keep-date copy-keep-date)
- (ignore-errors
- (set-file-modes newname (tramp-default-file-modes filename)))))
+ (tramp-cleanup-connection v 'keep-debug 'keep-password)))))
;; If the operation was `rename', delete the original file.
(unless (eq op 'copy)
@@ -2549,19 +2558,10 @@ The method used must be an out-of-band method."
(defun tramp-sh-handle-make-directory (dir &optional parents)
"Like `make-directory' for Tramp files."
- (setq dir (expand-file-name dir))
- (with-parsed-tramp-file-name dir nil
- (when (and (null parents) (file-exists-p dir))
- (tramp-error v 'file-already-exists dir))
- ;; When PARENTS is non-nil, DIR could be a chain of non-existent
- ;; directories a/b/c/... Instead of checking, we simply flush the
- ;; whole cache.
- (tramp-flush-directory-properties
- v (if parents "/" (file-name-directory localname)))
+ (tramp-skeleton-make-directory dir parents
(tramp-barf-unless-okay
v (format "%s -m %#o %s"
- (if parents "mkdir -p" "mkdir")
- (default-file-modes)
+ "mkdir" (default-file-modes)
(tramp-shell-quote-argument localname))
"Couldn't make directory %s" dir)))
@@ -2576,14 +2576,10 @@ The method used must be an out-of-band method."
(defun tramp-sh-handle-delete-file (filename &optional trash)
"Like `delete-file' for Tramp files."
- (setq filename (expand-file-name (expand-file-name filename)))
- (with-parsed-tramp-file-name filename nil
- (if (and delete-by-moving-to-trash trash)
- (move-file-to-trash filename)
- (tramp-barf-unless-okay
- v (format "rm -f %s" (tramp-shell-quote-argument localname))
- "Couldn't delete %s" filename))
- (tramp-flush-file-properties v localname)))
+ (tramp-skeleton-delete-file filename trash
+ (tramp-barf-unless-okay
+ v (format "rm -f %s" (tramp-shell-quote-argument localname))
+ "Couldn't delete %s" filename)))
;; Dired.
@@ -2645,21 +2641,23 @@ The method used must be an out-of-band method."
(defun tramp-sh-handle-insert-directory
(filename switches &optional wildcard full-directory-p)
"Like `insert-directory' for Tramp files."
- (unless switches (setq switches ""))
- ;; Check, whether directory is accessible.
- (unless wildcard
- (access-file filename "Reading directory"))
- (with-parsed-tramp-file-name (expand-file-name filename) nil
- (if (and (featurep 'ls-lisp)
- (not ls-lisp-use-insert-directory-program))
- (tramp-handle-insert-directory
- filename switches wildcard full-directory-p)
- (when (stringp switches)
- (setq switches (split-string switches)))
- (setq switches
- (append switches (split-string (tramp-sh--quoting-style-options v))))
- (unless (tramp-get-ls-command-with v "--dired")
- (setq switches (delete "-N" (delete "--dired" switches))))
+ (if (and (boundp 'ls-lisp-use-insert-directory-program)
+ (not ls-lisp-use-insert-directory-program))
+ (tramp-handle-insert-directory
+ filename switches wildcard full-directory-p)
+ (unless switches (setq switches ""))
+ ;; Check, whether directory is accessible.
+ (unless wildcard
+ (access-file filename "Reading directory"))
+ (with-parsed-tramp-file-name (expand-file-name filename) nil
+ (let ((dired (tramp-get-ls-command-with v "--dired")))
+ (when (stringp switches)
+ (setq switches (split-string switches)))
+ (setq switches
+ (append switches (split-string (tramp-sh--quoting-style-options v))
+ (when dired `(,dired))))
+ (unless dired
+ (setq switches (delete "-N" (delete "--dired" switches)))))
(when wildcard
(setq wildcard (tramp-run-real-handler
#'file-name-nondirectory (list localname)))
@@ -2667,7 +2665,8 @@ The method used must be an out-of-band method."
#'file-name-directory (list localname))))
(unless (or full-directory-p (member "-d" switches))
(setq switches (append switches '("-d"))))
- (setq switches (mapconcat #'tramp-shell-quote-argument switches " "))
+ (setq switches (delete-dups switches)
+ switches (mapconcat #'tramp-shell-quote-argument switches " "))
(when wildcard
(setq switches (concat switches " " wildcard)))
(tramp-message
@@ -2720,7 +2719,7 @@ The method used must be an out-of-band method."
(save-restriction
(narrow-to-region beg-marker end-marker)
;; Check for "--dired" output.
- (when (re-search-backward
+ (when (search-backward-regexp
(rx bol "//DIRED//" (+ blank) (group (+ nonl)) eol)
nil 'noerror)
(let ((beg (match-beginning 1))
@@ -2735,7 +2734,7 @@ The method used must be an out-of-band method."
(put-text-property start end 'dired-filename t))))))
;; Remove trailing lines.
(goto-char (point-max))
- (while (re-search-backward (rx bol "//") nil 'noerror)
+ (while (search-backward-regexp (rx bol "//") nil 'noerror)
(forward-line 1)
(delete-region (match-beginning 0) (point))))
;; Reset multibyte if needed.
@@ -2747,7 +2746,7 @@ The method used must be an out-of-band method."
(unless (tramp-compat-string-search
"color" (tramp-get-connection-property v "ls" ""))
(goto-char (point-min))
- (while (re-search-forward ansi-color-control-seq-regexp nil t)
+ (while (search-forward-regexp ansi-color-control-seq-regexp nil t)
(replace-match "")))
;; Now decode what read if necessary. Stolen from `insert-directory'.
@@ -2794,7 +2793,8 @@ 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 (and (re-search-forward (rx bol (group (* blank) "total")) nil t)
+ (when (and (search-forward-regexp
+ (rx bol (group (* blank) "total")) nil t)
;; Emacs 29.1 or later.
(not (fboundp 'dired--insert-disk-space)))
(when-let ((available (get-free-disk-space ".")))
@@ -2823,8 +2823,7 @@ the result will be a local, non-Tramp, file name."
;; there could be the false positive "/:".
(if (or (and (eq system-type 'windows-nt)
(string-match-p
- (tramp-compat-rx
- bol (| (: alpha ":") (: (literal (or null-device "")) eol)))
+ (rx bol (| (: alpha ":") (: (literal (or null-device "")) eol)))
name))
(and (not (tramp-tramp-file-p name))
(not (tramp-tramp-file-p dir))))
@@ -2848,9 +2847,7 @@ the result will be a local, non-Tramp, file name."
;; supposed to find such a shell on the remote host. Please
;; tell me about it when this doesn't work on your system.
(when (string-match
- (tramp-compat-rx
- bos "~" (group (* (not "/"))) (group (* nonl)) eos)
- localname)
+ (rx bos "~" (group (* (not "/"))) (group (* nonl)) eos) localname)
(let ((uname (match-string 1 localname))
(fname (match-string 2 localname))
hname)
@@ -2861,7 +2858,8 @@ the result will be a local, non-Tramp, file name."
;; appropriate either, because ssh and companions might
;; use a user name from the config file.
(when (and (tramp-string-empty-or-nil-p uname)
- (string-match-p (rx bos "su" (? "do") eos) method))
+ (string-match-p
+ (rx bos (| "su" "sudo" "doas" "ksu") eos) method))
(setq uname user))
(when (setq hname (tramp-get-home-directory v uname))
(setq localname (concat hname fname)))))
@@ -3042,6 +3040,7 @@ implementation will be used."
v 'file-error "Stderr buffer `%s' not supported" stderr))
(with-current-buffer stderr
(setq buffer-read-only nil))
+ (tramp-taint-remote-process-buffer stderr)
;; Create named pipe.
(tramp-send-command
v (format (tramp-get-remote-mknod-or-mkfifo v) tmpstderr))
@@ -3219,8 +3218,7 @@ implementation will be used."
(format
"%s %s %s"
(tramp-get-method-parameter vec 'tramp-remote-shell)
- (mapconcat
- #'identity
+ (string-join
(tramp-get-method-parameter vec 'tramp-remote-shell-args)
" ")
(tramp-shell-quote-argument (format "kill -%d $$" i))))
@@ -3267,7 +3265,7 @@ implementation will be used."
;; Determine input.
(if (null infile)
(setq input (tramp-get-remote-null-device v))
- (setq infile (tramp-compat-file-name-unquote (expand-file-name infile)))
+ (setq infile (file-name-unquote (expand-file-name infile)))
(if (tramp-equal-remote default-directory infile)
;; INFILE is on the same remote host.
(setq input (tramp-unquote-file-local-name infile))
@@ -3644,6 +3642,40 @@ implementation will be used."
"decoding command or an scp program")
method)))))))))
+(defun tramp-bundle-read-file-names (vec files)
+ "Read file attributes of FILES and with one command fill the cache.
+FILES must be the local names only. The cache attributes to be
+filled are described in `tramp-bundle-read-file-names'."
+ (when files
+ (tramp-maybe-send-script
+ vec
+ (format tramp-bundle-read-file-names
+ (tramp-get-file-exists-command vec)
+ (format "%s -r" (tramp-get-test-command vec))
+ (format "%s -d" (tramp-get-test-command vec)))
+ "tramp_bundle_read_file_names")
+
+ (dolist
+ (elt
+ (with-current-buffer (tramp-get-connection-buffer vec)
+ ;; We cannot use `tramp-send-command-and-read', because
+ ;; this does not cooperate well with heredoc documents.
+ (unless (tramp-send-command-and-check
+ vec
+ (format
+ "tramp_bundle_read_file_names <<'%s'\n%s\n%s\n"
+ tramp-end-of-heredoc
+ (mapconcat #'tramp-shell-quote-argument files "\n")
+ tramp-end-of-heredoc))
+ (tramp-error vec 'file-error "%s" (tramp-get-buffer-string)))
+ ;; Read the expression.
+ (goto-char (point-min))
+ (read (current-buffer))))
+
+ (tramp-set-file-property vec (car elt) "file-exists-p" (nth 1 elt))
+ (tramp-set-file-property vec (car elt) "file-readable-p" (nth 2 elt))
+ (tramp-set-file-property vec (car elt) "file-directory-p" (nth 3 elt)))))
+
(defvar tramp-vc-registered-file-names nil
"List used to collect file names, which are checked during `vc-registered'.")
@@ -3689,36 +3721,7 @@ implementation will be used."
(tramp-message v 10 "\n%s" tramp-vc-registered-file-names)
;; Send just one command, in order to fill the cache.
- (when tramp-vc-registered-file-names
- (tramp-maybe-send-script
- v
- (format tramp-vc-registered-read-file-names
- (tramp-get-file-exists-command v)
- (format "%s -r" (tramp-get-test-command v)))
- "tramp_vc_registered_read_file_names")
-
- (dolist
- (elt
- (ignore-errors
- ;; We cannot use `tramp-send-command-and-read',
- ;; because this does not cooperate well with
- ;; heredoc documents.
- (tramp-send-command
- v
- (format
- "tramp_vc_registered_read_file_names <<'%s'\n%s\n%s\n"
- tramp-end-of-heredoc
- (mapconcat #'tramp-shell-quote-argument
- tramp-vc-registered-file-names
- "\n")
- tramp-end-of-heredoc))
- (with-current-buffer (tramp-get-connection-buffer v)
- ;; Read the expression.
- (goto-char (point-min))
- (read (current-buffer)))))
-
- (tramp-set-file-property
- v (car elt) (cadr elt) (cadr (cdr elt))))))
+ (tramp-bundle-read-file-names v tramp-vc-registered-file-names))
;; Second run. Now all `file-exists-p' or `file-readable-p'
;; calls shall be answered from the file cache. We unset
@@ -3759,8 +3762,10 @@ implementation will be used."
"Invoke remote-shell Tramp file name handler.
Fall back to normal file name handler if no Tramp handler exists."
(if-let ((fn (assoc operation tramp-sh-file-name-handler-alist)))
- (save-match-data (apply (cdr fn) args))
- (tramp-run-real-handler operation args)))
+ (prog1 (save-match-data (apply (cdr fn) args))
+ (setq tramp-debug-message-fnh-function (cdr fn)))
+ (prog1 (tramp-run-real-handler operation args)
+ (setq tramp-debug-message-fnh-function operation))))
;;;###tramp-autoload
(defun tramp-sh-file-name-handler-p (vec)
@@ -3822,11 +3827,12 @@ Fall back to normal file name handler if no Tramp handler exists."
(cond
((and (memq 'change flags) (memq 'attribute-change flags))
(concat "create,modify,move,moved_from,moved_to,move_self,"
- "delete,delete_self,attrib,ignored"))
+ "delete,delete_self,attrib"))
((memq 'change flags)
(concat "create,modify,move,moved_from,moved_to,move_self,"
- "delete,delete_self,ignored"))
- ((memq 'attribute-change flags) "attrib,ignored"))
+ "delete,delete_self"))
+ ((memq 'attribute-change flags) "attrib"))
+ events (concat events ",ignored,unmount")
;; "-P" has been added to version 3.21, so we cannot assume it yet.
sequence `(,command "-mq" "-e" ,events ,localname)
;; Make events a list of symbols.
@@ -3841,10 +3847,10 @@ Fall back to normal file name handler if no Tramp handler exists."
(cond
((and (memq 'change flags) (memq 'attribute-change flags))
'(created changed changes-done-hint moved deleted
- attribute-changed))
+ attribute-changed unmounted))
((memq 'change flags)
- '(created changed changes-done-hint moved deleted))
- ((memq 'attribute-change flags) '(attribute-changed)))
+ '(created changed changes-done-hint moved deleted unmounted))
+ ((memq 'attribute-change flags) '(attribute-changed unmounted)))
sequence `(,command "monitor" ,localname)))
;; None.
(t (tramp-error
@@ -3864,8 +3870,6 @@ Fall back to normal file name handler if no Tramp handler exists."
v 'file-notify-error
"`%s' failed to start on remote host"
(string-join sequence " "))
- (tramp-message v 6 "Run `%s', %S" (string-join sequence " ") p)
- (process-put p 'tramp-vector v)
;; This is needed for ssh or PuTTY based processes, and only if
;; the respective options are set. Perhaps, the setting could
;; be more fine-grained.
@@ -3873,9 +3877,9 @@ Fall back to normal file name handler if no Tramp handler exists."
;; Needed for process filter.
(process-put p 'tramp-events events)
(process-put p 'tramp-watch-name localname)
- (set-process-query-on-exit-flag p nil)
(set-process-filter p filter)
(set-process-sentinel p #'tramp-file-notify-process-sentinel)
+ (tramp-post-process-creation p v)
;; There might be an error if the monitor is not supported.
;; Give the filter a chance to read the output.
(while (tramp-accept-process-output p))
@@ -3939,7 +3943,7 @@ Fall back to normal file name handler if no Tramp handler exists."
(setq string (tramp-compat-string-replace "\n\n" "\n" string))
(while (string-match
- (tramp-compat-rx
+ (rx
bol (+ (not ":")) ":" blank
(group (+ (not ":"))) ":" blank
(group (regexp (regexp-opt tramp-gio-events)))
@@ -4043,66 +4047,55 @@ commands. \"%n\" is replaced by \"2>/dev/null\", and \"%t\" is
replaced by a temporary file name. If VEC is nil, the respective
local commands are used. If there is a format specifier which
cannot be expanded, this function returns nil."
- (if (not (string-match-p
- (tramp-compat-rx (| bol (not "%")) "%" (any "ahlnoprsty")) script))
+ (if (not (string-match-p (rx (| bol (not "%")) "%" (any "ahlnoprsty")) script))
script
(catch 'wont-work
- (let ((awk (when (string-match-p
- (tramp-compat-rx (| bol (not "%")) "%a") script)
+ (let ((awk (when (string-match-p (rx (| bol (not "%")) "%a") script)
(or
(if vec (tramp-get-remote-awk vec) (executable-find "awk"))
(throw 'wont-work nil))))
- (hdmp (when (string-match-p
- (tramp-compat-rx (| bol (not "%")) "%h") script)
+ (hdmp (when (string-match-p (rx (| bol (not "%")) "%h") script)
(or
(if vec (tramp-get-remote-hexdump vec)
(executable-find "hexdump"))
(throw 'wont-work nil))))
- (dev (when (string-match-p
- (tramp-compat-rx (| bol (not "%")) "%n") script)
+ (dev (when (string-match-p (rx (| bol (not "%")) "%n") script)
(or
(if vec (concat "2>" (tramp-get-remote-null-device vec))
(if (eq system-type 'windows-nt) ""
(concat "2>" null-device)))
(throw 'wont-work nil))))
- (ls (when (string-match-p
- (tramp-compat-rx (| bol (not "%")) "%l") script)
+ (ls (when (string-match-p (rx (| bol (not "%")) "%l") script)
(format "%s %s"
(or (tramp-get-ls-command vec)
(throw 'wont-work nil))
(tramp-sh--quoting-style-options vec))))
- (od (when (string-match-p
- (tramp-compat-rx (| bol (not "%")) "%o") script)
+ (od (when (string-match-p (rx (| bol (not "%")) "%o") script)
(or (if vec (tramp-get-remote-od vec) (executable-find "od"))
(throw 'wont-work nil))))
- (perl (when (string-match-p
- (tramp-compat-rx (| bol (not "%")) "%p") script)
+ (perl (when (string-match-p (rx (| bol (not "%")) "%p") script)
(or
(if vec
(tramp-get-remote-perl vec) (executable-find "perl"))
(throw 'wont-work nil))))
- (python (when (string-match-p
- (tramp-compat-rx (| bol (not "%")) "%y") script)
- (or
- (if vec
- (tramp-get-remote-python vec)
- (executable-find "python"))
- (throw 'wont-work nil))))
- (readlink (when (string-match-p
- (tramp-compat-rx (| bol (not "%")) "%r") script)
+ (python (when (string-match-p (rx (| bol (not "%")) "%y") script)
+ (or
+ (if vec
+ (tramp-get-remote-python vec)
+ (executable-find "python"))
+ (throw 'wont-work nil))))
+ (readlink (when (string-match-p (rx (| bol (not "%")) "%r") script)
(or
(if vec
- (tramp-get-remote-readlink vec)
- (executable-find "readlink"))
- (throw 'wont-work nil))))
- (stat (when (string-match-p
- (tramp-compat-rx (| bol (not "%")) "%s") script)
+ (tramp-get-remote-readlink vec)
+ (executable-find "readlink"))
+ (throw 'wont-work nil))))
+ (stat (when (string-match-p (rx (| bol (not "%")) "%s") script)
(or
(if vec
(tramp-get-remote-stat vec) (executable-find "stat"))
(throw 'wont-work nil))))
- (tmp (when (string-match-p
- (tramp-compat-rx (| bol (not "%")) "%t") script)
+ (tmp (when (string-match-p (rx (| bol (not "%")) "%t") script)
(or
(if vec
(tramp-file-local-name (tramp-make-tramp-temp-name vec))
@@ -4124,7 +4117,7 @@ Only send the definition if it has not already been done."
(unless (member name scripts)
(with-tramp-progress-reporter
vec 5 (format-message "Sending script `%s'" name)
- ;; In bash, leading TABs like in `tramp-vc-registered-read-file-names'
+ ;; In bash, leading TABs like in `tramp-bundle-read-file-names'
;; could result in unwanted command expansion. Avoid this.
(setq script (tramp-compat-string-replace
(make-string 1 ?\t) (make-string 8 ? ) script))
@@ -4214,13 +4207,7 @@ variable PATH."
(format
"PATH=%s && export PATH"
(string-join (tramp-get-remote-path vec) ":")))
- (pipe-buf
- (with-tramp-connection-property vec "pipe-buf"
- (tramp-send-command-and-read
- vec
- (format "getconf PIPE_BUF / 2>%s || echo 4096"
- (tramp-get-remote-null-device vec))
- 'noerror)))
+ (pipe-buf (tramp-get-remote-pipe-buf vec))
tmpfile chunk chunksize)
(tramp-message vec 5 "Setting $PATH environment variable")
(if (tramp-compat-length< command pipe-buf)
@@ -4290,14 +4277,17 @@ file exists and nonzero exit status otherwise."
vec (format "%s %s" result existing))
(not (tramp-send-command-and-check
vec (format "%s %s" result nonexistent)))))
+ ;; We cannot use `tramp-get-ls-command', this results in an infloop.
+ ;; (Bug#65321)
(ignore-errors
- (and (setq result (format "%s -d" (tramp-get-ls-command vec)))
+ (and (setq result (format "ls -d >%s" (tramp-get-remote-null-device vec)))
(tramp-send-command-and-check
vec (format "%s %s" result existing))
(not (tramp-send-command-and-check
vec (format "%s %s" result nonexistent))))))
(tramp-error
vec 'file-error "Couldn't find command to check if file exists"))
+ (tramp-set-file-property vec existing "file-exists-p" t)
result))
(defun tramp-get-sh-extra-args (shell)
@@ -4360,8 +4350,7 @@ file exists and nonzero exit status otherwise."
"Couldn't find remote shell prompt for %s" shell)
(unless
(tramp-check-for-regexp
- (tramp-get-connection-process vec)
- (tramp-compat-rx (literal tramp-end-of-output)))
+ (tramp-get-connection-process vec) (rx (literal tramp-end-of-output)))
(tramp-wait-for-output (tramp-get-connection-process vec))
(tramp-message vec 5 "Setting shell prompt")
(tramp-send-command
@@ -4385,6 +4374,8 @@ file exists and nonzero exit status otherwise."
"`tramp-histfile-override' uses invalid file `%s'"
tramp-histfile-override))
+ (tramp-flush-connection-property
+ (tramp-get-connection-process vec) "scripts")
(tramp-set-connection-property
(tramp-get-connection-process vec) "remote-shell" shell)))
@@ -4402,8 +4393,7 @@ file exists and nonzero exit status otherwise."
(tramp-send-command
vec (format "echo ~%s" tramp-root-id-string) t)
(if (or (string-match-p
- (tramp-compat-rx
- bol "~" (literal tramp-root-id-string) eol)
+ (rx bol "~" (literal tramp-root-id-string) eol)
(buffer-string))
;; The default shell (ksh93) of OpenSolaris
;; and Solaris is buggy. We've got reports
@@ -4442,7 +4432,7 @@ seconds. If not, it produces an error message with the given ERROR-ARGS."
(condition-case nil
(tramp-wait-for-regexp
proc timeout
- (tramp-compat-rx
+ (rx
(| (regexp shell-prompt-pattern) (regexp tramp-shell-prompt-pattern))
(? (regexp ansi-color-control-seq-regexp))
eos))
@@ -4451,6 +4441,14 @@ seconds. If not, it produces an error message with the given ERROR-ARGS."
(apply #'tramp-error-with-buffer
(tramp-get-connection-buffer vec) vec 'file-error error-args)))))
+(defvar tramp-config-check nil
+ "A function to be called with one argument, VEC.
+It should return a string which is used to check, whether the
+configuration of the remote host has been changed (which would
+require flushing the cache data). This string is kept as
+connection property \"config-check-data\".
+This variable is intended as connection-local variable.")
+
(defun tramp-open-connection-setup-interactive-shell (proc vec)
"Set up an interactive shell.
Mainly sets the prompt and the echo correctly. PROC is the shell
@@ -4459,12 +4457,10 @@ process to set up. VEC specifies the connection."
(tramp-open-shell vec (tramp-get-method-parameter vec 'tramp-remote-shell))
(tramp-message vec 5 "Setting up remote shell environment")
- ;; Disable line editing.
- (tramp-send-command vec "set +o vi +o emacs" t)
-
- ;; Dump option settings in the traces.
- (when (>= tramp-verbose 9)
- (tramp-send-command vec "set -o" t))
+ ;; Disable line editing. Dump option settings in the traces.
+ (tramp-send-command
+ vec
+ (if (>= tramp-verbose 9) "set +o vi +o emacs -o" "set +o vi +o emacs") t)
;; Disable echo expansion.
(tramp-send-command
@@ -4497,7 +4493,7 @@ process to set up. VEC specifies the connection."
vec "uname"
(tramp-send-command-and-read vec "echo \\\"`uname -sr`\\\""))))
(config-check-function
- (tramp-get-method-parameter vec 'tramp-config-check))
+ (buffer-local-value 'tramp-config-check (process-buffer proc)))
(old-config-check
(and config-check-function
(tramp-get-connection-property vec "config-check-data")))
@@ -4604,7 +4600,7 @@ process to set up. VEC specifies the connection."
(tramp-send-command vec "set +H" t))
;; Disable tab expansion.
- (if (string-match-p (rx (| "BSD" "DragonFly" "Darwin")) uname)
+ (if (string-match-p tramp-bsd-unames uname)
(tramp-send-command vec "stty tabs" t)
(tramp-send-command vec "stty tab0" t))
@@ -4830,7 +4826,7 @@ Goes through the list `tramp-local-coding-commands' and
(with-current-buffer (tramp-get-connection-buffer vec)
(goto-char (point-min))
- (unless (looking-at-p (tramp-compat-rx (literal magic)))
+ (unless (looking-at-p (rx (literal magic)))
(throw 'wont-work-remote nil)))
;; `rem-enc' and `rem-dec' could be a string meanwhile.
@@ -4916,7 +4912,7 @@ Goes through the list `tramp-inline-compress-commands'."
nil t))
(throw 'next nil))
(goto-char (point-min))
- (unless (looking-at-p (tramp-compat-rx (literal magic)))
+ (unless (looking-at-p (rx (literal magic)))
(throw 'next nil)))
(tramp-message
vec 5
@@ -4927,7 +4923,7 @@ Goes through the list `tramp-inline-compress-commands'."
(throw 'next nil))
(with-current-buffer (tramp-get-buffer vec)
(goto-char (point-min))
- (unless (looking-at-p (tramp-compat-rx (literal magic)))
+ (unless (looking-at-p (rx (literal magic)))
(throw 'next nil)))
(setq found t)))
@@ -4963,12 +4959,19 @@ Goes through the list `tramp-inline-compress-commands'."
"Return the Control* arguments of the local ssh."
(cond
;; No options to be computed.
- ((or (null tramp-use-ssh-controlmaster-options)
+ ((or (null tramp-use-connection-share)
(null (assoc "%c" (tramp-get-method-parameter vec 'tramp-login-args))))
"")
+ ;; Use plink option.
+ ((string-match-p
+ (rx "plink" (? ".exe") eol)
+ (tramp-get-method-parameter vec 'tramp-login-program))
+ (if (eq tramp-use-connection-share 'suppress)
+ "-noshare" "-share"))
+
;; There is already a value to be used.
- ((and (eq tramp-use-ssh-controlmaster-options t)
+ ((and (eq tramp-use-connection-share t)
(stringp tramp-ssh-controlmaster-options))
tramp-ssh-controlmaster-options)
@@ -4982,18 +4985,26 @@ Goes through the list `tramp-inline-compress-commands'."
;; ControlMaster and ControlPath options are introduced in OpenSSH 3.9.
(concat
"-o ControlMaster="
- (if (eq tramp-use-ssh-controlmaster-options 'suppress)
+ (if (eq tramp-use-connection-share 'suppress)
"no" "auto")
" -o ControlPath="
- (if (eq tramp-use-ssh-controlmaster-options 'suppress)
+ (if (eq tramp-use-connection-share 'suppress)
"none"
- ;; Hashed tokens are introduced in OpenSSH 6.7.
- (if (tramp-ssh-option-exists-p vec "ControlPath=tramp.%C")
- "tramp.%%C" "tramp.%%r@%%h:%%p"))
+ ;; Hashed tokens are introduced in OpenSSH 6.7. On macOS
+ ;; we cannot use an absolute file name, it is too long.
+ ;; See Bug#19702.
+ (if (eq system-type 'darwin)
+ (if (tramp-ssh-option-exists-p vec "ControlPath=tramp.%C")
+ "tramp.%%C" "tramp.%%r@%%h:%%p")
+ (expand-file-name
+ (if (tramp-ssh-option-exists-p vec "ControlPath=tramp.%C")
+ "tramp.%%C" "tramp.%%r@%%h:%%p")
+ (or small-temporary-file-directory
+ tramp-compat-temporary-file-directory))))
;; ControlPersist option is introduced in OpenSSH 5.6.
- (when (and (not (eq tramp-use-ssh-controlmaster-options 'suppress))
+ (when (and (not (eq tramp-use-connection-share 'suppress))
(tramp-ssh-option-exists-p vec "ControlPersist=no"))
" -o ControlPersist=no"))))))
@@ -5080,7 +5091,7 @@ Goes through the list `tramp-inline-compress-commands'."
(tramp-call-process
vec1 tramp-encoding-shell nil t nil
tramp-encoding-command-switch
- (mapconcat #'identity command " "))
+ (string-join command " "))
(goto-char (point-min))
(not (search-forward "remotecommand" nil 'noerror)))))
@@ -5099,11 +5110,11 @@ Goes through the list `tramp-inline-compress-commands'."
found string)
(with-temp-buffer
;; Check hostkey of VEC2, seen from VEC1.
- (tramp-send-command vec1 (mapconcat #'identity command " "))
+ (tramp-send-command vec1 (string-join command " "))
;; Check hostkey of VEC2, seen locally.
(tramp-call-process
vec1 tramp-encoding-shell nil t nil tramp-encoding-command-switch
- (mapconcat #'identity command " "))
+ (string-join command " "))
(goto-char (point-min))
(while (and (not found) (not (eobp)))
(setq string
@@ -5150,240 +5161,240 @@ connection if a previous connection has died for some reason."
(unless (tramp-connectable-p vec)
(throw 'non-essential 'non-essential))
- (let ((p (tramp-get-connection-process vec))
- (process-name (tramp-get-connection-property vec "process-name"))
- (process-environment (copy-sequence process-environment))
- (pos (with-current-buffer (tramp-get-connection-buffer vec) (point))))
-
- ;; 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
- (time-since (cdr tramp-current-connection))
- (or tramp-connection-min-time-diff 0)))
- (throw 'suppress 'suppress))
-
- ;; If too much time has passed since last command was sent, look
- ;; whether process is still alive. If it isn't, kill it. When
- ;; using ssh, it can sometimes happen that the remote end has hung
- ;; up but the local ssh client doesn't recognize this until it
- ;; tries to send some data to the remote end. So that's why we
- ;; try to send a command from time to time, then look again
- ;; whether the process is really alive.
- (condition-case nil
- (when (and (time-less-p
- 60 (time-since
- (tramp-get-connection-property p "last-cmd-time" 0)))
- (process-live-p p))
- (tramp-send-command vec "echo are you awake" t t)
- (unless (and (process-live-p p)
- (tramp-wait-for-output p 10))
- ;; The error will be caught locally.
- (tramp-error vec 'file-error "Awake did fail")))
- (file-error
- (tramp-cleanup-connection vec t)
- (setq p nil)))
-
- ;; New connection must be opened.
- (condition-case err
- (unless (process-live-p p)
- (with-tramp-progress-reporter
- vec 3
- (if (tramp-string-empty-or-nil-p (tramp-file-name-user vec))
- (format "Opening connection %s for %s using %s"
+ (with-tramp-debug-message vec "Opening connection"
+ (let ((p (tramp-get-connection-process vec))
+ (process-name (tramp-get-connection-property vec "process-name"))
+ (process-environment (copy-sequence process-environment))
+ (pos (with-current-buffer (tramp-get-connection-buffer vec) (point))))
+
+ ;; 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
+ (time-since (cdr tramp-current-connection))
+ (or tramp-connection-min-time-diff 0)))
+ (throw 'suppress 'suppress))
+
+ ;; If too much time has passed since last command was sent, look
+ ;; whether process is still alive. If it isn't, kill it. When
+ ;; using ssh, it can sometimes happen that the remote end has
+ ;; hung up but the local ssh client doesn't recognize this until
+ ;; it tries to send some data to the remote end. So that's why
+ ;; we try to send a command from time to time, then look again
+ ;; whether the process is really alive.
+ (condition-case nil
+ (when (and (time-less-p
+ 60 (time-since
+ (tramp-get-connection-property p "last-cmd-time" 0)))
+ (process-live-p p))
+ (tramp-send-command vec "echo are you awake" t t)
+ (unless (and (process-live-p p)
+ (tramp-wait-for-output p 10))
+ ;; The error will be caught locally.
+ (tramp-error vec 'file-error "Awake did fail")))
+ (file-error
+ (tramp-cleanup-connection vec t)
+ (setq p nil)))
+
+ ;; New connection must be opened.
+ (condition-case err
+ (unless (process-live-p p)
+ (with-tramp-progress-reporter
+ vec 3
+ (if (tramp-string-empty-or-nil-p (tramp-file-name-user vec))
+ (format "Opening connection %s for %s using %s"
+ process-name
+ (tramp-file-name-host vec)
+ (tramp-file-name-method vec))
+ (format "Opening connection %s for %s@%s using %s"
process-name
+ (tramp-file-name-user vec)
(tramp-file-name-host vec)
- (tramp-file-name-method vec))
- (format "Opening connection %s for %s@%s using %s"
- process-name
- (tramp-file-name-user vec)
- (tramp-file-name-host vec)
- (tramp-file-name-method vec)))
-
- (catch 'uname-changed
- ;; Start new process.
- (when (and p (processp p))
- (delete-process p))
- (setenv "TERM" tramp-terminal-type)
- (setenv "LC_ALL" (tramp-get-local-locale vec))
- (if (stringp tramp-histfile-override)
- (setenv "HISTFILE" tramp-histfile-override)
- (if tramp-histfile-override
- (progn
- (setenv "HISTFILE")
- (setenv "HISTFILESIZE" "0")
- (setenv "HISTSIZE" "0"))))
- (setenv "PROMPT_COMMAND")
- (setenv "PS1" tramp-initial-end-of-output)
- (unless (stringp tramp-encoding-shell)
- (tramp-error vec 'file-error "`tramp-encoding-shell' not set"))
- (let* ((current-host tramp-system-name)
- (target-alist (tramp-compute-multi-hops vec))
- (previous-hop tramp-null-hop)
- ;; We will apply `tramp-ssh-controlmaster-options'
- ;; only for the first hop.
- (options (tramp-ssh-controlmaster-options vec))
- (process-connection-type tramp-process-connection-type)
- (process-adaptive-read-buffering nil)
- ;; There are unfortunate settings for "cmdproxy" on
- ;; W32 systems.
- (process-coding-system-alist nil)
- (coding-system-for-read nil)
- (extra-args (tramp-get-sh-extra-args tramp-encoding-shell))
- ;; This must be done in order to avoid our file
- ;; name handler.
- (p (let ((default-directory
- tramp-compat-temporary-file-directory))
- (apply
- #'start-process
- (tramp-get-connection-name vec)
- (tramp-get-connection-buffer vec)
- (append
- (list tramp-encoding-shell)
- (and extra-args (split-string extra-args))
- (and tramp-encoding-command-interactive
- (list tramp-encoding-command-interactive)))))))
-
- ;; Set sentinel and query flag. Initialize variables.
- (set-process-sentinel p #'tramp-process-sentinel)
- (process-put p 'tramp-vector vec)
- ;; This is needed for ssh or PuTTY based processes, and
- ;; only if the respective options are set. Perhaps,
- ;; the setting could be more fine-grained.
- ;; (process-put p 'tramp-shared-socket t)
- (process-put p 'adjust-window-size-function #'ignore)
- (set-process-query-on-exit-flag p nil)
- (setq tramp-current-connection (cons vec (current-time)))
-
- (tramp-message vec 6 "%s" (string-join (process-command p) " "))
-
- ;; Set connection-local variables.
- (tramp-set-connection-local-variables vec)
-
- ;; Check whether process is alive.
- (tramp-barf-if-no-shell-prompt
- p 10
- "Couldn't find local shell prompt for %s" tramp-encoding-shell)
-
- ;; Now do all the connections as specified.
- (while target-alist
- (let* ((hop (car target-alist))
- (l-method (tramp-file-name-method hop))
- (l-user (tramp-file-name-user hop))
- (l-domain (tramp-file-name-domain hop))
- (l-host (tramp-file-name-host hop))
- (l-port (tramp-file-name-port hop))
- (remote-shell
- (tramp-get-method-parameter hop 'tramp-remote-shell))
- (extra-args (tramp-get-sh-extra-args remote-shell))
- (async-args
- (tramp-compat-flatten-tree
- (tramp-get-method-parameter hop 'tramp-async-args)))
- (connection-timeout
- (tramp-get-method-parameter
- hop 'tramp-connection-timeout))
- (command
- (tramp-get-method-parameter hop 'tramp-login-program))
- ;; We don't create the temporary file. In
- ;; fact, it is just a prefix for the
- ;; ControlPath option of ssh; the real
- ;; temporary file has another name, and it is
- ;; created and protected by ssh. It is also
- ;; removed by ssh when the connection is
- ;; closed. The temporary file name is cached
- ;; in the main connection process, therefore
- ;; we cannot use `tramp-get-connection-process'.
- (tmpfile
- (with-tramp-connection-property
- (tramp-get-process vec) "temp-file"
- (tramp-compat-make-temp-name)))
- r-shell)
-
- ;; Check, whether there is a restricted shell.
- (dolist (elt tramp-restricted-shell-hosts-alist)
- (when (string-match-p elt current-host)
- (setq r-shell t)))
- (setq current-host l-host)
-
- ;; Set password prompt vector.
- (tramp-set-connection-property
- p "password-vector"
- (if (tramp-get-method-parameter
- hop 'tramp-password-previous-hop)
- (let ((pv (copy-tramp-file-name previous-hop)))
- (setf (tramp-file-name-method pv) l-method)
- pv)
- (make-tramp-file-name
- :method l-method :user l-user :domain l-domain
- :host l-host :port l-port)))
-
- ;; Set session timeout.
- (when (tramp-get-method-parameter
- hop 'tramp-session-timeout)
+ (tramp-file-name-method vec)))
+
+ (catch 'uname-changed
+ ;; Start new process.
+ (when (and p (processp p))
+ (delete-process p))
+ (setenv "TERM" tramp-terminal-type)
+ (setenv "LC_ALL" (tramp-get-local-locale vec))
+ (if (stringp tramp-histfile-override)
+ (setenv "HISTFILE" tramp-histfile-override)
+ (if tramp-histfile-override
+ (progn
+ (setenv "HISTFILE")
+ (setenv "HISTFILESIZE" "0")
+ (setenv "HISTSIZE" "0"))))
+ (setenv "PROMPT_COMMAND")
+ (setenv "PS1" tramp-initial-end-of-output)
+ (unless (stringp tramp-encoding-shell)
+ (tramp-error vec 'file-error "`tramp-encoding-shell' not set"))
+ (let* ((current-host tramp-system-name)
+ (target-alist (tramp-compute-multi-hops vec))
+ (previous-hop tramp-null-hop)
+ ;; We will apply `tramp-ssh-controlmaster-options'
+ ;; only for the first hop.
+ (options (tramp-ssh-controlmaster-options vec))
+ (process-connection-type tramp-process-connection-type)
+ (process-adaptive-read-buffering nil)
+ ;; There are unfortunate settings for
+ ;; "cmdproxy" on W32 systems.
+ (process-coding-system-alist nil)
+ (coding-system-for-read nil)
+ (extra-args
+ (tramp-get-sh-extra-args tramp-encoding-shell))
+ ;; This must be done in order to avoid our file
+ ;; name handler.
+ (p (let ((default-directory
+ tramp-compat-temporary-file-directory))
+ (apply
+ #'start-process
+ (tramp-get-connection-name vec)
+ (tramp-get-connection-buffer vec)
+ (append
+ `(,tramp-encoding-shell)
+ (and extra-args (split-string extra-args))
+ (and tramp-encoding-command-interactive
+ `(,tramp-encoding-command-interactive)))))))
+
+ ;; This is needed for ssh or PuTTY based processes,
+ ;; and only if the respective options are set.
+ ;; Perhaps, the setting could be more fine-grained.
+ ;; (process-put p 'tramp-shared-socket t)
+ ;; Set sentinel. Initialize variables.
+ (set-process-sentinel p #'tramp-process-sentinel)
+ (tramp-post-process-creation p vec)
+ (setq tramp-current-connection (cons vec (current-time)))
+
+ ;; Set connection-local variables.
+ (tramp-set-connection-local-variables vec)
+
+ ;; Check whether process is alive.
+ (tramp-barf-if-no-shell-prompt
+ p 10
+ "Couldn't find local shell prompt for %s"
+ tramp-encoding-shell)
+
+ ;; Now do all the connections as specified.
+ (while target-alist
+ (let* ((hop (car target-alist))
+ (l-method (tramp-file-name-method hop))
+ (l-user (tramp-file-name-user hop))
+ (l-domain (tramp-file-name-domain hop))
+ (l-host (tramp-file-name-host hop))
+ (l-port (tramp-file-name-port hop))
+ (remote-shell
+ (tramp-get-method-parameter hop 'tramp-remote-shell))
+ (extra-args (tramp-get-sh-extra-args remote-shell))
+ (async-args
+ (flatten-tree
+ (tramp-get-method-parameter hop 'tramp-async-args)))
+ (connection-timeout
+ (tramp-get-method-parameter
+ hop 'tramp-connection-timeout
+ tramp-connection-timeout))
+ (command
+ (tramp-get-method-parameter
+ hop 'tramp-login-program))
+ ;; We don't create the temporary file. In
+ ;; fact, it is just a prefix for the
+ ;; ControlPath option of ssh; the real
+ ;; temporary file has another name, and it
+ ;; is created and protected by ssh. It is
+ ;; also removed by ssh when the connection
+ ;; is closed. The temporary file name is
+ ;; cached in the main connection process,
+ ;; therefore we cannot use
+ ;; `tramp-get-connection-process'.
+ (tmpfile
+ (with-tramp-connection-property
+ (tramp-get-process vec) "temp-file"
+ (tramp-compat-make-temp-name)))
+ r-shell)
+
+ ;; Check, whether there is a restricted shell.
+ (dolist (elt tramp-restricted-shell-hosts-alist)
+ (when (string-match-p elt current-host)
+ (setq r-shell t)))
+ (setq current-host l-host)
+
+ ;; Set password prompt vector.
(tramp-set-connection-property
- p "session-timeout"
- (tramp-get-method-parameter
- hop 'tramp-session-timeout)))
-
- ;; Replace `login-args' place holders.
- (setq
- command
- (mapconcat
- #'identity
- (append
- ;; We do not want to see the trailing local
- ;; prompt in `start-file-process'.
- (unless r-shell '("exec"))
- `(,command)
- ;; Add arguments for asynchronous processes.
- (when process-name async-args)
- (tramp-expand-args
- hop 'tramp-login-args
- ?h (or l-host "") ?u (or l-user "") ?p (or l-port "")
- ?c (format-spec options (format-spec-make ?t tmpfile))
- ?n (concat
- "2>" (tramp-get-remote-null-device previous-hop))
- ?l (concat remote-shell " " extra-args " -i"))
- ;; A restricted shell does not allow "exec".
- (when r-shell '("&&" "exit")) '("||" "exit"))
- " "))
-
- ;; Send the command.
- (tramp-message vec 3 "Sending command `%s'" command)
- (tramp-send-command vec command t t)
- (tramp-process-actions
- p vec
- (min
- pos (with-current-buffer (process-buffer p) (point-max)))
- tramp-actions-before-shell
- (or connection-timeout tramp-connection-timeout))
- (tramp-message
- vec 3 "Found remote shell prompt on `%s'" l-host)
-
- ;; Next hop.
- (setq options ""
- target-alist (cdr target-alist)
- previous-hop hop)))
-
- ;; Activate session timeout.
- (when (tramp-get-connection-property p "session-timeout")
- (run-at-time
- (tramp-get-connection-property p "session-timeout") nil
- #'tramp-timeout-session vec))
-
- ;; Make initial shell settings.
- (tramp-open-connection-setup-interactive-shell p vec)
-
- ;; Mark it as connected.
- (tramp-set-connection-property p "connected" t)))))
-
- ;; Cleanup, and propagate the signal.
- ((error quit)
- (tramp-cleanup-connection vec t)
- (signal (car err) (cdr err))))))
+ p "password-vector"
+ (if (tramp-get-method-parameter
+ hop 'tramp-password-previous-hop)
+ (let ((pv (copy-tramp-file-name previous-hop)))
+ (setf (tramp-file-name-method pv) l-method)
+ pv)
+ (make-tramp-file-name
+ :method l-method :user l-user :domain l-domain
+ :host l-host :port l-port)))
+
+ ;; Set session timeout.
+ (when (tramp-get-method-parameter
+ hop 'tramp-session-timeout)
+ (tramp-set-connection-property
+ p "session-timeout"
+ (tramp-get-method-parameter
+ hop 'tramp-session-timeout)))
+
+ ;; Replace `login-args' place holders.
+ (setq
+ command
+ (string-join
+ (append
+ ;; We do not want to see the trailing local
+ ;; prompt in `start-file-process'.
+ (unless r-shell '("exec"))
+ `(,command)
+ ;; Add arguments for asynchronous processes.
+ (when process-name async-args)
+ (tramp-expand-args
+ hop 'tramp-login-args nil
+ ?h (or l-host "") ?u (or l-user "") ?p (or l-port "")
+ ?c (format-spec options (format-spec-make ?t tmpfile))
+ ?n (concat
+ "2>" (tramp-get-remote-null-device previous-hop))
+ ?l (concat remote-shell " " extra-args " -i"))
+ ;; A restricted shell does not allow "exec".
+ (when r-shell '("&&" "exit")) '("||" "exit"))
+ " "))
+
+ ;; Send the command.
+ (tramp-message vec 3 "Sending command `%s'" command)
+ (tramp-send-command vec command t t)
+ (tramp-process-actions
+ p vec
+ (min
+ pos (with-current-buffer (process-buffer p) (point-max)))
+ tramp-actions-before-shell connection-timeout)
+ (tramp-message
+ vec 3 "Found remote shell prompt on `%s'" l-host)
+
+ ;; Next hop.
+ (setq options ""
+ target-alist (cdr target-alist)
+ previous-hop hop)))
+
+ ;; Activate session timeout.
+ (when (tramp-get-connection-property p "session-timeout")
+ (run-at-time
+ (tramp-get-connection-property p "session-timeout") nil
+ #'tramp-timeout-session vec))
+
+ ;; Make initial shell settings.
+ (tramp-open-connection-setup-interactive-shell p vec)
+
+ ;; Mark it as connected.
+ (tramp-set-connection-property p "connected" t)))))
+
+ ;; Cleanup, and propagate the signal.
+ ((error quit)
+ (tramp-cleanup-connection vec t)
+ (signal (car err) (cdr err)))))))
(defun tramp-send-command (vec command &optional neveropen nooutput)
"Send the COMMAND to connection VEC.
@@ -5424,7 +5435,7 @@ function waits for output unless NOOUTPUT is set."
;; ignored. Busyboxes built with the EDITING_ASK_TERMINAL
;; config option send also ANSI control escape sequences,
;; which must be ignored.
- (regexp (tramp-compat-rx
+ (regexp (rx
(* (not (any "#$\n")))
(literal tramp-end-of-output)
(? (regexp ansi-color-control-seq-regexp))
@@ -5432,14 +5443,14 @@ function waits for output unless NOOUTPUT is set."
;; Sometimes, the commands do not return a newline but a
;; null byte before the shell prompt, for example "git
;; ls-files -c -z ...".
- (regexp1 (tramp-compat-rx (| bol "\000") (regexp regexp)))
+ (regexp1 (rx (| bol "\000") (regexp regexp)))
(found (tramp-wait-for-regexp proc timeout regexp1)))
(if found
(let ((inhibit-read-only t))
;; A simple-minded busybox has sent " ^H" sequences.
;; Delete them.
(goto-char (point-min))
- (when (re-search-forward
+ (when (search-forward-regexp
(rx bol (+ nonl "\b") eol) (line-end-position) t)
(forward-line 1)
(delete-region (point-min) (point)))
@@ -5472,8 +5483,7 @@ the exit status."
(let (cmd data)
(if (and (stringp command)
(string-match
- (tramp-compat-rx
- (* nonl) "<<'" (literal tramp-end-of-heredoc) "'" (* nonl))
+ (rx (* nonl) "<<'" (literal tramp-end-of-heredoc) "'" (* nonl))
command))
(setq cmd (match-string 0 command)
data (substring command (match-end 0)))
@@ -5522,7 +5532,7 @@ raises an error."
;; Read the marker.
(when (stringp marker)
(condition-case nil
- (re-search-forward marker)
+ (search-forward-regexp marker)
(error (unless noerror
(tramp-error
vec 'file-error
@@ -5535,7 +5545,7 @@ raises an error."
(unless noerror signal-hook-function)))
(read (current-buffer)))
;; Error handling.
- (when (re-search-forward (rx (not space)) (line-end-position) t)
+ (when (search-forward-regexp (rx (not space)) (line-end-position) t)
(error nil)))
(error (unless noerror
(tramp-error
@@ -5553,8 +5563,8 @@ raises an error."
string
""))
-(defun tramp-make-copy-program-file-name (vec)
- "Create a file name suitable for `scp', `pscp', or `nc' and workalikes."
+(defun tramp-make-copy-file-name (vec)
+ "Create a file name suitable for out-of-band methods."
(let ((method (tramp-file-name-method vec))
(user (tramp-file-name-user vec))
(host (tramp-file-name-host vec))
@@ -5565,13 +5575,13 @@ raises an error."
;; This does not work for MS Windows scp, if there are characters
;; to be quoted. OpenSSH 8 supports disabling of strict file name
;; checking in scp, we use it when available.
- (unless (string-match-p (rx "ftp" eos) method)
+ (unless (string-match-p (rx (| "dockercp" "podmancp" "ftp") eos) method)
(setq localname (tramp-unquote-shell-quote-argument localname)))
- (cond
- ((tramp-get-method-parameter vec 'tramp-remote-copy-program)
- localname)
- ((tramp-string-empty-or-nil-p user) (format "%s:%s" host localname))
- (t (format "%s@%s:%s" user host localname)))))
+ (string-join
+ (apply #'tramp-expand-args vec
+ 'tramp-copy-file-name tramp-default-copy-file-name
+ (list ?h (or host "") ?u (or user "") ?f localname))
+ "")))
(defun tramp-method-out-of-band-p (vec size)
"Return t if this is an out-of-band method, nil otherwise."
@@ -5592,6 +5602,7 @@ raises an error."
"Check whether REGEXP matches the connection property \"uname\"."
(string-match-p regexp (tramp-get-connection-property vec "uname" "")))
+;;;###tramp-autoload
(defun tramp-get-remote-path (vec)
"Compile list of remote directories for PATH.
Nonexistent directories are removed from spec."
@@ -5634,16 +5645,14 @@ Nonexistent directories are removed from spec."
(format
"%s %s %s 'echo %s \\\"$PATH\\\"'"
(tramp-get-method-parameter vec 'tramp-remote-shell)
- (mapconcat
- #'identity
+ (string-join
(tramp-get-method-parameter vec 'tramp-remote-shell-login)
" ")
- (mapconcat
- #'identity
+ (string-join
(tramp-get-method-parameter vec 'tramp-remote-shell-args)
" ")
(tramp-shell-quote-argument tramp-end-of-heredoc))
- 'noerror (tramp-compat-rx (literal tramp-end-of-heredoc)))
+ 'noerror (rx (literal tramp-end-of-heredoc)))
(progn
(tramp-message
vec 2 "Could not retrieve `tramp-own-remote-path'")
@@ -5666,22 +5675,37 @@ Nonexistent directories are removed from spec."
(setq remote-path (delq 'tramp-own-remote-path remote-path)))
;; Remove double entries.
- (setq elt1 remote-path)
- (while (consp elt1)
- (while (and (car elt1) (setq elt2 (member (car elt1) (cdr elt1))))
- (setcar elt2 nil))
- (setq elt1 (cdr elt1)))
+ (setq remote-path
+ (cl-remove-duplicates
+ remote-path :test #'string-equal :from-end t))
;; Remove non-existing directories.
- (delq
- nil
- (mapcar
- (lambda (x)
- (and
- (stringp x)
- (file-directory-p (tramp-make-tramp-file-name vec x))
- x))
- remote-path))))))
+ (let (remote-file-name-inhibit-cache)
+ (tramp-bundle-read-file-names vec remote-path)
+ (cl-remove-if
+ (lambda (x) (not (tramp-get-file-property vec x "file-directory-p")))
+ remote-path))))))
+
+;; The PIPE_BUF in POSIX [1] can be as low as 512 [2]. Here are the values
+;; on various platforms:
+;; - 512 on macOS, FreeBSD, NetBSD, OpenBSD, MirBSD, native Windows.
+;; - 4 KiB on Linux, OSF/1, Cygwin, Haiku.
+;; - 5 KiB on Solaris.
+;; - 8 KiB on HP-UX, Plan9.
+;; - 10 KiB on IRIX.
+;; - 32 KiB on AIX, Minix.
+;; [1] https://pubs.opengroup.org/onlinepubs/9699919799/functions/write.html
+;; [2] https://pubs.opengroup.org/onlinepubs/9699919799/basedefs/limits.h.html
+;; See Bug#65324.
+;;;###tramp-autoload
+(defun tramp-get-remote-pipe-buf (vec)
+ "Return PIPE_BUF config from the remote side."
+ (with-tramp-connection-property vec "pipe-buf"
+ (tramp-send-command-and-read
+ vec
+ (format "getconf PIPE_BUF / 2>%s || echo 4096"
+ (tramp-get-remote-null-device vec))
+ 'noerror)))
(defun tramp-get-remote-locale (vec)
"Determine remote locale, supporting UTF8 if possible."
@@ -5693,8 +5717,7 @@ Nonexistent directories are removed from spec."
(while candidates
(goto-char (point-min))
(if (string-match-p
- (tramp-compat-rx bol (literal (car candidates)) (? "\r") eol)
- (buffer-string))
+ (rx bol (literal (car candidates)) (? "\r") eol) (buffer-string))
(setq locale (car candidates)
candidates nil)
(setq candidates (cdr candidates)))))
@@ -5707,7 +5730,10 @@ Nonexistent directories are removed from spec."
(tramp-message vec 5 "Finding a suitable `ls' command")
(or
(catch 'ls-found
- (dolist (cmd '("ls" "gnuls" "gls"))
+ (dolist (cmd
+ ;; Prefer GNU ls on *BSD and macOS.
+ (if (tramp-check-remote-uname vec tramp-bsd-unames)
+ '( "gls" "ls" "gnuls") '("ls" "gnuls" "gls")))
(let ((dl (tramp-get-remote-path vec))
result)
(while (and dl (setq result (tramp-find-executable vec cmd dl t t)))
@@ -5772,7 +5798,7 @@ Nonexistent directories are removed from spec."
vec (format "( %s / -nt / )" (tramp-get-test-command vec)))
(with-current-buffer (tramp-get-buffer vec)
(goto-char (point-min))
- (when (looking-at-p (tramp-compat-rx (literal tramp-end-of-output)))
+ (when (looking-at-p (rx (literal tramp-end-of-output)))
(format "%s %%s -nt %%s" (tramp-get-test-command vec)))))
(progn
(tramp-send-command
@@ -5855,14 +5881,6 @@ Nonexistent directories are removed from spec."
vec (format "%s --canonicalize-missing /" result)))
result))))
-(defun tramp-get-remote-trash (vec)
- "Determine remote `trash' command.
-This command is returned only if `delete-by-moving-to-trash' is non-nil."
- (and delete-by-moving-to-trash
- (with-tramp-connection-property vec "trash"
- (tramp-message vec 5 "Finding a suitable `trash' command")
- (tramp-find-executable vec "trash" (tramp-get-remote-path vec)))))
-
(defun tramp-get-remote-touch (vec)
"Determine remote `touch' command."
(with-tramp-connection-property vec "touch"
diff --git a/lisp/net/tramp-smb.el b/lisp/net/tramp-smb.el
index 6d5697ad9ec..3616cad2fb3 100644
--- a/lisp/net/tramp-smb.el
+++ b/lisp/net/tramp-smb.el
@@ -53,7 +53,7 @@
;;;###tramp-autoload
(tramp--with-startup
(add-to-list 'tramp-default-user-alist
- `(,(tramp-compat-rx bos (literal tramp-smb-method) eos) nil nil))
+ `(,(rx bos (literal tramp-smb-method) eos) nil nil))
;; Add completion function for SMB method.
(tramp-set-completion-function
@@ -68,8 +68,8 @@
(defcustom tramp-smb-acl-program "smbcacls"
"Name of SMB acls to run."
:group 'tramp
- :type 'string
- :version "24.4")
+ :version "24.4"
+ :type 'string)
(defcustom tramp-smb-conf null-device
"Path of the \"smb.conf\" file.
@@ -85,16 +85,16 @@ They are added to the `tramp-smb-program' call via \"--option '...'\".
For example, if the deprecated SMB1 protocol shall be used, add to
this variable \"client min protocol=NT1\"."
:group 'tramp
- :type '(repeat string)
- :version "28.1")
+ :version "28.1"
+ :type '(repeat string))
(defvar tramp-smb-version nil
"Version string of the SMB client.")
(defconst tramp-smb-server-version
- (tramp-compat-rx "Domain=[" (* (not "]")) "] "
- "OS=[" (* (not "]")) "] "
- "Server=[" (* (not "]")) "]")
+ (rx "Domain=[" (* (not "]")) "] "
+ "OS=[" (* (not "]")) "] "
+ "Server=[" (* (not "]")) "]")
"Regexp of SMB server identification.")
(defconst tramp-smb-prompt
@@ -246,6 +246,7 @@ See `tramp-actions-before-shell' for more info.")
(file-file-equal-p . tramp-handle-file-equal-p)
(file-executable-p . tramp-handle-file-exists-p)
(file-exists-p . tramp-handle-file-exists-p)
+ (file-group-gid . tramp-handle-file-group-gid)
(file-in-directory-p . tramp-handle-file-in-directory-p)
(file-local-copy . tramp-smb-handle-file-local-copy)
(file-locked-p . tramp-handle-file-locked-p)
@@ -269,6 +270,7 @@ See `tramp-actions-before-shell' for more info.")
(file-symlink-p . tramp-handle-file-symlink-p)
(file-system-info . tramp-smb-handle-file-system-info)
(file-truename . tramp-handle-file-truename)
+ (file-user-uid . tramp-handle-file-user-uid)
(file-writable-p . tramp-smb-handle-file-writable-p)
(find-backup-file-name . tramp-handle-find-backup-file-name)
;; `get-file-buffer' performed by default handler.
@@ -316,22 +318,22 @@ Operations not mentioned here will be handled by the default Emacs primitives.")
If it isn't found in the local $PATH, the absolute path of winexe
shall be given. This is needed for remote processes."
:group 'tramp
- :type 'string
- :version "24.3")
+ :version "24.3"
+ :type 'string)
(defcustom tramp-smb-winexe-shell-command "powershell.exe"
"Shell to be used for processes on remote machines.
This must be Powershell V2 compatible."
:group 'tramp
- :type 'string
- :version "24.3")
+ :version "24.3"
+ :type 'string)
(defcustom tramp-smb-winexe-shell-command-switch "-file -"
"Command switch used together with `tramp-smb-winexe-shell-command'.
This can be used to disable echo etc."
:group 'tramp
- :type 'string
- :version "24.3")
+ :version "24.3"
+ :type 'string)
;; It must be a `defsubst' in order to push the whole code into
;; tramp-loaddefs.el. Otherwise, there would be recursive autoloading.
@@ -347,8 +349,10 @@ This can be used to disable echo etc."
First arg specifies the OPERATION, second arg is a list of
arguments to pass to the OPERATION."
(if-let ((fn (assoc operation tramp-smb-file-name-handler-alist)))
- (save-match-data (apply (cdr fn) args))
- (tramp-run-real-handler operation args)))
+ (prog1 (save-match-data (apply (cdr fn) args))
+ (setq tramp-debug-message-fnh-function (cdr fn)))
+ (prog1 (tramp-run-real-handler operation args)
+ (setq tramp-debug-message-fnh-function operation))))
;;;###tramp-autoload
(unless (memq system-type '(cygwin windows-nt))
@@ -555,13 +559,7 @@ arguments to pass to the OPERATION."
(tramp-get-connection-name v)
(tramp-get-connection-buffer v)
tramp-smb-program args)))
-
- (tramp-message
- v 6 "%s" (string-join (process-command p) " "))
- (process-put p 'tramp-vector v)
- (process-put
- p 'adjust-window-size-function #'ignore)
- (set-process-query-on-exit-flag p nil)
+ (tramp-post-process-creation p v)
(tramp-process-actions
p v nil tramp-smb-actions-with-tar)
@@ -620,7 +618,7 @@ PRESERVE-UID-GID and PRESERVE-EXTENDED-ATTRIBUTES are completely ignored."
;; with `jka-compr-handler', so we cannot trust its result as
;; indication for a remote file name.
(if-let ((tmpfile
- (and (file-remote-p filename) (file-local-copy filename))))
+ (and (tramp-tramp-file-p filename) (file-local-copy filename))))
;; Remote filename.
(condition-case err
(rename-file tmpfile newname ok-if-already-exists)
@@ -697,24 +695,17 @@ PRESERVE-UID-GID and PRESERVE-EXTENDED-ATTRIBUTES are completely ignored."
(defun tramp-smb-handle-delete-file (filename &optional trash)
"Like `delete-file' for Tramp files."
- (setq filename (expand-file-name filename))
- (when (file-exists-p filename)
- (with-parsed-tramp-file-name filename nil
- ;; We must also flush the cache of the directory, because
- ;; `file-attributes' reads the values from there.
- (tramp-flush-file-properties v localname)
- (if (and delete-by-moving-to-trash trash)
- (move-file-to-trash filename)
- (unless (tramp-smb-send-command
- v (format
- "%s %s"
- (if (tramp-smb-get-cifs-capabilities v) "posix_unlink" "rm")
- (tramp-smb-shell-quote-localname v)))
- ;; Error.
- (with-current-buffer (tramp-get-connection-buffer v)
- (goto-char (point-min))
- (search-forward-regexp tramp-smb-errors nil t)
- (tramp-error v 'file-error "%s `%s'" (match-string 0) filename)))))))
+ (tramp-skeleton-delete-file filename trash
+ (unless (tramp-smb-send-command
+ v (format
+ "%s %s"
+ (if (tramp-smb-get-cifs-capabilities v) "posix_unlink" "rm")
+ (tramp-smb-shell-quote-localname v)))
+ ;; Error.
+ (with-current-buffer (tramp-get-connection-buffer v)
+ (goto-char (point-min))
+ (search-forward-regexp tramp-smb-errors nil t)
+ (tramp-error v 'file-error "%s `%s'" (match-string 0) filename)))))
(defun tramp-smb-handle-expand-file-name (name &optional dir)
"Like `expand-file-name' for Tramp files."
@@ -736,8 +727,7 @@ PRESERVE-UID-GID and PRESERVE-EXTENDED-ATTRIBUTES are completely ignored."
(setq localname (file-name-unquote localname)))
;; Tilde expansion if necessary.
(when (string-match
- (tramp-compat-rx bos "~" (group (* (not "/"))) (group (* nonl)) eos)
- localname)
+ (rx bos "~" (group (* (not "/"))) (group (* nonl)) eos) localname)
(let ((uname (match-string 1 localname))
(fname (match-string 2 localname))
hname)
@@ -828,12 +818,7 @@ PRESERVE-UID-GID and PRESERVE-EXTENDED-ATTRIBUTES are completely ignored."
(tramp-get-connection-name v)
(tramp-get-connection-buffer v)
tramp-smb-acl-program args)))
-
- (tramp-message
- v 6 "%s" (string-join (process-command p) " "))
- (process-put p 'tramp-vector v)
- (process-put p 'adjust-window-size-function #'ignore)
- (set-process-query-on-exit-flag p nil)
+ (tramp-post-process-creation p v)
(tramp-process-actions p v nil tramp-smb-actions-get-acl)
(when (> (point-max) (point-min))
(substring-no-properties (buffer-string))))))))))))
@@ -887,7 +872,7 @@ PRESERVE-UID-GID and PRESERVE-EXTENDED-ATTRIBUTES are completely ignored."
;; Loop the listing.
(with-current-buffer (tramp-get-connection-buffer vec)
(goto-char (point-min))
- (unless (re-search-forward tramp-smb-errors nil t)
+ (unless (search-forward-regexp tramp-smb-errors nil t)
(while (not (eobp))
(cond
((looking-at
@@ -1089,8 +1074,7 @@ PRESERVE-UID-GID and PRESERVE-EXTENDED-ATTRIBUTES are completely ignored."
;; Check for matching entries.
(mapcar
(lambda (x)
- (when (string-match-p
- (tramp-compat-rx bol (literal base)) (nth 0 x))
+ (when (string-match-p (rx bol (literal base)) (nth 0 x))
x))
entries)
;; We just need the only and only entry FILENAME.
@@ -1178,101 +1162,31 @@ PRESERVE-UID-GID and PRESERVE-EXTENDED-ATTRIBUTES are completely ignored."
(defun tramp-smb-handle-make-directory (dir &optional parents)
"Like `make-directory' for Tramp files."
- (setq dir (directory-file-name (expand-file-name dir)))
- (unless (file-name-absolute-p dir)
- (setq dir (expand-file-name dir default-directory)))
- (with-parsed-tramp-file-name dir nil
- (when (and (null parents) (file-exists-p dir))
- (tramp-error v 'file-already-exists dir))
- (let* ((ldir (file-name-directory dir)))
- ;; Make missing directory parts.
- (when (and parents
- (tramp-smb-get-share v)
- (not (file-directory-p ldir)))
- (make-directory ldir parents))
- ;; Just do it.
- (when (file-directory-p ldir)
- (tramp-smb-send-command
- v (if (tramp-smb-get-cifs-capabilities v)
- (format "posix_mkdir %s %o"
- (tramp-smb-shell-quote-localname v) (default-file-modes))
- (format "mkdir %s" (tramp-smb-shell-quote-localname v))))
- ;; We must also flush the cache of the directory, because
- ;; `file-attributes' reads the values from there.
- (tramp-flush-file-properties v localname))
- (unless (file-directory-p dir)
- (tramp-error v 'file-error "Couldn't make directory %s" dir)))))
-
-;; This is not used anymore.
-(defun tramp-smb-handle-make-directory-internal (directory)
- "Like `make-directory-internal' for Tramp files."
- (declare (obsolete nil "29.1"))
- (setq directory (directory-file-name (expand-file-name directory)))
- (unless (file-name-absolute-p directory)
- (setq directory (expand-file-name directory default-directory)))
- (with-parsed-tramp-file-name directory nil
- (when (file-directory-p (file-name-directory directory))
- (tramp-smb-send-command
- v (if (tramp-smb-get-cifs-capabilities v)
- (format "posix_mkdir %s %o"
- (tramp-smb-shell-quote-localname v) (default-file-modes))
- (format "mkdir %s" (tramp-smb-shell-quote-localname v))))
- ;; We must also flush the cache of the directory, because
- ;; `file-attributes' reads the values from there.
- (tramp-flush-file-properties v localname))
- (unless (file-directory-p directory)
- (tramp-error v 'file-error "Couldn't make directory %s" directory))))
+ (tramp-skeleton-make-directory dir parents
+ (tramp-smb-send-command
+ v (if (tramp-smb-get-cifs-capabilities v)
+ (format "posix_mkdir %s %o"
+ (tramp-smb-shell-quote-localname v) (default-file-modes))
+ (format "mkdir %s" (tramp-smb-shell-quote-localname v))))
+ (unless (file-directory-p dir)
+ (tramp-error v 'file-error "Couldn't make directory %s" dir))))
(defun tramp-smb-handle-make-symbolic-link
- (target linkname &optional ok-if-already-exists)
- "Like `make-symbolic-link' for Tramp files.
-If TARGET is a non-Tramp file, it is used verbatim as the target
-of the symlink. If TARGET is a Tramp file, only the localname
-component is used as the target of the symlink."
- (with-parsed-tramp-file-name linkname nil
- ;; If TARGET is a Tramp name, use just the localname component.
- ;; Don't check for a proper method.
- (let ((non-essential t))
- (when (and (tramp-tramp-file-p target)
- (tramp-file-name-equal-p v (tramp-dissect-file-name target)))
- (setq target (tramp-file-local-name (expand-file-name target))))
- ;; There could be a cyclic link.
- (tramp-flush-file-properties
- v (expand-file-name target (tramp-file-local-name default-directory))))
-
- ;; If TARGET is still remote, quote it.
- (if (tramp-tramp-file-p target)
- (make-symbolic-link
- (tramp-compat-file-name-quote target 'top)
- linkname ok-if-already-exists)
-
- ;; Do the 'confirm if exists' thing.
- (when (file-exists-p linkname)
- ;; What to do?
- (if (or (null ok-if-already-exists) ; not allowed to exist
- (and (numberp ok-if-already-exists)
- (not (yes-or-no-p
- (format
- "File %s already exists; make it a link anyway?"
- localname)))))
- (tramp-error v 'file-already-exists localname)
- (delete-file linkname)))
-
- (unless (tramp-smb-get-cifs-capabilities v)
- (tramp-error v 'file-error "make-symbolic-link not supported"))
-
- ;; We must also flush the cache of the directory, because
- ;; `file-attributes' reads the values from there.
- (tramp-flush-file-properties v localname)
-
- (unless (tramp-smb-send-command
- v (format "symlink %s %s"
- (tramp-smb-shell-quote-argument target)
- (tramp-smb-shell-quote-localname v)))
- (tramp-error
- v 'file-error
- "error with make-symbolic-link, see buffer `%s' for details"
- (tramp-get-connection-buffer v))))))
+ (target linkname &optional ok-if-already-exists)
+ "Like `make-symbolic-link' for Tramp files."
+ (let ((v (tramp-dissect-file-name (expand-file-name linkname))))
+ (unless (tramp-smb-get-cifs-capabilities v)
+ (tramp-error v 'file-error "make-symbolic-link not supported")))
+
+ (tramp-skeleton-make-symbolic-link target linkname ok-if-already-exists
+ (unless (tramp-smb-send-command
+ v (format "symlink %s %s"
+ (tramp-smb-shell-quote-argument target)
+ (tramp-smb-shell-quote-localname v)))
+ (tramp-error
+ v 'file-error
+ "error with make-symbolic-link, see buffer `%s' for details"
+ (tramp-get-connection-buffer v)))))
(defun tramp-smb-handle-process-file
(program &optional infile destination display &rest args)
@@ -1289,7 +1203,7 @@ component is used as the target of the symlink."
;; Determine input.
(when infile
- (setq infile (tramp-compat-file-name-unquote (expand-file-name infile)))
+ (setq infile (file-name-unquote (expand-file-name infile)))
(if (tramp-equal-remote default-directory infile)
;; INFILE is on the same remote host.
(setq input (tramp-unquote-file-local-name infile))
@@ -1498,12 +1412,7 @@ component is used as the target of the symlink."
(tramp-get-connection-name v)
(tramp-get-connection-buffer v)
tramp-smb-acl-program args)))
-
- (tramp-message
- v 6 "%s" (string-join (process-command p) " "))
- (process-put p 'tramp-vector v)
- (process-put p 'adjust-window-size-function #'ignore)
- (set-process-query-on-exit-flag p nil)
+ (tramp-post-process-creation p v)
(tramp-process-actions p v nil tramp-smb-actions-set-acl)
;; This is meant for traces, and returning from
;; the function. No error is propagated outside,
@@ -1596,7 +1505,7 @@ component is used as the target of the symlink."
\"//\" substitutes only in the local filename part. Catches
errors for shares like \"C$/\", which are common in Microsoft Windows."
;; Check, whether the local part is a quoted file name.
- (if (tramp-compat-file-name-quoted-p filename)
+ (if (file-name-quoted-p filename)
filename
(with-parsed-tramp-file-name filename nil
;; Ignore in LOCALNAME everything before "//".
@@ -1649,8 +1558,7 @@ VEC or USER, or if there is no home directory, return nil."
"Return the share name of LOCALNAME."
(save-match-data
(let ((localname (tramp-file-name-unquote-localname vec)))
- (when (string-match
- (tramp-compat-rx bol (? "/") (group (+ (not "/"))) "/") localname)
+ (when (string-match (rx bol (? "/") (group (+ (not "/"))) "/") localname)
(match-string 1 localname)))))
(defun tramp-smb-get-localname (vec)
@@ -1661,8 +1569,7 @@ If VEC has no cifs capabilities, exchange \"/\" by \"\\\\\"."
(setq
localname
(if (string-match
- (tramp-compat-rx bol (? "/") (+ (not "/")) (group "/" (* nonl)))
- localname)
+ (rx bol (? "/") (+ (not "/")) (group "/" (* nonl))) localname)
;; There is a share, separated by "/".
(if (not (tramp-smb-get-cifs-capabilities vec))
(mapconcat
@@ -1670,8 +1577,7 @@ If VEC has no cifs capabilities, exchange \"/\" by \"\\\\\"."
(match-string 1 localname) "")
(match-string 1 localname))
;; There is just a share.
- (if (string-match
- (tramp-compat-rx bol (? "/") (group (+ (not "/"))) eol) localname)
+ (if (string-match (rx bol (? "/") (group (+ (not "/"))) eol) localname)
(match-string 1 localname)
"")))
@@ -1718,7 +1624,7 @@ Result is a list of (LOCALNAME MODE SIZE MONTH DAY TIME YEAR)."
;; Loop the listing.
(with-current-buffer (tramp-get-connection-buffer v)
(goto-char (point-min))
- (if (re-search-forward tramp-smb-errors nil t)
+ (if (search-forward-regexp tramp-smb-errors nil t)
(tramp-error v 'file-error "%s `%s'" (match-string 0) directory)
(while (not (eobp))
(setq entry (tramp-smb-read-file-entry share))
@@ -1799,8 +1705,7 @@ are listed. Result is the list (LOCALNAME MODE SIZE MTIME)."
(if (not share)
;; Read share entries.
- (when (string-match
- (tramp-compat-rx bol "Disk|" (group (+ (not "|"))) "|") line)
+ (when (string-match (rx bol "Disk|" (group (+ (not "|"))) "|") line)
(setq localname (match-string 1 line)
mode "dr-xr-xr-x"
size 0))
@@ -1910,8 +1815,8 @@ are listed. Result is the list (LOCALNAME MODE SIZE MTIME)."
(when (tramp-smb-send-command vec "posix")
(with-current-buffer (tramp-get-connection-buffer vec)
(goto-char (point-min))
- (when
- (re-search-forward "Server supports CIFS capabilities" nil t)
+ (when (search-forward-regexp
+ "Server supports CIFS capabilities" nil t)
(member
"pathnames"
(split-string
@@ -1947,157 +1852,152 @@ If ARGUMENT is non-nil, use it as argument for
(unless (tramp-connectable-p vec)
(throw 'non-essential 'non-essential))
- (let* ((share (tramp-smb-get-share vec))
- (buf (tramp-get-connection-buffer vec))
- (p (get-buffer-process buf)))
+ (with-tramp-debug-message vec "Opening connection"
+ (let* ((share (tramp-smb-get-share vec))
+ (buf (tramp-get-connection-buffer vec))
+ (p (get-buffer-process buf)))
+
+ ;; Check whether we still have the same smbclient version.
+ ;; Otherwise, we must delete the connection cache, because
+ ;; capabilities might have changed.
+ (unless (or argument (processp p))
+ (let ((default-directory tramp-compat-temporary-file-directory)
+ (command (concat tramp-smb-program " -V")))
+
+ (unless tramp-smb-version
+ (unless (executable-find tramp-smb-program)
+ (tramp-error
+ vec 'file-error
+ "Cannot find command %s in %s" tramp-smb-program exec-path))
+ (setq tramp-smb-version (shell-command-to-string command))
+ (tramp-message vec 6 command)
+ (tramp-message vec 6 "\n%s" tramp-smb-version)
+ (if (string-match (rx (+ (any " \t\r\n")) eos) tramp-smb-version)
+ (setq tramp-smb-version
+ (replace-match "" nil nil tramp-smb-version))))
+
+ (unless (string-equal
+ tramp-smb-version
+ (tramp-get-connection-property
+ vec "smbclient-version" tramp-smb-version))
+ (tramp-flush-directory-properties vec "/")
+ (tramp-flush-connection-properties vec))
+
+ (tramp-set-connection-property
+ vec "smbclient-version" tramp-smb-version)))
+
+ ;; If too much time has passed since last command was sent, look
+ ;; whether there has been an error message; maybe due to
+ ;; connection timeout.
+ (with-current-buffer buf
+ (goto-char (point-min))
+ (when (and (time-less-p
+ 60 (time-since
+ (tramp-get-connection-property p "last-cmd-time" 0)))
+ (process-live-p p)
+ (search-forward-regexp tramp-smb-errors nil t))
+ (delete-process p)
+ (setq p nil)))
+
+ ;; Check whether it is still the same share.
+ (unless (and (process-live-p p)
+ (or argument
+ (string-equal
+ share
+ (tramp-get-connection-property p "smb-share" ""))))
+ (save-match-data
+ ;; There might be unread output from checking for share names.
+ (when buf (with-current-buffer buf (erase-buffer)))
+ (when (and p (processp p)) (delete-process p))
- ;; Check whether we still have the same smbclient version.
- ;; Otherwise, we must delete the connection cache, because
- ;; capabilities might have changed.
- (unless (or argument (processp p))
- (let ((default-directory tramp-compat-temporary-file-directory)
- (command (concat tramp-smb-program " -V")))
+ (let* ((user (tramp-file-name-user vec))
+ (host (tramp-file-name-host vec))
+ (domain (tramp-file-name-domain vec))
+ (port (tramp-file-name-port vec))
+ (options tramp-smb-options)
+ args)
- (unless tramp-smb-version
- (unless (executable-find tramp-smb-program)
- (tramp-error
- vec 'file-error
- "Cannot find command %s in %s" tramp-smb-program exec-path))
- (setq tramp-smb-version (shell-command-to-string command))
- (tramp-message vec 6 command)
- (tramp-message vec 6 "\n%s" tramp-smb-version)
- (if (string-match (rx (+ (any " \t\r\n")) eos) tramp-smb-version)
- (setq tramp-smb-version
- (replace-match "" nil nil tramp-smb-version))))
-
- (unless (string-equal
- tramp-smb-version
- (tramp-get-connection-property
- vec "smbclient-version" tramp-smb-version))
- (tramp-flush-directory-properties vec "/")
- (tramp-flush-connection-properties vec))
-
- (tramp-set-connection-property
- vec "smbclient-version" tramp-smb-version)))
-
- ;; If too much time has passed since last command was sent, look
- ;; whether there has been an error message; maybe due to
- ;; connection timeout.
- (with-current-buffer buf
- (goto-char (point-min))
- (when (and (time-less-p
- 60 (time-since
- (tramp-get-connection-property p "last-cmd-time" 0)))
- (process-live-p p)
- (re-search-forward tramp-smb-errors nil t))
- (delete-process p)
- (setq p nil)))
-
- ;; Check whether it is still the same share.
- (unless (and (process-live-p p)
- (or argument
- (string-equal
- share
- (tramp-get-connection-property p "smb-share" ""))))
- (save-match-data
- ;; There might be unread output from checking for share names.
- (when buf (with-current-buffer buf (erase-buffer)))
- (when (and p (processp p)) (delete-process p))
-
- (let* ((user (tramp-file-name-user vec))
- (host (tramp-file-name-host vec))
- (domain (tramp-file-name-domain vec))
- (port (tramp-file-name-port vec))
- (options tramp-smb-options)
- args)
-
- (cond
- (argument
- (setq args (list (concat "//" host))))
- (share
- (setq args (list (concat "//" host "/" share))))
- (t
- (setq args (list "-g" "-L" host ))))
+ (cond
+ (argument (setq args (list (concat "//" host))))
+ (share (setq args (list (concat "//" host "/" share))))
+ (t (setq args (list "-g" "-L" host ))))
- (if (tramp-string-empty-or-nil-p user)
- (setq args (append args (list "-N")))
- (setq args (append args (list "-U" user))))
+ (if (tramp-string-empty-or-nil-p user)
+ (setq args (append args (list "-N")))
+ (setq args (append args (list "-U" user))))
- (when domain (setq args (append args (list "-W" domain))))
- (when port (setq args (append args (list "-p" port))))
- (when tramp-smb-conf
- (setq args (append args (list "-s" tramp-smb-conf))))
- (dolist (option options)
- (setq args (append args (list "--option" option))))
- (when argument
- (setq args (append args (list argument))))
-
- ;; OK, let's go.
- (with-tramp-progress-reporter
- vec 3
- (format "Opening connection for //%s%s/%s"
- (if (tramp-string-empty-or-nil-p user)
- "" (concat user "@"))
- host (or share ""))
-
- (let* (coding-system-for-read
- (process-connection-type tramp-process-connection-type)
- (p (let ((default-directory
- tramp-compat-temporary-file-directory)
- (process-environment
- (cons (concat "TERM=" tramp-terminal-type)
- process-environment)))
- (apply #'start-process
- (tramp-get-connection-name vec)
- (tramp-get-connection-buffer vec)
- (if argument
- tramp-smb-winexe-program tramp-smb-program)
- args))))
-
- (tramp-message vec 6 "%s" (string-join (process-command p) " "))
- (process-put p 'tramp-vector vec)
- (process-put p 'adjust-window-size-function #'ignore)
- (set-process-query-on-exit-flag p nil)
-
- ;; Set connection-local variables.
- (tramp-set-connection-local-variables vec)
-
- (condition-case err
- (let ((inhibit-message t))
- ;; Play login scenario.
- (tramp-process-actions
- p vec nil
- (if (or argument share)
- tramp-smb-actions-with-share
- tramp-smb-actions-without-share))
-
- ;; Set chunksize to 1. smbclient reads its input
- ;; character by character; if we send the string
- ;; at once, it is read painfully slow.
- (tramp-set-connection-property p "smb-share" share)
- (tramp-set-connection-property p "chunksize" 1)
-
- ;; Mark it as connected.
- (tramp-set-connection-property p "connected" t))
-
- ;; Check for the error reason. If it was due to wrong
- ;; password, reestablish the connection. We cannot
- ;; handle this in `tramp-process-actions', because
- ;; smbclient does not ask for the password, again.
- (error
- (with-current-buffer (tramp-get-connection-buffer vec)
- (goto-char (point-min))
- (if (and (bound-and-true-p auth-sources)
- (search-forward-regexp
- tramp-smb-wrong-passwd-regexp nil t))
- ;; Disable `auth-source' and `password-cache'.
- (let (auth-sources)
- (tramp-message
- vec 3 "Retry connection with new password")
- (tramp-cleanup-connection vec t)
- (tramp-smb-maybe-open-connection vec argument))
- ;; Propagate the error.
- (signal (car err) (cdr err)))))))))))))
+ (when domain (setq args (append args (list "-W" domain))))
+ (when port (setq args (append args (list "-p" port))))
+ (when tramp-smb-conf
+ (setq args (append args (list "-s" tramp-smb-conf))))
+ (dolist (option options)
+ (setq args (append args (list "--option" option))))
+ (when argument
+ (setq args (append args (list argument))))
+
+ ;; OK, let's go.
+ (with-tramp-progress-reporter
+ vec 3
+ (format "Opening connection for //%s%s/%s"
+ (if (tramp-string-empty-or-nil-p user)
+ "" (concat user "@"))
+ host (or share ""))
+
+ (let* (coding-system-for-read
+ (process-connection-type tramp-process-connection-type)
+ (p (let ((default-directory
+ tramp-compat-temporary-file-directory)
+ (process-environment
+ (cons (concat "TERM=" tramp-terminal-type)
+ process-environment)))
+ (apply #'start-process
+ (tramp-get-connection-name vec)
+ (tramp-get-connection-buffer vec)
+ (if argument
+ tramp-smb-winexe-program tramp-smb-program)
+ args))))
+ (tramp-post-process-creation p vec)
+
+ ;; Set connection-local variables.
+ (tramp-set-connection-local-variables vec)
+
+ (condition-case err
+ (let ((inhibit-message t))
+ ;; Play login scenario.
+ (tramp-process-actions
+ p vec nil
+ (if (or argument share)
+ tramp-smb-actions-with-share
+ tramp-smb-actions-without-share))
+
+ ;; Set chunksize to 1. smbclient reads its
+ ;; input character by character; if we send the
+ ;; string at once, it is read painfully slow.
+ (tramp-set-connection-property p "smb-share" share)
+ (tramp-set-connection-property p "chunksize" 1)
+
+ ;; Mark it as connected.
+ (tramp-set-connection-property p "connected" t))
+
+ ;; Check for the error reason. If it was due to
+ ;; wrong password, reestablish the connection. We
+ ;; cannot handle this in `tramp-process-actions',
+ ;; because smbclient does not ask for the password,
+ ;; again.
+ (error
+ (with-current-buffer (tramp-get-connection-buffer vec)
+ (goto-char (point-min))
+ (if (and (bound-and-true-p auth-sources)
+ (search-forward-regexp
+ tramp-smb-wrong-passwd-regexp nil t))
+ ;; Disable `auth-source' and `password-cache'.
+ (let (auth-sources)
+ (tramp-message
+ vec 3 "Retry connection with new password")
+ (tramp-cleanup-connection vec t)
+ (tramp-smb-maybe-open-connection vec argument))
+ ;; Propagate the error.
+ (signal (car err) (cdr err))))))))))))))
;; We don't use timeouts. If needed, the caller shall wrap around.
(defun tramp-smb-wait-for-output (vec)
@@ -2108,21 +2008,21 @@ Removes smb prompt. Returns nil if an error message has appeared."
(inhibit-read-only t))
;; Read pending output.
- (while (not (re-search-forward tramp-smb-prompt nil t))
+ (while (not (search-forward-regexp tramp-smb-prompt nil t))
(while (tramp-accept-process-output p))
(goto-char (point-min)))
(tramp-message vec 6 "\n%s" (buffer-string))
;; Remove prompt.
(goto-char (point-min))
- (when (re-search-forward tramp-smb-prompt nil t)
+ (when (search-forward-regexp tramp-smb-prompt nil t)
(goto-char (point-max))
- (re-search-backward tramp-smb-prompt nil t)
+ (search-backward-regexp tramp-smb-prompt nil t)
(delete-region (point) (point-max)))
;; Return value is whether no error message has appeared.
(goto-char (point-min))
- (not (re-search-forward tramp-smb-errors nil t)))))
+ (not (search-forward-regexp tramp-smb-errors nil t)))))
(defun tramp-smb-kill-winexe-function ()
"Send SIGKILL to the winexe process."
diff --git a/lisp/net/tramp-sshfs.el b/lisp/net/tramp-sshfs.el
index f258d75f6bf..d0d56b8967e 100644
--- a/lisp/net/tramp-sshfs.el
+++ b/lisp/net/tramp-sshfs.el
@@ -101,6 +101,7 @@
(file-equal-p . tramp-handle-file-equal-p)
(file-executable-p . tramp-fuse-handle-file-executable-p)
(file-exists-p . tramp-fuse-handle-file-exists-p)
+ (file-group-gid . tramp-handle-file-group-gid)
(file-in-directory-p . tramp-handle-file-in-directory-p)
(file-local-copy . tramp-handle-file-local-copy)
(file-locked-p . tramp-handle-file-locked-p)
@@ -124,6 +125,7 @@
(file-symlink-p . tramp-handle-file-symlink-p)
(file-system-info . tramp-sshfs-handle-file-system-info)
(file-truename . tramp-handle-file-truename)
+ (file-user-uid . tramp-handle-file-user-uid)
(file-writable-p . tramp-sshfs-handle-file-writable-p)
(find-backup-file-name . tramp-handle-find-backup-file-name)
;; `get-file-buffer' performed by default handler.
@@ -179,8 +181,10 @@ Operations not mentioned here will be handled by the default Emacs primitives.")
First arg specifies the OPERATION, second arg is a list of
arguments to pass to the OPERATION."
(if-let ((fn (assoc operation tramp-sshfs-file-name-handler-alist)))
- (save-match-data (apply (cdr fn) args))
- (tramp-run-real-handler operation args)))
+ (prog1 (save-match-data (apply (cdr fn) args))
+ (setq tramp-debug-message-fnh-function (cdr fn)))
+ (prog1 (tramp-run-real-handler operation args)
+ (setq tramp-debug-message-fnh-function operation))))
;;;###tramp-autoload
(tramp--with-startup
@@ -228,8 +232,7 @@ arguments to pass to the OPERATION."
(defun tramp-sshfs-handle-file-system-info (filename)
"Like `file-system-info' for Tramp files."
- ;;`file-system-info' exists since Emacs 27.1.
- (tramp-compat-funcall 'file-system-info (tramp-fuse-local-file-name filename)))
+ (file-system-info (tramp-fuse-local-file-name filename)))
(defun tramp-sshfs-handle-file-writable-p (filename)
"Like `file-writable-p' for Tramp files."
@@ -266,7 +269,7 @@ arguments to pass to the OPERATION."
;; Determine input.
(if (null infile)
(setq input (tramp-get-remote-null-device v))
- (setq infile (tramp-compat-file-name-unquote (expand-file-name infile)))
+ (setq infile (file-name-unquote (expand-file-name infile)))
(if (tramp-equal-remote default-directory infile)
;; INFILE is on the same remote host.
(setq input (tramp-unquote-file-local-name infile))
@@ -319,7 +322,7 @@ arguments to pass to the OPERATION."
v (tramp-get-method-parameter v 'tramp-login-program)
nil outbuf display
(tramp-expand-args
- v 'tramp-login-args
+ v 'tramp-login-args nil
?h (or (tramp-file-name-host v) "")
?u (or (tramp-file-name-user v) "")
?p (or (tramp-file-name-port v) "")
@@ -394,53 +397,53 @@ connection if a previous connection has died for some reason."
(unless (tramp-connectable-p vec)
(throw 'non-essential 'non-essential))
- ;; We need a process bound to the connection buffer. Therefore, we
- ;; create a dummy process. Maybe there is a better solution?
- (unless (get-buffer-process (tramp-get-connection-buffer vec))
- (let ((p (make-network-process
- :name (tramp-get-connection-name vec)
- :buffer (tramp-get-connection-buffer vec)
- :server t :host 'local :service t :noquery t)))
- (process-put p 'tramp-vector vec)
- (set-process-query-on-exit-flag p nil)
-
- ;; Set connection-local variables.
- (tramp-set-connection-local-variables vec)))
-
- ;; Create directory.
- (unless (file-directory-p (tramp-fuse-mount-point vec))
- (make-directory (tramp-fuse-mount-point vec) 'parents))
-
- (unless
- (or (tramp-fuse-mounted-p vec)
- (with-temp-buffer
- (zerop
- (apply
- #'tramp-call-process
- vec tramp-sshfs-program nil t nil
- (tramp-fuse-mount-spec vec)
- (tramp-fuse-mount-point vec)
- (tramp-expand-args
- vec 'tramp-mount-args
- ?p (or (tramp-file-name-port vec) ""))))))
- (tramp-error
- vec 'file-error "Error mounting %s" (tramp-fuse-mount-spec vec)))
-
- ;; Mark it as connected.
- (add-to-list 'tramp-fuse-mount-points (tramp-file-name-unify vec))
- (tramp-set-connection-property
- (tramp-get-connection-process vec) "connected" t)
-
- ;; In `tramp-check-cached-permissions', the connection properties
- ;; "{uid,gid}-{integer,string}" are used. We set them to proper values.
- (with-tramp-connection-property
- vec "uid-integer" (tramp-get-local-uid 'integer))
- (with-tramp-connection-property
- vec "gid-integer" (tramp-get-local-gid 'integer))
- (with-tramp-connection-property
- vec "uid-string" (tramp-get-local-uid 'string))
- (with-tramp-connection-property
- vec "gid-string" (tramp-get-local-gid 'string)))
+ (with-tramp-debug-message vec "Opening connection"
+ ;; We need a process bound to the connection buffer. Therefore,
+ ;; we create a dummy process. Maybe there is a better solution?
+ (unless (get-buffer-process (tramp-get-connection-buffer vec))
+ (let ((p (make-network-process
+ :name (tramp-get-connection-name vec)
+ :buffer (tramp-get-connection-buffer vec)
+ :server t :host 'local :service t :noquery t)))
+ (tramp-post-process-creation p vec)
+
+ ;; Set connection-local variables.
+ (tramp-set-connection-local-variables vec)))
+
+ ;; Create directory.
+ (unless (file-directory-p (tramp-fuse-mount-point vec))
+ (make-directory (tramp-fuse-mount-point vec) 'parents))
+
+ (unless
+ (or (tramp-fuse-mounted-p vec)
+ (with-temp-buffer
+ (zerop
+ (apply
+ #'tramp-call-process
+ vec tramp-sshfs-program nil t nil
+ (tramp-fuse-mount-spec vec)
+ (tramp-fuse-mount-point vec)
+ (tramp-expand-args
+ vec 'tramp-mount-args nil
+ ?p (or (tramp-file-name-port vec) ""))))))
+ (tramp-error
+ vec 'file-error "Error mounting %s" (tramp-fuse-mount-spec vec)))
+
+ ;; Mark it as connected.
+ (add-to-list 'tramp-fuse-mount-points (tramp-file-name-unify vec))
+ (tramp-set-connection-property
+ (tramp-get-connection-process vec) "connected" t)
+
+ ;; In `tramp-check-cached-permissions', the connection properties
+ ;; "{uid,gid}-{integer,string}" are used. We set them to proper values.
+ (with-tramp-connection-property
+ vec "uid-integer" (tramp-get-local-uid 'integer))
+ (with-tramp-connection-property
+ vec "gid-integer" (tramp-get-local-gid 'integer))
+ (with-tramp-connection-property
+ vec "uid-string" (tramp-get-local-uid 'string))
+ (with-tramp-connection-property
+ vec "gid-string" (tramp-get-local-gid 'string))))
;; `shell-mode' tries to open remote files like "/sshfs:user@host:~/.history".
;; This fails, because the tilde cannot be expanded. Tell
diff --git a/lisp/net/tramp-sudoedit.el b/lisp/net/tramp-sudoedit.el
index e1546f15b6d..7bbfec62753 100644
--- a/lisp/net/tramp-sudoedit.el
+++ b/lisp/net/tramp-sudoedit.el
@@ -23,7 +23,7 @@
;;; Commentary:
-;; The "sudoedit" Tramp method allows to edit a file as a different
+;; The "sudoedit" Tramp method enables editing a file as a different
;; user on the local host. Contrary to the "sudo" method, all magic
;; file name functions are implemented by single "sudo ..." commands.
;; The purpose is to make editing such a file as secure as possible;
@@ -49,7 +49,7 @@
(tramp-password-previous-hop t)))
(add-to-list 'tramp-default-user-alist
- `(,(tramp-compat-rx bos (literal tramp-sudoedit-method) eos)
+ `(,(rx bos (literal tramp-sudoedit-method) eos)
nil ,tramp-root-id-string))
(tramp-set-completion-function
@@ -90,6 +90,7 @@ See `tramp-actions-before-shell' for more info.")
(file-equal-p . tramp-handle-file-equal-p)
(file-executable-p . tramp-sudoedit-handle-file-executable-p)
(file-exists-p . tramp-sudoedit-handle-file-exists-p)
+ (file-group-gid . tramp-handle-file-group-gid)
(file-in-directory-p . tramp-handle-file-in-directory-p)
(file-local-copy . tramp-handle-file-local-copy)
(file-locked-p . tramp-handle-file-locked-p)
@@ -114,6 +115,7 @@ See `tramp-actions-before-shell' for more info.")
(file-symlink-p . tramp-handle-file-symlink-p)
(file-system-info . tramp-sudoedit-handle-file-system-info)
(file-truename . tramp-sudoedit-handle-file-truename)
+ (file-user-uid . tramp-handle-file-user-uid)
(file-writable-p . tramp-sudoedit-handle-file-writable-p)
(find-backup-file-name . tramp-handle-find-backup-file-name)
;; `get-file-buffer' performed by default handler.
@@ -168,8 +170,10 @@ See `tramp-actions-before-shell' for more info.")
First arg specifies the OPERATION, second arg is a list of
arguments to pass to the OPERATION."
(if-let ((fn (assoc operation tramp-sudoedit-file-name-handler-alist)))
- (save-match-data (apply (cdr fn) args))
- (tramp-run-real-handler operation args)))
+ (prog1 (save-match-data (apply (cdr fn) args))
+ (setq tramp-debug-message-fnh-function (cdr fn)))
+ (prog1 (tramp-run-real-handler operation args)
+ (setq tramp-debug-message-fnh-function operation))))
;;;###tramp-autoload
(tramp--with-startup
@@ -212,8 +216,8 @@ arguments to pass to the OPERATION."
(unless
(tramp-sudoedit-send-command
v1 "ln"
- (tramp-compat-file-name-unquote v1-localname)
- (tramp-compat-file-name-unquote v2-localname))
+ (file-name-unquote v1-localname)
+ (file-name-unquote v2-localname))
(tramp-error
v1 'file-error
"error with add-name-to-file, see buffer `%s' for details"
@@ -230,7 +234,7 @@ OK-IF-ALREADY-EXISTS means don't barf if NEWNAME exists already.
KEEP-DATE means to make sure that NEWNAME has the same timestamp
as FILENAME. PRESERVE-UID-GID, when non-nil, instructs to keep
the uid and gid if both files are on the same host.
-PRESERVE-EXTENDED-ATTRIBUTES activates selinux and acl commands.
+PRESERVE-EXTENDED-ATTRIBUTES activates SELinux and ACL commands.
This function is invoked by `tramp-sudoedit-handle-copy-file' and
`tramp-sudoedit-handle-rename-file'. It is an error if OP is
@@ -270,8 +274,8 @@ absolute file names."
(not (directory-name-p newname)))
(tramp-error v 'file-error "File is a directory %s" newname))
- (if (or (and (file-remote-p filename) (not t1))
- (and (file-remote-p newname) (not t2)))
+ (if (or (and (tramp-tramp-file-p filename) (not t1))
+ (and (tramp-tramp-file-p newname) (not t2)))
;; We cannot copy or rename directly.
(let ((tmpfile (tramp-compat-make-temp-file filename)))
(if (eq op 'copy)
@@ -292,7 +296,7 @@ absolute file names."
;; When `newname' is local, we must change the ownership to
;; the local user.
- (unless (file-remote-p newname)
+ (unless (tramp-tramp-file-p newname)
(tramp-set-file-uid-gid
(concat (file-remote-p filename) newname)
(tramp-get-local-uid 'integer)
@@ -342,22 +346,19 @@ absolute file names."
(tramp-skeleton-delete-directory directory recursive trash
(unless (tramp-sudoedit-send-command
v (if recursive '("rm" "-rf") "rmdir")
- (tramp-compat-file-name-unquote localname))
+ (file-name-unquote localname))
(tramp-error v 'file-error "Couldn't delete %s" directory))))
(defun tramp-sudoedit-handle-delete-file (filename &optional trash)
"Like `delete-file' for Tramp files."
- (with-parsed-tramp-file-name (expand-file-name filename) nil
- (tramp-flush-file-properties v localname)
- (if (and delete-by-moving-to-trash trash)
- (move-file-to-trash filename)
- (unless (tramp-sudoedit-send-command
- v "rm" "-f" (tramp-compat-file-name-unquote localname))
- ;; Propagate the error.
- (with-current-buffer (tramp-get-connection-buffer v)
- (goto-char (point-min))
- (tramp-error-with-buffer
- nil v 'file-error "Couldn't delete %s" filename))))))
+ (tramp-skeleton-delete-file filename trash
+ (unless (tramp-sudoedit-send-command
+ v "rm" "-f" (file-name-unquote localname))
+ ;; Propagate the error.
+ (with-current-buffer (tramp-get-connection-buffer v)
+ (goto-char (point-min))
+ (tramp-error-with-buffer
+ nil v 'file-error "Couldn't delete %s" filename)))))
(defun tramp-sudoedit-handle-expand-file-name (name &optional dir)
"Like `expand-file-name' for Tramp files.
@@ -386,8 +387,7 @@ the result will be a local, non-Tramp, file name."
(unless (file-name-absolute-p localname)
(setq localname (format "~%s/%s" user localname)))
(when (string-match
- (tramp-compat-rx bos "~" (group (* (not "/"))) (group (* nonl)) eos)
- localname)
+ (rx bos "~" (group (* (not "/"))) (group (* nonl)) eos) localname)
(let ((uname (match-string 1 localname))
(fname (match-string 2 localname))
hname)
@@ -417,7 +417,7 @@ the result will be a local, non-Tramp, file name."
(let ((result (and (tramp-sudoedit-remote-acl-p v)
(tramp-sudoedit-send-command-string
v "getfacl" "-acp"
- (tramp-compat-file-name-unquote localname)))))
+ (file-name-unquote localname)))))
;; The acl string must have a trailing \n, which is not
;; provided by `tramp-sudoedit-send-command-string'. Add it.
(and (stringp result) (concat result "\n"))))))
@@ -437,15 +437,37 @@ the result will be a local, non-Tramp, file name."
"stat format string to produce output suitable for use with
`file-attributes' on the remote file system.")
+(defconst tramp-sudoedit-file-attributes-with-selinux
+ (format
+ ;; Apostrophes in the stat output are masked as
+ ;; `tramp-stat-marker', in order to make a proper shell escape of
+ ;; them in file names. They are replaced in
+ ;; `tramp-sudoedit-send-command-and-read'.
+ (concat "((%s%%N%s) %%h (%s%%U%s . %%u) (%s%%G%s . %%g)"
+ " %%X %%Y %%Z %%s %s%%A%s t %%i -1 %s%%C%s)")
+ tramp-stat-marker tramp-stat-marker ; %%N
+ tramp-stat-marker tramp-stat-marker ; %%U
+ tramp-stat-marker tramp-stat-marker ; %%G
+ tramp-stat-marker tramp-stat-marker ; %%A
+ tramp-stat-marker tramp-stat-marker) ; %%C
+ "stat format string to produce output suitable for use with
+`file-attributes' on the remote file system, including SELinux context.")
+
(defun tramp-sudoedit-handle-file-attributes (filename &optional id-format)
"Like `file-attributes' for Tramp files."
;; The result is cached in `tramp-convert-file-attributes'.
(with-parsed-tramp-file-name (expand-file-name filename) nil
(tramp-convert-file-attributes v localname id-format
- (tramp-sudoedit-send-command-and-read
- v "env" "QUOTING_STYLE=locale" "stat" "-c"
- tramp-sudoedit-file-attributes
- (tramp-compat-file-name-unquote localname)))))
+ (cond
+ ((tramp-sudoedit-remote-selinux-p v)
+ (tramp-sudoedit-send-command-and-read
+ v "env" "QUOTING_STYLE=locale" "stat" "-c"
+ tramp-sudoedit-file-attributes-with-selinux
+ (file-name-unquote localname)))
+ (t
+ (tramp-sudoedit-send-command-and-read
+ v "env" "QUOTING_STYLE=locale" "stat" "-c"
+ tramp-sudoedit-file-attributes (file-name-unquote localname)))))))
(defun tramp-sudoedit-handle-file-executable-p (filename)
"Like `file-executable-p' for Tramp files."
@@ -457,13 +479,13 @@ the result will be a local, non-Tramp, file name."
(or (tramp-check-cached-permissions v ?x)
(tramp-check-cached-permissions v ?s))
(tramp-sudoedit-send-command
- v "test" "-x" (tramp-compat-file-name-unquote localname))))))
+ v "test" "-x" (file-name-unquote localname))))))
(defun tramp-sudoedit-handle-file-exists-p (filename)
"Like `file-exists-p' for Tramp files."
(tramp-skeleton-file-exists-p filename
(tramp-sudoedit-send-command
- v "test" "-e" (tramp-compat-file-name-unquote localname))))
+ v "test" "-e" (file-name-unquote localname))))
(defun tramp-sudoedit-handle-file-name-all-completions (filename directory)
"Like `file-name-all-completions' for Tramp files."
@@ -475,7 +497,7 @@ the result will be a local, non-Tramp, file name."
(tramp-sudoedit-send-command
v "ls" "-a1" "--quoting-style=literal" "--show-control-chars"
(if (tramp-string-empty-or-nil-p localname)
- "" (tramp-compat-file-name-unquote localname)))
+ "" (file-name-unquote localname)))
(mapcar
(lambda (f)
(if (ignore-errors (file-directory-p (expand-file-name f directory)))
@@ -496,7 +518,7 @@ the result will be a local, non-Tramp, file name."
(if (tramp-file-property-p v localname "file-attributes")
(tramp-handle-file-readable-p filename)
(tramp-sudoedit-send-command
- v "test" "-r" (tramp-compat-file-name-unquote localname))))))
+ v "test" "-r" (file-name-unquote localname))))))
(defun tramp-sudoedit-handle-set-file-modes (filename mode &optional flag)
"Like `set-file-modes' for Tramp files."
@@ -504,13 +526,12 @@ the result will be a local, non-Tramp, file name."
(unless (and (eq flag 'nofollow) (file-symlink-p filename))
(tramp-skeleton-set-file-modes-times-uid-gid filename
(unless (tramp-sudoedit-send-command
- v "chmod" (format "%o" mode)
- (tramp-compat-file-name-unquote localname))
+ v "chmod" (format "%o" mode) (file-name-unquote localname))
(tramp-error
v 'file-error "Error while changing file's mode %s" filename)))))
(defun tramp-sudoedit-remote-selinux-p (vec)
- "Check, whether SELINUX is enabled on the remote host."
+ "Check, whether SELinux is enabled on the remote host."
(with-tramp-connection-property (tramp-get-process vec) "selinux-p"
(zerop (tramp-call-process vec "selinuxenabled"))))
@@ -519,18 +540,17 @@ the result will be a local, non-Tramp, file name."
(with-parsed-tramp-file-name (expand-file-name filename) nil
(with-tramp-file-property v localname "file-selinux-context"
(let ((context '(nil nil nil nil))
- (regexp (tramp-compat-rx
+ (regexp (rx
(group (+ (any "_" alnum))) ":"
(group (+ (any "_" alnum))) ":"
(group (+ (any "_" alnum))) ":"
(group (+ (any "_" alnum))))))
(when (and (tramp-sudoedit-remote-selinux-p v)
(tramp-sudoedit-send-command
- v "ls" "-d" "-Z"
- (tramp-compat-file-name-unquote localname)))
+ v "ls" "-d" "-Z" (file-name-unquote localname)))
(with-current-buffer (tramp-get-connection-buffer v)
(goto-char (point-min))
- (when (re-search-forward regexp (line-end-position) t)
+ (when (search-forward-regexp regexp (line-end-position) t)
(setq context (list (match-string 1) (match-string 2)
(match-string 3) (match-string 4))))))
;; Return the context.
@@ -543,7 +563,7 @@ the result will be a local, non-Tramp, file name."
(tramp-message v 5 "file system info: %s" localname)
(when (tramp-sudoedit-send-command
v "df" "--block-size=1" "--output=size,used,avail"
- (tramp-compat-file-name-unquote localname))
+ (file-name-unquote localname))
(with-current-buffer (tramp-get-connection-buffer v)
(goto-char (point-min))
(forward-line)
@@ -561,60 +581,29 @@ the result will be a local, non-Tramp, file name."
(defun tramp-sudoedit-handle-set-file-times (filename &optional time flag)
"Like `set-file-times' for Tramp files."
(tramp-skeleton-set-file-modes-times-uid-gid filename
- (let ((time
- (if (or (null time)
- (tramp-compat-time-equal-p time tramp-time-doesnt-exist)
- (tramp-compat-time-equal-p time tramp-time-dont-know))
- nil
- time)))
- (tramp-sudoedit-send-command
- v "env" "TZ=UTC0" "touch" "-t"
- (format-time-string "%Y%m%d%H%M.%S" time t)
- (if (eq flag 'nofollow) "-h" "")
- (tramp-compat-file-name-unquote localname)))))
+ (tramp-sudoedit-send-command
+ v "env" "TZ=UTC0" "touch" "-t"
+ (format-time-string "%Y%m%d%H%M.%S" (tramp-defined-time time) t)
+ (if (eq flag 'nofollow) "-h" "")
+ (file-name-unquote localname))))
(defun tramp-sudoedit-handle-file-truename (filename)
"Like `file-truename' for Tramp files."
- ;; Preserve trailing "/".
- (funcall
- (if (directory-name-p filename) #'file-name-as-directory #'identity)
- ;; Quote properly.
- (funcall
- (if (tramp-compat-file-name-quoted-p filename)
- #'tramp-compat-file-name-quote #'identity)
- (with-parsed-tramp-file-name
- (tramp-compat-file-name-unquote (expand-file-name filename)) nil
- (tramp-make-tramp-file-name
- v
- (with-tramp-file-property v localname "file-truename"
- (let (result)
- (tramp-message v 4 "Finding true name for `%s'" filename)
- (setq result (tramp-sudoedit-send-command-string
- v "readlink" "--canonicalize-missing" localname))
- ;; Detect cycle.
- (when (and (file-symlink-p filename)
- (string-equal result localname))
- (tramp-error
- v 'file-error
- "Apparent cycle of symbolic links for %s" filename))
- ;; If the resulting localname looks remote, we must quote it
- ;; for security reasons.
- (when (file-remote-p result)
- (setq result (tramp-compat-file-name-quote result 'top)))
- (tramp-message v 4 "True name of `%s' is `%s'" localname result)
- result)))))))
+ (tramp-skeleton-file-truename filename
+ (tramp-sudoedit-send-command-string
+ v "readlink" "--canonicalize-missing" localname)))
(defun tramp-sudoedit-handle-file-writable-p (filename)
"Like `file-writable-p' for Tramp files."
(with-parsed-tramp-file-name (expand-file-name filename) nil
(with-tramp-file-property v localname "file-writable-p"
(if (file-exists-p filename)
+ ;; Examine `file-attributes' cache to see if request can be
+ ;; satisfied without remote operation.
(if (tramp-file-property-p v localname "file-attributes")
- ;; Examine `file-attributes' cache to see if request can
- ;; be satisfied without remote operation.
(tramp-check-cached-permissions v ?w)
(tramp-sudoedit-send-command
- v "test" "-w" (tramp-compat-file-name-unquote localname)))
+ v "test" "-w" (file-name-unquote localname)))
;; If file doesn't exist, check if directory is writable.
(and
(file-directory-p (file-name-directory filename))
@@ -622,62 +611,20 @@ the result will be a local, non-Tramp, file name."
(defun tramp-sudoedit-handle-make-directory (dir &optional parents)
"Like `make-directory' for Tramp files."
- (setq dir (expand-file-name dir))
- (with-parsed-tramp-file-name dir nil
- (when (and (null parents) (file-exists-p dir))
- (tramp-error v 'file-already-exists "Directory already exists %s" dir))
- ;; When PARENTS is non-nil, DIR could be a chain of non-existent
- ;; directories a/b/c/... Instead of checking, we simply flush the
- ;; whole cache.
- (tramp-flush-directory-properties
- v (if parents "/" (file-name-directory localname)))
+ (tramp-skeleton-make-directory dir parents
(unless (tramp-sudoedit-send-command
- v (if parents '("mkdir" "-p") "mkdir")
- "-m" (format "%#o" (default-file-modes))
- (tramp-compat-file-name-unquote localname))
+ v "mkdir" "-m" (format "%#o" (default-file-modes))
+ (file-name-unquote localname))
(tramp-error v 'file-error "Couldn't make directory %s" dir))))
(defun tramp-sudoedit-handle-make-symbolic-link
(target linkname &optional ok-if-already-exists)
- "Like `make-symbolic-link' for Tramp files.
-If TARGET is a non-Tramp file, it is used verbatim as the target
-of the symlink. If TARGET is a Tramp file, only the localname
-component is used as the target of the symlink."
- (with-parsed-tramp-file-name (expand-file-name linkname) nil
- ;; If TARGET is a Tramp name, use just the localname component.
- ;; Don't check for a proper method.
- (let ((non-essential t))
- (when (and (tramp-tramp-file-p target)
- (tramp-file-name-equal-p v (tramp-dissect-file-name target)))
- (setq target (tramp-file-local-name (expand-file-name target))))
- ;; There could be a cyclic link.
- (tramp-flush-file-properties
- v (expand-file-name target (tramp-file-local-name default-directory))))
-
- ;; If TARGET is still remote, quote it.
- (if (tramp-tramp-file-p target)
- (make-symbolic-link
- (tramp-compat-file-name-quote target 'top)
- linkname ok-if-already-exists)
-
- ;; Do the 'confirm if exists' thing.
- (when (file-exists-p linkname)
- ;; What to do?
- (if (or (null ok-if-already-exists) ; not allowed to exist
- (and (numberp ok-if-already-exists)
- (not
- (yes-or-no-p
- (format
- "File %s already exists; make it a link anyway?"
- localname)))))
- (tramp-error v 'file-already-exists localname)
- (delete-file linkname)))
-
- (tramp-flush-file-properties v localname)
- (tramp-sudoedit-send-command
- v "ln" "-sf"
- (tramp-compat-file-name-unquote target)
- (tramp-compat-file-name-unquote localname)))))
+ "Like `make-symbolic-link' for Tramp files."
+ (tramp-skeleton-make-symbolic-link target linkname ok-if-already-exists
+ (tramp-sudoedit-send-command
+ v "ln" "-sf"
+ (file-name-unquote target)
+ (file-name-unquote localname))))
(defun tramp-sudoedit-handle-rename-file
(filename newname &optional ok-if-already-exists)
@@ -701,8 +648,7 @@ component is used as the target of the symlink."
(setq acl-string (string-join (split-string acl-string "\n" 'omit) ","))
(prog1
(tramp-sudoedit-send-command
- v "setfacl" "-m"
- acl-string (tramp-compat-file-name-unquote localname))
+ v "setfacl" "-m" acl-string (file-name-unquote localname))
(tramp-flush-file-property v localname "file-acl")))))
(defun tramp-sudoedit-handle-set-file-selinux-context (filename context)
@@ -720,7 +666,7 @@ component is used as the target of the symlink."
(when role (format "--role=%s" role))
(when type (format "--type=%s" type))
(when range (format "--range=%s" range))
- (tramp-compat-file-name-unquote localname))
+ (file-name-unquote localname))
(if (and user role type range)
(tramp-set-file-property
v localname "file-selinux-context" context)
@@ -794,21 +740,21 @@ connection if a previous connection has died for some reason."
(unless (tramp-connectable-p vec)
(throw 'non-essential 'non-essential))
- ;; We need a process bound to the connection buffer. Therefore, we
- ;; create a dummy process. Maybe there is a better solution?
- (unless (tramp-get-connection-process vec)
- (let ((p (make-network-process
- :name (tramp-get-connection-name vec)
- :buffer (tramp-get-connection-buffer vec)
- :server t :host 'local :service t :noquery t)))
- (process-put p 'tramp-vector vec)
- (set-process-query-on-exit-flag p nil)
+ (with-tramp-debug-message vec "Opening connection"
+ ;; We need a process bound to the connection buffer. Therefore,
+ ;; we create a dummy process. Maybe there is a better solution?
+ (unless (tramp-get-connection-process vec)
+ (let ((p (make-network-process
+ :name (tramp-get-connection-name vec)
+ :buffer (tramp-get-connection-buffer vec)
+ :server t :host 'local :service t :noquery t)))
+ (tramp-post-process-creation p vec)
- ;; Set connection-local variables.
- (tramp-set-connection-local-variables vec)
+ ;; Set connection-local variables.
+ (tramp-set-connection-local-variables vec)
- ;; Mark it as connected.
- (tramp-set-connection-property p "connected" t))))
+ ;; Mark it as connected.
+ (tramp-set-connection-property p "connected" t)))))
(defun tramp-sudoedit-send-command (vec &rest args)
"Send commands ARGS to connection VEC.
@@ -825,10 +771,10 @@ in case of error, t otherwise."
(tramp-get-connection-name vec) (current-buffer)
(append
(tramp-expand-args
- vec 'tramp-sudo-login
+ vec 'tramp-sudo-login nil
?h (or (tramp-file-name-host vec) "")
?u (or (tramp-file-name-user vec) ""))
- (tramp-compat-flatten-tree args))))
+ (flatten-tree args))))
;; We suppress the messages `Waiting for prompts from remote shell'.
(tramp-verbose (if (= tramp-verbose 3) 2 tramp-verbose))
;; The password shall be cached also in case of "emacs -Q".
@@ -836,12 +782,9 @@ in case of error, t otherwise."
(tramp-cache-read-persistent-data t)
;; We do not want to save the password.
auth-source-save-behavior)
- (tramp-message vec 6 "%s" (string-join (process-command p) " "))
;; Avoid process status message in output buffer.
(set-process-sentinel p #'ignore)
- (process-put p 'tramp-vector vec)
- (process-put p 'adjust-window-size-function #'ignore)
- (set-process-query-on-exit-flag p nil)
+ (tramp-post-process-creation p vec)
(tramp-set-connection-property p "password-vector" tramp-sudoedit-null-hop)
(tramp-process-actions p vec nil tramp-sudoedit-sudo-actions)
(tramp-message vec 6 "%s\n%s" (process-exit-status p) (buffer-string))
@@ -869,7 +812,7 @@ In case there is no valid Lisp expression, it raises an error."
(condition-case nil
(prog1 (read (current-buffer))
;; Error handling.
- (when (re-search-forward (rx (not blank)) (line-end-position) t)
+ (when (search-forward-regexp (rx (not blank)) (line-end-position) t)
(error nil)))
(error (tramp-error
vec 'file-error
diff --git a/lisp/net/tramp.el b/lisp/net/tramp.el
index 2d6db31fee8..5b101000926 100644
--- a/lisp/net/tramp.el
+++ b/lisp/net/tramp.el
@@ -8,6 +8,9 @@
;; Keywords: comm, processes
;; Package: tramp
+;; This is a GNU ELPA :core package. Avoid functionality that is not
+;; compatible with the version of Emacs recorded in trampver.el.
+
;; This file is part of GNU Emacs.
;; GNU Emacs is free software: you can redistribute it and/or modify
@@ -55,6 +58,7 @@
;;; Code:
(require 'tramp-compat)
+(require 'tramp-message)
(require 'tramp-integration)
(require 'trampver)
@@ -63,7 +67,6 @@
(declare-function file-notify-rm-watch "filenotify")
(declare-function netrc-parse "netrc")
(defvar auto-save-file-name-transforms)
-(defvar ls-lisp-use-insert-directory-program)
(defvar tramp-prefix-format)
(defvar tramp-prefix-regexp)
(defvar tramp-method-regexp)
@@ -86,15 +89,6 @@
;;;###autoload (when (featurep 'tramp-compat)
;;;###autoload (load "tramp-compat" 'noerror 'nomessage))
-;;; User Customizable Internal Variables:
-
-(defgroup tramp nil
- "Edit remote files with a combination of ssh, scp, etc."
- :group 'files
- :group 'comm
- :link '(custom-manual "(tramp)Top")
- :version "22.1")
-
;;;###tramp-autoload
(progn
(defvar tramp--startup-hook nil
@@ -104,9 +98,26 @@
(defmacro tramp--with-startup (&rest body)
"Schedule BODY to be executed at the end of tramp.el."
- `(add-hook 'tramp--startup-hook (lambda () ,@body))))
+ `(add-hook 'tramp--startup-hook (lambda () ,@body)))
+
+ (eval-and-compile
+ (defalias 'tramp-byte-run--set-suppress-trace
+ #'(lambda (f _args val)
+ (list 'function-put (list 'quote f)
+ ''tramp-suppress-trace val)))
-(require 'tramp-loaddefs)
+ (add-to-list
+ 'defun-declarations-alist
+ (list 'tramp-suppress-trace #'tramp-byte-run--set-suppress-trace))))
+
+;;; User Customizable Internal Variables:
+
+(defgroup tramp nil
+ "Edit remote files with a combination of ssh, scp, etc."
+ :group 'files
+ :group 'comm
+ :version "22.1"
+ :link '(custom-manual "(tramp)Top"))
;; Maybe we need once a real Tramp mode, with key bindings etc.
;;;###autoload
@@ -115,32 +126,6 @@
If it is set to nil, all remote file names are used literally."
:type 'boolean)
-;;;###tramp-autoload
-(defcustom tramp-verbose 3
- "Verbosity level for Tramp messages.
-Any level x includes messages for all levels 1 .. x-1. The levels are
-
- 0 silent (no tramp messages at all)
- 1 errors
- 2 warnings
- 3 connection to remote hosts (default level)
- 4 activities
- 5 internal
- 6 sent and received strings
- 7 connection properties
- 8 file caching
- 9 test commands
-10 traces (huge)
-11 call traces (maintainer only)."
- :type 'integer)
-
-(defcustom tramp-debug-to-file nil
- "Whether Tramp debug messages shall be saved to file.
-The debug file has the same name as the debug buffer, written to
-`temporary-file-directory'."
- :version "28.1"
- :type 'boolean)
-
(defcustom tramp-backup-directory-alist nil
"Alist of filename patterns and backup directory names.
Each element looks like (REGEXP . DIRECTORY), with the same meaning like
@@ -165,7 +150,12 @@ This setting has precedence over `auto-save-file-name-transforms'."
;; Suppress `shell-file-name' for w32 systems.
(defcustom tramp-encoding-shell
(let (shell-file-name)
- (or (tramp-compat-funcall 'w32-shell-name) "/bin/sh"))
+ (or (tramp-compat-funcall 'w32-shell-name)
+ (if (eq system-type 'android)
+ ;; The shell is located at /system/bin/sh on Android
+ ;; systems.
+ "/system/bin/sh"
+ "/bin/sh")))
"Use this program for encoding and decoding commands on the local host.
This shell is used to execute the encoding and decoding command on the
local host, so if you want to use \"~\" in those commands, you should
@@ -302,13 +292,6 @@ pair of the form (KEY VALUE). The following KEYs are defined:
and container methods do. If it is a list of strings, they
are used to construct the remote command.
- * `tramp-config-check'
- A function to be called with one argument, VEC. It should
- return a string which is used to check, whether the
- configuration of the remote host has been changed (which
- would require to flush the cache data). This string is kept
- as connection property \"config-check-data\".
-
* `tramp-copy-program'
This specifies the name of the program to use for remotely copying
the file; this might be the absolute filename of scp or the name of
@@ -318,6 +301,15 @@ pair of the form (KEY VALUE). The following KEYs are defined:
This specifies the list of parameters to pass to the above mentioned
program, the hints for `tramp-login-args' also apply here.
+ * `tramp-copy-file-name'
+ The remote source or destination file name for out-of-band methods.
+ You can use \"%u\" and \"%h\" like in `tramp-login-args'.
+ Additionally, \"%f\" denotes the local file name part. This list
+ will be expanded to a string without spaces between the elements of
+ the list.
+
+ The default value is `tramp-default-copy-file-name'.
+
* `tramp-copy-env'
A list of environment variables and their values, which will
be set when calling `tramp-copy-program'.
@@ -465,9 +457,7 @@ See `tramp-methods' for a list of possibilities for METHOD."
(defcustom tramp-default-user nil
"Default user to use for transferring files.
It is nil by default; otherwise settings in configuration files like
-\"~/.ssh/config\" would be overwritten. Also see `tramp-default-user-alist'.
-
-This variable is regarded as obsolete, and will be removed soon."
+\"~/.ssh/config\" would be overwritten. Also see `tramp-default-user-alist'."
:type '(choice (const nil) string))
;;;###tramp-autoload
@@ -552,7 +542,7 @@ interpreted as a regular expression which always matches."
(defcustom tramp-restricted-shell-hosts-alist
(when (and (eq system-type 'windows-nt)
(not (string-match-p (rx "sh" eol) tramp-encoding-shell)))
- (list (tramp-compat-rx
+ (list (rx
bos (| (literal (downcase tramp-system-name))
(literal (upcase tramp-system-name)))
eos)))
@@ -566,15 +556,14 @@ host runs a restricted shell, it shall be added to this list, too."
;;;###tramp-autoload
(defcustom tramp-local-host-regexp
- (tramp-compat-rx
- bos
- (| (literal tramp-system-name)
- (| "localhost" "127.0.0.1" "::1"
- ;; Fedora.
- "localhost4" "localhost6"
- ;; Ubuntu.
- "ip6-localhost" "ip6-loopback"))
- eos)
+ (rx bos
+ (| (literal tramp-system-name)
+ (| "localhost" "127.0.0.1" "::1"
+ ;; Fedora.
+ "localhost4" "localhost6"
+ ;; Ubuntu.
+ "ip6-localhost" "ip6-loopback"))
+ eos)
"Host names which are regarded as local host.
If the local host runs a chrooted environment, set this to nil."
:version "29.3"
@@ -669,10 +658,11 @@ This regexp must match both `tramp-initial-end-of-output' and
:type 'regexp)
(defcustom tramp-password-prompt-regexp
- (tramp-compat-rx
- bol (* nonl)
- (group (regexp (regexp-opt password-word-equivalents)))
- (* nonl) (any "::៖") (? "\^@") (* blank))
+ (rx-to-string
+ `(: bol (* nonl)
+ (group (| . ,password-word-equivalents))
+ (* nonl) (any . ,tramp-compat-password-colon-equivalents)
+ (? "\^@") (* blank)))
"Regexp matching password-like prompts.
The regexp should match at end of buffer.
@@ -686,10 +676,11 @@ The `sudo' program appears to insert a `^@' character into the prompt."
:type 'regexp)
(defcustom tramp-otp-password-prompt-regexp
- (rx bol (* nonl)
- ;; JumpCloud.
- (group (| "Verification code"))
- (* nonl) (any "::៖") (* blank))
+ (rx-to-string
+ `(: bol (* nonl)
+ ;; JumpCloud.
+ (group (| "Verification code"))
+ (* nonl) (any . ,tramp-compat-password-colon-equivalents) (* blank)))
"Regexp matching one-time password prompts.
The regexp should match at end of buffer."
:version "29.2"
@@ -931,18 +922,17 @@ Used in `tramp-make-tramp-file-name'.")
(defun tramp-build-prefix-regexp ()
"Return `tramp-prefix-regexp'."
- (tramp-compat-rx bol (literal (tramp-build-prefix-format))))
+ (rx bol (literal (tramp-build-prefix-format))))
(defvar tramp-prefix-regexp nil ; Initialized when defining `tramp-syntax'!
"Regexp matching the very beginning of Tramp file names.
Should always start with \"^\". Derived from `tramp-prefix-format'.")
(defconst tramp-method-regexp-alist
- `((default . ,(tramp-compat-rx
- (| (literal tramp-default-method-marker) (>= 2 alnum))))
+ `((default . ,(rx (| (literal tramp-default-method-marker) (>= 2 alnum))))
(simplified . "")
- (separate . ,(tramp-compat-rx
- (? (| (literal tramp-default-method-marker) (>= 2 alnum))))))
+ (separate
+ . ,(rx (? (| (literal tramp-default-method-marker) (>= 2 alnum))))))
"Alist mapping Tramp syntax to regexps matching methods identifiers.")
(defun tramp-build-method-regexp ()
@@ -970,7 +960,7 @@ Used in `tramp-make-tramp-file-name'.")
(defun tramp-build-postfix-method-regexp ()
"Return `tramp-postfix-method-regexp'."
- (tramp-compat-rx (literal (tramp-build-postfix-method-format))))
+ (rx (literal (tramp-build-postfix-method-format))))
(defvar tramp-postfix-method-regexp nil ; Init'd when defining `tramp-syntax'!
"Regexp matching delimiter between method and user or host names.
@@ -982,8 +972,7 @@ Derived from `tramp-postfix-method-format'.")
(defconst tramp-prefix-domain-format "%"
"String matching delimiter between user and domain names.")
-(defconst tramp-prefix-domain-regexp
- (tramp-compat-rx (literal tramp-prefix-domain-format))
+(defconst tramp-prefix-domain-regexp (rx (literal tramp-prefix-domain-format))
"Regexp matching delimiter between user and domain names.
Derived from `tramp-prefix-domain-format'.")
@@ -991,7 +980,7 @@ Derived from `tramp-prefix-domain-format'.")
"Regexp matching domain names.")
(defconst tramp-user-with-domain-regexp
- (tramp-compat-rx
+ (rx
(group (regexp tramp-user-regexp))
(regexp tramp-prefix-domain-regexp)
(group (regexp tramp-domain-regexp)))
@@ -1001,8 +990,7 @@ Derived from `tramp-prefix-domain-format'.")
"String matching delimiter between user and host names.
Used in `tramp-make-tramp-file-name'.")
-(defconst tramp-postfix-user-regexp
- (tramp-compat-rx (literal tramp-postfix-user-format))
+(defconst tramp-postfix-user-regexp (rx (literal tramp-postfix-user-format))
"Regexp matching delimiter between user and host names.
Derived from `tramp-postfix-user-format'.")
@@ -1025,7 +1013,7 @@ Used in `tramp-make-tramp-file-name'.")
(defun tramp-build-prefix-ipv6-regexp ()
"Return `tramp-prefix-ipv6-regexp'."
- (tramp-compat-rx (literal tramp-prefix-ipv6-format)))
+ (rx (literal tramp-prefix-ipv6-format)))
(defvar tramp-prefix-ipv6-regexp nil ; Initialized when defining `tramp-syntax'!
"Regexp matching left hand side of IPv6 addresses.
@@ -1053,7 +1041,7 @@ Used in `tramp-make-tramp-file-name'.")
(defun tramp-build-postfix-ipv6-regexp ()
"Return `tramp-postfix-ipv6-regexp'."
- (tramp-compat-rx (literal tramp-postfix-ipv6-format)))
+ (rx (literal tramp-postfix-ipv6-format)))
(defvar tramp-postfix-ipv6-regexp nil ; Initialized when defining `tramp-syntax'!
"Regexp matching right hand side of IPv6 addresses.
@@ -1062,8 +1050,7 @@ Derived from `tramp-postfix-ipv6-format'.")
(defconst tramp-prefix-port-format "#"
"String matching delimiter between host names and port numbers.")
-(defconst tramp-prefix-port-regexp
- (tramp-compat-rx (literal tramp-prefix-port-format))
+(defconst tramp-prefix-port-regexp (rx (literal tramp-prefix-port-format))
"Regexp matching delimiter between host names and port numbers.
Derived from `tramp-prefix-port-format'.")
@@ -1071,7 +1058,7 @@ Derived from `tramp-prefix-port-format'.")
"Regexp matching port numbers.")
(defconst tramp-host-with-port-regexp
- (tramp-compat-rx
+ (rx
(group (regexp tramp-host-regexp))
(regexp tramp-prefix-port-regexp)
(group (regexp tramp-port-regexp)))
@@ -1080,8 +1067,7 @@ Derived from `tramp-prefix-port-format'.")
(defconst tramp-postfix-hop-format "|"
"String matching delimiter after ad-hoc hop definitions.")
-(defconst tramp-postfix-hop-regexp
- (tramp-compat-rx (literal tramp-postfix-hop-format))
+(defconst tramp-postfix-hop-regexp (rx (literal tramp-postfix-hop-format))
"Regexp matching delimiter after ad-hoc hop definitions.
Derived from `tramp-postfix-hop-format'.")
@@ -1101,7 +1087,7 @@ Used in `tramp-make-tramp-file-name'.")
(defun tramp-build-postfix-host-regexp ()
"Return `tramp-postfix-host-regexp'."
- (tramp-compat-rx (literal tramp-postfix-host-format)))
+ (rx (literal tramp-postfix-host-format)))
(defvar tramp-postfix-host-regexp nil ; Initialized when defining `tramp-syntax'!
"Regexp matching delimiter between host names and localnames.
@@ -1110,10 +1096,10 @@ Derived from `tramp-postfix-host-format'.")
(defconst tramp-localname-regexp (rx (* (not (any "\r\n"))) eos)
"Regexp matching localnames.")
-(defconst tramp-unknown-id-string "UNKNOWN"
+(defvar tramp-unknown-id-string "UNKNOWN"
"String used to denote an unknown user or group.")
-(defconst tramp-unknown-id-integer -1
+(defvar tramp-unknown-id-integer -1
"Integer used to denote an unknown user or group.")
;;;###tramp-autoload
@@ -1128,7 +1114,7 @@ Derived from `tramp-postfix-host-format'.")
(defun tramp-build-remote-file-name-spec-regexp ()
"Construct a regexp matching a Tramp file name for a Tramp syntax.
It is expected, that `tramp-syntax' has the proper value."
- (tramp-compat-rx
+ (rx
;; Method.
(group (regexp tramp-method-regexp)) (regexp tramp-postfix-method-regexp)
;; Optional user. This includes domain.
@@ -1150,7 +1136,7 @@ It is expected, that `tramp-syntax' has the proper value."
It is expected, that `tramp-syntax' has the proper value.
See `tramp-file-name-structure'."
(list
- (tramp-compat-rx
+ (rx
(regexp tramp-prefix-regexp)
(? (group (+ (regexp tramp-remote-file-name-spec-regexp)
(regexp tramp-postfix-hop-regexp))))
@@ -1210,11 +1196,9 @@ initial value is overwritten by the car of `tramp-file-name-structure'.")
;; `tramp-method-regexp' needs at least two characters, in order to
;; distinguish from volume letter. This is in the way when completing.
(defconst tramp-completion-method-regexp-alist
- `((default . ,(tramp-compat-rx
- (| (literal tramp-default-method-marker) (+ alnum))))
+ `((default . ,(rx (| (literal tramp-default-method-marker) (+ alnum))))
(simplified . "")
- (separate . ,(tramp-compat-rx
- (| (literal tramp-default-method-marker) (* alnum)))))
+ (separate . ,(rx (| (literal tramp-default-method-marker) (* alnum)))))
"Alist mapping Tramp syntax to regexps matching completion methods.")
(defun tramp-build-completion-method-regexp ()
@@ -1230,18 +1214,11 @@ The `ftp' syntax does not support methods.")
"Return `tramp-completion-file-name-regexp' according to `tramp-syntax'."
(if (eq tramp-syntax 'separate)
;; FIXME: This shouldn't be necessary.
- (tramp-compat-rx bos "/" (? "[" (* (not "]"))) eos)
- (tramp-compat-rx
- bos
- ;; `file-name-completion' uses absolute paths for matching.
- ;; This means that on W32 systems, something like
- ;; "/ssh:host:~/path" becomes "c:/ssh:host:~/path". See also
- ;; `tramp-drop-volume-letter'.
- (? (regexp tramp-volume-letter-regexp))
- ;; We cannot use `tramp-prefix-regexp', because it starts with `bol'.
- (literal tramp-prefix-format)
-
- ;; Optional multi hops.
+ (rx bos "/" (? "[" (* (not "]"))) eos)
+ (rx
+ (regexp tramp-prefix-regexp)
+
+ ;; Optional multi-hops.
(* (regexp tramp-remote-file-name-spec-regexp)
(regexp tramp-postfix-hop-regexp))
@@ -1306,7 +1283,7 @@ checked via the following code:
(process-send-eof proc)
(process-send-eof proc))
(while (not (progn (goto-char (point-min))
- (re-search-forward \"\\\\w+\" (point-max) t)))
+ (search-forward-regexp \"\\\\w+\" (point-max) t)))
(accept-process-output proc 1))
(when (process-live-p proc)
(setq received (string-to-number (match-string 0)))
@@ -1382,9 +1359,11 @@ let-bind this variable."
;; GNU/Linux (Debian, Suse, RHEL, Cygwin, MINGW64): /bin:/usr/bin
;; FreeBSD, DragonFly: /usr/bin:/bin:/usr/sbin:/sbin: - beware trailing ":"!
;; FreeBSD 12.1, Darwin: /usr/bin:/bin:/usr/sbin:/sbin
+;; NetBSD 9.3: /usr/bin:/bin:/usr/sbin:/sbin:/usr/pkg/bin:/usr/pkg/sbin:/usr/local/bin:/usr/local/sbin
;; IRIX64: /usr/bin
;; QNAP QTS: ---
;; Hydra: /run/current-system/sw/bin:/bin:/usr/bin
+;;;###tramp-autoload
(defcustom tramp-remote-path
'(tramp-default-remote-path "/bin" "/usr/bin" "/sbin" "/usr/sbin"
"/usr/local/bin" "/usr/local/sbin" "/local/bin" "/local/freeware/bin"
@@ -1435,26 +1414,12 @@ The TERM environment variable should be set via `tramp-terminal-type'.
The INSIDE_EMACS environment variable will automatically be set
based on the Tramp and Emacs versions, and should not be set here."
- :group 'tramp
:version "26.1"
:type '(repeat string))
-(defcustom tramp-completion-reread-directory-timeout 10
- "Defines seconds since last remote command before rereading a directory.
-A remote directory might have changed its contents. In order to
-make it visible during file name completion in the minibuffer,
-Tramp flushes its cache and rereads the directory contents when
-more than `tramp-completion-reread-directory-timeout' seconds
-have been gone since last remote command execution. A value of t
-would require an immediate reread during filename completion, nil
-means to use always cached values for the directory contents."
- :type '(choice (const nil) (const t) integer))
-(make-obsolete-variable
- 'tramp-completion-reread-directory-timeout
- 'remote-file-name-inhibit-cache "27.2")
-
;;; Internal Variables:
+;;;###tramp-autoload
(defvar tramp-current-connection nil
"Last connection timestamp.
It is a cons cell of the actual `tramp-file-name-structure', and
@@ -1474,6 +1439,7 @@ during direct remote copying with scp.")
(defconst tramp-completion-file-name-handler-alist
'((expand-file-name . tramp-completion-handle-expand-file-name)
+ (file-directory-p . tramp-completion-handle-file-directory-p)
(file-exists-p . tramp-completion-handle-file-exists-p)
(file-name-all-completions
. tramp-completion-handle-file-name-all-completions)
@@ -1512,100 +1478,109 @@ calling HANDLER.")
(cl-defstruct (tramp-file-name (:type list) :named)
method user domain host port localname hop))
-(put #'tramp-file-name-method 'tramp-suppress-trace t)
-(put #'tramp-file-name-user 'tramp-suppress-trace t)
-(put #'tramp-file-name-domain 'tramp-suppress-trace t)
-(put #'tramp-file-name-host 'tramp-suppress-trace t)
-(put #'tramp-file-name-port 'tramp-suppress-trace t)
-(put #'tramp-file-name-localname 'tramp-suppress-trace t)
-(put #'tramp-file-name-hop 'tramp-suppress-trace t)
+(function-put #'tramp-file-name-method 'tramp-suppress-trace t)
+(function-put #'tramp-file-name-user 'tramp-suppress-trace t)
+(function-put #'tramp-file-name-domain 'tramp-suppress-trace t)
+(function-put #'tramp-file-name-host 'tramp-suppress-trace t)
+(function-put #'tramp-file-name-port 'tramp-suppress-trace t)
+(function-put #'tramp-file-name-localname 'tramp-suppress-trace t)
+(function-put #'tramp-file-name-hop 'tramp-suppress-trace t)
-;; Needed for `tramp-read-passwd' and `tramp-get-remote-null-device'.
+;;;###tramp-autoload
(defconst tramp-null-hop
- (make-tramp-file-name :user (user-login-name) :host tramp-system-name)
-"Connection hop which identifies the virtual hop before the first one.")
+ (make-tramp-file-name
+ :method "local" :user (user-login-name) :host tramp-system-name)
+ "Connection hop which identifies the virtual hop before the first one.
+Used also for caching properties of the local machine.")
(defun tramp-file-name-user-domain (vec)
"Return user and domain components of VEC."
+ (declare (tramp-suppress-trace t))
(when (or (tramp-file-name-user vec) (tramp-file-name-domain vec))
(concat (tramp-file-name-user vec)
(and (tramp-file-name-domain vec)
tramp-prefix-domain-format)
(tramp-file-name-domain vec))))
-(put #'tramp-file-name-user-domain 'tramp-suppress-trace t)
-
(defun tramp-file-name-host-port (vec)
"Return host and port components of VEC."
+ (declare (tramp-suppress-trace t))
(when (or (tramp-file-name-host vec) (tramp-file-name-port vec))
(concat (tramp-file-name-host vec)
(and (tramp-file-name-port vec)
tramp-prefix-port-format)
(tramp-file-name-port vec))))
-(put #'tramp-file-name-host-port 'tramp-suppress-trace t)
-
(defun tramp-file-name-port-or-default (vec)
"Return port component of VEC.
If nil, return `tramp-default-port'."
+ (declare (tramp-suppress-trace t))
(or (tramp-file-name-port vec)
(tramp-get-method-parameter vec 'tramp-default-port)))
-(put #'tramp-file-name-port-or-default 'tramp-suppress-trace t)
-
;;;###tramp-autoload
(defun tramp-file-name-unify (vec &optional localname)
"Unify VEC by removing localname and hop from `tramp-file-name' structure.
-If LOCALNAME is an absolute file name, set it as localname. If
-LOCALNAME is a relative file name, return `tramp-cache-undefined'.
-Objects returned by this function compare `equal' if they refer to the
-same connection. Make a copy in order to avoid side effects."
+IF VEC is nil, set it to `tramp-null-hop'.
+If LOCALNAME is an absolute file name, set it as localname.
+If LOCALNAME is a relative file name, return `tramp-cache-undefined'.
+Objects returned by this function compare `equal' if they refer
+to the same connection. Make a copy in order to avoid side
+effects."
+ ;; (declare (tramp-suppress-trace t))
(if (and (stringp localname)
(not (file-name-absolute-p localname)))
(setq vec tramp-cache-undefined)
+ (unless vec (setq vec tramp-null-hop))
(when (tramp-file-name-p vec)
(setq vec (copy-tramp-file-name vec))
(setf (tramp-file-name-localname vec)
(and (stringp localname)
- (tramp-compat-file-name-unquote
- (directory-file-name localname)))
+ (file-name-unquote (directory-file-name localname)))
(tramp-file-name-hop vec) nil))
vec))
-(put #'tramp-file-name-unify 'tramp-suppress-trace t)
+;; We cannot use the `declare' form for `tramp-suppress-trace' in
+;; autoloaded functions, because the tramp-loaddefs.el generation
+;; would fail.
+(function-put #'tramp-file-name-unify 'tramp-suppress-trace t)
;; Comparison of file names is performed by `tramp-equal-remote'.
(defun tramp-file-name-equal-p (vec1 vec2)
"Check, whether VEC1 and VEC2 denote the same `tramp-file-name'.
LOCALNAME and HOP do not count."
+ (declare (tramp-suppress-trace t))
(and (tramp-file-name-p vec1) (tramp-file-name-p vec2)
(equal (tramp-file-name-unify vec1)
(tramp-file-name-unify vec2))))
-(defun tramp-get-method-parameter (vec param)
+(defun tramp-get-method-parameter (vec param &optional default)
"Return the method parameter PARAM.
If VEC is a vector, check first in connection properties.
Afterwards, check in `tramp-methods'. If the `tramp-methods'
-entry does not exist, return nil."
+entry does not exist, return DEFAULT."
(let ((hash-entry
(replace-regexp-in-string (rx bos "tramp-") "" (symbol-name param))))
(if (tramp-connection-property-p vec hash-entry)
;; We use the cached property.
(tramp-get-connection-property vec hash-entry)
;; Use the static value from `tramp-methods'.
- (when-let ((methods-entry
+ (if-let ((methods-entry
(assoc
param (assoc (tramp-file-name-method vec) tramp-methods))))
- (cadr methods-entry)))))
+ (cadr methods-entry)
+ ;; Return the default value.
+ default))))
;; The localname can be quoted with "/:". Extract this.
(defun tramp-file-name-unquote-localname (vec)
"Return unquoted localname component of VEC."
- (tramp-compat-file-name-unquote (tramp-file-name-localname vec)))
+ (file-name-unquote (tramp-file-name-localname vec)))
;;;###tramp-autoload
(defun tramp-tramp-file-p (name)
"Return t if NAME is a string with Tramp file name syntax."
+ ;; (declare (tramp-suppress-trace t))
(and tramp-mode (stringp name)
;; No "/:" and "/c:". This is not covered by `tramp-file-name-regexp'.
(not (string-match-p (rx bos "/" (? alpha) ":") name))
@@ -1615,7 +1590,10 @@ entry does not exist, return nil."
(string-match-p tramp-file-name-regexp name)
t))
-(put #'tramp-tramp-file-p 'tramp-suppress-trace t)
+;; We cannot use the `declare' form for `tramp-suppress-trace' in
+;; autoloaded functions, because the tramp-loaddefs.el generation
+;; would fail.
+(function-put #'tramp-tramp-file-p 'tramp-suppress-trace t)
;; This function bypasses the file name handler approach. It is NOT
;; recommended to use it in any package if not absolutely necessary.
@@ -1639,12 +1617,13 @@ of `process-file', `start-file-process', or `shell-command'."
;; The localname can be quoted with "/:". Extract this.
(defun tramp-unquote-file-local-name (name)
"Return unquoted localname of NAME."
- (tramp-compat-file-name-unquote (tramp-file-local-name name)))
+ (file-name-unquote (tramp-file-local-name name)))
(defun tramp-find-method (method user host)
"Return the right method string to use depending on USER and HOST.
This is METHOD, if non-nil. Otherwise, do a lookup in
`tramp-default-method-alist' and `tramp-default-method'."
+ (declare (tramp-suppress-trace t))
(when (and method
(or (string-empty-p method)
(string-equal method tramp-default-method-marker)))
@@ -1666,12 +1645,11 @@ This is METHOD, if non-nil. Otherwise, do a lookup in
result
(propertize result 'tramp-default t))))
-(put #'tramp-find-method 'tramp-suppress-trace t)
-
(defun tramp-find-user (method user host)
"Return the right user string to use depending on METHOD and HOST.
This is USER, if non-nil. Otherwise, do a lookup in
`tramp-default-user-alist' and `tramp-default-user'."
+ (declare (tramp-suppress-trace t))
(let ((result
(or user
(let ((choices tramp-default-user-alist)
@@ -1689,12 +1667,11 @@ This is USER, if non-nil. Otherwise, do a lookup in
result
(propertize result 'tramp-default t))))
-(put #'tramp-find-user 'tramp-suppress-trace t)
-
(defun tramp-find-host (method user host)
"Return the right host string to use depending on METHOD and USER.
This is HOST, if non-nil. Otherwise, do a lookup in
`tramp-default-host-alist' and `tramp-default-host'."
+ (declare (tramp-suppress-trace t))
(let ((result
(or (and (tramp-compat-length> host 0) host)
(let ((choices tramp-default-host-alist)
@@ -1712,8 +1689,6 @@ This is HOST, if non-nil. Otherwise, do a lookup in
result
(propertize result 'tramp-default t))))
-(put #'tramp-find-host 'tramp-suppress-trace t)
-
;;;###tramp-autoload
(defun tramp-dissect-file-name (name &optional nodefault)
"Return a `tramp-file-name' structure of NAME, a remote file name.
@@ -1723,6 +1698,7 @@ localname (file name on remote host), and hop.
Unless NODEFAULT is non-nil, method, user and host are expanded
to their default values. For the other file name parts, no
default values are used."
+ ;; (declare (tramp-suppress-trace t))
(save-match-data
(unless (tramp-tramp-file-p name)
(tramp-user-error nil "Not a Tramp file name: \"%s\"" name))
@@ -1779,7 +1755,10 @@ default values are used."
(tramp-user-error
v "Method `%s' is not supported for multi-hops" method)))))))
-(put #'tramp-dissect-file-name 'tramp-suppress-trace t)
+;; We cannot use the `declare' form for `tramp-suppress-trace' in
+;; autoloaded functions, because the tramp-loaddefs.el generation
+;; would fail.
+(function-put #'tramp-dissect-file-name 'tramp-suppress-trace t)
;;;###tramp-autoload
(defun tramp-ensure-dissected-file-name (vec-or-filename)
@@ -1787,20 +1766,25 @@ default values are used."
VEC-OR-FILENAME may be either a string or a `tramp-file-name'.
If it's not a Tramp filename, return nil."
+ ;; (declare (tramp-suppress-trace t))
(cond
((tramp-file-name-p vec-or-filename) vec-or-filename)
((tramp-tramp-file-p vec-or-filename)
(tramp-dissect-file-name vec-or-filename))))
-(put #'tramp-ensure-dissected-file-name 'tramp-suppress-trace t)
+;; We cannot use the `declare' form for `tramp-suppress-trace' in
+;; autoloaded functions, because the tramp-loaddefs.el generation
+;; would fail.
+(function-put #'tramp-ensure-dissected-file-name 'tramp-suppress-trace t)
(defun tramp-dissect-hop-name (name &optional nodefault)
"Return a `tramp-file-name' structure of `hop' part of NAME.
See `tramp-dissect-file-name' for details."
+ (declare (tramp-suppress-trace t))
(let ((v (tramp-dissect-file-name
(concat tramp-prefix-format
(replace-regexp-in-string
- (tramp-compat-rx (regexp tramp-postfix-hop-regexp) eos)
+ (rx (regexp tramp-postfix-hop-regexp) eos)
tramp-postfix-host-format name))
nodefault)))
;; Only some methods from tramp-sh.el do support multi-hops.
@@ -1811,14 +1795,14 @@ See `tramp-dissect-file-name' for details."
;; Return result.
v))
-(put #'tramp-dissect-hop-name 'tramp-suppress-trace t)
-
+;;;###tramp-autoload
(defsubst tramp-string-empty-or-nil-p (string)
"Check whether STRING is empty or nil."
(or (null string) (string= string "")))
(defun tramp-buffer-name (vec)
"A name for the connection buffer VEC."
+ (declare (tramp-suppress-trace t))
(let ((method (tramp-file-name-method vec))
(user-domain (tramp-file-name-user-domain vec))
(host-port (tramp-file-name-host-port vec)))
@@ -1826,20 +1810,13 @@ See `tramp-dissect-file-name' for details."
(format "*tramp/%s %s*" method host-port)
(format "*tramp/%s %s@%s*" method user-domain host-port))))
-(put #'tramp-buffer-name 'tramp-suppress-trace t)
-
;;;###tramp-autoload
(defun tramp-make-tramp-file-name (&rest args)
"Construct a Tramp file name from ARGS.
-
-ARGS could have two different signatures. The first one is of
-type (VEC &optional LOCALNAME).
If LOCALNAME is nil, the value in VEC is used. If it is a
symbol, a null localname will be used. Otherwise, LOCALNAME is
-expected to be a string, which will be used.
-
-The other signature exists for backward compatibility. It has
-the form (METHOD USER DOMAIN HOST PORT LOCALNAME &optional HOP)."
+expected to be a string, which will be used."
+ (declare (advertised-calling-convention (vec &optional localname) "29.1"))
(let (method user domain host port localname hop)
(cond
((tramp-file-name-p (car args))
@@ -1892,9 +1869,6 @@ the form (METHOD USER DOMAIN HOST PORT LOCALNAME &optional HOP)."
tramp-postfix-host-format
localname)))
-(set-advertised-calling-convention
- #'tramp-make-tramp-file-name '(vec &optional localname) "29.1")
-
(defun tramp-make-tramp-hop-name (vec)
"Construct a Tramp hop name from VEC."
(concat
@@ -1902,8 +1876,7 @@ the form (METHOD USER DOMAIN HOST PORT LOCALNAME &optional HOP)."
(replace-regexp-in-string
tramp-prefix-regexp ""
(replace-regexp-in-string
- (tramp-compat-rx
- (regexp tramp-postfix-host-regexp) eos)
+ (rx (regexp tramp-postfix-host-regexp) eos)
tramp-postfix-hop-format
(tramp-make-tramp-file-name (tramp-file-name-unify vec))))))
@@ -2009,366 +1982,6 @@ of `current-buffer'."
buffer (current-buffer))
(substring-no-properties (buffer-string))))
-(defun tramp-debug-buffer-name (vec)
- "A name for the debug buffer for VEC."
- (let ((method (tramp-file-name-method vec))
- (user-domain (tramp-file-name-user-domain vec))
- (host-port (tramp-file-name-host-port vec)))
- (if (tramp-string-empty-or-nil-p user-domain)
- (format "*debug tramp/%s %s*" method host-port)
- (format "*debug tramp/%s %s@%s*" method user-domain host-port))))
-
-(put #'tramp-debug-buffer-name 'tramp-suppress-trace t)
-
-(defconst tramp-debug-outline-regexp
- (rx ;; Timestamp.
- (+ digit) ":" (+ digit) ":" (+ digit) "." (+ digit) blank
- ;; Thread.
- (? (group "#<thread " (+ nonl) ">") blank)
- ;; Function name, verbosity.
- (+ (any "-" alnum)) " (" (group (+ digit)) ") #")
- "Used for highlighting Tramp debug buffers in `outline-mode'.")
-
-(defconst tramp-debug-font-lock-keywords
- ;; FIXME: Make it a function instead of an ELisp expression, so you
- ;; can evaluate it with `funcall' rather than `eval'!
- ;; Also, in `font-lock-defaults' you can specify a function name for
- ;; the "KEYWORDS" part, so font-lock calls it to get the actual keywords!
- '(list
- (tramp-compat-rx bol (regexp tramp-debug-outline-regexp) (+ nonl))
- '(1 font-lock-warning-face t t)
- '(0 (outline-font-lock-face) keep t))
- "Used for highlighting Tramp debug buffers in `outline-mode'.")
-
-(defun tramp-debug-outline-level ()
- "Return the depth to which a statement is nested in the outline.
-Point must be at the beginning of a header line.
-
-The outline level is equal to the verbosity of the Tramp message."
- (1+ (string-to-number (match-string 2))))
-
-(put #'tramp-debug-outline-level 'tramp-suppress-trace t)
-
-;; This function takes action since Emacs 28.1, when
-;; `read-extended-command-predicate' is set to
-;; `command-completion-default-include-p'.
-(defun tramp-debug-buffer-command-completion-p (_symbol buffer)
- "A predicate for Tramp interactive commands.
-They are completed by \"M-x TAB\" only in Tramp debug buffers."
- (with-current-buffer buffer
- (string-equal
- (buffer-substring (point-min) (min (+ (point-min) 10) (point-max)))
- ";; Emacs:")))
-
-(put #'tramp-debug-buffer-command-completion-p 'tramp-suppress-trace t)
-
-(defun tramp-setup-debug-buffer ()
- "Function to setup debug buffers."
- ;; (declare (completion tramp-debug-buffer-command-completion-p))
- (interactive)
- (set-buffer-file-coding-system 'utf-8)
- (setq buffer-undo-list t)
- ;; Activate `outline-mode'. This runs `text-mode-hook' and
- ;; `outline-mode-hook'. We must prevent that local processes die.
- ;; Yes: I've seen `flyspell-mode', which starts "ispell".
- ;; `(custom-declare-variable outline-minor-mode-prefix ...)' raises
- ;; on error in `(outline-mode)', we don't want to see it in the
- ;; traces.
- (let ((default-directory tramp-compat-temporary-file-directory))
- (outline-mode))
- (setq-local outline-level 'tramp-debug-outline-level)
- (setq-local font-lock-keywords
- ;; FIXME: This `(t FOO . BAR)' representation in
- ;; `font-lock-keywords' is supposed to be an internal
- ;; implementation "detail". Don't abuse it here!
- `(t (eval ,tramp-debug-font-lock-keywords t)
- ,(eval tramp-debug-font-lock-keywords t)))
- ;; Do not edit the debug buffer.
- (use-local-map special-mode-map)
- (set-buffer-modified-p nil)
- ;; For debugging purposes.
- (local-set-key "\M-n" 'clone-buffer)
- (add-hook 'clone-buffer-hook #'tramp-setup-debug-buffer nil 'local))
-
-(put #'tramp-setup-debug-buffer 'tramp-suppress-trace t)
-
-(function-put
- #'tramp-setup-debug-buffer 'completion-predicate
- #'tramp-debug-buffer-command-completion-p)
-
-(defun tramp-get-debug-buffer (vec)
- "Get the debug buffer for VEC."
- (with-current-buffer (get-buffer-create (tramp-debug-buffer-name vec))
- (when (bobp)
- (tramp-setup-debug-buffer))
- (current-buffer)))
-
-(put #'tramp-get-debug-buffer 'tramp-suppress-trace t)
-
-(defun tramp-get-debug-file-name (vec)
- "Get the debug file name for VEC."
- (expand-file-name
- (tramp-compat-string-replace "/" " " (tramp-debug-buffer-name vec))
- tramp-compat-temporary-file-directory))
-
-(put #'tramp-get-debug-file-name 'tramp-suppress-trace t)
-
-(defun tramp-trace-buffer-name (vec)
- "A name for the trace buffer for VEC."
- (tramp-compat-string-replace "debug" "trace" (tramp-debug-buffer-name vec)))
-
-(put #'tramp-trace-buffer-name 'tramp-suppress-trace t)
-
-(defvar tramp-trace-functions nil
- "A list of non-Tramp functions to be traced with `tramp-verbose' > 10.")
-
-;;;###tramp-autoload
-(defun tramp-debug-message (vec fmt-string &rest arguments)
- "Append message to debug buffer of VEC.
-Message is formatted with FMT-STRING as control string and the remaining
-ARGUMENTS to actually emit the message (if applicable)."
- (let ((inhibit-message t)
- create-lockfiles file-name-handler-alist message-log-max
- signal-hook-function)
- (with-current-buffer (tramp-get-debug-buffer vec)
- (goto-char (point-max))
- (let ((point (point)))
- (when (bobp)
- ;; Headline.
- (insert
- (format
- ";; Emacs: %s Tramp: %s -*- mode: outline; coding: utf-8; -*-"
- emacs-version tramp-version))
- (when (>= tramp-verbose 10)
- (let ((tramp-verbose 0))
- (insert
- (format
- "\n;; Location: %s Git: %s/%s"
- (locate-library "tramp")
- (or tramp-repository-branch "")
- (or tramp-repository-version "")))))
- ;; Traces.
- (when (>= tramp-verbose 11)
- (dolist
- (elt
- (append
- (mapcar
- #'intern (all-completions "tramp-" obarray #'functionp))
- tramp-trace-functions))
- (unless (get elt 'tramp-suppress-trace)
- (trace-function-background elt))))
- ;; Delete debug file.
- (when (and tramp-debug-to-file (tramp-get-debug-file-name vec))
- (ignore-errors (delete-file (tramp-get-debug-file-name vec)))))
- (unless (bolp)
- (insert "\n"))
- ;; Timestamp.
- (insert (format-time-string "%T.%6N "))
- ;; Calling Tramp function. We suppress compat and trace
- ;; functions from being displayed.
- (let ((btn 1) btf fn)
- (while (not fn)
- (setq btf (nth 1 (backtrace-frame btn)))
- (if (not btf)
- (setq fn "")
- (and (symbolp btf) (setq fn (symbol-name btf))
- (or (not (string-prefix-p "tramp" fn))
- (get btf 'tramp-suppress-trace))
- (setq fn nil))
- (setq btn (1+ btn))))
- ;; The following code inserts filename and line number.
- ;; Should be inactive by default, because it is time consuming.
- ;; (let ((ffn (find-function-noselect (intern fn))))
- ;; (insert
- ;; (format
- ;; "%s:%d: "
- ;; (file-name-nondirectory (buffer-file-name (car ffn)))
- ;; (with-current-buffer (car ffn)
- ;; (1+ (count-lines (point-min) (cdr ffn)))))))
- (insert (format "%s " fn)))
- ;; The message.
- (insert (apply #'format-message fmt-string arguments))
- ;; Write message to debug file.
- (when tramp-debug-to-file
- (ignore-errors
- (write-region
- point (point-max) (tramp-get-debug-file-name vec) 'append)))))))
-
-(put #'tramp-debug-message 'tramp-suppress-trace t)
-
-;;;###tramp-autoload
-(defvar tramp-inhibit-progress-reporter nil
- "Show Tramp progress reporter in the minibuffer.
-This variable is used to disable concurrent progress reporter messages.")
-
-;;;###tramp-autoload
-(defsubst tramp-message (vec-or-proc level fmt-string &rest arguments)
- "Emit a message depending on verbosity level.
-VEC-OR-PROC identifies the Tramp buffer to use. It can be either a
-vector or a process. LEVEL says to be quiet if `tramp-verbose' is
-less than LEVEL. The message is emitted only if `tramp-verbose' is
-greater than or equal to LEVEL.
-
-The message is also logged into the debug buffer when `tramp-verbose'
-is greater than or equal 4.
-
-Calls functions `message' and `tramp-debug-message' with FMT-STRING as
-control string and the remaining ARGUMENTS to actually emit the message (if
-applicable)."
- (ignore-errors
- (when (<= level tramp-verbose)
- ;; Display only when there is a minimum level, and the progress
- ;; reporter doesn't suppress further messages.
- (when (and (<= level 3) (null tramp-inhibit-progress-reporter))
- (apply #'message
- (concat
- (cond
- ((= level 0) "")
- ((= level 1) "")
- ((= level 2) "Warning: ")
- (t "Tramp: "))
- fmt-string)
- arguments))
- ;; Log only when there is a minimum level.
- (when (>= tramp-verbose 4)
- (let ((tramp-verbose 0))
- ;; Append connection buffer for error messages, if exists.
- (when (= level 1)
- (ignore-errors
- (setq fmt-string (concat fmt-string "\n%s")
- arguments
- (append
- arguments
- `(,(tramp-get-buffer-string
- (if (processp vec-or-proc)
- (process-buffer vec-or-proc)
- (tramp-get-connection-buffer
- vec-or-proc 'dont-create))))))))
- ;; Translate proc to vec.
- (when (processp vec-or-proc)
- (setq vec-or-proc (process-get vec-or-proc 'tramp-vector))))
- ;; Do it.
- (when (tramp-file-name-p vec-or-proc)
- (apply #'tramp-debug-message
- vec-or-proc
- (concat (format "(%d) # " level) fmt-string)
- arguments))))))
-
-(defsubst tramp-backtrace (&optional vec-or-proc force)
- "Dump a backtrace into the debug buffer.
-If VEC-OR-PROC is nil, the buffer *debug tramp* is used. FORCE
-forces the backtrace even if `tramp-verbose' is less than 10.
-This function is meant for debugging purposes."
- (let ((tramp-verbose (if force 10 tramp-verbose)))
- (when (>= tramp-verbose 10)
- (if vec-or-proc
- (tramp-message
- vec-or-proc 10 "\n%s" (with-output-to-string (backtrace)))
- (with-output-to-temp-buffer "*debug tramp*" (backtrace))))))
-
-(defun tramp-error (vec-or-proc signal fmt-string &rest arguments)
- "Emit an error.
-VEC-OR-PROC identifies the connection to use, SIGNAL is the
-signal identifier to be raised, remaining arguments passed to
-`tramp-message'. Finally, signal SIGNAL is raised with
-FMT-STRING and ARGUMENTS."
- (let (signal-hook-function)
- (tramp-backtrace vec-or-proc)
- (unless arguments
- ;; FMT-STRING could be just a file name, as in
- ;; `file-already-exists' errors. It could contain the ?\%
- ;; character, as in smb domain spec.
- (setq arguments (list fmt-string)
- fmt-string "%s"))
- (when vec-or-proc
- (tramp-message
- vec-or-proc 1 "%s"
- (error-message-string
- (list signal
- (get signal 'error-message)
- (apply #'format-message fmt-string arguments)))))
- (signal signal (list (substring-no-properties
- (apply #'format-message fmt-string arguments))))))
-
-(put #'tramp-error 'tramp-suppress-trace t)
-
-(defvar tramp-error-show-message-timeout 30
- "Time to show the Tramp buffer in case of an error.
-If it is bound to nil, the buffer is not shown. This is used in
-tramp-tests.el.")
-
-(defsubst tramp-error-with-buffer
- (buf vec-or-proc signal fmt-string &rest arguments)
- "Emit an error, and show BUF.
-If BUF is nil, show the connection buf. Wait for 30\", or until
-an input event arrives. The other arguments are passed to `tramp-error'."
- (save-window-excursion
- (let* ((buf (or (and (bufferp buf) buf)
- (and (processp vec-or-proc) (process-buffer vec-or-proc))
- (and (tramp-file-name-p vec-or-proc)
- (tramp-get-connection-buffer vec-or-proc))))
- (vec (or (and (tramp-file-name-p vec-or-proc) vec-or-proc)
- (and buf (tramp-dissect-file-name
- (tramp-get-default-directory buf))))))
- (unwind-protect
- (apply #'tramp-error vec-or-proc signal fmt-string arguments)
- ;; Save exit.
- (when (and buf
- (natnump tramp-error-show-message-timeout)
- (not (zerop tramp-verbose))
- ;; Do not show when flagged from outside.
- (not non-essential)
- ;; Show only when Emacs has started already.
- (current-message))
- (let ((enable-recursive-minibuffers t)
- inhibit-message)
- ;; `tramp-error' does not show messages. So we must do it
- ;; ourselves.
- (apply #'message fmt-string arguments)
- ;; Show buffer.
- (pop-to-buffer buf)
- (discard-input)
- (sit-for tramp-error-show-message-timeout)))
- ;; Reset timestamp. It would be wrong after waiting for a while.
- (when (tramp-file-name-equal-p vec (car tramp-current-connection))
- (setcdr tramp-current-connection (current-time)))))))
-
-;; We must make it a defun, because it is used earlier already.
-(defun tramp-user-error (vec-or-proc fmt-string &rest arguments)
- "Signal a user error (or \"pilot error\")."
- (unwind-protect
- (apply #'tramp-error vec-or-proc 'user-error fmt-string arguments)
- ;; Save exit.
- (when (and (natnump tramp-error-show-message-timeout)
- (not (zerop tramp-verbose))
- ;; Do not show when flagged from outside.
- (not non-essential)
- ;; Show only when Emacs has started already.
- (current-message))
- (let ((enable-recursive-minibuffers t)
- inhibit-message)
- ;; `tramp-error' does not show messages. So we must do it ourselves.
- (apply #'message fmt-string arguments)
- (discard-input)
- (sit-for tramp-error-show-message-timeout)
- ;; Reset timestamp. It would be wrong after waiting for a while.
- (when
- (tramp-file-name-equal-p vec-or-proc (car tramp-current-connection))
- (setcdr tramp-current-connection (current-time)))))))
-
-(put #'tramp-user-error 'tramp-suppress-trace t)
-
-(defmacro tramp-with-demoted-errors (vec-or-proc format &rest body)
- "Execute BODY while redirecting the error message to `tramp-message'.
-BODY is executed like wrapped by `with-demoted-errors'. FORMAT
-is a format-string containing a %-sequence meaning to substitute
-the resulting error message."
- (declare (indent 2) (debug (symbolp form body)))
- (let ((err (make-symbol "err")))
- `(condition-case-unless-debug ,err
- (progn ,@body)
- (error (tramp-message ,vec-or-proc 3 ,format ,err) nil))))
-
;; This macro shall optimize the cases where a `file-exists-p' call is
;; invoked first. Often, the file exists, so the remote command is
;; superfluous.
@@ -2385,33 +1998,19 @@ does not exist, otherwise propagate the error."
(tramp-error ,vec 'file-missing ,filename)
(signal (car ,err) (cdr ,err)))))))
-(defun tramp-test-message (fmt-string &rest arguments)
- "Emit a Tramp message according `default-directory'."
- (cond
- ((tramp-tramp-file-p default-directory)
- (apply #'tramp-message
- (tramp-dissect-file-name default-directory) 0 fmt-string arguments))
- ((tramp-file-name-p (car tramp-current-connection))
- (apply #'tramp-message
- (car tramp-current-connection) 0 fmt-string arguments))
- (t (apply #'message fmt-string arguments))))
-
-(put #'tramp-test-message 'tramp-suppress-trace t)
-
;; This function provides traces in case of errors not triggered by
;; Tramp functions.
(defun tramp-signal-hook-function (error-symbol data)
"Function to be called via `signal-hook-function'."
;; `custom-initialize-*' functions provoke `void-variable' errors.
;; We don't want to see them in the backtrace.
+ (declare (tramp-suppress-trace t))
(unless (eq error-symbol 'void-variable)
(let ((inhibit-message t))
(tramp-error
(car tramp-current-connection) error-symbol
(mapconcat (lambda (x) (format "%s" x)) data " ")))))
-(put #'tramp-signal-hook-function 'tramp-suppress-trace t)
-
(defmacro with-parsed-tramp-file-name (filename var &rest body)
"Parse a Tramp filename and make components available in the body.
@@ -2449,7 +2048,12 @@ If VAR is nil, then we bind `v' to the structure and `method', `user',
(let* ((parameters (cdr reporter))
(message (aref parameters 3)))
(when (tramp-compat-string-search message (or (current-message) ""))
- (tramp-compat-progress-reporter-update reporter value suffix))))
+ (progress-reporter-update reporter value suffix))))
+
+;;;###tramp-autoload
+(defvar tramp-inhibit-progress-reporter nil
+ "Show Tramp progress reporter in the minibuffer.
+This variable is used to disable concurrent progress reporter messages.")
(defmacro with-tramp-progress-reporter (vec level message &rest body)
"Execute BODY, spinning a progress reporter with MESSAGE in interactive mode.
@@ -2480,6 +2084,35 @@ without a visible progress reporter."
(if tm (cancel-timer tm))
(tramp-message ,vec ,level "%s...%s" ,message cookie)))))
+(defmacro with-tramp-timeout (list &rest body)
+ "Like `with-timeout', but allow SECONDS to be nil.
+
+\(fn (SECONDS TIMEOUT-FORMS...) BODY)"
+ (declare (indent 1) (debug ((form body) body)))
+ (let ((seconds (car list))
+ (timeout-forms (cdr list)))
+ ;; If non-nil, `seconds' must be a positive number.
+ `(if-let (((natnump ,seconds))
+ ((not (zerop timeout))))
+ (with-timeout (,seconds ,@timeout-forms) ,@body)
+ ,@body)))
+
+(defvar tramp-dont-suspend-timers nil
+ "Don't suspend timers when checking reentrant calls.
+This shouldn't be changed globally, but let-bind where needed.")
+
+(defmacro with-tramp-suspended-timers (&rest body)
+ "Run BODY with suspended timers.
+Obey `tramp-dont-suspend-timers'."
+ (declare (indent 0) (debug ((form body) body)))
+ `(if tramp-dont-suspend-timers
+ (progn ,@body)
+ (let ((stimers (with-timeout-suspend))
+ timer-list timer-idle-list)
+ (unwind-protect
+ (progn ,@body)
+ (with-timeout-unsuspend stimers)))))
+
(defun tramp-drop-volume-letter (name)
"Cut off unnecessary drive letter from file NAME.
The functions `tramp-*-handle-expand-file-name' call `expand-file-name'
@@ -2487,13 +2120,12 @@ locally on a remote file name. When the local system is a W32 system
but the remote system is Unix, this introduces a superfluous drive
letter into the file name. This function removes it."
(save-match-data
- (let ((quoted (tramp-compat-file-name-quoted-p name 'top))
- (result (tramp-compat-file-name-unquote name 'top)))
+ (let ((quoted (file-name-quoted-p name 'top))
+ (result (file-name-unquote name 'top)))
(setq result
(replace-regexp-in-string
- (tramp-compat-rx (regexp tramp-volume-letter-regexp) "/")
- "/" result))
- (if quoted (tramp-compat-file-name-quote result 'top) result))))
+ (rx (regexp tramp-volume-letter-regexp) "/") "/" result))
+ (if quoted (file-name-quote result 'top) result))))
;;; Config Manipulation Functions:
@@ -2538,6 +2170,8 @@ Example:
;; DNS-SD service type.
((string-match-p
tramp-dns-sd-service-regexp (nth 1 (car v))))
+ ;; Method.
+ ((string-equal method (nth 1 (car v))))
;; Configuration file or empty string.
(t (file-exists-p (nth 1 (car v))))))
(setq r (delete (car v) r)))
@@ -2602,7 +2236,7 @@ coding system might not be determined. This function repairs it."
;; We found a matching entry in `file-coding-system-alist'.
;; So we add a similar entry, but with the temporary file name
;; as regexp.
- (push (cons (tramp-compat-rx (literal tmpname)) (cdr elt)) result)))))
+ (push (cons (rx (literal tmpname)) (cdr elt)) result)))))
(defun tramp-run-real-handler (operation args)
"Invoke normal file name handler for OPERATION.
@@ -2652,15 +2286,13 @@ Must be handled by the callers."
file-name-nondirectory file-name-sans-versions
file-notify-add-watch file-ownership-preserved-p
file-readable-p file-regular-p file-remote-p
- file-selinux-context file-symlink-p file-truename
- file-writable-p find-backup-file-name get-file-buffer
- insert-directory insert-file-contents load
- make-directory set-file-acl set-file-modes
+ file-selinux-context file-symlink-p file-system-info
+ file-truename file-writable-p find-backup-file-name
+ get-file-buffer insert-directory insert-file-contents
+ load make-directory set-file-acl set-file-modes
set-file-selinux-context set-file-times
substitute-in-file-name unhandled-file-name-directory
vc-registered
- ;; Emacs 27+ only.
- file-system-info
;; Emacs 28- only.
make-directory-internal
;; Emacs 28+ only.
@@ -2703,12 +2335,12 @@ Must be handled by the callers."
(if (bufferp (nth 0 args)) (nth 0 args) (current-buffer))))
;; COMMAND.
((member operation
- '(make-nearby-temp-file process-file shell-command
- start-file-process temporary-file-directory
- ;; Emacs 27+ only.
- exec-path make-process
+ '(exec-path make-nearby-temp-file make-process process-file
+ shell-command start-file-process temporary-file-directory
;; Emacs 29+ only.
- list-system-processes memory-info process-attributes))
+ list-system-processes memory-info process-attributes
+ ;; Emacs 30+ only.
+ file-group-gid file-user-uid))
default-directory)
;; PROC.
((member operation '(file-notify-rm-watch file-notify-valid-p))
@@ -2785,22 +2417,20 @@ Fall back to normal file name handler if no Tramp file name handler exists."
tramp-compat-temporary-file-directory)
file-name-handler-alist)
(autoload-do-load sf foreign)))
- ;; (tramp-message
- ;; v 4 "Running `%s'..." (cons operation args))
- ;; If `non-essential' is non-nil, Tramp shall
- ;; not open a new connection.
- ;; If Tramp detects that it shouldn't continue
- ;; to work, it throws the `suppress' event.
- ;; This could happen for example, when Tramp
- ;; tries to open the same connection twice in
- ;; a short time frame.
- ;; In both cases, we try the default handler then.
- (setq result
- (catch 'non-essential
- (catch 'suppress
- (apply foreign operation args))))
- ;; (tramp-message
- ;; v 4 "Running `%s'...`%s'" (cons operation args) result)
+ (with-tramp-debug-message
+ v (format "Running `%S'" (cons operation args))
+ ;; If `non-essential' is non-nil, Tramp shall
+ ;; not open a new connection.
+ ;; If Tramp detects that it shouldn't continue
+ ;; to work, it throws the `suppress' event.
+ ;; This could happen for example, when Tramp
+ ;; tries to open the same connection twice in
+ ;; a short time frame.
+ ;; In both cases, we try the default handler then.
+ (setq result
+ (catch 'non-essential
+ (catch 'suppress
+ (apply foreign operation args)))))
(cond
((eq result 'non-essential)
(tramp-message
@@ -2887,7 +2517,7 @@ remote file names."
#'file-name-sans-extension
(directory-files
dir nil (rx bos "tramp" (+ nonl) ".el" (? "c") eos)))))
- (files-regexp (tramp-compat-rx bol (regexp (regexp-opt files)) eol)))
+ (files-regexp (rx bol (regexp (regexp-opt files)) eol)))
(mapatoms
(lambda (atom)
(when (and (functionp atom)
@@ -2924,7 +2554,7 @@ remote file names."
(put #'tramp-completion-file-name-handler 'operations
(mapcar #'car tramp-completion-file-name-handler-alist))
- ;; Integrated in Emacs 27.
+ ;; After unloading, `tramp-archive-enabled' might not be defined.
(when (bound-and-true-p tramp-archive-enabled)
(add-to-list 'file-name-handler-alist
(cons tramp-archive-file-name-regexp
@@ -2990,6 +2620,25 @@ whether HANDLER is to be called. Add operations defined in
(put #'tramp-unload-file-name-handlers 'tramp-autoload t)
(add-hook 'tramp-unload-hook #'tramp-unload-file-name-handlers)
+;;;###autoload
+(progn (defun inhibit-remote-files ()
+ "Deactivate remote file names."
+ (interactive)
+ (when (fboundp 'tramp-cleanup-all-connections)
+ (funcall 'tramp-cleanup-all-connections))
+ (tramp-unload-file-name-handlers)
+ (setq tramp-mode nil)))
+
+;;;###autoload
+(progn (defmacro without-remote-files (&rest body)
+ "Deactivate remote file names temporarily.
+Run BODY."
+ (declare (indent 0) (debug ((form body) body)))
+ `(let ((file-name-handler-alist (copy-tree file-name-handler-alist))
+ tramp-mode)
+ (tramp-unload-file-name-handlers)
+ ,@body)))
+
;;; File name handler functions for completion mode:
;; This function takes action since Emacs 28.1, when
@@ -3009,7 +2658,7 @@ not in completion mode."
(or ;; We check this for the process related to
;; `tramp-buffer-name'; otherwise `start-file-process'
;; wouldn't run ever when `non-essential' is non-nil.
- (and vec (process-live-p (get-process (tramp-buffer-name vec))))
+ (process-live-p (tramp-get-process vec))
(not non-essential))))
(defun tramp-completion-handle-expand-file-name (filename &optional directory)
@@ -3020,21 +2669,42 @@ not in completion mode."
(cond
((file-name-absolute-p filename) filename)
((and (eq tramp-syntax 'simplified)
- (string-match-p
- (tramp-compat-rx (regexp tramp-postfix-host-regexp) eos) dir))
+ (string-match-p (rx (regexp tramp-postfix-host-regexp) eos) dir))
(concat dir filename))
((string-match-p
- (tramp-compat-rx
- bos (regexp tramp-prefix-regexp)
- (* (regexp tramp-remote-file-name-spec-regexp)
- (regexp tramp-postfix-hop-regexp))
- (? (regexp tramp-method-regexp) (regexp tramp-postfix-method-regexp)
- (? (regexp tramp-user-regexp) (regexp tramp-postfix-user-regexp)))
- eos)
+ (rx (regexp tramp-prefix-regexp)
+ (* (regexp tramp-remote-file-name-spec-regexp)
+ (regexp tramp-postfix-hop-regexp))
+ (? (regexp tramp-method-regexp) (regexp tramp-postfix-method-regexp)
+ (? (regexp tramp-user-regexp) (regexp tramp-postfix-user-regexp)))
+ eos)
dir)
(concat dir filename))
(t (tramp-run-real-handler #'expand-file-name (list filename directory))))))
+;; This is needed in pcomplete.el.
+(defun tramp-completion-handle-file-directory-p (filename)
+ "Like `file-directory-p' for partial Tramp files."
+ ;; We need special handling only when a method is needed. Then we
+ ;; regard all files "/method:" or "/[method/" as existent, if
+ ;; "method" is a valid Tramp method.
+ (or (string-equal filename "/")
+ (and ;; Is it a valid method?
+ (not (string-empty-p tramp-postfix-method-format))
+ (string-match
+ (rx
+ (regexp tramp-prefix-regexp)
+ (* (regexp tramp-remote-file-name-spec-regexp)
+ (regexp tramp-postfix-hop-regexp))
+ (group-n 9 (regexp tramp-method-regexp))
+ (? (regexp tramp-postfix-method-regexp))
+ eos)
+ filename)
+ (assoc (match-string 9 filename) tramp-methods)
+ t)
+
+ (tramp-run-real-handler #'file-directory-p (list filename))))
+
(defun tramp-completion-handle-file-exists-p (filename)
"Like `file-exists-p' for partial Tramp files."
;; We need special handling only when a method is needed. Then we
@@ -3042,7 +2712,7 @@ not in completion mode."
;; "method" is a valid Tramp method. And we regard all files
;; "/method:user@", "/user@" or "/[method/user@" as existent, if
;; "user@" is a valid file name completion. Host completion is
- ;; performed in the respective backen operation.
+ ;; performed in the respective backend operation.
(or (and (cond
;; Completion styles like `flex' and `substring' check for
;; the file name "/". This does exist.
@@ -3050,7 +2720,7 @@ not in completion mode."
;; Is it a valid method?
((and (not (string-empty-p tramp-postfix-method-format))
(string-match
- (tramp-compat-rx
+ (rx
(regexp tramp-prefix-regexp)
(* (regexp tramp-remote-file-name-spec-regexp)
(regexp tramp-postfix-hop-regexp))
@@ -3061,7 +2731,7 @@ not in completion mode."
(assoc (match-string 9 filename) tramp-methods))
;; Is it a valid user?
((string-match
- (tramp-compat-rx
+ (rx
(regexp tramp-prefix-regexp)
(* (regexp tramp-remote-file-name-spec-regexp)
(regexp tramp-postfix-hop-regexp))
@@ -3086,7 +2756,7 @@ not in completion mode."
"Skeleton for `tramp-*-handle-filename-all-completions'.
BODY is the backend specific code."
(declare (indent 2) (debug t))
- `(tramp-compat-ignore-error file-missing
+ `(ignore-error file-missing
(delete-dups (delq nil
(let* ((case-fold-search read-file-name-completion-ignore-case)
(result (progn ,@body)))
@@ -3106,6 +2776,9 @@ BODY is the backend specific code."
result)
result))))))
+(defvar tramp--last-hop-directory nil
+ "Tracks the directory from which to run login programs.")
+
;; Method, host name and user name completion.
;; `tramp-completion-dissect-file-name' returns a list of
;; `tramp-file-name' structures. For all of them we return possible
@@ -3115,74 +2788,76 @@ BODY is the backend specific code."
(tramp-skeleton-file-name-all-completions filename directory
(let ((fullname
(tramp-drop-volume-letter (expand-file-name filename directory)))
- ;; When `tramp-syntax' is `simplified', we need a default method.
- (tramp-default-method
- (and (string-empty-p tramp-postfix-method-format)
- tramp-default-method))
- (tramp-default-method-alist
- (and (string-empty-p tramp-postfix-method-format)
- tramp-default-method-alist))
- tramp-default-user tramp-default-user-alist
- tramp-default-host tramp-default-host-alist
- hop result result1)
+ (directory (tramp-drop-volume-letter directory))
+ tramp--last-hop-directory hop result result1)
;; Suppress hop from completion.
(when (string-match
- (tramp-compat-rx
+ (rx
(regexp tramp-prefix-regexp)
(group (+ (regexp tramp-remote-file-name-spec-regexp)
(regexp tramp-postfix-hop-regexp))))
fullname)
(setq hop (match-string 1 fullname)
- fullname (replace-match "" nil nil fullname 1)))
-
- ;; Possible completion structures.
- (dolist (elt (tramp-completion-dissect-file-name fullname))
- (let* ((method (tramp-file-name-method elt))
- (user (tramp-file-name-user elt))
- (host (tramp-file-name-host elt))
- (localname (tramp-file-name-localname elt))
- (m (tramp-find-method method user host))
- all-user-hosts)
-
- (unless localname ;; Nothing to complete.
- (if (or user host)
- ;; Method dependent user / host combinations.
- (progn
- (mapc
- (lambda (x)
- (setq all-user-hosts
- (append all-user-hosts
- (funcall (nth 0 x) (nth 1 x)))))
- (tramp-get-completion-function m))
-
- (setq result
- (append result
- (mapcar
- (lambda (x)
- (tramp-get-completion-user-host
- method user host (nth 0 x) (nth 1 x)))
- (delq nil all-user-hosts)))))
-
- ;; Possible methods.
- (setq result
- (append result (tramp-get-completion-methods m)))))))
-
- ;; Add hop.
- (dolist (elt result)
- (when elt
- (string-match tramp-prefix-regexp elt)
- (setq elt (replace-match (concat tramp-prefix-format hop) nil nil elt))
- (push
- (substring elt (length (tramp-drop-volume-letter directory)))
- result1)))
-
- ;; Complete local parts.
- (append
- result1
- (ignore-errors
- (tramp-run-real-handler
- #'file-name-all-completions (list filename directory)))))))
+ fullname (replace-match "" nil nil fullname 1)
+ tramp--last-hop-directory
+ (tramp-make-tramp-file-name (tramp-dissect-hop-name hop))))
+
+ (let (;; When `tramp-syntax' is `simplified', we need a default method.
+ (tramp-default-method
+ (and (string-empty-p tramp-postfix-method-format)
+ tramp-default-method))
+ (tramp-default-method-alist
+ (and (string-empty-p tramp-postfix-method-format)
+ tramp-default-method-alist))
+ tramp-default-user tramp-default-user-alist
+ tramp-default-host tramp-default-host-alist)
+
+ ;; Possible completion structures.
+ (dolist (elt (tramp-completion-dissect-file-name fullname))
+ (let* ((method (tramp-file-name-method elt))
+ (user (tramp-file-name-user elt))
+ (host (tramp-file-name-host elt))
+ (localname (tramp-file-name-localname elt))
+ (m (tramp-find-method method user host))
+ all-user-hosts)
+
+ (unless localname ;; Nothing to complete.
+ (if (or user host)
+ ;; Method dependent user / host combinations.
+ (progn
+ (mapc
+ (lambda (x)
+ (setq all-user-hosts
+ (append all-user-hosts
+ (funcall (nth 0 x) (nth 1 x)))))
+ (tramp-get-completion-function m))
+
+ (setq result
+ (append result
+ (mapcar
+ (lambda (x)
+ (tramp-get-completion-user-host
+ method user host (nth 0 x) (nth 1 x)))
+ all-user-hosts))))
+
+ ;; Possible methods.
+ (setq result
+ (append result (tramp-get-completion-methods m hop)))))))
+
+ ;; Add hop.
+ (dolist (elt result)
+ (when elt
+ (setq elt (replace-regexp-in-string
+ tramp-prefix-regexp (concat tramp-prefix-format hop) elt))
+ (push (substring elt (length directory)) result1)))
+
+ ;; Complete local parts.
+ (append
+ result1
+ (ignore-errors
+ (tramp-run-real-handler
+ #'file-name-all-completions (list filename directory))))))))
;; Method, host name and user name completion for a file.
(defun tramp-completion-handle-file-name-completion
@@ -3219,14 +2894,14 @@ They are collected by `tramp-completion-dissect-file-name1'."
(let (;; "/method" "/[method"
(tramp-completion-file-name-structure1
(list
- (tramp-compat-rx
+ (rx
(regexp tramp-prefix-regexp)
(group (? (regexp tramp-completion-method-regexp))) eol)
1 nil nil nil))
;; "/method:user" "/[method/user"
(tramp-completion-file-name-structure2
(list
- (tramp-compat-rx
+ (rx
(regexp tramp-prefix-regexp)
(group (regexp tramp-method-regexp))
(regexp tramp-postfix-method-regexp)
@@ -3235,7 +2910,7 @@ They are collected by `tramp-completion-dissect-file-name1'."
;; "/method:host" "/[method/host"
(tramp-completion-file-name-structure3
(list
- (tramp-compat-rx
+ (rx
(regexp tramp-prefix-regexp)
(group (regexp tramp-method-regexp))
(regexp tramp-postfix-method-regexp)
@@ -3244,7 +2919,7 @@ They are collected by `tramp-completion-dissect-file-name1'."
;; "/method:[ipv6" "/[method/ipv6"
(tramp-completion-file-name-structure4
(list
- (tramp-compat-rx
+ (rx
(regexp tramp-prefix-regexp)
(group (regexp tramp-method-regexp))
(regexp tramp-postfix-method-regexp)
@@ -3254,7 +2929,7 @@ They are collected by `tramp-completion-dissect-file-name1'."
;; "/method:user@host" "/[method/user@host"
(tramp-completion-file-name-structure5
(list
- (tramp-compat-rx
+ (rx
(regexp tramp-prefix-regexp)
(group (regexp tramp-method-regexp))
(regexp tramp-postfix-method-regexp)
@@ -3265,7 +2940,7 @@ They are collected by `tramp-completion-dissect-file-name1'."
;; "/method:user@[ipv6" "/[method/user@ipv6"
(tramp-completion-file-name-structure6
(list
- (tramp-compat-rx
+ (rx
(regexp tramp-prefix-regexp)
(group (regexp tramp-method-regexp))
(regexp tramp-postfix-method-regexp)
@@ -3302,11 +2977,14 @@ remote host and localname (filename on remote host)."
;; This function returns all possible method completions, adding the
;; trailing method delimiter.
-(defun tramp-get-completion-methods (partial-method)
- "Return all method completions for PARTIAL-METHOD."
+(defun tramp-get-completion-methods (partial-method &optional multi-hop)
+ "Return all method completions for PARTIAL-METHOD.
+If MULTI-HOP is non-nil, return only multi-hop capable methods."
(mapcar
(lambda (method)
(and method (string-prefix-p (or partial-method "") method)
+ (or (not multi-hop)
+ (tramp-multi-hop-p (make-tramp-file-name :method method)))
(tramp-completion-make-tramp-file-name method nil nil nil)))
(mapcar #'car tramp-methods)))
@@ -3348,28 +3026,26 @@ PARTIAL-USER must match USER, PARTIAL-HOST must match HOST."
;; `filename' is "/[string" w/o a trailing method separator "/".
(cond
((string-match
- (tramp-compat-rx
- (group (regexp tramp-prefix-regexp)
- (* (regexp tramp-remote-file-name-spec-regexp)
- (regexp tramp-postfix-hop-regexp)))
- (? (regexp tramp-completion-method-regexp)) eos)
+ (rx (group (regexp tramp-prefix-regexp)
+ (* (regexp tramp-remote-file-name-spec-regexp)
+ (regexp tramp-postfix-hop-regexp)))
+ (? (regexp tramp-completion-method-regexp)) eos)
filename)
(match-string 1 filename))
((and (string-match
- (tramp-compat-rx
- (group
- (regexp tramp-prefix-regexp)
- (* (regexp tramp-remote-file-name-spec-regexp)
- (regexp tramp-postfix-hop-regexp))
- (group (regexp tramp-method-regexp))
- (regexp tramp-postfix-method-regexp)
- (? (regexp tramp-user-regexp)
- (regexp tramp-postfix-user-regexp)))
- (? (| (regexp tramp-host-regexp)
- (: (regexp tramp-prefix-ipv6-regexp)
- (? (regexp tramp-ipv6-regexp)
- (? (regexp tramp-postfix-ipv6-regexp))))))
- eos)
+ (rx (group
+ (regexp tramp-prefix-regexp)
+ (* (regexp tramp-remote-file-name-spec-regexp)
+ (regexp tramp-postfix-hop-regexp))
+ (group (regexp tramp-method-regexp))
+ (regexp tramp-postfix-method-regexp)
+ (? (regexp tramp-user-regexp)
+ (regexp tramp-postfix-user-regexp)))
+ (? (| (regexp tramp-host-regexp)
+ (: (regexp tramp-prefix-ipv6-regexp)
+ (? (regexp tramp-ipv6-regexp)
+ (? (regexp tramp-postfix-ipv6-regexp))))))
+ eos)
filename)
;; Is it a valid method?
(or (tramp-string-empty-or-nil-p (match-string 2 filename))
@@ -3387,6 +3063,12 @@ This function is added always in `tramp-get-completion-function'
for all methods. Resulting data are derived from default settings."
`((,(tramp-find-user method nil nil) ,(tramp-find-host method nil nil))))
+;;;###tramp-autoload
+(defcustom tramp-completion-multi-hop-methods nil
+ "Methods for which to provide completions over multi-hop connections."
+ :version "30.1"
+ :type '(repeat (string :tag "Method name")))
+
(defcustom tramp-completion-use-auth-sources auth-source-do-cache
"Whether to use `auth-source-search' for completion of user and host names.
This could be disturbing, if it requires a password / passphrase,
@@ -3409,7 +3091,7 @@ for all methods. Resulting data are derived from default settings."
"Return a (user host) tuple allowed to access.
User is always nil."
(let (result)
- (when (re-search-forward regexp (line-end-position) t)
+ (when (search-forward-regexp regexp (line-end-position) t)
(setq result (list nil (match-string match-level))))
(or
(> (skip-chars-forward skip-chars) 0)
@@ -3439,10 +3121,10 @@ Either user or host may be nil."
Either user or host may be nil."
(let (result
(regexp
- (tramp-compat-rx
+ (rx
bol (group (regexp tramp-host-regexp))
(? (+ blank) (group (regexp tramp-user-regexp))))))
- (when (re-search-forward regexp (line-end-position) t)
+ (when (search-forward-regexp regexp (line-end-position) t)
(setq result (append (list (match-string 2) (match-string 1)))))
(forward-line 1)
result))
@@ -3455,8 +3137,7 @@ User is always nil."
(defun tramp-parse-shosts-group ()
"Return a (user host) tuple allowed to access.
User is always nil."
- (tramp-parse-group
- (tramp-compat-rx bol (group (regexp tramp-host-regexp))) 1 ","))
+ (tramp-parse-group (rx bol (group (regexp tramp-host-regexp))) 1 ","))
(defun tramp-parse-sconfig (filename)
"Return a list of (user host) tuples allowed to access.
@@ -3467,7 +3148,7 @@ User is always nil."
"Return a (user host) tuple allowed to access.
User is always nil."
(tramp-parse-group
- (tramp-compat-rx
+ (rx
(| (: bol (* blank) "Host")
(: bol (+ nonl)) ;; ???
(group (regexp tramp-host-regexp))))
@@ -3492,15 +3173,14 @@ User is always nil."
User is always nil."
(tramp-parse-shostkeys-sknownhosts
dirname
- (tramp-compat-rx
- bol "key_" (+ digit) "_" (group (regexp tramp-host-regexp)) ".pub" eol)))
+ (rx bol "key_" (+ digit) "_" (group (regexp tramp-host-regexp)) ".pub" eol)))
(defun tramp-parse-sknownhosts (dirname)
"Return a list of (user host) tuples allowed to access.
User is always nil."
(tramp-parse-shostkeys-sknownhosts
dirname
- (tramp-compat-rx
+ (rx
bol (group (regexp tramp-host-regexp)) ".ssh-" (| "dss" "rsa") ".pub" eol)))
(defun tramp-parse-hosts (filename)
@@ -3512,8 +3192,7 @@ User is always nil."
"Return a (user host) tuple allowed to access.
User is always nil."
(tramp-parse-group
- (tramp-compat-rx
- bol (group (| (regexp tramp-ipv6-regexp) (regexp tramp-host-regexp))))
+ (rx bol (group (| (regexp tramp-ipv6-regexp) (regexp tramp-host-regexp))))
1 (rx blank)))
(defun tramp-parse-passwd (filename)
@@ -3532,8 +3211,8 @@ Host is always \"localhost\"."
"Return a (user host) tuple allowed to access.
Host is always \"localhost\"."
(let (result
- (regexp (tramp-compat-rx bol (group (regexp tramp-user-regexp)) ":")))
- (when (re-search-forward regexp (line-end-position) t)
+ (regexp (rx bol (group (regexp tramp-user-regexp)) ":")))
+ (when (search-forward-regexp regexp (line-end-position) t)
(setq result (list (match-string 1) "localhost")))
(forward-line 1)
result))
@@ -3583,15 +3262,14 @@ User is always nil."
(tramp-parse-putty-group registry-or-dirname)))))
;; UNIX case.
(tramp-parse-shostkeys-sknownhosts
- registry-or-dirname
- (tramp-compat-rx bol (group (regexp tramp-host-regexp)) eol))))
+ registry-or-dirname (rx bol (group (regexp tramp-host-regexp)) eol))))
(defun tramp-parse-putty-group (registry)
"Return a (user host) tuple allowed to access.
User is always nil."
(let (result
- (regexp (tramp-compat-rx (literal registry) "\\" (group (+ nonl)))))
- (when (re-search-forward regexp (line-end-position) t)
+ (regexp (rx (literal registry) "\\" (group (+ nonl)))))
+ (when (search-forward-regexp regexp (line-end-position) t)
(setq result (list nil (match-string 1))))
(forward-line 1)
result))
@@ -3617,15 +3295,35 @@ BODY is the backend specific code."
BODY is the backend specific code."
(declare (indent 3) (debug t))
`(with-parsed-tramp-file-name (expand-file-name ,directory) nil
- (if (and delete-by-moving-to-trash ,trash)
- ;; Move non-empty dir to trash only if recursive deletion was
- ;; requested.
- (if (not (or ,recursive (tramp-compat-directory-empty-p ,directory)))
- (tramp-error
- v 'file-error "Directory is not empty, not moving to trash")
- (move-file-to-trash ,directory))
- ,@body)
- (tramp-flush-directory-properties v localname)))
+ (let ((delete-by-moving-to-trash
+ (and delete-by-moving-to-trash
+ ;; This variable exists since Emacs 30.1.
+ (not (bound-and-true-p
+ remote-file-name-inhibit-delete-by-moving-to-trash)))))
+ (if (and delete-by-moving-to-trash ,trash)
+ ;; Move non-empty dir to trash only if recursive deletion was
+ ;; requested.
+ (if (not (or ,recursive (tramp-compat-directory-empty-p ,directory)))
+ (tramp-error
+ v 'file-error "Directory is not empty, not moving to trash")
+ (move-file-to-trash ,directory))
+ ,@body)
+ (tramp-flush-directory-properties v localname))))
+
+(defmacro tramp-skeleton-delete-file (filename &optional trash &rest body)
+ "Skeleton for `tramp-*-handle-delete-file'.
+BODY is the backend specific code."
+ (declare (indent 2) (debug t))
+ `(with-parsed-tramp-file-name (expand-file-name ,filename) nil
+ (let ((delete-by-moving-to-trash
+ (and delete-by-moving-to-trash
+ ;; This variable exists since Emacs 30.1.
+ (not (bound-and-true-p
+ remote-file-name-inhibit-delete-by-moving-to-trash)))))
+ (if (and delete-by-moving-to-trash ,trash)
+ (move-file-to-trash ,filename)
+ ,@body)
+ (tramp-flush-file-properties v localname))))
(defmacro tramp-skeleton-directory-files
(directory &optional full match nosort count &rest body)
@@ -3720,6 +3418,8 @@ BODY is the backend specific code."
(when (tramp-connectable-p ,filename)
(with-parsed-tramp-file-name (expand-file-name ,filename) nil
(with-tramp-file-property v localname "file-exists-p"
+ ;; Examine `file-attributes' cache to see if request can
+ ;; be satisfied without remote operation.
(if (tramp-file-property-p v localname "file-attributes")
(not
(null (tramp-get-file-property v localname "file-attributes")))
@@ -3740,6 +3440,99 @@ BODY is the backend specific code."
;; Trigger the `file-missing' error.
(signal 'error nil)))))
+(defmacro tramp-skeleton-file-truename (filename &rest body)
+ "Skeleton for `tramp-*-handle-file-truename'.
+BODY is the backend specific code."
+ (declare (indent 1) (debug (form body)))
+ ;; Preserve trailing "/".
+ `(funcall
+ (if (directory-name-p ,filename) #'file-name-as-directory #'identity)
+ ;; Quote properly.
+ (funcall
+ (if (file-name-quoted-p ,filename) #'file-name-quote #'identity)
+ (with-parsed-tramp-file-name
+ (file-name-unquote (expand-file-name ,filename)) nil
+ (tramp-make-tramp-file-name
+ v
+ (with-tramp-file-property v localname "file-truename"
+ (let (result)
+ (setq result (progn ,@body))
+ ;; Detect cycle.
+ (when (and (file-symlink-p ,filename)
+ (string-equal result localname))
+ (tramp-error
+ v 'file-error
+ "Apparent cycle of symbolic links for %s" ,filename))
+ ;; If the resulting localname looks remote, we must quote
+ ;; it for security reasons.
+ (when (tramp-tramp-file-p result)
+ (setq result (file-name-quote result 'top)))
+ result)))))))
+
+(defmacro tramp-skeleton-make-directory (dir &optional parents &rest body)
+ "Skeleton for `tramp-*-handle-make-directory'.
+BODY is the backend specific code."
+ ;; Since Emacs 29.1, PARENTS isn't propagated to the handlers
+ ;; anymore. And the return values are specified since then as well.
+ (declare (indent 2) (debug t))
+ `(let* ((dir (directory-file-name (expand-file-name ,dir)))
+ (par (file-name-directory dir)))
+ (with-parsed-tramp-file-name dir nil
+ (when (and (null ,parents) (file-exists-p dir))
+ (tramp-error v 'file-already-exists dir))
+ ;; Make missing directory parts.
+ (when ,parents
+ (unless (file-directory-p par)
+ (make-directory par ,parents)))
+ ;; Just do it.
+ (if (file-exists-p dir) t
+ (tramp-flush-file-properties v localname)
+ ,@body
+ nil))))
+
+(defmacro tramp-skeleton-make-symbolic-link
+ (target linkname &optional ok-if-already-exists &rest body)
+ "Skeleton for `tramp-*-handle-make-symbolic-link'.
+BODY is the backend specific code.
+If TARGET is a non-Tramp file, it is used verbatim as the target
+of the symlink. If TARGET is a Tramp file, only the localname
+component is used as the target of the symlink if it is located
+on the same host. Otherwise, TARGET is quoted."
+ (declare (indent 3) (debug t))
+ `(with-parsed-tramp-file-name (expand-file-name ,linkname) nil
+ ;; If TARGET is a Tramp name, use just the localname component.
+ ;; Don't check for a proper method.
+ (let ((non-essential t))
+ (when (and (tramp-tramp-file-p ,target)
+ (tramp-file-name-equal-p v (tramp-dissect-file-name ,target)))
+ (setf ,target (tramp-file-local-name (expand-file-name ,target))))
+ ;; There could be a cyclic link.
+ (tramp-flush-file-properties
+ v (expand-file-name ,target (tramp-file-local-name default-directory))))
+
+ ;; If TARGET is still remote, quote it.
+ (if (tramp-tramp-file-p ,target)
+ (make-symbolic-link
+ (file-name-quote ,target 'top) ,linkname ,ok-if-already-exists)
+
+ ;; Do the 'confirm if exists' thing.
+ (when (file-exists-p ,linkname)
+ ;; What to do?
+ (if (or (null ,ok-if-already-exists) ; not allowed to exist
+ (and (numberp ,ok-if-already-exists)
+ (not (yes-or-no-p
+ (format
+ "File %s already exists; make it a link anyway?"
+ localname)))))
+ (tramp-error v 'file-already-exists localname)
+ (delete-file ,linkname)))
+
+ ;; We must also flush the cache of the directory, because
+ ;; `file-attributes' reads the values from there.
+ (tramp-flush-file-properties v localname)
+
+ ,@body)))
+
(defmacro tramp-skeleton-set-file-modes-times-uid-gid
(filename &rest body)
"Skeleton for `tramp-*-set-file-{modes,times,uid-gid}'.
@@ -3812,7 +3605,7 @@ BODY is the backend specific code."
;; Lock file.
(when (and (not (auto-save-file-name-p
(file-name-nondirectory filename)))
- (file-remote-p lockname)
+ (tramp-tramp-file-p lockname)
(not file-locked))
(setq file-locked t)
;; `lock-file' exists since Emacs 28.1.
@@ -3916,21 +3709,55 @@ Let-bind it when necessary.")
vec (concat "~" (substring filename (match-beginning 1))))
(tramp-make-tramp-file-name (tramp-dissect-file-name filename)))))
+(defun tramp-handle-file-user-uid ()
+ "Like `file-user-uid' for Tramp files."
+ (let ((v (tramp-dissect-file-name default-directory)))
+ (or (tramp-get-remote-uid v 'integer)
+ ;; Some handlers for `tramp-get-remote-uid' return nil if they
+ ;; can't get the UID; always return -1 in this case for
+ ;; consistency.
+ tramp-unknown-id-integer)))
+
+(defun tramp-handle-file-group-gid ()
+ "Like `file-group-gid' for Tramp files."
+ (let ((v (tramp-dissect-file-name default-directory)))
+ (or (tramp-get-remote-gid v 'integer)
+ ;; Some handlers for `tramp-get-remote-gid' return nil if they
+ ;; can't get the GID; always return -1 in this case for
+ ;; consistency.
+ tramp-unknown-id-integer)))
+
(defun tramp-handle-access-file (filename string)
"Like `access-file' for Tramp files."
- (setq filename (file-truename filename))
- (with-parsed-tramp-file-name filename nil
- (if (file-exists-p filename)
- (unless
- (funcall
- (if (file-directory-p filename)
- #'file-accessible-directory-p #'file-readable-p)
- filename)
- (tramp-compat-permission-denied
- v (format "%s: Permission denied, %s" string filename)))
- (tramp-error
- v 'file-missing
- (format "%s: No such file or directory, %s" string filename)))))
+ (let ((timeout
+ ;; This variable exists since Emacs 30.1.
+ (bound-and-true-p remote-file-name-access-timeout))
+ (v (tramp-dissect-file-name
+ (if (file-name-absolute-p filename) filename default-directory)))
+ ;; We rely on timers, so don't suspend them.
+ (tramp-dont-suspend-timers t))
+ (with-tramp-timeout
+ (timeout
+ (unless (when-let ((p (tramp-get-connection-process v)))
+ (and (process-live-p p)
+ (tramp-get-connection-property p "connected")))
+ (tramp-cleanup-connection v 'keep-debug 'keep-password))
+ (tramp-error
+ v 'file-error
+ (format
+ "%s: Timeout %s second(s) accessing %s" string timeout filename)))
+ (setq filename (file-truename filename))
+ (if (file-exists-p filename)
+ (unless
+ (funcall
+ (if (file-directory-p filename)
+ #'file-accessible-directory-p #'file-readable-p)
+ filename)
+ (tramp-compat-permission-denied
+ v (format "%s: Permission denied, %s" string filename)))
+ (tramp-error
+ v 'file-missing
+ (format "%s: No such file or directory, %s" string filename))))))
(defun tramp-handle-add-name-to-file
(filename newname &optional ok-if-already-exists)
@@ -4024,8 +3851,7 @@ Let-bind it when necessary.")
;; not support tilde expansion. But users could declare a
;; respective connection property. (Bug#53847)
(when (string-match
- (tramp-compat-rx bos "~" (group (* (not "/"))) (group (* nonl)) eos)
- localname)
+ (rx bos "~" (group (* (not "/"))) (group (* nonl)) eos) localname)
(let ((uname (match-string 1 localname))
(fname (match-string 2 localname))
hname)
@@ -4128,6 +3954,9 @@ Let-bind it when necessary.")
(tramp-get-method-parameter v 'tramp-case-insensitive)
;; There isn't. So we must check, in case there's a connection already.
+ ;; Note: We cannot use it as DEFAULT value of
+ ;; `tramp-get-method-parameter', because it would be evalled
+ ;; during the call.
(and (let ((non-essential t)) (tramp-connectable-p v))
(with-tramp-connection-property v "case-insensitive"
(ignore-errors
@@ -4185,9 +4014,7 @@ Let-bind it when necessary.")
(and
completion-ignored-extensions
(string-match-p
- (tramp-compat-rx
- (regexp (regexp-opt completion-ignored-extensions)) eos)
- x)
+ (rx (regexp (regexp-opt completion-ignored-extensions)) eos) x)
;; We remember the hit.
(push x hits-ignored-extensions))))))
;; No match. So we try again for ignored files.
@@ -4220,18 +4047,11 @@ Let-bind it when necessary.")
((not (file-exists-p file2)) t)
;; Tramp reads and writes timestamps on second level. So we round
;; the timestamps to seconds without fractions.
- ;; `time-convert' has been introduced with Emacs 27.1.
- ((fboundp 'time-convert)
- (time-less-p
- (tramp-compat-funcall
- 'time-convert
- (file-attribute-modification-time (file-attributes file2)) 'integer)
- (tramp-compat-funcall
- 'time-convert
- (file-attribute-modification-time (file-attributes file1)) 'integer)))
(t (time-less-p
- (file-attribute-modification-time (file-attributes file2))
- (file-attribute-modification-time (file-attributes file1))))))
+ (time-convert
+ (file-attribute-modification-time (file-attributes file2)) 'integer)
+ (time-convert
+ (file-attribute-modification-time (file-attributes file1)) 'integer)))))
(defun tramp-handle-file-readable-p (filename)
"Like `file-readable-p' for Tramp files."
@@ -4265,13 +4085,14 @@ Let-bind it when necessary.")
(let ((tramp-verbose (min tramp-verbose 3)))
(when (tramp-tramp-file-p filename)
(let* ((o (tramp-dissect-file-name filename))
- (p (tramp-get-connection-process o))
+ (p (and (not (eq connected 'never))
+ (tramp-get-connection-process o)))
(c (and (process-live-p p)
(tramp-get-connection-property p "connected"))))
;; We expand the file name only, if there is already a connection.
(with-parsed-tramp-file-name
(if c (expand-file-name filename) filename) nil
- (and (or (not connected) c)
+ (and (or (memq connected '(nil never)) c)
(cond
((eq identification 'method) method)
;; Domain and port are appended to user and host,
@@ -4290,19 +4111,19 @@ Let-bind it when necessary.")
(defun tramp-handle-file-symlink-p (filename)
"Like `file-symlink-p' for Tramp files."
- (let ((x (file-attribute-type (file-attributes filename))))
- (and (stringp x) x)))
+ (with-parsed-tramp-file-name (expand-file-name filename) nil
+ ;; Some operations, like `file-truename', set the file property
+ ;; "file-symlink-marker". We can use it as indicator, and avoid a
+ ;; possible call of `file-attributes'.
+ (when (or (tramp-get-file-property v localname "file-symlink-marker")
+ (not (tramp-file-property-p v localname "file-symlink-marker")))
+ (let ((x (file-attribute-type (file-attributes filename))))
+ (and (stringp x) x)))))
(defun tramp-handle-file-truename (filename)
"Like `file-truename' for Tramp files."
- ;; Preserve trailing "/".
- (funcall
- (if (directory-name-p filename) #'file-name-as-directory #'identity)
- ;; Quote properly.
- (funcall
- (if (tramp-compat-file-name-quoted-p filename)
- #'tramp-compat-file-name-quote #'identity)
- (let ((result (tramp-compat-file-name-unquote (expand-file-name filename)))
+ (tramp-skeleton-file-truename filename
+ (let ((result (directory-file-name localname))
(numchase 0)
;; Don't make the following value larger than necessary.
;; People expect an error message in a timely fashion when
@@ -4312,31 +4133,21 @@ Let-bind it when necessary.")
;; Unquoting could enable encryption.
tramp-crypt-enabled
symlink-target)
- (with-parsed-tramp-file-name result v1
- ;; We cache only the localname.
- (tramp-make-tramp-file-name
- v1
- (with-tramp-file-property v1 v1-localname "file-truename"
- (while (and (setq symlink-target (file-symlink-p result))
- (< numchase numchase-limit))
- (setq numchase (1+ numchase)
- result
- (with-parsed-tramp-file-name (expand-file-name result) v2
- (tramp-make-tramp-file-name
- v2
- (if (stringp symlink-target)
- (if (file-remote-p symlink-target)
- (tramp-compat-file-name-quote symlink-target 'top)
- (tramp-drop-volume-letter
- (expand-file-name
- symlink-target
- (file-name-directory v2-localname))))
- v2-localname))))
- (when (>= numchase numchase-limit)
- (tramp-error
- v1 'file-error
- "Maximum number (%d) of symlinks exceeded" numchase-limit)))
- (tramp-file-local-name (directory-file-name result)))))))))
+ (while (and (setq symlink-target
+ (file-symlink-p (tramp-make-tramp-file-name v result)))
+ (< numchase numchase-limit))
+ (setq numchase (1+ numchase)
+ result
+ (if (tramp-tramp-file-p symlink-target)
+ (file-name-quote symlink-target 'top)
+ (tramp-drop-volume-letter
+ (expand-file-name
+ symlink-target (file-name-directory result)))))
+ (when (>= numchase numchase-limit)
+ (tramp-error
+ v 'file-error
+ "Maximum number (%d) of symlinks exceeded" numchase-limit)))
+ (directory-file-name result))))
(defun tramp-handle-file-writable-p (filename)
"Like `file-writable-p' for Tramp files."
@@ -4391,9 +4202,14 @@ Let-bind it when necessary.")
(tramp-error v 'file-error "Unsafe backup file name"))))))
(defun tramp-handle-insert-directory
- (filename switches &optional wildcard full-directory-p)
+ (filename switches &optional wildcard full-directory-p)
"Like `insert-directory' for Tramp files."
(require 'ls-lisp)
+ (defvar ls-lisp-dirs-first)
+ (defvar ls-lisp-emulation)
+ (defvar ls-lisp-ignore-case)
+ (defvar ls-lisp-use-insert-directory-program)
+ (defvar ls-lisp-verbosity)
(unless switches (setq switches ""))
;; Mark trailing "/".
(when (and (directory-name-p filename)
@@ -4404,8 +4220,14 @@ Let-bind it when necessary.")
(access-file filename "Reading directory"))
(with-parsed-tramp-file-name (expand-file-name filename) nil
(with-tramp-progress-reporter v 0 (format "Opening directory %s" filename)
- (let (ls-lisp-use-insert-directory-program start)
- ;; Silence byte compiler.
+ ;; We bind `ls-lisp-emulation' to nil (which is GNU).
+ ;; `ls-lisp-set-options' modifies `ls-lisp-ignore-case',
+ ;; `ls-lisp-dirs-first' and `ls-lisp-verbosity', so we bind them
+ ;; as well. We don't want to use `insert-directory-program'.
+ (let (ls-lisp-emulation ls-lisp-ignore-case ls-lisp-dirs-first
+ ls-lisp-verbosity ls-lisp-use-insert-directory-program start)
+ ;; Set proper options based on `ls-lisp-emulation'.
+ (tramp-compat-funcall 'ls-lisp-set-options)
(tramp-run-real-handler
#'insert-directory
(list filename switches wildcard full-directory-p))
@@ -4559,8 +4381,7 @@ Return it as number of seconds. Used in `tramp-process-attributes-ps-format'."
(defconst tramp-process-attributes-ps-args
`("-eww"
"-o"
- ,(mapconcat
- #'identity
+ ,(string-join
'("pid"
"euid"
"euser"
@@ -4636,53 +4457,49 @@ Parsing the remote \"ps\" output is controlled by
It is not guaranteed, that all process attributes as described in
`process-attributes' are returned. The additional attribute
`pid' shall be returned always."
- ;; Since Emacs 27.1.
- (when (fboundp 'connection-local-criteria-for-default-directory)
- (with-tramp-file-property vec "/" "process-attributes"
- (ignore-errors
- (with-temp-buffer
- (hack-connection-local-variables-apply
- (connection-local-criteria-for-default-directory))
- ;; (pop-to-buffer (current-buffer))
- (when (zerop
- (apply
- #'process-file
- "ps" nil t nil tramp-process-attributes-ps-args))
- (let (result res)
- (goto-char (point-min))
- (while (not (eobp))
- ;; (tramp-test-message
- ;; "%s" (buffer-substring (point) (line-end-position)))
- (when (save-excursion
- (search-forward-regexp
- (rx digit) (line-end-position) 'noerror))
- (setq res nil)
- (dolist (elt tramp-process-attributes-ps-format)
- (push
- (cons
- (car elt)
- (cond
- ((eq (cdr elt) 'number) (read (current-buffer)))
- ((eq (cdr elt) 'string)
- (search-forward-regexp (rx (+ (not blank))))
- (match-string 0))
- ((numberp (cdr elt))
- (search-forward-regexp (rx (+ blank)))
- (search-forward-regexp
- (rx (+ nonl)) (+ (point) (cdr elt)))
- (string-trim (match-string 0)))
- ((fboundp (cdr elt))
- (funcall (cdr elt)))
- ((null (cdr elt))
- (search-forward-regexp (rx (+ blank)))
- (buffer-substring (point) (line-end-position)))))
- res))
- ;; `nice' could be `-'.
- (setq res (rassq-delete-all '- res))
- (push (append res) result))
- (forward-line))
- ;; Return result.
- result)))))))
+ (with-tramp-file-property vec "/" "process-attributes"
+ (ignore-errors
+ (with-temp-buffer
+ (hack-connection-local-variables-apply
+ (connection-local-criteria-for-default-directory))
+ ;; (pop-to-buffer (current-buffer))
+ (when (zerop
+ (apply
+ #'process-file "ps" nil t nil tramp-process-attributes-ps-args))
+ (let (result res)
+ (goto-char (point-min))
+ (while (not (eobp))
+ ;; (tramp-test-message
+ ;; "%s" (buffer-substring (point) (line-end-position)))
+ (when (save-excursion
+ (search-forward-regexp
+ (rx digit) (line-end-position) 'noerror))
+ (setq res nil)
+ (dolist (elt tramp-process-attributes-ps-format)
+ (push
+ (cons
+ (car elt)
+ (cond
+ ((eq (cdr elt) 'number) (read (current-buffer)))
+ ((eq (cdr elt) 'string)
+ (search-forward-regexp (rx (+ (not blank))))
+ (match-string 0))
+ ((numberp (cdr elt))
+ (search-forward-regexp (rx (+ blank)))
+ (search-forward-regexp (rx (+ nonl)) (+ (point) (cdr elt)))
+ (string-trim (match-string 0)))
+ ((fboundp (cdr elt))
+ (funcall (cdr elt)))
+ ((null (cdr elt))
+ (search-forward-regexp (rx (+ blank)))
+ (buffer-substring (point) (line-end-position)))))
+ res))
+ ;; `nice' could be `-'.
+ (setq res (rassq-delete-all '- res))
+ (push (append res) result))
+ (forward-line))
+ ;; Return result.
+ result))))))
(defun tramp-handle-list-system-processes ()
"Like `list-system-processes' for Tramp files."
@@ -4797,11 +4614,22 @@ Do not set it manually, it is used buffer-local in `tramp-get-lock-pid'.")
(defun tramp-handle-unlock-file (file)
"Like `unlock-file' for Tramp files."
- (when-let ((lockname (tramp-compat-make-lock-file-name file)))
- (condition-case err
- (delete-file lockname)
- ;; `userlock--handle-unlock-error' exists since Emacs 28.1.
- (error (tramp-compat-funcall 'userlock--handle-unlock-error err)))))
+ (condition-case err
+ ;; When there is no connection, we don't do it. Otherwise,
+ ;; functions like `kill-buffer' would try to reestablish the
+ ;; connection. See Bug#61663.
+ (if-let ((v (tramp-dissect-file-name file))
+ ((process-live-p (tramp-get-process v)))
+ (lockname (tramp-compat-make-lock-file-name file)))
+ (delete-file lockname)
+ ;; Trigger the unlock error.
+ (signal 'file-error `("Cannot remove lock file for" ,file)))
+ ;; `userlock--handle-unlock-error' exists since Emacs 28.1. It
+ ;; checks for `create-lockfiles' since Emacs 30.1, we don't need
+ ;; this check here, then.
+ (error (unless (or (not create-lockfiles)
+ (bound-and-true-p remote-file-name-inhibit-locks))
+ (tramp-compat-funcall 'userlock--handle-unlock-error err)))))
(defun tramp-handle-load (file &optional noerror nomessage nosuffix must-suffix)
"Like `load' for Tramp files."
@@ -4829,8 +4657,9 @@ Do not set it manually, it is used buffer-local in `tramp-get-lock-pid'.")
(defun tramp-multi-hop-p (vec)
"Whether the method of VEC is capable of multi-hops."
- (and (tramp-sh-file-name-handler-p vec)
- (not (tramp-get-method-parameter vec 'tramp-copy-program))))
+ (let ((tramp-verbose 0))
+ (and (tramp-sh-file-name-handler-p vec)
+ (not (tramp-get-method-parameter vec 'tramp-copy-program)))))
(defun tramp-add-hops (vec)
"Add ad-hoc proxy definitions to `tramp-default-proxies-alist'."
@@ -4845,9 +4674,9 @@ Do not set it manually, it is used buffer-local in `tramp-get-lock-pid'.")
tramp-prefix-format proxy tramp-postfix-host-format))
(entry
(list (and (stringp host-port)
- (tramp-compat-rx bol (literal host-port) eol))
+ (rx bol (literal host-port) eol))
(and (stringp user-domain)
- (tramp-compat-rx bol (literal user-domain) eol))
+ (rx bol (literal user-domain) eol))
(propertize proxy 'tramp-ad-hoc t))))
;; Add the hop.
(unless (member entry tramp-default-proxies-alist)
@@ -4922,34 +4751,61 @@ Do not set it manually, it is used buffer-local in `tramp-get-lock-pid'.")
(or
;; The host name is used for the remote shell command.
(member
- "%h" (tramp-compat-flatten-tree
+ "%h" (flatten-tree
(tramp-get-method-parameter item 'tramp-login-args)))
;; The host name must match previous hop.
(string-match-p previous-host host))
(setq tramp-default-proxies-alist saved-tdpa)
(tramp-user-error
vec "Host name `%s' does not match `%s'" host previous-host))
- (setq previous-host (tramp-compat-rx bol (literal host) eol)))))
+ (setq previous-host (rx bol (literal host) eol)))))
;; Result.
target-alist))
-(defun tramp-expand-args (vec parameter &rest spec-list)
+(defvar tramp-extra-expand-args nil
+ "Method specific arguments.")
+
+(defun tramp-expand-args (vec parameter default &rest spec-list)
"Expand login arguments as given by PARAMETER in `tramp-methods'.
PARAMETER is a symbol like `tramp-login-args', denoting a list of
list of strings from `tramp-methods', containing %-sequences for
-substitution. SPEC-LIST is a list of char/value pairs used for
-`format-spec-make'."
- (let ((args (tramp-get-method-parameter vec parameter))
- (spec (apply 'format-spec-make spec-list)))
+substitution. DEFAULT is used when PARAMETER is not specified.
+SPEC-LIST is a list of char/value pairs used for
+`format-spec-make'. It is appended by `tramp-extra-expand-args',
+a connection-local variable."
+ (let ((args (tramp-get-method-parameter vec parameter default))
+ (extra-spec-list
+ (mapcar
+ #'eval
+ (buffer-local-value
+ 'tramp-extra-expand-args (tramp-get-connection-buffer vec))))
+ spec)
+ ;; Merge both spec lists. Remove duplicate entries.
+ (while spec-list
+ (unless (member (car spec-list) extra-spec-list)
+ (setq extra-spec-list
+ (append (tramp-compat-take 2 spec-list) extra-spec-list)))
+ (setq spec-list (cddr spec-list)))
+ (setq spec (apply #'format-spec-make extra-spec-list))
;; Expand format spec.
- (tramp-compat-flatten-tree
+ (flatten-tree
(mapcar
(lambda (x)
(setq x (mapcar (lambda (y) (format-spec y spec)) x))
(unless (member "" x) x))
args))))
+(defun tramp-post-process-creation (proc vec)
+ "Apply actions after creation of process PROC."
+ (declare (tramp-suppress-trace t))
+ (process-put proc 'tramp-vector vec)
+ (process-put proc 'adjust-window-size-function #'ignore)
+ (set-process-query-on-exit-flag proc nil)
+ (tramp-taint-remote-process-buffer (process-buffer proc))
+ (when (process-command proc)
+ (tramp-message vec 6 "%s" (string-join (process-command proc) " "))))
+
(defun tramp-direct-async-process-p (&rest args)
"Whether direct async `make-process' can be called."
(let ((v (tramp-dissect-file-name default-directory))
@@ -5007,7 +4863,12 @@ substitution. SPEC-LIST is a list of char/value pairs used for
(unless (or (null stderr) (bufferp stderr))
(signal 'wrong-type-argument (list #'bufferp stderr)))
- (let* ((buffer
+ ;; Check for `tramp-sh-file-name-handler', because something
+ ;; is different between tramp-sh.el, and tramp-adb.el or
+ ;; tramp-sshfs.el.
+ (let* ((sh-file-name-handler-p (tramp-sh-file-name-handler-p v))
+ (adb-file-name-handler-p (tramp-adb-file-name-p v))
+ (buffer
(if buffer
(get-buffer-create buffer)
;; BUFFER can be nil. We use a temporary buffer.
@@ -5027,6 +4888,12 @@ substitution. SPEC-LIST is a list of char/value pairs used for
(member
elt (default-toplevel-value 'process-environment))))
(setq env (cons elt env)))))
+ ;; Add remote path if exists.
+ (env (if-let ((sh-file-name-handler-p)
+ (remote-path
+ (string-join (tramp-get-remote-path v) ":")))
+ (setenv-internal env "PATH" remote-path 'keep)
+ env))
(env (setenv-internal
env "INSIDE_EMACS" (tramp-inside-emacs) 'keep))
(env (mapcar #'tramp-shell-quote-argument (delq nil env)))
@@ -5037,80 +4904,83 @@ substitution. SPEC-LIST is a list of char/value pairs used for
(append
`("cd" ,(tramp-shell-quote-argument localname) "&&" "(" "env")
env `(,command ")")))
- ;; Add remote shell if needed.
+ ;; Add remote shell if needed.
(command
(if (consp (tramp-get-method-parameter v 'tramp-direct-async))
(append
(tramp-get-method-parameter v 'tramp-direct-async)
- `(,(mapconcat #'identity command " ")))
- command)))
-
- ;; Check for `tramp-sh-file-name-handler', because something
- ;; is different between tramp-sh.el, and tramp-adb.el or
- ;; tramp-sshfs.el.
- (let* ((sh-file-name-handler-p (tramp-sh-file-name-handler-p v))
- (adb-file-name-handler-p (tramp-adb-file-name-p v))
- (login-program
- (tramp-get-method-parameter v 'tramp-login-program))
- ;; We don't create the temporary file. In fact, it
- ;; is just a prefix for the ControlPath option of
- ;; ssh; the real temporary file has another name, and
- ;; it is created and protected by ssh. It is also
- ;; removed by ssh when the connection is closed. The
- ;; temporary file name is cached in the main
- ;; connection process, therefore we cannot use
- ;; `tramp-get-connection-process'.
- (tmpfile
- (when sh-file-name-handler-p
- (with-tramp-connection-property
- (tramp-get-process v) "temp-file"
- (tramp-compat-make-temp-name))))
- (options
- (when sh-file-name-handler-p
- (tramp-compat-funcall
- 'tramp-ssh-controlmaster-options v)))
- (device
- (when adb-file-name-handler-p
- (tramp-compat-funcall
- 'tramp-adb-get-device v)))
- (pta (unless (eq connection-type 'pipe) "-t"))
- login-args p)
-
- ;; Replace `login-args' place holders. Split
- ;; ControlMaster options.
- (setq
- login-args
- (append
- (tramp-compat-flatten-tree
- (tramp-get-method-parameter v 'tramp-async-args))
- (tramp-compat-flatten-tree
- (mapcar
- (lambda (x) (split-string x " "))
- (tramp-expand-args
- v 'tramp-login-args
- ?h (or host "") ?u (or user "") ?p (or port "")
- ?c (format-spec (or options "") (format-spec-make ?t tmpfile))
- ?d (or device "") ?a (or pta "") ?l ""))))
- p (make-process
- :name name :buffer buffer
- :command (append `(,login-program) login-args command)
- :coding coding :noquery noquery :connection-type connection-type
- :sentinel sentinel :stderr stderr))
- ;; Set filter. Prior Emacs 29.1, it doesn't work reliably
- ;; to provide it as `make-process' argument when filter is
- ;; t. See Bug#51177.
- (when filter
- (set-process-filter p filter))
- (process-put p 'tramp-vector v)
- ;; This is needed for ssh or PuTTY based processes, and
- ;; only if the respective options are set. Perhaps, the
- ;; setting could be more fine-grained.
- ;; (process-put p 'tramp-shared-socket t)
- (process-put p 'remote-command orig-command)
- (tramp-set-connection-property p "remote-command" orig-command)
-
- (tramp-message v 6 "%s" (string-join (process-command p) " "))
- p))))))
+ `(,(string-join command " ")))
+ command))
+ (login-program
+ (tramp-get-method-parameter v 'tramp-login-program))
+ ;; We don't create the temporary file. In fact, it is
+ ;; just a prefix for the ControlPath option of ssh; the
+ ;; real temporary file has another name, and it is
+ ;; created and protected by ssh. It is also removed by
+ ;; ssh when the connection is closed. The temporary
+ ;; file name is cached in the main connection process,
+ ;; therefore we cannot use
+ ;; `tramp-get-connection-process'.
+ (tmpfile
+ (when sh-file-name-handler-p
+ (with-tramp-connection-property
+ (tramp-get-process v) "temp-file"
+ (tramp-compat-make-temp-name))))
+ (options
+ (when sh-file-name-handler-p
+ (tramp-compat-funcall
+ 'tramp-ssh-controlmaster-options v)))
+ (device
+ (when adb-file-name-handler-p
+ (tramp-compat-funcall
+ 'tramp-adb-get-device v)))
+ (pta (unless (eq connection-type 'pipe) "-t"))
+ login-args p)
+
+ ;; Command could be too long, for example due to a longish PATH.
+ (when (and sh-file-name-handler-p
+ (tramp-compat-length>
+ (string-join command) (tramp-get-remote-pipe-buf v)))
+ (signal 'error (cons "Command too long:" command)))
+
+ ;; Replace `login-args' place holders. Split ControlMaster
+ ;; options.
+ (setq
+ login-args
+ (append
+ (flatten-tree (tramp-get-method-parameter v 'tramp-async-args))
+ (flatten-tree
+ (mapcar
+ (lambda (x) (split-string x " "))
+ (tramp-expand-args
+ v 'tramp-login-args nil
+ ?h (or host "") ?u (or user "") ?p (or port "")
+ ?c (format-spec (or options "") (format-spec-make ?t tmpfile))
+ ?d (or device "") ?a (or pta "") ?l ""))))
+ p (make-process
+ :name name :buffer buffer
+ :command (append `(,login-program) login-args command)
+ :coding coding :noquery noquery :connection-type connection-type
+ :sentinel sentinel :stderr stderr))
+ ;; Set filter. Prior Emacs 29.1, it doesn't work reliably
+ ;; to provide it as `make-process' argument when filter is
+ ;; t. See Bug#51177.
+ (when filter
+ (set-process-filter p filter))
+ (tramp-post-process-creation p v)
+ ;; Query flag is overwritten in `tramp-post-process-creation',
+ ;; so we reset it.
+ (set-process-query-on-exit-flag p (null noquery))
+ ;; This is needed for ssh or PuTTY based processes, and
+ ;; only if the respective options are set. Perhaps, the
+ ;; setting could be more fine-grained.
+ ;; (process-put p 'tramp-shared-socket t)
+ (process-put p 'remote-command orig-command)
+ (tramp-set-connection-property p "remote-command" orig-command)
+ (when (bufferp stderr)
+ (tramp-taint-remote-process-buffer stderr))
+
+ p)))))
(defun tramp-handle-make-symbolic-link
(_target linkname &optional _ok-if-already-exists)
@@ -5131,25 +5001,25 @@ support symbolic links."
((zerop (process-file "cat" nil '(t) nil "/proc/meminfo"))
(goto-char (point-min))
(when
- (re-search-forward
+ (search-forward-regexp
(rx bol "MemTotal:" (* space) (group (+ digit)) (* space) "kB" eol)
nil 'noerror)
(setcar (nthcdr 0 result) (string-to-number (match-string 1))))
(goto-char (point-min))
(when
- (re-search-forward
+ (search-forward-regexp
(rx bol "MemFree:" (* space) (group (+ digit)) (* space) "kB" eol)
nil 'noerror)
(setcar (nthcdr 1 result) (string-to-number (match-string 1))))
(goto-char (point-min))
(when
- (re-search-forward
+ (search-forward-regexp
(rx bol "SwapTotal:" (* space) (group (+ digit)) (* space) "kB" eol)
nil 'noerror)
(setcar (nthcdr 2 result) (string-to-number (match-string 1))))
(goto-char (point-min))
(when
- (re-search-forward
+ (search-forward-regexp
(rx bol "SwapFree:" (* space) (group (+ digit)) (* space) "kB" eol)
nil 'noerror)
(setcar (nthcdr 3 result) (string-to-number (match-string 1)))))
@@ -5159,13 +5029,13 @@ support symbolic links."
((zerop (process-file "sysctl" nil '(t) nil "-a"))
(goto-char (point-min))
(when
- (re-search-forward
+ (search-forward-regexp
(rx bol "hw.pagesize:" (* space) (group (+ digit)) eol)
nil 'noerror)
(let ((pagesize (string-to-number (match-string 1))))
(goto-char (point-min))
(when
- (re-search-forward
+ (search-forward-regexp
(rx bol "vm.stats.vm.v_page_count:" (* space)
(group (+ digit)) eol)
nil 'noerror)
@@ -5174,7 +5044,7 @@ support symbolic links."
(/ (* (string-to-number (match-string 1)) pagesize) 1024)))
(goto-char (point-min))
(when
- (re-search-forward
+ (search-forward-regexp
(rx bol "vm.stats.vm.v_free_count:" (* space)
(group (+ digit)) eol)
nil 'noerror)
@@ -5185,7 +5055,7 @@ support symbolic links."
(when (zerop (process-file "swapctl" nil '(t) nil "-sk"))
(goto-char (point-min))
(when
- (re-search-forward
+ (search-forward-regexp
(rx bol "Total:" (* space)
(group (+ digit)) (* space) (group (+ digit)) eol)
nil 'noerror)
@@ -5290,19 +5160,11 @@ support symbolic links."
(when current-buffer-p
(barf-if-buffer-read-only)
(push-mark nil t))
- ;; `shell-command-save-pos-or-erase' has been introduced with
- ;; Emacs 27.1.
- (if (fboundp 'shell-command-save-pos-or-erase)
- (tramp-compat-funcall
- 'shell-command-save-pos-or-erase current-buffer-p)
- (setq buffer-read-only nil)
- (erase-buffer)))
+ (shell-command-save-pos-or-erase current-buffer-p))
(if (integerp asynchronous)
(let ((tramp-remote-process-environment
- ;; `async-shell-command-width' has been introduced with
- ;; Emacs 27.1.
- (if (natnump (bound-and-true-p async-shell-command-width))
+ (if (natnump async-shell-command-width)
(cons (format "COLUMNS=%d"
(bound-and-true-p async-shell-command-width))
tramp-remote-process-environment)
@@ -5356,11 +5218,7 @@ support symbolic links."
(goto-char (prog1 (mark t)
(set-marker (mark-marker) (point)
(current-buffer))))
- ;; `shell-command-set-point-after-cmd' has been
- ;; introduced with Emacs 27.1.
- (if (fboundp 'shell-command-set-point-after-cmd)
- (tramp-compat-funcall
- 'shell-command-set-point-after-cmd)))
+ (shell-command-set-point-after-cmd))
;; There's some output, display it.
(when (with-current-buffer output-buffer (> (point-max) (point-min)))
(display-message-or-buffer output-buffer)))))))
@@ -5368,10 +5226,7 @@ support symbolic links."
(defun tramp-handle-start-file-process (name buffer program &rest args)
"Like `start-file-process' for Tramp files.
BUFFER might be a list, in this case STDERR is separated."
- ;; `make-process' knows the `:file-handler' argument since Emacs
- ;; 27.1 only. Therefore, we invoke it via `tramp-file-name-handler'.
- (tramp-file-name-handler
- 'make-process
+ (make-process
:name name
:buffer (if (consp buffer) (car buffer) buffer)
:command (and program (cons program args))
@@ -5384,7 +5239,7 @@ BUFFER might be a list, in this case STDERR is separated."
"Like `substitute-in-file-name' for Tramp files.
\"//\" and \"/~\" substitute only in the local filename part."
;; Check, whether the local part is a quoted file name.
- (if (tramp-compat-file-name-quoted-p filename)
+ (if (file-name-quoted-p filename)
filename
;; First, we must replace environment variables.
(setq filename (tramp-replace-environment-variables filename))
@@ -5415,6 +5270,12 @@ BUFFER might be a list, in this case STDERR is separated."
(defconst tramp-time-doesnt-exist '(-1 65535)
"An invalid time value, used as \"Doesn't exist\" value.")
+(defsubst tramp-defined-time (time)
+ "Return TIME or nil (when TIME is not a time spec)."
+ (unless (or (time-equal-p time tramp-time-doesnt-exist)
+ (time-equal-p time tramp-time-dont-know))
+ time))
+
(defun tramp-handle-set-visited-file-modtime (&optional time-list)
"Like `set-visited-file-modtime' for Tramp files."
(unless (buffer-file-name)
@@ -5426,7 +5287,7 @@ BUFFER might be a list, in this case STDERR is separated."
(or (file-attribute-modification-time
(file-attributes (buffer-file-name)))
tramp-time-doesnt-exist))))
- (unless (tramp-compat-time-equal-p time-list tramp-time-dont-know)
+ (unless (time-equal-p time-list tramp-time-dont-know)
(tramp-run-real-handler #'set-visited-file-modtime (list time-list))))
(defun tramp-handle-verify-visited-file-modtime (&optional buf)
@@ -5452,14 +5313,13 @@ of."
(cond
;; File exists, and has a known modtime.
- ((and attr
- (not (tramp-compat-time-equal-p modtime tramp-time-dont-know)))
+ ((and attr (not (time-equal-p modtime tramp-time-dont-know)))
(< (abs (tramp-time-diff modtime mt)) 2))
;; Modtime has the don't know value.
(attr t)
;; If file does not exist, say it is not modified if and
;; only if that agrees with the buffer's record.
- (t (tramp-compat-time-equal-p mt tramp-time-doesnt-exist))))))))
+ (t (time-equal-p mt tramp-time-doesnt-exist))))))))
(defun tramp-handle-write-region
(start end filename &optional append visit lockname mustbenew)
@@ -5665,29 +5525,26 @@ The terminal type can be configured with `tramp-terminal-type'."
"Show the user a message for confirmation.
Wait, until the connection buffer changes."
(with-current-buffer (process-buffer proc)
- (let ((stimers (with-timeout-suspend))
- (cursor-in-echo-area t)
- set-message-function clear-message-function)
- ;; Silence byte compiler.
- (ignore set-message-function clear-message-function)
- (tramp-message vec 6 "\n%s" (buffer-string))
- (tramp-check-for-regexp proc tramp-process-action-regexp)
- (with-temp-message (concat (string-trim (match-string 0)) " ")
- ;; Hide message in buffer.
- (narrow-to-region (point-max) (point-max))
- ;; Wait for new output.
- (while (not (tramp-compat-ignore-error file-error
- (tramp-wait-for-regexp
- proc 0.1
- (tramp-compat-rx
- (| (regexp tramp-security-key-confirmed-regexp)
- (regexp tramp-security-key-pin-regexp)
- (regexp tramp-security-key-timeout-regexp))))))
- (when (tramp-check-for-regexp proc tramp-security-key-timeout-regexp)
- (throw 'tramp-action 'timeout))
- (redisplay 'force)))
- ;; Reenable the timers.
- (with-timeout-unsuspend stimers)))
+ (let ((cursor-in-echo-area t)
+ set-message-function clear-message-function tramp-dont-suspend-timers)
+ (with-tramp-suspended-timers
+ ;; Silence byte compiler.
+ (ignore set-message-function clear-message-function)
+ (tramp-message vec 6 "\n%s" (buffer-string))
+ (tramp-check-for-regexp proc tramp-process-action-regexp)
+ (with-temp-message (concat (string-trim (match-string 0)) " ")
+ ;; Hide message in buffer.
+ (narrow-to-region (point-max) (point-max))
+ ;; Wait for new output.
+ (while (not (ignore-error file-error
+ (tramp-wait-for-regexp
+ proc 0.1
+ (rx (| (regexp tramp-security-key-confirmed-regexp)
+ (regexp tramp-security-key-pin-regexp)
+ (regexp tramp-security-key-timeout-regexp))))))
+ (when (tramp-check-for-regexp proc tramp-security-key-timeout-regexp)
+ (throw 'tramp-action 'timeout))
+ (redisplay 'force))))))
t)
(defun tramp-action-process-alive (proc _vec)
@@ -5712,7 +5569,7 @@ Wait, until the connection buffer changes."
;; This can be ignored.
(with-current-buffer (process-buffer proc)
(goto-char (point-min))
- (if (re-search-forward tramp-operation-not-permitted-regexp nil t)
+ (if (search-forward-regexp tramp-operation-not-permitted-regexp nil t)
(progn
(tramp-message vec 5 "'set mode' error ignored.")
(tramp-message vec 3 "Process has finished.")
@@ -5735,14 +5592,13 @@ See `tramp-process-actions' for the format of ACTIONS."
;; Remove ANSI control escape sequences.
(with-current-buffer (tramp-get-connection-buffer vec)
(goto-char (point-min))
- (while (re-search-forward ansi-color-control-seq-regexp nil t)
+ (while (search-forward-regexp ansi-color-control-seq-regexp nil t)
(replace-match "")))
(setq todo actions)
(while todo
(setq item (pop todo)
tramp-process-action-regexp (symbol-value (nth 0 item))
- pattern
- (tramp-compat-rx (group (regexp tramp-process-action-regexp)) eos)
+ pattern (rx (group (regexp tramp-process-action-regexp)) eos)
action (nth 1 item))
(tramp-message
vec 5 "Looking for regexp \"%s\" from remote shell" pattern)
@@ -5787,12 +5643,7 @@ performed successfully. Any other value means an error."
proc 3 "Waiting for prompts from remote shell"
(let ((enable-recursive-minibuffers t)
exit)
- (if timeout
- (with-timeout (timeout (setq exit 'timeout))
- (while (not exit)
- (setq exit
- (catch 'tramp-action
- (tramp-process-one-action proc vec actions)))))
+ (with-tramp-timeout (timeout (setq exit 'timeout))
(while (not exit)
(setq exit (catch 'tramp-action
(tramp-process-one-action proc vec actions)))))
@@ -5848,11 +5699,12 @@ Mostly useful to protect BODY from being interrupted by timers."
(throw 'non-essential 'non-essential)
(tramp-error
,proc 'remote-file-error "Forbidden reentrant call of Tramp"))
- (unwind-protect
- (progn
- (tramp-set-connection-property ,proc "locked" t)
- ,@body)
- (tramp-flush-connection-property ,proc "locked"))))
+ (with-tramp-suspended-timers
+ (unwind-protect
+ (progn
+ (tramp-set-connection-property ,proc "locked" t)
+ ,@body)
+ (tramp-flush-connection-property ,proc "locked")))))
(defun tramp-accept-process-output (proc &optional _timeout)
"Like `accept-process-output' for Tramp processes.
@@ -5868,7 +5720,8 @@ If the user quits via `C-g', it is propagated up to `tramp-file-name-handler'."
(v (process-get proc 'tramp-vector)))
(dolist (p (delq proc (process-list)))
(when (tramp-file-name-equal-p v (process-get p 'tramp-vector))
- (with-local-quit (accept-process-output p 0 nil t)))))
+ (with-tramp-suspended-timers
+ (with-local-quit (accept-process-output p 0 nil t))))))
(with-current-buffer (process-buffer proc)
(let ((inhibit-read-only t)
@@ -5895,7 +5748,7 @@ Otherwise, return nil."
;; We restrict ourselves to the last 256 characters. There were
;; reports of a shell command "git ls-files -zco --exclude-standard"
;; with 85k files involved, which has blocked Tramp forever.
- (re-search-backward regexp (max (point-min) (- (point) 256)) 'noerror))
+ (search-backward-regexp regexp (max (point-min) (- (point) 256)) 'noerror))
(defun tramp-check-for-regexp (proc regexp)
"Check, whether REGEXP is contained in process buffer of PROC.
@@ -5907,12 +5760,12 @@ Erase echoed commands if exists."
;; the echo mark regexp is taken for search. We restrict the
;; search for the second echo mark to PIPE_BUF characters.
(when (and (tramp-get-connection-property proc "check-remote-echo")
- (re-search-forward
+ (search-forward-regexp
tramp-echoed-echo-mark-regexp
(+ (point) (* 5 tramp-echo-mark-marker-length)) t))
(let ((begin (match-beginning 0)))
(when
- (re-search-forward
+ (search-forward-regexp
tramp-echoed-echo-mark-regexp
(+ (point) (tramp-get-connection-property proc "pipe-buf" 4096)) t)
;; Discard echo from remote output.
@@ -5945,21 +5798,13 @@ Expects the output of PROC to be sent to the current buffer. Returns
the string that matched, or nil. Waits indefinitely if TIMEOUT is
nil."
(let ((found (tramp-check-for-regexp proc regexp)))
- (cond (timeout
- (with-timeout (timeout)
- (while (not found)
- (tramp-accept-process-output proc)
- (unless (process-live-p proc)
- (tramp-error-with-buffer
- nil proc 'file-error "Process has died"))
- (setq found (tramp-check-for-regexp proc regexp)))))
- (t
- (while (not found)
- (tramp-accept-process-output proc)
- (unless (process-live-p proc)
- (tramp-error-with-buffer
- nil proc 'file-error "Process has died"))
- (setq found (tramp-check-for-regexp proc regexp)))))
+ (with-tramp-timeout (timeout)
+ (while (not found)
+ (tramp-accept-process-output proc)
+ (unless (process-live-p proc)
+ (tramp-error-with-buffer
+ nil proc 'file-error "Process has died"))
+ (setq found (tramp-check-for-regexp proc regexp))))
;; The process could have timed out, for example due to session
;; timeout of sudo. The process buffer does not exist any longer then.
(ignore-errors
@@ -5996,8 +5841,7 @@ the remote host use line-endings as defined in the variable
(let ((inhibit-read-only t)) (delete-region (point-min) (point-max)))
;; Replace "\n" by `tramp-rsh-end-of-line'.
(setq string
- (mapconcat
- #'identity (split-string string "\n") tramp-rsh-end-of-line))
+ (string-join (split-string string "\n") tramp-rsh-end-of-line))
(unless (or (string-empty-p string)
(string-equal (substring string -1) tramp-rsh-end-of-line))
(setq string (concat string tramp-rsh-end-of-line)))
@@ -6029,8 +5873,7 @@ the remote host use line-endings as defined in the variable
(tramp-flush-directory-properties vec "/"))
(when (buffer-live-p buf)
(with-current-buffer buf
- (when (and prompt
- (tramp-search-regexp (tramp-compat-rx (literal prompt))))
+ (when (and prompt (tramp-search-regexp (rx (literal prompt))))
(delete-region (point) (point-max))))))))
(defun tramp-get-inode (vec)
@@ -6215,9 +6058,7 @@ ID-FORMAT valid values are `string' and `integer'."
(with-tramp-connection-property nil (format "gid-%s" id-format)
(cond
((equal id-format 'integer) (group-gid))
- ;; `group-name' has been introduced with Emacs 27.1.
- ((and (fboundp 'group-name) (equal id-format 'string))
- (tramp-compat-funcall 'group-name (group-gid)))
+ ((equal id-format 'string) (group-name (group-gid)))
((file-attribute-group-id (file-attributes "~/" id-format))))))
(defun tramp-get-local-locale (&optional vec)
@@ -6234,7 +6075,7 @@ VEC is used for tracing."
(while candidates
(goto-char (point-min))
(if (string-match-p
- (tramp-compat-rx bol (literal (car candidates)) (? "\r") eol)
+ (rx bol (literal (car candidates)) (? "\r") eol)
(buffer-string))
(setq locale (car candidates)
candidates nil)
@@ -6382,6 +6223,13 @@ to cache the result. Return the modified ATTR."
;; Set virtual device number.
(setcar (nthcdr 11 attr)
(tramp-get-device ,vec))
+ ;; Set SELinux context.
+ (when (stringp (nth 12 attr))
+ (tramp-set-file-property
+ ,vec ,localname "file-selinux-context"
+ (split-string (nth 12 attr) ":" 'omit)))
+ ;; Remove optional entries.
+ (setcdr (nthcdr 11 attr) nil)
attr)))))
;; Return normalized result.
@@ -6429,26 +6277,26 @@ ID-FORMAT valid values are `string' and `integer'."
(defun tramp-read-id-output (vec)
"Read in connection buffer the output of the `id' command.
-Set connection properties \"{uid,gid.groups}-{integer,string}\"."
+Set connection properties \"{uid,gid,groups}-{integer,string}\"."
(with-current-buffer (tramp-get-connection-buffer vec)
(let (uid-integer uid-string
gid-integer gid-string
groups-integer groups-string)
(goto-char (point-min))
;; Read uid.
- (when (re-search-forward
+ (when (search-forward-regexp
(rx "uid=" (group (+ digit)) "(" (group (+ (any "_-" alnum))) ")")
nil 'noerror)
(setq uid-integer (string-to-number (match-string 1))
uid-string (match-string 2)))
;; Read gid.
- (when (re-search-forward
+ (when (search-forward-regexp
(rx "gid=" (group (+ digit)) "(" (group (+ (any "_-" alnum))) ")")
nil 'noerror)
(setq gid-integer (string-to-number (match-string 1))
gid-string (match-string 2)))
;; Read groups.
- (when (re-search-forward (rx "groups=") nil 'noerror)
+ (when (search-forward-regexp (rx "groups=") nil 'noerror)
(while (looking-at
(rx (group (+ digit)) "(" (group (+ (any "_-" alnum))) ")"))
(setq groups-integer (cons (string-to-number (match-string 1))
@@ -6492,9 +6340,8 @@ This handles also chrooted environments, which are not regarded as local."
(defun tramp-get-remote-tmpdir (vec)
"Return directory for temporary files on the remote host identified by VEC."
(with-tramp-connection-property (tramp-get-process vec) "remote-tmpdir"
- (let ((dir
- (tramp-make-tramp-file-name
- vec (or (tramp-get-method-parameter vec 'tramp-tmpdir) "/tmp"))))
+ (let ((dir (tramp-make-tramp-file-name
+ vec (tramp-get-method-parameter vec 'tramp-tmpdir "/tmp"))))
(or (and (file-directory-p dir) (file-writable-p dir)
(tramp-file-local-name dir))
(tramp-error vec 'file-error "Directory %s not accessible" dir))
@@ -6521,6 +6368,7 @@ Return the local name of the temporary file."
(defun tramp-delete-temp-file-function ()
"Remove temporary files related to current buffer."
+ (declare (tramp-suppress-trace t))
(when (stringp tramp-temp-buffer-file-name)
(ignore-errors (delete-file tramp-temp-buffer-file-name))))
@@ -6564,7 +6412,7 @@ this file, if that variable is non-nil."
("|" . "__")
("[" . "_l")
("]" . "_r"))
- (tramp-compat-file-name-unquote (buffer-file-name)))
+ (file-name-unquote (buffer-file-name)))
tramp-auto-save-directory)))
result)
(prog1 ;; Run plain `make-auto-save-file-name'.
@@ -6593,7 +6441,7 @@ ALIST is of the form ((FROM . TO) ...)."
(let* ((pr (car alist))
(from (car pr))
(to (cdr pr)))
- (while (string-match (tramp-compat-rx (literal from)) string)
+ (while (string-match (rx (literal from)) string)
(setq string (replace-match to t t string)))
(setq alist (cdr alist))))
string))
@@ -6658,6 +6506,7 @@ are written with verbosity of 6."
(temporary-file-directory tramp-compat-temporary-file-directory)
(process-environment (default-toplevel-value 'process-environment))
(buffer (if (eq buffer t) (current-buffer) buffer))
+ (vec (or vec (car tramp-current-connection)))
result)
(tramp-message
vec 6 "`%s %s' %s %s %s %s"
@@ -6697,7 +6546,7 @@ verbosity of 6."
(apply #'process-lines program args)
(error
(tramp-error vec (car err) (cdr err)))))
- (tramp-message vec 6 "\n%s" (mapconcat #'identity result "\n"))
+ (tramp-message vec 6 "\n%s" (string-join result "\n"))
result))
(defun tramp-process-running-p (process-name)
@@ -6720,6 +6569,7 @@ verbosity of 6."
(defun tramp-read-passwd (proc &optional prompt)
"Read a password from user (compat function).
Consults the auth-source package."
+ (declare (tramp-suppress-trace t))
(let* (;; If `auth-sources' contains "~/.authinfo.gpg", and
;; `exec-path' contains a relative file name like ".", it
;; could happen that the "gpg" command is not found. So we
@@ -6746,9 +6596,7 @@ Consults the auth-source package."
(auth-source-creation-prompts `((secret . ,pw-prompt)))
;; Use connection-local value.
(auth-sources (buffer-local-value 'auth-sources (process-buffer proc)))
- ;; We suspend the timers while reading the password.
- (stimers (with-timeout-suspend))
- auth-info auth-passwd)
+ auth-info auth-passwd tramp-dont-suspend-timers)
(unwind-protect
;; We cannot use `with-parsed-tramp-file-name', because it
@@ -6773,7 +6621,7 @@ Consults the auth-source package."
(tramp-compat-auth-info-password auth-info))))
;; Try the password cache.
- (progn
+ (with-tramp-suspended-timers
(setq auth-passwd (password-read pw-prompt key)
tramp-password-save-function
(lambda () (password-cache-add key auth-passwd)))
@@ -6783,30 +6631,23 @@ Consults the auth-source package."
;; passwords. See discussion in Bug#50399.
(when (tramp-string-empty-or-nil-p auth-passwd)
(setq tramp-password-save-function nil))
- (tramp-set-connection-property vec "first-password-request" nil)
-
- ;; Reenable the timers.
- (with-timeout-unsuspend stimers))))
-
-(put #'tramp-read-passwd 'tramp-suppress-trace t)
+ (tramp-set-connection-property vec "first-password-request" nil))))
(defun tramp-read-passwd-without-cache (proc &optional prompt)
"Read a password from user (compat function)."
+ (declare (tramp-suppress-trace t))
;; We suspend the timers while reading the password.
- (let ((stimers (with-timeout-suspend)))
- (unwind-protect
- (password-read
- (or prompt
- (with-current-buffer (process-buffer proc)
- (tramp-check-for-regexp proc tramp-password-prompt-regexp)
- (match-string 0))))
- ;; Reenable the timers.
- (with-timeout-unsuspend stimers))))
-
-(put #'tramp-read-passwd-without-cache 'tramp-suppress-trace t)
+ (let (tramp-dont-suspend-timers)
+ (with-tramp-suspended-timers
+ (password-read
+ (or prompt
+ (with-current-buffer (process-buffer proc)
+ (tramp-check-for-regexp proc tramp-password-prompt-regexp)
+ (match-string 0)))))))
(defun tramp-clear-passwd (vec)
"Clear password cache for connection related to VEC."
+ (declare (tramp-suppress-trace t))
(let ((method (tramp-file-name-method vec))
(user-domain (tramp-file-name-user-domain vec))
(host-port (tramp-file-name-host-port vec))
@@ -6819,11 +6660,10 @@ Consults the auth-source package."
:host ,host-port :port ,method))
(password-cache-remove (tramp-make-tramp-file-name vec 'noloc))))
-(put #'tramp-clear-passwd 'tramp-suppress-trace t)
-
(defun tramp-time-diff (t1 t2)
"Return the difference between the two times, in seconds.
T1 and T2 are time values (as returned by `current-time' for example)."
+ (declare (tramp-suppress-trace t))
(float-time (time-subtract t1 t2)))
(defun tramp-unquote-shell-quote-argument (s)
@@ -6831,7 +6671,7 @@ T1 and T2 are time values (as returned by `current-time' for example)."
Suppress `shell-file-name'. This is needed on w32 systems, which
would use a wrong quoting for local file names. See `w32-shell-name'."
(let (shell-file-name)
- (shell-quote-argument (tramp-compat-file-name-unquote s))))
+ (shell-quote-argument (file-name-unquote s))))
;; Currently (as of Emacs 20.5), the function `shell-quote-argument'
;; does not deal well with newline characters. Newline is replaced by
@@ -6864,7 +6704,7 @@ Only works for Bourne-like shells."
(string= (substring result 0 2) "\\~"))
(setq result (substring result 1)))
(replace-regexp-in-string
- (tramp-compat-rx "\\" (literal tramp-rsh-end-of-line))
+ (rx "\\" (literal tramp-rsh-end-of-line))
(format "'%s'" tramp-rsh-end-of-line) result)))))
;;; Signal handling. This works for remote processes, which have set
diff --git a/lisp/net/trampver.el b/lisp/net/trampver.el
index 1647960ef0e..c131d39c110 100644
--- a/lisp/net/trampver.el
+++ b/lisp/net/trampver.el
@@ -7,8 +7,8 @@
;; Maintainer: Michael Albinus <michael.albinus@gmx.de>
;; Keywords: comm, processes
;; Package: tramp
-;; Version: 2.6.3-pre
-;; Package-Requires: ((emacs "26.1"))
+;; Version: 2.7.1-pre
+;; Package-Requires: ((emacs "27.1"))
;; Package-Type: multi
;; URL: https://www.gnu.org/software/tramp/
@@ -40,13 +40,14 @@
;; ./configure" to change them.
;;;###tramp-autoload
-(defconst tramp-version "2.6.3-pre"
+(defconst tramp-version "2.7.1-pre"
"This version of Tramp.")
;;;###tramp-autoload
(defconst tramp-bug-report-address "tramp-devel@gnu.org"
"Email address to send bug reports to.")
+;;;###tramp-autoload
(defconst tramp-repository-branch
(ignore-errors
;; Suppress message from `emacs-repository-get-branch'. We must
@@ -55,13 +56,12 @@
(dir (or (locate-dominating-file (locate-library "tramp") ".git")
source-directory))
debug-on-error)
- ;; `emacs-repository-get-branch' has been introduced with Emacs 27.1.
- (with-no-warnings
- (and (stringp dir) (file-directory-p dir)
- (executable-find "git")
- (emacs-repository-get-branch dir)))))
+ (and (stringp dir) (file-directory-p dir)
+ (executable-find "git")
+ (emacs-repository-get-branch dir))))
"The repository branch of the Tramp sources.")
+;;;###tramp-autoload
(defconst tramp-repository-version
(ignore-errors
;; Suppress message from `emacs-repository-get-version'. We must
@@ -76,9 +76,9 @@
"The repository revision of the Tramp sources.")
;; Check for Emacs version.
-(let ((x (if (not (string-version-lessp emacs-version "26.1"))
+(let ((x (if (not (string-version-lessp emacs-version "27.1"))
"ok"
- (format "Tramp 2.6.3-pre is not fit for %s"
+ (format "Tramp 2.7.1-pre is not fit for %s"
(replace-regexp-in-string "\n" "" (emacs-version))))))
(unless (string-equal "ok" x) (error "%s" x)))
diff --git a/lisp/net/webjump.el b/lisp/net/webjump.el
index c2c89e17ffb..cff838fca51 100644
--- a/lisp/net/webjump.el
+++ b/lisp/net/webjump.el
@@ -123,7 +123,7 @@ external browser like IceCat."
;; Misc. general interest.
("National Weather Service" . webjump-to-iwin)
("Usenet FAQs" .
- "www.faqs.org/faqs/")
+ "http://www.faqs.org/faqs/")
("RTFM Usenet FAQs by Group" .
"ftp://rtfm.mit.edu/pub/usenet-by-group/")
("RTFM Usenet FAQs by Hierarchy" .
@@ -132,7 +132,7 @@ external browser like IceCat."
;; Computer social issues, privacy, professionalism.
("Association for Computing Machinery" . "www.acm.org")
- ("Computer Professionals for Social Responsibility" . "www.cpsr.org")
+ ("Computer Professionals for Social Responsibility" . "http://www.cpsr.org")
("Electronic Frontier Foundation" . "www.eff.org")
("IEEE Computer Society" . "www.computer.org")
("Risks Digest" . webjump-to-risks)
@@ -194,7 +194,7 @@ If the symbol of a function is given, then the function will be called with the
Web site name (the one you specified in the CAR of the alist cell) as a
parameter. This might come in handy for various kludges.
-For convenience, if the `http://', `ftp://', or `file://' prefix is missing
+For convenience, if the `https://', `ftp://', or `file://' prefix is missing
from a URL, WebJump will make a guess at what you wanted and prepend it before
submitting the URL."
:type '(alist :key-type (string :tag "Name")
@@ -262,33 +262,22 @@ Please submit bug reports and other feedback to the author, Neil W. Van Dyke
(completing-read "WebJump to site: " webjump-sites nil t)
webjump-sites t))
(name (car item))
- (expr (cdr item)))
- (if webjump-use-internal-browser
- (browse-url-with-browser-kind
- 'internal (webjump-url-fix
- (cond ((not expr) "")
- ((stringp expr) expr)
- ((vectorp expr) (webjump-builtin expr name))
- ((listp expr) (eval expr t))
- ((symbolp expr)
- (if (fboundp expr)
- (funcall expr name)
- (error "WebJump URL function \"%s\" undefined"
- expr)))
- (t (error "WebJump URL expression for \"%s\" invalid"
- name)))))
- (browse-url (webjump-url-fix
- (cond ((not expr) "")
- ((stringp expr) expr)
- ((vectorp expr) (webjump-builtin expr name))
- ((listp expr) (eval expr t))
- ((symbolp expr)
- (if (fboundp expr)
- (funcall expr name)
- (error "WebJump URL function \"%s\" undefined"
- expr)))
- (t (error "WebJump URL expression for \"%s\" invalid"
- name))))))))
+ (expr (cdr item))
+ (fun (if webjump-use-internal-browser
+ (apply-partially #'browse-url-with-browser-kind 'internal)
+ #'browse-url)))
+ (funcall fun (webjump-url-fix
+ (cond ((not expr) "")
+ ((stringp expr) expr)
+ ((vectorp expr) (webjump-builtin expr name))
+ ((listp expr) (eval expr t))
+ ((symbolp expr)
+ (if (fboundp expr)
+ (funcall expr name)
+ (error "WebJump URL function \"%s\" undefined"
+ expr)))
+ (t (error "WebJump URL expression for \"%s\" invalid"
+ name)))))))
(defun webjump-builtin (expr name)
(if (< (length expr) 1)
@@ -380,9 +369,11 @@ Please submit bug reports and other feedback to the author, Neil W. Van Dyke
((string-match "^[a-zA-Z]+:" url) url)
((string-match "^/" url) (concat "file://" url))
((string-match "^\\([^\\./]+\\)" url)
+ ;; FIXME: ftp.gnu.org and many others now prefer HTTPS instead
+ ;; of FTP. Does this heuristic make sense these days?
(concat (if (string= (downcase (match-string 1 url)) "ftp")
"ftp"
- "http")
+ "https")
"://"
url))
(t url)))))
diff --git a/lisp/notifications.el b/lisp/notifications.el
index 3509968a6cd..2692df9d7fa 100644
--- a/lisp/notifications.el
+++ b/lisp/notifications.el
@@ -137,6 +137,12 @@ Various PARAMS can be set:
:app-icon The notification icon.
Default is `notifications-application-icon'.
Set to nil if you do not want any icon displayed.
+ If the value is a string, the function
+ interprets it as a file name and converts to
+ absolute by using `expand-file-name'; if it is a
+ symbol, the function will use its name (which is
+ useful when using the Icon Naming
+ Specification).
:actions A list of actions in the form:
(KEY TITLE KEY TITLE ...)
where KEY and TITLE are both strings.
@@ -304,7 +310,10 @@ of another `notifications-notify' call."
notifications-application-name)
:uint32 (or replaces-id 0)
:string (if app-icon
- (expand-file-name app-icon)
+ (if (stringp app-icon)
+ (expand-file-name app-icon)
+ ;; Convert symbol to string
+ (symbol-name app-icon))
;; If app-icon is nil because user
;; requested it to be so, send the
;; empty string
diff --git a/lisp/nxml/nxml-enc.el b/lisp/nxml/nxml-enc.el
index 6b0a850d476..b5b6c844ceb 100644
--- a/lisp/nxml/nxml-enc.el
+++ b/lisp/nxml/nxml-enc.el
@@ -3,7 +3,7 @@
;; Copyright (C) 2003, 2007-2024 Free Software Foundation, Inc.
;; Author: James Clark
-;; Keywords: wp, hypermedia, languages, XML
+;; Keywords: text, hypermedia, languages, XML
;; This file is part of GNU Emacs.
diff --git a/lisp/nxml/nxml-maint.el b/lisp/nxml/nxml-maint.el
index 54152a4e2b4..be49e41dbed 100644
--- a/lisp/nxml/nxml-maint.el
+++ b/lisp/nxml/nxml-maint.el
@@ -3,7 +3,7 @@
;; Copyright (C) 2003, 2007-2024 Free Software Foundation, Inc.
;; Author: James Clark
-;; Keywords: wp, hypermedia, languages, XML
+;; Keywords: text, hypermedia, languages, XML
;; This file is part of GNU Emacs.
@@ -26,7 +26,7 @@
;;; Parsing target repertoire files from ucs-fonts.
;; This is for converting the TARGET? files in
-;; http://www.cl.cam.ac.uk/~mgk25/download/ucs-fonts.tar.gz
+;; https://www.cl.cam.ac.uk/~mgk25/download/ucs-fonts.tar.gz
;; into a glyph set.
(defun nxml-insert-target-repertoire-glyph-set (file var)
diff --git a/lisp/nxml/nxml-mode.el b/lisp/nxml/nxml-mode.el
index f40e8085c7c..02391dc6968 100644
--- a/lisp/nxml/nxml-mode.el
+++ b/lisp/nxml/nxml-mode.el
@@ -3,7 +3,7 @@
;; Copyright (C) 2003-2004, 2007-2024 Free Software Foundation, Inc.
;; Author: James Clark
-;; Keywords: wp, hypermedia, languages, XML
+;; Keywords: text, hypermedia, languages, XML
;; This file is part of GNU Emacs.
@@ -151,17 +151,17 @@ This is not used directly, but only via inheritance by other faces."
This is not used directly, but only via inheritance by other faces."
:group 'nxml-faces)
+(defface nxml-text
+ '((t (:inherit default)))
+ "Face used to highlight text."
+ :group 'nxml-faces)
+
(defface nxml-delimiter
- nil
+ '((t (:inherit nxml-text)))
"Face used to highlight delimiters.
This is not used directly, but only via inheritance by other faces."
:group 'nxml-faces)
-(defface nxml-text
- nil
- "Face used to highlight text."
- :group 'nxml-faces)
-
(defface nxml-processing-instruction-delimiter
'((t (:inherit nxml-delimiter)))
"Face used for the delimiters of processing instructions, i.e., <? and ?>."
@@ -230,7 +230,7 @@ This includes the `x' in hex references."
:group 'nxml-faces)
(defface nxml-element-colon
- nil
+ '((t (:inherit nxml-delimiter)))
"Face used for the colon in element names."
:group 'nxml-faces)
@@ -390,7 +390,6 @@ reference.")
"C-c C-u" #'nxml-insert-named-char
"C-c C-o" nxml-outline-prefix-map
"/" #'nxml-electric-slash
- "M-TAB" #'completion-at-point
"S-<mouse-2>" #'nxml-mouse-hide-direct-text-content)
(defvar nxml-font-lock-keywords
diff --git a/lisp/nxml/nxml-ns.el b/lisp/nxml/nxml-ns.el
index a7a0649d224..10dafe32e62 100644
--- a/lisp/nxml/nxml-ns.el
+++ b/lisp/nxml/nxml-ns.el
@@ -3,7 +3,7 @@
;; Copyright (C) 2003, 2007-2024 Free Software Foundation, Inc.
;; Author: James Clark
-;; Keywords: wp, hypermedia, languages, XML
+;; Keywords: text, hypermedia, languages, XML
;; This file is part of GNU Emacs.
diff --git a/lisp/nxml/nxml-outln.el b/lisp/nxml/nxml-outln.el
index 5365013e436..a470fbdc5b1 100644
--- a/lisp/nxml/nxml-outln.el
+++ b/lisp/nxml/nxml-outln.el
@@ -3,7 +3,7 @@
;; Copyright (C) 2004, 2007-2024 Free Software Foundation, Inc.
;; Author: James Clark
-;; Keywords: wp, hypermedia, languages, XML
+;; Keywords: text, hypermedia, languages, XML
;; This file is part of GNU Emacs.
diff --git a/lisp/nxml/nxml-parse.el b/lisp/nxml/nxml-parse.el
index 92fccb262f4..61ff0b68b68 100644
--- a/lisp/nxml/nxml-parse.el
+++ b/lisp/nxml/nxml-parse.el
@@ -3,7 +3,7 @@
;; Copyright (C) 2003, 2007-2024 Free Software Foundation, Inc.
;; Author: James Clark
-;; Keywords: wp, hypermedia, languages, XML
+;; Keywords: text, hypermedia, languages, XML
;; This file is part of GNU Emacs.
diff --git a/lisp/nxml/nxml-rap.el b/lisp/nxml/nxml-rap.el
index 9ad9edd1231..6117b8bd33a 100644
--- a/lisp/nxml/nxml-rap.el
+++ b/lisp/nxml/nxml-rap.el
@@ -3,7 +3,7 @@
;; Copyright (C) 2003-2004, 2007-2024 Free Software Foundation, Inc.
;; Author: James Clark
-;; Keywords: wp, hypermedia, languages, XML
+;; Keywords: text, hypermedia, languages, XML
;; This file is part of GNU Emacs.
diff --git a/lisp/nxml/nxml-util.el b/lisp/nxml/nxml-util.el
index 5da169fc9be..7f425f8bcea 100644
--- a/lisp/nxml/nxml-util.el
+++ b/lisp/nxml/nxml-util.el
@@ -3,7 +3,7 @@
;; Copyright (C) 2003, 2007-2024 Free Software Foundation, Inc.
;; Author: James Clark
-;; Keywords: wp, hypermedia, languages, XML
+;; Keywords: text, hypermedia, languages, XML
;; This file is part of GNU Emacs.
diff --git a/lisp/nxml/rng-cmpct.el b/lisp/nxml/rng-cmpct.el
index 1331ed5aa91..9aa7eecf346 100644
--- a/lisp/nxml/rng-cmpct.el
+++ b/lisp/nxml/rng-cmpct.el
@@ -3,7 +3,7 @@
;; Copyright (C) 2003-2024 Free Software Foundation, Inc.
;; Author: James Clark
-;; Keywords: wp, hypermedia, languages, XML, RelaxNG
+;; Keywords: text, hypermedia, languages, XML, RelaxNG
;; This file is part of GNU Emacs.
diff --git a/lisp/nxml/rng-dt.el b/lisp/nxml/rng-dt.el
index 1592ba790ea..b7fd46dd894 100644
--- a/lisp/nxml/rng-dt.el
+++ b/lisp/nxml/rng-dt.el
@@ -3,7 +3,7 @@
;; Copyright (C) 2003, 2007-2024 Free Software Foundation, Inc.
;; Author: James Clark
-;; Keywords: wp, hypermedia, languages, XML, RelaxNG
+;; Keywords: text, hypermedia, languages, XML, RelaxNG
;; This file is part of GNU Emacs.
diff --git a/lisp/nxml/rng-loc.el b/lisp/nxml/rng-loc.el
index 77483dd3cfd..3e55bc5d4b9 100644
--- a/lisp/nxml/rng-loc.el
+++ b/lisp/nxml/rng-loc.el
@@ -3,7 +3,7 @@
;; Copyright (C) 2003, 2007-2024 Free Software Foundation, Inc.
;; Author: James Clark
-;; Keywords: wp, hypermedia, languages, XML, RelaxNG
+;; Keywords: text, hypermedia, languages, XML, RelaxNG
;; This file is part of GNU Emacs.
diff --git a/lisp/nxml/rng-maint.el b/lisp/nxml/rng-maint.el
index cf0c9ec5409..62f5ce8b93d 100644
--- a/lisp/nxml/rng-maint.el
+++ b/lisp/nxml/rng-maint.el
@@ -3,7 +3,7 @@
;; Copyright (C) 2003, 2007-2024 Free Software Foundation, Inc.
;; Author: James Clark
-;; Keywords: wp, hypermedia, languages, XML, RelaxNG
+;; Keywords: text, hypermedia, languages, XML, RelaxNG
;; This file is part of GNU Emacs.
diff --git a/lisp/nxml/rng-match.el b/lisp/nxml/rng-match.el
index f8e493e3ab2..61e4ffdb1a9 100644
--- a/lisp/nxml/rng-match.el
+++ b/lisp/nxml/rng-match.el
@@ -3,7 +3,7 @@
;; Copyright (C) 2003, 2007-2024 Free Software Foundation, Inc.
;; Author: James Clark
-;; Keywords: wp, hypermedia, languages, XML, RelaxNG
+;; Keywords: text, hypermedia, languages, XML, RelaxNG
;; This file is part of GNU Emacs.
diff --git a/lisp/nxml/rng-nxml.el b/lisp/nxml/rng-nxml.el
index a9bccd5686e..af16e7ae50b 100644
--- a/lisp/nxml/rng-nxml.el
+++ b/lisp/nxml/rng-nxml.el
@@ -3,7 +3,7 @@
;; Copyright (C) 2003, 2007-2024 Free Software Foundation, Inc.
;; Author: James Clark
-;; Keywords: wp, hypermedia, languages, XML, RelaxNG
+;; Keywords: text, hypermedia, languages, XML, RelaxNG
;; This file is part of GNU Emacs.
diff --git a/lisp/nxml/rng-parse.el b/lisp/nxml/rng-parse.el
index 7f4039d5dca..cb49f4f69e3 100644
--- a/lisp/nxml/rng-parse.el
+++ b/lisp/nxml/rng-parse.el
@@ -3,7 +3,7 @@
;; Copyright (C) 2003, 2007-2024 Free Software Foundation, Inc.
;; Author: James Clark
-;; Keywords: wp, hypermedia, languages, XML, RelaxNG
+;; Keywords: text, hypermedia, languages, XML, RelaxNG
;; This file is part of GNU Emacs.
diff --git a/lisp/nxml/rng-pttrn.el b/lisp/nxml/rng-pttrn.el
index b1b55deb837..996e9ca0929 100644
--- a/lisp/nxml/rng-pttrn.el
+++ b/lisp/nxml/rng-pttrn.el
@@ -3,7 +3,7 @@
;; Copyright (C) 2003, 2007-2024 Free Software Foundation, Inc.
;; Author: James Clark
-;; Keywords: wp, hypermedia, languages, XML, RelaxNG
+;; Keywords: text, hypermedia, languages, XML, RelaxNG
;; This file is part of GNU Emacs.
diff --git a/lisp/nxml/rng-uri.el b/lisp/nxml/rng-uri.el
index dcccafc3ee7..587ca226de8 100644
--- a/lisp/nxml/rng-uri.el
+++ b/lisp/nxml/rng-uri.el
@@ -3,7 +3,7 @@
;; Copyright (C) 2003, 2007-2024 Free Software Foundation, Inc.
;; Author: James Clark
-;; Keywords: wp, hypermedia, languages, XML
+;; Keywords: text, hypermedia, languages, XML
;; This file is part of GNU Emacs.
diff --git a/lisp/nxml/rng-util.el b/lisp/nxml/rng-util.el
index 63ad1eecfb0..f9d47c20347 100644
--- a/lisp/nxml/rng-util.el
+++ b/lisp/nxml/rng-util.el
@@ -3,7 +3,7 @@
;; Copyright (C) 2003, 2007-2024 Free Software Foundation, Inc.
;; Author: James Clark
-;; Keywords: wp, hypermedia, languages, XML, RelaxNG
+;; Keywords: text, hypermedia, languages, XML, RelaxNG
;; This file is part of GNU Emacs.
@@ -24,6 +24,8 @@
;;; Code:
+(require 'cl-lib)
+
(defun rng-make-datatypes-uri (uri)
(if (string-equal uri "")
;; The spec doesn't say to do this, but it's perfectly conformant
@@ -39,26 +41,7 @@
(defun rng-substq (new old list)
"Replace first member of LIST (if any) that is `eq' to OLD by NEW.
LIST is not modified."
- (cond ((null list) nil)
- ((eq (car list) old)
- (cons new (cdr list)))
- (t
- (let ((tail (cons (car list)
- nil))
- (rest (cdr list)))
- (setq list tail)
- (while rest
- (let ((item (car rest)))
- (setq rest (cdr rest))
- (cond ((eq item old)
- (setcdr tail
- (cons new rest))
- (setq rest nil))
- (t
- (setq tail
- (setcdr tail
- (cons item nil))))))))
- list)))
+ (cl-substitute new old list :count 1 :test #'eq))
(defun rng-escape-string (s)
(replace-regexp-in-string "[&\"<>]"
diff --git a/lisp/nxml/rng-valid.el b/lisp/nxml/rng-valid.el
index c91eb42b0de..1c9998345fb 100644
--- a/lisp/nxml/rng-valid.el
+++ b/lisp/nxml/rng-valid.el
@@ -3,7 +3,7 @@
;; Copyright (C) 2003, 2007-2024 Free Software Foundation, Inc.
;; Author: James Clark
-;; Keywords: wp, hypermedia, languages, XML, RelaxNG
+;; Keywords: text, hypermedia, languages, XML, RelaxNG
;; This file is part of GNU Emacs.
diff --git a/lisp/nxml/rng-xsd.el b/lisp/nxml/rng-xsd.el
index 8f00b1655f3..417e4c7b5bc 100644
--- a/lisp/nxml/rng-xsd.el
+++ b/lisp/nxml/rng-xsd.el
@@ -3,7 +3,7 @@
;; Copyright (C) 2003, 2007-2024 Free Software Foundation, Inc.
;; Author: James Clark
-;; Keywords: wp, hypermedia, languages, XML, RelaxNG
+;; Keywords: text, hypermedia, languages, XML, RelaxNG
;; This file is part of GNU Emacs.
diff --git a/lisp/nxml/xmltok.el b/lisp/nxml/xmltok.el
index b9fa34dc518..a4816d1b3f7 100644
--- a/lisp/nxml/xmltok.el
+++ b/lisp/nxml/xmltok.el
@@ -3,7 +3,7 @@
;; Copyright (C) 2003, 2007-2024 Free Software Foundation, Inc.
;; Author: James Clark
-;; Keywords: wp, hypermedia, languages, XML
+;; Keywords: text, hypermedia, languages, XML
;; This file is part of GNU Emacs.
diff --git a/lisp/nxml/xsd-regexp.el b/lisp/nxml/xsd-regexp.el
index eb5709fafc8..5474ac179d6 100644
--- a/lisp/nxml/xsd-regexp.el
+++ b/lisp/nxml/xsd-regexp.el
@@ -3,7 +3,7 @@
;; Copyright (C) 2003, 2007-2024 Free Software Foundation, Inc.
;; Author: James Clark
-;; Keywords: wp, hypermedia, languages, XML, regexp
+;; Keywords: text, hypermedia, languages, XML, regexp
;; This file is part of GNU Emacs.
diff --git a/lisp/obarray.el b/lisp/obarray.el
index a26992df8e2..5e646db9ab7 100644
--- a/lisp/obarray.el
+++ b/lisp/obarray.el
@@ -27,24 +27,13 @@
;;; Code:
-(defconst obarray-default-size 59
- "The value 59 is an arbitrary prime number that gives a good hash.")
+(defconst obarray-default-size 4)
+(make-obsolete-variable 'obarray-default-size
+ "obarrays now grow automatically." "30.1")
-(defun obarray-make (&optional size)
- "Return a new obarray of size SIZE or `obarray-default-size'."
- (let ((size (or size obarray-default-size)))
- (if (< 0 size)
- (make-vector size 0)
- (signal 'wrong-type-argument '(size 0)))))
-
-(defun obarray-size (ob)
- "Return the number of slots of obarray OB."
- (length ob))
-
-(defun obarrayp (object)
- "Return t if OBJECT is an obarray."
- (and (vectorp object)
- (< 0 (length object))))
+(defun obarray-size (_ob)
+ (declare (obsolete "obarrays now grow automatically." "30.1"))
+ obarray-default-size)
;; Don’t use obarray as a variable name to avoid shadowing.
(defun obarray-get (ob name)
@@ -54,7 +43,7 @@ Return nil otherwise."
(defun obarray-put (ob name)
"Return symbol named NAME from obarray OB.
-Creates and adds the symbol if doesn't exist."
+Creates and adds the symbol if it doesn't exist."
(intern name ob))
(defun obarray-remove (ob name)
diff --git a/lisp/obsolete/eieio-compat.el b/lisp/obsolete/eieio-compat.el
index 26648a4d7bb..8fdcebbd1c4 100644
--- a/lisp/obsolete/eieio-compat.el
+++ b/lisp/obsolete/eieio-compat.el
@@ -150,10 +150,9 @@ Summary:
(lambda (tag &rest _)
(and (symbolp tag) (setq tag (cl--find-class tag))
(eieio--class-p tag)
- (let ((superclasses (eieio--class-precedence-list tag))
+ (let ((superclasses (cl--class-allparents tag))
(specializers ()))
(dolist (superclass superclasses)
- (setq superclass (eieio--class-name superclass))
(push superclass specializers)
(push `(eieio--static ,superclass) specializers))
(nreverse specializers)))))
@@ -240,7 +239,7 @@ Summary:
(declare (obsolete cl-no-applicable-method "25.1"))
(apply #'cl-no-applicable-method method object args))
-(define-obsolete-function-alias 'call-next-method 'cl-call-next-method "25.1")
+(define-obsolete-function-alias 'call-next-method #'cl-call-next-method "25.1")
(defun next-method-p ()
(declare (obsolete cl-next-method-p "25.1"))
;; EIEIO's `next-method-p' just returned nil when called in an
diff --git a/lisp/obsolete/iswitchb.el b/lisp/obsolete/iswitchb.el
index 20e7960db3c..e1ea9141f0d 100644
--- a/lisp/obsolete/iswitchb.el
+++ b/lisp/obsolete/iswitchb.el
@@ -251,7 +251,7 @@
:group 'convenience
:group 'completion
:link '(emacs-commentary-link :tag "Commentary" "iswitchb.el")
- :link '(url-link "http://www.anc.ed.ac.uk/~stephen/emacs/")
+ :link '(url-link "https://www.anc.ed.ac.uk/~stephen/emacs/")
:link '(emacs-library-link :tag "Lisp File" "iswitchb.el"))
(defcustom iswitchb-case case-fold-search
@@ -370,7 +370,7 @@ See documentation of `walk-windows' for useful values."
This hook is run during minibuffer setup if `iswitchb' is active.
For instance:
\(add-hook \\='iswitchb-minibuffer-setup-hook
- \\='\(lambda () (set (make-local-variable \\='max-mini-window-height) 3)))
+ \\='\(lambda () (setq-local max-mini-window-height 3)))
will constrain the minibuffer to a maximum height of 3 lines when
iswitchb is running."
:type 'hook)
@@ -1262,7 +1262,7 @@ Modified from `icomplete-completions'."
"Set up minibuffer for `iswitchb-buffer'.
Copied from `icomplete-minibuffer-setup-hook'."
(when (iswitchb-entryfn-p)
- (set (make-local-variable 'iswitchb-use-mycompletion) t)
+ (setq-local iswitchb-use-mycompletion t)
(add-hook 'pre-command-hook #'iswitchb-pre-command nil t)
(add-hook 'post-command-hook #'iswitchb-post-command nil t)
(run-hooks 'iswitchb-minibuffer-setup-hook)))
diff --git a/lisp/obsolete/landmark.el b/lisp/obsolete/landmark.el
index 140f1e4ac12..0a67bba8028 100644
--- a/lisp/obsolete/landmark.el
+++ b/lisp/obsolete/landmark.el
@@ -549,10 +549,10 @@ along the DX, DY direction, considering that DVAL has been added on SQUARE."
;;; GAME CONTROL.
;;;
-;; Several variables are used to monitor a game, including a GAME-HISTORY (the
-;; list of all (SQUARE . PREVSCORE) played) that allows to take moves back
-;; (anti-updating the score table) and to compute the table from scratch in
-;; case of an interruption.
+;; Several variables are used to monitor a game, including a
+;; GAME-HISTORY (the list of all (SQUARE . PREVSCORE) played) that
+;; enables rescinding moves (anti-updating the score table) and to
+;; compute the table from scratch in case of an interruption.
(defvar landmark-game-in-progress nil
"Non-nil if a game is in progress.")
diff --git a/lisp/obsolete/longlines.el b/lisp/obsolete/longlines.el
index 647cbba24f5..f065bcaff26 100644
--- a/lisp/obsolete/longlines.el
+++ b/lisp/obsolete/longlines.el
@@ -7,7 +7,7 @@
;; Chong Yidong <cyd@stupidchicken.com>
;; Maintainer: emacs-devel@gnu.org
;; Obsolete-since: 24.4
-;; Keywords: convenience, wp
+;; Keywords: convenience, text
;; This file is part of GNU Emacs.
@@ -116,17 +116,14 @@ newlines are indicated with a symbol."
;; Turn on longlines mode
(progn
(use-hard-newlines 1 'never)
- (set (make-local-variable 'require-final-newline) nil)
+ (setq-local require-final-newline nil)
(add-to-list 'buffer-file-format 'longlines)
(add-hook 'change-major-mode-hook #'longlines-mode-off nil t)
(add-hook 'before-revert-hook #'longlines-before-revert-hook nil t)
(make-local-variable 'longlines-auto-wrap)
- (set (make-local-variable 'isearch-search-fun-function)
- #'longlines-search-function)
- (set (make-local-variable 'replace-search-function)
- #'longlines-search-forward)
- (set (make-local-variable 'replace-re-search-function)
- #'longlines-re-search-forward)
+ (setq-local isearch-search-fun-function #'longlines-search-function)
+ (setq-local replace-search-function #'longlines-search-forward)
+ (setq-local replace-re-search-function #'longlines-re-search-forward)
(add-function :filter-return (local 'filter-buffer-substring-function)
#'longlines-encode-string)
(when longlines-wrap-follows-window-size
@@ -136,8 +133,7 @@ newlines are indicated with a symbol."
(window-width)))
longlines-wrap-follows-window-size
2)))
- (set (make-local-variable 'fill-column)
- (- (window-width) dw)))
+ (setq-local fill-column (- (window-width) dw)))
(add-hook 'window-configuration-change-hook
#'longlines-window-change-function nil t))
(let ((buffer-undo-list t)
diff --git a/lisp/obsolete/mantemp.el b/lisp/obsolete/mantemp.el
index 5787070a1ff..32d7f81cf60 100644
--- a/lisp/obsolete/mantemp.el
+++ b/lisp/obsolete/mantemp.el
@@ -152,7 +152,7 @@ the lines."
(while (re-search-forward "^.+" nil t)
(progn
(beginning-of-line)
- (if (looking-at "struct[\\t ]+\\|class[\\t ]+")
+ (if (looking-at "struct[\t ]+\\|class[\t ]+")
(insert "template ")
(insert "template class "))))
(goto-char (point-min))
diff --git a/lisp/obsolete/pgg.el b/lisp/obsolete/pgg.el
index 6c00ad201f1..4c7b653155e 100644
--- a/lisp/obsolete/pgg.el
+++ b/lisp/obsolete/pgg.el
@@ -85,9 +85,9 @@ is true, or else the output buffer is displayed."
(set-buffer standard-output)
(insert-buffer-substring pgg-errors-buffer))))
-(defvar pgg-passphrase-cache (make-vector 7 0))
+(defvar pgg-passphrase-cache (obarray-make 7))
-(defvar pgg-pending-timers (make-vector 7 0)
+(defvar pgg-pending-timers (obarray-make 7)
"Hash table for managing scheduled pgg cache management timers.
We associate key and timer, so the timer can be canceled if a new
diff --git a/lisp/obsolete/ps-def.el b/lisp/obsolete/ps-def.el
index a384473b62b..641845d2b95 100644
--- a/lisp/obsolete/ps-def.el
+++ b/lisp/obsolete/ps-def.el
@@ -4,7 +4,7 @@
;; Author: Vinicius Jose Latorre <viniciusjl.gnu@gmail.com>
;; Kenichi Handa <handa@gnu.org> (multi-byte characters)
-;; Keywords: wp, print, PostScript
+;; Keywords: text, print, PostScript
;; URL: https://www.emacswiki.org/cgi-bin/wiki/ViniciusJoseLatorre
;; Package: ps-print
;; Obsolete-since: 29.1
diff --git a/lisp/obsolete/quickurl.el b/lisp/obsolete/quickurl.el
index 7393bebdce1..7da51a8a4a8 100644
--- a/lisp/obsolete/quickurl.el
+++ b/lisp/obsolete/quickurl.el
@@ -447,7 +447,7 @@ The key bindings for `quickurl-list-mode' are:
(defun quickurl-list-populate-buffer ()
"Populate the `quickurl-list' buffer."
- (with-current-buffer (get-buffer quickurl-list-buffer-name)
+ (with-current-buffer quickurl-list-buffer-name
(let* ((sizes (or (cl-loop for url in quickurl-urls
collect (length (quickurl-url-description url)))
(list 20)))
diff --git a/lisp/obsolete/rcompile.el b/lisp/obsolete/rcompile.el
index e0826475e32..258b2b519d9 100644
--- a/lisp/obsolete/rcompile.el
+++ b/lisp/obsolete/rcompile.el
@@ -169,12 +169,12 @@ See \\[compile]."
;; compilation-parse-errors will find referenced files by Tramp.
(with-current-buffer next-error-last-buffer
(when (fboundp 'tramp-make-tramp-file-name)
- (set (make-local-variable 'comint-file-name-prefix)
- (funcall
- #'tramp-make-tramp-file-name
- nil ;; method.
- remote-compile-user
- remote-compile-host
- ""))))))
+ (setq-local comint-file-name-prefix
+ (funcall
+ #'tramp-make-tramp-file-name
+ nil ;; method.
+ remote-compile-user
+ remote-compile-host
+ ""))))))
;;; rcompile.el ends here
diff --git a/lisp/obsolete/terminal.el b/lisp/obsolete/terminal.el
index cac533a4b2f..13667589c9e 100644
--- a/lisp/obsolete/terminal.el
+++ b/lisp/obsolete/terminal.el
@@ -1095,7 +1095,9 @@ subprocess started."
(or explicit-shell-file-name
(getenv "ESHELL")
(getenv "SHELL")
- "/bin/sh"))
+ (if (eq system-type 'android)
+ "/system/bin/sh"
+ "/bin/sh")))
(s (read-string
(format "Run program in emulator (default %s): "
default-s))))
@@ -1152,7 +1154,7 @@ subprocess started."
(defun te-parse-program-and-args (s)
- (cond ((string-match "\\`\\([-a-zA-Z0-9+=_.@/:]+[ \t]*\\)+\\'" s)
+ (cond ((string-match "\\`[-a-zA-Z0-9+=_.@/:][-a-zA-Z0-9+=_.@/: \t]*\\'" s)
(let ((l ()) (p 0))
(while p
(setq l (cons (if (string-match
diff --git a/lisp/obsolete/url-ns.el b/lisp/obsolete/url-ns.el
index 6114232e9e1..41aaa5b63be 100644
--- a/lisp/obsolete/url-ns.el
+++ b/lisp/obsolete/url-ns.el
@@ -39,13 +39,14 @@
;;;###autoload
(defun dnsResolve (host)
- (url-gateway-nslookup-host host))
+ (with-suppressed-warnings ((obsolete url-gateway-nslookup-host))
+ (url-gateway-nslookup-host host)))
;;;###autoload
(defun isResolvable (host)
(if (string-match "^[0-9.]+$" host)
t
- (not (string= host (url-gateway-nslookup-host host)))))
+ (not (string= host (dnsResolve host)))))
;;;###autoload
(defun isInNet (ip net mask)
diff --git a/lisp/org/ob-calc.el b/lisp/org/ob-calc.el
index d335aab7499..f834f05cb6d 100644
--- a/lisp/org/ob-calc.el
+++ b/lisp/org/ob-calc.el
@@ -93,7 +93,7 @@
(mapcar #'org-trim
(split-string (org-babel-expand-body:calc body params) "[\n\r]"))))
(save-excursion
- (with-current-buffer (get-buffer "*Calculator*")
+ (with-current-buffer "*Calculator*"
(prog1
(calc-eval (calc-top 1))
(calc-pop 1)))))
diff --git a/lisp/org/ob-eshell.el b/lisp/org/ob-eshell.el
index 3e2117ad019..eefb43dc1a9 100644
--- a/lisp/org/ob-eshell.el
+++ b/lisp/org/ob-eshell.el
@@ -47,11 +47,12 @@
"Execute a block of Eshell code BODY with PARAMS.
This function is called by `org-babel-execute-src-block'.
-The BODY can be any code which allowed executed in Eshell.
-Eshell allow to execute normal shell command and Elisp code.
-More details please reference Eshell Info.
+The BODY argument is code which can be executed in Eshell.
+Eshell allows executing normal shell command and Elisp code.
+For more details, see Info node `(eshell) Top'.
-The PARAMS are variables assignments."
+The PARAMS argument is passed to
+`org-babel-expand-body:generic' (which see)."
(let* ((session (org-babel-eshell-initiate-session
(cdr (assq :session params))))
(full-body (org-babel-expand-body:generic
diff --git a/lisp/org/ob-lua.el b/lisp/org/ob-lua.el
index 8bc9f34c4d6..6d60538e8ab 100644
--- a/lisp/org/ob-lua.el
+++ b/lisp/org/ob-lua.el
@@ -326,7 +326,7 @@ last statement in BODY, as elisp."
If RESULT-TYPE equals `output' then return standard output as a
string. If RESULT-TYPE equals `value' then return the value of the
last statement in BODY, as elisp."
- (let* ((send-wait (lambda () (comint-send-input nil t) (sleep-for 0 5)))
+ (let* ((send-wait (lambda () (comint-send-input nil t) (sleep-for 0.005)))
(dump-last-value
(lambda
(tmp-file pp)
diff --git a/lisp/org/ob-python.el b/lisp/org/ob-python.el
index 3302eb1e5ab..1a442a5a08f 100644
--- a/lisp/org/ob-python.el
+++ b/lisp/org/ob-python.el
@@ -235,7 +235,7 @@ then create. Return the initialized session."
;; multiple prompts during initialization.
(with-current-buffer py-buffer
(while (not org-babel-python--initialized)
- (sleep-for 0 10)))
+ (sleep-for 0.01)))
(org-babel-comint-wait-for-output py-buffer))
(setq org-babel-python-buffers
(cons (cons session py-buffer)
@@ -403,7 +403,7 @@ last statement in BODY, as elisp."
(body (org-babel-python-format-session-value
tmp-src-file tmp-results-file result-params)))
(org-babel-python--send-string session body)
- (sleep-for 0 10)
+ (sleep-for 0.01)
(org-babel-eval-read-file tmp-results-file)))))))
(org-babel-result-cond result-params
results
diff --git a/lisp/org/ob-tangle.el b/lisp/org/ob-tangle.el
index 1be97ba5582..13c928df316 100644
--- a/lisp/org/ob-tangle.el
+++ b/lisp/org/ob-tangle.el
@@ -357,7 +357,7 @@ Did you give the decimal value %1$d by mistake?" mode)))
(error "File mode %S not recognized as a valid format." mode))
((string-match-p "^o0?[0-7][0-7][0-7]$" mode)
(string-to-number (replace-regexp-in-string "^o" "" mode) 8))
- ((string-match-p "^[ugoa]*\\(?:[+-=][rwxXstugo]*\\)+\\(,[ugoa]*\\(?:[+-=][rwxXstugo]*\\)+\\)*$" mode)
+ ((string-match-p "^[ugoa]*\\(?:[+=-][rwxXstugo]*\\)+\\(,[ugoa]*\\(?:[+=-][rwxXstugo]*\\)+\\)*$" mode)
;; Match regexp taken from `file-modes-symbolic-to-number'.
(file-modes-symbolic-to-number mode org-babel-tangle-default-file-mode))
((string-match-p "^[r-][w-][xs-][r-][w-][xs-][r-][w-][x-]$" mode)
diff --git a/lisp/org/ol-bbdb.el b/lisp/org/ol-bbdb.el
index 2f31fad8d9d..dba587e345e 100644
--- a/lisp/org/ol-bbdb.el
+++ b/lisp/org/ol-bbdb.el
@@ -4,7 +4,7 @@
;; Authors: Carsten Dominik <carsten.dominik@gmail.com>
;; Thomas Baumann <thomas dot baumann at ch dot tum dot de>
-;; Keywords: outlines, hypermedia, calendar, wp
+;; Keywords: outlines, hypermedia, calendar, text
;; URL: https://orgmode.org
;;
;; This file is part of GNU Emacs.
diff --git a/lisp/org/ol-bibtex.el b/lisp/org/ol-bibtex.el
index fd2dce8c088..ea4b54cc25a 100644
--- a/lisp/org/ol-bibtex.el
+++ b/lisp/org/ol-bibtex.el
@@ -5,7 +5,7 @@
;; Authors: Bastien Guerry <bzg@gnu.org>
;; Carsten Dominik <carsten dot dominik at gmail dot com>
;; Eric Schulte <schulte dot eric at gmail dot com>
-;; Keywords: org, wp, capture
+;; Keywords: org, text, capture
;;
;; This file is part of GNU Emacs.
;;
diff --git a/lisp/org/ol-docview.el b/lisp/org/ol-docview.el
index 36bcfc4fc7d..f12d3558d42 100644
--- a/lisp/org/ol-docview.el
+++ b/lisp/org/ol-docview.el
@@ -3,7 +3,7 @@
;; Copyright (C) 2009-2024 Free Software Foundation, Inc.
;; Author: Jan Böcker <jan.boecker at jboecker dot de>
-;; Keywords: outlines, hypermedia, calendar, wp
+;; Keywords: outlines, hypermedia, calendar, text
;; URL: https://orgmode.org
;;
;; This file is part of GNU Emacs.
diff --git a/lisp/org/ol-gnus.el b/lisp/org/ol-gnus.el
index 26924ff342d..91af4d10a25 100644
--- a/lisp/org/ol-gnus.el
+++ b/lisp/org/ol-gnus.el
@@ -4,7 +4,7 @@
;; Author: Carsten Dominik <carsten.dominik@gmail.com>
;; Tassilo Horn <tassilo at member dot fsf dot org>
-;; Keywords: outlines, hypermedia, calendar, wp
+;; Keywords: outlines, hypermedia, calendar, text
;; URL: https://orgmode.org
;;
;; This file is part of GNU Emacs.
diff --git a/lisp/org/ol-info.el b/lisp/org/ol-info.el
index 760cadecca0..48581bd779b 100644
--- a/lisp/org/ol-info.el
+++ b/lisp/org/ol-info.el
@@ -3,7 +3,7 @@
;; Copyright (C) 2004-2024 Free Software Foundation, Inc.
;; Author: Carsten Dominik <carsten.dominik@gmail.com>
-;; Keywords: outlines, hypermedia, calendar, wp
+;; Keywords: outlines, hypermedia, calendar, text
;; URL: https://orgmode.org
;;
;; This file is part of GNU Emacs.
diff --git a/lisp/org/ol-man.el b/lisp/org/ol-man.el
index b6cada1b3c3..5ce04330021 100644
--- a/lisp/org/ol-man.el
+++ b/lisp/org/ol-man.el
@@ -3,7 +3,7 @@
;; Copyright (C) 2020-2024 Free Software Foundation, Inc.
;; Author: Carsten Dominik <carsten.dominik@gmail.com>
;; Maintainer: Bastien Guerry <bzg@gnu.org>
-;; Keywords: outlines, hypermedia, calendar, wp
+;; Keywords: outlines, hypermedia, calendar, text
;; URL: https://orgmode.org
;;
;; This file is part of GNU Emacs.
diff --git a/lisp/org/ol-mhe.el b/lisp/org/ol-mhe.el
index 106cfedc976..52339c0a622 100644
--- a/lisp/org/ol-mhe.el
+++ b/lisp/org/ol-mhe.el
@@ -3,7 +3,7 @@
;; Copyright (C) 2004-2024 Free Software Foundation, Inc.
;; Author: Thomas Baumann <thomas dot baumann at ch dot tum dot de>
-;; Keywords: outlines, hypermedia, calendar, wp
+;; Keywords: outlines, hypermedia, calendar, text
;; URL: https://orgmode.org
;;
;; This file is part of GNU Emacs.
diff --git a/lisp/org/ol-rmail.el b/lisp/org/ol-rmail.el
index f6031ab52ca..a1af1b94915 100644
--- a/lisp/org/ol-rmail.el
+++ b/lisp/org/ol-rmail.el
@@ -3,7 +3,7 @@
;; Copyright (C) 2004-2024 Free Software Foundation, Inc.
;; Author: Carsten Dominik <carsten.dominik@gmail.com>
-;; Keywords: outlines, hypermedia, calendar, wp
+;; Keywords: outlines, hypermedia, calendar, text
;; URL: https://orgmode.org
;;
;; This file is part of GNU Emacs.
diff --git a/lisp/org/ol-w3m.el b/lisp/org/ol-w3m.el
index 77b4844a6df..e8981173371 100644
--- a/lisp/org/ol-w3m.el
+++ b/lisp/org/ol-w3m.el
@@ -3,7 +3,7 @@
;; Copyright (C) 2008-2024 Free Software Foundation, Inc.
;; Author: Andy Stewart <lazycat dot manatee at gmail dot com>
-;; Keywords: outlines, hypermedia, calendar, wp
+;; Keywords: outlines, hypermedia, calendar, text
;; URL: https://orgmode.org
;;
;; This file is part of GNU Emacs.
diff --git a/lisp/org/ol.el b/lisp/org/ol.el
index 4c84e62f4c9..ac0c308da21 100644
--- a/lisp/org/ol.el
+++ b/lisp/org/ol.el
@@ -3,7 +3,7 @@
;; Copyright (C) 2018-2024 Free Software Foundation, Inc.
;; Author: Carsten Dominik <carsten.dominik@gmail.com>
-;; Keywords: outlines, hypermedia, calendar, wp
+;; Keywords: outlines, hypermedia, calendar, text
;; This file is part of GNU Emacs.
@@ -1803,7 +1803,7 @@ generate a description as described in `org-link-parameters'
docstring. Otherwise, if `org-link-make-description-function' is
non-nil, this function will be called with the link target, and
the result will be the default link description. When called
-non-interactively, don't allow to edit the default description."
+non-interactively, don't allow editing the default description."
(interactive "P")
(let* ((wcf (current-window-configuration))
(origbuf (current-buffer))
@@ -2042,7 +2042,7 @@ Also refresh fontification if needed."
(interactive)
(let ((old-regexp org-target-link-regexp)
;; Some languages, e.g., Chinese, do not use spaces to
- ;; separate words. Also allow to surround radio targets with
+ ;; separate words. Also allow surrounding radio targets with
;; line-breakable characters.
(before-re "\\(?:^\\|[^[:alnum:]]\\|\\c|\\)\\(")
(after-re "\\)\\(?:$\\|[^[:alnum:]]\\|\\c|\\)")
diff --git a/lisp/org/org-agenda.el b/lisp/org/org-agenda.el
index 10ca43220a4..06249ed48fa 100644
--- a/lisp/org/org-agenda.el
+++ b/lisp/org/org-agenda.el
@@ -3,7 +3,7 @@
;; Copyright (C) 2004-2024 Free Software Foundation, Inc.
;; Author: Carsten Dominik <carsten.dominik@gmail.com>
-;; Keywords: outlines, hypermedia, calendar, wp
+;; Keywords: outlines, hypermedia, calendar, text
;; URL: https://orgmode.org
;;
;; This file is part of GNU Emacs.
@@ -3883,7 +3883,7 @@ generating a new one."
;; buffer found
(get-buffer org-agenda-buffer-name)
;; C-u parameter is same as last call
- (with-current-buffer (get-buffer org-agenda-buffer-name)
+ (with-current-buffer org-agenda-buffer-name
(and
(equal current-prefix-arg
org-agenda-last-prefix-arg)
diff --git a/lisp/org/org-archive.el b/lisp/org/org-archive.el
index f2932da9d08..f5c223661c4 100644
--- a/lisp/org/org-archive.el
+++ b/lisp/org/org-archive.el
@@ -3,7 +3,7 @@
;; Copyright (C) 2004-2024 Free Software Foundation, Inc.
;; Author: Carsten Dominik <carsten.dominik@gmail.com>
-;; Keywords: outlines, hypermedia, calendar, wp
+;; Keywords: outlines, hypermedia, calendar, text
;; URL: https://orgmode.org
;;
;; This file is part of GNU Emacs.
diff --git a/lisp/org/org-capture.el b/lisp/org/org-capture.el
index 2ca68cea23e..1897c096306 100644
--- a/lisp/org/org-capture.el
+++ b/lisp/org/org-capture.el
@@ -3,7 +3,7 @@
;; Copyright (C) 2010-2024 Free Software Foundation, Inc.
;; Author: Carsten Dominik <carsten.dominik@gmail.com>
-;; Keywords: outlines, hypermedia, calendar, wp
+;; Keywords: outlines, hypermedia, calendar, text
;; URL: https://orgmode.org
;;
;; This file is part of GNU Emacs.
diff --git a/lisp/org/org-clock.el b/lisp/org/org-clock.el
index 069c851abed..e79677ad6be 100644
--- a/lisp/org/org-clock.el
+++ b/lisp/org/org-clock.el
@@ -3,7 +3,7 @@
;; Copyright (C) 2004-2024 Free Software Foundation, Inc.
;; Author: Carsten Dominik <carsten.dominik@gmail.com>
-;; Keywords: outlines, hypermedia, calendar, wp
+;; Keywords: outlines, hypermedia, calendar, text
;; URL: https://orgmode.org
;;
;; This file is part of GNU Emacs.
@@ -51,6 +51,8 @@
(declare-function org-dynamic-block-define "org" (type func))
(declare-function w32-notification-notify "w32fns.c" (&rest params))
(declare-function w32-notification-close "w32fns.c" (&rest params))
+(declare-function haiku-notifications-notify "haikuselect.c")
+(declare-function android-notifications-notify "androidselect.c")
(defvar org-frame-title-format-backup nil)
(defvar org-state)
@@ -855,6 +857,18 @@ use libnotify if available, or fall back on a message."
((stringp org-show-notification-handler)
(start-process "emacs-timer-notification" nil
org-show-notification-handler notification))
+ ((fboundp 'haiku-notifications-notify)
+ ;; N.B. timeouts are not available under Haiku.
+ (haiku-notifications-notify :title "Org mode message"
+ :body notification
+ :urgency 'low))
+ ((fboundp 'android-notifications-notify)
+ ;; N.B. timeouts are not available under Haiku or Android.
+ (android-notifications-notify :title "Org mode message"
+ :body notification
+ ;; Low urgency notifications
+ ;; are by default hidden.
+ :urgency 'normal))
((fboundp 'w32-notification-notify)
(let ((id (w32-notification-notify
:title "Org mode message"
diff --git a/lisp/org/org-colview.el b/lisp/org/org-colview.el
index d0be87fcc5d..ccf1ca731a4 100644
--- a/lisp/org/org-colview.el
+++ b/lisp/org/org-colview.el
@@ -3,7 +3,7 @@
;; Copyright (C) 2004-2024 Free Software Foundation, Inc.
;; Author: Carsten Dominik <carsten.dominik@gmail.com>
-;; Keywords: outlines, hypermedia, calendar, wp
+;; Keywords: outlines, hypermedia, calendar, text
;; URL: https://orgmode.org
;;
;; This file is part of GNU Emacs.
diff --git a/lisp/org/org-compat.el b/lisp/org/org-compat.el
index 33a510cd7f2..e9f68518e6f 100644
--- a/lisp/org/org-compat.el
+++ b/lisp/org/org-compat.el
@@ -3,7 +3,7 @@
;; Copyright (C) 2004-2024 Free Software Foundation, Inc.
;; Author: Carsten Dominik <carsten.dominik@gmail.com>
-;; Keywords: outlines, hypermedia, calendar, wp
+;; Keywords: outlines, hypermedia, calendar, text
;; URL: https://orgmode.org
;;
;; This file is part of GNU Emacs.
diff --git a/lisp/org/org-ctags.el b/lisp/org/org-ctags.el
index d583048507b..2417353ee5d 100644
--- a/lisp/org/org-ctags.el
+++ b/lisp/org/org-ctags.el
@@ -3,7 +3,7 @@
;; Copyright (C) 2007-2024 Free Software Foundation, Inc.
;; Author: Paul Sexton <eeeickythump@gmail.com>
-;; Keywords: org, wp
+;; Keywords: org, text
;; This file is part of GNU Emacs.
;;
@@ -156,7 +156,9 @@ Format is: /REGEXP/TAGNAME/FLAGS,TAGTYPE/
See the ctags documentation for more information.")
(defcustom org-ctags-path-to-ctags
- (if (executable-find "ctags-exuberant") "ctags-exuberant" "ctags")
+ (if (executable-find "ctags-exuberant")
+ "ctags-exuberant"
+ ctags-program-name)
"Name of the ctags executable file."
:version "24.1"
:type 'file)
diff --git a/lisp/org/org-datetree.el b/lisp/org/org-datetree.el
index 34837a93eaa..90581f1360c 100644
--- a/lisp/org/org-datetree.el
+++ b/lisp/org/org-datetree.el
@@ -3,7 +3,7 @@
;; Copyright (C) 2009-2024 Free Software Foundation, Inc.
;; Author: Carsten Dominik <carsten.dominik@gmail.com>
-;; Keywords: outlines, hypermedia, calendar, wp
+;; Keywords: outlines, hypermedia, calendar, text
;; URL: https://orgmode.org
;;
;; This file is part of GNU Emacs.
diff --git a/lisp/org/org-duration.el b/lisp/org/org-duration.el
index 844a3b66344..1ab84776117 100644
--- a/lisp/org/org-duration.el
+++ b/lisp/org/org-duration.el
@@ -3,7 +3,7 @@
;; Copyright (C) 2017-2024 Free Software Foundation, Inc.
;; Author: Nicolas Goaziou <mail@nicolasgoaziou.fr>
-;; Keywords: outlines, hypermedia, calendar, wp
+;; Keywords: outlines, hypermedia, calendar, text
;; This file is part of GNU Emacs.
diff --git a/lisp/org/org-element.el b/lisp/org/org-element.el
index 796191dd386..ef96dc024d1 100644
--- a/lisp/org/org-element.el
+++ b/lisp/org/org-element.el
@@ -3,7 +3,7 @@
;; Copyright (C) 2012-2024 Free Software Foundation, Inc.
;; Author: Nicolas Goaziou <n.goaziou at gmail dot com>
-;; Keywords: outlines, hypermedia, calendar, wp
+;; Keywords: outlines, hypermedia, calendar, text
;; This file is part of GNU Emacs.
@@ -2968,7 +2968,7 @@ CONTENTS is verse block contents."
;; object types they can contain will be specified in
;; `org-element-object-restrictions'.
;;
-;; Creating a new type of object requires to alter
+;; Creating a new type of object requires altering
;; `org-element--object-regexp' and `org-element--object-lex', add the
;; new type in `org-element-all-objects', and possibly add
;; restrictions in `org-element-object-restrictions'.
@@ -3523,7 +3523,7 @@ Assume point is at the beginning of the link."
;;
;; Also treat any newline character and associated
;; indentation as a single space character. This is not
- ;; compatible with RFC 3986, which requires to ignore
+ ;; compatible with RFC 3986, which requires ignoring
;; them altogether. However, doing so would require
;; users to encode spaces on the fly when writing links
;; (e.g., insert [[shell:ls%20*.org]] instead of
diff --git a/lisp/org/org-entities.el b/lisp/org/org-entities.el
index 709760bbd03..5820c7428cd 100644
--- a/lisp/org/org-entities.el
+++ b/lisp/org/org-entities.el
@@ -4,7 +4,7 @@
;; Author: Carsten Dominik <carsten.dominik@gmail.com>,
;; Ulf Stegemann <ulf at zeitform dot de>
-;; Keywords: outlines, calendar, wp
+;; Keywords: outlines, calendar, text
;; URL: https://orgmode.org
;;
;; This file is part of GNU Emacs.
diff --git a/lisp/org/org-faces.el b/lisp/org/org-faces.el
index 1bcf0373401..cb5c423ad0f 100644
--- a/lisp/org/org-faces.el
+++ b/lisp/org/org-faces.el
@@ -3,7 +3,7 @@
;; Copyright (C) 2004-2024 Free Software Foundation, Inc.
;; Author: Carsten Dominik <carsten.dominik@gmail.com>
-;; Keywords: outlines, hypermedia, calendar, wp
+;; Keywords: outlines, hypermedia, calendar, text
;; URL: https://orgmode.org
;;
;; This file is part of GNU Emacs.
diff --git a/lisp/org/org-feed.el b/lisp/org/org-feed.el
index 96500010f01..e4035dd4e96 100644
--- a/lisp/org/org-feed.el
+++ b/lisp/org/org-feed.el
@@ -3,7 +3,7 @@
;; Copyright (C) 2009-2024 Free Software Foundation, Inc.
;;
;; Author: Carsten Dominik <carsten.dominik@gmail.com>
-;; Keywords: outlines, hypermedia, calendar, wp
+;; Keywords: outlines, hypermedia, calendar, text
;; URL: https://orgmode.org
;;
;; This file is part of GNU Emacs.
diff --git a/lisp/org/org-footnote.el b/lisp/org/org-footnote.el
index c25f27346cb..608d694294c 100644
--- a/lisp/org/org-footnote.el
+++ b/lisp/org/org-footnote.el
@@ -3,7 +3,7 @@
;; Copyright (C) 2009-2024 Free Software Foundation, Inc.
;;
;; Author: Carsten Dominik <carsten.dominik@gmail.com>
-;; Keywords: outlines, hypermedia, calendar, wp
+;; Keywords: outlines, hypermedia, calendar, text
;; URL: https://orgmode.org
;;
;; This file is part of GNU Emacs.
diff --git a/lisp/org/org-goto.el b/lisp/org/org-goto.el
index a6ac1b7e7bd..e9df4057e4b 100644
--- a/lisp/org/org-goto.el
+++ b/lisp/org/org-goto.el
@@ -3,7 +3,7 @@
;; Copyright (C) 2012-2024 Free Software Foundation, Inc.
;; Author: Carsten Dominik <carsten.dominik@gmail.com>
-;; Keywords: outlines, hypermedia, calendar, wp
+;; Keywords: outlines, hypermedia, calendar, text
;; This file is part of GNU Emacs.
diff --git a/lisp/org/org-habit.el b/lisp/org/org-habit.el
index ba92e2c36e8..ca2910e1538 100644
--- a/lisp/org/org-habit.el
+++ b/lisp/org/org-habit.el
@@ -3,7 +3,7 @@
;; Copyright (C) 2009-2024 Free Software Foundation, Inc.
;; Author: John Wiegley <johnw at gnu dot org>
-;; Keywords: outlines, hypermedia, calendar, wp
+;; Keywords: outlines, hypermedia, calendar, text
;; URL: https://orgmode.org
;;
;; This file is part of GNU Emacs.
diff --git a/lisp/org/org-id.el b/lisp/org/org-id.el
index 9561f2de184..9586b728e70 100644
--- a/lisp/org/org-id.el
+++ b/lisp/org/org-id.el
@@ -3,7 +3,7 @@
;; Copyright (C) 2008-2024 Free Software Foundation, Inc.
;;
;; Author: Carsten Dominik <carsten.dominik@gmail.com>
-;; Keywords: outlines, hypermedia, calendar, wp
+;; Keywords: outlines, hypermedia, calendar, text
;; URL: https://orgmode.org
;;
;; This file is part of GNU Emacs.
diff --git a/lisp/org/org-indent.el b/lisp/org/org-indent.el
index d7f8d219b11..a612e1c9dc9 100644
--- a/lisp/org/org-indent.el
+++ b/lisp/org/org-indent.el
@@ -3,7 +3,7 @@
;; Copyright (C) 2009-2024 Free Software Foundation, Inc.
;;
;; Author: Carsten Dominik <carsten.dominik@gmail.com>
-;; Keywords: outlines, hypermedia, calendar, wp
+;; Keywords: outlines, hypermedia, calendar, text
;; URL: https://orgmode.org
;;
;; This file is part of GNU Emacs.
diff --git a/lisp/org/org-inlinetask.el b/lisp/org/org-inlinetask.el
index 81045e5c220..7cbdaae4e8e 100644
--- a/lisp/org/org-inlinetask.el
+++ b/lisp/org/org-inlinetask.el
@@ -3,7 +3,7 @@
;; Copyright (C) 2009-2024 Free Software Foundation, Inc.
;;
;; Author: Carsten Dominik <carsten.dominik@gmail.com>
-;; Keywords: outlines, hypermedia, calendar, wp
+;; Keywords: outlines, hypermedia, calendar, text
;; URL: https://orgmode.org
;; This file is part of GNU Emacs.
diff --git a/lisp/org/org-lint.el b/lisp/org/org-lint.el
index dc12ec272fa..5a202808e76 100644
--- a/lisp/org/org-lint.el
+++ b/lisp/org/org-lint.el
@@ -3,7 +3,7 @@
;; Copyright (C) 2015-2024 Free Software Foundation, Inc.
;; Author: Nicolas Goaziou <mail@nicolasgoaziou.fr>
-;; Keywords: outlines, hypermedia, calendar, wp
+;; Keywords: outlines, hypermedia, calendar, text
;; This file is part of GNU Emacs.
diff --git a/lisp/org/org-list.el b/lisp/org/org-list.el
index 502e61bc352..dbef7a82b1f 100644
--- a/lisp/org/org-list.el
+++ b/lisp/org/org-list.el
@@ -4,7 +4,7 @@
;;
;; Author: Carsten Dominik <carsten.dominik@gmail.com>
;; Bastien Guerry <bzg@gnu.org>
-;; Keywords: outlines, hypermedia, calendar, wp
+;; Keywords: outlines, hypermedia, calendar, text
;; URL: https://orgmode.org
;;
;; This file is part of GNU Emacs.
diff --git a/lisp/org/org-macro.el b/lisp/org/org-macro.el
index 0be51eec512..fe3bbc658ff 100644
--- a/lisp/org/org-macro.el
+++ b/lisp/org/org-macro.el
@@ -3,7 +3,7 @@
;; Copyright (C) 2013-2024 Free Software Foundation, Inc.
;; Author: Nicolas Goaziou <n.goaziou@gmail.com>
-;; Keywords: outlines, hypermedia, calendar, wp
+;; Keywords: outlines, hypermedia, calendar, text
;; This file is part of GNU Emacs.
diff --git a/lisp/org/org-macs.el b/lisp/org/org-macs.el
index b891284a8bb..aafbdf0e0aa 100644
--- a/lisp/org/org-macs.el
+++ b/lisp/org/org-macs.el
@@ -3,7 +3,7 @@
;; Copyright (C) 2004-2024 Free Software Foundation, Inc.
;; Author: Carsten Dominik <carsten.dominik@gmail.com>
-;; Keywords: outlines, hypermedia, calendar, wp
+;; Keywords: outlines, hypermedia, calendar, text
;; URL: https://orgmode.org
;;
;; This file is part of GNU Emacs.
@@ -982,7 +982,7 @@ Otherwise, return nil."
"Splits STRING into substrings at SEPARATORS.
SEPARATORS is a regular expression. When nil, it defaults to
-\"[ \f\t\n\r\v]+\".
+\"[ \\f\\t\\n\\r\\v]+\".
Unlike `split-string', matching SEPARATORS at the beginning and
end of string are ignored."
diff --git a/lisp/org/org-mobile.el b/lisp/org/org-mobile.el
index 0a0b63aa4c4..c34011fc3dc 100644
--- a/lisp/org/org-mobile.el
+++ b/lisp/org/org-mobile.el
@@ -2,7 +2,7 @@
;; Copyright (C) 2009-2024 Free Software Foundation, Inc.
;;
;; Author: Carsten Dominik <carsten.dominik@gmail.com>
-;; Keywords: outlines, hypermedia, calendar, wp
+;; Keywords: outlines, hypermedia, calendar, text
;; URL: https://orgmode.org
;;
;; This file is part of GNU Emacs.
diff --git a/lisp/org/org-mouse.el b/lisp/org/org-mouse.el
index 107979aab2b..35d1b6f1ce1 100644
--- a/lisp/org/org-mouse.el
+++ b/lisp/org/org-mouse.el
@@ -859,6 +859,10 @@ This means, between the beginning of line and the point."
(org-mouse-in-region-p (posn-point (event-start event))))
(mouse-drag-region event)))
+;; This function conflicts with touch screen gestures as it relays
+;; events to `mouse-drag-region'.
+(put 'org-mouse-down-mouse 'ignored-mouse-command t)
+
(add-hook 'org-mode-hook
(lambda ()
(setq org-mouse-context-menu-function #'org-mouse-context-menu)
diff --git a/lisp/org/org-num.el b/lisp/org/org-num.el
index 9cfc3985377..00a25b11e53 100644
--- a/lisp/org/org-num.el
+++ b/lisp/org/org-num.el
@@ -3,7 +3,7 @@
;; Copyright (C) 2018-2024 Free Software Foundation, Inc.
;; Author: Nicolas Goaziou <mail@nicolasgoaziou.fr>
-;; Keywords: outlines, hypermedia, calendar, wp
+;; Keywords: outlines, hypermedia, calendar, text
;; This file is part of GNU Emacs.
diff --git a/lisp/org/org-pcomplete.el b/lisp/org/org-pcomplete.el
index bb356bccb84..c793563570b 100644
--- a/lisp/org/org-pcomplete.el
+++ b/lisp/org/org-pcomplete.el
@@ -4,7 +4,7 @@
;;
;; Author: Carsten Dominik <carsten.dominik@gmail.com>
;; John Wiegley <johnw at gnu dot org>
-;; Keywords: outlines, hypermedia, calendar, wp
+;; Keywords: outlines, hypermedia, calendar, text
;; URL: https://orgmode.org
;;
;; This file is part of GNU Emacs.
diff --git a/lisp/org/org-protocol.el b/lisp/org/org-protocol.el
index 15dc225cb9b..61a9229adf1 100644
--- a/lisp/org/org-protocol.el
+++ b/lisp/org/org-protocol.el
@@ -7,7 +7,7 @@
;; Sebastian Rose <sebastian_rose AT gmx DOT de>
;; Ross Patterson <me AT rpatterson DOT net>
;; Maintainer: Sebastian Rose <sebastian_rose AT gmx DOT de>
-;; Keywords: org, emacsclient, wp
+;; Keywords: org, emacsclient, text
;; This file is part of GNU Emacs.
;;
diff --git a/lisp/org/org-refile.el b/lisp/org/org-refile.el
index d10efec3ead..4f204c739fa 100644
--- a/lisp/org/org-refile.el
+++ b/lisp/org/org-refile.el
@@ -3,7 +3,7 @@
;; Copyright (C) 2010-2024 Free Software Foundation, Inc.
;; Author: Carsten Dominik <carsten.dominik@gmail.com>
-;; Keywords: outlines, hypermedia, calendar, wp
+;; Keywords: outlines, hypermedia, calendar, text
;;
;; This file is part of GNU Emacs.
diff --git a/lisp/org/org-src.el b/lisp/org/org-src.el
index ba697cc9c42..8cc11965812 100644
--- a/lisp/org/org-src.el
+++ b/lisp/org/org-src.el
@@ -5,7 +5,7 @@
;; Author: Carsten Dominik <carsten.dominik@gmail.com>
;; Bastien Guerry <bzg@gnu.org>
;; Dan Davison <davison at stats dot ox dot ac dot uk>
-;; Keywords: outlines, hypermedia, calendar, wp
+;; Keywords: outlines, hypermedia, calendar, text
;; URL: https://orgmode.org
;;
;; This file is part of GNU Emacs.
@@ -658,7 +658,9 @@ as `org-src-fontify-natively' is non-nil."
(when new-prop
(if (not (eq prop 'invisible))
(put-text-property
- (+ start (1- pos)) (1- (+ start next)) prop new-prop
+ (+ start (- pos (point-min)))
+ (+ start (- next (point-min)))
+ prop new-prop
org-buffer)
;; Special case. `invisible' text property may
;; clash with Org folding. Do not assign
@@ -690,7 +692,8 @@ as `org-src-fontify-natively' is non-nil."
(when invisibility-spec
(add-to-invisibility-spec invisibility-spec))
(put-text-property
- (+ start (1- pos)) (1- (+ start next))
+ (+ start (- pos (point-min)))
+ (+ start (- next (point-min)))
'org-src-invisible new-prop
org-buffer)))))))
(setq pos next)))
diff --git a/lisp/org/org-table.el b/lisp/org/org-table.el
index 6408f48ccbd..bf0f503da2e 100644
--- a/lisp/org/org-table.el
+++ b/lisp/org/org-table.el
@@ -3,7 +3,7 @@
;; Copyright (C) 2004-2024 Free Software Foundation, Inc.
;; Author: Carsten Dominik <carsten.dominik@gmail.com>
-;; Keywords: outlines, hypermedia, calendar, wp
+;; Keywords: outlines, hypermedia, calendar, text
;; URL: https://orgmode.org
;;
;; This file is part of GNU Emacs.
@@ -417,7 +417,7 @@ It is probably good to never set this variable to nil, for the sake of
portability of tables."
:group 'org-table-calculation
:type '(choice
- (const :tag "Allow to cross" t)
+ (const :tag "Allow crossing hline" t)
(const :tag "Stick to hline" nil)
(const :tag "Error on attempt to cross" error)))
@@ -2862,7 +2862,7 @@ list, `literal' is for the format specifier L."
(if lispp
(if (eq lispp 'literal)
elements
- (if (and (eq elements "") (not keep-empty))
+ (if (and (equal elements "") (not keep-empty))
""
(prin1-to-string
(if numbers (string-to-number elements) elements))))
@@ -3900,7 +3900,7 @@ When non-nil, return the overlay narrowing the field."
;; Aligning table from the first row will not shrink again the
;; second row, which was not visible initially.
;;
- ;; However, fixing it requires to check every row, which may be
+ ;; However, fixing it requires checking every row, which may be
;; slow on large tables. Moreover, the hindrance of this
;; pathological case is very limited.
(beginning-of-line)
@@ -6134,9 +6134,13 @@ supported."
(with-temp-buffer
(insert (orgtbl-to-orgtbl table params))
(org-table-align)
- (replace-regexp-in-string
- "-|" "-+"
- (replace-regexp-in-string "|-" "+-" (buffer-substring 1 (buffer-size))))))
+ (goto-char (point-min))
+ (while (search-forward "-|" nil t)
+ (replace-match "-+"))
+ (goto-char (point-min))
+ (while (search-forward "|-" nil t)
+ (replace-match "+-"))
+ (buffer-string)))
(defun orgtbl-to-unicode (table params)
"Convert the `orgtbl-mode' TABLE into a table with unicode characters.
diff --git a/lisp/org/org-tempo.el b/lisp/org/org-tempo.el
index 44b04a9f4be..638f0ea3f4a 100644
--- a/lisp/org/org-tempo.el
+++ b/lisp/org/org-tempo.el
@@ -3,7 +3,7 @@
;; Copyright (C) 2017-2024 Free Software Foundation, Inc.
;;
;; Author: Rasmus Pank Roulund <emacs at pank dot eu>
-;; Keywords: outlines, hypermedia, calendar, wp
+;; Keywords: outlines, hypermedia, calendar, text
;; URL: https://orgmode.org
;;
;; This file is part of GNU Emacs.
diff --git a/lisp/org/org-timer.el b/lisp/org/org-timer.el
index e9ddfecadb4..561b2bc0f83 100644
--- a/lisp/org/org-timer.el
+++ b/lisp/org/org-timer.el
@@ -3,7 +3,7 @@
;; Copyright (C) 2008-2024 Free Software Foundation, Inc.
;; Author: Carsten Dominik <carsten.dominik@gmail.com>
-;; Keywords: outlines, hypermedia, calendar, wp
+;; Keywords: outlines, hypermedia, calendar, text
;; URL: https://orgmode.org
;;
;; This file is part of GNU Emacs.
diff --git a/lisp/org/org.el b/lisp/org/org.el
index 154388f79c6..678936f3417 100644
--- a/lisp/org/org.el
+++ b/lisp/org/org.el
@@ -5,7 +5,7 @@
;;
;; Author: Carsten Dominik <carsten.dominik@gmail.com>
;; Maintainer: Bastien Guerry <bzg@gnu.org>
-;; Keywords: outlines, hypermedia, calendar, wp
+;; Keywords: outlines, hypermedia, calendar, text
;; URL: https://orgmode.org
;; Package-Requires: ((emacs "26.1"))
@@ -1021,7 +1021,7 @@ time."
This is useful since some lines containing links can be very long and
uninteresting. Also tables look terrible when wrapped.
-The variable `org-startup-truncated' allows to configure
+The variable `org-startup-truncated' enables you to configure
truncation for Org mode different to the other modes that use the
variable `truncate-lines' and as a shortcut instead of putting
the variable `truncate-lines' into the `org-mode-hook'. If one
@@ -1339,14 +1339,15 @@ Possible values for the file identifier are:
to open [[file:document.pdf::5]] with evince at page 5.
Likely, you will need more entries: without page
- number; with search pattern; with cross-reference
- anchor; some combination of options. Consider simple
- pattern here and a Lisp function to determine command
- line arguments instead. Passing argument list to
- `call-process' or `make-process' directly allows to
- avoid treating some character in peculiar file names
- as shell specialls causing executing part of file
- name as a subcommand.
+ number; with search pattern; with
+ cross-reference anchor; some combination of
+ options. Consider simple pattern here and a
+ Lisp function to determine command line
+ arguments instead. Passing an argument list to
+ `call-process' or `make-process' directly avoids
+ treating some character in peculiar file names
+ as shell specials that prompt parts of said file
+ names to be executed as subcommands.
`directory' Matches a directory
`remote' Matches a remote file, accessible through tramp.
@@ -3778,7 +3779,6 @@ This is needed for font-lock setup.")
(defvar calc-embedded-close-formula)
(defvar calc-embedded-open-formula)
(defvar calc-embedded-open-mode)
-(defvar font-lock-unfontify-region-function)
(defvar org-agenda-tags-todo-honor-ignore-options)
(defvar remember-data-file)
(defvar texmathp-why)
@@ -5396,7 +5396,7 @@ by a #."
(zero-or-more (any " \t"))
(group (group (zero-or-more (not (any " \t\n"))))
(zero-or-more (any " \t"))
- (group (zero-or-more any)))))
+ (group (zero-or-more nonl)))))
limit t)
(let ((beg (match-beginning 0))
(end-of-beginline (match-end 0))
@@ -5422,7 +5422,7 @@ by a #."
"#+end"
,(match-string 4)
word-end
- (zero-or-more any)))))
+ (zero-or-more nonl)))))
;; We look further than LIMIT on purpose.
nil t)
;; We do have a matching #+end line.
@@ -5495,7 +5495,7 @@ by a #."
(beginning-of-line)
(looking-at (rx (group (zero-or-more (any " \t"))
"#+caption"
- (optional "[" (zero-or-more any) "]")
+ (optional "[" (zero-or-more nonl) "]")
":")
(zero-or-more (any " \t")))))
(add-text-properties (line-beginning-position) (match-end 1)
@@ -11368,7 +11368,7 @@ See also `org-scan-tags'."
(let ((match0 match)
(re (concat
"^&?\\([-+:]\\)?\\({[^}]+}\\|LEVEL\\([<=>]\\{1,2\\}\\)"
- "\\([0-9]+\\)\\|\\(\\(?:[[:alnum:]_]+\\(?:\\\\-\\)*\\)+\\)"
+ "\\([0-9]+\\)\\|\\([[:alnum:]_]\\(?:[[:alnum:]_]\\|\\\\-\\)*\\)"
"\\([<>=]\\{1,2\\}\\)"
"\\({[^}]+}\\|\"[^\"]*\"\\|-?[.0-9]+\\(?:[eE][-+]?[0-9]+\\)?\\)"
"\\|" org-tag-re "\\)"))
@@ -13250,7 +13250,7 @@ Optional argument DEFAULT provides a default value for PROPERTY."
nil nil nil nil default-prop)))
(defun org-set-property-and-value (use-last)
- "Allow to set [PROPERTY]: [value] direction from prompt.
+ "Allow setting [PROPERTY]: [value] direction from prompt.
When use-default, don't even ask, just use the last
\"[PROPERTY]: [value]\" string from the history."
(interactive "P")
@@ -14057,6 +14057,7 @@ user."
(unless deltadef
(let ((now (decode-time)))
(setq day (nth 3 now) month (nth 4 now) year (nth 5 now))))
+ ;; FIXME: Duplicated value in ‘cond’: ""
(cond ((member deltaw '("h" ""))
(when (boundp 'org-time-was-given)
(setq org-time-was-given t))
@@ -16460,7 +16461,7 @@ buffer boundaries with possible narrowing."
(defun org-display-inline-remove-overlay (ov after _beg _end &optional _len)
"Remove inline-display overlay if a corresponding region is modified."
(when (and ov after)
- (delete ov org-inline-image-overlays)
+ (setq org-inline-image-overlays (delete ov org-inline-image-overlays))
;; Clear image from cache to avoid image not updating upon
;; changing on disk. See Emacs bug#59902.
(when (overlay-get ov 'org-image-overlay)
@@ -17678,8 +17679,8 @@ region."
(defun org-open-line (n)
"Insert a new row in tables, call `open-line' elsewhere.
If `org-special-ctrl-o' is nil, just call `open-line' everywhere.
-As a special case, when a document starts with a table, allow to
-call `open-line' on the very first character."
+As a special case, when a document starts with a table, allow
+calling `open-line' on the very first character."
(interactive "*p")
(if (and org-special-ctrl-o (/= (point) 1) (org-at-table-p))
(org-table-insert-row)
@@ -18895,9 +18896,7 @@ ELEMENT."
(goto-char start)
(current-indentation)))
;; In any other case, indent like the current line.
- (t (current-indentation)))))
- ;; Finally, no indentation is needed, fall back to 0.
- (t (current-indentation))))))
+ (t (current-indentation)))))))))
(defun org--align-node-property ()
"Align node property at point.
diff --git a/lisp/org/ox-ascii.el b/lisp/org/ox-ascii.el
index 7f4d6cb7b0d..74fbe20e85d 100644
--- a/lisp/org/ox-ascii.el
+++ b/lisp/org/ox-ascii.el
@@ -4,7 +4,7 @@
;; Author: Nicolas Goaziou <n.goaziou at gmail dot com>
;; Maintainer: Nicolas Goaziou <mail@nicolasgoaziou.fr>
-;; Keywords: outlines, hypermedia, calendar, wp
+;; Keywords: outlines, hypermedia, calendar, text
;; This file is part of GNU Emacs.
diff --git a/lisp/org/ox-beamer.el b/lisp/org/ox-beamer.el
index 2843276a92c..d3a90179d73 100644
--- a/lisp/org/ox-beamer.el
+++ b/lisp/org/ox-beamer.el
@@ -5,7 +5,7 @@
;; Author: Carsten Dominik <carsten.dominik AT gmail DOT com>
;; Nicolas Goaziou <n.goaziou AT gmail DOT com>
;; Maintainer: Nicolas Goaziou <mail@nicolasgoaziou.fr>
-;; Keywords: org, wp, tex
+;; Keywords: org, text, tex
;; This file is part of GNU Emacs.
@@ -924,11 +924,10 @@ holding export options."
"Support for editing Beamer oriented Org mode files."
:lighter " Bm")
-(when (fboundp 'font-lock-add-keywords)
- (font-lock-add-keywords
- 'org-mode
- '((":\\(B_[a-z]+\\|BMCOL\\):" 1 'org-beamer-tag prepend))
- 'prepend))
+(font-lock-add-keywords
+ 'org-mode
+ '((":\\(B_[a-z]+\\|BMCOL\\):" 1 'org-beamer-tag prepend))
+ 'prepend)
(defface org-beamer-tag '((t (:box (:line-width 1 :color "grey40"))))
"The special face for beamer tags."
@@ -1009,7 +1008,10 @@ will be displayed when `org-export-show-temporary-export-buffer'
is non-nil."
(interactive)
(org-export-to-buffer 'beamer "*Org BEAMER Export*"
- async subtreep visible-only body-only ext-plist (lambda () (LaTeX-mode))))
+ async subtreep visible-only body-only ext-plist
+ (if (fboundp 'major-mode-remap)
+ (major-mode-remap 'latex-mode)
+ #'LaTeX-mode)))
;;;###autoload
(defun org-beamer-export-to-latex
diff --git a/lisp/org/ox-html.el b/lisp/org/ox-html.el
index 5a345a942f2..cde4f6117ec 100644
--- a/lisp/org/ox-html.el
+++ b/lisp/org/ox-html.el
@@ -5,7 +5,7 @@
;; Author: Carsten Dominik <carsten.dominik@gmail.com>
;; Jambunathan K <kjambunathan at gmail dot com>
;; Maintainer: TEC <orgmode@tec.tecosaur.net>
-;; Keywords: outlines, hypermedia, calendar, wp
+;; Keywords: outlines, hypermedia, calendar, text
;; This file is part of GNU Emacs.
@@ -3094,6 +3094,7 @@ CONTENTS is nil. INFO is a plist holding contextual information."
(let ((latex-frag (org-element-property :value latex-fragment))
(processing-type (plist-get info :with-latex)))
(cond
+ ;; FIXME: Duplicated value in ‘cond’: t
((memq processing-type '(t mathjax))
(org-html-format-latex latex-frag 'mathjax info))
((memq processing-type '(t html))
diff --git a/lisp/org/ox-icalendar.el b/lisp/org/ox-icalendar.el
index 116f8820fdd..1a6d29938fd 100644
--- a/lisp/org/ox-icalendar.el
+++ b/lisp/org/ox-icalendar.el
@@ -5,7 +5,7 @@
;; Author: Carsten Dominik <carsten.dominik@gmail.com>
;; Nicolas Goaziou <mail@nicolasgoaziou.fr>
;; Maintainer: Nicolas Goaziou <mail@nicolasgoaziou.fr>
-;; Keywords: outlines, hypermedia, calendar, wp
+;; Keywords: outlines, hypermedia, calendar, text
;; URL: https://orgmode.org
;; This file is part of GNU Emacs.
diff --git a/lisp/org/ox-koma-letter.el b/lisp/org/ox-koma-letter.el
index 59168c0777d..38460d1749e 100644
--- a/lisp/org/ox-koma-letter.el
+++ b/lisp/org/ox-koma-letter.el
@@ -7,7 +7,7 @@
;; Viktor Rosenfeld <listuser36 AT gmail DOT com>
;; Rasmus Pank Roulund <emacs AT pank DOT eu>
;; Maintainer: Marco Wahl <marcowahlsoft@gmail.com>
-;; Keywords: org, wp, tex
+;; Keywords: org, text, tex
;; This file is part of GNU Emacs.
@@ -911,7 +911,9 @@ non-nil."
(let (org-koma-letter-special-contents)
(org-export-to-buffer 'koma-letter "*Org KOMA-LETTER Export*"
async subtreep visible-only body-only ext-plist
- (lambda () (LaTeX-mode)))))
+ (if (fboundp 'major-mode-remap)
+ (major-mode-remap 'latex-mode)
+ #'LaTeX-mode))))
;;;###autoload
(defun org-koma-letter-export-to-latex
diff --git a/lisp/org/ox-latex.el b/lisp/org/ox-latex.el
index c83728a8f09..98b388081ea 100644
--- a/lisp/org/ox-latex.el
+++ b/lisp/org/ox-latex.el
@@ -4,7 +4,7 @@
;; Author: Nicolas Goaziou <n.goaziou at gmail dot com>
;; Maintainer: Daniel Fleischer <danflscr@gmail.com>
-;; Keywords: outlines, hypermedia, calendar, wp
+;; Keywords: outlines, hypermedia, calendar, text
;; This file is part of GNU Emacs.
@@ -1632,7 +1632,7 @@ explicitly been loaded. Then it is added to the rest of
package's options.
The optional argument to Babel or the mandatory argument to
-`\babelprovide' command may be \"AUTO\" which is then replaced
+`\\babelprovide' command may be \"AUTO\" which is then replaced
with the language of the document or
`org-export-default-language' unless language in question is
already loaded.
@@ -3667,7 +3667,7 @@ CONTENTS is the contents of the object."
;; takes care of tables with a "verbatim" mode. Otherwise, it
;; delegates the job to either `org-latex--table.el-table',
;; `org-latex--org-table', `org-latex--math-table' or
-;; `org-latex--org-align-string-tabbing' functions,
+;; `org-table--org-tabbing' functions,
;; depending of the type of the table and the mode requested.
;;
;; `org-latex--align-string' is a subroutine used to build alignment
@@ -4160,7 +4160,10 @@ will be displayed when `org-export-show-temporary-export-buffer'
is non-nil."
(interactive)
(org-export-to-buffer 'latex "*Org LATEX Export*"
- async subtreep visible-only body-only ext-plist (lambda () (LaTeX-mode))))
+ async subtreep visible-only body-only ext-plist
+ (if (fboundp 'major-mode-remap)
+ (major-mode-remap 'latex-mode)
+ #'LaTeX-mode)))
;;;###autoload
(defun org-latex-convert-region-to-latex ()
diff --git a/lisp/org/ox-man.el b/lisp/org/ox-man.el
index 7d1b578d97f..2019a531fa7 100644
--- a/lisp/org/ox-man.el
+++ b/lisp/org/ox-man.el
@@ -4,7 +4,7 @@
;; Author: Nicolas Goaziou <n.goaziou at gmail dot com>
;; Luis R Anaya <papoanaya aroba hot mail punto com>
-;; Keywords: outlines, hypermedia, calendar, wp
+;; Keywords: outlines, hypermedia, calendar, text
;; This file is part of GNU Emacs.
diff --git a/lisp/org/ox-md.el b/lisp/org/ox-md.el
index 8d01c746c1b..35bc4aa642b 100644
--- a/lisp/org/ox-md.el
+++ b/lisp/org/ox-md.el
@@ -4,7 +4,7 @@
;; Author: Nicolas Goaziou <n.goaziou@gmail.com>
;; Maintainer: Nicolas Goaziou <mail@nicolasgoaziou.fr>
-;; Keywords: org, wp, markdown
+;; Keywords: org, text, markdown
;; This file is part of GNU Emacs.
diff --git a/lisp/org/ox-odt.el b/lisp/org/ox-odt.el
index 2c70d1dea27..d0d4727e7aa 100644
--- a/lisp/org/ox-odt.el
+++ b/lisp/org/ox-odt.el
@@ -3,7 +3,7 @@
;; Copyright (C) 2010-2024 Free Software Foundation, Inc.
;; Author: Jambunathan K <kjambunathan at gmail dot com>
-;; Keywords: outlines, hypermedia, calendar, wp
+;; Keywords: outlines, hypermedia, calendar, text
;; URL: https://orgmode.org
;; This file is part of GNU Emacs.
diff --git a/lisp/org/ox-org.el b/lisp/org/ox-org.el
index ce2bcc1a337..fdd0658fb62 100644
--- a/lisp/org/ox-org.el
+++ b/lisp/org/ox-org.el
@@ -4,7 +4,7 @@
;; Author: Nicolas Goaziou <n.goaziou@gmail.com>
;; Maintainer: Nicolas Goaziou <mail@nicolasgoaziou.fr>
-;; Keywords: org, wp
+;; Keywords: org, text
;; This file is part of GNU Emacs.
diff --git a/lisp/org/ox-publish.el b/lisp/org/ox-publish.el
index e0815b3dc8d..ce45c6f1b77 100644
--- a/lisp/org/ox-publish.el
+++ b/lisp/org/ox-publish.el
@@ -3,7 +3,7 @@
;; Author: David O'Toole <dto@gnu.org>
;; Maintainer: Nicolas Goaziou <mail@nicolasgoaziou.fr>
-;; Keywords: hypermedia, outlines, wp
+;; Keywords: hypermedia, outlines, text
;; This file is part of GNU Emacs.
;;
diff --git a/lisp/org/ox-texinfo.el b/lisp/org/ox-texinfo.el
index 49d5d17d472..84313645e6e 100644
--- a/lisp/org/ox-texinfo.el
+++ b/lisp/org/ox-texinfo.el
@@ -3,7 +3,7 @@
;; Copyright (C) 2012-2024 Free Software Foundation, Inc.
;; Author: Jonathan Leech-Pepin <jonathan.leechpepin at gmail dot com>
;; Maintainer: Nicolas Goaziou <mail@nicolasgoaziou.fr>
-;; Keywords: outlines, hypermedia, calendar, wp
+;; Keywords: outlines, hypermedia, calendar, text
;; This file is part of GNU Emacs.
diff --git a/lisp/org/ox.el b/lisp/org/ox.el
index b8050bcda5c..bf2d9b569af 100644
--- a/lisp/org/ox.el
+++ b/lisp/org/ox.el
@@ -4,7 +4,7 @@
;; Author: Nicolas Goaziou <mail@nicolasgoaziou.fr>
;; Maintainer: Nicolas Goaziou <mail@nicolasgoaziou.fr>
-;; Keywords: outlines, hypermedia, calendar, wp
+;; Keywords: outlines, hypermedia, calendar, text
;; This file is part of GNU Emacs.
@@ -6608,7 +6608,7 @@ use it to set a major mode there, e.g.,
(interactive)
(org-export-to-buffer \\='latex \"*Org LATEX Export*\"
async subtreep visible-only body-only ext-plist
- #\\='LaTeX-mode))
+ (major-mode-remap \\='latex-mode)))
When expressed as an anonymous function, using `lambda',
POST-PROCESS needs to be quoted.
diff --git a/lisp/outline.el b/lisp/outline.el
index 724263ef3d2..40a75701cbf 100644
--- a/lisp/outline.el
+++ b/lisp/outline.el
@@ -260,7 +260,7 @@ non-nil and point is located on the heading line.")
'(
;; Highlight headings according to the level.
(eval . (list (or outline-search-function
- (concat "^\\(?:" outline-regexp "\\).*"))
+ (concat "^\\(?:" outline-regexp "\\).*" outline-heading-end-regexp))
0 '(if outline-minor-mode
(if outline-minor-mode-highlight
(list 'face (outline-font-lock-face)))
@@ -686,7 +686,7 @@ If POS is nil, use `point' instead."
(defun outline-back-to-heading (&optional invisible-ok)
"Move to previous heading line, or beg of this line if it's a heading.
Only visible heading lines are considered, unless INVISIBLE-OK is non-nil."
- (beginning-of-line)
+ (forward-line 0)
(or (outline-on-heading-p invisible-ok)
(let (found)
(save-excursion
@@ -705,7 +705,7 @@ Only visible heading lines are considered, unless INVISIBLE-OK is non-nil."
"Return t if point is on a (visible) heading line.
If INVISIBLE-OK is non-nil, an invisible heading line is ok too."
(save-excursion
- (beginning-of-line)
+ (forward-line 0)
(and (bolp) (or invisible-ok (not (outline-invisible-p)))
(if outline-search-function
(funcall outline-search-function nil nil nil t)
@@ -725,7 +725,7 @@ If INVISIBLE-OK is non-nil, an invisible heading line is ok too."
(not (string-match (concat "\\`\\(?:" outline-regexp "\\)")
(concat head " "))))
(setq head (concat head " ")))
- (unless (bolp) (end-of-line) (newline))
+ (unless (bolp) (goto-char (pos-eol)) (newline))
(insert head)
(unless (eolp)
(save-excursion (newline-and-indent)))
@@ -941,9 +941,7 @@ With ARG, repeats or can move backward if negative.
A heading line is one that starts with a `*' (or that
`outline-regexp' matches)."
(interactive "p")
- (if (< arg 0)
- (beginning-of-line)
- (end-of-line))
+ (goto-char (if (< arg 0) (pos-bol) (pos-eol)))
(let ((regexp (unless outline-search-function
(concat "^\\(?:" outline-regexp "\\)")))
found-heading-p)
@@ -963,7 +961,7 @@ A heading line is one that starts with a `*' (or that
(re-search-forward regexp nil 'move)))
(outline-invisible-p (match-beginning 0))))
(setq arg (1- arg)))
- (if found-heading-p (beginning-of-line))))
+ (if found-heading-p (forward-line 0))))
(defun outline-previous-visible-heading (arg)
"Move to the previous heading line.
@@ -980,7 +978,7 @@ This puts point at the start of the current subtree, and mark at the end."
(let ((beg))
(if (outline-on-heading-p)
;; we are already looking at a heading
- (beginning-of-line)
+ (forward-line 0)
;; else go back to previous heading
(outline-previous-visible-heading 1))
(setq beg (point))
@@ -1183,7 +1181,7 @@ of the current heading, or to 1 if the current line is not a heading."
(cond
(current-prefix-arg (prefix-numeric-value current-prefix-arg))
((save-excursion
- (beginning-of-line)
+ (forward-line 0)
(if outline-search-function
(funcall outline-search-function nil nil nil t)
(looking-at outline-regexp)))
@@ -1243,7 +1241,7 @@ This also unhides the top heading-less body, if any."
(interactive)
(save-excursion
(outline-back-to-heading)
- (if (not (outline-invisible-p (line-end-position)))
+ (if (not (outline-invisible-p (pos-eol)))
(outline-hide-subtree)
(outline-show-children)
(outline-show-entry))))
@@ -1834,7 +1832,7 @@ With a prefix argument, show headings up to that LEVEL."
(defun outline--insert-button (type)
(with-silent-modifications
(save-excursion
- (beginning-of-line)
+ (forward-line 0)
(let ((icon (nth (if (eq type 'close) 1 0) outline--button-icons))
(o (seq-find (lambda (o) (overlay-get o 'outline-button))
(overlays-at (point)))))
@@ -1842,7 +1840,7 @@ With a prefix argument, show headings up to that LEVEL."
(when (eq outline-minor-mode-use-buttons 'insert)
(let ((inhibit-read-only t))
(insert (apply #'propertize " " (text-properties-at (point))))
- (beginning-of-line)))
+ (forward-line 0)))
(setq o (make-overlay (point) (1+ (point))))
(overlay-put o 'outline-button t)
(overlay-put o 'evaporate t))
@@ -1866,7 +1864,7 @@ With a prefix argument, show headings up to that LEVEL."
(when from
(save-excursion
(goto-char from)
- (setq from (line-beginning-position))))
+ (setq from (pos-bol))))
(outline-map-region
(lambda ()
(let ((close-p (save-excursion
diff --git a/lisp/pcmpl-git.el b/lisp/pcmpl-git.el
index facca4107a1..95b6859dd23 100644
--- a/lisp/pcmpl-git.el
+++ b/lisp/pcmpl-git.el
@@ -88,7 +88,7 @@ Files listed by `git ls-files ARGS' satisfy the predicate."
(pcomplete-entries
nil (pcmpl-git--tracked-file-predicate "-m"))))
;; Complete all tracked files
- ((or "mv" "rm" "grep" "status")
+ ((or "mv" "rm" "grep" "status" "blame")
(pcomplete-here
(pcomplete-entries nil (pcmpl-git--tracked-file-predicate))))
;; Complete revisions
diff --git a/lisp/pcmpl-gnu.el b/lisp/pcmpl-gnu.el
index fcc4ab440eb..237e3d62526 100644
--- a/lisp/pcmpl-gnu.el
+++ b/lisp/pcmpl-gnu.el
@@ -184,6 +184,86 @@ Return the new list."
(when (and (not ,exist) (buffer-live-p ,buf))
(kill-buffer ,buf))))))
+(defvar pcmpl-gnu--tar-long-options
+ ;; FIXME: Extract this list from "tar --help".
+ '("--absolute-names"
+ "--after-date="
+ "--append"
+ "--atime-preserve"
+ "--backup"
+ "--block-number"
+ "--blocking-factor="
+ "--catenate"
+ "--checkpoint"
+ "--compare"
+ "--compress"
+ "--concatenate"
+ "--confirmation"
+ "--create"
+ "--delete"
+ "--dereference"
+ "--diff"
+ "--directory="
+ "--exclude="
+ "--exclude-from="
+ "--extract"
+ "--file="
+ "--files-from="
+ "--force-local"
+ "--get"
+ "--group="
+ "--gzip"
+ "--help"
+ "--ignore-failed-read"
+ "--ignore-zeros"
+ "--incremental"
+ "--info-script="
+ "--interactive"
+ "--keep-old-files"
+ "--label="
+ "--list"
+ "--listed-incremental"
+ "--mode="
+ "--modification-time"
+ "--multi-volume"
+ "--new-volume-script="
+ "--newer="
+ "--newer-mtime"
+ "--no-recursion"
+ "--null"
+ "--numeric-owner"
+ "--old-archive"
+ "--one-file-system"
+ "--owner="
+ "--portability"
+ "--posix"
+ "--preserve"
+ "--preserve-order"
+ "--preserve-permissions"
+ "--read-full-records"
+ "--record-size="
+ "--recursive-unlink"
+ "--remove-files"
+ "--rsh-command="
+ "--same-order"
+ "--same-owner"
+ "--same-permissions"
+ "--sparse"
+ "--starting-file="
+ "--suffix="
+ "--tape-length="
+ "--to-stdout"
+ "--totals"
+ "--uncompress"
+ "--ungzip"
+ "--unlink-first"
+ "--update"
+ "--use-compress-program="
+ "--verbose"
+ "--verify"
+ "--version"
+ "--volno-file="))
+
;;;###autoload
(defun pcomplete/tar ()
"Completion for the GNU tar utility."
@@ -192,148 +272,53 @@ Return the new list."
(while (pcomplete-match "^-" 0)
(setq saw-option t)
(if (pcomplete-match "^--" 0)
- (if (pcomplete-match "^--\\([^= \t\n\f]*\\)\\'" 0)
- ;; FIXME: Extract this list from "tar --help".
- (pcomplete-here*
- '("--absolute-names"
- "--after-date="
- "--append"
- "--atime-preserve"
- "--backup"
- "--block-number"
- "--blocking-factor="
- "--catenate"
- "--checkpoint"
- "--compare"
- "--compress"
- "--concatenate"
- "--confirmation"
- "--create"
- "--delete"
- "--dereference"
- "--diff"
- "--directory="
- "--exclude="
- "--exclude-from="
- "--extract"
- "--file="
- "--files-from="
- "--force-local"
- "--get"
- "--group="
- "--gzip"
- "--help"
- "--ignore-failed-read"
- "--ignore-zeros"
- "--incremental"
- "--info-script="
- "--interactive"
- "--keep-old-files"
- "--label="
- "--list"
- "--listed-incremental"
- "--mode="
- "--modification-time"
- "--multi-volume"
- "--new-volume-script="
- "--newer="
- "--newer-mtime"
- "--no-recursion"
- "--null"
- "--numeric-owner"
- "--old-archive"
- "--one-file-system"
- "--owner="
- "--portability"
- "--posix"
- "--preserve"
- "--preserve-order"
- "--preserve-permissions"
- "--read-full-records"
- "--record-size="
- "--recursive-unlink"
- "--remove-files"
- "--rsh-command="
- "--same-order"
- "--same-owner"
- "--same-permissions"
- "--sparse"
- "--starting-file="
- "--suffix="
- "--tape-length="
- "--to-stdout"
- "--totals"
- "--uncompress"
- "--ungzip"
- "--unlink-first"
- "--update"
- "--use-compress-program="
- "--verbose"
- "--verify"
- "--version"
- "--volno-file=")))
- (pcomplete-opt "01234567ABCFGKLMNOPRSTUVWXZbcdfghiklmoprstuvwxz"))
- (cond
- ((pcomplete-match "\\`-\\'" 0)
- (pcomplete-here*))
- ((pcomplete-match "\\`--after-date=" 0)
- (pcomplete-here*))
- ((pcomplete-match "\\`--backup=" 0)
- (pcomplete-here*))
- ((pcomplete-match "\\`--blocking-factor=" 0)
- (pcomplete-here*))
- ((pcomplete-match "\\`--directory=\\(.*\\)" 0)
- (pcomplete-here* (pcomplete-dirs)
- (pcomplete-match-string 1 0)))
- ((pcomplete-match "\\`--exclude-from=\\(.*\\)" 0)
- (pcomplete-here* (pcomplete-entries)
- (pcomplete-match-string 1 0)))
- ((pcomplete-match "\\`--exclude=" 0)
- (pcomplete-here*))
- ((pcomplete-match "\\`--\\(extract\\|list\\)\\'" 0)
- (setq complete-within t))
- ((pcomplete-match "\\`--file=\\(.*\\)" 0)
- (pcomplete-here* (pcomplete-dirs-or-entries pcmpl-gnu-tarfile-regexp)
- (pcomplete-match-string 1 0)))
- ((pcomplete-match "\\`--files-from=\\(.*\\)" 0)
- (pcomplete-here* (pcomplete-entries)
- (pcomplete-match-string 1 0)))
- ((pcomplete-match "\\`--group=\\(.*\\)" 0)
- (pcomplete-here* (pcmpl-unix-group-names)
- (pcomplete-match-string 1 0)))
- ((pcomplete-match "\\`--info-script=\\(.*\\)" 0)
- (pcomplete-here* (pcomplete-entries)
- (pcomplete-match-string 1 0)))
- ((pcomplete-match "\\`--label=" 0)
- (pcomplete-here*))
- ((pcomplete-match "\\`--mode=" 0)
- (pcomplete-here*))
- ((pcomplete-match "\\`--new-volume-script=\\(.*\\)" 0)
- (pcomplete-here* (pcomplete-entries)
- (pcomplete-match-string 1 0)))
- ((pcomplete-match "\\`--newer=" 0)
- (pcomplete-here*))
- ((pcomplete-match "\\`--owner=\\(.*\\)" 0)
- (pcomplete-here* (pcmpl-unix-user-names)
- (pcomplete-match-string 1 0)))
- ((pcomplete-match "\\`--record-size=" 0)
- (pcomplete-here*))
- ((pcomplete-match "\\`--rsh-command=\\(.*\\)" 0)
- (pcomplete-here* (funcall pcomplete-command-completion-function)
- (pcomplete-match-string 1 0)))
- ((pcomplete-match "\\`--starting-file=\\(.*\\)" 0)
- (pcomplete-here* (pcomplete-entries)
- (pcomplete-match-string 1 0)))
- ((pcomplete-match "\\`--suffix=" 0)
- (pcomplete-here*))
- ((pcomplete-match "\\`--tape-length=" 0)
- (pcomplete-here*))
- ((pcomplete-match "\\`--use-compress-program=\\(.*\\)" 0)
- (pcomplete-here* (funcall pcomplete-command-completion-function)
- (pcomplete-match-string 1 0)))
- ((pcomplete-match "\\`--volno-file=\\(.*\\)" 0)
- (pcomplete-here* (pcomplete-entries)
- (pcomplete-match-string 1 0)))))
+ (cond
+ ((pcomplete-match "^--\\([^= \t\n\f]*\\)\\'" 0)
+ (pcomplete-here* pcmpl-gnu--tar-long-options))
+ ((pcomplete-match "\\`--directory=\\(.*\\)" 0)
+ (pcomplete-here* (pcomplete-dirs)
+ (pcomplete-match-string 1 0)))
+ ((pcomplete-match "\\`--exclude-from=\\(.*\\)" 0)
+ (pcomplete-here* (pcomplete-entries)
+ (pcomplete-match-string 1 0)))
+ ((pcomplete-match "\\`--\\(extract\\|list\\)\\'" 0)
+ (setq complete-within t))
+ ((pcomplete-match "\\`--file=\\(.*\\)" 0)
+ (pcomplete-here* (pcomplete-dirs-or-entries
+ pcmpl-gnu-tarfile-regexp)
+ (pcomplete-match-string 1 0)))
+ ((pcomplete-match "\\`--files-from=\\(.*\\)" 0)
+ (pcomplete-here* (pcomplete-entries)
+ (pcomplete-match-string 1 0)))
+ ((pcomplete-match "\\`--group=\\(.*\\)" 0)
+ (pcomplete-here* (pcmpl-unix-group-names)
+ (pcomplete-match-string 1 0)))
+ ((pcomplete-match "\\`--info-script=\\(.*\\)" 0)
+ (pcomplete-here* (pcomplete-entries)
+ (pcomplete-match-string 1 0)))
+ ((pcomplete-match "\\`--new-volume-script=\\(.*\\)" 0)
+ (pcomplete-here* (pcomplete-entries)
+ (pcomplete-match-string 1 0)))
+ ((pcomplete-match "\\`--owner=\\(.*\\)" 0)
+ (pcomplete-here* (pcmpl-unix-user-names)
+ (pcomplete-match-string 1 0)))
+ ((pcomplete-match "\\`--rsh-command=\\(.*\\)" 0)
+ (pcomplete-here* (funcall pcomplete-command-completion-function)
+ (pcomplete-match-string 1 0)))
+ ((pcomplete-match "\\`--starting-file=\\(.*\\)" 0)
+ (pcomplete-here* (pcomplete-entries)
+ (pcomplete-match-string 1 0)))
+ ((pcomplete-match "\\`--use-compress-program=\\(.*\\)" 0)
+ (pcomplete-here* (funcall pcomplete-command-completion-function)
+ (pcomplete-match-string 1 0)))
+ ((pcomplete-match "\\`--volno-file=\\(.*\\)" 0)
+ (pcomplete-here* (pcomplete-entries)
+ (pcomplete-match-string 1 0)))
+ (t
+ (pcomplete-here*)))
+ (pcomplete-opt "01234567ABCFGKLMNOPRSTUVWXZbcdfghiklmoprstuvwxz")
+ (when (pcomplete-match "\\`-\\'" 0)
+ (pcomplete-here*))))
(unless saw-option
(pcomplete-here
(mapcar #'char-to-string
diff --git a/lisp/pcmpl-linux.el b/lisp/pcmpl-linux.el
index 3aee0b296f6..d0defc54174 100644
--- a/lisp/pcmpl-linux.el
+++ b/lisp/pcmpl-linux.el
@@ -61,7 +61,7 @@
(pcomplete-opt "hVanfFrsvwt(pcmpl-linux-fs-types)o?L?U?")
(while (pcomplete-here (pcomplete-entries) nil #'identity)))
-(defconst pcmpl-linux-fs-modules-path-format "/lib/modules/%s/kernel/fs/")
+(defvar pcmpl-linux-fs-modules-path-format "/lib/modules/%s/kernel/fs/")
(defun pcmpl-linux-fs-types ()
"Return a list of available fs modules on GNU/Linux systems."
@@ -69,7 +69,7 @@
(directory-files
(format pcmpl-linux-fs-modules-path-format kernel-ver))))
-(defconst pcmpl-linux-mtab-file "/etc/mtab")
+(defvar pcmpl-linux-mtab-file "/etc/mtab")
(defun pcmpl-linux-mounted-directories ()
"Return a list of mounted directory names."
diff --git a/lisp/pcmpl-unix.el b/lisp/pcmpl-unix.el
index 5abe39e0d7c..65308cffec4 100644
--- a/lisp/pcmpl-unix.el
+++ b/lisp/pcmpl-unix.el
@@ -227,7 +227,7 @@ documentation), this function returns nil."
;;;###autoload(defalias 'pcomplete/sha224sum 'pcomplete/md5sum)
;;;###autoload(defalias 'pcomplete/sha256sum 'pcomplete/md5sum)
;;;###autoload(defalias 'pcomplete/sha384sum 'pcomplete/md5sum)
-;;;###autoload(defalias 'pcomplete/sha521sum 'pcomplete/md5sum)
+;;;###autoload(defalias 'pcomplete/sha512sum 'pcomplete/md5sum)
;;;###autoload
(defun pcomplete/sort ()
@@ -685,6 +685,14 @@ Includes files as well as host names followed by a colon."
(funcall (or (pcomplete-find-completion-function (pcomplete-arg 1))
pcomplete-default-completion-function)))
+;;;###autoload
+(defun pcomplete/doas ()
+ "Completion for the `doas' command."
+ (pcomplete-opt "C(pcomplete-entries)Lnsu(pcmpl-unix-user-names)")
+ (funcall pcomplete-command-completion-function)
+ (funcall (or (pcomplete-find-completion-function (pcomplete-arg 1))
+ pcomplete-default-completion-function)))
+
(provide 'pcmpl-unix)
;;; pcmpl-unix.el ends here
diff --git a/lisp/pcomplete.el b/lisp/pcomplete.el
index 5c81138d596..0b34712a50c 100644
--- a/lisp/pcomplete.el
+++ b/lisp/pcomplete.el
@@ -138,6 +138,11 @@
"A regexp of names to be disregarded during directory completion."
:type '(choice regexp (const :tag "None" nil)))
+(defcustom pcomplete-remote-file-ignore nil
+ "Whether to ignore remote file names."
+ :version "30.1"
+ :type 'boolean)
+
(define-obsolete-variable-alias 'pcomplete-ignore-case 'completion-ignore-case
"28.1")
@@ -362,6 +367,32 @@ modified to be an empty string, or the desired separation string."
;;; User Functions:
+(defun pcomplete-default-exit-function (_s status)
+ "The default exit function to use in `pcomplete-completions-at-point'.
+This just adds `pcomplete-termination-string' after the
+completion if STATUS is `finished'."
+ (unless (zerop (length pcomplete-termination-string))
+ (when (eq status 'finished)
+ (if (looking-at
+ (regexp-quote pcomplete-termination-string))
+ (goto-char (match-end 0))
+ (insert pcomplete-termination-string)))))
+
+(defvar pcomplete-exit-function #'pcomplete-default-exit-function
+ "The exit function to call in `pcomplete-completions-at-point'.
+
+This variable is let-bound in `pcomplete-completions-at-point',
+so you can modify or advise it in order to adjust the behavior
+for a specific completion. For example, you might do the
+following in a `pcomplete-try-first-hook' function to insert a
+trailing slash after a completion:
+
+ (add-function
+ :before (var pcomplete-exit-function)
+ (lambda (_ status)
+ (when (eq status \\='finished)
+ (insert \"/\"))))")
+
;;; Alternative front-end using the standard completion facilities.
;; The way pcomplete-parse-arguments and pcomplete-stub work only
@@ -406,6 +437,7 @@ Same as `pcomplete' but using the standard completion UI."
(if pcomplete-allow-modifications buffer-read-only t))
pcomplete-seen pcomplete-norm-func
pcomplete-args pcomplete-last pcomplete-index
+ (pcomplete-exit-function pcomplete-exit-function)
(pcomplete-autolist pcomplete-autolist)
(pcomplete-suffix-list pcomplete-suffix-list)
;; Apparently the vars above are global vars modified by
@@ -438,6 +470,8 @@ Same as `pcomplete' but using the standard completion UI."
;; rely less on c-t-subvert.
(beg (max (- (point) (length pcomplete-stub))
argbeg))
+ (end (point))
+ tmp
buftext)
;; Try and improve our guess of `beg' in case the difference
;; between pcomplete-stub and the buffer's text is simply due to
@@ -445,11 +479,19 @@ Same as `pcomplete' but using the standard completion UI."
;; indispensable but reduces the reliance on c-t-subvert and
;; improves corner case behaviors.
(while (progn (setq buftext (pcomplete-unquote-argument
- (buffer-substring beg (point))))
+ (buffer-substring beg end)))
(and (> beg argbeg)
(> (length pcomplete-stub) (length buftext))))
(setq beg (max argbeg (- beg (- (length pcomplete-stub)
(length buftext))))))
+ ;; Try and improve our guess of `end' in case it's not point.
+ (while (and (< (length buftext) (length pcomplete-stub))
+ (< end (point-max))
+ (string-prefix-p (setq tmp (pcomplete-unquote-argument
+ (buffer-substring beg (1+ end))))
+ pcomplete-stub))
+ (setq end (1+ end))
+ (setq buftext tmp))
(when completions
(let ((table
(completion-table-with-quoting
@@ -483,7 +525,7 @@ Same as `pcomplete' but using the standard completion UI."
seen)))))))
(when completion-ignore-case
(setq table (completion-table-case-fold table)))
- (list beg (point) table
+ (list beg end table
:annotation-function
(lambda (cand)
(when (stringp cand)
@@ -494,16 +536,7 @@ Same as `pcomplete' but using the standard completion UI."
(get-text-property 0 'pcomplete-help cand)))
:predicate pred
:exit-function
- ;; If completion is finished, add a terminating space.
- ;; We used to also do this if STATUS is `sole', but
- ;; that does not work right when completion cycling.
- (unless (zerop (length pcomplete-termination-string))
- (lambda (_s status)
- (when (eq status 'finished)
- (if (looking-at
- (regexp-quote pcomplete-termination-string))
- (goto-char (match-end 0))
- (insert pcomplete-termination-string)))))))))))
+ pcomplete-exit-function))))))
;; I don't think such commands are usable before first setting up buffer-local
;; variables to parse args, so there's no point autoloading it.
@@ -652,35 +685,13 @@ parts of the list.
The OFFSET argument is added to/taken away from the index that will be
used. This is really only useful with `first' and `last', for
-accessing absolute argument positions.
-
-When the argument has been transformed into something that is not
-a string by `pcomplete-parse-arguments-function', the text
-representation of the argument, namely what the user actually
-typed in, is returned, and the value of the argument is stored in
-the pcomplete-arg-value text property of that string."
- (let ((arg
- (nth (+ (pcase index
- ('first 0)
- ('last pcomplete-last)
- (_ (- pcomplete-index (or index 0))))
- (or offset 0))
- pcomplete-args)))
- (if (or (stringp arg)
- ;; FIXME: 'last' is handled specially in Emacs 29, because
- ;; 'pcomplete-parse-arguments' accepts a list of strings
- ;; (which are completion candidates) as return value for
- ;; (pcomplete-arg 'last). See below: "it means it's a
- ;; list of completions computed during parsing,
- ;; e.g. Eshell uses that to turn globs into lists of
- ;; completions". This special case will be dealt with
- ;; differently in Emacs 30: the pcomplete-arg-value
- ;; property will be used by 'pcomplete-parse-arguments'.
- (eq index 'last))
- arg
- (propertize
- (car (split-string (pcomplete-actual-arg index offset)))
- 'pcomplete-arg-value arg))))
+accessing absolute argument positions."
+ (nth (+ (pcase index
+ ('first 0)
+ ('last pcomplete-last)
+ (_ (- pcomplete-index (or index 0))))
+ (or offset 0))
+ pcomplete-args))
(defun pcomplete-begin (&optional index offset)
"Return the beginning position of the INDEXth argument.
@@ -891,14 +902,16 @@ this is `comint-dynamic-complete-functions'."
(and dir-ignore (string-match dir-ignore file))
(and file-ignore (string-match file-ignore file))))))))
(reg-pred (if regexp (lambda (file) (string-match regexp file))))
- (pred (cond
- ((null (or ign-pred reg-pred)) predicate)
- ((null (or ign-pred predicate)) reg-pred)
- ((null (or reg-pred predicate)) ign-pred)
- (t (lambda (f)
+ ;; `completion-file-name-table' calls `file-exists-p' when
+ ;; the predicate is nil.
+ ;; So likewise, defer to PREDICATE if it's there, else take
+ ;; ourselves to be responsible for calling `file-exists-p'.
+ (pred (if (or ign-pred reg-pred)
+ (lambda (f)
(and (or (null reg-pred) (funcall reg-pred f))
(or (null ign-pred) (funcall ign-pred f))
- (or (null predicate) (funcall predicate f))))))))
+ (funcall (or predicate #'file-exists-p) f)))
+ predicate)))
(lambda (s p a)
(if (and (eq a 'metadata) pcomplete-compare-entry-function)
`(metadata (cycle-sort-function
@@ -906,7 +919,10 @@ this is `comint-dynamic-complete-functions'."
(sort comps pcomplete-compare-entry-function)))
,@(cdr (completion-file-name-table s p a)))
(let ((completion-ignored-extensions nil)
- (completion-ignore-case completion-ignore-case))
+ (completion-ignore-case completion-ignore-case)
+ (tramp-mode (and tramp-mode (not pcomplete-remote-file-ignore)))
+ (non-essential (not (file-remote-p s)))
+ (minibuffer-completing-file-name (not (file-remote-p s))))
(completion-table-with-predicate
#'comint-completion-file-name-table pred 'strict s p a))))))
@@ -1124,7 +1140,7 @@ Typing SPC flushes the help buffer."
(let (event)
(prog1
(catch 'done
- (while (with-current-buffer (get-buffer "*Completions*")
+ (while (with-current-buffer "*Completions*"
(setq event (read-event)))
(cond
((eq event ?\s)
@@ -1300,11 +1316,12 @@ If specific documentation can't be given, be generic."
;; general utilities
-(defun pcomplete-uniquify-list (l)
- "Sort and remove multiples in L."
- (setq l (sort l #'string-lessp))
- (seq-uniq l))
-(define-obsolete-function-alias 'pcomplete-uniqify-list #'pcomplete-uniquify-list "27.1")
+(defun pcomplete-uniquify-list (sequence)
+ "Sort and remove multiples in SEQUENCE.
+Sequence should be a vector or list of strings."
+ (sort (seq-uniq sequence) #'string-lessp))
+(define-obsolete-function-alias
+ 'pcomplete-uniqify-list #'pcomplete-uniquify-list "27.1")
(defun pcomplete-process-result (cmd &rest args)
"Call CMD using `call-process' and return the simplest result."
diff --git a/lisp/pgtk-dnd.el b/lisp/pgtk-dnd.el
index dc0d839126e..edc51320a79 100644
--- a/lisp/pgtk-dnd.el
+++ b/lisp/pgtk-dnd.el
@@ -238,10 +238,9 @@ WINDOW is the window where the drop happened.
STRING is the uri-list as a string. The URIs are separated by \\r\\n."
(let ((uri-list (split-string string "[\0\r\n]" t))
retval)
- (dolist (bf uri-list)
- ;; If one URL is handled, treat as if the whole drop succeeded.
- (let ((did-action (dnd-handle-one-url window action bf)))
- (when did-action (setq retval did-action))))
+ (let ((did-action (dnd-handle-multiple-urls window uri-list
+ action)))
+ (when did-action (setq retval did-action)))
retval))
(defun pgtk-dnd-handle-file-name (window action string)
@@ -252,17 +251,22 @@ STRING is the file names as a string, separated by nulls."
(coding (or file-name-coding-system
default-file-name-coding-system))
retval)
- (dolist (bf uri-list)
- ;; If one URL is handled, treat as if the whole drop succeeded.
- (if coding (setq bf (encode-coding-string bf coding)))
- (let* ((file-uri (concat "file://"
- (mapconcat 'url-hexify-string
- (split-string bf "/") "/")))
- (did-action (dnd-handle-one-url window action file-uri)))
- (when did-action (setq retval did-action))))
+ (let ((did-action
+ (dnd-handle-multiple-urls
+ window (mapcar
+ (lambda (item)
+ (when coding
+ (setq item (encode-coding-string item
+ coding)))
+ (concat "file://"
+ (mapconcat 'url-hexify-string
+ (split-string item "/")
+ "/")))
+ uri-list)
+ action)))
+ (when did-action (setq retval did-action)))
retval))
-
(defun pgtk-dnd-choose-type (types &optional known-types)
"Choose which type we want to receive for the drop.
TYPES are the types the source of the drop offers, a vector of type names
diff --git a/lisp/pixel-scroll.el b/lisp/pixel-scroll.el
index d7046925005..4bf912e54c0 100644
--- a/lisp/pixel-scroll.el
+++ b/lisp/pixel-scroll.el
@@ -148,67 +148,62 @@ is always with pixel resolution.")
"<next>" #'pixel-scroll-interpolate-down
"<prior>" #'pixel-scroll-interpolate-up)
+(defgroup pixel-scroll-precision nil
+ "Precise pixel scrolling."
+ :group 'mouse
+ :version "30.1")
+
(defcustom pixel-scroll-precision-use-momentum nil
"If non-nil, continue to scroll the display after wheel movement stops.
This is only effective if supported by your mouse or touchpad."
- :group 'mouse
:type 'boolean
:version "29.1")
(defcustom pixel-scroll-precision-momentum-tick 0.01
"Number of seconds between each momentum scroll."
- :group 'mouse
:type 'float
:version "29.1")
(defcustom pixel-scroll-precision-momentum-seconds 1.75
"The maximum duration in seconds of momentum scrolling."
- :group 'mouse
:type 'float
:version "29.1")
(defcustom pixel-scroll-precision-momentum-min-velocity 10.0
"The minimum scrolled pixels per second before momentum scrolling starts."
- :group 'mouse
:type 'float
:version "29.1")
(defcustom pixel-scroll-precision-initial-velocity-factor (/ 0.0335 4)
"Factor applied to the initial velocity before momentum scrolling begins."
- :group 'mouse
:type 'float
:version "29.1")
(defcustom pixel-scroll-precision-large-scroll-height nil
"Pixels that must be scrolled before an animation is performed.
Nil means to not interpolate such scrolls."
- :group 'mouse
:type '(choice (const :tag "Do not interpolate large scrolls" nil)
number)
:version "29.1")
(defcustom pixel-scroll-precision-interpolation-total-time 0.1
"The total time in seconds to spend interpolating a large scroll."
- :group 'mouse
:type 'float
:version "29.1")
(defcustom pixel-scroll-precision-interpolation-factor 2.0
"A factor to apply to the distance of an interpolated scroll."
- :group 'mouse
:type 'float
:version "29.1")
(defcustom pixel-scroll-precision-interpolation-between-scroll 0.001
"The number of seconds between each step of an interpolated scroll."
- :group 'mouse
:type 'float
:version "29.1")
(defcustom pixel-scroll-precision-interpolate-page nil
"Whether or not to interpolate scrolling via the Page Down and Page Up keys.
This is only effective when `pixel-scroll-precision-mode' is enabled."
- :group 'scrolling
:type 'boolean
:version "29.1")
@@ -216,7 +211,6 @@ This is only effective when `pixel-scroll-precision-mode' is enabled."
"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")
@@ -504,6 +498,7 @@ Otherwise, redisplay will reset the window's vscroll."
(set-window-start nil (pixel-point-at-unseen-line) t)
(set-window-vscroll nil vscroll t))
+;;;###autoload
(defun pixel-scroll-precision-scroll-down-page (delta)
"Scroll the current window down by DELTA pixels.
Note that this function doesn't work if DELTA is larger than
@@ -518,38 +513,41 @@ the height of the current window."
(desired-vscroll (if start-posn
(- delta (cdr (posn-x-y start-posn)))
(+ current-vs delta)))
- (edges (window-edges nil t))
- (usable-height (- (nth 3 edges)
- (nth 1 edges)))
- (next-pos (save-excursion
- (goto-char desired-start)
- (when (zerop (vertical-motion (1+ scroll-margin)))
- (set-window-start nil desired-start)
- (signal 'end-of-buffer nil))
- (while (when-let ((posn (posn-at-point)))
- (< (cdr (posn-x-y posn)) delta))
- (when (zerop (vertical-motion 1))
- (set-window-start nil desired-start)
- (signal 'end-of-buffer nil)))
- (point)))
(scroll-preserve-screen-position nil)
- (auto-window-vscroll nil))
- (when (and (or (< (point) next-pos))
- (let ((pos-visibility (pos-visible-in-window-p next-pos nil t)))
- (and pos-visibility
- (or (eq (length pos-visibility) 2)
- (when-let* ((posn (posn-at-point next-pos)))
- (> (cdr (posn-object-width-height posn))
- usable-height))))))
- (goto-char next-pos))
- (set-window-start nil (if (zerop (window-hscroll))
- desired-start
- (save-excursion
- (goto-char desired-start)
- (beginning-of-visual-line)
- (point)))
- t)
- (set-window-vscroll nil desired-vscroll t t)))
+ (auto-window-vscroll nil)
+ (new-start-position (if (zerop (window-hscroll))
+ desired-start
+ (save-excursion
+ (goto-char desired-start)
+ (beginning-of-visual-line)
+ (point)))))
+ (set-window-start nil new-start-position
+ (not (zerop desired-vscroll)))
+ (set-window-vscroll nil desired-vscroll t t)
+ ;; Constrain point to a location that will not result in
+ ;; recentering, if it is no longer completely visible.
+ (unless (pos-visible-in-window-p (point))
+ ;; If desired-vscroll is 0, target the window start itself. But
+ ;; in any other case, target the line immediately below the
+ ;; window start, unless that line is itself invisible. This
+ ;; improves the appearance of the window by maintaining the
+ ;; cursor row in a fully visible state.
+ (if (zerop desired-vscroll)
+ (goto-char new-start-position)
+ (let ((line-after (save-excursion
+ (goto-char new-start-position)
+ (if (zerop (vertical-motion 1))
+ (progn
+ (set-window-vscroll nil 0 t t)
+ nil) ; nil means move to new-start-position.
+ (point)))))
+ (if (not line-after)
+ (progn
+ (goto-char new-start-position)
+ (signal 'end-of-buffer nil))
+ (if (pos-visible-in-window-p line-after nil t)
+ (goto-char line-after)
+ (goto-char new-start-position))))))))
(defun pixel-scroll-precision-scroll-down (delta)
"Scroll the current window down by DELTA pixels."
@@ -560,6 +558,7 @@ the height of the current window."
(setq delta (- delta max-height)))
(pixel-scroll-precision-scroll-down-page delta)))
+;;;###autoload
(defun pixel-scroll-precision-scroll-up-page (delta)
"Scroll the current window up by DELTA pixels.
Note that this function doesn't work if DELTA is larger than
@@ -567,27 +566,12 @@ the height of the current window."
(let* ((edges (window-edges nil t nil t))
(max-y (- (nth 3 edges)
(nth 1 edges)))
- (usable-height max-y)
(posn (posn-at-x-y 0 (+ (window-tab-line-height)
(window-header-line-height)
(- max-y delta))))
- (point (posn-point posn))
- (up-point (and point
- (save-excursion
- (goto-char point)
- (vertical-motion (- (1+ scroll-margin)))
- (point)))))
- (when (and point (> (point) up-point))
- (when (let ((pos-visible (pos-visible-in-window-p up-point nil t)))
- (or (eq (length pos-visible) 2)
- (when-let* ((posn (posn-at-point up-point))
- (edges (window-edges nil t))
- (usable-height (- (nth 3 edges)
- (nth 1 edges))))
- (> (cdr (posn-object-width-height posn))
- usable-height))))
- (goto-char up-point)))
- (let ((current-vscroll (window-vscroll nil t)))
+ (point (posn-point posn)))
+ (let ((current-vscroll (window-vscroll nil t))
+ (wanted-pos (window-start)))
(setq delta (- delta current-vscroll))
(set-window-vscroll nil 0 t t)
(when (> delta 0)
@@ -596,16 +580,25 @@ the height of the current window."
start nil nil nil t))
(height (nth 1 dims))
(position (nth 2 dims)))
- (set-window-start nil position t)
- ;; If the line above is taller than the window height (i.e. there's
- ;; a very tall image), keep point on it.
- (when (> height usable-height)
- (goto-char position))
+ (setq wanted-pos position)
(when (or (not position) (eq position start))
(signal 'beginning-of-buffer nil))
(setq delta (- delta height))))
+ (set-window-start nil wanted-pos
+ (not (zerop delta)))
(when (< delta 0)
- (set-window-vscroll nil (- delta) t t)))))
+ (set-window-vscroll nil (- delta) t t))
+ ;; vscroll and the window start are now set. Move point to a
+ ;; position where redisplay will not recenter, if it is now
+ ;; outside the window.
+ (unless (pos-visible-in-window-p (point))
+ (let ((up-pos (save-excursion
+ (goto-char point)
+ (vertical-motion -1)
+ (point))))
+ (if (pos-visible-in-window-p up-pos nil t)
+ (goto-char up-pos)
+ (goto-char (window-start))))))))
(defun pixel-scroll-precision-interpolate (delta &optional old-window factor)
"Interpolate a scroll of DELTA pixels.
@@ -852,13 +845,15 @@ It is a vector of the form [ VELOCITY TIME SIGN ]."
;;;###autoload
(define-minor-mode pixel-scroll-precision-mode
"Toggle pixel scrolling.
-When enabled, this minor mode allows to scroll the display
+When enabled, this minor mode allows you to scroll the display
precisely, according to the turning of the mouse wheel."
:global t
:group 'mouse
:keymap pixel-scroll-precision-mode-map
(setq mwheel-coalesce-scroll-events
- (not pixel-scroll-precision-mode)))
+ (not pixel-scroll-precision-mode))
+ (setq-default make-cursor-line-fully-visible
+ (not pixel-scroll-precision-mode)))
(provide 'pixel-scroll)
;;; pixel-scroll.el ends here
diff --git a/lisp/play/cookie1.el b/lisp/play/cookie1.el
index 42449952dc6..c4697a0d3b9 100644
--- a/lisp/play/cookie1.el
+++ b/lisp/play/cookie1.el
@@ -2,7 +2,7 @@
;; Copyright (C) 1993, 2001-2024 Free Software Foundation, Inc.
-;; Author: Eric S. Raymond <esr@snark.thyrsus.com>
+;; Author: Eric S. Raymond <esr@thyrsus.com>
;; Maintainer: emacs-devel@gnu.org
;; Keywords: games, extensions
;; Created: Mon Mar 22 17:06:26 1993
@@ -65,7 +65,7 @@
(defconst cookie-delimiter "\n%%\n\\|\n%\n\\|\0"
"Delimiter used to separate cookie file entries.")
-(defvar cookie-cache (make-vector 511 0)
+(defvar cookie-cache (obarray-make 511)
"Cache of cookie files that have already been snarfed.")
(defun cookie-check-file (file)
diff --git a/lisp/play/decipher.el b/lisp/play/decipher.el
index bfc28ec9f89..56f166c10f1 100644
--- a/lisp/play/decipher.el
+++ b/lisp/play/decipher.el
@@ -481,7 +481,7 @@ The most useful commands are:
"Checkpoint the current cipher alphabet.
This records the current alphabet so you can return to it later.
You may have any number of checkpoints.
-Type `\\[decipher-restore-checkpoint]' to restore a checkpoint."
+Type \\[decipher-restore-checkpoint] to restore a checkpoint."
(interactive "sCheckpoint description: " decipher-mode)
(or (stringp desc)
(setq desc ""))
@@ -508,7 +508,7 @@ Type `\\[decipher-restore-checkpoint]' to restore a checkpoint."
If point is not on a checkpoint line, moves to the first checkpoint line.
If point is on a checkpoint, restores that checkpoint.
-Type `\\[decipher-make-checkpoint]' to make a checkpoint."
+Type \\[decipher-make-checkpoint] to make a checkpoint."
(interactive nil decipher-mode)
(beginning-of-line)
(if (looking-at "%!\\([A-Z ]+\\)!")
@@ -524,7 +524,7 @@ Type `\\[decipher-make-checkpoint]' to make a checkpoint."
;; Move to the first checkpoint:
(goto-char (point-min))
(if (re-search-forward "^%![A-Z ]+!" nil t)
- (message "Select the checkpoint to restore and type `%s'"
+ (message "Select the checkpoint to restore and type %s"
(substitute-command-keys "\\[decipher-restore-checkpoint]"))
(error "No checkpoints in this buffer"))))
diff --git a/lisp/play/doctor.el b/lisp/play/doctor.el
index 078cbf023b3..79ddc4fc929 100644
--- a/lisp/play/doctor.el
+++ b/lisp/play/doctor.el
@@ -129,6 +129,9 @@
"C-j" #'doctor-read-print
"RET" #'doctor-ret-or-read)
+;; Actually defined in textconv.c.
+(defvar text-conversion-style)
+
(define-derived-mode doctor-mode text-mode "Doctor"
"Major mode for running the Doctor (Eliza) program.
Like Text mode with Auto Fill mode
@@ -137,6 +140,8 @@ reads the sentence before point, and prints the Doctor's answer."
:interactive nil
(doctor-make-variables)
(turn-on-auto-fill)
+ ;; Make sure RET is processed by Emacs.
+ (setq text-conversion-style 'action)
(doctor-type '(i am the psychotherapist \.
(doc$ doctor--please) (doc$ doctor--describe) your (doc$ doctor--problems) \.
each time you are finished talking\, type \R\E\T twice \.))
diff --git a/lisp/play/dunnet.el b/lisp/play/dunnet.el
index 2f699f147b3..8d9a7853242 100644
--- a/lisp/play/dunnet.el
+++ b/lisp/play/dunnet.el
@@ -1132,9 +1132,14 @@ treasures for points?" "4" "four")
;;;; Mode definitions for interactive mode
+;; Actually defined in textconv.c.
+(defvar text-conversion-style)
+
(define-derived-mode dun-mode text-mode "Dungeon"
"Major mode for running dunnet."
:interactive nil
+ ;; Make sure RET is processed by Emacs.
+ (setq text-conversion-style 'action)
(setq-local scroll-step 2))
(defun dun-parse (_arg)
diff --git a/lisp/play/gamegrid.el b/lisp/play/gamegrid.el
index c9002df1e31..a098d0f6f69 100644
--- a/lisp/play/gamegrid.el
+++ b/lisp/play/gamegrid.el
@@ -411,7 +411,9 @@ convert to an Emacs image-spec instead")
pixel-size (floor (* resy (/ point-size 72.27)))
point-size (* (/ pixel-size resy) 72.27))
(face-spec-set gamegrid-face
- `((t :height ,(floor (* point-size 10))))))))))
+ ;; With some very high resolution displays,
+ ;; point-size floored can be zero.
+ `((t :height ,(max 8 (floor (* point-size 10)))))))))))
(defun gamegrid-initialize-display ()
(setq gamegrid-display-mode (gamegrid-display-type))
diff --git a/lisp/play/handwrite.el b/lisp/play/handwrite.el
index eb95e29c206..c71dffc42ed 100644
--- a/lisp/play/handwrite.el
+++ b/lisp/play/handwrite.el
@@ -5,7 +5,7 @@
;; Author: Danny Roozendaal (was: <danny@tvs.kun.nl>)
;; Maintainer: emacs-devel@gnu.org
;; Created: October 21 1996
-;; Keywords: wp, print, postscript, cursive writing
+;; Keywords: text, print, postscript, cursive writing
;; This file is part of GNU Emacs.
diff --git a/lisp/printing.el b/lisp/printing.el
index 29e2192c963..d9bc97d48af 100644
--- a/lisp/printing.el
+++ b/lisp/printing.el
@@ -3,7 +3,7 @@
;; Copyright (C) 2000-2024 Free Software Foundation, Inc.
;; Author: Vinicius Jose Latorre <viniciusjl.gnu@gmail.com>
-;; Keywords: wp, print, PostScript
+;; Keywords: text, print, PostScript
;; Old-Version: 6.9.3
;; URL: https://www.emacswiki.org/cgi-bin/wiki/ViniciusJoseLatorre
@@ -1148,8 +1148,7 @@ Used by `pr-menu-bind' and `pr-update-menus'.")
(defun pr-menu-get-item (name-list)
;; NAME-LIST is a string or a list of strings.
- (or (listp name-list)
- (setq name-list (list name-list)))
+ (setq name-list (ensure-list name-list))
(and name-list
(let* ((reversed (reverse name-list))
(name (easy-menu-intern (car reversed)))
diff --git a/lisp/proced.el b/lisp/proced.el
index d87c295b296..1d257b6bd4d 100644
--- a/lisp/proced.el
+++ b/lisp/proced.el
@@ -152,7 +152,7 @@ the external command (usually \"kill\")."
(pri "Pr" "%d" right proced-< t (pri pid) (nil t t))
(nice "Ni" "%3d" 3 proced-< t (nice pid) (t t nil))
(thcount "THCount" "%d" right proced-< t (thcount pid) (nil t t))
- (start "Start" proced-format-start 6 proced-time-lessp nil (start pid)
+ (start "Start" proced-format-start left proced-time-lessp nil (start pid)
(t t nil))
(vsize "VSize" proced-format-memory right proced-< t (vsize pid)
(nil t t))
@@ -362,9 +362,13 @@ of `proced-grammar-alist'."
:type 'integer)
(defcustom proced-auto-update-flag nil
- "Non-nil for auto update of a Proced buffer.
-Can be changed interactively via `proced-toggle-auto-update'."
- :type 'boolean)
+ "Non-nil means auto update proced buffers.
+Special value `visible' means only update proced buffers that are currently
+displayed in a window. Can be changed interactively via
+`proced-toggle-auto-update'."
+ :type '(radio (const :tag "Don't auto update" nil)
+ (const :tag "Only update visible proced buffers" visible)
+ (const :tag "Update all proced buffers" t)))
(make-variable-buffer-local 'proced-auto-update-flag)
(defcustom proced-tree-flag nil
@@ -656,6 +660,14 @@ Important: the match ends just after the marker.")
)
(put 'proced-mark :advertised-binding "m")
+(defvar-local proced-refinements nil
+ "Information about the current buffer refinements.
+
+It should be a list of elements of the form (REFINER PID KEY GRAMMAR), where
+REFINER and GRAMMAR are as described in `proced-grammar-alist', PID is the
+process ID of the process used to create the refinement, and KEY the attribute
+of the process. A value of nil indicates that there are no active refinements.")
+
(easy-menu-define proced-menu proced-mode-map
"Proced Menu."
`("Proced"
@@ -768,12 +780,12 @@ Important: the match ends just after the marker.")
(while (string-match "[ \t\n]+" hl pos)
(setq pos (match-end 0))
(put-text-property (match-beginning 0) pos 'display
- `(space :align-to ,(+ pos base))
+ `(space :align-to (,(+ pos base) . width))
hl)))
(setq hl (replace-regexp-in-string ;; preserve text properties
"\\(%\\)" "\\1\\1"
hl)))
- (list (propertize " " 'display `(space :align-to ,base))
+ (list (propertize " " 'display `(space :align-to (,base . width)))
hl)))
(defun proced-pid-at-point ()
@@ -784,6 +796,52 @@ Return nil if point is not on a process line."
(if (looking-at "^. .")
(get-text-property (match-end 0) 'proced-pid))))
+(defun proced--position-info (pos)
+ "Return information of the process at POS.
+
+The returned information will have the form `(PID KEY COLUMN)' where
+PID is the process ID of the process at point, KEY is the value of the
+proced-key text property at point, and COLUMN is the column for which the
+current value of the proced-key text property starts, or 0 if KEY is nil."
+ ;; If point is on a field, we try to return point to that field.
+ ;; Otherwise we try to return to the same column
+ (save-excursion
+ (goto-char pos)
+ (let ((pid (proced-pid-at-point))
+ (key (get-text-property (point) 'proced-key)))
+ (list pid key ; can both be nil
+ (if key
+ (if (get-text-property (1- (point)) 'proced-key)
+ (- (point) (previous-single-property-change
+ (point) 'proced-key))
+ 0)
+ (current-column))))))
+
+(defun proced--determine-pos (key column)
+ "Return position of point in the current line using KEY and COLUMN.
+
+Attempt to find the first position on the current line where the
+text property proced-key is equal to KEY. If this is not possible, return
+the position of point of column COLUMN on the current line."
+ (save-excursion
+ (let (new-pos)
+ (if key
+ (let ((limit (line-end-position)) pos)
+ (while (and (not new-pos)
+ (setq pos (next-property-change (point) nil limit)))
+ (goto-char pos)
+ (when (eq key (get-text-property (point) 'proced-key))
+ (forward-char (min column (- (next-property-change (point))
+ (point))))
+ (setq new-pos (point))))
+ (unless new-pos
+ ;; we found the process, but the field of point
+ ;; is not listed anymore
+ (setq new-pos (proced-move-to-goal-column))))
+ (setq new-pos (min (+ (line-beginning-position) column)
+ (line-end-position))))
+ new-pos)))
+
;; proced mode
(define-derived-mode proced-mode special-mode "Proced"
@@ -839,6 +897,9 @@ normal hook `proced-post-display-hook'.
(setq-local revert-buffer-function #'proced-revert)
(setq-local font-lock-defaults
'(proced-font-lock-keywords t nil nil beginning-of-line))
+ (setq-local switch-to-buffer-preserve-window-point nil)
+ ;; So that the heading scales together with the body of the table.
+ (setq-local text-scale-remap-header-line t)
(if (and (not proced-auto-update-timer) proced-auto-update-interval)
(setq proced-auto-update-timer
(run-at-time t proced-auto-update-interval
@@ -894,28 +955,40 @@ Proced buffers."
"Auto-update Proced buffers using `run-at-time'.
If there are no proced buffers, cancel the timer."
- (unless (seq-filter (lambda (buf)
- (with-current-buffer buf
- (when (eq major-mode 'proced-mode)
- (if proced-auto-update-flag
- (proced-update t t))
- t)))
- (buffer-list))
+ (if-let (buffers (match-buffers '(derived-mode . proced-mode)))
+ (dolist (buf buffers)
+ (when-let ((flag (buffer-local-value 'proced-auto-update-flag buf))
+ ((or (not (eq flag 'visible))
+ (get-buffer-window buf 'visible))))
+ (with-current-buffer buf
+ (proced-update t t))))
(cancel-timer proced-auto-update-timer)
(setq proced-auto-update-timer nil)))
(defun proced-toggle-auto-update (arg)
"Change whether this Proced buffer is updated automatically.
With prefix ARG, update this buffer automatically if ARG is positive,
-otherwise do not update. Sets the variable `proced-auto-update-flag'.
-The time interval for updates is specified via `proced-auto-update-interval'."
+update the buffer only when the buffer is displayed in a window if ARG is 0,
+otherwise do not update. Sets the variable `proced-auto-update-flag' by
+cycling between nil, `visible' and t. The time interval for updates is
+specified via `proced-auto-update-interval'."
(interactive (list (or current-prefix-arg 'toggle)) proced-mode)
(setq proced-auto-update-flag
- (cond ((eq arg 'toggle) (not proced-auto-update-flag))
- (arg (> (prefix-numeric-value arg) 0))
+ (cond ((eq arg 'toggle)
+ (cond ((not proced-auto-update-flag) 'visible)
+ ((eq proced-auto-update-flag 'visible) t)
+ (t nil)))
+ (arg
+ (setq arg (prefix-numeric-value arg))
+ (message "%s" arg)
+ (cond ((> arg 0) t)
+ ((eq arg 0) 'visible)
+ (t nil)))
(t (not proced-auto-update-flag))))
(message "Proced auto update %s"
- (if proced-auto-update-flag "enabled" "disabled")))
+ (cond ((eq proced-auto-update-flag 'visible) "enabled (only when buffer is visible)")
+ (proced-auto-update-flag "enabled (unconditionally)")
+ (t "disabled"))))
;;; Mark
@@ -1337,20 +1410,7 @@ a certain refinement, consider defining a new filter in `proced-filter-alist'."
(let* ((grammar (assq key proced-grammar-alist))
(refiner (nth 7 grammar)))
(when refiner
- (cond ((functionp (car refiner))
- (setq proced-process-alist (funcall (car refiner) pid)))
- ((consp refiner)
- (let ((predicate (nth 4 grammar))
- (ref (cdr (assq key (cdr (assq pid proced-process-alist)))))
- val new-alist)
- (dolist (process proced-process-alist)
- (setq val (funcall predicate (cdr (assq key (cdr process))) ref))
- (if (cond ((not val) (nth 2 refiner))
- ((eq val 'equal) (nth 1 refiner))
- (val (car refiner)))
- (push process new-alist)))
- (setq proced-process-alist new-alist))))
- ;; Do not revert listing.
+ (add-to-list 'proced-refinements (list refiner pid key grammar) t)
(proced-update)))
(message "No refiner defined here."))))
@@ -1555,8 +1615,7 @@ Prefix ARG controls sort order, see `proced-sort-interactive'."
(format "%02d%s%02d" minutes colon seconds)))))
(defun proced-format-start (start)
- "Format time START.
-The return string is always 6 characters wide."
+ "Format time START."
(let ((d-start (decode-time start))
(d-current (decode-time))
(colon (if proced-enable-color-flag
@@ -1859,10 +1918,29 @@ After updating a displayed Proced buffer run the normal hook
"Updating process display...")))
(if revert ;; evaluate all processes
(setq proced-process-alist (proced-process-attributes)))
- ;; filtering and sorting
+ ;; filtering
+ (setq proced-process-alist (proced-filter proced-process-alist proced-filter))
+ ;; refinements
+ (pcase-dolist (`(,refiner ,pid ,key ,grammar) proced-refinements)
+ ;; It's possible the process has exited since the refinement was made
+ (when (assq pid proced-process-alist)
+ (cond ((functionp (car refiner))
+ (setq proced-process-alist (funcall (car refiner) pid)))
+ ((consp refiner)
+ (let ((predicate (nth 4 grammar))
+ (ref (cdr (assq key (cdr (assq pid proced-process-alist)))))
+ val new-alist)
+ (dolist (process proced-process-alist)
+ (setq val (funcall predicate (cdr (assq key (cdr process))) ref))
+ (when (cond ((not val) (nth 2 refiner))
+ ((eq val 'equal) (nth 1 refiner))
+ (val (car refiner)))
+ (push process new-alist)))
+ (setq proced-process-alist new-alist))))))
+
+ ;; sorting
(setq proced-process-alist
- (proced-sort (proced-filter proced-process-alist proced-filter)
- proced-sort proced-descend))
+ (proced-sort proced-process-alist proced-sort proced-descend))
;; display as process tree?
(setq proced-process-alist
@@ -1875,17 +1953,10 @@ After updating a displayed Proced buffer run the normal hook
(if (consp buffer-undo-list)
(setq buffer-undo-list nil))
(let ((buffer-undo-list t)
- ;; If point is on a field, we try to return point to that field.
- ;; Otherwise we try to return to the same column
- (old-pos (let ((pid (proced-pid-at-point))
- (key (get-text-property (point) 'proced-key)))
- (list pid key ; can both be nil
- (if key
- (if (get-text-property (1- (point)) 'proced-key)
- (- (point) (previous-single-property-change
- (point) 'proced-key))
- 0)
- (current-column)))))
+ (window-pos-infos
+ (mapcar (lambda (w) `(,w . ,(proced--position-info (window-point w))))
+ (get-buffer-window-list (current-buffer) nil t)))
+ (old-pos (proced--position-info (point)))
buffer-read-only mp-list)
;; remember marked processes (whatever the mark was)
(goto-char (point-min))
@@ -1918,7 +1989,8 @@ After updating a displayed Proced buffer run the normal hook
;; Sometimes this puts point in the middle of the proced buffer
;; where it is not interesting. Is there a better / more flexible solution?
(goto-char (point-min))
- (let (pid mark new-pos)
+
+ (let (pid mark new-pos win-points)
(if (or mp-list (car old-pos))
(while (not (eobp))
(setq pid (proced-pid-at-point))
@@ -1927,28 +1999,25 @@ After updating a displayed Proced buffer run the normal hook
(delete-char 1)
(beginning-of-line))
(when (eq (car old-pos) pid)
- (if (nth 1 old-pos)
- (let ((limit (line-end-position)) pos)
- (while (and (not new-pos)
- (setq pos (next-property-change (point) nil limit)))
- (goto-char pos)
- (when (eq (nth 1 old-pos)
- (get-text-property (point) 'proced-key))
- (forward-char (min (nth 2 old-pos)
- (- (next-property-change (point))
- (point))))
- (setq new-pos (point))))
- (unless new-pos
- ;; we found the process, but the field of point
- ;; is not listed anymore
- (setq new-pos (proced-move-to-goal-column))))
- (setq new-pos (min (+ (line-beginning-position) (nth 2 old-pos))
- (line-end-position)))))
+ (setq new-pos (proced--determine-pos (nth 1 old-pos)
+ (nth 2 old-pos))))
+ (mapc (lambda (w-pos)
+ (when (eq (cadr w-pos) pid)
+ (push `(,(car w-pos) . ,(proced--determine-pos
+ (nth 1 (cdr w-pos))
+ (nth 2 (cdr w-pos))))
+ win-points)))
+ window-pos-infos)
(forward-line)))
- (if new-pos
- (goto-char new-pos)
- (goto-char (point-min))
- (proced-move-to-goal-column)))
+ (let ((fallback (save-excursion (goto-char (point-min))
+ (proced-move-to-goal-column)
+ (point))))
+ (goto-char (or new-pos fallback))
+ ;; Update window points
+ (mapc (lambda (w-pos)
+ (set-window-point (car w-pos)
+ (alist-get (car w-pos) win-points fallback)))
+ window-pos-infos)))
;; update mode line
;; Does the long `mode-name' clutter the mode line? It would be nice
;; to have some other location for displaying the values of the various
@@ -1976,7 +2045,9 @@ After updating a displayed Proced buffer run the normal hook
(defun proced-revert (&rest _args)
"Reevaluate the process listing based on the currently running processes.
-Preserves point and marks."
+Preserves point and marks, but not refinements (see `proced-refine' for
+information on refinements)."
+ (setq proced-refinements nil)
(proced-update t))
(defun proced-marked-processes ()
@@ -2206,7 +2277,7 @@ If LOG is a string and there are more args, it is formatted with
those ARGS. Usually the LOG string ends with a \\n.
End each bunch of errors with (proced-log t signal):
this inserts the current time, buffer and signal at the start of the page,
-and \f (formfeed) at the end."
+and \\f (formfeed) at the end."
(let ((obuf (current-buffer)))
(with-current-buffer (get-buffer-create proced-log-buffer)
(goto-char (point-max))
diff --git a/lisp/profiler.el b/lisp/profiler.el
index 80f84037a63..4e02cd1d890 100644
--- a/lisp/profiler.el
+++ b/lisp/profiler.el
@@ -38,8 +38,7 @@
(defcustom profiler-sampling-interval 1000000
"Default sampling interval in nanoseconds."
- :type 'natnum
- :group 'profiler)
+ :type 'natnum)
;;; Utilities
@@ -68,7 +67,7 @@
collect c into s
do (cl-decf i)
finally return
- (apply 'string (if (eq (car s) ?,) (cdr s) s)))
+ (apply #'string (if (eq (car s) ?,) (cdr s) s)))
(profiler-ensure-string number)))
(defun profiler-format (fmt &rest args)
@@ -76,7 +75,7 @@
for arg in args
for str = (cond
((consp subfmt)
- (apply 'profiler-format subfmt arg))
+ (apply #'profiler-format subfmt arg))
((stringp subfmt)
(format subfmt arg))
((and (symbolp subfmt)
@@ -91,7 +90,8 @@
if (< width len)
collect (progn (put-text-property (max 0 (- width 2)) len
'invisible 'profiler str)
- str) into frags
+ str)
+ into frags
else
collect
(let ((padding (make-string (max 0 (- width len)) ?\s)))
@@ -100,32 +100,11 @@
(right (concat padding str))))
into frags
finally return (apply #'concat frags)))
-
-
-;;; Entries
-
-(defun profiler-format-entry (entry)
- "Format ENTRY in human readable string.
-ENTRY would be a function name of a function itself."
- (cond ((memq (car-safe entry) '(closure lambda))
- (format "#<lambda %#x>" (sxhash entry)))
- ((byte-code-function-p entry)
- (format "#<compiled %#x>" (sxhash entry)))
- ((or (subrp entry) (symbolp entry) (stringp entry))
- (format "%s" entry))
- (t
- (format "#<unknown %#x>" (sxhash entry)))))
-
-(defun profiler-fixup-entry (entry)
- (if (symbolp entry)
- entry
- (profiler-format-entry entry)))
-
;;; Backtraces
(defun profiler-fixup-backtrace (backtrace)
- (apply 'vector (mapcar 'profiler-fixup-entry backtrace)))
+ (apply #'vector (mapcar #'help-fns-function-name backtrace)))
;;; Logs
@@ -434,18 +413,15 @@ Optional argument MODE means only check for the specified mode (cpu or mem)."
(defcustom profiler-report-closed-mark "+"
"An indicator of closed calltrees."
- :type 'string
- :group 'profiler)
+ :type 'string)
(defcustom profiler-report-open-mark "-"
"An indicator of open calltrees."
- :type 'string
- :group 'profiler)
+ :type 'string)
(defcustom profiler-report-leaf-mark " "
"An indicator of calltree leaves."
- :type 'string
- :group 'profiler)
+ :type 'string)
(defvar profiler-report-cpu-line-format
'((17 right ((12 right)
@@ -474,17 +450,18 @@ Do not touch this variable directly.")
(let ((string (cond
((eq entry t)
"Others")
- ((and (symbolp entry)
- (fboundp entry))
- (propertize (symbol-name entry)
- 'face 'link
- 'follow-link "\r"
- 'mouse-face 'highlight
- 'help-echo "\
+ (t (propertize (help-fns-function-name entry)
+ ;; Override the `button-map' which
+ ;; otherwise adds RET, mouse-1, and TAB
+ ;; bindings we don't want. :-(
+ 'keymap '(make-sparse-keymap)
+ 'follow-link "\r"
+ ;; FIXME: The help-echo code gets confused
+ ;; by the `follow-link' property and rewrites
+ ;; `mouse-2' to `mouse-1' :-(
+ 'help-echo "\
mouse-2: jump to definition\n\
-RET: expand or collapse"))
- (t
- (profiler-format-entry entry)))))
+RET: expand or collapse")))))
(propertize string 'profiler-entry entry)))
(defun profiler-report-make-name-part (tree)
@@ -719,10 +696,13 @@ point."
(current-buffer))
(and event (setq event (event-end event))
(posn-set-point event))
- (let ((tree (profiler-report-calltree-at-point)))
- (when tree
- (let ((entry (profiler-calltree-entry tree)))
- (find-function entry))))))
+ (save-excursion
+ (forward-line 0)
+ (let ((eol (pos-eol)))
+ (forward-button 1)
+ (if (> (point) eol)
+ (error "No entry found")
+ (push-button))))))
(defun profiler-report-describe-entry ()
"Describe entry at point."
diff --git a/lisp/progmodes/antlr-mode.el b/lisp/progmodes/antlr-mode.el
index f90dcf9f8b9..1364214329a 100644
--- a/lisp/progmodes/antlr-mode.el
+++ b/lisp/progmodes/antlr-mode.el
@@ -2147,7 +2147,7 @@ command `antlr-show-makefile-rules' for detail."
(antlr-makefile-insert-variable i " $(" ")"))
(insert "\n" (car antlr-makefile-specification))))
(if (string-equal (car antlr-makefile-specification) "\n")
- (backward-delete-char 1))
+ (delete-char -1))
(when with-error
(goto-char (point-min))
(insert antlr-help-unknown-file-text))
diff --git a/lisp/progmodes/asm-mode.el b/lisp/progmodes/asm-mode.el
index 5b8a0567066..d47c525c5f9 100644
--- a/lisp/progmodes/asm-mode.el
+++ b/lisp/progmodes/asm-mode.el
@@ -2,7 +2,7 @@
;; Copyright (C) 1991, 2001-2024 Free Software Foundation, Inc.
-;; Author: Eric S. Raymond <esr@snark.thyrsus.com>
+;; Author: Eric S. Raymond <esr@thyrsus.com>
;; Maintainer: emacs-devel@gnu.org
;; Keywords: languages
@@ -23,7 +23,7 @@
;;; Commentary:
-;; This mode was written by Eric S. Raymond <esr@snark.thyrsus.com>,
+;; This mode was written by Eric S. Raymond <esr@thyrsus.com>,
;; inspired by an earlier `asm-mode' by Martin Neitzel.
;; This major mode is based on `prog-mode'. It defines a private
@@ -52,9 +52,13 @@
:link '(custom-group-link :tag "Font Lock Faces group" font-lock-faces)
:group 'languages)
+(defun asm--safe-comment-char-p (char)
+ (memq char '(?\; ?# ?@)))
+
(defcustom asm-comment-char ?\;
"The `comment-start' character assumed by Asm mode."
- :type 'character)
+ :type 'character
+ :safe #'asm--safe-comment-char-p)
(defvar asm-mode-syntax-table
(let ((st (make-syntax-table)))
diff --git a/lisp/progmodes/bug-reference.el b/lisp/progmodes/bug-reference.el
index 3955f35db85..977a3d72cb7 100644
--- a/lisp/progmodes/bug-reference.el
+++ b/lisp/progmodes/bug-reference.el
@@ -35,6 +35,8 @@
;;; Code:
+(require 'thingatpt)
+
(defgroup bug-reference nil
"Hyperlinking references to bug reports."
;; Somewhat arbitrary, by analogy with eg goto-address.
@@ -465,10 +467,10 @@ and set it if applicable."
(defun bug-reference--try-setup-gnus-article ()
(when (and bug-reference-mode ;; Only if enabled in article buffers.
(derived-mode-p
- 'gnus-article-mode
- ;; Apparently, gnus-article-prepare-hook is run in the
- ;; summary buffer...
- 'gnus-summary-mode)
+ '(gnus-article-mode
+ ;; Apparently, `gnus-article-prepare-hook' is run in the
+ ;; summary buffer...
+ gnus-summary-mode))
gnus-article-buffer
gnus-original-article-buffer
(buffer-live-p (get-buffer gnus-article-buffer))
@@ -491,7 +493,7 @@ and set it if applicable."
;; the values of the From, To, and Cc headers.
(let (header-values)
(with-current-buffer
- (get-buffer gnus-original-article-buffer)
+ gnus-original-article-buffer
(save-excursion
(goto-char (point-min))
;; The Newsgroup is omitted because we already matched
@@ -654,17 +656,31 @@ have been run, the auto-setup is inhibited.")
(run-hook-with-args-until-success
'bug-reference-auto-setup-functions)))))
-;;;###autoload
-(define-minor-mode bug-reference-mode
- "Toggle hyperlinking bug references in the buffer (Bug Reference mode)."
- :after-hook (bug-reference--run-auto-setup)
- (if bug-reference-mode
- (jit-lock-register #'bug-reference-fontify)
+(defun bug-reference--url-at-point ()
+ "`thing-at-point' provider function."
+ (get-char-property (point) 'bug-reference-url))
+
+(defun bug-reference--init (enable)
+ (if enable
+ (progn
+ (jit-lock-register #'bug-reference-fontify)
+ (setq-local thing-at-point-provider-alist
+ (append thing-at-point-provider-alist
+ '((url . bug-reference--url-at-point)))))
(jit-lock-unregister #'bug-reference-fontify)
+ (setq thing-at-point-provider-alist
+ (delete '((url . bug-reference--url-at-point))
+ thing-at-point-provider-alist))
(save-restriction
(widen)
(bug-reference-unfontify (point-min) (point-max)))))
+;;;###autoload
+(define-minor-mode bug-reference-mode
+ "Toggle hyperlinking bug references in the buffer (Bug Reference mode)."
+ :after-hook (bug-reference--run-auto-setup)
+ (bug-reference--init bug-reference-mode))
+
(defun bug-reference-mode-force-auto-setup ()
"Enable `bug-reference-mode' and force auto-setup.
Enabling `bug-reference-mode' runs its auto-setup only if
@@ -681,12 +697,7 @@ same buffer is re-used for different contexts."
(define-minor-mode bug-reference-prog-mode
"Like `bug-reference-mode', but only buttonize in comments and strings."
:after-hook (bug-reference--run-auto-setup)
- (if bug-reference-prog-mode
- (jit-lock-register #'bug-reference-fontify)
- (jit-lock-unregister #'bug-reference-fontify)
- (save-restriction
- (widen)
- (bug-reference-unfontify (point-min) (point-max)))))
+ (bug-reference--init bug-reference-prog-mode))
(provide 'bug-reference)
;;; bug-reference.el ends here
diff --git a/lisp/progmodes/c-ts-common.el b/lisp/progmodes/c-ts-common.el
index 07161025d5d..e48bcc64f14 100644
--- a/lisp/progmodes/c-ts-common.el
+++ b/lisp/progmodes/c-ts-common.el
@@ -37,9 +37,8 @@
;;
;; For indenting statements:
;;
-;; - Set `c-ts-common-indent-offset',
-;; `c-ts-common-indent-block-type-regexp', and
-;; `c-ts-common-indent-bracketless-type-regexp', then use simple-indent
+;; - Set `c-ts-common-indent-offset', and
+;; `c-ts-common-indent-type-regexp-alist', then use simple-indent
;; offset `c-ts-common-statement-offset' in
;; `treesit-simple-indent-rules'.
@@ -331,9 +330,9 @@ If NODE is nil, return nil."
Assumes the anchor is (point-min), i.e., the 0th column.
This function basically counts the number of block nodes (i.e.,
-brackets) (defined by `c-ts-common-indent-block-type-regexp')
+brackets) (see `c-ts-common-indent-type-regexp-alist')
between NODE and the root node (not counting NODE itself), and
-multiply that by `c-ts-common-indent-offset'.
+multiplies that by `c-ts-common-indent-offset'.
To support GNU style, on each block level, this function also
checks whether the opening bracket { is on its own line, if so,
diff --git a/lisp/progmodes/c-ts-mode.el b/lisp/progmodes/c-ts-mode.el
index e69856baecc..3a89f0f494b 100644
--- a/lisp/progmodes/c-ts-mode.el
+++ b/lisp/progmodes/c-ts-mode.el
@@ -71,6 +71,8 @@
(eval-when-compile (require 'rx))
(declare-function treesit-parser-create "treesit.c")
+(declare-function treesit-parser-root-node "treesit.c")
+(declare-function treesit-parser-set-included-ranges "treesit.c")
(declare-function treesit-node-parent "treesit.c")
(declare-function treesit-node-start "treesit.c")
(declare-function treesit-node-end "treesit.c")
@@ -80,7 +82,6 @@
(declare-function treesit-node-prev-sibling "treesit.c")
(declare-function treesit-node-first-child-for-pos "treesit.c")
(declare-function treesit-node-next-sibling "treesit.c")
-(declare-function treesit-parser-set-included-ranges "treesit.c")
(declare-function treesit-query-compile "treesit.c")
;;; Custom variables
@@ -96,7 +97,7 @@
"Toggle the comment style between block and line comments.
Optional numeric ARG, if supplied, switches to block comment
style when positive, to line comment style when negative, and
-just toggles it when zero or left out."
+just toggles it when zero or omitted."
(interactive "P")
(let ((prevstate-line (string= comment-start "// ")))
(when (or (not arg)
@@ -134,7 +135,7 @@ symbol."
res)
(let ((buffer (car buffers)))
(with-current-buffer buffer
- (if (derived-mode-p 'c-ts-mode 'c++-ts-mode)
+ (if (derived-mode-p '(c-ts-mode c++-ts-mode))
(loop (append res (list buffer)) (cdr buffers))
(loop res (cdr buffers))))))))
@@ -146,9 +147,9 @@ symbol."
"Style used for indentation.
The selected style could be one of GNU, K&R, LINUX or BSD. If
-one of the supplied styles doesn't suffice, a function could be
-set instead. This function is expected to return a list that
-follows the form of `treesit-simple-indent-rules'."
+one of the supplied styles doesn't suffice, the value could be
+a function instead. This function is expected to return a list
+that follows the form of `treesit-simple-indent-rules'."
:version "29.1"
:type '(choice (symbol :tag "Gnu" gnu)
(symbol :tag "K&R" k&r)
@@ -192,7 +193,7 @@ in this Emacs session."
To set the default indent style globally, use
`c-ts-mode-set-global-style'."
(interactive (list (c-ts-mode--prompt-for-style)))
- (if (not (derived-mode-p 'c-ts-mode 'c++-ts-mode))
+ (if (not (derived-mode-p '(c-ts-mode c++-ts-mode)))
(user-error "The current buffer is not in `c-ts-mode' nor `c++-ts-mode'")
(setq-local c-ts-mode-indent-style style)
(setq treesit-simple-indent-rules
@@ -201,8 +202,8 @@ To set the default indent style globally, use
(if (derived-mode-p 'c-ts-mode) 'c 'cpp))))))
(defcustom c-ts-mode-emacs-sources-support t
- "Whether to enable Emacs source-specific features.
-This enables detection of definitions of Lisp function using
+ "Whether to enable Emacs source-specific C features.
+This enables detection of definitions of Lisp functions via
the DEFUN macro.
This needs to be set before enabling `c-ts-mode'; if you change
the value after enabling `c-ts-mode', toggle the mode off and on
@@ -242,7 +243,7 @@ again."
< and > are usually punctuation, e.g., in ->. But when used for
templates, they should be considered pairs.
-This function checks for < and > in the changed RANGES and apply
+This function checks for < and > in the changed RANGES and applies
appropriate text property to alter the syntax of template
delimiters < and >'s."
(goto-char beg)
@@ -283,9 +284,9 @@ is actually the parent of point at the moment of indentation."
"Return the start of the previous named sibling of NODE.
This anchor handles the special case where the previous sibling
-is a labeled_statement, in that case, return the child of the
+is a labeled_statement; in that case, return the child of the
labeled statement instead. (Actually, recursively go down until
-the node isn't a labeled_statement.) Eg,
+the node isn't a labeled_statement.) E.g.,
label:
int x = 1;
@@ -294,10 +295,11 @@ label:
The anchor of \"int y = 2;\" should be \"int x = 1;\" rather than
the labeled_statement.
-Return nil if a) there is no prev-sibling, or 2) prev-sibling
+Return nil if a) there is no prev-sibling, or b) prev-sibling
doesn't have a child.
-PARENT and BOL are like other anchor functions."
+PARENT is NODE's parent, BOL is the beginning of non-whitespace
+characters of the current line."
(when-let ((prev-sibling
(or (treesit-node-prev-sibling node t)
(treesit-node-prev-sibling
@@ -335,7 +337,7 @@ PARENT and BOL are like other anchor functions."
(defun c-ts-mode--standalone-parent-skip-preproc (_n parent &rest _)
"Like the standalone-parent anchor but skips preproc nodes.
-PARENT is the same as other anchor functions."
+PARENT is the parent of the current node."
(save-excursion
(treesit-node-start
(treesit-parent-until
@@ -343,7 +345,7 @@ PARENT is the same as other anchor functions."
;; nil.
parent (lambda (node)
(and node
- (not (string-match "preproc" (treesit-node-type node)))
+ (not (string-search "preproc" (treesit-node-type node)))
(progn
(goto-char (treesit-node-start node))
(looking-back (rx bol (* whitespace))
@@ -352,13 +354,15 @@ PARENT is the same as other anchor functions."
(defun c-ts-mode--standalone-grandparent (_node parent bol &rest args)
"Like the standalone-parent anchor but pass it the grandparent.
-PARENT, BOL, ARGS are the same as other anchor functions."
+PARENT is NODE's parent, BOL is the beginning of non-whitespace
+characters of the current line."
(apply (alist-get 'standalone-parent treesit-simple-indent-presets)
parent (treesit-node-parent parent) bol args))
(defun c-ts-mode--else-heuristic (node parent bol &rest _)
"Heuristic matcher for when \"else\" is followed by a closing bracket.
-NODE, PARENT, and BOL are the same as in other matchers."
+PARENT is NODE's parent, BOL is the beginning of non-whitespace
+characters of the current line."
(and (null node)
(save-excursion
(forward-line -1)
@@ -534,6 +538,13 @@ NODE should be a labeled_statement. PARENT is its parent."
;;; Font-lock
+(defvar c-ts-mode--feature-list
+ '(( comment definition)
+ ( keyword preprocessor string type)
+ ( assignment constant escape-sequence label literal)
+ ( bracket delimiter error function operator property variable))
+ "`treesit-font-lock-feature-list' for `c-ts-mode'.")
+
(defvar c-ts-mode--preproc-keywords
'("#define" "#if" "#ifdef" "#ifndef"
"#else" "#elif" "#endif" "#include")
@@ -749,7 +760,7 @@ MODE is either `c' or `cpp'."
(defun c-ts-mode--declarator-identifier (node &optional qualified)
"Return the identifier of the declarator node NODE.
-If QUALIFIED is non-nil, include the names space part of the
+If QUALIFIED is non-nil, include the namespace part of the
identifier and return a qualified_identifier."
(pcase (treesit-node-type node)
;; Recurse.
@@ -774,7 +785,7 @@ identifier and return a qualified_identifier."
node)))
(defun c-ts-mode--fontify-declarator (node override start end &rest _args)
- "Fontify a declarator (whatever under the \"declarator\" field).
+ "Fontify a declarator (whatever is under the \"declarator\" field).
For NODE, OVERRIDE, START, END, and ARGS, see
`treesit-font-lock-rules'."
(let* ((identifier (c-ts-mode--declarator-identifier node))
@@ -809,7 +820,7 @@ For NODE, OVERRIDE, START, END, and ARGS, see
(defun c-ts-mode--fontify-variable (node override start end &rest _)
"Fontify an identifier node if it is a variable.
-Don't fontify if it is a function identifier. For NODE,
+Don't fontify it if it is a function identifier. For NODE,
OVERRIDE, START, END, and ARGS, see `treesit-font-lock-rules'."
(when (not (equal (treesit-node-type
(treesit-node-parent node))
@@ -903,7 +914,8 @@ Return nil if NODE is not a defun node or doesn't have a name."
t))
((or "struct_specifier" "enum_specifier"
"union_specifier" "class_specifier"
- "namespace_definition")
+ "namespace_definition"
+ "preproc_def" "preproc_function_def")
(treesit-node-child-by-field-name node "name"))
;; DEFUNs in Emacs sources.
("expression_statement"
@@ -914,11 +926,22 @@ Return nil if NODE is not a defun node or doesn't have a name."
name)))
t))
+;;; Outline minor mode
+
+(defun c-ts-mode--outline-predicate (node)
+ "Match outlines on lines with function names."
+ (or (and (equal (treesit-node-type node) "function_declarator")
+ (equal (treesit-node-type (treesit-node-parent node))
+ "function_definition"))
+ ;; DEFUNs in Emacs sources.
+ (and c-ts-mode-emacs-sources-support
+ (c-ts-mode--emacs-defun-p node))))
+
;;; Defun navigation
(defun c-ts-mode--defun-valid-p (node)
"Return non-nil if NODE is a valid defun node.
-Ie, NODE is not nested."
+That is, NODE is not nested."
(let ((top-level-p (lambda (node)
(not (treesit-node-top-level
node (rx (or "function_definition"
@@ -957,8 +980,7 @@ Basically, if NODE is a class, return non-nil; if NODE is a
function but is under a class, return non-nil; if NODE is a
top-level function, return nil.
-This is for the Class subindex in
-`treesit-simple-imenu-settings'."
+This is for the Class subindex in `treesit-simple-imenu-settings'."
(pcase (treesit-node-type node)
;; The Class subindex only has class_specifier and
;; function_definition.
@@ -969,7 +991,7 @@ This is for the Class subindex in
(defun c-ts-mode--defun-skipper ()
"Custom defun skipper for `c-ts-mode' and friends.
-Structs in C ends with a semicolon, but the semicolon is not
+Structs in C end with a semicolon, but the semicolon is not
considered part of the struct node, so point would stop before
the semicolon. This function skips the semicolon."
(when (looking-at (rx (* (or " " "\t")) ";"))
@@ -989,7 +1011,7 @@ the semicolon. This function skips the semicolon."
(list node parent bol)))
(defun c-ts-mode--emacs-defun-p (node)
- "Return non-nil if NODE is a Lisp function defined using DEFUN.
+ "Return non-nil if NODE is a Lisp function defined via DEFUN.
This function detects Lisp primitives defined in Emacs source
files using the DEFUN macro."
(and (equal (treesit-node-type node) "expression_statement")
@@ -1010,15 +1032,15 @@ files using the DEFUN macro."
"Return the defun node at point.
In addition to regular C functions, this function recognizes
-definitions of Lisp primitrives in Emacs source files using DEFUN,
-if `c-ts-mode-emacs-sources-support' is non-nil.
+definitions of Lisp primitrives in Emacs source files defined
+via DEFUN, if `c-ts-mode-emacs-sources-support' is non-nil.
Note that DEFUN is parsed by tree-sitter as two separate
nodes, one for the declaration and one for the body; this
function returns the declaration node.
If RANGE is non-nil, return (BEG . END) where BEG end END
-encloses the whole defun. This is for when the entire defun
+enclose the whole defun. This is for when the entire defun
is required, not just the declaration part for DEFUN."
(when-let* ((node (treesit-defun-at-point))
(defun-range (cons (treesit-node-start node)
@@ -1047,22 +1069,51 @@ is required, not just the declaration part for DEFUN."
"Return the name of the current defun.
This is used for `add-log-current-defun-function'.
In addition to regular C functions, this function also recognizes
-Emacs primitives defined using DEFUN in Emacs sources,
+Emacs primitives defined via DEFUN in Emacs sources,
if `c-ts-mode-emacs-sources-support' is non-nil."
(or (treesit-add-log-current-defun)
(c-ts-mode--defun-name (c-ts-mode--emacs-defun-at-point))))
+;;; Things
+
+(defvar c-ts-mode--thing-settings
+ `(;; It's more useful to include semicolons as sexp so
+ ;; that users can move to the end of a statement.
+ (sexp (not ,(rx (or "{" "}" "[" "]" "(" ")" ","))))
+ ;; compound_statement makes us jump over too big units
+ ;; of code, so skip that one, and include the other
+ ;; statements.
+ (sentence
+ ,(regexp-opt '("preproc"
+ "declaration"
+ "specifier"
+ "attributed_statement"
+ "labeled_statement"
+ "expression_statement"
+ "if_statement"
+ "switch_statement"
+ "do_statement"
+ "while_statement"
+ "for_statement"
+ "return_statement"
+ "break_statement"
+ "continue_statement"
+ "goto_statement"
+ "case_statement")))
+ (text ,(regexp-opt '("comment"
+ "raw_string_literal"))))
+ "`treesit-thing-settings' for both C and C++.")
+
;;; Support for FOR_EACH_* macros
;;
;; FOR_EACH_TAIL, FOR_EACH_TAIL_SAFE, FOR_EACH_FRAME etc., followed by
;; an unbracketed body will mess up the parser, which parses the thing
;; as a function declaration. We "fix" it by adding a shadow parser
-;; for a language 'emacs-c' (which is just 'c' but under a different
-;; name). We use 'emacs-c' to find each FOR_EACH_* macro with a
-;; unbracketed body, and set the ranges of the C parser so that it
-;; skips those FOR_EACH_*'s. Note that we only ignore FOR_EACH_*'s
-;; with a unbracketed body. Those with a bracketed body parse more
-;; or less fine.
+;; with the tag `for-each'. We use this parser to find each
+;; FOR_EACH_* macro with a unbracketed body, and set the ranges of the
+;; default C parser so that it skips those FOR_EACH_*'s. Note that we
+;; only ignore FOR_EACH_*'s with a unbracketed body. Those with a
+;; bracketed body parse more or less fine.
;;
;; In the meantime, we have a special fontification rule for
;; FOR_EACH_* macros with a bracketed body that removes any applied
@@ -1083,12 +1134,12 @@ For BOL see `treesit-simple-indent-rules'."
(defvar c-ts-mode--emacs-c-range-query
(when (treesit-available-p)
(treesit-query-compile
- 'emacs-c `(((declaration
- type: (macro_type_specifier
- name: (identifier) @_name)
- @for-each-tail)
- (:match ,c-ts-mode--for-each-tail-regexp
- @_name)))))
+ 'c `(((declaration
+ type: (macro_type_specifier
+ name: (identifier) @_name)
+ @for-each-tail)
+ (:match ,c-ts-mode--for-each-tail-regexp
+ @_name)))))
"Query that finds a FOR_EACH_* macro with an unbracketed body.")
(defvar-local c-ts-mode--for-each-tail-ranges nil
@@ -1096,7 +1147,7 @@ For BOL see `treesit-simple-indent-rules'."
(defun c-ts-mode--reverse-ranges (ranges beg end)
"Reverse RANGES and return the new ranges between BEG and END.
-Positions that were included RANGES are not in the returned
+Positions that were included in RANGES are not in the returned
ranges, and vice versa.
Return nil if RANGES is nil. This way, passing the returned
@@ -1118,9 +1169,11 @@ parser parse the whole buffer."
"Set ranges for the C parser to skip some FOR_EACH_* macros.
BEG and END are described in `treesit-range-rules'."
(let* ((c-parser (treesit-parser-create 'c))
+ (for-each-parser (treesit-parser-create 'c nil nil 'for-each))
(old-ranges c-ts-mode--for-each-tail-ranges)
(new-ranges (treesit-query-range
- 'emacs-c c-ts-mode--emacs-c-range-query beg end))
+ (treesit-parser-root-node for-each-parser)
+ c-ts-mode--emacs-c-range-query beg end))
(set-ranges (treesit--clip-ranges
(treesit--merge-ranges
old-ranges new-ranges beg end)
@@ -1140,7 +1193,6 @@ BEG and END are described in `treesit-range-rules'."
"C-c C-c" #'comment-region
"C-c C-k" #'c-ts-mode-toggle-comment-style)
-;;;###autoload
(define-derived-mode c-ts-base-mode prog-mode "C"
"Major mode for editing C, powered by tree-sitter.
@@ -1156,7 +1208,9 @@ BEG and END are described in `treesit-range-rules'."
"enum_specifier"
"union_specifier"
"class_specifier"
- "namespace_definition")
+ "namespace_definition"
+ "preproc_def"
+ "preproc_function_def")
(and c-ts-mode-emacs-sources-support
'(;; DEFUN.
"expression_statement"
@@ -1166,6 +1220,13 @@ BEG and END are described in `treesit-range-rules'."
(setq-local treesit-defun-skipper #'c-ts-mode--defun-skipper)
(setq-local treesit-defun-name-function #'c-ts-mode--defun-name)
+ ;; IMO it makes more sense to define what's NOT sexp, since sexp by
+ ;; spirit, especially when used for movement, is like "expression"
+ ;; or "syntax unit". --yuan
+ (setq-local treesit-thing-settings
+ `((c ,@c-ts-mode--thing-settings)
+ (cpp ,@c-ts-mode--thing-settings)))
+
;; Nodes like struct/enum/union_specifier can appear in
;; function_definitions, so we need to find the top-level node.
(setq-local treesit-defun-prefer-top-level t)
@@ -1213,11 +1274,12 @@ BEG and END are described in `treesit-range-rules'."
eos)
c-ts-mode--defun-for-class-in-imenu-p nil))))
+ ;; Outline minor mode
+ (setq-local treesit-outline-predicate
+ #'c-ts-mode--outline-predicate)
+
(setq-local treesit-font-lock-feature-list
- '(( comment definition)
- ( keyword preprocessor string type)
- ( assignment constant escape-sequence label literal)
- ( bracket delimiter error function operator property variable))))
+ c-ts-mode--feature-list))
(defvar treesit-load-name-override-list)
@@ -1227,7 +1289,7 @@ BEG and END are described in `treesit-range-rules'."
This mode is independent from the classic cc-mode.el based
`c-mode', so configuration variables of that mode, like
-`c-basic-offset', doesn't affect this mode.
+`c-basic-offset', don't affect this mode.
To use tree-sitter C/C++ modes by default, evaluate
@@ -1236,21 +1298,15 @@ To use tree-sitter C/C++ modes by default, evaluate
(add-to-list \\='major-mode-remap-alist
\\='(c-or-c++-mode . c-or-c++-ts-mode))
-in your configuration."
+in your init files."
:group 'c
:after-hook (c-ts-mode-set-modeline)
(when (treesit-ready-p 'c)
- ;; Add a fake "emacs-c" language which is just C. Used for
- ;; skipping FOR_EACH_* macros, see `c-ts-mode--emacs-set-ranges'.
- (setf (alist-get 'emacs-c treesit-load-name-override-list)
- '("libtree-sitter-c" "tree_sitter_c"))
- ;; If Emacs source support is enabled, make sure emacs-c parser is
- ;; after c parser in the parser list. This way various tree-sitter
- ;; functions will automatically use the c parser rather than the
- ;; emacs-c parser.
+ ;; Create an "for-each" parser, see `c-ts-mode--emacs-set-ranges'
+ ;; for more.
(when c-ts-mode-emacs-sources-support
- (treesit-parser-create 'emacs-c))
+ (treesit-parser-create 'c nil nil 'for-each))
(treesit-parser-create 'c)
;; Comments.
@@ -1277,6 +1333,8 @@ in your configuration."
(lambda (_pos) 'c))
(treesit-font-lock-recompute-features '(emacs-devel)))))
+(derived-mode-add-parents 'c-ts-mode '(c-mode))
+
;;;###autoload
(define-derived-mode c++-ts-mode c-ts-base-mode "C++"
"Major mode for editing C++, powered by tree-sitter.
@@ -1292,7 +1350,7 @@ To use tree-sitter C/C++ modes by default, evaluate
(add-to-list \\='major-mode-remap-alist
\\='(c-or-c++-mode . c-or-c++-ts-mode))
-in your configuration.
+in your init files.
Since this mode uses a parser, unbalanced brackets might cause
some breakage in indentation/fontification. Therefore, it's
@@ -1301,13 +1359,17 @@ recommended to enable `electric-pair-mode' with this mode."
:after-hook (c-ts-mode-set-modeline)
(when (treesit-ready-p 'cpp)
+
(treesit-parser-create 'cpp)
+
;; Syntax.
(setq-local syntax-propertize-function
#'c-ts-mode--syntax-propertize)
+
;; Indent.
(setq-local treesit-simple-indent-rules
(c-ts-mode--get-indent-style 'cpp))
+
;; Font-lock.
(setq-local treesit-font-lock-settings (c-ts-mode--font-lock-settings 'cpp))
(treesit-major-mode-setup)
@@ -1316,6 +1378,8 @@ recommended to enable `electric-pair-mode' with this mode."
(setq-local add-log-current-defun-function
#'c-ts-mode--emacs-current-defun-name))))
+(derived-mode-add-parents 'c++-ts-mode '(c++-mode))
+
(easy-menu-define c-ts-mode-menu (list c-ts-mode-map c++-ts-mode-map)
"Menu for `c-ts-mode' and `c++-ts-mode'."
'("C/C++"
@@ -1361,7 +1425,7 @@ recommended to enable `electric-pair-mode' with this mode."
"\\|" id "::"
"\\|" id ws-maybe "=\\)"
"\\|" "\\(?:inline" ws "\\)?namespace"
- "\\(:?" ws "\\(?:" id "::\\)*" id "\\)?" ws-maybe "{"
+ "\\(?:" ws "\\(?:" id "::\\)*" id "\\)?" ws-maybe "{"
"\\|" "class" ws id
"\\(?:" ws "final" "\\)?" ws-maybe "[:{;\n]"
"\\|" "struct" ws id "\\(?:" ws "final" ws-maybe "[:{\n]"
@@ -1381,38 +1445,35 @@ matching on file name insufficient for detecting major mode that
should be used.
This function attempts to use file contents to determine whether
-the code is C or C++ and based on that chooses whether to enable
+the code is C or C++, and based on that chooses whether to enable
`c-ts-mode' or `c++-ts-mode'."
+ (declare (obsolete c-or-c++-mode "30.1"))
(interactive)
- (if (save-excursion
- (save-restriction
- (save-match-data ; Why `save-match-data'?
- (widen)
- (goto-char (point-min))
- (re-search-forward c-ts-mode--c-or-c++-regexp nil t))))
- (c++-ts-mode)
- (c-ts-mode)))
+ (let ((mode
+ (if (save-excursion
+ (save-restriction
+ (save-match-data ; Why `save-match-data'?
+ (widen)
+ (goto-char (point-min))
+ (re-search-forward c-ts-mode--c-or-c++-regexp nil t))))
+ 'c++-ts-mode
+ 'c-ts-mode)))
+ (funcall (major-mode-remap mode))))
+
;; The entries for C++ must come first to prevent *.c files be taken
;; as C++ on case-insensitive filesystems, since *.C files are C++,
;; not C.
(if (treesit-ready-p 'cpp)
- (add-to-list 'auto-mode-alist
- '("\\(\\.ii\\|\\.\\(CC?\\|HH?\\)\\|\\.[ch]\\(pp\\|xx\\|\\+\\+\\)\\|\\.\\(cc\\|hh\\)\\)\\'"
- . c++-ts-mode)))
+ (add-to-list 'major-mode-remap-defaults
+ '(c++-mode . c++-ts-mode)))
(when (treesit-ready-p 'c)
- (add-to-list 'auto-mode-alist
- '("\\(\\.[chi]\\|\\.lex\\|\\.y\\(acc\\)?\\)\\'" . c-ts-mode))
- (add-to-list 'auto-mode-alist '("\\.x[pb]m\\'" . c-ts-mode))
- ;; image-mode's association must be before the C mode, otherwise XPM
- ;; images will be initially visited as C files. Also note that the
- ;; regexp must be different from what files.el does, or else
- ;; add-to-list will not add the association where we want it.
- (add-to-list 'auto-mode-alist '("\\.x[pb]m\\'" . image-mode)))
-
-(if (and (treesit-ready-p 'cpp)
- (treesit-ready-p 'c))
- (add-to-list 'auto-mode-alist '("\\.h\\'" . c-or-c++-ts-mode)))
+ (add-to-list 'major-mode-remap-defaults '(c++-mode . c++-ts-mode))
+ (add-to-list 'major-mode-remap-defaults '(c-mode . c-ts-mode)))
+
+(when (and (treesit-ready-p 'cpp)
+ (treesit-ready-p 'c))
+ (add-to-list 'major-mode-remap-defaults '(c-or-c++-mode . c-or-c++-ts-mode)))
(provide 'c-ts-mode)
(provide 'c++-ts-mode)
diff --git a/lisp/progmodes/cc-align.el b/lisp/progmodes/cc-align.el
index 37e40d039cc..fbbb81b6f10 100644
--- a/lisp/progmodes/cc-align.el
+++ b/lisp/progmodes/cc-align.el
@@ -940,6 +940,16 @@ Works with: template-args-cont."
(zerop (c-forward-token-2 1 nil (c-point 'eol))))
(vector (current-column)))))
+(defun c-lineup-template-args-indented-from-margin (_langelem)
+ "Indent a template argument line `c-basic-offset' from the margin
+of the line with the containing <.
+
+Works with: template-args-cont."
+ (save-excursion
+ (goto-char (c-langelem-2nd-pos c-syntactic-element))
+ (back-to-indentation)
+ (vector (+ (current-column) c-basic-offset))))
+
(defun c-lineup-ObjC-method-call (langelem)
"Line up selector args as Emacs Lisp mode does with function args:
Go to the position right after the message receiver, and if you are at
diff --git a/lisp/progmodes/cc-awk.el b/lisp/progmodes/cc-awk.el
index 9798f397491..e299f4fa8d2 100644
--- a/lisp/progmodes/cc-awk.el
+++ b/lisp/progmodes/cc-awk.el
@@ -754,14 +754,14 @@
(if (eq (char-after beg) ?_) (setq beg (1+ beg)))
;; First put the properties on the delimiters.
- (cond ((eq end (point-max)) ; string/regexp terminated by EOB
- (c-put-char-property beg 'syntax-table '(15))) ; (15) = "string fence"
- ((/= (char-after beg) (char-after end)) ; missing end delimiter
- (c-put-char-property beg 'syntax-table '(15))
- (c-put-char-property end 'syntax-table '(15)))
- ((eq (char-after beg) ?/) ; Properly bracketed regexp
- (c-put-char-property beg 'syntax-table '(7)) ; (7) = "string"
- (c-put-char-property end 'syntax-table '(7)))
+ (cond ((eq end (point-max)) ; string/regexp terminated by EOB
+ (c-put-string-fence beg))
+ ((/= (char-after beg) (char-after end)) ; missing end delimiter
+ (c-put-string-fence beg)
+ (c-put-string-fence end))
+ ((eq (char-after beg) ?/) ; Properly bracketed regexp
+ (c-put-char-property beg 'syntax-table '(7)) ; (7) = "string"
+ (c-put-char-property end 'syntax-table '(7)))
(t)) ; Properly bracketed string: Nothing to do.
;; Now change the properties of any escaped "s in the string to punctuation.
(save-excursion
diff --git a/lisp/progmodes/cc-cmds.el b/lisp/progmodes/cc-cmds.el
index 8dc0714dacf..7cd6cb0dda0 100644
--- a/lisp/progmodes/cc-cmds.el
+++ b/lisp/progmodes/cc-cmds.el
@@ -4909,7 +4909,8 @@ If a fill prefix is specified, it overrides all the above."
(setq c-lit-limits (c-literal-limits nil nil t)))
(unless c-lit-type
(setq c-lit-type (c-literal-type c-lit-limits)))
- (if (memq (cond ((c-query-and-set-macro-start) 'cpp)
+ (if (memq (cond ((memq c-lit-type '(c c++ string)) c-lit-type)
+ ((c-query-and-set-macro-start) 'cpp)
((null c-lit-type) 'code)
(t c-lit-type))
c-ignore-auto-fill)
@@ -5145,6 +5146,41 @@ details."
(delete-char 1))))
+
+;; Text conversion support.
+
+(defun c-post-text-conversion ()
+ "Notice that the character `last-command-event' has been inserted.
+If said character is an electric character such as `*' or `{', delete
+it, then call the appropriate CC Mode function to electrically insert
+it again."
+ (cond ((eq last-command-event ?#)
+ (delete-char -1)
+ (c-electric-pound nil) t)
+ ((memq last-command-event '(?{ ?}))
+ (delete-char -1)
+ (c-electric-brace nil) t)
+ ((memq last-command-event '(?\( ?\)))
+ (delete-char -1)
+ (c-electric-paren nil) t)
+ ((eq last-command-event ?*)
+ (delete-char -1)
+ (c-electric-star nil) t)
+ ((eq last-command-event ?/)
+ (delete-char -1)
+ (c-electric-slash nil) t)
+ ((memq last-command-event '(?\; ?,))
+ (delete-char -1)
+ (c-electric-semi&comma nil) t)
+ ((eq last-command-event ?:)
+ (delete-char -1)
+ (c-electric-colon nil) t)
+ ((memq last-command-event '(?> ?<))
+ (delete-char -1)
+ (c-electric-lt-gt nil) t)))
+
+
+
(cc-provide 'cc-cmds)
;; Local Variables:
diff --git a/lisp/progmodes/cc-defs.el b/lisp/progmodes/cc-defs.el
index 8fe3d653636..e45ab76ec07 100644
--- a/lisp/progmodes/cc-defs.el
+++ b/lisp/progmodes/cc-defs.el
@@ -425,11 +425,14 @@ to it is returned. This function does not modify the point or the mark."
(defvar lookup-syntax-properties) ;XEmacs.
(defmacro c-is-escaped (pos)
- ;; Are there an odd number of backslashes before POS?
+ ;; Is the character following POS escaped?
(declare (debug t))
`(save-excursion
(goto-char ,pos)
- (not (zerop (logand (skip-chars-backward "\\\\") 1)))))
+ (if (and c-escaped-newline-takes-precedence
+ (memq (char-after) '(?\n ?\r)))
+ (eq (char-before) ?\\)
+ (not (zerop (logand (skip-chars-backward "\\\\") 1))))))
(defmacro c-will-be-escaped (pos beg end)
;; Will the character after POS be escaped after the removal of (BEG END)?
@@ -437,13 +440,23 @@ to it is returned. This function does not modify the point or the mark."
(declare (debug t))
`(save-excursion
(let ((-end- ,end)
+ (-pos- ,pos)
count)
- (goto-char ,pos)
- (setq count (skip-chars-backward "\\\\" -end-))
- (when (eq (point) -end-)
- (goto-char ,beg)
- (setq count (+ count (skip-chars-backward "\\\\"))))
- (not (zerop (logand count 1))))))
+ (if (and c-escaped-newline-takes-precedence
+ (memq (char-after -pos-) '(?\n ?\r)))
+ (eq (char-before (if (eq -pos- -end-)
+ ,beg
+ -pos-))
+ ?\\)
+ (goto-char -pos-)
+ (setq count
+ (if (> -pos- -end-)
+ (skip-chars-backward "\\\\" -end-)
+ 0))
+ (when (eq (point) -end-)
+ (goto-char ,beg)
+ (setq count (+ count (skip-chars-backward "\\\\"))))
+ (not (zerop (logand count 1)))))))
(defmacro c-will-be-unescaped (beg)
;; Would the character after BEG be unescaped?
@@ -720,9 +733,10 @@ various buffer change hooks."
(defmacro c-forward-syntactic-ws (&optional limit)
"Forward skip over syntactic whitespace.
-Syntactic whitespace is defined as whitespace characters, comments,
-and preprocessor directives. However if point starts inside a comment
-or preprocessor directive, the content of it is not treated as
+Syntactic whitespace is defined as whitespace characters with
+whitespace (or comment-end) syntax, comments, and preprocessor
+directives. However if point starts inside a comment or
+preprocessor directive, the content of it is not treated as
whitespace.
LIMIT sets an upper limit of the forward movement, if specified. If
@@ -742,9 +756,10 @@ comment at the start of cc-engine.el for more info."
(defmacro c-backward-syntactic-ws (&optional limit)
"Backward skip over syntactic whitespace.
-Syntactic whitespace is defined as whitespace characters, comments,
-and preprocessor directives. However if point starts inside a comment
-or preprocessor directive, the content of it is not treated as
+Syntactic whitespace is defined as whitespace characters with
+whitespace (or comment-end) syntax, comments, and preprocessor
+directives. However if point starts inside a comment or
+preprocessor directive, the content of it is not treated as
whitespace.
LIMIT sets a lower limit of the backward movement, if specified. If
@@ -912,7 +927,8 @@ be after it."
(when dest (goto-char dest) t)))
(defmacro c-beginning-of-defun-1 ()
- ;; Wrapper around beginning-of-defun.
+ ;; Wrapper around beginning-of-defun. Note that the return value from this
+ ;; macro has no significance.
;;
;; NOTE: This function should contain the only explicit use of
;; beginning-of-defun in CC Mode. Eventually something better than
@@ -925,44 +941,49 @@ be after it."
;; `c-parse-state'.
`(progn
- (if (and ,(fboundp 'buffer-syntactic-context-depth)
- c-enable-xemacs-performance-kludge-p)
- ,(when (fboundp 'buffer-syntactic-context-depth)
- ;; XEmacs only. This can improve the performance of
- ;; c-parse-state to between 3 and 60 times faster when
- ;; braces are hung. It can also degrade performance by
- ;; about as much when braces are not hung.
- '(let (beginning-of-defun-function end-of-defun-function
- pos)
- (while (not pos)
- (save-restriction
- (widen)
- (setq pos (c-safe-scan-lists
- (point) -1 (buffer-syntactic-context-depth))))
- (cond
- ((bobp) (setq pos (point-min)))
- ((not pos)
- (let ((distance (skip-chars-backward "^{")))
- ;; unbalanced parenthesis, while invalid C code,
- ;; shouldn't cause an infloop! See unbal.c
- (when (zerop distance)
- ;; Punt!
- (beginning-of-defun)
- (setq pos (point)))))
- ((= pos 0))
- ((not (eq (char-after pos) ?{))
- (goto-char pos)
- (setq pos nil))
- ))
- (goto-char pos)))
- ;; Emacs, which doesn't have buffer-syntactic-context-depth
- (let (beginning-of-defun-function end-of-defun-function)
- (beginning-of-defun)))
- ;; if defun-prompt-regexp is non-nil, b-o-d won't leave us at the
- ;; open brace.
- (and defun-prompt-regexp
- (looking-at defun-prompt-regexp)
- (goto-char (match-end 0)))))
+ (while
+ (progn
+ (if (and ,(fboundp 'buffer-syntactic-context-depth)
+ c-enable-xemacs-performance-kludge-p)
+ ,(when (fboundp 'buffer-syntactic-context-depth)
+ ;; XEmacs only. This can improve the performance of
+ ;; c-parse-state to between 3 and 60 times faster when
+ ;; braces are hung. It can also degrade performance by
+ ;; about as much when braces are not hung.
+ '(let (beginning-of-defun-function end-of-defun-function
+ pos)
+ (while (not pos)
+ (save-restriction
+ (widen)
+ (setq pos (c-safe-scan-lists
+ (point) -1 (buffer-syntactic-context-depth))))
+ (cond
+ ((bobp) (setq pos (point-min)))
+ ((not pos)
+ (let ((distance (skip-chars-backward "^{")))
+ ;; unbalanced parenthesis, while invalid C code,
+ ;; shouldn't cause an infloop! See unbal.c
+ (when (zerop distance)
+ ;; Punt!
+ (beginning-of-defun)
+ (setq pos (point)))))
+ ((= pos 0))
+ ((not (eq (char-after pos) ?{))
+ (goto-char pos)
+ (setq pos nil))
+ ))
+ (goto-char pos)))
+ ;; Emacs, which doesn't have buffer-syntactic-context-depth
+ (let (beginning-of-defun-function end-of-defun-function)
+ (beginning-of-defun)))
+ (and (not (bobp))
+ ;; if defun-prompt-regexp is non-nil, b-o-d won't leave us at
+ ;; the open brace.
+ defun-prompt-regexp
+ (looking-at (concat defun-prompt-regexp "\\s("))
+ (or (not (eq (char-before (match-end 0)) ?{))
+ (progn (goto-char (1- (match-end 0)))
+ nil)))))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
@@ -1089,6 +1110,38 @@ continuations."
(eq (char-before) ?\\)))
(backward-char))))
+(defmacro c-skip-ws-chars-forward (string &optional lim)
+ ;; Move point forward, stopping before a char which isn't in STRING, or a
+ ;; char whose syntax isn't whitespace or comment-end, or at pos LIM.
+ ;; Note that \n usually has comment-end syntax.
+ ;;
+ ;; Returns the distance traveled, either zero or positive.
+ (declare (debug t))
+ `(let ((-lim- ,lim)
+ (here (point))
+ count)
+ (setq count (skip-chars-forward ,string -lim-))
+ (when (> count 0)
+ (goto-char here)
+ (setq count (skip-syntax-forward " >" (+ here count))))
+ count))
+
+(defmacro c-skip-ws-chars-backward (string &optional lim)
+ ;; Move point backward, stopping after a char which isn't in STRING, or a
+ ;; char whose syntax isn't whitespace or comment-end, or at pos LIM. Note
+ ;; that \n usually has comment-end syntax.
+ ;;
+ ;; Returns the distance traveled, either zero or negative.
+ (declare (debug t))
+ `(let ((-lim- ,lim)
+ (here (point))
+ count)
+ (setq count (skip-chars-backward ,string -lim-))
+ (when (< count 0)
+ (goto-char here)
+ (setq count (skip-syntax-backward " >" (+ here count))))
+ count))
+
(eval-and-compile
(defvar c-langs-are-parametric nil))
@@ -1195,6 +1248,17 @@ MODE is either a mode symbol or a list of mode symbols."
`((setq c-syntax-table-hwm (min c-syntax-table-hwm -pos-))))
(put-text-property -pos- (1+ -pos-) ',property ,value))))
+(defmacro c-put-string-fence (pos)
+ ;; Put the string-fence syntax-table text property at POS.
+ ;; Since the character there cannot then count as syntactic whitespace,
+ ;; clear the properties `c-is-sws' and `c-in-sws' (see functions
+ ;; `c-forward-sws' and `c-backward-sws' in cc-engine.el for details).
+ (declare (debug t))
+ `(let ((-pos- ,pos))
+ (c-put-char-property -pos- 'syntax-table '(15))
+ (c-clear-char-property -pos- 'c-is-sws)
+ (c-clear-char-property -pos- 'c-in-sws)))
+
(eval-and-compile
;; Constant to decide at compilation time whether to use category
;; properties. Currently (2010-03) they're available only on GNU
@@ -1284,6 +1348,21 @@ MODE is either a mode symbol or a list of mode symbols."
pos)
(most-positive-fixnum))))
+(defmacro c-put-char-properties (from to property value)
+ ;; Put the given PROPERTY with the given VALUE on the characters between
+ ;; FROM and TO. PROPERTY is assumed to be constant. The return value is
+ ;; undefined.
+ ;;
+ ;; This macro does hidden buffer changes.
+ (declare (debug t))
+ (setq property (eval property))
+ `(let ((-from- ,from))
+ (progn
+ ,@(when (and (fboundp 'syntax-ppss)
+ (eq `,property 'syntax-table))
+ `((setq c-syntax-table-hwm (min c-syntax-table-hwm -from-))))
+ (put-text-property -from- ,to ',property ,value))))
+
(defmacro c-clear-char-properties (from to property)
;; Remove all the occurrences of the given property in the given
;; region that has been put with `c-put-char-property'. PROPERTY is
@@ -1379,7 +1458,8 @@ isn't found, return nil; point is then left undefined."
value)
(t (let ((place (c-next-single-property-change
(point) ,property nil -limit-)))
- (when place
+ (when (and place
+ (< place -limit-))
(goto-char (1+ place))
(c-get-char-property place ,property)))))))
@@ -1846,9 +1926,9 @@ with value CHAR in the region [FROM to)."
'(looking-at
"\\([;#]\\|\\'\\|\\s(\\|\\s)\\|\\s\"\\|\\s\\\\|\\s$\\|\\s<\\|\\s>\\|\\s!\\)")
'(or (looking-at
- "\\([;#]\\|\\'\\|\\s(\\|\\s)\\|\\s\"\\|\\s\\\\|\\s$\\|\\s<\\|\\s>\\)"
+ "\\([;#]\\|\\'\\|\\s(\\|\\s)\\|\\s\"\\|\\s\\\\|\\s$\\|\\s<\\|\\s>\\)")
(let ((prop (c-get-char-property (point) 'syntax-table)))
- (equal prop '(14))))))) ; '(14) is generic comment delimiter.
+ (equal prop '(14)))))) ; '(14) is generic comment delimiter.
(defsubst c-intersect-lists (list alist)
@@ -2345,7 +2425,7 @@ system."
(error "Unknown base mode `%s'" base-mode))
(put mode 'c-fallback-mode base-mode))
-(defvar c-lang-constants (make-vector 151 0))
+(defvar c-lang-constants (obarray-make 151))
;; Obarray used as a cache to keep track of the language constants.
;; The constants stored are those defined by `c-lang-defconst' and the values
;; computed by `c-lang-const'. It's mostly used at compile time but it's not
@@ -2550,7 +2630,7 @@ constant. A file is identified by its base name."
;; Clear the evaluated values that depend on this source.
(let ((agenda (get sym 'dependents))
- (visited (make-vector 101 0))
+ (visited (obarray-make 101))
ptr)
(while agenda
(setq sym (car agenda)
diff --git a/lisp/progmodes/cc-engine.el b/lisp/progmodes/cc-engine.el
index 8a954c4c14e..8c505e9556a 100644
--- a/lisp/progmodes/cc-engine.el
+++ b/lisp/progmodes/cc-engine.el
@@ -146,11 +146,6 @@
;; "typedef" keyword. It's value is a list of the identifiers that
;; the "typedef" declares as types.
;;
-;; 'c-<>-c-types-set
-;; This property is set on an opening angle bracket, and indicates that
-;; any "," separators within the template/generic expression have been
-;; marked with a 'c-type property value 'c-<>-arg-sep (see above).
-;;
;; 'c-awk-NL-prop
;; Used in AWK mode to mark the various kinds of newlines. See
;; cc-awk.el.
@@ -981,10 +976,10 @@ comment at the start of cc-engine.el for more info."
(point-min)))
(widen)
- (if (save-excursion
- (and (c-beginning-of-macro)
- (/= (point) start)))
- (setq macro-start (point)))
+ (save-excursion
+ (if (and (c-beginning-of-macro)
+ (/= (point) start))
+ (setq macro-start (point))))
;; Try to skip back over unary operator characters, to register
;; that we've moved.
@@ -1651,7 +1646,7 @@ This function does not do any hidden buffer changes."
;; comment, but XEmacs doesn't. We depend on the Emacs
;; behavior (which also is symmetric).
(if (and (eolp) (elt (parse-partial-sexp start (point)) 7))
- (condition-case nil (forward-char 1)))
+ (forward-char 1))
t))))
@@ -2135,7 +2130,7 @@ comment at the start of cc-engine.el for more info."
;; Skip simple ws and do a quick check on the following character to see
;; if it's anything that can't start syntactic ws, so we can bail out
;; early in the majority of cases when there just are a few ws chars.
- (skip-chars-forward " \t\n\r\f\v")
+ (c-skip-ws-chars-forward " \t\n\r\f\v")
(when (or (looking-at c-syntactic-ws-start)
(and c-opt-cpp-prefix
(looking-at c-noise-macro-name-re))
@@ -2185,7 +2180,7 @@ comment at the start of cc-engine.el for more info."
rung-pos (point) (point-max))
(setq rung-pos (point))
- (and (> (skip-chars-forward " \t\n\r\f\v") 0)
+ (and (> (c-skip-ws-chars-forward " \t\n\r\f\v") 0)
(not (eobp))))
;; We'll loop here if there is simple ws after the last rung.
@@ -2251,7 +2246,7 @@ comment at the start of cc-engine.el for more info."
(and c-opt-cpp-prefix
(looking-at c-opt-cpp-start)
(setq macro-start (point))
- (progn (skip-chars-backward " \t")
+ (progn (c-skip-ws-chars-backward " \t")
(bolp))
(or (bobp)
(progn (backward-char)
@@ -2291,7 +2286,7 @@ comment at the start of cc-engine.el for more info."
;; We've searched over a piece of non-white syntactic ws. See if this
;; can be cached.
(setq next-rung-pos (point))
- (skip-chars-forward " \t\n\r\f\v")
+ (c-skip-ws-chars-forward " \t\n\r\f\v")
(setq rung-end-pos (min (1+ (point)) (point-max)))
(if (or
@@ -2388,7 +2383,7 @@ comment at the start of cc-engine.el for more info."
;; bail out early in the majority of cases when there just are a few ws
;; chars. Newlines are complicated in the backward direction, so we can't
;; skip over them.
- (skip-chars-backward " \t\f")
+ (c-skip-ws-chars-backward " \t\f")
(when (and (not (bobp))
(save-excursion
(or (and
@@ -2416,7 +2411,7 @@ comment at the start of cc-engine.el for more info."
(setq simple-ws-beg (or attr-end ; After attribute.
(match-end 1) ; Noise macro, etc.
(match-end 0))) ; c-syntactic-ws-end
- (skip-chars-backward " \t\n\r\f\v")
+ (c-skip-ws-chars-backward " \t\n\r\f\v")
(if (setq rung-is-marked (text-property-any
(point) (min (1+ rung-pos) (point-max))
'c-is-sws t))
@@ -2453,10 +2448,10 @@ comment at the start of cc-engine.el for more info."
(point) rung-pos (point-min))
(setq rung-pos (point))
- (if (and (< (min (skip-chars-backward " \t\f\v")
+ (if (and (< (min (c-skip-ws-chars-backward " \t\f\v")
(progn
(setq simple-ws-beg (point))
- (skip-chars-backward " \t\n\r\f\v")))
+ (c-skip-ws-chars-backward " \t\n\r\f\v")))
0)
(setq rung-is-marked
(text-property-any (point) rung-pos
@@ -2536,7 +2531,7 @@ comment at the start of cc-engine.el for more info."
;; the macro, and then `simple-ws-beg' must be kept on the
;; same side of those comments.
(goto-char simple-ws-beg)
- (skip-chars-backward " \t\n\r\f\v")
+ (c-skip-ws-chars-backward " \t\n\r\f\v")
(if (eq (char-before) ?\\)
(forward-char))
(forward-line 1)
@@ -2549,7 +2544,7 @@ comment at the start of cc-engine.el for more info."
t)))
((/= (save-excursion
- (skip-chars-forward " \t\n\r\f\v" simple-ws-beg)
+ (c-skip-ws-chars-forward " \t\n\r\f\v" simple-ws-beg)
(setq next-rung-pos (point)))
simple-ws-beg)
;; Skipped over comments. Must put point at the end of
@@ -2586,7 +2581,7 @@ comment at the start of cc-engine.el for more info."
;; We've searched over a piece of non-white syntactic ws. See if this
;; can be cached.
(setq next-rung-pos (point))
- (skip-chars-backward " \t\f\v")
+ (c-skip-ws-chars-backward " \t\f\v")
(if (or
;; Cache if we started either from a marked rung or from a
@@ -2596,7 +2591,7 @@ comment at the start of cc-engine.el for more info."
;; Cache if there's a marked rung in the encountered simple ws.
(save-excursion
- (skip-chars-backward " \t\n\r\f\v")
+ (c-skip-ws-chars-backward " \t\n\r\f\v")
(text-property-any (point) (min (1+ next-rung-pos) (point-max))
'c-is-sws t)))
@@ -2677,6 +2672,7 @@ comment at the start of cc-engine.el for more info."
(progn (goto-char beg)
(c-skip-ws-forward end+1)
(eq (point) end+1))))))
+
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; We maintain a sopisticated cache of positions which are in a literal,
@@ -5915,19 +5911,21 @@ comment at the start of cc-engine.el for more info."
(cond
((> pos start) ; Nothing but literals
base)
- ((> base (point-min))
+ ((and
+ (> base (point-min))
+ (> (- base try-size) (point-min))) ; prevent infinite recursion.
(c-determine-limit how-far-back base (* 2 try-size) org-start))
(t base)))
((>= count how-far-back)
(c-determine-limit-no-macro
- (+ (car elt) (- count how-far-back))
- org-start))
+ (+ (car elt) (- count how-far-back))
+ org-start))
((eq base (point-min))
(point-min))
((> base (- start try-size)) ; Can only happen if we hit point-min.
(c-determine-limit-no-macro
- (car elt)
- org-start))
+ (car elt)
+ org-start))
(t
(c-determine-limit (- how-far-back count) base (* 2 try-size)
org-start))))))
@@ -6170,12 +6168,18 @@ comment at the start of cc-engine.el for more info."
(cons (point)
(cons bound-<> s)))))
+(defvar c-record-type-identifiers) ; Specially for `c-brace-stack-at'.
+
(defun c-brace-stack-at (here)
;; Given a buffer position HERE, Return the value of the brace stack there.
(save-excursion
(save-restriction
(widen)
- (let ((c c-bs-cache)
+ (let (c-record-type-identifiers ; In case `c-forward-<>-arglist' would
+ ; otherwise record identifiers outside
+ ; of the restriction in force before
+ ; this function.
+ (c c-bs-cache)
(can-use-prev (<= c-bs-prev-pos c-bs-cache-limit))
elt stack pos npos high-elt)
;; Trim the cache to take account of buffer changes.
@@ -6241,6 +6245,9 @@ comment at the start of cc-engine.el for more info."
;; prefix". The declaration prefix is the earlier of `cfd-prop-match' and
;; `cfd-re-match'. `cfd-match-pos' is set to the decl prefix.
;;
+ ;; The variables which this macro should set for `c-find-decl-spots' are
+ ;; `cfd-match-pos' and `cfd-continue-pos'.
+ ;;
;; This macro might do hidden buffer changes.
'(progn
@@ -6583,11 +6590,17 @@ comment at the start of cc-engine.el for more info."
;; and so we can continue the search from this point. If we
;; didn't hit `c-find-decl-syntactic-pos' then we're now in
;; the right spot to begin searching anyway.
- (if (and (eq (point) c-find-decl-syntactic-pos)
- c-find-decl-match-pos)
- (setq cfd-match-pos c-find-decl-match-pos
- cfd-continue-pos syntactic-pos)
-
+ (cond
+ ((and (eq (point) c-find-decl-syntactic-pos)
+ c-find-decl-match-pos)
+ (setq cfd-match-pos c-find-decl-match-pos
+ cfd-continue-pos syntactic-pos))
+ ((save-excursion (c-beginning-of-macro))
+ ;; The `c-backward-syntactic-ws' ~40 lines up failed to find non
+ ;; syntactic-ws and hit its limit, leaving us in a macro.
+ (setq cfd-match-pos cfd-start-pos
+ cfd-continue-pos cfd-start-pos))
+ (t
(setq c-find-decl-syntactic-pos syntactic-pos)
(when (if (bobp)
@@ -6605,7 +6618,7 @@ comment at the start of cc-engine.el for more info."
(c-find-decl-prefix-search)) ; sets cfd-continue-pos
(setq c-find-decl-match-pos (and (< cfd-match-pos cfd-start-pos)
- cfd-match-pos))))) ; end of `cond'
+ cfd-match-pos)))))) ; end of `cond'
;; Advance `cfd-continue-pos' if it's before the start position.
;; The closest continue position that might have effect at or
@@ -7027,8 +7040,8 @@ comment at the start of cc-engine.el for more info."
;; POS (default point) is at a < character. If it is both marked
;; with open/close paren syntax-table property, and has a matching >
;; (also marked) which is after LIM, remove the property both from
- ;; the current > and its partner. Return t when this happens, nil
- ;; when it doesn't.
+ ;; the current > and its partner. Return the position after the >
+ ;; when this happens, nil when it doesn't.
(save-excursion
(if pos
(goto-char pos)
@@ -7042,15 +7055,15 @@ comment at the start of cc-engine.el for more info."
c->-as-paren-syntax)) ; should always be true.
(c-unmark-<->-as-paren (1- (point)))
(c-unmark-<->-as-paren pos)
- (c-truncate-lit-pos-cache pos))
- t)))
+ (c-truncate-lit-pos-cache pos)
+ (point)))))
(defun c-clear->-pair-props-if-match-before (lim &optional pos)
;; POS (default point) is at a > character. If it is both marked
;; with open/close paren syntax-table property, and has a matching <
;; (also marked) which is before LIM, remove the property both from
- ;; the current < and its partner. Return t when this happens, nil
- ;; when it doesn't.
+ ;; the current < and its partner. Return the position of the < when
+ ;; this happens, nil when it doesn't.
(save-excursion
(if pos
(goto-char pos)
@@ -7064,8 +7077,8 @@ comment at the start of cc-engine.el for more info."
c-<-as-paren-syntax)) ; should always be true.
(c-unmark-<->-as-paren (point))
(c-truncate-lit-pos-cache (point))
- (c-unmark-<->-as-paren pos))
- t)))
+ (c-unmark-<->-as-paren pos)
+ (point)))))
;; Set by c-common-init in cc-mode.el.
(defvar c-new-BEG)
@@ -7073,7 +7086,48 @@ comment at the start of cc-engine.el for more info."
;; Set by c-before-change-check-raw-strings.
(defvar c-old-END-literality)
-(defun c-before-change-check-<>-operators (beg end)
+(defun c-end-of-literal (pt-s pt-search)
+ ;; If a literal is open in the `c-semi-pp-to-literal' state PT-S, return the
+ ;; end point of this literal (or point-max) assuming PT-S is valid at
+ ;; PT-SEARCH. Otherwise, return nil.
+ (when (car (cddr pt-s)) ; Literal start
+ (let ((lit-type (cadr pt-s))
+ (lit-beg (car (cddr pt-s)))
+ ml-end-re
+ )
+ (save-excursion
+ (cond
+ ((eq lit-type 'string)
+ (if (and c-ml-string-opener-re
+ (c-ml-string-opener-at-or-around-point lit-beg))
+ (progn
+ (setq ml-end-re
+ (funcall c-make-ml-string-closer-re-function
+ (match-string 1)))
+ (goto-char (max (- pt-search (1- (length ml-end-re)))
+ (point-min)))
+ (re-search-forward ml-end-re nil 'stay))
+ ;; For an ordinary string, we can't use `parse-partial-sexp' since
+ ;; not all syntax-table properties have yet been set.
+ (goto-char pt-search)
+ (re-search-forward
+ "\\(?:\\\\\\(?:.\\|\n\\)\\|[^\"\n\\]\\)*[\"\n]" nil 'stay)))
+ ((memq lit-type '(c c++))
+ ;; To work around a bug in parse-partial-sexp, where effect is given
+ ;; to the syntax of a backslash, even the the scan starts with point
+ ;; just after it.
+ (if (and (eq (char-before pt-search) ?\\)
+ (eq (char-after pt-search) ?\n))
+ (progn
+ (c-put-char-property (1- pt-search) 'syntax-table '(1))
+ (parse-partial-sexp pt-search (point-max) nil nil (car pt-s)
+ 'syntax-table)
+ (c-clear-char-property (1- pt-search) 'syntax-table))
+ (parse-partial-sexp pt-search (point-max) nil nil (car pt-s)
+ 'syntax-table))))
+ (point)))))
+
+(defun c-unmark-<>-around-region (beg end &optional old-len)
;; Unmark certain pairs of "< .... >" which are currently marked as
;; template/generic delimiters. (This marking is via syntax-table text
;; properties), and expand the (c-new-BEG c-new-END) region to include all
@@ -7087,66 +7141,196 @@ comment at the start of cc-engine.el for more info."
;; enclose a brace or semicolon, so we use these as bounds on the
;; region we must work on.
;;
+ ;; The buffer is widened, and point is undefined, both at entry and exit.
+ ;;
+ ;; FIXME!!! This routine ignores the possibility of macros entirely.
+ ;; 2010-01-29.
+
+ (when (> end beg)
+ ;; Extend the region (BEG END) to deal with any complicating literals.
+ (let* ((lit-search-beg (if (memq (char-before beg) '(?/ ?*))
+ (1- beg) beg))
+ (lit-search-end (if (memq (char-after end) '(?/ ?*))
+ (1+ end) end))
+ ;; Note we can't use c-full-pp-to-literal here, since we haven't
+ ;; yet applied syntax-table properties to ends of lines, etc.
+ (lit-search-beg-s (c-semi-pp-to-literal lit-search-beg))
+ (beg-literal-beg (car (cddr lit-search-beg-s)))
+ (lit-search-end-s (c-semi-pp-to-literal lit-search-end))
+ (end-literal-beg (car (cddr lit-search-end-s)))
+ (beg-literal-end (c-end-of-literal lit-search-beg-s lit-search-beg))
+ (end-literal-end (c-end-of-literal lit-search-end-s lit-search-end))
+ new-beg new-end search-region)
+
+ ;; Determine any new end of literal resulting from the insertion/deletion.
+ (setq search-region
+ (if (and (eq beg-literal-beg end-literal-beg)
+ (eq beg-literal-end end-literal-end))
+ (if beg-literal-beg
+ nil
+ (cons beg
+ (max end
+ (or beg-literal-end (point-min))
+ (or end-literal-end (point-min)))))
+ (cons (or beg-literal-beg beg)
+ (max end
+ (or beg-literal-end (point-min))
+ (or end-literal-end (point-min))))))
+
+ (when search-region
+ ;; If we've just inserted text, mask its syntaxes temporarily so that
+ ;; they won't interfere with the undoing of the properties on the <s
+ ;; and >s.
+ (c-save-buffer-state (syn-tab-settings syn-tab-value
+ swap-open-string-ends)
+ (unwind-protect
+ (progn
+ (when old-len
+ ;; Special case: If a \ has just been inserted into a
+ ;; string, escaping or unescaping a LF, temporarily swap
+ ;; the LF's syntax-table text property with that of the
+ ;; former end of the open string.
+ (goto-char end)
+ (when (and (eq (cadr lit-search-beg-s) 'string)
+ (not (eq beg-literal-end end-literal-end))
+ (skip-chars-forward "\\\\")
+ (eq (char-after) ?\n)
+ (not (zerop (skip-chars-backward "\\\\"))))
+ (setq swap-open-string-ends t)
+ (if (c-get-char-property (1- beg-literal-end)
+ 'syntax-table)
+ (progn
+ (c-clear-char-property (1- beg-literal-end)
+ 'syntax-table)
+ (c-put-string-fence (1- end-literal-end)))
+ (c-put-string-fence (1- beg-literal-end))
+ (c-clear-char-property (1- end-literal-end)
+ 'syntax-table)))
+
+ ;; Save current settings of the 'syntax-table property in
+ ;; (BEG END), then splat these with the punctuation value.
+ (goto-char beg)
+ (while (setq syn-tab-value
+ (c-search-forward-non-nil-char-property
+ 'syntax-table end))
+ (when (not (c-get-char-property (1- (point)) 'category))
+ (push (cons (1- (point)) syn-tab-value)
+ syn-tab-settings)))
+
+ (c-put-char-properties beg end 'syntax-table '(1))
+ ;; If an open string's opener has just been neutralized,
+ ;; do the same to the terminating LF.
+ (when (and end-literal-end
+ (eq (char-before end-literal-end) ?\n)
+ (equal (c-get-char-property
+ (1- end-literal-end) 'syntax-table)
+ '(15)))
+ (push (cons (1- end-literal-end) '(15)) syn-tab-settings)
+ (c-put-char-property (1- end-literal-end) 'syntax-table
+ '(1))))
+
+ (let
+ ((beg-lit-start (progn (goto-char beg) (c-literal-start)))
+ beg-limit end-limit <>-pos)
+ ;; Locate the earliest < after the barrier before the
+ ;; changed region, which isn't already marked as a paren.
+ (goto-char (or beg-lit-start beg))
+ (setq beg-limit (c-determine-limit 5000))
+
+ ;; Remove the syntax-table/category properties from each pertinent <...>
+ ;; pair. Firstly, the ones with the < before beg and > after beg....
+ (goto-char (cdr search-region))
+ (while (progn (c-syntactic-skip-backward "^;{}<" beg-limit)
+ (eq (char-before) ?<))
+ (c-backward-token-2)
+ (when (eq (char-after) ?<)
+ (when (setq <>-pos (c-clear-<-pair-props-if-match-after
+ (car search-region)))
+ (setq new-end <>-pos))
+ (setq new-beg (point))))
+
+ ;; ...Then the ones with < before end and > after end.
+ (goto-char (car search-region))
+ (setq end-limit (c-determine-+ve-limit 5000))
+ (while (and (c-syntactic-re-search-forward "[;{}>]" end-limit 'end)
+ (eq (char-before) ?>))
+ (when (eq (char-before) ?>)
+ (if (and (looking-at c->-op-cont-regexp)
+ (not (eq (char-after) ?>)))
+ (goto-char (match-end 0))
+ (when
+ (and (setq <>-pos
+ (c-clear->-pair-props-if-match-before
+ (cdr search-region)
+ (1- (point))))
+ (or (not new-beg)
+ (< <>-pos new-beg)))
+ (setq new-beg <>-pos))
+ (when (or (not new-end) (> (point) new-end))
+ (setq new-end (point))))))))
+
+ (when old-len
+ (c-clear-char-properties beg end 'syntax-table)
+ (dolist (elt syn-tab-settings)
+ (if (cdr elt)
+ (c-put-char-property (car elt) 'syntax-table (cdr elt)))))
+ ;; Swap the '(15) syntax-table property on open string LFs back
+ ;; again.
+ (when swap-open-string-ends
+ (if (c-get-char-property (1- beg-literal-end)
+ 'syntax-table)
+ (progn
+ (c-clear-char-property (1- beg-literal-end)
+ 'syntax-table)
+ (c-put-string-fence (1- end-literal-end)))
+ (c-put-string-fence (1- beg-literal-end))
+ (c-clear-char-property (1- end-literal-end)
+ 'syntax-table)))))
+ ;; Extend the fontification region, if needed.
+ (and new-beg
+ (< new-beg c-new-BEG)
+ (setq c-new-BEG new-beg))
+ (and new-end
+ (> new-end c-new-END)
+ (setq c-new-END new-end))))))
+
+(defun c-before-change-check-<>-operators (beg end)
+ ;; When we're deleting text, unmark certain pairs of "< .... >" which are
+ ;; currently marked as template/generic delimiters. (This marking is via
+ ;; syntax-table text properties), and expand the (c-new-BEG c-new-END)
+ ;; region to include all unmarked < and > operators within the certain
+ ;; bounds (see below).
+ ;;
+ ;; These pairs are those which are in the current "statement" (i.e.,
+ ;; the region between the {, }, or ; before BEG and the one after
+ ;; END), and which enclose any part of the interval (BEG END).
+ ;; Also unmark a < or > which is about to become part of a multi-character
+ ;; operator, e.g. <=.
+ ;;
+ ;; Note that in C++ (?and Java), template/generic parens cannot
+ ;; enclose a brace or semicolon, so we use these as bounds on the
+ ;; region we must work on.
+ ;;
;; This function is called from before-change-functions (via
;; c-get-state-before-change-functions). Thus the buffer is widened,
;; and point is undefined, both at entry and exit.
;;
;; FIXME!!! This routine ignores the possibility of macros entirely.
;; 2010-01-29.
- (when (and (or (> end beg)
- (and (> c-<-pseudo-digraph-cont-len 0)
- (goto-char beg)
- (progn
- (skip-chars-backward
- "^<" (max (- (point) c-<-pseudo-digraph-cont-len)
- (point-min)))
- (eq (char-before) ?<))
- (looking-at c-<-pseudo-digraph-cont-regexp)))
- (or
- (progn
- (goto-char beg)
- (search-backward "<" (max (- (point) 1024) (point-min)) t))
- (progn
- (goto-char end)
- (search-forward ">" (min (+ (point) 1024) (point-max)) t))))
- (save-excursion
- (c-save-buffer-state
- ((beg-lit-start (progn (goto-char beg) (c-literal-start)))
- (end-lit-limits (progn (goto-char end) (c-literal-limits)))
- new-beg new-end beg-limit end-limit)
- ;; Locate the earliest < after the barrier before the changed region,
- ;; which isn't already marked as a paren.
- (goto-char (or beg-lit-start beg))
- (setq beg-limit (c-determine-limit 512))
-
- ;; Remove the syntax-table/category properties from each pertinent <...>
- ;; pair. Firstly, the ones with the < before beg and > after beg....
- (while (progn (c-syntactic-skip-backward "^;{}<" beg-limit)
- (eq (char-before) ?<))
- (c-backward-token-2)
- (when (eq (char-after) ?<)
- (c-clear-<-pair-props-if-match-after beg)
- (setq new-beg (point))))
- (c-forward-syntactic-ws)
-
- ;; ...Then the ones with < before end and > after end.
- (goto-char (if end-lit-limits (cdr end-lit-limits) end))
- (setq end-limit (c-determine-+ve-limit 512))
- (while (and (c-syntactic-re-search-forward "[;{}>]" end-limit 'end)
- (eq (char-before) ?>))
- (c-end-of-current-token)
- (when (eq (char-before) ?>)
- (c-clear->-pair-props-if-match-before end (1- (point)))
- (setq new-end (point))))
- (c-backward-syntactic-ws)
-
- ;; Extend the fontification region, if needed.
- (and new-beg
- (< new-beg c-new-BEG)
- (setq c-new-BEG new-beg))
- (and new-end
- (> new-end c-new-END)
- (setq c-new-END new-end))))))
+ (when (> end beg)
+ ;; Cope with removing (beg end) coalescing a < or > with, say, an = sign.
+ (goto-char beg)
+ (let ((ch (char-before)))
+ (if (and (memq ch '(?< ?>))
+ (c-get-char-property (1- (point)) 'syntax-table)
+ (progn
+ (goto-char end)
+ (looking-at (if (eq ch ?<)
+ c-<-op-cont-regexp
+ c->-op-cont-regexp)))
+ (or (eq ch ?<)
+ (not (eq (char-after) ?>))))
+ (c-unmark-<>-around-region (1- beg) beg)))))
(defun c-after-change-check-<>-operators (beg end)
;; This is called from `after-change-functions' when
@@ -7186,29 +7370,38 @@ comment at the start of cc-engine.el for more info."
(c-clear-<>-pair-props)
(forward-char)))))))
+(defun c-<>-get-restricted ()
+ ;; With point at the < at the start of the purported <>-arglist, determine
+ ;; the value of `c-restricted-<>-arglists' to use for the call of
+ ;; `c-forward-<>-arglist' starting there.
+ (save-excursion
+ (c-backward-token-2)
+ (and (not (looking-at c-opt-<>-sexp-key))
+ (progn (c-backward-syntactic-ws) ; to ( or ,
+ (and (memq (char-before) '(?\( ?,)) ; what about <?
+ (not (eq (c-get-char-property (point) 'c-type)
+ 'c-decl-arg-start)))))))
+
(defun c-restore-<>-properties (_beg _end _old-len)
;; This function is called as an after-change function. It restores the
;; category/syntax-table properties on template/generic <..> pairs between
;; c-new-BEG and c-new-END. It may do hidden buffer changes.
- (c-save-buffer-state ((c-parse-and-markup-<>-arglists t)
- c-restricted-<>-arglists lit-limits)
+ (c-save-buffer-state ((c-parse-and-markup-<>-arglists t) lit-limits)
(goto-char c-new-BEG)
(if (setq lit-limits (c-literal-limits))
(goto-char (cdr lit-limits)))
(while (and (< (point) c-new-END)
- (c-syntactic-re-search-forward "<" c-new-END 'bound))
- (backward-char)
- (save-excursion
- (c-backward-token-2)
- (setq c-restricted-<>-arglists
- (and (not (looking-at c-opt-<>-sexp-key))
- (progn (c-backward-syntactic-ws) ; to ( or ,
- (and (memq (char-before) '(?\( ?,)) ; what about <?
- (not (eq (c-get-char-property (point) 'c-type)
- 'c-decl-arg-start)))))))
- (or (c-forward-<>-arglist nil)
- (c-forward-over-token-and-ws)
- (goto-char c-new-END)))))
+ (c-syntactic-re-search-forward "[<>]" c-new-END 'bound))
+ (if (eq (char-before) ?<)
+ (progn
+ (backward-char)
+ (let ((c-restricted-<>-arglists (c-<>-get-restricted)))
+ (or (c-forward-<>-arglist nil)
+ (c-forward-over-token-and-ws)
+ (goto-char c-new-END))))
+ (save-excursion
+ (when (c-backward-<>-arglist nil nil #'c-<>-get-restricted)
+ (setq c-new-BEG (min c-new-BEG (point)))))))))
;; Handling of CC Mode multi-line strings.
@@ -7360,13 +7553,13 @@ multi-line strings (but not C++, for example)."
(defun c-ml-string-opener-intersects-region (&optional start finish)
;; If any part of the region [START FINISH] is inside an ml-string opener,
- ;; return a dotted list of the start, end and double-quote position of that
- ;; opener. That list will not include any "context characters" before or
- ;; after the opener. If an opener is found, the match-data will indicate
- ;; it, with (match-string 1) being the entire delimiter, and (match-string
- ;; 2) the "main" double-quote. Otherwise, the match-data is undefined.
- ;; Both START and FINISH default to point. FINISH may not be at an earlier
- ;; buffer position than START.
+ ;; return a dotted list of the start, end and double-quote position of the
+ ;; first such opener. That list will not include any "context characters"
+ ;; before or after the opener. If an opener is found, the match-data will
+ ;; indicate it, with (match-string 1) being the entire delimiter, and
+ ;; (match-string 2) the "main" double-quote. Otherwise, the match-data is
+ ;; undefined. Both START and FINISH default to point. FINISH may not be at
+ ;; an earlier buffer position than START.
(let ((here (point)) found)
(or finish (setq finish (point)))
(or start (setq start (point)))
@@ -7390,7 +7583,10 @@ multi-line strings (but not C++, for example)."
;; If POSITION (default point) is at or inside an ml string opener, return a
;; dotted list of the start and end of that opener, and the position of the
;; double-quote in it. That list will not include any "context characters"
- ;; before or after the opener.
+ ;; before or after the opener. If an opener is found, the match-data will
+ ;; indicate it, with (match-string 1) being the entire delimiter, and
+ ;; (match-string 2) the "main" double-quote. Otherwise, the match-data is
+ ;; undefined.
(let ((here (point))
found)
(or position (setq position (point)))
@@ -7402,7 +7598,7 @@ multi-line strings (but not C++, for example)."
c-ml-string-opener-re
(min (+ position c-ml-string-max-opener-len) (point-max))
'bound))
- (<= (match-end 1) position)))
+ (< (match-end 1) position)))
(prog1
(and found
(<= (match-beginning 1) position)
@@ -7746,7 +7942,7 @@ multi-line strings (but not C++, for example)."
(insert (nth 3 (car state))))
((eq (nth 3 (car state)) t)
(insert ?\")
- (c-put-char-property end 'syntax-table '(15))))
+ (c-put-string-fence end)))
(c-truncate-lit-pos-cache end)
;; ....ensure c-new-END extends right to the end of the about
;; to be un-stringed raw string....
@@ -7991,7 +8187,7 @@ multi-line strings (but not C++, for example)."
(goto-char (cadr end-delim))
t)
(c-put-char-property (cddr delim) 'syntax-table '(1))
- (c-put-char-property (1- (cadr delim)) 'syntax-table '(15))
+ (c-put-string-fence (1- (cadr delim)))
(c-truncate-lit-pos-cache (1- (cddr delim)))
(when bound
;; In a CPP construct, we try to apply a generic-string
@@ -8021,10 +8217,10 @@ multi-line strings (but not C++, for example)."
(cadr delim) t))
(if (match-beginning 10)
(progn
- (c-put-char-property (match-beginning 10) 'syntax-table '(15))
+ (c-put-string-fence (match-beginning 10))
(c-truncate-lit-pos-cache (match-beginning 10)))
(c-put-char-property (match-beginning 5) 'syntax-table '(1))
- (c-put-char-property (1+ (match-beginning 5)) 'syntax-table '(15))
+ (c-put-string-fence (1+ (match-beginning 5)))
(c-truncate-lit-pos-cache (match-beginning 5))))
(goto-char bound))
nil))
@@ -8288,10 +8484,17 @@ multi-line strings (but not C++, for example)."
(setq c-record-ref-identifiers
(cons range c-record-ref-identifiers))))))
-(defmacro c-forward-keyword-prefixed-id (type)
+(defmacro c-forward-keyword-prefixed-id (type &optional stop-at-end)
;; Used internally in `c-forward-keyword-clause' to move forward
;; over a type (if TYPE is 'type) or a name (otherwise) which
;; possibly is prefixed by keywords and their associated clauses.
+ ;; Point should be at the type/name or a preceding keyword at the start of
+ ;; the macro, and it is left at the first token following the type/name,
+ ;; or (when STOP-AT-END is non-nil) immediately after that type/name.
+ ;;
+ ;; Note that both parameters are evaluated at compile time, not run time,
+ ;; so they must be constants.
+ ;;
;; Try with a type/name first to not trip up on those that begin
;; with a keyword. Return t if a known or found type is moved
;; over. The point is clobbered if nil is returned. If range
@@ -8300,51 +8503,84 @@ multi-line strings (but not C++, for example)."
;;
;; This macro might do hidden buffer changes.
(declare (debug t))
- `(let (res)
+ `(let (res pos)
(setq c-last-identifier-range nil)
(while (if (setq res ,(if (eq type 'type)
- '(c-forward-type)
- '(c-forward-name)))
- nil
- (cond ((looking-at c-keywords-regexp)
- (c-forward-keyword-clause 1))
- ((and c-opt-cpp-prefix
- (looking-at c-noise-macro-with-parens-name-re))
- (c-forward-noise-clause)))))
+ `(c-forward-type nil ,stop-at-end)
+ `(c-forward-name ,stop-at-end)))
+ (progn
+ (setq pos (point))
+ nil)
+ (and
+ (cond ((looking-at c-keywords-regexp)
+ (c-forward-keyword-clause 1 t))
+ ((and c-opt-cpp-prefix
+ (looking-at c-noise-macro-with-parens-name-re))
+ (c-forward-noise-clause t)))
+ (progn
+ (setq pos (point))
+ (c-forward-syntactic-ws)
+ t))))
(when (memq res '(t known found prefix maybe))
(when c-record-type-identifiers
- ,(if (eq type 'type)
- '(c-record-type-id c-last-identifier-range)
- '(c-record-ref-id c-last-identifier-range)))
+ ,(if (eq type 'type)
+ '(c-record-type-id c-last-identifier-range)
+ '(c-record-ref-id c-last-identifier-range)))
+ (when pos
+ (goto-char pos)
+ ,(unless stop-at-end
+ `(c-forward-syntactic-ws)))
t)))
-(defmacro c-forward-id-comma-list (type update-safe-pos)
+(defmacro c-forward-id-comma-list (type update-safe-pos &optional stop-at-end)
;; Used internally in `c-forward-keyword-clause' to move forward
;; over a comma separated list of types or names using
- ;; `c-forward-keyword-prefixed-id'.
+ ;; `c-forward-keyword-prefixed-id'. Point should start at the first token
+ ;; after the already scanned type/name, or (if STOP-AT-END is non-nil)
+ ;; immediately after that type/name. Point is left either before or
+ ;; after the whitespace following the last type/name in the list, depending
+ ;; on whether STOP-AT-END is non-nil or nil. The return value is without
+ ;; significance.
+ ;;
+ ;; Note that all three parameters are evaluated at compile time, not run
+ ;; time, so they must be constants.
;;
;; This macro might do hidden buffer changes.
(declare (debug t))
- `(while (and (progn
- ,(when update-safe-pos
- '(setq safe-pos (point)))
- (eq (char-after) ?,))
- (progn
- (forward-char)
- (c-forward-syntactic-ws)
- (c-forward-keyword-prefixed-id ,type)))))
+ `(let ((pos (point)))
+ (while (and (progn
+ ,(when update-safe-pos
+ `(setq safe-pos (point)))
+ (setq pos (point))
+ (c-forward-syntactic-ws)
+ (eq (char-after) ?,))
+ (progn
+ (forward-char)
+ (setq pos (point))
+ (c-forward-syntactic-ws)
+ (c-forward-keyword-prefixed-id ,type t))))
+ (goto-char pos)
+ ,(unless stop-at-end
+ `(c-forward-syntactic-ws))))
-(defun c-forward-noise-clause ()
+(defun c-forward-noise-clause (&optional stop-at-end)
;; Point is at a c-noise-macro-with-parens-names macro identifier. Go
;; forward over this name, any parenthesis expression which follows it, and
- ;; any syntactic WS, ending up at the next token or EOB. If there is an
+ ;; any syntactic WS, ending up either at the next token or EOB or (when
+ ;; STOP-AT-END is non-nil) directly after the clause. If there is an
;; unbalanced paren expression, leave point at it. Always Return t.
- (or (zerop (c-forward-token-2))
- (goto-char (point-max)))
- (if (and (eq (char-after) ?\()
- (c-go-list-forward))
+ (let (pos)
+ (or (c-forward-over-token)
+ (goto-char (point-max)))
+ (setq pos (point))
+ (c-forward-syntactic-ws)
+ (when (and (eq (char-after) ?\()
+ (c-go-list-forward))
+ (setq pos (point)))
+ (goto-char pos)
+ (unless stop-at-end
(c-forward-syntactic-ws))
- t)
+ t))
(defun c-forward-noise-clause-not-macro-decl (maybe-parens)
;; Point is at a noise macro identifier, which, when MAYBE-PARENS is
@@ -8378,11 +8614,12 @@ multi-line strings (but not C++, for example)."
(goto-char here)
nil)))
-(defun c-forward-keyword-clause (match)
+(defun c-forward-keyword-clause (match &optional stop-at-end)
;; Submatch MATCH in the current match data is assumed to surround a
;; token. If it's a keyword, move over it and any immediately
- ;; following clauses associated with it, stopping at the start of
- ;; the next token. t is returned in that case, otherwise the point
+ ;; following clauses associated with it, stopping either at the start
+ ;; of the next token, or (when STOP-AT-END is non-nil) at the end
+ ;; of the clause. t is returned in that case, otherwise the point
;; stays and nil is returned. The kind of clauses that are
;; recognized are those specified by `c-type-list-kwds',
;; `c-ref-list-kwds', `c-colon-type-list-kwds',
@@ -8412,19 +8649,23 @@ multi-line strings (but not C++, for example)."
(when kwd-sym
(goto-char (match-end match))
- (c-forward-syntactic-ws)
(setq safe-pos (point))
+ (c-forward-syntactic-ws)
(cond
((and (c-keyword-member kwd-sym 'c-type-list-kwds)
- (c-forward-keyword-prefixed-id type))
+ (c-forward-keyword-prefixed-id type t))
;; There's a type directly after a keyword in `c-type-list-kwds'.
- (c-forward-id-comma-list type t))
+ (setq safe-pos (point))
+ (c-forward-syntactic-ws)
+ (c-forward-id-comma-list type t t))
((and (c-keyword-member kwd-sym 'c-ref-list-kwds)
- (c-forward-keyword-prefixed-id ref))
+ (c-forward-keyword-prefixed-id ref t))
;; There's a name directly after a keyword in `c-ref-list-kwds'.
- (c-forward-id-comma-list ref t))
+ (setq safe-pos (point))
+ (c-forward-syntactic-ws)
+ (c-forward-id-comma-list ref t t))
((and (c-keyword-member kwd-sym 'c-paren-any-kwds)
(eq (char-after) ?\())
@@ -8444,20 +8685,20 @@ multi-line strings (but not C++, for example)."
(goto-char (match-end 0)))))
(goto-char pos)
- (c-forward-syntactic-ws)
- (setq safe-pos (point))))
+ (setq safe-pos (point)))
+ (c-forward-syntactic-ws))
((and (c-keyword-member kwd-sym 'c-<>-sexp-kwds)
(eq (char-after) ?<)
(c-forward-<>-arglist (c-keyword-member kwd-sym 'c-<>-type-kwds)))
- (c-forward-syntactic-ws)
- (setq safe-pos (point)))
+ (setq safe-pos (point))
+ (c-forward-syntactic-ws))
((and (c-keyword-member kwd-sym 'c-nonsymbol-sexp-kwds)
(not (looking-at c-symbol-start))
(c-safe (c-forward-sexp) t))
- (c-forward-syntactic-ws)
- (setq safe-pos (point)))
+ (setq safe-pos (point))
+ (c-forward-syntactic-ws))
((and (c-keyword-member kwd-sym 'c-protection-kwds)
(or (null c-post-protection-token)
@@ -8467,8 +8708,8 @@ multi-line strings (but not C++, for example)."
(not (c-end-of-current-token))))))
(if c-post-protection-token
(goto-char (match-end 0)))
- (c-forward-syntactic-ws)
- (setq safe-pos (point))))
+ (setq safe-pos (point))
+ (c-forward-syntactic-ws)))
(when (c-keyword-member kwd-sym 'c-colon-type-list-kwds)
(if (eq (char-after) ?:)
@@ -8477,8 +8718,10 @@ multi-line strings (but not C++, for example)."
(progn
(forward-char)
(c-forward-syntactic-ws)
- (when (c-forward-keyword-prefixed-id type)
- (c-forward-id-comma-list type t)))
+ (when (c-forward-keyword-prefixed-id type t)
+ (setq safe-pos (point))
+ (c-forward-syntactic-ws)
+ (c-forward-id-comma-list type t t)))
;; Not at the colon, so stop here. But the identifier
;; ranges in the type list later on should still be
;; recorded.
@@ -8488,15 +8731,18 @@ multi-line strings (but not C++, for example)."
;; this one, we move forward to the colon following the
;; clause matched above.
(goto-char safe-pos)
+ (c-forward-syntactic-ws)
(c-forward-over-colon-type-list))
(progn
(c-forward-syntactic-ws)
- (c-forward-keyword-prefixed-id type))
+ (c-forward-keyword-prefixed-id type t))
;; There's a type after the `c-colon-type-list-re' match
;; after a keyword in `c-colon-type-list-kwds'.
(c-forward-id-comma-list type nil))))
(goto-char safe-pos)
+ (unless stop-at-end
+ (c-forward-syntactic-ws))
t)))
;; cc-mode requires cc-fonts.
@@ -8578,11 +8824,9 @@ multi-line strings (but not C++, for example)."
;; List that collects the positions after the argument
;; separating ',' in the arglist.
arg-start-pos)
- ;; If the '<' has paren open syntax then we've marked it as an angle
- ;; bracket arglist before, so skip to the end.
- (if (and syntax-table-prop-on-<
- (or (not c-parse-and-markup-<>-arglists)
- (c-get-char-property (point) 'c-<>-c-types-set)))
+ (if (and (not c-parse-and-markup-<>-arglists)
+ syntax-table-prop-on-<)
+
(progn
(forward-char)
(if (and (c-go-up-list-forward)
@@ -8679,7 +8923,6 @@ multi-line strings (but not C++, for example)."
(c-unmark-<->-as-paren (point)))))
(c-mark-<-as-paren start)
(c-mark->-as-paren (1- (point)))
- (c-put-char-property start 'c-<>-c-types-set t)
(c-truncate-lit-pos-cache start))
(setq res t)
nil)) ; Exit the loop.
@@ -8762,7 +9005,7 @@ multi-line strings (but not C++, for example)."
(if res
(or c-record-found-types t)))))
-(defun c-backward-<>-arglist (all-types &optional limit)
+(defun c-backward-<>-arglist (all-types &optional limit restricted-function)
;; The point is assumed to be directly after a ">". Try to treat it
;; as the close paren of an angle bracket arglist and move back to
;; the corresponding "<". If successful, the point is left at
@@ -8771,7 +9014,12 @@ multi-line strings (but not C++, for example)."
;; `c-forward-<>-arglist'.
;;
;; If the optional LIMIT is given, it bounds the backward search.
- ;; It's then assumed to be at a syntactically relevant position.
+ ;; It's then assumed to be at a syntactically relevant position. If
+ ;; RESTRICTED-FUNCTION is non-nil, it should be a function taking no
+ ;; arguments, called with point at a < at the start of a purported
+ ;; <>-arglist, which will return the value of
+ ;; `c-restricted-<>-arglists' to be used in the `c-forward-<>-arglist'
+ ;; call starting at that <.
;;
;; This is a wrapper around `c-forward-<>-arglist'. See that
;; function for more details.
@@ -8807,7 +9055,11 @@ multi-line strings (but not C++, for example)."
t
(backward-char)
- (let ((beg-pos (point)))
+ (let ((beg-pos (point))
+ (c-restricted-<>-arglists
+ (if restricted-function
+ (funcall restricted-function)
+ c-restricted-<>-arglists)))
(if (c-forward-<>-arglist all-types)
(cond ((= (point) start)
;; Matched the arglist. Break the while.
@@ -8827,11 +9079,12 @@ multi-line strings (but not C++, for example)."
(/= (point) start))))
-(defun c-forward-name ()
- ;; Move forward over a complete name if at the beginning of one,
- ;; stopping at the next following token. A keyword, as such,
- ;; doesn't count as a name. If the point is not at something that
- ;; is recognized as a name then it stays put.
+(defun c-forward-name (&optional stop-at-end)
+ ;; Move forward over a complete name if at the beginning of one, stopping
+ ;; either at the next following token or (when STOP-AT-END is non-nil) at
+ ;; the end of the name. A keyword, as such, doesn't count as a name. If
+ ;; the point is not at something that is recognized as a name then it stays
+ ;; put.
;;
;; A name could be something as simple as "foo" in C or something as
;; complex as "X<Y<class A<int>::B, BIT_MAX >> b>, ::operator<> ::
@@ -8853,7 +9106,7 @@ multi-line strings (but not C++, for example)."
;;
;; This function might do hidden buffer changes.
- (let ((pos (point)) (start (point)) res id-start id-end
+ (let ((pos (point)) pos2 pos3 (start (point)) res id-start id-end
;; Turn off `c-promote-possible-types' here since we might
;; call `c-forward-<>-arglist' and we don't want it to promote
;; every suspect thing in the arglist to a type. We're
@@ -8895,7 +9148,7 @@ multi-line strings (but not C++, for example)."
(c-forward-syntactic-ws lim+)
(cond ((eq (char-before id-end) ?e)
;; Got "... ::template".
- (let ((subres (c-forward-name)))
+ (let ((subres (c-forward-name t)))
(when subres
(setq pos (point)
res subres))))
@@ -8907,7 +9160,7 @@ multi-line strings (but not C++, for example)."
(and (eq (c-forward-token-2) 0)
(not (eq (char-after) ?\())))))
;; Got a cast operator.
- (when (c-forward-type)
+ (when (c-forward-type nil t)
(setq pos (point)
res 'operator)
;; Now we should match a sequence of either
@@ -8931,8 +9184,8 @@ multi-line strings (but not C++, for example)."
(forward-char)
t)))))
(while (progn
- (c-forward-syntactic-ws lim+)
(setq pos (point))
+ (c-forward-syntactic-ws lim+)
(and
(<= (point) lim+)
(looking-at c-opt-type-modifier-key)))
@@ -8947,30 +9200,34 @@ multi-line strings (but not C++, for example)."
;; operator"" has an (?)optional tag after it.
(progn
(goto-char (match-end 0))
+ (setq pos2 (point))
(c-forward-syntactic-ws lim+)
(when (c-on-identifier)
- (c-forward-token-2 1 nil lim+)))
- (goto-char (match-end 0))
- (c-forward-syntactic-ws lim+))
- (setq pos (point)
+ (c-forward-over-token nil lim+)))
+ (goto-char (match-end 0))
+ (setq pos2 (point))
+ (c-forward-syntactic-ws lim+))
+ (setq pos pos2
res 'operator)))
nil)
;; `id-start' is equal to `id-end' if we've jumped over
;; an identifier that doesn't end with a symbol token.
- ;; That can occur e.g. for Java import directives on the
+ ;; That can occur e.g. for Java import directives of the
;; form "foo.bar.*".
(when (and id-start (/= id-start id-end))
(setq c-last-identifier-range
(cons id-start id-end)))
(goto-char id-end)
+ (setq pos (point))
(c-forward-syntactic-ws lim+)
- (setq pos (point)
- res t)))
+ (setq res t)))
(progn
(goto-char pos)
+ (c-forward-syntactic-ws lim+)
+ (setq pos3 (point))
(when (or c-opt-identifier-concat-key
c-recognize-<>-arglists)
@@ -8981,7 +9238,6 @@ multi-line strings (but not C++, for example)."
;; cases with tricky syntactic whitespace that aren't
;; covered in `c-identifier-key'.
(goto-char (match-end 0))
- (c-forward-syntactic-ws lim+)
t)
((and c-recognize-<>-arglists
@@ -8993,11 +9249,12 @@ multi-line strings (but not C++, for example)."
;; `lim+'.
(setq lim+ (c-determine-+ve-limit 500))
+ (setq pos2 (point))
(c-forward-syntactic-ws lim+)
(unless (eq (char-after) ?\()
(setq c-last-identifier-range nil)
- (c-add-type start (1+ pos)))
- (setq pos (point))
+ (c-add-type start (1+ pos3)))
+ (setq pos pos2)
(if (and c-opt-identifier-concat-key
(looking-at c-opt-identifier-concat-key))
@@ -9007,7 +9264,7 @@ multi-line strings (but not C++, for example)."
(progn
(when (and c-record-type-identifiers id-start)
(c-record-ref-id (cons id-start id-end)))
- (forward-char 2)
+ (goto-char (match-end 0))
(c-forward-syntactic-ws lim+)
t)
@@ -9019,11 +9276,14 @@ multi-line strings (but not C++, for example)."
)))))
(goto-char pos)
+ (unless stop-at-end
+ (c-forward-syntactic-ws lim+))
res))
-(defun c-forward-type (&optional brace-block-too)
+(defun c-forward-type (&optional brace-block-too stop-at-end)
;; Move forward over a type spec if at the beginning of one,
- ;; stopping at the next following token. The keyword "typedef"
+ ;; stopping at the next following token (if STOP-AT-END is nil) or
+ ;; at the end of the type spec (otherwise). The keyword "typedef"
;; isn't part of a type spec here.
;;
;; BRACE-BLOCK-TOO, when non-nil, means move over the brace block in
@@ -9062,7 +9322,7 @@ multi-line strings (but not C++, for example)."
(c-forward-syntactic-ws))
(let ((start (point)) pos res name-res id-start id-end id-range
- post-prefix-pos)
+ post-prefix-pos prefix-end-pos)
;; Skip leading type modifiers. If any are found we know it's a
;; prefix of a type.
@@ -9072,6 +9332,8 @@ multi-line strings (but not C++, for example)."
(when (looking-at c-no-type-key)
(setq res 'no-id)))
(goto-char (match-end 1))
+ (setq prefix-end-pos (point))
+ (setq pos (point))
(c-forward-syntactic-ws)
(or (eq res 'no-id)
(setq res 'prefix))))
@@ -9080,32 +9342,41 @@ multi-line strings (but not C++, for example)."
(cond
((looking-at c-typeof-key) ; e.g. C++'s "decltype".
(goto-char (match-end 1))
+ (setq pos (point))
(c-forward-syntactic-ws)
(setq res (and (eq (char-after) ?\()
(c-safe (c-forward-sexp))
'decltype))
(if res
- (c-forward-syntactic-ws)
+ (progn
+ (setq pos (point))
+ (c-forward-syntactic-ws))
(goto-char start)))
((looking-at c-type-prefix-key) ; e.g. "struct", "class", but NOT
; "typedef".
(goto-char (match-end 1))
+ (setq pos (point))
(c-forward-syntactic-ws)
(while (cond
((looking-at c-decl-hangon-key)
- (c-forward-keyword-clause 1))
+ (c-forward-keyword-clause 1 t)
+ (setq pos (point))
+ (c-forward-syntactic-ws))
((looking-at c-pack-key)
(goto-char (match-end 1))
+ (setq pos (point))
(c-forward-syntactic-ws))
((and c-opt-cpp-prefix
(looking-at c-noise-macro-with-parens-name-re))
- (c-forward-noise-clause))))
+ (c-forward-noise-clause t)
+ (setq pos (point))
+ (c-forward-syntactic-ws))))
+ (setq id-start (point))
+ (setq name-res (c-forward-name t))
(setq pos (point))
-
- (setq name-res (c-forward-name))
(setq res (not (null name-res)))
(when (eq name-res t)
;; With some keywords the name can be used without the prefix, so we
@@ -9113,21 +9384,21 @@ multi-line strings (but not C++, for example)."
(when (save-excursion
(goto-char post-prefix-pos)
(looking-at c-self-contained-typename-key))
- (c-add-type pos (save-excursion
- (c-backward-syntactic-ws)
- (point))))
+ (c-add-type id-start
+ (point)))
(when (and c-record-type-identifiers
c-last-identifier-range)
(c-record-type-id c-last-identifier-range)))
+ (c-forward-syntactic-ws)
(when (and brace-block-too
(memq res '(t nil))
(eq (char-after) ?\{)
(save-excursion
(c-safe
(progn (c-forward-sexp)
- (c-forward-syntactic-ws)
(setq pos (point))))))
(goto-char pos)
+ (c-forward-syntactic-ws)
(setq res t))
(unless res (goto-char start))) ; invalid syntax
@@ -9141,7 +9412,7 @@ multi-line strings (but not C++, for example)."
(if (looking-at c-identifier-start)
(save-excursion
(setq id-start (point)
- name-res (c-forward-name))
+ name-res (c-forward-name t))
(when name-res
(setq id-end (point)
id-range c-last-identifier-range))))
@@ -9154,8 +9425,9 @@ multi-line strings (but not C++, for example)."
(>= (save-excursion
(save-match-data
(goto-char (match-end 1))
+ (setq pos (point))
(c-forward-syntactic-ws)
- (setq pos (point))))
+ pos))
id-end)
(setq res nil)))))
;; Looking at a primitive or known type identifier. We've
@@ -9168,62 +9440,86 @@ multi-line strings (but not C++, for example)."
(or c-promote-possible-types (eq res t)))
(c-record-type-id (cons (match-beginning 1) (match-end 1))))
- (if (and c-opt-type-component-key
+ (cond
+ ((and c-opt-type-component-key
(save-match-data
(looking-at c-opt-type-component-key)))
;; There might be more keywords for the type.
- (let (safe-pos)
- (c-forward-keyword-clause 1)
- (while (progn
- (setq safe-pos (point))
- (looking-at c-opt-type-component-key))
- (when (and c-record-type-identifiers
- (looking-at c-primitive-type-key))
- (c-record-type-id (cons (match-beginning 1)
- (match-end 1))))
- (c-forward-keyword-clause 1))
- (if (looking-at c-primitive-type-key)
- (progn
- (when c-record-type-identifiers
- (c-record-type-id (cons (match-beginning 1)
- (match-end 1))))
- (c-forward-keyword-clause 1)
- (setq res t))
- (goto-char safe-pos)
- (setq res 'prefix)))
- (unless (save-match-data (c-forward-keyword-clause 1))
- (if pos
- (goto-char pos)
- (goto-char (match-end 1))
- (c-forward-syntactic-ws)))))
+ (let (safe-pos)
+ (c-forward-keyword-clause 1 t)
+ (while (progn
+ (setq safe-pos (point))
+ (c-forward-syntactic-ws)
+ (looking-at c-opt-type-component-key))
+ (when (and c-record-type-identifiers
+ (looking-at c-primitive-type-key))
+ (c-record-type-id (cons (match-beginning 1)
+ (match-end 1))))
+ (c-forward-keyword-clause 1 t))
+ (if (looking-at c-primitive-type-key)
+ (progn
+ (when c-record-type-identifiers
+ (c-record-type-id (cons (match-beginning 1)
+ (match-end 1))))
+ (c-forward-keyword-clause 1 t)
+ (setq res t)
+ (while (progn
+ (setq safe-pos (point))
+ (c-forward-syntactic-ws)
+ (looking-at c-opt-type-component-key))
+ (c-forward-keyword-clause 1 t)))
+ (goto-char safe-pos)
+ (setq res 'prefix))
+ (setq pos (point))))
+ ((save-match-data (c-forward-keyword-clause 1 t))
+ (while (progn
+ (setq pos (point))
+ (c-forward-syntactic-ws)
+ (and c-opt-type-component-key
+ (looking-at c-opt-type-component-key)))
+ (c-forward-keyword-clause 1 t)))
+ (pos (goto-char pos))
+ (t (goto-char (match-end 1))
+ (setq pos (point))))
+ (c-forward-syntactic-ws))
((and (eq name-res t)
(eq res 'prefix)
(c-major-mode-is 'c-mode)
(save-excursion
(goto-char id-end)
+ (setq pos (point))
+ (c-forward-syntactic-ws)
(and (not (looking-at c-symbol-start))
- (not (looking-at c-type-decl-prefix-key)))))
+ (or
+ (not (looking-at c-type-decl-prefix-key))
+ (and (eq (char-after) ?\()
+ (not (save-excursion
+ (c-forward-declarator))))))))
;; A C specifier followed by an implicit int, e.g.
;; "register count;"
- (goto-char id-start)
+ (goto-char prefix-end-pos)
+ (setq pos (point))
+ (unless stop-at-end
+ (c-forward-syntactic-ws))
(setq res 'no-id))
(name-res
(cond ((eq name-res t)
;; A normal identifier.
(goto-char id-end)
+ (setq pos (point))
+ (c-forward-syntactic-ws)
(if (or res c-promote-possible-types)
(progn
(when (not (eq c-promote-possible-types 'just-one))
- (c-add-type id-start (save-excursion
- (goto-char id-end)
- (c-backward-syntactic-ws)
- (point))))
+ (c-add-type id-start id-end))
(when (and c-record-type-identifiers id-range)
(c-record-type-id id-range))
(unless res
- (setq res 'found)))
+ (setq res 'found))
+ (when (eq res 'prefix)
+ (setq res t)))
(setq res (if (c-check-qualified-type id-start)
;; It's an identifier that has been used as
;; a type somewhere else.
@@ -9233,6 +9529,7 @@ multi-line strings (but not C++, for example)."
((eq name-res 'template)
;; A template is sometimes a type.
(goto-char id-end)
+ (setq pos (point))
(c-forward-syntactic-ws)
(setq res
(if (eq (char-after) ?\()
@@ -9258,6 +9555,7 @@ multi-line strings (but not C++, for example)."
(when c-opt-type-modifier-key
(while (looking-at c-opt-type-modifier-key) ; e.g. "const", "volatile"
(goto-char (match-end 1))
+ (setq pos (point))
(c-forward-syntactic-ws)
(setq res t)))
@@ -9268,11 +9566,13 @@ multi-line strings (but not C++, for example)."
(when c-opt-type-suffix-key ; e.g. "..."
(while (looking-at c-opt-type-suffix-key)
(goto-char (match-end 1))
+ (setq pos (point))
(c-forward-syntactic-ws)))
;; Skip any "WS" identifiers (e.g. "final" or "override" in C++)
(while (looking-at c-type-decl-suffix-ws-ids-key)
(goto-char (match-end 1))
+ (setq pos (point))
(c-forward-syntactic-ws)
(setq res t))
@@ -9296,7 +9596,8 @@ multi-line strings (but not C++, for example)."
(progn
(goto-char (match-end 1))
(c-forward-syntactic-ws)
- (setq subres (c-forward-type))))
+ (setq subres (c-forward-type nil t))
+ (setq pos (point))))
(progn
;; If either operand certainly is a type then both are, but we
@@ -9332,9 +9633,11 @@ multi-line strings (but not C++, for example)."
;; `nconc' doesn't mind that the tail of
;; `c-record-found-types' is t.
(nconc c-record-found-types
- c-record-type-identifiers))))
+ c-record-type-identifiers)))))))
- (goto-char pos))))
+ (goto-char pos)
+ (unless stop-at-end
+ (c-forward-syntactic-ws))
(when (and c-record-found-types (memq res '(known found)) id-range)
(setq c-record-found-types
@@ -9373,19 +9676,24 @@ multi-line strings (but not C++, for example)."
(setq ,ps (cdr ,ps)))))
(defun c-forward-over-compound-identifier ()
- ;; Go over a possibly compound identifier, such as C++'s Foo::Bar::Baz,
- ;; returning that identifier (with any syntactic WS removed). Return nil if
- ;; we're not at an identifier.
- (when (c-on-identifier)
+ ;; Go over a possibly compound identifier (but not any following
+ ;; whitespace), such as C++'s Foo::Bar::Baz, returning that identifier (with
+ ;; any syntactic WS removed). Return nil if we're not at an identifier, in
+ ;; which case point is not moved.
+ (when
+ (eq (c-on-identifier)
+ (point))
(let ((consolidated "") (consolidated-:: "")
- start end)
+ (here (point))
+ start end end-token)
(while
(progn
(setq start (point))
(c-forward-over-token)
(setq consolidated
(concat consolidated-::
- (buffer-substring-no-properties start (point))))
+ (buffer-substring-no-properties start (point)))
+ end-token (point))
(c-forward-syntactic-ws)
(and c-opt-identifier-concat-key
(looking-at c-opt-identifier-concat-key)
@@ -9400,7 +9708,9 @@ multi-line strings (but not C++, for example)."
(concat consolidated
(buffer-substring-no-properties start end))))))))
(if (equal consolidated "")
- nil
+ (progn (goto-char here)
+ nil)
+ (goto-char end-token)
consolidated))))
(defun c-back-over-compound-identifier ()
@@ -9573,13 +9883,16 @@ point unchanged and return nil."
;; Handling of large scale constructs like statements and declarations.
-(defun c-forward-primary-expression (&optional limit)
- ;; Go over the primary expression (if any) at point, moving to the next
- ;; token and return non-nil. If we're not at a primary expression leave
- ;; point unchanged and return nil.
+(defun c-forward-primary-expression (&optional limit stop-at-end)
+ ;; Go over the primary expression (if any) at point, and unless STOP-AT-END
+ ;; is non-nil, move to the next token then return non-nil. If we're not at
+ ;; a primary expression leave point unchanged and return nil.
;;
;; Note that this function is incomplete, handling only those cases expected
;; to be common in a C++20 requires clause.
+ ;;
+ ;; Note also that (...) is not recognized as a primary expression if the
+ ;; next token is an open brace.
(let ((here (point))
(c-restricted-<>-arglists t)
(c-parse-and-markup-<>-arglists nil)
@@ -9587,28 +9900,38 @@ point unchanged and return nil."
(if (cond
((looking-at c-constant-key)
(goto-char (match-end 1))
- (c-forward-syntactic-ws limit)
+ (unless stop-at-end (c-forward-syntactic-ws limit))
t)
((eq (char-after) ?\()
(and (c-go-list-forward (point) limit)
(eq (char-before) ?\))
- (progn (c-forward-syntactic-ws limit)
- t)))
+ (let ((after-paren (point)))
+ (c-forward-syntactic-ws limit)
+ (prog1
+ (not (eq (char-after) ?{))
+ (when stop-at-end
+ (goto-char after-paren))))))
((c-forward-over-compound-identifier)
- (c-forward-syntactic-ws limit)
- (while (cond
- ((looking-at "<")
- (prog1
- (c-forward-<>-arglist nil)
- (c-forward-syntactic-ws limit)))
- ((looking-at c-opt-identifier-concat-key)
- (and
- (zerop (c-forward-token-2 1 nil limit))
- (prog1
- (c-forward-over-compound-identifier)
- (c-forward-syntactic-ws limit))))))
- t)
- ((looking-at c-fun-name-substitute-key) ; "requires"
+ (let ((after-id (point)))
+ (c-forward-syntactic-ws limit)
+ (while (cond
+ ((and
+ (looking-at "<")
+ (prog1
+ (and
+ (c-forward-<>-arglist nil)
+ (setq after-id (point)))))
+ (c-forward-syntactic-ws limit))
+ ((looking-at c-opt-identifier-concat-key)
+ (and
+ (zerop (c-forward-token-2 1 nil limit))
+ (prog1
+ (c-forward-over-compound-identifier)
+ (c-forward-syntactic-ws limit))))))
+ (goto-char after-id)))
+ ((and
+ (looking-at c-fun-name-substitute-key) ; "requires"
+ (not (eq (char-after (match-end 0)) ?_)))
(goto-char (match-end 1))
(c-forward-syntactic-ws limit)
(and
@@ -9621,36 +9944,47 @@ point unchanged and return nil."
(and (c-go-list-forward (point) limit)
(eq (char-before) ?}))
(progn
- (c-forward-syntactic-ws limit)
+ (unless stop-at-end (c-forward-syntactic-ws limit))
t))))
t
(goto-char here)
nil)))
-(defun c-forward-c++-requires-clause (&optional limit)
- ;; Point is at the keyword "requires". Move forward over the requires
- ;; clause to the next token after it and return non-nil. If there is no
- ;; valid requires clause at point, leave point unmoved and return nil.
+(defun c-forward-constraint-clause (&optional limit stop-at-end)
+ ;; Point is at the putative start of a constraint clause. Move to its end
+ ;; (when STOP-AT-END is non-zero) or the token after that (otherwise) and
+ ;; return non-nil. Return nil without moving if we fail to find a
+ ;; constraint.
(let ((here (point))
final-point)
(or limit (setq limit (point-max)))
- (if (and
- (zerop (c-forward-token-2 1 nil limit)) ; over "requires".
- (prog1
- (c-forward-primary-expression limit)
- (setq final-point (point))
- (while
- (and (looking-at "\\(?:&&\\|||\\)")
- (progn (goto-char (match-end 0))
- (c-forward-syntactic-ws limit)
- (and (< (point) limit)
- (c-forward-primary-expression limit))))
- (setq final-point (point)))))
- (progn (goto-char final-point)
- t)
+ (if (c-forward-primary-expression limit t)
+ (progn
+ (setq final-point (point))
+ (c-forward-syntactic-ws limit)
+ (while
+ (and (looking-at "\\(?:&&\\|||\\)")
+ (<= (match-end 0) limit)
+ (progn (goto-char (match-end 0))
+ (c-forward-syntactic-ws limit)
+ (and (<= (point) limit)))
+ (c-forward-primary-expression limit t)
+ (setq final-point (point))))
+ (goto-char final-point)
+ (or stop-at-end (c-forward-syntactic-ws limit))
+ t)
(goto-char here)
nil)))
+(defun c-forward-c++-requires-clause (&optional limit stop-at-end)
+ ;; Point is at the keyword "requires". Move forward over the requires
+ ;; clause to its end (if STOP-AT-END is non-nil) or the next token after it
+ ;; (otherwise) and return non-nil. If there is no valid requires clause at
+ ;; point, leave point unmoved and return nil.
+ (or limit (setq limit (point-max)))
+ (and (zerop (c-forward-token-2)) ; over "requires".
+ (c-forward-constraint-clause limit stop-at-end)))
+
(defun c-forward-decl-arglist (not-top id-in-parens &optional limit)
;; Point is at an open parenthesis, assumed to be the arglist of a function
;; declaration. Move over this arglist and following syntactic whitespace,
@@ -9737,7 +10071,7 @@ point unchanged and return nil."
;; (e.g. "," or ";" or "}").
(let ((here (point))
id-start id-end brackets-after-id paren-depth decorated
- got-init arglist double-double-quote)
+ got-init arglist double-double-quote pos)
(or limit (setq limit (point-max)))
(if (and
(< (point) limit)
@@ -9771,6 +10105,7 @@ point unchanged and return nil."
(eq (char-after (1+ (point))) ?\"))
(setq double-double-quote t))
(goto-char (match-end 0))
+ (setq pos (point))
(c-forward-syntactic-ws limit)
(setq got-identifier t)
nil)
@@ -9783,7 +10118,10 @@ point unchanged and return nil."
;; prefix only if it specifies a member pointer.
(progn
(setq id-start (point))
- (when (c-forward-name)
+ (when (c-forward-name t)
+ (setq pos (point))
+ (c-forward-syntactic-ws limit)
+
(if (save-match-data
(looking-at "\\(::\\)"))
;; We only check for a trailing "::" and
@@ -9812,10 +10150,12 @@ point unchanged and return nil."
(setq id-start (point)))
(cond
((or got-identifier
- (c-forward-name))
- (save-excursion
- (c-backward-syntactic-ws)
- (setq id-end (point))))
+ (c-forward-name t))
+ (setq id-end
+ (or pos
+ (point)))
+ (c-forward-syntactic-ws limit)
+ t)
(accept-anon
(setq id-start nil id-end nil)
t)
@@ -9846,7 +10186,9 @@ point unchanged and return nil."
((looking-at c-type-decl-suffix-key)
(cond
((save-match-data
- (looking-at c-fun-name-substitute-key))
+ (and
+ (looking-at c-fun-name-substitute-key)
+ (not (eq (char-after (match-end 0)) ?_))))
(c-forward-c++-requires-clause))
((eq (char-after) ?\()
(if (c-forward-decl-arglist not-top decorated limit)
@@ -9883,7 +10225,11 @@ point unchanged and return nil."
(prog1
(setq found
(c-syntactic-re-search-forward
- "[;:,]\\|\\(=\\|\\s(\\)"
+ ;; Consider making the next regexp a
+ ;; c-lang-defvar (2023-07-04).
+ (if (c-major-mode-is 'objc-mode)
+ "\\(?:@end\\)\\|[;:,]\\|\\(=\\|[[(]\\)"
+ "[;:,]\\|\\(=\\|\\s(\\)")
limit 'limit t))
(setq got-init
(and found (match-beginning 1))))
@@ -10060,6 +10406,24 @@ This function might do hidden buffer changes."
;; This identifier is bound only in the inner let.
'(setq start id-start))))
+(defmacro c-fdoc-assymetric-space-about-asterisk ()
+ ;; We've got a "*" at `id-start' between two identifiers, the first at
+ ;; `type-start'. Return non-nil when there is either whitespace between the
+ ;; first id and the "*" or between the "*" and the second id, but not both.
+ `(let ((space-before-id
+ (save-excursion
+ (goto-char id-start) ; Position of "*".
+ (and (> (skip-chars-forward "* \t\n\r") 0)
+ (memq (char-before) '(?\ ?\t ?\n ?\r)))))
+ (space-after-type
+ (save-excursion
+ (goto-char type-start)
+ (and (c-forward-type nil t)
+ (or (eolp)
+ (memq (char-after) '(?\ ?\t)))))))
+ (not (eq (not space-before-id)
+ (not space-after-type)))))
+
(defun c-forward-decl-or-cast-1 (preceding-token-end context last-cast-end
&optional inside-macro)
;; Move forward over a declaration or a cast if at the start of one.
@@ -10282,7 +10646,9 @@ This function might do hidden buffer changes."
(when (and (c-major-mode-is 'c++-mode)
(c-keyword-member kwd-sym 'c-<>-sexp-kwds)
(save-match-data
- (looking-at c-fun-name-substitute-key)))
+ (and
+ (looking-at c-fun-name-substitute-key)
+ (not (eq (char-after (match-end 0)) ?_)))))
(c-forward-c++-requires-clause))
(setq kwd-clause-end (point))))
((and c-opt-cpp-prefix
@@ -10477,6 +10843,10 @@ This function might do hidden buffer changes."
got-parens
;; True if there is a terminated argument list.
got-arglist
+ ;; True when `got-arglist' and the token after the end of the
+ ;; arglist is an opening brace. Used only when we have a
+ ;; suspected typeless function name.
+ got-stmt-block
;; True if there is an identifier in the declarator.
got-identifier
;; True if we find a number where an identifier was expected.
@@ -10569,11 +10939,11 @@ This function might do hidden buffer changes."
(or got-identifier
(and (looking-at c-identifier-start)
(setq pos (point))
- (setq got-identifier (c-forward-name))
+ (setq got-identifier (c-forward-name t))
(save-excursion
- (c-backward-syntactic-ws)
(c-simple-skip-symbol-backward)
(setq identifier-start (point)))
+ (progn (c-forward-syntactic-ws) t)
(setq name-start pos))
(when (looking-at "[0-9]")
(setq got-number t)) ; We probably have an arithmetic expression.
@@ -10629,10 +10999,16 @@ This function might do hidden buffer changes."
(setq got-arglist t))
t)
(when (cond
+ ((and (eq (char-after) ?\()
+ (c-safe (c-forward-sexp 1) t))
+ (when (eq (char-before) ?\))
+ (setq got-arglist t)))
((save-match-data (looking-at "\\s("))
(c-safe (c-forward-sexp 1) t))
((save-match-data
- (looking-at c-fun-name-substitute-key)) ; C++ requires
+ (and
+ (looking-at c-fun-name-substitute-key)
+ (not (eq (char-after (match-end 0)) ?_)))) ; C++ requires
(c-forward-c++-requires-clause))
(t (goto-char (match-end 1))
t))
@@ -10641,6 +11017,11 @@ This function might do hidden buffer changes."
(setq got-suffix-after-parens (match-beginning 0)))
(setq got-suffix t))))
+ ((and got-arglist
+ (eq (char-after) ?{))
+ (setq got-stmt-block t)
+ nil)
+
(t
;; No suffix matched. We might have matched the
;; identifier as a type and the open paren of a
@@ -10709,9 +11090,17 @@ This function might do hidden buffer changes."
(not (memq context '(arglist decl))))
(or (and new-style-auto
(looking-at c-auto-ops-re))
- (and (or maybe-typeless backup-maybe-typeless)
- (not got-prefix)
- at-type)))
+ (and (not got-prefix)
+ at-type
+ (or maybe-typeless backup-maybe-typeless
+ ;; Do we have a (typeless) constructor?
+ (and got-stmt-block
+ (save-excursion
+ (goto-char type-start)
+ (and
+ (looking-at c-identifier-key)
+ (c-directly-in-class-called-p
+ (match-string 0)))))))))
;; Have found no identifier but `c-typeless-decl-kwds' has
;; matched so we know we're inside a declaration. The
;; preceding type must be the identifier instead.
@@ -10796,8 +11185,7 @@ This function might do hidden buffer changes."
type-start
(progn
(goto-char type-start)
- (c-forward-type)
- (c-backward-syntactic-ws)
+ (c-forward-type nil t)
(point)))))))))
;; Got a declaration of the form "foo bar (gnu);" or "bar
;; (gnu);" where we've recognized "bar" as the type and "gnu"
@@ -11081,19 +11469,25 @@ This function might do hidden buffer changes."
;; CASE 16
(when (and got-prefix-before-parens
at-type
- (or at-decl-end (looking-at "=[^=]"))
(memq context '(nil top))
(or (not got-suffix)
at-decl-start))
;; Got something like "foo * bar;". Since we're not inside
;; an arglist it would be a meaningless expression because
;; the result isn't used. We therefore choose to recognize
- ;; it as a declaration. We only allow a suffix (which makes
- ;; the construct look like a function call) when
- ;; `at-decl-start' provides additional evidence that we do
- ;; have a declaration.
+ ;; it as a declaration when there's "symmetrical WS" around
+ ;; the "*" or the flag `c-asymmetry-fontification-flag' is
+ ;; not set. We only allow a suffix (which makes the
+ ;; construct look like a function call) when `at-decl-start'
+ ;; provides additional evidence that we do have a
+ ;; declaration.
(setq maybe-expression t)
- (throw 'at-decl-or-cast t))
+ (when (or (not c-asymmetry-fontification-flag)
+ (looking-at "=\\([^=]\\|$\\)\\|;")
+ (c-fdoc-assymetric-space-about-asterisk))
+ (when (eq at-type 'maybe)
+ (setq unsafe-maybe t))
+ (throw 'at-decl-or-cast t)))
;; CASE 17
(when (and (or got-suffix-after-parens
@@ -11112,25 +11506,12 @@ This function might do hidden buffer changes."
got-prefix-before-parens
at-type
(or (not got-suffix)
- at-decl-start))
- (let ((space-before-id
- (save-excursion
- (goto-char id-start) ; Position of "*".
- (and (> (skip-chars-forward "* \t\n\r") 0)
- (memq (char-before) '(?\ ?\t ?\n ?\r)))))
- (space-after-type
- (save-excursion
- (goto-char type-start)
- (and (c-forward-type)
- (progn (c-backward-syntactic-ws) t)
- (or (eolp)
- (memq (char-after) '(?\ ?\t)))))))
- (when (not (eq (not space-before-id)
- (not space-after-type)))
- (when (eq at-type 'maybe)
- (setq unsafe-maybe t))
- (setq maybe-expression t)
- (throw 'at-decl-or-cast t)))))
+ at-decl-start)
+ (c-fdoc-assymetric-space-about-asterisk))
+ (when (eq at-type 'maybe)
+ (setq unsafe-maybe t))
+ (setq maybe-expression t)
+ (throw 'at-decl-or-cast t)))
;; CASE 18
(when (and at-decl-end
@@ -11895,11 +12276,14 @@ comment at the start of cc-engine.el for more info."
;; Each time around the following checks one
;; declaration (which may contain several identifiers).
(while (and
- (consp (setq decl-or-cast
- (c-forward-decl-or-cast-1
- after-prec-token
- nil ; Or 'arglist ???
- nil)))
+ (not (eq (char-after) ?{))
+ (or
+ (consp (setq decl-or-cast
+ (c-forward-decl-or-cast-1
+ after-prec-token
+ nil ; Or 'arglist ???
+ nil)))
+ (throw 'knr nil))
(memq (char-after) '(?\; ?\,))
(goto-char (car decl-or-cast))
(save-excursion
@@ -11962,13 +12346,21 @@ comment at the start of cc-engine.el for more info."
(zerop (c-backward-token-2 1 t lim))
t)
(or (looking-at c-block-stmt-1-key)
- (and (eq (char-after) ?\()
- (zerop (c-backward-token-2 1 t lim))
- (if (looking-at c-block-stmt-hangon-key)
- (zerop (c-backward-token-2 1 t lim))
- t)
- (or (looking-at c-block-stmt-2-key)
- (looking-at c-block-stmt-1-2-key))))
+ (or
+ (and
+ (eq (char-after) ?\()
+ (zerop (c-backward-token-2 1 t lim))
+ (if (looking-at c-block-stmt-hangon-key)
+ (zerop (c-backward-token-2 1 t lim))
+ t)
+ (or (looking-at c-block-stmt-2-key)
+ (looking-at c-block-stmt-1-2-key)))
+ (and (looking-at c-paren-clause-key)
+ (zerop (c-backward-token-2 1 t lim))
+ (if (looking-at c-negation-op-re)
+ (zerop (c-backward-token-2 1 t lim))
+ t)
+ (looking-at c-block-stmt-with-key))))
(point))))
(defun c-after-special-operator-id (&optional lim)
@@ -12243,31 +12635,27 @@ comment at the start of cc-engine.el for more info."
(let ((open-brace (point)) kwd-start first-specifier-pos)
(c-syntactic-skip-backward c-block-prefix-charset limit t)
- (when (and c-recognize-<>-arglists
- (eq (char-before) ?>))
- ;; Could be at the end of a template arglist.
- (let ((c-parse-and-markup-<>-arglists t))
- (while (and
- (c-backward-<>-arglist nil limit)
- (progn
- (c-syntactic-skip-backward c-block-prefix-charset limit t)
- (eq (char-before) ?>))))))
-
- ;; Skip back over noise clauses.
- (while (and
- c-opt-cpp-prefix
- (eq (char-before) ?\))
- (let ((after-paren (point)))
- (if (and (c-go-list-backward)
- (progn (c-backward-syntactic-ws)
- (c-simple-skip-symbol-backward))
- (or (looking-at c-paren-nontype-key)
- (looking-at c-noise-macro-with-parens-name-re)))
- (progn
- (c-syntactic-skip-backward c-block-prefix-charset limit t)
- t)
- (goto-char after-paren)
- nil))))
+ (while
+ (or
+ ;; Could be after a template arglist....
+ (and c-recognize-<>-arglists
+ (eq (char-before) ?>)
+ (let ((c-parse-and-markup-<>-arglists t))
+ (c-backward-<>-arglist nil limit)))
+ ;; .... or after a noise clause with parens.
+ (and c-opt-cpp-prefix
+ (let ((after-paren (point)))
+ (if (eq (char-before) ?\))
+ (and
+ (c-go-list-backward)
+ (eq (char-after) ?\()
+ (progn (c-backward-syntactic-ws)
+ (c-simple-skip-symbol-backward))
+ (or (looking-at c-paren-nontype-key) ; e.g. __attribute__
+ (looking-at c-noise-macro-with-parens-name-re)))
+ (goto-char after-paren)
+ nil))))
+ (c-syntactic-skip-backward c-block-prefix-charset limit t))
;; Note: Can't get bogus hits inside template arglists below since they
;; have gotten paren syntax above.
@@ -12277,10 +12665,18 @@ comment at the start of cc-engine.el for more info."
;; The `c-decl-block-key' search continues from there since
;; we know it can't match earlier.
(if goto-start
- (when (c-syntactic-re-search-forward c-symbol-start
- open-brace t t)
- (goto-char (setq first-specifier-pos (match-beginning 0)))
- t)
+ (progn
+ (while
+ (and
+ (c-syntactic-re-search-forward c-symbol-start
+ open-brace t t)
+ (goto-char (match-beginning 0))
+ (if (or (looking-at c-noise-macro-name-re)
+ (looking-at c-noise-macro-with-parens-name-re))
+ (c-forward-noise-clause)
+ (setq first-specifier-pos (match-beginning 0))
+ nil)))
+ first-specifier-pos)
t)
(cond
@@ -12349,34 +12745,39 @@ comment at the start of cc-engine.el for more info."
(goto-char first-specifier-pos)
(while (< (point) kwd-start)
- (if (looking-at c-symbol-key)
- ;; Accept any plain symbol token on the ground that
- ;; it's a specifier masked through a macro (just
- ;; like `c-forward-decl-or-cast-1' skip forward over
- ;; such tokens).
- ;;
- ;; Could be more restrictive wrt invalid keywords,
- ;; but that'd only occur in invalid code so there's
- ;; no use spending effort on it.
- (let ((end (match-end 0))
- (kwd-sym (c-keyword-sym (match-string 0))))
- (unless
- (and kwd-sym
- ;; Moving over a protection kwd and the following
- ;; ":" (in C++ Mode) to the next token could take
- ;; us all the way up to `kwd-start', leaving us
- ;; no chance to update `first-specifier-pos'.
- (not (c-keyword-member kwd-sym 'c-protection-kwds))
- (c-forward-keyword-clause 0))
- (goto-char end)
- (c-forward-syntactic-ws)))
-
+ (cond
+ ((or (looking-at c-noise-macro-name-re)
+ (looking-at c-noise-macro-with-parens-name-re))
+ (c-forward-noise-clause))
+ ((looking-at c-symbol-key)
+ ;; Accept any plain symbol token on the ground that
+ ;; it's a specifier masked through a macro (just
+ ;; like `c-forward-decl-or-cast-1' skips forward over
+ ;; such tokens).
+ ;;
+ ;; Could be more restrictive wrt invalid keywords,
+ ;; but that'd only occur in invalid code so there's
+ ;; no use spending effort on it.
+ (let ((end (match-end 0))
+ (kwd-sym (c-keyword-sym (match-string 0))))
+ (unless
+ (and kwd-sym
+ ;; Moving over a protection kwd and the following
+ ;; ":" (in C++ Mode) to the next token could take
+ ;; us all the way up to `kwd-start', leaving us
+ ;; no chance to update `first-specifier-pos'.
+ (not (c-keyword-member kwd-sym 'c-protection-kwds))
+ (c-forward-keyword-clause 0))
+ (goto-char end)
+ (c-forward-syntactic-ws))))
+
+ ((c-syntactic-re-search-forward c-symbol-start
+ kwd-start 'move t)
;; Can't parse a declaration preamble and is still
;; before `kwd-start'. That means `first-specifier-pos'
;; was in some earlier construct. Search again.
- (if (c-syntactic-re-search-forward c-symbol-start
- kwd-start 'move t)
- (goto-char (setq first-specifier-pos (match-beginning 0)))
+ (goto-char (setq first-specifier-pos (match-beginning 0))))
+ (t
;; Got no preamble before the block declaration keyword.
(setq first-specifier-pos kwd-start))))
@@ -12401,7 +12802,8 @@ comment at the start of cc-engine.el for more info."
(looking-at c-class-key))
(goto-char (match-end 1))
(c-forward-syntactic-ws)
- (looking-at name))))))
+ (and (looking-at c-identifier-key)
+ (string= (match-string 0) name)))))))
(defun c-search-uplist-for-classkey (paren-state)
;; Check if the closest containing paren sexp is a declaration
@@ -12625,11 +13027,19 @@ comment at the start of cc-engine.el for more info."
(defvar c-laomib-cache nil)
(make-variable-buffer-local 'c-laomib-cache)
-(defun c-laomib-get-cache (containing-sexp)
- ;; Get an element from `c-laomib-cache' matching CONTAINING-SEXP.
+(defun c-laomib-get-cache (containing-sexp start)
+ ;; Get an element from `c-laomib-cache' matching CONTAINING-SEXP, and which
+ ;; is suitable for start position START.
;; Return that element or nil if one wasn't found.
- (let ((elt (assq containing-sexp c-laomib-cache)))
- (when elt
+ (let ((ptr c-laomib-cache)
+ elt)
+ (while
+ (and ptr
+ (setq elt (car ptr))
+ (or (not (eq (car elt) containing-sexp))
+ (< start (car (cddr elt)))))
+ (setq ptr (cdr ptr)))
+ (when ptr
;; Move the fetched `elt' to the front of the cache.
(setq c-laomib-cache (delq elt c-laomib-cache))
(push elt c-laomib-cache)
@@ -12641,18 +13051,26 @@ comment at the start of cc-engine.el for more info."
;; the components of the new element (see comment for `c-laomib-cache').
;; The return value is of no significance.
(when lim
- (let ((old-elt (assq lim c-laomib-cache))
- ;; (elt (cons containing-sexp (cons start nil)))
+ (let (old-elt
(new-elt (list lim start end result))
big-ptr
(cur-ptr c-laomib-cache)
- togo (size 0) cur-size
- )
- (if old-elt (setq c-laomib-cache (delq old-elt c-laomib-cache)))
+ togo (size 0) cur-size)
+
+ ;; If there is an elt which overlaps with the new element, remove it.
+ (while
+ (and cur-ptr
+ (setq old-elt (car cur-ptr))
+ (or (not (eq (car old-elt) lim))
+ (not (and (> start (car (cddr old-elt)))
+ (<= start (cadr old-elt))))))
+ (setq cur-ptr (cdr cur-ptr)))
+ (when (and cur-ptr old-elt)
+ (setq c-laomib-cache (delq old-elt c-laomib-cache)))
(while (>= (length c-laomib-cache) 4)
;; We delete the least recently used elt which doesn't enclose START,
- ;; or..
+ ;; or ...
(dolist (elt c-laomib-cache)
(if (or (<= start (cadr elt))
(> start (car (cddr elt))))
@@ -12660,8 +13078,10 @@ comment at the start of cc-engine.el for more info."
;; ... delete the least recently used elt which isn't the biggest.
(when (not togo)
+ (setq cur-ptr c-laomib-cache)
(while (cdr cur-ptr)
- (setq cur-size (- (nth 2 (cadr cur-ptr)) (car (cadr cur-ptr))))
+ (setq cur-size (- (cadr (cadr cur-ptr))
+ (car (cddr (cadr cur-ptr)))))
(when (> cur-size size)
(setq size cur-size
big-ptr cur-ptr))
@@ -12763,7 +13183,9 @@ comment at the start of cc-engine.el for more info."
in-paren 'in-paren))
((looking-at c-pre-brace-non-bracelist-key)
(setq braceassignp nil))
- ((looking-at c-fun-name-substitute-key)
+ ((and
+ (looking-at c-fun-name-substitute-key)
+ (not (eq (char-after (match-end 0)) ?_)))
(setq braceassignp nil))
((looking-at c-return-key))
((and (looking-at c-symbol-start)
@@ -12778,7 +13200,8 @@ comment at the start of cc-engine.el for more info."
;; Have we a requires with a parenthesis list?
(when (save-excursion
(and (zerop (c-backward-token-2 1 nil lim))
- (looking-at c-fun-name-substitute-key)))
+ (looking-at c-fun-name-substitute-key)
+ (not (eq (char-after (match-end 0)) ?_))))
(setq braceassignp nil))
nil)
(t nil))
@@ -12850,7 +13273,7 @@ comment at the start of cc-engine.el for more info."
(goto-char pos)
(when (eq braceassignp 'dontknow)
(let* ((cache-entry (and containing-sexp
- (c-laomib-get-cache containing-sexp)))
+ (c-laomib-get-cache containing-sexp pos)))
(lim2 (or (cadr cache-entry) lim))
sub-bassign-p)
(if cache-entry
@@ -12872,6 +13295,8 @@ comment at the start of cc-engine.el for more info."
)
(setq braceassignp (nth 3 cache-entry))
(goto-char (nth 2 cache-entry)))
+ (c-laomib-put-cache containing-sexp
+ start (point) sub-bassign-p)
(setq braceassignp sub-bassign-p)))
(t))
@@ -13109,6 +13534,120 @@ comment at the start of cc-engine.el for more info."
(t nil)))
(goto-char here))))
+(defun c-forward-concept-fragment (&optional limit stop-at-end)
+ ;; Are we currently at the "concept" keyword in a concept construct? If so
+ ;; we return the position of the first constraint expression following the
+ ;; "=" sign and move forward over the constraint. Otherwise we return nil.
+ ;; LIMIT is a forward search limit.
+ (let ((here (point)))
+ (if
+ (and
+ (looking-at c-equals-nontype-decl-key) ; "concept"
+ (goto-char (match-end 0))
+ (progn (c-forward-syntactic-ws limit)
+ (not (looking-at c-keywords-regexp)))
+ (looking-at c-identifier-key)
+ (goto-char (match-end 0))
+ (progn (c-forward-syntactic-ws limit)
+ (looking-at c-operator-re))
+ (equal (match-string 0) "=")
+ (goto-char (match-end 0)))
+ (prog1
+ (progn (c-forward-syntactic-ws limit)
+ (point))
+ (c-forward-constraint-clause limit stop-at-end))
+ (goto-char here)
+ nil)))
+
+(defun c-looking-at-concept (&optional limit)
+ ;; Are we currently at the start of a concept construct? I.e. at the
+ ;; "template" keyword followed by the construct? If so, we return a cons of
+ ;; the position of "concept" and the position of the first constraint
+ ;; expression following the "=" sign, otherwise we return nil. LIMIT is a
+ ;; forward search limit.
+ (save-excursion
+ (let (conpos)
+ (and (looking-at c-pre-concept-<>-key)
+ (goto-char (match-end 1))
+ (< (point) limit)
+ (progn (c-forward-syntactic-ws limit)
+ (eq (char-after) ?<))
+ (let ((c-parse-and-markup-<>-arglists t)
+ c-restricted-<>-arglists)
+ (c-forward-<>-arglist nil))
+ (< (point) limit)
+ (progn (c-forward-syntactic-ws limit)
+ (looking-at c-equals-nontype-decl-key)) ; "concept"
+ (setq conpos (match-beginning 0))
+ (goto-char (match-end 0))
+ (< (point) limit)
+ (c-syntactic-re-search-forward
+ "=" limit t t)
+ (goto-char (match-end 0))
+ (<= (point) limit)
+ (progn (c-forward-syntactic-ws limit)
+ (cons conpos (point)))))))
+
+(defun c-in-requires-or-at-end-of-clause (&optional pos)
+ ;; Is POS (default POINT) in a C++ "requires" expression or "requires"
+ ;; clause or at the end of a "requires" clause? If so return a cons
+ ;; (POSITION . END) where POSITION is that of the "requires" keyword, and
+ ;; END is `expression' if POS is in an expression, nil if it's in a clause
+ ;; or t if it's at the end of a clause. "End of a clause" means just after
+ ;; the non syntactic WS on the line where the clause ends.
+ ;;
+ ;; Note we can't use `c-beginning-of-statement-1' in this function because
+ ;; of this function's use in `c-at-vsemi-p' for C++ Mode.
+ (save-excursion
+ (if pos (goto-char pos) (setq pos (point)))
+ (let ((limit (max (- (point) 2000) (point-min)))
+ found-req req-pos found-clause res pe-start pe-end
+ )
+ (while ; Loop around syntactically significant "requires" keywords.
+ (progn
+ (while
+ (and
+ (setq found-req (re-search-backward
+ c-fun-name-substitute-key
+ limit t)) ; Fast!
+ (or (not (setq found-req
+ (not (eq (char-after (match-end 0)) ?_))))
+ (not (setq found-req (not (c-in-literal))))))) ; Slow!
+ (setq req-pos (point))
+ (cond
+ ((not found-req) ; No "requires" found
+ nil)
+ ((save-excursion ; A primary expression `pos' is in
+ (setq pe-end nil)
+ (while (and (setq pe-start (point))
+ (< (point) pos)
+ (c-forward-primary-expression nil t)
+ (setq pe-end (point))
+ (progn (c-forward-syntactic-ws)
+ (looking-at "&&\\|||"))
+ (c-forward-over-token-and-ws)))
+ pe-end)
+ (if (<= pe-end pos)
+ t ; POS is not in a primary expression.
+ (setq res (cons pe-start 'expression))
+ nil))
+ ((progn
+ (goto-char req-pos)
+ (if (looking-at c-fun-name-substitute-key)
+ (setq found-clause (c-forward-c++-requires-clause nil t))
+ (and (c-forward-concept-fragment)
+ (setq found-clause (point))))
+ nil))
+ ((and found-clause (>= (point) pos))
+ (setq res (cons req-pos (eq (point) pos)))
+ nil)
+ (found-clause ; We found a constraint clause, but it did not
+ ; extend far enough forward to reach POS.
+ (c-go-up-list-backward req-pos limit))
+ (t (goto-char req-pos)
+ t))))
+ res)))
+
(defun c-looking-at-inexpr-block (lim containing-sexp &optional check-at-end)
;; Return non-nil if we're looking at the beginning of a block
;; inside an expression. The value returned is actually a cons of
@@ -13305,6 +13844,19 @@ comment at the start of cc-engine.el for more info."
(looking-at c-pre-lambda-tokens-re)))
(not (c-in-literal))))
+(defun c-c++-vsemi-p (&optional pos)
+ ;; C++ Only - Is there a "virtual semicolon" at POS or point?
+ ;; (See cc-defs.el for full details of "virtual semicolons".)
+ ;;
+ ;; This is true when point is at the last non syntactic WS position on the
+ ;; line, and either there is a "macro with semicolon" just before it (see
+ ;; `c-at-macro-vsemi-p') or there is a "requires" clause which ends there.
+ (let (res)
+ (cond
+ ((setq res (c-in-requires-or-at-end-of-clause pos))
+ (and res (eq (cdr res) t)))
+ ((c-at-macro-vsemi-p)))))
+
(defun c-at-macro-vsemi-p (&optional pos)
;; Is there a "virtual semicolon" at POS or point?
;; (See cc-defs.el for full details of "virtual semicolons".)
@@ -13640,7 +14192,8 @@ comment at the start of cc-engine.el for more info."
(defun c-add-class-syntax (symbol
containing-decl-open
containing-decl-start
- containing-decl-kwd)
+ containing-decl-kwd
+ &rest args)
;; The inclass and class-close syntactic symbols are added in
;; several places and some work is needed to fix everything.
;; Therefore it's collected here.
@@ -13655,7 +14208,7 @@ comment at the start of cc-engine.el for more info."
;; Ought to use `c-add-stmt-syntax' instead of backing up to boi
;; here, but we have to do like this for compatibility.
(back-to-indentation)
- (c-add-syntax symbol (point))
+ (apply #'c-add-syntax symbol (point) args)
(if (and (c-keyword-member containing-decl-kwd
'c-inexpr-class-kwds)
(/= containing-decl-start (c-point 'boi containing-decl-start)))
@@ -13689,9 +14242,10 @@ comment at the start of cc-engine.el for more info."
;; CASE B.1: class-open
((save-excursion
(and (eq (char-after) ?{)
- (c-looking-at-decl-block t)
+ (setq placeholder (c-looking-at-decl-block t))
(setq beg-of-same-or-containing-stmt (point))))
- (c-add-syntax 'class-open beg-of-same-or-containing-stmt))
+ (c-add-syntax 'class-open beg-of-same-or-containing-stmt
+ (c-point 'boi placeholder)))
;; CASE B.2: brace-list-open
((or (consp special-brace-list)
@@ -13856,7 +14410,7 @@ comment at the start of cc-engine.el for more info."
literal char-before-ip before-ws-ip char-after-ip macro-start
in-macro-expr c-syntactic-context placeholder
step-type tmpsymbol keyword injava-inher special-brace-list tmp-pos
- tmp-pos2 containing-<
+ tmp-pos2 containing-< tmp constraint-detail
;; The following record some positions for the containing
;; declaration block if we're directly within one:
;; `containing-decl-open' is the position of the open
@@ -14186,7 +14740,10 @@ comment at the start of cc-engine.el for more info."
'lambda-intro-cont)))
(goto-char (cdr placeholder))
(back-to-indentation)
- (c-add-stmt-syntax tmpsymbol nil t
+ (c-add-stmt-syntax tmpsymbol
+ (and (eq tmpsymbol 'class-open)
+ (list (point)))
+ t
(c-most-enclosing-brace state-cache (point))
paren-state)
(unless (eq (point) (cdr placeholder))
@@ -14229,9 +14786,10 @@ comment at the start of cc-engine.el for more info."
(goto-char indent-point)
(skip-chars-forward " \t")
(and (eq (char-after) ?{)
- (c-looking-at-decl-block t)
+ (setq tmp-pos (c-looking-at-decl-block t))
(setq placeholder (point))))
- (c-add-syntax 'class-open placeholder))
+ (c-add-syntax 'class-open placeholder
+ (c-point 'boi tmp-pos)))
;; CASE 5A.3: brace list open
((save-excursion
@@ -14271,6 +14829,33 @@ comment at the start of cc-engine.el for more info."
containing-decl-start
containing-decl-kwd))
+ ;; CASE 5A.7: "defun" open in a requires expression.
+ ((save-excursion
+ (goto-char indent-point)
+ (c-backward-syntactic-ws lim)
+ (and (or (not (eq (char-before) ?\)))
+ (c-go-list-backward nil lim))
+ (progn (c-backward-syntactic-ws lim)
+ (zerop (c-backward-token-2 nil nil lim)))
+ (looking-at c-fun-name-substitute-key)
+ (not (eq (char-after (match-end 0)) ?_))
+ (setq placeholder (point))))
+ (goto-char placeholder)
+ (back-to-indentation)
+ (c-add-syntax 'defun-open (point)))
+
+ ;; CASE 5A.6: "defun" open in concept.
+ ;; ((save-excursion
+ ;; (goto-char indent-point)
+ ;; (skip-chars-forward " \t")
+ ;; (and (eq (char-after) ?{)
+ ;; (eq (c-beginning-of-statement-1 lim) 'same)
+ ;; (setq placeholder
+ ;; (cdr (c-looking-at-concept indent-point)))))
+ ;; (goto-char placeholder)
+ ;; (back-to-indentation)
+ ;; (c-add-syntax 'defun-open (point)))
+
;; CASE 5A.5: ordinary defun open
(t
(save-excursion
@@ -14441,10 +15026,35 @@ comment at the start of cc-engine.el for more info."
nil nil
containing-sexp paren-state))
+ ;; CASE 5F: Close of a non-class declaration level block.
+ ((and (eq char-after-ip ?})
+ (c-keyword-member containing-decl-kwd
+ 'c-other-block-decl-kwds))
+ ;; This is inconsistent: Should use `containing-decl-open'
+ ;; here if it's at boi, like in case 5J.
+ (goto-char containing-decl-start)
+ (c-add-stmt-syntax
+ (if (string-equal (symbol-name containing-decl-kwd) "extern")
+ ;; Special case for compatibility with the
+ ;; extern-lang syntactic symbols.
+ 'extern-lang-close
+ (intern (concat (symbol-name containing-decl-kwd)
+ "-close")))
+ nil t
+ (c-most-enclosing-brace paren-state (point))
+ paren-state))
+
+ ;; CASE 5T: Continuation of a concept clause.
+ ((save-excursion
+ (and (eq (c-beginning-of-statement-1 nil t) 'same)
+ (setq tmp (c-looking-at-concept indent-point))))
+ (c-add-syntax 'constraint-cont (car tmp)))
+
;; CASE 5D: this could be a top-level initialization, a
;; member init list continuation, or a template argument
;; list continuation.
((save-excursion
+ (setq constraint-detail (c-in-requires-or-at-end-of-clause))
;; Note: We use the fact that lim is always after any
;; preceding brace sexp.
(if c-recognize-<>-arglists
@@ -14474,8 +15084,9 @@ comment at the start of cc-engine.el for more info."
;; clause - we assume only C++ needs it.
(c-syntactic-skip-backward "^;,=" lim t))
(setq placeholder (point))
- (and (memq (char-before) '(?, ?= ?<))
- (not (c-crosses-statement-barrier-p (point) indent-point))))
+ (or constraint-detail
+ (and (memq (char-before) '(?, ?= ?<))
+ (not (c-crosses-statement-barrier-p (point) indent-point)))))
(cond
;; CASE 5D.6: Something like C++11's "using foo = <type-exp>"
@@ -14493,8 +15104,7 @@ comment at the start of cc-engine.el for more info."
(c-on-identifier))
(setq placeholder preserve-point)))))
(c-add-syntax
- 'statement-cont placeholder)
- )
+ 'statement-cont placeholder))
;; CASE 5D.3: perhaps a template list continuation?
((and (c-major-mode-is 'c++-mode)
@@ -14544,21 +15154,10 @@ comment at the start of cc-engine.el for more info."
;; CASE 5D.7: Continuation of a "concept foo =" line in C++20 (or
;; similar).
- ((and c-equals-nontype-decl-key
- (save-excursion
- (prog1
- (and (zerop (c-backward-token-2 1 nil lim))
- (looking-at c-operator-re)
- (equal (match-string 0) "=")
- (zerop (c-backward-token-2 1 nil lim))
- (looking-at c-symbol-start)
- (not (looking-at c-keywords-regexp))
- (zerop (c-backward-token-2 1 nil lim))
- (looking-at c-equals-nontype-decl-key)
- (eq (c-beginning-of-statement-1 lim) 'same))
- (setq placeholder (point)))))
- (goto-char placeholder)
- (c-add-stmt-syntax 'topmost-intro-cont nil nil containing-sexp
+ ((and constraint-detail
+ (not (eq (cdr constraint-detail) 'expression)))
+ (goto-char (car constraint-detail))
+ (c-add-stmt-syntax 'constraint-cont nil nil containing-sexp
paren-state))
;; CASE 5D.5: Continuation of the "expression part" of a
@@ -14583,33 +15182,19 @@ comment at the start of cc-engine.el for more info."
nil nil containing-sexp paren-state))
))
- ;; CASE 5F: Close of a non-class declaration level block.
- ((and (eq char-after-ip ?})
- (c-keyword-member containing-decl-kwd
- 'c-other-block-decl-kwds))
- ;; This is inconsistent: Should use `containing-decl-open'
- ;; here if it's at boi, like in case 5J.
- (goto-char containing-decl-start)
- (c-add-stmt-syntax
- (if (string-equal (symbol-name containing-decl-kwd) "extern")
- ;; Special case for compatibility with the
- ;; extern-lang syntactic symbols.
- 'extern-lang-close
- (intern (concat (symbol-name containing-decl-kwd)
- "-close")))
- nil t
- (c-most-enclosing-brace paren-state (point))
- paren-state))
-
;; CASE 5G: we are looking at the brace which closes the
;; enclosing nested class decl
((and containing-sexp
(eq char-after-ip ?})
(eq containing-decl-open containing-sexp))
+ (save-excursion
+ (goto-char containing-decl-open)
+ (setq tmp-pos (c-looking-at-decl-block t)))
(c-add-class-syntax 'class-close
containing-decl-open
containing-decl-start
- containing-decl-kwd))
+ containing-decl-kwd
+ (c-point 'boi tmp-pos)))
;; CASE 5H: we could be looking at subsequent knr-argdecls
((and c-recognize-knr-p
@@ -14813,7 +15398,59 @@ comment at the start of cc-engine.el for more info."
(c-add-syntax 'topmost-intro-cont (c-point 'boi)))
))
- ;; (CASE 6 has been removed.)
+ ;; CASE 20: A C++ requires sub-clause.
+ ((and (setq tmp (c-in-requires-or-at-end-of-clause indent-point))
+ (not (eq (cdr tmp) 'expression))
+ (setq placeholder (car tmp)))
+ (c-add-syntax
+ (if (eq char-after-ip ?{)
+ 'substatement-open
+ 'substatement)
+ (c-point 'boi placeholder)))
+
+ ;; ((Old) CASE 6 has been removed.)
+ ;; CASE 6: line is within a C11 _Generic expression.
+ ((and c-generic-key
+ (eq (char-after containing-sexp) ?\()
+ (progn (setq tmp-pos (c-safe-scan-lists
+ containing-sexp 1 0
+ (min (+ (point) 2000) (point-max))))
+ t)
+ (save-excursion
+ (and
+ (progn (goto-char containing-sexp)
+ (zerop (c-backward-token-2)))
+ (looking-at c-generic-key)
+ (progn (goto-char (1+ containing-sexp))
+ (c-syntactic-re-search-forward
+ "," indent-point 'bound t t))
+ (setq placeholder (point)))))
+ (let ((res (c-syntactic-re-search-forward
+ "[,:)]"
+ (or tmp-pos (min (+ (point) 2000) (point-max)))
+ 'bound t t)))
+ (cond
+ ((and res
+ (eq (char-before) ?\))
+ (save-excursion
+ (backward-char)
+ (c-backward-syntactic-ws indent-point)
+ (eq (point) indent-point)))
+ (c-add-stmt-syntax
+ 'arglist-close (list containing-sexp) t
+ (c-most-enclosing-brace paren-state indent-point) paren-state))
+ ((or (not res)
+ (eq (char-before) ?\)))
+ (backward-char)
+ (c-syntactic-skip-backward "^,:" containing-sexp t)
+ (c-add-syntax (if (eq (char-before) ?:)
+ 'statement-case-intro
+ 'case-label)
+ (1+ containing-sexp)))
+ (t (c-add-syntax (if (eq (char-before) ?:)
+ 'case-label
+ 'statement-case-intro)
+ (1+ containing-sexp))))))
;; CASE 7: line is an expression, not a statement. Most
;; likely we are either in a function prototype or a function
@@ -15154,6 +15791,20 @@ comment at the start of cc-engine.el for more info."
(c-add-syntax 'defun-close (point))
(c-add-syntax 'inline-close (point))))
+ ;; CASE 16G: Do we have the closing brace of a "requires" clause
+ ;; of a C++20 "concept"?
+ ((save-excursion
+ (c-backward-syntactic-ws lim)
+ (and (or (not (eq (char-before) ?\)))
+ (c-go-list-backward nil lim))
+ (progn (c-backward-syntactic-ws lim)
+ (zerop (c-backward-token-2 nil nil lim)))
+ (looking-at c-fun-name-substitute-key)
+ (not (eq (char-after (match-end 0)) ?_))))
+ (goto-char containing-sexp)
+ (back-to-indentation)
+ (c-add-stmt-syntax 'defun-close nil t lim paren-state))
+
;; CASE 16F: Can be a defun-close of a function declared
;; in a statement block, e.g. in Pike or when using gcc
;; extensions, but watch out for macros followed by
@@ -15304,6 +15955,21 @@ comment at the start of cc-engine.el for more info."
(if (eq char-after-ip ?{)
(c-add-syntax 'block-open)))
+ ;; CASE 17J: first "statement" inside a C++20 requires
+ ;; "function".
+ ((save-excursion
+ (goto-char containing-sexp)
+ (c-backward-syntactic-ws lim)
+ (and (or (not (eq (char-before) ?\)))
+ (c-go-list-backward nil lim))
+ (progn (c-backward-syntactic-ws lim)
+ (zerop (c-backward-token-2 nil nil lim)))
+ (looking-at c-fun-name-substitute-key)
+ (not (eq (char-after (match-end 0)) ?_))))
+ (goto-char containing-sexp)
+ (back-to-indentation)
+ (c-add-syntax 'defun-block-intro (point)))
+
;; CASE 17F: first statement in an inline, or first
;; statement in a top-level defun. we can tell this is it
;; if there are no enclosing braces that haven't been
diff --git a/lisp/progmodes/cc-fonts.el b/lisp/progmodes/cc-fonts.el
index d4079bdd6dd..6419d6cf05a 100644
--- a/lisp/progmodes/cc-fonts.el
+++ b/lisp/progmodes/cc-fonts.el
@@ -259,14 +259,14 @@
(defmacro c-fontify-types-and-refs (varlist &rest body)
(declare (indent 1) (debug let*))
- ;; Like `let', but additionally activates `c-record-type-identifiers'
+ ;; Like `let*', but additionally activates `c-record-type-identifiers'
;; and `c-record-ref-identifiers', and fontifies the recorded ranges
;; accordingly on exit.
;;
;; This function does hidden buffer changes.
- `(let ((c-record-type-identifiers t)
- c-record-ref-identifiers
- ,@varlist)
+ `(let* ((c-record-type-identifiers t)
+ c-record-ref-identifiers
+ ,@varlist)
(prog1 (progn ,@body)
(c-fontify-recorded-types-and-refs))))
@@ -387,7 +387,7 @@
(parse-sexp-lookup-properties
(cc-eval-when-compile
(boundp 'parse-sexp-lookup-properties))))
- ,(c-make-font-lock-search-form regexp highlights))
+ ,(c-make-font-lock-search-form regexp highlights t))
nil)))
(defun c-make-font-lock-BO-decl-search-function (regexp &rest highlights)
@@ -1112,7 +1112,7 @@ casts and declarations are fontified. Used on level 2 and higher."
;; 'c-decl-type-start (according to TYPES). Stop at LIMIT.
;;
;; If TYPES is t, fontify all identifiers as types; if it is a number, a
- ;; buffer position, additionally set the `c-deftype' text property on the
+ ;; buffer position, additionally set the `c-typedef' text property on the
;; keyword at that position; if it is nil fontify as either variables or
;; functions, otherwise TYPES is a face to use. If NOT-TOP is non-nil, we
;; are not at the top-level ("top-level" includes being directly inside a
@@ -1219,6 +1219,7 @@ casts and declarations are fontified. Used on level 2 and higher."
;; inside a function declaration arglist).
;; '<> In an angle bracket arglist.
;; 'arglist Some other type of arglist.
+ ;; 'generic In a C11 _Generic construct.
;; 'top Some other context and point is at the top-level (either
;; outside any braces or directly inside a class or namespace,
;; etc.)
@@ -1345,6 +1346,15 @@ casts and declarations are fontified. Used on level 2 and higher."
(c-back-over-member-initializers)))
(c-put-char-property (1- match-pos) 'c-type 'c-not-decl)
(cons 'not-decl nil))
+ ;; In a C11 _Generic construct.
+ ((and c-generic-key
+ (eq (char-before match-pos) ?,)
+ (save-excursion
+ (and (c-go-up-list-backward match-pos
+ (max (- (point) 2000) (point-min)))
+ (zerop (c-backward-token-2))
+ (looking-at c-generic-key))))
+ (cons 'generic nil))
;; At start of a declaration inside a declaration paren.
((save-excursion
(goto-char match-pos)
@@ -1378,7 +1388,8 @@ casts and declarations are fontified. Used on level 2 and higher."
(memq type '(c-decl-arg-start
c-decl-type-start))))))))
((and (zerop (c-backward-token-2))
- (looking-at c-fun-name-substitute-key)))))))))
+ (looking-at c-fun-name-substitute-key)
+ (not (eq (char-after (match-end 0)) ?_))))))))))
;; Cache the result of this test for next time around.
(c-put-char-property (1- match-pos) 'c-type 'c-decl-arg-start)
(cons 'decl nil))
@@ -1616,13 +1627,16 @@ casts and declarations are fontified. Used on level 2 and higher."
(c-forward-syntactic-ws))
;; Now analyze the construct.
- (if (eq context 'not-decl)
- (progn
- (setq decl-or-cast nil)
- (if (c-syntactic-re-search-forward
- "," (min limit (point-max)) 'at-limit t)
- (c-put-char-property (1- (point)) 'c-type 'c-not-decl))
- nil)
+ (cond
+ ((eq context 'not-decl)
+ (setq decl-or-cast nil)
+ (if (c-syntactic-re-search-forward
+ "," (min limit (point-max)) 'at-limit t)
+ (c-put-char-property (1- (point)) 'c-type 'c-not-decl))
+ nil)
+ ((eq context 'generic)
+ (c-font-lock-c11-generic-clause))
+ (t
(setq decl-or-cast
(c-forward-decl-or-cast-1
match-pos context last-cast-end inside-macro))
@@ -1683,7 +1697,7 @@ casts and declarations are fontified. Used on level 2 and higher."
context
(or toplev (nth 4 decl-or-cast))))
- (t t))))
+ (t t)))))
;; It was a false alarm. Check if we're in a label (or other
;; construct with `:' except bitfield) instead.
@@ -1713,6 +1727,28 @@ casts and declarations are fontified. Used on level 2 and higher."
nil))))
+(defun c-font-lock-c11-generic-clause ()
+ ;; Fontify a type inside the C11 _Generic clause. Point will be at the
+ ;; type and will be left at the next comma of the clause (if any) or the
+ ;; closing parenthesis, if any, or at the end of the type, otherwise.
+ ;; The return value is always nil.
+ (c-fontify-types-and-refs
+ ((here (point))
+ (type-type (c-forward-type t))
+ (c-promote-possible-types (if (eq type-type 'maybe) 'just-one t))
+ (pos (point)) pos1)
+ (when (and type-type (eq (char-after) ?:))
+ (goto-char here)
+ (c-forward-type t)) ; Fontify the type.
+ (cond
+ ((c-syntactic-re-search-forward "," nil t t t)
+ (backward-char))
+ ((and (setq pos1 (c-up-list-forward))
+ (eq (char-before pos1) ?\)))
+ (goto-char (1- pos1)))
+ (t (goto-char pos))))
+ nil)
+
(defun c-font-lock-enum-body (limit)
;; Fontify the identifiers of each enum we find by searching forward.
;;
@@ -1854,6 +1890,38 @@ casts and declarations are fontified. Used on level 2 and higher."
(c-font-lock-declarators limit t in-typedef
(not (c-bs-at-toplevel-p (point)))))))))))
+(defun c-font-lock-ids-with-dollar (limit)
+ ;; Maybe fontify identifiers with a dollar using `font-lock-warning-face'.
+ ;; This is done only for languages which tolerate a $ in ids, and only when
+ ;; the flag variable `c-warn-ids-with-dollar' is set to non-nil. This
+ ;; function only works after functions such as `c-font-lock-declarations'
+ ;; have already been run.
+ ;;
+ ;; This function will be called from font-lock for a region bounded by POINT
+ ;; and LIMIT, as though it were to identify a keyword for
+ ;; font-lock-keyword-face. It always returns NIL to inhibit this and
+ ;; prevent a repeat invocation. See elisp/lispref page "Search-based
+ ;; Fontification".
+ (when c-warn-ids-with-dollar
+ (let (id-start)
+ (while (and (< (point) limit)
+ (skip-chars-forward "^$" limit)
+ (< (point) limit)
+ (eq (char-after) ?$))
+ (if (and (memq (c-get-char-property (point) 'face)
+ '(font-lock-variable-name-face
+ font-lock-function-name-face
+ font-lock-type-face))
+ (setq id-start (c-on-identifier)))
+ (progn
+ (goto-char id-start)
+ (looking-at c-identifier-key)
+ (c-put-font-lock-face (match-beginning 0) (match-end 0)
+ 'font-lock-warning-face)
+ (goto-char (match-end 0)))
+ (forward-char)))
+ nil)))
+
(defun c-font-lock-ml-strings (limit)
;; Fontify multi-line strings.
;;
@@ -2254,7 +2322,12 @@ on level 2 only and so aren't combined with `c-complex-decl-matchers'."
;; Fontify generic colon labels in languages that support them.
,@(when (c-lang-const c-recognize-colon-labels)
- '(c-font-lock-labels))))
+ '(c-font-lock-labels))
+
+ ;; Maybe fontify identifiers containing a dollar sign with
+ ;; `font-lock-warning-face'.
+ ,@(when (c-lang-const c-dollar-in-ids)
+ `(c-font-lock-ids-with-dollar))))
(c-lang-defconst c-complex-decl-matchers
"Complex font lock matchers for types and declarations. Used on level
@@ -2330,7 +2403,11 @@ on level 2 only and so aren't combined with `c-complex-decl-matchers'."
;; (see Elisp page "Search-based Fontification").
'(("\\<new\\>"
(c-font-lock-c++-new))))
- ))
+
+ ;; Maybe fontify identifiers containing a dollar sign with
+ ;; `font-lock-warning-face'.
+ ,@(when (c-lang-const c-dollar-in-ids)
+ `(c-font-lock-ids-with-dollar))))
(defun c-font-lock-labels (limit)
;; Fontify all statement labels from the point to LIMIT. Assumes
@@ -2623,7 +2700,9 @@ need for `c-font-lock-extra-types'.")
;; prevent a repeat invocation. See elisp/lispref page "Search-based
;; fontification".
(let (pos)
- (while (c-syntactic-re-search-forward c-using-key limit 'end)
+ (while
+ (and (< (point) limit)
+ (c-syntactic-re-search-forward c-using-key limit 'end))
(while ; Do one declarator of a comma separated list, each time around.
(progn
(c-forward-syntactic-ws)
@@ -2643,9 +2722,7 @@ need for `c-font-lock-extra-types'.")
'same)
(looking-at c-colon-type-list-re)))
;; Inherited protected member: leave unfontified
- )
- (t (goto-char pos)
- (c-font-lock-declarators limit nil c-label-face-name nil)))
+ ))
(eq (char-after) ?,)))
(forward-char))) ; over the comma.
nil))
diff --git a/lisp/progmodes/cc-langs.el b/lisp/progmodes/cc-langs.el
index 9bbcd065b7f..06b919f26fd 100644
--- a/lisp/progmodes/cc-langs.el
+++ b/lisp/progmodes/cc-langs.el
@@ -455,19 +455,29 @@ so that all identifiers are recognized as words.")
c++ '(c-extend-region-for-CPP
c-depropertize-CPP
c-before-change-check-ml-strings
+ c-unmark-<>-around-region
c-before-change-check-<>-operators
c-before-after-change-check-c++-modules
c-truncate-bs-cache
c-before-change-check-unbalanced-strings
c-parse-quotes-before-change
c-before-change-fix-comment-escapes)
- (c objc) '(c-extend-region-for-CPP
- c-depropertize-CPP
- c-truncate-bs-cache
- c-before-change-check-unbalanced-strings
- c-parse-quotes-before-change
- c-before-change-fix-comment-escapes)
+ c '(c-extend-region-for-CPP
+ c-depropertize-CPP
+ c-truncate-bs-cache
+ c-before-change-check-unbalanced-strings
+ c-parse-quotes-before-change
+ c-before-change-fix-comment-escapes)
+ objc '(c-extend-region-for-CPP
+ c-depropertize-CPP
+ c-truncate-bs-cache
+ c-before-change-check-unbalanced-strings
+ c-unmark-<>-around-region
+ c-before-change-check-<>-operators
+ c-parse-quotes-before-change
+ c-before-change-fix-comment-escapes)
java '(c-parse-quotes-before-change
+ c-unmark-<>-around-region
c-before-change-check-unbalanced-strings
c-before-change-check-<>-operators)
pike '(c-before-change-check-ml-strings
@@ -502,20 +512,31 @@ parameters \(point-min) and \(point-max).")
c-after-change-escape-NL-in-string
c-after-change-mark-abnormal-strings
c-change-expand-fl-region)
- (c objc) '(c-depropertize-new-text
- c-after-change-fix-comment-escapes
- c-after-change-escape-NL-in-string
- c-parse-quotes-after-change
- c-after-change-mark-abnormal-strings
- c-extend-font-lock-region-for-macros
- c-neutralize-syntax-in-CPP
- c-change-expand-fl-region)
+ c '(c-depropertize-new-text
+ c-after-change-fix-comment-escapes
+ c-after-change-escape-NL-in-string
+ c-parse-quotes-after-change
+ c-after-change-mark-abnormal-strings
+ c-extend-font-lock-region-for-macros
+ c-neutralize-syntax-in-CPP
+ c-change-expand-fl-region)
+ objc '(c-depropertize-new-text
+ c-after-change-fix-comment-escapes
+ c-after-change-escape-NL-in-string
+ c-parse-quotes-after-change
+ c-after-change-mark-abnormal-strings
+ c-unmark-<>-around-region
+ c-extend-font-lock-region-for-macros
+ c-neutralize-syntax-in-CPP
+ c-restore-<>-properties
+ c-change-expand-fl-region)
c++ '(c-depropertize-new-text
c-after-change-fix-comment-escapes
c-after-change-escape-NL-in-string
c-after-change-unmark-ml-strings
c-parse-quotes-after-change
c-after-change-mark-abnormal-strings
+ c-unmark-<>-around-region
c-extend-font-lock-region-for-macros
c-before-after-change-check-c++-modules
c-neutralize-syntax-in-CPP
@@ -524,6 +545,7 @@ parameters \(point-min) and \(point-max).")
java '(c-depropertize-new-text
c-after-change-escape-NL-in-string
c-parse-quotes-after-change
+ c-unmark-<>-around-region
c-after-change-mark-abnormal-strings
c-restore-<>-properties
c-change-expand-fl-region)
@@ -586,7 +608,8 @@ Such a function takes one optional parameter, a buffer position (defaults to
point), and returns nil or t. This variable contains nil for languages which
don't have EOL terminated statements. "
t nil
- (c c++ objc) 'c-at-macro-vsemi-p
+ (c objc) 'c-at-macro-vsemi-p
+ c++ 'c-c++-vsemi-p
awk 'c-awk-at-vsemi-p)
(c-lang-defvar c-at-vsemi-p-fn (c-lang-const c-at-vsemi-p-fn))
@@ -738,11 +761,11 @@ When non-nil, this variable should end in \"\\\\\\==\". Note that
such a backward search will match a minimal string, so a
\"context character\" is probably needed at the start of the
regexp. The value for csharp-mode would be something like
-\"\\\\(:?\\\\`\\\\|[^\\\"]\\\\)\\\"*\\\\\\==\"."
+\"\\\\(?:\\\\`\\\\|[^\\\"]\\\\)\\\"*\\\\\\==\"."
t nil
- pike "\\(:?\\`\\|[^\\\"]\\)\\(:?\\\\.\\)*\\="
+ pike "\\(?:\\`\\|[^\\\"]\\)\\(?:\\\\.\\)*\\="
;;pike ;; 2
- ;; "\\(:?\\`\\|[^\"]\\)\"*\\="
+ ;; "\\(?:\\`\\|[^\"]\\)\"*\\="
)
(c-lang-defvar c-ml-string-back-closer-re
(c-lang-const c-ml-string-back-closer-re))
@@ -794,7 +817,7 @@ there be copies of the opener contained in the multi-line string."
(c-lang-defconst c-cpp-or-ml-match-offset
;; The offset to be added onto match numbers for a multi-line string in
- ;; matches for `c-cpp-or-ml-string-opener-re'.
+ ;; matches for `c-ml-string-cpp-or-opener-re'.
t (if (c-lang-const c-anchored-cpp-prefix)
(+ 2 (regexp-opt-depth (c-lang-const c-anchored-cpp-prefix)))
2))
@@ -829,8 +852,9 @@ which `c-backward-sexp' needs to be called twice to move backwards over."
keyword. It's unspecified how far it matches. Does not contain a \\|
operator at the top level."
t (concat "[" c-alpha "_]")
+ (c c++) (concat "[" c-alpha "_$]")
java (concat "[" c-alpha "_@]")
- objc (concat "[" c-alpha "_@]")
+ objc (concat "[" c-alpha "_@$]")
pike (concat "[" c-alpha "_`]"))
(c-lang-defvar c-symbol-start (c-lang-const c-symbol-start))
@@ -843,6 +867,10 @@ This is of the form that fits inside [ ] in a regexp."
objc (concat c-alnum "_$@"))
(c-lang-defvar c-symbol-chars (c-lang-const c-symbol-chars))
+(c-lang-defconst c-dollar-in-ids
+ "Non-nil when a dollar (can be) a non-standard constituent of an identifier."
+ t (string-match (c-lang-const c-symbol-start) "$"))
+
(c-lang-defconst c-symbol-char-key
"Regexp matching a sequence of at least one identifier character."
t (concat "[" (c-lang-const c-symbol-chars) "]+"))
@@ -854,9 +882,9 @@ to match if `c-symbol-start' matches on the same position."
t (concat (c-lang-const c-symbol-start)
"[" (c-lang-const c-symbol-chars) "]\\{,1000\\}")
pike (concat
- ;; Use the value from C here since the operator backquote is
+ ;; Use the value from AWK here since the operator backquote is
;; covered by the other alternative.
- (c-lang-const c-symbol-key c)
+ (c-lang-const c-symbol-key awk)
"\\|"
(c-make-keywords-re nil
(c-lang-const c-overloadable-operators))))
@@ -1043,14 +1071,6 @@ Currently (2022-09) just C++ Mode uses this."
;; matched.
t nil)
-(c-lang-defconst c-string-escaped-newlines
- "Set if the language support backslash escaped newlines inside string
-literals."
- t nil
- (c c++ objc pike) t)
-(c-lang-defvar c-string-escaped-newlines
- (c-lang-const c-string-escaped-newlines))
-
(c-lang-defconst c-multiline-string-start-char
"Set if the language supports multiline string literals without escaped
newlines. If t, all string literals are multiline. If a character,
@@ -1067,6 +1087,18 @@ further directions."
(c-lang-defvar c-multiline-string-start-char
(c-lang-const c-multiline-string-start-char))
+(c-lang-defconst c-escaped-newline-takes-precedence
+ "Set if the language resolves escaped newlines first.
+This makes a difference in a string like \"...\\\\\n\". When
+this variable is nil, the first backslash escapes the second,
+leaving an unterminated string. When it's non-nil, the string is
+continued onto the next line, and the first backslash escapes
+whatever begins that next line."
+ t nil
+ (c c++ objc pike) t)
+(c-lang-defvar c-escaped-newline-takes-precedence
+ (c-lang-const c-escaped-newline-takes-precedence))
+
(c-lang-defconst c-string-innards-re-alist
;; An alist of regexps matching the innards of a string, the key being the
;; string's delimiter.
@@ -1077,9 +1109,12 @@ further directions."
t (mapcar (lambda (delim)
(cons
delim
- (concat "\\(\\\\\\(.\\|\n\\)\\|[^\\\n\r"
- (string delim)
- "]\\)*")))
+ (concat
+ (if (c-lang-const c-escaped-newline-takes-precedence)
+ "\\(\\\\\\(\\\\?\n\\|.\\)\\|[^\\\n\r"
+ "\\(\\\\\\(\n\\|.\\)\\|[^\\\n\r")
+ (string delim)
+ "]\\)*")))
(and
(or (null (c-lang-const c-multiline-string-start-char))
(c-characterp (c-lang-const c-multiline-string-start-char)))
@@ -1564,6 +1599,12 @@ operators."
(c-lang-defvar c-assignment-op-regexp
(c-lang-const c-assignment-op-regexp))
+(c-lang-defconst c-negation-op-re
+ ;; Regexp matching the negation operator.
+ t "!\\([^=]\\|$\\)")
+
+(c-lang-defvar c-negation-op-re (c-lang-const c-negation-op-re))
+
(c-lang-defconst c-arithmetic-operators
"List of all arithmetic operators, including \"+=\", etc."
;; Note: in the following, there are too many operators for AWK and IDL.
@@ -2635,9 +2676,12 @@ clause. An arglist may or may not follow such a keyword."
c++ '("requires"))
(c-lang-defconst c-fun-name-substitute-key
- ;; An adorned regular expression which matches any member of
+ ;; An unadorned regular expression which matches any member of
;; `c-fun-name-substitute-kwds'.
- t (c-make-keywords-re t (c-lang-const c-fun-name-substitute-kwds)))
+ t (c-make-keywords-re 'appendable (c-lang-const c-fun-name-substitute-kwds)))
+;; We use 'appendable, so that we get "\\>" on the regexp, but without a further
+;; character, which would mess up backward regexp search from just after the
+;; keyword. If only XEmacs had \\_>. ;-(
(c-lang-defvar c-fun-name-substitute-key
(c-lang-const c-fun-name-substitute-key))
@@ -3086,6 +3130,17 @@ Keywords here should also be in `c-block-stmt-1-kwds'."
t (c-make-keywords-re t (c-lang-const c-block-stmt-2-kwds)))
(c-lang-defvar c-block-stmt-2-key (c-lang-const c-block-stmt-2-key))
+(c-lang-defconst c-generic-kwds
+ "The keyword \"_Generic\" which introduces a C11 generic statement."
+ t nil
+ c '("_Generic"))
+
+(c-lang-defconst c-generic-key
+ ;; Regexp matching the keyword(s) in `c-generic-kwds'.
+ t (if (c-lang-const c-generic-kwds)
+ (c-make-keywords-re t (c-lang-const c-generic-kwds))))
+(c-lang-defvar c-generic-key (c-lang-const c-generic-key))
+
(c-lang-defconst c-block-stmt-kwds
;; Union of `c-block-stmt-1-kwds' and `c-block-stmt-2-kwds'.
t (c--delete-duplicates (append (c-lang-const c-block-stmt-1-kwds)
@@ -3114,6 +3169,30 @@ Keywords here should also be in `c-block-stmt-1-kwds'."
(c-lang-const c-block-stmt-2-kwds)))))
(c-lang-defvar c-opt-block-stmt-key (c-lang-const c-opt-block-stmt-key))
+(c-lang-defconst c-paren-clause-kwds
+ "Keywords which can stand in the place of paren sexps in conditionals.
+This applies only to conditionals in `c-block-stmt-with-kwds'."
+ t nil
+ c++ '("consteval"))
+
+(c-lang-defconst c-paren-clause-key
+ ;; Regexp matching a keyword in `c-paren-clause-kwds'.
+ t (c-make-keywords-re t
+ (c-lang-const c-paren-clause-kwds)))
+(c-lang-defvar c-paren-clause-key (c-lang-const c-paren-clause-key))
+
+(c-lang-defconst c-block-stmt-with-kwds
+ "Statement keywords which can be followed by a keyword instead of a parens.
+Such a keyword is a member of `c-paren-clause-kwds."
+ t nil
+ c++ '("if"))
+
+(c-lang-defconst c-block-stmt-with-key
+ ;; Regexp matching a keyword in `c-block-stmt-with-kwds'.
+ t (c-make-keywords-re t
+ (c-lang-const c-block-stmt-with-kwds)))
+(c-lang-defvar c-block-stmt-with-key (c-lang-const c-block-stmt-with-key))
+
(c-lang-defconst c-simple-stmt-kwds
"Statement keywords followed by an expression or nothing."
t '("break" "continue" "goto" "return")
@@ -3462,7 +3541,7 @@ Note that Java specific rules are currently applied to tell this from
(let* ((alist (c-lang-const c-keyword-member-alist))
kwd lang-const-list
- (obarray (make-vector (* (length alist) 2) 0)))
+ (obarray (obarray-make (* (length alist) 2))))
(while alist
(setq kwd (caar alist)
lang-const-list (cdar alist)
diff --git a/lisp/progmodes/cc-mode.el b/lisp/progmodes/cc-mode.el
index 5c1cc761ad6..1a9d0907bd0 100644
--- a/lisp/progmodes/cc-mode.el
+++ b/lisp/progmodes/cc-mode.el
@@ -255,6 +255,13 @@ control). See \"cc-mode.el\" for more info."
;; Will try initialization hooks again if they failed.
(put 'c-initialize-cc-mode initprop c-initialization-ok))))
+ ;; Set up text conversion, for Emacs >= 30.0
+ ;; This is needed here because CC-mode's implementation of
+ ;; electricity does not rely on `post-self-insert-hook' (which is
+ ;; already handled adequately by `analyze-text-conversion').
+ (when (boundp 'post-text-conversion-hook)
+ (add-hook 'post-text-conversion-hook #'c-post-text-conversion nil t))
+
(unless new-style-init
(c-init-language-vars-for 'c-mode)))
@@ -1275,7 +1282,9 @@ Note that the style variables are always made local to the buffer."
;; VALUE (which should not be nil).
;; `(let ((-pos- ,pos)
;; (-value- ,value))
- (c-put-char-property pos 'syntax-table value)
+ (if (equal value '(15))
+ (c-put-string-fence pos)
+ (c-put-char-property pos 'syntax-table value))
(c-put-char-property pos 'c-fl-syn-tab value)
(cond
((null c-min-syn-tab-mkr)
@@ -1367,7 +1376,15 @@ Note that the style variables are always made local to the buffer."
(and ;(< (point) end)
(not (nth 3 s))
(c-get-char-property (1- (point)) 'c-fl-syn-tab))
- (c-put-char-property pos 'syntax-table '(1)))
+ (c-put-char-property pos 'syntax-table '(1))
+ ;; Remove syntax-table text properties from template
+ ;; delimiters.
+ (c-clear-char-property-with-value
+ (1+ pos) (c-point 'eol pos)
+ 'syntax-table c-<-as-paren-syntax)
+ (c-clear-char-property-with-value
+ (1+ pos) (c-point 'eol pos)
+ 'syntax-table c->-as-paren-syntax))
(setq pos (point)))
(setq pos (1+ pos)))))))))
@@ -1384,6 +1401,9 @@ Note that the style variables are always made local to the buffer."
(setq pos
(c-min-property-position pos c-max-syn-tab-mkr 'c-fl-syn-tab))
(< pos c-max-syn-tab-mkr))
+ (when (and (equal (c-get-char-property pos 'syntax-table) '(1))
+ (equal (c-get-char-property pos 'c-fl-syn-tab) '(15)))
+ (c-clear-char-properties (1+ pos) (c-point 'eol pos) 'syntax-table))
(c-put-char-property pos 'syntax-table
(c-get-char-property pos 'c-fl-syn-tab))
(setq pos (1+ pos))))))
@@ -2444,8 +2464,6 @@ with // and /*, not more generic line and block comments."
(setq pseudo (c-cheap-inside-bracelist-p (c-parse-state)))))))
(goto-char pseudo))
t)
- (or (> (point) bod-lim)
- (eq bod-lim (point-min)))
;; Move forward to the start of the next declaration.
(progn (c-forward-syntactic-ws)
;; Have we got stuck in a comment at EOB?
@@ -2720,18 +2738,18 @@ This function is called from `c-common-init', once per mode initialization."
;; Emacs < 22 and XEmacs
(defmacro c-advise-fl-for-region (function)
(declare (debug t))
- `(defadvice ,function (before get-awk-region activate)
- ;; Make sure that any string/regexp is completely font-locked.
- (when c-buffer-is-cc-mode
- (save-excursion
- (ad-set-arg 1 c-new-END) ; end
- (ad-set-arg 0 c-new-BEG))))) ; beg
-
-(unless (boundp 'font-lock-extend-after-change-region-function)
- (c-advise-fl-for-region font-lock-after-change-function)
- (c-advise-fl-for-region jit-lock-after-change)
- (c-advise-fl-for-region lazy-lock-defer-rest-after-change)
- (c-advise-fl-for-region lazy-lock-defer-line-after-change))
+ (unless (boundp 'font-lock-extend-after-change-region-function)
+ `(defadvice ,function (before get-awk-region activate)
+ ;; Make sure that any string/regexp is completely font-locked.
+ (when c-buffer-is-cc-mode
+ (save-excursion
+ (ad-set-arg 1 c-new-END) ; end
+ (ad-set-arg 0 c-new-BEG)))))) ; beg
+
+(c-advise-fl-for-region font-lock-after-change-function)
+(c-advise-fl-for-region jit-lock-after-change)
+(c-advise-fl-for-region lazy-lock-defer-rest-after-change)
+(c-advise-fl-for-region lazy-lock-defer-line-after-change)
;; Connect up to `electric-indent-mode' (Emacs 24.4 and later).
(defun c-electric-indent-mode-hook ()
@@ -2861,7 +2879,7 @@ Key bindings:
"\\|" id "::"
"\\|" id ws-maybe "=\\)"
"\\|" "\\(?:inline" ws "\\)?namespace"
- "\\(:?" ws "\\(?:" id "::\\)*" id "\\)?" ws-maybe "{"
+ "\\(?:" ws "\\(?:" id "::\\)*" id "\\)?" ws-maybe "{"
"\\|" "class" ws id
"\\(?:" ws "final" "\\)?" ws-maybe "[:{;\n]"
"\\|" "struct" ws id "\\(?:" ws "final" ws-maybe "[:{\n]"
@@ -2884,15 +2902,19 @@ This function attempts to use file contents to determine whether
the code is C or C++ and based on that chooses whether to enable
`c-mode' or `c++-mode'."
(interactive)
- (if (save-excursion
- (save-restriction
- (save-match-data
- (widen)
- (goto-char (point-min))
- (re-search-forward c-or-c++-mode--regexp
- (+ (point) c-guess-region-max) t))))
- (c++-mode)
- (c-mode)))
+ (let ((mode
+ (if (save-excursion
+ (save-restriction
+ (save-match-data
+ (widen)
+ (goto-char (point-min))
+ (re-search-forward c-or-c++-mode--regexp
+ (+ (point) c-guess-region-max) t))))
+ 'c++-mode
+ 'c-mode)))
+ (funcall (if (fboundp 'major-mode-remap)
+ (major-mode-remap mode)
+ mode))))
;; Support for C++
diff --git a/lisp/progmodes/cc-styles.el b/lisp/progmodes/cc-styles.el
index b79853252ac..ff6371d9368 100644
--- a/lisp/progmodes/cc-styles.el
+++ b/lisp/progmodes/cc-styles.el
@@ -658,8 +658,9 @@ any reason to call this function directly."
(let ((func (if this-buf-only-p
'make-local-variable
'make-variable-buffer-local))
- (varsyms (cons 'c-indentation-style (copy-alist c-style-variables))))
- (delq 'c-special-indent-hook varsyms)
+ (varsyms (cons 'c-indentation-style
+ (delq 'c-special-indent-hook
+ (copy-alist c-style-variables)))))
(mapc func varsyms)
;; Hooks must be handled specially
(if this-buf-only-p
diff --git a/lisp/progmodes/cc-vars.el b/lisp/progmodes/cc-vars.el
index 88c389b4e5d..3845c2d55f0 100644
--- a/lisp/progmodes/cc-vars.el
+++ b/lisp/progmodes/cc-vars.el
@@ -280,6 +280,14 @@ anchoring position to indent the line in that case."
:type 'boolean
:group 'c)
+(defcustom c-warn-ids-with-dollar nil
+ "Fontify identifiers with a dollar character in font-lock-warn-face.
+This has effect only for languages in which `c-dollar-in-ids' is
+non-nil, e.g. C, C++, Objective C. It covers languages where
+\"$\" is permitted in ids \"informally\", but only by some compilers."
+ :type 'boolean
+ :group 'c)
+
(defcustom-c-stylevar c-basic-offset 4
"Amount of basic offset used by + and - symbols in `c-offsets-alist'.
Also used as the indentation step when `c-syntactic-indentation' is
@@ -1094,6 +1102,8 @@ can always override the use of `c-default-style' by making calls to
;; Anchor pos: Bol at the last line of previous construct.
(topmost-intro-cont . c-lineup-topmost-intro-cont)
;;Anchor pos: Bol at the topmost annotation line
+ (constraint-cont . +)
+ ;; Anchor pos: Boi of the starting requires/concept line
(annotation-top-cont . 0)
;;Anchor pos: Bol at the topmost annotation line
(annotation-var-cont . +)
@@ -1217,7 +1227,8 @@ can always override the use of `c-default-style' by making calls to
(incomposition . +)
;; Anchor pos: At the extern/namespace/etc block open brace if
;; it's at boi, otherwise boi at the keyword.
- (template-args-cont . (c-lineup-template-args +))
+ (template-args-cont . (c-lineup-template-args
+ c-lineup-template-args-indented-from-margin))
;; Anchor pos: Boi at the decl start. This might be changed;
;; the logical position is clearly the opening '<'.
(inlambda . 0)
@@ -1326,6 +1337,9 @@ Here is the current list of valid syntactic element symbols:
knr-argdecl -- Subsequent lines in a K&R C argument declaration.
topmost-intro -- The first line in a topmost construct definition.
topmost-intro-cont -- Topmost definition continuation lines.
+ constraint-cont -- Continuation line of a C++ requires clause (not
+ to be confused with a \"requires expression\") or
+ concept.
annotation-top-cont -- Topmost definition continuation line where only
annotations are on previous lines.
annotation-var-cont -- A continuation of a C (or like) statement where
diff --git a/lisp/progmodes/cl-font-lock.el b/lisp/progmodes/cl-font-lock.el
index 52378352aa9..f6d4cde3fec 100644
--- a/lisp/progmodes/cl-font-lock.el
+++ b/lisp/progmodes/cl-font-lock.el
@@ -6,7 +6,7 @@
;; Created: 2019-06-16
;; Old-Version: 0.3.0
;; Package-Requires: ((emacs "24.5"))
-;; Keywords: lisp wp files convenience
+;; Keywords: lisp text files convenience
;; URL: https://github.com/cl-font-lock/cl-font-lock
;; This file is part of GNU Emacs
diff --git a/lisp/progmodes/cmake-ts-mode.el b/lisp/progmodes/cmake-ts-mode.el
index 29c9e957d3c..b70806f4c30 100644
--- a/lisp/progmodes/cmake-ts-mode.el
+++ b/lisp/progmodes/cmake-ts-mode.el
@@ -193,13 +193,13 @@ Check if a node type is available, then return the right font lock rules."
'((ERROR) @font-lock-warning-face))
"Tree-sitter font-lock settings for `cmake-ts-mode'.")
-(defun cmake-ts-mode--function-name (node)
- "Return the function name of NODE.
-Return nil if there is no name or if NODE is not a function node."
+(defun cmake-ts-mode--defun-name (node)
+ "Return the defun name of NODE.
+Return nil if there is no name or if NODE is not a defun node."
(pcase (treesit-node-type node)
- ("function_command"
+ ((or "function_def" "macro_def")
(treesit-node-text
- (treesit-search-subtree node "^argument$" nil nil 2)
+ (treesit-search-subtree node "^argument$" nil nil 3)
t))))
;;;###autoload
@@ -216,9 +216,15 @@ Return nil if there is no name or if NODE is not a function node."
(setq-local comment-end "")
(setq-local comment-start-skip (rx "#" (* (syntax whitespace))))
+ ;; Defuns.
+ (setq-local treesit-defun-type-regexp (rx (or "function" "macro")
+ "_def"))
+ (setq-local treesit-defun-name-function #'cmake-ts-mode--defun-name)
+
;; Imenu.
(setq-local treesit-simple-imenu-settings
- `(("Function" "\\`function_command\\'" nil cmake-ts-mode--function-name)))
+ `(("Function" "^function_def$")
+ ("Macro" "^macro_def$")))
(setq-local which-func-functions nil)
;; Indent.
@@ -237,6 +243,8 @@ Return nil if there is no name or if NODE is not a function node."
(treesit-major-mode-setup)))
+(derived-mode-add-parents 'cmake-ts-mode '(cmake-mode))
+
(if (treesit-ready-p 'cmake)
(add-to-list 'auto-mode-alist
'("\\(?:CMakeLists\\.txt\\|\\.cmake\\)\\'" . cmake-ts-mode)))
diff --git a/lisp/progmodes/compile.el b/lisp/progmodes/compile.el
index 11902cd469b..11d400e145a 100644
--- a/lisp/progmodes/compile.el
+++ b/lisp/progmodes/compile.el
@@ -362,6 +362,28 @@ of[ \t]+\"?\\([a-zA-Z]?:?[^\":\n]+\\)\"?:" 3 2 nil (1))
(ruby-Test::Unit
"^ [[ ]?\\([^ (].*\\):\\([1-9][0-9]*\\)\\(\\]\\)?:in " 1 2)
+ ;; Tested with Lua 5.1, 5.2, 5.3, 5.4, and LuaJIT 2.1.
+ (lua
+ ,(rx bol
+ (+? (not (in "\t\n")))
+ ": "
+ (group (+? (not (in "\t\n"))))
+ ":"
+ (group (+ (in "0-9")))
+ ": "
+ (+ nonl)
+ "\nstack traceback:\n\t")
+ 1 2 nil 2 1)
+ (lua-stack
+ ,(rx bol "\t"
+ (| "[C]:"
+ (: (group (+? (not (in "\t\n"))))
+ ":"
+ (? (group (+ (in "0-9")))
+ ":")))
+ " in ")
+ 1 2 nil 0 1)
+
(gmake
;; Set GNU make error messages as INFO level.
;; It starts with the name of the make program which is variable,
@@ -683,7 +705,10 @@ File = \\(.+\\), Line = \\([0-9]+\\)\\(?:, Column = \\([0-9]+\\)\\)?"
"Alist of values for `compilation-error-regexp-alist'.")
(defcustom compilation-error-regexp-alist
- (mapcar #'car compilation-error-regexp-alist-alist)
+ ;; Omit `omake' by default: its mere presence here triggers special processing
+ ;; and modifies regexps for other rules (see `compilation-parse-errors'),
+ ;; which may slow down matching (or even cause mismatches).
+ (delq 'omake (mapcar #'car compilation-error-regexp-alist-alist))
"Alist that specifies how to match errors in compiler output.
On GNU and Unix, any string is a valid filename, so these
matchers must make some common sense assumptions, which catch
@@ -1706,7 +1731,7 @@ to `compilation-error-regexp-alist' if RULES is nil."
(set-marker (make-marker)
(save-excursion
(goto-char (point-min))
- (text-property-search-forward 'compilation-header-end)
+ (text-property-search-forward 'compilation-annotation)
;; If we have no end marker, this will be
;; `point-min' still.
(point)))))
@@ -1854,6 +1879,23 @@ If nil, don't hide anything."
;; buffers when it changes from nil to non-nil or vice-versa.
(unless compilation-in-progress (force-mode-line-update t)))
+(defun compilation-insert-annotation (&rest args)
+ "Insert ARGS at point, adding the `compilation-annotation' text property.
+This property is used to distinguish output of the compilation
+process from additional information inserted by Emacs."
+ (let ((start (point)))
+ (apply #'insert args)
+ (put-text-property start (point) 'compilation-annotation t)))
+
+(defvar-local compilation--start-time nil
+ "The time when the compilation started as returned by `float-time'.")
+
+(defun compilation--downcase-mode-name (mode)
+ "Downcase the name of major MODE, even if MODE is not a string.
+The function `downcase' will barf if passed the name of a `major-mode'
+which is not a string, but instead a symbol or a list."
+ (downcase (format-mode-line mode)))
+
;;;###autoload
(defun compilation-start (command &optional mode name-function highlight-regexp
continue)
@@ -1975,17 +2017,17 @@ Returns the compilation buffer created."
(setq-local compilation-auto-jump-to-next t))
(when (zerop (buffer-size))
;; Output a mode setter, for saving and later reloading this buffer.
- (insert "-*- mode: " name-of-mode
- "; default-directory: "
- (prin1-to-string (abbreviate-file-name default-directory))
- " -*-\n"))
- (insert (format "%s started at %s\n\n"
- mode-name
- (substring (current-time-string) 0 19))
- command "\n")
- ;; Mark the end of the header so that we don't interpret
- ;; anything in it as an error.
- (put-text-property (1- (point)) (point) 'compilation-header-end t)
+ (compilation-insert-annotation
+ "-*- mode: " name-of-mode
+ "; default-directory: "
+ (prin1-to-string (abbreviate-file-name default-directory))
+ " -*-\n"))
+ (compilation-insert-annotation
+ (format "%s started at %s\n\n"
+ mode-name
+ (substring (current-time-string) 0 19))
+ command "\n")
+ (setq compilation--start-time (float-time))
(setq thisdir default-directory))
(set-buffer-modified-p nil))
;; Pop up the compilation buffer.
@@ -2045,11 +2087,12 @@ Returns the compilation buffer created."
(get-buffer-process
(with-no-warnings
(comint-exec
- outbuf (downcase mode-name)
+ outbuf (compilation--downcase-mode-name mode-name)
shell-file-name
nil `(,shell-command-switch ,command)))))
- (start-file-process-shell-command (downcase mode-name)
- outbuf command))))
+ (start-file-process-shell-command
+ (compilation--downcase-mode-name mode-name)
+ outbuf command))))
;; Make the buffer's mode line show process state.
(setq mode-line-process
'((:propertize ":%s" face compilation-mode-line-run)
@@ -2467,13 +2510,20 @@ commands of Compilation major mode are available. See
(cur-buffer (current-buffer)))
;; Record where we put the message, so we can ignore it later on.
(goto-char omax)
- (insert ?\n mode-name " " (car status))
+ (compilation-insert-annotation ?\n mode-name " " (car status))
(if (and (numberp compilation-window-height)
(zerop compilation-window-height))
(message "%s" (cdr status)))
(if (bolp)
(forward-char -1))
- (insert " at " (substring (current-time-string) 0 19))
+ (compilation-insert-annotation
+ " at "
+ (substring (current-time-string) 0 19)
+ ", duration "
+ (let ((elapsed (- (float-time) compilation--start-time)))
+ (cond ((< elapsed 10) (format "%.2f s" elapsed))
+ ((< elapsed 60) (format "%.1f s" elapsed))
+ (t (format-seconds "%h:%02m:%02s" elapsed)))))
(goto-char (point-max))
;; Prevent that message from being recognized as a compilation error.
(add-text-properties omax (point)
@@ -2703,7 +2753,7 @@ looking for the next message."
(compilation-loop > compilation-next-single-property-change 1-
(if (get-buffer-process (current-buffer))
"No more %ss yet"
- "Moved past last %s")
+ "Past last %s")
(point-max))
;; Don't move "back" to message at or before point.
;; Pass an explicit (point-min) to make sure pt is non-nil.
@@ -2747,7 +2797,8 @@ Prefix arg N says how many files to move backwards (or forwards, if negative)."
(let ((buffer (compilation-find-buffer)))
(if (get-buffer-process buffer)
(interrupt-process (get-buffer-process buffer))
- (error "The %s process is not running" (downcase mode-name)))))
+ (error "The %s process is not running"
+ (compilation--downcase-mode-name mode-name)))))
(defalias 'compile-mouse-goto-error 'compile-goto-error)
@@ -3101,7 +3152,16 @@ and overlay is highlighted between MK and END-MK."
(cancel-timer next-error-highlight-timer))
(remove-hook 'pre-command-hook
#'compilation-goto-locus-delete-o))
-
+
+(defun compilation--expand-fn (directory filename)
+ "Expand FILENAME or resolve its true name.
+Unlike `expand-file-name', `file-truename' follows symlinks, which
+we try to avoid if possible."
+ (let* ((expandedname (expand-file-name filename directory)))
+ (if (file-exists-p expandedname)
+ expandedname
+ (file-truename (file-name-concat directory filename)))))
+
(defun compilation-find-file-1 (marker filename directory &optional formats)
(or formats (setq formats '("%s")))
(let ((dirs compilation-search-path)
@@ -3122,8 +3182,8 @@ and overlay is highlighted between MK and END-MK."
fmts formats)
;; For each directory, try each format string.
(while (and fmts (null buffer))
- (setq name (file-truename
- (file-name-concat thisdir (format (car fmts) filename)))
+ (setq name (compilation--expand-fn thisdir
+ (format (car fmts) filename))
buffer (and (file-exists-p name)
(find-file-noselect name))
fmts (cdr fmts)))
@@ -3145,8 +3205,8 @@ and overlay is highlighted between MK and END-MK."
(setq thisdir (car dirs)
fmts formats)
(while (and fmts (null buffer))
- (setq name (file-truename
- (file-name-concat thisdir (format (car fmts) filename)))
+ (setq name (compilation--expand-fn thisdir
+ (format (car fmts) filename))
buffer (and (file-exists-p name)
(find-file-noselect name))
fmts (cdr fmts)))
@@ -3206,8 +3266,7 @@ attempts to find a file whose name is produced by (format FMT FILENAME)."
(ding) (sit-for 2))
((and (file-directory-p name)
(not (file-exists-p
- (setq name (file-truename
- (file-name-concat name filename))))))
+ (setq name (compilation--expand-fn name filename)))))
(message "No `%s' in directory %s" filename origname)
(ding) (sit-for 2))
(t
diff --git a/lisp/progmodes/cperl-mode.el b/lisp/progmodes/cperl-mode.el
index b85db699e72..11709bfe00b 100644
--- a/lisp/progmodes/cperl-mode.el
+++ b/lisp/progmodes/cperl-mode.el
@@ -79,6 +79,9 @@
(eval-when-compile (require 'cl-lib))
(require 'facemenu)
+(defvar Man-switches)
+(defvar manual-program)
+(defvar imenu-max-items)
(defvar msb-menu-cond)
(defvar gud-perldb-history)
(defvar vc-rcs-header)
@@ -101,7 +104,10 @@
:version "20.3")
(defgroup cperl-indentation-details nil
- "Indentation."
+ "Indentation.
+The option `cperl-file-style' (which see) can be used to set
+several indentation options in one go, following popular
+indentation styles."
:prefix "cperl-"
:group 'cperl)
@@ -154,6 +160,29 @@ for constructs with multiline if/unless/while/until/for/foreach condition."
:type 'boolean
:group 'cperl-autoinsert-details)
+(defcustom cperl-file-style nil
+ "Indentation style to use in cperl-mode.
+Setting this option will override options as given in
+`cperl-style-alist' for the keyword provided here. If nil, then
+the individual options as customized are used.
+\"PBP\" is the style recommended in the Book \"Perl Best
+Practices\" by Damian Conway. \"CPerl\" is the traditional style
+of cperl-mode, and \"PerlStyle\" follows the Perl documentation
+in perlstyle. The other styles have been developed for other
+programming languages, mostly C."
+ :type '(choice (const "PBP")
+ (const "CPerl")
+ (const "PerlStyle")
+ (const "GNU")
+ (const "C++")
+ (const "K&R")
+ (const "BSD")
+ (const "Whitesmith")
+ (const :tag "Default" nil))
+ :group 'cperl-indentation-details
+ :version "29.1")
+;;;###autoload(put 'cperl-file-style 'safe-local-variable 'stringp)
+
(defcustom cperl-indent-level 2
"Indentation of CPerl statements with respect to containing block."
:type 'integer
@@ -275,7 +304,7 @@ Can be overwritten by `cperl-hairy' if nil."
:type '(choice (const null) boolean)
:group 'cperl-affected-by-hairy)
-(defcustom cperl-electric-parens-mark window-system
+(defcustom cperl-electric-parens-mark (not (not window-system))
"Not-nil means that electric parens look for active mark.
Default is yes if there is visual feedback on mark."
:type 'boolean
@@ -333,17 +362,7 @@ Affects: `cperl-font-lock', `cperl-electric-lbrace-space',
(defcustom cperl-vc-rcs-header '("($rcs) = (' $Id\ $ ' =~ /(\\d+(\\.\\d+)+)/);")
"Special version of `vc-rcs-header' that is used in CPerl mode buffers."
:type '(repeat string)
- :group 'cperl)
-
-;; (defcustom cperl-clobber-mode-lists
-;; (not
-;; (and
-;; (boundp 'interpreter-mode-alist)
-;; (assoc "miniperl" interpreter-mode-alist)
-;; (assoc "\\.\\([pP][Llm]\\|al\\)$" auto-mode-alist)))
-;; "Whether to install us into `interpreter-' and `extension' mode lists."
-;; :type 'boolean
-;; :group 'cperl)
+ :group 'cperl)
(defcustom cperl-info-on-command-no-prompt nil
"Not-nil (and non-null) means not to prompt on \\[cperl-info-on-command].
@@ -386,6 +405,8 @@ Font for POD headers."
:type 'face
:version "21.1"
:group 'cperl-faces)
+(make-obsolete-variable 'cperl-invalid-face
+ 'show-trailing-whitespace "30.1")
(defcustom cperl-pod-here-fontify t
"Not-nil after evaluation means to highlight POD and here-docs sections."
@@ -440,6 +461,11 @@ after reload."
Older version of this page was called `perl5', newer `perl'."
:type 'string
:group 'cperl-help-system)
+(make-obsolete-variable 'cperl-info-page
+ (concat "The Perl info page is no longer maintained. "
+ "Consider installing the perl-doc package from "
+ "GNU ELPA to access Perl documentation.")
+ "30.1")
(defcustom cperl-use-syntax-table-text-property t
"Non-nil means CPerl sets up and uses `syntax-table' text property."
@@ -480,12 +506,6 @@ If nil, the value of `cperl-indent-level' will be used."
:group 'cperl)
(make-obsolete-variable 'cperl-under-as-char 'superword-mode "24.4")
-(defcustom cperl-extra-perl-args ""
- "Extra arguments to use when starting Perl.
-Currently used with `cperl-check-syntax' only."
- :type 'string
- :group 'cperl)
-
(defcustom cperl-message-electric-keyword t
"Non-nil means that the `cperl-electric-keyword' prints a help message."
:type 'boolean
@@ -543,19 +563,17 @@ This way enabling/disabling of menu items is more correct."
:type 'boolean
:group 'cperl-speed)
-(defcustom cperl-file-style nil
- "Indentation style to use in cperl-mode."
- :type '(choice (const "CPerl")
- (const "PBP")
- (const "PerlStyle")
- (const "GNU")
- (const "C++")
- (const "K&R")
- (const "BSD")
- (const "Whitesmith")
- (const :tag "Default" nil))
- :version "29.1")
-;;;###autoload(put 'cperl-file-style 'safe-local-variable 'stringp)
+(defcustom cperl-fontify-trailer
+ 'perl-code
+ "How to fontify text after an \"__END__\" or \"__DATA__\" token.
+If \"perl-code\", treat as Perl code for fontification, and
+examine for imenu entries. Use this setting if you have trailing
+POD documentation, or for modules which use AutoLoad or
+AutoSplit. If \"comment\", treat as comment, and do not look for
+imenu entries."
+ :type '(choice (const perl-code)
+ (const comment))
+ :group 'cperl-faces)
(defcustom cperl-ps-print-face-properties
'((font-lock-keyword-face nil nil bold shadow)
@@ -626,22 +644,14 @@ This way enabling/disabling of menu items is more correct."
;;; Short extra-docs.
(defvar cperl-tips 'please-ignore-this-line
- "Note that to enable Compile choices in the menu you need to install
-mode-compile.el.
-
-If your Emacs does not default to `cperl-mode' on Perl files, and you
+ "If your Emacs does not default to `cperl-mode' on Perl files, and you
want it to: put the following into your .emacs file:
(add-to-list \\='major-mode-remap-alist \\='(perl-mode . cperl-mode))
-Get perl5-info from
- $CPAN/doc/manual/info/perl5-old/perl5-info.tar.gz
-Also, one can generate a newer documentation running `pod2texi' converter
- $CPAN/doc/manual/info/perl5/pod2texi-0.1.tar.gz
-
-If you use imenu-go, run imenu on perl5-info buffer (you can do it
-from Perl menu). If many files are related, generate TAGS files from
-Tools/Tags submenu in Perl menu.
+To read Perl documentation in info format you can convert POD to
+texinfo with the converter `pod2texi' from the texinfo project:
+ https://www.gnu.org/software/texinfo/manual/pod2texi.html
If some class structure is too complicated, use Tools/Hierarchy-view
from Perl menu, or hierarchic view of imenu. The second one uses the
@@ -705,48 +715,45 @@ voice);
d) Has support for imenu, including:
1) Separate unordered list of \"interesting places\";
2) Separate TOC of POD sections;
- 3) Separate list of packages;
+ 3) Separate list of packages/classes;
4) Hierarchical view of methods in (sub)packages;
5) and functions (by the full name - with package);
- e) Has an interface to INFO docs for Perl; The interface is
- very flexible, including shrink-wrapping of
- documentation buffer/frame;
- f) Has a builtin list of one-line explanations for perl constructs.
- g) Can show these explanations if you stay long enough at the
+ e) Has a builtin list of one-line explanations for perl constructs.
+ f) Can show these explanations if you stay long enough at the
corresponding place (or on demand);
- h) Has an enhanced fontification (using 3 or 4 additional faces
+ g) Has an enhanced fontification (using 3 or 4 additional faces
comparing to font-lock - basically, different
namespaces in Perl have different colors);
- i) Can construct TAGS basing on its knowledge of Perl syntax,
+ h) Can construct TAGS basing on its knowledge of Perl syntax,
the standard menu has 6 different way to generate
TAGS (if \"by directory\", .xs files - with C-language
bindings - are included in the scan);
- j) Can build a hierarchical view of classes (via imenu) basing
+ i) Can build a hierarchical view of classes (via imenu) basing
on generated TAGS file;
- k) Has electric parentheses, electric newlines, uses Abbrev
+ j) Has electric parentheses, electric newlines, uses Abbrev
for electric logical constructs
while () {}
with different styles of expansion (context sensitive
to be not so bothering). Electric parentheses behave
\"as they should\" in a presence of a visible region.
- l) Changes msb.el \"on the fly\" to insert a group \"Perl files\";
- m) Can convert from
+ k) Changes msb.el \"on the fly\" to insert a group \"Perl files\";
+ l) Can convert from
if (A) { B }
to
B if A;
- n) Highlights (by user-choice) either 3-delimiters constructs
+ m) Highlights (by user-choice) either 3-delimiters constructs
(such as tr/a/b/), or regular expressions and `y/tr';
- o) Highlights trailing whitespace;
- p) Is able to manipulate Perl Regular Expressions to ease
+ o) Is able to manipulate Perl Regular Expressions to ease
conversion to a more readable form.
- q) Can ispell POD sections and HERE-DOCs.
- r) Understands comments and character classes inside regular
+ p) Can ispell POD sections and HERE-DOCs.
+ q) Understands comments and character classes inside regular
expressions; can find matching () and [] in a regular expression.
- s) Allows indentation of //x-style regular expressions;
- t) Highlights different symbols in regular expressions according
+ r) Allows indentation of //x-style regular expressions;
+ s) Highlights different symbols in regular expressions according
to their function; much less problems with backslashitis;
- u) Allows to find regular expressions which contain interpolated parts.
+ t) Allows you to locate regular expressions which contain
+ interpolated parts.
5) The indentation engine was very smart, but most of tricks may be
not needed anymore with the support for `syntax-table' property. Has
@@ -834,7 +841,6 @@ B) Speed of editing operations.
`font-lock-type-face' Overridable keywords
`font-lock-variable-name-face' Variable declarations, indirect array and
hash names, POD headers/item names
- `cperl-invalid-face' Trailing whitespace
Note that in several situations the highlighting tries to inform about
possible confusion, such as different colors for function names in
@@ -911,17 +917,6 @@ Unless KEEP, removes the old indentation."
(delete-horizontal-space))
(indent-to column minimum))
-;; Probably it is too late to set these guys already, but it can help later:
-
-;;(and cperl-clobber-mode-lists
-;;(setq auto-mode-alist
-;; (append '(("\\.\\([pP][Llm]\\|al\\)$" . perl-mode)) auto-mode-alist ))
-;;(and (boundp 'interpreter-mode-alist)
-;; (setq interpreter-mode-alist (append interpreter-mode-alist
-;; '(("miniperl" . perl-mode))))))
-(eval-when-compile
- (mapc #'require '(imenu easymenu etags timer man info)))
-
(define-abbrev-table 'cperl-mode-electric-keywords-abbrev-table
(mapcar (lambda (x)
(let ((name (car x))
@@ -992,12 +987,12 @@ Unless KEEP, removes the old indentation."
(define-key map "\177" 'cperl-electric-backspace)
(define-key map "\t" 'cperl-indent-command)
;; don't clobber the backspace binding:
- (define-key map [(control ?c) (control ?h) ?F] 'cperl-info-on-command)
+ (define-key map [(control ?c) (control ?h) ?F] 'cperl-perldoc)
(if (cperl-val 'cperl-clobber-lisp-bindings)
(progn
(define-key map [(control ?h) ?f]
;;(concat (char-to-string help-char) "f") ; does not work
- 'cperl-info-on-command)
+ 'cperl-perldoc)
(define-key map [(control ?h) ?v]
;;(concat (char-to-string help-char) "v") ; does not work
'cperl-get-help)
@@ -1008,7 +1003,7 @@ Unless KEEP, removes the old indentation."
;;(concat (char-to-string help-char) "v") ; does not work
(key-binding "\C-hv")))
(define-key map [(control ?c) (control ?h) ?f]
- 'cperl-info-on-current-command)
+ 'cperl-perldoc)
(define-key map [(control ?c) (control ?h) ?v]
;;(concat (char-to-string help-char) "v") ; does not work
'cperl-get-help))
@@ -1061,17 +1056,10 @@ Unless KEEP, removes the old indentation."
["Comment region" cperl-comment-region (use-region-p)]
["Uncomment region" cperl-uncomment-region (use-region-p)]
"----"
- ["Run" mode-compile (fboundp 'mode-compile)]
- ["Kill" mode-compile-kill (and (fboundp 'mode-compile-kill)
- (get-buffer "*compilation*"))]
- ["Next error" next-error (get-buffer "*compilation*")]
- ["Check syntax" cperl-check-syntax (fboundp 'mode-compile)]
- "----"
["Debugger" cperl-db t]
"----"
("Tools"
["Imenu" imenu]
- ["Imenu on Perl Info" cperl-imenu-on-info (featurep 'imenu)]
"----"
["Ispell PODs" cperl-pod-spell
;; Better not to update syntaxification here:
@@ -1130,8 +1118,6 @@ Unless KEEP, removes the old indentation."
;; This is from imenu-go.el. I can't find it on any ELPA
;; archive, so I'm not sure if it's still in use or not.
(fboundp 'imenu-go-find-at-position)]
- ["Help on function" cperl-info-on-command t]
- ["Help on function at point" cperl-info-on-current-command t]
["Help on symbol at point" cperl-get-help t]
["Perldoc" cperl-perldoc t]
["Perldoc on word at point" cperl-perldoc-at-point t]
@@ -1147,7 +1133,7 @@ Unless KEEP, removes the old indentation."
["Fix whitespace on indent" cperl-toggle-construct-fix t]
["Auto-help on Perl constructs" cperl-toggle-autohelp t]
["Auto fill" auto-fill-mode t])
- ("Indent styles..."
+ ("Default indent styles..."
["CPerl" (cperl-set-style "CPerl") t]
["PBP" (cperl-set-style "PBP") t]
["PerlStyle" (cperl-set-style "PerlStyle") t]
@@ -1158,6 +1144,15 @@ Unless KEEP, removes the old indentation."
["Whitesmith" (cperl-set-style "Whitesmith") t]
["Memorize Current" (cperl-set-style "Current") t]
["Memorized" (cperl-set-style-back) cperl-old-style])
+ ("Indent styles for current buffer..."
+ ["CPerl" (cperl-set-style "CPerl") t]
+ ["PBP" (cperl-file-style "PBP") t]
+ ["PerlStyle" (cperl-file-style "PerlStyle") t]
+ ["GNU" (cperl-file-style "GNU") t]
+ ["C++" (cperl-file-style "C++") t]
+ ["K&R" (cperl-file-style "K&R") t]
+ ["BSD" (cperl-file-style "BSD") t]
+ ["Whitesmith" (cperl-file-style "Whitesmith") t])
("Micro-docs"
["Tips" (describe-variable 'cperl-tips) t]
["Problems" (describe-variable 'cperl-problems) t]
@@ -1187,8 +1182,7 @@ The expansion is entirely correct because it uses the C preprocessor."
"A regular expression for the name of a \"basic\" Perl variable.
Neither namespace separators nor sigils are included. As is,
this regular expression applies to labels,subroutine calls where
-the ampersand sigil is not required, and names of subroutine
-attributes.")
+the ampersand sigil is not required, and names of attributes.")
(defconst cperl--label-rx
`(sequence symbol-start
@@ -1225,6 +1219,30 @@ is a legal variable name).")
(in "!\"$%&'()+,-./:;<=>?@\\]^_`|~")) ; $., $|, $", ... but not $^ or ${
"The list of Perl \"punctuation\" variables, as listed in perlvar.")
+ (defconst cperl--basic-scalar-rx
+ `(sequence "$" ,cperl--basic-identifier-rx)
+ "Regular expression for a scalar (without package).
+This regexp intentionally does not support spaces (nor newlines
+and comments) between the sigil and the identifier, for
+educational reasons. So \"$foo\" will be matched, but \"$ foo\"
+or \"${ foo }\" will not.")
+
+ (defconst cperl--basic-array-rx
+ `(sequence "@" ,cperl--basic-identifier-rx)
+ "Regular expression for an array variable (without package).
+This regexp intentionally does not support spaces (nor newlines
+and comments) between the sigil and the identifier, for
+educational reasons. So \"@foo\" will be matched, but \"@ foo\"
+or \"@{ foo }\" will not.")
+
+ (defconst cperl--basic-hash-rx
+ `(sequence "%" ,cperl--basic-identifier-rx)
+ "Regular expression for a hash variable (without package).
+This regexp intentionally does not support spaces (nor newlines
+and comments) between the sigil and the identifier, for
+educational reasons. So \"%foo\" will be matched, but \"% foo\"
+or \"%{ foo }\" will not.")
+
(defconst cperl--ws-rx
'(sequence (or space "\n"))
"Regular expression for a single whitespace in Perl.")
@@ -1246,6 +1264,27 @@ is a legal variable name).")
`(1+ ,cperl--ws-or-comment-rx)
"Regular expression for a sequence of whitespace and comments in Perl.")
+ (defconst cperl--basic-variable-rx
+ `(sequence (in "$@%") ,cperl--basic-identifier-rx)
+ "Regular expression for a Perl variable (scalar, array or hash).
+This regexp intentionally does not support spaces (nor newlines
+and comments) between the sigil and the identifier, for
+educational reasons. So \"$foo\" will be matched, but \"$ foo\"
+or \"${ foo }\" will not.")
+
+ (defconst cperl--variable-list-rx
+ `(sequence "("
+ (optional (sequence
+ ,cperl--ws*-rx
+ ,cperl--basic-variable-rx
+ (0+ (sequence
+ ,cperl--ws*-rx
+ ","
+ ,cperl--ws*-rx
+ ,cperl--basic-variable-rx))
+ ,cperl--ws*-rx)))
+ "Regular expression for a list of Perl variables for declarations.")
+
;; This is left as a string regexp. There are many version schemes in
;; the wild, so people might want to fiddle with this variable.
(defconst cperl--version-regexp
@@ -1260,15 +1299,89 @@ is a legal variable name).")
(optional (sequence "_" (1+ word))))))
"A sequence for recommended version number schemes in Perl.")
+ (defconst cperl--single-attribute-rx
+ `(sequence ,cperl--basic-identifier-rx
+ (optional (sequence "("
+ (0+ (or (sequence "\\" not-newline)
+ (not (any "()\\"))
+ (sequence "("
+ (zero-or-more
+ (not
+ (any "()\\")))
+ ")")))
+ ")")))
+ "A regular expression for a single attribute, without leading colon.
+It may have parameters in parens, one level of parens within the
+parameter's value is supported. This regexp does not have
+capture groups.")
+
+ (defconst cperl--attribute-list-rx
+ `(sequence ":"
+ (optional
+ ,cperl--ws*-rx
+ ,cperl--single-attribute-rx
+ (0+ (sequence
+ (or (sequence ,cperl--ws*-rx
+ ":"
+ ,cperl--ws*-rx)
+ ,cperl--ws+-rx)
+ ,cperl--single-attribute-rx))
+ (optional ":")))
+ "A regular expression for an attribute list.
+Attribute lists may only occur in certain declarations. A colon
+is required before the first attribute but optional between
+subsequent attributes. This regexp does not have capture groups.")
+
+ (defconst cperl--prototype-rx
+ `(sequence "("
+ (0+ (any "$@%&*;\\[]"))
+ ")")
+ "A regular expression for a subroutine prototype. Not as strict
+as the actual prototype syntax, but good enough to distinguish
+prototypes from signatures.")
+
+ (defconst cperl--signature-rx
+ `(sequence "("
+ (optional
+ (sequence
+ (0+ (sequence ,cperl--ws*-rx
+ ,cperl--basic-scalar-rx
+ ,cperl--ws*-rx
+ ","))
+ ,cperl--ws*-rx
+ (or ,cperl--basic-scalar-rx
+ ,cperl--basic-array-rx
+ ,cperl--basic-hash-rx)))
+ (optional (sequence ,cperl--ws*-rx) "," )
+ ,cperl--ws*-rx
+ ")")
+ "A rx sequence subroutine signature without initializers.
+These are a bit more restricted than \"my\" declaration lists
+because they allow only one slurpy variable, and only in the last
+place.")
+
+ (defconst cperl--sloppy-signature-rx
+ `(sequence "("
+ ,cperl--ws*-rx
+ (or ,cperl--basic-scalar-rx
+ ,cperl--basic-array-rx
+ ,cperl--basic-hash-rx)
+ ,cperl--ws*-rx
+ (or "," "=" "||=" "//=" ")"))
+ "A rx sequence for the begin of a signature with initializers.
+Initializers can contain almost all Perl constructs and thus can
+not be covered by regular expressions. This sequence captures
+enough to distinguish a signature from a prototype.")
+
(defconst cperl--package-rx
- `(sequence (group "package")
+ `(sequence (group (or "package" "class"))
,cperl--ws+-rx
(group ,cperl--normal-identifier-rx)
(optional (sequence ,cperl--ws+-rx
(group (regexp ,cperl--version-regexp)))))
- "A regular expression for package NAME VERSION in Perl.
-Contains three groups for the keyword \"package\", for the
-package name and for the version.")
+ "A regular expression for package|class NAME VERSION in Perl.
+Contains three groups for the initial keyword \"package\" or
+\"class\", for the package name and for the version.")
(defconst cperl--package-for-imenu-rx
`(sequence symbol-start
@@ -1285,27 +1398,59 @@ NAME BLOCK\" and \"package NAME VERSION BLOCK.\" Contains three
groups: One for the keyword \"package\", one for the package
name, and one for the discovery of a following BLOCK.")
+ ;; This gets a regexp of its own because classes allow attributes
+ ;; (e.g. ":isa(Parent)") while packages don't. We skip over it, but
+ ;; like for "package" we capture the following ";" or "{".
+ (defconst cperl--class-for-imenu-rx
+ `(sequence symbol-start
+ (group-n 1 "class")
+ ,cperl--ws*-rx
+ (group-n 2 ,cperl--normal-identifier-rx)
+ (optional (sequence ,cperl--ws+-rx
+ (regexp ,cperl--version-regexp)))
+ (optional (sequence ,cperl--ws*-rx
+ ,cperl--attribute-list-rx))
+ ,cperl--ws*-rx
+ (group-n 3 (or ";" "{")))
+ "A regular expression to collect package names for `imenu'.
+Catches \"class NAME;\", \"class NAME VERSION;\", \"class NAME
+BLOCK\" and \"class NAME VERSION BLOCK\" and allows for
+attributes like \":isa(Parent)\". Contains three groups: One for
+the keyword \"package\", one for the package name, and one for
+the discovery of a following BLOCK.")
+
(defconst cperl--sub-name-for-imenu-rx
`(sequence symbol-start
(optional (sequence (group-n 3 (or "my" "state" "our"))
,cperl--ws+-rx))
- (group-n 1 "sub")
+ (group-n 1 (or "method" "sub"))
,cperl--ws+-rx
(group-n 2 ,cperl--normal-identifier-rx))
- "A regular expression to detect a subroutine start.
-Contains three groups: One to distinguish lexical from
-\"normal\" subroutines, for the keyword \"sub\", and one for the
-subroutine name.")
+ "A regular expression to detect a subroutine or method start.
+Contains three groups: One to distinguish lexical from \"normal\"
+subroutines, for the keyword \"sub\" or \"method\", and one for
+the subroutine name.")
(defconst cperl--block-declaration-rx
`(sequence
- (or "package" "sub") ; "class" and "method" coming soon
+ (or "class" "method" "package" "sub")
(1+ ,cperl--ws-or-comment-rx)
,cperl--normal-identifier-rx)
"A regular expression to find a declaration for a named block.
Used for indentation. These declarations introduce a block which
does not need a semicolon to terminate the statement.")
+;;; Initializer blocks are not (yet) part of the Perl core.
+;; (defconst cperl--field-declaration-rx
+;; `(sequence
+;; "field"
+;; (1+ ,cperl--ws-or-comment-rx)
+;; ,cperl--basic-variable-rx)
+;; "A regular expression to find a declaration for a field.
+;; Used for indentation. These declarations allow an initializer
+;; block which does not need a semicolon to terminate the
+;; statement.")
+
(defconst cperl--pod-heading-rx
`(sequence line-start
(group-n 1 "=head")
@@ -1318,15 +1463,25 @@ heading text.")
(defconst cperl--imenu-entries-rx
`(or ,cperl--package-for-imenu-rx
+ ,cperl--class-for-imenu-rx
,cperl--sub-name-for-imenu-rx
,cperl--pod-heading-rx)
"A regular expression to collect stuff that goes into the `imenu' index.
-Covers packages, subroutines, and POD headings.")
+Covers packages and classes, subroutines and methods, and POD headings.")
;; end of eval-and-compiled stuff
)
+(defun cperl-declaration-header-p (pos)
+ "Return t if POS is in the header of a declaration.
+Perl syntax can have various constructs between a
+keyword (e.g. \"sub\") and its associated block of code, and
+these can span several lines. These blocks are identified and
+marked with a text-property in `cperl-find-pods-heres'. This
+function tests that property."
+ (equal (get-text-property pos 'syntax-type) 'sub-decl))
+
(defun cperl-block-declaration-p ()
"Test whether the following ?\\{ opens a declaration block.
Returns the column where the declaring keyword is found, or nil
@@ -1345,6 +1500,9 @@ statement, so there's no semicolon."
((looking-at (rx (eval cperl--block-declaration-rx)))
(setq is-block-declaration (current-column)
continue-searching nil))
+ ((cperl-declaration-header-p (point))
+ (setq is-block-declaration (current-column)
+ continue-searching nil))
;; Another brace means this is no block declaration
((looking-at "{")
(setq continue-searching nil))
@@ -1400,7 +1558,7 @@ the last)."
(if attr (concat
"\\("
cperl-maybe-white-and-comment-rex ; whitespace-comments
- "\\(\\sw\\|_\\)+" ; attr-name
+ "\\(\\<\\sw\\|_\\)+" ; attr-name
;; attr-arg (1 level of internal parens allowed!)
"\\((\\(\\\\.\\|[^\\()]\\|([^\\()]*)\\)*)\\)?"
"\\(" ; optional : (XXX allows trailing???)
@@ -1415,7 +1573,7 @@ the last)."
;; Tired of editing this in 8 places every time I remember that there
;; is another method-defining keyword
(defvar cperl-sub-keywords
- '("sub"))
+ '("sub" "method"))
(defvar cperl-sub-regexp (regexp-opt cperl-sub-keywords))
@@ -1476,8 +1634,6 @@ the last)."
;; Fix for msb.el
(defvar cperl-msb-fixed nil)
(defvar cperl-use-major-mode 'cperl-mode)
-(defvar cperl-font-lock-multiline-start nil)
-(defvar cperl-font-lock-multiline nil)
(defvar cperl-font-locking nil)
(defvar cperl-compilation-error-regexp-list
@@ -1561,30 +1717,21 @@ into
\\{cperl-mode-map}
-Setting the variable `cperl-font-lock' to t switches on `font-lock-mode'
-\(even with older Emacsen), `cperl-electric-lbrace-space' to t switches
-on electric space between $ and {, `cperl-electric-parens-string' is
-the string that contains parentheses that should be electric in CPerl
-\(see also `cperl-electric-parens-mark' and `cperl-electric-parens'),
-setting `cperl-electric-keywords' enables electric expansion of
-control structures in CPerl. `cperl-electric-linefeed' governs which
-one of two linefeed behavior is preferable. You can enable all these
-options simultaneously (recommended mode of use) by setting
-`cperl-hairy' to t. In this case you can switch separate options off
-by setting them to `null'. Note that one may undo the extra
-whitespace inserted by semis and braces in `auto-newline'-mode by
-consequent \\[cperl-electric-backspace].
-
-If your site has perl5 documentation in info format, you can use commands
-\\[cperl-info-on-current-command] and \\[cperl-info-on-command] to access it.
-These keys run commands `cperl-info-on-current-command' and
-`cperl-info-on-command', which one is which is controlled by variable
-`cperl-info-on-command-no-prompt' and `cperl-clobber-lisp-bindings'
-\(in turn affected by `cperl-hairy').
-
-Even if you have no info-format documentation, short one-liner-style
-help is available on \\[cperl-get-help], and one can run perldoc or
-man via menu.
+Setting the variable `cperl-font-lock' to t switches on `font-lock-mode',
+`cperl-electric-lbrace-space' to t switches on electric space between $
+and {, `cperl-electric-parens-string' is the string that contains
+parentheses that should be electric in CPerl (see also
+`cperl-electric-parens-mark' and `cperl-electric-parens'), setting
+`cperl-electric-keywords' enables electric expansion of control
+structures in CPerl. `cperl-electric-linefeed' governs which one of two
+linefeed behavior is preferable. You can enable all these options
+simultaneously by setting `cperl-hairy' to t. In this case you can
+switch separate options off by setting them to `null'. Note that one may
+undo the extra whitespace inserted by semis and braces in
+`auto-newline'-mode by consequent \\[cperl-electric-backspace].
+
+Short one-liner-style help is available on \\[cperl-get-help],
+and one can run perldoc or man via menu.
It is possible to show this help automatically after some idle time.
This is regulated by variable `cperl-lazy-help-time'. Default with
@@ -1676,8 +1823,8 @@ or as help on variables `cperl-tips', `cperl-problems',
(cperl-val 'cperl-info-on-command-no-prompt))
(progn
;; don't clobber the backspace binding:
- (define-key cperl-mode-map "\C-hf" 'cperl-info-on-current-command)
- (define-key cperl-mode-map "\C-c\C-hf" 'cperl-info-on-command)))
+ (define-key cperl-mode-map "\C-hf" 'cperl-perldoc)
+ (define-key cperl-mode-map "\C-c\C-hf" 'cperl-perldoc)))
(setq local-abbrev-table cperl-mode-abbrev-table)
(if (cperl-val 'cperl-electric-keywords)
(abbrev-mode 1))
@@ -1686,7 +1833,6 @@ or as help on variables `cperl-tips', `cperl-problems',
(when (< emacs-major-version 27)
(setq-local open-paren-in-column-0-is-defun-start nil))
;; Until Emacs is multi-threaded, we do not actually need it local:
- (make-local-variable 'cperl-font-lock-multiline-start)
(make-local-variable 'cperl-font-locking)
(setq-local outline-regexp cperl-outline-regexp)
(setq-local outline-level 'cperl-outline-level)
@@ -1713,8 +1859,11 @@ or as help on variables `cperl-tips', `cperl-problems',
(concat "^[ \t]*\\("
cperl-sub-regexp
(cperl-after-sub-regexp 'named 'attr-groups)
+ (rx (eval cperl--ws*-rx))
+ (rx (optional (eval cperl--signature-rx)))
"\\|" ; per toke.c
- "\\(BEGIN\\|UNITCHECK\\|CHECK\\|INIT\\|END\\|AUTOLOAD\\|DESTROY\\)"
+ (rx (or "ADJUST" "AUTOLOAD" "BEGIN" "CHECK" "DESTROY"
+ "END" "INIT" "UNITCHECK"))
"\\)"
cperl-maybe-white-and-comment-rex))
(setq-local comment-indent-function #'cperl-comment-indent)
@@ -1759,7 +1908,6 @@ or as help on variables `cperl-tips', `cperl-problems',
;; to re-apply them.
(setq cperl-syntax-done-to start)
(cperl-fontify-syntactically end))))
- (setq cperl-font-lock-multiline t) ; Not localized...
(setq-local font-lock-multiline t)
(setq-local font-lock-fontify-region-function
#'cperl-font-lock-fontify-region-function)
@@ -1786,9 +1934,12 @@ or as help on variables `cperl-tips', `cperl-problems',
;; Setup Flymake
(add-hook 'flymake-diagnostic-functions #'perl-flymake nil t))
+(derived-mode-add-parents 'cperl-mode '(perl-mode))
+
(defun cperl--set-file-style ()
(when cperl-file-style
- (cperl-set-style cperl-file-style)))
+ (cperl-file-style cperl-file-style)))
+
;; Fix for perldb - make default reasonable
(defun cperl-db ()
@@ -2557,6 +2708,9 @@ PRESTART is the position basing on which START was found."
(<= parse-start start-point))
(goto-char parse-start)
(beginning-of-defun)
+ (when (cperl-declaration-header-p (point))
+ (goto-char (cperl-beginning-of-property (point) 'syntax-type))
+ (beginning-of-line))
(setq start-state nil))
(setq prestart (point))
(if start-state nil
@@ -2579,7 +2733,7 @@ PRESTART is the position basing on which START was found."
(defun cperl-beginning-of-property (p prop &optional lim)
"Given that P has a property PROP, find where the property starts.
Will not look before LIM."
-;;; XXXX What to do at point-max???
+;; XXXX What to do at point-max???
(or (previous-single-property-change (cperl-1+ p) prop lim)
(point-min))
;; (cond ((eq p (point-min))
@@ -2693,6 +2847,7 @@ Will not look before LIM."
;; in which case this line is the first argument decl.
(skip-chars-forward " \t")
(cperl-backward-to-noncomment (or old-indent (point-min)))
+ ;; Determine whether point is between statements
(setq state
(or (bobp)
(eq (point) old-indent) ; old-indent was at comment
@@ -2711,7 +2866,8 @@ Will not look before LIM."
(looking-at
(rx (sequence (0+ blank)
(eval cperl--label-rx))))))
- (get-text-property (point) 'first-format-line)))
+ (get-text-property (1- (point)) 'first-format-line)
+ (equal (get-text-property (point) 'syntax-type) 'format)))
;; Look at previous line that's at column 0
;; to determine whether we are in top-level decls
@@ -2748,10 +2904,13 @@ Will not look before LIM."
;; Back up over label lines, since they don't
;; affect whether our line is a continuation.
;; (Had \, too)
- (while (and (eq (preceding-char) ?:)
+ (while (save-excursion
+ (and (eq (preceding-char) ?:)
(re-search-backward
(rx (sequence (eval cperl--label-rx) point))
- nil t))
+ nil t)
+ ;; Ignore if in comment or RE
+ (not (nth 3 (syntax-ppss)))))
;; This is always FALSE?
(if (eq (preceding-char) ?\,)
;; Will go to beginning of line, essentially.
@@ -2763,12 +2922,15 @@ Will not look before LIM."
(if (not (or (eq (1- (point)) containing-sexp)
(and cperl-indent-parens-as-block
(not is-block))
- (save-excursion (cperl-block-declaration-p))
+ (and (looking-at "{")
+ (save-excursion (cperl-block-declaration-p)))
(memq (preceding-char)
(append (if is-block " ;{" " ,;{") '(nil)))
(and (eq (preceding-char) ?\})
(cperl-after-block-and-statement-beg
containing-sexp))
+ (and (cperl-declaration-header-p indent-point)
+ (not (cperl-declaration-header-p char-after-pos)))
(get-text-property (point) 'first-format-line)))
;; This line is continuation of preceding line's statement;
;; indent `cperl-continued-statement-offset' more than the
@@ -2847,12 +3009,11 @@ Will not look before LIM."
;; anonymous sub in a hash.
(if (and;; Is it a sub in group starting on this line?
cperl-indent-subs-specially
- (cond ((get-text-property (point) 'attrib-group)
- (goto-char (cperl-beginning-of-property
- (point) 'attrib-group)))
- ((eq (preceding-char) ?b)
- (forward-sexp -1)
- (looking-at (concat cperl-sub-regexp "\\>"))))
+ (cond
+ ((cperl-declaration-header-p (point))
+ (goto-char
+ (cperl-beginning-of-property (point)
+ 'syntax-type))))
(setq p (nth 1 ; start of innermost containing list
(parse-partial-sexp
(line-beginning-position)
@@ -2918,11 +3079,12 @@ and closing parentheses and brackets."
;;
((eq 'REx-part2 (elt i 0)) ;; [self start] start of /REP in s//REP/x
(goto-char (elt i 1))
- (condition-case nil ; Use indentation of the 1st part
- (forward-sexp -1))
+ (condition-case nil
+ (forward-sexp -1) ; Use indentation of the 1st part
+ (error nil))
(current-column))
((eq 'indentable (elt i 0)) ; Indenter for REGEXP qw() etc
- (cond ;;; [indentable terminator start-pos is-block]
+ (cond ; [indentable terminator start-pos is-block]
((eq 'terminator (elt i 1)) ; Lone terminator of "indentable string"
(goto-char (elt i 2)) ; After opening parens
(1- (current-column)))
@@ -2995,6 +3157,9 @@ and closing parentheses and brackets."
(goto-char (elt i 1)) ; statement-start
(+ (if (or (memq (elt i 2) (append "}])" nil)) ; char-after
(eq 'continuation ; do not stagger continuations
+ ;; FIXME: This clobbers the syntax state in parse-data
+ ;; for the *following* lines and makes the state
+ ;; useless for indent-region -- haj 2023-06-30
(elt (cperl-sniff-for-indent parse-data) 0)))
0 ; Closing parenthesis or continuation of a continuation
cperl-continued-statement-offset)
@@ -3005,7 +3170,8 @@ and closing parentheses and brackets."
;; Now it is a hash reference
(+ cperl-indent-level cperl-close-paren-offset))
;; Labels do not take :: ...
- (if (looking-at "\\(\\w\\|_\\)+[ \t]*:[^:]")
+ (if (and (looking-at "\\(\\w\\|_\\)+[ \t]*:[^:]")
+ (not (looking-at (rx (eval cperl--false-label-rx)))))
(if (> (current-indentation) cperl-min-label-indent)
(- (current-indentation) cperl-label-offset)
;; Do not move `parse-data', this should
@@ -3393,7 +3559,9 @@ position of the end of the unsafe construct."
(goto-char (nth 8 state)) ; beginning of this here-doc
(cperl-backward-to-noncomment ; skip back over more
(point-min)) ; here-documents (if any)
- (beginning-of-line)))) ; skip back over here-doc starters
+ (beginning-of-line)) ; skip back over here-doc starters
+ ((nth 4 state) ; in a comment (or POD)
+ (goto-char (nth 8 state))))) ; ...so go to its beginning
(while (and pos (progn
(beginning-of-line)
(get-text-property (setq pos (point)) 'syntax-type)))
@@ -3426,7 +3594,7 @@ position of the end of the unsafe construct."
(setq end (point)))))
(or end pos)))))
-(defun cperl-find-sub-attrs (&optional st-l b-fname e-fname pos)
+(defun cperl-find-sub-attrs (&optional st-l _b-fname _e-fname pos)
"Syntactically mark (and fontify) attributes of a subroutine.
Should be called with the point before leading colon of an attribute."
;; Works *before* syntax recognition is done
@@ -3440,7 +3608,7 @@ Should be called with the point before leading colon of an attribute."
"\\)"
(if after-first "?" "")
;; No space between name and paren allowed...
- "\\(\\sw+\\)" ; 3=name
+ (rx (group (eval cperl--basic-identifier-rx))) ; 3=name
"\\((\\)?")) ; 4=optional paren
(and (match-beginning 1)
(cperl-postpone-fontification
@@ -3468,22 +3636,36 @@ Should be called with the point before leading colon of an attribute."
"L%d: attribute `%s': %s"
(count-lines (point-min) (point))
(and start1 end1 (buffer-substring start1 end1)) b)
- (setq start nil)))
- (and start
- (progn
- (put-text-property start (point)
- 'attrib-group (if (looking-at "{") t 0))
- (and pos
- (< 1 (count-lines (+ 3 pos) (point))) ; end of `sub'
- ;; Apparently, we do not need `multiline': faces added now
- (put-text-property (+ 3 pos) (cperl-1+ (point))
- 'syntax-type 'sub-decl))
- (and b-fname ; Fontify here: the following condition
- (cperl-postpone-fontification ; is too hard to determine by
- b-fname e-fname 'face ; a REx, so do it here
- (if (looking-at "{")
- font-lock-function-name-face
- font-lock-variable-name-face)))))
+ ; (setq start nil) I'd like to keep trying -- haj 2023-06-26
+ ))
+ (cond
+ ;; Allow for a complete signature and trailing spaces here
+ ((search-forward-regexp (rx (sequence point
+ (eval cperl--ws*-rx)
+ (eval cperl--signature-rx)
+ (eval cperl--ws*-rx)))
+ nil
+ t)) ; NOERROR
+ ((looking-at (rx "("))
+ ;; We might be in the process of typing a prototype or
+ ;; signature. These start with a left paren, so we want this to
+ ;; be included into the area marked as sub-decl.
+ nil)
+ ;; Else, we are in no mans land. Just keep trying.
+ (t
+ ))
+ (when (looking-at (rx (in ";{")))
+ ;; A semicolon ends the declaration, an opening brace begins the
+ ;; BLOCK. Neither is part of the declaration.
+ (backward-char))
+ (when start
+ (put-text-property start (point)
+ 'attrib-group (if (looking-at "{") t 0))
+ (and pos
+ (progn
+ ;; Apparently, we do not need `multiline': faces added now
+ (put-text-property (+ 3 pos) (cperl-1+ (point))
+ 'syntax-type 'sub-decl))))
;; now restore the initial state
(if st
(progn
@@ -3606,7 +3788,7 @@ move point but does change match data."
delim-begin delim-end)
"Process a here-document's delimiters and body.
The parameters MIN, MAX, END, OVERSHOOT, STOP-POINT, ERR-L are
-used for recursive calls to `cperl-find-pods-here' to handle the
+used for recursive calls to `cperl-find-pods-heres' to handle the
rest of the line which contains the delimiter. MATCHED-POS and
TODO-POS are initial values for this function's result.
END-OF-HERE-DOC is the end of a previous here-doc in the same
@@ -3774,8 +3956,10 @@ recursive calls in starting lines of here-documents."
max))
(search
(concat
- "\\(\\`\n?\\|^\n\\)=" ; POD
+ ;; -------- POD using capture group 1
+ "\\(\\`\n?\\|^\n\\)="
"\\|"
+ ;; -------- HERE-document capture groups 2-7
;; One extra () before this:
"<<\\(~?\\)" ; HERE-DOC, indented-p = capture 2
"\\(" ; 2 + 1
@@ -3785,45 +3969,57 @@ recursive calls in starting lines of here-documents."
"\\([^\"'`\n]*\\)" ; 4 + 1
"\\4"
"\\|"
- ;; Second variant: Identifier or \ID (same as 'ID') or empty
- "\\\\?\\(\\([a-zA-Z_][a-zA-Z_0-9]*\\)?\\)" ; 5 + 1, 6 + 1
- ;; Do not have <<= or << 30 or <<30 or << $blah.
- ;; "\\([^= \t0-9$@%&]\\|[ \t]+[^ \t\n0-9$@%&]\\)" ; 6 + 1
+ ;; Second variant: Identifier or \ID (same as 'ID')
+ "\\\\?\\(\\([a-zA-Z_][a-zA-Z_0-9]*\\)\\)" ; 5 + 1, 6 + 1
"\\)"
"\\|"
+ ;; -------- format capture groups 8-9
;; 1+6 extra () before this:
- "^[ \t]*\\(format\\)[ \t]*\\([a-zA-Z0-9_]+\\)?[ \t]*=[ \t]*$" ;FRMAT
+ "^[ \t]*\\(format\\)[ \t]*\\([a-zA-Z0-9_]+\\)?[ \t]*=[ \t]*$"
(if cperl-use-syntax-table-text-property
(concat
"\\|"
+ ;; -------- quoted constructs and regexps, group 10
;; 1+6+2=9 extra () before this:
- "\\<\\(q[wxqr]?\\|[msy]\\|tr\\)\\>" ; QUOTED CONSTRUCT
+ "\\<\\(q[wxqr]?\\|[msy]\\|tr\\)\\>"
"\\|"
+ ;; -------- "bare" regex or glob, group 11
;; 1+6+2+1=10 extra () before this:
"\\([/<]\\)" ; /blah/ or <file*glob>
"\\|"
+ ;; -------- subroutine declarations, groups 12-17
;; 1+6+2+1+1=11 extra () before this
- "\\<" cperl-sub-regexp "\\>" ; sub with proto/attr
- "\\("
- cperl-white-and-comment-rex
- (rx (opt (group (eval cperl--normal-identifier-rx))))
- "\\)"
- "\\("
- cperl-maybe-white-and-comment-rex
- "\\(([^()]*)\\|:[^:]\\)\\)" ; prototype or attribute start
+ (rx (sequence
+ word-start
+ (group (regexp cperl-sub-regexp)) ; #12
+ (eval cperl--ws+-rx)
+ (opt (group (eval cperl--normal-identifier-rx))) ; #13
+ (eval cperl--ws*-rx)
+ (group (or (group (eval cperl--prototype-rx)) ; #14,#15
+ ;; (group (eval cperl--signature-rx)) ; #16
+ (group unmatchable) ; #16
+ (group (or anything buffer-end)))))) ; #17
"\\|"
- ;; 1+6+2+1+1+6=17 extra () before this:
+ ;; -------- weird variables, capture group 18
+ ;; FIXME: We don't need that group -- haj 2023-06-21
+ ;; 1+6+2+1+1+6=17 extra () before this
"\\$\\(['{]\\)" ; $' or ${foo}
"\\|"
+ ;; -------- old-style ' as package separator, group 19
;; 1+6+2+1+1+6+1=18 extra () before this (old pack'var syntax;
;; we do not support intervening comments...):
"\\(\\<" cperl-sub-regexp "[ \t\n\f]+\\|[&*$@%]\\)[a-zA-Z0-9_]*'"
- ;; 1+6+2+1+1+6+1+1=19 extra () before this:
"\\|"
+ ;; -------- __END__ and __DATA__ tokens, group 20
+ ;; 1+6+2+1+1+6+1+1=19 extra () before this:
"__\\(END\\|DATA\\)__" ; __END__ or __DATA__
;; 1+6+2+1+1+6+1+1+1=20 extra () before this:
"\\|"
- "\\\\\\(['`\"($]\\)") ; BACKWACKED something-hairy
+ ;; -------- backslash-escaped stuff, don't interpret it
+ "\\\\\\(['`\"($]\\)" ; BACKWACKED something-hairy
+ "\\|"
+ ;; -------- $\ is a variable in code, but not in a string
+ "\\(\\$\\\\\\)")
"")))
warning-message)
(unwind-protect
@@ -3877,7 +4073,12 @@ recursive calls in starting lines of here-documents."
(cperl-modify-syntax-type bb cperl-st-punct)))
;; No processing in strings/comments beyond this point:
((or (nth 3 state) (nth 4 state))
- t) ; Do nothing in comment/string
+ ;; Edge case: In a double-quoted string, $\ is not the
+ ;; punctuation variable, $ must not quote \ here. We
+ ;; generally make $ a punctuation character in strings
+ ;; and comments (Bug#69604).
+ (when (match-beginning 22)
+ (cperl-modify-syntax-type (match-beginning 22) cperl-st-punct)))
((match-beginning 1) ; POD section
;; "\\(\\`\n?\\|^\n\\)="
(setq b (match-beginning 0)
@@ -3965,20 +4166,10 @@ recursive calls in starting lines of here-documents."
;; Here document
;; We can do many here-per-line;
;; but multiline quote on the same line as <<HERE confuses us...
- ;; ;; One extra () before this:
- ;;"<<"
+ ;; One extra () before this:
;; "<<\\(~?\\)" ; HERE-DOC, indented-p = capture 2
- ;; ;; First variant "BLAH" or just ``.
- ;; "[ \t]*" ; Yes, whitespace is allowed!
- ;; "\\([\"'`]\\)" ; 3 + 1
- ;; "\\([^\"'`\n]*\\)" ; 4 + 1
- ;; "\\4"
- ;; "\\|"
- ;; ;; Second variant: Identifier or \ID or empty
- ;; "\\\\?\\(\\([a-zA-Z_][a-zA-Z_0-9]*\\)?\\)" ; 5 + 1, 6 + 1
- ;; ;; Do not have <<= or << 30 or <<30 or << $blah.
- ;; ;; "\\([^= \t0-9$@%&]\\|[ \t]+[^ \t\n0-9$@%&]\\)" ; 6 + 1
- ;; "\\)"
+ ;; First variant "BLAH" or just ``: capture groups 4 and 5
+ ;; Second variant: Identifier or \ID: capture group 6 and 7
((match-beginning 3) ; 2 + 1: found "<<", detect its type
(let* ((matched-pos (match-beginning 0))
(quoted-delim-p (if (match-beginning 6) nil t))
@@ -3997,14 +4188,11 @@ recursive calls in starting lines of here-documents."
overshoot (nth 1 here-doc-results))
(and (nth 2 here-doc-results)
(setq warning-message (nth 2 here-doc-results)))))))
- ;; format
+ ;; format capture groups 8-9
((match-beginning 8)
- ;; 1+6=7 extra () before this:
- ;;"^[ \t]*\\(format\\)[ \t]*\\([a-zA-Z0-9_]+\\)?[ \t]*=[ \t]*$"
(setq b (point)
- name (if (match-beginning 8) ; 7 + 1
- (buffer-substring (match-beginning 8) ; 7 + 1
- (match-end 8)) ; 7 + 1
+ name (if (match-beginning 9) ; 7 + 2
+ (match-string-no-properties 9) ; 7 + 2
"")
tb (match-beginning 0))
(setq argument nil)
@@ -4037,10 +4225,10 @@ recursive calls in starting lines of here-documents."
(if (looking-at "^\\.$") ; ";" is not supported yet
(progn
;; Highlight the ending delimiter
- (cperl-postpone-fontification (point) (+ (point) 2)
+ (cperl-postpone-fontification (point) (+ (point) 1)
'face font-lock-string-face)
- (cperl-commentify (point) (+ (point) 2) nil)
- (cperl-put-do-not-fontify (point) (+ (point) 2) t))
+ (cperl-commentify (point) (+ (point) 1) nil)
+ (cperl-put-do-not-fontify (point) (+ (point) 1) t))
(setq warning-message
(format "End of format `%s' not found." name))
(or (car err-l) (setcar err-l b)))
@@ -4048,12 +4236,9 @@ recursive calls in starting lines of here-documents."
(if (> (point) max)
(setq tmpend tb))
(put-text-property b (point) 'syntax-type 'format))
- ;; qq-like String or Regexp:
+ ;; quotelike operator or regexp: capture groups 10 or 11
+ ;; matches some false positives, to be eliminated here
((or (match-beginning 10) (match-beginning 11))
- ;; 1+6+2=9 extra () before this:
- ;; "\\<\\(q[wxqr]?\\|[msy]\\|tr\\)\\>"
- ;; "\\|"
- ;; "\\([/<]\\)" ; /blah/ or <file*glob>
(setq b1 (if (match-beginning 10) 10 11)
argument (buffer-substring
(match-beginning b1) (match-end b1))
@@ -4110,13 +4295,23 @@ recursive calls in starting lines of here-documents."
(and (eq (char-syntax (preceding-char)) ?w)
(progn
(forward-sexp -1)
-;; After these keywords `/' starts a RE. One should add all the
-;; functions/builtins which expect an argument, but ...
+ ;; After these keywords `/'
+ ;; starts a RE. One should
+ ;; add all the
+ ;; functions/builtins which
+ ;; expect an argument, but
+ ;; ...
(and
(not (memq (preceding-char)
'(?$ ?@ ?& ?%)))
(looking-at
- "\\(while\\|if\\|unless\\|until\\|for\\(each\\)?\\|and\\|or\\|not\\|xor\\|split\\|grep\\|map\\|print\\|say\\|return\\)\\>"))))
+ (regexp-opt
+ '("while" "if" "unless"
+ "until" "for" "foreach"
+ "and" "or" "not"
+ "xor" "split" "grep" "map"
+ "print" "say" "return")
+ 'symbols)))))
(and (eq (preceding-char) ?.)
(eq (char-after (- (point) 2)) ?.))
(bobp))
@@ -4316,12 +4511,13 @@ recursive calls in starting lines of here-documents."
(1- e) e 'face my-cperl-delimiters-face)))
(if (and is-REx cperl-regexp-scan)
;; Process RExen: embedded comments, charclasses and ]
-;;;/\3333\xFg\x{FFF}a\ppp\PPP\qqq\C\99f(?{ foo })(??{ foo })/;
-;;;/a\.b[^a[:ff:]b]x$ab->$[|$,$ab->[cd]->[ef]|$ab[xy].|^${a,b}{c,d}/;
-;;;/(?<=foo)(?<!bar)(x)(?:$ab|\$\/)$|\\\b\x888\776\[\:$/xxx;
-;;;m?(\?\?{b,a})? + m/(??{aa})(?(?=xx)aa|bb)(?#aac)/;
-;;;m$(^ab[c]\$)$ + m+(^ab[c]\$\+)+ + m](^ab[c\]$|.+)] + m)(^ab[c]$|.+\));
-;;;m^a[\^b]c^ + m.a[^b]\.c.;
+ ;; Examples:
+ ;;/\3333\xFg\x{FFF}a\ppp\PPP\qqq\C\99f(?{ foo })(??{ foo })/;
+ ;;/a\.b[^a[:ff:]b]x$ab->$[|$,$ab->[cd]->[ef]|$ab[xy].|^${a,b}{c,d}/;
+ ;;/(?<=foo)(?<!bar)(x)(?:$ab|\$\/)$|\\\b\x888\776\[\:$/xxx;
+ ;;m?(\?\?{b,a})? + m/(??{aa})(?(?=xx)aa|bb)(?#aac)/;
+ ;;m$(^ab[c]\$)$ + m+(^ab[c]\$\+)+ + m](^ab[c\]$|.+)] + m)(^ab[c]$|.+\));
+ ;;m^a[\^b]c^ + m.a[^b]\.c.;
(save-excursion
(goto-char (1+ b))
;; First
@@ -4385,8 +4581,6 @@ recursive calls in starting lines of here-documents."
"\\?([0-9]+)" ; (?(1)foo|bar)
"\\|"
"\\?<[=!]"
- ;;;"\\|"
- ;;; "\\?"
"\\)?"
"\\)"
"\\|"
@@ -4531,8 +4725,8 @@ recursive calls in starting lines of here-documents."
(setq REx-subgr-end qtag) ;End smart-highlighted
;; Apparently, I can't put \] into a charclass
;; in m]]: m][\\\]\]] produces [\\]]
-;;; POSIX? [:word:] [:^word:] only inside []
-;;; "\\=\\(\\\\.\\|[^][\\]\\|\\[:\\^?\sw+:]\\|\\[[^:]\\)*]")
+ ;; POSIX? [:word:] [:^word:] only inside []
+ ;; "\\=\\(\\\\.\\|[^][\\]\\|\\[:\\^?\sw+:]\\|\\[[^:]\\)*]")
(while ; look for unescaped ]
(and argument
(re-search-forward
@@ -4692,42 +4886,42 @@ recursive calls in starting lines of here-documents."
'REx-part2 t)))))
(if (> (point) max)
(setq tmpend tb))))
- ((match-beginning 17) ; sub with prototype or attribute
+ ((match-beginning 14) ; sub with prototype or attribute
;; 1+6+2+1+1=11 extra () before this (sub with proto/attr):
- ;;"\\<sub\\>\\(" ;12
- ;; cperl-white-and-comment-rex ;13
- ;; "\\([a-zA-Z_:'0-9]+\\)\\)?" ; name ;14
- ;;"\\(" cperl-maybe-white-and-comment-rex ;15,16
- ;; "\\(([^()]*)\\|:[^:]\\)\\)" ; 17:proto or attribute start
- (setq b1 (match-beginning 14) e1 (match-end 14))
+ ;; match-string 12: Keyword "sub" or "method"
+ ;; match-string 13: Name of the subroutine (optional)
+ ;; match-string 14: Indicator for proto/attr/signature
+ ;; match-string 15: Prototype
+ ;; match-string 16: unused
+ ;; match-string 17: Distinguish declaration/definition
+ (setq b1 (match-beginning 13) e1 (match-end 13))
(if (memq (char-after (1- b))
'(?\$ ?\@ ?\% ?\& ?\*))
- nil
+ nil ;; we found $sub or @method etc
(goto-char b)
- (if (eq (char-after (match-beginning 17)) ?\( )
+ (if (match-beginning 15) ; a complete prototype
(progn
(cperl-commentify ; Prototypes; mark as string
- (match-beginning 17) (match-end 17) t)
+ (match-beginning 15) (match-end 15) t)
(goto-char (match-end 0))
;; Now look for attributes after prototype:
(forward-comment (buffer-size))
- (and (looking-at ":[^:]")
- (cperl-find-sub-attrs st-l b1 e1 b)))
- ;; treat attributes without prototype
+ (cperl-find-sub-attrs st-l b1 e1 b))
+ ;; treat attributes without prototype and incomplete stuff
(goto-char (match-beginning 17))
(cperl-find-sub-attrs st-l b1 e1 b))))
;; 1+6+2+1+1+6+1=18 extra () before this:
;; "\\(\\<sub[ \t\n\f]+\\|[&*$@%]\\)[a-zA-Z0-9_]*'")
((match-beginning 19) ; old $abc'efg syntax
(setq bb (match-end 0))
- ;;;(if (nth 3 state) nil ; in string
(put-text-property (1- bb) bb 'syntax-table cperl-st-word)
(goto-char bb))
;; 1+6+2+1+1+6+1+1=19 extra () before this:
;; "__\\(END\\|DATA\\)__"
((match-beginning 20) ; __END__, __DATA__
- (setq bb (match-end 0))
- ;; (put-text-property b (1+ bb) 'syntax-type 'pod) ; Cheat
+ (if (eq cperl-fontify-trailer 'perl-code)
+ (setq bb (match-end 0))
+ (setq bb (point-max)))
(cperl-commentify b bb nil)
(setq end t))
;; "\\\\\\(['`\"($]\\)"
@@ -4736,7 +4930,7 @@ recursive calls in starting lines of here-documents."
(setq bb (match-end 0))
(goto-char b)
(skip-chars-backward "\\\\")
- ;;;(setq i2 (= (% (skip-chars-backward "\\\\") 2) -1))
+ ;; (setq i2 (= (% (skip-chars-backward "\\\\") 2) -1))
(cperl-modify-syntax-type b cperl-st-punct)
(goto-char bb))
(t (error "Error in regexp of the sniffer")))
@@ -4847,7 +5041,11 @@ statement would start; thus the block in ${func()} does not count."
(save-excursion
(forward-sexp -1)
;; else {} but not else::func {}
- (or (and (looking-at "\\(else\\|catch\\|try\\|continue\\|grep\\|map\\|BEGIN\\|END\\|UNITCHECK\\|CHECK\\|INIT\\)\\>")
+ (or (and (looking-at (rx (or "else" "catch" "try"
+ "finally" "defer"
+ "continue" "grep" "map"
+ "ADJUST" "BEGIN" "CHECK" "END"
+ "INIT" "UNITCHECK")))
(not (looking-at "\\(\\sw\\|_\\)+::")))
;; sub f {}
(progn
@@ -5009,18 +5207,16 @@ conditional/loop constructs."
(if (eq (following-char) ?$ ) ; for my $var (list)
(progn
(forward-sexp -1)
- (if (looking-at "\\(state\\|my\\|local\\|our\\)\\>")
+ (if (looking-at "\\(state\\|my\\|local\\|our\\|field\\)\\>")
(forward-sexp -1))))
(if (looking-at
(concat "\\(elsif\\|if\\|unless\\|while\\|until"
+ "\\|try\\|catch\\|finally\\|defer"
"\\|for\\(each\\)?\\>\\(\\("
cperl-maybe-white-and-comment-rex
- "\\(state\\|my\\|local\\|our\\)\\)?"
+ "\\(state\\|my\\|local\\|our\\|field\\)\\)?"
cperl-maybe-white-and-comment-rex
- (rx
- (sequence
- "$"
- (eval cperl--basic-identifier-rx)))
+ (rx (eval cperl--basic-variable-rx))
"\\)?\\)\\>"))
(progn
(goto-char top)
@@ -5137,6 +5333,7 @@ Returns some position at the last line."
(opt (sequence "}" (0+ blank) ))
symbol-start
(or "else" "elsif" "continue" "if" "unless" "while" "until"
+ "try" "catch" "finally" "defer"
(sequence (or "for" "foreach")
(opt
(opt (sequence (1+ blank)
@@ -5314,6 +5511,10 @@ conditional/loop constructs."
(let ((comment-column new-comm-indent))
(indent-for-comment)))
(progn
+ ;; FIXME: It would be nice to keep indent-info, but this
+ ;; doesn not work if the region contains continuation
+ ;; lines (see `cperl-calculate-indent') -- haj 2023-06-30
+ (setq indent-info (list nil nil nil))
(setq i (cperl-indent-line indent-info))
(or comm
(not i)
@@ -5462,6 +5663,8 @@ indentation and initial hashes. Behaves usually outside of comment."
;; Previous space could have gone:
(or (memq (preceding-char) '(?\s ?\t)) (insert " "))))))
+;; The following lists are used for categorizing the entries found by
+;; `cperl-imenu--create-perl-index'.
(defvar cperl-imenu-package-keywords '("package" "class" "role"))
(defvar cperl-imenu-sub-keywords '("sub" "method" "function" "fun"))
(defvar cperl-imenu-pod-keywords '("=head"))
@@ -5480,16 +5683,16 @@ comment, or POD."
(index-pod-alist '())
(index-sub-alist '())
(index-unsorted-alist '())
- (package-stack '()) ; for package NAME BLOCK
- (current-package "(main)")
- (current-package-end (point-max))) ; end of package scope
+ (namespace-stack '()) ; for package NAME BLOCK
+ (current-namespace "(main)")
+ (current-namespace-end (point-max))) ; end of package scope
;; collect index entries
(while (re-search-forward (rx (eval cperl--imenu-entries-rx)) nil t)
;; First, check whether we have left the scope of previously
;; recorded packages, and if so, eliminate them from the stack.
- (while (< current-package-end (point))
- (setq current-package (pop package-stack))
- (setq current-package-end (pop package-stack)))
+ (while (< current-namespace-end (point))
+ (setq current-namespace (pop namespace-stack))
+ (setq current-namespace-end (pop namespace-stack)))
(let ((state (syntax-ppss))
(entry-type (match-string 1))
name marker) ; for the "current" entry
@@ -5500,15 +5703,15 @@ comment, or POD."
(setq name (match-string-no-properties 2)
marker (copy-marker (match-end 2)))
(if (string= (match-string 3) ";")
- (setq current-package name) ; package NAME;
+ (setq current-namespace name) ; package NAME;
;; No semicolon, therefore we have: package NAME BLOCK.
;; Stash the current package, because we need to restore
;; it after the end of BLOCK.
- (push current-package-end package-stack)
- (push current-package package-stack)
+ (push current-namespace-end namespace-stack)
+ (push current-namespace namespace-stack)
;; record the current name and its scope
- (setq current-package name)
- (setq current-package-end (save-excursion
+ (setq current-namespace name)
+ (setq current-namespace-end (save-excursion
(goto-char (match-beginning 3))
(forward-sexp)
(point))))
@@ -5519,14 +5722,14 @@ comment, or POD."
(unless (nth 4 state) ; skip if in a comment
(setq name (match-string-no-properties 2)
marker (copy-marker (match-end 2)))
- ;; Qualify the sub name with the package if it doesn't
+ ;; Qualify the sub name with the namespace if it doesn't
;; already have one, and if it isn't lexically scoped.
;; "my" and "state" subs are lexically scoped, but "our"
;; are just lexical aliases to package subs.
(if (and (null (string-match "::" name))
(or (null (match-string 3))
(string-equal (match-string 3) "our")))
- (setq name (concat current-package "::" name)))
+ (setq name (concat current-namespace "::" name)))
(let ((index (cons name marker)))
(push index index-alist)
(push index index-sub-alist)
@@ -5590,7 +5793,7 @@ comment, or POD."
hier-list)
index-alist)))
(and index-package-alist
- (push (cons "+Packages+..."
+ (push (cons "+Classes,Packages+..."
(nreverse index-package-alist))
index-alist))
(and (or index-package-alist index-pod-alist
@@ -5620,7 +5823,6 @@ comment, or POD."
(cond ((featurep 'ps-print)
(or cperl-faces-init
(progn
- (setq cperl-font-lock-multiline t)
(cperl-init-faces))))
((not cperl-faces-init)
(add-hook 'font-lock-mode-hook
@@ -5663,6 +5865,14 @@ default function."
cperl-here-face)
(t (funcall (default-value 'font-lock-syntactic-face-function) state))))
+(defface cperl-method-call
+ '((t (:inherit 'default )))
+ "Font Lock mode face for method calls.
+Usually, method calls are not fontified.
+We use this face to prevent calls to methods which look like
+builtin functions to be fontified like, well, builtin
+functions (which they are not). Inherits from `default'.")
+
(defun cperl-init-faces ()
(condition-case errs
(progn
@@ -5670,7 +5880,59 @@ default function."
(setq
t-font-lock-keywords
(list
- `("[ \t]+$" 0 ',cperl-invalid-face t)
+ ;; -------- function definition _and_ declaration
+ ;; (matcher (subexp facespec))
+ ;; facespec is evaluated depending on whether the
+ ;; statement ends in a "{" (definition) or ";"
+ ;; (declaration without body)
+ (list (concat "\\<" cperl-sub-regexp
+ ;; group 1: optional subroutine name
+ (rx
+ (sequence (eval cperl--ws+-rx)
+ (group (optional
+ (eval cperl--normal-identifier-rx)))))
+ ;; "fontified" elsewhere: Prototype
+ (rx (optional
+ (sequence (eval cperl--ws*-rx)
+ (eval cperl--prototype-rx))))
+ ;; fontified elsewhere: Attributes
+ (rx (optional (sequence (eval cperl--ws*-rx)
+ (eval cperl--attribute-list-rx))))
+ (rx (eval cperl--ws*-rx))
+ ;; group 2: Identifies the start of the anchor
+ (rx (group
+ (or (group-n 3 ";") ; Either a declaration...
+ "{" ; ... or a code block
+ ;; ... or a complete signature
+ (sequence (eval cperl--signature-rx)
+ (eval cperl--ws*-rx))
+ ;; ... or the start of a "sloppy" signature
+ (sequence (eval cperl--sloppy-signature-rx)
+ ;; arbitrarily continue "a few lines"
+ (repeat 0 200 (not (in "{"))))
+ ;; make sure we have a reasonably
+ ;; short match for an incomplete sub
+ (not (in ";{("))
+ buffer-end))))
+ '(1 (if (match-beginning 3)
+ 'font-lock-variable-name-face
+ 'font-lock-function-name-face)
+ nil ; override
+ t) ; laxmatch in case of anonymous subroutines
+ ;; -------- anchored: Signature
+ `(,(rx (sequence (in "(,")
+ (eval cperl--ws*-rx)
+ (group (eval cperl--basic-variable-rx))))
+ (progn
+ (goto-char (match-beginning 2)) ; pre-match: Back to sig
+ (match-end 2))
+ nil
+ (1 font-lock-variable-name-face)))
+ ;; -------- flow control
+ ;; (matcher . subexp) font-lock-keyword-face by default
+ ;; This highlights declarations and definitions differently.
+ ;; We do not try to highlight in the case of attributes:
+ ;; it is already done by `cperl-find-pods-heres'
(cons
(concat
"\\(^\\|[^$@%&\\]\\)\\<\\("
@@ -5680,16 +5942,27 @@ default function."
'("if" "until" "while" "elsif" "else"
"given" "when" "default" "break"
"unless" "for"
- "try" "catch" "finally"
+ "try" "catch" "defer" "finally"
"foreach" "continue" "exit" "die" "last" "goto" "next"
"redo" "return" "local" "exec"
"do" "dump"
"use" "our"
"require" "package" "eval" "evalbytes" "my" "state"
- "BEGIN" "END" "CHECK" "INIT" "UNITCHECK"))) ; Flow control
+ "class" "field" "method"
+ "ADJUST" "BEGIN" "CHECK"
+ "END" "INIT" "UNITCHECK"
+ ;; not in core, but per popular request
+ "async" "await"))) ; Flow control
"\\)\\>") 2) ; was "\\)[ \n\t;():,|&]"
; In what follows we use `type' style
; for overwritable builtins
+ ;; -------- avoid method calls being fontified as keywords
+ ;; (matcher (subexp facespec))
+ (list
+ (rx "->" (* space) (group-n 1(eval cperl--basic-identifier-rx)))
+ 1 ''cperl-method-call)
+ ;; -------- builtin functions
+ ;; (matcher subexp facespec)
(list
(concat
"\\(^\\|[^$@%&\\]\\)\\<\\("
@@ -5732,6 +6005,10 @@ default function."
2 'font-lock-type-face)
;; In what follows we use `other' style
;; for nonoverwritable builtins
+ ;; This is a bit shaky because the status
+ ;; "nonoverwritable" can change between Perl versions.
+ ;; -------- "non overridable" functions
+ ;; (matcher subexp facespec)
(list
(concat
"\\(^\\|[^$@%&\\]\\)\\<\\("
@@ -5752,69 +6029,32 @@ default function."
;; '("#endif" "#else" "#ifdef" "#ifndef" "#if"
;; "#include" "#define" "#undef")
;; "\\|")
+ ;; -------- -X file tests
+ ;; (matcher subexp facespec)
'("-[rwxoRWXOezsfdlpSbctugkTBMAC]\\>\\([ \t]+_\\>\\)?" 0
font-lock-function-name-face keep) ; Not very good, triggers at "[a-z]"
- ;; This highlights declarations and definitions differently.
- ;; We do not try to highlight in the case of attributes:
- ;; it is already done by `cperl-find-pods-heres'
- (list (concat "\\<" cperl-sub-regexp
- cperl-white-and-comment-rex ; whitespace/comments
- "\\([^ \n\t{;()]+\\)" ; 2=name (assume non-anonymous)
- "\\("
- cperl-maybe-white-and-comment-rex ;whitespace/comments?
- "([^()]*)\\)?" ; prototype
- cperl-maybe-white-and-comment-rex ; whitespace/comments?
- "[{;]")
- 2 (if cperl-font-lock-multiline
- '(if (eq (char-after (cperl-1- (match-end 0))) ?\{ )
- 'font-lock-function-name-face
- 'font-lock-variable-name-face)
- ;; need to manually set 'multiline' for older font-locks
- '(progn
- (if (< 1 (count-lines (match-beginning 0)
- (match-end 0)))
- (put-text-property
- (+ 3 (match-beginning 0)) (match-end 0)
- 'syntax-type 'multiline))
- (if (eq (char-after (cperl-1- (match-end 0))) ?\{ )
- 'font-lock-function-name-face
- 'font-lock-variable-name-face))))
- `(,(rx (sequence symbol-start
- (or "package" "require" "use" "import"
- "no" "bootstrap")
- (eval cperl--ws+-rx)
- (group-n 1 (eval cperl--normal-identifier-rx))
- (any " \t;"))) ; require A if B;
- 1 font-lock-function-name-face)
+ ;; -------- various stuff calling for a package name
+ ;; (matcher (subexp facespec) (subexp facespec))
+ `(,(rx (sequence
+ (or (sequence symbol-start
+ (or "package" "require" "use" "import"
+ "no" "bootstrap" "class")
+ (eval cperl--ws+-rx))
+ (sequence (group-n 2 (sequence ":"
+ (eval cperl--ws*-rx)
+ "isa"))
+ "("
+ (eval cperl--ws*-rx)))
+ (group-n 1 (eval cperl--normal-identifier-rx))
+ (any " \t\n;)"))) ; require A if B;
+ (1 font-lock-function-name-face)
+ (2 font-lock-constant-face t t))
+ ;; -------- formats
+ ;; (matcher subexp facespec)
'("^[ \t]*format[ \t]+\\([a-zA-Z_][a-zA-Z_0-9:]*\\)[ \t]*=[ \t]*$"
1 font-lock-function-name-face)
- ;; bareword hash key: $foo{bar}
- `(,(rx (or (in "]}\\%@>*&") ; What Perl is this?
- (sequence "$" (eval cperl--normal-identifier-rx)))
- (0+ blank) "{" (0+ blank)
- (group-n 1 (sequence (opt "-")
- (eval cperl--basic-identifier-rx)))
- (0+ blank) "}")
-;; '("\\([]}\\%@>*&]\\|\\$[a-zA-Z0-9_:]*\\)[ \t]*{[ \t]*\\(-?[a-zA-Z0-9_:]+\\)[ \t]*}"
- (1 font-lock-string-face t)
- ;; anchored bareword hash key: $foo{bar}{baz}
- (,(rx point
- (0+ blank) "{" (0+ blank)
- (group-n 1 (sequence (opt "-")
- (eval cperl--basic-identifier-rx)))
- (0+ blank) "}")
- ;; ("\\=[ \t]*{[ \t]*\\(-?[a-zA-Z0-9_:]+\\)[ \t]*}"
- nil nil
- (1 font-lock-string-face t)))
- ;; hash element assignments with bareword key => value
- `(,(rx (in "[ \t{,()")
- (group-n 1 (sequence (opt "-")
- (eval cperl--basic-identifier-rx)))
- (0+ blank) "=>")
- 1 font-lock-string-face t)
-;; '("[[ \t{,(]\\(-?[a-zA-Z0-9_:]+\\)[ \t]*=>" 1
-;; font-lock-string-face t)
- ;; labels
+ ;; -------- labels
+ ;; (matcher subexp facespec)
`(,(rx
(sequence
(0+ space)
@@ -5825,7 +6065,8 @@ default function."
(or "until" "while" "for" "foreach" "do")
word-end))))
1 font-lock-constant-face)
- ;; labels as targets (no trailing colon!)
+ ;; -------- labels as targets (no trailing colon!)
+ ;; (matcher subexp facespec)
`(,(rx
(sequence
symbol-start
@@ -5834,13 +6075,15 @@ default function."
(group (eval cperl--basic-identifier-rx))))
1 font-lock-constant-face)
;; Uncomment to get perl-mode-like vars
- ;;; '("[$*]{?\\(\\sw+\\)" 1 font-lock-variable-name-face)
- ;;; '("\\([@%]\\|\\$#\\)\\(\\sw+\\)"
- ;;; (2 (cons font-lock-variable-name-face '(underline))))
- ;; 1=my_etc, 2=white? 3=(+white? 4=white? 5=var
- `(,(rx (sequence (or "state" "my" "local" "our"))
+ ;; '("[$*]{?\\(\\sw+\\)" 1 font-lock-variable-name-face)
+ ;; '("\\([@%]\\|\\$#\\)\\(\\sw+\\)"
+ ;; (2 (cons font-lock-variable-name-face '(underline))))
+ ;; 1=my_etc, 2=white? 3=(+white? 4=white? 5=var
+ ;; -------- variable declarations
+ ;; (matcher (subexp facespec) ...
+ `(,(rx (sequence (or "state" "my" "local" "our" "field"))
(eval cperl--ws*-rx)
- (opt (sequence "(" (eval cperl--ws*-rx)))
+ (opt (group (sequence "(" (eval cperl--ws*-rx))))
(group
(in "$@%*")
(or
@@ -5853,12 +6096,8 @@ default function."
;; "\\(("
;; cperl-maybe-white-and-comment-rex
;; "\\)?\\([$@%*]\\([a-zA-Z0-9_:]+\\|[^a-zA-Z0-9_]\\)\\)")
- ;; (5 ,(if cperl-font-lock-multiline
- (1 ,(if cperl-font-lock-multiline
- 'font-lock-variable-name-face
- '(progn (setq cperl-font-lock-multiline-start
- (match-beginning 0))
- 'font-lock-variable-name-face)))
+ (2 font-lock-variable-name-face)
+ ;; ... (anchored-matcher pre-form post-form subex-highlighters)
(,(rx (sequence point
(eval cperl--ws*-rx)
","
@@ -5879,37 +6118,21 @@ default function."
;; Bug in font-lock: limit is used not only to limit
;; searches, but to set the "extend window for
;; facification" property. Thus we need to minimize.
- ,(if cperl-font-lock-multiline
- '(if (match-beginning 1)
- (save-excursion
- (goto-char (match-beginning 1))
- (condition-case nil
- (forward-sexp 1)
- (error
- (condition-case nil
- (forward-char 200)
- (error nil)))) ; typeahead
- (1- (point))) ; report limit
- (forward-char -2)) ; disable continued expr
- '(if (match-beginning 1)
- (point-max) ; No limit for continuation
- (forward-char -2))) ; disable continued expr
- ,(if cperl-font-lock-multiline
- nil
- '(progn ; Do at end
- ;; "my" may be already fontified (POD),
- ;; so cperl-font-lock-multiline-start is nil
- (if (or (not cperl-font-lock-multiline-start)
- (> 2 (count-lines
- cperl-font-lock-multiline-start
- (point))))
- nil
- (put-text-property
- (1+ cperl-font-lock-multiline-start) (point)
- 'syntax-type 'multiline))
- (setq cperl-font-lock-multiline-start nil)))
+ (if (match-beginning 1) ; list declaration
+ (save-excursion
+ (goto-char (match-beginning 1))
+ (condition-case nil
+ (forward-sexp 1)
+ (error
+ (condition-case nil
+ (forward-char 200)
+ (error nil)))) ; typeahead
+ (1- (point))) ; report limit
+ (forward-char -2)) ; disable continued expr
+ nil
(1 font-lock-variable-name-face)))
- ;; foreach my $foo (
+ ;; ----- foreach my $foo (
+ ;; (matcher subexp facespec)
`(,(rx symbol-start "for" (opt "each")
(opt (sequence (1+ blank)
(or "state" "my" "local" "our")))
@@ -5920,34 +6143,44 @@ default function."
;; '("\\<for\\(each\\)?\\([ \t]+\\(state\\|my\\|local\\|our\\)\\)?[ \t]*\\(\\$[a-zA-Z_][a-zA-Z_0-9]*\\)[ \t]*("
1 font-lock-variable-name-face)
;; Avoid $!, and s!!, qq!! etc. when not fontifying syntactically
+ ;; -------- ! as a negation char like $false = !$true
+ ;; (matcher subexp facespec)
'("\\(?:^\\|[^smywqrx$]\\)\\(!\\)" 1 font-lock-negation-char-face)
+ ;; -------- ^ as a negation char in character classes m/[^abc]/
+ ;; (matcher subexp facespec)
'("\\[\\(\\^\\)" 1 font-lock-negation-char-face prepend)))
(setq
t-font-lock-keywords-1
`(
- ;; arrays and hashes. Access to elements is fixed below
- (,(rx (group-n 1 (group-n 2 (or (in "@%") "$#"))
- (eval cperl--normal-identifier-rx)))
- 1
-;; ("\\(\\([@%]\\|\\$#\\)[a-zA-Z_:][a-zA-Z0-9_:]*\\)" 1
- (if (eq (char-after (match-beginning 2)) ?%)
- 'cperl-hash-face
- 'cperl-array-face)
- nil) ; arrays and hashes
- ;; access to array/hash elements
- (,(rx (group-n 1 (group-n 2 (in "$@%"))
- (eval cperl--normal-identifier-rx))
- (0+ blank)
- (group-n 3 (in "[{")))
-;; ("\\(\\([$@%]+\\)[a-zA-Z_:][a-zA-Z0-9_:]*\\)[ \t]*\\([[{]\\)"
- 1
- (if (= (- (match-end 2) (match-beginning 2)) 1)
- (if (eq (char-after (match-beginning 3)) ?{)
- 'cperl-hash-face
- 'cperl-array-face) ; arrays and hashes
- font-lock-variable-name-face) ; Just to put something
- t) ; override previous
- ;; @$ array dereferences, $#$ last array index
+ ;; -------- bareword hash key: $foo{bar}, $foo[1]{bar}
+ ;; (matcher (subexp facespec) ...
+ (,(rx (or (in "]}\\%@>*&")
+ (sequence "$" (eval cperl--normal-identifier-rx)))
+ (0+ blank) "{" (0+ blank)
+ (group-n 1 (sequence (opt "-")
+ (eval cperl--basic-identifier-rx)))
+ (0+ blank) "}")
+;; '("\\([]}\\%@>*&]\\|\\$[a-zA-Z0-9_:]*\\)[ \t]*{[ \t]*\\(-?[a-zA-Z0-9_:]+\\)[ \t]*}"
+ (1 font-lock-string-face)
+ ;; -------- anchored bareword hash key: $foo{bar}{baz}
+ ;; ... (anchored-matcher pre-form post-form subex-highlighters)
+ (,(rx point
+ (0+ blank) "{" (0+ blank)
+ (group-n 1 (sequence (opt "-")
+ (eval cperl--basic-identifier-rx)))
+ (0+ blank) "}")
+ ;; ("\\=[ \t]*{[ \t]*\\(-?[a-zA-Z0-9_:]+\\)[ \t]*}"
+ nil nil
+ (1 font-lock-string-face)))
+ ;; -------- hash element assignments with bareword key => value
+ ;; (matcher subexp facespec)
+ (,(rx (in "[ \t{,()")
+ (group-n 1 (sequence (opt "-")
+ (eval cperl--basic-identifier-rx)))
+ (0+ blank) "=>")
+ 1 font-lock-string-face)
+ ;; -------- @$ array dereferences, $#$ last array index
+ ;; (matcher (subexp facespec) (subexp facespec))
(,(rx (group-n 1 (or "@" "$#"))
(group-n 2 (sequence "$"
(or (eval cperl--normal-identifier-rx)
@@ -5955,7 +6188,8 @@ default function."
;; ("\\(@\\|\\$#\\)\\(\\$+\\([a-zA-Z_:][a-zA-Z0-9_:]*\\|[^ \t\n]\\)\\)"
(1 'cperl-array-face)
(2 font-lock-variable-name-face))
- ;; %$ hash dereferences
+ ;; -------- %$ hash dereferences
+ ;; (matcher (subexp facespec) (subexp facespec))
(,(rx (group-n 1 "%")
(group-n 2 (sequence "$"
(or (eval cperl--normal-identifier-rx)
@@ -5963,8 +6197,34 @@ default function."
;; ("\\(%\\)\\(\\$+\\([a-zA-Z_:][a-zA-Z0-9_:]*\\|[^ \t\n]\\)\\)"
(1 'cperl-hash-face)
(2 font-lock-variable-name-face))
-;;("\\([smy]\\|tr\\)\\([^a-z_A-Z0-9]\\)\\(\\([^\n\\]*||\\)\\)\\2")
-;;; Too much noise from \s* @s[ and friends
+ ;; -------- access to array/hash elements
+ ;; (matcher subexp facespec)
+ ;; facespec is an expression to distinguish between arrays and hashes
+ (,(rx (group-n 1 (group-n 2 (in "$@%"))
+ (eval cperl--normal-identifier-rx))
+ (0+ blank)
+ (group-n 3 (in "[{")))
+;; ("\\(\\([$@%]+\\)[a-zA-Z_:][a-zA-Z0-9_:]*\\)[ \t]*\\([[{]\\)"
+ 1
+ (if (= (- (match-end 2) (match-beginning 2)) 1)
+ (if (eq (char-after (match-beginning 3)) ?{)
+ 'cperl-hash-face
+ 'cperl-array-face) ; arrays and hashes
+ font-lock-variable-name-face) ; Just to put something
+ nil) ; do not override previous
+ ;; -------- "Pure" arrays and hashes.
+ ;; (matcher subexp facespec)
+ ;; facespec is an expression to distinguish between arrays and hashes
+ (,(rx (group-n 1 (group-n 2 (or (in "@%") "$#"))
+ (eval cperl--normal-identifier-rx)))
+ 1
+ ;; ("\\(\\([@%]\\|\\$#\\)[a-zA-Z_:][a-zA-Z0-9_:]*\\)" 1
+ (if (eq (char-after (match-beginning 2)) ?%)
+ 'cperl-hash-face
+ 'cperl-array-face)
+ nil)
+ ;;("\\([smy]\\|tr\\)\\([^a-z_A-Z0-9]\\)\\(\\([^\n\\]*||\\)\\)\\2")
+ ;; Too much noise from \s* @s[ and friends
;;("\\(\\<\\([msy]\\|tr\\)[ \t]*\\([^ \t\na-zA-Z0-9_]\\)\\|\\(/\\)\\)"
;;(3 font-lock-function-name-face t t)
;;(4
@@ -6259,6 +6519,10 @@ See examples in `cperl-style-examples'.")
(defun cperl-set-style (style)
"Set CPerl mode variables to use one of several different indentation styles.
+This command sets the default values for the variables. It does
+not affect buffers visiting files where the style has been set as
+a file or directory variable. To change the indentation style of
+a buffer, use the command `cperl-file-style' instead.
The arguments are a string representing the desired style.
The list of styles is in `cperl-style-alist', available styles
are \"CPerl\", \"PBP\", \"PerlStyle\", \"GNU\", \"K&R\", \"BSD\", \"C++\"
@@ -6279,7 +6543,8 @@ side-effect of memorizing only. Examples in `cperl-style-examples'."
(let ((style (cdr (assoc style cperl-style-alist))) setting)
(while style
(setq setting (car style) style (cdr style))
- (set (car setting) (cdr setting)))))
+ (set-default-toplevel-value (car setting) (cdr setting))))
+ (set-default-toplevel-value 'cperl-file-style style))
(defun cperl-set-style-back ()
"Restore a style memorized by `cperl-set-style'."
@@ -6289,14 +6554,20 @@ side-effect of memorizing only. Examples in `cperl-style-examples'."
(while cperl-old-style
(setq setting (car cperl-old-style)
cperl-old-style (cdr cperl-old-style))
- (set (car setting) (cdr setting)))))
+ (set-default-toplevel-value (car setting) (cdr setting)))))
-(defvar perl-dbg-flags)
-(defun cperl-check-syntax ()
- (interactive)
- (require 'mode-compile)
- (let ((perl-dbg-flags (concat cperl-extra-perl-args " -wc")))
- (eval '(mode-compile)))) ; Avoid a warning
+(defun cperl-file-style (style)
+ "Set the indentation style for the current buffer to STYLE.
+The list of styles is in `cperl-style-alist', available styles
+are \"CPerl\", \"PBP\", \"PerlStyle\", \"GNU\", \"K&R\", \"BSD\", \"C++\"
+and \"Whitesmith\"."
+ (interactive
+ (list (completing-read "Enter style: " cperl-style-alist nil 'insist)))
+ (dolist (setting (cdr (assoc style cperl-style-alist)) style)
+ (let ((option (car setting))
+ (value (cdr setting)))
+ (set (make-local-variable option) value)))
+ (setq-local cperl-file-style style))
(declare-function Info-find-node "info"
(filename nodename &optional no-going-back strict-case
@@ -6341,10 +6612,7 @@ side-effect of memorizing only. Examples in `cperl-style-examples'."
'find-tag-default))))))
(defun cperl-info-on-command (command)
- "Show documentation for Perl command COMMAND in other window.
-If perl-info buffer is shown in some frame, uses this frame.
-Customized by setting variables `cperl-shrink-wrap-info-frame',
-`cperl-max-help-size'."
+ (declare (obsolete cperl-perldoc "30.1"))
(interactive
(let* ((default (cperl-word-at-point))
(read (read-string
@@ -6354,14 +6622,13 @@ Customized by setting variables `cperl-shrink-wrap-info-frame',
read))))
(let ((cmd-desc (concat "^" (regexp-quote command) "[^a-zA-Z_0-9]")) ; "tr///"
- pos isvar height iniheight frheight buf win fr1 fr2 iniwin not-loner
+ pos isvar height iniheight frheight buf win iniwin not-loner
max-height char-height buf-list)
(if (string-match "^-[a-zA-Z]$" command)
(setq cmd-desc "^-X[ \t\n]"))
(setq isvar (string-match "^[$@%]" command)
buf (cperl-info-buffer isvar)
- iniwin (selected-window)
- fr1 (window-frame iniwin))
+ iniwin (selected-window))
(set-buffer buf)
(goto-char (point-min))
(or isvar
@@ -6382,11 +6649,7 @@ Customized by setting variables `cperl-shrink-wrap-info-frame',
(or (not win)
(eq (window-buffer win) buf)
(set-window-buffer win buf))
- (and win (setq fr2 (window-frame win)))
- (if (or (not fr2) (eq fr1 fr2))
- (pop-to-buffer buf)
- (special-display-popup-frame buf) ; Make it visible
- (select-window win))
+ (pop-to-buffer buf)
(goto-char pos) ; Needed (?!).
;; Resize
(setq iniheight (window-height)
@@ -6420,52 +6683,30 @@ Customized by setting variables `cperl-shrink-wrap-info-frame',
(select-window iniwin)))
(defun cperl-info-on-current-command ()
- "Show documentation for Perl command at point in other window."
+ (declare (obsolete cperl-perldoc "30.1"))
(interactive)
- (cperl-info-on-command (cperl-word-at-point)))
+ (cperl-perldoc (cperl-word-at-point)))
(defun cperl-imenu-info-imenu-search ()
+ (declare (obsolete nil "30.1"))
(if (looking-at "^-X[ \t\n]") nil
(re-search-backward
"^\n\\([-a-zA-Z_]+\\)[ \t\n]")
(forward-line 1)))
(defun cperl-imenu-info-imenu-name ()
+ (declare (obsolete nil "30.1"))
(buffer-substring
(match-beginning 1) (match-end 1)))
(declare-function imenu-choose-buffer-index "imenu" (&optional prompt alist))
(defun cperl-imenu-on-info ()
- "Show imenu for Perl Info Buffer.
-Opens Perl Info buffer if needed."
+ (declare (obsolete nil "30.1"))
(interactive)
- (require 'imenu)
- (let* ((buffer (current-buffer))
- imenu-create-index-function
- imenu-prev-index-position-function
- imenu-extract-index-name-function
- (index-item (save-restriction
- (save-window-excursion
- (set-buffer (cperl-info-buffer nil))
- (setq imenu-create-index-function
- 'imenu-default-create-index-function
- imenu-prev-index-position-function
- #'cperl-imenu-info-imenu-search
- imenu-extract-index-name-function
- #'cperl-imenu-info-imenu-name)
- (imenu-choose-buffer-index)))))
- (and index-item
- (progn
- (push-mark)
- (pop-to-buffer "*info-perl*")
- (cond
- ((markerp (cdr index-item))
- (goto-char (marker-position (cdr index-item))))
- (t
- (goto-char (cdr index-item))))
- (set-window-start (selected-window) (point))
- (pop-to-buffer buffer)))))
+ (message
+ (concat "The info file `perl' is no longer available.\n"
+ "Consider installing the perl-doc package from GNU ELPA.")))
(defun cperl-lineup (beg end &optional step minshift)
"Lineup construction in a region.
@@ -6533,7 +6774,7 @@ in subdirectories too."
;; of etags has been commented out in the menu since ... well,
;; forever. So, let's just stick to ASCII here. -- haj, 2021-09-14
(interactive)
- (let ((cmd "etags")
+ (let ((cmd etags-program-name)
(args `("-l" "none" "-r"
;; 1=fullname 2=package? 3=name 4=proto? 5=attrs? (VERY APPROX!)
,(concat
@@ -6760,7 +7001,9 @@ Does not move point."
127
(if (string-match "^package " (car elt))
(substring (car elt) 8)
- (car elt) )
+ (if (string-match "^class " (car elt))
+ (substring (car elt) 6)
+ (car elt)))
1
(number-to-string (elt elt 2)) ; Line
","
@@ -7486,10 +7729,27 @@ $~ The name of the current report format.
... >> ... Bitwise shift right.
... >>= ... Bitwise shift right assignment.
... ? ... : ... Condition=if-then-else operator.
+... | ... Bitwise or.
+... || ... Logical or.
+... // ... Defined-or.
+~ ... Unary bitwise complement.
+... and ... Low-precedence synonym for &&.
+... cmp ... String compare.
+... eq ... String equality.
+... ge ... String greater than or equal.
+... gt ... String greater than.
+... le ... String less than or equal.
+... lt ... String less than.
+... ne ... String inequality.
+not ... Low-precedence synonym for ! - negation.
+... or ... Low-precedence synonym for ||.
+... x ... Repeat string or array.
+x= ... Repetition assignment.
+... xor ... Low-precedence synonym for exclusive or.
@ARGV Command line arguments (not including the command name - see $0).
@INC List of places to look for perl scripts during do/include/use.
@_ Parameter array for subroutines; result of split() unless in list context.
-\\ Creates reference to what follows, like \\$var, or quotes non-\\w in strings.
+\\ Creates reference to what follows, like \\$var. Quotes non-\\w in strings.
\\0 Octal char, e.g. \\033.
\\E Case modification terminator. See \\Q, \\L, and \\U.
\\L Lowercase until \\E . See also \\l, lc.
@@ -7507,12 +7767,9 @@ $~ The name of the current report format.
\\u Upcase the next character. See also \\U and \\l, ucfirst.
\\x Hex character, e.g. \\x1b.
... ^ ... Bitwise exclusive or.
-__END__ Ends program source.
__DATA__ Ends program source.
-__FILE__ Current (source) filename.
-__LINE__ Current line in current source.
-__PACKAGE__ Current package.
-__SUB__ Current sub.
+__END__ Ends program source.
+ADJUST {...} Callback for object creation
ARGV Default multi-file input filehandle. <ARGV> is a synonym for <>.
ARGVOUT Output filehandle with -i flag.
BEGIN { ... } Immediately executed (during compilation) piece of code.
@@ -7521,261 +7778,252 @@ CHECK { ... } Pseudo-subroutine executed after the script is compiled.
UNITCHECK { ... }
INIT { ... } Pseudo-subroutine executed before the script starts running.
DATA Input filehandle for what follows after __END__ or __DATA__.
-accept(NEWSOCKET,GENERICSOCKET)
-alarm(SECONDS)
-atan2(X,Y)
-bind(SOCKET,NAME)
-binmode(FILEHANDLE)
+abs [ EXPR ] absolute value function
+accept(NEWSOCKET,GENERICSOCKET) accept an incoming socket connect
+alarm(SECONDS) schedule a SIGALRM
+async(SUB NAME {}|SUB {}) Mark function as potentially asynchronous
+atan2(X,Y) arctangent of Y/X in the range -PI to PI
+await(ASYNCEXPR) Yield result of Future
+bind(SOCKET,NAME) binds an address to a socket
+binmode(FILEHANDLE) prepare binary files for I/O
+bless REFERENCE [, PACKAGE] Makes reference into an object of a package.
break Break out of a given/when statement
-caller[(LEVEL)]
-chdir(EXPR)
-chmod(LIST)
-chop[(LIST|VAR)]
-chown(LIST)
-chroot(FILENAME)
-close(FILEHANDLE)
-closedir(DIRHANDLE)
-... cmp ... String compare.
-connect(SOCKET,NAME)
+caller[(LEVEL)] get context of the current subroutine call
+chdir(EXPR) change your current working directory
+chmod(LIST) changes the permissions on a list of files
+chomp [LIST] Strips $/ off LIST/$_. Returns count.
+chop[(LIST|VAR)] remove the last character from a string
+chown(LIST) change the ownership on a list of files
+chr [NUMBER] Converts a number to char with the same ordinal.
+chroot(FILENAME) make directory new root for path lookups
+class NAME Introduce an object class.
+close(FILEHANDLE) close file (or pipe or socket) handle
+closedir(DIRHANDLE) close directory handle
+connect(SOCKET,NAME) connect to a remote socket
continue of { block } continue { block }. Is executed after `next' or at end.
-cos(EXPR)
-crypt(PLAINTEXT,SALT)
-dbmclose(%HASH)
-dbmopen(%HASH,DBNAME,MODE)
-default { ... } default case for given/when block
-defined(EXPR)
-delete($HASH{KEY})
-die(LIST)
+cos(EXPR) cosine function
+crypt(PLAINTEXT,SALT) one-way passwd-style encryption
+dbmclose(%HASH) breaks binding on a tied dbm file
+dbmopen(%HASH,DBNAME,MODE) create binding on a tied dbm file
+defined(EXPR) test whether a value, variable, or function is defined
+delete($HASH{KEY}) deletes a value from a hash
+die(LIST) raise an exception or bail out
do { ... }|SUBR while|until EXPR executes at least once
do(EXPR|SUBR([LIST])) (with while|until executes at least once)
-dump LABEL
-each(%HASH)
-endgrent
-endhostent
-endnetent
-endprotoent
-endpwent
-endservent
-eof[([FILEHANDLE])]
-... eq ... String equality.
-eval(EXPR) or eval { BLOCK }
+dump LABEL create an immediate core dump
+each(%HASH) retrieve the next key/value pair from a hash
+endgrent be done using group file
+endhostent be done using hosts file
+endnetent be done using networks file
+endprotoent be done using protocols file
+endpwent be done using passwd file
+endservent be done using services file
+eof[([FILEHANDLE])] test a filehandle for its end
+eval(EXPR) or eval { BLOCK } catch exceptions or compile and run code
evalbytes See eval.
exec([TRUENAME] ARGV0, ARGVs) or exec(SHELL_COMMAND_LINE)
-exit(EXPR)
-exp(EXPR)
+exists $HASH{KEY} True if the key exists.
+exit(EXPR) terminate this program
+exp(EXPR) raise e to a power
+fc EXPR Returns the casefolded version of EXPR.
fcntl(FILEHANDLE,FUNCTION,SCALAR)
-fileno(FILEHANDLE)
-flock(FILEHANDLE,OPERATION)
-for (EXPR;EXPR;EXPR) { ... }
-foreach [VAR] (@ARRAY) { ... }
-fork
-... ge ... String greater than or equal.
-getc[(FILEHANDLE)]
-getgrent
-getgrgid(GID)
-getgrnam(NAME)
-gethostbyaddr(ADDR,ADDRTYPE)
-gethostbyname(NAME)
-gethostent
-getlogin
-getnetbyaddr(ADDR,ADDRTYPE)
-getnetbyname(NAME)
-getnetent
-getpeername(SOCKET)
-getpgrp(PID)
-getppid
-getpriority(WHICH,WHO)
-getprotobyname(NAME)
-getprotobynumber(NUMBER)
-getprotoent
-getpwent
-getpwnam(NAME)
-getpwuid(UID)
-getservbyname(NAME,PROTO)
-getservbyport(PORT,PROTO)
-getservent
-getsockname(SOCKET)
-getsockopt(SOCKET,LEVEL,OPTNAME)
-given (EXPR) { [ when (EXPR) { ... } ]+ [ default { ... } ]? }
-gmtime(EXPR)
-goto LABEL
-... gt ... String greater than.
-hex(EXPR)
-if (EXPR) { ... } [ elsif (EXPR) { ... } ... ] [ else { ... } ] or EXPR if EXPR
-index(STR,SUBSTR[,OFFSET])
-int(EXPR)
-ioctl(FILEHANDLE,FUNCTION,SCALAR)
-join(EXPR,LIST)
-keys(%HASH)
-kill(LIST)
-last [LABEL]
-... le ... String less than or equal.
-length(EXPR)
-link(OLDFILE,NEWFILE)
-listen(SOCKET,QUEUESIZE)
-local(LIST)
-localtime(EXPR)
-log(EXPR)
-lstat(EXPR|FILEHANDLE|VAR)
-... lt ... String less than.
-m/PATTERN/iogsmx
-mkdir(FILENAME,MODE)
-msgctl(ID,CMD,ARG)
-msgget(KEY,FLAGS)
-msgrcv(ID,VAR,SIZE,TYPE.FLAGS)
-msgsnd(ID,MSG,FLAGS)
+field VAR [:param[(NAME)]] [=EXPR] declare an object attribute
+__FILE__ Current (source) filename.
+fileno(FILEHANDLE) return file descriptor from filehandle
+flock(FILEHANDLE,OPERATION) lock an entire file with an advisory lock
+fork create a new process just like this one
+format [NAME] = Start of output format. Ended by a single dot (.) on a line.
+formline PICTURE, LIST Backdoor into \"format\" processing.
+getc[(FILEHANDLE)] get the next character from the filehandle
+getgrent get group record given group user ID
+getgrgid(GID) get group record given group user ID
+getgrnam(NAME) get group record given group name
+gethostbyaddr(ADDR,ADDRTYPE) get host record given name
+gethostbyname(NAME) get host record given name
+gethostent get next hosts record
+getlogin return who logged in at this tty
+getnetbyaddr(ADDR,ADDRTYPE) get network record given its address
+getnetbyname(NAME) get networks record given name
+getnetent get next networks record
+getpeername(SOCKET) find the other end of a socket connection
+getpgrp(PID) get process group
+getppid get parent process ID
+getpriority(WHICH,WHO) get current nice value
+getprotobyname(NAME) get protocol record given name
+getprotobynumber(NUMBER) get protocol record numeric protocol
+getprotoent get next protocols record
+getpwent get next passwd record
+getpwnam(NAME) get passwd record given user login name
+getpwuid(UID) get passwd record given user ID
+getservbyname(NAME,PROTO) get services record given its name
+getservbyport(PORT,PROTO) get services record given numeric port
+getservent get next services record
+getsockname(SOCKET) retrieve the sockaddr for a given socket
+getsockopt(SOCKET,LEVEL,OPTNAME) get socket options on a given socket
+glob EXPR expand filenames using wildcards. Synonym of <EXPR>.
+gmtime(EXPR) convert UNIX time into record or string using Greenwich time
+goto LABEL create spaghetti code
+grep EXPR,LIST or grep {BLOCK} LIST Filters LIST via EXPR/BLOCK.
+hex(EXPR) convert a hexadecimal string to a number
+import patch a module's namespace into your own
+index(STR,SUBSTR[,OFFSET]) find a substring within a string
+int(EXPR) get the integer portion of a number
+ioctl(FILEHANDLE,FUNCTION,SCALAR) device control system call
+join(EXPR,LIST) join a list into a string using a separator
+keys(%HASH) retrieve list of indices from a hash
+kill(LIST) send a signal to a process or process group
+last [LABEL] exit a block prematurely
+lc [ EXPR ] Returns lowercased EXPR.
+lcfirst [ EXPR ] Returns EXPR with lower-cased first letter.
+length(EXPR) return the number of characters in a string
+__LINE__ Current line in current source.
+link(OLDFILE,NEWFILE) create a hard link in the filesystem
+listen(SOCKET,QUEUESIZE) register your socket as a server
+local(LIST) create a temporary value for a global variable
+localtime(EXPR) convert UNIX time into record or string using local time
+lock(THING) get a thread lock on a variable, subroutine, or method
+log(EXPR) retrieve the natural logarithm for a number
+lstat(EXPR|FILEHANDLE|VAR) stat a symbolic link
+m/PATTERN/iogsmx match a string with a regular expression pattern
+map EXPR, LIST or map {BLOCK} LIST Applies EXPR/BLOCK to elts of LIST.
+method [NAME [(signature)]] { BODY } method NAME;
+mkdir(FILENAME,MODE) create a directory
+msgctl(ID,CMD,ARG) SysV IPC message control operations
+msgget(KEY,FLAGS) get SysV IPC message queue
+msgrcv(ID,VAR,SIZE,TYPE.FLAGS) receive a SysV IPC message from a message queue
+msgsnd(ID,MSG,FLAGS) send a SysV IPC message to a message queue
my VAR or my (VAR1,...) Introduces a lexical variable ($VAR, @ARR, or %HASH).
-our VAR or our (VAR1,...) Lexically enable a global variable ($V, @A, or %H).
-... ne ... String inequality.
-next [LABEL]
-oct(EXPR)
-open(FILEHANDLE[,EXPR])
-opendir(DIRHANDLE,EXPR)
+next [LABEL] iterate a block prematurely
+no MODULE [SYMBOL1, ...] Partial reverse for `use'. Runs `unimport' method.
+oct(EXPR) convert a string to an octal number
+open(FILEHANDLE[,EXPR]) open a file, pipe, or descriptor
+opendir(DIRHANDLE,EXPR) open a directory
ord(EXPR) ASCII value of the first char of the string.
-pack(TEMPLATE,LIST)
+our VAR or our (VAR1,...) Lexically enable a global variable ($V, @A, or %H).
+pack(TEMPLATE,LIST) convert a list into a binary representation
package NAME Introduces package context.
+__PACKAGE__ Current package.
pipe(READHANDLE,WRITEHANDLE) Create a pair of filehandles on ends of a pipe.
-pop(ARRAY)
-print [FILEHANDLE] [(LIST)]
-printf [FILEHANDLE] (FORMAT,LIST)
-push(ARRAY,LIST)
+pop(ARRAY) remove the last element from an array and return it
+pos STRING Set/Get end-position of the last match over this string, see \\G.
+print [FILEHANDLE] [(LIST)] output a list to a filehandle
+printf [FILEHANDLE] (FORMAT,LIST) output a formatted list to a filehandle
+prototype \\&SUB Returns prototype of the function given a reference.
+push(ARRAY,LIST) append one or more elements to an array
q/STRING/ Synonym for \\='STRING\\='
qq/STRING/ Synonym for \"STRING\"
+qr/PATTERN/ compile pattern
+quotemeta quote regular expression magic characters
+qw/STRING/ quote a list of words
qx/STRING/ Synonym for \\=`STRING\\=`
-rand[(EXPR)]
-read(FILEHANDLE,SCALAR,LENGTH[,OFFSET])
-readdir(DIRHANDLE)
-readlink(EXPR)
-recv(SOCKET,SCALAR,LEN,FLAGS)
-redo [LABEL]
-rename(OLDNAME,NEWNAME)
-require [FILENAME | PERL_VERSION]
-reset[(EXPR)]
-return(LIST)
-reverse(LIST)
-rewinddir(DIRHANDLE)
-rindex(STR,SUBSTR[,OFFSET])
-rmdir(FILENAME)
-s/PATTERN/REPLACEMENT/gieoxsm
-say [FILEHANDLE] [(LIST)]
-scalar(EXPR)
-seek(FILEHANDLE,POSITION,WHENCE)
-seekdir(DIRHANDLE,POS)
-select(FILEHANDLE | RBITS,WBITS,EBITS,TIMEOUT)
-semctl(ID,SEMNUM,CMD,ARG)
-semget(KEY,NSEMS,SIZE,FLAGS)
-semop(KEY,...)
-send(SOCKET,MSG,FLAGS[,TO])
-setgrent
-sethostent(STAYOPEN)
-setnetent(STAYOPEN)
-setpgrp(PID,PGRP)
-setpriority(WHICH,WHO,PRIORITY)
-setprotoent(STAYOPEN)
-setpwent
-setservent(STAYOPEN)
-setsockopt(SOCKET,LEVEL,OPTNAME,OPTVAL)
-shift[(ARRAY)]
-shmctl(ID,CMD,ARG)
-shmget(KEY,SIZE,FLAGS)
-shmread(ID,VAR,POS,SIZE)
-shmwrite(ID,STRING,POS,SIZE)
-shutdown(SOCKET,HOW)
-sin(EXPR)
-sleep[(EXPR)]
-socket(SOCKET,DOMAIN,TYPE,PROTOCOL)
-socketpair(SOCKET1,SOCKET2,DOMAIN,TYPE,PROTOCOL)
-sort [SUBROUTINE] (LIST)
-splice(ARRAY,OFFSET[,LENGTH[,LIST]])
-split[(/PATTERN/[,EXPR[,LIMIT]])]
-sprintf(FORMAT,LIST)
-sqrt(EXPR)
-srand(EXPR)
-stat(EXPR|FILEHANDLE|VAR)
+rand[(EXPR)] retrieve the next pseudorandom number
+read(FILEHANDLE,SCALAR,LENGTH[,OFFSET]) fixed-length buffered input
+readdir(DIRHANDLE) get a directory from a directory handle
+readline FH Synonym of <FH>.
+readlink(EXPR) determine where a symbolic link is pointing
+readpipe CMD Synonym of \\=`CMD\\=`.
+recv(SOCKET,SCALAR,LEN,FLAGS) receive a message over a Socket
+redo [LABEL] start this loop iteration over again
+ref [ EXPR ] Type of EXPR when dereferenced.
+rename(OLDNAME,NEWNAME) change a filename
+require [FILENAME | PERL_VERSION] load from a library at runtime
+reset[(EXPR)] clear all variables of a given name
+return(LIST) get out of a function early
+reverse(LIST) flip a string or a list
+rewinddir(DIRHANDLE) reset directory handle
+rindex(STR,SUBSTR[,OFFSET]) right-to-left substring search
+rmdir(FILENAME) remove a directory
+s/PATTERN/REPLACEMENT/gieoxsm replace a pattern with a string
+say [FILEHANDLE] [(LIST)] output a list, appending a newline
+scalar(EXPR) force a scalar context
+seek(FILEHANDLE,POSITION,WHENCE) reposition file pointer
+seekdir(DIRHANDLE,POS) reposition directory pointer
+select(FILEHANDLE) reset default output or do I/O multiplexing
+select(RBITS,WBITS,EBITS,TIMEOUT) do I/O multiplexing
+semctl(ID,SEMNUM,CMD,ARG) SysV semaphore control operations
+semget(KEY,NSEMS,SIZE,FLAGS) get set of SysV semaphores
+semop(KEY,...) SysV semaphore operations
+send(SOCKET,MSG,FLAGS[,TO]) send a message over a socket
+setgrent prepare group file for use
+sethostent(STAYOPEN) prepare hosts file for use
+setnetent(STAYOPEN) prepare networks file for use
+setpgrp(PID,PGRP) set the process group of a process
+setpriority(WHICH,WHO,PRIORITY) Process set a process\\='s nice value
+setprotoent(STAYOPEN) etwork prepare protocols file for use
+setpwent prepare passwd file for use
+setservent(STAYOPEN) prepare services file for use
+setsockopt(SOCKET,LEVEL,OPTNAME,OPTVAL) set some socket options
+shift[(ARRAY)] remove the first element of an array, and return it
+shmctl(ID,CMD,ARG) SysV shared memory operations
+shmget(KEY,SIZE,FLAGS) get SysV shared memory segment identifier
+shmread(ID,VAR,POS,SIZE) read SysV shared memory
+shmwrite(ID,STRING,POS,SIZE) write SysV shared memory
+shutdown(SOCKET,HOW) close down just half of a socket connection
+sin(EXPR) return the sine of a number
+sleep[(EXPR)] block for some number of seconds
+socket(SOCKET,DOMAIN,TYPE,PROTOCOL) create a socket
+socketpair(SOCKET1,SOCKET2,DOMAIN,TYPE,PROTOCOL) create a pair of sockets
+sort [SUBROUTINE] (LIST) sort a list of values
+splice(ARRAY,OFFSET[,LENGTH[,LIST]]) add or remove elements anywhere
+split[(/PATTERN/[,EXPR[,LIMIT]])] split up a string using a regexp
+sprintf(FORMAT,LIST) formatted print into a string
+sqrt(EXPR) square root function
+srand(EXPR) seed the random number generator
+stat(EXPR|FILEHANDLE|VAR) get a file\\='s status information
state VAR or state (VAR1,...) Introduces a static lexical variable
-study[(SCALAR)]
+study[(SCALAR)] no-op, formerly optimized input data for repeated searches
sub [NAME [(format)]] { BODY } sub NAME [(format)]; sub [(format)] {...}
-substr(EXPR,OFFSET[,LEN])
-symlink(OLDFILE,NEWFILE)
-syscall(LIST)
-sysread(FILEHANDLE,SCALAR,LENGTH[,OFFSET])
+__SUB__ the current subroutine, or C<undef> if not in a subroutine
+substr(EXPR,OFFSET[,LEN]) get or alter a portion of a string
+symlink(OLDFILE,NEWFILE) create a symbolic link to a file
+syscall(LIST) execute an arbitrary system call
+sysopen FH, FILENAME, MODE [, PERM] (MODE is numeric, see Fcntl.)
+sysread(FILEHANDLE,SCALAR,LENGTH[,OFFSET]) fixed-length unbuffered input
+sysseek(FILEHANDLE,POSITION,WHENCE) position I/O pointer on handle
system([TRUENAME] ARGV0 [,ARGV]) or system(SHELL_COMMAND_LINE)
-syswrite(FILEHANDLE,SCALAR,LENGTH[,OFFSET])
-tell[(FILEHANDLE)]
-telldir(DIRHANDLE)
-time
-times
-tr/SEARCHLIST/REPLACEMENTLIST/cds
-truncate(FILE|EXPR,LENGTH)
-umask[(EXPR)]
-undef[(EXPR)]
-unless (EXPR) { ... } [ else { ... } ] or EXPR unless EXPR
-unlink(LIST)
-unpack(TEMPLATE,EXPR)
-unshift(ARRAY,LIST)
-until (EXPR) { ... } EXPR until EXPR
-utime(LIST)
-values(%HASH)
-vec(EXPR,OFFSET,BITS)
-wait
-waitpid(PID,FLAGS)
+syswrite(FILEHANDLE,SCALAR,LENGTH[,OFFSET]) fixed-length unbuffered output
+tell[(FILEHANDLE)] get current seekpointer on a filehandle
+telldir(DIRHANDLE) get current seekpointer on a directory handle
+tie VAR, CLASS, LIST Hide an object behind a simple Perl variable.
+tied Returns internal object for a tied data.
+time return number of seconds since 1970
+times return elapsed time for self and child processes
+tr/SEARCHLIST/REPLACEMENTLIST/cds transliterate a string
+truncate(FILE|EXPR,LENGTH) shorten a file
+uc [ EXPR ] Returns upcased EXPR.
+ucfirst [ EXPR ] Returns EXPR with upcased first letter.
+umask[(EXPR)] set file creation mode mask
+undef[(EXPR)] remove a variable or function definition
+unlink(LIST) remove one link to a file
+unpack(TEMPLATE,EXPR) convert binary structure into normal perl variables
+unshift(ARRAY,LIST) prepend more elements to the beginning of a list
+untie VAR Unlink an object from a simple Perl variable.
+use MODULE [SYMBOL1, ...] Compile-time `require' with consequent `import'.
+utime(LIST) set a file\\='s last access and modify times
+values(%HASH) return a list of the values in a hash
+vec(EXPR,OFFSET,BITS) test or set particular bits in a string
+wait wait for any child process to die
+waitpid(PID,FLAGS) wait for a particular child process to die
wantarray Returns true if the sub/eval is called in list context.
-warn(LIST)
-while (EXPR) { ... } EXPR while EXPR
-write[(EXPR|FILEHANDLE)]
-... x ... Repeat string or array.
-x= ... Repetition assignment.
-y/SEARCHLIST/REPLACEMENTLIST/
-... | ... Bitwise or.
-... || ... Logical or.
-... // ... Defined-or.
-~ ... Unary bitwise complement.
+warn(LIST) print debugging info
+write[(EXPR|FILEHANDLE)] print a picture record
+y/SEARCHLIST/REPLACEMENTLIST/ transliterate a string
#! OS interpreter indicator. If contains `perl', used for options, and -x.
AUTOLOAD {...} Shorthand for `sub AUTOLOAD {...}'.
CORE:: Prefix to access builtin function if imported sub obscures it.
SUPER:: Prefix to lookup for a method in @ISA classes.
DESTROY Shorthand for `sub DESTROY {...}'.
-... EQ ... Obsolete synonym of `eq'.
-... GE ... Obsolete synonym of `ge'.
-... GT ... Obsolete synonym of `gt'.
-... LE ... Obsolete synonym of `le'.
-... LT ... Obsolete synonym of `lt'.
-... NE ... Obsolete synonym of `ne'.
-abs [ EXPR ] absolute value
-... and ... Low-precedence synonym for &&.
-bless REFERENCE [, PACKAGE] Makes reference into an object of a package.
-chomp [LIST] Strips $/ off LIST/$_. Returns count. Special if $/ eq \\='\\='!
-chr Converts a number to char with the same ordinal.
else Part of if/unless {BLOCK} elsif {BLOCK} else {BLOCK}.
elsif Part of if/unless {BLOCK} elsif {BLOCK} else {BLOCK}.
-exists $HASH{KEY} True if the key exists.
-fc EXPR Returns the casefolded version of EXPR.
-format [NAME] = Start of output format. Ended by a single dot (.) on a line.
-formline PICTURE, LIST Backdoor into \"format\" processing.
-glob EXPR Synonym of <EXPR>.
-lc [ EXPR ] Returns lowercased EXPR.
-lcfirst [ EXPR ] Returns EXPR with lower-cased first letter.
-grep EXPR,LIST or grep {BLOCK} LIST Filters LIST via EXPR/BLOCK.
-map EXPR, LIST or map {BLOCK} LIST Applies EXPR/BLOCK to elts of LIST.
-no PACKAGE [SYMBOL1, ...] Partial reverse for `use'. Runs `unimport' method.
-not ... Low-precedence synonym for ! - negation.
-... or ... Low-precedence synonym for ||.
-pos STRING Set/Get end-position of the last match over this string, see \\G.
-prototype FUNC Returns the prototype of a function as a string, or undef.
-quotemeta [ EXPR ] Quote regexp metacharacters.
-qw/WORD1 .../ Synonym of split(\\='\\=', \\='WORD1 ...\\=')
-readline FH Synonym of <FH>.
-readpipe CMD Synonym of \\=`CMD\\=`.
-ref [ EXPR ] Type of EXPR when dereferenced.
-sysopen FH, FILENAME, MODE [, PERM] (MODE is numeric, see Fcntl.)
-tie VAR, PACKAGE, LIST Hide an object behind a simple Perl variable.
-tied Returns internal object for a tied data.
-uc [ EXPR ] Returns upcased EXPR.
-ucfirst [ EXPR ] Returns EXPR with upcased first letter.
-untie VAR Unlink an object from a simple Perl variable.
-use PACKAGE [SYMBOL1, ...] Compile-time `require' with consequent `import'.
-... xor ... Low-precedence synonym for exclusive or.
-prototype \\&SUB Returns prototype of the function given a reference.
+default { ... } default case for given/when block
+defer { ... } run this block after the containing block.
+for (EXPR;EXPR;EXPR) { ... }
+foreach [VAR] (@ARRAY) { ... }
+given (EXPR) { [ when (EXPR) { ... } ]+ [ default { ... } ]? }
+if (EXPR) { ... } [ elsif (EXPR) { ... } ... ] [ else { ... } ] or EXPR if EXPR
+unless (EXPR) { ... } [ else { ... } ] or EXPR unless EXPR
+until (EXPR) { ... } EXPR until EXPR
+while (EXPR) { ... } EXPR while EXPR
=head1 Top-level heading.
=head2 Second-level heading.
=head3 Third-level heading.
@@ -8549,8 +8797,6 @@ start with default arguments, then refine the slowdown regions."
(message "to %s:%6s,%7s" l delta tot))
tot))
-(defvar font-lock-cache-position)
-
(defun cperl-emulate-lazy-lock (&optional window-size)
"Emulate `lazy-lock' without `condition-case', so `debug-on-error' works.
Start fontifying the buffer from the start (or end) using the given
@@ -8622,6 +8868,7 @@ Delay of auto-help controlled by `cperl-lazy-help-time'."
;;; Plug for wrong font-lock:
(defun cperl-font-lock-unfontify-region-function (beg end)
+ (declare (obsolete nil "30.1"))
(with-silent-modifications
(remove-text-properties beg end '(face nil))))
@@ -8695,7 +8942,8 @@ do extra unwind via `cperl-unwind-to-safe'."
(defun cperl-fontify-update-bad (end)
;; Since fontification happens with different region than syntaxification,
- ;; do to the end of buffer, not to END;;; likewise, start earlier if needed
+ ;; do to the end of buffer, not to END
+ ;; likewise, start earlier if needed
(let* ((pos (point)) (prop (get-text-property pos 'cperl-postpone)) posend)
(if prop
(setq pos (or (cperl-beginning-of-property
diff --git a/lisp/progmodes/csharp-mode.el b/lisp/progmodes/csharp-mode.el
index 2740d34e3b2..9782eb443f2 100644
--- a/lisp/progmodes/csharp-mode.el
+++ b/lisp/progmodes/csharp-mode.el
@@ -962,6 +962,13 @@ Key bindings:
;; Comments.
(c-ts-common-comment-setup)
+ (setq-local treesit-thing-settings
+ `((c-sharp
+ (text
+ ,(regexp-opt '("comment"
+ "verbatim_string-literal"
+ "interpolated_verbatim_string-text"))))))
+
;; Indent.
(setq-local treesit-simple-indent-rules csharp-ts-mode--indent-rules)
@@ -994,6 +1001,8 @@ Key bindings:
(add-to-list 'auto-mode-alist '("\\.cs\\'" . csharp-ts-mode)))
+(derived-mode-add-parents 'csharp-ts-mode '(csharp-mode))
+
(provide 'csharp-mode)
;;; csharp-mode.el ends here
diff --git a/lisp/progmodes/dcl-mode.el b/lisp/progmodes/dcl-mode.el
index 63b839012f3..b8ca1f2d600 100644
--- a/lisp/progmodes/dcl-mode.el
+++ b/lisp/progmodes/dcl-mode.el
@@ -1396,7 +1396,7 @@ regexps in `dcl-electric-reindent-regexps'."
;;;-------------------------------------------------------------------------
(defun dcl-indent-to (col &optional minimum)
"Like `indent-to', but only indents if indentation would change."
- (interactive)
+ (interactive "NIndent to column: ")
(let (cur-indent collapsed indent)
(save-excursion
(skip-chars-forward " \t")
diff --git a/lisp/progmodes/dockerfile-ts-mode.el b/lisp/progmodes/dockerfile-ts-mode.el
index 878335431af..e31fd86bbdf 100644
--- a/lisp/progmodes/dockerfile-ts-mode.el
+++ b/lisp/progmodes/dockerfile-ts-mode.el
@@ -149,6 +149,11 @@ Return nil if there is no name or if NODE is not a stage node."
(setq-local treesit-simple-indent-rules
dockerfile-ts-mode--indent-rules)
+ ;; Navigation
+ (setq-local treesit-thing-settings
+ `((dockerfile
+ (sentence "instruction"))))
+
;; Font-lock.
(setq-local treesit-font-lock-settings
dockerfile-ts-mode--font-lock-settings)
@@ -160,6 +165,8 @@ Return nil if there is no name or if NODE is not a stage node."
(treesit-major-mode-setup)))
+(derived-mode-add-parents 'dockerfile-ts-mode '(dockerfile-mode))
+
(if (treesit-ready-p 'dockerfile)
(add-to-list 'auto-mode-alist
;; NOTE: We can't use `rx' here, as it breaks bootstrap.
diff --git a/lisp/progmodes/ebnf-abn.el b/lisp/progmodes/ebnf-abn.el
index df5227eb970..2037696bf2f 100644
--- a/lisp/progmodes/ebnf-abn.el
+++ b/lisp/progmodes/ebnf-abn.el
@@ -3,7 +3,7 @@
;; Copyright (C) 2001-2024 Free Software Foundation, Inc.
;; Author: Vinicius Jose Latorre <viniciusjl.gnu@gmail.com>
-;; Keywords: wp, ebnf, PostScript
+;; Keywords: text, ebnf, PostScript
;; Old-Version: 1.2
;; Package: ebnf2ps
diff --git a/lisp/progmodes/ebnf-bnf.el b/lisp/progmodes/ebnf-bnf.el
index 61d26ed5829..c1862843368 100644
--- a/lisp/progmodes/ebnf-bnf.el
+++ b/lisp/progmodes/ebnf-bnf.el
@@ -3,7 +3,7 @@
;; Copyright (C) 1999-2024 Free Software Foundation, Inc.
;; Author: Vinicius Jose Latorre <viniciusjl.gnu@gmail.com>
-;; Keywords: wp, ebnf, PostScript
+;; Keywords: text, ebnf, PostScript
;; Old-Version: 1.10
;; Package: ebnf2ps
diff --git a/lisp/progmodes/ebnf-dtd.el b/lisp/progmodes/ebnf-dtd.el
index e191e268f4e..a9d1cc5e2b8 100644
--- a/lisp/progmodes/ebnf-dtd.el
+++ b/lisp/progmodes/ebnf-dtd.el
@@ -3,7 +3,7 @@
;; Copyright (C) 2001-2024 Free Software Foundation, Inc.
;; Author: Vinicius Jose Latorre <viniciusjl.gnu@gmail.com>
-;; Keywords: wp, ebnf, PostScript
+;; Keywords: text, ebnf, PostScript
;; Old-Version: 1.1
;; Package: ebnf2ps
diff --git a/lisp/progmodes/ebnf-ebx.el b/lisp/progmodes/ebnf-ebx.el
index 0743b1867fd..b88e68dc4a6 100644
--- a/lisp/progmodes/ebnf-ebx.el
+++ b/lisp/progmodes/ebnf-ebx.el
@@ -3,7 +3,7 @@
;; Copyright (C) 2001-2024 Free Software Foundation, Inc.
;; Author: Vinicius Jose Latorre <viniciusjl.gnu@gmail.com>
-;; Keywords: wp, ebnf, PostScript
+;; Keywords: text, ebnf, PostScript
;; Old-Version: 1.2
;; Package: ebnf2ps
diff --git a/lisp/progmodes/ebnf-iso.el b/lisp/progmodes/ebnf-iso.el
index b91914b1d08..e8d3e65976d 100644
--- a/lisp/progmodes/ebnf-iso.el
+++ b/lisp/progmodes/ebnf-iso.el
@@ -3,7 +3,7 @@
;; Copyright (C) 1999-2024 Free Software Foundation, Inc.
;; Author: Vinicius Jose Latorre <viniciusjl.gnu@gmail.com>
-;; Keywords: wp, ebnf, PostScript
+;; Keywords: text, ebnf, PostScript
;; Old-Version: 1.9
;; Package: ebnf2ps
diff --git a/lisp/progmodes/ebnf-otz.el b/lisp/progmodes/ebnf-otz.el
index 3162edf46ea..15141e762d4 100644
--- a/lisp/progmodes/ebnf-otz.el
+++ b/lisp/progmodes/ebnf-otz.el
@@ -3,7 +3,7 @@
;; Copyright (C) 1999-2024 Free Software Foundation, Inc.
;; Author: Vinicius Jose Latorre <viniciusjl.gnu@gmail.com>
-;; Keywords: wp, ebnf, PostScript
+;; Keywords: text, ebnf, PostScript
;; Old-Version: 1.0
;; Package: ebnf2ps
@@ -566,7 +566,7 @@
;; determine suffix length
(while (and (> isuf 0) (setq tail (cdr tail)))
(let* ((cur head)
- (tlis (nreverse
+ (tlis (reverse
(if (eq (ebnf-node-kind (car tail)) 'ebnf-generate-sequence)
(ebnf-node-list (car tail))
(list (car tail)))))
@@ -577,7 +577,6 @@
(setq cur (cdr cur)
this (cdr this)
i (1+ i)))
- (nreverse tlis)
(setq isuf (min isuf i))))
(setq head (nreverse head))
(if (or (zerop isuf) (> isuf len))
diff --git a/lisp/progmodes/ebnf-yac.el b/lisp/progmodes/ebnf-yac.el
index bd8469f623d..0ef98bd2d14 100644
--- a/lisp/progmodes/ebnf-yac.el
+++ b/lisp/progmodes/ebnf-yac.el
@@ -3,7 +3,7 @@
;; Copyright (C) 1999-2024 Free Software Foundation, Inc.
;; Author: Vinicius Jose Latorre <viniciusjl.gnu@gmail.com>
-;; Keywords: wp, ebnf, PostScript
+;; Keywords: text, ebnf, PostScript
;; Old-Version: 1.4
;; Package: ebnf2ps
diff --git a/lisp/progmodes/ebnf2ps.el b/lisp/progmodes/ebnf2ps.el
index b9b14153aa4..c74a523808f 100644
--- a/lisp/progmodes/ebnf2ps.el
+++ b/lisp/progmodes/ebnf2ps.el
@@ -3,7 +3,7 @@
;; Copyright (C) 1999-2024 Free Software Foundation, Inc.
;; Author: Vinicius Jose Latorre <viniciusjl.gnu@gmail.com>
-;; Keywords: wp, ebnf, PostScript
+;; Keywords: text, ebnf, PostScript
;; Old-Version: 4.4
;; URL: https://www.emacswiki.org/cgi-bin/wiki/ViniciusJoseLatorre
@@ -5247,7 +5247,7 @@ killed after process termination."
(or ebnf-fonts-required
(setq ebnf-fonts-required
(mapconcat #'identity
- (ps-remove-duplicates
+ (delete-dups
(mapcar #'ebnf-font-name-select
(list ebnf-production-font
ebnf-terminal-font
diff --git a/lisp/progmodes/ebrowse.el b/lisp/progmodes/ebrowse.el
index 5a764f99575..37b3a5f190b 100644
--- a/lisp/progmodes/ebrowse.el
+++ b/lisp/progmodes/ebrowse.el
@@ -1130,7 +1130,7 @@ If given a numeric N-TIMES argument, mark that many classes."
(defun ebrowse-redraw-marks (start end)
"Display class marker signs in the tree between START and END."
- (interactive)
+ (interactive "r")
(save-excursion
(with-silent-modifications
(catch 'end
@@ -1494,9 +1494,9 @@ and possibly kill the viewed buffer."
(defun ebrowse-view-file-other-frame (file)
- "View a file FILE in another frame.
+ "View FILE in another frame.
The new frame is deleted when you quit viewing the file in that frame."
- (interactive)
+ (interactive "fIn other frame view file: ")
(let ((old-frame-configuration (current-frame-configuration))
(had-a-buf (get-file-buffer file))
(buf-to-view (find-file-noselect file)))
diff --git a/lisp/progmodes/eglot.el b/lisp/progmodes/eglot.el
index 9eaa92da03e..7d2f1a55165 100644
--- a/lisp/progmodes/eglot.el
+++ b/lisp/progmodes/eglot.el
@@ -2,11 +2,12 @@
;; Copyright (C) 2018-2024 Free Software Foundation, Inc.
-;; Version: 1.12.29
+;; Version: 1.17
;; Author: João Távora <joaotavora@gmail.com>
;; Maintainer: João Távora <joaotavora@gmail.com>
;; URL: https://github.com/joaotavora/eglot
;; Keywords: convenience, languages
+;; Package-Requires: ((emacs "26.3") (jsonrpc "1.0.24") (flymake "1.2.1") (project "0.9.8") (xref "1.6.2") (eldoc "1.14.0") (seq "2.23") (external-completion "0.1"))
;; This is a GNU ELPA :core package. Avoid adding functionality
;; that is not available in the version of Emacs recorded above or any
@@ -96,34 +97,41 @@
(require 'imenu)
(require 'cl-lib)
-(require 'project)
+
(require 'url-parse)
(require 'url-util)
(require 'pcase)
(require 'compile) ; for some faces
(require 'warnings)
-(require 'flymake)
-(require 'xref)
(eval-when-compile
(require 'subr-x))
-(require 'jsonrpc)
(require 'filenotify)
(require 'ert)
-(require 'array)
-(require 'external-completion)
-
-;; ElDoc is preloaded in Emacs, so `require'-ing won't guarantee we are
-;; using the latest version from GNU Elpa when we load eglot.el. Use an
-;; heuristic to see if we need to `load' it in Emacs < 28.
-(if (and (< emacs-major-version 28)
- (not (boundp 'eldoc-documentation-strategy)))
- (load "eldoc")
- (require 'eldoc))
-
-;; Similar issue as above for Emacs 26.3 and seq.el.
-(if (< emacs-major-version 27)
- (load "seq")
- (require 'seq))
+(require 'text-property-search nil t)
+(require 'diff-mode)
+(require 'diff)
+
+;; These dependencies are also GNU ELPA core packages. Because of
+;; bug#62576, since there is a risk that M-x package-install, despite
+;; having installed them, didn't correctly re-load them over the
+;; built-in versions.
+(eval-and-compile
+ ;; For those packages that are preloaded, reload them if needed,
+ ;; since that's the best we can do anyway.
+ ;; FIXME: Maybe the ELPA packages for those preloaded packages should
+ ;; force-reload themselves eagerly when the package is activated!
+ (let ((reload (if (fboundp 'require-with-check) ;Emacs≥30
+ #'require-with-check
+ (lambda (feature &rest _)
+ ;; Just blindly reload like we used to do before
+ ;; `require-with-check'.
+ (load (symbol-name feature) nil 'nomessage)))))
+
+ (funcall reload 'eldoc nil 'reload)
+ (funcall reload 'seq nil 'reload)
+ ;; For those packages which are not preloaded OTOH, signal an error if
+ ;; the loaded file is not the one that should have been loaded.
+ (mapc reload '(project flymake xref jsonrpc external-completion))))
;; forward-declare, but don't require (Emacs 28 doesn't seem to care)
(defvar markdown-fontify-code-blocks-natively)
@@ -133,6 +141,37 @@
(defvar tramp-use-ssh-controlmaster-options)
+;;; Obsolete aliases
+;;;
+(make-obsolete-variable 'eglot--managed-mode-hook
+ 'eglot-managed-mode-hook "1.6")
+(define-obsolete-variable-alias 'eglot-confirm-server-initiated-edits
+ 'eglot-confirm-server-edits "1.16")
+(make-obsolete-variable 'eglot-events-buffer-size
+ 'eglot-events-buffer-config "1.16")
+(define-obsolete-function-alias 'eglot--uri-to-path #'eglot-uri-to-path "1.16")
+(define-obsolete-function-alias 'eglot--path-to-uri #'eglot-path-to-uri "1.16")
+(define-obsolete-function-alias 'eglot--range-region #'eglot-range-region "1.16")
+(define-obsolete-function-alias 'eglot--server-capable #'eglot-server-capable "1.16")
+(define-obsolete-function-alias 'eglot--server-capable-or-lose #'eglot-server-capable-or-lose "1.16")
+(define-obsolete-function-alias
+ 'eglot-lsp-abiding-column #'eglot-utf-16-linepos "1.12")
+(define-obsolete-function-alias
+ 'eglot-current-column #'eglot-utf-32-linepos "1.12")
+(define-obsolete-variable-alias
+ 'eglot-current-column-function 'eglot-current-linepos-function "1.12")
+(define-obsolete-function-alias
+ 'eglot-move-to-current-column #'eglot-move-to-utf-32-linepos "1.12")
+(define-obsolete-function-alias
+ 'eglot-move-to-lsp-abiding-column #'eglot-move-to-utf-16-linepos "1.12")
+(define-obsolete-variable-alias
+ 'eglot-move-to-column-function 'eglot-move-to-linepos-function "1.12")
+(define-obsolete-variable-alias 'eglot-ignored-server-capabilites
+ 'eglot-ignored-server-capabilities "1.8")
+;;;###autoload
+(define-obsolete-function-alias 'eglot-update #'eglot-upgrade-eglot "29.1")
+
+
;;; User tweakable stuff
(defgroup eglot nil
"Interaction with Language Server Protocol servers."
@@ -143,11 +182,12 @@
"Compute server-choosing function for `eglot-server-programs'.
Each element of ALTERNATIVES is a string PROGRAM or a list of
strings (PROGRAM ARGS...) where program names an LSP server
-program to start with ARGS. Returns a function of one argument.
-When invoked, that function will return a list (ABSPATH ARGS),
-where ABSPATH is the absolute path of the PROGRAM that was
-chosen (interactively or automatically)."
- (lambda (&optional interactive)
+program to start with ARGS. Returns a function to be invoked
+automatically by Eglot on startup. When invoked, that function
+will return a list (ABSPATH ARGS), where ABSPATH is the absolute
+path of the PROGRAM that was chosen (interactively or
+automatically)."
+ (lambda (&optional interactive _project)
;; JT@2021-06-13: This function is way more complicated than it
;; could be because it accounts for the fact that
;; `eglot--executable-find' may take much longer to execute on
@@ -157,7 +197,10 @@ chosen (interactively or automatically)."
(err (lambda ()
(error "None of '%s' are valid executables"
(mapconcat #'car listified ", ")))))
- (cond (interactive
+ (cond ((and interactive current-prefix-arg)
+ ;; A C-u always lets user input something manually,
+ nil)
+ (interactive
(let* ((augmented (mapcar (lambda (a)
(let ((found (eglot--executable-find
(car a) t)))
@@ -183,85 +226,108 @@ chosen (interactively or automatically)."
when probe return (cons probe args)
finally (funcall err)))))))
-(defvar eglot-server-programs `(((rust-ts-mode rust-mode) . ,(eglot-alternatives '("rust-analyzer" "rls")))
- ((cmake-mode cmake-ts-mode) . ("cmake-language-server"))
- (vimrc-mode . ("vim-language-server" "--stdio"))
- ((python-mode python-ts-mode)
- . ,(eglot-alternatives
- '("pylsp" "pyls" ("pyright-langserver" "--stdio") "jedi-language-server" "ruff-lsp")))
- ((js-json-mode json-mode json-ts-mode)
- . ,(eglot-alternatives '(("vscode-json-language-server" "--stdio")
- ("vscode-json-languageserver" "--stdio")
- ("json-languageserver" "--stdio"))))
- (((js-mode :language-id "javascript")
- (js-ts-mode :language-id "javascript")
- (tsx-ts-mode :language-id "typescriptreact")
- (typescript-ts-mode :language-id "typescript")
- (typescript-mode :language-id "typescript"))
- . ("typescript-language-server" "--stdio"))
- ((bash-ts-mode sh-mode) . ("bash-language-server" "start"))
- ((php-mode phps-mode php-ts-mode)
- . ,(eglot-alternatives
- '(("phpactor" "language-server")
- ("php" "vendor/felixfbecker/language-server/bin/php-language-server.php"))))
- ((c-mode c-ts-mode c++-mode c++-ts-mode)
- . ,(eglot-alternatives
- '("clangd" "ccls")))
- (((caml-mode :language-id "ocaml")
- (tuareg-mode :language-id "ocaml") reason-mode)
- . ("ocamllsp"))
- ((ruby-mode ruby-ts-mode)
- . ("solargraph" "socket" "--port" :autoport))
- (haskell-mode
- . ("haskell-language-server-wrapper" "--lsp"))
- (elm-mode . ("elm-language-server"))
- (mint-mode . ("mint" "ls"))
- ((kotlin-mode kotlin-ts-mode) . ("kotlin-language-server"))
- ((go-mode go-dot-mod-mode go-dot-work-mode go-ts-mode go-mod-ts-mode)
- . ("gopls"))
- ((R-mode ess-r-mode) . ("R" "--slave" "-e"
- "languageserver::run()"))
- ((java-mode java-ts-mode) . ("jdtls"))
- ((dart-mode dart-ts-mode)
- . ("dart" "language-server"
- "--client-id" "emacs.eglot-dart"))
- (elixir-mode . ("language_server.sh"))
- (ada-mode . ("ada_language_server"))
- (scala-mode . ,(eglot-alternatives
- '("metals" "metals-emacs")))
- (racket-mode . ("racket" "-l" "racket-langserver"))
- ((tex-mode context-mode texinfo-mode bibtex-mode)
- . ,(eglot-alternatives '("digestif" "texlab")))
- (erlang-mode . ("erlang_ls" "--transport" "stdio"))
- ((yaml-ts-mode yaml-mode) . ("yaml-language-server" "--stdio"))
- (nix-mode . ,(eglot-alternatives '("nil" "rnix-lsp" "nixd")))
- ((nushell-mode nushell-ts-mode) . ("nu" "--lsp"))
- (gdscript-mode . ("localhost" 6008))
- ((fortran-mode f90-mode) . ("fortls"))
- (futhark-mode . ("futhark" "lsp"))
- (lua-mode . ,(eglot-alternatives
- '("lua-language-server" "lua-lsp")))
- (zig-mode . ("zls"))
- ((css-mode css-ts-mode)
- . ,(eglot-alternatives '(("vscode-css-language-server" "--stdio")
- ("css-languageserver" "--stdio"))))
- (html-mode . ,(eglot-alternatives '(("vscode-html-language-server" "--stdio") ("html-languageserver" "--stdio"))))
- ((dockerfile-mode dockerfile-ts-mode) . ("docker-langserver" "--stdio"))
- ((clojure-mode clojurescript-mode clojurec-mode)
- . ("clojure-lsp"))
- ((csharp-mode csharp-ts-mode)
- . ,(eglot-alternatives
- '(("omnisharp" "-lsp")
- ("csharp-ls"))))
- (purescript-mode . ("purescript-language-server" "--stdio"))
- ((perl-mode cperl-mode) . ("perl" "-MPerl::LanguageServer" "-e" "Perl::LanguageServer::run"))
- (markdown-mode
- . ,(eglot-alternatives
- '(("marksman" "server")
- ("vscode-markdown-language-server" "--stdio"))))
- (graphviz-dot-mode . ("dot-language-server" "--stdio"))
- (terraform-mode . ("terraform-ls" "serve"))
- ((uiua-ts-mode uiua-mode) . ("uiua" "lsp")))
+(defvar eglot-server-programs
+ ;; FIXME: Maybe this info should be distributed into the major modes
+ ;; themselves where they could set a buffer-local `eglot-server-program'
+ ;; instead of keeping this database centralized.
+ ;; FIXME: With `derived-mode-add-parents' in Emacs≥30, some of
+ ;; those entries can be simplified, but we keep them for when
+ ;; `eglot.el' is installed via GNU ELPA in an older Emacs.
+ `(((rust-ts-mode rust-mode) . ("rust-analyzer"))
+ ((cmake-mode cmake-ts-mode) . ("cmake-language-server"))
+ (vimrc-mode . ("vim-language-server" "--stdio"))
+ ((python-mode python-ts-mode)
+ . ,(eglot-alternatives
+ '("pylsp" "pyls" ("basedpyright-langserver" "--stdio")
+ ("pyright-langserver" "--stdio")
+ "jedi-language-server" "ruff-lsp")))
+ ((js-json-mode json-mode json-ts-mode)
+ . ,(eglot-alternatives '(("vscode-json-language-server" "--stdio")
+ ("vscode-json-languageserver" "--stdio")
+ ("json-languageserver" "--stdio"))))
+ (((js-mode :language-id "javascript")
+ (js-ts-mode :language-id "javascript")
+ (tsx-ts-mode :language-id "typescriptreact")
+ (typescript-ts-mode :language-id "typescript")
+ (typescript-mode :language-id "typescript"))
+ . ("typescript-language-server" "--stdio"))
+ ((bash-ts-mode sh-mode) . ("bash-language-server" "start"))
+ ((php-mode phps-mode php-ts-mode)
+ . ,(eglot-alternatives
+ '(("phpactor" "language-server")
+ ("php" "vendor/felixfbecker/language-server/bin/php-language-server.php"))))
+ ((c-mode c-ts-mode c++-mode c++-ts-mode objc-mode)
+ . ,(eglot-alternatives
+ '("clangd" "ccls")))
+ (((caml-mode :language-id "ocaml")
+ (tuareg-mode :language-id "ocaml") reason-mode)
+ . ("ocamllsp"))
+ ((ruby-mode ruby-ts-mode)
+ . ("solargraph" "socket" "--port" :autoport))
+ (haskell-mode
+ . ("haskell-language-server-wrapper" "--lsp"))
+ (elm-mode . ("elm-language-server"))
+ (mint-mode . ("mint" "ls"))
+ ((kotlin-mode kotlin-ts-mode) . ("kotlin-language-server"))
+ ((go-mode go-dot-mod-mode go-dot-work-mode go-ts-mode go-mod-ts-mode)
+ . ("gopls"))
+ ((R-mode ess-r-mode) . ("R" "--slave" "-e"
+ "languageserver::run()"))
+ ((java-mode java-ts-mode) . ("jdtls"))
+ ((dart-mode dart-ts-mode)
+ . ("dart" "language-server"
+ "--client-id" "emacs.eglot-dart"))
+ ((elixir-mode elixir-ts-mode heex-ts-mode)
+ . ,(if (and (fboundp 'w32-shell-dos-semantics)
+ (w32-shell-dos-semantics))
+ '("language_server.bat")
+ (eglot-alternatives
+ '("language_server.sh" "start_lexical.sh"))))
+ (ada-mode . ("ada_language_server"))
+ (scala-mode . ,(eglot-alternatives
+ '("metals" "metals-emacs")))
+ (racket-mode . ("racket" "-l" "racket-langserver"))
+ ((tex-mode context-mode texinfo-mode bibtex-mode)
+ . ,(eglot-alternatives '("digestif" "texlab")))
+ (erlang-mode . ("erlang_ls" "--transport" "stdio"))
+ ((yaml-ts-mode yaml-mode) . ("yaml-language-server" "--stdio"))
+ (nix-mode . ,(eglot-alternatives '("nil" "rnix-lsp" "nixd")))
+ (nickel-mode . ("nls"))
+ ((nushell-mode nushell-ts-mode) . ("nu" "--lsp"))
+ (gdscript-mode . ("localhost" 6008))
+ (fennel-mode . ("fennel-ls"))
+ (move-mode . ("move-analyzer"))
+ ((fortran-mode f90-mode) . ("fortls"))
+ (futhark-mode . ("futhark" "lsp"))
+ ((lua-mode lua-ts-mode) . ,(eglot-alternatives
+ '("lua-language-server" "lua-lsp")))
+ (zig-mode . ("zls"))
+ ((css-mode css-ts-mode)
+ . ,(eglot-alternatives '(("vscode-css-language-server" "--stdio")
+ ("css-languageserver" "--stdio"))))
+ (html-mode . ,(eglot-alternatives
+ '(("vscode-html-language-server" "--stdio")
+ ("html-languageserver" "--stdio"))))
+ ((dockerfile-mode dockerfile-ts-mode) . ("docker-langserver" "--stdio"))
+ ((clojure-mode clojurescript-mode clojurec-mode clojure-ts-mode)
+ . ("clojure-lsp"))
+ ((csharp-mode csharp-ts-mode)
+ . ,(eglot-alternatives
+ '(("omnisharp" "-lsp")
+ ("csharp-ls"))))
+ (purescript-mode . ("purescript-language-server" "--stdio"))
+ ((perl-mode cperl-mode)
+ . ("perl" "-MPerl::LanguageServer" "-e" "Perl::LanguageServer::run"))
+ (markdown-mode
+ . ,(eglot-alternatives
+ '(("marksman" "server")
+ ("vscode-markdown-language-server" "--stdio"))))
+ (graphviz-dot-mode . ("dot-language-server" "--stdio"))
+ (terraform-mode . ("terraform-ls" "serve"))
+ ((uiua-ts-mode uiua-mode) . ("uiua" "lsp"))
+ (sml-mode
+ . ,(lambda (_interactive project)
+ (list "millet-ls" (project-root project)))))
"How the command `eglot' guesses the server to start.
An association list of (MAJOR-MODE . CONTACT) pairs. MAJOR-MODE
identifies the buffers that are to be managed by a specific
@@ -317,16 +383,16 @@ CONTACT can be:
which you should see for the semantics of the mandatory
:PROCESS argument.
-* A function of a single argument producing any of the above
- values for CONTACT. The argument's value is non-nil if the
- connection was requested interactively (e.g. from the `eglot'
- command), and nil if it wasn't (e.g. from `eglot-ensure'). If
- the call is interactive, the function can ask the user for
- hints on finding the required programs, etc. Otherwise, it
- should not ask the user for any input, and return nil or signal
- an error if it can't produce a valid CONTACT. The helper
- function `eglot-alternatives' (which see) can be used to
- produce a function that offers more than one server for a given
+* A function of two arguments (INTERACTIVE PROJECT) producing any
+ of the above values for CONTACT. INTERACTIVE will be t if an
+ interactive `M-x eglot' was used, and nil otherwise (e.g. from
+ `eglot-ensure'). Interactive calls may ask the user for hints
+ on finding the required programs, etc. PROJECT is whatever
+ project Eglot discovered via `project-find-functions' (which
+ see). The function should return nil or signal an error if it
+ can't produce a valid CONTACT. The helper function
+ `eglot-alternatives' (which see) can be used to produce a
+ function that offers more than one server for a given
MAJOR-MODE.")
(defface eglot-highlight-symbol-face
@@ -380,47 +446,127 @@ as 0, i.e. don't block at all."
"Don't tell server of changes before Emacs's been idle for this many seconds."
:type 'number)
-(defcustom eglot-events-buffer-size 2000000
- "Control the size of the Eglot events buffer.
-If a number, don't let the buffer grow larger than that many
-characters. If 0, don't use an event's buffer at all. If nil,
-let the buffer grow forever.
-
-For changes on this variable to take effect on a connection
-already started, you need to restart the connection. That can be
-done by `eglot-reconnect'."
- :type '(choice (const :tag "No limit" nil)
- (integer :tag "Number of characters")))
-
-(defcustom eglot-confirm-server-initiated-edits 'confirm
- "Non-nil if server-initiated edits should be confirmed with user."
- :type '(choice (const :tag "Don't show confirmation prompt" nil)
- (const :tag "Show confirmation prompt" confirm)))
+(defcustom eglot-events-buffer-config
+ (list :size (or (bound-and-true-p eglot-events-buffer-size) 2000000)
+ :format 'full)
+ "Configure the Eglot events buffer.
+
+Value is a plist accepting the keys `:size', which controls the
+size in characters of the buffer (0 disables, nil means
+infinite), and `:format', which controls the shape of each log
+entry (`full' includes the original JSON, `lisp' uses
+pretty-printed Lisp).
+
+For changes on this variable to take effect, you need to restart
+the LSP connection. That can be done by `eglot-reconnect'."
+ :type '(plist :key-type (symbol :tag "Keyword")
+ :options (((const :tag "Size" :size)
+ (choice
+ (const :tag "No limit" nil)
+ (integer :tag "Number of characters")))
+ ((const :tag "Format" :format)
+ (choice
+ (const :tag "Full with original JSON" full)
+ (const :tag "Shortened" short)
+ (const :tag "Pretty-printed lisp" lisp))))))
+
+(defcustom eglot-confirm-server-edits '((eglot-rename . nil)
+ (t . maybe-summary))
+ "Control if changes proposed by LSP should be confirmed with user.
+
+If this variable's value is the symbol `diff', a diff buffer is
+pops up, allowing the user to apply each change individually. If
+the symbol `summary' or any other non-nil value, the user is
+prompted in the minibuffer with aa short summary of changes. The
+symbols `maybe-diff' and `maybe-summary' mean that the
+confirmation is offered to the user only if the changes target
+files visited in buffers. Finally, a nil value means all changes
+are applied directly without any confirmation.
+
+If this variable's value can also be an alist ((COMMAND . ACTION)
+...) where COMMAND is a symbol designating a command, such as
+`eglot-rename', `eglot-code-actions',
+`eglot-code-action-quickfix', etc. ACTION is one of the symbols
+described above. The value `t' for COMMAND is accepted and its
+ACTION is the default value for commands not in the alist."
+ :type (let ((basic-choices
+ '((const :tag "Use diff" diff)
+ (const :tag "Summarize and prompt" summary)
+ (const :tag "Maybe use diff" maybe-diff)
+ (const :tag "Maybe summarize and prompt" maybe-summary)
+ (const :tag "Don't confirm" nil))))
+ `(choice ,@basic-choices
+ (alist :tag "Per-command alist"
+ :key-type (choice (function :tag "Command")
+ (const :tag "Default" t))
+ :value-type (choice . ,basic-choices)))))
(defcustom eglot-extend-to-xref nil
"If non-nil, activate Eglot in cross-referenced non-project files."
:type 'boolean)
+(defcustom eglot-prefer-plaintext nil
+ "If non-nil, always request plaintext responses to hover requests."
+ :type 'boolean)
+
(defcustom eglot-menu-string "eglot"
"String displayed in mode line when Eglot is active."
:type 'string)
(defcustom eglot-report-progress t
- "If non-nil, show progress of long running LSP server work"
- :type 'boolean
- :version "29.1")
+ "If non-nil, show progress of long running LSP server work.
+If set to `messages', use *Messages* buffer, else use Eglot's
+mode line indicator."
+ :type '(choice (const :tag "Don't show progress" nil)
+ (const :tag "Show progress in *Messages*" messages)
+ (const :tag "Show progress in Eglot's mode line indicator" t))
+ :version "1.10")
+
+(defcustom eglot-ignored-server-capabilities (list)
+ "LSP server capabilities that Eglot could use, but won't.
+You could add, for instance, the symbol
+`:documentHighlightProvider' to prevent automatic highlighting
+under cursor."
+ :type '(set
+ :tag "Tick the ones you're not interested in"
+ (const :tag "Documentation on hover" :hoverProvider)
+ (const :tag "Code completion" :completionProvider)
+ (const :tag "Function signature help" :signatureHelpProvider)
+ (const :tag "Go to definition" :definitionProvider)
+ (const :tag "Go to type definition" :typeDefinitionProvider)
+ (const :tag "Go to implementation" :implementationProvider)
+ (const :tag "Go to declaration" :declarationProvider)
+ (const :tag "Find references" :referencesProvider)
+ (const :tag "Highlight symbols automatically" :documentHighlightProvider)
+ (const :tag "List symbols in buffer" :documentSymbolProvider)
+ (const :tag "List symbols in workspace" :workspaceSymbolProvider)
+ (const :tag "Execute code actions" :codeActionProvider)
+ (const :tag "Code lens" :codeLensProvider)
+ (const :tag "Format buffer" :documentFormattingProvider)
+ (const :tag "Format portion of buffer" :documentRangeFormattingProvider)
+ (const :tag "On-type formatting" :documentOnTypeFormattingProvider)
+ (const :tag "Rename symbol" :renameProvider)
+ (const :tag "Highlight links in document" :documentLinkProvider)
+ (const :tag "Decorate color references" :colorProvider)
+ (const :tag "Fold regions of buffer" :foldingRangeProvider)
+ (const :tag "Execute custom commands" :executeCommandProvider)
+ (const :tag "Inlay hints" :inlayHintProvider)))
(defvar eglot-withhold-process-id nil
"If non-nil, Eglot will not send the Emacs process id to the language server.
This can be useful when using docker to run a language server.")
-;; Customizable via `completion-category-overrides'.
-(when (assoc 'flex completion-styles-alist)
- (add-to-list 'completion-category-defaults '(eglot (styles flex basic))))
-
;;; Constants
;;;
+(defconst eglot--version
+ (eval-when-compile
+ (when byte-compile-current-file
+ (require 'lisp-mnt)
+ (lm-version byte-compile-current-file)))
+ "The version as a string of this version of Eglot.
+It is nil if Eglot is not byte-complied.")
+
(defconst eglot--symbol-kind-names
`((1 . "File") (2 . "Module")
(3 . "Namespace") (4 . "Package") (5 . "Class")
@@ -446,20 +592,31 @@ This can be useful when using docker to run a language server.")
(2 . eglot-diagnostic-tag-deprecated-face)))
(defvaralias 'eglot-{} 'eglot--{})
-(defconst eglot--{} (make-hash-table :size 1) "The empty JSON object.")
+
+(defconst eglot--{} (make-hash-table :size 0) "The empty JSON object.")
(defun eglot--executable-find (command &optional remote)
"Like Emacs 27's `executable-find', ignore REMOTE on Emacs 26."
(if (>= emacs-major-version 27) (executable-find command remote)
(executable-find command)))
+(defun eglot--accepted-formats ()
+ (if (and (not eglot-prefer-plaintext) (fboundp 'gfm-view-mode))
+ ["markdown" "plaintext"] ["plaintext"]))
+
+(defconst eglot--uri-path-allowed-chars
+ (let ((vec (copy-sequence url-path-allowed-chars)))
+ (aset vec ?: nil) ;; see github#639
+ vec)
+ "Like `url-path-allowed-chars' but more restrictive.")
+
;;; Message verification helpers
;;;
(eval-and-compile
(defvar eglot--lsp-interface-alist
`(
- (CodeAction (:title) (:kind :diagnostics :edit :command :isPreferred))
+ (CodeAction (:title) (:kind :diagnostics :edit :command :isPreferred :data))
(ConfigurationItem () (:scopeUri :section))
(Command ((:title . string) (:command . string)) (:arguments))
(CompletionItem (:label)
@@ -488,9 +645,7 @@ This can be useful when using docker to run a language server.")
(SymbolInformation (:name :kind :location)
(:deprecated :containerName))
(DocumentSymbol (:name :range :selectionRange :kind)
- ;; `:containerName' isn't really allowed , but
- ;; it simplifies the impl of `eglot-imenu'.
- (:detail :deprecated :children :containerName))
+ (:detail :deprecated :children))
(TextDocumentEdit (:textDocument :edits) ())
(TextEdit (:range :newText))
(VersionedTextDocumentIdentifier (:uri :version) ())
@@ -648,7 +803,6 @@ Honor `eglot-strict-mode'."
(cl-destructuring-bind (&key ,@vars &allow-other-keys) ,object-once
(funcall ,fn-once ,@vars))))))))
-
(cl-defmacro eglot--lambda (cl-lambda-list &body body)
"Function of args CL-LAMBDA-LIST for processing INTERFACE objects.
Honor `eglot-strict-mode'."
@@ -697,9 +851,6 @@ treated as in `eglot--dbind'."
,obj-once
',(mapcar #'car clauses)))))))
-
-;;; API (WORK-IN-PROGRESS!)
-;;;
(cl-defmacro eglot--when-live-buffer (buf &rest body)
"Check BUF live, then do BODY in it." (declare (indent 1) (debug t))
(let ((b (cl-gensym)))
@@ -717,14 +868,35 @@ treated as in `eglot--dbind'."
"Save excursion and restriction. Widen. Then run BODY." (declare (debug t))
`(save-excursion (save-restriction (widen) ,@body)))
+
+;;; Public Elisp API
+;;;
(cl-defgeneric eglot-handle-request (server method &rest params)
"Handle SERVER's METHOD request with PARAMS.")
(cl-defgeneric eglot-handle-notification (server method &rest params)
"Handle SERVER's METHOD notification with PARAMS.")
-(cl-defgeneric eglot-execute-command (server command arguments)
- "Ask SERVER to execute COMMAND with ARGUMENTS.")
+(cl-defgeneric eglot-execute-command (_ _ _)
+ (declare (obsolete eglot-execute "30.1"))
+ (:method
+ (server command arguments)
+ (eglot--request server :workspace/executeCommand
+ `(:command ,(format "%s" command) :arguments ,arguments))))
+
+(cl-defgeneric eglot-execute (server action)
+ "Ask SERVER to execute ACTION.
+ACTION is an LSP object of either `CodeAction' or `Command' type."
+ (:method
+ (server action) "Default implementation."
+ (eglot--dcase action
+ (((Command)) (eglot--request server :workspace/executeCommand action))
+ (((CodeAction) edit command data)
+ (if (and (null edit) (null command) data
+ (eglot-server-capable :codeActionProvider :resolveProvider))
+ (eglot-execute server (eglot--request server :codeAction/resolve action))
+ (when edit (eglot--apply-workspace-edit edit this-command))
+ (when command (eglot--request server :workspace/executeCommand command)))))))
(cl-defgeneric eglot-initialization-options (server)
"JSON object to send under `initializationOptions'."
@@ -783,14 +955,12 @@ treated as in `eglot--dbind'."
:tagSupport (:valueSet [1]))
:contextSupport t)
:hover (list :dynamicRegistration :json-false
- :contentFormat
- (if (fboundp 'gfm-view-mode)
- ["markdown" "plaintext"]
- ["plaintext"]))
+ :contentFormat (eglot--accepted-formats))
:signatureHelp (list :dynamicRegistration :json-false
:signatureInformation
`(:parameterInformation
(:labelOffsetSupport t)
+ :documentationFormat ,(eglot--accepted-formats)
:activeParameterSupport t))
:references `(:dynamicRegistration :json-false)
:definition (list :dynamicRegistration :json-false
@@ -810,6 +980,8 @@ treated as in `eglot--dbind'."
:documentHighlight `(:dynamicRegistration :json-false)
:codeAction (list
:dynamicRegistration :json-false
+ :resolveSupport `(:properties ["edit" "command"])
+ :dataSupport t
:codeActionLiteralSupport
'(:codeActionKind
(:valueSet
@@ -831,7 +1003,8 @@ treated as in `eglot--dbind'."
`(:valueSet
[,@(mapcar
#'car eglot--tag-faces)])))
- :window `(:workDoneProgress t)
+ :window `(:showDocument (:support t)
+ :workDoneProgress t)
:general (list :positionEncodings ["utf-32" "utf-8" "utf-16"])
:experimental eglot--{})))
@@ -840,7 +1013,7 @@ treated as in `eglot--dbind'."
(let ((project (eglot--project server)))
(vconcat
(mapcar (lambda (dir)
- (list :uri (eglot--path-to-uri dir)
+ (list :uri (eglot-path-to-uri dir)
:name (abbreviate-file-name dir)))
`(,(project-root project) ,@(project-external-roots project))))))
@@ -849,22 +1022,24 @@ treated as in `eglot--dbind'."
:documentation "Short nickname for the associated project."
:accessor eglot--project-nickname
:reader eglot-project-nickname)
- (major-modes
- :documentation "Major modes server is responsible for in a given project."
- :accessor eglot--major-modes)
- (language-id
- :documentation "Language ID string for the mode."
- :accessor eglot--language-id)
+ (languages
+ :initform nil
+ :documentation "Alist ((MODE . LANGUAGE-ID-STRING)...) of managed languages."
+ :accessor eglot--languages)
(capabilities
+ :initform nil
:documentation "JSON object containing server capabilities."
:accessor eglot--capabilities)
(server-info
+ :initform nil
:documentation "JSON object containing server info."
:accessor eglot--server-info)
(shutdown-requested
+ :initform nil
:documentation "Flag set when server is shutting down."
:accessor eglot--shutdown-requested)
(project
+ :initform nil
:documentation "Project associated with server."
:accessor eglot--project)
(progress-reporters
@@ -875,25 +1050,102 @@ treated as in `eglot--dbind'."
:documentation "Generalized boolean inhibiting auto-reconnection if true."
:accessor eglot--inhibit-autoreconnect)
(file-watches
- :documentation "Map ID to list of WATCHES for `didChangeWatchedFiles'."
+ :documentation "Map (DIR -> (WATCH ID1 ID2...)) for `didChangeWatchedFiles'."
:initform (make-hash-table :test #'equal) :accessor eglot--file-watches)
(managed-buffers
+ :initform nil
:documentation "List of buffers managed by server."
:accessor eglot--managed-buffers)
(saved-initargs
:documentation "Saved initargs for reconnection purposes."
- :accessor eglot--saved-initargs)
- (inferior-process
- :documentation "Server subprocess started automatically."
- :accessor eglot--inferior-process))
+ :accessor eglot--saved-initargs))
:documentation
"Represents a server. Wraps a process for LSP communication.")
+(declare-function w32-long-file-name "w32proc.c" (fn))
+(defun eglot-uri-to-path (uri)
+ "Convert URI to file path, helped by `eglot--current-server'."
+ (when (keywordp uri) (setq uri (substring (symbol-name uri) 1)))
+ (let* ((server (eglot-current-server))
+ (remote-prefix (and server (eglot--trampish-p server)))
+ (url (url-generic-parse-url uri)))
+ ;; Only parse file:// URIs, leave other URI untouched as
+ ;; `file-name-handler-alist' should know how to handle them
+ ;; (bug#58790).
+ (if (string= "file" (url-type url))
+ (let* ((retval (url-unhex-string (url-filename url)))
+ ;; Remove the leading "/" for local MS Windows-style paths.
+ (normalized (if (and (not remote-prefix)
+ (eq system-type 'windows-nt)
+ (cl-plusp (length retval)))
+ (w32-long-file-name (substring retval 1))
+ retval)))
+ (concat remote-prefix normalized))
+ uri)))
+
+(defun eglot-path-to-uri (path)
+ "Convert PATH, a file name, to LSP URI string and return it."
+ (let ((truepath (file-truename path)))
+ (if (and (url-type (url-generic-parse-url path))
+ ;; It might be MS Windows path which includes a drive
+ ;; letter that looks like a URL scheme (bug#59338)
+ (not (and (eq system-type 'windows-nt)
+ (file-name-absolute-p truepath))))
+ ;; Path is already a URI, so forward it to the LSP server
+ ;; untouched. The server should be able to handle it, since
+ ;; it provided this URI to clients in the first place.
+ path
+ (concat "file://"
+ ;; Add a leading "/" for local MS Windows-style paths.
+ (if (and (eq system-type 'windows-nt)
+ (not (file-remote-p truepath)))
+ "/")
+ (url-hexify-string
+ ;; Again watch out for trampy paths.
+ (directory-file-name (file-local-name truepath))
+ eglot--uri-path-allowed-chars)))))
+
+(defun eglot-range-region (range &optional markers)
+ "Return a cons (BEG . END) of positions representing LSP RANGE.
+If optional MARKERS, make markers instead."
+ (let* ((st (plist-get range :start))
+ (beg (eglot--lsp-position-to-point st markers))
+ (end (eglot--lsp-position-to-point (plist-get range :end) markers)))
+ (cons beg end)))
+
+(defun eglot-server-capable (&rest feats)
+ "Determine if current server is capable of FEATS."
+ (unless (cl-some (lambda (feat)
+ (memq feat eglot-ignored-server-capabilities))
+ feats)
+ (cl-loop for caps = (eglot--capabilities (eglot--current-server-or-lose))
+ then (cadr probe)
+ for (feat . more) on feats
+ for probe = (plist-member caps feat)
+ if (not probe) do (cl-return nil)
+ if (eq (cadr probe) :json-false) do (cl-return nil)
+ if (not (listp (cadr probe))) do (cl-return (if more nil (cadr probe)))
+ finally (cl-return (or (cadr probe) t)))))
+
+(defun eglot-server-capable-or-lose (&rest feats)
+ "Like `eglot-server-capable', but maybe error out."
+ (let ((retval (apply #'eglot-server-capable feats)))
+ (unless retval
+ (eglot--error "Unsupported or ignored LSP capability `%s'"
+ (mapconcat #'symbol-name feats " ")))
+ retval))
+
+
+;;; Process/server management
+(defun eglot--major-modes (s) "Major modes server S is responsible for."
+ (mapcar #'car (eglot--languages s)))
+
+(defun eglot--language-ids (s) "LSP Language ID strings for server S's modes."
+ (mapcar #'cdr (eglot--languages s)))
+
(cl-defmethod initialize-instance :before ((_server eglot-lsp-server) &optional args)
(cl-remf args :initializationOptions))
-
-;;; Process management
(defvar eglot--servers-by-project (make-hash-table :test #'equal)
"Keys are projects. Values are lists of processes.")
@@ -916,7 +1168,7 @@ SERVER."
(unwind-protect
(progn
(setf (eglot--shutdown-requested server) t)
- (jsonrpc-request server :shutdown nil :timeout (or timeout 1.5))
+ (eglot--request server :shutdown nil :timeout (or timeout 1.5))
(jsonrpc-notify server :exit nil))
;; Now ask jsonrpc.el to shut down the server.
(jsonrpc-shutdown server (not preserve-buffers))
@@ -940,12 +1192,9 @@ PRESERVE-BUFFERS as in `eglot-shutdown', which see."
(eglot-autoshutdown nil))
(eglot--when-live-buffer buffer (eglot--managed-mode-off))))
;; Kill any expensive watches
- (maphash (lambda (_id watches)
- (mapcar #'file-notify-rm-watch watches))
+ (maphash (lambda (_dir watch-and-ids)
+ (file-notify-rm-watch (car watch-and-ids)))
(eglot--file-watches server))
- ;; Kill any autostarted inferior processes
- (when-let (proc (eglot--inferior-process server))
- (delete-process proc))
;; Sever the project/server relationship for `server'
(setf (gethash (eglot--project server) eglot--servers-by-project)
(delq server
@@ -974,45 +1223,48 @@ PRESERVE-BUFFERS as in `eglot-shutdown', which see."
(defun eglot--lookup-mode (mode)
"Lookup `eglot-server-programs' for MODE.
-Return (MANAGED-MODES LANGUAGE-ID CONTACT-PROXY).
+Return (LANGUAGES . CONTACT-PROXY).
MANAGED-MODES is a list with MODE as its first element.
Subsequent elements are other major modes also potentially
managed by the server that is to manage MODE.
-If not specified in `eglot-server-programs' (which see),
-LANGUAGE-ID is determined from MODE's name.
+LANGUAGE-IDS is a list of the same length as MANAGED-MODES. Each
+elem is derived from the corresponding mode name, if not
+specified in `eglot-server-programs' (which see).
CONTACT-PROXY is the value of the corresponding
`eglot-server-programs' entry."
- (cl-loop
- for (modes . contact) in eglot-server-programs
- for mode-symbols = (cons mode
- (delete mode
- (mapcar #'car
- (mapcar #'eglot--ensure-list
- (eglot--ensure-list modes)))))
- thereis (cl-some
- (lambda (spec)
- (cl-destructuring-bind (probe &key language-id &allow-other-keys)
- (eglot--ensure-list spec)
- (and (provided-mode-derived-p mode probe)
- (list
- mode-symbols
- (or language-id
- (or (get mode 'eglot-language-id)
- (get spec 'eglot-language-id)
- (string-remove-suffix "-mode" (symbol-name mode))))
- contact))))
- (if (or (symbolp modes) (keywordp (cadr modes)))
- (list modes) modes))))
+ (cl-flet ((languages (main-mode-sym specs)
+ (let* ((res
+ (mapcar (jsonrpc-lambda (sym &key language-id &allow-other-keys)
+ (cons sym
+ (or language-id
+ (or (get sym 'eglot-language-id)
+ (replace-regexp-in-string
+ "\\(?:-ts\\)?-mode$" ""
+ (symbol-name sym))))))
+ specs))
+ (head (cl-find main-mode-sym res :key #'car)))
+ (cons head (delq head res)))))
+ (cl-loop
+ for (modes . contact) in eglot-server-programs
+ for specs = (mapcar #'eglot--ensure-list
+ (if (or (symbolp modes) (keywordp (cadr modes)))
+ (list modes) modes))
+ thereis (cl-some (lambda (spec)
+ (cl-destructuring-bind (sym &key &allow-other-keys) spec
+ (and (provided-mode-derived-p mode sym)
+ (cons (languages sym specs) contact))))
+ specs))))
(defun eglot--guess-contact (&optional interactive)
"Helper for `eglot'.
-Return (MANAGED-MODE PROJECT CLASS CONTACT LANG-ID). If INTERACTIVE is
+Return (MANAGED-MODES PROJECT CLASS CONTACT LANG-IDS). If INTERACTIVE is
non-nil, maybe prompt user, else error as soon as something can't
be guessed."
- (let* ((guessed-mode (if buffer-file-name major-mode))
+ (let* ((project (eglot--current-project))
+ (guessed-mode (if buffer-file-name major-mode))
(guessed-mode-name (and guessed-mode (symbol-name guessed-mode)))
(main-mode
(cond
@@ -1027,13 +1279,14 @@ be guessed."
((not guessed-mode)
(eglot--error "Can't guess mode to manage for `%s'" (current-buffer)))
(t guessed-mode)))
- (triplet (eglot--lookup-mode main-mode))
- (managed-modes (car triplet))
- (language-id (or (cadr triplet)
- (string-remove-suffix "-mode" (symbol-name guessed-mode))))
- (guess (caddr triplet))
+ (languages-and-contact (eglot--lookup-mode main-mode))
+ (managed-modes (mapcar #'car (car languages-and-contact)))
+ (language-ids (mapcar #'cdr (car languages-and-contact)))
+ (guess (cdr languages-and-contact))
(guess (if (functionp guess)
- (funcall guess interactive)
+ (pcase (cdr (func-arity guess))
+ (1 (funcall guess interactive))
+ (_ (funcall guess interactive project)))
guess))
(class (or (and (consp guess) (symbolp (car guess))
(prog1 (unless current-prefix-arg (car guess))
@@ -1069,21 +1322,25 @@ be guessed."
"\n" base-prompt)
(eglot--error
(concat "`%s' not found in PATH, but can't form"
- " an interactive prompt for to fix %s!")
+ " an interactive prompt for help you fix"
+ " this.")
program guess))))))
+ (input (and prompt (read-shell-command prompt
+ full-program-invocation
+ 'eglot-command-history)))
(contact
- (or (and prompt
- (split-string-and-unquote
- (read-shell-command
- prompt
- full-program-invocation
- 'eglot-command-history)))
- guess)))
- (list managed-modes (eglot--current-project) class contact language-id)))
-
-(defvar eglot-lsp-context)
-(put 'eglot-lsp-context 'variable-documentation
- "Dynamically non-nil when searching for projects in LSP context.")
+ (if input
+ (if (string-match
+ "^[\s\t]*\\(.*\\):\\([[:digit:]]+\\)[\s\t]*$" input)
+ ;; <host>:<port> special case (bug#67682)
+ (list (match-string 1 input)
+ (string-to-number (match-string 2 input)))
+ (split-string-and-unquote input))
+ guess)))
+ (list managed-modes project class contact language-ids)))
+
+(defvar eglot-lsp-context nil
+ "Dynamically non-nil when searching for projects in LSP context.")
(defun eglot--current-project ()
"Return a project object for Eglot's LSP purposes.
@@ -1096,25 +1353,29 @@ suitable root directory for a given LSP server's purposes."
(or (project-current)
`(transient . ,(expand-file-name default-directory)))))
+(cl-defmethod project-root ((project (head eglot--project)))
+ (cadr project))
+
;;;###autoload
-(defun eglot (managed-major-mode project class contact language-id
+(defun eglot (managed-major-modes project class contact language-ids
&optional _interactive)
- "Start LSP server in support of PROJECT's buffers under MANAGED-MAJOR-MODE.
+ "Start LSP server for PROJECT's buffers under MANAGED-MAJOR-MODES.
-This starts a Language Server Protocol (LSP) server suitable for the
-buffers of PROJECT whose `major-mode' is MANAGED-MAJOR-MODE.
-CLASS is the class of the LSP server to start and CONTACT specifies
-how to connect to the server.
+This starts a Language Server Protocol (LSP) server suitable for
+the buffers of PROJECT whose `major-mode' is among
+MANAGED-MAJOR-MODES. CLASS is the class of the LSP server to
+start and CONTACT specifies how to connect to the server.
-Interactively, the command attempts to guess MANAGED-MAJOR-MODE
-from the current buffer's `major-mode', CLASS and CONTACT from
-`eglot-server-programs' looked up by the major mode, and PROJECT from
-`project-find-functions'. The search for active projects in this
-context binds `eglot-lsp-context' (which see).
+Interactively, the command attempts to guess MANAGED-MAJOR-MODES,
+CLASS, CONTACT, and LANGUAGE-IDS from `eglot-server-programs',
+according to the current buffer's `major-mode'. PROJECT is
+guessed from `project-find-functions'. The search for active
+projects in this context binds `eglot-lsp-context' (which see).
-If it can't guess, it prompts the user for the mode and the server.
-With a single \\[universal-argument] prefix arg, it always prompts for COMMAND.
-With two \\[universal-argument], it also always prompts for MANAGED-MAJOR-MODE.
+If it can't guess, it prompts the user for the mode and the
+server. With a single \\[universal-argument] prefix arg, it
+always prompts for COMMAND. With two \\[universal-argument], it
+also always prompts for MANAGED-MAJOR-MODE.
The LSP server of CLASS is started (or contacted) via CONTACT.
If this operation is successful, current *and future* file
@@ -1132,8 +1393,8 @@ CONTACT specifies how to contact the server. It is a
keyword-value plist used to initialize CLASS or a plain list as
described in `eglot-server-programs', which see.
-LANGUAGE-ID is the language ID string to send to the server for
-MANAGED-MAJOR-MODE, which matters to a minority of servers.
+LANGUAGE-IDS is a list of language ID string to send to the
+server for each element in MANAGED-MAJOR-MODES.
INTERACTIVE is ignored and provided for backward compatibility."
(interactive
@@ -1144,8 +1405,9 @@ INTERACTIVE is ignored and provided for backward compatibility."
(user-error "[eglot] Connection attempt aborted by user."))
(prog1 (append (eglot--guess-contact t) '(t))
(when current-server (ignore-errors (eglot-shutdown current-server))))))
- (eglot--connect (eglot--ensure-list managed-major-mode)
- project class contact language-id))
+ (eglot--connect (eglot--ensure-list managed-major-modes)
+ project class contact
+ (eglot--ensure-list language-ids)))
(defun eglot-reconnect (server &optional interactive)
"Reconnect to SERVER.
@@ -1157,14 +1419,25 @@ INTERACTIVE is t if called interactively."
(eglot--project server)
(eieio-object-class-name server)
(eglot--saved-initargs server)
- (eglot--language-id server))
+ (eglot--language-ids server))
(eglot--message "Reconnected!"))
(defvar eglot--managed-mode) ; forward decl
;;;###autoload
(defun eglot-ensure ()
- "Start Eglot session for current buffer if there isn't one."
+ "Start Eglot session for current buffer if there isn't one.
+
+Only use this function (in major mode hooks, etc) if you are
+confident that Eglot can be started safely and efficiently for
+*every* buffer visited where these hooks may execute.
+
+Since it is difficult to establish this confidence fully, it's
+often wise to use the interactive command `eglot' instead. This
+command only needs to be invoked once per project, as all other
+files of a given major mode visited within the same project will
+automatically become managed with no further user intervention
+needed."
(let ((buffer (current-buffer)))
(cl-labels
((maybe-connect
@@ -1172,7 +1445,9 @@ INTERACTIVE is t if called interactively."
(eglot--when-live-buffer buffer
(remove-hook 'post-command-hook #'maybe-connect t)
(unless eglot--managed-mode
- (apply #'eglot--connect (eglot--guess-contact))))))
+ (condition-case-unless-debug oops
+ (apply #'eglot--connect (eglot--guess-contact))
+ (error (eglot--warn (error-message-string oops))))))))
(when buffer-file-name
(add-hook 'post-command-hook #'maybe-connect 'append t)))))
@@ -1230,13 +1505,12 @@ Each function is passed the server as an argument")
(defvar-local eglot--cached-server nil
"A cached reference to the current Eglot server.")
-(defun eglot--connect (managed-modes project class contact language-id)
- "Connect to MANAGED-MODES, LANGUAGE-ID, PROJECT, CLASS and CONTACT.
+(defun eglot--connect (managed-modes project class contact language-ids)
+ "Connect to MANAGED-MODES, LANGUAGE-IDS, PROJECT, CLASS and CONTACT.
This docstring appeases checkdoc, that's all."
(let* ((default-directory (project-root project))
(nickname (project-name project))
(readable-name (format "EGLOT (%s/%s)" nickname managed-modes))
- autostart-inferior-process
server-info
(contact (if (functionp contact) (funcall contact) contact))
(initargs
@@ -1249,16 +1523,16 @@ This docstring appeases checkdoc, that's all."
readable-name nil
(car contact) (cadr contact)
(cddr contact)))))
- ((and (stringp (car contact)) (memq :autoport contact))
+ ((and (stringp (car contact))
+ (cl-find-if (lambda (x)
+ (or (eq x :autoport)
+ (eq (car-safe x) :autoport)))
+ contact))
(setq server-info (list "<inferior process>"))
- `(:process ,(lambda ()
- (pcase-let ((`(,connection . ,inferior)
- (eglot--inferior-bootstrap
+ `(:process ,(jsonrpc-autoport-bootstrap
readable-name
contact
- '(:noquery t))))
- (setq autostart-inferior-process inferior)
- connection))))
+ :connect-args '(:noquery t))))
((stringp (car contact))
(let* ((probe (cl-position-if #'keywordp contact))
(more-initargs (and probe (cl-subseq contact probe)))
@@ -1291,7 +1565,7 @@ This docstring appeases checkdoc, that's all."
(apply
#'make-instance class
:name readable-name
- :events-buffer-scrollback-size eglot-events-buffer-size
+ :events-buffer-config eglot-events-buffer-config
:notification-dispatcher (funcall spread #'eglot-handle-notification)
:request-dispatcher (funcall spread #'eglot-handle-request)
:on-shutdown #'eglot--on-shutdown
@@ -1304,9 +1578,9 @@ This docstring appeases checkdoc, that's all."
(setf (eglot--saved-initargs server) initargs)
(setf (eglot--project server) project)
(setf (eglot--project-nickname server) nickname)
- (setf (eglot--major-modes server) (eglot--ensure-list managed-modes))
- (setf (eglot--language-id server) language-id)
- (setf (eglot--inferior-process server) autostart-inferior-process)
+ (setf (eglot--languages server)
+ (cl-loop for m in managed-modes for l in language-ids
+ collect (cons m l)))
(run-hook-with-args 'eglot-server-initialized-hook server)
;; Now start the handshake. To honor `eglot-sync-connect'
;; maybe-sync-maybe-async semantics we use `jsonrpc-async-request'
@@ -1324,11 +1598,14 @@ This docstring appeases checkdoc, that's all."
(eq (jsonrpc-process-type server)
'network))
(emacs-pid))
+ :clientInfo
+ `(:name "Eglot" ,@(when eglot--version
+ `(:version ,eglot--version)))
;; Maybe turn trampy `/ssh:foo@bar:/path/to/baz.py'
;; into `/path/to/baz.py', so LSP groks it.
:rootPath (file-local-name
(expand-file-name default-directory))
- :rootUri (eglot--path-to-uri default-directory)
+ :rootUri (eglot-path-to-uri default-directory)
:initializationOptions (eglot-initialization-options
server)
:capabilities (eglot-client-capabilities server)
@@ -1396,55 +1673,6 @@ in project `%s'."
(quit (jsonrpc-shutdown server) (setq canceled 'quit)))
(setq tag nil))))
-(defun eglot--inferior-bootstrap (name contact &optional connect-args)
- "Use CONTACT to start a server, then connect to it.
-Return a cons of two process objects (CONNECTION . INFERIOR).
-Name both based on NAME.
-CONNECT-ARGS are passed as additional arguments to
-`open-network-stream'."
- (let* ((port-probe (make-network-process :name "eglot-port-probe-dummy"
- :server t
- :host "localhost"
- :service 0))
- (port-number (unwind-protect
- (process-contact port-probe :service)
- (delete-process port-probe)))
- inferior connection)
- (unwind-protect
- (progn
- (setq inferior
- (make-process
- :name (format "autostart-inferior-%s" name)
- :stderr (format "*%s stderr*" name)
- :noquery t
- :command (cl-subst
- (format "%s" port-number) :autoport contact)))
- (setq connection
- (cl-loop
- repeat 10 for i from 1
- do (accept-process-output nil 0.5)
- while (process-live-p inferior)
- do (eglot--message
- "Trying to connect to localhost and port %s (attempt %s)"
- port-number i)
- thereis (ignore-errors
- (apply #'open-network-stream
- (format "autoconnect-%s" name)
- nil
- "localhost" port-number connect-args))))
- (cons connection inferior))
- (cond ((and (process-live-p connection)
- (process-live-p inferior))
- (eglot--message "Done, connected to %s!" port-number))
- (t
- (when inferior (delete-process inferior))
- (when connection (delete-process connection))
- (eglot--error "Could not start and connect to server%s"
- (if inferior
- (format " started with %s"
- (process-command inferior))
- "!")))))))
-
;;; Helpers (move these to API?)
;;;
@@ -1468,16 +1696,21 @@ CONNECT-ARGS are passed as additional arguments to
(line-beginning-position n))))
"Return position of first character in current line.")
+(cl-defun eglot--request (server method params &key
+ immediate
+ timeout cancel-on-input
+ cancel-on-input-retval)
+ "Like `jsonrpc-request', but for Eglot LSP requests.
+Unless IMMEDIATE, send pending changes before making request."
+ (unless immediate (eglot--signal-textDocument/didChange))
+ (jsonrpc-request server method params
+ :timeout timeout
+ :cancel-on-input cancel-on-input
+ :cancel-on-input-retval cancel-on-input-retval))
+
;;; Encoding fever
;;;
-(define-obsolete-function-alias
- 'eglot-lsp-abiding-column 'eglot-utf-16-linepos "29.1")
-(define-obsolete-function-alias
- 'eglot-current-column 'eglot-utf-32-linepos "29.1")
-(define-obsolete-variable-alias
- 'eglot-current-column-function 'eglot-current-linepos-function "29.1")
-
(defvar eglot-current-linepos-function #'eglot-utf-16-linepos
"Function calculating position relative to line beginning.
@@ -1516,13 +1749,6 @@ LBP defaults to `eglot--bol'."
:character (progn (when pos (goto-char pos))
(funcall eglot-current-linepos-function)))))
-(define-obsolete-function-alias
- 'eglot-move-to-current-column 'eglot-move-to-utf-32-linepos "29.1")
-(define-obsolete-function-alias
- 'eglot-move-to-lsp-abiding-column 'eglot-move-to-utf-16-linepos "29.1")
-(define-obsolete-variable-alias
-'eglot-move-to-column-function 'eglot-move-to-linepos-function "29.1")
-
(defvar eglot-move-to-linepos-function #'eglot-move-to-utf-16-linepos
"Function to move to a position within a line reported by the LSP server.
@@ -1595,49 +1821,6 @@ If optional MARKER, return a marker instead"
vec)
"Like `url-path-allowed-chars' but more restrictive.")
-(defun eglot--path-to-uri (path)
- "URIfy PATH."
- (let ((truepath (file-truename path)))
- (if (and (url-type (url-generic-parse-url path))
- ;; It might be MS Windows path which includes a drive
- ;; letter that looks like a URL scheme (bug#59338)
- (not (and (eq system-type 'windows-nt)
- (file-name-absolute-p truepath))))
- ;; Path is already a URI, so forward it to the LSP server
- ;; untouched. The server should be able to handle it, since
- ;; it provided this URI to clients in the first place.
- path
- (concat "file://"
- ;; Add a leading "/" for local MS Windows-style paths.
- (if (and (eq system-type 'windows-nt)
- (not (file-remote-p truepath)))
- "/")
- (url-hexify-string
- ;; Again watch out for trampy paths.
- (directory-file-name (file-local-name truepath))
- eglot--uri-path-allowed-chars)))))
-
-(declare-function w32-long-file-name "w32proc.c" (fn))
-(defun eglot--uri-to-path (uri)
- "Convert URI to file path, helped by `eglot--current-server'."
- (when (keywordp uri) (setq uri (substring (symbol-name uri) 1)))
- (let* ((server (eglot-current-server))
- (remote-prefix (and server (eglot--trampish-p server)))
- (url (url-generic-parse-url uri)))
- ;; Only parse file:// URIs, leave other URI untouched as
- ;; `file-name-handler-alist' should know how to handle them
- ;; (bug#58790).
- (if (string= "file" (url-type url))
- (let* ((retval (url-unhex-string (url-filename url)))
- ;; Remove the leading "/" for local MS Windows-style paths.
- (normalized (if (and (not remote-prefix)
- (eq system-type 'windows-nt)
- (cl-plusp (length retval)))
- (w32-long-file-name (substring retval 1))
- retval)))
- (concat remote-prefix normalized))
- uri)))
-
(defun eglot--snippet-expansion-fn ()
"Compute a function to expand snippets.
Doubles as an indicator of snippet support."
@@ -1660,73 +1843,17 @@ Doubles as an indicator of snippet support."
(setq-local markdown-fontify-code-blocks-natively t)
(insert string)
(let ((inhibit-message t)
- (message-log-max nil))
- (ignore-errors (delay-mode-hooks (funcall mode))))
- (font-lock-ensure)
- (string-trim (buffer-string)))))
-
-(define-obsolete-variable-alias 'eglot-ignored-server-capabilites
- 'eglot-ignored-server-capabilities "1.8")
-
-(defcustom eglot-ignored-server-capabilities (list)
- "LSP server capabilities that Eglot could use, but won't.
-You could add, for instance, the symbol
-`:documentHighlightProvider' to prevent automatic highlighting
-under cursor."
- :type '(set
- :tag "Tick the ones you're not interested in"
- (const :tag "Documentation on hover" :hoverProvider)
- (const :tag "Code completion" :completionProvider)
- (const :tag "Function signature help" :signatureHelpProvider)
- (const :tag "Go to definition" :definitionProvider)
- (const :tag "Go to type definition" :typeDefinitionProvider)
- (const :tag "Go to implementation" :implementationProvider)
- (const :tag "Go to declaration" :declarationProvider)
- (const :tag "Find references" :referencesProvider)
- (const :tag "Highlight symbols automatically" :documentHighlightProvider)
- (const :tag "List symbols in buffer" :documentSymbolProvider)
- (const :tag "List symbols in workspace" :workspaceSymbolProvider)
- (const :tag "Execute code actions" :codeActionProvider)
- (const :tag "Code lens" :codeLensProvider)
- (const :tag "Format buffer" :documentFormattingProvider)
- (const :tag "Format portion of buffer" :documentRangeFormattingProvider)
- (const :tag "On-type formatting" :documentOnTypeFormattingProvider)
- (const :tag "Rename symbol" :renameProvider)
- (const :tag "Highlight links in document" :documentLinkProvider)
- (const :tag "Decorate color references" :colorProvider)
- (const :tag "Fold regions of buffer" :foldingRangeProvider)
- (const :tag "Execute custom commands" :executeCommandProvider)
- (const :tag "Inlay hints" :inlayHintProvider)))
-
-(defun eglot--server-capable (&rest feats)
- "Determine if current server is capable of FEATS."
- (unless (cl-some (lambda (feat)
- (memq feat eglot-ignored-server-capabilities))
- feats)
- (cl-loop for caps = (eglot--capabilities (eglot--current-server-or-lose))
- then (cadr probe)
- for (feat . more) on feats
- for probe = (plist-member caps feat)
- if (not probe) do (cl-return nil)
- if (eq (cadr probe) :json-false) do (cl-return nil)
- if (not (listp (cadr probe))) do (cl-return (if more nil (cadr probe)))
- finally (cl-return (or (cadr probe) t)))))
-
-(defun eglot--server-capable-or-lose (&rest feats)
- "Like `eglot--server-capable', but maybe error out."
- (let ((retval (apply #'eglot--server-capable feats)))
- (unless retval
- (eglot--error "Unsupported or ignored LSP capability `%s'"
- (mapconcat #'symbol-name feats " ")))
- retval))
-
-(defun eglot--range-region (range &optional markers)
- "Return region (BEG . END) that represents LSP RANGE.
-If optional MARKERS, make markers."
- (let* ((st (plist-get range :start))
- (beg (eglot--lsp-position-to-point st markers))
- (end (eglot--lsp-position-to-point (plist-get range :end) markers)))
- (cons beg end)))
+ (message-log-max nil)
+ match)
+ (ignore-errors (delay-mode-hooks (funcall mode)))
+ (font-lock-ensure)
+ (goto-char (point-min))
+ (let ((inhibit-read-only t))
+ (when (fboundp 'text-property-search-forward) ;; FIXME: use compat
+ (while (setq match (text-property-search-forward 'invisible))
+ (delete-region (prop-match-beginning match)
+ (prop-match-end match)))))
+ (string-trim (buffer-string))))))
(defun eglot--read-server (prompt &optional dont-if-just-the-one)
"Read a running Eglot server from minibuffer using PROMPT.
@@ -1761,9 +1888,9 @@ and just return it. PROMPT shouldn't end with a question mark."
(defun eglot--plist-keys (plist) "Get keys of a plist."
(cl-loop for (k _v) on plist by #'cddr collect k))
-(defun eglot--ensure-list (x) (if (listp x) x (list x)))
-(when (fboundp 'ensure-list) ; Emacs 28 or later
- (define-obsolete-function-alias 'eglot--ensure-list #'ensure-list "29.1"))
+(defalias 'eglot--ensure-list
+ (if (fboundp 'ensure-list) #'ensure-list
+ (lambda (x) (if (listp x) x (list x)))))
;;; Minor modes
@@ -1832,21 +1959,23 @@ Use `eglot-managed-p' to determine if current buffer is managed.")
("utf-8"
(eglot--setq-saving eglot-current-linepos-function #'eglot-utf-8-linepos)
(eglot--setq-saving eglot-move-to-linepos-function #'eglot-move-to-utf-8-linepos)))
- (add-hook 'after-change-functions 'eglot--after-change nil t)
- (add-hook 'before-change-functions 'eglot--before-change nil t)
+ (add-hook 'after-change-functions #'eglot--after-change nil t)
+ (add-hook 'before-change-functions #'eglot--before-change nil t)
(add-hook 'kill-buffer-hook #'eglot--managed-mode-off nil t)
;; Prepend "didClose" to the hook after the "nonoff", so it will run first
- (add-hook 'kill-buffer-hook 'eglot--signal-textDocument/didClose nil t)
- (add-hook 'before-revert-hook 'eglot--signal-textDocument/didClose nil t)
- (add-hook 'after-revert-hook 'eglot--after-revert-hook nil t)
- (add-hook 'before-save-hook 'eglot--signal-textDocument/willSave nil t)
- (add-hook 'after-save-hook 'eglot--signal-textDocument/didSave nil t)
+ (add-hook 'kill-buffer-hook #'eglot--signal-textDocument/didClose nil t)
+ (add-hook 'before-revert-hook #'eglot--signal-textDocument/didClose nil t)
+ (add-hook 'after-revert-hook #'eglot--after-revert-hook nil t)
+ (add-hook 'before-save-hook #'eglot--signal-textDocument/willSave nil t)
+ (add-hook 'after-save-hook #'eglot--signal-textDocument/didSave nil t)
(unless (eglot--stay-out-of-p 'xref)
- (add-hook 'xref-backend-functions 'eglot-xref-backend nil t))
+ (add-hook 'xref-backend-functions #'eglot-xref-backend nil t))
(add-hook 'completion-at-point-functions #'eglot-completion-at-point nil t)
+ (add-hook 'completion-in-region-mode-hook #'eglot--capf-session-flush nil t)
+ (add-hook 'company-after-completion-hook #'eglot--capf-session-flush nil t)
(add-hook 'change-major-mode-hook #'eglot--managed-mode-off nil t)
- (add-hook 'post-self-insert-hook 'eglot--post-self-insert-hook nil t)
- (add-hook 'pre-command-hook 'eglot--pre-command-hook nil t)
+ (add-hook 'post-self-insert-hook #'eglot--post-self-insert-hook nil t)
+ (add-hook 'pre-command-hook #'eglot--pre-command-hook nil t)
(eglot--setq-saving xref-prompt-for-identifier nil)
(eglot--setq-saving flymake-diagnostic-functions '(eglot-flymake-backend))
(eglot--setq-saving company-backends '(company-capf))
@@ -1865,19 +1994,21 @@ Use `eglot-managed-p' to determine if current buffer is managed.")
(eldoc-mode 1))
(cl-pushnew (current-buffer) (eglot--managed-buffers (eglot-current-server))))
(t
- (remove-hook 'after-change-functions 'eglot--after-change t)
- (remove-hook 'before-change-functions 'eglot--before-change t)
+ (remove-hook 'after-change-functions #'eglot--after-change t)
+ (remove-hook 'before-change-functions #'eglot--before-change t)
(remove-hook 'kill-buffer-hook #'eglot--managed-mode-off t)
- (remove-hook 'kill-buffer-hook 'eglot--signal-textDocument/didClose t)
- (remove-hook 'before-revert-hook 'eglot--signal-textDocument/didClose t)
- (remove-hook 'after-revert-hook 'eglot--after-revert-hook t)
- (remove-hook 'before-save-hook 'eglot--signal-textDocument/willSave t)
- (remove-hook 'after-save-hook 'eglot--signal-textDocument/didSave t)
- (remove-hook 'xref-backend-functions 'eglot-xref-backend t)
+ (remove-hook 'kill-buffer-hook #'eglot--signal-textDocument/didClose t)
+ (remove-hook 'before-revert-hook #'eglot--signal-textDocument/didClose t)
+ (remove-hook 'after-revert-hook #'eglot--after-revert-hook t)
+ (remove-hook 'before-save-hook #'eglot--signal-textDocument/willSave t)
+ (remove-hook 'after-save-hook #'eglot--signal-textDocument/didSave t)
+ (remove-hook 'xref-backend-functions #'eglot-xref-backend t)
(remove-hook 'completion-at-point-functions #'eglot-completion-at-point t)
+ (remove-hook 'completion-in-region-mode-hook #'eglot--capf-session-flush t)
+ (remove-hook 'company-after-completion-hook #'eglot--capf-session-flush t)
(remove-hook 'change-major-mode-hook #'eglot--managed-mode-off t)
- (remove-hook 'post-self-insert-hook 'eglot--post-self-insert-hook t)
- (remove-hook 'pre-command-hook 'eglot--pre-command-hook t)
+ (remove-hook 'post-self-insert-hook #'eglot--post-self-insert-hook t)
+ (remove-hook 'pre-command-hook #'eglot--pre-command-hook t)
(remove-hook 'eldoc-documentation-functions #'eglot-hover-eldoc-function t)
(remove-hook 'eldoc-documentation-functions #'eglot-signature-eldoc-function t)
(cl-loop for (var . saved-binding) in eglot--saved-bindings
@@ -1905,14 +2036,15 @@ Use `eglot-managed-p' to determine if current buffer is managed.")
"Return logical Eglot server for current buffer, nil if none."
(setq eglot--cached-server
(or eglot--cached-server
- (cl-find major-mode
- (gethash (eglot--current-project) eglot--servers-by-project)
- :key #'eglot--major-modes
- :test #'memq)
- (and eglot-extend-to-xref
- buffer-file-name
- (gethash (expand-file-name buffer-file-name)
- eglot--servers-by-xrefed-file)))))
+ (and (not (eq major-mode 'fundamental-mode)) ; gh#1330
+ (or
+ (cl-find-if #'eglot--languageId
+ (gethash (eglot--current-project)
+ eglot--servers-by-project))
+ (and eglot-extend-to-xref
+ buffer-file-name
+ (gethash (expand-file-name buffer-file-name)
+ eglot--servers-by-xrefed-file)))))))
(defun eglot--current-server-or-lose ()
"Return current logical Eglot server connection or error."
@@ -1943,7 +2075,7 @@ If it is activated, also signal textDocument/didOpen."
(eglot-inlay-hints-mode 1)
(run-hooks 'eglot-managed-mode-hook))))
-(add-hook 'after-change-major-mode-hook 'eglot--maybe-activate-editing-mode)
+(add-hook 'after-change-major-mode-hook #'eglot--maybe-activate-editing-mode)
(defun eglot-clear-status (server)
"Clear the last JSONRPC error for SERVER."
@@ -1969,8 +2101,8 @@ If it is activated, also signal textDocument/didOpen."
(when update-mode-line
(force-mode-line-update t)))))))
-(defun eglot-manual () "Open documentation."
- (declare (obsolete info "29.1"))
+(defun eglot-manual () "Read Eglot's manual."
+ (declare (obsolete info "1.10"))
(interactive) (info "(eglot)"))
;;;###autoload
@@ -1983,9 +2115,6 @@ If it is activated, also signal textDocument/didOpen."
(package-delete existing t))
(package-install (cadr (assoc 'eglot package-archive-contents)))))
-;;;###autoload
-(define-obsolete-function-alias 'eglot-update 'eglot-upgrade-eglot "29.1")
-
(easy-menu-define eglot-menu nil "Eglot"
`("Eglot"
;; Commands for getting information and customization.
@@ -1994,47 +2123,47 @@ If it is activated, also signal textDocument/didOpen."
;; xref like commands.
["Find definitions" xref-find-definitions
:help "Find definitions of identifier at point"
- :active (eglot--server-capable :definitionProvider)]
+ :active (eglot-server-capable :definitionProvider)]
["Find references" xref-find-references
:help "Find references to identifier at point"
- :active (eglot--server-capable :referencesProvider)]
+ :active (eglot-server-capable :referencesProvider)]
["Find symbols in workspace (apropos)" xref-find-apropos
:help "Find symbols matching a query"
- :active (eglot--server-capable :workspaceSymbolProvider)]
+ :active (eglot-server-capable :workspaceSymbolProvider)]
["Find declaration" eglot-find-declaration
:help "Find declaration for identifier at point"
- :active (eglot--server-capable :declarationProvider)]
+ :active (eglot-server-capable :declarationProvider)]
["Find implementation" eglot-find-implementation
:help "Find implementation for identifier at point"
- :active (eglot--server-capable :implementationProvider)]
+ :active (eglot-server-capable :implementationProvider)]
["Find type definition" eglot-find-typeDefinition
:help "Find type definition for identifier at point"
- :active (eglot--server-capable :typeDefinitionProvider)]
+ :active (eglot-server-capable :typeDefinitionProvider)]
"--"
;; LSP-related commands (mostly Eglot's own commands).
["Rename symbol" eglot-rename
- :active (eglot--server-capable :renameProvider)]
+ :active (eglot-server-capable :renameProvider)]
["Format buffer" eglot-format-buffer
- :active (eglot--server-capable :documentFormattingProvider)]
+ :active (eglot-server-capable :documentFormattingProvider)]
["Format active region" eglot-format
:active (and (region-active-p)
- (eglot--server-capable :documentRangeFormattingProvider))]
+ (eglot-server-capable :documentRangeFormattingProvider))]
["Show Flymake diagnostics for buffer" flymake-show-buffer-diagnostics]
["Show Flymake diagnostics for project" flymake-show-project-diagnostics]
["Show Eldoc documentation at point" eldoc-doc-buffer]
"--"
["All possible code actions" eglot-code-actions
- :active (eglot--server-capable :codeActionProvider)]
+ :active (eglot-server-capable :codeActionProvider)]
["Organize imports" eglot-code-action-organize-imports
- :visible (eglot--server-capable :codeActionProvider)]
+ :visible (eglot-server-capable :codeActionProvider)]
["Extract" eglot-code-action-extract
- :visible (eglot--server-capable :codeActionProvider)]
+ :visible (eglot-server-capable :codeActionProvider)]
["Inline" eglot-code-action-inline
- :visible (eglot--server-capable :codeActionProvider)]
+ :visible (eglot-server-capable :codeActionProvider)]
["Rewrite" eglot-code-action-rewrite
- :visible (eglot--server-capable :codeActionProvider)]
+ :visible (eglot-server-capable :codeActionProvider)]
["Quickfix" eglot-code-action-quickfix
- :visible (eglot--server-capable :codeActionProvider)]))
+ :visible (eglot-server-capable :codeActionProvider)]))
(easy-menu-define eglot-server-menu nil "Monitor server communication"
'("Debugging the server communication"
@@ -2063,11 +2192,10 @@ Uses THING, FACE, DEFS and PREPEND."
mouse-face mode-line-highlight))))
(defun eglot--mode-line-format ()
- "Compose the Eglot's mode-line."
+ "Compose Eglot's mode-line."
(let* ((server (eglot-current-server))
(nick (and server (eglot-project-nickname server)))
- (pending (and server (hash-table-count
- (jsonrpc--request-continuations server))))
+ (pending (and server (jsonrpc-continuation-count server)))
(last-error (and server (jsonrpc-last-error server))))
(append
`(,(propertize
@@ -2100,7 +2228,15 @@ Uses THING, FACE, DEFS and PREPEND."
'((mouse-3 eglot-forget-pending-continuations
"Forget pending continuations"))
"Number of outgoing, \
-still unanswered LSP requests to the server\n"))))))))
+still unanswered LSP requests to the server\n")))
+ ,@(cl-loop for pr hash-values of (eglot--progress-reporters server)
+ when (eq (car pr) 'eglot--mode-line-reporter)
+ append `("/" ,(eglot--mode-line-props
+ (format "%s%%%%" (or (nth 4 pr) "?"))
+ 'eglot-mode-line
+ nil
+ (format "(%s) %s %s" (nth 1 pr)
+ (nth 2 pr) (nth 3 pr))))))))))
(add-to-list 'mode-line-misc-info
`(eglot--managed-mode (" [" eglot--mode-line-format "] ")))
@@ -2112,12 +2248,12 @@ still unanswered LSP requests to the server\n"))))))))
(put 'eglot-warning 'flymake-category 'flymake-warning)
(put 'eglot-error 'flymake-category 'flymake-error)
-(defalias 'eglot--make-diag 'flymake-make-diagnostic)
-(defalias 'eglot--diag-data 'flymake-diagnostic-data)
+(defalias 'eglot--make-diag #'flymake-make-diagnostic)
+(defalias 'eglot--diag-data #'flymake-diagnostic-data)
(defvar eglot-diagnostics-map
(let ((map (make-sparse-keymap)))
- (define-key map [mouse-2] 'eglot-code-actions-at-mouse)
+ (define-key map [mouse-2] #'eglot-code-actions-at-mouse)
map)
"Keymap active in Eglot-backed Flymake diagnostic overlays.")
@@ -2144,13 +2280,6 @@ still unanswered LSP requests to the server\n"))))))))
(when (memq 'disallow-unknown-methods eglot-strict-mode)
(jsonrpc-error "Unknown request method `%s'" method)))
-(cl-defmethod eglot-execute-command
- (server command arguments)
- "Execute COMMAND on SERVER with `:workspace/executeCommand'.
-COMMAND is a symbol naming the command."
- (jsonrpc-request server :workspace/executeCommand
- `(:command ,(format "%s" command) :arguments ,arguments)))
-
(cl-defmethod eglot-handle-notification
(_server (_method (eql window/showMessage)) &key type message)
"Handle notification window/showMessage."
@@ -2159,13 +2288,14 @@ COMMAND is a symbol naming the command."
type message))
(cl-defmethod eglot-handle-request
- (_server (_method (eql window/showMessageRequest)) &key type message actions)
+ (_server (_method (eql window/showMessageRequest))
+ &key type message actions &allow-other-keys)
"Handle server request window/showMessageRequest."
(let* ((actions (append actions nil)) ;; gh#627
(label (completing-read
(concat
(format (propertize "[eglot] Server reports (type=%s): %s"
- 'face (if (<= type 1) 'error))
+ 'face (if (or (not type) (<= type 1)) 'error))
type message)
"\nChoose an option: ")
(or (mapcar (lambda (obj) (plist-get obj :title)) actions)
@@ -2181,28 +2311,39 @@ COMMAND is a symbol naming the command."
(_server (_method (eql telemetry/event)) &rest _any)
"Handle notification telemetry/event.") ;; noop, use events buffer
+(defalias 'eglot--reporter-update
+ (if (> emacs-major-version 26) #'progress-reporter-update
+ (lambda (a b &optional _c) (progress-reporter-update a b))))
+
(cl-defmethod eglot-handle-notification
(server (_method (eql $/progress)) &key token value)
"Handle $/progress notification identified by TOKEN from SERVER."
(when eglot-report-progress
(cl-flet ((fmt (&rest args) (mapconcat #'identity args " "))
+ (mkpr (title)
+ (if (eq eglot-report-progress 'messages)
+ (make-progress-reporter
+ (format "[eglot] %s %s: %s"
+ (eglot-project-nickname server) token title))
+ (list 'eglot--mode-line-reporter token title)))
(upd (pcnt msg &optional
(pr (gethash token (eglot--progress-reporters server))))
- (when pr (progress-reporter-update pr pcnt msg))))
+ (cond
+ ((eq (car pr) 'eglot--mode-line-reporter)
+ (setcdr (cddr pr) (list msg pcnt))
+ (force-mode-line-update t))
+ (pr (eglot--reporter-update pr pcnt msg)))))
(eglot--dbind ((WorkDoneProgress) kind title percentage message) value
(pcase kind
("begin"
- (let ((prefix (format (concat "[eglot] %s %s:" (when percentage " "))
- (eglot-project-nickname server) token)))
- (upd percentage (fmt title message)
- (puthash token
- (if percentage
- (make-progress-reporter prefix 0 100 percentage 1 0)
- (make-progress-reporter prefix nil nil nil 1 0))
- (eglot--progress-reporters server)))))
- ("report" (upd percentage (fmt title message)))
- ("end" (upd (or percentage 100) (fmt title message))
- (remhash token (eglot--progress-reporters server))))))))
+ (upd percentage (fmt title message)
+ (puthash token (mkpr title)
+ (eglot--progress-reporters server))))
+ ("report" (upd percentage message))
+ ("end" (upd (or percentage 100) message)
+ (run-at-time 2 nil
+ (lambda ()
+ (remhash token (eglot--progress-reporters server))))))))))
(cl-defmethod eglot-handle-notification
(_server (_method (eql textDocument/publishDiagnostics)) &key uri diagnostics
@@ -2215,17 +2356,19 @@ COMMAND is a symbol naming the command."
(t 'eglot-note)))
(mess (source code message)
(concat source (and code (format " [%s]" code)) ": " message)))
- (if-let* ((path (expand-file-name (eglot--uri-to-path uri)))
+ (if-let* ((path (expand-file-name (eglot-uri-to-path uri)))
(buffer (find-buffer-visiting path)))
(with-current-buffer buffer
(cl-loop
- initially (assoc-delete-all path flymake-list-only-diagnostics #'string=)
+ initially
+ (setq flymake-list-only-diagnostics
+ (assoc-delete-all path flymake-list-only-diagnostics))
for diag-spec across diagnostics
collect (eglot--dbind ((Diagnostic) range code message severity source tags)
diag-spec
(setq message (mess source code message))
(pcase-let
- ((`(,beg . ,end) (eglot--range-region range)))
+ ((`(,beg . ,end) (eglot-range-region range)))
;; Fallback to `flymake-diag-region' if server
;; botched the range
(when (= beg end)
@@ -2273,7 +2416,7 @@ COMMAND is a symbol naming the command."
into diags
finally
(setq flymake-list-only-diagnostics
- (assoc-delete-all path flymake-list-only-diagnostics #'string=))
+ (assoc-delete-all path flymake-list-only-diagnostics))
(push (cons path diags) flymake-list-only-diagnostics)))))
(cl-defun eglot--register-unregister (server things how)
@@ -2301,7 +2444,7 @@ THINGS are either registrations or unregisterations (sic)."
(cl-defmethod eglot-handle-request
(_server (_method (eql workspace/applyEdit)) &key _label edit)
"Handle server request workspace/applyEdit."
- (eglot--apply-workspace-edit edit eglot-confirm-server-initiated-edits)
+ (eglot--apply-workspace-edit edit last-command)
`(:applied t))
(cl-defmethod eglot-handle-request
@@ -2309,9 +2452,39 @@ THINGS are either registrations or unregisterations (sic)."
"Handle server request workspace/workspaceFolders."
(eglot-workspace-folders server))
+(cl-defmethod eglot-handle-request
+ (_server (_method (eql window/showDocument)) &key
+ uri external takeFocus selection)
+ "Handle request window/showDocument."
+ (let ((success t)
+ (filename))
+ (cond
+ ((eq external t) (browse-url uri))
+ ((file-readable-p (setq filename (eglot-uri-to-path uri)))
+ ;; Use run-with-timer to avoid nested client requests like the
+ ;; "synchronous imenu" floated in bug#62116 presumably caused by
+ ;; which-func-mode.
+ (run-with-timer
+ 0 nil
+ (lambda ()
+ (with-current-buffer (find-file-noselect filename)
+ (cond (takeFocus
+ (pop-to-buffer (current-buffer))
+ (select-frame-set-input-focus (selected-frame)))
+ ((display-buffer (current-buffer))))
+ (when selection
+ (pcase-let ((`(,beg . ,end) (eglot-range-region selection)))
+ ;; FIXME: it is very naughty to use someone else's `--'
+ ;; function, but `xref--goto-char' happens to have
+ ;; exactly the semantics we want vis-a-vis widening.
+ (xref--goto-char beg)
+ (pulse-momentary-highlight-region beg end 'highlight)))))))
+ (t (setq success :json-false)))
+ `(:success ,success)))
+
(defun eglot--TextDocumentIdentifier ()
"Compute TextDocumentIdentifier object for current buffer."
- `(:uri ,(eglot--path-to-uri (or buffer-file-name
+ `(:uri ,(eglot-path-to-uri (or buffer-file-name
(ignore-errors
(buffer-file-name
(buffer-base-buffer)))))))
@@ -2323,12 +2496,20 @@ THINGS are either registrations or unregisterations (sic)."
(append (eglot--TextDocumentIdentifier)
`(:version ,eglot--versioned-identifier)))
+(cl-defun eglot--languageId (&optional (server (eglot--current-server-or-lose)))
+ "Compute LSP \\='languageId\\=' string for current buffer.
+Doubles as an predicate telling if SERVER can manage current
+buffer."
+ (cl-loop for (mode . languageid) in
+ (eglot--languages server)
+ when (provided-mode-derived-p major-mode mode)
+ return languageid))
+
(defun eglot--TextDocumentItem ()
"Compute TextDocumentItem object for current buffer."
(append
(eglot--VersionedTextDocumentIdentifier)
- (list :languageId
- (eglot--language-id (eglot--current-server-or-lose))
+ (list :languageId (eglot--languageId)
:text
(eglot--widening
(buffer-substring-no-properties (point-min) (point-max))))))
@@ -2343,16 +2524,16 @@ THINGS are either registrations or unregisterations (sic)."
(defun eglot--post-self-insert-hook ()
"Set `eglot--last-inserted-char', maybe call on-type-formatting."
- (setq eglot--last-inserted-char last-input-event)
- (let ((ot-provider (eglot--server-capable :documentOnTypeFormattingProvider)))
+ (setq eglot--last-inserted-char last-command-event)
+ (let ((ot-provider (eglot-server-capable :documentOnTypeFormattingProvider)))
(when (and ot-provider
(ignore-errors ; github#906, some LS's send empty strings
- (or (eq last-input-event
+ (or (eq eglot--last-inserted-char
(seq-first (plist-get ot-provider :firstTriggerCharacter)))
- (cl-find last-input-event
+ (cl-find eglot--last-inserted-char
(plist-get ot-provider :moreTriggerCharacter)
:key #'seq-first))))
- (eglot-format (point) nil last-input-event))))
+ (eglot-format (point) nil eglot--last-inserted-char))))
(defvar eglot--workspace-symbols-cache (make-hash-table :test #'equal)
"Cache of `workspace/Symbol' results used by `xref-find-definitions'.")
@@ -2368,7 +2549,7 @@ THINGS are either registrations or unregisterations (sic)."
`(:context
,(if-let (trigger (and (characterp eglot--last-inserted-char)
(cl-find eglot--last-inserted-char
- (eglot--server-capable :completionProvider
+ (eglot-server-capable :completionProvider
:triggerCharacters)
:key (lambda (str) (aref str 0))
:test #'char-equal)))
@@ -2441,16 +2622,6 @@ Records BEG, END and PRE-CHANGE-LENGTH locally."
(run-hooks 'eglot--document-changed-hook)
(setq eglot--change-idle-timer nil))))))))
-;; HACK! Launching a deferred sync request with outstanding changes is a
-;; bad idea, since that might lead to the request never having a
-;; chance to run, because `jsonrpc-connection-ready-p'.
-(advice-add #'jsonrpc-request :before
- (cl-function (lambda (_proc _method _params &key
- deferred &allow-other-keys)
- (when (and eglot--managed-mode deferred)
- (eglot--signal-textDocument/didChange))))
- '((name . eglot--signal-textDocument/didChange)))
-
(defvar-local eglot-workspace-configuration ()
"Configure LSP servers specifically for a given project.
@@ -2480,7 +2651,7 @@ root of the current project. It should return an object of the
format described above.")
;;;###autoload
-(put 'eglot-workspace-configuration 'safe-local-variable 'listp)
+(put 'eglot-workspace-configuration 'safe-local-variable #'listp)
(defun eglot-show-workspace-configuration (&optional server)
"Dump `eglot-workspace-configuration' as JSON for debugging."
@@ -2502,8 +2673,10 @@ local value of the `eglot-workspace-configuration' variable, else
use the root of SERVER's `eglot--project'."
(let ((val (with-temp-buffer
(setq default-directory
- (if path
- (file-name-directory path)
+ ;; See github#1281
+ (if path (if (file-directory-p path)
+ (file-name-as-directory path)
+ (file-name-directory path))
(project-root (eglot--project server))))
;; Set the major mode to be the first of the managed
;; modes. This is the one the user started eglot in.
@@ -2537,7 +2710,7 @@ When called interactively, use the currently active server"
(mapcar
(eglot--lambda ((ConfigurationItem) scopeUri section)
(cl-loop
- with scope-uri-path = (and scopeUri (eglot--uri-to-path scopeUri))
+ with scope-uri-path = (and scopeUri (eglot-uri-to-path scopeUri))
for (wsection o)
on (eglot--workspace-configuration-plist server scope-uri-path)
by #'cddr
@@ -2553,7 +2726,7 @@ When called interactively, use the currently active server"
"Send textDocument/didChange to server."
(when eglot--recent-changes
(let* ((server (eglot--current-server-or-lose))
- (sync-capability (eglot--server-capable :textDocumentSync))
+ (sync-capability (eglot-server-capable :textDocumentSync))
(sync-kind (if (numberp sync-capability) sync-capability
(plist-get sync-capability :change)))
(full-sync-p (or (eq sync-kind 1)
@@ -2598,18 +2771,18 @@ When called interactively, use the currently active server"
"Maybe send textDocument/willSave to server."
(let ((server (eglot--current-server-or-lose))
(params `(:reason 1 :textDocument ,(eglot--TextDocumentIdentifier))))
- (when (eglot--server-capable :textDocumentSync :willSave)
+ (when (eglot-server-capable :textDocumentSync :willSave)
(jsonrpc-notify server :textDocument/willSave params))
- (when (eglot--server-capable :textDocumentSync :willSaveWaitUntil)
+ (when (eglot-server-capable :textDocumentSync :willSaveWaitUntil)
(ignore-errors
(eglot--apply-text-edits
- (jsonrpc-request server :textDocument/willSaveWaitUntil params
- :timeout 0.5))))))
+ (eglot--request server :textDocument/willSaveWaitUntil params
+ :timeout 0.5))))))
(defun eglot--signal-textDocument/didSave ()
"Maybe send textDocument/didSave to server."
(eglot--signal-textDocument/didChange)
- (when (eglot--server-capable :textDocumentSync :save)
+ (when (eglot-server-capable :textDocumentSync :save)
(jsonrpc-notify
(eglot--current-server-or-lose)
:textDocument/didSave
@@ -2668,12 +2841,12 @@ may be called multiple times (respecting the protocol of
"Like `xref-make-match' but with LSP's NAME, URI and RANGE.
Try to visit the target file for a richer summary line."
(pcase-let*
- ((file (eglot--uri-to-path uri))
+ ((file (eglot-uri-to-path uri))
(visiting (or (find-buffer-visiting file)
(gethash uri eglot--temp-location-buffers)))
(collect (lambda ()
(eglot--widening
- (pcase-let* ((`(,beg . ,end) (eglot--range-region range))
+ (pcase-let* ((`(,beg . ,end) (eglot-range-region range))
(bol (progn (goto-char beg) (eglot--bol)))
(substring (buffer-substring bol (line-end-position)))
(hi-beg (- beg bol))
@@ -2704,7 +2877,7 @@ Try to visit the target file for a richer summary line."
"Ask for :workspace/symbol on PAT, return list of formatted strings.
If BUFFER, switch to it before."
(with-current-buffer (or buffer (current-buffer))
- (eglot--server-capable-or-lose :workspaceSymbolProvider)
+ (eglot-server-capable-or-lose :workspaceSymbolProvider)
(mapcar
(lambda (wss)
(eglot--dbind ((WorkspaceSymbol) name containerName kind) wss
@@ -2716,8 +2889,8 @@ If BUFFER, switch to it before."
(propertize (alist-get kind eglot--symbol-kind-names "Unknown")
'face 'shadow))
'eglot--lsp-workspaceSymbol wss)))
- (jsonrpc-request (eglot--current-server-or-lose) :workspace/symbol
- `(:query ,pat)))))
+ (eglot--request (eglot--current-server-or-lose) :workspace/symbol
+ `(:query ,pat)))))
(cl-defmethod xref-backend-identifier-completion-table ((_backend (eql eglot)))
"Yet another tricky connection between LSP and Elisp completion semantics."
@@ -2766,14 +2939,14 @@ If BUFFER, switch to it before."
(cl-defun eglot--lsp-xrefs-for-method (method &key extra-params capability)
"Make `xref''s for METHOD, EXTRA-PARAMS, check CAPABILITY."
- (eglot--server-capable-or-lose
+ (eglot-server-capable-or-lose
(or capability
(intern
(format ":%sProvider"
(cadr (split-string (symbol-name method)
"/"))))))
(let ((response
- (jsonrpc-request
+ (eglot--request
(eglot--current-server-or-lose)
method (append (eglot--TextDocumentPositionParams) extra-params))))
(eglot--collecting-xrefs (collect)
@@ -2830,15 +3003,15 @@ If BUFFER, switch to it before."
:textDocument/references :extra-params `(:context (:includeDeclaration t)))))
(cl-defmethod xref-backend-apropos ((_backend (eql eglot)) pattern)
- (when (eglot--server-capable :workspaceSymbolProvider)
+ (when (eglot-server-capable :workspaceSymbolProvider)
(eglot--collecting-xrefs (collect)
(mapc
(eglot--lambda ((SymbolInformation) name location)
(eglot--dbind ((Location) uri range) location
(collect (eglot--xref-make-match name uri range))))
- (jsonrpc-request (eglot--current-server-or-lose)
- :workspace/symbol
- `(:query ,pattern))))))
+ (eglot--request (eglot--current-server-or-lose)
+ :workspace/symbol
+ `(:query ,pattern))))))
(defun eglot-format-buffer ()
"Format contents of current buffer."
@@ -2868,9 +3041,9 @@ for which LSP on-type-formatting should be requested."
:end (eglot--pos-to-lsp-position end)))))
(t
'(:textDocument/formatting :documentFormattingProvider nil)))))
- (eglot--server-capable-or-lose cap)
+ (eglot-server-capable-or-lose cap)
(eglot--apply-text-edits
- (jsonrpc-request
+ (eglot--request
(eglot--current-server-or-lose)
method
(cl-list*
@@ -2879,14 +3052,49 @@ for which LSP on-type-formatting should be requested."
:insertSpaces (if indent-tabs-mode :json-false t)
:insertFinalNewline (if require-final-newline t :json-false)
:trimFinalNewlines (if delete-trailing-lines t :json-false))
- args)
- :deferred method))))
+ args))
+ nil
+ on-type-format)))
+
+(defvar eglot-cache-session-completions t
+ "If non-nil Eglot caches data during completion sessions.")
+
+(defvar eglot--capf-session :none "A cache used by `eglot-completion-at-point'.")
+
+(defun eglot--capf-session-flush (&optional _) (setq eglot--capf-session :none))
+
+(defun eglot--dumb-flex (pat comp ignorecase)
+ "Return destructively fontified COMP iff PAT matches it."
+ (cl-loop with lcomp = (length comp)
+ with case-fold-search = ignorecase
+ initially (remove-list-of-text-properties 0 lcomp '(face) comp)
+ for x across pat
+ for i = (cl-loop for j from (if i (1+ i) 0) below lcomp
+ when (char-equal x (aref comp j)) return j)
+ unless i do (cl-return nil)
+ ;; FIXME: could do much better here and coalesce intervals
+ do (add-face-text-property i (1+ i) 'completions-common-part
+ nil comp)
+ finally (cl-return comp)))
+
+(defun eglot--dumb-allc (pat table pred _point) (funcall table pat pred t))
+(defun eglot--dumb-tryc (pat table pred point)
+ (let ((probe (funcall table pat pred nil)))
+ (cond ((eq probe t) t)
+ (probe (cons probe (length probe)))
+ (t (cons pat point)))))
+
+(add-to-list 'completion-category-defaults '(eglot-capf (styles eglot--dumb-flex)))
+(add-to-list 'completion-styles-alist '(eglot--dumb-flex eglot--dumb-tryc eglot--dumb-allc))
(defun eglot-completion-at-point ()
"Eglot's `completion-at-point' function."
;; Commit logs for this function help understand what's going on.
- (when-let (completion-capability (eglot--server-capable :completionProvider))
+ (when-let (completion-capability (eglot-server-capable :completionProvider))
(let* ((server (eglot--current-server-or-lose))
+ (bounds (or (bounds-of-thing-at-point 'symbol)
+ (cons (point) (point))))
+ (bounds-string (buffer-substring (car bounds) (cdr bounds)))
(sort-completions
(lambda (completions)
(cl-sort completions
@@ -2895,43 +3103,50 @@ for which LSP on-type-formatting should be requested."
(plist-get
(get-text-property 0 'eglot--lsp-item c)
:sortText)))))
- (metadata `(metadata (category . eglot)
+ (metadata `(metadata (category . eglot-capf)
(display-sort-function . ,sort-completions)))
- resp items (cached-proxies :none)
+ (local-cache :none)
+ (orig-pos (point))
+ (resolved (make-hash-table))
(proxies
(lambda ()
- (if (listp cached-proxies) cached-proxies
- (setq resp
- (jsonrpc-request server
- :textDocument/completion
- (eglot--CompletionParams)
- :deferred :textDocument/completion
- :cancel-on-input t))
- (setq items (append
- (if (vectorp resp) resp (plist-get resp :items))
- nil))
- (setq cached-proxies
- (mapcar
- (jsonrpc-lambda
- (&rest item &key label insertText insertTextFormat
- textEdit &allow-other-keys)
- (let ((proxy
- ;; Snippet or textEdit, it's safe to
- ;; display/insert the label since
- ;; it'll be adjusted. If no usable
- ;; insertText at all, label is best,
- ;; too.
- (cond ((or (eql insertTextFormat 2)
- textEdit
- (null insertText)
- (string-empty-p insertText))
- (string-trim-left label))
- (t insertText))))
- (unless (zerop (length proxy))
- (put-text-property 0 1 'eglot--lsp-item item proxy))
- proxy))
- items)))))
- (resolved (make-hash-table))
+ (if (listp local-cache) local-cache
+ (let* ((resp (eglot--request server
+ :textDocument/completion
+ (eglot--CompletionParams)
+ :cancel-on-input t))
+ (items (append
+ (if (vectorp resp) resp (plist-get resp :items))
+ nil))
+ (cachep (and (listp resp) items
+ eglot-cache-session-completions
+ (eq (plist-get resp :isIncomplete) :json-false)))
+ (retval
+ (mapcar
+ (jsonrpc-lambda
+ (&rest item &key label insertText insertTextFormat
+ textEdit &allow-other-keys)
+ (let ((proxy
+ ;; Snippet or textEdit, it's safe to
+ ;; display/insert the label since
+ ;; it'll be adjusted. If no usable
+ ;; insertText at all, label is best,
+ ;; too.
+ (cond ((or (eql insertTextFormat 2)
+ textEdit
+ (null insertText)
+ (string-empty-p insertText))
+ (string-trim-left label))
+ (t insertText))))
+ (unless (zerop (length proxy))
+ (put-text-property 0 1 'eglot--lsp-item item proxy))
+ proxy))
+ items)))
+ ;; (trace-values "Requested" (length proxies) cachep bounds)
+ (setq eglot--capf-session
+ (if cachep (list bounds retval resolved orig-pos
+ bounds-string) :none))
+ (setq local-cache retval)))))
(resolve-maybe
;; Maybe completion/resolve JSON object `lsp-comp' into
;; another JSON object, if at all possible. Otherwise,
@@ -2939,34 +3154,44 @@ for which LSP on-type-formatting should be requested."
(lambda (lsp-comp)
(or (gethash lsp-comp resolved)
(setf (gethash lsp-comp resolved)
- (if (and (eglot--server-capable :completionProvider
+ (if (and (eglot-server-capable :completionProvider
:resolveProvider)
(plist-get lsp-comp :data))
- (jsonrpc-request server :completionItem/resolve
- lsp-comp :cancel-on-input t)
- lsp-comp)))))
- (bounds (bounds-of-thing-at-point 'symbol)))
+ (eglot--request server :completionItem/resolve
+ lsp-comp :cancel-on-input t)
+ lsp-comp))))))
+ (when (and (consp eglot--capf-session)
+ (= (car bounds) (car (nth 0 eglot--capf-session)))
+ (>= (cdr bounds) (cdr (nth 0 eglot--capf-session))))
+ (setq local-cache (nth 1 eglot--capf-session)
+ resolved (nth 2 eglot--capf-session)
+ orig-pos (nth 3 eglot--capf-session)
+ bounds-string (nth 4 eglot--capf-session))
+ ;; (trace-values "Recalling cache" (length local-cache) bounds orig-pos)
+ )
(list
- (or (car bounds) (point))
- (or (cdr bounds) (point))
- (lambda (probe pred action)
+ (car bounds)
+ (cdr bounds)
+ (lambda (pattern pred action)
(cond
((eq action 'metadata) metadata) ; metadata
((eq action 'lambda) ; test-completion
- (test-completion probe (funcall proxies)))
+ (test-completion pattern (funcall proxies)))
((eq (car-safe action) 'boundaries) nil) ; boundaries
((null action) ; try-completion
- (try-completion probe (funcall proxies)))
+ (try-completion pattern (funcall proxies)))
((eq action t) ; all-completions
- (all-completions
- ""
- (funcall proxies)
- (lambda (proxy)
- (let* ((item (get-text-property 0 'eglot--lsp-item proxy))
- (filterText (plist-get item :filterText)))
- (and (or (null pred) (funcall pred proxy))
- (string-prefix-p
- probe (or filterText proxy) completion-ignore-case))))))))
+ (let ((comps (funcall proxies)))
+ (dolist (c comps) (eglot--dumb-flex pattern c t))
+ (all-completions
+ ""
+ comps
+ (lambda (proxy)
+ (let* ((item (get-text-property 0 'eglot--lsp-item proxy))
+ (filterText (plist-get item :filterText)))
+ (and (or (null pred) (funcall pred proxy))
+ (eglot--dumb-flex
+ pattern (or filterText proxy) completion-ignore-case)))))))))
:annotation-function
(lambda (proxy)
(eglot--dbind ((CompletionItem) detail kind)
@@ -3019,7 +3244,7 @@ for which LSP on-type-formatting should be requested."
:company-require-match 'never
:company-prefix-length
(save-excursion
- (when (car bounds) (goto-char (car bounds)))
+ (goto-char (car bounds))
(when (listp completion-capability)
(looking-back
(regexp-opt
@@ -3027,6 +3252,7 @@ for which LSP on-type-formatting should be requested."
(eglot--bol))))
:exit-function
(lambda (proxy status)
+ (eglot--capf-session-flush)
(when (memq status '(finished exact))
;; To assist in using this whole `completion-at-point'
;; function inside `completion-in-region', ensure the exit
@@ -3050,20 +3276,16 @@ for which LSP on-type-formatting should be requested."
(let ((snippet-fn (and (eql insertTextFormat 2)
(eglot--snippet-expansion-fn))))
(cond (textEdit
- ;; Undo (yes, undo) the newly inserted completion.
- ;; If before completion the buffer was "foo.b" and
- ;; now is "foo.bar", `proxy' will be "bar". We
- ;; want to delete only "ar" (`proxy' minus the
- ;; symbol whose bounds we've calculated before)
- ;; (github#160).
- (delete-region (+ (- (point) (length proxy))
- (if bounds
- (- (cdr bounds) (car bounds))
- 0))
- (point))
+ ;; Revert buffer back to state when the edit
+ ;; was obtained from server. If a `proxy'
+ ;; "bar" was obtained from a buffer with
+ ;; "foo.b", the LSP edit applies to that
+ ;; state, _not_ the current "foo.bar".
+ (delete-region orig-pos (point))
+ (insert (substring bounds-string (- orig-pos (car bounds))))
(eglot--dbind ((TextEdit) range newText) textEdit
(pcase-let ((`(,beg . ,end)
- (eglot--range-region range)))
+ (eglot-range-region range)))
(delete-region beg end)
(goto-char beg)
(funcall (or snippet-fn #'insert) newText))))
@@ -3082,85 +3304,95 @@ for which LSP on-type-formatting should be requested."
(mapconcat #'eglot--format-markup
(if (vectorp contents) contents (list contents)) "\n"))
-(defun eglot--sig-info (sigs active-sig sig-help-active-param)
- (cl-loop
- for (sig . moresigs) on (append sigs nil) for i from 0
- concat
- (eglot--dbind ((SignatureInformation) label documentation parameters activeParameter) sig
- (with-temp-buffer
- (save-excursion (insert label))
- (let ((active-param (or activeParameter sig-help-active-param))
- params-start params-end)
- ;; Ad-hoc attempt to parse label as <name>(<params>)
- (when (looking-at "\\([^(]*\\)(\\([^)]+\\))")
- (setq params-start (match-beginning 2) params-end (match-end 2))
- (add-face-text-property (match-beginning 1) (match-end 1)
- 'font-lock-function-name-face))
- (when (eql i active-sig)
- ;; Decide whether to add one-line-summary to signature line
- (when (and (stringp documentation)
- (string-match "[[:space:]]*\\([^.\r\n]+[.]?\\)"
- documentation))
- (setq documentation (match-string 1 documentation))
- (unless (string-prefix-p (string-trim documentation) label)
- (goto-char (point-max))
- (insert ": " (eglot--format-markup documentation))))
- ;; Decide what to do with the active parameter...
- (when (and (eql i active-sig) active-param
- (< -1 active-param (length parameters)))
- (eglot--dbind ((ParameterInformation) label documentation)
- (aref parameters active-param)
- ;; ...perhaps highlight it in the formals list
- (when params-start
- (goto-char params-start)
- (pcase-let
- ((`(,beg ,end)
- (if (stringp label)
- (let ((case-fold-search nil))
- (and (re-search-forward
- (concat "\\<" (regexp-quote label) "\\>")
- params-end t)
- (list (match-beginning 0) (match-end 0))))
- (mapcar #'1+ (append label nil)))))
- (if (and beg end)
- (add-face-text-property
- beg end
- 'eldoc-highlight-function-argument))))
- ;; ...and/or maybe add its doc on a line by its own.
- (when documentation
- (goto-char (point-max))
- (insert "\n"
- (propertize
- (if (stringp label)
- label
- (apply #'buffer-substring (mapcar #'1+ label)))
- 'face 'eldoc-highlight-function-argument)
- ": " (eglot--format-markup documentation))))))
- (buffer-string))))
- when moresigs concat "\n"))
+(defun eglot--sig-info (sig &optional sig-active briefp)
+ (eglot--dbind ((SignatureInformation)
+ ((:label siglabel))
+ ((:documentation sigdoc)) parameters activeParameter)
+ sig
+ (with-temp-buffer
+ (insert siglabel)
+ ;; Add documentation, indented so we can distinguish multiple signatures
+ (when-let (doc (and (not briefp) sigdoc (eglot--format-markup sigdoc)))
+ (goto-char (point-max))
+ (insert "\n" (replace-regexp-in-string "^" " " doc)))
+ ;; Try to highlight function name only
+ (let (first-parlabel)
+ (cond ((and (cl-plusp (length parameters))
+ (vectorp (setq first-parlabel
+ (plist-get (aref parameters 0) :label))))
+ (save-excursion
+ (goto-char (elt first-parlabel 0))
+ (skip-syntax-backward "^w")
+ (add-face-text-property (point-min) (point)
+ 'font-lock-function-name-face)))
+ ((save-excursion
+ (goto-char (point-min))
+ (looking-at "\\([^(]*\\)([^)]*)"))
+ (add-face-text-property (match-beginning 1) (match-end 1)
+ 'font-lock-function-name-face))))
+ ;; Now to the parameters
+ (cl-loop
+ with active-param = (or sig-active activeParameter)
+ for i from 0 for parameter across parameters do
+ (eglot--dbind ((ParameterInformation)
+ ((:label parlabel))
+ ((:documentation pardoc)))
+ parameter
+ ;; ...perhaps highlight it in the formals list
+ (when (eq i active-param)
+ (save-excursion
+ (goto-char (point-min))
+ (pcase-let
+ ((`(,beg ,end)
+ (if (stringp parlabel)
+ (let ((case-fold-search nil))
+ (and (search-forward parlabel (line-end-position) t)
+ (list (match-beginning 0) (match-end 0))))
+ (mapcar #'1+ (append parlabel nil)))))
+ (if (and beg end)
+ (add-face-text-property
+ beg end
+ 'eldoc-highlight-function-argument)))))
+ ;; ...and/or maybe add its doc on a line by its own.
+ (let (fpardoc)
+ (when (and pardoc (not briefp)
+ (not (string-empty-p
+ (setq fpardoc (eglot--format-markup pardoc)))))
+ (insert "\n "
+ (propertize
+ (if (stringp parlabel) parlabel
+ (apply #'substring siglabel (mapcar #'1+ parlabel)))
+ 'face (and (eq i active-param) 'eldoc-highlight-function-argument))
+ ": " fpardoc)))))
+ (buffer-string))))
(defun eglot-signature-eldoc-function (cb)
"A member of `eldoc-documentation-functions', for signatures."
- (when (eglot--server-capable :signatureHelpProvider)
+ (when (eglot-server-capable :signatureHelpProvider)
(let ((buf (current-buffer)))
(jsonrpc-async-request
(eglot--current-server-or-lose)
:textDocument/signatureHelp (eglot--TextDocumentPositionParams)
:success-fn
(eglot--lambda ((SignatureHelp)
- signatures activeSignature activeParameter)
+ signatures activeSignature (activeParameter 0))
(eglot--when-buffer-window buf
- (funcall cb
- (unless (seq-empty-p signatures)
- (eglot--sig-info signatures
- activeSignature
- activeParameter)))))
+ (let ((active-sig (and (cl-plusp (length signatures))
+ (aref signatures (or activeSignature 0)))))
+ (if (not active-sig) (funcall cb nil)
+ (funcall
+ cb (mapconcat (lambda (s)
+ (eglot--sig-info s (and (eq s active-sig)
+ activeParameter)
+ nil))
+ signatures "\n")
+ :echo (eglot--sig-info active-sig activeParameter t))))))
:deferred :textDocument/signatureHelp))
t))
(defun eglot-hover-eldoc-function (cb)
"A member of `eldoc-documentation-functions', for hover."
- (when (eglot--server-capable :hoverProvider)
+ (when (eglot-server-capable :hoverProvider)
(let ((buf (current-buffer)))
(jsonrpc-async-request
(eglot--current-server-or-lose)
@@ -3169,7 +3401,8 @@ for which LSP on-type-formatting should be requested."
(eglot--when-buffer-window buf
(let ((info (unless (seq-empty-p contents)
(eglot--hover-info contents range))))
- (funcall cb info :buffer t))))
+ (funcall cb info
+ :echo (and info (string-match "\n" info))))))
:deferred :textDocument/hover))
(eglot--highlight-piggyback cb)
t))
@@ -3181,7 +3414,7 @@ for which LSP on-type-formatting should be requested."
;; FIXME: Obviously, this is just piggy backing on eldoc's calls for
;; convenience, as shown by the fact that we just ignore cb.
(let ((buf (current-buffer)))
- (when (eglot--server-capable :documentHighlightProvider)
+ (when (eglot-server-capable :documentHighlightProvider)
(jsonrpc-async-request
(eglot--current-server-or-lose)
:textDocument/documentHighlight (eglot--TextDocumentPositionParams)
@@ -3193,7 +3426,7 @@ for which LSP on-type-formatting should be requested."
(mapcar
(eglot--lambda ((DocumentHighlight) range)
(pcase-let ((`(,beg . ,end)
- (eglot--range-region range)))
+ (eglot-range-region range)))
(let ((ov (make-overlay beg end)))
(overlay-put ov 'face 'eglot-highlight-symbol-face)
(overlay-put ov 'modification-hooks
@@ -3203,52 +3436,62 @@ for which LSP on-type-formatting should be requested."
:deferred :textDocument/documentHighlight)
nil)))
-(defun eglot-imenu ()
+(defun eglot--imenu-SymbolInformation (res)
+ "Compute `imenu--index-alist' for RES vector of SymbolInformation."
+ (mapcar
+ (pcase-lambda (`(,kind . ,objs))
+ (cons
+ (alist-get kind eglot--symbol-kind-names "Unknown")
+ (mapcan
+ (pcase-lambda (`(,container . ,objs))
+ (let ((elems (mapcar
+ (eglot--lambda ((SymbolInformation) kind name location)
+ (let ((reg (eglot-range-region
+ (plist-get location :range)))
+ (kind (alist-get kind eglot--symbol-kind-names)))
+ (cons (propertize name
+ 'breadcrumb-region reg
+ 'breadcrumb-kind kind)
+ (car reg))))
+ objs)))
+ (if container (list (cons container elems)) elems)))
+ (seq-group-by
+ (eglot--lambda ((SymbolInformation) containerName) containerName) objs))))
+ (seq-group-by (eglot--lambda ((SymbolInformation) kind) kind) res)))
+
+(defun eglot--imenu-DocumentSymbol (res)
+ "Compute `imenu--index-alist' for RES vector of DocumentSymbol."
+ (cl-labels ((dfs (&key name children range kind &allow-other-keys)
+ (let* ((reg (eglot-range-region range))
+ (kind (alist-get kind eglot--symbol-kind-names))
+ (name (propertize name
+ 'breadcrumb-region reg
+ 'breadcrumb-kind kind)))
+ (if (seq-empty-p children)
+ (cons name (car reg))
+ (cons name
+ (mapcar (lambda (c) (apply #'dfs c)) children))))))
+ (mapcar (lambda (s) (apply #'dfs s)) res)))
+
+(cl-defun eglot-imenu ()
"Eglot's `imenu-create-index-function'.
Returns a list as described in docstring of `imenu--index-alist'."
- (cl-labels
- ((unfurl (obj)
- (eglot--dcase obj
- (((SymbolInformation)) (list obj))
- (((DocumentSymbol) name children)
- (cons obj
- (mapcar
- (lambda (c)
- (plist-put
- c :containerName
- (let ((existing (plist-get c :containerName)))
- (if existing (format "%s::%s" name existing)
- name))))
- (mapcan #'unfurl children)))))))
- (mapcar
- (pcase-lambda (`(,kind . ,objs))
- (cons
- (alist-get kind eglot--symbol-kind-names "Unknown")
- (mapcan (pcase-lambda (`(,container . ,objs))
- (let ((elems (mapcar
- (lambda (obj)
- (cons (plist-get obj :name)
- (car (eglot--range-region
- (eglot--dcase obj
- (((SymbolInformation) location)
- (plist-get location :range))
- (((DocumentSymbol) selectionRange)
- selectionRange))))))
- objs)))
- (if container (list (cons container elems)) elems)))
- (seq-group-by
- (lambda (e) (plist-get e :containerName)) objs))))
- (seq-group-by
- (lambda (obj) (plist-get obj :kind))
- (mapcan #'unfurl
- (jsonrpc-request (eglot--current-server-or-lose)
- :textDocument/documentSymbol
- `(:textDocument
- ,(eglot--TextDocumentIdentifier))
- :cancel-on-input non-essential))))))
-
-(cl-defun eglot--apply-text-edits (edits &optional version)
- "Apply EDITS for current buffer if at VERSION, or if it's nil."
+ (unless (eglot-server-capable :documentSymbolProvider)
+ (cl-return-from eglot-imenu))
+ (let* ((res (eglot--request (eglot--current-server-or-lose)
+ :textDocument/documentSymbol
+ `(:textDocument
+ ,(eglot--TextDocumentIdentifier))
+ :cancel-on-input non-essential))
+ (head (and (cl-plusp (length res)) (elt res 0))))
+ (when head
+ (eglot--dcase head
+ (((SymbolInformation)) (eglot--imenu-SymbolInformation res))
+ (((DocumentSymbol)) (eglot--imenu-DocumentSymbol res))))))
+
+(cl-defun eglot--apply-text-edits (edits &optional version silent)
+ "Apply EDITS for current buffer if at VERSION, or if it's nil.
+If SILENT, don't echo progress in mode-line."
(unless edits (cl-return-from eglot--apply-text-edits))
(unless (or (not version) (equal version eglot--versioned-identifier))
(jsonrpc-error "Edits on `%s' require version %d, you have %d"
@@ -3256,10 +3499,11 @@ Returns a list as described in docstring of `imenu--index-alist'."
(atomic-change-group
(let* ((change-group (prepare-change-group))
(howmany (length edits))
- (reporter (make-progress-reporter
- (format "[eglot] applying %s edits to `%s'..."
- howmany (current-buffer))
- 0 howmany))
+ (reporter (unless silent
+ (make-progress-reporter
+ (format "[eglot] applying %s edits to `%s'..."
+ howmany (current-buffer))
+ 0 howmany)))
(done 0))
(mapc (pcase-lambda (`(,newText ,beg . ,end))
(let ((source (current-buffer)))
@@ -3271,40 +3515,109 @@ Returns a list as described in docstring of `imenu--index-alist'."
(save-restriction
(narrow-to-region beg end)
(replace-buffer-contents temp)))
- (progress-reporter-update reporter (cl-incf done)))))))
+ (when reporter
+ (eglot--reporter-update reporter (cl-incf done))))))))
(mapcar (eglot--lambda ((TextEdit) range newText)
- (cons newText (eglot--range-region range 'markers)))
+ (cons newText (eglot-range-region range 'markers)))
(reverse edits)))
(undo-amalgamate-change-group change-group)
- (progress-reporter-done reporter))))
-
-(defun eglot--apply-workspace-edit (wedit &optional confirm)
- "Apply the workspace edit WEDIT. If CONFIRM, ask user first."
+ (when reporter
+ (progress-reporter-done reporter)))))
+
+(defun eglot--confirm-server-edits (origin _prepared)
+ "Helper for `eglot--apply-workspace-edit.
+ORIGIN is a symbol designating a command. Reads the
+`eglot-confirm-server-edits' user option and returns a symbol
+like `diff', `summary' or nil."
+ (let (v)
+ (cond ((symbolp eglot-confirm-server-edits) eglot-confirm-server-edits)
+ ((setq v (assoc origin eglot-confirm-server-edits)) (cdr v))
+ ((setq v (assoc t eglot-confirm-server-edits)) (cdr v)))))
+
+(defun eglot--propose-changes-as-diff (prepared)
+ "Helper for `eglot--apply-workspace-edit'.
+Goal is to popup a `diff-mode' buffer containing all the changes
+of PREPARED, ready to apply with C-c C-a. PREPARED is a
+list ((FILENAME EDITS VERSION)...)."
+ (with-current-buffer (get-buffer-create "*EGLOT proposed server changes*")
+ (buffer-disable-undo (current-buffer))
+ (let ((inhibit-read-only t)
+ (target (current-buffer)))
+ (diff-mode)
+ (erase-buffer)
+ (pcase-dolist (`(,path ,edits ,_) prepared)
+ (with-temp-buffer
+ (let* ((diff (current-buffer))
+ (existing-buf (find-buffer-visiting path))
+ (existing-buf-label (prin1-to-string existing-buf)))
+ (with-temp-buffer
+ (if existing-buf
+ (insert-buffer-substring existing-buf)
+ (insert-file-contents path))
+ (eglot--apply-text-edits edits nil t)
+ (diff-no-select (or existing-buf path) (current-buffer) nil t diff)
+ (when existing-buf
+ ;; Here we have to pretend the label of the unsaved
+ ;; buffer is the actual file, just so that we can
+ ;; diff-apply without troubles. If there's a better
+ ;; way, it probably involves changes to `diff.el'.
+ (with-current-buffer diff
+ (goto-char (point-min))
+ (while (search-forward existing-buf-label nil t)
+ (replace-match (buffer-file-name existing-buf))))))
+ (with-current-buffer target
+ (insert-buffer-substring diff))))))
+ (setq-local buffer-read-only t)
+ (buffer-enable-undo (current-buffer))
+ (goto-char (point-min))
+ (pop-to-buffer (current-buffer))
+ (font-lock-ensure)))
+
+(defun eglot--apply-workspace-edit (wedit origin)
+ "Apply (or offer to apply) the workspace edit WEDIT.
+ORIGIN is a symbol designating the command that originated this
+edit proposed by the server."
(eglot--dbind ((WorkspaceEdit) changes documentChanges) wedit
(let ((prepared
(mapcar (eglot--lambda ((TextDocumentEdit) textDocument edits)
(eglot--dbind ((VersionedTextDocumentIdentifier) uri version)
textDocument
- (list (eglot--uri-to-path uri) edits version)))
+ (list (eglot-uri-to-path uri) edits version)))
documentChanges)))
(unless (and changes documentChanges)
;; We don't want double edits, and some servers send both
;; changes and documentChanges. This unless ensures that we
;; prefer documentChanges over changes.
(cl-loop for (uri edits) on changes by #'cddr
- do (push (list (eglot--uri-to-path uri) edits) prepared)))
- (if (or confirm
- (cl-notevery #'find-buffer-visiting
- (mapcar #'car prepared)))
- (unless (y-or-n-p
- (format "[eglot] Server wants to edit:\n %s\n Proceed? "
- (mapconcat #'identity (mapcar #'car prepared) "\n ")))
- (jsonrpc-error "User canceled server edit")))
- (cl-loop for edit in prepared
- for (path edits version) = edit
- do (with-current-buffer (find-file-noselect path)
- (eglot--apply-text-edits edits version))
- finally (eldoc) (eglot--message "Edit successful!")))))
+ do (push (list (eglot-uri-to-path uri) edits) prepared)))
+ (cl-flet ((notevery-visited-p ()
+ (cl-notevery #'find-buffer-visiting
+ (mapcar #'car prepared)))
+ (accept-p ()
+ (y-or-n-p
+ (format "[eglot] Server wants to edit:\n%sProceed? "
+ (cl-loop
+ for (f eds _) in prepared
+ concat (format
+ " %s (%d change%s)\n"
+ f (length eds)
+ (if (> (length eds) 1) "s" ""))))))
+ (apply ()
+ (cl-loop for edit in prepared
+ for (path edits version) = edit
+ do (with-current-buffer (find-file-noselect path)
+ (eglot--apply-text-edits edits version))
+ finally (eldoc) (eglot--message "Edit successful!"))))
+ (let ((decision (eglot--confirm-server-edits origin prepared)))
+ (cond
+ ((or (eq decision 'diff)
+ (and (eq decision 'maybe-diff) (notevery-visited-p)))
+ (eglot--propose-changes-as-diff prepared))
+ ((or (memq decision '(t summary))
+ (and (eq decision 'maybe-summary) (notevery-visited-p)))
+ (when (accept-p) (apply)))
+ (t
+ (apply))))))))
(defun eglot-rename (newname)
"Rename the current symbol to NEWNAME."
@@ -3314,18 +3627,26 @@ Returns a list as described in docstring of `imenu--index-alist'."
"unknown symbol"))
nil nil nil nil
(symbol-name (symbol-at-point)))))
- (eglot--server-capable-or-lose :renameProvider)
+ (eglot-server-capable-or-lose :renameProvider)
(eglot--apply-workspace-edit
- (jsonrpc-request (eglot--current-server-or-lose)
- :textDocument/rename `(,@(eglot--TextDocumentPositionParams)
- :newName ,newname))
- current-prefix-arg))
-
-(defun eglot--region-bounds ()
- "Region bounds if active, else bounds of things at point."
- (if (use-region-p) `(,(region-beginning) ,(region-end))
- (let ((boftap (bounds-of-thing-at-point 'sexp)))
- (list (car boftap) (cdr boftap)))))
+ (eglot--request (eglot--current-server-or-lose)
+ :textDocument/rename `(,@(eglot--TextDocumentPositionParams)
+ :newName ,newname))
+ this-command))
+
+(defun eglot--code-action-bounds ()
+ "Calculate appropriate bounds depending on region and point."
+ (let (diags boftap)
+ (cond ((use-region-p) `(,(region-beginning) ,(region-end)))
+ ((setq diags (flymake-diagnostics (point)))
+ (cl-loop for d in diags
+ minimizing (flymake-diagnostic-beg d) into beg
+ maximizing (flymake-diagnostic-end d) into end
+ finally (cl-return (list beg end))))
+ ((setq boftap (bounds-of-thing-at-point 'sexp))
+ (list (car boftap) (cdr boftap)))
+ (t
+ (list (point) (point))))))
(defun eglot-code-actions (beg &optional end action-kind interactive)
"Find LSP code actions of type ACTION-KIND between BEG and END.
@@ -3335,16 +3656,16 @@ Interactively, default BEG and END to region's bounds else BEG is
point and END is nil, which results in a request for code actions
at point. With prefix argument, prompt for ACTION-KIND."
(interactive
- `(,@(eglot--region-bounds)
+ `(,@(eglot--code-action-bounds)
,(and current-prefix-arg
(completing-read "[eglot] Action kind: "
'("quickfix" "refactor.extract" "refactor.inline"
"refactor.rewrite" "source.organizeImports")))
t))
- (eglot--server-capable-or-lose :codeActionProvider)
+ (eglot-server-capable-or-lose :codeActionProvider)
(let* ((server (eglot--current-server-or-lose))
(actions
- (jsonrpc-request
+ (eglot--request
server
:textDocument/codeAction
(list :textDocument (eglot--TextDocumentIdentifier)
@@ -3356,12 +3677,12 @@ at point. With prefix argument, prompt for ACTION-KIND."
when (cdr (assoc 'eglot-lsp-diag
(eglot--diag-data diag)))
collect it)]
- ,@(when action-kind `(:only [,action-kind]))))
- :deferred t))
+ ,@(when action-kind `(:only [,action-kind]))))))
;; Redo filtering, in case the `:only' didn't go through.
(actions (cl-loop for a across actions
when (or (not action-kind)
- (equal action-kind (plist-get a :kind)))
+ ;; github#847
+ (string-prefix-p action-kind (plist-get a :kind)))
collect a)))
(if interactive
(eglot--read-execute-code-action actions server action-kind)
@@ -3393,20 +3714,13 @@ at point. With prefix argument, prompt for ACTION-KIND."
default-action)
menu-items nil t nil nil default-action)
menu-items))))))
- (eglot--dcase chosen
- (((Command) command arguments)
- (eglot-execute-command server (intern command) arguments))
- (((CodeAction) edit command)
- (when edit (eglot--apply-workspace-edit edit))
- (when command
- (eglot--dbind ((Command) command arguments) command
- (eglot-execute-command server (intern command) arguments)))))))
+ (eglot-execute server chosen)))
(defmacro eglot--code-action (name kind)
"Define NAME to execute KIND code action."
`(defun ,name (beg &optional end)
,(format "Execute `%s' code actions between BEG and END." kind)
- (interactive (eglot--region-bounds))
+ (interactive (eglot--code-action-bounds))
(eglot-code-actions beg end ,kind t)))
(eglot--code-action eglot-code-action-organize-imports "source.organizeImports")
@@ -3436,8 +3750,7 @@ at point. With prefix argument, prompt for ACTION-KIND."
(project-files
(eglot--project server))))))
(cl-labels
- ((handle-event
- (event)
+ ((handle-event (event)
(pcase-let* ((`(,desc ,action ,file ,file1) event)
(action-type (cl-case action
(created 1) (changed 2) (deleted 3)))
@@ -3450,17 +3763,25 @@ at point. With prefix argument, prompt for ACTION-KIND."
(funcall glob file))))
(jsonrpc-notify
server :workspace/didChangeWatchedFiles
- `(:changes ,(vector `(:uri ,(eglot--path-to-uri file)
- :type ,action-type)))))
+ `(:changes ,(vector `(:uri ,(eglot-path-to-uri file)
+ :type ,action-type))))
+ (when (and (eq action 'created)
+ (file-directory-p file))
+ (watch-dir file)))
((eq action 'renamed)
(handle-event `(,desc 'deleted ,file))
- (handle-event `(,desc 'created ,file1)))))))
+ (handle-event `(,desc 'created ,file1))))))
+ (watch-dir (dir)
+ (when-let ((probe
+ (and (file-readable-p dir)
+ (or (gethash dir (eglot--file-watches server))
+ (puthash dir (list (file-notify-add-watch
+ dir '(change) #'handle-event))
+ (eglot--file-watches server))))))
+ (push id (cdr probe)))))
(unwind-protect
(progn
- (dolist (dir dirs-to-watch)
- (when (file-readable-p dir)
- (push (file-notify-add-watch dir '(change) #'handle-event)
- (gethash id (eglot--file-watches server)))))
+ (mapc #'watch-dir dirs-to-watch)
(setq
success
`(:message ,(format "OK, watching %s directories in %s watchers"
@@ -3471,8 +3792,12 @@ at point. With prefix argument, prompt for ACTION-KIND."
(cl-defmethod eglot-unregister-capability
(server (_method (eql workspace/didChangeWatchedFiles)) id)
"Handle dynamic unregistration of workspace/didChangeWatchedFiles."
- (mapc #'file-notify-rm-watch (gethash id (eglot--file-watches server)))
- (remhash id (eglot--file-watches server))
+ (maphash (lambda (dir watch-and-ids)
+ (setcdr watch-and-ids (delete id (cdr watch-and-ids)))
+ (when (null (cdr watch-and-ids))
+ (file-notify-rm-watch (car watch-and-ids))
+ (remhash dir (eglot--file-watches server))))
+ (eglot--file-watches server))
(list t "OK"))
@@ -3705,7 +4030,7 @@ If NOERROR, return predicate, else erroring function."
"Minor mode for annotating buffers with LSP server's inlay hints."
:global nil
(cond (eglot-inlay-hints-mode
- (if (eglot--server-capable :inlayHintProvider)
+ (if (eglot-server-capable :inlayHintProvider)
(jit-lock-register #'eglot--update-hints 'contextual)
(eglot-inlay-hints-mode -1)))
(t
@@ -3732,11 +4057,7 @@ If NOERROR, return predicate, else erroring function."
"https://github.com/joaotavora/eglot/issues/%s"
"https://debbugs.gnu.org/%s")
(match-string 3))))
-;;; Obsolete
-;;;
-(make-obsolete-variable 'eglot--managed-mode-hook
- 'eglot-managed-mode-hook "1.6")
(provide 'eglot)
diff --git a/lisp/progmodes/elisp-mode.el b/lisp/progmodes/elisp-mode.el
index 7436fe710e8..8a713bd19a2 100644
--- a/lisp/progmodes/elisp-mode.el
+++ b/lisp/progmodes/elisp-mode.el
@@ -221,7 +221,7 @@ All commands in `lisp-mode-shared-map' are inherited by this map."
(load (byte-compile-dest-file buffer-file-name)))
(declare-function native-compile "comp")
-(declare-function comp-write-bytecode-file "comp")
+(declare-function comp--write-bytecode-file "comp")
(defun emacs-lisp-native-compile ()
"Native-compile the current buffer's file (if it has changed).
@@ -233,7 +233,7 @@ visited by the current buffer."
(byte-to-native-output-buffer-file nil)
(eln (native-compile buffer-file-name)))
(when eln
- (comp-write-bytecode-file eln))))
+ (comp--write-bytecode-file eln))))
(defun emacs-lisp-native-compile-and-load ()
"Native-compile the current buffer's file (if it has changed), then load it.
@@ -271,6 +271,9 @@ Comments in the form will be lost."
;; Empty symbol.
("##" (0 (unless (nth 8 (syntax-ppss))
(string-to-syntax "_"))))
+ ;; Prevent the @ from becoming part of a following 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\\}}"
@@ -306,7 +309,7 @@ Comments in the form will be lost."
INTERACTIVE non-nil means ask the user for confirmation; this
happens in interactive invocations."
(interactive "p")
- (if lexical-binding
+ (if (and (local-variable-p 'lexical-binding) lexical-binding)
(when interactive
(message "lexical-binding already enabled!")
(ding))
@@ -368,6 +371,12 @@ be used instead.
;; Font-locking support.
+(defun elisp--font-lock-shorthand (_limit)
+ ;; Add faces on shorthands between point and LIMIT.
+ ;; ...
+ ;; Return nil to tell font-lock, that there's nothing left to do.
+ nil)
+
(defun elisp--font-lock-flush-elisp-buffers (&optional file)
;; We're only ever called from after-load-functions, load-in-progress can
;; still be t in case of nested loads.
@@ -430,6 +439,14 @@ be used instead.
(defvar warning-minimum-log-level)
+(defvar elisp--local-macroenv
+ `((cl-eval-when . ,(lambda (&rest args) `(progn . ,(cdr args))))
+ (eval-when-compile . ,(lambda (&rest args) `(progn . ,args)))
+ (eval-and-compile . ,(lambda (&rest args) `(progn . ,args))))
+ "Environment to use while tentatively expanding macros.
+This is used to try and avoid the most egregious problems linked to the
+use of `macroexpand-all' as a way to find the \"underlying raw code\".")
+
(defun elisp--local-variables ()
"Return a list of locally let-bound variables at point."
(save-excursion
@@ -445,21 +462,22 @@ be used instead.
(car (read-from-string
(concat txt "elisp--witness--lisp" closer)))
((invalid-read-syntax end-of-file) nil)))
- (macroexpand-advice (lambda (expander form &rest args)
- (condition-case nil
- (apply expander form args)
- (error form))))
+ (macroexpand-advice
+ (lambda (expander form &rest args)
+ (condition-case err
+ (apply expander form args)
+ (error
+ (message "Ignoring macroexpansion error: %S" err) form))))
(sexp
(unwind-protect
;; Silence any macro expansion errors when
;; attempting completion at point (bug#58148).
(let ((inhibit-message t)
+ (macroexp-inhibit-compiler-macros t)
(warning-minimum-log-level :emergency))
- (advice-add 'macroexpand :around macroexpand-advice)
- (condition-case nil
- (macroexpand-all sexp)
- (error sexp)))
- (advice-remove 'macroexpand macroexpand-advice)))
+ (advice-add 'macroexpand-1 :around macroexpand-advice)
+ (macroexpand-all sexp elisp--local-macroenv))
+ (advice-remove 'macroexpand-1 macroexpand-advice)))
(vars (elisp--local-variables-1 nil sexp)))
(delq nil
(mapcar (lambda (var)
@@ -645,12 +663,13 @@ functions are annotated with \"<f>\" via the
(save-excursion
(backward-sexp 1)
(skip-chars-forward "`',‘#")
- (point))
+ (min (point) pos))
(scan-error pos)))
(end
- (unless (or (eq beg (point-max))
- (member (char-syntax (char-after beg))
- '(?\" ?\()))
+ (cond
+ ((and (< beg (point-max))
+ (memq (char-syntax (char-after beg))
+ '(?w ?\\ ?_)))
(condition-case nil
(save-excursion
(goto-char beg)
@@ -658,7 +677,11 @@ functions are annotated with \"<f>\" via the
(skip-chars-backward "'’")
(when (>= (point) pos)
(point)))
- (scan-error pos))))
+ (scan-error pos)))
+ ((or (>= beg (point-max))
+ (memq (char-syntax (char-after beg))
+ '(?\) ?\s)))
+ beg)))
;; t if in function position.
(funpos (eq (char-before beg) ?\())
(quoted (elisp--form-quoted-p beg))
@@ -970,6 +993,10 @@ namespace but with lower confidence."
cl-defmethod cl-defgeneric)))
;; (defun FUNC (... IDENT
'variable)
+ ((and (eql j 2)
+ (eq j-head 'defclass))
+ ;; (defclass CLASS (... IDENT
+ 'function)
((eq j-head 'cond)
;; (cond ... (... IDENT
'variable)
@@ -1382,9 +1409,9 @@ BEG and END are the start and end of the output in current buffer.
VALUE is the Lisp value printed, ALT1 and ALT2 are strings for the
alternative printed representations that can be displayed."
(let ((map (make-sparse-keymap)))
- (define-key map "\C-m" 'elisp-last-sexp-toggle-display)
- (define-key map [down-mouse-2] 'mouse-set-point)
- (define-key map [mouse-2] 'elisp-last-sexp-toggle-display)
+ (define-key map "\C-m" #'elisp-last-sexp-toggle-display)
+ (define-key map [down-mouse-2] #'mouse-set-point)
+ (define-key map [mouse-2] #'elisp-last-sexp-toggle-display)
(add-text-properties
beg end
`(printed-value (,value ,alt1 ,alt2)
@@ -1441,7 +1468,7 @@ If CHAR is not a character, return nil."
(lambda (modif)
(cond ((eq modif 'super) "\\s-")
(t (string ?\\ (upcase (aref (symbol-name modif) 0)) ?-))))
- mods "")
+ mods)
(cond
((memq c '(?\; ?\( ?\) ?\{ ?\} ?\[ ?\] ?\" ?\' ?\\)) (string ?\\ c))
((eq c 127) "\\C-?")
@@ -1517,7 +1544,7 @@ If CHAR is not a character, return nil."
`(call-interactively
(lambda (&rest args) ,expr args))))
expr)))))
-(define-obsolete-function-alias 'preceding-sexp 'elisp--preceding-sexp "25.1")
+(define-obsolete-function-alias 'preceding-sexp #'elisp--preceding-sexp "25.1")
(defun elisp--eval-last-sexp (eval-last-sexp-arg-internal)
"Evaluate sexp before point; print value in the echo area.
@@ -1561,9 +1588,6 @@ character)."
(buffer-substring-no-properties beg end))
))))
-
-(defvar elisp--eval-last-sexp-fake-value (make-symbol "t"))
-
(defun eval-sexp-add-defvars (exp &optional pos)
"Prepend EXP with all the `defvar's that precede it in the buffer.
POS specifies the starting position where EXP was found and defaults to point."
@@ -1605,16 +1629,10 @@ integer value is also printed as a character of that codepoint.
If `eval-expression-debug-on-error' is non-nil, which is the default,
this command arranges for all errors to enter the debugger."
(interactive "P")
- (if (null eval-expression-debug-on-error)
- (values--store-value
- (elisp--eval-last-sexp eval-last-sexp-arg-internal))
- (let ((value
- (let ((debug-on-error elisp--eval-last-sexp-fake-value))
- (cons (elisp--eval-last-sexp eval-last-sexp-arg-internal)
- debug-on-error))))
- (unless (eq (cdr value) elisp--eval-last-sexp-fake-value)
- (setq debug-on-error (cdr value)))
- (car value))))
+ (values--store-value
+ (handler-bind ((error (if eval-expression-debug-on-error
+ #'eval-expression--debug #'ignore)))
+ (elisp--eval-last-sexp eval-last-sexp-arg-internal))))
(defun elisp--eval-defun-1 (form)
"Treat some expressions in FORM specially.
@@ -1645,9 +1663,8 @@ Reinitialize the face according to the `defface' specification."
;; The second arg is an expression that evaluates to
;; an expression. The second evaluation is the one
;; normally performed not by normal execution but by
- ;; custom-initialize-set (for example), which does not
- ;; use lexical-binding.
- (eval (eval (nth 2 form) lexical-binding))))
+ ;; custom-initialize-set (for example).
+ (eval (eval (nth 2 form) lexical-binding) t)))
form)
;; `defface' is macroexpanded to `custom-declare-face'.
((eq (car form) 'custom-declare-face)
@@ -1674,8 +1691,7 @@ Return the result of evaluation."
;; FIXME: the print-length/level bindings should only be applied while
;; printing, not while evaluating.
(defvar elisp--eval-defun-result)
- (let ((debug-on-error eval-expression-debug-on-error)
- (edebugging edebug-all-defs)
+ (let ((edebugging edebug-all-defs)
elisp--eval-defun-result)
(save-excursion
;; Arrange for eval-region to "read" the (possibly) altered form.
@@ -1754,15 +1770,9 @@ which see."
(defvar edebug-all-defs)
(eval-defun (not edebug-all-defs)))
(t
- (if (null eval-expression-debug-on-error)
- (elisp--eval-defun)
- (let (new-value value)
- (let ((debug-on-error elisp--eval-last-sexp-fake-value))
- (setq value (elisp--eval-defun))
- (setq new-value debug-on-error))
- (unless (eq elisp--eval-last-sexp-fake-value new-value)
- (setq debug-on-error new-value))
- value)))))
+ (handler-bind ((error (if eval-expression-debug-on-error
+ #'eval-expression--debug #'ignore)))
+ (elisp--eval-defun)))))
;;; ElDoc Support
@@ -1787,7 +1797,7 @@ Elements are as follows:
(or (progn (elisp-eldoc-var-docstring callback) str)
(progn (elisp-eldoc-funcall callback) str))))
-(defalias 'elisp-eldoc-documentation-function 'elisp--documentation-one-liner
+(defalias 'elisp-eldoc-documentation-function #'elisp--documentation-one-liner
"Return Elisp documentation for the thing at point as one-line string.
This is meant as a backward compatibility aide to the \"old\"
Elisp eldoc behavior. Consider variable docstrings and function
diff --git a/lisp/progmodes/elixir-ts-mode.el b/lisp/progmodes/elixir-ts-mode.el
new file mode 100644
index 00000000000..9804152d9ab
--- /dev/null
+++ b/lisp/progmodes/elixir-ts-mode.el
@@ -0,0 +1,767 @@
+;;; elixir-ts-mode.el --- Major mode for Elixir with tree-sitter support -*- lexical-binding: t; -*-
+
+;; Copyright (C) 2022-2024 Free Software Foundation, Inc.
+
+;; Author: Wilhelm H Kirschbaum <wkirschbaum@gmail.com>
+;; Created: November 2022
+;; Keywords: elixir languages tree-sitter
+
+;; This file is part of GNU Emacs.
+
+;; GNU Emacs is free software: you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+
+;; GNU Emacs is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>.
+
+;;; Commentary:
+;;
+;; This package provides `elixir-ts-mode' which is a major mode for editing
+;; Elixir files and embedded HEEx templates that uses Tree Sitter to parse
+;; the language.
+;;
+;; This package is compatible with and was tested against the tree-sitter grammar
+;; for Elixir found at https://github.com/elixir-lang/tree-sitter-elixir.
+;;
+;; Features
+;;
+;; * Indent
+;;
+;; `elixir-ts-mode' tries to replicate the indentation provided by
+;; mix format, but will come with some minor differences.
+;;
+;; * IMenu
+;; * Navigation
+;; * Which-fun
+
+;;; Code:
+
+(require 'treesit)
+(eval-when-compile (require 'rx))
+
+(declare-function treesit-parser-create "treesit.c")
+(declare-function treesit-node-child "treesit.c")
+(declare-function treesit-node-type "treesit.c")
+(declare-function treesit-node-child-by-field-name "treesit.c")
+(declare-function treesit-parser-language "treesit.c")
+(declare-function treesit-parser-included-ranges "treesit.c")
+(declare-function treesit-parser-list "treesit.c")
+(declare-function treesit-node-p "treesit.c")
+(declare-function treesit-node-parent "treesit.c")
+(declare-function treesit-node-start "treesit.c")
+(declare-function treesit-node-end "treesit.c")
+(declare-function treesit-query-compile "treesit.c")
+(declare-function treesit-query-capture "treesit.c")
+(declare-function treesit-node-eq "treesit.c")
+(declare-function treesit-node-prev-sibling "treesit.c")
+
+(defgroup elixir-ts nil
+ "Major mode for editing Elixir code."
+ :prefix "elixir-ts-"
+ :group 'languages)
+
+(defcustom elixir-ts-indent-offset 2
+ "Indentation of Elixir statements."
+ :version "30.1"
+ :type 'integer
+ :safe 'integerp
+ :group 'elixir-ts)
+
+;; 'define-derived-mode' doesn't expose the generated mode hook
+;; variable to Custom, because we are not smart enough to provide the
+;; ':options' for hook variables. Also, some packages modify hook
+;; variables. The below is done because users of this mode explicitly
+;; requested the hook to be customizable via Custom.
+(defcustom elixir-ts-mode-hook nil
+ "Hook run after entering `elixir-ts-mode'."
+ :type 'hook
+ :options '(eglot-ensure)
+ :group 'elixir-ts
+ :version "30.1")
+
+(defface elixir-ts-comment-doc-identifier
+ '((t (:inherit font-lock-doc-face)))
+ "Face used for doc identifiers in Elixir files."
+ :group 'elixir-ts)
+
+(defface elixir-ts-comment-doc-attribute
+ '((t (:inherit font-lock-doc-face)))
+ "Face used for doc attributes in Elixir files."
+ :group 'elixir-ts)
+
+(defface elixir-ts-sigil-name
+ '((t (:inherit font-lock-string-face)))
+ "Face used for sigils in Elixir files."
+ :group 'elixir-ts)
+
+(defface elixir-ts-atom
+ '((t (:inherit font-lock-constant-face)))
+ "Face used for atoms in Elixir files."
+ :group 'elixir-ts)
+
+(defface elixir-ts-keyword-key
+ '((t (:inherit elixir-ts-atom)))
+ "Face used for keyword keys in Elixir files."
+ :group 'elixir-ts)
+
+(defface elixir-ts-attribute
+ '((t (:inherit font-lock-preprocessor-face)))
+ "Face used for attributes in Elixir files."
+ :group 'elixir-ts)
+
+(defconst elixir-ts--sexp-regexp
+ (rx bol
+ (or "call" "stab_clause" "binary_operator" "list" "tuple" "map" "pair"
+ "sigil" "string" "atom" "alias" "arguments" "identifier"
+ "boolean" "quoted_content" "bitstring")
+ eol))
+
+(defconst elixir-ts--test-definition-keywords
+ '("describe" "test"))
+
+(defconst elixir-ts--definition-keywords
+ '("def" "defdelegate" "defexception" "defguard" "defguardp"
+ "defimpl" "defmacro" "defmacrop" "defmodule" "defn" "defnp"
+ "defoverridable" "defp" "defprotocol" "defstruct"))
+
+(defconst elixir-ts--definition-keywords-re
+ (concat "^" (regexp-opt
+ (append elixir-ts--definition-keywords
+ elixir-ts--test-definition-keywords))
+ "$"))
+
+(defconst elixir-ts--kernel-keywords
+ '("alias" "case" "cond" "else" "for" "if" "import" "quote"
+ "raise" "receive" "require" "reraise" "super" "throw" "try"
+ "unless" "unquote" "unquote_splicing" "use" "with"))
+
+(defconst elixir-ts--kernel-keywords-re
+ (concat "^" (regexp-opt elixir-ts--kernel-keywords) "$"))
+
+(defconst elixir-ts--builtin-keywords
+ '("__MODULE__" "__DIR__" "__ENV__" "__CALLER__" "__STACKTRACE__"))
+
+(defconst elixir-ts--builtin-keywords-re
+ (concat "^" (regexp-opt elixir-ts--builtin-keywords) "$"))
+
+(defconst elixir-ts--doc-keywords
+ '("moduledoc" "typedoc" "doc"))
+
+(defconst elixir-ts--doc-keywords-re
+ (concat "^" (regexp-opt elixir-ts--doc-keywords) "$"))
+
+(defconst elixir-ts--reserved-keywords
+ '("when" "and" "or" "not" "in"
+ "not in" "fn" "do" "end" "catch" "rescue" "after" "else"))
+
+(defconst elixir-ts--reserved-keywords-re
+ (concat "^" (regexp-opt elixir-ts--reserved-keywords) "$"))
+
+(defconst elixir-ts--reserved-keywords-vector
+ (apply #'vector elixir-ts--reserved-keywords))
+
+(defvar elixir-ts--capture-anonymous-function-end
+ (when (treesit-available-p)
+ (treesit-query-compile 'elixir '((anonymous_function "end" @end)))))
+
+(defvar elixir-ts--capture-operator-parent
+ (when (treesit-available-p)
+ (treesit-query-compile 'elixir '((binary_operator operator: _ @val)))))
+
+(defvar elixir-ts--syntax-table
+ (let ((table (make-syntax-table)))
+ (modify-syntax-entry ?| "." table)
+ (modify-syntax-entry ?- "." table)
+ (modify-syntax-entry ?+ "." table)
+ (modify-syntax-entry ?* "." table)
+ (modify-syntax-entry ?/ "." table)
+ (modify-syntax-entry ?< "." table)
+ (modify-syntax-entry ?> "." table)
+ (modify-syntax-entry ?_ "_" table)
+ (modify-syntax-entry ?? "w" table)
+ (modify-syntax-entry ?~ "w" table)
+ (modify-syntax-entry ?! "_" table)
+ (modify-syntax-entry ?' "\"" table)
+ (modify-syntax-entry ?\" "\"" table)
+ (modify-syntax-entry ?# "<" table)
+ (modify-syntax-entry ?\n ">" table)
+ (modify-syntax-entry ?\( "()" table)
+ (modify-syntax-entry ?\) ")(" table)
+ (modify-syntax-entry ?\{ "(}" table)
+ (modify-syntax-entry ?\} "){" table)
+ (modify-syntax-entry ?\[ "(]" table)
+ (modify-syntax-entry ?\] ")[" table)
+ (modify-syntax-entry ?: "'" table)
+ (modify-syntax-entry ?@ "'" table)
+ table)
+ "Syntax table for `elixir-ts-mode'.")
+
+(defun elixir-ts--argument-indent-offset (node _parent &rest _)
+ "Return the argument offset position for NODE."
+ (if (or (treesit-node-prev-sibling node t)
+ ;; Don't indent if this is the first node or
+ ;; if the line is empty.
+ (save-excursion
+ (beginning-of-line)
+ (looking-at-p "[[:blank:]]*$")))
+ 0 elixir-ts-indent-offset))
+
+(defun elixir-ts--argument-indent-anchor (node parent &rest _)
+ "Return the argument anchor position for NODE and PARENT."
+ (let ((first-sibling (treesit-node-child parent 0 t)))
+ (if (and first-sibling (not (treesit-node-eq first-sibling node)))
+ (treesit-node-start first-sibling)
+ (elixir-ts--parent-expression-start node parent))))
+
+(defun elixir-ts--parent-expression-start (_node parent &rest _)
+ "Return the indentation expression start for NODE and PARENT."
+ ;; If the parent is the first expression on the line return the
+ ;; parent start of node position, otherwise use the parent call
+ ;; start if available.
+ (if (eq (treesit-node-start parent)
+ (save-excursion
+ (goto-char (treesit-node-start parent))
+ (back-to-indentation)
+ (point)))
+ (treesit-node-start parent)
+ (let ((expr-parent
+ (treesit-parent-until
+ parent
+ (lambda (n)
+ (member (treesit-node-type n)
+ '("call" "binary_operator" "keywords" "list"))))))
+ (save-excursion
+ (goto-char (treesit-node-start expr-parent))
+ (back-to-indentation)
+ (if (looking-at "|>")
+ (point)
+ (treesit-node-start expr-parent))))))
+
+(defvar elixir-ts--indent-rules
+ (let ((offset elixir-ts-indent-offset))
+ `((elixir
+ ((parent-is "^source$") column-0 0)
+ ((parent-is "^string$") parent-bol 0)
+ ((parent-is "^quoted_content$")
+ (lambda (_n parent bol &rest _)
+ (save-excursion
+ (back-to-indentation)
+ (if (bolp)
+ (progn
+ (goto-char (treesit-node-start parent))
+ (back-to-indentation)
+ (point))
+ (point))))
+ 0)
+ ((node-is "^|>$") parent-bol 0)
+ ((node-is "^|$") parent-bol 0)
+ ((node-is "^]$") ,'elixir-ts--parent-expression-start 0)
+ ((node-is "^}$") ,'elixir-ts--parent-expression-start 0)
+ ((node-is "^)$") ,'elixir-ts--parent-expression-start 0)
+ ((node-is "^>>$") ,'elixir-ts--parent-expression-start 0)
+ ((node-is "^else_block$") grand-parent 0)
+ ((node-is "^catch_block$") grand-parent 0)
+ ((node-is "^rescue_block$") grand-parent 0)
+ ((node-is "^after_block$") grand-parent 0)
+ ((parent-is "^else_block$") parent ,offset)
+ ((parent-is "^catch_block$") parent ,offset)
+ ((parent-is "^rescue_block$") parent ,offset)
+ ((parent-is "^rescue_block$") parent ,offset)
+ ((parent-is "^after_block$") parent ,offset)
+ ((parent-is "^access_call$")
+ ,'elixir-ts--argument-indent-anchor
+ ,'elixir-ts--argument-indent-offset)
+ ((parent-is "^tuple$")
+ ,'elixir-ts--argument-indent-anchor
+ ,'elixir-ts--argument-indent-offset)
+ ((parent-is "^list$")
+ ,'elixir-ts--argument-indent-anchor
+ ,'elixir-ts--argument-indent-offset)
+ ((parent-is "^pair$") parent ,offset)
+ ((parent-is "^bitstring$") parent ,offset)
+ ((parent-is "^map_content$") parent-bol 0)
+ ((parent-is "^map$") ,'elixir-ts--parent-expression-start ,offset)
+ ((node-is "^stab_clause$") parent-bol ,offset)
+ ((query ,elixir-ts--capture-operator-parent) grand-parent 0)
+ ((node-is "^when$") parent 0)
+ ((parent-is "^body$")
+ (lambda (node parent _)
+ (save-excursion
+ ;; The grammar adds a comment outside of the body, so we have to indent
+ ;; to the grand-parent if it is available.
+ (goto-char (treesit-node-start
+ (or (treesit-node-parent parent) (parent))))
+ (back-to-indentation)
+ (point)))
+ ,offset)
+ ((parent-is "^arguments$")
+ ,'elixir-ts--argument-indent-anchor
+ ,'elixir-ts--argument-indent-offset)
+ ;; Handle incomplete maps when parent is ERROR.
+ ((node-is "^keywords$") parent-bol ,offset)
+ ((n-p-gp "^binary_operator$" "ERROR" nil) parent-bol 0)
+ ;; When there is an ERROR, just indent to prev-line.
+ ((parent-is "ERROR") prev-line ,offset)
+ ((node-is "^binary_operator$")
+ (lambda (node parent &rest _)
+ (let ((top-level
+ (treesit-parent-while
+ node
+ (lambda (node)
+ (equal (treesit-node-type node)
+ "binary_operator")))))
+ (if (treesit-node-eq top-level node)
+ (elixir-ts--parent-expression-start node parent)
+ (treesit-node-start top-level))))
+ (lambda (node parent _)
+ (cond
+ ((equal (treesit-node-type parent) "do_block")
+ ,offset)
+ ((equal (treesit-node-type parent) "binary_operator")
+ ,offset)
+ (t 0))))
+ ((parent-is "^binary_operator$")
+ (lambda (node parent bol &rest _)
+ (treesit-node-start
+ (treesit-parent-while
+ parent
+ (lambda (node)
+ (equal (treesit-node-type node) "binary_operator")))))
+ ,offset)
+ ((node-is "^pair$") first-sibling 0)
+ ((query ,elixir-ts--capture-anonymous-function-end) parent-bol 0)
+ ((node-is "^end$") standalone-parent 0)
+ ((parent-is "^do_block$") grand-parent ,offset)
+ ((parent-is "^anonymous_function$")
+ elixir-ts--treesit-anchor-grand-parent-bol ,offset)
+ ((parent-is "^else_block$") parent ,offset)
+ ((parent-is "^rescue_block$") parent ,offset)
+ ((parent-is "^catch_block$") parent ,offset)
+ ((parent-is "^keywords$") parent-bol 0)
+ ((node-is "^call$") parent-bol ,offset)
+ ((node-is "^comment$") parent-bol ,offset)
+ ((node-is "\"\"\"") parent-bol 0)
+ ;; Handle quoted_content indentation on the last
+ ;; line before the closing \"\"\", where it might
+ ;; see it as no-node outside a HEEx tag.
+ (no-node (lambda (_n _p _bol)
+ (treesit-node-start
+ (treesit-node-parent
+ (treesit-node-at (point) 'elixir))))
+ 0)))))
+
+(defvar elixir-ts--font-lock-settings
+ (treesit-font-lock-rules
+ :language 'elixir
+ :feature 'elixir-definition
+ `((call target: (identifier) @target-identifier
+ (arguments
+ (call target: (identifier) @font-lock-function-name-face
+ (arguments)))
+ (:match ,elixir-ts--definition-keywords-re @target-identifier))
+ (call target: (identifier) @target-identifier
+ (arguments (identifier) @font-lock-function-name-face)
+ (:match ,elixir-ts--definition-keywords-re @target-identifier))
+ (call target: (identifier) @target-identifier
+ (arguments
+ (call target: (identifier) @font-lock-function-name-face
+ (arguments ((identifier)) @font-lock-variable-name-face)))
+ (:match ,elixir-ts--definition-keywords-re @target-identifier))
+ (call target: (identifier) @target-identifier
+ (arguments
+ (binary_operator
+ left: (call target: (identifier) @font-lock-function-name-face)))
+ (:match ,elixir-ts--definition-keywords-re @target-identifier))
+ (call target: (identifier) @target-identifier
+ (arguments (identifier) @font-lock-function-name-face)
+ (do_block)
+ (:match ,elixir-ts--definition-keywords-re @target-identifier))
+ (call target: (identifier) @target-identifier
+ (arguments
+ (call target: (identifier) @font-lock-function-name-face
+ (arguments ((identifier)) @font-lock-variable-name-face)))
+ (do_block)
+ (:match ,elixir-ts--definition-keywords-re @target-identifier))
+ (call target: (identifier) @target-identifier
+ (arguments
+ (binary_operator
+ left: (call target: (identifier) @font-lock-function-name-face
+ (arguments ((identifier)) @font-lock-variable-name-face))))
+ (do_block)
+ (:match ,elixir-ts--definition-keywords-re @target-identifier))
+ (unary_operator
+ operator: "@"
+ (call (arguments
+ (binary_operator
+ left: (call target: (identifier) @font-lock-function-name-face))))))
+
+ ;; A function definition like "def _foo" is valid, but we should
+ ;; not apply the comment-face unless its a non-function identifier, so
+ ;; the comment matches has to be after the function matches.
+ :language 'elixir
+ :feature 'elixir-comment
+ '((comment) @font-lock-comment-face
+ ((identifier) @font-lock-comment-face
+ (:match "^_[a-z]\\|^_$" @font-lock-comment-face)))
+
+ :language 'elixir
+ :feature 'elixir-variable
+ `((call target: (identifier)
+ (arguments
+ (binary_operator
+ (call target: (identifier)
+ (arguments ((identifier) @font-lock-variable-use-face))))))
+ (call target: (identifier)
+ (arguments
+ (call target: (identifier)
+ (arguments ((identifier)) @font-lock-variable-use-face))))
+ (dot left: (identifier) @font-lock-variable-use-face operator: "." ))
+
+ :language 'elixir
+ :feature 'elixir-doc
+ `((unary_operator
+ operator: "@" @elixir-ts-comment-doc-attribute
+ operand: (call
+ target: (identifier) @elixir-ts-comment-doc-identifier
+ ;; Arguments can be optional, so adding another
+ ;; entry without arguments.
+ ;; If we don't handle then we don't apply font
+ ;; and the non doc fortification query will take specify
+ ;; a more specific font which takes precedence.
+ (arguments
+ [
+ (string) @font-lock-doc-face
+ (charlist) @font-lock-doc-face
+ (sigil) @font-lock-doc-face
+ (boolean) @font-lock-doc-face
+ (keywords) @font-lock-doc-face
+ ]))
+ (:match ,elixir-ts--doc-keywords-re
+ @elixir-ts-comment-doc-identifier))
+ (unary_operator
+ operator: "@" @elixir-ts-comment-doc-attribute
+ operand: (call
+ target: (identifier) @elixir-ts-comment-doc-identifier)
+ (:match ,elixir-ts--doc-keywords-re
+ @elixir-ts-comment-doc-identifier)))
+
+ :language 'elixir
+ :feature 'elixir-string
+ '((interpolation
+ "#{" @font-lock-escape-face
+ "}" @font-lock-escape-face)
+ (string (quoted_content) @font-lock-string-face)
+ (quoted_keyword (quoted_content) @font-lock-string-face)
+ (charlist (quoted_content) @font-lock-string-face)
+ ["\"" "'" "\"\"\""] @font-lock-string-face)
+
+ :language 'elixir
+ :feature 'elixir-sigil
+ `((sigil
+ (sigil_name) @elixir-ts-sigil-name
+ (quoted_content) @font-lock-string-face
+ ;; HEEx and Surface templates will handled by
+ ;; heex-ts-mode if its available.
+ (:match "^[^HF]$" @elixir-ts-sigil-name))
+ @font-lock-string-face
+ (sigil
+ (sigil_name) @font-lock-regexp-face
+ (:match "^[rR]$" @font-lock-regexp-face))
+ @font-lock-regexp-face
+ (sigil
+ "~" @font-lock-string-face
+ (sigil_name) @font-lock-string-face
+ quoted_start: _ @font-lock-string-face
+ quoted_end: _ @font-lock-string-face))
+
+ :language 'elixir
+ :feature 'elixir-operator
+ `(["!"] @font-lock-negation-char-face
+ ["%"] @font-lock-bracket-face
+ ["," ";"] @font-lock-operator-face
+ ["(" ")" "[" "]" "{" "}" "<<" ">>"] @font-lock-bracket-face)
+
+ :language 'elixir
+ :feature 'elixir-data-type
+ '([(atom) (alias)] @font-lock-type-face
+ (keywords (pair key: (keyword) @elixir-ts-keyword-key))
+ [(keyword) (quoted_keyword)] @elixir-ts-atom
+ [(boolean) (nil)] @elixir-ts-atom
+ (unary_operator operator: "@" @elixir-ts-attribute
+ operand: [
+ (identifier) @elixir-ts-attribute
+ (call target: (identifier)
+ @elixir-ts-attribute)
+ (boolean) @elixir-ts-attribute
+ (nil) @elixir-ts-attribute
+ ])
+ (operator_identifier) @font-lock-operator-face)
+
+ :language 'elixir
+ :feature 'elixir-keyword
+ `(,elixir-ts--reserved-keywords-vector
+ @font-lock-keyword-face
+ (binary_operator
+ operator: _ @font-lock-keyword-face
+ (:match ,elixir-ts--reserved-keywords-re @font-lock-keyword-face))
+ (binary_operator operator: _ @font-lock-operator-face)
+ (call
+ target: (identifier) @font-lock-keyword-face
+ (:match ,elixir-ts--definition-keywords-re @font-lock-keyword-face))
+ (call
+ target: (identifier) @font-lock-keyword-face
+ (:match ,elixir-ts--kernel-keywords-re @font-lock-keyword-face)))
+
+ :language 'elixir
+ :feature 'elixir-function-call
+ '((call target: (identifier) @font-lock-function-call-face)
+ (unary_operator operator: "&" @font-lock-operator-face
+ operand: (binary_operator
+ left: (identifier)
+ @font-lock-function-call-face
+ operator: "/" right: (integer)))
+ (call
+ target: (dot right: (identifier) @font-lock-function-call-face))
+ (unary_operator operator: "&" @font-lock-variable-use-face
+ operand: (integer) @font-lock-variable-use-face)
+ (unary_operator operator: "&" @font-lock-operator-face
+ operand: (list)))
+
+ :language 'elixir
+ :feature 'elixir-string-escape
+ :override t
+ `((escape_sequence) @font-lock-escape-face)
+
+ :language 'elixir
+ :feature 'elixir-number
+ '([(integer) (float)] @font-lock-number-face)
+
+ :language 'elixir
+ :feature 'elixir-variable
+ '((binary_operator left: (identifier) @font-lock-variable-use-face)
+ (binary_operator right: (identifier) @font-lock-variable-use-face)
+ (arguments ( (identifier) @font-lock-variable-use-face))
+ (tuple (identifier) @font-lock-variable-use-face)
+ (list (identifier) @font-lock-variable-use-face)
+ (pair value: (identifier) @font-lock-variable-use-face)
+ (body (identifier) @font-lock-variable-use-face)
+ (unary_operator operand: (identifier) @font-lock-variable-use-face)
+ (interpolation (identifier) @font-lock-variable-use-face)
+ (do_block (identifier) @font-lock-variable-use-face)
+ (access_call target: (identifier) @font-lock-variable-use-face)
+ (access_call "[" key: (identifier) @font-lock-variable-use-face "]"))
+
+ :language 'elixir
+ :feature 'elixir-builtin
+ :override t
+ `(((identifier) @font-lock-builtin-face
+ (:match ,elixir-ts--builtin-keywords-re
+ @font-lock-builtin-face))))
+
+ "Tree-sitter font-lock settings.")
+
+(defvar elixir-ts--treesit-range-rules
+ (when (treesit-available-p)
+ (treesit-range-rules
+ :embed 'heex
+ :host 'elixir
+ '((sigil (sigil_name) @name (:match "^[HF]$" @name) (quoted_content) @heex)))))
+
+(defvar heex-ts--sexp-regexp)
+(defvar heex-ts--indent-rules)
+(defvar heex-ts--font-lock-settings)
+
+(defun elixir-ts--forward-sexp (&optional arg)
+ "Move forward across one balanced expression (sexp).
+With ARG, do it many times. Negative ARG means move backward."
+ (or arg (setq arg 1))
+ (funcall
+ (if (> arg 0) #'treesit-end-of-thing #'treesit-beginning-of-thing)
+ (if (eq (treesit-language-at (point)) 'heex)
+ heex-ts--sexp-regexp
+ elixir-ts--sexp-regexp)
+ (abs arg)))
+
+(defun elixir-ts--treesit-anchor-grand-parent-bol (_n parent &rest _)
+ "Return the beginning of non-space characters for the parent node of PARENT."
+ (save-excursion
+ (goto-char (treesit-node-start (treesit-node-parent parent)))
+ (back-to-indentation)
+ (point)))
+
+(defun elixir-ts--treesit-language-at-point (point)
+ "Return the language at POINT."
+ (let ((node (treesit-node-at point 'elixir)))
+ (if (and (equal (treesit-node-type node) "quoted_content")
+ (let ((prev-sibling (treesit-node-prev-sibling node t)))
+ (and (treesit-node-p prev-sibling)
+ (string-match-p
+ (rx bos (or "H" "F") eos)
+ (treesit-node-text prev-sibling)))))
+ 'heex
+ 'elixir)))
+
+(defun elixir-ts--defun-p (node)
+ "Return non-nil when NODE is a defun."
+ (member (treesit-node-text
+ (treesit-node-child-by-field-name node "target"))
+ (append
+ elixir-ts--definition-keywords
+ elixir-ts--test-definition-keywords)))
+
+(defun elixir-ts--defun-name (node)
+ "Return the name of the defun NODE.
+Return nil if NODE is not a defun node or doesn't have a name."
+ (pcase (treesit-node-type node)
+ ("call" (let ((node-child
+ (treesit-node-child (treesit-node-child node 1) 0)))
+ (pcase (treesit-node-type node-child)
+ ("alias" (treesit-node-text node-child t))
+ ("call" (treesit-node-text
+ (treesit-node-child-by-field-name node-child "target") t))
+ ("binary_operator"
+ (treesit-node-text
+ (treesit-node-child-by-field-name
+ (treesit-node-child-by-field-name node-child "left") "target")
+ t))
+ ("identifier"
+ (treesit-node-text node-child t))
+ (_ nil))))
+ (_ nil)))
+
+(defvar elixir-ts--syntax-propertize-query
+ (when (treesit-available-p)
+ (treesit-query-compile
+ 'elixir
+ '(((["\"\"\""] @quoted-text))))))
+
+(defun elixir-ts--syntax-propertize (start end)
+ "Apply syntax text properties between START and END for `elixir-ts-mode'."
+ (let ((captures
+ (treesit-query-capture 'elixir elixir-ts--syntax-propertize-query start end)))
+ (pcase-dolist (`(,name . ,node) captures)
+ (pcase-exhaustive name
+ ('quoted-text
+ (put-text-property (1- (treesit-node-end node)) (treesit-node-end node)
+ 'syntax-table (string-to-syntax "$")))))))
+
+(defun elixir-ts--electric-pair-string-delimiter ()
+ "Insert corresponding multi-line string for `electric-pair-mode'."
+ (when (and electric-pair-mode
+ (eq last-command-event ?\")
+ (let ((count 0))
+ (while (eq (char-before (- (point) count)) last-command-event)
+ (cl-incf count))
+ (= count 3))
+ (eq (char-after) last-command-event))
+ (save-excursion
+ (insert (make-string 2 last-command-event)))
+ (save-excursion
+ (newline 1 t))))
+
+;;;###autoload
+(define-derived-mode elixir-ts-mode prog-mode "Elixir"
+ "Major mode for editing Elixir, powered by tree-sitter."
+ :group 'elixir-ts
+ :syntax-table elixir-ts--syntax-table
+
+ ;; Comments.
+ (setq-local comment-start "# ")
+ (setq-local comment-start-skip
+ (rx "#" (* (syntax whitespace))))
+
+ (setq-local comment-end "")
+ (setq-local comment-end-skip
+ (rx (* (syntax whitespace))
+ (group (or (syntax comment-end) "\n"))))
+
+ ;; Compile.
+ (setq-local compile-command "mix")
+
+ ;; Electric pair.
+ (add-hook 'post-self-insert-hook
+ #'elixir-ts--electric-pair-string-delimiter 'append t)
+
+ (when (treesit-ready-p 'elixir)
+ ;; The HEEx parser has to be created first for elixir to ensure elixir
+ ;; is the first language when looking for treesit ranges.
+ (when (treesit-ready-p 'heex)
+ ;; Require heex-ts-mode only when we load elixir-ts-mode
+ ;; so that we don't get a tree-sitter compilation warning for
+ ;; elixir-ts-mode.
+ (require 'heex-ts-mode)
+ (treesit-parser-create 'heex))
+
+ (treesit-parser-create 'elixir)
+
+ (setq-local treesit-language-at-point-function
+ 'elixir-ts--treesit-language-at-point)
+
+ ;; Font-lock.
+ (setq-local treesit-font-lock-settings elixir-ts--font-lock-settings)
+ (setq-local treesit-font-lock-feature-list
+ '(( elixir-comment elixir-doc elixir-definition)
+ ( elixir-string elixir-keyword elixir-data-type)
+ ( elixir-sigil elixir-builtin elixir-string-escape)
+ ( elixir-function-call elixir-variable elixir-operator elixir-number )))
+
+
+ ;; Imenu.
+ (setq-local treesit-simple-imenu-settings
+ '((nil "\\`call\\'" elixir-ts--defun-p nil)))
+
+ ;; Indent.
+ (setq-local treesit-simple-indent-rules elixir-ts--indent-rules)
+
+ ;; Navigation.
+ (setq-local forward-sexp-function #'elixir-ts--forward-sexp)
+ (setq-local treesit-defun-type-regexp
+ '("call" . elixir-ts--defun-p))
+
+ (setq-local treesit-defun-name-function #'elixir-ts--defun-name)
+
+ ;; Embedded Heex.
+ (when (treesit-ready-p 'heex)
+ (setq-local treesit-range-settings elixir-ts--treesit-range-rules)
+
+ (setq-local treesit-simple-indent-rules
+ (append treesit-simple-indent-rules heex-ts--indent-rules))
+
+ (setq-local treesit-font-lock-settings
+ (append treesit-font-lock-settings
+ heex-ts--font-lock-settings))
+
+ (setq-local treesit-simple-indent-rules
+ (append treesit-simple-indent-rules
+ heex-ts--indent-rules))
+
+ (setq-local treesit-font-lock-feature-list
+ '(( elixir-comment elixir-doc elixir-definition
+ heex-comment heex-keyword heex-doctype )
+ ( elixir-string elixir-keyword elixir-data-type
+ heex-component heex-tag heex-attribute heex-string )
+ ( elixir-sigil elixir-builtin elixir-string-escape)
+ ( elixir-function-call elixir-variable elixir-operator elixir-number ))))
+
+ (treesit-major-mode-setup)
+ (setq-local syntax-propertize-function #'elixir-ts--syntax-propertize)))
+
+(derived-mode-add-parents 'elixir-ts-mode '(elixir-mode))
+
+(if (treesit-ready-p 'elixir)
+ (progn
+ (add-to-list 'auto-mode-alist '("\\.elixir\\'" . elixir-ts-mode))
+ (add-to-list 'auto-mode-alist '("\\.ex\\'" . elixir-ts-mode))
+ (add-to-list 'auto-mode-alist '("\\.exs\\'" . elixir-ts-mode))
+ (add-to-list 'auto-mode-alist '("mix\\.lock" . elixir-ts-mode))))
+
+(provide 'elixir-ts-mode)
+
+;;; elixir-ts-mode.el ends here
diff --git a/lisp/progmodes/erts-mode.el b/lisp/progmodes/erts-mode.el
index cc9822aaa32..0cb77b30a75 100644
--- a/lisp/progmodes/erts-mode.el
+++ b/lisp/progmodes/erts-mode.el
@@ -181,7 +181,8 @@ expected results and the actual results in a separate buffer."
(ert-test--erts-test
(list (cons 'dummy t)
(cons 'code (car (read-from-string test-function)))
- (cons 'point-char (erts-mode--preceding-spec "Point-Char")))
+ (cons 'point-char (save-match-data
+ (erts-mode--preceding-spec "Point-Char"))))
(buffer-file-name))
(:success (message "Test successful"))
(ert-test-failed
diff --git a/lisp/progmodes/etags-regen.el b/lisp/progmodes/etags-regen.el
new file mode 100644
index 00000000000..6cd78d3577a
--- /dev/null
+++ b/lisp/progmodes/etags-regen.el
@@ -0,0 +1,431 @@
+;;; etags-regen.el --- Auto-(re)regenerating tags -*- lexical-binding: t -*-
+
+;; Copyright (C) 2021-2023 Free Software Foundation, Inc.
+
+;; Author: Dmitry Gutov <dmitry@gutov.dev>
+;; 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 <https://www.gnu.org/licenses/>.
+
+;;; Commentary:
+
+;; Simple automatic tags generation with updates on save.
+;;
+;; This mode provides automatic indexing for Emacs "go to definition"
+;; feature, the `xref-go-forward' command (bound to `M-.' by default).
+;;
+;; At the moment reindexing works off before/after-save-hook, but to
+;; handle more complex changes (for example, the user switching to
+;; another branch from the terminal) we can look into plugging into
+;; something like `filenotify'.
+;;
+;; Note that this feature disables itself if the user has some tags
+;; table already visited (with `M-x visit-tags-table', or through an
+;; explicit prompt triggered by some feature that requires tags).
+
+;;; Code:
+
+(require 'cl-lib)
+
+(defgroup etags-regen nil
+ "Auto-(re)generating tags."
+ :group 'tools)
+
+(defvar etags-regen--tags-file nil)
+(defvar etags-regen--tags-root nil)
+(defvar etags-regen--new-file nil)
+
+(declare-function project-root "project")
+(declare-function project-files "project")
+(declare-function dired-glob-regexp "dired")
+
+(defcustom etags-regen-program (executable-find "etags")
+ "Name of the etags program used by `etags-regen-mode'.
+
+If you only have `ctags' installed, you can also set this to
+\"ctags -e\". Some features might not be supported this way."
+ ;; Always having our 'etags' here would be easier, but we can't
+ ;; always rely on it being installed. So it might be ctags's etags.
+ :type 'file
+ :version "30.1")
+
+(defcustom etags-regen-tags-file "TAGS"
+ "Name of the tags file to create inside the project by `etags-regen-mode'.
+
+The value should either be a simple file name (no directory
+specified), or a function that accepts the project root directory
+and returns a distinct absolute file name for its tags file. The
+latter possibility is useful when you prefer to store the tag
+files somewhere else, for example in `temporary-file-directory'."
+ :type '(choice (string :tag "File name")
+ (function :tag "Function that returns file name"))
+ :version "30.1")
+
+(defcustom etags-regen-program-options nil
+ "List of additional options for etags program invoked by `etags-regen-mode'."
+ :type '(repeat string)
+ :version "30.1")
+
+(defcustom etags-regen-regexp-alist nil
+ "Mapping of languages to etags regexps for `etags-regen-mode'.
+
+These regexps are used in addition to the tags made with the
+standard parsing based on the language.
+
+The value must be a list where each element has the
+form (LANGUAGES . TAG-REGEXPS) where both LANGUAGES and
+TAG-REGEXPS are lists of strings.
+
+Each language should be one of the recognized by etags, see
+`etags --help'. Each tag regexp should be a string in the format
+documented for the `--regex' arguments (without `{language}').
+
+We currently support only Emacs's etags program with this option."
+ :type '(repeat
+ (cons
+ :tag "Languages group"
+ (repeat (string :tag "Language name"))
+ (repeat (string :tag "Tag Regexp"))))
+ :version "30.1")
+
+;;;###autoload
+(put 'etags-regen-regexp-alist 'safe-local-variable
+ (lambda (value)
+ (and (listp value)
+ (seq-every-p
+ (lambda (group)
+ (and (consp group)
+ (listp (car group))
+ (listp (cdr group))
+ (seq-every-p #'stringp (car group))
+ (seq-every-p #'stringp (cdr group))))
+ value))))
+
+;; We have to list all extensions: etags falls back to Fortran
+;; when it cannot determine the type of the file.
+;; http://lists.gnu.org/archive/html/emacs-devel/2018-01/msg00323.html
+(defcustom etags-regen-file-extensions
+ '("rb" "js" "py" "pl" "el" "c" "cpp" "cc" "h" "hh" "hpp"
+ "java" "go" "cl" "lisp" "prolog" "php" "erl" "hrl"
+ "F" "f" "f90" "for" "cs" "a" "asm" "ads" "adb" "ada")
+ "Code file extensions for `etags-regen-mode'.
+
+File extensions to generate the tags for."
+ :type '(repeat (string :tag "File extension"))
+ :version "30.1")
+
+;;;###autoload
+(put 'etags-regen-file-extensions 'safe-local-variable
+ (lambda (value) (and (listp value) (seq-every-p #'stringp value))))
+
+;; FIXME: We don't support root anchoring yet.
+(defcustom etags-regen-ignores nil
+ "Additional ignore rules, in the format of `project-ignores'."
+ :type '(repeat
+ (string :tag "Glob to ignore"))
+ :version "30.1")
+
+;;;###autoload
+(put 'etags-regen-ignores 'safe-local-variable
+ (lambda (value) (and (listp value) (seq-every-p #'stringp value))))
+
+(defvar etags-regen--errors-buffer-name "*etags-regen-tags-errors*")
+
+(defvar etags-regen--rescan-files-limit 100)
+
+(defun etags-regen--all-mtimes (proj)
+ (let ((files (etags-regen--all-files proj))
+ (mtimes (make-hash-table :test 'equal))
+ file-name-handler-alist)
+ (dolist (f files)
+ (condition-case nil
+ (puthash f
+ (file-attribute-modification-time
+ (file-attributes f))
+ mtimes)
+ (file-missing nil)))
+ mtimes))
+
+(defun etags-regen--choose-tags-file (proj)
+ (if (functionp etags-regen-tags-file)
+ (funcall etags-regen-tags-file (project-root proj))
+ (expand-file-name etags-regen-tags-file (project-root proj))))
+
+(defun etags-regen--refresh (proj)
+ (save-excursion
+ (let* ((tags-file (etags-regen--choose-tags-file proj))
+ (tags-mtime (file-attribute-modification-time
+ (file-attributes tags-file)))
+ (all-mtimes (etags-regen--all-mtimes proj))
+ added-files
+ changed-files
+ removed-files)
+ (etags-regen--visit-table tags-file (project-root proj))
+ (set-buffer (get-file-buffer tags-file))
+ (dolist (file (tags-table-files))
+ (let ((mtime (gethash file all-mtimes)))
+ (cond
+ ((null mtime)
+ (push file removed-files))
+ ((time-less-p tags-mtime mtime)
+ (push file changed-files)
+ (remhash file all-mtimes))
+ (t
+ (remhash file all-mtimes)))))
+ (maphash
+ (lambda (key _value)
+ (push key added-files))
+ all-mtimes)
+ (if (> (+ (length added-files)
+ (length changed-files)
+ (length removed-files))
+ etags-regen--rescan-files-limit)
+ (progn
+ (message "etags-regen: Too many changes, falling back to full rescan")
+ (etags-regen--tags-cleanup))
+ (dolist (file (nconc removed-files changed-files))
+ (etags-regen--remove-tag file))
+ (when (or changed-files added-files)
+ (apply #'etags-regen--append-tags
+ (nconc changed-files added-files)))
+ (when (or changed-files added-files removed-files)
+ (let ((save-silently t)
+ (message-log-max nil))
+ (save-buffer 0)))))))
+
+(defun etags-regen--maybe-generate ()
+ (let (proj)
+ (when (and etags-regen--tags-root
+ (not (file-in-directory-p default-directory
+ etags-regen--tags-root)))
+ (etags-regen--tags-cleanup))
+ (when (and (not etags-regen--tags-root)
+ ;; If existing table is visited that's not generated by
+ ;; this mode, skip all functionality.
+ (not (or tags-file-name
+ tags-table-list))
+ (file-exists-p (etags-regen--choose-tags-file
+ (setq proj (project-current)))))
+ (message "Found existing tags table, refreshing...")
+ (etags-regen--refresh proj))
+ (when (and (not (or tags-file-name
+ tags-table-list))
+ (setq proj (or proj (project-current))))
+ (message "Generating new tags table...")
+ (let ((start (time-to-seconds)))
+ (etags-regen--tags-generate proj)
+ (message "...done (%.2f s)" (- (time-to-seconds) start))))))
+
+(defun etags-regen--all-files (proj)
+ (let* ((root (project-root proj))
+ (default-directory root)
+ ;; TODO: Make the scanning more efficient, e.g. move the
+ ;; filtering by glob to project (project-files-filtered...).
+ (files (project-files proj))
+ (match-re (concat
+ "\\."
+ (regexp-opt etags-regen-file-extensions)
+ "\\'"))
+ (ir-start (1- (length root)))
+ (ignores-regexps
+ (mapcar #'etags-regen--ignore-regexp
+ etags-regen-ignores)))
+ (cl-delete-if
+ (lambda (f) (or (not (string-match-p match-re f))
+ (string-match-p "/\\.#" f) ;Backup files.
+ (cl-some (lambda (ignore) (string-match ignore f ir-start))
+ ignores-regexps)))
+ files)))
+
+(defun etags-regen--ignore-regexp (ignore)
+ (require 'dired)
+ ;; It's somewhat brittle to rely on Dired.
+ (let ((re (dired-glob-regexp ignore)))
+ ;; We could implement root anchoring here, but \\= doesn't work in
+ ;; string-match :-(.
+ (concat (unless (eq ?/ (aref re 3)) "/")
+ ;; Cutting off the anchors added by `dired-glob-regexp'.
+ (substring re 2 (- (length re) 2))
+ ;; This way we allow a glob to match against a directory
+ ;; name, or a file name. And when it ends with / already,
+ ;; no need to add the anchoring.
+ (unless (eq ?/ (aref re (- (length re) 3)))
+ ;; Either match a full name segment, or eos.
+ "\\(?:/\\|\\'\\)"))))
+
+(defun etags-regen--tags-generate (proj)
+ (let* ((root (project-root proj))
+ (default-directory root)
+ (files (etags-regen--all-files proj))
+ (tags-file (etags-regen--choose-tags-file proj))
+ (ctags-p (etags-regen--ctags-p))
+ (command (format "%s %s %s - -o %s"
+ etags-regen-program
+ (mapconcat #'identity
+ (etags-regen--build-program-options ctags-p)
+ " ")
+ ;; ctags's etags requires '-L' for stdin input.
+ (if ctags-p "-L" "")
+ tags-file)))
+ (with-temp-buffer
+ (mapc (lambda (f)
+ (insert f "\n"))
+ files)
+ (shell-command-on-region (point-min) (point-max) command
+ nil nil etags-regen--errors-buffer-name t))
+ (etags-regen--visit-table tags-file root)))
+
+(defun etags-regen--visit-table (tags-file root)
+ ;; Invalidate the scanned tags after any change is written to disk.
+ (add-hook 'after-save-hook #'etags-regen--update-file)
+ (add-hook 'before-save-hook #'etags-regen--mark-as-new)
+ (setq etags-regen--tags-file tags-file
+ etags-regen--tags-root root)
+ (visit-tags-table etags-regen--tags-file))
+
+(defun etags-regen--ctags-p ()
+ (string-search "Ctags"
+ (shell-command-to-string
+ (format "%s --version" etags-regen-program))))
+
+(defun etags-regen--build-program-options (ctags-p)
+ (when (and etags-regen-regexp-alist ctags-p)
+ (user-error "etags-regen-regexp-alist is not supported with Ctags"))
+ (nconc
+ (mapcan
+ (lambda (group)
+ (mapcan
+ (lambda (lang)
+ (mapcar (lambda (regexp)
+ (concat "--regex="
+ (shell-quote-argument
+ (format "{%s}%s" lang regexp))))
+ (cdr group)))
+ (car group)))
+ etags-regen-regexp-alist)
+ (mapcar #'shell-quote-argument
+ etags-regen-program-options)))
+
+(defun etags-regen--update-file ()
+ ;; TODO: Maybe only do this when Emacs is idle for a bit. Or defer
+ ;; the updates and do them later in bursts when the table is used.
+ (let* ((file-name buffer-file-name)
+ (tags-file-buf (and etags-regen--tags-root
+ (get-file-buffer etags-regen--tags-file)))
+ (relname (concat "/" (file-relative-name file-name
+ etags-regen--tags-root)))
+ (ignores etags-regen-ignores)
+ pr should-scan)
+ (save-excursion
+ (when tags-file-buf
+ (cond
+ ((and etags-regen--new-file
+ (kill-local-variable 'etags-regen--new-file)
+ (setq pr (project-current))
+ (equal (project-root pr) etags-regen--tags-root)
+ (member file-name (project-files pr)))
+ (set-buffer tags-file-buf)
+ (setq should-scan t))
+ ((progn (set-buffer tags-file-buf)
+ (etags-regen--remove-tag file-name))
+ (setq should-scan t))))
+ (when (and should-scan
+ (not (cl-some
+ (lambda (ignore)
+ (string-match-p
+ (etags-regen--ignore-regexp ignore)
+ relname))
+ ignores)))
+ (etags-regen--append-tags file-name)
+ (let ((save-silently t)
+ (message-log-max nil))
+ (save-buffer 0))))))
+
+(defun etags-regen--remove-tag (file-name)
+ (goto-char (point-min))
+ (when (search-forward (format "\f\n%s," file-name) nil t)
+ (let ((start (match-beginning 0)))
+ (search-forward "\f\n" nil 'move)
+ (let ((inhibit-read-only t))
+ (delete-region start
+ (if (eobp)
+ (point)
+ (- (point) 2)))))
+ t))
+
+(defun etags-regen--append-tags (&rest file-names)
+ (goto-char (point-max))
+ (let ((options (etags-regen--build-program-options (etags-regen--ctags-p)))
+ (inhibit-read-only t))
+ ;; XXX: call-process is significantly faster, though.
+ ;; Like 10ms vs 20ms here. But `shell-command' makes it easy to
+ ;; direct stderr to a separate buffer.
+ (shell-command
+ (format "%s %s %s -o -"
+ etags-regen-program (mapconcat #'identity options " ")
+ (mapconcat #'identity file-names " "))
+ t etags-regen--errors-buffer-name))
+ ;; FIXME: Is there a better way to do this?
+ ;; Completion table is the only remaining place where the
+ ;; update is not incremental.
+ (setq-default tags-completion-table nil))
+
+(defun etags-regen--mark-as-new ()
+ (when (and etags-regen--tags-root
+ (not buffer-file-number))
+ (setq-local etags-regen--new-file t)))
+
+(defun etags-regen--tags-cleanup ()
+ (when etags-regen--tags-file
+ (let ((buffer (get-file-buffer etags-regen--tags-file)))
+ (and buffer
+ (kill-buffer buffer)))
+ (tags-reset-tags-tables)
+ (setq tags-file-name nil
+ tags-table-list nil
+ etags-regen--tags-file nil
+ etags-regen--tags-root nil))
+ (remove-hook 'after-save-hook #'etags-regen--update-file)
+ (remove-hook 'before-save-hook #'etags-regen--mark-as-new))
+
+(defvar etags-regen-mode-map (make-sparse-keymap))
+
+;;;###autoload
+(define-minor-mode etags-regen-mode
+ "Minor mode to automatically generate and update tags tables.
+
+This minor mode generates the tags table automatically based on
+the current project configuration, and later updates it as you
+edit the files and save the changes.
+
+If you select a tags table manually (for example, using
+\\[visit-tags-table]), then this mode will be effectively
+disabled for the entire session. Use \\[tags-reset-tags-tables]
+to countermand the effect of a previous \\[visit-tags-table]."
+ :global t
+ (if etags-regen-mode
+ (progn
+ (advice-add 'etags--xref-backend :before
+ #'etags-regen--maybe-generate)
+ (advice-add 'tags-completion-at-point-function :before
+ #'etags-regen--maybe-generate))
+ (advice-remove 'etags--xref-backend #'etags-regen--maybe-generate)
+ (advice-remove 'tags-completion-at-point-function #'etags-regen--maybe-generate)
+ (etags-regen--tags-cleanup)))
+
+(provide 'etags-regen)
+
+;;; etags-regen.el ends here
diff --git a/lisp/progmodes/etags.el b/lisp/progmodes/etags.el
index 370dcb17df8..597612196fd 100644
--- a/lisp/progmodes/etags.el
+++ b/lisp/progmodes/etags.el
@@ -732,6 +732,7 @@ Returns t if it visits a tags table, or nil if there are no more in the list."
"File %s does not exist")
local-tags-file-name)))))
+;;;###autoload
(defun tags-reset-tags-tables ()
"Reset tags state to cancel effect of any previous \\[visit-tags-table] or \\[find-tag]."
(interactive)
@@ -1487,7 +1488,7 @@ hits the start of file."
(setq symbs (symbol-value symbs))
(insert (format-message "symbol `%s' has no value\n" symbs))
(setq symbs nil)))
- (if (vectorp symbs)
+ (if (obarrayp symbs)
(mapatoms ins-symb symbs)
(dolist (sy symbs)
(funcall ins-symb (car sy))))
@@ -1729,6 +1730,21 @@ if the file was newly read in, the value is the filename."
(fileloop-next-file novisit)
(switch-to-buffer (current-buffer)))
+(defun etags--ensure-file (file)
+ "Ensure FILE can be visited.
+
+FILE should be an expanded file name.
+This function tries to locate FILE, possibly adding it a suffix
+present in `tags-compression-info-list'. If the file can't be found,
+signals an error.
+Else, returns the filename that can be visited for sure."
+ (let ((f (locate-file file nil (if auto-compression-mode
+ tags-compression-info-list
+ '("")))))
+ (unless f
+ (signal 'file-missing (list "Cannot locate file in TAGS" file)))
+ f))
+
(defun tags--all-files ()
(save-excursion
(let ((cbuf (current-buffer))
@@ -1750,7 +1766,7 @@ if the file was newly read in, the value is the filename."
;; list later returned by (tags-table-files).
(setf (if tail (cdr tail) files)
(mapcar #'expand-file-name (tags-table-files)))))
- files)))
+ (mapcar #'etags--ensure-file files))))
(make-obsolete-variable 'tags-loop-operate 'fileloop-initialize "27.1")
(defvar tags-loop-operate nil
@@ -2049,7 +2065,8 @@ for \\[find-tag] (which see)."
(user-error "%s"
(substitute-command-keys
"No tags table loaded; try \\[visit-tags-table]")))
- (let ((comp-data (tags-completion-at-point-function)))
+ (let ((comp-data (tags-completion-at-point-function))
+ (completion-ignore-case (find-tag--completion-ignore-case)))
(if (null comp-data)
(user-error "Nothing to complete")
(completion-in-region (car comp-data) (cadr comp-data)
@@ -2137,7 +2154,7 @@ file name, add `tag-partial-file-name-match-p' to the list value.")
(beginning-of-line)
(pcase-let* ((tag-info (etags-snarf-tag))
(`(,hint ,line . _) tag-info))
- (let* ((file (file-of-tag))
+ (let* ((file (etags--ensure-file (file-of-tag)))
(mark-key (cons file line)))
(unless (gethash mark-key marks)
(let ((loc (xref-make-etags-location
@@ -2167,7 +2184,7 @@ file name, add `tag-partial-file-name-match-p' to the list value.")
(setq symbs (symbol-value symbs))
(warn "symbol `%s' has no value" symbs)
(setq symbs nil))
- (if (vectorp symbs)
+ (if (obarrayp symbs)
(mapatoms add-xref symbs)
(dolist (sy symbs)
(funcall add-xref (car sy))))
diff --git a/lisp/progmodes/f90.el b/lisp/progmodes/f90.el
index 6b76d905bb8..ec9d1995547 100644
--- a/lisp/progmodes/f90.el
+++ b/lisp/progmodes/f90.el
@@ -159,7 +159,6 @@
;; 3. Labels for "else" statements (F2003)?
(defvar comment-auto-fill-only-comments)
-(defvar font-lock-keywords)
;; User options
diff --git a/lisp/progmodes/flymake-proc.el b/lisp/progmodes/flymake-proc.el
index f8cac84500c..2c7bb542489 100644
--- a/lisp/progmodes/flymake-proc.el
+++ b/lisp/progmodes/flymake-proc.el
@@ -607,6 +607,9 @@ Create parent directories as needed."
(process-put proc 'flymake-proc--unprocessed-mark
(point-marker))))))))
+(defvar-local flymake-proc--temp-source-file-name nil)
+(defvar-local flymake-proc--temp-master-file-name nil)
+
(defun flymake-proc--process-sentinel (proc _event)
"Sentinel for syntax check buffers."
(let (debug
@@ -910,9 +913,7 @@ can also be executed interactively independently of
(file-truename (expand-file-name suffix temp-dir)))
(setq suffix (file-name-directory suffix)))))
-(defvar-local flymake-proc--temp-source-file-name nil)
(defvar-local flymake-proc--master-file-name nil)
-(defvar-local flymake-proc--temp-master-file-name nil)
(defvar-local flymake-proc--base-dir nil)
(defun flymake-proc-init-create-temp-buffer-copy (create-temp-f)
diff --git a/lisp/progmodes/flymake.el b/lisp/progmodes/flymake.el
index bb062753d39..779c612f479 100644
--- a/lisp/progmodes/flymake.el
+++ b/lisp/progmodes/flymake.el
@@ -4,9 +4,9 @@
;; Author: Pavel Kobyakov <pk_at_work@yahoo.com>
;; Maintainer: João Távora <joaotavora@gmail.com>
-;; Version: 1.2.2
+;; Version: 1.3.7
;; Keywords: c languages tools
-;; Package-Requires: ((emacs "26.1") (eldoc "1.1.0") (project "0.7.1"))
+;; Package-Requires: ((emacs "26.1") (eldoc "1.14.0") (project "0.7.1"))
;; This is a GNU ELPA :core package. Avoid functionality that is not
;; compatible with the version of Emacs recorded above.
@@ -114,7 +114,7 @@
(require 'thingatpt) ; end-of-thing
(require 'warnings) ; warning-numeric-level, display-warning
(require 'compile) ; for some faces
-;; We need the next require to avoid compiler warnings and run-time
+;; We need the next `require' to avoid compiler warnings and run-time
;; errors about mouse-wheel-up/down-event in builds --without-x, where
;; mwheel is not preloaded.
(require 'mwheel)
@@ -354,8 +354,13 @@ the diagnostic's type symbol."
If neither BEG or END is supplied, use whole accessible buffer,
otherwise if BEG is non-nil and END is nil, consider only
diagnostics at BEG."
- (mapcar (lambda (ov) (overlay-get ov 'flymake-diagnostic))
- (flymake--overlays :beg beg :end end)))
+ (save-restriction
+ (widen)
+ (cl-loop for o in
+ (cond (end (overlays-in beg end))
+ (beg (overlays-at beg))
+ (t (overlays-in (point-min) (point-max))))
+ when (overlay-get o 'flymake-diagnostic) collect it)))
(defmacro flymake--diag-accessor (public internal thing)
"Make PUBLIC an alias for INTERNAL, add doc using THING."
@@ -371,7 +376,21 @@ diagnostics at BEG."
(flymake--diag-accessor flymake-diagnostic-end flymake--diag-end end)
(flymake--diag-accessor flymake-diagnostic-buffer flymake--diag-locus locus)
-(cl-defun flymake--overlays (&key beg end filter compare key)
+(defun flymake-diagnostic-oneliner (diag &optional nopaintp)
+ "Get truncated one-line text string for diagnostic DIAG.
+This is useful for displaying the DIAG's text to the user in
+confined spaces, such as the echo are. Unless NOPAINTP is t,
+propertize returned text with the `echo-face' property of DIAG's
+type."
+ (let* ((txt (flymake-diagnostic-text diag))
+ (txt (substring txt 0 (cl-loop for i from 0 for a across txt
+ when (eq a ?\n) return i))))
+ (if nopaintp txt
+ (propertize txt 'face
+ (flymake--lookup-type-property
+ (flymake-diagnostic-type diag) 'echo-face 'flymake-error)))))
+
+(cl-defun flymake--really-all-overlays ()
"Get flymake-related overlays.
If BEG is non-nil and END is nil, consider only `overlays-at'
BEG. Otherwise consider `overlays-in' the region comprised by BEG
@@ -379,19 +398,8 @@ and END, defaulting to the whole buffer. Remove all that do not
verify FILTER, a function, and sort them by COMPARE (using KEY)."
(save-restriction
(widen)
- (let ((ovs (cl-remove-if-not
- (lambda (ov)
- (and (overlay-get ov 'flymake-diagnostic)
- (or (not filter)
- (funcall filter ov))))
- (if (and beg (null end))
- (overlays-at beg t)
- (overlays-in (or beg (point-min))
- (or end (point-max)))))))
- (if compare
- (cl-sort ovs compare :key (or key
- #'identity))
- ovs))))
+ (cl-remove-if-not (lambda (o) (overlay-get o 'flymake-overlay))
+ (overlays-in (point-min) (point-max)))))
(defface flymake-error
'((((supports :underline (:style wave)))
@@ -417,6 +425,59 @@ verify FILTER, a function, and sort them by COMPARE (using KEY)."
"Face used for marking note regions."
:version "26.1")
+(defface flymake-error-echo
+ '((t :inherit compilation-error))
+ "Face used for showing summarized descriptions of errors."
+ :package-version '(Flymake . "1.3.4"))
+
+(defface flymake-warning-echo
+ '((t :inherit compilation-warning))
+ "Face used for showing summarized descriptions of warnings."
+ :package-version '(Flymake . "1.3.4"))
+
+(defface flymake-note-echo
+ '((t :inherit compilation-info))
+ "Face used for showing summarized descriptions of notes."
+ :package-version '(Flymake . "1.3.4"))
+
+(defface flymake-end-of-line-diagnostics-face
+ '((t :height 0.85 :box (:line-width -1)))
+ "Face used for end-of-line diagnostics.
+See variable `flymake-show-diagnostics-at-end-of-line'."
+ :package-version '(Flymake . "1.3.5"))
+
+(defface flymake-error-echo-at-eol
+ '((t :inherit (flymake-end-of-line-diagnostics-face compilation-error)))
+ "Face like `flymake-error-echo', but for end-of-line overlays."
+ :package-version '(Flymake . "1.3.5"))
+
+(defface flymake-warning-echo-at-eol
+ '((t :inherit (flymake-end-of-line-diagnostics-face compilation-warning)))
+ "Face like `flymake-warning-echo', but for end-of-line overlays."
+ :package-version '(Flymake . "1.3.5"))
+
+(defface flymake-note-echo-at-eol
+ '((t :inherit (flymake-end-of-line-diagnostics-face compilation-info)))
+ "Face like `flymake-note-echo', but for end-of-line overlays."
+ :package-version '(Flymake . "1.3.5"))
+
+(defface flymake-eol-information-face
+ '((t :inherit (flymake-end-of-line-diagnostics-face)
+ :box nil
+ :slant italic))
+ "Face used for information about end-of-line diagnostics."
+ :package-version '(Flymake . "1.3.6"))
+
+(defcustom flymake-show-diagnostics-at-end-of-line nil
+ "If non-nil, add diagnostic summary messages at end-of-line.
+The value `short' means that only the most severe diagnostic
+shall be shown. Any other non-nil value means show all
+diagnostic summaries at end-of-line."
+ :type '(choice (const :tag "Display most severe diagnostic" short)
+ (const :tag "Display all diagnostics" t)
+ (const :tag "Don't display diagnostics at end-of-line" nil))
+ :package-version '(Flymake . "1.3.6"))
+
(define-obsolete-face-alias 'flymake-warnline 'flymake-warning "26.1")
(define-obsolete-face-alias 'flymake-errline 'flymake-error "26.1")
@@ -570,19 +631,25 @@ Node `(Flymake)Flymake error types'"
(put 'flymake-error 'face 'flymake-error)
(put 'flymake-error 'flymake-bitmap 'flymake-error-bitmap)
(put 'flymake-error 'severity (warning-numeric-level :error))
-(put 'flymake-error 'mode-line-face 'compilation-error)
+(put 'flymake-error 'mode-line-face 'flymake-error-echo)
+(put 'flymake-error 'echo-face 'flymake-error-echo)
+(put 'flymake-error 'eol-face 'flymake-error-echo-at-eol)
(put 'flymake-error 'flymake-type-name "error")
(put 'flymake-warning 'face 'flymake-warning)
(put 'flymake-warning 'flymake-bitmap 'flymake-warning-bitmap)
(put 'flymake-warning 'severity (warning-numeric-level :warning))
-(put 'flymake-warning 'mode-line-face 'compilation-warning)
+(put 'flymake-warning 'mode-line-face 'flymake-warning-echo)
+(put 'flymake-warning 'echo-face 'flymake-warning-echo)
+(put 'flymake-warning 'eol-face 'flymake-warning-echo-at-eol)
(put 'flymake-warning 'flymake-type-name "warning")
(put 'flymake-note 'face 'flymake-note)
(put 'flymake-note 'flymake-bitmap 'flymake-note-bitmap)
(put 'flymake-note 'severity (warning-numeric-level :debug))
-(put 'flymake-note 'mode-line-face 'compilation-info)
+(put 'flymake-note 'mode-line-face 'flymake-note-echo)
+(put 'flymake-note 'echo-face 'flymake-note-echo)
+(put 'flymake-note 'eol-face 'flymake-note-echo-at-eol)
(put 'flymake-note 'flymake-type-name "note")
(defun flymake--lookup-type-property (type prop &optional default)
@@ -639,6 +706,52 @@ associated `flymake-category' return DEFAULT."
flymake-diagnostic-text)
always (equal (funcall comp a) (funcall comp b)))))
+(defun flymake--delete-overlay (ov)
+ "Like `delete-overlay', delete OV, but do some more stuff."
+ (let ((eolov (overlay-get ov 'eol-ov)))
+ (when eolov
+ (let ((src-ovs (delq ov (overlay-get eolov 'flymake-eol-source-overlays))))
+ (overlay-put eolov 'flymake-eol-source-overlays src-ovs)))
+ (delete-overlay ov)))
+
+(defun flymake--eol-overlay-summary (src-ovs)
+ "Helper function for `flymake--update-eol-overlays'."
+ (cl-flet ((summarize (d)
+ (propertize (flymake-diagnostic-oneliner d t) 'face
+ (flymake--lookup-type-property (flymake--diag-type d)
+ 'eol-face))))
+ (let* ((diags
+ (cl-sort
+ (mapcar (lambda (o) (overlay-get o 'flymake-diagnostic)) src-ovs)
+ #'>
+ :key (lambda (d) (flymake--severity (flymake-diagnostic-type d)))))
+ (summary
+ (concat
+ " "
+ (cond ((eq flymake-show-diagnostics-at-end-of-line 'short)
+ (concat
+ (summarize (car diags))
+ (and (cdr diags)
+ (concat
+ " "
+ (propertize (format "and %s more"
+ (1- (length diags)))
+ 'face 'flymake-eol-information-face)))))
+ (t
+ (mapconcat #'summarize diags " "))))))
+ (put-text-property 0 1 'cursor t summary)
+ summary)))
+
+(defun flymake--update-eol-overlays ()
+ "Update the `before-string' property of end-of-line overlays."
+ (save-restriction
+ (widen)
+ (dolist (o (overlays-in (point-min) (point-max)))
+ (when (overlay-get o 'flymake--eol-overlay)
+ (if-let ((src-ovs (overlay-get o 'flymake-eol-source-overlays)))
+ (overlay-put o 'before-string (flymake--eol-overlay-summary src-ovs))
+ (delete-overlay o))))))
+
(cl-defun flymake--highlight-line (diagnostic &optional foreign)
"Attempt to overlay DIAGNOSTIC in current buffer.
@@ -674,10 +787,11 @@ Return nil or the overlay created."
(setq beg a end b))))
(setf (flymake--diag-beg diagnostic) beg
(flymake--diag-end diagnostic) end)
- ;; Try to fix the remedy the situation if there is the same
- ;; diagnostic is already registered in the same place, which only
- ;; happens for clashes between domestic and foreign diagnostics
+ ;; Try to remedy the situation if the same diagnostic is already
+ ;; registered in the same place. This happens for clashes between
+ ;; domestic and foreign diagnostics
(cl-loop for e in (flymake-diagnostics beg end)
+ for eov = (flymake--diag-overlay e)
when (flymake--equal-diagnostic-p e diagnostic)
;; FIXME. This is an imperfect heuristic. Ideally, we'd
;; want to delete no overlays and keep annotating the
@@ -693,8 +807,14 @@ Return nil or the overlay created."
(flymake--diag-orig-beg e)
(flymake--diag-end e)
(flymake--diag-orig-end e))
- (delete-overlay (flymake--diag-overlay e))))
- (setq ov (make-overlay end beg))
+ (flymake--delete-overlay eov)))
+ (setq ov (make-overlay beg end))
+ (setf (flymake--diag-overlay diagnostic) ov)
+ (when (= (overlay-start ov) (overlay-end ov))
+ ;; Some backends report diagnostics with invalid bounds. Don't
+ ;; bother.
+ (delete-overlay ov)
+ (cl-return-from flymake--highlight-line nil))
(setf (flymake--diag-beg diagnostic) (overlay-start ov)
(flymake--diag-end diagnostic) (overlay-end ov))
;; First set `category' in the overlay
@@ -726,11 +846,13 @@ Return nil or the overlay created."
'flymake-bitmap
(alist-get 'bitmap (alist-get type ; backward compat
flymake-diagnostic-types-alist)))))
+ ;; (default-maybe 'after-string
+ ;; (flymake--diag-text diagnostic))
(default-maybe 'help-echo
(lambda (window _ov pos)
(with-selected-window window
(mapconcat
- #'flymake-diagnostic-text
+ #'flymake-diagnostic-oneliner
(flymake-diagnostics pos)
"\n"))))
(default-maybe 'severity (warning-numeric-level :error))
@@ -740,8 +862,29 @@ Return nil or the overlay created."
;; Some properties can't be overridden.
;;
(overlay-put ov 'evaporate t)
+ (overlay-put ov 'flymake-overlay t)
(overlay-put ov 'flymake-diagnostic diagnostic)
- (setf (flymake--diag-overlay diagnostic) ov)
+ ;; Handle `flymake-show-diagnostics-at-end-of-line'
+ ;;
+ (when flymake-show-diagnostics-at-end-of-line
+ (save-excursion
+ (goto-char (overlay-start ov))
+ (let* ((start (line-end-position))
+ (end (min (1+ start) (point-max)))
+ (eolov (car
+ (cl-remove-if-not
+ (lambda (o) (overlay-get o 'flymake-eol-source-overlays))
+ (overlays-in start end)))))
+ ;; FIXME: 1. no checking if there are unexpectedly more than
+ ;; one eolov at point.
+ (if eolov
+ (push ov (overlay-get eolov 'flymake-eol-source-overlays))
+ (setq eolov (make-overlay start end nil t nil))
+ (overlay-put eolov 'flymake-overlay t)
+ (overlay-put eolov 'flymake--eol-overlay t)
+ (overlay-put eolov 'flymake-eol-source-overlays (list ov))
+ (overlay-put eolov 'evaporate (not (= start end)))) ; FIXME: fishy
+ (overlay-put ov 'eol-ov eolov))))
ov))
;; Nothing in Flymake uses this at all any more, so this is just for
@@ -850,18 +993,29 @@ report applies to that region."
(float-time
(time-since flymake-check-start-time))))))
(setf (flymake--state-reported-p state) t)
+ ;; All of the above might have touched the eol overlays, so issue
+ ;; a call to update them. But check running and reporting
+ ;; backends first to flickering when multiple backends touch the
+ ;; same eol overlays.
+ (when (and flymake-show-diagnostics-at-end-of-line
+ (not (cl-set-difference (flymake-running-backends)
+ (flymake-reporting-backends))))
+ (flymake--update-eol-overlays))
(flymake--update-diagnostics-listings (current-buffer))))
(defun flymake--clear-foreign-diags (state)
(maphash (lambda (_buffer diags)
(cl-loop for d in diags
when (flymake--diag-overlay d)
- do (delete-overlay it)))
+ do (flymake--delete-overlay it)))
(flymake--state-foreign-diags state))
(clrhash (flymake--state-foreign-diags state)))
(defvar-local flymake-mode nil)
+(defvar-local flymake--mode-line-counter-cache nil
+ "A cache used in `flymake-mode-line-counters'.")
+
(cl-defun flymake--publish-diagnostics (diags &key backend state region)
"Helper for `flymake--handle-report'.
Publish DIAGS, which contain diagnostics for the current buffer
@@ -883,7 +1037,7 @@ and other buffers."
(flymake--intersects-p
(overlay-start ov) (overlay-end ov)
(car region) (cdr region)))
- do (delete-overlay ov)
+ do (flymake--delete-overlay ov)
else collect diag into surviving
finally (setf (flymake--state-diags state)
surviving)))
@@ -892,7 +1046,7 @@ and other buffers."
(not (flymake--state-reported-p state))
(cl-loop for diag in (flymake--state-diags state)
for ov = (flymake--diag-overlay diag)
- when ov do (delete-overlay ov))
+ when ov do (flymake--delete-overlay ov))
(setf (flymake--state-diags state) nil)
;; Also clear all overlays for `foreign-diags' in all other
;; buffers.
@@ -922,7 +1076,9 @@ and other buffers."
(setf (flymake--diag-locus d) (buffer-file-name))))
(cl-assert (stringp (flymake--diag-locus d)))
(push d (gethash (flymake--diag-locus d)
- (flymake--state-foreign-diags state))))))))
+ (flymake--state-foreign-diags state))))))
+ ;; Finally, flush some caches
+ (setq flymake--mode-line-counter-cache nil)))
(defun flymake-make-report-fn (backend &optional token)
"Make a suitable anonymous report function for BACKEND.
@@ -991,15 +1147,7 @@ with a report function."
(setf (flymake--state-running state) run-token
(flymake--state-disabled state) nil
(flymake--state-reported-p state) nil))
- ;; FIXME: Should use `condition-case-unless-debug' here, but don't
- ;; for two reasons: (1) that won't let me catch errors from inside
- ;; `ert-deftest' where `debug-on-error' appears to be always
- ;; t. (2) In cases where the user is debugging elisp somewhere
- ;; else, and using flymake, the presence of a frequently
- ;; misbehaving backend in the global hook (most likely the legacy
- ;; backend) will trigger an annoying backtrace.
- ;;
- (condition-case err
+ (condition-case-unless-debug err
(apply backend (flymake-make-report-fn backend run-token)
args)
(error
@@ -1069,6 +1217,11 @@ Interactively, with a prefix arg, FORCE is t."
(run-hook-wrapped
'flymake-diagnostic-functions
(lambda (backend)
+ (flymake--with-backend-state backend state
+ (setf (flymake--state-reported-p state) nil))))
+ (run-hook-wrapped
+ 'flymake-diagnostic-functions
+ (lambda (backend)
(cond
((and (not force)
(flymake--with-backend-state backend state
@@ -1136,7 +1289,7 @@ special *Flymake log* buffer." :group 'flymake :lighter
;; existing diagnostic overlays, lest we forget them by blindly
;; reinitializing `flymake--state' in the next line.
;; See https://github.com/joaotavora/eglot/issues/223.
- (mapc #'delete-overlay (flymake--overlays))
+ (mapc #'flymake--delete-overlay (flymake--really-all-overlays))
(setq flymake--state (make-hash-table))
(setq flymake--recent-changes nil)
@@ -1183,7 +1336,7 @@ special *Flymake log* buffer." :group 'flymake :lighter
(when flymake-timer
(cancel-timer flymake-timer)
(setq flymake-timer nil))
- (mapc #'delete-overlay (flymake--overlays))
+ (mapc #'flymake--delete-overlay (flymake--really-all-overlays))
(when flymake--state
(maphash (lambda (_backend state)
(flymake--clear-foreign-diags state))
@@ -1228,12 +1381,29 @@ Do it only if `flymake-no-changes-timeout' is non-nil."
(make-obsolete 'flymake-mode-on 'flymake-mode "26.1")
(make-obsolete 'flymake-mode-off 'flymake-mode "26.1")
-(defun flymake-after-change-function (start stop _len)
+(defun flymake-after-change-function (start stop pre-change-len)
"Start syntax check for current buffer if it isn't already running.
START and STOP and LEN are as in `after-change-functions'."
(let((new-text (buffer-substring start stop)))
(push (list start stop new-text) flymake--recent-changes)
- (flymake--schedule-timer-maybe)))
+ (flymake--schedule-timer-maybe))
+ ;; Some special handling to prevent eol overlays from temporarily
+ ;; moving to wrong line
+ (when (and flymake-show-diagnostics-at-end-of-line
+ (zerop pre-change-len))
+ (save-excursion
+ (goto-char start)
+ (when-let* ((probe (search-forward "\n" stop t))
+ (eolovs (cl-remove-if-not
+ (lambda (o)
+ (let ((lbound
+ (cl-loop for s in (overlay-get o 'flymake-eol-source-overlays)
+ minimizing (overlay-start s))))
+ (and lbound (< lbound (1- probe)))))
+ (overlays-at (line-end-position)))))
+ (goto-char start)
+ (let ((newend (line-end-position)))
+ (dolist (ov eolovs) (move-overlay ov newend (1+ newend))))))))
(defun flymake-after-save-hook ()
(when flymake-start-on-save-buffer
@@ -1254,10 +1424,11 @@ START and STOP and LEN are as in `after-change-functions'."
(defun flymake-eldoc-function (report-doc &rest _)
"Document diagnostics at point.
Intended for `eldoc-documentation-functions' (which see)."
- (let ((diags (flymake-diagnostics (point))))
- (when diags
- (funcall report-doc
- (mapconcat #'flymake-diagnostic-text diags "\n")))))
+ (when-let ((diags (flymake-diagnostics (point))))
+ (funcall report-doc
+ (mapconcat #'flymake-diagnostic-text diags "\n")
+ :echo (mapconcat #'flymake-diagnostic-oneliner
+ diags "\n"))))
(defun flymake-goto-next-error (&optional n filter interactive)
"Go to Nth next Flymake diagnostic that matches FILTER.
@@ -1277,20 +1448,17 @@ default) no filter is applied."
'(:error :warning))
t))
(let* ((n (or n 1))
- (ovs (flymake--overlays :filter
- (lambda (ov)
- (let ((diag (overlay-get
- ov
- 'flymake-diagnostic)))
- (and diag
- (or
- (not filter)
- (cl-find
- (flymake--severity
- (flymake-diagnostic-type diag))
- filter :key #'flymake--severity)))))
- :compare (if (cl-plusp n) #'< #'>)
- :key #'overlay-start))
+ (ovs (cl-loop
+ for o in (overlays-in (point-min) (point-max))
+ for diag = (overlay-get o 'flymake-diagnostic)
+ when (and diag (or (not filter) (cl-find
+ (flymake--severity
+ (flymake-diagnostic-type diag))
+ filter :key #'flymake--severity)))
+ collect o into retval
+ finally (cl-return
+ (cl-sort retval (if (cl-plusp n) #'< #'>)
+ :key #'overlay-start))))
(tail (cl-member-if (lambda (ov)
(if (cl-plusp n)
(> (overlay-start ov)
@@ -1382,7 +1550,7 @@ The counters are only placed if some Flymake backend initialized
correctly.")
(defvar flymake-mode-line-error-counter
- `(:eval (flymake--mode-line-counter :error t)))
+ `(:eval (flymake--mode-line-counter :error)))
(defvar flymake-mode-line-warning-counter
`(:eval (flymake--mode-line-counter :warning)))
(defvar flymake-mode-line-note-counter
@@ -1401,13 +1569,19 @@ correctly.")
,flymake-mode-line-lighter
mouse-face mode-line-highlight
help-echo
- ,(lambda (&rest _)
- (concat
- (format "%s known backends\n" (hash-table-count flymake--state))
- (format "%s running\n" (length (flymake-running-backends)))
- (format "%s disabled\n" (length (flymake-disabled-backends)))
- "mouse-1: Display minor mode menu\n"
- "mouse-2: Show help for minor mode"))
+ ,(lambda (w &rest _)
+ (with-current-buffer (window-buffer w)
+ ;; Mouse can activate tool-tip without window being active.
+ ;; `flymake--state' is buffer local and is null when line
+ ;; lighter appears in *Help* `describe-mode'.
+ (concat
+ (unless (null flymake--state)
+ (concat
+ (format "%s known backends\n" (hash-table-count flymake--state))
+ (format "%s running\n" (length (flymake-running-backends)))
+ (format "%s disabled\n" (length (flymake-disabled-backends)))))
+ "mouse-1: Display minor mode menu\n"
+ "mouse-2: Show help for minor mode")))
keymap
,(let ((map (make-sparse-keymap)))
(define-key map [mode-line down-mouse-1]
@@ -1449,9 +1623,40 @@ correctly.")
(defun flymake--mode-line-counters ()
(when (flymake-running-backends) flymake-mode-line-counter-format))
-(defun flymake--mode-line-counter (type &optional no-space)
- "Compute number of diagnostics in buffer with TYPE's severity.
-TYPE is usually keyword `:error', `:warning' or `:note'."
+(defun flymake--mode-line-counter-scroll-prev (event)
+ (interactive "e")
+ (let* ((event-start (event-start event))
+ (posn-string (posn-string event-start))
+ (type (get-text-property
+ (cdr posn-string) 'flymake--diagnostic-type (car posn-string))))
+ (with-selected-window (posn-window event-start)
+ (flymake-goto-prev-error 1 (list type) t))))
+
+(defun flymake--mode-line-counter-scroll-next (event)
+ (interactive "e")
+ (let* ((event-start (event-start event))
+ (posn-string (posn-string event-start))
+ (type (get-text-property
+ (cdr posn-string) 'flymake--diagnostic-type (car posn-string))))
+ (with-selected-window (posn-window event-start)
+ (flymake-goto-next-error 1 (list type) t))))
+
+(defvar flymake--mode-line-counter-map
+ (let ((map (make-sparse-keymap)))
+ ;; BEWARE: `mouse-wheel-UP-event' corresponds to `wheel-DOWN' events
+ ;; and vice versa!!
+ (define-key map (vector 'mode-line mouse-wheel-down-event)
+ #'flymake--mode-line-counter-scroll-prev)
+ (define-key map [mode-line wheel-down]
+ #'flymake--mode-line-counter-scroll-next)
+ (define-key map (vector 'mode-line mouse-wheel-up-event)
+ #'flymake--mode-line-counter-scroll-next)
+ (define-key map [mode-line wheel-up]
+ #'flymake--mode-line-counter-scroll-prev)
+ map))
+
+(defun flymake--mode-line-counter-1 (type)
+ "Helper for `flymake--mode-line-counter'."
(let ((count 0)
(face (flymake--lookup-type-property type
'mode-line-face
@@ -1468,7 +1673,7 @@ TYPE is usually keyword `:error', `:warning' or `:note'."
(warning-numeric-level
flymake-suppress-zero-counters)))
(t t)))
- `(,(if no-space "" '(:propertize " "))
+ `(,(if (eq type :error) "" '(:propertize " "))
(:propertize
,(format "%d" count)
face ,face
@@ -1479,21 +1684,17 @@ TYPE is usually keyword `:error', `:warning' or `:note'."
((eq type :warning) "warnings")
((eq type :note) "notes")
(t (format "%s diagnostics" type))))
- keymap
- ,(let ((map (make-sparse-keymap)))
- (define-key map (vector 'mode-line
- mouse-wheel-down-event)
- (lambda (event)
- (interactive "e")
- (with-selected-window (posn-window (event-start event))
- (flymake-goto-prev-error 1 (list type) t))))
- (define-key map (vector 'mode-line
- mouse-wheel-up-event)
- (lambda (event)
- (interactive "e")
- (with-selected-window (posn-window (event-start event))
- (flymake-goto-next-error 1 (list type) t))))
- map))))))
+ flymake--diagnostic-type ,type
+ keymap ,flymake--mode-line-counter-map)))))
+
+(defun flymake--mode-line-counter (type)
+ "Compute number of diagnostics in buffer with TYPE's severity.
+TYPE is usually keyword `:error', `:warning' or `:note'."
+ (let ((probe (alist-get type flymake--mode-line-counter-cache 'none)))
+ (if (eq probe 'none)
+ (setf (alist-get type flymake--mode-line-counter-cache)
+ (flymake--mode-line-counter-1 type))
+ probe)))
;;; Per-buffer diagnostic listing
@@ -1588,8 +1789,7 @@ filename of the diagnostic relative to that directory."
"\\1\\2" bname)
"(anon)")
'help-echo (format "From `%s' backend" backend))
- (,(replace-regexp-in-string "\n.*" ""
- (flymake-diagnostic-text diag))
+ (,(flymake-diagnostic-oneliner diag t)
mouse-face highlight
help-echo "mouse-2: visit this diagnostic"
face nil
@@ -1641,6 +1841,7 @@ buffer."
(define-derived-mode flymake-diagnostics-buffer-mode tabulated-list-mode
"Flymake diagnostics"
"A mode for listing Flymake diagnostics."
+ :interactive nil
(setq tabulated-list-format flymake--diagnostics-base-tabulated-list-format)
(setq tabulated-list-entries
'flymake--diagnostics-buffer-entries)
@@ -1698,6 +1899,7 @@ some of this variable's contents the diagnostic listings.")
(define-derived-mode flymake-project-diagnostics-mode tabulated-list-mode
"Flymake diagnostics"
"A mode for listing Flymake diagnostics."
+ :interactive nil
(setq tabulated-list-format
(vconcat [("File" 25 t)]
flymake--diagnostics-base-tabulated-list-format))
@@ -1783,6 +1985,4 @@ some of this variable's contents the diagnostic listings.")
(provide 'flymake)
-(require 'flymake-proc)
-
;;; flymake.el ends here
diff --git a/lisp/progmodes/fortran.el b/lisp/progmodes/fortran.el
index e388d4f7517..8a726dfe66e 100644
--- a/lisp/progmodes/fortran.el
+++ b/lisp/progmodes/fortran.el
@@ -37,7 +37,7 @@
;; We acknowledge many contributions and valuable suggestions by
;; Lawrence R. Dodd, Ralf Fassel, Ralph Finch, Stephen Gildea,
-;; Dr. Anil Gokhale, Ulrich Mueller, Mark Neale, Eric Prestemon,
+;; Dr. Anil Gokhale, Ulrich Müller, Mark Neale, Eric Prestemon,
;; Gary Sabot and Richard Stallman.
;;; Code:
diff --git a/lisp/progmodes/gdb-mi.el b/lisp/progmodes/gdb-mi.el
index 312b71ba640..c8b086cfad2 100644
--- a/lisp/progmodes/gdb-mi.el
+++ b/lisp/progmodes/gdb-mi.el
@@ -222,7 +222,6 @@ address for root variables.")
Only used for files that Emacs can't find.")
(defvar gdb-active-process nil
"GUD tooltips display variable values when t, and macro definitions otherwise.")
-(defvar gdb-error "Non-nil when GDB is reporting an error.")
(defvar gdb-macro-info nil
"Non-nil if GDB knows that the inferior includes preprocessor macro info.")
(defvar gdb-register-names nil "List of register names.")
@@ -237,6 +236,7 @@ Only used for files that Emacs can't find.")
(defvar gdb-source-file-list nil
"List of source files for the current executable.")
(defvar gdb-first-done-or-error t)
+(defvar gdb-target-async-checked nil)
(defvar gdb-source-window-list nil
"List of windows used for displaying source files.
Sorted in most-recently-visited-first order.")
@@ -453,9 +453,7 @@ valid signal handlers.")
(const :tag "Unlimited" nil))
:version "22.1")
-;; This is disabled by default because we don't really support
-;; asynchronous execution of the debuggee; see bug#63084. FIXME.
-(defcustom gdb-non-stop-setting nil
+(defcustom gdb-non-stop-setting (not (eq system-type 'windows-nt))
"If non-nil, GDB sessions are expected to support the non-stop mode.
When in the non-stop mode, stopped threads can be examined while
other threads continue to execute.
@@ -470,7 +468,7 @@ don't support the non-stop mode.
GDB session needs to be restarted for this setting to take effect."
:type 'boolean
:group 'gdb-non-stop
- :version "29.1")
+ :version "30.1")
(defcustom gdb-debuginfod-enable-setting
;; debuginfod servers are only for ELF executables, and elfutils, of
@@ -718,6 +716,13 @@ that GDB starts to reuse existing source windows."
:group 'gdb
:version "28.1")
+(defcustom gdb-display-io-buffer t
+ "When non-nil, display the separate `gdb-inferior-io' buffer.
+Otherwise, send program output to the GDB buffer."
+ :type 'boolean
+ :group 'gdb-buffers
+ :version "30.1")
+
(defvar gdbmi-debug-mode nil
"When non-nil, print the messages sent/received from GDB/MI in *Messages*.")
@@ -812,6 +817,42 @@ NOARG must be t when this macro is used outside `gud-def'."
(defvar gdb-control-level 0)
+(defun gdb-load-history ()
+ "Load GDB history from a history file.
+The name of the history file is given by environment variable GDBHISTFILE,
+falling back to \".gdb_history\" and \".gdbinit\"."
+ (when (ring-empty-p comint-input-ring) ; cf shell-mode
+ (let ((hfile (expand-file-name (or (getenv "GDBHISTFILE")
+ (if (eq system-type 'ms-dos)
+ "_gdb_history"
+ ".gdb_history"))))
+ ;; gdb defaults to 256, but we'll default to comint-input-ring-size.
+ (hsize (getenv "HISTSIZE")))
+ (dolist (file (append '("~/.gdbinit")
+ (unless (string-equal (expand-file-name ".")
+ (expand-file-name "~"))
+ '(".gdbinit"))))
+ (if (file-readable-p (setq file (expand-file-name file)))
+ (with-temp-buffer
+ (insert-file-contents file)
+ ;; TODO? check for "set history save\\( *on\\)?" and do
+ ;; not use history otherwise?
+ (while (re-search-forward
+ "^ *set history \\(filename\\|size\\) *\\(.*\\)" nil t)
+ (cond ((string-equal (match-string 1) "filename")
+ (setq hfile (expand-file-name
+ (match-string 2)
+ (file-name-directory file))))
+ ((string-equal (match-string 1) "size")
+ (setq hsize (match-string 2))))))))
+ (and (stringp hsize)
+ (integerp (setq hsize (string-to-number hsize)))
+ (> hsize 0)
+ (setq-local comint-input-ring-size hsize))
+ (if (stringp hfile)
+ (setq-local comint-input-ring-file-name hfile))
+ (comint-read-input-ring t))))
+
;;;###autoload
(defun gdb (command-line)
"Run gdb passing it COMMAND-LINE as arguments.
@@ -897,39 +938,10 @@ detailed description of this mode.
(setq-local gud-minor-mode 'gdbmi)
(setq-local gdb-control-level 0)
(setq comint-input-sender 'gdb-send)
- (when (ring-empty-p comint-input-ring) ; cf shell-mode
- (let ((hfile (expand-file-name (or (getenv "GDBHISTFILE")
- (if (eq system-type 'ms-dos)
- "_gdb_history"
- ".gdb_history"))))
- ;; gdb defaults to 256, but we'll default to comint-input-ring-size.
- (hsize (getenv "HISTSIZE")))
- (dolist (file (append '("~/.gdbinit")
- (unless (string-equal (expand-file-name ".")
- (expand-file-name "~"))
- '(".gdbinit"))))
- (if (file-readable-p (setq file (expand-file-name file)))
- (with-temp-buffer
- (insert-file-contents file)
- ;; TODO? check for "set history save\\( *on\\)?" and do
- ;; not use history otherwise?
- (while (re-search-forward
- "^ *set history \\(filename\\|size\\) *\\(.*\\)" nil t)
- (cond ((string-equal (match-string 1) "filename")
- (setq hfile (expand-file-name
- (match-string 2)
- (file-name-directory file))))
- ((string-equal (match-string 1) "size")
- (setq hsize (match-string 2))))))))
- (and (stringp hsize)
- (integerp (setq hsize (string-to-number hsize)))
- (> hsize 0)
- (setq-local comint-input-ring-size hsize))
- (if (stringp hfile)
- (setq-local comint-input-ring-file-name hfile))
- (comint-read-input-ring t)))
+ (gdb-load-history)
+
(gud-def gud-tbreak "tbreak %f:%l" "\C-t"
- "Set temporary breakpoint at current line.")
+ "Set temporary breakpoint at current line." t)
(gud-def gud-jump
(progn (gud-call "tbreak %f:%l" arg) (gud-call "jump %f:%l"))
"\C-j" "Set execution address to current line.")
@@ -960,7 +972,7 @@ detailed description of this mode.
"Finish executing current function.")
(gud-def gud-run "-exec-run"
nil
- "Run the program.")
+ "Run the program." t)
(gud-def gud-break (if (not (string-match "Disassembly" mode-name))
(gud-call "break %f:%l" arg)
@@ -968,7 +980,7 @@ detailed description of this mode.
(beginning-of-line)
(forward-char 2)
(gud-call "break *%a" arg)))
- "\C-b" "Set breakpoint at current line or address.")
+ "\C-b" "Set breakpoint at current line or address." t)
(gud-def gud-remove (if (not (string-match "Disassembly" mode-name))
(gud-call "clear %f:%l" arg)
@@ -976,7 +988,7 @@ detailed description of this mode.
(beginning-of-line)
(forward-char 2)
(gud-call "clear *%a" arg)))
- "\C-d" "Remove breakpoint at current line or address.")
+ "\C-d" "Remove breakpoint at current line or address." t)
;; -exec-until doesn't support --all yet
(gud-def gud-until (if (not (string-match "Disassembly" mode-name))
@@ -1001,9 +1013,10 @@ detailed description of this mode.
(gud-def gud-pp
(gud-call
(concat
- "pp " (if (eq (buffer-local-value
- 'major-mode (window-buffer)) 'speedbar-mode)
- (gdb-find-watch-expression) "%e")) arg)
+ "pp " (if (eq (buffer-local-value 'major-mode (window-buffer))
+ 'speedbar-mode)
+ (gdb-find-watch-expression) "%e"))
+ arg)
nil "Print the Emacs s-expression.")
(define-key gud-minor-mode-map [left-margin mouse-1]
@@ -1045,6 +1058,7 @@ detailed description of this mode.
(setq gdb-first-prompt t)
(setq gud-running nil)
+ (setq gud-async-running nil)
(gdb-update)
@@ -1069,6 +1083,7 @@ detailed description of this mode.
gdb-handler-list '()
gdb-prompt-name nil
gdb-first-done-or-error t
+ gdb-target-async-checked nil
gdb-buffer-fringe-width (car (window-fringes))
gdb-debug-log nil
gdb-source-window-list nil
@@ -1078,7 +1093,8 @@ detailed description of this mode.
gdb-threads-list '()
gdb-breakpoints-list '()
gdb-register-names '()
- gdb-non-stop gdb-non-stop-setting
+ gdb-supports-non-stop nil
+ gdb-non-stop nil
gdb-debuginfod-enable gdb-debuginfod-enable-setting)
;;
(gdbmi-bnf-init)
@@ -1097,9 +1113,10 @@ detailed description of this mode.
(if gdb-debuginfod-enable "on" "off"))
'gdb-debuginfod-message)
- (gdb-get-buffer-create 'gdb-inferior-io)
- (gdb-clear-inferior-io)
- (gdb-inferior-io--init-proc (get-process "gdb-inferior"))
+ (when gdb-display-io-buffer
+ (gdb-get-buffer-create 'gdb-inferior-io)
+ (gdb-clear-inferior-io)
+ (gdb-inferior-io--init-proc (get-process "gdb-inferior")))
(when (eq system-type 'windows-nt)
;; Don't create a separate console window for the debuggee.
@@ -1110,7 +1127,7 @@ detailed description of this mode.
(gdb-input "-gdb-set interactive-mode on" 'ignore))
(gdb-input "-gdb-set height 0" 'ignore)
- (when gdb-non-stop
+ (when gdb-non-stop-setting
(gdb-input "-gdb-set non-stop 1" 'gdb-non-stop-handler))
(gdb-input "-enable-pretty-printing" 'ignore)
@@ -1145,16 +1162,30 @@ detailed description of this mode.
(setq gdb-non-stop nil)
(setq gdb-supports-non-stop nil))
(setq gdb-supports-non-stop t)
- (gdb-input "-gdb-set target-async 1" 'ignore)
+ ;; Try to use "mi-async" first, needs GDB 7.7 onwards. Note if
+ ;; "mi-async" is not available, GDB is still running in "sync"
+ ;; mode, "No symbol" for "mi-async" must appear before other
+ ;; commands.
+ (gdb-input "-gdb-set mi-async 1" 'gdb-set-mi-async-handler)))
+
+(defun gdb-set-mi-async-handler()
+ (goto-char (point-min))
+ (if (re-search-forward "No symbol" nil t)
+ (gdb-input "-gdb-set target-async 1" 'ignore)))
+
+(defun gdb-try-check-target-async-support()
+ (when (and gdb-non-stop-setting gdb-supports-non-stop
+ (not gdb-target-async-checked))
(gdb-input "-list-target-features" 'gdb-check-target-async)))
(defun gdb-check-target-async ()
(goto-char (point-min))
- (unless (re-search-forward "async" nil t)
+ (if (re-search-forward "async" nil t)
+ (setq gdb-non-stop t)
(message
"Target doesn't support non-stop mode. Turning it off.")
- (setq gdb-non-stop nil)
- (gdb-input "-gdb-set non-stop 0" 'ignore)))
+ (gdb-input "-gdb-set non-stop 0" 'ignore))
+ (setq gdb-target-async-checked t))
(defun gdb-delchar-or-quit (arg)
"Delete ARG characters or send a quit command to GDB.
@@ -1169,13 +1200,13 @@ no input, and GDB is waiting for input."
(process-live-p proc)
(not gud-running)
(= (point) (marker-position (process-mark proc))))
- ;; Sending an EOF does not work with GDB-MI; submit an
- ;; explicit quit command.
- (progn
- (if (> gdb-control-level 0)
- (process-send-eof proc)
- (insert "quit")
- (comint-send-input t t)))
+ ;; Exit a recursive reading loop or quit.
+ (if (> gdb-control-level 0)
+ (process-send-eof proc)
+ ;; Sending an EOF does not work with GDB-MI; submit an
+ ;; explicit quit command.
+ (insert "quit")
+ (comint-send-input t t))
(delete-char arg))))
(defvar gdb-define-alist nil "Alist of #define directives for GUD tooltips.")
@@ -1938,19 +1969,23 @@ static char *magick[] = {
:group 'gdb)
-(defvar gdb-python-guile-commands-regexp
- "python\\|python-interactive\\|pi\\|guile\\|guile-repl\\|gr"
- "Regexp that matches Python and Guile commands supported by GDB.")
-
(defvar gdb-control-commands-regexp
- (concat
- "^\\("
- "comm\\(a\\(n\\(ds?\\)?\\)?\\)?\\|if\\|while"
- "\\|def\\(i\\(ne?\\)?\\)?\\|doc\\(u\\(m\\(e\\(nt?\\)?\\)?\\)?\\)?\\|"
- gdb-python-guile-commands-regexp
- "\\|while-stepping\\|stepp\\(i\\(ng?\\)?\\)?\\|ws\\|actions"
- "\\|expl\\(o\\(re?\\)?\\)?"
- "\\)\\([[:blank:]]+\\([^[:blank:]]*\\)\\)*$")
+ (rx bol
+ (or
+ (or "comm" "comma" "comman" "command" "commands"
+ "if" "while"
+ "def" "defi" "defin" "define"
+ "doc" "docu" "docum" "docume" "documen" "document"
+ "while-stepping"
+ "stepp" "steppi" "steppin" "stepping"
+ "ws" "actions"
+ "expl" "explo" "explor" "explore")
+ (group ; group 1: Python and Guile commands
+ (or "python" "python-interactive" "pi" "guile" "guile-repl" "gr")))
+ (? (+ blank)
+ (group ; group 2: command arguments
+ (* nonl)))
+ eol)
"Regexp matching GDB commands that enter a recursive reading loop.
As long as GDB is in the recursive reading loop, it does not expect
commands to be prefixed by \"-interpreter-exec console\".")
@@ -2010,15 +2045,13 @@ commands to be prefixed by \"-interpreter-exec console\".")
(setq gdb-continuation nil)))
;; Python and Guile commands that have an argument don't enter the
;; recursive reading loop.
- (let* ((control-command-p (string-match gdb-control-commands-regexp string))
- (command-arg (and control-command-p (match-string 3 string)))
- (python-or-guile-p (string-match gdb-python-guile-commands-regexp
- string)))
- (if (and control-command-p
- (or (not python-or-guile-p)
- (null command-arg)
- (zerop (length command-arg))))
- (setq gdb-control-level (1+ gdb-control-level)))))
+ (when (string-match gdb-control-commands-regexp string)
+ (let ((python-or-guile-p (match-beginning 1))
+ (command-arg (match-string 2 string)))
+ (when (or (not python-or-guile-p)
+ (null command-arg)
+ (zerop (length command-arg)))
+ (setq gdb-control-level (1+ gdb-control-level))))))
(defun gdb-mi-quote (string)
"Return STRING quoted properly as an MI argument.
@@ -2653,6 +2686,16 @@ Sets `gdb-thread-number' to new id."
(defun gdb-starting (_output-field _result)
;; CLI commands don't emit ^running at the moment so use gdb-running too.
(setq gdb-inferior-status "running")
+
+ ;; Set `gdb-non-stop' when `gdb-last-command' is a CLI background
+ ;; running command e.g. "run &", attach &" or a MI command
+ ;; e.g. "-exec-run" or "-exec-attach".
+ (if (or (string-match "&\s*$" gdb-last-command)
+ (string-match "^-" gdb-last-command))
+ (progn (gdb-try-check-target-async-support)
+ (setq gud-async-running t))
+ (setq gud-async-running nil))
+
(gdb-force-mode-line-update
(propertize gdb-inferior-status 'face font-lock-type-face))
(setq gdb-active-process t)
@@ -2723,6 +2766,10 @@ current thread and update GDB buffers."
;; Print "(gdb)" to GUD console
(when gdb-first-done-or-error
+ ;; If running target with a non-background CLI command
+ ;; e.g. "run" (no trailing '&'), target async feature can only
+ ;; be checked when when the program stops for the first time
+ (gdb-try-check-target-async-support)
(setq gdb-filter-output (concat gdb-filter-output gdb-prompt-name)))
;; In non-stop, we update information as soon as another thread gets
@@ -3248,7 +3295,8 @@ Place breakpoint icon in its buffer."
(if (re-search-forward gdb-source-file-regexp nil t)
(progn
(setq source-file (gdb-mi--c-string-from-string (match-string 1)))
- (delete (cons bptno "File not found") gdb-location-alist)
+ (setq gdb-location-alist
+ (delete (cons bptno "File not found") gdb-location-alist))
(push (cons bptno source-file) gdb-location-alist))
(gdb-resync)
(unless (assoc bptno gdb-location-alist)
@@ -4408,6 +4456,24 @@ member."
:group 'gud
:version "29.1")
+(defcustom gdb-locals-table-row-config `((name . 20)
+ (type . 20)
+ (value . ,gdb-locals-value-limit))
+ "Configuration for table rows in the local variable display.
+
+An alist that controls the display of the name, type and value of
+local variables inside the currently active stack-frame. The key
+controls which column to change whereas the value determines the
+maximum number of characters to display in each column. A value
+of 0 means there is no limit.
+
+Additionally, the order the element in the alist determines the
+left-to-right display order of the properties."
+ :type '(alist :key-type symbol :value-type integer)
+ :group 'gud
+ :version "30.1")
+
+
(defvar gdb-locals-values-table (make-hash-table :test #'equal)
"Mapping of local variable names to a string with their value.")
@@ -4437,12 +4503,9 @@ member."
(defun gdb-locals-value-filter (value)
"Filter function for the local variable VALUE."
- (let* ((no-nl (replace-regexp-in-string "\n" " " value))
- (str (replace-regexp-in-string "[[:space:]]+" " " no-nl))
- (limit gdb-locals-value-limit))
- (if (>= (length str) limit)
- (concat (substring str 0 limit) "...")
- str)))
+ (let* ((no-nl (replace-regexp-in-string "\n" " " (or value "<Unknown>")))
+ (str (replace-regexp-in-string "[[:space:]]+" " " no-nl)))
+ str))
(defun gdb-edit-locals-value (&optional event)
"Assign a value to a variable displayed in the locals buffer."
@@ -4456,6 +4519,22 @@ member."
(gud-basic-call
(concat "-gdb-set variable " var " = " value)))))
+
+(defun gdb-locals-table-columns-list (alist)
+ "Format and arrange the columns in locals display based on ALIST."
+ (let (columns)
+ (dolist (config gdb-locals-table-row-config columns)
+ (let* ((key (car config))
+ (max (cdr config))
+ (prop (alist-get key alist)))
+ (when prop
+ (if (and (> max 0) (length> prop max))
+ (push (propertize (string-truncate-left prop max) 'help-echo prop)
+ columns)
+ (push prop columns)))))
+ (nreverse columns)))
+
+
;; Complex data types are looked up in `gdb-locals-values-table'.
(defun gdb-locals-handler-custom ()
"Handler to rebuild the local variables table buffer."
@@ -4484,12 +4563,14 @@ member."
help-echo "mouse-2: edit value"
local-map ,gdb-edit-locals-map-1)
value))
+ (setf (gdb-table-right-align table) t)
+ (setq name (propertize name 'font-lock-face font-lock-variable-name-face))
+ (setq type (propertize type 'font-lock-face font-lock-type-face))
(gdb-table-add-row
table
- (list
- (propertize type 'font-lock-face font-lock-type-face)
- (propertize name 'font-lock-face font-lock-variable-name-face)
- value)
+ (gdb-locals-table-columns-list `((name . ,name)
+ (type . ,type)
+ (value . ,value)))
`(gdb-local-variable ,local))))
(insert (gdb-table-string table " "))
(setq mode-name
@@ -4515,7 +4596,8 @@ member."
(gdb-set-window-buffer
(gdb-get-buffer-create
'gdb-registers-buffer
- gdb-thread-number) t)))
+ gdb-thread-number)
+ t)))
map))
(define-derived-mode gdb-locals-mode gdb-parent-mode "Locals"
@@ -4635,7 +4717,8 @@ executes FUNCTION."
(gdb-set-window-buffer
(gdb-get-buffer-create
'gdb-locals-buffer
- gdb-thread-number) t)))
+ gdb-thread-number)
+ t)))
(define-key map "f" #'gdb-registers-toggle-filter)
map))
@@ -5035,7 +5118,7 @@ Function buffers are locals buffer, registers buffer, etc, but
not including main command buffer (the one where you type GDB
commands) or source buffers (that display program source code)."
(with-current-buffer buffer
- (derived-mode-p 'gdb-parent-mode 'gdb-inferior-io-mode)))
+ (derived-mode-p '(gdb-parent-mode gdb-inferior-io-mode))))
(defun gdb--buffer-type (buffer)
"Return the type of BUFFER if it is a function buffer.
@@ -5177,6 +5260,8 @@ This arrangement depends on the values of variable
(defun gdb-reset ()
"Exit a debugging session cleanly.
Kills the gdb buffers, and resets variables and the source buffers."
+ ;; Save GDB history
+ (comint-write-input-ring)
;; The gdb-inferior buffer has a pty hooked up to the main gdb
;; process. This pty must be deleted explicitly.
(let ((pty (get-process "gdb-inferior")))
diff --git a/lisp/progmodes/go-ts-mode.el b/lisp/progmodes/go-ts-mode.el
index e8a176e3d9d..cc330688dc3 100644
--- a/lisp/progmodes/go-ts-mode.el
+++ b/lisp/progmodes/go-ts-mode.el
@@ -35,6 +35,7 @@
(declare-function treesit-node-child "treesit.c")
(declare-function treesit-node-child-by-field-name "treesit.c")
(declare-function treesit-node-start "treesit.c")
+(declare-function treesit-node-end "treesit.c")
(declare-function treesit-node-type "treesit.c")
(declare-function treesit-search-subtree "treesit.c")
@@ -205,9 +206,16 @@
'((ERROR) @font-lock-warning-face))
"Tree-sitter font-lock settings for `go-ts-mode'.")
+(defvar-keymap go-ts-mode-map
+ :doc "Keymap used in Go mode, powered by tree-sitter"
+ :parent prog-mode-map
+ "C-c C-d" #'go-ts-mode-docstring)
+
;;;###autoload
(define-derived-mode go-ts-mode prog-mode "Go"
- "Major mode for editing Go, powered by tree-sitter."
+ "Major mode for editing Go, powered by tree-sitter.
+
+\\{go-ts-mode-map}"
:group 'go
:syntax-table go-ts-mode--syntax-table
@@ -253,12 +261,17 @@
(treesit-major-mode-setup)))
+(derived-mode-add-parents 'go-ts-mode '(go-mode))
+
(if (treesit-ready-p 'go)
+ ;; FIXME: Should we instead put `go-mode' in `auto-mode-alist'
+ ;; and then use `major-mode-remap-defaults' to map it to `go-ts-mode'?
(add-to-list 'auto-mode-alist '("\\.go\\'" . go-ts-mode)))
-(defun go-ts-mode--defun-name (node)
+(defun go-ts-mode--defun-name (node &optional skip-prefix)
"Return the defun name of NODE.
-Return nil if there is no name or if NODE is not a defun node."
+Return nil if there is no name or if NODE is not a defun node.
+Methods are prefixed with the receiver name, unless SKIP-PREFIX is t."
(pcase (treesit-node-type node)
("function_declaration"
(treesit-node-text
@@ -267,11 +280,10 @@ Return nil if there is no name or if NODE is not a defun node."
t))
("method_declaration"
(let* ((receiver-node (treesit-node-child-by-field-name node "receiver"))
- (type-node (treesit-search-subtree receiver-node "type_identifier"))
- (name-node (treesit-node-child-by-field-name node "name")))
- (concat
- "(" (treesit-node-text type-node) ")."
- (treesit-node-text name-node))))
+ (receiver (treesit-node-text (treesit-search-subtree receiver-node "type_identifier")))
+ (method (treesit-node-text (treesit-node-child-by-field-name node "name"))))
+ (if skip-prefix method
+ (concat "(" receiver ")." method))))
("type_declaration"
(treesit-node-text
(treesit-node-child-by-field-name
@@ -304,6 +316,32 @@ Return nil if there is no name or if NODE is not a defun node."
(not (go-ts-mode--struct-node-p node))
(not (go-ts-mode--alias-node-p node))))
+(defun go-ts-mode-docstring ()
+ "Add a docstring comment for the current defun.
+The added docstring is prefilled with the defun's name. If the
+comment already exists, jump to it."
+ (interactive)
+ (when-let ((defun-node (treesit-defun-at-point)))
+ (goto-char (treesit-node-start defun-node))
+ (if (go-ts-mode--comment-on-previous-line-p)
+ ;; go to top comment line
+ (while (go-ts-mode--comment-on-previous-line-p)
+ (forward-line -1))
+ (insert "// " (go-ts-mode--defun-name defun-node t))
+ (newline)
+ (backward-char))))
+
+(defun go-ts-mode--comment-on-previous-line-p ()
+ "Return t if the previous line is a comment."
+ (when-let ((point (- (pos-bol) 1))
+ ((> point 0))
+ (node (treesit-node-at point)))
+ (and
+ ;; check point is actually inside the found node
+ ;; treesit-node-at can return nodes after point
+ (<= (treesit-node-start node) point (treesit-node-end node))
+ (string-equal "comment" (treesit-node-type node)))))
+
;; go.mod support.
(defvar go-mod-ts-mode--syntax-table
@@ -403,6 +441,8 @@ what the parent of the node would be if it were a node."
(treesit-major-mode-setup)))
+(derived-mode-add-parents 'go-mod-ts-mode '(go-mod-mode))
+
(if (treesit-ready-p 'gomod)
(add-to-list 'auto-mode-alist '("/go\\.mod\\'" . go-mod-ts-mode)))
diff --git a/lisp/progmodes/grep.el b/lisp/progmodes/grep.el
index fdcbbe789af..657349cbdff 100644
--- a/lisp/progmodes/grep.el
+++ b/lisp/progmodes/grep.el
@@ -457,6 +457,33 @@ buffer `default-directory'."
:type '(repeat (choice (const :tag "Default" nil)
(string :tag "Directory"))))
+(defcustom grep-use-headings nil
+ "If non-nil, subdivide grep output into sections, one per file."
+ :type 'boolean
+ :version "30.1")
+
+(defface grep-heading `((t :inherit ,grep-hit-face))
+ "Face of headings when `grep-use-headings' is non-nil."
+ :version "30.1")
+
+(defvar grep-heading-regexp
+ (rx bol
+ (or
+ (group-n 2
+ (group-n 1 (+ (not (any 0 ?\n))))
+ 0)
+ (group-n 2
+ (group-n 1 (+? nonl))
+ (any ?: ?- ?=)))
+ (+ digit)
+ (any ?: ?- ?=))
+ "Regexp used to create headings from grep output lines.
+It should be anchored at beginning of line. The first capture
+group, if present, should match the heading associated to the
+line. The buffer range of the second capture, if present, is
+made invisible (presumably because displaying it would be
+redundant).")
+
(defvar grep-find-abbreviate-properties
(let ((ellipsis (if (char-displayable-p ?…) "[…]" "[...]"))
(map (make-sparse-keymap)))
@@ -612,6 +639,40 @@ This function is called from `compilation-filter-hook'."
(while (re-search-forward "\033\\[[0-9;]*[mK]" end 1)
(replace-match "" t t))))))
+(defvar grep--heading-format
+ (eval-when-compile
+ (let ((title (propertize "%s"
+ 'font-lock-face 'grep-heading
+ 'outline-level 1)))
+ (propertize (concat title "\n") 'compilation-annotation t)))
+ "Format string of grep headings.
+This is passed to `format' with one argument, the text of the
+first capture group of `grep-heading-regexp'.")
+
+(defvar-local grep--heading-state nil
+ "Variable to keep track of the `grep--heading-filter' state.")
+
+(defun grep--heading-filter ()
+ "Filter function to add headings to output of a grep process."
+ (unless grep--heading-state
+ (setq grep--heading-state (cons (point-min-marker) nil)))
+ (save-excursion
+ (let ((limit (car grep--heading-state)))
+ ;; Move point to the old limit and update limit marker.
+ (move-marker limit (prog1 (pos-bol) (goto-char limit)))
+ (while (re-search-forward grep-heading-regexp limit t)
+ (unless (get-text-property (point) 'compilation-annotation)
+ (let ((heading (match-string-no-properties 1))
+ (start (match-beginning 2))
+ (end (match-end 2)))
+ (when start
+ (put-text-property start end 'invisible t))
+ (when (and heading (not (equal heading (cdr grep--heading-state))))
+ (save-excursion
+ (goto-char (pos-bol))
+ (insert-before-markers (format grep--heading-format heading)))
+ (setf (cdr grep--heading-state) heading))))))))
+
(defun grep-probe (command args &optional func result)
(let (process-file-side-effects)
(equal (condition-case nil
@@ -906,6 +967,11 @@ The value depends on `grep-command', `grep-template',
(add-function :filter-return (local 'kill-transform-function)
(lambda (string)
(string-replace "\0" ":" string)))
+ (when grep-use-headings
+ (add-hook 'compilation-filter-hook #'grep--heading-filter 80 t)
+ (setq-local outline-search-function #'outline-search-level
+ outline-level (lambda () (get-text-property
+ (point) 'outline-level))))
(add-hook 'compilation-filter-hook #'grep-filter nil t))
(defun grep--save-buffers ()
diff --git a/lisp/progmodes/gud.el b/lisp/progmodes/gud.el
index a5d96a9b8ac..f10b047cc74 100644
--- a/lisp/progmodes/gud.el
+++ b/lisp/progmodes/gud.el
@@ -3,7 +3,7 @@
;; Copyright (C) 1992-1996, 1998, 2000-2024 Free Software Foundation,
;; Inc.
-;; Author: Eric S. Raymond <esr@snark.thyrsus.com>
+;; Author: Eric S. Raymond <esr@thyrsus.com>
;; Maintainer: emacs-devel@gnu.org
;; Keywords: unix, tools
@@ -80,7 +80,7 @@
(defgroup gud nil
"The \"Grand Unified Debugger\" interface.
-Supported debuggers include gdb, sdb, dbx, xdb, perldb,
+Supported debuggers include gdb, lldb, sdb, dbx, xdb, perldb,
pdb (Python), and jdb."
:group 'processes
:group 'tools)
@@ -128,6 +128,10 @@ If SOFT is non-nil, returns nil if the symbol doesn't already exist."
"Non-nil if debugged program is running.
Used to gray out relevant toolbar icons.")
+(defvar gud-async-running nil
+ "Non-nil if debugged program is running in async mode.
+Check it when `gud-running' is t")
+
(defvar gud-target-name "--unknown--"
"The apparent name of the program being debugged in a gud buffer.")
@@ -135,9 +139,9 @@ Used to gray out relevant toolbar icons.")
(defun gud-goto-info ()
"Go to relevant Emacs info node."
(interactive)
- (if (eq gud-minor-mode 'gdbmi)
- (info-other-window "(emacs)GDB Graphical Interface")
- (info-other-window "(emacs)Debuggers")))
+ (info-other-window (if (eq gud-minor-mode 'gdbmi)
+ "(emacs)GDB Graphical Interface"
+ "(emacs)Debuggers")))
(defun gud-tool-bar-item-visible-no-fringe ()
(not (or (eq (buffer-local-value 'major-mode (window-buffer)) 'speedbar-mode)
@@ -159,143 +163,145 @@ Used to gray out relevant toolbar icons.")
(t
(comint-interrupt-subjob)))))
-(easy-mmode-defmap gud-menu-map
- '(([help] "Info (debugger)" . gud-goto-info)
- ([tooltips] menu-item "Show GUD tooltips" gud-tooltip-mode
- :enable (and (not emacs-basic-display)
- (display-graphic-p)
- (fboundp 'x-show-tip))
- :visible (memq gud-minor-mode
- '(gdbmi guiler dbx sdb xdb pdb))
- :button (:toggle . gud-tooltip-mode))
- ([refresh] "Refresh" . gud-refresh)
- ([run] menu-item "Run" gud-run
- :enable (not gud-running)
- :visible (or (memq gud-minor-mode '(gdb dbx jdb))
- (and (eq gud-minor-mode 'gdbmi)
- (or (not (gdb-show-run-p))
- (bound-and-true-p
- gdb-active-process)))))
- ([go] . (menu-item (if (bound-and-true-p gdb-active-process)
- "Continue" "Run")
- gud-go
- :visible (and (eq gud-minor-mode 'gdbmi)
- (gdb-show-run-p))))
- ([stop] menu-item "Stop" gud-stop-subjob
- :visible (or (not (memq gud-minor-mode '(gdbmi pdb)))
- (and (eq gud-minor-mode 'gdbmi)
- (gdb-show-stop-p))))
- ([until] menu-item "Continue to selection" gud-until
- :enable (not gud-running)
- :visible (and (memq gud-minor-mode '(gdbmi gdb perldb))
- (gud-tool-bar-item-visible-no-fringe)))
- ([remove] menu-item "Remove Breakpoint" gud-remove
- :enable (not gud-running)
- :visible (gud-tool-bar-item-visible-no-fringe))
- ([tbreak] menu-item "Temporary Breakpoint" gud-tbreak
- :enable (not gud-running)
- :visible (memq gud-minor-mode
- '(gdbmi gdb sdb xdb)))
- ([break] menu-item "Set Breakpoint" gud-break
- :enable (not gud-running)
- :visible (gud-tool-bar-item-visible-no-fringe))
- ([up] menu-item "Up Stack" gud-up
- :enable (not gud-running)
- :visible (memq gud-minor-mode
- '(gdbmi gdb guiler dbx xdb jdb pdb)))
- ([down] menu-item "Down Stack" gud-down
- :enable (not gud-running)
- :visible (memq gud-minor-mode
- '(gdbmi gdb guiler dbx xdb jdb pdb)))
- ([pp] menu-item "Print S-expression" gud-pp
- :enable (and (not gud-running)
- (bound-and-true-p gdb-active-process))
- :visible (and (string-equal
- (buffer-local-value
- 'gud-target-name gud-comint-buffer)
- "emacs")
- (eq gud-minor-mode 'gdbmi)))
- ([print*] . (menu-item (if (eq gud-minor-mode 'jdb)
- "Dump object"
- "Print Dereference")
- gud-pstar
- :enable (not gud-running)
- :visible (memq gud-minor-mode '(gdbmi gdb jdb))))
- ([print] menu-item "Print Expression" gud-print
- :enable (not gud-running))
- ([watch] menu-item "Watch Expression" gud-watch
- :enable (not gud-running)
- :visible (eq gud-minor-mode 'gdbmi))
- ([finish] menu-item "Finish Function" gud-finish
- :enable (not gud-running)
- :visible (memq gud-minor-mode
- '(gdbmi gdb guiler xdb jdb pdb)))
- ([stepi] menu-item "Step Instruction" gud-stepi
- :enable (not gud-running)
- :visible (memq gud-minor-mode '(gdbmi gdb dbx)))
- ([nexti] menu-item "Next Instruction" gud-nexti
- :enable (not gud-running)
- :visible (memq gud-minor-mode '(gdbmi gdb dbx)))
- ([step] menu-item "Step Line" gud-step
- :enable (not gud-running))
- ([next] menu-item "Next Line" gud-next
- :enable (not gud-running))
- ([cont] menu-item "Continue" gud-cont
- :enable (not gud-running)
- :visible (not (eq gud-minor-mode 'gdbmi))))
- "Menu for `gud-mode'."
- :name "Gud")
-
-(easy-mmode-defmap gud-minor-mode-map
- (append
- `(([menu-bar debug] . ("Gud" . ,gud-menu-map)))
- ;; Get tool bar like functionality from the menu bar on a text only
- ;; terminal.
- (unless window-system
- `(([menu-bar down]
- . (,(propertize "down" 'face 'font-lock-doc-face) . gud-down))
- ([menu-bar up]
- . (,(propertize "up" 'face 'font-lock-doc-face) . gud-up))
- ([menu-bar finish]
- . (,(propertize "finish" 'face 'font-lock-doc-face) . gud-finish))
- ([menu-bar step]
- . (,(propertize "step" 'face 'font-lock-doc-face) . gud-step))
- ([menu-bar next]
- . (,(propertize "next" 'face 'font-lock-doc-face) . gud-next))
- ([menu-bar until] menu-item
- ,(propertize "until" 'face 'font-lock-doc-face) gud-until
- :visible (memq gud-minor-mode '(gdbmi gdb perldb)))
- ([menu-bar cont] menu-item
- ,(propertize "cont" 'face 'font-lock-doc-face) gud-cont
- :visible (not (eq gud-minor-mode 'gdbmi)))
- ([menu-bar run] menu-item
- ,(propertize "run" 'face 'font-lock-doc-face) gud-run
- :visible (memq gud-minor-mode '(gdbmi gdb dbx jdb)))
- ([menu-bar go] menu-item
- ,(propertize " go " 'face 'font-lock-doc-face) gud-go
- :visible (and (eq gud-minor-mode 'gdbmi)
- (gdb-show-run-p)))
- ([menu-bar stop] menu-item
- ,(propertize "stop" 'face 'font-lock-doc-face) gud-stop-subjob
- :visible (or (and (eq gud-minor-mode 'gdbmi)
- (gdb-show-stop-p))
- (not (eq gud-minor-mode 'gdbmi))))
- ([menu-bar print]
- . (,(propertize "print" 'face 'font-lock-doc-face) . gud-print))
- ([menu-bar tools] . undefined)
- ([menu-bar buffer] . undefined)
- ([menu-bar options] . undefined)
- ([menu-bar edit] . undefined)
- ([menu-bar file] . undefined))))
- "Map used in visited files.")
-
-(setf (alist-get 'gud-minor-mode minor-mode-map-alist)
- gud-minor-mode-map)
+(defvar-keymap gud-text-menu-bar-map
+ :doc "Menu-bar keymap used in GUD buffers on text frames."
+ ;; Use the menu-bar as a pseudo-tool-bar.
+ "<down>" `(,(propertize "down" 'face 'font-lock-doc-face) . gud-down)
+ "<up>" `(,(propertize "up" 'face 'font-lock-doc-face) . gud-up)
+ "<finish>" `(,(propertize "finish" 'face 'font-lock-doc-face) . gud-finish)
+ "<step>" `(,(propertize "step" 'face 'font-lock-doc-face) . gud-step)
+ "<next>" `(,(propertize "next" 'face 'font-lock-doc-face) . gud-next)
+ "<until>" `(menu-item
+ ,(propertize "until" 'face 'font-lock-doc-face) gud-until
+ :visible (memq gud-minor-mode '(gdbmi gdb lldb perldb)))
+ "<cont>" `(menu-item
+ ,(propertize "cont" 'face 'font-lock-doc-face) gud-cont
+ :visible (not (eq gud-minor-mode 'gdbmi)))
+ "<run>" `(menu-item
+ ,(propertize "run" 'face 'font-lock-doc-face) gud-run
+ :visible (memq gud-minor-mode '(gdbmi gdb lldb dbx jdb)))
+ "<go>" `(menu-bar-item
+ ,(propertize " go " 'face 'font-lock-doc-face) gud-go
+ :visible (and (eq gud-minor-mode 'gdbmi)
+ (gdb-show-run-p)))
+ "<stop>" `(menu-item
+ ,(propertize "stop" 'face 'font-lock-doc-face) gud-stop-subjob
+ :visible (or (and (eq gud-minor-mode 'gdbmi)
+ (gdb-show-stop-p))
+ (not (eq gud-minor-mode 'gdbmi))))
+ "<print>" `(,(propertize "print" 'face 'font-lock-doc-face) . gud-print)
+ ;; Hide the usual menus to make room.
+ "<tools>" #'undefined
+ "<buffer>" #'undefined
+ "<options>" #'undefined
+ "<edit>" #'undefined
+ "<file>" #'undefined)
+
+(defvar-keymap gud-menu-mode-map
+ :doc "Keymap shared between `gud-mode' and `gud-minor-mode'.")
+
+(defvar-keymap gud-mode-map
+ :doc "`gud-mode' keymap."
+ ;; BEWARE: `gud-mode-map' does not inherit from something like
+ ;; `gud-menu-mode-map' because the `gud-mode' buffer is also in
+ ;; `gud-minor-mode'.
+ ;;:parent (make-composed-keymap gud-menu-mode-map comint-mode-map)
+ )
-(defvar gud-mode-map
- ;; Will inherit from comint-mode via define-derived-mode.
- (make-sparse-keymap)
- "`gud-mode' keymap.")
+(defvar-keymap gud-minor-mode-map
+ ;; Part of the menu is dynamic, so we use 2 keymaps: `gud-menu-mode-map'
+ ;; is the static/normal menu defined with easy-menu, and
+ ;; `gud-text-menu-bar-map' is the part that's only used on text frames.
+ ;; We then merge them here into `gud-minor-mode-map'.
+ :parent gud-menu-mode-map
+ "<menu-bar>" `(menu-item nil ,gud-text-menu-bar-map
+ ;; Be careful to return an empty keymap rather than nil
+ ;; so as not to hide the parent's menus.
+ :filter ,(lambda (map) (if window-system '(keymap) map))))
+
+(easy-menu-define gud-menu-map gud-menu-mode-map
+ "Menu for `gud-mode'."
+ '("Gud"
+ ["Continue" gud-cont
+ :enable (not gud-running)
+ :visible (not (eq gud-minor-mode 'gdbmi))]
+ ["Next Line" gud-next
+ :enable (not gud-running)]
+ ["Step Line" gud-step
+ :enable (not gud-running)]
+ ["Next Instruction" gud-nexti
+ :enable (not gud-running)
+ :visible (memq gud-minor-mode '(gdbmi gdb lldb dbx))]
+ ["Step Instruction" gud-stepi
+ :enable (not gud-running)
+ :visible (memq gud-minor-mode '(gdbmi gdb lldb dbx))]
+ ["Finish Function" gud-finish
+ :enable (not gud-running)
+ :visible (memq gud-minor-mode '(gdbmi gdb lldb guiler xdb jdb pdb))]
+ ["Watch Expression" gud-watch
+ :enable (not gud-running)
+ :visible (eq gud-minor-mode 'gdbmi)]
+ ["Print Expression" gud-print
+ :enable (not gud-running)]
+ ["Dump object-Dereference" gud-pstar
+ :label (if (eq gud-minor-mode 'jdb)
+ "Dump object"
+ "Print Dereference")
+ :enable (not gud-running)
+ :visible (memq gud-minor-mode '(gdbmi gdb lldb jdb))]
+ ["Print S-expression" gud-pp
+ :enable (and (not gud-running)
+ (bound-and-true-p gdb-active-process))
+ :visible (and (string-equal
+ (buffer-local-value
+ 'gud-target-name gud-comint-buffer)
+ "emacs")
+ (eq gud-minor-mode 'gdbmi))]
+ ["Down Stack" gud-down
+ :enable (not gud-running)
+ :visible (memq gud-minor-mode '(gdbmi gdb lldb guiler dbx xdb jdb pdb))]
+ ["Up Stack" gud-up
+ :enable (not gud-running)
+ :visible (memq gud-minor-mode
+ '(gdbmi gdb lldb guiler dbx xdb jdb pdb))]
+ ["Set Breakpoint" gud-break
+ :enable (or (not gud-running) gud-async-running)
+ :visible (gud-tool-bar-item-visible-no-fringe)]
+ ["Temporary Breakpoint" gud-tbreak
+ :enable (or (not gud-running) gud-async-running)
+ :visible (memq gud-minor-mode '(gdbmi gdb lldb sdb xdb))]
+ ["Remove Breakpoint" gud-remove
+ :enable (or (not gud-running) gud-async-running)
+ :visible (gud-tool-bar-item-visible-no-fringe)]
+ ["Continue to selection" gud-until
+ :enable (not gud-running)
+ :visible (and (memq gud-minor-mode '(gdbmi gdb lldb perldb))
+ (gud-tool-bar-item-visible-no-fringe))]
+ ["Stop" gud-stop-subjob
+ :visible (or (not (memq gud-minor-mode '(gdbmi pdb)))
+ (and (eq gud-minor-mode 'gdbmi)
+ (gdb-show-stop-p)))]
+ ["Continue-Run" gud-go
+ :label (if (bound-and-true-p gdb-active-process)
+ "Continue" "Run")
+ :visible (and (eq gud-minor-mode 'gdbmi)
+ (gdb-show-run-p))]
+ ["Run" gud-run
+ :enable (or (not gud-running) gud-async-running)
+ :visible (or (memq gud-minor-mode '(gdb lldb dbx jdb))
+ (and (eq gud-minor-mode 'gdbmi)
+ (or (not (gdb-show-run-p))
+ (bound-and-true-p
+ gdb-active-process))))]
+ ["Refresh" gud-refresh]
+ ["Show GUD tooltips" gud-tooltip-mode
+ :enable (and (not emacs-basic-display)
+ (display-graphic-p)
+ (fboundp 'x-show-tip))
+ :visible (memq gud-minor-mode
+ '(gdbmi lldb guiler dbx sdb xdb pdb))
+ :button (:toggle . gud-tooltip-mode)]
+ ["Info (debugger)" gud-goto-info]))
(setf (alist-get 'gud-minor-mode minor-mode-map-alist)
gud-minor-mode-map)
@@ -323,7 +329,7 @@ Used to gray out relevant toolbar icons.")
(gud-goto-info . "info"))
map)
(tool-bar-local-item-from-menu
- (car x) (cdr x) map gud-minor-mode-map))))
+ (car x) (cdr x) map gud-menu-mode-map))))
(defvar gud-gdb-repeat-map
(let ((map (make-sparse-keymap)))
@@ -401,13 +407,15 @@ Uses `gud-<MINOR-MODE>-directories' to find the source files."
;; Of course you may use `gud-def' with any other debugger command, including
;; user defined ones.
-;; A macro call like (gud-def FUNC CMD KEY DOC) expands to a form
+;; A macro call like (gud-def FUNC CMD KEY DOC ASYNC-OK) expands to a form
;; which defines FUNC to send the command CMD to the debugger, gives
;; it the docstring DOC, and binds that function to KEY in the GUD
-;; major mode. The function is also bound in the global keymap with the
+;; major mode. The FUNC still sends CMD when both ASYNC-OK and
+;; `gud-async-running' are t even `gud-running' is t.
+;; The function is also bound in the global keymap with the
;; GUD prefix.
-(defmacro gud-def (func cmd key &optional doc)
+(defmacro gud-def (func cmd key &optional doc async-ok)
"Define FUNC to be a command sending CMD and bound to KEY, with
optional doc string DOC. Certain %-escapes in the string arguments
are interpreted specially if present. These are:
@@ -432,7 +440,7 @@ we're in the GUD buffer)."
(defalias ',func (lambda (arg)
,@(if doc (list doc))
(interactive "p")
- (if (not gud-running)
+ (if (or (not gud-running) (and ,async-ok gud-async-running))
,(if (stringp cmd)
`(gud-call ,cmd arg)
;; Unused lexical warning if cmd does not use "arg".
@@ -582,9 +590,9 @@ required by the caller."
(value (nth 4 var)) (status (nth 5 var))
(has-more (nth 6 var)))
(put-text-property
- 0 (length expr) 'face font-lock-variable-name-face expr)
+ 0 (length expr) 'face 'font-lock-variable-name-face expr)
(put-text-property
- 0 (length type) 'face font-lock-type-face type)
+ 0 (length type) 'face 'font-lock-type-face type)
(while (string-match "\\." varnum start)
(setq depth (1+ depth)
start (1+ (match-beginning 0))))
@@ -700,7 +708,7 @@ The option \"--fullname\" must be included in this value."
(setq gud-marker-acc (concat gud-marker-acc string))
(let ((output ""))
- ;; Process all the complete markers in this chunk.
+ ;; Processn all the complete markers in this chunk.
(while (string-match gud-gdb-marker-regexp gud-marker-acc)
(setq
@@ -965,6 +973,7 @@ It is passed through `gud-gdb-marker-filter' before we look at it."
(setq gud-gdb-fetch-lines-string string)
"")))
+
;; gdb speedbar functions
;; Part of the macro expansion of dframe-with-attached-buffer.
@@ -1307,7 +1316,7 @@ whereby $stopformat=1 produces an output format compatible with
(define-key map key cmd))
(when (or gud-mips-p
gud-irix-p)
- (define-key map "f" 'gud-finish))
+ (define-key map "f" #'gud-finish))
map)
"Keymap to repeat `dbx' stepping instructions \\`C-x C-a C-n n n'.
Used in `repeat-mode'.")
@@ -2694,10 +2703,12 @@ gud, see `gud-mode'."
(define-derived-mode gud-mode comint-mode "Debugger"
"Major mode for interacting with an inferior debugger process.
- You start it up with one of the commands \\[gdb], \\[sdb], \\[dbx],
-\\[perldb], \\[xdb], or \\[jdb]. Each entry point finishes by executing a
-hook; `gdb-mode-hook', `sdb-mode-hook', `dbx-mode-hook',
-`perldb-mode-hook', `xdb-mode-hook', or `jdb-mode-hook' respectively.
+ You start it up with one of the commands \\[gdb], \\[lldb],
+\\[sdb], \\[dbx], \\[perldb], \\[xdb], or \\[jdb]. Each entry
+point finishes by executing a hook; `gdb-mode-hook',
+`lldb-mode-hook' `sdb-mode-hook', `dbx-mode-hook',
+`perldb-mode-hook', `xdb-mode-hook', or `jdb-mode-hook'
+respectively.
After startup, the following commands are available in both the GUD
interaction buffer and any source buffer GUD visits due to a breakpoint stop
@@ -2727,11 +2738,11 @@ Under gdb, sdb and xdb, \\[gud-tbreak] behaves exactly like \\[gud-break],
except that the breakpoint is temporary; that is, it is removed when
execution stops on it.
-Under gdb, dbx, and xdb, \\[gud-up] pops up through an enclosing stack
-frame. \\[gud-down] drops back down through one.
+Under gdb, lldb, dbx, and xdb, \\[gud-up] pops up through an
+enclosing stack frame. \\[gud-down] drops back down through one.
-If you are using gdb or xdb, \\[gud-finish] runs execution to the return from
-the current function and stops.
+If you are using gdb, lldb, or xdb, \\[gud-finish] runs execution
+to the return from the current function and stops.
All the keystrokes above are accessible in the GUD buffer
with the prefix C-c, and in all buffers through the prefix C-x C-a.
@@ -2934,6 +2945,10 @@ It is saved for when this flag is not set.")
(declare-function speedbar-change-initial-expansion-list "speedbar" (new))
(defvar speedbar-previously-used-expansion-list-name)
+(defvar gud-highlight-current-line-overlay nil
+ "Overlay created for `gud-highlight-current-line'.
+It is nil if not yet present.")
+
(defun gud-sentinel (proc msg)
(cond ((null (buffer-name (process-buffer proc)))
;; buffer killed
@@ -2950,6 +2965,10 @@ It is saved for when this flag is not set.")
((memq (process-status proc) '(signal exit))
;; Stop displaying an arrow in a source file.
(setq gud-overlay-arrow-position nil)
+ ;; And any highlight overlays.
+ (when gud-highlight-current-line-overlay
+ (delete-overlay gud-highlight-current-line-overlay)
+ (setq gud-highlight-current-line-overlay nil))
(if (eq (buffer-local-value 'gud-minor-mode gud-comint-buffer)
'gdbmi)
(gdb-reset)
@@ -3001,7 +3020,12 @@ Obeying it means displaying in another window the specified file and line."
(interactive)
(when gud-last-frame
(gud-set-buffer)
- (gud-display-line (car gud-last-frame) (cdr gud-last-frame))
+ ;; Support either (file . line) or (file line column).
+ (if (consp (cdr gud-last-frame))
+ (let ((line (cadr gud-last-frame))
+ (column (caddr gud-last-frame)))
+ (gud-display-line (car gud-last-frame) line column))
+ (gud-display-line (car gud-last-frame) (cdr gud-last-frame)))
(setq gud-last-last-frame gud-last-frame
gud-last-frame nil)))
@@ -3016,7 +3040,25 @@ Obeying it means displaying in another window the specified file and line."
;; region-restriction if that's possible. We use an explicit display-buffer
;; to get around the fact that this is called inside a save-excursion.
-(defun gud-display-line (true-file line)
+(defcustom gud-highlight-current-line nil
+ "Whether Gud should highlight the source line being debugged.
+If non-nil, Gud will accentuate the source code line previously
+executed upon each pause in the debugee's execution with an
+overlay in the face `gud-highlight-current-line-face'.
+
+If nil, yet one of `hl-line-mode' or `global-hl-line-mode' (which
+see) is enabled, then the emphasis imposed by either of those
+major modes is instead momentarily moved to the aforesaid source
+line, until it is displaced by subsequent cursor motion."
+ :version "30.1"
+ :type 'boolean)
+
+(defface gud-highlight-current-line-face
+ '((t :inherit highlight :extend t))
+ "Face for highlighting the source code line being executed."
+ :version "30.1")
+
+(defun gud-display-line (true-file line &optional column)
(let* ((last-nonmenu-event t) ; Prevent use of dialog box for questions.
(buffer
(with-current-buffer gud-comint-buffer
@@ -3042,17 +3084,37 @@ Obeying it means displaying in another window the specified file and line."
(goto-char (point-min))
(forward-line (1- line))
(setq pos (point))
+ (when column
+ (forward-char (1- column)))
(or gud-overlay-arrow-position
(setq gud-overlay-arrow-position (make-marker)))
(set-marker gud-overlay-arrow-position (point) (current-buffer))
- ;; If they turned on hl-line, move the hl-line highlight to
- ;; the arrow's line.
- (when (featurep 'hl-line)
- (cond
- (global-hl-line-mode
- (global-hl-line-highlight))
- ((and hl-line-mode hl-line-sticky-flag)
- (hl-line-highlight)))))
+ (if gud-highlight-current-line
+ (progn
+ (unless gud-highlight-current-line-overlay
+ ;; Create the highlight overlay if it does not yet
+ ;; exist.
+ (let ((overlay (make-overlay (point) (point))))
+ (overlay-put overlay 'priority -45) ; 5 less than hl-line.
+ (overlay-put overlay 'face 'gud-highlight-current-line-face)
+ (setq gud-highlight-current-line-overlay overlay)))
+ ;; Next, move the overlay to the current line.
+ (move-overlay gud-highlight-current-line-overlay
+ (line-beginning-position)
+ (line-beginning-position 2)
+ (current-buffer)))
+ ;; Delete any overlay introduced if g-h-c-l-f has changed.
+ (when gud-highlight-current-line-overlay
+ (delete-overlay gud-highlight-current-line-overlay)
+ (setq gud-highlight-current-line-overlay nil))
+ ;; If they turned on hl-line, move the hl-line highlight to
+ ;; the arrow's line.
+ (when (featurep 'hl-line)
+ (cond
+ (global-hl-line-mode
+ (global-hl-line-highlight))
+ ((and hl-line-mode hl-line-sticky-flag)
+ (hl-line-highlight))))))
(cond ((or (< pos (point-min)) (> pos (point-max)))
(widen)
(goto-char pos))))
@@ -3148,7 +3210,7 @@ Obeying it means displaying in another window the specified file and line."
(defun gud-basic-call (command)
"Invoke the debugger COMMAND displaying source in other window."
- (interactive)
+ (interactive "sInvoke debugger command: ")
(gud-set-buffer)
(let ((proc (get-buffer-process gud-comint-buffer)))
(or proc (error "Current buffer has no process"))
@@ -3469,9 +3531,9 @@ class of the file (using s to separate nested class ids)."
(defun gdb-script-font-lock-syntactic-face (state)
(cond
- ((nth 3 state) font-lock-string-face)
- ((nth 7 state) font-lock-doc-face)
- (t font-lock-comment-face)))
+ ((nth 3 state) 'font-lock-string-face)
+ ((nth 7 state) 'font-lock-doc-face)
+ (t 'font-lock-comment-face)))
(defvar gdb-script-basic-indent 2)
@@ -3502,7 +3564,7 @@ class of the file (using s to separate nested class ids)."
(defun gdb-script-indent-line ()
"Indent current line of GDB script."
(interactive)
- (if (and (eq (get-text-property (point) 'face) font-lock-doc-face)
+ (if (and (eq (get-text-property (point) 'face) 'font-lock-doc-face)
(save-excursion
(forward-line 0)
(skip-chars-forward " \t")
@@ -3609,8 +3671,7 @@ Treats actions as defuns."
(remove-hook 'after-save-hook #'gdb-create-define-alist t))))
(defcustom gud-tooltip-modes '( gud-mode c-mode c++-mode fortran-mode
- python-mode c-ts-mode c++-ts-mode
- python-ts-mode)
+ python-mode)
"List of modes for which to enable GUD tooltips."
:type '(repeat (symbol :tag "Major mode"))
:group 'tooltip)
@@ -3646,10 +3707,9 @@ only tooltips in the buffer containing the overlay arrow."
#'gud-tooltip-activate-mouse-motions-if-enabled)
(dolist (buffer (buffer-list))
(with-current-buffer buffer
- (if (and gud-tooltip-mode
- (memq major-mode gud-tooltip-modes))
- (gud-tooltip-activate-mouse-motions t)
- (gud-tooltip-activate-mouse-motions nil)))))
+ (gud-tooltip-activate-mouse-motions
+ (and gud-tooltip-mode
+ (derived-mode-p gud-tooltip-modes))))))
(defvar gud-tooltip-mouse-motions-active nil
"Locally t in a buffer if tooltip processing of mouse motion is enabled.")
@@ -3715,13 +3775,17 @@ With arg, dereference expr if ARG is positive, otherwise do not dereference."
; gdb-mi.el gets around this problem.
(defun gud-tooltip-process-output (process output)
"Process debugger output and show it in a tooltip window."
- (remove-function (process-filter process) #'gud-tooltip-process-output)
- (tooltip-show (tooltip-strip-prompt process output)
- (or gud-tooltip-echo-area (not tooltip-mode))))
+ ;; First line is the print command itself.
+ (unless (string-search (gud-tooltip-print-command "") output)
+ (remove-function (process-filter process)
+ #'gud-tooltip-process-output)
+ (tooltip-show (tooltip-strip-prompt process output)
+ (or gud-tooltip-echo-area (not tooltip-mode)))))
(defun gud-tooltip-print-command (expr)
"Return a suitable command to print the expression EXPR."
(pcase gud-minor-mode
+ ('lldb (format "dwim-print -- %s" expr))
('gdbmi (concat "-data-evaluate-expression \"" expr "\""))
('guiler expr)
('dbx (concat "print " expr))
@@ -3783,11 +3847,312 @@ so they have been disabled."))
(gdb-input
(concat cmd "\n")
(lambda () (gdb-tooltip-print expr))))
+ ;; Not gdbmi.
(add-function :override (process-filter process)
#'gud-tooltip-process-output)
(gud-basic-call cmd))
expr))))))))
+
+;; 'gud-lldb-history' and 'gud-gud-lldb-command-name' are required
+;; because 'gud-symbol' uses their values if they are present. Their
+;; names are deduced from the minor-mode name.
+(defvar gud-lldb-history nil)
+
+(defcustom gud-gud-lldb-command-name "lldb"
+ "Default command to invoke LLDB in order to debug a program with it."
+ :type 'string
+ :version "30.1")
+
+(defun gud-lldb-marker-filter (string)
+ "Deduce interesting stuff from process output STRING."
+
+ ;; Pick information from our own frame info line "!gud LINE:COL:FILE"
+ ;; because the file name in the standard LLDB frame-format doesn't have
+ ;; a directory.
+ (setq string
+ (replace-regexp-in-string
+ (rx bol "!gud "
+ (group (+ digit)) ":" ; 1: line
+ (group (* digit)) ":" ; 2: column
+ (group (+ (not (in "\n\r")))) ; 3: file
+ (* "\r") "\n")
+ (lambda (m)
+ (let ((line (string-to-number (match-string 1 m)))
+ (col (string-to-number (match-string 2 m)))
+ (file (match-string 3 m)))
+ (setq gud-last-frame (list file line col)))
+ ;; Remove the line so that the user won't see it.
+ "")
+ string t t))
+
+ (when (string-match (rx "Process " (1+ digit) " exited with status")
+ string)
+ ;; Process 72874 exited with status = 9 (0x00000009) killed.
+ ;; Doesn't seem to be changeable as of LLDB 17.0.2.
+ (setq gud-last-last-frame nil)
+ (setq gud-overlay-arrow-position nil))
+
+ ;; LLDB sometimes emits certain ECMA-48 sequences even if TERM is "dumb":
+ ;; CHA (Character Horizontal Absolute) and ED (Erase in Display),
+ ;; seemingly to undo previous output on the same line.
+ ;; Filter out these sequences here while carrying out their edits.
+ (let ((bol (pos-bol)))
+ (when (> (point) bol)
+ ;; Move the current line to the string, so that control sequences
+ ;; can delete parts of it.
+ (setq string (concat (buffer-substring-no-properties bol (point))
+ string))
+ (let ((inhibit-read-only t))
+ (delete-region bol (point)))))
+ (let ((ofs 0))
+ (while (string-match (rx (group (* (not (in "\e\n")))) ; preceding chars
+ "\e[" ; CSI
+ (? (group (+ digit))) ; argument
+ (group (in "GJ"))) ; CHA or ED
+ string ofs)
+ (let* ((start (match-beginning 1))
+ (prefix-end (match-end 1))
+ (op (aref string (match-beginning 3)))
+ (end (match-end 0))
+ (keep-end
+ (if (eq op ?G)
+ ;; Move to absolute column (CHA)
+ (min prefix-end
+ (+ start
+ (if (match-beginning 2)
+ (1- (string-to-number (match-string 2 string)))
+ 0)))
+ ;; Erase in display (ED): no further action.
+ prefix-end)))
+ ;; Delete the control sequence and possibly part of the preceding chars.
+ (setq string (concat (substring string 0 keep-end)
+ (substring string end)))
+ (setq ofs start))))
+ string)
+
+;; According to SBCommandInterpreter.cpp, the return value of
+;; HandleCompletions is as follows:
+;;
+;; Index 1 to the end contain all the completions.
+;;
+;; At index 0:
+;;
+;; If all completions have a common prefix, this is the shortest
+;; completion, with the common prefix removed from it.
+;;
+;; If it is the completion for a whole word, a space is added at the
+;; end.
+;;
+;; So, the prefix is what could be added to make the command partially
+;; complete.
+;;
+;; If there is no common prefix, index 0 has an empty string "".
+
+(defcustom gud-lldb-max-completions 20
+ "Maximum number of completions to request from LLDB."
+ :type 'integer
+ :version "30.1")
+
+(defconst gud--lldb-python-init-string
+ "\
+deb = lldb.debugger
+inst = deb.GetInstanceName()
+ff = deb.GetInternalVariableValue('frame-format', inst).GetStringAtIndex(0)
+ff = ff[:-1] + '!gud ${line.number}:${line.column}:${line.file.fullpath}\\\\n\"'
+_ = deb.SetInternalVariable('frame-format', ff, inst)
+def gud_complete(s, max):
+ interpreter = lldb.debugger.GetCommandInterpreter()
+ string_list = lldb.SBStringList()
+ interpreter.HandleCompletion(s, len(s), len(s), max, string_list)
+ print('gud-completions: ##(')
+ # Specifying a max count doesn't seem to work in LLDB 17.
+ max = min(max, string_list.GetSize())
+ for i in range(max):
+ print(f'\"{string_list.GetStringAtIndex(i)}\" ')
+ print(')##')
+"
+ "Python code sent to LLDB for gud-specific initialization.")
+
+(defun gud-lldb-fetch-completions (context command)
+ "Return the data to complete the LLDB command before point.
+This is what the Python function we installed at initialization
+time returns, as a Lisp list.
+Maximum number of completions requested from LLDB is controlled
+by `gud-lldb-max-completions', which see."
+ (let* ((process (get-buffer-process gud-comint-buffer))
+ (to-complete (concat context command))
+ (output-buffer (get-buffer-create "*lldb-completions*")))
+ ;; Send the completion command with output to our buffer
+ (with-current-buffer output-buffer
+ (erase-buffer))
+ (comint-redirect-send-command-to-process
+ (format "script --language python -- gud_complete('%s', %d)"
+ to-complete gud-lldb-max-completions)
+ output-buffer process nil t)
+ ;; Wait for output
+ (unwind-protect
+ (while (not comint-redirect-completed)
+ (accept-process-output process 2))
+ (comint-redirect-cleanup))
+ ;; Process the completion output.
+ (with-current-buffer output-buffer
+ (goto-char (point-min))
+ (when (search-forward "gud-completions: ##" nil t)
+ (read (current-buffer))))))
+
+(defun gud-lldb-completions (context command)
+ "Completion table for LLDB commands."
+ (let ((completions (gud-lldb-fetch-completions context command)))
+ ;; If this is a cmpletion for w whole word, return a completion
+ ;; list that contains that word only, with a space appended.
+ (if (string-suffix-p " " (car completions))
+ (list (concat (cadr completions) " "))
+ (cdr completions))))
+
+(defun gud-lldb-completion-at-point ()
+ "Return the data to complete the LLDB command before point."
+ (let* ((end (point))
+ (line-start (comint-line-beginning-position))
+ (start (save-excursion
+ (skip-chars-backward "^ " line-start)
+ (point)))
+ (context (buffer-substring line-start start)))
+ (list (copy-marker start t)
+ end
+ (completion-table-dynamic
+ (apply-partially #'gud-lldb-completions context)))))
+
+(defun gud-lldb-send-python (python)
+ (gud-basic-call "script --language python --")
+ (mapc #'gud-basic-call (split-string python "\n"))
+ (gud-basic-call "exit()"))
+
+(defun gud-lldb-initialize ()
+ "Initialize the LLDB process as needed for this debug session."
+ (gud-lldb-send-python gud--lldb-python-init-string)
+ (gud-basic-call "settings set stop-line-count-before 0")
+ (gud-basic-call "settings set stop-line-count-after 0"))
+
+;;;###autoload
+(defun lldb (command-line)
+ "Run LLDB passing it COMMAND-LINE as arguments.
+If COMMAND-LINE names a program FILE to debug, LLDB will run in
+a buffer named *gud-FILE*, and the directory containing FILE
+becomes the initial working directory and source-file directory
+for the debug session. If you don't want `default-directory' to
+change to the directory of FILE, specify FILE without leading
+directories, in which case FILE should reside either in the
+directory of the buffer from which this command is invoked, or
+it can be found by searching PATH.
+
+If COMMAND-LINE requests that LLDB attaches to a process PID, LLDB
+will run in *gud-PID*, otherwise it will run in *gud*; in these
+cases the initial working directory is the `default-directory' of
+the buffer in which this command was invoked.
+
+Please note that completion framework that complete while you
+type, like Corfu, do not work well with this mode. You should
+consider to turn them off in this mode.
+
+This command runs functions from `lldb-mode-hook'."
+ (interactive (list (gud-query-cmdline 'lldb)))
+
+ (when (and gud-comint-buffer
+ (buffer-name gud-comint-buffer)
+ (get-buffer-process gud-comint-buffer)
+ (with-current-buffer gud-comint-buffer (eq gud-minor-mode 'gud-lldb)))
+ (gdb-restore-windows)
+ ;; FIXME: Copied from gud-gdb, but what does that even say?
+ (error "Multiple debugging requires restarting in text command mode"))
+
+ (gud-common-init command-line nil 'gud-lldb-marker-filter)
+ (setq-local gud-minor-mode 'lldb)
+
+ (gud-def gud-break
+ "breakpoint set --joint-specifier %f:%l"
+ "\C-b"
+ "Set breakpoint at current line.")
+ (gud-def gud-tbreak
+ "_regexp-break %f:%l"
+ "\C-t"
+ "Set temporary breakpoint at current line.")
+ (gud-def gud-remove
+ "breakpoint clear --line %l --file %f"
+ "\C-d"
+ "Remove breakpoint at current line")
+ (gud-def gud-step "thread step-in --count %p"
+ "\C-s"
+ "Step one source line with display.")
+ (gud-def gud-stepi
+ "thread step-inst --count %p"
+ "\C-i"
+ "Step one instruction with display.")
+ (gud-def gud-next
+ "thread step-over --count %p"
+ "\C-n"
+ "Step one line (skip functions).")
+ (gud-def gud-nexti
+ "thread step-inst-over --count %p"
+ nil
+ "Step one instruction (skip functions).")
+ (gud-def gud-cont
+ "process continue --ignore-count %p"
+ "\C-r"
+ "Continue with display.")
+ (gud-def gud-finish
+ "thread step-out"
+ "\C-f"
+ "Finish executing current function.")
+ (gud-def gud-jump
+ (progn
+ (gud-call "_regexp-break %f:%l" arg)
+ (gud-call "_regexp-jump %f:%l"))
+ "\C-j"
+ "Set execution address to current line.")
+ (gud-def gud-up
+ "_regexp-up %p"
+ "<"
+ "Up N stack frames (numeric arg).")
+ (gud-def gud-down
+ "_regexp-down %p"
+ ">"
+ "Down N stack frames (numeric arg).")
+ (gud-def gud-print
+ "dwim-print %e"
+ "\C-p"
+ "Evaluate C expression at point.")
+ (gud-def gud-pstar
+ "dwim-print *%e"
+ nil
+ "Evaluate C dereferenced pointer expression at point.")
+ (gud-def gud-pv
+ "xprint %e"
+ "\C-v"
+ "Print value of lisp variable (for debugging Emacs only).")
+ (gud-def gud-until
+ "thread until %l"
+ "\C-u"
+ "Continue to current line.")
+ (gud-def gud-run
+ ;; Extension for process launch --tty?
+ "process launch -X true"
+ nil
+ "Run the program.")
+
+ (add-hook 'completion-at-point-functions
+ #'gud-lldb-completion-at-point
+ nil 'local)
+ (keymap-local-set "<tab>" #'completion-at-point)
+
+ (gud-set-repeat-map-property 'gud-gdb-repeat-map)
+ (setq comint-prompt-regexp (rx line-start "(lldb)" (0+ blank)))
+ (setq comint-process-echoes t)
+ (setq paragraph-start comint-prompt-regexp)
+ (setq gud-running nil)
+ (gud-lldb-initialize)
+ (run-hooks 'lldb-mode-hook))
+
(provide 'gud)
;;; gud.el ends here
diff --git a/lisp/progmodes/heex-ts-mode.el b/lisp/progmodes/heex-ts-mode.el
new file mode 100644
index 00000000000..07b8bfdc74f
--- /dev/null
+++ b/lisp/progmodes/heex-ts-mode.el
@@ -0,0 +1,198 @@
+;;; heex-ts-mode.el --- Major mode for Heex with tree-sitter support -*- lexical-binding: t; -*-
+
+;; Copyright (C) 2022-2024 Free Software Foundation, Inc.
+
+;; Author: Wilhelm H Kirschbaum <wkirschbaum@gmail.com>
+;; Created: November 2022
+;; Keywords: elixir languages tree-sitter
+
+;; This file is part of GNU Emacs.
+
+;; GNU Emacs is free software: you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+
+;; GNU Emacs is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>.
+
+;;; Commentary:
+;;
+;; This package provides `heex-ts-mode' which is a major mode for editing
+;; HEEx files that uses Tree Sitter to parse the language.
+;;
+;; This package is compatible with and was tested against the tree-sitter grammar
+;; for HEEx found at https://github.com/phoenixframework/tree-sitter-heex.
+
+;;; Code:
+
+(require 'treesit)
+(eval-when-compile (require 'rx))
+
+(declare-function treesit-parser-create "treesit.c")
+(declare-function treesit-node-child "treesit.c")
+(declare-function treesit-node-type "treesit.c")
+(declare-function treesit-node-start "treesit.c")
+
+(defgroup heex-ts nil
+ "Major mode for editing HEEx code."
+ :prefix "heex-ts-"
+ :group 'langauges)
+
+(defcustom heex-ts-indent-offset 2
+ "Indentation of HEEx statements."
+ :version "30.1"
+ :type 'integer
+ :safe 'integerp
+ :group 'heex-ts)
+
+(defconst heex-ts--sexp-regexp
+ (rx bol
+ (or "directive" "tag" "component" "slot"
+ "attribute" "attribute_value" "quoted_attribute_value")
+ eol))
+
+;; There seems to be no parent directive block for tree-sitter-heex,
+;; so we ignore them for now until we learn how to query them.
+;; https://github.com/phoenixframework/tree-sitter-heex/issues/28
+(defvar heex-ts--indent-rules
+ (let ((offset heex-ts-indent-offset))
+ `((heex
+ ((parent-is "fragment")
+ (lambda (node parent &rest _)
+ ;; If HEEx is embedded indent to parent
+ ;; otherwise indent to the bol.
+ (if (eq (treesit-language-at (point-min)) 'heex)
+ (point-min)
+ (save-excursion
+ (goto-char (treesit-node-start parent))
+ (back-to-indentation)
+ (point))
+ )) 0)
+ ((node-is "end_tag") parent-bol 0)
+ ((node-is "end_component") parent-bol 0)
+ ((node-is "end_slot") parent-bol 0)
+ ((node-is "/>") parent-bol 0)
+ ((node-is ">") parent-bol 0)
+ ((parent-is "comment") prev-adaptive-prefix 0)
+ ((parent-is "component") parent-bol ,offset)
+ ((parent-is "tag") parent-bol ,offset)
+ ((parent-is "start_tag") parent-bol ,offset)
+ ((parent-is "component") parent-bol ,offset)
+ ((parent-is "start_component") parent-bol ,offset)
+ ((parent-is "slot") parent-bol ,offset)
+ ((parent-is "start_slot") parent-bol ,offset)
+ ((parent-is "self_closing_tag") parent-bol ,offset)
+ (no-node parent-bol ,offset)))))
+
+(defvar heex-ts--font-lock-settings
+ (when (treesit-available-p)
+ (treesit-font-lock-rules
+ :language 'heex
+ :feature 'heex-comment
+ '((comment) @font-lock-comment-face)
+ :language 'heex
+ :feature 'heex-doctype
+ '((doctype) @font-lock-doc-face)
+ :language 'heex
+ :feature 'heex-tag
+ `([(tag_name) (slot_name)] @font-lock-function-name-face)
+ :language 'heex
+ :feature 'heex-attribute
+ `((attribute_name) @font-lock-variable-name-face)
+ :language 'heex
+ :feature 'heex-keyword
+ `((special_attribute_name) @font-lock-keyword-face)
+ :language 'heex
+ :feature 'heex-string
+ `([(attribute_value) (quoted_attribute_value)] @font-lock-constant-face)
+ :language 'heex
+ :feature 'heex-component
+ `([
+ (component_name) @font-lock-function-name-face
+ (module) @font-lock-keyword-face
+ (function) @font-lock-keyword-face
+ "." @font-lock-keyword-face
+ ])))
+ "Tree-sitter font-lock settings.")
+
+(defun heex-ts--defun-name (node)
+ "Return the name of the defun NODE.
+Return nil if NODE is not a defun node or doesn't have a name."
+ (pcase (treesit-node-type node)
+ ((or "component" "slot" "tag")
+ (string-trim
+ (treesit-node-text
+ (treesit-node-child (treesit-node-child node 0) 1) nil)))
+ (_ nil)))
+
+(defun heex-ts--forward-sexp (&optional arg)
+ "Move forward across one balanced expression (sexp).
+With ARG, do it many times. Negative ARG means move backward."
+ (or arg (setq arg 1))
+ (funcall
+ (if (> arg 0) #'treesit-end-of-thing #'treesit-beginning-of-thing)
+ heex-ts--sexp-regexp
+ (abs arg)))
+
+;;;###autoload
+(define-derived-mode heex-ts-mode html-mode "HEEx"
+ "Major mode for editing HEEx, powered by tree-sitter."
+ :group 'heex-ts
+
+ (when (treesit-ready-p 'heex)
+ (treesit-parser-create 'heex)
+
+ ;; Comments
+ (setq-local treesit-thing-settings
+ `((heex
+ (text ,(regexp-opt '("comment" "text"))))))
+
+ (setq-local forward-sexp-function #'heex-ts--forward-sexp)
+
+ ;; Navigation.
+ (setq-local treesit-defun-type-regexp
+ (rx bol (or "component" "tag" "slot") eol))
+ (setq-local treesit-defun-name-function #'heex-ts--defun-name)
+
+ ;; Imenu
+ (setq-local treesit-simple-imenu-settings
+ '(("Component" "\\`component\\'" nil nil)
+ ("Slot" "\\`slot\\'" nil nil)
+ ("Tag" "\\`tag\\'" nil nil)))
+
+ ;; Outline minor mode
+ ;; `heex-ts-mode' inherits from `html-mode' that sets
+ ;; regexp-based outline variables. So need to restore
+ ;; the default values of outline variables to be able
+ ;; to use `treesit-outline-predicate' derived
+ ;; from `treesit-simple-imenu-settings' above.
+ (kill-local-variable 'outline-heading-end-regexp)
+ (kill-local-variable 'outline-regexp)
+ (kill-local-variable 'outline-level)
+
+ (setq-local treesit-font-lock-settings heex-ts--font-lock-settings)
+
+ (setq-local treesit-simple-indent-rules heex-ts--indent-rules)
+
+ (setq-local treesit-font-lock-feature-list
+ '(( heex-comment heex-keyword heex-doctype )
+ ( heex-component heex-tag heex-attribute heex-string )
+ () ()))
+
+ (treesit-major-mode-setup)))
+
+(derived-mode-add-parents 'heex-ts-mode '(heex-mode))
+
+(if (treesit-ready-p 'heex)
+ ;; Both .heex and the deprecated .leex files should work
+ ;; with the tree-sitter-heex grammar.
+ (add-to-list 'auto-mode-alist '("\\.[hl]?eex\\'" . heex-ts-mode)))
+
+(provide 'heex-ts-mode)
+;;; heex-ts-mode.el ends here
diff --git a/lisp/progmodes/hideif.el b/lisp/progmodes/hideif.el
index cb15b4f8bd0..98e567299a1 100644
--- a/lisp/progmodes/hideif.el
+++ b/lisp/progmodes/hideif.el
@@ -113,6 +113,7 @@
;; Various floating point types and operations are also supported but the
;; actual precision is limited by the Emacs internal floating representation,
;; which is the C data type "double" or IEEE binary64 format.
+;; C99 and GNU style variadic arguments support is completed in 2022/E.
;;; Code:
@@ -389,11 +390,13 @@ If there is a marked region from START to END it only shows the symbols within."
(defun hif-after-revert-function ()
(and hide-ifdef-mode hide-ifdef-hiding
(hide-ifdefs nil nil t)))
-(add-hook 'after-revert-hook 'hif-after-revert-function)
+(add-hook 'after-revert-hook #'hif-after-revert-function)
(defun hif-end-of-line ()
+ "Find the end-point of line concatenation."
(end-of-line)
- (while (= (logand 1 (skip-chars-backward "\\\\")) 1)
+ (while (progn (skip-chars-backward " \t" (line-beginning-position))
+ (= ?\\ (char-before)))
(end-of-line 2)))
(defun hif-merge-ifdef-region (start end)
@@ -471,7 +474,7 @@ Everything including these lines is made invisible."
(defun hif-eval (form)
"Evaluate hideif internal representation."
- (let ((val (eval form)))
+ (let ((val (eval form t)))
(if (stringp val)
(or (get-text-property 0 'hif-value val)
val)
@@ -536,10 +539,10 @@ that form should be displayed.")
;;===%%SF%% parsing (Start) ===
;;; The code that understands what ifs and ifdef in files look like.
-(defconst hif-cpp-prefix "\\(^\\|\r\\)[ \t]*#[ \t]*")
+(defconst hif-cpp-prefix "\\(^\\|\r\\)?[ \t]*#[ \t]*")
(defconst hif-ifxdef-regexp (concat hif-cpp-prefix "if\\(n\\)?def"))
(defconst hif-ifndef-regexp (concat hif-cpp-prefix "ifndef"))
-(defconst hif-ifx-regexp (concat hif-cpp-prefix "if\\(n?def\\)?[ \t]+"))
+(defvar hif-ifx-regexp (concat hif-cpp-prefix "if\\((\\|\\(n?def\\)?[ \t]+\\)"))
(defconst hif-elif-regexp (concat hif-cpp-prefix "elif"))
(defconst hif-else-regexp (concat hif-cpp-prefix "else"))
(defconst hif-endif-regexp (concat hif-cpp-prefix "endif"))
@@ -547,18 +550,23 @@ that form should be displayed.")
(concat hif-ifx-regexp "\\|" hif-elif-regexp "\\|" hif-else-regexp "\\|"
hif-endif-regexp))
(defconst hif-macro-expr-prefix-regexp
- (concat hif-cpp-prefix "\\(if\\(n?def\\)?\\|elif\\|define\\)[ \t]+"))
+ (concat hif-cpp-prefix "\\(if(\\|if\\(n?def\\)?[ \t]+\\|elif\\|define[ \t]+\\)"))
-(defconst hif-white-regexp "[ \t]*")
+(defconst hif-line-concat "\\\\[ \t]*[\n\r]")
+;; If `hif-white-regexp' is modified, `hif-tokenize' might need to be modified
+;; accordingly.
+(defconst hif-white-regexp (concat "\\(?:[ \t]\\|/\\*.*?\\*/"
+ "\\|\\(?:" hif-line-concat "\\)\\)*"))
(defconst hif-define-regexp (concat hif-cpp-prefix "\\(define\\|undef\\)"))
(defconst hif-id-regexp (concat "[[:alpha:]_][[:alnum:]_]*"))
+(defconst hif-etc-regexp "\\.\\.\\.")
(defconst hif-macroref-regexp
(concat hif-white-regexp "\\(" hif-id-regexp "\\)"
"\\("
"(" hif-white-regexp
"\\(" hif-id-regexp "\\)?" hif-white-regexp
"\\(" "," hif-white-regexp hif-id-regexp hif-white-regexp "\\)*"
- "\\(\\.\\.\\.\\)?" hif-white-regexp
+ "\\(" "," hif-white-regexp "\\)?" "\\(" hif-etc-regexp "\\)?" hif-white-regexp
")"
"\\)?" ))
@@ -671,7 +679,7 @@ that form should be displayed.")
("..." . hif-etc)
("defined" . hif-defined)))
-(defconst hif-valid-token-list (mapcar 'cdr hif-token-alist))
+(defconst hif-valid-token-list (mapcar #'cdr hif-token-alist))
(defconst hif-token-regexp
;; The ordering of regexp grouping is crucial to `hif-strtok'
@@ -682,7 +690,7 @@ that form should be displayed.")
;; decimal/octal:
"\\|\\(\\([+-]?[0-9']+\\(\\.[0-9']*\\)?\\)\\([eE][+-]?[0-9]+\\)?"
hif-numtype-suffix-regexp "?\\)"
- "\\|" (regexp-opt (mapcar 'car hif-token-alist) t)
+ "\\|" (regexp-opt (mapcar #'car hif-token-alist) t)
"\\|\\(\\w+\\)"))
;; C++11 Unicode string literals (L"" u8"" u"" U"" R"" LR"" u8R"" uR"")
@@ -859,7 +867,7 @@ Assuming we've just performed a `hif-token-regexp' lookup."
(t
(setq hif-simple-token-only nil)
- (intern-safe string)))))
+ (hif--intern-safe string)))))
(defun hif-backward-comment (&optional start end)
"If we're currently within a C(++) comment, skip them backwards."
@@ -936,7 +944,11 @@ Assuming we've just performed a `hif-token-regexp' lookup."
(defun hif-tokenize (start end)
"Separate string between START and END into a list of tokens."
(let ((token-list nil)
- (white-regexp "[ \t]+")
+ ;; Similar to `hif-white-regexp' but keep the spaces if there are
+ (white-regexp (concat "\\(?:"
+ "\\([ \t]+\\)\\|/\\*.*?\\*/"
+ "\\|\\(?:" hif-line-concat "\\)"
+ "\\)*"))
token)
(setq hif-simple-token-only t)
(with-syntax-table hide-ifdef-syntax-table
@@ -956,29 +968,31 @@ Assuming we've just performed a `hif-token-regexp' lookup."
(forward-char 2))
((looking-at hif-string-literal-regexp)
- (setq token (substring-no-properties (match-string 1)))
+ (setq token (match-string-no-properties 1))
(goto-char (match-end 0))
(when (looking-at white-regexp)
- (add-text-properties 0 1 '(hif-space t) token)
+ (if (not (zerop (length (match-string-no-properties 1))))
+ (add-text-properties 0 1 '(hif-space t) token))
(goto-char (match-end 0)))
(push token token-list))
((looking-at hif-token-regexp)
(goto-char (match-end 0))
- (setq token (hif-strtok
- (substring-no-properties (match-string 0))))
+ (setq token (hif-strtok (match-string-no-properties 0)))
(push token token-list)
(when (looking-at white-regexp)
- ;; We can't just append a space to the token string, otherwise
- ;; `0xf0 ' ## `01' will become `0xf0 01' instead of the expected
- ;; `0xf001', hence a standalone `hif-space' is placed instead.
- (push 'hif-space token-list)
+ (if (not (zerop (length (match-string-no-properties 1))))
+ ;; We can't just append a space to the token string,
+ ;; otherwise `0xf0 ' ## `01' will become `0xf0 01' instead
+ ;; of the expected `0xf001', hence a standalone `hif-space'
+ ;; is placed instead.
+ (push 'hif-space token-list))
(goto-char (match-end 0))))
((looking-at "\r") ; Sometimes MS-Windows user will leave CR in
(forward-char 1)) ; the source code. Let's not get stuck here.
- (t (error "Bad #if expression: %s" (buffer-string)))))))
+ (t (error "Bad preprocessor expression: %s" (buffer-string)))))))
(if (eq 'hif-space (car token-list))
(setq token-list (cdr token-list))) ;; remove trailing white space
(nreverse token-list))))
@@ -1126,7 +1140,7 @@ this is to emulate the stringification behavior of C++ preprocessor."
(and (eq (car remains) 'hif-space)
(eq (cadr remains) 'hif-lparen)
(setq remains (cdr remains)))))
- ;; No argument, no invocation
+ ;; No argument list, no invocation
tok
;; Argumented macro, get arguments and invoke it.
;; Dynamically bind `hif-token-list' and `hif-token'
@@ -1369,8 +1383,9 @@ factor : `!' factor | `~' factor | `(' exprlist `)' | `defined(' id `)' |
(parmlist nil) ; A "token" list of parameters, will later be parsed
(parm nil))
- (while (or (not (eq (hif-nexttoken keep-space) 'hif-rparen))
- (/= nest 0))
+ (while (and (or (not (eq (hif-nexttoken keep-space) 'hif-rparen))
+ (/= nest 0))
+ hif-token)
(if (eq (car (last parm)) 'hif-comma)
(setq parm nil))
(cond
@@ -1384,6 +1399,8 @@ factor : `!' factor | `~' factor | `(' exprlist `)' | `defined(' id `)' |
(setq parm nil)))
(push hif-token parm))
+ (if (equal parm '(hif-comma)) ;; missing the last argument
+ (setq parm '(nil)))
(push (nreverse parm) parmlist) ; Okay even if PARM is nil
(hif-nexttoken keep-space) ; Drop the `hif-rparen', get next token
(nreverse parmlist)))
@@ -1431,7 +1448,7 @@ This macro cannot be evaluated alone without parameters input."
(t
(error "Invalid token to stringify"))))
-(defun intern-safe (str)
+(defun hif--intern-safe (str)
(if (stringp str)
(intern str)))
@@ -1609,11 +1626,21 @@ and `+='...)."
;; no need to reassemble the list if no `##' presents
l))
-(defun hif-delimit (lis atom)
- (nconc (mapcan (lambda (l) (list l atom))
+(defun hif-delimit (lis elem)
+ (nconc (mapcan (lambda (l) (list l elem))
(butlast lis))
(last lis)))
+(defun hif-delete-nth (n lst)
+ "Non-destructively delete the nth item from a list."
+ (if (zerop n)
+ (cdr lst)
+ ;; non-destructive
+ (let* ((duplst (copy-sequence lst))
+ (node (nthcdr (1- n) duplst)))
+ (setcdr node (cddr node))
+ duplst)))
+
;; Perform token replacement:
(defun hif-macro-supply-arguments (macro-name actual-parms)
"Expand a macro call, replace ACTUAL-PARMS in the macro body."
@@ -1633,49 +1660,160 @@ and `+='...)."
;; For each actual parameter, evaluate each one and associate it
;; with an actual parameter, put it into local table and finally
;; evaluate the macro body.
- (if (setq etc (eq (car formal-parms) 'hif-etc))
+ (if (setq etc (or (eq (car formal-parms) 'hif-etc)
+ (and (eq (car formal-parms) 'hif-etc-c99) 'c99)))
;; Take care of `hif-etc' first. Prefix `hif-comma' back if needed.
(setq formal-parms (cdr formal-parms)))
(setq formal-count (length formal-parms)
actual-count (length actual-parms))
- (if (> formal-count actual-count)
- (error "Too few parameters for macro %S" macro-name)
- (if (< formal-count actual-count)
- (or etc
- (error "Too many parameters for macro %S" macro-name))))
+ ;; Fix empty arguments applied
+ (if (and (= formal-count 1)
+ (null (car formal-parms)))
+ (setq formal-parms nil
+ formal-count (1- formal-count)))
+ (if (and (= actual-count 1)
+ (or (null (car actual-parms))
+ ;; white space as the only argument
+ (equal '(hif-space) (car actual-parms))))
+ (setq actual-parms nil
+ actual-count (1- actual-count)))
+
+ ;; Basic error checking
+ (if etc
+ (if (eq etc 'c99)
+ (if (and (> formal-count 1) ; f(a,b,...)
+ (< actual-count formal-count))
+ (error "C99 variadic argument macro %S need at least %d arguments"
+ macro-name formal-count))
+ ;; GNU style variadic argument
+ (if (and (> formal-count 1)
+ (< actual-count (1- formal-count)))
+ (error "GNU variadic argument macro %S need at least %d arguments"
+ macro-name (1- formal-count))))
+ (if (> formal-count actual-count)
+ (error "Too few parameters for macro %S; %d instead of %d"
+ macro-name actual-count formal-count)
+ (if (< formal-count actual-count)
+ (error "Too many parameters for macro %S; %d instead of %d"
+ macro-name actual-count formal-count))))
;; Perform token replacement on the MACRO-BODY with the parameters
- (while (setq formal (pop formal-parms))
- ;; Prevent repetitive substitution, thus cannot use `subst'
- ;; for example:
- ;; #define mac(a,b) (a+b)
- ;; #define testmac mac(b,y)
- ;; testmac should expand to (b+y): replace of argument a and b
- ;; occurs simultaneously, not sequentially. If sequentially,
- ;; according to the argument order, it will become:
- ;; 1. formal parm #1 'a' replaced by actual parm 'b', thus (a+b)
- ;; becomes (b+b)
- ;; 2. formal parm #2 'b' replaced by actual parm 'y', thus (b+b)
- ;; becomes (y+y).
- (setq macro-body
- ;; Unlike `subst', `substitute' replace only the top level
- ;; instead of the whole tree; more importantly, it's not
- ;; destructive.
- (cl-substitute (if (and etc (null formal-parms))
- (hif-delimit actual-parms 'hif-comma)
- (car actual-parms))
- formal macro-body))
- (setq actual-parms (cdr actual-parms)))
-
- ;; Replacement completed, stringifiy and concatenate the token list.
- ;; Stringification happens must take place before flattening, otherwise
- ;; only the first token will be stringified.
- (setq macro-body
- (flatten-tree (hif-token-stringification macro-body)))
-
- ;; Token concatenation happens here, keep single 'hif-space
- (hif-keep-single (hif-token-concatenation macro-body) 'hif-space))))
+
+ ;; Every substituted argument in the macro-body must be in list form so
+ ;; that it won't again be substituted incorrectly in later iterations.
+ ;; Finally we will flatten the list to fix that.
+ (cl-loop
+ do
+ ;; Note that C99 '...' and GNU 'x...' allow empty match
+ (setq formal (pop formal-parms))
+ ;;
+ ;; Prevent repetitive substitution, thus cannot use `subst'
+ ;; for example:
+ ;; #define mac(a,b) (a+b)
+ ;; #define testmac mac(b,y)
+ ;; testmac should expand to (b+y): replace of argument a and b
+ ;; occurs simultaneously, not sequentially. If sequentially,
+ ;; according to the argument order, it will become:
+ ;; 1. formal parm #1 'a' replaced by actual parm 'b', thus (a+b)
+ ;; becomes (b+b)
+ ;; 2. formal parm #2 'b' replaced by actual parm 'y', thus (b+b)
+ ;; becomes (y+y).
+ ;; Unlike `subst', `cl-substitute' replace only the top level
+ ;; instead of the whole tree; more importantly, it's not
+ ;; destructive.
+ ;;
+ (if (not (and (null formal-parms) etc))
+ ;; One formal with one actual
+ (setq macro-body
+ (cl-substitute (car actual-parms) formal macro-body))
+ ;; `formal-parms' used up, now take care of '...'
+ (cond
+
+ ((eq etc 'c99) ; C99 __VA_ARGS__ style '...'
+ (when formal
+ (setq macro-body
+ (cl-substitute (car actual-parms) formal macro-body))
+ ;; Now the whole __VA_ARGS__ represents the whole
+ ;; remaining actual params
+ (pop actual-parms))
+ ;; Replace if __VA_ARGS__ presents:
+ ;; if yes, see if it's prefixed with ", ##" or not,
+ ;; if yes, remove the "##", then if actual-params is
+ ;; exhausted, remove the prefixed ',' as well.
+ ;; Prepare for destructive operation
+ (let ((rem-body (copy-sequence macro-body))
+ new-body va left part)
+ ;; Find each __VA_ARGS__ and remove its immediate prefixed '##'
+ ;; and comma if presents and if `formal_param' is exhausted
+ (while (setq va (cl-position '__VA_ARGS__ rem-body))
+ ;; Split REM-BODY @ __VA_ARGS__ into LEFT and right
+ (setq part nil)
+ (if (zerop va)
+ (setq left nil ; __VA_ARGS__ trimmed
+ rem-body (cdr rem-body))
+ (setq left rem-body
+ rem-body (cdr (nthcdr va rem-body))) ; _V_ removed
+ (setcdr (nthcdr va left) nil) ; now _V_ be the last in LEFT
+ ;; now LEFT=(, w? ## w? _V_) rem=(W X Y) where w = white space
+ (setq left (cdr (nreverse left)))) ; left=(w? ## w? ,)
+
+ ;; Try to recognize w?##w? and remove ", ##" if found
+ ;; (remember head = __VA_ARGS__ is temporarily removed)
+ (while (and left (eq 'hif-space (car left))) ; skip whites
+ (setq part (cons 'hif-space part)
+ left (cdr left)))
+
+ (if (eq (car left) 'hif-token-concat) ; match '##'
+ (if actual-parms
+ ;; Keep everything
+ (setq part (append part (cdr left)))
+ ;; `actual-params' exhausted, delete ',' if presents
+ (while (and left (eq 'hif-space (car left))) ; skip whites
+ (setq part (cons 'hif-space part)
+ left (cdr left)))
+ (setq part
+ (append part
+ (if (eq (car left) 'hif-comma) ; match ','
+ (cdr left)
+ left))))
+ ;; No immediate '##' found
+ (setq part (append part left)))
+
+ ;; Insert __VA_ARGS__ as a list
+ (push (hif-delimit actual-parms 'hif-comma) part)
+ ;; Reverse `left' back
+ (setq left (nreverse part)
+ new-body (append new-body left)))
+
+ ;; Replacement of __VA_ARGS__ done here, add rem-body back
+ (setq macro-body (append new-body rem-body)
+ actual-parms nil)))
+
+ (etc ; GNU style '...', substitute last argument
+ (if (null actual-parms)
+ ;; Must be non-destructive otherwise the original function
+ ;; definition defined in `hide-ifdef-env' will be destroyed.
+ (setq macro-body (remove formal macro-body))
+ (setq macro-body
+ (cl-substitute (hif-delimit actual-parms 'hif-comma)
+ formal macro-body)
+ actual-parms nil)))
+
+ (t
+ (error "Internal error: impossible case"))))
+
+ (pop actual-parms)
+ while actual-parms) ; end cl-loop
+
+ ;; Replacement completed, stringifiy and concatenate the token list.
+ ;; Stringification happens must take place before flattening, otherwise
+ ;; only the first token will be stringified.
+ (setq macro-body
+ (flatten-tree (hif-token-stringification macro-body))))
+
+ ;; Token concatenation happens here, keep single 'hif-space
+ (hif-keep-single (hif-token-concatenation macro-body) 'hif-space)))
(defun hif-invoke (macro-name actual-parms)
"Invoke a macro by expanding it, reparse macro-body and finally invoke it."
@@ -1710,7 +1848,9 @@ and `+='...)."
Do this when cursor is at the beginning of `regexp' (i.e. #ifX)."
(let ((case-fold-search nil))
(save-excursion
- (re-search-forward regexp)
+ (if (re-search-forward regexp)
+ (if (= ?\( (char-before)) ;; "#if(" found
+ (goto-char (1- (point)))))
(let* ((curr-regexp (match-string 0))
(defined (string-match hif-ifxdef-regexp curr-regexp))
(negate (and defined
@@ -1724,29 +1864,48 @@ Do this when cursor is at the beginning of `regexp' (i.e. #ifX)."
(setq tokens (list 'hif-not tokens)))
(hif-parse-exp tokens)))))
+(defun hif-is-in-comment ()
+ "Check if we're currently within a C(++) comment."
+ (or (nth 4 (syntax-ppss))
+ (looking-at "/[/*]")))
+
+(defun hif-search-ifX-regexp (hif-regexp &optional backward)
+ "Search for a valid ifX regexp defined in hideif."
+ (let ((start (point))
+ (re-search-func (if backward
+ #'re-search-backward
+ #'re-search-forward))
+ (limit (if backward (point-min) (point-max)))
+ found)
+ (while (and (setq found
+ (funcall re-search-func hif-regexp limit t))
+ (hif-is-in-comment)))
+ ;; Jump to the pattern if found
+ (if found
+ (unless backward
+ (setq found
+ (goto-char (- (point) (length (match-string 0))))))
+ (goto-char start))
+ found))
+
(defun hif-find-any-ifX ()
"Move to next #if..., or #ifndef, at point or after."
;; (message "find ifX at %d" (point))
- (prog1
- (re-search-forward hif-ifx-regexp (point-max) t)
- (beginning-of-line)))
-
+ (hif-search-ifX-regexp hif-ifx-regexp))
(defun hif-find-next-relevant ()
"Move to next #if..., #elif..., #else, or #endif, after the current line."
;; (message "hif-find-next-relevant at %d" (point))
(end-of-line)
- ;; Avoid infinite recursion by only going to line-beginning if match found
- (if (re-search-forward hif-ifx-else-endif-regexp (point-max) t)
- (beginning-of-line)))
+ ;; Avoid infinite recursion by going to the pattern only if a match is found
+ (hif-search-ifX-regexp hif-ifx-else-endif-regexp))
(defun hif-find-previous-relevant ()
"Move to previous #if..., #else, or #endif, before the current line."
;; (message "hif-find-previous-relevant at %d" (point))
(beginning-of-line)
- ;; Avoid infinite recursion by only going to line-beginning if match found
- (if (re-search-backward hif-ifx-else-endif-regexp (point-min) t)
- (beginning-of-line)))
+ ;; Avoid infinite recursion by going to the pattern only if a match is found
+ (hif-search-ifX-regexp hif-ifx-else-endif-regexp 't))
(defun hif-looking-at-ifX ()
@@ -1931,6 +2090,7 @@ Point is left unchanged."
((hif-looking-at-else)
(setq else (point)))
(t
+ (beginning-of-line) ; otherwise #endif line will be hidden
(setq end (point)))))
;; If found #else, look for #endif.
(when else
@@ -1940,6 +2100,7 @@ Point is left unchanged."
(hif-ifdef-to-endif))
(if (hif-looking-at-else)
(error "Found two elses in a row? Broken!"))
+ (beginning-of-line) ; otherwise #endif line will be hidden
(setq end (point))) ; (line-end-position)
(hif-make-range start end else elif))))
@@ -2085,16 +2246,20 @@ Refer to `hide-ifdef-expand-reinclusion-guard' for more details."
(eq (car def) 'hif-define-macro))
(let ((cdef (concat "#define " name))
(parmlist (cadr def))
- s)
+ p s etc)
(setq def (caddr def))
;; parmlist
(when parmlist
(setq cdef (concat cdef "("))
- (while (car parmlist)
- (setq cdef (concat cdef (symbol-name (car parmlist))
- (if (cdr parmlist) ","))
+ (if (setq etc (or (eq (setq p (car parmlist)) 'hif-etc)
+ (and (eq p 'hif-etc-c99) 'c99)))
+ (pop parmlist))
+ (while (setq p (car parmlist))
+ (setq cdef (concat cdef (symbol-name p) (if (cdr parmlist) ","))
parmlist (cdr parmlist)))
- (setq cdef (concat cdef ")")))
+ (setq cdef (concat cdef
+ (if etc (concat (if (eq etc 'c99) ",") "..."))
+ ")")))
(setq cdef (concat cdef " "))
;; body
(while def
@@ -2221,25 +2386,38 @@ however, when this command is prefixed, it will display the error instead."
result))))
(defun hif-parse-macro-arglist (str)
- "Parse argument list formatted as `( arg1 [ , argn] [...] )'.
+ "Parse argument list formatted as `( arg1 [ , argn] [,] [...] )'.
The `...' is also included. Return a list of the arguments, if `...' exists the
first arg will be `hif-etc'."
(let* ((hif-simple-token-only nil) ; Dynamic binding var for `hif-tokenize'
(tokenlist
(cdr (hif-tokenize
(- (point) (length str)) (point)))) ; Remove `hif-lparen'
- etc result token)
- (while (not (eq (setq token (pop tokenlist)) 'hif-rparen))
+ etc result token prevtok prev2tok)
+ (while (not (eq (setq prev2tok prevtok
+ prevtok token
+ token (pop tokenlist)) 'hif-rparen))
(cond
((eq token 'hif-etc)
- (setq etc t))
+ ;; GNU type "..." or C99 type
+ (setq etc (if (or (null prevtok)
+ (eq prevtok 'hif-comma)
+ (and (eq prevtok 'hif-space)
+ (eq prev2tok 'hif-comma)))
+ 'c99 t)))
((eq token 'hif-comma)
- t)
+ (if etc
+ (error "Syntax error: no comma allowed after `...'.")))
(t
(push token result))))
- (if etc
- (cons 'hif-etc (nreverse result))
- (nreverse result))))
+ (setq result (nreverse result))
+ (cond
+ ((eq etc 'c99)
+ (cons 'hif-etc-c99 result))
+ ((eq etc t)
+ (cons 'hif-etc result))
+ (t
+ result))))
;; The original version of hideif evaluates the macro early and store the
;; final values for the defined macro into the symbol database (aka
@@ -2280,9 +2458,11 @@ first arg will be `hif-etc'."
(let* ((defining (string= "define" (match-string 2)))
(name (and (re-search-forward hif-macroref-regexp max t)
(match-string 1)))
- (parmlist (or (and (match-string 3) ; First arg id found
+ (parmlist (or (and (or (match-string 3) ; First arg id found
+ (match-string 6)) ; '...' found
(delq 'hif-space
- (hif-parse-macro-arglist (match-string 2))))
+ (hif-parse-macro-arglist
+ (match-string 2))))
(and (match-string 2) ; empty arglist
(list nil)))))
(if defining
@@ -2325,7 +2505,8 @@ first arg will be `hif-etc'."
(expr (and tokens
;; `hif-simple-token-only' is checked only
;; here.
- (or (and hif-simple-token-only
+ (or (and (null parmlist)
+ hif-simple-token-only
(listp tokens)
(= (length tokens) 1)
(hif-parse-exp tokens))
@@ -2354,13 +2535,22 @@ first arg will be `hif-etc'."
(save-excursion
(save-restriction
;; (mark-region min max) ;; for debugging
+ (and min (goto-char min))
(setq hif-verbose-define-count 0)
(forward-comment (point-max))
- (while (hif-find-define min max)
- (forward-comment (point-max))
- (setf min (point)))
+ (setq min (point))
+ (let ((breakloop nil))
+ (while (and (not breakloop)
+ (hif-find-define min max))
+ (forward-comment (point-max))
+ (if (and max
+ (> (point) max))
+ (setq max (point)
+ breakloop t))
+ (setq min (point))))
(if max (goto-char max)
- (goto-char (point-max))))))
+ (goto-char (point-max))
+ nil))))
(defun hide-ifdef-guts ()
"Does most of the work of `hide-ifdefs'.
@@ -2376,7 +2566,7 @@ It does not do the work that's pointless to redo on a recursive entry."
min max)
(setq hif-__COUNTER__ 0)
(goto-char (point-min))
- (setf min (point))
+ (setq min (point))
;; Without this `condition-case' it would be easier to see which
;; operation went wrong thru the backtrace `iff' user realize
;; the underlying meaning of all hif-* operation; for example,
@@ -2384,11 +2574,11 @@ It does not do the work that's pointless to redo on a recursive entry."
;; operation arguments would be invalid.
(condition-case err
(cl-loop do
- (setf max (hif-find-any-ifX))
- (hif-add-new-defines min max)
+ (setq max (hif-find-any-ifX))
+ (setq max (hif-add-new-defines min max))
(if max
(hif-possibly-hide expand-header))
- (setf min (point))
+ (setq min (point))
while max)
(error (error "Error: failed at line %d %S"
(line-number-at-pos) err))))))
diff --git a/lisp/progmodes/hideshow.el b/lisp/progmodes/hideshow.el
index f3033f9fd32..07616960565 100644
--- a/lisp/progmodes/hideshow.el
+++ b/lisp/progmodes/hideshow.el
@@ -254,6 +254,9 @@ This has effect only if `search-invisible' is set to `open'."
;;;###autoload
(defvar hs-special-modes-alist
+ ;; FIXME: Currently the check is made via
+ ;; (assoc major-mode hs-special-modes-alist) so it doesn't pay attention
+ ;; to the mode hierarchy.
(mapcar #'purecopy
'((c-mode "{" "}" "/[*/]" nil nil)
(c-ts-mode "{" "}" "/[*/]" nil nil)
@@ -264,6 +267,7 @@ This has effect only if `search-invisible' is set to `open'."
(java-ts-mode "{" "}" "/[*/]" nil nil)
(js-mode "{" "}" "/[*/]" nil)
(js-ts-mode "{" "}" "/[*/]" nil)
+ (lua-ts-mode "{\\|\\[\\[" "}\\|\\]\\]" "--" nil)
(mhtml-mode "{\\|<[^/>]*?" "}\\|</[^/>]*[^/]>" "<!--" mhtml-forward nil)
;; Add more support here.
))
diff --git a/lisp/progmodes/idlw-help.el b/lisp/progmodes/idlw-help.el
index c8cefbfbdb1..7bed69a738b 100644
--- a/lisp/progmodes/idlw-help.el
+++ b/lisp/progmodes/idlw-help.el
@@ -631,7 +631,7 @@ Needs additional info stored in global `idlwave-completion-help-info'."
Those words in `idlwave-completion-help-links' have links. The
`idlwave-help-link' face is used for this."
(if idlwave-highlight-help-links-in-completion
- (with-current-buffer (get-buffer "*Completions*")
+ (with-current-buffer "*Completions*"
(save-excursion
(let* ((case-fold-search t)
(props (list 'face 'idlwave-help-link))
@@ -1141,7 +1141,6 @@ When DING is non-nil, ring the bell as well."
(goto-char pos)
(recenter 0)))))
-(defvar font-lock-verbose)
(defvar idlwave-mode-syntax-table)
(defvar idlwave-font-lock-defaults)
(defun idlwave-help-fontify ()
diff --git a/lisp/progmodes/idlw-shell.el b/lisp/progmodes/idlw-shell.el
index d9a8aa74b7d..b5d91f46b17 100644
--- a/lisp/progmodes/idlw-shell.el
+++ b/lisp/progmodes/idlw-shell.el
@@ -96,8 +96,8 @@
(defcustom idlwave-shell-prompt-pattern "^\r? ?IDL> "
"Regexp to match IDL prompt at beginning of a line.
-For example, \"^\r?IDL> \" or \"^\r?WAVE> \".
-The \"^\r?\" is needed, to indicate the beginning of the line, with
+For example, \"^\\r?IDL> \" or \"^\\r?WAVE> \".
+The \"^\\r?\" is needed, to indicate the beginning of the line, with
optional return character (which IDL seems to output randomly).
This variable is used to initialize `comint-prompt-regexp' in the
process buffer."
@@ -829,7 +829,7 @@ IDL has currently stepped.")
3. Routine Info
------------
- `\\[idlwave-routine-info]' displays information about an IDL routine near point,
+ \\[idlwave-routine-info] displays information about an IDL routine near point,
just like in `idlwave-mode'. The module used is the one at point or
the one whose argument list is being edited.
To update IDLWAVE's knowledge about compiled or edited modules, use
@@ -1454,9 +1454,7 @@ and then calls `idlwave-shell-send-command' for any pending commands."
(concat idlwave-shell-accumulation string)))
(setq idlwave-shell-accumulation
(substring string
- (progn (string-match "\\(.*[\n\r]+\\)*"
- string)
- (match-end 0)))))
+ (string-match "[^\n\r]*\\'" string))))
(setq idlwave-shell-accumulation
(concat idlwave-shell-accumulation string)))
diff --git a/lisp/progmodes/idlwave.el b/lisp/progmodes/idlwave.el
index 95c0e288bf2..30442fa0d34 100644
--- a/lisp/progmodes/idlwave.el
+++ b/lisp/progmodes/idlwave.el
@@ -309,7 +309,7 @@ beginning with a \";\". Expressions for comments at the beginning of
the line should begin with \"^\"."
:group 'idlwave-code-formatting
:type '(choice (const :tag "Any line beginning with `;'" nil)
- 'regexp))
+ regexp))
(defcustom idlwave-code-comment ";;[^;]"
"A comment that starts with this regular expression on a line by
@@ -657,7 +657,7 @@ When you specify a class, this information can be stored as a text
property on the `->' arrow in the source code, so that during the same
editing session, IDLWAVE will not have to ask again. When this
variable is non-nil, IDLWAVE will store and reuse the class information.
-The class stored can be checked and removed with `\\[idlwave-routine-info]'
+The class stored can be checked and removed with \\[idlwave-routine-info]
on the arrow.
The default of this variable is nil, since the result of commands then
@@ -3891,7 +3891,7 @@ you specify /."
(while (and item)
;;
;; Call etags
- (if (not (string-match "^[ \\t]*$" item))
+ (if (not (string-match "^[ \t]*$" item))
(progn
(message "%s" (concat "Tagging " item "..."))
(setq errbuf (get-buffer-create "*idltags-error*"))
@@ -4311,10 +4311,7 @@ automatically when called interactively. When you need routine
information updated immediately, leave NO-CONCATENATE nil."
(interactive "P\np")
;; Stop any idle processing
- (if (or (and (fboundp 'itimerp)
- (itimerp idlwave-load-rinfo-idle-timer))
- (and (fboundp 'timerp)
- (timerp idlwave-load-rinfo-idle-timer)))
+ (if (timerp idlwave-load-rinfo-idle-timer)
(cancel-timer idlwave-load-rinfo-idle-timer))
(cond
((equal arg '(64))
@@ -4388,10 +4385,7 @@ information updated immediately, leave NO-CONCATENATE nil."
(defvar idlwave-load-rinfo-steps-done (make-vector 6 nil))
(defvar idlwave-load-rinfo-idle-timer nil)
(defun idlwave-start-load-rinfo-timer ()
- (if (or (and (fboundp 'itimerp)
- (itimerp idlwave-load-rinfo-idle-timer))
- (and (fboundp 'timerp)
- (timerp idlwave-load-rinfo-idle-timer)))
+ (if (timerp idlwave-load-rinfo-idle-timer)
(cancel-timer idlwave-load-rinfo-idle-timer))
(setq idlwave-load-rinfo-steps-done (make-vector 6 nil))
(setq idlwave-load-rinfo-idle-timer nil)
@@ -4653,7 +4647,7 @@ Gets set in cached XML rinfo, or `idlw-rinfo.el'.")
(setcar alias (car x))
(push alias idlwave-system-routines)))
(cl-loop for x in remove-list do
- (delq x idlwave-system-routines))))
+ (setq idlwave-system-routines (delq x idlwave-system-routines)))))
(defun idlwave-convert-xml-clean-sysvar-aliases (aliases)
;; Duplicate and trim original routine aliases from rinfo list
@@ -4666,7 +4660,8 @@ Gets set in cached XML rinfo, or `idlw-rinfo.el'.")
(setcar alias (car x))
(push alias idlwave-system-variables-alist)))
(cl-loop for x in remove-list do
- (delq x idlwave-system-variables-alist))))
+ (setq idlwave-system-variables-alist
+ (delq x idlwave-system-variables-alist)))))
(defun idlwave-xml-create-sysvar-alist (xml-entry)
@@ -5340,7 +5335,6 @@ directories and save the routine info.
(idlwave-path-alist-remove-flag dir-entry 'user)))
(idlwave-scan-user-lib-files path-alist)))
-(defvar font-lock-mode)
(defun idlwave-scan-user-lib-files (path-alist)
;; Scan the PRO files in PATH-ALIST and store the info in the user catalog
(let* ((idlwave-scanning-lib t)
@@ -6898,7 +6892,7 @@ If these don't exist, a letter in the string is automatically selected."
;; Display prompt and wait for quick reply
(message "%s[%s]" prompt
(mapconcat (lambda(x) (char-to-string (car x)))
- keys-alist ""))
+ keys-alist))
(if (sit-for delay)
;; No quick reply: Show help
(save-window-excursion
@@ -7964,7 +7958,7 @@ demand _EXTRA in the keyword list."
;; If this is the OBJ_NEW function, try to figure out the class and use
;; the keywords from the corresponding INIT method.
(if (and (equal (upcase name) "OBJ_NEW")
- (derived-mode-p 'idlwave-mode 'idlwave-shell-mode))
+ (derived-mode-p '(idlwave-mode idlwave-shell-mode)))
(let* ((bos (save-excursion (idlwave-beginning-of-statement) (point)))
(string (buffer-substring bos (point)))
(case-fold-search t)
@@ -8756,11 +8750,12 @@ This expects NAME TYPE IDLWAVE-TWIN-CLASS to be bound to the right values."
(defun idlwave-count-eq (elt list)
"How often is ELT in LIST?"
- (length (delq nil (mapcar (lambda (x) (eq x elt)) list))))
+ (declare (obsolete nil "30.1"))
+ (seq-count (lambda (x) (eq x elt)) list))
(defun idlwave-count-memq (elt alist)
"How often is ELT a key in ALIST?"
- (length (delq nil (mapcar (lambda (x) (eq (car x) elt)) alist))))
+ (seq-count (lambda (x) (eq (car x) elt)) alist))
(defun idlwave-syslib-p (file)
"Non-nil if FILE is in the system library."
diff --git a/lisp/progmodes/java-ts-mode.el b/lisp/progmodes/java-ts-mode.el
index 5c4bce340f0..bb4a7df3340 100644
--- a/lisp/progmodes/java-ts-mode.el
+++ b/lisp/progmodes/java-ts-mode.el
@@ -310,6 +310,13 @@ Return nil if there is no name or if NODE is not a defun node."
(treesit-node-child-by-field-name node "name")
t))))
+
+(defvar java-ts-mode--feature-list
+ '(( comment definition )
+ ( constant keyword string type)
+ ( annotation expression literal)
+ ( bracket delimiter operator)))
+
;;;###autoload
(define-derived-mode java-ts-mode prog-mode "Java"
"Major mode for editing Java, powered by tree-sitter."
@@ -362,13 +369,34 @@ Return nil if there is no name or if NODE is not a defun node."
"constructor_declaration")))
(setq-local treesit-defun-name-function #'java-ts-mode--defun-name)
+ (setq-local treesit-thing-settings
+ `((java
+ (sexp ,(rx (or "annotation"
+ "parenthesized_expression"
+ "argument_list"
+ "identifier"
+ "modifiers"
+ "block"
+ "body"
+ "literal"
+ "access"
+ "reference"
+ "_type"
+ "true"
+ "false")))
+ (sentence ,(rx (or "statement"
+ "local_variable_declaration"
+ "field_declaration"
+ "module_declaration"
+ "package_declaration"
+ "import_declaration")))
+ (text ,(regexp-opt '("line_comment"
+ "block_comment"
+ "text_block"))))))
+
;; Font-lock.
(setq-local treesit-font-lock-settings java-ts-mode--font-lock-settings)
- (setq-local treesit-font-lock-feature-list
- '(( comment definition )
- ( constant keyword string type)
- ( annotation expression literal)
- ( bracket delimiter operator)))
+ (setq-local treesit-font-lock-feature-list java-ts-mode--feature-list)
;; Imenu.
(setq-local treesit-simple-imenu-settings
@@ -378,6 +406,8 @@ Return nil if there is no name or if NODE is not a defun node."
("Method" "\\`method_declaration\\'" nil nil)))
(treesit-major-mode-setup))
+(derived-mode-add-parents 'java-ts-mode '(java-mode))
+
(if (treesit-ready-p 'java)
(add-to-list 'auto-mode-alist '("\\.java\\'" . java-ts-mode)))
diff --git a/lisp/progmodes/js.el b/lisp/progmodes/js.el
index 20350c0ccb6..6cb84592896 100644
--- a/lisp/progmodes/js.el
+++ b/lisp/progmodes/js.el
@@ -672,15 +672,6 @@ This variable is like `sgml-attribute-offset'."
:type 'integer
:safe 'integerp)
-;;; Keymap
-
-(defvar-keymap js-mode-map
- :doc "Keymap for `js-mode'."
- "M-." #'js-find-symbol)
-
-(defvar js-ts-mode-map (copy-keymap js-mode-map)
- "Keymap used in `js-ts-mode'.")
-
;;; Syntax table and parsing
(defvar js-mode-syntax-table
@@ -3726,6 +3717,9 @@ Currently there are `js-mode' and `js-ts-mode'."
(define-derived-mode js-mode js-base-mode "JavaScript"
"Major mode for editing JavaScript."
:group 'js
+ (js--mode-setup))
+
+(defun js--mode-setup ()
;; Ensure all CC Mode "lang variables" are set to valid values.
(c-init-language-vars js-mode)
(setq-local indent-line-function #'js-indent-line)
@@ -3808,6 +3802,54 @@ Currently there are `js-mode' and `js-ts-mode'."
;;(syntax-propertize (point-max))
)
+(defvar js--treesit-sentence-nodes
+ '("import_statement"
+ "debugger_statement"
+ "expression_statement"
+ "if_statement"
+ "switch_statement"
+ "for_statement"
+ "for_in_statement"
+ "while_statement"
+ "do_statement"
+ "try_statement"
+ "with_statement"
+ "break_statement"
+ "continue_statement"
+ "return_statement"
+ "throw_statement"
+ "empty_statement"
+ "labeled_statement"
+ "variable_declaration"
+ "lexical_declaration"
+ "jsx_element"
+ "jsx_self_closing_element")
+ "Nodes that designate sentences in JavaScript.
+See `treesit-thing-settings' for more information.")
+
+(defvar js--treesit-sexp-nodes
+ '("expression"
+ "pattern"
+ "array"
+ "function"
+ "string"
+ "escape"
+ "template"
+ "regex"
+ "number"
+ "identifier"
+ "this"
+ "super"
+ "true"
+ "false"
+ "null"
+ "undefined"
+ "arguments"
+ "pair"
+ "jsx")
+ "Nodes that designate sexps in JavaScript.
+See `treesit-thing-settings' for more information.")
+
;;;###autoload
(define-derived-mode js-ts-mode js-base-mode "JavaScript"
"Major mode for editing JavaScript.
@@ -3824,6 +3866,7 @@ Currently there are `js-mode' and `js-ts-mode'."
;; Comment.
(c-ts-common-comment-setup)
(setq-local comment-multi-line t)
+
;; Electric-indent.
(setq-local electric-indent-chars
(append "{}():;,<>/" electric-indent-chars)) ;FIXME: js2-mode adds "[]*".
@@ -3843,6 +3886,14 @@ Currently there are `js-mode' and `js-ts-mode'."
"function_declaration"
"lexical_declaration")))
(setq-local treesit-defun-name-function #'js--treesit-defun-name)
+
+ (setq-local treesit-thing-settings
+ `((javascript
+ (sexp ,(regexp-opt js--treesit-sexp-nodes))
+ (sentence ,(regexp-opt js--treesit-sentence-nodes))
+ (text ,(regexp-opt '("comment"
+ "template_string"))))))
+
;; Fontification.
(setq-local treesit-font-lock-settings js--treesit-font-lock-settings)
(setq-local treesit-font-lock-feature-list
@@ -3865,6 +3916,8 @@ Currently there are `js-mode' and `js-ts-mode'."
(add-to-list 'auto-mode-alist
'("\\(\\.js[mx]\\|\\.har\\)\\'" . js-ts-mode))))
+(derived-mode-add-parents 'js-ts-mode '(js-mode))
+
(defvar js-ts--s-p-query
(when (treesit-available-p)
(treesit-query-compile 'javascript
@@ -3891,7 +3944,9 @@ Currently there are `js-mode' and `js-ts-mode'."
(put-text-property (1- ne) ne 'syntax-table syntax)))))
;;;###autoload
-(define-derived-mode js-json-mode js-mode "JSON"
+(define-derived-mode js-json-mode prog-mode "JSON"
+ :syntax-table js-mode-syntax-table
+ (js--mode-setup) ;Reuse most of `js-mode', but not as parent (bug#67463).
(setq-local js-enabled-frameworks nil)
;; Speed up `syntax-ppss': JSON files can be big but can't hold
;; regexp matchers nor #! thingies (and `js-enabled-frameworks' is nil).
diff --git a/lisp/progmodes/json-ts-mode.el b/lisp/progmodes/json-ts-mode.el
index dc19abec305..1fb96555010 100644
--- a/lisp/progmodes/json-ts-mode.el
+++ b/lisp/progmodes/json-ts-mode.el
@@ -147,6 +147,10 @@ Return nil if there is no name or if NODE is not a defun node."
(rx (or "pair" "object")))
(setq-local treesit-defun-name-function #'json-ts-mode--defun-name)
+ (setq-local treesit-thing-settings
+ `((json
+ (sentence "pair"))))
+
;; Font-lock.
(setq-local treesit-font-lock-settings json-ts-mode--font-lock-settings)
(setq-local treesit-font-lock-feature-list
@@ -160,6 +164,8 @@ Return nil if there is no name or if NODE is not a defun node."
(treesit-major-mode-setup))
+(derived-mode-add-parents 'json-ts-mode '(json-mode))
+
(if (treesit-ready-p 'json)
(add-to-list 'auto-mode-alist
'("\\.json\\'" . json-ts-mode)))
diff --git a/lisp/progmodes/lua-ts-mode.el b/lisp/progmodes/lua-ts-mode.el
new file mode 100644
index 00000000000..407ef230c32
--- /dev/null
+++ b/lisp/progmodes/lua-ts-mode.el
@@ -0,0 +1,797 @@
+;;; lua-ts-mode.el --- Major mode for editing Lua files -*- lexical-binding: t -*-
+
+;; Copyright (C) 2023-2024 Free Software Foundation, Inc.
+
+;; Author: John Muhl <jm@pub.pink>
+;; Created: June 27, 2023
+;; Keywords: lua languages tree-sitter
+
+;; This file is part of GNU Emacs.
+
+;; GNU Emacs is free software: you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+;;
+;; GNU Emacs is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+;;
+;; You should have received a copy of the GNU General Public License
+;; along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>.
+
+;;; Commentary:
+
+;; This package provides `lua-ts-mode' which is a major mode for Lua
+;; files that uses Tree Sitter to parse the language.
+;;
+;; This package is compatible with and tested against the grammar for
+;; Lua found at https://github.com/tree-sitter-grammars/tree-sitter-lua
+
+;;; Code:
+
+(require 'comint)
+(require 'treesit)
+
+(eval-when-compile
+ (require 'cl-lib)
+ (require 'rx))
+
+(declare-function treesit-induce-sparse-tree "treesit.c")
+(declare-function treesit-node-child-by-field-name "treesit.c")
+(declare-function treesit-node-child-count "treesit.c")
+(declare-function treesit-node-first-child-for-pos "treesit.c")
+(declare-function treesit-node-parent "treesit.c")
+(declare-function treesit-node-start "treesit.c")
+(declare-function treesit-node-end "treesit.c")
+(declare-function treesit-node-type "treesit.c")
+(declare-function treesit-parser-create "treesit.c")
+(declare-function treesit-search-subtree "treesit.c")
+
+(defgroup lua-ts nil
+ "Major mode for editing Lua files."
+ :prefix "lua-ts-"
+ :group 'languages)
+
+(defcustom lua-ts-mode-hook nil
+ "Hook run after entering `lua-ts-mode'."
+ :type 'hook
+ :options '(flymake-mode
+ hs-minor-mode
+ outline-minor-mode)
+ :version "30.1")
+
+(defcustom lua-ts-indent-offset 4
+ "Number of spaces for each indentation step in `lua-ts-mode'."
+ :type 'natnum
+ :safe 'natnump
+ :version "30.1")
+
+(defcustom lua-ts-luacheck-program "luacheck"
+ "Location of the Luacheck program."
+ :type '(choice (const :tag "None" nil) string)
+ :version "30.1")
+
+(defcustom lua-ts-inferior-buffer "*Lua*"
+ "Name of the inferior Lua buffer."
+ :type 'string
+ :safe 'stringp
+ :version "30.1")
+
+(defcustom lua-ts-inferior-program "lua"
+ "Program to run in the inferior Lua process."
+ :type '(choice (const :tag "None" nil) string)
+ :version "30.1")
+
+(defcustom lua-ts-inferior-options '("-i")
+ "Command line options for the inferior Lua process."
+ :type '(repeat string)
+ :version "30.1")
+
+(defcustom lua-ts-inferior-startfile nil
+ "File to load into the inferior Lua process at startup."
+ :type '(choice (const :tag "None" nil) (file :must-match t))
+ :version "30.1")
+
+(defcustom lua-ts-inferior-prompt ">"
+ "Prompt used by the inferior Lua process."
+ :type 'string
+ :safe 'stringp
+ :version "30.1")
+
+(defcustom lua-ts-inferior-prompt-continue ">>"
+ "Continuation prompt used by the inferior Lua process."
+ :type 'string
+ :safe 'stringp
+ :version "30.1")
+
+(defcustom lua-ts-inferior-history nil
+ "File used to save command history of the inferior Lua process."
+ :type '(choice (const :tag "None" nil) file)
+ :safe 'string-or-null-p
+ :version "30.1")
+
+(defcustom lua-ts-indent-continuation-lines t
+ "Controls how multi-line if/else statements are aligned.
+
+If t, then continuation lines are indented by `lua-ts-indent-offset':
+
+ if a
+ and b then
+ print(1)
+ end
+
+If nil, then continuation lines are aligned with the beginning of
+the statement:
+
+ if a
+ and b then
+ print(1)
+ end"
+ :type 'boolean
+ :safe 'booleanp
+ :version "30.1")
+
+(defvar lua-ts--builtins
+ '("assert" "bit32" "collectgarbage" "coroutine" "debug" "dofile"
+ "error" "getmetatable" "io" "ipairs" "load" "loadfile"
+ "math" "next" "os" "package" "pairs" "pcall" "print"
+ "rawequal" "rawget" "rawlen" "rawset" "require" "select"
+ "setmetatable" "string" "table" "tonumber" "tostring"
+ "type" "utf8" "warn" "xpcall" "_G" "_VERSION"
+ ;; methods for file handlers
+ "close" "flush" "lines" "read" "seek" "setvbuf" "write")
+ "Lua built-in functions for tree-sitter font-locking.")
+
+(defvar lua-ts--keywords
+ '("and" "do" "else" "elseif" "end" "for" "function" "goto" "if"
+ "in" "local" "not" "or" "repeat" "return" "then" "until" "while")
+ "Lua keywords for tree-sitter font-locking and navigation.")
+
+(defun lua-ts--comment-font-lock (node override start end &rest _)
+ "Apply font lock to comment NODE within START and END.
+Applies `font-lock-comment-delimiter-face' and
+`font-lock-comment-face'. See `treesit-fontify-with-override' for
+values of OVERRIDE."
+ (let* ((node-start (treesit-node-start node))
+ (node-end (treesit-node-end node))
+ (node-text (treesit-node-text node t))
+ (delimiter-end (+ 2 node-start)))
+ (when (and (>= node-start start)
+ (<= delimiter-end end)
+ (string-match "\\`--" node-text))
+ (treesit-fontify-with-override node-start
+ delimiter-end
+ font-lock-comment-delimiter-face
+ override))
+ (treesit-fontify-with-override (max delimiter-end start)
+ (min node-end end)
+ font-lock-comment-face
+ override)))
+
+(defvar lua-ts--font-lock-settings
+ (treesit-font-lock-rules
+ :default-language 'lua
+ :feature 'bracket
+ '(["(" ")" "[" "]" "{" "}"] @font-lock-bracket-face)
+
+ :feature 'delimiter
+ '(["," ";"] @font-lock-delimiter-face)
+
+ :feature 'constant
+ '([(variable_list
+ attribute: (attribute (["<" ">"] (identifier))))
+ (label_statement)
+ (true) (false) (nil)]
+ @font-lock-constant-face)
+
+ :feature 'operator
+ '(["+" "-" "*" "/" "%" "^" "#" "==" "~=" "<=" ">="
+ "<" ">" "=" "&" "~" "|" "<<" ">>" "//" ".."
+ (vararg_expression)]
+ @font-lock-operator-face)
+
+ :feature 'builtin
+ `(((identifier) @font-lock-builtin-face
+ (:match ,(regexp-opt lua-ts--builtins 'symbols)
+ @font-lock-builtin-face)))
+
+ :feature 'function
+ '((function_call name: (identifier) @font-lock-function-call-face)
+ (function_call
+ (method_index_expression
+ method: (identifier) @font-lock-function-call-face))
+ (function_call
+ (dot_index_expression
+ field: (identifier) @font-lock-function-call-face)))
+
+ :feature 'punctuation
+ '(["." ":"] @font-lock-punctuation-face)
+
+ :feature 'variable
+ '((function_call
+ (arguments (identifier) @font-lock-variable-use-face))
+ (function_call
+ (arguments
+ (binary_expression (identifier) @font-lock-variable-use-face)))
+ (function_call
+ (arguments
+ (bracket_index_expression (identifier) @font-lock-variable-use-face)))
+ (function_declaration
+ (parameters name: (identifier) @font-lock-variable-name-face)))
+
+ :feature 'number
+ '((number) @font-lock-number-face)
+
+ :feature 'keyword
+ `([(break_statement)
+ ,(vconcat lua-ts--keywords)]
+ @font-lock-keyword-face
+ (goto_statement ((identifier) @font-lock-constant-face)))
+
+ :feature 'string
+ '((string) @font-lock-string-face)
+
+ :feature 'escape
+ :override t
+ '((escape_sequence) @font-lock-escape-face)
+
+ :feature 'comment
+ '((comment) @lua-ts--comment-font-lock
+ (hash_bang_line) @font-lock-comment-face)
+
+ :feature 'definition
+ '((function_declaration
+ (identifier) @font-lock-function-name-face)
+ (function_declaration
+ (dot_index_expression
+ field: (identifier) @font-lock-function-name-face))
+ (function_declaration
+ (method_index_expression
+ method: (identifier) @font-lock-function-name-face))
+ (assignment_statement
+ (variable_list
+ (identifier) @font-lock-function-name-face)
+ (expression_list value: (function_definition)))
+ (field
+ name: (identifier) @font-lock-function-name-face
+ value: (function_definition))
+ (assignment_statement
+ (variable_list
+ (dot_index_expression
+ field: (identifier) @font-lock-function-name-face))
+ (expression_list
+ value:
+ (function_definition))))
+
+ :feature 'assignment
+ '((variable_list (identifier) @font-lock-variable-name-face)
+ (variable_list
+ (bracket_index_expression
+ field: (identifier) @font-lock-variable-name-face))
+ (variable_list
+ (dot_index_expression
+ field: (identifier) @font-lock-variable-name-face))
+ (for_numeric_clause name: (identifier) @font-lock-variable-name-face))
+
+ :feature 'property
+ '((field name: (identifier) @font-lock-property-name-face)
+ (dot_index_expression
+ field: (identifier) @font-lock-property-use-face))
+
+ :feature 'error
+ :override t
+ '((ERROR) @font-lock-warning-face))
+ "Tree-sitter font-lock settings for `lua-ts-mode'.")
+
+(defvar lua-ts--simple-indent-rules
+ `((lua
+ ((or (node-is "comment")
+ (parent-is "comment_content")
+ (parent-is "string_content")
+ (node-is "]]"))
+ no-indent 0)
+ ((and (n-p-gp "field" "table_constructor" "arguments")
+ lua-ts--multi-arg-function-call-matcher)
+ parent lua-ts-indent-offset)
+ ((and (n-p-gp "}" "table_constructor" "arguments")
+ lua-ts--multi-arg-function-call-matcher)
+ parent 0)
+ ((or (node-is "do")
+ (node-is "then")
+ (node-is "elseif_statement")
+ (node-is "else_statement")
+ (node-is "until")
+ (node-is ")")
+ (node-is "}"))
+ standalone-parent 0)
+ ((match null "table_constructor")
+ standalone-parent lua-ts-indent-offset)
+ ((or (and (parent-is "arguments") lua-ts--first-child-matcher)
+ (and (parent-is "parameters") lua-ts--first-child-matcher)
+ (and (parent-is "table_constructor") lua-ts--first-child-matcher))
+ standalone-parent lua-ts-indent-offset)
+ ((or (parent-is "arguments")
+ (parent-is "parameters")
+ (parent-is "table_constructor"))
+ (nth-sibling 1) 0)
+ ((and (n-p-gp "block" "function_definition" "parenthesized_expression")
+ lua-ts--nested-function-block-matcher
+ lua-ts--nested-function-block-include-matcher)
+ parent lua-ts-indent-offset)
+ ((and (n-p-gp "block" "function_definition" "arguments")
+ lua-ts--nested-function-argument-matcher)
+ parent lua-ts-indent-offset)
+ ((match "function_definition" "parenthesized_expression")
+ standalone-parent lua-ts-indent-offset)
+ ((node-is "block") standalone-parent lua-ts-indent-offset)
+ ((parent-is "block") parent 0)
+ ((and (node-is "end") lua-ts--end-line-matcher)
+ standalone-parent lua-ts--end-indent-offset)
+ ((match "end" "function_declaration") parent 0)
+ ((and (n-p-gp "end" "function_definition" "parenthesized_expression")
+ lua-ts--nested-function-end-argument-matcher)
+ parent 0)
+ ((and (n-p-gp "end" "function_definition" "parenthesized_expression")
+ lua-ts--nested-function-block-matcher
+ lua-ts--nested-function-end-matcher
+ lua-ts--nested-function-last-function-matcher)
+ parent 0)
+ ((n-p-gp "end" "function_definition" "arguments") parent 0)
+ ((or (match "end" "function_definition")
+ (node-is "end"))
+ standalone-parent 0)
+ ((n-p-gp "expression_list" "assignment_statement" "variable_declaration")
+ lua-ts--variable-declaration-continuation-anchor
+ lua-ts-indent-offset)
+ ((and (parent-is "binary_expression")
+ lua-ts--variable-declaration-continuation)
+ lua-ts--variable-declaration-continuation-anchor
+ lua-ts-indent-offset)
+ ((and (lambda (&rest _) lua-ts-indent-continuation-lines)
+ (parent-is "binary_expression"))
+ standalone-parent lua-ts-indent-offset)
+ ((parent-is "binary_expression") standalone-parent 0)
+ ((or (parent-is "function_declaration")
+ (parent-is "function_definition")
+ (parent-is "do_statement")
+ (parent-is "for_statement")
+ (parent-is "repeat_statement")
+ (parent-is "while_statement")
+ (parent-is "if_statement")
+ (parent-is "else_statement")
+ (parent-is "elseif_statement"))
+ standalone-parent lua-ts-indent-offset)
+ ((parent-is "chunk") column-0 0)
+ ((parent-is "ERROR") no-indent 0))))
+
+(defun lua-ts--end-line-matcher (&rest _)
+ "Matches if there is more than one `end' on the current line."
+ (> (lua-ts--end-count) 1))
+
+(defun lua-ts--end-indent-offset (&rest _)
+ "Calculate indent offset based on `end' count."
+ (- (* (1- (lua-ts--end-count)) lua-ts-indent-offset)))
+
+(defun lua-ts--end-count ()
+ "Count the number of `end's on the current line."
+ (count-matches "end" (line-beginning-position) (line-end-position)))
+
+(defun lua-ts--first-child-matcher (node &rest _)
+ "Matches if NODE is the first among its siblings."
+ (= (treesit-node-index node) 1))
+
+(defun lua-ts--function-definition-p (node)
+ "Return t if NODE is a function_definition."
+ (equal "function_definition" (treesit-node-type node)))
+
+(defun lua-ts--g-g-g-parent (node)
+ "Return the great-great-grand-parent of NODE."
+ (let* ((parent (treesit-node-parent node))
+ (g-parent (treesit-node-parent parent))
+ (g-g-parent (treesit-node-parent g-parent)))
+ (treesit-node-parent g-g-parent)))
+
+(defun lua-ts--multi-arg-function-call-matcher (_n parent &rest _)
+ "Matches if PARENT has multiple arguments."
+ (> (treesit-node-child-count (treesit-node-parent parent)) 3))
+
+(defun lua-ts--nested-function-argument-matcher (node &rest _)
+ "Matches if NODE is in a nested function argument."
+ (save-excursion
+ (goto-char (treesit-node-start node))
+ (treesit-beginning-of-defun)
+ (backward-char 2)
+ (not (looking-at ")("))))
+
+(defun lua-ts--nested-function-block-matcher (node &rest _)
+ "Matches if NODE is in a nested function block."
+ (let* ((g-g-g-parent (lua-ts--g-g-g-parent node))
+ (g-g-g-type (treesit-node-type g-g-g-parent)))
+ (not (equal g-g-g-type "chunk"))))
+
+(defun lua-ts--nested-function-block-include-matcher (node _p bol &rest _)
+ "Matches if NODE's child at BOL is not another block."
+ (let* ((child (treesit-node-first-child-for-pos node bol))
+ (child-type (treesit-node-type child))
+ (g-g-g-type (treesit-node-type (lua-ts--g-g-g-parent node))))
+ (or (equal child-type "assignment_statement")
+ (and (equal child-type "return_statement")
+ (or (equal g-g-g-type "arguments")
+ (and (equal g-g-g-type "expression_list")
+ (not (treesit-search-subtree child "function_call"))))))))
+
+(defun lua-ts--nested-function-end-matcher (node &rest _)
+ "Matches if NODE is the `end' of a nested function."
+ (save-excursion
+ (goto-char (treesit-node-start node))
+ (treesit-beginning-of-defun)
+ (looking-at "function[[:space:]]*")))
+
+(defun lua-ts--nested-function-end-argument-matcher (node &rest _)
+ "Matches if great-great-grandparent of NODE is arguments."
+ (equal "arguments" (treesit-node-type (lua-ts--g-g-g-parent node))))
+
+(defun lua-ts--nested-function-last-function-matcher (_n parent &rest _)
+ "Matches if PARENT is the last nested function."
+ (let ((sparse-tree
+ (treesit-induce-sparse-tree parent #'lua-ts--function-definition-p)))
+ (= 1 (length (cadr sparse-tree)))))
+
+(defun lua-ts--variable-declaration-continuation (node &rest _)
+ "Matches if NODE is part of a multi-line variable declaration."
+ (treesit-parent-until node
+ (lambda (p)
+ (equal "variable_declaration"
+ (treesit-node-type p)))))
+
+(defun lua-ts--variable-declaration-continuation-anchor (node &rest _)
+ "Return the start position of the variable declaration for NODE."
+ (save-excursion
+ (goto-char (treesit-node-start
+ (lua-ts--variable-declaration-continuation node)))
+ (when (looking-back (rx bol (* whitespace))
+ (line-beginning-position))
+ (point))))
+
+(defvar lua-ts--syntax-table
+ (let ((table (make-syntax-table)))
+ (modify-syntax-entry ?+ "." table)
+ (modify-syntax-entry ?- ". 12" table)
+ (modify-syntax-entry ?= "." table)
+ (modify-syntax-entry ?% "." table)
+ (modify-syntax-entry ?^ "." table)
+ (modify-syntax-entry ?~ "." table)
+ (modify-syntax-entry ?< "." table)
+ (modify-syntax-entry ?> "." table)
+ (modify-syntax-entry ?/ "." table)
+ (modify-syntax-entry ?* "." table)
+ (modify-syntax-entry ?\n ">" table)
+ (modify-syntax-entry ?\' "\"" table)
+ (modify-syntax-entry ?\" "\"" table)
+ table)
+ "Syntax table for `lua-ts-mode'.")
+
+(defun lua-ts--defun-name-function (node)
+ "Return the defun name of NODE.
+Return nil if there is no name or if NODE is not a defun node."
+ (let ((child (treesit-node-child-by-field-name node "name")))
+ (pcase (treesit-node-type node)
+ ((or "function_declaration" "function_definition")
+ (treesit-node-text child t))
+ ("variable_declaration"
+ (if child
+ (treesit-node-text child t)
+ (treesit-node-text
+ (treesit-node-child-by-field-name
+ (treesit-search-subtree node "assignment_statement" nil nil 1)
+ "name"))))
+ ("field"
+ (and (treesit-search-subtree node "function_definition" nil nil 1)
+ (treesit-node-text child t))))))
+
+(defun lua-ts--named-function-p (node)
+ "Matches if NODE is a named function."
+ (let ((type (treesit-node-type node)))
+ (or (equal "function_declaration" type)
+ (and (equal "field" type)
+ (equal "function_definition"
+ (treesit-node-type
+ (treesit-node-child-by-field-name
+ node "value")))
+ (treesit-node-child-by-field-name node "name")))))
+
+(defun lua-ts--require-name-function (node)
+ "Return name of NODE to use for requires in imenu."
+ (when-let* (((lua-ts--require-p node))
+ (parent (treesit-node-parent node))
+ (parent-type (treesit-node-type parent)))
+ (if (equal "expression_list" parent-type)
+ (let* ((g-parent (treesit-node-parent parent))
+ (name (treesit-node-child-by-field-name g-parent "name")))
+ (treesit-node-text name t))
+ (treesit-node-text (treesit-search-subtree node "string_content") t))))
+
+(defun lua-ts--require-p (node)
+ "Matches if NODE is a require statement."
+ (let ((name (treesit-node-child-by-field-name node "name")))
+ (equal "require" (treesit-node-text name t))))
+
+(defvar-local lua-ts--flymake-process nil)
+
+(defun lua-ts-flymake-luacheck (report-fn &rest _args)
+ "Luacheck backend for Flymake.
+Calls REPORT-FN directly."
+ (when (process-live-p lua-ts--flymake-process)
+ (kill-process lua-ts--flymake-process))
+ (let ((source (current-buffer)))
+ (save-restriction
+ (widen)
+ (setq lua-ts--flymake-process
+ (make-process
+ :name "lua-ts-flymake-luacheck"
+ :noquery t
+ :connection-type 'pipe
+ :buffer (generate-new-buffer " *lua-ts-flymake-luacheck*")
+ :command `(,lua-ts-luacheck-program
+ "--codes" "--ranges" "--formatter" "plain" "-")
+ :sentinel
+ (lambda (proc _event)
+ (when (eq 'exit (process-status proc))
+ (unwind-protect
+ (if (with-current-buffer source
+ (eq proc lua-ts--flymake-process))
+ (with-current-buffer (process-buffer proc)
+ (goto-char (point-min))
+ (cl-loop
+ while (search-forward-regexp
+ (rx (seq bol
+ (0+ alnum) ":"
+ (group (1+ digit)) ":"
+ (group (1+ digit)) "-"
+ (group (1+ digit)) ": "
+ (group (0+ nonl))
+ eol))
+ nil t)
+ for (beg . end) = (flymake-diag-region
+ source
+ (string-to-number (match-string 1))
+ (string-to-number (match-string 2)))
+ for msg = (match-string 4)
+ for type = (if (string-match "^(W" msg)
+ :warning
+ :error)
+ when (and beg end)
+ collect (flymake-make-diagnostic source
+ beg
+ end
+ type
+ msg)
+ into diags
+ finally (funcall report-fn diags)))
+ (flymake-log :warning "Canceling obsolete check %s" proc))
+ (kill-buffer (process-buffer proc)))))))
+ (process-send-region lua-ts--flymake-process (point-min) (point-max))
+ (process-send-eof lua-ts--flymake-process))))
+
+;;;###autoload
+(defun lua-ts-inferior-lua ()
+ "Run a Lua interpreter in an inferior process."
+ (interactive)
+ (unless (comint-check-proc lua-ts-inferior-buffer)
+ (apply #'make-comint-in-buffer
+ (string-replace "*" "" lua-ts-inferior-buffer)
+ lua-ts-inferior-buffer
+ lua-ts-inferior-program
+ lua-ts-inferior-startfile
+ lua-ts-inferior-options)
+ (when lua-ts-inferior-history
+ (set-process-sentinel (get-buffer-process lua-ts-inferior-buffer)
+ 'lua-ts-inferior--write-history))
+ (with-current-buffer lua-ts-inferior-buffer
+ (setq-local comint-input-ignoredups t
+ comint-input-ring-file-name lua-ts-inferior-history
+ comint-prompt-read-only t
+ comint-prompt-regexp (rx-to-string `(: bol
+ ,lua-ts-inferior-prompt
+ (1+ space))))
+ (comint-read-input-ring t)
+ (add-hook 'comint-preoutput-filter-functions
+ (lambda (string)
+ (if (equal string (concat lua-ts-inferior-prompt-continue " "))
+ string
+ (concat
+ ;; Filter out the extra prompt characters that
+ ;; accumulate in the output when sending regions
+ ;; to the inferior process.
+ (replace-regexp-in-string (rx-to-string
+ `(: bol
+ (* ,lua-ts-inferior-prompt
+ (? ,lua-ts-inferior-prompt)
+ (1+ space))
+ (group (* nonl))))
+ "\\1" string)
+ ;; Re-add the prompt for the next line.
+ lua-ts-inferior-prompt " ")))
+ nil t)))
+ (select-window (display-buffer lua-ts-inferior-buffer
+ '((display-buffer-reuse-window
+ display-buffer-pop-up-window)
+ (reusable-frames . t))))
+ (get-buffer-process (current-buffer)))
+
+(defun lua-ts-send-buffer ()
+ "Send current buffer to the inferior Lua process."
+ (interactive)
+ (lua-ts-send-region (point-min) (point-max)))
+
+(defun lua-ts-send-file (file)
+ "Send contents of FILE to the inferior Lua process."
+ (interactive "f")
+ (with-temp-buffer
+ (insert-file-contents-literally file)
+ (lua-ts-send-region (point-min) (point-max))))
+
+(defun lua-ts-send-region (beg end)
+ "Send region between BEG and END to the inferior Lua process."
+ (interactive "r")
+ (let ((string (buffer-substring-no-properties beg end))
+ (proc-buffer (lua-ts-inferior-lua)))
+ (comint-send-string proc-buffer "print()") ; Prevent output from
+ (comint-send-string proc-buffer "\n") ; appearing at prompt.
+ (comint-send-string proc-buffer string)
+ (comint-send-string proc-buffer "\n")))
+
+(defun lua-ts-show-process-buffer ()
+ "Show the inferior Lua process buffer."
+ (interactive)
+ (display-buffer lua-ts-inferior-buffer))
+
+(defun lua-ts-hide-process-buffer ()
+ "Hide the inferior Lua process buffer."
+ (interactive)
+ (delete-windows-on lua-ts-inferior-buffer))
+
+(defun lua-ts-kill-process ()
+ "Kill the inferior Lua process."
+ (interactive)
+ (with-current-buffer lua-ts-inferior-buffer
+ (kill-buffer-and-window)))
+
+(defun lua-ts-inferior--write-history (process _)
+ "Write history file for inferior Lua PROCESS."
+ ;; Depending on how the process is killed the buffer may not be
+ ;; around anymore; e.g. `kill-buffer'.
+ (when-let* ((buffer (process-buffer process))
+ ((buffer-live-p (process-buffer process))))
+ (with-current-buffer buffer (comint-write-input-ring))))
+
+(defvar lua-ts-mode-map
+ (let ((map (make-sparse-keymap "Lua")))
+ (define-key map "\C-c\C-n" 'lua-ts-inferior-lua)
+ (define-key map "\C-c\C-c" 'lua-ts-send-buffer)
+ (define-key map "\C-c\C-l" 'lua-ts-send-file)
+ (define-key map "\C-c\C-r" 'lua-ts-send-region)
+ map)
+ "Keymap for `lua-ts-mode' buffers.")
+
+(easy-menu-define lua-ts-mode-menu lua-ts-mode-map
+ "Menu bar entry for `lua-ts-mode'."
+ `("Lua"
+ ["Evaluate Buffer" lua-ts-send-buffer]
+ ["Evaluate File" lua-ts-send-file]
+ ["Evaluate Region" lua-ts-send-region]
+ "--"
+ ["Start Process" lua-ts-inferior-lua]
+ ["Show Process Buffer" lua-ts-show-process-buffer]
+ ["Hide Process Buffer" lua-ts-hide-process-buffer]
+ ["Kill Process" lua-ts-kill-process]
+ "--"
+ ["Customize" (lambda () (interactive) (customize-group "lua-ts"))]))
+
+;;;###autoload
+(define-derived-mode lua-ts-mode prog-mode "Lua"
+ "Major mode for editing Lua files, powered by tree-sitter.
+
+\\{lua-ts-mode-map}"
+ :syntax-table lua-ts--syntax-table
+ (use-local-map lua-ts-mode-map)
+
+ (when (treesit-ready-p 'lua)
+ (treesit-parser-create 'lua)
+
+ ;; Comments.
+ (setq-local comment-start "--")
+ (setq-local comment-start-skip "--\\s-*")
+ (setq-local comment-end "")
+
+ ;; Font-lock.
+ (setq-local treesit-font-lock-settings lua-ts--font-lock-settings)
+ (setq-local treesit-font-lock-feature-list
+ '((comment definition)
+ (keyword string)
+ (assignment builtin constant number)
+ (bracket
+ delimiter
+ escape
+ function
+ operator
+ property
+ punctuation
+ variable)))
+
+ ;; Indent.
+ (setq-local treesit-simple-indent-rules lua-ts--simple-indent-rules)
+
+ ;; Navigation.
+ (setq-local treesit-defun-name-function #'lua-ts--defun-name-function)
+ (setq-local treesit-defun-type-regexp
+ (rx (or "function_declaration" "function_definition")))
+ (setq-local treesit-thing-settings
+ `((lua
+ (function ,(rx (or "function_declaration"
+ "function_definition")))
+ (keyword ,(regexp-opt lua-ts--keywords
+ 'symbols))
+ (loop-statement ,(rx (or "do_statement"
+ "for_statement"
+ "repeat_statement"
+ "while_statement")))
+ (sentence (or function
+ loop-statement
+ ,(rx (or "assignment_statement"
+ "comment"
+ "field"
+ "function_call"
+ "if_statement"
+ "return_statement"
+ "variable_declaration"))))
+ (sexp (or function
+ keyword
+ loop-statement
+ ,(rx (or "arguments"
+ "break_statement"
+ "expression_list"
+ "false"
+ "identifier"
+ "nil"
+ "number"
+ "parameters"
+ "parenthesized_expression"
+ "string"
+ "table_constructor"
+ "true"
+ "vararg_expression"))))
+ (text "comment"))))
+
+ ;; Imenu/Outline.
+ (setq-local treesit-simple-imenu-settings
+ `(("Requires"
+ "\\`function_call\\'"
+ lua-ts--require-p
+ lua-ts--require-name-function)
+ ("Variables" "\\`variable_declaration\\'" nil nil)
+ (nil
+ "\\`\\(?:f\\(?:ield\\|unction_declaration\\)\\)\\'"
+ lua-ts--named-function-p
+ nil)))
+
+ ;; Which-function.
+ (setq-local which-func-functions (treesit-defun-at-point))
+
+ ;; Align.
+ (setq-local align-indent-before-aligning t)
+
+ (treesit-major-mode-setup))
+
+ (add-hook 'flymake-diagnostic-functions #'lua-ts-flymake-luacheck nil 'local))
+
+(derived-mode-add-parents 'lua-ts-mode '(lua-mode))
+
+(when (treesit-ready-p 'lua)
+ (add-to-list 'auto-mode-alist '("\\.lua\\'" . lua-ts-mode)))
+
+(provide 'lua-ts-mode)
+
+;;; lua-ts-mode.el ends here
diff --git a/lisp/progmodes/make-mode.el b/lisp/progmodes/make-mode.el
index d7a09020567..be5884604da 100644
--- a/lisp/progmodes/make-mode.el
+++ b/lisp/progmodes/make-mode.el
@@ -3,7 +3,7 @@
;; Copyright (C) 1992-2024 Free Software Foundation, Inc.
;; Author: Thomas Neumann <tom@smart.bo.open.de>
-;; Eric S. Raymond <esr@snark.thyrsus.com>
+;; Eric S. Raymond <esr@thyrsus.com>
;; Maintainer: emacs-devel@gnu.org
;; Adapted-By: ESR
;; Keywords: unix, tools
@@ -44,10 +44,6 @@
;; prerequisites, which targets are out-of-date, and which have no
;; prerequisites.
;;
-;; The command C-c C-b pops up a browser window listing all target and
-;; macro names. You can mark or unmark items with C-c SPC, and insert
-;; all marked items back in the Makefile with C-c TAB.
-;;
;; The command C-c TAB in the makefile buffer inserts a GNU make builtin.
;; You will be prompted for the builtin's arguments.
;;
@@ -66,17 +62,9 @@
;; interact with font-lock.
;; * Would be nice to edit the commands in ksh-mode and have
;; indentation and slashification done automatically. Hard.
-;; * Consider removing browser mode. It seems useless.
;; * ":" should notice when a new target is made and add it to the
;; list (or at least set `makefile-need-target-pickup').
-;; * Make browser into a major mode.
;; * Clean up macro insertion stuff. It is a mess.
-;; * Browser entry and exit is weird. Normalize.
-;; * Browser needs to be rewritten. Right now it is kind of a crock.
-;; Should at least:
-;; * Act more like dired/buffer menu/whatever.
-;; * Highlight as mouse traverses.
-;; * B2 inserts.
;; * Update documentation above.
;; * Update texinfo manual.
;; * Update files.el.
@@ -105,7 +93,7 @@
:version "22.1")
(defface makefile-shell
- ()
+ '((t (:inherit default)))
;;'((((class color) (min-colors 88) (background light)) (:background "seashell1"))
;; (((class color) (min-colors 88) (background dark)) (:background "seashell4")))
"Face to use for additionally highlighting Shell commands in Font-Lock mode."
@@ -118,6 +106,7 @@
"Face to use for additionally highlighting Perl code in Font-Lock mode."
:version "22.1")
+(make-obsolete-variable 'makefile-browser-buffer-name nil "30.1")
(defcustom makefile-browser-buffer-name "*Macros and Targets*"
"Name of the macro- and target browser buffer."
:type 'string)
@@ -152,10 +141,12 @@ Otherwise, a space is inserted.
The default is t."
:type 'boolean)
+(make-obsolete-variable 'makefile-browser-leftmost-column nil "30.1")
(defcustom makefile-browser-leftmost-column 10
"Number of blanks to the left of the browser selection mark."
:type 'integer)
+(make-obsolete-variable 'makefile-browser-cursor-column nil "30.1")
(defcustom makefile-browser-cursor-column 10
"Column the cursor goes to when it moves up or down in the Makefile browser."
:type 'integer)
@@ -168,14 +159,17 @@ The default is t."
"If non-nil, `makefile-backslash-region' will align backslashes."
:type 'boolean)
+(make-obsolete-variable 'makefile-browser-selected-mark nil "30.1")
(defcustom makefile-browser-selected-mark "+ "
"String used to mark selected entries in the Makefile browser."
:type 'string)
+(make-obsolete-variable 'makefile-browser-unselected-mark nil "30.1")
(defcustom makefile-browser-unselected-mark " "
"String used to mark unselected entries in the Makefile browser."
:type 'string)
+(make-obsolete-variable 'makefile-browser-auto-advance-after-selection-p nil "30.1")
(defcustom makefile-browser-auto-advance-after-selection-p t
"If non-nil, cursor will move after item is selected in Makefile browser."
:type 'boolean)
@@ -198,6 +192,7 @@ to MODIFY A FILE WITHOUT YOUR CONFIRMATION when \"it seems necessary\"."
"Normal hook run by `makefile-mode'."
:type 'hook)
+(make-obsolete-variable 'makefile-browser-hook nil "30.1")
(defvar makefile-browser-hook '())
;;
@@ -611,9 +606,6 @@ The function must satisfy this calling convention:
;; Other.
["Up To Date Overview" makefile-create-up-to-date-overview
:help "Create a buffer containing an overview of the state of all known targets"]
- ["Pop up Makefile Browser" makefile-switch-to-browser
- ;; XXX: this needs a better string, the function is not documented...
- :help "Pop up Makefile Browser"]
("Switch Makefile Type"
["GNU make" makefile-gmake-mode
:help "An adapted `makefile-mode' that knows about GNU make"
@@ -641,6 +633,7 @@ The function must satisfy this calling convention:
:selected (eq major-mode 'makefile-makepp-mode)])))
+(make-obsolete-variable 'makefile-browser-map nil "30.1")
(defvar-keymap makefile-browser-map
:doc "The keymap that is used in the macro- and target browser."
"n" #'makefile-browser-next-line
@@ -695,9 +688,11 @@ The function must satisfy this calling convention:
"Table of all macro names known for this buffer.")
(put 'makefile-macro-table 'risky-local-variable t)
+(make-obsolete-variable 'makefile-browser-client nil "30.1")
(defvar makefile-browser-client nil
"A buffer in Makefile mode that is currently using the browser.")
+(make-obsolete-variable 'makefile-browser-selection-vector nil "30.1")
(defvar makefile-browser-selection-vector nil)
(defvar makefile-has-prereqs nil)
(defvar makefile-need-target-pickup t)
@@ -757,15 +752,8 @@ dependency, despite the colon.
\\{makefile-mode-map}
-In the browser, use the following keys:
-
-\\{makefile-browser-map}
-
Makefile mode can be configured by modifying the following variables:
-`makefile-browser-buffer-name':
- Name of the macro- and target browser buffer.
-
`makefile-target-colon':
The string that gets appended to all target names
inserted by `makefile-insert-target'.
@@ -783,24 +771,6 @@ Makefile mode can be configured by modifying the following variables:
If you want a TAB (instead of a space) to be appended after the
target colon, then set this to a non-nil value.
-`makefile-browser-leftmost-column':
- Number of blanks to the left of the browser selection mark.
-
-`makefile-browser-cursor-column':
- Column in which the cursor is positioned when it moves
- up or down in the browser.
-
-`makefile-browser-selected-mark':
- String used to mark selected entries in the browser.
-
-`makefile-browser-unselected-mark':
- String used to mark unselected entries in the browser.
-
-`makefile-browser-auto-advance-after-selection-p':
- If this variable is set to a non-nil value the cursor
- will automagically advance to the next line after an item
- has been selected in the browser.
-
`makefile-pickup-everything-picks-up-filenames-p':
If this variable is set to a non-nil value then
`makefile-pickup-everything' also picks up filenames as targets
@@ -816,10 +786,6 @@ Makefile mode can be configured by modifying the following variables:
IMPORTANT: Please note that enabling this option causes Makefile mode
to MODIFY A FILE WITHOUT YOUR CONFIRMATION when \"it seems necessary\".
-`makefile-browser-hook':
- A function or list of functions to be called just before the
- browser is entered. This is executed in the makefile buffer.
-
`makefile-special-targets-list':
List of special targets. You will be offered to complete
on one of those in the minibuffer whenever you enter a `.'.
@@ -1306,6 +1272,7 @@ Fill comments, backslashed lines, and variable definitions specially."
;;; ------------------------------------------------------------
(defun makefile-browser-format-target-line (target selected)
+ (declare (obsolete nil "30.1"))
(format
(concat (make-string makefile-browser-leftmost-column ?\ )
(if selected
@@ -1315,6 +1282,7 @@ Fill comments, backslashed lines, and variable definitions specially."
target makefile-target-colon))
(defun makefile-browser-format-macro-line (macro selected)
+ (declare (obsolete nil "30.1"))
(format
(concat (make-string makefile-browser-leftmost-column ?\ )
(if selected
@@ -1323,17 +1291,22 @@ Fill comments, backslashed lines, and variable definitions specially."
(makefile-format-macro-ref macro))))
(defun makefile-browser-fill (targets macros)
+ (declare (obsolete nil "30.1"))
(let ((inhibit-read-only t))
(goto-char (point-min))
(erase-buffer)
- (mapconcat
- (lambda (item) (insert (makefile-browser-format-target-line (car item) nil) "\n"))
- targets
- "")
- (mapconcat
- (lambda (item) (insert (makefile-browser-format-macro-line (car item) nil) "\n"))
- macros
- "")
+ (mapc
+ (lambda (item) (insert (with-suppressed-warnings
+ ((obsolete makefile-browser-format-target-line))
+ (makefile-browser-format-target-line (car item) nil))
+ "\n"))
+ targets)
+ (mapc
+ (lambda (item) (insert (with-suppressed-warnings
+ ((obsolete makefile-browser-format-macro-line))
+ (makefile-browser-format-macro-line (car item) nil))
+ "\n"))
+ macros)
(sort-lines nil (point-min) (point-max))
(goto-char (1- (point-max)))
(delete-char 1) ; remove unnecessary newline at eob
@@ -1346,6 +1319,7 @@ Fill comments, backslashed lines, and variable definitions specially."
(defun makefile-browser-next-line ()
"Move the browser selection cursor to the next line."
+ (declare (obsolete nil "30.1"))
(interactive)
(unless (makefile-last-line-p)
(forward-line 1)
@@ -1353,6 +1327,7 @@ Fill comments, backslashed lines, and variable definitions specially."
(defun makefile-browser-previous-line ()
"Move the browser selection cursor to the previous line."
+ (declare (obsolete nil "30.1"))
(interactive)
(unless (makefile-first-line-p)
(forward-line -1)
@@ -1364,6 +1339,7 @@ Fill comments, backslashed lines, and variable definitions specially."
(defun makefile-browser-quit ()
"Leave the browser and return to the makefile buffer."
+ (declare (obsolete nil "30.1"))
(interactive)
(let ((my-client makefile-browser-client))
(setq makefile-browser-client nil) ; we quit, so NO client!
@@ -1377,6 +1353,7 @@ Fill comments, backslashed lines, and variable definitions specially."
(defun makefile-browser-toggle ()
"Toggle the selection state of the browser item at the cursor position."
+ (declare (obsolete nil "30.1"))
(interactive)
(let ((this-line (count-lines (point-min) (point))))
(setq this-line (max 1 this-line))
@@ -1389,19 +1366,24 @@ Fill comments, backslashed lines, and variable definitions specially."
(let ((macro-name (makefile-browser-this-line-macro-name)))
(delete-region (point) (progn (end-of-line) (point)))
(insert
- (makefile-browser-format-macro-line
- macro-name
- (makefile-browser-get-state-for-line this-line))))
+ (with-suppressed-warnings
+ ((obsolete makefile-browser-format-macro-line))
+ (makefile-browser-format-macro-line
+ macro-name
+ (makefile-browser-get-state-for-line this-line)))))
(let ((target-name (makefile-browser-this-line-target-name)))
(delete-region (point) (progn (end-of-line) (point)))
(insert
- (makefile-browser-format-target-line
- target-name
- (makefile-browser-get-state-for-line this-line))))))
+ (with-suppressed-warnings
+ ((obsolete makefile-browser-format-target-line))
+ (makefile-browser-format-target-line
+ target-name
+ (makefile-browser-get-state-for-line this-line)))))))
(beginning-of-line)
(forward-char makefile-browser-cursor-column)
(if makefile-browser-auto-advance-after-selection-p
- (makefile-browser-next-line))))
+ (with-suppressed-warnings ((obsolete makefile-browser-next-line))
+ (makefile-browser-next-line)))))
;;;
;;; Making insertions into the client buffer
@@ -1414,6 +1396,7 @@ character, insert a new blank line, go to that line and indent by one TAB.
This is most useful in the process of creating continued lines when copying
large dependencies from the browser to the client buffer.
\(point) advances accordingly in the client buffer."
+ (declare (obsolete nil "30.1"))
(interactive)
(with-current-buffer makefile-browser-client
(end-of-line)
@@ -1422,6 +1405,7 @@ large dependencies from the browser to the client buffer.
(defun makefile-browser-insert-selection ()
"Insert all selected targets and/or macros in the makefile buffer.
Insertion takes place at point."
+ (declare (obsolete nil "30.1"))
(interactive)
(save-excursion
(goto-char (point-min))
@@ -1433,11 +1417,15 @@ Insertion takes place at point."
(setq current-line (1+ current-line))))))
(defun makefile-browser-insert-selection-and-quit ()
+ (declare (obsolete nil "30.1"))
(interactive)
- (makefile-browser-insert-selection)
- (makefile-browser-quit))
+ (with-suppressed-warnings ((obsolete makefile-browser-insert-selection)
+ (obsolete makefile-browser-quit))
+ (makefile-browser-insert-selection)
+ (makefile-browser-quit)))
(defun makefile-browser-send-this-line-item ()
+ (declare (obsolete nil "30.1"))
(if (makefile-browser-on-macro-line-p)
(save-excursion
(let ((macro-name (makefile-browser-this-line-macro-name)))
@@ -1449,10 +1437,12 @@ Insertion takes place at point."
(insert target-name " ")))))
(defun makefile-browser-start-interaction ()
+ (declare (obsolete nil "30.1"))
(use-local-map makefile-browser-map)
(setq buffer-read-only t))
(defun makefile-browse (targets macros)
+ (declare (obsolete imenu "30.1"))
(if (zerop (+ (length targets) (length macros)))
(progn
(beep)
@@ -1462,19 +1452,23 @@ Insertion takes place at point."
"Consider running \\[makefile-pickup-everything]"))))
(let ((browser-buffer (get-buffer-create makefile-browser-buffer-name)))
(pop-to-buffer browser-buffer)
- (makefile-browser-fill targets macros)
+ (with-suppressed-warnings ((obsolete makefile-browser-fill))
+ (makefile-browser-fill targets macros))
(shrink-window-if-larger-than-buffer)
(setq-local makefile-browser-selection-vector
(make-vector (+ (length targets) (length macros)) nil))
- (makefile-browser-start-interaction))))
+ (with-suppressed-warnings ((obsolete makefile-browser-start-interaction))
+ (makefile-browser-start-interaction)))))
(defun makefile-switch-to-browser ()
+ (declare (obsolete imenu "30.1"))
(interactive)
(run-hooks 'makefile-browser-hook)
(setq makefile-browser-client (current-buffer))
(makefile-pickup-targets)
(makefile-pickup-macros)
- (makefile-browse makefile-target-table makefile-macro-table))
+ (with-suppressed-warnings ((obsolete makefile-browse))
+ (makefile-browse makefile-target-table makefile-macro-table)))
@@ -1726,12 +1720,14 @@ This acts according to the value of `makefile-tab-after-target-colon'."
(defun makefile-browser-on-macro-line-p ()
"Determine if point is on a macro line in the browser."
+ (declare (obsolete nil "30.1"))
(save-excursion
(beginning-of-line)
(re-search-forward "\\$[{(]" (line-end-position) t)))
(defun makefile-browser-this-line-target-name ()
"Extract the target name from a line in the browser."
+ (declare (obsolete nil "30.1"))
(save-excursion
(end-of-line)
(skip-chars-backward "^ \t")
@@ -1739,6 +1735,7 @@ This acts according to the value of `makefile-tab-after-target-colon'."
(defun makefile-browser-this-line-macro-name ()
"Extract the macro name from a line in the browser."
+ (declare (obsolete nil "30.1"))
(save-excursion
(beginning-of-line)
(re-search-forward "\\$[{(]" (line-end-position) t)
@@ -1757,13 +1754,18 @@ Uses `makefile-use-curly-braces-for-macros-p'."
(format "$(%s)" macro-name))))
(defun makefile-browser-get-state-for-line (n)
+ (declare (obsolete nil "30.1"))
(aref makefile-browser-selection-vector (1- n)))
(defun makefile-browser-set-state-for-line (n to-state)
+ (declare (obsolete nil "30.1"))
(aset makefile-browser-selection-vector (1- n) to-state))
(defun makefile-browser-toggle-state-for-line (n)
- (makefile-browser-set-state-for-line n (not (makefile-browser-get-state-for-line n))))
+ (declare (obsolete nil "30.1"))
+ (with-suppressed-warnings ((obsolete makefile-browser-set-state-for-line)
+ (obsolete makefile-browser-get-state-for-line))
+ (makefile-browser-set-state-for-line n (not (makefile-browser-get-state-for-line n)))))
(defun makefile-last-line-p ()
(= (line-end-position) (point-max)))
diff --git a/lisp/progmodes/modula2.el b/lisp/progmodes/modula2.el
index 09cb848fd52..2bb31988290 100644
--- a/lisp/progmodes/modula2.el
+++ b/lisp/progmodes/modula2.el
@@ -325,20 +325,20 @@ followed by the first character of the construct.
;;
;; Module definitions.
("\\<\\(INTERFACE\\|MODULE\\|PROCEDURE\\)\\>[ \t]*\\(\\sw+\\)?"
- (1 font-lock-keyword-face) (2 font-lock-function-name-face nil t))
+ (1 'font-lock-keyword-face) (2 'font-lock-function-name-face nil t))
;;
;; Import directives.
("\\<\\(EXPORTS\\|FROM\\|IMPORT\\)\\>"
- (1 font-lock-keyword-face)
+ (1 'font-lock-keyword-face)
(font-lock-match-c-style-declaration-item-and-skip-to-next
nil (goto-char (match-end 0))
- (1 font-lock-constant-face)))
+ (1 'font-lock-constant-face)))
;;
;; Pragmas as warnings.
;; Spencer Allain <sallain@teknowledge.com> says do them as comments...
;; ("<\\*.*\\*>" . font-lock-warning-face)
;; ... but instead we fontify the first word.
- ("<\\*[ \t]*\\(\\sw+\\)" 1 font-lock-warning-face prepend)
+ ("<\\*[ \t]*\\(\\sw+\\)" 1 'font-lock-warning-face prepend)
)
"Subdued level highlighting for Modula-3 modes.")
@@ -366,26 +366,29 @@ followed by the first character of the construct.
"LOOPHOLE" "MAX" "MIN" "NARROW" "NEW" "NUMBER" "ORD"
"ROUND" "SUBARRAY" "TRUNC" "TYPECODE" "VAL")))
)
- (list
- ;;
- ;; Keywords except those fontified elsewhere.
- (concat "\\<\\(" m3-keywords "\\)\\>")
- ;;
- ;; Builtins.
- (cons (concat "\\<\\(" m3-builtins "\\)\\>") 'font-lock-builtin-face)
- ;;
- ;; Type names.
- (cons (concat "\\<\\(" m3-types "\\)\\>") 'font-lock-type-face)
- ;;
- ;; Fontify tokens as function names.
- '("\\<\\(END\\|EXCEPTION\\|RAISES?\\)\\>[ \t{]*"
- (1 font-lock-keyword-face)
+ `(
+ ;;
+ ;; Keywords except those fontified elsewhere.
+ ,(concat "\\<\\(" m3-keywords "\\)\\>")
+ ;;
+ ;; Builtins.
+ (,(concat "\\<\\(" m3-builtins "\\)\\>")
+ (0 'font-lock-builtin-face))
+ ;;
+ ;; Type names.
+ (,(concat "\\<\\(" m3-types "\\)\\>")
+ (0 'font-lock-type-face))
+ ;;
+ ;; Fontify tokens as function names.
+ ("\\<\\(END\\|EXCEPTION\\|RAISES?\\)\\>[ \t{]*"
+ (1 'font-lock-keyword-face)
(font-lock-match-c-style-declaration-item-and-skip-to-next
nil (goto-char (match-end 0))
- (1 font-lock-function-name-face)))
- ;;
- ;; Fontify constants as references.
- '("\\<\\(FALSE\\|NIL\\|NULL\\|TRUE\\)\\>" . font-lock-constant-face)
+ (1 'font-lock-function-name-face)))
+ ;;
+ ;; Fontify constants as references.
+ ("\\<\\(FALSE\\|NIL\\|NULL\\|TRUE\\)\\>"
+ (0 'font-lock-constant-face))
))))
"Gaudy level highlighting for Modula-3 modes.")
diff --git a/lisp/progmodes/opascal.el b/lisp/progmodes/opascal.el
index 5e8263cb646..a80e12b8129 100644
--- a/lisp/progmodes/opascal.el
+++ b/lisp/progmodes/opascal.el
@@ -281,7 +281,7 @@ nested routine.")
(eval-when-compile
(pcase-defmacro opascal--in (set)
- `(pred (pcase--flip memq ,set))))
+ `(pred (memq _ ,set))))
(defun opascal-string-of (start end)
;; Returns the buffer string from start to end.
diff --git a/lisp/progmodes/perl-mode.el b/lisp/progmodes/perl-mode.el
index 81a765d6f0c..f6c4dbed1e2 100644
--- a/lisp/progmodes/perl-mode.el
+++ b/lisp/progmodes/perl-mode.el
@@ -223,7 +223,10 @@
"\\|=>"
"\\|[?:.,;|&*=!~({[]"
"\\|[^-+][-+]" ;Bug#42168: `+' is intro but `++' isn't!
- "\\|\\(^\\)\\)[ \t\n]*")))
+ "\\|\\(^\\)\\)[ \t\n]*"))
+
+ (defconst perl--format-regexp "^[ \t]*format.*=[ \t]*\\(\n\\)"
+ "Regexp to match the start of a format declaration."))
(defun perl-syntax-propertize-function (start end)
(let ((case-fold-search nil))
@@ -248,11 +251,20 @@
;; correctly the \() construct (Bug#11996) as well as references
;; to string values.
("\\(\\\\\\)['`\"($]" (1 (unless (nth 3 (syntax-ppss))
- (string-to-syntax "."))))
+ (string-to-syntax "."))))
+ ;; A "$" in Perl code must escape the next char to protect against
+ ;; misinterpreting Perl's punctuation variables as unbalanced
+ ;; quotes or parens. This is not needed in strings and broken in
+ ;; the special case of "$\"" (Bug#69604). Make "$" a punctuation
+ ;; char in strings.
+ ("\\$" (0 (if (save-excursion
+ (nth 3 (syntax-ppss (match-beginning 0))))
+ (string-to-syntax ".")
+ (string-to-syntax "/"))))
;; Handle funny names like $DB'stop.
("\\$ ?{?\\^?[_[:alpha:]][_[:alnum:]]*\\('\\)[_[:alpha:]]" (1 "_"))
;; format statements
- ("^[ \t]*format.*=[ \t]*\\(\n\\)"
+ (perl--format-regexp
(1 (prog1 "\"" (perl-syntax-propertize-special-constructs end))))
;; Propertize perl prototype chars `$%&*;+@\[]' as punctuation
;; in `sub' arg-specs like `sub myfun ($)' and `sub ($)'. But
@@ -946,6 +958,17 @@ changed by, or (parse-state) if line starts in a quoted string."
(goto-char (- (point-max) pos)))
shift-amt))
+(defun perl--end-of-format-p ()
+ "Non-nil if point is at the end of a format declaration, skipping whitespace."
+ (save-excursion
+ (skip-chars-backward " \t\n")
+ (beginning-of-line)
+ (when-let ((comm (and (looking-at "^\\.$")
+ (nth 8 (syntax-ppss)))))
+ (goto-char comm)
+ (beginning-of-line)
+ (looking-at perl--format-regexp))))
+
(defun perl-continuation-line-p ()
"Move to end of previous line and return non-nil if continued."
;; Statement level. Is it a continuation or a new statement?
@@ -959,12 +982,13 @@ changed by, or (parse-state) if line starts in a quoted string."
(beginning-of-line)
(perl-backward-to-noncomment))
;; Now we get the answer.
- (unless (memq (preceding-char) '(?\; ?\} ?\{))
+ (unless (or (memq (preceding-char) '(?\; ?\} ?\{))
+ (perl--end-of-format-p))
(preceding-char)))
(defun perl-hanging-paren-p ()
"Non-nil if we are right after a hanging parenthesis-like char."
- (and (looking-at "[ \t]*$")
+ (and (looking-at "[ \t]*\\(?:#.*\\)?$")
(save-excursion
(skip-syntax-backward " (") (not (bolp)))))
@@ -999,7 +1023,9 @@ Returns (parse-state) if line starts inside a string."
(state (syntax-ppss))
(containing-sexp (nth 1 state))
;; Don't auto-indent in a quoted string or a here-document.
- (unindentable (or (nth 3 state) (eq 2 (nth 7 state)))))
+ (unindentable (or (nth 3 state) (eq 2 (nth 7 state))))
+ (format (and (nth 3 state)
+ (char-equal (nth 3 state) ?\n))))
(when (and (eq t (nth 3 state))
(save-excursion
(goto-char (nth 8 state))
@@ -1009,7 +1035,7 @@ Returns (parse-state) if line starts inside a string."
(setq unindentable nil)
(setq containing-sexp (nth 8 state)))
(cond
- (unindentable 'noindent)
+ (unindentable (if format 0 'noindent))
((null containing-sexp) ; Line is at top level.
(skip-chars-forward " \t\f")
(if (memq (following-char)
@@ -1018,7 +1044,8 @@ Returns (parse-state) if line starts inside a string."
;; indent a little if this is a continuation line
(perl-backward-to-noncomment)
(if (or (bobp)
- (memq (preceding-char) '(?\; ?\})))
+ (memq (preceding-char) '(?\; ?\}))
+ (perl--end-of-format-p))
0 perl-continued-statement-offset)))
((/= (char-after containing-sexp) ?{)
;; line is expression, not statement:
diff --git a/lisp/progmodes/prog-mode.el b/lisp/progmodes/prog-mode.el
index 562a9c319d6..d4e0514a6c3 100644
--- a/lisp/progmodes/prog-mode.el
+++ b/lisp/progmodes/prog-mode.el
@@ -30,7 +30,14 @@
;;; Code:
(eval-when-compile (require 'cl-lib)
- (require 'subr-x))
+ (require 'subr-x)
+ (require 'treesit))
+
+(declare-function treesit-available-p "treesit.c")
+(declare-function treesit-parser-list "treesit.c")
+(declare-function treesit-node-type "treesit.c")
+(declare-function treesit-node-at "treesit.c")
+(declare-function treesit-node-match-p "treesit.c")
(defgroup prog-mode nil
"Generic programming mode, from which others derive."
@@ -102,7 +109,8 @@
(defvar-keymap prog-mode-map
:doc "Keymap used for programming modes."
- "C-M-q" #'prog-indent-sexp)
+ "C-M-q" #'prog-indent-sexp
+ "M-q" #'prog-fill-reindent-defun)
(defvar prog-indentation-context nil
"When non-nil, provides context for indenting embedded code chunks.
@@ -140,6 +148,30 @@ instead."
(end (progn (forward-sexp 1) (point))))
(indent-region start end nil))))
+(defun prog-fill-reindent-defun (&optional argument)
+ "Refill or reindent the paragraph or defun that contains point.
+
+If the point is in a string or a comment, fill the paragraph that
+contains point or follows point.
+
+Otherwise, reindent the function definition that contains point
+or follows point."
+ (interactive "P")
+ (save-excursion
+ (let ((treesit-text-node
+ (and (treesit-available-p)
+ (treesit-parser-list)
+ (treesit-node-match-p
+ (treesit-node-at (point)) 'text t))))
+ (if (or treesit-text-node
+ (nth 8 (syntax-ppss))
+ (re-search-forward "\\s-*\\s<" (line-end-position) t))
+ (fill-paragraph argument (region-active-p))
+ (beginning-of-defun)
+ (let ((start (point)))
+ (end-of-defun)
+ (indent-region start (point) nil))))))
+
(defun prog-first-column ()
"Return the indentation column normally used for top-level constructs."
(or (car prog-indentation-context) 0))
@@ -308,6 +340,8 @@ support it."
(setq-local require-final-newline mode-require-final-newline)
(setq-local parse-sexp-ignore-comments t)
(add-hook 'context-menu-functions 'prog-context-menu 10 t)
+ ;; Enable text conversion in this buffer.
+ (setq-local text-conversion-style t)
;; Any programming language is always written left to right.
(setq bidi-paragraph-direction 'left-to-right))
diff --git a/lisp/progmodes/project.el b/lisp/progmodes/project.el
index b671a08b744..a10e24f3e28 100644
--- a/lisp/progmodes/project.el
+++ b/lisp/progmodes/project.el
@@ -1,7 +1,7 @@
;;; project.el --- Operations on the current project -*- lexical-binding: t; -*-
;; Copyright (C) 2015-2024 Free Software Foundation, Inc.
-;; Version: 0.9.8
+;; Version: 0.10.0
;; Package-Requires: ((emacs "26.1") (xref "1.4.0"))
;; This is a GNU ELPA :core package. Avoid functionality that is not
@@ -197,14 +197,27 @@ CL struct.")
"Value to use instead of `default-directory' when detecting the project.
When it is non-nil, `project-current' will always skip prompting too.")
+(defcustom project-prompter #'project-prompt-project-dir
+ "Function to call to prompt for a project.
+Called with no arguments and should return a project root dir."
+ :type '(choice (const :tag "Prompt for a project directory"
+ project-prompt-project-dir)
+ (const :tag "Prompt for a project name"
+ project-prompt-project-name)
+ (function :tag "Custom function" nil))
+ :group 'project
+ :version "30.1")
+
;;;###autoload
(defun project-current (&optional maybe-prompt directory)
"Return the project instance in DIRECTORY, defaulting to `default-directory'.
When no project is found in that directory, the result depends on
the value of MAYBE-PROMPT: if it is nil or omitted, return nil,
-else ask the user for a directory in which to look for the
-project, and if no project is found there, return a \"transient\"
+else prompt the user for the project to use. To prompt for a
+project, call the function specified by `project-prompter', which
+returns the directory in which to look for the project. If no
+project is found in that directory, return a \"transient\"
project instance.
The \"transient\" project instance is a special kind of value
@@ -216,12 +229,13 @@ See the doc string of `project-find-functions' for the general form
of the project instance object."
(unless directory (setq directory (or project-current-directory-override
default-directory)))
- (let ((pr (project--find-in-directory directory)))
+ (let ((pr (project--find-in-directory directory))
+ (non-essential (not maybe-prompt)))
(cond
(pr)
((unless project-current-directory-override
maybe-prompt)
- (setq directory (project-prompt-project-dir)
+ (setq directory (funcall project-prompter)
pr (project--find-in-directory directory))))
(when maybe-prompt
(if pr
@@ -232,7 +246,12 @@ of the project instance object."
pr))
(defun project--find-in-directory (dir)
- (run-hook-with-args-until-success 'project-find-functions dir))
+ ;; Use 'ignore-error' when 27.1 is the minimum supported.
+ (condition-case nil
+ (run-hook-with-args-until-success 'project-find-functions dir)
+ ;; Maybe we'd like to continue to the next backend instead? Let's
+ ;; see if somebody ever ends up in that situation.
+ (permission-denied nil)))
(defvar project--within-roots-fallback nil)
@@ -397,7 +416,8 @@ the buffer's value of `default-directory'."
(defcustom project-vc-ignores nil
"List of patterns to add to `project-ignores'."
:type '(repeat string))
-;;;###autoload(put 'project-vc-ignores 'safe-local-variable #'listp)
+;; Change to `list-of-strings-p' when support for Emacs 28 is dropped.
+;;;###autoload(put 'project-vc-ignores 'safe-local-variable (lambda (val) (and (listp val) (not (memq nil (mapcar #'stringp val))))))
(defcustom project-vc-merge-submodules t
"Non-nil to consider submodules part of the parent project.
@@ -452,6 +472,7 @@ variables, such as `project-vc-ignores' or `project-vc-name'."
:type '(repeat string)
:version "29.1"
:package-version '(project . "0.9.0"))
+;; Change to `list-of-strings-p' when support for Emacs 28 is dropped.
;;;###autoload(put 'project-vc-extra-root-markers 'safe-local-variable (lambda (val) (and (listp val) (not (memq nil (mapcar #'stringp val))))))
;; FIXME: Using the current approach, major modes are supposed to set
@@ -552,6 +573,12 @@ See `project-vc-extra-root-markers' for the marker value format.")
(let* ((parent (file-name-directory (directory-file-name root))))
(setq root (vc-call-backend 'Git 'root parent))))
(when root
+ (when (not backend)
+ (let* ((project-vc-extra-root-markers nil)
+ ;; Avoid submodules scan.
+ (enable-dir-local-variables nil)
+ (parent (project-try-vc root)))
+ (and parent (setq backend (nth 1 parent)))))
(setq project (list 'vc backend root))
;; FIXME: Cache for a shorter time.
(vc-file-setprop dir 'project-vc project)
@@ -576,7 +603,7 @@ See `project-vc-extra-root-markers' for the marker value format.")
(goto-char (point-min))
;; Kind of a hack to distinguish a submodule from
;; other cases of .git files pointing elsewhere.
- (looking-at "gitdir: [./]+/\\.git/modules/"))
+ (looking-at "gitdir: .+/\\.git/\\(worktrees/.*\\)?modules/"))
t)
(t nil))))
@@ -626,6 +653,7 @@ See `project-vc-extra-root-markers' for the marker value format.")
(include-untracked (project--value-in-dir
'project-vc-include-untracked
dir))
+ (submodules (project--git-submodules))
files)
(setq args (append args
'("-c" "--exclude-standard")
@@ -657,23 +685,25 @@ See `project-vc-extra-root-markers' for the marker value format.")
i)))
extra-ignores)))))
(setq files
- (mapcar
- (lambda (file) (concat default-directory file))
- (split-string
- (apply #'vc-git--run-command-string nil "ls-files" args)
- "\0" t)))
+ (delq nil
+ (mapcar
+ (lambda (file)
+ (unless (member file submodules)
+ (concat default-directory file)))
+ (split-string
+ (apply #'vc-git--run-command-string nil "ls-files" args)
+ "\0" t))))
(when (project--vc-merge-submodules-p default-directory)
;; Unfortunately, 'ls-files --recurse-submodules' conflicts with '-o'.
- (let* ((submodules (project--git-submodules))
- (sub-files
- (mapcar
- (lambda (module)
- (when (file-directory-p module)
- (project--vc-list-files
- (concat default-directory module)
- backend
- extra-ignores)))
- submodules)))
+ (let ((sub-files
+ (mapcar
+ (lambda (module)
+ (when (file-directory-p module)
+ (project--vc-list-files
+ (concat default-directory module)
+ backend
+ extra-ignores)))
+ submodules)))
(setq files
(apply #'nconc files sub-files))))
;; 'git ls-files' returns duplicate entries for merge conflicts.
@@ -718,11 +748,10 @@ See `project-vc-extra-root-markers' for the marker value format.")
(cl-defmethod project-ignores ((project (head vc)) dir)
(let* ((root (nth 2 project))
- backend)
+ (backend (cadr project)))
(append
(when (and backend
(file-equal-p dir root))
- (setq backend (cadr project))
(delq
nil
(mapcar
@@ -780,8 +809,10 @@ DIRS must contain directory names."
(with-temp-buffer
(setq default-directory dir)
(let ((enable-local-variables :all))
- (hack-dir-local-variables-non-file-buffer))
- (symbol-value var)))
+ (hack-dir-local-variables))
+ ;; Don't use `hack-local-variables-apply' to avoid setting modes.
+ (alist-get var file-local-variables-alist
+ (symbol-value var))))
(cl-defmethod project-buffers ((project (head vc)))
(let* ((root (expand-file-name (file-name-as-directory (project-root project))))
@@ -827,6 +858,7 @@ DIRS must contain directory names."
(define-key map "G" 'project-or-external-find-regexp)
(define-key map "r" 'project-query-replace-regexp)
(define-key map "x" 'project-execute-extended-command)
+ (define-key map "o" 'project-any-command)
(define-key map "\C-b" 'project-list-buffers)
map)
"Keymap for project commands.")
@@ -860,6 +892,17 @@ DIRS must contain directory names."
(call-interactively cmd)
(user-error "%s is undefined" (key-description key)))))
+(defun project--other-place-prefix (place &optional extra-keymap)
+ (cl-assert (member place '(window frame tab)))
+ (prefix-command-preserve-state)
+ (let ((inhibit-message t)) (funcall (intern (format "other-%s-prefix" place))))
+ (message "Display next project command buffer in a new %s..." place)
+ ;; Should return exitfun from set-transient-map
+ (set-transient-map (if extra-keymap
+ (make-composed-keymap project-prefix-map
+ extra-keymap)
+ project-prefix-map)))
+
;;;###autoload
(defun project-other-window-command ()
"Run project command, displaying resultant buffer in another window.
@@ -869,9 +912,11 @@ The following commands are available:
\\{project-prefix-map}
\\{project-other-window-map}"
(interactive)
- (project--other-place-command '((display-buffer-pop-up-window)
- (inhibit-same-window . t))
- project-other-window-map))
+ (if (< emacs-major-version 30)
+ (project--other-place-command '((display-buffer-pop-up-window)
+ (inhibit-same-window . t))
+ project-other-window-map)
+ (project--other-place-prefix 'window project-other-window-map)))
;;;###autoload (define-key ctl-x-4-map "p" #'project-other-window-command)
@@ -884,8 +929,10 @@ The following commands are available:
\\{project-prefix-map}
\\{project-other-frame-map}"
(interactive)
- (project--other-place-command '((display-buffer-pop-up-frame))
- project-other-frame-map))
+ (if (< emacs-major-version 30)
+ (project--other-place-command '((display-buffer-pop-up-frame))
+ project-other-frame-map)
+ (project--other-place-prefix 'frame project-other-frame-map)))
;;;###autoload (define-key ctl-x-5-map "p" #'project-other-frame-command)
@@ -897,7 +944,9 @@ The following commands are available:
\\{project-prefix-map}"
(interactive)
- (project--other-place-command '((display-buffer-in-new-tab))))
+ (if (< emacs-major-version 30)
+ (project--other-place-command '((display-buffer-in-new-tab)))
+ (project--other-place-prefix 'tab)))
;;;###autoload
(when (bound-and-true-p tab-prefix-map)
@@ -946,9 +995,7 @@ requires quoting, e.g. `\\[quoted-insert]<space>'."
;;;###autoload
(defun project-or-external-find-regexp (regexp)
- "Find all matches for REGEXP in the project roots or external roots.
-With \\[universal-argument] prefix, you can specify the file name
-pattern to search for."
+ "Find all matches for REGEXP in the project roots or external roots."
(interactive (list (project--read-regexp)))
(require 'xref)
(let* ((pr (project-current t))
@@ -976,12 +1023,30 @@ pattern to search for."
(read-regexp "Find regexp" (and sym (regexp-quote sym))
project-regexp-history-variable)))
+(defun project--find-default-from (filename project)
+ "Ensure FILENAME is in PROJECT.
+
+Usually, just return FILENAME. But if
+`project-current-directory-override' is set, adjust it to be
+relative to PROJECT instead.
+
+This supports using a relative file name from the current buffer
+when switching projects with `project-switch-project' and then
+using a command like `project-find-file'."
+ (if-let (filename-proj (and project-current-directory-override
+ (project-current nil default-directory)))
+ ;; file-name-concat requires Emacs 28+
+ (concat (file-name-as-directory (project-root project))
+ (file-relative-name filename (project-root filename-proj)))
+ filename))
+
;;;###autoload
(defun project-find-file (&optional include-all)
"Visit a file (with completion) in the current project.
The filename at point (determined by `thing-at-point'), if any,
-is available as part of \"future history\".
+is available as part of \"future history\". If none, the current
+buffer's file name is used.
If INCLUDE-ALL is non-nil, or with prefix argument when called
interactively, include all files under the project root, except
@@ -992,7 +1057,7 @@ for VCS directories listed in `vc-directory-exclusion-list'."
(dirs (list root)))
(project-find-file-in
(or (thing-at-point 'filename)
- (and buffer-file-name (file-relative-name buffer-file-name root)))
+ (and buffer-file-name (project--find-default-from buffer-file-name pr)))
dirs pr include-all)))
;;;###autoload
@@ -1000,17 +1065,23 @@ for VCS directories listed in `vc-directory-exclusion-list'."
"Visit a file (with completion) in the current project or external roots.
The filename at point (determined by `thing-at-point'), if any,
-is available as part of \"future history\".
+is available as part of \"future history\". If none, the current
+buffer's file name is used.
If INCLUDE-ALL is non-nil, or with prefix argument when called
interactively, include all files under the project root, except
for VCS directories listed in `vc-directory-exclusion-list'."
(interactive "P")
+ (defvar project-file-history-behavior)
(let* ((pr (project-current t))
(dirs (cons
(project-root pr)
- (project-external-roots pr))))
- (project-find-file-in (thing-at-point 'filename) dirs pr include-all)))
+ (project-external-roots pr)))
+ (project-file-history-behavior t))
+ (project-find-file-in
+ (or (thing-at-point 'filename)
+ (and buffer-file-name (project--find-default-from buffer-file-name pr)))
+ dirs pr include-all)))
(defcustom project-read-file-name-function #'project--read-file-cpd-relative
"Function to call to read a file name from a list.
@@ -1023,6 +1094,27 @@ For the arguments list, see `project--read-file-cpd-relative'."
:group 'project
:version "27.1")
+(defcustom project-file-history-behavior t
+ "If `relativize', entries in `file-name-history' are adjusted.
+
+History entries shown in `project-find-file', `project-find-dir',
+(from `file-name-history') are adjusted to be relative to the
+current project root, instead of the project which added those
+paths. This only affects history entries added by earlier calls
+to `project-find-file' or `project-find-dir'.
+
+This has the effect of sharing more history between projects."
+ :type '(choice (const :tag "Default behavior" t)
+ (const :tag "Adjust to be relative to current" relativize))
+ :group 'project
+ :version "30.1")
+
+(defun project--transplant-file-name (filename project)
+ (when-let ((old-root (get-text-property 0 'project filename)))
+ (expand-file-name
+ (file-relative-name filename old-root)
+ (project-root project))))
+
(defun project--read-file-cpd-relative (prompt
all-files &optional predicate
hist mb-default)
@@ -1045,27 +1137,31 @@ by the user at will."
(setq all-files
(delete common-parent-directory all-files))
t))
+ (mb-default (if (and common-parent-directory
+ mb-default
+ (file-name-absolute-p mb-default))
+ (file-relative-name mb-default common-parent-directory)
+ mb-default))
(substrings (mapcar (lambda (s) (substring s cpd-length)) all-files))
(_ (when included-cpd
(setq substrings (cons "./" substrings))))
(new-collection (project--file-completion-table substrings))
- (abbr-cpd (abbreviate-file-name common-parent-directory))
- (abbr-cpd-length (length abbr-cpd))
- (relname (cl-letf ((history-add-new-input nil)
- ((symbol-value hist)
- (mapcan
- (lambda (s)
- (and (string-prefix-p abbr-cpd s)
- (not (eq abbr-cpd-length (length s)))
- (list (substring s abbr-cpd-length))))
- (symbol-value hist))))
+ (abs-cpd (expand-file-name common-parent-directory))
+ (abs-cpd-length (length abs-cpd))
+ (relname (cl-letf* ((non-essential t) ;Avoid new Tramp connections.
+ ((symbol-value hist)
+ (mapcan
+ (lambda (s)
+ (setq s (expand-file-name s))
+ (and (string-prefix-p abs-cpd s)
+ (not (eq abs-cpd-length (length s)))
+ (list (substring s abs-cpd-length))))
+ (symbol-value hist))))
(project--completing-read-strict prompt
new-collection
predicate
hist mb-default)))
(absname (expand-file-name relname common-parent-directory)))
- (when (and hist history-add-new-input)
- (add-to-history hist (abbreviate-file-name absname)))
absname))
(defun project--read-file-absolute (prompt
@@ -1076,10 +1172,33 @@ by the user at will."
predicate
hist mb-default))
+(defun project--read-file-name ( project prompt
+ all-files &optional predicate
+ hist mb-default)
+ "Call `project-read-file-name-function' with appropriate history.
+
+Depending on `project-file-history-behavior', entries are made
+project-relative where possible."
+ (let ((file
+ (cl-letf ((history-add-new-input nil)
+ ((symbol-value hist)
+ (if (eq project-file-history-behavior 'relativize)
+ (mapcar
+ (lambda (f)
+ (or (project--transplant-file-name f project) f))
+ (symbol-value hist))
+ (symbol-value hist))))
+ (funcall project-read-file-name-function
+ prompt all-files predicate hist mb-default))))
+ (when (and hist history-add-new-input)
+ (add-to-history hist
+ (propertize file 'project (project-root project))))
+ file))
+
(defun project-find-file-in (suggested-filename dirs project &optional include-all)
"Complete a file name in DIRS in PROJECT and visit the result.
-SUGGESTED-FILENAME is a relative file name, or part of it, which
+SUGGESTED-FILENAME is a file name, or part of it, which
is used as part of \"future history\".
If INCLUDE-ALL is non-nil, or with prefix argument when called
@@ -1096,9 +1215,10 @@ directories listed in `vc-directory-exclusion-list'."
dirs)
(project-files project dirs)))
(completion-ignore-case read-file-name-completion-ignore-case)
- (file (funcall project-read-file-name-function
- "Find file" all-files nil 'file-name-history
- suggested-filename)))
+ (file (project--read-file-name
+ project "Find file"
+ all-files nil 'file-name-history
+ suggested-filename)))
(if (string= file "")
(user-error "You didn't specify the file")
(find-file file))))
@@ -1119,7 +1239,10 @@ directories listed in `vc-directory-exclusion-list'."
;;;###autoload
(defun project-find-dir ()
- "Start Dired in a directory inside the current project."
+ "Start Dired in a directory inside the current project.
+
+The current buffer's `default-directory' is available as part of
+\"future history\"."
(interactive)
(let* ((project (project-current t))
(all-files (project-files project))
@@ -1130,11 +1253,13 @@ directories listed in `vc-directory-exclusion-list'."
;; https://stackoverflow.com/a/50685235/615245 for possible
;; implementation.
(all-dirs (mapcar #'file-name-directory all-files))
- (dir (funcall project-read-file-name-function
- "Dired"
- ;; Some completion UIs show duplicates.
- (delete-dups all-dirs)
- nil 'file-name-history)))
+ (dir (project--read-file-name
+ project "Dired"
+ ;; Some completion UIs show duplicates.
+ (delete-dups all-dirs)
+ nil 'file-name-history
+ (and default-directory
+ (project--find-default-from default-directory project)))))
(dired dir)))
;;;###autoload
@@ -1212,8 +1337,7 @@ command \\[fileloop-continue]."
(interactive "sSearch (regexp): ")
(fileloop-initialize-search
regexp
- ;; XXX: See the comment in project-query-replace-regexp.
- (cl-delete-if-not #'file-regular-p (project-files (project-current t)))
+ (project-files (project-current t))
'default)
(fileloop-continue))
@@ -1234,20 +1358,20 @@ If you exit the `query-replace', you can later continue the
(list from to))))
(fileloop-initialize-replace
from to
- ;; XXX: Filter out Git submodules, which are not regular files.
- ;; `project-files' can return those, which is arguably suboptimal,
- ;; but removing them eagerly has performance cost.
- (cl-delete-if-not #'file-regular-p (project-files (project-current t)))
+ (project-files (project-current t))
'default)
(fileloop-continue))
(defvar compilation-read-command)
(declare-function compilation-read-command "compile")
+(declare-function recompile "compile")
(defun project-prefixed-buffer-name (mode)
(concat "*"
- (file-name-nondirectory
- (directory-file-name default-directory))
+ (if-let ((proj (project-current nil)))
+ (project-name proj)
+ (file-name-nondirectory
+ (directory-file-name default-directory)))
"-"
(downcase mode)
"*"))
@@ -1259,7 +1383,7 @@ If non-nil, it overrides `compilation-buffer-name-function' for
:version "28.1"
:group 'project
:type '(choice (const :tag "Default" nil)
- (const :tag "Prefixed with root directory name"
+ (const :tag "Prefixed with project name"
project-prefixed-buffer-name)
(function :tag "Custom function")))
@@ -1274,6 +1398,18 @@ If non-nil, it overrides `compilation-buffer-name-function' for
compilation-buffer-name-function)))
(call-interactively #'compile)))
+(defun project-recompile (&optional edit-command)
+ "Run `recompile' with appropriate buffer."
+ (declare (interactive-only recompile))
+ (interactive "P")
+ (let ((compilation-buffer-name-function
+ (or project-compilation-buffer-name-function
+ ;; Should we error instead? When there's no
+ ;; project-specific naming, there is no point in using
+ ;; this command.
+ compilation-buffer-name-function)))
+ (recompile edit-command)))
+
(defcustom project-ignore-buffer-conditions nil
"List of conditions to filter the buffers to be switched to.
If any of these conditions are satisfied for a buffer in the
@@ -1309,13 +1445,23 @@ general form of conditions."
(and (memq (cdr buffer) buffers)
(not
(project--buffer-check
- (cdr buffer) project-ignore-buffer-conditions))))))
- (read-buffer
- "Switch to buffer: "
- (when (funcall predicate (cons other-name other-buffer))
- other-name)
- nil
- predicate)))
+ (cdr buffer) project-ignore-buffer-conditions)))))
+ (buffer (read-buffer
+ "Switch to buffer: "
+ (when (funcall predicate (cons other-name other-buffer))
+ other-name)
+ nil
+ predicate)))
+ ;; XXX: This check hardcodes the default buffer-belonging relation
+ ;; which `project-buffers' is allowed to override. Straighten
+ ;; this up sometime later. Or not. Since we can add a method
+ ;; `project-contains-buffer-p', but a separate method to create a
+ ;; new project buffer seems too much.
+ (if (or (get-buffer buffer)
+ (file-in-directory-p default-directory (project-root pr)))
+ buffer
+ (let ((default-directory (project-root pr)))
+ (get-buffer-create buffer)))))
;;;###autoload
(defun project-switch-to-buffer (buffer-or-name)
@@ -1370,7 +1516,8 @@ ARG, show only buffers that are visiting files."
(lambda (buffer)
(let ((name (buffer-name buffer))
(file (buffer-file-name buffer)))
- (and (or (not (string= (substring name 0 1) " "))
+ (and (or Buffer-menu-show-internal
+ (not (string= (substring name 0 1) " "))
file)
(not (eq buffer (current-buffer)))
(or file (not Buffer-menu-files-only)))))
@@ -1380,6 +1527,7 @@ ARG, show only buffers that are visiting files."
(let ((buf (list-buffers-noselect
arg (with-current-buffer
(get-buffer-create "*Buffer List*")
+ (setq-local Buffer-menu-show-internal nil)
(let ((Buffer-menu-files-only arg))
(funcall buffer-list-function))))))
(with-current-buffer buf
@@ -1451,6 +1599,7 @@ Used by `project-kill-buffers'."
:package-version '(project . "0.8.2"))
;;;###autoload(put 'project-kill-buffers-display-buffer-list 'safe-local-variable #'booleanp)
+;; FIXME: Could this be replaced by `buffer-match-p' in Emacs 29+?
(defun project--buffer-check (buf conditions)
"Check if buffer BUF matches any element of the list CONDITIONS.
See `project-kill-buffer-conditions' or
@@ -1510,7 +1659,7 @@ Also see the `project-kill-buffers-display-buffer-list' variable."
(yes-or-no-p
(format "Kill %d buffers in %s? "
(length bufs)
- (project-root pr))))))
+ (project-name pr))))))
(cond (no-confirm
(mapc #'kill-buffer bufs))
((null bufs)
@@ -1556,7 +1705,15 @@ With some possible metadata (to be decided).")
(when (file-exists-p filename)
(with-temp-buffer
(insert-file-contents filename)
- (read (current-buffer)))))
+ (mapcar
+ (lambda (elem)
+ (let ((name (car elem)))
+ (list (if (file-remote-p name) name
+ (abbreviate-file-name name)))))
+ (condition-case nil
+ (read (current-buffer))
+ (end-of-file
+ (warn "Failed to read the projects list file due to unexpected EOF")))))))
(unless (seq-every-p
(lambda (elt) (stringp (car-safe elt)))
project--list)
@@ -1576,16 +1733,20 @@ With some possible metadata (to be decided).")
(insert ";;; -*- lisp-data -*-\n")
(let ((print-length nil)
(print-level nil))
- (pp project--list (current-buffer)))
+ (pp (mapcar (lambda (elem)
+ (let ((name (car elem)))
+ (list (if (file-remote-p name) name
+ (expand-file-name name)))))
+ project--list)
+ (current-buffer)))
(write-region nil nil filename nil 'silent))))
-;;;###autoload
-(defun project-remember-project (pr &optional no-write)
- "Add project PR to the front of the project list.
+(defun project--remember-dir (root &optional no-write)
+ "Add project root ROOT to the front of the project list.
Save the result in `project-list-file' if the list of projects
has changed, and NO-WRITE is nil."
(project--ensure-read-project-list)
- (let ((dir (project-root pr)))
+ (let ((dir (abbreviate-file-name root)))
(unless (equal (caar project--list) dir)
(dolist (ent project--list)
(when (equal dir (car ent))
@@ -1594,6 +1755,13 @@ has changed, and NO-WRITE is nil."
(unless no-write
(project--write-project-list)))))
+;;;###autoload
+(defun project-remember-project (pr &optional no-write)
+ "Add project PR to the front of the project list.
+Save the result in `project-list-file' if the list of projects
+has changed, and NO-WRITE is nil."
+ (project--remember-dir (project-root pr) no-write))
+
(defun project--remove-from-project-list (project-root report-message)
"Remove directory PROJECT-ROOT of a missing project from the project list.
If the directory was in the list before the removal, save the
@@ -1601,7 +1769,7 @@ result in `project-list-file'. Announce the project's removal
from the list using REPORT-MESSAGE, which is a format string
passed to `message' as its first argument."
(project--ensure-read-project-list)
- (when-let ((ent (assoc project-root project--list)))
+ (when-let ((ent (assoc (abbreviate-file-name project-root) project--list)))
(setq project--list (delq ent project--list))
(message report-message project-root)
(project--write-project-list)))
@@ -1611,10 +1779,12 @@ passed to `message' as its first argument."
"Remove directory PROJECT-ROOT from the project list.
PROJECT-ROOT is the root directory of a known project listed in
the project list."
- (interactive (list (project-prompt-project-dir)))
+ (interactive (list (funcall project-prompter)))
(project--remove-from-project-list
project-root "Project `%s' removed from known projects"))
+(defvar project--dir-history)
+
(defun project-prompt-project-dir ()
"Prompt the user for a directory that is one of the known project roots.
The project is chosen among projects known from the project list,
@@ -1627,14 +1797,53 @@ It's also possible to enter an arbitrary directory not in the list."
;; completion style).
(project--file-completion-table
(append project--list `(,dir-choice))))
+ (project--dir-history (project-known-project-roots))
(pr-dir ""))
(while (equal pr-dir "")
;; If the user simply pressed RET, do this again until they don't.
- (setq pr-dir (completing-read "Select project: " choices nil t)))
+ (setq pr-dir
+ (let (history-add-new-input)
+ (completing-read "Select project: " choices nil t nil 'project--dir-history))))
(if (equal pr-dir dir-choice)
(read-directory-name "Select directory: " default-directory nil t)
pr-dir)))
+(defvar project--name-history)
+
+(defun project-prompt-project-name ()
+ "Prompt the user for a project, by name, that is one of the known project roots.
+The project is chosen among projects known from the project list,
+see `project-list-file'.
+It's also possible to enter an arbitrary directory not in the list."
+ (let* ((dir-choice "... (choose a dir)")
+ project--name-history
+ (choices
+ (let (ret)
+ ;; Iterate in reverse order so project--name-history is in
+ ;; the same order as project--list.
+ (dolist (dir (reverse (project-known-project-roots)))
+ ;; We filter out directories that no longer map to a project,
+ ;; since they don't have a clean project-name.
+ (when-let ((proj (project--find-in-directory dir))
+ (name (project-name proj)))
+ (push name project--name-history)
+ (push (cons name proj) ret)))
+ (reverse ret)))
+ ;; XXX: Just using this for the category (for the substring
+ ;; completion style).
+ (table (project--file-completion-table
+ (reverse (cons dir-choice choices))))
+ (pr-name ""))
+ (while (equal pr-name "")
+ ;; If the user simply pressed RET, do this again until they don't.
+ (setq pr-name
+ (let (history-add-new-input)
+ (completing-read "Select project: " table nil t nil 'project--name-history))))
+ (if (equal pr-name dir-choice)
+ (read-directory-name "Select directory: " default-directory nil t)
+ (let ((proj (assoc pr-name choices)))
+ (if (stringp proj) proj (project-root (cdr proj)))))))
+
;;;###autoload
(defun project-known-project-roots ()
"Return the list of root directories of all known projects."
@@ -1649,6 +1858,44 @@ It's also possible to enter an arbitrary directory not in the list."
(let ((default-directory (project-root (project-current t))))
(call-interactively #'execute-extended-command)))
+;;;###autoload
+(defun project-any-command (&optional overriding-map prompt-format)
+ "Run the next command in the current project.
+
+If the command name starts with `project-', or its symbol has
+property `project-aware', it gets passed the project to use
+with the variable `project-current-directory-override'.
+Otherwise, `default-directory' is temporarily set to the current
+project's root.
+
+If OVERRIDING-MAP is non-nil, it will be used as
+`overriding-terminal-local-map' to provide shorter bindings
+from that map which will take priority over the global ones."
+ (interactive)
+ (let* ((pr (project-current t))
+ (prompt-format (or prompt-format "[execute in %s]:"))
+ (command (let ((overriding-terminal-local-map overriding-map))
+ (key-binding (read-key-sequence
+ (format prompt-format (project-root pr)))
+ t)))
+ (root (project-root pr)))
+ (when command
+ (if (when (symbolp command)
+ (or (string-prefix-p "project-" (symbol-name command))
+ (get command 'project-aware)))
+ (let ((project-current-directory-override root))
+ (call-interactively command))
+ (let ((default-directory root))
+ (call-interactively command))))))
+
+;;;###autoload
+(defun project-prefix-or-any-command ()
+ "Run the next command in the current project.
+Works like `project-any-command', but also mixes in the shorter
+bindings from `project-prefix-map'."
+ (interactive)
+ (project-any-command project-prefix-map "[execute in %s]:"))
+
(defun project-remember-projects-under (dir &optional recursive)
"Index all projects below a directory DIR.
If RECURSIVE is non-nil, recurse into all subdirectories to find
@@ -1657,35 +1904,28 @@ the progress. The function returns the number of detected
projects."
(interactive "DDirectory: \nP")
(project--ensure-read-project-list)
- (let ((queue (list dir))
- (count 0)
- (known (make-hash-table
- :size (* 2 (length project--list))
- :test #'equal )))
+ (let ((dirs (if recursive
+ (directory-files-recursively dir "" t)
+ (directory-files dir t)))
+ (known (make-hash-table :size (* 2 (length project--list))
+ :test #'equal))
+ (count 0))
(dolist (project (mapcar #'car project--list))
(puthash project t known))
- (while queue
- (when-let ((subdir (pop queue))
- ((file-directory-p subdir)))
- (when-let ((project (project--find-in-directory subdir))
- (project-root (project-root project))
- ((not (gethash project-root known))))
- (project-remember-project project t)
- (puthash project-root t known)
- (message "Found %s..." project-root)
- (setq count (1+ count)))
- (when (and recursive (file-directory-p subdir))
- (setq queue
- (nconc
- (directory-files
- subdir t directory-files-no-dot-files-regexp t)
- queue)))))
- (unless (eq recursive 'in-progress)
- (if (zerop count)
- (message "No projects were found")
- (project--write-project-list)
- (message "%d project%s were found"
- count (if (= count 1) "" "s"))))
+ (dolist (subdir dirs)
+ (when-let (((file-directory-p subdir))
+ (project (project--find-in-directory subdir))
+ (project-root (project-root project))
+ ((not (gethash project-root known))))
+ (project-remember-project project t)
+ (puthash project-root t known)
+ (message "Found %s..." project-root)
+ (setq count (1+ count))))
+ (if (zerop count)
+ (message "No projects were found")
+ (project--write-project-list)
+ (message "%d project%s were found"
+ count (if (= count 1) "" "s")))
count))
(defun project-forget-zombie-projects ()
@@ -1727,7 +1967,8 @@ forgotten projects."
(project-find-regexp "Find regexp")
(project-find-dir "Find directory")
(project-vc-dir "VC-Dir")
- (project-eshell "Eshell"))
+ (project-eshell "Eshell")
+ (project-any-command "Other"))
"Alist mapping commands to descriptions.
Used by `project-switch-project' to construct a dispatch menu of
commands available upon \"switching\" to another project.
@@ -1751,7 +1992,9 @@ invoked immediately without any dispatch menu."
(choice :tag "Key to press"
(const :tag "Infer from the keymap" nil)
(character :tag "Explicit key"))))
- (symbol :tag "Single command")))
+ (const :tag "Use both short keys and global bindings"
+ project-prefix-or-any-command)
+ (symbol :tag "Custom command")))
(defcustom project-switch-use-entire-map nil
"Whether `project-switch-project' will use the entire `project-prefix-map'.
@@ -1764,7 +2007,28 @@ listed in the dispatch menu produced from `project-switch-commands'."
:group 'project
:version "28.1")
+(defcustom project-key-prompt-style (if (facep 'help-key-binding)
+ t
+ 'brackets)
+ "Which presentation to use when asking to choose a command by key.
+
+When `brackets', use text brackets and `bold' for the character.
+Otherwise, use the face `help-key-binding' in the prompt."
+ :type '(choice (const :tag "Using help-key-binding face" t)
+ (const :tag "Using bold face and brackets" brackets))
+ :group 'project
+ :version "30.1")
+
(defun project--keymap-prompt ()
+ "Return a prompt for the project switching using the prefix map."
+ (let (keys)
+ (map-keymap
+ (lambda (evt _)
+ (when (characterp evt) (push evt keys)))
+ project-prefix-map)
+ (mapconcat (lambda (key) (help-key-description (string key) nil)) keys " ")))
+
+(defun project--menu-prompt ()
"Return a prompt for the project switching dispatch menu."
(mapconcat
(pcase-lambda (`(,cmd ,label ,key))
@@ -1776,9 +2040,13 @@ listed in the dispatch menu produced from `project-switch-commands'."
(let ((key (if key
(vector key)
(where-is-internal cmd (list project-prefix-map) t))))
- (format "[%s] %s"
- (propertize (key-description key) 'face 'bold)
- label)))
+ (if (not (eq project-key-prompt-style 'brackets))
+ (format "%s %s"
+ (propertize (key-description key) 'face 'help-key-binding)
+ label)
+ (format "[%s] %s"
+ (propertize (key-description key) 'face 'bold)
+ label))))
project-switch-commands
" "))
@@ -1799,20 +2067,30 @@ listed in the dispatch menu produced from `project-switch-commands'."
(when-let ((cmd (nth 0 row))
(keychar (nth 2 row)))
(define-key temp-map (vector keychar) cmd)))))
- command)
+ command
+ choice)
(while (not command)
(let* ((overriding-local-map commands-map)
- (choice (read-key-sequence (project--keymap-prompt))))
+ (prompt (if project-switch-use-entire-map
+ (project--keymap-prompt)
+ (project--menu-prompt))))
+ (when choice
+ (setq prompt (concat prompt
+ (format " %s: %s"
+ (propertize "Unrecognized input"
+ 'face 'warning)
+ (help-key-description choice nil)))))
+ (setq choice (read-key-sequence (concat "Choose: " prompt)))
(when (setq command (lookup-key commands-map choice))
+ (when (numberp command) (setq command nil))
(unless (or project-switch-use-entire-map
(assq command commands-menu))
- ;; TODO: Add some hint to the prompt, like "key not
- ;; recognized" or something.
(setq command nil)))
(let ((global-command (lookup-key (current-global-map) choice)))
(when (memq global-command
'(keyboard-quit keyboard-escape-quit))
(call-interactively global-command)))))
+ (message nil)
command))
;;;###autoload
@@ -1823,12 +2101,78 @@ made from `project-switch-commands'.
When called in a program, it will use the project corresponding
to directory DIR."
- (interactive (list (project-prompt-project-dir)))
+ (interactive (list (funcall project-prompter)))
+ (project--remember-dir dir)
(let ((command (if (symbolp project-switch-commands)
project-switch-commands
- (project--switch-project-command))))
- (let ((project-current-directory-override dir))
- (call-interactively command))))
+ (project--switch-project-command)))
+ (buffer (current-buffer)))
+ (unwind-protect
+ (progn
+ (setq-local project-current-directory-override dir)
+ (call-interactively command))
+ (with-current-buffer buffer
+ (kill-local-variable 'project-current-directory-override)))))
+
+;;;###autoload
+(defun project-uniquify-dirname-transform (dirname)
+ "Uniquify name of directory DIRNAME using `project-name', if in a project.
+
+If you set `uniquify-dirname-transform' to this function,
+slash-separated components from `project-name' will be appended to
+the buffer's directory name when buffers from two different projects
+would otherwise have the same name."
+ (if-let (proj (project-current nil dirname))
+ (let ((root (project-root proj)))
+ (expand-file-name
+ (file-name-concat
+ (file-name-directory root)
+ (project-name proj)
+ (file-relative-name dirname root))))
+ dirname))
+
+;;; Project mode-line
+
+;;;###autoload
+(defcustom project-mode-line nil
+ "Whether to show current project name and Project menu on the mode line.
+This feature requires the presence of the following item in
+`mode-line-format': `(project-mode-line project-mode-line-format)'; it
+is part of the default mode line beginning with Emacs 30."
+ :type 'boolean
+ :group 'project
+ :version "30.1")
+
+(defvar project-mode-line-map
+ (let ((map (make-sparse-keymap)))
+ (define-key map [mode-line down-mouse-1]
+ (bound-and-true-p menu-bar-project-item))
+ map))
+
+(defvar project-mode-line-face nil
+ "Face name to use for the project name on the mode line.")
+
+(defvar project-mode-line-format '(:eval (project-mode-line-format)))
+(put 'project-mode-line-format 'risky-local-variable t)
+
+(defun project-mode-line-format ()
+ "Compose the project mode-line."
+ (when-let ((project (project-current)))
+ ;; Preserve the global value of 'last-coding-system-used'
+ ;; that 'write-region' needs to set for 'basic-save-buffer',
+ ;; but updating the mode line might occur at the same time
+ ;; during saving the buffer and 'project-name' can change
+ ;; 'last-coding-system-used' when reading the project name
+ ;; from .dir-locals.el also enables flyspell-mode (bug#66825).
+ (let ((last-coding-system-used last-coding-system-used))
+ (concat
+ " "
+ (propertize
+ (project-name project)
+ 'face project-mode-line-face
+ 'mouse-face 'mode-line-highlight
+ 'help-echo "mouse-1: Project menu"
+ 'local-map project-mode-line-map)))))
(provide 'project)
;;; project.el ends here
diff --git a/lisp/progmodes/prolog.el b/lisp/progmodes/prolog.el
index 3e4a3863a02..97f08a79ccd 100644
--- a/lisp/progmodes/prolog.el
+++ b/lisp/progmodes/prolog.el
@@ -828,7 +828,7 @@ Relevant only when `prolog-imenu-flag' is non-nil."
((not (zerop (skip-chars-forward prolog-operator-chars))))
((not (zerop (skip-syntax-forward "w_'"))))
;; In case of non-ASCII punctuation.
- ((not (zerop (skip-syntax-forward ".")))))
+ (t (skip-syntax-forward ".")))
(point))))
(defun prolog-smie-backward-token ()
@@ -842,7 +842,7 @@ Relevant only when `prolog-imenu-flag' is non-nil."
((not (zerop (skip-chars-backward prolog-operator-chars))))
((not (zerop (skip-syntax-backward "w_'"))))
;; In case of non-ASCII punctuation.
- ((not (zerop (skip-syntax-backward ".")))))
+ (t (skip-syntax-backward ".")))
(point))))
(defconst prolog-smie-grammar
@@ -1148,7 +1148,7 @@ line and comments can also be enclosed in /* ... */.
If an optional argument SYSTEM is non-nil, set up mode for the given system.
To find out what version of Prolog mode you are running, enter
-`\\[prolog-mode-version]'.
+\\[prolog-mode-version].
Commands:
\\{prolog-mode-map}"
@@ -1268,7 +1268,7 @@ imitating normal Unix input editing.
\\[comint-quit-subjob] sends quit signal, likewise.
To find out what version of Prolog mode you are running, enter
-`\\[prolog-mode-version]'."
+\\[prolog-mode-version]."
(require 'compile)
(setq comint-input-filter 'prolog-input-filter)
(setq mode-line-process '(": %s"))
diff --git a/lisp/progmodes/ps-mode.el b/lisp/progmodes/ps-mode.el
index 4bb1953527e..7fa6d9dca8c 100644
--- a/lisp/progmodes/ps-mode.el
+++ b/lisp/progmodes/ps-mode.el
@@ -97,11 +97,9 @@ When the figure is finished these values should be replaced."
(const :tag "archC" (1296 1728))
(const :tag "archB" (864 1296))
(const :tag "archA" (648 864))
- (const :tag "flsa" (612 936))
- (const :tag "flse" (612 936))
+ (const :tag "flsa, flse" (612 936))
(const :tag "halfletter" (396 612))
- (const :tag "11x17" (792 1224))
- (const :tag "tabloid" (792 1224))
+ (const :tag "11x17, tabloid" (792 1224))
(const :tag "ledger" (1224 792))
(const :tag "csheet" (1224 1584))
(const :tag "dsheet" (1584 2448))
diff --git a/lisp/progmodes/python.el b/lisp/progmodes/python.el
index 9849fde8588..8279617b6e7 100644
--- a/lisp/progmodes/python.el
+++ b/lisp/progmodes/python.el
@@ -5,11 +5,14 @@
;; Author: Fabián E. Gallina <fgallina@gnu.org>
;; URL: https://github.com/fgallina/python.el
;; Version: 0.28
-;; Package-Requires: ((emacs "24.4") (compat "28.1.2.1") (seq "2.23"))
+;; Package-Requires: ((emacs "24.4") (compat "29.1.1.0") (seq "2.23"))
;; Maintainer: emacs-devel@gnu.org
;; Created: Jul 2010
;; Keywords: languages
+;; This is a GNU ELPA :core package. Avoid functionality that is not
+;; compatible with the version of Emacs recorded above.
+
;; This file is part of GNU Emacs.
;; GNU Emacs is free software: you can redistribute it and/or modify
@@ -125,9 +128,9 @@
;; receiving escape sequences (with some limitations, i.e. completion
;; in blocks does not work). The code executed for the "fallback"
;; completion can be found in `python-shell-completion-setup-code' and
-;; `python-shell-completion-string-code' variables. Their default
-;; values enable completion for both CPython and IPython, and probably
-;; any readline based shell (it's known to work with PyPy). If your
+;; `python-shell-completion-get-completions'. Their default values
+;; enable completion for both CPython and IPython, and probably any
+;; readline based shell (it's known to work with PyPy). If your
;; Python installation lacks readline (like CPython for Windows),
;; installing pyreadline (URL `https://ipython.org/pyreadline.html')
;; should suffice. To troubleshoot why you are not getting any
@@ -138,6 +141,12 @@
;; If you see an error, then you need to either install pyreadline or
;; setup custom code that avoids that dependency.
+;; By default, the "native" completion uses the built-in rlcompleter.
+;; To use other readline completer (e.g. Jedi) or a custom one, you just
+;; need to set it in the PYTHONSTARTUP file. You can set an
+;; Emacs-specific completer by testing the environment variable
+;; INSIDE_EMACS.
+
;; Shell virtualenv support: The shell also contains support for
;; virtualenvs and other special environment modifications thanks to
;; `python-shell-process-environment' and `python-shell-exec-path'.
@@ -264,7 +273,7 @@
(eval-when-compile (require 'subr-x)) ;For `string-empty-p' and `string-join'.
(require 'treesit)
(require 'pcase)
-(require 'compat nil 'noerror)
+(require 'compat)
(require 'project nil 'noerror)
(require 'seq)
@@ -297,11 +306,18 @@
(defcustom python-interpreter "python"
"Python interpreter for noninteractive use.
-To customize the Python shell, modify `python-shell-interpreter'
-instead."
+Some Python interpreters also require changes to
+`python-interpreter-args'.
+
+To customize the Python interpreter for interactive use, modify
+`python-shell-interpreter' instead."
:version "29.1"
:type 'string)
+(defcustom python-interpreter-args ""
+ "Arguments for the Python interpreter for noninteractive use."
+ :version "30.1"
+ :type 'string)
;;; Bindings
@@ -899,6 +915,7 @@ is used to limit the scan."
"Put `syntax-table' property correctly on single/triple quotes."
(let* ((ppss (save-excursion (backward-char 3) (syntax-ppss)))
(string-start (and (eq t (nth 3 ppss)) (nth 8 ppss)))
+ (string-literal-concat (numberp (nth 3 ppss)))
(quote-starting-pos (- (point) 3))
(quote-ending-pos (point)))
(cond ((or (nth 4 ppss) ;Inside a comment
@@ -911,6 +928,8 @@ is used to limit the scan."
((nth 5 ppss)
;; The first quote is escaped, so it's not part of a triple quote!
(goto-char (1+ quote-starting-pos)))
+ ;; Handle string literal concatenation (bug#45897)
+ (string-literal-concat nil)
((null string-start)
;; This set of quotes delimit the start of a string. Put
;; string fence syntax on last quote. (bug#49518)
@@ -1349,15 +1368,15 @@ For NODE, OVERRIDE, START, END, and ARGS, see
(save-excursion
(goto-char start)
(while (re-search-forward (rx (or "\"\"\"" "'''")) end t)
- (let ((node (treesit-node-at (point))))
- ;; The triple quotes surround a non-empty string.
- (when (equal (treesit-node-type node) "string_content")
- (let ((start (treesit-node-start node))
- (end (treesit-node-end node)))
- (put-text-property (1- start) start
- 'syntax-table (string-to-syntax "|"))
- (put-text-property end (min (1+ end) (point-max))
- 'syntax-table (string-to-syntax "|"))))))))
+ (let ((node (treesit-node-at (- (point) 3))))
+ ;; Handle triple-quoted strings.
+ (pcase (treesit-node-type node)
+ ("string_start"
+ (put-text-property (1- (point)) (point)
+ 'syntax-table (string-to-syntax "|")))
+ ("string_end"
+ (put-text-property (- (point) 3) (- (point) 2)
+ 'syntax-table (string-to-syntax "|"))))))))
;;; Indentation
@@ -1384,11 +1403,59 @@ For NODE, OVERRIDE, START, END, and ARGS, see
:type '(repeat symbol))
(defcustom python-indent-def-block-scale 2
- "Multiplier applied to indentation inside multi-line def blocks."
+ "Multiplier applied to indentation inside multi-line blocks.
+The indentation in parens in the block header will be the current
+indentation plus `python-indent-offset' multiplied by this
+variable. For example, the arguments are indented as follows if
+this variable is 1:
+
+ def do_something(
+ arg1,
+ arg2):
+ print('hello')
+
+if this variable is 2 (default):
+
+ def do_something(
+ arg1,
+ arg2):
+ print('hello')
+
+This variable has an effect on all blocks, not just def block.
+This variable only works if the opening paren is not followed by
+non-whitespace characters on the same line. Modify
+`python-indent-block-paren-deeper' to customize the case where
+non-whitespace characters follow the opening paren on the same
+line."
:version "26.1"
:type 'integer
:safe 'natnump)
+(defcustom python-indent-block-paren-deeper nil
+ "Increase indentation inside parens of a block.
+If non-nil, increase the indentation of the lines inside parens
+in a header of a block when they are indented to the same level
+as the body of the block:
+
+ if (some_expression
+ and another_expression):
+ do_something()
+
+instead of:
+
+ if (some_expression
+ and another_expression):
+ do_something()
+
+This variable only works if the opening paren is followed by
+non-whitespace characters on the same line. Modify
+`python-indent-def-block-scale' to customize the case where
+non-whitespace character does not follow the opening paren on the
+same line."
+ :version "30.1"
+ :type 'boolean
+ :safe 'booleanp)
+
(defvar python-indent-current-level 0
"Deprecated var available for compatibility.")
@@ -1486,6 +1553,14 @@ keyword
- Point is inside a paren with items starting in their own line
from a block start.
- START is the position of the open paren.
+:inside-paren-from-block
+ - Point is inside a paren from a block start followed by some
+ items on the same line.
+ - START is the first non space char position *after* the open paren.
+:inside-paren-continuation-line
+ - Point is on a continuation line inside a paren.
+ - START is the position where the previous line (excluding lines
+ for inner parens) starts.
:after-backslash
- Fallback case when point is after backslash.
@@ -1540,7 +1615,21 @@ keyword
(= (line-number-at-pos)
(progn
(python-util-forward-comment)
- (line-number-at-pos))))))))
+ (line-number-at-pos)))))))
+ (continuation-start
+ (when start
+ (save-excursion
+ (forward-line -1)
+ (back-to-indentation)
+ ;; Skip inner parens.
+ (cl-loop with prev-start = (python-syntax-context 'paren)
+ while (and prev-start (>= prev-start start))
+ if (= prev-start start)
+ return (point)
+ else do (goto-char prev-start)
+ (back-to-indentation)
+ (setq prev-start
+ (python-syntax-context 'paren)))))))
(when start
(cond
;; Current line only holds the closing paren.
@@ -1556,6 +1645,9 @@ keyword
(back-to-indentation)
(python-syntax-closing-paren-p))
(cons :inside-paren-at-closing-nested-paren start))
+ ;; This line is a continuation of the previous line.
+ (continuation-start
+ (cons :inside-paren-continuation-line continuation-start))
;; This line starts from an opening block in its own line.
((save-excursion
(goto-char start)
@@ -1569,12 +1661,16 @@ keyword
(starts-in-newline
(cons :inside-paren-newline-start start))
;; General case.
- (t (cons :inside-paren
- (save-excursion
- (goto-char (1+ start))
- (skip-syntax-forward "(" 1)
- (skip-syntax-forward " ")
- (point))))))))
+ (t (let ((after-start (save-excursion
+ (goto-char (1+ start))
+ (skip-syntax-forward "(" 1)
+ (skip-syntax-forward " ")
+ (point))))
+ (if (save-excursion
+ (python-nav-beginning-of-statement)
+ (python-info-looking-at-beginning-of-block))
+ (cons :inside-paren-from-block after-start)
+ (cons :inside-paren after-start))))))))
;; After backslash.
((let ((start (when (not (python-syntax-comment-or-string-p ppss))
(python-info-line-ends-backslash-p
@@ -1667,7 +1763,8 @@ possibilities can be narrowed to specific indentation points."
(`(,(or :after-line
:after-comment
:inside-string
- :after-backslash) . ,start)
+ :after-backslash
+ :inside-paren-continuation-line) . ,start)
;; Copy previous indentation.
(goto-char start)
(current-indentation))
@@ -1722,7 +1819,17 @@ possibilities can be narrowed to specific indentation points."
(`(,(or :inside-paren-newline-start-from-block) . ,start)
(goto-char start)
(+ (current-indentation)
- (* python-indent-offset python-indent-def-block-scale))))))
+ (* python-indent-offset python-indent-def-block-scale)))
+ (`(,:inside-paren-from-block . ,start)
+ (goto-char start)
+ (let ((column (current-column)))
+ (if (and python-indent-block-paren-deeper
+ (= column (+ (save-excursion
+ (python-nav-beginning-of-statement)
+ (current-indentation))
+ python-indent-offset)))
+ (+ column python-indent-offset)
+ column))))))
(defun python-indent--calculate-levels (indentation)
"Calculate levels list given INDENTATION.
@@ -2602,7 +2709,7 @@ position, else returns nil."
(cond ((executable-find "python3") "python3")
((executable-find "python") "python")
(t "python3"))
- "Default Python interpreter for shell.
+ "Python interpreter for interactive use.
Some Python interpreters also require changes to
`python-shell-interpreter-args'. In particular, setting
@@ -2617,11 +2724,12 @@ Some Python interpreters also require changes to
:safe 'stringp)
(defcustom python-shell-interpreter-args "-i"
- "Default arguments for the Python interpreter."
+ "Arguments for the Python interpreter for interactive use."
:type 'string)
(defcustom python-shell-interpreter-interactive-arg "-i"
- "Interpreter argument to force it to run interactively."
+ "Interpreter argument to force it to run interactively.
+This is used only for prompt detection."
:type 'string
:version "24.4")
@@ -2773,8 +2881,7 @@ dedicated to the current buffer or its project (if one is found)."
(defmacro python-shell--add-to-path-with-priority (pathvar paths)
"Modify PATHVAR and ensure PATHS are added only once at beginning."
`(dolist (path (reverse ,paths))
- (cl-delete path ,pathvar :test #'string=)
- (cl-pushnew path ,pathvar :test #'string=)))
+ (setq ,pathvar (cons path (cl-delete path ,pathvar :test #'string=)))))
(defun python-shell-calculate-pythonpath ()
"Calculate the PYTHONPATH using `python-shell-extra-pythonpaths'."
@@ -3414,6 +3521,16 @@ eventually provide a shell."
:version "25.1"
:type 'hook)
+(defconst python-shell-setup-code
+ "\
+try:
+ import tty
+except ImportError:
+ pass
+else:
+ tty.setraw(0)"
+ "Code used to setup the inferior Python processes.")
+
(defconst python-shell-eval-setup-code
"\
def __PYTHON_EL_eval(source, filename):
@@ -3479,10 +3596,12 @@ The coding cookie regexp is specified in PEP 263.")
(format "exec(%s)\n" (python-shell--encode-string string))))))
;; Bootstrap: the normal definition of `python-shell-send-string'
;; depends on the Python code sent here.
+ (python-shell-send-string-no-output python-shell-setup-code)
(python-shell-send-string-no-output python-shell-eval-setup-code)
(python-shell-send-string-no-output python-shell-eval-file-setup-code))
(with-current-buffer (current-buffer)
(let ((inhibit-quit nil))
+ (python-shell-readline-detect)
(run-hooks 'python-shell-first-prompt-hook))))))
output)
@@ -3503,7 +3622,6 @@ interpreter is run. Variables
`python-shell-prompt-block-regexp',
`python-shell-font-lock-enable',
`python-shell-completion-setup-code',
-`python-shell-completion-string-code',
`python-eldoc-setup-code',
`python-ffap-setup-code' can
customize this mode for different Python interpreters.
@@ -4143,8 +4261,9 @@ def __PYTHON_EL_get_completions(text):
completions = []
completer = None
+ import json
try:
- import readline
+ import readline, re
try:
import __builtin__
@@ -4155,16 +4274,29 @@ def __PYTHON_EL_get_completions(text):
is_ipython = ('__IPYTHON__' in builtins or
'__IPYTHON__active' in builtins)
- splits = text.split()
- is_module = splits and splits[0] in ('from', 'import')
-
- if is_ipython and is_module:
- from IPython.core.completerlib import module_completion
- completions = module_completion(text.strip())
- elif is_ipython and '__IP' in builtins:
- completions = __IP.complete(text)
- elif is_ipython and 'get_ipython' in builtins:
- completions = get_ipython().Completer.all_completions(text)
+
+ if is_ipython and 'get_ipython' in builtins:
+ def filter_c(prefix, c):
+ if re.match('_+(i?[0-9]+)?$', c):
+ return False
+ elif c[0] == '%' and not re.match('[%a-zA-Z]+$', prefix):
+ return False
+ return True
+
+ import IPython
+ try:
+ if IPython.version_info[0] >= 6:
+ from IPython.core.completer import provisionalcompleter
+ with provisionalcompleter():
+ completions = [
+ [c.text, c.start, c.end, c.type or '?', c.signature or '']
+ for c in get_ipython().Completer.completions(text, len(text))
+ if filter_c(text, c.text)]
+ else:
+ part, matches = get_ipython().Completer.complete(line_buffer=text)
+ completions = [text + m[len(part):] for m in matches if filter_c(text, m)]
+ except:
+ pass
else:
# Try to reuse current completer.
completer = readline.get_completer()
@@ -4187,7 +4319,7 @@ def __PYTHON_EL_get_completions(text):
finally:
if getattr(completer, 'PYTHON_EL_WRAPPED', False):
completer.print_mode = True
- return completions"
+ return json.dumps(completions)"
"Code used to setup completion in inferior Python processes."
:type 'string)
@@ -4228,6 +4360,26 @@ When a match is found, native completion is disabled."
:version "25.1"
:type 'float)
+(defvar python-shell-readline-completer-delims nil
+ "Word delimiters used by the readline completer.
+It is automatically set by Python shell. An empty string means no
+characters are considered delimiters and the readline completion
+considers the entire line of input. A value of nil means the Python
+shell has no readline support.")
+
+(defun python-shell-readline-detect ()
+ "Detect the readline support for Python shell completion."
+ (let* ((process (python-shell-get-process))
+ (output (python-shell-send-string-no-output "
+try:
+ import readline
+ print(readline.get_completer_delims())
+except:
+ print('No readline support')" process)))
+ (setq-local python-shell-readline-completer-delims
+ (unless (string-search "No readline support" output)
+ (string-trim-right output)))))
+
(defvar python-shell-completion-native-redirect-buffer
" *Python completions redirect*"
"Buffer to be used to redirect output of readline commands.")
@@ -4394,21 +4546,15 @@ With argument MSG show activation/deactivation message."
(cond
((python-shell-completion-native-interpreter-disabled-p)
(python-shell-completion-native-turn-off msg))
- ((python-shell-completion-native-setup)
+ ((and python-shell-readline-completer-delims
+ (python-shell-completion-native-setup))
(when msg
(message "Shell native completion is enabled.")))
- (t (lwarn
- '(python python-shell-completion-native-turn-on-maybe)
- :warning
- (concat
- "Your `python-shell-interpreter' doesn't seem to "
- "support readline, yet `python-shell-completion-native-enable' "
- (format "was t and %S is not part of the "
- (file-name-nondirectory python-shell-interpreter))
- "`python-shell-completion-native-disabled-interpreters' "
- "list. Native completions have been disabled locally. "
- "Consider installing the python package \"readline\". "))
- (python-shell-completion-native-turn-off msg))))))
+ (t
+ (when msg
+ (message (concat "Python does not use GNU readline;"
+ " no completion in multi-line commands.")))
+ (python-shell-completion-native-turn-off nil))))))
(defun python-shell-completion-native-turn-on-maybe-with-msg ()
"Like `python-shell-completion-native-turn-on-maybe' but force messages."
@@ -4433,6 +4579,8 @@ With argument MSG show activation/deactivation message."
(let* ((original-filter-fn (process-filter process))
(redirect-buffer (get-buffer-create
python-shell-completion-native-redirect-buffer))
+ (sep (if (string= python-shell-readline-completer-delims "")
+ "[\n\r]+" "[ \f\t\n\r\v()]+"))
(trigger "\t")
(new-input (concat input trigger))
(input-length
@@ -4475,28 +4623,80 @@ With argument MSG show activation/deactivation message."
process python-shell-completion-native-output-timeout
comint-redirect-finished-regexp)
(re-search-backward "0__dummy_completion__" nil t)
- (cl-remove-duplicates
- (split-string
- (buffer-substring-no-properties
- (line-beginning-position) (point-min))
- "[ \f\t\n\r\v()]+" t)
- :test #'string=))))
+ (let ((str (buffer-substring-no-properties
+ (line-beginning-position) (point-min))))
+ ;; The readline completer is allowed to return a list
+ ;; of (text start end type signature) as a JSON
+ ;; string. See the return value for IPython in
+ ;; `python-shell-completion-setup-code'.
+ (if (string= "[" (substring str 0 1))
+ (condition-case nil
+ (python--parse-json-array str)
+ (t (cl-remove-duplicates (split-string str sep t)
+ :test #'string=)))
+ (cl-remove-duplicates (split-string str sep t)
+ :test #'string=))))))
(set-process-filter process original-filter-fn)))))
(defun python-shell-completion-get-completions (process input)
"Get completions of INPUT using PROCESS."
(with-current-buffer (process-buffer process)
- (let ((completions
- (python-util-strip-string
- (python-shell-send-string-no-output
- (format
- "%s\nprint(';'.join(__PYTHON_EL_get_completions(%s)))"
+ (python--parse-json-array
+ (python-shell-send-string-no-output
+ (format "%s\nprint(__PYTHON_EL_get_completions(%s))"
python-shell-completion-setup-code
(python-shell--encode-string input))
- process))))
- (when (> (length completions) 2)
- (split-string completions
- "^'\\|^\"\\|;\\|'$\\|\"$" t)))))
+ process))))
+
+(defun python-shell--get-multiline-input ()
+ "Return lines at a multi-line input in Python shell."
+ (save-excursion
+ (let ((p (point)) lines)
+ (when (progn
+ (beginning-of-line)
+ (looking-back python-shell-prompt-block-regexp (pos-bol)))
+ (push (buffer-substring-no-properties (point) p) lines)
+ (while (progn (comint-previous-prompt 1)
+ (looking-back python-shell-prompt-block-regexp (pos-bol)))
+ (push (buffer-substring-no-properties (point) (pos-eol)) lines))
+ (push (buffer-substring-no-properties (point) (pos-eol)) lines))
+ lines)))
+
+(defun python-shell--extra-completion-context ()
+ "Get extra completion context of current input in Python shell."
+ (let ((lines (python-shell--get-multiline-input))
+ (python-indent-guess-indent-offset nil))
+ (when (not (zerop (length lines)))
+ (with-temp-buffer
+ (delay-mode-hooks
+ (insert (string-join lines "\n"))
+ (python-mode)
+ (python-shell-completion-extra-context))))))
+
+(defun python-shell-completion-extra-context (&optional pos)
+ "Get extra completion context at position POS in Python buffer.
+If optional argument POS is nil, use current position.
+
+Readline completers could use current line as the completion
+context, which may be insufficient. In this function, extra
+context (e.g. multi-line function call) is found and reformatted
+as one line, which is required by native completion."
+ (let (bound p)
+ (save-excursion
+ (and pos (goto-char pos))
+ (setq bound (pos-bol))
+ (python-nav-up-list -1)
+ (when (and (< (point) bound)
+ (or
+ (looking-back
+ (python-rx (group (+ (or "." symbol-name)))) (pos-bol) t)
+ (progn
+ (forward-line 0)
+ (looking-at "^[ \t]*\\(from \\)"))))
+ (setq p (match-beginning 1))))
+ (when p
+ (replace-regexp-in-string
+ "\n[ \t]*" "" (buffer-substring-no-properties p (1- bound))))))
(defvar-local python-shell--capf-cache nil
"Variable to store cached completions and invalidation keys.")
@@ -4511,21 +4711,27 @@ using that one instead of current buffer's process."
;; Working on a shell buffer: use prompt end.
(cdr (python-util-comint-last-prompt))
(line-beginning-position)))
- (import-statement
- (when (string-match-p
- (rx (* space) word-start (or "from" "import") word-end space)
- (buffer-substring-no-properties line-start (point)))
- (buffer-substring-no-properties line-start (point))))
+ (no-delims
+ (and (not (if is-shell-buffer
+ (eq 'font-lock-comment-face
+ (get-text-property (1- (point)) 'face))
+ (python-syntax-context 'comment)))
+ (with-current-buffer (process-buffer process)
+ (if python-shell-completion-native-enable
+ (string= python-shell-readline-completer-delims "")
+ (or (string-match-p "ipython[23]?\\'" python-shell-interpreter)
+ (equal python-shell-readline-completer-delims ""))))))
(start
(if (< (point) line-start)
(point)
(save-excursion
- (if (not (re-search-backward
- (python-rx
- (or whitespace open-paren close-paren
- string-delimiter simple-operator))
- line-start
- t 1))
+ (if (or no-delims
+ (not (re-search-backward
+ (python-rx
+ (or whitespace open-paren close-paren
+ string-delimiter simple-operator))
+ line-start
+ t 1)))
line-start
(forward-char (length (match-string-no-properties 0)))
(point)))))
@@ -4565,18 +4771,56 @@ using that one instead of current buffer's process."
(t #'python-shell-completion-native-get-completions))))
(prev-prompt (car python-shell--capf-cache))
(re (or (cadr python-shell--capf-cache) regexp-unmatchable))
- (prefix (buffer-substring-no-properties start end)))
+ (prefix (buffer-substring-no-properties start end))
+ (prefix-offset 0)
+ (extra-context (when no-delims
+ (if is-shell-buffer
+ (python-shell--extra-completion-context)
+ (python-shell-completion-extra-context))))
+ (extra-offset (length extra-context)))
+ (unless (zerop extra-offset)
+ (setq prefix (concat extra-context prefix)))
;; To invalidate the cache, we check if the prompt position or the
;; completion prefix changed.
(unless (and (equal prev-prompt (car prompt-boundaries))
- (string-match re prefix))
+ (string-match re prefix)
+ (setq prefix-offset (- (length prefix) (match-end 1))))
(setq python-shell--capf-cache
`(,(car prompt-boundaries)
,(if (string-empty-p prefix)
regexp-unmatchable
- (concat "\\`" (regexp-quote prefix) "\\(?:\\sw\\|\\s_\\)*\\'"))
- ,@(funcall completion-fn process (or import-statement prefix)))))
- (list start end (cddr python-shell--capf-cache))))
+ (concat "\\`\\(" (regexp-quote prefix) "\\)\\(?:\\sw\\|\\s_\\)*\\'"))
+ ,@(funcall completion-fn process prefix))))
+ (let ((cands (cddr python-shell--capf-cache)))
+ (cond
+ ((stringp (car cands))
+ (if no-delims
+ ;; Reduce completion candidates due to long prefix.
+ (if-let ((Lp (length prefix))
+ ((string-match "\\(\\sw\\|\\s_\\)+\\'" prefix))
+ (L (match-beginning 0)))
+ ;; If extra-offset is not zero:
+ ;; start end
+ ;; o------------------o---------o-------o
+ ;; |<- extra-offset ->|
+ ;; |<----------- L ------------>|
+ ;; new-start
+ (list (+ start L (- extra-offset)) end
+ (mapcar (lambda (s) (substring s L)) cands))
+ (list end end (mapcar (lambda (s) (substring s Lp)) cands)))
+ (list start end cands)))
+ ;; python-shell-completion(-native)-get-completions may produce a
+ ;; list of (text start end type signature) for completion.
+ ((consp (car cands))
+ (list (+ start (nth 1 (car cands)) (- extra-offset))
+ ;; Candidates may be cached, so the end position should
+ ;; be adjusted according to current completion prefix.
+ (+ start (nth 2 (car cands)) (- extra-offset) prefix-offset)
+ cands
+ :annotation-function
+ (lambda (c) (concat " " (nth 3 (assoc c cands))))
+ :company-docsig
+ (lambda (c) (nth 4 (assoc c cands)))))))))
(define-obsolete-function-alias
'python-shell-completion-complete-at-point
@@ -5083,11 +5327,6 @@ the if condition."
(not (python-syntax-comment-or-string-p))
python-skeleton-autoinsert)))
-(defun python--completion-predicate (_ buffer)
- (provided-mode-derived-p
- (buffer-local-value 'major-mode buffer)
- 'python-base-mode))
-
(defmacro python-skeleton-define (name doc &rest skel)
"Define a `python-mode' skeleton using NAME DOC and SKEL.
The skeleton will be bound to python-skeleton-NAME and will
@@ -5096,7 +5335,7 @@ be added to `python-mode-skeleton-abbrev-table'."
(let* ((name (symbol-name name))
(function-name (intern (concat "python-skeleton-" name))))
`(progn
- (put ',function-name 'completion-predicate #'python--completion-predicate)
+ (function-put ',function-name 'command-modes '(python-base-mode))
(define-abbrev python-mode-skeleton-abbrev-table
,name "" ',function-name :system t)
(setq python-skeleton-available
@@ -5123,7 +5362,7 @@ The skeleton will be bound to python-skeleton-NAME."
`(< ,(format "%s:" name) \n \n
> _ \n)))
`(progn
- (put ',function-name 'completion-predicate #'ignore)
+ (function-put ',function-name 'completion-predicate #'ignore)
(define-skeleton ,function-name
,(or doc
(format "Auxiliary skeleton for %s statement." name))
@@ -5256,11 +5495,13 @@ def __FFAP_get_module_path(objstr):
(defcustom python-check-command
(cond ((executable-find "pyflakes") "pyflakes")
+ ((executable-find "ruff") "ruff")
+ ((executable-find "flake8") "flake8")
((executable-find "epylint") "epylint")
(t "pyflakes"))
"Command used to check a Python file."
:type 'string
- :version "29.1")
+ :version "30.1")
(defcustom python-check-buffer-name
"*Python check: %s*"
@@ -6165,7 +6406,9 @@ point's current `syntax-ppss'."
counter)))
(python-util-forward-comment -1)
(python-nav-beginning-of-statement)
- (cond ((bobp))
+ (cond ((and (bobp) (save-excursion
+ (python-util-forward-comment)
+ (looking-at-p re))))
((python-info-assignment-statement-p) t)
((python-info-looking-at-beginning-of-defun))
(t nil))))))
@@ -6496,8 +6739,14 @@ REPORT-FN is Flymake's callback function."
;;; Import management
(defconst python--list-imports "\
-from isort import find_imports_in_stream, find_imports_in_paths
-from sys import argv, stdin
+from sys import argv, exit, stdin
+
+try:
+ from isort import find_imports_in_stream, find_imports_in_paths
+except ModuleNotFoundError:
+ exit(2)
+except ImportError:
+ exit(3)
query, files, result = argv[1] or None, argv[2:], {}
@@ -6528,6 +6777,17 @@ for key in sorted(result):
(project-files proj))
(list default-directory)))
+(defun python--list-imports-check-status (status)
+ (unless (eq 0 status)
+ (let* ((details
+ (cond
+ ((eq 2 status) " (maybe isort is missing?)")
+ ((eq 3 status) " (maybe isort version is older than 5.7.0?)")
+ (t "")))
+ (msg
+ (concat "%s exited with status %s" details)))
+ (error msg python-interpreter status))))
+
(defun python--list-imports (name source)
"List all Python imports matching NAME in SOURCE.
If NAME is nil, list all imports. SOURCE can be a buffer or a
@@ -6538,22 +6798,27 @@ recursively."
(let* ((temp (current-buffer))
(status (if (bufferp source)
(with-current-buffer source
- (call-process-region (point-min) (point-max)
- python-interpreter
- nil (list temp nil) nil
- "-c" python--list-imports
- (or name "")))
+ (apply #'call-process-region
+ (point-min) (point-max)
+ python-interpreter
+ nil (list temp nil) nil
+ (append
+ (split-string-shell-command
+ python-interpreter-args)
+ `("-c" ,python--list-imports)
+ (list (or name "")))))
(with-current-buffer buffer
(apply #'call-process
python-interpreter
nil (list temp nil) nil
- "-c" python--list-imports
- (or name "")
- (mapcar #'file-local-name source)))))
+ (append
+ (split-string-shell-command
+ python-interpreter-args)
+ `("-c" ,python--list-imports)
+ (list (or name ""))
+ (mapcar #'file-local-name source))))))
lines)
- (unless (eq 0 status)
- (error "%s exited with status %s (maybe isort is missing?)"
- python-interpreter status))
+ (python--list-imports-check-status status)
(goto-char (point-min))
(while (not (eobp))
(push (buffer-substring-no-properties (point) (pos-eol))
@@ -6594,7 +6859,11 @@ Return non-nil if the buffer was actually modified."
(point-min) (point-max)
python-interpreter
nil (list temp nil) nil
- "-m" "isort" "-" args))
+ (append
+ (split-string-shell-command
+ python-interpreter-args)
+ '("-m" "isort" "-")
+ args)))
(tick (buffer-chars-modified-tick)))
(unless (eq 0 status)
(error "%s exited with status %s (maybe isort is missing?)"
@@ -6664,10 +6933,14 @@ asking."
(with-temp-buffer
(let ((temp (current-buffer)))
(with-current-buffer buffer
- (call-process-region (point-min) (point-max)
- python-interpreter
- nil temp nil
- "-m" "pyflakes"))
+ (apply #'call-process-region
+ (point-min) (point-max)
+ python-interpreter
+ nil temp nil
+ (append
+ (split-string-shell-command
+ python-interpreter-args)
+ '("-m" "pyflakes"))))
(goto-char (point-min))
(when (looking-at-p ".* No module named pyflakes$")
(error "%s couldn't find pyflakes" python-interpreter))
@@ -6870,8 +7143,10 @@ implementations: `python-mode' and `python-ts-mode'."
(add-to-list 'auto-mode-alist '("\\.py[iw]?\\'" . python-ts-mode))
(add-to-list 'interpreter-mode-alist '("python[0-9.]*" . python-ts-mode))))
+(derived-mode-add-parents 'python-ts-mode '(python-mode))
+
;;; Completion predicates for M-x
-;; Commands that only make sense when editing Python code
+;; Commands that only make sense when editing Python code.
(dolist (sym '(python-add-import
python-check
python-fill-paragraph
@@ -6905,12 +7180,7 @@ implementations: `python-mode' and `python-ts-mode'."
python-shell-send-defun
python-shell-send-statement
python-sort-imports))
- (put sym 'completion-predicate #'python--completion-predicate))
-
-(defun python-shell--completion-predicate (_ buffer)
- (provided-mode-derived-p
- (buffer-local-value 'major-mode buffer)
- 'python-base-mode 'inferior-python-mode))
+ (function-put sym 'command-modes '(python-base-mode)))
;; Commands that only make sense in the Python shell or when editing
;; Python code.
@@ -6925,8 +7195,12 @@ implementations: `python-mode' and `python-ts-mode'."
python-shell-font-lock-turn-off
python-shell-font-lock-turn-on
python-shell-package-enable
- python-shell-completion-complete-or-indent ))
- (put sym 'completion-predicate #'python-shell--completion-predicate))
+ python-shell-completion-complete-or-indent))
+ (function-put sym 'command-modes '(python-base-mode inferior-python-mode)))
+
+;;;###autoload
+(add-to-list 'auto-mode-alist
+ '("/\\(?:Pipfile\\|\\.?flake8\\)\\'" . conf-mode))
(provide 'python)
diff --git a/lisp/progmodes/ruby-mode.el b/lisp/progmodes/ruby-mode.el
index 534eeb16a67..999fbebfb08 100644
--- a/lisp/progmodes/ruby-mode.el
+++ b/lisp/progmodes/ruby-mode.el
@@ -516,7 +516,9 @@ is customizable via `ruby-encoding-magic-comment-style'.
When set to `always-utf8' an utf-8 comment will always be added,
even if it's not required."
- :type 'boolean :group 'ruby)
+ :type '(choice (const :tag "Don't insert" nil)
+ (const :tag "Insert utf-8 comment always" always-utf8)
+ (const :tag "Insert only when required" t)))
(defcustom ruby-encoding-magic-comment-style 'ruby
"The style of the magic encoding comment to use."
@@ -1850,93 +1852,92 @@ For example:
File.open
See `add-log-current-defun-function'."
- (condition-case nil
- (save-excursion
- (let* ((indent (ruby--add-log-current-indent))
- mname mlist
- (start (point))
- (make-definition-re
- (lambda (re &optional method-name?)
- (concat "^[ \t]*" re "[ \t]+"
- "\\("
- ;; \\. and :: for class methods
- "\\([A-Za-z_]" ruby-symbol-re "*[?!]?"
- "\\|"
- (if method-name? ruby-operator-re "\\.")
- "\\|::" "\\)"
- "+\\)")))
- (definition-re (funcall make-definition-re ruby-defun-beg-re t))
- (module-re (funcall make-definition-re "\\(class\\|module\\)")))
- ;; Get the current method definition (or class/module).
- (when (catch 'found
- (while (and (re-search-backward definition-re nil t)
- (if (if (string-equal "def" (match-string 1))
- ;; We're inside a method.
- (if (ruby-block-contains-point (1- start))
- t
- ;; Try to match a method only once.
- (setq definition-re module-re)
- nil)
- ;; Class/module. For performance,
- ;; comparing indentation.
- (or (not (numberp indent))
- (> indent (current-indentation))))
- (throw 'found t)
- t))))
- (goto-char (match-beginning 1))
- (if (not (string-equal "def" (match-string 1)))
- (setq mlist (list (match-string 2)))
- (setq mname (match-string 2)))
- (setq indent (current-column))
- (beginning-of-line))
- ;; Walk up the class/module nesting.
- (while (and indent
- (> indent 0)
- (re-search-backward module-re nil t))
- (goto-char (match-beginning 1))
- (when (< (current-column) indent)
- (setq mlist (cons (match-string 2) mlist))
- (setq indent (current-column))
- (beginning-of-line)))
- ;; Process the method name.
- (when mname
- (let ((mn (split-string mname "\\.\\|::")))
- (if (cdr mn)
- (progn
- (unless (string-equal "self" (car mn)) ; def self.foo
- ;; def C.foo
- (let ((ml (reverse mlist)))
- ;; If the method name references one of the
- ;; containing modules, drop the more nested ones.
- (while ml
- (if (string-equal (car ml) (car mn))
- (setq mlist (nreverse (cdr ml)) ml nil))
- (setq ml (cdr ml))))
- (if mlist
- (setcdr (last mlist) (butlast mn))
- (setq mlist (butlast mn))))
- (setq mname (concat "." (car (last mn)))))
- ;; See if the method is in singleton class context.
- (let ((in-singleton-class
- (when (re-search-forward ruby-singleton-class-re start t)
- (goto-char (match-beginning 0))
- ;; FIXME: Optimize it out, too?
- ;; This can be slow in a large file, but
- ;; unlike class/module declaration
- ;; indentations, method definitions can be
- ;; intermixed with these, and may or may not
- ;; be additionally indented after visibility
- ;; keywords.
- (ruby-block-contains-point start))))
- (setq mname (concat
- (if in-singleton-class "." "#")
- mname))))))
- ;; Generate the string.
- (if (consp mlist)
- (setq mlist (mapconcat (function identity) mlist "::")))
- (if mname
- (if mlist (concat mlist mname) mname)
- mlist)))))
+ (save-excursion
+ (let* ((indent (ruby--add-log-current-indent))
+ mname mlist
+ (start (point))
+ (make-definition-re
+ (lambda (re &optional method-name?)
+ (concat "^[ \t]*" re "[ \t]+"
+ "\\("
+ ;; \\. and :: for class methods
+ "\\([A-Za-z_]" ruby-symbol-re "*[?!]?"
+ "\\|"
+ (if method-name? ruby-operator-re "\\.")
+ "\\|::" "\\)"
+ "+\\)")))
+ (definition-re (funcall make-definition-re ruby-defun-beg-re t))
+ (module-re (funcall make-definition-re "\\(class\\|module\\)")))
+ ;; Get the current method definition (or class/module).
+ (when (catch 'found
+ (while (and (re-search-backward definition-re nil t)
+ (if (if (string-equal "def" (match-string 1))
+ ;; We're inside a method.
+ (if (ruby-block-contains-point (1- start))
+ t
+ ;; Try to match a method only once.
+ (setq definition-re module-re)
+ nil)
+ ;; Class/module. For performance,
+ ;; comparing indentation.
+ (or (not (numberp indent))
+ (> indent (current-indentation))))
+ (throw 'found t)
+ t))))
+ (goto-char (match-beginning 1))
+ (if (not (string-equal "def" (match-string 1)))
+ (setq mlist (list (match-string 2)))
+ (setq mname (match-string 2)))
+ (setq indent (current-column))
+ (beginning-of-line))
+ ;; Walk up the class/module nesting.
+ (while (and indent
+ (> indent 0)
+ (re-search-backward module-re nil t))
+ (goto-char (match-beginning 1))
+ (when (< (current-column) indent)
+ (setq mlist (cons (match-string 2) mlist))
+ (setq indent (current-column))
+ (beginning-of-line)))
+ ;; Process the method name.
+ (when mname
+ (let ((mn (split-string mname "\\.\\|::")))
+ (if (cdr mn)
+ (progn
+ (unless (string-equal "self" (car mn)) ; def self.foo
+ ;; def C.foo
+ (let ((ml (reverse mlist)))
+ ;; If the method name references one of the
+ ;; containing modules, drop the more nested ones.
+ (while ml
+ (if (string-equal (car ml) (car mn))
+ (setq mlist (nreverse (cdr ml)) ml nil))
+ (setq ml (cdr ml))))
+ (if mlist
+ (setcdr (last mlist) (butlast mn))
+ (setq mlist (butlast mn))))
+ (setq mname (concat "." (car (last mn)))))
+ ;; See if the method is in singleton class context.
+ (let ((in-singleton-class
+ (when (re-search-forward ruby-singleton-class-re start t)
+ (goto-char (match-beginning 0))
+ ;; FIXME: Optimize it out, too?
+ ;; This can be slow in a large file, but
+ ;; unlike class/module declaration
+ ;; indentations, method definitions can be
+ ;; intermixed with these, and may or may not
+ ;; be additionally indented after visibility
+ ;; keywords.
+ (ruby-block-contains-point start))))
+ (setq mname (concat
+ (if in-singleton-class "." "#")
+ mname))))))
+ ;; Generate the string.
+ (if (consp mlist)
+ (setq mlist (mapconcat (function identity) mlist "::")))
+ (if mname
+ (if mlist (concat mlist mname) mname)
+ mlist))))
(defun ruby-block-contains-point (pt)
(save-excursion
@@ -2105,12 +2106,6 @@ or `gem' statement around point."
"\\(%\\)[qQrswWxIi]?\\([[:punct:]]\\)"
"Regexp to match the beginning of percent literal.")
- (defconst ruby-syntax-methods-before-regexp
- '("gsub" "gsub!" "sub" "sub!" "scan" "split" "split!" "index" "match"
- "assert_match" "Given" "Then" "When")
- "Methods that can take regexp as the first argument.
-It will be properly highlighted even when the call omits parens.")
-
(defvar ruby-syntax-before-regexp-re
(concat
;; Special tokens that can't be followed by a division operator.
@@ -2122,11 +2117,9 @@ It will be properly highlighted even when the call omits parens.")
"\\|\\(?:^\\|\\s \\)"
(regexp-opt '("if" "elsif" "unless" "while" "until" "when" "and"
"or" "not" "&&" "||"))
- ;; Method name from the list.
- "\\|\\_<"
- (regexp-opt ruby-syntax-methods-before-regexp t)
"\\)\\s *")
- "Regexp to match text that can be followed by a regular expression."))
+ "Regexp to match text that disambiguates a regular expression.
+A slash character after any of these should begin a regexp."))
(defun ruby-syntax-propertize (start end)
"Syntactic keywords for Ruby mode. See `syntax-propertize-function'."
@@ -2182,20 +2175,18 @@ It will be properly highlighted even when the call omits parens.")
(when (save-excursion
(forward-char -1)
(cl-evenp (skip-chars-backward "\\\\")))
- (let ((state (save-excursion (syntax-ppss (match-beginning 1))))
- division-like)
+ (let ((state (save-excursion (syntax-ppss (match-beginning 1)))))
(when (or
;; Beginning of a regexp.
(and (null (nth 8 state))
- (save-excursion
- (setq division-like
- (or (eql (char-after) ?\s)
- (not (eql (char-before (1- (point))) ?\s))))
- (forward-char -1)
- (looking-back ruby-syntax-before-regexp-re
- (line-beginning-position)))
- (not (and division-like
- (match-beginning 2))))
+ (or (not
+ ;; Looks like division.
+ (or (eql (char-after) ?\s)
+ (not (eql (char-before (1- (point))) ?\s))))
+ (save-excursion
+ (forward-char -1)
+ (looking-back ruby-syntax-before-regexp-re
+ (line-beginning-position)))))
;; End of regexp. We don't match the whole
;; regexp at once because it can have
;; string interpolation inside, or span
@@ -2704,18 +2695,18 @@ Currently there are `ruby-mode' and `ruby-ts-mode'."
;;;###autoload
(add-to-list 'auto-mode-alist
(cons (purecopy (concat "\\(?:\\.\\(?:"
- "rbw?\\|ru\\|rake\\|thor"
+ "rbw?\\|ru\\|rake\\|thor\\|axlsx"
"\\|jbuilder\\|rabl\\|gemspec\\|podspec"
"\\)"
"\\|/"
"\\(?:Gem\\|Rake\\|Cap\\|Thor"
- "\\|Puppet\\|Berks\\|Brew"
+ "\\|Puppet\\|Berks\\|Brew\\|Fast"
"\\|Vagrant\\|Guard\\|Pod\\)file"
"\\)\\'"))
'ruby-mode))
;;;###autoload
-(dolist (name (list "ruby" "rbx" "jruby" "ruby1.9" "ruby1.8"))
+(dolist (name (list "ruby" "rbx" "jruby" "j?ruby\\(?:[0-9.]+\\)"))
(add-to-list 'interpreter-mode-alist (cons (purecopy name) 'ruby-mode)))
(provide 'ruby-mode)
diff --git a/lisp/progmodes/ruby-ts-mode.el b/lisp/progmodes/ruby-ts-mode.el
index b182fa867da..7133cb0b5b0 100644
--- a/lisp/progmodes/ruby-ts-mode.el
+++ b/lisp/progmodes/ruby-ts-mode.el
@@ -25,7 +25,7 @@
;;; Commentary:
;; This file defines ruby-ts-mode which is a major mode for editing
-;; Ruby files that uses Tree Sitter to parse the language. More
+;; Ruby files that uses Tree Sitter to parse the language. More
;; information about Tree Sitter can be found in the ELisp Info pages
;; as well as this website: https://tree-sitter.github.io/tree-sitter/
@@ -1088,6 +1088,15 @@ leading double colon is not added."
(put-text-property pos (1+ pos) 'syntax-table
(string-to-syntax "!"))))))))
+(defun ruby-ts--sexp-p (node)
+ ;; Skip parenless calls (implicit parens are both non-obvious to the
+ ;; user, and might take over when we want to just over some physical
+ ;; parens/braces).
+ (or (not (equal (treesit-node-type node)
+ "argument_list"))
+ (equal (treesit-node-type (treesit-node-child node 0))
+ "(")))
+
(defvar-keymap ruby-ts-mode-map
:doc "Keymap used in Ruby mode"
:parent prog-mode-map
@@ -1115,12 +1124,74 @@ leading double colon is not added."
;; Navigation.
(setq-local treesit-defun-type-regexp ruby-ts--method-regex)
+ (setq-local treesit-thing-settings
+ `((ruby
+ (sexp ,(cons (rx
+ bol
+ (or
+ "class"
+ "singleton_class"
+ "module"
+ "method"
+ "singleton_method"
+ "array"
+ "hash"
+ "parenthesized_statements"
+ "method_parameters"
+ "array_pattern"
+ "hash_pattern"
+ "if"
+ "else"
+ "then"
+ "unless"
+ "case"
+ "case_match"
+ "when"
+ "while"
+ "until"
+ "for"
+ "block"
+ "do_block"
+ "begin"
+ "integer"
+ "identifier"
+ "self"
+ "super"
+ "constant"
+ "simple_symbol"
+ "hash_key_symbol"
+ "symbol_array"
+ "string"
+ "string_array"
+ "heredoc_body"
+ "regex"
+ "argument_list"
+ "interpolation"
+ "instance_variable"
+ "global_variable"
+ )
+ eol)
+ #'ruby-ts--sexp-p)))))
+
;; AFAIK, Ruby can not nest methods
(setq-local treesit-defun-prefer-top-level nil)
;; Imenu.
(setq-local imenu-create-index-function #'ruby-ts--imenu)
+ ;; Outline minor mode.
+ (setq-local treesit-outline-predicate
+ (rx bos (or "singleton_method"
+ "method"
+ "alias"
+ "class"
+ "module")
+ eos))
+ ;; Restore default values of outline variables
+ ;; to use `treesit-outline-predicate'.
+ (kill-local-variable 'outline-regexp)
+ (kill-local-variable 'outline-level)
+
(setq-local treesit-simple-indent-rules (ruby-ts--indent-rules))
;; Font-lock.
@@ -1139,19 +1210,11 @@ leading double colon is not added."
(setq-local syntax-propertize-function #'ruby-ts--syntax-propertize))
+(derived-mode-add-parents 'ruby-ts-mode '(ruby-mode))
+
(if (treesit-ready-p 'ruby)
- ;; Copied from ruby-mode.el.
- (add-to-list 'auto-mode-alist
- (cons (concat "\\(?:\\.\\(?:"
- "rbw?\\|ru\\|rake\\|thor"
- "\\|jbuilder\\|rabl\\|gemspec\\|podspec"
- "\\)"
- "\\|/"
- "\\(?:Gem\\|Rake\\|Cap\\|Thor"
- "\\|Puppet\\|Berks\\|Brew"
- "\\|Vagrant\\|Guard\\|Pod\\)file"
- "\\)\\'")
- 'ruby-ts-mode)))
+ (add-to-list 'major-mode-remap-defaults
+ '(ruby-mode . ruby-ts-mode)))
(provide 'ruby-ts-mode)
diff --git a/lisp/progmodes/rust-ts-mode.el b/lisp/progmodes/rust-ts-mode.el
index 36ff4300f15..c67ac43e4d0 100644
--- a/lisp/progmodes/rust-ts-mode.el
+++ b/lisp/progmodes/rust-ts-mode.el
@@ -48,6 +48,12 @@
:safe 'integerp
:group 'rust)
+(defvar rust-ts-mode-prettify-symbols-alist
+ '(("&&" . ?∧) ("||" . ?∨)
+ ("<=" . ?≤) (">=" . ?≥) ("!=" . ?≠)
+ ("INFINITY" . ?∞) ("->" . ?→) ("=>" . ?⇒))
+ "Value for `prettify-symbols-alist' in `rust-ts-mode'.")
+
(defvar rust-ts-mode--syntax-table
(let ((table (make-syntax-table)))
(modify-syntax-entry ?+ "." table)
@@ -292,7 +298,8 @@
(let* ((beg (treesit-node-start node))
(face (save-excursion
(goto-char beg)
- (if (looking-at "/\\(?:/\\(?:/[^/]\\|!\\)\\|*\\(?:*[^*/]\\|!\\)\\)" t)
+ (if (looking-at-p
+ "/\\(?:/\\(?:/[^/]\\|!\\)\\|\\*\\(?:\\*[^*/]\\|!\\)\\)")
'font-lock-doc-face
'font-lock-comment-face))))
(treesit-fontify-with-override beg (treesit-node-end node)
@@ -397,6 +404,19 @@ delimiters < and >'s."
(?< '(4 . ?>))
(?> '(5 . ?<))))))))
+(defun rust-ts-mode--prettify-symbols-compose-p (start end match)
+ "Return true iff the symbol MATCH should be composed.
+See `prettify-symbols-compose-predicate'."
+ (and (fboundp 'prettify-symbols-default-compose-p)
+ (prettify-symbols-default-compose-p start end match)
+ ;; Make sure || is not a closure with 0 arguments and && is not
+ ;; a double reference.
+ (pcase match
+ ((or "||" "&&")
+ (string= (treesit-node-field-name (treesit-node-at (point)))
+ "operator"))
+ (_ t))))
+
;;;###autoload
(define-derived-mode rust-ts-mode prog-mode "Rust"
"Major mode for editing Rust, powered by tree-sitter."
@@ -422,6 +442,11 @@ delimiters < and >'s."
number type)
( bracket delimiter error function operator property variable)))
+ ;; Prettify configuration
+ (setq prettify-symbols-alist rust-ts-mode-prettify-symbols-alist)
+ (setq prettify-symbols-compose-predicate
+ #'rust-ts-mode--prettify-symbols-compose-p)
+
;; Imenu.
(setq-local treesit-simple-imenu-settings
`(("Module" "\\`mod_item\\'" nil nil)
@@ -449,6 +474,8 @@ delimiters < and >'s."
(treesit-major-mode-setup)))
+(derived-mode-add-parents 'rust-ts-mode '(rust-mode))
+
(if (treesit-ready-p 'rust)
(add-to-list 'auto-mode-alist '("\\.rs\\'" . rust-ts-mode)))
diff --git a/lisp/progmodes/scheme.el b/lisp/progmodes/scheme.el
index 9c4edbd11a0..67abab6913d 100644
--- a/lisp/progmodes/scheme.el
+++ b/lisp/progmodes/scheme.el
@@ -155,7 +155,7 @@
,(rx bol (zero-or-more space)
"(define-module"
(one-or-more space)
- (group "(" (one-or-more any) ")"))
+ (group "(" (one-or-more nonl) ")"))
1)
("Macros"
,(rx bol (zero-or-more space) "("
diff --git a/lisp/progmodes/sh-script.el b/lisp/progmodes/sh-script.el
index ee8cfe61d7f..ab95dc9f924 100644
--- a/lisp/progmodes/sh-script.el
+++ b/lisp/progmodes/sh-script.el
@@ -158,10 +158,6 @@
(autoload 'shell-command-completion "shell")
(autoload 'shell-environment-variable-completion "shell")
-(defvar font-lock-comment-face)
-(defvar font-lock-set-defaults)
-(defvar font-lock-string-face)
-
(defgroup sh nil
"Shell programming utilities."
@@ -864,14 +860,17 @@ See `sh-feature'.")
("\\${?\\([[:alpha:]_][[:alnum:]_]*\\|[0-9]+\\|[$*_]\\)" 1
font-lock-variable-name-face))
(rpm sh-append rpm2
- ("%{?\\(\\sw+\\)" 1 font-lock-keyword-face))
+ ("^\\s-*%\\(\\sw+\\)" 1 font-lock-keyword-face)
+ ("%{?\\([!?]*[[:alpha:]_][[:alnum:]_]*\\|[0-9]+\\|[%*#]\\*?\\|!?-[[:alpha:]]\\*?\\)"
+ 1 font-lock-variable-name-face))
(rpm2 sh-append shell
("^Summary:\\(.*\\)$" (1 font-lock-doc-face t))
- ("^\\(\\sw+\\):" 1 font-lock-variable-name-face)))
+ ("^\\(\\sw+\\)\\((\\(\\sw+\\))\\)?:" (1 font-lock-variable-name-face)
+ (3 font-lock-string-face nil t))))
"Default expressions to highlight in Shell Script modes. See `sh-feature'.")
(defvar sh-font-lock-keywords-var-1
- '((sh "[ \t]in\\>"))
+ '((sh "[ \t]\\(in\\|do\\)\\>"))
"Subdued level highlighting for Shell Script modes.")
(defvar sh-font-lock-keywords-var-2 ()
@@ -1042,7 +1041,9 @@ subshells can nest."
;; Maybe we've bumped into an escaped newline.
(sh-is-quoted-p (point)))
(backward-char 1))
- (when (eq (char-before) ?|)
+ (when (and
+ (eq (char-before) ?|)
+ (not (eq (char-before (1- (point))) ?\;)))
(backward-char 1) t)))
(and (> (point) (1+ (point-min)))
(progn (backward-char 2)
@@ -1053,7 +1054,8 @@ subshells can nest."
;; a normal command rather than the real `in' keyword.
;; I.e. we should look back to try and find the
;; corresponding `case'.
- (and (looking-at ";[;&]\\|\\_<in")
+ ;; Also recognize OpenBSD's case X { ... } (bug#55764).
+ (and (looking-at ";\\(?:;&?\\|[&|]\\)\\|\\_<in\\|.{")
;; ";; esac )" is a case that looks
;; like a case-pattern but it's really just a close
;; paren after a case statement. I.e. if we skipped
@@ -1487,6 +1489,7 @@ Return the name of the shell suitable for `sh-set-shell'."
((string-match "[.]t?csh\\(rc\\)?\\>" buffer-file-name) "csh")
((string-match "[.]zsh\\(rc\\|env\\)?\\>" buffer-file-name) "zsh")
((equal (file-name-nondirectory buffer-file-name) ".profile") "sh")
+ ((equal (file-name-nondirectory buffer-file-name) "PKGBUILD") "bash")
(t sh-shell-file)))
;;;###autoload
@@ -1628,9 +1631,16 @@ not written in Bash or sh."
( bracket delimiter misc-punctuation operator)))
(setq-local treesit-font-lock-settings
sh-mode--treesit-settings)
+ (setq-local treesit-thing-settings
+ `((bash
+ (sentence ,(regexp-opt '("comment"
+ "heredoc_start"
+ "heredoc_body"))))))
(setq-local treesit-defun-type-regexp "function_definition")
(treesit-major-mode-setup)))
+(derived-mode-add-parents 'bash-ts-mode '(sh-mode))
+
(advice-add 'bash-ts-mode :around #'sh--redirect-bash-ts-mode
;; Give it lower precedence than normal advice, so other
;; advices take precedence over it.
@@ -1785,8 +1795,9 @@ before the newline and in that case point should be just before the token."
(pattern (rpattern) ("case-(" rpattern))
(branches (branches ";;" branches)
(branches ";&" branches) (branches ";;&" branches) ;bash.
+ (branches ";|" branches) ;zsh.
(pattern "case-)" cmd)))
- '((assoc ";;" ";&" ";;&"))
+ '((assoc ";;" ";&" ";;&" ";|"))
'((assoc ";" "&") (assoc "&&" "||") (assoc "|" "|&")))))
(defconst sh-smie--sh-operators
@@ -1802,8 +1813,8 @@ before the newline and in that case point should be just before the token."
(concat "\\(?:^\\|[^\\]\\)\\(?:\\\\\\\\\\)*"
"\\(" sh-smie--sh-operators-re "\\)"))
-(defun sh-smie--sh-keyword-in-p ()
- "Assuming we're looking at \"in\", return non-nil if it's a keyword.
+(defun sh-smie--sh-keyword-in/do-p (tok)
+ "When looking at TOK (either \"in\" or \"do\"), non-nil if TOK is a keyword.
Does not preserve point."
(let ((forward-sexp-function nil)
(words nil) ;We've seen words.
@@ -1825,7 +1836,10 @@ Does not preserve point."
((equal prev ";")
(if words (setq newline t)
(setq res 'keyword)))
- ((member prev '("case" "for" "select")) (setq res 'keyword))
+ ((member prev (if (string= tok "in")
+ '("case" "for" "select")
+ '("for" "select")))
+ (setq res 'keyword))
((assoc prev smie-grammar) (setq res 'word))
(t
(if newline
@@ -1837,7 +1851,7 @@ Does not preserve point."
"Non-nil if TOK (at which we're looking) really is a keyword."
(cond
((looking-at "[[:alnum:]_]+=") nil)
- ((equal tok "in") (sh-smie--sh-keyword-in-p))
+ ((member tok '("in" "do")) (sh-smie--sh-keyword-in/do-p tok))
(t (sh-smie--keyword-p))))
(defun sh-smie--default-forward-token ()
@@ -2011,7 +2025,7 @@ May return nil if the line should not be treated as continued."
(forward-line -1)
(if (sh-smie--looking-back-at-continuation-p)
(current-indentation)
- (+ (current-indentation) sh-basic-offset))))
+ (+ (current-indentation) (sh-var-value 'sh-indent-for-continuation)))))
(t
;; Just make sure a line-continuation is indented deeper.
(save-excursion
@@ -2032,7 +2046,10 @@ May return nil if the line should not be treated as continued."
;; check the line before that one.
(> ci indent))
(t ;Previous line is the beginning of the continued line.
- (setq indent (min (+ ci sh-basic-offset) max))
+ (setq
+ indent
+ (min
+ (+ ci (sh-var-value 'sh-indent-for-continuation)) max))
nil)))))
indent))))))
@@ -2043,9 +2060,9 @@ May return nil if the line should not be treated as continued."
(sh-var-value 'sh-indent-for-case-label)))
(`(:before . ,(or "(" "{" "[" "while" "if" "for" "case"))
(cond
- ((and (equal token "{") (smie-rule-parent-p "for"))
+ ((and (equal token "{") (smie-rule-parent-p "for" "case"))
(let ((data (smie-backward-sexp "in")))
- (when (equal (nth 2 data) "for")
+ (when (member (nth 2 data) '("for" "case"))
`(column . ,(smie-indent-virtual)))))
((not (smie-rule-prev-p "&&" "||" "|"))
(when (smie-rule-hanging-p)
@@ -2056,11 +2073,11 @@ May return nil if the line should not be treated as continued."
`(column . ,(smie-indent-virtual))))))
;; FIXME: Maybe this handling of ;; should be made into
;; a smie-rule-terminator function that takes the substitute ";" as arg.
- (`(:before . ,(or ";;" ";&" ";;&"))
- (if (and (smie-rule-bolp) (looking-at ";;?&?[ \t]*\\(#\\|$\\)"))
+ (`(:before . ,(or ";;" ";&" ";;&" ";|"))
+ (if (and (smie-rule-bolp) (looking-at ";\\(?:;&?\\|[&|]\\)?[ \t]*\\(#\\|$\\)"))
(cons 'column (smie-indent-keyword ";"))
(smie-rule-separator kind)))
- (`(:after . ,(or ";;" ";&" ";;&"))
+ (`(:after . ,(or ";;" ";&" ";;&" ";|"))
(with-demoted-errors "SMIE rule error: %S"
(smie-backward-sexp token)
(cons 'column
@@ -2149,8 +2166,9 @@ May return nil if the line should not be treated as continued."
(pattern (pattern "|" pattern))
(branches (branches ";;" branches)
(branches ";&" branches) (branches ";;&" branches) ;bash.
+ (branches ";|" branches) ;zsh.
(pattern "case-)" cmd)))
- '((assoc ";;" ";&" ";;&"))
+ '((assoc ";;" ";&" ";;&" ";|"))
'((assoc "case") (assoc ";" "&") (assoc "&&" "||") (assoc "|" "|&")))))
(defun sh-smie--rc-after-special-arg-p ()
@@ -2288,7 +2306,7 @@ Point should be before the newline."
When used interactively, insert the proper starting #!-line,
and make the visited file executable via `executable-set-magic',
perhaps querying depending on the value of `executable-query'.
-(If given a prefix (i.e., `\\[universal-argument]') don't insert any starting #!
+(If given a prefix (i.e., \\[universal-argument]) don't insert any starting #!
line.)
When this function is called noninteractively, INSERT-FLAG (the third
diff --git a/lisp/progmodes/sql.el b/lisp/progmodes/sql.el
index d1301aed3bb..604f04a3d57 100644
--- a/lisp/progmodes/sql.el
+++ b/lisp/progmodes/sql.el
@@ -235,10 +235,6 @@
(require 'view)
(eval-when-compile (require 'subr-x)) ; string-empty-p
-(defvar font-lock-keyword-face)
-(defvar font-lock-set-defaults)
-(defvar font-lock-string-face)
-
;;; Allow customization
(defgroup SQL nil
@@ -1191,12 +1187,11 @@ Starts `sql-interactive-mode' after doing some setup."
(defcustom sql-postgres-options '("-P" "pager=off")
"List of additional options for `sql-postgres-program'.
-The default setting includes the -P option which breaks older versions
-of the psql client (such as version 6.5.3). The -P option is equivalent
-to the --pset option. If you want the psql to prompt you for a user
-name, add the string \"-u\" to the list of options. If you want to
-provide a user name on the command line (newer versions such as 7.1),
-add your name with a \"-U\" prefix (such as \"-Umark\") to the list."
+The default -P option is equivalent to the --pset option. If you
+want psql to prompt you for a user name, add the string \"-u\" to
+the list of options. If you want to provide a user name on the
+command line, add your name with a \"-U\" prefix (such as
+\"-Umark\") to the list."
:type '(repeat string)
:version "20.8")
@@ -3096,9 +3091,7 @@ displayed."
(defun sql-accumulate-and-indent ()
"Continue SQL statement on the next line."
(interactive)
- (if (fboundp 'comint-accumulate)
- (comint-accumulate)
- (newline))
+ (comint-accumulate)
(indent-according-to-mode))
(defun sql-help-list-products (indent freep)
@@ -4033,7 +4026,7 @@ The list is maintained in SQL interactive buffers.")
(defun sql--completion-table (string pred action)
(when sql-completion-sqlbuf
(with-current-buffer sql-completion-sqlbuf
- (let ((schema (and (string-match "\\`\\(\\sw\\(:?\\sw\\|\\s_\\)*\\)[.]" string)
+ (let ((schema (and (string-match "\\`\\(\\sw\\(?:\\sw\\|\\s_\\)*\\)[.]" string)
(downcase (match-string 1 string)))))
;; If we haven't loaded any object name yet, load local schema
diff --git a/lisp/progmodes/tcl.el b/lisp/progmodes/tcl.el
index 882aa10aaee..dc11f456cd0 100644
--- a/lisp/progmodes/tcl.el
+++ b/lisp/progmodes/tcl.el
@@ -1340,7 +1340,7 @@ to update the alist.")
If FLAG is nil, just uses `current-word'.
Otherwise scans backward for most likely Tcl command word."
(if (and flag
- (derived-mode-p 'tcl-mode 'inferior-tcl-mode))
+ (derived-mode-p '(tcl-mode inferior-tcl-mode)))
(condition-case nil
(save-excursion
;; Look backward for first word actually in alist.
@@ -1575,7 +1575,7 @@ The first line is assumed to look like \"#!.../program ...\"."
(if (memq char '(?\[ ?\] ?{ ?} ?\\ ?\" ?$ ?\s ?\;))
(concat "\\" (char-to-string char))
(char-to-string char)))
- string ""))
+ string))
diff --git a/lisp/progmodes/typescript-ts-mode.el b/lisp/progmodes/typescript-ts-mode.el
index 7021f012dcd..ea4f6417c5a 100644
--- a/lisp/progmodes/typescript-ts-mode.el
+++ b/lisp/progmodes/typescript-ts-mode.el
@@ -391,6 +391,52 @@ Argument LANGUAGE is either `typescript' or `tsx'."
:override t
'((escape_sequence) @font-lock-escape-face))))
+(defvar typescript-ts-mode--sentence-nodes
+ '("import_statement"
+ "debugger_statement"
+ "expression_statement"
+ "if_statement"
+ "switch_statement"
+ "for_statement"
+ "for_in_statement"
+ "while_statement"
+ "do_statement"
+ "try_statement"
+ "with_statement"
+ "break_statement"
+ "continue_statement"
+ "return_statement"
+ "throw_statement"
+ "empty_statement"
+ "labeled_statement"
+ "variable_declaration"
+ "lexical_declaration"
+ "property_signature")
+ "Nodes that designate sentences in TypeScript.
+See `treesit-thing-settings' for more information.")
+
+(defvar typescript-ts-mode--sexp-nodes
+ '("expression"
+ "pattern"
+ "array"
+ "function"
+ "string"
+ "escape"
+ "template"
+ "regex"
+ "number"
+ "identifier"
+ "this"
+ "super"
+ "true"
+ "false"
+ "null"
+ "undefined"
+ "arguments"
+ "pair")
+ "Nodes that designate sexps in TypeScript.
+See `treesit-thing-settings' for more information.")
+
;;;###autoload
(define-derived-mode typescript-ts-base-mode prog-mode "TypeScript"
"Generic major mode for editing TypeScript.
@@ -401,6 +447,7 @@ This mode is intended to be inherited by concrete major modes."
;; Comments.
(c-ts-common-comment-setup)
+ (setq-local treesit-defun-prefer-top-level t)
;; Electric
(setq-local electric-indent-chars
@@ -415,6 +462,14 @@ This mode is intended to be inherited by concrete major modes."
"lexical_declaration")))
(setq-local treesit-defun-name-function #'js--treesit-defun-name)
+ (setq-local treesit-thing-settings
+ `((typescript
+ (sexp ,(regexp-opt typescript-ts-mode--sexp-nodes))
+ (sentence ,(regexp-opt
+ typescript-ts-mode--sentence-nodes))
+ (text ,(regexp-opt '("comment"
+ "template_string"))))))
+
;; Imenu (same as in `js-ts-mode').
(setq-local treesit-simple-imenu-settings
`(("Function" "\\`function_declaration\\'" nil nil)
@@ -450,6 +505,8 @@ This mode is intended to be inherited by concrete major modes."
(treesit-major-mode-setup)))
+(derived-mode-add-parents 'typescript-ts-mode '(typescript-mode))
+
(if (treesit-ready-p 'typescript)
(add-to-list 'auto-mode-alist '("\\.ts\\'" . typescript-ts-mode)))
@@ -485,6 +542,16 @@ at least 3 (which is the default value)."
(setq-local treesit-simple-indent-rules
(typescript-ts-mode--indent-rules 'tsx))
+ (setq-local treesit-thing-settings
+ `((tsx
+ (sexp ,(regexp-opt
+ (append typescript-ts-mode--sexp-nodes
+ '("jsx"))))
+ (sentence ,(regexp-opt
+ (append typescript-ts-mode--sentence-nodes
+ '("jsx_element"
+ "jsx_self_closing_element")))))))
+
;; Font-lock.
(setq-local treesit-font-lock-settings
(typescript-ts-mode--font-lock-settings 'tsx))
@@ -497,6 +564,8 @@ at least 3 (which is the default value)."
(treesit-major-mode-setup)))
+(derived-mode-add-parents 'tsx-ts-mode '(tsx-mode))
+
(defvar typescript-ts--s-p-query
(when (treesit-available-p)
(treesit-query-compile 'typescript
diff --git a/lisp/progmodes/vera-mode.el b/lisp/progmodes/vera-mode.el
index db5383a44a3..184cce66ae4 100644
--- a/lisp/progmodes/vera-mode.el
+++ b/lisp/progmodes/vera-mode.el
@@ -5,7 +5,7 @@
;; Author: Reto Zimmermann <reto@gnu.org>
;; Version: 2.28
;; Keywords: languages vera
-;; WWW: https://guest.iis.ee.ethz.ch/~zimmi/emacs/vera-mode.html
+;; URL: https://iis-people.ee.ethz.ch/~zimmi/emacs/vera-mode.html
;; Yoni Rabkin <yoni@rabkins.net> contacted the maintainer of this
;; file on 18/3/2008, and the maintainer agreed that when a bug is
diff --git a/lisp/progmodes/verilog-mode.el b/lisp/progmodes/verilog-mode.el
index 38c012b2626..a83bad0e8ed 100644
--- a/lisp/progmodes/verilog-mode.el
+++ b/lisp/progmodes/verilog-mode.el
@@ -9,7 +9,7 @@
;; Keywords: languages
;; The "Version" is the date followed by the decimal rendition of the Git
;; commit hex.
-;; Version: 2021.10.14.127365406
+;; Version: 2024.03.01.121933719
;; Yoni Rabkin <yoni@rabkins.net> contacted the maintainer of this
;; file on 19/3/2008, and the maintainer agreed that when a bug is
@@ -124,7 +124,7 @@
;;
;; This variable will always hold the version number of the mode
-(defconst verilog-mode-version "2021-10-14-797711e-vpo-GNU"
+(defconst verilog-mode-version "2024-03-01-7448f97-vpo-GNU"
"Version of this Verilog mode.")
(defconst verilog-mode-release-emacs t
"If non-nil, this version of Verilog mode was released with Emacs itself.")
@@ -356,7 +356,9 @@ wherever possible, since it is slow."
(eval-and-compile
;; Both xemacs and emacs
(condition-case nil
- (require 'diff) ; diff-command and diff-switches
+ ;; `diff-command' and `diff-switches',
+ ;; although XEmacs lacks the former.
+ (require 'diff)
(error nil))
(condition-case nil
(require 'compile) ; compilation-error-regexp-alist-alist
@@ -370,7 +372,8 @@ wherever possible, since it is slow."
(unless (fboundp 'ignore-errors)
(defmacro ignore-errors (&rest body)
(declare (debug t) (indent 0))
- `(condition-case nil (progn ,@body) (error nil)))))
+ `(condition-case nil (progn ,@body) (error nil))))
+ (error nil))
;; Added in Emacs 24.1
(condition-case nil
(unless (fboundp 'prog-mode)
@@ -455,11 +458,11 @@ This function may be removed when Emacs 21 is no longer supported."
last-command-event)))
(defvar verilog-no-change-functions nil
- "True if `after-change-functions' is disabled.
+ "Non-nil if `after-change-functions' is disabled.
Use of `syntax-ppss' may break, as ppss's cache may get corrupted.")
(defvar verilog-in-hooks nil
- "True when within a `verilog-run-hooks' block.")
+ "Non-nil when within a `verilog-run-hooks' block.")
(defmacro verilog-run-hooks (&rest hooks)
"Run each hook in HOOKS using `run-hooks'.
@@ -505,8 +508,14 @@ Set `verilog-in-hooks' during this time, to assist AUTO caches."
(defvar verilog-debug nil
"Non-nil means enable debug messages for `verilog-mode' internals.")
-(defvar verilog-warn-fatal nil
- "Non-nil means `verilog-warn-error' warnings are fatal `error's.")
+(defcustom verilog-warn-fatal nil
+ "Non-nil means `verilog-warn-error' warnings are fatal `error's."
+ :group 'verilog-mode-auto
+ :type 'boolean)
+(put 'verilog-warn-fatal 'safe-local-variable #'verilog-booleanp)
+
+;; Internal use similar to `verilog-warn-fatal'
+(defvar verilog-warn-fatal-internal t)
(defcustom verilog-linter
"echo 'No verilog-linter set, see \"M-x describe-variable verilog-linter\"'"
@@ -679,6 +688,18 @@ Set to 0 to have all directives start at the left side of the screen."
:type 'integer)
(put 'verilog-indent-level-directive 'safe-local-variable #'integerp)
+(defcustom verilog-indent-ignore-multiline-defines t
+ "Non-nil means ignore indentation on lines that are part of a multiline define."
+ :group 'verilog-mode-indent
+ :type 'boolean)
+(put 'verilog-indent-ignore-multiline-defines 'safe-local-variable #'verilog-booleanp)
+
+(defcustom verilog-indent-ignore-regexp nil
+ "Regexp that matches lines that should be ignored for indentation."
+ :group 'verilog-mode-indent
+ :type 'boolean)
+(put 'verilog-indent-ignore-regexp 'safe-local-variable #'stringp)
+
(defcustom verilog-cexp-indent 2
"Indentation of Verilog statements split across lines."
:group 'verilog-mode-indent
@@ -723,6 +744,13 @@ Otherwise, line them up."
:type 'boolean)
(put 'verilog-indent-begin-after-if 'safe-local-variable #'verilog-booleanp)
+(defcustom verilog-indent-class-inside-pkg t
+ "Non-nil means indent classes inside packages.
+Otherwise, classes have zero indentation."
+ :group 'verilog-mode-indent
+ :type 'boolean)
+(put 'verilog-indent-class-inside-pkg 'safe-local-variable #'verilog-booleanp)
+
(defcustom verilog-align-ifelse nil
"Non-nil means align `else' under matching `if'.
Otherwise else is lined up with first character on line holding matching if."
@@ -730,6 +758,38 @@ Otherwise else is lined up with first character on line holding matching if."
:type 'boolean)
(put 'verilog-align-ifelse 'safe-local-variable #'verilog-booleanp)
+(defcustom verilog-align-decl-expr-comments t
+ "Non-nil means align declaration and expressions comments."
+ :group 'verilog-mode-indent
+ :type 'boolean)
+(put 'verilog-align-decl-expr-comments 'safe-local-variable #'verilog-booleanp)
+
+(defcustom verilog-align-comment-distance 1
+ "Distance (in spaces) between longest declaration/expression and comments.
+Only works if `verilog-align-decl-expr-comments' is non-nil."
+ :group 'verilog-mode-indent
+ :type 'integer)
+(put 'verilog-align-comment-distance 'safe-local-variable #'integerp)
+
+(defcustom verilog-align-assign-expr nil
+ "Non-nil means align expressions of continuous assignments."
+ :group 'verilog-mode-indent
+ :type 'boolean)
+(put 'verilog-align-assign-expr 'safe-local-variable #'verilog-booleanp)
+
+(defcustom verilog-align-typedef-regexp nil
+ "Regexp that matches user typedefs for declaration alignment."
+ :group 'verilog-mode-indent
+ :type '(choice (regexp :tag "Regexp")
+ (const :tag "None" nil)))
+(put 'verilog-align-typedef-regexp 'safe-local-variable #'stringp)
+
+(defcustom verilog-align-typedef-words nil
+ "List of words that match user typedefs for declaration alignment."
+ :group 'verilog-mode-indent
+ :type '(repeat string))
+(put 'verilog-align-typedef-words 'safe-local-variable #'listp)
+
(defcustom verilog-minimum-comment-distance 10
"Minimum distance (in lines) between begin and end required before a comment.
Setting this variable to zero results in every end acquiring a comment; the
@@ -876,6 +936,12 @@ always be saved."
:type 'boolean)
(put 'verilog-auto-star-save 'safe-local-variable #'verilog-booleanp)
+(defcustom verilog-fontify-variables t
+ "Non-nil means fontify declaration variables."
+ :group 'verilog-mode-actions
+ :type 'boolean)
+(put 'verilog-fontify-variables 'safe-local-variable #'verilog-booleanp)
+
(defvar verilog-auto-update-tick nil
"Modification tick at which autos were last performed.")
@@ -1052,7 +1118,7 @@ You might want these defined in each file; put at the *END* of your file
something like:
// Local Variables:
- // verilog-library-files:(\"/some/path/technology.v\" \"/some/path/tech2.v\")
+ // verilog-library-files:(\"/path/technology.v\" \"/path2/tech2.v\")
// End:
Verilog-mode attempts to detect changes to this local variable, but they
@@ -1124,7 +1190,7 @@ those temporaries reset. See example in `verilog-auto-reset'."
(put 'verilog-auto-reset-blocking-in-non 'safe-local-variable #'verilog-booleanp)
(defcustom verilog-auto-reset-widths t
- "True means AUTORESET should determine the width of signals.
+ "Non-nil means AUTORESET should determine the width of signals.
This is then used to set the width of the zero (32'h0 for example). This
is required by some lint tools that aren't smart enough to ignore widths of
the constant zero. This may result in ugly code when parameters determine
@@ -1264,7 +1330,7 @@ See `verilog-auto-inst-param-value'."
Also affects AUTOINSTPARAM. Declaration order is the default for
backward compatibility, and as some teams prefer signals that are
declared together to remain together. Sorted order reduces
-changes when declarations are moved around in a file. Sorting is
+changes when declarations are moved around in a file. Sorting is
within input/output/inout groupings, there is intentionally no
option to intermix between input/output/inouts.
@@ -1275,7 +1341,7 @@ See also `verilog-auto-arg-sort'."
(put 'verilog-auto-inst-sort 'safe-local-variable #'verilog-booleanp)
(defcustom verilog-auto-inst-vector t
- "True means when creating default ports with AUTOINST, use bus subscripts.
+ "Non-nil means when creating default ports with AUTOINST, use bus subscripts.
If nil, skip the subscript when it matches the entire bus as declared in
the module (AUTOWIRE signals always are subscripted, you must manually
declare the wire to have the subscripts removed.) Setting this to nil may
@@ -1515,10 +1581,9 @@ If set will become buffer local.")
(define-key map "\C-c/" #'verilog-star-comment)
(define-key map "\C-c\C-c" #'verilog-comment-region)
(define-key map "\C-c\C-u" #'verilog-uncomment-region)
- (when (featurep 'xemacs)
- (define-key map [(meta control h)] #'verilog-mark-defun)
- (define-key map "\M-\C-a" #'verilog-beg-of-defun)
- (define-key map "\M-\C-e" #'verilog-end-of-defun))
+ (define-key map "\M-\C-h" #'verilog-mark-defun)
+ (define-key map "\M-\C-a" #'verilog-beg-of-defun)
+ (define-key map "\M-\C-e" #'verilog-end-of-defun)
(define-key map "\C-c\C-d" #'verilog-goto-defun)
(define-key map "\C-c\C-k" #'verilog-delete-auto)
(define-key map "\C-c\C-a" #'verilog-auto)
@@ -2028,11 +2093,11 @@ Where __FLAGS__ appears in the string `verilog-current-flags'
will be substituted. Where __FILE__ appears in the string, the
current buffer's file-name, without the directory portion, will
be substituted."
- (setq command (verilog-string-replace-matches
+ (setq command (verilog-string-replace-matches
;; Note \\b only works if under verilog syntax table
"\\b__FLAGS__\\b" (verilog-current-flags)
t t command))
- (setq command (verilog-string-replace-matches
+ (setq command (verilog-string-replace-matches
"\\b__FILE__\\b" (file-name-nondirectory
(or (buffer-file-name) ""))
t t command))
@@ -2468,13 +2533,8 @@ find the errors."
;;
;; Regular expressions used to calculate indent, etc.
;;
-(defconst verilog-symbol-re "\\<[a-zA-Z_][a-zA-Z_0-9.]*\\>")
-;; Want to match
-;; aa :
-;; aa,bb :
-;; a[34:32] :
-;; a,
-;; b :
+(defconst verilog-identifier-re "[a-zA-Z_][a-zA-Z_0-9]*")
+(defconst verilog-identifier-sym-re (concat "\\<" verilog-identifier-re "\\>"))
(defconst verilog-assignment-operator-re
(eval-when-compile
(verilog-regexp-opt
@@ -2492,16 +2552,17 @@ find the errors."
) 't
)))
(defconst verilog-assignment-operation-re
- (concat
- ;; "\\(^\\s-*[A-Za-z0-9_]+\\(\\[\\([A-Za-z0-9_]+\\)\\]\\)*\\s-*\\)"
- ;; "\\(^\\s-*[^=<>+-*/%&|^:\\s-]+[^=<>+-*/%&|^\n]*?\\)"
- "\\(^.*?\\)" "\\B" verilog-assignment-operator-re "\\B" ))
+ (concat "\\(^.*?\\)" verilog-assignment-operator-re))
+(defconst verilog-assignment-operation-re-2
+ (concat "\\(.*?\\)" verilog-assignment-operator-re))
+
+;; Loosely related to IEEE 1800's concurrent_assertion_statement
+(defconst verilog-concurrent-assertion-statement-re
+ "\\(\\<\\(assert\\|assume\\|cover\\|restrict\\)\\>\\s-+\\<\\(property\\|sequence\\)\\>\\)\\|\\(\\<assert\\>\\)")
-(defconst verilog-label-re (concat verilog-symbol-re "\\s-*:\\s-*"))
+(defconst verilog-label-re (concat verilog-identifier-sym-re "\\s-*:\\s-*"))
(defconst verilog-property-re
- (concat "\\(" verilog-label-re "\\)?"
- ;; "\\(assert\\|assume\\|cover\\)\\s-+property\\>"
- "\\(\\(assert\\|assume\\|cover\\)\\>\\s-+\\<property\\>\\)\\|\\(assert\\)"))
+ (concat "\\(" verilog-label-re "\\)?" verilog-concurrent-assertion-statement-re))
(defconst verilog-no-indent-begin-re
(eval-when-compile
@@ -2656,7 +2717,6 @@ find the errors."
"\\(\\<fork\\>\\)\\|" ; 7
"\\(\\<if\\>\\)\\|"
verilog-property-re "\\|"
- "\\(\\(" verilog-label-re "\\)?\\<assert\\>\\)\\|"
"\\(\\<clocking\\>\\)\\|"
"\\(\\<task\\>\\)\\|"
"\\(\\<function\\>\\)\\|"
@@ -2732,6 +2792,9 @@ find the errors."
"\\|\\(\\<clocking\\>\\)" ;17
"\\|\\(\\<`[ou]vm_[a-z_]+_begin\\>\\)" ;18
"\\|\\(\\<`vmm_[a-z_]+_member_begin\\>\\)"
+ "\\|\\(\\<`ifn?def\\>\\)" ;20, matched end can be: `else `elsif `endif
+ "\\|\\(\\<`else\\>\\)" ;21, matched end can be: `endif
+ "\\|\\(\\<`elsif\\>\\)" ;22, matched end can be: `else `endif
;;
))
@@ -2817,40 +2880,54 @@ find the errors."
"localparam" "parameter" "var"
;; misc
"string" "event" "chandle" "virtual" "enum" "genvar"
- "struct" "union"
+ "struct" "union" "type"
;; builtin classes
"mailbox" "semaphore"
))))
-(defconst verilog-declaration-re
- (concat "\\(" verilog-declaration-prefix-re "\\s-*\\)?" verilog-declaration-core-re))
(defconst verilog-range-re "\\(\\[[^]]*\\]\\s-*\\)+")
(defconst verilog-optional-signed-re "\\s-*\\(\\(un\\)?signed\\)?")
(defconst verilog-optional-signed-range-re
- (concat
- "\\s-*\\(\\<\\(reg\\|wire\\)\\>\\s-*\\)?\\(\\<\\(un\\)?signed\\>\\s-*\\)?\\(" verilog-range-re "\\)?"))
+ (concat "\\s-*\\(\\<\\(reg\\|wire\\)\\>\\s-*\\)?\\(\\<\\(un\\)?signed\\>\\s-*\\)?\\(" verilog-range-re "\\)?"))
(defconst verilog-macroexp-re "`\\sw+")
-
(defconst verilog-delay-re "#\\s-*\\(\\([0-9_]+\\('s?[hdxbo][0-9a-fA-F_xz]+\\)?\\)\\|\\(([^()]*)\\)\\|\\(\\sw+\\)\\)")
-(defconst verilog-declaration-re-2-no-macro
- (concat "\\s-*" verilog-declaration-re
- "\\s-*\\(\\(" verilog-optional-signed-range-re "\\)\\|\\(" verilog-delay-re "\\)"
- "\\)"))
-(defconst verilog-declaration-re-2-macro
- (concat "\\s-*" verilog-declaration-re
- "\\s-*\\(\\(" verilog-optional-signed-range-re "\\)\\|\\(" verilog-delay-re "\\)"
- "\\|\\(" verilog-macroexp-re "\\)"
- "\\)"))
-(defconst verilog-declaration-re-1-macro
- (concat "^" verilog-declaration-re-2-macro))
-
-(defconst verilog-declaration-re-1-no-macro (concat "^" verilog-declaration-re-2-no-macro))
+(defconst verilog-interface-modport-re "\\(\\s-*\\([a-zA-Z0-9`_$]+\\.[a-zA-Z0-9`_$]+\\)[ \t\f]+\\)")
+(defconst verilog-comment-start-regexp "//\\|/\\*" "Dual comment value for `comment-start-regexp'.")
+(defconst verilog-typedef-enum-re
+ (concat "^\\s-*\\(typedef\\s-+\\)?enum\\(\\s-+" verilog-declaration-core-re verilog-optional-signed-range-re "\\)?"))
+
+(defconst verilog-declaration-simple-re
+ (concat "\\(" verilog-declaration-prefix-re "\\s-*\\)?" verilog-declaration-core-re))
+(defconst verilog-declaration-re
+ (concat "\\s-*" verilog-declaration-simple-re
+ "\\s-*\\(\\(" verilog-optional-signed-range-re "\\)\\|\\(" verilog-delay-re "\\)\\)"))
+(defconst verilog-declaration-re-macro
+ (concat "\\s-*" verilog-declaration-simple-re
+ "\\s-*\\(\\(" verilog-optional-signed-range-re "\\)\\|\\(" verilog-delay-re "\\)\\|\\(" verilog-macroexp-re "\\)\\)"))
+(defconst verilog-declaration-or-iface-mp-re
+ (concat "\\(" verilog-declaration-re "\\)\\|\\(" verilog-interface-modport-re "\\)"))
+(defconst verilog-declaration-embedded-comments-re
+ (concat "\\( " verilog-declaration-re "\\) ""\\s-*" "\\(" verilog-comment-start-regexp "\\)")
+ "Match expressions such as: input logic [7:0] /* auto enum sm_psm */ sm_psm;.")
(defconst verilog-defun-re
(eval-when-compile (verilog-regexp-words '("macromodule" "connectmodule" "module" "class" "program" "interface" "package" "primitive" "config"))))
(defconst verilog-end-defun-re
(eval-when-compile (verilog-regexp-words '("endconnectmodule" "endmodule" "endclass" "endprogram" "endinterface" "endpackage" "endprimitive" "endconfig"))))
+(defconst verilog-defun-tf-re-beg
+ (eval-when-compile (verilog-regexp-words '("macromodule" "connectmodule" "module" "class" "program" "interface" "package" "primitive" "config" "function" "task"))))
+(defconst verilog-defun-tf-re-end
+ (eval-when-compile (verilog-regexp-words '("endconnectmodule" "endmodule" "endclass" "endprogram" "endinterface" "endpackage" "endprimitive" "endconfig" "endfunction" "endtask"))))
+(defconst verilog-defun-tf-re-all
+ (eval-when-compile (verilog-regexp-words '("macromodule" "connectmodule" "module" "class" "program" "interface" "package" "primitive" "config" "function" "task"
+ "endconnectmodule" "endmodule" "endclass" "endprogram" "endinterface" "endpackage" "endprimitive" "endconfig" "endfunction" "endtask"))))
+(defconst verilog-defun-no-class-re
+ (eval-when-compile (verilog-regexp-words '("macromodule" "connectmodule" "module" "program" "interface" "package" "primitive" "config"))))
+(defconst verilog-end-defun-no-class-re
+ (eval-when-compile (verilog-regexp-words '("endconnectmodule" "endmodule" "endprogram" "endinterface" "endpackage" "endprimitive" "endconfig"))))
(defconst verilog-zero-indent-re
(concat verilog-defun-re "\\|" verilog-end-defun-re))
+(defconst verilog-zero-indent-no-class-re
+ (concat verilog-defun-no-class-re "\\|" verilog-end-defun-no-class-re))
(defconst verilog-inst-comment-re
(eval-when-compile (verilog-regexp-words '("Outputs" "Inouts" "Inputs" "Interfaces" "Interfaced"))))
@@ -2983,19 +3060,38 @@ find the errors."
(defconst verilog-extended-case-re "\\(\\(unique0?\\s-+\\|priority\\s-+\\)?case[xz]?\\|randcase\\)")
(defconst verilog-extended-complete-re
;; verilog-beg-of-statement also looks backward one token to extend this match
- (concat "\\(\\(\\<extern\\s-+\\|\\<\\(\\<\\(pure\\|context\\)\\>\\s-+\\)?virtual\\s-+\\|\\<protected\\s-+\\|\\<static\\s-+\\)*\\(\\<function\\>\\|\\<task\\>\\)\\)"
+ (concat "\\(\\(\\<extern\\s-+\\|\\<\\(\\<\\(pure\\|context\\)\\>\\s-+\\)?virtual\\s-+\\|\\<local\\s-+\\|\\<protected\\s-+\\|\\<static\\s-+\\)*\\(\\<function\\>\\|\\<task\\>\\)\\)"
"\\|\\(\\(\\<typedef\\>\\s-+\\)*\\(\\<struct\\>\\|\\<union\\>\\|\\<class\\>\\)\\)"
"\\|\\(\\(\\<\\(import\\|export\\)\\>\\s-+\\)?\\(\"DPI\\(-C\\)?\"\\s-+\\)?\\(\\<\\(pure\\|context\\)\\>\\s-+\\)?\\([A-Za-z_][A-Za-z0-9_]*\\s-*=\\s-*\\)?\\(function\\>\\|task\\>\\)\\)"
"\\|" verilog-extended-case-re ))
+
+(eval-and-compile
+ (defconst verilog-basic-complete-words
+ '("always" "assign" "always_latch" "always_ff" "always_comb" "analog" "connectmodule" "constraint"
+ "import" "initial" "final" "module" "macromodule" "repeat" "randcase" "while"
+ "if" "for" "forever" "foreach" "else" "parameter" "do" "localparam" "assert" "default" "generate"))
+ (defconst verilog-basic-complete-words-expr
+ (let ((words verilog-basic-complete-words))
+ (dolist (word '("default" "parameter" "localparam"))
+ (setq words (remove word words)))
+ words))
+ (defconst verilog-basic-complete-words-expr-no-assign
+ (remove "assign" verilog-basic-complete-words-expr)))
+
(defconst verilog-basic-complete-re
(eval-when-compile
- (verilog-regexp-words
- '(
- "always" "assign" "always_latch" "always_ff" "always_comb" "analog" "connectmodule" "constraint"
- "import" "initial" "final" "module" "macromodule" "repeat" "randcase" "while"
- "if" "for" "forever" "foreach" "else" "parameter" "do" "localparam" "assert"
- ))))
-(defconst verilog-complete-reg
+ (verilog-regexp-words verilog-basic-complete-words)))
+
+(defconst verilog-basic-complete-expr-re
+ (eval-when-compile
+ (verilog-regexp-words verilog-basic-complete-words-expr)))
+
+(defconst verilog-basic-complete-expr-no-assign-re
+ (eval-when-compile
+ (verilog-regexp-words verilog-basic-complete-words-expr-no-assign)))
+
+
+(defconst verilog-complete-re
(concat
verilog-extended-complete-re "\\|\\(" verilog-basic-complete-re "\\)"))
@@ -3114,9 +3210,6 @@ find the errors."
))
"List of Verilog keywords.")
-(defconst verilog-comment-start-regexp "//\\|/\\*"
- "Dual comment value for `comment-start-regexp'.")
-
(defvar verilog-mode-syntax-table
(let ((table (make-syntax-table)))
;; Populate the syntax TABLE.
@@ -3338,12 +3431,12 @@ See also `verilog-font-lock-extra-types'.")
(list
"\\<\\(\\(macro\\|connect\\)?module\\|primitive\\|class\\|program\\|interface\\|package\\|task\\)\\>\\s-*\\(\\sw+\\)"
'(1 font-lock-keyword-face)
- '(3 font-lock-function-name-face prepend))
+ '(3 font-lock-function-name-face))
;; Fontify function definitions
(list
(concat "\\<function\\>\\s-+\\(integer\\|real\\(time\\)?\\|time\\)\\s-+\\(\\sw+\\)" )
'(1 font-lock-keyword-face)
- '(3 font-lock-constant-face prepend))
+ '(3 font-lock-constant-face))
'("\\<function\\>\\s-+\\(\\[[^]]+\\]\\)\\s-+\\(\\sw+\\)"
(1 font-lock-keyword-face)
(2 font-lock-constant-face append))
@@ -3358,12 +3451,12 @@ See also `verilog-font-lock-extra-types'.")
;; Pre-form for this anchored matcher:
;; First, avoid declaration keywords written in comments,
;; which can also trigger this anchor.
- '(if (not (verilog-in-comment-p))
+ '(if (and (not (verilog-in-comment-p))
+ (not (member (thing-at-point 'symbol) verilog-keywords)))
(verilog-single-declaration-end verilog-highlight-max-lookahead)
(point)) ;; => current declaration statement is of 0 length
nil ;; Post-form: nothing to be done
- '(0 font-lock-variable-name-face t t)))
- )))
+ '(0 font-lock-variable-name-face))))))
(setq verilog-font-lock-keywords-2
@@ -3617,7 +3710,7 @@ inserted using a single call to `verilog-insert'."
(defun verilog-single-declaration-end (limit)
"Return pos where current (single) declaration statement ends.
Also, this function moves POINT forward to the start of a variable name
-(skipping the range-part and whitespace).
+\(skipping the range-part and whitespace).
Function expected to be called with POINT just after a declaration keyword.
LIMIT sets the max POINT for searching and moving to. No such limit if LIMIT
is 0.
@@ -3629,8 +3722,6 @@ Meaning of *single* declaration:
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)
;; maxpoint = min(curr-point + limit, buffer-size)
(setq maxpoint (if (eq limit 0)
@@ -3651,7 +3742,7 @@ POINT is moved to `y'."
(not (eq old-point (point)))
(not (eq (char-after) ?\; ))
(not (eq (char-after) ?\) ))
- (not (looking-at verilog-declaration-re)))
+ (not (looking-at (verilog-get-declaration-re))))
(setq old-point (point))
(ignore-errors
(forward-sexp)
@@ -3669,31 +3760,28 @@ This function moves POINT to the next variable within the same declaration (if
it exists).
LIMIT is expected to be the pos at which current single-declaration ends,
obtained using `verilog-single-declaration-end'."
-
- (let (found-var old-point)
-
- ;; Remove starting whitespace
- (verilog-forward-ws&directives limit)
-
- (when (< (point) limit) ;; no matching if this is violated
-
- ;; Find the variable name (match-data is set here)
- (setq found-var (re-search-forward verilog-symbol-re limit t))
-
- ;; Walk to this variable's delimiter
- (save-match-data
- (verilog-forward-ws&directives limit)
- (setq old-point nil)
- (while (and (< (point) limit)
- (not (member (char-after) '(?, ?\) ?\;)))
- (not (eq old-point (point))))
- (setq old-point (point))
+ (when (and verilog-fontify-variables
+ (not (member (thing-at-point 'symbol) verilog-keywords)))
+ (let (found-var old-point)
+ ;; Remove starting whitespace
+ (verilog-forward-ws&directives limit)
+ (when (< (point) limit) ;; no matching if this is violated
+ ;; Find the variable name (match-data is set here)
+ (setq found-var (re-search-forward verilog-identifier-sym-re limit t))
+ ;; Walk to this variable's delimiter
+ (save-match-data
(verilog-forward-ws&directives limit)
- (forward-sexp)
- (verilog-forward-ws&directives limit))
- ;; Only a comma or semicolon expected at this point
- (skip-syntax-forward "."))
- found-var)))
+ (setq old-point nil)
+ (while (and (< (point) limit)
+ (not (member (char-after) '(?, ?\) ?\] ?\} ?\;)))
+ (not (eq old-point (point))))
+ (setq old-point (point))
+ (verilog-forward-ws&directives limit)
+ (forward-sexp)
+ (verilog-forward-ws&directives limit))
+ ;; Only a comma or semicolon expected at this point
+ (skip-syntax-forward "."))
+ found-var))))
(defun verilog-point-text (&optional pointnum)
"Return text describing where POINTNUM or current point is (for errors).
@@ -3728,9 +3816,14 @@ Use filename, if current buffer being edited shorten to just buffer name."
(elsec 1)
(found nil)
(st (point)))
- (if (not (looking-at "\\<"))
- (forward-word-strictly -1))
+ (unless (looking-at "\\<")
+ (forward-word-strictly -1))
(cond
+ ((save-excursion
+ (goto-char st)
+ (member (preceding-char) '(?\) ?\} ?\])))
+ (goto-char st)
+ (backward-sexp 1))
((verilog-skip-backward-comment-or-string))
((looking-at "\\<else\\>")
(setq reg (concat
@@ -3754,7 +3847,17 @@ Use filename, if current buffer being edited shorten to just buffer name."
(setq found 't))))))
((looking-at verilog-end-block-re)
(verilog-leap-to-head))
- ((looking-at "\\(endmodule\\>\\)\\|\\(\\<endprimitive\\>\\)\\|\\(\\<endclass\\>\\)\\|\\(\\<endprogram\\>\\)\\|\\(\\<endinterface\\>\\)\\|\\(\\<endpackage\\>\\)\\|\\(\\<endconnectmodule\\>\\)")
+ (;; Fallback, when current word does not match `verilog-end-block-re'
+ (looking-at (concat
+ "\\(\\<endmodule\\>\\)\\|" ; 1
+ "\\(\\<endprimitive\\>\\)\\|" ; 2
+ "\\(\\<endclass\\>\\)\\|" ; 3
+ "\\(\\<endprogram\\>\\)\\|" ; 4
+ "\\(\\<endinterface\\>\\)\\|" ; 5
+ "\\(\\<endpackage\\>\\)\\|" ; 6
+ "\\(\\<endconnectmodule\\>\\)\\|" ; 7
+ "\\(\\<endchecker\\>\\)\\|" ; 8
+ "\\(\\<endconfig\\>\\)")) ; 9
(cond
((match-end 1)
(verilog-re-search-backward "\\<\\(macro\\)?module\\>" nil 'move))
@@ -3769,7 +3872,11 @@ Use filename, if current buffer being edited shorten to just buffer name."
((match-end 6)
(verilog-re-search-backward "\\<package\\>" nil 'move))
((match-end 7)
- (verilog-re-search-backward "\\<connectmodule\\>" nil 'move))
+ (verilog-re-search-backward "\\<connectmodule\\>" nil 'move))
+ ((match-end 8)
+ (verilog-re-search-backward "\\<checker\\>" nil 'move))
+ ((match-end 9)
+ (verilog-re-search-backward "\\<config\\>" nil 'move))
(t
(goto-char st)
(backward-sexp 1))))
@@ -3782,9 +3889,14 @@ Use filename, if current buffer being edited shorten to just buffer name."
(md 2)
(st (point))
(nest 'yes))
- (if (not (looking-at "\\<"))
- (forward-word-strictly -1))
+ (unless (looking-at "\\<")
+ (forward-word-strictly -1))
(cond
+ ((save-excursion
+ (goto-char st)
+ (member (following-char) '(?\( ?\{ ?\[)))
+ (goto-char st)
+ (forward-sexp 1))
((verilog-skip-forward-comment-or-string)
(verilog-forward-syntactic-ws))
((looking-at verilog-beg-block-re-ordered)
@@ -3843,22 +3955,31 @@ Use filename, if current buffer being edited shorten to just buffer name."
;; Search forward for matching endtask
(setq reg "\\<endtask\\>" )
(setq nest 'no))
- ((match-end 12)
+ ((match-end 13)
;; Search forward for matching endgenerate
(setq reg "\\(\\<generate\\>\\)\\|\\(\\<endgenerate\\>\\)" ))
- ((match-end 13)
+ ((match-end 14)
;; Search forward for matching endgroup
(setq reg "\\(\\<covergroup\\>\\)\\|\\(\\<endgroup\\>\\)" ))
- ((match-end 14)
+ ((match-end 15)
;; Search forward for matching endproperty
(setq reg "\\(\\<property\\>\\)\\|\\(\\<endproperty\\>\\)" ))
- ((match-end 15)
+ ((match-end 16)
;; Search forward for matching endsequence
(setq reg "\\(\\<\\(rand\\)?sequence\\>\\)\\|\\(\\<endsequence\\>\\)" )
(setq md 3)) ; 3 to get to endsequence in the reg above
((match-end 17)
;; Search forward for matching endclocking
- (setq reg "\\(\\<clocking\\>\\)\\|\\(\\<endclocking\\>\\)" )))
+ (setq reg "\\(\\<clocking\\>\\)\\|\\(\\<endclocking\\>\\)" ))
+ ((match-end 20)
+ ;; Search forward for matching `ifn?def, can be `else `elseif or `endif
+ (setq reg "\\(\\<`ifn?def\\>\\)\\|\\(\\<`endif\\>\\|\\<`else\\>\\|\\<`elsif\\>\\)" ))
+ ((match-end 21)
+ ;; Search forward for matching `else, can be `endif
+ (setq reg "\\(\\<`else\\>\\|\\<`ifn?def\\>\\)\\|\\(\\<`endif\\>\\)" ))
+ ((match-end 22)
+ ;; Search forward for matching `elsif, can be `else or `endif, DONT support `elsif
+ (setq reg "\\(\\<`elsif\\>\\|\\<`ifn?def\\>\\)\\|\\(\\<`endif\\>\\|\\<`else\\>\\)" )))
(if (and reg
(forward-word-strictly 1))
(catch 'skip
@@ -3867,15 +3988,26 @@ Use filename, if current buffer being edited shorten to just buffer name."
here)
(while (verilog-re-search-forward reg nil 'move)
(cond
- ((match-end md) ; a closer in regular expression, so we are climbing out
+ ((and (or (match-end md)
+ (and (member (match-string-no-properties 1) '("`else" "`elsif"))
+ (= 1 depth)))
+ (or (and (member (match-string-no-properties 2) '("`else" "`elsif"))
+ (= 1 depth))
+ ;; stop at `else/`elsif which matching ifn?def (or `elsif with same depth)
+ ;; a closer in regular expression, so we are climbing out
+ (not (member (match-string-no-properties 2) '("`else" "`elsif")))))
(setq depth (1- depth))
(if (= 0 depth) ; we are out!
(throw 'skip 1)))
- ((match-end 1) ; an opener in the r-e, so we are in deeper now
+ ((and (match-end 1) ; an opener in the r-e, so we are in deeper now
+ (not (member (match-string-no-properties 1) '("`else" "`elsif"))))
(setq here (point)) ; remember where we started
(goto-char (match-beginning 1))
(cond
- ((if (or
+ ((verilog-looking-back "\\(\\<typedef\\>\\s-+\\)" (point-at-bol))
+ ;; avoid nesting for typedef class defs
+ (forward-word-strictly 1))
+ ((if (or
(looking-at verilog-disable-fork-re)
(and (looking-at "fork")
(progn
@@ -3890,28 +4022,37 @@ Use filename, if current buffer being edited shorten to just buffer name."
(throw 'skip 1))))))
((looking-at (concat
- "\\(\\<\\(macro\\)?module\\>\\)\\|"
- "\\(\\<primitive\\>\\)\\|"
- "\\(\\<class\\>\\)\\|"
- "\\(\\<program\\>\\)\\|"
- "\\(\\<interface\\>\\)\\|"
- "\\(\\<package\\>\\)\\|"
- "\\(\\<connectmodule\\>\\)"))
+ "\\(\\<\\(macro\\)?module\\>\\)\\|" ; 1,2
+ "\\(\\<primitive\\>\\)\\|" ; 3
+ "\\(\\(\\(interface\\|virtual\\)\\s-+\\)?\\<class\\>\\)\\|" ; 4,5,6
+ "\\(\\<program\\>\\)\\|" ; 7
+ "\\(\\<interface\\>\\)\\|" ; 8
+ "\\(\\<package\\>\\)\\|" ; 9
+ "\\(\\<connectmodule\\>\\)\\|" ; 10
+ "\\(\\<generate\\>\\)\\|" ; 11
+ "\\(\\<checker\\>\\)\\|" ; 12
+ "\\(\\<config\\>\\)")) ; 13
(cond
((match-end 1)
(verilog-re-search-forward "\\<endmodule\\>" nil 'move))
- ((match-end 2)
- (verilog-re-search-forward "\\<endprimitive\\>" nil 'move))
((match-end 3)
- (verilog-re-search-forward "\\<endclass\\>" nil 'move))
+ (verilog-re-search-forward "\\<endprimitive\\>" nil 'move))
((match-end 4)
+ (verilog-re-search-forward "\\<endclass\\>" nil 'move))
+ ((match-end 7)
(verilog-re-search-forward "\\<endprogram\\>" nil 'move))
- ((match-end 5)
+ ((match-end 8)
(verilog-re-search-forward "\\<endinterface\\>" nil 'move))
- ((match-end 6)
+ ((match-end 9)
(verilog-re-search-forward "\\<endpackage\\>" nil 'move))
- ((match-end 7)
- (verilog-re-search-forward "\\<endconnectmodule\\>" nil 'move))
+ ((match-end 10)
+ (verilog-re-search-forward "\\<endconnectmodule\\>" nil 'move))
+ ((match-end 11)
+ (verilog-re-search-forward "\\<endgenerate\\>" nil 'move))
+ ((match-end 12)
+ (verilog-re-search-forward "\\<endchecker\\>" nil 'move))
+ ((match-end 13)
+ (verilog-re-search-forward "\\<endconfig\\>" nil 'move))
(t
(goto-char st)
(if (= (following-char) ?\) )
@@ -3924,11 +4065,69 @@ Use filename, if current buffer being edited shorten to just buffer name."
(forward-sexp 1))))))
(defun verilog-declaration-beg ()
- (verilog-re-search-backward verilog-declaration-re (bobp) t))
-
-;;
-;;
-;; Mode
+ (verilog-re-search-backward (verilog-get-declaration-re) (bobp) t))
+
+(defun verilog-align-typedef-enabled-p ()
+ "Return non-nil if alignment of user typedefs is enabled.
+This will be automatically set when either `verilog-align-typedef-regexp'
+or `verilog-align-typedef-words' are non-nil."
+ (when (or verilog-align-typedef-regexp
+ verilog-align-typedef-words)
+ t))
+
+(defun verilog-get-declaration-typedef-re ()
+ "Return regexp of a user defined typedef.
+See `verilog-align-typedef-regexp' and `verilog-align-typedef-words'."
+ (let (typedef-re words words-re re)
+ (when (verilog-align-typedef-enabled-p)
+ (setq typedef-re verilog-align-typedef-regexp)
+ (setq words verilog-align-typedef-words)
+ (setq words-re (verilog-regexp-words verilog-align-typedef-words))
+ (cond ((and typedef-re (not words))
+ (setq re typedef-re))
+ ((and (not typedef-re) words)
+ (setq re words-re))
+ ((and typedef-re words)
+ (setq re (concat verilog-align-typedef-regexp "\\|" words-re))))
+ (concat "\\s-*" "\\(" verilog-declaration-prefix-re "\\s-*\\(" verilog-range-re "\\)?" "\\s-*\\)?"
+ (concat "\\(" re "\\)")
+ "\\(\\s-*" verilog-range-re "\\)?\\s-+"))))
+
+(defun verilog-get-declaration-re (&optional type)
+ "Return declaration regexp depending on customizable variables and TYPE."
+ (let ((re (cond ((equal type 'iface-mp)
+ verilog-declaration-or-iface-mp-re)
+ ((equal type 'embedded-comments)
+ verilog-declaration-embedded-comments-re)
+ (verilog-indent-declaration-macros
+ verilog-declaration-re-macro)
+ (t
+ verilog-declaration-re))))
+ (when (and (verilog-align-typedef-enabled-p)
+ (or (string= re verilog-declaration-or-iface-mp-re)
+ (string= re verilog-declaration-re)))
+ (setq re (concat "\\(" (verilog-get-declaration-typedef-re) "\\)\\|\\(" re "\\)")))
+ re))
+
+(defun verilog-looking-at-decl-to-align ()
+ "Return non-nil if pointing at a Verilog variable declaration that must be aligned."
+ (let* ((re (verilog-get-declaration-re))
+ (valid-re (looking-at re))
+ (id-pos (match-end 0)))
+ (and valid-re
+ (not (verilog-at-struct-decl-p))
+ (not (verilog-at-enum-decl-p))
+ (save-excursion
+ (goto-char id-pos)
+ (verilog-forward-syntactic-ws)
+ (and (not (looking-at ";"))
+ (not (member (thing-at-point 'symbol) verilog-keywords))
+ (progn ; Avoid alignment of instances whose name match user defined types
+ (forward-word)
+ (verilog-forward-syntactic-ws)
+ (not (looking-at "("))))))))
+
+;;; Mode:
;;
(defvar verilog-which-tool 1)
;;;###autoload
@@ -3965,6 +4164,11 @@ Variables controlling indentation/edit style:
function keyword.
`verilog-indent-level-directive' (default 1)
Indentation of \\=`ifdef/\\=`endif blocks.
+ `verilog-indent-ignore-multiline-defines' (default t)
+ Non-nil means ignore indentation on lines that are part of a multiline
+ define.
+ `verilog-indent-ignore-regexp' (default nil
+ Regexp that matches lines that should be ignored for indentation.
`verilog-cexp-indent' (default 1)
Indentation of Verilog statements broken across lines i.e.:
if (a)
@@ -3988,6 +4192,9 @@ Variables controlling indentation/edit style:
otherwise you get:
if (a)
begin
+ `verilog-indent-class-inside-pkg' (default t)
+ Non-nil means indent classes inside packages.
+ Otherwise, classes have zero indentation.
`verilog-auto-endcomments' (default t)
Non-nil means a comment /* ... */ is set after the ends which ends
cases, tasks, functions and modules.
@@ -3997,6 +4204,17 @@ Variables controlling indentation/edit style:
will be inserted. Setting this variable to zero results in every
end acquiring a comment; the default avoids too many redundant
comments in tight quarters.
+ `verilog-align-decl-expr-comments' (default t)
+ Non-nil means align declaration and expressions comments.
+ `verilog-align-comment-distance' (default 1)
+ Distance (in spaces) between longest declaration and comments.
+ Only works if `verilog-align-decl-expr-comments' is non-nil.
+ `verilog-align-assign-expr' (default nil)
+ Non-nil means align expressions of continuous assignments.
+ `verilog-align-typedef-regexp' (default nil)
+ Regexp that matches user typedefs for declaration alignment.
+ `verilog-align-typedef-words' (default nil)
+ List of words that match user typedefs for declaration alignment.
`verilog-auto-lineup' (default `declarations')
List of contexts where auto lineup of code should be done.
@@ -4020,17 +4238,20 @@ Some other functions are:
\\[verilog-mark-defun] Mark function.
\\[verilog-beg-of-defun] Move to beginning of current function.
\\[verilog-end-of-defun] Move to end of current function.
- \\[verilog-label-be] Label matching begin ... end, fork ... join, etc statements.
+ \\[verilog-label-be] Label matching begin ... end, fork ... join, etc
+ statements.
\\[verilog-comment-region] Put marked area in a comment.
- \\[verilog-uncomment-region] Uncomment an area commented with \\[verilog-comment-region].
+ \\[verilog-uncomment-region] Uncomment an area commented with
+ \\[verilog-comment-region].
\\[verilog-insert-block] Insert begin ... end.
\\[verilog-star-comment] Insert /* ... */.
\\[verilog-sk-always] Insert an always @(AS) begin .. end block.
\\[verilog-sk-begin] Insert a begin .. end block.
\\[verilog-sk-case] Insert a case block, prompting for details.
- \\[verilog-sk-for] Insert a for (...) begin .. end block, prompting for details.
+ \\[verilog-sk-for] Insert a for (...) begin .. end block, prompting for
+ details.
\\[verilog-sk-generate] Insert a generate .. endgenerate block.
\\[verilog-sk-header] Insert a header block at the top of file.
\\[verilog-sk-initial] Insert an initial begin .. end block.
@@ -4053,14 +4274,17 @@ Some other functions are:
\\[verilog-sk-else-if] Insert an else if (..) begin .. end block.
\\[verilog-sk-comment] Insert a comment block.
\\[verilog-sk-assign] Insert an assign .. = ..; statement.
- \\[verilog-sk-function] Insert a function .. begin .. end endfunction block.
+ \\[verilog-sk-function] Insert a function .. begin .. end endfunction
+ block.
\\[verilog-sk-input] Insert an input declaration, prompting for details.
\\[verilog-sk-output] Insert an output declaration, prompting for details.
- \\[verilog-sk-state-machine] Insert a state machine definition, prompting for details.
+ \\[verilog-sk-state-machine] Insert a state machine definition, prompting
+ for details.
\\[verilog-sk-inout] Insert an inout declaration, prompting for details.
\\[verilog-sk-wire] Insert a wire declaration, prompting for details.
\\[verilog-sk-reg] Insert a register declaration, prompting for details.
- \\[verilog-sk-define-signal] Define signal under point as a register at the top of the module.
+ \\[verilog-sk-define-signal] Define signal under point as a register at
+ the top of the module.
All key bindings can be seen in a Verilog-buffer with \\[describe-bindings].
Key bindings specific to `verilog-mode-map' are:
@@ -4147,7 +4371,7 @@ Key bindings specific to `verilog-mode-map' are:
;; verilog-mode-hook call added by define-derived-mode
)
-;;; Integration with the speedbar
+;;; Integration with the speedbar:
;;
;; Avoid problems with XEmacs byte-compiles.
@@ -4427,15 +4651,24 @@ following code fragment:
"Mark the current Verilog function (or procedure).
This puts the mark at the end, and point at the beginning."
(interactive)
- (if (featurep 'xemacs)
- (progn
- (push-mark)
- (verilog-end-of-defun)
- (push-mark)
- (verilog-beg-of-defun)
- (if (fboundp 'zmacs-activate-region)
- (zmacs-activate-region)))
- (mark-defun)))
+ (let (found)
+ (if (featurep 'xemacs)
+ (progn
+ (push-mark)
+ (verilog-end-of-defun)
+ (push-mark)
+ (verilog-beg-of-defun)
+ (if (fboundp 'zmacs-activate-region)
+ (zmacs-activate-region)))
+ ;; GNU Emacs
+ (when (verilog-beg-of-defun)
+ (setq found (point))
+ (verilog-end-of-defun)
+ (end-of-line)
+ (push-mark)
+ (goto-char found)
+ (beginning-of-line)
+ (setq mark-active t)))))
(defun verilog-comment-region (start end)
;; checkdoc-params: (start end)
@@ -4514,7 +4747,21 @@ area. See also `verilog-comment-region'."
(defun verilog-beg-of-defun ()
"Move backward to the beginning of the current function or procedure."
(interactive)
- (verilog-re-search-backward verilog-defun-re nil 'move))
+ (let (found)
+ (save-excursion
+ (when (verilog-looking-back verilog-defun-tf-re-end (point-at-bol))
+ (verilog-backward-sexp)
+ (setq found (point)))
+ (while (and (not found)
+ (verilog-re-search-backward verilog-defun-tf-re-all nil t))
+ (cond ((verilog-looking-back "\\(\\<typedef\\>\\s-+\\)" (point-at-bol)) ; corner case, e.g. 'typedef class <id>;'
+ (backward-word))
+ ((looking-at verilog-defun-tf-re-end)
+ (verilog-backward-sexp))
+ ((looking-at verilog-defun-tf-re-beg)
+ (setq found (point))))))
+ (when found
+ (goto-char found))))
(defun verilog-beg-of-defun-quick ()
"Move backward to the beginning of the current function or procedure.
@@ -4525,7 +4772,10 @@ Uses `verilog-scan' cache."
(defun verilog-end-of-defun ()
"Move forward to the end of the current function or procedure."
(interactive)
- (verilog-re-search-forward verilog-end-defun-re nil 'move))
+ (when (or (looking-at verilog-defun-tf-re-beg)
+ (verilog-beg-of-defun))
+ (verilog-forward-sexp)
+ (point)))
(defun verilog-get-end-of-defun ()
(save-excursion
@@ -4542,10 +4792,10 @@ Uses `verilog-scan' cache."
(case-fold-search nil)
(oldpos (point))
(b (progn
- (verilog-beg-of-defun)
+ (verilog-re-search-backward verilog-defun-re nil 'move)
(point-marker)))
(e (progn
- (verilog-end-of-defun)
+ (verilog-re-search-forward verilog-end-defun-re nil 'move)
(point-marker))))
(goto-char (marker-position b))
(if (> (- e b) 200)
@@ -4594,7 +4844,7 @@ Uses `verilog-scan' cache."
(not (or (looking-at "\\<") (forward-word-strictly -1)))
;; stop if we see an assertion (perhaps labeled)
(and
- (looking-at "\\(\\w+\\W*:\\W*\\)?\\(\\<\\(assert\\|assume\\|cover\\)\\>\\s-+\\<property\\>\\)\\|\\(\\<assert\\>\\)")
+ (looking-at (concat "\\(\\w+\\W*:\\W*\\)?" verilog-concurrent-assertion-statement-re))
(progn
(setq h (point))
(save-excursion
@@ -4605,19 +4855,18 @@ Uses `verilog-scan' cache."
(goto-char h)))
;; stop if we see an extended complete reg, perhaps a complete one
(and
- (looking-at verilog-complete-reg)
+ (looking-at verilog-complete-re)
(let* ((p (point)))
(while (and (looking-at verilog-extended-complete-re)
(progn (setq p (point))
(verilog-backward-token)
(/= p (point)))))
(goto-char p)))
- ;; stop if we see a complete reg (previous found extended ones)
- (looking-at verilog-basic-complete-re)
;; stop if previous token is an ender
(save-excursion
(verilog-backward-token)
- (looking-at verilog-end-block-re))))
+ (or (looking-at verilog-end-block-re)
+ (verilog-in-directive-p)))))
(verilog-backward-syntactic-ws)
(verilog-backward-token))
;; Now point is where the previous line ended.
@@ -4634,28 +4883,23 @@ Uses `verilog-scan' cache."
(verilog-backward-syntactic-ws))
(let ((pt (point)))
(catch 'done
- (while (not (looking-at verilog-complete-reg))
+ (while (not (looking-at verilog-complete-re))
(setq pt (point))
(verilog-backward-syntactic-ws)
(if (or (bolp)
(= (preceding-char) ?\;)
+ (and (= (preceding-char) ?\{)
+ (save-excursion
+ (backward-char)
+ (verilog-at-struct-p)))
(progn
(verilog-backward-token)
- (looking-at verilog-ends-re)))
+ (or (looking-at verilog-ends-re)
+ (looking-at "begin"))))
(progn
(goto-char pt)
(throw 'done t)))))
(verilog-forward-syntactic-ws)))
-;;
-;; (while (and
-;; (not (looking-at verilog-complete-reg))
-;; (not (bolp))
-;; (not (= (preceding-char) ?\;)))
-;; (verilog-backward-token)
-;; (verilog-backward-syntactic-ws)
-;; (setq pt (point)))
-;; (goto-char pt)
-;; ;(verilog-forward-syntactic-ws)
(defun verilog-end-of-statement ()
"Move forward to end of current statement."
@@ -4713,7 +4957,7 @@ Uses `verilog-scan' cache."
pos)))))
(defun verilog-in-case-region-p ()
- "Return true if in a case region.
+ "Return non-nil if in a case region.
More specifically, point @ in the line foo : @ begin"
(interactive)
(save-excursion
@@ -4727,7 +4971,7 @@ More specifically, point @ in the line foo : @ begin"
(while t
(verilog-re-search-backward
(concat "\\(\\<module\\>\\)\\|\\(\\<connectmodule\\>\\)\\|\\(\\<randcase\\>\\|\\<case[xz]?\\>[^:]\\)\\|"
- "\\(\\<endcase\\>\\)\\>")
+ "\\(\\<endcase\\>\\)")
nil 'move)
(cond
((match-end 4)
@@ -4758,7 +5002,7 @@ More specifically, point @ in the line foo : @ begin"
(forward-sexp arg)))
(defun verilog-in-generate-region-p ()
- "Return true if in a generate region.
+ "Return non-nil if in a generate region.
More specifically, after a generate and before an endgenerate."
(interactive)
(let ((nest 1))
@@ -4767,33 +5011,35 @@ More specifically, after a generate and before an endgenerate."
(while (and
(/= nest 0)
(verilog-re-search-backward
- "\\<\\(module\\)\\|\\(connectmodule\\)\\|\\(generate\\)\\|\\(endgenerate\\)\\|\\(if\\)\\|\\(case\\)\\|\\(for\\)\\>" nil 'move)
+ "\\<\\(?:\\(module\\)\\|\\(connectmodule\\)\\|\\(endmodule\\)\\|\\(generate\\)\\|\\(endgenerate\\)\\|\\(if\\)\\|\\(case\\)\\|\\(for\\)\\)\\>" nil 'move)
(cond
((match-end 1) ; module - we have crawled out
(throw 'done 1))
- ((match-end 2) ; connectmodule - we have crawled out
- (throw 'done 1))
- ((match-end 3) ; generate
+ ((match-end 2) ; connectmodule - we have crawled out
+ (throw 'done 1))
+ ((match-end 3) ; endmodule - we were outside of module block
+ (throw 'done -1))
+ ((match-end 4) ; generate
(setq nest (1- nest)))
- ((match-end 4) ; endgenerate
- (setq nest (1+ nest)))
- ((match-end 5) ; if
- (setq nest (1- nest)))
- ((match-end 6) ; case
- (setq nest (1- nest)))
- ((match-end 7) ; for
- (setq nest (1- nest))))))))
+ ((match-end 5) ; endgenerate
+ (setq nest (1+ nest)))
+ ((match-end 6) ; if
+ (setq nest (1- nest)))
+ ((match-end 7) ; case
+ (setq nest (1- nest)))
+ ((match-end 8) ; for
+ (setq nest (1- nest))))))))
(= nest 0) )) ; return nest
(defun verilog-in-fork-region-p ()
- "Return true if between a fork and join."
+ "Return non-nil if between a fork and join."
(interactive)
- (let ((lim (save-excursion (verilog-beg-of-defun) (point)))
+ (let ((lim (save-excursion (verilog-re-search-backward verilog-defun-re nil 'move) (point)))
(nest 1))
(save-excursion
(while (and
(/= nest 0)
- (verilog-re-search-backward "\\<\\(fork\\)\\|\\(join\\(_any\\|_none\\)?\\)\\>" lim 'move)
+ (verilog-re-search-backward "\\<\\(?:\\(fork\\)\\|\\(join\\(_any\\|_none\\)?\\)\\)\\>" lim 'move)
(cond
((match-end 1) ; fork
(setq nest (1- nest)))
@@ -4802,7 +5048,7 @@ More specifically, after a generate and before an endgenerate."
(= nest 0) )) ; return nest
(defun verilog-in-deferred-immediate-final-p ()
- "Return true if inside an `assert/assume/cover final' statement."
+ "Return non-nil if inside an `assert/assume/cover final' statement."
(interactive)
(and (looking-at "final")
(verilog-looking-back "\\<\\(?:assert\\|assume\\|cover\\)\\>\\s-+" nil))
@@ -5013,7 +5259,7 @@ primitive or interface named NAME."
(insert str)
(ding 't))
(let ((lim
- (save-excursion (verilog-beg-of-defun) (point)))
+ (save-excursion (verilog-re-search-backward verilog-defun-re nil 'move) (point)))
(here (point)))
(cond
(;-- handle named block differently
@@ -5090,7 +5336,7 @@ primitive or interface named NAME."
(match-end 3)
(goto-char there)
(let ((nest 0)
- (reg "\\(\\<begin\\>\\)\\|\\(\\<end\\>\\)\\|\\(\\<if\\>\\)\\|\\(assert\\)"))
+ (reg "\\(\\<begin\\>\\)\\|\\(\\<end\\>\\)\\|\\(\\<if\\>\\)\\|\\(\\<assert\\>\\)"))
(catch 'skip
(while (verilog-re-search-backward reg nil 'move)
(cond
@@ -5129,10 +5375,7 @@ primitive or interface named NAME."
(goto-char (match-end 0))
(setq there (point))
(setq err nil)
- (setq str (concat " // " cntx (verilog-get-expr))))
-
- (;-- otherwise...
- (setq str " // auto-endcomment confused "))))
+ (setq str (concat " // " cntx (verilog-get-expr))))))
((and
(verilog-in-case-region-p) ;-- handle case item differently
@@ -5461,7 +5704,7 @@ For example:
becomes:
// surefire lint_line_off UDDONX"
(interactive)
- (let ((buff (if (boundp 'next-error-last-buffer) ;Added to Emacs-22.1
+ (let ((buff (if (boundp 'next-error-last-buffer) ; Added to Emacs-22.1
next-error-last-buffer
(verilog--suppressed-warnings
((obsolete compilation-last-buffer))
@@ -5560,7 +5803,7 @@ FILENAME to find directory to run in, or defaults to `buffer-file-name'."
(dir (file-name-directory (or filename buffer-file-name)))
(cmd (concat "cd " dir "; " command)))
(with-output-to-temp-buffer "*Verilog-Preprocessed*"
- (with-current-buffer (get-buffer "*Verilog-Preprocessed*")
+ (with-current-buffer "*Verilog-Preprocessed*"
(insert (concat "// " cmd "\n"))
(call-process shell-file-name nil t nil shell-command-switch cmd)
(verilog-mode)
@@ -5585,13 +5828,14 @@ FILENAME to find directory to run in, or defaults to `buffer-file-name'."
(defun verilog-warn-error (string &rest args)
"Call `error' using STRING and optional ARGS.
If `verilog-warn-fatal' is non-nil, call `verilog-warn' instead."
- (apply (if verilog-warn-fatal #'error #'verilog-warn)
+ (apply (if (and verilog-warn-fatal verilog-warn-fatal-internal)
+ #'error #'verilog-warn)
string args))
(defmacro verilog-batch-error-wrapper (&rest body)
"Execute BODY and add error prefix to any errors found.
This lets programs calling batch mode to easily extract error messages."
- `(let ((verilog-warn-fatal nil))
+ `(let ((verilog-warn-fatal-internal nil))
(condition-case err
(progn ,@body)
(error
@@ -5721,7 +5965,7 @@ This sets up the appropriate Verilog mode environment, calls
(string . 0)))
(defun verilog-continued-line-1 (lim)
- "Return true if this is a continued line.
+ "Return non-nil if this is a continued line.
Set point to where line starts. Limit search to point LIM."
(let ((continued 't))
(if (eq 0 (forward-line -1))
@@ -5774,7 +6018,6 @@ Return a list of two elements: (INDENT-TYPE INDENT-LEVEL)."
;; if we are in a parenthesized list, and the user likes to indent these, return.
;; unless we are in the newfangled coverpoint or constraint blocks
(if (and
- verilog-indent-lists
(verilog-in-paren)
(not (verilog-in-coverage-p))
)
@@ -5791,7 +6034,7 @@ Return a list of two elements: (INDENT-TYPE INDENT-LEVEL)."
(looking-at verilog-in-constraint-re) )) ; may still get hosed if concat in constraint
(let ((sp (point)))
(if (and
- (not (looking-at verilog-complete-reg))
+ (not (looking-at verilog-complete-re))
(verilog-continued-line-1 lim))
(progn (goto-char sp)
(throw 'nesting 'cexp))
@@ -5996,7 +6239,13 @@ Return a list of two elements: (INDENT-TYPE INDENT-LEVEL)."
(goto-char here) ; or is clocking, starts a new block
(throw 'nesting 'block)))))
- ((looking-at "\\<class\\|struct\\|function\\|task\\>")
+ ;; if find `ifn?def `else `elsif
+ ((or (match-end 20)
+ (match-end 21)
+ (match-end 22))
+ (throw 'continue 'foo))
+
+ ((looking-at "\\<\\(?:class\\|struct\\|function\\|task\\)\\>")
;; *sigh* These words have an optional prefix:
;; extern {virtual|protected}? function a();
;; and we don't want to confuse this with
@@ -6020,12 +6269,16 @@ Return a list of two elements: (INDENT-TYPE INDENT-LEVEL)."
(throw 'nesting 'defun))))
;;
- ((looking-at "\\<property\\>")
+ ((looking-at "\\<\\(property\\|sequence\\)\\>")
;; *sigh*
- ;; {assert|assume|cover} property (); are complete
- ;; and could also be labeled: - foo: assert property
- ;; but
- ;; property ID () ... needs end_property
+ ;; - {assert|assume|cover|restrict} property (); are complete
+ ;; - cover sequence (); is complete
+ ;; and could also be labeled:
+ ;; - foo: assert property
+ ;; - bar: cover sequence
+ ;; but:
+ ;; - property ID () ... needs endproperty
+ ;; - sequence ID () ... needs endsequence
(verilog-beg-of-statement)
(if (looking-at verilog-property-re)
(throw 'continue 'statement) ; We don't need an endproperty for these
@@ -6110,6 +6363,23 @@ of the appropriate enclosing block."
(ding 't)
(setq nest 0))))))
+(defun verilog-leap-to-class-head ()
+ (let ((nest 1)
+ (class-re (concat "\\(\\<class\\>\\)\\|\\(\\<endclass\\>\\)")))
+ (catch 'skip
+ (while (verilog-re-search-backward class-re nil 'move)
+ (cond
+ ((match-end 1) ; begin
+ (when (verilog-looking-back "\\(\\<interface\\>\\s-+\\)\\|\\(\\<virtual\\>\\s-+\\)" (point-at-bol))
+ (goto-char (match-beginning 0)))
+ (unless (verilog-looking-back "\\<typedef\\>\\s-+" (point-at-bol))
+ (setq nest (1- nest))
+ (if (= 0 nest)
+ ;; Now previous line describes syntax
+ (throw 'skip 1))))
+ ((match-end 2) ; end
+ (setq nest (1+ nest))))))))
+
(defun verilog-leap-to-head ()
"Move point to the head of this block.
Jump from end to matching begin, from endcase to matching case, and so on."
@@ -6137,7 +6407,9 @@ Jump from end to matching begin, from endcase to matching case, and so on."
(setq reg "\\(\\<fork\\>\\)\\|\\(\\<join\\(_any\\|_none\\)?\\>\\)" ))
((looking-at "\\<endclass\\>")
;; 5: Search back for matching class
- (setq reg "\\(\\<class\\>\\)\\|\\(\\<endclass\\>\\)" ))
+ (catch 'nesting
+ (verilog-leap-to-class-head)
+ (setq reg nil)))
((looking-at "\\<endtable\\>")
;; 6: Search back for matching table
(setq reg "\\(\\<table\\>\\)\\|\\(\\<endtable\\>\\)" ))
@@ -6175,7 +6447,19 @@ Jump from end to matching begin, from endcase to matching case, and so on."
(setq reg "\\(\\<\\(rand\\)?sequence\\>\\)\\|\\(\\<endsequence\\>\\)" ))
((looking-at "\\<endclocking\\>")
;; 12: Search back for matching clocking
- (setq reg "\\(\\<clocking\\)\\|\\(\\<endclocking\\>\\)" )))
+ (setq reg "\\(\\<clocking\\)\\|\\(\\<endclocking\\>\\)" ))
+ ;; Search back for matching package
+ ((looking-at "\\<endpackage\\>")
+ (setq reg "\\(\\<package\\>\\)" ))
+ ;; Search back for matching program
+ ((looking-at "\\<endprogram\\>")
+ (setq reg "\\(\\<program\\>\\)" ))
+ ((looking-at "\\<`endif\\>")
+ ;; Search back for matching `endif `else `elsif
+ (setq reg "\\(\\<`ifn?def\\>\\)\\|\\(\\<`endif\\>\\)" ))
+ ((looking-at "\\<`else\\>")
+ ;; Search back for matching `else `else `elsif
+ (setq reg "\\(\\<`ifn?def\\>\\|\\<`elsif\\>\\)\\|\\(\\<`else\\>\\)" )))
(if reg
(catch 'skip
(if (eq nesting 'yes)
@@ -6221,7 +6505,7 @@ Jump from end to matching begin, from endcase to matching case, and so on."
(throw 'skip 1)))))))
(defun verilog-continued-line ()
- "Return true if this is a continued line.
+ "Return non-nil if this is a continued line.
Set point to where line starts."
(let ((continued 't))
(if (eq 0 (forward-line -1))
@@ -6394,10 +6678,10 @@ Optional BOUND limits search."
(let ((state (save-excursion (verilog-syntax-ppss))))
(cond
((nth 7 state) ; in // comment
- (verilog-re-search-backward "//" nil 'move)
+ (re-search-backward "//" nil 'move)
(skip-chars-backward "/"))
((nth 4 state) ; in /* */ comment
- (verilog-re-search-backward "/\\*" nil 'move))))
+ (re-search-backward "/\\*" nil 'move))))
(narrow-to-region bound (point))
(while (/= here (point))
(setq here (point))
@@ -6450,13 +6734,61 @@ Optional BOUND limits search."
(if jump
(beginning-of-line 2))))))))
+(defun verilog-pos-at-beg-of-statement ()
+ "Return point position at the beginning of current statement."
+ (save-excursion
+ (verilog-beg-of-statement)
+ (point)))
+
+(defun verilog-col-at-beg-of-statement ()
+ "Return current column at the beginning of current statement."
+ (save-excursion
+ (verilog-beg-of-statement)
+ (current-column)))
+
+(defun verilog-pos-at-end-of-statement ()
+ "Return point position at the end of current statement."
+ (save-excursion
+ (verilog-end-of-statement)
+ (point)))
+
+(defun verilog-col-at-end-of-statement ()
+ "Return current column at the end of current statement."
+ (save-excursion
+ (verilog-end-of-statement)
+ (current-column)))
+
+(defun verilog-pos-at-forward-syntactic-ws ()
+ "Return point position at next non whitespace/comment token."
+ (save-excursion
+ (verilog-forward-syntactic-ws)
+ (point)))
+
+(defun verilog-col-at-forward-syntactic-ws ()
+ "Return current column at next non whitespace/comment token."
+ (save-excursion
+ (verilog-forward-syntactic-ws)
+ (current-column)))
+
+(defun verilog-pos-at-backward-syntactic-ws ()
+ "Return point position at previous non whitespace/comment token."
+ (save-excursion
+ (verilog-backward-syntactic-ws)
+ (point)))
+
+(defun verilog-col-at-backward-syntactic-ws ()
+ "Return current column at previous non whitespace/comment token."
+ (save-excursion
+ (verilog-backward-syntactic-ws)
+ (current-column)))
+
(defun verilog-in-comment-p ()
- "Return true if in a star or // comment."
+ "Return non-nil if in a star or // comment."
(let ((state (save-excursion (verilog-syntax-ppss))))
(or (nth 4 state) (nth 7 state))))
(defun verilog-in-star-comment-p ()
- "Return true if in a star comment."
+ "Return non-nil if in a star comment."
(let ((state (save-excursion (verilog-syntax-ppss))))
(and
(nth 4 state) ; t if in a comment of style a // or b /**/
@@ -6465,40 +6797,39 @@ Optional BOUND limits search."
))))
(defun verilog-in-slash-comment-p ()
- "Return true if in a slash comment."
+ "Return non-nil if in a slash comment."
(let ((state (save-excursion (verilog-syntax-ppss))))
(nth 7 state)))
(defun verilog-in-comment-or-string-p ()
- "Return true if in a string or comment."
+ "Return non-nil if in a string or comment."
(let ((state (save-excursion (verilog-syntax-ppss))))
(or (nth 3 state) (nth 4 state) (nth 7 state)))) ; Inside string or comment)
(defun verilog-in-attribute-p ()
- "Return true if point is in an attribute (* [] attribute *)."
- (save-match-data
- (save-excursion
- (verilog-re-search-backward "\\((\\*\\)\\|\\(\\*)\\)" nil 'move)
- (cond
- ((match-end 1)
- (progn (goto-char (match-end 1))
- (not (looking-at "\\s-*)")))
- nil)
- ((match-end 2)
- (progn (goto-char (match-beginning 2))
- (not (looking-at "(\\s-*")))
- nil)
- (t nil)))))
+ "Return non-nil if point is in an attribute (* [] attribute *)."
+ (let ((pos (point)))
+ (save-match-data
+ (save-excursion
+ (and (verilog-re-search-backward "(\\*" nil 'move)
+ (progn (forward-sexp)
+ (skip-chars-backward "*)"))
+ (< pos (point)))))))
(defun verilog-in-parameter-p ()
- "Return true if point is in a parameter assignment #( p1=1, p2=5)."
+ "Return non-nil if point is in a parameter assignment #( p1=1, p2=5)."
(save-match-data
(save-excursion
- (verilog-re-search-backward "\\(#(\\)\\|\\()\\)" nil 'move)
- (numberp (match-beginning 1)))))
+ (and (progn
+ (verilog-backward-up-list 1)
+ (verilog-backward-syntactic-ws)
+ (= (preceding-char) ?\#))
+ (progn
+ (verilog-beg-of-statement-1)
+ (looking-at verilog-defun-re))))))
(defun verilog-in-escaped-name-p ()
- "Return true if in an escaped name."
+ "Return non-nil if in an escaped name."
(save-excursion
(backward-char)
(skip-chars-backward "^ \t\n\f")
@@ -6507,20 +6838,20 @@ Optional BOUND limits search."
nil)))
(defun verilog-in-directive-p ()
- "Return true if in a directive."
+ "Return non-nil if in a directive."
(save-excursion
(beginning-of-line)
(looking-at verilog-directive-re-1)))
(defun verilog-in-parenthesis-p ()
- "Return true if in a ( ) expression (but not { } or [ ])."
+ "Return non-nil if in a ( ) expression (but not { } or [ ])."
(save-match-data
(save-excursion
(verilog-re-search-backward "\\((\\)\\|\\()\\)" nil 'move)
(numberp (match-beginning 1)))))
(defun verilog-in-paren ()
- "Return true if in a parenthetical expression.
+ "Return non-nil if in a parenthetical expression.
May cache result using `verilog-syntax-ppss'."
(let ((state (save-excursion (verilog-syntax-ppss))))
(> (nth 0 state) 0 )))
@@ -6534,7 +6865,7 @@ May cache result using `verilog-syntax-ppss'."
0 )))
(defun verilog-in-paren-quick ()
- "Return true if in a parenthetical expression.
+ "Return non-nil if in a parenthetical expression.
Always starts from `point-min', to allow inserts with hooks disabled."
;; The -quick refers to its use alongside the other -quick functions,
;; not that it's likely to be faster than verilog-in-paren.
@@ -6542,7 +6873,7 @@ Always starts from `point-min', to allow inserts with hooks disabled."
(> (nth 0 state) 0 )))
(defun verilog-in-struct-p ()
- "Return true if in a struct declaration."
+ "Return non-nil if in a struct declaration."
(interactive)
(save-excursion
(if (verilog-in-paren)
@@ -6568,7 +6899,7 @@ Return >0 for nested struct."
nil))))
(defun verilog-in-coverage-p ()
- "Return true if in a constraint or coverpoint expression."
+ "Return non-nil if in a constraint or coverpoint expression."
(interactive)
(save-excursion
(if (verilog-in-paren)
@@ -6608,13 +6939,13 @@ Also move point to constraint."
(equal (char-before) ?\;)
(equal (char-before) ?\}))
;; skip what looks like bus repetition operator {#{
- (not (string-match "^{\\s-*[()0-9a-zA-Z_\\]*\\s-*{"
+ (not (string-match "^{\\s-*[][()0-9a-zA-Z_,:\\]*\\s-*{"
(buffer-substring p (point)))))))))
(progn
(let ( (pt (point)) (pass 0))
(verilog-backward-ws&directives)
(verilog-backward-token)
- (if (looking-at (concat "\\<constraint\\|coverpoint\\|cross\\|with\\>\\|" verilog-in-constraint-re))
+ (if (looking-at (concat "\\<\\(?:constraint\\|coverpoint\\|cross\\|with\\)\\>\\|" verilog-in-constraint-re))
(progn (setq pass 1)
(if (looking-at "\\<with\\>")
(progn (verilog-backward-ws&directives)
@@ -6625,7 +6956,7 @@ Also move point to constraint."
))
;; if first word token not keyword, it maybe the instance name
;; check next word token
- (if (looking-at "\\<\\w+\\>\\|\\s-*(\\s-*\\S-+")
+ (if (looking-at "\\<\\w+\\>\\|\\s-*[[(}]\\s-*\\S-+")
(progn (verilog-beg-of-statement)
(if (and
(not (string-match verilog-named-block-re (buffer-substring pt (point)))) ;; Abort if 'begin' keyword is found
@@ -6655,7 +6986,7 @@ Also move point to constraint."
(save-excursion
(if (and (equal (char-after) ?\{)
(verilog-backward-token))
- (looking-at "\\<struct\\|union\\|packed\\|\\(un\\)?signed\\>")
+ (looking-at "\\<\\(?:struct\\|union\\|packed\\|\\(un\\)?signed\\)\\>")
nil)))
(defun verilog-at-struct-mv-p ()
@@ -6663,7 +6994,7 @@ Also move point to constraint."
(let ((pt (point)))
(if (and (equal (char-after) ?\{)
(verilog-backward-token))
- (if (looking-at "\\<struct\\|union\\|packed\\|\\(un\\)?signed\\>")
+ (if (looking-at "\\<\\(?:struct\\|union\\|packed\\|\\(un\\)?signed\\)\\>")
(progn (verilog-beg-of-statement) (point))
(progn (goto-char pt) nil))
(progn (goto-char pt) nil))))
@@ -6674,13 +7005,39 @@ Also move point to constraint."
(verilog-in-struct-p)
(looking-at "}\\(?:\\s-*\\w+\\s-*\\(?:,\\s-*\\w+\\s-*\\)*\\)?;")))
+(defun verilog-at-struct-decl-p ()
+ "Return non-nil if at a struct declaration."
+ (interactive)
+ (save-excursion
+ (verilog-re-search-forward "{" (point-at-eol) t)
+ (unless (bobp)
+ (backward-char))
+ (verilog-at-struct-p)))
+
+(defun verilog-at-enum-p ()
+ "If at the { of a enum, return true, not moving point."
+ (save-excursion
+ (when (equal (char-after) ?\{)
+ (verilog-beg-of-statement)
+ (beginning-of-line)
+ (when (verilog-re-search-forward verilog-typedef-enum-re (verilog-pos-at-end-of-statement) t)
+ t))))
+
+(defun verilog-at-enum-decl-p ()
+ "Return non-nil if at a enum declaration."
+ (interactive)
+ (save-excursion
+ (verilog-re-search-forward "{" (verilog-pos-at-end-of-statement) t)
+ (unless (bobp)
+ (backward-char))
+ (verilog-at-enum-p)))
+
(defun verilog-parenthesis-depth ()
"Return non zero if in parenthetical-expression."
(save-excursion (nth 1 (verilog-syntax-ppss))))
-
(defun verilog-skip-forward-comment-or-string ()
- "Return true if in a string or comment."
+ "Return non-nil if in a string or comment."
(let ((state (save-excursion (verilog-syntax-ppss))))
(cond
((nth 3 state) ;Inside string
@@ -6695,7 +7052,7 @@ Also move point to constraint."
nil))))
(defun verilog-skip-backward-comment-or-string ()
- "Return true if in a string or comment."
+ "Return non-nil if in a string or comment."
(let ((state (save-excursion (verilog-syntax-ppss))))
(cond
((nth 3 state) ;Inside string
@@ -6712,7 +7069,7 @@ Also move point to constraint."
nil))))
(defun verilog-skip-backward-comments ()
- "Return true if a comment was skipped."
+ "Return non-nil if a comment was skipped."
(let ((more t))
(while more
(setq more
@@ -6831,6 +7188,9 @@ Only look at a few lines to determine indent level."
(let ((type (car indent-str))
(ind (car (cdr indent-str))))
(cond
+ (; handle indentation ignoring
+ (verilog-indent-ignore-p)
+ nil)
(; handle continued exp
(eq type 'cexp)
(let ((here (point)))
@@ -6840,14 +7200,14 @@ Only look at a few lines to determine indent level."
(= (preceding-char) ?\,)
(save-excursion
(verilog-beg-of-statement-1)
- (looking-at verilog-declaration-re)))
+ (verilog-looking-at-decl-to-align)))
(let* ( fst
(val
(save-excursion
(backward-char 1)
(verilog-beg-of-statement-1)
(setq fst (point))
- (if (looking-at verilog-declaration-re)
+ (if (looking-at (verilog-get-declaration-re))
(progn ; we have multiple words
(goto-char (match-end 0))
(skip-chars-forward " \t")
@@ -6869,9 +7229,9 @@ Only look at a few lines to determine indent level."
(+ (current-column) verilog-cexp-indent))))))
(goto-char here)
(indent-line-to val)
- (if (and (not verilog-indent-lists)
- (verilog-in-paren))
- (verilog-pretty-declarations-auto))
+ (when (and (not verilog-indent-lists)
+ (verilog-in-paren))
+ (verilog-pretty-declarations-auto))
))
((= (preceding-char) ?\) )
(goto-char here)
@@ -6897,21 +7257,17 @@ Only look at a few lines to determine indent level."
(; handle inside parenthetical expressions
(eq type 'cparenexp)
- (let* ( here
- (val (save-excursion
- (verilog-backward-up-list 1)
- (forward-char 1)
- (if verilog-indent-lists
- (skip-chars-forward " \t")
- (verilog-forward-syntactic-ws))
+ (let* ((val (verilog-cparenexp-indent-level))
+ (here (save-excursion
+ (verilog-backward-up-list 1)
+ (forward-char 1)
+ (skip-chars-forward " \t")
+ (point)))
+ (decl (save-excursion
+ (goto-char here)
+ (verilog-forward-syntactic-ws)
(setq here (point))
- (current-column)))
-
- (decl (save-excursion
- (goto-char here)
- (verilog-forward-syntactic-ws)
- (setq here (point))
- (looking-at verilog-declaration-re))))
+ (looking-at (verilog-get-declaration-re)))))
(indent-line-to val)
(if decl
(verilog-pretty-declarations-auto))))
@@ -6938,17 +7294,20 @@ Only look at a few lines to determine indent level."
(;-- defun
(and (eq type 'defun)
- (looking-at verilog-zero-indent-re))
+ (or (and verilog-indent-class-inside-pkg
+ (looking-at verilog-zero-indent-no-class-re))
+ (and (not verilog-indent-class-inside-pkg)
+ (looking-at verilog-zero-indent-re))))
(indent-line-to 0))
(;-- declaration
(and (or
(eq type 'defun)
(eq type 'block))
- (looking-at verilog-declaration-re)
+ (verilog-looking-at-decl-to-align)
;; Do not consider "virtual function", "virtual task", "virtual class"
;; as declarations
- (not (looking-at (concat verilog-declaration-re
+ (not (looking-at (concat (verilog-get-declaration-re)
"\\s-+\\(function\\|task\\|class\\)\\b"))))
(verilog-indent-declaration ind))
@@ -6994,6 +7353,81 @@ Do not count named blocks or case-statements."
(t
(current-column)))))
+(defun verilog-cparenexp-indent-level ()
+ "Return indent level for current line inside a parenthetical expression."
+ (let ((start-pos (point))
+ (close-par (looking-at "[)}]"))
+ pos pos-arg-paren)
+ (save-excursion
+ (verilog-backward-up-list 1)
+ (if verilog-indent-lists
+ (progn
+ (forward-char 1)
+ (skip-chars-forward " \t")
+ (current-column))
+ ;; Indentation with `verilog-indent-lists' set to nil
+ (verilog-beg-of-statement-1)
+ (when (looking-at "\\<\\(function\\|task\\)\\>")
+ (verilog-beg-of-statement)) ; find virtual/protected/static
+ (cond (;; 1) Closing ); of a module/function/task
+ (and close-par
+ (save-excursion
+ (verilog-beg-of-statement-1)
+ (or (looking-at verilog-complete-re)
+ (progn (beginning-of-line)
+ (not (looking-at verilog-assignment-operation-re))))))
+ (current-column))
+ (;; 2) if (condition)
+ (looking-at "(")
+ (forward-char 1)
+ (skip-chars-forward " \t\f" (point-at-eol))
+ (current-column))
+ (;; 3) Inside a module/defun param list or function/task argument list
+ (or (looking-at verilog-defun-level-re)
+ (looking-at "\\(\\<\\(virtual\\|protected\\|static\\)\\>\\s-+\\)?\\(\\<task\\>\\|\\<function\\>\\)"))
+ (setq pos-arg-paren (save-excursion
+ (goto-char start-pos)
+ (verilog-backward-up-list 1)
+ (forward-char)
+ (skip-chars-forward " \t")
+ (when (not (eolp))
+ (current-column))))
+ (or pos-arg-paren
+ ;; arg in next line after (
+ (+ (current-column) verilog-indent-level)))
+ (;; 4) Assignment operation
+ (save-excursion
+ (beginning-of-line)
+ (and (looking-at verilog-assignment-operation-re)
+ (save-excursion
+ (goto-char (match-beginning 2))
+ (not (verilog-within-string)))
+ (progn (verilog-forward-syntactic-ws)
+ (not (looking-at verilog-complete-re)))))
+ (goto-char (match-end 2))
+ (skip-chars-forward " \t\f" (point-at-eol))
+ (skip-chars-forward "{(" (1+ (point)))
+ (skip-chars-forward " \t\f" (point-at-eol))
+ (current-column))
+ (;; 5) Typedef enum declaration
+ (verilog-at-enum-decl-p)
+ (verilog-re-search-forward "{" (verilog-pos-at-end-of-statement) t)
+ (if (> (verilog-pos-at-forward-syntactic-ws) (point-at-eol))
+ (+ (verilog-col-at-beg-of-statement) verilog-indent-level)
+ (verilog-col-at-forward-syntactic-ws)))
+ (;; 6) Long reporting strings (e.g. $display or $sformatf inside `uvm_info)
+ (save-excursion
+ (goto-char start-pos)
+ (verilog-backward-up-list 1)
+ (setq pos (1+ (point)))
+ (backward-word)
+ (or (looking-at (concat "\\$" verilog-identifier-re)) ; System function/task
+ (looking-at verilog-uvm-statement-re))) ; `uvm_* macros
+ (goto-char pos)
+ (current-column))
+ (t ;; 7) Default
+ (+ (current-column) verilog-indent-level)))))))
+
(defun verilog-indent-comment ()
"Indent current line as comment."
(let* ((stcol
@@ -7053,90 +7487,137 @@ _ARG is ignored, for `comment-indent-function' compatibility."
;;
+(defun verilog-align-comments (startpos endpos)
+ "Align inline comments between STARTPOS and ENDPOS."
+ (let (comm-ind e)
+ (when verilog-align-decl-expr-comments
+ (setq comm-ind (verilog-get-comment-align-indent (marker-position startpos) endpos))
+ (save-excursion
+ (goto-char (marker-position startpos))
+ (while (progn (setq e (marker-position endpos))
+ (< (point) e))
+ (when (verilog-search-comment-in-declaration e)
+ (goto-char (match-beginning 0))
+ (delete-horizontal-space)
+ (indent-to (1- (+ comm-ind verilog-align-comment-distance)))))))))
+
(defun verilog-pretty-declarations-auto (&optional quiet)
"Call `verilog-pretty-declarations' QUIET based on `verilog-auto-lineup'."
(when (or (eq 'all verilog-auto-lineup)
(eq 'declarations verilog-auto-lineup))
(verilog-pretty-declarations quiet)))
+(defun verilog--pretty-declarations-find-end (&optional reg-end)
+ "Find end position for current alignment of declarations.
+If region is active, use arg REG-END to set a limit on the alignment."
+ (let (e)
+ (if (and (verilog-parenthesis-depth)
+ (not (verilog-in-struct-p)))
+ ;; In an argument list or parameter block
+ (progn
+ (verilog-backward-up-list -1)
+ (forward-char -1)
+ (verilog-backward-syntactic-ws)
+ (if (region-active-p)
+ (min reg-end (point))
+ (point)))
+ ;; In a declaration block (not in argument list)
+ (verilog-end-of-statement)
+ (setq e (point)) ; Might be on last line
+ (verilog-forward-syntactic-ws)
+ (while (verilog-looking-at-decl-to-align)
+ (verilog-end-of-statement)
+ (setq e (point))
+ (verilog-forward-syntactic-ws))
+ (if (region-active-p)
+ (min reg-end e)
+ e))))
+
+(defun verilog--pretty-declarations-find-base-ind ()
+ "Find base indentation for current alignment of declarations."
+ (if (and (verilog-parenthesis-depth)
+ (not (verilog-in-struct-p)))
+ ;; In an argument list or parameter block
+ (progn
+ (unless (or (verilog-looking-back "(" (point-at-bol))
+ (bolp))
+ (forward-char 1))
+ (skip-chars-forward " \t")
+ (current-column))
+ ;; In a declaration block (not in argument list)
+ (progn
+ (verilog-do-indent (verilog-calculate-indent))
+ (verilog-forward-ws&directives)
+ (current-column))))
+
(defun verilog-pretty-declarations (&optional quiet)
"Line up declarations around point.
Be verbose about progress unless optional QUIET set."
(interactive)
- (let* ((m1 (make-marker))
- (e (point))
- el
- r
- (here (point))
- ind
- start
- startpos
- end
- endpos
- base-ind
- )
+ (let ((m1 (make-marker))
+ (e (point))
+ (here (point))
+ el r ind start startpos end endpos base-ind rstart rend)
(save-excursion
+ (when (region-active-p)
+ (setq rstart (region-beginning))
+ (setq rend (region-end))
+ (goto-char rstart)) ; Shrinks the region but ensures that start is a valid declaration
(if (progn
- ;; (verilog-beg-of-statement-1)
+ ;; Check if alignment can be performed
(beginning-of-line)
(verilog-forward-syntactic-ws)
- (and (not (verilog-in-directive-p)) ; could have `define input foo
- (looking-at verilog-declaration-re)))
- (progn
- (if (verilog-parenthesis-depth)
- ;; in an argument list or parameter block
- (setq el (verilog-backward-up-list -1)
- start (progn
- (goto-char e)
- (verilog-backward-up-list 1)
- (forward-line) ; ignore ( input foo,
- (verilog-re-search-forward verilog-declaration-re el 'move)
- (goto-char (match-beginning 0))
+ (or (and (not (verilog-in-directive-p)) ; could have `define input foo
+ (verilog-looking-at-decl-to-align))
+ (and (verilog-parenthesis-depth)
+ (looking-at verilog-interface-modport-re))))
+ ;; Find boundaries of alignment
+ (progn
+ (cond (;; Using region
+ (region-active-p)
+ (setq start rstart
+ startpos (set-marker (make-marker) start)
+ end (progn (goto-char start)
+ (verilog--pretty-declarations-find-end rend))
+ endpos (set-marker (make-marker) end)
+ base-ind (progn (goto-char start)
+ (verilog--pretty-declarations-find-base-ind))))
+ (;; In an argument list or parameter block
+ (and (verilog-parenthesis-depth)
+ (not (verilog-in-struct-p)))
+ (setq el (verilog-backward-up-list -1)
+ start (progn
+ (goto-char e)
+ (verilog-backward-up-list 1)
+ (verilog-re-search-forward (verilog-get-declaration-re 'iface-mp) el 'move)
+ (goto-char (match-beginning 0))
+ (skip-chars-backward " \t")
+ (point))
+ startpos (set-marker (make-marker) start)
+ end (progn (goto-char start)
+ (verilog--pretty-declarations-find-end))
+ endpos (set-marker (make-marker) end)
+ base-ind (progn (goto-char start)
+ (verilog--pretty-declarations-find-base-ind))))
+ (;; In a declaration block (not in argument list)
+ t
+ (setq
+ start (progn
+ (verilog-beg-of-statement-1)
+ (while (and (verilog-looking-at-decl-to-align)
+ (not (bobp)))
(skip-chars-backward " \t")
- (point))
- startpos (set-marker (make-marker) start)
- end (progn
- (goto-char start)
- (verilog-backward-up-list -1)
- (forward-char -1)
- (verilog-backward-syntactic-ws)
- (point))
- endpos (set-marker (make-marker) end)
- base-ind (progn
- (goto-char start)
- (forward-char 1)
- (skip-chars-forward " \t")
- (current-column)))
- ;; in a declaration block (not in argument list)
- (setq
- start (progn
- (verilog-beg-of-statement-1)
- (while (and (looking-at verilog-declaration-re)
- (not (bobp)))
- (skip-chars-backward " \t")
- (setq e (point))
- (beginning-of-line)
- (verilog-backward-syntactic-ws)
- (backward-char)
- (verilog-beg-of-statement-1))
- e)
- startpos (set-marker (make-marker) start)
- end (progn
- (goto-char here)
- (verilog-end-of-statement)
- (setq e (point)) ;Might be on last line
- (verilog-forward-syntactic-ws)
- (while (looking-at verilog-declaration-re)
- (verilog-end-of-statement)
- (setq e (point))
- (verilog-forward-syntactic-ws))
- e)
- endpos (set-marker (make-marker) end)
- base-ind (progn
- (goto-char start)
- (verilog-do-indent (verilog-calculate-indent))
- (verilog-forward-ws&directives)
- (current-column))))
+ (setq e (point))
+ (verilog-backward-syntactic-ws)
+ (backward-char)
+ (verilog-beg-of-statement-1))
+ e)
+ startpos (set-marker (make-marker) start)
+ end (progn (goto-char here)
+ (verilog--pretty-declarations-find-end))
+ endpos (set-marker (make-marker) end)
+ base-ind (progn (goto-char start)
+ (verilog--pretty-declarations-find-base-ind)))))
;; OK, start and end are set
(goto-char (marker-position startpos))
(if (and (not quiet)
@@ -7152,12 +7633,13 @@ Be verbose about progress unless optional QUIET set."
(indent-line-to base-ind)
(verilog-forward-ws&directives)
(if (< (point) e)
- (verilog-re-search-forward "[ \t\n\f]" e 'move)))
+ (verilog-re-search-forward "[ \t\n\f]" (marker-position endpos) 'move)))
(t
- (just-one-space)
- (verilog-re-search-forward "[ \t\n\f]" e 'move)))
- ;;(forward-line)
- )
+ (unless (verilog-looking-back "(" (point-at-bol))
+ (just-one-space))
+ (if (looking-at verilog-comment-start-regexp)
+ (verilog-forward-syntactic-ws)
+ (verilog-re-search-forward "[ \t\n\f]" e 'move)))))
;; Now find biggest prefix
(setq ind (verilog-get-lineup-indent (marker-position startpos) endpos))
;; Now indent each line.
@@ -7167,27 +7649,27 @@ Be verbose about progress unless optional QUIET set."
(> r 0))
(setq e (point))
(unless quiet (message "%d" r))
- ;; (verilog-do-indent (verilog-calculate-indent)))
(verilog-forward-ws&directives)
(cond
- ((or (and verilog-indent-declaration-macros
- (looking-at verilog-declaration-re-2-macro))
- (looking-at verilog-declaration-re-2-no-macro))
- (let ((p (match-end 0)))
- (set-marker m1 p)
- (if (verilog-re-search-forward "[[#`]" p 'move)
- (progn
- (forward-char -1)
- (just-one-space)
- (goto-char (marker-position m1))
+ ((looking-at (verilog-get-declaration-re 'iface-mp))
+ (unless (looking-at (verilog-get-declaration-re 'embedded-comments))
+ (let ((p (match-end 0)))
+ (set-marker m1 p)
+ (if (verilog-re-search-forward "[[#`]" p 'move)
+ (progn
+ (forward-char -1)
+ (just-one-space)
+ (goto-char (marker-position m1))
+ (delete-horizontal-space)
+ (indent-to ind 1))
+ (progn
(delete-horizontal-space)
- (indent-to ind 1))
- (progn
- (delete-horizontal-space)
- (indent-to ind 1)))))
+ (indent-to ind 1))))))
((verilog-continued-line-1 (marker-position startpos))
(goto-char e)
- (indent-line-to ind))
+ (unless (and (verilog-in-parenthesis-p)
+ (looking-at (concat "\\s-*" verilog-identifier-sym-re "\\s-+" verilog-identifier-sym-re "\\s-*")))
+ (indent-line-to ind)))
((verilog-in-struct-p)
;; could have a declaration of a user defined item
(goto-char e)
@@ -7197,104 +7679,202 @@ Be verbose about progress unless optional QUIET set."
(verilog-forward-ws&directives)
(forward-line -1)))
(forward-line 1))
- (unless quiet (message "")))))))
+ ;; Align comments if enabled
+ (when verilog-align-decl-expr-comments
+ (verilog-align-comments startpos endpos)))
+ ;; Exit
+ (unless quiet (message ""))))))
+
+(defun verilog--pretty-expr-assignment-found (&optional discard-re)
+ "Return non-nil if point is at a valid assignment operation to be aligned.
+Ensure cursor is not over DISCARD-RE (e.g. Verilog keywords).
+If returned non-nil, update match data according to `verilog-assignment-operation-re'."
+ ;; Not looking at a verilog keyword sentence (i.e looking at a potential assignment)
+ (and (if discard-re
+ (not (looking-at discard-re))
+ t)
+ ;; Corner case to filter first parameter on param lists
+ (save-excursion
+ (if (and (verilog-re-search-forward verilog-assignment-operation-re (point-at-eol) 'move)
+ (verilog-in-parenthesis-p))
+ (progn (verilog-backward-up-list 1)
+ (forward-char 1)
+ (not (eq 0 (string-match discard-re (buffer-substring-no-properties (point) (point-at-eol))))))
+ t))
+ ;; Don't work on multiline assignments unless they are continued lines
+ ;; e.g, multiple parameters or variable declarations in the same statement
+ (if (save-excursion
+ (and (not (verilog-in-parameter-p))
+ (verilog-continued-line)
+ (not (looking-at verilog-basic-complete-re))))
+ (save-excursion
+ (verilog-beg-of-statement-1)
+ (looking-at (verilog-get-declaration-re)))
+ t)
+ ;; Ensure it's not any kind of logical comparison
+ (save-excursion
+ (unless (and (not (verilog-in-parameter-p))
+ (verilog-re-search-forward (verilog-regexp-words '("if" "for" "assert" "with")) (point-at-eol) 'move))
+ t))
+ ;; Looking at an assignment (last check, provides match data)
+ (looking-at verilog-assignment-operation-re)))
+
+(defun verilog--pretty-expr-find-end (&optional discard-re reg-end)
+ "Find end position for current alignment of expressions.
+Use optional arg DISCARD-RE when aligning expressions outside of an
+argument list and REG-END to set a limit on the alignment when the
+region is active."
+ (if (verilog-in-parenthesis-p)
+ ;; Limit end in argument list
+ (progn
+ (verilog-backward-up-list -1)
+ (forward-char -1)
+ (verilog-backward-syntactic-ws)
+ (if (region-active-p)
+ (min reg-end (point))
+ (point)))
+ ;; Limit end in non-argument list
+ (save-excursion ; EOL of the last line of the assignment block
+ (end-of-line)
+ (let ((pt (point))) ; Might be on last line
+ (verilog-forward-syntactic-ws)
+ (beginning-of-line)
+ (while (and (verilog--pretty-expr-assignment-found discard-re)
+ (progn
+ (end-of-line)
+ (not (eq pt (point)))))
+ (setq pt (point))
+ (verilog-forward-syntactic-ws)
+ (beginning-of-line))
+ (if (region-active-p)
+ (min reg-end pt)
+ pt)))))
(defun verilog-pretty-expr (&optional quiet)
"Line up expressions around point.
If QUIET is non-nil, do not print messages showing the progress of line-up."
(interactive)
- (unless (verilog-in-comment-or-string-p)
+ (let* ((basic-complete-pretty-expr-re (if verilog-align-assign-expr
+ verilog-basic-complete-expr-no-assign-re
+ verilog-basic-complete-expr-re))
+ (complete-pretty-expr-re (concat verilog-extended-complete-re "\\|\\(" basic-complete-pretty-expr-re "\\)"))
+ (discard-re (concat "^\\s-*\\(" complete-pretty-expr-re "\\)"))
+ rstart rend)
(save-excursion
- (let ((regexp (concat "^\\s-*" verilog-complete-reg))
- (regexp1 (concat "^\\s-*" verilog-basic-complete-re)))
+ (when (region-active-p)
+ (setq rstart (region-beginning))
+ (setq rend (region-end))
+ (goto-char rstart))
+ (unless (verilog-in-comment-or-string-p)
(beginning-of-line)
- (when (and (not (looking-at regexp))
- (looking-at verilog-assignment-operation-re)
+ (when (and (verilog--pretty-expr-assignment-found discard-re)
(save-excursion
(goto-char (match-end 2))
(and (not (verilog-in-attribute-p))
- (not (verilog-in-parameter-p))
(not (verilog-in-comment-or-string-p)))))
- (let* ((start (save-excursion ; BOL of the first line of the assignment block
- (beginning-of-line)
- (let ((pt (point)))
- (verilog-backward-syntactic-ws)
- (beginning-of-line)
- (while (and (not (looking-at regexp1))
- (looking-at verilog-assignment-operation-re)
- (not (bobp)))
- (setq pt (point))
- (verilog-backward-syntactic-ws)
- (beginning-of-line)) ; Ack, need to grok `define
- pt)))
- (end (save-excursion ; EOL of the last line of the assignment block
- (end-of-line)
- (let ((pt (point))) ; Might be on last line
- (verilog-forward-syntactic-ws)
- (beginning-of-line)
- (while (and
- (not (looking-at regexp1))
- (looking-at verilog-assignment-operation-re)
- (progn
- (end-of-line)
- (not (eq pt (point)))))
- (setq pt (point))
- (verilog-forward-syntactic-ws)
- (beginning-of-line))
- pt)))
- (contains-2-char-operator (string-match "<=" (buffer-substring-no-properties start end)))
- (endmark (set-marker (make-marker) end)))
- (goto-char start)
- (verilog-do-indent (verilog-calculate-indent))
+ (let* ((start (cond (;; Using region
+ (region-active-p)
+ rstart)
+ (;; Parameter list
+ (verilog-in-parenthesis-p)
+ (progn
+ (verilog-backward-up-list 1)
+ (forward-char)
+ (verilog-re-search-forward verilog-assignment-operation-re-2 nil 'move)
+ (goto-char (match-beginning 0))
+ (point)))
+ (t ;; Declarations
+ (save-excursion ; BOL of the first line of the assignment block
+ (beginning-of-line)
+ (let ((pt (point)))
+ (verilog-backward-syntactic-ws)
+ (beginning-of-line)
+ (while (and (verilog--pretty-expr-assignment-found discard-re)
+ (not (bobp)))
+ (setq pt (point))
+ (verilog-backward-syntactic-ws)
+ (beginning-of-line)) ; Ack, need to grok `define
+ pt)))))
+ (startpos (set-marker (make-marker) start))
+ (end (cond (;; Using region
+ (region-active-p)
+ (verilog--pretty-expr-find-end discard-re rend))
+ (;; Parameter list
+ (verilog-in-parenthesis-p)
+ (verilog--pretty-expr-find-end))
+ (t ;; Declarations
+ (verilog--pretty-expr-find-end discard-re))))
+ (endpos (set-marker (make-marker) end))
+ (contains-2-char-operator (string-match "<=" (buffer-substring-no-properties start end))))
+ ;; Start with alignment
+ (goto-char startpos)
+ (unless (save-excursion
+ (beginning-of-line)
+ (looking-at discard-re))
+ (verilog-do-indent (verilog-calculate-indent)))
(when (and (not quiet)
- (> (- end start) 100))
+ (> (- (marker-position endpos) (marker-position startpos)) 100))
(message "Lining up expressions.. (please stand by)"))
-
;; Set indent to minimum throughout region
;; Rely on mark rather than on point as the indentation changes can
;; make the older point reference obsolete
- (while (< (point) (marker-position endmark))
+ (while (< (point) (marker-position endpos))
(beginning-of-line)
(save-excursion
- (verilog-just-one-space verilog-assignment-operation-re))
+ (if (looking-at verilog-complete-re)
+ (progn (goto-char (marker-position startpos))
+ (verilog-just-one-space verilog-assignment-operation-re-2))
+ (verilog-just-one-space verilog-assignment-operation-re)))
(verilog-do-indent (verilog-calculate-indent))
(end-of-line)
(verilog-forward-syntactic-ws))
- (let ((ind (verilog-get-lineup-indent-2 verilog-assignment-operation-re start (marker-position endmark))) ; Find the biggest prefix
+ (let ((ind (verilog-get-lineup-indent-2 verilog-assignment-operation-re (marker-position startpos) (marker-position endpos))) ; Find the biggest prefix
e)
;; Now indent each line.
- (goto-char start)
+ (goto-char (marker-position startpos))
(while (progn
- (setq e (marker-position endmark))
+ (setq e (marker-position endpos))
(> e (point)))
(unless quiet
(message " verilog-pretty-expr: %d" (- e (point))))
(setq e (point))
(cond
- ((looking-at verilog-assignment-operation-re)
+ ((or (looking-at verilog-assignment-operation-re)
+ (and (verilog-in-parenthesis-p)
+ (looking-at verilog-assignment-operation-re-2)))
(goto-char (match-beginning 2))
- (unless (or (verilog-in-parenthesis-p) ; Leave attributes and comparisons alone
+ (unless (or (and (verilog-in-parenthesis-p) ; Leave attributes and comparisons alone
+ (save-excursion ; Allow alignment of some expressions inside param/port list
+ (verilog-backward-up-list 1)
+ (verilog-beg-of-statement-1)
+ (not (looking-at verilog-defun-level-re))))
(verilog-in-coverage-p))
(if (and contains-2-char-operator
(eq (char-after) ?=))
(indent-to (1+ ind)) ; Line up the = of the <= with surrounding =
- (indent-to ind))))
- ((verilog-continued-line-1 start)
+ (indent-to ind)))
+ (forward-line 1))
+ ((and (save-excursion
+ (verilog-forward-syntactic-ws)
+ (not (looking-at verilog-complete-re)))
+ (verilog-continued-line-1 (marker-position startpos)))
(goto-char e)
- (indent-line-to ind))
- (t ; Must be comment or white space
+ (indent-line-to ind)
+ (forward-line 1))
+ (t ; Must be comment, white space or syntax error
(goto-char e)
- (verilog-forward-ws&directives)
- (forward-line -1)))
- (forward-line 1))
+ (forward-line 1))))
+ ;; Align comments if enabled
+ (when verilog-align-decl-expr-comments
+ (verilog-align-comments startpos endpos))
(unless quiet
(message "")))))))))
(defun verilog-just-one-space (myre)
"Remove extra spaces around regular expression MYRE."
(interactive)
- (if (and (not(looking-at verilog-complete-reg))
+ (if (and (not(looking-at verilog-complete-re))
(looking-at myre))
(let ((p1 (match-end 1))
(p2 (match-end 2)))
@@ -7312,59 +7892,63 @@ BASEIND is the base indent to offset everything."
;; `ind' is used in expressions stored in `verilog-indent-alist'.
(verilog--suppressed-warnings ((lexical ind)) (defvar ind))
(let ((pos (point-marker))
- (lim (save-excursion
- ;; (verilog-re-search-backward verilog-declaration-opener nil 'move)
- (verilog-re-search-backward "\\(\\<begin\\>\\)\\|\\(\\<\\(connect\\)?module\\>\\)\\|\\(\\<task\\>\\)" nil 'move)
- (point)))
- (ind)
- (val)
- (m1 (make-marker)))
- (setq val
- (+ baseind (eval (cdr (assoc 'declaration verilog-indent-alist)))))
+ (m1 (make-marker))
+ (in-paren (verilog-parenthesis-depth))
+ (val (+ baseind (eval (cdr (assoc 'declaration verilog-indent-alist)))))
+ ind)
(indent-line-to val)
-
;; Use previous declaration (in this module) as template.
- (if (or (eq 'all verilog-auto-lineup)
- (eq 'declarations verilog-auto-lineup))
- (if (verilog-re-search-backward
- (or (and verilog-indent-declaration-macros
- verilog-declaration-re-1-macro)
- verilog-declaration-re-1-no-macro)
- lim t)
- (progn
- (goto-char (match-end 0))
- (skip-chars-forward " \t")
- (setq ind (current-column))
- (goto-char pos)
- (setq val
- (+ baseind
- (eval (cdr (assoc 'declaration verilog-indent-alist)))))
- (indent-line-to val)
- (if (and verilog-indent-declaration-macros
- (looking-at verilog-declaration-re-2-macro))
- (let ((p (match-end 0)))
- (set-marker m1 p)
- (if (verilog-re-search-forward "[[#`]" p 'move)
- (progn
- (forward-char -1)
- (just-one-space)
- (goto-char (marker-position m1))
- (delete-horizontal-space)
- (indent-to ind 1))
- (delete-horizontal-space)
- (indent-to ind 1)))
- (if (looking-at verilog-declaration-re-2-no-macro)
- (let ((p (match-end 0)))
- (set-marker m1 p)
- (if (verilog-re-search-forward "[[`#]" p 'move)
- (progn
- (forward-char -1)
- (just-one-space)
- (goto-char (marker-position m1))
- (delete-horizontal-space)
- (indent-to ind 1))
- (delete-horizontal-space)
- (indent-to ind 1))))))))
+ (when (and (or (eq 'all verilog-auto-lineup)
+ (eq 'declarations verilog-auto-lineup))
+ ;; Limit alignment to consecutive statements
+ (progn
+ (verilog-backward-syntactic-ws)
+ (backward-char)
+ (looking-at ";"))
+ (progn
+ (verilog-beg-of-statement)
+ (looking-at (verilog-get-declaration-re)))
+ ;; Make sure that we don't jump to an argument list or parameter block if
+ ;; we were in a declaration block (not in argument list)
+ (or (and in-paren
+ (verilog-parenthesis-depth))
+ (and (not in-paren)
+ (not (verilog-parenthesis-depth))))
+ ;; Skip variable declarations inside functions/tasks
+ (skip-chars-backward " \t\f")
+ (bolp))
+ (goto-char (match-end 0))
+ (skip-chars-forward " \t")
+ (setq ind (current-column))
+ (goto-char pos)
+ (setq val
+ (+ baseind
+ (eval (cdr (assoc 'declaration verilog-indent-alist)))))
+ (indent-line-to val)
+ (if (looking-at (verilog-get-declaration-re))
+ (let ((p (match-end 0)))
+ (set-marker m1 p)
+ (if (verilog-re-search-forward "[[#`]" p 'move)
+ (progn
+ (forward-char -1)
+ (just-one-space)
+ (goto-char (marker-position m1))
+ (delete-horizontal-space)
+ (indent-to ind 1))
+ (delete-horizontal-space)
+ (indent-to ind 1)))
+ (when (looking-at (verilog-get-declaration-re))
+ (let ((p (match-end 0)))
+ (set-marker m1 p)
+ (if (verilog-re-search-forward "[[`#]" p 'move)
+ (progn
+ (forward-char -1)
+ (just-one-space)
+ (goto-char (marker-position m1))
+ (delete-horizontal-space)
+ (indent-to ind 1))
+ (delete-horizontal-space)
+ (indent-to ind 1))))))
(goto-char pos)))
(defun verilog-get-lineup-indent (b edpos)
@@ -7376,16 +7960,13 @@ Region is defined by B and EDPOS."
;; Get rightmost position
(while (progn (setq e (marker-position edpos))
(< (point) e))
- (if (verilog-re-search-forward
- (or (and verilog-indent-declaration-macros
- verilog-declaration-re-1-macro)
- verilog-declaration-re-1-no-macro) e 'move)
- (progn
- (goto-char (match-end 0))
- (verilog-backward-syntactic-ws)
- (if (> (current-column) ind)
- (setq ind (current-column)))
- (goto-char (match-end 0)))))
+ (when (verilog-re-search-forward (verilog-get-declaration-re 'iface-mp) e 'move)
+ (goto-char (match-end 0))
+ (verilog-backward-syntactic-ws)
+ (if (> (current-column) ind)
+ (setq ind (current-column)))
+ (goto-char (match-end 0))
+ (forward-line 1)))
(if (> ind 0)
(1+ ind)
;; No lineup-string found
@@ -7402,12 +7983,13 @@ BEG and END."
(save-excursion
(let ((ind 0))
(goto-char beg)
+ (beginning-of-line)
;; Get rightmost position
(while (< (point) end)
(when (and (verilog-re-search-forward regexp end 'move)
(not (verilog-in-attribute-p))) ; skip attribute exprs
(goto-char (match-beginning 2))
- (verilog-backward-syntactic-ws)
+ (skip-chars-backward " \t")
(if (> (current-column) ind)
(setq ind (current-column)))
(goto-char (match-end 0))))
@@ -7420,6 +8002,32 @@ BEG and END."
(1+ (current-column))))
ind)))
+(defun verilog-search-comment-in-declaration (bound)
+ "Move cursor to position of comment in declaration and return point.
+BOUND is a buffer position that bounds the search."
+ (and (verilog-re-search-forward (verilog-get-declaration-re 'iface-mp) bound 'move)
+ (not (looking-at (concat "\\s-*" verilog-comment-start-regexp)))
+ (re-search-forward verilog-comment-start-regexp (point-at-eol) :noerror)))
+
+(defun verilog-get-comment-align-indent (b endpos)
+ "Return the indent level that will line up comments within the region.
+Region is defined by B and ENDPOS."
+ (save-excursion
+ (let ((ind 0)
+ e comm-ind)
+ (goto-char b)
+ ;; Get rightmost position
+ (while (progn (setq e (marker-position endpos))
+ (< (point) e))
+ (when (verilog-search-comment-in-declaration e)
+ (end-of-line)
+ (verilog-backward-syntactic-ws)
+ (setq comm-ind (1+ (current-column)))
+ (when (> comm-ind ind)
+ (setq ind comm-ind)))
+ (forward-line 1))
+ ind)))
+
(defun verilog-comment-depth (type val)
"A useful mode debugging aide. TYPE and VAL are comments for insertion."
(save-excursion
@@ -7439,6 +8047,20 @@ BEG and END."
(insert
(format "%s %d" type val))))
+(defun verilog-indent-ignore-p ()
+ "Return non-nil if current line should ignore indentation."
+ (or (and verilog-indent-ignore-multiline-defines
+ ;; Line with multiline define, ends with "\" or "\" plus trailing whitespace
+ (or (save-excursion
+ (verilog-re-search-forward ".*\\\\\\s-*$" (line-end-position) t))
+ (save-excursion ; Last line after multiline define
+ (verilog-backward-syntactic-ws)
+ (unless (bobp)
+ (backward-char))
+ (looking-at "\\\\"))))
+ (and verilog-indent-ignore-regexp ; Ignore lines according to specified regexp
+ (looking-at verilog-indent-ignore-regexp))))
+
;;; Completion:
;;
@@ -7446,7 +8068,7 @@ BEG and END."
(defvar verilog-all nil)
(defvar verilog-buffer-to-use nil)
(defvar verilog-toggle-completions nil
- "True means \\<verilog-mode-map>\\[verilog-complete-word] should try all possible completions one by one.
+ "Non-nil means \\<verilog-mode-map>\\[verilog-complete-word] should try all possible completions one by one.
Repeated use of \\[verilog-complete-word] will show you all of them.
Normally, when there is more than one possible completion,
it displays a list of all possible completions.")
@@ -7598,16 +8220,14 @@ TYPE is `module', `tf' for task or function, or t if unknown."
(defun verilog-get-completion-decl (end)
"Macro for searching through current declaration (var, type or const)
for matches of `str' and adding the occurrence tp `all' through point END."
- (let ((re (or (and verilog-indent-declaration-macros
- verilog-declaration-re-2-macro)
- verilog-declaration-re-2-no-macro))
+ (let ((re (verilog-get-declaration-re))
decl-end match)
;; Traverse lines
(while (and (< (point) end)
(verilog-re-search-forward re end t))
;; Traverse current line
(setq decl-end (save-excursion (verilog-declaration-end)))
- (while (and (verilog-re-search-forward verilog-symbol-re decl-end t)
+ (while (and (verilog-re-search-forward verilog-identifier-sym-re decl-end t)
(not (match-end 1)))
(setq match (buffer-substring (match-beginning 0) (match-end 0)))
(if (string-match (concat "\\<" verilog-str) match)
@@ -7619,7 +8239,7 @@ for matches of `str' and adding the occurrence tp `all' through point END."
"Calculate all possible completions for variables (or constants)."
(let ((start (point)))
;; Search for all reachable var declarations
- (verilog-beg-of-defun)
+ (verilog-re-search-backward verilog-defun-re nil 'move)
(save-excursion
;; Check var declarations
(verilog-get-completion-decl start))))
@@ -8707,7 +9327,8 @@ Return an array of [outputs inouts inputs wire reg assign const gparam intf]."
((looking-at "(\\*")
;; To advance past either "(*)" or "(* ... *)" don't forward past first *
(forward-char 1)
- (or (search-forward "*)")
+ (or (looking-at "\\*\\s-*)") ; (* )
+ (search-forward "*)") ; end attribute
(error "%s: Unmatched (* *), at char %d" (verilog-point-text) (point))))
((eq ?\" (following-char))
(or (re-search-forward "[^\\]\"" nil t) ; don't forward-char first, since we look for a non backslash first
@@ -8765,6 +9386,11 @@ Return an array of [outputs inouts inputs wire reg assign const gparam intf]."
(t ; Bit width
(setq vec (verilog-string-replace-matches
"\\s-+" "" nil nil keywd)))))
+ ;; int'(a) is cast, not declaration of a
+ ((and (looking-at "'")
+ (not rvalue))
+ (forward-char 1)
+ (setq expect-signal nil rvalue nil))
;; Normal or escaped identifier -- note we remember the \ if escaped
((looking-at "\\s-*\\([a-zA-Z0-9`_$]+\\|\\\\[^ \t\n\f]+\\)")
(goto-char (match-end 0))
@@ -9054,7 +9680,7 @@ Return an array of [outputs inouts inputs wire reg assign const gparam intf]."
(cond
;; {..., a, b} requires us to recurse on a,b
;; To support {#{},{#{a,b}} we'll just split everything on [{},]
- ((string-match "^\\s-*{\\(.*\\)}\\s-*$" expr)
+ ((string-match "^\\s-*'?{\\(.*\\)}\\s-*$" expr)
(let ((mlst (split-string (match-string 1 expr) "[{},]"))
mstr)
(while (setq mstr (pop mlst))
@@ -9134,7 +9760,10 @@ Inserts the list of signals found, using submodi to look up each port."
;; We intentionally ignore (non-escaped) signals with .s in them
;; this prevents AUTOWIRE etc from noticing hierarchical sigs.
(when port
- (cond ((looking-at "[^\n]*AUTONOHOOKUP"))
+ (cond ((and verilog-auto-ignore-concat
+ (looking-at "[({]"))
+ nil) ; {...} or (...) historically ignored with auto-ignore-concat
+ ((looking-at "[^\n]*AUTONOHOOKUP"))
((looking-at "\\([a-zA-Z_][a-zA-Z_0-9]*\\)\\s-*)")
(verilog-read-sub-decls-sig
submoddecls par-values comment port
@@ -9702,9 +10331,9 @@ resolve it. If optional RECURSE is non-nil, recurse through \\=`includes.
Localparams must be simple assignments to constants, or have their own
\"localparam\" label rather than a list of localparams. Thus:
- localparam X = 5, Y = 10; // Ok
- localparam X = {1\\='b1, 2\\='h2}; // Ok
- localparam X = {1\\='b1, 2\\='h2}, Y = 10; // Bad, make into 2 localparam lines
+ localparam X = 5, Y = 10; // Ok
+ localparam X = {1\\='b1, 2\\='h2}; // Ok
+ localparam X = {1\\='b1, 2\\='h2}, Y = 10; // Bad, make into 2 localparam lines
Defines must be simple text substitutions, one on a line, starting
at the beginning of the line. Any ifdefs or multiline comments around the
@@ -9827,8 +10456,7 @@ variable over and over when many modules are compiled together, put a test
around the inside each include file:
foo.v (an include file):
- \\=`ifdef _FOO_V // include if not already included
- \\=`else
+ \\=`ifndef _FOO_V // include if not already included
\\=`define _FOO_V
... contents of file
\\=`endif // _FOO_V"
@@ -10066,7 +10694,7 @@ Results are cached if inside `verilog-preserve-dir-cache'."
;; (prin1 (verilog-dir-files ".")) nil)
(defun verilog-dir-file-exists-p (filename)
- "Return true if FILENAME exists.
+ "Return non-nil if FILENAME exists.
Like `file-exists-p' but results are cached if inside
`verilog-preserve-dir-cache'."
(let* ((dirname (file-name-directory filename))
@@ -10105,7 +10733,7 @@ Allows version control to check out the file if need be."
modi)))))
(defun verilog-is-number (symbol)
- "Return true if SYMBOL is number-like."
+ "Return non-nil if SYMBOL is number-like."
(or (string-match "^[0-9 \t:]+$" symbol)
(string-match "^[---]*[0-9]+$" symbol)
(string-match "^[0-9 \t]+'s?[hdxbo][0-9a-fA-F_xz? \t]*$" symbol)))
@@ -10177,7 +10805,7 @@ Or, just the existing dirnames themselves if there are no wildcards."
(unless dirnames
(error "`verilog-library-directories' should include at least `.'"))
(save-match-data
- (setq dirnames (reverse dirnames)) ; not nreverse
+ (setq dirnames (reverse dirnames)) ; not nreverse
(let ((dirlist nil)
pattern dirfile dirfiles dirname root filename rest basefile)
(setq dirnames (mapcar #'substitute-in-file-name dirnames))
@@ -10816,7 +11444,7 @@ This repairs those mis-inserted by an AUTOARG."
(while (string-match
(concat "\\([[({:*/<>+-]\\)" ; - must be last
"(\\<\\([0-9A-Za-z_]+\\))"
- "\\([])}:*/<>+-]\\)")
+ "\\([])}:*/<>.+-]\\)")
out)
(setq out (replace-match "\\1\\2\\3" nil nil out)))
(while (string-match
@@ -10885,12 +11513,12 @@ This repairs those mis-inserted by an AUTOARG."
(if (equal (match-string 3 out) ">>")
(int-to-string (ash (string-to-number (match-string 2 out))
(* -1 (string-to-number (match-string 4 out))))))
- (if (equal (match-string 3 out) "<<")
- (int-to-string (ash (string-to-number (match-string 2 out))
- (string-to-number (match-string 4 out)))))
(if (equal (match-string 3 out) ">>>")
(int-to-string (ash (string-to-number (match-string 2 out))
(* -1 (string-to-number (match-string 4 out))))))
+ (if (equal (match-string 3 out) "<<")
+ (int-to-string (ash (string-to-number (match-string 2 out))
+ (string-to-number (match-string 4 out)))))
(if (equal (match-string 3 out) "<<<")
(int-to-string (ash (string-to-number (match-string 2 out))
(string-to-number (match-string 4 out)))))
@@ -10911,7 +11539,8 @@ This repairs those mis-inserted by an AUTOARG."
;;(verilog-simplify-range-expression "[(TEST[1])-1:0]")
;;(verilog-simplify-range-expression "[1<<2:8>>2]") ; [4:2]
;;(verilog-simplify-range-expression "[2*4/(4-2) +2+4 <<4 >>2]")
-;;(verilog-simplify-range-expression "[WIDTH*2/8-1:0]")
+;;(verilog-simplify-range-expression "[WIDTH*2/8-1:0]") ; "[WIDTH*2/8-1:0]"
+;;(verilog-simplify-range-expression "[(FOO).size:0]") ; "[FOO.size:0]"
(defun verilog-clog2 (value)
"Compute $clog2 - ceiling log2 of VALUE."
@@ -10920,7 +11549,7 @@ This repairs those mis-inserted by an AUTOARG."
(ceiling (/ (log value) (log 2)))))
(defun verilog-typedef-name-p (variable-name)
- "Return true if the VARIABLE-NAME is a type definition."
+ "Return non-nil if the VARIABLE-NAME is a type definition."
(when verilog-typedef-regexp
(verilog-string-match-fold verilog-typedef-regexp variable-name)))
@@ -11275,31 +11904,33 @@ If optional REGEXP, ignore differences matching it."
This requires the external program `diff-command' to be in your `exec-path',
and uses `diff-switches' in which you may want to have \"-u\" flag.
Ignores WHITESPACE if t, and writes output to stdout if SHOW."
- ;; Similar to `diff-buffer-with-file' but works on XEmacs, and doesn't
- ;; call `diff' as `diff' has different calling semantics on different
- ;; versions of Emacs.
+ ;; Similar to `diff-buffer-with-file' but works on Emacs 21, and
+ ;; doesn't call `diff' as `diff' has different calling semantics on
+ ;; different versions of Emacs.
(if (not (file-exists-p f1))
- (message "Buffer `%s' has no associated file on disk" (buffer-name b2))
- (with-temp-buffer "*Verilog-Diff*"
- (let ((outbuf (current-buffer))
- (f2 (make-temp-file "vm-diff-auto-")))
- (unwind-protect
- (progn
- (with-current-buffer b2
- (save-restriction
- (widen)
- (write-region (point-min) (point-max) f2 nil 'nomessage)))
- (call-process diff-command nil outbuf t
- diff-switches ; User may want -u in diff-switches
- (if whitespace "-b" "")
- f1 f2)
- ;; Print out results. Alternatively we could have call-processed
- ;; ourself, but this way we can reuse diff switches
- (when show
- (with-current-buffer outbuf (message "%s" (buffer-string))))))
- (sit-for 0)
- (when (file-exists-p f2)
- (delete-file f2))))))
+ (message "Buffer `%s' has no associated file on disk" b2)
+ (let ((outbuf (get-buffer "*Verilog-Diff*"))
+ (f2 (make-temp-file "vm-diff-auto-")))
+ (unwind-protect
+ ;; User may want -u in `diff-switches'.
+ (let ((args `(,@(if (listp diff-switches)
+ diff-switches
+ (list diff-switches))
+ ,@(and whitespace '("-b"))
+ ,f1 ,f2)))
+ (with-current-buffer b2
+ (save-restriction
+ (widen)
+ (write-region (point-min) (point-max) f2 nil 'nomessage)))
+ (apply #'call-process diff-command nil outbuf t args)
+ ;; Print out results. Alternatively we could have call-processed
+ ;; ourself, but this way we can reuse diff switches.
+ (when show
+ (with-current-buffer outbuf (message "%s" (buffer-string)))))
+ (sit-for 0)
+ (condition-case nil
+ (delete-file f2)
+ (error nil))))))
(defun verilog-diff-report (b1 b2 diffpt)
"Report differences detected with `verilog-diff-auto'.
@@ -11625,18 +12256,12 @@ If PAR-VALUES replace final strings with these parameter values."
(vl-memory (verilog-sig-memory port-st))
(vl-mbits (if (verilog-sig-multidim port-st)
(verilog-sig-multidim-string port-st) ""))
- (vl-bits (if (or (eq verilog-auto-inst-vector t)
- (and (eq verilog-auto-inst-vector `unsigned)
- (not (verilog-sig-signed port-st)))
- (not (assoc port (verilog-decls-get-signals moddecls)))
- (not (equal (verilog-sig-bits port-st)
- (verilog-sig-bits
- (assoc port (verilog-decls-get-signals moddecls))))))
- (or (verilog-sig-bits port-st) "")
- ""))
+ (vl-bits (or (verilog-sig-bits port-st) ""))
(case-fold-search nil)
(check-values par-values)
- tpl-net dflt-bits)
+ auto-inst-vector
+ auto-inst-vector-tpl
+ tpl-net dflt-bits)
;; Replace parameters in bit-width
(when (and check-values
(not (equal vl-bits "")))
@@ -11659,6 +12284,16 @@ If PAR-VALUES replace final strings with these parameter values."
vl-mbits (verilog-simplify-range-expression vl-mbits)
vl-memory (when vl-memory (verilog-simplify-range-expression vl-memory))
vl-width (verilog-make-width-expression vl-bits))) ; Not in the loop for speed
+ (setq auto-inst-vector
+ (if (or (eq verilog-auto-inst-vector t)
+ (and (eq verilog-auto-inst-vector `unsigned)
+ (not (verilog-sig-signed port-st)))
+ (not (assoc port (verilog-decls-get-signals moddecls)))
+ (not (equal (verilog-sig-bits port-st)
+ (verilog-sig-bits
+ (assoc port (verilog-decls-get-signals moddecls))))))
+ vl-bits
+ ""))
;; Default net value if not found
(setq dflt-bits (if (or (and (verilog-sig-bits port-st)
(verilog-sig-multidim port-st))
@@ -11668,7 +12303,7 @@ If PAR-VALUES replace final strings with these parameter values."
(if vl-memory "." "")
(if vl-memory vl-memory "")
"*/")
- (concat vl-bits))
+ (concat auto-inst-vector))
tpl-net (concat port
(if (and vl-modport
;; .modport cannot be added if attachment is
@@ -11678,7 +12313,7 @@ If PAR-VALUES replace final strings with these parameter values."
(concat "." vl-modport) "")
dflt-bits))
;; Find template
- (cond (tpl-ass ; Template of exact port name
+ (cond (tpl-ass ; Template of exact port name
(setq tpl-net (nth 1 tpl-ass)))
((nth 1 tpl-list) ; Wildcards in template, search them
(let ((wildcards (nth 1 tpl-list)))
@@ -11707,10 +12342,21 @@ If PAR-VALUES replace final strings with these parameter values."
(if (numberp value) (setq value (number-to-string value)))
value))
(substring tpl-net (match-end 0))))))
+ ;; Get range based off template net
+ (setq auto-inst-vector-tpl
+ (if (or (eq verilog-auto-inst-vector t)
+ (and (eq verilog-auto-inst-vector `unsigned)
+ (not (verilog-sig-signed port-st)))
+ (not (assoc tpl-net (verilog-decls-get-signals moddecls)))
+ (not (equal (verilog-sig-bits port-st)
+ (verilog-sig-bits
+ (assoc tpl-net (verilog-decls-get-signals moddecls))))))
+ vl-bits
+ ""))
;; Replace @ and [] magic variables in final output
(setq tpl-net (verilog-string-replace-matches "@" tpl-num nil nil tpl-net))
(setq tpl-net (verilog-string-replace-matches "\\[\\]\\[\\]" dflt-bits nil nil tpl-net))
- (setq tpl-net (verilog-string-replace-matches "\\[\\]" vl-bits nil nil tpl-net)))
+ (setq tpl-net (verilog-string-replace-matches "\\[\\]" auto-inst-vector-tpl nil nil tpl-net)))
;; Insert it
(when (or tpl-ass (not verilog-auto-inst-template-required))
(verilog--auto-inst-first indent-pt section)
@@ -11880,7 +12526,7 @@ Typing \\[verilog-auto] will make this into:
endmodule
Where the list of inputs and outputs came from the inst module.
-
+
Exceptions:
Unless you are instantiating a module multiple times, or the module is
@@ -11905,7 +12551,7 @@ Exceptions:
// Outputs
.o (o[31:0]));
-
+
Templates:
For multiple instantiations based upon a single template, create a
@@ -11976,7 +12622,7 @@ Templates:
.ptl_bus (ptl_busnew[3:0]),
....
-
+
Multiple Module Templates:
The same template lines can be applied to multiple modules with
@@ -11991,7 +12637,7 @@ Multiple Module Templates:
*/
Note there is only one AUTO_TEMPLATE opening parenthesis.
-
+
@ Templates:
It is common to instantiate a cell multiple times, so templates make it
@@ -12056,7 +12702,7 @@ Multiple Module Templates:
.ptl_mapvalidx (BAR_ptl_mapvalid),
.ptl_mapvalidp1x (ptl_mapvalid_BAR));
-
+
Regexp Templates:
A template entry of the form
@@ -12080,7 +12726,7 @@ Regexp Templates:
subscript:
.\\(.*\\)_l (\\1_[]),
-
+
Lisp Templates:
First any regular expression template is expanded.
@@ -12125,7 +12771,7 @@ Lisp Templates:
After the evaluation is completed, @ substitution and [] substitution
occur.
-
+
Ignoring Hookup:
AUTOWIRE and related AUTOs will read the signals created by a template.
@@ -12134,7 +12780,7 @@ Ignoring Hookup:
.pci_req_l (pci_req_not_to_wire), //AUTONOHOOKUP
-
+
For more information see the \\[verilog-faq] and forums at URL
`https://www.veripool.org'."
(save-excursion
@@ -12240,7 +12886,9 @@ For more information see the \\[verilog-faq] and forums at URL
(cond ((not verilog-auto-inst-first-any)
(re-search-backward "," pt t)
(delete-char 1)
- (insert ");")
+ (when (looking-at " ")
+ (delete-char 1)) ; so we can align // Templated comments
+ (insert ");")
(search-forward "\n") ; Added by inst-port
(delete-char -1)
(if (search-forward ")" nil t) ; From user, moved up a line
@@ -12286,7 +12934,7 @@ Typing \\[verilog-auto] will make this into:
endmodule
Where the list of parameter connections come from the inst module.
-
+
Templates:
You can customize the parameter connections using AUTO_TEMPLATEs,
@@ -14645,7 +15293,7 @@ and the case items."
(if (not (member v1 verilog-keywords))
(save-excursion
(setq verilog-sk-signal v1)
- (verilog-beg-of-defun)
+ (verilog-re-search-backward verilog-defun-re nil 'move)
(verilog-end-of-statement)
(verilog-forward-syntactic-ws)
(verilog-sk-def-reg)
@@ -14897,7 +15545,12 @@ Files are checked based on `verilog-library-flags'."
'(
verilog-active-low-regexp
verilog-after-save-font-hook
+ verilog-align-assign-expr
+ verilog-align-comment-distance
+ verilog-align-decl-expr-comments
verilog-align-ifelse
+ verilog-align-typedef-regexp
+ verilog-align-typedef-words
verilog-assignment-delay
verilog-auto-arg-sort
verilog-auto-declare-nettype
@@ -14942,13 +15595,17 @@ Files are checked based on `verilog-library-flags'."
verilog-compiler
verilog-coverage
verilog-delete-auto-hook
+ verilog-fontify-variables
verilog-getopt-flags-hook
verilog-highlight-grouping-keywords
verilog-highlight-includes
verilog-highlight-modules
verilog-highlight-translate-off
verilog-indent-begin-after-if
+ verilog-indent-class-inside-pkg
verilog-indent-declaration-macros
+ verilog-indent-ignore-multiline-defines
+ verilog-indent-ignore-regexp
verilog-indent-level
verilog-indent-level-behavioral
verilog-indent-level-declaration
diff --git a/lisp/progmodes/vhdl-mode.el b/lisp/progmodes/vhdl-mode.el
index a9a25f6ec89..144bfa944d3 100644
--- a/lisp/progmodes/vhdl-mode.el
+++ b/lisp/progmodes/vhdl-mode.el
@@ -6,7 +6,7 @@
;; Rodney J. Whitby <software.vhdl-mode@rwhitby.net>
;; Maintainer: Reto Zimmermann <reto@gnu.org>
;; Keywords: languages vhdl
-;; WWW: https://guest.iis.ee.ethz.ch/~zimmi/emacs/vhdl-mode.html
+;; URL: https://iis-people.ee.ethz.ch/~zimmi/emacs/vhdl-mode.html
;; Yoni Rabkin <yoni@rabkins.net> contacted the maintainer of this
;; file on 18/3/2008, and the maintainer agreed that when a bug is
@@ -457,7 +457,7 @@ If no file name at all is printed out, set both \"File Message\" entries to 0
\(a default file name message will be printed out instead, does not work in
XEmacs).
-A compiler is selected for syntax analysis (`\\[vhdl-compile]') by
+A compiler is selected for syntax analysis (\\[vhdl-compile]) by
assigning its name to option `vhdl-compiler'.
Please send any missing or erroneous compiler properties to the maintainer for
@@ -1106,14 +1106,14 @@ For more information on format strings, see the documentation for the
(defcustom vhdl-modify-date-prefix-string "-- Last update: "
"Prefix string of modification date in VHDL file header.
If actualization of the modification date is called (menu,
-`\\[vhdl-template-modify]'), this string is searched and the rest
+\\[vhdl-template-modify]), this string is searched and the rest
of the line replaced by the current date."
:type 'string
:group 'vhdl-header)
(defcustom vhdl-modify-date-on-saving t
"Non-nil means update the modification date when the buffer is saved.
-Calls function `\\[vhdl-template-modify]').
+Calls function \\[vhdl-template-modify]).
NOTE: Activate the new setting in a VHDL buffer by using the menu entry
\"Activate Options\"."
@@ -4469,7 +4469,7 @@ Usage:
according to option `vhdl-argument-list-indent'.
If option `vhdl-indent-tabs-mode' is nil, spaces are used instead of
- tabs. `\\[tabify]' and `\\[untabify]' allow the conversion of spaces to
+ tabs. \\[tabify] and \\[untabify] allow the conversion of spaces to
tabs and vice versa.
Syntax-based indentation can be very slow in large files. Option
@@ -4780,7 +4780,7 @@ Usage:
`vhdl-highlight-translate-off' is non-nil.
For documentation and customization of the used colors see
- customization group `vhdl-highlight-faces' (`\\[customize-group]'). For
+ customization group `vhdl-highlight-faces' (\\[customize-group]). For
highlighting of matching parenthesis, see customization group
`paren-showing'. Automatic buffer highlighting is turned on/off by
option `global-font-lock-mode' (`font-lock-auto-fontify' in XEmacs).
@@ -4840,14 +4840,14 @@ Usage:
sessions using the \"Save Options\" menu entry.
Options and their detailed descriptions can also be accessed by using
- the \"Customize\" menu entry or the command `\\[customize-option]'
- (`\\[customize-group]' for groups). Some customizations only take effect
+ the \"Customize\" menu entry or the command \\[customize-option]
+ (\\[customize-group] for groups). Some customizations only take effect
after some action (read the NOTE in the option documentation).
Customization can also be done globally (i.e. site-wide, read the
INSTALL file).
Not all options are described in this documentation, so go and see
- what other useful user options there are (`\\[vhdl-customize]' or menu)!
+ what other useful user options there are (\\[vhdl-customize] or menu)!
FILE EXTENSIONS:
@@ -4876,7 +4876,7 @@ Usage:
Maintenance:
------------
-To submit a bug report, enter `\\[vhdl-submit-bug-report]' within VHDL Mode.
+To submit a bug report, enter \\[vhdl-submit-bug-report] within VHDL Mode.
Add a description of the problem and include a reproducible test case.
Questions and enhancement requests can be sent to <reto@gnu.org>.
@@ -8398,6 +8398,44 @@ buffer."
(message "Updating sensitivity lists...done")))
(when noninteractive (save-buffer)))
+(defun vhdl--re2-region (beg-re end-re)
+ "Return a function searching for a region delimited by a pair of regexps.
+BEG-RE and END-RE are the regexps delimiting the region to search for."
+ (lambda (proc-end)
+ (when (vhdl-re-search-forward beg-re proc-end t)
+ (save-excursion
+ (vhdl-re-search-forward end-re proc-end t)))))
+
+(defconst vhdl--signal-regions-functions
+ (list
+ ;; right-hand side of signal/variable assignment
+ ;; (special case: "<=" is relational operator in a condition)
+ (vhdl--re2-region "[<:]="
+ ";\\|\\<\\(then\\|loop\\|report\\|severity\\|is\\)\\>")
+ ;; if condition
+ (vhdl--re2-region "^\\s-*if\\>" "\\<then\\>")
+ ;; elsif condition
+ (vhdl--re2-region "\\<elsif\\>" "\\<then\\>")
+ ;; while loop condition
+ (vhdl--re2-region "^\\s-*while\\>" "\\<loop\\>")
+ ;; exit/next condition
+ (vhdl--re2-region "\\<\\(exit\\|next\\)\\s-+\\w+\\s-+when\\>" ";")
+ ;; assert condition
+ (vhdl--re2-region "\\<assert\\>" "\\(\\<report\\>\\|\\<severity\\>\\|;\\)")
+ ;; case expression
+ (vhdl--re2-region "^\\s-*case\\>" "\\<is\\>")
+ ;; parameter list of procedure call, array index
+ (lambda (proc-end)
+ (when (re-search-forward "^\\s-*\\(\\w\\|\\.\\)+[ \t\n\r\f]*(" proc-end t)
+ (forward-char -1)
+ (save-excursion
+ (forward-sexp)
+ (while (looking-at "(") (forward-sexp)) (point)))))
+ "Define syntactic regions where signals are read.
+Each function is called with one arg (a limit for the (forward) search) and
+should return either nil or the end position of the region (in which case
+point will be set to its beginning).")
+
(defun vhdl-update-sensitivity-list ()
"Update sensitivity list."
(let ((proc-beg (point))
@@ -8418,35 +8456,6 @@ buffer."
(let
;; scan for visible signals
((visible-list (vhdl-get-visible-signals))
- ;; define syntactic regions where signals are read
- (scan-regions-list
- `(;; 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))
- ;; if condition
- ((vhdl-re-search-forward "^\\s-*if\\>" ,proc-end t)
- (vhdl-re-search-forward "\\<then\\>" ,proc-end t))
- ;; elsif condition
- ((vhdl-re-search-forward "\\<elsif\\>" ,proc-end t)
- (vhdl-re-search-forward "\\<then\\>" ,proc-end t))
- ;; while loop condition
- ((vhdl-re-search-forward "^\\s-*while\\>" ,proc-end t)
- (vhdl-re-search-forward "\\<loop\\>" ,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))
- ;; assert condition
- ((vhdl-re-search-forward "\\<assert\\>" ,proc-end t)
- (vhdl-re-search-forward "\\(\\<report\\>\\|\\<severity\\>\\|;\\)" ,proc-end t))
- ;; case expression
- ((vhdl-re-search-forward "^\\s-*case\\>" ,proc-end t)
- (vhdl-re-search-forward "\\<is\\>" ,proc-end t))
- ;; parameter list of procedure call, array index
- ((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)))))
name field read-list sens-list signal-list tmp-list
sens-beg sens-end beg end margin)
;; scan for signals in old sensitivity list
@@ -8475,11 +8484,9 @@ buffer."
(push (cons end (point)) seq-region-list)
(beginning-of-line)))
;; scan for signals read in process
- (while scan-regions-list
+ (dolist (scan-fun vhdl--signal-regions-functions)
(goto-char proc-mid)
- (while (and (setq beg (eval (nth 0 (car scan-regions-list))))
- (setq end (eval (nth 1 (car scan-regions-list)))))
- (goto-char beg)
+ (while (setq end (funcall scan-fun proc-end))
(unless (or (vhdl-in-literal)
(and seq-region-list
(let ((tmp-list seq-region-list))
@@ -8518,8 +8525,7 @@ buffer."
(car tmp-list))
(setq read-list (delete (car tmp-list) read-list)))
(setq tmp-list (cdr tmp-list)))))
- (goto-char (match-end 1)))))
- (setq scan-regions-list (cdr scan-regions-list)))
+ (goto-char (match-end 1))))))
;; update sensitivity list
(goto-char sens-beg)
(if sens-end
@@ -11769,8 +11775,8 @@ reflected in a subsequent paste operation."
(setq comment (substring type (match-beginning 2)))
(setq type (substring type 0 (match-beginning 1))))
;; strip of trailing group-comment
- (string-match "\\(\\(\\s-*\\S-+\\)+\\)\\s-*" type)
- (setq type (substring type 0 (match-end 1)))
+ (when (string-match "\\S-\\s-*\\'" type)
+ (setq type (substring type 0 (1+ (match-beginning 0)))))
;; parse initialization expression
(setq init nil)
(when (vhdl-parse-string ":=[ \t\n\r\f]*" t)
@@ -11844,8 +11850,8 @@ reflected in a subsequent paste operation."
(setq comment (substring type (match-beginning 2)))
(setq type (substring type 0 (match-beginning 1))))
;; strip of trailing group-comment
- (string-match "\\(\\(\\s-*\\S-+\\)+\\)\\s-*" type)
- (setq type (substring type 0 (match-end 1)))
+ (when (string-match "\\S-\\s-*\\'" type)
+ (setq type (substring type 0 (1+ (match-beginning 0)))))
(vhdl-forward-syntactic-ws)
(setq end-of-list (vhdl-parse-string ")" t))
(vhdl-parse-string "\\s-*;\\s-*")
@@ -12580,8 +12586,8 @@ reflected in a subsequent paste operation."
(setq comment (substring type (match-beginning 2)))
(setq type (substring type 0 (match-beginning 1))))
;; strip off trailing group-comment
- (string-match "\\(\\(\\s-*\\S-+\\)+\\)\\s-*" type)
- (setq type (substring type 0 (match-end 1)))
+ (when (string-match "\\S-\\s-*\\'" type)
+ (setq type (substring type 0 (1+ (match-beginning 0)))))
;; parse initialization expression
(setq init nil)
(when (vhdl-parse-string ":=[ \t\n\r\f]*" t)
@@ -12621,8 +12627,9 @@ reflected in a subsequent paste operation."
(setq return-comment (substring return-type (match-beginning 2)))
(setq return-type (substring return-type 0 (match-beginning 1))))
;; strip of trailing group-comment
- (string-match "\\(\\(\\s-*\\S-+\\)+\\)\\s-*" return-type)
- (setq return-type (substring return-type 0 (match-end 1)))
+ (when (string-match "\\S-\\s-*\\'" return-type)
+ (setq return-type
+ (substring return-type 0 (1+ (match-beginning 0)))))
;; parse return comment
(unless return-comment
(setq return-comment (and (vhdl-parse-string "--\\s-*\\([^\n]*\\)" t)
@@ -14977,9 +14984,9 @@ otherwise use cached data."
(vhdl-aput 'vhdl-directory-alist directory (list (list directory))))
(defun vhdl-speedbar-insert-hierarchy ( ent-alist-arg conf-alist-arg
- package-alist ent-inst-list depth)
- "Insert hierarchy of ENT-ALIST-ARG, CONF-ALIST-ARG, and PACKAGE-ALIST."
- (if (not (or ent-alist-arg conf-alist-arg package-alist))
+ pkg-alist ent-inst-list depth)
+ "Insert hierarchy of ENT-ALIST-ARG, CONF-ALIST-ARG, and PKG-ALIST."
+ (if (not (or ent-alist-arg conf-alist-arg pkg-alist))
(vhdl-speedbar-make-title-line "No VHDL design units!" depth)
(let ((ent-alist ent-alist-arg)
(conf-alist conf-alist-arg)
@@ -15009,15 +15016,15 @@ otherwise use cached data."
'vhdl-speedbar-configuration-face depth)
(setq conf-alist (cdr conf-alist)))
;; insert packages
- (when package-alist (vhdl-speedbar-make-title-line "Packages:" depth))
- (while package-alist
- (setq pack-entry (car package-alist))
+ (when pkg-alist (vhdl-speedbar-make-title-line "Packages:" depth))
+ (while pkg-alist
+ (setq pack-entry (car pkg-alist))
(vhdl-speedbar-make-pack-line
(nth 0 pack-entry) (nth 1 pack-entry)
(cons (nth 2 pack-entry) (nth 3 pack-entry))
(cons (nth 7 pack-entry) (nth 8 pack-entry))
depth)
- (setq package-alist (cdr package-alist))))))
+ (setq pkg-alist (cdr pkg-alist))))))
(declare-function speedbar-line-directory "speedbar" (&optional depth))
diff --git a/lisp/progmodes/which-func.el b/lisp/progmodes/which-func.el
index 800da1cd6c7..b36e13104e3 100644
--- a/lisp/progmodes/which-func.el
+++ b/lisp/progmodes/which-func.el
@@ -86,6 +86,17 @@ long time to send the information, you can use this option to delay
activation of Which Function until Imenu is used for the first time."
:type '(repeat (symbol :tag "Major mode")))
+(defcustom which-func-display 'mode
+ "Where to display the function name.
+
+If `mode', display in the mode line. If `header', display in the
+header line. If `mode-and-header', display in both."
+ :type '(choice (const :tag "Display in mode line" mode)
+ (const :tag "Display in header line" header)
+ (const :tag "Display in both header and mode line"
+ mode-and-header))
+ :version "30.1")
+
(defcustom which-func-maxout 500000
"Don't automatically compute the Imenu menu if buffer is this big or bigger.
Zero means compute the Imenu menu regardless of size.
@@ -184,17 +195,42 @@ and you want to simplify them for the mode line
;;;###autoload (put 'which-func-current 'risky-local-variable t)
(defvar-local which-func-mode nil
- "Non-nil means display current function name in mode line.
+ "Non-nil means display current function name in mode or header line.
This makes a difference only if variable `which-function-mode' is
non-nil.")
+(defvar-local which-func--use-header-line nil
+ "If non-nil, display the function name in the header line.")
+
+(defvar-local which-func--use-mode-line nil
+ "If non-nil, display the function name in the mode line.")
+
(add-hook 'after-change-major-mode-hook #'which-func-ff-hook t)
(defun which-func-try-to-enable ()
- (unless (or (not which-function-mode)
- (local-variable-p 'which-func-mode))
- (setq which-func-mode (or (eq which-func-modes t)
- (member major-mode which-func-modes)))))
+ (when which-function-mode
+ (unless (local-variable-p 'which-func-mode)
+ (setq which-func-mode (or (eq which-func-modes t)
+ (derived-mode-p which-func-modes)))
+ (setq which-func--use-mode-line
+ (member which-func-display '(mode mode-and-header)))
+ (setq which-func--use-header-line
+ (member which-func-display '(header mode-and-header))))
+ ;; We might need to re-add which-func-format to the header line,
+ ;; if which-function-mode was toggled off and on.
+ (when (and which-func-mode which-func--use-header-line
+ (listp header-line-format))
+ (add-to-list 'header-line-format '("" which-func-format " ")))))
+
+(defun which-func--header-line-remove ()
+ (when (and which-func-mode which-func--use-header-line
+ (listp header-line-format))
+ (setq header-line-format
+ (delete '("" which-func-format " ") header-line-format))))
+
+(defun which-func--disable ()
+ (which-func--header-line-remove)
+ (setq which-func-mode nil))
(defun which-func-ff-hook ()
"`after-change-major-mode-hook' for Which Function mode.
@@ -203,17 +239,17 @@ It creates the Imenu index for the buffer, if necessary."
(condition-case err
(if (and which-func-mode
- (not (member major-mode which-func-non-auto-modes))
+ (not (derived-mode-p which-func-non-auto-modes))
(or (null which-func-maxout)
(< buffer-saved-size which-func-maxout)
(= which-func-maxout 0)))
(setq imenu--index-alist
(save-excursion (funcall imenu-create-index-function))))
(imenu-unavailable
- (setq which-func-mode nil))
+ (which-func--disable))
(error
(message "which-func-ff-hook error: %S" err)
- (setq which-func-mode nil))))
+ (which-func--disable))))
(defun which-func-update ()
"Update the Which-Function mode display in the current window."
@@ -231,7 +267,7 @@ It creates the Imenu index for the buffer, if necessary."
(puthash window current which-func-table)
(force-mode-line-update)))
(error
- (setq which-func-mode nil)
+ (which-func--disable)
(error "Error in which-func-update: %S" info))))))
(defvar which-func-update-timer nil)
@@ -241,7 +277,8 @@ It creates the Imenu index for the buffer, if necessary."
(add-to-list 'mode-line-misc-info
'(which-function-mode ;Only display if mode is enabled.
(which-func-mode ;Only display if buffer supports it.
- ("" which-func-format " ")))))
+ (which-func--use-mode-line
+ ("" which-func-format " "))))))
;; This is the name people would normally expect.
;;;###autoload
@@ -258,9 +295,11 @@ in certain major modes."
(when which-function-mode
;;Turn it on.
(setq which-func-update-timer
- (run-with-idle-timer idle-update-delay t #'which-func-update))
- (dolist (buf (buffer-list))
- (with-current-buffer buf (which-func-try-to-enable)))))
+ (run-with-idle-timer idle-update-delay t #'which-func-update)))
+ (dolist (buf (buffer-list))
+ (with-current-buffer buf
+ (which-func--header-line-remove)
+ (which-func-ff-hook))))
(defvar which-function-imenu-failed nil
"Locally t in a buffer if `imenu--make-index-alist' found nothing there.")
diff --git a/lisp/progmodes/xref.el b/lisp/progmodes/xref.el
index c70bd5dbd60..755c3db04fd 100644
--- a/lisp/progmodes/xref.el
+++ b/lisp/progmodes/xref.el
@@ -281,9 +281,10 @@ current project's main and external roots."
(xref-references-in-directory identifier dir)
(message "Searching %s... done" dir)))
(let ((pr (project-current t)))
- (cons
- (xref--project-root pr)
- (project-external-roots pr)))))
+ (project-combine-directories
+ (cons
+ (xref--project-root pr)
+ (project-external-roots pr))))))
(cl-defgeneric xref-backend-apropos (backend pattern)
"Find all symbols that match PATTERN string.
@@ -638,6 +639,18 @@ If SELECT is non-nil, select the target window."
"Face used to highlight matches in the xref buffer."
:version "28.1")
+(defvar-local xref-num-matches-found 0)
+
+(defvar xref-num-matches-face 'compilation-info
+ "Face name to show the number of matches on the mode line.")
+
+(defconst xref-mode-line-matches
+ `(" [" (:propertize (:eval (int-to-string xref-num-matches-found))
+ face ,xref-num-matches-face
+ help-echo "Number of matches so far")
+ "]"))
+(put 'xref-mode-line-matches 'risky-local-variable t)
+
(defmacro xref--with-dedicated-window (&rest body)
`(let* ((xref-w (get-buffer-window xref-buffer-name))
(xref-w-dedicated (window-dedicated-p xref-w)))
@@ -1235,6 +1248,8 @@ Return an alist of the form ((GROUP . (XREF ...)) ...)."
(xref--ensure-default-directory dd (current-buffer))
(xref--xref-buffer-mode)
(xref--show-common-initialize xref-alist fetcher alist)
+ (setq xref-num-matches-found (length xrefs))
+ (setq mode-line-process (list xref-mode-line-matches))
(pop-to-buffer (current-buffer))
(setq buf (current-buffer)))
(xref--auto-jump-first buf (assoc-default 'auto-jump alist))
@@ -1468,7 +1483,6 @@ The meanings of both arguments are the same as documented in
(xref--show-xrefs fetcher display-action))
(defun xref--show-xrefs (fetcher display-action &optional _always-show-list)
- (xref--push-markers)
(unless (functionp fetcher)
;; Old convention.
(let ((xrefs fetcher))
@@ -1479,21 +1493,32 @@ The meanings of both arguments are the same as documented in
(prog1
xrefs
(setq xrefs 'called-already)))))))
- (funcall xref-show-xrefs-function fetcher
- `((window . ,(selected-window))
- (display-action . ,display-action)
- (auto-jump . ,xref-auto-jump-to-first-xref))))
+ (let ((cb (current-buffer))
+ (pt (point)))
+ (prog1
+ (funcall xref-show-xrefs-function fetcher
+ `((window . ,(selected-window))
+ (display-action . ,display-action)
+ (auto-jump . ,xref-auto-jump-to-first-xref)))
+ (xref--push-markers cb pt))))
(defun xref--show-defs (xrefs display-action)
- (xref--push-markers)
- (funcall xref-show-definitions-function xrefs
- `((window . ,(selected-window))
- (display-action . ,display-action)
- (auto-jump . ,xref-auto-jump-to-first-definition))))
-
-(defun xref--push-markers ()
- (unless (region-active-p) (push-mark nil t))
- (xref-push-marker-stack))
+ (let ((cb (current-buffer))
+ (pt (point)))
+ (prog1
+ (funcall xref-show-definitions-function xrefs
+ `((window . ,(selected-window))
+ (display-action . ,display-action)
+ (auto-jump . ,xref-auto-jump-to-first-definition)))
+ (xref--push-markers cb pt))))
+
+(defun xref--push-markers (buf pt)
+ (when (buffer-live-p buf)
+ (save-excursion
+ (with-no-warnings (set-buffer buf))
+ (goto-char pt)
+ (unless (region-active-p) (push-mark nil t))
+ (xref-push-marker-stack))))
(defun xref--prompt-p (command)
(or (eq xref-prompt-for-identifier t)
@@ -1525,7 +1550,7 @@ The meanings of both arguments are the same as documented in
prompt))
(xref-backend-identifier-completion-table backend)
nil nil nil
- 'xref--read-identifier-history def)))
+ 'xref--read-identifier-history def t)))
(if (equal id "")
(or def (user-error "There is no default identifier"))
id)))
@@ -1613,7 +1638,8 @@ is nil, prompt only if there's no usable symbol at point."
(defun xref-find-references-and-replace (from to)
"Replace all references to identifier FROM with TO."
(interactive
- (let* ((query-replace-read-from-default 'find-tag-default)
+ (let* ((query-replace-read-from-default
+ (lambda () (xref-backend-identifier-at-point (xref-find-backend))))
(common
(query-replace-read-args "Query replace identifier" nil)))
(list (nth 0 common) (nth 1 common))))
@@ -1637,7 +1663,9 @@ This command is intended to be bound to a mouse event."
(mouse-set-point event)
(xref-backend-identifier-at-point (xref-find-backend)))))
(if identifier
- (xref-find-definitions identifier)
+ (progn
+ (mouse-set-point event)
+ (xref-find-definitions identifier))
(user-error "No identifier here"))))
;;;###autoload
@@ -1651,6 +1679,7 @@ This command is intended to be bound to a mouse event."
(xref-backend-identifier-at-point (xref-find-backend)))))
(if identifier
(let ((xref-prompt-for-identifier nil))
+ (mouse-set-point event)
(xref-find-references identifier))
(user-error "No identifier here"))))
@@ -2147,7 +2176,7 @@ Such as the current syntax table and the applied syntax properties."
(or
(buffer-modified-p buf)
(unless xref--hits-remote-id
- (not (verify-visited-file-modtime (current-buffer))))))
+ (not (verify-visited-file-modtime buf)))))
;; We can't use buffers whose contents diverge from disk (bug#54025).
(setq buf nil))
(setq xref--last-file-buffer (cons file buf))))
diff --git a/lisp/ps-bdf.el b/lisp/ps-bdf.el
index 741921bc02f..ee754077009 100644
--- a/lisp/ps-bdf.el
+++ b/lisp/ps-bdf.el
@@ -11,7 +11,7 @@
;; Author: Kenichi Handa <handa@gnu.org>
;; (according to ack.texi)
-;; Keywords: wp, BDF, font, PostScript
+;; Keywords: text, BDF, font, PostScript
;; Package: ps-print
;; This file is part of GNU Emacs.
diff --git a/lisp/ps-mule.el b/lisp/ps-mule.el
index 06889d28614..1ea4d8f7097 100644
--- a/lisp/ps-mule.el
+++ b/lisp/ps-mule.el
@@ -4,7 +4,7 @@
;; Author: Vinicius Jose Latorre <viniciusjl.gnu@gmail.com>
;; Kenichi Handa <handa@gnu.org> (multi-byte characters)
-;; Keywords: wp, print, PostScript, multibyte, mule
+;; Keywords: text, print, PostScript, multibyte, mule
;; Package: ps-print
;; This file is part of GNU Emacs.
diff --git a/lisp/ps-print.el b/lisp/ps-print.el
index e5a9d58aa41..b73d28280ef 100644
--- a/lisp/ps-print.el
+++ b/lisp/ps-print.el
@@ -7,7 +7,7 @@
;; Vinicius Jose Latorre <viniciusjl.gnu@gmail.com>
;; Kenichi Handa <handa@gnu.org> (multi-byte characters)
;; Maintainer: Vinicius Jose Latorre <viniciusjl.gnu@gmail.com>
-;; Keywords: wp, print, PostScript
+;; Keywords: text, print, PostScript
;; Old-Version: 7.3.5
;; URL: https://www.emacswiki.org/cgi-bin/wiki/ViniciusJoseLatorre
@@ -4850,17 +4850,6 @@ page-height == ((floor print-height ((th + ls) * zh)) * ((th + ls) * zh)) - th
(and has-local-background (ps-output "}def\n"))))
-;; Return a list of the distinct elements of LIST.
-;; Elements are compared with `equal'.
-(defun ps-remove-duplicates (list)
- (let (new (tail list))
- (while tail
- (or (member (car tail) new)
- (setq new (cons (car tail) new)))
- (setq tail (cdr tail)))
- (nreverse new)))
-
-
;; Find the first occurrence of ITEM in LIST.
;; Return the index of the matching item, or nil if not found.
;; Elements are compared with `eq'.
@@ -5342,7 +5331,7 @@ XSTART YSTART are the relative position for the first page in a sheet.")
(if ps-landscape-mode "Landscape" "Portrait")
"\n%%DocumentNeededResources: font Times-Roman Times-Italic\n%%+ font "
(mapconcat 'identity
- (ps-remove-duplicates
+ (seq-uniq
(append (ps-fonts 'ps-font-for-text)
(list (ps-font 'ps-font-for-header 'normal)
(ps-font 'ps-font-for-header 'bold)
@@ -5491,7 +5480,7 @@ XSTART YSTART are the relative position for the first page in a sheet.")
"\n%%IncludeResource: font Times-Italic"
"\n%%IncludeResource: font "
(mapconcat 'identity
- (ps-remove-duplicates
+ (seq-uniq
(append (ps-fonts 'ps-font-for-text)
(list (ps-font 'ps-font-for-header 'normal)
(ps-font 'ps-font-for-header 'bold)
@@ -6548,6 +6537,7 @@ Please send all bug fixes and enhancements to
(make-obsolete-variable 'ps-print-version 'emacs-version "29.1")
(define-obsolete-function-alias 'ps-print-ensure-fontified #'font-lock-ensure "29.1")
+(define-obsolete-function-alias 'ps-remove-duplicates #'seq-uniq "30.1")
(provide 'ps-print)
diff --git a/lisp/ps-samp.el b/lisp/ps-samp.el
index 4b418faa932..828a9eb5f08 100644
--- a/lisp/ps-samp.el
+++ b/lisp/ps-samp.el
@@ -7,7 +7,7 @@
;; Vinicius Jose Latorre <viniciusjl.gnu@gmail.com>
;; Kenichi Handa <handa@gnu.org> (multi-byte characters)
;; Maintainer: Vinicius Jose Latorre <viniciusjl.gnu@gmail.com>
-;; Keywords: wp, print, PostScript
+;; Keywords: text, print, PostScript
;; URL: https://www.emacswiki.org/cgi-bin/wiki/ViniciusJoseLatorre
;; Package: ps-print
diff --git a/lisp/recentf.el b/lisp/recentf.el
index 0d46078c4dc..2529424b8eb 100644
--- a/lisp/recentf.el
+++ b/lisp/recentf.el
@@ -112,11 +112,15 @@ must return non-nil to exclude it."
:group 'recentf
:type '(repeat (choice regexp function)))
+(defun recentf-access-file (filename)
+ "Check whether FILENAME is accessible."
+ (ignore-errors (not (access-file filename "Checking recentf file"))))
+
(defun recentf-keep-default-predicate (file)
"Return non-nil if FILE should be kept in the recent list.
It handles the case of remote files as well."
(cond
- ((file-remote-p file nil t) (file-readable-p file))
+ ((file-remote-p file nil t) (recentf-access-file file))
((file-remote-p file))
((file-readable-p file))))
@@ -801,25 +805,31 @@ Filenames are relative to the `default-directory'."
;;; Rule based menu filters
;;
(defcustom recentf-arrange-rules
- '(
- ("Elisp files (%d)" ".\\.el\\'")
- ("Java files (%d)" ".\\.java\\'")
- ("C/C++ files (%d)" "c\\(pp\\)?\\'")
+ `(
+ ("Elisp files (%d)" ,(rx nonl ".el" eos))
+ ("C/C++ files (%d)" ,(rx nonl "."
+ (or "c" "cc" "cpp" "h" "hpp" "cxx" "hxx")
+ eos))
+ ("Python files (%d)" ,(rx nonl ".py" eos))
+ ("Java files (%d)" ,(rx nonl ".java" eos))
)
"List of rules used by `recentf-arrange-by-rule' to build sub-menus.
+
A rule is a pair (SUB-MENU-TITLE . MATCHER). SUB-MENU-TITLE is the
displayed title of the sub-menu where a `%d' `format' pattern is
replaced by the number of items in the sub-menu. MATCHER is a regexp
or a list of regexps. Items matching one of the regular expressions in
MATCHER are added to the corresponding sub-menu.
-SUB-MENU-TITLE can be a function. It is passed every items that
+
+SUB-MENU-TITLE can be a function. It is passed every item that
matched the corresponding MATCHER, and it must return a
pair (SUB-MENU-TITLE . ITEM). SUB-MENU-TITLE is a computed sub-menu
title that can be another function. ITEM is the received item which
may have been modified to match another rule."
:group 'recentf-filters
:type '(repeat (cons (choice string function)
- (repeat regexp))))
+ (repeat regexp)))
+ :version "30.1")
(defcustom recentf-arrange-by-rule-others "Other files (%d)"
"Title of the `recentf-arrange-by-rule' sub-menu.
diff --git a/lisp/rect.el b/lisp/rect.el
index 20f68cf0152..0212dedcb48 100644
--- a/lisp/rect.el
+++ b/lisp/rect.el
@@ -212,7 +212,10 @@ The returned value has the form of (WIDTH . HEIGHT)."
(cons width height))))
(defun delete-rectangle-line (startcol endcol fill)
- (when (= (move-to-column startcol (if fill t 'coerce)) startcol)
+ ;; We use >= here, not =, for characters that use more than one
+ ;; column on display, when STARTCOL is in the middle of such a
+ ;; character.
+ (when (>= (move-to-column startcol (if fill t 'coerce)) startcol)
(delete-region (point)
(progn (move-to-column endcol 'coerce)
(point)))))
@@ -279,7 +282,8 @@ When called from a program the rectangle's corners are START and END.
With a prefix (or a FILL) argument, also fill lines where nothing has
to be deleted."
(interactive "*r\nP")
- (apply-on-rectangle 'delete-rectangle-line start end fill))
+ (let (indent-tabs-mode)
+ (apply-on-rectangle 'delete-rectangle-line start end fill)))
;;;###autoload
(defun delete-extract-rectangle (start end &optional fill)
@@ -334,7 +338,8 @@ you can use this command to copy text from a read-only buffer.
even beep.)"
(interactive "r\nP")
(condition-case nil
- (setq killed-rectangle (delete-extract-rectangle start end fill))
+ (let (indent-tabs-mode)
+ (setq killed-rectangle (delete-extract-rectangle start end fill)))
((buffer-read-only text-read-only)
(setq deactivate-mark t)
(setq killed-rectangle (extract-rectangle start end))
@@ -930,8 +935,9 @@ Ignores `line-move-visual'."
(mapc #'delete-overlay (nthcdr 5 rol))
(setcar (cdr rol) nil)))
-(defun rectangle--duplicate-right (n)
- "Duplicate the rectangular region N times on the right-hand side."
+(defun rectangle--duplicate-right (n displacement)
+ "Duplicate the rectangular region N times on the right-hand side.
+Leave the region moved DISPLACEMENT region-wide steps to the right."
(let ((cols (rectangle--pos-cols (point) (mark))))
(apply-on-rectangle
(lambda (startcol endcol)
@@ -942,15 +948,20 @@ Ignores `line-move-visual'."
(insert (cadr lines)))))
(min (point) (mark))
(max (point) (mark)))
- ;; Recompute the rectangle state; no crutches should be needed now.
- (let ((p (point))
- (m (mark)))
+ ;; Recompute the rectangle state.
+ (let* ((p (point))
+ (m (mark))
+ (point-col (car cols))
+ (mark-col (cdr cols))
+ (d (* displacement (abs (- point-col mark-col)))))
(rectangle--reset-crutches)
(goto-char m)
- (move-to-column (cdr cols) t)
- (set-mark (point))
+ (move-to-column (+ mark-col d) t)
+ (if (= d 0)
+ (set-mark (point))
+ (push-mark (point)))
(goto-char p)
- (move-to-column (car cols) t))))
+ (move-to-column (+ point-col d) t))))
(provide 'rect)
diff --git a/lisp/register.el b/lisp/register.el
index 609c1450f49..822467a0d72 100644
--- a/lisp/register.el
+++ b/lisp/register.el
@@ -35,6 +35,8 @@
;; FIXME: Clean up namespace usage!
+(declare-function frameset-register-p "frameset")
+
(cl-defstruct
(registerv (:constructor nil)
(:constructor registerv--make (&optional data print-func
@@ -94,17 +96,75 @@ of the marked text."
(defcustom register-preview-delay 1
"If non-nil, time to wait in seconds before popping up register preview window.
If nil, do not show register previews, unless `help-char' (or a member of
-`help-event-list') is pressed."
+`help-event-list') is pressed.
+
+This variable has no effect when `register-use-preview' is set to any
+value except \\='traditional."
:version "24.4"
:type '(choice number (const :tag "No preview unless requested" nil))
:group 'register)
+(defcustom register-preview-default-keys (mapcar #'string (number-sequence ?a ?z))
+ "Default keys for setting a new register."
+ :type '(repeat string)
+ :version "30.1")
+
+(defvar register--read-with-preview-function nil
+ "Function to use for reading a register name with preview.
+Two functions are provided, one that provide navigation and highlighting
+of the selected register, filtering of register according to command in
+use, defaults register to use when setting a new register, confirmation
+and notification when you are about to overwrite a register, and generic
+functions to configure how each existing command behaves. Use the
+function `register-read-with-preview-fancy' for this. The other
+provided function, `register-read-with-preview-traditional', behaves
+the same as in Emacs 29 and before: no filtering, no navigation,
+and no defaults.")
+
+(defvar register-preview-function nil
+ "Function to format a register for previewing.
+Called with one argument, a cons (NAME . CONTENTS), as found
+in `register-alist'. The function should return a string, the
+description of the argument. The function to use is set according
+to the value of `register--read-with-preview-function'.")
+
+(defcustom register-use-preview 'traditional
+ "Whether to show register preview when modifying registers.
+
+When set to `t', show a preview buffer with navigation and
+highlighting.
+When set to \\='insist, behave as with `t', but allow exiting the
+minibuffer by pressing the register name a second time. E.g.,
+press \"a\" to select register \"a\", then press \"a\" again to
+exit the minibuffer.
+When nil, show a preview buffer without navigation and highlighting, and
+exit the minibuffer immediately after inserting response in minibuffer.
+When set to \\='never, behave as with nil, but with no preview buffer at
+all; the preview buffer is still accessible with `help-char' (C-h).
+When set to \\='traditional (the default), provide a more basic preview
+according to `register-preview-delay'; this preserves the traditional
+behavior of Emacs 29 and before."
+ :type '(choice
+ (const :tag "Use preview" t)
+ (const :tag "Use preview and exit by pressing register name" insist)
+ (const :tag "Use quick preview" nil)
+ (const :tag "Never use preview" never)
+ (const :tag "Basic preview like Emacs-29" traditional))
+ :version "30.1"
+ :set (lambda (var val)
+ (set var val)
+ (setq register--read-with-preview-function
+ (if (eq val 'traditional)
+ #'register-read-with-preview-traditional
+ #'register-read-with-preview-fancy))
+ (setq register-preview-function nil)))
+
(defun get-register (register)
"Return contents of Emacs register named REGISTER, or nil if none."
(alist-get register register-alist))
(defun set-register (register value)
- "Set contents of Emacs register named REGISTER to VALUE. Return VALUE.
+ "Set contents of Emacs register named REGISTER to VALUE, return VALUE.
See the documentation of the variable `register-alist' for possible VALUEs."
(setf (alist-get register register-alist) value))
@@ -117,42 +177,290 @@ See the documentation of the variable `register-alist' for possible VALUEs."
(substring d (match-end 0))
d)))
+(defun register-preview-default-1 (r)
+ "Function used to format a register for fancy previewing.
+This is used as the value of the variable `register-preview-function'
+when `register-use-preview' is set to t or nil."
+ (format "%s: %s\n"
+ (propertize (string (car r))
+ 'display (single-key-description (car r)))
+ (register-describe-oneline (car r))))
+
(defun register-preview-default (r)
- "Function that is the default value of the variable `register-preview-function'."
+ "Function used to format a register for traditional preview.
+This is the default value of the variable `register-preview-function',
+and is used when `register-use-preview' is set to \\='traditional."
(format "%s: %s\n"
(single-key-description (car r))
(register-describe-oneline (car r))))
-(defvar register-preview-function #'register-preview-default
- "Function to format a register for previewing.
-Called with one argument, a cons (NAME . CONTENTS) as found in `register-alist'.
-The function should return a string, the description of the argument.")
+(cl-defgeneric register--preview-function (read-preview-function)
+ "Return a function to format registers for previewing by READ-PREVIEW-FUNCTION.")
+(cl-defmethod register--preview-function ((_read-preview-function
+ (eql register-read-with-preview-traditional)))
+ #'register-preview-default)
+(cl-defmethod register--preview-function ((_read-preview-function
+ (eql register-read-with-preview-fancy)))
+ #'register-preview-default-1)
+
+(cl-defstruct register-preview-info
+ "Store data for a specific register command.
+TYPES are the supported types of registers.
+MSG is the minibuffer message to show when a register is selected.
+ACT is the type of action the command is doing on register.
+SMATCH accept a boolean value to say if the command accepts non-matching
+registers.
+If NOCONFIRM is non-nil, request confirmation of register name by RET."
+ types msg act smatch noconfirm)
+
+(cl-defgeneric register-command-info (command)
+ "Return a `register-preview-info' object storing data for COMMAND."
+ (ignore command))
+(cl-defmethod register-command-info ((_command (eql insert-register)))
+ (make-register-preview-info
+ :types '(string number)
+ :msg "Insert register `%s'"
+ :act 'insert
+ :smatch t
+ :noconfirm (memq register-use-preview '(nil never))))
+(cl-defmethod register-command-info ((_command (eql jump-to-register)))
+ (make-register-preview-info
+ :types '(window frame marker kmacro
+ file buffer file-query)
+ :msg "Jump to register `%s'"
+ :act 'jump
+ :smatch t
+ :noconfirm (memq register-use-preview '(nil never))))
+(cl-defmethod register-command-info ((_command (eql view-register)))
+ (make-register-preview-info
+ :types '(all)
+ :msg "View register `%s'"
+ :act 'view
+ :noconfirm (memq register-use-preview '(nil never))
+ :smatch t))
+(cl-defmethod register-command-info ((_command (eql append-to-register)))
+ (make-register-preview-info
+ :types '(string number)
+ :msg "Append to register `%s'"
+ :act 'modify
+ :noconfirm (memq register-use-preview '(nil never))
+ :smatch t))
+(cl-defmethod register-command-info ((_command (eql prepend-to-register)))
+ (make-register-preview-info
+ :types '(string number)
+ :msg "Prepend to register `%s'"
+ :act 'modify
+ :noconfirm (memq register-use-preview '(nil never))
+ :smatch t))
+(cl-defmethod register-command-info ((_command (eql increment-register)))
+ (make-register-preview-info
+ :types '(string number)
+ :msg "Increment register `%s'"
+ :act 'modify
+ :noconfirm (memq register-use-preview '(nil never))
+ :smatch t))
+(cl-defmethod register-command-info ((_command (eql copy-to-register)))
+ (make-register-preview-info
+ :types '(all)
+ :msg "Copy to register `%s'"
+ :act 'set
+ :noconfirm (memq register-use-preview '(nil never))))
+(cl-defmethod register-command-info ((_command (eql point-to-register)))
+ (make-register-preview-info
+ :types '(all)
+ :msg "Point to register `%s'"
+ :act 'set
+ :noconfirm (memq register-use-preview '(nil never))))
+(cl-defmethod register-command-info ((_command (eql number-to-register)))
+ (make-register-preview-info
+ :types '(all)
+ :msg "Number to register `%s'"
+ :act 'set
+ :noconfirm (memq register-use-preview '(nil never))))
+(cl-defmethod register-command-info
+ ((_command (eql window-configuration-to-register)))
+ (make-register-preview-info
+ :types '(all)
+ :msg "Window configuration to register `%s'"
+ :act 'set
+ :noconfirm (memq register-use-preview '(nil never))))
+(cl-defmethod register-command-info ((_command (eql frameset-to-register)))
+ (make-register-preview-info
+ :types '(all)
+ :msg "Frameset to register `%s'"
+ :act 'set
+ :noconfirm (memq register-use-preview '(nil never))))
+(cl-defmethod register-command-info ((_command (eql copy-rectangle-to-register)))
+ (make-register-preview-info
+ :types '(all)
+ :msg "Copy rectangle to register `%s'"
+ :act 'set
+ :noconfirm (memq register-use-preview '(nil never))
+ :smatch t))
+
+(defun register-preview-forward-line (arg)
+ "Move to next or previous line in register preview buffer.
+If ARG is positive, go to next line; if negative, go to previous line.
+Do nothing when defining or executing kmacros."
+ ;; Ensure user enter manually key in minibuffer when recording a macro.
+ (unless (or defining-kbd-macro executing-kbd-macro
+ (not (get-buffer-window "*Register Preview*" 'visible)))
+ (let ((fn (if (> arg 0) #'eobp #'bobp))
+ (posfn (if (> arg 0)
+ #'point-min
+ (lambda () (1- (point-max)))))
+ str)
+ (with-current-buffer "*Register Preview*"
+ (let ((ovs (overlays-in (point-min) (point-max)))
+ pos)
+ (goto-char (if ovs
+ (overlay-start (car ovs))
+ (point-min)))
+ (setq pos (point))
+ (and ovs (forward-line arg))
+ (when (and (funcall fn)
+ (or (> arg 0) (eql pos (point))))
+ (goto-char (funcall posfn)))
+ (setq str (buffer-substring-no-properties
+ (pos-bol) (1+ (pos-bol))))
+ (remove-overlays)
+ (with-selected-window (minibuffer-window)
+ (delete-minibuffer-contents)
+ (insert str)))))))
+
+(defun register-preview-next ()
+ "Go to next line in the register preview buffer."
+ (interactive)
+ (register-preview-forward-line 1))
+
+(defun register-preview-previous ()
+ "Go to previous line in the register preview buffer."
+ (interactive)
+ (register-preview-forward-line -1))
+
+(defun register-type (register)
+ "Return REGISTER type.
+Register type that can be returned is one of the following:
+ - string
+ - number
+ - marker
+ - buffer
+ - file
+ - file-query
+ - window
+ - frame
+ - kmacro
+
+One can add new types to a specific command by defining a new `cl-defmethod'
+matching that command. Predicates for type in new `cl-defmethod' should
+satisfy `cl-typep', otherwise the new type should be defined with
+`cl-deftype'."
+ ;; Call register--type against the register value.
+ (register--type (if (consp (cdr register))
+ (cadr register)
+ (cdr register))))
+
+(cl-defgeneric register--type (regval)
+ "Return the type of register value REGVAL."
+ (ignore regval))
+
+(cl-defmethod register--type ((_regval string)) 'string)
+(cl-defmethod register--type ((_regval number)) 'number)
+(cl-defmethod register--type ((_regval marker)) 'marker)
+(cl-defmethod register--type ((_regval (eql buffer))) 'buffer)
+(cl-defmethod register--type ((_regval (eql file))) 'file)
+(cl-defmethod register--type ((_regval (eql file-query))) 'file-query)
+(cl-defmethod register--type ((_regval window-configuration)) 'window)
+(cl-deftype frame-register () '(satisfies frameset-register-p))
+(cl-defmethod register--type :extra "frame-register" (_regval) 'frame)
+(cl-deftype kmacro-register () '(satisfies kmacro-register-p))
+(cl-defmethod register--type :extra "kmacro-register" (_regval) 'kmacro)
+
+(defun register-of-type-alist (types)
+ "Filter `register-alist' according to TYPES."
+ (if (memq 'all types)
+ register-alist
+ (cl-loop for register in register-alist
+ when (memq (register-type register) types)
+ collect register)))
(defun register-preview (buffer &optional show-empty)
- "Pop up a window showing the registers preview in BUFFER.
-If SHOW-EMPTY is non-nil, show the window even if no registers.
+ "Pop up a window showing the preview of registers in BUFFER.
+If SHOW-EMPTY is non-nil, show the preview window even if no registers.
Format of each entry is controlled by the variable `register-preview-function'."
+ (unless register-preview-function
+ (setq register-preview-function (register--preview-function
+ register--read-with-preview-function)))
(when (or show-empty (consp register-alist))
- (with-current-buffer-window
- buffer
- (cons 'display-buffer-below-selected
- '((window-height . fit-window-to-buffer)
- (preserve-size . (nil . t))))
- nil
- (with-current-buffer standard-output
- (setq cursor-in-non-selected-windows nil)
- (mapc (lambda (elem)
- (when (get-register (car elem))
- (insert (funcall register-preview-function elem))))
- register-alist)))))
+ (with-current-buffer-window buffer
+ register-preview-display-buffer-alist
+ nil
+ (with-current-buffer standard-output
+ (setq cursor-in-non-selected-windows nil)
+ (mapc (lambda (elem)
+ (when (get-register (car elem))
+ (insert (funcall register-preview-function elem))))
+ register-alist)))))
+
+(defcustom register-preview-display-buffer-alist '(display-buffer-at-bottom
+ (window-height . fit-window-to-buffer)
+ (preserve-size . (nil . t)))
+ "Window configuration for the register preview buffer."
+ :type display-buffer--action-custom-type)
+
+(defun register-preview-1 (buffer &optional show-empty types)
+ "Pop up a window showing the preview of registers in BUFFER.
+
+This is the preview function used with the `register-read-with-preview-fancy'
+function.
+If SHOW-EMPTY is non-nil, show the preview window even if no registers.
+Optional argument TYPES (a list) specifies the types of register to show;
+if it is nil, show all the registers. See `register-type' for suitable types.
+Format of each entry is controlled by the variable `register-preview-function'."
+ (unless register-preview-function
+ (setq register-preview-function (register--preview-function
+ register--read-with-preview-function)))
+ (let ((registers (register-of-type-alist (or types '(all)))))
+ (when (or show-empty (consp registers))
+ (with-current-buffer-window
+ buffer
+ register-preview-display-buffer-alist
+ nil
+ (with-current-buffer standard-output
+ (setq cursor-in-non-selected-windows nil)
+ (mapc (lambda (elem)
+ (when (get-register (car elem))
+ (insert (funcall register-preview-function elem))))
+ registers))))))
+
+(cl-defgeneric register-preview-get-defaults (action)
+ "Return default registers according to ACTION."
+ (ignore action))
+(cl-defmethod register-preview-get-defaults ((_action (eql set)))
+ (cl-loop for s in register-preview-default-keys
+ unless (assoc (string-to-char s) register-alist)
+ collect s))
(defun register-read-with-preview (prompt)
- "Read and return a register name, possibly showing existing registers.
-Prompt with the string PROMPT. If `register-alist' and
-`register-preview-delay' are both non-nil, display a window
-listing existing registers after `register-preview-delay' seconds.
+ "Read register name, prompting with PROMPT; possibly show existing registers.
+This reads and returns the name of a register. PROMPT should be a string
+to prompt the user for the name.
+If `help-char' (or a member of `help-event-list') is pressed,
+display preview window unconditionally.
+This calls the function specified by `register--read-with-preview-function'."
+ (funcall register--read-with-preview-function prompt))
+
+(defun register-read-with-preview-traditional (prompt)
+ "Read register name, prompting with PROMPT; possibly show existing registers.
+This reads and returns the name of a register. PROMPT should be a string
+to prompt the user for the name.
+If `register-alist' and `register-preview-delay' are both non-nil, display
+a window listing existing registers after `register-preview-delay' seconds.
If `help-char' (or a member of `help-event-list') is pressed,
-display such a window regardless."
+display preview window unconditionally.
+
+This function is used as the value of `register--read-with-preview-function'
+when `register-use-preview' is set to \\='traditional."
(let* ((buffer "*Register Preview*")
(timer (when (numberp register-preview-delay)
(run-with-timer register-preview-delay nil
@@ -179,6 +487,127 @@ display such a window regardless."
(and (window-live-p w) (delete-window w)))
(and (get-buffer buffer) (kill-buffer buffer)))))
+(defun register-read-with-preview-fancy (prompt)
+ "Read register name, prompting with PROMPT; possibly show existing registers.
+This reads and returns the name of a register. PROMPT should be a string
+to prompt the user for the name.
+If `help-char' (or a member of `help-event-list') is pressed,
+display preview window regardless.
+
+This function is used as the value of `register--read-with-preview-function'
+when `register-use-preview' is set to any value other than \\='traditional
+or \\='never."
+ (let* ((buffer "*Register Preview*")
+ (buffer1 "*Register quick preview*")
+ (buf (if register-use-preview buffer buffer1))
+ (pat "")
+ (map (let ((m (make-sparse-keymap)))
+ (set-keymap-parent m minibuffer-local-map)
+ m))
+ (data (register-command-info this-command))
+ (enable-recursive-minibuffers t)
+ types msg result act win strs smatch noconfirm)
+ (if data
+ (setq types (register-preview-info-types data)
+ msg (register-preview-info-msg data)
+ act (register-preview-info-act data)
+ smatch (register-preview-info-smatch data)
+ noconfirm (register-preview-info-noconfirm data))
+ (setq types '(all)
+ msg "Overwrite register `%s'"
+ act 'set))
+ (setq strs (mapcar (lambda (x)
+ (string (car x)))
+ (register-of-type-alist types)))
+ (when (and (memq act '(insert jump view)) (null strs))
+ (error "No register suitable for `%s'" act))
+ (dolist (k (cons help-char help-event-list))
+ (define-key map (vector k)
+ (lambda ()
+ (interactive)
+ ;; Do nothing when buffer1 is in use.
+ (unless (get-buffer-window buf)
+ (with-selected-window (minibuffer-selected-window)
+ (register-preview-1 buffer 'show-empty types))))))
+ (define-key map (kbd "<down>") 'register-preview-next)
+ (define-key map (kbd "<up>") 'register-preview-previous)
+ (define-key map (kbd "C-n") 'register-preview-next)
+ (define-key map (kbd "C-p") 'register-preview-previous)
+ (unless (or executing-kbd-macro (eq register-use-preview 'never))
+ (register-preview-1 buf nil types))
+ (unwind-protect
+ (let ((setup
+ (lambda ()
+ (with-selected-window (minibuffer-window)
+ (let ((input (minibuffer-contents)))
+ (when (> (length input) 1)
+ (let ((new (substring input 1))
+ (old (substring input 0 1)))
+ (setq input (if (or (null smatch)
+ (member new strs))
+ new old))
+ (delete-minibuffer-contents)
+ (insert input)
+ ;; Exit minibuffer on second hit
+ ;; when *-use-preview == insist.
+ (when (and (string= new old)
+ (eq register-use-preview 'insist))
+ (setq noconfirm t))))
+ (when (and smatch (not (string= input ""))
+ (not (member input strs)))
+ (setq input "")
+ (delete-minibuffer-contents)
+ (minibuffer-message "Not matching"))
+ (when (not (string= input pat))
+ (setq pat input))))
+ (if (setq win (get-buffer-window buffer))
+ (with-selected-window win
+ (when noconfirm
+ ;; Happen only when
+ ;; *-use-preview == insist.
+ (exit-minibuffer))
+ (let ((ov (make-overlay
+ (point-min) (point-min)))
+ ;; Allow upper-case and lower-case letters
+ ;; to refer to different registers.
+ (case-fold-search nil))
+ (goto-char (point-min))
+ (remove-overlays)
+ (unless (string= pat "")
+ (if (re-search-forward (concat "^" pat) nil t)
+ (progn (move-overlay
+ ov
+ (match-beginning 0) (pos-eol))
+ (overlay-put ov 'face 'match)
+ (when msg
+ (with-selected-window
+ (minibuffer-window)
+ (minibuffer-message msg pat))))
+ (with-selected-window (minibuffer-window)
+ (minibuffer-message
+ "Register `%s' is empty" pat))))))
+ (unless (string= pat "")
+ (with-selected-window (minibuffer-window)
+ (if (and (member pat strs)
+ (null noconfirm))
+ (with-selected-window (minibuffer-window)
+ (minibuffer-message msg pat))
+ ;; `:noconfirm' is specified explicitly, don't ask for
+ ;; confirmation and exit immediately (bug#66394).
+ (setq result pat)
+ (exit-minibuffer))))))))
+ (minibuffer-with-setup-hook
+ (lambda () (add-hook 'post-command-hook setup nil 'local))
+ (setq result (read-from-minibuffer
+ prompt nil map nil nil
+ (register-preview-get-defaults act))))
+ (cl-assert (and result (not (string= result "")))
+ nil "No register specified")
+ (string-to-char result))
+ (let ((w (get-buffer-window buf)))
+ (and (window-live-p w) (delete-window w)))
+ (and (get-buffer buf) (kill-buffer buf)))))
+
(defun point-to-register (register &optional arg)
"Store current location of point in REGISTER.
With prefix argument ARG, store current frame configuration (a.k.a. \"frameset\").
diff --git a/lisp/replace.el b/lisp/replace.el
index cf2e3d228aa..01a892bbba7 100644
--- a/lisp/replace.el
+++ b/lisp/replace.el
@@ -1667,13 +1667,15 @@ A positive number means to include that many lines both before and after."
(defcustom list-matching-lines-face 'match
"Face used by \\[list-matching-lines] to show the text that matches.
If the value is nil, don't highlight the matching portions specially."
- :type 'face
+ :type '(choice (const :tag "Don't highlight matching portions" nil)
+ face)
:group 'matching)
(defcustom list-matching-lines-buffer-name-face 'underline
"Face used by \\[list-matching-lines] to show the names of buffers.
If the value is nil, don't highlight the buffer names specially."
- :type 'face
+ :type '(choice (const :tag "Don't highlight buffer names" nil)
+ face)
:group 'matching)
(defcustom list-matching-lines-current-line-face 'lazy-highlight
@@ -1929,7 +1931,7 @@ See also `multi-occur'."
(lambda (boo)
(buffer-name (if (overlayp boo) (overlay-buffer boo) boo)))
active-bufs))
- (with-current-buffer (get-buffer buf-name)
+ (with-current-buffer buf-name
(rename-uniquely)))
;; Now find or create the output buffer.
@@ -2640,10 +2642,6 @@ passed in. If LITERAL is set, no checking is done, anyway."
noedit nil)))
(set-match-data match-data)
(replace-match newtext fixedcase literal)
- ;; `query-replace' undo feature needs the beginning of the match position,
- ;; but `replace-match' may change it, for instance, with a regexp like "^".
- ;; Ensure that this function preserves the match data (Bug#31492).
- (set-match-data match-data)
;; `replace-match' leaves point at the end of the replacement text,
;; so move point to the beginning when replacing backward.
(when backward (goto-char (nth 0 match-data)))
@@ -2757,6 +2755,7 @@ to a regexp that is actually used for the search.")
(isearch-regexp-lax-whitespace
replace-regexp-lax-whitespace)
(isearch-case-fold-search case-fold)
+ (isearch-invisible search-invisible)
(isearch-forward (not backward))
(isearch-other-end match-beg)
(isearch-error nil)
@@ -2917,7 +2916,7 @@ characters."
;; If last typed key in previous call of multi-buffer perform-replace
;; was `automatic-all', don't ask more questions in next files
- (when (eq (lookup-key map (vector last-input-event)) 'automatic-all)
+ (when (eq (lookup-key map (vector last-input-event) t) 'automatic-all)
(setq query-flag nil multi-buffer t))
(cond
@@ -3101,7 +3100,7 @@ characters."
;; read-event that clobbers the match data.
(set-match-data real-match-data)
(setq key (vector key))
- (setq def (lookup-key map key))
+ (setq def (lookup-key map key t))
;; Restore the match data while we process the command.
(cond ((eq def 'help)
(let ((display-buffer-overriding-action
diff --git a/lisp/reveal.el b/lisp/reveal.el
index d4c7ef7965c..055667aa343 100644
--- a/lisp/reveal.el
+++ b/lisp/reveal.el
@@ -118,17 +118,13 @@ Each element has the form (WINDOW . OVERLAY).")
;; overlay. Always reveal invisible text, but only reveal
;; display properties if `reveal-toggle-invisible' is
;; present.
- (let ((inv (overlay-get ol 'invisible))
- (disp (and (overlay-get ol 'display)
- (overlay-get ol 'reveal-toggle-invisible)))
- open)
- (when (and (or (and inv
- ;; There's an `invisible' property.
- ;; Make sure it's actually invisible,
- ;; and ellipsized.
- (and (consp buffer-invisibility-spec)
- (cdr (assq inv buffer-invisibility-spec))))
- disp)
+ (let* ((inv (overlay-get ol 'invisible))
+ (disp (and (overlay-get ol 'display)
+ (overlay-get ol 'reveal-toggle-invisible)))
+ (hidden (invisible-p inv))
+ (ellipsis (and hidden (not (eq t hidden))))
+ open)
+ (when (and (or ellipsis disp)
(or (setq open
(or (overlay-get ol 'reveal-toggle-invisible)
(and (symbolp inv)
diff --git a/lisp/saveplace.el b/lisp/saveplace.el
index 37673b35a77..a4942cb484b 100644
--- a/lisp/saveplace.el
+++ b/lisp/saveplace.el
@@ -35,6 +35,8 @@
;;; Code:
+(require 'cl-lib)
+
;; this is what I was using during testing:
;; (define-key ctl-x-map "p" 'toggle-save-place-globally)
@@ -98,11 +100,79 @@ this happens automatically before saving `save-place-alist' to
`save-place-file'."
:type 'boolean)
+(defun save-place-load-alist-from-file ()
+ (if (not save-place-loaded)
+ (progn
+ (setq save-place-loaded t)
+ (let ((file (expand-file-name save-place-file)))
+ ;; make sure that the alist does not get overwritten, and then
+ ;; load it if it exists:
+ (if (file-readable-p file)
+ ;; don't want to use find-file because we have been
+ ;; adding hooks to it.
+ (with-current-buffer (get-buffer-create " *Saved Places*")
+ (delete-region (point-min) (point-max))
+ ;; Make sure our 'coding:' cookie in the save-place
+ ;; file will take effect, in case the caller binds
+ ;; coding-system-for-read.
+ (let (coding-system-for-read)
+ (insert-file-contents file))
+ (goto-char (point-min))
+ (setq save-place-alist
+ (with-demoted-errors "Error reading save-place-file: %S"
+ (car (read-from-string
+ (buffer-substring (point-min) (point-max))))))
+
+ ;; If there is a limit, and we're over it, then we'll
+ ;; have to truncate the end of the list:
+ (if save-place-limit
+ (if (<= save-place-limit 0)
+ ;; Zero gets special cased. I'm not thrilled
+ ;; with this, but the loop for >= 1 is tight.
+ (setq save-place-alist nil)
+ ;; Else the limit is >= 1, so enforce it by
+ ;; counting and then `setcdr'ing.
+ (let ((s save-place-alist)
+ (count 1))
+ (while s
+ (if (>= count save-place-limit)
+ (setcdr s nil)
+ (setq count (1+ count)))
+ (setq s (cdr s))))))
+
+ (kill-buffer (current-buffer))))
+ nil))))
+
(defcustom save-place-abbreviate-file-names nil
"If non-nil, abbreviate file names before saving them.
This can simplify sharing the `save-place-file' file across
-different hosts."
+different hosts.
+
+Changing this option requires rewriting `save-place-alist' with
+corresponding file name format, therefore setting this option
+just using `setq' may cause out-of-sync problems. You should use
+either `setopt' or M-x customize-variable to set this option."
:type 'boolean
+ :set (lambda (sym val)
+ (set-default sym val)
+ (or save-place-loaded (save-place-load-alist-from-file))
+ (let ((fun (if val #'abbreviate-file-name #'expand-file-name))
+ ;; Don't expand file names for non-existing remote connections.
+ (non-essential t))
+ (setq save-place-alist
+ (cl-delete-duplicates
+ (cl-loop for (k . v) in save-place-alist
+ collect
+ (cons (funcall fun k)
+ (if (listp v)
+ (cl-loop for (k1 . v1) in v
+ collect
+ (cons k1 (funcall fun v1)))
+ v)))
+ :key #'car
+ :from-end t
+ :test #'equal)))
+ val)
:version "28.1")
(defcustom save-place-save-skipped t
@@ -226,7 +296,11 @@ file names."
((and (derived-mode-p 'dired-mode) directory)
(let ((filename (dired-get-filename nil t)))
(if filename
- `((dired-filename . ,filename))
+ (list
+ (cons 'dired-filename
+ (if save-place-abbreviate-file-names
+ (abbreviate-file-name filename)
+ filename)))
(point))))
(t (point)))))
(if cell
@@ -290,49 +364,6 @@ may have changed) back to `save-place-alist'."
(file-error (message "Saving places: can't write %s" file)))
(kill-buffer (current-buffer))))))
-(defun save-place-load-alist-from-file ()
- (if (not save-place-loaded)
- (progn
- (setq save-place-loaded t)
- (let ((file (expand-file-name save-place-file)))
- ;; make sure that the alist does not get overwritten, and then
- ;; load it if it exists:
- (if (file-readable-p file)
- ;; don't want to use find-file because we have been
- ;; adding hooks to it.
- (with-current-buffer (get-buffer-create " *Saved Places*")
- (delete-region (point-min) (point-max))
- ;; Make sure our 'coding:' cookie in the save-place
- ;; file will take effect, in case the caller binds
- ;; coding-system-for-read.
- (let (coding-system-for-read)
- (insert-file-contents file))
- (goto-char (point-min))
- (setq save-place-alist
- (with-demoted-errors "Error reading save-place-file: %S"
- (car (read-from-string
- (buffer-substring (point-min) (point-max))))))
-
- ;; If there is a limit, and we're over it, then we'll
- ;; have to truncate the end of the list:
- (if save-place-limit
- (if (<= save-place-limit 0)
- ;; Zero gets special cased. I'm not thrilled
- ;; with this, but the loop for >= 1 is tight.
- (setq save-place-alist nil)
- ;; Else the limit is >= 1, so enforce it by
- ;; counting and then `setcdr'ing.
- (let ((s save-place-alist)
- (count 1))
- (while s
- (if (>= count save-place-limit)
- (setcdr s nil)
- (setq count (1+ count)))
- (setq s (cdr s))))))
-
- (kill-buffer (current-buffer))))
- nil))))
-
(defun save-places-to-alist ()
;; go through buffer-list, saving places to alist if save-place-mode
;; is non-nil, deleting them from alist if it is nil.
@@ -365,7 +396,11 @@ may have changed) back to `save-place-alist'."
"Function added to `find-file-hook' by `save-place-mode'.
It runs the hook `save-place-after-find-file-hook'."
(or save-place-loaded (save-place-load-alist-from-file))
- (let ((cell (assoc buffer-file-name save-place-alist)))
+ (let ((cell (and (stringp buffer-file-name)
+ (assoc (if save-place-abbreviate-file-names
+ (abbreviate-file-name buffer-file-name)
+ buffer-file-name)
+ save-place-alist))))
(if cell
(progn
(or revert-buffer-in-progress-p
@@ -381,25 +416,25 @@ It runs the hook `save-place-after-find-file-hook'."
"Position point in a Dired buffer according to its saved place.
This is run via `dired-initial-position-hook', which see."
(or save-place-loaded (save-place-load-alist-from-file))
- (let* ((directory (and (derived-mode-p 'dired-mode)
- (boundp 'dired-subdir-alist)
- dired-subdir-alist
- (dired-current-directory)))
- (cell (assoc (and directory
- (expand-file-name (if (consp directory)
- (car directory)
- directory)))
- save-place-alist)))
- (if cell
- (progn
- (or revert-buffer-in-progress-p
- (cond
- ((integerp (cdr cell))
- (goto-char (cdr cell)))
- ((and (listp (cdr cell)) (assq 'dired-filename (cdr cell)))
- (dired-goto-file (cdr (assq 'dired-filename (cdr cell)))))))
- ;; and make sure it will be saved again for later
- (setq save-place-mode t)))))
+ (when-let ((directory (and (derived-mode-p 'dired-mode)
+ (boundp 'dired-subdir-alist)
+ dired-subdir-alist
+ (dired-current-directory)))
+ (item (expand-file-name (if (consp directory)
+ (car directory)
+ directory)))
+ (cell (assoc (if save-place-abbreviate-file-names
+ (abbreviate-file-name item) item)
+ save-place-alist)))
+ (or revert-buffer-in-progress-p
+ (cond
+ ((integerp (cdr cell))
+ (goto-char (cdr cell)))
+ ((listp (cdr cell))
+ (when-let ((elt (assq 'dired-filename (cdr cell))))
+ (dired-goto-file (expand-file-name (cdr elt)))))))
+ ;; and make sure it will be saved again for later
+ (setq save-place-mode t)))
(defun save-place-kill-emacs-hook ()
;; First update the alist. This loads the old save-place-file if nec.
diff --git a/lisp/select.el b/lisp/select.el
index 44b9765b748..ab78e88478b 100644
--- a/lisp/select.el
+++ b/lisp/select.el
@@ -49,27 +49,28 @@ the current system default encoding on 9x/Me, `utf-16le-dos'
\(Unicode) on NT/W2K/XP, and `iso-latin-1-dos' on MS-DOS.
For X Windows:
-When sending text via selection and clipboard, if the target
-data-type matches this coding system according to the table
-below, it is used for encoding the text. Otherwise (including
-the case that this variable is nil), a proper coding system is
-selected as below:
-
-data-type coding system
---------- -------------
-UTF8_STRING utf-8
-COMPOUND_TEXT compound-text-with-extensions
-STRING iso-latin-1
-C_STRING raw-text-unix
-
-When receiving text, if this coding system is non-nil, it is used
-for decoding regardless of the data-type. If this is nil, a
-proper coding system is used according to the data-type as above.
-See also the documentation of the variable `x-select-request-type' how
-to control which data-type to request for receiving text.
+This coding system replaces that of the default coding system
+selection text is encoded by in reaction to a request for the
+polymorphic `TEXT' selection target when its base coding system
+is compatible with `compound-text' and the text being encoded
+cannot be rendered Latin-1 without loss of information.
+
+It also replaces the coding system by which calls to
+`gui-get-selection' decode selection requests for text data
+types, which are enumerated below beside their respective coding
+systems otherwise used.
+
+DATA TYPE CODING SYSTEM
+-------------------------- -------------
+UTF8_STRING utf-8
+text/plain\\;charset=utf-8 utf-8
+COMPOUND_TEXT compound-text-with-extensions
+STRING iso-latin-1
+C_STRING raw-text-unix
-The default value is nil."
+See also the documentation of the variable `x-select-request-type' how
+to control which data-type to request for receiving text."
:type 'coding-system
:group 'mule
;; Default was compound-text-with-extensions in 22.x (pre-unicode).
diff --git a/lisp/server.el b/lisp/server.el
index f6b05bb2f43..b65053267a6 100644
--- a/lisp/server.el
+++ b/lisp/server.el
@@ -275,6 +275,11 @@ If nil, no instructions are displayed."
:version "28.1"
:type 'boolean)
+(defvar server-stop-automatically) ; Defined below to avoid recursive load.
+
+(defvar server-stop-automatically--timer nil
+ "The timer object for `server-stop-automatically--maybe-kill-emacs'.")
+
;; We do not use `temporary-file-directory' here, because emacsclient
;; does not read the init file.
(defvar server-socket-dir
@@ -325,6 +330,9 @@ ENV should be in the same format as `process-environment'."
(defun server-delete-client (proc &optional noframe)
"Delete PROC, including its buffers, terminals and frames.
If NOFRAME is non-nil, let the frames live.
+If NOFRAME is the symbol \\='dont-kill-client, also don't
+delete PROC or its terminals, just kill its buffers: this is
+for when `find-alternate-file' calls this via `kill-buffer-hook'.
Updates `server-clients'."
(server-log (concat "server-delete-client" (if noframe " noframe")) proc)
;; Force a new lookup of client (prevents infinite recursion).
@@ -361,23 +369,28 @@ Updates `server-clients'."
(set-frame-parameter frame 'client nil)
(delete-frame frame))))
- (setq server-clients (delq proc server-clients))
+ (or (eq noframe 'dont-kill-client)
+ (setq server-clients (delq proc server-clients)))
;; Delete the client's tty, except on Windows (both GUI and
;; console), where there's only one terminal and does not make
;; sense to delete it, or if we are explicitly told not.
(unless (or (eq system-type 'windows-nt)
+ ;; 'find-alternate-file' caused the last client
+ ;; buffer to be killed, but we will reuse the client
+ ;; for another buffer.
+ (eq noframe 'dont-kill-client)
(process-get proc 'no-delete-terminal))
(let ((terminal (process-get proc 'terminal)))
;; Only delete the terminal if it is non-nil.
(when (and terminal (eq (terminal-live-p terminal) t))
(delete-terminal terminal))))
- ;; Delete the client's process.
- (if (eq (process-status proc) 'open)
- (delete-process proc))
-
- (server-log "Deleted" proc))))
+ ;; Delete the client's process (or don't).
+ (unless (eq noframe 'dont-kill-client)
+ (if (eq (process-status proc) 'open)
+ (delete-process proc))
+ (server-log "Deleted" proc)))))
(defvar server-log-time-function #'current-time-string
"Function to generate timestamps for `server-buffer'.")
@@ -638,7 +651,8 @@ anyway."
(setq stopped-p t
server-process nil
server-mode nil
- global-minor-modes (delq 'server-mode global-minor-modes)))
+ global-minor-modes (delq 'server-mode global-minor-modes))
+ (server-apply-stop-automatically))
(unwind-protect
;; Delete the socket files made by previous server
;; invocations.
@@ -715,7 +729,9 @@ the `server-process' variable."
(concat "Unable to start the Emacs server.\n"
(cadr err)
(substitute-command-keys
- "\nTo start the server in this Emacs process, stop the existing server or call `\\[server-force-delete]' to forcibly disconnect it."))
+ (concat "\nTo start the server in this Emacs process, stop "
+ "the existing server or call \\[server-force-delete] "
+ "to forcibly disconnect it.")))
:warning)
(setq leave-dead t)))
;; Now any previous server is properly stopped.
@@ -759,6 +775,7 @@ the `server-process' variable."
(list :family 'local
:service server-file
:plist '(:authenticated t)))))
+ (server-apply-stop-automatically)
(unless server-process (error "Could not start server process"))
(server-log "Started server")
(process-put server-process :server-file server-file)
@@ -1138,8 +1155,18 @@ The following commands are accepted by the client:
(process-put proc :authenticated t)
(server-log "Authentication successful" proc))
(server-log "Authentication failed" proc)
+ ;; Display the error as a message and give the user time to see
+ ;; it, in case the error written by emacsclient to stderr is not
+ ;; visible for some reason.
+ (message "Authentication failed")
+ (sit-for 2)
(server-send-string
proc (concat "-error " (server-quote-arg "Authentication failed")))
+ (unless (eq system-type 'windows-nt)
+ (let ((terminal (process-get proc 'terminal)))
+ ;; Only delete the terminal if it is non-nil.
+ (when (and terminal (eq (terminal-live-p terminal) t))
+ (delete-terminal terminal))))
;; Before calling `delete-process', give emacsclient time to
;; receive the error string and shut down on its own.
(sit-for 1)
@@ -1174,6 +1201,7 @@ The following commands are accepted by the client:
parent-id ; Window ID for XEmbed
dontkill ; t if client should not be killed.
commands
+ evalexprs
dir
use-current-frame
frame-parameters ;parameters for newly created frame
@@ -1307,8 +1335,7 @@ The following commands are accepted by the client:
(let ((expr (pop args-left)))
(if coding-system
(setq expr (decode-coding-string expr coding-system)))
- (push (lambda () (server-eval-and-print expr proc))
- commands)
+ (push expr evalexprs)
(setq filepos nil)))
;; -env NAME=VALUE: An environment variable.
@@ -1333,7 +1360,7 @@ The following commands are accepted by the client:
;; arguments, use an existing frame.
(and nowait
(not (eq tty-name 'window-system))
- (or files commands)
+ (or files commands evalexprs)
(setq use-current-frame t))
(setq frame
@@ -1382,7 +1409,7 @@ The following commands are accepted by the client:
(let ((default-directory
(if (and dir (file-directory-p dir))
dir default-directory)))
- (server-execute proc files nowait commands
+ (server-execute proc files nowait commands evalexprs
dontkill frame tty-name)))))
(when (or frame files)
@@ -1392,22 +1419,39 @@ The following commands are accepted by the client:
;; condition-case
(t (server-return-error proc err))))
-(defun server-execute (proc files nowait commands dontkill frame tty-name)
+(defvar server-eval-args-left nil
+ "List of eval args not yet processed.
+
+Adding or removing strings from this variable while the Emacs
+server is processing a series of eval requests will affect what
+Emacs evaluates.
+
+See also `argv' for a similar variable which works for
+invocations of \"emacs\".")
+
+(defun server-execute (proc files nowait commands evalexprs dontkill frame tty-name)
;; This is run from timers and process-filters, i.e. "asynchronously".
;; But w.r.t the user, this is not really asynchronous since the timer
;; is run after 0s and the process-filter is run in response to the
;; user running `emacsclient'. So it is OK to override the
- ;; inhibit-quit flag, which is good since `commands' (as well as
+ ;; inhibit-quit flag, which is good since `evalexprs' (as well as
;; find-file-noselect via the major-mode) can run arbitrary code,
;; including code that needs to wait.
(with-local-quit
(condition-case err
- (let ((buffers (server-visit-files files proc nowait)))
+ (let ((buffers (server-visit-files files proc nowait))
+ ;; On Android, the Emacs server generally can't provide
+ ;; feedback to the user except by means of dialog boxes,
+ ;; which are displayed in the GUI emacsclient wrapper.
+ (use-dialog-box-override (featurep 'android)))
(mapc 'funcall (nreverse commands))
+ (let ((server-eval-args-left (nreverse evalexprs)))
+ (while server-eval-args-left
+ (server-eval-and-print (pop server-eval-args-left) proc)))
;; If we were told only to open a new client, obey
;; `initial-buffer-choice' if it specifies a file
;; or a function.
- (unless (or files commands)
+ (unless (or files commands evalexprs)
(let ((buf
(cond ((stringp initial-buffer-choice)
(find-file-noselect initial-buffer-choice))
@@ -1460,10 +1504,20 @@ The following commands are accepted by the client:
(defun server-return-error (proc err)
(ignore-errors
+ ;; Display the error as a message and give the user time to see
+ ;; it, in case the error written by emacsclient to stderr is not
+ ;; visible for some reason.
+ (message (error-message-string err))
+ (sit-for 2)
(server-send-string
proc (concat "-error " (server-quote-arg
(error-message-string err))))
(server-log (error-message-string err) proc)
+ (unless (eq system-type 'windows-nt)
+ (let ((terminal (process-get proc 'terminal)))
+ ;; Only delete the terminal if it is non-nil.
+ (when (and terminal (eq (terminal-live-p terminal) t))
+ (delete-terminal terminal))))
;; Before calling `delete-process', give emacsclient time to
;; receive the error string and shut down on its own.
(sit-for 5)
@@ -1566,7 +1620,8 @@ FOR-KILLING if non-nil indicates that we are called from `kill-buffer'."
;; frames, which might change the current buffer. We
;; don't want that (bug#640).
(save-current-buffer
- (server-delete-client proc))
+ (server-delete-client proc
+ find-alternate-file-dont-kill-client))
(server-delete-client proc))))))
(when (and (bufferp buffer) (buffer-name buffer))
;; We may or may not kill this buffer;
@@ -1774,9 +1829,6 @@ be a cons cell (LINENUMBER . COLUMNNUMBER)."
(when server-raise-frame
(select-frame-set-input-focus (window-frame)))))
-(defvar server-stop-automatically nil
- "Internal status variable for `server-stop-automatically'.")
-
;;;###autoload
(defun server-save-buffers-kill-terminal (arg)
;; Called from save-buffers-kill-terminal in files.el.
@@ -1784,11 +1836,19 @@ be a cons cell (LINENUMBER . COLUMNNUMBER)."
With ARG non-nil, silently save all file-visiting buffers, then kill.
If emacsclient was started with a list of filenames to edit, then
-only these files will be asked to be saved."
- (let ((proc (frame-parameter nil 'client)))
+only these files will be asked to be saved.
+
+When running Emacs as a daemon and with
+`server-stop-automatically' (which see) set to `kill-terminal' or
+`delete-frame', this function may call `save-buffers-kill-emacs'
+if there are no other active clients."
+ (let ((stop-automatically
+ (and (daemonp)
+ (memq server-stop-automatically '(kill-terminal delete-frame))))
+ (proc (frame-parameter nil 'client)))
(cond ((eq proc 'nowait)
;; Nowait frames have no client buffer list.
- (if (length> (frame-list) (if server-stop-automatically 2 1))
+ (if (length> (frame-list) (if stop-automatically 2 1))
;; If there are any other frames, only delete this one.
;; When `server-stop-automatically' is set, don't count
;; the daemon frame.
@@ -1797,7 +1857,7 @@ only these files will be asked to be saved."
;; If we're the last frame standing, kill Emacs.
(save-buffers-kill-emacs arg)))
((processp proc)
- (if (or (not server-stop-automatically)
+ (if (or (not stop-automatically)
(length> server-clients 1)
(seq-some
(lambda (frame)
@@ -1823,31 +1883,14 @@ only these files will be asked to be saved."
(save-buffers-kill-emacs arg)))
(t (error "Invalid client frame")))))
-(defun server-stop-automatically--handle-delete-frame (frame)
- "Handle deletion of FRAME when `server-stop-automatically' is used."
- (when server-stop-automatically
- (if (if (and (processp (frame-parameter frame 'client))
- (eq this-command 'save-buffers-kill-terminal))
- (progn
- (dolist (f (frame-list))
- (when (and (eq (frame-parameter frame 'client)
- (frame-parameter f 'client))
- (not (eq frame f)))
- (set-frame-parameter f 'client nil)
- (let ((server-stop-automatically nil))
- (delete-frame f))))
- (if (cddr (frame-list))
- (let ((server-stop-automatically nil))
- (delete-frame frame)
- nil)
- t))
- (null (cddr (frame-list))))
- (let ((server-stop-automatically nil))
- (save-buffers-kill-emacs)
- (delete-frame frame)))))
+(defun server-stop-automatically--handle-delete-frame (_frame)
+ "Handle deletion of FRAME when `server-stop-automatically' is `delete-frame'."
+ (when (null (cddr (frame-list)))
+ (let ((server-stop-automatically nil))
+ (save-buffers-kill-emacs))))
(defun server-stop-automatically--maybe-kill-emacs ()
- "Handle closing of Emacs daemon when `server-stop-automatically' is used."
+ "Handle closing of Emacs daemon when `server-stop-automatically' is `empty'."
(unless (cdr (frame-list))
(when (and
(not (memq t (mapcar (lambda (b)
@@ -1861,41 +1904,70 @@ only these files will be asked to be saved."
(process-list)))))
(kill-emacs))))
-;;;###autoload
-(defun server-stop-automatically (arg)
- "Automatically stop server as specified by ARG.
-
-If ARG is the symbol `empty', stop the server when it has no
+(defun server-apply-stop-automatically ()
+ "Apply the current value of `server-stop-automatically'.
+This function adds or removes the necessary helpers to manage
+stopping the Emacs server automatically, depending on the whether
+the server is running or not. This function only applies when
+running Emacs as a daemon."
+ (when (daemonp)
+ (let (empty-timer-p delete-frame-p)
+ (when server-process
+ (pcase server-stop-automatically
+ ('empty (setq empty-timer-p t))
+ ('delete-frame (setq delete-frame-p t))))
+ ;; Start or stop the timer.
+ (if empty-timer-p
+ (unless server-stop-automatically--timer
+ (setq server-stop-automatically--timer
+ (run-with-timer
+ 10 2
+ #'server-stop-automatically--maybe-kill-emacs)))
+ (when server-stop-automatically--timer
+ (cancel-timer server-stop-automatically--timer)
+ (setq server-stop-automatically--timer nil)))
+ ;; Add or remove the delete-frame hook.
+ (if delete-frame-p
+ (add-hook 'delete-frame-functions
+ #'server-stop-automatically--handle-delete-frame)
+ (remove-hook 'delete-frame-functions
+ #'server-stop-automatically--handle-delete-frame))))
+ ;; Return the current value of `server-stop-automatically'.
+ server-stop-automatically)
+
+(defcustom server-stop-automatically nil
+ "If non-nil, stop the server under the requested conditions.
+
+If this is the symbol `empty', stop the server when it has no
remaining clients, no remaining unsaved file-visiting buffers,
and no running processes with a `query-on-exit' flag.
-If ARG is the symbol `delete-frame', ask the user when the last
+If this is the symbol `delete-frame', ask the user when the last
frame is deleted whether each unsaved file-visiting buffer must
be saved and each running process with a `query-on-exit' flag
can be stopped, and if so, stop the server itself.
-If ARG is the symbol `kill-terminal', ask the user when the
+If this is the symbol `kill-terminal', ask the user when the
terminal is killed with \\[save-buffers-kill-terminal] \
whether each unsaved file-visiting
buffer must be saved and each running process with a `query-on-exit'
-flag can be stopped, and if so, stop the server itself.
-
-Any other value of ARG will cause this function to signal an error.
+flag can be stopped, and if so, stop the server itself."
+ :type '(choice
+ (const :tag "Never" nil)
+ (const :tag "When no clients, unsaved files, or processes"
+ empty)
+ (const :tag "When killing last terminal" kill-terminal)
+ (const :tag "When killing last terminal or frame" delete-frame))
+ :set (lambda (symbol value)
+ (set-default symbol value)
+ (server-apply-stop-automatically))
+ :version "29.1")
-This function is meant to be called from the user init file."
- (when (daemonp)
- (setq server-stop-automatically arg)
- (cond
- ((eq arg 'empty)
- (setq server-stop-automatically nil)
- (run-with-timer 10 2
- #'server-stop-automatically--maybe-kill-emacs))
- ((eq arg 'delete-frame)
- (add-hook 'delete-frame-functions
- #'server-stop-automatically--handle-delete-frame))
- ((eq arg 'kill-terminal))
- (t
- (error "Unexpected argument")))))
+;;;###autoload
+(defun server-stop-automatically (value)
+ "Automatically stop the Emacs server as specified by VALUE.
+This sets the variable `server-stop-automatically' (which see)."
+ (setopt server-stop-automatically value))
(define-key ctl-x-map "#" 'server-edit)
@@ -1910,12 +1982,22 @@ This function is meant to be called from the user init file."
;; continue standard unloading
nil)
+(define-error 'server-return-invalid-read-syntax
+ "Emacs server returned unreadable result of evaluation"
+ 'invalid-read-syntax)
+
(defun server-eval-at (server form)
"Contact the Emacs server named SERVER and evaluate FORM there.
-Returns the result of the evaluation, or signals an error if it
-cannot contact the specified server. For example:
+Returns the result of the evaluation. For example:
(server-eval-at \"server\" \\='(emacs-pid))
-returns the process ID of the Emacs instance running \"server\"."
+returns the process ID of the Emacs instance running \"server\".
+
+This function signals `error' if it could not contact the server.
+
+This function signals `server-return-invalid-read-syntax' if
+`read' fails on the result returned by the server.
+This will occur whenever the result of evaluating FORM is
+something that cannot be printed readably."
(let* ((server-dir (if server-use-tcp server-auth-dir server-socket-dir))
(server-file (expand-file-name server server-dir))
(coding-system-for-read 'binary)
@@ -1961,8 +2043,14 @@ returns the process ID of the Emacs instance running \"server\"."
(progn (skip-chars-forward "^\n")
(point))))))
(if (not (equal answer ""))
- (read (decode-coding-string (server-unquote-arg answer)
- 'emacs-internal)))))))
+ (condition-case err
+ (read
+ (decode-coding-string (server-unquote-arg answer)
+ 'emacs-internal))
+ ;; Re-signal with a more specific condition.
+ (invalid-read-syntax
+ (signal 'server-return-invalid-read-syntax
+ (cdr err)))))))))
(provide 'server)
diff --git a/lisp/ses.el b/lisp/ses.el
index 8e742533c2f..fcbb0567901 100644
--- a/lisp/ses.el
+++ b/lisp/ses.el
@@ -69,6 +69,8 @@
(require 'macroexp)
(eval-when-compile (require 'cl-lib))
+;; Autoloaded, but we have not loaded cl-loaddefs yet.
+(declare-function cl-member "cl-seq" (cl-item cl-list &rest cl-keys))
;;----------------------------------------------------------------------------
;; User-customizable variables
@@ -556,13 +558,15 @@ the corresponding cell with name PROPERTY-NAME."
(defun ses-is-cell-sym-p (sym)
"Check whether SYM point at a cell of this spread sheet."
- (let ((rowcol (get sym 'ses-cell)))
- (and rowcol
- (if (eq rowcol :ses-named)
- (and ses--named-cell-hashmap (gethash sym ses--named-cell-hashmap))
- (and (< (car rowcol) ses--numrows)
- (< (cdr rowcol) ses--numcols)
- (eq (ses-cell-symbol (car rowcol) (cdr rowcol)) sym))))))
+ (and (symbolp sym)
+ (local-variable-p sym)
+ (let ((rowcol (get sym 'ses-cell)))
+ (and rowcol
+ (if (eq rowcol :ses-named)
+ (and ses--named-cell-hashmap (gethash sym ses--named-cell-hashmap))
+ (and (< (car rowcol) ses--numrows)
+ (< (cdr rowcol) ses--numcols)
+ (eq (ses-cell-symbol (car rowcol) (cdr rowcol)) sym)))))))
(defun ses--cell (sym value formula printer references)
"Load a cell SYM from the spreadsheet file.
@@ -735,10 +739,8 @@ checking that it is a valid printer function."
(defun ses-formula-record (formula)
"If FORMULA is of the form \\='SYMBOL, add it to the list of symbolic formulas
for this spreadsheet."
- (when (and (eq (car-safe formula) 'quote)
- (symbolp (cadr formula)))
- (add-to-list 'ses--symbolic-formulas
- (list (symbol-name (cadr formula))))))
+ (and (ses-is-cell-sym-p formula)
+ (cl-pushnew (symbol-name formula) ses--symbolic-formulas :test #'string=)))
(defun ses-column-letter (col)
"Return the alphabetic name of column number COL.
@@ -884,33 +886,36 @@ means Emacs will crash if FORMULA contains a circular list."
(newref (ses-formula-references formula))
(inhibit-quit t)
not-a-cell-ref-list
- x xrow xcol)
+ x xref xrow xcol)
(cl-pushnew sym ses--deferred-recalc)
;;Delete old references from this cell. Skip the ones that are also
;;in the new list.
(dolist (ref oldref)
(unless (memq ref newref)
- ;; because we do not cancel edit when the user provides a
+ ;; Because we do not cancel edit when the user provides a
;; false reference in it, then we need to check that ref
;; points to a cell that is within the spreadsheet.
- (setq x (ses-sym-rowcol ref))
- (and x
- (< (setq xrow (car x)) ses--numrows)
- (< (setq xcol (cdr x)) ses--numcols)
- (ses-set-cell xrow xcol 'references
- (delq sym (ses-cell-references xrow xcol))))))
+ (when
+ (and (setq x (ses-sym-rowcol ref))
+ (< (setq xrow (car x)) ses--numrows)
+ (< (setq xcol (cdr x)) ses--numcols))
+ ;; Cell reference has to be re-written to data area as its
+ ;; reference list is changed.
+ (cl-pushnew x ses--deferred-write :test #'equal)
+ (ses-set-cell xrow xcol 'references
+ (delq sym (ses-cell-references xrow xcol))))))
;;Add new ones. Skip ones left over from old list
(dolist (ref newref)
- (setq x (ses-sym-rowcol ref))
;;Do not trust the user, the reference may be outside the spreadsheet
(if (and
- x
+ (setq x (ses-sym-rowcol ref))
(< (setq xrow (car x)) ses--numrows)
(< (setq xcol (cdr x)) ses--numcols))
- (progn
- (setq x (ses-cell-references xrow xcol))
- (or (memq sym x)
- (ses-set-cell xrow xcol 'references (cons sym x))))
+ (unless (memq sym (setq xref (ses-cell-references xrow xcol)))
+ ;; Cell reference has to be re-written to data area as
+ ;; its reference list is changed.
+ (cl-pushnew x ses--deferred-write :test #'equal)
+ (ses-set-cell xrow xcol 'references (cons sym xref)))
(cl-pushnew ref not-a-cell-ref-list)))
(ses-formula-record formula)
(ses-set-cell row col 'formula formula)
@@ -2762,6 +2767,18 @@ See `ses-read-cell-printer' for input forms."
;;----------------------------------------------------------------------------
;; Spreadsheet size adjustments
;;----------------------------------------------------------------------------
+(defun ses--blank-line-needs-printing-p ()
+ "Returns `t' when blank new line print-out needs to be initialized
+by calling the printers on it, `nil' otherwise."
+ (let (ret
+ printer
+ (printers (append ses--col-printers (list ses--default-printer))))
+ (while printers
+ (if (and (setq printer (pop printers))
+ (null (string= "" (ses-call-printer printer))))
+ (setq ret t
+ printers nil)))
+ ret))
(defun ses-insert-row (count)
"Insert a new row before the current one.
@@ -2794,15 +2811,13 @@ With prefix, insert COUNT rows before current one."
(ses-goto-data row 0)
(insert (make-string (* (1+ ses--numcols) count) ?\n))
(ses-relocate-all row 0 count 0)
- ;;If any cell printers insert constant text, insert that text
- ;;into the line.
- (let ((cols (mapconcat #'ses-call-printer ses--col-printers nil))
- (global (ses-call-printer ses--default-printer)))
- (if (or (> (length cols) 0) (> (length global) 0))
- (dotimes (x count)
- (dotimes (col ses--numcols)
- ;;These cells are always nil, only constant formatting printed
- (1value (ses-print-cell (+ x row) col))))))
+ ;;If any cell printers insert constant text, insert that text into
+ ;;the line.
+ (if (ses--blank-line-needs-printing-p)
+ (dotimes (x count)
+ (dotimes (col ses--numcols)
+ ;;These cells are always nil, only constant formatting printed
+ (1value (ses-print-cell (+ x row) col)))))
(when (> ses--header-row row)
;;Inserting before header
(ses-set-parameter 'ses--header-row (+ ses--header-row count))
@@ -3667,9 +3682,8 @@ highlighted range in the spreadsheet."
"Rename current cell."
(interactive "*SEnter new name: ")
(or
- (and (local-variable-p new-name)
- (ses-is-cell-sym-p new-name)
- (error "Already a cell name"))
+ (and (ses-is-cell-sym-p new-name)
+ (error "Already a cell name"))
(and (boundp new-name)
(null (yes-or-no-p
(format-message
diff --git a/lisp/shell.el b/lisp/shell.el
index ca86059f9de..cd49d289403 100644
--- a/lisp/shell.el
+++ b/lisp/shell.el
@@ -345,10 +345,10 @@ undefined commands."
"List of directories saved by pushd in this buffer's shell.
Thus, this does not include the shell's current directory.")
-(defvaralias 'shell-dirtrack-mode 'shell-dirtrackp)
-
-(defvar shell-dirtrackp t
- "Non-nil in a shell buffer means directory tracking is enabled.")
+(defvaralias 'shell-dirtrackp 'shell-dirtrack-mode
+ "Non-nil in a shell buffer means directory tracking is enabled.
+Directory tracking (`shell-dirtrack-mode') is automatically enabled
+when `shell-mode' is activated.")
(defvar shell-last-dir nil
"Keep track of last directory for ksh `cd -' command.")
@@ -365,6 +365,12 @@ Useful for shells like zsh that has this feature."
:group 'shell-directories
:version "28.1")
+(defcustom shell-get-old-input-include-continuation-lines nil
+ "Whether `shell-get-old-input' includes \"\\\" lines."
+ :type 'boolean
+ :group 'shell
+ :version "30.1")
+
(defcustom shell-kill-buffer-on-exit nil
"Kill a shell buffer after the shell process terminates."
:type 'boolean
@@ -505,6 +511,39 @@ Useful for shells like zsh that has this feature."
(push (mapconcat #'identity (nreverse arg) "") args)))
(cons (nreverse args) (nreverse begins)))))
+(defun shell-get-old-input ()
+ "Default for `comint-get-old-input' in `shell-mode'.
+If `comint-use-prompt-regexp' is nil, then either
+return the current input field (if point is on an input field), or the
+current line (if point is on an output field).
+If `comint-use-prompt-regexp' is non-nil, then return
+the current line, with any initial string matching the regexp
+`comint-prompt-regexp' removed.
+In either case, if `shell-get-old-input-include-continuation-lines'
+is non-nil and the current line ends with a backslash, the next
+line is also included and examined for a backslash, ending with a
+final line without a backslash."
+ (let (field-prop bof)
+ (if (and (not comint-use-prompt-regexp)
+ ;; Make sure we're in an input rather than output field.
+ (not (setq field-prop (get-char-property
+ (setq bof (field-beginning)) 'field))))
+ (field-string-no-properties bof)
+ (comint-bol)
+ (let ((start (point)))
+ (cond ((or comint-use-prompt-regexp
+ (eq field-prop 'output))
+ (goto-char (line-end-position))
+ (when shell-get-old-input-include-continuation-lines
+ ;; Include continuation lines as long as the current
+ ;; line ends with a backslash.
+ (while (and (not (eobp))
+ (= (char-before) ?\\))
+ (goto-char (line-end-position 2)))))
+ (t
+ (goto-char (field-end))))
+ (buffer-substring-no-properties start (point))))))
+
;;;###autoload
(defun split-string-shell-command (string)
"Split STRING (a shell command) into a list of strings.
@@ -555,6 +594,9 @@ Shell buffers. It implements `shell-completion-execonly' for
;; Don't use pcomplete's defaulting mechanism, rely on
;; shell-dynamic-complete-functions instead.
(setq-local pcomplete-default-completion-function #'ignore)
+ ;; Do not expand remote file names.
+ (setq-local pcomplete-remote-file-ignore
+ (not (file-remote-p default-directory)))
(setq-local comint-input-autoexpand shell-input-autoexpand)
;; Not needed in shell-mode because it's inherited from comint-mode, but
;; placed here for read-shell-command.
@@ -564,6 +606,9 @@ Shell buffers. It implements `shell-completion-execonly' for
(defvar sh-shell-file)
+(declare-function w32-application-type "w32proc.c"
+ (program) t)
+
(define-derived-mode shell-mode comint-mode "Shell"
"Major mode for interacting with an inferior shell.
\\<shell-mode-map>
@@ -641,6 +686,7 @@ command."
(setq-local font-lock-defaults '(shell-font-lock-keywords t))
(setq-local shell-dirstack nil)
(setq-local shell-last-dir nil)
+ (setq-local comint-get-old-input #'shell-get-old-input)
;; People expect Shell mode to keep the last line of output at
;; window bottom.
(setq-local scroll-conservatively 101)
@@ -711,6 +757,11 @@ command."
((string-equal shell "ksh") "echo $PWD ~-")
;; Bypass any aliases. TODO all shells could use this.
((string-equal shell "bash") "command dirs")
+ ((and (string-equal shell "bash.exe")
+ (eq system-type 'windows-nt)
+ (eq (w32-application-type (executable-find "bash.exe"))
+ 'msys))
+ "command pwd -W")
((string-equal shell "zsh") "dirs -l")
(t "dirs")))
;; Bypass a bug in certain versions of bash.
@@ -956,6 +1007,21 @@ Make the shell buffer the current buffer, and return it.
;; replace it with a process filter that watches for and strips out
;; these messages.
+(define-minor-mode shell-dirtrack-mode
+ "Toggle directory tracking in this shell buffer (Shell Dirtrack mode).
+This assigns a buffer-local non-nil value to `shell-dirtrackp'.
+
+The `dirtrack' package provides an alternative implementation of
+this feature; see the function `dirtrack-mode'. Also see
+`comint-osc-directory-tracker' for an escape-sequence based
+solution."
+ :lighter nil
+ :interactive (shell-mode)
+ (setq list-buffers-directory (if shell-dirtrack-mode default-directory))
+ (if shell-dirtrack-mode
+ (add-hook 'comint-input-filter-functions #'shell-directory-tracker nil t)
+ (remove-hook 'comint-input-filter-functions #'shell-directory-tracker t)))
+
(defun shell-directory-tracker (str)
"Tracks cd, pushd and popd commands issued to the shell.
This function is called on each input passed to the shell.
@@ -972,7 +1038,7 @@ and `shell-popd-regexp', while `shell-pushd-tohome', `shell-pushd-dextract',
and `shell-pushd-dunique' control the behavior of the relevant command.
Environment variables are expanded, see function `substitute-in-file-name'."
- (if shell-dirtrackp
+ (if shell-dirtrack-mode
;; We fail gracefully if we think the command will fail in the shell.
;;; (with-demoted-errors "Directory tracker failure: %s"
;; This fails so often that it seems better to just ignore errors (?).
@@ -1126,23 +1192,10 @@ Environment variables are expanded, see function `substitute-in-file-name'."
(and (string-match "^\\+[1-9][0-9]*$" str)
(string-to-number str)))
-(define-minor-mode shell-dirtrack-mode
- "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'. 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
- (add-hook 'comint-input-filter-functions #'shell-directory-tracker nil t)
- (remove-hook 'comint-input-filter-functions #'shell-directory-tracker t)))
-
(defun shell-cd (dir)
"Do normal `cd' to DIR, and set `list-buffers-directory'."
(cd dir)
- (if shell-dirtrackp
+ (if shell-dirtrack-mode
(setq list-buffers-directory default-directory)))
(defun shell-resync-dirs ()
@@ -1331,7 +1384,12 @@ Returns t if successful."
(while path-dirs
(setq dir (file-name-as-directory (comint-directory (or (car path-dirs) ".")))
comps-in-dir (and (file-accessible-directory-p dir)
- (file-name-all-completions filenondir dir)))
+ (condition-case nil
+ (file-name-all-completions filenondir dir)
+ ;; Systems such as Android sometimes
+ ;; put inaccessible directories in
+ ;; PATH.
+ (permission-denied nil))))
;; Go thru each completion found, to see whether it should be used.
(while comps-in-dir
(setq file (car comps-in-dir)
diff --git a/lisp/simple.el b/lisp/simple.el
index d91efb23363..0645f18cc78 100644
--- a/lisp/simple.el
+++ b/lisp/simple.el
@@ -623,7 +623,7 @@ A non-nil INTERACTIVE argument means to run the `post-self-insert-hook'."
(beforepos (point))
(last-command-event ?\n)
;; Don't auto-fill if we have a prefix argument.
- (auto-fill-function (if arg nil auto-fill-function))
+ (inhibit-auto-fill (or inhibit-auto-fill arg))
(arg (prefix-numeric-value arg))
(procsym (make-symbol "newline-postproc")) ;(bug#46326)
(postproc
@@ -1029,7 +1029,7 @@ that if you use overwrite mode as your normal editing mode, you can use
this function to insert characters when necessary.
In binary overwrite mode, this function does overwrite, and octal
-(or decimal or hex) digits are interpreted as a character code. This
+\(or decimal or hex) digits are interpreted as a character code. This
is intended to be useful for editing binary files."
(interactive "*p")
(let* ((char
@@ -1762,6 +1762,7 @@ not at the start of a line.
When IGNORE-INVISIBLE-LINES is non-nil, invisible lines are not
included in the count."
+ (declare (side-effect-free t))
(save-excursion
(save-restriction
(narrow-to-region start end)
@@ -2086,6 +2087,9 @@ of the prefix argument for `eval-expression' and
((= num -1) most-positive-fixnum)
(t eval-expression-print-maximum-character)))))
+(defun eval-expression--debug (err)
+ (funcall debugger 'error err :backtrace-base #'eval-expression--debug))
+
;; We define this, rather than making `eval' interactive,
;; for the sake of completion of names like eval-region, eval-buffer.
(defun eval-expression (exp &optional insert-value no-truncate char-print-limit)
@@ -2119,23 +2123,17 @@ this command arranges for all errors to enter the debugger."
(cons (read--expression "Eval: ")
(eval-expression-get-print-arguments current-prefix-arg)))
- (let (result)
+ (let* (result
+ (runfun
+ (lambda ()
+ (setq result
+ (values--store-value
+ (eval (let ((lexical-binding t)) (macroexpand-all exp))
+ t))))))
(if (null eval-expression-debug-on-error)
- (setq result
- (values--store-value
- (eval (let ((lexical-binding t)) (macroexpand-all exp)) t)))
- (let ((old-value (make-symbol "t")) new-value)
- ;; Bind debug-on-error to something unique so that we can
- ;; detect when evalled code changes it.
- (let ((debug-on-error old-value))
- (setq result
- (values--store-value
- (eval (let ((lexical-binding t)) (macroexpand-all exp)) t)))
- (setq new-value debug-on-error))
- ;; If evalled code has changed the value of debug-on-error,
- ;; propagate that change to the global binding.
- (unless (eq old-value new-value)
- (setq debug-on-error new-value))))
+ (funcall runfun)
+ (handler-bind ((error #'eval-expression--debug))
+ (funcall runfun)))
(let ((print-length (unless no-truncate eval-expression-print-length))
(print-level (unless no-truncate eval-expression-print-level))
@@ -2426,9 +2424,7 @@ BUFFER."
"Say whether MODES are in action in BUFFER.
This is the case if either the major mode is derived from one of MODES,
or (if one of MODES is a minor mode), if it is switched on in BUFFER."
- (or (apply #'provided-mode-derived-p
- (buffer-local-value 'major-mode buffer)
- modes)
+ (or (provided-mode-derived-p (buffer-local-value 'major-mode buffer) modes)
;; It's a minor mode.
(seq-intersection modes
(buffer-local-value 'local-minor-modes buffer)
@@ -2503,7 +2499,7 @@ Equivalent key-bindings are also shown in the completion list of
:group 'keyboard
:type '(choice (const :tag "off" nil)
(natnum :tag "time" 2)
- (other :tag "on")))
+ (other :tag "on" t)))
(defcustom extended-command-suggest-shorter t
"If non-nil, show a shorter \\[execute-extended-command] invocation \
@@ -2719,7 +2715,16 @@ function as needed."
(let ((doc (car body)))
(when (funcall docstring-p doc)
doc)))
- (_ (signal 'invalid-function (list function))))))
+ ((pred symbolp)
+ (let ((f (indirect-function function)))
+ (if f (function-documentation f)
+ (signal 'void-function (list function)))))
+ (`(macro . ,f) (function-documentation f))
+ (_
+ (let ((doc (internal-subr-documentation function)))
+ (if (eq t doc)
+ (signal 'invalid-function (list function))
+ doc))))))
(cl-defmethod function-documentation ((function accessor))
(oclosure--accessor-docstring function)) ;; FIXME: η-reduce!
@@ -2739,7 +2744,8 @@ instead."
nil)
(cl-defmethod oclosure-interactive-form ((f cconv--interactive-helper))
- `(interactive (funcall ',(cconv--interactive-helper--if f))))
+ (let ((if (cconv--interactive-helper--if f)))
+ `(interactive ,(if (functionp if) `(funcall ',if) if))))
(defun command-execute (cmd &optional record-flag keys special)
;; BEWARE: Called directly from the C code.
@@ -2978,11 +2984,17 @@ this by calling a function defined by `minibuffer-default-add-function'.")
(defun minibuffer-default-add-completions ()
"Return a list of all completions without the default value.
This function is used to add all elements of the completion table to
-the end of the list of defaults just after the default value."
+the end of the list of defaults just after the default value.
+If you don't want to add initial completions to the default value,
+use either `minibuffer-setup-hook' or `minibuffer-with-setup-hook'
+to set the value of `minibuffer-default-add-function' to nil."
(let ((def minibuffer-default)
- (all (all-completions ""
- minibuffer-completion-table
- minibuffer-completion-predicate)))
+ ;; Avoid some popular completions with undefined order
+ (all (unless (memq minibuffer-completion-table
+ `(help--symbol-completion-table ,obarray))
+ (all-completions ""
+ minibuffer-completion-table
+ minibuffer-completion-predicate))))
(if (listp def)
(append def all)
(cons def (delete def all)))))
@@ -3862,16 +3874,14 @@ whether (MARKER . ADJUSTMENT) undo elements are in the region,
because markers can be arbitrarily relocated. Instead, pass the
marker adjustment's corresponding (TEXT . POS) element."
(cond ((integerp undo-elt)
- (and (>= undo-elt start)
- (<= undo-elt end)))
+ (<= start undo-elt end))
((eq undo-elt nil)
t)
((atom undo-elt)
nil)
((stringp (car undo-elt))
;; (TEXT . POSITION)
- (and (>= (abs (cdr undo-elt)) start)
- (<= (abs (cdr undo-elt)) end)))
+ (<= start (abs (cdr undo-elt)) end))
((and (consp undo-elt) (markerp (car undo-elt)))
;; (MARKER . ADJUSTMENT)
(<= start (car undo-elt) end))
@@ -4086,10 +4096,11 @@ default values.")
"Amalgamate undo if necessary.
This function can be called before an amalgamating command. It
removes the previous `undo-boundary' if a series of such calls
-have been made. By default `self-insert-command' and
-`delete-char' are the only amalgamating commands, although this
-function could be called by any command wishing to have this
-behavior."
+have been made. `self-insert-command' and `delete-char' are the
+most common amalgamating commands, although this function can be
+called by any command which desires this behavior.
+`analyze-text-conversion' (which see) is also an amalgamating
+command in most circumstances."
(let ((last-amalgamating-count
(undo-auto--last-boundary-amalgamating-number)))
(setq undo-auto--this-command-amalgamating t)
@@ -4259,19 +4270,19 @@ This buffer is used when `shell-command' or `shell-command-on-region'
is run interactively. A value of nil means that output to stderr and
stdout will be intermixed in the output stream.")
-(declare-function mailcap-file-default-commands "mailcap" (files))
(declare-function dired-get-filename "dired" (&optional localp no-error-if-not-filep))
+(declare-function shell-command-guess "dired-aux" (files))
(defun minibuffer-default-add-shell-commands ()
"Return a list of all commands associated with the current file.
-This function is used to add all related commands retrieved by `mailcap'
-to the end of the list of defaults just after the default value."
- (interactive)
+This function is used to add all related commands retrieved by
+`shell-command-guess' to the end of the list of defaults just
+after the default value."
(let* ((filename (if (listp minibuffer-default)
(car minibuffer-default)
minibuffer-default))
- (commands (and filename (require 'mailcap nil t)
- (mailcap-file-default-commands (list filename)))))
+ (commands (and filename (require 'dired-aux)
+ (shell-command-guess (list filename)))))
(setq commands (mapcar (lambda (command)
(concat command " " filename))
commands))
@@ -4725,7 +4736,7 @@ impose the use of a shell (with its need to quote arguments)."
(when (buffer-live-p buf)
(remove-function (process-filter proc)
nonce)
- (display-buffer buf))))
+ (display-buffer buf '(nil (allow-no-window . t))))))
`((name . ,nonce)))))))
;; Otherwise, command is executed synchronously.
(shell-command-on-region (point) (point) command
@@ -4749,6 +4760,30 @@ Also see the `async-shell-command-buffer' variable."
action))
(user-error "Shell command in progress"))))
+(defun file-user-uid ()
+ "Return the connection-local effective uid.
+This is similar to `user-uid', but may invoke a file name handler
+based on `default-directory'. See Info node `(elisp)Magic File
+Names'.
+
+If a file name handler is unable to retrieve the effective uid,
+this function will instead return -1."
+ (if-let ((handler (find-file-name-handler default-directory 'file-user-uid)))
+ (funcall handler 'file-user-uid)
+ (user-uid)))
+
+(defun file-group-gid ()
+ "Return the connection-local effective gid.
+This is similar to `group-gid', but may invoke a file name handler
+based on `default-directory'. See Info node `(elisp)Magic File
+Names'.
+
+If a file name handler is unable to retrieve the effective gid,
+this function will instead return -1."
+ (if-let ((handler (find-file-name-handler default-directory 'file-group-gid)))
+ (funcall handler 'file-group-gid)
+ (group-gid)))
+
(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
@@ -4865,7 +4900,7 @@ appears at the end of the output.
Optional fourth arg OUTPUT-BUFFER specifies where to put the
command's output. If the value is a buffer or buffer name,
erase that buffer and insert the output there; a non-nil value of
-`shell-command-dont-erase-buffer' prevent to erase the buffer.
+`shell-command-dont-erase-buffer' prevents erasing the buffer.
If the value is nil, use the buffer specified by `shell-command-buffer-name'.
Any other non-nil value means to insert the output in the
current buffer after START.
@@ -5121,7 +5156,7 @@ never with `setq'.")
(defcustom process-file-return-signal-string nil
"Whether to return a string describing the signal interrupting a process.
When a process returns an exit code greater than 128, it is
-interpreted as a signal. `process-file' requires to return a
+interpreted as a signal. `process-file' requires returning a
string describing this signal.
Since there are processes violating this rule, returning exit
codes greater than 128 which are not bound to a signal,
@@ -6384,7 +6419,7 @@ PROMPT is a string to prompt with."
0 (length s)
'(
keymap local-map action mouse-action
- button category help-args)
+ read-only button category help-args)
s)
s)
kill-ring))
@@ -6435,9 +6470,9 @@ If non-nil, the kill ring is rotated after selecting previously killed text."
(defun yank-from-kill-ring (string &optional arg)
"Select a stretch of previously killed text and insert (\"paste\") it.
-This command allows to choose one of the stretches of text killed
-or yanked by previous commands, which are recorded in `kill-ring',
-and reinsert the chosen kill at point.
+This command allows you to select one of the stretches of text
+killed or yanked by previous commands, which are recorded in
+`kill-ring', and reinsert the chosen kill at point.
This command prompts for a previously-killed text in the minibuffer.
Use the minibuffer history and search commands, or the minibuffer
@@ -6538,7 +6573,7 @@ If the Unicode tables are not yet available, e.g. during bootstrap,
then gives correct answers only for ASCII characters."
(cond ((unicode-property-table-internal 'lowercase)
(characterp (get-char-code-property char 'lowercase)))
- ((and (>= char ?A) (<= char ?Z)))))
+ ((<= ?A char ?Z))))
(defun zap-to-char (arg char &optional interactive)
"Kill up to and including ARGth occurrence of CHAR.
@@ -6848,6 +6883,7 @@ is active, and returns an integer or nil in the usual way.
If you are using this in an editing command, you are most likely making
a mistake; see the documentation of `set-mark'."
+ (declare (side-effect-free t))
(if (or force (not transient-mark-mode) mark-active mark-even-if-inactive)
(marker-position (mark-marker))
(signal 'mark-inactive nil)))
@@ -8418,7 +8454,7 @@ even beep.)"
(and (= (cdr (nth 6 (posn-at-point))) orig-vlnum)
;; Make sure we delete the character where the line wraps
;; under visual-line-mode, be it whitespace or a
- ;; character whose category set allows to wrap at it.
+ ;; character whose category set permits wrapping at it.
(or (looking-at-p "[ \t]")
(and word-wrap-by-category
(aref (char-category-set (following-char)) ?\|)))
@@ -8544,12 +8580,12 @@ variables `truncate-lines' and `truncate-partial-width-windows'."
"Interchange characters around point, moving forward one character.
With prefix arg ARG, effect is to take character before point
and drag it forward past ARG other characters (backward if ARG negative).
-If no argument and at end of line, the previous two chars are exchanged."
- (interactive "*P")
- (when (and (null arg) (eolp) (not (bobp))
+If at end of line, the previous two chars are exchanged."
+ (interactive "*p")
+ (when (and (eolp) (not (bobp))
(not (get-text-property (1- (point)) 'read-only)))
(forward-char -1))
- (transpose-subr 'forward-char (prefix-numeric-value arg)))
+ (transpose-subr #'forward-char arg))
(defun transpose-words (arg)
"Interchange words around point, leaving point at end of them.
@@ -8561,6 +8597,45 @@ are interchanged."
(interactive "*p")
(transpose-subr 'forward-word arg))
+(defun transpose-sexps-default-function (arg)
+ "Default method to locate a pair of points for transpose-sexps."
+ ;; Here we should try to simulate the behavior of
+ ;; (cons (progn (forward-sexp x) (point))
+ ;; (progn (forward-sexp (- x)) (point)))
+ ;; Except that we don't want to rely on the second forward-sexp
+ ;; putting us back to where we want to be, since forward-sexp-function
+ ;; might do funny things like infix-precedence.
+ (if (if (> arg 0)
+ (looking-at "\\sw\\|\\s_")
+ (and (not (bobp))
+ (save-excursion
+ (forward-char -1)
+ (looking-at "\\sw\\|\\s_"))))
+ ;; Jumping over a symbol. We might be inside it, mind you.
+ (progn (funcall (if (> arg 0)
+ #'skip-syntax-backward #'skip-syntax-forward)
+ "w_")
+ (cons (save-excursion (forward-sexp arg) (point)) (point)))
+ ;; Otherwise, we're between sexps. Take a step back before jumping
+ ;; to make sure we'll obey the same precedence no matter which
+ ;; direction we're going.
+ (funcall (if (> arg 0) #'skip-syntax-backward #'skip-syntax-forward)
+ " .")
+ (cons (save-excursion (forward-sexp arg) (point))
+ (progn (while (or (forward-comment (if (> arg 0) 1 -1))
+ (not (zerop (funcall (if (> arg 0)
+ #'skip-syntax-forward
+ #'skip-syntax-backward)
+ ".")))))
+ (point)))))
+
+(defvar transpose-sexps-function #'transpose-sexps-default-function
+ "If non-nil, `transpose-sexps' delegates to this function.
+
+This function takes one argument ARG, a number. Its expected
+return value is a position pair, which is a cons (BEG . END),
+where BEG and END are buffer positions.")
+
(defun transpose-sexps (arg &optional interactive)
"Like \\[transpose-chars] (`transpose-chars'), but applies to sexps.
Unlike `transpose-words', point must be between the two sexps and not
@@ -8576,38 +8651,7 @@ report errors as appropriate for this kind of usage."
(condition-case nil
(transpose-sexps arg nil)
(scan-error (user-error "Not between two complete sexps")))
- (transpose-subr
- (lambda (arg)
- ;; Here we should try to simulate the behavior of
- ;; (cons (progn (forward-sexp x) (point))
- ;; (progn (forward-sexp (- x)) (point)))
- ;; Except that we don't want to rely on the second forward-sexp
- ;; putting us back to where we want to be, since forward-sexp-function
- ;; might do funny things like infix-precedence.
- (if (if (> arg 0)
- (looking-at "\\sw\\|\\s_")
- (and (not (bobp))
- (save-excursion
- (forward-char -1)
- (looking-at "\\sw\\|\\s_"))))
- ;; Jumping over a symbol. We might be inside it, mind you.
- (progn (funcall (if (> arg 0)
- 'skip-syntax-backward 'skip-syntax-forward)
- "w_")
- (cons (save-excursion (forward-sexp arg) (point)) (point)))
- ;; Otherwise, we're between sexps. Take a step back before jumping
- ;; to make sure we'll obey the same precedence no matter which
- ;; direction we're going.
- (funcall (if (> arg 0) 'skip-syntax-backward 'skip-syntax-forward)
- " .")
- (cons (save-excursion (forward-sexp arg) (point))
- (progn (while (or (forward-comment (if (> arg 0) 1 -1))
- (not (zerop (funcall (if (> arg 0)
- 'skip-syntax-forward
- 'skip-syntax-backward)
- ".")))))
- (point)))))
- arg 'special)))
+ (transpose-subr transpose-sexps-function arg 'special)))
(defun transpose-lines (arg)
"Exchange current line and previous line, leaving point after both.
@@ -8632,13 +8676,15 @@ With argument 0, interchanges line point is in with line mark is in."
;; FIXME document SPECIAL.
(defun transpose-subr (mover arg &optional special)
"Subroutine to do the work of transposing objects.
-Works for lines, sentences, paragraphs, etc. MOVER is a function that
-moves forward by units of the given object (e.g. `forward-sentence',
-`forward-paragraph'). If ARG is zero, exchanges the current object
-with the one containing mark. If ARG is an integer, moves the
-current object past ARG following (if ARG is positive) or
-preceding (if ARG is negative) objects, leaving point after the
-current object."
+Works for lines, sentences, paragraphs, etc. MOVER is a function
+that moves forward by units of the given
+object (e.g. `forward-sentence', `forward-paragraph'), or a
+function calculating a cons of buffer positions.
+
+ If ARG is zero, exchanges the current object with the one
+containing mark. If ARG is an integer, moves the current object
+past ARG following (if ARG is positive) or preceding (if ARG is
+negative) objects, leaving point after the current object."
(let ((aux (if special mover
(lambda (x)
(cons (progn (funcall mover x) (point))
@@ -8665,6 +8711,8 @@ current object."
(goto-char (+ (car pos2) (- (cdr pos1) (car pos1))))))))
(defun transpose-subr-1 (pos1 pos2)
+ (unless (and pos1 pos2)
+ (error "Don't have two things to transpose"))
(when (> (car pos1) (cdr pos1)) (setq pos1 (cons (cdr pos1) (car pos1))))
(when (> (car pos2) (cdr pos2)) (setq pos2 (cons (cdr pos2) (car pos2))))
(when (> (car pos1) (car pos2))
@@ -8931,11 +8979,15 @@ unless optional argument SOFT is non-nil."
;; If we're not inside a comment, just try to indent.
(t (indent-according-to-mode))))))
+(defvar inhibit-auto-fill nil
+ "Non-nil means to do as if `auto-fill-mode' was disabled.")
+
(defun internal-auto-fill ()
"The function called by `self-insert-command' to perform auto-filling."
- (when (or (not comment-start)
- (not comment-auto-fill-only-comments)
- (nth 4 (syntax-ppss)))
+ (unless (or inhibit-auto-fill
+ (and comment-start
+ comment-auto-fill-only-comments
+ (not (nth 4 (syntax-ppss)))))
(funcall auto-fill-function)))
(defvar normal-auto-fill-function 'do-auto-fill
@@ -9120,6 +9172,14 @@ presented."
"Toggle buffer size display in the mode line (Size Indication mode)."
:global t :group 'mode-line)
+(defcustom remote-file-name-inhibit-auto-save nil
+ "When nil, `auto-save-mode' will auto-save remote files.
+Any other value means that it will not."
+ :group 'auto-save
+ :group 'tramp
+ :type 'boolean
+ :version "30.1")
+
(define-minor-mode auto-save-mode
"Toggle auto-saving in the current buffer (Auto Save mode).
@@ -9142,6 +9202,9 @@ For more details, see Info node `(emacs) Auto Save'."
(setq buffer-auto-save-file-name
(cond
((null val) nil)
+ ((and buffer-file-name remote-file-name-inhibit-auto-save
+ (file-remote-p buffer-file-name))
+ nil)
((and buffer-file-name auto-save-visited-file-name
(not buffer-read-only))
buffer-file-name)
@@ -9213,6 +9276,21 @@ it skips the contents of comments that end before point."
:type 'boolean
:group 'paren-blinking)
+(defcustom blink-matching-paren-highlight-offscreen nil
+ "If non-nil, highlight matched off-screen open paren in the echo area.
+This highlighting uses the `blink-matching-paren-offscreen' face."
+ :type 'boolean
+ :version "30.1"
+ :group 'paren-blinking)
+
+(defface blink-matching-paren-offscreen
+ '((t :foreground "green"))
+ "Face for showing in the echo area matched open paren that is off-screen.
+This face is used only when `blink-matching-paren-highlight-offscreen'
+is non-nil."
+ :version "30.1"
+ :group 'paren-blinking)
+
(defun blink-matching-check-mismatch (start end)
"Return whether or not START...END are matching parens.
END is the current point and START is the blink position.
@@ -9310,47 +9388,78 @@ The function should return non-nil if the two tokens do not match.")
(delete-overlay blink-matching--overlay)))))
((not show-paren-context-when-offscreen)
(minibuffer-message
- "Matches %s"
- (substring-no-properties
- (blink-paren-open-paren-line-string blinkpos))))))))
+ "%s%s"
+ (propertize "Matches " 'face 'shadow)
+ (blink-paren-open-paren-line-string blinkpos)))))))
(defun blink-paren-open-paren-line-string (pos)
- "Return the line string that contains the openparen at POS."
+ "Return the line string that contains the openparen at POS.
+Remove the line string's properties but give the openparen a distinct
+face if `blink-matching-paren-highlight-offscreen' is non-nil."
(save-excursion
(goto-char pos)
;; Capture the regions in terms of (beg . end) conses whose
;; buffer-substrings we want to show as a context string. Ensure
;; they are font-locked (bug#59527).
- (let (regions)
- ;; Show what precedes the open in its line, if anything.
+ (let (regions
+ openparen-idx)
(cond
+ ;; Show what precedes the open in its line, if anything.
((save-excursion (skip-chars-backward " \t") (not (bolp)))
- (setq regions (list (cons (line-beginning-position)
- (1+ pos)))))
+ (let ((bol (line-beginning-position)))
+ (setq regions (list (cons bol (1+ pos)))
+ openparen-idx (- pos bol))))
;; Show what follows the open in its line, if anything.
((save-excursion
(forward-char 1)
(skip-chars-forward " \t")
(not (eolp)))
- (setq regions (list (cons pos (line-end-position)))))
+ (setq regions (list (cons pos (line-end-position)))
+ openparen-idx 0))
;; Otherwise show the previous nonblank line,
;; if there is one.
((save-excursion (skip-chars-backward "\n \t") (not (bobp)))
- (setq regions (list (cons (progn
- (skip-chars-backward "\n \t")
- (line-beginning-position))
- (progn (end-of-line)
- (skip-chars-backward " \t")
- (point)))
+ (setq regions (list (cons
+ (let (bol)
+ (skip-chars-backward "\n \t")
+ (setq bol (line-beginning-position)
+ openparen-idx (- bol))
+ bol)
+ (let (eol)
+ (end-of-line)
+ (skip-chars-backward " \t")
+ (setq eol (point)
+ openparen-idx (+ openparen-idx
+ eol
+ ;; (length "...")
+ 3))
+ eol))
(cons pos (1+ pos)))))
;; There is nothing to show except the char itself.
- (t (setq regions (list (cons pos (1+ pos))))))
+ (t (setq regions (list (cons pos (1+ pos)))
+ openparen-idx 0)))
;; Ensure we've font-locked the context region.
(font-lock-ensure (caar regions) (cdar (last regions)))
- (mapconcat (lambda (region)
- (buffer-substring (car region) (cdr region)))
- regions
- "..."))))
+ (let ((line-string
+ (mapconcat
+ (lambda (region)
+ (buffer-substring (car region) (cdr region)))
+ regions
+ "..."))
+ (openparen-next-char-idx (1+ openparen-idx)))
+ (setq line-string (substring-no-properties line-string))
+ (concat
+ (substring line-string
+ 0 openparen-idx)
+ (let ((matched-offscreen-openparen
+ (substring line-string
+ openparen-idx openparen-next-char-idx)))
+ (if blink-matching-paren-highlight-offscreen
+ (propertize matched-offscreen-openparen
+ 'face 'blink-matching-paren-offscreen)
+ matched-offscreen-openparen))
+ (substring line-string
+ openparen-next-char-idx))))))
(defvar blink-paren-function 'blink-matching-open
"Function called, if non-nil, whenever a close parenthesis is inserted.
@@ -9712,10 +9821,15 @@ makes it easier to edit it."
(define-key map "\C-m" 'choose-completion)
(define-key map "\e\e\e" 'delete-completion-window)
(define-key map [remap keyboard-quit] #'delete-completion-window)
+ (define-key map [up] 'previous-line-completion)
+ (define-key map [down] 'next-line-completion)
(define-key map [left] 'previous-completion)
(define-key map [right] 'next-completion)
(define-key map [?\t] 'next-completion)
(define-key map [backtab] 'previous-completion)
+ (define-key map [M-up] 'minibuffer-previous-completion)
+ (define-key map [M-down] 'minibuffer-next-completion)
+ (define-key map "\M-\r" 'minibuffer-choose-completion)
(define-key map "z" 'kill-current-buffer)
(define-key map "n" 'next-completion)
(define-key map "p" 'previous-completion)
@@ -9770,8 +9884,9 @@ Go to the window from which completion was requested."
(select-window (get-buffer-window buf))))))
(defcustom completion-auto-wrap t
- "Non-nil means to wrap around when selecting completion options.
-This affects the commands `next-completion' and `previous-completion'.
+ "Non-nil means to wrap around when selecting completion candidates.
+This affects the commands `next-completion', `previous-completion',
+`next-line-completion' and `previous-line-completion'.
When `completion-auto-select' is t, it wraps through the minibuffer
for the commands bound to the TAB key."
:type 'boolean
@@ -9779,12 +9894,12 @@ for the commands bound to the TAB key."
:group 'completion)
(defcustom completion-auto-select nil
- "Non-nil means to automatically select the *Completions* buffer.
+ "If non-nil, automatically select the window showing 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 showing the completions list buffer, and the next TAB will
-switch to that window.
+select 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)
@@ -9795,7 +9910,7 @@ the completions is popped up and down."
:group 'completion)
(defun first-completion ()
- "Move to the first item in the completion list."
+ "Move to the first item in the completions buffer."
(interactive)
(goto-char (point-min))
(if (get-text-property (point) 'mouse-face)
@@ -9807,7 +9922,7 @@ the completions is popped up and down."
(goto-char pos))))
(defun last-completion ()
- "Move to the last item in the completion list."
+ "Move to the last item in the completions buffer."
(interactive)
(goto-char (previous-single-property-change
(point-max) 'mouse-face nil (point-min)))
@@ -9817,7 +9932,7 @@ the completions is popped up and down."
(goto-char pos))))
(defun previous-completion (n)
- "Move to the previous item in the completion list.
+ "Move to the previous item in the completions buffer.
With prefix argument N, move back N items (negative N means move
forward).
@@ -9825,8 +9940,22 @@ Also see the `completion-auto-wrap' variable."
(interactive "p")
(next-completion (- n)))
+(defun completion--move-to-candidate-start ()
+ "If in a completion candidate, move point to its start."
+ (when (and (get-text-property (point) 'mouse-face)
+ (not (bobp))
+ (get-text-property (1- (point)) 'mouse-face))
+ (goto-char (previous-single-property-change (point) 'mouse-face))))
+
+(defun completion--move-to-candidate-end ()
+ "If in a completion candidate, move point to its end."
+ (when (and (get-text-property (point) 'mouse-face)
+ (not (eobp))
+ (get-text-property (1+ (point)) 'mouse-face))
+ (goto-char (or (next-single-property-change (point) 'mouse-face) (point-max)))))
+
(defun next-completion (n)
- "Move to the next item in the completion list.
+ "Move to the next item in the completions buffer.
With prefix argument N, move N items (negative N means move
backward).
@@ -9889,6 +10018,98 @@ Also see the `completion-auto-wrap' variable."
(when (/= 0 n)
(switch-to-minibuffer))))
+(defun previous-line-completion (&optional n)
+ "Move to completion candidate on the previous line in the completions buffer.
+With prefix argument N, move back N lines (negative N means move forward).
+
+Also see the `completion-auto-wrap' variable."
+ (interactive "p")
+ (next-line-completion (- n)))
+
+(defun next-line-completion (&optional n)
+ "Move to completion candidate on the next line in the completions buffer.
+With prefix argument N, move N lines forward (negative N means move backward).
+
+Also see the `completion-auto-wrap' variable."
+ (interactive "p")
+ (let (line column pos found)
+ (when (and (bobp)
+ (> n 0)
+ (get-text-property (point) 'mouse-face)
+ (not (get-text-property (point) 'first-completion)))
+ (let ((inhibit-read-only t))
+ (add-text-properties (point) (1+ (point)) '(first-completion t)))
+ (setq n (1- n)))
+
+ (if (get-text-property (point) 'mouse-face)
+ ;; If in a completion, move to the start of it.
+ (completion--move-to-candidate-start)
+ ;; Try to move to the previous completion.
+ (setq pos (previous-single-property-change (point) 'mouse-face))
+ (if pos
+ ;; Move to the start of the previous completion.
+ (progn
+ (goto-char pos)
+ (unless (get-text-property (point) 'mouse-face)
+ (goto-char (previous-single-property-change
+ (point) 'mouse-face nil (point-min)))))
+ (cond ((> n 0) (setq n (1- n)) (first-completion))
+ ((< n 0) (first-completion)))))
+
+ (while (> n 0)
+ (setq found nil pos nil column (current-column) line (line-number-at-pos))
+ (completion--move-to-candidate-end)
+ (while (and (not found)
+ (eq (forward-line 1) 0)
+ (not (eobp))
+ (move-to-column column))
+ (when (get-text-property (point) 'mouse-face)
+ (setq found t)))
+ (when (not found)
+ (if (not completion-auto-wrap)
+ (last-completion)
+ (save-excursion
+ (goto-char (point-min))
+ (when (and (eq (move-to-column column) column)
+ (get-text-property (point) 'mouse-face))
+ (setq pos (point)))
+ (while (and (not pos) (> line (line-number-at-pos)))
+ (forward-line 1)
+ (when (and (eq (move-to-column column) column)
+ (get-text-property (point) 'mouse-face))
+ (setq pos (point)))))
+ (if pos (goto-char pos))))
+ (setq n (1- n)))
+
+ (while (< n 0)
+ (setq found nil pos nil column (current-column) line (line-number-at-pos))
+ (completion--move-to-candidate-start)
+ (while (and (not found)
+ (eq (forward-line -1) 0)
+ (move-to-column column))
+ (when (get-text-property (point) 'mouse-face)
+ (setq found t)))
+ (when (not found)
+ (if (not completion-auto-wrap)
+ (first-completion)
+ (save-excursion
+ (goto-char (point-max))
+ (when (and (eq (move-to-column column) column)
+ (get-text-property (point) 'mouse-face))
+ (setq pos (point)))
+ (while (and (not pos) (< line (line-number-at-pos)))
+ (forward-line -1)
+ (when (and (eq (move-to-column column) column)
+ (get-text-property (point) 'mouse-face))
+ (setq pos (point)))))
+ (if pos (goto-char pos))))
+ (setq n (1+ n)))))
+
+(defvar choose-completion-deselect-if-after nil
+ "If non-nil, don't choose a completion candidate if point is right after it.
+
+This makes `completions--deselect' effective.")
+
(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.
@@ -9909,6 +10130,10 @@ minibuffer, but don't quit the completions window."
(insert-function completion-list-insert-choice-function)
(completion-no-auto-exit (if no-exit t completion-no-auto-exit))
(choice
+ (if choose-completion-deselect-if-after
+ (if-let ((str (get-text-property (posn-point (event-start event)) 'completion--string)))
+ (substring-no-properties str)
+ (error "No completion here"))
(save-excursion
(goto-char (posn-point (event-start event)))
(let (beg)
@@ -9924,7 +10149,7 @@ minibuffer, but don't quit the completions window."
beg 'completion--string)
beg))
(substring-no-properties
- (get-text-property beg 'completion--string))))))
+ (get-text-property beg 'completion--string)))))))
(unless (buffer-live-p buffer)
(error "Destination buffer is dead"))
@@ -10073,6 +10298,8 @@ Called from `temp-buffer-show-hook'."
:version "22.1"
:group 'completion)
+(defvar minibuffer-visible-completions--always-bind)
+
;; 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 ()
@@ -10110,11 +10337,28 @@ Called from `temp-buffer-show-hook'."
;; Maybe insert help string.
(when completion-show-help
(goto-char (point-min))
- (if (display-mouse-p)
- (insert "Click on a completion to select it.\n"))
- (insert (substitute-command-keys
- "In this buffer, type \\[choose-completion] to \
-select the completion near point.\n\n"))))))
+ (if minibuffer-visible-completions
+ (let ((helps
+ (with-current-buffer (window-buffer (active-minibuffer-window))
+ (let ((minibuffer-visible-completions--always-bind t))
+ (list
+ (substitute-command-keys
+ (if (display-mouse-p)
+ "Click or type \\[minibuffer-choose-completion-or-exit] on a completion to select it.\n"
+ "Type \\[minibuffer-choose-completion-or-exit] on a completion to select it.\n"))
+ (substitute-command-keys
+ "Type \\[minibuffer-next-completion], \\[minibuffer-previous-completion], \
+\\[minibuffer-next-line-completion], \\[minibuffer-previous-line-completion] \
+to move point between completions.\n\n"))))))
+ (dolist (help helps)
+ (insert help)))
+ (insert (substitute-command-keys
+ (if (display-mouse-p)
+ "Click or type \\[minibuffer-choose-completion] on a completion to select it.\n"
+ "Type \\[minibuffer-choose-completion] on a completion to select it.\n")))
+ (insert (substitute-command-keys
+ "Type \\[minibuffer-next-completion] or \\[minibuffer-previous-completion] \
+to move point between completions.\n\n")))))))
(add-hook 'completion-setup-hook #'completion-setup-function)
@@ -10182,19 +10426,34 @@ SYMBOL is the name of this modifier, as a symbol.
LSHIFTBY is the numeric value of this modifier, in keyboard events.
PREFIX is the string that represents this modifier in an event type symbol."
(if (numberp event)
- (cond ((eq symbol 'control)
- (if (<= 64 (upcase event) 95)
- (- (upcase event) 64)
- (logior (ash 1 lshiftby) event)))
- ((eq symbol 'shift)
- ;; FIXME: Should we also apply this "upcase" behavior of shift
- ;; to non-ascii letters?
- (if (and (<= (downcase event) ?z)
- (>= (downcase event) ?a))
- (upcase event)
- (logior (ash 1 lshiftby) event)))
- (t
- (logior (ash 1 lshiftby) event)))
+ ;; Use the base event to determine how the control and shift
+ ;; modifiers should be applied.
+ (let* ((base-event (event-basic-type event)))
+ (cond ((eq symbol 'control)
+ (if (<= 64 (upcase base-event) 95)
+ ;; Apply the control modifier...
+ (logior (- (upcase base-event) 64)
+ ;; ... and any additional modifiers
+ ;; specified in the original event...
+ (logand event (logior ?\M-\0 ?\C-\0 ?\S-\0
+ ?\H-\0 ?\s-\0 ?\A-\0))
+ ;; ... including any shift modifier that
+ ;; `event-basic-type' may have removed.
+ (if (<= ?A event ?Z) ?\S-\0 0))
+ (logior (ash 1 lshiftby) event)))
+ ((eq symbol 'shift)
+ ;; FIXME: Should we also apply this "upcase" behavior of shift
+ ;; to non-ascii letters?
+ (if (<= ?a base-event ?z)
+ ;; Apply the Shift modifier.
+ (logior (upcase base-event)
+ ;; ... and any additional modifiers
+ ;; specified in the original event.
+ (logand event (logior ?\M-\0 ?\C-\0 ?\S-\0
+ ?\H-\0 ?\s-\0 ?\A-\0)))
+ (logior (ash 1 lshiftby) event)))
+ (t
+ (logior (ash 1 lshiftby) event))))
(if (memq symbol (event-modifiers event))
event
(let ((event-type (if (symbolp event) event (car event))))
@@ -10467,7 +10726,7 @@ call `normal-erase-is-backspace-mode' (which see) instead."
(if (if (eq normal-erase-is-backspace 'maybe)
(and (not noninteractive)
(or (memq system-type '(ms-dos windows-nt))
- (memq window-system '(w32 ns pgtk haiku))
+ (memq window-system '(w32 ns pgtk haiku android))
(and (eq window-system 'x)
(fboundp 'x-backspace-delete-keys-p)
(x-backspace-delete-keys-p))
@@ -10543,10 +10802,10 @@ See also `normal-erase-is-backspace'."
(t
(if enabled
(progn
- (keyboard-translate ?\C-h ?\C-?)
- (keyboard-translate ?\C-? ?\C-d))
- (keyboard-translate ?\C-h ?\C-h)
- (keyboard-translate ?\C-? ?\C-?))))
+ (key-translate "C-h" "DEL")
+ (key-translate "DEL" "C-d"))
+ (key-translate "C-h" "C-h")
+ (key-translate "DEL" "DEL"))))
(if (called-interactively-p 'interactive)
(message "Delete key deletes %s"
@@ -10602,6 +10861,87 @@ and setting it to nil."
(setq-local vis-mode-saved-buffer-invisibility-spec
buffer-invisibility-spec)
(setq buffer-invisibility-spec nil)))
+
+
+(defvar read-passwd--mode-line-buffer nil
+ "Buffer to modify `mode-line-format' for showing/hiding passwords.")
+
+(defvar read-passwd--mode-line-icon nil
+ "Propertized mode line icon for showing/hiding passwords.")
+
+(defun read-passwd-toggle-visibility ()
+ "Toggle minibuffer contents visibility.
+Adapt also mode line."
+ (interactive)
+ (setq read-passwd--hide-password (not read-passwd--hide-password))
+ (with-current-buffer read-passwd--mode-line-buffer
+ (setq read-passwd--mode-line-icon
+ `(:propertize
+ ,(if icon-preference
+ (icon-string
+ (if read-passwd--hide-password
+ 'read-passwd--show-password-icon
+ 'read-passwd--hide-password-icon))
+ "")
+ mouse-face mode-line-highlight
+ local-map
+ (keymap
+ (mode-line keymap (mouse-1 . read-passwd-toggle-visibility)))))
+ (force-mode-line-update))
+ (read-passwd--hide-password))
+
+(define-minor-mode read-passwd-mode
+ "Toggle visibility of password in minibuffer."
+ :group 'mode-line
+ :group 'minibuffer
+ :keymap read-passwd-map
+ :version "30.1"
+
+ (require 'icons)
+ ;; It would be preferable to use "👁" ("\N{EYE}"). However, there is
+ ;; no corresponding Unicode char with a slash. So we use symbols as
+ ;; fallback only, with "⦵" ("\N{CIRCLE WITH HORIZONTAL BAR}") for
+ ;; hiding the password.
+ (define-icon read-passwd--show-password-icon nil
+ '((image "reveal.svg" "reveal.pbm" :height (0.8 . em))
+ (symbol "👁")
+ (text "<o>"))
+ "Mode line icon to show a hidden password."
+ :group mode-line-faces
+ :version "30.1"
+ :help-echo "mouse-1: Toggle password visibility")
+ (define-icon read-passwd--hide-password-icon nil
+ '((image "conceal.svg" "conceal.pbm" :height (0.8 . em))
+ (symbol "⦵")
+ (text "<\\>"))
+ "Mode line icon to hide a visible password."
+ :group mode-line-faces
+ :version "30.1"
+ :help-echo "mouse-1: Toggle password visibility")
+
+ (setq read-passwd--hide-password nil
+ ;; Stolen from `eldoc-minibuffer-message'.
+ read-passwd--mode-line-buffer
+ (window-buffer
+ (or (window-in-direction 'above (minibuffer-window))
+ (minibuffer-selected-window)
+ (get-largest-window))))
+
+ (if read-passwd-mode
+ (with-current-buffer read-passwd--mode-line-buffer
+ ;; Add `read-passwd--mode-line-icon'.
+ (when (listp mode-line-format)
+ (setq mode-line-format
+ (cons '(:eval read-passwd--mode-line-icon)
+ mode-line-format))))
+ (with-current-buffer read-passwd--mode-line-buffer
+ ;; Remove `read-passwd--mode-line-icon'.
+ (when (listp mode-line-format)
+ (setq mode-line-format (cdr mode-line-format)))))
+
+ (when read-passwd-mode
+ (read-passwd-toggle-visibility)))
+
(defvar messages-buffer-mode-map
(let ((map (make-sparse-keymap)))
@@ -10886,6 +11226,7 @@ killed."
(defsubst string-empty-p (string)
"Check whether STRING is empty."
+ (declare (pure t) (side-effect-free t))
(string= string ""))
(defun read-signal-name ()
@@ -10903,15 +11244,171 @@ killed."
(defun lax-plist-get (plist prop)
"Extract a value from a property list, comparing with `equal'."
- (declare (obsolete plist-get "29.1"))
+ (declare (pure t) (side-effect-free t) (obsolete plist-get "29.1"))
(plist-get plist prop #'equal))
(defun lax-plist-put (plist prop val)
"Change value in PLIST of PROP to VAL, comparing with `equal'."
(declare (obsolete plist-put "29.1"))
(plist-put plist prop val #'equal))
+
+;; Text conversion support. See textconv.c for more details about
+;; what this is.
+
+;; Actually in textconv.c.
+(defvar text-conversion-edits)
+
+;; Actually in elec-pair.el.
+(defvar electric-pair-preserve-balance)
+(declare-function electric-pair-analyze-conversion "elec-pair.el")
+
+;; Actually in emacs-lisp/timer.el.
+(declare-function timer-set-time "emacs-lisp/timer.el")
+
+(defvar-local post-text-conversion-hook nil
+ "Hook run after text is inserted by an input method.
+Each function in this list is run until one returns non-nil.
+When run, `last-command-event' is bound to the last character
+that was inserted by the input method.")
+
+(defun analyze-text-conversion ()
+ "Analyze the results of the previous text conversion event.
+
+For each insertion:
+
+ - Look for the insertion of a string starting or ending with a
+ character inside `auto-fill-chars', and fill the text around
+ it if `auto-fill-mode' is enabled.
+
+ - Look for the insertion of a new line, and cause automatic
+ line breaking of the previous line when `auto-fill-mode' is
+ enabled.
+
+ - Look for the deletion of a single electric pair character,
+ and delete the adjacent pair if
+ `electric-pair-delete-adjacent-pairs'.
+
+ - Run `post-self-insert-hook' for the last character of
+ any inserted text so that modes such as `electric-pair-mode'
+ can work.
+
+ - Run `post-text-conversion-hook' with `last-command-event' set
+ to the last character of any inserted text to finish up.
+
+Finally, amalgamate recent changes to the undo list with previous
+ones, unless a new line has been inserted or auto-fill has taken
+place. If undo information is being recorded, make sure
+`undo-auto-current-boundary-timer' will run within the next 5
+seconds."
+ (interactive)
+ ;; One important consideration to bear in mind when adjusting this
+ ;; code is to _never_ move point in reaction to an edit so long as
+ ;; the additional processing undertaken by this function does not
+ ;; also edit the buffer text.
+ (let ((any-nonephemeral nil)
+ point-moved)
+ ;; The list must be processed in reverse.
+ (dolist (edit (reverse text-conversion-edits))
+ ;; Filter out ephemeral edits and deletions after point. Here, we
+ ;; are only interested in insertions or deletions whose contents
+ ;; can be identified.
+ (when (stringp (nth 3 edit))
+ (with-current-buffer (car edit)
+ ;; Record that the point hasn't been moved by the execution
+ ;; of a post command or text conversion hook.
+ (setq point-moved nil)
+ (if (not (eq (nth 1 edit) (nth 2 edit)))
+ ;; Process this insertion. (nth 3 edit) is the text which
+ ;; was inserted.
+ (let* ((inserted (nth 3 edit))
+ ;; Get the first and last characters.
+ (start (aref inserted 0))
+ (end (aref inserted (1- (length inserted))))
+ ;; Figure out whether or not to auto-fill.
+ (auto-fill-p (or (aref auto-fill-chars start)
+ (aref auto-fill-chars end)))
+ ;; Figure out whether or not a newline was inserted.
+ (newline-p (string-search "\n" inserted))
+ ;; Save the current undo list to figure out
+ ;; whether or not auto-fill has actually taken
+ ;; place.
+ (old-undo-list buffer-undo-list)
+ ;; Save the point position to return it there
+ ;; later.
+ (old-point (point)))
+ (save-excursion
+ (if (and auto-fill-function newline-p)
+ (progn (goto-char (nth 2 edit))
+ (previous-logical-line)
+ (funcall auto-fill-function)
+ (setq old-point (point)))
+ (when (and auto-fill-function auto-fill-p)
+ (goto-char (nth 2 edit))
+ (funcall auto-fill-function)
+ (setq old-point (point))))
+ ;; Record whether or not this edit should result in
+ ;; an undo boundary being added.
+ (setq any-nonephemeral
+ (or any-nonephemeral newline-p
+ ;; See if auto-fill has taken place by
+ ;; comparing the current undo list with
+ ;; the saved head.
+ (not (eq old-undo-list
+ buffer-undo-list)))))
+ (goto-char (nth 2 edit))
+ (let ((last-command-event end)
+ (point (point)))
+ (unless (run-hook-with-args-until-success
+ 'post-text-conversion-hook)
+ (run-hooks 'post-self-insert-hook))
+ (when (not (eq (point) point))
+ (setq point-moved t)))
+ ;; If post-self-insert-hook doesn't move the point,
+ ;; restore it to its previous location. Generally,
+ ;; the call to goto-char upon processing the last edit
+ ;; recorded text-conversion-edit will see to this, but
+ ;; if the input method sets point expressly, no edit
+ ;; will be recorded, and point will wind up away from
+ ;; where the input method believes it is.
+ (unless point-moved
+ (goto-char old-point)))
+ ;; Process this deletion before point. (nth 2 edit) is the
+ ;; text which was deleted. Input methods typically prefer
+ ;; to edit words instead of deleting characters off their
+ ;; ends, but they seem to always send proper requests for
+ ;; deletion for punctuation.
+ (when (and (boundp 'electric-pair-delete-adjacent-pairs)
+ (symbol-value 'electric-pair-delete-adjacent-pairs)
+ ;; Make sure elec-pair is loaded.
+ (fboundp 'electric-pair-analyze-conversion)
+ ;; Only do this if only a single edit happened.
+ text-conversion-edits)
+ (save-excursion
+ (goto-char (nth 2 edit))
+ (electric-pair-analyze-conversion (nth 3 edit))))))))
+ ;; If all edits were ephemeral, make this an amalgamating command.
+ ;; Then, make sure that an undo boundary is placed within the next
+ ;; five seconds.
+ (unless any-nonephemeral
+ (undo-auto-amalgamate)
+ (let ((timer undo-auto-current-boundary-timer))
+ (if timer
+ ;; The timer is already running. See if it's due to expire
+ ;; within the next five seconds.
+ (let ((time (list (aref timer 1) (aref timer 2)
+ (aref timer 3))))
+ (unless (<= (time-convert (time-subtract time nil)
+ 'integer)
+ 5)
+ ;; It's not, so make it run in 5 seconds.
+ (timer-set-time undo-auto-current-boundary-timer
+ (time-add nil 5))))
+ ;; Otherwise, start it for five seconds from now.
+ (setq undo-auto-current-boundary-timer
+ (run-at-time 5 nil #'undo-auto--boundary-timer)))))))
+
(provide 'simple)
;;; simple.el ends here
diff --git a/lisp/so-long.el b/lisp/so-long.el
index 213c96b0cf0..0208f3fddef 100644
--- a/lisp/so-long.el
+++ b/lisp/so-long.el
@@ -310,7 +310,7 @@
;; possibly also `so-long-max-lines' and `so-long-skip-leading-comments' (these
;; latter two are not used by default starting from Emacs 28.1). E.g.:
;;
-;; (add-hook 'js-mode-hook 'my-js-mode-hook)
+;; (add-hook 'js-mode-hook #'my-js-mode-hook)
;;
;; (defun my-js-mode-hook ()
;; "Custom `js-mode' behaviors."
@@ -324,7 +324,7 @@
;; set `bidi-inhibit-bpa' in XML files, on the basis that XML files with long
;; lines are less likely to trigger BPA-related performance problems:
;;
-;; (add-hook 'nxml-mode-hook 'my-nxml-mode-hook)
+;; (add-hook 'nxml-mode-hook #'my-nxml-mode-hook)
;;
;; (defun my-nxml-mode-hook ()
;; "Custom `nxml-mode' behaviors."
@@ -366,7 +366,7 @@
;; variable. Refer to M-: (info "(emacs) Specifying File Variables") RET
;;
;; `so-long-minor-mode' can also be called directly if desired. e.g.:
-;; (add-hook 'FOO-mode-hook 'so-long-minor-mode)
+;; (add-hook 'FOO-mode-hook #'so-long-minor-mode)
;;
;; In Emacs 26.1 or later (see "Caveats" below) you also have the option of
;; using file-local and directory-local variables to determine how `so-long'
@@ -783,8 +783,7 @@ an example."
:package-version '(so-long . "1.0"))
(make-variable-buffer-local 'so-long-file-local-mode-function)
-;; `provided-mode-derived-p' was added in 26.1
-(unless (fboundp 'provided-mode-derived-p)
+(unless (fboundp 'provided-mode-derived-p) ;Only in Emacs≥26.1
(defun provided-mode-derived-p (mode &rest modes)
"Non-nil if MODE is derived from one of MODES.
Uses the `derived-mode-parent' property of the symbol to trace backwards.
@@ -1320,8 +1319,8 @@ This minor mode is a standard `so-long-action' option."
(so-long--ensure-enabled)
(setq so-long--active t
so-long-detected-p t
- so-long-function 'turn-on-so-long-minor-mode
- so-long-revert-function 'turn-off-so-long-minor-mode)
+ so-long-function #'turn-on-so-long-minor-mode
+ so-long-revert-function #'turn-off-so-long-minor-mode)
(so-long-remember-all :reset)
(unless (derived-mode-p 'so-long-mode)
(setq so-long-mode-line-info (so-long-mode-line-info))))
@@ -1345,7 +1344,7 @@ This minor mode is a standard `so-long-action' option."
(defvar so-long-mode-map
(let ((map (make-sparse-keymap)))
- (define-key map (kbd "C-c C-c") 'so-long-revert)
+ (define-key map (kbd "C-c C-c") #'so-long-revert)
;; Define the major mode menu. We have an awkward issue whereby
;; [menu-bar so-long] is already defined in the global map and is
;; :visible so-long-detected-p, but we also want this to be
@@ -1396,12 +1395,12 @@ configure the behavior."
(so-long--ensure-enabled)
(setq so-long--active t
so-long-detected-p t
- so-long-function 'so-long-mode
- so-long-revert-function 'so-long-mode-revert))
+ so-long-function #'so-long-mode
+ so-long-revert-function #'so-long-mode-revert))
;; Use `after-change-major-mode-hook' to disable minor modes and override
;; variables. Append, to act after any globalized modes have acted.
(add-hook 'after-change-major-mode-hook
- 'so-long-after-change-major-mode :append :local)
+ #'so-long-after-change-major-mode :append :local)
;; Override variables. This is the first of two instances where we do this
;; (the other being `so-long-after-change-major-mode'). It is desirable to
;; set variables here in order to cover cases where the setting of a variable
@@ -1591,8 +1590,8 @@ because we do not want to downgrade the major mode in that scenario."
(when (and (symbolp (so-long-function))
(provided-mode-derived-p (so-long-function) 'so-long-mode))
;; Downgrade from `so-long-mode' to the `so-long-minor-mode' behavior.
- (setq so-long-function 'turn-on-so-long-minor-mode
- so-long-revert-function 'turn-off-so-long-minor-mode))))
+ (setq so-long-function #'turn-on-so-long-minor-mode
+ so-long-revert-function #'turn-off-so-long-minor-mode))))
(defun so-long-inhibit (&optional _mode)
"Prevent `global-so-long-mode' from having any effect.
@@ -1717,7 +1716,7 @@ major mode is a member (or derivative of a member) of `so-long-target-modes'.
(not so-long--inhibited)
(not so-long--calling)
(or (eq so-long-target-modes t)
- (apply #'derived-mode-p so-long-target-modes))
+ (derived-mode-p so-long-target-modes))
(setq so-long-detected-p (funcall so-long-predicate))
;; `so-long' should be called; but only if and when the buffer is
;; displayed in a window. Long lines in invisible buffers are generally
@@ -1897,7 +1896,6 @@ Use \\[so-long-commentary] for more information.
Use \\[so-long-customize] to open the customization group `so-long' to
configure the behavior."
:global t
- :group 'so-long
(if global-so-long-mode
;; Enable
(progn
@@ -2030,7 +2028,7 @@ If it appears in `%s', you should remove it."
;; Update to version 1.0 from earlier versions:
(when (version< so-long-version "1.0")
(remove-hook 'change-major-mode-hook 'so-long-change-major-mode)
- (eval-and-compile (require 'advice)) ;; Both macros and functions.
+ (require 'advice) ;; It should already be loaded, but just in case.
(declare-function ad-find-advice "advice")
(declare-function ad-remove-advice "advice")
(declare-function ad-activate "advice")
diff --git a/lisp/sort.el b/lisp/sort.el
index 1ee91df50d7..2ee76b6e1e3 100644
--- a/lisp/sort.el
+++ b/lisp/sort.el
@@ -257,18 +257,15 @@ the sort order."
(lambda () (skip-chars-forward "\n"))
'forward-page))))
-(defvar sort-fields-syntax-table nil)
-(if sort-fields-syntax-table nil
- (let ((table (make-syntax-table))
- (i 0))
- (while (< i 256)
- (modify-syntax-entry i "w" table)
- (setq i (1+ i)))
+(defvar sort-fields-syntax-table
+ (let ((table (make-syntax-table)))
+ (dotimes (i 256)
+ (modify-syntax-entry i "w" table))
(modify-syntax-entry ?\s " " table)
(modify-syntax-entry ?\t " " table)
(modify-syntax-entry ?\n " " table)
(modify-syntax-entry ?\. "_" table) ; for floating pt. numbers. -wsr
- (setq sort-fields-syntax-table table)))
+ table))
(defcustom sort-numeric-base 10
"The default base used by `sort-numeric-fields'."
diff --git a/lisp/speedbar.el b/lisp/speedbar.el
index 99e9267be07..2ed97986fe7 100644
--- a/lisp/speedbar.el
+++ b/lisp/speedbar.el
@@ -631,7 +631,7 @@ function `speedbar-extension-list-to-regex'.")
(append '(".[ch]\\(\\+\\+\\|pp\\|c\\|h\\|xx\\)?" ".tex\\(i\\(nfo\\)?\\)?"
".el" ".emacs" ".l" ".lsp" ".p" ".java" ".js" ".f\\(90\\|77\\|or\\)?")
(if speedbar-use-imenu-flag
- '(".ad[abs]" ".p[lm]" ".tcl" ".m" ".scm" ".pm" ".py" ".g"
+ '(".ad[abs]" ".p[lm]" ".tcl" ".m" ".scm" ".pm" ".py" ".g" ".lua"
;; html is not supported by default, but an imenu tags package
;; is available. Also, html files are nice to be able to see.
".s?html"
@@ -662,7 +662,7 @@ the dot should NOT be quoted in with \\. Other regular expression
matchers are allowed however. EXTENSION may be a single string or a
list of strings."
(interactive "sExtension: ")
- (if (not (listp extension)) (setq extension (list extension)))
+ (setq extension (ensure-list extension))
(while extension
(if (member (car extension) speedbar-supported-extension-expressions)
nil
@@ -677,8 +677,7 @@ list of strings."
This function will modify `speedbar-ignored-directory-regexp' and add
DIRECTORY-EXPRESSION to `speedbar-ignored-directory-expressions'."
(interactive "sDirectory regex: ")
- (if (not (listp directory-expression))
- (setq directory-expression (list directory-expression)))
+ (setq directory-expression (ensure-list directory-expression))
(while directory-expression
(if (member (car directory-expression) speedbar-ignored-directory-expressions)
nil
@@ -2591,13 +2590,12 @@ interrupted by the user."
(if (not speedbar-stealthy-update-recurse)
(let ((l (speedbar-initial-stealthy-functions))
(speedbar-stealthy-update-recurse t))
- (unwind-protect
- (speedbar-with-writable
- (while (and l (funcall (car l)))
- ;;(sit-for 0)
- (setq l (cdr l))))
- ;;(dframe-message "Exit with %S" (car l))
- ))))
+ (speedbar-with-writable
+ (while (and l (funcall (car l)))
+ ;;(sit-for 0)
+ (setq l (cdr l))))
+ ;;(dframe-message "Exit with %S" (car l))
+ )))
(defun speedbar-reset-scanners ()
"Reset any variables used by functions in the stealthy list as state.
@@ -3490,7 +3488,7 @@ functions to do caching and flushing if appropriate."
nil
-(eval-when-compile (condition-case nil (require 'imenu) (error nil)))
+(eval-when-compile (require 'imenu))
(declare-function imenu--make-index-alist "imenu" (&optional no-error))
(defun speedbar-fetch-dynamic-imenu (file)
@@ -3532,7 +3530,7 @@ to be at the beginning of a line in the etags buffer.
This variable is ignored if `speedbar-use-imenu-flag' is non-nil.")
-(defcustom speedbar-fetch-etags-command "etags"
+(defcustom speedbar-fetch-etags-command etags-program-name
"Command used to create an etags file.
This variable is ignored if `speedbar-use-imenu-flag' is t."
:group 'speedbar
@@ -3551,9 +3549,7 @@ This variable is ignored if `speedbar-use-imenu-flag' is t."
"Toggle FLAG in `speedbar-fetch-etags-arguments'.
FLAG then becomes a member of etags command line arguments. If flag
is \"sort\", then toggle the value of `speedbar-sort-tags'. If its
-value is \"show\" then toggle the value of
-`speedbar-show-unknown-files'."
- (interactive)
+value is \"show\" then toggle the value of `speedbar-show-unknown-files'."
(cond
((equal flag "sort")
(setq speedbar-sort-tags (not speedbar-sort-tags)))
@@ -3572,38 +3568,36 @@ value is \"show\" then toggle the value of
"For FILE, run etags and create a list of symbols extracted.
Each symbol will be associated with its line position in FILE."
(let ((newlist nil))
- (unwind-protect
- (save-excursion
- (if (get-buffer "*etags tmp*")
- (kill-buffer "*etags tmp*")) ;kill to clean it up
- (if (<= 1 speedbar-verbosity-level)
- (dframe-message "Fetching etags..."))
- (set-buffer (get-buffer-create "*etags tmp*"))
- (apply 'call-process speedbar-fetch-etags-command nil
- (current-buffer) nil
- (append speedbar-fetch-etags-arguments (list file)))
- (goto-char (point-min))
- (if (<= 1 speedbar-verbosity-level)
- (dframe-message "Fetching etags..."))
- (let ((expr
- (let ((exprlst speedbar-fetch-etags-parse-list)
- (ans nil))
- (while (and (not ans) exprlst)
- (if (string-match (car (car exprlst)) file)
- (setq ans (car exprlst)))
- (setq exprlst (cdr exprlst)))
- (cdr ans))))
- (if expr
- (let (tnl)
- (set-buffer (get-buffer-create "*etags tmp*"))
- (while (not (save-excursion (end-of-line) (eobp)))
- (save-excursion
- (setq tnl (speedbar-extract-one-symbol expr)))
- (if tnl (setq newlist (cons tnl newlist)))
- (forward-line 1)))
- (dframe-message
- "Sorry, no support for a file of that extension"))))
- )
+ (save-excursion
+ (if (get-buffer "*etags tmp*")
+ (kill-buffer "*etags tmp*")) ;kill to clean it up
+ (if (<= 1 speedbar-verbosity-level)
+ (dframe-message "Fetching etags..."))
+ (set-buffer (get-buffer-create "*etags tmp*"))
+ (apply 'call-process speedbar-fetch-etags-command nil
+ (current-buffer) nil
+ (append speedbar-fetch-etags-arguments (list file)))
+ (goto-char (point-min))
+ (if (<= 1 speedbar-verbosity-level)
+ (dframe-message "Fetching etags..."))
+ (let ((expr
+ (let ((exprlst speedbar-fetch-etags-parse-list)
+ (ans nil))
+ (while (and (not ans) exprlst)
+ (if (string-match (car (car exprlst)) file)
+ (setq ans (car exprlst)))
+ (setq exprlst (cdr exprlst)))
+ (cdr ans))))
+ (if expr
+ (let (tnl)
+ (set-buffer (get-buffer-create "*etags tmp*"))
+ (while (not (save-excursion (end-of-line) (eobp)))
+ (save-excursion
+ (setq tnl (speedbar-extract-one-symbol expr)))
+ (if tnl (setq newlist (cons tnl newlist)))
+ (forward-line 1)))
+ (dframe-message
+ "Sorry, no support for a file of that extension"))))
(if speedbar-sort-tags
(sort newlist (lambda (a b) (string< (car a) (car b))))
(reverse newlist))))
diff --git a/lisp/sqlite-mode.el b/lisp/sqlite-mode.el
index 7477992e774..7b1a9ce2e88 100644
--- a/lisp/sqlite-mode.el
+++ b/lisp/sqlite-mode.el
@@ -33,6 +33,7 @@
(declare-function sqlite-finalize "sqlite.c")
(declare-function sqlite-select "sqlite.c")
(declare-function sqlite-open "sqlite.c")
+(declare-function sqlite-close "sqlite.c")
(defvar-keymap sqlite-mode-map
"g" #'sqlite-mode-list-tables
diff --git a/lisp/startup.el b/lisp/startup.el
index eb1e027d2cb..357a4154e4c 100644
--- a/lisp/startup.el
+++ b/lisp/startup.el
@@ -120,7 +120,10 @@ the remaining command-line args are in the variable `command-line-args-left'.")
"List of command-line args not yet processed.
This is a convenience alias, so that one can write (pop argv)
inside of --eval command line arguments in order to access
-following arguments."))
+following arguments.
+
+See also `server-eval-args-left' for a similar variable which
+works for invocations of \"emacsclient --eval\"."))
(internal-make-var-non-special 'argv)
(defvar command-line-args-left nil
@@ -390,7 +393,7 @@ If this is nil, Emacs uses `system-name'."
"The email address of the current user.
This defaults to either: the value of EMAIL environment variable; or
user@host, using `user-login-name' and `mail-host-address' (or `system-name')."
- :initialize 'custom-initialize-delay
+ :initialize #'custom-initialize-delay
:set-after '(mail-host-address)
:type 'string
:group 'mail)
@@ -489,7 +492,7 @@ DIRS are relative."
(setq tail (cdr tail)))
;;Splice the new section in.
(when tail
- (setcdr tail (append (mapcar 'expand-file-name dirs) (cdr tail))))))
+ (setcdr tail (append (mapcar #'expand-file-name dirs) (cdr tail))))))
;; The default location for XDG-convention Emacs init files.
(defconst startup--xdg-config-default "~/.config/emacs/")
@@ -520,27 +523,6 @@ DIRS are relative."
xdg-dir)
(t emacs-d-dir))))
-(defvar comp--compilable)
-(defvar comp--delayed-sources)
-(defun startup--require-comp-safely ()
- "Require the native compiler avoiding circular dependencies."
- (when (featurep 'native-compile)
- ;; Require comp with `comp--compilable' set to nil to break
- ;; circularity.
- (let ((comp--compilable nil))
- (require 'comp))
- (native--compile-async comp--delayed-sources nil 'late)
- (setq comp--delayed-sources nil)))
-
-(declare-function native--compile-async "comp.el"
- (files &optional recursively load selector))
-(defun startup--honor-delayed-native-compilations ()
- "Honor pending delayed deferred native compilations."
- (when (and (native-comp-available-p)
- comp--delayed-sources)
- (startup--require-comp-safely))
- (setq comp--compilable t))
-
(defvar native-comp-eln-load-path)
(defvar native-comp-jit-compilation)
(defvar native-comp-enable-subr-trampolines)
@@ -574,11 +556,35 @@ the updated value."
(setq startup--original-eln-load-path
(copy-sequence native-comp-eln-load-path))))
+(defun startup--rescale-elt-match-p (font-pattern font-object)
+ "Test whether FONT-OBJECT matches an element of `face-font-rescale-alist'.
+FONT-OBJECT is a font-object that specifies a font to test.
+FONT-PATTERN is the car of an element of `face-font-rescale-alist',
+which can be either a regexp matching a font name or a font-spec."
+ (if (stringp font-pattern)
+ ;; FONT-PATTERN is a regexp, we need the name of FONT-OBJECT to match.
+ (string-match-p font-pattern (font-xlfd-name font-object))
+ ;; FONT-PATTERN is a font-spec.
+ (font-match-p font-pattern font-object)))
+
+(defvar android-fonts-enumerated nil
+ "Whether or not fonts have been enumerated already.
+On Android, Emacs uses this variable internally at startup.")
+
(defun normal-top-level ()
"Emacs calls this function when it first starts up.
It sets `command-line-processed', processes the command-line,
reads the initialization files, etc.
It is the default value of the variable `top-level'."
+ ;; Initialize the Android font driver late.
+ ;; This is done here because it needs the `mac-roman' coding system
+ ;; to be loaded.
+ (when (and (featurep 'android)
+ (fboundp 'android-enumerate-fonts)
+ (not android-fonts-enumerated))
+ (funcall 'android-enumerate-fonts)
+ (setq android-fonts-enumerated t))
+
(if command-line-processed
(message internal--top-level-message)
(setq command-line-processed t)
@@ -646,7 +652,24 @@ It is the default value of the variable `top-level'."
(setq eol-mnemonic-dos "(DOS)"
eol-mnemonic-mac "(Mac)")))
- (set-locale-environment nil)
+ (if (and (featurep 'android)
+ (eq system-type 'android)
+ (fboundp 'android-locale-for-system-language)
+ initial-window-system)
+ ;; If Android windowing is enabled, derive a proper locale
+ ;; from the system's language preferences. On Android, LANG
+ ;; and LC_* must be set to one of the two locales the C
+ ;; library supports, but, by contrast with other systems, the
+ ;; C library locale does not reflect the configured system
+ ;; language.
+ ;;
+ ;; For this reason, the locale from which Emacs derives a
+ ;; default language environment is computed from such
+ ;; preferences, rather than environment variables that the C
+ ;; library refers to.
+ (set-locale-environment
+ (funcall 'android-locale-for-system-language))
+ (set-locale-environment nil))
;; Decode all default-directory's (probably, only *scratch* exists
;; at this point). default-directory of *scratch* is the basis
;; for many other file-name variables and directory lists, so it
@@ -804,8 +827,9 @@ It is the default value of the variable `top-level'."
(when (and (display-multi-font-p)
(not (eq face-font-rescale-alist
old-face-font-rescale-alist))
- (assoc (font-xlfd-name (face-attribute 'default :font))
- face-font-rescale-alist #'string-match-p))
+ (assoc (face-attribute 'default :font)
+ face-font-rescale-alist
+ #'startup--rescale-elt-match-p))
(set-face-attribute 'default nil :font (font-spec)))
;; Modify the initial frame based on what .emacs puts into
@@ -837,13 +861,16 @@ It is the default value of the variable `top-level'."
(let ((display (frame-parameter nil 'display)))
;; Be careful which DISPLAY to remove from process-environment: follow
;; the logic of `callproc.c'.
- (if (stringp display) (setq display (concat "DISPLAY=" display))
- (dolist (varval initial-environment)
- (if (string-match "\\`DISPLAY=" varval)
- (setq display varval))))
+ (if (stringp display)
+ (setq display (concat "DISPLAY=" display))
+ (let ((env initial-environment))
+ (while (and env (or (not (string-match "\\`DISPLAY=" (car env)))
+ (progn
+ (setq display (car env))
+ nil)))
+ (setq env (cdr env)))))
(when display
- (delete display process-environment))))
- (startup--honor-delayed-native-compilations))
+ (setq process-environment (delete display process-environment))))))
;; Precompute the keyboard equivalents in the menu bar items.
;; Command-line options supported by tty's:
@@ -1004,6 +1031,9 @@ If STYLE is nil, display appropriately for the terminal."
(when standard-display-table
(aset standard-display-table char nil)))))))
+(defun startup--debug (err)
+ (funcall debugger 'error err :backtrace-base #'startup--debug))
+
(defun startup--load-user-init-file
(filename-function &optional alternate-filename-function load-defaults)
"Load a user init-file.
@@ -1017,79 +1047,79 @@ is non-nil.
This function sets `user-init-file' to the name of the loaded
init-file, or to a default value if loading is not possible."
- (let ((debug-on-error-from-init-file nil)
- (debug-on-error-should-be-set nil)
- (debug-on-error-initial
- (if (eq init-file-debug t)
- 'startup
- 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))
+ ;; The init file might contain byte-code with embedded NULs,
+ ;; which can cause problems when read back, so disable nul
+ ;; byte detection. (Bug#52554)
+ (let ((inhibit-null-byte-detection t)
+ (body
+ (lambda ()
+ (when init-file-user
+ (let ((init-file-name (funcall filename-function)))
+
+ ;; If `user-init-file' is t, then `load' will store
+ ;; the name of the file that it loads into
+ ;; `user-init-file'.
+ (setq user-init-file t)
+ (when init-file-name
+ (load (if (equal (file-name-extension init-file-name)
+ "el")
+ (file-name-sans-extension init-file-name)
+ init-file-name)
+ 'noerror 'nomessage))
+
+ (when (and (eq user-init-file t) alternate-filename-function)
+ (let ((alt-file (funcall alternate-filename-function)))
+ (unless init-file-name
+ (setq init-file-name alt-file))
+ (and (equal (file-name-extension alt-file) "el")
+ (setq alt-file (file-name-sans-extension alt-file)))
+ (load alt-file 'noerror 'nomessage)))
+
+ ;; If we did not find the user's init file, set
+ ;; user-init-file conclusively. Don't let it be
+ ;; set from default.el.
+ (when (eq user-init-file t)
+ (setq user-init-file init-file-name)))
+
+ ;; If we loaded a compiled file, set `user-init-file' to
+ ;; the source version if that exists.
+ (if (equal (file-name-extension user-init-file) "elc")
+ (let* ((source (file-name-sans-extension user-init-file))
+ (alt (concat source ".el")))
+ (setq source (cond ((file-exists-p alt) alt)
+ ((file-exists-p source) source)
+ (t nil)))
+ (when source
+ (when (file-newer-than-file-p source user-init-file)
+ (message "Warning: %s is newer than %s"
+ source user-init-file)
+ (sit-for 1))
+ (setq user-init-file source)))
+ ;; Else, perhaps the user init file was compiled
+ (when (and (equal (file-name-extension user-init-file) "eln")
+ ;; The next test is for builds without native
+ ;; compilation support or builds with unexec.
+ (boundp 'comp-eln-to-el-h))
+ (if-let (source (gethash (file-name-nondirectory
+ user-init-file)
+ comp-eln-to-el-h))
+ ;; source exists or the .eln file would not load
+ (setq user-init-file source)
+ (message "Warning: unknown source file for init file %S"
+ user-init-file)
+ (sit-for 1))))
+
+ (when (and load-defaults
+ (not inhibit-default-init))
+ ;; Prevent default.el from changing the value of
+ ;; `inhibit-startup-screen'.
+ (let ((inhibit-startup-screen nil))
+ (load "default" 'noerror 'nomessage)))))))
+ (if (eq init-file-debug t)
+ (handler-bind ((error #'startup--debug))
+ (funcall body))
(condition-case-unless-debug error
- (when init-file-user
- (let ((init-file-name (funcall filename-function)))
-
- ;; If `user-init-file' is t, then `load' will store
- ;; the name of the file that it loads into
- ;; `user-init-file'.
- (setq user-init-file t)
- (when init-file-name
- (load (if (equal (file-name-extension init-file-name)
- "el")
- (file-name-sans-extension init-file-name)
- init-file-name)
- 'noerror 'nomessage))
-
- (when (and (eq user-init-file t) alternate-filename-function)
- (let ((alt-file (funcall alternate-filename-function)))
- (unless init-file-name
- (setq init-file-name alt-file))
- (and (equal (file-name-extension alt-file) "el")
- (setq alt-file (file-name-sans-extension alt-file)))
- (load alt-file 'noerror 'nomessage)))
-
- ;; If we did not find the user's init file, set
- ;; user-init-file conclusively. Don't let it be
- ;; set from default.el.
- (when (eq user-init-file t)
- (setq user-init-file init-file-name)))
-
- ;; If we loaded a compiled file, set `user-init-file' to
- ;; the source version if that exists.
- (if (equal (file-name-extension user-init-file) "elc")
- (let* ((source (file-name-sans-extension user-init-file))
- (alt (concat source ".el")))
- (setq source (cond ((file-exists-p alt) alt)
- ((file-exists-p source) source)
- (t nil)))
- (when source
- (when (file-newer-than-file-p source user-init-file)
- (message "Warning: %s is newer than %s"
- source user-init-file)
- (sit-for 1))
- (setq user-init-file source)))
- ;; Else, perhaps the user init file was compiled
- (when (and (equal (file-name-extension user-init-file) "eln")
- ;; The next test is for builds without native
- ;; compilation support or builds with unexec.
- (boundp 'comp-eln-to-el-h))
- (if-let (source (gethash (file-name-nondirectory user-init-file)
- comp-eln-to-el-h))
- ;; source exists or the .eln file would not load
- (setq user-init-file source)
- (message "Warning: unknown source file for init file %S"
- user-init-file)
- (sit-for 1))))
-
- (when (and load-defaults
- (not inhibit-default-init))
- ;; Prevent default.el from changing the value of
- ;; `inhibit-startup-screen'.
- (let ((inhibit-startup-screen nil))
- (load "default" 'noerror 'nomessage))))
+ (funcall body)
(error
(display-warning
'initialization
@@ -1104,16 +1134,7 @@ the `--debug-init' option to view a complete error backtrace."
(mapconcat (lambda (s) (prin1-to-string s t))
(cdr error) ", "))
:warning)
- (setq init-file-had-error t)))
-
- ;; If we can tell that the init file altered debug-on-error,
- ;; arrange to preserve the value that it set up.
- (or (eq debug-on-error debug-on-error-initial)
- (setq debug-on-error-should-be-set t
- debug-on-error-from-init-file debug-on-error)))
-
- (when debug-on-error-should-be-set
- (setq debug-on-error debug-on-error-from-init-file))))
+ (setq init-file-had-error t))))))
(defvar lisp-directory nil
"Directory where Emacs's own *.el and *.elc Lisp files are installed.")
@@ -1409,7 +1430,7 @@ please check its value")
(error
(princ
(if (eq (car error) 'error)
- (apply 'concat (cdr error))
+ (apply #'concat (cdr error))
(if (memq 'file-error (get (car error) 'error-conditions))
(format "%s: %s"
(nth 1 error)
@@ -1618,7 +1639,9 @@ Consider using a subdirectory instead, e.g.: %s"
(let ((dn (daemonp)))
(when dn
(when (stringp dn) (setq server-name dn))
- (server-start)
+ (condition-case err
+ (server-start)
+ (error (error "Unable to start daemon: %s; exiting" (error-message-string err))))
(if server-process
(daemon-initialized)
(if (stringp dn)
@@ -1666,7 +1689,7 @@ Changed settings will be marked as \"CHANGED outside of Customize\"."
(defcustom initial-scratch-message (purecopy "\
;; This buffer is for text that is not saved, and for Lisp evaluation.
-;; To create a file, visit it with \\[find-file] and enter text in its buffer.
+;; To create a file, visit it with `\\[find-file]' and enter text in its buffer.
")
"Initial documentation displayed in *scratch* buffer at startup.
@@ -1861,10 +1884,10 @@ Each element in the list should be a list of strings or pairs
(let ((map (make-sparse-keymap)))
(suppress-keymap map)
(set-keymap-parent map button-buffer-map)
- (define-key map "\C-?" 'scroll-down-command)
- (define-key map [?\S-\ ] 'scroll-down-command)
- (define-key map " " 'scroll-up-command)
- (define-key map "q" 'exit-splash-screen)
+ (define-key map "\C-?" #'scroll-down-command)
+ (define-key map [?\S-\ ] #'scroll-down-command)
+ (define-key map " " #'scroll-up-command)
+ (define-key map "q" #'exit-splash-screen)
map)
"Keymap for splash screen buffer.")
@@ -2017,7 +2040,6 @@ a face or button specification."
(call-interactively
'recover-session)))
" to recover the files you were editing."))))
-
(when concise
(fancy-splash-insert
:face 'variable-pitch "\n"
@@ -2070,6 +2092,10 @@ splash screen in another window."
(make-local-variable 'startup-screen-inhibit-startup-screen)
(if pure-space-overflow
(insert pure-space-overflow-message))
+ ;; Insert the permissions notice if the user has yet to grant Emacs
+ ;; storage permissions.
+ (when (fboundp 'android-before-splash-screen)
+ (funcall 'android-before-splash-screen t))
(unless concise
(fancy-splash-head))
(dolist (text fancy-startup-text)
@@ -2176,7 +2202,10 @@ splash screen in another window."
(if pure-space-overflow
(insert pure-space-overflow-message))
-
+ ;; Insert the permissions notice if the user has yet to grant
+ ;; Emacs storage permissions.
+ (when (fboundp 'android-before-splash-screen)
+ (funcall 'android-before-splash-screen nil))
;; The convention for this piece of code is that
;; each piece of output starts with one or two newlines
;; and does not end with any newlines.
@@ -2218,7 +2247,6 @@ splash screen in another window."
(insert "\n\nIf an Emacs session crashed recently, "
"type M-x recover-session RET\nto recover"
" the files you were editing.\n"))
-
(use-local-map splash-screen-keymap)
;; Display the input that we set up in the buffer.
@@ -2294,7 +2322,7 @@ To quit a partially entered command, type Control-g.\n")
;; If C-h can't be invoked, temporarily disable its
;; binding, so where-is uses alternative bindings.
(let ((map (make-sparse-keymap)))
- (define-key map [?\C-h] 'undefined)
+ (define-key map [?\C-h] #'undefined)
map))
minor-mode-overriding-map-alist)))
@@ -2486,8 +2514,8 @@ A fancy display is used on graphic displays, normal otherwise."
(fancy-about-screen)
(normal-splash-screen nil)))
-(defalias 'about-emacs 'display-about-screen)
-(defalias 'display-splash-screen 'display-startup-screen)
+(defalias 'about-emacs #'display-about-screen)
+(defalias 'display-splash-screen #'display-startup-screen)
;; This avoids byte-compiler warning in the unexec build.
(declare-function pdumper-stats "pdumper.c" ())
@@ -2918,7 +2946,7 @@ nil default-directory" name)
(when (looking-at "#!")
(forward-line))
(let (value form)
- (while (ignore-error 'end-of-file
+ (while (ignore-error end-of-file
(setq form (read (current-buffer))))
(setq value (eval form t)))
(kill-emacs (if (numberp value)
diff --git a/lisp/strokes.el b/lisp/strokes.el
index a935af85e38..50920229d9d 100644
--- a/lisp/strokes.el
+++ b/lisp/strokes.el
@@ -266,6 +266,14 @@ able to see the strokes. This be helpful for people who don't like
the delay in switching to the strokes buffer."
:type 'boolean)
+(defvar strokes-no-match-function 'strokes-no-match-default
+ "Function run by `strokes-execute-stroke' when no stroke matches.
+The function is called with two arguments, the stroke and the
+closest match returned by `strokes-match-stroke'. It can be used
+to show detailed information about the unmatched stroke or
+perform some fallback action. The default function
+`strokes-no-match-default' simply signals an error.")
+
;;; internal variables...
(defvar strokes-window-configuration nil
@@ -760,27 +768,27 @@ Optional EVENT is acceptable as the starting event of the stroke."
(setq safe-to-draw-p t))
(push (cdr (mouse-pixel-position))
pix-locs)))
- (setq event (read--potential-mouse-event)))))
- ;; protected
- ;; clean up strokes buffer and then bury it.
- (when (equal (buffer-name) strokes-buffer-name)
- (subst-char-in-region (point-min) (point-max)
- strokes-character ?\s)
- (goto-char (point-min))
- (bury-buffer))))
- ;; Otherwise, don't use strokes buffer and read stroke silently
- (when prompt
- (message "%s" prompt)
- (setq event (read--potential-mouse-event))
- (or (strokes-button-press-event-p event)
- (error "You must draw with the mouse")))
- (track-mouse
- (or event (setq event (read--potential-mouse-event)))
- (while (not (strokes-button-release-event-p event))
- (if (strokes-mouse-event-p event)
- (push (cdr (mouse-pixel-position))
- pix-locs))
- (setq event (read--potential-mouse-event))))
+ (setq event (read--potential-mouse-event))))
+ ;; protected
+ ;; clean up strokes buffer and then bury it.
+ (when (equal (buffer-name) strokes-buffer-name)
+ (subst-char-in-region (point-min) (point-max)
+ strokes-character ?\s)
+ (goto-char (point-min))
+ (bury-buffer))))
+ ;; Otherwise, don't use strokes buffer and read stroke silently
+ (when prompt
+ (message "%s" prompt)
+ (setq event (read--potential-mouse-event))
+ (or (strokes-button-press-event-p event)
+ (error "You must draw with the mouse")))
+ (track-mouse
+ (or event (setq event (read--potential-mouse-event)))
+ (while (not (strokes-button-release-event-p event))
+ (if (strokes-mouse-event-p event)
+ (push (cdr (mouse-pixel-position))
+ pix-locs))
+ (setq event (read--potential-mouse-event)))))
(setq grid-locs (strokes-renormalize-to-grid (nreverse pix-locs)))
(strokes-fill-stroke
(strokes-eliminate-consecutive-redundancies grid-locs)))))
@@ -838,14 +846,16 @@ Optional EVENT is acceptable as the starting event of the stroke."
(goto-char (point-min))
(bury-buffer)))))))
+(defun strokes-no-match-default (&rest _)
+ "Signal an error when no stroke matches."
+ (error
+ "No stroke matches; see variable `strokes-minimum-match-score'"))
+
(defun strokes-execute-stroke (stroke)
"Given STROKE, execute the command which corresponds to it.
The command will be executed provided one exists for that stroke,
-based on the variable `strokes-minimum-match-score'.
-If no stroke matches, nothing is done and return value is nil."
- ;; FIXME: Undocument return value. It is not documented for all cases,
- ;; and doesn't allow differentiating between no stroke matches and
- ;; command-execute returning nil, anyway.
+based on the variable `strokes-minimum-match-score'. If no
+stroke matches, `strokes-no-match-function' is called."
(let* ((match (strokes-match-stroke stroke strokes-global-map))
(command (car match))
(score (cdr match)))
@@ -859,10 +869,7 @@ If no stroke matches, nothing is done and return value is nil."
strokes-file))
(strokes-load-user-strokes))
(error "No strokes defined; use `strokes-global-set-stroke'")))
- (t
- (error
- "No stroke matches; see variable `strokes-minimum-match-score'")
- nil))))
+ (t (funcall strokes-no-match-function stroke match)))))
;;;###autoload
(defun strokes-do-stroke (event)
@@ -1211,12 +1218,7 @@ the stroke as a character in some language."
;;\\{edit-strokes-mode-map}"
;; (setq truncate-lines nil
;; auto-show-mode nil ; don't want problems here either
-;; mode-popup-menu edit-strokes-menu) ; what about extent-specific stuff?
-;; (and (featurep 'menubar)
-;; current-menubar
-;; (setq-local current-menubar
-;; (copy-sequence current-menubar))
-;; (add-submenu nil edit-strokes-menu)))
+;; mode-popup-menu edit-strokes-menu)) ; what about extent-specific stuff?
;;(let ((map edit-strokes-mode-map))
;; (define-key map "<" 'beginning-of-buffer)
diff --git a/lisp/subr.el b/lisp/subr.el
index d9df8d1a458..90dbfc75d52 100644
--- a/lisp/subr.el
+++ b/lisp/subr.el
@@ -1,7 +1,6 @@
;;; subr.el --- basic lisp subroutines for Emacs -*- lexical-binding:t -*-
-;; Copyright (C) 1985-1986, 1992, 1994-1995, 1999-2024 Free Software
-;; Foundation, Inc.
+;; Copyright (C) 1985-2024 Free Software Foundation, Inc.
;; Maintainer: emacs-devel@gnu.org
;; Keywords: internal
@@ -205,6 +204,7 @@ buffer-local wherever it is set."
(defun buffer-local-boundp (symbol buffer)
"Return non-nil if SYMBOL is bound in BUFFER.
Also see `local-variable-p'."
+ (declare (side-effect-free t))
(condition-case nil
(buffer-local-value symbol buffer)
(:success t)
@@ -276,25 +276,56 @@ change the list."
(macroexp-let2 macroexp-copyable-p x getter
`(prog1 ,x ,(funcall setter `(cdr ,x))))))))
+;; Note: `static-if' can be copied into a package to enable it to be
+;; used in Emacsen older than Emacs 30.1. If the package is used in
+;; very old Emacsen or XEmacs (in which `eval' takes exactly one
+;; argument) the copy will need amending.
+(defmacro static-if (condition then-form &rest else-forms)
+ "A conditional compilation macro.
+Evaluate CONDITION at macro-expansion time. If it is non-nil,
+expand the macro to THEN-FORM. Otherwise expand it to ELSE-FORMS
+enclosed in a `progn' form. ELSE-FORMS may be empty."
+ (declare (indent 2)
+ (debug (sexp sexp &rest sexp)))
+ (if (eval condition lexical-binding)
+ then-form
+ (cons 'progn else-forms)))
+
(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."
(declare (indent 1) (debug t))
- (list 'if cond (cons 'progn body)))
+ (if body
+ (list 'if cond (cons 'progn body))
+ (macroexp-warn-and-return (format-message "`when' with empty body")
+ cond '(empty-body when) t)))
(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."
(declare (indent 1) (debug t))
- (cons 'if (cons cond (cons nil body))))
+ (if body
+ (cons 'if (cons cond (cons nil body)))
+ (macroexp-warn-and-return (format-message "`unless' with empty body")
+ cond '(empty-body unless) t)))
(defsubst subr-primitive-p (object)
- "Return t if OBJECT is a built-in primitive function."
+ "Return t if OBJECT is a built-in primitive written in C.
+Such objects can be functions or special forms."
+ (declare (side-effect-free error-free))
(and (subrp object)
(not (subr-native-elisp-p object))))
+(defsubst primitive-function-p (object)
+ "Return t if OBJECT is a built-in primitive function.
+This excludes special forms, since they are not functions."
+ (declare (side-effect-free error-free))
+ (and (subrp object)
+ (not (or (subr-native-elisp-p object)
+ (eq (cdr (subr-arity object)) 'unevalled)))))
+
(defsubst xor (cond1 cond2)
"Return the boolean exclusive-or of COND1 and COND2.
If only one of the arguments is non-nil, return it; otherwise
@@ -381,9 +412,24 @@ without silencing all errors."
"Execute BODY; if the error CONDITION occurs, return nil.
Otherwise, return result of last form in BODY.
-CONDITION can also be a list of error conditions."
+CONDITION can also be a list of error conditions.
+The CONDITION argument is not evaluated. Do not quote it."
(declare (debug t) (indent 1))
- `(condition-case nil (progn ,@body) (,condition nil)))
+ (cond
+ ((and (eq (car-safe condition) 'quote)
+ (cdr condition) (null (cddr condition)))
+ (macroexp-warn-and-return
+ (format-message
+ "`ignore-error' condition argument should not be quoted: %S"
+ condition)
+ `(condition-case nil (progn ,@body) (,(cadr condition) nil))
+ nil t condition))
+ (body
+ `(condition-case nil (progn ,@body) (,condition nil)))
+ (t
+ (macroexp-warn-and-return (format-message "`ignore-error' with empty body")
+ nil '(empty-body ignore-error) t condition))))
+
;;;; Basic Lisp functions.
@@ -394,6 +440,7 @@ CONDITION can also be a list of error conditions."
"Return a new uninterned symbol.
The name is made by appending `gensym-counter' to PREFIX.
PREFIX is a string, and defaults to \"g\"."
+ (declare (important-return-value t))
(let ((num (prog1 gensym-counter
(setq gensym-counter (1+ gensym-counter)))))
(make-symbol (format "%s%d" (or prefix "g") num))))
@@ -402,7 +449,9 @@ PREFIX is a string, and defaults to \"g\"."
"Ignore ARGUMENTS, do nothing, and return nil.
This function accepts any number of arguments in ARGUMENTS.
Also see `always'."
- (declare (completion ignore))
+ ;; Not declared `side-effect-free' because we don't want calls to it
+ ;; elided; see `byte-compile-ignore'.
+ (declare (pure t) (completion ignore))
(interactive)
nil)
@@ -410,6 +459,7 @@ Also see `always'."
"Ignore ARGUMENTS, do nothing, and return t.
This function accepts any number of arguments in ARGUMENTS.
Also see `ignore'."
+ (declare (pure t) (side-effect-free error-free))
t)
;; Signal a compile-error if the first arg is missing.
@@ -477,6 +527,7 @@ Defaults to `error'."
"Return non-nil if OBJECT seems to be a frame configuration.
Any list whose car is `frame-configuration' is assumed to be a frame
configuration."
+ (declare (pure t) (side-effect-free error-free))
(and (consp object)
(eq (car object) 'frame-configuration)))
@@ -486,6 +537,7 @@ ARGS is a list of the first N arguments to pass to FUN.
The result is a new function which does the same as FUN, except that
the first N arguments are fixed at the values with which this function
was called."
+ (declare (side-effect-free error-free))
(lambda (&rest args2)
(apply fun (append args args2))))
@@ -493,16 +545,19 @@ was called."
"Return t if NUMBER is zero."
;; Used to be in C, but it's pointless since (= 0 n) is faster anyway because
;; = has a byte-code.
- (declare (compiler-macro (lambda (_) `(= 0 ,number))))
+ (declare (pure t) (side-effect-free t)
+ (compiler-macro (lambda (_) `(= 0 ,number))))
(= 0 number))
(defun fixnump (object)
"Return t if OBJECT is a fixnum."
+ (declare (side-effect-free error-free))
(and (integerp object)
(<= most-negative-fixnum object most-positive-fixnum)))
(defun bignump (object)
"Return t if OBJECT is a bignum."
+ (declare (side-effect-free error-free))
(and (integerp object) (not (fixnump object))))
(defun lsh (value count)
@@ -517,8 +572,10 @@ if, when COUNT is negative, your program really needs the special
treatment of negative COUNT provided by this function."
(declare (compiler-macro
(lambda (form)
- (macroexp-warn-and-return "avoid `lsh'; use `ash' instead"
- form '(suspicious lsh) t form))))
+ (macroexp-warn-and-return
+ (format-message "avoid `lsh'; use `ash' instead")
+ form '(suspicious lsh) t form)))
+ (side-effect-free t))
(when (and (< value 0) (< count 0))
(when (< value most-negative-fixnum)
(signal 'args-out-of-range (list value count)))
@@ -691,7 +748,7 @@ treatment of negative COUNT provided by this function."
If LIST is nil, return nil.
If N is non-nil, return the Nth-to-last link of LIST.
If N is bigger than the length of LIST, return LIST."
- (declare (side-effect-free t))
+ (declare (pure t) (side-effect-free t)) ; pure up to mutation
(if n
(and (>= n 0)
(let ((m (safe-length list)))
@@ -746,7 +803,9 @@ one is kept. See `seq-uniq' for non-destructive operation."
(defun delete-consecutive-dups (list &optional circular)
"Destructively remove `equal' consecutive duplicates from LIST.
First and last elements are considered consecutive if CIRCULAR is
-non-nil."
+non-nil.
+Of several consecutive `equal' occurrences, the one earliest in
+the list is kept."
(let ((tail list) last)
(while (cdr tail)
(if (equal (car tail) (cadr tail))
@@ -782,6 +841,7 @@ TO as (+ FROM (* N INC)) or use a variable whose value was
computed with this exact expression. Alternatively, you can,
of course, also replace TO with a slightly larger value
\(or a slightly more negative value if INC is negative)."
+ (declare (side-effect-free t))
(if (or (not to) (= from to))
(list from)
(or inc (setq inc 1))
@@ -798,27 +858,34 @@ of course, also replace TO with a slightly larger value
next (+ from (* n inc)))))
(nreverse seq))))
-(defun copy-tree (tree &optional vecp)
+(defun copy-tree (tree &optional vectors-and-records)
"Make a copy of TREE.
If TREE is a cons cell, this recursively copies both its car and its cdr.
-Contrast to `copy-sequence', which copies only along the cdrs. With second
-argument VECP, this copies vectors as well as conses."
+Contrast to `copy-sequence', which copies only along the cdrs.
+With the second argument VECTORS-AND-RECORDS non-nil, this
+traverses and copies vectors and records as well as conses."
+ (declare (side-effect-free error-free))
(if (consp tree)
(let (result)
(while (consp tree)
(let ((newcar (car tree)))
- (if (or (consp (car tree)) (and vecp (vectorp (car tree))))
- (setq newcar (copy-tree (car tree) vecp)))
+ (if (or (consp (car tree))
+ (and vectors-and-records
+ (or (vectorp (car tree)) (recordp (car tree)))))
+ (setq newcar (copy-tree (car tree) vectors-and-records)))
(push newcar result))
(setq tree (cdr tree)))
(nconc (nreverse result)
- (if (and vecp (vectorp tree)) (copy-tree tree vecp) tree)))
- (if (and vecp (vectorp tree))
+ (if (and vectors-and-records (or (vectorp tree) (recordp tree)))
+ (copy-tree tree vectors-and-records)
+ tree)))
+ (if (and vectors-and-records (or (vectorp tree) (recordp tree)))
(let ((i (length (setq tree (copy-sequence tree)))))
(while (>= (setq i (1- i)) 0)
- (aset tree i (copy-tree (aref tree i) vecp)))
+ (aset tree i (copy-tree (aref tree i) vectors-and-records)))
tree)
tree)))
+
;;;; Various list-search functions.
@@ -834,6 +901,7 @@ If that is non-nil, the element matches; then `assoc-default'
If no element matches, the value is nil.
If TEST is omitted or nil, `equal' is used."
+ (declare (important-return-value t))
(let (found (tail alist) value)
(while (and tail (not found))
(let ((elt (car tail)))
@@ -859,6 +927,7 @@ Non-strings in LIST are ignored."
Compare keys with TEST. Defaults to `equal'.
Return the modified alist.
Elements of ALIST that are not conses are ignored."
+ (declare (important-return-value t))
(unless test (setq test #'equal))
(while (and (consp (car alist))
(funcall test (caar alist) key))
@@ -875,12 +944,14 @@ Elements of ALIST that are not conses are ignored."
"Delete from ALIST all elements whose car is `eq' to KEY.
Return the modified alist.
Elements of ALIST that are not conses are ignored."
+ (declare (important-return-value t))
(assoc-delete-all key alist #'eq))
(defun rassq-delete-all (value alist)
"Delete from ALIST all elements whose cdr is `eq' to VALUE.
Return the modified alist.
Elements of ALIST that are not conses are ignored."
+ (declare (important-return-value t))
(while (and (consp (car alist))
(eq (cdr (car alist)) value))
(setq alist (cdr alist)))
@@ -923,6 +994,7 @@ Example:
(setf (alist-get \\='b foo nil \\='remove) nil)
foo => ((a . 1))"
+ (declare (important-return-value t))
(ignore remove) ;;Silence byte-compiler.
(let ((x (if (not testfn)
(assq key alist)
@@ -935,11 +1007,11 @@ SEQ must be a list, vector, or string. The comparison is done with `equal'.
Contrary to `delete', this does not use side-effects, and the argument
SEQ is not modified."
(declare (side-effect-free t))
- (if (nlistp seq)
- ;; If SEQ isn't a list, there's no need to copy SEQ because
- ;; `delete' will return a new object.
- (delete elt seq)
- (delete elt (copy-sequence seq))))
+ (delete elt (if (nlistp seq)
+ ;; If SEQ isn't a list, there's no need to copy SEQ because
+ ;; `delete' will return a new object.
+ seq
+ (copy-sequence seq))))
(defun remq (elt list)
"Return LIST with all occurrences of ELT removed.
@@ -1038,6 +1110,7 @@ any corresponding binding in PARENT, but it does not override corresponding
bindings in other keymaps of MAPS.
MAPS can be a list of keymaps or a single keymap.
PARENT if non-nil should be a keymap."
+ (declare (side-effect-free t))
`(keymap
,@(if (keymapp maps) (list maps) maps)
,@parent))
@@ -1178,6 +1251,7 @@ This resolves inheritance and redefinitions. The returned keymap
should behave identically to a copy of KEYMAP w.r.t `lookup-key'
and use in active keymaps and menus.
Subkeymaps may be modified but are not canonicalized."
+ (declare (important-return-value t))
;; FIXME: Problem with the difference between a nil binding
;; that hides a binding in an inherited map and a nil binding that's ignored
;; to let some further binding visible. Currently a nil binding hides all.
@@ -1500,6 +1574,7 @@ See also `current-global-map'.")
(defun listify-key-sequence (key)
"Convert a key sequence to a list of events."
+ (declare (side-effect-free t))
(if (vectorp key)
(append key nil)
(mapcar (lambda (c)
@@ -1510,6 +1585,7 @@ See also `current-global-map'.")
(defun eventp (object)
"Return non-nil if OBJECT is an input event or event object."
+ (declare (pure t) (side-effect-free error-free))
(or (integerp object)
(and (if (consp object)
(setq object (car object))
@@ -1526,6 +1602,7 @@ EVENT may be an event or an event type. If EVENT is a symbol
that has never been used in an event that has been read as input
in the current Emacs session, then this function may fail to include
the `click' modifier."
+ (declare (side-effect-free t))
(unless (stringp event)
(let ((type event))
(if (listp type)
@@ -1559,6 +1636,7 @@ The value is a printing character (not upper case) or a symbol.
EVENT may be an event or an event type. If EVENT is a symbol
that has never been used in an event that has been read as input
in the current Emacs session, then this function may return nil."
+ (declare (side-effect-free t))
(unless (stringp event)
(if (consp event)
(setq event (car event)))
@@ -1574,10 +1652,12 @@ in the current Emacs session, then this function may return nil."
(defsubst mouse-movement-p (object)
"Return non-nil if OBJECT is a mouse movement event."
+ (declare (side-effect-free error-free))
(eq (car-safe object) 'mouse-movement))
(defun mouse-event-p (object)
"Return non-nil if OBJECT is a mouse click event."
+ (declare (side-effect-free t))
;; is this really correct? maybe remove mouse-movement?
(memq (event-basic-type object) '(mouse-1 mouse-2 mouse-3 mouse-movement)))
@@ -1600,8 +1680,9 @@ in the current Emacs session, then this function may return nil."
(defun event-start (event)
"Return the starting position of EVENT.
-EVENT should be a mouse click, drag, or key press event. If
-EVENT is nil, the value of `posn-at-point' is used instead.
+EVENT should be a mouse click, drag, touch screen, or key press
+event. If EVENT is nil, the value of `posn-at-point' is used
+instead.
The following accessor functions are used to access the elements
of the position:
@@ -1623,25 +1704,46 @@ nil or (STRING . POSITION)'.
`posn-timestamp': The time the event occurred, in milliseconds.
For more information, see Info node `(elisp)Click Events'."
- (or (and (consp event) (nth 1 event))
- (event--posn-at-point)))
+ (declare (side-effect-free t))
+ (if (and (consp event)
+ (or (eq (car event) 'touchscreen-begin)
+ (eq (car event) 'touchscreen-end)))
+ ;; Touch screen begin and end events save their information in a
+ ;; different format, where the mouse position list is the cdr of
+ ;; (nth 1 event).
+ (cdadr event)
+ (or (and (consp event)
+ ;; Ignore touchscreen update events. They store the posn
+ ;; in a different format, and can have multiple posns.
+ (not (eq (car event) 'touchscreen-update))
+ (nth 1 event))
+ (event--posn-at-point))))
(defun event-end (event)
"Return the ending position of EVENT.
-EVENT should be a click, drag, or key press event.
+EVENT should be a click, drag, touch screen, or key press event.
See `event-start' for a description of the value returned."
- (or (and (consp event) (nth (if (consp (nth 2 event)) 2 1) event))
- (event--posn-at-point)))
+ (declare (side-effect-free t))
+ (if (and (consp event)
+ (or (eq (car event) 'touchscreen-begin)
+ (eq (car event) 'touchscreen-end)))
+ (cdadr event)
+ (or (and (consp event)
+ (not (eq (car event) 'touchscreen-update))
+ (nth (if (consp (nth 2 event)) 2 1) event))
+ (event--posn-at-point))))
(defsubst event-click-count (event)
"Return the multi-click count of EVENT, a click or drag event.
The return value is a positive integer."
+ (declare (side-effect-free t))
(if (and (consp event) (integerp (nth 2 event))) (nth 2 event) 1))
(defsubst event-line-count (event)
"Return the line count of EVENT, a mousewheel event.
The return value is a positive integer."
+ (declare (side-effect-free t))
(if (and (consp event) (integerp (nth 3 event))) (nth 3 event) 1))
;;;; Extracting fields of the positions in an event.
@@ -1651,6 +1753,7 @@ The return value is a positive integer."
A `posn' object is returned from functions such as `event-start'.
If OBJ is a valid `posn' object, but specifies a frame rather
than a window, return nil."
+ (declare (side-effect-free error-free))
;; FIXME: Correct the behavior of this function so that all valid
;; `posn' objects are recognized, after updating other code that
;; depends on its present behavior.
@@ -1664,12 +1767,14 @@ than a window, return nil."
If POSITION is outside the frame where the event was initiated,
return that frame instead. POSITION should be a list of the form
returned by the `event-start' and `event-end' functions."
+ (declare (side-effect-free t))
(nth 0 position))
(defsubst posn-area (position)
"Return the window area recorded in POSITION, or nil for the text area.
POSITION should be a list of the form returned by the `event-start'
and `event-end' functions."
+ (declare (side-effect-free t))
(let ((area (if (consp (nth 1 position))
(car (nth 1 position))
(nth 1 position))))
@@ -1681,6 +1786,7 @@ POSITION should be a list of the form returned by the `event-start'
and `event-end' functions.
Returns nil if POSITION does not correspond to any buffer location (e.g.
a click on a scroll bar)."
+ (declare (side-effect-free t))
(or (nth 5 position)
(let ((pt (nth 1 position)))
(or (car-safe pt)
@@ -1706,6 +1812,7 @@ Select the corresponding window as well."
The return value has the form (X . Y), where X and Y are given in
pixels. POSITION should be a list of the form returned by
`event-start' and `event-end'."
+ (declare (side-effect-free t))
(nth 2 position))
(declare-function scroll-bar-scale "scroll-bar" (num-denom whole))
@@ -1725,6 +1832,7 @@ corresponds to the vertical position of the click in the scroll bar.
POSITION should be a list of the form returned by the `event-start'
and `event-end' functions."
+ (declare (side-effect-free t))
(let* ((pair (posn-x-y position))
(frame-or-window (posn-window position))
(frame (if (framep frame-or-window)
@@ -1770,12 +1878,14 @@ This function does not account for the width on display, like the
number of visual columns taken by a TAB or image. If you need
the coordinates of POSITION in character units, you should use
`posn-col-row', not this function."
+ (declare (side-effect-free t))
(nth 6 position))
(defsubst posn-timestamp (position)
"Return the timestamp of POSITION.
POSITION should be a list of the form returned by the `event-start'
and `event-end' functions."
+ (declare (side-effect-free t))
(nth 3 position))
(defun posn-string (position)
@@ -1783,6 +1893,7 @@ and `event-end' functions."
Value is a cons (STRING . STRING-POS), or nil if not a string.
POSITION should be a list of the form returned by the `event-start'
and `event-end' functions."
+ (declare (side-effect-free t))
(let ((x (nth 4 position)))
;; Apparently this can also be `handle' or `below-handle' (bug#13979).
(when (consp x) x)))
@@ -1792,6 +1903,7 @@ and `event-end' functions."
Value is a list (image ...), or nil if not an image.
POSITION should be a list of the form returned by the `event-start'
and `event-end' functions."
+ (declare (side-effect-free t))
(nth 7 position))
(defsubst posn-object (position)
@@ -1800,6 +1912,7 @@ Value is a list (image ...) for an image object, a cons cell
\(STRING . STRING-POS) for a string object, and nil for a buffer position.
POSITION should be a list of the form returned by the `event-start'
and `event-end' functions."
+ (declare (side-effect-free t))
(or (posn-image position) (posn-string position)))
(defsubst posn-object-x-y (position)
@@ -1808,12 +1921,14 @@ The return value has the form (DX . DY), where DX and DY are
given in pixels, and they are relative to the top-left corner of
the clicked glyph of object at POSITION. POSITION should be a
list of the form returned by `event-start' and `event-end'."
+ (declare (side-effect-free t))
(nth 8 position))
(defsubst posn-object-width-height (position)
"Return the pixel width and height of the object of POSITION.
The return value has the form (WIDTH . HEIGHT). POSITION should
be a list of the form returned by `event-start' and `event-end'."
+ (declare (side-effect-free t))
(nth 9 position))
(defun values--store-value (value)
@@ -1846,7 +1961,7 @@ be a list of the form returned by `event-start' and `event-end'."
(defun log10 (x)
"Return (log X 10), the log base 10 of X."
- (declare (obsolete log "24.4"))
+ (declare (side-effect-free t) (obsolete log "24.4"))
(log x 10))
(set-advertised-calling-convention
@@ -1856,6 +1971,7 @@ be a list of the form returned by `event-start' and `event-end'."
(set-advertised-calling-convention 'redirect-frame-focus '(frame focus-frame) "24.3")
(set-advertised-calling-convention 'libxml-parse-xml-region '(&optional start end base-url) "27.1")
(set-advertised-calling-convention 'libxml-parse-html-region '(&optional start end base-url) "27.1")
+(set-advertised-calling-convention 'sleep-for '(seconds) "30.1")
(set-advertised-calling-convention 'time-convert '(time form) "29.1")
;;;; Obsolescence declarations for variables, and aliases.
@@ -1915,6 +2031,8 @@ instead; it will indirectly limit the specpdl stack size as well.")
(defvaralias 'native-comp-deferred-compilation 'native-comp-jit-compilation)
+(define-obsolete-function-alias 'fetch-bytecode #'ignore "30.1")
+
;;;; Alternate names for functions - these are not being phased out.
@@ -1935,6 +2053,7 @@ instead; it will indirectly limit the specpdl stack size as well.")
(defalias 'store-match-data #'set-match-data)
(defalias 'chmod #'set-file-modes)
(defalias 'mkdir #'make-directory)
+(defalias 'wholenump #'natnump)
;; These were the XEmacs names, now obsolete:
(defalias 'point-at-eol #'line-end-position)
@@ -2470,6 +2589,8 @@ Affects only hooks run in the current buffer."
(list binding binding))
((null (cdr binding))
(list (make-symbol "s") (car binding)))
+ ((eq '_ (car binding))
+ (list (make-symbol "s") (cadr binding)))
(t binding)))
(when (> (length binding) 2)
(signal 'error
@@ -2510,7 +2631,7 @@ This is like `when-let' but doesn't handle a VARLIST of the form
(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."
+are non-nil, then the result is the value of the last binding."
(declare (indent 1) (debug if-let*))
(let (res)
(if varlist
@@ -2523,7 +2644,8 @@ are non-nil, then the result is non-nil."
"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.
+THEN, otherwise the value of the last form in ELSE, or nil if
+there are none.
Each element of SPEC is a list (SYMBOL VALUEFORM) that binds
SYMBOL to the value of VALUEFORM. An element can additionally be
@@ -2573,26 +2695,161 @@ The variable list SPEC is the same as in `if-let*'."
;; PUBLIC: find if the current mode derives from another.
-(defun provided-mode-derived-p (mode &rest modes)
- "Non-nil if MODE is derived from one of MODES.
-Uses the `derived-mode-parent' property of the symbol to trace backwards.
-If you just want to check `major-mode', use `derived-mode-p'."
- ;; If MODE is an alias, then look up the real mode function first.
- (when-let ((alias (symbol-function mode)))
- (when (symbolp alias)
- (setq mode alias)))
- (while
- (and
- (not (memq mode modes))
- (let* ((parent (get mode 'derived-mode-parent))
- (parentfn (symbol-function parent)))
- (setq mode (if (and parentfn (symbolp parentfn)) parentfn parent)))))
- mode)
-
-(defun derived-mode-p (&rest modes)
- "Non-nil if the current major mode is derived from one of MODES.
-Uses the `derived-mode-parent' property of the symbol to trace backwards."
- (apply #'provided-mode-derived-p major-mode modes))
+(defun merge-ordered-lists (lists &optional error-function)
+ "Merge LISTS in a consistent order.
+LISTS is a list of lists of elements.
+Merge them into a single list containing the same elements (removing
+duplicates), obeying their relative positions in each list.
+The order of the (sub)lists determines the final order in those cases where
+the order within the sublists does not impose a unique choice.
+Equality of elements is tested with `eql'.
+
+If a consistent order does not exist, call ERROR-FUNCTION with
+a remaining list of lists that we do not know how to merge.
+It should return the candidate to use to continue the merge, which
+has to be the head of one of the lists.
+By default we choose the head of the first list."
+ ;; Algorithm inspired from
+ ;; [C3](https://en.wikipedia.org/wiki/C3_linearization)
+ (let ((result '()))
+ (setq lists (remq nil lists)) ;Don't mutate the original `lists' argument.
+ (while (cdr (setq lists (delq nil lists)))
+ ;; Try to find the next element of the result. This
+ ;; is achieved by considering the first element of each
+ ;; (non-empty) input list and accepting a candidate if it is
+ ;; consistent with the rests of the input lists.
+ (let* ((next nil)
+ (tail lists))
+ (while tail
+ (let ((candidate (caar tail))
+ (other-lists lists))
+ ;; Ensure CANDIDATE is not in any position but the first
+ ;; in any of the element lists of LISTS.
+ (while other-lists
+ (if (not (memql candidate (cdr (car other-lists))))
+ (setq other-lists (cdr other-lists))
+ (setq candidate nil)
+ (setq other-lists nil)))
+ (if (not candidate)
+ (setq tail (cdr tail))
+ (setq next candidate)
+ (setq tail nil))))
+ (unless next ;; The graph is inconsistent.
+ (setq next (funcall (or error-function #'caar) lists))
+ (unless (assoc next lists #'eql)
+ (error "Invalid candidate returned by error-function: %S" next)))
+ ;; The graph is consistent so far, add NEXT to result and
+ ;; merge input lists, dropping NEXT from their heads where
+ ;; applicable.
+ (push next result)
+ (setq lists
+ (mapcar (lambda (l) (if (eql (car l) next) (cdr l) l))
+ lists))))
+ (if (null result) (car lists) ;; Common case.
+ (append (nreverse result) (car lists)))))
+
+(defun derived-mode-all-parents (mode &optional known-children)
+ "Return all the parents of MODE, starting with MODE.
+This includes the parents set by `define-derived-mode' and additional
+ones set by `derived-mode-add-parents'.
+The returned list is not fresh, don't modify it.
+\n(fn MODE)" ;`known-children' is for internal use only.
+ ;; Can't use `with-memoization' :-(
+ (let ((ps (get mode 'derived-mode--all-parents)))
+ (cond
+ (ps ps)
+ ((memq mode known-children)
+ ;; These things happen, better not get all worked up about it.
+ ;;(error "Cycle in the major mode hierarchy: %S" mode)
+ ;; But do try to return something meaningful.
+ (memq mode (reverse known-children)))
+ (t
+ ;; The mode hierarchy (or DAG, actually), is very static, but we
+ ;; need to react to changes because `parent' may not be defined
+ ;; yet (e.g. it's still just an autoload), so the recursive call
+ ;; to `derived-mode-all-parents' may return an
+ ;; invalid/incomplete result which we'll need to update when the
+ ;; mode actually gets loaded.
+ (let* ((new-children (cons mode known-children))
+ (get-all-parents
+ (lambda (parent)
+ ;; Can't use `cl-lib' here (nor `gv') :-(
+ ;;(cl-assert (not (equal parent mode)))
+ ;;(cl-pushnew mode (get parent 'derived-mode--followers))
+ (let ((followers (get parent 'derived-mode--followers)))
+ (unless (memq mode followers)
+ (put parent 'derived-mode--followers
+ (cons mode followers))))
+ (derived-mode-all-parents parent new-children)))
+ (parent (or (get mode 'derived-mode-parent)
+ ;; If MODE is an alias, then follow the alias.
+ (let ((alias (symbol-function mode)))
+ (and (symbolp alias) alias))))
+ (extras (get mode 'derived-mode-extra-parents))
+ (all-parents
+ (merge-ordered-lists
+ (cons (if (and parent (not (memq parent extras)))
+ (funcall get-all-parents parent))
+ (mapcar get-all-parents extras)))))
+ ;; Cache the result unless it was affected by `known-children'
+ ;; because of a cycle.
+ (if (and (memq mode all-parents) known-children)
+ (cons mode (remq mode all-parents))
+ (put mode 'derived-mode--all-parents (cons mode all-parents))))))))
+
+(defun provided-mode-derived-p (mode &optional modes &rest old-modes)
+ "Non-nil if MODE is derived from a mode that is a member of the list MODES.
+MODES can also be a single mode instead of a list.
+This examines the parent modes set by `define-derived-mode' and also
+additional ones set by `derived-mode-add-parents'.
+If you just want to check the current `major-mode', use `derived-mode-p'.
+We also still support the deprecated calling convention:
+\(provided-mode-derived-p MODE &rest MODES)."
+ (declare (side-effect-free t)
+ (advertised-calling-convention (mode modes) "30.1"))
+ (cond
+ (old-modes (setq modes (cons modes old-modes)))
+ ((not (listp modes)) (setq modes (list modes))))
+ (let ((ps (derived-mode-all-parents mode)))
+ (while (and modes (not (memq (car modes) ps)))
+ (setq modes (cdr modes)))
+ (car modes)))
+
+(defun derived-mode-p (&optional modes &rest old-modes)
+ "Return non-nil if the current major mode is derived from one of MODES.
+MODES should be a list of symbols or a single mode symbol instead of a list.
+This examines the parent modes set by `define-derived-mode' and also
+additional ones set by `derived-mode-add-parents'.
+We also still support the deprecated calling convention:
+\(derived-mode-p &rest MODES)."
+ (declare (side-effect-free t)
+ ;; FIXME: It's cumbersome for external packages to write code which
+ ;; accommodates both the old and the new calling conventions *and*
+ ;; doesn't cause spurious warnings. So let's be more lenient
+ ;; for now and maybe remove `deprecated-args' for Emacs-31.
+ (advertised-calling-convention (modes &rest deprecated-args) "30.1"))
+ (provided-mode-derived-p major-mode (if old-modes (cons modes old-modes)
+ modes)))
+
+(defun derived-mode-set-parent (mode parent)
+ "Declare PARENT to be the parent of MODE."
+ (put mode 'derived-mode-parent parent)
+ (derived-mode--flush mode))
+
+(defun derived-mode-add-parents (mode extra-parents)
+ "Add EXTRA-PARENTS to the parents of MODE.
+Declares the parents of MODE to be its main parent (as defined
+in `define-derived-mode') plus EXTRA-PARENTS, which should be a list
+of symbols."
+ (put mode 'derived-mode-extra-parents extra-parents)
+ (derived-mode--flush mode))
+
+(defun derived-mode--flush (mode)
+ (put mode 'derived-mode--all-parents nil)
+ (let ((followers (get mode 'derived-mode--followers)))
+ (when followers ;; Common case.
+ (put mode 'derived-mode--followers nil)
+ (mapc #'derived-mode--flush followers))))
(defvar-local major-mode--suspended nil)
(put 'major-mode--suspended 'permanent-local t)
@@ -2715,6 +2972,7 @@ If TOGGLE has a `:menu-tag', that is used for the menu item's label."
(defsubst autoloadp (object)
"Non-nil if OBJECT is an autoload."
+ (declare (side-effect-free error-free))
(eq 'autoload (car-safe object)))
;; (defun autoload-type (object)
@@ -2759,6 +3017,7 @@ This is to `put' what `defalias' is to `fset'."
(defun locate-eln-file (eln-file)
"Locate a natively-compiled ELN-FILE by searching its load path.
This function looks in directories named by `native-comp-eln-load-path'."
+ (declare (important-return-value t))
(or (locate-file-internal (concat comp-native-version-dir "/" eln-file)
native-comp-eln-load-path)
(locate-file-internal
@@ -2790,6 +3049,7 @@ instead.
This function only works for symbols defined in Lisp files. For
symbols that are defined in C files, use `help-C-file-name'
instead."
+ (declare (important-return-value t))
(if (and (or (null type) (eq type 'defun))
(symbolp symbol)
(autoloadp (symbol-function symbol)))
@@ -2855,7 +3115,7 @@ instead."
LIBRARY should be a relative file name of the library, a string.
It can omit the suffix (a.k.a. file-name extension) if NOSUFFIX is
nil (which is the default, see below).
-This command searches the directories in `load-path' like `\\[load-library]'
+This command searches the directories in `load-path' like \\[load-library]
to find the file that `\\[load-library] RET LIBRARY RET' would load.
Optional second arg NOSUFFIX non-nil means don't add suffixes `load-suffixes'
to the specified name LIBRARY.
@@ -2916,6 +3176,7 @@ argument, which will be called with the exit status of the
program before the output is collected. If STATUS-HANDLER is
nil, an error is signaled if the program returns with a non-zero
exit status."
+ (declare (important-return-value t))
(with-temp-buffer
(let ((status (apply #'call-process program nil (current-buffer) nil args)))
(if status-handler
@@ -2936,12 +3197,14 @@ exit status."
"Execute PROGRAM with ARGS, returning its output as a list of lines.
Signal an error if the program returns with a non-zero exit status.
Also see `process-lines-ignore-status'."
+ (declare (important-return-value t))
(apply #'process-lines-handling-status program nil args))
(defun process-lines-ignore-status (program &rest args)
"Execute PROGRAM with ARGS, returning its output as a list of lines.
The exit status of the program is ignored.
Also see `process-lines'."
+ (declare (important-return-value t))
(apply #'process-lines-handling-status program #'ignore args))
(defun process-live-p (process)
@@ -2970,6 +3233,7 @@ process."
(defun process-get (process propname)
"Return the value of PROCESS' PROPNAME property.
This is the last value stored with `(process-put PROCESS PROPNAME VALUE)'."
+ (declare (side-effect-free t))
(plist-get (process-plist process) propname))
(defun process-put (process propname value)
@@ -2980,6 +3244,7 @@ It can be retrieved with `(process-get PROCESS PROPNAME)'."
(defun memory-limit ()
"Return an estimate of Emacs virtual memory usage, divided by 1024."
+ (declare (side-effect-free error-free))
(let ((default-directory temporary-file-directory))
(or (cdr (assq 'vsize (process-attributes (emacs-pid)))) 0)))
@@ -3013,6 +3278,11 @@ So escape sequences and keyboard encoding are taken into account.
When there's an ambiguity because the key looks like the prefix of
some sort of escape sequence, the ambiguity is resolved via `read-key-delay'.
+Also in contrast to `read-event', input method text conversion
+will be disabled while the key sequence is read, so that
+character input events will always be generated for keyboard
+input.
+
If the optional argument PROMPT is non-nil, display that as a
prompt.
@@ -3071,7 +3341,8 @@ only unbound fallback disabled is downcasing of the last event."
(lookup-key global-map [tool-bar])))
map))
(let* ((keys
- (catch 'read-key (read-key-sequence-vector prompt nil t)))
+ (catch 'read-key (read-key-sequence-vector prompt nil t
+ nil nil t)))
(key (aref keys 0)))
(if (and (> (length keys) 1)
(memq key '(mode-line header-line
@@ -3085,22 +3356,30 @@ only unbound fallback disabled is downcasing of the last event."
(message nil)
(use-global-map old-global-map))))
+(defvar touch-screen-events-received nil
+ "Whether a touch screen event has ever been translated.
+The value of this variable governs whether
+`read--potential-mouse-event' calls read-key or read-event.")
+
;; FIXME: Once there's a safe way to transition away from read-event,
;; callers to this function should be updated to that way and this
;; function should be deleted.
(defun read--potential-mouse-event ()
- "Read an event that might be a mouse event.
+ "Read an event that might be a mouse event.
This function exists for backward compatibility in code packaged
with Emacs. Do not call it directly in your own packages."
- ;; `xterm-mouse-mode' events must go through `read-key' as they
- ;; are decoded via `input-decode-map'.
- (if xterm-mouse-mode
- (read-key nil
- ;; Normally `read-key' discards all mouse button
- ;; down events. However, we want them here.
- t)
- (read-event)))
+ ;; `xterm-mouse-mode' events must go through `read-key' as they
+ ;; are decoded via `input-decode-map'.
+ (if (or xterm-mouse-mode
+ ;; If a touch screen is being employed, then mouse events
+ ;; are subject to translation as well.
+ touch-screen-events-received)
+ (read-key nil
+ ;; Normally `read-key' discards all mouse button
+ ;; down events. However, we want them here.
+ t)
+ (read-event)))
(defvar read-passwd-map
;; BEWARE: `defconst' would purecopy it, breaking the sharing with
@@ -3108,14 +3387,27 @@ with Emacs. Do not call it directly in your own packages."
(let ((map (make-sparse-keymap)))
(set-keymap-parent map minibuffer-local-map)
(define-key map "\C-u" #'delete-minibuffer-contents) ;bug#12570
+ (define-key map "\t" #'read-passwd-toggle-visibility)
map)
"Keymap used while reading passwords.")
-(defun read-password--hide-password ()
+(defvar read-passwd--hide-password t)
+
+(defun read-passwd--hide-password ()
+ "Make password in minibuffer hidden or visible."
(let ((beg (minibuffer-prompt-end)))
(dotimes (i (1+ (- (buffer-size) beg)))
- (put-text-property (+ i beg) (+ 1 i beg)
- 'display (string (or read-hide-char ?*))))))
+ (if read-passwd--hide-password
+ (put-text-property
+ (+ i beg) (+ 1 i beg) 'display (string (or read-hide-char ?*)))
+ (remove-list-of-text-properties (+ i beg) (+ 1 i beg) '(display)))
+ (put-text-property
+ (+ i beg) (+ 1 i beg)
+ 'help-echo "C-u: Clear password\nTAB: Toggle password visibility"))))
+
+;; Actually in textconv.c.
+(defvar overriding-text-conversion-style)
+(declare-function set-text-conversion-style "textconv.c")
(defun read-passwd (prompt &optional confirm default)
"Read a password, prompting with PROMPT, and return it.
@@ -3153,21 +3445,27 @@ by doing (clear-string STRING)."
(setq-local inhibit-modification-hooks nil) ;bug#15501.
(setq-local show-paren-mode nil) ;bug#16091.
(setq-local inhibit--record-char t)
- (add-hook 'post-command-hook #'read-password--hide-password nil t))
+ (read-passwd-mode 1)
+ (add-hook 'post-command-hook #'read-passwd--hide-password nil t))
(unwind-protect
(let ((enable-recursive-minibuffers t)
- (read-hide-char (or read-hide-char ?*)))
+ (read-hide-char (or read-hide-char ?*))
+ (overriding-text-conversion-style 'password))
(read-string prompt nil t default)) ; t = "no history"
(when (buffer-live-p minibuf)
(with-current-buffer minibuf
+ (read-passwd-mode -1)
;; Not sure why but it seems that there might be cases where the
;; minibuffer is not always properly reset later on, so undo
;; whatever we've done here (bug#11392).
(remove-hook 'after-change-functions
- #'read-password--hide-password 'local)
+ #'read-passwd--hide-password 'local)
(kill-local-variable 'post-self-insert-hook)
;; And of course, don't keep the sensitive data around.
- (erase-buffer))))))))
+ (erase-buffer)
+ ;; Then restore the previous text conversion style.
+ (when (fboundp 'set-text-conversion-style)
+ (set-text-conversion-style text-conversion-style)))))))))
(defvar read-number-history nil
"The default history for the `read-number' function.")
@@ -3257,6 +3555,8 @@ causes it to evaluate `help-form' and display the result."
(while (not done)
(unless (get-text-property 0 'face prompt)
(setq prompt (propertize prompt 'face 'minibuffer-prompt)))
+ ;; Display the on screen keyboard if it exists.
+ (frame-toggle-on-screen-keyboard (selected-frame) nil)
(setq char (let ((inhibit-quit inhibit-keyboard-quit))
(read-key prompt)))
(and show-help (buffer-live-p (get-buffer helpbuf))
@@ -3271,11 +3571,6 @@ causes it to evaluate `help-form' and display the result."
(help-form-show)))
((memq char chars)
(setq done t))
- ((and executing-kbd-macro (= char -1))
- ;; read-event returns -1 if we are in a kbd macro and
- ;; there are no more events in the macro. Attempt to
- ;; get an event interactively.
- (setq executing-kbd-macro nil))
((not inhibit-keyboard-quit)
(cond
((and (null esc-flag) (eq char ?\e))
@@ -3286,7 +3581,7 @@ causes it to evaluate `help-form' and display the result."
(message "%s%s" prompt (char-to-string char))
char))
-(defun sit-for (seconds &optional nodisp obsolete)
+(defun sit-for (seconds &optional nodisp)
"Redisplay, then wait for SECONDS seconds. Stop when input is available.
SECONDS may be a floating-point value.
\(On operating systems that do not support waiting for fractions of a
@@ -3295,29 +3590,11 @@ second, floating-point values are rounded down to the nearest integer.)
If optional arg NODISP is t, don't redisplay, just wait for input.
Redisplay does not happen if input is available before it starts.
-Value is t if waited the full time with no input arriving, and nil otherwise.
-
-An obsolete, but still supported form is
-\(sit-for SECONDS &optional MILLISECONDS NODISP)
-where the optional arg MILLISECONDS specifies an additional wait period,
-in milliseconds; this was useful when Emacs was built without
-floating point support."
- (declare (advertised-calling-convention (seconds &optional nodisp) "22.1")
- (compiler-macro
- (lambda (form)
- (if (not (or (numberp nodisp) obsolete)) form
- (macroexp-warn-and-return
- "Obsolete calling convention for 'sit-for'"
- `(,(car form) (+ ,seconds (/ (or ,nodisp 0) 1000.0)) ,obsolete)
- '(obsolete sit-for))))))
+Value is t if waited the full time with no input arriving, and nil otherwise."
;; This used to be implemented in C until the following discussion:
;; https://lists.gnu.org/r/emacs-devel/2006-07/msg00401.html
;; Then it was moved here using an implementation based on an idle timer,
;; which was then replaced by the use of read-event.
- (if (numberp nodisp)
- (setq seconds (+ seconds (* 1e-3 nodisp))
- nodisp obsolete)
- (if obsolete (setq nodisp obsolete)))
(cond
(noninteractive
(sleep-for seconds)
@@ -3379,7 +3656,7 @@ If there is a natural number at point, use it as default."
(let ((map (make-sparse-keymap)))
(set-keymap-parent map minibuffer-local-map)
- (define-key map [remap self-insert-command] #'read-char-from-minibuffer-insert-char)
+ ;; (define-key map [remap self-insert-command] #'read-char-from-minibuffer-insert-char)
(define-key map [remap exit-minibuffer] #'read-char-from-minibuffer-insert-other)
(define-key map [remap recenter-top-bottom] #'minibuffer-recenter-top-bottom)
@@ -3410,13 +3687,16 @@ 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)
+ (when (minibufferp) ;;FIXME: Why?
(delete-minibuffer-contents)
(ding)
(discard-input)
(minibuffer-message "Wrong answer")
(sit-for 2)))
+;; Defined in textconv.c.
+(defvar overriding-text-conversion-style)
+
(defun read-char-from-minibuffer (prompt &optional chars history)
"Read a character from the minibuffer, prompting for it with PROMPT.
Like `read-char', but uses the minibuffer to read and return a character.
@@ -3431,7 +3711,15 @@ while calling this function, then pressing `help-char'
causes it to evaluate `help-form' and display the result.
There is no need to explicitly add `help-char' to CHARS;
`help-char' is bound automatically to `help-form-show'."
- (let* ((map (if (consp chars)
+
+ ;; If text conversion is enabled in this buffer, then it will only
+ ;; be disabled the next time `force-mode-line-update' happens.
+ (when (and (bound-and-true-p overriding-text-conversion-style)
+ (bound-and-true-p text-conversion-style))
+ (force-mode-line-update))
+
+ (let* ((overriding-text-conversion-style nil)
+ (map (if (consp chars)
(or (gethash (list help-form (cons help-char chars))
read-char-from-minibuffer-map-hash)
(let ((map (make-sparse-keymap))
@@ -3443,22 +3731,39 @@ There is no need to explicitly add `help-char' to CHARS;
;; being a command char.
(when help-form
(define-key map (vector help-char)
- (lambda ()
- (interactive)
- (let ((help-form msg)) ; lexically bound msg
- (help-form-show)))))
+ (lambda ()
+ (interactive)
+ (let ((help-form msg)) ; lexically bound msg
+ (help-form-show)))))
+ ;; FIXME: We use `read-char-from-minibuffer-insert-char'
+ ;; here only as a kind of alias of `self-insert-command'
+ ;; to prevent those keys from being remapped to
+ ;; `read-char-from-minibuffer-insert-other'.
(dolist (char chars)
(define-key map (vector char)
- #'read-char-from-minibuffer-insert-char))
+ #'read-char-from-minibuffer-insert-char))
(define-key map [remap self-insert-command]
- #'read-char-from-minibuffer-insert-other)
+ #'read-char-from-minibuffer-insert-other)
(puthash (list help-form (cons help-char chars))
map read-char-from-minibuffer-map-hash)
map))
read-char-from-minibuffer-map))
;; Protect this-command when called from pre-command-hook (bug#45029)
(this-command this-command)
- (result (read-from-minibuffer prompt nil map nil (or history t)))
+ (result (minibuffer-with-setup-hook
+ (lambda ()
+ (setq-local post-self-insert-hook nil)
+ (add-hook 'post-command-hook
+ (lambda ()
+ (if (<= (1+ (minibuffer-prompt-end))
+ (point-max))
+ (exit-minibuffer)))
+ nil 'local))
+ ;; Disable text conversion if it is enabled.
+ ;; (bug#65370)
+ (when (fboundp 'set-text-conversion-style)
+ (set-text-conversion-style text-conversion-style))
+ (read-from-minibuffer prompt nil map nil (or history t))))
(char
(if (> (length result) 0)
;; We have a string (with one character), so return the first one.
@@ -3550,21 +3855,34 @@ confusing to some users.")
(defvar from--tty-menu-p nil
"Non-nil means the current command was invoked from a TTY menu.")
+
+(declare-function android-detect-keyboard "androidfns.c")
+
+(defvar use-dialog-box-override nil
+ "Whether `use-dialog-box-p' should always return t.")
+
(defun use-dialog-box-p ()
"Return non-nil if the current command should prompt the user via a dialog box."
- (and last-input-event ; not during startup
- (or (consp last-nonmenu-event) ; invoked by a mouse event
- (and (null last-nonmenu-event)
- (consp last-input-event))
- from--tty-menu-p) ; invoked via TTY menu
- use-dialog-box))
+ (or use-dialog-box-override
+ (and last-input-event ; not during startup
+ (or (consp last-nonmenu-event) ; invoked by a mouse event
+ (and (null last-nonmenu-event)
+ (consp last-input-event))
+ (and (featurep 'android) ; Prefer dialog boxes on
+ ; Android.
+ (not (android-detect-keyboard))) ; If no keyboard is
+ ; connected.
+ from--tty-menu-p) ; invoked via TTY menu
+ use-dialog-box)))
(defun y-or-n-p (prompt)
"Ask user a \"y or n\" question.
Return t if answer is \"y\" and nil if it is \"n\".
PROMPT is the string to display to ask the question; `y-or-n-p'
-adds \"(y or n) \" to it.
+adds \"(y or n) \" to it. If PROMPT is a non-empty string, and
+it ends with a non-space character, a space character will be
+appended to it.
If you bind the variable `help-form' to a non-nil value
while calling this function, then pressing `help-char'
@@ -3666,6 +3984,9 @@ like) while `y-or-n-p' is running)."
(setq prompt (funcall padded prompt))
(let* ((enable-recursive-minibuffers t)
(msg help-form)
+ ;; Disable text conversion so that real Y or N events are
+ ;; sent.
+ (overriding-text-conversion-style nil)
(keymap (let ((map (make-composed-keymap
y-or-n-p-map query-replace-map)))
(when help-form
@@ -3679,9 +4000,15 @@ like) while `y-or-n-p' is running)."
map))
;; Protect this-command when called from pre-command-hook (bug#45029)
(this-command this-command)
- (str (read-from-minibuffer
- prompt nil keymap nil
- (or y-or-n-p-history-variable t))))
+ (str (progn
+ ;; If the minibuffer is already active, the
+ ;; selected window might not change. Disable
+ ;; text conversion by hand.
+ (when (fboundp 'set-text-conversion-style)
+ (set-text-conversion-style text-conversion-style))
+ (read-from-minibuffer
+ prompt nil keymap nil
+ (or y-or-n-p-history-variable t)))))
(setq answer (if (member str '("y" "Y")) 'act 'skip)))))
(let ((ret (eq answer 'act)))
(unless noninteractive
@@ -3697,6 +4024,9 @@ This means that if BODY exits abnormally,
all of its changes to the current buffer are undone.
This works regardless of whether undo is enabled in the buffer.
+Do not call functions which edit the undo list within BODY; see
+`prepare-change-group'.
+
This mechanism is transparent to ordinary use of undo;
if undo is enabled in the buffer and BODY succeeds, the
user can undo the change normally."
@@ -3763,6 +4093,12 @@ Once you finish the group, don't use the handle again--don't try to
finish the same group twice. For a simple example of correct use, see
the source code of `atomic-change-group'.
+As long as this handle is still in use, do not call functions
+which edit the undo list: if it no longer contains its current
+value, Emacs will not be able to cancel the change group. This
+includes any \"amalgamating\" commands, such as `delete-char',
+which call `undo-auto-amalgamate'.
+
The handle records only the specified buffer. To make a multibuffer
change group, call this function once for each buffer you want to
cover, then use `nconc' to combine the returned values, like this:
@@ -3885,6 +4221,7 @@ If MESSAGE is nil, instructions to type EXIT-CHAR are displayed there."
(defun copy-overlay (o)
"Return a copy of overlay O."
+ (declare (important-return-value t))
(let ((o1 (if (overlay-buffer o)
(make-overlay (overlay-start o) (overlay-end o)
;; FIXME: there's no easy way to find the
@@ -3967,6 +4304,7 @@ See also `locate-user-emacs-file'.")
(defsubst buffer-narrowed-p ()
"Return non-nil if the current buffer is narrowed."
+ (declare (side-effect-free t))
(/= (- (point-max) (point-min)) (buffer-size)))
(defmacro with-restriction (start end &rest rest)
@@ -3983,17 +4321,10 @@ buffer, use `without-restriction' with the same LABEL argument.
\(fn START END [:label LABEL] BODY)"
(declare (indent 2) (debug t))
(if (eq (car rest) :label)
- `(internal--with-restriction ,start ,end (lambda () ,@(cddr rest))
- ,(cadr rest))
- `(internal--with-restriction ,start ,end (lambda () ,@rest))))
-
-(defun internal--with-restriction (start end body &optional label)
- "Helper function for `with-restriction', which see."
- (save-restriction
- (if label
- (internal--labeled-narrow-to-region start end label)
- (narrow-to-region start end))
- (funcall body)))
+ `(save-restriction
+ (internal--labeled-narrow-to-region ,start ,end ,(cadr rest))
+ ,@(cddr rest))
+ `(save-restriction (narrow-to-region ,start ,end) ,@rest)))
(defmacro without-restriction (&rest rest)
"Execute BODY without restrictions.
@@ -4006,17 +4337,8 @@ by `with-restriction' with the same LABEL argument are lifted.
\(fn [:label LABEL] BODY)"
(declare (indent 0) (debug t))
(if (eq (car rest) :label)
- `(internal--without-restriction (lambda () ,@(cddr rest))
- ,(cadr rest))
- `(internal--without-restriction (lambda () ,@rest))))
-
-(defun internal--without-restriction (body &optional label)
- "Helper function for `without-restriction', which see."
- (save-restriction
- (if label
- (internal--labeled-widen label)
- (widen))
- (funcall body)))
+ `(save-restriction (internal--labeled-widen ,(cadr rest)) ,@(cddr rest))
+ `(save-restriction (widen) ,@rest)))
(defun find-tag-default-bounds ()
"Determine the boundaries of the default tag, based on text at point.
@@ -4094,7 +4416,8 @@ 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
+ (declare (important-return-value t))
+ (cond
((and (not posix) (eq system-type 'ms-dos))
;; Quote using double quotes, but escape any existing quotes in
;; the argument with backslashes.
@@ -4154,15 +4477,18 @@ system's shell."
(defsubst string-to-list (string)
"Return a list of characters in STRING."
+ (declare (side-effect-free t))
(append string nil))
(defsubst string-to-vector (string)
"Return a vector of characters in STRING."
+ (declare (side-effect-free t))
(vconcat string))
(defun string-or-null-p (object)
"Return t if OBJECT is a string or nil.
Otherwise, return nil."
+ (declare (pure t) (side-effect-free error-free))
(or (stringp object) (null object)))
(defun list-of-strings-p (object)
@@ -4175,21 +4501,24 @@ Otherwise, return nil."
(defun booleanp (object)
"Return t if OBJECT is one of the two canonical boolean values: t or nil.
Otherwise, return nil."
+ (declare (pure t) (side-effect-free error-free))
(and (memq object '(nil t)) t))
(defun special-form-p (object)
"Non-nil if and only if OBJECT is a special form."
- (if (and (symbolp object) (fboundp object))
- (setq object (indirect-function object)))
+ (declare (side-effect-free error-free))
+ (if (symbolp object) (setq object (indirect-function object)))
(and (subrp object) (eq (cdr (subr-arity object)) 'unevalled)))
(defun plistp (object)
"Non-nil if and only if OBJECT is a valid plist."
+ (declare (pure t) (side-effect-free error-free))
(let ((len (proper-list-p object)))
(and len (zerop (% len 2)))))
(defun macrop (object)
"Non-nil if and only if OBJECT is a macro."
+ (declare (side-effect-free t))
(let ((def (indirect-function object)))
(when (consp def)
(or (eq 'macro (car def))
@@ -4199,10 +4528,13 @@ Otherwise, return nil."
"Return non-nil if OBJECT is a function that has been compiled.
Does not distinguish between functions implemented in machine code
or byte-code."
- (or (subrp object) (byte-code-function-p object)))
+ (declare (side-effect-free error-free))
+ (or (and (subrp object) (not (eq 'unevalled (cdr (subr-arity object)))))
+ (byte-code-function-p object)))
(defun field-at-pos (pos)
"Return the field at position POS, taking stickiness etc into account."
+ (declare (important-return-value t))
(let ((raw-field (get-char-property (field-beginning pos) 'field)))
(if (eq raw-field 'boundary)
(get-char-property (1- (field-end pos)) 'field)
@@ -4218,6 +4550,7 @@ string; otherwise returna 40-character string.
Note that SHA-1 is not collision resistant and should not be used
for anything security-related. See `secure-hash' for
alternatives."
+ (declare (side-effect-free t))
(secure-hash 'sha1 object start end binary))
(defun function-get (f prop &optional autoload)
@@ -4225,6 +4558,7 @@ alternatives."
If AUTOLOAD is non-nil and F is autoloaded, try to load it
in the hope that it will set PROP. If AUTOLOAD is `macro', do it only
if it's an autoloaded macro."
+ (declare (important-return-value t))
(let ((val nil))
(while (and (symbolp f)
(null (setq val (get f prop)))
@@ -4713,7 +5047,7 @@ read-only, and scans it for function and variable names to make them into
clickable cross-references.
See the related form `with-temp-buffer-window'."
- (declare (debug t))
+ (declare (debug t) (indent 1))
(let ((old-dir (make-symbol "old-dir"))
(buf (make-symbol "buf")))
`(let* ((,old-dir default-directory)
@@ -4889,9 +5223,12 @@ even if this catches the signal."
`(condition-case ,var
,bodyform
,@(mapcar (lambda (handler)
- `((debug ,@(if (listp (car handler)) (car handler)
- (list (car handler))))
- ,@(cdr handler)))
+ (let ((condition (car handler)))
+ (if (eq condition :success)
+ handler
+ `((debug ,@(if (listp condition) condition
+ (list condition)))
+ ,@(cdr handler)))))
handlers)))
(defmacro with-demoted-errors (format &rest body)
@@ -4905,6 +5242,7 @@ but that should be robust in the unexpected case that an error is signaled."
(declare (debug t) (indent 1))
(let* ((err (make-symbol "err"))
(orig-body body)
+ (orig-format format)
(format (if (and (stringp format) body) format
(prog1 "Error: %S"
(if format (push format body)))))
@@ -4915,7 +5253,10 @@ but that should be robust in the unexpected case that an error is signaled."
(if (eq orig-body body) exp
;; The use without `format' is obsolete, let's warn when we bump
;; into any such remaining uses.
- (macroexp-warn-and-return "Missing format argument" exp nil nil format))))
+ (macroexp-warn-and-return
+ (format-message "Missing format argument in `with-demoted-errors'")
+ exp nil nil
+ orig-format))))
(defmacro combine-after-change-calls (&rest body)
"Execute BODY, but don't call the after-change functions till the end.
@@ -4989,31 +5330,41 @@ the function `undo--wrap-and-run-primitive-undo'."
(kill-local-variable 'before-change-functions))
(if local-acf (setq after-change-functions acf)
(kill-local-variable 'after-change-functions))))
- (when (not (eq buffer-undo-list t))
- (let ((ap-elt
- (list 'apply
- (- end end-marker)
- beg
- (marker-position end-marker)
- #'undo--wrap-and-run-primitive-undo
- beg (marker-position end-marker) buffer-undo-list))
- (ptr buffer-undo-list))
- (if (not (eq buffer-undo-list old-bul))
- (progn
- (while (and (not (eq (cdr ptr) old-bul))
- ;; In case garbage collection has removed OLD-BUL.
- (cdr ptr))
- (if (and (consp (cdr ptr))
- (consp (cadr ptr))
- (eq (caadr ptr) t))
- ;; Don't include a timestamp entry.
- (setcdr ptr (cddr ptr))
- (setq ptr (cdr ptr))))
- (unless (or (cdr ptr) (null old-bul))
- (message "combine-change-calls: buffer-undo-list presumably truncated by GC"))
- (setcdr ptr nil)
- (push ap-elt buffer-undo-list)
- (setcdr buffer-undo-list old-bul)))))
+ ;; If buffer-undo-list is neither t (in which case undo
+ ;; information is not recorded) nor equal to buffer-undo-list
+ ;; before body was funcalled (in which case (funcall body) did
+ ;; not add items to buffer-undo-list) ...
+ (unless (or (eq buffer-undo-list t)
+ (eq buffer-undo-list old-bul))
+ (let ((ptr buffer-undo-list) body-undo-list)
+ ;; ... then loop over buffer-undo-list, until the head of
+ ;; buffer-undo-list before body was funcalled is found, or
+ ;; ptr is nil (which may happen if garbage-collect has
+ ;; been called after (funcall body) and has removed
+ ;; entries of buffer-undo-list that were added by (funcall
+ ;; body)), and add these entries to body-undo-list.
+ (while (and ptr (not (eq ptr old-bul)))
+ (push (car ptr) body-undo-list)
+ (setq ptr (cdr ptr)))
+ (setq body-undo-list (nreverse body-undo-list))
+ ;; Warn if garbage-collect has truncated buffer-undo-list
+ ;; behind our back.
+ (when (and old-bul (not ptr))
+ (message
+ "combine-change-calls: buffer-undo-list has been truncated"))
+ ;; Add an (apply ...) entry to buffer-undo-list, using
+ ;; body-undo-list ...
+ (push (list 'apply
+ (- end end-marker)
+ beg
+ (marker-position end-marker)
+ #'undo--wrap-and-run-primitive-undo
+ beg (marker-position end-marker)
+ body-undo-list)
+ buffer-undo-list)
+ ;; ... and set the cdr of buffer-undo-list to
+ ;; buffer-undo-list before body was funcalled.
+ (setcdr buffer-undo-list old-bul)))
(if (not inhibit-modification-hooks)
(run-hook-with-args 'after-change-functions
beg (marker-position end-marker)
@@ -5177,6 +5528,7 @@ In other words, all back-references in the form `\\&' and `\\N'
are substituted with actual strings matched by the last search.
Optional FIXEDCASE, LITERAL, STRING and SUBEXP have the same
meaning as for `replace-match'."
+ (declare (side-effect-free t))
(let ((match (match-string 0 string)))
(save-match-data
(match-data--translate (- (match-beginning 0)))
@@ -5222,11 +5574,13 @@ wherever possible, since it is slow."
(defsubst looking-at-p (regexp)
"\
Same as `looking-at' except this function does not change the match data."
+ (declare (side-effect-free t))
(looking-at regexp t))
(defsubst string-match-p (regexp string &optional start)
"\
Same as `string-match' except this function does not change the match data."
+ (declare (side-effect-free t))
(string-match regexp string start t))
(defun subregexp-context-p (regexp pos &optional start)
@@ -5236,6 +5590,7 @@ A non-subregexp context is for example within brackets, or within a
repetition bounds operator `\\=\\{...\\}', or right after a `\\'.
If START is non-nil, it should be a position in REGEXP, smaller
than POS, and known to be in a subregexp context."
+ (declare (important-return-value t))
;; Here's one possible implementation, with the great benefit that it
;; reuses the regexp-matcher's own parser, so it understands all the
;; details of the syntax. A disadvantage is that it needs to match the
@@ -5317,6 +5672,7 @@ case that you wish to retain zero-length substrings when splitting on
whitespace, use `(split-string STRING split-string-default-separators)'.
Modifies the match data; use `save-match-data' if necessary."
+ (declare (important-return-value t))
(let* ((keep-nulls (not (if separators omit-nulls t)))
(rexp (or separators split-string-default-separators))
(start 0)
@@ -5374,6 +5730,7 @@ Only some SEPARATORs will work properly.
Note that this is not intended to protect STRINGS from
interpretation by shells, use `shell-quote-argument' for that."
+ (declare (important-return-value t))
(let* ((sep (or separator " "))
(re (concat "[\\\"]" "\\|" (regexp-quote sep))))
(mapconcat
@@ -5388,6 +5745,7 @@ interpretation by shells, use `shell-quote-argument' for that."
It understands Emacs Lisp quoting within STRING, such that
(split-string-and-unquote (combine-and-quote-strings strs)) == strs
The SEPARATOR regexp defaults to \"\\s-+\"."
+ (declare (important-return-value t))
(let ((sep (or separator "\\s-+"))
(i (string-search "\"" string)))
(if (null i)
@@ -5455,6 +5813,7 @@ To replace only the first match (if any), make REGEXP match up to \\\\='
and replace a sub-expression, e.g.
(replace-regexp-in-string \"\\\\(foo\\\\).*\\\\\\='\" \"bar\" \" foo foo\" nil nil 1)
=> \" bar foo\""
+ (declare (important-return-value t))
;; To avoid excessive consing from multiple matches in long strings,
;; don't just call `replace-match' continually. Walk down the
@@ -5497,7 +5856,7 @@ Upper-case and lower-case letters are treated as equal.
Unibyte strings are converted to multibyte for comparison.
See also `string-equal'."
- (declare (pure t) (side-effect-free t))
+ (declare (side-effect-free t))
(eq t (compare-strings string1 0 nil string2 0 nil t)))
(defun string-prefix-p (prefix string &optional ignore-case)
@@ -5506,7 +5865,7 @@ PREFIX should be a string; the function returns non-nil if the
characters at the beginning of STRING compare equal with PREFIX.
If IGNORE-CASE is non-nil, the comparison is done without paying attention
to letter-case differences."
- (declare (pure t) (side-effect-free t))
+ (declare (side-effect-free t))
(let ((prefix-length (length prefix)))
(if (> prefix-length (length string)) nil
(eq t (compare-strings prefix 0 prefix-length string
@@ -5518,7 +5877,7 @@ SUFFIX should be a string; the function returns non-nil if the
characters at end of STRING compare equal with SUFFIX.
If IGNORE-CASE is non-nil, the comparison is done without paying
attention to letter-case differences."
- (declare (pure t) (side-effect-free t))
+ (declare (side-effect-free t))
(let ((start-pos (- (length string) (length suffix))))
(and (>= start-pos 0)
(eq t (compare-strings suffix nil nil
@@ -5546,6 +5905,7 @@ consisting of STR followed by an invisible left-to-right mark
"Return non-nil if STRING1 is greater than STRING2 in lexicographic order.
Case is significant.
Symbols are also allowed; their print names are used instead."
+ (declare (pure t) (side-effect-free t))
(string-lessp string2 string1))
@@ -5573,8 +5933,8 @@ Return nil if there isn't one."
(load-elt (and loads (car loads))))
(save-match-data
(while (and loads
- (or (null (car load-elt))
- (not (string-match file-regexp (car load-elt)))))
+ (not (and (car load-elt)
+ (string-match file-regexp (car load-elt)))))
(setq loads (cdr loads)
load-elt (and loads (car loads)))))
load-elt))
@@ -5813,6 +6173,7 @@ from `standard-syntax-table' otherwise."
(defun syntax-after (pos)
"Return the raw syntax descriptor for the char after POS.
If POS is outside the buffer's accessible portion, return nil."
+ (declare (important-return-value t))
(unless (or (< pos (point-min)) (>= pos (point-max)))
(let ((st (if parse-sexp-lookup-properties
(get-char-property pos 'syntax-table))))
@@ -5827,6 +6188,7 @@ integer that encodes the corresponding syntax class. See Info
node `(elisp)Syntax Table Internals' for a list of codes.
If SYNTAX is nil, return nil."
+ (declare (pure t) (side-effect-free t))
(and syntax (logand (car syntax) 65535)))
;; Utility motion commands
@@ -6062,13 +6424,14 @@ If non-nil, BASE should be a function, and frames before its
nearest activation frame are discarded."
(let ((frames nil))
(mapbacktrace (lambda (&rest frame) (push frame frames))
- (or base 'backtrace-frames))
+ (or base #'backtrace-frames))
(nreverse frames)))
(defun backtrace-frame (nframes &optional base)
"Return the function and arguments NFRAMES up from current execution point.
If non-nil, BASE should be a function, and NFRAMES counts from its
-nearest activation frame.
+nearest activation frame. BASE can also be of the form (OFFSET . FUNCTION)
+in which case OFFSET will be added to NFRAMES.
If the frame has not evaluated the arguments yet (or is a special form),
the value is (nil FUNCTION ARG-FORMS...).
If the frame has evaluated its arguments and called its function already,
@@ -6079,7 +6442,7 @@ or a lambda expression for macro calls.
If NFRAMES is more than the number of frames, the value is nil."
(backtrace-frame--internal
(lambda (evald func args _) `(,evald ,func ,@args))
- nframes (or base 'backtrace-frame)))
+ nframes (or base #'backtrace-frame)))
(defvar called-interactively-p-functions nil
@@ -6145,14 +6508,8 @@ command is called from a keyboard macro?"
;; Skip special forms (from non-compiled code).
(and frame (null (car frame)))
;; Skip also `interactive-p' (because we don't want to know if
- ;; interactive-p was called interactively but if it's caller was)
- ;; and `byte-code' (idem; this appears in subexpressions of things
- ;; like condition-case, which are wrapped in a separate bytecode
- ;; chunk).
- ;; FIXME: For lexical-binding code, this is much worse,
- ;; because the frames look like "byte-code -> funcall -> #[...]",
- ;; which is not a reliable signature.
- (memq (nth 1 frame) '(interactive-p 'byte-code))
+ ;; interactive-p was called interactively but if its caller was).
+ (eq (nth 1 frame) 'interactive-p)
;; Skip package-specific stack-frames.
(let ((skip (run-hook-with-args-until-success
'called-interactively-p-functions
@@ -6195,7 +6552,8 @@ To test whether a function can be called interactively, use
`commandp'."
;; Kept around for now. See discussion at:
;; https://lists.gnu.org/r/emacs-devel/2020-08/msg00564.html
- (declare (obsolete called-interactively-p "23.2"))
+ (declare (obsolete called-interactively-p "23.2")
+ (side-effect-free error-free))
(called-interactively-p 'interactive))
(defun internal-push-keymap (keymap symbol)
@@ -6395,7 +6753,6 @@ effectively rounded up."
(unless min-time
(setq min-time 0.2))
(let ((reporter
- ;; Force a call to `message' now
(cons (or min-value 0)
(vector (if (>= min-time 0.02)
(float-time) nil)
@@ -6406,9 +6763,12 @@ effectively rounded up."
min-time
;; SUFFIX
nil))))
+ ;; Force a call to `message' now.
(progress-reporter-update reporter (or current-value min-value))
reporter))
+(defalias 'progress-reporter-make #'make-progress-reporter)
+
(defun progress-reporter-force-update (reporter &optional value new-message suffix)
"Report progress of an operation in the echo area unconditionally.
@@ -6631,6 +6991,7 @@ Examples of version conversion:
\"22.8beta3\" (22 8 -2 3)
See documentation for `version-separator' and `version-regexp-alist'."
+ (declare (side-effect-free t))
(unless (stringp ver)
(error "Version must be a string"))
;; Change .x.y to 0.x.y
@@ -6682,6 +7043,7 @@ Note that a version specified by the list (1) is equal to (1 0),
\(1 0 0), (1 0 0 0), etc. That is, the trailing zeros are insignificant.
Also, a version given by the list (1) is higher than (1 -1), which in
turn is higher than (1 -2), which is higher than (1 -3)."
+ (declare (pure t) (side-effect-free t))
(while (and l1 l2 (= (car l1) (car l2)))
(setq l1 (cdr l1)
l2 (cdr l2)))
@@ -6703,6 +7065,7 @@ Note that a version specified by the list (1) is equal to (1 0),
\(1 0 0), (1 0 0 0), etc. That is, the trailing zeros are insignificant.
Also, a version given by the list (1) is higher than (1 -1), which in
turn is higher than (1 -2), which is higher than (1 -3)."
+ (declare (pure t) (side-effect-free t))
(while (and l1 l2 (= (car l1) (car l2)))
(setq l1 (cdr l1)
l2 (cdr l2)))
@@ -6724,6 +7087,7 @@ Note that integer list (1) is equal to (1 0), (1 0 0), (1 0 0 0),
etc. That is, the trailing zeroes are insignificant. Also, integer
list (1) is greater than (1 -1) which is greater than (1 -2)
which is greater than (1 -3)."
+ (declare (pure t) (side-effect-free t))
(while (and l1 l2 (= (car l1) (car l2)))
(setq l1 (cdr l1)
l2 (cdr l2)))
@@ -6741,6 +7105,7 @@ which is greater than (1 -3)."
"Return the first non-zero element of LST, which is a list of integers.
If all LST elements are zeros or LST is nil, return zero."
+ (declare (pure t) (side-effect-free t))
(while (and lst (zerop (car lst)))
(setq lst (cdr lst)))
(if lst
@@ -6757,6 +7122,7 @@ etc. That is, the trailing \".0\"s are insignificant. Also, version
string \"1\" is higher (newer) than \"1pre\", which is higher than \"1beta\",
which is higher than \"1alpha\", which is higher than \"1snapshot\".
Also, \"-GIT\", \"-CVS\" and \"-NNN\" are treated as snapshot versions."
+ (declare (side-effect-free t))
(version-list-< (version-to-list v1) (version-to-list v2)))
(defun version<= (v1 v2)
@@ -6767,6 +7133,7 @@ etc. That is, the trailing \".0\"s are insignificant. Also, version
string \"1\" is higher (newer) than \"1pre\", which is higher than \"1beta\",
which is higher than \"1alpha\", which is higher than \"1snapshot\".
Also, \"-GIT\", \"-CVS\" and \"-NNN\" are treated as snapshot versions."
+ (declare (side-effect-free t))
(version-list-<= (version-to-list v1) (version-to-list v2)))
(defun version= (v1 v2)
@@ -6777,6 +7144,7 @@ etc. That is, the trailing \".0\"s are insignificant. Also, version
string \"1\" is higher (newer) than \"1pre\", which is higher than \"1beta\",
which is higher than \"1alpha\", which is higher than \"1snapshot\".
Also, \"-GIT\", \"-CVS\" and \"-NNN\" are treated as snapshot versions."
+ (declare (side-effect-free t))
(version-list-= (version-to-list v1) (version-to-list v2)))
(defvar package--builtin-versions
@@ -6880,6 +7248,7 @@ returned list are in the same order as in TREE.
\(flatten-tree \\='(1 (2 . 3) nil (4 5 (6)) 7))
=> (1 2 3 4 5 6 7)"
+ (declare (side-effect-free error-free))
(let (elems)
(while (consp tree)
(let ((elem (pop tree)))
@@ -6898,7 +7267,11 @@ returned list are in the same order as in TREE.
"Trim STRING of leading string matching REGEXP.
REGEXP defaults to \"[ \\t\\n\\r]+\"."
- (if (string-match (concat "\\`\\(?:" (or regexp "[ \t\n\r]+") "\\)") string)
+ (declare (important-return-value t))
+ (if (string-match (if regexp
+ (concat "\\`\\(?:" regexp "\\)")
+ "\\`[ \t\n\r]+")
+ string)
(substring string (match-end 0))
string))
@@ -6906,7 +7279,10 @@ REGEXP defaults to \"[ \\t\\n\\r]+\"."
"Trim STRING of trailing string matching REGEXP.
REGEXP defaults to \"[ \\t\\n\\r]+\"."
- (let ((i (string-match-p (concat "\\(?:" (or regexp "[ \t\n\r]+") "\\)\\'")
+ (declare (side-effect-free t))
+ (let ((i (string-match-p (if regexp
+ (concat "\\(?:" regexp "\\)\\'")
+ "[ \t\n\r]+\\'")
string)))
(if i (substring string 0 i) string)))
@@ -6914,6 +7290,7 @@ REGEXP defaults to \"[ \\t\\n\\r]+\"."
"Trim STRING of leading and trailing strings matching TRIM-LEFT and TRIM-RIGHT.
TRIM-LEFT and TRIM-RIGHT default to \"[ \\t\\n\\r]+\"."
+ (declare (important-return-value t))
(string-trim-left (string-trim-right string trim-right) trim-left))
;; The initial anchoring is for better performance in searching matches.
@@ -6977,6 +7354,7 @@ sentence (see Info node `(elisp) Documentation Tips')."
"Return OBJECT as a list.
If OBJECT is already a list, return OBJECT itself. If it's
not a list, return a one-element list containing OBJECT."
+ (declare (side-effect-free error-free))
(if (listp object)
object
(list object)))
@@ -6992,27 +7370,17 @@ string will be displayed only if BODY takes longer than TIMEOUT seconds.
(lambda ()
,@body)))
-(defun function-alias-p (func &optional noerror)
+(defun function-alias-p (func &optional _noerror)
"Return nil if FUNC is not a function alias.
-If FUNC is a function alias, return the function alias chain.
-
-If the function alias chain contains loops, an error will be
-signaled. If NOERROR, the non-loop parts of the chain is returned."
- (declare (side-effect-free t))
- (let ((chain nil)
- (orig-func func))
- (nreverse
- (catch 'loop
- (while (and (symbolp func)
- (setq func (symbol-function func))
- (symbolp func))
- (when (or (memq func chain)
- (eq func orig-func))
- (if noerror
- (throw 'loop chain)
- (signal 'cyclic-function-indirection (list orig-func))))
- (push func chain))
- chain))))
+If FUNC is a function alias, return the function alias chain."
+ (declare (advertised-calling-convention (func) "30.1")
+ (side-effect-free error-free))
+ (let ((chain nil))
+ (while (and (symbolp func)
+ (setq func (symbol-function func))
+ (symbolp func))
+ (push func chain))
+ (nreverse chain)))
(defun readablep (object)
"Say whether OBJECT has a readable syntax.
@@ -7062,6 +7430,7 @@ is inserted before adjusting the number of empty lines."
If OMIT-NULLS, empty lines will be removed from the results.
If KEEP-NEWLINES, don't strip trailing newlines from the result
lines."
+ (declare (side-effect-free t))
(if (equal string "")
(if omit-nulls
nil
@@ -7090,13 +7459,15 @@ lines."
(setq start (length string)))))
(nreverse lines))))
-(defun buffer-match-p (condition buffer-or-name &optional arg)
+(defvar buffer-match-p--past-warnings nil)
+
+(defun buffer-match-p (condition buffer-or-name &rest args)
"Return non-nil if BUFFER-OR-NAME matches CONDITION.
CONDITION is either:
- the symbol t, to always match,
- the symbol nil, which never matches,
- a regular expression, to match a buffer name,
-- a predicate function that takes BUFFER-OR-NAME and ARG as
+- a predicate function that takes BUFFER-OR-NAME plus ARGS 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:
@@ -7121,9 +7492,18 @@ CONDITION is either:
((pred stringp)
(string-match-p condition (buffer-name buffer)))
((pred functionp)
- (if (eq 1 (cdr (func-arity condition)))
- (funcall condition buffer-or-name)
- (funcall condition buffer-or-name arg)))
+ (if (cdr args)
+ ;; New in Emacs>29.1. no need for compatibility hack.
+ (apply condition buffer-or-name args)
+ (condition-case-unless-debug err
+ (apply condition buffer-or-name args)
+ (wrong-number-of-arguments
+ (unless (member condition
+ buffer-match-p--past-warnings)
+ (message "%s" (error-message-string err))
+ (push condition buffer-match-p--past-warnings))
+ (apply condition buffer-or-name
+ (if args nil '(nil)))))))
(`(major-mode . ,mode)
(eq
(buffer-local-value 'major-mode buffer)
@@ -7145,20 +7525,42 @@ CONDITION is either:
(throw 'match t)))))))
(funcall match (list condition))))
-(defun match-buffers (condition &optional buffers arg)
+(defun match-buffers (condition &optional buffers &rest args)
"Return a list of buffers that match CONDITION, or nil if none match.
See `buffer-match-p' for various supported CONDITIONs.
By default all buffers are checked, but the optional
argument BUFFERS can restrict that: its value should be
an explicit list of buffers to check.
-Optional argument ARG is passed to `buffer-match-p', for
+Optional arguments ARGS are passed to `buffer-match-p', for
predicate conditions in CONDITION."
(let (bufs)
(dolist (buf (or buffers (buffer-list)))
- (when (buffer-match-p condition (get-buffer buf) arg)
+ (when (apply #'buffer-match-p condition (get-buffer buf) args)
(push buf bufs)))
bufs))
+(defmacro handler-bind (handlers &rest body)
+ "Setup error HANDLERS around execution of BODY.
+HANDLERS is a list of (CONDITIONS HANDLER) where
+CONDITIONS should be a list of condition names (symbols) or
+a single condition name, and HANDLER is a form whose evaluation
+returns a function.
+When an error is signaled during execution of BODY, if that
+error matches CONDITIONS, then the associated HANDLER
+function is called with the error object as argument.
+HANDLERs can either transfer the control via a non-local exit,
+or return normally. If a handler returns normally, the search for an
+error handler continues from where it left off."
+ ;; FIXME: Completion support as in `condition-case'?
+ (declare (indent 1) (debug ((&rest (sexp form)) body)))
+ (let ((args '()))
+ (dolist (cond+handler handlers)
+ (let ((handler (car (cdr cond+handler)))
+ (conds (car cond+handler)))
+ (push `',(ensure-list conds) args)
+ (push handler args)))
+ `(handler-bind-1 (lambda () ,@body) ,@(nreverse args))))
+
(defmacro with-memoization (place &rest code)
"Return the value of CODE and stash it in PLACE.
If PLACE's value is non-nil, then don't bother evaluating CODE
diff --git a/lisp/svg.el b/lisp/svg.el
index b7728ca9c68..f2eb2ec66dd 100644
--- a/lisp/svg.el
+++ b/lisp/svg.el
@@ -8,6 +8,9 @@
;; Version: 1.1
;; Package-Requires: ((emacs "25"))
+;; This is a GNU ELPA :core package. Avoid functionality that is not
+;; compatible with the version of Emacs recorded above.
+
;; This file is part of GNU Emacs.
;; GNU Emacs is free software: you can redistribute it and/or modify
diff --git a/lisp/tab-bar.el b/lisp/tab-bar.el
index 9383baf810a..fa22500a04e 100644
--- a/lisp/tab-bar.el
+++ b/lisp/tab-bar.el
@@ -31,13 +31,8 @@
;;; Code:
-(eval-when-compile
- (require 'cl-lib)
- (require 'seq)
- (require 'icons))
-
-(autoload 'cl--set-substring "cl-lib")
-
+(eval-when-compile (require 'icons))
+(eval-when-compile (require 'cl-lib))
(defgroup tab-bar nil
"Frame-local tabs."
@@ -107,7 +102,7 @@ For easier selection of tabs by their numbers, consider customizing
(const hyper)
(const super)
(const alt))
- :initialize 'custom-initialize-default
+ :initialize #'custom-initialize-default
:set (lambda (sym val)
(set-default sym val)
;; Reenable the tab-bar with new keybindings
@@ -118,23 +113,23 @@ For easier selection of tabs by their numbers, consider customizing
:version "27.1")
(defun tab-bar--define-keys ()
- "Install key bindings for switching between tabs if the user has configured them."
+ "Install key bindings to switch between tabs if so configured."
(when tab-bar-select-tab-modifiers
(global-set-key (vector (append tab-bar-select-tab-modifiers (list ?0)))
- 'tab-recent)
+ #'tab-recent)
(dotimes (i 8)
(global-set-key (vector (append tab-bar-select-tab-modifiers
(list (+ i 1 ?0))))
- 'tab-bar-select-tab))
+ #'tab-bar-select-tab))
(global-set-key (vector (append tab-bar-select-tab-modifiers (list ?9)))
- 'tab-last))
+ #'tab-last))
;; Don't override user customized key bindings
(unless (global-key-binding [(control tab)])
- (global-set-key [(control tab)] 'tab-next))
+ (global-set-key [(control tab)] #'tab-next))
(unless (global-key-binding [(control shift tab)])
- (global-set-key [(control shift tab)] 'tab-previous))
+ (global-set-key [(control shift tab)] #'tab-previous))
(unless (global-key-binding [(control shift iso-lefttab)])
- (global-set-key [(control shift iso-lefttab)] 'tab-previous))
+ (global-set-key [(control shift iso-lefttab)] #'tab-previous))
;; Replace default value with a condition that supports displaying
;; global-mode-string in the tab bar instead of the mode line.
@@ -159,9 +154,14 @@ For easier selection of tabs by their numbers, consider customizing
(defun tab-bar--load-buttons ()
"Load the icons for the tab buttons."
(require 'icons)
+ (declare-function icon-string "icons" (name))
+ (declare-function iconp "icons" (object))
+ (declare-function icons--register "icons")
(unless (iconp 'tab-bar-new)
(define-icon tab-bar-new nil
- `((image "tabs/new.xpm"
+ `((image "symbols/plus_16.svg" "tabs/new.xpm"
+ :face shadow
+ :height (1 . em)
:margin ,tab-bar-button-margin
:ascent center)
;; (emoji "➕")
@@ -174,7 +174,9 @@ For easier selection of tabs by their numbers, consider customizing
(unless (iconp 'tab-bar-close)
(define-icon tab-bar-close nil
- `((image "tabs/close.xpm"
+ `((image "symbols/cross_16.svg" "tabs/close.xpm"
+ :face shadow
+ :height (1 . em)
:margin ,tab-bar-button-margin
:ascent center)
;; (emoji " ❌")
@@ -188,7 +190,11 @@ For easier selection of tabs by their numbers, consider customizing
(unless (iconp 'tab-bar-menu-bar)
(define-icon tab-bar-menu-bar nil
- '(;; (emoji "🍔")
+ `((image "symbols/menu_16.svg"
+ :height (1 . em)
+ :margin ,tab-bar-button-margin
+ :ascent center)
+ ;; (emoji "🍔")
(symbol "☰")
(text "Menu" :face tab-bar-tab-inactive))
"Icon for the menu bar."
@@ -229,7 +235,8 @@ a list of frames to update."
;; Update `default-frame-alist'
(when (eq frames t)
(setq default-frame-alist
- (cons (cons 'tab-bar-lines (if (and tab-bar-mode (eq tab-bar-show t)) 1 0))
+ (cons (cons 'tab-bar-lines
+ (if (and tab-bar-mode (eq tab-bar-show t)) 1 0))
(assq-delete-all 'tab-bar-lines default-frame-alist)))))
(define-minor-mode tab-bar-mode
@@ -281,7 +288,8 @@ It returns a list of the form (KEY KEY-BINDING CLOSE-P), where:
;; This code is used when you click the mouse in the tab bar
;; on a console which has no window system but does have a mouse.
(let* ((x-position (car (posn-x-y posn)))
- (keymap (lookup-key (cons 'keymap (nreverse (current-active-maps))) [tab-bar]))
+ (keymap (lookup-key (cons 'keymap (nreverse (current-active-maps)))
+ [tab-bar]))
(column 0))
(when x-position
(catch 'done
@@ -338,10 +346,12 @@ only when you click on its \"x\" close button."
(unless (eq tab-number t)
(tab-bar-close-tab tab-number))))
-(defun tab-bar-mouse-context-menu (event)
- "Pop up the context menu for the tab on which you click."
+(defun tab-bar-mouse-context-menu (event &optional posn)
+ "Pop up the context menu for the tab on which you click.
+EVENT is a mouse or touch screen event. POSN is nil or the
+position of EVENT."
(interactive "e")
- (let* ((item (tab-bar--event-to-item (event-start event)))
+ (let* ((item (tab-bar--event-to-item (or posn (event-start event))))
(tab-number (tab-bar--key-to-number (nth 0 item)))
(menu (make-sparse-keymap (propertize "Context Menu" 'hide t))))
@@ -394,6 +404,80 @@ at the mouse-down event to the position at mouse-up event."
(tab-bar-move-tab-to
(if (null to) (1+ (tab-bar--current-tab-index)) to) from))))
+
+
+;;; Tab bar touchscreen support.
+
+(declare-function touch-screen-track-tap "touch-screen.el")
+
+(defun tab-bar-handle-timeout ()
+ "Handle a touch-screen timeout on the tab bar.
+Beep, then throw to `context-menu' and return."
+ (beep)
+ (throw 'context-menu 'context-menu))
+
+(defvar touch-screen-delay)
+
+(defun tab-bar-touchscreen-begin (event)
+ "Handle a touchscreen begin EVENT on the tab bar.
+
+Determine where the touch was made. If it was made on a tab
+itself, start a timer set to go off after a certain amount of
+time, and wait for the touch point to be released, and either
+display a context menu or select a tab as appropriate.
+
+Otherwise, if it was made on a button, close or create a tab as
+appropriate."
+ (interactive "e")
+ (let* ((posn (cdadr event))
+ (item (tab-bar--event-to-item posn))
+ (number (tab-bar--key-to-number (car item)))
+ timer)
+ (when (eq (catch 'context-menu
+ (cond ((integerp number)
+ ;; The touch began on a tab. Start a context
+ ;; menu timer and start tracking the tap.
+ (unwind-protect
+ (progn
+ (setq timer (run-at-time touch-screen-delay nil
+ #'tab-bar-handle-timeout))
+ ;; Now wait for the tap to complete.
+ (when (touch-screen-track-tap event)
+ ;; And select the tab, or close it,
+ ;; depending on whether or not the
+ ;; close button was pressed.
+ (if (caddr item)
+ (tab-bar-close-tab number)
+ (tab-bar-select-tab number))))
+ ;; Cancel the timer.
+ (cancel-timer timer)))
+ ((and (memq (car item) '(add-tab history-back
+ history-forward))
+ (functionp (cadr item)))
+ ;; This is some kind of button. Wait for the
+ ;; tap to complete and press it.
+ (when (touch-screen-track-tap event)
+ (call-interactively (cadr item))))
+ (t
+ ;; The touch began on the tab bar itself.
+ ;; Start a context menu timer and start
+ ;; tracking the tap, but don't do anything
+ ;; afterwards.
+ (unwind-protect
+ (progn
+ (setq timer (run-at-time touch-screen-delay nil
+ #'tab-bar-handle-timeout))
+ ;; Now wait for the tap to complete.
+ (touch-screen-track-tap event))
+ ;; Cancel the timer.
+ (cancel-timer timer)))))
+ 'context-menu)
+ ;; Display the context menu in response to a time out waiting
+ ;; for the tap to complete.
+ (tab-bar-mouse-context-menu event posn))))
+
+
+
(defvar-keymap tab-bar-map
:doc "Keymap for the commands used on the tab bar."
"<down-mouse-1>" #'tab-bar-mouse-down-1
@@ -415,7 +499,8 @@ at the mouse-down event to the position at mouse-up event."
"S-<wheel-up>" #'tab-bar-move-tab-backward
"S-<wheel-down>" #'tab-bar-move-tab
"S-<wheel-left>" #'tab-bar-move-tab-backward
- "S-<wheel-right>" #'tab-bar-move-tab)
+ "S-<wheel-right>" #'tab-bar-move-tab
+ "<touchscreen-begin>" #'tab-bar-touchscreen-begin)
(global-set-key [tab-bar]
`(menu-item ,(purecopy "tab bar") ,(make-sparse-keymap)
@@ -480,7 +565,7 @@ you can use the command `toggle-frame-tab-bar'."
:type '(choice (const :tag "Always" t)
(const :tag "When more than one tab" 1)
(const :tag "Never" nil))
- :initialize 'custom-initialize-default
+ :initialize #'custom-initialize-default
:set (lambda (sym val)
(set-default sym val)
(if val
@@ -531,7 +616,7 @@ to get the group name."
"If non-nil, show the \"New tab\" button in the tab bar.
When this is nil, you can create new tabs with \\[tab-new]."
:type 'boolean
- :initialize 'custom-initialize-default
+ :initialize #'custom-initialize-default
:set (lambda (sym val)
(set-default sym val)
(force-mode-line-update))
@@ -552,7 +637,7 @@ If nil, don't show it at all."
(const :tag "On selected tab" selected)
(const :tag "On non-selected tabs" non-selected)
(const :tag "None" nil))
- :initialize 'custom-initialize-default
+ :initialize #'custom-initialize-default
:set (lambda (sym val)
(set-default sym val)
(force-mode-line-update))
@@ -576,7 +661,7 @@ If nil, don't show it at all."
This helps to select the tab by its number using `tab-bar-select-tab'
and `tab-bar-select-tab-modifiers'."
:type 'boolean
- :initialize 'custom-initialize-default
+ :initialize #'custom-initialize-default
:set (lambda (sym val)
(set-default sym val)
(force-mode-line-update))
@@ -606,7 +691,7 @@ from all windows in the window configuration."
(const :tag "All window buffers"
tab-bar-tab-name-all)
(function :tag "Function"))
- :initialize 'custom-initialize-default
+ :initialize #'custom-initialize-default
:set (lambda (sym val)
(set-default sym val)
(force-mode-line-update))
@@ -615,13 +700,18 @@ from all windows in the window configuration."
(defun tab-bar-tab-name-current ()
"Generate tab name from the buffer of the selected window."
- (buffer-name (window-buffer (minibuffer-selected-window))))
+ ;; `minibuffer-selected-window' loses its original window
+ ;; after switching to another tab while the minibuffer was active,
+ ;; so get the most recently used non-minibuffer window.
+ (buffer-name (window-buffer (or (minibuffer-selected-window)
+ (and (window-minibuffer-p)
+ (get-mru-window))))))
(defun tab-bar-tab-name-current-with-count ()
"Generate tab name from the buffer of the selected window.
Also add the number of windows in the window configuration."
(let ((count (length (window-list-1 nil 'nomini)))
- (name (window-buffer (minibuffer-selected-window))))
+ (name (tab-bar-tab-name-current)))
(if (> count 1)
(format "%s (%d)" name count)
(format "%s" name))))
@@ -648,7 +738,7 @@ to `tab-bar-tab-name-truncated'."
"Generate tab name from the buffer of the selected window.
Truncate it to the length specified by `tab-bar-tab-name-truncated-max'.
Append ellipsis `tab-bar-tab-name-ellipsis' in this case."
- (let ((tab-name (buffer-name (window-buffer (minibuffer-selected-window)))))
+ (let ((tab-name (tab-bar-tab-name-current)))
(if (< (length tab-name) tab-bar-tab-name-truncated-max)
tab-name
(propertize (truncate-string-to-width
@@ -691,6 +781,31 @@ Return its existing value or a new value."
(set-frame-parameter frame 'tabs tabs))
+(defun tab-bar-tab-name-format-truncated (name _tab _i)
+ "Truncate the tab name.
+The maximal length is specified by `tab-bar-tab-name-truncated-max'.
+Append ellipsis `tab-bar-tab-name-ellipsis' at the end."
+ (if (< (length name) tab-bar-tab-name-truncated-max)
+ name
+ (truncate-string-to-width
+ name tab-bar-tab-name-truncated-max nil nil
+ tab-bar-tab-name-ellipsis)))
+
+(defun tab-bar-tab-name-format-hints (name _tab i)
+ "Show absolute numbers on tabs in the tab bar before the tab name.
+It has effect when `tab-bar-tab-hints' is non-nil."
+ (if tab-bar-tab-hints (concat (format "%d " i) name) name))
+
+(defun tab-bar-tab-name-format-close-button (name tab _i)
+ "Show the tab close button.
+The variable `tab-bar-close-button-show' defines when to show it."
+ (if (and tab-bar-close-button-show
+ (not (eq tab-bar-close-button-show
+ (if (eq (car tab) 'current-tab) 'non-selected 'selected)))
+ tab-bar-close-button)
+ (concat name tab-bar-close-button)
+ name))
+
(defcustom tab-bar-tab-face-function #'tab-bar-tab-face-default
"Function to define a tab face.
Function gets one argument: a tab."
@@ -701,30 +816,50 @@ Function gets one argument: a tab."
(defun tab-bar-tab-face-default (tab)
(if (eq (car tab) 'current-tab) 'tab-bar-tab 'tab-bar-tab-inactive))
+(defun tab-bar-tab-name-format-face (name tab _i)
+ "Apply the face to the tab name.
+It uses the function `tab-bar-tab-face-function'."
+ (add-face-text-property
+ 0 (length name) (funcall tab-bar-tab-face-function tab) t name)
+ name)
+
+(defcustom tab-bar-tab-name-format-functions
+ '(tab-bar-tab-name-format-hints
+ tab-bar-tab-name-format-close-button
+ tab-bar-tab-name-format-face)
+ "Functions called to modify the tab name.
+Each function is called with three arguments: the name returned
+by the previously called modifier, the tab and its number.
+It should return the formatted tab name to display in the tab bar."
+ :type '(repeat
+ (choice (function-item tab-bar-tab-name-format-truncated)
+ (function-item tab-bar-tab-name-format-hints)
+ (function-item tab-bar-tab-name-format-close-button)
+ (function-item tab-bar-tab-name-format-face)
+ (function :tag "Custom function")))
+ :group 'tab-bar
+ :version "30.1")
+
+(defun tab-bar-tab-name-format-default (tab i)
+ (let ((name (copy-sequence (alist-get 'name tab))))
+ (run-hook-wrapped 'tab-bar-tab-name-format-functions
+ (lambda (fun)
+ (setq name (funcall fun name tab i))
+ nil))
+ name))
+
(defcustom tab-bar-tab-name-format-function #'tab-bar-tab-name-format-default
"Function to format a tab name.
Function gets two arguments, the tab and its number, and should return
the formatted tab name to display in the tab bar."
:type 'function
- :initialize 'custom-initialize-default
+ :initialize #'custom-initialize-default
:set (lambda (sym val)
(set-default sym val)
(force-mode-line-update))
:group 'tab-bar
:version "28.1")
-(defun tab-bar-tab-name-format-default (tab i)
- (let ((current-p (eq (car tab) 'current-tab)))
- (propertize
- (concat (if tab-bar-tab-hints (format "%d " i) "")
- (alist-get 'name tab)
- (or (and tab-bar-close-button-show
- (not (eq tab-bar-close-button-show
- (if current-p 'non-selected 'selected)))
- tab-bar-close-button)
- ""))
- 'face (funcall tab-bar-tab-face-function tab))))
-
(defcustom tab-bar-format '(tab-bar-format-history
tab-bar-format-tabs
tab-bar-separator
@@ -755,7 +890,7 @@ of the mode line. Replacing `tab-bar-format-tabs' with
tab-bar-format-add-tab
tab-bar-format-align-right
tab-bar-format-global)
- :initialize 'custom-initialize-default
+ :initialize #'custom-initialize-default
:set (lambda (sym val)
(set-default sym val)
(force-mode-line-update))
@@ -782,7 +917,7 @@ Used by `tab-bar-format-menu-bar'."
(defun tab-bar-format-menu-bar ()
"Produce the Menu button for the tab bar that shows the menu bar."
`((menu-bar menu-item ,tab-bar-menu-bar-button
- tab-bar-menu-bar :help "Menu Bar")))
+ tab-bar-menu-bar :help "Menu bar")))
(defun tab-bar-format-history ()
"Produce back and forward buttons for the tab bar.
@@ -809,15 +944,16 @@ You can hide these buttons by customizing `tab-bar-format' and removing
menu-item
,(funcall tab-bar-tab-name-format-function tab i)
ignore
- :help "Current tab")))
+ :help ,(alist-get 'name tab))))
(t
`((,(intern (format "tab-%i" i))
menu-item
,(funcall tab-bar-tab-name-format-function tab i)
,(alist-get 'binding tab)
- :help "Click to visit tab"))))
+ :help ,(alist-get 'name tab)))))
(when (alist-get 'close-binding tab)
- `((,(if (eq (car tab) 'current-tab) 'C-current-tab (intern (format "C-tab-%i" i)))
+ `((,(if (eq (car tab) 'current-tab) 'C-current-tab
+ (intern (format "C-tab-%i" i)))
menu-item ""
,(alist-get 'close-binding tab))))))
@@ -834,7 +970,7 @@ You can hide these buttons by customizing `tab-bar-format' and removing
"Function to get a tab group name.
Function gets one argument: a tab."
:type 'function
- :initialize 'custom-initialize-default
+ :initialize #'custom-initialize-default
:set (lambda (sym val)
(set-default sym val)
(force-mode-line-update))
@@ -850,7 +986,7 @@ Function gets three arguments, a tab with a group name, its number, and
an optional value that is non-nil when the tab is from the current group.
It should return the formatted tab group name to display in the tab bar."
:type 'function
- :initialize 'custom-initialize-default
+ :initialize #'custom-initialize-default
:set (lambda (sym val)
(set-default sym val)
(force-mode-line-update))
@@ -921,7 +1057,8 @@ when the tab is current. Return the result as a keymap."
(when (and (not (equal previous-group tab-group)) tab-group)
(tab-bar--format-tab-group tab i t))
;; Override default tab faces to use group faces
- (let ((tab-bar-tab-face-function tab-bar-tab-group-face-function))
+ (let ((tab-bar-tab-face-function
+ tab-bar-tab-group-face-function))
(tab-bar--format-tab tab i))))
;; Show first tab of other groups with a group name
((not (equal previous-group tab-group))
@@ -950,7 +1087,8 @@ when the tab is current. Return the result as a keymap."
;; when windows are split horizontally (bug#59620)
(if (window-system)
`(space :align-to (- right (,hpos)))
- `(space :align-to (,(- (frame-inner-width) hpos)))))))
+ `(space :align-to (,(- (frame-inner-width)
+ hpos)))))))
`((align-right menu-item ,str ignore))))
(defun tab-bar-format-global ()
@@ -1020,7 +1158,7 @@ This variable has effect only when `tab-bar-auto-width' is non-nil."
(const :tag "No limit" nil)
(list (integer :tag "Max width (pixels)" :value 220)
(integer :tag "Max width (chars)" :value 20)))
- :initialize 'custom-initialize-default
+ :initialize #'custom-initialize-default
:set (lambda (sym val)
(set-default sym val)
(setq tab-bar--auto-width-hash nil))
@@ -1089,17 +1227,18 @@ tab bar might wrap to the second line when it shouldn't.")
curr-width)
(cond
((< prev-width width)
- (let* ((space (apply 'propertize " "
+ (let* ((space (apply #'propertize " "
(text-properties-at 0 name)))
(ins-pos (- len (if close-p
(length tab-bar-close-button)
0)))
(prev-name name))
(while continue
- (setf (substring name ins-pos ins-pos) space)
+ (setq name (concat (substring name 0 ins-pos)
+ space
+ (substring name ins-pos)))
(setq curr-width (string-pixel-width name))
- (if (and (< curr-width width)
- (> curr-width prev-width))
+ (if (< curr-width width)
(setq prev-width curr-width
prev-name name)
;; Set back a shorter name
@@ -1109,10 +1248,11 @@ tab bar might wrap to the second line when it shouldn't.")
(let ((del-pos1 (if close-p -2 -1))
(del-pos2 (if close-p -1 nil)))
(while continue
- (setf (substring name del-pos1 del-pos2) "")
+ (setq name (concat (substring name 0 del-pos1)
+ (and del-pos2
+ (substring name del-pos2))))
(setq curr-width (string-pixel-width name))
- (if (and (> curr-width width)
- (< curr-width prev-width))
+ (if (> curr-width width)
(setq prev-width curr-width)
(setq continue nil)))
(let* ((len (length name))
@@ -1162,7 +1302,7 @@ tab bar might wrap to the second line when it shouldn't.")
(ws . ,(window-state-get
(frame-root-window (or frame (selected-frame))) 'writable))
(wc . ,(current-window-configuration))
- (wc-point . ,(point-marker))
+ (wc-point . ,(copy-marker (window-point) window-point-insertion-type))
(wc-bl . ,bl)
(wc-bbl . ,bbl)
,@(when tab-bar-history-mode
@@ -1245,6 +1385,74 @@ inherits the current tab's `explicit-name' parameter."
tabs))))
+(defcustom tab-bar-tab-post-select-functions nil
+ "List of functions to call after selecting a tab.
+Two arguments are supplied: the previous tab that was selected before,
+and the newly selected tab."
+ :type '(repeat function)
+ :group 'tab-bar
+ :version "30.1")
+
+(defcustom tab-bar-select-restore-windows #'tab-bar-select-restore-windows
+ "Function called when selecting a tab to handle windows whose buffer was killed.
+When a tab-bar tab displays a window whose buffer was killed since
+this tab was last selected, this function determines what to do with
+that window. By default, either a random buffer is displayed instead of
+the killed buffer, or the window gets deleted. However, with the help
+of `window-restore-killed-buffer-windows' it's possible to handle such
+situations better by displaying an information about the killed buffer."
+ :type '(choice (const :tag "No special handling" nil)
+ (const :tag "Show placeholder buffers"
+ tab-bar-select-restore-windows)
+ (function :tag "Function"))
+ :group 'tab-bar
+ :version "30.1")
+
+(defun tab-bar-select-restore-windows (_frame windows _type)
+ "Display a placeholder buffer in the window whose buffer was killed.
+A button in the window allows to restore the killed buffer,
+if it was visiting a file."
+ (dolist (quad windows)
+ (when (window-live-p (nth 0 quad))
+ (let* ((window (nth 0 quad))
+ (old-buffer (nth 1 quad))
+ (file (when (bufferp old-buffer)
+ (buffer-file-name old-buffer)))
+ (name (or file
+ (and (bufferp old-buffer)
+ (fboundp 'buffer-last-name)
+ (buffer-last-name old-buffer))
+ old-buffer))
+ (new-buffer (generate-new-buffer
+ (format "*Old buffer %s*" name))))
+ (with-current-buffer new-buffer
+ (set-auto-mode)
+ (insert (format-message "This window displayed the %s `%s'.\n"
+ (if file "file" "buffer")
+ name))
+ (when file
+ (insert-button
+ "[Restore]" 'action
+ (lambda (_button)
+ (set-window-buffer window (find-file-noselect file))
+ (set-window-start window (nth 2 quad) t)
+ (set-window-point window (nth 3 quad))))
+ (insert "\n"))
+ (goto-char (point-min))
+ (setq buffer-read-only t)
+ (set-window-buffer window new-buffer))))))
+
+(defvar tab-bar-minibuffer-restore-tab nil
+ "Tab number for `tab-bar-minibuffer-restore-tab'.")
+
+(defun tab-bar-minibuffer-restore-tab ()
+ "Switch back to the tab where the minibuffer was activated.
+This is necessary to prepare the same window configuration where
+original windows were saved and will be restored. This function
+is used only when `read-minibuffer-restore-windows' is non-nil."
+ (when tab-bar-minibuffer-restore-tab
+ (tab-bar-select-tab tab-bar-minibuffer-restore-tab)))
+
(defun tab-bar-select-tab (&optional tab-number)
"Switch to the tab by its absolute position TAB-NUMBER in the tab bar.
When this command is bound to a numeric key (with a key prefix or modifier key
@@ -1270,11 +1478,19 @@ Negative TAB-NUMBER counts tabs from the end of the tab bar."
(to-index (1- (max 1 (min to-number (length tabs)))))
(minibuffer-was-active (minibuffer-window-active-p (selected-window))))
+ (when (and read-minibuffer-restore-windows minibuffer-was-active
+ (not tab-bar-minibuffer-restore-tab))
+ (setq-local tab-bar-minibuffer-restore-tab (1+ from-index))
+ (add-hook 'minibuffer-exit-hook 'tab-bar-minibuffer-restore-tab nil t))
+
(unless (eq from-index to-index)
(let* ((from-tab (tab-bar--tab))
(to-tab (nth to-index tabs))
(wc (alist-get 'wc to-tab))
- (ws (alist-get 'ws to-tab)))
+ (ws (alist-get 'ws to-tab))
+ (window-restore-killed-buffer-windows
+ (or tab-bar-select-restore-windows
+ window-restore-killed-buffer-windows)))
;; During the same session, use window-configuration to switch
;; tabs, because window-configurations are more reliable
@@ -1299,13 +1515,7 @@ Negative TAB-NUMBER counts tabs from the end of the tab bar."
;; set-window-configuration does not restore the value of
;; point in the current buffer, so restore it separately.
(when (and (markerp wc-point)
- (marker-buffer wc-point)
- ;; FIXME: After dired-revert, marker relocates to 1.
- ;; window-configuration restores point to global point
- ;; in this dired buffer, not to its window point,
- ;; but this is slightly better than 1.
- ;; Maybe better to save dired-filename in each window?
- (not (eq 1 (marker-position wc-point))))
+ (marker-buffer wc-point))
(goto-char wc-point))
(when wc-bl (set-frame-parameter nil 'buffer-list wc-bl))
@@ -1313,11 +1523,13 @@ Negative TAB-NUMBER counts tabs from the end of the tab bar."
(when tab-bar-history-mode
(puthash (selected-frame)
- (and (window-configuration-p (alist-get 'wc (car wc-history-back)))
+ (and (window-configuration-p
+ (alist-get 'wc (car wc-history-back)))
wc-history-back)
tab-bar-history-back)
(puthash (selected-frame)
- (and (window-configuration-p (alist-get 'wc (car wc-history-forward)))
+ (and (window-configuration-p
+ (alist-get 'wc (car wc-history-forward)))
wc-history-forward)
tab-bar-history-forward))))
@@ -1343,10 +1555,14 @@ Negative TAB-NUMBER counts tabs from the end of the tab bar."
(when from-index
(setf (nth from-index tabs) from-tab))
- (setf (nth to-index tabs) (tab-bar--current-tab-make (nth to-index tabs)))
+ (setf (nth to-index tabs)
+ (tab-bar--current-tab-make (nth to-index tabs)))
(unless tab-bar-mode
- (message "Selected tab '%s'" (alist-get 'name to-tab))))
+ (message "Selected tab '%s'" (alist-get 'name to-tab)))
+
+ (run-hook-with-args 'tab-bar-tab-post-select-functions
+ from-tab to-tab))
(force-mode-line-update))))
@@ -1410,7 +1626,7 @@ and rename it to NAME."
(tab-bar-new-tab)
(tab-bar-rename-tab name))))
-(defalias 'tab-bar-select-tab-by-name 'tab-bar-switch-to-tab)
+(defalias 'tab-bar-select-tab-by-name #'tab-bar-switch-to-tab)
(defun tab-bar-move-tab-to (to-number &optional from-number)
@@ -1425,7 +1641,8 @@ where argument addressing is relative."
(from-number (or from-number (1+ (tab-bar--current-tab-index tabs))))
(from-tab (nth (1- from-number) tabs))
(to-number (if to-number (prefix-numeric-value to-number) 1))
- (to-number (if (< to-number 0) (+ (length tabs) (1+ to-number)) to-number))
+ (to-number (if (< to-number 0) (+ (length tabs) (1+ to-number))
+ to-number))
(to-index (max 0 (min (1- to-number) (1- (length tabs))))))
(setq tabs (delq from-tab tabs))
(cl-pushnew from-tab (nthcdr to-index tabs))
@@ -1451,7 +1668,8 @@ Like `tab-bar-move-tab', but moves in the opposite direction."
(interactive "p")
(tab-bar-move-tab (- (or arg 1))))
-(defun tab-bar-move-tab-to-frame (arg &optional from-frame from-number to-frame to-number)
+(defun tab-bar-move-tab-to-frame (arg &optional from-frame from-number
+ to-frame to-number)
"Move tab from FROM-NUMBER position to new position at TO-NUMBER.
FROM-NUMBER defaults to the current tab number.
FROM-NUMBER and TO-NUMBER count from 1.
@@ -1467,7 +1685,8 @@ to which to move the tab; ARG defaults to 1."
(setq to-frame (next-frame to-frame))))
(unless (eq from-frame to-frame)
(let* ((from-tabs (funcall tab-bar-tabs-function from-frame))
- (from-number (or from-number (1+ (tab-bar--current-tab-index from-tabs))))
+ (from-number (or from-number
+ (1+ (tab-bar--current-tab-index from-tabs))))
(from-tab (nth (1- from-number) from-tabs))
(to-tabs (funcall tab-bar-tabs-function to-frame))
(to-index (max 0 (min (1- (or to-number 1)) (1- (length to-tabs))))))
@@ -1489,7 +1708,8 @@ to which to move the tab; ARG defaults to 1."
FROM-NUMBER defaults to the current tab (which happens interactively)."
(interactive (list (1+ (tab-bar--current-tab-index))))
(let* ((tabs (funcall tab-bar-tabs-function))
- (tab-index (1- (or from-number (1+ (tab-bar--current-tab-index tabs)))))
+ (tab-index (1- (or from-number
+ (1+ (tab-bar--current-tab-index tabs)))))
(tab-name (alist-get 'name (nth tab-index tabs)))
;; On some window managers, `make-frame' selects the new frame,
;; so previously selected frame is saved to `from-frame'.
@@ -1754,7 +1974,8 @@ for the last tab on a frame is determined by
;; Select another tab before deleting the current tab
(let ((to-index (or (if to-number (1- to-number))
(pcase tab-bar-close-tab-select
- ('left (1- (if (< current-index 1) 2 current-index)))
+ ('left (1- (if (< current-index 1) 2
+ current-index)))
('right (if (> (length tabs) (1+ current-index))
(1+ current-index)
(1- current-index)))
@@ -1779,7 +2000,8 @@ for the last tab on a frame is determined by
(force-mode-line-update)
(unless tab-bar-mode
- (message "Deleted tab and switched to %s" tab-bar-close-tab-select))))))
+ (message "Deleted tab and switched to %s"
+ tab-bar-close-tab-select))))))
(defun tab-bar-close-tab-by-name (name)
"Close the tab given its NAME.
@@ -1870,7 +2092,8 @@ If NAME is the empty string, then use the automatic name
function `tab-bar-tab-name-function'."
(interactive
(let* ((tabs (funcall tab-bar-tabs-function))
- (tab-number (or current-prefix-arg (1+ (tab-bar--current-tab-index tabs))))
+ (tab-number (or current-prefix-arg
+ (1+ (tab-bar--current-tab-index tabs))))
(tab-name (alist-get 'name (nth (1- tab-number) tabs))))
(list (read-from-minibuffer
"New name for tab (leave blank for automatic naming): "
@@ -2117,7 +2340,8 @@ and can restore them."
(unless (iconp 'tab-bar-back)
(define-icon tab-bar-back nil
- `((image "tabs/left-arrow.xpm"
+ `((image "symbols/chevron_left_16.svg" "tabs/left-arrow.xpm"
+ :height (1 . em)
:margin ,tab-bar-button-margin
:ascent center)
(text " < "))
@@ -2127,7 +2351,8 @@ and can restore them."
(unless (iconp 'tab-bar-forward)
(define-icon tab-bar-forward nil
- `((image "tabs/right-arrow.xpm"
+ `((image "symbols/chevron_right_16.svg" "tabs/right-arrow.xpm"
+ :height (1 . em)
:margin ,tab-bar-button-margin
:ascent center)
(text " > "))
@@ -2135,10 +2360,10 @@ and can restore them."
:version "29.1"))
(setq tab-bar-forward-button (icon-string 'tab-bar-forward))
- (add-hook 'pre-command-hook 'tab-bar--history-pre-change)
- (add-hook 'window-configuration-change-hook 'tab-bar--history-change))
- (remove-hook 'pre-command-hook 'tab-bar--history-pre-change)
- (remove-hook 'window-configuration-change-hook 'tab-bar--history-change)))
+ (add-hook 'pre-command-hook #'tab-bar--history-pre-change)
+ (add-hook 'window-configuration-change-hook #'tab-bar--history-change))
+ (remove-hook 'pre-command-hook #'tab-bar--history-pre-change)
+ (remove-hook 'window-configuration-change-hook #'tab-bar--history-change)))
;;; Non-graphical access to frame-local tabs (named window configurations)
@@ -2178,8 +2403,9 @@ For more information, see the function `tab-switcher'."
(tabs (sort tabs (lambda (a b) (< (alist-get 'time b)
(alist-get 'time a))))))
(with-current-buffer (get-buffer-create
- (format " *Tabs*<%s>" (or (frame-parameter nil 'window-id)
- (frame-parameter nil 'name))))
+ (format " *Tabs*<%s>"
+ (or (frame-parameter nil 'window-id)
+ (frame-parameter nil 'name))))
(setq buffer-read-only nil)
(erase-buffer)
(tab-switcher-mode)
@@ -2194,7 +2420,8 @@ For more information, see the function `tab-switcher'."
(propertize
(alist-get 'name tab)
'mouse-face 'highlight
- 'help-echo "mouse-2: select this window configuration"))
+ 'help-echo
+ "mouse-2: select this window configuration"))
'tab tab)))
(goto-char (point-min))
(goto-char (or (next-single-property-change (point) 'tab) (point-min)))
@@ -2270,8 +2497,8 @@ Interactively, ARG is the prefix numeric argument and defaults to 1."
(move-to-column tab-switcher-column))
(defun tab-switcher-unmark (&optional backup)
- "Cancel requested operations on window configuration on this line and move down.
-With prefix arg, move up instead."
+ "Cancel operations on window configuration on this line and move down.
+With prefix arg BACKUP, move up instead."
(interactive "P")
(beginning-of-line)
(move-to-column tab-switcher-column)
@@ -2282,7 +2509,7 @@ With prefix arg, move up instead."
(move-to-column tab-switcher-column))
(defun tab-switcher-backup-unmark ()
- "Move up one line and cancel requested operations on window configuration there."
+ "Move up one line and cancel operations on window configuration there."
(interactive)
(forward-line -1)
(tab-switcher-unmark)
@@ -2290,9 +2517,10 @@ With prefix arg, move up instead."
(move-to-column tab-switcher-column))
(defun tab-switcher-delete (&optional arg)
- "Mark window configuration on this line to be deleted by \\<tab-switcher-mode-map>\\[tab-switcher-execute] command.
+ "Mark window configuration on this line to be deleted.
Prefix arg says how many window configurations to delete.
-Negative arg means delete backwards."
+Negative arg means delete backwards.
+The deletion will be done by the \\<tab-switcher-mode-map>\\[tab-switcher-execute] command."
(interactive "p")
(let ((buffer-read-only nil))
(if (or (null arg) (= arg 0))
@@ -2310,8 +2538,9 @@ Negative arg means delete backwards."
(move-to-column tab-switcher-column)))
(defun tab-switcher-delete-backwards (&optional arg)
- "Mark window configuration on this line to be deleted by \\<tab-switcher-mode-map>\\[tab-switcher-execute] command.
-Then move up one line. Prefix arg means move that many lines."
+ "Mark window configuration on this line to be deleted.
+Then move up one line. Prefix arg means move that many lines.
+The deletion will be done by the \\<tab-switcher-mode-map>\\[tab-switcher-execute] command."
(interactive "p")
(tab-switcher-delete (- (or arg 1))))
@@ -2324,7 +2553,9 @@ Then move up one line. Prefix arg means move that many lines."
(tab-bar-tabs-set (delq tab (funcall tab-bar-tabs-function))))
(defun tab-switcher-execute ()
- "Delete window configurations marked with \\<tab-switcher-mode-map>\\[tab-switcher-delete] commands."
+ "Delete the marked window configurations.
+Use the \\<tab-switcher-mode-map>\\[tab-switcher-delete] commands
+to set those marks."
(interactive)
(save-excursion
(goto-char (point-min))
@@ -2370,7 +2601,8 @@ with those specified by the selected window configuration."
((framep all-frames) (list all-frames))
(t (list (selected-frame)))))
-(defun tab-bar-get-buffer-tab (buffer-or-name &optional all-frames ignore-current-tab all-tabs)
+(defun tab-bar-get-buffer-tab (buffer-or-name
+ &optional all-frames ignore-current-tab all-tabs)
"Return the tab that owns the window whose buffer is BUFFER-OR-NAME.
BUFFER-OR-NAME may be a buffer or a buffer name, and defaults to
the current buffer.
@@ -2546,7 +2778,7 @@ files will be visited."
(progn
(setq value (nreverse value))
(switch-to-buffer-other-tab (car value))
- (mapc 'switch-to-buffer (cdr value))
+ (mapc #'switch-to-buffer (cdr value))
value)
(switch-to-buffer-other-tab value))))
@@ -2588,26 +2820,26 @@ When `switch-to-buffer-obey-display-actions' is non-nil,
;;; Short aliases and keybindings
-(defalias 'tab-new 'tab-bar-new-tab)
-(defalias 'tab-new-to 'tab-bar-new-tab-to)
-(defalias 'tab-duplicate 'tab-bar-duplicate-tab)
-(defalias 'tab-detach 'tab-bar-detach-tab)
-(defalias 'tab-window-detach 'tab-bar-move-window-to-tab)
-(defalias 'tab-close 'tab-bar-close-tab)
-(defalias 'tab-close-other 'tab-bar-close-other-tabs)
-(defalias 'tab-close-group 'tab-bar-close-group-tabs)
-(defalias 'tab-undo 'tab-bar-undo-close-tab)
-(defalias 'tab-select 'tab-bar-select-tab)
-(defalias 'tab-switch 'tab-bar-switch-to-tab)
-(defalias 'tab-next 'tab-bar-switch-to-next-tab)
-(defalias 'tab-previous 'tab-bar-switch-to-prev-tab)
-(defalias 'tab-last 'tab-bar-switch-to-last-tab)
-(defalias 'tab-recent 'tab-bar-switch-to-recent-tab)
-(defalias 'tab-move 'tab-bar-move-tab)
-(defalias 'tab-move-to 'tab-bar-move-tab-to)
-(defalias 'tab-rename 'tab-bar-rename-tab)
-(defalias 'tab-group 'tab-bar-change-tab-group)
-(defalias 'tab-list 'tab-switcher)
+(defalias 'tab-new #'tab-bar-new-tab)
+(defalias 'tab-new-to #'tab-bar-new-tab-to)
+(defalias 'tab-duplicate #'tab-bar-duplicate-tab)
+(defalias 'tab-detach #'tab-bar-detach-tab)
+(defalias 'tab-window-detach #'tab-bar-move-window-to-tab)
+(defalias 'tab-close #'tab-bar-close-tab)
+(defalias 'tab-close-other #'tab-bar-close-other-tabs)
+(defalias 'tab-close-group #'tab-bar-close-group-tabs)
+(defalias 'tab-undo #'tab-bar-undo-close-tab)
+(defalias 'tab-select #'tab-bar-select-tab)
+(defalias 'tab-switch #'tab-bar-switch-to-tab)
+(defalias 'tab-next #'tab-bar-switch-to-next-tab)
+(defalias 'tab-previous #'tab-bar-switch-to-prev-tab)
+(defalias 'tab-last #'tab-bar-switch-to-last-tab)
+(defalias 'tab-recent #'tab-bar-switch-to-recent-tab)
+(defalias 'tab-move #'tab-bar-move-tab)
+(defalias 'tab-move-to #'tab-bar-move-tab-to)
+(defalias 'tab-rename #'tab-bar-rename-tab)
+(defalias 'tab-group #'tab-bar-change-tab-group)
+(defalias 'tab-list #'tab-switcher)
(keymap-set tab-prefix-map "n" #'tab-duplicate)
(keymap-set tab-prefix-map "N" #'tab-new-to)
diff --git a/lisp/tab-line.el b/lisp/tab-line.el
index c5dd95e20ec..cc60f94c9c5 100644
--- a/lisp/tab-line.el
+++ b/lisp/tab-line.el
@@ -28,7 +28,8 @@
;;; Code:
(require 'cl-lib)
-(require 'seq) ; tab-line.el is not pre-loaded so it's safe to use it here
+(require 'seq)
+(require 'icons)
(defgroup tab-line nil
@@ -137,33 +138,38 @@ function `tab-line-tab-face-group'."
(defvar-keymap tab-line-tab-map
:doc "Local keymap for `tab-line-mode' window tabs."
- "<tab-line> <down-mouse-1>" #'tab-line-select-tab
- "<tab-line> <mouse-2>" #'tab-line-close-tab
- "<tab-line> <down-mouse-3>" #'tab-line-tab-context-menu
+ "<tab-line> <down-mouse-1>" #'tab-line-select-tab
+ "<tab-line> <mouse-2>" #'tab-line-close-tab
+ "<tab-line> <down-mouse-3>" #'tab-line-tab-context-menu
+ "<tab-line> <touchscreen-begin>" #'tab-line-select-tab
"RET" #'tab-line-select-tab)
(defvar-keymap tab-line-add-map
:doc "Local keymap to add `tab-line-mode' window tabs."
- "<tab-line> <down-mouse-1>" #'tab-line-new-tab
- "<tab-line> <down-mouse-2>" #'tab-line-new-tab
+ "<tab-line> <down-mouse-1>" #'tab-line-new-tab
+ "<tab-line> <down-mouse-2>" #'tab-line-new-tab
+ "<tab-line> <touchscreen-begin>" #'tab-line-new-tab
"RET" #'tab-line-new-tab)
(defvar-keymap tab-line-tab-close-map
:doc "Local keymap to close `tab-line-mode' window tabs."
- "<tab-line> <mouse-1>" #'tab-line-close-tab
- "<tab-line> <mouse-2>" #'tab-line-close-tab)
+ "<tab-line> <mouse-1>" #'tab-line-close-tab
+ "<tab-line> <mouse-2>" #'tab-line-close-tab
+ "<tab-line> <touchscreen-begin>" #'tab-line-close-tab)
(defvar-keymap tab-line-left-map
:doc "Local keymap to scroll `tab-line-mode' window tabs to the left."
- "<tab-line> <down-mouse-1>" #'tab-line-hscroll-left
- "<tab-line> <down-mouse-2>" #'tab-line-hscroll-left
- "RET" #'tab-line-new-tab)
+ "<tab-line> <down-mouse-1>" #'tab-line-hscroll-left
+ "<tab-line> <down-mouse-2>" #'tab-line-hscroll-left
+ "<tab-line> <touchscreen-begin>" #'tab-line-hscroll-left
+ "RET" #'tab-line-new-tab)
(defvar-keymap tab-line-right-map
:doc "Local keymap to scroll `tab-line-mode' window tabs to the right."
- "<tab-line> <down-mouse-1>" #'tab-line-hscroll-right
- "<tab-line> <down-mouse-2>" #'tab-line-hscroll-right
- "RET" #'tab-line-new-tab)
+ "<tab-line> <down-mouse-1>" #'tab-line-hscroll-right
+ "<tab-line> <down-mouse-2>" #'tab-line-hscroll-right
+ "<tab-line> <touchscreen-begin>" #'tab-line-hscroll-right
+ "RET" #'tab-line-new-tab)
(defcustom tab-line-new-tab-choice t
@@ -185,12 +191,20 @@ If the value is a function, call it with no arguments."
:group 'tab-line
:version "27.1")
+(define-icon tab-line-new nil
+ `((image "symbols/plus_16.svg" "tabs/new.xpm"
+ :face shadow
+ :height (1 . em)
+ :margin (2 . 0)
+ :ascent center)
+ (text " + "))
+ "Icon for creating a new tab."
+ :version "30.1"
+ :help-echo "New tab")
+
(defvar tab-line-new-button
- (propertize " + "
- 'display '(image :type xpm
- :file "tabs/new.xpm"
- :margin (2 . 0)
- :ascent center)
+ (propertize (icon-string 'tab-line-new)
+ 'rear-nonsticky nil
'keymap tab-line-add-map
'mouse-face 'tab-line-highlight
'help-echo "Click to add tab")
@@ -213,34 +227,56 @@ If nil, don't show it at all."
:group 'tab-line
:version "27.1")
+(define-icon tab-line-close nil
+ `((image "symbols/cross_16.svg" "tabs/close.xpm"
+ :face shadow
+ :height (1 . em)
+ :margin (2 . 0)
+ :ascent center)
+ (text " x"))
+ "Icon for closing the clicked tab."
+ :version "30.1"
+ :help-echo "Click to close tab")
+
(defvar tab-line-close-button
- (propertize " x"
- 'display '(image :type xpm
- :file "tabs/close.xpm"
- :margin (2 . 0)
- :ascent center)
+ (propertize (icon-string 'tab-line-close)
+ 'rear-nonsticky nil ;; important to not break auto-scroll
'keymap tab-line-tab-close-map
'mouse-face 'tab-line-close-highlight
'help-echo "Click to close tab")
"Button for closing the clicked tab.")
+(define-icon tab-line-left nil
+ `((image "symbols/chevron_left_16.svg" "tabs/left-arrow.xpm"
+ :face shadow
+ :height (1 . em)
+ :margin (2 . 0)
+ :ascent center)
+ (text " <"))
+ "Icon for scrolling horizontally to the left."
+ :version "30.1")
+
(defvar tab-line-left-button
- (propertize " <"
- 'display '(image :type xpm
- :file "tabs/left-arrow.xpm"
- :margin (2 . 0)
- :ascent center)
+ (propertize (icon-string 'tab-line-left)
+ 'rear-nonsticky nil
'keymap tab-line-left-map
'mouse-face 'tab-line-highlight
'help-echo "Click to scroll left")
"Button for scrolling horizontally to the left.")
+(define-icon tab-line-right nil
+ `((image "symbols/chevron_right_16.svg" "tabs/right-arrow.xpm"
+ :face shadow
+ :height (1 . em)
+ :margin (2 . 0)
+ :ascent center)
+ (text "> "))
+ "Icon for scrolling horizontally to the right."
+ :version "30.1")
+
(defvar tab-line-right-button
- (propertize "> "
- 'display '(image :type xpm
- :file "tabs/right-arrow.xpm"
- :margin (2 . 0)
- :ascent center)
+ (propertize (icon-string 'tab-line-right)
+ 'rear-nonsticky nil
'keymap tab-line-right-map
'mouse-face 'tab-line-highlight
'help-echo "Click to scroll right")
@@ -484,21 +520,27 @@ which the tab will represent."
(setf face (funcall fn tab tabs face buffer-p selected-p)))
(apply 'propertize
(concat (propertize (string-replace "%" "%%" name) ;; (bug#57848)
+ 'face face
'keymap tab-line-tab-map
'help-echo (if selected-p "Current tab"
"Click to select tab")
;; Don't turn mouse-1 into mouse-2 (bug#49247)
'follow-link 'ignore)
- (or (and (or buffer-p (assq 'buffer tab) (assq 'close tab))
- tab-line-close-button-show
- (not (eq tab-line-close-button-show
- (if selected-p 'non-selected 'selected)))
- tab-line-close-button)
- ""))
+ (let ((close (or (and (or buffer-p (assq 'buffer tab)
+ (assq 'close tab))
+ tab-line-close-button-show
+ (not (eq tab-line-close-button-show
+ (if selected-p 'non-selected
+ 'selected)))
+ tab-line-close-button)
+ "")))
+ (setq close (copy-sequence close))
+ ;; Don't overwrite the icon face
+ (add-face-text-property 0 (length close) face t close)
+ close))
`(
tab ,tab
,@(if selected-p '(selected t))
- face ,face
mouse-face tab-line-highlight))))
(defun tab-line-format-template (tabs)
@@ -637,7 +679,7 @@ the selected tab visible."
(erase-buffer)
(apply 'insert strings)
(goto-char (point-min))
- (add-face-text-property (point-min) (point-max) 'tab-line)
+ (add-face-text-property (point-min) (point-max) 'tab-line t)
;; Continuation means tab-line doesn't fit completely,
;; thus scroll arrows are needed for scrolling.
(setq show-arrows (> (vertical-motion 1) 0))
@@ -719,17 +761,21 @@ the selected tab visible."
"Scroll the tab line ARG positions to the right.
Interactively, ARG is the prefix numeric argument and defaults to 1."
(interactive (list current-prefix-arg last-nonmenu-event))
- (let ((window (and (listp event) (posn-window (event-start event)))))
- (tab-line-hscroll arg window)
- (force-mode-line-update window)))
+ (when (tab-line-track-tap event)
+ (let ((window (and (listp event)
+ (posn-window (tab-line-event-start event)))))
+ (tab-line-hscroll arg window)
+ (force-mode-line-update window))))
(defun tab-line-hscroll-left (&optional arg event)
"Scroll the tab line ARG positions to the left.
Interactively, ARG is the prefix numeric argument and defaults to 1."
(interactive (list current-prefix-arg last-nonmenu-event))
- (let ((window (and (listp event) (posn-window (event-start event)))))
- (tab-line-hscroll (- (or arg 1)) window)
- (force-mode-line-update window)))
+ (when (tab-line-track-tap event)
+ (let ((window (and (listp event)
+ (posn-window (tab-line-event-start event)))))
+ (tab-line-hscroll (- (or arg 1)) window)
+ (force-mode-line-update window))))
(defun tab-line-new-tab (&optional event)
@@ -738,15 +784,16 @@ This command is usually invoked by clicking on the plus-shaped button
on the tab line. Switching to another buffer also adds a new tab
corresponding to the new buffer shown in the window."
(interactive (list last-nonmenu-event))
- (if (functionp tab-line-new-tab-choice)
- (funcall tab-line-new-tab-choice)
- (let ((tab-line-tabs-buffer-groups mouse-buffer-menu-mode-groups))
- (if (and (listp event)
- (display-popup-menus-p)
- (not tty-menu-open-use-tmm))
- (mouse-buffer-menu event) ; like (buffer-menu-open)
- ;; tty menu doesn't support mouse clicks, so use tmm
- (tmm-prompt (mouse-buffer-menu-keymap))))))
+ (when (tab-line-track-tap event)
+ (if (functionp tab-line-new-tab-choice)
+ (funcall tab-line-new-tab-choice)
+ (let ((tab-line-tabs-buffer-groups mouse-buffer-menu-mode-groups))
+ (if (and (listp event)
+ (display-popup-menus-p)
+ (not tty-menu-open-use-tmm))
+ (mouse-buffer-menu event) ; like (buffer-menu-open)
+ ;; tty menu doesn't support mouse clicks, so use tmm
+ (tmm-prompt (mouse-buffer-menu-keymap)))))))
(defun tab-line-select-tab (&optional event)
"Switch to the buffer specified by the tab on which you click.
@@ -754,16 +801,17 @@ This command maintains the original order of prev/next buffers.
So, for example, switching to a previous tab is equivalent to
using the `previous-buffer' command."
(interactive "e")
- (let* ((posnp (event-start event))
- (tab (tab-line--get-tab-property 'tab (car (posn-string posnp))))
- (buffer (if (bufferp tab) tab (cdr (assq 'buffer tab)))))
- (if buffer
- (tab-line-select-tab-buffer buffer (posn-window posnp))
- (let ((select (cdr (assq 'select tab))))
- (when (functionp select)
- (with-selected-window (posn-window posnp)
- (funcall select)
- (force-mode-line-update)))))))
+ (when (tab-line-track-tap event #'tab-line-tab-context-menu)
+ (let* ((posnp (tab-line-event-start event))
+ (tab (tab-line--get-tab-property 'tab (car (posn-string posnp))))
+ (buffer (if (bufferp tab) tab (cdr (assq 'buffer tab)))))
+ (if buffer
+ (tab-line-select-tab-buffer buffer (posn-window posnp))
+ (let ((select (cdr (assq 'select tab))))
+ (when (functionp select)
+ (with-selected-window (posn-window posnp)
+ (funcall select)
+ (force-mode-line-update))))))))
(defun tab-line-select-tab-buffer (buffer &optional window)
(let* ((window-buffer (window-buffer window))
@@ -869,25 +917,27 @@ This command is usually invoked by clicking on the close button on the
right side of the tab. This command buries the buffer, so it goes out of
sight of the tab line."
(interactive (list last-nonmenu-event))
- (let* ((posnp (and (listp event) (event-start event)))
- (window (and posnp (posn-window posnp)))
- (tab (tab-line--get-tab-property 'tab (car (posn-string posnp))))
- (buffer (if (bufferp tab) tab (cdr (assq 'buffer tab))))
- (close-function (unless (bufferp tab) (cdr (assq 'close tab)))))
- (with-selected-window (or window (selected-window))
- (cond
- ((functionp close-function)
- (funcall close-function))
- ((eq tab-line-close-tab-function 'kill-buffer)
- (kill-buffer buffer))
- ((eq tab-line-close-tab-function 'bury-buffer)
- (if (eq buffer (current-buffer))
- (bury-buffer)
- (set-window-prev-buffers nil (assq-delete-all buffer (window-prev-buffers)))
- (set-window-next-buffers nil (delq buffer (window-next-buffers)))))
- ((functionp tab-line-close-tab-function)
- (funcall tab-line-close-tab-function tab)))
- (force-mode-line-update))))
+ (when (tab-line-track-tap event)
+ (let* ((posnp (and (listp event)
+ (tab-line-event-start event)))
+ (window (and posnp (posn-window posnp)))
+ (tab (tab-line--get-tab-property 'tab (car (posn-string posnp))))
+ (buffer (if (bufferp tab) tab (cdr (assq 'buffer tab))))
+ (close-function (unless (bufferp tab) (cdr (assq 'close tab)))))
+ (with-selected-window (or window (selected-window))
+ (cond
+ ((functionp close-function)
+ (funcall close-function))
+ ((eq tab-line-close-tab-function 'kill-buffer)
+ (kill-buffer buffer))
+ ((eq tab-line-close-tab-function 'bury-buffer)
+ (if (eq buffer (current-buffer))
+ (bury-buffer)
+ (set-window-prev-buffers nil (assq-delete-all buffer (window-prev-buffers)))
+ (set-window-next-buffers nil (delq buffer (window-next-buffers)))))
+ ((functionp tab-line-close-tab-function)
+ (funcall tab-line-close-tab-function tab)))
+ (force-mode-line-update)))))
(defun tab-line-tab-context-menu (&optional event)
"Pop up the context menu for a tab-line tab."
@@ -906,6 +956,47 @@ sight of the tab line."
(popup-menu menu event)))
+;;; Touch screen support.
+
+(defvar touch-screen-delay)
+
+(defun tab-line-track-tap (event &optional function)
+ "Track a tap starting from EVENT.
+If EVENT is not a `touchscreen-begin' event, return t.
+Otherwise, return t if the tap completes successfully, and nil if
+the tap should be ignored.
+
+If FUNCTION is specified and the tap does not complete within
+`touch-screen-delay' seconds, display the appropriate context
+menu by calling FUNCTION with EVENT, and return nil."
+ (if (not (eq (car-safe event) 'touchscreen-begin))
+ t
+ (let ((result (catch 'context-menu
+ (let (timer)
+ (unwind-protect
+ (progn
+ (when function
+ (setq timer
+ (run-at-time touch-screen-delay t
+ #'throw 'context-menu
+ 'context-menu)))
+ (touch-screen-track-tap event))
+ (when timer
+ (cancel-timer timer)))))))
+ (cond ((eq result 'context-menu)
+ (prog1 nil
+ (funcall function event)))
+ (result t)))))
+
+(defun tab-line-event-start (event)
+ "Like `event-start'.
+However, return the correct mouse position list if EVENT is a
+`touchscreen-begin' event."
+ (or (and (eq (car-safe event) 'touchscreen-begin)
+ (cdadr event))
+ (event-start event)))
+
+
;;;###autoload
(define-minor-mode tab-line-mode
"Toggle display of tab line in the windows displaying the current buffer."
diff --git a/lisp/tar-mode.el b/lisp/tar-mode.el
index d81d93d8dc8..375191a8167 100644
--- a/lisp/tar-mode.el
+++ b/lisp/tar-mode.el
@@ -215,6 +215,98 @@ Preserve the modified states of the buffers and set `tar-data-swapped'."
"Round S up to the next multiple of 512."
(ash (ash (+ s 511) -9) 9))
+;; Reference:
+;; https://pubs.opengroup.org/onlinepubs/9699919799/utilities/pax.html#tag_20_92_13_02
+(defconst pax-extended-attribute-record-regexp
+ ;; We omit attributes that are "reserved" by Posix, since no
+ ;; processing has been defined for them.
+ "\\([0-9]+\\) \\(gid\\|gname\\|hdrcharset\\|linkpath\\|mtime\\|path\\|size\\|uid\\|uname\\)="
+ "Regular expression for looking up extended attributes in a
+Posix-standard pax extended header of a tar file.
+Only attributes that `tar-mode' can grok are mentioned.")
+
+(defconst pax-gid-index 0)
+(defconst pax-gname-index 1)
+(defconst pax-linkpath-index 2)
+(defconst pax-mtime-index 3)
+(defconst pax-path-index 4)
+(defconst pax-size-index 5)
+(defconst pax-uid-index 6)
+(defconst pax-uname-index 7)
+(defsubst pax-header-gid (attr-vec)
+ (aref attr-vec pax-gid-index))
+(defsubst pax-header-gname (attr-vec)
+ (aref attr-vec pax-gname-index))
+(defsubst pax-header-linkpath (attr-vec)
+ (aref attr-vec pax-linkpath-index))
+(defsubst pax-header-mtime (attr-vec)
+ (aref attr-vec pax-mtime-index))
+(defsubst pax-header-path (attr-vec)
+ (aref attr-vec pax-path-index))
+(defsubst pax-header-size (attr-vec)
+ (aref attr-vec pax-size-index))
+(defsubst pax-header-uid (attr-vec)
+ (aref attr-vec pax-uid-index))
+(defsubst pax-header-uname (attr-vec)
+ (aref attr-vec pax-uid-index))
+
+(defsubst pax-decode-string (str coding)
+ (if str
+ (decode-coding-string str coding)
+ str))
+
+(defvar tar-attr-vector (make-vector 8 nil))
+(defun tar-parse-pax-extended-header (pos)
+ "Parse a pax external header of a Posix-format tar file."
+ (let ((end (+ pos 512))
+ (result tar-attr-vector)
+ (coding 'utf-8-unix)
+ attr value record-len value-len)
+ (fillarray result nil)
+ (goto-char pos)
+ (while (and (< pos end)
+ (re-search-forward pax-extended-attribute-record-regexp
+ end 'move))
+ (setq record-len (string-to-number (match-string 1))
+ attr (match-string 2)
+ value-len (- record-len
+ (length (match-string 1))
+ 1
+ (length (match-string 2))
+ 2)
+ value (buffer-substring (point) (+ (point) value-len)))
+ (setq pos (goto-char (+ (point) value-len 1)))
+ (cond
+ ((equal attr "gid")
+ (aset result pax-gid-index value))
+ ((equal attr "gname")
+ (aset result pax-gname-index value))
+ ((equal attr "linkpath")
+ (aset result pax-linkpath-index value))
+ ((equal attr "mtime")
+ (aset result pax-mtime-index (string-to-number value)))
+ ((equal attr "path")
+ (aset result pax-path-index value))
+ ((equal attr "size")
+ (aset result pax-size-index value))
+ ((equal attr "uid")
+ (aset result pax-uid-index value))
+ ((equal attr "uname")
+ (aset result pax-uname-index value))
+ ((equal attr "hdrcharset")
+ (setq coding (if (equal value "BINARY") 'no-conversion 'utf-8-unix))))
+ (setq pos (+ pos (skip-chars-forward "\000"))))
+ ;; Decode string-valued attributes.
+ (aset result pax-gname-index
+ (pax-decode-string (aref result pax-gname-index) coding))
+ (aset result pax-linkpath-index
+ (pax-decode-string (aref result pax-linkpath-index) coding))
+ (aset result pax-path-index
+ (pax-decode-string (aref result pax-path-index) coding))
+ (aset result pax-uname-index
+ (pax-decode-string (aref result pax-uname-index) coding))
+ result))
+
(defun tar-header-block-tokenize (pos coding &optional disable-slash)
"Return a `tar-header' structure.
This is a list of name, mode, uid, gid, size,
@@ -276,12 +368,11 @@ of the file header. This is used for \"old GNU\" Tar format."
;; format (i.e. "ustar ") but some POSIX Tar files
;; (with "ustar\0") have been seen using it as well.
(member magic-str '("ustar " "ustar\0")))
- ;; This is a GNU Tar long-file-name header.
(let* ((size (tar-parse-octal-integer
string tar-size-offset tar-time-offset))
;; The long name is in the next 512-byte block.
- ;; We've already moved POS there, when we computed
- ;; STRING above.
+ ;; We've already moved POS there, when we
+ ;; computed STRING above.
(name (decode-coding-string
;; -1 so as to strip the terminating 0 byte.
(buffer-substring pos (+ pos size -1)) coding))
@@ -310,28 +401,74 @@ of the file header. This is used for \"old GNU\" Tar format."
(setf (tar-header-header-start descriptor)
(copy-marker (- pos 512) t))
descriptor)
-
- (make-tar-header
- (copy-marker pos nil)
- name
- (tar-parse-octal-integer string tar-mode-offset tar-uid-offset)
- (tar-parse-octal-integer string tar-uid-offset tar-gid-offset)
- (tar-parse-octal-integer string tar-gid-offset tar-size-offset)
- (tar-parse-octal-integer string tar-size-offset tar-time-offset)
- (tar-parse-octal-integer string tar-time-offset tar-chk-offset)
- (tar-parse-octal-integer string tar-chk-offset tar-linkp-offset)
- link-p
- linkname
- uname-valid-p
- (when uname-valid-p
- (decode-coding-string
- (substring string tar-uname-offset uname-end) coding))
- (when uname-valid-p
- (decode-coding-string
- (substring string tar-gname-offset gname-end) coding))
- (tar-parse-octal-integer string tar-dmaj-offset tar-dmin-offset)
- (tar-parse-octal-integer string tar-dmin-offset tar-prefix-offset)
- ))))))
+ ;; Posix pax extended header. FIXME: support ?g as well.
+ (if (and (eq link-p (- ?x ?0))
+ (member magic-str '("ustar " "ustar\0")))
+ ;; Get whatever attributes are in the extended header,
+ (let* ((pax-attrs (tar-parse-pax-extended-header pos))
+ (gid (pax-header-gid pax-attrs))
+ (gname (pax-header-gname pax-attrs))
+ (linkpath (pax-header-linkpath pax-attrs))
+ (mtime (pax-header-mtime pax-attrs))
+ (path (pax-header-path pax-attrs))
+ (size (pax-header-size pax-attrs))
+ (uid (pax-header-uid pax-attrs))
+ (uname (pax-header-uname pax-attrs))
+ ;; Tokenize the header of the _real_ file entry,
+ ;; which is further 512 bytes into the archive.
+ (descriptor
+ (tar-header-block-tokenize (+ pos 512) coding
+ 'ignore-trailing-slash)))
+ ;; Fix the descriptor of the real file entry by
+ ;; overriding some of the fields with the information
+ ;; from the extended header.
+ (if gid
+ (setf (tar-header-gid descriptor) gid))
+ (if gname
+ (setf (tar-header-gname descriptor) gname))
+ (if linkpath
+ (setf (tar-header-link-name descriptor) linkpath))
+ (if mtime
+ (setf (tar-header-date descriptor) mtime))
+ (if path
+ (setf (tar-header-name descriptor) path))
+ (if size
+ (setf (tar-header-size descriptor) size))
+ (if uid
+ (setf (tar-header-uid descriptor) uid))
+ (if uname
+ (setf (tar-header-uname descriptor) uname))
+ descriptor)
+
+ (make-tar-header
+ (copy-marker pos nil)
+ name
+ (tar-parse-octal-integer string tar-mode-offset
+ tar-uid-offset)
+ (tar-parse-octal-integer string tar-uid-offset
+ tar-gid-offset)
+ (tar-parse-octal-integer string tar-gid-offset
+ tar-size-offset)
+ (tar-parse-octal-integer string tar-size-offset
+ tar-time-offset)
+ (tar-parse-octal-integer string tar-time-offset
+ tar-chk-offset)
+ (tar-parse-octal-integer string tar-chk-offset
+ tar-linkp-offset)
+ link-p
+ linkname
+ uname-valid-p
+ (when uname-valid-p
+ (decode-coding-string
+ (substring string tar-uname-offset uname-end) coding))
+ (when uname-valid-p
+ (decode-coding-string
+ (substring string tar-gname-offset gname-end) coding))
+ (tar-parse-octal-integer string tar-dmaj-offset
+ tar-dmin-offset)
+ (tar-parse-octal-integer string tar-dmin-offset
+ tar-prefix-offset)
+ )))))))
;; Pseudo-field.
(defun tar-header-data-end (descriptor)
diff --git a/lisp/tempo.el b/lisp/tempo.el
index fe7a866954b..b7ad680c2a9 100644
--- a/lisp/tempo.el
+++ b/lisp/tempo.el
@@ -116,8 +116,7 @@
"Prompt user for strings in templates.
If this variable is non-nil, `tempo-insert' prompts the
user for text to insert in the templates."
- :type 'boolean
- :group 'tempo)
+ :type 'boolean)
(defcustom tempo-insert-region nil
"Automatically insert current region when there is a `r' in the template
@@ -126,20 +125,17 @@ elements, unless the template function is given a prefix (or a non-nil
argument). If this variable is non-nil, the behavior is reversed.
In Transient Mark mode, this option is unused."
- :type 'boolean
- :group 'tempo)
+ :type 'boolean)
(defcustom tempo-show-completion-buffer t
"If non-nil, show a buffer with possible completions, when only
a partial completion can be found."
- :type 'boolean
- :group 'tempo)
+ :type 'boolean)
(defcustom tempo-leave-completion-buffer nil
"If nil, a completion buffer generated by \\[tempo-complete-tag]
disappears at the next keypress; otherwise, it remains forever."
- :type 'boolean
- :group 'tempo)
+ :type 'boolean)
;;; Internal variables
@@ -168,7 +164,7 @@ documentation for the function `tempo-complete-tag' for more info.
"Indicates if the tag collection needs to be rebuilt.")
(defvar-local tempo-marks nil
- "A list of marks to jump to with `\\[tempo-forward-mark]' and `\\[tempo-backward-mark]'.")
+ "A list of marks to jump to with \\[tempo-forward-mark] and \\[tempo-backward-mark].")
(defvar-local tempo-match-finder "\\b\\([[:word:]]+\\)\\="
"The regexp or function used to find the string to match against tags.
@@ -189,11 +185,12 @@ returns a pair of the form (STRING . POS), where STRING is the string
used for matching and POS is the buffer position after which text
should be replaced with a template.")
-(defvar tempo-user-elements nil
+(define-obsolete-variable-alias 'tempo-user-elements 'tempo-user-element-functions "30.1")
+(defvar tempo-user-element-functions nil
"Element handlers for user-defined elements.
-A list of symbols which are bound to functions that take one argument.
-This function should return something to be sent to `tempo-insert' if
-it recognizes the argument, and nil otherwise.")
+This is an abnormal hook where the functions are called with one argument
+\(an element in a template) and they should return something to be sent to
+`tempo-insert' if they recognize the argument, and nil otherwise.")
(defvar-local tempo-named-insertions nil
"Temporary storage for named insertions.")
@@ -201,6 +198,10 @@ it recognizes the argument, and nil otherwise.")
(defvar-local tempo-region-start (make-marker)
"Region start when inserting around the region.")
+;; Insertion by the template at the region start position should move
+;; the marker to preserve the original region contents.
+(set-marker-insertion-type tempo-region-start t)
+
(defvar-local tempo-region-stop (make-marker)
"Region stop when inserting around the region.")
@@ -262,7 +263,7 @@ The elements in ELEMENTS can be of several types:
- `n>': Inserts a newline and indents line.
- `o': Like `%' but leaves the point before the newline.
- nil: It is ignored.
- - Anything else: Each function in `tempo-user-elements' is called
+ - Anything else: Each function in `tempo-user-element-functions' is called
with it as argument until one of them returns non-nil, and the
result is inserted. If all of them return nil, it is evaluated and
the result is treated as an element to be inserted. One additional
@@ -274,14 +275,13 @@ The elements in ELEMENTS can be of several types:
name)))
(command-name template-name))
(set template-name elements)
- (fset command-name (list 'lambda (list '&optional 'arg)
- (or documentation
- (concat "Insert a " name "."))
- (list 'interactive "*P")
- (list 'tempo-insert-template (list 'quote
- template-name)
- (list 'if 'tempo-insert-region
- (list 'not 'arg) 'arg))))
+ (fset command-name (lambda (&optional arg)
+ (:documentation
+ (or documentation (concat "Insert a " name ".")))
+ (interactive "*P")
+ (tempo-insert-template template-name
+ (if tempo-insert-region
+ (not arg) arg))))
(and tag
(tempo-add-tag tag template-name taglist))
command-name))
@@ -325,72 +325,58 @@ elements are replaced with the current region.
See documentation for `tempo-define-template' for the kind of elements
possible."
- (cond ((stringp element) (tempo-process-and-insert-string element))
- ((and (consp element)
- (eq (car element) 'p)) (tempo-insert-prompt-compat
- (cdr element)))
- ((and (consp element)
- (eq (car element) 'P)) (let ((tempo-interactive t))
- (tempo-insert-prompt-compat
- (cdr element))))
-;;; ((and (consp element)
-;;; (eq (car element) 'v)) (tempo-save-named
-;;; (nth 1 element)
-;;; nil
-;;; (nth 2 element)))
- ((and (consp element)
- (eq (car element) 'r)) (if on-region
- (goto-char tempo-region-stop)
- (tempo-insert-prompt-compat
- (cdr element))))
- ((and (consp element)
- (eq (car element) 'r>)) (if on-region
- (progn
- (goto-char tempo-region-stop)
- (indent-region (mark) (point) nil))
- (tempo-insert-prompt-compat
- (cdr element))))
- ((and (consp element)
- (eq (car element) 's)) (tempo-insert-named (car (cdr element))))
- ((and (consp element)
- (eq (car element) 'l)) (mapcar (lambda (elt)
- (tempo-insert elt on-region))
- (cdr element)))
- ((eq element 'p) (tempo-insert-mark (point-marker)))
- ((eq element 'r) (if on-region
- (goto-char tempo-region-stop)
- (tempo-insert-mark (point-marker))))
- ((eq element 'r>) (if on-region
- (progn
- (goto-char tempo-region-stop)
- (indent-region (mark) (point) nil))
- (tempo-insert-mark (point-marker))))
- ((eq element '>) (indent-according-to-mode))
- ((eq element '&) (if (not (or (= (current-column) 0)
- (save-excursion
- (re-search-backward
- "^\\s-*\\=" nil t))))
- (insert "\n")))
- ((eq element '%) (if (not (or (eolp)
- (save-excursion
- (re-search-forward
- "\\=\\s-*$" nil t))))
- (insert "\n")))
- ((eq element 'n) (insert "\n"))
- ((eq element 'n>) (insert "\n") (indent-according-to-mode))
- ;; Bug: If the 'o is the first element in a template, strange
- ;; things can happen when the template is inserted at the
- ;; beginning of a line.
- ((eq element 'o) (if (not (or on-region
- (eolp)
- (save-excursion
- (re-search-forward
- "\\=\\s-*$" nil t))))
- (open-line 1)))
- ((null element))
- (t (tempo-insert (or (tempo-is-user-element element)
- (eval element))
- on-region))))
+ (pcase element
+ ((pred stringp) (tempo-process-and-insert-string element))
+ (`(p . ,rest) (tempo-insert-prompt-compat rest))
+ (`(P . ,rest) (let ((tempo-interactive t))
+ (tempo-insert-prompt-compat rest)))
+ ;; (`(v ,name ,data) (tempo-save-named name nil data))
+ (`(r . ,rest) (if on-region
+ (goto-char tempo-region-stop)
+ (tempo-insert-prompt-compat rest)))
+ (`(r> . ,rest) (if on-region
+ (progn
+ (goto-char tempo-region-stop)
+ (indent-region tempo-region-start
+ tempo-region-stop))
+ (tempo-insert-prompt-compat rest)))
+ (`(s ,name) (tempo-insert-named name))
+ (`(l . ,rest) (dolist (elt rest) (tempo-insert elt on-region)))
+ ('p (tempo-insert-mark (point-marker)))
+ ('r (if on-region
+ (goto-char tempo-region-stop)
+ (tempo-insert-mark (point-marker))))
+ ('r> (if on-region
+ (progn
+ (goto-char tempo-region-stop)
+ (indent-region tempo-region-start tempo-region-stop))
+ (tempo-insert-mark (point-marker))))
+ ('> (indent-according-to-mode))
+ ('& (if (not (or (= (current-column) 0)
+ (save-excursion
+ (re-search-backward
+ "^\\s-*\\=" nil t))))
+ (insert "\n")))
+ ('% (if (not (or (eolp)
+ (save-excursion
+ (re-search-forward
+ "\\=\\s-*$" nil t))))
+ (insert "\n")))
+ ('n (insert "\n"))
+ ('n> (insert "\n") (indent-according-to-mode))
+ ;; Bug: If the 'o is the first element in a template, strange
+ ;; things can happen when the template is inserted at the
+ ;; beginning of a line.
+ ('o (if (not (or on-region
+ (eolp)
+ (save-excursion
+ (re-search-forward
+ "\\=\\s-*$" nil t))))
+ (open-line 1)))
+ ('nil nil)
+ (_ (tempo-insert (or (tempo-is-user-element element)
+ (eval element t))
+ on-region))))
;;;
;;; tempo-insert-prompt
@@ -400,7 +386,7 @@ possible."
PROMPT can be either a prompt string, or a list of arguments to
`tempo-insert-prompt', or nil."
(if (consp prompt) ; not nil either
- (apply 'tempo-insert-prompt prompt)
+ (apply #'tempo-insert-prompt prompt)
(tempo-insert-prompt prompt)))
(defun tempo-insert-prompt (prompt &optional save-name no-insert)
@@ -445,14 +431,8 @@ never prompted."
;;; tempo-is-user-element
(defun tempo-is-user-element (element)
- "Try all the user-defined element handlers in `tempo-user-elements'."
- ;; Sigh... I need (some list)
- (catch 'found
- (mapc (lambda (handler)
- (let ((result (funcall handler element)))
- (if result (throw 'found result))))
- tempo-user-elements)
- (throw 'found nil)))
+ "Try all the user-defined element handlers in `tempo-user-element-functions'."
+ (run-hook-with-args-until-success 'tempo-user-element-functions element))
;;;
;;; tempo-forget-insertions
@@ -602,7 +582,7 @@ TAG-LIST is a symbol whose variable value is a tag list created with
`tempo-add-tag'.
COMPLETION-FUNCTION is an obsolete option for specifying an optional
-function or string that is used by `\\[tempo-complete-tag]' to find a
+function or string that is used by \\[tempo-complete-tag] to find a
string to match the tag against. It has the same definition as the
variable `tempo-match-finder'. In this version, supplying a
COMPLETION-FUNCTION just sets `tempo-match-finder' locally."
@@ -636,12 +616,12 @@ If `tempo-dirty-collection' is nil, the old collection is reused."
(or (and (not tempo-dirty-collection)
tempo-collection)
(setq tempo-collection
- (apply (function append)
+ (apply #'append
(mapcar (lambda (tag-list)
; If the format for
; tempo-local-tags changes,
; change this
- (eval (car tag-list)))
+ (eval (car tag-list) t))
tempo-local-tags))))
(setq tempo-dirty-collection nil)))
@@ -653,16 +633,10 @@ If `tempo-dirty-collection' is nil, the old collection is reused."
FINDER is a function or a string. Returns (STRING . POS), or nil
if no reasonable string is found."
(cond ((stringp finder)
- (let (successful)
- (save-excursion
- (or (setq successful (re-search-backward finder nil t))
- 0))
- (if successful
- (cons (buffer-substring (match-beginning 1)
- (match-end 1)) ; This seems to be a
- ; bug in emacs
- (match-beginning 1))
- nil)))
+ (if (save-excursion (re-search-backward finder nil t))
+ (cons (match-string 1) ; This seems to be a bug in Emacs (?)
+ (match-beginning 1))
+ nil))
(t
(funcall finder))))
diff --git a/lisp/term.el b/lisp/term.el
index e769577b4f2..c15f6cf2e9f 100644
--- a/lisp/term.el
+++ b/lisp/term.el
@@ -954,6 +954,9 @@ underlying shell."
(define-key map [next] 'term-send-next)
(define-key map [xterm-paste] #'term--xterm-paste)
(define-key map [?\C-/] #'term-send-C-_)
+ (define-key map [?\C- ] #'term-send-C-@)
+ (define-key map [?\C-\M-/] #'term-send-C-M-_)
+ (define-key map [?\C-\M- ] #'term-send-C-M-@)
(when term-bind-function-keys
(dotimes (key 21)
@@ -977,12 +980,7 @@ For custom keybindings purposes please note there is also
(defun term--update-term-menu (&optional force)
(when (and (lookup-key term-mode-map [menu-bar terminal])
(or force (frame-or-buffer-changed-p)))
- (let ((buffer-list
- (seq-filter
- (lambda (buffer)
- (provided-mode-derived-p (buffer-local-value 'major-mode buffer)
- 'term-mode))
- (buffer-list))))
+ (let ((buffer-list (match-buffers '(derived-mode . term-mode))))
(easy-menu-change
nil
"Terminal Buffers"
@@ -1090,6 +1088,8 @@ For custom keybindings purposes please note there is also
(setq term-ansi-current-invisible nil)
(setq term-ansi-current-bg-color 0))
+(defvar touch-screen-display-keyboard)
+
(define-derived-mode term-mode fundamental-mode "Term"
"Major mode for interacting with an inferior interpreter.
The interpreter name is same as buffer name, sans the asterisks.
@@ -1138,6 +1138,7 @@ Commands in line mode:
\\{term-mode-map}
Entry to this mode runs the hooks on `term-mode-hook'."
+ :interactive nil
;; we do not want indent to sneak in any tabs
(setq indent-tabs-mode nil)
(setq buffer-display-table term-display-table)
@@ -1148,6 +1149,9 @@ Entry to this mode runs the hooks on `term-mode-hook'."
(setq-local term-last-input-end (make-marker))
(setq-local term-last-input-match "")
+ ;; Always display the onscreen keyboard.
+ (setq-local touch-screen-display-keyboard t)
+
;; These local variables are set to their local values:
(make-local-variable 'term-saved-home-marker)
(make-local-variable 'term-saved-cursor)
@@ -1382,7 +1386,6 @@ Entry to this mode runs the hooks on `term-mode-hook'."
(interactive "e")
;; Give temporary modes such as isearch a chance to turn off.
(run-hooks 'mouse-leave-buffer-hook)
- (setq this-command 'yank)
(mouse-set-point click)
;; As we have moved point, bind `select-active-regions' to prevent
;; the `deactivate-mark' call in `term-send-raw-string' from
@@ -1429,6 +1432,9 @@ Entry to this mode runs the hooks on `term-mode-hook'."
(defun term-send-del () (interactive) (term-send-raw-string "\e[3~"))
(defun term-send-backspace () (interactive) (term-send-raw-string "\C-?"))
(defun term-send-C-_ () (interactive) (term-send-raw-string "\C-_"))
+(defun term-send-C-@ () (interactive) (term-send-raw-string "\C-@"))
+(defun term-send-C-M-_ () (interactive) (term-send-raw-string "\e\C-_"))
+(defun term-send-C-M-@ () (interactive) (term-send-raw-string "\e\C-@"))
(defun term-send-function-key ()
"If bound to a function key, this will send that key to the underlying shell."
@@ -1741,7 +1747,12 @@ Nil if unknown.")
(push (format "EMACS=%s (term:%s)" emacs-version term-protocol-version)
process-environment))
(apply #'start-process name buffer
- "/bin/sh" "-c"
+ ;; On Android, /bin doesn't exist, and the default shell is
+ ;; found as /system/bin/sh.
+ (if (eq system-type 'android)
+ "/system/bin/sh"
+ "/bin/sh")
+ "-c"
(format "stty -nl echo rows %d columns %d sane 2>%s;\
if [ $1 = .. ]; then shift; fi; exec \"$@\""
term-height term-width null-device)
@@ -2071,7 +2082,7 @@ See `term-replace-by-expanded-history'. Returns t if successful."
;; We cannot know the interpreter's idea of input line numbers.
(goto-char (match-end 0))
(message "Absolute reference cannot be expanded"))
- ((looking-at "!-\\([0-9]+\\)\\(:?[0-9^$*-]+\\)?")
+ ((looking-at "!-\\([0-9]+\\):?\\([0-9^$*-]+\\)?")
;; Just a number of args from `number' lines backward.
(let ((number (1- (string-to-number
(buffer-substring (match-beginning 1)
@@ -2094,7 +2105,7 @@ See `term-replace-by-expanded-history'. Returns t if successful."
t t)
(message "History item: previous"))
((looking-at
- "!\\??\\({\\(.+\\)}\\|\\(\\sw+\\)\\)\\(:?[0-9^$*-]+\\)?")
+ "!\\??\\({\\(.+\\)}\\|\\(\\sw+\\)\\):?\\([0-9^$*-]+\\)?")
;; Most recent input starting with or containing (possibly
;; protected) string, maybe just a number of args. Phew.
(let* ((mb1 (match-beginning 1)) (me1 (match-end 1))
@@ -2973,7 +2984,7 @@ See `term-prompt-regexp'."
;; It emulates (most of the features of) a VT100/ANSI-style terminal.
;; References:
-;; [ctlseqs]: http://invisible-island.net/xterm/ctlseqs/ctlseqs.html
+;; [ctlseqs]: https://invisible-island.net/xterm/ctlseqs/ctlseqs.html
;; [ECMA-48]: https://www.ecma-international.org/publications/standards/Ecma-048.htm
;; [vt100]: https://vt100.net/docs/vt100-ug/chapter3.html
@@ -4338,7 +4349,7 @@ Typing SPC flushes the help buffer."
(display-completion-list (sort completions 'string-lessp)))
(message "Hit space to flush")
(let (key first)
- (if (with-current-buffer (get-buffer "*Completions*")
+ (if (with-current-buffer "*Completions*"
(setq key (read-key-sequence nil)
first (aref key 0))
(and (consp first)
diff --git a/lisp/term/AT386.el b/lisp/term/AT386.el
index 74422cd598c..6592fd3da45 100644
--- a/lisp/term/AT386.el
+++ b/lisp/term/AT386.el
@@ -2,7 +2,7 @@
;; Copyright (C) 1992, 2001-2024 Free Software Foundation, Inc.
-;; Author: Eric S. Raymond <esr@snark.thyrsus.com>
+;; Author: Eric S. Raymond <esr@thyrsus.com>
;; Keywords: terminals
;; This file is part of GNU Emacs.
diff --git a/lisp/term/android-win.el b/lisp/term/android-win.el
new file mode 100644
index 00000000000..6512ef81ff7
--- /dev/null
+++ b/lisp/term/android-win.el
@@ -0,0 +1,622 @@
+;;; android-win.el --- terminal set up for Android -*- lexical-binding:t -*-
+
+;; Copyright (C) 2023-2024 Free Software Foundation, Inc.
+
+;; Author: FSF
+;; Keywords: terminals, i18n, android
+
+;; This file is part of GNU Emacs.
+
+;; GNU Emacs is free software: you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+
+;; GNU Emacs is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>.
+
+;;; Commentary:
+
+;; This file contains the support for initializing the Lisp side of
+;; Android windowing.
+
+;;; Code:
+
+
+(unless (featurep 'android)
+ (error "%s: Loading android-win without having Android"
+ invocation-name))
+
+;; Documentation-purposes only: actually loaded in loadup.el.
+(require 'frame)
+(require 'mouse)
+(require 'fontset)
+(require 'dnd)
+(require 'touch-screen)
+
+(add-to-list 'display-format-alist '(".*" . android))
+
+(declare-function android-get-connection "androidfns.c")
+
+;; Window system initialization. This is extremely simple because all
+;; initialization is done in android_term_init.
+
+(cl-defmethod window-system-initialization (&context (window-system android)
+ &optional _ignored)
+ "Set up the window system. WINDOW-SYSTEM must be ANDROID.
+DISPLAY is ignored on Android."
+ ;; Create the default fontset.
+ (create-default-fontset)
+ ;; Just make sure the window system was initialized at startup.
+ (android-get-connection))
+
+(cl-defmethod frame-creation-function (params &context (window-system android))
+ (x-create-frame-with-faces params))
+
+(cl-defmethod handle-args-function (args &context (window-system android))
+ ;; Android has no command line to provide arguments on.
+ ;; However, call x-handle-args to handle file name args.
+ (x-handle-args args))
+
+
+;;; Selection support.
+
+(declare-function android-clipboard-exists-p "androidselect.c")
+(declare-function android-get-clipboard "androidselect.c")
+(declare-function android-set-clipboard "androidselect.c")
+(declare-function android-clipboard-owner-p "androidselect.c")
+(declare-function android-get-clipboard-targets "androidselect.c")
+(declare-function android-get-clipboard-data "androidselect.c")
+
+(defvar android-primary-selection nil
+ "The last string placed in the primary selection.
+nil if there was no such string.
+
+Android is not equipped with a primary selection of its own, so
+Emacs emulates one in Lisp.")
+
+(defvar android-secondary-selection nil
+ "The last string placed in the secondary selection.
+nil if there was no such string.
+
+Android is not equipped with a secondary selection of its own, so
+Emacs emulates one in Lisp.")
+
+(defun android-get-clipboard-1 (data-type)
+ "Return data saved from the clipboard.
+DATA-TYPE is a selection conversion target.
+
+`STRING' means return the contents of the clipboard as a string,
+while `TARGETS' means return the types of all data present within
+the clipboard as a vector.
+
+Interpret any other symbol as a MIME type for which any clipboard
+data is returned"
+ (or (and (eq data-type 'STRING)
+ (android-get-clipboard))
+ (and (eq data-type 'TARGETS)
+ (android-clipboard-exists-p)
+ (vconcat [TARGETS STRING]
+ (let ((i nil))
+ (dolist (type (android-get-clipboard-targets))
+ ;; Don't report plain text as a valid target
+ ;; since it is addressed by STRING.
+ (unless (equal type "text/plain")
+ (push (intern type) i)))
+ (nreverse i))))
+ (and (symbolp data-type)
+ (android-get-clipboard-data (symbol-name data-type)))))
+
+(defun android-get-primary (data-type)
+ "Return the last string placed in the primary selection, or nil.
+Return nil if DATA-TYPE is anything other than STRING or TARGETS."
+ (when android-primary-selection
+ (or (and (eq data-type 'STRING)
+ android-primary-selection)
+ (and (eq data-type 'TARGETS)
+ [TARGETS STRING]))))
+
+(defun android-get-secondary (data-type)
+ "Return the last string placed in the secondary selection, or nil.
+Return nil if DATA-TYPE is anything other than STRING or TARGETS."
+ (when android-secondary-selection
+ (or (and (eq data-type 'STRING)
+ android-secondary-selection)
+ (and (eq data-type 'TARGETS)
+ [TARGETS STRING]))))
+
+(defun android-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 android-encode-select-string (value)
+ "Turn VALUE into a string suitable for placing in the clipboard.
+VALUE should be something suitable for passing to
+`gui-set-selection'."
+ (unless (stringp value)
+ (when-let ((bounds (android-selection-bounds value)))
+ (setq value (ignore-errors
+ (with-current-buffer (nth 2 bounds)
+ (buffer-substring (nth 0 bounds)
+ (nth 1 bounds)))))))
+ value)
+
+(cl-defmethod gui-backend-get-selection (type data-type
+ &context (window-system android))
+ (cond ((eq type 'CLIPBOARD)
+ (android-get-clipboard-1 data-type))
+ ((eq type 'PRIMARY)
+ (android-get-primary data-type))
+ ((eq type 'SECONDARY)
+ (android-get-secondary data-type))))
+
+(cl-defmethod gui-backend-selection-exists-p (selection
+ &context (window-system android))
+ (cond ((eq selection 'CLIPBOARD)
+ (android-clipboard-exists-p))
+ ((eq selection 'PRIMARY)
+ (not (null android-primary-selection)))
+ ((eq selection 'SECONDARY)
+ (not (null android-secondary-selection)))))
+
+(cl-defmethod gui-backend-selection-owner-p (selection
+ &context (window-system android))
+ (cond ((eq selection 'CLIPBOARD)
+ (let ((ownership (android-clipboard-owner-p)))
+ ;; If ownership is `lambda', then Emacs couldn't establish
+ ;; whether or not it owns the clipboard.
+ (and (not (eq ownership 'lambda)) ownership)))
+ ((eq selection 'PRIMARY)
+ ;; Emacs always owns its own primary selection as long as it
+ ;; exists.
+ (not (null android-primary-selection)))
+ ((eq selection 'SECONDARY)
+ ;; Emacs always owns its own secondary selection as long as
+ ;; it exists.
+ (not (null android-secondary-selection)))))
+
+(cl-defmethod gui-backend-set-selection (type value
+ &context (window-system android))
+ ;; First, try to turn value into a string.
+ ;; Don't set anything if that did not work.
+ (when-let ((string (android-encode-select-string value)))
+ (cond ((eq type 'CLIPBOARD)
+ (android-set-clipboard string))
+ ((eq type 'PRIMARY)
+ (setq android-primary-selection string))
+ ((eq type 'SECONDARY)
+ (setq android-secondary-selection string)))))
+
+;;; Character composition display.
+
+(defvar android-preedit-overlay nil
+ "The overlay currently used to display preedit text from a compose sequence.")
+
+;; With some input methods, text gets inserted before Emacs is told to
+;; remove any preedit text that was displayed, which causes both the
+;; preedit overlay and the text to be visible for a brief period of
+;; time. This pre-command-hook clears the overlay before any command
+;; and should be set whenever a preedit overlay is visible.
+(defun android-clear-preedit-text ()
+ "Clear the pre-edit overlay and remove itself from pre-command-hook.
+This function should be installed in `pre-command-hook' whenever
+preedit text is displayed."
+ (when android-preedit-overlay
+ (delete-overlay android-preedit-overlay)
+ (setq android-preedit-overlay nil))
+ (remove-hook 'pre-command-hook #'android-clear-preedit-text))
+
+(defun android-preedit-text (event)
+ "Display preedit text from a compose sequence in EVENT.
+EVENT is a preedit-text event."
+ (interactive "e")
+ (when android-preedit-overlay
+ (delete-overlay android-preedit-overlay)
+ (setq android-preedit-overlay nil)
+ (remove-hook 'pre-command-hook #'android-clear-preedit-text))
+ (when (nth 1 event)
+ (let ((string (propertize (nth 1 event) 'face '(:underline t))))
+ (setq android-preedit-overlay (make-overlay (point) (point)))
+ (add-hook 'pre-command-hook #'android-clear-preedit-text)
+ (overlay-put android-preedit-overlay 'window (selected-window))
+ (overlay-put android-preedit-overlay 'before-string string))))
+
+(define-key special-event-map [preedit-text] 'android-preedit-text)
+
+
+;; Android cursor shapes, named according to the X scheme.
+;; Many X cursors are missing.
+
+(defconst x-pointer-arrow 1000)
+(defconst x-pointer-left-ptr 1000)
+(defconst x-pointer-left-side 1020)
+(defconst x-pointer-sb-h-double-arrow 1014)
+(defconst x-pointer-sb-v-double-arrow 1015)
+(defconst x-pointer-watch 1004)
+(defconst x-pointer-xterm 1008)
+(defconst x-pointer-invisible 0)
+
+
+;; Drag-and-drop. There are two formats of drag and drop event under
+;; Android. The data field of the first is set to a cons of X and Y,
+;; which represent a position within a frame that something is being
+;; dragged over, whereas that of the second is a cons of either symbol
+;; `uri' or `text' and a list of URIs or text to insert.
+;;
+;; If a content:// URI is encountered, then it in turn designates a
+;; file within the special-purpose /content/by-authority directory,
+;; which facilitates accessing such atypical files.
+
+(declare-function url-type "url-parse")
+(declare-function url-host "url-parse")
+(declare-function url-filename "url-parse")
+
+(defun android-handle-dnd-event (event)
+ "Respond to a drag-and-drop event EVENT.
+If it reflects the motion of an item above a frame, call
+`dnd-handle-movement' to move the cursor or scroll the window
+under the item pursuant to the pertinent user options.
+
+If it holds dropped text, insert such text within window at the
+location of the drop.
+
+If it holds a list of URIs, or file names, then open each URI or
+file name, converting content:// URIs into the special file
+names which represent them."
+ (interactive "e")
+ (let ((message (caddr event))
+ (posn (event-start event)))
+ (cond ((fixnump (car message))
+ (dnd-handle-movement posn))
+ ((eq (car message) 'text)
+ (let ((window (posn-window posn)))
+ (with-selected-window window
+ (unless mouse-yank-at-point
+ (goto-char (posn-point (event-start event))))
+ (dnd-insert-text window 'copy (cdr message)))))
+ ((eq (car message) 'uri)
+ (let ((uri-list (split-string (cdr message)
+ "[\0\r\n]" t))
+ (new-uri-list nil)
+ (dnd-unescape-file-uris t))
+ (dolist (uri uri-list)
+ ;; If the URI is a preprepared file name, insert it directly.
+ (if (string-match-p "^/content/by-authority\\(-named\\)?/" uri)
+ (setq uri (concat "file:" uri)
+ dnd-unescape-file-uris nil)
+ (ignore-errors
+ (let ((url (url-generic-parse-url uri)))
+ (when (equal (url-type url) "content")
+ ;; Replace URI with a matching /content file
+ ;; name.
+ (setq uri (format "file:/content/by-authority/%s%s"
+ (url-host url)
+ (url-filename url))
+ ;; And guarantee that this file URI is not
+ ;; subject to URI decoding, for it must be
+ ;; transformed back into a content URI.
+ dnd-unescape-file-uris nil)))))
+ (push uri new-uri-list))
+ (dnd-handle-multiple-urls (posn-window posn)
+ new-uri-list
+ 'copy))))))
+
+(define-key special-event-map [drag-n-drop] 'android-handle-dnd-event)
+
+
+;; Bind keys sent by input methods to manipulate the state of the
+;; selection to commands which set or deactivate the mark.
+
+(defun android-deactivate-mark-command ()
+ "Deactivate the mark in this buffer.
+This command is generally invoked by input methods sending
+the `stop-selecting-text' editing key."
+ (interactive)
+ (deactivate-mark))
+
+(global-set-key [select-all] 'mark-whole-buffer)
+(global-set-key [start-selecting-text] 'set-mark-command)
+(global-set-key [stop-selecting-text] 'android-deactivate-mark-command)
+
+
+;; Splash screen notice. Users are frequently left scratching their
+;; heads when they overlook the Android appendix in the Emacs manual
+;; and discover that external storage is not accessible; worse yet,
+;; Android 11 and later veil the settings panel controlling such
+;; permissions behind layer upon layer of largely immaterial settings
+;; panels, such that several modified copies of the Android Settings
+;; app have omitted them altogether after their developers conducted
+;; their own interface simplifications. Display a button on the
+;; splash screen that instructs users on granting these permissions
+;; when they are denied.
+
+(declare-function android-external-storage-available-p "androidfns.c")
+(declare-function android-request-storage-access "androidfns.c")
+(declare-function android-request-directory-access "androidfns.c")
+
+(defun android-display-storage-permission-popup (&optional _ignored)
+ "Display a dialog regarding storage permissions.
+Display a buffer explaining the need for storage permissions and
+offering to grant them."
+ (interactive)
+ (with-current-buffer (get-buffer-create "*Android Permissions*")
+ (setq buffer-read-only nil)
+ (erase-buffer)
+ (insert (propertize "Storage Access Permissions"
+ 'face '(bold (:height 1.2))))
+ (insert "
+
+Before Emacs can access your device's external storage
+directories, such as /sdcard and /storage/emulated/0, you must
+grant it permission to do so.
+
+Alternatively, you can request access to a particular directory
+in external storage, whereafter it will be available under the
+directory /content/storage.
+
+")
+ (insert-button "Grant storage permissions"
+ 'action (lambda (_)
+ (android-request-storage-access)
+ (quit-window)))
+ (newline)
+ (newline)
+ (insert-button "Request access to directory"
+ 'action (lambda (_)
+ (android-request-directory-access)))
+ (newline)
+ (special-mode)
+ (setq buffer-read-only t))
+ (let ((window (display-buffer "*Android Permissions*")))
+ (when (windowp window)
+ (with-selected-window window
+ ;; Fill the text to the width of this window in columns if it
+ ;; does not exceed 72, that the text might not be wrapped or
+ ;; truncated.
+ (when (<= (window-width window) 72)
+ (let ((fill-column (window-width window))
+ (inhibit-read-only t))
+ (fill-region (point-min) (point-max))))))))
+
+(defun android-before-splash-screen (fancy-p)
+ "Insert a brief notice on the absence of storage permissions.
+If storage permissions are as yet denied to Emacs, insert a short
+notice to that effect, followed by a button that enables the user
+to grant such permissions.
+
+FANCY-P non-nil means the notice will be displayed with faces, in
+the style appropriate for its incorporation within the fancy splash
+screen display; see `fancy-splash-insert'."
+ (unless (android-external-storage-available-p)
+ (if fancy-p
+ (fancy-splash-insert
+ :face '(variable-pitch
+ font-lock-function-call-face)
+ "Permissions necessary to access external storage directories have"
+ "\nbeen denied. Click "
+ :link '("here" android-display-storage-permission-popup)
+ " to grant them.\n")
+ (insert
+ "Permissions necessary to access external storage directories"
+ "\nhave been denied. ")
+ (insert-button "Click here to grant them.\n"
+ 'action #'android-display-storage-permission-popup
+ 'follow-link t)
+ (newline))))
+
+
+;;; Locale preferences.
+
+(defvar android-os-language)
+
+(defun android-locale-for-system-language ()
+ "Return a locale representing the system language.
+This locale reflects the system's language preferences in its
+language name and country variant fields, and always specifies
+the UTF-8 coding system."
+ ;; android-os-language is a list comprising four elements LANGUAGE,
+ ;; COUNTRY, SCRIPT, and VARIANT.
+ ;;
+ ;; LANGUAGE and COUNTRY are ISO language and country codes identical
+ ;; to those stored within POSIX locales.
+ ;;
+ ;; SCRIPT is an ISO 15924 script tag, representing the script used
+ ;; if available, or if required to disambiguate between distinct
+ ;; writing systems for the same combination of language and country.
+ ;;
+ ;; VARIANT is an arbitrary string representing the variant of the
+ ;; LANGUAGE or SCRIPT represented.
+ ;;
+ ;; Each of these fields might be empty, but the locale is invalid if
+ ;; LANGUAGE is empty, which if true "en_US.UTF-8" is returned as a
+ ;; placeholder.
+ (let ((language (or (nth 0 android-os-language) ""))
+ (country (or (nth 1 android-os-language) ""))
+ (script (or (nth 2 android-os-language) ""))
+ (variant (or (nth 3 android-os-language) ""))
+ locale-base locale-modifier)
+ (if (string-empty-p language)
+ (setq locale-base "en_US.UTF-8")
+ (if (string-empty-p country)
+ (setq locale-base (concat language ".UTF-8"))
+ (setq locale-base (concat language "_" country
+ ".UTF-8"))))
+ ;; No straightforward relation between Java script and variant
+ ;; combinations exist: Java permits both a script and a variant to
+ ;; be supplied at once, whereas POSIX's closest analog "modifiers"
+ ;; permit only either an alternative script or a variant to be
+ ;; supplied.
+ ;;
+ ;; Emacs disregards variants besides "EURO" and scripts besides
+ ;; "Cyrl", for these two never coexist in existing locales, and
+ ;; their POSIX equivalents are the sole modifiers recognized by
+ ;; Emacs.
+ (if (string-equal script "Cyrl")
+ (setq locale-modifier "@cyrillic")
+ (if (string-equal variant "EURO")
+ (setq locale-modifier "@euro")
+ (setq locale-modifier "")))
+ ;; Return the concatenation of both these values.
+ (concat locale-base locale-modifier)))
+
+
+;; Miscellaneous functions.
+
+(declare-function android-browse-url-internal "androidselect.c")
+
+(defun android-browse-url (url &optional send)
+ "Open URL in an external application.
+
+URL should be a URL-encoded URL with a scheme specified unless
+SEND is non-nil. Signal an error upon failure.
+
+If SEND is nil, start a program that is able to display the URL,
+such as a web browser. Otherwise, try to share URL using
+programs such as email clients.
+
+If URL is a file URI, convert it into a `content' address
+accessible to other programs."
+ (when-let* ((uri (url-generic-parse-url url))
+ (filename (url-filename uri))
+ ;; If `uri' is a file URI and the file resides in /content
+ ;; or /assets, copy it to a temporary file before
+ ;; providing it to other programs.
+ (replacement-url (and (string-match-p
+ "/\\(content\\|assets\\)[/$]"
+ filename)
+ (prog1 t
+ (copy-file
+ filename
+ (setq filename
+ (make-temp-file
+ "local"
+ nil
+ (let ((extension
+ (file-name-extension
+ filename)))
+ (if extension
+ (concat "."
+ extension)
+ nil))))
+ t))
+ (concat "file://" filename))))
+ (setq url replacement-url))
+ (android-browse-url-internal url send))
+
+
+;; Coding systems used by androidvfs.c.
+
+(define-ccl-program android-encode-jni
+ `(2 ((loop
+ (read r0)
+ (if (r0 < #x1) ; 0x0 is encoded specially in JNI environments.
+ ((write #xc0)
+ (write #x80))
+ ((if (r0 < #x80) ; ASCII
+ ((write r0))
+ (if (r0 < #x800) ; \u0080 - \u07ff
+ ((write ((r0 >> 6) | #xC0))
+ (write ((r0 & #x3F) | #x80)))
+ ;; \u0800 - \uFFFF
+ (if (r0 < #x10000)
+ ((write ((r0 >> 12) | #xE0))
+ (write (((r0 >> 6) & #x3F) | #x80))
+ (write ((r0 & #x3F) | #x80)))
+ ;; Supplementary characters must be converted into
+ ;; surrogate pairs before encoding.
+ (;; High surrogate
+ (r1 = ((((r0 - #x10000) >> 10) & #x3ff) + #xD800))
+ ;; Low surrogate.
+ (r2 = (((r0 - #x10000) & #x3ff) + #xDC00))
+ ;; Write both surrogate characters.
+ (write ((r1 >> 12) | #xE0))
+ (write (((r1 >> 6) & #x3F) | #x80))
+ (write ((r1 & #x3F) | #x80))
+ (write ((r2 >> 12) | #xE0))
+ (write (((r2 >> 6) & #x3F) | #x80))
+ (write ((r2 & #x3F) | #x80))))))))
+ (repeat))))
+ "Encode characters from the input buffer for Java virtual machines.")
+
+(define-ccl-program android-decode-jni
+ `(1 ((loop
+ ((read-if (r0 >= #x80) ; More than a one-byte sequence?
+ ((if (r0 < #xe0)
+ ;; Two-byte sequence; potentially a NULL
+ ;; character.
+ ((read r4)
+ (r4 &= #x3f)
+ (r0 = (((r0 & #x1f) << 6) | r4)))
+ (if (r0 < ?\xF0)
+ ;; Three-byte sequence, after which surrogate
+ ;; pairs should be processed.
+ ((read r4 r6)
+ (r4 = ((r4 & #x3f) << 6))
+ (r6 &= #x3f)
+ (r0 = ((((r0 & #xf) << 12) | r4) | r6)))
+ ;; Four-byte sequences are not valid under the
+ ;; JVM specification, but Android produces them
+ ;; when encoding Emoji characters for being
+ ;; supposedly less of a surprise to applications.
+ ;; This is obviously not true of programs written
+ ;; to the letter of the documentation, but 50
+ ;; million Frenchmen make a right (and this
+ ;; deviation from the norm is predictably absent
+ ;; from Android's documentation on the subject).
+ ((read r1 r4 r6)
+ (r1 = ((r1 & #x3f) << 12))
+ (r4 = ((r4 & #x3f) << 6))
+ (r6 &= #x3F)
+ (r0 = (((((r0 & #x07) << 18) | r1) | r4) | r6))))))))
+ (if ((r0 & #xf800) == #xd800)
+ ;; High surrogate.
+ ((read-if (r2 >= #xe0)
+ ((r0 = ((r0 & #x3ff) << 10))
+ (read r4 r6)
+ (r4 = ((r4 & #x3f) << 6))
+ (r6 &= #x3f)
+ (r1 = ((((r2 & #xf) << 12) | r4) | r6))
+ (r0 = (((r1 & #x3ff) | r0) + #xffff))))))
+ (write r0)
+ (repeat))))
+ "Decode JVM-encoded characters in the input buffer.")
+
+(define-coding-system 'android-jni
+ "CESU-8 based encoding for communication with the Android runtime."
+ :mnemonic ?J
+ :coding-type 'ccl
+ :eol-type 'unix
+ :ascii-compatible-p nil ; for \0 is encoded as a two-byte sequence.
+ :default-char ?\0
+ :charset-list '(unicode)
+ :ccl-decoder 'android-decode-jni
+ :ccl-encoder 'android-encode-jni)
+
+
+(provide 'android-win)
+;; android-win.el ends here.
diff --git a/lisp/term/bobcat.el b/lisp/term/bobcat.el
index 983c8cded2f..0c2eba486a3 100644
--- a/lisp/term/bobcat.el
+++ b/lisp/term/bobcat.el
@@ -3,8 +3,8 @@
(defun terminal-init-bobcat ()
"Terminal initialization function for bobcat."
;; HP terminals usually encourage using ^H as the rubout character
- (keyboard-translate ?\177 ?\^h)
- (keyboard-translate ?\^h ?\177))
+ (key-translate "DEL" "C-h")
+ (key-translate "C-h" "DEL"))
(provide 'term/bobcat)
diff --git a/lisp/term/haiku-win.el b/lisp/term/haiku-win.el
index adebab1b0b4..efc0a129062 100644
--- a/lisp/term/haiku-win.el
+++ b/lisp/term/haiku-win.el
@@ -36,6 +36,9 @@
(require 'menu-bar)
(require 'fontset)
(require 'dnd)
+;; For when building a --without-x configuration, where this is not
+;; preloaded.
+(eval-when-compile (require 'mwheel))
(add-to-list 'display-format-alist '(".*" . haiku))
@@ -366,14 +369,15 @@ or a pair of markers) and turns it into a file system reference."
((posn-area (event-start event)))
((assoc "refs" string)
(with-selected-window window
- (dolist (filename (cddr (assoc "refs" string)))
- (dnd-handle-one-url window action
- (concat "file:" filename)))))
+ (dnd-handle-multiple-urls
+ window (mapcar
+ (lambda (name) (concat "file:" name))
+ (cddr (assoc "refs" string)))
+ action)))
((assoc "text/uri-list" string)
(dolist (text (cddr (assoc "text/uri-list" string)))
(let ((uri-list (split-string text "[\0\r\n]" t)))
- (dolist (bf uri-list)
- (dnd-handle-one-url window action bf)))))
+ (dnd-handle-multiple-urls window uri-list action))))
((assoc "text/plain" string)
(with-selected-window window
(dolist (text (cddr (assoc "text/plain" string)))
diff --git a/lisp/term/ns-win.el b/lisp/term/ns-win.el
index acff6616ab9..2a29457133e 100644
--- a/lisp/term/ns-win.el
+++ b/lisp/term/ns-win.el
@@ -520,11 +520,12 @@ string dropped into the current buffer."
(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))))
+ (let ((urls (if (eq type 'file) (mapcar
+ (lambda (file)
+ (concat "file:" file))
+ objects)
+ objects)))
+ (dnd-handle-multiple-urls window urls 'private)))
(t
;; Insert the text as is.
(dnd-insert-text window 'private string))))))
diff --git a/lisp/term/pgtk-win.el b/lisp/term/pgtk-win.el
index 2e03e7f57a5..7999d348082 100644
--- a/lisp/term/pgtk-win.el
+++ b/lisp/term/pgtk-win.el
@@ -48,45 +48,6 @@
(declare-function pgtk-use-im-context "pgtkim.c")
-(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."
- (interactive "e")
- (let* ((window (posn-window (event-start event)))
- (arg (car (cdr (cdr event))))
- (type (car arg))
- (data (car (cdr arg)))
- (url-or-string (cond ((eq type 'file)
- (concat "file:" data))
- (t data))))
- (set-frame-selected-window nil window)
- (when new-frame
- (select-frame (make-frame)))
- (raise-frame)
- (setq window (selected-window))
- (if force-text
- (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
-the last file dropped is selected."
- (interactive "e")
- (pgtk-drag-n-drop event t))
-
-(defun pgtk-drag-n-drop-as-text (event)
- "Drop the data in EVENT as text."
- (interactive "e")
- (pgtk-drag-n-drop event nil t))
-
-(defun pgtk-drag-n-drop-as-text-other-frame (event)
- "Drop the data in EVENT as text in a new frame."
- (interactive "e")
- (pgtk-drag-n-drop event t t))
-
-(global-set-key [drag-n-drop] 'pgtk-drag-n-drop)
-
(defun pgtk-suspend-error ()
"Don't allow suspending if any of the frames are PGTK frames."
(if (memq 'pgtk (mapcar 'window-system (frame-list)))
@@ -392,7 +353,6 @@ Users should not call this function; see `device-class' instead."
(defvaralias 'x-gtk-use-system-tooltips 'use-system-tooltips)
-
(define-key special-event-map [drag-n-drop] #'pgtk-dnd-handle-drag-n-drop-event)
(add-hook 'after-make-frame-functions #'pgtk-dnd-init-frame)
diff --git a/lisp/term/w32-win.el b/lisp/term/w32-win.el
index 6119d88cca2..9b696475c34 100644
--- a/lisp/term/w32-win.el
+++ b/lisp/term/w32-win.el
@@ -117,12 +117,14 @@
(split-string (encode-coding-string f coding)
"/")
"/")))
- (dnd-handle-one-url window 'private
- (concat
- (if (eq system-type 'cygwin)
- "file://"
- "file:")
- file-name)))
+ ;; FIXME: is the W32 build capable only of receiving a single file
+ ;; from each drop?
+ (dnd-handle-multiple-urls window (list (concat
+ (if (eq system-type 'cygwin)
+ "file://"
+ "file:")
+ file-name))
+ 'private))
(defun w32-drag-n-drop (event &optional new-frame)
"Edit the files listed in the drag-n-drop EVENT.
diff --git a/lisp/term/xterm.el b/lisp/term/xterm.el
index def87dd47fa..82f9a60b53b 100644
--- a/lisp/term/xterm.el
+++ b/lisp/term/xterm.el
@@ -725,7 +725,7 @@ Return the pasted text as a string."
;; `tty-set-up-initial-frame-faces' only once, but that
;; caused the light background faces to be computed
;; incorrectly. See:
- ;; http://permalink.gmane.org/gmane.emacs.devel/119627
+ ;; https://lists.gnu.org/r/emacs-devel/2010-01/msg00439.html
(when recompute-faces
(tty-set-up-initial-frame-faces))))))
diff --git a/lisp/textmodes/artist.el b/lisp/textmodes/artist.el
index b0e2cfb46ba..b6029dc1ffd 100644
--- a/lisp/textmodes/artist.el
+++ b/lisp/textmodes/artist.el
@@ -2800,7 +2800,9 @@ EXTRA-ARGS for figlet, for the command line, may be specified."
(defun artist-figlet-get-font-list ()
"Read fonts in with the shell command.
Returns a list of strings."
- (let* ((cmd-interpreter "/bin/sh")
+ (let* ((cmd-interpreter (if (eq system-type 'android)
+ "/system/bin/sh"
+ "/bin/sh"))
(ls-cmd artist-figlet-list-fonts-command)
(result (artist-system cmd-interpreter ls-cmd nil))
(exit-code (elt result 0))
diff --git a/lisp/textmodes/bibtex.el b/lisp/textmodes/bibtex.el
index d78dac53516..a6da34d6a41 100644
--- a/lisp/textmodes/bibtex.el
+++ b/lisp/textmodes/bibtex.el
@@ -1837,7 +1837,7 @@ Initialized by `bibtex-set-dialect'.")
(bibtex-font-lock-url) (bibtex-font-lock-crossref)
;; cite
,@(mapcar (lambda (matcher)
- `((lambda (bound) (bibtex-font-lock-cite ',matcher bound))))
+ `(,(lambda (bound) (bibtex-font-lock-cite matcher bound))))
bibtex-cite-matcher-alist))
"Default expressions to highlight in BibTeX mode.")
@@ -1845,7 +1845,7 @@ Initialized by `bibtex-set-dialect'.")
;; Assume that field names begin at the beginning of a line.
(concat "^[ \t]*"
(regexp-opt (delete-dups (mapcar #'caar bibtex-generate-url-list)) t)
- "[ \t]*=[ \t]*")
+ "[ \t\n]*=[ \t\n]*")
"Regexp for `bibtex-font-lock-url' derived from `bibtex-generate-url-list'.")
(defvar bibtex-string-empty-key nil
@@ -2760,7 +2760,7 @@ Formats current entry according to variable `bibtex-entry-format'."
(setq error-field-name
(car (last (aref alt-fields idx))))
(user-error "Alternative mandatory fields `%s' are missing"
- (mapconcat 'identity
+ (mapconcat #'identity
(reverse
(aref alt-expect idx))
", ")))
@@ -2768,7 +2768,7 @@ Formats current entry according to variable `bibtex-entry-format'."
(setq error-field-name
(car (last (aref alt-fields idx))))
(user-error "Fields `%s' are alternatives"
- (mapconcat 'identity
+ (mapconcat #'identity
(reverse
(aref alt-fields idx))
", ")))))))
@@ -3624,7 +3624,7 @@ if that value is non-nil.
(unless bibtex-parse-idle-timer
(setq bibtex-parse-idle-timer (run-with-idle-timer
bibtex-parse-keys-timeout t
- 'bibtex-parse-buffers-stealthily)))
+ #'bibtex-parse-buffers-stealthily)))
(setq-local paragraph-start "[ \f\n\t]*$")
(setq-local comment-column 0)
(setq-local defun-prompt-regexp "^[ \t]*@[[:alnum:]]+[ \t]*")
@@ -3829,7 +3829,7 @@ for the templates of `bibtex-entry', whereas entry validation performed by
(if (and (nth 3 elt)
(<= 0 (nth 3 elt)))
(push (nth 3 elt) alt-list)))
- (setq alt-list (sort alt-list '<))
+ (setq alt-list (sort alt-list #'<))
;; Skip aliases. If ELT is marked as "proper alternative", but all
;; alternatives for field ELT are aliases, we do not label ELT
;; as an alternative either.
@@ -4641,7 +4641,7 @@ Return t if test was successful, nil otherwise."
(let ((file (file-name-nondirectory (buffer-file-name)))
(dir default-directory)
(err-buf "*BibTeX validation errors*"))
- (setq error-list (sort error-list 'car-less-than-car))
+ (setq error-list (sort error-list #'car-less-than-car))
(with-current-buffer (get-buffer-create err-buf)
(setq default-directory dir)
(unless (eq major-mode 'compilation-mode) (compilation-mode))
@@ -4714,7 +4714,7 @@ Return t if test was successful, nil otherwise."
(delete-region (point-min) (point-max))
(insert (substitute-command-keys
"BibTeX mode command `bibtex-validate-globally'\n\n"))
- (dolist (err (sort error-list 'string-lessp)) (insert err))
+ (dolist (err (sort error-list #'string-lessp)) (insert err))
(set-buffer-modified-p nil))
(goto-char (point-min))
(forward-line 2)) ; first error message
diff --git a/lisp/textmodes/conf-mode.el b/lisp/textmodes/conf-mode.el
index 382312f8b81..5e1636033f6 100644
--- a/lisp/textmodes/conf-mode.el
+++ b/lisp/textmodes/conf-mode.el
@@ -245,6 +245,7 @@ This variable is best set in the file local variables, or through
("^\\s-*\\(.+?\\)\\(?:\\[\\(.*?\\)\\]\\)?\\s-*="
(1 'font-lock-variable-name-face)
(2 'font-lock-constant-face nil t))
+ ;; Must be lower-case according to the TOML spec.
("\\_<false\\|true\\_>" 0 'font-lock-keyword-face))
"Keywords to highlight in Conf TOML mode.")
@@ -435,6 +436,7 @@ The optional arg FONT-LOCK is the value for FONT-LOCK-KEYWORDS."
(setq-local comment-start comment)
(setq-local comment-start-skip
(concat (regexp-quote comment-start) "+\\s *"))
+ (setq-local text-conversion-style t)
(if font-lock
(setq-local font-lock-defaults `(,font-lock nil t nil nil))))
@@ -643,7 +645,10 @@ For details see `conf-mode'. Example:
\[entry]
value = \"some string\""
- (conf-mode-initialize "#" 'conf-toml-font-lock-keywords)
+ (conf-mode-initialize "#")
+ ;; Booleans are "always lowercase", so we must *not* use case
+ ;; folding. Therefore, we can't set it using `conf-mode-initialize´.
+ (setq-local font-lock-defaults `(,conf-toml-font-lock-keywords nil nil nil nil))
(setq-local conf-assignment-column 0)
(setq-local conf-assignment-sign ?=))
diff --git a/lisp/textmodes/css-mode.el b/lisp/textmodes/css-mode.el
index 425f3ec8a30..f5a20e0ca0e 100644
--- a/lisp/textmodes/css-mode.el
+++ b/lisp/textmodes/css-mode.el
@@ -1830,6 +1830,8 @@ can also be used to fill comments.
(add-to-list 'auto-mode-alist '("\\.css\\'" . css-ts-mode))))
+(derived-mode-add-parents 'css-ts-mode '(css-mode))
+
;;;###autoload
(define-derived-mode css-mode css-base-mode "CSS"
"Major mode to edit Cascading Style Sheets (CSS).
diff --git a/lisp/textmodes/enriched.el b/lisp/textmodes/enriched.el
index 458cc3eb5da..385674f5b1a 100644
--- a/lisp/textmodes/enriched.el
+++ b/lisp/textmodes/enriched.el
@@ -3,7 +3,7 @@
;; Copyright (C) 1994-1996, 2001-2024 Free Software Foundation, Inc.
;; Author: Boris Goldowsky <boris@gnu.org>
-;; Keywords: wp, faces
+;; Keywords: text, faces
;; This file is part of GNU Emacs.
@@ -146,7 +146,7 @@ them and their old values to `enriched-old-bindings'."
:type 'hook)
(defcustom enriched-allow-eval-in-display-props nil
- "If non-nil allow to evaluate arbitrary forms in display properties.
+ "If non-nil, allow evaluating arbitrary forms in display properties.
Enriched mode recognizes display properties of text stored using
an extension command to the text/enriched format, \"x-display\".
diff --git a/lisp/textmodes/fill.el b/lisp/textmodes/fill.el
index da6385e70b3..29c56f8feaf 100644
--- a/lisp/textmodes/fill.el
+++ b/lisp/textmodes/fill.el
@@ -4,7 +4,7 @@
;; Software Foundation, Inc.
;; Maintainer: emacs-devel@gnu.org
-;; Keywords: wp
+;; Keywords: text
;; Package: emacs
;; This file is part of GNU Emacs.
@@ -103,7 +103,7 @@ reinserts the fill prefix in each resulting line."
;; Added `%' for TeX comments.
;; RMS: deleted the code to match `1.' and `(1)'.
;; Update mail-mode's paragraph-separate if you change this.
- (purecopy "[ \t]*\\([-–!|#%;>*·•‣⁃◦]+[ \t]*\\)*")
+ (purecopy "[-–!|#%;>*·•‣⁃◦ \t]*")
"Regexp to match text at start of line that constitutes indentation.
If Adaptive Fill mode is enabled, a prefix matching this pattern
on the first and second lines of a paragraph is used as the
diff --git a/lisp/textmodes/flyspell.el b/lisp/textmodes/flyspell.el
index 4a06dcd3390..09d4e8a8d1a 100644
--- a/lisp/textmodes/flyspell.el
+++ b/lisp/textmodes/flyspell.el
@@ -22,7 +22,7 @@
;; along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>.
;;; Commentary:
-;;
+
;; Flyspell is a minor Emacs mode performing on-the-fly spelling
;; checking.
;;
@@ -33,8 +33,7 @@
;; M-x flyspell-prog-mode.
;; In that mode only text inside comments and strings is checked.
;;
-;; Some user variables control the behavior of flyspell. They are
-;; those defined under the `User configuration' comment.
+;; Use `M-x customize-group RET flyspell RET' to customize flyspell.
;;; Code:
@@ -289,6 +288,15 @@ If this variable is nil, all regions are treated as small."
"The key binding for flyspell auto correction."
:type 'key-sequence)
+(defcustom flyspell-check-changes nil
+ "If non-nil, spell-check only words that were edited.
+By default, this is nil, and Flyspell checks every word across which
+you move point, even if you haven't edited the word. Customizing this
+option to a non-nil value will not flag mis-spelled words across which
+you move point without editing them."
+ :type 'boolean
+ :version "30.1")
+
;;*---------------------------------------------------------------------*/
;;* Mode specific options */
;;* ------------------------------------------------------------- */
@@ -411,18 +419,6 @@ like <img alt=\"Some thing.\">."
(run-hooks 'flyspell-prog-mode-hook))
;;*---------------------------------------------------------------------*/
-;;* Overlay compatibility */
-;;*---------------------------------------------------------------------*/
-(autoload 'make-overlay "overlay" "Overlay compatibility kit." t)
-(autoload 'overlayp "overlay" "Overlay compatibility kit." t)
-(autoload 'overlays-in "overlay" "Overlay compatibility kit." t)
-(autoload 'delete-overlay "overlay" "Overlay compatibility kit." t)
-(autoload 'overlays-at "overlay" "Overlay compatibility kit." t)
-(autoload 'overlay-put "overlay" "Overlay compatibility kit." t)
-(autoload 'overlay-get "overlay" "Overlay compatibility kit." t)
-(autoload 'previous-overlay-change "overlay" "Overlay compatibility kit." t)
-
-;;*---------------------------------------------------------------------*/
;;* The minor mode declaration. */
;;*---------------------------------------------------------------------*/
(defvar-keymap flyspell-mouse-map
@@ -529,10 +525,10 @@ in your init file.
:group 'flyspell
(if flyspell-mode
(condition-case err
- (flyspell-mode-on (called-interactively-p 'interactive))
+ (flyspell--mode-on (called-interactively-p 'interactive))
(error (message "Error enabling Flyspell mode:\n%s" (cdr err))
(flyspell-mode -1)))
- (flyspell-mode-off)))
+ (flyspell--mode-off)))
;;;###autoload
(defun turn-on-flyspell ()
@@ -597,14 +593,14 @@ in your init file.
(kill-local-variable 'flyspell-word-cache-word))))
;; Make sure we flush our caches when needed. Do it here rather than in
-;; flyspell-mode-on, since flyspell-region may be used without ever turning
+;; flyspell--mode-on, since flyspell-region may be used without ever turning
;; on flyspell-mode.
(add-hook 'ispell-kill-ispell-hook 'flyspell-kill-ispell-hook)
;;*---------------------------------------------------------------------*/
-;;* flyspell-mode-on ... */
+;;* flyspell--mode-on ... */
;;*---------------------------------------------------------------------*/
-(defun flyspell-mode-on (&optional show-msg)
+(defun flyspell--mode-on (&optional show-msg)
"Turn Flyspell mode on. Do not use this; use `flyspell-mode' instead.
If optional argument SHOW-MSG is non-nil, show a welcome message
@@ -612,7 +608,6 @@ if `flyspell-issue-message-flag' and `flyspell-issue-welcome-flag'
are both non-nil."
(ispell-set-spellchecker-params) ; Initialize variables and dicts alists
(setq ispell-highlight-face 'flyspell-incorrect)
- ;; local dictionaries setup
(or ispell-local-dictionary ispell-dictionary
(if flyspell-default-dictionary
(ispell-change-dictionary flyspell-default-dictionary)))
@@ -622,24 +617,18 @@ are both non-nil."
;; Pass the `force' argument for the case where flyspell was active already
;; but the buffer's local-defs have been edited.
(flyspell-accept-buffer-local-defs 'force)
- ;; we put the `flyspell-delayed' property on some commands
(flyspell-delay-commands)
- ;; we put the `flyspell-deplacement' property on some commands
(flyspell-deplacement-commands)
- ;; we bound flyspell action to post-command hook
- (add-hook 'post-command-hook (function flyspell-post-command-hook) t t)
- ;; we bound flyspell action to pre-command hook
+ (if flyspell-check-changes
+ (add-hook 'post-command-hook (function flyspell-check-changes) t t)
+ (add-hook 'post-command-hook (function flyspell-post-command-hook) t t))
(add-hook 'pre-command-hook (function flyspell-pre-command-hook) t t)
- ;; we bound flyspell action to after-change hook
(add-hook 'after-change-functions 'flyspell-after-change-function nil t)
- ;; we bound flyspell action to hack-local-variables-hook
(add-hook 'hack-local-variables-hook
(function flyspell-hack-local-variables-hook) t t)
- ;; set flyspell-generic-check-word-predicate based on the major mode
(let ((mode-predicate (get major-mode 'flyspell-mode-predicate)))
(if mode-predicate
(setq flyspell-generic-check-word-predicate mode-predicate)))
- ;; the welcome message
(if (and flyspell-issue-message-flag
flyspell-issue-welcome-flag
show-msg)
@@ -726,23 +715,20 @@ has been used, the current word is not checked."
(setq flyspell-pre-column (current-column)))
;;*---------------------------------------------------------------------*/
-;;* flyspell-mode-off ... */
+;;* flyspell--mode-off ... */
;;*---------------------------------------------------------------------*/
;;;###autoload
-(defun flyspell-mode-off ()
+(defun flyspell--mode-off ()
"Turn Flyspell mode off."
- ;; We remove the hooks.
+ (remove-hook 'post-command-hook (function flyspell-check-changes) t)
(remove-hook 'post-command-hook (function flyspell-post-command-hook) t)
(remove-hook 'pre-command-hook (function flyspell-pre-command-hook) t)
(remove-hook 'after-change-functions 'flyspell-after-change-function t)
(remove-hook 'hack-local-variables-hook
(function flyspell-hack-local-variables-hook) t)
- ;; We remove all the flyspell highlightings.
(flyspell-delete-all-overlays)
- ;; We have to erase pre cache variables.
(setq flyspell-pre-buffer nil)
(setq flyspell-pre-point nil)
- ;; We mark the mode as killed.
(setq flyspell-mode nil))
;;*---------------------------------------------------------------------*/
@@ -1016,6 +1002,23 @@ Mostly we check word delimiters."
(setq flyspell-changes (cdr flyspell-changes))))
(setq flyspell-previous-command command)))))
+(defun flyspell-check-changes ()
+ "Function to spell-check only edited words when point moves off the word.
+This is installed by flyspell as `post-command-hook' when the user
+option `flyspell-check-changes' is non-nil. It spell-checks a word
+on moving point from the word only if the word was edited before the move."
+ (when flyspell-mode
+ (with-local-quit
+ (when (consp flyspell-changes)
+ (let ((start (car (car flyspell-changes)))
+ (stop (cdr (car flyspell-changes)))
+ (word (save-excursion (flyspell-get-word))))
+ (unless (and word (<= (nth 1 word) start) (>= (nth 2 word) stop))
+ (save-excursion
+ (goto-char start)
+ (flyspell-word))
+ (setq flyspell-changes nil)))))))
+
;;*---------------------------------------------------------------------*/
;;* flyspell-notify-misspell ... */
;;*---------------------------------------------------------------------*/
@@ -2381,6 +2384,9 @@ This function is meant to be added to `flyspell-incorrect-hook'."
(defun flyspell-change-abbrev (table old new)
(set (abbrev-symbol old table) new))
+(define-obsolete-function-alias 'flyspell-mode-on 'flyspell--mode-on "30.1")
+(define-obsolete-function-alias 'flyspell-mode-off 'flyspell--mode-off "30.1")
+
(provide 'flyspell)
;;; flyspell.el ends here
diff --git a/lisp/textmodes/glyphless-mode.el b/lisp/textmodes/glyphless-mode.el
index 94c122239c0..6f8363a3b67 100644
--- a/lisp/textmodes/glyphless-mode.el
+++ b/lisp/textmodes/glyphless-mode.el
@@ -30,7 +30,6 @@ The value can be any of the groups supported by
`all', for all glyphless characters."
:version "29.1"
:type '(repeat (choice (const :tag "All" all)
- (const :tag "No font" no-font)
(const :tag "C0 Control" c0-control)
(const :tag "C1 Control" c1-control)
(const :tag "Format Control" format-control)
diff --git a/lisp/textmodes/html-ts-mode.el b/lisp/textmodes/html-ts-mode.el
new file mode 100644
index 00000000000..235e1055fa9
--- /dev/null
+++ b/lisp/textmodes/html-ts-mode.el
@@ -0,0 +1,144 @@
+;;; html-ts-mode.el --- tree-sitter support for HTML -*- lexical-binding: t; -*-
+
+;; Copyright (C) 2023-2024 Free Software Foundation, Inc.
+
+;; Author : Theodor Thornhill <theo@thornhill.no>
+;; Maintainer : Theodor Thornhill <theo@thornhill.no>
+;; Created : January 2023
+;; Keywords : html languages tree-sitter
+
+;; This file is part of GNU Emacs.
+
+;; GNU Emacs is free software: you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+
+;; GNU Emacs is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>.
+
+;;; Commentary:
+;;
+
+;;; Code:
+
+(require 'treesit)
+(require 'sgml-mode)
+
+(declare-function treesit-parser-create "treesit.c")
+(declare-function treesit-node-type "treesit.c")
+
+(defcustom html-ts-mode-indent-offset 2
+ "Number of spaces for each indentation step in `html-ts-mode'."
+ :version "29.1"
+ :type 'integer
+ :safe 'integerp
+ :group 'html)
+
+(defvar html-ts-mode--indent-rules
+ `((html
+ ((parent-is "fragment") column-0 0)
+ ((node-is "/>") parent-bol 0)
+ ((node-is ">") parent-bol 0)
+ ((node-is "end_tag") parent-bol 0)
+ ((parent-is "comment") prev-adaptive-prefix 0)
+ ((parent-is "element") parent-bol html-ts-mode-indent-offset)
+ ((parent-is "script_element") parent-bol html-ts-mode-indent-offset)
+ ((parent-is "style_element") parent-bol html-ts-mode-indent-offset)
+ ((parent-is "start_tag") parent-bol html-ts-mode-indent-offset)
+ ((parent-is "self_closing_tag") parent-bol html-ts-mode-indent-offset)))
+ "Tree-sitter indent rules.")
+
+(defvar html-ts-mode--font-lock-settings
+ (treesit-font-lock-rules
+ :language 'html
+ :override t
+ :feature 'comment
+ `((comment) @font-lock-comment-face)
+ :language 'html
+ :override t
+ :feature 'keyword
+ `("doctype" @font-lock-keyword-face)
+ :language 'html
+ :override t
+ :feature 'definition
+ `((tag_name) @font-lock-function-name-face)
+ :language 'html
+ :override t
+ :feature 'string
+ `((quoted_attribute_value) @font-lock-string-face)
+ :language 'html
+ :override t
+ :feature 'property
+ `((attribute_name) @font-lock-variable-name-face))
+ "Tree-sitter font-lock settings for `html-ts-mode'.")
+
+(defun html-ts-mode--defun-name (node)
+ "Return the defun name of NODE.
+Return nil if there is no name or if NODE is not a defun node."
+ (when (equal (treesit-node-type node) "tag_name")
+ (treesit-node-text node t)))
+
+;;;###autoload
+(define-derived-mode html-ts-mode html-mode "HTML"
+ "Major mode for editing Html, powered by tree-sitter."
+ :group 'html
+
+ (unless (treesit-ready-p 'html)
+ (error "Tree-sitter for HTML isn't available"))
+
+ (treesit-parser-create 'html)
+
+ ;; Indent.
+ (setq-local treesit-simple-indent-rules html-ts-mode--indent-rules)
+
+ ;; Navigation.
+ (setq-local treesit-defun-type-regexp "element")
+
+ (setq-local treesit-defun-name-function #'html-ts-mode--defun-name)
+
+ (setq-local treesit-thing-settings
+ `((html
+ (sexp ,(regexp-opt '("element"
+ "text"
+ "attribute"
+ "value")))
+ (sentence "tag")
+ (text ,(regexp-opt '("comment" "text"))))))
+
+ ;; Font-lock.
+ (setq-local treesit-font-lock-settings html-ts-mode--font-lock-settings)
+ (setq-local treesit-font-lock-feature-list
+ '((comment keyword definition)
+ (property string)
+ () ()))
+
+ ;; Imenu.
+ (setq-local treesit-simple-imenu-settings
+ '(("Element" "\\`tag_name\\'" nil nil)))
+
+ ;; Outline minor mode.
+ (setq-local treesit-outline-predicate "\\`element\\'")
+ ;; `html-ts-mode' inherits from `html-mode' that sets
+ ;; regexp-based outline variables. So need to restore
+ ;; the default values of outline variables to be able
+ ;; to use `treesit-outline-predicate' above.
+ (kill-local-variable 'outline-regexp)
+ (kill-local-variable 'outline-heading-end-regexp)
+ (kill-local-variable 'outline-level)
+
+ (treesit-major-mode-setup))
+
+(derived-mode-add-parents 'html-ts-mode '(html-mode))
+
+(if (treesit-ready-p 'html)
+ (add-to-list 'auto-mode-alist '("\\.html\\'" . html-ts-mode)))
+
+(provide 'html-ts-mode)
+
+;;; html-ts-mode.el ends here
diff --git a/lisp/textmodes/ispell.el b/lisp/textmodes/ispell.el
index 08a7b816de3..17af1f1d926 100644
--- a/lisp/textmodes/ispell.el
+++ b/lisp/textmodes/ispell.el
@@ -1756,6 +1756,7 @@ Ispell is then restarted because the local words could conflict.")
(defvar-local ispell-buffer-session-localwords nil
"List of words accepted for session in this buffer.")
+(put 'ispell-buffer-session-localwords 'safe-local-variable #'list-of-strings-p)
(defvar ispell-parser 'use-mode-name
"Indicates whether ispell should parse the current buffer as TeX Code.
@@ -3688,6 +3689,27 @@ If APPEND is non-nil, don't erase previous debugging output."
(if (>= column (- (window-width) 2))
(scroll-left (max (- column (window-width) -3) 10)))))))
+;;;###autoload
+(defun ispell-completion-at-point ()
+ "Word completion function for use in `completion-at-point-functions'."
+ (pcase (bounds-of-thing-at-point 'word)
+ (`(,beg . ,end)
+ (when (and (< beg (point)) (<= (point) end))
+ (let* ((word (buffer-substring-no-properties beg end))
+ (len (length word))
+ (inhibit-message t)
+ (all (cons word (ispell-lookup-words word)))
+ (cur all))
+ (while cur
+ (unless (string-prefix-p word (car cur))
+ (setcar cur (concat word (substring (car cur) len))))
+ (while (when-let ((next (cadr cur)))
+ (not (string-prefix-p word next t)))
+ (setcdr cur (cddr cur)))
+ (setq cur (cdr cur)))
+ (list beg end (cdr all)
+ :exclusive 'no))))))
+
;;; Interactive word completion.
;; Forces "previous-word" processing. Do we want to make this selectable?
@@ -3704,7 +3726,6 @@ This command uses a word-list file specified
by `ispell-alternate-dictionary' or by `ispell-complete-word-dict';
if none of those name an existing word-list file, this command
signals an error."
- ;; FIXME: completion-at-point-function.
(interactive "P")
(let ((case-fold-search-val case-fold-search)
(word (ispell-get-word nil "\\*")) ; force "previous-word" processing.
diff --git a/lisp/textmodes/less-css-mode.el b/lisp/textmodes/less-css-mode.el
index 90a4a5b6681..198f067f1d8 100644
--- a/lisp/textmodes/less-css-mode.el
+++ b/lisp/textmodes/less-css-mode.el
@@ -215,7 +215,7 @@ directory by default."
;;;###autoload (add-to-list 'auto-mode-alist '("\\.less\\'" . less-css-mode))
;;;###autoload
(define-derived-mode less-css-mode css-mode "Less"
- "Major mode for editing Less files (http://lesscss.org/).
+ "Major mode for editing Less files (https://lesscss.org/).
Special commands:
\\{less-css-mode-map}"
(font-lock-add-keywords nil less-css-font-lock-keywords)
diff --git a/lisp/textmodes/mhtml-mode.el b/lisp/textmodes/mhtml-mode.el
index 4d45541c06a..0b5c6756ab9 100644
--- a/lisp/textmodes/mhtml-mode.el
+++ b/lisp/textmodes/mhtml-mode.el
@@ -2,7 +2,7 @@
;; Copyright (C) 2017-2024 Free Software Foundation, Inc.
-;; Keywords: wp, hypermedia, comm, languages
+;; Keywords: text, hypermedia, comm, languages
;; This file is part of GNU Emacs.
diff --git a/lisp/textmodes/nroff-mode.el b/lisp/textmodes/nroff-mode.el
index 415e2df614f..026d37f1b74 100644
--- a/lisp/textmodes/nroff-mode.el
+++ b/lisp/textmodes/nroff-mode.el
@@ -3,7 +3,7 @@
;; Copyright (C) 1985-2024 Free Software Foundation, Inc.
;; Maintainer: emacs-devel@gnu.org
-;; Keywords: wp
+;; Keywords: text
;; This file is part of GNU Emacs.
diff --git a/lisp/textmodes/page-ext.el b/lisp/textmodes/page-ext.el
index 148cc99e9ea..f5f59adb0cf 100644
--- a/lisp/textmodes/page-ext.el
+++ b/lisp/textmodes/page-ext.el
@@ -4,7 +4,7 @@
;; Author: Robert J. Chassell <bob@gnu.org>
;; (according to ack.texi)
-;; Keywords: wp data
+;; Keywords: text data
;; This file is part of GNU Emacs.
diff --git a/lisp/textmodes/page.el b/lisp/textmodes/page.el
index 537260e1843..a5de354fc0a 100644
--- a/lisp/textmodes/page.el
+++ b/lisp/textmodes/page.el
@@ -3,7 +3,7 @@
;; Copyright (C) 1985, 2001-2024 Free Software Foundation, Inc.
;; Maintainer: emacs-devel@gnu.org
-;; Keywords: wp convenience
+;; Keywords: text convenience
;; Package: emacs
;; This file is part of GNU Emacs.
@@ -159,21 +159,23 @@ point, respectively."
total before after)))
(defun page--what-page ()
- "Return a list of the page and line number of point."
+ "Return a list of the page and line number of point.
+The line number is relative to the start of the page."
(save-restriction
(widen)
(save-excursion
(let ((count 1)
+ (adjust (if (or (bolp) (looking-back page-delimiter nil)) 1 0))
(opoint (point)))
(goto-char (point-min))
(while (re-search-forward page-delimiter opoint t)
(when (= (match-beginning 0) (match-end 0))
(forward-char))
(setq count (1+ count)))
- (list count (line-number-at-pos opoint))))))
+ (list count (+ adjust (count-lines (point) opoint)))))))
(defun what-page ()
- "Print page and line number of point."
+ "Display the page number, and the line number within that page."
(interactive)
(apply #'message (cons "Page %d, line %d" (page--what-page))))
diff --git a/lisp/textmodes/paragraphs.el b/lisp/textmodes/paragraphs.el
index ad063a6b790..af99a96e045 100644
--- a/lisp/textmodes/paragraphs.el
+++ b/lisp/textmodes/paragraphs.el
@@ -4,7 +4,7 @@
;; Foundation, Inc.
;; Maintainer: emacs-devel@gnu.org
-;; Keywords: wp
+;; Keywords: text
;; Package: emacs
;; This file is part of GNU Emacs.
@@ -440,13 +440,12 @@ the current paragraph with the one containing the mark."
(if (< (point) (point-max))
(end-of-paragraph-text))))))
-(defun forward-sentence (&optional arg)
+(defun forward-sentence-default-function (&optional arg)
"Move forward to next end of sentence. With argument, repeat.
When ARG is negative, move backward repeatedly to start of sentence.
The variable `sentence-end' is a regular expression that matches ends of
sentences. Also, every paragraph boundary terminates sentences as well."
- (interactive "^p")
(or arg (setq arg 1))
(let ((opoint (point))
(sentence-end (sentence-end)))
@@ -478,6 +477,18 @@ sentences. Also, every paragraph boundary terminates sentences as well."
(setq arg (1- arg)))
(constrain-to-field nil opoint t)))
+(defvar forward-sentence-function #'forward-sentence-default-function
+ "Function to be used to calculate sentence movements.
+See `forward-sentence' for a description of its behavior.")
+
+(defun forward-sentence (&optional arg)
+ "Move forward to next end of sentence. With argument ARG, repeat.
+If ARG is negative, move backward repeatedly to start of
+sentence. Delegates its work to `forward-sentence-function'."
+ (interactive "^p")
+ (or arg (setq arg 1))
+ (funcall forward-sentence-function arg))
+
(defun count-sentences (start end)
"Count sentences in current buffer from START to END."
(let ((sentences 0)
diff --git a/lisp/textmodes/picture.el b/lisp/textmodes/picture.el
index 988e345d146..adb06cb6a29 100644
--- a/lisp/textmodes/picture.el
+++ b/lisp/textmodes/picture.el
@@ -4,7 +4,7 @@
;; Author: K. Shane Hartman
;; Maintainer: emacs-devel@gnu.org
-;; Keywords: convenience wp
+;; Keywords: convenience text
;; This file is part of GNU Emacs.
@@ -383,7 +383,7 @@ Interactively, ARG is the numeric argument, and defaults to 1."
The syntax for this variable is like the syntax used inside of `[...]'
in a regular expression--but without the `[' and the `]'.
It is NOT a regular expression, and should follow the usual
-rules for the contents of a character alternative.
+rules for the contents of a bracket expression.
It defines a set of \"interesting characters\" to look for when setting
\(or searching for) tab stops, initially \"!-~\" (all printing characters).
For example, suppose that you are editing a table which is formatted thus:
diff --git a/lisp/textmodes/refill.el b/lisp/textmodes/refill.el
index 937a8ed250d..63789e887e2 100644
--- a/lisp/textmodes/refill.el
+++ b/lisp/textmodes/refill.el
@@ -4,7 +4,7 @@
;; Author: Dave Love <fx@gnu.org>
;; Maintainer: Miles Bader <miles@gnu.org>
-;; Keywords: wp
+;; Keywords: text
;; This file is part of GNU Emacs.
@@ -106,10 +106,10 @@ This is used to optimize refilling.")
;; FIXME: forward-paragraph seems to disregard `use-hard-newlines',
;; leading to excessive refilling and wrong choice of fill-prefix.
;; might be a bug in my paragraphs.el.
- (forward-paragraph)
+ (fill-forward-paragraph 1)
(skip-syntax-backward "-")
(let ((end (point))
- (beg (progn (backward-paragraph) (point)))
+ (beg (progn (fill-forward-paragraph -1) (point)))
(obeg (overlay-start refill-ignorable-overlay))
(oend (overlay-end refill-ignorable-overlay)))
(unless (> beg pos) ;Don't fill if point is outside the paragraph.
diff --git a/lisp/textmodes/reftex-cite.el b/lisp/textmodes/reftex-cite.el
index df63005e1a9..f7b155874de 100644
--- a/lisp/textmodes/reftex-cite.el
+++ b/lisp/textmodes/reftex-cite.el
@@ -566,7 +566,7 @@ If FORMAT is non-nil `format' entry accordingly."
(reftex-get-bib-field "booktitle" entry "in: %s"))
(t ""))))
(setq authors (reftex-truncate authors 30 t t))
- (when (reftex-use-fonts)
+ (when reftex-use-fonts
(put-text-property 0 (length key) 'face reftex-label-face
key)
(put-text-property 0 (length authors) 'face reftex-bib-author-face
@@ -609,7 +609,7 @@ If FORMAT is non-nil `format' entry accordingly."
(push text lines)
(setq text (mapconcat #'identity (nreverse lines) "\n "))
- (when (reftex-use-fonts)
+ (when reftex-use-fonts
(put-text-property 0 (length text) 'face reftex-bib-author-face text))
(concat key "\n " text "\n\n")))
diff --git a/lisp/textmodes/reftex-global.el b/lisp/textmodes/reftex-global.el
index 6f02884858c..0eaffec3b54 100644
--- a/lisp/textmodes/reftex-global.el
+++ b/lisp/textmodes/reftex-global.el
@@ -39,8 +39,10 @@ The TAGS file is also immediately visited with `visit-tags-table'."
(reftex-access-scan-info current-prefix-arg)
(let* ((master (reftex-TeX-master-file))
(files (reftex-all-document-files))
- (cmd (format "etags %s" (mapconcat #'shell-quote-argument
- files " "))))
+ (cmd (format "%s %s"
+ etags-program-name
+ (mapconcat #'shell-quote-argument
+ files " "))))
(with-current-buffer (reftex-get-file-buffer-force master)
(message "Running etags to create TAGS file...")
(shell-command cmd)
diff --git a/lisp/textmodes/reftex-index.el b/lisp/textmodes/reftex-index.el
index d39c85a6e80..a93afd63855 100644
--- a/lisp/textmodes/reftex-index.el
+++ b/lisp/textmodes/reftex-index.el
@@ -536,14 +536,10 @@ SPC=view TAB=goto RET=goto+hide [e]dit [q]uit [r]escan [f]ollow [?]Help
(nth 2 (car reftex-index-restriction-data))
reftex-index-restriction-indicator)))
- (if (reftex-use-fonts)
+ (if reftex-use-fonts
(put-text-property (point-min) (point)
'face reftex-index-header-face))
- (if (fboundp 'cursor-intangible-mode)
- (cursor-intangible-mode 1)
- ;; If `cursor-intangible' is not available, fallback on the old
- ;; intrusive `intangible' property.
- (put-text-property (point-min) (point) 'intangible t))
+ (cursor-intangible-mode 1)
(add-text-properties (point-min) (point)
'(cursor-intangible t
front-sticky (cursor-intangible)
@@ -571,7 +567,7 @@ SPC=view TAB=goto RET=goto+hide [e]dit [q]uit [r]escan [f]ollow [?]Help
(context-indent (concat indent " "))
(section-chars (mapcar #'identity reftex-index-section-letters))
(this-section-char 0)
- (font (reftex-use-fonts))
+ (font reftex-use-fonts)
(bor (car reftex-index-restriction-data))
(eor (nth 1 reftex-index-restriction-data))
(mouse-face
@@ -1445,20 +1441,19 @@ match, the user will be asked to confirm the replacement."
(as-words reftex-index-phrases-search-whole-words))
(unless macro-data
(error "No macro associated with key %c" char))
- (unwind-protect
- (let ((overlay-arrow-string "=>")
- (overlay-arrow-position
- reftex-index-phrases-marker)
- (replace-count 0))
- ;; Show the overlay arrow
- (move-marker reftex-index-phrases-marker
- (match-beginning 0) (current-buffer))
- ;; Start the query-replace
- (reftex-query-index-phrase-globally
- files phrase macro-fmt
- index-key repeat as-words)
- (message "%s replaced"
- (reftex-number replace-count "occurrence"))))))
+ (let ((overlay-arrow-string "=>")
+ (overlay-arrow-position
+ reftex-index-phrases-marker)
+ (replace-count 0))
+ ;; Show the overlay arrow
+ (move-marker reftex-index-phrases-marker
+ (match-beginning 0) (current-buffer))
+ ;; Start the query-replace
+ (reftex-query-index-phrase-globally
+ files phrase macro-fmt
+ index-key repeat as-words)
+ (message "%s replaced"
+ (reftex-number replace-count "occurrence")))))
(t (error "Cannot parse this line")))))
(defun reftex-index-all-phrases ()
diff --git a/lisp/textmodes/reftex-ref.el b/lisp/textmodes/reftex-ref.el
index c16ba003378..8dab7e6c48f 100644
--- a/lisp/textmodes/reftex-ref.el
+++ b/lisp/textmodes/reftex-ref.el
@@ -495,7 +495,7 @@ When called with 2 \\[universal-argument] prefix args, disable magic word recogn
sep1 (cdr (assoc sep reftex-multiref-punctuation))
labels (cdr labels))
(when cut
- (backward-delete-char cut)
+ (delete-char (- cut))
(setq cut nil))
;; remove ~ if we do already have a space
@@ -781,10 +781,9 @@ When called with 2 \\[universal-argument] prefix args, disable magic word recogn
(funcall errorf "Label %s not found" label))
found)))
-(defvar font-lock-mode)
(defun reftex-show-entry (beg-hlt end-hlt)
;; Show entry if point is hidden
- (let* ((n (/ (reftex-window-height) 2))
+ (let* ((n (/ (window-height) 2))
(beg (save-excursion
(re-search-backward "[\n\r]" nil 1 n) (point)))
(end (save-excursion
diff --git a/lisp/textmodes/reftex-sel.el b/lisp/textmodes/reftex-sel.el
index ff227cf7ef0..fa36543daf4 100644
--- a/lisp/textmodes/reftex-sel.el
+++ b/lisp/textmodes/reftex-sel.el
@@ -204,7 +204,7 @@ During a selection process, these are the local bindings.
;; a used member near to this one, as a possible starting point.
;; XR-PREFIX is the prefix to put in front of labels.
;; TOC-BUFFER means this is to fill the toc buffer.
- (let* ((font (reftex-use-fonts))
+ (let* ((font reftex-use-fonts)
(cnt 0)
(index -1)
(toc-indent " ")
diff --git a/lisp/textmodes/reftex-toc.el b/lisp/textmodes/reftex-toc.el
index 189795486ab..1cc6e27e780 100644
--- a/lisp/textmodes/reftex-toc.el
+++ b/lisp/textmodes/reftex-toc.el
@@ -215,9 +215,7 @@ When called with a raw \\[universal-argument] prefix, rescan the document first.
(here-I-am (if reftex--rebuilding-toc
(get 'reftex-toc :reftex-data)
(car (reftex-where-am-I))))
- (unsplittable (if (fboundp 'frame-property)
- (frame-property (selected-frame) 'unsplittable)
- (frame-parameter nil 'unsplittable)))
+ (unsplittable (frame-parameter nil 'unsplittable))
offset toc-window)
(if (setq toc-window (get-buffer-window
@@ -265,13 +263,9 @@ SPC=view TAB=goto RET=goto+hide [q]uit [r]escan [l]abels [f]ollow [x]r [?]Help
------------------------------------------------------------------------------
" (abbreviate-file-name reftex-last-toc-master)))
- (if (reftex-use-fonts)
+ (if reftex-use-fonts
(put-text-property (point-min) (point) 'font-lock-face reftex-toc-header-face))
- (if (fboundp 'cursor-intangible-mode)
- (cursor-intangible-mode 1)
- ;; If `cursor-intangible' is not available, fallback on the old
- ;; intrusive `intangible' property.
- (put-text-property (point-min) (point) 'intangible t))
+ (cursor-intangible-mode 1)
(add-text-properties (point-min) (point)
'(cursor-intangible t
front-sticky (cursor-intangible)
@@ -385,11 +379,8 @@ SPC=view TAB=goto RET=goto+hide [q]uit [r]escan [l]abels [f]ollow [x]r [?]Help
;; Check if FRAME is the dedicated TOC frame.
;; If yes, and ERROR is non-nil, throw an error.
(setq frame (or frame (selected-frame)))
- (let ((res (equal
- (if (fboundp 'frame-property)
- (frame-property frame 'name)
- (frame-parameter frame 'name))
- "RefTeX TOC Frame")))
+ (let ((res (equal (frame-parameter frame 'name)
+ "RefTeX TOC Frame")))
(if (and res error)
(error (substitute-command-keys
"This frame is view-only. Use \\[reftex-toc] \
@@ -586,10 +577,7 @@ With prefix arg 1, restrict index to the section at point."
(defun reftex-toc-revert (&rest _)
"Regenerate the TOC from the internal lists."
(interactive)
- (let ((unsplittable
- (if (fboundp 'frame-property)
- (frame-property (selected-frame) 'unsplittable)
- (frame-parameter nil 'unsplittable)))
+ (let ((unsplittable (frame-parameter nil 'unsplittable))
(reftex--rebuilding-toc t))
(if unsplittable
(switch-to-buffer
@@ -1036,12 +1024,9 @@ always show the current section in connection with the option
`reftex-auto-recenter-toc'."
(interactive)
(catch 'exit
- (let* ((frames (frame-list)) frame
- (get-frame-prop-func (if (fboundp 'frame-property)
- 'frame-property
- 'frame-parameter)))
+ (let* ((frames (frame-list)) frame)
(while (setq frame (pop frames))
- (if (equal (funcall get-frame-prop-func frame 'name)
+ (if (equal (frame-parameter frame 'name)
"RefTeX TOC Frame")
(progn
(delete-frame frame)
diff --git a/lisp/textmodes/reftex-vars.el b/lisp/textmodes/reftex-vars.el
index f4251043158..791b10412c9 100644
--- a/lisp/textmodes/reftex-vars.el
+++ b/lisp/textmodes/reftex-vars.el
@@ -235,11 +235,10 @@ distribution. Mixed-case symbols are convenience aliases.")
"ConTeXt bib module"
((?\C-m . "\\cite[%l]")
(?s . "\\cite[][%l]")
- (?n . "\\nocite[%l]")))
- )
+ (?n . "\\nocite[%l]"))))
"Builtin versions of the citation format.
The following conventions are valid for all alist entries:
-`?\C-m' should always point to a straight \\cite{%l} macro.
+`?\\C-m' should always point to a straight \\cite{%l} macro.
`?t' should point to a textual citation (citation as a noun).
`?p' should point to a parenthetical citation.")
@@ -1156,7 +1155,7 @@ immediately offer the correct label menu - otherwise it will prompt you for
a label type. If you set this variable to nil, RefTeX will always prompt."
:group 'reftex-referencing-labels
:type 'boolean)
-;;;###autoload(put 'reftex-guess-label-type 'safe-local-variable (lambda (x) (memq x '(nil t))))
+;;;###autoload(put 'reftex-guess-label-type 'safe-local-variable #'booleanp)
(defcustom reftex-format-ref-function nil
"Function which produces the string to insert as a reference.
@@ -1933,7 +1932,6 @@ The value of this variable will only have any effect when
(defcustom reftex-use-fonts t
"Non-nil means, use fonts in *toc* and selection buffers.
-Font-lock must be loaded as well to actually get fontified display.
When changing this option, a rescan may be necessary to activate the change."
:group 'reftex-fontification-configurations
:type 'boolean)
diff --git a/lisp/textmodes/reftex.el b/lisp/textmodes/reftex.el
index 14e5108eca2..6974a4be4a7 100644
--- a/lisp/textmodes/reftex.el
+++ b/lisp/textmodes/reftex.el
@@ -250,9 +250,6 @@ on the menu bar.
(defvar LaTeX-label-function)
(defvar tex-main-file)
(defvar outline-minor-mode)
-(defvar font-lock-mode)
-(defvar font-lock-keywords)
-(defvar font-lock-fontify-region-function)
;;; =========================================================================
;;;
@@ -442,7 +439,7 @@ the label information is recompiled on next use."
;; When it is a symbol, remove all other symbols
(and (symbolp entry)
(not (memq entry list))
- (setq list (reftex-remove-symbols-from-list list)))
+ (setq list (seq-remove #'symbolp list)))
;; Add to list unless already member
(unless (member entry list)
(setq reftex-tables-dirty t
@@ -477,9 +474,9 @@ will deactivate it."
changed t)
(setq list (delete style list))))
(t
- (if (member style list)
- (delete style list)
- (setq list (append list (list style))))
+ (setq list (if (member style list)
+ (delete style list)
+ (append list (list style))))
(setq reftex-tables-dirty t
changed t)))
(when changed
@@ -1664,11 +1661,6 @@ When DIE is non-nil, throw an error if file not found."
(pop alist))
(nreverse out)))
-(defun reftex-window-height ()
- (if (fboundp 'window-displayed-height)
- (window-displayed-height)
- (window-height)))
-
(defun reftex-enlarge-to-fit (buf2 &optional keep-current)
;; Enlarge other window displaying buffer to show whole buffer if possible.
;; If KEEP-CURRENT in non-nil, current buffer must remain visible.
@@ -1680,7 +1672,7 @@ When DIE is non-nil, throw an error if file not found."
(unless (and (pos-visible-in-window-p (point-min))
(pos-visible-in-window-p (point-max)))
(enlarge-window (1+ (- (count-lines (point-min) (point-max))
- (reftex-window-height))))))
+ (window-height))))))
(cond
((window-live-p win1) (select-window win1))
(keep-current
@@ -1705,7 +1697,7 @@ When DIE is non-nil, throw an error if file not found."
(unless (and (pos-visible-in-window-p (point-min))
(pos-visible-in-window-p (point-max)))
(enlarge-window (1+ (- (count-lines (point-min) (point-max))
- (reftex-window-height)))))
+ (window-height)))))
(setq truncate-lines t))
(if (and (pos-visible-in-window-p (point-min))
(pos-visible-in-window-p (point-max)))
@@ -1828,15 +1820,6 @@ When DIE is non-nil, throw an error if file not found."
(push (pop list) rtn))
(nreverse rtn)))
-(defun reftex-remove-symbols-from-list (list)
- ;; Remove all symbols from list
- (let (rtn)
- (while list
- (unless (symbolp (car list))
- (push (car list) rtn))
- (setq list (cdr list)))
- (nreverse rtn)))
-
(defun reftex-uniquify (list &optional sort)
;; Return a list of all strings in LIST, but each only once, keeping order
;; unless SORT is set (faster!).
@@ -2032,21 +2015,14 @@ IGNORE-WORDS List of words which should be removed from the string."
;;;
;;; Fontification and Highlighting
-(defun reftex-use-fonts ()
- ;; Return t if we can and want to use fonts.
- (and ; window-system
- reftex-use-fonts
- (featurep 'font-lock)))
-
(defun reftex-refontify ()
;; Return t if we need to refontify context
- (and (reftex-use-fonts)
+ (and reftex-use-fonts
(or (eq t reftex-refontify-context)
(and (eq 1 reftex-refontify-context)
;; Test of we use the font-lock version of x-symbol
(and (featurep 'x-symbol-tex) (not (boundp 'x-symbol-mode)))))))
-(defvar font-lock-defaults-computed)
(defun reftex-fontify-select-label-buffer (parent-buffer)
;; Fontify the `*RefTeX Select*' buffer. Buffer is temporarily renamed to
;; start with none-SPC char, because Font-Lock otherwise refuses operation.
@@ -2274,20 +2250,17 @@ IGNORE-WORDS List of words which should be removed from the string."
(defun reftex-create-customize-menu ()
"Create a full customization menu for RefTeX, insert it into the menu."
(interactive)
- (if (fboundp 'customize-menu-create)
- (progn
- (easy-menu-change
- '("Ref") "Customize"
- `(["Browse RefTeX group" reftex-customize t]
- "--"
- ,(customize-menu-create 'reftex)
- ["Set" Custom-set t]
- ["Save" Custom-save t]
- ["Reset to Current" Custom-reset-current t]
- ["Reset to Saved" Custom-reset-saved t]
- ["Reset to Standard Settings" Custom-reset-standard t]))
- (message "\"Ref\"-menu now contains full customization menu"))
- (error "Cannot expand menu (outdated version of cus-edit.el)")))
+ (easy-menu-change
+ '("Ref") "Customize"
+ `(["Browse RefTeX group" reftex-customize t]
+ "--"
+ ,(customize-menu-create 'reftex)
+ ["Set" Custom-set t]
+ ["Save" Custom-save t]
+ ["Reset to Current" Custom-reset-current t]
+ ["Reset to Saved" Custom-reset-saved t]
+ ["Reset to Standard Settings" Custom-reset-standard t]))
+ (message "\"Ref\"-menu now contains full customization menu"))
;;; Misc
@@ -2348,6 +2321,16 @@ Your bug report will be posted to the AUCTeX bug reporting list.
(setq reftex-tables-dirty t) ; in case this file is evaluated by hand
+(define-obsolete-function-alias 'reftex-window-height #'window-height "30.1")
+
+(defun reftex-use-fonts ()
+ (declare (obsolete "use variable `reftex-use-fonts' instead." "30.1"))
+ reftex-use-fonts)
+
+(defun reftex-remove-symbols-from-list (list)
+ (declare (obsolete seq-remove "30.1"))
+ (seq-remove #'symbolp list))
+
(provide 'reftex)
;;; reftex.el ends here
diff --git a/lisp/textmodes/remember.el b/lisp/textmodes/remember.el
index b8a2b9cda29..c75a9b758e7 100644
--- a/lisp/textmodes/remember.el
+++ b/lisp/textmodes/remember.el
@@ -7,7 +7,7 @@
;; Created: 29 Mar 1999
;; Old-Version: 2.0
;; Keywords: data memory todo pim
-;; URL: http://gna.org/projects/remember-el/
+;; URL: http://gna.org/projects/remember-el/ [dead link]
;; This file is part of GNU Emacs.
@@ -185,7 +185,7 @@
(defcustom remember-mode-hook nil
"Functions run upon entering `remember-mode'."
:type 'hook
- :options '(flyspell-mode turn-on-auto-fill org-remember-apply-template))
+ :options '(flyspell-mode turn-on-auto-fill))
(defcustom remember-in-new-frame nil
"Non-nil means use a separate frame for capturing remember data."
@@ -210,8 +210,7 @@ recorded somewhere by that function."
:options '(remember-store-in-mailbox
remember-append-to-file
remember-store-in-files
- remember-diary-extract-entries
- org-remember-handler))
+ remember-diary-extract-entries))
(defcustom remember-all-handler-functions nil
"If non-nil every function in `remember-handler-functions' is called."
@@ -235,7 +234,7 @@ recorded somewhere by that function."
(defcustom remember-annotation-functions '(buffer-file-name)
"Hook that returns an annotation to be inserted into the remember buffer."
:type 'hook
- :options '(org-remember-annotation buffer-file-name))
+ :options '(buffer-file-name))
(defvar remember-annotation nil
"Current annotation.")
diff --git a/lisp/textmodes/rst.el b/lisp/textmodes/rst.el
index 82df64184f9..5fbff4ba888 100644
--- a/lisp/textmodes/rst.el
+++ b/lisp/textmodes/rst.el
@@ -170,8 +170,7 @@ When FUN is called match data is just set by `looking-at' and
point is at the beginning of the line. Return nil if moving
forward failed or otherwise the return value of FUN. Preserve
global match data, point, mark and current buffer."
- (unless (listp rst-re-args)
- (setq rst-re-args (list rst-re-args)))
+ (setq rst-re-args (ensure-list rst-re-args))
(unless fun
(setq fun #'identity))
(save-match-data
@@ -1148,14 +1147,14 @@ as well but give an additional message."
(unless (fboundp forwarder-function)
(defalias forwarder-function
(lambda ()
+ (:documentation
+ (format "Deprecated binding for %s, use \\[%s] instead."
+ def def))
(interactive)
(call-interactively def)
(message "[Deprecated use of key %s; use key %s instead]"
(key-description (this-command-keys))
- (key-description key)))
- ;; FIXME: In Emacs-25 we could use (:documentation ...) instead.
- (format "Deprecated binding for %s, use \\[%s] instead."
- def def)))
+ (key-description key)))))
(dolist (dep-key deprecated)
(define-key keymap dep-key forwarder-function)))))
@@ -1473,7 +1472,7 @@ for modes derived from Text mode, like Mail mode."
:version "21.1")
;; FIXME: Default must match suggestion in
-;; http://sphinx-doc.org/rest.html#sections for Python documentation.
+;; https://sphinx-doc.org/rest.html#sections for Python documentation.
(defcustom rst-preferred-adornments '((?= over-and-under 1)
(?= simple 0)
(?- simple 0)
diff --git a/lisp/textmodes/sgml-mode.el b/lisp/textmodes/sgml-mode.el
index 518712e6549..0e15f7e6062 100644
--- a/lisp/textmodes/sgml-mode.el
+++ b/lisp/textmodes/sgml-mode.el
@@ -7,7 +7,7 @@
;; Maintainer: emacs-devel@gnu.org
;; Adapted-By: ESR, Daniel Pfeiffer <occitan@esperanto.org>,
;; F.Potorti@cnuce.cnr.it
-;; Keywords: wp, hypermedia, comm, languages
+;; Keywords: text, hypermedia, comm, languages
;; This file is part of GNU Emacs.
@@ -66,7 +66,7 @@ When 2, attribute indentation looks like this:
</element>"
:version "25.1"
:type 'integer
- :safe 'integerp)
+ :safe #'integerp)
(defcustom sgml-xml-mode nil
"When non-nil, tag insertion functions will be XML-compliant.
@@ -81,7 +81,7 @@ a DOCTYPE or an XML declaration."
(defcustom sgml-transformation-function 'identity
"Default value for `skeleton-transformation-function' in SGML mode."
:type 'function
- :initialize 'custom-initialize-default
+ :initialize #'custom-initialize-default
:set (lambda (sym val)
(set-default sym val)
(mapc (lambda (buff)
@@ -120,40 +120,40 @@ This takes effect when first loading the `sgml-mode' library.")
(defvar sgml-mode-map
(let ((map (make-keymap))) ;`sparse' doesn't allow binding to charsets.
- (define-key map "\C-c\C-i" 'sgml-tags-invisible)
- (define-key map "/" 'sgml-slash)
- (define-key map "\C-c\C-n" 'sgml-name-char)
- (define-key map "\C-c\C-t" 'sgml-tag)
- (define-key map "\C-c\C-a" 'sgml-attributes)
- (define-key map "\C-c\C-b" 'sgml-skip-tag-backward)
- (define-key map [?\C-c left] 'sgml-skip-tag-backward)
- (define-key map "\C-c\C-f" 'sgml-skip-tag-forward)
- (define-key map [?\C-c right] 'sgml-skip-tag-forward)
- (define-key map "\C-c\C-d" 'sgml-delete-tag)
- (define-key map "\C-c\^?" 'sgml-delete-tag)
- (define-key map "\C-c?" 'sgml-tag-help)
- (define-key map "\C-c]" 'sgml-close-tag)
- (define-key map "\C-c/" 'sgml-close-tag)
+ (define-key map "\C-c\C-i" #'sgml-tags-invisible)
+ (define-key map "/" #'sgml-slash)
+ (define-key map "\C-c\C-n" #'sgml-name-char)
+ (define-key map "\C-c\C-t" #'sgml-tag)
+ (define-key map "\C-c\C-a" #'sgml-attributes)
+ (define-key map "\C-c\C-b" #'sgml-skip-tag-backward)
+ (define-key map [?\C-c left] #'sgml-skip-tag-backward)
+ (define-key map "\C-c\C-f" #'sgml-skip-tag-forward)
+ (define-key map [?\C-c right] #'sgml-skip-tag-forward)
+ (define-key map "\C-c\C-d" #'sgml-delete-tag)
+ (define-key map "\C-c\^?" #'sgml-delete-tag)
+ (define-key map "\C-c?" #'sgml-tag-help)
+ (define-key map "\C-c]" #'sgml-close-tag)
+ (define-key map "\C-c/" #'sgml-close-tag)
;; Redundant keybindings, for consistency with TeX mode.
- (define-key map "\C-c\C-o" 'sgml-tag)
- (define-key map "\C-c\C-e" 'sgml-close-tag)
+ (define-key map "\C-c\C-o" #'sgml-tag)
+ (define-key map "\C-c\C-e" #'sgml-close-tag)
- (define-key map "\C-c8" 'sgml-name-8bit-mode)
- (define-key map "\C-c\C-v" 'sgml-validate)
+ (define-key map "\C-c8" #'sgml-name-8bit-mode)
+ (define-key map "\C-c\C-v" #'sgml-validate)
(when sgml-quick-keys
- (define-key map "&" 'sgml-name-char)
- (define-key map "<" 'sgml-tag)
- (define-key map " " 'sgml-auto-attributes)
- (define-key map ">" 'sgml-maybe-end-tag)
+ (define-key map "&" #'sgml-name-char)
+ (define-key map "<" #'sgml-tag)
+ (define-key map " " #'sgml-auto-attributes)
+ (define-key map ">" #'sgml-maybe-end-tag)
(when (memq ?\" sgml-specials)
- (define-key map "\"" 'sgml-name-self))
+ (define-key map "\"" #'sgml-name-self))
(when (memq ?' sgml-specials)
- (define-key map "'" 'sgml-name-self)))
+ (define-key map "'" #'sgml-name-self)))
(let ((c 127)
(map (nth 1 map)))
(while (< (setq c (1+ c)) 256)
- (aset map c 'sgml-maybe-name-self)))
+ (aset map c #'sgml-maybe-name-self)))
map)
"Keymap for SGML mode. See also `sgml-specials'.")
@@ -312,28 +312,28 @@ Any terminating `>' or `/' is not matched.")
;; internal
(defconst sgml-font-lock-keywords-1
- `((,(concat "<\\([!?]" sgml-name-re "\\)") 1 font-lock-keyword-face)
+ `((,(concat "<\\([!?]" sgml-name-re "\\)") 1 'font-lock-keyword-face)
;; We could use the simpler "\\(" sgml-namespace-re ":\\)?" instead,
;; but it would cause a bit more backtracking in the re-matcher.
(,(concat "</?\\(" sgml-namespace-re "\\)\\(?::\\(" sgml-name-re "\\)\\)?")
- (1 (if (match-end 2) sgml-namespace-face font-lock-function-name-face))
- (2 font-lock-function-name-face nil t))
+ (1 (if (match-end 2) 'sgml-namespace 'font-lock-function-name-face))
+ (2 'font-lock-function-name-face nil t))
;; FIXME: this doesn't cover the variables using a default value.
;; The first shy-group is an important anchor: it prevents an O(n^2)
;; pathological case where we otherwise keep retrying a failing match
;; against a very long word at every possible position within the word.
(,(concat "\\(?:^\\|[ \t]\\)\\(" sgml-namespace-re "\\)\\(?::\\("
sgml-name-re "\\)\\)?=[\"']")
- (1 (if (match-end 2) sgml-namespace-face font-lock-variable-name-face))
+ (1 (if (match-end 2) 'sgml-namespace 'font-lock-variable-name-face))
(2 font-lock-variable-name-face nil t))
- (,(concat "[&%]" sgml-name-re ";?") . font-lock-variable-name-face)))
+ (,(concat "[&%]" sgml-name-re ";?") 0 'font-lock-variable-name-face)))
(defconst sgml-font-lock-keywords-2
(append
sgml-font-lock-keywords-1
'((eval
. (cons (concat "<"
- (regexp-opt (mapcar 'car sgml-tag-face-alist) t)
+ (regexp-opt (mapcar #'car sgml-tag-face-alist) t)
"\\([ \t][^>]*\\)?>\\([^<]+\\)</\\1>")
'(3 (cdr (assoc-string (match-string 1) sgml-tag-face-alist t))
prepend))))))
@@ -346,8 +346,8 @@ Any terminating `>' or `/' is not matched.")
(defun sgml-font-lock-syntactic-face (state)
"`font-lock-syntactic-face-function' for `sgml-mode'."
;; Don't use string face outside of tags.
- (cond ((and (nth 9 state) (nth 3 state)) font-lock-string-face)
- ((nth 4 state) font-lock-comment-face)))
+ (cond ((and (nth 9 state) (nth 3 state)) 'font-lock-string-face)
+ ((nth 4 state) 'font-lock-comment-face)))
(defvar-local sgml--syntax-propertize-ppss nil)
@@ -511,7 +511,7 @@ an optional alist of possible values."
(looking-at "\\s-*<\\?xml")
(when (re-search-forward
(eval-when-compile
- (mapconcat 'identity
+ (mapconcat #'identity
'("<!DOCTYPE" "\\(\\w+\\)" "\\(\\w+\\)"
"\"\\([^\"]+\\)\"" "\"\\([^\"]+\\)\"")
"\\s-+"))
@@ -535,8 +535,8 @@ an optional alist of possible values."
(cond (tag-face
(setq tag-face (funcall skeleton-transformation-function tag-face))
(setq facemenu-end-add-face
- (mapconcat (lambda (f) (concat "</" f ">")) (reverse tag-face) ""))
- (mapconcat (lambda (f) (concat "<" f ">")) tag-face ""))
+ (mapconcat (lambda (f) (concat "</" f ">")) (reverse tag-face)))
+ (mapconcat (lambda (f) (concat "<" f ">")) tag-face))
((and (consp face)
(consp (car face))
(null (cdr face))
@@ -593,7 +593,8 @@ Do \\[describe-key] on the following bindings to discover what they do.
(setq-local tildify-space-string
(if (equal (decode-coding-string
(encode-coding-string " " buffer-file-coding-system)
- buffer-file-coding-system) " ")
+ buffer-file-coding-system)
+ " ")
" " "&#160;"))
;; FIXME: Use the fact that we're parsing the document already
;; rather than using regex-based filtering.
@@ -616,12 +617,12 @@ Do \\[describe-key] on the following bindings to discover what they do.
\[ \t]*</?\\(" sgml-name-re sgml-attrs-re "\\)?>"))
(setq-local paragraph-separate (concat paragraph-start "$"))
(setq-local adaptive-fill-regexp "[ \t]*")
- (add-hook 'fill-nobreak-predicate 'sgml-fill-nobreak nil t)
- (setq-local indent-line-function 'sgml-indent-line)
+ (add-hook 'fill-nobreak-predicate #'sgml-fill-nobreak nil t)
+ (setq-local indent-line-function #'sgml-indent-line)
(setq-local comment-start "<!-- ")
(setq-local comment-end " -->")
- (setq-local comment-indent-function 'sgml-comment-indent)
- (setq-local comment-line-break-function 'sgml-comment-indent-new-line)
+ (setq-local comment-indent-function #'sgml-comment-indent)
+ (setq-local comment-line-break-function #'sgml-comment-indent-new-line)
(setq-local skeleton-further-elements '((completion-ignore-case t)))
(setq-local skeleton-end-newline nil)
(setq-local skeleton-end-hook
@@ -637,7 +638,7 @@ Do \\[describe-key] on the following bindings to discover what they do.
. sgml-font-lock-syntactic-face)))
(setq-local syntax-propertize-function #'sgml-syntax-propertize)
(setq-local syntax-ppss-table sgml-tag-syntax-table)
- (setq-local facemenu-add-face-function 'sgml-mode-facemenu-add-face-function)
+ (setq-local facemenu-add-face-function #'sgml-mode-facemenu-add-face-function)
(when (sgml-xml-guess)
(setq-local sgml-xml-mode t))
(unless sgml-xml-mode
@@ -922,7 +923,7 @@ With prefix argument, only self insert."
"Skip to beginning of tag or matching opening tag if present.
With prefix argument ARG, repeat this ARG times.
Return non-nil if we skipped over matched tags."
- (interactive "p")
+ (interactive "^p")
;; FIXME: use sgml-get-context or something similar.
(let ((return t))
(while (>= arg 1)
@@ -997,9 +998,7 @@ Return non-nil if we skipped over matched tags."
(point))))
(or (not endp) (eq (char-after cl-end) ?>)))
(when clones
- (message "sgml-electric-tag-pair-before-change-function: deleting old OLs")
- (mapc 'delete-overlay clones))
- (message "sgml-electric-tag-pair-before-change-function: new clone")
+ (mapc #'delete-overlay clones))
(text-clone-create cl-start cl-end 'spread "[[:alnum:]-_.:]+")
(setq sgml-electric-tag-pair-overlays
(append (get-char-property (point) 'text-clones)
@@ -1021,13 +1020,13 @@ an opening markup tag automatically updates the closing tag."
(if sgml-electric-tag-pair-mode
(progn
(add-hook 'before-change-functions
- 'sgml-electric-tag-pair-before-change-function
+ #'sgml-electric-tag-pair-before-change-function
nil t)
(unless sgml-electric-tag-pair-timer
(setq sgml-electric-tag-pair-timer
- (run-with-idle-timer 5 'repeat 'sgml-electric-tag-pair-flush-overlays))))
+ (run-with-idle-timer 5 'repeat #'sgml-electric-tag-pair-flush-overlays))))
(remove-hook 'before-change-functions
- 'sgml-electric-tag-pair-before-change-function
+ #'sgml-electric-tag-pair-before-change-function
t)
;; We leave the timer running for other buffers.
))
@@ -1037,7 +1036,7 @@ an opening markup tag automatically updates the closing tag."
"Skip to end of tag or matching closing tag if present.
With prefix argument ARG, repeat this ARG times.
Return t if after a closing tag."
- (interactive "p")
+ (interactive "^p")
;; FIXME: Use sgml-get-context or something similar.
;; It currently might jump to an unrelated </P> if the <P>
;; we're skipping has no matching </P>.
@@ -1781,8 +1780,8 @@ Currently just returns (EMPTY-TAGS UNCLOSED-TAGS)."
(push (match-string-no-properties 1) empty))
((string= (match-string 2) "O")
(push (match-string-no-properties 1) unclosed))))
- (setq empty (sort (mapcar 'downcase empty) 'string<))
- (setq unclosed (sort (mapcar 'downcase unclosed) 'string<))
+ (setq empty (sort (mapcar #'downcase empty) #'string<))
+ (setq unclosed (sort (mapcar #'downcase unclosed) #'string<))
(list empty unclosed)))
;;; HTML mode
@@ -1801,41 +1800,41 @@ This takes effect when first loading the library.")
(defvar html-mode-map
(let ((map (make-sparse-keymap)))
(set-keymap-parent map sgml-mode-map)
- (define-key map "\C-c6" 'html-headline-6)
- (define-key map "\C-c5" 'html-headline-5)
- (define-key map "\C-c4" 'html-headline-4)
- (define-key map "\C-c3" 'html-headline-3)
- (define-key map "\C-c2" 'html-headline-2)
- (define-key map "\C-c1" 'html-headline-1)
- (define-key map "\C-c\r" 'html-paragraph)
- (define-key map "\C-c\n" 'html-line)
- (define-key map "\C-c\C-c-" 'html-horizontal-rule)
- (define-key map "\C-c\C-co" 'html-ordered-list)
- (define-key map "\C-c\C-cu" 'html-unordered-list)
- (define-key map "\C-c\C-cr" 'html-radio-buttons)
- (define-key map "\C-c\C-cc" 'html-checkboxes)
- (define-key map "\C-c\C-cl" 'html-list-item)
- (define-key map "\C-c\C-ch" 'html-href-anchor)
- (define-key map "\C-c\C-cf" 'html-href-anchor-file)
- (define-key map "\C-c\C-cn" 'html-name-anchor)
- (define-key map "\C-c\C-c#" 'html-id-anchor)
- (define-key map "\C-c\C-ci" 'html-image)
+ (define-key map "\C-c6" #'html-headline-6)
+ (define-key map "\C-c5" #'html-headline-5)
+ (define-key map "\C-c4" #'html-headline-4)
+ (define-key map "\C-c3" #'html-headline-3)
+ (define-key map "\C-c2" #'html-headline-2)
+ (define-key map "\C-c1" #'html-headline-1)
+ (define-key map "\C-c\r" #'html-paragraph)
+ (define-key map "\C-c\n" #'html-line)
+ (define-key map "\C-c\C-c-" #'html-horizontal-rule)
+ (define-key map "\C-c\C-co" #'html-ordered-list)
+ (define-key map "\C-c\C-cu" #'html-unordered-list)
+ (define-key map "\C-c\C-cr" #'html-radio-buttons)
+ (define-key map "\C-c\C-cc" #'html-checkboxes)
+ (define-key map "\C-c\C-cl" #'html-list-item)
+ (define-key map "\C-c\C-ch" #'html-href-anchor)
+ (define-key map "\C-c\C-cf" #'html-href-anchor-file)
+ (define-key map "\C-c\C-cn" #'html-name-anchor)
+ (define-key map "\C-c\C-c#" #'html-id-anchor)
+ (define-key map "\C-c\C-ci" #'html-image)
(when html-quick-keys
- (define-key map "\C-c-" 'html-horizontal-rule)
- (define-key map "\C-cd" 'html-div)
- (define-key map "\C-co" 'html-ordered-list)
- (define-key map "\C-cu" 'html-unordered-list)
- (define-key map "\C-cr" 'html-radio-buttons)
- (define-key map "\C-cc" 'html-checkboxes)
- (define-key map "\C-cl" 'html-list-item)
- (define-key map "\C-ch" 'html-href-anchor)
- (define-key map "\C-cf" 'html-href-anchor-file)
- (define-key map "\C-cn" 'html-name-anchor)
- (define-key map "\C-c#" 'html-id-anchor)
- (define-key map "\C-ci" 'html-image)
- (define-key map "\C-cs" 'html-span))
- (define-key map "\C-c\C-s" 'html-autoview-mode)
- (define-key map "\C-c\C-v" 'browse-url-of-buffer)
+ (define-key map "\C-c-" #'html-horizontal-rule)
+ (define-key map "\C-cd" #'html-div)
+ (define-key map "\C-co" #'html-ordered-list)
+ (define-key map "\C-cu" #'html-unordered-list)
+ (define-key map "\C-cr" #'html-radio-buttons)
+ (define-key map "\C-cc" #'html-checkboxes)
+ (define-key map "\C-cl" #'html-list-item)
+ (define-key map "\C-ch" #'html-href-anchor)
+ (define-key map "\C-cf" #'html-href-anchor-file)
+ (define-key map "\C-cn" #'html-name-anchor)
+ (define-key map "\C-c#" #'html-id-anchor)
+ (define-key map "\C-ci" #'html-image)
+ (define-key map "\C-cs" #'html-span))
+ (define-key map "\C-c\C-s" #'html-autoview-mode)
+ (define-key map "\C-c\C-v" #'browse-url-of-buffer)
(define-key map "\M-o" 'facemenu-keymap)
map)
"Keymap for commands for use in HTML mode.")
@@ -2405,7 +2404,7 @@ To work around that, do:
(lambda () (char-before (match-end 0))))
(setq-local add-log-current-defun-function #'html-current-defun-name)
(setq-local sentence-end-base "[.?!][]\"'”)}]*\\(<[^>]*>\\)*")
- (add-hook 'completion-at-point-functions 'html-mode--complete-at-point nil t)
+ (add-hook 'completion-at-point-functions #'html-mode--complete-at-point nil t)
(when (fboundp 'libxml-parse-html-region)
(defvar css-class-list-function)
@@ -2413,7 +2412,7 @@ To work around that, do:
(defvar css-id-list-function)
(setq-local css-id-list-function #'html-current-buffer-ids))
- (setq imenu-create-index-function 'html-imenu-index)
+ (setq imenu-create-index-function #'html-imenu-index)
(yank-media-handler 'text/html #'html-mode--html-yank-handler)
(yank-media-handler "image/.*" #'html-mode--image-yank-handler)
@@ -2681,7 +2680,6 @@ HTML Autoview mode is a buffer-local minor mode for use with
"<html lang=\"en\">" \n
"<head>" \n
"<meta charset=\"utf-8\">" \n
- "<meta http-equiv=\"X-UA-Compatible\" content=\"IE=edge\">" \n
"<meta name=\"viewport\" content=\"width=device-width, initial-scale=1\">" \n
"<title>" (skeleton-read "Page Title: ") "</title>" \n
"</head>" \n
diff --git a/lisp/textmodes/table.el b/lisp/textmodes/table.el
index 973f589b204..19c6a8d7c4f 100644
--- a/lisp/textmodes/table.el
+++ b/lisp/textmodes/table.el
@@ -2,7 +2,7 @@
;; Copyright (C) 2000-2024 Free Software Foundation, Inc.
-;; Keywords: wp, convenience
+;; Keywords: text, convenience
;; Author: Takaaki Ota <Takaaki.Ota@am.sony.com>
;; Created: Sat Jul 08 2000 13:28:45 (PST)
@@ -1935,8 +1935,8 @@ specific features."
(if (and cell table-detect-cell-alignment)
(table--detect-cell-alignment cell)))
(unless (re-search-forward border end t)
- (goto-char end))))))))))
- (restore-buffer-modified-p modified-flag)))
+ (goto-char end))))))
+ (restore-buffer-modified-p modified-flag)))))))
;;;###autoload
(defun table-unrecognize-region (beg end)
diff --git a/lisp/textmodes/tex-mode.el b/lisp/textmodes/tex-mode.el
index 64fc1152cbb..02ee1242c72 100644
--- a/lisp/textmodes/tex-mode.el
+++ b/lisp/textmodes/tex-mode.el
@@ -33,9 +33,6 @@
(require 'cl-lib)
(require 'skeleton))
-(defvar font-lock-comment-face)
-(defvar font-lock-doc-face)
-
(require 'shell)
(require 'compile)
@@ -514,17 +511,26 @@ An alternative value is \" . \", if you use a font with a narrow period."
;; This would allow highlighting \newcommand\CMD but requires
;; adapting subgroup numbers below.
;; (arg "\\(?:{\\(\\(?:[^{}\\]+\\|\\\\.\\|{[^}]*}\\)+\\)\\|\\\\[a-z*]+\\)"))
- (inbraces-re (lambda (re)
- (concat "\\(?:[^{}\\]\\|\\\\.\\|" re "\\)")))
- (arg (concat "{\\(" (funcall inbraces-re "{[^}]*}") "+\\)")))
- `( ;; Highlight $$math$$ and $math$.
+ (inbraces-re
+ (lambda (n) ;; Level of nesting of braces we should support.
+ (let ((re "[^}]"))
+ (dotimes (_ n)
+ (setq re
+ (concat "\\(?:[^{}\\]\\|\\\\.\\|{" re "*}\\)")))
+ re)))
+ (arg (concat "{\\(" (funcall inbraces-re 2) "+\\)")))
+ `(;; Verbatim-like args.
+ ;; Do it first, because we don't want to highlight them
+ ;; in comments (bug#68827), but we do want to highlight them
+ ;; in $math$.
+ (,(concat slash verbish opt arg) 3 'tex-verbatim keep)
+ ;; Highlight $$math$$ and $math$.
;; This is done at the very beginning so as to interact with the other
;; keywords in the same way as comments and strings.
(,(concat "\\$\\$?\\(?:[^$\\{}]\\|\\\\.\\|{"
- (funcall inbraces-re
- (concat "{" (funcall inbraces-re "{[^}]*}") "*}"))
+ (funcall inbraces-re 6)
"*}\\)+\\$?\\$")
- (0 'tex-math))
+ (0 'tex-math keep))
;; Heading args.
(,(concat slash headings "\\*?" opt arg)
;; If ARG ends up matching too much (if the {} don't match, e.g.)
@@ -546,8 +552,6 @@ An alternative value is \" . \", if you use a font with a narrow period."
(,(concat slash variables " *" arg) 2 font-lock-variable-name-face)
;; Include args.
(,(concat slash includes opt arg) 3 font-lock-builtin-face)
- ;; Verbatim-like args.
- (,(concat slash verbish opt arg) 3 'tex-verbatim t)
;; Definitions. I think.
("^[ \t]*\\\\def *\\\\\\(\\(\\w\\|@\\)+\\)"
1 font-lock-function-name-face))))
@@ -605,14 +609,14 @@ An alternative value is \" . \", if you use a font with a narrow period."
(list (concat (regexp-opt '("``" "\"<" "\"`" "<<" "«") t)
"\\(\\(.\\|\n\\)+?\\)"
(regexp-opt `("''" "\">" "\"'" ">>" "»") t))
- '(1 font-lock-keyword-face)
- '(2 font-lock-string-face)
- '(4 font-lock-keyword-face))
+ '(1 'font-lock-keyword-face)
+ '(2 'font-lock-string-face)
+ '(4 'font-lock-keyword-face))
;;
;; Command names, special and general.
(cons (concat slash specials-1) 'font-lock-warning-face)
(list (concat "\\(" slash specials-2 "\\)\\([^a-zA-Z@]\\|\\'\\)")
- 1 'font-lock-warning-face)
+ '(1 'font-lock-warning-face))
(concat slash general)
;;
;; Font environments. It seems a bit dubious to use `bold' etc. faces
@@ -680,7 +684,7 @@ An alternative value is \" . \", if you use a font with a narrow period."
(eval-when-compile
(defconst tex-syntax-propertize-rules
(syntax-propertize-precompile-rules
- ("\\\\verb\\**\\([^a-z@*]\\)"
+ ("\\\\verb\\**\\([^a-z@*]\\)"
(1 (prog1 "\""
(tex-font-lock-verb
(match-beginning 0) (char-after (match-beginning 1))))))))
@@ -764,7 +768,7 @@ automatically inserts its partner."
(regexp-quote (buffer-substring arg-start arg-end)))
(text-clone-create arg-start arg-end))))))))
(scan-error nil)
- (error (message "Error in latex-env-before-change: %s" err)))))
+ (error (message "Error in latex-env-before-change: %S" err)))))
(defun tex-font-lock-unfontify-region (beg end)
(font-lock-default-unfontify-region beg end)
@@ -852,7 +856,7 @@ START is the position of the \\ and DELIM is the delimiter char."
(let ((char (nth 3 state)))
(cond
((not char)
- (if (eq 2 (nth 7 state)) 'tex-verbatim font-lock-comment-face))
+ (if (eq 2 (nth 7 state)) 'tex-verbatim 'font-lock-comment-face))
((eq char ?$) 'tex-math)
;; A \verb element.
(t 'tex-verbatim))))
@@ -1032,14 +1036,20 @@ says which mode to use."
;; `tex--guess-mode' really tries to guess the *type* of file,
;; so we still need to consult `major-mode-remap-alist'
;; to see which mode to use for that type.
- (alist-get mode major-mode-remap-alist mode))))))
+ (major-mode-remap mode))))))
-;; The following three autoloaded aliases appear to conflict with
-;; AUCTeX. We keep those confusing aliases for those users who may
-;; have files annotated with -*- LaTeX -*- (e.g. because they received
+;; Support files annotated with -*- LaTeX -*- (e.g. because they received
;; them from someone using AUCTeX).
-;; FIXME: Turn them into autoloads so that AUCTeX can override them
-;; with its own autoloads? Or maybe rely on `major-mode-remap-alist'?
+;;;###autoload (add-to-list 'major-mode-remap-defaults '(TeX-mode . tex-mode))
+;;;###autoload (add-to-list 'major-mode-remap-defaults '(plain-TeX-mode . plain-tex-mode))
+;;;###autoload (add-to-list 'major-mode-remap-defaults '(LaTeX-mode . latex-mode))
+
+;; FIXME: These aliases conflict with AUCTeX, but we still need them
+;; because of packages out there which call these functions directly.
+;; They should be patched to use `major-mode-remap'.
+;; It would be nice to mark them obsolete somehow to encourage using
+;; something else, but the obsolete declaration would become invalid
+;; and confusing when AUCTeX *is* installed.
;;;###autoload (defalias 'TeX-mode #'tex-mode)
;;;###autoload (defalias 'plain-TeX-mode #'plain-tex-mode)
;;;###autoload (defalias 'LaTeX-mode #'latex-mode)
@@ -1265,8 +1275,8 @@ Entering SliTeX mode runs the hook `text-mode-hook', then the hook
(setq-local facemenu-end-add-face "}")
(setq-local facemenu-remove-face-function t)
(setq-local font-lock-defaults
- '((tex-font-lock-keywords tex-font-lock-keywords-1
- tex-font-lock-keywords-2 tex-font-lock-keywords-3)
+ '(( tex-font-lock-keywords tex-font-lock-keywords-1
+ tex-font-lock-keywords-2 tex-font-lock-keywords-3)
nil nil nil nil
;; Who ever uses that anyway ???
(font-lock-mark-block-function . mark-paragraph)
@@ -2137,6 +2147,7 @@ If NOT-ALL is non-nil, save the `.dvi' file."
t "%r.pdf"))
'("pdf" "xe" "lua"))
((concat tex-command
+ " " tex-start-options
" " (if (< 0 (length tex-start-commands))
(shell-quote-argument tex-start-commands))
" %f")
diff --git a/lisp/textmodes/text-mode.el b/lisp/textmodes/text-mode.el
index 533972fcc95..e8e1f4898ce 100644
--- a/lisp/textmodes/text-mode.el
+++ b/lisp/textmodes/text-mode.el
@@ -4,7 +4,7 @@
;; Inc.
;; Maintainer: emacs-devel@gnu.org
-;; Keywords: wp
+;; Keywords: text
;; Package: emacs
;; This file is part of GNU Emacs.
@@ -41,6 +41,9 @@
"Non-nil if this buffer's major mode is a variant of Text mode.")
(make-obsolete-variable 'text-mode-variant 'derived-mode-p "27.1")
+;; Actually defined in textconv.c.
+(defvar text-conversion-style)
+
(defvar text-mode-syntax-table
(let ((st (make-syntax-table)))
(modify-syntax-entry ?\" ". " st)
@@ -70,8 +73,28 @@
(defvar-keymap text-mode-map
:doc "Keymap for `text-mode'.
Many other modes, such as `mail-mode' and `outline-mode', inherit
-all the commands defined in this map."
- "C-M-i" #'ispell-complete-word)
+all the commands defined in this map.")
+
+(defcustom text-mode-ispell-word-completion 'completion-at-point
+ "How Text mode provides Ispell word completion.
+
+By default, this option is set to `completion-at-point', which
+means that Text mode adds an Ispell word completion function to
+`completion-at-point-functions'. Any other non-nil value says to
+bind M-TAB directly to `ispell-complete-word' instead. If this
+is nil, Text mode neither binds M-TAB to `ispell-complete-word'
+nor does it extend `completion-at-point-functions'.
+
+This user option only takes effect when you customize it in
+Custom or with `setopt', not with `setq'."
+ :group 'text
+ :type '(choice (const completion-at-point) boolean)
+ :version "30.1"
+ :set (lambda (sym val)
+ (if (and (set sym val)
+ (not (eq val 'completion-at-point)))
+ (keymap-set text-mode-map "C-M-i" #'ispell-complete-word)
+ (keymap-unset text-mode-map "C-M-i" t))))
(easy-menu-define text-mode-menu text-mode-map
"Menu for `text-mode'."
@@ -125,7 +148,12 @@ You can thus get the full benefit of adaptive filling
Turning on Text mode runs the normal hook `text-mode-hook'."
(setq-local text-mode-variant t)
(setq-local require-final-newline mode-require-final-newline)
- (add-hook 'context-menu-functions 'text-mode-context-menu 10 t))
+
+ ;; Enable text conversion in this buffer.
+ (setq-local text-conversion-style t)
+ (add-hook 'context-menu-functions 'text-mode-context-menu 10 t)
+ (when (eq text-mode-ispell-word-completion 'completion-at-point)
+ (add-hook 'completion-at-point-functions #'ispell-completion-at-point 10 t)))
(define-derived-mode paragraph-indent-text-mode text-mode "Parindent"
"Major mode for editing text, with leading spaces starting a paragraph.
diff --git a/lisp/textmodes/tildify.el b/lisp/textmodes/tildify.el
index 2f6965259f9..8bdb41a07b1 100644
--- a/lisp/textmodes/tildify.el
+++ b/lisp/textmodes/tildify.el
@@ -5,7 +5,7 @@
;; Author: Milan Zamazal <pdm@zamazal.org>
;; Michal Nazarewicz <mina86@mina86.com>
;; Version: 4.6.1
-;; Keywords: text, TeX, SGML, wp
+;; Keywords: text, TeX, SGML
;; This file is part of GNU Emacs.
diff --git a/lisp/textmodes/toml-ts-mode.el b/lisp/textmodes/toml-ts-mode.el
index d2ee0e54210..1b621032f8a 100644
--- a/lisp/textmodes/toml-ts-mode.el
+++ b/lisp/textmodes/toml-ts-mode.el
@@ -39,8 +39,8 @@
(defcustom toml-ts-mode-indent-offset 2
"Number of spaces for each indentation step in `toml-ts-mode'."
:version "29.1"
- :type 'integer
- :safe 'integerp
+ :type 'natnum
+ :safe 'natnump
:group 'toml)
(defvar toml-ts-mode--syntax-table
@@ -153,6 +153,8 @@ Return nil if there is no name or if NODE is not a defun node."
(treesit-major-mode-setup)))
+(derived-mode-add-parents 'toml-ts-mode '(toml-mode))
+
(if (treesit-ready-p 'toml)
(add-to-list 'auto-mode-alist '("\\.toml\\'" . toml-ts-mode)))
diff --git a/lisp/textmodes/two-column.el b/lisp/textmodes/two-column.el
index 415e3edc6c8..806d6c5e709 100644
--- a/lisp/textmodes/two-column.el
+++ b/lisp/textmodes/two-column.el
@@ -4,7 +4,7 @@
;; Author: Daniel Pfeiffer <occitan@esperanto.org>
;; Adapted-By: ESR, Daniel Pfeiffer
-;; Keywords: wp
+;; Keywords: text
;; This file is part of GNU Emacs.
diff --git a/lisp/textmodes/underline.el b/lisp/textmodes/underline.el
index 61441a13d6c..b1157febc24 100644
--- a/lisp/textmodes/underline.el
+++ b/lisp/textmodes/underline.el
@@ -3,7 +3,7 @@
;; Copyright (C) 1985, 2001-2024 Free Software Foundation, Inc.
;; Maintainer: emacs-devel@gnu.org
-;; Keywords: wp
+;; Keywords: text
;; This file is part of GNU Emacs.
diff --git a/lisp/textmodes/yaml-ts-mode.el b/lisp/textmodes/yaml-ts-mode.el
index 2b57b384300..210835585fe 100644
--- a/lisp/textmodes/yaml-ts-mode.el
+++ b/lisp/textmodes/yaml-ts-mode.el
@@ -30,6 +30,9 @@
(require 'treesit)
(declare-function treesit-parser-create "treesit.c")
+(declare-function treesit-node-start "treesit.c")
+(declare-function treesit-node-end "treesit.c")
+(declare-function treesit-node-type "treesit.c")
(defvar yaml-ts-mode--syntax-table
(let ((table (make-syntax-table)))
@@ -117,6 +120,27 @@
'((ERROR) @font-lock-warning-face))
"Tree-sitter font-lock settings for `yaml-ts-mode'.")
+(defun yaml-ts-mode--fill-paragraph (&optional justify)
+ "Fill paragraph.
+Behaves like `fill-paragraph', but respects block node
+boundaries. JUSTIFY is passed to `fill-paragraph'."
+ (interactive "*P")
+ (save-restriction
+ (widen)
+ (let ((node (treesit-node-at (point))))
+ (if (member (treesit-node-type node) '("block_scalar" "comment"))
+ (let* ((start (treesit-node-start node))
+ (end (treesit-node-end node))
+ (start-marker (point-marker))
+ (fill-paragraph-function nil))
+ (save-excursion
+ (goto-char start)
+ (forward-line)
+ (move-marker start-marker (point))
+ (narrow-to-region (point) end))
+ (fill-region start-marker end justify))
+ t))))
+
;;;###autoload
(define-derived-mode yaml-ts-mode text-mode "YAML"
"Major mode for editing YAML, powered by tree-sitter."
@@ -141,8 +165,12 @@
(constant escape-sequence number property)
(bracket delimiter error misc-punctuation)))
+ (setq-local fill-paragraph-function #'yaml-ts-mode--fill-paragraph)
+
(treesit-major-mode-setup)))
+(derived-mode-add-parents 'yaml-ts-mode '(yaml-mode))
+
(if (treesit-ready-p 'yaml)
(add-to-list 'auto-mode-alist '("\\.ya?ml\\'" . yaml-ts-mode)))
diff --git a/lisp/thingatpt.el b/lisp/thingatpt.el
index 63b0ee613c2..7896ad984df 100644
--- a/lisp/thingatpt.el
+++ b/lisp/thingatpt.el
@@ -52,7 +52,6 @@
;;; Code:
-(require 'cl-lib)
(provide 'thingatpt)
(defvar thing-at-point-provider-alist nil
@@ -175,11 +174,14 @@ See the file `thingatpt.el' for documentation on how to define
a symbol as a valid THING."
(let ((text
(cond
- ((cl-loop for (pthing . function) in thing-at-point-provider-alist
- when (eq pthing thing)
- for result = (funcall function)
- when result
- return result))
+ ((let ((alist thing-at-point-provider-alist)
+ elt result)
+ (while (and alist (null result))
+ (setq elt (car alist)
+ alist (cdr alist))
+ (and (eq (car elt) thing)
+ (setq result (funcall (cdr elt)))))
+ result))
((get thing 'thing-at-point)
(funcall (get thing 'thing-at-point)))
(t
@@ -250,7 +252,8 @@ Prefer the enclosing string with fallback on sexp at point.
(goto-char (nth 8 ppss))
(cons (point) (progn (forward-sexp) (point))))
;; At the beginning of the string
- (if (eq (char-syntax (char-after)) ?\")
+ (if (let ((ca (char-after)))
+ (and ca (eq (char-syntax ca) ?\")))
(let ((bound (bounds-of-thing-at-point 'sexp)))
(and bound
(<= (car bound) (point)) (< (point) (cdr bound))
@@ -359,6 +362,10 @@ E.g.:
(and (file-exists-p filename)
filename)))
+(put 'existing-filename 'bounds-of-thing-at-point
+ (lambda ()
+ (and (thing-at-point 'existing-filename)
+ (bounds-of-thing-at-point 'filename))))
(put 'existing-filename 'thing-at-point 'thing-at-point-file-at-point)
;; Faces
@@ -560,9 +567,9 @@ looks like an email address, \"ftp://\" if it starts with
;; If it looks like ftp.example.com. treat it as ftp.
(if (string-match "\\`ftp\\." str)
(setq str (concat "ftp://" str)))
- ;; If it looks like www.example.com. treat it as http.
+ ;; If it looks like www.example.com. treat it as https.
(if (string-match "\\`www\\." str)
- (setq str (concat "http://" str)))
+ (setq str (concat "https://" str)))
;; Otherwise, it just isn't a URI.
(setq str nil)))
str)))
@@ -612,40 +619,24 @@ point.
Optional argument DISTANCE limits search for REGEXP forward and
back from point."
- (save-excursion
- (let ((old-point (point))
- (forward-bound (and distance (+ (point) distance)))
- (backward-bound (and distance (- (point) distance)))
- match prev-pos new-pos)
- (and (looking-at regexp)
- (>= (match-end 0) old-point)
- (setq match (point)))
- ;; Search back repeatedly from end of next match.
- ;; This may fail if next match ends before this match does.
- (re-search-forward regexp forward-bound 'limit)
- (setq prev-pos (point))
- (while (and (setq new-pos (re-search-backward regexp backward-bound t))
- ;; Avoid inflooping with some regexps, such as "^",
- ;; matching which never moves point.
- (< new-pos prev-pos)
- (or (> (match-beginning 0) old-point)
- (and (looking-at regexp) ; Extend match-end past search start
- (>= (match-end 0) old-point)
- (setq match (point))))))
- (if (not match) nil
- (goto-char match)
- ;; Back up a char at a time in case search skipped
- ;; intermediate match straddling search start pos.
- (while (and (not (bobp))
- (progn (backward-char 1) (looking-at regexp))
- (>= (match-end 0) old-point)
- (setq match (point))))
- (goto-char match)
- (looking-at regexp)))))
+ (let* ((old (point))
+ (beg (if distance (max (point-min) (- old distance)) (point-min)))
+ (end (if distance (min (point-max) (+ old distance))))
+ prev match)
+ (save-excursion
+ (goto-char beg)
+ (while (and (setq prev (point)
+ match (re-search-forward regexp end t))
+ (< (match-end 0) old))
+ (goto-char (match-beginning 0))
+ ;; Avoid inflooping when `regexp' matches the empty string.
+ (unless (< prev (point)) (forward-char))))
+ (and match (<= (match-beginning 0) old (match-end 0)))))
+
;; Email addresses
(defvar thing-at-point-email-regexp
- "<?[-+_.~a-zA-Z][-+_.~:a-zA-Z0-9]*@[-.a-zA-Z0-9]+>?"
+ "<?[-+_~a-zA-Z0-9/][-+_.~:a-zA-Z0-9/]*@[-a-zA-Z0-9]+[-.a-zA-Z0-9]*>?"
"A regular expression probably matching an email address.
This does not match the real name portion, only the address, optionally
with angle brackets.")
@@ -744,20 +735,33 @@ Signal an error if the entire string was not used."
(let ((thing (thing-at-point 'symbol)))
(if thing (intern thing))))
+(defvar thing-at-point-decimal-regexp
+ "-?[0-9]+\\.?[0-9]*"
+ "A regexp matching a decimal number.")
+
+(defvar thing-at-point-hexadecimal-regexp
+ "\\(0x\\|#x\\)\\([a-fA-F0-9]+\\)"
+ "A regexp matchin a hexadecimal number.")
+
;;;###autoload
(defun number-at-point ()
"Return the number at point, or nil if none is found.
Decimal numbers like \"14\" or \"-14.5\", as well as hex numbers
like \"0xBEEF09\" or \"#xBEEF09\", are recognized."
(cond
- ((thing-at-point-looking-at "\\(0x\\|#x\\)\\([a-fA-F0-9]+\\)" 500)
+ ((thing-at-point-looking-at thing-at-point-hexadecimal-regexp 500)
(string-to-number
(buffer-substring (match-beginning 2) (match-end 2))
16))
- ((thing-at-point-looking-at "-?[0-9]+\\.?[0-9]*" 500)
+ ((thing-at-point-looking-at thing-at-point-decimal-regexp 500)
(string-to-number
(buffer-substring (match-beginning 0) (match-end 0))))))
+(put 'number 'bounds-of-thing-at-point
+ (lambda ()
+ (and (or (thing-at-point-looking-at thing-at-point-hexadecimal-regexp 500)
+ (thing-at-point-looking-at thing-at-point-decimal-regexp 500))
+ (cons (match-beginning 0) (match-end 0)))))
(put 'number 'forward-op 'forward-word)
(put 'number 'thing-at-point 'number-at-point)
diff --git a/lisp/time.el b/lisp/time.el
index 6d95ae326c6..a8d3ab9c813 100644
--- a/lisp/time.el
+++ b/lisp/time.el
@@ -139,6 +139,12 @@ make the mail indicator stand out on a color display."
:version "22.1"
:type '(choice (const :tag "None" nil) face))
+(defface display-time-date-and-time
+ '((t nil))
+ "Face for `display-time-format'."
+ :group 'mode-line-faces
+ :version "30.1")
+
(defvar display-time-mail-icon
(find-image '((:type xpm :file "letter.xpm" :ascent center)
(:type pbm :file "letter.pbm" :ascent center)))
@@ -179,6 +185,7 @@ depend on `display-time-day-and-date' and `display-time-24hr-format'."
(format-time-string (or display-time-format
(if display-time-24hr-format "%H:%M" "%-I:%M%p"))
now)
+ 'face 'display-time-date-and-time
'help-echo (format-time-string "%a %b %e, %Y" now))
load
(if mail
@@ -582,7 +589,7 @@ See `world-clock'."
(defun world-clock ()
"Display a world clock buffer with times in various time zones.
The variable `world-clock-list' specifies which time zones to use.
-To turn off the world time display, go to the window and type `\\[quit-window]'."
+To turn off the world time display, go to the window and type \\[quit-window]."
(interactive)
(if-let ((buffer (get-buffer world-clock-buffer-name)))
(pop-to-buffer buffer)
@@ -604,7 +611,7 @@ To turn off the world time display, go to the window and type `\\[quit-window]'.
(defun world-clock-update (&optional _arg _noconfirm)
"Update the `world-clock' buffer."
(if (get-buffer world-clock-buffer-name)
- (with-current-buffer (get-buffer world-clock-buffer-name)
+ (with-current-buffer world-clock-buffer-name
(let ((op (point)))
(world-clock-display (time--display-world-list))
(goto-char op)))
diff --git a/lisp/tool-bar.el b/lisp/tool-bar.el
index 179b979ee2e..96b61c7b229 100644
--- a/lisp/tool-bar.el
+++ b/lisp/tool-bar.el
@@ -83,6 +83,14 @@ buffer-locally and add the items you want to it with
`tool-bar-add-item', `tool-bar-add-item-from-menu' and related
functions.")
+(defvar secondary-tool-bar-map nil
+ "Optional secondary keymap for the tool bar.
+
+If non-nil, tool bar items defined within this map are displayed
+in a line below the tool bar if the `tool-bar-position' frame
+parameter is set to `top', and above the tool bar it is set to
+`bottom'.")
+
(global-set-key [tool-bar]
`(menu-item ,(purecopy "tool bar") ignore
:filter tool-bar-make-keymap))
@@ -91,15 +99,21 @@ functions.")
(defconst tool-bar-keymap-cache (make-hash-table :test #'equal))
-(defun tool-bar--cache-key ()
+(defsubst tool-bar--cache-key ()
(cons (frame-terminal) (sxhash-eq tool-bar-map)))
+(defsubst tool-bar--secondary-cache-key ()
+ (cons (frame-terminal) (sxhash-eq secondary-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))
+ (secondary-id (and secondary-tool-bar-map
+ (sxhash-eq secondary-tool-bar-map)))
(entries nil))
(maphash (lambda (k _)
- (when (equal (cdr k) id)
+ (when (or (equal (cdr k) id)
+ (equal (cdr k) secondary-id))
(push k entries)))
tool-bar-keymap-cache)
(dolist (k entries)
@@ -107,14 +121,56 @@ functions.")
(defun tool-bar-make-keymap (&optional _ignore)
"Generate an actual keymap from `tool-bar-map'.
+If `secondary-tool-bar-map' is non-nil, take it into account as well.
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."
- (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."
+ (let* ((key (tool-bar--cache-key))
+ (base-keymap
+ (or (gethash key tool-bar-keymap-cache)
+ (setf (gethash key tool-bar-keymap-cache)
+ (tool-bar-make-keymap-1))))
+ (secondary-keymap
+ (and secondary-tool-bar-map
+ (or (gethash (tool-bar--secondary-cache-key)
+ tool-bar-keymap-cache)
+ (setf (gethash (tool-bar--secondary-cache-key)
+ tool-bar-keymap-cache)
+ (tool-bar-make-keymap-1
+ secondary-tool-bar-map))))))
+ (if secondary-keymap
+ (or (ignore-errors
+ (progn
+ ;; Determine the value of the `tool-bar-position' frame
+ ;; parameter.
+ (let ((position (frame-parameter nil 'tool-bar-position)))
+ (cond ((eq position 'top)
+ ;; Place `base-keymap' above `secondary-keymap'.
+ (append base-keymap (list (list (gensym)
+ 'menu-item
+ "" 'ignore
+ :wrap t))
+ (cdr secondary-keymap)))
+ ((eq position 'bottom)
+ ;; Place `secondary-keymap' above `base-keymap'.
+ (append secondary-keymap (list (list (gensym)
+ 'menu-item
+ "" 'ignore
+ :wrap t))
+ (cdr base-keymap)))
+ ;; If the tool bar position isn't known, don't
+ ;; display the secondary keymap at all.
+ (t base-keymap)))))
+ ;; If combining both keymaps fails, return the base
+ ;; keymap.
+ base-keymap)
+ base-keymap)))
+
+;; This function should return binds even if images can not be
+;; displayed so the tool bar can still be displayed on terminals.
+(defun tool-bar-make-keymap-1 (&optional map)
+ "Generate an actual keymap from `tool-bar-map', without caching.
+MAP is either a keymap to use as a source for menu items, or nil,
+in which case the value of `tool-bar-map' is used instead."
(mapcar (lambda (bind)
(let (image-exp plist)
(when (and (eq (car-safe (cdr-safe bind)) 'menu-item)
@@ -126,17 +182,16 @@ color capability and based on the available image libraries."
(consp image-exp)
(not (eq (car image-exp) 'image))
(fboundp (car image-exp)))
- (if (not (display-images-p))
- (setq bind nil)
- (let ((image (eval image-exp)))
- (unless (and image (image-mask-p image))
- (setq image (append image '(:mask heuristic))))
- (setq bind (copy-sequence bind)
- plist (nthcdr (if (consp (nth 4 bind)) 5 4)
- bind))
- (plist-put plist :image image))))
+ (let ((image (and (display-images-p)
+ (eval image-exp))))
+ (unless (and image (image-mask-p image))
+ (setq image (append image '(:mask heuristic))))
+ (setq bind (copy-sequence bind)
+ plist (nthcdr (if (consp (nth 4 bind)) 5 4)
+ bind))
+ (plist-put plist :image image)))
bind))
- tool-bar-map))
+ (or map tool-bar-map)))
;;;###autoload
(defun tool-bar-add-item (icon def key &rest props)
@@ -322,6 +377,207 @@ Customize `tool-bar-mode' if you want to show or hide the tool bar."
(modify-all-frames-parameters
(list (cons 'tool-bar-position val))))))
+
+
+;; Modifier bar mode.
+;; This displays a small tool bar containing modifier keys
+;; above or below the main tool bar itself.
+
+(defvar modifier-bar-modifier-list nil
+ "List of modifiers that are currently applied.
+Each symbol in this list represents a modifier button that has
+been pressed as part of decoding this key sequence.")
+
+(declare-function set-text-conversion-style "textconv.c")
+
+;; These functions are very similar to their counterparts in
+;; simple.el, but allow combining multiple modifier buttons together.
+
+(defun tool-bar-apply-modifiers (event modifiers)
+ "Apply the specified list of MODIFIERS to EVENT.
+MODIFIERS must be a list containing only the symbols `alt',
+`super', `hyper', `shift', `control' and `meta'.
+Return EVENT with the specified modifiers applied."
+ (dolist (modifier modifiers)
+ (cond
+ ((eq modifier 'alt)
+ (setq event (event-apply-modifier event 'alt 22 "A-")))
+ ((eq modifier 'super)
+ (setq event (event-apply-modifier event 'super 23 "s-")))
+ ((eq modifier 'hyper)
+ (setq event (event-apply-modifier event 'hyper 24 "H-")))
+ ((eq modifier 'shift)
+ (setq event (event-apply-modifier event 'shift 25 "S-")))
+ ((eq modifier 'control)
+ (setq event (event-apply-modifier event 'control 26 "C-")))
+ ((eq modifier 'meta)
+ (setq event (event-apply-modifier event 'meta 27 "M-")))))
+ event)
+
+(defvar overriding-text-conversion-style)
+
+(defun modifier-bar-button (init-modifier-list)
+ "Decode the key sequence associated with a modifier bar button.
+INIT-MODIFIER-LIST is a list of one symbol describing the button
+being pressed.
+
+Bind `modifier-bar-modifier-list' to INIT-MODIFIER-LIST. Read
+events, adding each subsequent modifier bar event's associated
+modifier to that list while updating the tool bar to disable
+buttons that were pressed. Return any other event read with all
+modifier keys read applied.
+
+Temporarily disable text conversion and display the on screen
+keyboard while doing so."
+ ;; Save the previously used text conversion style.
+ (let ((old-text-conversion-style text-conversion-style)
+ ;; Clear the list of modifiers currently pressed.
+ (modifier-bar-modifier-list init-modifier-list))
+ ;; Disable text conversion.
+ (when (fboundp 'set-text-conversion-style)
+ (set-text-conversion-style nil))
+ (unwind-protect
+ (progn
+ ;; Display the on screen keyboard.
+ (frame-toggle-on-screen-keyboard nil nil)
+ ;; Update the tool bar to disable this modifier key.
+ (force-mode-line-update)
+ (let* ((modifiers init-modifier-list) event1
+ (overriding-text-conversion-style nil)
+ (event (read-event)))
+ ;; Combine any more modifier key presses.
+ (while (eq event 'tool-bar)
+ (setq event1 (event-basic-type (read-event)))
+ ;; Reject unknown tool bar events.
+ (unless (memq event1 '(alt super hyper shift control meta))
+ (user-error "Unknown tool-bar event %s" event1))
+ ;; If `event' is the name of a modifier key, apply that
+ ;; modifier key as well.
+ (unless (memq event1 modifiers)
+ (push event1 modifiers)
+ ;; This list is used to check which tool bar buttons
+ ;; need to be enabled.
+ (push event1 modifier-bar-modifier-list))
+ ;; Update the tool bar to disable the modifier button
+ ;; that was read.
+ (force-mode-line-update)
+ (redisplay)
+ ;; Read another event.
+ (setq event (read-event)))
+ ;; EVENT is a keyboard event to which the specified list of
+ ;; modifier keys should be applied.
+ (vector (tool-bar-apply-modifiers event modifiers))))
+ ;; Re-enable text conversion if necessary.
+ (unless (or (not (fboundp 'set-text-conversion-style))
+ (eq old-text-conversion-style text-conversion-style))
+ (set-text-conversion-style old-text-conversion-style t))
+ ;; Re-enable all modifier bar buttons which may have been
+ ;; disabled.
+ (force-mode-line-update))))
+
+(defun tool-bar-event-apply-alt-modifier (_ignore-prompt)
+ "Like `event-apply-alt-modifier'.
+However, take additional modifier tool bar items into account;
+apply any extra modifiers bound to subsequent `tool-bar' events."
+ (modifier-bar-button '(alt)))
+
+(defun tool-bar-event-apply-super-modifier (_ignore-prompt)
+ "Like `event-apply-super-modifier'.
+However, take additional modifier tool bar items into account;
+apply any extra modifiers bound to subsequent `tool-bar' events."
+ (modifier-bar-button '(super)))
+
+(defun tool-bar-event-apply-hyper-modifier (_ignore-prompt)
+ "Like `event-apply-hyper-modifier'.
+However, take additional modifier tool bar items into account;
+apply any extra modifiers bound to subsequent `tool-bar' events."
+ (modifier-bar-button '(hyper)))
+
+(defun tool-bar-event-apply-shift-modifier (_ignore-prompt)
+ "Like `event-apply-shift-modifier'.
+However, take additional modifier tool bar items into account;
+apply any extra modifiers bound to subsequent `tool-bar' events."
+ (modifier-bar-button '(shift)))
+
+(defun tool-bar-event-apply-control-modifier (_ignore-prompt)
+ "Like `event-apply-control-modifier'.
+However, take additional modifier tool bar items into account;
+apply any extra modifiers bound to subsequent `tool-bar' events."
+ (modifier-bar-button '(control)))
+
+(defun tool-bar-event-apply-meta-modifier (_ignore-prompt)
+ "Like `event-apply-meta-modifier'.
+However, take additional modifier tool bar items into account;
+apply any extra modifiers bound to subsequent `tool-bar' events."
+ (modifier-bar-button '(meta)))
+
+(defun modifier-bar-available-p (modifier)
+ "Return whether the modifier button for MODIFIER should be enabled.
+Return t if MODIFIER has not yet been selected as part of
+decoding the current key sequence, nil otherwise."
+ (not (memq modifier modifier-bar-modifier-list)))
+
+(define-minor-mode modifier-bar-mode
+ "Toggle display of the modifier bar.
+
+When enabled, a small tool bar will be displayed next to the tool
+bar containing items bound to
+`tool-bar-event-apply-control-modifier' and its related commands,
+which see."
+ :init-value nil
+ :global t
+ :group 'tool-bar
+ (if modifier-bar-mode
+ (progn
+ (setq secondary-tool-bar-map
+ ;; The commands specified in the menu items here are not
+ ;; used. Instead, Emacs relies on each of the tool bar
+ ;; events being specified in `input-decode-map'.
+ `(keymap (control menu-item "Control Key"
+ event-apply-control-modifier
+ :help "Add Control modifier to the following event"
+ :image ,(tool-bar--image-expression "ctrl")
+ :enable (modifier-bar-available-p 'control))
+ (shift menu-item "Shift Key"
+ event-apply-shift-modifier
+ :help "Add Shift modifier to the following event"
+ :image ,(tool-bar--image-expression "shift")
+ :enable (modifier-bar-available-p 'shift))
+ (meta menu-item "Meta Key"
+ event-apply-meta-modifier
+ :help "Add Meta modifier to the following event"
+ :image ,(tool-bar--image-expression "meta")
+ :enable (modifier-bar-available-p 'meta))
+ (alt menu-item "Alt Key"
+ event-apply-alt-modifier
+ :help "Add Alt modifier to the following event"
+ :image ,(tool-bar--image-expression "alt")
+ :enable (modifier-bar-available-p 'alt))
+ (super menu-item "Super Key"
+ event-apply-super-modifier
+ :help "Add Super modifier to the following event"
+ :image ,(tool-bar--image-expression "super")
+ :enable (modifier-bar-available-p 'super))
+ (hyper menu-item "Hyper Key"
+ event-apply-hyper-modifier
+ :help "Add Hyper modifier to the following event"
+ :image ,(tool-bar--image-expression "hyper")
+ :enable (modifier-bar-available-p 'hyper))))
+ (define-key input-decode-map [tool-bar control]
+ #'tool-bar-event-apply-control-modifier)
+ (define-key input-decode-map [tool-bar shift]
+ #'tool-bar-event-apply-shift-modifier)
+ (define-key input-decode-map [tool-bar meta]
+ #'tool-bar-event-apply-meta-modifier)
+ (define-key input-decode-map [tool-bar alt]
+ #'tool-bar-event-apply-alt-modifier)
+ (define-key input-decode-map [tool-bar super]
+ #'tool-bar-event-apply-super-modifier)
+ (define-key input-decode-map [tool-bar hyper]
+ #'tool-bar-event-apply-hyper-modifier))
+ (setq secondary-tool-bar-map nil))
+ ;; Update the mode line now.
+ (force-mode-line-update t))
(provide 'tool-bar)
diff --git a/lisp/tooltip.el b/lisp/tooltip.el
index 69d8c082cd1..4537fdf8087 100644
--- a/lisp/tooltip.el
+++ b/lisp/tooltip.el
@@ -194,13 +194,13 @@ This might return nil if the event did not occur over a buffer."
(defun tooltip-cancel-delayed-tip ()
"Disable the tooltip timeout."
(when tooltip-timeout-id
- (disable-timeout tooltip-timeout-id)
+ (cancel-timer tooltip-timeout-id)
(setq tooltip-timeout-id nil)))
(defun tooltip-start-delayed-tip ()
"Add a one-shot timeout to call function `tooltip-timeout'."
(setq tooltip-timeout-id
- (add-timeout (tooltip-delay) 'tooltip-timeout nil)))
+ (run-with-timer (tooltip-delay) nil 'tooltip-timeout nil)))
(defun tooltip-timeout (_object)
"Function called when timer with id `tooltip-timeout-id' fires."
diff --git a/lisp/touch-screen.el b/lisp/touch-screen.el
new file mode 100644
index 00000000000..c8de1d8ee31
--- /dev/null
+++ b/lisp/touch-screen.el
@@ -0,0 +1,2043 @@
+;;; touch-screen.el --- touch screen support for X and Android -*- lexical-binding: t; -*-
+
+;; Copyright (C) 2023-2024 Free Software Foundation, Inc.
+
+;; Maintainer: emacs-devel@gnu.org
+;; Package: emacs
+
+;; This file is part of GNU Emacs.
+
+;; GNU Emacs is free software: you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+
+;; GNU Emacs is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>.
+
+;;; Commentary:
+
+;; This file provides code to recognize simple touch screen gestures.
+;; It is used on X and Android, currently the only systems where Emacs
+;; supports touch input.
+;;
+;; See (elisp)Touchscreen Events for a description of the details of
+;; touch events.
+
+;;; Code:
+
+(defvar touch-screen-current-tool nil
+ "The touch point currently being tracked, or nil.
+If non-nil, this is a list of ten elements: the ID of the touch
+point being tracked, the window where the touch began, a cons
+holding the last registered position of the touch point, relative
+to that window, a field used to store data while tracking the
+touch point, the initial position of the touchpoint, another four
+fields to used store data while tracking the touch point, and the
+last known position of the touch point.
+
+See `touch-screen-handle-point-update' and
+`touch-screen-handle-point-up' for the meanings of the fourth
+element.
+
+The third and last elements differ in that the former is not
+modified until after a gesture is recognized in reaction to an
+update, whereas the latter is updated upon each apposite
+`touchscreen-update' event.")
+
+(defvar touch-screen-aux-tool nil
+ "The ancillary tool being tracked, or nil.
+If non-nil, this is a vector of ten elements: the ID of the
+touch point being tracked, the window where the touch began, a
+cons holding the initial position of the touch point, and the
+last known position of the touch point, all in the same format as
+in `touch-screen-current-tool', the distance in pixels between
+the current tool and the aforementioned initial position, the
+center of the line formed between those two points, the ratio
+between the present distance between both tools and the aforesaid
+initial distance when a pinch gesture was last sent, and three
+elements into which commands can save data particular to a tool.
+
+The ancillary tool is a second tool whose movement is interpreted
+in unison with that of the current tool to recognize gestures
+comprising the motion of both such as \"pinch\" gestures, in
+which the text scale is adjusted in proportion to the distance
+between both tools.")
+
+(defvar touch-screen-set-point-commands '(mouse-set-point)
+ "List of commands known to set the point.
+This is used to determine whether or not to display the on-screen
+keyboard after a mouse command is executed in response to a
+`touchscreen-end' event.")
+
+(defvar touch-screen-current-timer nil
+ "Timer used to track long-presses.
+This is always cleared upon any significant state change.")
+
+(defvar touch-screen-translate-prompt nil
+ "Prompt given to the touch screen translation function.
+If non-nil, the touch screen key event translation machinery
+is being called from `read-sequence' or some similar function.")
+
+(defgroup touch-screen nil
+ "Interact with Emacs from touch screen devices."
+ :group 'mouse
+ :version "30.1")
+
+(defcustom touch-screen-display-keyboard nil
+ "If non-nil, always display the on screen keyboard.
+A buffer local value means to always display the on screen
+keyboard when the buffer is selected."
+ :type 'boolean
+ :group 'touch-screen
+ :version "30.1")
+
+(defcustom touch-screen-delay 0.7
+ "Delay in seconds before Emacs considers a touch to be a long-press."
+ :type 'number
+ :group 'touch-screen
+ :version "30.1")
+
+(defcustom touch-screen-precision-scroll nil
+ "Whether or not to use precision scrolling for touch screens.
+See `pixel-scroll-precision-mode' for more details."
+ :type 'boolean
+ :group 'touch-screen
+ :version "30.1")
+
+(defcustom touch-screen-word-select nil
+ "Whether or not to select whole words while dragging to select.
+If non-nil, long-press events (see `touch-screen-delay') followed
+by dragging will try to select entire words."
+ :type 'boolean
+ :group 'touch-screen
+ :version "30.1")
+
+(defcustom touch-screen-extend-selection nil
+ "If non-nil, restart drag-to-select upon a tap on point or mark.
+When enabled, tapping on the character containing the point or
+mark will resume dragging where it left off while the region is
+active."
+ :type 'boolean
+ :group 'touch-screen
+ :version "30.1")
+
+(defcustom touch-screen-preview-select nil
+ "If non-nil, display a preview while selecting text.
+When enabled, a preview of the visible line within the window
+will be displayed in the echo area while dragging combined with
+an indication of the position of point within that line."
+ :type 'boolean
+ :group 'touch-screen
+ :version "30.1")
+
+(defcustom touch-screen-enable-hscroll t
+ "If non-nil, hscroll can be changed from the touch screen.
+When enabled, tapping on a window and dragging your finger left
+or right will scroll that window horizontally."
+ :type 'boolean
+ :group 'touch-screen
+ :version "30.1")
+
+(defvar-local touch-screen-word-select-bounds nil
+ "The start and end positions of the word last selected.
+Normally a cons of those two positions or nil if no word was
+selected.")
+
+(defvar-local touch-screen-word-select-initial-word nil
+ "The start and end positions of the first word to be selected.
+Used in an attempt to keep this word selected during later
+dragging.")
+
+
+
+;;; Scroll gesture.
+
+(defun touch-screen-relative-xy (posn window)
+ "Return the coordinates of POSN, a mouse position list.
+However, return the coordinates relative to WINDOW.
+
+If (posn-window posn) is the same as window, simply return the
+coordinates in POSN. Otherwise, convert them to the frame, and
+then back again.
+
+If WINDOW is the symbol `frame', simply convert the coordinates
+to the frame that they belong in."
+ (if (or (eq (posn-window posn) window)
+ (and (eq window 'frame)
+ (framep (posn-window posn))))
+ (posn-x-y posn)
+ (let ((xy (posn-x-y posn))
+ (edges (and (windowp window)
+ (window-inside-pixel-edges window))))
+ ;; Make the X and Y positions frame relative.
+ (when (windowp (posn-window posn))
+ (let ((edges (window-inside-pixel-edges
+ (posn-window posn))))
+ (setq xy (cons (+ (car xy) (car edges))
+ (+ (cdr xy) (cadr edges))))))
+ (if (eq window 'frame)
+ xy
+ ;; Make the X and Y positions window relative again.
+ (cons (- (car xy) (car edges))
+ (- (cdr xy) (cadr edges)))))))
+
+(defun touch-screen-handle-scroll (dx dy)
+ "Scroll the display assuming that a touch point has moved by DX and DY.
+Perform vertical scrolling by DY, using `pixel-scroll-precision'
+if `touch-screen-precision-scroll' is enabled. Next, perform
+horizontal scrolling according to the movement in DX."
+ ;; Perform vertical scrolling first. Do not ding at buffer limits.
+ ;; Show a message instead.
+ (condition-case nil
+ (if touch-screen-precision-scroll
+ (progn
+ (if (> dy 0)
+ (pixel-scroll-precision-scroll-down-page dy)
+ (pixel-scroll-precision-scroll-up-page (- dy)))
+ ;; Now set `lines-vscrolled' to an value that will result
+ ;; in hscroll being disabled if dy looks as if a
+ ;; significant amount of scrolling is about to take
+ ;; Otherwise, horizontal scrolling may then interfere with
+ ;; precision scrolling.
+ (when (> (abs dy) 10)
+ (setcar (nthcdr 7 touch-screen-current-tool) 10)))
+ ;; Start conventional scrolling. First, determine the
+ ;; direction in which the scrolling is taking place. Load the
+ ;; accumulator value.
+ (let ((accumulator (or (nth 5 touch-screen-current-tool) 0))
+ (window (cadr touch-screen-current-tool))
+ (lines-vscrolled (or (nth 7 touch-screen-current-tool) 0)))
+ (setq accumulator (+ accumulator dy)) ; Add dy.
+ ;; Figure out how much it has scrolled and how much remains
+ ;; on the top or bottom of the window.
+ (while (catch 'again
+ (let* ((line-height (window-default-line-height window)))
+ (if (and (< accumulator 0)
+ (>= (- accumulator) line-height))
+ (progn
+ (setq accumulator (+ accumulator line-height))
+ (scroll-down 1)
+ (setq lines-vscrolled (1+ lines-vscrolled))
+ (when (not (zerop accumulator))
+ ;; If there is still an outstanding
+ ;; amount to scroll, do this again.
+ (throw 'again t)))
+ (when (and (> accumulator 0)
+ (>= accumulator line-height))
+ (setq accumulator (- accumulator line-height))
+ (scroll-up 1)
+ (setq lines-vscrolled (1+ lines-vscrolled))
+ (when (not (zerop accumulator))
+ ;; If there is still an outstanding amount
+ ;; to scroll, do this again.
+ (throw 'again t)))))
+ ;; Scrolling is done. Move the accumulator back to
+ ;; touch-screen-current-tool and break out of the
+ ;; loop.
+ (setcar (nthcdr 5 touch-screen-current-tool) accumulator)
+ (setcar (nthcdr 7 touch-screen-current-tool)
+ lines-vscrolled)
+ nil))))
+ (beginning-of-buffer
+ (message (error-message-string '(beginning-of-buffer))))
+ (end-of-buffer
+ (message (error-message-string '(end-of-buffer)))))
+
+ ;; Perform horizontal scrolling by DX, as this does not signal at
+ ;; the beginning of the buffer.
+ (let ((accumulator (or (nth 6 touch-screen-current-tool) 0))
+ (window (cadr touch-screen-current-tool))
+ (lines-vscrolled (or (nth 7 touch-screen-current-tool) 0))
+ (lines-hscrolled (or (nth 8 touch-screen-current-tool) 0)))
+ (setq accumulator (+ accumulator dx)) ; Add dx.
+ ;; Figure out how much it has scrolled and how much remains on the
+ ;; left or right of the window. If a line has already been
+ ;; vscrolled but no hscrolling has happened, don't hscroll, as
+ ;; otherwise it is too easy to hscroll by accident.
+ (if (or (> lines-hscrolled 0)
+ (< lines-vscrolled 1))
+ (while (catch 'again
+ (let* ((column-width (frame-char-width (window-frame window))))
+ (if (and (< accumulator 0)
+ (>= (- accumulator) column-width))
+ (progn
+ (setq accumulator (+ accumulator column-width))
+ ;; Maintain both hscroll counters even when
+ ;; it's disabled to prevent unintentional or
+ ;; patently horizontal gestures from
+ ;; scrolling the window vertically.
+ (when touch-screen-enable-hscroll
+ (scroll-right 1))
+ (setq lines-hscrolled (1+ lines-hscrolled))
+ (when (not (zerop accumulator))
+ ;; If there is still an outstanding amount
+ ;; to scroll, do this again.
+ (throw 'again t)))
+ (when (and (> accumulator 0)
+ (>= accumulator column-width))
+ (setq accumulator (- accumulator column-width))
+ (when touch-screen-enable-hscroll
+ (scroll-left 1))
+ (setq lines-hscrolled (1+ lines-hscrolled))
+ (when (not (zerop accumulator))
+ ;; If there is still an outstanding amount to
+ ;; scroll, do this again.
+ (throw 'again t)))))
+ ;; Scrolling is done. Move the accumulator back to
+ ;; touch-screen-current-tool and break out of the
+ ;; loop.
+ (setcar (nthcdr 6 touch-screen-current-tool) accumulator)
+ (setcar (nthcdr 8 touch-screen-current-tool) lines-hscrolled)
+ nil)))))
+
+(defun touch-screen-scroll (event)
+ "Scroll the window within EVENT, a `touchscreen-scroll' event.
+If `touch-screen-precision-scroll', scroll the window vertically
+by the number of pixels specified within that event. Else,
+scroll the window by one line for every
+`window-default-line-height' pixels worth of movement.
+
+If EVENT also specifies horizontal motion and no significant
+amount of vertical scrolling has taken place, also scroll the
+window horizontally in conjunction with the number of pixels in
+the event."
+ (interactive "e")
+ (let ((window (nth 1 event))
+ (dx (nth 2 event))
+ (dy (nth 3 event)))
+ (with-selected-window window
+ (touch-screen-handle-scroll dx dy))))
+
+(global-set-key [touchscreen-scroll] #'touch-screen-scroll)
+
+
+
+;;; Drag-to-select gesture.
+
+;;;###autoload
+(defun touch-screen-hold (event)
+ "Handle a long press EVENT.
+Ding and select the window at EVENT, then activate the mark. If
+`touch-screen-word-select' is enabled, try to select the whole
+word around EVENT; otherwise, set point to the location of EVENT."
+ (interactive "e")
+ (let* ((posn (cadr event))
+ (point (posn-point posn))
+ (window (posn-window posn)))
+ (when (and point
+ ;; Make sure WINDOW is not an inactive minibuffer
+ ;; window.
+ (or (not (eq window
+ (minibuffer-window
+ (window-frame window))))
+ (minibuffer-window-active-p window)))
+ (beep)
+ (select-window window)
+ (if (or (not touch-screen-word-select)
+ (when-let* ((char (char-after point))
+ (class (char-syntax char)))
+ ;; Don't select words if point isn't inside a word
+ ;; constituent or similar.
+ (not (or (eq class ?w) (eq class ?_)))))
+ (progn
+ ;; Set the mark and activate it.
+ (setq touch-screen-word-select-initial-word nil
+ touch-screen-word-select-bounds nil)
+ (push-mark point)
+ (goto-char point)
+ (activate-mark))
+ ;; Start word selection by trying to obtain the position
+ ;; around point.
+ (let ((word-start nil)
+ (word-end nil))
+ (unless (posn-object posn)
+ ;; If there's an object under POSN avoid trying to
+ ;; ascertain the bounds of the word surrounding it.
+ (save-excursion
+ (goto-char point)
+ (forward-word-strictly)
+ ;; Set word-end to ZV if there is no word after this
+ ;; one.
+ (setq word-end (point))
+ ;; Now try to move backwards. Set word-start to BEGV if
+ ;; this word is there.
+ (backward-word-strictly)
+ (setq word-start (point))))
+ ;; Check if word-start and word-end are identical, if there
+ ;; is an object under POSN, or if point is looking at or
+ ;; outside a word.
+ (if (or (eq word-start word-end)
+ (>= word-start point))
+ (progn
+ ;; If so, clear the bounds and set and activate the
+ ;; mark.
+ (setq touch-screen-word-select-bounds nil
+ touch-screen-word-select-initial-word nil)
+ (push-mark point)
+ (goto-char point)
+ (activate-mark))
+ ;; Otherwise, select the word. Move point to either the
+ ;; end or the start of the word, depending on which is
+ ;; closer to EVENT.
+ (let ((diff-beg (- point word-start))
+ (diff-end (- word-end point))
+ use-end)
+ (if (> diff-beg diff-end)
+ ;; Set the point to the end of the word.
+ (setq use-end t)
+ (if (< diff-end diff-beg)
+ (setq use-end nil)
+ ;; POINT is in the middle of the word. Use its
+ ;; window coordinates to establish whether or not it
+ ;; is closer to the start of the word or to the end
+ ;; of the word.
+ (let ((posn-beg (posn-at-point word-start))
+ (posn-end (posn-at-point word-end)))
+ ;; Give up if there's an object at either of those
+ ;; positions, or they're not on the same row.
+ ;; If one of the positions isn't visible, use the
+ ;; window end.
+ (if (and posn-beg posn-end
+ (not (posn-object posn-beg))
+ (not (posn-object posn-end))
+ (eq (cdr (posn-col-row posn-beg))
+ (cdr (posn-col-row posn-end))))
+ (setq use-end nil)
+ ;; Compare the pixel positions.
+ (setq point (car (posn-x-y posn))
+ diff-beg (- point (car (posn-x-y posn-beg)))
+ diff-end (- (car (posn-x-y posn-end)) point))
+ ;; Now determine whether or not point should be
+ ;; moved to the end.
+ (setq use-end (>= diff-beg diff-end))))))
+ (if use-end
+ (progn
+ (push-mark word-start)
+ (activate-mark)
+ (goto-char word-end))
+ (progn
+ (push-mark word-end)
+ (activate-mark)
+ (goto-char word-start)))
+ ;; Record the bounds of the selected word.
+ (setq touch-screen-word-select-bounds
+ (cons word-start word-end)
+ ;; Save this for the benefit of touch-screen-drag.
+ touch-screen-word-select-initial-word
+ (cons word-start word-end)))))))))
+
+(defun touch-screen-preview-select ()
+ "Display a preview of the line around point in the echo area.
+Unless the minibuffer is an active or the current line is
+excessively tall, display an indication of the position of point
+and the contents of the visible line around it within the echo
+area.
+
+If the selected window is hscrolled or lines may be truncated,
+attempt to find the extents of the text between column 0 and the
+right most column of the window using `posn-at-x-y'."
+ (interactive)
+ ;; First, establish that the minibuffer isn't active and the line
+ ;; isn't taller than two times the frame character height.
+ (unless (or (> (minibuffer-depth) 0)
+ ;; The code below doesn't adapt well to buffers
+ ;; containing long lines.
+ (long-line-optimizations-p)
+ (let ((window-line-height (window-line-height))
+ (maximum-height (* 2 (frame-char-height))))
+ (unless window-line-height
+ ;; `window-line-height' isn't available.
+ ;; Redisplay first and try to ascertain the height
+ ;; of the line again.
+ (redisplay t)
+ (setq window-line-height (window-line-height)))
+ ;; `window-line-height' might still be unavailable.
+ (and window-line-height
+ (> (car window-line-height)
+ maximum-height))))
+ (catch 'hscrolled-away
+ (let ((beg nil) end string y)
+ ;; Detect whether or not the window is hscrolled. If it
+ ;; is, set beg to the location of the first column
+ ;; instead.
+ (when (> (window-hscroll) 0)
+ (setq y (+ (or (cdr (posn-x-y (posn-at-point)))
+ (throw 'hscrolled-away t))
+ (window-header-line-height)
+ (window-tab-line-height)))
+ (let* ((posn (posn-at-x-y 0 y))
+ (point (posn-point posn)))
+ (setq beg point)))
+ ;; Check if lines are being truncated; if so, use the
+ ;; character at the end of the window as the end of the
+ ;; text to be displayed, as the visual line may extend
+ ;; past the window.
+ (when (or truncate-lines beg) ; truncate-lines or hscroll.
+ (setq y (or y (+ (or (cdr (posn-x-y (posn-at-point)))
+ (throw 'hscrolled-away t))
+ (window-header-line-height)
+ (window-tab-line-height))))
+ (let* ((posn (posn-at-x-y (1- (window-width nil t)) y))
+ (point (posn-point posn)))
+ (setq end point)))
+ ;; Now find the rest of the visual line.
+ (save-excursion
+ (unless beg
+ (beginning-of-visual-line)
+ (setq beg (point)))
+ (unless end
+ (end-of-visual-line)
+ (setq end (point))))
+ ;; Obtain a substring containing the beginning of the
+ ;; visual line and the end.
+ (setq string (buffer-substring beg end))
+ ;; Hack `invisible' properties within the new string.
+ ;; Look for each change of the property that is a variable
+ ;; name and replace it with its actual value according to
+ ;; `buffer-invisibility-spec'.
+ (when (listp buffer-invisibility-spec)
+ (let ((index 0)
+ (property (get-text-property 0
+ 'invisible
+ string))
+ index1 invisible)
+ (while index
+ ;; Find the end of this text property.
+ (setq index1 (next-single-property-change index
+ 'invisible
+ string))
+ ;; Replace the property with whether or not it is
+ ;; non-nil.
+ (when property
+ (setq invisible nil)
+ (catch 'invisible
+ (dolist (spec buffer-invisibility-spec)
+ ;; Process one element of the buffer
+ ;; invisibility specification.
+ (if (consp spec)
+ (when (eq (cdr spec) 't)
+ ;; (ATOM . t) makes N invisible if N is
+ ;; equal to ATOM or a list containing
+ ;; ATOM.
+ (when (or (eq (car spec) property)
+ (and (listp spec)
+ (memq (car spec) invisible)))
+ (throw 'invisible (setq invisible t))))
+ ;; Otherwise, N is invisible if SPEC is
+ ;; equal to N.
+ (when (eq spec property)
+ (throw 'invisible (setq invisible t))))))
+ (put-text-property index (or index1
+ (- end beg))
+ 'invisible invisible string))
+ ;; Set index to that of the next text property and
+ ;; continue.
+ (setq index index1
+ property (and index1
+ (get-text-property index1
+ 'invisible
+ string))))))
+ (let ((resize-mini-windows t) difference width
+ (message-log-max nil))
+ ;; Find the offset of point from beg and display a cursor
+ ;; below.
+ (setq difference (- (point) beg)
+ width (string-pixel-width
+ (substring string 0 difference)))
+ (message "%s\n%s^" string
+ (propertize " "
+ 'display (list 'space
+ :width (list width)))))
+ nil))))
+
+(defun touch-screen-drag (event)
+ "Handle a drag EVENT by setting the region to its new point.
+If `touch-screen-word-select' and EVENT lies outside the last
+word that was selected, select the word that now contains POINT.
+Scroll the window if EVENT's coordinates are outside its text
+area."
+ (interactive "e")
+ (let* ((posn (cadr event)) ; Position of the tool.
+ (point (posn-point posn)) ; Point of the event.
+ ;; Window where the tap originated.
+ (window (nth 1 touch-screen-current-tool))
+ ;; The currently selected window. Used to redisplay within
+ ;; the correct window while scrolling.
+ (old-window (selected-window))
+ ;; Whether or not text should be selected word-by-word.
+ (word-select touch-screen-word-select)
+ ;; Cons containing the confines of the word initially
+ ;; selected when the touchpoint was first held down.
+ (initial touch-screen-word-select-initial-word)
+ initial-point)
+ ;; Keep dragging.
+ (with-selected-window window
+ ;; Figure out what character to go to. If this posn is in the
+ ;; window, go to (posn-point posn). If not, then go to the line
+ ;; before either window start or window end.
+ (setq initial-point (point))
+ (when (or (not point)
+ (not (eq point initial-point)))
+ (if (and (eq (posn-window posn) window)
+ point
+ ;; point must be visible in the window. If it isn't,
+ ;; the window must be scrolled.
+ (pos-visible-in-window-p point))
+ (let* ((bounds touch-screen-word-select-bounds)
+ (maybe-select-word (or (not touch-screen-word-select)
+ (or (not bounds)
+ (> point (cdr bounds))
+ (< point (car bounds))))))
+ (if (and word-select
+ ;; point is now outside the last word selected.
+ maybe-select-word
+ (not (posn-object posn))
+ (when-let* ((char (char-after point))
+ (class (char-syntax char)))
+ ;; Don't select words if point isn't inside a
+ ;; word constituent or similar.
+ (or (eq class ?w) (eq class ?_))))
+ ;; Determine the confines of the word containing
+ ;; POINT.
+ (let (word-start word-end)
+ (save-excursion
+ (goto-char point)
+ (forward-word-strictly)
+ ;; Set word-end to ZV if there is no word after
+ ;; this one.
+ (setq word-end (point))
+ ;; Now try to move backwards. Set word-start to
+ ;; BEGV if this word is there.
+ (backward-word-strictly)
+ (setq word-start (point)))
+ (let ((mark (mark)))
+ ;; Extend the region to cover either word-end or
+ ;; word-start; whether to goto word-end or
+ ;; word-start is subject to the position of the
+ ;; mark relative to point.
+ (if (< word-start mark)
+ ;; The start of the word is behind mark.
+ ;; Extend the region towards the start.
+ (goto-char word-start)
+ ;; Else, go to the end of the word.
+ (goto-char word-end))
+ ;; If point is less than mark, which is is less
+ ;; than the end of the word that was originally
+ ;; selected, try to keep it selected by moving
+ ;; mark there.
+ (when (and initial (<= (point) mark)
+ (< mark (cdr initial)))
+ (set-mark (cdr initial)))
+ ;; Do the opposite when the converse is true.
+ (when (and initial (>= (point) mark)
+ (> mark (car initial)))
+ (set-mark (car initial))))
+ (if bounds
+ (progn (setcar bounds word-start)
+ (setcdr bounds word-end))
+ (setq touch-screen-word-select-bounds
+ (cons word-start word-end))))
+ (when maybe-select-word
+ (goto-char (posn-point posn))
+ (when initial
+ ;; If point is less than mark, which is is less
+ ;; than the end of the word that was originally
+ ;; selected, try to keep it selected by moving
+ ;; mark there.
+ (when (and (<= (point) (mark))
+ (< (mark) (cdr initial)))
+ (set-mark (cdr initial)))
+ ;; Do the opposite when the converse is true.
+ (when (and (>= (point) (mark))
+ (> (mark) (car initial)))
+ (set-mark (car initial))))
+ (setq touch-screen-word-select-bounds nil)))
+ ;; Finally, display a preview of the line around point
+ ;; if requested by the user.
+ (when (and touch-screen-preview-select
+ (not (eq (point) initial-point)))
+ (touch-screen-preview-select)))
+ ;; POSN is outside the window. Scroll accordingly.
+ (let* ((relative-xy
+ (touch-screen-relative-xy posn window))
+ (xy (posn-x-y posn))
+ ;; The height of the window's text area.
+ (body-height (window-body-height nil t))
+ ;; This is used to find the character closest to
+ ;; POSN's column at the bottom of the window.
+ (height (- body-height
+ ;; Use the last row of the window, not its
+ ;; last pixel.
+ (frame-char-height)))
+ (midpoint (/ body-height 2))
+ (scroll-conservatively 101))
+ (cond
+ ((< (cdr relative-xy) midpoint)
+ ;; POSN is before half the window, yet POINT does not
+ ;; exist or is not completely visible within. Scroll
+ ;; downwards.
+ (ignore-errors
+ ;; Scroll down by a single line.
+ (scroll-down 1)
+ ;; After scrolling, look up the new posn at EVENT's
+ ;; column and go there.
+ (setq posn (posn-at-x-y (car xy) 0)
+ point (posn-point posn))
+ (if point
+ (goto-char point)
+ ;; If there's no buffer position at that column, go
+ ;; to the window start.
+ (goto-char (window-start)))
+ ;; If word selection is enabled, now try to keep the
+ ;; initially selected word within the active region.
+ (when word-select
+ (when initial
+ ;; If point is less than mark, which is is less
+ ;; than the end of the word that was originally
+ ;; selected, try to keep it selected by moving
+ ;; mark there.
+ (when (and (<= (point) (mark))
+ (< (mark) (cdr initial)))
+ (set-mark (cdr initial)))
+ ;; Do the opposite when the converse is true.
+ (when (and (>= (point) (mark))
+ (> (mark) (car initial)))
+ (set-mark (car initial))))
+ (setq touch-screen-word-select-bounds nil))
+ ;; Display a preview of the line now around point if
+ ;; requested by the user.
+ (when touch-screen-preview-select
+ (touch-screen-preview-select))
+ ;; Select old-window, so that redisplay doesn't
+ ;; display WINDOW as selected if it isn't already.
+ (with-selected-window old-window
+ ;; Now repeat this every `mouse-scroll-delay' until
+ ;; input becomes available, but scroll down a few
+ ;; more lines.
+ (while (sit-for mouse-scroll-delay)
+ ;; Select WINDOW again.
+ (with-selected-window window
+ ;; Keep scrolling down until input becomes
+ ;; available.
+ (scroll-down 4)
+ ;; After scrolling, look up the new posn at
+ ;; EVENT's column and go there.
+ (setq posn (posn-at-x-y (car xy) 0)
+ point (posn-point posn))
+ (if point
+ (goto-char point)
+ ;; If there's no buffer position at that
+ ;; column, go to the window start.
+ (goto-char (window-start)))
+ ;; If word selection is enabled, now try to keep
+ ;; the initially selected word within the active
+ ;; region.
+ (when word-select
+ (when initial
+ ;; If point is less than mark, which is is
+ ;; less than the end of the word that was
+ ;; originally selected, try to keep it
+ ;; selected by moving mark there.
+ (when (and (<= (point) (mark))
+ (< (mark) (cdr initial)))
+ (set-mark (cdr initial)))
+ ;; Do the opposite when the converse is true.
+ (when (and (>= (point) (mark))
+ (> (mark) (car initial)))
+ (set-mark (car initial))))
+ (setq touch-screen-word-select-bounds nil))
+ ;; Display a preview of the line now around
+ ;; point if requested by the user.
+ (when touch-screen-preview-select
+ (touch-screen-preview-select))))))
+ (setq touch-screen-word-select-bounds nil))
+ ((>= (cdr relative-xy) midpoint)
+ ;; Default to scrolling upwards even if POSN is still
+ ;; within the confines of the window. If POINT is
+ ;; partially visible, and the branch above hasn't been
+ ;; taken it must be somewhere at the bottom of the
+ ;; window, so scroll downwards.
+ (ignore-errors
+ ;; Scroll up by a single line.
+ (scroll-up 1)
+ ;; After scrolling, look up the new posn at EVENT's
+ ;; column and go there.
+ (setq posn (posn-at-x-y (car xy) height)
+ point (posn-point posn))
+ (if point
+ (goto-char point)
+ ;; If there's no buffer position at that column, go
+ ;; to the window start.
+ (goto-char (window-end nil t)))
+ ;; If word selection is enabled, now try to keep
+ ;; the initially selected word within the active
+ ;; region.
+ (when word-select
+ (when initial
+ ;; If point is less than mark, which is is less
+ ;; than the end of the word that was originally
+ ;; selected, try to keep it selected by moving
+ ;; mark there.
+ (when (and (<= (point) (mark))
+ (< (mark) (cdr initial)))
+ (set-mark (cdr initial)))
+ ;; Do the opposite when the converse is true.
+ (when (and (>= (point) (mark))
+ (> (mark) (car initial)))
+ (set-mark (car initial))))
+ (setq touch-screen-word-select-bounds nil))
+ ;; Display a preview of the line now around point if
+ ;; requested by the user.
+ (when touch-screen-preview-select
+ (touch-screen-preview-select))
+ ;; Select old-window, so that redisplay doesn't
+ ;; display WINDOW as selected if it isn't already.
+ (with-selected-window old-window
+ ;; Now repeat this every `mouse-scroll-delay' until
+ ;; input becomes available, but scroll down a few
+ ;; more lines.
+ (while (sit-for mouse-scroll-delay)
+ ;; Select WINDOW again.
+ (with-selected-window window
+ ;; Keep scrolling down until input becomes
+ ;; available.
+ (scroll-up 4)
+ ;; After scrolling, look up the new posn at
+ ;; EVENT's column and go there.
+ (setq posn (posn-at-x-y (car xy) height)
+ point (posn-point posn))
+ (if point
+ (goto-char point)
+ ;; If there's no buffer position at that
+ ;; column, go to the window start.
+ (goto-char (window-end nil t)))
+ ;; If word selection is enabled, now try to keep
+ ;; the initially selected word within the active
+ ;; region.
+ (when word-select
+ (when initial
+ ;; If point is less than mark, which is is less
+ ;; than the end of the word that was originally
+ ;; selected, try to keep it selected by moving
+ ;; mark there.
+ (when (and (<= (point) (mark))
+ (< (mark) (cdr initial)))
+ (set-mark (cdr initial)))
+ ;; Do the opposite when the converse is true.
+ (when (and (>= (point) (mark))
+ (> (mark) (car initial)))
+ (set-mark (car initial))))
+ (setq touch-screen-word-select-bounds nil))
+ ;; Display a preview of the line now around
+ ;; point if requested by the user.
+ (when touch-screen-preview-select
+ (touch-screen-preview-select))))))))))))))
+
+(defun touch-screen-restart-drag (event)
+ "Restart dragging to select text.
+Set point to the location of EVENT within its window while
+keeping the bounds of the region intact, and set up state for
+`touch-screen-drag'."
+ (interactive "e")
+ (let* ((posn (event-start event))
+ (window (posn-window posn))
+ (point (posn-point posn)))
+ (with-selected-window window
+ (let ((current-point (point))
+ (current-mark (mark)))
+ ;; Ensure that mark and point haven't changed since EVENT was
+ ;; generated, and the region is still active.
+ (when (or (eq point current-point)
+ (eq point current-mark)
+ (region-active-p))
+ (when (eq point current-mark)
+ ;; Exchange point and mark.
+ (exchange-point-and-mark))
+ ;; Clear the state necessary to set up dragging. Don't try
+ ;; to select entire words immediately after dragging starts,
+ ;; to allow for fine grained selection inside a word.
+ (setq touch-screen-word-select-bounds nil
+ touch-screen-word-select-initial-word nil))))))
+
+(global-set-key [touchscreen-hold] #'touch-screen-hold)
+(global-set-key [touchscreen-drag] #'touch-screen-drag)
+(global-set-key [touchscreen-restart-drag] #'touch-screen-restart-drag)
+
+
+
+;; Pinch gesture.
+
+(defvar text-scale-mode)
+(defvar text-scale-mode-amount)
+(defvar text-scale-mode-step)
+
+(defun touch-screen-scroll-point-to-y (target-point target-y)
+ "Move the row surrounding TARGET-POINT to TARGET-Y.
+Scroll the current window such that the position of TARGET-POINT
+within it on the Y axis approaches TARGET-Y."
+ (condition-case nil
+ (let* ((last-point (point))
+ (current-y (cadr (pos-visible-in-window-p target-point
+ nil t)))
+ (direction (if (if current-y
+ (< target-y current-y)
+ (< (window-start) target-point))
+ -1 1)))
+ (while (< 0 (* direction (if current-y
+ (- target-y current-y)
+ (- (window-start) target-point))))
+ (scroll-down direction)
+ (setq last-point (point))
+ (setq current-y (cadr (pos-visible-in-window-p target-point nil t))))
+ (unless (and (< direction 0) current-y)
+ (scroll-up direction)
+ (goto-char last-point)))
+ ;; Ignore BOB and EOB.
+ ((beginning-of-buffer end-of-buffer) nil)))
+
+(defun touch-screen-pinch (event)
+ "Scroll the window in the touchscreen-pinch event EVENT.
+Pan the display by the pan deltas in EVENT, and adjust the
+text scale by the ratio therein."
+ (interactive "e")
+ (require 'face-remap)
+ (let* ((posn (cadr event))
+ (window (posn-window posn))
+ (scale (nth 2 event))
+ (ratio-diff (nth 5 event))
+ current-scale start-scale)
+ (when (windowp window)
+ (with-selected-window window
+ (setq current-scale (if text-scale-mode
+ text-scale-mode-amount
+ 0)
+ start-scale (or (aref touch-screen-aux-tool 7)
+ (aset touch-screen-aux-tool 7
+ current-scale)))
+ ;; Set the text scale.
+ (text-scale-set (+ start-scale
+ (round (log scale text-scale-mode-step))))
+ ;; Subsequently move the row which was at the centrum to its Y
+ ;; position.
+ (if (and (not (eq current-scale
+ text-scale-mode-amount))
+ (posn-point posn)
+ (cdr (posn-x-y posn)))
+ (touch-screen-scroll-point-to-y (posn-point posn)
+ (cdr (posn-x-y posn)))
+ ;; Rather than scroll POSN's point to its old row, scroll the
+ ;; display by the Y axis deltas within EVENT.
+ (let ((height (window-default-line-height))
+ (y-accumulator (or (aref touch-screen-aux-tool 8) 0)))
+ (setq y-accumulator (+ y-accumulator (nth 4 event)))
+ (when (or (> y-accumulator height)
+ (< y-accumulator (- height)))
+ (ignore-errors
+ (if (> y-accumulator 0)
+ (scroll-down 1)
+ (scroll-up 1)))
+ (setq y-accumulator 0))
+ (aset touch-screen-aux-tool 8 y-accumulator))
+ ;; Likewise for the X axis deltas.
+ (let ((width (frame-char-width))
+ (x-accumulator (or (aref touch-screen-aux-tool 9) 0)))
+ (setq x-accumulator (+ x-accumulator (nth 3 event)))
+ (when (or (> x-accumulator width)
+ (< x-accumulator (- width)))
+ ;; Do not hscroll if the ratio has shrunk, for that is
+ ;; generally attended by the centerpoint moving left,
+ ;; and Emacs can hscroll left even when no lines are
+ ;; truncated.
+ (unless (and (< x-accumulator 0)
+ (< ratio-diff 0))
+ (if (> x-accumulator 0)
+ (scroll-right 1)
+ (scroll-left 1)))
+ (setq x-accumulator 0))
+ (aset touch-screen-aux-tool 9 x-accumulator)))))))
+
+(define-key global-map [touchscreen-pinch] #'touch-screen-pinch)
+
+
+
+;; Touch screen event translation. The code here translates raw touch
+;; screen events into `touchscreen-scroll' events and mouse events in
+;; a ``DWIM'' fashion, consulting the keymaps at the position of the
+;; mouse event to determine the best course of action, while also
+;; recognizing drag-to-select and other gestures.
+
+(defun touch-screen-handle-timeout (arg)
+ "Start the touch screen timeout or handle it depending on ARG.
+When ARG is nil, start the `touch-screen-current-timer' to go off
+in `touch-screen-delay' seconds, and call this function with ARG
+t.
+
+When ARG is t, set the fourth element of
+`touch-screen-current-tool' to `held', and generate a
+`touchscreen-hold' event at the original position of that tool."
+ (if (not arg)
+ ;; Cancel the touch screen long-press timer, if it is still
+ ;; there by any chance.
+ (progn
+ (when touch-screen-current-timer
+ (cancel-timer touch-screen-current-timer))
+ (setq touch-screen-current-timer
+ (run-at-time touch-screen-delay nil
+ #'touch-screen-handle-timeout
+ t)))
+ ;; Set touch-screen-current-timer to nil.
+ (setq touch-screen-current-timer nil)
+ (when touch-screen-current-tool
+ ;; Set the state to `held'.
+ (setcar (nthcdr 3 touch-screen-current-tool) 'held)
+ ;; Generate an input event at the original position of the mark.
+ ;; This assumes that the timer is running within
+ ;; `touch-screen-translate-touch'.
+ (let ((posn (nth 4 touch-screen-current-tool)))
+ (throw 'input-event (list 'touchscreen-hold posn))))))
+
+(defun touch-screen-handle-point-update (point)
+ "Notice that the touch point POINT has changed position.
+Perform the editing operations or throw to the input translation
+function with an input event tied to any gesture that is
+recognized.
+
+Update the tenth element of `touch-screen-current-tool' with
+POINT relative to the window it was placed on. Update the third
+element in like fashion, once sufficient motion has accumulated
+that an event is generated.
+
+POINT must be the touch point currently being tracked as
+`touch-screen-current-tool'.
+
+If the fourth element of `touch-screen-current-tool' is nil, then
+the touch has just begun. In a related case, if it is
+`ancillary-tool', then the ancillary tool has been removed and
+gesture translation must be resumed. Determine how much POINT
+has moved. If POINT has moved upwards or downwards by a
+significant amount, then set the fourth element to `scroll'.
+Then, generate a `touchscreen-scroll' event with the window that
+POINT was initially placed upon, and pixel deltas describing how
+much point has moved relative to its previous position in the X
+and Y axes.
+
+If the fourth element of `touch-screen-current-tool' is `scroll',
+then generate a `touchscreen-scroll' event with the window that
+POINT was initially placed upon, and pixel deltas describing how
+much point has moved relative to its previous position in the X
+and Y axes.
+
+If the fourth element of `touch-screen-current-tool' is
+`mouse-drag' and `track-mouse' is non-nil, then generate a
+`mouse-movement' event with the position of POINT.
+
+If the fourth element of `touch-screen-current-tool' is `held',
+then the touch has been held down for some time. If motion
+happens, set the field to `drag'. Then, generate a
+`touchscreen-drag' event.
+
+If the fourth element of `touch-screen-current-tool' is
+`restart-drag', set the field to `drag' and generate a
+`touchscreen-drag'.
+
+If the fourth element of `touch-screen-current-tool' is `drag',
+then move point to the position of POINT."
+ (let* ((window (nth 1 touch-screen-current-tool))
+ (what (nth 3 touch-screen-current-tool))
+ (posn (cdr point))
+ ;; Now get the position of X and Y relative to WINDOW.
+ (relative-xy
+ (touch-screen-relative-xy posn window)))
+ ;; Update the 10th field of the tool list with RELATIVE-XY.
+ (setcar (nthcdr 9 touch-screen-current-tool) relative-xy)
+ (cond ((or (null what)
+ (eq what 'ancillary-tool))
+ (let* ((last-posn (nth 2 touch-screen-current-tool))
+ (diff-x (- (car last-posn) (car relative-xy)))
+ (diff-y (- (cdr last-posn) (cdr relative-xy))))
+ (when (or (> diff-y 10)
+ (> diff-x (frame-char-width))
+ (< diff-y -10)
+ (< diff-x (- (frame-char-width))))
+ (setcar (nthcdr 3 touch-screen-current-tool)
+ 'scroll)
+ (setcar (nthcdr 2 touch-screen-current-tool)
+ relative-xy)
+ ;; Cancel the touch screen long-press timer, if it is
+ ;; still there by any chance.
+ (when touch-screen-current-timer
+ (cancel-timer touch-screen-current-timer)
+ (setq touch-screen-current-timer nil))
+ ;; Generate a `touchscreen-scroll' event with `diff-x'
+ ;; and `diff-y'.
+ (throw 'input-event
+ (list 'touchscreen-scroll
+ window diff-x diff-y)))))
+ ((eq what 'scroll)
+ ;; Cancel the touch screen long-press timer, if it is still
+ ;; there by any chance.
+ (when touch-screen-current-timer
+ (cancel-timer touch-screen-current-timer)
+ (setq touch-screen-current-timer nil))
+ (let* ((last-posn (nth 2 touch-screen-current-tool))
+ (diff-x (- (car last-posn) (car relative-xy)))
+ (diff-y (- (cdr last-posn) (cdr relative-xy))))
+ (setcar (nthcdr 3 touch-screen-current-tool)
+ 'scroll)
+ (setcar (nthcdr 2 touch-screen-current-tool)
+ relative-xy)
+ (unless (and (zerop diff-x) (zerop diff-y))
+ (throw 'input-event
+ ;; Generate a `touchscreen-scroll' event with
+ ;; `diff-x' and `diff-y'.
+ (list 'touchscreen-scroll
+ window diff-x diff-y)))))
+ ((eq what 'mouse-drag)
+ ;; There was a `down-mouse-1' event bound at the starting
+ ;; point of the event. Generate a mouse-motion event if
+ ;; mouse movement is being tracked.
+ (when track-mouse
+ (throw 'input-event (list 'mouse-movement
+ (cdr point)))))
+ ((eq what 'held)
+ (let* ((posn (cdr point)))
+ ;; Now start dragging.
+ (setcar (nthcdr 3 touch-screen-current-tool)
+ 'drag)
+ ;; Generate a (touchscreen-drag POSN) event.
+ ;; `touchscreen-hold' was generated when the timeout
+ ;; fired.
+ (throw 'input-event (list 'touchscreen-drag posn))))
+ ((eq what 'restart-drag)
+ (let* ((posn (cdr point)))
+ ;; Now start dragging.
+ (setcar (nthcdr 3 touch-screen-current-tool)
+ 'drag)
+ ;; Generate a (touchscreen-drag POSN) event.
+ ;; `touchscreen-restart-drag' was generated when the
+ ;; timeout fired.
+ (throw 'input-event (list 'touchscreen-drag posn))))
+ ((eq what 'drag)
+ (let* ((posn (cdr point)))
+ ;; Generate a (touchscreen-drag POSN) event.
+ (throw 'input-event (list 'touchscreen-drag posn)))))))
+
+(defsubst touch-screen-distance (pos1 pos2)
+ "Compute the distance in pixels between POS1 and POS2.
+Each is a coordinate whose car and cdr are respectively its X and
+Y values."
+ (let ((v1 (- (cdr pos2) (cdr pos1)))
+ (v2 (- (car pos2) (car pos1))))
+ (abs (sqrt (+ (* v1 v1) (* v2 v2))))))
+
+(defsubst touch-screen-centrum (pos1 pos2)
+ "Compute the center of a line between the points POS1 and POS2.
+Each, and value, is a coordinate whose car and cdr are
+respectively its X and Y values."
+ (let ((v1 (+ (cdr pos2) (cdr pos1)))
+ (v2 (+ (car pos2) (car pos1))))
+ (cons (/ v2 2) (/ v1 2))))
+
+(defun touch-screen-handle-aux-point-update (point number)
+ "Notice that a point being observed has moved.
+Register motion from either the current or ancillary tool while
+an ancillary tool is present.
+
+POINT must be the cdr of an element of a `touchscreen-update'
+event's list of touch points. NUMBER must be its touch ID.
+
+Calculate the distance between POINT's position and that of the
+other tool (which is to say the ancillary tool of POINT is the
+current tool, and vice versa). Compare this distance to that
+between both points at the time they were placed on the screen,
+and signal a pinch event to adjust the text scale and scroll the
+window by the factor so derived. Such events are lists formed as
+so illustrated:
+
+ (touchscreen-pinch CENTRUM RATIO PAN-X PAN-Y RATIO-DIFF)
+
+in which CENTRUM is a posn representing the midpoint of a line
+between the present locations of both tools, RATIO is the said
+factor, PAN-X is the number of pixels on the X axis that centrum
+has moved since the last event, PAN-Y is that on the Y axis, and
+RATIO-DIFF is the difference between RATIO and the ratio in the
+last such event."
+ (let (this-point-position
+ other-point-position
+ (window (cadr touch-screen-current-tool)))
+ (when (windowp window)
+ (if (eq number (aref touch-screen-aux-tool 0))
+ (progn
+ ;; The point pressed is the ancillary tool. Set
+ ;; other-point-position to that of the current tool.
+ (setq other-point-position (nth 9 touch-screen-current-tool))
+ ;; Update the position within touch-screen-aux-tool.
+ (aset touch-screen-aux-tool 3
+ (setq this-point-position
+ (touch-screen-relative-xy point window))))
+ (setq other-point-position (aref touch-screen-aux-tool 3))
+ (setcar (nthcdr 2 touch-screen-current-tool)
+ (setq this-point-position
+ (touch-screen-relative-xy point window)))
+ (setcar (nthcdr 9 touch-screen-current-tool)
+ this-point-position))
+ ;; Now compute, and take the absolute of, this distance.
+ (let ((distance (touch-screen-distance this-point-position
+ other-point-position))
+ (centrum (touch-screen-centrum this-point-position
+ other-point-position))
+ (initial-distance (aref touch-screen-aux-tool 4))
+ (initial-centrum (aref touch-screen-aux-tool 5)))
+ (let* ((ratio (/ distance initial-distance))
+ (ratio-diff (- ratio (aref touch-screen-aux-tool 6)))
+ (diff (abs (- ratio (aref touch-screen-aux-tool 6))))
+ (centrum-diff (+ (abs (- (car initial-centrum)
+ (car centrum)))
+ (abs (- (cdr initial-centrum)
+ (cdr centrum))))))
+ ;; If the difference in ratio has surpassed a threshold of
+ ;; 0.2 or the centrum difference exceeds the frame's char
+ ;; width, send a touchscreen-pinch event with this
+ ;; information and update that saved in
+ ;; touch-screen-aux-tool.
+ (when (or (> diff 0.2)
+ (> centrum-diff
+ (/ (frame-char-width) 2)))
+ (aset touch-screen-aux-tool 5 centrum)
+ (aset touch-screen-aux-tool 6 ratio)
+ (throw 'input-event
+ (list 'touchscreen-pinch
+ (if (or (<= (car centrum) 0)
+ (<= (cdr centrum) 0))
+ (list window nil centrum nil nil
+ nil nil nil nil nil)
+ (let ((posn (posn-at-x-y (car centrum)
+ (cdr centrum)
+ window)))
+ (if (eq (posn-window posn)
+ window)
+ posn
+ ;; Return a placeholder
+ ;; outside the window if
+ ;; the centrum has moved
+ ;; beyond the confines of
+ ;; the window where the
+ ;; gesture commenced.
+ (list window nil centrum nil nil
+ nil nil nil nil nil))))
+ ratio
+ (- (car centrum)
+ (car initial-centrum))
+ (- (cdr centrum)
+ (cdr initial-centrum))
+ ratio-diff))))))))
+
+(defun touch-screen-window-selection-changed (frame)
+ "Notice that FRAME's selected window has changed.
+Cancel any timer that is supposed to hide the keyboard in
+response to the minibuffer being closed."
+ (with-selected-frame frame
+ (unless (and (or buffer-read-only
+ (get-text-property (point) 'read-only))
+ ;; Don't hide the on-screen keyboard if it's always
+ ;; supposed to be displayed.
+ (not touch-screen-display-keyboard))
+ ;; Prevent hiding the minibuffer from hiding the on screen
+ ;; keyboard.
+ (when minibuffer-on-screen-keyboard-timer
+ (cancel-timer minibuffer-on-screen-keyboard-timer)
+ (setq minibuffer-on-screen-keyboard-timer nil)))))
+
+(defun touch-screen-handle-point-up (point prefix)
+ "Notice that POINT has been removed from the screen.
+POINT should be the point currently tracked as
+`touch-screen-current-tool'.
+PREFIX should be a virtual function key used to look up key
+bindings.
+
+If an ancillary touch point is being observed, transfer touch
+information from `touch-screen-aux-tool' to
+`touch-screen-current-tool' and set it to nil, thereby resuming
+gesture recognition with that tool replacing the tool removed.
+
+Otherwise:
+
+If the fourth element of `touch-screen-current-tool' is nil or
+`restart-drag', move point to the position of POINT, selecting
+the window under POINT as well, and deactivate the mark; if there
+is a button or link at POINT, call the command bound to `mouse-2'
+there. Otherwise, call the command bound to `mouse-1'.
+
+If the fourth element of `touch-screen-current-tool' is
+`mouse-drag', then generate either a `mouse-1' or a
+`drag-mouse-1' event depending on how far the position of POINT
+is from the starting point of the touch.
+
+If the fourth element of `touch-screen-current-tool' is
+`mouse-1-menu', then generate a `down-mouse-1' event at the
+original position of the tool to display its bound keymap as a
+menu.
+
+If the fourth element of `touch-screen-current-tool' is `drag' or
+`held', the region is active, and the tool's initial window's
+selected buffer isn't read-only, display the on screen keyboard.
+
+If the command being executed is listed in
+`touch-screen-set-point-commands' also display the on-screen
+keyboard if the current buffer and the character at the new point
+is not read-only."
+ (if touch-screen-aux-tool
+ (progn
+ (let ((point-no (aref touch-screen-aux-tool 0))
+ (relative-xy (aref touch-screen-aux-tool 3)))
+ ;; Replace the current position of touch-screen-current-tool
+ ;; with relative-xy and its number with point-no, but leave
+ ;; other information (such as its starting position) intact:
+ ;; this touchpoint is meant to continue the gesture
+ ;; interrupted by the removal of the last, not to commence a
+ ;; new one.
+ (setcar touch-screen-current-tool point-no)
+ (setcar (nthcdr 2 touch-screen-current-tool)
+ relative-xy)
+ (setcar (nthcdr 9 touch-screen-current-tool)
+ relative-xy))
+ (setq touch-screen-aux-tool nil))
+ (let ((what (nth 3 touch-screen-current-tool))
+ (posn (cdr point)) window point)
+ (cond ((or (null what)
+ ;; If dragging has been restarted but the touch point
+ ;; hasn't been moved, translate the sequence into a
+ ;; regular mouse click.
+ (eq what 'restart-drag))
+ (when (windowp (posn-window posn))
+ (setq point (posn-point posn)
+ window (posn-window posn))
+ ;; Select the window that was tapped given that it
+ ;; isn't an inactive minibuffer window.
+ (when (or (not (eq window
+ (minibuffer-window
+ (window-frame window))))
+ (minibuffer-window-active-p window))
+ (select-window window))
+ ;; Now simulate a mouse click there. If there is a
+ ;; link or a button, use mouse-2 to push it.
+ (let* ((event (list (if (or (mouse-on-link-p posn)
+ (and point (button-at point)))
+ 'mouse-2
+ 'mouse-1)
+ posn))
+ ;; Look for the command bound to this event.
+ (command (key-binding (if prefix
+ (vector prefix
+ (car event))
+ (vector (car event)))
+ t nil posn)))
+ (deactivate-mark)
+ (when point
+ ;; This is necessary for following links.
+ (goto-char point))
+ ;; Figure out if the on screen keyboard needs to be
+ ;; displayed.
+ (when command
+ (if (memq command touch-screen-set-point-commands)
+ (if touch-screen-translate-prompt
+ ;; Forgo displaying the virtual keyboard
+ ;; should touch-screen-translate-prompt be
+ ;; set, for then the key won't be delivered
+ ;; to the command loop, but rather to a
+ ;; caller of read-key-sequence such as
+ ;; describe-key.
+ (throw 'input-event event)
+ (if (and (or (not buffer-read-only)
+ touch-screen-display-keyboard)
+ ;; Detect the splash screen and
+ ;; avoid displaying the on screen
+ ;; keyboard there.
+ (not (equal (buffer-name) "*GNU Emacs*")))
+ ;; Once the on-screen keyboard has been
+ ;; opened, add
+ ;; `touch-screen-window-selection-changed'
+ ;; as a window selection change function
+ ;; This then prevents it from being
+ ;; hidden after exiting the minibuffer.
+ (progn
+ (add-hook
+ 'window-selection-change-functions
+ #'touch-screen-window-selection-changed)
+ (frame-toggle-on-screen-keyboard
+ (selected-frame) nil))
+ ;; Otherwise, hide the on screen keyboard
+ ;; now.
+ (frame-toggle-on-screen-keyboard (selected-frame)
+ t))
+ ;; But if it's being called from `describe-key'
+ ;; or some such, return it as a key sequence.
+ (throw 'input-event event)))
+ ;; If not, return the event.
+ (throw 'input-event event)))))
+ ((eq what 'mouse-drag)
+ ;; Generate a corresponding `mouse-1' event.
+ (let* ((new-window (posn-window posn))
+ (new-point (posn-point posn))
+ (old-posn (nth 4 touch-screen-current-tool))
+ (old-window (posn-window posn))
+ (old-point (posn-point posn)))
+ (throw 'input-event
+ ;; If the position of the touch point hasn't
+ ;; changed, or it doesn't start or end on a
+ ;; window...
+ (if (and (not old-point) (not new-point))
+ ;; Should old-point and new-point both equal
+ ;; nil, compare the posn areas and nominal
+ ;; column position. If either are
+ ;; different, generate a drag event.
+ (let ((new-col-row (posn-col-row posn))
+ (new-area (posn-area posn))
+ (old-col-row (posn-col-row old-posn))
+ (old-area (posn-area old-posn)))
+ (if (and (equal new-col-row old-col-row)
+ (eq new-area old-area))
+ ;; ... generate a mouse-1 event...
+ (list 'mouse-1 posn)
+ ;; ... otherwise, generate a
+ ;; drag-mouse-1 event.
+ (list 'drag-mouse-1 old-posn posn)))
+ (if (and (eq new-window old-window)
+ (eq new-point old-point)
+ (windowp new-window)
+ (windowp old-window))
+ ;; ... generate a mouse-1 event...
+ (list 'mouse-1 posn)
+ ;; ... otherwise, generate a drag-mouse-1
+ ;; event.
+ (list 'drag-mouse-1 old-posn posn))))))
+ ((eq what 'mouse-1-menu)
+ ;; Generate a `down-mouse-1' event at the position the tap
+ ;; took place.
+ (throw 'input-event
+ (list 'down-mouse-1
+ (nth 4 touch-screen-current-tool))))
+ ((or (eq what 'drag)
+ ;; Merely initiating a drag is sufficient to select a
+ ;; word if word selection is enabled.
+ (eq what 'held))
+ ;; Display the on screen keyboard if the region is now
+ ;; active. Check this within the window where the tool
+ ;; was first place.
+ (setq window (nth 1 touch-screen-current-tool))
+ (when window
+ (with-selected-window window
+ (when (and (region-active-p)
+ (not buffer-read-only))
+ ;; Once the on-screen keyboard has been opened, add
+ ;; `touch-screen-window-selection-changed' as a
+ ;; window selection change function. This then
+ ;; prevents it from being hidden after exiting the
+ ;; minibuffer.
+ (progn
+ (add-hook 'window-selection-change-functions
+ #'touch-screen-window-selection-changed)
+ (frame-toggle-on-screen-keyboard (selected-frame)
+ nil))))))))))
+
+(defun touch-screen-handle-touch (event prefix &optional interactive)
+ "Handle a single touch EVENT, and perform associated actions.
+EVENT can either be a `touchscreen-begin', `touchscreen-update' or
+`touchscreen-end' event.
+PREFIX is either nil, or a symbol specifying a virtual function
+key to apply to EVENT.
+
+If INTERACTIVE, execute the command associated with any event
+generated instead of throwing `input-event'. Otherwise, throw
+`input-event' with a single input event if that event should take
+the place of EVENT within the key sequence being translated, or
+`nil' if all tools have been released.
+
+Set `touch-screen-events-received' to `t' to indicate that touch
+screen events have been received, and thus by extension require
+functions undertaking event management themselves to call
+`read-key' rather than `read-event'."
+ (interactive "e\ni\np")
+ (unless touch-screen-events-received
+ (setq touch-screen-events-received t))
+ (if interactive
+ ;; Called interactively (probably from wid-edit.el.)
+ ;; Add any event generated to `unread-command-events'.
+ (let ((event1
+ (let ((current-key-remap-sequence (vector event)))
+ (touch-screen-translate-touch nil))))
+ (when (vectorp event1)
+ (setq unread-command-events
+ (nconc unread-command-events
+ (nreverse (append event1 nil))))))
+ (cond
+ ((eq (car event) 'touchscreen-begin)
+ ;; A tool was just pressed against the screen. Figure out the
+ ;; window where it is and make it the tool being tracked on the
+ ;; window.
+ (let* ((touchpoint (caadr event))
+ (position (cdadr event))
+ (window (posn-window position))
+ (point (posn-point position))
+ binding tool-list)
+ ;; Cancel the touch screen timer, if it is still there by any
+ ;; chance.
+ (when touch-screen-current-timer
+ (cancel-timer touch-screen-current-timer)
+ (setq touch-screen-current-timer nil))
+ ;; If a tool already exists...
+ (if (and touch-screen-current-tool
+ ;; ..and the number of this tool is at variance with
+ ;; that of the current tool: if a `touchscreen-end'
+ ;; event is delivered that is somehow withheld from
+ ;; this function and the system does not assign
+ ;; monotonically increasing touch point identifiers,
+ ;; then the ancillary tool will be set to a tool
+ ;; bearing the same number as the current tool, and
+ ;; consequently the mechanism for detecting
+ ;; erroneously retained touch points upon the
+ ;; registration of `touchscreen-update' events will
+ ;; not be activated.
+ (not (eq touchpoint (car touch-screen-current-tool))))
+ ;; Then record this tool as the ``auxiliary tool''.
+ ;; Updates to the auxiliary tool are considered in unison
+ ;; with those to the current tool; the distance between
+ ;; both tools is measured and compared with that when the
+ ;; auxiliary tool was first pressed, then interpreted as a
+ ;; scale by which to adjust text within the current tool's
+ ;; window.
+ (when (eq (if (framep window) window (window-frame window))
+ ;; Verify that the new tool was placed on the
+ ;; same frame the current tool has, so as not to
+ ;; consider events distributed across distinct
+ ;; frames components of a single gesture.
+ (window-frame (nth 1 touch-screen-current-tool)))
+ ;; Set touch-screen-aux-tool as is proper. Mind that
+ ;; the last field is always relative to the current
+ ;; tool's window.
+ (let* ((window (nth 1 touch-screen-current-tool))
+ (relative-x-y (touch-screen-relative-xy position
+ window))
+ (initial-pos (nth 4 touch-screen-current-tool))
+ (initial-x-y (touch-screen-relative-xy initial-pos
+ window))
+ computed-distance computed-centrum)
+ ;; Calculate the distance and centrum from this point
+ ;; to the initial position of the current tool.
+ (setq computed-distance (touch-screen-distance relative-x-y
+ initial-x-y)
+ computed-centrum (touch-screen-centrum relative-x-y
+ initial-x-y))
+ ;; If computed-distance is zero, ignore this tap.
+ (unless (zerop computed-distance)
+ (setq touch-screen-aux-tool (vector touchpoint window
+ position relative-x-y
+ computed-distance
+ computed-centrum
+ 1.0 nil nil nil)))
+ ;; When an auxiliary tool is pressed, any gesture
+ ;; previously in progress must be terminated, so long
+ ;; as it represents a gesture recognized from the
+ ;; current tool's motion rather than ones detected by
+ ;; this function from circumstances surrounding its
+ ;; first press, such as the presence of a menu or
+ ;; down-mouse-1 button beneath its first press.
+ (unless (memq (nth 3 touch-screen-current-tool)
+ '(mouse-drag mouse-1-menu))
+ ;; Set the what field to the symbol `ancillary-tool'
+ ;; rather than nil, that mouse events may not be
+ ;; generated if no gesture is subsequently
+ ;; recognized; this, among others, prevents
+ ;; undesirable point movement (through the execution
+ ;; of `mouse-set-point') after both points are
+ ;; released without any gesture being detected.
+ (setcar (nthcdr 3 touch-screen-current-tool)
+ 'ancillary-tool))))
+ ;; Replace any previously ongoing gesture. If POSITION has no
+ ;; window or position, make it nil instead.
+ (setq tool-list (and (windowp window)
+ (list touchpoint window
+ (posn-x-y position)
+ nil position
+ nil nil nil nil
+ (posn-x-y position)))
+ touch-screen-current-tool tool-list)
+ ;; Select the window underneath the event as the checks below
+ ;; will look up keymaps and markers inside its buffer.
+ (save-selected-window
+ ;; Check if `touch-screen-extend-selection' is enabled,
+ ;; the tap lies on the point or the mark, and the region
+ ;; is active. If that's the case, set the fourth element
+ ;; of `touch-screen-current-tool' to `restart-drag', then
+ ;; generate a `touchscreen-restart-drag' event.
+ (when tool-list
+ ;; tool-list is always non-nil where the selected window
+ ;; matters.
+ (select-window window)
+ (when (and touch-screen-extend-selection
+ (or (eq point (point))
+ (eq point (mark)))
+ (region-active-p)
+ ;; Only restart drag-to-select if the tap
+ ;; falls on the same row as the selection.
+ ;; This prevents dragging from starting if
+ ;; the tap is below the last window line with
+ ;; text and `point' is at ZV, as the user
+ ;; most likely meant to scroll the window
+ ;; instead.
+ (when-let* ((posn-point (posn-at-point point))
+ (posn-row (cdr
+ (posn-col-row posn-point))))
+ (eq (cdr (posn-col-row position)) posn-row)))
+ ;; Indicate that a drag is about to restart.
+ (setcar (nthcdr 3 tool-list) 'restart-drag)
+ ;; Generate the `restart-drag' event.
+ (throw 'input-event (list 'touchscreen-restart-drag
+ position))))
+ ;; Determine if there is a command bound to `down-mouse-1'
+ ;; at the position of the tap and that command is not a
+ ;; command whose functionality is replaced by the
+ ;; long-press mechanism. If so, set the fourth element of
+ ;; `touch-screen-current-tool' to `mouse-drag' and
+ ;; generate an emulated `mouse-1' event.
+ ;;
+ ;; If the command in question is a keymap, set that
+ ;; element to `mouse-1-menu' instead of `mouse-drag', and
+ ;; don't generate a `down-mouse-1' event immediately.
+ ;; Instead, wait for the touch point to be released.
+ (if (and tool-list
+ (and (setq binding
+ (key-binding (if prefix
+ (vector prefix
+ 'down-mouse-1)
+ [down-mouse-1])
+ t nil position))
+ (not (and (symbolp binding)
+ (get binding 'ignored-mouse-command)))))
+ (if (or (keymapp binding)
+ (and (symbolp binding)
+ (get binding 'mouse-1-menu-command)))
+ ;; binding is a keymap, or a command that does
+ ;; almost the same thing. If a `mouse-1' event is
+ ;; generated after the keyboard command loop
+ ;; displays it as a menu, that event could cause
+ ;; unwanted commands to be run. Set what to
+ ;; `mouse-1-menu' instead and wait for the up
+ ;; event to display the menu.
+ (setcar (nthcdr 3 tool-list) 'mouse-1-menu)
+ (progn (setcar (nthcdr 3 tool-list) 'mouse-drag)
+ (throw 'input-event (list 'down-mouse-1 position))))
+ (and point
+ ;; Start the long-press timer.
+ (touch-screen-handle-timeout nil)))))))
+ ((eq (car event) 'touchscreen-update)
+ (unless touch-screen-current-tool
+ ;; If a stray touchscreen-update event arrives (most likely
+ ;; from the menu bar), stop translating this sequence.
+ (throw 'input-event nil))
+ ;; The positions of tools currently pressed against the screen
+ ;; have changed. If there is a tool being tracked as part of a
+ ;; gesture, look it up in the list of tools.
+ (if-let ((new-point (assq (car touch-screen-current-tool)
+ (cadr event))))
+ (if touch-screen-aux-tool
+ (touch-screen-handle-aux-point-update (cdr new-point)
+ (car new-point))
+ (touch-screen-handle-point-update new-point))
+ ;; If the current tool exists no longer, a touchscreen-end
+ ;; event is certain to have been disregarded. So that
+ ;; touchscreen gesture translation might continue as usual
+ ;; after this aberration to the normal flow of events, delete
+ ;; the current tool now.
+ (when touch-screen-current-timer
+ ;; Cancel the touch screen long-press timer, if it is still
+ ;; there by any chance.
+ (cancel-timer touch-screen-current-timer)
+ (setq touch-screen-current-timer nil))
+ ;; Don't call `touch-screen-handle-point-up' when terminating
+ ;; translation abnormally.
+ (setq touch-screen-current-tool nil
+ ;; Delete the ancillary tool while at it.
+ touch-screen-aux-tool nil)
+ (message "Current touch screen tool vanished!"))
+ ;; Check for updates to any ancillary point being monitored.
+ (when touch-screen-aux-tool
+ (let ((new-point (assq (aref touch-screen-aux-tool 0)
+ (cadr event))))
+ (when new-point
+ (touch-screen-handle-aux-point-update (cdr new-point)
+ (car new-point))))))
+ ((eq (car event) 'touchscreen-end)
+ ;; A tool has been removed from the screen. If it is the tool
+ ;; currently being tracked, clear `touch-screen-current-tool'.
+ (when (eq (caadr event) (car touch-screen-current-tool))
+ ;; Cancel the touch screen long-press timer, if it is still
+ ;; there by any chance.
+ (when touch-screen-current-timer
+ (cancel-timer touch-screen-current-timer)
+ (setq touch-screen-current-timer nil))
+ (let ((old-aux-tool touch-screen-aux-tool))
+ (unwind-protect
+ ;; Don't perform any actions associated with releasing the
+ ;; tool if the touch sequence was intercepted by another
+ ;; program.
+ (if (caddr event)
+ (setq touch-screen-current-tool nil)
+ (touch-screen-handle-point-up (cadr event) prefix))
+ ;; If an ancillary tool is present the function call above
+ ;; will merely transfer information from it into the current
+ ;; tool list, thereby rendering it the new current tool,
+ ;; until such time as it too is released.
+ (when (not (and old-aux-tool (not touch-screen-aux-tool)))
+ ;; Make sure the tool list is cleared even if
+ ;; `touch-screen-handle-point-up' throws.
+ (setq touch-screen-current-tool nil)))))
+ ;; If it is rather the ancillary tool, delete its vector. No
+ ;; further action is required, for the next update received will
+ ;; resume regular gesture recognition.
+ ;;
+ ;; The what field in touch-screen-current-tool is set to a
+ ;; signal value when the ancillary tool is pressed, so gesture
+ ;; recognition will commence with a clean slate, save for when
+ ;; the first touch landed atop a menu or some other area
+ ;; down-mouse-1 was bound.
+ ;;
+ ;; Gesture recognition will be inhibited in that case, so that
+ ;; mouse menu or mouse motion events are generated in its place
+ ;; as they would be were no ancillary tool ever pressed.
+ (when (and touch-screen-aux-tool
+ (eq (caadr event) (aref touch-screen-aux-tool 0)))
+ (setq touch-screen-aux-tool nil))
+ ;; Throw to the key translation function.
+ (throw 'input-event nil)))))
+
+;; Mark `mouse-drag-region' as ignored for the purposes of mouse click
+;; emulation.
+
+(put 'mouse-drag-region 'ignored-mouse-command t)
+
+(defun touch-screen-translate-touch (prompt)
+ "Translate touch screen events into a sequence of mouse events.
+PROMPT is the prompt string given to `read-key-sequence', or nil
+if this function is being called from the keyboard command loop.
+Value is a new key sequence.
+
+Read the touch screen event within `current-key-remap-sequence'
+and give it to `touch-screen-handle-touch'. Return any key
+sequence signaled.
+
+If `touch-screen-handle-touch' does not signal for an event to be
+returned after the last element of the key sequence is read,
+continue reading touch screen events until
+`touch-screen-handle-touch' signals. Return a sequence
+consisting of the first event encountered that is not a touch
+screen event.
+
+In addition to non-touchscreen events read, key sequences
+returned may contain any one of the following events:
+
+ (touchscreen-scroll WINDOW DX DY)
+
+where WINDOW specifies a window to scroll, and DX and DY are
+integers describing how many pixels to be scrolled horizontally
+and vertically,
+
+ (touchscreen-hold POSN)
+ (touchscreen-drag POSN)
+
+where POSN is the position of the long-press or touchpoint
+motion,
+
+ (touchscreen-restart-drag POSN)
+
+where POSN is the position of the tap,
+
+ (down-mouse-1 POSN)
+ (drag-mouse-1 POSN)
+
+where POSN is the position of the mouse button press or click,
+
+ (mouse-1 POSN)
+ (mouse-2 POSN)
+
+where POSN is the position of the mouse click, either `mouse-2'
+if POSN is on a link or a button, or `mouse-1' otherwise."
+ (unwind-protect
+ ;; Save the virtual function key if this is a mode line event.
+ (let* ((prefix-specified
+ ;; Virtual prefix keys can be nil for events that fall
+ ;; outside a frame or within its internal border.
+ (> (length current-key-remap-sequence) 1))
+ (prefix (and prefix-specified
+ (aref current-key-remap-sequence 0)))
+ (touch-screen-translate-prompt prompt)
+ (event (catch 'input-event
+ ;; First, process the one event already within
+ ;; `current-key-remap-sequence'.
+ (touch-screen-handle-touch
+ (aref current-key-remap-sequence
+ (if prefix-specified 1 0))
+ prefix)
+ ;; Next, continue reading input events.
+ (while t
+ (let ((event1 (read-event)))
+ ;; If event1 is a virtual function key, make
+ ;; it the new prefix.
+ (if (memq event1 '(mode-line tab-line nil
+ vertical-line
+ header-line tool-bar tab-bar
+ left-fringe right-fringe
+ left-margin right-margin
+ right-divider bottom-divider))
+ (setq prefix event1)
+ ;; If event1 is not a touch screen event,
+ ;; return it.
+ (if (not (memq (car-safe event1)
+ '(touchscreen-begin
+ touchscreen-end
+ touchscreen-update)))
+ (throw 'input-event event1)
+ ;; Process this event as well.
+ (touch-screen-handle-touch event1 prefix))))))))
+ ;; Return a key sequence consisting of event
+ ;; or an empty vector if it is nil, meaning that
+ ;; no key events have been translated.
+ (if event (or (and prefix (consp event)
+ ;; Only generate virtual function keys for
+ ;; mouse events.
+ (memq (car event)
+ '(down-mouse-1 mouse-1
+ mouse-2 mouse-movement))
+ ;; If this is a mode line event, then
+ ;; generate the appropriate function key.
+ (vector prefix event))
+ (vector event))
+ ""))
+ ;; Cancel the touch screen long-press timer, if it is still there
+ ;; by any chance. If the timer is to operate correctly, it must
+ ;; fire within the catch block above.
+ (when touch-screen-current-timer
+ (cancel-timer touch-screen-current-timer)
+ (setq touch-screen-current-timer nil))))
+
+(define-key function-key-map [touchscreen-begin]
+ #'touch-screen-translate-touch)
+(define-key function-key-map [touchscreen-update]
+ #'touch-screen-translate-touch)
+(define-key function-key-map [touchscreen-end]
+ #'touch-screen-translate-touch)
+
+(define-key function-key-map [mode-line touchscreen-begin]
+ #'touch-screen-translate-touch)
+(define-key function-key-map [mode-line touchscreen-end]
+ #'touch-screen-translate-touch)
+
+;; These are used to translate events sent from the internal border or
+;; from outside the frame.
+
+(define-key function-key-map [nil touchscreen-begin]
+ #'touch-screen-translate-touch)
+(define-key function-key-map [nil touchscreen-end]
+ #'touch-screen-translate-touch)
+
+(define-key function-key-map [header-line touchscreen-begin]
+ #'touch-screen-translate-touch)
+(define-key function-key-map [header-line touchscreen-end]
+ #'touch-screen-translate-touch)
+
+(define-key function-key-map [bottom-divider touchscreen-begin]
+ #'touch-screen-translate-touch)
+(define-key function-key-map [bottom-divider touchscreen-end]
+ #'touch-screen-translate-touch)
+
+(define-key function-key-map [right-divider touchscreen-begin]
+ #'touch-screen-translate-touch)
+(define-key function-key-map [right-divider touchscreen-end]
+ #'touch-screen-translate-touch)
+
+(define-key function-key-map [right-divider touchscreen-begin]
+ #'touch-screen-translate-touch)
+(define-key function-key-map [right-divider touchscreen-end]
+ #'touch-screen-translate-touch)
+
+(define-key function-key-map [left-fringe touchscreen-begin]
+ #'touch-screen-translate-touch)
+(define-key function-key-map [left-fringe touchscreen-end]
+ #'touch-screen-translate-touch)
+
+(define-key function-key-map [right-fringe touchscreen-begin]
+ #'touch-screen-translate-touch)
+(define-key function-key-map [right-fringe touchscreen-end]
+ #'touch-screen-translate-touch)
+
+(define-key function-key-map [left-margin touchscreen-begin]
+ #'touch-screen-translate-touch)
+(define-key function-key-map [left-margin touchscreen-end]
+ #'touch-screen-translate-touch)
+
+(define-key function-key-map [right-margin touchscreen-begin]
+ #'touch-screen-translate-touch)
+(define-key function-key-map [right-margin touchscreen-end]
+ #'touch-screen-translate-touch)
+
+(define-key function-key-map [tool-bar touchscreen-begin]
+ #'touch-screen-translate-touch)
+(define-key function-key-map [tool-bar touchscreen-end]
+ #'touch-screen-translate-touch)
+
+(define-key function-key-map [tab-bar touchscreen-begin]
+ #'touch-screen-translate-touch)
+(define-key function-key-map [tab-bar touchscreen-end]
+ #'touch-screen-translate-touch)
+
+(define-key function-key-map [tab-line touchscreen-begin]
+ #'touch-screen-translate-touch)
+(define-key function-key-map [tab-line touchscreen-end]
+ #'touch-screen-translate-touch)
+
+(define-key function-key-map [vertical-line touchscreen-begin]
+ #'touch-screen-translate-touch)
+(define-key function-key-map [vertical-line touchscreen-end]
+ #'touch-screen-translate-touch)
+
+(define-key function-key-map [nil touchscreen-begin]
+ #'touch-screen-translate-touch)
+(define-key function-key-map [nil touchscreen-end]
+ #'touch-screen-translate-touch)
+
+
+;; Exports. These functions are intended for use externally.
+
+;;;###autoload
+(defun touch-screen-track-tap (event &optional update data threshold)
+ "Track a single tap starting from EVENT.
+EVENT should be a `touchscreen-begin' event.
+
+Read touch screen events until a `touchscreen-end' event is
+received with the same ID as in EVENT. If UPDATE is non-nil and
+a `touchscreen-update' event is received in the mean time and
+contains a touch point with the same ID as in EVENT, call UPDATE
+with that event and DATA.
+
+If THRESHOLD is non-nil, enforce a threshold of movement that is
+either itself or 10 pixels when it is not a number. If the
+aforementioned touch point moves beyond that threshold on any
+axis, return nil immediately, and further resume mouse event
+translation for the touch point at hand.
+
+Return nil immediately if any other kind of event is received;
+otherwise, return t once the `touchscreen-end' event arrives."
+ (let ((disable-inhibit-text-conversion t)
+ (threshold (and threshold (or (and (numberp threshold)
+ threshold)
+ 10)))
+ (original-x-y (posn-x-y (cdadr event)))
+ (original-window (posn-window (cdadr event))))
+ (catch 'finish
+ (while t
+ (let ((new-event (read-event nil))
+ touch-point)
+ (cond
+ ((eq (car-safe new-event) 'touchscreen-update)
+ (when (setq touch-point (assq (caadr event) (cadr new-event)))
+ (when update
+ (funcall update new-event data))
+ (when threshold
+ (setq touch-point (cdr touch-point))
+ ;; Detect the touch point moving past the threshold.
+ (let* ((x-y (touch-screen-relative-xy touch-point
+ original-window))
+ (x (car x-y)) (y (cdr x-y)))
+ (when (or (> (abs (- x (car original-x-y))) threshold)
+ (> (abs (- y (cdr original-x-y))) threshold))
+ ;; Resume normal touch-screen to mouse event
+ ;; translation for this touch sequence by
+ ;; supplying both the event starting it and the
+ ;; motion event that overstepped the threshold to
+ ;; touch-screen-handle-touch.
+ (touch-screen-handle-touch event nil t)
+ (touch-screen-handle-touch new-event nil t)
+ (throw 'finish nil))))))
+ ((eq (car-safe new-event) 'touchscreen-end)
+ (throw 'finish
+ ;; Now determine whether or not the `touchscreen-end'
+ ;; event has the same ID as EVENT. If it doesn't,
+ ;; then this is another touch, so return nil.
+ (eq (caadr event) (caadr new-event))))
+ (t (throw 'finish nil))))))))
+
+;;;###autoload
+(defun touch-screen-track-drag (event update &optional data)
+ "Track a single drag starting from EVENT.
+EVENT should be a `touchscreen-begin' event.
+
+Read touch screen events until a `touchscreen-end' event is
+received with the same ID as in EVENT. For each
+`touchscreen-update' event received in the mean time containing a
+touch point with the same ID as in EVENT, call UPDATE with the
+touch point in event and DATA, once the touch point has moved
+significantly by at least 5 pixels from where it was in EVENT.
+
+Return nil immediately if any other kind of event is received;
+otherwise, return either t or `no-drag' once the
+`touchscreen-end' event arrives; return `no-drag' returned if the
+touch point in EVENT did not move significantly, and t otherwise."
+ (let ((return-value 'no-drag)
+ (start-xy (touch-screen-relative-xy (cdadr event)
+ 'frame))
+ (disable-inhibit-text-conversion t))
+ (catch 'finish
+ (while t
+ (let ((new-event (read-event nil)))
+ (cond
+ ((eq (car-safe new-event) 'touchscreen-update)
+ (when-let* ((tool (assq (caadr event) (nth 1 new-event)))
+ (xy (touch-screen-relative-xy (cdr tool) 'frame)))
+ (when (or (> (- (car xy) (car start-xy)) 5)
+ (< (- (car xy) (car start-xy)) -5)
+ (> (- (cdr xy) (cdr start-xy)) 5)
+ (< (- (cdr xy) (cdr start-xy)) -5))
+ (setq return-value t))
+ (when (and update tool (eq return-value t))
+ (funcall update new-event data))))
+ ((eq (car-safe new-event) 'touchscreen-end)
+ (throw 'finish
+ ;; Now determine whether or not the `touchscreen-end'
+ ;; event has the same ID as EVENT. If it doesn't,
+ ;; then this is another touch, so return nil.
+ (and (eq (caadr event) (caadr new-event))
+ return-value)))
+ (t (throw 'finish nil))))))))
+
+
+
+;;; Event handling exports. These functions are intended for use by
+;;; Lisp commands bound to touch screen gesture events.
+
+;;;###autoload
+(defun touch-screen-inhibit-drag ()
+ "Inhibit subsequent `touchscreen-drag' events from being sent.
+Prevent `touchscreen-drag' and translated mouse events from being
+sent until the touch sequence currently being translated ends.
+Must be called from a command bound to a `touchscreen-hold' or
+`touchscreen-drag' event."
+ (let* ((tool touch-screen-current-tool)
+ (current-what (nth 4 tool)))
+ ;; Signal an error if no hold or drag is in progress.
+ (when (and (not (eq current-what 'hold)
+ (eq current-what 'drag)))
+ (error "Calling `touch-screen-inhibit-drag' outside hold or drag"))
+ ;; Now set the fourth element of tool to `command-inhibit'.
+ (setcar (nthcdr 3 tool) 'command-inhibit)))
+
+
+
+(provide 'touch-screen)
+
+;;; touch-screen ends here
diff --git a/lisp/transient.el b/lisp/transient.el
index 04dc4756825..c3b9448e2c4 100644
--- a/lisp/transient.el
+++ b/lisp/transient.el
@@ -5,9 +5,7 @@
;; Author: Jonas Bernoulli <jonas@bernoul.li>
;; URL: https://github.com/magit/transient
;; Keywords: extensions
-
-;; Package-Version: 0.4.3
-;; Package-Requires: ((emacs "26.1"))
+;; Version: 0.6.0
;; SPDX-License-Identifier: GPL-3.0-or-later
@@ -28,27 +26,9 @@
;;; Commentary:
-;; Taking inspiration from prefix keys and prefix arguments, Transient
-;; implements a similar abstraction involving a prefix command, infix
-;; arguments and suffix commands. We could call this abstraction a
-;; "transient command", but because it always involves at least two
-;; commands (a prefix and a suffix) we prefer to call it just a
-;; "transient".
-
-;; When the user calls a transient prefix command, then a transient
-;; (temporary) keymap is activated, which binds the transient's infix
-;; and suffix commands, and functions that control the transient state
-;; are added to `pre-command-hook' and `post-command-hook'. The
-;; available suffix and infix commands and their state are shown in
-;; the echo area until the transient is exited by invoking a suffix
-;; command.
-
-;; Calling an infix command causes its value to be changed, possibly
-;; by reading a new value in the minibuffer.
-
-;; Calling a suffix command usually causes the transient to be exited
-;; but suffix commands can also be configured to not exit the
-;; transient state.
+;; Transient is the library used to implement the keyboard-driven menus
+;; in Magit. It is distributed as a separate package, so that it can be
+;; used to implement similar menus in other packages.
;;; Code:
@@ -56,7 +36,41 @@
(require 'eieio)
(require 'edmacro)
(require 'format-spec)
+
+(eval-and-compile
+ (when (and (featurep' seq)
+ (not (fboundp 'seq-keep)))
+ (unload-feature 'seq 'force)))
(require 'seq)
+(unless (fboundp 'seq-keep)
+ (display-warning 'transient (substitute-command-keys "\
+Transient requires `seq' >= 2.24,
+but due to bad defaults, Emacs' package manager, refuses to
+upgrade this and other built-in packages to higher releases
+from GNU Elpa, when a package specifies that this is needed.
+
+To fix this, you have to add this to your init file:
+
+ (setq package-install-upgrade-built-in t)
+
+Then evaluate that expression by placing the cursor after it
+and typing \\[eval-last-sexp].
+
+Once you have done that, you have to explicitly upgrade `seq':
+
+ \\[package-upgrade] seq \\`RET'
+
+Then you also must make sure the updated version is loaded,
+by evaluating this form:
+
+ (progn (unload-feature 'seq t) (require 'seq))
+
+Until you do this, you will get random errors about `seq-keep'
+being undefined while using Transient.
+
+If you don't use the `package' package manager but still get
+this warning, then your chosen package manager likely has a
+similar defect.") :emergency))
(eval-when-compile (require 'subr-x))
@@ -65,21 +79,34 @@
(declare-function Man-next-section "man" (n))
(declare-function Man-getpage-in-background "man" (topic))
-(defvar display-line-numbers) ; since Emacs 26.1
(defvar Man-notify-method)
(defvar pp-default-function) ; since Emacs 29.1
-(defmacro transient--with-emergency-exit (&rest body)
+(defmacro static-if (condition then-form &rest else-forms)
+ "A conditional compilation macro.
+Evaluate CONDITION at macro-expansion time. If it is non-nil,
+expand the macro to THEN-FORM. Otherwise expand it to ELSE-FORMS
+enclosed in a `progn' form. ELSE-FORMS may be empty."
+ (declare (indent 2)
+ (debug (sexp sexp &rest sexp)))
+ (if (eval condition lexical-binding)
+ then-form
+ (cons 'progn else-forms)))
+
+(defmacro transient--with-emergency-exit (id &rest body)
(declare (indent defun))
+ (unless (keywordp id)
+ (setq body (cons id body))
+ (setq id nil))
`(condition-case err
(let ((debugger #'transient--exit-and-debug))
,(macroexp-progn body))
((debug error)
- (transient--emergency-exit)
+ (transient--emergency-exit ,id)
(signal (car err) (cdr err)))))
(defun transient--exit-and-debug (&rest args)
- (transient--emergency-exit)
+ (transient--emergency-exit :debugger)
(apply #'debug args))
;;; Options
@@ -198,21 +225,30 @@ If nil, then the buffer has no mode-line. If the buffer is not
displayed right above the echo area, then this probably is not
a good value.
-If `line' (the default), then the buffer also has no mode-line,
-but a thin line is drawn instead, using the background color of
-the face `transient-separator'. Termcap frames cannot display
-thin lines and therefore fallback to treating `line' like nil.
+If `line' (the default) or a natural number, then the buffer
+has no mode-line, but a line is drawn is drawn in its place.
+If a number is used, that specifies the thickness of the line.
+On termcap frames we cannot draw lines, so there `line' and
+numbers are synonyms for nil.
+
+The color of the line is used to indicate if non-suffixes are
+allowed and whether they exit the transient. The foreground
+color of `transient-key-noop' (if non-suffix are disallowed),
+`transient-key-stay' (if allowed and transient stays active), or
+`transient-key-exit' (if allowed and they exit the transient) is
+used to draw the line.
Otherwise this can be any mode-line format.
See `mode-line-format' for details."
:package-version '(transient . "0.2.0")
:group 'transient
- :type '(choice (const :tag "hide mode-line" nil)
- (const :tag "substitute thin line" line)
- (const :tag "name of prefix command"
- ("%e" mode-line-front-space
- mode-line-buffer-identification))
- (sexp :tag "custom mode-line format")))
+ :type '(choice (const :tag "hide mode-line" nil)
+ (const :tag "substitute thin line" line)
+ (number :tag "substitute line with thickness")
+ (const :tag "name of prefix command"
+ ("%e" mode-line-front-space
+ mode-line-buffer-identification))
+ (sexp :tag "custom mode-line format")))
(defcustom transient-show-common-commands nil
"Whether to show common transient suffixes in the popup buffer.
@@ -236,7 +272,7 @@ of this variable use \"C-x t\" when a transient is active."
This only affects infix arguments that represent command-line
arguments. When this option is non-nil, then the key binding
for infix argument are highlighted when only a long argument
-\(e.g. \"--verbose\") is specified but no shor-thand (e.g \"-v\").
+\(e.g., \"--verbose\") is specified but no shorthand (e.g., \"-v\").
In the rare case that a short-hand is specified but does not
match the key binding, then it is highlighted differently.
@@ -285,19 +321,14 @@ using a layout optimized for Lisp.
:group 'transient
:type '(choice (const :tag "Transform no keys (nil)" nil) function))
-(defcustom transient-semantic-coloring nil
- "Whether to color prefixes and suffixes in Hydra-like fashion.
-This feature is experimental.
+(defcustom transient-semantic-coloring t
+ "Whether to use colors to indicate transient behavior.
If non-nil, then the key binding of each suffix is colorized to
-indicate whether it exits the transient state or not. The color
-of the prefix is indicated using the line that is drawn when the
-value of `transient-mode-line-format' is `line'.
-
-For more information about how Hydra uses colors see
-https://github.com/abo-abo/hydra#color and
-https://oremacs.com/2015/02/19/hydra-colors-reloaded."
- :package-version '(transient . "0.3.0")
+indicate whether it exits the transient state or not, and the
+line that is drawn below the transient popup buffer is used to
+indicate the behavior of non-suffix commands."
+ :package-version '(transient . "0.5.0")
:group 'transient
:type 'boolean)
@@ -356,8 +387,8 @@ text and might otherwise have to scroll in two dimensions."
:group 'transient
:type 'boolean)
+(defconst transient--max-level 7)
(defconst transient--default-child-level 1)
-
(defconst transient--default-prefix-level 4)
(defcustom transient-default-level transient--default-prefix-level
@@ -436,22 +467,18 @@ give you as many additional suffixes as you hoped.)"
"Face used for headings."
:group 'transient-faces)
-(defface transient-key '((t :inherit font-lock-builtin-face))
- "Face used for keys."
- :group 'transient-faces)
-
-(defface transient-argument '((t :inherit font-lock-warning-face))
+(defface transient-argument '((t :inherit font-lock-string-face :weight bold))
"Face used for enabled arguments."
:group 'transient-faces)
-(defface transient-value '((t :inherit font-lock-string-face))
- "Face used for values."
- :group 'transient-faces)
-
(defface transient-inactive-argument '((t :inherit shadow))
"Face used for inactive arguments."
:group 'transient-faces)
+(defface transient-value '((t :inherit font-lock-string-face :weight bold))
+ "Face used for values."
+ :group 'transient-faces)
+
(defface transient-inactive-value '((t :inherit shadow))
"Face used for inactive values."
:group 'transient-faces)
@@ -460,28 +487,14 @@ give you as many additional suffixes as you hoped.)"
"Face used for suffixes unreachable from the current prefix sequence."
:group 'transient-faces)
-(defface transient-active-infix '((t :inherit secondary-selection))
- "Face used for the infix for which the value is being read."
- :group 'transient-faces)
-
-(defface transient-unreachable-key '((t :inherit (transient-key shadow)))
- "Face used for keys unreachable from the current prefix sequence."
- :group 'transient-faces)
-
-(defface transient-nonstandard-key '((t :underline t))
- "Face optionally used to highlight keys conflicting with short-argument.
-Also see option `transient-highlight-mismatched-keys'."
- :group 'transient-faces)
-
-(defface transient-mismatched-key '((t :underline t))
- "Face optionally used to highlight keys without a short-argument.
-Also see option `transient-highlight-mismatched-keys'."
- :group 'transient-faces)
-
(defface transient-inapt-suffix '((t :inherit shadow :italic t))
"Face used for suffixes that are inapt at this time."
:group 'transient-faces)
+(defface transient-active-infix '((t :inherit highlight))
+ "Face used for the infix for which the value is being read."
+ :group 'transient-faces)
+
(defface transient-enabled-suffix
'((t :background "green" :foreground "black" :weight bold))
"Face used for enabled levels while editing suffix levels.
@@ -494,63 +507,83 @@ See info node `(transient)Enabling and Disabling Suffixes'."
See info node `(transient)Enabling and Disabling Suffixes'."
:group 'transient-faces)
-(defface transient-higher-level '((t :underline t))
+(defface transient-higher-level
+ `((t :box ( :line-width ,(if (>= emacs-major-version 28) (cons -1 -1) -1)
+ :color ,(let ((color (face-attribute 'shadow :foreground nil t)))
+ (or (and (not (eq color 'unspecified)) color)
+ "grey60")))))
"Face optionally used to highlight suffixes on higher levels.
Also see option `transient-highlight-higher-levels'."
:group 'transient-faces)
-(defface transient-separator
- `((((class color) (background light))
- ,@(and (>= emacs-major-version 27) '(:extend t))
- :background "grey80")
- (((class color) (background dark))
- ,@(and (>= emacs-major-version 27) '(:extend t))
- :background "grey30"))
- "Face used to draw line below transient popup window.
-This is only used if `transient-mode-line-format' is `line'.
-Only the background color is significant."
+(defface transient-delimiter '((t :inherit shadow))
+ "Face used for delimiters and separators.
+This includes the parentheses around values and the pipe
+character used to separate possible values from each other."
:group 'transient-faces)
-(defgroup transient-color-faces
- '((transient-semantic-coloring custom-variable))
- "Faces used by Transient for Hydra-like command coloring.
-These faces are only used if `transient-semantic-coloring'
-\(which see) is non-nil."
+(defface transient-key '((t :inherit font-lock-builtin-face))
+ "Face used for keys."
:group 'transient-faces)
-(defface transient-red
- '((t :inherit transient-key :foreground "red"))
- "Face used for red prefixes and suffixes."
- :group 'transient-color-faces)
+(defface transient-key-stay
+ `((((class color) (background light))
+ :inherit transient-key
+ :foreground "#22aa22")
+ (((class color) (background dark))
+ :inherit transient-key
+ :foreground "#ddffdd"))
+ "Face used for keys of suffixes that don't exit transient state."
+ :group 'transient-faces)
-(defface transient-blue
- '((t :inherit transient-key :foreground "blue"))
- "Face used for blue prefixes and suffixes."
- :group 'transient-color-faces)
+(defface transient-key-noop
+ `((((class color) (background light))
+ :inherit transient-key
+ :foreground "grey80")
+ (((class color) (background dark))
+ :inherit transient-key
+ :foreground "grey30"))
+ "Face used for keys of suffixes that currently cannot be invoked."
+ :group 'transient-faces)
-(defface transient-amaranth
- '((t :inherit transient-key :foreground "#E52B50"))
- "Face used for amaranth prefixes."
- :group 'transient-color-faces)
+(defface transient-key-return
+ `((((class color) (background light))
+ :inherit transient-key
+ :foreground "#aaaa11")
+ (((class color) (background dark))
+ :inherit transient-key
+ :foreground "#ffffcc"))
+ "Face used for keys of suffixes that return to the parent transient."
+ :group 'transient-faces)
-(defface transient-pink
- '((t :inherit transient-key :foreground "#FF6EB4"))
- "Face used for pink prefixes."
- :group 'transient-color-faces)
+(defface transient-key-exit
+ `((((class color) (background light))
+ :inherit transient-key
+ :foreground "#aa2222")
+ (((class color) (background dark))
+ :inherit transient-key
+ :foreground "#ffdddd"))
+ "Face used for keys of suffixes that exit transient state."
+ :group 'transient-faces)
-(defface transient-teal
- '((t :inherit transient-key :foreground "#367588"))
- "Face used for teal prefixes."
- :group 'transient-color-faces)
+(defface transient-unreachable-key
+ '((t :inherit (shadow transient-key) :weight normal))
+ "Face used for keys unreachable from the current prefix sequence."
+ :group 'transient-faces)
-(defface transient-purple
- '((t :inherit transient-key :foreground "#a020f0"))
- "Face used for purple prefixes.
+(defface transient-nonstandard-key
+ `((t :box ( :line-width ,(if (>= emacs-major-version 28) (cons -1 -1) -1)
+ :color "cyan")))
+ "Face optionally used to highlight keys conflicting with short-argument.
+Also see option `transient-highlight-mismatched-keys'."
+ :group 'transient-faces)
-This is an addition to the colors supported by Hydra. It is
-used by suffixes that quit the current prefix but return to
-the previous prefix."
- :group 'transient-color-faces)
+(defface transient-mismatched-key
+ `((t :box ( :line-width ,(if (>= emacs-major-version 28) (cons -1 -1) -1)
+ :color "magenta")))
+ "Face optionally used to highlight keys without a short-argument.
+Also see option `transient-highlight-mismatched-keys'."
+ :group 'transient-faces)
;;; Persistence
@@ -633,9 +666,12 @@ If `transient-save-history' is nil, then do nothing."
(man-page :initarg :man-page :initform nil)
(transient-suffix :initarg :transient-suffix :initform nil)
(transient-non-suffix :initarg :transient-non-suffix :initform nil)
+ (transient-switch-frame :initarg :transient-switch-frame)
+ (refresh-suffixes :initarg :refresh-suffixes :initform nil)
(incompatible :initarg :incompatible :initform nil)
(suffix-description :initarg :suffix-description)
(variable-pitch :initarg :variable-pitch :initform nil)
+ (column-widths :initarg :column-widths :initform nil)
(unwind-suffix :documentation "Internal use." :initform nil))
"Transient prefix command.
@@ -693,12 +729,15 @@ slot is non-nil."
:abstract t)
(defclass transient-suffix (transient-child)
- ((key :initarg :key)
+ ((definition :allocation :class :initform nil)
+ (key :initarg :key)
(command :initarg :command)
(transient :initarg :transient)
(format :initarg :format :initform " %k %d")
(description :initarg :description :initform nil)
+ (face :initarg :face :initform nil)
(show-help :initarg :show-help :initform nil)
+ (inapt-face :initarg :inapt-face :initform 'transient-inapt-suffix)
(inapt :initform nil)
(inapt-if
:initarg :inapt-if
@@ -734,6 +773,12 @@ slot is non-nil."
:documentation "Inapt if major-mode does not derive from value."))
"Superclass for suffix command.")
+(defclass transient-information (transient-suffix)
+ ((format :initform " %k %d")
+ (key :initform " "))
+ "Display-only information.
+A suffix object with no associated command.")
+
(defclass transient-infix (transient-suffix)
((transient :initform t)
(argument :initarg :argument)
@@ -788,8 +833,8 @@ They become the value of this argument.")
((suffixes :initarg :suffixes :initform nil)
(hide :initarg :hide :initform nil)
(description :initarg :description :initform nil)
- (setup-children :initarg :setup-children)
- (pad-keys :initarg :pad-keys))
+ (pad-keys :initarg :pad-keys :initform nil)
+ (setup-children :initarg :setup-children))
"Abstract superclass of all group classes."
:abstract t)
@@ -815,7 +860,6 @@ elements themselves.")
;;; Define
-;;;###autoload
(defmacro transient-define-prefix (name arglist &rest args)
"Define NAME as a transient prefix command.
@@ -907,7 +951,10 @@ ARGLIST. The infix arguments are usually accessed by using
(pcase-let ((`(,class ,slots ,_ ,docstr ,body)
(transient--expand-define-args args arglist)))
`(progn
- (defalias ',name (lambda ,arglist ,@body))
+ (defalias ',name
+ ,(if (and (not body) class (oref-default class definition))
+ `(oref-default ',class definition)
+ `(lambda ,arglist ,@body)))
(put ',name 'interactive-only t)
(put ',name 'function-documentation ,docstr)
(put ',name 'transient--suffix
@@ -932,11 +979,11 @@ explicitly.
The function definitions is always:
- (lambda ()
- (interactive)
- (let ((obj (transient-suffix-object)))
- (transient-infix-set obj (transient-infix-read obj)))
- (transient--show))
+ (lambda ()
+ (interactive)
+ (let ((obj (transient-suffix-object)))
+ (transient-infix-set obj (transient-infix-read obj)))
+ (transient--show))
`transient-infix-read' and `transient-infix-set' are generic
functions. Different infix commands behave differently because
@@ -958,7 +1005,7 @@ keyword.
`(progn
(defalias ',name #'transient--default-infix-command)
(put ',name 'interactive-only t)
- (put ',name 'command-modes (list 'not-a-mode))
+ (put ',name 'completion-predicate #'transient--suffix-only)
(put ',name 'function-documentation ,docstr)
(put ',name 'transient--suffix
(,(or class 'transient-switch) :command ',name ,@slots)))))
@@ -973,41 +1020,70 @@ example, sets a variable, use `transient-define-infix' instead.
\(fn NAME ARGLIST [DOCSTRING] [KEYWORD VALUE]...)")
(defun transient--default-infix-command ()
- "Most transient infix commands are but an alias for this command."
+ ;; Most infix commands are but an alias for this command.
+ "Cannot show any documentation for this transient infix command.
+
+When you request help for an infix command using `transient-help', that
+usually shows the respective man-page and tries to jump to the location
+where the respective argument is being described.
+
+If no man-page is specified for the containing transient menu, then the
+docstring is displayed instead, if any.
+
+If the infix command doesn't have a docstring, as is the case here, then
+this docstring is displayed instead, because technically infix commands
+are aliases for `transient--default-infix-command'.
+
+`describe-function' also shows the docstring of the infix command,
+falling back to that of the same aliased command."
(interactive)
(let ((obj (transient-suffix-object)))
(transient-infix-set obj (transient-infix-read obj)))
(transient--show))
(put 'transient--default-infix-command 'interactive-only t)
-(put 'transient--default-infix-command 'command-modes (list 'not-a-mode))
-
-(defun transient--expand-define-args (args &optional arglist)
- (unless (listp arglist)
- (error "Mandatory ARGLIST is missing"))
- (let (class keys suffixes docstr)
- (when (stringp (car args))
- (setq docstr (pop args)))
- (while (keywordp (car args))
- (let ((k (pop args))
- (v (pop args)))
- (if (eq k :class)
- (setq class v)
- (push k keys)
- (push v keys))))
- (while (let ((arg (car args)))
- (or (vectorp arg)
- (and arg (symbolp arg))))
- (push (pop args) suffixes))
- (list (if (eq (car-safe class) 'quote)
- (cadr class)
- class)
- (nreverse keys)
- (nreverse suffixes)
- docstr
- args)))
+(put 'transient--default-infix-command 'completion-predicate
+ #'transient--suffix-only)
+
+(defun transient--find-function-advised-original (fn func)
+ "Return nil instead of `transient--default-infix-command'.
+When using `find-function' to jump to the definition of a transient
+infix command/argument, then we want to actually jump to that, not to
+the definition of `transient--default-infix-command', which all infix
+commands are aliases for."
+ (let ((val (funcall fn func)))
+ (and val (not (eq val 'transient--default-infix-command)) val)))
+(advice-add 'find-function-advised-original :around
+ #'transient--find-function-advised-original)
+
+(eval-and-compile
+ (defun transient--expand-define-args (args &optional arglist)
+ (unless (listp arglist)
+ (error "Mandatory ARGLIST is missing"))
+ (let (class keys suffixes docstr)
+ (when (stringp (car args))
+ (setq docstr (pop args)))
+ (while (keywordp (car args))
+ (let ((k (pop args))
+ (v (pop args)))
+ (if (eq k :class)
+ (setq class v)
+ (push k keys)
+ (push v keys))))
+ (while (let ((arg (car args)))
+ (or (vectorp arg)
+ (and arg (symbolp arg))))
+ (push (pop args) suffixes))
+ (list (if (eq (car-safe class) 'quote)
+ (cadr class)
+ class)
+ (nreverse keys)
+ (nreverse suffixes)
+ docstr
+ args))))
(defun transient--parse-child (prefix spec)
- (cl-etypecase spec
+ (cl-typecase spec
+ (null (error "Invalid transient--parse-child spec: %s" spec))
(symbol (let ((value (symbol-value spec)))
(if (and (listp value)
(or (listp (car value))
@@ -1016,7 +1092,8 @@ example, sets a variable, use `transient-define-infix' instead.
(transient--parse-child prefix value))))
(vector (and-let* ((c (transient--parse-group prefix spec))) (list c)))
(list (and-let* ((c (transient--parse-suffix prefix spec))) (list c)))
- (string (list spec))))
+ (string (list spec))
+ (t (error "Invalid transient--parse-child spec: %s" spec))))
(defun transient--parse-group (prefix spec)
(setq spec (append spec nil))
@@ -1037,12 +1114,16 @@ example, sets a variable, use `transient-define-infix' instead.
(and (listp val) (not (eq (car val) 'lambda))))
(setq args (plist-put args key (macroexp-quote val))))
((setq args (plist-put args key val))))))
+ (unless (or spec class (not (plist-get args :setup-children)))
+ (message "WARNING: %s: When %s is used, %s must also be specified"
+ 'transient-define-prefix :setup-children :class))
(list 'vector
(or level transient--default-child-level)
- (or class
- (if (vectorp car)
- (quote 'transient-columns)
- (quote 'transient-column)))
+ (cond (class)
+ ((or (vectorp car)
+ (and car (symbolp car)))
+ (quote 'transient-columns))
+ ((quote 'transient-column)))
(and args (cons 'list args))
(cons 'list
(cl-mapcan (lambda (s) (transient--parse-child prefix s))
@@ -1069,8 +1150,9 @@ example, sets a variable, use `transient-define-infix' instead.
(commandp (cadr spec)))
(setq args (plist-put args :description (macroexp-quote pop)))))
(cond
+ ((eq car :info))
((keywordp car)
- (error "Need command, got `%s'" car))
+ (error "Need command or `:info', got `%s'" car))
((symbolp car)
(setq args (plist-put args :command (macroexp-quote pop))))
((and (commandp car)
@@ -1080,15 +1162,19 @@ example, sets a variable, use `transient-define-infix' instead.
(format "transient:%s:%s"
prefix
(let ((desc (plist-get args :description)))
- (if (and desc (or (stringp desc) (symbolp desc)))
+ (if (and (stringp desc)
+ (length< desc 16))
desc
(plist-get args :key)))))))
(setq args (plist-put
args :command
`(prog1 ',sym
(put ',sym 'interactive-only t)
- (put ',sym 'command-modes (list 'not-a-mode))
- (defalias ',sym ,(macroexp-quote cmd)))))))
+ (put ',sym 'completion-predicate #'transient--suffix-only)
+ (defalias ',sym
+ ,(if (eq (car-safe cmd) 'lambda)
+ cmd
+ (macroexp-quote cmd))))))))
((or (stringp car)
(and car (listp car)))
(let ((arg pop)
@@ -1107,7 +1193,7 @@ example, sets a variable, use `transient-define-infix' instead.
args :command
`(prog1 ',sym
(put ',sym 'interactive-only t)
- (put ',sym 'command-modes (list 'not-a-mode))
+ (put ',sym 'completion-predicate #'transient--suffix-only)
(defalias ',sym #'transient--default-infix-command))))
(cond ((and car (not (keywordp car)))
(setq class 'transient-option)
@@ -1123,6 +1209,9 @@ example, sets a variable, use `transient-define-infix' instead.
(val pop))
(cond ((eq key :class) (setq class val))
((eq key :level) (setq level val))
+ ((eq key :info)
+ (setq class 'transient-information)
+ (setq args (plist-put args :description val)))
((eq (car-safe val) '\,)
(setq args (plist-put args key (cadr val))))
((or (symbolp val)
@@ -1142,13 +1231,34 @@ example, sets a variable, use `transient-define-infix' instead.
(and (string-match "\\`\\(-[a-zA-Z]\\)\\(\\'\\|=\\)" arg)
(match-string 1 arg))))
+(defun transient-command-completion-not-suffix-only-p (symbol _buffer)
+ "Say whether SYMBOL should be offered as a completion.
+If the value of SYMBOL's `completion-predicate' property is
+`transient--suffix-only', then return nil, otherwise return t.
+This is the case when a command should only ever be used as a
+suffix of a transient prefix command (as opposed to bindings
+in regular keymaps or by using `execute-extended-command')."
+ (not (eq (get symbol 'completion-predicate) 'transient--suffix-only)))
+
+(defalias 'transient--suffix-only #'ignore
+ "Ignore ARGUMENTS, do nothing, and return nil.
+Also see `transient-command-completion-not-suffix-only-p'.
+Only use this alias as the value of the `completion-predicate'
+symbol property.")
+
+(when (and (boundp 'read-extended-command-predicate) ; since Emacs 28.1
+ (not read-extended-command-predicate))
+ (setq read-extended-command-predicate
+ #'transient-command-completion-not-suffix-only-p))
+
(defun transient-parse-suffix (prefix suffix)
"Parse SUFFIX, to be added to PREFIX.
PREFIX is a prefix command, a symbol.
SUFFIX is a suffix command or a group specification (of
the same forms as expected by `transient-define-prefix').
Intended for use in a group's `:setup-children' function."
- (eval (car (transient--parse-child prefix suffix))))
+ (cl-assert (and prefix (symbolp prefix)))
+ (eval (car (transient--parse-child prefix suffix)) t))
(defun transient-parse-suffixes (prefix suffixes)
"Parse SUFFIXES, to be added to PREFIX.
@@ -1156,6 +1266,7 @@ PREFIX is a prefix command, a symbol.
SUFFIXES is a list of suffix command or a group specification
(of the same forms as expected by `transient-define-prefix').
Intended for use in a group's `:setup-children' function."
+ (cl-assert (and prefix (symbolp prefix)))
(mapcar (apply-partially #'transient-parse-suffix prefix) suffixes))
;;; Edit
@@ -1167,7 +1278,7 @@ Intended for use in a group's `:setup-children' function."
(string suffix)))
(mem (transient--layout-member loc prefix))
(elt (car mem)))
- (setq suf (eval suf))
+ (setq suf (eval suf t))
(cond
((not mem)
(message "Cannot insert %S into %s; %s not found"
@@ -1191,11 +1302,11 @@ Intended for use in a group's `:setup-children' function."
(equal (transient--suffix-predicate suf)
(transient--suffix-predicate conflict)))))
(transient-remove-suffix prefix key))
- (cl-ecase action
- (insert (setcdr mem (cons elt (cdr mem)))
- (setcar mem suf))
- (append (setcdr mem (cons suf (cdr mem))))
- (replace (setcar mem suf)))))))
+ (pcase-exhaustive action
+ ('insert (setcdr mem (cons elt (cdr mem)))
+ (setcar mem suf))
+ ('append (setcdr mem (cons suf (cdr mem))))
+ ('replace (setcar mem suf)))))))
;;;###autoload
(defun transient-insert-suffix (prefix loc suffix &optional keep-other)
@@ -1306,7 +1417,7 @@ See info node `(transient)Modifying Existing Transients'."
(delq (car (transient--group-member loc layout))
(aref layout 3)))
nil)
- (t (transient--group-member loc layout))))
+ ((transient--group-member loc layout))))
(defun transient--group-member (loc group)
(cl-member-if (lambda (suffix)
@@ -1335,7 +1446,7 @@ See info node `(transient)Modifying Existing Transients'."
(plist-get plist :command)))))
(defun transient--command-key (cmd)
- (and-let* ((obj (get cmd 'transient--suffix)))
+ (and-let* ((obj (transient--suffix-prototype cmd)))
(cond ((slot-boundp obj 'key)
(oref obj key))
((slot-exists-p obj 'shortarg)
@@ -1376,11 +1487,15 @@ variable instead.")
(defconst transient--exit nil "Do exit the transient.")
(defvar transient--exitp nil "Whether to exit the transient.")
-(defvar transient--showp nil "Whether the transient is show in a popup buffer.")
+(defvar transient--showp nil "Whether to show the transient popup buffer.")
(defvar transient--helpp nil "Whether help-mode is active.")
(defvar transient--editp nil "Whether edit-mode is active.")
-(defvar transient--active-infix nil "The active infix awaiting user input.")
+(defvar transient--refreshp nil
+ "Whether to refresh the transient completely.")
+
+(defvar transient--all-levels-p nil
+ "Whether temporary display of suffixes on all levels is active.")
(defvar transient--timer nil)
@@ -1392,7 +1507,7 @@ variable instead.")
"Name of the transient buffer.")
(defvar transient--window nil
- "The window used to display the transient popup.")
+ "The window used to display the transient popup buffer.")
(defvar transient--original-window nil
"The window that was selected before the transient was invoked.
@@ -1402,7 +1517,25 @@ Usually it remains selected while the transient is active.")
"The buffer that was current before the transient was invoked.
Usually it remains current while the transient is active.")
-(defvar transient--debug nil "Whether put debug information into *Messages*.")
+(defvar transient--restore-winconf nil
+ "Window configuration to restore after exiting help.")
+
+(defvar transient--shadowed-buffer nil
+ "The buffer that is temporarily shadowed by the transient buffer.
+This is bound while the suffix predicate is being evaluated and while
+drawing in the transient buffer.")
+
+(defvar transient--pending-suffix nil
+ "The suffix that is currently being processed.
+This is bound while the suffix predicate is being evaluated,
+and while functions that return faces are being evaluated.")
+
+(defvar transient--pending-group nil
+ "The group that is currently being processed.
+This is bound while the suffixes are drawn in the transient buffer.")
+
+(defvar transient--debug nil
+ "Whether to put debug information into *Messages*.")
(defvar transient--history nil)
@@ -1414,6 +1547,31 @@ Usually it remains current while the transient is active.")
;;; Identities
+(defun transient-prefix-object ()
+ "Return the current prefix as an object.
+
+While a transient is being setup or refreshed (which involves
+preparing its suffixes) the variable `transient--prefix' can be
+used to access the prefix object. Thus this is what has to be
+used in suffix methods such as `transient-format-description',
+and in object-specific functions that are stored in suffix slots
+such as `description'.
+
+When a suffix command is invoked (i.e., in its `interactive' form
+and function body) then the variable `transient-current-prefix'
+has to be used instead.
+
+Two distinct variables are needed, because any prefix may itself
+be used as a suffix of another prefix, and such sub-prefixes have
+to be able to tell themselves apart from the prefix they were
+invoked from.
+
+Regular suffix commands, which are not prefixes, do not have to
+concern themselves with this distinction, so they can use this
+function instead. In the context of a plain suffix, it always
+returns the value of the appropriate variable."
+ (or transient--prefix transient-current-prefix))
+
(defun transient-suffix-object (&optional command)
"Return the object associated with the current suffix command.
@@ -1425,11 +1583,11 @@ This function is intended to be called by infix commands, which
are usually aliases of `transient--default-infix-command', which
is defined like this:
- (defun transient--default-infix-command ()
- (interactive)
- (let ((obj (transient-suffix-object)))
- (transient-infix-set obj (transient-infix-read obj)))
- (transient--show))
+ (defun transient--default-infix-command ()
+ (interactive)
+ (let ((obj (transient-suffix-object)))
+ (transient-infix-set obj (transient-infix-read obj)))
+ (transient--show))
\(User input is read outside of `interactive' to prevent the
command from being added to `command-history'. See #23.)
@@ -1453,33 +1611,40 @@ probably use this instead:
(get COMMAND \\='transient--suffix)"
(when command
(cl-check-type command command))
- (if (or transient--prefix
- transient-current-prefix)
- (let ((suffixes
- (cl-remove-if-not
- (lambda (obj)
- (eq (oref obj command)
- (or command
- (if (eq this-command 'transient-set-level)
- ;; This is how it can look up for which
- ;; command it is setting the level.
- this-original-command
- this-command))))
- (or transient--suffixes
- transient-current-suffixes))))
- (or (and (cdr suffixes)
- (cl-find-if
- (lambda (obj)
- (equal (listify-key-sequence (transient--kbd (oref obj key)))
- (listify-key-sequence (this-command-keys))))
- suffixes))
- (car suffixes)))
- (when-let* ((obj (get (or command this-command) 'transient--suffix))
- (obj (clone obj)))
- ;; Cannot use and-let* because of debbugs#31840.
- (transient-init-scope obj)
- (transient-init-value obj)
- obj)))
+ (cond
+ (transient--pending-suffix)
+ ((or transient--prefix
+ transient-current-prefix)
+ (let ((suffixes
+ (cl-remove-if-not
+ (lambda (obj)
+ (eq (oref obj command)
+ (or command
+ (if (eq this-command 'transient-set-level)
+ ;; This is how it can look up for which
+ ;; command it is setting the level.
+ this-original-command
+ this-command))))
+ (or transient--suffixes
+ transient-current-suffixes))))
+ (or (and (cdr suffixes)
+ (cl-find-if
+ (lambda (obj)
+ (equal (listify-key-sequence (transient--kbd (oref obj key)))
+ (listify-key-sequence (this-command-keys))))
+ suffixes))
+ (car suffixes))))
+ ((and-let* ((obj (transient--suffix-prototype (or command this-command)))
+ (obj (clone obj)))
+ (progn ; work around debbugs#31840
+ (transient-init-scope obj)
+ (transient-init-value obj)
+ obj)))))
+
+(defun transient--suffix-prototype (command)
+ (or (get command 'transient--suffix)
+ (seq-some (lambda (cmd) (get cmd 'transient--suffix))
+ (function-alias-p command))))
;;; Keymaps
@@ -1570,7 +1735,9 @@ to `transient-predicate-map'. Also see `transient-base-map'."
(if transient-show-common-commands
"Hide common commands"
"Show common permanently")))
- (list "C-x l" "Show/hide suffixes" #'transient-set-level))))))))
+ (list "C-x l" "Show/hide suffixes" #'transient-set-level)
+ (list "C-x a" #'transient-toggle-level-limit)))))
+ t)))
(defvar-keymap transient-popup-navigation-map
:doc "One of the keymaps used when popup navigation is enabled.
@@ -1588,6 +1755,16 @@ See `transient-enable-popup-navigation'."
"<mouse-1>" #'transient-push-button
"<mouse-2>" #'transient-push-button)
+(defvar-keymap transient-resume-mode-map
+ :doc "Keymap for `transient-resume-mode'.
+
+This keymap remaps every command that would usually just quit the
+documentation buffer to `transient-resume', which additionally
+resumes the suspended transient."
+ "<remap> <Man-quit>" #'transient-resume
+ "<remap> <Info-exit>" #'transient-resume
+ "<remap> <quit-window>" #'transient-resume)
+
(defvar-keymap transient-predicate-map
:doc "Base keymap used to map common commands to their transient behavior.
@@ -1623,7 +1800,9 @@ of the corresponding object."
"<transient-update>" #'transient--do-stay
"<transient-toggle-common>" #'transient--do-stay
"<transient-set>" #'transient--do-call
+ "<transient-set-and-exit>" #'transient--do-exit
"<transient-save>" #'transient--do-call
+ "<transient-save-and-exit>" #'transient--do-exit
"<transient-reset>" #'transient--do-call
"<describe-key-briefly>" #'transient--do-stay
"<describe-key>" #'transient--do-stay
@@ -1642,7 +1821,10 @@ of the corresponding object."
;; an unbound key, then Emacs calls the `undefined' command
;; but does not set `this-command', `this-original-command'
;; or `real-this-command' accordingly. Instead they are nil.
- "<nil>" #'transient--do-warn)
+ "<nil>" #'transient--do-warn
+ ;; Bound to the `mouse-movement' event, this command is similar
+ ;; to `ignore'.
+ "<ignore-preserving-kill-region>" #'transient--do-noop)
(defvar transient--transient-map nil)
(defvar transient--predicate-map nil)
@@ -1699,50 +1881,66 @@ of the corresponding object."
map))
(defun transient--make-predicate-map ()
- (let ((map (make-sparse-keymap)))
+ (let* ((default (transient--resolve-pre-command
+ (oref transient--prefix transient-suffix)))
+ (return (and transient--stack (eq default t)))
+ (map (make-sparse-keymap)))
(set-keymap-parent map transient-predicate-map)
- (when (memq (oref transient--prefix transient-non-suffix)
- '(nil transient--do-warn transient--do-noop))
- (keymap-set map "<handle-switch-frame>" #'transient--do-suspend))
+ (when (or (and (slot-boundp transient--prefix 'transient-switch-frame)
+ (transient--resolve-pre-command
+ (not (oref transient--prefix transient-switch-frame))))
+ (memq (transient--resolve-pre-command
+ (oref transient--prefix transient-non-suffix))
+ '(nil transient--do-warn transient--do-noop)))
+ (define-key map [handle-switch-frame] #'transient--do-suspend))
(dolist (obj transient--suffixes)
(let* ((cmd (oref obj command))
- (sub-prefix (and (symbolp cmd) (get cmd 'transient--prefix) t)))
+ (kind (cond ((get cmd 'transient--prefix) 'prefix)
+ ((cl-typep obj 'transient-infix) 'infix)
+ (t 'suffix))))
(cond
((oref obj inapt)
(define-key map (vector cmd) #'transient--do-warn-inapt))
((slot-boundp obj 'transient)
(define-key map (vector cmd)
- (let ((do (oref obj transient)))
- (pcase (list do sub-prefix)
- ('(t t) #'transient--do-recurse)
- ('(t nil) (if (cl-typep obj 'transient-infix)
- #'transient--do-stay
- #'transient--do-call))
- ('(nil t) #'transient--do-replace)
- ('(nil nil) #'transient--do-exit)
- (_ do)))))
+ (pcase (list kind
+ (transient--resolve-pre-command (oref obj transient))
+ return)
+ (`(prefix t ,_) #'transient--do-recurse)
+ (`(prefix nil ,_) #'transient--do-stack)
+ (`(infix t ,_) #'transient--do-stay)
+ (`(suffix t ,_) #'transient--do-call)
+ ('(suffix nil t) #'transient--do-return)
+ (`(,_ nil ,_) #'transient--do-exit)
+ (`(,_ ,do ,_) do))))
((not (lookup-key transient-predicate-map (vector cmd)))
(define-key map (vector cmd)
- (if sub-prefix
- #'transient--do-replace
- (or (oref transient--prefix transient-suffix)
- #'transient--do-exit)))))))
+ (pcase (list kind default return)
+ (`(prefix ,(or 'transient--do-stay 'transient--do-call) ,_)
+ #'transient--do-recurse)
+ (`(prefix t ,_) #'transient--do-recurse)
+ (`(prefix ,_ ,_) #'transient--do-stack)
+ (`(infix ,_ ,_) #'transient--do-stay)
+ (`(suffix t ,_) #'transient--do-call)
+ ('(suffix nil t) #'transient--do-return)
+ (`(suffix nil ,_) #'transient--do-exit)
+ (`(suffix ,do ,_) do)))))))
map))
(defun transient--make-redisplay-map ()
(setq transient--redisplay-key
- (cl-case this-command
- (transient-update
+ (pcase this-command
+ ('transient-update
(setq transient--showp t)
(setq unread-command-events
(listify-key-sequence (this-single-command-raw-keys))))
- (transient-quit-seq
+ ('transient-quit-seq
(setq unread-command-events
(butlast (listify-key-sequence
(this-single-command-raw-keys))
2))
(butlast transient--redisplay-key))
- (t nil)))
+ (_ nil)))
(let ((topmap (make-sparse-keymap))
(submap (make-sparse-keymap)))
(when transient--redisplay-key
@@ -1776,7 +1974,7 @@ the \"scope\" of the transient (see `transient-define-prefix').
This function is also called internally in which case LAYOUT and
EDIT may be non-nil."
(transient--debug 'setup)
- (transient--with-emergency-exit
+ (transient--with-emergency-exit :setup
(cond
((not name)
;; Switching between regular and edit mode.
@@ -1786,7 +1984,7 @@ EDIT may be non-nil."
(setq params (list :scope (oref transient--prefix scope))))
(transient--prefix
;; Invoked as a ":transient-non-suffix 'transient--do-{stay,call}"
- ;; of an outer prefix. Unlike the usual `transient--do-replace',
+ ;; of an outer prefix. Unlike the usual `transient--do-stack',
;; these predicates fail to clean up after the outer prefix.
(transient--pop-keymap 'transient--transient-map)
(transient--pop-keymap 'transient--redisplay-map))
@@ -1797,10 +1995,8 @@ EDIT may be non-nil."
;; Returning from help to edit.
(setq transient--editp t)))
(transient--init-objects name layout params)
+ (transient--init-keymaps)
(transient--history-init transient--prefix)
- (setq transient--predicate-map (transient--make-predicate-map))
- (setq transient--transient-map (transient--make-transient-map))
- (setq transient--redisplay-map (transient--make-redisplay-map))
(setq transient--original-window (selected-window))
(setq transient--original-buffer (current-buffer))
(setq transient--minibuffer-depth (minibuffer-depth))
@@ -1817,8 +2013,16 @@ value. Otherwise return CHILDREN as is."
(funcall (oref group setup-children) children)
children))
-(defun transient--init-objects (name layout params)
- (setq transient--prefix (transient--init-prefix name params))
+(defun transient--init-keymaps ()
+ (setq transient--predicate-map (transient--make-predicate-map))
+ (setq transient--transient-map (transient--make-transient-map))
+ (setq transient--redisplay-map (transient--make-redisplay-map)))
+
+(defun transient--init-objects (&optional name layout params)
+ (if name
+ (setq transient--prefix (transient--init-prefix name params))
+ (setq name (oref transient--prefix command)))
+ (setq transient--refreshp (oref transient--prefix refresh-suffixes))
(setq transient--layout (or layout (transient--init-suffixes name)))
(setq transient--suffixes (transient--flatten-suffixes transient--layout)))
@@ -1845,10 +2049,11 @@ value. Otherwise return CHILDREN as is."
(cl-labels ((s (def)
(cond
((stringp def) nil)
+ ((cl-typep def 'transient-information) nil)
((listp def) (cl-mapcan #'s def))
- ((transient-group--eieio-childp def)
+ ((cl-typep def 'transient-group)
(cl-mapcan #'s (oref def suffixes)))
- ((transient-suffix--eieio-childp def)
+ ((cl-typep def 'transient-suffix)
(list def)))))
(cl-mapcan #'s layout)))
@@ -1860,31 +2065,37 @@ value. Otherwise return CHILDREN as is."
(defun transient--init-group (levels spec)
(pcase-let ((`(,level ,class ,args ,children) (append spec nil)))
- (when-let* ((- (transient--use-level-p level))
- (obj (apply class :level level args))
- (- (transient--use-suffix-p obj))
- (suffixes (cl-mapcan (lambda (c) (transient--init-child levels c))
- (transient-setup-children obj children))))
- ;; Cannot use and-let* because of debbugs#31840.
- (oset obj suffixes suffixes)
- (list obj))))
+ (and-let* ((- (transient--use-level-p level))
+ (obj (apply class :level level args))
+ (- (transient--use-suffix-p obj))
+ (suffixes (cl-mapcan (lambda (c) (transient--init-child levels c))
+ (transient-setup-children obj children))))
+ (progn ; work around debbugs#31840
+ (oset obj suffixes suffixes)
+ (list obj)))))
(defun transient--init-suffix (levels spec)
(pcase-let* ((`(,level ,class ,args) spec)
(cmd (plist-get args :command))
- (level (or (alist-get cmd levels) level)))
+ (key (transient--kbd (plist-get args :key)))
+ (level (or (alist-get (cons cmd key) levels nil nil #'equal)
+ (alist-get cmd levels)
+ level)))
(let ((fn (and (symbolp cmd)
(symbol-function cmd))))
(when (autoloadp fn)
(transient--debug " autoload %s" cmd)
(autoload-do-load fn)))
(when (transient--use-level-p level)
- (unless (and cmd (symbolp cmd))
- (error "BUG: Non-symbolic suffix command: %s" cmd))
- (let ((obj (if-let ((proto (get cmd 'transient--suffix)))
- (apply #'clone proto :level level args)
- (apply class :command cmd :level level args))))
- (cond ((commandp cmd))
+ (let ((obj (if (child-of-class-p class 'transient-information)
+ (apply class :level level args)
+ (unless (and cmd (symbolp cmd))
+ (error "BUG: Non-symbolic suffix command: %s" cmd))
+ (if-let ((proto (and cmd (transient--suffix-prototype cmd))))
+ (apply #'clone proto :level level args)
+ (apply class :command cmd :level level args)))))
+ (cond ((not cmd))
+ ((commandp cmd))
((or (cl-typep obj 'transient-switch)
(cl-typep obj 'transient-option))
;; As a temporary special case, if the package was compiled
@@ -1893,7 +2104,8 @@ value. Otherwise return CHILDREN as is."
(defalias cmd #'transient--default-infix-command))
((transient--use-suffix-p obj)
(error "Suffix command %s is not defined or autoloaded" cmd)))
- (transient--init-suffix-key obj)
+ (unless (cl-typep obj 'transient-information)
+ (transient--init-suffix-key obj))
(when (transient--use-suffix-p obj)
(if (transient--inapt-suffix-p obj)
(oset obj inapt t)
@@ -1917,33 +2129,38 @@ value. Otherwise return CHILDREN as is."
(error "No key for %s" (oref obj command))))))
(defun transient--use-level-p (level &optional edit)
- (or (and transient--editp (not edit))
+ (or transient--all-levels-p
+ (and transient--editp (not edit))
(and (>= level 1)
(<= level (oref transient--prefix level)))))
(defun transient--use-suffix-p (obj)
- (transient--do-suffix-p
- (oref obj if)
- (oref obj if-not)
- (oref obj if-nil)
- (oref obj if-non-nil)
- (oref obj if-mode)
- (oref obj if-not-mode)
- (oref obj if-derived)
- (oref obj if-not-derived)
- t))
+ (let ((transient--shadowed-buffer (current-buffer))
+ (transient--pending-suffix obj))
+ (transient--do-suffix-p
+ (oref obj if)
+ (oref obj if-not)
+ (oref obj if-nil)
+ (oref obj if-non-nil)
+ (oref obj if-mode)
+ (oref obj if-not-mode)
+ (oref obj if-derived)
+ (oref obj if-not-derived)
+ t)))
(defun transient--inapt-suffix-p (obj)
- (transient--do-suffix-p
- (oref obj inapt-if)
- (oref obj inapt-if-not)
- (oref obj inapt-if-nil)
- (oref obj inapt-if-non-nil)
- (oref obj inapt-if-mode)
- (oref obj inapt-if-not-mode)
- (oref obj inapt-if-derived)
- (oref obj inapt-if-not-derived)
- nil))
+ (let ((transient--shadowed-buffer (current-buffer))
+ (transient--pending-suffix obj))
+ (transient--do-suffix-p
+ (oref obj inapt-if)
+ (oref obj inapt-if-not)
+ (oref obj inapt-if-nil)
+ (oref obj inapt-if-non-nil)
+ (oref obj inapt-if-mode)
+ (oref obj inapt-if-not-mode)
+ (oref obj inapt-if-derived)
+ (oref obj inapt-if-not-derived)
+ nil)))
(defun transient--do-suffix-p
(if if-not if-nil if-non-nil if-mode if-not-mode if-derived if-not-derived
@@ -1959,13 +2176,15 @@ value. Otherwise return CHILDREN as is."
(if-not-mode (not (if (atom if-not-mode)
(eq major-mode if-not-mode)
(memq major-mode if-not-mode))))
- (if-derived (if (atom if-derived)
+ (if-derived (if (or (atom if-derived)
+ (>= emacs-major-version 30))
(derived-mode-p if-derived)
(apply #'derived-mode-p if-derived)))
- (if-not-derived (not (if (atom if-not-derived)
+ (if-not-derived (not (if (or (atom if-not-derived)
+ (>= emacs-major-version 30))
(derived-mode-p if-not-derived)
(apply #'derived-mode-p if-not-derived))))
- (t default)))
+ (default)))
(defun transient--suffix-predicate (spec)
(let ((plist (nth 2 spec)))
@@ -1996,16 +2215,27 @@ value. Otherwise return CHILDREN as is."
;; that we just added.
(setq transient--exitp 'replace)))
+(defun transient--refresh-transient ()
+ (transient--debug 'refresh-transient)
+ (transient--pop-keymap 'transient--predicate-map)
+ (transient--pop-keymap 'transient--transient-map)
+ (transient--pop-keymap 'transient--redisplay-map)
+ (transient--init-objects)
+ (transient--init-keymaps)
+ (transient--push-keymap 'transient--transient-map)
+ (transient--push-keymap 'transient--redisplay-map)
+ (transient--redisplay))
+
(defun transient--pre-command ()
(transient--debug 'pre-command)
- (transient--with-emergency-exit
+ (transient--with-emergency-exit :pre-command
;; The use of `overriding-terminal-local-map' does not prevent the
;; lookup of command remappings in the overridden maps, which can
;; lead to a suffix being remapped to a non-suffix. We have to undo
;; the remapping in that case. However, remapping a non-suffix to
;; another should remain possible.
- (when (and (transient--get-predicate-for this-original-command 'suffix)
- (not (transient--get-predicate-for this-command 'suffix)))
+ (when (and (transient--get-pre-command this-original-command 'suffix)
+ (not (transient--get-pre-command this-command 'suffix)))
(setq this-command this-original-command))
(cond
((memq this-command '(transient-update transient-quit-seq))
@@ -2029,34 +2259,11 @@ value. Otherwise return CHILDREN as is."
(transient--wrap-command))
(t
(setq transient--exitp nil)
- (let ((exitp (eq (transient--do-pre-command) transient--exit)))
+ (let ((exitp (eq (transient--call-pre-command) transient--exit)))
(transient--wrap-command)
(when exitp
(transient--pre-exit)))))))
-(defun transient--do-pre-command ()
- (if-let ((fn (transient--get-predicate-for this-command)))
- (let ((action (funcall fn)))
- (when (eq action transient--exit)
- (setq transient--exitp (or transient--exitp t)))
- action)
- (if (let ((keys (this-command-keys-vector)))
- (eq (aref keys (1- (length keys))) ?\C-g))
- (setq this-command 'transient-noop)
- (unless (transient--edebug-command-p)
- (setq this-command 'transient-undefined)))
- transient--stay))
-
-(defun transient--get-predicate-for (cmd &optional suffix-only)
- (or (ignore-errors
- (lookup-key transient--predicate-map (vector cmd)))
- (and (not suffix-only)
- (let ((pred (oref transient--prefix transient-non-suffix)))
- (pcase pred
- ('t #'transient--do-stay)
- ('nil #'transient--do-warn)
- (_ pred))))))
-
(defun transient--pre-exit ()
(transient--debug 'pre-exit)
(transient--delete-window)
@@ -2083,13 +2290,14 @@ value. Otherwise return CHILDREN as is."
(when (window-live-p transient--window)
(let ((remain-in-minibuffer-window
(and (minibuffer-selected-window)
- (selected-window)))
- (buf (window-buffer transient--window)))
- ;; Only delete the window if it never showed another buffer.
- (unless (eq (car (window-parameter transient--window 'quit-restore)) 'other)
+ (selected-window))))
+ ;; Only delete the window if it has never shown another buffer.
+ (unless (eq (car (window-parameter transient--window 'quit-restore))
+ 'other)
(with-demoted-errors "Error while exiting transient: %S"
(delete-window transient--window)))
- (kill-buffer buf)
+ (when-let ((buffer (get-buffer transient--buffer-name)))
+ (kill-buffer buffer))
(when remain-in-minibuffer-window
(select-window remain-in-minibuffer-window)))))
@@ -2107,7 +2315,10 @@ value. Otherwise return CHILDREN as is."
((and transient--prefix transient--redisplay-key)
(setq transient--redisplay-key nil)
(when transient--showp
- (transient--show))))
+ (if-let ((win (minibuffer-selected-window)))
+ (with-selected-window win
+ (transient--show))
+ (transient--show)))))
(transient--pop-keymap 'transient--transient-map)
(transient--pop-keymap 'transient--redisplay-map)
(remove-hook 'pre-command-hook #'transient--pre-command)
@@ -2162,66 +2373,72 @@ value. Otherwise return CHILDREN as is."
(remove-hook 'minibuffer-exit-hook ,exit)))
,@body)))
-(defun transient--wrap-command ()
- (if (>= emacs-major-version 30)
- (transient--wrap-command-30)
- (transient--wrap-command-29)))
-
-(defun transient--wrap-command-30 ()
- (letrec
- ((prefix transient--prefix)
- (suffix this-command)
- (advice (lambda (fn &rest args)
- (interactive
- (lambda (spec)
- (let ((abort t))
- (unwind-protect
- (prog1 (advice-eval-interactive-spec spec)
- (setq abort nil))
- (when abort
- (when-let ((unwind (oref prefix unwind-suffix)))
- (transient--debug 'unwind-interactive)
- (funcall unwind suffix))
- (advice-remove suffix advice)
- (oset prefix unwind-suffix nil))))))
- (unwind-protect
- (apply fn args)
- (when-let ((unwind (oref prefix unwind-suffix)))
- (transient--debug 'unwind-command)
- (funcall unwind suffix))
- (advice-remove suffix advice)
- (oset prefix unwind-suffix nil)))))
- (advice-add suffix :around advice '((depth . -99)))))
-
-(defun transient--wrap-command-29 ()
- (let* ((prefix transient--prefix)
- (suffix this-command)
- (advice nil)
- (advice-interactive
- (lambda (spec)
- (let ((abort t))
+(static-if (>= emacs-major-version 30) ;transient--wrap-command
+ (defun transient--wrap-command ()
+ (cl-assert
+ (>= emacs-major-version 30) nil
+ "Emacs was downgraded, making it necessary to recompile Transient")
+ (letrec
+ ((prefix transient--prefix)
+ (suffix this-command)
+ (advice
+ (lambda (fn &rest args)
+ (interactive
+ (lambda (spec)
+ (let ((abort t))
+ (unwind-protect
+ (prog1 (let ((debugger #'transient--exit-and-debug))
+ (advice-eval-interactive-spec spec))
+ (setq abort nil))
+ (when abort
+ (when-let ((unwind (oref prefix unwind-suffix)))
+ (transient--debug 'unwind-interactive)
+ (funcall unwind suffix))
+ (advice-remove suffix advice)
+ (oset prefix unwind-suffix nil))))))
+ (unwind-protect
+ (let ((debugger #'transient--exit-and-debug))
+ (apply fn args))
+ (when-let ((unwind (oref prefix unwind-suffix)))
+ (transient--debug 'unwind-command)
+ (funcall unwind suffix))
+ (advice-remove suffix advice)
+ (oset prefix unwind-suffix nil)))))
+ (when (symbolp this-command)
+ (advice-add suffix :around advice '((depth . -99))))))
+
+ (defun transient--wrap-command ()
+ (let* ((prefix transient--prefix)
+ (suffix this-command)
+ (advice nil)
+ (advice-interactive
+ (lambda (spec)
+ (let ((abort t))
+ (unwind-protect
+ (prog1 (let ((debugger #'transient--exit-and-debug))
+ (advice-eval-interactive-spec spec))
+ (setq abort nil))
+ (when abort
+ (when-let ((unwind (oref prefix unwind-suffix)))
+ (transient--debug 'unwind-interactive)
+ (funcall unwind suffix))
+ (advice-remove suffix advice)
+ (oset prefix unwind-suffix nil))))))
+ (advice-body
+ (lambda (fn &rest args)
(unwind-protect
- (prog1 (advice-eval-interactive-spec spec)
- (setq abort nil))
- (when abort
- (when-let ((unwind (oref prefix unwind-suffix)))
- (transient--debug 'unwind-interactive)
- (funcall unwind suffix))
- (advice-remove suffix advice)
- (oset prefix unwind-suffix nil))))))
- (advice-body
- (lambda (fn &rest args)
- (unwind-protect
- (apply fn args)
- (when-let ((unwind (oref prefix unwind-suffix)))
- (transient--debug 'unwind-command)
- (funcall unwind suffix))
- (advice-remove suffix advice)
- (oset prefix unwind-suffix nil)))))
- (setq advice `(lambda (fn &rest args)
- (interactive ,advice-interactive)
- (apply ',advice-body fn args)))
- (advice-add suffix :around advice '((depth . -99)))))
+ (let ((debugger #'transient--exit-and-debug))
+ (apply fn args))
+ (when-let ((unwind (oref prefix unwind-suffix)))
+ (transient--debug 'unwind-command)
+ (funcall unwind suffix))
+ (advice-remove suffix advice)
+ (oset prefix unwind-suffix nil)))))
+ (setq advice `(lambda (fn &rest args)
+ (interactive ,advice-interactive)
+ (apply ',advice-body fn args)))
+ (when (symbolp this-command)
+ (advice-add suffix :around advice '((depth . -99)))))))
(defun transient--premature-post-command ()
(and (equal (this-command-keys-vector) [])
@@ -2240,9 +2457,23 @@ value. Otherwise return CHILDREN as is."
(defun transient--post-command ()
(unless (transient--premature-post-command)
(transient--debug 'post-command)
- (transient--with-emergency-exit
+ (transient--with-emergency-exit :post-command
(cond (transient--exitp (transient--post-exit))
- ((eq this-command (oref transient--prefix command)))
+ ;; If `this-command' is the current transient prefix, then we
+ ;; have already taken care of updating the transient buffer...
+ ((and (eq this-command (oref transient--prefix command))
+ ;; ... but if `prefix-arg' is non-nil, then the values
+ ;; of `this-command' and `real-this-command' are untrue
+ ;; because `prefix-command-preserve-state' changes them.
+ ;; We cannot use `current-prefix-arg' because it is set
+ ;; too late (in `command-execute'), and if it were set
+ ;; earlier, then we likely still would not be able to
+ ;; rely on it and `prefix-command-preserve-state-hook'
+ ;; would have to be used to record that a universal
+ ;; argument is in effect.
+ (not prefix-arg)))
+ (transient--refreshp
+ (transient--refresh-transient))
((let ((old transient--redisplay-map)
(new (transient--make-redisplay-map)))
(unless (equal old new)
@@ -2282,6 +2513,7 @@ value. Otherwise return CHILDREN as is."
(setq transient--exitp nil)
(setq transient--helpp nil)
(setq transient--editp nil)
+ (setq transient--all-levels-p nil)
(setq transient--minibuffer-depth 0)
(run-hooks 'transient-exit-hook)
(when resume
@@ -2292,6 +2524,7 @@ value. Otherwise return CHILDREN as is."
(push (list (oref transient--prefix command)
transient--layout
transient--editp
+ :transient-suffix (oref transient--prefix transient-suffix)
:scope (oref transient--prefix scope))
transient--stack))
@@ -2342,24 +2575,29 @@ value. Otherwise return CHILDREN as is."
(if (symbolp arg)
(message "-- %-22s (cmd: %s, event: %S, exit: %s%s)"
arg
- (or (and (symbolp this-command) this-command)
- (if (byte-code-function-p this-command)
- "#[...]"
- this-command))
+ (if (fboundp 'help-fns-function-name)
+ (help-fns-function-name this-command)
+ (if (byte-code-function-p this-command)
+ "#[...]"
+ this-command))
(key-description (this-command-keys-vector))
transient--exitp
- (cond ((stringp (car args))
+ (cond ((keywordp (car args))
+ (format ", from: %s"
+ (substring (symbol-name (car args)) 1)))
+ ((stringp (car args))
(concat ", " (apply #'format args)))
- (args
+ ((functionp (car args))
(concat ", " (apply (car args) (cdr args))))
- (t "")))
+ ("")))
(apply #'message arg args)))))
-(defun transient--emergency-exit ()
+(defun transient--emergency-exit (&optional id)
"Exit the current transient command after an error occurred.
-When no transient is active (i.e. when `transient--prefix' is
-nil) then do nothing."
- (transient--debug 'emergency-exit)
+When no transient is active (i.e., when `transient--prefix' is
+nil) then do nothing. Optional ID is a keyword identifying the
+exit."
+ (transient--debug 'emergency-exit id)
(when transient--prefix
(setq transient--stack nil)
(setq transient--exitp t)
@@ -2368,6 +2606,37 @@ nil) then do nothing."
;;; Pre-Commands
+(defun transient--call-pre-command ()
+ (if-let ((fn (transient--get-pre-command this-command)))
+ (let ((action (funcall fn)))
+ (when (eq action transient--exit)
+ (setq transient--exitp (or transient--exitp t)))
+ action)
+ (if (let ((keys (this-command-keys-vector)))
+ (eq (aref keys (1- (length keys))) ?\C-g))
+ (setq this-command 'transient-noop)
+ (unless (transient--edebug-command-p)
+ (setq this-command 'transient-undefined)))
+ transient--stay))
+
+(defun transient--get-pre-command (&optional cmd enforce-type)
+ (or (and (not (eq enforce-type 'non-suffix))
+ (symbolp cmd)
+ (lookup-key transient--predicate-map (vector cmd)))
+ (and (not (eq enforce-type 'suffix))
+ (transient--resolve-pre-command
+ (oref transient--prefix transient-non-suffix)
+ t))))
+
+(defun transient--resolve-pre-command (pre &optional resolve-boolean)
+ (cond ((booleanp pre)
+ (if resolve-boolean
+ (if pre #'transient--do-stay #'transient--do-warn)
+ pre))
+ ((string-match-p "--do-" (symbol-name pre)) pre)
+ ((let ((sym (intern (format "transient--do-%s" pre))))
+ (if (functionp sym) sym pre)))))
+
(defun transient--do-stay ()
"Call the command without exporting variables and stay transient."
transient--stay)
@@ -2408,7 +2677,8 @@ If there is no parent prefix, then behave like `transient--do-exit'."
(defun transient--do-leave ()
"Call the command without exporting variables and exit the transient."
- transient--stay)
+ (transient--stack-zap)
+ transient--exit)
(defun transient--do-push-button ()
"Call the command represented by the activated button.
@@ -2423,26 +2693,35 @@ Use that command's pre-command to determine transient behavior."
(posn-point (event-start last-command-event))
(point))
'command)))
- (transient--do-pre-command)))
+ (transient--call-pre-command)))
(defun transient--do-recurse ()
"Call the transient prefix command, preparing for return to active transient.
If there is no parent prefix, then just call the command."
- (transient--do-replace))
+ (transient--do-stack))
(defun transient--setup-recursion (prefix-obj)
(when transient--stack
(let ((command (oref prefix-obj command)))
(when-let ((suffix-obj (transient-suffix-object command)))
- (when (and (slot-boundp suffix-obj 'transient)
- (memq (oref suffix-obj transient)
- (list t #'transient--do-recurse)))
- (oset prefix-obj transient-suffix 'transient--do-return))))))
+ (when (memq (if (slot-boundp suffix-obj 'transient)
+ (oref suffix-obj transient)
+ (oref transient-current-prefix transient-suffix))
+ (list t #'transient--do-recurse))
+ (oset prefix-obj transient-suffix t))))))
+
+(defun transient--do-stack ()
+ "Call the transient prefix command, stacking the active transient.
+Push the active transient to the transient stack."
+ (transient--export)
+ (transient--stack-push)
+ (setq transient--exitp 'replace)
+ transient--exit)
(defun transient--do-replace ()
- "Call the transient prefix command, replacing the active transient."
+ "Call the transient prefix command, replacing the active transient.
+Do not push the active transient to the transient stack."
(transient--export)
- (transient--stack-push)
(setq transient--exitp 'replace)
transient--exit)
@@ -2461,7 +2740,9 @@ If there is no parent prefix, then just call the command."
(setq transient--editp nil)
(transient-setup)
transient--stay)
- (t transient--exit)))
+ (prefix-arg
+ transient--stay)
+ (transient--exit)))
(defun transient--do-quit-all ()
"Exit all transients without saving the transient stack."
@@ -2473,7 +2754,7 @@ If there is no parent prefix, then just call the command."
In that case behave like `transient--do-stay', otherwise similar
to `transient--do-warn'."
(unless transient-enable-popup-navigation
- (setq this-command 'transient-popup-navigation-help))
+ (setq this-command 'transient-inhibit-move))
transient--stay)
(defun transient--do-minus ()
@@ -2484,22 +2765,27 @@ prefix argument and pivot to `transient-update'."
(setq this-command 'transient-update))
transient--stay)
-(put 'transient--do-stay 'transient-color 'transient-red)
-(put 'transient--do-noop 'transient-color 'transient-red)
-(put 'transient--do-warn 'transient-color 'transient-red)
-(put 'transient--do-warn-inapt 'transient-color 'transient-red)
-(put 'transient--do-call 'transient-color 'transient-red)
-(put 'transient--do-return 'transient-color 'transient-purple)
-(put 'transient--do-exit 'transient-color 'transient-blue)
-(put 'transient--do-recurse 'transient-color 'transient-red)
-(put 'transient--do-replace 'transient-color 'transient-blue)
-(put 'transient--do-suspend 'transient-color 'transient-blue)
-(put 'transient--do-quit-one 'transient-color 'transient-blue)
-(put 'transient--do-quit-all 'transient-color 'transient-blue)
-(put 'transient--do-move 'transient-color 'transient-red)
-(put 'transient--do-minus 'transient-color 'transient-red)
+(put 'transient--do-stay 'transient-face 'transient-key-stay)
+(put 'transient--do-noop 'transient-face 'transient-key-noop)
+(put 'transient--do-warn 'transient-face 'transient-key-noop)
+(put 'transient--do-warn-inapt 'transient-face 'transient-key-noop)
+(put 'transient--do-call 'transient-face 'transient-key-stay)
+(put 'transient--do-return 'transient-face 'transient-key-return)
+(put 'transient--do-exit 'transient-face 'transient-key-exit)
+(put 'transient--do-leave 'transient-face 'transient-key-exit)
+
+(put 'transient--do-recurse 'transient-face 'transient-key-stay)
+(put 'transient--do-stack 'transient-face 'transient-key-stay)
+(put 'transient--do-replace 'transient-face 'transient-key-exit)
+(put 'transient--do-suspend 'transient-face 'transient-key-exit)
+
+(put 'transient--do-quit-one 'transient-face 'transient-key-return)
+(put 'transient--do-quit-all 'transient-face 'transient-key-exit)
+(put 'transient--do-move 'transient-face 'transient-key-stay)
+(put 'transient--do-minus 'transient-face 'transient-key-stay)
;;; Commands
+;;;; Noop
(defun transient-noop ()
"Do nothing at all."
@@ -2538,27 +2824,23 @@ prefix argument and pivot to `transient-update'."
(other-window 1)
(display-warning 'transient "Inconsistent transient state detected.
This should never happen.
-Please open an issue and post the shown command log.
-This is a heisenbug, so any additional details might help.
-Thanks!" :error)))
+Please open an issue and post the shown command log." :error)))
-(defun transient-toggle-common ()
- "Toggle whether common commands are always shown."
+(defun transient-inhibit-move ()
+ "Warn the user that popup navigation is disabled."
(interactive)
- (setq transient-show-common-commands (not transient-show-common-commands)))
+ (message "To enable use of `%s', please customize `%s'"
+ this-original-command
+ 'transient-enable-popup-navigation))
-(defun transient-suspend ()
- "Suspend the current transient.
-It can later be resumed using `transient-resume' while no other
-transient is active."
- (interactive))
+;;;; Core
(defun transient-quit-all ()
"Exit all transients without saving the transient stack."
(interactive))
(defun transient-quit-one ()
- "Exit the current transients, possibly returning to the previous."
+ "Exit the current transients, returning to outer transient, if any."
(interactive))
(defun transient-quit-seq ()
@@ -2568,17 +2850,48 @@ transient is active."
(defun transient-update ()
"Redraw the transient's state in the popup buffer."
(interactive)
- (when (equal this-original-command 'negative-argument)
- (setq prefix-arg current-prefix-arg)))
+ (setq prefix-arg current-prefix-arg))
(defun transient-show ()
"Show the transient's state in the popup buffer."
(interactive)
(setq transient--showp t))
-(defvar-local transient--restore-winconf nil)
+(defun transient-push-button ()
+ "Invoke the suffix command represented by this button."
+ (interactive))
+
+;;;; Suspend
-(defvar transient-resume-mode)
+(defun transient-suspend ()
+ "Suspend the current transient.
+It can later be resumed using `transient-resume', while no other
+transient is active."
+ (interactive))
+
+(define-minor-mode transient-resume-mode
+ "Auxiliary minor-mode used to resume a transient after viewing help.")
+
+(defun transient-resume ()
+ "Resume a previously suspended stack of transients."
+ (interactive)
+ (cond (transient--stack
+ (let ((winconf transient--restore-winconf))
+ (kill-local-variable 'transient--restore-winconf)
+ (when transient-resume-mode
+ (transient-resume-mode -1)
+ (quit-window))
+ (when winconf
+ (set-window-configuration winconf)))
+ (transient--stack-pop))
+ (transient-resume-mode
+ (kill-local-variable 'transient--restore-winconf)
+ (transient-resume-mode -1)
+ (quit-window))
+ (t
+ (message "No suspended transient command"))))
+
+;;;; Help
(defun transient-help (&optional interactive)
"Show help for the active transient or one of its suffixes.\n\n(fn)"
@@ -2595,12 +2908,15 @@ transient is active."
transient--prefix
(or (transient-suffix-object)
this-original-command)))
- (setq transient--restore-winconf winconf))
+ (setq-local transient--restore-winconf winconf))
(fit-window-to-buffer nil (frame-height) (window-height))
(transient-resume-mode)
- (message "Type \"q\" to resume transient command.")
+ (message (substitute-command-keys
+ "Type \\`q' to resume transient command."))
t))))
+;;;; Level
+
(defun transient-set-level (&optional command level)
"Set the level of the transient or one of its suffix commands."
(interactive
@@ -2612,10 +2928,9 @@ transient is active."
(list command
(let ((keys (this-single-command-raw-keys)))
(and (lookup-key transient--transient-map keys)
- (string-to-number
- (let ((transient--active-infix
- (transient-suffix-object command)))
- (transient--show)
+ (progn
+ (transient--show)
+ (string-to-number
(transient--read-number-N
(format "Set level for `%s': " command)
nil nil (not (eq command prefix)))))))))))
@@ -2626,32 +2941,64 @@ transient is active."
(level
(let* ((prefix (oref transient--prefix command))
(alist (alist-get prefix transient-levels))
- (sym command))
- (if (eq command prefix)
- (progn (oset transient--prefix level level)
- (setq sym t))
- (oset (transient-suffix-object command) level level))
- (setf (alist-get sym alist) level)
+ (akey command))
+ (cond ((eq command prefix)
+ (oset transient--prefix level level)
+ (setq akey t))
+ (t
+ (oset (transient-suffix-object command) level level)
+ (when (cdr (cl-remove-if-not (lambda (obj)
+ (eq (oref obj command) command))
+ transient--suffixes))
+ (setq akey (cons command (this-command-keys))))))
+ (setf (alist-get akey alist) level)
(setf (alist-get prefix transient-levels) alist))
(transient-save-levels)
(transient--show))
(t
(transient-undefined))))
+(transient-define-suffix transient-toggle-level-limit ()
+ "Toggle whether to temporarily displayed suffixes on all levels."
+ :description
+ (lambda ()
+ (cond
+ ((= transient-default-level transient--max-level)
+ "Always displaying all levels")
+ (transient--all-levels-p
+ (format "Hide suffix %s"
+ (propertize
+ (format "levels > %s" (oref (transient-prefix-object) level))
+ 'face 'transient-higher-level)))
+ ("Show all suffix levels")))
+ :inapt-if (lambda () (= transient-default-level transient--max-level))
+ :transient t
+ (interactive)
+ (setq transient--all-levels-p (not transient--all-levels-p))
+ (setq transient--refreshp t))
+
+;;;; Value
+
(defun transient-set ()
- "Save the value of the active transient for this Emacs session."
+ "Set active transient's value for this Emacs session."
(interactive)
- (transient-set-value (or transient--prefix transient-current-prefix)))
+ (transient-set-value (transient-prefix-object)))
+
+(defalias 'transient-set-and-exit #'transient-set
+ "Set active transient's value for this Emacs session and exit.")
(defun transient-save ()
- "Save the value of the active transient persistenly across Emacs sessions."
+ "Save active transient's value for this and future Emacs sessions."
(interactive)
- (transient-save-value (or transient--prefix transient-current-prefix)))
+ (transient-save-value (transient-prefix-object)))
+
+(defalias 'transient-save-and-exit #'transient-save
+ "Save active transient's value for this and future Emacs sessions and exit.")
(defun transient-reset ()
"Clear the set and saved values of the active transient."
(interactive)
- (transient-reset-value (or transient--prefix transient-current-prefix)))
+ (transient-reset-value (transient-prefix-object)))
(defun transient-history-next ()
"Switch to the next value used for the active transient."
@@ -2678,44 +3025,36 @@ transient is active."
(oset obj value (nth pos hst))
(mapc #'transient-init-value transient--suffixes))))
-(defun transient-scroll-up (&optional arg)
- "Scroll text of transient popup window upward ARG lines.
-If ARG is nil scroll near full screen. This is a wrapper
-around `scroll-up-command' (which see)."
- (interactive "^P")
- (with-selected-window transient--window
- (scroll-up-command arg)))
+;;;; Auxiliary
-(defun transient-scroll-down (&optional arg)
- "Scroll text of transient popup window down ARG lines.
-If ARG is nil scroll near full screen. This is a wrapper
-around `scroll-down-command' (which see)."
- (interactive "^P")
- (with-selected-window transient--window
- (scroll-down-command arg)))
-
-(defun transient-push-button ()
- "Invoke the suffix command represented by this button."
- (interactive))
+(defun transient-toggle-common ()
+ "Toggle whether common commands are permanently shown."
+ (interactive)
+ (setq transient-show-common-commands (not transient-show-common-commands)))
-(defun transient-resume ()
- "Resume a previously suspended stack of transients."
+(defun transient-toggle-debug ()
+ "Toggle debugging statements for transient commands."
(interactive)
- (cond (transient--stack
- (let ((winconf transient--restore-winconf))
- (kill-local-variable 'transient--restore-winconf)
- (when transient-resume-mode
- (transient-resume-mode -1)
- (quit-window))
- (when winconf
- (set-window-configuration winconf)))
- (transient--stack-pop))
- (transient-resume-mode
- (kill-local-variable 'transient--restore-winconf)
- (transient-resume-mode -1)
- (quit-window))
- (t
- (message "No suspended transient command"))))
+ (setq transient--debug (not transient--debug))
+ (message "Debugging transient %s"
+ (if transient--debug "enabled" "disabled")))
+
+(transient-define-suffix transient-echo-arguments (arguments)
+ "Show the transient's active ARGUMENTS in the echo area.
+Intended for use in prefixes used for demonstration purposes,
+such as when suggesting a new feature or reporting an issue."
+ :transient t
+ :description "Echo arguments"
+ :key "x"
+ (interactive (list (transient-args transient-current-command)))
+ (message "%s: %s"
+ (key-description (this-command-keys))
+ (mapconcat (lambda (arg)
+ (propertize (if (string-match-p " " arg)
+ (format "%S" arg)
+ arg)
+ 'face 'transient-argument))
+ arguments " ")))
;;; Value
;;;; Init
@@ -2821,29 +3160,19 @@ user using the reader specified by the `reader' slot (using the
`transient-infix' method described below).
For some infix classes the value is changed without reading
-anything in the minibuffer, i.e. the mere act of invoking the
+anything in the minibuffer, i.e., the mere act of invoking the
infix command determines what the new value should be, based
on the previous value.")
(cl-defmethod transient-infix-read :around ((obj transient-infix))
- "Highlight the infix in the popup buffer.
-
-This also wraps the call to `cl-call-next-method' with two
-macros.
-
-`transient--with-suspended-override' is necessary to allow
-reading user input using the minibuffer.
-
-`transient--with-emergency-exit' arranges for the transient to
-be exited in case of an error because otherwise Emacs would get
-stuck in an inconsistent state, which might make it necessary to
-kill it from the outside.
-
-If you replace this method, then you must make sure to always use
-the latter macro and most likely also the former."
- (let ((transient--active-infix obj))
- (transient--show))
- (transient--with-emergency-exit
+ "Refresh the transient buffer and call the next method.
+
+Also wrap `cl-call-next-method' with two macros:
+- `transient--with-suspended-override' allows use of minibuffer.
+- `transient--with-emergency-exit' arranges for the transient to
+ be exited in case of an error."
+ (transient--show)
+ (transient--with-emergency-exit :infix-read
(transient--with-suspended-override
(cl-call-next-method obj))))
@@ -2860,7 +3189,7 @@ the lack of history, for example.
Only for very simple classes that toggle or cycle through a very
limited number of possible values should you replace this with a
-simple method that does not handle history. (E.g. for a command
+simple method that does not handle history. (E.g., for a command
line switch the only possible values are \"use it\" and \"don't use
it\", in which case it is pointless to preserve history.)"
(with-slots (value multi-value always-read allow-empty choices) obj
@@ -2871,6 +3200,7 @@ it\", in which case it is pointless to preserve history.)"
(oset obj value nil)
(let* ((enable-recursive-minibuffers t)
(reader (oref obj reader))
+ (choices (if (functionp choices) (funcall choices) choices))
(prompt (transient-prompt obj))
(value (if multi-value (mapconcat #'identity value ",") value))
(history-key (or (oref obj history-key)
@@ -2893,7 +3223,7 @@ it\", in which case it is pointless to preserve history.)"
initial-input history))
(choices
(completing-read prompt choices nil t initial-input history))
- (t (read-string prompt initial-input history)))))
+ ((read-string prompt initial-input history)))))
(cond ((and (equal value "") (not allow-empty))
(setq value nil))
((and (equal value "\"\"") allow-empty)
@@ -2924,8 +3254,10 @@ The last value is \"don't use any of these switches\"."
"Elsewhere use the reader of the infix command COMMAND.
Use this if you want to share an infix's history with a regular
stand-alone command."
- (cl-letf (((symbol-function #'transient--show) #'ignore))
- (transient-infix-read (get command 'transient--suffix))))
+ (if-let ((obj (transient--suffix-prototype command)))
+ (cl-letf (((symbol-function #'transient--show) #'ignore))
+ (transient-infix-read obj))
+ (error "Not a suffix command: `%s'" command)))
;;;; Readers
@@ -3016,8 +3348,6 @@ prompt."
;;;; Set
-(defvar transient--unset-incompatible t)
-
(cl-defgeneric transient-infix-set (obj value)
"Set the value of infix object OBJ to value.")
@@ -3025,29 +3355,32 @@ prompt."
"Set the value of infix object OBJ to value."
(oset obj value value))
-(cl-defmethod transient-infix-set :around ((obj transient-argument) value)
+(cl-defmethod transient-infix-set :after ((obj transient-argument) value)
"Unset incompatible infix arguments."
- (let ((arg (if (slot-boundp obj 'argument)
- (oref obj argument)
- (oref obj argument-regexp))))
- (if-let ((sic (and value arg transient--unset-incompatible))
- (spec (oref transient--prefix incompatible))
- (incomp (cl-mapcan (lambda (rule)
- (and (member arg rule)
- (remove arg rule)))
- spec)))
- (progn
- (cl-call-next-method obj value)
- (dolist (arg incomp)
- (when-let ((obj (cl-find-if
- (lambda (obj)
- (and (slot-exists-p obj 'argument)
- (slot-boundp obj 'argument)
- (equal (oref obj argument) arg)))
- transient--suffixes)))
- (let ((transient--unset-incompatible nil))
- (transient-infix-set obj nil)))))
- (cl-call-next-method obj value))))
+ (when-let* ((--- value)
+ (val (transient-infix-value obj))
+ (arg (if (slot-boundp obj 'argument)
+ (oref obj argument)
+ (oref obj argument-format)))
+ (spec (oref transient--prefix incompatible))
+ (filter (lambda (x rule)
+ (and (member x rule)
+ (remove x rule))))
+ (incomp (nconc
+ (cl-mapcan (apply-partially filter arg) spec)
+ (and (not (equal val arg))
+ (cl-mapcan (apply-partially filter val) spec)))))
+ (dolist (obj transient--suffixes)
+ (when-let* ((--- (cl-typep obj 'transient-argument))
+ (val (transient-infix-value obj))
+ (arg (if (slot-boundp obj 'argument)
+ (oref obj argument)
+ (oref obj argument-format)))
+ (--- (if (equal val arg)
+ (member arg incomp)
+ (or (member val incomp)
+ (member arg incomp)))))
+ (transient-infix-set obj nil)))))
(cl-defgeneric transient-set-value (obj)
"Set the value of the transient prefix OBJ.")
@@ -3101,7 +3434,7 @@ the set, saved or default value for PREFIX."
(transient--init-suffixes prefix)))))
(defun transient-get-value ()
- (transient--with-emergency-exit
+ (transient--with-emergency-exit :get-value
(cl-mapcan (lambda (obj)
(and (or (not (slot-exists-p obj 'unsavable))
(not (oref obj unsavable)))
@@ -3110,11 +3443,11 @@ the set, saved or default value for PREFIX."
(defun transient--get-wrapped-value (obj)
(and-let* ((value (transient-infix-value obj)))
- (cl-ecase (and (slot-exists-p obj 'multi-value)
- (oref obj multi-value))
- ((nil) (list value))
- ((t rest) (list value))
- (repeat value))))
+ (pcase-exhaustive (and (slot-exists-p obj 'multi-value)
+ (oref obj multi-value))
+ ('nil (list value))
+ ((or 't 'rest) (list value))
+ ('repeat value))))
(cl-defgeneric transient-infix-value (obj)
"Return the value of the suffix object OBJ.
@@ -3149,17 +3482,17 @@ does nothing." nil)
"Return ARGUMENT and VALUE as a unit or nil if the latter is nil."
(and-let* ((value (oref obj value)))
(let ((arg (oref obj argument)))
- (cl-ecase (oref obj multi-value)
- ((nil) (concat arg value))
- ((t rest) (cons arg value))
- (repeat (mapcar (lambda (v) (concat arg v)) value))))))
+ (pcase-exhaustive (oref obj multi-value)
+ ('nil (concat arg value))
+ ((or 't 'rest) (cons arg value))
+ ('repeat (mapcar (lambda (v) (concat arg v)) value))))))
(cl-defmethod transient-infix-value ((_ transient-variable))
"Return nil, which means \"no value\".
Setting the value of a variable is done by, well, setting the
-value of the variable. I.e. this is a side-effect and does not
-contribute to the value of the transient."
+value of the variable. I.e., this is a side-effect and does
+not contribute to the value of the transient."
nil)
;;;; Utilities
@@ -3241,12 +3574,13 @@ have a history of their own.")
(list (propertize (oref suffix key) 'face 'transient-key)))))
transient--suffixes)
#'string<)
- (propertize "|" 'face 'transient-unreachable-key))))))
+ (propertize "|" 'face 'transient-delimiter))))))
(defun transient--show ()
(transient--timer-cancel)
(setq transient--showp t)
- (let ((buf (get-buffer-create transient--buffer-name))
+ (let ((transient--shadowed-buffer (current-buffer))
+ (buf (get-buffer-create transient--buffer-name))
(focus nil))
(with-current-buffer buf
(when transient-enable-popup-navigation
@@ -3259,9 +3593,11 @@ have a history of their own.")
(when (bound-and-true-p tab-line-format)
(setq tab-line-format nil))
(setq header-line-format nil)
- (setq mode-line-format (if (eq transient-mode-line-format 'line)
- nil
- transient-mode-line-format))
+ (setq mode-line-format
+ (if (or (natnump transient-mode-line-format)
+ (eq transient-mode-line-format 'line))
+ nil
+ transient-mode-line-format))
(setq mode-line-buffer-identification
(symbol-name (oref transient--prefix command)))
(if transient-enable-popup-navigation
@@ -3272,16 +3608,8 @@ have a history of their own.")
(transient--insert-groups)
(when (or transient--helpp transient--editp)
(transient--insert-help))
- (when (and (eq transient-mode-line-format 'line)
- window-system)
- (let ((face
- (if-let ((f (and (transient--semantic-coloring-p)
- (transient--prefix-color transient--prefix))))
- `(,@(and (>= emacs-major-version 27) '(:extend t))
- :background ,(face-foreground f))
- 'transient-separator)))
- (insert (propertize "__" 'face face 'display '(space :height (1))))
- (insert (propertize "\n" 'face face 'line-height t))))
+ (when-let ((line (transient--separator-line)))
+ (insert line))
(when transient-force-fixed-pitch
(transient--force-fixed-pitch)))
(unless (window-live-p transient--window)
@@ -3303,11 +3631,31 @@ have a history of their own.")
(fit-window-to-buffer window nil (window-height window))
(fit-window-to-buffer window nil 1))))
+(defun transient--separator-line ()
+ (and-let* ((height (cond ((not window-system) nil)
+ ((natnump transient-mode-line-format)
+ transient-mode-line-format)
+ ((eq transient-mode-line-format 'line) 1)))
+ (face `(,@(and (>= emacs-major-version 27) '(:extend t))
+ :background
+ ,(or (face-foreground (transient--key-face nil 'non-suffix)
+ nil t)
+ "#gray60"))))
+ (concat (propertize "__" 'face face 'display `(space :height (,height)))
+ (propertize "\n" 'face face 'line-height t))))
+
+(defmacro transient-with-shadowed-buffer (&rest body)
+ "While in the transient buffer, temporarly make the shadowed buffer current."
+ (declare (indent 0) (debug t))
+ `(with-current-buffer (or transient--shadowed-buffer (current-buffer))
+ ,@body))
+
(defun transient--insert-groups ()
(let ((groups (cl-mapcan (lambda (group)
(let ((hide (oref group hide)))
(and (not (and (functionp hide)
- (funcall hide)))
+ (transient-with-shadowed-buffer
+ (funcall hide))))
(list group))))
transient--layout))
group)
@@ -3323,23 +3671,25 @@ have a history of their own.")
(cl-defmethod transient--insert-group :around ((group transient-group))
"Insert GROUP's description, if any."
- (when-let ((desc (transient-format-description group)))
+ (when-let ((desc (transient-with-shadowed-buffer
+ (transient-format-description group))))
(insert desc ?\n))
(let ((transient--max-group-level
- (max (oref group level) transient--max-group-level)))
+ (max (oref group level) transient--max-group-level))
+ (transient--pending-group group))
(cl-call-next-method group)))
(cl-defmethod transient--insert-group ((group transient-row))
(transient--maybe-pad-keys group)
(dolist (suffix (oref group suffixes))
- (insert (transient-format suffix))
+ (insert (transient-with-shadowed-buffer (transient-format suffix)))
(insert " "))
(insert ?\n))
(cl-defmethod transient--insert-group ((group transient-column))
(transient--maybe-pad-keys group)
(dolist (suffix (oref group suffixes))
- (let ((str (transient-format suffix)))
+ (let ((str (transient-with-shadowed-buffer (transient-format suffix))))
(insert str)
(unless (string-match-p ".\n\\'" str)
(insert ?\n)))))
@@ -3349,19 +3699,26 @@ have a history of their own.")
(mapcar
(lambda (column)
(transient--maybe-pad-keys column group)
- (let ((rows (mapcar #'transient-format (oref column suffixes))))
- (when-let ((desc (transient-format-description column)))
- (push desc rows))
- (flatten-tree rows)))
+ (transient-with-shadowed-buffer
+ (let* ((transient--pending-group column)
+ (rows (mapcar #'transient-format (oref column suffixes))))
+ (when-let ((desc (transient-format-description column)))
+ (push desc rows))
+ (flatten-tree rows))))
(oref group suffixes)))
(vp (or (oref transient--prefix variable-pitch)
transient-align-variable-pitch))
(rs (apply #'max (mapcar #'length columns)))
(cs (length columns))
- (cw (mapcar (lambda (col)
- (apply #'max
- (mapcar (if vp #'transient--pixel-width #'length)
- col)))
+ (cw (mapcar (let ((widths (oref transient--prefix column-widths)))
+ (lambda (col)
+ (apply
+ #'max
+ (if-let ((min (pop widths)))
+ (if vp (* min (transient--pixel-width " ")) min)
+ 0)
+ (mapcar (if vp #'transient--pixel-width #'length)
+ col))))
columns))
(cc (transient--seq-reductions-from
(apply-partially #'+ (* 3 (if vp (transient--pixel-width " ") 1)))
@@ -3392,15 +3749,6 @@ have a history of their own.")
(when (= c (1- cs))
(insert ?\n))))))))
-(defun transient--pixel-width (string)
- (save-window-excursion
- (with-temp-buffer
- (insert string)
- (set-window-dedicated-p nil nil)
- (set-window-buffer nil (current-buffer))
- (car (window-text-pixel-size
- nil (line-beginning-position) (point))))))
-
(cl-defmethod transient--insert-group ((group transient-subgroups))
(let* ((subgroups (oref group suffixes))
(n (length subgroups)))
@@ -3431,36 +3779,31 @@ making `transient--original-buffer' current.")
"Return a string containing just the ARG character."
(char-to-string arg))
-(cl-defmethod transient-format :around ((obj transient-infix))
- "When reading user input for this infix, then highlight it."
+(cl-defmethod transient-format :around ((obj transient-suffix))
+ "Add additional formatting if appropriate.
+When reading user input for this infix, then highlight it.
+When edit-mode is enabled, then prepend the level information.
+When `transient-enable-popup-navigation' is non-nil then format
+as a button."
(let ((str (cl-call-next-method obj)))
- (when (eq obj transient--active-infix)
- (setq str (concat str "\n"))
- (add-face-text-property
- (if (eq this-command 'transient-set-level) 3 0)
- (length str)
- 'transient-active-infix nil str))
+ (when (and (cl-typep obj 'transient-infix)
+ (eq (oref obj command) this-original-command)
+ (active-minibuffer-window))
+ (setq str (transient--add-face str 'transient-active-infix)))
+ (when transient--editp
+ (setq str (concat (let ((level (oref obj level)))
+ (propertize (format " %s " level)
+ 'face (if (transient--use-level-p level t)
+ 'transient-enabled-suffix
+ 'transient-disabled-suffix)))
+ str)))
+ (when (and transient-enable-popup-navigation
+ (slot-boundp obj 'command))
+ (setq str (make-text-button str nil
+ 'type 'transient
+ 'command (oref obj command))))
str))
-(cl-defmethod transient-format :around ((obj transient-suffix))
- "When edit-mode is enabled, then prepend the level information.
-Optional support for popup buttons is also implemented here."
- (let ((str (concat
- (and transient--editp
- (let ((level (oref obj level)))
- (propertize (format " %s " level)
- 'face (if (transient--use-level-p level t)
- 'transient-enabled-suffix
- 'transient-disabled-suffix))))
- (cl-call-next-method obj))))
- (when (oref obj inapt)
- (add-face-text-property 0 (length str) 'transient-inapt-suffix nil str))
- (if transient-enable-popup-navigation
- (make-text-button str nil
- 'type 'transient
- 'command (oref obj command))
- str)))
-
(cl-defmethod transient-format ((obj transient-infix))
"Return a string generated using OBJ's `format'.
%k is formatted using `transient-format-key'.
@@ -3482,10 +3825,19 @@ Optional support for popup buttons is also implemented here."
(cl-defgeneric transient-format-key (obj)
"Format OBJ's `key' for display and return the result.")
+(cl-defmethod transient-format-key :around ((obj transient-suffix))
+ "Add `transient-inapt-suffix' face if suffix is inapt."
+ (let ((str (cl-call-next-method)))
+ (if (oref obj inapt)
+ (transient--add-face str 'transient-inapt-suffix)
+ str)))
+
(cl-defmethod transient-format-key ((obj transient-suffix))
"Format OBJ's `key' for display and return the result."
- (let ((key (oref obj key))
- (cmd (oref obj command)))
+ (let ((key (if (slot-boundp obj 'key) (oref obj key) ""))
+ (cmd (and (slot-boundp obj 'command) (oref obj command))))
+ (when-let ((width (oref transient--pending-group pad-keys)))
+ (setq key (truncate-string-to-width key width nil ?\s)))
(if transient--redisplay-key
(let ((len (length transient--redisplay-key))
(seq (cl-coerce (edmacro-parse-keys key t) 'list)))
@@ -3502,7 +3854,7 @@ Optional support for popup buttons is also implemented here."
(setq pre (string-replace "TAB" "C-i" pre))
(setq suf (string-replace "RET" "C-m" suf))
(setq suf (string-replace "TAB" "C-i" suf))
- ;; We use e.g. "-k" instead of the more correct "- k",
+ ;; We use e.g., "-k" instead of the more correct "- k",
;; because the former is prettier. If we did that in
;; the definition, then we want to drop the space that
;; is reinserted above. False-positives are possible
@@ -3512,33 +3864,27 @@ Optional support for popup buttons is also implemented here."
(setq suf (string-replace " " "" suf)))
(concat (propertize pre 'face 'transient-unreachable-key)
(and (string-prefix-p (concat pre " ") key) " ")
- (transient--colorize-key suf cmd)
+ (propertize suf 'face (transient--key-face cmd))
(save-excursion
(and (string-match " +\\'" key)
(propertize (match-string 0 key)
'face 'fixed-pitch))))))
((transient--lookup-key transient-sticky-map (kbd key))
- (transient--colorize-key key cmd))
+ (propertize key 'face (transient--key-face cmd)))
(t
(propertize key 'face 'transient-unreachable-key))))
- (transient--colorize-key key cmd))))
-
-(defun transient--colorize-key (key command)
- (propertize key 'face
- (or (and (transient--semantic-coloring-p)
- (transient--suffix-color command))
- 'transient-key)))
+ (propertize key 'face (transient--key-face cmd)))))
(cl-defmethod transient-format-key :around ((obj transient-argument))
+ "Handle `transient-highlight-mismatched-keys'."
(let ((key (cl-call-next-method obj)))
- (cond ((not transient-highlight-mismatched-keys))
- ((not (slot-boundp obj 'shortarg))
- (add-face-text-property
- 0 (length key) 'transient-nonstandard-key nil key))
- ((not (string-equal key (oref obj shortarg)))
- (add-face-text-property
- 0 (length key) 'transient-mismatched-key nil key)))
- key))
+ (cond
+ ((not transient-highlight-mismatched-keys) key)
+ ((not (slot-boundp obj 'shortarg))
+ (transient--add-face key 'transient-nonstandard-key))
+ ((not (string-equal key (oref obj shortarg)))
+ (transient--add-face key 'transient-mismatched-key))
+ (key))))
(cl-defgeneric transient-format-description (obj)
"Format OBJ's `description' for display and return the result.")
@@ -3547,10 +3893,14 @@ Optional support for popup buttons is also implemented here."
"The `description' slot may be a function, in which case that is
called inside the correct buffer (see `transient--insert-group')
and its value is returned to the caller."
- (and-let* ((desc (oref obj description)))
- (if (functionp desc)
- (with-current-buffer transient--original-buffer
- (funcall desc))
+ (and-let* ((desc (oref obj description))
+ (desc (if (functionp desc)
+ (if (= (car (func-arity desc)) 1)
+ (funcall desc obj)
+ (funcall desc))
+ desc)))
+ (if-let* ((face (transient--get-face obj 'face)))
+ (transient--add-face desc face t)
desc)))
(cl-defmethod transient-format-description ((obj transient-group))
@@ -3572,16 +3922,19 @@ If the OBJ's `key' is currently unreachable, then apply the face
(funcall (oref transient--prefix suffix-description)
obj))
(propertize "(BUG: no description)" 'face 'error))))
- (cond ((transient--key-unreachable-p obj)
- (propertize desc 'face 'transient-unreachable))
- ((and transient-highlight-higher-levels
- (> (max (oref obj level) transient--max-group-level)
- transient--default-prefix-level))
- (add-face-text-property
- 0 (length desc) 'transient-higher-level nil desc)
- desc)
- (t
- desc))))
+ (when (if transient--all-levels-p
+ (> (oref obj level) transient--default-prefix-level)
+ (and transient-highlight-higher-levels
+ (> (max (oref obj level) transient--max-group-level)
+ transient--default-prefix-level)))
+ (setq desc (transient--add-face desc 'transient-higher-level)))
+ (when-let ((inapt-face (and (oref obj inapt)
+ (transient--get-face obj 'inapt-face))))
+ (setq desc (transient--add-face desc inapt-face)))
+ (when (and (slot-boundp obj 'key)
+ (transient--key-unreachable-p obj))
+ (setq desc (transient--add-face desc 'transient-unreachable)))
+ desc))
(cl-defgeneric transient-format-value (obj)
"Format OBJ's value for display and return the result.")
@@ -3595,24 +3948,32 @@ If the OBJ's `key' is currently unreachable, then apply the face
(cl-defmethod transient-format-value ((obj transient-option))
(let ((argument (oref obj argument)))
(if-let ((value (oref obj value)))
- (propertize
- (cl-ecase (oref obj multi-value)
- ((nil) (concat argument value))
- ((t rest) (concat argument
- (and (not (string-suffix-p " " argument)) " ")
- (mapconcat #'prin1-to-string value " ")))
- (repeat (mapconcat (lambda (v) (concat argument v)) value " ")))
- 'face 'transient-value)
- (propertize argument 'face 'transient-inactive-value))))
+ (pcase-exhaustive (oref obj multi-value)
+ ('nil
+ (concat (propertize argument 'face 'transient-argument)
+ (propertize value 'face 'transient-value)))
+ ((or 't 'rest)
+ (concat (propertize (if (string-suffix-p " " argument)
+ argument
+ (concat argument " "))
+ 'face 'transient-argument)
+ (propertize (mapconcat #'prin1-to-string value " ")
+ 'face 'transient-value)))
+ ('repeat
+ (mapconcat (lambda (value)
+ (concat (propertize argument 'face 'transient-argument)
+ (propertize value 'face 'transient-value)))
+ value " ")))
+ (propertize argument 'face 'transient-inactive-argument))))
(cl-defmethod transient-format-value ((obj transient-switches))
(with-slots (value argument-format choices) obj
(format (propertize argument-format
'face (if value
- 'transient-value
- 'transient-inactive-value))
- (concat
- (propertize "[" 'face 'transient-inactive-value)
+ 'transient-argument
+ 'transient-inactive-argument))
+ (format
+ (propertize "[%s]" 'face 'transient-delimiter)
(mapconcat
(lambda (choice)
(propertize choice 'face
@@ -3620,8 +3981,33 @@ If the OBJ's `key' is currently unreachable, then apply the face
'transient-value
'transient-inactive-value)))
choices
- (propertize "|" 'face 'transient-inactive-value))
- (propertize "]" 'face 'transient-inactive-value)))))
+ (propertize "|" 'face 'transient-delimiter))))))
+
+(defun transient--add-face (string face &optional append beg end)
+ (let ((str (copy-sequence string)))
+ (add-face-text-property (or beg 0) (or end (length str)) face append str)
+ str))
+
+(defun transient--get-face (obj slot)
+ (and-let* ((! (slot-exists-p obj slot))
+ (! (slot-boundp obj slot))
+ (face (slot-value obj slot)))
+ (if (and (not (facep face))
+ (functionp face))
+ (let ((transient--pending-suffix obj))
+ (if (= (car (func-arity face)) 1)
+ (funcall face obj)
+ (funcall face)))
+ face)))
+
+(defun transient--key-face (&optional cmd enforce-type)
+ (or (and transient-semantic-coloring
+ (not transient--helpp)
+ (not transient--editp)
+ (or (and cmd (get cmd 'transient-face))
+ (get (transient--get-pre-command cmd enforce-type)
+ 'transient-face)))
+ (if cmd 'transient-key 'transient-key-noop)))
(defun transient--key-unreachable-p (obj)
(and transient--redisplay-key
@@ -3636,19 +4022,24 @@ If the OBJ's `key' is currently unreachable, then apply the face
(and val (not (integerp val)) val)))
(defun transient--maybe-pad-keys (group &optional parent)
- (when-let ((pad (if (slot-boundp group 'pad-keys)
- (oref group pad-keys)
- (and parent
- (slot-boundp parent 'pad-keys)
- (oref parent pad-keys)))))
- (let ((width (apply #'max
- (cons (if (integerp pad) pad 0)
- (mapcar (lambda (suffix)
- (length (oref suffix key)))
- (oref group suffixes))))))
- (dolist (suffix (oref group suffixes))
- (oset suffix key
- (truncate-string-to-width (oref suffix key) width nil ?\s))))))
+ (when-let ((pad (or (oref group pad-keys)
+ (and parent (oref parent pad-keys)))))
+ (oset group pad-keys
+ (apply #'max (cons (if (integerp pad) pad 0)
+ (seq-keep (lambda (suffix)
+ (and (eieio-object-p suffix)
+ (slot-boundp suffix 'key)
+ (length (oref suffix key))))
+ (oref group suffixes)))))))
+
+(defun transient--pixel-width (string)
+ (save-window-excursion
+ (with-temp-buffer
+ (insert string)
+ (set-window-dedicated-p nil nil)
+ (set-window-buffer nil (current-buffer))
+ (car (window-text-pixel-size
+ nil (line-beginning-position) (point))))))
(defun transient-command-summary-or-name (obj)
"Return the summary or name of the command represented by OBJ.
@@ -3676,7 +4067,7 @@ if non-nil, else show the `man-page' if non-nil, else use
(cond (show-help (funcall show-help obj))
(info-manual (transient--show-manual info-manual))
(man-page (transient--show-manpage man-page))
- (t (transient--describe-function command)))))
+ ((transient--describe-function command)))))
(cl-defmethod transient-show-help ((obj transient-suffix))
"Call `show-help' if non-nil, else use `describe-function'.
@@ -3690,9 +4081,9 @@ prefix method."
'transient--prefix)))
(and prefix (not (eq (oref transient--prefix command) this-command))
(prog1 t (transient-show-help prefix)))))
- (t (if-let ((show-help (oref obj show-help)))
- (funcall show-help obj)
- (transient--describe-function this-command)))))
+ ((if-let ((show-help (oref obj show-help)))
+ (funcall show-help obj)
+ (transient--describe-function this-command)))))
(cl-defmethod transient-show-help ((obj transient-infix))
"Call `show-help' if non-nil, else show the `man-page'
@@ -3712,7 +4103,7 @@ manpage, then try to jump to the correct location."
(transient--describe-function cmd))
(defun transient--describe-function (fn)
- (describe-function (if (symbolp fn) fn 'transient--anonymous-infix-argument))
+ (describe-function fn)
(unless (derived-mode-p 'help-mode)
(when-let* ((buf (get-buffer "*Help*"))
(win (or (and buf (get-buffer-window buf))
@@ -3722,21 +4113,6 @@ manpage, then try to jump to the correct location."
(window-list)))))
(select-window win))))
-(defun transient--anonymous-infix-argument ()
- "Cannot show any documentation for this anonymous infix command.
-
-The infix command in question was defined anonymously, i.e.,
-it was define when the prefix command that it belongs to was
-defined, which means that it gets no docstring and also that
-no symbol is bound to it.
-
-When you request help for an infix command, then we usually
-show the respective man-page and jump to the location where
-the respective argument is being described.
-
-Because the containing prefix command does not specify any
-man-page, we cannot do that in this case. Sorry about that.")
-
(defun transient--show-manual (manual)
(info manual))
@@ -3829,37 +4205,23 @@ Suffixes on levels %s and %s are unavailable.\n"
(propertize (format ">=%s" (1+ level))
'face 'transient-disabled-suffix))))))
-(defvar-keymap transient-resume-mode-map
- :doc "Keymap for `transient-resume-mode'.
-
-This keymap remaps every command that would usually just quit the
-documentation buffer to `transient-resume', which additionally
-resumes the suspended transient."
- "<remap> <Man-quit>" #'transient-resume
- "<remap> <Info-exit>" #'transient-resume
- "<remap> <quit-window>" #'transient-resume)
-
-(define-minor-mode transient-resume-mode
- "Auxiliary minor-mode used to resume a transient after viewing help.")
-
-(defun transient-toggle-debug ()
- "Toggle debugging statements for transient commands."
- (interactive)
- (setq transient--debug (not transient--debug))
- (message "Debugging transient %s"
- (if transient--debug "enabled" "disabled")))
-
;;; Popup Navigation
-(defun transient-popup-navigation-help ()
- "Inform the user how to enable popup navigation commands."
- (interactive)
- (message "This command is only available if `%s' is non-nil"
- 'transient-enable-popup-navigation))
+(defun transient-scroll-up (&optional arg)
+ "Scroll text of transient popup window upward ARG lines.
+If ARG is nil scroll near full screen. This is a wrapper
+around `scroll-up-command' (which see)."
+ (interactive "^P")
+ (with-selected-window transient--window
+ (scroll-up-command arg)))
-(define-button-type 'transient
- 'face nil
- 'keymap transient-button-map)
+(defun transient-scroll-down (&optional arg)
+ "Scroll text of transient popup window down ARG lines.
+If ARG is nil scroll near full screen. This is a wrapper
+around `scroll-down-command' (which see)."
+ (interactive "^P")
+ (with-selected-window transient--window
+ (scroll-down-command arg)))
(defun transient-backward-button (n)
"Move to the previous button in the transient popup buffer.
@@ -3875,6 +4237,10 @@ See `forward-button' for information about N."
(with-selected-window transient--window
(forward-button n t)))
+(define-button-type 'transient
+ 'face nil
+ 'keymap transient-button-map)
+
(defun transient--goto-button (command)
(cond
((stringp command)
@@ -3952,36 +4318,6 @@ search instead."
(select-window transient--original-window)
(transient--resume-override))
-;;;; Hydra Color Emulation
-
-(defun transient--semantic-coloring-p ()
- (and transient-semantic-coloring
- (not transient--helpp)
- (not transient--editp)))
-
-(defun transient--suffix-color (command)
- (or (get command 'transient-color)
- (get (transient--get-predicate-for command) 'transient-color)))
-
-(defun transient--prefix-color (command)
- (let* ((nonsuf (or (oref command transient-non-suffix)
- 'transient--do-warn))
- (nonsuf (if (memq nonsuf '(transient--do-noop transient--do-warn))
- 'disallow
- (get nonsuf 'transient-color)))
- (suffix (if-let ((pred (oref command transient-suffix)))
- (get pred 'transient-color)
- (if (eq nonsuf 'transient-red)
- 'transient-red
- 'transient-blue))))
- (pcase (list suffix nonsuf)
- (`(transient-purple ,_) 'transient-purple)
- ('(transient-red disallow) 'transient-amaranth)
- ('(transient-blue disallow) 'transient-teal)
- ('(transient-red transient-red) 'transient-pink)
- ('(transient-red transient-blue) 'transient-red)
- ('(transient-blue transient-blue) 'transient-blue))))
-
;;;; Edebug
(defun transient--edebug-command-p ()
@@ -4043,7 +4379,7 @@ we stop there."
(let ((key (oref obj key)))
(cond ((string-equal key "q") "Q")
((string-equal key "Q") "M-q")
- (t key))))
+ (key))))
(defun transient--force-fixed-pitch ()
(require 'face-remap)
@@ -4078,8 +4414,7 @@ we stop there."
(regexp-opt (list "transient-define-prefix"
"transient-define-infix"
"transient-define-argument"
- "transient-define-suffix"
- "transient-define-groups")
+ "transient-define-suffix")
t)
"\\_>[ \t'(]*"
"\\(\\(?:\\sw\\|\\s_\\)+\\)?")
diff --git a/lisp/treesit.el b/lisp/treesit.el
index 2676ed932dc..2b4893e6129 100644
--- a/lisp/treesit.el
+++ b/lisp/treesit.el
@@ -32,9 +32,8 @@
;;; Code:
-(eval-when-compile (require 'cl-lib))
(eval-when-compile (require 'subr-x)) ; For `string-join'.
-(require 'cl-seq)
+(require 'cl-lib)
(require 'font-lock)
(require 'seq)
@@ -56,6 +55,7 @@
(declare-function treesit-parser-list "treesit.c")
(declare-function treesit-parser-buffer "treesit.c")
(declare-function treesit-parser-language "treesit.c")
+(declare-function treesit-parser-tag "treesit.c")
(declare-function treesit-parser-root-node "treesit.c")
@@ -88,9 +88,12 @@
(declare-function treesit-search-forward "treesit.c")
(declare-function treesit-induce-sparse-tree "treesit.c")
(declare-function treesit-subtree-stat "treesit.c")
+(declare-function treesit-node-match-p "treesit.c")
(declare-function treesit-available-p "treesit.c")
+(defvar treesit-thing-settings)
+
;;; Custom options
;; Tree-sitter always appear as treesit in symbols.
@@ -106,7 +109,7 @@ indent, imenu, etc."
;; 40MB for 64-bit systems, 15 for 32-bit.
(if (or (< most-positive-fixnum (* 2.0 1024 mb))
;; 32-bit system with wide ints.
- (string-match-p "--with-wide-int" system-configuration-options))
+ (string-search "--with-wide-int" system-configuration-options))
(* 15 mb)
(* 40 mb)))
"Maximum buffer size (in bytes) for enabling tree-sitter parsing.
@@ -143,10 +146,15 @@ cumbersome and can't deal with some edge cases.")
(defun treesit-language-at (position)
"Return the language at POSITION.
+
This function assumes that parser ranges are up-to-date. It
returns the return value of `treesit-language-at-point-function'
if it's non-nil, otherwise it returns the language of the first
-parser in `treesit-parser-list', or nil if there is no parser."
+parser in `treesit-parser-list', or nil if there is no parser.
+
+In a multi-language buffer, make sure
+`treesit-language-at-point-function' is implemented! Otherwise
+`treesit-language-at' wouldn't return the correct result."
(if treesit-language-at-point-function
(funcall treesit-language-at-point-function position)
(when-let ((parser (car (treesit-parser-list))))
@@ -190,11 +198,20 @@ only look for named nodes.
If PARSER-OR-LANG is a parser, use that parser; if PARSER-OR-LANG
is a language, find the first parser for that language in the
current buffer, or create one if none exists; If PARSER-OR-LANG
-is nil, try to guess the language at POS using `treesit-language-at'."
+is nil, try to guess the language at POS using `treesit-language-at'.
+
+If there's a local parser at POS, the local parser takes priority
+unless PARSER-OR-LANG is a parser, or PARSER-OR-LANG is a
+language and doesn't match the language of the local parser."
(let* ((root (if (treesit-parser-p parser-or-lang)
(treesit-parser-root-node parser-or-lang)
- (treesit-buffer-root-node
- (or parser-or-lang (treesit-language-at pos)))))
+ (or (when-let ((parser
+ (car (treesit-local-parsers-at
+ pos parser-or-lang))))
+ (treesit-parser-root-node parser))
+ (treesit-buffer-root-node
+ (or parser-or-lang
+ (treesit-language-at pos))))))
(node root)
(node-before root)
(pos-1 (max (1- pos) (point-min)))
@@ -239,11 +256,20 @@ named node.
If PARSER-OR-LANG is a parser, use that parser; if PARSER-OR-LANG
is a language, find the first parser for that language in the
current buffer, or create one if none exists; If PARSER-OR-LANG
-is nil, try to guess the language at BEG using `treesit-language-at'."
- (let ((root (if (treesit-parser-p parser-or-lang)
- (treesit-parser-root-node parser-or-lang)
- (treesit-buffer-root-node
- (or parser-or-lang (treesit-language-at beg))))))
+is nil, try to guess the language at BEG using `treesit-language-at'.
+
+If there's a local parser between BEG and END, try to use that
+parser first."
+ (let* ((lang-at-point (treesit-language-at beg))
+ (root (if (treesit-parser-p parser-or-lang)
+ (treesit-parser-root-node parser-or-lang)
+ (or (when-let ((parser
+ (car (treesit-local-parsers-on
+ beg end (or parser-or-lang
+ lang-at-point)))))
+ (treesit-parser-root-node parser))
+ (treesit-buffer-root-node
+ (or parser-or-lang lang-at-point))))))
(treesit-node-descendant-for-range root beg (or end beg) named)))
(defun treesit-node-top-level (node &optional pred include-node)
@@ -252,33 +278,32 @@ is nil, try to guess the language at BEG using `treesit-language-at'."
Specifically, return the highest parent of NODE that has the same
type as it. If no such parent exists, return nil.
-If PRED is non-nil, match each parent's type with PRED as a
-regexp, rather than using NODE's type. PRED can also be a
-function that takes the node as an argument, and return
-non-nil/nil for match/no match.
+If PRED is non-nil, match each parent's type with PRED rather
+than using NODE's type. PRED can also be a predicate function,
+and more. See `treesit-thing-settings' for details.
If INCLUDE-NODE is non-nil, return NODE if it satisfies PRED."
- (let ((pred (or pred (treesit-node-type node)))
+ (let ((pred (or pred (rx bos (literal (treesit-node-type node)) eos)))
(result nil))
(cl-loop for cursor = (if include-node node
(treesit-node-parent node))
then (treesit-node-parent cursor)
while cursor
- if (if (stringp pred)
- (string-match-p pred (treesit-node-type cursor))
- (funcall pred cursor))
+ if (treesit-node-match-p cursor pred t)
do (setq result cursor))
result))
-(defun treesit-buffer-root-node (&optional language)
+(defun treesit-buffer-root-node (&optional language tag)
"Return the root node of the current buffer.
Use the first parser in the parser list if LANGUAGE is omitted.
-If LANGUAGE is non-nil, use the first parser for LANGUAGE in the
-parser list, or create one if none exists."
+
+If LANGUAGE is non-nil, use the first parser for LANGUAGE with
+TAG in the parser list, or create one if none exists. TAG
+defaults to nil."
(if-let ((parser
(if language
- (treesit-parser-create language)
+ (treesit-parser-create language nil nil tag)
(or (car (treesit-parser-list))
(signal 'treesit-no-parser (list (current-buffer)))))))
(treesit-parser-root-node parser)))
@@ -319,14 +344,13 @@ ancestor node which satisfies the predicate PRED; then it
returns that ancestor node. It returns nil if no ancestor
node was found that satisfies PRED.
-PRED should be a function that takes one argument, the node to
-examine, and returns a boolean value indicating whether that
-node is a match.
+PRED can be a predicate function, a regexp matching node type,
+and more; see docstring of `treesit-thing-settings'.
If INCLUDE-NODE is non-nil, return NODE if it satisfies PRED."
(let ((node (if include-node node
(treesit-node-parent node))))
- (while (and node (not (funcall pred node)))
+ (while (and node (not (treesit-node-match-p node pred)))
(setq node (treesit-node-parent node)))
node))
@@ -339,11 +363,10 @@ no longer satisfies the predicate PRED; it returns the last
examined node that satisfies PRED. If no node satisfies PRED, it
returns nil.
-PRED should be a function that takes one argument, the node to
-examine, and returns a boolean value indicating whether that
-node is a match."
+PRED can be a predicate function, a regexp matching node type,
+and more; see docstring of `treesit-thing-settings'."
(let ((last nil))
- (while (and node (funcall pred node))
+ (while (and node (treesit-node-match-p node pred))
(setq last node
node (treesit-node-parent node)))
last))
@@ -370,6 +393,85 @@ If NAMED is non-nil, count named child only."
(idx (treesit-node-index node)))
(treesit-node-field-name-for-child parent idx)))
+(defun treesit-node-get (node instructions)
+ "Get things from NODE by INSTRUCTIONS.
+
+This is a convenience function that chains together multiple node
+accessor functions together. For example, to get NODE's parent's
+next sibling's second child's text, call
+
+ (treesit-node-get node
+ \\='((parent 1)
+ (sibling 1 nil)
+ (child 1 nil)
+ (text nil)))
+
+INSTRUCTION is a list of INSTRUCTIONs of the form (FN ARG...).
+The following FN's are supported:
+
+\(child IDX NAMED) Get the IDX'th child
+\(parent N) Go to parent N times
+\(field-name) Get the field name of the current node
+\(type) Get the type of the current node
+\(text NO-PROPERTY) Get the text of the current node
+\(children NAMED) Get a list of children
+\(sibling STEP NAMED) Get the nth prev/next sibling, negative STEP
+ means prev sibling, positive means next
+
+Note that arguments like NAMED and NO-PROPERTY can't be omitted,
+unlike in their original functions."
+ (declare (indent 1))
+ (while (and node instructions)
+ (pcase (pop instructions)
+ ('(field-name) (setq node (treesit-node-field-name node)))
+ ('(type) (setq node (treesit-node-type node)))
+ (`(child ,idx ,named) (setq node (treesit-node-child node idx named)))
+ (`(parent ,n) (dotimes (_ n)
+ (setq node (treesit-node-parent node))))
+ (`(text ,no-property) (setq node (treesit-node-text node no-property)))
+ (`(children ,named) (setq node (treesit-node-children node named)))
+ (`(sibling ,step ,named)
+ (dotimes (_ (abs step))
+ (setq node (if (> step 0)
+ (treesit-node-next-sibling node named)
+ (treesit-node-prev-sibling node named)))))))
+ node)
+
+(defun treesit-node-enclosed-p (smaller larger &optional strict)
+ "Return non-nil if SMALLER is enclosed in LARGER.
+SMALLER and LARGER can be either (BEG . END) or a node.
+
+Return non-nil if LARGER's start <= SMALLER's start and LARGER's
+end <= SMALLER's end.
+
+If STRICT is t, compare with < rather than <=.
+
+If STRICT is \\='partial, consider LARGER encloses SMALLER when
+at least one side is strictly enclosing."
+ (unless (and (or (consp larger) (treesit-node-p larger))
+ (or (consp smaller) (treesit-node-p smaller)))
+ (signal 'wrong-type-argument '((or cons treesit-node))))
+ (let ((larger-start (if (consp larger)
+ (car larger)
+ (treesit-node-start larger)))
+ (larger-end (if (consp larger)
+ (cdr larger)
+ (treesit-node-end larger)))
+ (smaller-start (if (consp smaller)
+ (car smaller)
+ (treesit-node-start smaller)))
+ (smaller-end (if (consp smaller)
+ (cdr smaller)
+ (treesit-node-end smaller))))
+ (pcase strict
+ ('t (and (< larger-start smaller-start)
+ (< smaller-end larger-end)))
+ ('partial (and (or (not (eq larger-start smaller-start))
+ (not (eq larger-end smaller-end)))
+ (<= larger-start smaller-start
+ smaller-end larger-end)))
+ (_ (<= larger-start smaller-start smaller-end larger-end)))))
+
;;; Query API supplement
(defun treesit-query-string (string query language)
@@ -382,32 +484,40 @@ See `treesit-query-capture' for QUERY."
(treesit-parser-root-node parser)
query))))
-(defun treesit-query-range (node query &optional beg end)
+(defun treesit-query-range (node query &optional beg end offset)
"Query the current buffer and return ranges of captured nodes.
QUERY, NODE, BEG, END are the same as in `treesit-query-capture'.
This function returns a list of (START . END), where START and
-END specifics the range of each captured node. Capture names
-generally don't matter, but names that starts with an underscore
-are ignored."
- (cl-loop for capture
- in (treesit-query-capture node query beg end)
- for name = (car capture)
- for node = (cdr capture)
- if (not (string-prefix-p "_" (symbol-name name)))
- collect (cons (treesit-node-start node)
- (treesit-node-end node))))
+END specifics the range of each captured node. OFFSET is an
+optional pair of numbers (START-OFFSET . END-OFFSET). The
+respective offset values are added to each (START . END) range
+being returned. Capture names generally don't matter, but names
+that starts with an underscore are ignored."
+ (let ((offset-left (or (car offset) 0))
+ (offset-right (or (cdr offset) 0)))
+ (cl-loop for capture
+ in (treesit-query-capture node query beg end)
+ for name = (car capture)
+ for node = (cdr capture)
+ if (not (string-prefix-p "_" (symbol-name name)))
+ collect (cons (+ (treesit-node-start node) offset-left)
+ (+ (treesit-node-end node) offset-right)))))
;;; Range API supplement
(defvar-local treesit-range-settings nil
"A list of range settings.
-Each element of the list is of the form (QUERY LANGUAGE).
-When updating the range of each parser in the buffer,
+Each element of the list is of the form (QUERY LANGUAGE LOCAL-P
+OFFSET). When updating the range of each parser in the buffer,
`treesit-update-ranges' queries each QUERY, and sets LANGUAGE's
range to the range spanned by captured nodes. QUERY must be a
-compiled query.
+compiled query. If LOCAL-P is t, give each range a separate
+local parser rather than using a single parser for all the
+ranges. If OFFSET is non-nil, it should be a cons of
+numbers (START-OFFSET . END-OFFSET), where the start and end
+offset are added to each queried range to get the result ranges.
Capture names generally don't matter, but names that starts with
an underscore are ignored.
@@ -440,6 +550,7 @@ it. For example,
(treesit-range-rules
:embed \\='javascript
:host \\='html
+ :offset \\='(1 . -1)
\\='((script_element (raw_text) @cap)))
The `:embed' keyword specifies the embedded language, and the
@@ -448,15 +559,28 @@ this way: Emacs queries QUERY in the host language's parser,
computes the ranges spanned by the captured nodes, and applies
these ranges to parsers for the embedded language.
+If there's a `:local' keyword with value t, the range computed by
+this QUERY is given a dedicated local parser. Otherwise, the
+range shares the same parser with other ranges.
+
+If there's an `:offset' keyword with a pair of numbers, each
+captured range is offset by those numbers. For example, an
+offset of (1 . -1) will update a captured range of (2 . 8) to
+be (3 . 7). This can be used to exclude things like surrounding
+delimiters from being included in the range covered by an
+embedded parser.
+
QUERY can also be a function that takes two arguments, START and
END. If QUERY is a function, it doesn't need the :KEYWORD VALUE
pair preceding it. This function should set the ranges for
parsers in the current buffer in the region between START and
END. It is OK for this function to set ranges in a larger region
that encompasses the region between START and END."
- (let (host embed result)
+ (let (host embed offset result local)
(while query-specs
(pcase (pop query-specs)
+ (:local (when (eq t (pop query-specs))
+ (setq local t)))
(:host (let ((host-lang (pop query-specs)))
(unless (symbolp host-lang)
(signal 'treesit-error (list "Value of :host option should be a symbol" host-lang)))
@@ -465,6 +589,12 @@ that encompasses the region between START and END."
(unless (symbolp embed-lang)
(signal 'treesit-error (list "Value of :embed option should be a symbol" embed-lang)))
(setq embed embed-lang)))
+ (:offset (let ((range-offset (pop query-specs)))
+ (unless (and (consp range-offset)
+ (numberp (car range-offset))
+ (numberp (cdr range-offset)))
+ (signal 'treesit-error (list "Value of :offset option should be a pair of numbers" range-offset)))
+ (setq offset range-offset)))
(query (if (functionp query)
(push (list query nil nil) result)
(when (null embed)
@@ -472,9 +602,9 @@ that encompasses the region between START and END."
(when (null host)
(signal 'treesit-error (list "Value of :host option cannot be omitted")))
(push (list (treesit-query-compile host query)
- embed host)
+ embed local offset)
result))
- (setq host nil embed nil))))
+ (setq host nil embed nil offset nil local nil))))
(nreverse result)))
(defun treesit--merge-ranges (old-ranges new-ranges start end)
@@ -523,6 +653,85 @@ those inside are kept."
if (<= start (car range) (cdr range) end)
collect range))
+(defun treesit-local-parsers-at (&optional pos language with-host)
+ "Return all the local parsers at POS.
+
+POS defaults to point.
+Local parsers are those which only parse a limited region marked
+by an overlay with non-nil `treesit-parser' property.
+If LANGUAGE is non-nil, only return parsers for LANGUAGE.
+
+If WITH-HOST is non-nil, return a list of (PARSER . HOST-PARSER)
+instead. HOST-PARSER is the host parser which created the local
+PARSER."
+ (let ((res nil))
+ (dolist (ov (overlays-at (or pos (point))))
+ (when-let ((parser (overlay-get ov 'treesit-parser))
+ (host-parser (overlay-get ov 'treesit-host-parser)))
+ (when (or (null language)
+ (eq (treesit-parser-language parser)
+ language))
+ (push (if with-host (cons parser host-parser) parser) res))))
+ (nreverse res)))
+
+(defun treesit-local-parsers-on (&optional beg end language with-host)
+ "Return all the local parsers between BEG END.
+
+BEG and END default to the beginning and end of the buffer's
+accessible portion.
+Local parsers are those which have an `embedded' tag, and only parse
+a limited region marked by an overlay with a non-nil `treesit-parser'
+property. If LANGUAGE is non-nil, only return parsers for LANGUAGE.
+
+If WITH-HOST is non-nil, return a list of (PARSER . HOST-PARSER)
+instead. HOST-PARSER is the host parser which created the local
+PARSER."
+ (let ((res nil))
+ (dolist (ov (overlays-in (or beg (point-min)) (or end (point-max))))
+ (when-let ((parser (overlay-get ov 'treesit-parser))
+ (host-parser (overlay-get ov 'treesit-host-parser)))
+ (when (or (null language)
+ (eq (treesit-parser-language parser)
+ language))
+ (push (if with-host (cons parser host-parser) parser) res))))
+ (nreverse res)))
+
+(defun treesit--update-ranges-local
+ (query embedded-lang &optional beg end)
+ "Update range for local parsers between BEG and END.
+Use QUERY to get the ranges, and make sure each range has a local
+parser for EMBEDDED-LANG."
+ ;; Clean up.
+ (dolist (ov (overlays-in (or beg (point-min)) (or end (point-max))))
+ (when-let ((parser (overlay-get ov 'treesit-parser)))
+ (when (eq (overlay-start ov) (overlay-end ov))
+ (delete-overlay ov)
+ (treesit-parser-delete parser))))
+ ;; Update range.
+ (let* ((host-lang (treesit-query-language query))
+ (host-parser (treesit-parser-create host-lang))
+ (ranges (treesit-query-range host-parser query beg end)))
+ (pcase-dolist (`(,beg . ,end) ranges)
+ (let ((has-parser nil))
+ (dolist (ov (overlays-in beg end))
+ ;; Update range of local parser.
+ (let ((embedded-parser (overlay-get ov 'treesit-parser)))
+ (when (and (treesit-parser-p embedded-parser)
+ (eq (treesit-parser-language embedded-parser)
+ embedded-lang))
+ (treesit-parser-set-included-ranges
+ embedded-parser `((,beg . ,end)))
+ (setq has-parser t))))
+ ;; Create overlay and local parser.
+ (when (not has-parser)
+ (let ((embedded-parser (treesit-parser-create
+ embedded-lang nil t 'embedded))
+ (ov (make-overlay beg end nil nil t)))
+ (overlay-put ov 'treesit-parser embedded-parser)
+ (overlay-put ov 'treesit-host-parser host-parser)
+ (treesit-parser-set-included-ranges
+ embedded-parser `((,beg . ,end)))))))))
+
(defun treesit-update-ranges (&optional beg end)
"Update the ranges for each language in the current buffer.
If BEG and END are non-nil, only update parser ranges in that
@@ -535,21 +744,25 @@ region."
(dolist (setting treesit-range-settings)
(let ((query (nth 0 setting))
(language (nth 1 setting))
+ (local (nth 2 setting))
+ (offset (nth 3 setting))
(beg (or beg (point-min)))
(end (or end (point-max))))
- (if (functionp query) (funcall query beg end)
+ (cond
+ ((functionp query) (funcall query beg end))
+ (local
+ (treesit--update-ranges-local query language beg end))
+ (t
(let* ((host-lang (treesit-query-language query))
(parser (treesit-parser-create language))
(old-ranges (treesit-parser-included-ranges parser))
(new-ranges (treesit-query-range
- host-lang query beg end))
+ host-lang query beg end offset))
(set-ranges (treesit--clip-ranges
(treesit--merge-ranges
old-ranges new-ranges beg end)
(point-min) (point-max))))
- (dolist (parser (treesit-parser-list))
- (when (eq (treesit-parser-language parser)
- language)
+ (dolist (parser (treesit-parser-list nil language))
(treesit-parser-set-included-ranges
parser (or set-ranges
;; When there's no range for the embedded
@@ -724,6 +937,8 @@ Other keywords include:
`append' Append the new face to existing ones.
`prepend' Prepend the new face to existing ones.
`keep' Fill-in regions without an existing face.
+ :default-language LANGUAGE Every QUERY after this keyword
+ will use LANGUAGE by default.
Capture names in QUERY should be face names like
`font-lock-keyword-face'. The captured node will be fontified
@@ -753,12 +968,22 @@ name, it is ignored."
;; that following queries will apply to.
current-language current-override
current-feature
+ ;; DEFAULT-LANGUAGE will be chosen when current-language is
+ ;; not set.
+ default-language
;; The list this function returns.
(result nil))
(while query-specs
(let ((token (pop query-specs)))
(pcase token
;; (1) Process keywords.
+ (:default-language
+ (let ((lang (pop query-specs)))
+ (when (or (not (symbolp lang)) (null lang))
+ (signal 'treesit-font-lock-error
+ `("Value of :default-language should be a symbol"
+ ,lang)))
+ (setq default-language lang)))
(:language
(let ((lang (pop query-specs)))
(when (or (not (symbolp lang)) (null lang))
@@ -786,23 +1011,24 @@ name, it is ignored."
(setq current-feature var)))
;; (2) Process query.
((pred treesit-query-p)
- (when (null current-language)
- (signal 'treesit-font-lock-error
- `("Language unspecified, use :language keyword to specify a language for this query" ,token)))
- (when (null current-feature)
- (signal 'treesit-font-lock-error
- `("Feature unspecified, use :feature keyword to specify the feature name for this query" ,token)))
- (if (treesit-compiled-query-p token)
- (push `(,current-language token) result)
- (push `(,(treesit-query-compile current-language token)
- t
- ,current-feature
- ,current-override)
- result))
- ;; Clears any configurations set for this query.
- (setq current-language nil
- current-override nil
- current-feature nil))
+ (let ((lang (or default-language current-language)))
+ (when (null lang)
+ (signal 'treesit-font-lock-error
+ `("Language unspecified, use :language keyword or :default-language to specify a language for this query" ,token)))
+ (when (null current-feature)
+ (signal 'treesit-font-lock-error
+ `("Feature unspecified, use :feature keyword to specify the feature name for this query" ,token)))
+ (if (treesit-compiled-query-p token)
+ (push `(,lang token) result)
+ (push `(,(treesit-query-compile lang token)
+ t
+ ,current-feature
+ ,current-override)
+ result))
+ ;; Clears any configurations set for this query.
+ (setq current-language nil
+ current-override nil
+ current-feature nil)))
(_ (signal 'treesit-font-lock-error
`("Unexpected value" ,token))))))
(nreverse result))))
@@ -814,7 +1040,8 @@ name, it is ignored."
(defvar treesit--font-lock-verbose nil
"If non-nil, print debug messages when fontifying.")
-(defun treesit-font-lock-recompute-features (&optional add-list remove-list)
+(defun treesit-font-lock-recompute-features
+ (&optional add-list remove-list language)
"Enable/disable font-lock features.
Enable each feature in ADD-LIST, disable each feature in
@@ -829,7 +1056,10 @@ the features are disabled.
ADD-LIST and REMOVE-LIST are lists of feature symbols. The
same feature symbol cannot appear in both lists; the function
-signals the `treesit-font-lock-error' error if that happens."
+signals the `treesit-font-lock-error' error if that happens.
+
+If LANGUAGE is non-nil, only compute features for that language,
+and leave settings for other languages unchanged."
(when-let ((intersection (cl-intersection add-list remove-list)))
(signal 'treesit-font-lock-error
(list "ADD-LIST and REMOVE-LIST contain the same feature"
@@ -849,9 +1079,13 @@ signals the `treesit-font-lock-error' error if that happens."
(additive (or add-list remove-list)))
(cl-loop for idx = 0 then (1+ idx)
for setting in treesit-font-lock-settings
+ for lang = (treesit-query-language (nth 0 setting))
for feature = (nth 2 setting)
for current-value = (nth 1 setting)
- ;; Set the ENABLE flag for the setting.
+ ;; Set the ENABLE flag for the setting if its language is
+ ;; relevant.
+ if (or (null language)
+ (eq language lang))
do (setf (nth 1 (nth idx treesit-font-lock-settings))
(cond
((not additive)
@@ -864,13 +1098,12 @@ signals the `treesit-font-lock-error' error if that happens."
(start end face override &optional bound-start bound-end)
"Apply FACE to the region between START and END.
OVERRIDE can be nil, t, `append', `prepend', or `keep'.
-See `treesit-font-lock-rules' for their semantic.
+See `treesit-font-lock-rules' for their semantics.
If BOUND-START and BOUND-END are non-nil, only fontify the region
in between them."
(when (or (null bound-start) (null bound-end)
- (and bound-start bound-end
- (<= bound-start end)
+ (and (<= bound-start end)
(>= bound-end start)))
(when (and bound-start bound-end)
(setq start (max bound-start start)
@@ -1009,72 +1242,92 @@ If LOUDLY is non-nil, display some debugging information."
(message "Fontifying region: %s-%s" start end))
(treesit-update-ranges start end)
(font-lock-unfontify-region start end)
- (dolist (setting treesit-font-lock-settings)
- (let* ((query (nth 0 setting))
- (enable (nth 1 setting))
- (override (nth 3 setting))
- (language (treesit-query-language query)))
-
- ;; Use deterministic way to decide whether to turn on "fast
- ;; mode". (See bug#60691, bug#60223.)
- (when (eq treesit--font-lock-fast-mode 'unspecified)
- (pcase-let ((`(,max-depth ,max-width)
- (treesit-subtree-stat
- (treesit-buffer-root-node language))))
- (if (or (> max-depth 100) (> max-width 4000))
- (setq treesit--font-lock-fast-mode t)
- (setq treesit--font-lock-fast-mode nil))))
-
- (when-let* ((root (treesit-buffer-root-node language))
- (nodes (if (eq t treesit--font-lock-fast-mode)
- (treesit--children-covering-range-recurse
- root start end (* 4 jit-lock-chunk-size))
- (list (treesit-buffer-root-node language))))
- ;; Only activate if ENABLE flag is t.
- (activate (eq t enable)))
- (ignore activate)
-
- ;; Query each node.
- (dolist (sub-node nodes)
- (let* ((delta-start (car treesit--font-lock-query-expand-range))
- (delta-end (cdr treesit--font-lock-query-expand-range))
- (captures (treesit-query-capture
- sub-node query
- (max (- start delta-start) (point-min))
- (min (+ end delta-end) (point-max)))))
-
- ;; For each captured node, fontify that node.
- (with-silent-modifications
- (dolist (capture captures)
- (let* ((face (car capture))
- (node (cdr capture))
- (node-start (treesit-node-start node))
- (node-end (treesit-node-end node)))
-
- ;; If node is not in the region, take them out. See
- ;; comment #3 above for more detail.
- (if (and (facep face)
- (or (>= start node-end) (>= node-start end)))
- (when (or loudly treesit--font-lock-verbose)
- (message "Captured node %s(%s-%s) but it is outside of fontifing region" node node-start node-end))
-
- (cond
- ((facep face)
- (treesit-fontify-with-override
- (max node-start start) (min node-end end)
- face override))
- ((functionp face)
- (funcall face node override start end)))
-
- ;; Don't raise an error if FACE is neither a face nor
- ;; a function. This is to allow intermediate capture
- ;; names used for #match and #eq.
- (when (or loudly treesit--font-lock-verbose)
- (message "Fontifying text from %d to %d, Face: %s, Node: %s"
- (max node-start start) (min node-end end)
- face (treesit-node-type node))))))))))))
+ (let* ((local-parsers (treesit-local-parsers-on start end))
+ (global-parsers (treesit-parser-list))
+ (root-nodes
+ (mapcar #'treesit-parser-root-node
+ (append local-parsers global-parsers))))
+ (dolist (setting treesit-font-lock-settings)
+ (let* ((query (nth 0 setting))
+ (enable (nth 1 setting))
+ (override (nth 3 setting))
+ (language (treesit-query-language query))
+ (root-nodes (cl-remove-if-not
+ (lambda (node)
+ (eq (treesit-node-language node) language))
+ root-nodes)))
+
+ ;; Use deterministic way to decide whether to turn on "fast
+ ;; mode". (See bug#60691, bug#60223.)
+ (when (eq treesit--font-lock-fast-mode 'unspecified)
+ (pcase-let ((`(,max-depth ,max-width)
+ (treesit-subtree-stat
+ (treesit-buffer-root-node language))))
+ (if (or (> max-depth 100) (> max-width 4000))
+ (setq treesit--font-lock-fast-mode t)
+ (setq treesit--font-lock-fast-mode nil))))
+
+ ;; Only activate if ENABLE flag is t.
+ (when-let
+ ((activate (eq t enable))
+ (nodes (if (eq t treesit--font-lock-fast-mode)
+ (mapcan
+ (lambda (node)
+ (treesit--children-covering-range-recurse
+ node start end (* 4 jit-lock-chunk-size)))
+ root-nodes)
+ root-nodes)))
+ (ignore activate)
+
+ ;; Query each node.
+ (dolist (sub-node nodes)
+ (treesit--font-lock-fontify-region-1
+ sub-node query start end override loudly))))))
`(jit-lock-bounds ,start . ,end))
+(defun treesit--font-lock-fontify-region-1 (node query start end override loudly)
+ "Fontify the region between START and END by querying NODE with QUERY.
+
+If OVERRIDE is non-nil, override existing faces, if LOUDLY is
+non-nil, print debugging information."
+ (let* ((delta-start (car treesit--font-lock-query-expand-range))
+ (delta-end (cdr treesit--font-lock-query-expand-range))
+ (captures (treesit-query-capture
+ node query
+ (max (- start delta-start) (point-min))
+ (min (+ end delta-end) (point-max)))))
+
+ ;; For each captured node, fontify that node.
+ (with-silent-modifications
+ (dolist (capture captures)
+ (let* ((face (car capture))
+ (node (cdr capture))
+ (node-start (treesit-node-start node))
+ (node-end (treesit-node-end node)))
+
+ ;; If node is not in the region, take them out. See
+ ;; comment #3 above for more detail.
+ (if (and (facep face)
+ (or (>= start node-end) (>= node-start end)))
+ (when (or loudly treesit--font-lock-verbose)
+ (message "Captured node %s(%s-%s) but it is outside of fontifing region" node node-start node-end))
+
+ (cond
+ ((facep face)
+ (treesit-fontify-with-override
+ (max node-start start) (min node-end end)
+ face override))
+ ((functionp face)
+ (funcall face node override start end)))
+
+ ;; Don't raise an error if FACE is neither a face nor
+ ;; a function. This is to allow intermediate capture
+ ;; names used for #match and #eq.
+ (when (or loudly treesit--font-lock-verbose)
+ (message "Fontifying text from %d to %d, Face: %s, Node: %s"
+ (max node-start start) (min node-end end)
+ face (treesit-node-type node)))))))))
+
(defun treesit--font-lock-notifier (ranges parser)
"Ensures updated parts of the parse-tree are refontified.
RANGES is a list of (BEG . END) ranges, PARSER is the tree-sitter
@@ -1129,7 +1382,15 @@ as comment due to incomplete parse tree."
;; `treesit-update-ranges' will force the host language's parser to
;; reparse and set correct ranges for embedded parsers. Then
;; `treesit-parser-root-node' will force those parsers to reparse.
- (treesit-update-ranges)
+ (let ((len (+ (* (window-body-height) (window-body-width)) 800)))
+ ;; FIXME: As a temporary fix, this prevents Emacs from updating
+ ;; every single local parsers in the buffer every time there's an
+ ;; edit. Moving forward, we need some way to properly track the
+ ;; regions which need update on parser ranges, like what jit-lock
+ ;; and syntax-ppss does.
+ (treesit-update-ranges
+ (max (point-min) (- (point) len))
+ (min (point-max) (+ (point) len))))
;; Force repase on _all_ the parsers might not be necessary, but
;; this is probably the most robust way.
(dolist (parser (treesit-parser-list))
@@ -1557,9 +1818,18 @@ Return (ANCHOR . OFFSET). This function is used by
(forward-line 0)
(skip-chars-forward " \t")
(point)))
+ (local-parsers (treesit-local-parsers-at bol nil t))
(smallest-node
- (cond ((null (treesit-parser-list)) nil)
- ((eq 1 (length (treesit-parser-list)))
+ (cond ((car local-parsers)
+ (let ((local-parser (caar local-parsers))
+ (host-parser (cdar local-parsers)))
+ (if (eq (treesit-node-start
+ (treesit-parser-root-node local-parser))
+ bol)
+ (treesit-node-at bol host-parser)
+ (treesit-node-at bol local-parser))))
+ ((null (treesit-parser-list)) nil)
+ ((eq 1 (length (treesit-parser-list nil nil t)))
(treesit-node-at bol))
((treesit-language-at bol)
(treesit-node-at bol (treesit-language-at bol)))
@@ -1740,12 +2010,28 @@ OFFSET."
(message "No matched rule"))
(cons nil nil))))))
-(defun treesit-check-indent (mode)
- "Check current buffer's indentation against a major mode MODE.
+(defun treesit--read-major-mode ()
+ "Read a major mode using completion.
+Helper function to use in the `interactive' spec of `treesit-check-indent'."
+ (let* ((default (and (symbolp major-mode) (symbol-name major-mode)))
+ (mode
+ (completing-read
+ (format-prompt "Target major mode" default)
+ obarray
+ (lambda (sym)
+ (and (string-suffix-p "-mode" (symbol-name sym))
+ (not (or (memq sym minor-mode-list)
+ (string-suffix-p "-minor-mode"
+ (symbol-name sym))))))
+ nil nil nil default nil)))
+ (cond
+ ((equal mode "nil") nil)
+ ((and (stringp mode) (fboundp (intern mode))) (intern mode))
+ (t mode))))
-Pop up a diff buffer showing the difference. Correct
-indentation (target) is in green, current indentation is in red."
- (interactive "CTarget major mode: ")
+(defun treesit-check-indent (mode)
+ "Compare the current buffer with how major mode MODE would indent it."
+ (interactive (list (treesit--read-major-mode)))
(let ((source-buf (current-buffer)))
(with-temp-buffer
(insert-buffer-substring source-buf)
@@ -1838,6 +2124,73 @@ BACKWARD and ALL are the same as in `treesit-search-forward'."
(goto-char current-pos)))
node))
+(make-obsolete 'treesit-sexp-type-regexp
+ "`treesit-sexp-type-regexp' will be removed soon, use `treesit-thing-settings' instead." "30.1")
+
+(defvar-local treesit-sexp-type-regexp nil
+ "A regexp that matches the node type of sexp nodes.
+
+A sexp node is a node that is bigger than punctuation, and
+delimits medium sized statements in the source code. It is,
+however, smaller in scope than sentences. This is used by
+`treesit-forward-sexp' and friends.")
+
+(defun treesit-forward-sexp (&optional arg)
+ "Tree-sitter implementation for `forward-sexp-function'.
+
+ARG is described in the docstring of `forward-sexp-function'. If
+there are no further sexps to move across, signal `scan-error'
+like `forward-sexp' does. If point is already at top-level,
+return nil without moving point."
+ (interactive "^p")
+ (let ((arg (or arg 1))
+ (pred (or treesit-sexp-type-regexp 'sexp)))
+ (or (if (> arg 0)
+ (treesit-end-of-thing pred (abs arg) 'restricted)
+ (treesit-beginning-of-thing pred (abs arg) 'restricted))
+ ;; If we couldn't move, we should signal an error and report
+ ;; the obstacle, like `forward-sexp' does. If we couldn't
+ ;; find a parent, we simply return nil without moving point,
+ ;; then functions like `up-list' will signal "at top level".
+ (when-let* ((parent (treesit--thing-at (point) pred t))
+ (boundary (if (> arg 0)
+ (treesit-node-child parent -1)
+ (treesit-node-child parent 0))))
+ (signal 'scan-error (list "No more sexp to move across"
+ (treesit-node-start boundary)
+ (treesit-node-end boundary)))))))
+
+(defun treesit-transpose-sexps (&optional arg)
+ "Tree-sitter `transpose-sexps' function.
+ARG is the same as in `transpose-sexps'.
+
+Locate the node closest to POINT, and transpose that node with
+its sibling node ARG nodes away.
+
+Return a pair of positions as described by
+`transpose-sexps-function' for use in `transpose-subr' and
+friends."
+ ;; First arrive at the right level at where the node at point is
+ ;; considered a sexp. If sexp isn't defined, or we can't find any
+ ;; node that's a sexp, use the node at point.
+ (let* ((node (or (treesit-thing-at-point 'sexp 'nested)
+ (treesit-node-at (point))))
+ (parent (treesit-node-parent node))
+ (child (treesit-node-child parent 0 t)))
+ (named-let loop ((prev child)
+ (next (treesit-node-next-sibling child t)))
+ (when (and prev next)
+ (if (< (point) (treesit-node-end next))
+ (if (= arg -1)
+ (cons (treesit-node-start prev)
+ (treesit-node-end prev))
+ (when-let ((n (treesit-node-child
+ parent (+ arg (treesit-node-index prev t)) t)))
+ (cons (treesit-node-end n)
+ (treesit-node-start n))))
+ (loop (treesit-node-next-sibling prev t)
+ (treesit-node-next-sibling next t)))))))
+
;;; Navigation, defun, things
;;
;; Emacs lets you define "things" by a regexp that matches the type of
@@ -1853,7 +2206,8 @@ BACKWARD and ALL are the same as in `treesit-search-forward'."
;; - treesit-thing/defun-at-point
;;
;; And more generic functions like:
-;; - treesit--things-around
+;; - treesit--thing-prev/next
+;; - treesit--thing-at
;; - treesit--top-level-thing
;; - treesit--navigate-thing
;;
@@ -1862,11 +2216,13 @@ BACKWARD and ALL are the same as in `treesit-search-forward'."
;;
;; TODO: I'm not entirely sure how would this go, so I only documented
;; the "defun" functions and didn't document any "thing" functions.
-;; We should also document `treesit-block-type-regexp' and support it
-;; in major modes if we can meaningfully integrate hideshow: I tried
-;; and failed, we need SomeOne that understands hideshow to look at
-;; it. (BTW, hideshow should use its own
-;; `treesit-hideshow-block-type-regexp'.)
+;; We should also document `treesit-thing-settings'.
+
+;; TODO: Integration with thing-at-point: once our thing interface is
+;; stable.
+;;
+;; TODO: Integration with hideshow: I tried and failed, we need
+;; SomeOne that understands hideshow to look at it.
(defvar-local treesit-defun-type-regexp nil
"A regexp that matches the node type of defun nodes.
@@ -1880,11 +2236,8 @@ for invalid node.
This is used by `treesit-beginning-of-defun' and friends.")
-(defvar-local treesit-block-type-regexp nil
- "Like `treesit-defun-type-regexp', but for blocks.")
-
(defvar-local treesit-defun-tactic 'nested
- "Determines how does Emacs treat nested defuns.
+ "Determines how Emacs treats nested defuns.
If the value is `top-level', Emacs only moves across top-level
defuns, if the value is `nested', Emacs recognizes nested defuns.")
@@ -1900,52 +2253,73 @@ If the value is nil, no skipping is performed.")
(defvar-local treesit-defun-name-function nil
"A function that is called with a node and returns its defun name or nil.
If the node is a defun node, return the defun name, e.g., the
-function name of a function. If the node is not a defun node, or
-the defun node doesn't have a name, or the node is nil, return
-nil.")
+name of a function. If the node is not a defun node, or the
+defun node doesn't have a name, or the node is nil, return nil.")
(defvar-local treesit-add-log-defun-delimiter "."
"The delimiter used to connect several defun names.
This is used in `treesit-add-log-current-defun'.")
-(defsubst treesit--thing-unpack-pattern (pattern)
- "Unpack PATTERN in the shape of `treesit-defun-type-regexp'.
+(defun treesit-thing-definition (thing language)
+ "Return the predicate for THING if it's defined for LANGUAGE.
+A thing is considered defined if it has an entry in
+`treesit-thing-settings'.
-Basically,
+If LANGUAGE is nil, return the first definition for THING in
+`treesit-thing-settings'."
+ (if language
+ (car (alist-get thing (alist-get language
+ treesit-thing-settings)))
+ (car (alist-get thing (mapcan (lambda (entry)
+ (copy-tree (cdr entry)))
+ treesit-thing-settings)))))
- (unpack REGEXP) = (REGEXP . nil)
- (unpack (REGEXP . PRED)) = (REGEXP . PRED)"
- (if (consp pattern)
- pattern
- (cons pattern nil)))
+(defalias 'treesit-thing-defined-p #'treesit-thing-definition
+ "Return non-nil if THING is defined.")
-(defun treesit-beginning-of-thing (pattern &optional arg)
+(defun treesit-beginning-of-thing (thing &optional arg tactic)
"Like `beginning-of-defun', but generalized into things.
-PATTERN is like `treesit-defun-type-regexp', ARG
-is the same as in `beginning-of-defun'.
+THING can be a thing defined in `treesit-thing-settings', which see,
+or a predicate. ARG is the same as in `beginning-of-defun'.
+
+TACTIC determines how does this function move between things. It
+can be `nested', `top-level', `restricted', or nil. `nested'
+means normal nested navigation: try to move to siblings first,
+and if there aren't enough siblings, move to the parent and its
+siblings. `top-level' means only consider top-level things, and
+nested things are ignored. `restricted' means movement is
+restricted inside the thing that encloses POS (i.e., parent),
+should there be one. If omitted, TACTIC is considered to be
+`nested'.
Return non-nil if successfully moved, nil otherwise."
(pcase-let* ((arg (or arg 1))
- (`(,regexp . ,pred) (treesit--thing-unpack-pattern
- pattern))
(dest (treesit--navigate-thing
- (point) (- arg) 'beg regexp pred)))
+ (point) (- arg) 'beg thing tactic)))
(when dest
(goto-char dest))))
-(defun treesit-end-of-thing (pattern &optional arg)
+(defun treesit-end-of-thing (thing &optional arg tactic)
"Like `end-of-defun', but generalized into things.
-PATTERN is like `treesit-defun-type-regexp', ARG is the same as
-in `end-of-defun'.
+THING can be a thing defined in `treesit-thing-settings', which
+see, or a predicate. ARG is the same as in `end-of-defun'.
+
+TACTIC determines how does this function move between things. It
+can be `nested', `top-level', `restricted', or nil. `nested'
+means normal nested navigation: try to move to siblings first,
+and if there aren't enough siblings, move to the parent and its
+siblings. `top-level' means only consider top-level things, and
+nested things are ignored. `restricted' means movement is
+restricted inside the thing that encloses POS (i.e., parent),
+should there be one. If omitted, TACTIC is considered to be
+`nested'.
Return non-nil if successfully moved, nil otherwise."
(pcase-let* ((arg (or arg 1))
- (`(,regexp . ,pred) (treesit--thing-unpack-pattern
- pattern))
(dest (treesit--navigate-thing
- (point) arg 'end regexp pred)))
+ (point) arg 'end thing tactic)))
(when dest
(goto-char dest))))
@@ -1959,18 +2333,21 @@ If search is successful, return t, otherwise return nil.
This is a tree-sitter equivalent of `beginning-of-defun'.
Behavior of this function depends on `treesit-defun-type-regexp'
-and `treesit-defun-skipper'."
+and `treesit-defun-skipper'. If `treesit-defun-type-regexp' is
+not set, Emacs also looks for definition of defun in
+`treesit-thing-settings'."
(interactive "^p")
(or (not (eq this-command 'treesit-beginning-of-defun))
(eq last-command 'treesit-beginning-of-defun)
(and transient-mark-mode mark-active)
(push-mark))
(let ((orig-point (point))
- (success nil))
+ (success nil)
+ (pred (or treesit-defun-type-regexp 'defun)))
(catch 'done
(dotimes (_ 2)
- (when (treesit-beginning-of-thing treesit-defun-type-regexp arg)
+ (when (treesit-beginning-of-thing pred arg treesit-defun-tactic)
(when treesit-defun-skipper
(funcall treesit-defun-skipper)
(setq success t)))
@@ -1991,9 +2368,12 @@ Negative argument -N means move back to Nth preceding end of defun.
This is a tree-sitter equivalent of `end-of-defun'. Behavior of
this function depends on `treesit-defun-type-regexp' and
-`treesit-defun-skipper'."
+`treesit-defun-skipper'. If `treesit-defun-type-regexp' is not
+set, Emacs also looks for definition of defun in
+`treesit-thing-settings'."
(interactive "^p\nd")
- (let ((orig-point (point)))
+ (let ((orig-point (point))
+ (pred (or treesit-defun-type-regexp 'defun)))
(if (or (null arg) (= arg 0)) (setq arg 1))
(or (not (eq this-command 'treesit-end-of-defun))
(eq last-command 'treesit-end-of-defun)
@@ -2002,7 +2382,7 @@ this function depends on `treesit-defun-type-regexp' and
(catch 'done
(dotimes (_ 2) ; Not making progress is better than infloop.
- (when (treesit-end-of-thing treesit-defun-type-regexp arg)
+ (when (treesit-end-of-thing pred arg treesit-defun-tactic)
(when treesit-defun-skipper
(funcall treesit-defun-skipper)))
@@ -2014,6 +2394,46 @@ this function depends on `treesit-defun-type-regexp' and
(throw 'done nil)
(setq arg (if (> arg 0) (1+ arg) (1- arg))))))))
+(make-obsolete 'treesit-text-type-regexp
+ "`treesit-text-type-regexp' will be removed soon, use `treesit-thing-settings' instead." "30.1")
+
+(defvar-local treesit-text-type-regexp "\\`comment\\'"
+ "A regexp that matches the node type of textual nodes.
+
+A textual node is a node that is not normal code, such as
+comments and multiline string literals. For example,
+\"(line|block)_comment\" in the case of a comment, or
+\"text_block\" in the case of a string. This is used by
+`prog-fill-reindent-defun' and friends.")
+
+(make-obsolete 'treesit-sentence-type-regexp
+ "`treesit-sentence-type-regexp' will be removed soon, use `treesit-thing-settings' instead." "30.1")
+
+(defvar-local treesit-sentence-type-regexp nil
+ "A regexp that matches the node type of sentence nodes.
+
+A sentence node is a node that is bigger than a sexp, and
+delimits larger statements in the source code. It is, however,
+smaller in scope than defuns. This is used by
+`treesit-forward-sentence' and friends.")
+
+(defun treesit-forward-sentence (&optional arg)
+ "Tree-sitter `forward-sentence-function' implementation.
+
+ARG is the same as in `forward-sentence'.
+
+If point is inside a text environment, go forward a prose
+sentence using `forward-sentence-default-function'. If point is
+inside code, go forward a source code sentence.
+
+What constitutes as text and source code sentence is determined
+by `text' and `sentence' in `treesit-thing-settings'."
+ (if (treesit-node-match-p (treesit-node-at (point)) 'text t)
+ (funcall #'forward-sentence-default-function arg)
+ (funcall
+ (if (> arg 0) #'treesit-end-of-thing #'treesit-beginning-of-thing)
+ 'sentence (abs arg))))
+
(defun treesit-default-defun-skipper ()
"Skips spaces after navigating a defun.
This function tries to move to the beginning of a line, either by
@@ -2031,18 +2451,9 @@ the current line if the beginning of the defun is indented."
(line-beginning-position))
(beginning-of-line))))
-;; prev-sibling:
-;; 1. end-of-node before pos
-;; 2. highest such node
-;;
-;; next-sibling:
-;; 1. beg-of-node after pos
-;; 2. highest such node
-;;
-;; parent:
-;; 1. node covers pos
-;; 2. smallest such node
-(defun treesit--things-around (pos regexp &optional pred)
+(make-obsolete 'treesit--things-around
+ "`treesit--things-around' will be removed soon, use `treesit--thing-prev', `treesit--thing-next', `treesit--thing-at' instead." "30.1")
+(defun treesit--things-around (pos thing)
"Return the previous, next, and parent thing around POS.
Return a list of (PREV NEXT PARENT), where PREV and NEXT are
@@ -2050,7 +2461,8 @@ previous and next sibling things around POS, and PARENT is the
parent thing surrounding POS. All of three could be nil if no
sound things exists.
-REGEXP and PRED are the same as in `treesit-thing-at-point'."
+THING should be a thing defined in `treesit-thing-settings',
+which see; it can also be a predicate."
(let* ((node (treesit-node-at pos))
(result (list nil nil nil)))
;; 1. Find previous and next sibling defuns.
@@ -2073,9 +2485,7 @@ REGEXP and PRED are the same as in `treesit-thing-at-point'."
when node
do (let ((cursor node)
(iter-pred (lambda (node)
- (and (string-match-p
- regexp (treesit-node-type node))
- (or (null pred) (funcall pred node))
+ (and (treesit-node-match-p node thing t)
(funcall pos-pred node)))))
;; Find the node just before/after POS to start searching.
(save-excursion
@@ -2089,13 +2499,11 @@ REGEXP and PRED are the same as in `treesit-thing-at-point'."
(setf (nth idx result)
(treesit-node-top-level cursor iter-pred t))
(setq cursor (treesit-search-forward
- cursor regexp backward backward)))))
+ cursor thing backward backward)))))
;; 2. Find the parent defun.
(let ((cursor (or (nth 0 result) (nth 1 result) node))
(iter-pred (lambda (node)
- (and (string-match-p
- regexp (treesit-node-type node))
- (or (null pred) (funcall pred node))
+ (and (treesit-node-match-p node thing t)
(not (treesit-node-eq node (nth 0 result)))
(not (treesit-node-eq node (nth 1 result)))
(< (treesit-node-start node)
@@ -2105,14 +2513,76 @@ REGEXP and PRED are the same as in `treesit-thing-at-point'."
(treesit-parent-until cursor iter-pred)))
result))
-(defun treesit--top-level-thing (node regexp &optional pred)
- "Return the top-level parent thing of NODE.
-REGEXP and PRED are the same as in `treesit-thing-at-point'."
- (treesit-node-top-level
- node (lambda (node)
- (and (string-match-p regexp (treesit-node-type node))
- (or (null pred) (funcall pred node))))
- t))
+(defun treesit--thing-sibling (pos thing prev)
+ "Return the next or previous THING at POS.
+
+If PREV is non-nil, return the previous THING. It's guaranteed
+that returned previous sibling's end <= POS, and returned next
+sibling's beginning >= POS.
+
+Return nil if no THING can be found. THING should be a thing
+defined in `treesit-thing-settings', or a predicate as described
+in `treesit-thing-settings'."
+ (let* ((cursor (treesit-node-at pos))
+ (pos-pred (if prev
+ (lambda (n) (<= (treesit-node-end n) pos))
+ (lambda (n) (>= (treesit-node-start n) pos))))
+ (iter-pred (lambda (node)
+ (and (treesit-node-match-p node thing t)
+ (funcall pos-pred node))))
+ (sibling nil))
+ (when cursor
+ ;; Find the node just before/after POS to start searching.
+ (save-excursion
+ (while (and cursor (not (funcall pos-pred cursor)))
+ (setq cursor (treesit-search-forward-goto
+ cursor "" prev prev t))))
+ ;; Keep searching until we run out of candidates or found a
+ ;; return value.
+ (while (and cursor
+ (funcall pos-pred cursor)
+ (null sibling))
+ (setq sibling (treesit-node-top-level cursor iter-pred t))
+ (setq cursor (treesit-search-forward cursor thing prev prev)))
+ sibling)))
+
+(defun treesit--thing-prev (pos thing)
+ "Return the previous THING at POS.
+
+The returned node, if non-nil, must be before POS, i.e., its end
+<= POS.
+
+THING should be a thing defined in `treesit-thing-settings', or a
+predicate as described in `treesit-thing-settings'."
+ (treesit--thing-sibling pos thing t))
+
+(defun treesit--thing-next (pos thing)
+ "Return the next THING at POS.
+
+The returned node, if non-nil, must be after POS, i.e., its
+start >= POS.
+
+THING should be a thing defined in `treesit-thing-settings', or a
+predicate as described in `treesit-thing-settings'."
+ (treesit--thing-sibling pos thing nil))
+
+(defun treesit--thing-at (pos thing &optional strict)
+ "Return the smallest THING enclosing POS.
+
+The returned node, if non-nil, must enclose POS, i.e., its start
+<= POS, its end > POS. If STRICT is non-nil, the returned node's
+start must < POS rather than <= POS.
+
+THING should be a thing defined in `treesit-thing-settings', or
+it can be a predicate described in `treesit-thing-settings'."
+ (let* ((cursor (treesit-node-at pos))
+ (iter-pred (lambda (node)
+ (and (treesit-node-match-p node thing t)
+ (if strict
+ (< (treesit-node-start node) pos)
+ (<= (treesit-node-start node) pos))
+ (< pos (treesit-node-end node))))))
+ (treesit-parent-until cursor iter-pred t)))
;; The basic idea for nested defun navigation is that we first try to
;; move across sibling defuns in the same level, if no more siblings
@@ -2141,7 +2611,7 @@ REGEXP and PRED are the same as in `treesit-thing-at-point'."
;; -> Obviously we don't want to go to parent's end, instead, we
;; want to go to parent's prev-sibling's end. Again, we recurse
;; in the function to do that.
-(defun treesit--navigate-thing (pos arg side regexp &optional pred recursing)
+(defun treesit--navigate-thing (pos arg side thing &optional tactic recursing)
"Navigate thing ARG steps from POS.
If ARG is positive, move forward that many steps, if negative,
@@ -2152,7 +2622,18 @@ This function doesn't actually move point, it just returns the
position it would move to. If there aren't enough things to move
across, return nil.
-REGEXP and PRED are the same as in `treesit-thing-at-point'.
+THING can be a regexp, a predicate function, and more. See
+`treesit-thing-settings' for details.
+
+TACTIC determines how does this function move between things. It
+can be `nested', `top-level', `restricted', or nil. `nested'
+means normal nested navigation: try to move to siblings first,
+and if there aren't enough siblings, move to the parent and its
+siblings. `top-level' means only consider top-level things, and
+nested things are ignored. `restricted' means movement is
+restricted inside the thing that encloses POS (i.e., parent),
+should there be one. If omitted, TACTIC is considered to be
+`nested'.
RECURSING is an internal parameter, if non-nil, it means this
function is called recursively."
@@ -2169,101 +2650,108 @@ function is called recursively."
dest)))))
(catch 'term
(while (> counter 0)
- (pcase-let
- ((`(,prev ,next ,parent)
- (treesit--things-around pos regexp pred)))
+ (let ((prev (treesit--thing-prev pos thing))
+ (next (treesit--thing-next pos thing))
+ (parent (treesit--thing-at pos thing t)))
+ (when (and parent prev
+ (not (treesit-node-enclosed-p prev parent)))
+ (setq prev nil))
+ (when (and parent next
+ (not (treesit-node-enclosed-p next parent)))
+ (setq next nil))
;; When PARENT is nil, nested and top-level are the same, if
;; there is a PARENT, make PARENT to be the top-level parent
;; and pretend there is no nested PREV and NEXT.
- (when (and (eq treesit-defun-tactic 'top-level)
+ (when (and (eq tactic 'top-level)
parent)
- (setq parent (treesit--top-level-thing
- parent regexp pred)
+ (setq parent (treesit-node-top-level parent thing t)
prev nil
next nil))
- ;; Move...
- (if (> arg 0)
- ;; ...forward.
- (if (and (eq side 'beg)
- ;; Should we skip the defun (recurse)?
- (cond (next (and (not recursing) ; [1] (see below)
- (eq pos (funcall advance next))))
- (parent t))) ; [2]
- ;; Special case: go to next beg-of-defun, but point
- ;; is already on beg-of-defun. Set POS to the end
- ;; of next-sib/parent defun, and run one more step.
- ;; If there is a next-sib defun, we only need to
- ;; recurse once, so we don't need to recurse if we
- ;; are already recursing [1]. If there is no
- ;; next-sib but a parent, keep stepping out
- ;; (recursing) until we got out of the parents until
- ;; (1) there is a next sibling defun, or (2) no more
- ;; parents [2].
- ;;
- ;; If point on beg-of-defun but we are already
- ;; recurring, that doesn't count as special case,
- ;; because we have already made progress (by moving
- ;; the end of next before recurring.)
+ ;; If TACTIC is `restricted', the implementation is simple.
+ ;; In principle we don't go to parent's beg/end for
+ ;; `restricted' tactic, but if the parent is a "leaf thing"
+ ;; (doesn't have any child "thing" inside it), then we can
+ ;; move to the beg/end of it (bug#68899).
+ (if (eq tactic 'restricted)
+ (setq pos (funcall
+ advance
+ (cond ((and (null next) (null prev)) parent)
+ ((> arg 0) next)
+ (t prev))))
+ ;; For `nested', it's a bit more work:
+ ;; Move...
+ (if (> arg 0)
+ ;; ...forward.
+ (if (and (eq side 'beg)
+ ;; Should we skip the defun (recurse)?
+ (cond (next (and (not recursing) ; [1] (see below)
+ (eq pos (funcall advance next))))
+ (parent t))) ; [2]
+ ;; Special case: go to next beg-of-defun, but point
+ ;; is already on beg-of-defun. Set POS to the end
+ ;; of next-sib/parent defun, and run one more step.
+ ;; If there is a next-sib defun, we only need to
+ ;; recurse once, so we don't need to recurse if we
+ ;; are already recursing [1]. If there is no
+ ;; next-sib but a parent, keep stepping out
+ ;; (recursing) until we got out of the parents until
+ ;; (1) there is a next sibling defun, or (2) no more
+ ;; parents [2].
+ ;;
+ ;; If point on beg-of-defun but we are already
+ ;; recurring, that doesn't count as special case,
+ ;; because we have already made progress (by moving
+ ;; the end of next before recurring.)
+ (setq pos (or (treesit--navigate-thing
+ (treesit-node-end (or next parent))
+ 1 'beg thing tactic t)
+ (throw 'term nil)))
+ ;; Normal case.
+ (setq pos (funcall advance (or next parent))))
+ ;; ...backward.
+ (if (and (eq side 'end)
+ (cond (prev (and (not recursing)
+ (eq pos (funcall advance prev))))
+ (parent t)))
+ ;; Special case: go to prev end-of-defun.
(setq pos (or (treesit--navigate-thing
- (treesit-node-end (or next parent))
- 1 'beg regexp pred t)
+ (treesit-node-start (or prev parent))
+ -1 'end thing tactic t)
(throw 'term nil)))
;; Normal case.
- (setq pos (funcall advance (or next parent))))
- ;; ...backward.
- (if (and (eq side 'end)
- (cond (prev (and (not recursing)
- (eq pos (funcall advance prev))))
- (parent t)))
- ;; Special case: go to prev end-of-defun.
- (setq pos (or (treesit--navigate-thing
- (treesit-node-start (or prev parent))
- -1 'end regexp pred t)
- (throw 'term nil)))
- ;; Normal case.
- (setq pos (funcall advance (or prev parent)))))
+ (setq pos (funcall advance (or prev parent))))))
;; A successful step! Decrement counter.
(cl-decf counter))))
;; Counter equal to 0 means we successfully stepped ARG steps.
(if (eq counter 0) pos nil)))
;; TODO: In corporate into thing-at-point.
-(defun treesit-thing-at-point (pattern tactic)
- "Return the thing node at point or nil if none is found.
-
-\"Thing\" is defined by PATTERN, which can be either a string
-REGEXP or a cons cell (REGEXP . PRED): if a node's type matches
-REGEXP, it is a thing. The \"thing\" could be further restricted
-by PRED: if non-nil, PRED should be a function that takes a node
-and returns t if the node is a \"thing\", and nil if not.
-
-Return the top-level defun if TACTIC is `top-level', return the
-immediate parent thing if TACTIC is `nested'."
- (pcase-let* ((`(,regexp . ,pred)
- (treesit--thing-unpack-pattern pattern))
- (`(,_ ,next ,parent)
- (treesit--things-around (point) regexp pred))
- ;; If point is at the beginning of a thing, we
- ;; prioritize that thing over the parent in nested
- ;; mode.
- (node (or (and (eq (treesit-node-start next) (point))
- next)
- parent)))
+(defun treesit-thing-at-point (thing tactic)
+ "Return the THING at point, or nil if none is found.
+
+THING can be a symbol, a regexp, a predicate function, and more;
+see `treesit-thing-settings' for details.
+
+Return the top-level THING if TACTIC is `top-level'; return the
+smallest enclosing THING as POS if TACTIC is `nested'."
+
+ (let ((node (treesit--thing-at (point) thing)))
(if (eq tactic 'top-level)
- (treesit--top-level-thing node regexp pred)
+ (treesit-node-top-level node thing t)
node)))
(defun treesit-defun-at-point ()
- "Return the defun node at point or nil if none is found.
+ "Return the defun node at point, or nil if none is found.
-Respects `treesit-defun-tactic': return the top-level defun if it
-is `top-level', return the immediate parent defun if it is
-`nested'.
+Respects `treesit-defun-tactic': returns the top-level defun if it
+is `top-level', otherwise return the immediate parent defun if it
+is `nested'.
-Return nil if `treesit-defun-type-regexp' is not set."
- (when treesit-defun-type-regexp
+Return nil if `treesit-defun-type-regexp' isn't set and `defun'
+isn't defined in `treesit-thing-settings'."
+ (when (or treesit-defun-type-regexp (treesit-thing-defined-p 'defun))
(treesit-thing-at-point
- treesit-defun-type-regexp treesit-defun-tactic)))
+ (or treesit-defun-type-regexp 'defun) treesit-defun-tactic)))
(defun treesit-defun-name (node)
"Return the defun name of NODE.
@@ -2379,6 +2867,71 @@ ENTRY. MARKER marks the start of each tree-sitter node."
index))))
treesit-simple-imenu-settings)))
+;;; Outline minor mode
+
+(defvar-local treesit-outline-predicate nil
+ "Predicate used to find outline headings in the syntax tree.
+The predicate can be a function, a regexp matching node type,
+and more; see docstring of `treesit-thing-settings'.
+It matches the nodes located on lines with outline headings.
+Intended to be set by a major mode. When nil, the predicate
+is constructed from the value of `treesit-simple-imenu-settings'
+when a major mode sets it.")
+
+(defun treesit-outline-predicate--from-imenu (node)
+ ;; Return an outline searching predicate created from Imenu.
+ ;; Return the value suitable to set `treesit-outline-predicate'.
+ ;; Create this predicate from the value `treesit-simple-imenu-settings'
+ ;; that major modes set to find Imenu entries. The assumption here
+ ;; is that the positions of Imenu entries most of the time coincide
+ ;; with the lines of outline headings. When this assumption fails,
+ ;; you can directly set a proper value to `treesit-outline-predicate'.
+ (seq-some
+ (lambda (setting)
+ (and (string-match-p (nth 1 setting) (treesit-node-type node))
+ (or (null (nth 2 setting))
+ (funcall (nth 2 setting) node))))
+ treesit-simple-imenu-settings))
+
+(defun treesit-outline-search (&optional bound move backward looking-at)
+ "Search for the next outline heading in the syntax tree.
+See the descriptions of arguments in `outline-search-function'."
+ (if looking-at
+ (when-let* ((node (or (treesit--thing-at (pos-eol) treesit-outline-predicate)
+ (treesit--thing-at (pos-bol) treesit-outline-predicate)))
+ (start (treesit-node-start node)))
+ (eq (pos-bol) (save-excursion (goto-char start) (pos-bol))))
+
+ (let* ((pos
+ ;; When function wants to find the current outline, point
+ ;; is at the beginning of the current line. When it wants
+ ;; to find the next outline, point is at the second column.
+ (if (eq (point) (pos-bol))
+ (if (bobp) (point) (1- (point)))
+ (pos-eol)))
+ (found (treesit--navigate-thing pos (if backward -1 1) 'beg
+ treesit-outline-predicate)))
+ (if found
+ (if (or (not bound) (if backward (>= found bound) (<= found bound)))
+ (progn
+ (goto-char found)
+ (goto-char (pos-bol))
+ (set-match-data (list (point) (pos-eol)))
+ t)
+ (when move (goto-char bound))
+ nil)
+ (when move (goto-char (or bound (if backward (point-min) (point-max)))))
+ nil))))
+
+(defun treesit-outline-level ()
+ "Return the depth of the current outline heading."
+ (let* ((node (treesit-node-at (point) nil t))
+ (level (if (treesit-node-match-p node treesit-outline-predicate)
+ 1 0)))
+ (while (setq node (treesit-parent-until node treesit-outline-predicate))
+ (setq level (1+ level)))
+ (if (zerop level) 1 level)))
+
;;; Activating tree-sitter
(defun treesit-ready-p (language &optional quiet)
@@ -2436,14 +2989,18 @@ and enable `font-lock-mode'.
If `treesit-simple-indent-rules' is non-nil, set up indentation.
-If `treesit-defun-type-regexp' is non-nil, set up
-`beginning-of-defun-function' and `end-of-defun-function'.
+If `treesit-defun-type-regexp' is non-nil or `defun' is defined
+in `treesit-thing-settings', set up `beginning-of-defun-function'
+and `end-of-defun-function'.
If `treesit-defun-name-function' is non-nil, set up
`add-log-current-defun'.
If `treesit-simple-imenu-settings' is non-nil, set up Imenu.
+If `sexp', `sentence' are defined in `treesit-thing-settings',
+enable tree-sitter navigation commands for them.
+
Make sure necessary parsers are created for the current buffer
before calling this function."
;; Font-lock.
@@ -2473,7 +3030,8 @@ before calling this function."
(setq-local indent-line-function #'treesit-indent)
(setq-local indent-region-function #'treesit-indent-region))
;; Navigation.
- (when treesit-defun-type-regexp
+ (when (or treesit-defun-type-regexp
+ (treesit-thing-defined-p 'defun nil))
(keymap-set (current-local-map) "<remap> <beginning-of-defun>"
#'treesit-beginning-of-defun)
(keymap-set (current-local-map) "<remap> <end-of-defun>"
@@ -2491,10 +3049,35 @@ before calling this function."
(when treesit-defun-name-function
(setq-local add-log-current-defun-function
#'treesit-add-log-current-defun))
+
+ (when (treesit-thing-defined-p 'sexp nil)
+ (setq-local forward-sexp-function #'treesit-forward-sexp)
+ (setq-local transpose-sexps-function #'treesit-transpose-sexps))
+
+ (when (treesit-thing-defined-p 'sentence nil)
+ (setq-local forward-sentence-function #'treesit-forward-sentence))
+
;; Imenu.
(when treesit-simple-imenu-settings
(setq-local imenu-create-index-function
- #'treesit-simple-imenu)))
+ #'treesit-simple-imenu))
+
+ ;; Outline minor mode.
+ (when (and (or treesit-outline-predicate treesit-simple-imenu-settings)
+ (not (seq-some #'local-variable-p
+ '(outline-search-function
+ outline-regexp outline-level))))
+ (unless treesit-outline-predicate
+ (setq treesit-outline-predicate
+ #'treesit-outline-predicate--from-imenu))
+ (setq-local outline-search-function #'treesit-outline-search
+ outline-level #'treesit-outline-level))
+
+ ;; Remove existing local parsers.
+ (dolist (ov (overlays-in (point-min) (point-max)))
+ (when-let ((parser (overlay-get ov 'treesit-parser)))
+ (treesit-parser-delete parser)
+ (delete-overlay ov))))
;;; Debugging
@@ -2740,7 +3323,6 @@ in the region."
(defun treesit--explorer-jump (button)
"Mark the original text corresponding to BUTTON."
- (interactive)
(when (and (derived-mode-p 'treesit--explorer-tree-mode)
(buffer-live-p treesit--explorer-source-buffer))
(with-current-buffer treesit--explorer-source-buffer
@@ -2891,10 +3473,12 @@ the text in the active region is highlighted in the explorer
window."
:lighter " TSexplore"
(if treesit-explore-mode
- (let ((language (intern (completing-read
- "Language: "
- (mapcar #'treesit-parser-language
- (treesit-parser-list))))))
+ (let ((language
+ (intern (completing-read
+ "Language: "
+ (cl-remove-duplicates
+ (mapcar #'treesit-parser-language
+ (treesit-parser-list nil nil t)))))))
(if (not (treesit-language-available-p language))
(user-error "Cannot find tree-sitter grammar for %s: %s"
language (cdr (treesit-language-available-p
@@ -2940,7 +3524,8 @@ The value should be an alist where each element has the form
(LANG . (URL REVISION SOURCE-DIR CC C++))
Only LANG and URL are mandatory. LANG is the language symbol.
-URL is the Git repository URL for the grammar.
+URL is the URL of the grammar's Git repository or a directory
+where the repository has been cloned.
REVISION is the Git tag or branch of the desired version,
defaulting to the latest default branch.
@@ -2986,8 +3571,11 @@ See `treesit-language-source-alist' for details."
(buffer-local-value 'url-http-response-status buffer)
200)))))
+(defvar treesit--install-language-grammar-out-dir-history nil
+ "History for OUT-DIR for `treesit-install-language-grammar'.")
+
;;;###autoload
-(defun treesit-install-language-grammar (lang)
+(defun treesit-install-language-grammar (lang &optional out-dir)
"Build and install the tree-sitter language grammar library for LANG.
Interactively, if `treesit-language-source-alist' doesn't already
@@ -3001,20 +3589,41 @@ and the linker to be installed and on PATH. It also requires that the
recipe for LANG exists in `treesit-language-source-alist'.
See `exec-path' for the current path where Emacs looks for
-executable programs, such as the C/C++ compiler and linker."
+executable programs, such as the C/C++ compiler and linker.
+
+Interactively, prompt for the directory in which to install the
+compiled grammar files. Non-interactively, use OUT-DIR; if it's
+nil, the grammar is installed to the standard location, the
+\"tree-sitter\" directory under `user-emacs-directory'."
(interactive (list (intern
(completing-read
"Language: "
- (mapcar #'car treesit-language-source-alist)))))
+ (mapcar #'car treesit-language-source-alist)))
+ 'interactive))
(when-let ((recipe
(or (assoc lang treesit-language-source-alist)
- (treesit--install-language-grammar-build-recipe
- lang))))
+ (if (eq out-dir 'interactive)
+ (treesit--install-language-grammar-build-recipe
+ lang)
+ (signal 'treesit-error `("Cannot find recipe for this language" ,lang)))))
+ (default-out-dir
+ (or (car treesit--install-language-grammar-out-dir-history)
+ (locate-user-emacs-file "tree-sitter")))
+ (out-dir
+ (if (eq out-dir 'interactive)
+ (read-string
+ (format "Install to (default: %s): "
+ default-out-dir)
+ nil
+ 'treesit--install-language-grammar-out-dir-history
+ default-out-dir)
+ ;; When called non-interactively, OUT-DIR should
+ ;; default to DEFAULT-OUT-DIR.
+ (or out-dir default-out-dir))))
(condition-case err
(progn
(apply #'treesit--install-language-grammar-1
- ;; The nil is OUT-DIR.
- (cons nil recipe))
+ (cons out-dir recipe))
;; Check that the installed language grammar is loadable.
(pcase-let ((`(,available . ,err)
@@ -3050,6 +3659,26 @@ content as signal data, and erase buffer afterwards."
(buffer-string)))
(erase-buffer)))
+(defun treesit--git-checkout-branch (repo-dir revision)
+ "Checkout REVISION in a repo located in REPO-DIR."
+ (treesit--call-process-signal
+ "git" nil t nil "-C" repo-dir "checkout" revision))
+
+(defun treesit--git-clone-repo (url revision workdir)
+ "Clone repo pointed by URL at commit REVISION to WORKDIR.
+
+REVISION may be nil, in which case the cloned repo will be at its
+default branch."
+ (message "Cloning repository")
+ ;; git clone xxx --depth 1 --quiet [-b yyy] workdir
+ (if revision
+ (treesit--call-process-signal
+ "git" nil t nil "clone" url "--depth" "1" "--quiet"
+ "-b" revision workdir)
+ (treesit--call-process-signal
+ "git" nil t nil "clone" url "--depth" "1" "--quiet"
+ workdir)))
+
(defun treesit--install-language-grammar-1
(out-dir lang url &optional revision source-dir cc c++)
"Install and compile a tree-sitter language grammar library.
@@ -3063,8 +3692,12 @@ For LANG, URL, REVISION, SOURCE-DIR, GRAMMAR-DIR, CC, C++, see
`treesit-language-source-alist'. If anything goes wrong, this
function signals an error."
(let* ((lang (symbol-name lang))
+ (maybe-repo-dir (expand-file-name url))
+ (url-is-dir (file-accessible-directory-p maybe-repo-dir))
(default-directory (make-temp-file "treesit-workdir" t))
- (workdir (expand-file-name "repo"))
+ (workdir (if url-is-dir
+ maybe-repo-dir
+ (expand-file-name "repo")))
(source-dir (expand-file-name (or source-dir "src") workdir))
(cc (or cc (seq-find #'executable-find '("cc" "gcc" "c99"))
;; If no C compiler found, just use cc and let
@@ -3079,15 +3712,10 @@ function signals an error."
(lib-name (concat "libtree-sitter-" lang soext)))
(unwind-protect
(with-temp-buffer
- (message "Cloning repository")
- ;; git clone xxx --depth 1 --quiet [-b yyy] workdir
- (if revision
- (treesit--call-process-signal
- "git" nil t nil "clone" url "--depth" "1" "--quiet"
- "-b" revision workdir)
- (treesit--call-process-signal
- "git" nil t nil "clone" url "--depth" "1" "--quiet"
- workdir))
+ (if url-is-dir
+ (when revision
+ (treesit--git-checkout-branch workdir revision))
+ (treesit--git-clone-repo url revision workdir))
;; We need to go into the source directory because some
;; header files use relative path (#include "../xxx").
;; cd "${sourcedir}"
@@ -3108,11 +3736,17 @@ function signals an error."
(apply #'treesit--call-process-signal
(if (file-exists-p "scanner.cc") c++ cc)
nil t nil
- `("-fPIC" "-shared"
- ,@(directory-files
- default-directory nil
- (rx bos (+ anychar) ".o" eos))
- "-o" ,lib-name))
+ (if (eq system-type 'cygwin)
+ `("-shared" "-Wl,-dynamicbase"
+ ,@(directory-files
+ default-directory nil
+ (rx bos (+ anychar) ".o" eos))
+ "-o" ,lib-name)
+ `("-fPIC" "-shared"
+ ,@(directory-files
+ default-directory nil
+ (rx bos (+ anychar) ".o" eos))
+ "-o" ,lib-name)))
;; Copy out.
(unless (file-exists-p out-dir)
(make-directory out-dir t))
@@ -3128,7 +3762,9 @@ function signals an error."
;; Ignore errors, in case the old version is still used.
(ignore-errors (delete-file old-fname)))
(message "Library installed to %s/%s" out-dir lib-name))
- (when (file-exists-p workdir)
+ ;; Remove workdir if it's not a repo owned by user and we
+ ;; managed to create it in the first place.
+ (when (and (not url-is-dir) (file-exists-p workdir))
(delete-directory workdir t)))))
;;; Etc
@@ -3142,7 +3778,7 @@ function signals an error."
(with-temp-buffer
(insert-file-contents (find-library-name "treesit"))
(cl-remove-if
- (lambda (name) (string-match "treesit--" name))
+ (lambda (name) (string-search "treesit--" name))
(cl-sort
(save-excursion
(goto-char (point-min))
@@ -3191,7 +3827,6 @@ function signals an error."
(define-short-documentation-group treesit
-
"Parsers"
(treesit-parser-create
:no-eval (treesit-parser-create 'c)
@@ -3241,6 +3876,9 @@ function signals an error."
"Retrieving a node from another node"
+ (treesit-node-get
+ :no-eval (treesit-node-get node '((parent 1) (sibling 1) (text)))
+ :eg-result-string "#<treesit-node (declaration) in 1-11>")
(treesit-node-parent
:no-eval (treesit-node-parent node)
:eg-result-string "#<treesit-node (declaration) in 1-11>")
@@ -3334,7 +3972,9 @@ function signals an error."
(treesit-node-check
:no-eval (treesit-node-check node 'named)
:eg-result t)
-
+ (treesit-node-enclosed-p
+ :no-eval (treesit-node-enclosed-p node1 node2)
+ :no-eval (treesit-node-enclosed-p node1 '(12 . 18)))
(treesit-node-field-name-for-child
:no-eval (treesit-node-field-name-for-child node)
diff --git a/lisp/type-break.el b/lisp/type-break.el
index be6ac27ae73..182f4656b16 100644
--- a/lisp/type-break.el
+++ b/lisp/type-break.el
@@ -586,13 +586,13 @@ INTERVAL is the full length of an interval (defaults to TIME)."
(type-break-check-post-command-hook)
(type-break-cancel-schedule)
(type-break-time-warning-schedule time 'reset)
- (type-break-run-at-time (max 1 time) nil 'type-break-alarm)
+ (run-at-time (max 1 time) nil 'type-break-alarm)
(setq type-break-time-next-break
(type-break-time-sum start (or interval time))))
(defun type-break-cancel-schedule ()
(type-break-cancel-time-warning-schedule)
- (type-break-cancel-function-timers 'type-break-alarm)
+ (cancel-function-timers 'type-break-alarm)
(setq type-break-alarm-p nil)
(setq type-break-time-next-break nil))
@@ -623,7 +623,7 @@ INTERVAL is the full length of an interval (defaults to TIME)."
;(let (type-break-current-time-warning-interval)
; (type-break-cancel-time-warning-schedule))
- (type-break-run-at-time (max 1 time) nil 'type-break-time-warning-alarm)
+ (run-at-time (max 1 time) nil 'type-break-time-warning-alarm)
(cond
(resetp
@@ -633,7 +633,7 @@ INTERVAL is the full length of an interval (defaults to TIME)."
(setq type-break-warning-countdown-string-type "seconds"))))))))
(defun type-break-cancel-time-warning-schedule ()
- (type-break-cancel-function-timers 'type-break-time-warning-alarm)
+ (cancel-function-timers 'type-break-time-warning-alarm)
(remove-hook 'type-break-post-command-hook 'type-break-time-warning)
(setq type-break-current-time-warning-interval
type-break-time-warning-intervals)
@@ -986,21 +986,6 @@ With optional non-nil ALL, force redisplay of all mode-lines."
(add-hook 'post-command-hook 'type-break-run-tb-post-command-hook 'append))
-;;; Timer wrapper functions
-;;
-;; These shield type-break from variations in the interval timer packages
-;; for different versions of Emacs.
-
-(defun type-break-run-at-time (time repeat function)
- (condition-case nil (or (require 'timer) (require 'itimer)) (error nil))
- (run-at-time time repeat function))
-
-(defvar timer-dont-exit)
-(defun type-break-cancel-function-timers (function)
- (let ((timer-dont-exit t))
- (cancel-function-timers function)))
-
-
;;; Demo wrappers
(defun type-break-catch-up-event ()
@@ -1146,6 +1131,8 @@ With optional non-nil ALL, force redisplay of all mode-lines."
(kill-buffer buffer-name))))))
(define-obsolete-function-alias 'timep 'type-break-timep "29.1")
+(define-obsolete-function-alias 'type-break-run-at-time #'run-at-time "30.1")
+(define-obsolete-function-alias 'type-break-cancel-function-timers #'cancel-function-timers "30.1")
(provide 'type-break)
diff --git a/lisp/uniquify.el b/lisp/uniquify.el
index 326a58a66a0..7085089dbe3 100644
--- a/lisp/uniquify.el
+++ b/lisp/uniquify.el
@@ -168,14 +168,40 @@ This can be handy when you have deep parallel hierarchies."
That means that when `buffer-file-name' is set to nil, `list-buffers-directory'
contains the name of the directory which the buffer is visiting.")
+(defcustom uniquify-dirname-transform #'identity
+ "Function to transform buffer's directory name when uniquifying buffer's name.
+
+When `uniquify-buffer-name-style' is non-nil, Emacs makes buffer
+names unique by adding components of the buffer's directory name
+until the resulting name is unique. This function is used to
+transform the buffer's directory name during this uniquifying
+process, allowing the unique buffer name to include strings
+from sources other than the buffer's directory. The default is
+`identity', so the unmodified buffer's directory name is used for
+uniquifying.
+
+This function is called with the buffer's directory name and
+should return a string which names a file (that does not need to
+actually exist in the filesystem); the components of this file
+name will then be used to uniquify the buffer's name.
+
+To include components from the `project-name' of the buffer, set
+this variable to `project-uniquify-dirname-transform'."
+ :type `(choice (function-item :tag "Use directory name as-is" identity)
+ (function-item :tag "Include project name in directory name"
+ ,#'project-uniquify-dirname-transform)
+ function)
+ :version "30.1"
+ :group 'uniquify)
+
;;; Utilities
;; uniquify-fix-list data structure
(cl-defstruct (uniquify-item
(:constructor nil) (:copier nil)
(:constructor uniquify-make-item
- (base dirname buffer &optional proposed original-dirname)))
- base dirname buffer proposed original-dirname)
+ (base dirname buffer &optional proposed)))
+ base dirname buffer proposed)
;; Internal variables used free
(defvar uniquify-possibly-resolvable nil)
@@ -209,9 +235,10 @@ this rationalization."
;; this buffer.
(with-current-buffer newbuf (setq uniquify-managed nil))
(when dirname
- (setq dirname (expand-file-name (directory-file-name dirname)))
+ (setq dirname (funcall uniquify-dirname-transform
+ (expand-file-name (directory-file-name dirname))))
(let ((fix-list (list (uniquify-make-item base dirname newbuf
- nil dirname)))
+ nil)))
items)
(dolist (buffer (buffer-list))
(when (and (not (and uniquify-ignore-buffers-re
@@ -268,10 +295,11 @@ in `uniquify-list-buffers-directory-modes', otherwise returns nil."
(if (memq major-mode uniquify-list-buffers-directory-modes)
list-buffers-directory))))
(when filename
- (directory-file-name
- (file-name-directory
- (expand-file-name
- (directory-file-name filename))))))))
+ (funcall uniquify-dirname-transform
+ (directory-file-name
+ (file-name-directory
+ (expand-file-name
+ (directory-file-name filename)))))))))
(defun uniquify-rerationalize-w/o-cb (fix-list)
"Re-rationalize the buffers in FIX-LIST, but ignoring `current-buffer'."
@@ -292,8 +320,7 @@ in `uniquify-list-buffers-directory-modes', otherwise returns nil."
(setf (uniquify-item-proposed item)
(uniquify-get-proposed-name (uniquify-item-base item)
(uniquify-item-dirname item)
- nil
- (uniquify-item-original-dirname item)))
+ nil))
(setq uniquify-managed fix-list)))
;; Strip any shared last directory names of the dirname.
(when (and (cdr fix-list) uniquify-strip-common-suffix)
@@ -316,8 +343,7 @@ in `uniquify-list-buffers-directory-modes', otherwise returns nil."
(uniquify-item-dirname item))))
(and f (directory-file-name f)))
(uniquify-item-buffer item)
- (uniquify-item-proposed item)
- (uniquify-item-original-dirname item))
+ (uniquify-item-proposed item))
fix-list)))))
;; If uniquify-min-dir-content is 0, this will end up just
;; passing fix-list to uniquify-rationalize-conflicting-sublist.
@@ -345,21 +371,10 @@ in `uniquify-list-buffers-directory-modes', otherwise returns nil."
(uniquify-rationalize-conflicting-sublist conflicting-sublist
old-proposed depth)))
-(defun uniquify-get-proposed-name (base dirname &optional depth
- original-dirname)
+(defun uniquify-get-proposed-name (base dirname &optional depth)
(unless depth (setq depth uniquify-min-dir-content))
(cl-assert (equal (directory-file-name dirname) dirname)) ;No trailing slash.
- ;; Distinguish directories by adding extra separator.
- (if (and uniquify-trailing-separator-p
- (file-directory-p (expand-file-name base original-dirname))
- (not (string-equal base "")))
- (cond ((eq uniquify-buffer-name-style 'forward)
- (setq base (file-name-as-directory base)))
- ;; (setq base (concat base "/")))
- ((eq uniquify-buffer-name-style 'reverse)
- (setq base (concat (or uniquify-separator "\\") base)))))
-
(let ((extra-string nil)
(n depth))
(while (and (> n 0) dirname)
@@ -421,8 +436,7 @@ in `uniquify-list-buffers-directory-modes', otherwise returns nil."
(uniquify-get-proposed-name
(uniquify-item-base item)
(uniquify-item-dirname item)
- depth
- (uniquify-item-original-dirname item))))
+ depth)))
(uniquify-rationalize-a-list conf-list depth))
(unless (string= old-name "")
(uniquify-rename-buffer (car conf-list) old-name)))))
@@ -492,15 +506,14 @@ For use on `kill-buffer-hook'."
;; (advice-add 'create-file-buffer :around #'uniquify--create-file-buffer-advice)
-(defun uniquify--create-file-buffer-advice (buf filename)
+(defun uniquify--create-file-buffer-advice (buf filename basename)
;; BEWARE: This is called directly from `files.el'!
"Uniquify buffer names with parts of directory name."
(when uniquify-buffer-name-style
- (let ((filename (expand-file-name (directory-file-name filename))))
- (uniquify-rationalize-file-buffer-names
- (file-name-nondirectory filename)
- (file-name-directory filename)
- buf))))
+ (uniquify-rationalize-file-buffer-names
+ basename
+ (file-name-directory (expand-file-name (directory-file-name filename)))
+ buf)))
(defun uniquify-unload-function ()
"Unload the uniquify library."
diff --git a/lisp/url/url-cache.el b/lisp/url/url-cache.el
index 0d27321cc47..ce6de2b3ee4 100644
--- a/lisp/url/url-cache.el
+++ b/lisp/url/url-cache.el
@@ -70,7 +70,7 @@ FILE can be created or overwritten."
;;;###autoload
(defun url-store-in-cache (&optional buff)
"Store buffer BUFF in the cache."
- (with-current-buffer (get-buffer (or buff (current-buffer)))
+ (with-current-buffer (or buff (current-buffer))
(let ((fname (url-cache-create-filename (url-view-url t))))
(if (url-cache-prepare fname)
(let ((coding-system-for-write 'binary))
diff --git a/lisp/url/url-cid.el b/lisp/url/url-cid.el
index 17a0318e652..d80037f8fe9 100644
--- a/lisp/url/url-cid.el
+++ b/lisp/url/url-cid.el
@@ -1,6 +1,6 @@
;;; url-cid.el --- Content-ID URL loader -*- lexical-binding: t; -*-
-;; Copyright (C) 1998-1999, 2004-2024 Free Software Foundation, Inc.
+;; Copyright (C) 1998-2024 Free Software Foundation, Inc.
;; Keywords: comm, data, processes
@@ -52,12 +52,7 @@
;;;###autoload
(defun url-cid (url)
- (cond
- ((fboundp 'mm-get-content-id)
- ;; Using Pterodactyl Gnus or later
- (with-current-buffer (generate-new-buffer " *url-cid*")
- (url-cid-gnus (url-filename url))))
- (t
- (message "Unable to handle CID URL: %s" url))))
+ (with-current-buffer (generate-new-buffer " *url-cid*")
+ (url-cid-gnus (url-filename url))))
;;; url-cid.el ends here
diff --git a/lisp/url/url-domsuf.el b/lisp/url/url-domsuf.el
index af301cc6745..b720f73efd7 100644
--- a/lisp/url/url-domsuf.el
+++ b/lisp/url/url-domsuf.el
@@ -30,14 +30,26 @@
(defvar url-domsuf-domains nil)
+(defun url-domsuf--public-suffix-file ()
+ "Look for and return a file name for a recent \"public_suffix_list.dat\".
+Emacs ships with a copy of this file, but some systems might have
+a newer version available. Look for it in some standard
+locations, and if a newer file was found, then return that."
+ (car (sort
+ (seq-filter
+ #'file-readable-p
+ (list (expand-file-name "publicsuffix.txt.gz" data-directory)
+ (expand-file-name "publicsuffix.txt" data-directory)
+ ;; Debian and Fedora
+ "/usr/share/publicsuffix/public_suffix_list.dat"
+ ;; FreeBSD port
+ "/usr/local/share/public_suffix_list/public_suffix_list.dat"))
+ #'file-newer-than-file-p)))
+
(defun url-domsuf-parse-file ()
(with-temp-buffer
(with-auto-compression-mode
- (insert-file-contents
- (let* ((suffixfile (expand-file-name "publicsuffix.txt" data-directory))
- (compressed-file (concat suffixfile ".gz")))
- (or (and (file-readable-p compressed-file) compressed-file)
- suffixfile))))
+ (insert-file-contents (url-domsuf--public-suffix-file)))
(let ((domains nil)
domain exception)
(while (not (eobp))
diff --git a/lisp/url/url-future.el b/lisp/url/url-future.el
index 67f34d8dd36..790da8b5d6d 100644
--- a/lisp/url/url-future.el
+++ b/lisp/url/url-future.el
@@ -53,7 +53,7 @@
(define-inline url-future-errored-p (url-future)
(inline-quote (eq (url-future-status ,url-future) 'error)))
-(define-inline url-future-cancelled-p (url-future)
+(define-inline url-future-canceled-p (url-future)
(inline-quote (eq (url-future-status ,url-future) 'cancel)))
(defun url-future-finish (url-future &optional status)
@@ -96,5 +96,8 @@
(signal 'error 'url-future-already-done)
(url-future-finish url-future 'cancel)))
+(define-obsolete-function-alias 'url-future-cancelled-p
+ #'url-future-canceled-p "30.1")
+
(provide 'url-future)
;;; url-future.el ends here
diff --git a/lisp/url/url-gw.el b/lisp/url/url-gw.el
index 22cf342a3ab..62be70827fa 100644
--- a/lisp/url/url-gw.el
+++ b/lisp/url/url-gw.el
@@ -97,21 +97,27 @@ This list will be executed as a command after logging in via telnet."
(defcustom url-gateway-broken-resolution nil
"Whether to use nslookup to resolve hostnames.
-This should be used when your version of Emacs cannot correctly use DNS,
-but your machine can. This usually happens if you are running a statically
-linked Emacs under SunOS 4.x."
+This should be used when your version of Emacs cannot correctly
+use DNS, but your machine can.
+
+This used to happen on SunOS 4.x and Ultrix when Emacs was linked
+statically, and also was not linked with the resolver libraries.
+Those systems are no longer supported by Emacs."
:type 'boolean
:group 'url-gateway)
+(make-obsolete-variable 'url-gateway-broken-resolution nil "30.1")
(defcustom url-gateway-nslookup-program "nslookup"
"If non-nil then a string naming nslookup program."
:type '(choice (const :tag "None" :value nil) string)
:group 'url-gateway)
+(make-obsolete-variable 'url-gateway-nslookup-program nil "30.1")
;; Stolen from ange-ftp
;;;###autoload
(defun url-gateway-nslookup-host (host)
"Attempt to resolve the given HOST using nslookup if possible."
+ (declare (obsolete nil "30.1"))
(interactive "sHost: ")
(if url-gateway-nslookup-program
(let ((proc (start-process " *nslookup*" " *nslookup*"
@@ -237,37 +243,37 @@ overriding the value of `url-gateway-method'."
;; If the user told us to do DNS for them, do it.
(if url-gateway-broken-resolution
- (setq host (url-gateway-nslookup-host host)))
-
- (condition-case nil
- ;; This is a clean way to ensure the new process inherits the
- ;; right coding systems in both Emacs and XEmacs.
- (let ((coding-system-for-read 'binary)
- (coding-system-for-write 'binary))
- (setq conn (pcase gw-method
- ((or 'tls 'ssl 'native)
- (if (eq gw-method 'native)
- (setq gw-method 'plain))
- (open-network-stream
- name buffer host service
- :type gw-method
- ;; Use non-blocking socket if we can.
- :nowait (and (featurep 'make-network-process)
- (url-asynchronous url-current-object)
- '(:nowait t))))
- ('socks
- (socks-open-network-stream name buffer host service))
- ('telnet
- (url-open-telnet name buffer host service))
- ('rlogin
- (unless url-gw-rlogin-obsolete-warned-once
- (lwarn 'url :error "Setting `url-gateway-method' to `rlogin' is obsolete")
- (setq url-gw-rlogin-obsolete-warned-once t))
- (with-suppressed-warnings ((obsolete url-open-rlogin))
- (url-open-rlogin name buffer host service)))
- (_
- (error "Bad setting of url-gateway-method: %s"
- url-gateway-method))))))
+ (with-suppressed-warnings ((obsolete url-gateway-nslookup-host))
+ (setq host (url-gateway-nslookup-host host))))
+
+ ;; This is a clean way to ensure the new process inherits the
+ ;; right coding systems in both Emacs and XEmacs.
+ (let ((coding-system-for-read 'binary)
+ (coding-system-for-write 'binary))
+ (setq conn (pcase gw-method
+ ((or 'tls 'ssl 'native)
+ (if (eq gw-method 'native)
+ (setq gw-method 'plain))
+ (open-network-stream
+ name buffer host service
+ :type gw-method
+ ;; Use non-blocking socket if we can.
+ :nowait (and (featurep 'make-network-process)
+ (url-asynchronous url-current-object)
+ '(:nowait t))))
+ ('socks
+ (socks-open-network-stream name buffer host service))
+ ('telnet
+ (url-open-telnet name buffer host service))
+ ('rlogin
+ (unless url-gw-rlogin-obsolete-warned-once
+ (lwarn 'url :error "Setting `url-gateway-method' to `rlogin' is obsolete")
+ (setq url-gw-rlogin-obsolete-warned-once t))
+ (with-suppressed-warnings ((obsolete url-open-rlogin))
+ (url-open-rlogin name buffer host service)))
+ (_
+ (error "Bad setting of url-gateway-method: %s"
+ url-gateway-method)))))
conn)))
(provide 'url-gw)
diff --git a/lisp/url/url-http.el b/lisp/url/url-http.el
index f6054366329..184c1278072 100644
--- a/lisp/url/url-http.el
+++ b/lisp/url/url-http.el
@@ -358,10 +358,6 @@ Use `url-http-referer' as the Referer-header (subject to `url-privacy-level')."
(url-port url-http-target-url))
(format "Host: %s\r\n"
(url-http--encode-string (puny-encode-domain host))))
- ;; Who its from
- (if url-personal-mail-address
- (concat
- "From: " url-personal-mail-address "\r\n"))
;; Encodings we understand
(if (or url-mime-encoding-string
;; MS-Windows loads zlib dynamically, so recheck
@@ -431,7 +427,7 @@ Use `url-http-referer' as the Referer-header (subject to `url-privacy-level')."
;; Parsing routines
(defun url-http-clean-headers ()
- "Remove trailing \r from header lines.
+ "Remove trailing \\r from header lines.
This allows us to use `mail-fetch-field', etc.
Return the number of characters removed."
(let ((end (marker-position url-http-end-of-headers)))
diff --git a/lisp/url/url-irc.el b/lisp/url/url-irc.el
index f540d0281e8..e6499bce31e 100644
--- a/lisp/url/url-irc.el
+++ b/lisp/url/url-irc.el
@@ -83,18 +83,20 @@ PASSWORD - What password to use.
(pass (url-password url))
(user (url-user url))
(chan (url-filename url))
- (type (url-type url))
- (compatp (eql 5 (cdr (func-arity url-irc-function)))))
+ (type (url-type url)))
(if (url-target url)
(setq chan (concat chan "#" (url-target url))))
(if (string-match "^/" chan)
(setq chan (substring chan 1 nil)))
(if (= (length chan) 0)
(setq chan nil))
- (when compatp
- (lwarn 'url :error "Obsolete value for `url-irc-function'"))
- (apply url-irc-function
- host port chan user pass (unless compatp (list type)))
+ (condition-case nil
+ (funcall url-irc-function host port chan user pass type)
+ (wrong-number-of-arguments
+ (display-warning 'url
+ (concat "Incompatible value for `url-irc-function'."
+ " Likely not expecting a 6th (SCHEME) arg."))
+ (funcall url-irc-function host port chan user pass)))
nil))
;;;; ircs://
diff --git a/lisp/url/url-ldap.el b/lisp/url/url-ldap.el
index 1bdd5099637..6aaea606c27 100644
--- a/lisp/url/url-ldap.el
+++ b/lisp/url/url-ldap.el
@@ -1,6 +1,6 @@
;;; url-ldap.el --- LDAP Uniform Resource Locator retrieval code -*- lexical-binding: t; -*-
-;; Copyright (C) 1998-1999, 2004-2024 Free Software Foundation, Inc.
+;; Copyright (C) 1998-2024 Free Software Foundation, Inc.
;; Keywords: comm, data, processes
@@ -92,12 +92,8 @@
"'>" dn "</a>"))
(defun url-ldap-certificate-formatter (data)
- (condition-case ()
- (require 'ssl)
- (error nil))
- (let ((vals (if (fboundp 'ssl-certificate-information)
- (ssl-certificate-information data)
- (tls-certificate-information data))))
+ ;; FIXME: tls.el is obsolete.
+ (let ((vals (tls-certificate-information data)))
(if (not vals)
"<b>Unable to parse certificate</b>"
(concat "<table border=0>\n"
diff --git a/lisp/url/url-mailto.el b/lisp/url/url-mailto.el
index 47dd0c6e1a5..50293ab3f05 100644
--- a/lisp/url/url-mailto.el
+++ b/lisp/url/url-mailto.el
@@ -1,6 +1,6 @@
;;; url-mailto.el --- Mail Uniform Resource Locator retrieval code -*- lexical-binding: t; -*-
-;; Copyright (C) 1996-1999, 2004-2024 Free Software Foundation, Inc.
+;; Copyright (C) 1996-2024 Free Software Foundation, Inc.
;; Keywords: comm, data, processes
@@ -28,12 +28,7 @@
(require 'url-util)
;;;###autoload
-(defun url-mail (&rest args)
- (interactive "P")
- (if (fboundp 'message-mail)
- (apply 'message-mail args)
- (or (apply 'mail args)
- (error "Mail aborted"))))
+(defalias 'url-mail #'message-mail)
(defun url-mail-goto-field (field)
(if (not field)
@@ -57,8 +52,6 @@
(save-excursion
(insert "\n"))))))
-(declare-function mail-send-and-exit "sendmail")
-
;;;###autoload
(defun url-mailto (url)
"Handle the mailto: URL syntax."
@@ -111,8 +104,6 @@
;; (setq func (intern-soft (concat "mail-" (caar args))))
(insert (mapconcat 'identity (cdar args) ", ")))
(setq args (cdr args)))
- ;; (url-mail-goto-field "User-Agent")
-;; (insert url-package-name "/" url-package-version " URL/" url-version)
(if (not url-request-data)
(progn
(set-buffer-modified-p nil)
@@ -120,16 +111,16 @@
(url-mail-goto-field nil)
(url-mail-goto-field "subject")))
(if url-request-extra-headers
- (mapconcat
+ (mapc
(lambda (x)
(url-mail-goto-field (car x))
(insert (cdr x)))
- url-request-extra-headers ""))
+ url-request-extra-headers))
(goto-char (point-max))
(insert url-request-data)
;; It seems Microsoft-ish to send without warning.
- ;; Fixme: presumably this should depend on a privacy setting.
- (if (y-or-n-p "Send this auto-generated mail? ")
+ ;; FIXME: presumably this should depend on a privacy setting.
+ (if (y-or-n-p "Send this auto-generated mail?")
(let ((buffer (current-buffer)))
(cond ((eq url-mail-command 'compose-mail)
(funcall (get mail-user-agent 'sendfunc) nil))
diff --git a/lisp/url/url-privacy.el b/lisp/url/url-privacy.el
index bc55b073121..aa710588f49 100644
--- a/lisp/url/url-privacy.el
+++ b/lisp/url/url-privacy.el
@@ -59,16 +59,6 @@
('tty "TTY")
(_ nil)))))
- (setq url-personal-mail-address (or url-personal-mail-address
- user-mail-address
- (format "%s@%s" (user-real-login-name)
- (system-name))))
-
- (if (or (memq url-privacy-level '(paranoid high))
- (and (listp url-privacy-level)
- (memq 'email url-privacy-level)))
- (setq url-personal-mail-address nil))
-
(setq url-os-type
(cond
((or (eq url-privacy-level 'paranoid)
diff --git a/lisp/url/url-util.el b/lisp/url/url-util.el
index 28d1885387d..5f45b98c7a5 100644
--- a/lisp/url/url-util.el
+++ b/lisp/url/url-util.el
@@ -335,7 +335,7 @@ appropriate coding-system; see `decode-coding-string'."
str (substring str (match-end 0)))))
(concat tmp str)))
-(defconst url-unreserved-chars
+(defvar url-unreserved-chars
'(?a ?b ?c ?d ?e ?f ?g ?h ?i ?j ?k ?l ?m ?n ?o ?p ?q ?r ?s ?t ?u ?v ?w ?x ?y ?z
?A ?B ?C ?D ?E ?F ?G ?H ?I ?J ?K ?L ?M ?N ?O ?P ?Q ?R ?S ?T ?U ?V ?W ?X ?Y ?Z
?0 ?1 ?2 ?3 ?4 ?5 ?6 ?7 ?8 ?9
diff --git a/lisp/url/url-vars.el b/lisp/url/url-vars.el
index 29e0addbb6f..09b3019a553 100644
--- a/lisp/url/url-vars.el
+++ b/lisp/url/url-vars.el
@@ -90,6 +90,7 @@ This is what is sent to HTTP servers as the FROM field in an HTTP
request."
:type '(choice (const :tag "Unspecified" nil) string)
:group 'url)
+(make-obsolete-variable 'url-personal-mail-address nil "30.1")
(defcustom url-directory-index-file "index.html"
"The filename to look for when indexing a directory.
@@ -113,18 +114,22 @@ paranoid -- don't send anything
If a list, this should be a list of symbols of what NOT to send.
Valid symbols are:
-email -- the email address
+email -- the email address (in Emacs 29 or older)
os -- the operating system info
emacs -- the version of Emacs
lastloc -- the last location (see also `url-lastloc-privacy-level')
agent -- do not send the User-Agent string
cookies -- never accept HTTP cookies
+Emacs 30 and newer never includes the email address in the
+User-Agent string. If you expect to use older versions of Emacs,
+it is recommended to always customize this list to include `email'.
+
Samples:
(setq url-privacy-level \\='high)
(setq url-privacy-level \\='(email lastloc)) ;; equivalent to \\='high
- (setq url-privacy-level \\='(os))
+ (setq url-privacy-level \\='(email lastloc os emacs))
::NOTE::
This variable controls several other variables and is _NOT_ automatically
diff --git a/lisp/use-package/use-package-bind-key.el b/lisp/use-package/use-package-bind-key.el
index 92415153980..18c3f29cf34 100644
--- a/lisp/use-package/use-package-bind-key.el
+++ b/lisp/use-package/use-package-bind-key.el
@@ -4,7 +4,6 @@
;; Author: John Wiegley <johnw@newartisans.com>
;; Maintainer: John Wiegley <johnw@newartisans.com>
-;; Package: use-package
;; This file is part of GNU Emacs.
diff --git a/lisp/use-package/use-package-core.el b/lisp/use-package/use-package-core.el
index 3eef056b137..d9343e14839 100644
--- a/lisp/use-package/use-package-core.el
+++ b/lisp/use-package/use-package-core.el
@@ -4,7 +4,6 @@
;; Author: John Wiegley <johnw@newartisans.com>
;; Maintainer: John Wiegley <johnw@newartisans.com>
-;; Package: use-package
;; This file is part of GNU Emacs.
@@ -77,6 +76,7 @@
:functions
:preface
:if :when :unless
+ :vc
:no-require
:catch
:after
@@ -327,12 +327,15 @@ Must be set before loading `use-package'."
(set-default sym value))
:group 'use-package)
+;; Redundant in Emacs 26 or later, which already highlights macro names.
(defconst use-package-font-lock-keywords
'(("(\\(use-package\\)\\_>[ \t']*\\(\\(?:\\sw\\|\\s_\\)+\\)?"
(1 font-lock-keyword-face)
(2 font-lock-constant-face nil t))))
-
-(font-lock-add-keywords 'emacs-lisp-mode use-package-font-lock-keywords)
+(make-obsolete-variable 'use-package-font-lock-keywords
+ 'lisp-el-font-lock-keywords "30.1")
+(when (< emacs-major-version 26)
+ (font-lock-add-keywords 'emacs-lisp-mode use-package-font-lock-keywords))
(defcustom use-package-compute-statistics nil
"If non-nil, compute statistics concerned `use-package' declarations.
@@ -1036,15 +1039,23 @@ meaning:
Configured :config has been processed (the package is loaded!)
Initialized :init has been processed (load status unknown)
Prefaced :preface has been processed
- Declared the use-package declaration was seen"
+ Declared the use-package declaration was seen
+
+Customize the user option `use-package-compute-statistics' to
+enable gathering statistics."
(interactive)
- (with-current-buffer (get-buffer-create "*use-package statistics*")
- (setq tabulated-list-entries
- (mapcar #'use-package-statistics-convert
- (hash-table-keys use-package-statistics)))
- (use-package-statistics-mode)
- (tabulated-list-print)
- (display-buffer (current-buffer))))
+ (let ((statistics (hash-table-keys use-package-statistics)))
+ (unless statistics
+ (if use-package-compute-statistics
+ (user-error "No use-package statistics available")
+ (user-error (concat "Customize `use-package-compute-statistics'"
+ " to enable reporting"))))
+ (with-current-buffer (get-buffer-create "*use-package statistics*")
+ (setq tabulated-list-entries
+ (mapcar #'use-package-statistics-convert statistics))
+ (use-package-statistics-mode)
+ (tabulated-list-print)
+ (display-buffer (current-buffer)))))
(defvar use-package-statistics-status-order
'(("Declared" . 0)
@@ -1055,6 +1066,7 @@ meaning:
(define-derived-mode use-package-statistics-mode tabulated-list-mode
"use-package statistics"
"Show current statistics gathered about `use-package' declarations."
+ :interactive nil
(setq tabulated-list-format
;; The sum of column width is 80 characters:
[("Package" 25 t)
@@ -1152,7 +1164,8 @@ meaning:
#'use-package-normalize-paths))
(defun use-package-handler/:load-path (name _keyword arg rest state)
- (let ((body (use-package-process-keywords name rest state)))
+ (let ((body (use-package-process-keywords name rest
+ (plist-put state :load-path arg))))
(use-package-concat
(mapcar #'(lambda (path)
`(eval-and-compile (add-to-list 'load-path ,path)))
@@ -1578,6 +1591,110 @@ no keyword implies `:all'."
(when use-package-compute-statistics
`((use-package-statistics-gather :config ',name t))))))
+;;;; :vc
+
+(defun use-package-vc-install (arg &optional local-path)
+ "Install a package with `package-vc.el'.
+ARG is a list of the form (NAME OPTIONS REVISION), as returned by
+`use-package-normalize--vc-arg'. If LOCAL-PATH is non-nil, call
+`package-vc-install-from-checkout'; otherwise, indicating a
+remote host, call `package-vc-install' instead."
+ (pcase-let* ((`(,name ,opts ,rev) arg)
+ (spec (if opts (cons name opts) name)))
+ (unless (package-installed-p name)
+ (if local-path
+ (package-vc-install-from-checkout local-path (symbol-name name))
+ (package-vc-install spec rev)))))
+
+(defun use-package-handler/:vc (name _keyword arg rest state)
+ "Generate code to install package NAME, or do so directly.
+When the use-package declaration is part of a byte-compiled file,
+install the package during compilation; otherwise, add it to the
+macro expansion and wait until runtime. The remaining arguments
+are as follows:
+
+_KEYWORD is ignored.
+
+ARG is the normalized input to the `:vc' keyword, as returned by
+the `use-package-normalize/:vc' function.
+
+REST is a plist of other (following) keywords and their
+arguments, each having already been normalized by the respective
+function.
+
+STATE is a plist of any state that keywords processed before
+`:vc' (see `use-package-keywords') may have accumulated.
+
+Also see the Info node `(use-package) Creating an extension'."
+ (let ((body (use-package-process-keywords name rest state))
+ (local-path (car (plist-get state :load-path))))
+ ;; See `use-package-handler/:ensure' for an explanation.
+ (if (bound-and-true-p byte-compile-current-file)
+ (funcall #'use-package-vc-install arg local-path) ; compile time
+ (push `(use-package-vc-install ',arg ,local-path) body)) ; runtime
+ body))
+
+(defun use-package-normalize--vc-arg (arg)
+ "Normalize possible arguments to the `:vc' keyword.
+ARG is a cons-cell of approximately the form that
+`package-vc-selected-packages' accepts, plus an additional `:rev'
+keyword. If `:rev' is not given, it defaults to `:last-release'.
+
+Returns a list (NAME SPEC REV), where (NAME . SPEC) is compliant
+with `package-vc-selected-packages' and REV is a (possibly nil,
+indicating the latest commit) revision."
+ (cl-flet* ((ensure-string (s)
+ (if (and s (stringp s)) s (symbol-name s)))
+ (ensure-symbol (s)
+ (if (and s (stringp s)) (intern s) s))
+ (normalize (k v)
+ (pcase k
+ (:rev (cond ((or (eq v :last-release) (not v)) :last-release)
+ ((eq v :newest) nil)
+ (t (ensure-string v))))
+ (:vc-backend (ensure-symbol v))
+ (_ (ensure-string v)))))
+ (pcase-let ((valid-kws '(:url :branch :lisp-dir :main-file :vc-backend :rev))
+ (`(,name . ,opts) arg))
+ (if (stringp opts) ; (NAME . VERSION-STRING) ?
+ (list name opts)
+ ;; Error handling
+ (cl-loop for (k _) on opts by #'cddr
+ if (not (member k valid-kws))
+ do (use-package-error
+ (format "Keyword :vc received unknown argument: %s. Supported keywords are: %s"
+ k valid-kws)))
+ ;; Actual normalization
+ (list name
+ (cl-loop for (k v) on opts by #'cddr
+ if (not (eq k :rev))
+ nconc (list k (normalize k v)))
+ (normalize :rev (plist-get opts :rev)))))))
+
+(defun use-package-normalize/:vc (name _keyword args)
+ "Normalize possible arguments to the `:vc' keyword.
+NAME is the name of the `use-package' declaration, _KEYWORD is
+ignored, and ARGS it a list of arguments given to the `:vc'
+keyword, the cdr of which is ignored.
+
+See `use-package-normalize--vc-arg' for most of the actual
+normalization work. Also see the Info
+node `(use-package) Creating an extension'."
+ (let ((arg (car args)))
+ (pcase arg
+ ((or 'nil 't) (list name)) ; guess name
+ ((pred symbolp) (list arg)) ; use this name
+ ((pred stringp) (list name arg)) ; version string + guess name
+ ((pred plistp) ; plist + guess name
+ (use-package-normalize--vc-arg (cons name arg)))
+ (`(,(pred symbolp) . ,(or (pred plistp) ; plist/version string + name
+ (pred stringp)))
+ (use-package-normalize--vc-arg arg))
+ (_ (use-package-error "Unrecognized argument to :vc.\
+ The keyword wants an argument of nil, t, a name of a package,\
+ or a cons-cell as accepted by `package-vc-selected-packages', where \
+ the accepted plist is augmented by a `:rev' keyword.")))))
+
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
;;; The main macro
@@ -1667,7 +1784,9 @@ Usage:
(compare with `custom-set-variables').
:custom-face Call `custom-set-faces' with each face definition.
:ensure Loads the package using package.el if necessary.
-:pin Pin the package to an archive."
+:pin Pin the package to an archive.
+:vc Install the package directly from a version control system
+ (using `package-vc.el')."
(declare (indent defun))
(unless (memq :disabled args)
(macroexp-progn
diff --git a/lisp/use-package/use-package-delight.el b/lisp/use-package/use-package-delight.el
index 0037c56a8dd..c458d263cf0 100644
--- a/lisp/use-package/use-package-delight.el
+++ b/lisp/use-package/use-package-delight.el
@@ -4,7 +4,6 @@
;; Author: John Wiegley <johnw@newartisans.com>
;; Maintainer: John Wiegley <johnw@newartisans.com>
-;; Package: use-package
;; This file is part of GNU Emacs.
diff --git a/lisp/use-package/use-package-diminish.el b/lisp/use-package/use-package-diminish.el
index e0558ab868c..79421a0e273 100644
--- a/lisp/use-package/use-package-diminish.el
+++ b/lisp/use-package/use-package-diminish.el
@@ -4,7 +4,6 @@
;; Author: John Wiegley <johnw@newartisans.com>
;; Maintainer: John Wiegley <johnw@newartisans.com>
-;; Package: use-package
;; This file is part of GNU Emacs.
diff --git a/lisp/use-package/use-package-ensure-system-package.el b/lisp/use-package/use-package-ensure-system-package.el
index 3e369d99624..6c7f8c0a1ea 100644
--- a/lisp/use-package/use-package-ensure-system-package.el
+++ b/lisp/use-package/use-package-ensure-system-package.el
@@ -7,7 +7,6 @@
;; URL: https://github.com/waymondo/use-package-ensure-system-package
;; Package-Requires: ((use-package "2.1") (system-packages "1.0.4"))
;; Filename: use-package-ensure-system-package.el
-;; Package: use-package
;; This file is part of GNU Emacs.
diff --git a/lisp/use-package/use-package-ensure.el b/lisp/use-package/use-package-ensure.el
index feff6af6170..5f75b6b59ea 100644
--- a/lisp/use-package/use-package-ensure.el
+++ b/lisp/use-package/use-package-ensure.el
@@ -4,7 +4,6 @@
;; Author: John Wiegley <johnw@newartisans.com>
;; Maintainer: John Wiegley <johnw@newartisans.com>
-;; Package: use-package
;; This file is part of GNU Emacs.
@@ -183,7 +182,8 @@ manually updated package."
;;;###autoload
(defun use-package-handler/:ensure (name _keyword ensure rest state)
- (let* ((body (use-package-process-keywords name rest state)))
+ (let* ((body (use-package-process-keywords name rest state))
+ (ensure (and (not (plist-member rest :vc)) ensure)))
;; We want to avoid installing packages when the `use-package' macro is
;; being macro-expanded by elisp completion (see `lisp--local-variables'),
;; but still install packages when byte-compiling, to avoid requiring
diff --git a/lisp/use-package/use-package-jump.el b/lisp/use-package/use-package-jump.el
index 162ae176a63..604b2600b3d 100644
--- a/lisp/use-package/use-package-jump.el
+++ b/lisp/use-package/use-package-jump.el
@@ -4,7 +4,6 @@
;; Author: John Wiegley <johnw@newartisans.com>
;; Maintainer: John Wiegley <johnw@newartisans.com>
-;; Package: use-package
;; This file is part of GNU Emacs.
diff --git a/lisp/use-package/use-package-lint.el b/lisp/use-package/use-package-lint.el
index 25e6bcb7f90..15c58809478 100644
--- a/lisp/use-package/use-package-lint.el
+++ b/lisp/use-package/use-package-lint.el
@@ -4,7 +4,6 @@
;; Author: John Wiegley <johnw@newartisans.com>
;; Maintainer: John Wiegley <johnw@newartisans.com>
-;; Package: use-package
;; This file is part of GNU Emacs.
diff --git a/lisp/use-package/use-package.el b/lisp/use-package/use-package.el
index dbefa5be089..fc5c994a5f9 100644
--- a/lisp/use-package/use-package.el
+++ b/lisp/use-package/use-package.el
@@ -10,6 +10,9 @@
;; Keywords: dotemacs startup speed config package extensions
;; URL: https://github.com/jwiegley/use-package
+;; This is a GNU ELPA :core package. Avoid functionality that is not
+;; compatible with the version of Emacs recorded above.
+
;; This file is part of GNU Emacs.
;; GNU Emacs is free software: you can redistribute it and/or modify
diff --git a/lisp/userlock.el b/lisp/userlock.el
index 53c4c16cb85..db94bb214e6 100644
--- a/lisp/userlock.el
+++ b/lisp/userlock.el
@@ -64,10 +64,11 @@ in any way you like."
(match-string 0 opponent)))
opponent))
(while (null answer)
+ (when noninteractive
+ (signal 'file-locked (list file opponent "Cannot resolve lock conflict in batch mode")))
(message (substitute-command-keys
"%s locked by %s: (\\`s', \\`q', \\`p', \\`?')? ")
short-file short-opponent)
- (if noninteractive (error "Cannot resolve lock conflict in batch mode"))
(let ((tem (let ((inhibit-quit t)
(cursor-in-echo-area t))
(prog1 (downcase (read-char))
@@ -110,10 +111,11 @@ You can <\\`q'>uit; don't modify this file."))
(defun userlock--check-content-unchanged (filename)
(with-demoted-errors "Unchanged content check: %S"
- ;; Even tho we receive `filename', we know that `filename' refers to the current
- ;; buffer's file.
- (cl-assert (equal (expand-file-name filename)
- (expand-file-name buffer-file-truename)))
+ ;; Even tho we receive `filename', we know that `filename' refers
+ ;; to the current buffer's file.
+ (cl-assert (or (null buffer-file-truename) ; temporary buffer
+ (equal (expand-file-name filename)
+ (expand-file-name buffer-file-truename))))
;; Note: rather than read the file and compare to the buffer, we could save
;; the buffer and compare to the file, but for encrypted data this
;; wouldn't work well (and would risk exposing the data).
@@ -135,7 +137,15 @@ You can <\\`q'>uit; don't modify this file."))
(compare-buffer-substrings
buf start end
(current-buffer) (point-min) (point-max))))))
- (set-visited-file-modtime)
+ ;; We know that some buffer visits FILENAME, because our
+ ;; caller (see lock_file) verified that. Thus, we set the
+ ;; modtime in that buffer, to cater to use case where the
+ ;; file is about to be written to from some buffer that
+ ;; doesn't visit any file, like a temporary buffer.
+ (let ((buf (get-file-buffer (file-truename filename))))
+ (when buf ; If we cannot find the visiting buffer, punt.
+ (with-current-buffer buf
+ (set-visited-file-modtime))))
'unchanged)))))
;;;###autoload
@@ -206,11 +216,12 @@ file, then make the change again."))
;;;###autoload
(defun userlock--handle-unlock-error (error)
"Report an ERROR that occurred while unlocking a file."
- (display-warning
- '(unlock-file)
- ;; There is no need to explain that this is an unlock error because
- ;; ERROR is a `file-error' condition, which explains this.
- (message "%s, ignored" (error-message-string error))
- :warning))
+ (when create-lockfiles
+ (display-warning
+ '(unlock-file)
+ ;; There is no need to explain that this is an unlock error because
+ ;; ERROR is a `file-error' condition, which explains this.
+ (message "%s, ignored" (error-message-string error))
+ :warning)))
;;; userlock.el ends here
diff --git a/lisp/vc/cvs-status.el b/lisp/vc/cvs-status.el
index bec65e6f6f7..c9ad1d13d24 100644
--- a/lisp/vc/cvs-status.el
+++ b/lisp/vc/cvs-status.el
@@ -352,10 +352,8 @@ the list is a three-string list TAG, KIND, REV."
(delete-region pt (point)))
tags)))
-(defvar font-lock-mode)
;; (defun cvs-refontify (beg end)
-;; (when (and font-lock-mode
-;; (fboundp 'font-lock-fontify-region))
+;; (when font-lock-mode
;; (font-lock-fontify-region (1- beg) (1+ end))))
(defun cvs-status-trees ()
diff --git a/lisp/vc/diff-mode.el b/lisp/vc/diff-mode.el
index 4f150dc7f36..66043059d14 100644
--- a/lisp/vc/diff-mode.el
+++ b/lisp/vc/diff-mode.el
@@ -153,6 +153,17 @@ and hunk-based syntax highlighting otherwise as a fallback."
:type (get 'whitespace-style 'custom-type)
:version "29.1")
+(defcustom diff-ignore-whitespace-switches "-b"
+ "Switch or list of diff switches to use when ignoring whitespace.
+The default \"-b\" means to ignore whitespace-only changes,
+\"-w\" means ignore all whitespace changes."
+ :type '(choice
+ (string :tag "Ignore whitespace-only changes" :value "-b")
+ (string :tag "Ignore all whitespace changes" :value "-w")
+ (string :tag "Single switch")
+ (repeat :tag "Multiple switches" (string :tag "Switch")))
+ :version "30.1")
+
(defvar diff-vc-backend nil
"The VC backend that created the current Diff buffer, if any.")
@@ -205,6 +216,7 @@ and hunk-based syntax highlighting otherwise as a fallback."
"C-x 4 A" #'diff-add-change-log-entries-other-window
;; Misc operations.
"C-c C-a" #'diff-apply-hunk
+ "C-c C-m a" #'diff-apply-buffer
"C-c C-e" #'diff-ediff-patch
"C-c C-n" #'diff-restrict-view
"C-c C-s" #'diff-split-hunk
@@ -228,6 +240,8 @@ and hunk-based syntax highlighting otherwise as a fallback."
:help "Apply the current hunk to the source file and go to the next"]
["Test applying hunk" diff-test-hunk
:help "See whether it's possible to apply the current hunk"]
+ ["Apply all hunks" diff-apply-buffer
+ :help "Apply all hunks in the current diff buffer"]
["Apply diff with Ediff" diff-ediff-patch
:help "Call `ediff-patch-file' on the current buffer"]
["Create Change Log entries" diff-add-change-log-entries-other-window
@@ -505,8 +519,8 @@ use the face `diff-removed' for removed lines, and the face
("^Only in .*\n" . 'diff-nonexistent)
("^Binary files .* differ\n" . 'diff-file-header)
("^\\(#\\)\\(.*\\)"
- (1 font-lock-comment-delimiter-face)
- (2 font-lock-comment-face))
+ (1 'font-lock-comment-delimiter-face)
+ (2 'font-lock-comment-face))
("^diff: .*" (0 'diff-error))
("^[^-=+*!<>#].*\n" (0 'diff-context))
(,#'diff--font-lock-syntax)
@@ -932,7 +946,8 @@ like \(diff-merge-strings \"b/foo\" \"b/bar\" \"/a/c/foo\")."
(when (and (string-match (concat
"\\`\\(.*?\\)\\(.*\\)\\(.*\\)\n"
"\\1\\(.*\\)\\3\n"
- "\\(.*\\(\\2\\).*\\)\\'") str)
+ "\\(.*\\(\\2\\).*\\)\\'")
+ str)
(equal to (match-string 5 str)))
(concat (substring str (match-beginning 5) (match-beginning 6))
(match-string 4 str)
@@ -1604,7 +1619,7 @@ modified lines of the diff."
nil)))
(when (eq diff-buffer-type 'git)
(setq diff-outline-regexp
- (concat "\\(^diff --git.*\n\\|" diff-hunk-header-re "\\)")))
+ (concat "\\(^diff --git.*\\|" diff-hunk-header-re "\\)")))
(setq-local outline-level #'diff--outline-level)
(setq-local outline-regexp diff-outline-regexp))
@@ -1987,7 +2002,7 @@ With a prefix argument, REVERSE the hunk."
(diff-find-source-location nil reverse)))
(cond
((null line-offset)
- (error "Can't find the text to patch"))
+ (user-error "Can't find the text to patch"))
((with-current-buffer buf
(and buffer-file-name
(backup-file-name-p buffer-file-name)
@@ -1996,7 +2011,7 @@ With a prefix argument, REVERSE the hunk."
(yes-or-no-p (format "Really apply this hunk to %s? "
(file-name-nondirectory
buffer-file-name)))))))
- (error "%s"
+ (user-error "%s"
(substitute-command-keys
(format "Use %s\\[diff-apply-hunk] to apply it to the other file"
(if (not reverse) "\\[universal-argument] ")))))
@@ -2043,6 +2058,40 @@ With a prefix argument, try to REVERSE the hunk."
(diff-hunk-kill)
(diff-hunk-next)))))
+(defun diff-apply-buffer ()
+ "Apply the diff in the entire diff buffer.
+When applying all hunks was successful, then save the changed buffers."
+ (interactive)
+ (let ((buffer-edits nil)
+ (failures 0)
+ (diff-refine nil))
+ (save-excursion
+ (goto-char (point-min))
+ (diff-beginning-of-hunk t)
+ (while (pcase-let ((`(,buf ,line-offset ,pos ,_src ,dst ,switched)
+ (diff-find-source-location nil nil)))
+ (cond ((and line-offset (not switched))
+ (push (cons pos dst)
+ (alist-get buf buffer-edits)))
+ (t (setq failures (1+ failures))))
+ (and (not (eq (prog1 (point) (ignore-errors (diff-hunk-next)))
+ (point)))
+ (looking-at-p diff-hunk-header-re)))))
+ (cond ((zerop failures)
+ (dolist (buf-edits (reverse buffer-edits))
+ (with-current-buffer (car buf-edits)
+ (dolist (edit (cdr buf-edits))
+ (let ((pos (car edit))
+ (dst (cdr edit))
+ (inhibit-read-only t))
+ (goto-char (car pos))
+ (delete-region (car pos) (cdr pos))
+ (insert (car dst))))
+ (save-buffer)))
+ (message "Saved %d buffers" (length buffer-edits)))
+ (t
+ (message "%d hunks failed; no buffers changed" failures)))))
+
(defalias 'diff-mouse-goto-source #'diff-goto-source)
(defun diff-goto-source (&optional other-file event)
@@ -2103,10 +2152,13 @@ For use in `add-log-current-defun-function'."
(goto-char (+ (car pos) (cdr src)))
(add-log-current-defun)))))))
-(defun diff-ignore-whitespace-hunk ()
- "Re-diff the current hunk, ignoring whitespace differences."
- (interactive)
- (diff-refresh-hunk t))
+(defun diff-ignore-whitespace-hunk (&optional whole-buffer)
+ "Re-diff the current hunk, ignoring whitespace differences.
+With non-nil prefix arg, re-diff all the hunks."
+ (interactive "P")
+ (if whole-buffer
+ (diff--ignore-whitespace-all-hunks)
+ (diff-refresh-hunk t)))
(defun diff-refresh-hunk (&optional ignore-whitespace)
"Re-diff the current hunk."
@@ -2127,7 +2179,7 @@ For use in `add-log-current-defun-function'."
(coding-system-for-read buffer-file-coding-system)
opts old new)
(when ignore-whitespace
- (setq opts '("-b")))
+ (setq opts (ensure-list diff-ignore-whitespace-switches)))
(when opt-type
(setq opts (cons opt-type opts)))
@@ -2226,6 +2278,24 @@ Return new point, if it was moved."
(end (progn (diff-end-of-hunk) (point))))
(diff--refine-hunk beg end)))))
+(defun diff--refine-propertize (beg end face)
+ (let ((ol (make-overlay beg end)))
+ (overlay-put ol 'diff-mode 'fine)
+ (overlay-put ol 'evaporate t)
+ (overlay-put ol 'face face)))
+
+(defcustom diff-refine-nonmodified nil
+ "If non-nil, also highlight the added/removed lines as \"refined\".
+The lines highlighted when this is non-nil are those that were
+added or removed in their entirety, as opposed to lines some
+parts of which were modified. The added lines are highlighted
+using the `diff-refine-added' face, while the removed lines are
+highlighted using the `diff-refine-removed' face.
+This is currently implemented only for diff formats supported
+by `diff-refine-hunk'."
+ :version "30.1"
+ :type 'boolean)
+
(defun diff--refine-hunk (start end)
(require 'smerge-mode)
(goto-char start)
@@ -2240,41 +2310,68 @@ Return new point, if it was moved."
(goto-char beg)
(pcase style
('unified
- (while (re-search-forward "^-" end t)
+ (while (re-search-forward "^[-+]" end t)
(let ((beg-del (progn (beginning-of-line) (point)))
beg-add end-add)
- (when (and (diff--forward-while-leading-char ?- end)
- ;; Allow for "\ No newline at end of file".
- (progn (diff--forward-while-leading-char ?\\ end)
- (setq beg-add (point)))
- (diff--forward-while-leading-char ?+ end)
- (progn (diff--forward-while-leading-char ?\\ end)
- (setq end-add (point))))
+ (cond
+ ((eq (char-after) ?+)
+ (diff--forward-while-leading-char ?+ end)
+ (when diff-refine-nonmodified
+ (diff--refine-propertize beg-del (point) 'diff-refine-added)))
+ ((and (diff--forward-while-leading-char ?- end)
+ ;; Allow for "\ No newline at end of file".
+ (progn (diff--forward-while-leading-char ?\\ end)
+ (setq beg-add (point)))
+ (diff--forward-while-leading-char ?+ end)
+ (progn (diff--forward-while-leading-char ?\\ end)
+ (setq end-add (point))))
(smerge-refine-regions beg-del beg-add beg-add end-add
- nil #'diff-refine-preproc props-r props-a)))))
+ nil #'diff-refine-preproc props-r props-a))
+ (t ;; If we're here, it's because
+ ;; (diff--forward-while-leading-char ?+ end) failed.
+ (when diff-refine-nonmodified
+ (diff--refine-propertize beg-del (point)
+ 'diff-refine-removed)))))))
('context
(let* ((middle (save-excursion (re-search-forward "^---" end t)))
(other middle))
- (while (and middle
- (re-search-forward "^\\(?:!.*\n\\)+" middle t))
- (smerge-refine-regions (match-beginning 0) (match-end 0)
- (save-excursion
- (goto-char other)
- (re-search-forward "^\\(?:!.*\n\\)+" end)
- (setq other (match-end 0))
- (match-beginning 0))
- other
- (if diff-use-changed-face props-c)
- #'diff-refine-preproc
- (unless diff-use-changed-face props-r)
- (unless diff-use-changed-face props-a)))))
+ (when middle
+ (while (re-search-forward "^\\(?:!.*\n\\)+" middle t)
+ (smerge-refine-regions (match-beginning 0) (match-end 0)
+ (save-excursion
+ (goto-char other)
+ (re-search-forward "^\\(?:!.*\n\\)+" end)
+ (setq other (match-end 0))
+ (match-beginning 0))
+ other
+ (if diff-use-changed-face props-c)
+ #'diff-refine-preproc
+ (unless diff-use-changed-face props-r)
+ (unless diff-use-changed-face props-a)))
+ (when diff-refine-nonmodified
+ (goto-char beg)
+ (while (re-search-forward "^\\(?:-.*\n\\)+" middle t)
+ (diff--refine-propertize (match-beginning 0)
+ (match-end 0)
+ 'diff-refine-removed))
+ (goto-char middle)
+ (while (re-search-forward "^\\(?:\\+.*\n\\)+" end t)
+ (diff--refine-propertize (match-beginning 0)
+ (match-end 0)
+ 'diff-refine-added))))))
(_ ;; Normal diffs.
(let ((beg1 (1+ (point))))
- (when (re-search-forward "^---.*\n" end t)
+ (cond
+ ((re-search-forward "^---.*\n" end t)
;; It's a combined add&remove, so there's something to do.
(smerge-refine-regions beg1 (match-beginning 0)
(match-end 0) end
- nil #'diff-refine-preproc props-r props-a)))))))
+ nil #'diff-refine-preproc props-r props-a))
+ (diff-refine-nonmodified
+ (diff--refine-propertize
+ beg1 end
+ (if (eq (char-after beg1) ?<)
+ 'diff-refine-removed 'diff-refine-added)))))))))
(defun diff--iterate-hunks (max fun)
"Iterate over all hunks between point and MAX.
@@ -2299,6 +2396,16 @@ Call FUN with two args (BEG and END) for each hunk."
(or (ignore-errors (diff-hunk-next) (point))
max)))))))))
+;; This doesn't use `diff--iterate-hunks', since that assumes that
+;; hunks don't change size.
+(defun diff--ignore-whitespace-all-hunks ()
+ "Re-diff all the hunks, ignoring whitespace-differences."
+ (save-excursion
+ (goto-char (point-min))
+ (diff-hunk-next)
+ (while (looking-at diff-hunk-header-re)
+ (diff-refresh-hunk t))))
+
(defun diff--font-lock-refined (max)
"Apply hunk refinement from font-lock."
(when (eq diff-refine 'font-lock)
@@ -2758,6 +2865,57 @@ and the position in MAX."
(defvar-local diff--syntax-file-attributes nil)
(put 'diff--syntax-file-attributes 'permanent-local t)
+(defvar diff--cached-revision-buffers nil
+ "List of ((FILE . REVISION) . BUFFER) in MRU order.")
+
+(defvar diff--cache-clean-timer nil)
+(defconst diff--cache-clean-interval 3600) ; seconds
+
+(defun diff--cache-clean ()
+ "Discard the least recently used half of the cache."
+ (let ((n (/ (length diff--cached-revision-buffers) 2)))
+ (mapc #'kill-buffer (mapcar #'cdr (nthcdr n diff--cached-revision-buffers)))
+ (setq diff--cached-revision-buffers
+ (ntake n diff--cached-revision-buffers)))
+ (diff--cache-schedule-clean))
+
+(defun diff--cache-schedule-clean ()
+ (setq diff--cache-clean-timer
+ (and diff--cached-revision-buffers
+ (run-with-timer diff--cache-clean-interval nil
+ #'diff--cache-clean))))
+
+(defun diff--get-revision-properties (file revision text line-nb)
+ "Get font-lock properties from FILE at REVISION for TEXT at LINE-NB."
+ (let* ((file-rev (cons file revision))
+ (entry (assoc file-rev diff--cached-revision-buffers))
+ (buffer (cdr entry)))
+ (if (buffer-live-p buffer)
+ (progn
+ ;; Don't re-initialize the buffer (which would throw
+ ;; away the previous fontification work).
+ (setq file nil)
+ (setq diff--cached-revision-buffers
+ (cons entry
+ (delq entry diff--cached-revision-buffers))))
+ ;; Cache miss: create a new entry.
+ (setq buffer (get-buffer-create (format " *diff-syntax:%s.~%s~*"
+ file revision)))
+ (condition-case nil
+ (vc-find-revision-no-save file revision diff-vc-backend buffer)
+ (error
+ (kill-buffer buffer)
+ (setq buffer nil))
+ (:success
+ (push (cons file-rev buffer)
+ diff--cached-revision-buffers))))
+ (when diff--cache-clean-timer
+ (cancel-timer diff--cache-clean-timer))
+ (diff--cache-schedule-clean)
+ (and buffer
+ (with-current-buffer buffer
+ (diff-syntax-fontify-props file text line-nb)))))
+
(defun diff-syntax-fontify-hunk (beg end old)
"Highlight source language syntax in diff hunk between BEG and END.
When OLD is non-nil, highlight the hunk from the old source."
@@ -2808,22 +2966,8 @@ When OLD is non-nil, highlight the hunk from the old source."
(insert-file-contents file)
(setq diff--syntax-file-attributes attrs)))
(diff-syntax-fontify-props file text line-nb)))))
- ;; Get properties from a cached revision
- (let* ((buffer-name (format " *diff-syntax:%s.~%s~*"
- file revision))
- (buffer (get-buffer buffer-name)))
- (if buffer
- ;; Don't re-initialize the buffer (which would throw
- ;; away the previous fontification work).
- (setq file nil)
- (setq buffer (ignore-errors
- (vc-find-revision-no-save
- file revision
- diff-vc-backend
- (get-buffer-create buffer-name)))))
- (when buffer
- (with-current-buffer buffer
- (diff-syntax-fontify-props file text line-nb))))))))
+ (diff--get-revision-properties file revision
+ text line-nb)))))
(let ((file (car (diff-hunk-file-names old))))
(cond
((and file diff-default-directory
diff --git a/lisp/vc/diff.el b/lisp/vc/diff.el
index 79f6ea51bcf..a64fbc47853 100644
--- a/lisp/vc/diff.el
+++ b/lisp/vc/diff.el
@@ -165,7 +165,7 @@ returns the buffer used."
(unless (bufferp new) (setq new (expand-file-name new)))
(unless (bufferp old) (setq old (expand-file-name old)))
(or switches (setq switches diff-switches)) ; If not specified, use default.
- (unless (listp switches) (setq switches (list switches)))
+ (setq switches (ensure-list switches))
(or buf (setq buf (get-buffer-create "*Diff*")))
(diff-check-labels)
(let* ((old-alt (diff-file-local-copy old))
diff --git a/lisp/vc/ediff-diff.el b/lisp/vc/ediff-diff.el
index c5a03dc3b2f..83bd7cde12f 100644
--- a/lisp/vc/ediff-diff.el
+++ b/lisp/vc/ediff-diff.el
@@ -142,7 +142,7 @@ The status can be =diff(A), =diff(B), or =diff(A+B).")
;;; Fine differences
-(ediff-defvar-local ediff-auto-refine (if (ediff-has-face-support-p) 'on 'nix)
+(ediff-defvar-local ediff-auto-refine 'on
"If `on', Ediff auto-highlights fine diffs for the current diff region.
If `off', auto-highlighting is not used. If `nix', no fine diffs are shown
at all, unless the user force-refines the region by hitting `*'.
diff --git a/lisp/vc/ediff-util.el b/lisp/vc/ediff-util.el
index 070a368a4ba..597d8a5e643 100644
--- a/lisp/vc/ediff-util.el
+++ b/lisp/vc/ediff-util.el
@@ -1269,36 +1269,28 @@ which see."
(or (display-graphic-p)
(user-error "Emacs is not running as a window application"))
- (cond ((eq ediff-window-setup-function #'ediff-setup-windows-multiframe)
- (setq ediff-multiframe nil)
- (setq window-setup-func #'ediff-setup-windows-plain)
- (message "ediff is now in `plain' mode"))
- ((eq ediff-window-setup-function #'ediff-setup-windows-plain)
- (if (and (ediff-buffer-live-p ediff-control-buffer)
- (window-live-p ediff-control-window))
- (set-window-dedicated-p ediff-control-window nil))
- (setq ediff-multiframe t)
- (setq window-setup-func #'ediff-setup-windows-multiframe)
- (message "ediff is now in `multiframe' mode"))
- (t
- (if (and (ediff-buffer-live-p ediff-control-buffer)
- (window-live-p ediff-control-window))
- (set-window-dedicated-p ediff-control-window nil))
- (setq ediff-multiframe t)
- (setq window-setup-func #'ediff-setup-windows-multiframe))
- (message "ediff is now in `multiframe' mode"))
-
- ;; change default
- (setq-default ediff-window-setup-function window-setup-func)
- ;; change in all active ediff sessions
- (mapc (lambda(buf) (ediff-with-current-buffer buf
- (setq ediff-window-setup-function window-setup-func
- ediff-window-B nil)))
- ediff-session-registry)
- (if (ediff-in-control-buffer-p)
- (progn
- (set-window-dedicated-p (selected-window) nil)
- (ediff-recenter 'no-rehighlight)))))
+ (cond ((eq ediff-window-setup-function #'ediff-setup-windows-multiframe)
+ (setq ediff-multiframe nil)
+ (setq window-setup-func #'ediff-setup-windows-plain)
+ (message "ediff is now in `plain' mode"))
+ (t ; (eq ediff-window-setup-function #'ediff-setup-windows-plain)
+ (if (and (ediff-buffer-live-p ediff-control-buffer)
+ (window-live-p ediff-control-window))
+ (set-window-dedicated-p ediff-control-window nil))
+ (setq ediff-multiframe t)
+ (setq window-setup-func #'ediff-setup-windows-multiframe)
+ (message "ediff is now in `multiframe' mode")))
+
+ ;; change default
+ (setq-default ediff-window-setup-function window-setup-func)
+ ;; change in all active ediff sessions
+ (mapc (lambda (buf) (ediff-with-current-buffer buf
+ (setq ediff-window-setup-function window-setup-func
+ ediff-window-B nil)))
+ ediff-session-registry)
+ (when (ediff-in-control-buffer-p)
+ (set-window-dedicated-p (selected-window) nil)
+ (ediff-recenter 'no-rehighlight))))
;;;###autoload
@@ -3138,16 +3130,15 @@ Hit \\[ediff-recenter] to reset the windows afterward."
;; e.g., if file name ends with .Z or .gz
;; This is needed so that patches produced by ediff will
;; have more meaningful names
- (ediff-make-empty-tmp-file short-f))
+ (make-temp-file short-f))
(prefix
;; Prefix is most often the same as the file name for the
- ;; variant. Here we are trying to use the original file
- ;; name but in the temp directory.
- (ediff-make-empty-tmp-file f 'keep-name))
+ ;; variant.
+ (make-temp-file f))
(t
;; If don't care about name, add some random stuff
;; to proposed file name.
- (ediff-make-empty-tmp-file short-f))))
+ (make-temp-file short-f))))
;; create the file
(ediff-with-current-buffer buff
@@ -3159,28 +3150,6 @@ Hit \\[ediff-recenter] to reset the windows afterward."
(set-file-modes f ediff-temp-file-mode)
(expand-file-name f))))
-;; Create a temporary file.
-;; The returned file name (created by appending some random characters at the
-;; end of PROPOSED-NAME is guaranteed to point to a newly created empty file.
-;; This is a replacement for make-temp-name, which eliminates a security hole.
-;; If KEEP-PROPOSED-NAME isn't nil, try to keep PROPOSED-NAME, unless such file
-;; already exists.
-;; It is a modified version of make-temp-file in emacs 20.5
-(defun ediff-make-empty-tmp-file (proposed-name &optional keep-proposed-name)
- (let ((file proposed-name))
- (while (condition-case ()
- (progn
- (if (or (file-exists-p file) (not keep-proposed-name))
- (setq file (make-temp-name proposed-name)))
- (write-region "" nil file nil 'silent nil 'excl)
- nil)
- (file-already-exists t))
- ;; the file was somehow created by someone else between
- ;; `make-temp-name' and `write-region', let's try again.
- nil)
- file))
-
-
;; Make sure the current buffer (for a file) has the same contents as the
;; file on disk, and attempt to remedy the situation if not.
;; Signal an error if we can't make them the same, or the user doesn't want
@@ -3741,7 +3710,7 @@ Ediff Control Panel to restore highlighting."
;; these buffers).
;; EXCL-BUFF-LIST is an exclusion list.
(defun ediff-other-buffer (excl-buff-lst)
- (or (listp excl-buff-lst) (setq excl-buff-lst (list excl-buff-lst)))
+ (setq excl-buff-lst (ensure-list excl-buff-lst))
(let* ((all-buffers (nconc (ediff-get-selected-buffers) (buffer-list)))
;; we compute this the second time because we need to do memq on it
;; later, and nconc above will break it. Either this or use slow
@@ -4144,6 +4113,10 @@ Mail anyway? (y or n) ")
(define-obsolete-function-alias 'ediff-intersection #'seq-intersection "28.1")
(define-obsolete-function-alias 'ediff-set-difference #'seq-difference "28.1")
+(defun ediff-make-empty-tmp-file (prefix &optional _ignored)
+ (declare (obsolete make-temp-file "30.1"))
+ (make-temp-file prefix))
+
(run-hooks 'ediff-load-hook)
;;; ediff-util.el ends here
diff --git a/lisp/vc/ediff-wind.el b/lisp/vc/ediff-wind.el
index 4720481b8ee..0e172e60277 100644
--- a/lisp/vc/ediff-wind.el
+++ b/lisp/vc/ediff-wind.el
@@ -69,6 +69,16 @@ provided functions are written."
(function :tag "Other function"))
:version "24.3")
+(defcustom ediff-floating-control-frame nil
+ "If non-nil, try making the control frame be floating rather than tiled.
+
+If your X window manager makes the Ediff control frame a tiled one,
+set this to a non-nil value, and Emacs will try to make it floating.
+This only has effect on X displays."
+ :type '(choice (const :tag "Control frame floats" t)
+ (const :tag "Control frame has default WM behavior" nil))
+ :version "30.1")
+
(ediff-defvar-local ediff-multiframe nil
"Indicates if we are in a multiframe setup.")
@@ -873,6 +883,19 @@ Create a new splittable frame if none is found."
(not (ediff-frame-has-dedicated-windows (window-frame wind)))
)))
+(defvar x-fast-protocol-requests)
+(declare-function x-change-window-property "xfns.c")
+
+(defun ediff-frame-make-utility (frame)
+ (let ((x-fast-protocol-requests t))
+ (x-change-window-property
+ "_NET_WM_WINDOW_TYPE" '("_NET_WM_WINDOW_TYPE_UTILITY")
+ frame "ATOM" 32 t)
+ (x-change-window-property
+ "WM_TRANSIENT_FOR"
+ (list (string-to-number (frame-parameter nil 'window-id)))
+ frame "WINDOW" 32 t)))
+
;; Prepare or refresh control frame
(defun ediff-setup-control-frame (ctl-buffer designated-minibuffer-frame)
(let ((window-min-height 1)
@@ -948,6 +971,8 @@ Create a new splittable frame if none is found."
(goto-char (point-min))
(modify-frame-parameters ctl-frame adjusted-parameters)
+ (when (and ediff-floating-control-frame (eq (window-system ctl-frame) 'x))
+ (ediff-frame-make-utility ctl-frame))
(make-frame-visible ctl-frame)
;; This works around a bug in 19.25 and earlier. There, if frame gets
diff --git a/lisp/vc/emerge.el b/lisp/vc/emerge.el
index de09be80e7c..5328ebc73ad 100644
--- a/lisp/vc/emerge.el
+++ b/lisp/vc/emerge.el
@@ -877,8 +877,8 @@ This is *not* a user option, since Emerge uses it for its own processing.")
(defun emerge-buffers (buffer-A buffer-B &optional startup-hooks quit-hooks)
"Run Emerge on two buffers BUFFER-A and BUFFER-B."
(interactive "bBuffer A to merge: \nbBuffer B to merge: ")
- (let ((emerge-file-A (emerge-make-temp-file "A"))
- (emerge-file-B (emerge-make-temp-file "B")))
+ (let ((emerge-file-A (make-temp-file "emerge-A"))
+ (emerge-file-B (make-temp-file "emerge-B")))
(with-current-buffer
buffer-A
(write-region (point-min) (point-max) emerge-file-A nil 'no-message))
@@ -901,9 +901,9 @@ This is *not* a user option, since Emerge uses it for its own processing.")
"Run Emerge on two buffers, giving another buffer as the ancestor."
(interactive
"bBuffer A to merge: \nbBuffer B to merge: \nbAncestor buffer: ")
- (let ((emerge-file-A (emerge-make-temp-file "A"))
- (emerge-file-B (emerge-make-temp-file "B"))
- (emerge-file-ancestor (emerge-make-temp-file "anc")))
+ (let ((emerge-file-A (make-temp-file "emerge-A"))
+ (emerge-file-B (make-temp-file "emerge-B"))
+ (emerge-file-ancestor (make-temp-file "emerge-ancestor")))
(with-current-buffer
buffer-A
(write-region (point-min) (point-max) emerge-file-A nil 'no-message))
@@ -1039,8 +1039,8 @@ This is *not* a user option, since Emerge uses it for its own processing.")
startup-hooks quit-hooks _output-file)
(let ((buffer-A (get-buffer-create (format "%s,%s" file revision-A)))
(buffer-B (get-buffer-create (format "%s,%s" file revision-B)))
- (emerge-file-A (emerge-make-temp-file "A"))
- (emerge-file-B (emerge-make-temp-file "B")))
+ (emerge-file-A (make-temp-file "emerge-A"))
+ (emerge-file-B (make-temp-file "emerge-B")))
;; Get the revisions into buffers
(with-current-buffer
buffer-A
@@ -1076,9 +1076,9 @@ This is *not* a user option, since Emerge uses it for its own processing.")
(let ((buffer-A (get-buffer-create (format "%s,%s" file revision-A)))
(buffer-B (get-buffer-create (format "%s,%s" file revision-B)))
(buffer-ancestor (get-buffer-create (format "%s,%s" file ancestor)))
- (emerge-file-A (emerge-make-temp-file "A"))
- (emerge-file-B (emerge-make-temp-file "B"))
- (emerge-ancestor (emerge-make-temp-file "ancestor")))
+ (emerge-file-A (make-temp-file "emerge-A"))
+ (emerge-file-B (make-temp-file "emerge-B"))
+ (emerge-ancestor (make-temp-file "emerge-ancestor")))
;; Get the revisions into buffers
(with-current-buffer
buffer-A
@@ -1299,7 +1299,7 @@ Otherwise, the A or B file present is copied to the output file."
(setq ancestor-dir-files (cdr ancestor-dir-files))))
(if output-dir
(insert "output=" output-dir f "\t"))
- (backward-delete-char 1)
+ (delete-char -1)
(insert "\n")))))
;;; Common setup routines
@@ -2851,14 +2851,6 @@ Otherwise, signal an error."
(setq vars (cdr vars))
(setq values (cdr values))))
-;; When the pointless option emerge-temp-file-prefix goes,
-;; make this function obsolete too, and just use make-temp-file.
-(defun emerge-make-temp-file (prefix)
- "Make a private temporary file based on PREFIX.
-This is named by concatenating `emerge-temp-file-prefix' with
-PREFIX."
- (make-temp-file (concat emerge-temp-file-prefix prefix)))
-
;;; Functions that query the user before he can write out the current buffer.
(defun emerge-query-write-file ()
@@ -3062,6 +3054,8 @@ See also `auto-save-file-name-p'."
:type '(choice (const nil) regexp))
(make-obsolete-variable 'emerge-metachars nil "26.1")
+(define-obsolete-function-alias 'emerge-make-temp-file #'make-temp-file "30.1")
+
(provide 'emerge)
;;; emerge.el ends here
diff --git a/lisp/vc/log-edit.el b/lisp/vc/log-edit.el
index b0d3e9f54e3..1f766eea455 100644
--- a/lisp/vc/log-edit.el
+++ b/lisp/vc/log-edit.el
@@ -61,12 +61,12 @@
"C-c C-d" #'log-edit-show-diff
"C-c C-f" #'log-edit-show-files
"C-c C-k" #'log-edit-kill-buffer
- "C-a" #'log-edit-beginning-of-line
"M-n" #'log-edit-next-comment
"M-p" #'log-edit-previous-comment
"M-r" #'log-edit-comment-search-backward
"M-s" #'log-edit-comment-search-forward
- "C-c ?" #'log-edit-mode-help)
+ "C-c ?" #'log-edit-mode-help
+ "<remap> <move-beginning-of-line>" #'log-edit-beginning-of-line)
(easy-menu-define log-edit-menu log-edit-mode-map
"Menu used for `log-edit-mode'."
@@ -76,6 +76,8 @@
"--"
["Insert ChangeLog" log-edit-insert-changelog
:help "Insert a log message by looking at the ChangeLog"]
+ ["Generate ChangeLog" log-edit-generate-changelog-from-diff
+ :help "Generate a log message from the diff and insert it into this buffer"]
["Add to ChangeLog" log-edit-add-to-changelog
:help "Insert this log message into the appropriate ChangeLog file"]
"--"
@@ -93,6 +95,60 @@
["Search comment backward" log-edit-comment-search-backward
:help "Search backwards through comment history for substring match of str"]))
+(defvar log-edit-tool-bar-map
+ (let ((map (make-sparse-keymap)))
+ (tool-bar-local-item-from-menu 'find-file "new" map
+ nil :label "New File"
+ :vert-only t)
+ (tool-bar-local-item-from-menu 'menu-find-file-existing "open" map
+ nil :label "Open" :vert-only t)
+ (tool-bar-local-item-from-menu 'dired "diropen" map nil :vert-only t)
+ (tool-bar-local-item-from-menu 'kill-this-buffer "close" map nil
+ :vert-only t)
+ (define-key-after map [separator-1] menu-bar-separator)
+ (tool-bar-local-item-from-menu 'log-edit-done "commit"
+ map log-edit-mode-map :vert-only t
+ :help
+ "Exit log buffer and commit the changes")
+ (define-key-after map [separator-2] menu-bar-separator)
+ (tool-bar-local-item-from-menu 'log-edit-insert-changelog
+ "load-changelog"
+ map log-edit-mode-map :vert-only t
+ :help
+ "Produce log message from ChangeLog file")
+ (tool-bar-local-item-from-menu 'log-edit-generate-changelog-from-diff
+ "gen-changelog"
+ map log-edit-mode-map :vert-only t
+ :help
+ "Generate log message skeleton from diffs")
+ (tool-bar-local-item-from-menu 'log-edit-add-to-changelog
+ "ins-changelog"
+ map log-edit-mode-map :vert-only t
+ :help
+ "Insert this log message into ChangeLog file")
+ (define-key-after map [separator-3] menu-bar-separator)
+ (tool-bar-local-item-from-menu 'log-edit-show-diff
+ "view-diff"
+ map log-edit-mode-map :vert-only t
+ :help
+ "View diffs for the files to be committed")
+ (tool-bar-local-item-from-menu 'log-edit-show-files
+ "info"
+ map log-edit-mode-map :vert-only t
+ :help
+ "View list of files to be committed")
+ (define-key-after map [separator-4] menu-bar-separator)
+ (tool-bar-local-item-from-menu 'undo "undo" map nil)
+ (define-key-after map [separator-5] menu-bar-separator)
+ (tool-bar-local-item-from-menu (lookup-key menu-bar-edit-menu [cut])
+ "cut" map nil)
+ (tool-bar-local-item-from-menu (lookup-key menu-bar-edit-menu [copy])
+ "copy" map nil)
+ (tool-bar-local-item-from-menu (lookup-key menu-bar-edit-menu [paste])
+ "paste" map nil)
+ map)
+ "Like the default `tool-bar-map', but with additions for Log-Edit mode.")
+
(defcustom log-edit-confirm 'changed
"If non-nil, `log-edit-done' will request confirmation.
If `changed', only request confirmation if the list of files has
@@ -511,25 +567,90 @@ the \\[vc-prefix-map] prefix for VC commands, for example).
(setq-local fill-paragraph-function #'log-edit-fill-entry)
(make-local-variable 'log-edit-comment-ring-index)
(add-hook 'kill-buffer-hook 'log-edit-remember-comment nil t)
- (hack-dir-local-variables-non-file-buffer))
+ (hack-dir-local-variables-non-file-buffer)
+ ;; Replace the tool bar map with `log-edit-tool-bar-map'.
+ (setq-local tool-bar-map log-edit-tool-bar-map))
(defun log-edit--insert-filled-defuns (func-names)
"Insert FUNC-NAMES, following ChangeLog formatting."
(if (not func-names)
(insert ":")
+ ;; Insert a space unless this list of defun names is being
+ ;; inserted at the start of a line or after a space character.
(unless (or (memq (char-before) '(?\n ?\s))
(> (current-column) fill-column))
(insert " "))
- (cl-loop for first-fun = t then nil
- for def in func-names do
- (when (> (+ (current-column) (string-width def)) fill-column)
- (unless first-fun
- (insert ")"))
- (insert "\n"))
- (insert (if (memq (char-before) '(?\n ?\s))
- "(" ", ")
- def))
- (insert "):")))
+ (let ((inside-paren-pair nil)
+ (first-line t)
+ name)
+ ;; Now insert the functions names one by one, inserting newlines
+ ;; as appropriate.
+ (while func-names
+ (setq name (car func-names))
+ (setq func-names (cdr func-names))
+ ;; If inserting `name' after preexisting text in the first
+ ;; line would overflow the fill column, place it on its own
+ ;; line.
+ (if (and first-line
+ (> (current-column) 0)
+ (> (+ (current-column)
+ (string-width name)
+ ;; If this be the last name, the column must be
+ ;; followed by an extra colon character.
+ (if func-names 1 2))
+ fill-column))
+ (progn
+ (insert "\n")
+ ;; Iterate over this function name again.
+ (setq func-names (cons name func-names)))
+ (if inside-paren-pair
+ ;; If `name' is not the first item in a list of defuns
+ ;; and inserting it would overflow the fill column,
+ ;; start a new list of defuns on the next line.
+ (if (> (+ (current-column)
+ (string-width name)
+ ;; If this be the last name, the column must
+ ;; be followed by an extra colon character;
+ ;; however, there are two separator characters
+ ;; that will be deleted, so the number of
+ ;; columns to add to this in the case of
+ ;; `name' being final and in other cases are 0
+ ;; and 1 respectively.
+ (if func-names 0 1))
+ fill-column)
+ (progn
+ (delete-char -2)
+ (insert ")\n")
+ (setq inside-paren-pair nil
+ ;; Iterate over this function name again.
+ func-names (cons name func-names)))
+ ;; Insert this defun name with a separator attached.
+ (insert name ", "))
+ ;; Otherwise, decide whether to start a list of defuns or
+ ;; to insert `name' on its own line.
+ (if (> (+ (current-column)
+ (string-width name)
+ (if func-names 1 2)) ; The column number of
+ ; line after inserting
+ ; `name'...
+ fill-column)
+ ;; ...would leave insufficient space for any
+ ;; subsequent defun names so insert it on its own
+ ;; line.
+ (insert (if func-names
+ (format "(%s)\n" name)
+ (format "(%s):" name)))
+ ;; Insert a new defun list, unless `name' is the last
+ ;; function name.
+ (insert (if (not func-names)
+ (format "(%s):" name)
+ (setq inside-paren-pair t)
+ (format "(%s, " name))))))
+ (setq first-line nil))
+ ;; Close any open list of defuns.
+ (when inside-paren-pair
+ (delete-char -2)
+ (insert "):")))))
(defun log-edit-fill-entry (&optional justify)
"Like \\[fill-paragraph], but for filling ChangeLog-formatted entries.
@@ -537,32 +658,70 @@ Consecutive function entries without prose (i.e., lines of the
form \"(FUNCTION):\") will be combined into \"(FUNC1, FUNC2):\"
according to `fill-column'."
(save-excursion
- (pcase-let ((`(,beg ,end) (log-edit-changelog-paragraph)))
+ (let* ((range (log-edit-changelog-paragraph))
+ (beg (car range))
+ (end (cadr range)))
(if (= beg end)
;; Not a ChangeLog entry, fill as normal.
nil
- (cl-callf copy-marker end)
+ (setq end (copy-marker end))
(goto-char beg)
- (cl-loop
- for defuns-beg =
- (and (< beg end)
- (re-search-forward
- (concat "\\(?1:" change-log-unindented-file-names-re
- "\\)\\|^\\(?1:\\)[[:blank:]]*(")
- end t)
- (copy-marker (match-end 1)))
- ;; Fill prose between log entries.
- do (let ((fill-indent-according-to-mode t)
- (end (if defuns-beg (match-beginning 0) end))
- (beg (progn (goto-char beg) (line-beginning-position))))
- (when (<= (line-end-position) end)
- (fill-region beg end justify)))
- while defuns-beg
- for defuns = (progn (goto-char defuns-beg)
- (change-log-read-defuns end))
- do (progn (delete-region defuns-beg (point))
- (log-edit--insert-filled-defuns defuns)
- (setq beg (point))))
+ (let* ((defuns-beg nil)
+ (defuns nil))
+ (while
+ (progn
+ ;; Match a regexp against the next ChangeLog entry.
+ ;; `defuns-beg' will be the end of the file name,
+ ;; which marks the beginning of the list of defuns.
+ (setq defuns-beg
+ (and (< beg end)
+ (re-search-forward
+ (concat "\\(?1:"
+ change-log-unindented-file-names-re
+ "\\)\\|^\\(?1:\\)[[:blank:]]*(")
+ end t)
+ (copy-marker (match-end 1))))
+ ;; Fill the intervening prose between the end of the
+ ;; last match and the beginning of the current match.
+ (let ((fill-indent-according-to-mode t)
+ (end (if defuns-beg
+ (match-beginning 0) end))
+ (beg (progn (goto-char beg)
+ (line-beginning-position)))
+ space-beg space-end)
+ (when (<= (line-end-position) end)
+ ;; Replace space characters within parentheses
+ ;; that resemble ChangeLog defun names between BEG
+ ;; and END with non-breaking spaces to prevent
+ ;; them from being considered break points by
+ ;; `fill-region'.
+ (save-excursion
+ (goto-char beg)
+ (when (re-search-forward
+ "^[[:blank:]]*(.*\\([[:space:]]\\).*):"
+ end t)
+ (replace-regexp-in-region "[[:space:]]" " "
+ (setq space-beg
+ (copy-marker
+ (match-beginning 0)))
+ (setq space-end
+ (copy-marker
+ (match-end 0))))))
+ (fill-region beg end justify))
+ ;; Restore the spaces replaced by NBSPs.
+ (when space-beg
+ (replace-string-in-region " " " "
+ space-beg space-end)
+ (set-marker space-beg nil)
+ (set-marker space-end nil)))
+ defuns-beg)
+ (goto-char defuns-beg)
+ (setq defuns (change-log-read-defuns end))
+ (progn
+ (delete-region defuns-beg (point))
+ (log-edit--insert-filled-defuns defuns)
+ (setq beg (point))))
+ nil)
t))))
(defun log-edit-hide-buf (&optional buf where)
@@ -1219,7 +1378,10 @@ line of MSG."
(let ((pt (point)))
(and (zerop (forward-line 1))
(looking-at "\n\\|\\'")
- (let ((summary (buffer-substring-no-properties pt (1- (point)))))
+ (let ((summary (buffer-substring-no-properties pt
+ (if (bolp)
+ (1- (point))
+ (point)))))
(skip-chars-forward " \n")
(delete-region pt (point))
(log-edit-set-header "Summary" summary)))))))
@@ -1227,3 +1389,7 @@ line of MSG."
(provide 'log-edit)
;;; log-edit.el ends here
+
+;; Local Variables:
+;; coding: utf-8-unix
+;; End:
diff --git a/lisp/vc/log-view.el b/lisp/vc/log-view.el
index 98460b1aba8..e9e6602e414 100644
--- a/lisp/vc/log-view.el
+++ b/lisp/vc/log-view.el
@@ -516,7 +516,8 @@ If called interactively, visit the version at point."
(switch-to-buffer (vc-find-revision (if log-view-per-file-logs
(log-view-current-file)
(car log-view-vc-fileset))
- (log-view-current-tag)))))
+ (log-view-current-tag)
+ log-view-vc-backend))))
(defun log-view-extract-comment ()
@@ -562,7 +563,8 @@ If called interactively, annotate the version at point."
(vc-annotate (if log-view-per-file-logs
(log-view-current-file)
(car log-view-vc-fileset))
- (log-view-current-tag))))
+ (log-view-current-tag)
+ nil nil nil log-view-vc-backend)))
;;
;; diff
diff --git a/lisp/vc/smerge-mode.el b/lisp/vc/smerge-mode.el
index f224246f40b..a16c7871ff9 100644
--- a/lisp/vc/smerge-mode.el
+++ b/lisp/vc/smerge-mode.el
@@ -255,10 +255,6 @@ Can be nil if the style is undecided, or else:
- `diff3-E'
- `diff3-A'")
-;; Compiler pacifiers
-(defvar font-lock-mode)
-(defvar font-lock-keywords)
-
;;;;
;;;; Actual code
;;;;
@@ -1243,7 +1239,11 @@ spacing of the \"Lower\" chunk."
(write-region beg1 end1 file1 nil 'nomessage)
(write-region beg2 end2 file2 nil 'nomessage)
(unwind-protect
- (with-current-buffer (get-buffer-create smerge-diff-buffer-name)
+ (save-current-buffer
+ (if-let (buffer (get-buffer smerge-diff-buffer-name))
+ (set-buffer buffer)
+ (set-buffer (get-buffer-create smerge-diff-buffer-name))
+ (setq buffer-read-only t))
(setq default-directory dir)
(let ((inhibit-read-only t))
(erase-buffer)
diff --git a/lisp/vc/vc-annotate.el b/lisp/vc/vc-annotate.el
index 43432f5602e..b206abec27f 100644
--- a/lisp/vc/vc-annotate.el
+++ b/lisp/vc/vc-annotate.el
@@ -162,6 +162,11 @@ List of factors, used to expand/compress the time scale. See `vc-annotate'."
:type '(repeat number)
:group 'vc)
+(defcustom vc-annotate-use-short-revision t
+ "If non-nil, \\[vc-annotate] will use short revisions in its buffer name."
+ :type 'boolean
+ :group 'vc)
+
(defvar-keymap vc-annotate-mode-map
:doc "Local keymap used for VC-Annotate mode."
"a" #'vc-annotate-revision-previous-to-line
@@ -397,7 +402,10 @@ should be applied to the background or to the foreground."
(save-current-buffer
(vc-ensure-vc-buffer)
(list buffer-file-name
- (let ((def (vc-working-revision buffer-file-name)))
+ (let ((def (funcall (if vc-annotate-use-short-revision
+ #'vc-short-revision
+ #'vc-working-revision)
+ buffer-file-name)))
(if (null current-prefix-arg) def
(vc-read-revision
(format-prompt "Annotate from revision" def)
@@ -718,23 +726,24 @@ The annotations are relative to the current time, unless overridden by OFFSET."
(let* ((color (or (vc-annotate-compcar difference vc-annotate-color-map)
(cons nil vc-annotate-very-old-color)))
;; substring from index 1 to remove any leading `#' in the name
- (face-name (concat "vc-annotate-face-"
- (if (string-equal
- (substring (cdr color) 0 1) "#")
- (substring (cdr color) 1)
- (cdr color))))
+ (face (intern (concat "vc-annotate-face-"
+ (if (string-equal
+ (substring (cdr color) 0 1) "#")
+ (substring (cdr color) 1)
+ (cdr color)))))
;; Make the face if not done.
- (face (or (intern-soft face-name)
- (let ((tmp-face (make-face (intern face-name))))
- (set-face-extend tmp-face t)
- (cond
- (vc-annotate-background-mode
- (set-face-background tmp-face (cdr color)))
- (t
- (set-face-foreground tmp-face (cdr color))
- (when vc-annotate-background
- (set-face-background tmp-face vc-annotate-background))))
- tmp-face)))) ; Return the face
+ (face (if (facep face)
+ face
+ (make-face face)
+ (set-face-extend face t)
+ (cond
+ (vc-annotate-background-mode
+ (set-face-background face (cdr color)))
+ (t
+ (set-face-foreground face (cdr color))
+ (when vc-annotate-background
+ (set-face-background face vc-annotate-background))))
+ face)))
(put-text-property start end 'face face)))))
;; Pretend to font-lock there were no matches.
nil)
diff --git a/lisp/vc/vc-cvs.el b/lisp/vc/vc-cvs.el
index df45b7e3157..63b566b0afe 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))
+(eval-when-compile (require 'cl-lib))
(require 'log-view)
(declare-function vc-checkout "vc" (file &optional rev))
@@ -475,7 +476,7 @@ The changes are between FIRST-REVISION and SECOND-REVISION."
(concat "-j" first-revision)
(concat "-j" second-revision))
(vc-file-setprop file 'vc-state 'edited)
- (with-current-buffer (get-buffer "*vc*")
+ (with-current-buffer "*vc*"
(goto-char (point-min))
(if (re-search-forward "conflicts during merge" nil t)
(progn
@@ -494,7 +495,7 @@ The changes are between FIRST-REVISION and SECOND-REVISION."
(vc-cvs-command nil nil file "update")
;; Analyze the merge result reported by CVS, and set
;; file properties accordingly.
- (with-current-buffer (get-buffer "*vc*")
+ (with-current-buffer "*vc*"
(goto-char (point-min))
;; get new working revision
(if (re-search-forward
@@ -813,7 +814,10 @@ individually should stay local."
'yes 'no))))))))))))
(defun vc-cvs-repository-hostname (dirname)
- "Hostname of the CVS server associated to workarea DIRNAME."
+ "Hostname of the CVS server associated to workarea DIRNAME.
+
+Return nil if there is no hostname, or the hostname could not be
+determined because the CVS/Root specification is invalid."
(let ((rootname (expand-file-name "CVS/Root" dirname)))
(when (file-readable-p rootname)
(with-temp-buffer
@@ -822,73 +826,146 @@ individually should stay local."
default-file-name-coding-system)))
(vc-insert-file rootname))
(goto-char (point-min))
- (nth 2 (vc-cvs-parse-root
- (buffer-substring (point)
- (line-end-position))))))))
-
-(defun vc-cvs-parse-uhp (path)
- "Parse user@host/path into (user@host /path)."
- (if (string-match "\\([^/]+\\)\\(/.*\\)" path)
- (list (match-string 1 path) (match-string 2 path))
- (list nil path)))
-
-(defun vc-cvs-parse-root (root)
- "Split CVS ROOT specification string into a list of fields.
-A CVS root specification of the form
- [:METHOD:][[USER@]HOSTNAME]:?/path/to/repository
-is converted to a normalized record with the following structure:
- \(METHOD USER HOSTNAME CVS-ROOT).
-The default METHOD for a CVS root of the form
- /path/to/repository
-is `local'.
-The default METHOD for a CVS root of the form
- [USER@]HOSTNAME:/path/to/repository
-is `ext'.
-For an empty string, nil is returned (invalid CVS root)."
- ;; Split CVS root into colon separated fields (0-4).
- ;; The `x:' makes sure, that leading colons are not lost;
- ;; `HOST:/PATH' is then different from `:METHOD:/PATH'.
- (let* ((root-list (cdr (split-string (concat "x:" root) ":")))
- (len (length root-list))
- ;; All syntactic varieties will get a proper METHOD.
- (root-list
- (cond
- ((= len 0)
- ;; Invalid CVS root
- nil)
- ((= len 1)
- (let ((uhp (vc-cvs-parse-uhp (car root-list))))
- (cons (if (car uhp) "ext" "local") uhp)))
- ((= len 2)
- ;; [USER@]HOST:PATH => method `ext'
- (and (not (equal (car root-list) ""))
- (cons "ext" root-list)))
- ((= len 3)
- ;; :METHOD:PATH or :METHOD:USER@HOSTNAME/PATH
- (cons (cadr root-list)
- (vc-cvs-parse-uhp (nth 2 root-list))))
- (t
- ;; :METHOD:[USER@]HOST:PATH
- (cdr root-list)))))
- (if root-list
- (let ((method (car root-list))
- (uhost (or (cadr root-list) ""))
- (root (nth 2 root-list))
- user host)
- ;; Split USER@HOST
- (if (string-match "\\(.*\\)@\\(.*\\)" uhost)
- (setq user (match-string 1 uhost)
- host (match-string 2 uhost))
- (setq host uhost))
- ;; Remove empty HOST
- (and (equal host "")
- (setq host nil))
- ;; Fix windows style CVS root `:local:C:\\project\\cvs\\some\\dir'
- (and host
- (equal method "local")
- (setq root (concat host ":" root) host nil))
- ;; Normalize CVS root record
- (list method user host root)))))
+ (let ((hostname
+ (nth 2 (vc-cvs-parse-root
+ (buffer-substring (point)
+ (line-end-position))))))
+ (unless (string= hostname "")
+ hostname))))))
+
+(cl-defun vc-cvs-parse-root (root)
+ "Split CVS Root specification string into a list of fields.
+
+Convert a CVS Root specification of the form
+
+ [:METHOD:][[[USER][:PASSWORD]@]HOSTNAME][:[PORT]]/path/to/repository
+
+to a normalized record with the following structure:
+
+ \(METHOD USER HOSTNAME FILENAME).
+
+The default METHOD for a CVS root of the form /path/to/repository
+is \"local\". The default METHOD for a CVS root of the
+form [USER@]HOSTNAME:/path/to/repository is \"ext\".
+
+If METHOD is explicitly \"local\" or \"fork\", then the repository's
+file name starts immediately after the [:METHOD:] part. This must be
+used on MS-Windows platforms where absolute file names start with a
+drive letter.
+
+Note that, except for METHOD, which is defaulted if not present,
+other optional parts will default to nil if not syntactically
+present, or to an empty string if present and delimited, but empty.
+
+Return nil in case of an unparsable CVS Root (including the
+empty string), and issue a warning in that case.
+
+This function doesn't check that an explicit method is valid, or
+that some fields which should not be empty for a given method,
+are empty or nil."
+ (let (method user password hostname port filename
+ ;; IDX set by `next-delim' as a side-effect
+ idx)
+ (cl-labels
+ ((invalid (reason &rest args)
+ (apply #'lwarn '(vc-cvs) :warning
+ (concat "vc-cvs-parse-root: Can't parse '%s': " reason)
+ root args)
+ (cl-return-from vc-cvs-parse-root))
+ (no-filename ()
+ (invalid "No repository file name"))
+ (next-delim (start)
+ ;; Search for a :, @ or /. If none is found, there can be
+ ;; no file name at the end, which is an error.
+ (setq idx (string-match-p "[:@/]" root start))
+ (if idx (aref root idx) (no-filename)))
+ (grab-user (start end)
+ (setq user (substring root start end)))
+ (at-hostname-block (start)
+ (let ((cand (next-delim start)))
+ (cl-ecase cand
+ (?:
+ ;; Could be : before PORT and /path/to/repository, or
+ ;; before PASSWORD. We search for a @ to disambiguate.
+ (let ((colon-idx idx)
+ (cand (next-delim (1+ idx))))
+ (cl-ecase cand
+ (?:
+ (invalid
+ (eval-when-compile
+ (concat "Hostname block: Superfluous : at %s "
+ "or missing @ before"))
+ idx))
+ (?@
+ ;; USER:PASSWORD case
+ (grab-user start colon-idx)
+ (delimited-password (1+ colon-idx) idx))
+ (?/
+ ;; HOSTNAME[:[PORT]] case
+ (grab-hostname start colon-idx)
+ (delimited-port (1+ colon-idx) idx)))))
+ (?@
+ (grab-user start idx)
+ (at-hostname (1+ idx)))
+ (?/
+ (if (/= idx start)
+ (grab-hostname start idx))
+ (at-filename idx)))))
+ (delimited-password (start end)
+ (setq password (substring root start end))
+ (at-hostname (1+ end)))
+ (grab-hostname (start end)
+ (setq hostname (substring root start end)))
+ (at-hostname (start)
+ (let ((cand (next-delim start)))
+ (cl-ecase cand
+ (?:
+ (grab-hostname start idx)
+ (at-port (1+ idx)))
+ (?@
+ (invalid "Hostname: Unexpected @ after index %s" start))
+ (?/
+ (grab-hostname start idx)
+ (at-filename idx)))))
+ (delimited-port (start end)
+ (setq port (substring root start end))
+ (at-filename end))
+ (at-port (start)
+ (let ((end (string-match-p "/" root start)))
+ (if end (delimited-port start end) (no-filename))))
+ (at-filename (start)
+ (setq filename (substring root start))))
+ (when (string= root "")
+ (invalid "Empty Root string"))
+ ;; Check for a starting ":"
+ (if (= (aref root 0) ?:)
+ ;; 3 possible cases:
+ ;; - :METHOD: at start. METHOD doesn't have any @.
+ ;; - :PASSWORD@ at start. Must be followed by HOSTNAME.
+ ;; - :[PORT] at start. Must be followed immediately by a "/".
+ ;; So, find the next character equal to ":", "@" or "/".
+ (let ((cand (next-delim 1)))
+ (cl-ecase cand
+ (?:
+ ;; :METHOD: case
+ (setq method (substring root 1 idx))
+ ;; Continue
+ (if (member method '("local" "fork"))
+ (at-filename (1+ idx))
+ (at-hostname-block (1+ idx))))
+ (?@
+ ;; :PASSWORD@HOSTNAME case
+ (delimited-password 1 idx))
+ (?/
+ ;; :[PORT] case.
+ (at-port 1 idx))))
+ ;; No starting ":", there can't be any METHOD.
+ (at-hostname-block 0)))
+ (unless method
+ ;; Default the method if not specified
+ (setq method
+ (if (or user password hostname port) "ext" "local")))
+ (list method user hostname filename)))
;; XXX: This does not work correctly for subdirectories. "cvs status"
;; information is context sensitive, it contains lines like:
@@ -899,7 +976,7 @@ For an empty string, nil is returned (invalid CVS root)."
(defun vc-cvs-parse-status (&optional full)
"Parse output of \"cvs status\" command in the current buffer.
Set file properties accordingly. Unless FULL is t, parse only
-essential information. Note that this can never set the `ignored'
+essential information. Note that this can never set the `ignored'
state."
(let (file status missing)
(goto-char (point-min))
@@ -955,13 +1032,16 @@ state."
(cdr (assoc (char-after) translation)))
result)
(cond
- ((looking-at "cvs update: warning: \\(.*\\) was lost")
+ ((looking-at "cvs update: warning: .* was lost")
;; Format is:
;; cvs update: warning: FILENAME was lost
;; U FILENAME
- (push (list (match-string 1) 'missing) result)
- ;; Skip the "U" line
- (forward-line 1))
+ ;; with FILENAME in the first line possibly enclosed in
+ ;; quotes (since CVS 1.12.3). To avoid problems, use the U
+ ;; line where name is never quoted.
+ (forward-line 1)
+ (when (looking-at "^U \\(.*\\)$")
+ (push (list (match-string 1) 'missing) result)))
((looking-at "cvs update: New directory `\\(.*\\)' -- ignored")
(push (list (match-string 1) 'unregistered) result))))
(forward-line 1))
diff --git a/lisp/vc/vc-dir.el b/lisp/vc/vc-dir.el
index fa18fddfc3e..d733b36f8ff 100644
--- a/lisp/vc/vc-dir.el
+++ b/lisp/vc/vc-dir.el
@@ -785,8 +785,7 @@ MARK-FILES should be a list of absolute filenames."
(defun vc-dir-mark-state-files (states)
"Mark files that are in the state specified by the list in STATES."
- (unless (listp states)
- (setq states (list states)))
+ (setq states (ensure-list states))
(ewoc-map
(lambda (filearg)
(when (memq (vc-dir-fileinfo->state filearg) states)
diff --git a/lisp/vc/vc-git.el b/lisp/vc/vc-git.el
index 9c37730f462..b23a5ca95a1 100644
--- a/lisp/vc/vc-git.el
+++ b/lisp/vc/vc-git.el
@@ -89,6 +89,7 @@
;; - make-version-backups-p (file) NOT NEEDED
;; - previous-revision (file rev) OK
;; - next-revision (file rev) OK
+;; - file-name-changes (rev) OK
;; - check-headers () COULD BE SUPPORTED
;; - delete-file (file) OK
;; - rename-file (old new) OK
@@ -122,7 +123,10 @@ If nil, use the value of `vc-diff-switches'. If t, use no switches."
(defcustom vc-git-annotate-switches nil
"String or list of strings specifying switches for Git blame under VC.
-If nil, use the value of `vc-annotate-switches'. If t, use no switches."
+If nil, use the value of `vc-annotate-switches'. If t, use no switches.
+
+Tip: Set this to \"-w\" to make Git blame ignore whitespace when
+comparing changes. See Man page `git-blame' for more."
:type '(choice (const :tag "Unspecified" nil)
(const :tag "None" t)
(string :tag "Argument String")
@@ -136,12 +140,31 @@ If nil, use the value of `vc-annotate-switches'. If t, use no switches."
;;;###autoload(put 'vc-git-annotate-switches 'safe-local-variable (lambda (switches) (equal switches "-w")))
(defcustom vc-git-log-switches nil
- "String or list of strings specifying switches for Git log under VC."
+ "String or list of strings giving Git log switches for non-shortlogs."
:type '(choice (const :tag "None" nil)
(string :tag "Argument String")
(repeat :tag "Argument List" :value ("") string))
:version "28.1")
+(defcustom vc-git-shortlog-switches nil
+ "String or list of strings giving Git log switches for shortlogs."
+ :type '(choice (const :tag "None" nil)
+ (string :tag "Argument String")
+ (repeat :tag "Argument List" :value ("") string))
+ :version "30.1")
+
+(defcustom vc-git-file-name-changes-switches '("-M" "-C")
+ "String or list of string to pass to Git when finding previous names.
+
+This option should usually at least contain '-M'. You can adjust
+the flags to change the similarity thresholds (default 50%). Or
+add `--find-copies-harder' (slower in large projects, since it
+uses a full scan)."
+ :type '(choice (const :tag "None" nil)
+ (string :tag "Argument String")
+ (repeat :tag "Argument List" :value ("") string))
+ :version "30.1")
+
(defcustom vc-git-resolve-conflicts t
"When non-nil, mark conflicted file as resolved upon saving.
That is performed after all conflict markers in it have been
@@ -308,6 +331,23 @@ Good example of file name that needs this: \"test[56].xx\".")
(string-trim-right (match-string 1 version-string) "\\.")
"0")))))
+(defun vc-git--git-path (&optional path)
+ "Resolve .git/PATH for the current working tree.
+In particular, handle the case where this is a linked working
+tree, such that .git is a plain file.
+
+See the --git-dir and --git-path options to git-rev-parse(1)."
+ (if (and path (not (string-empty-p path)))
+ ;; Canonicalize in this branch because --git-dir always returns
+ ;; an absolute file name.
+ (expand-file-name
+ (string-trim-right
+ (vc-git--run-command-string nil "rev-parse"
+ "--git-path" path)))
+ (concat (string-trim-right
+ (vc-git--run-command-string nil "rev-parse" "--git-dir"))
+ "/")))
+
(defun vc-git--git-status-to-vc-state (code-list)
"Convert CODE-LIST to a VC status.
@@ -389,15 +429,20 @@ in the order given by `git status'."
(defun vc-git-mode-line-string (file)
"Return a string for `vc-mode-line' to put in the mode line for FILE."
- (let* ((rev (vc-working-revision file 'Git))
- (disp-rev (or (vc-git--symbolic-ref file)
- (and rev (substring rev 0 7))))
- (def-ml (vc-default-mode-line-string 'Git file))
- (help-echo (get-text-property 0 'help-echo def-ml))
- (face (get-text-property 0 'face def-ml)))
- (propertize (concat (substring def-ml 0 4) disp-rev)
- 'face face
- 'help-echo (concat help-echo "\nCurrent revision: " rev))))
+ (pcase-let* ((backend-name "Git")
+ (state (vc-state file))
+ (`(,state-echo ,face ,indicator)
+ (vc-mode-line-state state))
+ (rev (vc-working-revision file 'Git))
+ (disp-rev (or (vc-git--symbolic-ref file)
+ (and rev (substring rev 0 7))))
+ (state-string (concat (unless (eq vc-display-status 'no-backend)
+ backend-name)
+ indicator disp-rev)))
+ (propertize state-string 'face face 'help-echo
+ (concat state-echo " under the " backend-name
+ " version control system"
+ "\nCurrent revision: " rev))))
(cl-defstruct (vc-git-extra-fileinfo
(:copier nil)
@@ -752,27 +797,51 @@ or an empty string if none."
:help "Show the contents of the current stash"))
map))
+(defun vc-git--cmds-in-progress ()
+ "Return a list of Git commands in progress in this worktree."
+ (let ((gitdir (vc-git--git-path))
+ cmds)
+ ;; See contrib/completion/git-prompt.sh in git.git.
+ (when (or (file-directory-p
+ (expand-file-name "rebase-merge" gitdir))
+ (file-exists-p
+ (expand-file-name "rebase-apply/rebasing" gitdir)))
+ (push 'rebase cmds))
+ (when (file-exists-p
+ (expand-file-name "rebase-apply/applying" gitdir))
+ (push 'am cmds))
+ (when (file-exists-p (expand-file-name "MERGE_HEAD" gitdir))
+ (push 'merge cmds))
+ (when (file-exists-p (expand-file-name "BISECT_START" gitdir))
+ (push 'bisect cmds))
+ cmds))
+
(defun vc-git-dir-extra-headers (dir)
- (let ((str (with-output-to-string
- (with-current-buffer standard-output
- (vc-git--out-ok "symbolic-ref" "HEAD"))))
+ (let ((str (vc-git--out-str "symbolic-ref" "HEAD"))
(stash-list (vc-git-stash-list))
(default-directory dir)
+ (in-progress (vc-git--cmds-in-progress))
- branch remote remote-url stash-button stash-string)
+ branch remote-url stash-button stash-string tracking-branch)
(if (string-match "^\\(refs/heads/\\)?\\(.+\\)$" str)
(progn
(setq branch (match-string 2 str))
- (setq remote
- (with-output-to-string
- (with-current-buffer standard-output
- (vc-git--out-ok "config"
- (concat "branch." branch ".remote")))))
- (when (string-match "\\([^\n]+\\)" remote)
- (setq remote (match-string 1 remote)))
- (when (> (length remote) 0)
- (setq remote-url (vc-git-repository-url dir remote))))
- (setq branch "not (detached HEAD)"))
+ (let ((remote (vc-git--out-str
+ "config" (concat "branch." branch ".remote")))
+ (merge (vc-git--out-str
+ "config" (concat "branch." branch ".merge"))))
+ (when (string-match "\\([^\n]+\\)" remote)
+ (setq remote (match-string 1 remote)))
+ (when (string-match "^\\(refs/heads/\\)?\\(.+\\)$" merge)
+ (setq tracking-branch (match-string 2 merge)))
+ (pcase remote
+ ("."
+ (setq remote-url "none (tracking local branch)"))
+ ((pred (not string-empty-p))
+ (setq
+ remote-url (vc-git-repository-url dir remote)
+ tracking-branch (concat remote "/" tracking-branch))))))
+ (setq branch "none (detached HEAD)"))
(when stash-list
(let* ((len (length stash-list))
(limit
@@ -825,6 +894,11 @@ or an empty string if none."
(propertize "Branch : " 'face 'vc-dir-header)
(propertize branch
'face 'vc-dir-header-value)
+ (when tracking-branch
+ (concat
+ "\n"
+ (propertize "Tracking : " 'face 'vc-dir-header)
+ (propertize tracking-branch 'face 'vc-dir-header-value)))
(when remote-url
(concat
"\n"
@@ -832,9 +906,9 @@ or an empty string if none."
(propertize remote-url
'face 'vc-dir-header-value)))
;; For now just a heading, key bindings can be added later for various bisect actions
- (when (file-exists-p (expand-file-name ".git/BISECT_START" (vc-git-root dir)))
+ (when (memq 'bisect in-progress)
(propertize "\nBisect : in progress" 'face 'vc-dir-status-warning))
- (when (file-exists-p (expand-file-name ".git/rebase-apply" (vc-git-root dir)))
+ (when (memq 'rebase in-progress)
(propertize "\nRebase : in progress" 'face 'vc-dir-status-warning))
(if stash-list
(concat
@@ -1016,13 +1090,26 @@ It is based on `log-edit-mode', and has Git-specific extensions."
(if (eq system-type 'windows-nt)
(let ((default-directory (or (file-name-directory file1)
default-directory)))
- (make-nearby-temp-file "git-msg")))))
+ (make-nearby-temp-file "git-msg"))))
+ to-stash)
(when vc-git-patch-string
(unless (zerop (vc-git-command nil t nil "diff" "--cached" "--quiet"))
- ;; Check that all staged changes also exist in the patch.
- ;; This is needed to allow adding/removing files that are
- ;; currently staged to the index. So remove the whole file diff
- ;; from the patch because commit will take it from the index.
+ ;; Check that what's already staged is compatible with what
+ ;; we want to commit (bug#60126).
+ ;;
+ ;; 1. If the changes to a file in the index are identical to
+ ;; the changes to that file we want to commit, remove the
+ ;; changes from our patch, and let the commit take them
+ ;; from the index. This is necessary for adding and
+ ;; removing files to work.
+ ;;
+ ;; 2. If the changes to a file in the index are different to
+ ;; changes to that file we want to commit, then we have to
+ ;; unstage the changes or abort.
+ ;;
+ ;; 3. If there are changes to a file in the index but we don't
+ ;; want to commit any changes to that file, we need to
+ ;; stash those changes before committing.
(with-temp-buffer
;; If the user has switches like -D, -M etc. in their
;; `vc-git-diff-switches', we must pass them here too, or
@@ -1033,23 +1120,35 @@ It is based on `log-edit-mode', and has Git-specific extensions."
;; Following code doesn't understand plain diff(1) output.
(user-error "Cannot commit patch with nil `vc-git-diff-switches'"))
(goto-char (point-min))
- (let ((pos (point)) file-diff file-beg)
+ (let ((pos (point)) file-name file-header file-diff file-beg)
(while (not (eobp))
+ (when (and (looking-at "^diff --git a/\\(.+\\) b/\\(.+\\)")
+ (string= (match-string 1) (match-string 2)))
+ (setq file-name (match-string 1)))
(forward-line 1) ; skip current "diff --git" line
+ (setq file-header (buffer-substring pos (point)))
(search-forward "diff --git" nil 'move)
(move-beginning-of-line 1)
(setq file-diff (buffer-substring pos (point)))
- (if (and (setq file-beg (string-search
- file-diff vc-git-patch-string))
- ;; Check that file diff ends with an empty string
- ;; or the beginning of the next file diff.
- (string-match-p "\\`\\'\\|\\`diff --git"
- (substring
- vc-git-patch-string
- (+ file-beg (length file-diff)))))
- (setq vc-git-patch-string
- (string-replace file-diff "" vc-git-patch-string))
- (user-error "Index not empty"))
+ (cond ((and (setq file-beg (string-search
+ file-diff vc-git-patch-string))
+ ;; Check that file diff ends with an empty string
+ ;; or the beginning of the next file diff.
+ (string-match-p "\\`\\'\\|\\`diff --git"
+ (substring
+ vc-git-patch-string
+ (+ file-beg (length file-diff)))))
+ (setq vc-git-patch-string
+ (string-replace file-diff "" vc-git-patch-string)))
+ ((string-match (format "^%s" (regexp-quote file-header))
+ vc-git-patch-string)
+ (if (and file-name
+ (yes-or-no-p
+ (format "Unstage already-staged changes to %s?"
+ file-name)))
+ (vc-git-command nil 0 file-name "reset" "-q" "--")
+ (user-error "Index not empty")))
+ (t (push file-name to-stash)))
(setq pos (point))))))
(unless (string-empty-p vc-git-patch-string)
(let ((patch-file (make-nearby-temp-file "git-patch"))
@@ -1065,7 +1164,8 @@ It is based on `log-edit-mode', and has Git-specific extensions."
(insert vc-git-patch-string))
(unwind-protect
(vc-git-command nil 0 patch-file "apply" "--cached")
- (delete-file patch-file)))))
+ (delete-file patch-file))))
+ (when to-stash (vc-git--stash-staged-changes files)))
(cl-flet ((boolean-arg-fn
(argument)
(lambda (value) (when (equal value "yes") (list argument)))))
@@ -1091,7 +1191,58 @@ It is based on `log-edit-mode', and has Git-specific extensions."
args)
(unless vc-git-patch-string
(if only (list "--only" "--") '("-a"))))))
- (if (and msg-file (file-exists-p msg-file)) (delete-file msg-file))))
+ (if (and msg-file (file-exists-p msg-file)) (delete-file msg-file))
+ (when to-stash
+ (let ((cached (make-nearby-temp-file "git-cached")))
+ (unwind-protect
+ (progn (with-temp-file cached
+ (vc-git-command t 0 nil "stash" "show" "-p"))
+ (vc-git-command nil 0 cached "apply" "--cached"))
+ (delete-file cached))
+ (vc-git-command nil 0 nil "stash" "drop")))))
+
+(defun vc-git--stash-staged-changes (files)
+ "Stash only the staged changes to FILES."
+ ;; This is necessary because even if you pass a list of file names
+ ;; to 'git stash push', it will stash any and all staged changes.
+ (unless (zerop
+ (vc-git-command nil t files "diff" "--cached" "--quiet"))
+ (cl-flet
+ ((git-string (&rest args)
+ (string-trim-right
+ (with-output-to-string
+ (apply #'vc-git-command standard-output 0 nil args)))))
+ (let ((cached (make-nearby-temp-file "git-cached"))
+ (message "Previously staged changes")
+ tree)
+ ;; Use a temporary index to create a tree object corresponding
+ ;; to the staged changes to FILES.
+ (unwind-protect
+ (progn
+ (with-temp-file cached
+ (vc-git-command t 0 files "diff" "--cached" "--"))
+ (let* ((index (make-nearby-temp-file "git-index"))
+ (process-environment
+ (cons (format "GIT_INDEX_FILE=%s" index)
+ process-environment)))
+ (unwind-protect
+ (progn
+ (vc-git-command nil 0 nil "read-tree" "HEAD")
+ (vc-git-command nil 0 cached "apply" "--cached")
+ (setq tree (git-string "write-tree")))
+ (delete-file index))))
+ (delete-file cached))
+ ;; Prepare stash commit object, which has a special structure.
+ (let* ((tree-commit (git-string "commit-tree" "-m" message
+ "-p" "HEAD" tree))
+ (stash-commit (git-string "commit-tree" "-m" message
+ "-p" "HEAD" "-p" tree-commit
+ tree)))
+ ;; Push the new stash entry.
+ (vc-git-command nil 0 nil "update-ref" "--create-reflog"
+ "-m" message "refs/stash" stash-commit)
+ ;; Unstage the changes we've now stashed.
+ (vc-git-command nil 0 files "reset" "--"))))))
(defun vc-git-find-revision (file rev buffer)
(let* (process-file-side-effects
@@ -1202,8 +1353,7 @@ This prompts for a branch to merge from."
(completing-read "Merge from branch: "
(if (or (member "FETCH_HEAD" branches)
(not (file-readable-p
- (expand-file-name ".git/FETCH_HEAD"
- root))))
+ (vc-git--git-path "FETCH_HEAD"))))
branches
(cons "FETCH_HEAD" branches))
nil t)))
@@ -1231,8 +1381,10 @@ This prompts for a branch to merge from."
(defun vc-git-repository-url (file-or-dir &optional remote-name)
(let ((default-directory (vc-git-root file-or-dir)))
(with-temp-buffer
- (vc-git-command (current-buffer) 0 nil "remote" "get-url"
- (or remote-name "origin"))
+ ;; The "get-url" subcommand of "git remote" was new in git 2.7.0;
+ ;; "git config" also works in older versions. -- rgr, 15-Aug-23.
+ (let ((opt-name (concat "remote." (or remote-name "origin") ".url")))
+ (vc-git-command (current-buffer) 0 (list "config" "--get" opt-name)))
(buffer-substring-no-properties (point-min) (1- (point-max))))))
;; Everywhere but here, follows vc-git-command, which uses vc-do-command
@@ -1248,8 +1400,7 @@ This prompts for a branch to merge from."
(unless (or
(not (eq vc-git-resolve-conflicts 'unstage-maybe))
;; Doing a merge, so bug#20292 doesn't apply.
- (file-exists-p (expand-file-name ".git/MERGE_HEAD"
- (vc-git-root buffer-file-name)))
+ (file-exists-p (vc-git--git-path "MERGE_HEAD"))
(vc-git-conflicted-files (vc-git-root buffer-file-name)))
(vc-git-command nil 0 nil "reset"))
(vc-resynch-buffer buffer-file-name t t)
@@ -1269,9 +1420,16 @@ This prompts for a branch to merge from."
(vc-message-unresolved-conflicts buffer-file-name)))
(defun vc-git-clone (remote directory rev)
- (if rev
- (vc-git--out-ok "clone" "--branch" rev remote directory)
+ "Attempt to clone REMOTE repository into DIRECTORY at revision REV."
+ (cond
+ ((null rev)
(vc-git--out-ok "clone" remote directory))
+ ((ignore-errors
+ (vc-git--out-ok "clone" "--branch" rev remote directory)))
+ ((vc-git--out-ok "clone" remote directory)
+ (let ((default-directory directory))
+ (vc-git--out-ok "checkout" rev)))
+ ((error "Failed to check out %s at %s" remote rev)))
directory)
;;; HISTORY FUNCTIONS
@@ -1287,7 +1445,16 @@ This prompts for a branch to merge from."
;; Long explanation here:
;; https://stackoverflow.com/questions/46487476/git-log-follow-graph-skips-commits
(defcustom vc-git-print-log-follow nil
- "If true, follow renames in Git logs for a single file."
+ "If non-nil, use the flag `--follow' when producing single file logs.
+
+A non-nil value will make the printed log automatically follow
+the file renames. The downsides is that the log produced this
+way may omit certain (merge) commits, and that `log-view-diff'
+fails on commits that used the previous name, in that log buffer.
+
+When this variable is nil, and the log ends with a rename, we
+show a button below that which allows to show the log for the
+file name before the rename."
:type 'boolean
:version "26.1")
@@ -1324,7 +1491,8 @@ If LIMIT is a revision string, use it as an end-revision."
,(format "--pretty=tformat:%s"
(car vc-git-root-log-format))
"--abbrev-commit"))
- (ensure-list vc-git-log-switches)
+ (ensure-list
+ (if shortlog vc-git-shortlog-switches vc-git-log-switches))
(when (numberp limit)
(list "-n" (format "%s" limit)))
(when start-revision
@@ -1339,16 +1507,16 @@ If LIMIT is a revision string, use it as an end-revision."
(defun vc-git-log-outgoing (buffer remote-location)
(vc-setup-buffer buffer)
- (vc-git-command
- buffer 'async nil
- "log"
- "--no-color" "--graph" "--decorate" "--date=short"
- (format "--pretty=tformat:%s" (car vc-git-root-log-format))
- "--abbrev-commit"
- (concat (if (string= remote-location "")
- "@{upstream}"
- remote-location)
- "..HEAD")))
+ (apply #'vc-git-command buffer 'async nil
+ `("log"
+ "--no-color" "--graph" "--decorate" "--date=short"
+ ,(format "--pretty=tformat:%s" (car vc-git-root-log-format))
+ "--abbrev-commit"
+ ,@(ensure-list vc-git-shortlog-switches)
+ ,(concat (if (string= remote-location "")
+ "@{upstream}"
+ remote-location)
+ "..HEAD"))))
(defun vc-git-log-incoming (buffer remote-location)
(vc-setup-buffer buffer)
@@ -1358,15 +1526,15 @@ If LIMIT is a revision string, use it as an end-revision."
;; so remove everything except a repository name.
(replace-regexp-in-string
"/.*" "" remote-location)))
- (vc-git-command
- buffer 'async nil
- "log"
- "--no-color" "--graph" "--decorate" "--date=short"
- (format "--pretty=tformat:%s" (car vc-git-root-log-format))
- "--abbrev-commit"
- (concat "HEAD.." (if (string= remote-location "")
- "@{upstream}"
- remote-location))))
+ (apply #'vc-git-command buffer 'async nil
+ `("log"
+ "--no-color" "--graph" "--decorate" "--date=short"
+ ,(format "--pretty=tformat:%s" (car vc-git-root-log-format))
+ "--abbrev-commit"
+ ,@(ensure-list vc-git-shortlog-switches)
+ ,(concat "HEAD.." (if (string= remote-location "")
+ "@{upstream}"
+ remote-location)))))
(defun vc-git-log-search (buffer pattern)
"Search the log of changes for PATTERN and output results into BUFFER.
@@ -1377,6 +1545,7 @@ Display all entries that match log messages in long format.
With a prefix argument, ask for a command to run that will output
log entries."
(let ((args `("log" "--no-color" "-i"
+ ,@(ensure-list vc-git-log-switches)
,(format "--grep=%s" (or pattern "")))))
(when current-prefix-arg
(setq args (cdr (split-string
@@ -1424,11 +1593,11 @@ log entries."
`((,log-view-message-re (1 'change-log-acknowledgment)))
;; Handle the case:
;; user: foo@bar
- '(("^Author:[ \t]+\\([A-Za-z0-9_.+-]+@[A-Za-z0-9_.-]+\\)"
+ '(("^\\(?:Author\\|Commit\\):[ \t]+\\([A-Za-z0-9_.+-]+@[A-Za-z0-9_.-]+\\)"
(1 'change-log-email))
;; Handle the case:
;; user: FirstName LastName <foo@bar>
- ("^Author:[ \t]+\\([^<(]+?\\)[ \t]*[(<]\\([A-Za-z0-9_.+-]+@[A-Za-z0-9_.-]+\\)[>)]"
+ ("^\\(?:Author\\|Commit\\):[ \t]+\\([^<(]+?\\)[ \t]*[(<]\\([A-Za-z0-9_.+-]+@[A-Za-z0-9_.-]+\\)[>)]"
(1 'change-log-name)
(2 'change-log-email))
("^ +\\(?:\\(?:[Aa]cked\\|[Ss]igned-[Oo]ff\\)-[Bb]y:\\)[ \t]+\\([A-Za-z0-9_.+-]+@[A-Za-z0-9_.-]+\\)"
@@ -1439,7 +1608,7 @@ log entries."
("^Merge: \\([0-9a-z]+\\) \\([0-9a-z]+\\)"
(1 'change-log-acknowledgment)
(2 'change-log-acknowledgment))
- ("^\\(?:Date: \\|AuthorDate: \\)\\(.+\\)" (1 'change-log-date))
+ ("^\\(?:Date: \\|AuthorDate: \\|CommitDate: \\)\\(.+\\)" (1 'change-log-date))
("^summary:[ \t]+\\(.+\\)" (1 'log-view-message)))))))
@@ -1461,7 +1630,11 @@ or BRANCH^ (where \"^\" can be repeated)."
(defun vc-git-expanded-log-entry (revision)
(with-temp-buffer
- (apply #'vc-git-command t nil nil (list "log" revision "-1" "--no-color" "--"))
+ (apply #'vc-git-command t nil nil
+ `("log"
+ ,revision
+ "-1" "--no-color" ,@(ensure-list vc-git-log-switches)
+ "--"))
(goto-char (point-min))
(unless (eobp)
;; Indent the expanded log entry.
@@ -1513,7 +1686,6 @@ This requires git 1.8.4 or later, for the \"-L\" option of \"git log\"."
map))
(defvar vc-git--log-view-long-font-lock-keywords nil)
-(defvar font-lock-keywords)
(defvar vc-git-region-history-font-lock-keywords
'((vc-git-region-history-font-lock)))
@@ -1591,7 +1763,7 @@ This requires git 1.8.4 or later, for the \"-L\" option of \"git log\"."
"^refs/\\(heads\\|tags\\|remotes\\)/\\(.*\\)$")))
(while (re-search-forward regexp nil t)
(push (match-string 2) table))))
- table))
+ (nreverse table)))
(defun vc-git-revision-completion-table (files)
(letrec ((table (lazy-completion-table
@@ -1607,14 +1779,19 @@ This requires git 1.8.4 or later, for the \"-L\" option of \"git log\"."
(declare-function vc-annotate-convert-time "vc-annotate" (&optional time))
+(autoload 'decoded-time-set-defaults "time-date")
+(autoload 'iso8601-parse "iso8601")
+
(defun vc-git-annotate-time ()
- (and (re-search-forward "^[0-9a-f^]+[^()]+(.*?\\([0-9]+\\)-\\([0-9]+\\)-\\([0-9]+\\) \\(:?\\([0-9]+\\):\\([0-9]+\\):\\([0-9]+\\) \\([-+0-9]+\\)\\)? *[0-9]+) " nil t)
- (vc-annotate-convert-time
- (apply #'encode-time (mapcar (lambda (match)
- (if (match-beginning match)
- (string-to-number (match-string match))
- 0))
- '(6 5 4 3 2 1 7))))))
+ (and (re-search-forward "^[0-9a-f^]+[^()]+(.*?\\([0-9]+-[0-9]+-[0-9]+\\)\\(?: \\([0-9]+:[0-9]+:[0-9]+\\) \\([-+0-9]+\\)\\)? +[0-9]+) " nil t)
+ (let* ((dt (match-string 1))
+ (dt (if (not (match-beginning 2)) dt
+ ;; Format as ISO 8601.
+ (concat dt "T" (match-string 2) (match-string 3))))
+ (decoded (ignore-errors (iso8601-parse dt))))
+ (and decoded
+ (vc-annotate-convert-time
+ (encode-time (decoded-time-set-defaults decoded)))))))
(defun vc-git-annotate-extract-revision-at-line ()
(save-excursion
@@ -1660,7 +1837,8 @@ This requires git 1.8.4 or later, for the \"-L\" option of \"git log\"."
(if branchp "branch" "tag"))))
(if branchp
(vc-git-command nil 0 nil "checkout" "-b" name
- (when (and start-point (not (eq start-point "")))
+ (when (and start-point
+ (not (equal start-point "")))
start-point))
(vc-git-command nil 0 nil "tag" name)))))
@@ -1695,8 +1873,11 @@ This requires git 1.8.4 or later, for the \"-L\" option of \"git log\"."
(defun vc-git--rev-parse (rev)
(with-temp-buffer
(and
- (vc-git--out-ok "rev-parse" rev)
- (buffer-substring-no-properties (point-min) (+ (point-min) 40)))))
+ (apply #'vc-git--out-ok "rev-parse"
+ (append (when vc-use-short-revision '("--short"))
+ (list rev)))
+ (goto-char (point-min))
+ (buffer-substring-no-properties (point) (pos-eol)))))
(defun vc-git-next-revision (file rev)
"Git-specific version of `vc-next-revision'."
@@ -1726,6 +1907,31 @@ This requires git 1.8.4 or later, for the \"-L\" option of \"git log\"."
(progn (forward-line 1) (1- (point)))))))))
(or (vc-git-symbolic-commit next-rev) next-rev)))
+(defun vc-git-file-name-changes (rev)
+ (with-temp-buffer
+ (let ((root (vc-git-root default-directory)))
+ (unless vc-git-print-log-follow
+ (apply #'vc-git-command (current-buffer) t nil
+ "diff"
+ "--name-status"
+ "--diff-filter=ADCR"
+ (concat rev "^") rev
+ (vc-switches 'git 'file-name-changes)))
+ (let (res)
+ (goto-char (point-min))
+ (while (re-search-forward "^\\([ADCR]\\)[0-9]*\t\\([^\n\t]+\\)\\(?:\t\\([^\n\t]+\\)\\)?" nil t)
+ (pcase (match-string 1)
+ ("A" (push (cons nil (match-string 2)) res))
+ ("D" (push (cons (match-string 2) nil) res))
+ ((or "C" "R") (push (cons (match-string 2) (match-string 3)) res))
+ ;; ("M" (push (cons (match-string 1) (match-string 1)) res))
+ ))
+ (mapc (lambda (c)
+ (if (car c) (setcar c (expand-file-name (car c) root)))
+ (if (cdr c) (setcdr c (expand-file-name (cdr c) root))))
+ res)
+ (nreverse res)))))
+
(defun vc-git-delete-file (file)
(vc-git-command nil 0 file "rm" "-f" "--"))
@@ -1792,6 +1998,7 @@ This requires git 1.8.4 or later, for the \"-L\" option of \"git log\"."
(defvar compilation-environment)
;; Derived from `lgrep'.
+;;;###autoload
(defun vc-git-grep (regexp &optional files dir)
"Run git grep, searching for REGEXP in FILES in directory DIR.
The search is limited to file names matching shell pattern FILES.
@@ -2028,8 +2235,17 @@ The difference to vc-do-command is that this function always invokes
(apply #'process-file vc-git-program nil buffer nil "--no-pager" command args)))
(defun vc-git--out-ok (command &rest args)
+ "Run `git COMMAND ARGS...' and insert standard output in current buffer.
+Return whether the process exited with status zero."
(zerop (apply #'vc-git--call '(t nil) command args)))
+(defun vc-git--out-str (command &rest args)
+ "Run `git COMMAND ARGS...' and return standard output as a string.
+The exit status is ignored."
+ (with-output-to-string
+ (with-current-buffer standard-output
+ (apply #'vc-git--out-ok command args))))
+
(defun vc-git--run-command-string (file &rest args)
"Run a git command on FILE and return its output as string.
FILE can be nil."
diff --git a/lisp/vc/vc-hg.el b/lisp/vc/vc-hg.el
index 8aa5bc6081d..7de41a2ae50 100644
--- a/lisp/vc/vc-hg.el
+++ b/lisp/vc/vc-hg.el
@@ -77,6 +77,7 @@
;; - make-version-backups-p (file) ??
;; - previous-revision (file rev) OK
;; - next-revision (file rev) OK
+;; - file-name-changes (rev) OK
;; - check-headers () ??
;; - delete-file (file) TEST IT
;; - rename-file (old new) OK
@@ -216,8 +217,9 @@ If `ask', you will be prompted for a branch type."
(defun vc-hg-state (file)
"Hg-specific version of `vc-state'."
- (let ((state (vc-hg-state-fast file)))
- (if (eq state 'unsupported) (vc-hg-state-slow file) state)))
+ (unless (file-directory-p file)
+ (let ((state (vc-hg-state-fast file)))
+ (if (eq state 'unsupported) (vc-hg-state-slow file) state))))
(defun vc-hg-state-slow (file)
"Determine status of FILE by running hg."
@@ -351,47 +353,24 @@ specific file to query."
(defun vc-hg-mode-line-string (file)
"Hg-specific version of `vc-mode-line-string'."
- (let* ((backend-name "Hg")
- (truename (file-truename file))
- (state (vc-state truename))
- (state-echo nil)
- (face nil)
- (rev (and state
- (let ((default-directory
- (expand-file-name (vc-hg-root truename))))
- (vc-hg--symbolic-revision
- "."
- (and vc-hg-use-file-version-for-mode-line-version
- truename)))))
- (rev (or rev "???")))
- (propertize
- (cond ((or (eq state 'up-to-date)
- (eq state 'needs-update))
- (setq state-echo "Up to date file")
- (setq face 'vc-up-to-date-state)
- (concat backend-name "-" rev))
- ((eq state 'added)
- (setq state-echo "Locally added file")
- (setq face 'vc-locally-added-state)
- (concat backend-name "@" rev))
- ((eq state 'conflict)
- (setq state-echo "File contains conflicts after the last merge")
- (setq face 'vc-conflict-state)
- (concat backend-name "!" rev))
- ((eq state 'removed)
- (setq state-echo "File removed from the VC system")
- (setq face 'vc-removed-state)
- (concat backend-name "!" rev))
- ((eq state 'missing)
- (setq state-echo "File tracked by the VC system, but missing from the file system")
- (setq face 'vc-missing-state)
- (concat backend-name "?" rev))
- (t
- (setq state-echo "Locally modified file")
- (setq face 'vc-edited-state)
- (concat backend-name ":" rev)))
- 'face face
- 'help-echo (concat state-echo " under the " backend-name
+ (pcase-let* ((backend-name "Hg")
+ (truename (file-truename file))
+ (state (vc-state truename))
+ (`(,state-echo ,face ,indicator)
+ (vc-mode-line-state state))
+ (rev (and state
+ (let ((default-directory
+ (expand-file-name (vc-hg-root truename))))
+ (vc-hg--symbolic-revision
+ "."
+ (and vc-hg-use-file-version-for-mode-line-version
+ truename)))))
+ (rev (or rev "???"))
+ (state-string (concat (unless (eq vc-display-status 'no-backend)
+ backend-name)
+ indicator rev)))
+ (propertize state-string 'face face 'help-echo
+ (concat state-echo " under the " backend-name
" version control system"))))
;;; History functions
@@ -500,7 +479,6 @@ This requires hg 4.4 or later, for the \"-L\" option of \"hg log\"."
map))
(defvar vc-hg--log-view-long-font-lock-keywords nil)
-(defvar font-lock-keywords)
(defvar vc-hg-region-history-font-lock-keywords
'((vc-hg-region-history-font-lock)))
@@ -581,7 +559,7 @@ This requires hg 4.4 or later, for the \"-L\" option of \"hg log\"."
(defun vc-hg-annotate-command (file buffer &optional revision)
"Execute \"hg annotate\" on FILE, inserting the contents in BUFFER.
Optional arg REVISION is a revision to annotate from."
- (apply #'vc-hg-command buffer 0 file "annotate" "-dq" "-n"
+ (apply #'vc-hg-command buffer 'async file "annotate" "-dq" "-n"
(append (vc-switches 'hg 'annotate)
(if revision (list (concat "-r" revision))))))
@@ -606,8 +584,8 @@ Optional arg REVISION is a revision to annotate from."
(vc-annotate-convert-time
(let ((str (match-string-no-properties 2)))
(encode-time 0 0 0
- (string-to-number (substring str 6 8))
- (string-to-number (substring str 4 6))
+ (string-to-number (substring str 8 10))
+ (string-to-number (substring str 5 7))
(string-to-number (substring str 0 4)))))))
(defun vc-hg-annotate-extract-revision-at-line ()
@@ -1226,6 +1204,22 @@ REV is ignored."
(vc-hg-command buffer 0 file "cat" "-r" rev)
(vc-hg-command buffer 0 file "cat"))))
+(defun vc-hg-file-name-changes (rev)
+ (unless (member "--follow" vc-hg-log-switches)
+ (with-temp-buffer
+ (let ((root (vc-hg-root default-directory)))
+ (vc-hg-command (current-buffer) t nil
+ "log" "-g" "-p" "-r" rev)
+ (let (res)
+ (goto-char (point-min))
+ (while (re-search-forward "^diff --git a/\\([^ \n]+\\) b/\\([^ \n]+\\)" nil t)
+ (when (not (equal (match-string 1) (match-string 2)))
+ (push (cons
+ (expand-file-name (match-string 1) root)
+ (expand-file-name (match-string 2) root))
+ res)))
+ (nreverse res))))))
+
(defun vc-hg-find-ignore-file (file)
"Return the root directory of the repository of FILE."
(expand-file-name ".hgignore"
@@ -1375,17 +1369,28 @@ REV is the revision to check out into WORKFILE."
;; Follows vc-exec-after.
(declare-function vc-set-async-update "vc-dispatcher" (process-buffer))
+(defvar vc-hg--program-version nil)
+
+(defun vc-hg--program-version ()
+ (or vc-hg--program-version
+ (setq vc-hg--program-version
+ (with-temp-buffer
+ (condition-case _ (vc-hg-command t 0 nil "version")
+ (error "0")
+ (:success
+ (goto-char (point-min))
+ (re-search-forward "Mercurial Distributed SCM (version \\([0-9][0-9.]+\\)")
+ (string-trim-right (match-string 1) "\\.")))))))
+
(defun vc-hg-dir-status-files (dir files update-function)
;; XXX: We can't pass DIR directly to 'hg status' because that
;; returns all ignored files if FILES is non-nil (bug#22481).
(let ((default-directory dir))
- ;; TODO: Use "--config 'status.relative=1'" instead of "re:"
- ;; when we're allowed to depend on Mercurial 4.2+
- ;; (it's a bit faster).
- (vc-hg-command (current-buffer) 'async files
- "status" "re:" "-I" "."
- (concat "-mardu" (if files "i"))
- "-C"))
+ (apply #'vc-hg-command (current-buffer) 'async files
+ "status" (concat "-mardu" (if files "i")) "-C"
+ (if (version<= "4.2" (vc-hg--program-version))
+ '("--config" "commands.status.relative=1")
+ '("re:" "-I" "."))))
(vc-run-delayed
(vc-hg-after-dir-status update-function)))
diff --git a/lisp/vc/vc-hooks.el b/lisp/vc/vc-hooks.el
index bf4c87034fa..8f212e96933 100644
--- a/lisp/vc/vc-hooks.el
+++ b/lisp/vc/vc-hooks.el
@@ -87,6 +87,11 @@
"Face for VC modeline state when the file is edited."
:version "25.1")
+(defface vc-ignored-state
+ '((default :inherit vc-state-base))
+ "Face for VC modeline state when the file is registered, but ignored."
+ :version "30.1")
+
;; Customization Variables (the rest is in vc.el)
(defcustom vc-ignore-dir-regexp
@@ -147,8 +152,12 @@ visited and a warning displayed."
(defcustom vc-display-status t
"If non-nil, display revision number and lock status in mode line.
-Otherwise, not displayed."
- :type 'boolean
+If nil, only the backend name is displayed. When the value
+is `no-backend', then no backend name is displayed before the
+revision number and lock status."
+ :type '(choice (const :tag "Show only revision/status" no-backend)
+ (const :tag "Show backend and revision/status" t)
+ (const :tag "Show only backend name" nil))
:group 'vc)
@@ -176,8 +185,9 @@ Otherwise, not displayed."
"Version Control minor mode.
This minor mode is automatically activated whenever you visit a file under
control of one of the revision control systems in `vc-handled-backends'.
-VC commands are globally reachable under the prefix `\\[vc-prefix-map]':
-\\{vc-prefix-map}")
+VC commands are globally reachable under the prefix \\[vc-prefix-map]:
+\\{vc-prefix-map}"
+ nil)
(defmacro vc-error-occurred (&rest body)
`(condition-case nil (progn ,@body nil) (error t)))
@@ -188,7 +198,7 @@ VC commands are globally reachable under the prefix `\\[vc-prefix-map]':
;; during any subsequent VC operations, and forget them when
;; the buffer is killed.
-(defvar vc-file-prop-obarray (make-vector 17 0)
+(defvar vc-file-prop-obarray (obarray-make 17)
"Obarray for per-file properties.")
(defvar vc-touched-properties nil)
@@ -316,31 +326,37 @@ This function performs the check each time it is called. To rely
on the result of a previous call, use `vc-backend' instead. If the
file was previously registered under a certain backend, then that
backend is tried first."
- (let (handler)
- (cond
- ((and (file-name-directory file)
- (string-match vc-ignore-dir-regexp (file-name-directory file)))
- nil)
- ((and (boundp 'file-name-handler-alist)
- (setq handler (find-file-name-handler file 'vc-registered)))
- ;; handler should set vc-backend and return t if registered
- (funcall handler 'vc-registered file))
- (t
- ;; There is no file name handler.
- ;; Try vc-BACKEND-registered for each handled BACKEND.
- (catch 'found
- (let ((backend (vc-file-getprop file 'vc-backend)))
- (mapc
- (lambda (b)
- (and (vc-call-backend b 'registered file)
- (vc-file-setprop file 'vc-backend b)
- (throw 'found t)))
- (if (or (not backend) (eq backend 'none))
- vc-handled-backends
- (cons backend vc-handled-backends))))
- ;; File is not registered.
- (vc-file-setprop file 'vc-backend 'none)
- nil)))))
+ ;; Subprocesses (and with them, VC backends) can't run from /contents
+ ;; or /actions, which are fictions maintained by Emacs that do not
+ ;; exist in the filesystem.
+ (if (and (eq system-type 'android)
+ (string-match-p "/\\(content\\|assets\\)[/$]"
+ (expand-file-name file)))
+ nil
+ (let (handler)
+ (cond
+ ((and (file-name-directory file)
+ (string-match vc-ignore-dir-regexp (file-name-directory file)))
+ nil)
+ ((setq handler (find-file-name-handler file 'vc-registered))
+ ;; handler should set vc-backend and return t if registered
+ (funcall handler 'vc-registered file))
+ (t
+ ;; There is no file name handler.
+ ;; Try vc-BACKEND-registered for each handled BACKEND.
+ (catch 'found
+ (let ((backend (vc-file-getprop file 'vc-backend)))
+ (mapc
+ (lambda (b)
+ (and (vc-call-backend b 'registered file)
+ (vc-file-setprop file 'vc-backend b)
+ (throw 'found t)))
+ (if (or (not backend) (eq backend 'none))
+ vc-handled-backends
+ (cons backend vc-handled-backends))))
+ ;; File is not registered.
+ (vc-file-setprop file 'vc-backend 'none)
+ nil))))))
(defun vc-backend (file-or-list)
"Return the version control type of FILE-OR-LIST, nil if it's not registered.
@@ -348,15 +364,22 @@ If the argument is a list, the files must all have the same back end."
;; `file' can be nil in several places (typically due to the use of
;; code like (vc-backend buffer-file-name)).
(cond ((stringp file-or-list)
- (let ((property (vc-file-getprop file-or-list 'vc-backend)))
- ;; Note that internally, Emacs remembers unregistered
- ;; files by setting the property to `none'.
- (cond ((eq property 'none) nil)
- (property)
- ;; vc-registered sets the vc-backend property
- (t (if (vc-registered file-or-list)
- (vc-file-getprop file-or-list 'vc-backend)
- nil)))))
+ ;; Subprocesses (and with them, VC backends) can't run from
+ ;; /contents or /actions, which are fictions maintained by
+ ;; Emacs that do not exist in the filesystem.
+ (if (and (eq system-type 'android)
+ (string-match-p "/\\(content\\|assets\\)[/$]"
+ (expand-file-name file-or-list)))
+ nil
+ (let ((property (vc-file-getprop file-or-list 'vc-backend)))
+ ;; Note that internally, Emacs remembers unregistered
+ ;; files by setting the property to `none'.
+ (cond ((eq property 'none) nil)
+ (property)
+ ;; vc-registered sets the vc-backend property
+ (t (if (vc-registered file-or-list)
+ (vc-file-getprop file-or-list 'vc-backend)
+ nil))))))
((and file-or-list (listp file-or-list))
(vc-backend (car file-or-list)))
(t
@@ -498,6 +521,18 @@ If FILE is not registered, this function always returns nil."
(vc-call-backend
backend 'working-revision file))))))
+(defvar vc-use-short-revision nil
+ "If non-nil, VC backend functions should return short revisions if possible.
+This is set to t when calling `vc-short-revision', which will
+then call the \\=`working-revision' backend function.")
+
+(defun vc-short-revision (file &optional backend)
+ "Return the repository version for FILE in a shortened form.
+If FILE is not registered, this function always returns nil."
+ (let ((vc-use-short-revision t))
+ (vc-call-backend (or backend (vc-backend file))
+ 'working-revision file)))
+
(defun vc-default-registered (backend file)
"Check if FILE is registered in BACKEND using vc-BACKEND-master-templates."
(let ((sym (vc-make-backend-sym backend 'master-templates)))
@@ -701,6 +736,50 @@ If BACKEND is passed use it as the VC backend when computing the result."
(force-mode-line-update)
backend)
+(defun vc-mode-line-state (state)
+ "Return a list of data to display on the mode line.
+The argument STATE should contain the version control state returned
+from `vc-state'. The returned list includes three elements: the echo
+string, the face name, and the indicator that usually is one character."
+ (let (state-echo face indicator)
+ (cond ((or (eq state 'up-to-date)
+ (eq state 'needs-update))
+ (setq state-echo "Up to date file")
+ (setq face 'vc-up-to-date-state)
+ (setq indicator "-"))
+ ((stringp state)
+ (setq state-echo (concat "File locked by" state))
+ (setq face 'vc-locked-state)
+ (setq indicator (concat ":" state ":")))
+ ((eq state 'added)
+ (setq state-echo "Locally added file")
+ (setq face 'vc-locally-added-state)
+ (setq indicator "@"))
+ ((eq state 'conflict)
+ (setq state-echo "File contains conflicts after the last merge")
+ (setq face 'vc-conflict-state)
+ (setq indicator "!"))
+ ((eq state 'removed)
+ (setq state-echo "File removed from the VC system")
+ (setq face 'vc-removed-state)
+ (setq indicator "!"))
+ ((eq state 'missing)
+ (setq state-echo "File tracked by the VC system, but missing from the file system")
+ (setq face 'vc-missing-state)
+ (setq indicator "?"))
+ ((eq state 'ignored)
+ (setq state-echo "File tracked by the VC system, but ignored")
+ (setq face 'vc-ignored-state)
+ (setq indicator "!"))
+ (t
+ ;; Not just for the 'edited state, but also a fallback
+ ;; for all other states. Think about different symbols
+ ;; for 'needs-update and 'needs-merge.
+ (setq state-echo "Locally modified file")
+ (setq face 'vc-edited-state)
+ (setq indicator ":")))
+ (list state-echo face indicator)))
+
(defun vc-default-mode-line-string (backend file)
"Return a string for `vc-mode-line' to put in the mode line for FILE.
Format:
@@ -713,47 +792,17 @@ Format:
\"BACKEND?REV\" if the file is under VC, but is missing
This function assumes that the file is registered."
- (let* ((backend-name (symbol-name backend))
- (state (vc-state file backend))
- (state-echo nil)
- (face nil)
- (rev (vc-working-revision file backend)))
- (propertize
- (cond ((or (eq state 'up-to-date)
- (eq state 'needs-update))
- (setq state-echo "Up to date file")
- (setq face 'vc-up-to-date-state)
- (concat backend-name "-" rev))
- ((stringp state)
- (setq state-echo (concat "File locked by" state))
- (setq face 'vc-locked-state)
- (concat backend-name ":" state ":" rev))
- ((eq state 'added)
- (setq state-echo "Locally added file")
- (setq face 'vc-locally-added-state)
- (concat backend-name "@" rev))
- ((eq state 'conflict)
- (setq state-echo "File contains conflicts after the last merge")
- (setq face 'vc-conflict-state)
- (concat backend-name "!" rev))
- ((eq state 'removed)
- (setq state-echo "File removed from the VC system")
- (setq face 'vc-removed-state)
- (concat backend-name "!" rev))
- ((eq state 'missing)
- (setq state-echo "File tracked by the VC system, but missing from the file system")
- (setq face 'vc-missing-state)
- (concat backend-name "?" rev))
- (t
- ;; Not just for the 'edited state, but also a fallback
- ;; for all other states. Think about different symbols
- ;; for 'needs-update and 'needs-merge.
- (setq state-echo "Locally modified file")
- (setq face 'vc-edited-state)
- (concat backend-name ":" rev)))
- 'face face
- 'help-echo (concat state-echo " under the " backend-name
- " version control system"))))
+ (pcase-let* ((backend-name (symbol-name backend))
+ (state (vc-state file backend))
+ (rev (vc-working-revision file backend))
+ (`(,state-echo ,face ,indicator)
+ (vc-mode-line-state state))
+ (state-string (concat (unless (eq vc-display-status 'no-backend)
+ backend-name)
+ indicator rev)))
+ (propertize state-string 'face face 'help-echo
+ (concat state-echo " under the " backend-name
+ " version control system"))))
(defun vc-follow-link ()
"If current buffer visits a symbolic link, visit the real file.
diff --git a/lisp/vc/vc-rcs.el b/lisp/vc/vc-rcs.el
index 8e802c4bd8a..33377ce1cc8 100644
--- a/lisp/vc/vc-rcs.el
+++ b/lisp/vc/vc-rcs.el
@@ -864,14 +864,15 @@ and CVS."
(defvar vc-rcs-rcs2log-program
(let (exe)
(cond ((file-executable-p
- (setq exe (expand-file-name "rcs2log" exec-directory)))
+ (setq exe (expand-file-name rcs2log-program-name
+ exec-directory)))
exe)
;; In the unlikely event that someone is running an
;; uninstalled Emacs and wants to do something RCS-related.
((file-executable-p
(setq exe (expand-file-name "lib-src/rcs2log" source-directory)))
exe)
- (t "rcs2log")))
+ (t rcs2log-program-name)))
"Path to the `rcs2log' program (normally in `exec-directory').")
(autoload 'vc-buffer-sync "vc-dispatcher")
@@ -1176,7 +1177,7 @@ variable `vc-rcs-release' is set to the returned value."
(or vc-rcs-release
(setq vc-rcs-release
(or (and (zerop (vc-do-command "*vc*" nil "rcs" nil "-V"))
- (with-current-buffer (get-buffer "*vc*")
+ (with-current-buffer "*vc*"
(vc-parse-buffer "^RCS version \\([0-9.]+ *.*\\)" 1)))
'unknown))))
diff --git a/lisp/vc/vc-svn.el b/lisp/vc/vc-svn.el
index 96baa642b44..ae281e54519 100644
--- a/lisp/vc/vc-svn.el
+++ b/lisp/vc/vc-svn.el
@@ -436,7 +436,7 @@ The changes are between FIRST-VERSION and SECOND-VERSION."
(concat first-version ":" second-version)
first-version))
(vc-file-setprop file 'vc-state 'edited)
- (with-current-buffer (get-buffer "*vc*")
+ (with-current-buffer "*vc*"
(goto-char (point-min))
(if (looking-at "C ")
1 ; signal conflict
@@ -450,7 +450,7 @@ The changes are between FIRST-VERSION and SECOND-VERSION."
(vc-svn-command nil 0 file "update")
;; Analyze the merge result reported by SVN, and set
;; file properties accordingly.
- (with-current-buffer (get-buffer "*vc*")
+ (with-current-buffer "*vc*"
(goto-char (point-min))
;; get new working revision
(if (re-search-forward
diff --git a/lisp/vc/vc.el b/lisp/vc/vc.el
index 25540406b4e..f26e5cc751d 100644
--- a/lisp/vc/vc.el
+++ b/lisp/vc/vc.el
@@ -517,6 +517,13 @@
;; Return the revision number that precedes REV for FILE, or nil if no such
;; revision exists.
;;
+;; - file-name-changes (rev)
+;;
+;; Return the list of pairs with changes in file names in REV. When
+;; a file was added, it should be a cons with nil car. When
+;; deleted, a cons with nil cdr. When copied or renamed, a cons
+;; with the source name as car and destination name as cdr.
+;;
;; - next-revision (file rev)
;;
;; Return the revision number that follows REV for FILE, or nil if no such
@@ -928,7 +935,7 @@ is sensitive to blank lines."
(defun vc-clear-context ()
"Clear all cached file properties."
(interactive)
- (fillarray vc-file-prop-obarray 0))
+ (obarray-clear vc-file-prop-obarray))
(defmacro with-vc-properties (files form settings)
"Execute FORM, then maybe set per-file properties for FILES.
@@ -1067,18 +1074,29 @@ Within directories, only files already under version control are noticed."
(defvar vc-dir-backend)
(defvar log-view-vc-backend)
+(defvar log-view-vc-fileset)
(defvar log-edit-vc-backend)
(defvar diff-vc-backend)
(defvar diff-vc-revisions)
+(defcustom vc-deduce-backend-nonvc-modes
+ ;; Maybe we could even use comint-mode rather than shell-mode?
+ '(dired-mode shell-mode eshell-mode compilation-mode)
+ "List of modes not supported by VC where backend should be deduced.
+In these modes the backend is deduced based on `default-directory'.
+If the value is t, the backend is deduced in all modes."
+ :type '(choice (const :tag "None" nil)
+ (repeat symbol)
+ (const :tag "All" t))
+ :version "30.1")
+
(defun vc-deduce-backend ()
(cond ((derived-mode-p 'vc-dir-mode) vc-dir-backend)
((derived-mode-p 'log-view-mode) log-view-vc-backend)
((derived-mode-p 'log-edit-mode) log-edit-vc-backend)
((derived-mode-p 'diff-mode) diff-vc-backend)
- ;; Maybe we could even use comint-mode rather than shell-mode?
- ((derived-mode-p
- 'dired-mode 'shell-mode 'eshell-mode 'compilation-mode)
+ ((or (eq vc-deduce-backend-nonvc-modes t)
+ (derived-mode-p vc-deduce-backend-nonvc-modes))
(ignore-errors (vc-responsible-backend default-directory)))
(vc-mode (vc-backend buffer-file-name))))
@@ -1121,19 +1139,8 @@ possible values of STATE are explained in `vc-state', and MODEL in
the returned list.
BEWARE: this function may change the current buffer."
- (let (new-buf res)
- (with-current-buffer (or (buffer-base-buffer) (current-buffer))
- (setq res
- (vc-deduce-fileset-1 not-state-changing
- allow-unregistered
- state-model-only-files))
- (setq new-buf (current-buffer)))
- (set-buffer new-buf)
- res))
-
-(defun vc-deduce-fileset-1 (not-state-changing
- allow-unregistered
- state-model-only-files)
+ (when (buffer-base-buffer)
+ (set-buffer (buffer-base-buffer)))
(let (backend)
(cond
((derived-mode-p 'vc-dir-mode)
@@ -1149,6 +1156,11 @@ BEWARE: this function may change the current buffer."
(vc-state buffer-file-name)
(vc-checkout-model backend buffer-file-name))
(list backend (list buffer-file-name))))
+ ((derived-mode-p 'log-view-mode)
+ ;; 'log-view-mode' stashes the backend and the fileset in the
+ ;; two special variables, so we use them to avoid any possible
+ ;; mistakes from a decision made here ad-hoc.
+ (list log-view-vc-backend log-view-vc-fileset))
((and (buffer-live-p vc-parent-buffer)
;; FIXME: Why this test? --Stef
(or (buffer-file-name vc-parent-buffer)
@@ -1158,7 +1170,7 @@ BEWARE: this function may change the current buffer."
(derived-mode-p 'diff-mode)))))
(progn ;FIXME: Why not `with-current-buffer'? --Stef.
(set-buffer vc-parent-buffer)
- (vc-deduce-fileset-1 not-state-changing allow-unregistered state-model-only-files)))
+ (vc-deduce-fileset not-state-changing allow-unregistered state-model-only-files)))
((and (not buffer-file-name)
(setq backend (vc-responsible-backend default-directory)))
(list backend nil))
@@ -1749,7 +1761,8 @@ Runs the normal hooks `vc-before-checkin-hook' and `vc-checkin-hook'."
nil
"-p1"
"-r" null-device
- "--no-backup-if-mismatch"
+ "--posix"
+ "--remove-empty-files"
"-i" "-"))
(user-error "Patch failed: %s" (buffer-string))))
(vc-call-backend backend 'checkin files comment))
@@ -2249,7 +2262,7 @@ saving the buffer."
(vc-maybe-buffer-sync not-urgent)
(let ((backend (vc-deduce-backend))
(default-directory default-directory)
- rootdir working-revision)
+ rootdir)
(if backend
(setq rootdir (vc-call-backend backend 'root default-directory))
(setq rootdir (read-directory-name "Directory for VC root-diff: "))
@@ -2257,14 +2270,13 @@ saving the buffer."
(if backend
(setq default-directory rootdir)
(error "Directory is not version controlled")))
- (setq working-revision (vc-working-revision rootdir))
;; VC diff for the root directory produces output that is
;; relative to it. Bind default-directory to the root directory
;; here, this way the *vc-diff* buffer is setup correctly, so
;; relative file names work.
(let ((default-directory rootdir))
(vc-diff-internal
- t (list backend (list rootdir) working-revision) nil nil
+ t (list backend (list rootdir)) nil nil
(called-interactively-p 'interactive))))))
;;;###autoload
@@ -2683,22 +2695,55 @@ Not all VC backends support short logs!")
(defvar log-view-vc-fileset)
(defvar log-view-message-re)
+;; XXX: File might have been renamed multiple times, so to support
+;; multiple jumps back, this probably should be a stack of entries.
+(defvar log-view-vc-prev-revision nil)
+(defvar log-view-vc-prev-fileset nil)
(defun vc-print-log-setup-buttons (working-revision is-start-revision limit pl-return)
"Insert at the end of the current buffer buttons to show more log entries.
In the new log, leave point at WORKING-REVISION (if non-nil).
-LIMIT is the number of entries currently shown.
-Does nothing if IS-START-REVISION is non-nil, or if LIMIT is nil,
+LIMIT is the current maximum number of entries shown, or the
+revision (string) before which to stop. Does nothing if
+IS-START-REVISION is non-nil and LIMIT is 1, or if LIMIT is nil,
or if PL-RETURN is `limit-unsupported'."
+ ;; LIMIT=1 is set by vc-annotate-show-log-revision-at-line
+ ;; or by vc-print-root-log with current-prefix-arg=1.
+ ;; In either case only one revision is wanted, no buttons.
(when (and limit (not (eq 'limit-unsupported pl-return))
- (not is-start-revision))
+ (not (and is-start-revision
+ (eql limit 1))))
(let ((entries 0))
(goto-char (point-min))
(while (re-search-forward log-view-message-re nil t)
(cl-incf entries))
- ;; If we got fewer entries than we asked for, then displaying
- ;; the "more" buttons isn't useful.
- (when (>= entries limit)
+ (if (or (stringp limit)
+ (< entries limit))
+ ;; The log has been printed in full. Perhaps it started
+ ;; with a copy or rename?
+ ;; FIXME: We'd probably still want this button even when
+ ;; vc-log-show-limit is customized to 0 (should be rare).
+ (let* ((last-revision (log-view-current-tag (point-max)))
+ ;; XXX: Could skip this when vc-git-print-log-follow = t.
+ (name-changes
+ (condition-case nil
+ (vc-call-backend log-view-vc-backend
+ 'file-name-changes last-revision)
+ (vc-not-supported nil)))
+ (matching-changes
+ (cl-delete-if-not (lambda (f) (member f log-view-vc-fileset))
+ name-changes :key #'cdr))
+ (old-names (delq nil (mapcar #'car matching-changes))))
+ (when old-names
+ (goto-char (point-max))
+ (unless (looking-back "\n\n" (- (point) 2))
+ (insert "\n"))
+ (vc-print-log-renamed-add-button old-names log-view-vc-backend
+ log-view-vc-fileset
+ working-revision
+ last-revision
+ limit)))
+ ;; Perhaps there are more entries in the log.
(goto-char (point-max))
(insert "\n")
(insert-text-button
@@ -2719,16 +2764,57 @@ or if PL-RETURN is `limit-unsupported'."
'help-echo "Show the log again, including all entries")
(insert "\n")))))
+(defun vc-print-log-renamed-add-button ( renamed-files backend
+ current-fileset
+ current-revision
+ revision limit)
+ "Print the button for jump to the log for a different fileset.
+RENAMED-FILES is the fileset to use. BACKEND is the VC backend.
+REVISION is the revision from which to start the new log.
+CURRENT-FILESET, if non-nil, is the fileset to use in the \"back\"
+button for. Same for CURRENT-REVISION. LIMIT means the usual."
+ (let ((relatives (mapcar #'file-relative-name renamed-files))
+ (from-to (if current-fileset "from" "to"))
+ (before-after (if current-fileset "before" "after")))
+ (insert
+ (format
+ "Renamed %s %s"
+ from-to
+ (mapconcat (lambda (s)
+ (propertize s 'font-lock-face
+ 'log-view-file))
+ relatives
+ ", "))
+ " ")
+ (insert-text-button
+ "View log"
+ 'action (lambda (&rest _ignore)
+ ;; To set up parent buffer in the new viewer.
+ (with-current-buffer vc-parent-buffer
+ (let ((log-view-vc-prev-fileset current-fileset)
+ (log-view-vc-prev-revision current-revision))
+ (vc-print-log-internal backend renamed-files
+ revision t limit))))
+ ;; XXX: Showing the full history for OLD-NAMES (with
+ ;; IS-START-REVISION=nil) can be better sometimes
+ ;; (e.g. when some edits still occurred after a rename
+ ;; -- multiple branches scenario), but it also can hurt
+ ;; in others because of Git's automatic history
+ ;; simplification: as a result, the logs for some
+ ;; use-package's files before merge could not be found.
+ 'help-echo
+ (format
+ "Show the log for the file name(s) %s the rename"
+ before-after))))
+
(defun vc-print-log-internal (backend files working-revision
&optional is-start-revision limit type)
"For specified BACKEND and FILES, show the VC log.
Leave point at WORKING-REVISION, if it is non-nil.
If IS-START-REVISION is non-nil, start the log from WORKING-REVISION
\(not all backends support this); i.e., show only WORKING-REVISION and
-earlier revisions. Show up to LIMIT entries (non-nil means unlimited)."
- ;; As of 2013/04 the only thing that passes IS-START-REVISION non-nil
- ;; is vc-annotate-show-log-revision-at-line, which sets LIMIT = 1.
-
+earlier revisions. Show up to LIMIT entries (nil means unlimited).
+LIMIT can also be a string, which means the revision before which to stop."
;; Don't switch to the output buffer before running the command,
;; so that any buffer-local settings in the vc-controlled
;; buffer can be accessed by the command.
@@ -2740,8 +2826,22 @@ earlier revisions. Show up to LIMIT entries (non-nil means unlimited)."
(vc-log-internal-common
backend buffer-name files type
(lambda (bk buf _type-arg files-arg)
- (vc-call-backend bk 'print-log files-arg buf shortlog
- (when is-start-revision working-revision) limit))
+ (vc-call-backend bk 'print-log files-arg buf shortlog
+ (when is-start-revision working-revision) limit)
+ (when log-view-vc-prev-fileset
+ (with-current-buffer buf
+ (let ((inhibit-read-only t)
+ (pmark (process-mark (get-buffer-process buf))))
+ (goto-char (point-min))
+ (vc-print-log-renamed-add-button log-view-vc-prev-fileset
+ backend
+ nil
+ nil
+ log-view-vc-prev-revision
+ limit)
+ (insert "\n\n")
+ (when (< pmark (point))
+ (set-marker pmark (point)))))))
(lambda (_bk _files-arg ret)
(save-excursion
(vc-print-log-setup-buttons working-revision
@@ -3194,14 +3294,13 @@ its name; otherwise return nil."
(vc-resynch-buffer file t t))
;;;###autoload
-(defun vc-switch-backend (file backend)
+(defun vc-change-backend (file backend)
"Make BACKEND the current version control system for FILE.
FILE must already be registered in BACKEND. The change is not
permanent, only for the current session. This function only changes
VC's perspective on FILE, it does not register or unregister it.
By default, this command cycles through the registered backends.
To get a prompt, use a prefix argument."
- (declare (obsolete nil "28.1"))
(interactive
(list
(or buffer-file-name
@@ -3232,6 +3331,9 @@ To get a prompt, use a prefix argument."
(error "%s is not registered in %s" file backend))
(vc-mode-line file)))
+(define-obsolete-function-alias 'vc-switch-backend #'vc-change-backend
+ "30.1")
+
;;;###autoload
(defun vc-transfer-file (file new-backend)
"Transfer FILE to another version control system NEW-BACKEND.
@@ -3256,8 +3358,7 @@ backend to NEW-BACKEND, and unregister FILE from the current backend.
(if registered
(set-file-modes file (logior (file-modes file) 128))
;; `registered' might have switched under us.
- (with-suppressed-warnings ((obsolete vc-switch-backend))
- (vc-switch-backend file old-backend))
+ (vc-change-backend file old-backend)
(let* ((rev (vc-working-revision file))
(modified-file (and edited (make-temp-file file)))
(unmodified-file (and modified-file (vc-version-backup-file file))))
@@ -3276,19 +3377,16 @@ backend to NEW-BACKEND, and unregister FILE from the current backend.
(vc-revert-file file))))
(vc-call-backend new-backend 'receive-file file rev))
(when modified-file
- (with-suppressed-warnings ((obsolete vc-switch-backend))
- (vc-switch-backend file new-backend))
+ (vc-change-backend file new-backend)
(unless (eq (vc-checkout-model new-backend (list file)) 'implicit)
(vc-checkout file))
(rename-file modified-file file 'ok-if-already-exists)
(vc-file-setprop file 'vc-checkout-time nil)))))
(when move
- (with-suppressed-warnings ((obsolete vc-switch-backend))
- (vc-switch-backend file old-backend))
+ (vc-change-backend file old-backend)
(setq comment (vc-call-backend old-backend 'comment-history file))
(vc-call-backend old-backend 'unregister file))
- (with-suppressed-warnings ((obsolete vc-switch-backend))
- (vc-switch-backend file new-backend))
+ (vc-change-backend file new-backend)
(when (or move edited)
(vc-file-setprop file 'vc-state 'edited)
(vc-mode-line file new-backend)
@@ -3459,7 +3557,7 @@ If nil, no default will be used. This option may be set locally."
(declare-function message--name-table "message" (orig-string))
(declare-function mml-attach-buffer "mml"
- (buffer &optional type description disposition))
+ (buffer &optional type description disposition filename))
(declare-function log-view-get-marked "log-view" ())
(defun vc-default-prepare-patch (_backend rev)
@@ -3500,6 +3598,19 @@ of the current file."
(and-let* ((file (buffer-file-name)))
(vc-working-revision file)))))
+(defun vc--subject-to-file-name (subject)
+ "Generate a file name for a patch with subject line SUBJECT."
+ (let* ((stripped
+ (replace-regexp-in-string "\\`\\[.*PATCH.*\\]\\s-*" ""
+ subject))
+ (truncated (if (length> stripped 50)
+ (substring stripped 0 50)
+ stripped)))
+ (concat
+ (string-trim (replace-regexp-in-string "\\W" "-" truncated)
+ "-+" "-+")
+ ".patch")))
+
;;;###autoload
(defun vc-prepare-patch (addressee subject revisions)
"Compose an Email sending patches for REVISIONS to ADDRESSEE.
@@ -3510,9 +3621,17 @@ revision, with SUBJECT derived from each revision subject.
When invoked with a numerical prefix argument, use the last N
revisions.
When invoked interactively in a Log View buffer with
-marked revisions, use those these."
+marked revisions, use those."
(interactive
- (let ((revs (vc-prepare-patch-prompt-revisions)) to)
+ (let* ((revs (vc-prepare-patch-prompt-revisions))
+ (subject
+ (and (length= revs 1)
+ (plist-get
+ (vc-call-backend
+ (vc-responsible-backend default-directory)
+ 'prepare-patch (car revs))
+ :subject)))
+ to)
(require 'message)
(while (null (setq to (completing-read-multiple
(format-prompt
@@ -3525,10 +3644,9 @@ marked revisions, use those these."
(sit-for blink-matching-delay))
(list (string-join to ", ")
(and (not vc-prepare-patches-separately)
- (read-string "Subject: " "[PATCH] " nil nil t))
+ (read-string "Subject: " (or subject "[PATCH] ") nil nil t))
revs)))
(save-current-buffer
- (vc-ensure-vc-buffer)
(let ((patches (mapcar (lambda (rev)
(vc-call-backend
(vc-responsible-backend default-directory)
@@ -3556,11 +3674,17 @@ marked revisions, use those these."
(rfc822-goto-eoh)
(forward-line)
(save-excursion
- (dolist (patch patches)
- (mml-attach-buffer (buffer-name (plist-get patch :buffer))
- "text/x-patch"
- (plist-get patch :subject)
- "attachment")))
+ (let ((i 0))
+ (dolist (patch patches)
+ (let* ((patch-subject (plist-get patch :subject))
+ (filename
+ (vc--subject-to-file-name patch-subject)))
+ (mml-attach-buffer
+ (buffer-name (plist-get patch :buffer))
+ "text/x-patch"
+ patch-subject
+ "attachment"
+ (format "%04d-%s" (cl-incf i) filename))))))
(open-line 2)))))
(defun vc-default-responsible-p (_backend _file)
@@ -3641,7 +3765,8 @@ to provide the `find-revision' operation instead."
(file-buffer (or (get-file-buffer file) (current-buffer))))
(message "Checking out %s..." file)
(let ((failed t)
- (backup-name (car (find-backup-file-name file))))
+ (backup-name (when (file-exists-p file)
+ (car (find-backup-file-name file)))))
(when backup-name
(copy-file file backup-name 'ok-if-already-exists 'keep-date)
(unless (file-writable-p file)
@@ -3686,8 +3811,7 @@ If BACKEND is nil or omitted, the function iterates through every known
backend in `vc-handled-backends' until one succeeds to clone REMOTE.
If REV is non-nil, it indicates a specific revision to check out after
cloning; the syntax of REV depends on what BACKEND accepts."
- (unless directory
- (setq directory default-directory))
+ (setq directory (expand-file-name (or directory default-directory)))
(if backend
(progn
(unless (memq backend vc-handled-backends)
@@ -3706,7 +3830,7 @@ cloning; the syntax of REV depends on what BACKEND accepts."
"Default `last-change' implementation.
It returns the last revision that changed LINE number in FILE."
(unless (file-exists-p file)
- (signal 'file-error "File doesn't exist"))
+ (signal 'file-error '("File doesn't exist")))
(with-temp-buffer
(vc-call-backend (vc-backend file) 'annotate-command
file (current-buffer))
diff --git a/lisp/vcursor.el b/lisp/vcursor.el
index ec5adbd832c..15791285b13 100644
--- a/lisp/vcursor.el
+++ b/lisp/vcursor.el
@@ -433,7 +433,7 @@ Default is nil."
(defcustom vcursor-interpret-input nil
"If non-nil, input from the vcursor is treated as interactive input.
This will cause text insertion to be much slower. Note that no special
-interpretation of strings is done: \"\C-x\" is a string of four
+interpretation of strings is done: \"\\C-x\" is a string of four
characters. The default is simply to copy strings."
:type 'boolean
:version "20.3")
diff --git a/lisp/version.el b/lisp/version.el
index 73968b1cd92..a84f7f161f0 100644
--- a/lisp/version.el
+++ b/lisp/version.el
@@ -26,6 +26,31 @@
;;; Code:
+
+
+(defun android-read-build-system ()
+ "Obtain the host name of the system on which Emacs was built.
+Use the data stored in the special file `/assets/build_info'.
+Value is the string ``Unknown'' upon failure, else the hostname
+of the build system."
+ (with-temp-buffer
+ (insert-file-contents "/assets/build_info")
+ (let ((string (buffer-substring 1 (line-end-position))))
+ (and (not (equal string "Unknown")) string))))
+
+(defun android-read-build-time ()
+ "Obtain the time at which Emacs was built.
+Use the data stored in the special file `/assets/build_info'.
+Value is nil upon failure, else the time in the same format as
+returned by `current-time'."
+ (with-temp-buffer
+ (insert-file-contents "/assets/build_info")
+ (end-of-line)
+ (let ((number (read (current-buffer))))
+ (time-convert number 'list))))
+
+
+
(defconst emacs-major-version
(progn (string-match "^[0-9]+" emacs-version)
(string-to-number (match-string 0 emacs-version)))
@@ -36,10 +61,21 @@
(string-to-number (match-string 1 emacs-version)))
"Minor version number of this version of Emacs.")
-(defconst emacs-build-system (system-name)
+;; N.B. (featurep 'android) is tested for in addition to
+;; `system-type', because that can also be Android on a TTY-only
+;; Android build that doesn't employ the window system packaging
+;; support. (bug#65319)
+(defconst emacs-build-system (or (and (featurep 'android)
+ (eq system-type 'android)
+ (android-read-build-system))
+ (system-name))
"Name of the system on which Emacs was built, or nil if not available.")
-(defconst emacs-build-time (if emacs-build-system (current-time))
+(defconst emacs-build-time (if emacs-build-system
+ (or (and (featurep 'android)
+ (eq system-type 'android)
+ (android-read-build-time))
+ (current-time)))
"Time at which Emacs was dumped out, or nil if not available.")
(defconst emacs-build-number 1 ; loadup.el may increment this
@@ -130,9 +166,22 @@ or if we could not determine the revision.")
(looking-at "[[:xdigit:]]\\{40\\}"))
(match-string 0)))))
+(defun emacs-repository-version-android ()
+ "Return the Emacs repository revision Emacs was built from.
+Value is nil if Emacs was not built from a repository checkout.
+Use information from the `/assets/version' special file."
+ (with-temp-buffer
+ (insert-file-contents "/assets/version")
+ (let ((string (buffer-substring 1 (line-end-position))))
+ (and (not (equal string "Unknown")) string))))
+
(defun emacs-repository-get-version (&optional dir _external)
"Try to return as a string the repository revision of the Emacs sources.
The format of the returned string is dependent on the VCS in use.
+
+If Emacs is built for Android, use the version information
+embedded in the Emacs installation package.
+
Value is nil if the sources do not seem to be under version
control, or if we could not determine the revision. Note that
this reports on the current state of the sources, which may not
@@ -140,13 +189,28 @@ correspond to the running Emacs.
Optional argument DIR is a directory to use instead of `source-directory'.
Optional argument EXTERNAL is ignored."
- (emacs-repository-version-git (or dir source-directory)))
+ (cond ((and (featurep 'android)
+ (eq system-type 'android))
+ (emacs-repository-version-android))
+ (t (emacs-repository-version-git
+ (or dir source-directory)))))
(defvar emacs-repository-branch nil
"String giving the repository branch from which this Emacs was built.
Value is nil if Emacs was not built from a repository checkout,
or if we could not determine the branch.")
+(defun emacs-repository-branch-android ()
+ "Return the Emacs repository branch Emacs was built from.
+Value is nil if Emacs was not built from a repository checkout.
+Use information from the `/assets/version' special file."
+ (with-temp-buffer
+ (insert-file-contents "/assets/version")
+ (end-of-line)
+ (forward-char)
+ (let ((string (buffer-substring (point) (line-end-position))))
+ (and (not (equal string "Unknown")) string))))
+
(defun emacs-repository-branch-git (dir)
"Ask git itself for the branch information for directory DIR."
(message "Waiting for git...")
@@ -162,12 +226,20 @@ or if we could not determine the branch.")
(defun emacs-repository-get-branch (&optional dir)
"Try to return as a string the repository branch of the Emacs sources.
The format of the returned string is dependent on the VCS in use.
+
+If Emacs is built for Android, use the version information
+embedded in the Emacs installation package.
+
Value is nil if the sources do not seem to be under version
control, or if we could not determine the branch. Note that
this reports on the current state of the sources, which may not
correspond to the running Emacs.
Optional argument DIR is a directory to use instead of `source-directory'."
- (emacs-repository-branch-git (or dir source-directory)))
+ (cond ((and (featurep 'android)
+ (eq system-type 'android))
+ (emacs-repository-branch-android))
+ (t (emacs-repository-branch-git
+ (or dir source-directory)))))
;;; version.el ends here
diff --git a/lisp/visual-wrap.el b/lisp/visual-wrap.el
new file mode 100644
index 00000000000..d95cf4bb569
--- /dev/null
+++ b/lisp/visual-wrap.el
@@ -0,0 +1,204 @@
+;;; visual-wrap.el --- Smart line-wrapping with wrap-prefix -*- lexical-binding: t -*-
+
+;; Copyright (C) 2011-2021, 2024 Free Software Foundation, Inc.
+
+;; Author: Stephen Berman <stephen.berman@gmx.net>
+;; Stefan Monnier <monnier@iro.umontreal.ca>
+;; Maintainer: emacs-devel@gnu.org
+;; Keywords: convenience
+;; Package: emacs
+
+;; This file is part of GNU Emacs.
+
+;; 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 <http://www.gnu.org/licenses/>.
+
+;;; Commentary:
+
+;; This package provides the `visual-wrap-prefix-mode' minor mode
+;; which sets the wrap-prefix property on the fly so that
+;; single-long-line paragraphs get word-wrapped in a way similar to
+;; what you'd get with M-q using adaptive-fill-mode, but without
+;; actually changing the buffer's text.
+
+;;; Code:
+
+(defcustom visual-wrap-extra-indent 0
+ "Number of extra spaces to indent in `visual-wrap-prefix-mode'.
+
+`visual-wrap-prefix-mode' indents the visual lines to the level
+of the actual line plus `visual-wrap-extra-indent'. A negative
+value will do a relative de-indent.
+
+Examples:
+
+actual indent = 2
+extra indent = -1
+
+ Lorem ipsum dolor sit amet, consectetur adipisicing elit, sed
+ do eiusmod tempor incididunt ut labore et dolore magna
+ aliqua. Ut enim ad minim veniam, quis nostrud exercitation
+ ullamco laboris nisi ut aliquip ex ea commodo consequat.
+
+actual indent = 2
+extra indent = 2
+
+ Lorem ipsum dolor sit amet, consectetur adipisicing elit, sed
+ do eiusmod tempor incididunt ut labore et dolore magna
+ aliqua. Ut enim ad minim veniam, quis nostrud exercitation
+ ullamco laboris nisi ut aliquip ex ea commodo consequat."
+ :type 'integer
+ :safe 'integerp
+ :version "30.1"
+ :group 'visual-line)
+
+(defun visual-wrap--face-extend-p (face)
+ ;; Before Emacs 27, faces always extended beyond EOL, so we check
+ ;; for a non-default background instead.
+ (cond
+ ((listp face)
+ (plist-get face (if (fboundp 'face-extend-p) :extend :background)))
+ ((symbolp face)
+ (if (fboundp 'face-extend-p)
+ (face-extend-p face nil t)
+ (face-background face nil t)))))
+
+(defun visual-wrap--prefix-face (fcp _beg end)
+ ;; If the fill-context-prefix already specifies a face, just use that.
+ (cond ((get-text-property 0 'face fcp))
+ ;; Else, if the last character is a newline and has a face
+ ;; that extends beyond EOL, assume that this face spans the
+ ;; whole line and apply it to the prefix to preserve the
+ ;; "block" visual effect.
+ ;;
+ ;; NB: the face might not actually span the whole line: see
+ ;; for example removed lines in diff-mode, where the first
+ ;; character has the diff-indicator-removed face, while the
+ ;; rest of the line has the diff-removed face.
+ ((= (char-before end) ?\n)
+ (let ((eol-face (get-text-property (1- end) 'face)))
+ ;; `eol-face' can be a face, a "face value"
+ ;; (plist of face properties) or a list of one of those.
+ (if (or (not (consp eol-face)) (keywordp (car eol-face)))
+ ;; A single face.
+ (if (visual-wrap--face-extend-p eol-face) eol-face)
+ ;; A list of faces. Keep the ones that extend beyond EOL.
+ (delq nil (mapcar (lambda (f)
+ (if (visual-wrap--face-extend-p f) f))
+ eol-face)))))))
+
+(defun visual-wrap--prefix (fcp)
+ (let ((fcp-len (string-width fcp)))
+ (cond
+ ((= 0 visual-wrap-extra-indent)
+ fcp)
+ ((< 0 visual-wrap-extra-indent)
+ (concat fcp (make-string visual-wrap-extra-indent ?\s)))
+ ((< 0 (+ visual-wrap-extra-indent fcp-len))
+ (substring fcp
+ 0
+ (+ visual-wrap-extra-indent fcp-len)))
+ (t
+ ""))))
+
+(defun visual-wrap-fill-context-prefix (beg end)
+ "Compute visual wrap prefix from text between BEG and END.
+This is like `fill-context-prefix', but with prefix length adjusted
+by `visual-wrap-extra-indent'."
+ (let* ((fcp
+ ;; `fill-context-prefix' ignores prefixes that look like
+ ;; paragraph starts, in order to avoid inadvertently
+ ;; creating a new paragraph while filling, but here we're
+ ;; only dealing with single-line "paragraphs" and we don't
+ ;; actually modify the buffer, so this restriction doesn't
+ ;; make much sense (and is positively harmful in
+ ;; taskpaper-mode where paragraph-start matches everything).
+ (or (let ((paragraph-start regexp-unmatchable))
+ (fill-context-prefix beg end))
+ ;; Note: fill-context-prefix may return nil; See:
+ ;; http://article.gmane.org/gmane.emacs.devel/156285
+ ""))
+ (prefix (visual-wrap--prefix fcp))
+ (face (visual-wrap--prefix-face fcp beg end)))
+ (if face
+ (propertize prefix 'face face)
+ prefix)))
+
+(defun visual-wrap-prefix-function (beg end)
+ "Indent the region between BEG and END with visual filling."
+ ;; Any change at the beginning of a line might change its wrap
+ ;; prefix, which affects the whole line. So we need to "round-up"
+ ;; `end' to the nearest end of line. We do the same with `beg'
+ ;; although it's probably not needed.
+ (goto-char end)
+ (unless (bolp) (forward-line 1))
+ (setq end (point))
+ (goto-char beg)
+ (forward-line 0)
+ (setq beg (point))
+ (while (< (point) end)
+ (let ((lbp (point)))
+ (put-text-property
+ (point) (progn (search-forward "\n" end 'move) (point))
+ 'wrap-prefix
+ (let ((pfx (visual-wrap-fill-context-prefix
+ lbp (point))))
+ ;; Remove any `wrap-prefix' property that might have been
+ ;; added earlier. Otherwise, we end up with a string
+ ;; containing a `wrap-prefix' string containing a
+ ;; `wrap-prefix' string ...
+ (remove-text-properties
+ 0 (length pfx) '(wrap-prefix) pfx)
+ (let ((dp (get-text-property 0 'display pfx)))
+ (when (and dp (eq dp (get-text-property (1- lbp) 'display)))
+ ;; There's a `display' property which covers not just the
+ ;; prefix but also the previous newline. So it's not
+ ;; just making the prefix more pretty and could interfere
+ ;; or even defeat our efforts (e.g. it comes from
+ ;; `adaptive-fill-mode').
+ (remove-text-properties
+ 0 (length pfx) '(display) pfx)))
+ pfx))))
+ `(jit-lock-bounds ,beg . ,end))
+
+;;;###autoload
+(define-minor-mode visual-wrap-prefix-mode
+ "Display continuation lines with prefixes from surrounding context.
+To enable this minor mode across all buffers, enable
+`global-visual-wrap-prefix-mode'."
+ :lighter ""
+ :group 'visual-line
+ (if visual-wrap-prefix-mode
+ (progn
+ ;; HACK ATTACK! We want to run after font-lock (so our
+ ;; wrap-prefix includes the faces applied by font-lock), but
+ ;; jit-lock-register doesn't accept an `append' argument, so
+ ;; we add ourselves beforehand, to make sure we're at the end
+ ;; of the hook (bug#15155).
+ (add-hook 'jit-lock-functions
+ #'visual-wrap-prefix-function 'append t)
+ (jit-lock-register #'visual-wrap-prefix-function))
+ (jit-lock-unregister #'visual-wrap-prefix-function)
+ (with-silent-modifications
+ (save-restriction
+ (widen)
+ (remove-text-properties (point-min) (point-max) '(wrap-prefix nil))))))
+
+;;;###autoload
+(define-globalized-minor-mode global-visual-wrap-prefix-mode
+ visual-wrap-prefix-mode visual-wrap-prefix-mode
+ :init-value nil
+ :group 'visual-line)
+
+(provide 'visual-wrap)
+;;; visual-wrap.el ends here
diff --git a/lisp/w32-fns.el b/lisp/w32-fns.el
index 26b0ce7300e..a68f1ceec35 100644
--- a/lisp/w32-fns.el
+++ b/lisp/w32-fns.el
@@ -331,7 +331,7 @@ names."
(vminor
(w32-read-registry 'HKLM key
"CurrentMinorVersionNumber")))
- (if (and vmajor vmajor)
+ (if (and vmajor vminor)
(format "%d.%d" vmajor vminor)
(w32-read-registry 'HKLM key "CurrentVersion")))))
(os-csd (w32-read-registry 'HKLM key "CSDVersion"))
diff --git a/lisp/wdired.el b/lisp/wdired.el
index 99858226eee..d5d593483dc 100644
--- a/lisp/wdired.el
+++ b/lisp/wdired.el
@@ -261,6 +261,10 @@ See `wdired-mode'."
(add-function :override (local 'revert-buffer-function) #'wdired-revert)
(set-buffer-modified-p nil)
(setq buffer-undo-list nil)
+ ;; Non-nil `dired-filename-display-length' may cause filenames to be
+ ;; hidden partly, so we remove filename invisibility spec
+ ;; temporarily to ensure filenames are visible for editing.
+ (dired-filename-update-invisibility-spec)
(run-mode-hooks 'wdired-mode-hook)
(message "%s" (substitute-command-keys
"Press \\[wdired-finish-edit] when finished \
@@ -453,9 +457,12 @@ non-nil means return old filename."
(force-mode-line-update)
(setq buffer-read-only t)
(setq major-mode 'dired-mode)
- (setq mode-name "Dired")
+ (dired-sort-set-mode-line)
(dired-advertise)
(dired-hide-details-update-invisibility-spec)
+ ;; Restore filename invisibility spec that is removed in
+ ;; `wdired-change-to-wdired-mode'.
+ (dired-filename-update-invisibility-spec)
(remove-hook 'kill-buffer-hook #'wdired-check-kill-buffer t)
(remove-hook 'before-change-functions #'wdired--before-change-fn t)
(remove-hook 'after-change-functions #'wdired--restore-properties t)
@@ -556,8 +563,24 @@ non-nil means return old filename."
;; been modified with their new name keeping
;; the ones that are unmodified at the same place.
(cl-loop for f in (cdr dired-directory)
- collect (or (assoc-default f files-renamed)
- f))))))
+ collect
+ (or (assoc-default f files-renamed)
+ ;; F could be relative or
+ ;; abbreviated, whereas
+ ;; files-renamed always consists
+ ;; of absolute file names.
+ (let ((relative
+ (not (file-name-absolute-p f)))
+ (match
+ (assoc-default (expand-file-name f)
+ files-renamed)))
+ (cond
+ ;; If it was relative, convert
+ ;; the new name back to relative.
+ ((and match relative)
+ (file-relative-name match))
+ (t match)))
+ f))))))
;; Re-sort the buffer.
(revert-buffer)
(let ((inhibit-read-only t))
diff --git a/lisp/whitespace.el b/lisp/whitespace.el
index b93ebe95a4f..15c1b83fcc1 100644
--- a/lisp/whitespace.el
+++ b/lisp/whitespace.el
@@ -3,7 +3,7 @@
;; Copyright (C) 2000-2024 Free Software Foundation, Inc.
;; Author: Vinicius Jose Latorre <viniciusjl.gnu@gmail.com>
-;; Keywords: data, wp
+;; Keywords: data, text
;; Version: 13.2.2
;; URL: https://www.emacswiki.org/cgi-bin/wiki/ViniciusJoseLatorre
@@ -1014,34 +1014,11 @@ See also `whitespace-newline' and `whitespace-display-mappings'."
;;;###autoload
-(define-minor-mode global-whitespace-mode
- "Toggle whitespace visualization globally (Global Whitespace mode).
-
-See also `whitespace-style', `whitespace-newline' and
-`whitespace-display-mappings'."
- :lighter " WS"
+(define-globalized-minor-mode global-whitespace-mode
+ whitespace-mode
+ whitespace-turn-on-if-enabled
:init-value nil
- :global t
- :group 'whitespace
- (cond
- (noninteractive ; running a batch job
- (setq global-whitespace-mode nil))
- (global-whitespace-mode ; global-whitespace-mode on
- (save-current-buffer
- (add-hook 'find-file-hook 'whitespace-turn-on-if-enabled)
- (add-hook 'after-change-major-mode-hook 'whitespace-turn-on-if-enabled)
- (dolist (buffer (buffer-list)) ; adjust all local mode
- (set-buffer buffer)
- (unless whitespace-mode
- (whitespace-turn-on-if-enabled)))))
- (t ; global-whitespace-mode off
- (save-current-buffer
- (remove-hook 'find-file-hook 'whitespace-turn-on-if-enabled)
- (remove-hook 'after-change-major-mode-hook 'whitespace-turn-on-if-enabled)
- (dolist (buffer (buffer-list)) ; adjust all local mode
- (set-buffer buffer)
- (unless whitespace-mode
- (whitespace-turn-off)))))))
+ :group 'whitespace)
(defvar whitespace-enable-predicate
(lambda ()
@@ -1049,8 +1026,8 @@ See also `whitespace-style', `whitespace-newline' and
((eq whitespace-global-modes t))
((listp whitespace-global-modes)
(if (eq (car-safe whitespace-global-modes) 'not)
- (not (apply #'derived-mode-p (cdr whitespace-global-modes)))
- (apply #'derived-mode-p whitespace-global-modes)))
+ (not (derived-mode-p (cdr whitespace-global-modes)))
+ (derived-mode-p whitespace-global-modes)))
(t nil))
;; ...we have a display (not running a batch job)
(not noninteractive)
@@ -1067,7 +1044,7 @@ This variable is normally modified via `add-function'.")
(defun whitespace-turn-on-if-enabled ()
(when (funcall whitespace-enable-predicate)
- (whitespace-turn-on)))
+ (whitespace-mode)))
;;;###autoload
(define-minor-mode global-whitespace-newline-mode
@@ -1797,10 +1774,10 @@ cleaning up these problems."
(when has-bogus
(goto-char (point-max))
(insert (substitute-command-keys
- " Type `\\[whitespace-cleanup]'")
+ " Type \\[whitespace-cleanup]")
" to cleanup the buffer.\n\n"
(substitute-command-keys
- " Type `\\[whitespace-cleanup-region]'")
+ " Type \\[whitespace-cleanup-region]")
" to cleanup a region.\n\n"))
(whitespace-display-window (current-buffer))))))
has-bogus)))
@@ -2511,7 +2488,7 @@ purposes)."
(setq whitespace-display-table-was-local t)
;; Save the old table so we can restore it when
;; `whitespace-mode' is switched off again.
- (when (or whitespace-mode global-whitespace-mode)
+ (when whitespace-mode
(setq whitespace-display-table
(copy-sequence buffer-display-table)))
;; Assure `buffer-display-table' is unique
diff --git a/lisp/wid-browse.el b/lisp/wid-browse.el
index bb56f3f62fb..d4000187bd1 100644
--- a/lisp/wid-browse.el
+++ b/lisp/wid-browse.el
@@ -141,7 +141,7 @@ The following commands are available:
(setq key (nth 0 items)
value (nth 1 items)
printer (or (get key 'widget-keyword-printer)
- 'widget-browse-sexp)
+ #'widget-browse-sexp)
items (cdr (cdr items)))
(widget-insert "\n" (symbol-name key) "\n\t")
(funcall printer widget key value)
@@ -204,24 +204,10 @@ VALUE is assumed to be a list of widgets."
(defun widget-browse-sexp (_widget _key value)
"Insert description of WIDGET's KEY VALUE.
Nothing is assumed about value."
- (let ((pp (condition-case signal
- (pp-to-string value)
- (error (prin1-to-string signal)))))
- (when (string-match "\n\\'" pp)
- (setq pp (substring pp 0 (1- (length pp)))))
- (if (cond ((string-search "\n" pp)
- nil)
- ((> (length pp) (- (window-width) (current-column)))
- nil)
- (t t))
- (widget-insert pp)
- (widget-create 'push-button
- :tag "show"
- :action (lambda (widget &optional _event)
- (with-output-to-temp-buffer
- "*Pp Eval Output*"
- (princ (widget-get widget :value))))
- pp))))
+ (require 'pp)
+ (declare-function pp-insert-short-sexp "pp" (sexp &optional width))
+ (widget--allow-insertion
+ (pp-insert-short-sexp value)))
(defun widget-browse-sexps (widget key value)
"Insert description of WIDGET's KEY VALUE.
@@ -235,11 +221,11 @@ VALUE is assumed to be a list of widgets."
;;; Keyword Printers.
-(put :parent 'widget-keyword-printer 'widget-browse-widget)
-(put :children 'widget-keyword-printer 'widget-browse-widgets)
-(put :buttons 'widget-keyword-printer 'widget-browse-widgets)
-(put :button 'widget-keyword-printer 'widget-browse-widget)
-(put :args 'widget-keyword-printer 'widget-browse-sexps)
+(put :parent 'widget-keyword-printer #'widget-browse-widget)
+(put :children 'widget-keyword-printer #'widget-browse-widgets)
+(put :buttons 'widget-keyword-printer #'widget-browse-widgets)
+(put :button 'widget-keyword-printer #'widget-browse-widget)
+(put :args 'widget-keyword-printer #'widget-browse-sexps)
;;; Widget Minor Mode.
diff --git a/lisp/wid-edit.el b/lisp/wid-edit.el
index dc5fa4a4fac..172da3db1e0 100644
--- a/lisp/wid-edit.el
+++ b/lisp/wid-edit.el
@@ -1,4 +1,4 @@
-;;; wid-edit.el --- Functions for creating and using widgets -*- lexical-binding:t -*-
+;; wid-edit.el --- Functions for creating and using widgets -*- lexical-binding:t -*-
;;
;; Copyright (C) 1996-1997, 1999-2024 Free Software Foundation, Inc.
;;
@@ -64,8 +64,9 @@
;;; Compatibility.
-(defun widget-event-point (event)
- "Character position of the end of event if that exists, or nil."
+(defsubst widget-event-point (event)
+ "Character position of the end of event if that exists, or nil.
+EVENT can either be a mouse event or a touch screen event."
(posn-point (event-end event)))
(defun widget-button-release-event-p (event)
@@ -246,10 +247,10 @@ to evaluate to nil for the menu item to be meaningful."
(eq (car value) :radio))
(setq selected (cdr value))))
(setq plist (cddr plist)))
- (when (and (eval visible)
- (eval enable)
+ (when (and (eval visible t)
+ (eval enable t)
(or (not selected)
- (not (eval selected))))
+ (not (eval selected t))))
(push (cons (nth 1 def) ev) simplified)))))
extended)
(reverse simplified)))
@@ -281,71 +282,82 @@ The user is asked to choose between each NAME from ITEMS.
If ITEMS has simple item definitions, then this function returns the VALUE of
the chosen element. If ITEMS is a keymap, then the return value is the symbol
in the key vector, as in the argument of `define-key'."
- (cond ((and (< (length items) widget-menu-max-size)
- event (display-popup-menus-p))
- ;; Mouse click.
- (if (keymapp items)
- ;; Modify the keymap prompt, and then restore the old one, if any.
- (let ((prompt (keymap-prompt items)))
- (unwind-protect
- (progn
- (setq items (delete prompt items))
- (push title (cdr items))
- ;; Return just the first element of the list of events.
- (car (x-popup-menu event items)))
- (setq items (delete title items))
- (when prompt
- (push prompt (cdr items)))))
- (x-popup-menu event (list title (cons "" items)))))
- ((or widget-menu-minibuffer-flag
- (> (length items) widget-menu-max-shortcuts))
- (when (keymapp items)
- (setq items (widget--simplify-menu items)))
- ;; Read the choice of name from the minibuffer.
- (setq items (cl-remove-if 'stringp items))
- (let ((val (completing-read (concat title ": ") items nil t)))
- (if (stringp val)
- (let ((try (try-completion val items)))
- (when (stringp try)
- (setq val try))
- (cdr (assoc val items))))))
- (t
- (when (keymapp items)
- (setq items (widget--simplify-menu items)))
- ;; Construct a menu of the choices
- ;; and then use it for prompting for a single character.
- (let* ((next-digit ?0)
- alist choice some-choice-enabled value)
- (with-current-buffer (get-buffer-create " widget-choose")
- (erase-buffer)
- (insert "Available choices:\n\n")
- (while items
- (setq choice (pop items))
- (when (consp choice)
- (let* ((name (substitute-command-keys (car choice)))
- (function (cdr choice)))
- (insert (format "%c = %s\n" next-digit name))
- (push (cons next-digit function) alist)
- (setq some-choice-enabled t)))
- ;; Allocate digits to disabled alternatives
- ;; so that the digit of a given alternative never varies.
- (setq next-digit (1+ next-digit)))
- (insert "\nC-g = Quit")
- (goto-char (point-min))
- (forward-line))
- (or some-choice-enabled
- (error "None of the choices is currently meaningful"))
- (save-window-excursion
- ;; Select window to be able to scroll it from minibuffer
- (with-selected-window
- (display-buffer (get-buffer " widget-choose")
- '(display-buffer-in-direction
- (direction . bottom)
- (window-height . fit-window-to-buffer)))
- (setq value (read-char-choice
- (format "%s: " title)
- (mapcar #'car alist)))))
- (cdr (assoc value alist))))))
+ ;; Apply substitution to choice menu title and item text, whether it
+ ;; occurs in a widget buffer or in a popup menu.
+ (let ((items (mapc (lambda (x)
+ (if (proper-list-p x)
+ (dotimes (i (1- (length x)))
+ (when (stringp (nth i x))
+ (setcar (nthcdr i x)
+ (substitute-command-keys
+ (car (nthcdr i x))))))
+ ;; ITEMS has simple item definitions.
+ (when (and (consp x) (stringp (car x)))
+ (setcar x (substitute-command-keys (car x))))))
+ items))
+ (title (substitute-command-keys title)))
+ (cond ((and (< (length items) widget-menu-max-size)
+ event (display-popup-menus-p))
+ ;; Mouse click.
+ (if (keymapp items)
+ ;; Modify the keymap prompt, and then restore the old one, if any.
+ (let ((prompt (keymap-prompt items)))
+ (unwind-protect
+ (progn
+ (setq items (delete prompt items))
+ (push title (cdr items))
+ ;; Return just the first element of the list of events.
+ (car (x-popup-menu event items)))
+ (setq items (delete title items))
+ (when prompt
+ (push prompt (cdr items)))))
+ (x-popup-menu event (list title (cons "" items)))))
+ ((or widget-menu-minibuffer-flag
+ (> (length items) widget-menu-max-shortcuts))
+ (when (keymapp items)
+ (setq items (widget--simplify-menu items)))
+ ;; Read the choice of name from the minibuffer.
+ (setq items (cl-remove-if #'stringp items))
+ (let ((val (completing-read (concat title ": ") items nil t)))
+ (if (stringp val)
+ (let ((try (try-completion val items)))
+ (when (stringp try)
+ (setq val try))
+ (cdr (assoc val items))))))
+ (t
+ (when (keymapp items)
+ (setq items (widget--simplify-menu items)))
+ ;; Construct a menu of the choices
+ ;; and then use it for prompting for a single character.
+ (let ((next-digit ?0)
+ alist some-choice-enabled value)
+ (with-current-buffer (get-buffer-create " widget-choose")
+ (erase-buffer)
+ (insert "Available choices:\n\n")
+ (dolist (choice items)
+ (when (consp choice)
+ (insert (format "%c = %s\n" next-digit (car choice)))
+ (push (cons next-digit (cdr choice)) alist)
+ (setq some-choice-enabled t))
+ ;; Allocate digits to disabled alternatives
+ ;; so that the digit of a given alternative never varies.
+ (setq next-digit (1+ next-digit)))
+ (insert "\nC-g = Quit")
+ (goto-char (point-min))
+ (forward-line))
+ (or some-choice-enabled
+ (error "None of the choices is currently meaningful"))
+ (save-window-excursion
+ ;; Select window to be able to scroll it from minibuffer
+ (with-selected-window
+ (display-buffer (get-buffer " widget-choose")
+ '(display-buffer-in-direction
+ (direction . bottom)
+ (window-height . fit-window-to-buffer)))
+ (setq value (read-char-choice
+ (format "%s: " title)
+ (mapcar #'car alist)))))
+ (cdr (assoc value alist)))))))
;;; Widget text specifications.
;;
@@ -497,14 +509,20 @@ With CHECK-AFTER non-nil, considers also the content after point, if needed."
;; indented it.
(not (eq (following-char) ?\s))))))
-(defmacro widget-specify-insert (&rest form)
- "Execute FORM without inheriting any text properties."
- (declare (debug (body)))
+(defmacro widget--allow-insertion (&rest forms)
+ "Run FORMS such that they can insert widgets in the current buffer."
+ (declare (debug t))
+ `(let ((inhibit-read-only t)
+ (inhibit-modification-hooks t)) ;; FIXME: Why? This is risky!
+ ,@forms))
+
+(defmacro widget-specify-insert (&rest forms)
+ "Execute FORMS without inheriting any text properties."
+ (declare (debug t))
`(save-restriction
- (let ((inhibit-read-only t)
- (inhibit-modification-hooks t))
+ (widget--allow-insertion
(narrow-to-region (point) (point))
- (prog1 (progn ,@form)
+ (prog1 (progn ,@forms)
(goto-char (point-max))))))
(defface widget-inactive
@@ -635,8 +653,7 @@ Return a list whose car contains all members of VALS that matched WIDGET."
(defun widget-prompt-value (widget prompt &optional value unbound)
"Prompt for a value matching WIDGET, using PROMPT.
The current value is assumed to be VALUE, unless UNBOUND is non-nil."
- (unless (listp widget)
- (setq widget (list widget)))
+ (setq widget (ensure-list widget))
(setq prompt (format "[%s] %s" (widget-type widget) prompt))
(setq widget (widget-convert widget))
(let ((answer (widget-apply widget :prompt-value prompt value unbound)))
@@ -647,12 +664,9 @@ The current value is assumed to be VALUE, unless UNBOUND is non-nil."
(defun widget-get-sibling (widget)
"Get the item WIDGET is assumed to toggle.
This is only meaningful for radio buttons or checkboxes in a list."
- (let* ((children (widget-get (widget-get widget :parent) :children))
- child)
+ (let* ((children (widget-get (widget-get widget :parent) :children)))
(catch 'child
- (while children
- (setq child (car children)
- children (cdr children))
+ (dolist (child children)
(when (eq (widget-get child :button) widget)
(throw 'child child)))
nil)))
@@ -832,14 +846,14 @@ button is pressed or inactive, respectively. These are currently ignored."
(defun widget-create (type &rest args)
"Create widget of TYPE.
The optional ARGS are additional keyword arguments."
- (let ((widget (apply 'widget-convert type args)))
+ (let ((widget (apply #'widget-convert type args)))
(widget-apply widget :create)
widget))
(defun widget-create-child-and-convert (parent type &rest args)
"As part of the widget PARENT, create a child widget TYPE.
The child is converted, using the keyword arguments ARGS."
- (let ((widget (apply 'widget-convert type args)))
+ (let ((widget (apply #'widget-convert type args)))
(widget-put widget :parent parent)
(unless (widget-get widget :indent)
(widget-put widget :indent (+ (or (widget-get parent :indent) 0)
@@ -893,18 +907,19 @@ The optional ARGS are additional keyword arguments."
(keys args))
;; First set the :args keyword.
(while (cdr current) ;Look in the type.
- (if (and (keywordp (cadr current))
- ;; If the last element is a keyword,
- ;; it is still the :args element,
- ;; even though it is a keyword.
- (cddr current))
- (if (eq (cadr current) :args)
- ;; If :args is explicitly specified, obey it.
- (setq current nil)
- ;; Some other irrelevant keyword.
- (setq current (cdr (cdr current))))
- (setcdr current (list :args (cdr current)))
- (setq current nil)))
+ (setq current
+ (if (and (keywordp (cadr current))
+ ;; If the last element is a keyword,
+ ;; it is still the :args element,
+ ;; even though it is a keyword.
+ (cddr current))
+ (if (eq (cadr current) :args)
+ ;; If :args is explicitly specified, obey it.
+ nil
+ ;; Some other irrelevant keyword.
+ (cdr (cdr current)))
+ (setcdr current (list :args (cdr current)))
+ nil)))
(while (and args (not done)) ;Look in ARGS.
(cond ((eq (car args) :args)
;; Handle explicit specification of :args.
@@ -925,11 +940,9 @@ The optional ARGS are additional keyword arguments."
;; Finally set the keyword args.
(while keys
(let ((next (nth 0 keys)))
- (if (keywordp next)
- (progn
- (widget-put widget next (nth 1 keys))
- (setq keys (nthcdr 2 keys)))
- (setq keys nil))))
+ (setq keys (when (keywordp next)
+ (widget-put widget next (nth 1 keys))
+ (nthcdr 2 keys)))))
;; Convert the :value to internal format.
(if (widget-member widget :value)
(widget-put widget
@@ -942,9 +955,8 @@ The optional ARGS are additional keyword arguments."
;;;###autoload
(defun widget-insert (&rest args)
"Call `insert' with ARGS even if surrounding text is read only."
- (let ((inhibit-read-only t)
- (inhibit-modification-hooks t))
- (apply 'insert args)))
+ (widget--allow-insertion
+ (apply #'insert args)))
(defun widget-convert-text (type from to
&optional button-from button-to
@@ -955,7 +967,7 @@ and TO will be used as the widgets end points. If optional arguments
BUTTON-FROM and BUTTON-TO are given, these will be used as the widgets
button end points.
Optional ARGS are extra keyword arguments for TYPE."
- (let ((widget (apply 'widget-convert type :delete 'widget-leave-text args))
+ (let ((widget (apply #'widget-convert type :delete 'widget-leave-text args))
(from (copy-marker from))
(to (copy-marker to)))
(set-marker-insertion-type from t)
@@ -972,7 +984,7 @@ Optional ARGS are extra keyword arguments for TYPE.
No text will be inserted to the buffer, instead the text between FROM
and TO will be used as the widgets end points, as well as the widgets
button end points."
- (apply 'widget-convert-text type from to from to args))
+ (apply #'widget-convert-text type from to from to args))
(defun widget-leave-text (widget)
"Remove markers and overlays from WIDGET and its children."
@@ -990,7 +1002,7 @@ button end points."
(delete-overlay doc))
(when field
(delete-overlay field))
- (mapc 'widget-leave-text (widget-get widget :children))))
+ (mapc #'widget-leave-text (widget-get widget :children))))
(defun widget-text (widget)
"Get the text representation of the widget."
@@ -1005,7 +1017,7 @@ button end points."
;; Custom-mode) which key-binding of widget-keymap one wants to refer to.
;; https://lists.gnu.org/r/emacs-devel/2008-11/msg00480.html
(define-obsolete-function-alias 'advertised-widget-backward
- 'widget-backward "23.2")
+ #'widget-backward "23.2")
;;;###autoload
(defvar widget-keymap
@@ -1017,6 +1029,7 @@ button end points."
(define-key map [backtab] 'widget-backward)
(define-key map [down-mouse-2] 'widget-button-click)
(define-key map [down-mouse-1] 'widget-button-click)
+ (define-key map [touchscreen-begin] 'widget-button-click)
;; The following definition needs to avoid using escape sequences that
;; might get converted to ^M when building loaddefs.el
(define-key map [(control ?m)] 'widget-button-press)
@@ -1030,13 +1043,13 @@ Note that such modes will need to require wid-edit.")
(defvar widget-field-keymap
(let ((map (copy-keymap widget-keymap)))
- (define-key map "\C-k" 'widget-kill-line)
- (define-key map "\M-\t" 'widget-complete)
- (define-key map "\C-m" 'widget-field-activate)
+ (define-key map "\C-k" #'widget-kill-line)
+ (define-key map "\M-\t" #'widget-complete)
+ (define-key map "\C-m" #'widget-field-activate)
;; Since the widget code uses a `field' property to identify fields,
;; ordinary beginning-of-line does the right thing.
- ;; (define-key map "\C-a" 'widget-beginning-of-line)
- (define-key map "\C-e" 'widget-end-of-line)
+ ;; (define-key map "\C-a" #'widget-beginning-of-line)
+ (define-key map "\C-e" #'widget-end-of-line)
map)
"Keymap used inside an editable field.")
@@ -1044,8 +1057,8 @@ Note that such modes will need to require wid-edit.")
(let ((map (copy-keymap widget-keymap)))
;; Since the widget code uses a `field' property to identify fields,
;; ordinary beginning-of-line does the right thing.
- ;; (define-key map "\C-a" 'widget-beginning-of-line)
- (define-key map "\C-e" 'widget-end-of-line)
+ ;; (define-key map "\C-a" #'widget-beginning-of-line)
+ (define-key map "\C-e" #'widget-end-of-line)
map)
"Keymap used inside a text field.")
@@ -1074,6 +1087,7 @@ If nil, point returns to its original position after invoking a button.")
(defun widget-button--check-and-call-button (event button)
"Call BUTTON if BUTTON is a widget and EVENT is correct for it.
+EVENT can either be a mouse event or a touchscreen-begin event.
If nothing was called, return non-nil."
(let* ((oevent event)
(mouse-1 (memq (event-basic-type event) '(mouse-1 down-mouse-1)))
@@ -1093,40 +1107,49 @@ If nothing was called, return non-nil."
(face (overlay-get overlay 'face))
(mouse-face (overlay-get overlay 'mouse-face)))
(unwind-protect
- ;; Read events, including mouse-movement
- ;; events, waiting for a release event. If we
- ;; began with a mouse-1 event and receive a
- ;; movement event, that means the user wants
- ;; to perform drag-selection, so cancel the
- ;; button press and do the default mouse-1
- ;; action. For mouse-2, just highlight/
- ;; unhighlight the button the mouse was
- ;; initially on when we move over it.
+ ;; Read events, including mouse-movement events,
+ ;; waiting for a release event. If we began with a
+ ;; mouse-1 event and receive a movement event, that
+ ;; means the user wants to perform drag-selection, so
+ ;; cancel the button press and do the default mouse-1
+ ;; action. For mouse-2, just highlight/ unhighlight
+ ;; the button the mouse was initially on when we move
+ ;; over it.
+ ;;
+ ;; If this function was called in response to a
+ ;; touchscreen event, then wait for a corresponding
+ ;; touchscreen-end event instead.
(save-excursion
(when face ; avoid changing around image
(overlay-put overlay 'face pressed-face)
(overlay-put overlay 'mouse-face pressed-face))
- (unless (widget-apply button :mouse-down-action event)
- (let ((track-mouse t))
- (while (not (widget-button-release-event-p event))
- (setq event (read--potential-mouse-event))
- (when (and mouse-1 (mouse-movement-p event))
- (push event unread-command-events)
- (setq event oevent)
- (throw 'button-press-cancelled t))
- (unless (or (integerp event)
- (memq (car event)
- '(switch-frame select-window))
- (eq (car event) 'scroll-bar-movement))
- (setq pos (widget-event-point event))
- (if (and pos
- (eq (get-char-property pos 'button)
- button))
- (when face
- (overlay-put overlay 'face pressed-face)
- (overlay-put overlay 'mouse-face pressed-face))
- (overlay-put overlay 'face face)
- (overlay-put overlay 'mouse-face mouse-face))))))
+ (if (eq (car event) 'touchscreen-begin)
+ ;; This a touchscreen event and must be handled
+ ;; specially through `touch-screen-track-tap'.
+ (progn
+ (unless (touch-screen-track-tap event nil nil t)
+ (throw 'button-press-cancelled t)))
+ (unless (widget-apply button :mouse-down-action event)
+ (let ((track-mouse t))
+ (while (not (widget-button-release-event-p event))
+ (setq event (read--potential-mouse-event))
+ (when (and mouse-1 (mouse-movement-p event))
+ (push event unread-command-events)
+ (setq event oevent)
+ (throw 'button-press-cancelled t))
+ (unless (or (integerp event)
+ (memq (car event)
+ '(switch-frame select-window))
+ (eq (car event) 'scroll-bar-movement))
+ (setq pos (widget-event-point event))
+ (if (and pos
+ (eq (get-char-property pos 'button)
+ button))
+ (when face
+ (overlay-put overlay 'face pressed-face)
+ (overlay-put overlay 'mouse-face pressed-face))
+ (overlay-put overlay 'face face)
+ (overlay-put overlay 'mouse-face mouse-face)))))))
;; When mouse is released over the button, run
;; its action function.
@@ -1155,30 +1178,37 @@ If nothing was called, return non-nil."
(when (or (null button)
(widget-button--check-and-call-button event button))
- (let ((up t)
+ (let ((up (not (eq (car event) 'touchscreen-begin)))
command)
;; Mouse click not on a widget button. Find the global
;; command to run, and check whether it is bound to an
;; up event.
- (if mouse-1
- (cond ((setq command ;down event
- (lookup-key widget-global-map [down-mouse-1]))
- (setq up nil))
- ((setq command ;up event
- (lookup-key widget-global-map [mouse-1]))))
- (cond ((setq command ;down event
- (lookup-key widget-global-map [down-mouse-2]))
- (setq up nil))
- ((setq command ;up event
- (lookup-key widget-global-map [mouse-2])))))
+ (cond
+ ((eq (car event) 'touchscreen-begin)
+ (setq command 'touch-screen-handle-touch))
+ (mouse-1 (cond ((setq command ;down event
+ (lookup-key widget-global-map [down-mouse-1]))
+ (setq up nil))
+ ((setq command ;up event
+ (lookup-key widget-global-map [mouse-1])))))
+ (t (cond ((setq command ;down event
+ (lookup-key widget-global-map [down-mouse-2]))
+ (setq up nil))
+ ((setq command ;up event
+ (lookup-key widget-global-map [mouse-2]))))))
(when up
;; Don't execute up events twice.
- (while (not (widget-button-release-event-p event))
+ (while (not (and (widget-button-release-event-p event)))
(setq event (read--potential-mouse-event))))
(when command
(call-interactively command)))))
(message "You clicked somewhere weird.")))
+;; Make sure `touch-screen-handle-touch' abstains from emulating
+;; down-mouse-1 events for `widget-button-click'.
+
+(put 'widget-button-click 'ignored-mouse-command t)
+
(defun widget-button-press (pos &optional event)
"Invoke button at POS."
(interactive "@d")
@@ -1269,7 +1299,7 @@ With optional ARG, move across that many fields."
;; Since the widget code uses a `field' property to identify fields,
;; ordinary beginning-of-line does the right thing.
-(defalias 'widget-beginning-of-line 'beginning-of-line)
+(defalias 'widget-beginning-of-line #'beginning-of-line)
(defun widget-end-of-line ()
"Go to end of field or end of line, whichever is first.
@@ -1346,19 +1376,18 @@ When not inside a field, signal an error."
;;;###autoload
(defun widget-setup ()
"Setup current buffer so editing string widgets works."
- (let ((inhibit-read-only t)
- (inhibit-modification-hooks t)
- field)
- (while widget-field-new
- (setq field (car widget-field-new)
- widget-field-new (cdr widget-field-new)
- widget-field-list (cons field widget-field-list))
- (let ((from (car (widget-get field :field-overlay)))
- (to (cdr (widget-get field :field-overlay))))
- (widget-specify-field field
- (marker-position from) (marker-position to))
- (set-marker from nil)
- (set-marker to nil))))
+ (widget--allow-insertion
+ (let (field)
+ (while widget-field-new
+ (setq field (car widget-field-new)
+ widget-field-new (cdr widget-field-new)
+ widget-field-list (cons field widget-field-list))
+ (let ((from (car (widget-get field :field-overlay)))
+ (to (cdr (widget-get field :field-overlay))))
+ (widget-specify-field field
+ (marker-position from) (marker-position to))
+ (set-marker from nil)
+ (set-marker to nil)))))
(widget-clear-undo)
(widget-add-change))
@@ -1433,11 +1462,8 @@ When not inside a field, signal an error."
(defun widget-field-find (pos)
"Return the field at POS.
Unlike (get-char-property POS \\='field), this works with empty fields too."
- (let ((fields widget-field-list)
- field found)
- (while fields
- (setq field (car fields)
- fields (cdr fields))
+ (let (found)
+ (dolist (field widget-field-list)
(when (and (<= (widget-field-start field) pos)
(<= pos (widget-field-end field)))
(when found
@@ -1452,11 +1478,11 @@ Unlike (get-char-property POS \\='field), this works with empty fields too."
(let ((from-field (widget-field-find from))
(to-field (widget-field-find to)))
(cond ((not (eq from-field to-field))
- (add-hook 'post-command-hook 'widget-add-change nil t)
+ (add-hook 'post-command-hook #'widget-add-change nil t)
(signal 'text-read-only
'("Change should be restricted to a single field")))
((null from-field)
- (add-hook 'post-command-hook 'widget-add-change nil t)
+ (add-hook 'post-command-hook #'widget-add-change nil t)
(signal 'text-read-only
'("Attempt to change text outside editable field")))
(widget-field-use-before-change
@@ -1464,9 +1490,9 @@ Unlike (get-char-property POS \\='field), this works with empty fields too."
from-field (list 'before-change from to)))))))
(defun widget-add-change ()
- (remove-hook 'post-command-hook 'widget-add-change t)
- (add-hook 'before-change-functions 'widget-before-change nil t)
- (add-hook 'after-change-functions 'widget-after-change nil t))
+ (remove-hook 'post-command-hook #'widget-add-change t)
+ (add-hook 'before-change-functions #'widget-before-change nil t)
+ (add-hook 'after-change-functions #'widget-after-change nil t))
(defun widget-after-change (from to _old)
"Adjust field size and text properties."
@@ -1486,12 +1512,12 @@ Unlike (get-char-property POS \\='field), this works with empty fields too."
(insert-char ?\s (- (+ begin size) end))))
((> (- end begin) size)
;; Field too large and
- (if (or (< (point) (+ begin size))
- (> (point) end))
- ;; Point is outside extra space.
- (setq begin (+ begin size))
- ;; Point is within the extra space.
- (setq begin (point)))
+ (setq begin (if (or (< (point) (+ begin size))
+ (> (point) end))
+ ;; Point is outside extra space.
+ (+ begin size)
+ ;; Point is within the extra space.
+ (point)))
(save-excursion
(goto-char end)
(while (and (eq (preceding-char) ?\s)
@@ -1511,9 +1537,9 @@ Optional EVENT is the event that triggered the action."
(defun widget-children-value-delete (widget)
"Delete all :children and :buttons in WIDGET."
- (mapc 'widget-delete (widget-get widget :children))
+ (mapc #'widget-delete (widget-get widget :children))
(widget-put widget :children nil)
- (mapc 'widget-delete (widget-get widget :buttons))
+ (mapc #'widget-delete (widget-get widget :buttons))
(widget-put widget :buttons nil))
(defun widget-children-validate (widget)
@@ -1564,13 +1590,13 @@ The value of the :type attribute should be an unconverted widget type."
(defun widget-types-copy (widget)
"Copy :args as widget types in WIDGET."
- (widget-put widget :args (mapcar 'widget-copy (widget-get widget :args)))
+ (widget-put widget :args (mapcar #'widget-copy (widget-get widget :args)))
widget)
;; Made defsubst to speed up face editor creation.
(defsubst widget-types-convert-widget (widget)
"Convert :args as widget types in WIDGET."
- (widget-put widget :args (mapcar 'widget-convert (widget-get widget :args)))
+ (widget-put widget :args (mapcar #'widget-convert (widget-get widget :args)))
widget)
(defun widget-value-convert-widget (widget)
@@ -1625,17 +1651,18 @@ The value of the :type attribute should be an unconverted widget type."
(defun widget-default-completions (widget)
"Return completion data, like `completion-at-point-functions' would."
(let ((completions (widget-get widget :completions)))
- (if completions
- (list (widget-field-start widget)
- (max (point) (widget-field-text-end widget))
- completions)
- (if (widget-get widget :complete)
- (lambda () (widget-apply widget :complete))
- (if (widget-get widget :complete-function)
- (lambda ()
- (let ((widget--completing-widget widget))
- (call-interactively
- (widget-get widget :complete-function)))))))))
+ (cond
+ (completions
+ (list (widget-field-start widget)
+ (max (point) (widget-field-text-end widget))
+ completions))
+ ((widget-get widget :complete)
+ (lambda () (widget-apply widget :complete)))
+ ((widget-get widget :complete-function)
+ (lambda ()
+ (let ((widget--completing-widget widget))
+ (call-interactively
+ (widget-get widget :complete-function))))))))
(defun widget-default-create (widget)
"Create WIDGET at point in the current buffer."
@@ -1743,24 +1770,23 @@ The value of the :type attribute should be an unconverted widget type."
(inactive-overlay (widget-get widget :inactive))
(button-overlay (widget-get widget :button-overlay))
(sample-overlay (widget-get widget :sample-overlay))
- (doc-overlay (widget-get widget :doc-overlay))
- (inhibit-modification-hooks t)
- (inhibit-read-only t))
- (widget-apply widget :value-delete)
- (widget-children-value-delete widget)
- (when inactive-overlay
- (delete-overlay inactive-overlay))
- (when button-overlay
- (delete-overlay button-overlay))
- (when sample-overlay
- (delete-overlay sample-overlay))
- (when doc-overlay
- (delete-overlay doc-overlay))
- (when (< from to)
- ;; Kludge: this doesn't need to be true for empty formats.
- (delete-region from to))
- (set-marker from nil)
- (set-marker to nil))
+ (doc-overlay (widget-get widget :doc-overlay)))
+ (widget--allow-insertion
+ (widget-apply widget :value-delete)
+ (widget-children-value-delete widget)
+ (when inactive-overlay
+ (delete-overlay inactive-overlay))
+ (when button-overlay
+ (delete-overlay button-overlay))
+ (when sample-overlay
+ (delete-overlay sample-overlay))
+ (when doc-overlay
+ (delete-overlay doc-overlay))
+ (when (< from to)
+ ;; Kludge: this doesn't need to be true for empty formats.
+ (delete-region from to))
+ (set-marker from nil)
+ (set-marker to nil)))
(widget-clear-undo))
(defun widget-default-value-set (widget value)
@@ -1781,9 +1807,9 @@ The value of the :type attribute should be an unconverted widget type."
(widget-put widget :value value)
(widget-apply widget :create))
(if offset
- (if (< offset 0)
- (goto-char (+ (widget-get widget :to) offset 1))
- (goto-char (min (+ from offset) (1- (widget-get widget :to))))))))
+ (goto-char (if (< offset 0)
+ (+ (widget-get widget :to) offset 1)
+ (min (+ from offset) (1- (widget-get widget :to))))))))
(defun widget-default-value-inline (widget)
"Wrap value in a list unless it is inline."
@@ -1946,8 +1972,8 @@ as the argument to `documentation-property'."
;; Only bind mouse-2, since mouse-1 will be translated accordingly to
;; the customization of `mouse-1-click-follows-link'.
(define-key map [down-mouse-1] (lookup-key widget-global-map [down-mouse-1]))
- (define-key map [down-mouse-2] 'widget-button-click)
- (define-key map [mouse-2] 'widget-button-click)
+ (define-key map [down-mouse-2] #'widget-button-click)
+ (define-key map [mouse-2] #'widget-button-click)
map)
"Keymap used inside a link widget.")
@@ -2119,7 +2145,8 @@ the earlier input."
;; `widget-setup' is called.
(overlay (cons (make-marker) (make-marker))))
(widget-put widget :field-overlay overlay)
- (insert value)
+ (when value
+ (insert value))
(and size
(< (length value) size)
(insert-char ?\s (- size (length value))))
@@ -2294,13 +2321,10 @@ when he invoked the menu."
((and widget-choice-toggle
(= (length args) 2)
(memq old args))
- (if (eq old (nth 0 args))
- (nth 1 args)
- (nth 0 args)))
+ (nth (if (eq old (nth 0 args)) 1 0)
+ args))
(t
- (while args
- (setq current (car args)
- args (cdr args))
+ (dolist (current args)
(setq choices
(cons (cons (widget-apply current :menu-tag-get)
current)
@@ -2393,9 +2417,8 @@ when he invoked the menu."
(widget-toggle-action widget event)
(let ((sibling (widget-get-sibling widget)))
(when sibling
- (if (widget-value widget)
- (widget-apply sibling :activate)
- (widget-apply sibling :deactivate))
+ (widget-apply sibling
+ (if (widget-value widget) :activate :deactivate))
(widget-clear-undo))))
;;; The `checklist' Widget.
@@ -2444,7 +2467,7 @@ If the item is checked, CHOSEN is a cons whose cdr is the value."
(cond ((eq escape ?%)
(insert ?%))
((eq escape ?b)
- (setq button (apply 'widget-create-child-and-convert
+ (setq button (apply #'widget-create-child-and-convert
widget 'checkbox
:value (not (null chosen))
button-args)))
@@ -2524,11 +2547,8 @@ Return an alist of (TYPE MATCH)."
(defun widget-checklist-value-get (widget)
;; The values of all selected items.
- (let ((children (widget-get widget :children))
- child result)
- (while children
- (setq child (car children)
- children (cdr children))
+ (let (result)
+ (dolist (child (widget-get widget :children))
(if (widget-value (widget-get child :button))
(setq result (append result (widget-apply child :value-inline)))))
result))
@@ -2596,12 +2616,8 @@ Return an alist of (TYPE MATCH)."
(defun widget-radio-value-create (widget)
;; Insert all values
- (let ((args (widget-get widget :args))
- arg)
- (while args
- (setq arg (car args)
- args (cdr args))
- (widget-radio-add-item widget arg))))
+ (dolist (arg (widget-get widget :args))
+ (widget-radio-add-item widget arg)))
(defun widget-radio-add-item (widget type)
"Add to radio widget WIDGET a new radio button item of type TYPE."
@@ -2628,7 +2644,7 @@ Return an alist of (TYPE MATCH)."
(cond ((eq escape ?%)
(insert ?%))
((eq escape ?b)
- (setq button (apply 'widget-create-child-and-convert
+ (setq button (apply #'widget-create-child-and-convert
widget 'radio-button
:value (not (null chosen))
button-args)))
@@ -2684,11 +2700,8 @@ Return an alist of (TYPE MATCH)."
;; We can't just delete and recreate a radio widget, since children
;; can be added after the original creation and won't be recreated
;; by `:create'.
- (let ((children (widget-get widget :children))
- current found)
- (while children
- (setq current (car children)
- children (cdr children))
+ (let (found)
+ (dolist (current (widget-get widget :children))
(let* ((button (widget-get current :button))
(match (and (not found)
(widget-apply current :match value))))
@@ -2715,13 +2728,9 @@ Return an alist of (TYPE MATCH)."
(defun widget-radio-action (widget child event)
;; Check if a radio button was pressed.
- (let ((children (widget-get widget :children))
- (buttons (widget-get widget :buttons))
- current)
+ (let ((buttons (widget-get widget :buttons)))
(when (memq child buttons)
- (while children
- (setq current (car children)
- children (cdr children))
+ (dolist (current (widget-get widget :children))
(let* ((button (widget-get current :button)))
(cond ((eq child button)
(widget-value-set button t)
@@ -2791,7 +2800,7 @@ Return an alist of (TYPE MATCH)."
(and (widget--should-indent-p)
(widget-get widget :indent)
(insert-char ?\s (widget-get widget :indent)))
- (apply 'widget-create-child-and-convert
+ (apply #'widget-create-child-and-convert
widget 'insert-button
(widget-get widget :append-button-args)))
(t
@@ -2811,9 +2820,9 @@ Return an alist of (TYPE MATCH)."
(if answer
(setq children (cons (widget-editable-list-entry-create
widget
- (if (widget-inline-p type t)
- (car answer)
- (car (car answer)))
+ (car (if (widget-inline-p type t)
+ answer
+ (car answer)))
t)
children)
value (cdr answer))
@@ -2822,8 +2831,8 @@ Return an alist of (TYPE MATCH)."
(defun widget-editable-list-value-get (widget)
;; Get value of the child widget.
- (apply 'append (mapcar (lambda (child) (widget-apply child :value-inline))
- (widget-get widget :children))))
+ (apply #'append (mapcar (lambda (child) (widget-apply child :value-inline))
+ (widget-get widget :children))))
(defun widget-editable-list-match (widget value)
;; Value must be a list and all the members must match the type.
@@ -2854,27 +2863,26 @@ The new widget gets inserted at the position of the BEFORE child."
(last-deleted (when-let ((lst (widget-get widget :last-deleted)))
(prog1
(pop lst)
- (widget-put widget :last-deleted lst))))
- (inhibit-read-only t)
- (inhibit-modification-hooks t))
- (cond (before
- (goto-char (widget-get before :entry-from)))
- (t
- (goto-char (widget-get widget :value-pos))))
- (let ((child (widget-editable-list-entry-create
- widget (and last-deleted
- (widget-apply last-deleted
- :value-to-external
- (widget-get last-deleted :value)))
- last-deleted)))
- (when (< (widget-get child :entry-from) (widget-get widget :from))
- (set-marker (widget-get widget :from)
- (widget-get child :entry-from)))
- (if (eq (car children) before)
- (widget-put widget :children (cons child children))
- (while (not (eq (car (cdr children)) before))
- (setq children (cdr children)))
- (setcdr children (cons child (cdr children)))))))
+ (widget-put widget :last-deleted lst)))))
+ (widget--allow-insertion
+ (cond (before
+ (goto-char (widget-get before :entry-from)))
+ (t
+ (goto-char (widget-get widget :value-pos))))
+ (let ((child (widget-editable-list-entry-create
+ widget (and last-deleted
+ (widget-apply last-deleted
+ :value-to-external
+ (widget-get last-deleted :value)))
+ last-deleted)))
+ (when (< (widget-get child :entry-from) (widget-get widget :from))
+ (set-marker (widget-get widget :from)
+ (widget-get child :entry-from)))
+ (if (eq (car children) before)
+ (widget-put widget :children (cons child children))
+ (while (not (eq (car (cdr children)) before))
+ (setq children (cdr children)))
+ (setcdr children (cons child (cdr children))))))))
(widget-setup)
(widget-apply widget :notify widget))
@@ -2890,25 +2898,19 @@ Save CHILD into the :last-deleted list, so it can be inserted later."
(widget-put widget :last-deleted lst))
;; Delete child from list of children.
(save-excursion
- (let ((buttons (copy-sequence (widget-get widget :buttons)))
- button
- (inhibit-read-only t)
- (inhibit-modification-hooks t))
- (while buttons
- (setq button (car buttons)
- buttons (cdr buttons))
- (when (eq (widget-get button :widget) child)
- (widget-put widget
- :buttons (delq button (widget-get widget :buttons)))
- (widget-delete button))))
+ (widget--allow-insertion
+ (dolist (button (copy-sequence (widget-get widget :buttons)))
+ (when (eq (widget-get button :widget) child)
+ (widget-put widget
+ :buttons (delq button (widget-get widget :buttons)))
+ (widget-delete button))))
(let ((entry-from (widget-get child :entry-from))
- (entry-to (widget-get child :entry-to))
- (inhibit-read-only t)
- (inhibit-modification-hooks t))
- (widget-delete child)
- (delete-region entry-from entry-to)
- (set-marker entry-from nil)
- (set-marker entry-to nil))
+ (entry-to (widget-get child :entry-to)))
+ (widget--allow-insertion
+ (widget-delete child)
+ (delete-region entry-from entry-to)
+ (set-marker entry-from nil)
+ (set-marker entry-to nil)))
(widget-put widget :children (delq child (widget-get widget :children))))
(widget-setup)
(widget-apply widget :notify widget))
@@ -2931,19 +2933,17 @@ Save CHILD into the :last-deleted list, so it can be inserted later."
(cond ((eq escape ?%)
(insert ?%))
((eq escape ?i)
- (setq insert (apply 'widget-create-child-and-convert
+ (setq insert (apply #'widget-create-child-and-convert
widget 'insert-button
(widget-get widget :insert-button-args))))
((eq escape ?d)
- (setq delete (apply 'widget-create-child-and-convert
+ (setq delete (apply #'widget-create-child-and-convert
widget 'delete-button
(widget-get widget :delete-button-args))))
((eq escape ?v)
- (if conv
- (setq child (widget-create-child-value
- widget type value))
- (setq child (widget-create-child-value
- widget type (widget-default-get type)))))
+ (setq child (widget-create-child-value
+ widget type
+ (if conv value (widget-default-get type)))))
(t
(error "Unknown escape `%c'" escape)))))
(let ((buttons (widget-get widget :buttons)))
@@ -2983,13 +2983,10 @@ Save CHILD into the :last-deleted list, so it can be inserted later."
(defun widget-group-value-create (widget)
;; Create each component.
- (let ((args (widget-get widget :args))
- (value (widget-get widget :value))
- arg answer children)
- (while args
- (setq arg (car args)
- args (cdr args)
- answer (widget-match-inline arg value)
+ (let ((value (widget-get widget :value))
+ answer children)
+ (dolist (arg (widget-get widget :args))
+ (setq answer (widget-match-inline arg value)
value (cdr answer))
(and (widget--should-indent-p)
(widget-get widget :indent)
@@ -3005,7 +3002,7 @@ Save CHILD into the :last-deleted list, so it can be inserted later."
(defun widget-group-default-get (widget)
;; Get the default of the components.
- (mapcar 'widget-default-get (widget-get widget :args)))
+ (mapcar #'widget-default-get (widget-get widget :args)))
(defun widget-group-match (widget vals)
;; Match if the components match.
@@ -3063,20 +3060,20 @@ The following properties have special meanings for this widget:
"Display documentation for WIDGET's value. Ignore optional argument EVENT."
(let* ((string (widget-get widget :value))
(symbol (intern string)))
- (if (and (fboundp symbol) (boundp symbol))
- ;; If there are two doc strings, give the user a way to pick one.
- (apropos (concat "\\`" (regexp-quote string) "\\'"))
- (cond
- ((fboundp symbol)
- (describe-function symbol))
- ((facep symbol)
- (describe-face symbol))
- ((featurep symbol)
- (describe-package symbol))
- ((or (boundp symbol) (get symbol 'variable-documentation))
- (describe-variable symbol))
- (t
- (message "No documentation available for %s" symbol))))))
+ (cond
+ ((and (fboundp symbol) (boundp symbol))
+ ;; If there are two doc strings, give the user a way to pick one.
+ (apropos (concat "\\`" (regexp-quote string) "\\'")))
+ ((fboundp symbol)
+ (describe-function symbol))
+ ((facep symbol)
+ (describe-face symbol))
+ ((featurep symbol)
+ (describe-package symbol))
+ ((or (boundp symbol) (get symbol 'variable-documentation))
+ (describe-variable symbol))
+ (t
+ (message "No documentation available for %s" symbol)))))
(defcustom widget-documentation-links t
"Add hyperlinks to documentation strings when non-nil."
@@ -3209,7 +3206,7 @@ Optional ARGS specifies additional keyword arguments for the
(unless (or (numberp doc-indent) (null doc-indent))
(setq doc-indent 0))
(widget-put widget :buttons
- (cons (apply 'widget-create-child-and-convert
+ (cons (apply #'widget-create-child-and-convert
widget 'documentation-string
:indent doc-indent
(nconc args (list doc)))
@@ -3321,18 +3318,18 @@ It reads a file name from an editable text field."
(must-match (widget-get widget :must-match)))
(read-file-name (format-prompt prompt value) dir nil must-match file)))))
-;;;(defun widget-file-action (widget &optional event)
-;;; ;; Read a file name from the minibuffer.
-;;; (let* ((value (widget-value widget))
-;;; (dir (file-name-directory value))
-;;; (file (file-name-nondirectory value))
-;;; (menu-tag (widget-apply widget :menu-tag-get))
-;;; (must-match (widget-get widget :must-match))
-;;; (answer (read-file-name (format-prompt menu-tag value)
-;;; dir nil must-match file)))
-;;; (widget-value-set widget (abbreviate-file-name answer))
-;;; (widget-setup)
-;;; (widget-apply widget :notify widget event)))
+;;(defun widget-file-action (widget &optional event)
+;; ;; Read a file name from the minibuffer.
+;; (let* ((value (widget-value widget))
+;; (dir (file-name-directory value))
+;; (file (file-name-nondirectory value))
+;; (menu-tag (widget-apply widget :menu-tag-get))
+;; (must-match (widget-get widget :must-match))
+;; (answer (read-file-name (format-prompt menu-tag value)
+;; dir nil must-match file)))
+;; (widget-value-set widget (abbreviate-file-name answer))
+;; (widget-setup)
+;; (widget-apply widget :notify widget event)))
;; Fixme: use file-name-as-directory.
(define-widget 'directory 'file
@@ -3521,7 +3518,7 @@ It reads a directory name from an editable text field."
(if (stringp value)
(if (string-match "\\`[[:space:]]*\\'" value)
widget-key-sequence-default-value
- (read-kbd-macro value))
+ (key-parse value))
value))
@@ -3647,8 +3644,12 @@ match-alternatives: %S"
value
(widget-get widget :match)
(widget-get widget :match-alternatives))
- :warning))
- (read value)))
+ :warning)
+ ;; Make sure we will `read' a string.
+ (setq value (prin1-to-string value)))
+ (if (string-empty-p value)
+ value
+ (read value))))
(defun widget-restricted-sexp-match (widget value)
(let ((alternatives (widget-get widget :match-alternatives))
@@ -3771,15 +3772,26 @@ like the newline character or the tab character."
(define-widget 'list 'group
"A Lisp list."
:tag "List"
+ :default-get #'widget-list-default-get
:format "%{%t%}:\n%v")
+(defun widget-list-default-get (widget)
+ "Return the default external value for a list WIDGET.
+
+The default value is the one stored in the :value property, even if it is nil,
+or a list with the default value of each component of the list WIDGET."
+ (widget-apply widget :value-to-external
+ (if (widget-member widget :value)
+ (widget-get widget :value)
+ (widget-group-default-get widget))))
+
(define-widget 'vector 'group
"A Lisp vector."
:tag "Vector"
:format "%{%t%}:\n%v"
:match 'widget-vector-match
:value-to-internal (lambda (_widget value) (append value nil))
- :value-to-external (lambda (_widget value) (apply 'vector value)))
+ :value-to-external (lambda (_widget value) (apply #'vector value)))
(defun widget-vector-match (widget value)
(and (vectorp value)
@@ -3794,7 +3806,7 @@ like the newline character or the tab character."
:value-to-internal (lambda (_widget value)
(list (car value) (cdr value)))
:value-to-external (lambda (_widget value)
- (apply 'cons value)))
+ (apply #'cons value)))
(defun widget-cons-match (widget value)
(and (consp value)
@@ -3881,7 +3893,7 @@ example:
(args (if options
(list `(checklist :inline t
:greedy t
- ,@(mapcar 'widget-plist-convert-option
+ ,@(mapcar #'widget-plist-convert-option
options))
other)
(list other))))
@@ -3894,14 +3906,11 @@ example:
(if (listp option)
(let ((key (nth 0 option)))
(setq value-type (nth 1 option))
- (if (listp key)
- (setq key-type key)
- (setq key-type `(const ,key))))
+ (setq key-type (if (listp key) key `(const ,key))))
(setq key-type `(const ,option)
value-type widget-plist-value-type))
`(group :format "Key: %v" :inline t ,key-type ,value-type)))
-
;;; The `alist' Widget.
;;
;; Association lists.
@@ -3911,6 +3920,7 @@ example:
:key-type '(sexp :tag "Key")
:value-type '(sexp :tag "Value")
:convert-widget 'widget-alist-convert-widget
+ :default-get #'widget-alist-default-get
:tag "Alist")
(defvar widget-alist-value-type) ;Dynamic variable
@@ -3926,7 +3936,7 @@ example:
(args (if options
(list `(checklist :inline t
:greedy t
- ,@(mapcar 'widget-alist-convert-option
+ ,@(mapcar #'widget-alist-convert-option
options))
other)
(list other))))
@@ -3939,12 +3949,29 @@ example:
(if (listp option)
(let ((key (nth 0 option)))
(setq value-type (nth 1 option))
- (if (listp key)
- (setq key-type key)
- (setq key-type `(const ,key))))
+ (setq key-type (if (listp key) key `(const ,key))))
(setq key-type `(const ,option)
value-type widget-alist-value-type))
`(cons :format "Key: %v" ,key-type ,value-type)))
+
+(defun widget-alist-default-get (widget)
+ "Return the default value for WIDGET, an alist widget.
+
+The default value may be one of:
+- The one stored in the :value property, even if it is nil.
+- If WIDGET has options available, an alist consisting of the
+default values for each option.
+- nil, otherwise."
+ (widget-apply widget :value-to-external
+ (cond ((widget-member widget :value)
+ (widget-get widget :value))
+ ((widget-get widget :options)
+ (mapcar #'widget-default-get
+ ;; Last one is the editable-list part, and
+ ;; we don't want those showing up as
+ ;; part of the default value. (Bug#63290)
+ (butlast (widget-get widget :args))))
+ (t nil))))
(define-widget 'choice 'menu-choice
"A union of several sexp types.
@@ -3977,19 +4004,16 @@ current choice is inline."
nil)
((= (length args) 1)
(nth 0 args))
- ((and (= (length args) 2)
+ ((and widget-choice-toggle
+ (= (length args) 2)
(memq old args))
- (if (eq old (nth 0 args))
- (nth 1 args)
- (nth 0 args)))
+ (nth (if (eq old (nth 0 args)) 1 0)
+ args))
(t
- (while args
- (setq current (car args)
- args (cdr args))
- (setq choices
- (cons (cons (widget-apply current :menu-tag-get)
- current)
- choices)))
+ (dolist (current args)
+ (push (cons (widget-apply current :menu-tag-get)
+ current)
+ choices))
(let ((val (completing-read prompt choices nil t)))
(if (stringp val)
(let ((try (try-completion val choices)))
@@ -4038,6 +4062,7 @@ is inline."
:button-prefix 'widget-push-button-prefix
:button-suffix 'widget-push-button-suffix
:format "%{%t%}: %[Toggle%] %v\n"
+ :match (lambda (_widget value) (booleanp value))
:on "on (non-nil)"
:off "off (nil)")
@@ -4139,7 +4164,7 @@ is inline."
(help-echo (and widget (widget-get widget :help-echo))))
(if (functionp help-echo)
(setq help-echo (funcall help-echo widget)))
- (if help-echo (message "%s" (eval help-echo)))))
+ (if help-echo (message "%s" (eval help-echo t)))))
(define-obsolete-function-alias 'widget-sublist #'seq-subseq "28.1")
(define-obsolete-function-alias 'widget-visibility-value-create
diff --git a/lisp/windmove.el b/lisp/windmove.el
index 12ecb936033..b4e77102abd 100644
--- a/lisp/windmove.el
+++ b/lisp/windmove.el
@@ -485,7 +485,7 @@ Default value of MODIFIERS is `shift'."
(interactive)
(unless modifiers (setq modifiers 'shift))
(when (eq modifiers 'none) (setq modifiers nil))
- (unless (listp modifiers) (setq modifiers (list modifiers)))
+ (setq modifiers (ensure-list modifiers))
(windmove-install-defaults nil modifiers
'((windmove-left left)
(windmove-right right)
@@ -626,7 +626,7 @@ Default value of MODIFIERS is `shift-meta'."
(interactive)
(unless modifiers (setq modifiers '(shift meta)))
(when (eq modifiers 'none) (setq modifiers nil))
- (unless (listp modifiers) (setq modifiers (list modifiers)))
+ (setq modifiers (ensure-list modifiers))
(windmove-install-defaults nil modifiers
'((windmove-display-left left)
(windmove-display-right right)
@@ -641,7 +641,7 @@ Default value of MODIFIERS is `shift-meta'."
(defun windmove-delete-in-direction (dir &optional arg)
"Delete the window at direction DIR.
-If prefix ARG is `\\[universal-argument]', also kill the buffer in that window.
+If prefix ARG is \\[universal-argument], also kill the buffer in that window.
With \\`M-0' prefix, delete the selected window and
select the window at direction DIR.
When `windmove-wrap-around' is non-nil, takes the window
@@ -703,10 +703,10 @@ Default value of PREFIX is \\`C-x' and MODIFIERS is `shift'."
(interactive)
(unless prefix (setq prefix '(?\C-x)))
(when (eq prefix 'none) (setq prefix nil))
- (unless (listp prefix) (setq prefix (list prefix)))
+ (setq prefix (ensure-list prefix))
(unless modifiers (setq modifiers '(shift)))
(when (eq modifiers 'none) (setq modifiers nil))
- (unless (listp modifiers) (setq modifiers (list modifiers)))
+ (setq modifiers (ensure-list modifiers))
(windmove-install-defaults prefix modifiers
'((windmove-delete-left left)
(windmove-delete-right right)
@@ -724,6 +724,8 @@ from the opposite side of the frame."
nil windmove-wrap-around 'nomini)))
(cond ((or (null other-window) (window-minibuffer-p other-window))
(user-error "No window %s from selected window" dir))
+ ((window-minibuffer-p (selected-window))
+ (user-error "Can't swap window with the minibuffer"))
(t
(window-swap-states nil other-window)))))
@@ -764,7 +766,7 @@ Default value of MODIFIERS is `shift-super'."
(interactive)
(unless modifiers (setq modifiers '(shift super)))
(when (eq modifiers 'none) (setq modifiers nil))
- (unless (listp modifiers) (setq modifiers (list modifiers)))
+ (setq modifiers (ensure-list modifiers))
(windmove-install-defaults nil modifiers
'((windmove-swap-states-left left)
(windmove-swap-states-right right)
diff --git a/lisp/window.el b/lisp/window.el
index 13fe1feba10..df55a7ca673 100644
--- a/lisp/window.el
+++ b/lisp/window.el
@@ -2121,12 +2121,16 @@ remapped (see `face-remapping-alist'), the function returns the
information for the remapped face."
(with-selected-window (window-normalize-window window t)
(if (display-multi-font-p)
- (let* ((face (if face face 'default))
- (info (font-info (face-font face)))
- (width (aref info 11)))
- (if (> width 0)
- width
- (aref info 10)))
+ ;; Opening the XLFD returned by `font-info' may be
+ ;; unsuccessful. Use `frame-char-width' as a recourse if
+ ;; such a situation transpires.
+ (or (when-let* ((face (if face face 'default))
+ (info (font-info (face-font face)))
+ (width (aref info 11)))
+ (if (> width 0)
+ width
+ (aref info 10)))
+ (frame-char-width))
(frame-char-width))))
(defun window-font-height (&optional window face)
@@ -2138,9 +2142,10 @@ remapped (see `face-remapping-alist'), the function returns the
information for the remapped face."
(with-selected-window (window-normalize-window window t)
(if (display-multi-font-p)
- (let* ((face (if face face 'default))
- (info (font-info (face-font face))))
- (aref info 3))
+ (or (when-let* ((face (if face face 'default))
+ (info (font-info (face-font face))))
+ (aref info 3))
+ (frame-char-height))
(frame-char-height))))
(defvar overflow-newline-into-fringe)
@@ -2510,6 +2515,7 @@ have special meanings:
Any other value of ALL-FRAMES means consider all windows on the
selected frame and no others."
+ (declare (side-effect-free error-free))
(let ((windows (window-list-1 nil 'nomini all-frames))
best-window best-time second-best-window second-best-time time)
(dolist (window windows)
@@ -2588,6 +2594,7 @@ have special meanings:
Any other value of ALL-FRAMES means consider all windows on the
selected frame and no others."
+ (declare (side-effect-free error-free))
(let ((best-size 0)
best-window size)
(dolist (window (window-list-1 nil 'nomini all-frames))
@@ -3786,6 +3793,7 @@ frame, rounded if necessary. PIXELWISE non-nil means to return
the coordinates in pixels where the values for RIGHT and BOTTOM
are one more than the actual value of these edges. Note that if
ABSOLUTE is non-nil, PIXELWISE is implicitly non-nil too."
+ (declare (side-effect-free t))
(let* ((window (window-normalize-window window body))
(frame (window-frame window))
(border-width (frame-internal-border-width frame))
@@ -3841,6 +3849,7 @@ ABSOLUTE is non-nil, PIXELWISE is implicitly non-nil too."
"Return a list of the edge coordinates of WINDOW's body.
The return value is that of `window-edges' called with argument
BODY non-nil."
+ (declare (side-effect-free t))
(window-edges window t))
(defalias 'window-inside-edges 'window-body-edges)
@@ -3848,12 +3857,14 @@ BODY non-nil."
"Return a list of the edge pixel coordinates of WINDOW.
The return value is that of `window-edges' called with argument
PIXELWISE non-nil."
+ (declare (side-effect-free t))
(window-edges window nil nil t))
(defun window-body-pixel-edges (&optional window)
"Return a list of the edge pixel coordinates of WINDOW's body.
The return value is that of `window-edges' called with arguments
BODY and PIXELWISE non-nil."
+ (declare (side-effect-free t))
(window-edges window t nil t))
(defalias 'window-inside-pixel-edges 'window-body-pixel-edges)
@@ -3861,12 +3872,14 @@ BODY and PIXELWISE non-nil."
"Return a list of the edge pixel coordinates of WINDOW.
The return value is that of `window-edges' called with argument
ABSOLUTE non-nil."
+ (declare (side-effect-free t))
(window-edges window nil t t))
(defun window-absolute-body-pixel-edges (&optional window)
"Return a list of the edge pixel coordinates of WINDOW's text area.
The return value is that of `window-edges' called with arguments
BODY and ABSOLUTE non-nil."
+ (declare (side-effect-free t))
(window-edges window t t t))
(defalias 'window-inside-absolute-pixel-edges 'window-absolute-body-pixel-edges)
@@ -4076,6 +4089,7 @@ with a special meaning are:
Anything else means consider all windows on the selected frame
and no others."
+ (declare (side-effect-free error-free))
(let ((base-window (selected-window)))
(if (and nomini (eq base-window (minibuffer-window)))
(setq base-window (next-window base-window)))
@@ -4163,8 +4177,8 @@ a non-nil `no-other-window' parameter."
"How to choose a frame's selected window after window deletion.
When a frame's selected window gets deleted, Emacs has to choose
another live window on that frame to serve as its selected
-window. This option allows to control which window gets selected
-instead.
+window. This option controls the window that is selected in such
+a situation.
The possible choices are `mru' (the default) to select the most
recently used window on that frame, and `pos' to choose the
@@ -6160,6 +6174,12 @@ value can be also stored on disk and read back in a new session."
(defvar window-state-put-stale-windows nil
"Helper variable for `window-state-put'.")
+(defvar window-state-put-kept-windows nil
+ "Helper variable for `window-state-put'.")
+
+(defvar window-state-put-selected-window nil
+ "Helper variable for `window-state-put'.")
+
(defun window--state-put-1 (state &optional window ignore totals pixelwise)
"Helper function for `window-state-put'."
(let ((type (car state)))
@@ -6173,7 +6193,14 @@ value can be also stored on disk and read back in a new session."
(let* ((horizontal (eq type 'hc))
(total (window-size window horizontal pixelwise))
(first t)
- (window-combination-limit (cdr (assq 'combination-limit state)))
+ ;; Make sure to make a new parent window for a horizontal
+ ;; or vertical combination embedded in one of the same type
+ ;; (see Bug#50867 and Bug#64405).
+ (window-combination-limit
+ (and (or (eq (cdr (assq 'combination-limit state)) t)
+ (and horizontal (window-combined-p window t))
+ (and (not horizontal) (window-combined-p window)))
+ t))
size new)
(dolist (item state)
;; Find the next child window. WINDOW always points to the
@@ -6257,9 +6284,11 @@ value can be also stored on disk and read back in a new session."
(set-window-parameter window (car parameter) (cdr parameter))))
;; Process buffer related state.
(when state
- (let ((buffer (get-buffer (car state)))
- (state (cdr state)))
- (if buffer
+ (let* ((old-buffer-or-name (car state))
+ (buffer (get-buffer old-buffer-or-name))
+ (state (cdr state))
+ (dedicated (cdr (assq 'dedicated state))))
+ (if (buffer-live-p buffer)
(with-current-buffer buffer
(set-window-buffer window buffer)
(set-window-hscroll window (cdr (assq 'hscroll state)))
@@ -6317,7 +6346,7 @@ value can be also stored on disk and read back in a new session."
window delta t ignore nil nil nil pixelwise))
(window-resize window delta t ignore pixelwise))))
;; Set dedicated status.
- (set-window-dedicated-p window (cdr (assq 'dedicated state)))
+ (set-window-dedicated-p window dedicated)
;; Install positions (maybe we should do this after all
;; windows have been created and sized).
(ignore-errors
@@ -6327,7 +6356,18 @@ value can be also stored on disk and read back in a new session."
(set-window-point window (cdr (assq 'point state))))
;; Select window if it's the selected one.
(when (cdr (assq 'selected state))
- (select-window window))
+ ;; This used to call 'select-window' which, however,
+ ;; can be partially undone because the current buffer
+ ;; may subsequently change twice: When leaving the
+ ;; present 'with-current-buffer' and when leaving the
+ ;; containing 'with-temp-buffer' form (Bug#69093).
+ ;; 'window-state-put-selected-window' should now work
+ ;; around that bug but we leave this 'select-window'
+ ;; in since some code run before the part that fixed
+ ;; it might still refer to this window as the selected
+ ;; one.
+ (select-window window)
+ (setq window-state-put-selected-window window))
(set-window-next-buffers
window
(delq nil (mapcar (lambda (buffer)
@@ -6349,12 +6389,31 @@ value can be also stored on disk and read back in a new session."
(set-marker (make-marker) m2
buffer))))))
prev-buffers))))
- ;; We don't want to raise an error in case the buffer does
- ;; not exist anymore, so we switch to a previous one and
- ;; save the window with the intention of deleting it later
- ;; if possible.
- (switch-to-prev-buffer window)
- (push window window-state-put-stale-windows)))))))
+ (unless (window-minibuffer-p window)
+ ;; Preferably show a buffer previously shown in this
+ ;; window.
+ (switch-to-prev-buffer window)
+ (cond
+ ((functionp window-restore-killed-buffer-windows)
+ (let* ((start (cdr (assq 'start state)))
+ ;; Handle both - marker positions from writable
+ ;; states and markers from non-writable states.
+ (start-pos (if (markerp start)
+ (marker-last-position start)
+ start))
+ (point (cdr (assq 'point state)))
+ (point-pos (if (markerp point)
+ (marker-last-position point)
+ point)))
+ (push (list window old-buffer-or-name
+ start-pos point-pos dedicated nil)
+ window-state-put-kept-windows)))
+ ((or (and dedicated
+ (eq window-restore-killed-buffer-windows 'dedicated))
+ (memq window-restore-killed-buffer-windows '(nil delete)))
+ ;; Try to delete the window.
+ (push window window-state-put-stale-windows)))
+ (set-window-dedicated-p window nil))))))))
(defun window-state-put (state &optional window ignore)
"Put window state STATE into WINDOW.
@@ -6367,8 +6426,13 @@ If WINDOW is nil, create a new window before putting STATE into it.
Optional argument IGNORE non-nil means ignore minimum window
sizes and fixed size restrictions. IGNORE equal `safe' means
windows can get as small as `window-safe-min-height' and
-`window-safe-min-width'."
+`window-safe-min-width'.
+
+If this function tries to restore a non-minibuffer window whose buffer
+was killed since STATE was made, it will consult the variable
+`window-restore-killed-buffer-windows' on how to proceed."
(setq window-state-put-stale-windows nil)
+ (setq window-state-put-kept-windows nil)
;; When WINDOW is internal or nil, reduce it to a live one,
;; then create a new window on the same frame to put STATE into.
@@ -6413,7 +6477,10 @@ windows can get as small as `window-safe-min-height' and
head)))
(min-width (cdr (assq
(if pixelwise 'min-pixel-width 'min-weight)
- head))))
+ head)))
+ ;; Bind the following two variables. `window--state-put-1' has
+ ;; to fully control them (see Bug#50867 and Bug#64405).
+ window-combination-limit window-combination-resize)
(if (and (not totals)
(or (> min-height (window-size window nil pixelwise))
(> min-width (window-size window t pixelwise)))
@@ -6458,6 +6525,7 @@ windows can get as small as `window-safe-min-height' and
(error "Window %s too small to accommodate state" window)
(setq state (cdr state))
(setq window-state-put-list nil)
+ (setq window-state-put-selected-window nil)
;; Work on the windows of a temporary buffer to make sure that
;; splitting proceeds regardless of any buffer local values of
;; `window-size-fixed'. Release that buffer after the buffers of
@@ -6466,14 +6534,20 @@ windows can get as small as `window-safe-min-height' and
(set-window-buffer window (current-buffer))
(window--state-put-1 state window nil totals pixelwise)
(window--state-put-2 ignore pixelwise))
+ (when (window-live-p window-state-put-selected-window)
+ (select-window window-state-put-selected-window))
(while window-state-put-stale-windows
(let ((window (pop window-state-put-stale-windows)))
- ;; Avoid that 'window-deletable-p' throws an error if window
+ ;; Avoid that 'window-deletable-p' throws an error if window
;; was already deleted when exiting 'with-temp-buffer' above
;; (Bug#54028).
(when (and (window-valid-p window)
(eq (window-deletable-p window) t))
(delete-window window))))
+ (when (functionp window-restore-killed-buffer-windows)
+ (funcall window-restore-killed-buffer-windows
+ frame window-state-put-kept-windows 'state)
+ (setq window-state-put-kept-windows nil))
(window--check frame))))
(defun window-state-buffers (state)
@@ -6840,6 +6914,7 @@ BUFFER in a window of the selected frame.
If ARGS is a list whose car is a symbol, use (car ARGS) as a
function to do the work. Pass it BUFFER as first argument, and
pass the elements of (cdr ARGS) as the remaining arguments."
+ (declare (obsolete display-buffer-pop-up-frame "30.1"))
(if (and args (symbolp (car args)))
(apply (car args) buffer (cdr args))
(let ((window (get-buffer-window buffer 0)))
@@ -6859,9 +6934,8 @@ pass the elements of (cdr ARGS) as the remaining arguments."
;; Stay on the same frame if requested.
(when (or (cdr (assq 'same-frame args)) (cdr (assq 'same-window args)))
(let* ((pop-up-windows t)
- pop-up-frames
special-display-buffer-names special-display-regexps)
- (display-buffer buffer)))
+ (display-buffer buffer '((pop-up-frames . nil)))))
;; If no window yet, make one in a new frame.
(let* ((frame
(with-current-buffer buffer
@@ -6974,6 +7048,13 @@ Emacs Lisp manual for an example."
(const :tag "Always" t))
:group 'windows)
+(defun window--pop-up-frames (alist)
+ (let* ((override (assq 'pop-up-frames alist))
+ (pop-up (if override (cdr override) pop-up-frames)))
+ (if (eq pop-up 'graphic-only)
+ (display-graphic-p)
+ pop-up)))
+
(defcustom display-buffer-reuse-frames nil
"Non-nil means `display-buffer' should reuse frames.
If the buffer in question is already displayed in a frame, raise
@@ -7448,6 +7529,64 @@ Return WINDOW if BUFFER and WINDOW are live."
The actual non-nil value of this variable will be copied to the
`window-dedicated-p' flag.")
+(defcustom toggle-window-dedicated-flag 'interactive
+ "What dedicated flag should `toggle-window-dedicated' use by default.
+
+If `toggle-window-dedicated' does not receive a flag argument,
+the value of this variable is used and passed to
+`set-window-dedicated-p'. Setting this to t will make
+`toggle-window-dedicated' use strong dedication by default. Any
+other non-nil value will result in the same kind of non-strong
+dedication."
+ :type '(choice (const :tag "Strongly dedicated" t)
+ (const :tag "Dedicated" interactive))
+ :version "30.0"
+ :group 'windows)
+
+(defun toggle-window-dedicated (&optional window flag interactive)
+ "Toggle whether WINDOW is dedicated to its current buffer.
+
+WINDOW must be a live window and defaults to the selected one.
+If FLAG is t (interactively, the prefix argument), make the window
+\"strongly\" dedicated to its buffer. FLAG defaults to a non-nil,
+non-t value, and is passed to `set-window-dedicated-p', which see.
+If INTERACTIVE is non-nil, print a message describing the dedication
+status of WINDOW, after toggling it. Interactively, this argument is
+always non-nil.
+
+When a window is dedicated to its buffer, `display-buffer' will avoid
+displaying another buffer in it, if possible. When a window is
+strongly dedicated to its buffer, changing the buffer shown in the
+window will usually signal an error.
+
+You can control the default of FLAG with
+`toggle-window-dedicated-flag'. Consequently, if you set that
+variable to t, strong dedication will be used by default and
+\\[universal-argument] will make the window weakly dedicated.
+
+See the info node `(elisp)Dedicated Windows' for more details."
+ (interactive "i\nP\np")
+ (setq window (window-normalize-window window))
+ (setq flag (cond
+ ((consp flag)
+ (if (eq toggle-window-dedicated-flag t)
+ 'interactive
+ t))
+ ((null flag) toggle-window-dedicated-flag)
+ (t flag)))
+ (if (window-dedicated-p window)
+ (set-window-dedicated-p window nil)
+ (set-window-dedicated-p window flag))
+ (when interactive
+ (message "Window is %s dedicated to buffer %s"
+ (let ((status (window-dedicated-p window)))
+ (cond
+ ((null status) "no longer")
+ ((eq status t) "now strongly")
+ (t "now")))
+ (current-buffer))
+ (force-mode-line-update)))
+
(defconst display-buffer--action-function-custom-type
'(choice :tag "Function"
(const :tag "--" ignore) ; default for insertion
@@ -7515,10 +7654,8 @@ where:
arguments: a buffer to display and an alist of the same form as
ALIST. See `display-buffer' for details.
-`display-buffer' scans this alist until it either finds a
-matching regular expression or the function specified by a
-condition returns non-nil. In any of these cases, it adds the
-associated action to the list of actions it will try."
+`display-buffer' scans this alist until the CONDITION is satisfied
+and adds the associated ACTION to the list of actions it will try."
:type `(alist :key-type
(choice :tag "Condition"
regexp
@@ -7664,6 +7801,8 @@ Action alist entries are:
Possible values are nil (the selected frame), t (any live
frame), visible (any visible frame), 0 (any visible or
iconified frame) or an existing live frame.
+ `pop-up-frames' -- Same effect as the eponymous variable.
+ Takes precedence over the variable.
`pop-up-frame-parameters' -- The value specifies an alist of
frame parameters to give a new frame, if one is created.
`window-height' -- The value specifies the desired height of the
@@ -7709,6 +7848,14 @@ Action alist entries are:
and `preserve-size' are applied. The function is supposed
to fill the window body with some contents that might depend
on dimensions of the displayed window.
+ `post-command-select-window' -- A non-nil value means that after the
+ current command is executed and the hook `post-command-hook' is called,
+ the window displayed by this function will be selected. A nil value
+ means that if functions like `pop-to-buffer' selected another window,
+ at the end of this command that window will be deselected, and the
+ window that was selected before calling this function will remain
+ selected regardless of which windows were selected afterwards within
+ this command.
The entries `window-height', `window-width', `window-size' and
`preserve-size' are applied only when the window used for
@@ -7752,18 +7899,29 @@ specified by the ACTION argument."
user-action special-action action extra-action
display-buffer-base-action
display-buffer-fallback-action))
- (functions (apply 'append
+ (functions (apply #'append
(mapcar (lambda (x)
(setq x (car x))
(if (functionp x) (list x) x))
actions)))
- (alist (apply 'append (mapcar 'cdr actions)))
+ (alist (apply #'append (mapcar #'cdr actions)))
window)
(unless (buffer-live-p buffer)
(error "Invalid buffer"))
(while (and functions (not window))
(setq window (funcall (car functions) buffer alist)
functions (cdr functions)))
+ (when-let ((select (assq 'post-command-select-window alist)))
+ (letrec ((old-selected-window (selected-window))
+ (postfun
+ (lambda ()
+ (if (cdr select)
+ (when (window-live-p window)
+ (select-window window))
+ (when (window-live-p old-selected-window)
+ (select-window old-selected-window)))
+ (remove-hook 'post-command-hook postfun))))
+ (add-hook 'post-command-hook postfun)))
(and (windowp window) window))))
(defun display-buffer-other-frame (buffer)
@@ -7900,9 +8058,7 @@ called only by `display-buffer' or a function directly or
indirectly called by the latter."
(let* ((alist-entry (assq 'reusable-frames alist))
(frames (cond (alist-entry (cdr alist-entry))
- ((if (eq pop-up-frames 'graphic-only)
- (display-graphic-p)
- pop-up-frames)
+ ((window--pop-up-frames alist)
0)
(display-buffer-reuse-frames 0)
(t (last-nonminibuffer-frame))))
@@ -7956,9 +8112,7 @@ indirectly called by the latter."
(let* ((alist-entry (assq 'reusable-frames alist))
(alist-mode-entry (assq 'mode alist))
(frames (cond (alist-entry (cdr alist-entry))
- ((if (eq pop-up-frames 'graphic-only)
- (display-graphic-p)
- pop-up-frames)
+ ((window--pop-up-frames alist)
0)
(display-buffer-reuse-frames 0)
(t (last-nonminibuffer-frame))))
@@ -7970,8 +8124,7 @@ indirectly called by the latter."
buffer-mode))
(curwin (selected-window))
(curframe (selected-frame)))
- (unless (listp allowed-modes)
- (setq allowed-modes (list allowed-modes)))
+ (setq allowed-modes (ensure-list allowed-modes))
(let (same-mode-same-frame
same-mode-other-frame
derived-mode-same-frame
@@ -7979,10 +8132,8 @@ indirectly called by the latter."
(dolist (window windows)
(let ((mode?
(with-current-buffer (window-buffer window)
- (cond ((memq major-mode allowed-modes)
- 'same)
- ((apply #'derived-mode-p allowed-modes)
- 'derived)))))
+ (cond ((memq major-mode allowed-modes) 'same)
+ ((derived-mode-p allowed-modes) 'derived)))))
(when (and mode?
(not (and inhibit-same-window-p
(eq window curwin))))
@@ -8107,9 +8258,7 @@ text-only terminal), try with `display-buffer-pop-up-frame'.
ALIST is an association list of action symbols and values. See
Info node `(elisp) Buffer Display Action Alists' for details of
such alists."
- (and (if (eq pop-up-frames 'graphic-only)
- (display-graphic-p)
- pop-up-frames)
+ (and (window--pop-up-frames alist)
(display-buffer-pop-up-frame buffer alist)))
(defun display-buffer--maybe-pop-up-window (buffer alist)
@@ -8256,8 +8405,8 @@ This function tries to reuse or split a window such that the
window produced this way is on the side of the reference window
specified by the `direction' entry.
-Four special values for `direction' entries allow to implicitly
-specify the selected frame's main window as reference window:
+Four special values for `direction' entries allow implicitly
+specifying the selected frame's main window as reference window:
`leftmost', `top', `rightmost' and `bottom'. Hence, instead of
`(direction . left) (window . main)' one can simply write
`(direction . leftmost)'.
@@ -8473,9 +8622,7 @@ indirectly called by the latter."
(cdr (assq 'inhibit-same-window alist)))
(frames (cond
(alist-entry (cdr alist-entry))
- ((if (eq pop-up-frames 'graphic-only)
- (display-graphic-p)
- pop-up-frames)
+ ((window--pop-up-frames alist)
0)
(display-buffer-reuse-frames 0)
(t (last-nonminibuffer-frame))))
@@ -8521,11 +8668,11 @@ buffer. ALIST is a buffer display action alist as compiled by
use time is higher than this.
- `window-min-width' specifies a preferred minimum width in
- canonical frame columns. If it is the constant `full-width',
+ canonical frame columns. If it is the symbol `full-width',
prefer a full-width window.
- `window-min-height' specifies a preferred minimum height in
- canonical frame lines. If it is the constant `full-height',
+ canonical frame lines. If it is the symbol `full-height',
prefer a full-height window.
If ALIST contains a non-nil `inhibit-same-window' entry, do not
@@ -8652,11 +8799,11 @@ Distinctive features are:
call.
`window-min-width' specifies a preferred minimum width in
- canonical frame columns. If it is the constant `full-width',
+ canonical frame columns. If it is the symbol `full-width',
prefer a full-width window.
`window-min-height' specifies a preferred minimum height in
- canonical frame lines. If it is the constant `full-height',
+ canonical frame lines. If it is the symbol `full-height',
prefer a full-height window.
- If the preceding steps fail, try to pop up a new window on the
@@ -8780,7 +8927,8 @@ another window."
:group 'windows
:group 'comint)
-(defcustom display-tex-shell-buffer-action '(display-buffer-in-previous-window)
+(defcustom display-tex-shell-buffer-action '(display-buffer-in-previous-window
+ (inhibit-same-window . t))
"`display-buffer' action for displaying TeX shell buffers."
:type display-buffer--action-custom-type
:risky t
@@ -10730,10 +10878,12 @@ Used in `repeat-mode'."
"2" #'split-root-window-below
"3" #'split-root-window-right
"s" #'window-toggle-side-windows
+ "d" #'toggle-window-dedicated
"^ f" #'tear-off-window
"^ t" #'tab-window-detach
"-" #'fit-window-to-buffer
- "0" #'delete-windows-on)
+ "0" #'delete-windows-on
+ "q" #'quit-window)
(define-key ctl-x-map "w" window-prefix-map)
(provide 'window)
diff --git a/lisp/winner.el b/lisp/winner.el
index 2aa59a86b25..19641a05bfc 100644
--- a/lisp/winner.el
+++ b/lisp/winner.el
@@ -178,7 +178,8 @@ You may want to include buffer names such as *Help*, *Apropos*,
(setq winner-last-frames nil)
(setq winner-last-command this-command))
(dolist (frame winner-modified-list)
- (winner-insert-if-new frame))
+ (if (frame-live-p frame)
+ (winner-insert-if-new frame)))
(setq winner-modified-list nil)
(winner-remember)))
diff --git a/lisp/woman.el b/lisp/woman.el
index 00c8dc6ef15..2357ba6b132 100644
--- a/lisp/woman.el
+++ b/lisp/woman.el
@@ -1346,8 +1346,8 @@ PATH-DIRS should be a list of general manual directories (like
manual directory regexps (like `woman-path').
Ignore any paths that are unreadable or not directories."
;; Allow each path to be a single string or a list of strings:
- (if (not (listp path-dirs)) (setq path-dirs (list path-dirs)))
- (if (not (listp path-regexps)) (setq path-regexps (list path-regexps)))
+ (setq path-dirs (ensure-list path-dirs))
+ (setq path-regexps (ensure-list path-regexps))
(let (head dirs path)
(dolist (dir path-dirs)
(when (consp dir)
@@ -1698,11 +1698,11 @@ Do not call directly!"
(progn
(goto-char (point-min))
(while (search-forward "__\b\b" nil t)
- (backward-delete-char 4)
+ (delete-char -4)
(woman-set-face (point) (1+ (point)) 'woman-italic))
(goto-char (point-min))
(while (search-forward "\b\b__" nil t)
- (backward-delete-char 4)
+ (delete-char -4)
(woman-set-face (1- (point)) (point) 'woman-italic))))
;; Interpret overprinting to indicate bold face:
@@ -1854,7 +1854,6 @@ Argument EVENT is the invoking mouse event."
(defun woman-reset-emulation (value)
"Reset `woman-emulation' to VALUE and reformat, for menu use."
- (interactive)
(setq woman-emulation value)
(woman-reformat-last-file))
@@ -2090,8 +2089,6 @@ European characters."
;;; The main decoding driver:
-(defvar font-lock-mode) ; for the compiler
-
(defun woman-decode-buffer ()
"Decode a buffer in UN*X man-page source format.
No external programs are used."
@@ -2569,7 +2566,8 @@ If DELETE is non-nil then delete from point."
;; "\\(\\\\{\\)\\|\\(\n[.']\\)?[ \t]*\\\\}[ \t]*"
;; Interpret bogus `el \}' as `el \{',
;; especially for Tcl/Tk man pages:
- "\\(\\\\{\\|el[ \t]*\\\\}\\)\\|\\(\n[.']\\)?[ \t]*\\\\}[ \t]*")
+ "\\(\\\\{\\|el[ \t]*\\\\}\\)\\|\\(\n[.']\\)?[ \t]*\\\\}[ \t]*"
+ nil t)
(match-beginning 1))
(re-search-forward "\\\\}"))
(delete-region (if delete from (match-beginning 0)) (point))
diff --git a/lisp/x-dnd.el b/lisp/x-dnd.el
index a09162c84c9..063b1dd6228 100644
--- a/lisp/x-dnd.el
+++ b/lisp/x-dnd.el
@@ -31,6 +31,9 @@
;;; Code:
(require 'dnd)
+;; For when building a --without-x configuration, where this is not
+;; preloaded.
+(eval-when-compile (require 'mwheel))
;;; Customizable variables
(defcustom x-dnd-test-function #'x-dnd-default-test-function
@@ -366,10 +369,9 @@ WINDOW is the window where the drop happened.
STRING is the uri-list as a string. The URIs are separated by \\r\\n."
(let ((uri-list (split-string string "[\0\r\n]" t))
retval)
- (dolist (bf uri-list)
- ;; If one URL is handled, treat as if the whole drop succeeded.
- (let ((did-action (dnd-handle-one-url window action bf)))
- (when did-action (setq retval did-action))))
+ (let ((did-action (dnd-handle-multiple-urls window uri-list
+ action)))
+ (when did-action (setq retval did-action)))
retval))
(defun x-dnd-handle-file-name (window action string)
@@ -380,17 +382,23 @@ STRING is the file names as a string, separated by nulls."
(coding (or file-name-coding-system
default-file-name-coding-system))
retval)
- (dolist (bf uri-list)
- ;; If one URL is handled, treat as if the whole drop succeeded.
- (if coding (setq bf (encode-coding-string bf coding)))
- (let* ((file-uri (concat "file://"
- (mapconcat 'url-hexify-string
- (split-string bf "/") "/")))
- (did-action (dnd-handle-one-url window action file-uri)))
- (when did-action (setq retval did-action))))
+ (let ((did-action
+ (dnd-handle-multiple-urls
+ window
+ (mapcar
+ (lambda (item)
+ (when coding
+ (setq item (encode-coding-string item
+ coding)))
+ (concat "file://"
+ (mapconcat 'url-hexify-string
+ (split-string item "/")
+ "/")))
+ uri-list)
+ action)))
+ (when did-action (setq retval did-action)))
retval))
-
(defun x-dnd-choose-type (types &optional known-types)
"Choose which type we want to receive for the drop.
TYPES are the types the source of the drop offers, a vector of type names
diff --git a/lisp/xml.el b/lisp/xml.el
index 02469bf6ad3..849377bb758 100644
--- a/lisp/xml.el
+++ b/lisp/xml.el
@@ -265,7 +265,7 @@ See also `xml-get-attribute-or-nil'."
"\\)*\"\\|'\\(?:[^%&']\\|"
xml-pe-reference-re "\\|"
xml-reference-re "\\)*'\\)"))
-) ; End of `eval-when-compile'
+) ; End of `eval-and-compile'
;; [75] ExternalID ::= 'SYSTEM' S SystemLiteral
@@ -669,10 +669,7 @@ Leave point at the first non-blank character after the tag."
(if (assoc name attlist)
(error "XML: (Not Well-Formed) Each attribute must be unique within an element"))
- ;; Multiple whitespace characters should be replaced with a single one
- ;; in the attributes
(let ((string (match-string-no-properties 1)))
- (replace-regexp-in-string "\\s-\\{2,\\}" " " string)
(let ((expansion (xml-substitute-special string)))
(unless (stringp expansion)
;; We say this is the constraint. It is actually that
diff --git a/lisp/xt-mouse.el b/lisp/xt-mouse.el
index cd00467f14f..081b8f32456 100644
--- a/lisp/xt-mouse.el
+++ b/lisp/xt-mouse.el
@@ -40,6 +40,8 @@
;;; Code:
+(require 'mwheel)
+
(defvar xterm-mouse-debug-buffer nil)
(defun xterm-mouse-translate (_event)
@@ -193,6 +195,12 @@ single byte."
(cons n c))
(cons (- (setq c (xterm-mouse--read-coordinate)) 32) c))))
+(defun xterm-mouse--button-p (event btn)
+ (and (symbolp event)
+ (string-prefix-p "mouse-" (symbol-name event))
+ (eq btn (car (read-from-string (symbol-name event)
+ (length "mouse-"))))))
+
;; XTerm reports mouse events as
;; <EVENT-CODE> <X> <Y> in default mode, and
;; <EVENT-CODE> ";" <X> ";" <Y> <"M" or "m"> in extended mode.
@@ -230,13 +238,22 @@ single byte."
;; Spurious release event without previous button-down
;; event: assume, that the last button was button 1.
(t 1)))
- (sym (if move 'mouse-movement
- (intern (concat (if ctrl "C-" "")
- (if meta "M-" "")
- (if shift "S-" "")
- (if down "down-" "")
- "mouse-"
- (number-to-string btn))))))
+ (sym
+ (if move 'mouse-movement
+ (intern
+ (concat
+ (if ctrl "C-" "")
+ (if meta "M-" "")
+ (if shift "S-" "")
+ (if down "down-" "")
+ (cond
+ ;; BEWARE: `mouse-wheel-UP-event' corresponds to
+ ;; `wheel-DOWN' events and vice versa!!
+ ((xterm-mouse--button-p mouse-wheel-down-event btn) "wheel-up")
+ ((xterm-mouse--button-p mouse-wheel-up-event btn) "wheel-down")
+ ((xterm-mouse--button-p mouse-wheel-left-event btn) "wheel-left")
+ ((xterm-mouse--button-p mouse-wheel-right-event btn) "wheel-right")
+ (t (format "mouse-%d" btn))))))))
(list sym (1- x) (1- y))))
(defun xterm-mouse--set-click-count (event click-count)
diff --git a/lisp/yank-media.el b/lisp/yank-media.el
index 1d44eef91e1..e33c36da5b6 100644
--- a/lisp/yank-media.el
+++ b/lisp/yank-media.el
@@ -81,7 +81,7 @@ all the different selection types."
(gui-get-selection 'CLIPBOARD 'TARGETS)))
(defun yank-media--get-selection (data-type)
- (when-let ((data (gui-backend-get-selection 'CLIPBOARD data-type)))
+ (when-let ((data (gui-get-selection 'CLIPBOARD data-type)))
(if (string-match-p "\\`text/" (symbol-name data-type))
(yank-media-types--format data-type data)
data)))
diff --git a/m4/00gnulib.m4 b/m4/00gnulib.m4
index 3448c40bbd6..99c99d1b0fb 100644
--- a/m4/00gnulib.m4
+++ b/m4/00gnulib.m4
@@ -1,4 +1,4 @@
-# 00gnulib.m4 serial 8
+# 00gnulib.m4 serial 9
dnl Copyright (C) 2009-2024 Free Software Foundation, Inc.
dnl This file is free software; the Free Software Foundation
dnl gives unlimited permission to copy and/or distribute it,
@@ -49,14 +49,14 @@ dnl AC_REQUIRE([gl_COMPILER_CLANG])
[if test $gl_cv_compiler_clang = yes; then
dnl Test whether the compiler supports the option
dnl '-Werror=implicit-function-declaration'.
- save_ac_compile="$ac_compile"
+ saved_ac_compile="$ac_compile"
ac_compile="$ac_compile -Werror=implicit-function-declaration"
dnl Use _AC_COMPILE_IFELSE instead of AC_COMPILE_IFELSE, to avoid a
dnl warning "AC_COMPILE_IFELSE was called before AC_USE_SYSTEM_EXTENSIONS".
_AC_COMPILE_IFELSE([AC_LANG_PROGRAM([[]],[[]])],
[gl_cv_compiler_check_decl_option='-Werror=implicit-function-declaration'],
[gl_cv_compiler_check_decl_option=none])
- ac_compile="$save_ac_compile"
+ ac_compile="$saved_ac_compile"
else
gl_cv_compiler_check_decl_option=none
fi
@@ -71,11 +71,11 @@ dnl Redefine _AC_CHECK_DECL_BODY so that it references ac_compile_for_check_decl
dnl instead of ac_compile. If, for whatever reason, the override of AC_PROG_CC
dnl in zzgnulib.m4 is inactive, use the original ac_compile.
m4_define([_AC_CHECK_DECL_BODY],
-[ ac_save_ac_compile="$ac_compile"
+[ ac_saved_ac_compile="$ac_compile"
if test -n "$ac_compile_for_check_decl"; then
ac_compile="$ac_compile_for_check_decl"
fi]
-m4_defn([_AC_CHECK_DECL_BODY])[ ac_compile="$ac_save_ac_compile"
+m4_defn([_AC_CHECK_DECL_BODY])[ ac_compile="$ac_saved_ac_compile"
])
# gl_00GNULIB
diff --git a/m4/absolute-header.m4 b/m4/absolute-header.m4
index aa7d0dac6da..0e9f9ba763a 100644
--- a/m4/absolute-header.m4
+++ b/m4/absolute-header.m4
@@ -1,4 +1,4 @@
-# absolute-header.m4 serial 17
+# absolute-header.m4 serial 18
dnl Copyright (C) 2006-2024 Free Software Foundation, Inc.
dnl This file is free software; the Free Software Foundation
dnl gives unlimited permission to copy and/or distribute it,
@@ -66,7 +66,7 @@ AC_DEFUN([gl_ABSOLUTE_HEADER_ONE],
esac
changequote(,)
case "$host_os" in
- mingw*)
+ mingw* | windows*)
dnl For the sake of native Windows compilers (excluding gcc),
dnl treat backslash as a directory separator, like /.
dnl Actually, these compilers use a double-backslash as
diff --git a/m4/acl.m4 b/m4/acl.m4
index 59ada447581..2050d108b0c 100644
--- a/m4/acl.m4
+++ b/m4/acl.m4
@@ -1,5 +1,5 @@
# acl.m4 - check for access control list (ACL) primitives
-# serial 24
+# serial 30
# Copyright (C) 2002, 2004-2024 Free Software Foundation, Inc.
# This file is free software; the Free Software Foundation
@@ -12,12 +12,12 @@ AC_DEFUN([gl_FUNC_ACL_ARG],
[
gl_need_lib_has_acl=
AC_ARG_ENABLE([acl],
- AS_HELP_STRING([--disable-acl], [do not support ACLs]),
+ AS_HELP_STRING([[--disable-acl]], [do not support ACLs]),
, [enable_acl=auto])
])
-AC_DEFUN([gl_FUNC_ACL],
+AC_DEFUN_ONCE([gl_FUNC_ACL],
[
AC_REQUIRE([gl_FUNC_ACL_ARG])
AC_CHECK_FUNCS_ONCE([fchmod])
@@ -27,7 +27,7 @@ AC_DEFUN([gl_FUNC_ACL],
dnl On all platforms, the ACL related API is declared in <sys/acl.h>.
AC_CHECK_HEADERS([sys/acl.h])
if test $ac_cv_header_sys_acl_h = yes; then
- ac_save_LIBS=$LIBS
+ gl_saved_LIBS=$LIBS
dnl Test for POSIX-draft-like API (GNU/Linux, FreeBSD, Mac OS X,
dnl IRIX, Tru64, Cygwin >= 2.5).
@@ -129,7 +129,7 @@ int type = ACL_TYPE_EXTENDED;]])],
fi
fi
- LIBS=$ac_save_LIBS
+ LIBS=$gl_saved_LIBS
fi
if test "$enable_acl$use_acl" = yes0; then
@@ -139,7 +139,9 @@ int type = ACL_TYPE_EXTENDED;]])],
AC_MSG_WARN([AC_PACKAGE_NAME will be built without ACL support.])
fi
fi
- test -n "$gl_need_lib_has_acl" && LIB_HAS_ACL=$LIB_ACL
+ if test -n "$gl_need_lib_has_acl"; then
+ FILE_HAS_ACL_LIB=$LIB_ACL
+ fi
AC_SUBST([LIB_ACL])
AC_DEFINE_UNQUOTED([USE_ACL], [$use_acl],
[Define to nonzero if you want access control list support.])
@@ -175,37 +177,23 @@ AC_DEFUN([gl_ACL_GET_FILE],
AS_IF([test "$gl_cv_func_working_acl_get_file" != no], [$1], [$2])
])
-# On GNU/Linux, testing if a file has an acl can be done with the getxattr
-# syscall which doesn't require linking against additional libraries.
+# On GNU/Linux, testing if a file has an acl can be done with the
+# listxattr and getxattr syscalls, which don't require linking
+# against additional libraries. Assume this works if linux/attr.h
+# and listxattr are present.
AC_DEFUN([gl_FILE_HAS_ACL],
[
AC_REQUIRE([gl_FUNC_ACL_ARG])
- if test "$enable_acl" != no; then
- AC_CACHE_CHECK([for getxattr with XATTR_NAME_POSIX_ACL macros],
- [gl_cv_getxattr_with_posix_acls],
- [gl_cv_getxattr_with_posix_acls=no
- AC_LINK_IFELSE(
- [AC_LANG_PROGRAM(
- [[#include <sys/types.h>
- #include <sys/xattr.h>
- #include <linux/xattr.h>
- ]],
- [[ssize_t a = getxattr (".", XATTR_NAME_POSIX_ACL_ACCESS, 0, 0);
- ssize_t b = getxattr (".", XATTR_NAME_POSIX_ACL_DEFAULT, 0, 0);
- return a < 0 || b < 0;
- ]])],
- [gl_cv_getxattr_with_posix_acls=yes])])
- fi
- if test "$gl_cv_getxattr_with_posix_acls" = yes; then
- LIB_HAS_ACL=
- AC_DEFINE([GETXATTR_WITH_POSIX_ACLS], 1,
- [Define to 1 if getxattr works with XATTR_NAME_POSIX_ACL_ACCESS
- and XATTR_NAME_POSIX_ACL_DEFAULT.])
- else
- dnl Set gl_need_lib_has_acl to a nonempty value, so that any
- dnl later gl_FUNC_ACL call will set LIB_HAS_ACL=$LIB_ACL.
- gl_need_lib_has_acl=1
- LIB_HAS_ACL=$LIB_ACL
- fi
- AC_SUBST([LIB_HAS_ACL])
+ AC_CHECK_HEADERS_ONCE([linux/xattr.h])
+ AC_CHECK_FUNCS_ONCE([listxattr])
+ FILE_HAS_ACL_LIB=
+ AS_CASE([$enable_acl,$ac_cv_header_linux_xattr_h,$ac_cv_func_listxattr],
+ [no,*,*], [],
+ [*,yes,yes], [],
+ [*],
+ [dnl Set gl_need_lib_has_acl to a nonempty value, so that any
+ dnl later gl_FUNC_ACL call will set FILE_HAS_ACL_LIB=$LIB_ACL.
+ gl_need_lib_has_acl=1
+ FILE_HAS_ACL_LIB=$LIB_ACL])
+ AC_SUBST([FILE_HAS_ACL_LIB])
])
diff --git a/m4/alloca.m4 b/m4/alloca.m4
index 911a003a04f..90960215382 100644
--- a/m4/alloca.m4
+++ b/m4/alloca.m4
@@ -1,6 +1,6 @@
# alloca.m4 serial 21
-dnl Copyright (C) 2002-2004, 2006-2007, 2009-2024 Free Software
-dnl Foundation, Inc.
+dnl Copyright (C) 2002-2004, 2006-2007, 2009-2024 Free Software Foundation,
+dnl Inc.
dnl This file is free software; the Free Software Foundation
dnl gives unlimited permission to copy and/or distribute it,
dnl with or without modifications, as long as this notice is preserved.
diff --git a/m4/assert_h.m4 b/m4/assert_h.m4
index e3aaad34ddc..d3d4c42519f 100644
--- a/m4/assert_h.m4
+++ b/m4/assert_h.m4
@@ -9,16 +9,16 @@ dnl From Paul Eggert.
AC_DEFUN([gl_ASSERT_H],
[
AC_CACHE_CHECK([for static_assert], [gl_cv_static_assert],
- [gl_save_CFLAGS=$CFLAGS
+ [gl_saved_CFLAGS=$CFLAGS
for gl_working in "yes, a keyword" "yes, an <assert.h> macro"; do
AS_CASE([$gl_working],
- [*assert.h*], [CFLAGS="$gl_save_CFLAGS -DINCLUDE_ASSERT_H"])
+ [*assert.h*], [CFLAGS="$gl_saved_CFLAGS -DINCLUDE_ASSERT_H"])
AC_COMPILE_IFELSE(
[AC_LANG_PROGRAM(
[[#if defined __clang__ && __STDC_VERSION__ < 202311
#pragma clang diagnostic error "-Wc2x-extensions"
- #pragma clang diagnostic error "-Wc++17-extensions"
+ #pragma clang diagnostic error "-Wc++1z-extensions"
#endif
#ifdef INCLUDE_ASSERT_H
#include <assert.h>
@@ -32,7 +32,7 @@ AC_DEFUN([gl_ASSERT_H],
]])],
[gl_cv_static_assert=$gl_working],
[gl_cv_static_assert=no])
- CFLAGS=$gl_save_CFLAGS
+ CFLAGS=$gl_saved_CFLAGS
test "$gl_cv_static_assert" != no && break
done])
@@ -46,10 +46,13 @@ AC_DEFUN([gl_ASSERT_H],
gl_NEXT_HEADERS([assert.h])])
dnl The "zz" puts this toward config.h's end, to avoid potential
- dnl collisions with other definitions. #undef assert so that
- dnl programs are not tempted to use it without specifically
- dnl including assert.h. Break the #undef apart with a comment
- dnl so that 'configure' does not comment it out.
+ dnl collisions with other definitions.
+ dnl #undef assert so that programs are not tempted to use it without
+ dnl specifically including assert.h.
+ dnl #undef __ASSERT_H__ so that on IRIX, when programs later include
+ dnl <assert.h>, this include actually defines assert.
+ dnl Break the #undef_s apart with a comment so that 'configure' does
+ dnl not comment them out.
AH_VERBATIM([zzstatic_assert],
[#if (!defined HAVE_C_STATIC_ASSERT && !defined assert \
&& (!defined __cplusplus \
@@ -57,10 +60,13 @@ AC_DEFUN([gl_ASSERT_H],
&& __GNUG__ < 6 && __clang_major__ < 6)))
#include <assert.h>
#undef/**/assert
+ #ifdef __sgi
+ #undef/**/__ASSERT_H__
+ #endif
/* Solaris 11.4 <assert.h> defines static_assert as a macro with 2 arguments.
We need it also to be invocable with a single argument. */
#if defined __sun && (__STDC_VERSION__ - 0 >= 201112L) && !defined __cplusplus
- #undef static_assert
+ #undef/**/static_assert
#define static_assert _Static_assert
#endif
#endif])
diff --git a/m4/canonicalize.m4 b/m4/canonicalize.m4
index c7129b2049d..05dc6dd264d 100644
--- a/m4/canonicalize.m4
+++ b/m4/canonicalize.m4
@@ -1,4 +1,4 @@
-# canonicalize.m4 serial 37
+# canonicalize.m4 serial 39
dnl Copyright (C) 2003-2007, 2009-2024 Free Software Foundation, Inc.
@@ -12,7 +12,8 @@ AC_DEFUN([gl_FUNC_CANONICALIZE_FILENAME_MODE],
[
AC_REQUIRE([gl_USE_SYSTEM_EXTENSIONS])
AC_REQUIRE([gl_FUNC_LSTAT_FOLLOWS_SLASHED_SYMLINK])
- AC_CHECK_FUNCS_ONCE([canonicalize_file_name faccessat])
+ AC_CHECK_FUNCS_ONCE([canonicalize_file_name])
+ gl_CHECK_FUNCS_ANDROID([faccessat], [[#include <unistd.h>]])
AC_REQUIRE([gl_DOUBLE_SLASH_ROOT])
AC_REQUIRE([gl_FUNC_REALPATH_WORKS])
if test $ac_cv_func_canonicalize_file_name = no; then
@@ -58,14 +59,15 @@ AC_DEFUN([gl_CANONICALIZE_LGPL_SEPARATE],
[
AC_REQUIRE([gl_USE_SYSTEM_EXTENSIONS])
AC_REQUIRE([gl_FUNC_LSTAT_FOLLOWS_SLASHED_SYMLINK])
- AC_CHECK_FUNCS_ONCE([canonicalize_file_name faccessat])
+ AC_CHECK_FUNCS_ONCE([canonicalize_file_name])
+ gl_CHECK_FUNCS_ANDROID([faccessat], [[#include <unistd.h>]])
dnl On native Windows, we use _getcwd(), regardless whether getcwd() is
dnl available through the linker option '-loldnames'.
AC_REQUIRE([AC_CANONICAL_HOST])
case "$host_os" in
- mingw*) ;;
- *) AC_CHECK_FUNCS([getcwd]) ;;
+ mingw* | windows*) ;;
+ *) AC_CHECK_FUNCS([getcwd]) ;;
esac
AC_REQUIRE([gl_DOUBLE_SLASH_ROOT])
@@ -156,16 +158,16 @@ AC_DEFUN([gl_FUNC_REALPATH_WORKS],
esac
],
[case "$host_os" in
- # Guess yes on glibc systems.
- *-gnu* | gnu*) gl_cv_func_realpath_works="guessing yes" ;;
- # Guess 'nearly' on musl systems.
- *-musl*) gl_cv_func_realpath_works="guessing nearly" ;;
- # Guess no on Cygwin.
- cygwin*) gl_cv_func_realpath_works="guessing no" ;;
- # Guess no on native Windows.
- mingw*) gl_cv_func_realpath_works="guessing no" ;;
- # If we don't know, obey --enable-cross-guesses.
- *) gl_cv_func_realpath_works="$gl_cross_guess_normal" ;;
+ # Guess yes on glibc systems.
+ *-gnu* | gnu*) gl_cv_func_realpath_works="guessing yes" ;;
+ # Guess 'nearly' on musl systems.
+ *-musl*) gl_cv_func_realpath_works="guessing nearly" ;;
+ # Guess no on Cygwin.
+ cygwin*) gl_cv_func_realpath_works="guessing no" ;;
+ # Guess no on native Windows.
+ mingw* | windows*) gl_cv_func_realpath_works="guessing no" ;;
+ # If we don't know, obey --enable-cross-guesses.
+ *) gl_cv_func_realpath_works="$gl_cross_guess_normal" ;;
esac
])
rm -rf conftest.a conftest.l conftest.d
diff --git a/m4/clock_time.m4 b/m4/clock_time.m4
index 0c6d182d106..c016575c8ea 100644
--- a/m4/clock_time.m4
+++ b/m4/clock_time.m4
@@ -1,32 +1,53 @@
-# clock_time.m4 serial 11
+# clock_time.m4 serial 14
dnl Copyright (C) 2002-2006, 2009-2024 Free Software Foundation, Inc.
dnl This file is free software; the Free Software Foundation
dnl gives unlimited permission to copy and/or distribute it,
dnl with or without modifications, as long as this notice is preserved.
# Check for clock_getres, clock_gettime and clock_settime,
-# and set LIB_CLOCK_GETTIME.
+# and set CLOCK_TIME_LIB.
# For a program named, say foo, you should add a line like the following
# in the corresponding Makefile.am file:
-# foo_LDADD = $(LDADD) $(LIB_CLOCK_GETTIME)
+# foo_LDADD = $(LDADD) $(CLOCK_TIME_LIB)
AC_DEFUN([gl_CLOCK_TIME],
[
+ AC_REQUIRE([AC_CANONICAL_HOST])
+
dnl Persuade glibc and Solaris <time.h> to declare these functions.
AC_REQUIRE([gl_USE_SYSTEM_EXTENSIONS])
+ # On mingw, these functions are defined in the libwinpthread library,
+ # which is better avoided. In fact, the clock_gettime function is buggy
+ # in 32-bit mingw, when -D__MINGW_USE_VC2005_COMPAT is used (which Gnulib's
+ # year2038 module does): It leaves the upper 32 bits of the tv_sec field
+ # of the result uninitialized.
+
# Solaris 2.5.1 needs -lposix4 to get the clock_gettime function.
# Solaris 7 prefers the library name -lrt to the obsolescent name -lposix4.
# Save and restore LIBS so e.g., -lrt, isn't added to it. Otherwise, *all*
# programs in the package would end up linked with that potentially-shared
# library, inducing unnecessary run-time overhead.
- LIB_CLOCK_GETTIME=
+ CLOCK_TIME_LIB=
+ AC_SUBST([CLOCK_TIME_LIB])
+ case "$host_os" in
+ mingw* | windows*)
+ ac_cv_func_clock_getres=no
+ ac_cv_func_clock_gettime=no
+ ac_cv_func_clock_settime=no
+ ;;
+ *)
+ gl_saved_libs=$LIBS
+ AC_SEARCH_LIBS([clock_gettime], [rt posix4],
+ [test "$ac_cv_search_clock_gettime" = "none required" ||
+ CLOCK_TIME_LIB=$ac_cv_search_clock_gettime])
+ AC_CHECK_FUNCS([clock_getres clock_gettime clock_settime])
+ LIBS=$gl_saved_libs
+ ;;
+ esac
+
+ # For backward compatibility.
+ LIB_CLOCK_GETTIME="$CLOCK_TIME_LIB"
AC_SUBST([LIB_CLOCK_GETTIME])
- gl_saved_libs=$LIBS
- AC_SEARCH_LIBS([clock_gettime], [rt posix4],
- [test "$ac_cv_search_clock_gettime" = "none required" ||
- LIB_CLOCK_GETTIME=$ac_cv_search_clock_gettime])
- AC_CHECK_FUNCS([clock_getres clock_gettime clock_settime])
- LIBS=$gl_saved_libs
])
diff --git a/m4/codeset.m4 b/m4/codeset.m4
new file mode 100644
index 00000000000..94dccce7775
--- /dev/null
+++ b/m4/codeset.m4
@@ -0,0 +1,24 @@
+# codeset.m4 serial 5 (gettext-0.18.2)
+dnl Copyright (C) 2000-2002, 2006, 2008-2014, 2016, 2019-2024 Free Software
+dnl Foundation, Inc.
+dnl This file is free software; the Free Software Foundation
+dnl gives unlimited permission to copy and/or distribute it,
+dnl with or without modifications, as long as this notice is preserved.
+
+dnl From Bruno Haible.
+
+AC_DEFUN([AM_LANGINFO_CODESET],
+[
+ AC_CACHE_CHECK([for nl_langinfo and CODESET], [am_cv_langinfo_codeset],
+ [AC_LINK_IFELSE(
+ [AC_LANG_PROGRAM(
+ [[#include <langinfo.h>]],
+ [[char* cs = nl_langinfo(CODESET); return !cs;]])],
+ [am_cv_langinfo_codeset=yes],
+ [am_cv_langinfo_codeset=no])
+ ])
+ if test $am_cv_langinfo_codeset = yes; then
+ AC_DEFINE([HAVE_LANGINFO_CODESET], [1],
+ [Define if you have <langinfo.h> and nl_langinfo(CODESET).])
+ fi
+])
diff --git a/m4/copy-file-range.m4 b/m4/copy-file-range.m4
index b5d7a03a03a..443e598ba55 100644
--- a/m4/copy-file-range.m4
+++ b/m4/copy-file-range.m4
@@ -1,4 +1,4 @@
-# copy-file-range.m4
+# copy-file-range.m4 serial 5
dnl Copyright 2019-2024 Free Software Foundation, Inc.
dnl This file is free software; the Free Software Foundation
dnl gives unlimited permission to copy and/or distribute it,
@@ -17,43 +17,42 @@ AC_DEFUN([gl_FUNC_COPY_FILE_RANGE],
dnl Programs that use copy_file_range must fall back on read+write
dnl anyway, and there's little point to substituting the Gnulib stub
dnl for a glibc stub.
- AC_CACHE_CHECK([for copy_file_range], [gl_cv_func_copy_file_range],
- [AC_LINK_IFELSE(
- [AC_LANG_PROGRAM(
- [[#include <unistd.h>
- ]],
- [[ssize_t (*func) (int, off_t *, int, off_t *, size_t, unsigned)
- = copy_file_range;
- return func (0, 0, 0, 0, 0, 0) & 127;
- ]])
- ],
- [gl_cv_func_copy_file_range=yes],
- [gl_cv_func_copy_file_range=no])
- ])
-
+ case "$host_os" in
+ *-gnu* | gnu*)
+ AC_CACHE_CHECK([for copy_file_range], [gl_cv_func_copy_file_range],
+ [AC_LINK_IFELSE(
+ [AC_LANG_PROGRAM(
+ [[#include <unistd.h>
+ ]],
+ [[ssize_t (*func) (int, off_t *, int, off_t *, size_t, unsigned)
+ = copy_file_range;
+ return func (0, 0, 0, 0, 0, 0) & 127;
+ ]])
+ ],
+ [gl_cv_func_copy_file_range=yes],
+ [gl_cv_func_copy_file_range=no])
+ ])
+ gl_cv_onwards_func_copy_file_range="$gl_cv_func_copy_file_range"
+ ;;
+ *)
+ gl_CHECK_FUNCS_ANDROID([copy_file_range], [[#include <unistd.h>]])
+ gl_cv_func_copy_file_range="$ac_cv_func_copy_file_range"
+ ;;
+ esac
if test "$gl_cv_func_copy_file_range" != yes; then
HAVE_COPY_FILE_RANGE=0
+ case "$gl_cv_onwards_func_copy_file_range" in
+ future*) REPLACE_COPY_FILE_RANGE=1 ;;
+ esac
else
AC_DEFINE([HAVE_COPY_FILE_RANGE], 1,
[Define to 1 if the function copy_file_range exists.])
case $host_os in
linux*)
- AC_CACHE_CHECK([whether copy_file_range is known to work],
- [gl_cv_copy_file_range_known_to_work],
- [AC_COMPILE_IFELSE(
- [AC_LANG_PROGRAM(
- [[#include <linux/version.h>
- ]],
- [[#if LINUX_VERSION_CODE < KERNEL_VERSION (5, 3, 0)
- #error "copy_file_range is buggy"
- #endif
- ]])],
- [gl_cv_copy_file_range_known_to_work=yes],
- [gl_cv_copy_file_range_known_to_work=no])])
- if test "$gl_cv_copy_file_range_known_to_work" = no; then
- REPLACE_COPY_FILE_RANGE=1
- fi;;
+ # See copy-file-range.c comment re pre-5.3 Linux kernel bugs.
+ # We should be able to remove this hack in 2025.
+ REPLACE_COPY_FILE_RANGE=1;;
esac
fi
])
diff --git a/m4/d-type.m4 b/m4/d-type.m4
index 13bab57a3a5..b06bca5a7dc 100644
--- a/m4/d-type.m4
+++ b/m4/d-type.m4
@@ -5,8 +5,7 @@ dnl
dnl Check whether struct dirent has a member named d_type.
dnl
-# Copyright (C) 1997, 1999-2004, 2006, 2009-2024 Free Software
-# Foundation, Inc.
+# Copyright (C) 1997, 1999-2004, 2006, 2009-2024 Free Software Foundation, Inc.
#
# This file is free software; the Free Software Foundation
# gives unlimited permission to copy and/or distribute it,
diff --git a/m4/dirent_h.m4 b/m4/dirent_h.m4
index a856a113d60..3e3d967f499 100644
--- a/m4/dirent_h.m4
+++ b/m4/dirent_h.m4
@@ -1,4 +1,4 @@
-# dirent_h.m4 serial 19
+# dirent_h.m4 serial 22
dnl Copyright (C) 2008-2024 Free Software Foundation, Inc.
dnl This file is free software; the Free Software Foundation
dnl gives unlimited permission to copy and/or distribute it,
@@ -21,12 +21,28 @@ AC_DEFUN_ONCE([gl_DIRENT_H],
fi
AC_SUBST([HAVE_DIRENT_H])
+ gl_DIRENT_DIR
+
dnl Check for declarations of anything we want to poison if the
dnl corresponding gnulib module is not in use.
gl_WARN_ON_USE_PREPARE([[#include <dirent.h>
]], [alphasort closedir dirfd fdopendir opendir readdir rewinddir scandir])
])
+dnl Determine whether <dirent.h> needs to override the DIR type.
+AC_DEFUN_ONCE([gl_DIRENT_DIR],
+[
+ dnl Set DIR_HAS_FD_MEMBER if dirfd() works, i.e. not always returns -1.
+ dnl We could use the findings from gl_FUNC_DIRFD and gl_PREREQ_DIRFD, but
+ dnl it's simpler since we know the affected platforms.
+ AC_REQUIRE([AC_CANONICAL_HOST])
+ case "$host_os" in
+ mingw* | windows* | os2*) DIR_HAS_FD_MEMBER=0 ;;
+ *) DIR_HAS_FD_MEMBER=1 ;;
+ esac
+ AC_SUBST([DIR_HAS_FD_MEMBER])
+])
+
# gl_DIRENT_MODULE_INDICATOR([modulename])
# sets the shell variable that indicates the presence of the given module
# to a C preprocessor expression that will evaluate to 1.
@@ -73,6 +89,8 @@ AC_DEFUN([gl_DIRENT_H_DEFAULTS],
HAVE_SCANDIR=1; AC_SUBST([HAVE_SCANDIR])
HAVE_ALPHASORT=1; AC_SUBST([HAVE_ALPHASORT])
REPLACE_OPENDIR=0; AC_SUBST([REPLACE_OPENDIR])
+ REPLACE_READDIR=0; AC_SUBST([REPLACE_READDIR])
+ REPLACE_REWINDDIR=0; AC_SUBST([REPLACE_REWINDDIR])
REPLACE_CLOSEDIR=0; AC_SUBST([REPLACE_CLOSEDIR])
REPLACE_DIRFD=0; AC_SUBST([REPLACE_DIRFD])
REPLACE_FDOPENDIR=0; AC_SUBST([REPLACE_FDOPENDIR])
diff --git a/m4/dirfd.m4 b/m4/dirfd.m4
index 85223351b28..e58582e6145 100644
--- a/m4/dirfd.m4
+++ b/m4/dirfd.m4
@@ -1,4 +1,4 @@
-# serial 26 -*- Autoconf -*-
+# serial 30 -*- Autoconf -*-
dnl Find out how to get the file descriptor associated with an open DIR*.
@@ -12,7 +12,7 @@ dnl From Jim Meyering
AC_DEFUN([gl_FUNC_DIRFD],
[
AC_REQUIRE([gl_DIRENT_H_DEFAULTS])
- AC_REQUIRE([AC_CANONICAL_HOST]) dnl for cross-compiles
+ AC_REQUIRE([AC_CANONICAL_HOST])
dnl Persuade glibc <dirent.h> to declare dirfd().
AC_REQUIRE([AC_USE_SYSTEM_EXTENSIONS])
@@ -36,15 +36,17 @@ AC_DEFUN([gl_FUNC_DIRFD],
[gl_cv_func_dirfd_macro=yes],
[gl_cv_func_dirfd_macro=no])])
- # Use the replacement if we have no function or macro with that name,
- # or if OS/2 kLIBC whose dirfd() does not work.
- # Replace only if the system declares dirfd already.
- case $ac_cv_func_dirfd,$gl_cv_func_dirfd_macro,$host_os,$ac_cv_have_decl_dirfd in
- no,no,*,yes | *,*,os2*,yes)
+ if test $ac_cv_func_dirfd = no && test $gl_cv_func_dirfd_macro = no; then
+ HAVE_DIRFD=0
+ else
+ HAVE_DIRFD=1
+ dnl Replace dirfd() on native Windows and OS/2 kLIBC,
+ dnl to support fdopendir().
+ AC_REQUIRE([gl_DIRENT_DIR])
+ if test $DIR_HAS_FD_MEMBER = 0; then
REPLACE_DIRFD=1
- AC_DEFINE([REPLACE_DIRFD], [1],
- [Define to 1 if gnulib's dirfd() replacement is used.]);;
- esac
+ fi
+ fi
])
dnl Prerequisites of lib/dirfd.c.
@@ -53,7 +55,7 @@ AC_DEFUN([gl_PREREQ_DIRFD],
AC_CACHE_CHECK([how to get the file descriptor associated with an open DIR*],
[gl_cv_sys_dir_fd_member_name],
[
- dirfd_save_CFLAGS=$CFLAGS
+ gl_saved_CFLAGS=$CFLAGS
for ac_expr in d_fd dd_fd; do
CFLAGS="$CFLAGS -DDIR_FD_MEMBER_NAME=$ac_expr"
@@ -63,7 +65,7 @@ AC_DEFUN([gl_PREREQ_DIRFD],
[[DIR *dir_p = opendir("."); (void) dir_p->DIR_FD_MEMBER_NAME;]])],
[dir_fd_found=yes]
)
- CFLAGS=$dirfd_save_CFLAGS
+ CFLAGS=$gl_saved_CFLAGS
test "$dir_fd_found" = yes && break
done
test "$dir_fd_found" = yes || ac_expr=no_such_member
diff --git a/m4/dup2.m4 b/m4/dup2.m4
index 1833ff0ec17..f6759b647a6 100644
--- a/m4/dup2.m4
+++ b/m4/dup2.m4
@@ -1,6 +1,5 @@
-#serial 27
-dnl Copyright (C) 2002, 2005, 2007, 2009-2024 Free Software Foundation,
-dnl Inc.
+#serial 28
+dnl Copyright (C) 2002, 2005, 2007, 2009-2024 Free Software Foundation, Inc.
dnl This file is free software; the Free Software Foundation
dnl gives unlimited permission to copy and/or distribute it,
dnl with or without modifications, as long as this notice is preserved.
@@ -68,7 +67,7 @@ AC_DEFUN([gl_FUNC_DUP2],
],
[gl_cv_func_dup2_works=yes], [gl_cv_func_dup2_works=no],
[case "$host_os" in
- mingw*) # on this platform, dup2 always returns 0 for success
+ mingw* | windows*) # on this platform, dup2 always returns 0 for success
gl_cv_func_dup2_works="guessing no" ;;
cygwin*) # on cygwin 1.5.x, dup2(1,1) returns 0
gl_cv_func_dup2_works="guessing no" ;;
diff --git a/m4/euidaccess.m4 b/m4/euidaccess.m4
index ab8f4c6d0ee..e3d828f6ca5 100644
--- a/m4/euidaccess.m4
+++ b/m4/euidaccess.m4
@@ -1,4 +1,4 @@
-# euidaccess.m4 serial 15
+# euidaccess.m4 serial 17
dnl Copyright (C) 2002-2024 Free Software Foundation, Inc.
dnl This file is free software; the Free Software Foundation
dnl gives unlimited permission to copy and/or distribute it,
@@ -32,7 +32,7 @@ AC_DEFUN([gl_FUNC_EUIDACCESS],
# Prerequisites of lib/euidaccess.c.
AC_DEFUN([gl_PREREQ_EUIDACCESS], [
dnl Prefer POSIX faccessat over non-standard euidaccess.
- AC_CHECK_FUNCS_ONCE([faccessat])
+ gl_CHECK_FUNCS_ANDROID([faccessat], [[#include <unistd.h>]])
dnl Try various other non-standard fallbacks.
AC_CHECK_HEADERS([libgen.h])
AC_FUNC_GETGROUPS
@@ -41,12 +41,15 @@ AC_DEFUN([gl_PREREQ_EUIDACCESS], [
# Save and restore LIBS so -lgen isn't added to it. Otherwise, *all*
# programs in the package would end up linked with that potentially-shared
# library, inducing unnecessary run-time overhead.
- LIB_EACCESS=
- AC_SUBST([LIB_EACCESS])
+ EUIDACCESS_LIBGEN=
+ AC_SUBST([EUIDACCESS_LIBGEN])
gl_saved_libs=$LIBS
AC_SEARCH_LIBS([eaccess], [gen],
[test "$ac_cv_search_eaccess" = "none required" ||
- LIB_EACCESS=$ac_cv_search_eaccess])
+ EUIDACCESS_LIBGEN=$ac_cv_search_eaccess])
AC_CHECK_FUNCS([eaccess])
LIBS=$gl_saved_libs
+ # For backward compatibility.
+ LIB_EACCESS="$EUIDACCESS_LIBGEN"
+ AC_SUBST([LIB_EACCESS])
])
diff --git a/m4/extensions.m4 b/m4/extensions.m4
index e79c9d21139..6fc2e300e0a 100644
--- a/m4/extensions.m4
+++ b/m4/extensions.m4
@@ -1,4 +1,4 @@
-# serial 22 -*- Autoconf -*-
+# serial 23 -*- Autoconf -*-
# Enable extensions on systems that normally disable them.
# Copyright (C) 2003, 2006-2024 Free Software Foundation, Inc.
@@ -31,7 +31,7 @@ m4_ifndef([AC_CHECK_INCLUDES_DEFAULT],
# its dependencies. This will ensure that the gl_USE_SYSTEM_EXTENSIONS
# invocation occurs in gl_EARLY, not in gl_INIT.
-m4_version_prereq([2.70.1], [], [
+m4_version_prereq([2.72], [], [
# AC_USE_SYSTEM_EXTENSIONS
# ------------------------
@@ -113,11 +113,15 @@ AH_VERBATIM([USE_SYSTEM_EXTENSIONS],
#ifndef __STDC_WANT_IEC_60559_DFP_EXT__
# undef __STDC_WANT_IEC_60559_DFP_EXT__
#endif
+/* Enable extensions specified by C23 Annex F. */
+#ifndef __STDC_WANT_IEC_60559_EXT__
+# undef __STDC_WANT_IEC_60559_EXT__
+#endif
/* Enable extensions specified by ISO/IEC TS 18661-4:2015. */
#ifndef __STDC_WANT_IEC_60559_FUNCS_EXT__
# undef __STDC_WANT_IEC_60559_FUNCS_EXT__
#endif
-/* Enable extensions specified by ISO/IEC TS 18661-3:2015. */
+/* Enable extensions specified by C23 Annex H and ISO/IEC TS 18661-3:2015. */
#ifndef __STDC_WANT_IEC_60559_TYPES_EXT__
# undef __STDC_WANT_IEC_60559_TYPES_EXT__
#endif
@@ -187,6 +191,7 @@ dnl it should only be defined when necessary.
AC_DEFINE([__STDC_WANT_IEC_60559_ATTRIBS_EXT__])
AC_DEFINE([__STDC_WANT_IEC_60559_BFP_EXT__])
AC_DEFINE([__STDC_WANT_IEC_60559_DFP_EXT__])
+ AC_DEFINE([__STDC_WANT_IEC_60559_EXT__])
AC_DEFINE([__STDC_WANT_IEC_60559_FUNCS_EXT__])
AC_DEFINE([__STDC_WANT_IEC_60559_TYPES_EXT__])
AC_DEFINE([__STDC_WANT_LIB_EXT2__])
diff --git a/m4/extern-inline.m4 b/m4/extern-inline.m4
index 009c6a221ad..680250ec774 100644
--- a/m4/extern-inline.m4
+++ b/m4/extern-inline.m4
@@ -79,7 +79,8 @@ AC_DEFUN([gl_EXTERN_INLINE],
# define _GL_EXTERN_INLINE_STDHEADER_BUG
#endif
#if ((__GNUC__ \
- ? defined __GNUC_STDC_INLINE__ && __GNUC_STDC_INLINE__ \
+ ? (defined __GNUC_STDC_INLINE__ && __GNUC_STDC_INLINE__ \
+ && !defined __PCC__) \
: (199901L <= __STDC_VERSION__ \
&& !defined __HP_cc \
&& !defined __PGI \
@@ -89,6 +90,7 @@ AC_DEFUN([gl_EXTERN_INLINE],
# define _GL_EXTERN_INLINE extern inline
# define _GL_EXTERN_INLINE_IN_USE
#elif (2 < __GNUC__ + (7 <= __GNUC_MINOR__) && !defined __STRICT_ANSI__ \
+ && !defined __PCC__ \
&& !defined _GL_EXTERN_INLINE_STDHEADER_BUG)
# if defined __GNUC_GNU_INLINE__ && __GNUC_GNU_INLINE__
/* __gnu_inline__ suppresses a GCC 4.2 diagnostic. */
diff --git a/m4/faccessat.m4 b/m4/faccessat.m4
index 7240e5d3850..b8c058cef28 100644
--- a/m4/faccessat.m4
+++ b/m4/faccessat.m4
@@ -1,4 +1,4 @@
-# serial 10
+# serial 12
# See if we need to provide faccessat replacement.
dnl Copyright (C) 2009-2024 Free Software Foundation, Inc.
@@ -16,9 +16,12 @@ AC_DEFUN([gl_FUNC_FACCESSAT],
dnl Persuade glibc <unistd.h> to declare faccessat().
AC_REQUIRE([gl_USE_SYSTEM_EXTENSIONS])
- AC_CHECK_FUNCS_ONCE([faccessat])
+ gl_CHECK_FUNCS_ANDROID([faccessat], [[#include <unistd.h>]])
if test $ac_cv_func_faccessat = no; then
HAVE_FACCESSAT=0
+ case "$gl_cv_onwards_func_faccessat" in
+ future*) REPLACE_FACCESSAT=1 ;;
+ esac
else
case $gl_cv_func_lstat_dereferences_slashed_symlink in
*yes) ;;
diff --git a/m4/fchmodat.m4 b/m4/fchmodat.m4
index abb8a797c1a..9750572a5a3 100644
--- a/m4/fchmodat.m4
+++ b/m4/fchmodat.m4
@@ -1,4 +1,4 @@
-# fchmodat.m4 serial 7
+# fchmodat.m4 serial 8
dnl Copyright (C) 2004-2024 Free Software Foundation, Inc.
dnl This file is free software; the Free Software Foundation
dnl gives unlimited permission to copy and/or distribute it,
@@ -97,6 +97,6 @@ AC_DEFUN([gl_FUNC_FCHMODAT],
# Prerequisites of lib/fchmodat.c.
AC_DEFUN([gl_PREREQ_FCHMODAT],
[
- AC_CHECK_FUNCS_ONCE([readlinkat])
+ gl_CHECK_FUNCS_ANDROID([readlinkat], [[#include <unistd.h>]])
:
])
diff --git a/m4/fdopendir.m4 b/m4/fdopendir.m4
index 5f2a2e2b523..bf361ff154c 100644
--- a/m4/fdopendir.m4
+++ b/m4/fdopendir.m4
@@ -1,4 +1,4 @@
-# serial 14
+# serial 15
# See if we need to provide fdopendir.
dnl Copyright (C) 2009-2024 Free Software Foundation, Inc.
@@ -49,12 +49,12 @@ DIR *fdopendir (int);
[gl_cv_func_fdopendir_works=yes],
[gl_cv_func_fdopendir_works=no],
[case "$host_os" in
- # Guess yes on glibc systems.
- *-gnu*) gl_cv_func_fdopendir_works="guessing yes" ;;
- # Guess yes on musl systems.
- *-musl*) gl_cv_func_fdopendir_works="guessing yes" ;;
- # If we don't know, obey --enable-cross-guesses.
- *) gl_cv_func_fdopendir_works="$gl_cross_guess_normal" ;;
+ # Guess yes on glibc systems.
+ *-gnu*) gl_cv_func_fdopendir_works="guessing yes" ;;
+ # Guess yes on musl systems.
+ *-musl* | midipix*) gl_cv_func_fdopendir_works="guessing yes" ;;
+ # If we don't know, obey --enable-cross-guesses.
+ *) gl_cv_func_fdopendir_works="$gl_cross_guess_normal" ;;
esac
])])
case "$gl_cv_func_fdopendir_works" in
diff --git a/m4/filemode.m4 b/m4/filemode.m4
index 3dd40f44b8b..b72317281b3 100644
--- a/m4/filemode.m4
+++ b/m4/filemode.m4
@@ -1,6 +1,5 @@
# filemode.m4 serial 9
-dnl Copyright (C) 2002, 2005-2006, 2009-2024 Free Software Foundation,
-dnl Inc.
+dnl Copyright (C) 2002, 2005-2006, 2009-2024 Free Software Foundation, Inc.
dnl This file is free software; the Free Software Foundation
dnl gives unlimited permission to copy and/or distribute it,
dnl with or without modifications, as long as this notice is preserved.
diff --git a/m4/fstatat.m4 b/m4/fstatat.m4
index 1b5e5f19276..c22569b7961 100644
--- a/m4/fstatat.m4
+++ b/m4/fstatat.m4
@@ -1,4 +1,4 @@
-# fstatat.m4 serial 4
+# fstatat.m4 serial 5
dnl Copyright (C) 2004-2024 Free Software Foundation, Inc.
dnl This file is free software; the Free Software Foundation
dnl gives unlimited permission to copy and/or distribute it,
@@ -50,7 +50,7 @@ AC_DEFUN([gl_FUNC_FSTATAT],
esac
case $host_os in
- solaris*)
+ darwin* | solaris*)
REPLACE_FSTATAT=1 ;;
esac
diff --git a/m4/fsusage.m4 b/m4/fsusage.m4
index c1fd69d24f6..31d424c857d 100644
--- a/m4/fsusage.m4
+++ b/m4/fsusage.m4
@@ -1,8 +1,7 @@
# serial 35
# Obtaining file system usage information.
-# Copyright (C) 1997-1998, 2000-2001, 2003-2024 Free Software
-# Foundation, Inc.
+# Copyright (C) 1997-1998, 2000-2001, 2003-2024 Free Software Foundation, Inc.
#
# This file is free software; the Free Software Foundation
# gives unlimited permission to copy and/or distribute it,
@@ -270,7 +269,7 @@ int check_f_blocks_size[sizeof fsd.f_blocks * CHAR_BIT <= 32 ? -1 : 1];
# Check for SunOS statfs brokenness wrt partitions 2GB and larger.
# If <sys/vfs.h> exists and struct statfs has a member named f_spare,
-# enable the work-around code in fsusage.c.
+# enable the workaround code in fsusage.c.
AC_DEFUN([gl_STATFS_TRUNCATES],
[
AC_CACHE_CHECK([for statfs that truncates block counts],
diff --git a/m4/futimens.m4 b/m4/futimens.m4
index 62537deafa8..ac961e7bde5 100644
--- a/m4/futimens.m4
+++ b/m4/futimens.m4
@@ -1,4 +1,4 @@
-# serial 9
+# serial 11
# See if we need to provide futimens replacement.
dnl Copyright (C) 2009-2024 Free Software Foundation, Inc.
@@ -13,9 +13,12 @@ AC_DEFUN([gl_FUNC_FUTIMENS],
AC_REQUIRE([gl_SYS_STAT_H_DEFAULTS])
AC_REQUIRE([AC_CANONICAL_HOST]) dnl for cross-compiles
AC_REQUIRE([gl_USE_SYSTEM_EXTENSIONS])
- AC_CHECK_FUNCS_ONCE([futimens])
+ gl_CHECK_FUNCS_ANDROID([futimens], [[#include <sys/stat.h>]])
if test $ac_cv_func_futimens = no; then
HAVE_FUTIMENS=0
+ case "$gl_cv_onwards_func_futimens" in
+ future*) REPLACE_FUTIMENS=1 ;;
+ esac
else
AC_CACHE_CHECK([whether futimens works],
[gl_cv_func_futimens_works],
diff --git a/m4/getdelim.m4 b/m4/getdelim.m4
new file mode 100644
index 00000000000..0dbd8bc6f8b
--- /dev/null
+++ b/m4/getdelim.m4
@@ -0,0 +1,114 @@
+# getdelim.m4 serial 19
+
+dnl Copyright (C) 2005-2007, 2009-2024 Free Software Foundation, Inc.
+dnl
+dnl This file is free software; the Free Software Foundation
+dnl gives unlimited permission to copy and/or distribute it,
+dnl with or without modifications, as long as this notice is preserved.
+
+AC_PREREQ([2.59])
+
+AC_DEFUN([gl_FUNC_GETDELIM],
+[
+ AC_REQUIRE([gl_STDIO_H_DEFAULTS])
+ AC_REQUIRE([AC_CANONICAL_HOST])
+
+ dnl Persuade glibc <stdio.h> to declare getdelim().
+ AC_REQUIRE([AC_USE_SYSTEM_EXTENSIONS])
+
+ AC_CHECK_DECLS_ONCE([getdelim])
+
+ gl_CHECK_FUNCS_ANDROID([getdelim], [[#include <stdio.h>]])
+ if test $ac_cv_func_getdelim = yes; then
+ HAVE_GETDELIM=1
+ dnl Found it in some library. Verify that it works.
+ AC_CACHE_CHECK([for working getdelim function],
+ [gl_cv_func_working_getdelim],
+ [case "$host_os" in
+ darwin*)
+ dnl On macOS 10.13, valgrind detected an out-of-bounds read during
+ dnl the GNU sed test suite:
+ dnl Invalid read of size 16
+ dnl at 0x100EE6A05: _platform_memchr$VARIANT$Base (in /usr/lib/system/libsystem_platform.dylib)
+ dnl by 0x100B7B0BD: getdelim (in /usr/lib/system/libsystem_c.dylib)
+ dnl by 0x10000B0BE: ck_getdelim (utils.c:254)
+ gl_cv_func_working_getdelim=no ;;
+ *)
+ echo fooNbarN | tr -d '\012' | tr N '\012' > conftest.data
+ AC_RUN_IFELSE([AC_LANG_SOURCE([[
+# include <stdio.h>
+# include <stdlib.h>
+# include <string.h>
+ int main ()
+ {
+ FILE *in = fopen ("./conftest.data", "r");
+ if (!in)
+ return 1;
+ {
+ /* Test result for a NULL buffer and a zero size.
+ Based on a test program from Karl Heuer. */
+ char *line = NULL;
+ size_t siz = 0;
+ int len = getdelim (&line, &siz, '\n', in);
+ if (!(len == 4 && line && strcmp (line, "foo\n") == 0))
+ { free (line); fclose (in); return 2; }
+ free (line);
+ }
+ {
+ /* Test result for a NULL buffer and a non-zero size.
+ This crashes on FreeBSD 8.0. */
+ char *line = NULL;
+ size_t siz = (size_t)(~0) / 4;
+ if (getdelim (&line, &siz, '\n', in) == -1)
+ { fclose (in); return 3; }
+ free (line);
+ }
+ fclose (in);
+ return 0;
+ }
+ ]])],
+ [gl_cv_func_working_getdelim=yes],
+ [gl_cv_func_working_getdelim=no],
+ [dnl We're cross compiling.
+ dnl Guess it works on glibc2 systems and musl systems.
+ AC_EGREP_CPP([Lucky GNU user],
+ [
+#include <features.h>
+#ifdef __GNU_LIBRARY__
+ #if (__GLIBC__ >= 2) && !defined __UCLIBC__
+ Lucky GNU user
+ #endif
+#endif
+ ],
+ [gl_cv_func_working_getdelim="guessing yes"],
+ [case "$host_os" in
+ *-musl* | midipix*) gl_cv_func_working_getdelim="guessing yes" ;;
+ *) gl_cv_func_working_getdelim="$gl_cross_guess_normal" ;;
+ esac
+ ])
+ ])
+ ;;
+ esac
+ ])
+ case "$gl_cv_func_working_getdelim" in
+ *yes) ;;
+ *) REPLACE_GETDELIM=1 ;;
+ esac
+ else
+ HAVE_GETDELIM=0
+ case "$gl_cv_onwards_func_getdelim" in
+ future*) REPLACE_GETDELIM=1 ;;
+ esac
+ fi
+
+ if test $ac_cv_have_decl_getdelim = no; then
+ HAVE_DECL_GETDELIM=0
+ fi
+])
+
+# Prerequisites of lib/getdelim.c.
+AC_DEFUN([gl_PREREQ_GETDELIM],
+[
+ AC_CHECK_FUNCS([flockfile funlockfile])
+ AC_CHECK_DECLS([getc_unlocked])
+])
diff --git a/m4/getgroups.m4 b/m4/getgroups.m4
index 5062278b335..f6e0cbd3fce 100644
--- a/m4/getgroups.m4
+++ b/m4/getgroups.m4
@@ -1,10 +1,9 @@
-# serial 24
+# serial 25
dnl From Jim Meyering.
dnl A wrapper around AC_FUNC_GETGROUPS.
-# Copyright (C) 1996-1997, 1999-2004, 2008-2024 Free Software
-# Foundation, Inc.
+# Copyright (C) 1996-1997, 1999-2004, 2008-2024 Free Software Foundation, Inc.
#
# This file is free software; the Free Software Foundation
# gives unlimited permission to copy and/or distribute it,
@@ -21,7 +20,7 @@ AC_DEFUN([AC_FUNC_GETGROUPS],
# If we don't yet have getgroups, see if it's in -lbsd.
# This is reported to be necessary on an ITOS 3000WS running SEIUX 3.1.
- ac_save_LIBS=$LIBS
+ gl_saved_LIBS=$LIBS
if test $ac_cv_func_getgroups = no; then
AC_CHECK_LIB(bsd, getgroups, [GETGROUPS_LIB=-lbsd])
fi
@@ -57,7 +56,7 @@ AC_DEFUN([AC_FUNC_GETGROUPS],
[Define to 1 if your system has a working `getgroups' function.])
;;
esac
- LIBS=$ac_save_LIBS
+ LIBS=$gl_saved_LIBS
])# AC_FUNC_GETGROUPS
AC_DEFUN([gl_FUNC_GETGROUPS],
diff --git a/m4/getline.m4 b/m4/getline.m4
new file mode 100644
index 00000000000..1a7e89034bc
--- /dev/null
+++ b/m4/getline.m4
@@ -0,0 +1,111 @@
+# getline.m4 serial 33
+
+dnl Copyright (C) 1998-2003, 2005-2007, 2009-2024 Free Software Foundation,
+dnl Inc.
+dnl
+dnl This file is free software; the Free Software Foundation
+dnl gives unlimited permission to copy and/or distribute it,
+dnl with or without modifications, as long as this notice is preserved.
+
+AC_PREREQ([2.59])
+
+dnl See if there's a working, system-supplied version of the getline function.
+dnl We can't just do AC_REPLACE_FUNCS([getline]) because some systems
+dnl have a function by that name in -linet that doesn't have anything
+dnl to do with the function we need.
+AC_DEFUN([gl_FUNC_GETLINE],
+[
+ AC_REQUIRE([gl_STDIO_H_DEFAULTS])
+ AC_REQUIRE([AC_CANONICAL_HOST]) dnl for cross-compiles
+
+ dnl Persuade glibc <stdio.h> to declare getline().
+ AC_REQUIRE([AC_USE_SYSTEM_EXTENSIONS])
+
+ AC_CHECK_DECLS_ONCE([getline])
+
+ gl_CHECK_FUNCS_ANDROID([getline], [[#include <stdio.h>]])
+ if test $ac_cv_func_getline = yes; then
+ dnl Found it in some library. Verify that it works.
+ AC_CACHE_CHECK([for working getline function],
+ [am_cv_func_working_getline],
+ [echo fooNbarN | tr -d '\012' | tr N '\012' > conftest.data
+ AC_RUN_IFELSE([AC_LANG_SOURCE([[
+# include <stdio.h>
+# include <stdlib.h>
+# include <string.h>
+ int main ()
+ {
+ FILE *in = fopen ("./conftest.data", "r");
+ if (!in)
+ return 1;
+ {
+ /* Test result for a NULL buffer and a zero size.
+ Based on a test program from Karl Heuer. */
+ char *line = NULL;
+ size_t siz = 0;
+ int len = getline (&line, &siz, in);
+ if (!(len == 4 && line && strcmp (line, "foo\n") == 0))
+ { free (line); fclose (in); return 2; }
+ free (line);
+ }
+ {
+ /* Test result for a NULL buffer and a non-zero size.
+ This crashes on FreeBSD 8.0. */
+ char *line = NULL;
+ size_t siz = (size_t)(~0) / 4;
+ if (getline (&line, &siz, in) == -1)
+ { fclose (in); return 3; }
+ free (line);
+ }
+ fclose (in);
+ return 0;
+ }
+ ]])],
+ [am_cv_func_working_getline=yes],
+ [am_cv_func_working_getline=no],
+ [dnl We're cross compiling.
+ dnl Guess it works on glibc2 systems and musl systems.
+ AC_EGREP_CPP([Lucky GNU user],
+ [
+#include <features.h>
+#ifdef __GNU_LIBRARY__
+ #if (__GLIBC__ >= 2) && !defined __UCLIBC__
+ Lucky GNU user
+ #endif
+#endif
+ ],
+ [am_cv_func_working_getline="guessing yes"],
+ [case "$host_os" in
+ *-musl* | midipix*) am_cv_func_working_getline="guessing yes" ;;
+ *) am_cv_func_working_getline="$gl_cross_guess_normal" ;;
+ esac
+ ])
+ ])
+ ])
+ else
+ am_cv_func_working_getline=no
+ case "$gl_cv_onwards_func_getline" in
+ future*) REPLACE_GETLINE=1 ;;
+ esac
+ fi
+
+ if test $ac_cv_have_decl_getline = no; then
+ HAVE_DECL_GETLINE=0
+ fi
+
+ case "$am_cv_func_working_getline" in
+ *yes) ;;
+ *)
+ dnl Set REPLACE_GETLINE always: Even if we have not found the broken
+ dnl getline function among $LIBS, it may exist in libinet and the
+ dnl executable may be linked with -linet.
+ REPLACE_GETLINE=1
+ ;;
+ esac
+])
+
+# Prerequisites of lib/getline.c.
+AC_DEFUN([gl_PREREQ_GETLINE],
+[
+ :
+])
diff --git a/m4/getloadavg.m4 b/m4/getloadavg.m4
index 48c8d0df87a..9d0236f77fe 100644
--- a/m4/getloadavg.m4
+++ b/m4/getloadavg.m4
@@ -1,13 +1,13 @@
# Check for getloadavg.
-# Copyright (C) 1992-1996, 1999-2000, 2002-2003, 2006, 2008-2024 Free
-# Software Foundation, Inc.
+# Copyright (C) 1992-1996, 1999-2000, 2002-2003, 2006, 2008-2024 Free Software
+# Foundation, Inc.
# This file is free software; the Free Software Foundation
# gives unlimited permission to copy and/or distribute it,
# with or without modifications, as long as this notice is preserved.
-#serial 10
+#serial 13
# Autoconf defines AC_FUNC_GETLOADAVG, but that is obsolescent.
# New applications should use gl_GETLOADAVG instead.
@@ -20,13 +20,18 @@ AC_DEFUN([gl_GETLOADAVG],
# Persuade glibc <stdlib.h> to declare getloadavg().
AC_REQUIRE([AC_USE_SYSTEM_EXTENSIONS])
-gl_save_LIBS=$LIBS
+gl_saved_LIBS=$LIBS
# getloadavg is present in libc on glibc >= 2.2, Mac OS X, FreeBSD >= 2.0,
# NetBSD >= 0.9, OpenBSD >= 2.0, Solaris >= 7.
HAVE_GETLOADAVG=1
-AC_CHECK_FUNC([getloadavg], [],
- [gl_func_getloadavg_done=no
+gl_CHECK_FUNCS_ANDROID([getloadavg], [[#include <stdlib.h>]])
+if test $ac_cv_func_getloadavg != yes; then
+ case "$gl_cv_onwards_func_getloadavg" in
+ future*) REPLACE_GETLOADAVG=1 ;;
+ esac
+
+ gl_func_getloadavg_done=no
# Some systems with -lutil have (and need) -lkvm as well, some do not.
# On Solaris, -lkvm requires nlist from -lelf, so check that first
@@ -73,14 +78,15 @@ AC_CHECK_FUNC([getloadavg], [],
AC_DEFINE([DGUX], [1], [Define to 1 for DGUX with <sys/dg_sys_info.h>.])
AC_CHECK_LIB([dgc], [dg_sys_info])])
fi
- fi])
+ fi
+fi
-if test "x$gl_save_LIBS" = x; then
+if test "x$gl_saved_LIBS" = x; then
GETLOADAVG_LIBS=$LIBS
else
- GETLOADAVG_LIBS=`echo "$LIBS" | sed "s!$gl_save_LIBS!!"`
+ GETLOADAVG_LIBS=`echo "$LIBS" | sed "s!$gl_saved_LIBS!!"`
fi
-LIBS=$gl_save_LIBS
+LIBS=$gl_saved_LIBS
AC_SUBST([GETLOADAVG_LIBS])dnl
diff --git a/m4/getopt.m4 b/m4/getopt.m4
index cc0356390ba..be812d8459b 100644
--- a/m4/getopt.m4
+++ b/m4/getopt.m4
@@ -1,4 +1,4 @@
-# getopt.m4 serial 48
+# getopt.m4 serial 49
dnl Copyright (C) 2002-2006, 2008-2024 Free Software Foundation, Inc.
dnl This file is free software; the Free Software Foundation
dnl gives unlimited permission to copy and/or distribute it,
@@ -197,8 +197,8 @@ main ()
fi
else
case "$host_os" in
- darwin* | aix* | mingw*) gl_cv_func_getopt_posix="guessing no";;
- *) gl_cv_func_getopt_posix="guessing yes";;
+ darwin* | aix* | mingw* | windows*) gl_cv_func_getopt_posix="guessing no";;
+ *) gl_cv_func_getopt_posix="guessing yes";;
esac
fi
])
diff --git a/m4/getrandom.m4 b/m4/getrandom.m4
index 205ee8a6138..55be445c31a 100644
--- a/m4/getrandom.m4
+++ b/m4/getrandom.m4
@@ -1,4 +1,4 @@
-# getrandom.m4 serial 8
+# getrandom.m4 serial 13
dnl Copyright 2020-2024 Free Software Foundation, Inc.
dnl This file is free software; the Free Software Foundation
dnl gives unlimited permission to copy and/or distribute it,
@@ -9,9 +9,20 @@ dnl Written by Paul Eggert.
AC_DEFUN([gl_FUNC_GETRANDOM],
[
AC_REQUIRE([gl_SYS_RANDOM_H_DEFAULTS])
- AC_CHECK_FUNCS_ONCE([getrandom])
+ AC_REQUIRE([AC_CANONICAL_HOST])
+
+ gl_CHECK_FUNCS_ANDROID([getrandom],
+ [[/* Additional includes are needed before <sys/random.h> on uClibc
+ and Mac OS X. */
+ #include <sys/types.h>
+ #include <stdlib.h>
+ #include <sys/random.h>
+ ]])
if test "$ac_cv_func_getrandom" != yes; then
HAVE_GETRANDOM=0
+ case "$gl_cv_onwards_func_getrandom" in
+ future*) REPLACE_GETRANDOM=1 ;;
+ esac
else
dnl On Solaris 11.4 the return type is 'int', not 'ssize_t'.
AC_CACHE_CHECK([whether getrandom is compatible with its GNU+BSD signature],
@@ -36,7 +47,7 @@ AC_DEFUN([gl_FUNC_GETRANDOM],
fi
case "$host_os" in
- mingw*)
+ mingw* | windows*)
AC_CHECK_HEADERS([bcrypt.h], [], [],
[[#include <windows.h>
]])
@@ -56,13 +67,16 @@ AC_DEFUN([gl_FUNC_GETRANDOM],
if test $gl_cv_lib_assume_bcrypt = yes; then
AC_DEFINE([HAVE_LIB_BCRYPT], [1],
[Define to 1 if the bcrypt library is guaranteed to be present.])
- LIB_GETRANDOM='-lbcrypt'
+ GETRANDOM_LIB='-lbcrypt'
else
- LIB_GETRANDOM='-ladvapi32'
+ GETRANDOM_LIB='-ladvapi32'
fi
;;
*)
- LIB_GETRANDOM= ;;
+ GETRANDOM_LIB= ;;
esac
+ AC_SUBST([GETRANDOM_LIB])
+ dnl For backward compatibility.
+ LIB_GETRANDOM="$GETRANDOM_LIB"
AC_SUBST([LIB_GETRANDOM])
])
diff --git a/m4/gettime.m4 b/m4/gettime.m4
index 4b7af40b205..1ec018d5154 100644
--- a/m4/gettime.m4
+++ b/m4/gettime.m4
@@ -1,6 +1,5 @@
-# gettime.m4 serial 12
-dnl Copyright (C) 2002, 2004-2006, 2009-2024 Free Software Foundation,
-dnl Inc.
+# gettime.m4 serial 15
+dnl Copyright (C) 2002, 2004-2006, 2009-2024 Free Software Foundation, Inc.
dnl This file is free software; the Free Software Foundation
dnl gives unlimited permission to copy and/or distribute it,
dnl with or without modifications, as long as this notice is preserved.
@@ -19,25 +18,45 @@ AC_DEFUN([gl_GETTIME],
])
dnl Tests whether the function timespec_get exists.
-dnl Sets gl_cv_func_timespec_get.
+dnl Sets gl_cv_func_timespec_get and gl_cv_onwards_func_timespec_get.
AC_DEFUN([gl_CHECK_FUNC_TIMESPEC_GET],
[
+ AC_REQUIRE([AC_CANONICAL_HOST])
+
dnl Persuade OpenBSD <time.h> to declare timespec_get().
AC_REQUIRE([gl_USE_SYSTEM_EXTENSIONS])
dnl We can't use AC_CHECK_FUNC here, because timespec_get() is defined as a
dnl static inline function in <time.h> on MSVC 14.
- AC_CACHE_CHECK([for timespec_get], [gl_cv_func_timespec_get],
- [AC_LINK_IFELSE(
- [AC_LANG_PROGRAM(
- [[#include <time.h>
- struct timespec ts;
- ]],
- [[return timespec_get (&ts, 0);]])
- ],
- [gl_cv_func_timespec_get=yes],
- [gl_cv_func_timespec_get=no])
+ dnl But at the same time, we need to notice a missing declaration, like
+ dnl gl_CHECK_FUNCS_ANDROID does.
+ AC_CHECK_DECL([timespec_get], , , [[#include <time.h>]])
+ AC_CACHE_CHECK([for timespec_get], [gl_cv_onwards_func_timespec_get],
+ [if test $ac_cv_have_decl_timespec_get = yes; then
+ AC_LINK_IFELSE(
+ [AC_LANG_PROGRAM(
+ [[#include <time.h>
+ struct timespec ts;
+ ]],
+ [[return timespec_get (&ts, 0);]])
+ ],
+ [gl_cv_onwards_func_timespec_get=yes],
+ [gl_cv_onwards_func_timespec_get=no])
+ else
+ gl_cv_onwards_func_timespec_get=no
+ fi
+ case "$host_os" in
+ linux*-android*)
+ if test $gl_cv_onwards_func_timespec_get = no; then
+ gl_cv_onwards_func_timespec_get='future OS version'
+ fi
+ ;;
+ esac
])
+ case "$gl_cv_onwards_func_timespec_get" in
+ future*) gl_cv_func_timespec_get=no ;;
+ *) gl_cv_func_timespec_get=$gl_cv_onwards_func_timespec_get ;;
+ esac
])
AC_DEFUN([gl_GETTIME_RES],
@@ -45,5 +64,5 @@ AC_DEFUN([gl_GETTIME_RES],
dnl Prerequisites of lib/gettime-res.c.
AC_REQUIRE([gl_CLOCK_TIME])
AC_REQUIRE([gl_TIMESPEC])
- AC_CHECK_FUNCS_ONCE([timespec_getres])
+ gl_CHECK_FUNCS_ANDROID([timespec_getres], [[#include <time.h>]])
])
diff --git a/m4/gettimeofday.m4 b/m4/gettimeofday.m4
index 6c2f8583603..35269914ced 100644
--- a/m4/gettimeofday.m4
+++ b/m4/gettimeofday.m4
@@ -1,7 +1,6 @@
-# serial 29
+# serial 30
-# Copyright (C) 2001-2003, 2005, 2007, 2009-2024 Free Software
-# Foundation, Inc.
+# Copyright (C) 2001-2003, 2005, 2007, 2009-2024 Free Software Foundation, Inc.
# This file is free software; the Free Software Foundation
# gives unlimited permission to copy and/or distribute it,
# with or without modifications, as long as this notice is preserved.
@@ -58,7 +57,7 @@ int gettimeofday (struct timeval *restrict, struct timezone *restrict);
dnl On mingw, the original gettimeofday has only a precision of 15.6
dnl milliseconds. So override it.
case "$host_os" in
- mingw*) REPLACE_GETTIMEOFDAY=1 ;;
+ mingw* | windows*) REPLACE_GETTIMEOFDAY=1 ;;
esac
fi
AC_DEFINE_UNQUOTED([GETTIMEOFDAY_TIMEZONE], [$gl_gettimeofday_timezone],
diff --git a/m4/gnulib-common.m4 b/m4/gnulib-common.m4
index af9ab58012d..d8d0904f787 100644
--- a/m4/gnulib-common.m4
+++ b/m4/gnulib-common.m4
@@ -1,4 +1,4 @@
-# gnulib-common.m4 serial 74
+# gnulib-common.m4 serial 92
dnl Copyright (C) 2007-2024 Free Software Foundation, Inc.
dnl This file is free software; the Free Software Foundation
dnl gives unlimited permission to copy and/or distribute it,
@@ -15,6 +15,10 @@ AC_DEFUN([gl_COMMON], [
AC_REQUIRE([gl_ZZGNULIB])
])
AC_DEFUN([gl_COMMON_BODY], [
+ AH_VERBATIM([0witness],
+[/* Witness that <config.h> has been included. */
+#define _GL_CONFIG_H_INCLUDED 1
+])
AH_VERBATIM([_GL_GNUC_PREREQ],
[/* True if the compiler says it groks GNU C version MAJOR.MINOR. */
#if defined __GNUC__ && defined __GNUC_MINOR__
@@ -38,6 +42,11 @@ AC_DEFUN([gl_COMMON_BODY], [
AIX system header files and several gnulib header files use precisely
this syntax with 'extern'. */
# define _Noreturn [[noreturn]]
+# elif (defined __clang__ && __clang_major__ < 16 \
+ && defined _GL_WORK_AROUND_LLVM_BUG_59792)
+ /* Compile with -D_GL_WORK_AROUND_LLVM_BUG_59792 to work around
+ that rare LLVM bug, though you may get many false-alarm warnings. */
+# define _Noreturn
# elif ((!defined __cplusplus || defined __clang__) \
&& (201112 <= (defined __STDC_VERSION__ ? __STDC_VERSION__ : 0) \
|| (!defined __STRICT_ANSI__ \
@@ -67,54 +76,74 @@ AC_DEFUN([gl_COMMON_BODY], [
#endif])
AH_VERBATIM([attribute],
[/* Attributes. */
-#if (defined __has_attribute \
- && (!defined __clang_minor__ \
- || (defined __apple_build_version__ \
- ? 6000000 <= __apple_build_version__ \
- : 3 < __clang_major__ + (5 <= __clang_minor__))))
-# define _GL_HAS_ATTRIBUTE(attr) __has_attribute (__##attr##__)
-#else
-# define _GL_HAS_ATTRIBUTE(attr) _GL_ATTR_##attr
-# define _GL_ATTR_alloc_size _GL_GNUC_PREREQ (4, 3)
-# define _GL_ATTR_always_inline _GL_GNUC_PREREQ (3, 2)
-# define _GL_ATTR_artificial _GL_GNUC_PREREQ (4, 3)
-# define _GL_ATTR_cold _GL_GNUC_PREREQ (4, 3)
-# define _GL_ATTR_const _GL_GNUC_PREREQ (2, 95)
-# define _GL_ATTR_deprecated _GL_GNUC_PREREQ (3, 1)
-# define _GL_ATTR_diagnose_if 0
-# define _GL_ATTR_error _GL_GNUC_PREREQ (4, 3)
-# define _GL_ATTR_externally_visible _GL_GNUC_PREREQ (4, 1)
-# define _GL_ATTR_fallthrough _GL_GNUC_PREREQ (7, 0)
-# define _GL_ATTR_format _GL_GNUC_PREREQ (2, 7)
-# define _GL_ATTR_leaf _GL_GNUC_PREREQ (4, 6)
-# define _GL_ATTR_malloc _GL_GNUC_PREREQ (3, 0)
-# ifdef _ICC
-# define _GL_ATTR_may_alias 0
+/* Define _GL_HAS_ATTRIBUTE only once, because on FreeBSD, with gcc < 5, if
+ <config.h> gets included once again after <sys/cdefs.h>, __has_attribute(x)
+ expands to 0 always, and redefining _GL_HAS_ATTRIBUTE would turn off all
+ attributes. */
+#ifndef _GL_HAS_ATTRIBUTE
+# if (defined __has_attribute \
+ && (!defined __clang_minor__ \
+ || (defined __apple_build_version__ \
+ ? 7000000 <= __apple_build_version__ \
+ : 5 <= __clang_major__)))
+# define _GL_HAS_ATTRIBUTE(attr) __has_attribute (__##attr##__)
# else
-# define _GL_ATTR_may_alias _GL_GNUC_PREREQ (3, 3)
+# define _GL_HAS_ATTRIBUTE(attr) _GL_ATTR_##attr
+# define _GL_ATTR_alloc_size _GL_GNUC_PREREQ (4, 3)
+# define _GL_ATTR_always_inline _GL_GNUC_PREREQ (3, 2)
+# define _GL_ATTR_artificial _GL_GNUC_PREREQ (4, 3)
+# define _GL_ATTR_cold _GL_GNUC_PREREQ (4, 3)
+# define _GL_ATTR_const _GL_GNUC_PREREQ (2, 95)
+# define _GL_ATTR_deprecated _GL_GNUC_PREREQ (3, 1)
+# define _GL_ATTR_diagnose_if 0
+# define _GL_ATTR_error _GL_GNUC_PREREQ (4, 3)
+# define _GL_ATTR_externally_visible _GL_GNUC_PREREQ (4, 1)
+# define _GL_ATTR_fallthrough _GL_GNUC_PREREQ (7, 0)
+# define _GL_ATTR_format _GL_GNUC_PREREQ (2, 7)
+# define _GL_ATTR_leaf _GL_GNUC_PREREQ (4, 6)
+# define _GL_ATTR_malloc _GL_GNUC_PREREQ (3, 0)
+# ifdef _ICC
+# define _GL_ATTR_may_alias 0
+# else
+# define _GL_ATTR_may_alias _GL_GNUC_PREREQ (3, 3)
+# endif
+# define _GL_ATTR_noinline _GL_GNUC_PREREQ (3, 1)
+# define _GL_ATTR_nonnull _GL_GNUC_PREREQ (3, 3)
+# define _GL_ATTR_nonstring _GL_GNUC_PREREQ (8, 0)
+# define _GL_ATTR_nothrow _GL_GNUC_PREREQ (3, 3)
+# define _GL_ATTR_packed _GL_GNUC_PREREQ (2, 7)
+# define _GL_ATTR_pure _GL_GNUC_PREREQ (2, 96)
+# define _GL_ATTR_returns_nonnull _GL_GNUC_PREREQ (4, 9)
+# define _GL_ATTR_sentinel _GL_GNUC_PREREQ (4, 0)
+# define _GL_ATTR_unused _GL_GNUC_PREREQ (2, 7)
+# define _GL_ATTR_warn_unused_result _GL_GNUC_PREREQ (3, 4)
# endif
-# define _GL_ATTR_noinline _GL_GNUC_PREREQ (3, 1)
-# define _GL_ATTR_nonnull _GL_GNUC_PREREQ (3, 3)
-# define _GL_ATTR_nonstring _GL_GNUC_PREREQ (8, 0)
-# define _GL_ATTR_nothrow _GL_GNUC_PREREQ (3, 3)
-# define _GL_ATTR_packed _GL_GNUC_PREREQ (2, 7)
-# define _GL_ATTR_pure _GL_GNUC_PREREQ (2, 96)
-# define _GL_ATTR_returns_nonnull _GL_GNUC_PREREQ (4, 9)
-# define _GL_ATTR_sentinel _GL_GNUC_PREREQ (4, 0)
-# define _GL_ATTR_unused _GL_GNUC_PREREQ (2, 7)
-# define _GL_ATTR_warn_unused_result _GL_GNUC_PREREQ (3, 4)
#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##__)
+/* Use __has_c_attribute if available. However, do not use with
+ pre-C23 GCC, which can issue false positives if -Wpedantic. */
+#if (defined __has_c_attribute \
+ && ! (_GL_GNUC_PREREQ (4, 6) \
+ && (defined __STDC_VERSION__ ? __STDC_VERSION__ : 0) <= 201710))
+# define _GL_HAVE___HAS_C_ATTRIBUTE 1
#else
-# define _GL_HAS_C_ATTRIBUTE(attr) 0
+# define _GL_HAVE___HAS_C_ATTRIBUTE 0
#endif
+/* Define if, in a function declaration, the attributes in bracket syntax
+ [[...]] must come before the attributes in __attribute__((...)) syntax.
+ If this is defined, it is best to avoid the bracket syntax, so that the
+ various _GL_ATTRIBUTE_* can be cumulated on the same declaration in any
+ order. */
+#ifdef __cplusplus
+# if defined __clang__
+# define _GL_BRACKET_BEFORE_ATTRIBUTE 1
+# endif
+#else
+# if defined __GNUC__ && !defined __clang__
+# define _GL_BRACKET_BEFORE_ATTRIBUTE 1
+# endif
+#endif
]dnl There is no _GL_ATTRIBUTE_ALIGNED; use stdalign's alignas instead.
[
/* _GL_ATTRIBUTE_ALLOC_SIZE ((N)) declares that the Nth argument of the function
@@ -123,29 +152,35 @@ AC_DEFUN([gl_COMMON_BODY], [
by the Nth argument of the function is the size of the returned memory block.
*/
/* Applies to: function, pointer to function, function types. */
-#if _GL_HAS_ATTRIBUTE (alloc_size)
-# define _GL_ATTRIBUTE_ALLOC_SIZE(args) __attribute__ ((__alloc_size__ args))
-#else
-# define _GL_ATTRIBUTE_ALLOC_SIZE(args)
+#ifndef _GL_ATTRIBUTE_ALLOC_SIZE
+# if _GL_HAS_ATTRIBUTE (alloc_size)
+# define _GL_ATTRIBUTE_ALLOC_SIZE(args) __attribute__ ((__alloc_size__ args))
+# else
+# define _GL_ATTRIBUTE_ALLOC_SIZE(args)
+# endif
#endif
/* _GL_ATTRIBUTE_ALWAYS_INLINE tells that the compiler should always inline the
function and report an error if it cannot do so. */
/* Applies to: function. */
-#if _GL_HAS_ATTRIBUTE (always_inline)
-# define _GL_ATTRIBUTE_ALWAYS_INLINE __attribute__ ((__always_inline__))
-#else
-# define _GL_ATTRIBUTE_ALWAYS_INLINE
+#ifndef _GL_ATTRIBUTE_ALWAYS_INLINE
+# if _GL_HAS_ATTRIBUTE (always_inline)
+# define _GL_ATTRIBUTE_ALWAYS_INLINE __attribute__ ((__always_inline__))
+# else
+# define _GL_ATTRIBUTE_ALWAYS_INLINE
+# endif
#endif
/* _GL_ATTRIBUTE_ARTIFICIAL declares that the function is not important to show
in stack traces when debugging. The compiler should omit the function from
stack traces. */
/* Applies to: function. */
-#if _GL_HAS_ATTRIBUTE (artificial)
-# define _GL_ATTRIBUTE_ARTIFICIAL __attribute__ ((__artificial__))
-#else
-# define _GL_ATTRIBUTE_ARTIFICIAL
+#ifndef _GL_ATTRIBUTE_ARTIFICIAL
+# if _GL_HAS_ATTRIBUTE (artificial)
+# define _GL_ATTRIBUTE_ARTIFICIAL __attribute__ ((__artificial__))
+# else
+# define _GL_ATTRIBUTE_ARTIFICIAL
+# endif
#endif
/* _GL_ATTRIBUTE_COLD declares that the function is rarely executed. */
@@ -153,14 +188,16 @@ AC_DEFUN([gl_COMMON_BODY], [
/* Avoid __attribute__ ((cold)) on MinGW; see thread starting at
<https://lists.gnu.org/r/emacs-devel/2019-04/msg01152.html>.
Also, Oracle Studio 12.6 requires 'cold' not '__cold__'. */
-#if _GL_HAS_ATTRIBUTE (cold) && !defined __MINGW32__
-# ifndef __SUNPRO_C
-# define _GL_ATTRIBUTE_COLD __attribute__ ((__cold__))
+#ifndef _GL_ATTRIBUTE_COLD
+# if _GL_HAS_ATTRIBUTE (cold) && !defined __MINGW32__
+# ifndef __SUNPRO_C
+# define _GL_ATTRIBUTE_COLD __attribute__ ((__cold__))
+# else
+# define _GL_ATTRIBUTE_COLD __attribute__ ((cold))
+# endif
# else
-# define _GL_ATTRIBUTE_COLD __attribute__ ((cold))
+# define _GL_ATTRIBUTE_COLD
# endif
-#else
-# define _GL_ATTRIBUTE_COLD
#endif
/* _GL_ATTRIBUTE_CONST declares that it is OK for a compiler to omit duplicate
@@ -170,10 +207,12 @@ AC_DEFUN([gl_COMMON_BODY], [
forever, and does not call longjmp.
(This attribute is stricter than _GL_ATTRIBUTE_PURE.) */
/* Applies to: functions. */
-#if _GL_HAS_ATTRIBUTE (const)
-# define _GL_ATTRIBUTE_CONST __attribute__ ((__const__))
-#else
-# define _GL_ATTRIBUTE_CONST
+#ifndef _GL_ATTRIBUTE_CONST
+# if _GL_HAS_ATTRIBUTE (const)
+# define _GL_ATTRIBUTE_CONST __attribute__ ((__const__))
+# else
+# define _GL_ATTRIBUTE_CONST
+# endif
#endif
/* _GL_ATTRIBUTE_DEALLOC (F, I) declares that the function returns pointers
@@ -182,16 +221,25 @@ AC_DEFUN([gl_COMMON_BODY], [
_GL_ATTRIBUTE_DEALLOC_FREE declares that the function returns pointers that
can be freed via 'free'; it can be used only after declaring 'free'. */
/* Applies to: functions. Cannot be used on inline functions. */
-#if _GL_GNUC_PREREQ (11, 0)
-# define _GL_ATTRIBUTE_DEALLOC(f, i) __attribute__ ((__malloc__ (f, i)))
-#else
-# define _GL_ATTRIBUTE_DEALLOC(f, i)
+#ifndef _GL_ATTRIBUTE_DEALLOC
+# if _GL_GNUC_PREREQ (11, 0)
+# define _GL_ATTRIBUTE_DEALLOC(f, i) __attribute__ ((__malloc__ (f, i)))
+# else
+# define _GL_ATTRIBUTE_DEALLOC(f, i)
+# endif
#endif
/* If gnulib's <string.h> or <wchar.h> has already defined this macro, continue
to use this earlier definition, since <stdlib.h> may not have been included
yet. */
#ifndef _GL_ATTRIBUTE_DEALLOC_FREE
-# define _GL_ATTRIBUTE_DEALLOC_FREE _GL_ATTRIBUTE_DEALLOC (free, 1)
+# if defined __cplusplus && defined __GNUC__ && !defined __clang__
+/* Work around GCC bug <https://gcc.gnu.org/bugzilla/show_bug.cgi?id=108231> */
+# define _GL_ATTRIBUTE_DEALLOC_FREE \
+ _GL_ATTRIBUTE_DEALLOC ((void (*) (void *)) free, 1)
+# else
+# define _GL_ATTRIBUTE_DEALLOC_FREE \
+ _GL_ATTRIBUTE_DEALLOC (free, 1)
+# endif
#endif
/* _GL_ATTRIBUTE_DEPRECATED: Declares that an entity is deprecated.
@@ -202,12 +250,20 @@ AC_DEFUN([gl_COMMON_BODY], [
- enumeration, enumeration item,
- typedef,
in C++ also: namespace, class, template specialization. */
-#if _GL_HAS_C_ATTRIBUTE (deprecated)
-# define _GL_ATTRIBUTE_DEPRECATED [[__deprecated__]]
-#elif _GL_HAS_ATTRIBUTE (deprecated)
-# define _GL_ATTRIBUTE_DEPRECATED __attribute__ ((__deprecated__))
-#else
-# define _GL_ATTRIBUTE_DEPRECATED
+#ifndef _GL_ATTRIBUTE_DEPRECATED
+# ifndef _GL_BRACKET_BEFORE_ATTRIBUTE
+# if _GL_HAVE___HAS_C_ATTRIBUTE
+# if __has_c_attribute (__deprecated__)
+# define _GL_ATTRIBUTE_DEPRECATED [[__deprecated__]]
+# endif
+# endif
+# endif
+# if !defined _GL_ATTRIBUTE_DEPRECATED && _GL_HAS_ATTRIBUTE (deprecated)
+# define _GL_ATTRIBUTE_DEPRECATED __attribute__ ((__deprecated__))
+# endif
+# ifndef _GL_ATTRIBUTE_DEPRECATED
+# define _GL_ATTRIBUTE_DEPRECATED
+# endif
#endif
/* _GL_ATTRIBUTE_ERROR(msg) requests an error if a function is called and
@@ -215,24 +271,28 @@ AC_DEFUN([gl_COMMON_BODY], [
_GL_ATTRIBUTE_WARNING(msg) requests a warning if a function is called and
the function call is not optimized away. */
/* Applies to: functions. */
-#if _GL_HAS_ATTRIBUTE (error)
-# define _GL_ATTRIBUTE_ERROR(msg) __attribute__ ((__error__ (msg)))
-# define _GL_ATTRIBUTE_WARNING(msg) __attribute__ ((__warning__ (msg)))
-#elif _GL_HAS_ATTRIBUTE (diagnose_if)
-# define _GL_ATTRIBUTE_ERROR(msg) __attribute__ ((__diagnose_if__ (1, msg, "error")))
-# define _GL_ATTRIBUTE_WARNING(msg) __attribute__ ((__diagnose_if__ (1, msg, "warning")))
-#else
-# define _GL_ATTRIBUTE_ERROR(msg)
-# define _GL_ATTRIBUTE_WARNING(msg)
+#if !(defined _GL_ATTRIBUTE_ERROR && defined _GL_ATTRIBUTE_WARNING)
+# if _GL_HAS_ATTRIBUTE (error)
+# define _GL_ATTRIBUTE_ERROR(msg) __attribute__ ((__error__ (msg)))
+# define _GL_ATTRIBUTE_WARNING(msg) __attribute__ ((__warning__ (msg)))
+# elif _GL_HAS_ATTRIBUTE (diagnose_if)
+# define _GL_ATTRIBUTE_ERROR(msg) __attribute__ ((__diagnose_if__ (1, msg, "error")))
+# define _GL_ATTRIBUTE_WARNING(msg) __attribute__ ((__diagnose_if__ (1, msg, "warning")))
+# else
+# define _GL_ATTRIBUTE_ERROR(msg)
+# define _GL_ATTRIBUTE_WARNING(msg)
+# endif
#endif
/* _GL_ATTRIBUTE_EXTERNALLY_VISIBLE declares that the entity should remain
visible to debuggers etc., even with '-fwhole-program'. */
/* Applies to: functions, variables. */
-#if _GL_HAS_ATTRIBUTE (externally_visible)
-# define _GL_ATTRIBUTE_EXTERNALLY_VISIBLE __attribute__ ((externally_visible))
-#else
-# define _GL_ATTRIBUTE_EXTERNALLY_VISIBLE
+#ifndef _GL_ATTRIBUTE_EXTERNALLY_VISIBLE
+# if _GL_HAS_ATTRIBUTE (externally_visible)
+# define _GL_ATTRIBUTE_EXTERNALLY_VISIBLE __attribute__ ((externally_visible))
+# else
+# define _GL_ATTRIBUTE_EXTERNALLY_VISIBLE
+# endif
#endif
/* _GL_ATTRIBUTE_FALLTHROUGH declares that it is not a programming mistake if
@@ -240,12 +300,18 @@ AC_DEFUN([gl_COMMON_BODY], [
'default' label. The compiler should not warn in this case. */
/* Applies to: Empty statement (;), inside a 'switch' statement. */
/* Always expands to something. */
-#if _GL_HAS_C_ATTRIBUTE (fallthrough)
-# define _GL_ATTRIBUTE_FALLTHROUGH [[__fallthrough__]]
-#elif _GL_HAS_ATTRIBUTE (fallthrough)
-# define _GL_ATTRIBUTE_FALLTHROUGH __attribute__ ((__fallthrough__))
-#else
-# define _GL_ATTRIBUTE_FALLTHROUGH ((void) 0)
+#ifndef _GL_ATTRIBUTE_FALLTHROUGH
+# if _GL_HAVE___HAS_C_ATTRIBUTE
+# if __has_c_attribute (__fallthrough__)
+# define _GL_ATTRIBUTE_FALLTHROUGH [[__fallthrough__]]
+# endif
+# endif
+# if !defined _GL_ATTRIBUTE_FALLTHROUGH && _GL_HAS_ATTRIBUTE (fallthrough)
+# define _GL_ATTRIBUTE_FALLTHROUGH __attribute__ ((__fallthrough__))
+# endif
+# ifndef _GL_ATTRIBUTE_FALLTHROUGH
+# define _GL_ATTRIBUTE_FALLTHROUGH ((void) 0)
+# endif
#endif
/* _GL_ATTRIBUTE_FORMAT ((ARCHETYPE, STRING-INDEX, FIRST-TO-CHECK))
@@ -259,10 +325,12 @@ AC_DEFUN([gl_COMMON_BODY], [
If FIRST-TO-CHECK is not 0, arguments starting at FIRST-TO_CHECK
are suitable for the format string. */
/* Applies to: functions. */
-#if _GL_HAS_ATTRIBUTE (format)
-# define _GL_ATTRIBUTE_FORMAT(spec) __attribute__ ((__format__ spec))
-#else
-# define _GL_ATTRIBUTE_FORMAT(spec)
+#ifndef _GL_ATTRIBUTE_FORMAT
+# if _GL_HAS_ATTRIBUTE (format)
+# define _GL_ATTRIBUTE_FORMAT(spec) __attribute__ ((__format__ spec))
+# else
+# define _GL_ATTRIBUTE_FORMAT(spec)
+# endif
#endif
/* _GL_ATTRIBUTE_LEAF declares that if the function is called from some other
@@ -270,19 +338,23 @@ AC_DEFUN([gl_COMMON_BODY], [
exception handling. This declaration lets the compiler optimize that unit
more aggressively. */
/* Applies to: functions. */
-#if _GL_HAS_ATTRIBUTE (leaf)
-# define _GL_ATTRIBUTE_LEAF __attribute__ ((__leaf__))
-#else
-# define _GL_ATTRIBUTE_LEAF
+#ifndef _GL_ATTRIBUTE_LEAF
+# if _GL_HAS_ATTRIBUTE (leaf)
+# define _GL_ATTRIBUTE_LEAF __attribute__ ((__leaf__))
+# else
+# define _GL_ATTRIBUTE_LEAF
+# endif
#endif
/* _GL_ATTRIBUTE_MALLOC declares that the function returns a pointer to freshly
allocated memory. */
/* Applies to: functions. */
-#if _GL_HAS_ATTRIBUTE (malloc)
-# define _GL_ATTRIBUTE_MALLOC __attribute__ ((__malloc__))
-#else
-# define _GL_ATTRIBUTE_MALLOC
+#ifndef _GL_ATTRIBUTE_MALLOC
+# if _GL_HAS_ATTRIBUTE (malloc)
+# define _GL_ATTRIBUTE_MALLOC __attribute__ ((__malloc__))
+# else
+# define _GL_ATTRIBUTE_MALLOC
+# endif
#endif
/* _GL_ATTRIBUTE_MAY_ALIAS declares that pointers to the type may point to the
@@ -290,10 +362,12 @@ AC_DEFUN([gl_COMMON_BODY], [
strict aliasing optimization. */
/* Applies to: types. */
/* Oracle Studio 12.6 mishandles may_alias despite __has_attribute OK. */
-#if _GL_HAS_ATTRIBUTE (may_alias) && !defined __SUNPRO_C
-# define _GL_ATTRIBUTE_MAY_ALIAS __attribute__ ((__may_alias__))
-#else
-# define _GL_ATTRIBUTE_MAY_ALIAS
+#ifndef _GL_ATTRIBUTE_MAY_ALIAS
+# if _GL_HAS_ATTRIBUTE (may_alias) && !defined __SUNPRO_C
+# define _GL_ATTRIBUTE_MAY_ALIAS __attribute__ ((__may_alias__))
+# else
+# define _GL_ATTRIBUTE_MAY_ALIAS
+# endif
#endif
/* _GL_ATTRIBUTE_MAYBE_UNUSED declares that it is not a programming mistake if
@@ -305,13 +379,26 @@ AC_DEFUN([gl_COMMON_BODY], [
- enumeration, enumeration item,
- typedef,
in C++ also: class. */
-/* In C++ and C2x, this is spelled [[__maybe_unused__]].
+/* In C++ and C23, this is spelled [[__maybe_unused__]].
GCC's syntax is __attribute__ ((__unused__)).
- clang supports both syntaxes. */
-#if _GL_HAS_C_ATTRIBUTE (maybe_unused)
-# define _GL_ATTRIBUTE_MAYBE_UNUSED [[__maybe_unused__]]
-#else
-# define _GL_ATTRIBUTE_MAYBE_UNUSED _GL_ATTRIBUTE_UNUSED
+ clang supports both syntaxes. Except that with clang ≥ 6, < 10, in C++ mode,
+ __has_c_attribute (__maybe_unused__) yields true but the use of
+ [[__maybe_unused__]] nevertheless produces a warning. */
+#ifndef _GL_ATTRIBUTE_MAYBE_UNUSED
+# ifndef _GL_BRACKET_BEFORE_ATTRIBUTE
+# if defined __clang__ && defined __cplusplus
+# if !defined __apple_build_version__ && __clang_major__ >= 10
+# define _GL_ATTRIBUTE_MAYBE_UNUSED [[__maybe_unused__]]
+# endif
+# elif _GL_HAVE___HAS_C_ATTRIBUTE
+# if __has_c_attribute (__maybe_unused__)
+# define _GL_ATTRIBUTE_MAYBE_UNUSED [[__maybe_unused__]]
+# endif
+# endif
+# endif
+# ifndef _GL_ATTRIBUTE_MAYBE_UNUSED
+# define _GL_ATTRIBUTE_MAYBE_UNUSED _GL_ATTRIBUTE_UNUSED
+# endif
#endif
/* Alternative spelling of this macro, for convenience and for
compatibility with glibc/include/libc-symbols.h. */
@@ -323,21 +410,40 @@ AC_DEFUN([gl_COMMON_BODY], [
discard the return value. The compiler may warn if the caller does not use
the return value, unless the caller uses something like ignore_value. */
/* Applies to: function, enumeration, class. */
-#if _GL_HAS_C_ATTRIBUTE (nodiscard)
-# define _GL_ATTRIBUTE_NODISCARD [[__nodiscard__]]
-#elif _GL_HAS_ATTRIBUTE (warn_unused_result)
-# define _GL_ATTRIBUTE_NODISCARD __attribute__ ((__warn_unused_result__))
-#else
-# define _GL_ATTRIBUTE_NODISCARD
+#ifndef _GL_ATTRIBUTE_NODISCARD
+# ifndef _GL_BRACKET_BEFORE_ATTRIBUTE
+# if defined __clang__ && defined __cplusplus
+ /* With clang up to 15.0.6 (at least), in C++ mode, [[__nodiscard__]] produces
+ a warning.
+ The 1000 below means a yet unknown threshold. When clang++ version X
+ starts supporting [[__nodiscard__]] without warning about it, you can
+ replace the 1000 with X. */
+# if __clang_major__ >= 1000
+# define _GL_ATTRIBUTE_NODISCARD [[__nodiscard__]]
+# endif
+# elif _GL_HAVE___HAS_C_ATTRIBUTE
+# if __has_c_attribute (__nodiscard__)
+# define _GL_ATTRIBUTE_NODISCARD [[__nodiscard__]]
+# endif
+# endif
+# endif
+# if !defined _GL_ATTRIBUTE_NODISCARD && _GL_HAS_ATTRIBUTE (warn_unused_result)
+# define _GL_ATTRIBUTE_NODISCARD __attribute__ ((__warn_unused_result__))
+# endif
+# ifndef _GL_ATTRIBUTE_NODISCARD
+# define _GL_ATTRIBUTE_NODISCARD
+# endif
#endif
/* _GL_ATTRIBUTE_NOINLINE tells that the compiler should not inline the
function. */
/* Applies to: functions. */
-#if _GL_HAS_ATTRIBUTE (noinline)
-# define _GL_ATTRIBUTE_NOINLINE __attribute__ ((__noinline__))
-#else
-# define _GL_ATTRIBUTE_NOINLINE
+#ifndef _GL_ATTRIBUTE_NOINLINE
+# if _GL_HAS_ATTRIBUTE (noinline)
+# define _GL_ATTRIBUTE_NOINLINE __attribute__ ((__noinline__))
+# else
+# define _GL_ATTRIBUTE_NOINLINE
+# endif
#endif
/* _GL_ATTRIBUTE_NONNULL ((N1, N2,...)) declares that the arguments N1, N2,...
@@ -345,20 +451,24 @@ AC_DEFUN([gl_COMMON_BODY], [
_GL_ATTRIBUTE_NONNULL () declares that all pointer arguments must not be
null. */
/* Applies to: functions. */
-#if _GL_HAS_ATTRIBUTE (nonnull)
-# define _GL_ATTRIBUTE_NONNULL(args) __attribute__ ((__nonnull__ args))
-#else
-# define _GL_ATTRIBUTE_NONNULL(args)
+#ifndef _GL_ATTRIBUTE_NONNULL
+# if _GL_HAS_ATTRIBUTE (nonnull)
+# define _GL_ATTRIBUTE_NONNULL(args) __attribute__ ((__nonnull__ args))
+# else
+# define _GL_ATTRIBUTE_NONNULL(args)
+# endif
#endif
/* _GL_ATTRIBUTE_NONSTRING declares that the contents of a character array is
not meant to be NUL-terminated. */
/* Applies to: struct/union members and variables that are arrays of element
type '[[un]signed] char'. */
-#if _GL_HAS_ATTRIBUTE (nonstring)
-# define _GL_ATTRIBUTE_NONSTRING __attribute__ ((__nonstring__))
-#else
-# define _GL_ATTRIBUTE_NONSTRING
+#ifndef _GL_ATTRIBUTE_NONSTRING
+# if _GL_HAS_ATTRIBUTE (nonstring)
+# define _GL_ATTRIBUTE_NONSTRING __attribute__ ((__nonstring__))
+# else
+# define _GL_ATTRIBUTE_NONSTRING
+# endif
#endif
/* There is no _GL_ATTRIBUTE_NORETURN; use _Noreturn instead. */
@@ -366,10 +476,26 @@ AC_DEFUN([gl_COMMON_BODY], [
/* _GL_ATTRIBUTE_NOTHROW declares that the function does not throw exceptions.
*/
/* Applies to: functions. */
-#if _GL_HAS_ATTRIBUTE (nothrow) && !defined __cplusplus
-# define _GL_ATTRIBUTE_NOTHROW __attribute__ ((__nothrow__))
-#else
-# define _GL_ATTRIBUTE_NOTHROW
+/* After a function's parameter list, this attribute must come first, before
+ other attributes. */
+#ifndef _GL_ATTRIBUTE_NOTHROW
+# if defined __cplusplus
+# if _GL_GNUC_PREREQ (2, 8) || __clang_major >= 4
+# if __cplusplus >= 201103L
+# define _GL_ATTRIBUTE_NOTHROW noexcept (true)
+# else
+# define _GL_ATTRIBUTE_NOTHROW throw ()
+# endif
+# else
+# define _GL_ATTRIBUTE_NOTHROW
+# endif
+# else
+# if _GL_HAS_ATTRIBUTE (nothrow)
+# define _GL_ATTRIBUTE_NOTHROW __attribute__ ((__nothrow__))
+# else
+# define _GL_ATTRIBUTE_NOTHROW
+# endif
+# endif
#endif
/* _GL_ATTRIBUTE_PACKED declares:
@@ -378,10 +504,12 @@ AC_DEFUN([gl_COMMON_BODY], [
minimizing the memory required. */
/* Applies to: struct members, struct, union,
in C++ also: class. */
-#if _GL_HAS_ATTRIBUTE (packed)
-# define _GL_ATTRIBUTE_PACKED __attribute__ ((__packed__))
-#else
-# define _GL_ATTRIBUTE_PACKED
+#ifndef _GL_ATTRIBUTE_PACKED
+# if _GL_HAS_ATTRIBUTE (packed)
+# define _GL_ATTRIBUTE_PACKED __attribute__ ((__packed__))
+# else
+# define _GL_ATTRIBUTE_PACKED
+# endif
#endif
/* _GL_ATTRIBUTE_PURE declares that It is OK for a compiler to omit duplicate
@@ -391,19 +519,23 @@ AC_DEFUN([gl_COMMON_BODY], [
observable state, and always returns exactly once.
(This attribute is looser than _GL_ATTRIBUTE_CONST.) */
/* Applies to: functions. */
-#if _GL_HAS_ATTRIBUTE (pure)
-# define _GL_ATTRIBUTE_PURE __attribute__ ((__pure__))
-#else
-# define _GL_ATTRIBUTE_PURE
+#ifndef _GL_ATTRIBUTE_PURE
+# if _GL_HAS_ATTRIBUTE (pure)
+# define _GL_ATTRIBUTE_PURE __attribute__ ((__pure__))
+# else
+# define _GL_ATTRIBUTE_PURE
+# endif
#endif
/* _GL_ATTRIBUTE_RETURNS_NONNULL declares that the function's return value is
a non-NULL pointer. */
/* Applies to: functions. */
-#if _GL_HAS_ATTRIBUTE (returns_nonnull)
-# define _GL_ATTRIBUTE_RETURNS_NONNULL __attribute__ ((__returns_nonnull__))
-#else
-# define _GL_ATTRIBUTE_RETURNS_NONNULL
+#ifndef _GL_ATTRIBUTE_RETURNS_NONNULL
+# if _GL_HAS_ATTRIBUTE (returns_nonnull)
+# define _GL_ATTRIBUTE_RETURNS_NONNULL __attribute__ ((__returns_nonnull__))
+# else
+# define _GL_ATTRIBUTE_RETURNS_NONNULL
+# endif
#endif
/* _GL_ATTRIBUTE_SENTINEL(pos) declares that the variadic function expects a
@@ -411,17 +543,21 @@ AC_DEFUN([gl_COMMON_BODY], [
_GL_ATTRIBUTE_SENTINEL () - The last argument is NULL (requires C99).
_GL_ATTRIBUTE_SENTINEL ((N)) - The (N+1)st argument from the end is NULL. */
/* Applies to: functions. */
-#if _GL_HAS_ATTRIBUTE (sentinel)
-# define _GL_ATTRIBUTE_SENTINEL(pos) __attribute__ ((__sentinel__ pos))
-#else
-# define _GL_ATTRIBUTE_SENTINEL(pos)
+#ifndef _GL_ATTRIBUTE_SENTINEL
+# if _GL_HAS_ATTRIBUTE (sentinel)
+# define _GL_ATTRIBUTE_SENTINEL(pos) __attribute__ ((__sentinel__ pos))
+# else
+# define _GL_ATTRIBUTE_SENTINEL(pos)
+# endif
#endif
/* A helper macro. Don't use it directly. */
-#if _GL_HAS_ATTRIBUTE (unused)
-# define _GL_ATTRIBUTE_UNUSED __attribute__ ((__unused__))
-#else
-# define _GL_ATTRIBUTE_UNUSED
+#ifndef _GL_ATTRIBUTE_UNUSED
+# if _GL_HAS_ATTRIBUTE (unused)
+# define _GL_ATTRIBUTE_UNUSED __attribute__ ((__unused__))
+# else
+# define _GL_ATTRIBUTE_UNUSED
+# endif
#endif
]dnl There is no _GL_ATTRIBUTE_VISIBILITY; see m4/visibility.m4 instead.
@@ -432,10 +568,24 @@ AC_DEFUN([gl_COMMON_BODY], [
/* Applies to: label (both in C and C++). */
/* Note that g++ < 4.5 does not support the '__attribute__ ((__unused__)) ;'
syntax. But clang does. */
-#if !(defined __cplusplus && !_GL_GNUC_PREREQ (4, 5)) || defined __clang__
-# define _GL_UNUSED_LABEL _GL_ATTRIBUTE_UNUSED
+#ifndef _GL_UNUSED_LABEL
+# if !(defined __cplusplus && !_GL_GNUC_PREREQ (4, 5)) || defined __clang__
+# define _GL_UNUSED_LABEL _GL_ATTRIBUTE_UNUSED
+# else
+# define _GL_UNUSED_LABEL
+# endif
+#endif
+])
+ AH_VERBATIM([c_linkage],
+[/* In C++, there is the concept of "language linkage", that encompasses
+ name mangling and function calling conventions.
+ The following macros start and end a block of "C" linkage. */
+#ifdef __cplusplus
+# define _GL_BEGIN_C_LINKAGE extern "C" {
+# define _GL_END_C_LINKAGE }
#else
-# define _GL_UNUSED_LABEL
+# define _GL_BEGIN_C_LINKAGE
+# define _GL_END_C_LINKAGE
#endif
])
AH_VERBATIM([async_safe],
@@ -493,7 +643,7 @@ AC_DEFUN([gl_COMMON_BODY], [
dnl gl_cross_guess_normal (to be used when 'yes' is good and 'no' is bad),
dnl gl_cross_guess_inverted (to be used when 'no' is good and 'yes' is bad).
AC_ARG_ENABLE([cross-guesses],
- [AS_HELP_STRING([--enable-cross-guesses={conservative|risky}],
+ [AS_HELP_STRING([[--enable-cross-guesses={conservative|risky}]],
[specify policy for cross-compilation guesses])],
[if test "x$enableval" != xconservative && test "x$enableval" != xrisky; then
AC_MSG_WARN([invalid argument supplied to --enable-cross-guesses])
@@ -930,6 +1080,7 @@ AC_DEFUN([gl_CC_GNULIB_WARNINGS],
dnl -Wno-pedantic >= 4.8 >= 3.9
dnl -Wno-sign-compare >= 3 >= 3.9
dnl -Wno-sign-conversion >= 4.3 >= 3.9
+ dnl -Wno-tautological-out-of-range-compare - >= 3.9
dnl -Wno-type-limits >= 4.3 >= 3.9
dnl -Wno-undef >= 3 >= 3.9
dnl -Wno-unsuffixed-float-constants >= 4.5
@@ -955,6 +1106,9 @@ AC_DEFUN([gl_CC_GNULIB_WARNINGS],
#if __GNUC__ + (__GNUC_MINOR__ >= 8) > 4 || (__clang_major__ + (__clang_minor__ >= 9) > 3)
-Wno-pedantic
#endif
+ #if 3 < __clang_major__ + (9 <= __clang_minor__)
+ -Wno-tautological-constant-out-of-range-compare
+ #endif
#if __GNUC__ + (__GNUC_MINOR__ >= 3) > 4 || (__clang_major__ + (__clang_minor__ >= 9) > 3)
-Wno-sign-conversion
-Wno-type-limits
@@ -1005,6 +1159,238 @@ AC_DEFUN([gl_CONDITIONAL_HEADER],
m4_popdef([gl_header_name])
])
+dnl Preparations for gl_CHECK_FUNCS_MACOS.
+AC_DEFUN([gl_PREPARE_CHECK_FUNCS_MACOS],
+[
+ AC_REQUIRE([AC_CANONICAL_HOST])
+ AC_REQUIRE([gl_COMPILER_CLANG])
+ AC_CACHE_CHECK([for compiler option needed when checking for future declarations],
+ [gl_cv_compiler_check_future_option],
+ [case "$host_os" in
+ dnl This is only needed on macOS.
+ darwin*)
+ if test $gl_cv_compiler_clang = yes; then
+ dnl Test whether the compiler supports the option
+ dnl '-Werror=unguarded-availability-new'.
+ saved_ac_compile="$ac_compile"
+ ac_compile="$ac_compile -Werror=unguarded-availability-new"
+ AC_COMPILE_IFELSE([AC_LANG_PROGRAM([[]],[[]])],
+ [gl_cv_compiler_check_future_option='-Werror=unguarded-availability-new'],
+ [gl_cv_compiler_check_future_option=none])
+ ac_compile="$saved_ac_compile"
+ else
+ gl_cv_compiler_check_future_option=none
+ fi
+ ;;
+ *) gl_cv_compiler_check_future_option=none ;;
+ esac
+ ])
+])
+
+dnl Pieces of the expansion of
+dnl gl_CHECK_FUNCS_ANDROID
+dnl gl_CHECK_FUNCS_MACOS
+dnl gl_CHECK_FUNCS_ANDROID_MACOS
+
+AC_DEFUN([gl_CHECK_FUNCS_DEFAULT_CASE],
+[
+ *)
+ AC_CHECK_FUNC([$1])
+ [gl_cv_onwards_func_][$1]=$[ac_cv_func_][$1]
+ ;;
+])
+
+AC_DEFUN([gl_CHECK_FUNCS_CASE_FOR_ANDROID],
+[
+ linux*-android*)
+ AC_CHECK_DECL([$1], , , [$2])
+ if test $[ac_cv_have_decl_][$1] = yes; then
+ AC_CHECK_FUNC([[$1]])
+ if test $[ac_cv_func_][$1] = yes; then
+ [gl_cv_onwards_func_][$1]=yes
+ else
+ dnl The function is declared but does not exist. This should not
+ dnl happen normally. But anyway, we know that a future version
+ dnl of Android will have the function.
+ [gl_cv_onwards_func_][$1]='future OS version'
+ fi
+ else
+ [gl_cv_onwards_func_][$1]='future OS version'
+ fi
+ ;;
+])
+
+AC_DEFUN([gl_CHECK_FUNCS_CASE_FOR_MACOS],
+[
+ darwin*)
+ if test "x$gl_cv_compiler_check_future_option" != "xnone"; then
+ dnl Use a compile test, not a link test.
+ saved_ac_compile="$ac_compile"
+ ac_compile="$ac_compile $gl_cv_compiler_check_future_option"
+ saved_ac_compile_for_check_decl="$ac_compile_for_check_decl"
+ ac_compile_for_check_decl="$ac_compile_for_check_decl $gl_cv_compiler_check_future_option"
+ unset [ac_cv_have_decl_][$1]
+ AC_CHECK_DECL([$1], , , [$2])
+ ac_compile="$saved_ac_compile"
+ ac_compile_for_check_decl="$saved_ac_compile_for_check_decl"
+ [ac_cv_func_][$1]="$[ac_cv_have_decl_][$1]"
+ if test $[ac_cv_func_][$1] = yes; then
+ [gl_cv_onwards_func_][$1]=yes
+ else
+ unset [ac_cv_have_decl_][$1]
+ AC_CHECK_DECL([$1], , , [$2])
+ if test $[ac_cv_have_decl_][$1] = yes; then
+ [gl_cv_onwards_func_][$1]='future OS version'
+ else
+ [gl_cv_onwards_func_][$1]=no
+ fi
+ fi
+ else
+ AC_CHECK_FUNC([$1])
+ [gl_cv_onwards_func_][$1]=$[ac_cv_func_][$1]
+ fi
+ ;;
+])
+
+AC_DEFUN([gl_CHECK_FUNCS_SET_RESULTS],
+[
+ case "$[gl_cv_onwards_func_][$1]" in
+ future*) [ac_cv_func_][$1]=no ;;
+ *) [ac_cv_func_][$1]=$[gl_cv_onwards_func_][$1] ;;
+ esac
+ if test $[ac_cv_func_][$1] = yes; then
+ AC_DEFINE([HAVE_]m4_translit([[$1]],
+ [abcdefghijklmnopqrstuvwxyz],
+ [ABCDEFGHIJKLMNOPQRSTUVWXYZ]),
+ [1], [Define to 1 if you have the `$1' function.])
+ fi
+])
+
+dnl gl_CHECK_FUNCS_ANDROID([func], [[#include <foo.h>]])
+dnl is like AC_CHECK_FUNCS([func]), taking into account a portability problem
+dnl on Android.
+dnl
+dnl When code is compiled on Android, it is in the context of a certain
+dnl "Android API level", which indicates the minimum version of Android on
+dnl which the app can be installed. In other words, you don't compile for a
+dnl specific version of Android. You compile for all versions of Android,
+dnl onwards from the given API level.
+dnl Thus, the question "does the OS have the function func" has three possible
+dnl answers:
+dnl - yes, in all versions starting from the given API level,
+dnl - no, in no version,
+dnl - not in the given API level, but in a later version of Android.
+dnl
+dnl In detail, this works as follows:
+dnl If func was added to Android API level, say, 28, then the libc.so has the
+dnl symbol func always, whereas the header file <foo.h> declares func
+dnl conditionally:
+dnl #if __ANDROID_API__ >= 28
+dnl ... func (...) __INTRODUCED_IN(28);
+dnl #endif
+dnl Thus, when compiling with "clang -target armv7a-unknown-linux-android28",
+dnl the function func is declared and exists in libc.
+dnl Whereas when compiling with "clang -target armv7a-unknown-linux-android27",
+dnl the function func is not declared but exists in libc.
+dnl
+dnl This macro sets two variables:
+dnl - gl_cv_onwards_func_<func> to yes / no / "future OS version"
+dnl - ac_cv_func_<func> to yes / no / no
+dnl The first variable allows to distinguish all three cases.
+dnl The second variable is set, so that an invocation
+dnl gl_CHECK_FUNCS_ANDROID([func], [[#include <foo.h>]])
+dnl can be used as a drop-in replacement for
+dnl AC_CHECK_FUNCS([func]).
+AC_DEFUN([gl_CHECK_FUNCS_ANDROID],
+[
+ AC_REQUIRE([AC_CANONICAL_HOST])
+ AC_CACHE_CHECK([for [$1]],
+ [[gl_cv_onwards_func_][$1]],
+ [gl_SILENT([
+ case "$host_os" in
+ gl_CHECK_FUNCS_CASE_FOR_ANDROID([$1], [$2])
+ gl_CHECK_FUNCS_DEFAULT_CASE([$1])
+ esac
+ ])
+ ])
+ gl_CHECK_FUNCS_SET_RESULTS([$1])
+])
+
+dnl gl_CHECK_FUNCS_MACOS([func], [[#include <foo.h>]])
+dnl is like AC_CHECK_FUNCS([func]), taking into account a portability problem
+dnl on macOS.
+dnl
+dnl When code is compiled on macOS, it is in the context of a certain minimum
+dnl macOS version, that can be set through the option '-mmacosx-version-min='.
+dnl In other words, you don't compile for a specific version of macOS. You
+dnl compile for all versions of macOS, onwards from the given version.
+dnl Thus, the question "does the OS have the function func" has three possible
+dnl answers:
+dnl - yes, in all versions starting from the given version,
+dnl - no, in no version,
+dnl - not in the given version, but in a later version of macOS.
+dnl
+dnl In detail, this works as follows:
+dnl If func was added to, say, macOS version 13, then the libc has the
+dnl symbol func always, whereas the header file <foo.h> declares func
+dnl conditionally with a special availability attribute:
+dnl ... func (...) __attribute__((availability(macos,introduced=13.0)));
+dnl Thus, when compiling with "clang mmacosx-version-min=13", there is no
+dnl warning about the use of func, and the resulting binary
+dnl - runs fine on macOS 13,
+dnl - aborts with a dyld "Symbol not found" message on macOS 12.
+dnl Whereas, when compiling with "clang mmacosx-version-min=12", there is a
+dnl warning: 'func' is only available on macOS 13.0 or newer
+dnl [-Wunguarded-availability-new],
+dnl and the resulting binary
+dnl - runs fine on macOS 13,
+dnl - crashes with a SIGSEGV (signal 11) on macOS 12.
+dnl
+dnl This macro sets two variables:
+dnl - gl_cv_onwards_func_<func> to yes / no / "future OS version"
+dnl - ac_cv_func_<func> to yes / no / no
+dnl The first variable allows to distinguish all three cases.
+dnl The second variable is set, so that an invocation
+dnl gl_CHECK_FUNCS_MACOS([func], [[#include <foo.h>]])
+dnl can be used as a drop-in replacement for
+dnl AC_CHECK_FUNCS([func]).
+AC_DEFUN([gl_CHECK_FUNCS_MACOS],
+[
+ AC_REQUIRE([AC_CANONICAL_HOST])
+ AC_REQUIRE([gl_PREPARE_CHECK_FUNCS_MACOS])
+ AC_CACHE_CHECK([for [$1]],
+ [[gl_cv_onwards_func_][$1]],
+ [gl_SILENT([
+ case "$host_os" in
+ gl_CHECK_FUNCS_CASE_FOR_MACOS([$1], [$2])
+ gl_CHECK_FUNCS_DEFAULT_CASE([$1])
+ esac
+ ])
+ ])
+ gl_CHECK_FUNCS_SET_RESULTS([$1])
+])
+
+dnl gl_CHECK_FUNCS_ANDROID_MACOS([func], [[#include <foo.h>]])
+dnl is like AC_CHECK_FUNCS([func]), taking into account a portability problem
+dnl on Android and on macOS.
+dnl It is the combination of gl_CHECK_FUNCS_ANDROID and gl_CHECK_FUNCS_MACOS.
+AC_DEFUN([gl_CHECK_FUNCS_ANDROID_MACOS],
+[
+ AC_REQUIRE([AC_CANONICAL_HOST])
+ AC_REQUIRE([gl_PREPARE_CHECK_FUNCS_MACOS])
+ AC_CACHE_CHECK([for [$1]],
+ [[gl_cv_onwards_func_][$1]],
+ [gl_SILENT([
+ case "$host_os" in
+ gl_CHECK_FUNCS_CASE_FOR_ANDROID([$1], [$2])
+ gl_CHECK_FUNCS_CASE_FOR_MACOS([$1], [$2])
+ gl_CHECK_FUNCS_DEFAULT_CASE([$1])
+ esac
+ ])
+ ])
+ gl_CHECK_FUNCS_SET_RESULTS([$1])
+])
+
dnl Expands to some code for use in .c programs that, on native Windows, defines
dnl the Microsoft deprecated alias function names to the underscore-prefixed
dnl actual function names. With this macro, these function names are available
diff --git a/m4/gnulib-comp.m4 b/m4/gnulib-comp.m4
index 9ee69c37553..d8b92e7b122 100644
--- a/m4/gnulib-comp.m4
+++ b/m4/gnulib-comp.m4
@@ -44,12 +44,14 @@ AC_DEFUN([gl_EARLY],
# Code from module absolute-header:
# Code from module acl-permissions:
+ # Code from module alignasof:
# Code from module alloca-opt:
# Code from module allocator:
# Code from module assert-h:
# Code from module at-internal:
# Code from module attribute:
# Code from module binary-io:
+ # Code from module boot-time:
# Code from module builtin-expect:
# Code from module byteswap:
# Code from module c-ctype:
@@ -82,7 +84,6 @@ AC_DEFUN([gl_EARLY],
# Code from module errno:
# Code from module euidaccess:
# Code from module execinfo:
- # Code from module explicit_bzero:
# Code from module extensions:
# Code from module extern-inline:
# Code from module faccessat:
@@ -104,8 +105,10 @@ AC_DEFUN([gl_EARLY],
# Code from module fsync:
# Code from module futimens:
# Code from module gen-header:
+ # Code from module getdelim:
# Code from module getdtablesize:
# Code from module getgroups:
+ # Code from module getline:
# Code from module getloadavg:
# Code from module getopt-gnu:
# Code from module getopt-posix:
@@ -124,7 +127,6 @@ AC_DEFUN([gl_EARLY],
# Code from module intprops:
# Code from module inttypes-incomplete:
# Code from module largefile:
- AC_REQUIRE([gl_YEAR2038_EARLY])
AC_REQUIRE([AC_SYS_LARGEFILE])
# Code from module lchmod:
# Code from module libc-config:
@@ -137,6 +139,7 @@ AC_DEFUN([gl_EARLY],
# Code from module memmem-simple:
# Code from module mempcpy:
# Code from module memrchr:
+ # Code from module memset_explicit:
# Code from module minmax:
# Code from module mkostemp:
# Code from module mktime:
@@ -171,12 +174,12 @@ AC_DEFUN([gl_EARLY],
# Code from module ssize_t:
# Code from module stat-time:
# Code from module std-gnu11:
- # Code from module stdalign:
# Code from module stdbool:
# Code from module stdckdint:
# Code from module stddef:
# Code from module stdint:
# Code from module stdio:
+ gl_STDIO_H_EARLY
# Code from module stdlib:
# Code from module stpcpy:
# Code from module string:
@@ -190,7 +193,7 @@ AC_DEFUN([gl_EARLY],
# Code from module sys_time:
# Code from module sys_types:
# Code from module tempname:
- # Code from module time:
+ # Code from module time-h:
# Code from module time_r:
# Code from module time_rz:
# Code from module timegm:
@@ -210,6 +213,8 @@ AC_DEFUN([gl_EARLY],
# Code from module vla:
# Code from module warnings:
# Code from module xalloc-oversized:
+ # Code from module year2038:
+ AC_REQUIRE([AC_SYS_YEAR2038])
])
# This macro should be invoked from ./configure.ac, in the section
@@ -232,12 +237,14 @@ AC_DEFUN([gl_INIT],
gl_source_base='lib'
gl_source_base_prefix=
gl_FUNC_ACL
+ gl_ALIGNASOF
gl_FUNC_ALLOCA
gl_CONDITIONAL_HEADER([alloca.h])
AC_PROG_MKDIR_P
gl_ASSERT_H
gl_CONDITIONAL_HEADER([assert.h])
AC_PROG_MKDIR_P
+ gl_PREREQ_READUTMP_H
gl___BUILTIN_EXPECT
gl_BYTESWAP
gl_CONDITIONAL_HEADER([byteswap.h])
@@ -249,7 +256,7 @@ AC_DEFUN([gl_INIT],
gl_STDLIB_MODULE_INDICATOR([canonicalize_file_name])
gl_STDLIB_MODULE_INDICATOR([realpath])
AC_REQUIRE([AC_C_RESTRICT])
- AC_CHECK_FUNCS_ONCE([readlinkat])
+ gl_CHECK_FUNCS_ANDROID([readlinkat], [[#include <unistd.h>]])
gl_CLOCK_TIME
gl_MODULE_INDICATOR([close-stream])
gl_FUNC_COPY_FILE_RANGE
@@ -285,12 +292,6 @@ AC_DEFUN([gl_INIT],
gl_CONDITIONAL_HEADER([execinfo.h])
AC_PROG_MKDIR_P
gl_CONDITIONAL([GL_COND_OBJ_EXECINFO], [$GL_GENERATE_EXECINFO_H])
- gl_FUNC_EXPLICIT_BZERO
- gl_CONDITIONAL([GL_COND_OBJ_EXPLICIT_BZERO], [test $HAVE_EXPLICIT_BZERO = 0])
- AM_COND_IF([GL_COND_OBJ_EXPLICIT_BZERO], [
- gl_PREREQ_EXPLICIT_BZERO
- ])
- gl_STRING_MODULE_INDICATOR([explicit_bzero])
AC_REQUIRE([gl_EXTERN_INLINE])
gl_FUNC_FACCESSAT
gl_CONDITIONAL([GL_COND_OBJ_FACCESSAT],
@@ -349,9 +350,16 @@ AC_DEFUN([gl_INIT],
gl_CONDITIONAL([GL_COND_OBJ_FUTIMENS],
[test $HAVE_FUTIMENS = 0 || test $REPLACE_FUTIMENS = 1])
gl_SYS_STAT_MODULE_INDICATOR([futimens])
+ gl_FUNC_GETLINE
+ gl_CONDITIONAL([GL_COND_OBJ_GETLINE], [test $REPLACE_GETLINE = 1])
+ AM_COND_IF([GL_COND_OBJ_GETLINE], [
+ gl_PREREQ_GETLINE
+ ])
+ gl_STDIO_MODULE_INDICATOR([getline])
AC_REQUIRE([AC_CANONICAL_HOST])
gl_GETLOADAVG
- gl_CONDITIONAL([GL_COND_OBJ_GETLOADAVG], [test $HAVE_GETLOADAVG = 0])
+ gl_CONDITIONAL([GL_COND_OBJ_GETLOADAVG],
+ [test $HAVE_GETLOADAVG = 0 || test $REPLACE_GETLOADAVG = 1])
AM_COND_IF([GL_COND_OBJ_GETLOADAVG], [
gl_PREREQ_GETLOADAVG
])
@@ -411,7 +419,8 @@ AC_DEFUN([gl_INIT],
fi
gl_STRING_MODULE_INDICATOR([memmem])
gl_FUNC_MEMPCPY
- gl_CONDITIONAL([GL_COND_OBJ_MEMPCPY], [test $HAVE_MEMPCPY = 0])
+ gl_CONDITIONAL([GL_COND_OBJ_MEMPCPY],
+ [test $HAVE_MEMPCPY = 0 || test $REPLACE_MEMPCPY = 1])
AM_COND_IF([GL_COND_OBJ_MEMPCPY], [
gl_PREREQ_MEMPCPY
])
@@ -422,9 +431,17 @@ AC_DEFUN([gl_INIT],
gl_PREREQ_MEMRCHR
])
gl_STRING_MODULE_INDICATOR([memrchr])
+ gl_FUNC_MEMSET_EXPLICIT
+ gl_CONDITIONAL([GL_COND_OBJ_MEMSET_EXPLICIT],
+ [test $HAVE_MEMSET_EXPLICIT = 0 || test $REPLACE_MEMSET_EXPLICIT = 1])
+ AM_COND_IF([GL_COND_OBJ_MEMSET_EXPLICIT], [
+ gl_PREREQ_MEMSET_EXPLICIT
+ ])
+ gl_STRING_MODULE_INDICATOR([memset_explicit])
gl_MINMAX
gl_FUNC_MKOSTEMP
- gl_CONDITIONAL([GL_COND_OBJ_MKOSTEMP], [test $HAVE_MKOSTEMP = 0])
+ gl_CONDITIONAL([GL_COND_OBJ_MKOSTEMP],
+ [test $HAVE_MKOSTEMP = 0 || test $REPLACE_MKOSTEMP = 1])
AM_COND_IF([GL_COND_OBJ_MKOSTEMP], [
gl_PREREQ_MKOSTEMP
])
@@ -457,6 +474,14 @@ AC_DEFUN([gl_INIT],
gl_PREREQ_PTHREAD_SIGMASK
])
gl_SIGNAL_MODULE_INDICATOR([pthread_sigmask])
+ gl_FUNC_XATTR
+ AC_REQUIRE([gl_FUNC_ACL])
+ if test "$use_xattr" = yes; then
+ QCOPY_ACL_LIB="$LIB_XATTR"
+ else
+ QCOPY_ACL_LIB="$LIB_ACL"
+ fi
+ AC_SUBST([QCOPY_ACL_LIB])
gl_FUNC_READLINK
gl_CONDITIONAL([GL_COND_OBJ_READLINK],
[test $HAVE_READLINK = 0 || test $REPLACE_READLINK = 1])
@@ -488,9 +513,6 @@ AC_DEFUN([gl_INIT],
gt_TYPE_SSIZE_T
gl_STAT_TIME
gl_STAT_BIRTHTIME
- gl_STDALIGN_H
- gl_CONDITIONAL_HEADER([stdalign.h])
- AC_PROG_MKDIR_P
gl_C_BOOL
AC_CHECK_HEADERS_ONCE([stdckdint.h])
if test $ac_cv_header_stdckdint_h = yes; then
@@ -541,7 +563,8 @@ AC_DEFUN([gl_INIT],
gl_STDLIB_H_REQUIRE_DEFAULTS
AC_PROG_MKDIR_P
gl_FUNC_STPCPY
- gl_CONDITIONAL([GL_COND_OBJ_STPCPY], [test $HAVE_STPCPY = 0])
+ gl_CONDITIONAL([GL_COND_OBJ_STPCPY],
+ [test $HAVE_STPCPY = 0 || test $REPLACE_STPCPY = 1])
AM_COND_IF([GL_COND_OBJ_STPCPY], [
gl_PREREQ_STPCPY
])
@@ -630,6 +653,7 @@ AC_DEFUN([gl_INIT],
gl_gnulib_enabled_dirfd=false
gl_gnulib_enabled_925677f0343de64b89a9f0c790b4104c=false
gl_gnulib_enabled_euidaccess=false
+ gl_gnulib_enabled_getdelim=false
gl_gnulib_enabled_getdtablesize=false
gl_gnulib_enabled_getgroups=false
gl_gnulib_enabled_be453cec5eecf5731a274f2de7f2db36=false
@@ -651,27 +675,27 @@ AC_DEFUN([gl_INIT],
gl_gnulib_enabled_682e609604ccaac6be382e4ee3a4eaec=false
func_gl_gnulib_m4code_260941c0e5dc67ec9e87d1fb321c300b ()
{
- if ! $gl_gnulib_enabled_260941c0e5dc67ec9e87d1fb321c300b; then
+ if $gl_gnulib_enabled_260941c0e5dc67ec9e87d1fb321c300b; then :; else
AC_REQUIRE([AC_CANONICAL_HOST])
gl_gnulib_enabled_260941c0e5dc67ec9e87d1fb321c300b=true
- if case $host_os in mingw*) false;; *) :;; esac; then
+ if case $host_os in mingw* | windows*) false;; *) :;; esac; then
func_gl_gnulib_m4code_open
fi
fi
}
func_gl_gnulib_m4code_cloexec ()
{
- if ! $gl_gnulib_enabled_cloexec; then
+ if $gl_gnulib_enabled_cloexec; then :; else
gl_MODULE_INDICATOR_FOR_TESTS([cloexec])
gl_gnulib_enabled_cloexec=true
fi
}
func_gl_gnulib_m4code_dirfd ()
{
- if ! $gl_gnulib_enabled_dirfd; then
+ if $gl_gnulib_enabled_dirfd; then :; else
gl_FUNC_DIRFD
gl_CONDITIONAL([GL_COND_OBJ_DIRFD],
- [test $ac_cv_func_dirfd = no && test $gl_cv_func_dirfd_macro = no || test $REPLACE_DIRFD = 1])
+ [test $HAVE_DIRFD = 0 || test $REPLACE_DIRFD = 1])
AM_COND_IF([GL_COND_OBJ_DIRFD], [
gl_PREREQ_DIRFD
])
@@ -681,13 +705,13 @@ AC_DEFUN([gl_INIT],
}
func_gl_gnulib_m4code_925677f0343de64b89a9f0c790b4104c ()
{
- if ! $gl_gnulib_enabled_925677f0343de64b89a9f0c790b4104c; then
+ if $gl_gnulib_enabled_925677f0343de64b89a9f0c790b4104c; then :; else
gl_gnulib_enabled_925677f0343de64b89a9f0c790b4104c=true
fi
}
func_gl_gnulib_m4code_euidaccess ()
{
- if ! $gl_gnulib_enabled_euidaccess; then
+ if $gl_gnulib_enabled_euidaccess; then :; else
gl_FUNC_EUIDACCESS
gl_CONDITIONAL([GL_COND_OBJ_EUIDACCESS], [test $HAVE_EUIDACCESS = 0])
AM_COND_IF([GL_COND_OBJ_EUIDACCESS], [
@@ -701,9 +725,22 @@ AC_DEFUN([gl_INIT],
func_gl_gnulib_m4code_6099e9737f757db36c47fa9d9f02e88c
fi
}
+ func_gl_gnulib_m4code_getdelim ()
+ {
+ if $gl_gnulib_enabled_getdelim; then :; else
+ gl_FUNC_GETDELIM
+ gl_CONDITIONAL([GL_COND_OBJ_GETDELIM],
+ [test $HAVE_GETDELIM = 0 || test $REPLACE_GETDELIM = 1])
+ AM_COND_IF([GL_COND_OBJ_GETDELIM], [
+ gl_PREREQ_GETDELIM
+ ])
+ gl_STDIO_MODULE_INDICATOR([getdelim])
+ gl_gnulib_enabled_getdelim=true
+ fi
+ }
func_gl_gnulib_m4code_getdtablesize ()
{
- if ! $gl_gnulib_enabled_getdtablesize; then
+ if $gl_gnulib_enabled_getdtablesize; then :; else
gl_FUNC_GETDTABLESIZE
gl_CONDITIONAL([GL_COND_OBJ_GETDTABLESIZE],
[test $HAVE_GETDTABLESIZE = 0 || test $REPLACE_GETDTABLESIZE = 1])
@@ -716,7 +753,7 @@ AC_DEFUN([gl_INIT],
}
func_gl_gnulib_m4code_getgroups ()
{
- if ! $gl_gnulib_enabled_getgroups; then
+ if $gl_gnulib_enabled_getgroups; then :; else
gl_FUNC_GETGROUPS
gl_CONDITIONAL([GL_COND_OBJ_GETGROUPS],
[test $HAVE_GETGROUPS = 0 || test $REPLACE_GETGROUPS = 1])
@@ -729,7 +766,7 @@ AC_DEFUN([gl_INIT],
}
func_gl_gnulib_m4code_be453cec5eecf5731a274f2de7f2db36 ()
{
- if ! $gl_gnulib_enabled_be453cec5eecf5731a274f2de7f2db36; then
+ if $gl_gnulib_enabled_be453cec5eecf5731a274f2de7f2db36; then :; else
AC_SUBST([LIBINTL])
AC_SUBST([LTLIBINTL])
gl_gnulib_enabled_be453cec5eecf5731a274f2de7f2db36=true
@@ -737,14 +774,14 @@ AC_DEFUN([gl_INIT],
}
func_gl_gnulib_m4code_fd38c7e463b54744b77b98aeafb4fa7c ()
{
- if ! $gl_gnulib_enabled_fd38c7e463b54744b77b98aeafb4fa7c; then
+ if $gl_gnulib_enabled_fd38c7e463b54744b77b98aeafb4fa7c; then :; else
AC_PROG_MKDIR_P
gl_gnulib_enabled_fd38c7e463b54744b77b98aeafb4fa7c=true
fi
}
func_gl_gnulib_m4code_8444034ea779b88768865bb60b4fb8c9 ()
{
- if ! $gl_gnulib_enabled_8444034ea779b88768865bb60b4fb8c9; then
+ if $gl_gnulib_enabled_8444034ea779b88768865bb60b4fb8c9; then :; else
AC_PROG_MKDIR_P
gl_gnulib_enabled_8444034ea779b88768865bb60b4fb8c9=true
func_gl_gnulib_m4code_ef455225c00f5049c808c2eda3e76866
@@ -753,7 +790,7 @@ AC_DEFUN([gl_INIT],
}
func_gl_gnulib_m4code_a9786850e999ae65a836a6041e8e5ed1 ()
{
- if ! $gl_gnulib_enabled_a9786850e999ae65a836a6041e8e5ed1; then
+ if $gl_gnulib_enabled_a9786850e999ae65a836a6041e8e5ed1; then :; else
gl_FUNC_GROUP_MEMBER
gl_CONDITIONAL([GL_COND_OBJ_GROUP_MEMBER], [test $HAVE_GROUP_MEMBER = 0])
AM_COND_IF([GL_COND_OBJ_GROUP_MEMBER], [
@@ -771,7 +808,7 @@ AC_DEFUN([gl_INIT],
}
func_gl_gnulib_m4code_lchmod ()
{
- if ! $gl_gnulib_enabled_lchmod; then
+ if $gl_gnulib_enabled_lchmod; then :; else
gl_FUNC_LCHMOD
gl_CONDITIONAL([GL_COND_OBJ_LCHMOD], [test $HAVE_LCHMOD = 0])
AM_COND_IF([GL_COND_OBJ_LCHMOD], [
@@ -783,7 +820,7 @@ AC_DEFUN([gl_INIT],
}
func_gl_gnulib_m4code_e80bf6f757095d2e5fc94dafb8f8fc8b ()
{
- if ! $gl_gnulib_enabled_e80bf6f757095d2e5fc94dafb8f8fc8b; then
+ if $gl_gnulib_enabled_e80bf6f757095d2e5fc94dafb8f8fc8b; then :; else
gl_FUNC_MALLOC_GNU
if test $REPLACE_MALLOC_FOR_MALLOC_GNU = 1; then
AC_LIBOBJ([malloc])
@@ -798,7 +835,7 @@ AC_DEFUN([gl_INIT],
}
func_gl_gnulib_m4code_ef455225c00f5049c808c2eda3e76866 ()
{
- if ! $gl_gnulib_enabled_ef455225c00f5049c808c2eda3e76866; then
+ if $gl_gnulib_enabled_ef455225c00f5049c808c2eda3e76866; then :; else
AC_REQUIRE([gl_FUNC_MALLOC_POSIX])
if test $REPLACE_MALLOC_FOR_MALLOC_POSIX = 1; then
AC_LIBOBJ([malloc])
@@ -812,7 +849,7 @@ AC_DEFUN([gl_INIT],
}
func_gl_gnulib_m4code_5264294aa0a5557541b53c8c741f7f31 ()
{
- if ! $gl_gnulib_enabled_5264294aa0a5557541b53c8c741f7f31; then
+ if $gl_gnulib_enabled_5264294aa0a5557541b53c8c741f7f31; then :; else
gl_FUNC_MKTIME_INTERNAL
if test $WANT_MKTIME_INTERNAL = 1; then
AC_LIBOBJ([mktime])
@@ -823,7 +860,7 @@ AC_DEFUN([gl_INIT],
}
func_gl_gnulib_m4code_open ()
{
- if ! $gl_gnulib_enabled_open; then
+ if $gl_gnulib_enabled_open; then :; else
gl_FUNC_OPEN
gl_CONDITIONAL([GL_COND_OBJ_OPEN], [test $REPLACE_OPEN = 1])
AM_COND_IF([GL_COND_OBJ_OPEN], [
@@ -838,13 +875,13 @@ AC_DEFUN([gl_INIT],
}
func_gl_gnulib_m4code_03e0aaad4cb89ca757653bd367a6ccb7 ()
{
- if ! $gl_gnulib_enabled_03e0aaad4cb89ca757653bd367a6ccb7; then
+ if $gl_gnulib_enabled_03e0aaad4cb89ca757653bd367a6ccb7; then :; else
gl_gnulib_enabled_03e0aaad4cb89ca757653bd367a6ccb7=true
fi
}
func_gl_gnulib_m4code_rawmemchr ()
{
- if ! $gl_gnulib_enabled_rawmemchr; then
+ if $gl_gnulib_enabled_rawmemchr; then :; else
gl_FUNC_RAWMEMCHR
gl_CONDITIONAL([GL_COND_OBJ_RAWMEMCHR], [test $HAVE_RAWMEMCHR = 0])
AM_COND_IF([GL_COND_OBJ_RAWMEMCHR], [
@@ -856,7 +893,7 @@ AC_DEFUN([gl_INIT],
}
func_gl_gnulib_m4code_d3b2383720ee0e541357aa2aac598e2b ()
{
- if ! $gl_gnulib_enabled_d3b2383720ee0e541357aa2aac598e2b; then
+ if $gl_gnulib_enabled_d3b2383720ee0e541357aa2aac598e2b; then :; else
gl_FUNC_REALLOC_GNU
if test $REPLACE_REALLOC_FOR_REALLOC_GNU = 1; then
AC_LIBOBJ([realloc])
@@ -874,7 +911,7 @@ AC_DEFUN([gl_INIT],
}
func_gl_gnulib_m4code_61bcaca76b3e6f9ae55d57a1c3193bc4 ()
{
- if ! $gl_gnulib_enabled_61bcaca76b3e6f9ae55d57a1c3193bc4; then
+ if $gl_gnulib_enabled_61bcaca76b3e6f9ae55d57a1c3193bc4; then :; else
gl_FUNC_REALLOC_POSIX
if test $REPLACE_REALLOC_FOR_REALLOC_POSIX = 1; then
AC_LIBOBJ([realloc])
@@ -891,13 +928,13 @@ AC_DEFUN([gl_INIT],
}
func_gl_gnulib_m4code_6099e9737f757db36c47fa9d9f02e88c ()
{
- if ! $gl_gnulib_enabled_6099e9737f757db36c47fa9d9f02e88c; then
+ if $gl_gnulib_enabled_6099e9737f757db36c47fa9d9f02e88c; then :; else
gl_gnulib_enabled_6099e9737f757db36c47fa9d9f02e88c=true
fi
}
func_gl_gnulib_m4code_strtoll ()
{
- if ! $gl_gnulib_enabled_strtoll; then
+ if $gl_gnulib_enabled_strtoll; then :; else
gl_FUNC_STRTOLL
gl_CONDITIONAL([GL_COND_OBJ_STRTOLL],
[test $HAVE_STRTOLL = 0 || test $REPLACE_STRTOLL = 1])
@@ -910,14 +947,14 @@ AC_DEFUN([gl_INIT],
}
func_gl_gnulib_m4code_utimens ()
{
- if ! $gl_gnulib_enabled_utimens; then
+ if $gl_gnulib_enabled_utimens; then :; else
gl_UTIMENS
gl_gnulib_enabled_utimens=true
fi
}
func_gl_gnulib_m4code_682e609604ccaac6be382e4ee3a4eaec ()
{
- if ! $gl_gnulib_enabled_682e609604ccaac6be382e4ee3a4eaec; then
+ if $gl_gnulib_enabled_682e609604ccaac6be382e4ee3a4eaec; then :; else
gl_gnulib_enabled_682e609604ccaac6be382e4ee3a4eaec=true
fi
}
@@ -966,13 +1003,16 @@ AC_DEFUN([gl_INIT],
if test $HAVE_FUTIMENS = 0 || test $REPLACE_FUTIMENS = 1; then
func_gl_gnulib_m4code_utimens
fi
- if case $host_os in mingw*) false;; *) test $HAVE_GETLOADAVG = 0;; esac; then
+ if test $REPLACE_GETLINE = 1; then
+ func_gl_gnulib_m4code_getdelim
+ fi
+ if case $host_os in mingw* | windows*) false;; *) test $HAVE_GETLOADAVG = 0 || test $REPLACE_GETLOADAVG = 1;; esac; then
func_gl_gnulib_m4code_open
fi
if test $REPLACE_GETOPT = 1; then
func_gl_gnulib_m4code_be453cec5eecf5731a274f2de7f2db36
fi
- if case $host_os in mingw*) false;; *) test $HAVE_GETRANDOM = 0 || test $REPLACE_GETRANDOM = 1;; esac; then
+ if case $host_os in mingw* | windows*) false;; *) test $HAVE_GETRANDOM = 0 || test $REPLACE_GETRANDOM = 1;; esac; then
func_gl_gnulib_m4code_open
fi
if test $HAVE_READLINKAT = 0 || test $REPLACE_READLINKAT = 1; then
@@ -984,7 +1024,7 @@ AC_DEFUN([gl_INIT],
if test $ac_use_included_regex = yes; then
func_gl_gnulib_m4code_fd38c7e463b54744b77b98aeafb4fa7c
fi
- if { test $HAVE_DECL_STRTOIMAX = 0 || test $REPLACE_STRTOIMAX = 1; } && test $ac_cv_type_long_long_int = yes; then
+ if test $HAVE_DECL_STRTOIMAX = 0 || test $REPLACE_STRTOIMAX = 1; then
func_gl_gnulib_m4code_strtoll
fi
if test $HAVE_TIMEGM = 0 || test $REPLACE_TIMEGM = 1; then
@@ -1005,6 +1045,7 @@ AC_DEFUN([gl_INIT],
AM_CONDITIONAL([gl_GNULIB_ENABLED_dirfd], [$gl_gnulib_enabled_dirfd])
AM_CONDITIONAL([gl_GNULIB_ENABLED_925677f0343de64b89a9f0c790b4104c], [$gl_gnulib_enabled_925677f0343de64b89a9f0c790b4104c])
AM_CONDITIONAL([gl_GNULIB_ENABLED_euidaccess], [$gl_gnulib_enabled_euidaccess])
+ AM_CONDITIONAL([gl_GNULIB_ENABLED_getdelim], [$gl_gnulib_enabled_getdelim])
AM_CONDITIONAL([gl_GNULIB_ENABLED_getdtablesize], [$gl_gnulib_enabled_getdtablesize])
AM_CONDITIONAL([gl_GNULIB_ENABLED_getgroups], [$gl_gnulib_enabled_getgroups])
AM_CONDITIONAL([gl_GNULIB_ENABLED_be453cec5eecf5731a274f2de7f2db36], [$gl_gnulib_enabled_be453cec5eecf5731a274f2de7f2db36])
@@ -1214,6 +1255,9 @@ AC_DEFUN([gl_FILE_LIST], [
lib/attribute.h
lib/binary-io.c
lib/binary-io.h
+ lib/boot-time-aux.h
+ lib/boot-time.c
+ lib/boot-time.h
lib/byteswap.in.h
lib/c++defs.h
lib/c-ctype.c
@@ -1237,6 +1281,7 @@ AC_DEFUN([gl_FILE_LIST], [
lib/count-trailing-zeros.c
lib/count-trailing-zeros.h
lib/diffseq.h
+ lib/dirent-private.h
lib/dirent.in.h
lib/dirfd.c
lib/dtoastr.c
@@ -1248,7 +1293,6 @@ AC_DEFUN([gl_FILE_LIST], [
lib/euidaccess.c
lib/execinfo.c
lib/execinfo.in.h
- lib/explicit_bzero.c
lib/faccessat.c
lib/fchmodat.c
lib/fcntl.c
@@ -1272,8 +1316,10 @@ AC_DEFUN([gl_FILE_LIST], [
lib/ftoastr.h
lib/futimens.c
lib/get-permissions.c
+ lib/getdelim.c
lib/getdtablesize.c
lib/getgroups.c
+ lib/getline.c
lib/getloadavg.c
lib/getopt-cdefs.in.h
lib/getopt-core.h
@@ -1318,6 +1364,7 @@ AC_DEFUN([gl_FILE_LIST], [
lib/memmem.c
lib/mempcpy.c
lib/memrchr.c
+ lib/memset_explicit.c
lib/mini-gmp-gnulib.c
lib/mini-gmp.c
lib/mini-gmp.h
@@ -1342,6 +1389,7 @@ AC_DEFUN([gl_FILE_LIST], [
lib/rawmemchr.valgrind
lib/readlink.c
lib/readlinkat.c
+ lib/readutmp.h
lib/realloc.c
lib/regcomp.c
lib/regex.c
@@ -1364,7 +1412,6 @@ AC_DEFUN([gl_FILE_LIST], [
lib/signal.in.h
lib/stat-time.c
lib/stat-time.h
- lib/stdalign.in.h
lib/stdckdint.in.h
lib/stddef.in.h
lib/stdint.in.h
@@ -1375,6 +1422,7 @@ AC_DEFUN([gl_FILE_LIST], [
lib/stdlib.in.h
lib/stpcpy.c
lib/str-two-way.h
+ lib/strftime.c
lib/strftime.h
lib/string.in.h
lib/strnlen.c
@@ -1421,6 +1469,7 @@ AC_DEFUN([gl_FILE_LIST], [
m4/c-bool.m4
m4/canonicalize.m4
m4/clock_time.m4
+ m4/codeset.m4
m4/copy-file-range.m4
m4/d-type.m4
m4/dirent_h.m4
@@ -1432,7 +1481,6 @@ AC_DEFUN([gl_FILE_LIST], [
m4/errno_h.m4
m4/euidaccess.m4
m4/execinfo.m4
- m4/explicit_bzero.m4
m4/extensions.m4
m4/extern-inline.m4
m4/faccessat.m4
@@ -1450,8 +1498,10 @@ AC_DEFUN([gl_FILE_LIST], [
m4/fsusage.m4
m4/fsync.m4
m4/futimens.m4
+ m4/getdelim.m4
m4/getdtablesize.m4
m4/getgroups.m4
+ m4/getline.m4
m4/getloadavg.m4
m4/getopt.m4
m4/getrandom.m4
@@ -1467,6 +1517,7 @@ AC_DEFUN([gl_FILE_LIST], [
m4/lchmod.m4
m4/libgmp.m4
m4/limits-h.m4
+ m4/locale-fr.m4
m4/lstat.m4
m4/malloc.m4
m4/manywarnings-c++.m4
@@ -1476,11 +1527,13 @@ AC_DEFUN([gl_FILE_LIST], [
m4/memmem.m4
m4/mempcpy.m4
m4/memrchr.m4
+ m4/memset_explicit.m4
m4/minmax.m4
m4/mkostemp.m4
m4/mktime.m4
m4/mode_t.m4
m4/multiarch.m4
+ m4/musl.m4
m4/nanosleep.m4
m4/nocrash.m4
m4/nproc.m4
@@ -1497,6 +1550,7 @@ AC_DEFUN([gl_FILE_LIST], [
m4/rawmemchr.m4
m4/readlink.m4
m4/readlinkat.m4
+ m4/readutmp.m4
m4/realloc.m4
m4/regex.m4
m4/sha1.m4
@@ -1544,6 +1598,6 @@ AC_DEFUN([gl_FILE_LIST], [
m4/warnings.m4
m4/wchar_t.m4
m4/wint_t.m4
- m4/year2038.m4
+ m4/xattr.m4
m4/zzgnulib.m4
])
diff --git a/m4/group-member.m4 b/m4/group-member.m4
index e058ace62b9..60b3d526db2 100644
--- a/m4/group-member.m4
+++ b/m4/group-member.m4
@@ -1,7 +1,6 @@
# serial 14
-# Copyright (C) 1999-2001, 2003-2007, 2009-2024 Free Software
-# Foundation, Inc.
+# Copyright (C) 1999-2001, 2003-2007, 2009-2024 Free Software Foundation, Inc.
# This file is free software; the Free Software Foundation
# gives unlimited permission to copy and/or distribute it,
diff --git a/m4/include_next.m4 b/m4/include_next.m4
index 8a1c52c8564..70cb746f435 100644
--- a/m4/include_next.m4
+++ b/m4/include_next.m4
@@ -1,4 +1,4 @@
-# include_next.m4 serial 26
+# include_next.m4 serial 27
dnl Copyright (C) 2006-2024 Free Software Foundation, Inc.
dnl This file is free software; the Free Software Foundation
dnl gives unlimited permission to copy and/or distribute it,
@@ -74,17 +74,17 @@ EOF
#endif
#define DEFINED_IN_CONFTESTD2
EOF
- gl_save_CPPFLAGS="$CPPFLAGS"
- CPPFLAGS="$gl_save_CPPFLAGS -Iconftestd1b -Iconftestd2"
+ gl_saved_CPPFLAGS="$CPPFLAGS"
+ CPPFLAGS="$gl_saved_CPPFLAGS -Iconftestd1b -Iconftestd2"
dnl We intentionally avoid using AC_LANG_SOURCE here.
AC_COMPILE_IFELSE([AC_LANG_DEFINES_PROVIDED[#include <conftest.h>]],
[gl_cv_have_include_next=yes],
- [CPPFLAGS="$gl_save_CPPFLAGS -Iconftestd1a -Iconftestd2"
+ [CPPFLAGS="$gl_saved_CPPFLAGS -Iconftestd1a -Iconftestd2"
AC_COMPILE_IFELSE([AC_LANG_DEFINES_PROVIDED[#include <conftest.h>]],
[gl_cv_have_include_next=buggy],
[gl_cv_have_include_next=no])
])
- CPPFLAGS="$gl_save_CPPFLAGS"
+ CPPFLAGS="$gl_saved_CPPFLAGS"
rm -rf conftestd1a conftestd1b conftestd2
])
PRAGMA_SYSTEM_HEADER=
diff --git a/m4/inttypes.m4 b/m4/inttypes.m4
index 73f4df8b038..6abf9dbe280 100644
--- a/m4/inttypes.m4
+++ b/m4/inttypes.m4
@@ -1,4 +1,4 @@
-# inttypes.m4 serial 36
+# inttypes.m4 serial 37
dnl Copyright (C) 2006-2024 Free Software Foundation, Inc.
dnl This file is free software; the Free Software Foundation
dnl gives unlimited permission to copy and/or distribute it,
@@ -170,6 +170,10 @@ AC_DEFUN([gl_INTTYPES_H_DEFAULTS],
HAVE_DECL_STRTOIMAX=1; AC_SUBST([HAVE_DECL_STRTOIMAX])
HAVE_DECL_STRTOUMAX=1; AC_SUBST([HAVE_DECL_STRTOUMAX])
HAVE_IMAXDIV_T=1; AC_SUBST([HAVE_IMAXDIV_T])
+ HAVE_IMAXABS=1; AC_SUBST([HAVE_IMAXABS])
+ HAVE_IMAXDIV=1; AC_SUBST([HAVE_IMAXDIV])
+ REPLACE_IMAXABS=0; AC_SUBST([REPLACE_IMAXABS])
+ REPLACE_IMAXDIV=0; AC_SUBST([REPLACE_IMAXDIV])
REPLACE_STRTOIMAX=0; AC_SUBST([REPLACE_STRTOIMAX])
REPLACE_STRTOUMAX=0; AC_SUBST([REPLACE_STRTOUMAX])
INT32_MAX_LT_INTMAX_MAX=1; AC_SUBST([INT32_MAX_LT_INTMAX_MAX])
diff --git a/m4/largefile.m4 b/m4/largefile.m4
index abee5479d62..cbe9bc1f63d 100644
--- a/m4/largefile.m4
+++ b/m4/largefile.m4
@@ -10,10 +10,9 @@
# It does not set _LARGEFILE_SOURCE=1 on HP-UX/ia64 32-bit, although this
# setting of _LARGEFILE_SOURCE is needed so that <stdio.h> declares fseeko
# and ftello in C++ mode as well.
-# Fixed in Autoconf 2.72, which has AC_SYS_YEAR2038.
+# This problem occurs in Autoconf 2.71 and earlier, which lack AC_SYS_YEAR2038.
AC_DEFUN([gl_SET_LARGEFILE_SOURCE],
-[
- m4_ifndef([AC_SYS_YEAR2038], [
+ m4_ifndef([AC_SYS_YEAR2038], [[
AC_REQUIRE([AC_CANONICAL_HOST])
AC_FUNC_FSEEKO
case "$host_os" in
@@ -22,58 +21,264 @@ AC_DEFUN([gl_SET_LARGEFILE_SOURCE],
[Define to 1 to make fseeko visible on some hosts (e.g. glibc 2.2).])
;;
esac
- ])
+ ]])
+)
+
+m4_ifndef([AC_SYS_YEAR2038_RECOMMENDED], [
+# Support AC_SYS_YEAR2038_RECOMMENDED and related macros, even if
+# Autoconf 2.71 or earlier. This code is taken from Autoconf master.
+
+# _AC_SYS_YEAR2038_TEST_CODE
+# --------------------------
+# C code used to probe for time_t that can represent time points more
+# than 2**31 - 1 seconds after the epoch. With the usual Unix epoch,
+# these correspond to dates after 2038-01-18 22:14:07 +0000 (Gregorian),
+# hence the name.
+AC_DEFUN([_AC_SYS_YEAR2038_TEST_CODE],
+[[
+ #include <time.h>
+ /* Check that time_t can represent 2**32 - 1 correctly. */
+ #define LARGE_TIME_T \\
+ ((time_t) (((time_t) 1 << 30) - 1 + 3 * ((time_t) 1 << 30)))
+ int verify_time_t_range[(LARGE_TIME_T / 65537 == 65535
+ && LARGE_TIME_T % 65537 == 0)
+ ? 1 : -1];
+]])
+
+# _AC_SYS_YEAR2038_OPTIONS
+# ------------------------
+# List of known ways to enable support for large time_t. If you change
+# this list you probably also need to change the AS_CASE at the end of
+# _AC_SYS_YEAR2038_PROBE.
+m4_define([_AC_SYS_YEAR2038_OPTIONS], m4_normalize(
+ ["none needed"] dnl 64-bit and newer 32-bit Unix
+ ["-D_TIME_BITS=64"] dnl glibc 2.34 with some 32-bit ABIs
+ ["-D__MINGW_USE_VC2005_COMPAT"] dnl 32-bit MinGW
+ ["-U_USE_32_BIT_TIME_T -D__MINGW_USE_VC2005_COMPAT"]
+ dnl 32-bit MinGW (misconfiguration)
+))
+
+# _AC_SYS_YEAR2038_PROBE
+# ----------------------
+# Subroutine of AC_SYS_YEAR2038. Probe for time_t that can represent
+# time points more than 2**31 - 1 seconds after the epoch (dates after
+# 2038-01-18, see above) and set the cache variable ac_cv_sys_year2038_opts
+# to one of the values in the _AC_SYS_YEAR2038_OPTIONS list, or to
+# "support not detected" if none of them worked. Then, set compilation
+# options and #defines as necessary to enable large time_t support.
+#
+# Note that we do not test whether mktime, localtime, etc. handle
+# large values of time_t correctly, as that would require use of
+# AC_TRY_RUN. Note also that some systems only support large time_t
+# together with large off_t.
+#
+# If you change this macro you may also need to change
+# _AC_SYS_YEAR2038_OPTIONS.
+AC_DEFUN([_AC_SYS_YEAR2038_PROBE],
+[AC_CACHE_CHECK([for $CC option for timestamps after 2038],
+ [ac_cv_sys_year2038_opts],
+ [ac_save_CPPFLAGS="$CPPFLAGS"
+ ac_opt_found=no
+ for ac_opt in _AC_SYS_YEAR2038_OPTIONS; do
+ AS_IF([test x"$ac_opt" != x"none needed"],
+ [CPPFLAGS="$ac_save_CPPFLAGS $ac_opt"])
+ AC_COMPILE_IFELSE([AC_LANG_PROGRAM([_AC_SYS_YEAR2038_TEST_CODE])],
+ [ac_cv_sys_year2038_opts="$ac_opt"
+ ac_opt_found=yes])
+ test $ac_opt_found = no || break
+ done
+ CPPFLAGS="$ac_save_CPPFLAGS"
+ test $ac_opt_found = yes || ac_cv_sys_year2038_opts="support not detected"])
+
+ac_have_year2038=yes
+AS_CASE([$ac_cv_sys_year2038_opts],
+ ["none needed"], [],
+ ["support not detected"],
+ [ac_have_year2038=no],
+
+ ["-D_TIME_BITS=64"],
+ [AC_DEFINE([_TIME_BITS], [64],
+ [Number of bits in time_t, on hosts where this is settable.])],
+
+ ["-D__MINGW_USE_VC2005_COMPAT"],
+ [AC_DEFINE([__MINGW_USE_VC2005_COMPAT], [1],
+ [Define to 1 on platforms where this makes time_t a 64-bit type.])],
+
+ ["-U_USE_32_BIT_TIME_T"*],
+ [AC_MSG_FAILURE(m4_text_wrap(
+ [the 'time_t' type is currently forced to be 32-bit.
+ It will stop working after mid-January 2038.
+ Remove _USE_32BIT_TIME_T from the compiler flags.],
+ [], [], [55]))],
+
+ [AC_MSG_ERROR(
+ [internal error: bad value for \$ac_cv_sys_year2038_opts])])
])
-# Work around a problem in Autoconf through 2.71 on glibc 2.34+
-# with _TIME_BITS. Also, work around a problem in autoconf <= 2.69:
-# AC_SYS_LARGEFILE does not configure for large inodes on Mac OS X 10.5,
-# or configures them incorrectly in some cases.
-m4_version_prereq([2.70], [], [
-
-# _AC_SYS_LARGEFILE_TEST_INCLUDES
-# -------------------------------
-m4_define([_AC_SYS_LARGEFILE_TEST_INCLUDES],
-[#include <sys/types.h>
- /* Check that off_t can represent 2**63 - 1 correctly.
- We can't simply define LARGE_OFF_T to be 9223372036854775807,
+# _AC_SYS_YEAR2038_ENABLE
+# -----------------------
+# Depending on which of the YEAR2038 macros was used, add either an
+# --enable-year2038 or a --disable-year2038 to
+# the configure script. This is expanded very late and
+# therefore there cannot be any code in the AC_ARG_ENABLE. The
+# default value for 'enable_year2038' is emitted unconditionally
+# because the generated code always looks at this variable.
+m4_define([_AC_SYS_YEAR2038_ENABLE],
+[m4_divert_text([DEFAULTS],
+ m4_provide_if([AC_SYS_YEAR2038],
+ [enable_year2038=yes],
+ [enable_year2038=no]))]dnl
+[AC_ARG_ENABLE([year2038],
+ m4_provide_if([AC_SYS_YEAR2038],
+ [AS_HELP_STRING([--disable-year2038],
+ [don't support timestamps after 2038])],
+ [AS_HELP_STRING([--enable-year2038],
+ [support timestamps after 2038])]))])
+
+# AC_SYS_YEAR2038
+# ---------------
+# Attempt to detect and activate support for large time_t.
+# On systems where time_t is not always 64 bits, this probe can be
+# skipped by passing the --disable-year2038 option to configure.
+AC_DEFUN([AC_SYS_YEAR2038],
+[AC_REQUIRE([AC_SYS_LARGEFILE])dnl
+AS_IF([test "$enable_year2038,$ac_have_year2038,$cross_compiling" = yes,no,no],
+ [# If we're not cross compiling and 'touch' works with a large
+ # timestamp, then we can presume the system supports wider time_t
+ # *somehow* and we just weren't able to detect it. One common
+ # case that we deliberately *don't* probe for is a system that
+ # supports both 32- and 64-bit ABIs but only the 64-bit ABI offers
+ # wide time_t. (It would be inappropriate for us to override an
+ # intentional use of -m32.) Error out, demanding use of
+ # --disable-year2038 if this is intentional.
+ AS_IF([TZ=UTC0 touch -t 210602070628.15 conftest.time 2>/dev/null],
+ [AS_CASE([`TZ=UTC0 LC_ALL=C ls -l conftest.time 2>/dev/null`],
+ [*'Feb 7 2106'* | *'Feb 7 17:10'*],
+ [AC_MSG_FAILURE(m4_text_wrap(
+ [this system appears to support timestamps after mid-January 2038,
+ but no mechanism for enabling wide 'time_t' was detected.
+ Did you mean to build a 64-bit binary? (E.g., 'CC="${CC} -m64"'.)
+ To proceed with 32-bit time_t, configure with '--disable-year2038'.],
+ [], [], [55]))])])])])
+
+# AC_SYS_YEAR2038_RECOMMENDED
+# ---------------------------
+# Same as AC_SYS_YEAR2038, but recommend support for large time_t.
+# If we cannot find any way to make time_t capable of representing
+# values larger than 2**31 - 1, error out unless --disable-year2038 is given.
+AC_DEFUN([AC_SYS_YEAR2038_RECOMMENDED],
+[AC_REQUIRE([AC_SYS_YEAR2038])dnl
+AS_IF([test "$enable_year2038,$ac_have_year2038" = yes,no],
+ [AC_MSG_FAILURE(m4_text_wrap(
+ [could not enable timestamps after mid-January 2038.
+ This package recommends support for these later timestamps.
+ However, to proceed with signed 32-bit time_t even though it
+ will fail then, configure with '--disable-year2038'.],
+ [], [], [55]))])])
+
+# _AC_SYS_LARGEFILE_TEST_CODE
+# ---------------------------
+# C code used to probe for large file support.
+m4_define([_AC_SYS_LARGEFILE_TEST_CODE],
+[@%:@include <sys/types.h>
+@%:@ifndef FTYPE
+@%:@ define FTYPE off_t
+@%:@endif
+ /* Check that FTYPE can represent 2**63 - 1 correctly.
+ We can't simply define LARGE_FTYPE to be 9223372036854775807,
since some C++ compilers masquerading as C compilers
incorrectly reject 9223372036854775807. */
-#define LARGE_OFF_T (((off_t) 1 << 31 << 31) - 1 + ((off_t) 1 << 31 << 31))
- int off_t_is_large[[(LARGE_OFF_T % 2147483629 == 721
- && LARGE_OFF_T % 2147483647 == 1)
- ? 1 : -1]];[]dnl
+@%:@define LARGE_FTYPE (((FTYPE) 1 << 31 << 31) - 1 + ((FTYPE) 1 << 31 << 31))
+ int FTYPE_is_large[[(LARGE_FTYPE % 2147483629 == 721
+ && LARGE_FTYPE % 2147483647 == 1)
+ ? 1 : -1]];[]dnl
])
-])# m4_version_prereq 2.70
-
-m4_ifndef([AC_SYS_YEAR2038], [
-
-# _AC_SYS_LARGEFILE_MACRO_VALUE(C-MACRO, VALUE,
-# CACHE-VAR,
-# DESCRIPTION,
-# PROLOGUE, [FUNCTION-BODY])
-# --------------------------------------------------------
-m4_define([_AC_SYS_LARGEFILE_MACRO_VALUE],
-[AC_CACHE_CHECK([for $1 value needed for large files], [$3],
-[while :; do
- m4_ifval([$6], [AC_LINK_IFELSE], [AC_COMPILE_IFELSE])(
- [AC_LANG_PROGRAM([$5], [$6])],
- [$3=no; break])
- m4_ifval([$6], [AC_LINK_IFELSE], [AC_COMPILE_IFELSE])(
- [AC_LANG_PROGRAM([#undef $1
-#define $1 $2
-$5], [$6])],
- [$3=$2; break])
- $3=unknown
- break
-done])
-case $$3 in #(
- no | unknown) ;;
- *) AC_DEFINE_UNQUOTED([$1], [$$3], [$4]);;
-esac
-rm -rf conftest*[]dnl
-])# _AC_SYS_LARGEFILE_MACRO_VALUE
+# Defined by Autoconf 2.71 and circa 2022 Gnulib unwisely depended on it.
+m4_define([_AC_SYS_LARGEFILE_TEST_INCLUDES], [_AC_SYS_LARGEFILE_TEST_CODE])
+
+# _AC_SYS_LARGEFILE_OPTIONS
+# -------------------------
+# List of known ways to enable support for large files. If you change
+# this list you probably also need to change the AS_CASE at the end of
+# _AC_SYS_LARGEFILE_PROBE.
+m4_define([_AC_SYS_LARGEFILE_OPTIONS], m4_normalize(
+ ["none needed"] dnl Most current systems
+ ["-D_FILE_OFFSET_BITS=64"] dnl X/Open LFS spec
+ ["-D_LARGE_FILES=1"] dnl 32-bit AIX 4.2.1+, 32-bit z/OS
+ ["-n32"] dnl 32-bit IRIX 6, SGI cc (obsolete)
+))
+
+# _AC_SYS_LARGEFILE_PROBE
+# -----------------------
+# Subroutine of AC_SYS_LARGEFILE. Probe for large file support and set
+# the cache variable ac_cv_sys_largefile_opts to one of the values in
+# the _AC_SYS_LARGEFILE_OPTIONS list, or to "support not detected" if
+# none of the options in that list worked. Then, set compilation
+# options and #defines as necessary to enable large file support.
+#
+# If large file support is not detected, the behavior depends on which of
+# the top-level AC_SYS_LARGEFILE macros was used (see below).
+#
+# If you change this macro you may also need to change
+# _AC_SYS_LARGEFILE_OPTIONS.
+AC_DEFUN([_AC_SYS_LARGEFILE_PROBE],
+[AC_CACHE_CHECK([for $CC option to enable large file support],
+ [ac_cv_sys_largefile_opts],
+ [ac_save_CC="$CC"
+ ac_opt_found=no
+ for ac_opt in _AC_SYS_LARGEFILE_OPTIONS; do
+ AS_IF([test x"$ac_opt" != x"none needed"],
+ [CC="$ac_save_CC $ac_opt"])
+ AC_COMPILE_IFELSE([AC_LANG_PROGRAM([_AC_SYS_LARGEFILE_TEST_CODE])],
+ [AS_IF([test x"$ac_opt" = x"none needed"],
+ [# GNU/Linux s390x and alpha need _FILE_OFFSET_BITS=64 for wide ino_t.
+ CC="$CC -DFTYPE=ino_t"
+ AC_COMPILE_IFELSE([], [],
+ [CC="$CC -D_FILE_OFFSET_BITS=64"
+ AC_COMPILE_IFELSE([], [ac_opt='-D_FILE_OFFSET_BITS=64'])])])
+ ac_cv_sys_largefile_opts=$ac_opt
+ ac_opt_found=yes])
+ test $ac_opt_found = no || break
+ done
+ CC="$ac_save_CC"
+ dnl Gnulib implements large file support for native Windows, based on the
+ dnl variables WINDOWS_64_BIT_OFF_T, WINDOWS_64_BIT_ST_SIZE.
+ m4_ifdef([gl_LARGEFILE], [
+ AC_REQUIRE([AC_CANONICAL_HOST])
+ if test $ac_opt_found != yes; then
+ AS_CASE([$host_os],
+ [mingw* | windows*],
+ [ac_cv_sys_largefile_opts="supported through gnulib"
+ ac_opt_found=yes]
+ )
+ fi
+ ])
+ test $ac_opt_found = yes || ac_cv_sys_largefile_opts="support not detected"])
+
+ac_have_largefile=yes
+AS_CASE([$ac_cv_sys_largefile_opts],
+ ["none needed"], [],
+ ["supported through gnulib"], [],
+ ["support not detected"],
+ [ac_have_largefile=no],
+
+ ["-D_FILE_OFFSET_BITS=64"],
+ [AC_DEFINE([_FILE_OFFSET_BITS], [64],
+ [Number of bits in a file offset, on hosts where this is settable.])],
+
+ ["-D_LARGE_FILES=1"],
+ [AC_DEFINE([_LARGE_FILES], [1],
+ [Define to 1 on platforms where this makes off_t a 64-bit type.])],
+
+ ["-n32"],
+ [CC="$CC -n32"],
+
+ [AC_MSG_ERROR(
+ [internal error: bad value for \$ac_cv_sys_largefile_opts])])
+AS_IF([test "$enable_year2038" != no],
+ [_AC_SYS_YEAR2038_PROBE])
+AC_CONFIG_COMMANDS_PRE([_AC_SYS_YEAR2038_ENABLE])])
# AC_SYS_LARGEFILE
# ----------------
@@ -85,44 +290,12 @@ rm -rf conftest*[]dnl
# to have a 64-bit inode number cannot be accessed by 32-bit applications on
# Linux x86/x86_64. This can occur with file systems such as XFS and NFS.
AC_DEFUN([AC_SYS_LARGEFILE],
-[AC_ARG_ENABLE(largefile,
- [ --disable-largefile omit support for large files])
-AS_IF([test "$enable_largefile" != no],
- [AC_CACHE_CHECK([for special C compiler options needed for large files],
- ac_cv_sys_largefile_CC,
- [ac_cv_sys_largefile_CC=no
- if test "$GCC" != yes; then
- ac_save_CC=$CC
- while :; do
- # IRIX 6.2 and later do not support large files by default,
- # so use the C compiler's -n32 option if that helps.
- AC_LANG_CONFTEST([AC_LANG_PROGRAM([_AC_SYS_LARGEFILE_TEST_INCLUDES])])
- AC_COMPILE_IFELSE([], [break])
- CC="$CC -n32"
- AC_COMPILE_IFELSE([], [ac_cv_sys_largefile_CC=' -n32'; break])
- break
- done
- CC=$ac_save_CC
- rm -f conftest.$ac_ext
- fi])
- if test "$ac_cv_sys_largefile_CC" != no; then
- CC=$CC$ac_cv_sys_largefile_CC
- fi
-
- _AC_SYS_LARGEFILE_MACRO_VALUE(_FILE_OFFSET_BITS, 64,
- ac_cv_sys_file_offset_bits,
- [Number of bits in a file offset, on hosts where this is settable.],
- [_AC_SYS_LARGEFILE_TEST_INCLUDES])
- AS_CASE([$ac_cv_sys_file_offset_bits],
- [unknown],
- [_AC_SYS_LARGEFILE_MACRO_VALUE([_LARGE_FILES], [1],
- [ac_cv_sys_large_files],
- [Define for large files, on AIX-style hosts.],
- [_AC_SYS_LARGEFILE_TEST_INCLUDES])],
- [64],
- [gl_YEAR2038_BODY([])])])
-])# AC_SYS_LARGEFILE
-])# m4_ifndef AC_SYS_YEAR2038
+[AC_ARG_ENABLE([largefile],
+ [AS_HELP_STRING([--disable-largefile],
+ [omit support for large files])])dnl
+AS_IF([test "$enable_largefile,$enable_year2038" != no,no],
+ [_AC_SYS_LARGEFILE_PROBE])])
+])# m4_ifndef AC_SYS_YEAR2038_RECOMMENDED
# Enable large files on systems where this is implemented by Gnulib, not by the
# system headers.
@@ -132,7 +305,7 @@ AC_DEFUN([gl_LARGEFILE],
[
AC_REQUIRE([AC_CANONICAL_HOST])
case "$host_os" in
- mingw*)
+ mingw* | windows*)
dnl Native Windows.
dnl mingw64 defines off_t to a 64-bit type already, if
dnl _FILE_OFFSET_BITS=64, which is ensured by AC_SYS_LARGEFILE.
diff --git a/m4/libgmp.m4 b/m4/libgmp.m4
index 43c7cac375a..782dfbae2e1 100644
--- a/m4/libgmp.m4
+++ b/m4/libgmp.m4
@@ -1,4 +1,4 @@
-# libgmp.m4 serial 7
+# libgmp.m4 serial 8
# Configure the GMP library or a replacement.
dnl Copyright 2020-2024 Free Software Foundation, Inc.
dnl This file is free software; the Free Software Foundation
@@ -15,7 +15,7 @@ dnl empty.
AC_DEFUN([gl_LIBGMP],
[
AC_ARG_WITH([libgmp],
- [AS_HELP_STRING([--without-libgmp],
+ [AS_HELP_STRING([[--without-libgmp]],
[do not use the GNU Multiple Precision (GMP) library;
this is the default on systems lacking libgmp.])])
HAVE_LIBGMP=no
diff --git a/m4/limits-h.m4 b/m4/limits-h.m4
index 8588c193c7d..1825328380b 100644
--- a/m4/limits-h.m4
+++ b/m4/limits-h.m4
@@ -23,14 +23,27 @@ AC_DEFUN_ONCE([gl_LIMITS_H],
int wb = WORD_BIT;
int ullw = ULLONG_WIDTH;
int bw = BOOL_WIDTH;
+ int bm = BOOL_MAX;
+ int mblm = MB_LEN_MAX;
]])],
[gl_cv_header_limits_width=yes],
[gl_cv_header_limits_width=no])])
- if test "$gl_cv_header_limits_width" = yes; then
- GL_GENERATE_LIMITS_H=false
- else
- GL_GENERATE_LIMITS_H=true
- fi
+ GL_GENERATE_LIMITS_H=true
+ AS_IF([test "$gl_cv_header_limits_width" = yes],
+ [AC_CACHE_CHECK([whether limits.h has SSIZE_MAX],
+ [gl_cv_header_limits_ssize_max],
+ [AC_COMPILE_IFELSE(
+ [AC_LANG_SOURCE(
+ [[#include <limits.h>
+ #ifndef SSIZE_MAX
+ #error "SSIZE_MAX is not defined"
+ #endif
+ ]])],
+ [gl_cv_header_limits_ssize_max=yes],
+ [gl_cv_header_limits_ssize_max=no])])
+ if test "$gl_cv_header_limits_ssize_max" = yes; then
+ GL_GENERATE_LIMITS_H=false
+ fi])
])
dnl Unconditionally enables the replacement of <limits.h>.
diff --git a/m4/lstat.m4 b/m4/lstat.m4
index 38b6c471765..48cc8653fe6 100644
--- a/m4/lstat.m4
+++ b/m4/lstat.m4
@@ -1,4 +1,4 @@
-# serial 33
+# serial 36
# Copyright (C) 1997-2001, 2003-2024 Free Software Foundation, Inc.
#
@@ -18,7 +18,7 @@ AC_DEFUN([gl_FUNC_LSTAT],
if test $ac_cv_func_lstat = yes; then
AC_REQUIRE([gl_FUNC_LSTAT_FOLLOWS_SLASHED_SYMLINK])
case $host_os,$gl_cv_func_lstat_dereferences_slashed_symlink in
- solaris* | *no)
+ darwin* | solaris* | *no)
REPLACE_LSTAT=1
;;
esac
@@ -56,10 +56,13 @@ AC_DEFUN([gl_FUNC_LSTAT_FOLLOWS_SLASHED_SYMLINK],
linux-* | linux)
# Guess yes on Linux systems.
gl_cv_func_lstat_dereferences_slashed_symlink="guessing yes" ;;
+ midipix*)
+ # Guess yes on systems that emulate the Linux system calls.
+ gl_cv_func_lstat_dereferences_slashed_symlink="guessing yes" ;;
*-gnu* | gnu*)
# Guess yes on glibc systems.
gl_cv_func_lstat_dereferences_slashed_symlink="guessing yes" ;;
- mingw*)
+ mingw* | windows*)
# Guess no on native Windows.
gl_cv_func_lstat_dereferences_slashed_symlink="guessing no" ;;
*)
diff --git a/m4/malloc.m4 b/m4/malloc.m4
index 734d68e54be..635d6726b11 100644
--- a/m4/malloc.m4
+++ b/m4/malloc.m4
@@ -1,4 +1,4 @@
-# malloc.m4 serial 28
+# malloc.m4 serial 31
dnl Copyright (C) 2007, 2009-2024 Free Software Foundation, Inc.
dnl This file is free software; the Free Software Foundation
dnl gives unlimited permission to copy and/or distribute it,
@@ -16,7 +16,8 @@ AC_DEFUN([_AC_FUNC_MALLOC_IF],
[[#include <stdlib.h>
]],
[[void *p = malloc (0);
- int result = !p;
+ void * volatile vp = p;
+ int result = !vp;
free (p);
return result;]])
],
@@ -25,8 +26,8 @@ AC_DEFUN([_AC_FUNC_MALLOC_IF],
[case "$host_os" in
# Guess yes on platforms where we know the result.
*-gnu* | freebsd* | netbsd* | openbsd* | bitrig* \
- | gnu* | *-musl* | midnightbsd* \
- | hpux* | solaris* | cygwin* | mingw* | msys* )
+ | gnu* | *-musl* | midipix* | midnightbsd* \
+ | hpux* | solaris* | cygwin* | mingw* | windows* | msys* )
ac_cv_func_malloc_0_nonnull="guessing yes" ;;
# If we don't know, obey --enable-cross-guesses.
*) ac_cv_func_malloc_0_nonnull="$gl_cross_guess_normal" ;;
@@ -128,7 +129,7 @@ AC_DEFUN([gl_CHECK_MALLOC_POSIX],
dnl except on those platforms where we have seen 'test-malloc-gnu',
dnl 'test-realloc-gnu', 'test-calloc-gnu' fail.
case "$host_os" in
- mingw*)
+ mingw* | windows*)
gl_cv_func_malloc_posix=no ;;
irix* | solaris*)
dnl On IRIX 6.5, the three functions return NULL with errno unset
diff --git a/m4/manywarnings.m4 b/m4/manywarnings.m4
index 7402edcddfd..3c6795ceb28 100644
--- a/m4/manywarnings.m4
+++ b/m4/manywarnings.m4
@@ -1,4 +1,4 @@
-# manywarnings.m4 serial 23
+# manywarnings.m4 serial 25
dnl Copyright (C) 2008-2024 Free Software Foundation, Inc.
dnl This file is free software; the Free Software Foundation
dnl gives unlimited permission to copy and/or distribute it,
@@ -6,6 +6,8 @@ dnl with or without modifications, as long as this notice is preserved.
dnl From Simon Josefsson
+AC_PREREQ([2.64])
+
# gl_MANYWARN_COMPLEMENT(OUTVAR, LISTVAR, REMOVEVAR)
# --------------------------------------------------
# Copy LISTVAR to OUTVAR except for the entries in REMOVEVAR.
@@ -21,7 +23,7 @@ AC_DEFUN([gl_MANYWARN_COMPLEMENT],
*" $gl_warn_item "*)
;;
*)
- gl_AS_VAR_APPEND([gl_warn_set], [" $gl_warn_item"])
+ AS_VAR_APPEND([gl_warn_set], [" $gl_warn_item"])
;;
esac
done
@@ -46,59 +48,46 @@ AC_DEFUN([gl_MANYWARN_ALL_GCC(C)],
dnl First, check for some issues that only occur when combining multiple
dnl gcc warning categories.
AC_REQUIRE([AC_PROG_CC])
- if test -n "$GCC"; then
-
- dnl Check if -Wextra -Werror -Wno-missing-field-initializers is supported
- dnl with the current $CC $CFLAGS $CPPFLAGS.
- AC_CACHE_CHECK([whether -Wno-missing-field-initializers is supported],
- [gl_cv_cc_nomfi_supported],
- [gl_save_CFLAGS="$CFLAGS"
- CFLAGS="$CFLAGS -Wextra -Werror -Wno-missing-field-initializers"
+ AS_IF([test -n "$GCC"], [
+ AC_CACHE_CHECK([whether -Wno-missing-field-initializers is needed],
+ [gl_cv_cc_nomfi_needed],
+ [gl_cv_cc_nomfi_needed=no
+ gl_saved_CFLAGS="$CFLAGS"
+ CFLAGS="$CFLAGS -Wextra -Werror"
AC_COMPILE_IFELSE(
- [AC_LANG_PROGRAM([[]], [[]])],
- [gl_cv_cc_nomfi_supported=yes],
- [gl_cv_cc_nomfi_supported=no])
- CFLAGS="$gl_save_CFLAGS"
- ])
-
- if test "$gl_cv_cc_nomfi_supported" = yes; then
- dnl Now check whether -Wno-missing-field-initializers is needed
- dnl for the { 0, } construct.
- AC_CACHE_CHECK([whether -Wno-missing-field-initializers is needed],
- [gl_cv_cc_nomfi_needed],
- [gl_save_CFLAGS="$CFLAGS"
- CFLAGS="$CFLAGS -Wextra -Werror"
- AC_COMPILE_IFELSE(
- [AC_LANG_PROGRAM(
- [[int f (void)
- {
- typedef struct { int a; int b; } s_t;
- s_t s1 = { 0, };
- return s1.b;
- }
- ]],
- [[]])],
- [gl_cv_cc_nomfi_needed=no],
- [gl_cv_cc_nomfi_needed=yes])
- CFLAGS="$gl_save_CFLAGS"
- ])
- fi
+ [AC_LANG_PROGRAM(
+ [[struct file_data { int desc, name; };
+ struct cmp { struct file_data file[1]; };
+ void f (struct cmp *r)
+ {
+ typedef struct { int a; int b; } s_t;
+ s_t s1 = { 0, };
+ struct cmp cmp = { .file[0].desc = r->file[0].desc + s1.a };
+ *r = cmp;
+ }
+ ]],
+ [[]])],
+ [],
+ [CFLAGS="$CFLAGS -Wno-missing-field-initializers"
+ AC_COMPILE_IFELSE([],
+ [gl_cv_cc_nomfi_needed=yes])])
+ CFLAGS="$gl_saved_CFLAGS"
+ ])
dnl Next, check if -Werror -Wuninitialized is useful with the
dnl user's choice of $CFLAGS; some versions of gcc warn that it
dnl has no effect if -O is not also used
AC_CACHE_CHECK([whether -Wuninitialized is supported],
[gl_cv_cc_uninitialized_supported],
- [gl_save_CFLAGS="$CFLAGS"
+ [gl_saved_CFLAGS="$CFLAGS"
CFLAGS="$CFLAGS -Werror -Wuninitialized"
AC_COMPILE_IFELSE(
[AC_LANG_PROGRAM([[]], [[]])],
[gl_cv_cc_uninitialized_supported=yes],
[gl_cv_cc_uninitialized_supported=no])
- CFLAGS="$gl_save_CFLAGS"
+ CFLAGS="$gl_saved_CFLAGS"
])
-
- fi
+ ])
# List all gcc warning categories.
# To compare this list to your installed GCC's, run this Bash command:
@@ -109,7 +98,7 @@ AC_DEFUN([gl_MANYWARN_ALL_GCC(C)],
# <(LC_ALL=C gcc --help=warnings | sed -n 's/^ \(-[^ ]*\) .*/\1/p' | sort)
$1=
- for gl_manywarn_item in -fanalyzer -fno-common \
+ for gl_manywarn_item in -fanalyzer -fstrict-flex-arrays \
-Wall \
-Warith-conversion \
-Wbad-function-cast \
@@ -137,6 +126,7 @@ AC_DEFUN([gl_MANYWARN_ALL_GCC(C)],
-Wpointer-arith \
-Wshadow \
-Wstack-protector \
+ -Wstrict-flex-arrays \
-Wstrict-overflow \
-Wstrict-prototypes \
-Wsuggest-attribute=cold \
@@ -160,46 +150,51 @@ AC_DEFUN([gl_MANYWARN_ALL_GCC(C)],
-Wwrite-strings \
\
; do
- gl_AS_VAR_APPEND([$1], [" $gl_manywarn_item"])
+ AS_VAR_APPEND([$1], [" $gl_manywarn_item"])
done
# gcc --help=warnings outputs an unusual form for these options; list
# them here so that the above 'comm' command doesn't report a false match.
- gl_AS_VAR_APPEND([$1], [' -Warray-bounds=2'])
- gl_AS_VAR_APPEND([$1], [' -Wattribute-alias=2'])
- gl_AS_VAR_APPEND([$1], [' -Wbidi-chars=any,ucn'])
- gl_AS_VAR_APPEND([$1], [' -Wformat-overflow=2'])
- gl_AS_VAR_APPEND([$1], [' -Wformat=2'])
- gl_AS_VAR_APPEND([$1], [' -Wformat-truncation=2'])
- gl_AS_VAR_APPEND([$1], [' -Wimplicit-fallthrough=5'])
- gl_AS_VAR_APPEND([$1], [' -Wshift-overflow=2'])
- gl_AS_VAR_APPEND([$1], [' -Wuse-after-free=3'])
- gl_AS_VAR_APPEND([$1], [' -Wunused-const-variable=2'])
- gl_AS_VAR_APPEND([$1], [' -Wvla-larger-than=4031'])
+ AS_VAR_APPEND([$1], [' -Warray-bounds=2'])
+ AS_VAR_APPEND([$1], [' -Wattribute-alias=2'])
+ AS_VAR_APPEND([$1], [' -Wbidi-chars=any,ucn'])
+ AS_VAR_APPEND([$1], [' -Wformat-overflow=2'])
+ AS_VAR_APPEND([$1], [' -Wformat=2'])
+ AS_VAR_APPEND([$1], [' -Wformat-truncation=2'])
+ AS_VAR_APPEND([$1], [' -Wimplicit-fallthrough=5'])
+ AS_VAR_APPEND([$1], [' -Wshift-overflow=2'])
+ AS_VAR_APPEND([$1], [' -Wuse-after-free=3'])
+ AS_VAR_APPEND([$1], [' -Wunused-const-variable=2'])
+ AS_VAR_APPEND([$1], [' -Wvla-larger-than=4031'])
# These are needed for older GCC versions.
- if test -n "$GCC"; then
- case `($CC --version) 2>/dev/null` in
+ if test -n "$GCC" && gl_gcc_version=`($CC --version) 2>/dev/null`; then
+ case $gl_gcc_version in
'gcc (GCC) '[[0-3]].* | \
'gcc (GCC) '4.[[0-7]].*)
- gl_AS_VAR_APPEND([$1], [' -fdiagnostics-show-option'])
- gl_AS_VAR_APPEND([$1], [' -funit-at-a-time'])
+ AS_VAR_APPEND([$1], [' -fdiagnostics-show-option'])
+ AS_VAR_APPEND([$1], [' -funit-at-a-time'])
+ ;;
+ esac
+ case $gl_gcc_version in
+ 'gcc (GCC) '[[0-9]].*)
+ AS_VAR_APPEND([$1], [' -fno-common'])
;;
esac
fi
# Disable specific options as needed.
if test "$gl_cv_cc_nomfi_needed" = yes; then
- gl_AS_VAR_APPEND([$1], [' -Wno-missing-field-initializers'])
+ AS_VAR_APPEND([$1], [' -Wno-missing-field-initializers'])
fi
if test "$gl_cv_cc_uninitialized_supported" = no; then
- gl_AS_VAR_APPEND([$1], [' -Wno-uninitialized'])
+ AS_VAR_APPEND([$1], [' -Wno-uninitialized'])
fi
# This warning have too many false alarms in GCC 11.2.1.
# https://gcc.gnu.org/bugzilla/show_bug.cgi?id=101713
- gl_AS_VAR_APPEND([$1], [' -Wno-analyzer-malloc-leak'])
+ AS_VAR_APPEND([$1], [' -Wno-analyzer-malloc-leak'])
AC_LANG_POP([C])
])
diff --git a/m4/mempcpy.m4 b/m4/mempcpy.m4
index 088a1f8334a..94ce05d1a6a 100644
--- a/m4/mempcpy.m4
+++ b/m4/mempcpy.m4
@@ -1,6 +1,6 @@
-# mempcpy.m4 serial 12
-dnl Copyright (C) 2003-2004, 2006-2007, 2009-2024 Free Software
-dnl Foundation, Inc.
+# mempcpy.m4 serial 14
+dnl Copyright (C) 2003-2004, 2006-2007, 2009-2024 Free Software Foundation,
+dnl Inc.
dnl This file is free software; the Free Software Foundation
dnl gives unlimited permission to copy and/or distribute it,
dnl with or without modifications, as long as this notice is preserved.
@@ -14,9 +14,12 @@ AC_DEFUN([gl_FUNC_MEMPCPY],
AC_REQUIRE([AC_C_RESTRICT])
AC_REQUIRE([gl_STRING_H_DEFAULTS])
- AC_CHECK_FUNCS([mempcpy])
+ gl_CHECK_FUNCS_ANDROID([mempcpy], [[#include <string.h>]])
if test $ac_cv_func_mempcpy = no; then
HAVE_MEMPCPY=0
+ case "$gl_cv_onwards_func_mempcpy" in
+ future*) REPLACE_MEMPCPY=1 ;;
+ esac
fi
])
diff --git a/m4/memrchr.m4 b/m4/memrchr.m4
index 21604f0ef94..b4ccdfa3c8d 100644
--- a/m4/memrchr.m4
+++ b/m4/memrchr.m4
@@ -1,6 +1,6 @@
# memrchr.m4 serial 11
-dnl Copyright (C) 2002-2003, 2005-2007, 2009-2024 Free Software
-dnl Foundation, Inc.
+dnl Copyright (C) 2002-2003, 2005-2007, 2009-2024 Free Software Foundation,
+dnl Inc.
dnl This file is free software; the Free Software Foundation
dnl gives unlimited permission to copy and/or distribute it,
dnl with or without modifications, as long as this notice is preserved.
diff --git a/m4/memset_explicit.m4 b/m4/memset_explicit.m4
new file mode 100644
index 00000000000..19514ff917e
--- /dev/null
+++ b/m4/memset_explicit.m4
@@ -0,0 +1,24 @@
+# memset_explicit.m4 serial 2
+dnl Copyright 2022-2024 Free Software Foundation, Inc.
+dnl This file is free software; the Free Software Foundation
+dnl gives unlimited permission to copy and/or distribute it,
+dnl with or without modifications, as long as this notice is preserved.
+
+AC_DEFUN([gl_FUNC_MEMSET_EXPLICIT],
+[
+ AC_REQUIRE([gl_STRING_H_DEFAULTS])
+
+ gl_CHECK_FUNCS_ANDROID([memset_explicit], [[#include <string.h>]])
+ if test $ac_cv_func_memset_explicit = no; then
+ HAVE_MEMSET_EXPLICIT=0
+ case "$gl_cv_onwards_func_memset_explicit" in
+ future*) REPLACE_MEMSET_EXPLICIT=1 ;;
+ esac
+ fi
+])
+
+AC_DEFUN([gl_PREREQ_MEMSET_EXPLICIT],
+[
+ AC_CHECK_FUNCS([explicit_memset])
+ AC_CHECK_FUNCS_ONCE([memset_s])
+])
diff --git a/m4/mkostemp.m4 b/m4/mkostemp.m4
index efcd1b1cd11..1c22b8d51b4 100644
--- a/m4/mkostemp.m4
+++ b/m4/mkostemp.m4
@@ -1,4 +1,4 @@
-# mkostemp.m4 serial 2
+# mkostemp.m4 serial 4
dnl Copyright (C) 2009-2024 Free Software Foundation, Inc.
dnl This file is free software; the Free Software Foundation
dnl gives unlimited permission to copy and/or distribute it,
@@ -11,9 +11,12 @@ AC_DEFUN([gl_FUNC_MKOSTEMP],
dnl Persuade glibc <stdlib.h> to declare mkostemp().
AC_REQUIRE([AC_USE_SYSTEM_EXTENSIONS])
- AC_CHECK_FUNCS_ONCE([mkostemp])
+ gl_CHECK_FUNCS_ANDROID([mkostemp], [[#include <stdlib.h>]])
if test $ac_cv_func_mkostemp != yes; then
HAVE_MKOSTEMP=0
+ case "$gl_cv_onwards_func_mkostemp" in
+ future*) REPLACE_MKOSTEMP=1 ;;
+ esac
fi
])
diff --git a/m4/mktime.m4 b/m4/mktime.m4
index cf79406b142..0565e5e61fe 100644
--- a/m4/mktime.m4
+++ b/m4/mktime.m4
@@ -1,6 +1,6 @@
-# serial 37
-dnl Copyright (C) 2002-2003, 2005-2007, 2009-2024 Free Software
-dnl Foundation, Inc.
+# serial 39
+dnl Copyright (C) 2002-2003, 2005-2007, 2009-2024 Free Software Foundation,
+dnl Inc.
dnl This file is free software; the Free Software Foundation
dnl gives unlimited permission to copy and/or distribute it,
dnl with or without modifications, as long as this notice is preserved.
@@ -264,9 +264,9 @@ main ()
[gl_cv_func_working_mktime=yes],
[gl_cv_func_working_mktime=no],
[case "$host_os" in
- # Guess no on native Windows.
- mingw*) gl_cv_func_working_mktime="guessing no" ;;
- *) gl_cv_func_working_mktime="$gl_cross_guess_normal" ;;
+ # Guess no on native Windows.
+ mingw* | windows*) gl_cv_func_working_mktime="guessing no" ;;
+ *) gl_cv_func_working_mktime="$gl_cross_guess_normal" ;;
esac
])
fi
@@ -280,7 +280,6 @@ AC_DEFUN([gl_FUNC_MKTIME],
AC_REQUIRE([AC_CANONICAL_HOST])
AC_REQUIRE([gl_FUNC_MKTIME_WORKS])
- REPLACE_MKTIME=0
if test "$gl_cv_func_working_mktime" != yes; then
REPLACE_MKTIME=1
AC_DEFINE([NEED_MKTIME_WORKING], [1],
@@ -288,7 +287,7 @@ AC_DEFUN([gl_FUNC_MKTIME],
with the algorithmic workarounds.])
fi
case "$host_os" in
- mingw*)
+ mingw* | windows*)
REPLACE_MKTIME=1
AC_DEFINE([NEED_MKTIME_WINDOWS], [1],
[Define if the compilation of mktime.c should define 'mktime'
diff --git a/m4/musl.m4 b/m4/musl.m4
new file mode 100644
index 00000000000..34d2c1ff22a
--- /dev/null
+++ b/m4/musl.m4
@@ -0,0 +1,20 @@
+# musl.m4 serial 4
+dnl Copyright (C) 2019-2024 Free Software Foundation, Inc.
+dnl This file is free software; the Free Software Foundation
+dnl gives unlimited permission to copy and/or distribute it,
+dnl with or without modifications, as long as this notice is preserved.
+
+# Test for musl libc, despite the musl libc authors don't like it
+# <https://wiki.musl-libc.org/faq.html>
+# <https://lists.gnu.org/archive/html/bug-gnulib/2018-02/msg00079.html>.
+# From Bruno Haible.
+
+AC_DEFUN_ONCE([gl_MUSL_LIBC],
+[
+ AC_REQUIRE([AC_CANONICAL_HOST])
+ case "$host_os" in
+ *-musl* | midipix*)
+ AC_DEFINE([MUSL_LIBC], [1], [Define to 1 on musl libc.])
+ ;;
+ esac
+])
diff --git a/m4/nanosleep.m4 b/m4/nanosleep.m4
index 51083cb65b5..ff730b676cd 100644
--- a/m4/nanosleep.m4
+++ b/m4/nanosleep.m4
@@ -1,4 +1,4 @@
-# serial 42
+# serial 47
dnl From Jim Meyering.
dnl Check for the nanosleep function.
@@ -21,15 +21,15 @@ AC_DEFUN([gl_FUNC_NANOSLEEP],
AC_CHECK_DECLS_ONCE([alarm])
- nanosleep_save_libs=$LIBS
+ gl_saved_LIBS=$LIBS
# Solaris 2.5.1 needs -lposix4 to get the nanosleep function.
# Solaris 7 prefers the library name -lrt to the obsolescent name -lposix4.
- LIB_NANOSLEEP=
- AC_SUBST([LIB_NANOSLEEP])
+ NANOSLEEP_LIB=
+ AC_SUBST([NANOSLEEP_LIB])
AC_SEARCH_LIBS([nanosleep], [rt posix4],
[test "$ac_cv_search_nanosleep" = "none required" ||
- LIB_NANOSLEEP=$ac_cv_search_nanosleep])
+ NANOSLEEP_LIB=$ac_cv_search_nanosleep])
if test "x$ac_cv_search_nanosleep" != xno; then
dnl The system has a nanosleep function.
@@ -116,19 +116,24 @@ AC_DEFUN([gl_FUNC_NANOSLEEP],
*) gl_cv_func_nanosleep=no ;;
esac],
[case "$host_os" in
- linux*) # Guess it halfway works when the kernel is Linux.
+ # Guess it halfway works when the kernel is Linux.
+ linux*)
gl_cv_func_nanosleep='guessing no (mishandles large arguments)' ;;
- mingw*) # Guess no on native Windows.
+ # Midipix generally emulates the Linux system calls,
+ # but here it handles large arguments correctly.
+ midipix*)
+ gl_cv_func_nanosleep='guessing yes' ;;
+ # Guess no on native Windows.
+ mingw* | windows*)
gl_cv_func_nanosleep='guessing no' ;;
- *) # If we don't know, obey --enable-cross-guesses.
+ # If we don't know, obey --enable-cross-guesses.
+ *)
gl_cv_func_nanosleep="$gl_cross_guess_normal" ;;
esac
])
])
case "$gl_cv_func_nanosleep" in
- *yes)
- REPLACE_NANOSLEEP=0
- ;;
+ *yes) ;;
*)
REPLACE_NANOSLEEP=1
case "$gl_cv_func_nanosleep" in
@@ -142,5 +147,9 @@ AC_DEFUN([gl_FUNC_NANOSLEEP],
else
HAVE_NANOSLEEP=0
fi
- LIBS=$nanosleep_save_libs
+ LIBS=$gl_saved_LIBS
+
+ # For backward compatibility.
+ LIB_NANOSLEEP="$NANOSLEEP_LIB"
+ AC_SUBST([LIB_NANOSLEEP])
])
diff --git a/m4/ndk-build.m4 b/m4/ndk-build.m4
new file mode 100644
index 00000000000..7012471e046
--- /dev/null
+++ b/m4/ndk-build.m4
@@ -0,0 +1,651 @@
+dnl Copyright (C) 2023-2024 Free Software Foundation, Inc.
+dnl This file is part of GNU Emacs.
+
+dnl GNU Emacs is free software: you can redistribute it and/or modify
+dnl it under the terms of the GNU General Public License as published by
+dnl the Free Software Foundation, either version 3 of the License, or
+dnl (at your option) any later version.
+
+dnl GNU Emacs is distributed in the hope that it will be useful,
+dnl but WITHOUT ANY WARRANTY; without even the implied warranty of
+dnl MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+dnl GNU General Public License for more details.
+
+dnl You should have received a copy of the GNU General Public License
+dnl along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>.
+
+# Support for building Emacs with dependencies using the Android NDK
+# build system.
+
+AC_ARG_WITH([ndk_path],
+ [AS_HELP_STRING([--with-ndk-path],
+ [find Android libraries in these directories])])
+
+AC_ARG_WITH([ndk_cxx],
+ [AS_HELP_STRING([--with-ndk-cxx],
+ [name of the C++ compiler included with the NDK])])
+
+# ndk_INIT(ABI, API, DIR, CFLAGS)
+# -------------------------------
+# Initialize the Android NDK. ABI is the ABI being built for.
+# API is the API version being built for.
+# CFLAGS is a list of compiler flags.
+# As a side effect, set the variable ndk_INITIALIZED to true.
+# DIR should be a directory containing the Makefile.in actually
+# implementing the Android NDK build system.
+
+AC_DEFUN([ndk_INIT],
+[
+# Look for Android.mk files.
+ndk_module_files=
+for file in $with_ndk_path; do
+ if test -f $file/Android.mk; then
+ ndk_module_files="$ndk_module_files$file/Android.mk "
+ fi
+done
+
+AC_REQUIRE_AUX_FILE([ndk-build-helper.mk])
+ndk_AUX_DIR=$ac_aux_dir
+ndk_ABI=$1
+ndk_MODULES=
+ndk_MAKEFILES=
+ndk_INITIALIZED=yes
+ndk_API=$2
+ndk_DIR=$3
+ndk_ANY_CXX=
+ndk_BUILD_CFLAGS="$4"
+ndk_working_cxx=no
+ndk_CXX_SHARED=
+
+AS_CASE(["$ndk_ABI"],
+ [*arm64*], [ndk_ARCH=arm64],
+ [*arm*], [ndk_ARCH=arm],
+ [*x86_64*], [ndk_ARCH=x86_64],
+ [*x86*], [ndk_ARCH=x86],
+ [*mips64*], [ndk_ARCH=mips64],
+ [*mips*], [ndk_ARCH=mips],
+ [AC_MSG_ERROR([Failed to determine Android device architecture])])
+
+# This is a map between pkg-config style package names and Android
+# ones.
+
+ndk_package_map="libwebpdemux:webpdemux libxml-2.0:libxml2 jansson:libjansson"
+ndk_package_map="$ndk_package_map sqlite3:libsqlite_static_minimal"
+ndk_package_map="$ndk_package_map MagickWand:libmagickwand-7 lcms2:liblcms2"
+
+# Replace ndk_module with the appropriate Android module name if it is
+# found in ndk_package_map.
+
+ndk_replace_pkg_config_package () {
+ for ndk_stuff in $ndk_package_map; do
+ ndk_key=`AS_ECHO([$ndk_stuff]) | cut -d: -f1`
+ ndk_value=`AS_ECHO([$ndk_stuff]) | cut -d: -f2`
+
+ if test "$ndk_key" = "$ndk_module"; then
+ ndk_module="$ndk_value"
+ break
+ fi
+ done
+}
+
+# Run the Makefile helper script for the Android.mk file.
+
+ndk_run_test () {
+ # Figure out where the helper Makefile is.
+ ndk_build_helper_file="${ndk_AUX_DIR}ndk-build-helper.mk"
+ ndk_module_extract_awk="${ndk_AUX_DIR}ndk-module-extract.awk"
+ ndk_dir=`AS_DIRNAME([$ndk_android_mk])`
+
+ # Now call Make with the right arguments.
+ "$MAKE" -s -f "$ndk_build_helper_file" EMACS_SRCDIR=`pwd` \
+ EMACS_ABI="$ndk_ABI" ANDROID_MAKEFILE="$ndk_android_mk" \
+ NDK_BUILD_DIR="$ndk_DIR" NDK_ROOT="/tmp" \
+ ANDROID_MODULE_DIRECTORY="$ndk_dir" BUILD_AUXDIR=$ndk_AUX_DIR \
+ NDK_BUILD_ARCH="$ndk_ARCH" 2>&AS_MESSAGE_LOG_FD >conftest.ndk
+
+ # Read the output.
+ cat conftest.ndk | awk -f "$ndk_module_extract_awk" MODULE="$ndk_module"
+
+ # Remove the temporary file.
+ rm -f conftest.ndk
+}
+
+# ndk_parse_pkg_config_string PKG_CONFIG_STRING
+# ---------------------------------------------
+# Parse a pkg-config style list of modules. Place the resulting list
+# in ndk_modules.
+
+ndk_parse_pkg_config_string () {
+ ndk_input=[$]1
+ ndk_modules=
+ while test -n "$ndk_input"; do
+ ndk_str=`AS_ECHO_N(["$ndk_input"]) | cut -f1 -d' '`
+ ndk_input=`AS_ECHO_N(["$ndk_input"]) | cut -s -f2- -d' '`
+
+ if test "$ndk_str" = ">=" || test "$ndk_str" = "<=" \
+ || test "$ndk_str" = ">" || test "$ndk_str" = "<" \
+ || test "$ndk_str" = "!="; then
+ ndk_input=`AS_ECHO_N(["$ndk_input"]) | cut -s -f2- -d' '`
+ else
+ ndk_modules="$ndk_modules$ndk_str "
+ fi
+ done
+}
+
+# ndk_resolve_import_module MODULE
+# --------------------------------
+# Resolve MODULE, a single import. Prepend its makefile to
+# ndk_MAKEFILES if found. Also, prepend all includes to the variable
+# ndk_import_includes.
+
+ndk_resolve_import_module () {
+ module_name=
+ ndk_module=[$]1
+
+ AC_MSG_CHECKING([for imported $ndk_module])
+
+ for ndk_android_mk in $ndk_module_files; do
+ # Read this Android.mk file. Set NDK_ROOT to /tmp: the Android in
+ # tree build system sets it to a meaningful value, but build files
+ # just use it to test whether or not the NDK is being used.
+ ndk_commands=`ndk_run_test`
+ eval "$ndk_commands"
+
+ if test -n "$module_name"; then
+ break;
+ fi
+ done
+
+ AS_IF([test -z "$module_name"],
+ [AC_MSG_RESULT([no])
+ AC_MSG_ERROR([The module currently being built depends on [$]1, but \
+that could not be found in the list of directories specified in \
+`--with-ndk-path'.])])
+
+ if test -n "$module_cxx_deps"; then
+ ndk_ANY_CXX=yes
+ fi
+
+ AS_IF([test "$module_cxx_deps" = "yes" && test -z "$ndk_CXX_STL" \
+ && test -z "$ndk_CXX_LDFLAGS"],
+ [AC_MSG_ERROR([The module $1 requires a C++ standard library,
+but none were found.])])
+
+ AS_IF([test "$module_cxx_deps" = "yes" && test "$ndk_working_cxx" != "yes"],
+ [AC_MSG_ERROR([The module [$]1 requires the C++ standard library,
+but a working C++ compiler was not found.])])
+
+ AC_MSG_RESULT([yes])
+
+ # Make sure the module is prepended.
+ ndk_MAKEFILES="$ndk_android_mk $ndk_MAKEFILES"
+ ndk_import_includes="$module_includes $ndk_import_includes"
+
+ # Now recursively resolve this module's imports.
+ for ndk_module in $module_imports; do
+ ndk_resolve_import_module $ndk_module
+ done
+}
+
+# ndk_filter_cc_for_cxx
+# ---------------------
+# Run through $CC, removing any options that are not suitable for
+# use in a C++ compiler.
+
+ndk_filter_cc_for_cxx () {
+ for ndk_word in $CC; do
+ AS_CASE([$ndk_word], [*-std=*], [],
+ [AS_ECHO_N(["$ndk_word "])])
+ done
+}
+
+# ndk_subst_cc_onto_cxx
+# ---------------------
+# Print the value of $CXX, followed by any innocent looking options
+# in $CC.
+
+ndk_subst_cc_onto_cxx () {
+ AS_ECHO_N(["$CXX "])
+ ndk_flag=
+ for ndk_word in `AS_ECHO_N(["$CC"]) | cut -s -f2- -d' '`; do
+ AS_IF([test "$ndk_flag" = "yes"],
+ [AS_ECHO_N(["$ndk_word "])
+ ndk_flag=no],
+ [AS_CASE([$ndk_word],
+ [*-sysroot=*],
+ [AS_ECHO_N(["$ndk_word "])],
+ [*-isystem*],
+ [AS_ECHO_N(["$ndk_word "])
+ ndk_flag=yes],
+ [*-sysroot*],
+ [AS_ECHO_N(["$ndk_word "])
+ ndk_flag=yes],
+ [-D__ANDROID_API__*],
+ [AS_ECHO_N(["$ndk_word "])])])
+ done
+}
+
+# ndk_subst_cflags_onto_cxx
+# ---------------------
+# Print any options in CFLAGS also suitable for a C++ compiler.
+
+ndk_subst_cflags_onto_cxx () {
+ ndk_flag=
+ for ndk_word in $CFLAGS; do
+ AS_IF([test "$ndk_flag" = "yes"],
+ [AS_ECHO_N(["$ndk_word "])
+ ndk_flag=no],
+ [AS_CASE([$ndk_word],
+ [*-sysroot=*],
+ [AS_ECHO_N(["$ndk_word "])],
+ [*-isystem*],
+ [AS_ECHO_N(["$ndk_word "])
+ ndk_flag=yes],
+ [*-I*],
+ [AS_ECHO_N(["$ndk_word "])
+ ndk_flag=yes],
+ [*-sysroot*],
+ [AS_ECHO_N(["$ndk_word "])
+ ndk_flag=yes],
+ [-D__ANDROID_API__*],
+ [AS_ECHO_N(["$ndk_word "])])])
+ done
+}
+
+# Detect the installation directory and type of the NDK being used.
+
+ndk_install_dir=
+ndk_toolchain_type=
+
+AC_MSG_CHECKING([for the directory where the NDK is installed])
+
+dnl If the install directory isn't available, repeat the search over
+dnl each entry in the programs directory.
+ndk_programs_dirs=`$CC -print-search-dirs | sed -n "s/^programs:[[\t ]]*=\?\(.*\)/\1/p"`
+ndk_save_IFS=$IFS; IFS=:
+for ndk_dir in $ndk_programs_dirs; do
+ if test -d "$ndk_dir"; then :; else
+ continue
+ fi
+ ndk_dir=`cd "$ndk_dir"; pwd`
+ while test "$ndk_dir" != "/" && test -z "$ndk_toolchain_type"; do
+ ndk_dir=`AS_DIRNAME([$ndk_dir])`
+ AS_IF([test -d "$ndk_dir/bin" && test -d "$ndk_dir/lib"],
+ [dnl The directory reached is most likely either the directory
+ dnl holding prebuilt binaries in a combined toolchain or the
+ dnl directory holding a standalone toolchain itself.
+ dnl
+ dnl Distinguish between the two by verifying the name of the
+ dnl parent directory (and its parent).
+ ndk_dir1=`AS_DIRNAME(["$ndk_dir"])`
+ ndk_basename=`AS_BASENAME(["$ndk_dir1"])`
+ AS_IF([test "$ndk_basename" = "prebuilt"],
+ [dnl Directories named "prebuilt" are exclusively present in
+ dnl combined toolchains, where they are children of the
+ dnl base directory or, in recent releases, a directory
+ dnl within the base directory. Continue searching for the
+ dnl base directory.
+ ndk_toolchain_type=combined
+ while test "$ndk_dir1" != "/"; do
+ AS_IF([test -d "$ndk_dir1/toolchains" \
+ && test -d "$ndk_dir1/sources"],
+ [ndk_install_dir=$ndk_dir1
+ break])
+ ndk_dir1=`AS_DIRNAME(["$ndk_dir1"])`
+ done],
+ [ndk_toolchain_type=standalone
+ ndk_install_dir=$ndk_dir])])
+ done
+ AS_IF([test -n "$ndk_toolchain_type"],
+ [break])
+done
+IFS=$ndk_save_IFS
+
+AS_IF([test -z "$ndk_install_dir"],
+ [AC_MSG_RESULT([unknown])
+ AC_MSG_WARN([The NDK installation directory could not be \
+derived from the compiler.])],
+ [AC_MSG_RESULT([$ndk_install_dir ($ndk_toolchain_type)])])
+
+# Look for a suitable ar and ranlib in the same directory as the C
+# compiler.
+ndk_cc_firstword=`AS_ECHO(["$CC"]) | cut -d' ' -f1`
+ndk_where_cc=`which $ndk_cc_firstword`
+ndk_ar_search_path=$PATH
+ndk_ranlib_search_path=$RANLIB
+
+# First, try to find $host_alias-ar in PATH.
+AC_PATH_PROGS([AR], [$host_alias-ar], [], [$ndk_ar_search_path])
+
+AS_IF([test -z "$AR"],[
+ # Next, try finding either that or llvm-ar in the directory holding
+ # CC.
+ ndk_ar_search_path="`AS_DIRNAME([$ndk_where_cc])`:$ndk_ar_search_path"
+ AC_PATH_PROGS([AR], [$host_alias-ar llvm-ar], [], [$ndk_ar_search_path])])
+
+# First, try to find $host_alias-ranlib in PATH.
+AC_PATH_PROGS([RANLIB], [$host_alias-ranlib], [], [$ndk_ranlib_search_path])
+
+AS_IF([test -z "$RANLIB"],[
+ # Next, try finding either that or llvm-ranlib in the directory
+ # holding CC.
+ ndk_ranlib_search_path="`AS_DIRNAME([$ndk_where_cc])`:$ndk_ranlib_search_path"
+ AC_PATH_PROGS([RANLIB], [$host_alias-ranlib llvm-ranlib], [],
+ [$ndk_ranlib_search_path])])
+
+NDK_BUILD_NASM=
+
+# Next, try to find nasm on x86. This doesn't ship with the NDK.
+AS_IF([test "$ndk_ARCH" = "x86" || test "$ndk_ARCH" = "x86_64"],
+ [AC_CHECK_PROGS([NDK_BUILD_NASM], [nasm])])
+
+# Search for a C++ compiler. Upon failure, pretend the C compiler is a
+# C++ compiler and use that instead.
+
+ndk_cc_name=`AS_BASENAME(["${ndk_cc_firstword}"])`
+ndk_cxx_name=
+
+AS_CASE([$ndk_cc_name], [*-gcc],
+ [ndk_cxx_name=`AS_ECHO([$ndk_cc_name]) | sed 's/gcc/g++/'`],
+ [ndk_cxx_name="${ndk_cc_name}++"])
+
+AS_IF([test -n "$with_ndk_cxx"], [CXX=$with_ndk_cxx],
+ [AC_PATH_PROGS([CXX], [$ndk_cxx_name],
+ [], [`AS_DIRNAME(["$ndk_where_cc"])`:$PATH])
+ AS_IF([test -z "$CXX"], [CXX=`ndk_filter_cc_for_cxx`],
+ [CXX=`ndk_subst_cc_onto_cxx`])])
+
+# None of the C++ standard libraries installed with Android are
+# available to NDK programs, which are expected to select one of several
+# standard libraries distributed with the NDK. This library must be
+# extracted from the NDK by the program's build system and copied into
+# the application directory, and the build system is also expected to
+# provide the compiler with suitable options to enable it.
+#
+# Emacs, on recent releases of the NDK, prefers the libc++ library, the
+# most complete of the libraries available, when it detects the presence
+# of its headers and libraries in the compiler's search path. Next in
+# line are the several libraries located in a directory named `cxx-stl'
+# inside the NDK distribution, of which Emacs prefers, in this order,
+# the GNU libstdc++, stlport, gabi and the system C++ library. The
+# scope of the last two is confined to providing runtime support for
+# basic C++ operations, and is useless for compiling most C++
+# dependencies whose requirements go beyond such operations.
+#
+# The NDK comes in two forms. In a "combined toolchain", all C++
+# libraries are present in the NDK directory and the responsibility is
+# left to the build system to locate and select the best C++ library,
+# whereas in a "standalone toolchain" an STL will have already been
+# specified a C++ library, besides which no others will be present.
+#
+# Though Android.mk files are provided by the NDK for each such library,
+# Emacs cannot use any of these, both for lack of prebuilt support in
+# its ndk-build implementation, and since they are absent from combined
+# toolchains.
+
+ndk_CXX_SHARED=
+ndk_CXX_STL=
+ndk_CXX_LDFLAGS=
+
+AS_IF([test -n "$CXX" && test -n "$ndk_install_dir"],
+ [ndk_library_dirs=`$CXX -print-search-dirs \
+ | sed -n "s/^libraries:[[\t ]]*=\?\(.*\)/\1/p"`
+ AS_IF([test "$ndk_toolchain_type" = "standalone"],
+ [dnl With a standalone toolchain, just use the first C++ library
+ dnl present in the compiler's library search path, that being the
+ dnl only C++ library that will ever be present.
+ ndk_save_IFS=$IFS; IFS=:
+ for ndk_dir in $ndk_library_dirs; do
+ if test -d "$ndk_dir"; then :; else
+ continue
+ fi
+ ndk_dir=`cd "$ndk_dir"; pwd`
+ if test -f "$ndk_dir/libc++_shared.so"; then
+ ndk_CXX_SHARED="$ndk_dir/libc++_shared.so"
+ ndk_CXX_LDFLAGS=-lc++_shared; break
+ elif test -f "$ndk_dir/libgnustl_shared.so"; then
+ ndk_CXX_SHARED="$ndk_dir/libgnustl_shared.so"
+ ndk_CXX_LDFLAGS=-lgnustl_shared; break
+ elif test -f "$ndk_dir/libstlport_shared.so"; then
+ ndk_CXX_SHARED="$ndk_dir/libstlport_shared.so"
+ ndk_CXX_LDFLAGS=-lstlport_shared; break
+ fi
+ done
+ IFS=$ndk_save_IFS],
+ [dnl Otherwise, search for a suitable standard library
+ dnl in the order stated above.
+ dnl
+ dnl Detect if this compiler is configured to link against libc++ by
+ dnl default.
+ AC_MSG_CHECKING([whether compiler defaults to libc++])
+ cat <<_ACEOF >conftest.cc
+#include <string>
+#ifndef _LIBCPP_VERSION
+Not libc++!
+#endif /* _LIBCPP_VERSION */
+
+int
+main (void)
+{
+
+}
+_ACEOF
+ AS_IF([$CXX conftest.cc -o conftest.o >&AS_MESSAGE_LOG_FD 2>&1],
+ [dnl The compiler defaults to libc++.
+ AC_MSG_RESULT([yes])
+ ndk_save_IFS=$IFS; IFS=:
+ for ndk_dir in $ndk_library_dirs; do
+ if test -f "$ndk_dir/libc++_shared.so"; then
+ ndk_CXX_SHARED="$ndk_dir/libc++_shared.so"
+ ndk_CXX_LDFLAGS=-lc++_shared; break
+ fi
+ done
+ IFS=$ndk_save_IFS],
+ [dnl Search for gnustl, stlport, gabi, and failing that, system.
+ dnl The name of the gabi system root directory varies by GCC
+ dnl version.
+ AC_MSG_RESULT([no])
+ ndk_gcc_version=`($CXX -v 2>&1) \
+ | sed -n "s/^gcc version \([[0123456789]\+.[0123456789]\+]\).*/\1/p"`
+ cxx_stl="$ndk_install_dir/sources/cxx-stl"
+ ndk_cxx_stl_base="$cxx_stl/gnu-libstdc++/$ndk_gcc_version"
+ AS_IF([test -n "$ndk_gcc_version" \
+ && test -d "$ndk_cxx_stl_base/libs/$ndk_ABI"],
+ [ndk_CXX_LDFLAGS="-L$ndk_cxx_stl_base/libs/$ndk_ABI -lgnustl_shared"
+ ndk_CXX_LDFLAGS="$ndk_CXX_LDFLAGS -lsupc++"
+ ndk_CXX_STL="-isystem $ndk_cxx_stl_base/include"
+ ndk_CXX_STL="$ndk_CXX_STL -isystem $ndk_cxx_stl_base/libs/$ndk_ABI/include"
+ ndk_CXX_SHARED="$ndk_cxx_stl_base/libs/$ndk_ABI/libgnustl_shared.so"])
+ AS_IF([test -f "$ndk_CXX_SHARED"], [],
+ [dnl No STL was located or the library is not reachable.
+ dnl Search for alternatives.
+ ndk_CXX_STL=
+ ndk_CXX_SHARED=
+ ndk_CXX_LDFLAGS=
+ ndk_cxx_stl_base="$cxx_stl/stlport"
+ AS_IF([test -d "$ndk_cxx_stl_base"],
+ [ndk_CXX_LDFLAGS="-L$ndk_cxx_stl_base/libs/$ndk_ABI -lstlport_shared"
+ ndk_CXX_STL="-isystem $ndk_cxx_stl_base/stlport"
+ ndk_CXX_SHARED="$ndk_cxx_stl_base/libs/$ndk_ABI/libstlport_shared.so"])
+ AS_IF([test -f "$ndk_CXX_SHARED"], [],
+ [ndk_CXX_STL=
+ ndk_CXX_SHARED=
+ ndk_CXX_LDFLAGS=
+ ndk_cxx_stl_base="$cxx_stl/gabi++"
+ AS_IF([test -d "$ndk_cxx_stl_base"],
+ [ndk_CXX_LDFLAGS="-L$ndk_cxx_stl_base/libs/$ndk_ABI -lgabi++_shared"
+ ndk_CXX_STL="$ndk_CXX_STL -isystem $ndk_cxx_stl_base/include"
+ ndk_CXX_SHARED="$ndk_cxx_stl_base/libs/$ndk_ABI/lgabi++_shared.so"])])
+ AS_IF([test -f "$ndk_CXX_SHARED"], [],
+ [ndk_CXX_STL=
+ ndk_CXX_SHARED=
+ ndk_CXX_LDFLAGS=
+ ndk_cxx_stl_base="$cxx_stl/system"
+ AS_IF([test -d "$ndk_cxx_stl_base"],
+ [ndk_CXX_LDFLAGS="-L$ndk_cxx_stl_base/libs/$ndk_ABI -lstdc++"
+ ndk_CXX_STL="-isystem $ndk_cxx_stl_base/include"
+ dnl The "system" library is distributed with Android and
+ dnl need not be present in app packages.
+ ndk_CXX_SHARED=
+ dnl Done.
+ ])])])])
+ rm -f conftest.o])])
+
+AS_ECHO([])
+AS_ECHO(["C++ compiler configuration: "])
+AS_ECHO([])
+AS_ECHO(["Library includes : $ndk_CXX_STL"])
+AS_ECHO(["Linker options : $ndk_CXX_LDFLAGS"])
+AS_ECHO(["Library file (if any) : $ndk_CXX_SHARED"])
+AS_ECHO([])
+])
+
+# ndk_LATE_EARLY
+# --------------
+# Call before ndk_LATE to establish certain variables in time for
+# ndk_LATE's C++ compiler detection.
+
+AC_DEFUN([ndk_LATE_EARLY],
+[ndk_save_LDFLAGS="$LDFLAGS"
+ LDFLAGS="$LDFLAGS $ndk_CXX_LDFLAGS"
+ CXXFLAGS="$CXXFLAGS `ndk_subst_cflags_onto_cxx` $ndk_CXX_STL"])
+
+# ndk_LATE
+# --------
+# Perform late initialization of the ndk-build system by checking for
+# required C and C++ headers.
+
+AC_DEFUN([ndk_LATE],
+[dnl
+AS_IF([test "$ndk_INITIALIZED" = "yes"],[
+ AS_IF([test -n "$CXX"], [
+ AC_LANG_PUSH([C++])
+ AC_CHECK_HEADER([string], [ndk_working_cxx=yes],
+ [AC_MSG_WARN([Your C++ compiler is not properly configured, as \
+the standard library headers could not be found.])])
+ AC_LANG_POP([C++])])])
+LDFLAGS="$ndk_save_LDFLAGS"
+])
+
+# ndk_SEARCH_MODULE(MODULE, NAME, ACTION-IF-FOUND, [ACTION-IF-NOT-FOUND])
+# -----------------------------------------------------------------------
+# Search for a module named MODULE in `with_ndk_path'. Add the file
+# name of the module's Android.mk file to the variable ndk_MAKEFILES.
+# Set NAME_CFLAGS and NAME_LIBS to the appropriate values. Then, call
+# ACTION-IF-FOUND, or ACTION-IF-NOT-FOUND upon failure.
+#
+# Resolve any imports specified by MODULE, and expand AC_MSG_ERROR
+# with a suitable error message if imports were not found.
+AC_DEFUN([ndk_SEARCH_MODULE],
+[
+module_name=
+ndk_module=$1
+ndk_replace_pkg_config_package
+AC_MSG_CHECKING([for Android.mk that builds $ndk_module])
+
+for ndk_android_mk in $ndk_module_files; do
+ # Read this Android.mk file. Set NDK_ROOT to /tmp: the Android in
+ # tree build system sets it to a meaning value, but build files just
+ # use it to test whether or not the NDK is being used.
+ ndk_commands=`ndk_run_test`
+
+ eval "$ndk_commands"
+ if test -n "$module_name"; then
+ break;
+ fi
+done
+
+if test -z "$module_name"; then
+ AC_MSG_RESULT([no])
+ $4
+else
+ if test -n "$module_cxx_deps"; then
+ ndk_ANY_CXX=yes
+ fi
+
+ AS_IF([test "$module_cxx_deps" = "yes" && test -z "$ndk_CXX_STL" \
+ && test -z "$ndk_CXX_LDFLAGS"],
+ [AC_MSG_ERROR([The module $1 requires a C++ standard library,
+but none were found.])])
+
+ AS_IF([test "$module_cxx_deps" = "yes" && test "$ndk_working_cxx" != "yes"],
+ [AC_MSG_ERROR([The module [$]1 requires the C++ standard library,
+but a working C++ compiler was not found.])])
+
+ $2[]_CFLAGS="[$]$2[]_CFLAGS $module_cflags $module_includes"
+ $2[]_LIBS="[$]$2[]_LIBS $module_ldflags"
+ ndk_MAKEFILES="$ndk_MAKEFILES $ndk_android_mk"
+ ndk_MODULES="$ndk_MODULES $module_target"
+ AC_MSG_RESULT([yes])
+ $3
+
+ # Now, resolve imports. Make sure the imports' Makefiles comes
+ # before ndk_MAKEFILES; likewise for its includes.
+ ndk_import_includes=
+ for ndk_module in $module_imports; do
+ ndk_resolve_import_module $ndk_module
+ $2[]_CFLAGS="$ndk_import_includes [$]$2[]_CFLAGS"
+ done
+fi
+])
+
+# ndk_CHECK_MODULES(VARIABLE-PREFIX, MODULES, [ACTION-IF-FOUND],
+# [ACTION-IF-NOT-FOUND])
+# --------------------------------------------------------------
+# Just like `PKG_CHECK_MODULES'. However, it uses the ndk-build
+# system instead.
+
+AC_DEFUN([ndk_CHECK_MODULES],
+[
+ ndk_modules=
+ ndk_parse_pkg_config_string "$2"
+ ndk_found=no
+
+ for module in $ndk_modules; do
+ ndk_SEARCH_MODULE([$module], [$1], [ndk_found=yes], [ndk_found=no])
+ done
+
+ AS_IF([test "$ndk_found" = "yes"],[$3],[$4])
+])
+
+# ndk_CONFIG_FILES
+# -------------------------------------------------------------
+# Write out the NDK build Makefile with the appropriate variables
+# set if the NDK has been initialized.
+
+AC_DEFUN_ONCE([ndk_CONFIG_FILES],
+[
+ if test "$ndk_INITIALIZED" = "yes"; then
+ NDK_BUILD_ANDROID_MK="$ndk_MAKEFILES"
+ NDK_BUILD_ARCH=$ndk_ARCH
+ NDK_BUILD_ABI=$ndk_ABI
+ NDK_BUILD_SDK=$ndk_API
+ NDK_BUILD_CC=$CC
+ NDK_BUILD_CXX=$CXX
+ NDK_BUILD_AR=$AR
+ NDK_BUILD_MODULES="$ndk_MODULES"
+ NDK_BUILD_CXX_SHARED="$ndk_CXX_SHARED"
+ NDK_BUILD_CXX_STL="$ndk_CXX_STL"
+ NDK_BUILD_CXX_LDFLAGS="$ndk_CXX_LDFLAGS"
+ NDK_BUILD_ANY_CXX_MODULE=$ndk_ANY_CXX
+ NDK_BUILD_CFLAGS="$ndk_BUILD_CFLAGS"
+
+ AC_SUBST([NDK_BUILD_ANDROID_MK])
+ AC_SUBST([NDK_BUILD_ARCH])
+ AC_SUBST([NDK_BUILD_ABI])
+ AC_SUBST([NDK_BUILD_SDK])
+ AC_SUBST([NDK_BUILD_CC])
+ AC_SUBST([NDK_BUILD_CXX])
+ AC_SUBST([NDK_BUILD_AR])
+ AC_SUBST([NDK_BUILD_NASM])
+ AC_SUBST([NDK_BUILD_MODULES])
+ AC_SUBST([NDK_BUILD_CXX_SHARED])
+ AC_SUBST([NDK_BUILD_CXX_STL])
+ AC_SUBST([NDK_BUILD_CXX_LDFLAGS])
+ AC_SUBST([NDK_BUILD_ANY_CXX_MODULE])
+ AC_SUBST([NDK_BUILD_CFLAGS])
+
+ AC_CONFIG_FILES([$ndk_DIR/Makefile])
+ AC_CONFIG_FILES([$ndk_DIR/ndk-build.mk])
+ fi
+])
diff --git a/m4/nproc.m4 b/m4/nproc.m4
index 9aec579f78b..e4065776a86 100644
--- a/m4/nproc.m4
+++ b/m4/nproc.m4
@@ -1,4 +1,4 @@
-# nproc.m4 serial 5
+# nproc.m4 serial 6
dnl Copyright (C) 2009-2024 Free Software Foundation, Inc.
dnl This file is free software; the Free Software Foundation
dnl gives unlimited permission to copy and/or distribute it,
@@ -25,8 +25,8 @@ AC_DEFUN([gl_PREREQ_NPROC],
#endif
])
- AC_CHECK_FUNCS([sched_getaffinity sched_getaffinity_np \
- pstat_getdynamic sysmp sysctl])
+ AC_CHECK_FUNCS([sched_getaffinity_np pstat_getdynamic sysmp sysctl])
+ gl_CHECK_FUNCS_ANDROID([sched_getaffinity], [[#include <sched.h>]])
dnl Test whether sched_getaffinity has the expected declaration.
dnl glibc 2.3.[0-2]:
diff --git a/m4/nstrftime.m4 b/m4/nstrftime.m4
index 01725b2a331..aa5d63a54b5 100644
--- a/m4/nstrftime.m4
+++ b/m4/nstrftime.m4
@@ -1,7 +1,6 @@
-# serial 37
+# serial 38
-# Copyright (C) 1996-1997, 1999-2007, 2009-2024 Free Software
-# Foundation, Inc.
+# Copyright (C) 1996-1997, 1999-2007, 2009-2024 Free Software Foundation, Inc.
#
# This file is free software; the Free Software Foundation
# gives unlimited permission to copy and/or distribute it,
@@ -17,7 +16,4 @@ AC_DEFUN([gl_FUNC_GNU_STRFTIME],
AC_REQUIRE([AC_STRUCT_TIMEZONE])
AC_REQUIRE([gl_TM_GMTOFF])
-
- AC_DEFINE([my_strftime], [nstrftime],
- [Define to the name of the strftime replacement function.])
])
diff --git a/m4/open.m4 b/m4/open.m4
index edbd8b93c83..91e5c31b59a 100644
--- a/m4/open.m4
+++ b/m4/open.m4
@@ -1,4 +1,4 @@
-# open.m4 serial 15
+# open.m4 serial 16
dnl Copyright (C) 2007-2024 Free Software Foundation, Inc.
dnl This file is free software; the Free Software Foundation
dnl gives unlimited permission to copy and/or distribute it,
@@ -9,7 +9,7 @@ AC_DEFUN([gl_FUNC_OPEN],
AC_REQUIRE([AC_CANONICAL_HOST])
AC_REQUIRE([gl_PREPROC_O_CLOEXEC])
case "$host_os" in
- mingw* | pw*)
+ mingw* | windows* | pw*)
REPLACE_OPEN=1
;;
*)
diff --git a/m4/pathmax.m4 b/m4/pathmax.m4
index b7ce9ff1468..a0fc296c9b2 100644
--- a/m4/pathmax.m4
+++ b/m4/pathmax.m4
@@ -1,6 +1,6 @@
# pathmax.m4 serial 11
-dnl Copyright (C) 2002-2003, 2005-2006, 2009-2024 Free Software
-dnl Foundation, Inc.
+dnl Copyright (C) 2002-2003, 2005-2006, 2009-2024 Free Software Foundation,
+dnl Inc.
dnl This file is free software; the Free Software Foundation
dnl gives unlimited permission to copy and/or distribute it,
dnl with or without modifications, as long as this notice is preserved.
diff --git a/m4/pipe2.m4 b/m4/pipe2.m4
index f4119987f49..74b7b284b3e 100644
--- a/m4/pipe2.m4
+++ b/m4/pipe2.m4
@@ -1,4 +1,4 @@
-# pipe2.m4 serial 2
+# pipe2.m4 serial 4
dnl Copyright (C) 2009-2024 Free Software Foundation, Inc.
dnl This file is free software; the Free Software Foundation
dnl gives unlimited permission to copy and/or distribute it,
@@ -11,8 +11,13 @@ AC_DEFUN([gl_FUNC_PIPE2],
dnl Persuade glibc <unistd.h> to declare pipe2().
AC_REQUIRE([AC_USE_SYSTEM_EXTENSIONS])
- AC_CHECK_FUNCS_ONCE([pipe2])
+ gl_CHECK_FUNCS_ANDROID([pipe2], [[#include <unistd.h>]])
if test $ac_cv_func_pipe2 != yes; then
HAVE_PIPE2=0
+ case "$gl_cv_onwards_func_pipe2" in
+ future*) REPLACE_PIPE2=1 ;;
+ esac
+ else
+ REPLACE_PIPE2=1
fi
])
diff --git a/m4/printf-posix-rpl.m4 b/m4/printf-posix-rpl.m4
new file mode 100644
index 00000000000..0f741192499
--- /dev/null
+++ b/m4/printf-posix-rpl.m4
@@ -0,0 +1,26 @@
+# printf-posix-rpl.m4 serial 4
+dnl Copyright (C) 2007-2024 Free Software Foundation, Inc.
+dnl This file is free software; the Free Software Foundation
+dnl gives unlimited permission to copy and/or distribute it,
+dnl with or without modifications, as long as this notice is preserved.
+
+AC_DEFUN([gl_FUNC_PRINTF_POSIX],
+[
+ AC_REQUIRE([gl_FUNC_VFPRINTF_POSIX])
+ if test $gl_cv_func_vfprintf_posix = no; then
+ gl_REPLACE_PRINTF
+ fi
+])
+
+AC_DEFUN([gl_REPLACE_PRINTF],
+[
+ AC_REQUIRE([gl_STDIO_H_DEFAULTS])
+ AC_REQUIRE([gl_ASM_SYMBOL_PREFIX])
+ AC_LIBOBJ([printf])
+ REPLACE_PRINTF=1
+ AC_DEFINE([REPLACE_PRINTF_POSIX], [1],
+ [Define if printf is overridden by a POSIX compliant gnulib implementation.])
+ gl_PREREQ_PRINTF
+])
+
+AC_DEFUN([gl_PREREQ_PRINTF], [:])
diff --git a/m4/pselect.m4 b/m4/pselect.m4
index 3f6842253c1..005b722b965 100644
--- a/m4/pselect.m4
+++ b/m4/pselect.m4
@@ -1,4 +1,4 @@
-# pselect.m4 serial 10
+# pselect.m4 serial 11
dnl Copyright (C) 2011-2024 Free Software Foundation, Inc.
dnl This file is free software; the Free Software Foundation
dnl gives unlimited permission to copy and/or distribute it,
@@ -54,6 +54,8 @@ AC_DEFUN([gl_FUNC_PSELECT],
case "$host_os" in
# Guess yes on Linux systems.
linux-* | linux) gl_cv_func_pselect_detects_ebadf="guessing yes" ;;
+ # Guess yes on systems that emulate the Linux system calls.
+ midipix*) gl_cv_func_pselect_detects_ebadf="guessing yes" ;;
# Guess yes on glibc systems.
*-gnu* | gnu*) gl_cv_func_pselect_detects_ebadf="guessing yes" ;;
# If we don't know, obey --enable-cross-guesses.
diff --git a/m4/pthread_sigmask.m4 b/m4/pthread_sigmask.m4
index 91c0fb9893d..cb2ee900313 100644
--- a/m4/pthread_sigmask.m4
+++ b/m4/pthread_sigmask.m4
@@ -1,4 +1,4 @@
-# pthread_sigmask.m4 serial 21
+# pthread_sigmask.m4 serial 23
dnl Copyright (C) 2011-2024 Free Software Foundation, Inc.
dnl This file is free software; the Free Software Foundation
dnl gives unlimited permission to copy and/or distribute it,
@@ -24,7 +24,7 @@ AC_DEFUN([gl_FUNC_PTHREAD_SIGMASK],
[gl_cv_func_pthread_sigmask_macro=no])
])
- LIB_PTHREAD_SIGMASK=
+ PTHREAD_SIGMASK_LIB=
if test $gl_cv_func_pthread_sigmask_macro = yes; then
dnl pthread_sigmask is a dummy macro.
@@ -47,7 +47,7 @@ AC_DEFUN([gl_FUNC_PTHREAD_SIGMASK],
if test -n "$LIBMULTITHREAD"; then
AC_CACHE_CHECK([for pthread_sigmask in $LIBMULTITHREAD],
[gl_cv_func_pthread_sigmask_in_LIBMULTITHREAD],
- [gl_save_LIBS="$LIBS"
+ [gl_saved_LIBS="$LIBS"
LIBS="$LIBS $LIBMULTITHREAD"
AC_LINK_IFELSE(
[AC_LANG_PROGRAM(
@@ -58,11 +58,11 @@ AC_DEFUN([gl_FUNC_PTHREAD_SIGMASK],
],
[gl_cv_func_pthread_sigmask_in_LIBMULTITHREAD=yes],
[gl_cv_func_pthread_sigmask_in_LIBMULTITHREAD=no])
- LIBS="$gl_save_LIBS"
+ LIBS="$gl_saved_LIBS"
])
if test $gl_cv_func_pthread_sigmask_in_LIBMULTITHREAD = yes; then
dnl pthread_sigmask is available with -pthread or -lpthread.
- LIB_PTHREAD_SIGMASK="$LIBMULTITHREAD"
+ PTHREAD_SIGMASK_LIB="$LIBMULTITHREAD"
else
dnl pthread_sigmask is not available at all.
HAVE_PTHREAD_SIGMASK=0
@@ -101,6 +101,9 @@ AC_DEFUN([gl_FUNC_PTHREAD_SIGMASK],
])
fi
+ AC_SUBST([PTHREAD_SIGMASK_LIB])
+ dnl For backward compatibility.
+ LIB_PTHREAD_SIGMASK="$PTHREAD_SIGMASK_LIB"
AC_SUBST([LIB_PTHREAD_SIGMASK])
dnl We don't need a variable LTLIB_PTHREAD_SIGMASK, because when
dnl "$gl_threads_api" = posix, $LTLIBMULTITHREAD and $LIBMULTITHREAD are the
@@ -114,7 +117,7 @@ AC_DEFUN([gl_FUNC_PTHREAD_SIGMASK],
dnl On FreeBSD 13.0, MidnightBSD 1.1, HP-UX 11.31, Solaris 9, in programs
dnl that are not linked with -lpthread, the pthread_sigmask() function
dnl always returns 0 and has no effect.
- if test -z "$LIB_PTHREAD_SIGMASK"; then
+ if test -z "$PTHREAD_SIGMASK_LIB"; then
case " $LIBS " in
*' -pthread '*) ;;
*' -lpthread '*) ;;
@@ -161,8 +164,8 @@ AC_DEFUN([gl_FUNC_PTHREAD_SIGMASK],
AC_CACHE_CHECK([whether pthread_sigmask returns error numbers],
[gl_cv_func_pthread_sigmask_return_works],
[
- gl_save_LIBS="$LIBS"
- LIBS="$LIBS $LIB_PTHREAD_SIGMASK"
+ gl_saved_LIBS="$LIBS"
+ LIBS="$LIBS $PTHREAD_SIGMASK_LIB"
AC_RUN_IFELSE(
[AC_LANG_SOURCE([[
#include <pthread.h>
@@ -185,7 +188,7 @@ int main ()
gl_cv_func_pthread_sigmask_return_works="guessing yes";;
esac
])
- LIBS="$gl_save_LIBS"
+ LIBS="$gl_saved_LIBS"
])
case "$gl_cv_func_pthread_sigmask_return_works" in
*no)
@@ -208,10 +211,10 @@ int main ()
gl_cv_func_pthread_sigmask_unblock_works="guessing yes";;
esac
m4_ifdef([gl_][THREADLIB],
- [dnl Link against $LIBMULTITHREAD, not only $LIB_PTHREAD_SIGMASK.
+ [dnl Link against $LIBMULTITHREAD, not only $PTHREAD_SIGMASK_LIB.
dnl Otherwise we get a false positive on those platforms where
dnl $gl_cv_func_pthread_sigmask_in_libc_works is "no".
- gl_save_LIBS=$LIBS
+ gl_saved_LIBS=$LIBS
LIBS="$LIBS $LIBMULTITHREAD"])
AC_RUN_IFELSE(
[AC_LANG_SOURCE([[
@@ -255,7 +258,7 @@ int main ()
[:],
[gl_cv_func_pthread_sigmask_unblock_works=no],
[:])
- m4_ifdef([gl_][THREADLIB], [LIBS=$gl_save_LIBS])
+ m4_ifdef([gl_][THREADLIB], [LIBS=$gl_saved_LIBS])
])
case "$gl_cv_func_pthread_sigmask_unblock_works" in
*no)
diff --git a/m4/readlink.m4 b/m4/readlink.m4
index b9e62b93afc..6d78ec84a03 100644
--- a/m4/readlink.m4
+++ b/m4/readlink.m4
@@ -1,4 +1,4 @@
-# readlink.m4 serial 16
+# readlink.m4 serial 17
dnl Copyright (C) 2003, 2007, 2009-2024 Free Software Foundation, Inc.
dnl This file is free software; the Free Software Foundation
dnl gives unlimited permission to copy and/or distribute it,
@@ -38,6 +38,9 @@ AC_DEFUN([gl_FUNC_READLINK],
# Guess yes on Linux or glibc systems.
linux-* | linux | *-gnu* | gnu*)
gl_cv_func_readlink_trailing_slash="guessing yes" ;;
+ # Guess yes on systems that emulate the Linux system calls.
+ midipix*)
+ gl_cv_func_readlink_trailing_slash="guessing yes" ;;
# Guess no on AIX or HP-UX.
aix* | hpux*)
gl_cv_func_readlink_trailing_slash="guessing no" ;;
@@ -75,6 +78,9 @@ AC_DEFUN([gl_FUNC_READLINK],
# Guess yes on Linux or glibc systems.
linux-* | linux | *-gnu* | gnu*)
gl_cv_func_readlink_truncate="guessing yes" ;;
+ # Guess yes on systems that emulate the Linux system calls.
+ midipix*)
+ gl_cv_func_readlink_truncate="guessing yes" ;;
# Guess no on AIX or HP-UX.
aix* | hpux*)
gl_cv_func_readlink_truncate="guessing no" ;;
diff --git a/m4/readlinkat.m4 b/m4/readlinkat.m4
index b7d068d5c8d..99822102294 100644
--- a/m4/readlinkat.m4
+++ b/m4/readlinkat.m4
@@ -1,4 +1,4 @@
-# serial 6
+# serial 8
# See if we need to provide readlinkat replacement.
dnl Copyright (C) 2009-2024 Free Software Foundation, Inc.
@@ -12,10 +12,13 @@ AC_DEFUN([gl_FUNC_READLINKAT],
[
AC_REQUIRE([gl_UNISTD_H_DEFAULTS])
AC_REQUIRE([gl_USE_SYSTEM_EXTENSIONS])
- AC_CHECK_FUNCS_ONCE([readlinkat])
+ gl_CHECK_FUNCS_ANDROID([readlinkat], [[#include <unistd.h>]])
AC_REQUIRE([gl_FUNC_READLINK])
if test $ac_cv_func_readlinkat = no; then
HAVE_READLINKAT=0
+ case "$gl_cv_onwards_func_readlinkat" in
+ future*) REPLACE_READLINKAT=1 ;;
+ esac
else
AC_CACHE_CHECK([whether readlinkat signature is correct],
[gl_cv_decl_readlinkat_works],
diff --git a/m4/readutmp.m4 b/m4/readutmp.m4
new file mode 100644
index 00000000000..ec40019735f
--- /dev/null
+++ b/m4/readutmp.m4
@@ -0,0 +1,121 @@
+# readutmp.m4 serial 31
+dnl Copyright (C) 2002-2024 Free Software Foundation, Inc.
+dnl This file is free software; the Free Software Foundation
+dnl gives unlimited permission to copy and/or distribute it,
+dnl with or without modifications, as long as this notice is preserved.
+
+AC_DEFUN([gl_READUTMP],
+[
+ AC_REQUIRE([gl_SYSTEMD_CHOICE])
+
+ dnl Set READUTMP_LIB to '-lsystemd' or '', depending on whether use of
+ dnl systemd APIs is possible and desired (only the systemd login API, here).
+ dnl AC_LIB_LINKFLAGS_BODY would be overkill here, since few people install
+ dnl libsystemd in non-system directories.
+ READUTMP_LIB=
+ if test "$SYSTEMD_CHOICE" = yes; then
+ AC_CHECK_HEADER([systemd/sd-login.h])
+ if test $ac_cv_header_systemd_sd_login_h = yes; then
+ AC_CACHE_CHECK([for libsystemd version >= 254],
+ [gl_cv_lib_readutmp_systemd],
+ [gl_saved_LIBS="$LIBS"
+ LIBS="$LIBS -lsystemd"
+ AC_LINK_IFELSE(
+ [AC_LANG_PROGRAM([[
+ #include <stdint.h>
+ #include <systemd/sd-login.h>
+ ]], [[
+ uint64_t st;
+ sd_session_get_start_time ("1", &st);
+ ]])
+ ],
+ [gl_cv_lib_readutmp_systemd=yes],
+ [gl_cv_lib_readutmp_systemd=no])
+ LIBS="$gl_saved_LIBS"
+ ])
+ if test $gl_cv_lib_readutmp_systemd = yes; then
+ AC_DEFINE([READUTMP_USE_SYSTEMD], [1],
+ [Define if the readutmp module should use the systemd login API.])
+ READUTMP_LIB='-lsystemd'
+ fi
+ fi
+ fi
+ AC_SUBST([READUTMP_LIB])
+
+ gl_PREREQ_READUTMP_H
+])
+
+# Prerequisites of readutmp.h and boot-time-aux.h.
+AC_DEFUN_ONCE([gl_PREREQ_READUTMP_H],
+[
+ dnl Persuade utmpx.h to declare utmpxname
+ AC_REQUIRE([AC_USE_SYSTEM_EXTENSIONS])
+
+ AC_CHECK_HEADERS_ONCE([utmp.h utmpx.h])
+ if test $ac_cv_header_utmp_h = yes || test $ac_cv_header_utmpx_h = yes; then
+ dnl Prerequisites of lib/readutmp.h and lib/readutmp.c.
+ AC_CHECK_FUNCS_ONCE([utmpname utmpxname])
+ AC_CHECK_DECLS([endutent],,,[[
+/* <sys/types.h> is a prerequisite of <utmp.h> on FreeBSD 8.0, OpenBSD 4.6. */
+#include <sys/types.h>
+#ifdef HAVE_UTMP_H
+# include <utmp.h>
+#endif
+]])
+ utmp_includes="\
+AC_INCLUDES_DEFAULT
+#ifdef HAVE_UTMPX_H
+# include <utmpx.h>
+#endif
+#ifdef HAVE_UTMP_H
+# if defined _THREAD_SAFE && defined UTMP_DATA_INIT
+ /* When including both utmp.h and utmpx.h on AIX 4.3, with _THREAD_SAFE
+ defined, work around the duplicate struct utmp_data declaration. */
+# define utmp_data gl_aix_4_3_workaround_utmp_data
+# endif
+# include <utmp.h>
+#endif
+"
+ AC_CHECK_MEMBERS([struct utmpx.ut_user],,,[$utmp_includes])
+ AC_CHECK_MEMBERS([struct utmp.ut_user],,,[$utmp_includes])
+ AC_CHECK_MEMBERS([struct utmpx.ut_name],,,[$utmp_includes])
+ AC_CHECK_MEMBERS([struct utmp.ut_name],,,[$utmp_includes])
+ AC_CHECK_MEMBERS([struct utmpx.ut_type],,,[$utmp_includes])
+ AC_CHECK_MEMBERS([struct utmp.ut_type],,,[$utmp_includes])
+ AC_CHECK_MEMBERS([struct utmpx.ut_pid],,,[$utmp_includes])
+ AC_CHECK_MEMBERS([struct utmp.ut_pid],,,[$utmp_includes])
+ AC_CHECK_MEMBERS([struct utmp.ut_tv],,,[$utmp_includes])
+ AC_CHECK_MEMBERS([struct utmpx.ut_host],,,[$utmp_includes])
+ AC_CHECK_MEMBERS([struct utmp.ut_host],,,[$utmp_includes])
+ AC_CHECK_MEMBERS([struct utmpx.ut_id],,,[$utmp_includes])
+ AC_CHECK_MEMBERS([struct utmp.ut_id],,,[$utmp_includes])
+ AC_CHECK_MEMBERS([struct utmpx.ut_session],,,[$utmp_includes])
+ AC_CHECK_MEMBERS([struct utmp.ut_session],,,[$utmp_includes])
+ AC_CHECK_MEMBERS([struct utmpx.ut_exit],,,[$utmp_includes])
+ AC_CHECK_MEMBERS([struct utmp.ut_exit],,,[$utmp_includes])
+
+ AC_CHECK_MEMBERS([struct utmpx.ut_exit.ut_exit],,,[$utmp_includes])
+ AC_CHECK_MEMBERS([struct utmpx.ut_exit.e_exit],,,[$utmp_includes])
+ AC_CHECK_MEMBERS([struct utmp.ut_exit.e_exit],,,[$utmp_includes])
+
+ AC_CHECK_MEMBERS([struct utmpx.ut_exit.ut_termination],,,[$utmp_includes])
+ AC_CHECK_MEMBERS([struct utmpx.ut_exit.e_termination],,,[$utmp_includes])
+ AC_CHECK_MEMBERS([struct utmp.ut_exit.e_termination],,,[$utmp_includes])
+ fi
+
+ AC_CHECK_DECLS([sysinfo],,,[[
+ #include <sys/sysinfo.h>
+ ]])
+
+ AC_CHECK_HEADERS_ONCE([sys/param.h])
+ dnl <sys/sysctl.h> requires <sys/param.h> on OpenBSD 4.0.
+ AC_CHECK_HEADERS([sys/sysctl.h],,,
+ [AC_INCLUDES_DEFAULT
+ #if HAVE_SYS_PARAM_H
+ # include <sys/param.h>
+ #endif
+ ])
+ AC_CHECK_FUNCS([sysctl])
+
+ AC_CHECK_HEADERS_ONCE([OS.h])
+])
diff --git a/m4/realloc.m4 b/m4/realloc.m4
index 89f9a5ad270..a59af2807c9 100644
--- a/m4/realloc.m4
+++ b/m4/realloc.m4
@@ -1,4 +1,4 @@
-# realloc.m4 serial 26
+# realloc.m4 serial 29
dnl Copyright (C) 2007, 2009-2024 Free Software Foundation, Inc.
dnl This file is free software; the Free Software Foundation
dnl gives unlimited permission to copy and/or distribute it,
@@ -16,7 +16,8 @@ AC_DEFUN([_AC_FUNC_REALLOC_IF],
[[#include <stdlib.h>
]],
[[void *p = realloc (0, 0);
- int result = !p;
+ void * volatile vp = p;
+ int result = !vp;
free (p);
return result;]])
],
@@ -25,8 +26,8 @@ AC_DEFUN([_AC_FUNC_REALLOC_IF],
[case "$host_os" in
# Guess yes on platforms where we know the result.
*-gnu* | freebsd* | netbsd* | openbsd* | bitrig* \
- | gnu* | *-musl* | midnightbsd* \
- | hpux* | solaris* | cygwin* | mingw* | msys* )
+ | gnu* | *-musl* | midipix* | midnightbsd* \
+ | hpux* | solaris* | cygwin* | mingw* | windows* | msys* )
ac_cv_func_realloc_0_nonnull="guessing yes" ;;
# If we don't know, obey --enable-cross-guesses.
*) ac_cv_func_realloc_0_nonnull="$gl_cross_guess_normal" ;;
diff --git a/m4/regex.m4 b/m4/regex.m4
index 03a6864b0b4..3dfeabea057 100644
--- a/m4/regex.m4
+++ b/m4/regex.m4
@@ -1,4 +1,4 @@
-# serial 73
+# serial 75
# Copyright (C) 1996-2001, 2003-2024 Free Software Foundation, Inc.
#
@@ -15,7 +15,7 @@ AC_DEFUN([gl_REGEX],
[
AC_REQUIRE([AC_CANONICAL_HOST]) dnl for cross-compiles
AC_ARG_WITH([included-regex],
- [AS_HELP_STRING([--without-included-regex],
+ [AS_HELP_STRING([[--without-included-regex]],
[don't compile regex; this is the default on systems
with recent-enough versions of the GNU C Library
(use with caution on other systems).])])
@@ -327,10 +327,10 @@ AC_DEFUN([gl_REGEX],
[gl_cv_func_re_compile_pattern_working=yes],
[gl_cv_func_re_compile_pattern_working=no],
[case "$host_os" in
- # Guess no on native Windows.
- mingw*) gl_cv_func_re_compile_pattern_working="guessing no" ;;
- # Otherwise obey --enable-cross-guesses.
- *) gl_cv_func_re_compile_pattern_working="$gl_cross_guess_normal" ;;
+ # Guess no on native Windows.
+ mingw* | windows*) gl_cv_func_re_compile_pattern_working="guessing no" ;;
+ # Otherwise obey --enable-cross-guesses.
+ *) gl_cv_func_re_compile_pattern_working="$gl_cross_guess_normal" ;;
esac
])
])
diff --git a/m4/sig2str.m4 b/m4/sig2str.m4
index 2cb77c58a46..ab3786b8954 100644
--- a/m4/sig2str.m4
+++ b/m4/sig2str.m4
@@ -1,6 +1,5 @@
# serial 7
-dnl Copyright (C) 2002, 2005-2006, 2009-2024 Free Software Foundation,
-dnl Inc.
+dnl Copyright (C) 2002, 2005-2006, 2009-2024 Free Software Foundation, Inc.
dnl This file is free software; the Free Software Foundation
dnl gives unlimited permission to copy and/or distribute it,
dnl with or without modifications, as long as this notice is preserved.
diff --git a/m4/ssize_t.m4 b/m4/ssize_t.m4
index 787bf6dd363..25b28d77e4e 100644
--- a/m4/ssize_t.m4
+++ b/m4/ssize_t.m4
@@ -1,24 +1,37 @@
-# ssize_t.m4 serial 5 (gettext-0.18.2)
-dnl Copyright (C) 2001-2003, 2006, 2010-2024 Free Software Foundation,
-dnl Inc.
+# ssize_t.m4 serial 6
+dnl Copyright (C) 2001-2003, 2006, 2010-2024 Free Software Foundation, Inc.
dnl This file is free software; the Free Software Foundation
dnl gives unlimited permission to copy and/or distribute it,
dnl with or without modifications, as long as this notice is preserved.
dnl From Bruno Haible.
-dnl Test whether ssize_t is defined.
+dnl Define ssize_t if it does not already exist.
AC_DEFUN([gt_TYPE_SSIZE_T],
[
- AC_CACHE_CHECK([for ssize_t], [gt_cv_ssize_t],
+ AC_CACHE_CHECK([for ssize_t], [gl_cv_ssize_t],
[AC_COMPILE_IFELSE(
[AC_LANG_PROGRAM(
[[#include <sys/types.h>]],
[[int x = sizeof (ssize_t *) + sizeof (ssize_t);
return !x;]])],
- [gt_cv_ssize_t=yes], [gt_cv_ssize_t=no])])
- if test $gt_cv_ssize_t = no; then
- AC_DEFINE([ssize_t], [int],
- [Define as a signed type of the same size as size_t.])
+ [gl_cv_ssize_t=yes], [gl_cv_ssize_t=no])])
+ if test $gl_cv_ssize_t = no; then
+ dnl On 64-bit native Windows, ssize_t needs to be defined as 'long long',
+ dnl for consistency with the 64-bit size_t.
+ AC_CACHE_CHECK([whether size_t is wider than 'long'], [gl_cv_size_t_large],
+ [AC_COMPILE_IFELSE(
+ [AC_LANG_PROGRAM(
+ [[#include <sys/types.h>
+ typedef int array [2 * (sizeof (size_t) > sizeof (long)) - 1];
+ ]])],
+ [gl_cv_size_t_large=yes], [gl_cv_size_t_large=no])])
+ if test $gl_cv_size_t_large = yes; then
+ gl_def_ssize_t='long long'
+ else
+ gl_def_ssize_t='long'
+ fi
+ AC_DEFINE_UNQUOTED([ssize_t], [$gl_def_ssize_t],
+ [Define as a signed type of the same size as size_t.])
fi
])
diff --git a/m4/stat-time.m4 b/m4/stat-time.m4
index 7535a4c7e5c..8bec2f5f815 100644
--- a/m4/stat-time.m4
+++ b/m4/stat-time.m4
@@ -1,7 +1,7 @@
# Checks for stat-related time functions.
-# Copyright (C) 1998-1999, 2001, 2003, 2005-2007, 2009-2024 Free
-# Software Foundation, Inc.
+# Copyright (C) 1998-1999, 2001, 2003, 2005-2007, 2009-2024 Free Software
+# Foundation, Inc.
# This file is free software; the Free Software Foundation
# gives unlimited permission to copy and/or distribute it,
diff --git a/m4/stdalign.m4 b/m4/stdalign.m4
index 0239bbf66e5..e3c1e609236 100644
--- a/m4/stdalign.m4
+++ b/m4/stdalign.m4
@@ -5,16 +5,18 @@ dnl This file is free software; the Free Software Foundation
dnl gives unlimited permission to copy and/or distribute it,
dnl with or without modifications, as long as this notice is preserved.
+dnl Written by Paul Eggert and Bruno Haible.
+
# Prepare for substituting <stdalign.h> if it is not supported.
-AC_DEFUN([gl_STDALIGN_H],
+AC_DEFUN([gl_ALIGNASOF],
[
AC_CACHE_CHECK([for alignas and alignof],
[gl_cv_header_working_stdalign_h],
- [gl_save_CFLAGS=$CFLAGS
+ [gl_saved_CFLAGS=$CFLAGS
for gl_working in "yes, keywords" "yes, <stdalign.h> macros"; do
AS_CASE([$gl_working],
- [*stdalign.h*], [CFLAGS="$gl_save_CFLAGS -DINCLUDE_STDALIGN_H"])
+ [*stdalign.h*], [CFLAGS="$gl_saved_CFLAGS -DINCLUDE_STDALIGN_H"])
AC_COMPILE_IFELSE(
[AC_LANG_PROGRAM(
[[#include <stdint.h>
@@ -54,81 +56,151 @@ AC_DEFUN([gl_STDALIGN_H],
[gl_cv_header_working_stdalign_h=$gl_working],
[gl_cv_header_working_stdalign_h=no])
- CFLAGS=$gl_save_CFLAGS
+ CFLAGS=$gl_saved_CFLAGS
test "$gl_cv_header_working_stdalign_h" != no && break
done])
- GL_GENERATE_STDALIGN_H=false
AS_CASE([$gl_cv_header_working_stdalign_h],
- [no],
- [GL_GENERATE_STDALIGN_H=true],
[yes*keyword*],
[AC_DEFINE([HAVE_C_ALIGNASOF], [1],
[Define to 1 if the alignas and alignof keywords work.])])
- AC_CHECK_HEADERS_ONCE([stdalign.h])
-
dnl The "zz" puts this toward config.h's end, to avoid potential
dnl collisions with other definitions.
AH_VERBATIM([zzalignas],
-[#if !defined HAVE_C_ALIGNASOF && __cplusplus < 201103 && !defined alignof
-# if HAVE_STDALIGN_H
+[#if !defined HAVE_C_ALIGNASOF \
+ && !(defined __cplusplus && 201103 <= __cplusplus) \
+ && !defined alignof
+# if defined HAVE_STDALIGN_H
# include <stdalign.h>
-# else
- /* Substitute. Keep consistent with gnulib/lib/stdalign.in.h. */
-# ifndef _GL_STDALIGN_H
-# define _GL_STDALIGN_H
-# undef _Alignas
-# undef _Alignof
-# if (!defined __STDC_VERSION__ || __STDC_VERSION__ < 201112 \
- || (defined __GNUC__ && __GNUC__ < 4 + (__GNUC_MINOR__ < 9) \
- && !defined __clang__) \
- || (defined __clang__ && __clang_major__ < 8))
-# ifdef __cplusplus
-# if (201103 <= __cplusplus || defined _MSC_VER)
-# define _Alignof(type) alignof (type)
+# endif
+
+/* ISO C23 alignas and alignof for platforms that lack it.
+
+ References:
+ ISO C23 (latest free draft
+ <http://www.open-std.org/jtc1/sc22/wg14/www/docs/n3047.pdf>)
+ sections 6.5.3.4, 6.7.5, 7.15.
+ C++11 (latest free draft
+ <http://www.open-std.org/jtc1/sc22/wg21/docs/papers/2011/n3242.pdf>)
+ section 18.10. */
+
+/* alignof (TYPE), also known as _Alignof (TYPE), yields the alignment
+ requirement of a structure member (i.e., slot or field) that is of
+ type TYPE, as an integer constant expression.
+
+ This differs from GCC's and clang's __alignof__ operator, which can
+ yield a better-performing alignment for an object of that type. For
+ example, on x86 with GCC and on Linux/x86 with clang,
+ __alignof__ (double) and __alignof__ (long long) are 8, whereas
+ alignof (double) and alignof (long long) are 4 unless the option
+ '-malign-double' is used.
+
+ The result cannot be used as a value for an 'enum' constant, if you
+ want to be portable to HP-UX 10.20 cc and AIX 3.2.5 xlc. */
+
+/* GCC releases before GCC 4.9 had a bug in _Alignof. See GCC bug 52023
+ <https://gcc.gnu.org/bugzilla/show_bug.cgi?id=52023>.
+ clang versions < 8.0.0 have the same bug. */
+# if (!defined __STDC_VERSION__ || __STDC_VERSION__ < 201112 \
+ || (defined __GNUC__ && __GNUC__ < 4 + (__GNUC_MINOR__ < 9) \
+ && !defined __clang__) \
+ || (defined __clang__ && __clang_major__ < 8))
+# undef/**/_Alignof
+# ifdef __cplusplus
+# if (201103 <= __cplusplus || defined _MSC_VER)
+# define _Alignof(type) alignof (type)
+# else
+ template <class __t> struct __alignof_helper { char __a; __t __b; };
+# if (defined __GNUC__ && 4 <= __GNUC__) || defined __clang__
+# define _Alignof(type) __builtin_offsetof (__alignof_helper<type>, __b)
# else
- template <class __t> struct __alignof_helper { char __a; __t __b; };
# define _Alignof(type) offsetof (__alignof_helper<type>, __b)
-# define _GL_STDALIGN_NEEDS_STDDEF 1
# endif
+# define _GL_STDALIGN_NEEDS_STDDEF 1
+# endif
+# else
+# if (defined __GNUC__ && 4 <= __GNUC__) || defined __clang__
+# define _Alignof(type) __builtin_offsetof (struct { char __a; type __b; }, __b)
# else
# define _Alignof(type) offsetof (struct { char __a; type __b; }, __b)
# define _GL_STDALIGN_NEEDS_STDDEF 1
# endif
# endif
-# if ! (defined __cplusplus && (201103 <= __cplusplus || defined _MSC_VER))
-# define alignof _Alignof
-# endif
-# define __alignof_is_defined 1
-# if !defined __STDC_VERSION__ || __STDC_VERSION__ < 201112
-# if defined __cplusplus && (201103 <= __cplusplus || defined _MSC_VER)
-# define _Alignas(a) alignas (a)
-# elif (!defined __attribute__ \
- && ((defined __APPLE__ && defined __MACH__ \
- ? 4 < __GNUC__ + (1 <= __GNUC_MINOR__) \
- : __GNUC__ && !defined __ibmxl__) \
- || (4 <= __clang_major__) \
- || (__ia64 && (61200 <= __HP_cc || 61200 <= __HP_aCC)) \
- || __ICC || 0x590 <= __SUNPRO_C || 0x0600 <= __xlC__))
-# define _Alignas(a) __attribute__ ((__aligned__ (a)))
-# elif 1300 <= _MSC_VER
-# define _Alignas(a) __declspec (align (a))
-# endif
-# endif
-# if ((defined _Alignas \
- && !(defined __cplusplus && (201103 <= __cplusplus || defined _MSC_VER))) \
- || (defined __STDC_VERSION__ && 201112 <= __STDC_VERSION__))
-# define alignas _Alignas
-# endif
-# if (defined alignas \
- || (defined __cplusplus && (201103 <= __cplusplus || defined _MSC_VER)))
-# define __alignas_is_defined 1
-# endif
-# if _GL_STDALIGN_NEEDS_STDDEF
-# include <stddef.h>
-# endif
-# endif /* _GL_STDALIGN_H */
+# endif
+# if ! (defined __cplusplus && (201103 <= __cplusplus || defined _MSC_VER))
+# undef/**/alignof
+# define alignof _Alignof
+# endif
+
+/* alignas (A), also known as _Alignas (A), aligns a variable or type
+ to the alignment A, where A is an integer constant expression. For
+ example:
+
+ int alignas (8) foo;
+ struct s { int a; int alignas (8) bar; };
+
+ aligns the address of FOO and the offset of BAR to be multiples of 8.
+
+ A should be a power of two that is at least the type's alignment
+ and at most the implementation's alignment limit. This limit is
+ 2**28 on typical GNUish hosts, and 2**13 on MSVC. To be portable
+ to MSVC through at least version 10.0, A should be an integer
+ constant, as MSVC does not support expressions such as 1 << 3.
+ To be portable to Sun C 5.11, do not align auto variables to
+ anything stricter than their default alignment.
+
+ The following C23 requirements are not supported here:
+
+ - If A is zero, alignas has no effect.
+ - alignas can be used multiple times; the strictest one wins.
+ - alignas (TYPE) is equivalent to alignas (alignof (TYPE)).
+
+ */
+# if !defined __STDC_VERSION__ || __STDC_VERSION__ < 201112
+# if defined __cplusplus && (201103 <= __cplusplus || defined _MSC_VER)
+# define _Alignas(a) alignas (a)
+# elif (!defined __attribute__ \
+ && ((defined __APPLE__ && defined __MACH__ \
+ ? 4 < __GNUC__ + (1 <= __GNUC_MINOR__) \
+ : __GNUC__ && !defined __ibmxl__) \
+ || (4 <= __clang_major__) \
+ || (__ia64 && (61200 <= __HP_cc || 61200 <= __HP_aCC)) \
+ || __ICC || 0x590 <= __SUNPRO_C || 0x0600 <= __xlC__))
+# define _Alignas(a) __attribute__ ((__aligned__ (a)))
+# elif 1300 <= _MSC_VER
+# define _Alignas(a) __declspec (align (a))
+# endif
+# endif
+# if !defined HAVE_STDALIGN_H
+# if ((defined _Alignas \
+ && !(defined __cplusplus \
+ && (201103 <= __cplusplus || defined _MSC_VER))) \
+ || (defined __STDC_VERSION__ && 201112 <= __STDC_VERSION__))
+# define alignas _Alignas
+# endif
+# endif
+
+# if defined _GL_STDALIGN_NEEDS_STDDEF
+# include <stddef.h>
# endif
#endif])
])
+
+AC_DEFUN([gl_STDALIGN_H],
+[
+ AC_REQUIRE([gl_ALIGNASOF])
+ if test "$gl_cv_header_working_stdalign_h" = no; then
+ GL_GENERATE_STDALIGN_H=true
+ else
+ GL_GENERATE_STDALIGN_H=false
+ fi
+
+ gl_CHECK_NEXT_HEADERS([stdalign.h])
+ if test $ac_cv_header_stdalign_h = yes; then
+ HAVE_STDALIGN_H=1
+ else
+ HAVE_STDALIGN_H=0
+ fi
+ AC_SUBST([HAVE_STDALIGN_H])
+])
diff --git a/m4/stddef_h.m4 b/m4/stddef_h.m4
index 3430bb58faf..1bf9eb39b66 100644
--- a/m4/stddef_h.m4
+++ b/m4/stddef_h.m4
@@ -1,4 +1,4 @@
-# stddef_h.m4 serial 12
+# stddef_h.m4 serial 14
dnl Copyright (C) 2009-2024 Free Software Foundation, Inc.
dnl This file is free software; the Free Software Foundation
dnl gives unlimited permission to copy and/or distribute it,
@@ -22,7 +22,14 @@ AC_DEFUN_ONCE([gl_STDDEF_H],
[gl_cv_type_max_align_t],
[AC_COMPILE_IFELSE(
[AC_LANG_PROGRAM(
- [[#include <stddef.h>
+ [[/* On FreeBSD 12.0/x86, max_align_t defined by <stddef.h> has
+ the correct alignment with the default (wrong) definition of
+ _Alignof, but a wrong alignment as soon as we activate an
+ ISO C compliant _Alignof definition. */
+ #if ((defined __GNUC__ && 4 <= __GNUC__) || defined __clang__) && !defined __cplusplus
+ #define _Alignof(type) __builtin_offsetof (struct { char __a; type __b; }, __b)
+ #endif
+ #include <stddef.h>
unsigned int s = sizeof (max_align_t);
#if defined __GNUC__ || defined __clang__ || defined __IBM__ALIGNOF__
int check1[2 * (__alignof__ (double) <= __alignof__ (max_align_t)) - 1];
@@ -61,6 +68,21 @@ AC_DEFUN_ONCE([gl_STDDEF_H],
GL_GENERATE_STDDEF_H=true
fi
+ AC_CACHE_CHECK([for unreachable],
+ [gl_cv_func_unreachable],
+ [AC_LINK_IFELSE(
+ [AC_LANG_PROGRAM(
+ [[#include <stddef.h>
+ ]],
+ [[unreachable ();
+ ]])],
+ [gl_cv_func_unreachable=yes],
+ [gl_cv_func_unreachable=no])
+ ])
+ if test $gl_cv_func_unreachable = no; then
+ GL_GENERATE_STDDEF_H=true
+ fi
+
if $GL_GENERATE_STDDEF_H; then
gl_NEXT_HEADERS([stddef.h])
fi
diff --git a/m4/stdint.m4 b/m4/stdint.m4
index 67c05c28216..4aa250827cc 100644
--- a/m4/stdint.m4
+++ b/m4/stdint.m4
@@ -1,4 +1,4 @@
-# stdint.m4 serial 61
+# stdint.m4 serial 63
dnl Copyright (C) 2001-2024 Free Software Foundation, Inc.
dnl This file is free software; the Free Software Foundation
dnl gives unlimited permission to copy and/or distribute it,
@@ -150,7 +150,10 @@ intmax_t i = INTMAX_MAX;
uintmax_t j = UINTMAX_MAX;
/* Check that SIZE_MAX has the correct type, if possible. */
-#if 201112 <= __STDC_VERSION__
+/* ISO C 11 mandates _Generic, but GCC versions < 4.9 lack it. */
+#if 201112 <= __STDC_VERSION__ \
+ && (!defined __GNUC__ || 4 < __GNUC__ + (9 <= __GNUC_MINOR__) \
+ || defined __clang__)
int k = _Generic (SIZE_MAX, size_t: 0);
#elif (2 <= __GNUC__ || 4 <= __clang_major__ || defined __IBM__TYPEOF__ \
|| (0x5110 <= __SUNPRO_C && !__STDC__))
@@ -283,10 +286,10 @@ static const char *macro_values[] =
[gl_cv_header_working_stdint_h=yes],
[],
[case "$host_os" in
- # Guess yes on native Windows.
- mingw*) gl_cv_header_working_stdint_h="guessing yes" ;;
- # In general, assume it works.
- *) gl_cv_header_working_stdint_h="guessing yes" ;;
+ # Guess yes on native Windows.
+ mingw* | windows*) gl_cv_header_working_stdint_h="guessing yes" ;;
+ # In general, assume it works.
+ *) gl_cv_header_working_stdint_h="guessing yes" ;;
esac
])
])
diff --git a/m4/stdio_h.m4 b/m4/stdio_h.m4
index a2e0b6d684e..c19feefe717 100644
--- a/m4/stdio_h.m4
+++ b/m4/stdio_h.m4
@@ -1,12 +1,22 @@
-# stdio_h.m4 serial 59
+# stdio_h.m4 serial 63
dnl Copyright (C) 2007-2024 Free Software Foundation, Inc.
dnl This file is free software; the Free Software Foundation
dnl gives unlimited permission to copy and/or distribute it,
dnl with or without modifications, as long as this notice is preserved.
-AC_DEFUN_ONCE([gl_STDIO_H],
+AC_DEFUN([gl_STDIO_H_EARLY],
[
- AC_REQUIRE([gl_STDIO_H_DEFAULTS])
+ dnl Defining __USE_MINGW_ANSI_STDIO to 1 must be done early, because
+ dnl the results of several configure tests depend on it: The tests
+ dnl - checking whether snprintf returns a byte count as in C99...
+ dnl - checking whether snprintf truncates the result as in C99...
+ dnl - checking whether printf supports the 'F' directive...
+ dnl - checking whether printf supports the grouping flag...
+ dnl - checking whether printf supports the zero flag correctly...
+ dnl - checking whether printf supports infinite 'double' arguments...
+ dnl - checking whether printf supports large precisions...
+ dnl report 'yes' if __USE_MINGW_ANSI_STDIO is 1 but 'no' if
+ dnl __USE_MINGW_ANSI_STDIO is not set.
AH_VERBATIM([MINGW_ANSI_STDIO],
[/* Use GNU style printf and scanf. */
#ifndef __USE_MINGW_ANSI_STDIO
@@ -14,6 +24,11 @@ AC_DEFUN_ONCE([gl_STDIO_H],
#endif
])
AC_DEFINE([__USE_MINGW_ANSI_STDIO])
+])
+
+AC_DEFUN_ONCE([gl_STDIO_H],
+[
+ AC_REQUIRE([gl_STDIO_H_DEFAULTS])
gl_NEXT_HEADERS([stdio.h])
dnl Determine whether __USE_MINGW_ANSI_STDIO makes printf and
@@ -40,6 +55,9 @@ AC_DEFUN_ONCE([gl_STDIO_H],
attribute "__gnu_printf__" instead of "__printf__"])
fi
+ dnl For defining _PRINTF_NAN_LEN_MAX.
+ gl_MUSL_LIBC
+
dnl This ifdef is an optimization, to avoid performing a configure check whose
dnl result is not used. But it does not make the test of
dnl GNULIB_STDIO_H_NONBLOCKING or GNULIB_NONBLOCKING redundant.
@@ -82,6 +100,16 @@ AC_DEFUN_ONCE([gl_STDIO_H],
if test $ac_cv_have_decl_fcloseall = no; then
HAVE_DECL_FCLOSEALL=0
fi
+
+ AC_CHECK_DECLS_ONCE([getw])
+ if test $ac_cv_have_decl_getw = no; then
+ HAVE_DECL_GETW=0
+ fi
+
+ AC_CHECK_DECLS_ONCE([putw])
+ if test $ac_cv_have_decl_putw = no; then
+ HAVE_DECL_PUTW=0
+ fi
])
# gl_STDIO_MODULE_INDICATOR([modulename])
@@ -178,7 +206,9 @@ AC_DEFUN([gl_STDIO_H_DEFAULTS],
HAVE_DECL_FTELLO=1; AC_SUBST([HAVE_DECL_FTELLO])
HAVE_DECL_GETDELIM=1; AC_SUBST([HAVE_DECL_GETDELIM])
HAVE_DECL_GETLINE=1; AC_SUBST([HAVE_DECL_GETLINE])
+ HAVE_DECL_GETW=1; AC_SUBST([HAVE_DECL_GETW])
HAVE_DECL_OBSTACK_PRINTF=1; AC_SUBST([HAVE_DECL_OBSTACK_PRINTF])
+ HAVE_DECL_PUTW=1; AC_SUBST([HAVE_DECL_PUTW])
HAVE_DECL_SNPRINTF=1; AC_SUBST([HAVE_DECL_SNPRINTF])
HAVE_DECL_VSNPRINTF=1; AC_SUBST([HAVE_DECL_VSNPRINTF])
HAVE_DPRINTF=1; AC_SUBST([HAVE_DPRINTF])
diff --git a/m4/stdlib_h.m4 b/m4/stdlib_h.m4
index b859dcb2f3c..92e67a74bb5 100644
--- a/m4/stdlib_h.m4
+++ b/m4/stdlib_h.m4
@@ -1,4 +1,4 @@
-# stdlib_h.m4 serial 66
+# stdlib_h.m4 serial 76
dnl Copyright (C) 2007-2024 Free Software Foundation, Inc.
dnl This file is free software; the Free Software Foundation
dnl gives unlimited permission to copy and/or distribute it,
@@ -23,15 +23,58 @@ AC_DEFUN_ONCE([gl_STDLIB_H],
# include <random.h>
#endif
]], [_Exit aligned_alloc atoll canonicalize_file_name free
- getloadavg getsubopt grantpt
- initstate initstate_r mbtowc mkdtemp mkostemp mkostemps mkstemp mkstemps
- posix_memalign posix_openpt ptsname ptsname_r qsort_r
+ getloadavg getprogname getsubopt grantpt
+ initstate initstate_r mbstowcs mbtowc mkdtemp mkostemp mkostemps mkstemp
+ mkstemps posix_memalign posix_openpt ptsname ptsname_r qsort_r
random random_r reallocarray realpath rpmatch secure_getenv setenv
setstate setstate_r srandom srandom_r
strtod strtol strtold strtoll strtoul strtoull unlockpt unsetenv])
AC_REQUIRE([AC_C_RESTRICT])
+ dnl Test whether MB_CUR_MAX needs to be overridden.
+ dnl On Solaris 10, in UTF-8 locales, its value is 3 but needs to be 4.
+ dnl Fortunately, we can do this because on this platform MB_LEN_MAX is 5.
+ AC_REQUIRE([AC_CANONICAL_HOST])
+ AC_REQUIRE([gt_LOCALE_FR_UTF8])
+ AC_CACHE_CHECK([whether MB_CUR_MAX is correct],
+ [gl_cv_macro_MB_CUR_MAX_good],
+ [
+ dnl Initial guess, used when cross-compiling or when no suitable locale
+ dnl is present.
+changequote(,)dnl
+ case "$host_os" in
+ # Guess no on Solaris.
+ solaris*) gl_cv_macro_MB_CUR_MAX_good="guessing no" ;;
+ # Guess yes otherwise.
+ *) gl_cv_macro_MB_CUR_MAX_good="guessing yes" ;;
+ esac
+changequote([,])dnl
+ if test $LOCALE_FR_UTF8 != none; then
+ AC_RUN_IFELSE(
+ [AC_LANG_SOURCE([[
+#include <locale.h>
+#include <stdlib.h>
+int main ()
+{
+ int result = 0;
+ if (setlocale (LC_ALL, "$LOCALE_FR_UTF8") != NULL)
+ {
+ if (MB_CUR_MAX < 4)
+ result |= 1;
+ }
+ return result;
+}]])],
+ [gl_cv_macro_MB_CUR_MAX_good=yes],
+ [gl_cv_macro_MB_CUR_MAX_good=no],
+ [:])
+ fi
+ ])
+ case "$gl_cv_macro_MB_CUR_MAX_good" in
+ *yes) ;;
+ *) REPLACE_MB_CUR_MAX=1 ;;
+ esac
+
AC_CHECK_DECLS_ONCE([ecvt])
if test $ac_cv_have_decl_ecvt = no; then
HAVE_DECL_ECVT=0
@@ -73,10 +116,12 @@ AC_DEFUN([gl_STDLIB_H_REQUIRE_DEFAULTS],
gl_MODULE_INDICATOR_INIT_VARIABLE([GNULIB_CANONICALIZE_FILE_NAME])
gl_MODULE_INDICATOR_INIT_VARIABLE([GNULIB_FREE_POSIX])
gl_MODULE_INDICATOR_INIT_VARIABLE([GNULIB_GETLOADAVG])
+ gl_MODULE_INDICATOR_INIT_VARIABLE([GNULIB_GETPROGNAME])
gl_MODULE_INDICATOR_INIT_VARIABLE([GNULIB_GETSUBOPT])
gl_MODULE_INDICATOR_INIT_VARIABLE([GNULIB_GRANTPT])
gl_MODULE_INDICATOR_INIT_VARIABLE([GNULIB_MALLOC_GNU])
gl_MODULE_INDICATOR_INIT_VARIABLE([GNULIB_MALLOC_POSIX])
+ gl_MODULE_INDICATOR_INIT_VARIABLE([GNULIB_MBSTOWCS])
gl_MODULE_INDICATOR_INIT_VARIABLE([GNULIB_MBTOWC])
gl_MODULE_INDICATOR_INIT_VARIABLE([GNULIB_MKDTEMP])
gl_MODULE_INDICATOR_INIT_VARIABLE([GNULIB_MKOSTEMP])
@@ -89,6 +134,7 @@ AC_DEFUN([gl_STDLIB_H_REQUIRE_DEFAULTS],
gl_MODULE_INDICATOR_INIT_VARIABLE([GNULIB_PTSNAME_R])
gl_MODULE_INDICATOR_INIT_VARIABLE([GNULIB_PUTENV])
gl_MODULE_INDICATOR_INIT_VARIABLE([GNULIB_QSORT_R])
+ gl_MODULE_INDICATOR_INIT_VARIABLE([GNULIB_RAND])
gl_MODULE_INDICATOR_INIT_VARIABLE([GNULIB_RANDOM])
gl_MODULE_INDICATOR_INIT_VARIABLE([GNULIB_RANDOM_R])
gl_MODULE_INDICATOR_INIT_VARIABLE([GNULIB_REALLOCARRAY])
@@ -130,6 +176,8 @@ AC_DEFUN([gl_STDLIB_H_DEFAULTS],
HAVE_DECL_FCVT=1; AC_SUBST([HAVE_DECL_FCVT])
HAVE_DECL_GCVT=1; AC_SUBST([HAVE_DECL_GCVT])
HAVE_DECL_GETLOADAVG=1; AC_SUBST([HAVE_DECL_GETLOADAVG])
+ HAVE_DECL_PROGRAM_INVOCATION_NAME=1; AC_SUBST([HAVE_DECL_PROGRAM_INVOCATION_NAME])
+ HAVE_GETPROGNAME=1; AC_SUBST([HAVE_GETPROGNAME])
HAVE_GETSUBOPT=1; AC_SUBST([HAVE_GETSUBOPT])
HAVE_GRANTPT=1; AC_SUBST([HAVE_GRANTPT])
HAVE_INITSTATE=1; AC_SUBST([HAVE_INITSTATE])
@@ -166,21 +214,31 @@ AC_DEFUN([gl_STDLIB_H_DEFAULTS],
HAVE_SYS_LOADAVG_H=0; AC_SUBST([HAVE_SYS_LOADAVG_H])
HAVE_UNLOCKPT=1; AC_SUBST([HAVE_UNLOCKPT])
HAVE_DECL_UNSETENV=1; AC_SUBST([HAVE_DECL_UNSETENV])
+ REPLACE__EXIT=0; AC_SUBST([REPLACE__EXIT])
REPLACE_ALIGNED_ALLOC=0; AC_SUBST([REPLACE_ALIGNED_ALLOC])
REPLACE_CALLOC_FOR_CALLOC_GNU=0; AC_SUBST([REPLACE_CALLOC_FOR_CALLOC_GNU])
REPLACE_CALLOC_FOR_CALLOC_POSIX=0; AC_SUBST([REPLACE_CALLOC_FOR_CALLOC_POSIX])
REPLACE_CANONICALIZE_FILE_NAME=0; AC_SUBST([REPLACE_CANONICALIZE_FILE_NAME])
REPLACE_FREE=0; AC_SUBST([REPLACE_FREE])
+ REPLACE_GETLOADAVG=0; AC_SUBST([REPLACE_GETLOADAVG])
+ REPLACE_GETPROGNAME=0; AC_SUBST([REPLACE_GETPROGNAME])
+ REPLACE_GETSUBOPT=0; AC_SUBST([REPLACE_GETSUBOPT])
REPLACE_INITSTATE=0; AC_SUBST([REPLACE_INITSTATE])
REPLACE_MALLOC_FOR_MALLOC_GNU=0; AC_SUBST([REPLACE_MALLOC_FOR_MALLOC_GNU])
REPLACE_MALLOC_FOR_MALLOC_POSIX=0; AC_SUBST([REPLACE_MALLOC_FOR_MALLOC_POSIX])
+ REPLACE_MB_CUR_MAX=0; AC_SUBST([REPLACE_MB_CUR_MAX])
+ REPLACE_MBSTOWCS=0; AC_SUBST([REPLACE_MBSTOWCS])
REPLACE_MBTOWC=0; AC_SUBST([REPLACE_MBTOWC])
+ REPLACE_MKOSTEMP=0; AC_SUBST([REPLACE_MKOSTEMP])
+ REPLACE_MKOSTEMPS=0; AC_SUBST([REPLACE_MKOSTEMPS])
REPLACE_MKSTEMP=0; AC_SUBST([REPLACE_MKSTEMP])
REPLACE_POSIX_MEMALIGN=0; AC_SUBST([REPLACE_POSIX_MEMALIGN])
+ REPLACE_POSIX_OPENPT=0; AC_SUBST([REPLACE_POSIX_OPENPT])
REPLACE_PTSNAME=0; AC_SUBST([REPLACE_PTSNAME])
REPLACE_PTSNAME_R=0; AC_SUBST([REPLACE_PTSNAME_R])
REPLACE_PUTENV=0; AC_SUBST([REPLACE_PUTENV])
REPLACE_QSORT_R=0; AC_SUBST([REPLACE_QSORT_R])
+ REPLACE_RAND=0; AC_SUBST([REPLACE_RAND])
REPLACE_RANDOM=0; AC_SUBST([REPLACE_RANDOM])
REPLACE_RANDOM_R=0; AC_SUBST([REPLACE_RANDOM_R])
REPLACE_REALLOC_FOR_REALLOC_GNU=0; AC_SUBST([REPLACE_REALLOC_FOR_REALLOC_GNU])
diff --git a/m4/stpcpy.m4 b/m4/stpcpy.m4
index 8fba4d26f06..04c8bbe4c94 100644
--- a/m4/stpcpy.m4
+++ b/m4/stpcpy.m4
@@ -1,4 +1,4 @@
-# stpcpy.m4 serial 9
+# stpcpy.m4 serial 11
dnl Copyright (C) 2002, 2007, 2009-2024 Free Software Foundation, Inc.
dnl This file is free software; the Free Software Foundation
dnl gives unlimited permission to copy and/or distribute it,
@@ -13,9 +13,12 @@ AC_DEFUN([gl_FUNC_STPCPY],
AC_REQUIRE([AC_C_RESTRICT])
AC_REQUIRE([gl_STRING_H_DEFAULTS])
- AC_CHECK_FUNCS([stpcpy])
+ gl_CHECK_FUNCS_ANDROID([stpcpy], [[#include <string.h>]])
if test $ac_cv_func_stpcpy = no; then
HAVE_STPCPY=0
+ case "$gl_cv_onwards_func_stpcpy" in
+ future*) REPLACE_STPCPY=1 ;;
+ esac
fi
])
diff --git a/m4/string_h.m4 b/m4/string_h.m4
index 77648236c98..9ea748cc774 100644
--- a/m4/string_h.m4
+++ b/m4/string_h.m4
@@ -5,7 +5,7 @@
# gives unlimited permission to copy and/or distribute it,
# with or without modifications, as long as this notice is preserved.
-# serial 34
+# serial 39
# Written by Paul Eggert.
@@ -21,7 +21,8 @@ AC_DEFUN_ONCE([gl_STRING_H],
dnl guaranteed by C89.
gl_WARN_ON_USE_PREPARE([[#include <string.h>
]],
- [ffsl ffsll memmem mempcpy memrchr rawmemchr stpcpy stpncpy strchrnul
+ [explicit_bzero ffsl ffsll memmem mempcpy memrchr memset_explicit
+ rawmemchr stpcpy stpncpy strchrnul
strdup strncat strndup strnlen strpbrk strsep strcasestr strtok_r
strerror_r strerrorname_np sigabbrev_np sigdescr_np strsignal strverscmp])
@@ -54,6 +55,7 @@ AC_DEFUN([gl_STRING_H_REQUIRE_DEFAULTS],
gl_MODULE_INDICATOR_INIT_VARIABLE([GNULIB_MEMMEM])
gl_MODULE_INDICATOR_INIT_VARIABLE([GNULIB_MEMPCPY])
gl_MODULE_INDICATOR_INIT_VARIABLE([GNULIB_MEMRCHR])
+ gl_MODULE_INDICATOR_INIT_VARIABLE([GNULIB_MEMSET_EXPLICIT])
gl_MODULE_INDICATOR_INIT_VARIABLE([GNULIB_RAWMEMCHR])
gl_MODULE_INDICATOR_INIT_VARIABLE([GNULIB_STPCPY])
gl_MODULE_INDICATOR_INIT_VARIABLE([GNULIB_STPNCPY])
@@ -107,6 +109,7 @@ AC_DEFUN([gl_STRING_H_DEFAULTS],
HAVE_FFSLL=1; AC_SUBST([HAVE_FFSLL])
HAVE_DECL_MEMMEM=1; AC_SUBST([HAVE_DECL_MEMMEM])
HAVE_MEMPCPY=1; AC_SUBST([HAVE_MEMPCPY])
+ HAVE_MEMSET_EXPLICIT=1; AC_SUBST([HAVE_MEMSET_EXPLICIT])
HAVE_DECL_MEMRCHR=1; AC_SUBST([HAVE_DECL_MEMRCHR])
HAVE_RAWMEMCHR=1; AC_SUBST([HAVE_RAWMEMCHR])
HAVE_STPCPY=1; AC_SUBST([HAVE_STPCPY])
@@ -128,6 +131,9 @@ AC_DEFUN([gl_STRING_H_DEFAULTS],
REPLACE_FFSLL=0; AC_SUBST([REPLACE_FFSLL])
REPLACE_MEMCHR=0; AC_SUBST([REPLACE_MEMCHR])
REPLACE_MEMMEM=0; AC_SUBST([REPLACE_MEMMEM])
+ REPLACE_MEMPCPY=0; AC_SUBST([REPLACE_MEMPCPY])
+ REPLACE_MEMSET_EXPLICIT=0; AC_SUBST([REPLACE_MEMSET_EXPLICIT])
+ REPLACE_STPCPY=0; AC_SUBST([REPLACE_STPCPY])
REPLACE_STPNCPY=0; AC_SUBST([REPLACE_STPNCPY])
REPLACE_STRCHRNUL=0; AC_SUBST([REPLACE_STRCHRNUL])
REPLACE_STRDUP=0; AC_SUBST([REPLACE_STRDUP])
@@ -141,5 +147,6 @@ AC_DEFUN([gl_STRING_H_DEFAULTS],
REPLACE_STRERROR_R=0; AC_SUBST([REPLACE_STRERROR_R])
REPLACE_STRERRORNAME_NP=0; AC_SUBST([REPLACE_STRERRORNAME_NP])
REPLACE_STRSIGNAL=0; AC_SUBST([REPLACE_STRSIGNAL])
+ REPLACE_STRVERSCMP=0; AC_SUBST([REPLACE_STRVERSCMP])
UNDEFINE_STRTOK_R=0; AC_SUBST([UNDEFINE_STRTOK_R])
])
diff --git a/m4/strnlen.m4 b/m4/strnlen.m4
index 16b351a3d41..3eac8e629d7 100644
--- a/m4/strnlen.m4
+++ b/m4/strnlen.m4
@@ -1,6 +1,6 @@
# strnlen.m4 serial 14
-dnl Copyright (C) 2002-2003, 2005-2007, 2009-2024 Free Software
-dnl Foundation, Inc.
+dnl Copyright (C) 2002-2003, 2005-2007, 2009-2024 Free Software Foundation,
+dnl Inc.
dnl This file is free software; the Free Software Foundation
dnl gives unlimited permission to copy and/or distribute it,
dnl with or without modifications, as long as this notice is preserved.
diff --git a/m4/strtoimax.m4 b/m4/strtoimax.m4
index 0708d7e1ce8..b58fa48ff6e 100644
--- a/m4/strtoimax.m4
+++ b/m4/strtoimax.m4
@@ -1,6 +1,5 @@
-# strtoimax.m4 serial 16
-dnl Copyright (C) 2002-2004, 2006, 2009-2024 Free Software Foundation,
-dnl Inc.
+# strtoimax.m4 serial 17
+dnl Copyright (C) 2002-2004, 2006, 2009-2024 Free Software Foundation, Inc.
dnl This file is free software; the Free Software Foundation
dnl gives unlimited permission to copy and/or distribute it,
dnl with or without modifications, as long as this notice is preserved.
@@ -62,12 +61,12 @@ int main ()
[gl_cv_func_strtoimax=yes],
[gl_cv_func_strtoimax=no],
[case "$host_os" in
- # Guess no on AIX 5.
- aix5*) gl_cv_func_strtoimax="guessing no" ;;
- # Guess yes on native Windows.
- mingw*) gl_cv_func_strtoimax="guessing yes" ;;
- # Guess yes otherwise.
- *) gl_cv_func_strtoimax="guessing yes" ;;
+ # Guess no on AIX 5.
+ aix5*) gl_cv_func_strtoimax="guessing no" ;;
+ # Guess yes on native Windows.
+ mingw* | windows*) gl_cv_func_strtoimax="guessing yes" ;;
+ # Guess yes otherwise.
+ *) gl_cv_func_strtoimax="guessing yes" ;;
esac
])
])
diff --git a/m4/strtoll.m4 b/m4/strtoll.m4
index 0ce3a4258f3..130b9094d88 100644
--- a/m4/strtoll.m4
+++ b/m4/strtoll.m4
@@ -1,6 +1,5 @@
-# strtoll.m4 serial 9
-dnl Copyright (C) 2002, 2004, 2006, 2008-2024 Free Software Foundation,
-dnl Inc.
+# strtoll.m4 serial 12
+dnl Copyright (C) 2002, 2004, 2006, 2008-2024 Free Software Foundation, Inc.
dnl This file is free software; the Free Software Foundation
dnl gives unlimited permission to copy and/or distribute it,
dnl with or without modifications, as long as this notice is preserved.
@@ -20,10 +19,23 @@ AC_DEFUN([gl_FUNC_STRTOLL],
char *term;
/* This test fails on Minix and native Windows. */
{
- const char input[] = "0x";
- (void) strtoll (input, &term, 16);
- if (term != input + 1)
- result |= 1;
+ static char const input[2][3] = {"0x", "0b"};
+ static int const base[] = {0, 2, 10};
+ int i, j;
+ for (i = 0; i < 2; i++)
+ for (j = 0; j < 3; j++)
+ {
+ (void) strtoll (input[i], &term, base[j]);
+ if (term != input[i] + 1)
+ result |= 1;
+ }
+ }
+ /* This test fails on pre-C23 platforms. */
+ {
+ const char input[] = "0b1";
+ (void) strtoll (input, &term, 2);
+ if (term != input + 3)
+ result |= 2;
}
return result;
]])
@@ -31,9 +43,13 @@ AC_DEFUN([gl_FUNC_STRTOLL],
[gl_cv_func_strtoll_works=yes],
[gl_cv_func_strtoll_works=no],
[case "$host_os" in
- # Guess no on native Windows.
- mingw*) gl_cv_func_strtoll_works="guessing no" ;;
- *) gl_cv_func_strtoll_works="$gl_cross_guess_normal" ;;
+ # Guess no on native Windows.
+ mingw* | windows*) gl_cv_func_strtoll_works="guessing no" ;;
+ # Guess no on glibc systems.
+ *-gnu* | gnu*) gl_cv_func_strtoll_works="guessing no" ;;
+ # Guess no on musl systems.
+ *-musl* | midipix*) gl_cv_func_strtoll_works="guessing no" ;;
+ *) gl_cv_func_strtoll_works="$gl_cross_guess_normal" ;;
esac
])
])
diff --git a/m4/symlink.m4 b/m4/symlink.m4
index f0242c52572..62062cf1499 100644
--- a/m4/symlink.m4
+++ b/m4/symlink.m4
@@ -1,4 +1,4 @@
-# serial 9
+# serial 10
# See if we need to provide symlink replacement.
dnl Copyright (C) 2009-2024 Free Software Foundation, Inc.
@@ -38,6 +38,8 @@ AC_DEFUN([gl_FUNC_SYMLINK],
[case "$host_os" in
# Guess yes on Linux systems.
linux-* | linux) gl_cv_func_symlink_works="guessing yes" ;;
+ # Guess yes on systems that emulate the Linux system calls.
+ midipix*) gl_cv_func_symlink_works="guessing yes" ;;
# Guess yes on glibc systems.
*-gnu* | gnu*) gl_cv_func_symlink_works="guessing yes" ;;
# If we don't know, obey --enable-cross-guesses.
diff --git a/m4/time_h.m4 b/m4/time_h.m4
index 5acf14b5f63..32fade0f401 100644
--- a/m4/time_h.m4
+++ b/m4/time_h.m4
@@ -1,9 +1,8 @@
# Configure a more-standard replacement for <time.h>.
-# Copyright (C) 2000-2001, 2003-2007, 2009-2024 Free Software
-# Foundation, Inc.
+# Copyright (C) 2000-2001, 2003-2007, 2009-2024 Free Software Foundation, Inc.
-# serial 20
+# serial 25
# This file is free software; the Free Software Foundation
# gives unlimited permission to copy and/or distribute it,
@@ -24,7 +23,10 @@ AC_DEFUN_ONCE([gl_TIME_H],
dnl corresponding gnulib module is not in use.
gl_WARN_ON_USE_PREPARE([[
#include <time.h>
- ]], [asctime_r ctime_r])
+ ]], [
+ asctime asctime_r ctime ctime_r gmtime_r localtime localtime_r mktime
+ nanosleep strftime strptime time timegm timespec_get timespec_getres tzset
+ ])
AC_REQUIRE([AC_C_RESTRICT])
@@ -138,6 +140,7 @@ AC_DEFUN([gl_TIME_H_REQUIRE_DEFAULTS],
gl_MODULE_INDICATOR_INIT_VARIABLE([GNULIB_NANOSLEEP])
gl_MODULE_INDICATOR_INIT_VARIABLE([GNULIB_STRFTIME])
gl_MODULE_INDICATOR_INIT_VARIABLE([GNULIB_STRPTIME])
+ gl_MODULE_INDICATOR_INIT_VARIABLE([GNULIB_TIME])
gl_MODULE_INDICATOR_INIT_VARIABLE([GNULIB_TIMEGM])
gl_MODULE_INDICATOR_INIT_VARIABLE([GNULIB_TIMESPEC_GET])
gl_MODULE_INDICATOR_INIT_VARIABLE([GNULIB_TIMESPEC_GETRES])
@@ -162,23 +165,16 @@ AC_DEFUN([gl_TIME_H_DEFAULTS],
HAVE_TIMESPEC_GETRES=1; AC_SUBST([HAVE_TIMESPEC_GETRES])
dnl Even GNU libc does not have timezone_t yet.
HAVE_TIMEZONE_T=0; AC_SUBST([HAVE_TIMEZONE_T])
- dnl If another module says to replace or to not replace, do that.
- dnl Otherwise, replace only if someone compiles with -DGNULIB_PORTCHECK;
- dnl this lets maintainers check for portability.
- REPLACE_CTIME=GNULIB_PORTCHECK; AC_SUBST([REPLACE_CTIME])
- REPLACE_LOCALTIME_R=GNULIB_PORTCHECK; AC_SUBST([REPLACE_LOCALTIME_R])
- REPLACE_MKTIME=GNULIB_PORTCHECK; AC_SUBST([REPLACE_MKTIME])
- REPLACE_NANOSLEEP=GNULIB_PORTCHECK; AC_SUBST([REPLACE_NANOSLEEP])
- REPLACE_STRFTIME=GNULIB_PORTCHECK; AC_SUBST([REPLACE_STRFTIME])
- REPLACE_TIMEGM=GNULIB_PORTCHECK; AC_SUBST([REPLACE_TIMEGM])
- REPLACE_TZSET=GNULIB_PORTCHECK; AC_SUBST([REPLACE_TZSET])
-
- dnl Hack so that the time module doesn't depend on the sys_time module.
- dnl First, default GNULIB_GETTIMEOFDAY to 0 if sys_time is absent.
- : ${GNULIB_GETTIMEOFDAY=0}; AC_SUBST([GNULIB_GETTIMEOFDAY])
- dnl Second, it's OK to not use GNULIB_PORTCHECK for REPLACE_GMTIME
- dnl and REPLACE_LOCALTIME, as portability to Solaris 2.6 and earlier
- dnl is no longer a big deal.
+ REPLACE_CTIME=0; AC_SUBST([REPLACE_CTIME])
REPLACE_GMTIME=0; AC_SUBST([REPLACE_GMTIME])
REPLACE_LOCALTIME=0; AC_SUBST([REPLACE_LOCALTIME])
+ REPLACE_LOCALTIME_R=0; AC_SUBST([REPLACE_LOCALTIME_R])
+ REPLACE_MKTIME=0; AC_SUBST([REPLACE_MKTIME])
+ REPLACE_NANOSLEEP=0; AC_SUBST([REPLACE_NANOSLEEP])
+ REPLACE_STRFTIME=0; AC_SUBST([REPLACE_STRFTIME])
+ REPLACE_TIME=0; AC_SUBST([REPLACE_TIME])
+ REPLACE_TIMEGM=0; AC_SUBST([REPLACE_TIMEGM])
+ REPLACE_TIMESPEC_GET=0; AC_SUBST([REPLACE_TIMESPEC_GET])
+ REPLACE_TIMESPEC_GETRES=0; AC_SUBST([REPLACE_TIMESPEC_GETRES])
+ REPLACE_TZSET=0; AC_SUBST([REPLACE_TZSET])
])
diff --git a/m4/time_r.m4 b/m4/time_r.m4
index 66ac2db4d50..4ee2175b690 100644
--- a/m4/time_r.m4
+++ b/m4/time_r.m4
@@ -57,9 +57,7 @@ AC_DEFUN([gl_TIME_R],
[gl_cv_time_r_posix=yes],
[gl_cv_time_r_posix=no])
])
- if test $gl_cv_time_r_posix = yes; then
- REPLACE_LOCALTIME_R=0
- else
+ if test $gl_cv_time_r_posix != yes; then
REPLACE_LOCALTIME_R=1
fi
else
diff --git a/m4/timegm.m4 b/m4/timegm.m4
index d726d2d9595..84336043e5d 100644
--- a/m4/timegm.m4
+++ b/m4/timegm.m4
@@ -1,4 +1,4 @@
-# timegm.m4 serial 13
+# timegm.m4 serial 16
dnl Copyright (C) 2003, 2007, 2009-2024 Free Software Foundation, Inc.
dnl This file is free software; the Free Software Foundation
dnl gives unlimited permission to copy and/or distribute it,
@@ -8,8 +8,7 @@ AC_DEFUN([gl_FUNC_TIMEGM],
[
AC_REQUIRE([gl_TIME_H_DEFAULTS])
AC_REQUIRE([gl_FUNC_MKTIME_WORKS])
- REPLACE_TIMEGM=0
- AC_CHECK_FUNCS_ONCE([timegm])
+ gl_CHECK_FUNCS_ANDROID([timegm], [[#include <time.h>]])
if test $ac_cv_func_timegm = yes; then
if test "$gl_cv_func_working_mktime" != yes; then
# Assume that timegm is buggy if mktime is.
@@ -17,6 +16,9 @@ AC_DEFUN([gl_FUNC_TIMEGM],
fi
else
HAVE_TIMEGM=0
+ case "$gl_cv_onwards_func_timegm" in
+ future*) REPLACE_TIMEGM=1 ;;
+ esac
fi
])
diff --git a/m4/timer_time.m4 b/m4/timer_time.m4
index e9c0fbd88cd..10b7654d30f 100644
--- a/m4/timer_time.m4
+++ b/m4/timer_time.m4
@@ -1,10 +1,10 @@
-# timer_time.m4 serial 5
+# timer_time.m4 serial 6
dnl Copyright (C) 2011-2024 Free Software Foundation, Inc.
dnl This file is free software; the Free Software Foundation
dnl gives unlimited permission to copy and/or distribute it,
dnl with or without modifications, as long as this notice is preserved.
-# Check for timer_settime, and set LIB_TIMER_TIME.
+# Check for timer_settime, and set TIMER_TIME_LIB.
AC_DEFUN([gl_TIMER_TIME],
[
@@ -21,13 +21,13 @@ AC_DEFUN([gl_TIMER_TIME],
AC_CHECK_DECL([timer_settime], [], [],
[[#include <time.h>
]])
- LIB_TIMER_TIME=
- AC_SUBST([LIB_TIMER_TIME])
+ TIMER_TIME_LIB=
+ AC_SUBST([TIMER_TIME_LIB])
AS_IF([test "$ac_cv_have_decl_timer_settime" = yes], [
gl_saved_libs=$LIBS
AC_SEARCH_LIBS([timer_settime], [rt posix4],
[test "$ac_cv_search_timer_settime" = "none required" ||
- LIB_TIMER_TIME=$ac_cv_search_timer_settime])
+ TIMER_TIME_LIB=$ac_cv_search_timer_settime])
m4_ifdef([gl_][PTHREADLIB],
[dnl GLIBC uses threads to emulate posix timers when kernel support
dnl is not available (like Linux < 2.6 or when used with kFreeBSD)
@@ -42,8 +42,11 @@ AC_DEFUN([gl_TIMER_TIME],
#endif
#endif
],
- [LIB_TIMER_TIME="$LIB_TIMER_TIME $LIBPMULTITHREAD"])])
+ [TIMER_TIME_LIB="$TIMER_TIME_LIB $LIBPMULTITHREAD"])])
AC_CHECK_FUNCS([timer_settime])
LIBS=$gl_saved_libs
])
+ dnl For backward compatibility.
+ LIB_TIMER_TIME="$TIMER_TIME_LIB"
+ AC_SUBST([LIB_TIMER_TIME])
])
diff --git a/m4/timespec.m4 b/m4/timespec.m4
index 0a1c90e550c..59a0db9966e 100644
--- a/m4/timespec.m4
+++ b/m4/timespec.m4
@@ -1,7 +1,6 @@
#serial 15
-# Copyright (C) 2000-2001, 2003-2007, 2009-2024 Free Software
-# Foundation, Inc.
+# Copyright (C) 2000-2001, 2003-2007, 2009-2024 Free Software Foundation, Inc.
# This file is free software; the Free Software Foundation
# gives unlimited permission to copy and/or distribute it,
diff --git a/m4/unistd_h.m4 b/m4/unistd_h.m4
index f5ead753b87..e078bd617a7 100644
--- a/m4/unistd_h.m4
+++ b/m4/unistd_h.m4
@@ -1,4 +1,4 @@
-# unistd_h.m4 serial 90
+# unistd_h.m4 serial 95
dnl Copyright (C) 2006-2024 Free Software Foundation, Inc.
dnl This file is free software; the Free Software Foundation
dnl gives unlimited permission to copy and/or distribute it,
@@ -225,6 +225,7 @@ AC_DEFUN([gl_UNISTD_H_DEFAULTS],
REPLACE_COPY_FILE_RANGE=0; AC_SUBST([REPLACE_COPY_FILE_RANGE])
REPLACE_DUP=0; AC_SUBST([REPLACE_DUP])
REPLACE_DUP2=0; AC_SUBST([REPLACE_DUP2])
+ REPLACE_DUP3=0; AC_SUBST([REPLACE_DUP3])
REPLACE_EXECL=0; AC_SUBST([REPLACE_EXECL])
REPLACE_EXECLE=0; AC_SUBST([REPLACE_EXECLE])
REPLACE_EXECLP=0; AC_SUBST([REPLACE_EXECLP])
@@ -233,11 +234,14 @@ AC_DEFUN([gl_UNISTD_H_DEFAULTS],
REPLACE_EXECVP=0; AC_SUBST([REPLACE_EXECVP])
REPLACE_EXECVPE=0; AC_SUBST([REPLACE_EXECVPE])
REPLACE_FACCESSAT=0; AC_SUBST([REPLACE_FACCESSAT])
+ REPLACE_FCHDIR=0; AC_SUBST([REPLACE_FCHDIR])
REPLACE_FCHOWNAT=0; AC_SUBST([REPLACE_FCHOWNAT])
+ REPLACE_FDATASYNC=0; AC_SUBST([REPLACE_FDATASYNC])
REPLACE_FTRUNCATE=0; AC_SUBST([REPLACE_FTRUNCATE])
REPLACE_GETCWD=0; AC_SUBST([REPLACE_GETCWD])
REPLACE_GETDOMAINNAME=0; AC_SUBST([REPLACE_GETDOMAINNAME])
REPLACE_GETDTABLESIZE=0; AC_SUBST([REPLACE_GETDTABLESIZE])
+ REPLACE_GETENTROPY=0; AC_SUBST([REPLACE_GETENTROPY])
REPLACE_GETLOGIN_R=0; AC_SUBST([REPLACE_GETLOGIN_R])
REPLACE_GETGROUPS=0; AC_SUBST([REPLACE_GETGROUPS])
REPLACE_GETPAGESIZE=0; AC_SUBST([REPLACE_GETPAGESIZE])
@@ -248,12 +252,14 @@ AC_DEFUN([gl_UNISTD_H_DEFAULTS],
REPLACE_LINK=0; AC_SUBST([REPLACE_LINK])
REPLACE_LINKAT=0; AC_SUBST([REPLACE_LINKAT])
REPLACE_LSEEK=0; AC_SUBST([REPLACE_LSEEK])
+ REPLACE_PIPE2=0; AC_SUBST([REPLACE_PIPE2])
REPLACE_PREAD=0; AC_SUBST([REPLACE_PREAD])
REPLACE_PWRITE=0; AC_SUBST([REPLACE_PWRITE])
REPLACE_READ=0; AC_SUBST([REPLACE_READ])
REPLACE_READLINK=0; AC_SUBST([REPLACE_READLINK])
REPLACE_READLINKAT=0; AC_SUBST([REPLACE_READLINKAT])
REPLACE_RMDIR=0; AC_SUBST([REPLACE_RMDIR])
+ REPLACE_SETHOSTNAME=0; AC_SUBST([REPLACE_SETHOSTNAME])
REPLACE_SLEEP=0; AC_SUBST([REPLACE_SLEEP])
REPLACE_SYMLINK=0; AC_SUBST([REPLACE_SYMLINK])
REPLACE_SYMLINKAT=0; AC_SUBST([REPLACE_SYMLINKAT])
diff --git a/m4/utimens.m4 b/m4/utimens.m4
index 1de94a5a915..0f5bfd4c843 100644
--- a/m4/utimens.m4
+++ b/m4/utimens.m4
@@ -3,7 +3,7 @@ dnl This file is free software; the Free Software Foundation
dnl gives unlimited permission to copy and/or distribute it,
dnl with or without modifications, as long as this notice is preserved.
-dnl serial 11
+dnl serial 16
AC_DEFUN([gl_UTIMENS],
[
@@ -11,7 +11,11 @@ AC_DEFUN([gl_UTIMENS],
AC_REQUIRE([gl_FUNC_UTIMES])
AC_REQUIRE([gl_CHECK_TYPE_STRUCT_TIMESPEC])
AC_REQUIRE([AC_CANONICAL_HOST]) dnl for cross-compiles
- AC_CHECK_FUNCS_ONCE([futimes futimesat futimens utimensat lutimes])
+ gl_CHECK_FUNCS_ANDROID([futimes], [[#include <sys/time.h>]])
+ gl_CHECK_FUNCS_ANDROID([futimesat], [[#include <sys/time.h>]])
+ gl_CHECK_FUNCS_ANDROID([lutimes], [[#include <sys/time.h>]])
+ gl_CHECK_FUNCS_ANDROID([futimens], [[#include <sys/stat.h>]])
+ gl_CHECK_FUNCS_ANDROID([utimensat], [[#include <sys/stat.h>]])
if test $ac_cv_func_futimens = no && test $ac_cv_func_futimesat = yes; then
dnl FreeBSD 8.0-rc2 mishandles futimesat(fd,NULL,time). It is not
@@ -32,12 +36,13 @@ AC_DEFUN([gl_UTIMENS],
[gl_cv_func_futimesat_works=yes],
[gl_cv_func_futimesat_works=no],
[case "$host_os" in
- # Guess yes on Linux systems.
- linux-* | linux) gl_cv_func_futimesat_works="guessing yes" ;;
- # Guess yes on glibc systems.
- *-gnu*) gl_cv_func_futimesat_works="guessing yes" ;;
- # If we don't know, obey --enable-cross-guesses.
- *) gl_cv_func_futimesat_works="$gl_cross_guess_normal" ;;
+ # Guess yes on Linux systems
+ # and on systems that emulate the Linux system calls.
+ linux* | midipix*) gl_cv_func_futimesat_works="guessing yes" ;;
+ # Guess yes on glibc systems.
+ *-gnu*) gl_cv_func_futimesat_works="guessing yes" ;;
+ # If we don't know, obey --enable-cross-guesses.
+ *) gl_cv_func_futimesat_works="$gl_cross_guess_normal" ;;
esac
])
rm -f conftest.file])
diff --git a/m4/utimensat.m4 b/m4/utimensat.m4
index d1b6c080a24..4af7f6f81c8 100644
--- a/m4/utimensat.m4
+++ b/m4/utimensat.m4
@@ -1,4 +1,4 @@
-# serial 9
+# serial 12
# See if we need to provide utimensat replacement.
dnl Copyright (C) 2009-2024 Free Software Foundation, Inc.
@@ -13,9 +13,12 @@ AC_DEFUN([gl_FUNC_UTIMENSAT],
AC_REQUIRE([gl_SYS_STAT_H_DEFAULTS])
AC_REQUIRE([gl_USE_SYSTEM_EXTENSIONS])
AC_REQUIRE([AC_CANONICAL_HOST]) dnl for cross-compiles
- AC_CHECK_FUNCS_ONCE([utimensat])
+ gl_CHECK_FUNCS_ANDROID([utimensat], [[#include <sys/stat.h>]])
if test $ac_cv_func_utimensat = no; then
HAVE_UTIMENSAT=0
+ case "$gl_cv_onwards_func_utimensat" in
+ future*) REPLACE_UTIMENSAT=1 ;;
+ esac
else
AC_CACHE_CHECK([whether utimensat works],
[gl_cv_func_utimensat_works],
@@ -80,6 +83,9 @@ AC_DEFUN([gl_FUNC_UTIMENSAT],
# Guess yes on Linux or glibc systems.
linux-* | linux | *-gnu* | gnu*)
gl_cv_func_utimensat_works="guessing yes" ;;
+ # Guess yes on systems that emulate the Linux system calls.
+ midipix*)
+ gl_cv_func_utimensat_works="guessing yes" ;;
# Guess 'nearly' on AIX.
aix*)
gl_cv_func_utimensat_works="guessing nearly" ;;
diff --git a/m4/utimes.m4 b/m4/utimes.m4
index 040b1af8050..05b23cbb736 100644
--- a/m4/utimes.m4
+++ b/m4/utimes.m4
@@ -1,5 +1,5 @@
# Detect some bugs in glibc's implementation of utimes.
-# serial 8
+# serial 9
dnl Copyright (C) 2003-2005, 2009-2024 Free Software Foundation, Inc.
dnl This file is free software; the Free Software Foundation
@@ -144,11 +144,11 @@ main ()
[gl_cv_func_working_utimes=yes],
[gl_cv_func_working_utimes=no],
[case "$host_os" in
- # Guess yes on musl systems.
- *-musl*) gl_cv_func_working_utimes="guessing yes" ;;
- # Guess no on native Windows.
- mingw*) gl_cv_func_working_utimes="guessing no" ;;
- *) gl_cv_func_working_utimes="$gl_cross_guess_normal" ;;
+ # Guess yes on musl systems.
+ *-musl*) gl_cv_func_working_utimes="guessing yes" ;;
+ # Guess no on native Windows.
+ mingw* | windows*) gl_cv_func_working_utimes="guessing no" ;;
+ *) gl_cv_func_working_utimes="$gl_cross_guess_normal" ;;
esac
])
])
diff --git a/m4/warnings.m4 b/m4/warnings.m4
index 560ab6bf946..d487636aa36 100644
--- a/m4/warnings.m4
+++ b/m4/warnings.m4
@@ -1,4 +1,4 @@
-# warnings.m4 serial 16
+# warnings.m4 serial 20
dnl Copyright (C) 2008-2024 Free Software Foundation, Inc.
dnl This file is free software; the Free Software Foundation
dnl gives unlimited permission to copy and/or distribute it,
@@ -6,14 +6,7 @@ dnl with or without modifications, as long as this notice is preserved.
dnl From Simon Josefsson
-# gl_AS_VAR_APPEND(VAR, VALUE)
-# ----------------------------
-# Provide the functionality of AS_VAR_APPEND if Autoconf does not have it.
-m4_ifdef([AS_VAR_APPEND],
-[m4_copy([AS_VAR_APPEND], [gl_AS_VAR_APPEND])],
-[m4_define([gl_AS_VAR_APPEND],
-[AS_VAR_SET([$1], [AS_VAR_GET([$1])$2])])])
-
+AC_PREREQ([2.64])
# gl_COMPILER_OPTION_IF(OPTION, [IF-SUPPORTED], [IF-NOT-SUPPORTED],
# [PROGRAM = AC_LANG_PROGRAM()])
@@ -33,13 +26,13 @@ case $gl_positive in
esac
m4_pushdef([gl_Positive], [$gl_positive])])dnl
AC_CACHE_CHECK([whether _AC_LANG compiler handles $1], [gl_Warn], [
- gl_save_compiler_FLAGS="$gl_Flags"
- gl_AS_VAR_APPEND(m4_defn([gl_Flags]),
+ gl_saved_compiler_FLAGS="$gl_Flags"
+ AS_VAR_APPEND(m4_defn([gl_Flags]),
[" $gl_unknown_warnings_are_errors ]m4_defn([gl_Positive])["])
AC_LINK_IFELSE([m4_default([$4], [AC_LANG_PROGRAM([[]])])],
[AS_VAR_SET([gl_Warn], [yes])],
[AS_VAR_SET([gl_Warn], [no])])
- gl_Flags="$gl_save_compiler_FLAGS"
+ gl_Flags="$gl_saved_compiler_FLAGS"
])
AS_VAR_IF(gl_Warn, [yes], [$2], [$3])
m4_popdef([gl_Positive])dnl
@@ -88,16 +81,18 @@ AC_DEFUN([gl_UNKNOWN_WARNINGS_ARE_ERRORS_IMPL],
# gl_WARN_ADD(OPTION, [VARIABLE = WARN_CFLAGS/WARN_CXXFLAGS],
# [PROGRAM = AC_LANG_PROGRAM()])
# -----------------------------------------------------------
-# Adds parameter to WARN_CFLAGS/WARN_CXXFLAGS if the compiler supports it
-# when compiling PROGRAM. For example, gl_WARN_ADD([-Wparentheses]).
+# Adds OPTION to VARIABLE (which defaults to WARN_CFLAGS or WARN_CXXFLAGS)
+# if the compiler supports it when compiling PROGRAM.
#
# If VARIABLE is a variable name, AC_SUBST it.
#
# The effects of this macro depend on the current language (_AC_LANG).
+#
+# Example: gl_WARN_ADD([-Wparentheses]).
AC_DEFUN([gl_WARN_ADD],
[AC_REQUIRE([gl_UNKNOWN_WARNINGS_ARE_ERRORS(]_AC_LANG[)])
gl_COMPILER_OPTION_IF([$1],
- [gl_AS_VAR_APPEND(m4_if([$2], [], [[WARN_]_AC_LANG_PREFIX[FLAGS]], [[$2]]), [" $1"])],
+ [AS_VAR_APPEND(m4_if([$2], [], [[WARN_]_AC_LANG_PREFIX[FLAGS]], [[$2]]), [" $1"])],
[],
[$3])
m4_ifval([$2],
@@ -105,6 +100,77 @@ m4_ifval([$2],
[AC_SUBST([WARN_]_AC_LANG_PREFIX[FLAGS])])dnl
])
+
+# gl_CC_INHIBIT_WARNINGS
+# sets and substitutes a variable GL_CFLAG_INHIBIT_WARNINGS, to a $(CC) option
+# that reverts all preceding -W* options, if available.
+# This is expected to be '-w' at least on gcc, clang, AIX xlc, xlclang, Sun cc,
+# "compile cl" (MSVC), "compile clang-cl" (MSVC-compatible clang). Or it can be
+# empty.
+AC_DEFUN([gl_CC_INHIBIT_WARNINGS],
+[
+ AC_REQUIRE([AC_PROG_CC])
+ AC_CACHE_CHECK([for C compiler option to inhibit all warnings],
+ [gl_cv_cc_winhibit],
+ [rm -f conftest*
+ echo 'int dummy;' > conftest.c
+ AC_TRY_COMMAND([${CC-cc} $CFLAGS $CPPFLAGS -c conftest.c 2>conftest1.err]) >/dev/null
+ AC_TRY_COMMAND([${CC-cc} $CFLAGS $CPPFLAGS -w -c conftest.c 2>conftest2.err]) >/dev/null
+ if test $? = 0 && test `wc -l < conftest1.err` = `wc -l < conftest2.err`; then
+ gl_cv_cc_winhibit='-w'
+ else
+ gl_cv_cc_winhibit=none
+ fi
+ rm -f conftest*
+ ])
+ case "$gl_cv_cc_winhibit" in
+ none) GL_CFLAG_INHIBIT_WARNINGS='' ;;
+ *)
+ GL_CFLAG_INHIBIT_WARNINGS="$gl_cv_cc_winhibit"
+ dnl If all warnings are inhibited, there's no point in having the GCC
+ dnl analyzer enabled. This saves RAM requirements and CPU consumption.
+ gl_WARN_ADD([-fno-analyzer], [GL_CFLAG_INHIBIT_WARNINGS])
+ ;;
+ esac
+ AC_SUBST([GL_CFLAG_INHIBIT_WARNINGS])
+])
+
+# gl_CXX_INHIBIT_WARNINGS
+# sets and substitutes a variable GL_CXXFLAG_INHIBIT_WARNINGS, to a $(CC) option
+# that reverts all preceding -W* options, if available.
+AC_DEFUN([gl_CXX_INHIBIT_WARNINGS],
+[
+ dnl Requires AC_PROG_CXX or gl_PROG_ANSI_CXX.
+ if test -n "$CXX" && test "$CXX" != no; then
+ AC_CACHE_CHECK([for C++ compiler option to inhibit all warnings],
+ [gl_cv_cxx_winhibit],
+ [rm -f conftest*
+ echo 'int dummy;' > conftest.cc
+ AC_TRY_COMMAND([${CXX-c++} $CXXFLAGS $CPPFLAGS -c conftest.cc 2>conftest1.err]) >/dev/null
+ AC_TRY_COMMAND([${CXX-c++} $CXXFLAGS $CPPFLAGS -w -c conftest.cc 2>conftest2.err]) >/dev/null
+ if test $? = 0 && test `wc -l < conftest1.err` = `wc -l < conftest2.err`; then
+ gl_cv_cxx_winhibit='-w'
+ else
+ gl_cv_cxx_winhibit=none
+ fi
+ rm -f conftest*
+ ])
+ case "$gl_cv_cxx_winhibit" in
+ none) GL_CXXFLAG_INHIBIT_WARNINGS='' ;;
+ *)
+ GL_CXXFLAG_INHIBIT_WARNINGS="$gl_cv_cxx_winhibit"
+ dnl If all warnings are inhibited, there's no point in having the GCC
+ dnl analyzer enabled. This saves RAM requirements and CPU consumption.
+ gl_WARN_ADD([-fno-analyzer], [GL_CXXFLAG_INHIBIT_WARNINGS])
+ ;;
+ esac
+ else
+ GL_CXXFLAG_INHIBIT_WARNINGS=''
+ fi
+ AC_SUBST([GL_CXXFLAG_INHIBIT_WARNINGS])
+])
+
+
# Local Variables:
# mode: autoconf
# End:
diff --git a/m4/xattr.m4 b/m4/xattr.m4
new file mode 100644
index 00000000000..7f72a81eeab
--- /dev/null
+++ b/m4/xattr.m4
@@ -0,0 +1,53 @@
+# xattr.m4 - check for Extended Attributes (Linux)
+# serial 7
+
+# Copyright (C) 2003-2024 Free Software Foundation, Inc.
+# This file is free software; the Free Software Foundation
+# gives unlimited permission to copy and/or distribute it,
+# with or without modifications, as long as this notice is preserved.
+
+AC_DEFUN([gl_FUNC_XATTR],
+[
+ AC_ARG_ENABLE([xattr],
+ AS_HELP_STRING([[--disable-xattr]],
+ [do not support extended attributes]),
+ [use_xattr=$enableval], [use_xattr=yes])
+
+ LIB_XATTR=
+ AC_SUBST([LIB_XATTR])
+
+ if test "$use_xattr" = yes; then
+ AC_CACHE_CHECK([for xattr library with ATTR_ACTION_PERMISSIONS],
+ [gl_cv_xattr_lib],
+ [gl_cv_xattr_lib=no
+ AC_LANG_CONFTEST(
+ [AC_LANG_PROGRAM(
+ [[#include <attr/error_context.h>
+ #include <attr/libattr.h>
+ static int
+ is_attr_permissions (const char *name, struct error_context *ctx)
+ {
+ return attr_copy_action (name, ctx) == ATTR_ACTION_PERMISSIONS;
+ }
+ ]],
+ [[return attr_copy_fd ("/", 0, "/", 0, is_attr_permissions, 0);
+ ]])])
+ AC_LINK_IFELSE([],
+ [gl_cv_xattr_lib='none required'],
+ [xattr_saved_LIBS=$LIBS
+ LIBS="-lattr $LIBS"
+ AC_LINK_IFELSE([], [gl_cv_xattr_lib=-lattr])
+ LIBS=$xattr_saved_LIBS])])
+ if test "$gl_cv_xattr_lib" = no; then
+ AC_MSG_WARN([libattr development library was not found or not usable.])
+ AC_MSG_WARN([AC_PACKAGE_NAME will be built without xattr support.])
+ use_xattr=no
+ elif test "$gl_cv_xattr_lib" != 'none required'; then
+ LIB_XATTR=$gl_cv_xattr_lib
+ fi
+ fi
+ if test "$use_xattr" = yes; then
+ AC_DEFINE([USE_XATTR], [1],
+ [Define to 1 to use the Linux extended attributes library.])
+ fi
+])
diff --git a/make-dist b/make-dist
index 71dd2576afc..c8b0fcf4f24 100755
--- a/make-dist
+++ b/make-dist
@@ -357,6 +357,9 @@ possibly_non_vc_files="
MANIFEST aclocal.m4 configure
admin/charsets/jisx2131-filter
src/config.in
+ exec/configure exec/config.h.in
+ exec/config.sub exec/config.guess
+ exec/install-sh
leim/small-ja-dic-option
"$(
find admin doc etc lisp \
diff --git a/msdos/autogen/Makefile.in b/msdos/autogen/Makefile.in
index b9d255bc0f6..18403250875 100644
--- a/msdos/autogen/Makefile.in
+++ b/msdos/autogen/Makefile.in
@@ -921,13 +921,11 @@ LIBXT_OTHER = @LIBXT_OTHER@
LIBX_OTHER = @LIBX_OTHER@
LIBZ = @LIBZ@
LIB_ACL = @LIB_ACL@
-LIB_CLOCK_GETTIME = @LIB_CLOCK_GETTIME@
-LIB_EACCESS = @LIB_EACCESS@
+CLOCK_TIME_LIB = @CLOCK_TIME_LIB@
+EUIDACCESS_LIBGEN = @EUIDACCESS_LIBGEN@
LIB_EXECINFO = @LIB_EXECINFO@
-LIB_FDATASYNC = @LIB_FDATASYNC@
LIB_MATH = @LIB_MATH@
LIB_PTHREAD = @LIB_PTHREAD@
-LIB_PTHREAD_SIGMASK = @LIB_PTHREAD_SIGMASK@
LIB_TIMER_TIME = @LIB_TIMER_TIME@
LIB_WSOCK32 = @LIB_WSOCK32@
LN_S_FILEONLY = @LN_S_FILEONLY@
diff --git a/msdos/sed1v2.inp b/msdos/sed1v2.inp
index e6ce38f4e3a..632c45a16b6 100644
--- a/msdos/sed1v2.inp
+++ b/msdos/sed1v2.inp
@@ -48,15 +48,17 @@ s/\.h\.in/.h-in/
/^LIB_MATH *=/s/@LIB_MATH@/-lm/
/^LIB_PTHREAD *=/s/@LIB_PTHREAD@//
/^LIB_ACL *=/s/@LIB_ACL@//
-/^LIB_EACCESS *=/s/@LIB_EACCESS@//
-/^LIB_FDATASYNC *=/s/@LIB_FDATASYNC@//
-/^LIB_NANOSLEEP *=/s/@LIB_NANOSLEEP@//
+/^EUIDACCESS_LIBGEN *=/s/@EUIDACCESS_LIBGEN@//
+/^NANOSLEEP_LIB *=/s/@NANOSLEEP_LIB@//
s/ *@LIBTIFF@//
s/ *@LIBJPEG@//
s/ *@LIBPNG@//
s/ *@LIBGIF@//
s/ *@LIBXPM@//
s/ *@WEBP_LIBS@//
+/^GIF_CFLAGS *=/s/@GIF_CFLAGS@//
+/^JPEG_CFLAGS *=/s/@JPEG_CFLAGS@//
+/^TIFF_CFLAGS *=/s/@TIFF_CFLAGS@//
/^HAVE_NATIVE_COMP *=/s/@HAVE_NATIVE_COMP@/no/
/^HAVE_PDUMPER *=/s/@HAVE_PDUMPER@/no/
/^HAVE_BE_APP *=/s/@HAVE_BE_APP@/no/
@@ -140,7 +142,7 @@ s/ *@WEBP_LIBS@//
/^LIBSELINUX_LIBS *=/s/@LIBSELINUX_LIBS@//
/^LIBSYSTEMD_LIBS *=/s/@LIBSYSTEMD_LIBS@//
/^LIBSYSTEMD_CFLAGS *=/s/@LIBSYSTEMD_CFLAGS@//
-/^LIB_CLOCK_GETTIME *=/s/@[^@\n]*@//g
+/^CLOCK_TIME_LIB *=/s/@[^@\n]*@//g
/^LIB_TIMER_TIME *=/s/@[^@\n]*@//g
/^LIB_EXECINFO *=/s/@[^@\n]*@//g
/^LIBGNUTLS_LIBS *=/s/@[^@\n]*@//
@@ -183,6 +185,8 @@ s/ *@WEBP_LIBS@//
/^TREE_SITTER_CFLAGS *=/s/@TREE_SITTER_CFLAGS@//
/^HARFBUZZ_CFLAGS *=/s/@HARFBUZZ_CFLAGS@//
/^HARFBUZZ_LIBS *=/s/@HARFBUZZ_LIBS@//
+/^QCOPY_ACL_LIB *=/s/@QCOPY_ACL_LIB@//
+/^TIMER_TIME_LIB *=/s/@TIMER_TIME_LIB@//
/^LCMS2_CFLAGS *=/s/@LCMS2_CFLAGS@//
/^LCMS2_LIBS *=/s/@LCMS2_LIBS@//
/^LIBGMP *=/s/@LIBGMP@//
@@ -200,8 +204,20 @@ s/ *@WEBP_LIBS@//
/^PAXCTL_dumped *=/s/=.*$/=/
/^PAXCTL_notdumped *=/s/=.*$/=/
/^DUMPING *=/s/@DUMPING@/unexec/
+/^ANDROID_OBJ *=/s/@ANDROID_OBJ@//
+/^ANDROID_LIBS *=/s/@ANDROID_LIBS@//
+/^ANDROID_LDFLAGS *=/s/@ANDROID_LDFLAGS@//
+/^ANDROID_BUILD_CFLAGS *=/s/@ANDROID_BUILD_CFLAGS@//
+/^LIBGMP_CFLAGS *=/s/@LIBGMP_CFLAGS@//
+/^SQLITE3_CFLAGS *=/s/@SQLITE3_CFLAGS@//
+/^LIBSELINUX_CFLAGS *=/s/@LIBSELINUX_CFLAGS@//
+/^XCONFIGURE *=/s/@XCONFIGURE@//
/^[ \t]*MAKE_PDUMPER_FINGERPRINT = *$/c\
MAKE_PDUMPER_FINGERPRINT =
+# While this variable is named abs_top_builddir, the distinction is
+# only relevant when Emacs is undergoing cross-compilation.
+/^abs_top_builddir =*/s/@abs_top_builddir@/../
+s/\$(abs_top_builddir)\/src\/lisp.mk/lisp.mk/
/^lisp\.mk:/,/^$/c\
lisp.mk: $(lispsource)/loadup.el\
@rm -f $@\
@@ -283,3 +299,4 @@ s| -I\. -I\$(srcdir)| -I.|
/^ *test "X/d
/\$(CC) -o \$@.tmp/s/\$@.tmp/\$@/
/mv \$@.tmp \$@/d
+/^top_builddir =*/s/@top_builddir@/../
diff --git a/msdos/sed2v2.inp b/msdos/sed2v2.inp
index 34b382df8fe..9f8bca1a987 100644
--- a/msdos/sed2v2.inp
+++ b/msdos/sed2v2.inp
@@ -67,7 +67,7 @@
/^#undef PACKAGE_NAME/s/^.*$/#define PACKAGE_NAME ""/
/^#undef PACKAGE_STRING/s/^.*$/#define PACKAGE_STRING ""/
/^#undef PACKAGE_TARNAME/s/^.*$/#define PACKAGE_TARNAME ""/
-/^#undef PACKAGE_VERSION/s/^.*$/#define PACKAGE_VERSION "29.3.50"/
+/^#undef PACKAGE_VERSION/s/^.*$/#define PACKAGE_VERSION "30.0.50"/
/^#undef SYSTEM_TYPE/s/^.*$/#define SYSTEM_TYPE "ms-dos"/
/^#undef HAVE_DECL_GETENV/s/^.*$/#define HAVE_DECL_GETENV 1/
/^#undef SYS_SIGLIST_DECLARED/s/^.*$/#define SYS_SIGLIST_DECLARED 1/
diff --git a/msdos/sed3v2.inp b/msdos/sed3v2.inp
index 166f4385588..9982a5e638f 100644
--- a/msdos/sed3v2.inp
+++ b/msdos/sed3v2.inp
@@ -32,9 +32,9 @@
/^LIBRESOLV *=/s/@[^@\n]*@//g
/^LIBS_MAIL *=/s/@[^@\n]*@//g
/^LIBS_SYSTEM *=/s/@[^@\n]*@//g
-/^LIB_CLOCK_GETTIME *=/s/@[^@\n]*@//g
+/^CLOCK_TIME_LIB *=/s/@[^@\n]*@//g
/^LIB_TIMER_TIME *=/s/@[^@\n]*@//g
-/^LIB_GETRANDOM *=/s/@[^@\n]*@//g
+/^GETRANDOM_LIB *=/s/@[^@\n]*@//g
/^CFLAGS *=/s!=.*$!=-O2 -g!
/^CPPFLAGS *=/s/@CPPFLAGS@//
/^LDFLAGS *=/s/@LDFLAGS@//
@@ -49,7 +49,6 @@
/^ALLOCA *=/s!@ALLOCA@!!
/^EXEEXT *=/s!@EXEEXT@!.exe!
/^CLIENTW *=/s/@CLIENTW@//
-/^LIB_FDATASYNC *=/s/@LIB_FDATASYNC@//
/^LIB_WSOCK32 *=/s/@LIB_WSOCK32@//
/^LIBS_ECLIENT *=/s/@LIBS_ECLIENT@//
/^NTLIB *=/s/@NTLIB@//
@@ -58,3 +57,4 @@
/^GETOPT_H *=/s!@GETOPT_H@!getopt.h!
/^GETOPTOBJS *=/s!@GETOPTOBJS@!getopt.o getopt1.o!
/^INSTALLABLES/s/emacsclient[^ ]* *//
+/^XCONFIGURE *=/s/@XCONFIGURE@//
diff --git a/msdos/sedleim.inp b/msdos/sedleim.inp
index f644e9ce965..d43fbef4672 100644
--- a/msdos/sedleim.inp
+++ b/msdos/sedleim.inp
@@ -41,3 +41,7 @@ RUN_EMACS = ${EMACS} -batch --no-site-file --no-site-lisp
/^MKDIR_P *=/s,@MKDIR_P@,gmkdir -p,
/^\${leimdir}\/quail \${leimdir}\/ja-dic: *$/s|\${leimdir}/|$(rel_leimdir)\\|
+
+# Should an option to enable this be provided by config.bat?
+/^SMALL_JA_DIC *=/s/@SMALL_JA_DIC@//
+/^small-ja-dic-option: /s|../config.status||
diff --git a/msdos/sedlibcf.inp b/msdos/sedlibcf.inp
index 3bce8a45eb2..8f7aa33f823 100644
--- a/msdos/sedlibcf.inp
+++ b/msdos/sedlibcf.inp
@@ -20,3 +20,4 @@
# ----------------------------------------------------------------------
s/c++defs/cxxdefs/g
s/\([a-zA-Z0-9_]*\)\.in\.h/\1.in-h/g
+/^XCONFIGURE *=/s/@XCONFIGURE@//
diff --git a/msdos/sedlibmk.inp b/msdos/sedlibmk.inp
index 16562e477bb..1d8ae778168 100644
--- a/msdos/sedlibmk.inp
+++ b/msdos/sedlibmk.inp
@@ -156,6 +156,7 @@ s/@PACKAGE@/emacs/
/^HYBRID_MALLOC *=/s/@HYBRID_MALLOC@//
/^WARN_CFLAGS *=/s/@WARN_CFLAGS@//
/^WERROR_CFLAGS *=/s/@WERROR_CFLAGS@//
+/^ANDROID_BUILD_CFLAGS *=/s/@ANDROID_BUILD_CFLAGS@//
/^DEFS *=/s/@[^@\n]*@//
/^DEPDIR *=/s/@[^@\n]*@/deps/
/^ECHO_N *=/s/@[^@\n]*@/-n/
@@ -199,6 +200,9 @@ s/@PACKAGE@/emacs/
/^GL_GNULIB_[^ =]* *= *@/s/@[^@\n]*@/0/
/^GL_GSETTINGS_CFLAGS *=/s/@[^@\n]*@//
/^GL_GSETTINGS_LIBS *=/s/@[^@\n]*@//
+# Miscellaneous variables.
+/^DIR_HAS_FD_MEMBER *=/s/@DIR_HAS_FD_MEMBER@/0/
+/^LOCALE_FR_UTF8 *=/s/@LOCALE_FR_UTF8@/none/
#
# Edit the HAVE_foo variables
/^HAVE_ATOLL *=/s/@HAVE_ATOLL@/0/
@@ -270,7 +274,6 @@ s/@PACKAGE@/emacs/
/^LDFLAGS *=/s/@[^@\n]*@//
/^LD_FIRSTFLAG *=/s/@[^@\n]*@//
/^LIB_PTHREAD *=/s/@[^@\n]*@//
-/^LIB_PTHREAD_SIGMASK *=/s/@[^@\n]*@//
/^LIBS *=/s/@[^@\n]*@//
/^MAKEINFO *=/s/@MAKEINFO@/makeinfo/
# MKDIR_P lines are edited further below
@@ -300,8 +303,10 @@ s/@PACKAGE@/emacs/
/^NEXT_DIRENT_H *=/s/@[^@\n]*@/<dirent.h>/
/^NEXT_ERRNO_H *=/s/@[^@\n]*@//
/^NEXT_FCNTL_H *=/s/@[^@\n]*@/<fcntl.h>/
+/^NEXT_FLOAT_H *=/s/@[^@\n]*@//
/^NEXT_GETOPT_H *=/s/@[^@\n]*@/<getopt.h>/
/^NEXT_LIMITS_H *=/s/@[^@\n]*@/<limits.h>/
+/^NEXT_MATH_H *=/s/@[^@\n]*@//
/^NEXT_SIGNAL_H *=/s/@[^@\n]*@/<signal.h>/
/^NEXT_STDDEF_H *=/s/@[^@\n]*@/<stddef.h>/
/^NEXT_STDIO_H *=/s/@[^@\n]*@/<stdio.h>/
@@ -310,9 +315,11 @@ s/@PACKAGE@/emacs/
/^NEXT_STRING_H *=/s/@[^@\n]*@/<string.h>/
/^NEXT_SYS_SELECT_H *=/s/@[^@\n]*@//
/^NEXT_SYS_STAT_H *=/s!@[^@\n]*@!<sys/stat.h>!
+/^NEXT_SYS_RANDOM_H *=/s/@[^@\n]*@//
/^NEXT_SYS_TIME_H *=/s/@[^@\n]*@//
/^NEXT_SYS_TYPES_H *=/s!@[^@\n]*@!<sys/types.h>!
/^NEXT_TIME_H *=/s/@[^@\n]*@/<time.h>/
+/^NEXT_INTTYPES_H *=/s/@[^@\n]*@//
/^NEXT_UNISTD_H *=/s/@[^@\n]*@/<unistd.h>/
/^OBJEXT *=/s/@[^@\n]*@/o/
/^PRAGMA_COLUMNS *=/s/@[^@\n]*@//
@@ -323,7 +330,7 @@ s/@PACKAGE@/emacs/
/^REPLACE_MKTIME *=/s/@[^@\n]*@/1/
# We don't want any other gnulib replacement functions
/^REPLACE_[^ =]* *= *@/s/@[^@\n]*@/0/
-/^LIB_GETRANDOM[^ =]* *= *@/s/@[^@\n]*@//
+/^GETRANDOM_LIB[^ =]* *= *@/s/@[^@\n]*@//
/^SIG_ATOMIC_T_SUFFIX *=/s/@SIG_ATOMIC_T_SUFFIX@//
/^SIZE_T_SUFFIX *=/s/@SIZE_T_SUFFIX@/u/
/^ASSERT_H *=/s/@[^@\n]*@/assert.h/
@@ -332,6 +339,7 @@ s/@PACKAGE@/emacs/
/^DIRENT_H *=/s/@[^@\n]*@//
/^ERRNO_H *=/s/@[^@\n]*@//
/^EXECINFO_H *=/s/@[^@\n]*@/execinfo.h/
+/^FLOAT_H *=/s/@[^@\n]*@//
/^GETOPT_CDEFS_H *=/s/@[^@\n]*@/getopt-cdefs.h/
/^GMP_H *=/s/@[^@\n]*@/gmp.h/
/^LIMITS_H *=/s/@[^@\n]*@/limits.h/
@@ -428,13 +436,16 @@ s/= @GL_GENERATE_STDDEF_H_CONDITION@/= 1/
s/= @GL_GENERATE_STDINT_H_CONDITION@/= 1/
s/= @GL_GENERATE_LIMITS_H_CONDITION@/= 1/
s/= @GL_GENERATE_ERRNO_H_CONDITION@/= /
-s/= @GL_GENERATE_LIMITS_H_CONDITION@/= /
+s/= @GL_GENERATE_GETOPT_CDEFS_H_CONDITION@/= 1/
+s/= @GL_GENERATE_GETOPT_H_CONDITION@/= 1/
s/= @GL_GENERATE_GMP_H_CONDITION@/= 1/
s/= @GL_GENERATE_GMP_GMP_H_CONDITION@/= /
s/= @GL_GENERATE_MINI_GMP_H_CONDITION@/= 1/
s/= @GL_GENERATE_STDCKDINT_H_CONDITION@/= 1/
s/= @GL_COND_OBJ_STDIO_READ_CONDITION@/= /
s/= @GL_COND_OBJ_STDIO_WRITE_CONDITION@/= /
+s/= @GL_COND_OBJ_STPNCPY_CONDITION@/= /
+s/= @GL_COND_OBJ_.*@/= 1/
s/\$\(MKDIR_P\) malloc//
#
# Determine which modules to build and which to omit
@@ -454,6 +465,8 @@ OMIT_GNULIB_MODULE_fcntl = true\
OMIT_GNULIB_MODULE_fdopendir = true\
OMIT_GNULIB_MODULE_fstatat = true\
OMIT_GNULIB_MODULE_fsync = true\
+OMIT_GNULIB_MODULE_getline = true\
+OMIT_GNULIB_MODULE_getdelim = true\
OMIT_GNULIB_MODULE_getdtablesize = true\
OMIT_GNULIB_MODULE_getgroups = true\
OMIT_GNULIB_MODULE_gettimeofday = true\
@@ -461,6 +474,7 @@ OMIT_GNULIB_MODULE_group-member = true\
OMIT_GNULIB_MODULE_inttypes-incomplete = true\
OMIT_GNULIB_MODULE_localtime-buffer = true\
OMIT_GNULIB_MODULE_lstat = true\
+OMIT_GNULIB_MODULE_math = true\
OMIT_GNULIB_MODULE_nanosleep = true\
OMIT_GNULIB_MODULE_open = true\
OMIT_GNULIB_MODULE_pipe2 = true\
@@ -469,11 +483,13 @@ OMIT_GNULIB_MODULE_putenv = true\
OMIT_GNULIB_MODULE_qcopy-acl = true\
OMIT_GNULIB_MODULE_readlink = true\
OMIT_GNULIB_MODULE_readlinkat = true\
+OMIT_GNULIB_MODULE_stpcpy = true\
OMIT_GNULIB_MODULE_strtoimax = true\
OMIT_GNULIB_MODULE_strtoll = true\
OMIT_GNULIB_MODULE_symlink = true\
OMIT_GNULIB_MODULE_sys_select = true\
OMIT_GNULIB_MODULE_sys_time = true\
+OMIT_GNULIB_MODULE_boot-time = true\
OMIT_GNULIB_MODULE_crypto\/md5 = true
/^arg-nonnull\.h:/,/^[ ][ ]*mv /c\
arg-nonnull.h: $(top_srcdir)/build-aux/snippet/arg-nonnull.h\
diff --git a/nextstep/Makefile.in b/nextstep/Makefile.in
index 02183be87d0..5811bf87342 100644
--- a/nextstep/Makefile.in
+++ b/nextstep/Makefile.in
@@ -46,11 +46,7 @@ ns_check_file = @ns_appdir@/@ns_check_file@
.PHONY: all
-ifeq ($(DUMPING),pdumper)
-ns_pdmp_target = ${ns_applibexecdir}/Emacs.pdmp
-endif
-
-all: ${ns_appdir} ${ns_appbindir}/Emacs ${ns_pdmp_target}
+all: ${ns_appdir} ${ns_appbindir}/Emacs
${ns_check_file}: ${ns_appdir}
@@ -71,12 +67,6 @@ ${ns_appbindir}/Emacs: ${ns_appdir} ${ns_check_file} ../src/emacs${EXEEXT}
${MKDIR_P} ${ns_appbindir}
cp -f ../src/emacs${EXEEXT} $@
-# FIXME: Don't install the dump file into the app bundle when
-# self-contained install is disabled.
-${ns_applibexecdir}/Emacs.pdmp: ${ns_appdir} ${ns_check_file} ../src/emacs${EXEEXT}.pdmp
- ${MKDIR_P} ${ns_applibexecdir}
- cp -f ../src/emacs${EXEEXT}.pdmp $@
-
.PHONY: FORCE
../src/emacs${EXEEXT}: FORCE
diff --git a/nt/INSTALL.W64 b/nt/INSTALL.W64
index 127699fb21b..2aa05ea0062 100644
--- a/nt/INSTALL.W64
+++ b/nt/INSTALL.W64
@@ -115,7 +115,7 @@ put the Emacs source into C:\emacs\emacs-master:
mkdir /c/emacs
cd /c/emacs
- git clone git://git.sv.gnu.org/emacs.git emacs-master
+ git clone https://git.savannah.gnu.org/git/emacs.git emacs-master
This will produce the development sources, i.e. the master branch of
the Emacs Git repository, in the directory C:\emacs\emacs-master.
diff --git a/nt/README.W32 b/nt/README.W32
index a1838f66988..98657246f67 100644
--- a/nt/README.W32
+++ b/nt/README.W32
@@ -1,7 +1,7 @@
Copyright (C) 2001-2024 Free Software Foundation, Inc.
See the end of the file for license conditions.
- Emacs version 29.3.50 for MS-Windows
+ Emacs version 30.0.50 for MS-Windows
This README file describes how to set up and run a precompiled
distribution of the latest version of GNU Emacs for MS-Windows. You
diff --git a/nt/cmdproxy.c b/nt/cmdproxy.c
index 0500b653bb2..c012151cf96 100644
--- a/nt/cmdproxy.c
+++ b/nt/cmdproxy.c
@@ -38,6 +38,14 @@ along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. */
#include <string.h> /* strlen */
#include <ctype.h> /* isspace, isalpha */
+/* UCRT has a C99-compatible snprintf, and _snprintf is defined inline
+ in stdio.h, which we don't want to include here. Since the
+ differences in behavior between snprintf and _snprintf don't matter
+ in this file, we take the easy way out. */
+#ifdef _UCRT
+# define _snprintf snprintf
+#endif
+
/* We don't want to include stdio.h because we are already duplicating
lots of it here */
extern int _snprintf (char *buffer, size_t count, const char *format, ...);
diff --git a/nt/ftime-nostartup.bat b/nt/ftime-nostartup.bat
deleted file mode 100755
index f9e93b7f967..00000000000
--- a/nt/ftime-nostartup.bat
+++ /dev/null
@@ -1,24 +0,0 @@
-@echo off
-if (%1)==() echo Usage: %0 tracefile
-if (%1)==() goto done
-rem Need to fiddle with the dumped image so prep doesn't break it
-obj\i386\preprep ..\src\obj\i386\emacs.exe ..\src\obj\i386\pemacs.exe
-copy ..\src\obj\i386\temacs.map ..\src\obj\i386\pemacs.map
-rem -----------------------------------------------------------------
-rem Use this version to profile explicit commands only.
-rem prep /om /ft /sf _Fexecute_extended_command ..\src\obj\i386\pemacs
-rem -----------------------------------------------------------------
-rem Use this version to ignore startup code
-prep /om /ft /sf _command_loop_1 ..\src\obj\i386\pemacs
-rem -----------------------------------------------------------------
-rem Use this version to include startup code
-rem prep /om /ft ..\src\obj\i386\pemacs
-rem -----------------------------------------------------------------
-if errorlevel 1 goto done
-profile ..\src\obj\i386\pemacs %2 %3 %4 %5 %6 %7 %8 %9
-if errorlevel 1 goto done
-prep /m ..\src\obj\i386\pemacs
-if errorlevel 1 goto done
-plist ..\src\obj\i386\pemacs > %1
-:done
-
diff --git a/nt/ftime.bat b/nt/ftime.bat
deleted file mode 100644
index b7cdf968c1e..00000000000
--- a/nt/ftime.bat
+++ /dev/null
@@ -1,24 +0,0 @@
-@echo off
-if (%1)==() echo Usage: %0 tracefile
-if (%1)==() goto done
-rem Need to fiddle with the dumped image so prep doesn't break it
-obj\i386\preprep ..\src\obj\i386\emacs.exe ..\src\obj\i386\pemacs.exe
-copy ..\src\obj\i386\temacs.map ..\src\obj\i386\pemacs.map
-rem -----------------------------------------------------------------
-rem Use this version to profile explicit commands only.
-prep /om /ft /sf _Fexecute_extended_command ..\src\obj\i386\pemacs
-rem -----------------------------------------------------------------
-rem Use this version to ignore startup code
-rem prep /om /ft /sf _command_loop_1 ..\src\obj\i386\pemacs
-rem -----------------------------------------------------------------
-rem Use this version to include startup code
-rem prep /om /ft ..\src\obj\i386\pemacs
-rem -----------------------------------------------------------------
-if errorlevel 1 goto done
-profile ..\src\obj\i386\pemacs %2 %3 %4 %5 %6 %7 %8 %9
-if errorlevel 1 goto done
-prep /m ..\src\obj\i386\pemacs
-if errorlevel 1 goto done
-plist ..\src\obj\i386\pemacs > %1
-:done
-
diff --git a/nt/gnulib-cfg.mk b/nt/gnulib-cfg.mk
index 7f25a7bd7cb..048f812724a 100644
--- a/nt/gnulib-cfg.mk
+++ b/nt/gnulib-cfg.mk
@@ -44,34 +44,44 @@
OMIT_GNULIB_MODULE_acl-permissions = true
OMIT_GNULIB_MODULE_allocator = true
OMIT_GNULIB_MODULE_at-internal = true
+OMIT_GNULIB_MODULE_canonicalize-lgpl = true
OMIT_GNULIB_MODULE_careadlinkat = true
+OMIT_GNULIB_MODULE_copy-file-range = true
OMIT_GNULIB_MODULE_dirent = true
OMIT_GNULIB_MODULE_dirfd = true
+OMIT_GNULIB_MODULE_fchmodat = true
OMIT_GNULIB_MODULE_fcntl = true
OMIT_GNULIB_MODULE_fcntl-h = true
+OMIT_GNULIB_MODULE_file-has-acl = true
+OMIT_GNULIB_MODULE_float = true
+OMIT_GNULIB_MODULE_fpucw = true
OMIT_GNULIB_MODULE_free-posix = true
+OMIT_GNULIB_MODULE_fseterr = true
OMIT_GNULIB_MODULE_fsusage = true
+OMIT_GNULIB_MODULE_futimens = true
+OMIT_GNULIB_MODULE_getdelim = true
+OMIT_GNULIB_MODULE_getline = true
OMIT_GNULIB_MODULE_inttypes-incomplete = true
+OMIT_GNULIB_MODULE_lchmod = true
OMIT_GNULIB_MODULE_malloc-posix = true
+OMIT_GNULIB_MODULE_nanosleep = true
+OMIT_GNULIB_MODULE_nproc = true
OMIT_GNULIB_MODULE_open = true
OMIT_GNULIB_MODULE_pipe2 = true
OMIT_GNULIB_MODULE_realloc-gnu = true
OMIT_GNULIB_MODULE_realloc-posix = true
OMIT_GNULIB_MODULE_secure_getenv = true
OMIT_GNULIB_MODULE_signal-h = true
+OMIT_GNULIB_MODULE_signbit = true
+OMIT_GNULIB_MODULE_size_max = true
OMIT_GNULIB_MODULE_stdio = true
OMIT_GNULIB_MODULE_stdlib = true
+OMIT_GNULIB_MODULE_stpncpy = true
OMIT_GNULIB_MODULE_sys_select = true
OMIT_GNULIB_MODULE_sys_stat = true
OMIT_GNULIB_MODULE_sys_time = true
OMIT_GNULIB_MODULE_sys_types = true
OMIT_GNULIB_MODULE_unistd = true
-OMIT_GNULIB_MODULE_canonicalize-lgpl = true
OMIT_GNULIB_MODULE_utimens = true
-OMIT_GNULIB_MODULE_fchmodat = true
-OMIT_GNULIB_MODULE_lchmod = true
-OMIT_GNULIB_MODULE_futimens = true
OMIT_GNULIB_MODULE_utimensat = true
-OMIT_GNULIB_MODULE_file-has-acl = true
-OMIT_GNULIB_MODULE_nproc = true
-OMIT_GNULIB_MODULE_nanosleep = true
+OMIT_GNULIB_MODULE_xsize = true
diff --git a/nt/inc/ms-w32.h b/nt/inc/ms-w32.h
index 34023d7645e..cea0b072723 100644
--- a/nt/inc/ms-w32.h
+++ b/nt/inc/ms-w32.h
@@ -111,18 +111,6 @@ along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. */
# endif
#endif
-/* This isn't perfect, as some systems might have the page file in
- another place. Also, I suspect that the time stamp of that file
- might also change when Windows enlarges the file due to
- insufficient VM. Still, this seems to be the most reliable way;
- the alternative (of using GetSystemTimes) won't work on laptops
- that hibernate, because the system clock is stopped then. Other
- possibility would be to run "net statistics workstation" and parse
- the output, but that's gross. So this should do; if the file is
- not there, the boot time will be returned as zero, and filelock.c
- already handles that. */
-#define BOOT_TIME_FILE "C:/pagefile.sys"
-
/* ============================================================ */
/* Here, add any special hacks needed to make Emacs work on this
@@ -220,7 +208,7 @@ extern struct tm * sys_localtime (const time_t *);
/* Unlike MS and mingw.org, MinGW64 doesn't define gai_strerror as an
inline function in a system header file, and instead seems to
- require to link against ws2_32.a. But we don't want to link with
+ require linking against ws2_32.a. But we don't want to link with
-lws2_32, as that would make Emacs dependent on the respective DLL.
So MinGW64 is amply punished here by the following: */
#undef HAVE_GAI_STRERROR
diff --git a/nt/mingw-cfg.site b/nt/mingw-cfg.site
index 7ca19cbad06..9962cc46642 100644
--- a/nt/mingw-cfg.site
+++ b/nt/mingw-cfg.site
@@ -124,7 +124,7 @@ gl_cv_func_pthread_sigmask_return_works=yes
gl_cv_func_pthread_sigmask_unblock_works="not relevant"
gl_cv_func_pthread_sigmask_macro=no
# Implemented in w32proc.c
-emacs_cv_langinfo_codeset=yes
+am_cv_langinfo_codeset=yes
emacs_cv_langinfo__nl_paper_width=yes
# Declared in ms-w32.h
ac_cv_have_decl_alarm=yes
@@ -170,3 +170,6 @@ gl_cv_func_free_preserves_errno=yes
# Don't build the Gnulib nanosleep module: it requires W2K or later,
# and MinGW does have nanosleep.
gl_cv_func_nanosleep=yes
+# Suppress configure-time diagnostic from unnecessary libxattr check,
+# as xattr will not be supported here.
+enable_xattr=no
diff --git a/oldXMenu/ChangeLog.1 b/oldXMenu/ChangeLog.1
index c32f300c19a..629ac2e2b65 100644
--- a/oldXMenu/ChangeLog.1
+++ b/oldXMenu/ChangeLog.1
@@ -240,7 +240,7 @@
* Relicense all FSF files to GPLv3 or later.
-2007-06-04 Ulrich Mueller <ulm@gentoo.org> (tiny change)
+2007-06-04 Ulrich Müller <ulm@gentoo.org> (tiny change)
* ChgPane.c, ChgSel.c: Quiet --with-x-toolkit=no
compilation warnings: #include <config.h>.
@@ -249,7 +249,7 @@
* Version 22.1 released.
-2007-05-30 Ulrich Mueller <ulm@gentoo.org> (tiny change)
+2007-05-30 Ulrich Müller <ulm@gentoo.org> (tiny change)
* XMakeAssoc.c (XMakeAssoc): Use malloc rather than xmalloc.
diff --git a/src/.gdbinit b/src/.gdbinit
index bc6cad0560e..6c4dda67f06 100644
--- a/src/.gdbinit
+++ b/src/.gdbinit
@@ -15,6 +15,10 @@
# You should have received a copy of the GNU General Public License
# along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>.
+# If you don't want messages from GDB to interfere with ordinary editing
+# whenever it creates a subprocess, uncomment the following line.
+### set print inferior-events off
+
# Force loading of symbols, enough to give us VALBITS etc.
set $dummy = main + 8
# With some compilers, we need this to give us struct Lisp_Symbol etc.:
diff --git a/src/.lldbinit b/src/.lldbinit
index 6af0a78b263..e958c1b832c 100644
--- a/src/.lldbinit
+++ b/src/.lldbinit
@@ -30,4 +30,7 @@ script -- sys.path.append('../etc')
# Load our Python files
command script import emacs_lldb
+# Print with children provider, depth 2.
+command alias xprint frame variable -P 2
+
# end.
diff --git a/src/ChangeLog.11 b/src/ChangeLog.11
index 82d22c0a927..abea7688c87 100644
--- a/src/ChangeLog.11
+++ b/src/ChangeLog.11
@@ -6278,7 +6278,7 @@
2010-07-09 Michael Albinus <michael.albinus@gmx.de>
* dbusbind.c (xd_initialize): Add new argument RAISE_ERROR, which
- allows to suppress errors when polling in Emacs' main loop.
+ allows suppressing errors when polling in Emacs' main loop.
(Fdbus_init_bus, Fdbus_get_unique_name, Fdbus_call_method)
(Fdbus_call_method_asynchronously, Fdbus_method_return_internal)
(Fdbus_method_error_internal, Fdbus_send_signal)
@@ -12876,7 +12876,7 @@
* editfns.c (Ftranspose_regions): Doc fix (Bug#3248).
-2009-05-10 Ulrich Mueller <ulm@gentoo.org>
+2009-05-10 Ulrich Müller <ulm@gentoo.org>
* s/gnu-linux.h: Make GCPROs and UNGCPRO no-ops also on SuperH.
@@ -12978,7 +12978,7 @@
* process.c (create_process): Clean up merger residues of
2008-07-17 change.
-2009-04-29 Ulrich Mueller <ulm@gentoo.org>
+2009-04-29 Ulrich Müller <ulm@gentoo.org>
* lread.c (Vread_circle): New variable.
(read1): Disable recursive read if Vread_circle is nil.
@@ -14860,7 +14860,7 @@
* process.c (Fsystem_process_attributes, syms_of_process):
Fix typo in name of Ssystem_process_attributes.
- Reported by Ulrich Mueller <ulm@kph.uni-mainz.de>.
+ Reported by Ulrich Müller <ulm@kph.uni-mainz.de>.
2008-12-11 Juanma Barranquero <lekktu@gmail.com>
@@ -15356,7 +15356,7 @@
* keyboard.c (command_loop_1): Handle NORECORD in call of
Fselect_frame (currently ifdefd).
-2008-11-02 Ulrich Mueller <ulm@kph.uni-mainz.de>
+2008-11-02 Ulrich Müller <ulm@kph.uni-mainz.de>
* emacs.c (USAGE2): Untabify.
@@ -15626,7 +15626,7 @@
(Fset_window_buffer): Respect any non-nil dedicated value for
window. Rename "buffer" argument to "buffer_or_name".
-2008-10-18 Ulrich Mueller <ulm@gentoo.org>
+2008-10-18 Ulrich Müller <ulm@gentoo.org>
* m/sh3.h: New file, machine description for SuperH.
@@ -23405,7 +23405,7 @@
* Makefile.in (lisp): Add ${lispsource}language/tai-viet.el.
(shortlisp): Add ../lisp/language/tai-viet.el.
-2008-02-01 Ulrich Mueller <ulm@gentoo.org>
+2008-02-01 Ulrich Müller <ulm@gentoo.org>
* Makefile.in (${lispsource}international/charprop.el): Depend on
temacs${EXEEXT}.
diff --git a/src/ChangeLog.12 b/src/ChangeLog.12
index a7671077916..7792bd88c01 100644
--- a/src/ChangeLog.12
+++ b/src/ChangeLog.12
@@ -7077,7 +7077,7 @@
* .gdbinit: Use "set $dummy = ..." to avoid warnings from GDB 7.5
and later about non-assignments with no effect. See discussion at
- http://sourceware.org/ml/gdb-patches/2012-08/msg00518.html for
+ https://sourceware.org/ml/gdb-patches/2012-08/msg00518.html for
details.
2012-08-20 Dmitry Antipov <dmantipov@yandex.ru>
diff --git a/src/ChangeLog.3 b/src/ChangeLog.3
index 917921dda5f..e9fa000aff4 100644
--- a/src/ChangeLog.3
+++ b/src/ChangeLog.3
@@ -1250,7 +1250,7 @@
* data.c (Fdefine_function): New function (same code as Fdefalias).
-1993-04-28 Eric S. Raymond (eric@mole.gnu.ai.mit.edu)
+1993-04-28 Eric S. Raymond (esr@thyrsus.com)
* eval.c (do_autoload): Fixed the bug in the autoload-saving code.
@@ -1258,7 +1258,7 @@
* keyboard.c (Fcurrent_input_mode): New function.
-1993-04-27 Eric S. Raymond (eric@mole.gnu.ai.mit.edu)
+1993-04-27 Eric S. Raymond (esr@thyrsus.com)
* eval.c (un_autoload): Don't try to save old autoload forms when
we load something in. Something about the code now conditioned
@@ -1311,7 +1311,7 @@
* dispnew.c (Fsleep_for, Fsit_for): Allow SECONDS to be a
floating point value.
-1993-04-26 Eric S. Raymond (eric@mole.gnu.ai.mit.edu)
+1993-04-26 Eric S. Raymond (esr@thyrsus.com)
* sysdep.c (read_pending_input):
Fix the garbaged-modifiers bug under System Vs previous
@@ -1330,7 +1330,7 @@
beginning or end of the original text to float to the
corresponding position in the replacement text.
-1993-04-25 Eric S. Raymond (eric@mole.gnu.ai.mit.edu)
+1993-04-25 Eric S. Raymond (esr@thyrsus.com)
* window.c (Fset-window-buffer):
Set horizontal-scrolling on a window to zero when
@@ -1351,7 +1351,7 @@
(apply_modifiers): Don't abort if you see extra modifier bits,
just remove them.
-1993-04-23 Eric S. Raymond (eric@mole.gnu.ai.mit.edu)
+1993-04-23 Eric S. Raymond (esr@thyrsus.com)
* data.c (Fdefine_function):
Changed name back to Fdefalias, so we get things
@@ -1386,7 +1386,7 @@
(eval_region, eval_buffer): Call readevalloop with new arg.
(load_history): New variable.
-1993-04-16 Eric S. Raymond (eric@mole.gnu.ai.mit.edu)
+1993-04-16 Eric S. Raymond (esr@thyrsus.com)
* lread.c (readevalloop): New argument is the source file name (or
nil if none). All calls changed. Do the two-step
@@ -1928,7 +1928,7 @@
* xfns.c (Fx_display_color_p): Renamed from Fx_color_display_p.
(syms_of_xfns): Use new name in defsubr.
-1993-03-19 Eric S. Raymond (eric@geech.gnu.ai.mit.edu)
+1993-03-19 Eric S. Raymond (esr@thyrsus.com)
* Makefile.in (unlock, relock): New productions to assist with
version control.
@@ -1960,7 +1960,7 @@
* xfns.c (x_screen): Make this var file scope.
(Fx_server_version): Use Fcons, not list3.
-1993-03-17 Eric S. Raymond (eric@mole.gnu.ai.mit.edu)
+1993-03-17 Eric S. Raymond (esr@thyrsus.com)
* xterm.c (term_get_fkeys): Less klugey version of the last fix.
@@ -1976,7 +1976,7 @@
* xterm.c (x_display_box_cursor, x_display_bar_cursor): Don't
display the cursor on garbaged frames.
-1993-03-17 Eric S. Raymond (eric@mole.gnu.ai.mit.edu)
+1993-03-17 Eric S. Raymond (esr@thyrsus.com)
* term.c (term_get_fkeys) Supply second args for all tgetstr calls.
@@ -2182,7 +2182,7 @@
* cmd.c (internal_self_insert): Check that tab_width does not
exceed 20, to be consistent with indent.c and xdisp.c.
-1993-03-12 Eric S. Raymond (eric@mole.gnu.ai.mit.edu)
+1993-03-12 Eric S. Raymond (esr@thyrsus.com)
* term.c (CONDITIONAL_REASSIGN): Fixed reference to tigetstr.
This should have been tgetstr, but I typoed and tigetstr happens
@@ -2215,7 +2215,7 @@
(make_lispy_event): Handle menu bar events.
(read_key_sequence): Make dummy prefix `menu-bar' for menu bar events.
-1993-03-11 Eric S. Raymond (eric@mole.gnu.ai.mit.edu)
+1993-03-11 Eric S. Raymond (esr@thyrsus.com)
* term.c (fkey_table): Added many more keycap cookies to the
fkey_table; it now supports the full intersection of the set of X
@@ -2289,7 +2289,7 @@
have the data_start symbol defined, so we'll just use the address
of environ.
- * s/usg5-4.h: Changes from Eric Raymond:
+ * s/usg5-4.h: Changes from Eric S. Raymond:
If we're doing ordinary linking, define LIB_STANDARD appropriately.
Give LIBS_DEBUG a null definition; usg5-4 has no -lg.
#define LIBS_STANDARD as "-lc"; usg5-4 has no -lPW.
@@ -2297,7 +2297,7 @@
#define HAVE_TERMIOS instead of HAVE_TCATTR.
Provide our own definition of LIB_X11_LIB.
- * s/usg5-3.h (LIBX11_SYSTEM): Eric Raymond says the libraries here
+ * s/usg5-3.h (LIBX11_SYSTEM): Eric S. Raymond says the libraries here
were slightly wrong.
* m/intel386.h (LIB_STANDARD): If USG5_4 is #defined, there's no
@@ -4335,7 +4335,7 @@
* Makefile.in: Rearrange dependencies to make sure that xmakefile
is built before we try to use it, even using a parallel make.
- Changes for SYSV from Eric Raymond:
+ Changes for SYSV from Eric S. Raymond:
* process.c [SYSV]: Don't include <termios.h>, <termio.h>, or
<fcntl.h>.
(process_send_signal): Don't try to send SIGTSTP
@@ -6187,7 +6187,7 @@
* xterm.c: Doc fixes.
- More SYSV portability changes from Eric Raymond:
+ More SYSV portability changes from Eric S. Raymond:
* xterm.c [USG5]: Don't include <sys/types.h>.
@@ -6222,7 +6222,7 @@
1992-08-14 Jim Blandy (jimb@pogo.cs.oberlin.edu)
- Applied SYSV portability changes from Eric Raymond:
+ Applied SYSV portability changes from Eric S. Raymond:
* xrdb.c [USG5]: Define SYSV, and then include <unistd.h>.
Apparently, Xlib.h include string.h if SYSV is defined, and
@@ -6279,7 +6279,7 @@
* sysdep.c [USG5]: Don't include fcntl.h.
- * s/usg5-3.h: Eric Raymond writes:
+ * s/usg5-3.h: Eric S. Raymond writes:
Define HAVE_SELECT and BSTRINGS only if HAVE_X_WINDOWS is on,
because that means we'll be linking in the shared libraries
containing the BSD emulations. Teach the file about the shared
@@ -6333,7 +6333,7 @@
wasn't written portably, and it should probably go somewhere else
anyway - say, funcall or eval.
- End of changes from Eric Raymond.
+ End of changes from Eric S. Raymond.
* xfns.c (Fx_create_frame): Make the default for the icon-type
parameter nil, not t. It seems to cause problems with some X
diff --git a/src/ChangeLog.4 b/src/ChangeLog.4
index 55549a3eeb1..711e142232c 100644
--- a/src/ChangeLog.4
+++ b/src/ChangeLog.4
@@ -3490,7 +3490,7 @@
* Makefile.in.in (temacs): Delete redundant use of LDFLAGS.
-1994-01-02 Ulrich Mueller (ulm@vsnhd1.cern.ch)
+1994-01-02 Ulrich Müller (ulm@vsnhd1.cern.ch)
* sysdep.c (get_system_name): If the official name of the host is
not a fully qualified domain name, then try to find one in the
diff --git a/src/Makefile.in b/src/Makefile.in
index b034f1661e3..de45b2290f1 100644
--- a/src/Makefile.in
+++ b/src/Makefile.in
@@ -33,6 +33,20 @@ top_builddir = @top_builddir@
# MinGW CPPFLAGS may use this.
abs_top_srcdir=@abs_top_srcdir@
VPATH = $(srcdir)
+
+# This is not empty if this is a Makefile that will be copied to
+# cross/src.
+XCONFIGURE = @XCONFIGURE@
+
+ifneq ($(XCONFIGURE),)
+vpath %.c := $(srcdir)
+vpath %.h := $(srcdir)
+endif
+
+# abs_top_builddir is the name of the toplevel build directory under
+# cross-compiled builds.
+abs_top_builddir = @abs_top_builddir@
+
CC = @CC@
CXX = @CXX@
CFLAGS = @CFLAGS@
@@ -48,6 +62,7 @@ LIBOBJS = @LIBOBJS@
lispsource = $(top_srcdir)/lisp
lib = ../lib
+hostlib = $(top_builddir)/lib
libsrc = ../lib-src
etc = ../etc
oldXMenudir = ../oldXMenu
@@ -127,6 +142,10 @@ LIB_PTHREAD=@LIB_PTHREAD@
LIBIMAGE=@LIBTIFF@ @LIBJPEG@ @LIBPNG@ @LIBGIF@ @LIBXPM@ @WEBP_LIBS@
+GIF_CFLAGS=@GIF_CFLAGS@
+JPEG_CFLAGS=@JPEG_CFLAGS@
+TIFF_CFLAGS=@TIFF_CFLAGS@
+
XCB_LIBS=@XCB_LIBS@
XFT_LIBS=@XFT_LIBS@
XRENDER_LIBS=@XRENDER_LIBS@
@@ -144,10 +163,11 @@ M17N_FLT_CFLAGS = @M17N_FLT_CFLAGS@
M17N_FLT_LIBS = @M17N_FLT_LIBS@
LIB_ACL=@LIB_ACL@
-LIB_CLOCK_GETTIME=@LIB_CLOCK_GETTIME@
-LIB_EACCESS=@LIB_EACCESS@
-LIB_NANOSLEEP=@LIB_NANOSLEEP@
-LIB_TIMER_TIME=@LIB_TIMER_TIME@
+CLOCK_TIME_LIB=@CLOCK_TIME_LIB@
+EUIDACCESS_LIBGEN=@EUIDACCESS_LIBGEN@
+NANOSLEEP_LIB=@NANOSLEEP_LIB@
+QCOPY_ACL_LIB=@QCOPY_ACL_LIB@
+TIMER_TIME_LIB=@TIMER_TIME_LIB@
DBUS_CFLAGS = @DBUS_CFLAGS@
DBUS_LIBS = @DBUS_LIBS@
@@ -240,6 +260,7 @@ LIBXML2_LIBS = @LIBXML2_LIBS@
LIBXML2_CFLAGS = @LIBXML2_CFLAGS@
SQLITE3_LIBS = @SQLITE3_LIBS@
+SQLITE3_CFLAGS = @SQLITE3_CFLAGS@
GETADDRINFO_A_LIBS = @GETADDRINFO_A_LIBS@
@@ -326,12 +347,13 @@ W32_RES_LINK=@W32_RES_LINK@
## if HAVE_HARFBUZZ, hbfont.o is added regardless of the rest
FONT_OBJ=@FONT_OBJ@
-## Empty for MinGW, cm.o for the rest.
+## Empty for MinGW and Android, cm.o for the rest.
CM_OBJ=@CM_OBJ@
LIBGPM = @LIBGPM@
LIBSELINUX_LIBS = @LIBSELINUX_LIBS@
+LIBSELINUX_CFLAGS = @LIBSELINUX_CFLAGS@
LIBGNUTLS_LIBS = @LIBGNUTLS_LIBS@
LIBGNUTLS_CFLAGS = @LIBGNUTLS_CFLAGS@
@@ -370,6 +392,13 @@ HAIKU_CXX_OBJ = @HAIKU_CXX_OBJ@
HAIKU_LIBS = @HAIKU_LIBS@
HAIKU_CFLAGS = @HAIKU_CFLAGS@
+ANDROID_OBJ = @ANDROID_OBJ@
+ANDROID_LIBS = @ANDROID_LIBS@
+ANDROID_LDFLAGS = @ANDROID_LDFLAGS@
+ANDROID_BUILD_CFLAGS = @ANDROID_BUILD_CFLAGS@
+
+LIBGMP_CFLAGS = @LIBGMP_CFLAGS@
+
DUMPING=@DUMPING@
CHECK_STRUCTS = @CHECK_STRUCTS@
HAVE_PDUMPER = @HAVE_PDUMPER@
@@ -411,7 +440,9 @@ 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) $(XCOMPOSITE_CFLAGS) $(XSHAPE_CFLAGS)
+ $(WERROR_CFLAGS) $(HAIKU_CFLAGS) $(XCOMPOSITE_CFLAGS) $(XSHAPE_CFLAGS) \
+ $(ANDROID_BUILD_CFLAGS) $(GIF_CFLAGS) $(JPEG_CFLAGS) $(SQLITE3_CFLAGS) \
+ $(LIBGMP_CFLAGS) $(TIFF_CFLAGS) $(LIBSELINUX_CFLAGS)
ALL_CFLAGS = $(EMACS_CFLAGS) $(WARN_CFLAGS) $(CFLAGS)
ALL_OBJC_CFLAGS = $(EMACS_CFLAGS) \
$(filter-out $(NON_OBJC_CFLAGS),$(WARN_CFLAGS)) $(CFLAGS) \
@@ -449,7 +480,7 @@ base_obj = dispnew.o frame.o scroll.o xdisp.o menu.o $(XMENU_OBJ) window.o \
$(if $(HYBRID_MALLOC),sheap.o) \
$(MSDOS_OBJ) $(MSDOS_X_OBJ) $(NS_OBJ) $(CYGWIN_OBJ) $(FONT_OBJ) \
$(W32_OBJ) $(WINDOW_SYSTEM_OBJ) $(XGSELOBJ) $(JSON_OBJ) \
- $(HAIKU_OBJ) $(PGTK_OBJ)
+ $(HAIKU_OBJ) $(PGTK_OBJ) $(ANDROID_OBJ)
doc_obj = $(base_obj) $(NS_OBJC_OBJ)
obj = $(doc_obj) $(HAIKU_CXX_OBJ)
@@ -466,7 +497,8 @@ SOME_MACHINE_OBJECTS = dosfns.o msdos.o \
w32menu.o w32proc.o w32reg.o w32select.o w32term.o w32xfns.o \
w16select.o widget.o xfont.o ftfont.o xftfont.o gtkutil.o \
xsettings.o xgselect.o termcap.o hbfont.o \
- haikuterm.o haikufns.o haikumenu.o haikufont.o
+ haikuterm.o haikufns.o haikumenu.o haikufont.o androidterm.o androidfns.o \
+ androidfont.o androidselect.c sfntfont-android.c sfntfont.c
## gmalloc.o if !SYSTEM_MALLOC && !DOUG_LEA_MALLOC, else empty.
GMALLOC_OBJ=@GMALLOC_OBJ@
@@ -537,15 +569,19 @@ endif
## we need to remove leim-list, site-init, and site-load by hand.
## There's not much to choose between these two approaches,
## but the second one seems like it could be more future-proof.
+##
+## This list is placed in the toplevel build directory to prevent it
+## from being unnecessarily regenerated by the successive use of this
+## Makefile within cross/Makefile.
shortlisp =
-lisp.mk: $(lispsource)/loadup.el
+$(abs_top_builddir)/src/lisp.mk: $(lispsource)/loadup.el
${AM_V_GEN}( printf 'shortlisp = \\\n'; \
sed -n 's/^[ \t]*(load "\([^"]*\)".*/\1/p' $< | \
sed -e 's/$$/.elc \\/' -e 's/\.el\.elc/.el/'; \
echo "" ) > $@.tmp
$(AM_V_at)mv -f $@.tmp $@
--include lisp.mk
+-include $(abs_top_builddir)/src/lisp.mk
shortlisp_filter = leim/leim-list.el site-load.elc site-init.elc
shortlisp := $(filter-out ${shortlisp_filter},${shortlisp})
## Place loaddefs.el first, so it gets generated first, since it is on
@@ -558,9 +594,9 @@ lisp = $(addprefix ${lispsource}/,${shortlisp})
## Construct full set of libraries to be linked.
LIBES = $(LIBS) $(W32_LIBS) $(LIBS_GNUSTEP) $(PGTK_LIBS) $(LIBX_BASE) $(LIBIMAGE) \
$(LIBX_OTHER) $(LIBSOUND) \
- $(RSVG_LIBS) $(IMAGEMAGICK_LIBS) $(LIB_ACL) $(LIB_CLOCK_GETTIME) \
- $(LIB_NANOSLEEP) $(WEBKIT_LIBS) \
- $(LIB_EACCESS) $(LIB_TIMER_TIME) $(DBUS_LIBS) \
+ $(RSVG_LIBS) $(IMAGEMAGICK_LIBS) $(LIB_ACL) $(CLOCK_TIME_LIB) \
+ $(NANOSLEEP_LIB) $(QCOPY_ACL_LIB) $(WEBKIT_LIBS) \
+ $(EUIDACCESS_LIBGEN) $(TIMER_TIME_LIB) $(DBUS_LIBS) \
$(LIB_EXECINFO) $(XRANDR_LIBS) $(XINERAMA_LIBS) $(XFIXES_LIBS) \
$(XDBE_LIBS) $(XSYNC_LIBS) \
$(LIBXML2_LIBS) $(LIBGPM) $(LIBS_SYSTEM) $(CAIRO_LIBS) \
@@ -569,15 +605,18 @@ 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) $(XCOMPOSITE_LIBS) $(XSHAPE_LIBS)
+ $(TREE_SITTER_LIBS) $(SQLITE3_LIBS) $(XCOMPOSITE_LIBS) $(XSHAPE_LIBS) \
+ $(ANDROID_LIBS)
## FORCE it so that admin/unidata can decide whether this file is
## up-to-date. Although since charprop depends on bootstrap-emacs,
## and emacs depends on charprop, in practice this rule was always run
## anyway.
+ifneq ($(XCONFIGURE),android)
$(lispsource)/international/charprop.el: \
FORCE | bootstrap-emacs$(EXEEXT) $(bootstrap_pdmp)
$(MAKE) -C ../admin/unidata all EMACS="../$(bootstrap_exe)"
+endif
## We require charprop.el to exist before ucs-normalize.el is
## byte-compiled, because ucs-normalize.el needs to load 2 uni-*.el files.
@@ -611,7 +650,7 @@ SYSTEM_TYPE = @SYSTEM_TYPE@
## since not all pieces are used on all platforms. But DOC depends
## on all of $lisp, and emacs depends on DOC, so it is ok to use $lisp here.
emacs$(EXEEXT): temacs$(EXEEXT) \
- lisp.mk $(etc)/DOC $(lisp) \
+ $(abs_top_builddir)/src/lisp.mk $(etc)/DOC $(lisp) \
$(lispsource)/international/charprop.el ${charsets}
ifeq ($(SYSTEM_TYPE),cygwin)
find ${top_builddir} -name '*.eln' | rebase -v -O -T -
@@ -658,7 +697,7 @@ $(etc)/DOC: $(libsrc)/make-docfile$(EXEEXT) $(doc_obj)
$(SOME_MACHINE_OBJECTS) $(doc_obj) > $(etc)/DOC
$(libsrc)/make-docfile$(EXEEXT) $(libsrc)/make-fingerprint$(EXEEXT): \
- $(lib)/libgnu.a
+ $(hostlib)/libgnu.a
$(MAKE) -C $(dir $@) $(notdir $@)
buildobj.h: Makefile
@@ -719,6 +758,47 @@ ifeq ($(DUMPING),unexec)
endif
endif
+ifeq ($(XCONFIGURE),android)
+## The Android package internally links to a shared library named
+## `libemacs.so' at startup. It is built almost the same way temacs
+## is. But it is position independent, and is not dumped here.
+## Instead, it dumps itself the first time it starts on the user's
+## device.
+
+# Include ndk-build.mk in order to build Emacs dependencies.
+old_top_builddir := $(top_builddir)
+top_builddir := $(old_top_builddir)/..
+include $(old_top_builddir)/ndk-build/ndk-build.mk
+top_builddir := $(old_top_builddir)
+
+## Builds using libemacs.so (Android) don't dump Emacs within this
+## Makefile, but on device. Make sure the library hash changes for
+## each change in shortlisp by linking an object that changes
+## accordingly to it.
+BUILD_COUNTER_OBJ = build-counter.o
+
+# This file is then compiled into libemacs.so
+build-counter.c: $(abs_top_builddir)/src/lisp.mk $(lisp)
+ $(AM_V_GEN) $(top_srcdir)/build-aux/makecounter.sh $@
+
+libemacs.so: $(ALLOBJS) $(BUILD_COUNTER_OBJ) $(LIBEGNU_ARCHIVE) \
+ $(EMACSRES) $(MAKE_PDUMPER_FINGERPRINT) \
+ $(NDK_BUILD_SHARED) $(NDK_BUILD_STATIC) $(etc)/DOC
+ $(AM_V_CCLD)$(CC) -o $@ $(ALL_CFLAGS) $(TEMACS_LDFLAGS) \
+ $(ANDROID_LDFLAGS) $(LDFLAGS) -shared $(ALLOBJS) \
+ $(BUILD_COUNTER_OBJ) $(LIBEGNU_ARCHIVE) $(LIBES)
+ $(AM_V_at)$(MAKE_PDUMPER_FINGERPRINT) $@
+
+# There is also a binary named `android-emacs' which simply calls
+# emacs.so. It need not link against libemacs because app_process
+# will do that instead.
+
+android-emacs: android-emacs.c
+ $(AM_V_CCLD)$(CC) $(lastword $^) -o $@ \
+ $(ALL_CFLAGS) $(LDFLAGS) \
+ $(LIBEGNU_ARCHIVE)
+endif
+
## The following oldxmenu-related rules are only (possibly) used if
## HAVE_X11 && !USE_GTK, but there is no harm in always defining them.
$(lwlibdir)/liblw.a: $(config_h) globals.h lisp.h FORCE
@@ -747,7 +827,8 @@ ns-app: emacs$(EXEEXT) $(pdmp)
.PHONY: versionclean
mostlyclean:
- rm -f temacs$(EXEEXT) core ./*.core \#* ./*.o
+ rm -f android-emacs libemacs.so
+ rm -f temacs$(EXEEXT) core ./*.core \#* ./*.o build-counter.c
rm -f dmpstruct.h
rm -f emacs.pdmp
rm -f ../etc/DOC
@@ -836,10 +917,16 @@ tags: TAGS ../lisp/TAGS $(lwlibdir)/TAGS $(lib)/TAGS
## To solve the freshness issue, in the past we tried various clever tricks,
## but now that we require GNU make, we can simply specify
## bootstrap-emacs$(EXEEXT) as an order-only prerequisite.
+##
+## bootstrap-emacs doesn't have to be built when cross-compiling
+## libemacs.so for Android, however, as the Lisp files have already
+## been compiled by the top level `src' Makefile.
+ifneq ($(XCONFIGURE),android)
%.elc: %.el | bootstrap-emacs$(EXEEXT) $(bootstrap_pdmp)
@$(MAKE) $(AM_V_NO_PD) -C ../lisp EMACS="$(bootstrap_exe)"\
THEFILE=$< $<c
+endif
ifeq ($(HAVE_NATIVE_COMP):$(NATIVE_DISABLED),yes:)
## The following rules are used only when building a source tarball
@@ -856,6 +943,8 @@ elnlisp := \
international/charscript.eln \
emacs-lisp/comp.eln \
emacs-lisp/comp-cstr.eln \
+ emacs-lisp/comp-common.eln \
+ emacs-lisp/comp-run.eln \
international/emoji-zwj.eln
elnlisp := $(addprefix ${lispsource}/,${elnlisp}) $(lisp:.elc=.eln)
@@ -893,8 +982,10 @@ NATIVE_COMPILATION_AOT = @NATIVE_COMPILATION_AOT@
fi
endif
+ifneq ($(XCONFIGURE),android)
$(lispsource)/loaddefs.el: | bootstrap-emacs$(EXEEXT) $(bootstrap_pdmp)
$(MAKE) -C ../lisp autoloads EMACS="$(bootstrap_exe)"
+endif
## Dump an Emacs executable named bootstrap-emacs containing the
## files from loadup.el in source form.
diff --git a/src/alloc.c b/src/alloc.c
index b02f13e911f..2ffd2415447 100644
--- a/src/alloc.c
+++ b/src/alloc.c
@@ -34,7 +34,6 @@ along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. */
#include "dispextern.h"
#include "intervals.h"
#include "puresize.h"
-#include "sheap.h"
#include "sysstdio.h"
#include "systime.h"
#include "character.h"
@@ -50,6 +49,10 @@ along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. */
#include TERM_HEADER
#endif /* HAVE_WINDOW_SYSTEM */
+#if defined HAVE_ANDROID && !defined ANDROID_STUBIFY
+#include "sfntfont.h"
+#endif
+
#ifdef HAVE_TREE_SITTER
#include "treesit.h"
#endif
@@ -80,6 +83,37 @@ along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. */
#include <valgrind/memcheck.h>
#endif
+/* AddressSanitizer exposes additional functions for manually marking
+ memory as poisoned/unpoisoned. When ASan is enabled and the needed
+ header is available, memory is poisoned when:
+
+ * An ablock is freed (lisp_align_free), or ablocks are initially
+ allocated (lisp_align_malloc).
+ * An interval_block is initially allocated (make_interval).
+ * A dead INTERVAL is put on the interval free list
+ (sweep_intervals).
+ * A sdata is marked as dead (sweep_strings, pin_string).
+ * An sblock is initially allocated (allocate_string_data).
+ * A string_block is initially allocated (allocate_string).
+ * A dead string is put on string_free_list (sweep_strings).
+ * A float_block is initially allocated (make_float).
+ * A dead float is put on float_free_list.
+ * A cons_block is initially allocated (Fcons).
+ * A dead cons is put on cons_free_list (sweep_cons).
+ * A dead vector is put on vector_free_list (setup_on_free_list),
+ or a new vector block is allocated (allocate_vector_from_block).
+ Accordingly, objects reused from the free list are unpoisoned.
+
+ This feature can be disabled with the run-time flag
+ `allow_user_poisoning' set to zero. */
+#if ADDRESS_SANITIZER && defined HAVE_SANITIZER_ASAN_INTERFACE_H \
+ && !defined GC_ASAN_POISON_OBJECTS
+# define GC_ASAN_POISON_OBJECTS 1
+# include <sanitizer/asan_interface.h>
+#else
+# define GC_ASAN_POISON_OBJECTS 0
+#endif
+
/* GC_CHECK_MARKED_OBJECTS means do sanity checks on allocated objects.
We turn that on by default when ENABLE_CHECKING is defined;
define GC_CHECK_MARKED_OBJECTS to zero to disable. */
@@ -325,8 +359,16 @@ static struct gcstat
object_ct total_floats, total_free_floats;
object_ct total_intervals, total_free_intervals;
object_ct total_buffers;
+
+ /* Size of the ancillary arrays of live hash-table and obarray objects.
+ The objects themselves are not included (counted as vectors above). */
+ byte_ct total_hash_table_bytes;
} gcstat;
+/* Total size of ancillary arrays of all allocated hash-table and obarray
+ objects, both dead and alive. This number is always kept up-to-date. */
+static ptrdiff_t hash_table_allocated_bytes = 0;
+
/* Points to memory space allocated as "spare", to be freed if we run
out of memory. We keep one large block, four cons-blocks, and
two string blocks. */
@@ -378,31 +420,6 @@ static EMACS_INT gc_threshold;
const char *pending_malloc_warning;
-/* Pointer sanity only on request. FIXME: Code depending on
- SUSPICIOUS_OBJECT_CHECKING is obsolete; remove it entirely. */
-#ifdef ENABLE_CHECKING
-#define SUSPICIOUS_OBJECT_CHECKING 1
-#endif
-
-#ifdef SUSPICIOUS_OBJECT_CHECKING
-struct suspicious_free_record
-{
- void *suspicious_object;
- void *backtrace[128];
-};
-static void *suspicious_objects[32];
-static int suspicious_object_index;
-struct suspicious_free_record suspicious_free_history[64] EXTERNALLY_VISIBLE;
-static int suspicious_free_history_index;
-/* Find the first currently-monitored suspicious pointer in range
- [begin,end) or NULL if no such pointer exists. */
-static void *find_suspicious_object_in_range (void *begin, void *end);
-static void detect_suspicious_free (void *ptr);
-#else
-# define find_suspicious_object_in_range(begin, end) ((void *) NULL)
-# define detect_suspicious_free(ptr) ((void) 0)
-#endif
-
/* Maximum amount of C stack to save when a GC happens. */
#ifndef MAX_SAVE_STACK
@@ -832,7 +849,7 @@ xnmalloc (ptrdiff_t nitems, ptrdiff_t item_size)
{
eassert (0 <= nitems && 0 < item_size);
ptrdiff_t nbytes;
- if (INT_MULTIPLY_WRAPV (nitems, item_size, &nbytes) || SIZE_MAX < nbytes)
+ if (ckd_mul (&nbytes, nitems, item_size) || SIZE_MAX < nbytes)
memory_full (SIZE_MAX);
return xmalloc (nbytes);
}
@@ -846,7 +863,7 @@ xnrealloc (void *pa, ptrdiff_t nitems, ptrdiff_t item_size)
{
eassert (0 <= nitems && 0 < item_size);
ptrdiff_t nbytes;
- if (INT_MULTIPLY_WRAPV (nitems, item_size, &nbytes) || SIZE_MAX < nbytes)
+ if (ckd_mul (&nbytes, nitems, item_size) || SIZE_MAX < nbytes)
memory_full (SIZE_MAX);
return xrealloc (pa, nbytes);
}
@@ -893,13 +910,13 @@ xpalloc (void *pa, ptrdiff_t *nitems, ptrdiff_t nitems_incr_min,
NITEMS_MAX, and what the C language can represent safely. */
ptrdiff_t n, nbytes;
- if (INT_ADD_WRAPV (n0, n0 >> 1, &n))
+ if (ckd_add (&n, n0, n0 >> 1))
n = PTRDIFF_MAX;
if (0 <= nitems_max && nitems_max < n)
n = nitems_max;
ptrdiff_t adjusted_nbytes
- = ((INT_MULTIPLY_WRAPV (n, item_size, &nbytes) || SIZE_MAX < nbytes)
+ = ((ckd_mul (&nbytes, n, item_size) || SIZE_MAX < nbytes)
? min (PTRDIFF_MAX, SIZE_MAX)
: nbytes < DEFAULT_MXFAST ? DEFAULT_MXFAST : 0);
if (adjusted_nbytes)
@@ -911,9 +928,9 @@ xpalloc (void *pa, ptrdiff_t *nitems, ptrdiff_t nitems_incr_min,
if (! pa)
*nitems = 0;
if (n - n0 < nitems_incr_min
- && (INT_ADD_WRAPV (n0, nitems_incr_min, &n)
+ && (ckd_add (&n, n0, nitems_incr_min)
|| (0 <= nitems_max && nitems_max < n)
- || INT_MULTIPLY_WRAPV (n, item_size, &nbytes)))
+ || ckd_mul (&nbytes, n, item_size)))
memory_full (SIZE_MAX);
pa = xrealloc (pa, nbytes);
*nitems = n;
@@ -1052,7 +1069,11 @@ lisp_free (void *block)
BLOCK_BYTES and guarantees they are aligned on a BLOCK_ALIGN boundary. */
/* Byte alignment of storage blocks. */
-#define BLOCK_ALIGN (1 << 10)
+#ifdef HAVE_UNEXEC
+# define BLOCK_ALIGN (1 << 10)
+#else /* !HAVE_UNEXEC */
+# define BLOCK_ALIGN (1 << 15)
+#endif
verify (POWER_OF_2 (BLOCK_ALIGN));
/* Use aligned_alloc if it or a simple substitute is available.
@@ -1157,6 +1178,16 @@ struct ablocks
(1 & (intptr_t) ABLOCKS_BUSY (abase) ? abase : ((void **) (abase))[-1])
#endif
+#if GC_ASAN_POISON_OBJECTS
+# define ASAN_POISON_ABLOCK(b) \
+ __asan_poison_memory_region (&(b)->x, sizeof ((b)->x))
+# define ASAN_UNPOISON_ABLOCK(b) \
+ __asan_unpoison_memory_region (&(b)->x, sizeof ((b)->x))
+#else
+# define ASAN_POISON_ABLOCK(b) ((void) 0)
+# define ASAN_UNPOISON_ABLOCK(b) ((void) 0)
+#endif
+
/* The list of free ablock. */
static struct ablock *free_ablock;
@@ -1235,6 +1266,7 @@ lisp_align_malloc (size_t nbytes, enum mem_type type)
{
abase->blocks[i].abase = abase;
abase->blocks[i].x.next_free = free_ablock;
+ ASAN_POISON_ABLOCK (&abase->blocks[i]);
free_ablock = &abase->blocks[i];
}
intptr_t ialigned = aligned;
@@ -1247,6 +1279,7 @@ lisp_align_malloc (size_t nbytes, enum mem_type type)
eassert ((intptr_t) ABLOCKS_BUSY (abase) == aligned);
}
+ ASAN_UNPOISON_ABLOCK (free_ablock);
abase = ABLOCK_ABASE (free_ablock);
ABLOCKS_BUSY (abase)
= (struct ablocks *) (2 + (intptr_t) ABLOCKS_BUSY (abase));
@@ -1278,6 +1311,7 @@ lisp_align_free (void *block)
#endif
/* Put on free list. */
ablock->x.next_free = free_ablock;
+ ASAN_POISON_ABLOCK (ablock);
free_ablock = ablock;
/* Update busy count. */
intptr_t busy = (intptr_t) ABLOCKS_BUSY (abase) - 2;
@@ -1290,9 +1324,12 @@ lisp_align_free (void *block)
bool aligned = busy;
struct ablock **tem = &free_ablock;
struct ablock *atop = &abase->blocks[aligned ? ABLOCKS_SIZE : ABLOCKS_SIZE - 1];
-
while (*tem)
{
+#if GC_ASAN_POISON_OBJECTS
+ __asan_unpoison_memory_region (&(*tem)->x,
+ sizeof ((*tem)->x));
+#endif
if (*tem >= (struct ablock *) abase && *tem < atop)
{
i++;
@@ -1421,6 +1458,24 @@ static int interval_block_index = INTERVAL_BLOCK_SIZE;
static INTERVAL interval_free_list;
+#if GC_ASAN_POISON_OBJECTS
+# define ASAN_POISON_INTERVAL_BLOCK(b) \
+ __asan_poison_memory_region ((b)->intervals, \
+ sizeof ((b)->intervals))
+# define ASAN_UNPOISON_INTERVAL_BLOCK(b) \
+ __asan_unpoison_memory_region ((b)->intervals, \
+ sizeof ((b)->intervals))
+# define ASAN_POISON_INTERVAL(i) \
+ __asan_poison_memory_region (i, sizeof *(i))
+# define ASAN_UNPOISON_INTERVAL(i) \
+ __asan_unpoison_memory_region (i, sizeof *(i))
+#else
+# define ASAN_POISON_INTERVAL_BLOCK(b) ((void) 0)
+# define ASAN_UNPOISON_INTERVAL_BLOCK(b) ((void) 0)
+# define ASAN_POISON_INTERVAL(i) ((void) 0)
+# define ASAN_UNPOISON_INTERVAL(i) ((void) 0)
+#endif
+
/* Return a new interval. */
INTERVAL
@@ -1433,6 +1488,7 @@ make_interval (void)
if (interval_free_list)
{
val = interval_free_list;
+ ASAN_UNPOISON_INTERVAL (val);
interval_free_list = INTERVAL_PARENT (interval_free_list);
}
else
@@ -1443,10 +1499,12 @@ make_interval (void)
= lisp_malloc (sizeof *newi, false, MEM_TYPE_NON_LISP);
newi->next = interval_block;
+ ASAN_POISON_INTERVAL_BLOCK (newi);
interval_block = newi;
interval_block_index = 0;
}
val = &interval_block->intervals[interval_block_index++];
+ ASAN_UNPOISON_INTERVAL (val);
}
MALLOC_UNBLOCK_INPUT;
@@ -1687,6 +1745,41 @@ init_strings (void)
staticpro (&empty_multibyte_string);
}
+#if GC_ASAN_POISON_OBJECTS
+/* Prepare s for denoting a free sdata struct, i.e, poison all bytes
+ in the flexible array member, except the first SDATA_OFFSET bytes.
+ This is only effective for strings of size n where n > sdata_size(n).
+ */
+# define ASAN_PREPARE_DEAD_SDATA(s, size) \
+ do { \
+ __asan_poison_memory_region (s, sdata_size (size)); \
+ __asan_unpoison_memory_region (&(s)->string, \
+ sizeof (struct Lisp_String *)); \
+ __asan_unpoison_memory_region (&SDATA_NBYTES (s), \
+ sizeof SDATA_NBYTES (s)); \
+ } while (false)
+/* Prepare s for storing string data for NBYTES bytes. */
+# define ASAN_PREPARE_LIVE_SDATA(s, nbytes) \
+ __asan_unpoison_memory_region (s, sdata_size (nbytes))
+# define ASAN_POISON_SBLOCK_DATA(b, size) \
+ __asan_poison_memory_region ((b)->data, size)
+# define ASAN_POISON_STRING_BLOCK(b) \
+ __asan_poison_memory_region ((b)->strings, STRING_BLOCK_SIZE)
+# define ASAN_UNPOISON_STRING_BLOCK(b) \
+ __asan_unpoison_memory_region ((b)->strings, STRING_BLOCK_SIZE)
+# define ASAN_POISON_STRING(s) \
+ __asan_poison_memory_region (s, sizeof *(s))
+# define ASAN_UNPOISON_STRING(s) \
+ __asan_unpoison_memory_region (s, sizeof *(s))
+#else
+# define ASAN_PREPARE_DEAD_SDATA(s, size) ((void) 0)
+# define ASAN_PREPARE_LIVE_SDATA(s, nbytes) ((void) 0)
+# define ASAN_POISON_SBLOCK_DATA(b, size) ((void) 0)
+# define ASAN_POISON_STRING_BLOCK(b) ((void) 0)
+# define ASAN_UNPOISON_STRING_BLOCK(b) ((void) 0)
+# define ASAN_POISON_STRING(s) ((void) 0)
+# define ASAN_UNPOISON_STRING(s) ((void) 0)
+#endif
#ifdef GC_CHECK_STRING_BYTES
@@ -1805,12 +1898,14 @@ allocate_string (void)
NEXT_FREE_LISP_STRING (s) = string_free_list;
string_free_list = s;
}
+ ASAN_POISON_STRING_BLOCK (b);
}
check_string_free_list ();
/* Pop a Lisp_String off the free-list. */
s = string_free_list;
+ ASAN_UNPOISON_STRING (s);
string_free_list = NEXT_FREE_LISP_STRING (s);
MALLOC_UNBLOCK_INPUT;
@@ -1870,6 +1965,7 @@ allocate_string_data (struct Lisp_String *s,
#endif
b = lisp_malloc (size + GC_STRING_EXTRA, clearit, MEM_TYPE_NON_LISP);
+ ASAN_POISON_SBLOCK_DATA (b, size);
#ifdef DOUG_LEA_MALLOC
if (!mmap_lisp_allowed_p ())
@@ -1891,6 +1987,8 @@ allocate_string_data (struct Lisp_String *s,
{
/* Not enough room in the current sblock. */
b = lisp_malloc (SBLOCK_SIZE, false, MEM_TYPE_NON_LISP);
+ ASAN_POISON_SBLOCK_DATA (b, SBLOCK_SIZE);
+
data = b->data;
b->next = NULL;
b->next_free = data;
@@ -1903,10 +2001,19 @@ allocate_string_data (struct Lisp_String *s,
}
data = b->next_free;
+
if (clearit)
- memset (SDATA_DATA (data), 0, nbytes);
+ {
+#if GC_ASAN_POISON_OBJECTS
+ /* We are accessing SDATA_DATA (data) before it gets
+ * normally unpoisoned, so do it manually. */
+ __asan_unpoison_memory_region (SDATA_DATA (data), nbytes);
+#endif
+ memset (SDATA_DATA (data), 0, nbytes);
+ }
}
+ ASAN_PREPARE_LIVE_SDATA (data, nbytes);
data->string = s;
b->next_free = (sdata *) ((char *) data + needed + GC_STRING_EXTRA);
eassert ((uintptr_t) b->next_free % alignof (sdata) == 0);
@@ -1998,12 +2105,16 @@ sweep_strings (void)
int i, nfree = 0;
struct Lisp_String *free_list_before = string_free_list;
+ ASAN_UNPOISON_STRING_BLOCK (b);
+
next = b->next;
for (i = 0; i < STRING_BLOCK_SIZE; ++i)
{
struct Lisp_String *s = b->strings + i;
+ ASAN_UNPOISON_STRING (s);
+
if (s->u.s.data)
{
/* String was not on free-list before. */
@@ -2040,6 +2151,8 @@ sweep_strings (void)
/* Put the string on the free-list. */
NEXT_FREE_LISP_STRING (s) = string_free_list;
+ ASAN_POISON_STRING (s);
+ ASAN_PREPARE_DEAD_SDATA (data, SDATA_NBYTES (data));
string_free_list = s;
++nfree;
}
@@ -2048,6 +2161,8 @@ sweep_strings (void)
{
/* S was on the free-list before. Put it there again. */
NEXT_FREE_LISP_STRING (s) = string_free_list;
+ ASAN_POISON_STRING (s);
+
string_free_list = s;
++nfree;
}
@@ -2174,6 +2289,7 @@ compact_small_strings (void)
if (from != to)
{
eassert (tb != b || to < from);
+ ASAN_PREPARE_LIVE_SDATA (to, nbytes);
memmove (to, from, size + GC_STRING_EXTRA);
to->string->u.s.data = SDATA_DATA (to);
}
@@ -2245,7 +2361,7 @@ a multibyte string even if INIT is an ASCII character. */)
ptrdiff_t len = CHAR_STRING (c, str);
EMACS_INT string_len = XFIXNUM (length);
- if (INT_MULTIPLY_WRAPV (len, string_len, &nbytes))
+ if (ckd_mul (&nbytes, len, string_len))
string_overflow ();
val = make_clear_multibyte_string (string_len, nbytes, clearit);
if (!clearit)
@@ -2525,6 +2641,7 @@ pin_string (Lisp_Object string)
memcpy (s->u.s.data, data, size);
old_sdata->string = NULL;
SDATA_NBYTES (old_sdata) = size;
+ ASAN_PREPARE_DEAD_SDATA (old_sdata, size);
}
s->u.s.size_byte = -3;
}
@@ -2574,13 +2691,31 @@ struct float_block
};
#define XFLOAT_MARKED_P(fptr) \
- GETMARKBIT (FLOAT_BLOCK (fptr), FLOAT_INDEX ((fptr)))
+ GETMARKBIT (FLOAT_BLOCK (fptr), FLOAT_INDEX (fptr))
#define XFLOAT_MARK(fptr) \
- SETMARKBIT (FLOAT_BLOCK (fptr), FLOAT_INDEX ((fptr)))
+ SETMARKBIT (FLOAT_BLOCK (fptr), FLOAT_INDEX (fptr))
#define XFLOAT_UNMARK(fptr) \
- UNSETMARKBIT (FLOAT_BLOCK (fptr), FLOAT_INDEX ((fptr)))
+ UNSETMARKBIT (FLOAT_BLOCK (fptr), FLOAT_INDEX (fptr))
+
+#if GC_ASAN_POISON_OBJECTS
+# define ASAN_POISON_FLOAT_BLOCK(fblk) \
+ __asan_poison_memory_region ((fblk)->floats, \
+ sizeof ((fblk)->floats))
+# define ASAN_UNPOISON_FLOAT_BLOCK(fblk) \
+ __asan_unpoison_memory_region ((fblk)->floats, \
+ sizeof ((fblk)->floats))
+# define ASAN_POISON_FLOAT(p) \
+ __asan_poison_memory_region (p, sizeof (struct Lisp_Float))
+# define ASAN_UNPOISON_FLOAT(p) \
+ __asan_unpoison_memory_region (p, sizeof (struct Lisp_Float))
+#else
+# define ASAN_POISON_FLOAT_BLOCK(fblk) ((void) 0)
+# define ASAN_UNPOISON_FLOAT_BLOCK(fblk) ((void) 0)
+# define ASAN_POISON_FLOAT(p) ((void) 0)
+# define ASAN_UNPOISON_FLOAT(p) ((void) 0)
+#endif
/* Current float_block. */
@@ -2606,6 +2741,7 @@ make_float (double float_value)
if (float_free_list)
{
XSETFLOAT (val, float_free_list);
+ ASAN_UNPOISON_FLOAT (float_free_list);
float_free_list = float_free_list->u.chain;
}
else
@@ -2616,9 +2752,11 @@ make_float (double float_value)
= lisp_align_malloc (sizeof *new, MEM_TYPE_FLOAT);
new->next = float_block;
memset (new->gcmarkbits, 0, sizeof new->gcmarkbits);
+ ASAN_POISON_FLOAT_BLOCK (new);
float_block = new;
float_block_index = 0;
}
+ ASAN_UNPOISON_FLOAT (&float_block->floats[float_block_index]);
XSETFLOAT (val, &float_block->floats[float_block_index]);
float_block_index++;
}
@@ -2665,13 +2803,13 @@ struct cons_block
};
#define XCONS_MARKED_P(fptr) \
- GETMARKBIT (CONS_BLOCK (fptr), CONS_INDEX ((fptr)))
+ GETMARKBIT (CONS_BLOCK (fptr), CONS_INDEX (fptr))
#define XMARK_CONS(fptr) \
- SETMARKBIT (CONS_BLOCK (fptr), CONS_INDEX ((fptr)))
+ SETMARKBIT (CONS_BLOCK (fptr), CONS_INDEX (fptr))
#define XUNMARK_CONS(fptr) \
- UNSETMARKBIT (CONS_BLOCK (fptr), CONS_INDEX ((fptr)))
+ UNSETMARKBIT (CONS_BLOCK (fptr), CONS_INDEX (fptr))
/* Minimum number of bytes of consing since GC before next GC,
when memory is full. */
@@ -2690,6 +2828,19 @@ static int cons_block_index = CONS_BLOCK_SIZE;
static struct Lisp_Cons *cons_free_list;
+#if GC_ASAN_POISON_OBJECTS
+# define ASAN_POISON_CONS_BLOCK(b) \
+ __asan_poison_memory_region ((b)->conses, sizeof ((b)->conses))
+# define ASAN_POISON_CONS(p) \
+ __asan_poison_memory_region (p, sizeof (struct Lisp_Cons))
+# define ASAN_UNPOISON_CONS(p) \
+ __asan_unpoison_memory_region (p, sizeof (struct Lisp_Cons))
+#else
+# define ASAN_POISON_CONS_BLOCK(b) ((void) 0)
+# define ASAN_POISON_CONS(p) ((void) 0)
+# define ASAN_UNPOISON_CONS(p) ((void) 0)
+#endif
+
/* Explicitly free a cons cell by putting it on the free-list. */
void
@@ -2700,6 +2851,7 @@ free_cons (struct Lisp_Cons *ptr)
cons_free_list = ptr;
ptrdiff_t nbytes = sizeof *ptr;
tally_consing (-nbytes);
+ ASAN_POISON_CONS (ptr);
}
DEFUN ("cons", Fcons, Scons, 2, 2, 0,
@@ -2712,6 +2864,7 @@ DEFUN ("cons", Fcons, Scons, 2, 2, 0,
if (cons_free_list)
{
+ ASAN_UNPOISON_CONS (cons_free_list);
XSETCONS (val, cons_free_list);
cons_free_list = cons_free_list->u.s.u.chain;
}
@@ -2722,10 +2875,12 @@ DEFUN ("cons", Fcons, Scons, 2, 2, 0,
struct cons_block *new
= lisp_align_malloc (sizeof *new, MEM_TYPE_CONS);
memset (new->gcmarkbits, 0, sizeof new->gcmarkbits);
+ ASAN_POISON_CONS_BLOCK (new);
new->next = cons_block;
cons_block = new;
cons_block_index = 0;
}
+ ASAN_UNPOISON_CONS (&cons_block->conses[cons_block_index]);
XSETCONS (val, &cons_block->conses[cons_block_index]);
cons_block_index++;
}
@@ -2881,9 +3036,8 @@ enum { VECTOR_BLOCK_SIZE = 4096 };
/* Vector size requests are a multiple of this. */
enum { roundup_size = COMMON_MULTIPLE (LISP_ALIGNMENT, word_size) };
-/* Verify assumptions described above. */
+/* Verify assumption described above. */
verify (VECTOR_BLOCK_SIZE % roundup_size == 0);
-verify (VECTOR_BLOCK_SIZE <= (1 << PSEUDOVECTOR_SIZE_BITS));
/* Round up X to nearest mult-of-ROUNDUP_SIZE --- use at compile time. */
#define vroundup_ct(x) ROUNDUP (x, roundup_size)
@@ -2894,6 +3048,11 @@ verify (VECTOR_BLOCK_SIZE <= (1 << PSEUDOVECTOR_SIZE_BITS));
enum {VECTOR_BLOCK_BYTES = VECTOR_BLOCK_SIZE - vroundup_ct (sizeof (void *))};
+/* The current code expects to be able to represent an unused block by
+ a single PVEC_FREE object, whose size is limited by the header word.
+ (Of course we could use multiple such objects.) */
+verify (VECTOR_BLOCK_BYTES <= (word_size << PSEUDOVECTOR_REST_BITS));
+
/* Size of the minimal vector allocated from block. */
enum { VBLOCK_BYTES_MIN = vroundup_ct (header_size + sizeof (Lisp_Object)) };
@@ -2903,10 +3062,10 @@ enum { VBLOCK_BYTES_MIN = vroundup_ct (header_size + sizeof (Lisp_Object)) };
enum { VBLOCK_BYTES_MAX = vroundup_ct ((VECTOR_BLOCK_BYTES / 2) - word_size) };
/* We maintain one free list for each possible block-allocated
- vector size, and this is the number of free lists we have. */
-
-enum { VECTOR_MAX_FREE_LIST_INDEX =
- (VECTOR_BLOCK_BYTES - VBLOCK_BYTES_MIN) / roundup_size + 1 };
+ vector size, one for blocks one word bigger,
+ and one for all free vectors larger than that. */
+enum { VECTOR_FREE_LIST_ARRAY_SIZE =
+ (VBLOCK_BYTES_MAX - VBLOCK_BYTES_MIN) / roundup_size + 1 + 2 };
/* Common shortcut to advance vector pointer over a block data. */
@@ -2968,9 +3127,20 @@ struct vector_block
static struct vector_block *vector_blocks;
/* Vector free lists, where NTH item points to a chain of free
- vectors of the same NBYTES size, so NTH == VINDEX (NBYTES). */
+ vectors of the same NBYTES size, so NTH == VINDEX (NBYTES),
+ except for the last element which may contain larger vectors.
+
+ I.e., for each vector V in vector_free_lists[I] the following holds:
+ - V has type PVEC_FREE
+ - V's total size in bytes, BS(V) = PVSIZE(V) * word_size + header_size
+ - For I < VECTOR_FREE_LIST_ARRAY_SIZE-1, VINDEX(BS(V)) = I
+ - For I = VECTOR_FREE_LIST_ARRAY_SIZE-1, VINDEX(BS(V)) ≥ I */
+static struct Lisp_Vector *vector_free_lists[VECTOR_FREE_LIST_ARRAY_SIZE];
-static struct Lisp_Vector *vector_free_lists[VECTOR_MAX_FREE_LIST_INDEX];
+/* Index to the bucket in vector_free_lists into which we last inserted
+ or split a free vector. We use this as a heuristic telling us where
+ to start looking for free vectors when the exact-size bucket is empty. */
+static ptrdiff_t last_inserted_vector_free_idx = VECTOR_FREE_LIST_ARRAY_SIZE;
/* Singly-linked list of large vectors. */
@@ -2980,6 +3150,19 @@ static struct large_vector *large_vectors;
Lisp_Object zero_vector;
+#if GC_ASAN_POISON_OBJECTS
+# define ASAN_POISON_VECTOR_CONTENTS(v, bytes) \
+ __asan_poison_memory_region ((v)->contents, bytes)
+# define ASAN_UNPOISON_VECTOR_CONTENTS(v, bytes) \
+ __asan_unpoison_memory_region ((v)->contents, bytes)
+# define ASAN_UNPOISON_VECTOR_BLOCK(b) \
+ __asan_unpoison_memory_region ((b)->data, sizeof (b)->data)
+#else
+# define ASAN_POISON_VECTOR_CONTENTS(v, bytes) ((void) 0)
+# define ASAN_UNPOISON_VECTOR_CONTENTS(v, bytes) ((void) 0)
+# define ASAN_UNPOISON_VECTOR_BLOCK(b) ((void) 0)
+#endif
+
/* Common shortcut to setup vector on a free list. */
static void
@@ -2990,9 +3173,12 @@ setup_on_free_list (struct Lisp_Vector *v, ptrdiff_t nbytes)
XSETPVECTYPESIZE (v, PVEC_FREE, 0, nwords);
eassert (nbytes % roundup_size == 0);
ptrdiff_t vindex = VINDEX (nbytes);
- eassert (vindex < VECTOR_MAX_FREE_LIST_INDEX);
+ /* Anything too large goes into the last slot (overflow bin). */
+ vindex = min(vindex, VECTOR_FREE_LIST_ARRAY_SIZE - 1);
set_next_vector (v, vector_free_lists[vindex]);
+ ASAN_POISON_VECTOR_CONTENTS (v, nbytes - header_size);
vector_free_lists[vindex] = v;
+ last_inserted_vector_free_idx = vindex;
}
/* Get a new vector block. */
@@ -3021,6 +3207,17 @@ init_vectors (void)
staticpro (&zero_vector);
}
+/* Memory footprint in bytes of a pseudovector other than a bool-vector. */
+static ptrdiff_t
+pseudovector_nbytes (const union vectorlike_header *hdr)
+{
+ eassert (!PSEUDOVECTOR_TYPEP (hdr, PVEC_BOOL_VECTOR));
+ ptrdiff_t nwords = ((hdr->size & PSEUDOVECTOR_SIZE_MASK)
+ + ((hdr->size & PSEUDOVECTOR_REST_MASK)
+ >> PSEUDOVECTOR_SIZE_BITS));
+ return vroundup (header_size + word_size * nwords);
+}
+
/* Allocate vector from a vector block. */
static struct Lisp_Vector *
@@ -3039,6 +3236,7 @@ allocate_vector_from_block (ptrdiff_t nbytes)
if (vector_free_lists[index])
{
vector = vector_free_lists[index];
+ ASAN_UNPOISON_VECTOR_CONTENTS (vector, nbytes - header_size);
vector_free_lists[index] = next_vector (vector);
return vector;
}
@@ -3046,18 +3244,27 @@ allocate_vector_from_block (ptrdiff_t nbytes)
/* Next, check free lists containing larger vectors. Since
we will split the result, we should have remaining space
large enough to use for one-slot vector at least. */
- for (index = VINDEX (nbytes + VBLOCK_BYTES_MIN);
- index < VECTOR_MAX_FREE_LIST_INDEX; index++)
+ for (index = max (VINDEX (nbytes + VBLOCK_BYTES_MIN),
+ last_inserted_vector_free_idx);
+ index < VECTOR_FREE_LIST_ARRAY_SIZE; index++)
if (vector_free_lists[index])
{
/* This vector is larger than requested. */
vector = vector_free_lists[index];
+ size_t vector_nbytes = pseudovector_nbytes (&vector->header);
+ eassert (vector_nbytes > nbytes);
+ ASAN_UNPOISON_VECTOR_CONTENTS (vector, nbytes - header_size);
vector_free_lists[index] = next_vector (vector);
/* Excess bytes are used for the smaller vector,
which should be set on an appropriate free list. */
- restbytes = index * roundup_size + VBLOCK_BYTES_MIN - nbytes;
+ restbytes = vector_nbytes - nbytes;
eassert (restbytes % roundup_size == 0);
+#if GC_ASAN_POISON_OBJECTS
+ /* Ensure that accessing excess bytes does not trigger ASan. */
+ __asan_unpoison_memory_region (ADVANCE (vector, nbytes),
+ restbytes);
+#endif
setup_on_free_list (ADVANCE (vector, nbytes), restbytes);
return vector;
}
@@ -3105,9 +3312,7 @@ vectorlike_nbytes (const union vectorlike_header *hdr)
nwords = (boolvec_bytes - header_size + word_size - 1) / word_size;
}
else
- nwords = ((size & PSEUDOVECTOR_SIZE_MASK)
- + ((size & PSEUDOVECTOR_REST_MASK)
- >> PSEUDOVECTOR_SIZE_BITS));
+ return pseudovector_nbytes (hdr);
}
else
nwords = size;
@@ -3129,85 +3334,159 @@ vectorlike_nbytes (const union vectorlike_header *hdr)
static void
cleanup_vector (struct Lisp_Vector *vector)
{
- detect_suspicious_free (vector);
-
- if (PSEUDOVECTOR_TYPEP (&vector->header, PVEC_BIGNUM))
- mpz_clear (PSEUDOVEC_STRUCT (vector, Lisp_Bignum)->value);
- else if (PSEUDOVECTOR_TYPEP (&vector->header, PVEC_OVERLAY))
- {
- struct Lisp_Overlay *ol = PSEUDOVEC_STRUCT (vector, Lisp_Overlay);
- xfree (ol->interval);
- }
- else if (PSEUDOVECTOR_TYPEP (&vector->header, PVEC_FINALIZER))
- unchain_finalizer (PSEUDOVEC_STRUCT (vector, Lisp_Finalizer));
- else if (PSEUDOVECTOR_TYPEP (&vector->header, PVEC_FONT))
+ if ((vector->header.size & PSEUDOVECTOR_FLAG) == 0)
+ return; /* nothing more to do for plain vectors */
+ switch (PSEUDOVECTOR_TYPE (vector))
{
- if ((vector->header.size & PSEUDOVECTOR_SIZE_MASK) == FONT_OBJECT_MAX)
- {
- struct font *font = PSEUDOVEC_STRUCT (vector, font);
- struct font_driver const *drv = font->driver;
+ case PVEC_BIGNUM:
+ mpz_clear (PSEUDOVEC_STRUCT (vector, Lisp_Bignum)->value);
+ break;
+ case PVEC_OVERLAY:
+ {
+ struct Lisp_Overlay *ol = PSEUDOVEC_STRUCT (vector, Lisp_Overlay);
+ xfree (ol->interval);
+ }
+ break;
+ case PVEC_FINALIZER:
+ unchain_finalizer (PSEUDOVEC_STRUCT (vector, Lisp_Finalizer));
+ break;
+ case PVEC_FONT:
+ {
+ if ((vector->header.size & PSEUDOVECTOR_SIZE_MASK) == FONT_OBJECT_MAX)
+ {
+ struct font *font = PSEUDOVEC_STRUCT (vector, font);
+ struct font_driver const *drv = font->driver;
- /* The font driver might sometimes be NULL, e.g. if Emacs was
- interrupted before it had time to set it up. */
- if (drv)
- {
- /* Attempt to catch subtle bugs like Bug#16140. */
- eassert (valid_font_driver (drv));
- drv->close_font (font);
- }
- }
- }
- else if (PSEUDOVECTOR_TYPEP (&vector->header, PVEC_THREAD))
- finalize_one_thread (PSEUDOVEC_STRUCT (vector, thread_state));
- else if (PSEUDOVECTOR_TYPEP (&vector->header, PVEC_MUTEX))
- finalize_one_mutex (PSEUDOVEC_STRUCT (vector, Lisp_Mutex));
- else if (PSEUDOVECTOR_TYPEP (&vector->header, PVEC_CONDVAR))
- finalize_one_condvar (PSEUDOVEC_STRUCT (vector, Lisp_CondVar));
- else if (PSEUDOVECTOR_TYPEP (&vector->header, PVEC_MARKER))
- {
+ /* The font driver might sometimes be NULL, e.g. if Emacs was
+ interrupted before it had time to set it up. */
+ if (drv)
+ {
+ /* Attempt to catch subtle bugs like Bug#16140. */
+ eassert (valid_font_driver (drv));
+ drv->close_font (font);
+ }
+ }
+
+#if defined HAVE_ANDROID && !defined ANDROID_STUBIFY
+ /* The Android font driver needs the ability to associate extra
+ information with font entities. */
+ if (((vector->header.size & PSEUDOVECTOR_SIZE_MASK)
+ == FONT_ENTITY_MAX)
+ && PSEUDOVEC_STRUCT (vector, font_entity)->is_android)
+ android_finalize_font_entity (PSEUDOVEC_STRUCT (vector, font_entity));
+#endif
+ }
+ break;
+ case PVEC_THREAD:
+ finalize_one_thread (PSEUDOVEC_STRUCT (vector, thread_state));
+ break;
+ case PVEC_MUTEX:
+ finalize_one_mutex (PSEUDOVEC_STRUCT (vector, Lisp_Mutex));
+ break;
+ case PVEC_CONDVAR:
+ finalize_one_condvar (PSEUDOVEC_STRUCT (vector, Lisp_CondVar));
+ break;
+ case PVEC_MARKER:
/* sweep_buffer should already have unchained this from its buffer. */
eassert (! PSEUDOVEC_STRUCT (vector, Lisp_Marker)->buffer);
- }
- else if (PSEUDOVECTOR_TYPEP (&vector->header, PVEC_USER_PTR))
- {
- struct Lisp_User_Ptr *uptr = PSEUDOVEC_STRUCT (vector, Lisp_User_Ptr);
- if (uptr->finalizer)
- uptr->finalizer (uptr->p);
- }
+ break;
+ case PVEC_USER_PTR:
+ {
+ struct Lisp_User_Ptr *uptr = PSEUDOVEC_STRUCT (vector, Lisp_User_Ptr);
+ if (uptr->finalizer)
+ uptr->finalizer (uptr->p);
+ }
+ break;
+ case PVEC_TS_PARSER:
+#ifdef HAVE_TREE_SITTER
+ treesit_delete_parser (PSEUDOVEC_STRUCT (vector, Lisp_TS_Parser));
+#endif
+ break;
+ case PVEC_TS_COMPILED_QUERY:
#ifdef HAVE_TREE_SITTER
- else if (PSEUDOVECTOR_TYPEP (&vector->header, PVEC_TS_PARSER))
- treesit_delete_parser (PSEUDOVEC_STRUCT (vector, Lisp_TS_Parser));
- else if (PSEUDOVECTOR_TYPEP (&vector->header, PVEC_TS_COMPILED_QUERY))
- treesit_delete_query (PSEUDOVEC_STRUCT (vector, Lisp_TS_Query));
+ treesit_delete_query (PSEUDOVEC_STRUCT (vector, Lisp_TS_Query));
#endif
+ break;
+ case PVEC_MODULE_FUNCTION:
#ifdef HAVE_MODULES
- else if (PSEUDOVECTOR_TYPEP (&vector->header, PVEC_MODULE_FUNCTION))
- {
- ATTRIBUTE_MAY_ALIAS struct Lisp_Module_Function *function
- = (struct Lisp_Module_Function *) vector;
- module_finalize_function (function);
- }
+ {
+ ATTRIBUTE_MAY_ALIAS struct Lisp_Module_Function *function
+ = (struct Lisp_Module_Function *) vector;
+ module_finalize_function (function);
+ }
#endif
+ break;
+ case PVEC_NATIVE_COMP_UNIT:
#ifdef HAVE_NATIVE_COMP
- else if (PSEUDOVECTOR_TYPEP (&vector->header, PVEC_NATIVE_COMP_UNIT))
- {
- struct Lisp_Native_Comp_Unit *cu =
- PSEUDOVEC_STRUCT (vector, Lisp_Native_Comp_Unit);
- unload_comp_unit (cu);
- }
- else if (PSEUDOVECTOR_TYPEP (&vector->header, PVEC_SUBR))
- {
- struct Lisp_Subr *subr =
- PSEUDOVEC_STRUCT (vector, Lisp_Subr);
- if (!NILP (subr->native_comp_u))
- {
- /* FIXME Alternative and non invasive solution to this
- cast? */
- xfree ((char *)subr->symbol_name);
- xfree (subr->native_c_name);
- }
- }
+ {
+ struct Lisp_Native_Comp_Unit *cu =
+ PSEUDOVEC_STRUCT (vector, Lisp_Native_Comp_Unit);
+ unload_comp_unit (cu);
+ }
+#endif
+ break;
+ case PVEC_SUBR:
+#ifdef HAVE_NATIVE_COMP
+ {
+ struct Lisp_Subr *subr = PSEUDOVEC_STRUCT (vector, Lisp_Subr);
+ if (!NILP (subr->native_comp_u))
+ {
+ /* FIXME Alternative and non invasive solution to this cast? */
+ xfree ((char *)subr->symbol_name);
+ xfree (subr->native_c_name);
+ }
+ }
#endif
+ break;
+ case PVEC_HASH_TABLE:
+ {
+ struct Lisp_Hash_Table *h = PSEUDOVEC_STRUCT (vector, Lisp_Hash_Table);
+ if (h->table_size > 0)
+ {
+ eassert (h->index_bits > 0);
+ xfree (h->index);
+ xfree (h->key_and_value);
+ xfree (h->next);
+ xfree (h->hash);
+ ptrdiff_t bytes = (h->table_size * (2 * sizeof *h->key_and_value
+ + sizeof *h->hash
+ + sizeof *h->next)
+ + hash_table_index_size (h) * sizeof *h->index);
+ hash_table_allocated_bytes -= bytes;
+ }
+ }
+ break;
+ case PVEC_OBARRAY:
+ {
+ struct Lisp_Obarray *o = PSEUDOVEC_STRUCT (vector, Lisp_Obarray);
+ xfree (o->buckets);
+ ptrdiff_t bytes = obarray_size (o) * sizeof *o->buckets;
+ hash_table_allocated_bytes -= bytes;
+ }
+ break;
+ /* Keep the switch exhaustive. */
+ case PVEC_NORMAL_VECTOR:
+ case PVEC_FREE:
+ case PVEC_SYMBOL_WITH_POS:
+ case PVEC_MISC_PTR:
+ case PVEC_PROCESS:
+ case PVEC_FRAME:
+ case PVEC_WINDOW:
+ case PVEC_BOOL_VECTOR:
+ case PVEC_BUFFER:
+ case PVEC_TERMINAL:
+ case PVEC_WINDOW_CONFIGURATION:
+ case PVEC_OTHER:
+ case PVEC_XWIDGET:
+ case PVEC_XWIDGET_VIEW:
+ case PVEC_TS_NODE:
+ case PVEC_SQLITE:
+ case PVEC_COMPILED:
+ case PVEC_CHAR_TABLE:
+ case PVEC_SUB_CHAR_TABLE:
+ case PVEC_RECORD:
+ break;
+ }
}
/* Reclaim space used by unmarked vectors. */
@@ -3223,6 +3502,7 @@ sweep_vectors (void)
gcstat.total_vectors = 0;
gcstat.total_vector_slots = gcstat.total_free_vector_slots = 0;
memset (vector_free_lists, 0, sizeof (vector_free_lists));
+ last_inserted_vector_free_idx = VECTOR_FREE_LIST_ARRAY_SIZE;
/* Looking through vector blocks. */
@@ -3233,6 +3513,7 @@ sweep_vectors (void)
for (vector = (struct Lisp_Vector *) block->data;
VECTOR_IN_BLOCK (vector, block); vector = next)
{
+ ASAN_UNPOISON_VECTOR_BLOCK (block);
if (XVECTOR_MARKED_P (vector))
{
XUNMARK_VECTOR (vector);
@@ -3306,6 +3587,8 @@ sweep_vectors (void)
lisp_free (lv);
}
}
+
+ gcstat.total_hash_table_bytes = hash_table_allocated_bytes;
}
/* Maximum number of elements in a vector. This is a macro so that it
@@ -3355,9 +3638,6 @@ allocate_vectorlike (ptrdiff_t len, bool clearit)
mallopt (M_MMAP_MAX, MMAP_MAX_AREAS);
#endif
- if (find_suspicious_object_in_range (p, (char *) p + nbytes))
- emacs_abort ();
-
tally_consing (nbytes);
vector_cells_consed += len;
@@ -3409,7 +3689,7 @@ allocate_pseudovector (int memlen, int lisplen,
enum { size_max = (1 << PSEUDOVECTOR_SIZE_BITS) - 1 };
enum { rest_max = (1 << PSEUDOVECTOR_REST_BITS) - 1 };
verify (size_max + rest_max <= VECTOR_ELTS_MAX);
- eassert (0 <= tag && tag <= PVEC_FONT);
+ eassert (0 <= tag && tag <= PVEC_TAG_MAX);
eassert (0 <= lisplen && lisplen <= zerolen && zerolen <= memlen);
eassert (lisplen <= size_max);
eassert (memlen <= size_max + rest_max);
@@ -3609,6 +3889,23 @@ struct symbol_block
struct symbol_block *next;
};
+#if GC_ASAN_POISON_OBJECTS
+# define ASAN_POISON_SYMBOL_BLOCK(s) \
+ __asan_poison_memory_region ((s)->symbols, sizeof ((s)->symbols))
+# define ASAN_UNPOISON_SYMBOL_BLOCK(s) \
+ __asan_unpoison_memory_region ((s)->symbols, sizeof ((s)->symbols))
+# define ASAN_POISON_SYMBOL(sym) \
+ __asan_poison_memory_region (sym, sizeof *(sym))
+# define ASAN_UNPOISON_SYMBOL(sym) \
+ __asan_unpoison_memory_region (sym, sizeof *(sym))
+
+#else
+# define ASAN_POISON_SYMBOL_BLOCK(s) ((void) 0)
+# define ASAN_UNPOISON_SYMBOL_BLOCK(s) ((void) 0)
+# define ASAN_POISON_SYMBOL(sym) ((void) 0)
+# define ASAN_UNPOISON_SYMBOL(sym) ((void) 0)
+#endif
+
/* Current symbol block and index of first unused Lisp_Symbol
structure in it. */
@@ -3662,6 +3959,7 @@ Its value is void, and its function definition and property list are nil. */)
if (symbol_free_list)
{
+ ASAN_UNPOISON_SYMBOL (symbol_free_list);
XSETSYMBOL (val, symbol_free_list);
symbol_free_list = symbol_free_list->u.s.next;
}
@@ -3671,10 +3969,13 @@ Its value is void, and its function definition and property list are nil. */)
{
struct symbol_block *new
= lisp_malloc (sizeof *new, false, MEM_TYPE_SYMBOL);
+ ASAN_POISON_SYMBOL_BLOCK (new);
new->next = symbol_block;
symbol_block = new;
symbol_block_index = 0;
}
+
+ ASAN_UNPOISON_SYMBOL (&symbol_block->symbols[symbol_block_index]);
XSETSYMBOL (val, &symbol_block->symbols[symbol_block_index]);
symbol_block_index++;
}
@@ -4562,6 +4863,11 @@ static struct Lisp_String *
live_string_holding (struct mem_node *m, void *p)
{
eassert (m->type == MEM_TYPE_STRING);
+#if GC_ASAN_POISON_OBJECTS
+ if (__asan_address_is_poisoned (p))
+ return NULL;
+#endif
+
struct string_block *b = m->start;
char *cp = p;
ptrdiff_t offset = cp - (char *) &b->strings[0];
@@ -4578,6 +4884,10 @@ live_string_holding (struct mem_node *m, void *p)
|| off == offsetof (struct Lisp_String, u.s.data))
{
struct Lisp_String *s = p = cp -= off;
+#if GC_ASAN_POISON_OBJECTS
+ if (__asan_region_is_poisoned (s, sizeof (*s)))
+ return NULL;
+#endif
if (s->u.s.data)
return s;
}
@@ -4599,6 +4909,11 @@ static struct Lisp_Cons *
live_cons_holding (struct mem_node *m, void *p)
{
eassert (m->type == MEM_TYPE_CONS);
+#if GC_ASAN_POISON_OBJECTS
+ if (__asan_address_is_poisoned (p))
+ return NULL;
+#endif
+
struct cons_block *b = m->start;
char *cp = p;
ptrdiff_t offset = cp - (char *) &b->conses[0];
@@ -4616,6 +4931,10 @@ live_cons_holding (struct mem_node *m, void *p)
|| off == offsetof (struct Lisp_Cons, u.s.u.cdr))
{
struct Lisp_Cons *s = p = cp -= off;
+#if GC_ASAN_POISON_OBJECTS
+ if (__asan_region_is_poisoned (s, sizeof (*s)))
+ return NULL;
+#endif
if (!deadp (s->u.s.car))
return s;
}
@@ -4638,6 +4957,10 @@ static struct Lisp_Symbol *
live_symbol_holding (struct mem_node *m, void *p)
{
eassert (m->type == MEM_TYPE_SYMBOL);
+#if GC_ASAN_POISON_OBJECTS
+ if (__asan_address_is_poisoned (p))
+ return NULL;
+#endif
struct symbol_block *b = m->start;
char *cp = p;
ptrdiff_t offset = cp - (char *) &b->symbols[0];
@@ -4663,6 +4986,10 @@ live_symbol_holding (struct mem_node *m, void *p)
|| off == offsetof (struct Lisp_Symbol, u.s.next))
{
struct Lisp_Symbol *s = p = cp -= off;
+#if GC_ASAN_POISON_OBJECTS
+ if (__asan_region_is_poisoned (s, sizeof (*s)))
+ return NULL;
+#endif
if (!deadp (s->u.s.function))
return s;
}
@@ -4685,6 +5012,11 @@ static struct Lisp_Float *
live_float_holding (struct mem_node *m, void *p)
{
eassert (m->type == MEM_TYPE_FLOAT);
+#if GC_ASAN_POISON_OBJECTS
+ if (__asan_address_is_poisoned (p))
+ return NULL;
+#endif
+
struct float_block *b = m->start;
char *cp = p;
ptrdiff_t offset = cp - (char *) &b->floats[0];
@@ -4699,8 +5031,12 @@ live_float_holding (struct mem_node *m, void *p)
&& (b != float_block
|| offset / sizeof b->floats[0] < float_block_index))
{
- p = cp - off;
- return p;
+ struct Lisp_Float *f = (struct Lisp_Float *) (cp - off);
+#if GC_ASAN_POISON_OBJECTS
+ if (__asan_region_is_poisoned (f, sizeof (*f)))
+ return NULL;
+#endif
+ return f;
}
}
return NULL;
@@ -4979,7 +5315,7 @@ mark_memory (void const *start, void const *end)
a Lisp_Object might be split into registers saved into
non-adjacent words and P might be the low-order word's value. */
intptr_t ip;
- INT_ADD_WRAPV ((intptr_t) p, (intptr_t) lispsym, &ip);
+ ckd_add (&ip, (intptr_t) p, (intptr_t) lispsym);
mark_maybe_pointer ((void *) ip, true);
}
}
@@ -5091,15 +5427,6 @@ typedef union
#endif
} stacktop_sentry;
-/* Yield an address close enough to the top of the stack that the
- garbage collector need not scan above it. Callers should be
- declared NO_INLINE. */
-#ifdef HAVE___BUILTIN_FRAME_ADDRESS
-# define NEAR_STACK_TOP(addr) ((void) (addr), __builtin_frame_address (0))
-#else
-# define NEAR_STACK_TOP(addr) (addr)
-#endif
-
/* Set *P to the address of the top of the stack. This must be a
macro, not a function, so that it is executed in the caller's
environment. It is not inside a do-while so that its storage
@@ -5314,6 +5641,29 @@ valid_lisp_object_p (Lisp_Object obj)
return 0;
}
+/* Like xmalloc, but makes allocation count toward the total consing
+ and hash table or obarray usage.
+ Return NULL for a zero-sized allocation. */
+void *
+hash_table_alloc_bytes (ptrdiff_t nbytes)
+{
+ if (nbytes == 0)
+ return NULL;
+ tally_consing (nbytes);
+ hash_table_allocated_bytes += nbytes;
+ return xmalloc (nbytes);
+}
+
+/* Like xfree, but makes allocation count toward the total consing. */
+void
+hash_table_free_bytes (void *p, ptrdiff_t nbytes)
+{
+ tally_consing (-nbytes);
+ hash_table_allocated_bytes -= nbytes;
+ xfree (p);
+}
+
+
/***********************************************************************
Pure Storage Management
***********************************************************************/
@@ -5407,6 +5757,22 @@ find_string_data_in_pure (const char *data, ptrdiff_t nbytes)
if (pure_bytes_used_non_lisp <= nbytes)
return NULL;
+ /* The Android GCC generates code like:
+
+ 0xa539e755 <+52>: lea 0x430(%esp),%esi
+=> 0xa539e75c <+59>: movdqa %xmm0,0x0(%ebp)
+ 0xa539e761 <+64>: add $0x10,%ebp
+
+ but data is not aligned appropriately, so a GP fault results. */
+
+#if defined __i386__ \
+ && defined HAVE_ANDROID \
+ && !defined ANDROID_STUBIFY \
+ && !defined (__clang__)
+ if ((intptr_t) data & 15)
+ return NULL;
+#endif
+
/* Set up the Boyer-Moore table. */
skip = nbytes + 1;
for (i = 0; i < 256; i++)
@@ -5579,30 +5945,35 @@ make_pure_vector (ptrdiff_t len)
static struct Lisp_Hash_Table *
purecopy_hash_table (struct Lisp_Hash_Table *table)
{
- eassert (NILP (table->weak));
+ eassert (table->weakness == Weak_None);
eassert (table->purecopy);
struct Lisp_Hash_Table *pure = pure_alloc (sizeof *pure, Lisp_Vectorlike);
- struct hash_table_test pure_test = table->test;
-
- /* Purecopy the hash table test. */
- pure_test.name = purecopy (table->test.name);
- pure_test.user_hash_function = purecopy (table->test.user_hash_function);
- pure_test.user_cmp_function = purecopy (table->test.user_cmp_function);
-
- pure->header = table->header;
- pure->weak = purecopy (Qnil);
- pure->hash = purecopy (table->hash);
- pure->next = purecopy (table->next);
- pure->index = purecopy (table->index);
- pure->count = table->count;
- pure->next_free = table->next_free;
- pure->purecopy = table->purecopy;
- eassert (!pure->mutable);
- pure->rehash_threshold = table->rehash_threshold;
- pure->rehash_size = table->rehash_size;
- pure->key_and_value = purecopy (table->key_and_value);
- pure->test = pure_test;
+ *pure = *table;
+ pure->mutable = false;
+
+ if (table->table_size > 0)
+ {
+ ptrdiff_t hash_bytes = table->table_size * sizeof *table->hash;
+ pure->hash = pure_alloc (hash_bytes, -(int)sizeof *table->hash);
+ memcpy (pure->hash, table->hash, hash_bytes);
+
+ ptrdiff_t next_bytes = table->table_size * sizeof *table->next;
+ pure->next = pure_alloc (next_bytes, -(int)sizeof *table->next);
+ memcpy (pure->next, table->next, next_bytes);
+
+ ptrdiff_t nvalues = table->table_size * 2;
+ ptrdiff_t kv_bytes = nvalues * sizeof *table->key_and_value;
+ pure->key_and_value = pure_alloc (kv_bytes,
+ -(int)sizeof *table->key_and_value);
+ for (ptrdiff_t i = 0; i < nvalues; i++)
+ pure->key_and_value[i] = purecopy (table->key_and_value[i]);
+
+ ptrdiff_t index_bytes = hash_table_index_size (table)
+ * sizeof *table->index;
+ pure->index = pure_alloc (index_bytes, -(int)sizeof *table->index);
+ memcpy (pure->index, table->index, index_bytes);
+ }
return pure;
}
@@ -5662,7 +6033,7 @@ purecopy (Lisp_Object obj)
/* Do not purify hash tables which haven't been defined with
:purecopy as non-nil or are weak - they aren't guaranteed to
not change. */
- if (!NILP (table->weak) || !table->purecopy)
+ if (table->weakness != Weak_None || !table->purecopy)
{
/* Instead, add the hash table to the list of pinned objects,
so that it will be marked during GC. */
@@ -5673,8 +6044,7 @@ purecopy (Lisp_Object obj)
return obj; /* Don't hash cons it. */
}
- struct Lisp_Hash_Table *h = purecopy_hash_table (table);
- XSET_HASH_TABLE (obj, h);
+ obj = make_lisp_hash_table (purecopy_hash_table (table));
}
else if (COMPILEDP (obj) || VECTORP (obj) || RECORDP (obj))
{
@@ -5786,6 +6156,7 @@ total_bytes_of_live_objects (void)
tot += object_bytes (gcstat.total_floats, sizeof (struct Lisp_Float));
tot += object_bytes (gcstat.total_intervals, sizeof (struct interval));
tot += object_bytes (gcstat.total_strings, sizeof (struct Lisp_String));
+ tot += gcstat.total_hash_table_bytes;
return tot;
}
@@ -5917,16 +6288,44 @@ mark_pinned_objects (void)
mark_object (pobj->object);
}
+#if defined HAVE_ANDROID && !defined (__clang__)
+
+/* The Android gcc is broken and needs the following version of
+ make_lisp_symbol. Otherwise a mysterious ICE pops up. */
+
+#define make_lisp_symbol android_make_lisp_symbol
+
+static Lisp_Object
+android_make_lisp_symbol (struct Lisp_Symbol *sym)
+{
+ intptr_t symoffset;
+
+ symoffset = (intptr_t) sym;
+ ckd_sub (&symoffset, symoffset, (intptr_t) &lispsym);
+
+ {
+ Lisp_Object a = TAG_PTR_INITIALLY (Lisp_Symbol, symoffset);
+ return a;
+ }
+}
+
+#endif
+
static void
mark_pinned_symbols (void)
{
struct symbol_block *sblk;
- int lim = (symbol_block_pinned == symbol_block
- ? symbol_block_index : SYMBOL_BLOCK_SIZE);
+ int lim;
+ struct Lisp_Symbol *sym, *end;
+
+ if (symbol_block_pinned == symbol_block)
+ lim = symbol_block_index;
+ else
+ lim = SYMBOL_BLOCK_SIZE;
for (sblk = symbol_block_pinned; sblk; sblk = sblk->next)
{
- struct Lisp_Symbol *sym = sblk->symbols, *end = sym + lim;
+ sym = sblk->symbols, end = sym + lim;
for (; sym < end; ++sym)
if (sym->u.s.pinned)
mark_object (make_lisp_symbol (sym));
@@ -6204,6 +6603,9 @@ garbage_collect (void)
mark_terminals ();
mark_kboards ();
mark_threads ();
+ mark_charset ();
+ mark_composite ();
+ mark_profiler ();
#ifdef HAVE_PGTK
mark_pgtkterm ();
#endif
@@ -6222,15 +6624,24 @@ garbage_collect (void)
#ifdef HAVE_X_WINDOWS
mark_xterm ();
+ mark_xselect ();
+#endif
+
+#ifdef HAVE_ANDROID
+ mark_androidterm ();
+#ifndef ANDROID_STUBIFY
+ mark_sfntfont ();
+#endif
#endif
#ifdef HAVE_NS
mark_nsterm ();
#endif
+ mark_fns ();
/* 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. */
+ removing any items which aren't reachable otherwise. */
compact_font_caches ();
@@ -6291,13 +6702,6 @@ garbage_collect (void)
image_prune_animation_caches (false);
#endif
- if (!NILP (Vpost_gc_hook))
- {
- specpdl_ref gc_count = inhibit_garbage_collection ();
- safe_run_hooks (Qpost_gc_hook);
- unbind_to (gc_count, Qnil);
- }
-
/* Accumulate statistics. */
if (FLOATP (Vgc_elapsed))
{
@@ -6316,6 +6720,13 @@ garbage_collect (void)
if (tot_after < tot_before)
malloc_probe (min (tot_before - tot_after, SIZE_MAX));
}
+
+ if (!NILP (Vpost_gc_hook))
+ {
+ specpdl_ref gc_count = inhibit_garbage_collection ();
+ safe_run_hooks (Qpost_gc_hook);
+ unbind_to (gc_count, Qnil);
+ }
}
DEFUN ("garbage-collect", Fgarbage_collect, Sgarbage_collect, 0, 0, "",
@@ -6555,7 +6966,7 @@ mark_buffer (struct buffer *buffer)
if (!BUFFER_LIVE_P (buffer))
mark_object (BVAR (buffer, undo_list));
- if (buffer->overlays)
+ if (!itree_empty_p (buffer->overlays))
mark_overlays (buffer->overlays->root);
/* If this is an indirect buffer, mark its base buffer. */
@@ -6587,20 +6998,6 @@ mark_face_cache (struct face_cache *c)
}
}
-NO_INLINE /* To reduce stack depth in mark_object. */
-static void
-mark_localized_symbol (struct Lisp_Symbol *ptr)
-{
- struct Lisp_Buffer_Local_Value *blv = SYMBOL_BLV (ptr);
- Lisp_Object where = blv->where;
- /* If the value is set up for a killed buffer restore its global binding. */
- if ((BUFFERP (where) && !BUFFER_LIVE_P (XBUFFER (where))))
- swap_in_global_binding (ptr);
- mark_object (blv->where);
- mark_object (blv->valcell);
- mark_object (blv->defcell);
-}
-
/* Remove killed buffers or items whose car is a killed buffer from
LIST, and mark other items. Return changed LIST, which is marked. */
@@ -6632,6 +7029,11 @@ static void
mark_frame (struct Lisp_Vector *ptr)
{
struct frame *f = (struct frame *) ptr;
+#ifdef HAVE_TEXT_CONVERSION
+ struct text_conversion_action *tem;
+#endif
+
+
mark_vectorlike (&ptr->header);
mark_face_cache (f->face_cache);
#ifdef HAVE_WINDOW_SYSTEM
@@ -6643,6 +7045,15 @@ mark_frame (struct Lisp_Vector *ptr)
mark_vectorlike (&font->header);
}
#endif
+
+#ifdef HAVE_TEXT_CONVERSION
+ mark_object (f->conversion.compose_region_start);
+ mark_object (f->conversion.compose_region_end);
+ mark_object (f->conversion.compose_region_overlay);
+
+ for (tem = f->conversion.actions; tem; tem = tem->next)
+ mark_object (tem->data);
+#endif
}
static void
@@ -6891,26 +7302,32 @@ process_mark_stack (ptrdiff_t base_sp)
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);
+ if (h->weakness == Weak_None)
+ /* The values pushed here may include
+ HASH_UNUSED_ENTRY_KEY, which this function must
+ cope with. */
+ mark_stack_push_values (h->key_and_value,
+ 2 * h->table_size);
else
{
- /* For weak tables, mark only the vector and not its
+ /* For weak tables, don't mark the
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_OBARRAY:
+ {
+ struct Lisp_Obarray *o = (struct Lisp_Obarray *)ptr;
+ set_vector_marked (ptr);
+ mark_stack_push_values (o->buckets, obarray_size (o));
+ break;
+ }
+
case PVEC_CHAR_TABLE:
case PVEC_SUB_CHAR_TABLE:
mark_char_table (ptr, (enum pvec_type) pvectype);
@@ -6988,7 +7405,17 @@ process_mark_stack (ptrdiff_t base_sp)
break;
}
case SYMBOL_LOCALIZED:
- mark_localized_symbol (ptr);
+ {
+ struct Lisp_Buffer_Local_Value *blv = SYMBOL_BLV (ptr);
+ Lisp_Object where = blv->where;
+ /* If the value is set up for a killed buffer,
+ restore its global binding. */
+ if (BUFFERP (where) && !BUFFER_LIVE_P (XBUFFER (where)))
+ swap_in_global_binding (ptr);
+ mark_stack_push_value (blv->where);
+ mark_stack_push_value (blv->valcell);
+ mark_stack_push_value (blv->defcell);
+ }
break;
case SYMBOL_FORWARDED:
/* If the value is forwarded to a buffer or keyboard field,
@@ -7032,14 +7459,19 @@ process_mark_stack (ptrdiff_t base_sp)
}
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;
+ {
+ struct Lisp_Float *f = XFLOAT (obj);
+ if (!f)
+ break; /* for HASH_UNUSED_ENTRY_KEY */
+ 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 (f))
+ eassert (pdumper_cold_object_p (f));
+ else if (!XFLOAT_MARKED_P (f))
+ XFLOAT_MARK (f);
+ break;
+ }
case_Lisp_Int:
break;
@@ -7181,11 +7613,13 @@ sweep_conses (void)
struct Lisp_Cons *acons = &cblk->conses[pos];
if (!XCONS_MARKED_P (acons))
{
+ ASAN_UNPOISON_CONS (&cblk->conses[pos]);
this_free++;
cblk->conses[pos].u.s.u.chain = cons_free_list;
cons_free_list = &cblk->conses[pos];
cons_free_list->u.s.car = dead_object ();
- }
+ ASAN_POISON_CONS (&cblk->conses[pos]);
+ }
else
{
num_used++;
@@ -7203,6 +7637,7 @@ sweep_conses (void)
{
*cprev = cblk->next;
/* Unhook from the free list. */
+ ASAN_UNPOISON_CONS (&cblk->conses[0]);
cons_free_list = cblk->conses[0].u.s.u.chain;
lisp_align_free (cblk);
}
@@ -7229,6 +7664,7 @@ sweep_floats (void)
for (struct float_block *fblk; (fblk = *fprev); )
{
int this_free = 0;
+ ASAN_UNPOISON_FLOAT_BLOCK (fblk);
for (int i = 0; i < lim; i++)
{
struct Lisp_Float *afloat = &fblk->floats[i];
@@ -7236,6 +7672,7 @@ sweep_floats (void)
{
this_free++;
fblk->floats[i].u.chain = float_free_list;
+ ASAN_POISON_FLOAT (&fblk->floats[i]);
float_free_list = &fblk->floats[i];
}
else
@@ -7252,7 +7689,8 @@ sweep_floats (void)
{
*fprev = fblk->next;
/* Unhook from the free list. */
- float_free_list = fblk->floats[0].u.chain;
+ ASAN_UNPOISON_FLOAT (&fblk->floats[0]);
+ float_free_list = fblk->floats[0].u.chain;
lisp_align_free (fblk);
}
else
@@ -7278,13 +7716,14 @@ sweep_intervals (void)
for (struct interval_block *iblk; (iblk = *iprev); )
{
int this_free = 0;
-
+ ASAN_UNPOISON_INTERVAL_BLOCK (iblk);
for (int i = 0; i < lim; i++)
{
if (!iblk->intervals[i].gcmarkbit)
{
set_interval_parent (&iblk->intervals[i], interval_free_list);
interval_free_list = &iblk->intervals[i];
+ ASAN_POISON_INTERVAL (&iblk->intervals[i]);
this_free++;
}
else
@@ -7301,6 +7740,7 @@ sweep_intervals (void)
{
*iprev = iblk->next;
/* Unhook from the free list. */
+ ASAN_UNPOISON_INTERVAL (&iblk->intervals[0]);
interval_free_list = INTERVAL_PARENT (&iblk->intervals[0]);
lisp_free (iblk);
}
@@ -7330,6 +7770,8 @@ sweep_symbols (void)
for (sblk = symbol_block; sblk; sblk = *sprev)
{
+ ASAN_UNPOISON_SYMBOL_BLOCK (sblk);
+
int this_free = 0;
struct Lisp_Symbol *sym = sblk->symbols;
struct Lisp_Symbol *end = sym + lim;
@@ -7351,7 +7793,8 @@ sweep_symbols (void)
sym->u.s.next = symbol_free_list;
symbol_free_list = sym;
symbol_free_list->u.s.function = dead_object ();
- ++this_free;
+ ASAN_POISON_SYMBOL (sym);
+ ++this_free;
}
else
{
@@ -7370,6 +7813,7 @@ sweep_symbols (void)
{
*sprev = sblk->next;
/* Unhook from the free list. */
+ ASAN_UNPOISON_SYMBOL (&sblk->symbols[0]);
symbol_free_list = sblk->symbols[0].u.s.next;
lisp_free (sblk);
}
@@ -7623,78 +8067,6 @@ which_symbols (Lisp_Object obj, EMACS_INT find_max)
return unbind_to (gc_count, found);
}
-#ifdef SUSPICIOUS_OBJECT_CHECKING
-
-static void *
-find_suspicious_object_in_range (void *begin, void *end)
-{
- char *begin_a = begin;
- char *end_a = end;
- int i;
-
- for (i = 0; i < ARRAYELTS (suspicious_objects); ++i)
- {
- char *suspicious_object = suspicious_objects[i];
- if (begin_a <= suspicious_object && suspicious_object < end_a)
- return suspicious_object;
- }
-
- return NULL;
-}
-
-static void
-note_suspicious_free (void *ptr)
-{
- struct suspicious_free_record *rec;
-
- rec = &suspicious_free_history[suspicious_free_history_index++];
- if (suspicious_free_history_index ==
- ARRAYELTS (suspicious_free_history))
- {
- suspicious_free_history_index = 0;
- }
-
- memset (rec, 0, sizeof (*rec));
- rec->suspicious_object = ptr;
- backtrace (&rec->backtrace[0], ARRAYELTS (rec->backtrace));
-}
-
-static void
-detect_suspicious_free (void *ptr)
-{
- int i;
-
- eassert (ptr != NULL);
-
- for (i = 0; i < ARRAYELTS (suspicious_objects); ++i)
- if (suspicious_objects[i] == ptr)
- {
- note_suspicious_free (ptr);
- suspicious_objects[i] = NULL;
- }
-}
-
-#endif /* SUSPICIOUS_OBJECT_CHECKING */
-
-DEFUN ("suspicious-object", Fsuspicious_object, Ssuspicious_object, 1, 1, 0,
- doc: /* Return OBJ, maybe marking it for extra scrutiny.
-If Emacs is compiled with suspicious object checking, capture
-a stack trace when OBJ is freed in order to help track down
-garbage collection bugs. Otherwise, do nothing and return OBJ. */)
- (Lisp_Object obj)
-{
-#ifdef SUSPICIOUS_OBJECT_CHECKING
- /* Right now, we care only about vectors. */
- if (VECTORLIKEP (obj))
- {
- suspicious_objects[suspicious_object_index++] = XVECTOR (obj);
- if (suspicious_object_index == ARRAYELTS (suspicious_objects))
- suspicious_object_index = 0;
- }
-#endif
- return obj;
-}
-
#ifdef ENABLE_CHECKING
bool suppress_checking;
@@ -7926,7 +8298,6 @@ N should be nonnegative. */);
#ifdef HAVE_MALLOC_TRIM
defsubr (&Smalloc_trim);
#endif
- defsubr (&Ssuspicious_object);
Lisp_Object watcher;
diff --git a/src/android-asset.h b/src/android-asset.h
new file mode 100644
index 00000000000..a6b5aa3366c
--- /dev/null
+++ b/src/android-asset.h
@@ -0,0 +1,430 @@
+/* Android initialization for GNU Emacs.
+
+Copyright (C) 2023-2024 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 <https://www.gnu.org/licenses/>. */
+
+#include <android/log.h>
+
+/* This file contains an emulation of the Android asset manager API
+ used on builds for Android 2.2. It is included by android.c
+ whenever appropriate.
+
+ The replacements in this file are not thread safe and must only be
+ called from the creating thread. */
+
+struct android_asset_manager
+{
+ /* JNI environment. */
+ JNIEnv *env;
+
+ /* Asset manager class and functions. */
+ jclass class;
+ jmethodID open_fd;
+
+ /* Asset file descriptor class and functions. */
+ jclass fd_class;
+ jmethodID get_length;
+ jmethodID create_input_stream;
+ jmethodID close;
+
+ /* Input stream class and functions. */
+ jclass input_stream_class;
+ jmethodID read;
+ jmethodID stream_close;
+
+ /* Associated asset manager object. */
+ jobject asset_manager;
+};
+
+typedef struct android_asset_manager AAssetManager;
+
+struct android_asset
+{
+ /* The asset manager. */
+ AAssetManager *manager;
+
+ /* The length of the asset, or -1. */
+ jlong length;
+
+ /* The asset file descriptor and input stream. */
+ jobject fd, stream;
+
+ /* The mode. */
+ int mode;
+};
+
+typedef struct android_asset AAsset;
+
+static AAssetManager *
+AAssetManager_fromJava (JNIEnv *env, jobject java_manager)
+{
+ AAssetManager *manager;
+ jclass temp;
+
+ manager = malloc (sizeof *manager);
+
+ if (!manager)
+ return NULL;
+
+ manager->env = env;
+ manager->asset_manager
+ = (*env)->NewGlobalRef (env, java_manager);
+
+ if (!manager->asset_manager)
+ {
+ free (manager);
+ return NULL;
+ }
+
+ manager->class
+ = (*env)->FindClass (env, "android/content/res/AssetManager");
+ assert (manager->class);
+
+ manager->open_fd
+ = (*env)->GetMethodID (env, manager->class, "openFd",
+ "(Ljava/lang/String;)"
+ "Landroid/content/res/AssetFileDescriptor;");
+ assert (manager->open);
+
+ manager->fd_class
+ = (*env)->FindClass (env, "android/content/res/AssetFileDescriptor");
+ assert (manager->fd_class);
+
+ manager->get_length
+ = (*env)->GetMethodID (env, manager->fd_class, "getLength",
+ "()J");
+ assert (manager->get_length);
+
+ manager->create_input_stream
+ = (*env)->GetMethodID (env, manager->fd_class,
+ "createInputStream",
+ "()Ljava/io/FileInputStream;");
+ assert (manager->create_input_stream);
+
+ manager->close
+ = (*env)->GetMethodID (env, manager->fd_class,
+ "close", "()V");
+ assert (manager->close);
+
+ manager->input_stream_class
+ = (*env)->FindClass (env, "java/io/InputStream");
+ assert (manager->input_stream_class);
+
+ manager->read
+ = (*env)->GetMethodID (env, manager->input_stream_class,
+ "read", "([B)I");
+ assert (manager->read);
+
+ manager->stream_close
+ = (*env)->GetMethodID (env, manager->input_stream_class,
+ "close", "()V");
+ assert (manager->stream_close);
+
+ /* Now convert all the class references to global ones. */
+ temp = manager->class;
+ manager->class
+ = (*env)->NewGlobalRef (env, temp);
+ assert (manager->class);
+ (*env)->DeleteLocalRef (env, temp);
+ temp = manager->fd_class;
+ manager->fd_class
+ = (*env)->NewGlobalRef (env, temp);
+ assert (manager->fd_class);
+ (*env)->DeleteLocalRef (env, temp);
+ temp = manager->input_stream_class;
+ manager->input_stream_class
+ = (*env)->NewGlobalRef (env, temp);
+ assert (manager->input_stream_class);
+ (*env)->DeleteLocalRef (env, temp);
+
+ /* Return the asset manager. */
+ return manager;
+}
+
+enum
+ {
+ AASSET_MODE_STREAMING = 0,
+ AASSET_MODE_BUFFER = 1,
+ };
+
+static AAsset *
+AAssetManager_open (AAssetManager *manager, const char *c_name,
+ int mode)
+{
+ jobject desc;
+ jstring name;
+ AAsset *asset;
+
+ /* Push a local frame. */
+ asset = NULL;
+
+ (*(manager->env))->PushLocalFrame (manager->env, 3);
+
+ if ((*(manager->env))->ExceptionCheck (manager->env))
+ goto fail;
+
+ /* Encoding issues can be ignored for now as there are only ASCII
+ file names in Emacs. */
+ name = (*(manager->env))->NewStringUTF (manager->env, c_name);
+
+ if (!name)
+ goto fail;
+
+ /* Now try to open an ``AssetFileDescriptor''. */
+ desc = (*(manager->env))->CallObjectMethod (manager->env,
+ manager->asset_manager,
+ manager->open_fd,
+ name);
+
+ if (!desc)
+ goto fail;
+
+ /* Allocate the asset. */
+ asset = calloc (1, sizeof *asset);
+
+ if (!asset)
+ {
+ (*(manager->env))->CallVoidMethod (manager->env,
+ desc,
+ manager->close);
+ goto fail;
+ }
+
+ /* Pop the local frame and return desc. */
+ desc = (*(manager->env))->NewGlobalRef (manager->env, desc);
+
+ if (!desc)
+ goto fail;
+
+ (*(manager->env))->PopLocalFrame (manager->env, NULL);
+
+ asset->manager = manager;
+ asset->length = -1;
+ asset->fd = desc;
+ asset->mode = mode;
+
+ return asset;
+
+ fail:
+ (*(manager->env))->ExceptionClear (manager->env);
+ (*(manager->env))->PopLocalFrame (manager->env, NULL);
+ free (asset);
+
+ return NULL;
+}
+
+static AAsset *
+AAsset_close (AAsset *asset)
+{
+ JNIEnv *env;
+
+ env = asset->manager->env;
+
+ (*env)->CallVoidMethod (asset->manager->env,
+ asset->fd,
+ asset->manager->close);
+ (*env)->DeleteGlobalRef (asset->manager->env,
+ asset->fd);
+
+ if (asset->stream)
+ {
+ (*env)->CallVoidMethod (asset->manager->env,
+ asset->stream,
+ asset->manager->stream_close);
+ (*env)->DeleteGlobalRef (asset->manager->env,
+ asset->stream);
+ }
+
+ free (asset);
+}
+
+/* Create an input stream associated with the given ASSET. Set
+ ASSET->stream to its global reference.
+
+ Value is 1 upon failure, else 0. ASSET must not already have an
+ input stream. */
+
+static int
+android_asset_create_stream (AAsset *asset)
+{
+ jobject stream;
+ JNIEnv *env;
+
+ env = asset->manager->env;
+ stream
+ = (*env)->CallObjectMethod (env, asset->fd,
+ asset->manager->create_input_stream);
+
+ if (!stream)
+ {
+ (*env)->ExceptionClear (env);
+ return 1;
+ }
+
+ asset->stream
+ = (*env)->NewGlobalRef (env, stream);
+
+ if (!asset->stream)
+ {
+ (*env)->ExceptionClear (env);
+ (*env)->DeleteLocalRef (env, stream);
+ return 1;
+ }
+
+ (*env)->DeleteLocalRef (env, stream);
+ return 0;
+}
+
+/* Read NBYTES from the specified asset into the given BUFFER;
+
+ Internally, allocate a Java byte array containing 4096 elements and
+ copy the data to and from that array.
+
+ Value is the number of bytes actually read, 0 at EOF, or -1 upon
+ failure, in which case errno is set accordingly. If NBYTES is
+ zero, behavior is undefined. */
+
+static int
+android_asset_read_internal (AAsset *asset, int nbytes, char *buffer)
+{
+ jbyteArray stash;
+ JNIEnv *env;
+ jint bytes_read, total;
+
+ /* Allocate a suitable amount of storage. Either nbytes or 4096,
+ whichever is larger. */
+ env = asset->manager->env;
+ stash = (*env)->NewByteArray (env, MIN (nbytes, 4096));
+
+ if (!stash)
+ {
+ (*env)->ExceptionClear (env);
+ errno = ENOMEM;
+ return -1;
+ }
+
+ /* Try to create an input stream. */
+
+ if (!asset->stream
+ && android_asset_create_stream (asset))
+ {
+ (*env)->DeleteLocalRef (env, stash);
+ errno = ENOMEM;
+ return -1;
+ }
+
+ /* Start reading. */
+
+ total = 0;
+
+ while (nbytes)
+ {
+ bytes_read = (*env)->CallIntMethod (env, asset->stream,
+ asset->manager->read,
+ stash);
+
+ /* Detect error conditions. */
+
+ if ((*env)->ExceptionCheck (env))
+ goto out_errno;
+
+ /* Detect EOF. */
+
+ if (bytes_read == -1)
+ goto out;
+
+ /* Finally write out the amount that was read. */
+ bytes_read = MIN (bytes_read, nbytes);
+ (*env)->GetByteArrayRegion (env, stash, 0, bytes_read, buffer);
+
+ buffer += bytes_read;
+ total += bytes_read;
+ nbytes -= bytes_read;
+ }
+
+ /* Make sure the value of nbytes still makes sense. */
+ assert (nbytes >= 0);
+
+ out:
+ (*env)->ExceptionClear (env);
+ (*env)->DeleteLocalRef (env, stash);
+ return total;
+
+ out_errno:
+ /* Return an error indication if an exception arises while the file
+ is being read. */
+ (*env)->ExceptionClear (env);
+ (*env)->DeleteLocalRef (env, stash);
+ errno = EIO;
+ return -1;
+}
+
+static long
+AAsset_getLength (AAsset *asset)
+{
+ JNIEnv *env;
+
+ if (asset->length != -1)
+ return asset->length;
+
+ env = asset->manager->env;
+ asset->length
+ = (*env)->CallLongMethod (env, asset->fd,
+ asset->manager->get_length);
+ return asset->length;
+}
+
+static char *
+AAsset_getBuffer (AAsset *asset)
+{
+ long length;
+ char *buffer;
+
+ length = AAsset_getLength (asset);
+
+ if (!length)
+ return NULL;
+
+ buffer = malloc (length);
+
+ if (!buffer)
+ return NULL;
+
+ if (android_asset_read_internal (asset, length, buffer)
+ != length)
+ {
+ free (buffer);
+ return NULL;
+ }
+
+ return buffer;
+}
+
+static size_t
+AAsset_read (AAsset *asset, void *buffer, size_t size)
+{
+ return android_asset_read_internal (asset, MIN (size, INT_MAX),
+ buffer);
+}
+
+static off_t
+AAsset_seek (AAsset *asset, off_t offset, int whence)
+{
+ /* Java InputStreams don't support seeking at all. */
+ errno = ESPIPE;
+ return -1;
+}
diff --git a/src/android-emacs.c b/src/android-emacs.c
new file mode 100644
index 00000000000..5a43445612a
--- /dev/null
+++ b/src/android-emacs.c
@@ -0,0 +1,178 @@
+/* Android initialization for GNU Emacs.
+
+Copyright (C) 2023-2024 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 <https://www.gnu.org/licenses/>. */
+
+#include <config.h>
+#include <stdio.h>
+#include <alloca.h>
+#include <string.h>
+#include <unistd.h>
+
+/* android-emacs is a wrapper around /system/bin/app_process(64).
+ It invokes app_process(64) with the right class path and then
+ starts org.gnu.emacs.EmacsNoninteractive.
+
+ The main function in that class tries to load an activity thread
+ and obtain a context and asset manager before calling
+ android_emacs_init, which is required for Emacs to find required
+ preloaded Lisp. */
+
+int
+main (int argc, char **argv)
+{
+ char **args;
+ int i;
+ char *bootclasspath, *emacs_class_path, *ld_library_path;
+
+ /* Allocate enough to hold the arguments to app_process. */
+ args = alloca ((10 + argc) * sizeof *args);
+
+ /* Clear args. */
+ memset (args, 0, (10 + argc) * sizeof *args);
+
+ /* First, figure out what program to start. */
+#if defined __x86_64__ || defined __aarch64__ || defined __mips64
+ args[0] = (char *) "/system/bin/app_process64";
+#else /* i386 || regular mips || arm */
+ args[0] = (char *) "/system/bin/app_process";
+#endif /* __x86_64__ || __aarch64__ || __mips64 */
+
+ /* Machines with ART require the boot classpath to be manually
+ specified. Machines with Dalvik however refuse to do so, as they
+ open the jars inside the BOOTCLASSPATH environment variable at
+ startup, resulting in the following crash:
+
+ W/dalvikvm( 1608): Refusing to reopen boot DEX
+ '/system/framework/core.jar'
+ W/dalvikvm( 1608): Refusing to reopen boot DEX
+ '/system/framework/bouncycastle.jar'
+ E/dalvikvm( 1608): Too many exceptions during init (failed on
+ 'Ljava/io/IOException;' 'Re-opening BOOTCLASSPATH DEX files is
+ not allowed')
+ E/dalvikvm( 1608): VM aborting */
+
+#if HAVE_DECL_ANDROID_GET_DEVICE_API_LEVEL
+ if (android_get_device_api_level () < 21)
+ {
+ bootclasspath = NULL;
+ goto skip_setup;
+ }
+#else /* !HAVE_DECL_ANDROID_GET_DEVICE_API_LEVEL */
+ if (__ANDROID_API__ < 21)
+ {
+ bootclasspath = NULL;
+ goto skip_setup;
+ }
+#endif /* HAVE_DECL_ANDROID_GET_DEVICE_API_LEVEL */
+
+ /* Next, obtain the boot class path. */
+ bootclasspath = getenv ("BOOTCLASSPATH");
+
+ if (!bootclasspath)
+ {
+ fprintf (stderr, "The BOOTCLASSPATH environment variable"
+ " is not set. As a result, Emacs does not know"
+ " how to start app_process.\n"
+ "This is likely a change in the Android platform."
+ " Please report this to bug-gnu-emacs@gnu.org.\n");
+ return 1;
+ }
+
+ skip_setup:
+
+ /* And the Emacs class path. */
+ emacs_class_path = getenv ("EMACS_CLASS_PATH");
+
+ if (!emacs_class_path)
+ {
+ fprintf (stderr, "EMACS_CLASS_PATH not set."
+ " Please make sure Emacs is being started"
+ " from within a running copy of Emacs.\n");
+ return 1;
+ }
+
+ /* Restore LD_LIBRARY_PATH to its original value, the app library
+ directory, to guarantee that it is possible for Java to find the
+ Emacs C code later. */
+
+ ld_library_path = getenv ("EMACS_LD_LIBRARY_PATH");
+
+ if (ld_library_path)
+ setenv ("LD_LIBRARY_PATH", ld_library_path, 1);
+
+ if (bootclasspath)
+ {
+ if (asprintf (&bootclasspath, "-Djava.class.path=%s:%s",
+ bootclasspath, emacs_class_path) < 0)
+ {
+ perror ("asprintf");
+ return 1;
+ }
+ }
+ else
+ {
+ if (asprintf (&bootclasspath, "-Djava.class.path=%s",
+ emacs_class_path) < 0)
+ {
+ perror ("asprintf");
+ return 1;
+ }
+ }
+
+ args[1] = bootclasspath;
+ args[2] = (char *) "/system/bin";
+
+#if HAVE_DECL_ANDROID_GET_DEVICE_API_LEVEL
+ /* I don't know exactly when --nice-name was introduced; this is
+ just a guess. */
+ if (android_get_device_api_level () >= 26)
+ {
+ args[3] = (char *) "--nice-name=emacs";
+ args[4] = (char *) "org.gnu.emacs.EmacsNoninteractive";
+
+ /* Arguments from here on are passed to main in
+ EmacsNoninteractive.java. */
+ args[5] = argv[0];
+
+ /* Now copy the rest of the arguments over. */
+ for (i = 1; i < argc; ++i)
+ args[5 + i] = argv[i];
+ }
+ else
+ {
+#endif /* HAVE_DECL_ANDROID_GET_DEVICE_API_LEVEL */
+ args[3] = (char *) "org.gnu.emacs.EmacsNoninteractive";
+
+ /* Arguments from here on are passed to main in
+ EmacsNoninteractive.java. */
+ args[4] = argv[0];
+
+ /* Now copy the rest of the arguments over. */
+ for (i = 1; i < argc; ++i)
+ args[4 + i] = argv[i];
+#if HAVE_DECL_ANDROID_GET_DEVICE_API_LEVEL
+ }
+#endif /* HAVE_DECL_ANDROID_GET_DEVICE_API_LEVEL */
+
+ /* Finally, try to start the app_process. */
+ execvp (args[0], args);
+
+ /* If exit fails, return an error indication. */
+ perror ("exec");
+ return 1;
+}
diff --git a/src/android.c b/src/android.c
new file mode 100644
index 00000000000..dcd5c6d99c7
--- /dev/null
+++ b/src/android.c
@@ -0,0 +1,7711 @@
+/* Android initialization for GNU Emacs.
+
+Copyright (C) 2023-2024 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 <https://www.gnu.org/licenses/>. */
+
+#include <config.h>
+
+#include <allocator.h>
+#include <assert.h>
+#include <careadlinkat.h>
+#include <errno.h>
+#include <fcntl.h>
+#include <fingerprint.h>
+#include <intprops.h>
+#include <libgen.h>
+#include <limits.h>
+#include <math.h>
+#include <pthread.h>
+#include <semaphore.h>
+#include <signal.h>
+#include <stat-time.h>
+#include <stdckdint.h>
+#include <string.h>
+#include <timespec.h>
+#include <unistd.h>
+
+#include <sys/param.h>
+#include <sys/stat.h>
+#include <sys/select.h>
+
+/* Old NDK versions lack MIN and MAX. */
+#include <minmax.h>
+
+#include "android.h"
+#include "androidgui.h"
+
+#include "lisp.h"
+#include "blockinput.h"
+#include "coding.h"
+#include "epaths.h"
+#include "systime.h"
+
+/* Whether or not Emacs is running inside the application process and
+ Android windowing should be enabled. */
+bool android_init_gui;
+
+#ifndef ANDROID_STUBIFY
+
+#include <android/bitmap.h>
+#include <android/log.h>
+
+#include <linux/unistd.h>
+
+#include <sys/syscall.h>
+
+#ifdef __aarch64__
+#include <arm_neon.h>
+#endif /* __aarch64__ */
+
+struct android_emacs_pixmap
+{
+ jclass class;
+ jmethodID constructor_mutable;
+};
+
+struct android_graphics_point
+{
+ jclass class;
+ jmethodID constructor;
+};
+
+struct android_emacs_drawable
+{
+ jclass class;
+ jmethodID get_bitmap;
+};
+
+struct android_emacs_window
+{
+ jclass class;
+ jmethodID swap_buffers;
+ jmethodID toggle_on_screen_keyboard;
+ jmethodID lookup_string;
+ jmethodID set_fullscreen;
+ jmethodID change_window_background;
+ jmethodID reparent_to;
+ jmethodID map_window;
+ jmethodID unmap_window;
+ jmethodID resize_window;
+ jmethodID move_window;
+ jmethodID make_input_focus;
+ jmethodID raise;
+ jmethodID lower;
+ jmethodID reconfigure;
+ jmethodID get_window_geometry;
+ jmethodID translate_coordinates;
+ jmethodID set_dont_accept_focus;
+ jmethodID set_dont_focus_on_map;
+ jmethodID define_cursor;
+ jmethodID damage_rect;
+ jmethodID recreate_activity;
+ jmethodID clear_window;
+ jmethodID clear_area;
+};
+
+struct android_emacs_cursor
+{
+ jclass class;
+ jmethodID constructor;
+};
+
+struct android_key_character_map
+{
+ jclass class;
+ jmethodID get_dead_char;
+};
+
+/* The API level of the current device. */
+static int android_api_level;
+
+/* The directory used to store site-lisp. */
+char *android_site_load_path;
+
+/* The directory used to store native libraries. */
+char *android_lib_dir;
+
+/* The directory used to store game files. */
+char *android_game_path;
+
+/* The directory used to store temporary files. */
+char *android_cache_dir;
+
+/* The list of archive files within which the Java virtual macine
+ looks for class files. */
+char *android_class_path;
+
+/* The display's pixel densities. */
+double android_pixel_density_x, android_pixel_density_y;
+
+/* The display pixel density used to convert between point and pixel
+ font sizes. */
+double android_scaled_pixel_density;
+
+/* The Android application data directory. */
+static char *android_files_dir;
+
+/* The Java environment being used for the main thread. */
+JNIEnv *android_java_env;
+
+#ifdef THREADS_ENABLED
+
+/* The Java VM new threads attach to. */
+JavaVM *android_jvm;
+
+#endif /* THREADS_ENABLED */
+
+/* The EmacsGC class. */
+static jclass emacs_gc_class;
+
+/* Various fields. */
+static jfieldID emacs_gc_foreground, emacs_gc_background;
+static jfieldID emacs_gc_function, emacs_gc_clip_rects;
+static jfieldID emacs_gc_clip_x_origin, emacs_gc_clip_y_origin;
+static jfieldID emacs_gc_stipple, emacs_gc_clip_mask;
+static jfieldID emacs_gc_fill_style, emacs_gc_ts_origin_x;
+static jfieldID emacs_gc_ts_origin_y;
+
+/* The constructor and one function. */
+static jmethodID emacs_gc_constructor, emacs_gc_mark_dirty;
+
+/* The Rect class. */
+static jclass android_rect_class;
+
+/* Its constructor. */
+static jmethodID android_rect_constructor;
+
+/* The EmacsService object. */
+jobject emacs_service;
+
+/* Various methods associated with the EmacsService. */
+struct android_emacs_service service_class;
+
+/* Various methods associated with the EmacsPixmap class. */
+static struct android_emacs_pixmap pixmap_class;
+
+/* Various methods associated with the Point class. */
+static struct android_graphics_point point_class;
+
+/* Various methods associated with the EmacsDrawable class. */
+static struct android_emacs_drawable drawable_class;
+
+/* Various methods associated with the EmacsWindow class. */
+static struct android_emacs_window window_class;
+
+/* Various methods associated with the EmacsCursor class. */
+static struct android_emacs_cursor cursor_class;
+
+/* Various methods associated with the KeyCharacterMap class. */
+static struct android_key_character_map key_character_map_class;
+
+/* The time at which Emacs was installed, which also supplies the
+ mtime of asset files. */
+struct timespec emacs_installation_time;
+
+/* The last event serial used. This is a 32 bit value, but it is
+ stored in unsigned long to be consistent with X. */
+unsigned int event_serial;
+
+#ifdef __i386__
+
+/* Unused pointer used to control compiler optimizations. */
+void *unused_pointer;
+
+#endif /* __i386__ */
+
+/* Whether or not the default signal mask has been changed. If so,
+ the signal mask must be restored before calling
+ android_emacs_init. */
+static bool signal_mask_changed_p;
+
+/* The signal mask at the time Emacs was started. */
+static sigset_t startup_signal_mask;
+
+
+
+/* Event handling functions. Events are stored on a (circular) queue
+ that is read synchronously. The Android port replaces pselect with
+ a function android_select, which runs pselect in a separate thread,
+ but more importantly also waits for events to be available on the
+ android event queue. */
+
+struct android_event_container
+{
+ /* The next and last events in this queue. */
+ struct android_event_container *next, *last;
+
+ /* The event itself. */
+ union android_event event;
+};
+
+struct android_event_queue
+{
+ /* Mutex protecting the event queue. */
+ pthread_mutex_t mutex;
+
+ /* Mutex protecting the select data. */
+ pthread_mutex_t select_mutex;
+
+ /* The thread used to run select. */
+ pthread_t select_thread;
+
+ /* Condition variables for the reading side. */
+ pthread_cond_t read_var;
+
+ /* The number of events in the queue. If this is greater than 1024,
+ writing will block. */
+ int num_events;
+
+ /* Circular queue of events. */
+ struct android_event_container events;
+};
+
+/* Arguments to pselect used by the select thread. */
+static int android_pselect_nfds;
+static fd_set *android_pselect_readfds;
+static fd_set *android_pselect_writefds;
+static fd_set *android_pselect_exceptfds;
+static struct timespec *android_pselect_timeout;
+
+/* Value of pselect. */
+static int android_pselect_rc;
+
+/* The global event queue. */
+static struct android_event_queue event_queue;
+
+/* Semaphores used to signal select completion and start. */
+static sem_t android_pselect_sem, android_pselect_start_sem;
+
+#if __ANDROID_API__ < 16
+
+/* Select self-pipe. */
+static int select_pipe[2];
+
+#else
+
+/* Whether or not pselect has been interrupted. */
+static volatile sig_atomic_t android_pselect_interrupted;
+
+#endif
+
+/* Set the task name of the current task to NAME, a string at most 16
+ characters in length.
+
+ This name is displayed as that of the task (LWP)'s pthread in
+ GDB. */
+
+static void
+android_set_task_name (const char *name)
+{
+ char proc_name[INT_STRLEN_BOUND (long)
+ + sizeof "/proc/self/task//comm"];
+ int fd;
+ pid_t lwp;
+ size_t length;
+
+ lwp = gettid ();
+ sprintf (proc_name, "/proc/self/task/%ld/comm", (long) lwp);
+ fd = open (proc_name, O_WRONLY | O_TRUNC);
+
+ if (fd < 0)
+ goto failure;
+
+ length = strlen (name);
+
+ if (write (fd, name, MIN (16, length)) < 0)
+ goto failure;
+
+ close (fd);
+ return;
+
+ failure:
+ __android_log_print (ANDROID_LOG_WARN, __func__,
+ "Failed to set task name for LWP %ld: %s",
+ (long) lwp, strerror (errno));
+
+ /* Close the file descriptor if it is already set. */
+ if (fd >= 0)
+ close (fd);
+}
+
+static void *
+android_run_select_thread (void *data)
+{
+ /* Apparently this is required too. */
+ JNI_STACK_ALIGNMENT_PROLOGUE;
+
+ int rc;
+#if __ANDROID_API__ < 16
+ int nfds;
+ fd_set readfds;
+ char byte;
+#else
+ sigset_t signals, waitset;
+ int sig;
+#endif
+
+ /* Set the name of this thread's LWP for debugging purposes. */
+ android_set_task_name ("`android_select'");
+
+#if __ANDROID_API__ < 16
+ /* A completely different implementation is used when building for
+ Android versions earlier than 16, because pselect with a signal
+ mask does not work there. Instead of blocking SIGUSR1 and
+ unblocking it inside pselect, a file descriptor is used instead.
+ Something is written to the file descriptor every time select is
+ supposed to return. */
+
+ while (true)
+ {
+ /* Wait for the thread to be released. */
+ while (sem_wait (&android_pselect_start_sem) < 0)
+ ;;
+
+ /* Get the select lock and call pselect. API 8 does not have
+ working pselect in any sense. Instead, pselect wakes up on
+ select_pipe[0]. */
+
+ pthread_mutex_lock (&event_queue.select_mutex);
+ nfds = android_pselect_nfds;
+
+ if (android_pselect_readfds)
+ readfds = *android_pselect_readfds;
+ else
+ FD_ZERO (&readfds);
+
+ if (nfds < select_pipe[0] + 1)
+ nfds = select_pipe[0] + 1;
+ FD_SET (select_pipe[0], &readfds);
+
+ rc = pselect (nfds, &readfds,
+ android_pselect_writefds,
+ android_pselect_exceptfds,
+ android_pselect_timeout,
+ NULL);
+
+ /* Subtract 1 from rc if readfds contains the select pipe, and
+ also remove it from that set. */
+
+ if (rc != -1 && FD_ISSET (select_pipe[0], &readfds))
+ {
+ rc -= 1;
+ FD_CLR (select_pipe[0], &readfds);
+
+ /* If no file descriptors aside from the select pipe are
+ ready, then pretend that an error has occurred. */
+ if (!rc)
+ rc = -1;
+ }
+
+ /* Save the read file descriptor set back again. */
+
+ if (android_pselect_readfds)
+ *android_pselect_readfds = readfds;
+
+ android_pselect_rc = rc;
+ pthread_mutex_unlock (&event_queue.select_mutex);
+
+ /* Signal the main thread that there is now data to read. Hold
+ the event queue lock during this process to make sure this
+ does not happen before the main thread begins to wait for the
+ condition variable. */
+
+ pthread_mutex_lock (&event_queue.mutex);
+ pthread_cond_broadcast (&event_queue.read_var);
+ pthread_mutex_unlock (&event_queue.mutex);
+
+ /* Read a single byte from the select pipe. */
+ read (select_pipe[0], &byte, 1);
+
+ /* Signal the Emacs thread that pselect is done. If read_var
+ was signaled by android_write_event, event_queue.mutex could
+ still be locked, so this must come before. */
+ sem_post (&android_pselect_sem);
+ }
+#else
+ if (pthread_sigmask (SIG_BLOCK, &signals, NULL))
+ __android_log_print (ANDROID_LOG_FATAL, __func__,
+ "pthread_sigmask: %s",
+ strerror (errno));
+
+ sigfillset (&signals);
+ sigdelset (&signals, SIGUSR1);
+ sigemptyset (&waitset);
+ sigaddset (&waitset, SIGUSR1);
+
+ while (true)
+ {
+ /* Wait for the thread to be released. */
+ while (sem_wait (&android_pselect_start_sem) < 0)
+ ;;
+
+ /* Clear the ``pselect interrupted'' flag. This is safe because
+ right now, SIGUSR1 is blocked. */
+ android_pselect_interrupted = 0;
+
+ /* Get the select lock and call pselect. */
+ pthread_mutex_lock (&event_queue.select_mutex);
+ rc = pselect (android_pselect_nfds,
+ android_pselect_readfds,
+ android_pselect_writefds,
+ android_pselect_exceptfds,
+ android_pselect_timeout,
+ &signals);
+ android_pselect_rc = rc;
+ pthread_mutex_unlock (&event_queue.select_mutex);
+
+ /* Signal the main thread that there is now data to read. Hold
+ the event queue lock during this process to make sure this
+ does not happen before the main thread begins to wait for the
+ condition variable. */
+
+ pthread_mutex_lock (&event_queue.mutex);
+ pthread_cond_broadcast (&event_queue.read_var);
+ pthread_mutex_unlock (&event_queue.mutex);
+
+ /* Check `android_pselect_interrupted' instead of rc and errno.
+
+ This is because `pselect' does not return an rc of -1 upon
+ being interrupted in some versions of Android, but does set
+ signal masks correctly. */
+
+ if (!android_pselect_interrupted)
+ /* Now, wait for SIGUSR1, unless pselect was interrupted and
+ the signal was already delivered. The Emacs thread will
+ always send this signal after read_var is triggered or the
+ UI thread has sent an event. */
+ sigwait (&waitset, &sig);
+
+ /* Signal the Emacs thread that pselect is done. If read_var
+ was signaled by android_write_event, event_queue.mutex could
+ still be locked, so this must come before. */
+ sem_post (&android_pselect_sem);
+ }
+#endif
+
+ return NULL;
+}
+
+#if __ANDROID_API__ >= 16
+
+static void
+android_handle_sigusr1 (int sig, siginfo_t *siginfo, void *arg)
+{
+ /* Notice that pselect has been interrupted. */
+ android_pselect_interrupted = 1;
+}
+
+#endif
+
+/* Semaphore used to indicate completion of a query.
+ This should ideally be defined further down. */
+static sem_t android_query_sem;
+
+/* ID of the Emacs thread. */
+static pthread_t main_thread_id;
+
+/* Set up the global event queue by initializing the mutex and two
+ condition variables, and the linked list of events. This must be
+ called before starting the Emacs thread. Also, initialize the
+ thread used to run pselect.
+
+ These functions must also use the C library malloc and free,
+ because xmalloc is not thread safe. */
+
+static void
+android_init_events (void)
+{
+ struct sigaction sa;
+
+ if (pthread_mutex_init (&event_queue.mutex, NULL))
+ __android_log_print (ANDROID_LOG_FATAL, __func__,
+ "pthread_mutex_init: %s",
+ strerror (errno));
+
+ if (pthread_mutex_init (&event_queue.select_mutex, NULL))
+ __android_log_print (ANDROID_LOG_FATAL, __func__,
+ "pthread_mutex_init: %s",
+ strerror (errno));
+
+ if (pthread_cond_init (&event_queue.read_var, NULL))
+ __android_log_print (ANDROID_LOG_FATAL, __func__,
+ "pthread_cond_init: %s",
+ strerror (errno));
+
+ sem_init (&android_pselect_sem, 0, 0);
+ sem_init (&android_pselect_start_sem, 0, 0);
+ sem_init (&android_query_sem, 0, 0);
+
+ event_queue.events.next = &event_queue.events;
+ event_queue.events.last = &event_queue.events;
+
+ main_thread_id = pthread_self ();
+
+#if __ANDROID_API__ >= 16
+
+ /* Before starting the select thread, make sure the disposition for
+ SIGUSR1 is correct. */
+ sigfillset (&sa.sa_mask);
+ sa.sa_sigaction = android_handle_sigusr1;
+ sa.sa_flags = SA_SIGINFO;
+
+#else
+
+ /* Set up the file descriptor used to wake up pselect. */
+ if (pipe2 (select_pipe, O_CLOEXEC) < 0)
+ __android_log_print (ANDROID_LOG_FATAL, __func__,
+ "pipe2: %s", strerror (errno));
+
+ /* Make sure the read end will fit in fd_set. */
+ if (select_pipe[0] >= FD_SETSIZE)
+ __android_log_print (ANDROID_LOG_FATAL, __func__,
+ "read end of select pipe"
+ " lies outside FD_SETSIZE!");
+
+#endif
+
+ if (sigaction (SIGUSR1, &sa, NULL))
+ __android_log_print (ANDROID_LOG_FATAL, __func__,
+ "sigaction: %s",
+ strerror (errno));
+
+ /* Start the select thread. */
+ if (pthread_create (&event_queue.select_thread, NULL,
+ android_run_select_thread, NULL))
+ __android_log_print (ANDROID_LOG_FATAL, __func__,
+ "pthread_create: %s",
+ strerror (errno));
+}
+
+int
+android_pending (void)
+{
+ int i;
+
+ pthread_mutex_lock (&event_queue.mutex);
+ i = event_queue.num_events;
+ pthread_mutex_unlock (&event_queue.mutex);
+
+ return i;
+}
+
+/* Wait for events to become available synchronously. Return once an
+ event arrives. Also, reply to the UI thread whenever it requires a
+ response. */
+
+void
+android_wait_event (void)
+{
+ /* Run queries from the UI thread to the Emacs thread. */
+ android_check_query ();
+
+ pthread_mutex_lock (&event_queue.mutex);
+
+ /* Wait for events to appear if there are none available to
+ read. */
+ if (!event_queue.num_events)
+ pthread_cond_wait (&event_queue.read_var,
+ &event_queue.mutex);
+
+ pthread_mutex_unlock (&event_queue.mutex);
+
+ /* Check for queries again. If a query is sent after the call to
+ `android_check_query' above, `read_var' will be signaled. */
+ android_check_query ();
+}
+
+void
+android_next_event (union android_event *event_return)
+{
+ struct android_event_container *container;
+
+ pthread_mutex_lock (&event_queue.mutex);
+
+ /* Wait for events to appear if there are none available to
+ read. */
+ if (!event_queue.num_events)
+ pthread_cond_wait (&event_queue.read_var,
+ &event_queue.mutex);
+
+ /* Obtain the event from the end of the queue. */
+ container = event_queue.events.last;
+ eassert (container != &event_queue.events);
+
+ /* Remove the event from the queue and copy it to the caller
+ supplied buffer. */
+ container->last->next = container->next;
+ container->next->last = container->last;
+ *event_return = container->event;
+ event_queue.num_events--;
+
+ /* Free the container. */
+ free (container);
+
+ /* Unlock the queue. */
+ pthread_mutex_unlock (&event_queue.mutex);
+}
+
+bool
+android_check_if_event (union android_event *event_return,
+ bool (*predicate) (union android_event *,
+ void *),
+ void *arg)
+{
+ struct android_event_container *container;
+
+ pthread_mutex_lock (&event_queue.mutex);
+
+ /* Loop over each event. */
+ container = event_queue.events.last;
+ for (; container != &event_queue.events; container = container->last)
+ {
+ /* See if the predicate matches. */
+ if ((*predicate) (&container->event, arg))
+ {
+ /* Copy out the event and return true. */
+ *event_return = container->event;
+ --event_queue.num_events;
+
+ /* Unlink container. */
+ container->last->next = container->next;
+ container->next->last = container->last;
+ free (container);
+ pthread_mutex_unlock (&event_queue.mutex);
+ return true;
+ }
+ }
+
+ pthread_mutex_unlock (&event_queue.mutex);
+ return false;
+}
+
+void
+android_write_event (union android_event *event)
+{
+ struct android_event_container *container;
+
+ container = malloc (sizeof *container);
+
+ if (!container)
+ return;
+
+ /* If the event queue hasn't been initialized yet, return false. */
+ if (!event_queue.events.next)
+ return;
+
+ pthread_mutex_lock (&event_queue.mutex);
+ container->next = event_queue.events.next;
+ container->last = &event_queue.events;
+ container->next->last = container;
+ container->last->next = container;
+ container->event = *event;
+ event_queue.num_events++;
+ pthread_cond_broadcast (&event_queue.read_var);
+ pthread_mutex_unlock (&event_queue.mutex);
+
+ /* Now set pending_signals to true, and raise SIGIO to interrupt any
+ ongoing reads if the event is important. */
+ pending_signals = true;
+
+ switch (event->type)
+ {
+ /* Key press and window action events are considered important,
+ as they either end up quitting or asking for responses to the
+ IME. */
+ case ANDROID_KEY_PRESS:
+ case ANDROID_WINDOW_ACTION:
+ kill (getpid (), SIGIO);
+ break;
+
+ default:
+ break;
+ }
+}
+
+
+
+/* Whether or not the UI thread has been waiting for a significant
+ amount of time for a function to run in the main thread, and Emacs
+ should answer the query ASAP. */
+static bool android_urgent_query;
+
+int
+android_select (int nfds, fd_set *readfds, fd_set *writefds,
+ fd_set *exceptfds, struct timespec *timeout)
+{
+ int nfds_return;
+#if __ANDROID_API__ < 16
+ static char byte;
+#endif
+
+#ifdef THREADS_ENABLED
+ if (!pthread_equal (pthread_self (), main_thread_id))
+ return pselect (nfds, readfds, writefds, exceptfds, timeout,
+ NULL);
+#endif /* THREADS_ENABLED */
+
+ /* Since Emacs is reading keyboard input again, signify that queries
+ from input methods are no longer ``urgent''. */
+
+ __atomic_clear (&android_urgent_query, __ATOMIC_RELEASE);
+
+ /* Check for and run anything the UI thread wants to run on the main
+ thread. */
+ android_check_query ();
+
+ pthread_mutex_lock (&event_queue.mutex);
+
+ if (event_queue.num_events)
+ {
+ /* Zero READFDS, WRITEFDS and EXCEPTFDS, lest the caller
+ mistakenly interpret this return value as indicating that an
+ inotify file descriptor is readable, and try to poll an
+ unready one. */
+
+ if (readfds)
+ FD_ZERO (readfds);
+
+ if (writefds)
+ FD_ZERO (writefds);
+
+ if (exceptfds)
+ FD_ZERO (exceptfds);
+ pthread_mutex_unlock (&event_queue.mutex);
+ return 1;
+ }
+
+ nfds_return = 0;
+
+ pthread_mutex_lock (&event_queue.select_mutex);
+ android_pselect_nfds = nfds;
+ android_pselect_readfds = readfds;
+ android_pselect_writefds = writefds;
+ android_pselect_exceptfds = exceptfds;
+ android_pselect_timeout = timeout;
+ pthread_mutex_unlock (&event_queue.select_mutex);
+
+ /* Release the select thread. */
+ sem_post (&android_pselect_start_sem);
+
+ /* Start waiting for the event queue condition to be set. */
+ pthread_cond_wait (&event_queue.read_var, &event_queue.mutex);
+
+#if __ANDROID_API__ >= 16
+ /* Interrupt the select thread now, in case it's still in
+ pselect. */
+ pthread_kill (event_queue.select_thread, SIGUSR1);
+#else
+ /* Interrupt the select thread by writing to the select pipe. */
+ if (write (select_pipe[1], &byte, 1) != 1)
+ __android_log_print (ANDROID_LOG_FATAL, __func__,
+ "write: %s", strerror (errno));
+#endif
+
+ /* Unlock the event queue mutex. */
+ pthread_mutex_unlock (&event_queue.mutex);
+
+ /* Wait for pselect to return in any case. This must be done with
+ the event queue mutex unlocked. Otherwise, the pselect thread
+ can hang if it tries to lock the event queue mutex to signal
+ read_var after the UI thread has already done so. */
+ while (sem_wait (&android_pselect_sem) < 0)
+ ;;
+
+ /* If there are now events in the queue, return 1. */
+
+ pthread_mutex_lock (&event_queue.mutex);
+ if (event_queue.num_events)
+ nfds_return = 1;
+ pthread_mutex_unlock (&event_queue.mutex);
+
+ /* Add the return value of pselect if it has also found ready file
+ descriptors. */
+
+ if (android_pselect_rc >= 0)
+ nfds_return += android_pselect_rc;
+ else if (!nfds_return)
+ /* If pselect was interrupted and nfds_return is 0 (meaning that
+ no events have been read), indicate that an error has taken
+ place. */
+ nfds_return = android_pselect_rc;
+
+ if ((android_pselect_rc < 0) && nfds_return >= 0)
+ {
+ /* Clear the file descriptor sets if events will be delivered
+ but no file descriptors have become ready to prevent the
+ caller from misinterpreting a non-zero return value. */
+
+ if (readfds)
+ FD_ZERO (readfds);
+
+ if (writefds)
+ FD_ZERO (writefds);
+
+ if (exceptfds)
+ FD_ZERO (exceptfds);
+ }
+
+ /* This is to shut up process.c when pselect gets EINTR. */
+ if (nfds_return < 0)
+ errno = EINTR;
+
+#ifndef THREADS_ENABLED
+ /* Now check for and run anything the UI thread wants to run in the
+ main thread. */
+ android_check_query ();
+#endif /* THREADS_ENABLED */
+
+ return nfds_return;
+}
+
+
+
+static void *
+android_run_debug_thread (void *data)
+{
+ FILE *file;
+ int fd;
+ char *line;
+ size_t n;
+
+ /* Set the name of this thread's LWP for debugging purposes. */
+ android_set_task_name ("`android_debug'");
+
+ fd = (int) (intptr_t) data;
+ file = fdopen (fd, "r");
+
+ if (!file)
+ return NULL;
+
+ line = NULL;
+
+ while (true)
+ {
+ if (getline (&line, &n, file) < 0)
+ {
+ free (line);
+ break;
+ }
+
+ __android_log_print (ANDROID_LOG_INFO, __func__, "%s", line);
+ }
+
+ fclose (file);
+ return NULL;
+}
+
+
+
+/* Intercept USER_FULL_NAME and return something that makes sense if
+ pw->pw_gecos is NULL. */
+
+char *
+android_user_full_name (struct passwd *pw)
+{
+#ifdef HAVE_STRUCT_PASSWD_PW_GECOS
+ if (!pw->pw_gecos)
+ return (char *) "Android user";
+
+ return pw->pw_gecos;
+#else /* !HAVE_STRUCT_PASSWD_PW_GECOS */
+ return "Android user";
+#endif /* HAVE_STRUCT_PASSWD_PW_GECOS */
+}
+
+
+
+/* Return whether or not the specified file NAME designates a file in
+ the directory DIR, which should be an absolute file name. NAME
+ must be in canonical form. */
+
+bool
+android_is_special_directory (const char *name, const char *dir)
+{
+ size_t len;
+
+ /* Compare up to strlen (DIR) bytes of NAME with DIR. */
+
+ len = strlen (dir);
+ if (strncmp (name, dir, len))
+ return false;
+
+ /* Now see if the character of NAME after len is either a directory
+ separator or a terminating NULL. */
+
+ name += len;
+ switch (*name)
+ {
+ case '\0': /* NAME is an exact match for DIR. */
+ case '/': /* NAME is a constituent of DIR. */
+ return true;
+ }
+
+ /* The file name doesn't match. */
+ return false;
+}
+
+#if 0
+
+/* URL-encode N bytes of the specified STRING into at most N bytes of
+ BUFFER; STRING is assumed to be encoded in a `utf-8-emacs'
+ compatible coding system. Value is the number of bytes encoded
+ (excluding the trailing null byte placed at the end of the encoded
+ text) or -1 upon failure. */
+
+static ssize_t
+android_url_encode (const char *restrict string, size_t length,
+ char *restrict buffer, size_t n)
+{
+ int len, character;
+ size_t num_encoded;
+ char *end;
+ char format[1 + 25];
+
+ /* For each multibyte character... */
+
+ end = string + length;
+ num_encoded = 0;
+
+ while (string < end)
+ {
+ /* XXX: Android documentation claims that URIs is encoded
+ according to the ``Unicode'' scheme, but what this means in
+ reality is that the URI is encoded in UTF-8, and then
+ each of its bytes are encoded. */
+ /* Find the length of the multibyte character at STRING. */
+ len = /* multibyte_length (string, end, true, true) */ 1;
+
+ /* 0 means that STRING is not a valid multibyte string. */
+ if (!len || string + len > end)
+ goto failure;
+
+ /* Now fetch the character and increment string. */
+ /* character = /\* STRING_CHAR ((unsigned char *) string) *\/; */
+ character = *(unsigned char *) string;
+ string += len;
+
+ /* If CHARACTER is not a letter or an unreserved character,
+ escape it. */
+
+ if (!((character >= 'A'
+ && character <= 'Z')
+ || (character >= 'a'
+ && character <= 'z')
+ || (character >= '0'
+ && character <= '9')
+ || character == '_'
+ || character == '-'
+ || character == '!'
+ || character == '.'
+ || character == '~'
+ || character == '\''
+ || character == '('
+ || character == ')'
+ || character == '*'))
+ {
+ len = sprintf (format, "%%%X", (unsigned int) character);
+ if (len < 0)
+ goto failure;
+
+ /* See if there is enough space left to hold the encoded
+ string. */
+
+ if (n < len)
+ goto failure;
+
+ n -= len;
+ num_encoded += len;
+
+ /* Copy the encoded string to STRING. */
+ memcpy (buffer, format, n);
+ buffer += len;
+ }
+ else
+ {
+ /* No more space within BUFFER. */
+ if (!n)
+ goto failure;
+
+ /* Don't encode this ASCII character; just store it. */
+ n--, num_encoded++;
+ *(buffer++) = character;
+ }
+ }
+
+ /* If there's no space for a trailing null byte or more bytes have
+ been encoded than representable in ssize_t, fail. */
+
+ if (!n || num_encoded > SSIZE_MAX)
+ goto failure;
+
+ /* Store the terminating NULL byte. */
+ *buffer = '\0';
+ return num_encoded;
+
+ failure:
+ return -1;
+}
+
+/* Return the content URI corresponding to a `/content' file name,
+ or NULL if it is not a content URI.
+
+ This function is not reentrant. */
+
+static const char *
+android_get_content_name (const char *filename)
+{
+ static char buffer[PATH_MAX + 1];
+ char *head, *token, *next, *saveptr, *copy, *mark, *mark1;
+ ssize_t rc;
+ size_t n, length;
+
+ /* Find the file name described if it starts with `/content'. If
+ just the directory is described, return content://. */
+
+ filename = android_is_special_directory (filename, "/content");
+
+ if (!filename)
+ return NULL;
+
+ if (!*filename)
+ return "content://";
+
+ /* Now copy FILENAME into a buffer and convert it into a content
+ URI. */
+
+ copy = xstrdup (filename);
+ mark = saveptr = NULL;
+ head = stpcpy (buffer, "content:/");
+
+ /* Split FILENAME by slashes. */
+
+ token = strtok_r (copy, "/", &saveptr);
+
+ while (token)
+ {
+ /* Compute the number of bytes remaining in buffer excluding a
+ trailing null byte. */
+ n = PATH_MAX - (head - buffer);
+
+ /* Write / to the buffer. Return failure if there is no space
+ for it. */
+
+ if (!n)
+ goto failure;
+
+ *head++ = '/';
+ n--;
+
+ /* Find the next token now. */
+ next = strtok_r (NULL, "/", &saveptr);
+
+ /* Detect and avoid encoding an encoded URL query affixed to the
+ end of the last component within the content file name.
+
+ Content URIs can include a query describing parameters that
+ must be provided to the content provider. They are separated
+ from the rest of the URI by a single question mark character,
+ which should not be encoded.
+
+ However, the distinction between the separator and question
+ marks that appear inside file name components is lost when a
+ content URI is decoded into a content path. To compensate
+ for this loss of information, Emacs assumes that the last
+ question mark is always a URI separator, and suffixes content
+ file names which contain question marks with a trailing
+ question mark. */
+
+ if (!next)
+ {
+ /* Find the last question mark character. */
+
+ mark1 = strchr (token, '?');
+
+ while (mark1)
+ {
+ mark = mark1;
+ mark1 = strchr (mark + 1, '?');
+ }
+ }
+
+ if (mark)
+ {
+ /* First, encode the part leading to the question mark
+ character. */
+
+ rc = 0;
+ if (mark > token)
+ rc = android_url_encode (token, mark - token,
+ head, n + 1);
+
+ /* If this fails, bail out. */
+
+ if (rc < 0)
+ goto failure;
+
+ /* Copy mark to the file name. */
+
+ n -= rc, head += rc;
+ length = strlen (mark);
+
+ if (n < length)
+ goto failure;
+
+ strcpy (head, mark);
+
+ /* Now break out of the loop, since this is the last
+ component anyway. */
+ break;
+ }
+ else
+ /* Now encode this file name component into the buffer. */
+ rc = android_url_encode (token, strlen (token),
+ head, n + 1);
+
+ if (rc < 0)
+ goto failure;
+
+ head += rc;
+ token = next;
+ }
+
+ /* buffer must have been null terminated by
+ `android_url_encode'. */
+ xfree (copy);
+ return buffer;
+
+ failure:
+ xfree (copy);
+ return NULL;
+}
+
+#endif /* 0 */
+
+/* Return the current user's ``home'' directory, which is actually the
+ app data directory on Android. */
+
+const char *
+android_get_home_directory (void)
+{
+ return android_files_dir;
+}
+
+/* Return the name of the file behind a file descriptor FD by reading
+ /proc/self/fd/. Value is allocated memory holding the file name
+ upon success, and 0 upon failure. */
+
+static char *
+android_proc_name (int fd)
+{
+ char format[sizeof "/proc/self/fd/"
+ + INT_STRLEN_BOUND (int)];
+ static struct allocator allocator = {
+ /* Fill the allocator with C library malloc functions. xmalloc
+ and so aren't thread safe. */
+ malloc, realloc, free, NULL,
+ };
+
+ sprintf (format, "/proc/self/fd/%d", fd);
+ return careadlinkat (AT_FDCWD, format, NULL, 0,
+ &allocator, readlinkat);
+}
+
+/* Try to guarantee the existence of the `lib' directory within the
+ parent directory of the application files directory.
+
+ If `/data/data/org.gnu.emacs/lib' (or
+ `/data/user/N/org.gnu.emacs/lib') does not exist or is a dangling
+ symbolic link, create a symlink from it to the library
+ directory.
+
+ Newer versions of Android don't create this link by default, making
+ it difficult to locate the directory containing Emacs library
+ files, particularly from scripts in other programs sharing the same
+ user ID as Emacs that don't have access to `exec-path'. */
+
+static void
+android_create_lib_link (void)
+{
+ char *filename;
+ char lib_directory[PATH_MAX];
+ int fd;
+
+ /* Find the directory containing the files directory. */
+ filename = dirname (android_files_dir);
+ if (!filename)
+ goto failure;
+
+ /* Now make `lib_directory' the name of the library directory
+ within. */
+ snprintf (lib_directory, PATH_MAX, "%s/lib", filename);
+
+ /* Try to open this directory. */
+ fd = open (lib_directory, O_DIRECTORY);
+
+ /* If the directory can be opened normally, close it and return
+ now. */
+ if (fd >= 0)
+ goto success;
+
+ /* Try to unlink the directory in case it's a dangling symbolic
+ link. */
+ unlink (lib_directory);
+
+ /* Otherwise, try to symlink lib_directory to the actual library
+ directory. */
+
+ if (symlink (android_lib_dir, lib_directory))
+ /* Print a warning message if creating the link fails. */
+ __android_log_print (ANDROID_LOG_WARN, __func__,
+ "Failed to create symbolic link from"
+ " application library directory `%s'"
+ " to its actual location at `%s'",
+ lib_directory, android_files_dir);
+
+ success:
+ close (fd);
+ failure:
+ return;
+}
+
+
+
+/* JNI functions called by Java. */
+
+#ifdef __clang__
+#pragma clang diagnostic push
+#pragma clang diagnostic ignored "-Wmissing-prototypes"
+#else
+#pragma GCC diagnostic push
+#pragma GCC diagnostic ignored "-Wmissing-prototypes"
+#endif
+
+JNIEXPORT jint JNICALL
+NATIVE_NAME (dup) (JNIEnv *env, jobject object, jint fd)
+{
+ JNI_STACK_ALIGNMENT_PROLOGUE;
+
+ return dup (fd);
+}
+
+JNIEXPORT jint JNICALL
+NATIVE_NAME (close) (JNIEnv *env, jobject object, jint fd)
+{
+ JNI_STACK_ALIGNMENT_PROLOGUE;
+
+ return close (fd);
+}
+
+JNIEXPORT jstring JNICALL
+NATIVE_NAME (getFingerprint) (JNIEnv *env, jobject object)
+{
+ JNI_STACK_ALIGNMENT_PROLOGUE;
+
+ char buffer[sizeof fingerprint * 2 + 1];
+
+ memset (buffer, 0, sizeof buffer);
+ hexbuf_digest (buffer, (char *) fingerprint,
+ sizeof fingerprint);
+
+ return (*env)->NewStringUTF (env, buffer);
+}
+
+JNIEXPORT void JNICALL
+NATIVE_NAME (setEmacsParams) (JNIEnv *env, jobject object,
+ jobject local_asset_manager,
+ jobject files_dir, jobject libs_dir,
+ jobject cache_dir,
+ jfloat pixel_density_x,
+ jfloat pixel_density_y,
+ jfloat scaled_density,
+ jobject class_path,
+ jobject emacs_service_object,
+ jint api_level)
+{
+ JNI_STACK_ALIGNMENT_PROLOGUE;
+
+ int pipefd[2];
+ pthread_t thread;
+ const char *java_string;
+ struct stat statb;
+
+#ifdef THREADS_ENABLED
+ /* Save the Java VM. */
+ if ((*env)->GetJavaVM (env, &android_jvm))
+ emacs_abort ();
+#endif /* THREADS_ENABLED */
+
+ /* Set the Android API level early, as it is used by
+ `android_vfs_init'. */
+ android_api_level = api_level;
+
+ /* This function should only be called from the main thread. */
+ android_pixel_density_x = pixel_density_x;
+ android_pixel_density_y = pixel_density_y;
+ android_scaled_pixel_density = scaled_density;
+
+ __android_log_print (ANDROID_LOG_INFO, __func__,
+ "Initializing "PACKAGE_STRING"...\nPlease report bugs to "
+ PACKAGE_BUGREPORT". Thanks.\n");
+
+ if (emacs_service_object)
+ {
+ /* Create a pipe and duplicate it to stdout and stderr. Next,
+ make a thread that prints stderr to the system log.
+
+ Notice that this function is called in one of two ways. The
+ first is when Emacs is being started as a GUI application by
+ the system, and the second is when Emacs is being started by
+ libandroid-emacs.so as an ordinary noninteractive Emacs.
+
+ In the second case, stderr is usually connected to a PTY, so
+ this is unnecessary. */
+
+ if (pipe2 (pipefd, O_CLOEXEC) < 0)
+ emacs_abort ();
+
+ if (dup2 (pipefd[1], 2) < 0)
+ emacs_abort ();
+ close (pipefd[1]);
+
+ if (pthread_create (&thread, NULL, android_run_debug_thread,
+ (void *) (intptr_t) pipefd[0]))
+ emacs_abort ();
+ }
+
+ /* Now set the path to the site load directory. */
+
+ java_string = (*env)->GetStringUTFChars (env, (jstring) files_dir,
+ NULL);
+
+ if (!java_string)
+ emacs_abort ();
+
+ android_files_dir = strdup ((const char *) java_string);
+
+ if (!android_files_dir)
+ emacs_abort ();
+
+ (*env)->ReleaseStringUTFChars (env, (jstring) files_dir,
+ java_string);
+
+ java_string = (*env)->GetStringUTFChars (env, (jstring) libs_dir,
+ NULL);
+
+ if (!java_string)
+ emacs_abort ();
+
+ android_lib_dir = strdup ((const char *) java_string);
+
+ if (!android_files_dir)
+ emacs_abort ();
+
+ (*env)->ReleaseStringUTFChars (env, (jstring) libs_dir,
+ java_string);
+
+ java_string = (*env)->GetStringUTFChars (env, (jstring) cache_dir,
+ NULL);
+
+ if (!java_string)
+ emacs_abort ();
+
+ android_cache_dir = strdup ((const char *) java_string);
+
+ if (!android_files_dir)
+ emacs_abort ();
+
+ (*env)->ReleaseStringUTFChars (env, (jstring) cache_dir,
+ java_string);
+
+ if (class_path)
+ {
+ java_string = (*env)->GetStringUTFChars (env, (jstring) class_path,
+ NULL);
+
+ if (!java_string)
+ emacs_abort ();
+
+ android_class_path = strdup ((const char *) java_string);
+
+ if (!android_class_path)
+ emacs_abort ();
+
+ (*env)->ReleaseStringUTFChars (env, (jstring) class_path,
+ java_string);
+ }
+
+ /* Derive the installation date from the modification time of the
+ file constitituing the class path. */
+
+ emacs_installation_time = invalid_timespec ();
+
+ if (class_path)
+ {
+ if (!stat (android_class_path, &statb))
+ emacs_installation_time = get_stat_mtime (&statb);
+ }
+
+ /* Calculate the site-lisp path. */
+
+ android_site_load_path = malloc (PATH_MAX + 1);
+
+ if (!android_site_load_path)
+ emacs_abort ();
+
+ android_game_path = malloc (PATH_MAX + 1);
+
+ if (!android_game_path)
+ emacs_abort ();
+
+ snprintf (android_site_load_path, PATH_MAX, "%s/site-lisp",
+ android_files_dir);
+ snprintf (android_game_path, PATH_MAX, "%s/scores", android_files_dir);
+
+ __android_log_print (ANDROID_LOG_INFO, __func__,
+ "Site-lisp directory: %s\n"
+ "Files directory: %s\n"
+ "Native code directory: %s\n"
+ "Game score path: %s\n"
+ "Class path: %s\n",
+ android_site_load_path,
+ android_files_dir,
+ android_lib_dir, android_game_path,
+ (android_class_path
+ ? android_class_path
+ : "None"));
+
+ if (android_class_path)
+ /* Set EMACS_CLASS_PATH to the class path where
+ EmacsNoninteractive can be found. */
+ setenv ("EMACS_CLASS_PATH", android_class_path, 1);
+
+ /* Set LD_LIBRARY_PATH to an appropriate value. */
+ setenv ("LD_LIBRARY_PATH", android_lib_dir, 1);
+
+ /* EMACS_LD_LIBRARY_PATH records the location of the app library
+ directory. android-emacs refers to this, since users have valid
+ reasons for changing LD_LIBRARY_PATH to a value that precludes
+ the possibility of Java locating libemacs later. */
+ setenv ("EMACS_LD_LIBRARY_PATH", android_lib_dir, 1);
+
+ /* If the system is Android 5.0 or later, set LANG to en_US.utf8,
+ which is understood by the C library. In other instances set it
+ to C, a meaningless value, for good measure. */
+
+ if (emacs_service_object)
+ {
+ if (api_level >= 21)
+ setenv ("LANG", "en_US.utf8", 1);
+ else
+ setenv ("LANG", "C", 1);
+ }
+
+ /* Make a reference to the Emacs service. */
+
+ if (emacs_service_object)
+ {
+ emacs_service = (*env)->NewGlobalRef (env, emacs_service_object);
+
+ if (!emacs_service)
+ emacs_abort ();
+
+ /* If the service is set this Emacs is being initialized as part
+ of the Emacs application itself.
+
+ Try to create a symlink from where scripts expect Emacs to
+ place its library files to the directory that actually holds
+ them; earlier versions of Android used to do this
+ automatically, but that feature has been removed. */
+
+ android_create_lib_link ();
+ }
+
+ /* Set up events. */
+ android_init_events ();
+
+ /* Set up the Android virtual filesystem layer. */
+ android_vfs_init (env, local_asset_manager);
+
+ /* OK, setup is now complete. The caller may call initEmacs
+ now. */
+}
+
+JNIEXPORT jobject JNICALL
+NATIVE_NAME (getProcName) (JNIEnv *env, jobject object, jint fd)
+{
+ JNI_STACK_ALIGNMENT_PROLOGUE;
+
+ char *buffer;
+ size_t length;
+ jbyteArray array;
+
+ buffer = android_proc_name (fd);
+ if (!buffer)
+ return NULL;
+
+ /* Return a byte array, as Java strings cannot always encode file
+ names. */
+ length = strlen (buffer);
+ array = (*env)->NewByteArray (env, length);
+ if (!array)
+ goto finish;
+
+ (*env)->SetByteArrayRegion (env, array, 0, length,
+ (jbyte *) buffer);
+
+ finish:
+ free (buffer);
+ return array;
+}
+
+/* Initialize service_class, aborting if something goes wrong. */
+
+static void
+android_init_emacs_service (void)
+{
+ jclass old;
+
+ service_class.class
+ = (*android_java_env)->FindClass (android_java_env,
+ "org/gnu/emacs/EmacsService");
+ eassert (service_class.class);
+
+ old = service_class.class;
+ service_class.class
+ = (jclass) (*android_java_env)->NewGlobalRef (android_java_env,
+ (jobject) old);
+ ANDROID_DELETE_LOCAL_REF (old);
+
+ if (!service_class.class)
+ emacs_abort ();
+
+#define FIND_METHOD(c_name, name, signature) \
+ service_class.c_name \
+ = (*android_java_env)->GetMethodID (android_java_env, \
+ service_class.class, \
+ name, signature); \
+ eassert (service_class.c_name);
+
+ FIND_METHOD (fill_rectangle, "fillRectangle",
+ "(Lorg/gnu/emacs/EmacsDrawable;"
+ "Lorg/gnu/emacs/EmacsGC;IIII)V");
+ FIND_METHOD (fill_polygon, "fillPolygon",
+ "(Lorg/gnu/emacs/EmacsDrawable;"
+ "Lorg/gnu/emacs/EmacsGC;"
+ "[Landroid/graphics/Point;)V");
+ FIND_METHOD (draw_rectangle, "drawRectangle",
+ "(Lorg/gnu/emacs/EmacsDrawable;"
+ "Lorg/gnu/emacs/EmacsGC;IIII)V");
+ FIND_METHOD (draw_line, "drawLine",
+ "(Lorg/gnu/emacs/EmacsDrawable;"
+ "Lorg/gnu/emacs/EmacsGC;IIII)V");
+ FIND_METHOD (draw_point, "drawPoint",
+ "(Lorg/gnu/emacs/EmacsDrawable;"
+ "Lorg/gnu/emacs/EmacsGC;II)V");
+ FIND_METHOD (ring_bell, "ringBell", "(I)V");
+ FIND_METHOD (query_tree, "queryTree",
+ "(Lorg/gnu/emacs/EmacsWindow;)[S");
+ FIND_METHOD (get_screen_width, "getScreenWidth", "(Z)I");
+ FIND_METHOD (get_screen_height, "getScreenHeight", "(Z)I");
+ FIND_METHOD (detect_mouse, "detectMouse", "()Z");
+ FIND_METHOD (detect_keyboard, "detectKeyboard", "()Z");
+ FIND_METHOD (name_keysym, "nameKeysym", "(I)Ljava/lang/String;");
+ FIND_METHOD (browse_url, "browseUrl", "(Ljava/lang/String;Z)"
+ "Ljava/lang/String;");
+ FIND_METHOD (restart_emacs, "restartEmacs", "()V");
+ FIND_METHOD (update_ic, "updateIC",
+ "(Lorg/gnu/emacs/EmacsWindow;IIII)V");
+ FIND_METHOD (reset_ic, "resetIC",
+ "(Lorg/gnu/emacs/EmacsWindow;I)V");
+ FIND_METHOD (open_content_uri, "openContentUri",
+ "([BZZZ)I");
+ FIND_METHOD (check_content_uri, "checkContentUri",
+ "(Ljava/lang/String;ZZ)Z");
+ FIND_METHOD (query_battery, "queryBattery", "()[J");
+ FIND_METHOD (update_extracted_text, "updateExtractedText",
+ "(Lorg/gnu/emacs/EmacsWindow;"
+ "Landroid/view/inputmethod/ExtractedText;I)V");
+ FIND_METHOD (update_cursor_anchor_info, "updateCursorAnchorInfo",
+ "(Lorg/gnu/emacs/EmacsWindow;FFFF)V");
+ FIND_METHOD (get_document_authorities, "getDocumentAuthorities",
+ "()[Ljava/lang/String;");
+ FIND_METHOD (request_directory_access, "requestDirectoryAccess",
+ "()I");
+ FIND_METHOD (get_document_trees, "getDocumentTrees",
+ "([B)[Ljava/lang/String;");
+ FIND_METHOD (document_id_from_name, "documentIdFromName",
+ "(Ljava/lang/String;Ljava/lang/String;"
+ "[Ljava/lang/String;)I");
+ FIND_METHOD (get_tree_uri, "getTreeUri",
+ "(Ljava/lang/String;Ljava/lang/String;)"
+ "Ljava/lang/String;");
+ FIND_METHOD (stat_document, "statDocument",
+ "(Ljava/lang/String;Ljava/lang/String;Z)[J");
+ FIND_METHOD (access_document, "accessDocument",
+ "(Ljava/lang/String;Ljava/lang/String;Z)I");
+ FIND_METHOD (open_document_directory, "openDocumentDirectory",
+ "(Ljava/lang/String;Ljava/lang/String;)"
+ "Landroid/database/Cursor;");
+ FIND_METHOD (read_directory_entry, "readDirectoryEntry",
+ "(Landroid/database/Cursor;)Lorg/gnu/emacs/"
+ "EmacsDirectoryEntry;");
+ FIND_METHOD (open_document, "openDocument",
+ "(Ljava/lang/String;Ljava/lang/String;ZZZ)"
+ "Landroid/os/ParcelFileDescriptor;");
+ FIND_METHOD (create_document, "createDocument",
+ "(Ljava/lang/String;Ljava/lang/String;"
+ "Ljava/lang/String;)Ljava/lang/String;");
+ FIND_METHOD (create_directory, "createDirectory",
+ "(Ljava/lang/String;Ljava/lang/String;"
+ "Ljava/lang/String;)Ljava/lang/String;");
+ FIND_METHOD (delete_document, "deleteDocument",
+ "(Ljava/lang/String;Ljava/lang/String;"
+ "Ljava/lang/String;)I");
+ FIND_METHOD (rename_document, "renameDocument",
+ "(Ljava/lang/String;Ljava/lang/String;"
+ "Ljava/lang/String;Ljava/lang/String;)I");
+ FIND_METHOD (move_document, "moveDocument",
+ "(Ljava/lang/String;Ljava/lang/String;"
+ "Ljava/lang/String;Ljava/lang/String;"
+ "Ljava/lang/String;)Ljava/lang/String;");
+ FIND_METHOD (valid_authority, "validAuthority",
+ "(Ljava/lang/String;)Z");
+ FIND_METHOD (external_storage_available,
+ "externalStorageAvailable", "()Z");
+ FIND_METHOD (request_storage_access,
+ "requestStorageAccess", "()V");
+ FIND_METHOD (cancel_notification,
+ "cancelNotification", "(Ljava/lang/String;)V");
+#undef FIND_METHOD
+}
+
+static void
+android_init_emacs_pixmap (void)
+{
+ jclass old;
+
+ pixmap_class.class
+ = (*android_java_env)->FindClass (android_java_env,
+ "org/gnu/emacs/EmacsPixmap");
+ eassert (pixmap_class.class);
+
+ old = pixmap_class.class;
+ pixmap_class.class
+ = (jclass) (*android_java_env)->NewGlobalRef (android_java_env,
+ (jobject) old);
+ ANDROID_DELETE_LOCAL_REF (old);
+
+ if (!pixmap_class.class)
+ emacs_abort ();
+
+#define FIND_METHOD(c_name, name, signature) \
+ pixmap_class.c_name \
+ = (*android_java_env)->GetMethodID (android_java_env, \
+ pixmap_class.class, \
+ name, signature); \
+ eassert (pixmap_class.c_name);
+
+ FIND_METHOD (constructor_mutable, "<init>", "(SIII)V");
+
+#undef FIND_METHOD
+}
+
+static void
+android_init_graphics_point (void)
+{
+ jclass old;
+
+ point_class.class
+ = (*android_java_env)->FindClass (android_java_env,
+ "android/graphics/Point");
+ eassert (point_class.class);
+
+ old = point_class.class;
+ point_class.class
+ = (jclass) (*android_java_env)->NewGlobalRef (android_java_env,
+ (jobject) old);
+ ANDROID_DELETE_LOCAL_REF (old);
+
+ if (!point_class.class)
+ emacs_abort ();
+
+#define FIND_METHOD(c_name, name, signature) \
+ point_class.c_name \
+ = (*android_java_env)->GetMethodID (android_java_env, \
+ point_class.class, \
+ name, signature); \
+ eassert (point_class.c_name);
+
+ FIND_METHOD (constructor, "<init>", "(II)V");
+#undef FIND_METHOD
+}
+
+static void
+android_init_emacs_drawable (void)
+{
+ jclass old;
+
+ drawable_class.class
+ = (*android_java_env)->FindClass (android_java_env,
+ "org/gnu/emacs/EmacsDrawable");
+ eassert (drawable_class.class);
+
+ old = drawable_class.class;
+ drawable_class.class
+ = (jclass) (*android_java_env)->NewGlobalRef (android_java_env,
+ (jobject) old);
+ ANDROID_DELETE_LOCAL_REF (old);
+
+ if (!drawable_class.class)
+ emacs_abort ();
+
+#define FIND_METHOD(c_name, name, signature) \
+ drawable_class.c_name \
+ = (*android_java_env)->GetMethodID (android_java_env, \
+ drawable_class.class, \
+ name, signature); \
+ eassert (drawable_class.c_name);
+
+ FIND_METHOD (get_bitmap, "getBitmap", "()Landroid/graphics/Bitmap;");
+#undef FIND_METHOD
+}
+
+static void
+android_init_emacs_window (void)
+{
+ jclass old;
+
+ window_class.class
+ = (*android_java_env)->FindClass (android_java_env,
+ "org/gnu/emacs/EmacsWindow");
+ eassert (window_class.class);
+
+ old = window_class.class;
+ window_class.class
+ = (jclass) (*android_java_env)->NewGlobalRef (android_java_env,
+ (jobject) old);
+ ANDROID_DELETE_LOCAL_REF (old);
+
+ if (!window_class.class)
+ emacs_abort ();
+
+#define FIND_METHOD(c_name, name, signature) \
+ window_class.c_name \
+ = (*android_java_env)->GetMethodID (android_java_env, \
+ window_class.class, \
+ name, signature); \
+ eassert (window_class.c_name);
+
+ FIND_METHOD (swap_buffers, "swapBuffers", "()V");
+ FIND_METHOD (toggle_on_screen_keyboard,
+ "toggleOnScreenKeyboard", "(Z)V");
+ FIND_METHOD (lookup_string, "lookupString", "(I)Ljava/lang/String;");
+ FIND_METHOD (set_fullscreen, "setFullscreen", "(Z)V");
+ FIND_METHOD (change_window_background, "changeWindowBackground",
+ "(I)V");
+ FIND_METHOD (reparent_to, "reparentTo",
+ "(Lorg/gnu/emacs/EmacsWindow;II)V");
+ FIND_METHOD (map_window, "mapWindow", "()V");
+ FIND_METHOD (unmap_window, "unmapWindow", "()V");
+ FIND_METHOD (resize_window, "resizeWindow", "(II)V");
+ FIND_METHOD (move_window, "moveWindow", "(II)V");
+ FIND_METHOD (make_input_focus, "makeInputFocus", "(J)V");
+ FIND_METHOD (raise, "raise", "()V");
+ FIND_METHOD (lower, "lower", "()V");
+ FIND_METHOD (reconfigure, "reconfigure", "(Lorg/gnu/emacs/EmacsWindow;I)V");
+ FIND_METHOD (get_window_geometry, "getWindowGeometry",
+ "()[I");
+ FIND_METHOD (translate_coordinates, "translateCoordinates",
+ "(II)[I");
+ FIND_METHOD (set_dont_focus_on_map, "setDontFocusOnMap", "(Z)V");
+ FIND_METHOD (set_dont_accept_focus, "setDontAcceptFocus", "(Z)V");
+ FIND_METHOD (define_cursor, "defineCursor",
+ "(Lorg/gnu/emacs/EmacsCursor;)V");
+ /* In spite of the declaration of this function being located within
+ EmacsDrawable, the ID of the `damage_rect' method is retrieved
+ from EmacsWindow, which avoids virtual function dispatch within
+ android_damage_window. */
+ FIND_METHOD (damage_rect, "damageRect", "(IIII)V");
+ FIND_METHOD (recreate_activity, "recreateActivity", "()V");
+ FIND_METHOD (clear_window, "clearWindow", "()V");
+ FIND_METHOD (clear_area, "clearArea", "(IIII)V");
+#undef FIND_METHOD
+}
+
+static void
+android_init_emacs_cursor (void)
+{
+ jclass old;
+
+ cursor_class.class
+ = (*android_java_env)->FindClass (android_java_env,
+ "org/gnu/emacs/EmacsCursor");
+ eassert (cursor_class.class);
+
+ old = cursor_class.class;
+ cursor_class.class
+ = (jclass) (*android_java_env)->NewGlobalRef (android_java_env,
+ (jobject) old);
+ ANDROID_DELETE_LOCAL_REF (old);
+
+ if (!cursor_class.class)
+ emacs_abort ();
+
+#define FIND_METHOD(c_name, name, signature) \
+ cursor_class.c_name \
+ = (*android_java_env)->GetMethodID (android_java_env, \
+ cursor_class.class, \
+ name, signature); \
+ eassert (cursor_class.c_name);
+
+ FIND_METHOD (constructor, "<init>", "(SI)V");
+#undef FIND_METHOD
+}
+
+static void
+android_init_key_character_map (void)
+{
+ jclass old;
+
+ key_character_map_class.class
+ = (*android_java_env)->FindClass (android_java_env,
+ "android/view/KeyCharacterMap");
+ eassert (key_character_map_class.class);
+
+ old = key_character_map_class.class;
+ key_character_map_class.class
+ = (jclass) (*android_java_env)->NewGlobalRef (android_java_env,
+ (jobject) old);
+ ANDROID_DELETE_LOCAL_REF (old);
+
+ if (!key_character_map_class.class)
+ emacs_abort ();
+
+ key_character_map_class.get_dead_char
+ = (*android_java_env)->GetStaticMethodID (android_java_env,
+ key_character_map_class.class,
+ "getDeadChar", "(II)I");
+ eassert (key_character_map_class.get_dead_char);
+}
+
+JNIEXPORT void JNICALL
+NATIVE_NAME (initEmacs) (JNIEnv *env, jobject object, jarray argv,
+ jobject dump_file_object)
+{
+ /* android_emacs_init is not main, so GCC is not nice enough to add
+ the stack alignment prologue.
+
+ Unfortunately for us, dalvik on Android 4.0.x calls native code
+ with a 4 byte aligned stack, so this prologue must be inserted
+ before each function exported via JNI. */
+
+ JNI_STACK_ALIGNMENT_PROLOGUE;
+
+ char **c_argv;
+ jsize nelements, i;
+ jobject argument;
+ const char *c_argument;
+ char *dump_file;
+
+ android_java_env = env;
+
+ nelements = (*env)->GetArrayLength (env, argv);
+ c_argv = alloca (sizeof *c_argv * (nelements + 1));
+
+ for (i = 0; i < nelements; ++i)
+ {
+ argument = (*env)->GetObjectArrayElement (env, argv, i);
+ c_argument = (*env)->GetStringUTFChars (env, (jstring) argument,
+ NULL);
+
+ if (!c_argument)
+ emacs_abort ();
+
+ /* Note that c_argument is in ``modified UTF-8 encoding'', but
+ we don't care as NUL bytes are not being specified inside. */
+ c_argv[i] = alloca (strlen (c_argument) + 1);
+ strcpy (c_argv[i], c_argument);
+ (*env)->ReleaseStringUTFChars (env, (jstring) argument, c_argument);
+ }
+
+ c_argv[nelements] = NULL;
+
+ android_init_emacs_service ();
+ android_init_emacs_pixmap ();
+ android_init_graphics_point ();
+ android_init_emacs_drawable ();
+ android_init_emacs_window ();
+ android_init_emacs_cursor ();
+ android_init_key_character_map ();
+
+ /* Set HOME to the app data directory. */
+ setenv ("HOME", android_files_dir, 1);
+
+ /* Set TMPDIR to the temporary files directory. */
+ setenv ("TMPDIR", android_cache_dir, 1);
+
+ /* And finally set "SHELL" to /system/bin/sh. Otherwise, some
+ programs will look for /bin/sh, which is problematic. */
+ setenv ("SHELL", "/system/bin/sh", 1);
+
+ /* Set the cwd to that directory as well. */
+ if (chdir (android_files_dir))
+ __android_log_print (ANDROID_LOG_WARN, __func__,
+ "chdir: %s", strerror (errno));
+
+ /* Initialize the Android GUI as long as the service object was
+ set. */
+
+ if (emacs_service)
+ android_init_gui = true;
+
+ /* Now see if a dump file has been specified and should be used. */
+ dump_file = NULL;
+
+ if (dump_file_object)
+ {
+ c_argument
+ = (*env)->GetStringUTFChars (env, (jstring) dump_file_object,
+ NULL);
+
+ /* Copy the Java string data once. */
+ dump_file = strdup (c_argument);
+
+ /* Release the Java string data. */
+ (*env)->ReleaseStringUTFChars (env, (jstring) dump_file_object,
+ c_argument);
+ }
+
+ /* Delete local references to objects that are no longer needed. */
+ ANDROID_DELETE_LOCAL_REF (argv);
+ ANDROID_DELETE_LOCAL_REF (dump_file_object);
+
+ /* Restore the signal mask at the time of startup if it was changed
+ to block unwanted signals from reaching system threads. */
+
+ if (signal_mask_changed_p)
+ pthread_sigmask (SIG_SETMASK, &startup_signal_mask, NULL);
+
+ /* Now start Emacs proper. */
+ android_emacs_init (nelements, c_argv, dump_file);
+
+ /* android_emacs_init should never return. */
+ emacs_abort ();
+}
+
+JNIEXPORT void JNICALL
+NATIVE_NAME (emacsAbort) (JNIEnv *env, jobject object)
+{
+ JNI_STACK_ALIGNMENT_PROLOGUE;
+
+ emacs_abort ();
+}
+
+JNIEXPORT void JNICALL
+NATIVE_NAME (quit) (JNIEnv *env, jobject object)
+{
+ JNI_STACK_ALIGNMENT_PROLOGUE;
+
+ __android_log_print (ANDROID_LOG_VERBOSE, __func__,
+ "Sending SIGIO and setting Vquit_flag");
+
+ /* Raise sigio to interrupt anything that could be reading
+ input. */
+ Vquit_flag = Qt;
+ kill (getpid (), SIGIO);
+}
+
+/* Call shut_down_emacs subsequent to a call to the service's
+ onDestroy callback. CLOSURE is ignored. */
+
+static void
+android_shut_down_emacs (void *closure)
+{
+ __android_log_print (ANDROID_LOG_INFO, __func__,
+ "The Emacs service is being shut down");
+ shut_down_emacs (0, Qnil);
+}
+
+JNIEXPORT void JNICALL
+NATIVE_NAME (shutDownEmacs) (JNIEnv *env, jobject object)
+{
+ JNI_STACK_ALIGNMENT_PROLOGUE;
+
+ android_run_in_emacs_thread (android_shut_down_emacs, NULL);
+}
+
+/* Carry out garbage collection and clear all image caches on the
+ Android terminal. Called when the system has depleted most of its
+ memory and desires that background processes release unused
+ core. */
+
+static void
+android_on_low_memory (void *closure)
+{
+ Fclear_image_cache (Qt, Qnil);
+ garbage_collect ();
+}
+
+JNIEXPORT void JNICALL
+NATIVE_NAME (onLowMemory) (JNIEnv *env, jobject object)
+{
+ JNI_STACK_ALIGNMENT_PROLOGUE;
+
+ android_run_in_emacs_thread (android_on_low_memory, NULL);
+}
+
+JNIEXPORT jlong JNICALL
+NATIVE_NAME (sendConfigureNotify) (JNIEnv *env, jobject object,
+ jshort window, jlong time,
+ jint x, jint y, jint width,
+ jint height)
+{
+ JNI_STACK_ALIGNMENT_PROLOGUE;
+
+ union android_event event;
+
+ event.xconfigure.type = ANDROID_CONFIGURE_NOTIFY;
+ event.xconfigure.serial = ++event_serial;
+ event.xconfigure.window = window;
+ event.xconfigure.time = time;
+ event.xconfigure.x = x;
+ event.xconfigure.y = y;
+ event.xconfigure.width = width;
+ event.xconfigure.height = height;
+
+ android_write_event (&event);
+ return event_serial;
+}
+
+JNIEXPORT jlong JNICALL
+NATIVE_NAME (sendKeyPress) (JNIEnv *env, jobject object,
+ jshort window, jlong time,
+ jint state, jint keycode,
+ jint unicode_char)
+{
+ JNI_STACK_ALIGNMENT_PROLOGUE;
+
+ union android_event event;
+
+ event.xkey.type = ANDROID_KEY_PRESS;
+ event.xkey.serial = ++event_serial;
+ event.xkey.window = window;
+ event.xkey.time = time;
+ event.xkey.state = state;
+ event.xkey.keycode = keycode;
+ event.xkey.unicode_char = unicode_char;
+ event.xkey.counter = 0;
+
+ android_write_event (&event);
+ return event_serial;
+}
+
+JNIEXPORT jlong JNICALL
+NATIVE_NAME (sendKeyRelease) (JNIEnv *env, jobject object,
+ jshort window, jlong time,
+ jint state, jint keycode,
+ jint unicode_char)
+{
+ JNI_STACK_ALIGNMENT_PROLOGUE;
+
+ union android_event event;
+
+ event.xkey.type = ANDROID_KEY_RELEASE;
+ event.xkey.serial = ++event_serial;
+ event.xkey.window = window;
+ event.xkey.time = time;
+ event.xkey.state = state;
+ event.xkey.keycode = keycode;
+ event.xkey.unicode_char = unicode_char;
+ event.xkey.counter = 0;
+
+ android_write_event (&event);
+ return event_serial;
+}
+
+JNIEXPORT jlong JNICALL
+NATIVE_NAME (sendFocusIn) (JNIEnv *env, jobject object,
+ jshort window, jlong time)
+{
+ JNI_STACK_ALIGNMENT_PROLOGUE;
+
+ union android_event event;
+
+ event.xfocus.type = ANDROID_FOCUS_IN;
+ event.xfocus.serial = ++event_serial;
+ event.xfocus.window = window;
+ event.xfocus.time = time;
+
+ android_write_event (&event);
+ return event_serial;
+}
+
+JNIEXPORT jlong JNICALL
+NATIVE_NAME (sendFocusOut) (JNIEnv *env, jobject object,
+ jshort window, jlong time)
+{
+ JNI_STACK_ALIGNMENT_PROLOGUE;
+
+ union android_event event;
+
+ event.xfocus.type = ANDROID_FOCUS_OUT;
+ event.xfocus.serial = ++event_serial;
+ event.xfocus.window = window;
+ event.xfocus.time = time;
+
+ android_write_event (&event);
+ return ++event_serial;
+}
+
+JNIEXPORT jlong JNICALL
+NATIVE_NAME (sendWindowAction) (JNIEnv *env, jobject object,
+ jshort window, jint action)
+{
+ JNI_STACK_ALIGNMENT_PROLOGUE;
+
+ union android_event event;
+
+ event.xaction.type = ANDROID_WINDOW_ACTION;
+ event.xaction.serial = ++event_serial;
+ event.xaction.window = window;
+ event.xaction.action = action;
+
+ android_write_event (&event);
+ return event_serial;
+}
+
+JNIEXPORT jlong JNICALL
+NATIVE_NAME (sendEnterNotify) (JNIEnv *env, jobject object,
+ jshort window, jint x, jint y,
+ jlong time)
+{
+ JNI_STACK_ALIGNMENT_PROLOGUE;
+
+ union android_event event;
+
+ event.xcrossing.type = ANDROID_ENTER_NOTIFY;
+ event.xcrossing.serial = ++event_serial;
+ event.xcrossing.window = window;
+ event.xcrossing.x = x;
+ event.xcrossing.y = y;
+ event.xcrossing.time = time;
+
+ android_write_event (&event);
+ return event_serial;
+}
+
+JNIEXPORT jlong JNICALL
+NATIVE_NAME (sendLeaveNotify) (JNIEnv *env, jobject object,
+ jshort window, jint x, jint y,
+ jlong time)
+{
+ JNI_STACK_ALIGNMENT_PROLOGUE;
+
+ union android_event event;
+
+ event.xcrossing.type = ANDROID_LEAVE_NOTIFY;
+ event.xcrossing.serial = ++event_serial;
+ event.xcrossing.window = window;
+ event.xcrossing.x = x;
+ event.xcrossing.y = y;
+ event.xcrossing.time = time;
+
+ android_write_event (&event);
+ return event_serial;
+}
+
+JNIEXPORT jlong JNICALL
+NATIVE_NAME (sendMotionNotify) (JNIEnv *env, jobject object,
+ jshort window, jint x, jint y,
+ jlong time)
+{
+ JNI_STACK_ALIGNMENT_PROLOGUE;
+
+ union android_event event;
+
+ event.xmotion.type = ANDROID_MOTION_NOTIFY;
+ event.xmotion.serial = ++event_serial;
+ event.xmotion.window = window;
+ event.xmotion.x = x;
+ event.xmotion.y = y;
+ event.xmotion.time = time;
+
+ android_write_event (&event);
+ return event_serial;
+}
+
+JNIEXPORT jlong JNICALL
+NATIVE_NAME (sendButtonPress) (JNIEnv *env, jobject object,
+ jshort window, jint x, jint y,
+ jlong time, jint state,
+ jint button)
+{
+ JNI_STACK_ALIGNMENT_PROLOGUE;
+
+ union android_event event;
+
+ event.xbutton.type = ANDROID_BUTTON_PRESS;
+ event.xbutton.serial = ++event_serial;
+ event.xbutton.window = window;
+ event.xbutton.x = x;
+ event.xbutton.y = y;
+ event.xbutton.time = time;
+ event.xbutton.state = state;
+ event.xbutton.button = button;
+
+ android_write_event (&event);
+ return event_serial;
+}
+
+JNIEXPORT jlong JNICALL
+NATIVE_NAME (sendButtonRelease) (JNIEnv *env, jobject object,
+ jshort window, jint x, jint y,
+ jlong time, jint state,
+ jint button)
+{
+ JNI_STACK_ALIGNMENT_PROLOGUE;
+
+ union android_event event;
+
+ event.xbutton.type = ANDROID_BUTTON_RELEASE;
+ event.xbutton.serial = ++event_serial;
+ event.xbutton.window = window;
+ event.xbutton.x = x;
+ event.xbutton.y = y;
+ event.xbutton.time = time;
+ event.xbutton.state = state;
+ event.xbutton.button = button;
+
+ android_write_event (&event);
+ return event_serial;
+}
+
+JNIEXPORT jlong JNICALL
+NATIVE_NAME (sendTouchDown) (JNIEnv *env, jobject object,
+ jshort window, jint x, jint y,
+ jlong time, jint pointer_id,
+ jint flags)
+{
+ JNI_STACK_ALIGNMENT_PROLOGUE;
+
+ union android_event event;
+
+ event.touch.type = ANDROID_TOUCH_DOWN;
+ event.touch.serial = ++event_serial;
+ event.touch.window = window;
+ event.touch.x = x;
+ event.touch.y = y;
+ event.touch.time = time;
+ event.touch.pointer_id = pointer_id;
+ event.touch.flags = flags;
+
+ android_write_event (&event);
+ return event_serial;
+}
+
+JNIEXPORT jlong JNICALL
+NATIVE_NAME (sendTouchUp) (JNIEnv *env, jobject object,
+ jshort window, jint x, jint y,
+ jlong time, jint pointer_id,
+ jint flags)
+{
+ JNI_STACK_ALIGNMENT_PROLOGUE;
+
+ union android_event event;
+
+ event.touch.type = ANDROID_TOUCH_UP;
+ event.touch.serial = ++event_serial;
+ event.touch.window = window;
+ event.touch.x = x;
+ event.touch.y = y;
+ event.touch.time = time;
+ event.touch.pointer_id = pointer_id;
+ event.touch.flags = flags;
+
+ android_write_event (&event);
+ return event_serial;
+}
+
+JNIEXPORT jlong JNICALL
+NATIVE_NAME (sendTouchMove) (JNIEnv *env, jobject object,
+ jshort window, jint x, jint y,
+ jlong time, jint pointer_id,
+ jint flags)
+{
+ JNI_STACK_ALIGNMENT_PROLOGUE;
+
+ union android_event event;
+
+ event.touch.type = ANDROID_TOUCH_MOVE;
+ event.touch.serial = ++event_serial;
+ event.touch.window = window;
+ event.touch.x = x;
+ event.touch.y = y;
+ event.touch.time = time;
+ event.touch.pointer_id = pointer_id;
+ event.touch.flags = flags;
+
+ android_write_event (&event);
+ return event_serial;
+}
+
+JNIEXPORT jlong JNICALL
+NATIVE_NAME (sendWheel) (JNIEnv *env, jobject object,
+ jshort window, jint x, jint y,
+ jlong time, jint state,
+ jfloat x_delta, jfloat y_delta)
+{
+ JNI_STACK_ALIGNMENT_PROLOGUE;
+
+ union android_event event;
+
+ event.wheel.type = ANDROID_WHEEL;
+ event.wheel.serial = ++event_serial;
+ event.wheel.window = window;
+ event.wheel.x = x;
+ event.wheel.y = y;
+ event.wheel.time = time;
+ event.wheel.state = state;
+ event.wheel.x_delta = x_delta;
+ event.wheel.y_delta = y_delta;
+
+ android_write_event (&event);
+ return event_serial;
+}
+
+JNIEXPORT jlong JNICALL
+NATIVE_NAME (sendIconified) (JNIEnv *env, jobject object,
+ jshort window)
+{
+ JNI_STACK_ALIGNMENT_PROLOGUE;
+
+ union android_event event;
+
+ event.iconified.type = ANDROID_ICONIFIED;
+ event.iconified.serial = ++event_serial;
+ event.iconified.window = window;
+
+ android_write_event (&event);
+ return event_serial;
+}
+
+JNIEXPORT jlong JNICALL
+NATIVE_NAME (sendDeiconified) (JNIEnv *env, jobject object,
+ jshort window)
+{
+ JNI_STACK_ALIGNMENT_PROLOGUE;
+
+ union android_event event;
+
+ event.iconified.type = ANDROID_DEICONIFIED;
+ event.iconified.serial = ++event_serial;
+ event.iconified.window = window;
+
+ android_write_event (&event);
+ return event_serial;
+}
+
+JNIEXPORT jlong JNICALL
+NATIVE_NAME (sendContextMenu) (JNIEnv *env, jobject object,
+ jshort window, jint menu_event_id,
+ jint menu_event_serial)
+{
+ JNI_STACK_ALIGNMENT_PROLOGUE;
+
+ union android_event event;
+
+ event.menu.type = ANDROID_CONTEXT_MENU;
+ event.menu.serial = ++event_serial;
+ event.menu.window = window;
+ event.menu.menu_event_id = menu_event_id;
+ event.menu.menu_event_serial = menu_event_serial;
+
+ android_write_event (&event);
+ return event_serial;
+}
+
+JNIEXPORT jlong JNICALL
+NATIVE_NAME (sendExpose) (JNIEnv *env, jobject object,
+ jshort window, jint x, jint y,
+ jint width, jint height)
+{
+ JNI_STACK_ALIGNMENT_PROLOGUE;
+
+ union android_event event;
+
+ event.xexpose.type = ANDROID_EXPOSE;
+ event.xexpose.serial = ++event_serial;
+ event.xexpose.window = window;
+ event.xexpose.x = x;
+ event.xexpose.y = y;
+ event.xexpose.width = width;
+ event.xexpose.height = height;
+
+ android_write_event (&event);
+ return event_serial;
+}
+
+JNIEXPORT jlong JNICALL
+NATIVE_NAME (sendDndDrag) (JNIEnv *env, jobject object,
+ jshort window, jint x, jint y)
+{
+ JNI_STACK_ALIGNMENT_PROLOGUE;
+
+ union android_event event;
+
+ event.dnd.type = ANDROID_DND_DRAG_EVENT;
+ event.dnd.serial = ++event_serial;
+ event.dnd.window = window;
+ event.dnd.x = x;
+ event.dnd.y = y;
+ event.dnd.uri_or_string = NULL;
+ event.dnd.length = 0;
+
+ android_write_event (&event);
+ return event_serial;
+}
+
+JNIEXPORT jlong JNICALL
+NATIVE_NAME (sendDndUri) (JNIEnv *env, jobject object,
+ jshort window, jint x, jint y,
+ jstring string)
+{
+ JNI_STACK_ALIGNMENT_PROLOGUE;
+
+ union android_event event;
+ const jchar *characters;
+ jsize length;
+ uint16_t *buffer;
+
+ event.dnd.type = ANDROID_DND_URI_EVENT;
+ event.dnd.serial = ++event_serial;
+ event.dnd.window = window;
+ event.dnd.x = x;
+ event.dnd.y = y;
+
+ length = (*env)->GetStringLength (env, string);
+ buffer = malloc (length * sizeof *buffer);
+ characters = (*env)->GetStringChars (env, string, NULL);
+
+ if (!characters)
+ /* The JVM has run out of memory; return and let the out of memory
+ error take its course. */
+ return 0;
+
+ memcpy (buffer, characters, length * sizeof *buffer);
+ (*env)->ReleaseStringChars (env, string, characters);
+
+ event.dnd.uri_or_string = buffer;
+ event.dnd.length = length;
+
+ android_write_event (&event);
+ return event_serial;
+}
+
+JNIEXPORT jlong JNICALL
+NATIVE_NAME (sendDndText) (JNIEnv *env, jobject object,
+ jshort window, jint x, jint y,
+ jstring string)
+{
+ JNI_STACK_ALIGNMENT_PROLOGUE;
+
+ union android_event event;
+ const jchar *characters;
+ jsize length;
+ uint16_t *buffer;
+
+ event.dnd.type = ANDROID_DND_TEXT_EVENT;
+ event.dnd.serial = ++event_serial;
+ event.dnd.window = window;
+ event.dnd.x = x;
+ event.dnd.y = y;
+
+ length = (*env)->GetStringLength (env, string);
+ buffer = malloc (length * sizeof *buffer);
+ characters = (*env)->GetStringChars (env, string, NULL);
+
+ if (!characters)
+ /* The JVM has run out of memory; return and let the out of memory
+ error take its course. */
+ return 0;
+
+ memcpy (buffer, characters, length * sizeof *buffer);
+ (*env)->ReleaseStringChars (env, string, characters);
+
+ event.dnd.uri_or_string = buffer;
+ event.dnd.length = length;
+
+ android_write_event (&event);
+ return event_serial;
+}
+
+JNIEXPORT jlong JNICALL
+NATIVE_NAME (sendNotificationDeleted) (JNIEnv *env, jobject object,
+ jstring tag)
+{
+ JNI_STACK_ALIGNMENT_PROLOGUE;
+
+ union android_event event;
+ const char *characters;
+
+ event.notification.type = ANDROID_NOTIFICATION_DELETED;
+ event.notification.serial = ++event_serial;
+ event.notification.window = ANDROID_NONE;
+
+ /* TAG is guaranteed to be an ASCII string, of which the JNI character
+ encoding is a superset. */
+ characters = (*env)->GetStringUTFChars (env, tag, NULL);
+ if (!characters)
+ return 0;
+
+ event.notification.tag = strdup (characters);
+ (*env)->ReleaseStringUTFChars (env, tag, characters);
+ if (!event.notification.tag)
+ return 0;
+
+ event.notification.action = NULL;
+ event.notification.length = 0;
+
+ android_write_event (&event);
+ return event_serial;
+}
+
+JNIEXPORT jlong JNICALL
+NATIVE_NAME (sendNotificationAction) (JNIEnv *env, jobject object,
+ jstring tag, jstring action)
+{
+ JNI_STACK_ALIGNMENT_PROLOGUE;
+
+ union android_event event;
+ const void *characters;
+ jsize length;
+ uint16_t *buffer;
+
+ event.notification.type = ANDROID_NOTIFICATION_ACTION;
+ event.notification.serial = ++event_serial;
+ event.notification.window = ANDROID_NONE;
+
+ /* TAG is guaranteed to be an ASCII string, of which the JNI character
+ encoding is a superset. */
+ characters = (*env)->GetStringUTFChars (env, tag, NULL);
+ if (!characters)
+ return 0;
+
+ event.notification.tag = strdup (characters);
+ (*env)->ReleaseStringUTFChars (env, tag, characters);
+ if (!event.notification.tag)
+ return 0;
+
+ length = (*env)->GetStringLength (env, action);
+ buffer = malloc (length * sizeof *buffer);
+ characters = (*env)->GetStringChars (env, action, NULL);
+
+ if (!characters)
+ {
+ /* The JVM has run out of memory; return and let the out of memory
+ error take its course. */
+ xfree (event.notification.tag);
+ return 0;
+ }
+
+ memcpy (buffer, characters, length * sizeof *buffer);
+ (*env)->ReleaseStringChars (env, action, characters);
+
+ event.notification.action = buffer;
+ event.notification.length = length;
+
+ android_write_event (&event);
+ return event_serial;
+}
+
+JNIEXPORT jboolean JNICALL
+NATIVE_NAME (shouldForwardMultimediaButtons) (JNIEnv *env,
+ jobject object)
+{
+ JNI_STACK_ALIGNMENT_PROLOGUE;
+
+ /* Yes, android_pass_multimedia_buttons_to_system is being
+ read from the UI thread. */
+ return !android_pass_multimedia_buttons_to_system;
+}
+
+JNIEXPORT jboolean JNICALL
+NATIVE_NAME (shouldForwardCtrlSpace) (JNIEnv *env, jobject object)
+{
+ JNI_STACK_ALIGNMENT_PROLOGUE;
+
+ return !android_intercept_control_space;
+}
+
+JNIEXPORT void JNICALL
+NATIVE_NAME (blitRect) (JNIEnv *env, jobject object,
+ jobject src, jobject dest,
+ jint x1, jint y1, jint x2, jint y2)
+{
+ AndroidBitmapInfo src_info, dest_info;
+ unsigned char *src_data_1, *dest_data_1;
+ void *src_data, *dest_data;
+
+ /* N.B. that X2 and Y2 represent the pixel past the edge of the
+ rectangle; thus, the width is x2 - x1 and the height is y2 -
+ y1. */
+
+ memset (&src_info, 0, sizeof src_info);
+ memset (&dest_info, 0, sizeof dest_info);
+ AndroidBitmap_getInfo (env, src, &src_info);
+ AndroidBitmap_getInfo (env, dest, &dest_info);
+
+ /* If the stride is 0 after a call to `getInfo', assume it
+ failed. */
+
+ if (!src_info.stride || !dest_info.stride)
+ return;
+
+ /* If formats differ, abort. */
+ eassert (src_info.format == dest_info.format
+ && src_info.format == ANDROID_BITMAP_FORMAT_RGBA_8888);
+
+ /* Lock the image data. */
+ src_data = NULL;
+ AndroidBitmap_lockPixels (env, src, &src_data);
+
+ if (!src_data)
+ return;
+
+ dest_data = NULL;
+ AndroidBitmap_lockPixels (env, dest, &dest_data);
+
+ if (!dest_data)
+ goto fail1;
+
+ /* Now clip the rectangle to the bounds of the source and
+ destination bitmap. */
+
+ x1 = MAX (x1, 0);
+ y1 = MAX (y1, 0);
+ x2 = MAX (x2, 0);
+ y2 = MAX (y2, 0);
+
+
+ if (x1 >= src_info.width
+ || x1 >= dest_info.width)
+ x1 = MIN (dest_info.width - 1, src_info.width - 1);
+
+ if (x2 > src_info.width
+ || x2 > dest_info.width)
+ x2 = MIN (src_info.width, dest_info.width);
+
+ if (y1 >= src_info.height
+ || y1 >= dest_info.height)
+ y1 = MIN (dest_info.height - 1, src_info.height - 1);
+
+ if (y2 > src_info.height
+ || y2 > dest_info.height)
+ y2 = MIN (src_info.height, dest_info.height);
+
+ if (x1 >= x2 || y1 >= y2)
+ goto fail2;
+
+ /* Determine the address of the first line to copy. */
+
+ src_data_1 = src_data;
+ dest_data_1 = dest_data;
+ src_data_1 += x1 * 4;
+ src_data_1 += y1 * src_info.stride;
+ dest_data_1 += x1 * 4;
+ dest_data_1 += y1 * dest_info.stride;
+
+ /* Start copying each line. */
+
+ while (y1 != y2)
+ {
+ memcpy (dest_data_1, src_data_1, (x2 - x1) * 4);
+ src_data_1 += src_info.stride;
+ dest_data_1 += dest_info.stride;
+ y1++;
+ }
+
+ /* Complete the copy and unlock the bitmap. */
+
+ fail2:
+ AndroidBitmap_unlockPixels (env, dest);
+ fail1:
+ AndroidBitmap_unlockPixels (env, src);
+}
+
+JNIEXPORT void JNICALL
+NATIVE_NAME (notifyPixelsChanged) (JNIEnv *env, jobject object,
+ jobject bitmap)
+{
+ JNI_STACK_ALIGNMENT_PROLOGUE;
+
+ void *data;
+
+ /* Lock and unlock the bitmap. This calls
+ SkBitmap->notifyPixelsChanged. */
+
+ if (AndroidBitmap_lockPixels (env, bitmap, &data) < 0)
+ /* The return value is less than 0 if an error occurs.
+ Good luck finding this in the documentation. */
+ return;
+
+ AndroidBitmap_unlockPixels (env, bitmap);
+}
+
+/* Forward declarations of deadlock prevention functions. */
+
+static void android_begin_query (void);
+static void android_end_query (void);
+static void android_answer_query_spin (void);
+
+JNIEXPORT void JNICALL
+NATIVE_NAME (beginSynchronous) (JNIEnv *env, jobject object)
+{
+ JNI_STACK_ALIGNMENT_PROLOGUE;
+
+ android_begin_query ();
+}
+
+JNIEXPORT void JNICALL
+NATIVE_NAME (endSynchronous) (JNIEnv *env, jobject object)
+{
+ JNI_STACK_ALIGNMENT_PROLOGUE;
+
+ android_end_query ();
+}
+
+JNIEXPORT void JNICALL
+NATIVE_NAME (answerQuerySpin) (JNIEnv *env, jobject object)
+{
+ JNI_STACK_ALIGNMENT_PROLOGUE;
+
+ android_answer_query_spin ();
+}
+
+
+
+/* System thread setup. Android doesn't always block signals Emacs is
+ interested in from being received by the UI or render threads,
+ which can lead to problems when those signals then interrupt one of
+ those threads. */
+
+JNIEXPORT void JNICALL
+NATIVE_NAME (setupSystemThread) (void)
+{
+ JNI_STACK_ALIGNMENT_PROLOGUE;
+
+ sigset_t sigset;
+
+ /* Block everything except for SIGSEGV and SIGBUS; those two are
+ used by the runtime. */
+
+ sigfillset (&sigset);
+ sigdelset (&sigset, SIGSEGV);
+ sigdelset (&sigset, SIGBUS);
+
+ /* Save the signal mask that was previously used. It will be
+ restored in `initEmacs'. */
+
+ if (pthread_sigmask (SIG_BLOCK, &sigset, &startup_signal_mask))
+ __android_log_print (ANDROID_LOG_WARN, __func__,
+ "pthread_sigmask: %s", strerror (errno));
+ else
+ signal_mask_changed_p = true;
+}
+
+#ifdef __clang__
+#pragma clang diagnostic pop
+#else
+#pragma GCC diagnostic pop
+#endif
+
+
+
+/* Java functions called by C.
+
+ Because all C code runs in the native function initEmacs, ALL LOCAL
+ REFERENCES WILL PERSIST!
+
+ This means that every local reference must be explicitly destroyed
+ with DeleteLocalRef. A helper macro is provided to do this. */
+
+struct android_handle_entry
+{
+ /* The type. */
+ enum android_handle_type type;
+
+ /* The handle. */
+ jobject handle;
+};
+
+/* Table of handles MAX_HANDLE long. */
+struct android_handle_entry android_handles[USHRT_MAX];
+
+/* The largest handle ID currently known, but subject to
+ wraparound. */
+static android_handle max_handle;
+
+/* Allocate a new, unused, handle identifier. If Emacs is out of
+ identifiers, return 0. */
+
+static android_handle
+android_alloc_id (void)
+{
+ android_handle handle;
+
+ /* 0 is never a valid handle ID. */
+
+ if (!max_handle)
+ max_handle++;
+
+ /* See if the handle is already occupied. */
+
+ if (android_handles[max_handle].handle)
+ {
+ /* Look for a fresh unoccupied handle. */
+
+ handle = max_handle;
+ max_handle++;
+
+ while (handle != max_handle)
+ {
+ ++max_handle;
+
+ /* Make sure the handle is valid. */
+ if (!max_handle)
+ ++max_handle;
+
+ if (!android_handles[max_handle].handle)
+ return max_handle++;
+ }
+
+ return ANDROID_NONE;
+ }
+
+ return max_handle++;
+}
+
+/* Destroy the specified handle and mark it as free on the Java side
+ as well. */
+
+static void
+android_destroy_handle (android_handle handle)
+{
+ static jclass old, class;
+ static jmethodID method;
+
+ if (!android_handles[handle].handle)
+ {
+ __android_log_print (ANDROID_LOG_ERROR, __func__,
+ "Trying to destroy free handle!");
+ emacs_abort ();
+ }
+
+ if (!class)
+ {
+ class
+ = (*android_java_env)->FindClass (android_java_env,
+ "org/gnu/emacs/EmacsHandleObject");
+ eassert (class != NULL);
+
+ method
+ = (*android_java_env)->GetMethodID (android_java_env, class,
+ "destroyHandle", "()V");
+ eassert (method != NULL);
+
+ old = class;
+ class
+ = (jclass) (*android_java_env)->NewGlobalRef (android_java_env,
+ (jobject) class);
+ android_exception_check_1 (old);
+ ANDROID_DELETE_LOCAL_REF (old);
+ }
+
+ (*android_java_env)->CallVoidMethod (android_java_env,
+ android_handles[handle].handle,
+ method);
+
+ /* Just clear any exception thrown. If destroying the handle
+ fails from an out-of-memory error, then Emacs loses some
+ resources, but that is not as big deal as signaling. */
+ (*android_java_env)->ExceptionClear (android_java_env);
+
+ /* Delete the global reference regardless of any error. */
+ (*android_java_env)->DeleteGlobalRef (android_java_env,
+ android_handles[handle].handle);
+ android_handles[handle].handle = NULL;
+}
+
+jobject
+android_resolve_handle (android_handle handle,
+ enum android_handle_type type)
+{
+ if (!handle)
+ /* ANDROID_NONE. */
+ return NULL;
+
+ /* CheckJNI will normally ensure that the handle exists and is
+ the right type, but with a less informative error message.
+ Don't waste cycles doing our own checking here. */
+
+#ifdef ENABLE_CHECKING
+
+ if (!android_handles[handle].handle)
+ {
+ __android_log_print (ANDROID_LOG_ERROR, __func__,
+ "Trying to resolve free handle!");
+ emacs_abort ();
+ }
+
+ if (android_handles[handle].type != type)
+ {
+ __android_log_print (ANDROID_LOG_ERROR, __func__,
+ "Handle has wrong type!");
+ emacs_abort ();
+ }
+
+#endif /* ENABLE_CHECKING */
+
+ return android_handles[handle].handle;
+}
+
+static jobject
+android_resolve_handle2 (android_handle handle,
+ enum android_handle_type type,
+ enum android_handle_type type2)
+{
+ if (!handle)
+ return NULL;
+
+ /* CheckJNI will normally ensure that the handle exists and is
+ the right type, but with a less informative error message.
+ Don't waste cycles doing our own checking here. */
+
+#ifdef ENABLE_CHECKING
+
+ if (!android_handles[handle].handle)
+ {
+ __android_log_print (ANDROID_LOG_ERROR, __func__,
+ "Trying to resolve free handle!");
+ emacs_abort ();
+ }
+
+ if (android_handles[handle].type != type
+ && android_handles[handle].type != type2)
+ {
+ __android_log_print (ANDROID_LOG_ERROR, __func__,
+ "Handle has wrong type!");
+ emacs_abort ();
+ }
+
+#endif /* ENABLE_CHECKING */
+
+ return android_handles[handle].handle;
+}
+
+void
+android_change_window_attributes (android_window handle,
+ enum android_window_value_mask value_mask,
+ struct android_set_window_attributes *attrs)
+{
+ jmethodID method;
+ jobject window;
+ jint pixel;
+
+ window = android_resolve_handle (handle, ANDROID_HANDLE_WINDOW);
+
+ if (value_mask & ANDROID_CW_BACK_PIXEL)
+ {
+ method = window_class.change_window_background;
+ pixel = (jint) attrs->background_pixel;
+ (*android_java_env)->CallNonvirtualVoidMethod (android_java_env,
+ window,
+ window_class.class,
+ method, pixel);
+ android_exception_check ();
+ }
+}
+
+/* Create a new window with the given width, height and
+ attributes. */
+
+android_window
+android_create_window (android_window parent, int x, int y,
+ int width, int height,
+ enum android_window_value_mask value_mask,
+ struct android_set_window_attributes *attrs)
+{
+ static jclass class;
+ static jmethodID constructor;
+ jobject object, parent_object, old;
+ android_window window;
+ android_handle prev_max_handle;
+ bool override_redirect;
+
+ parent_object = android_resolve_handle (parent, ANDROID_HANDLE_WINDOW);
+
+ prev_max_handle = max_handle;
+ window = android_alloc_id ();
+
+ if (!window)
+ error ("Out of window handles!");
+
+ if (!class)
+ {
+ class = (*android_java_env)->FindClass (android_java_env,
+ "org/gnu/emacs/EmacsWindow");
+ eassert (class != NULL);
+
+ constructor
+ = (*android_java_env)->GetMethodID (android_java_env, class, "<init>",
+ "(SLorg/gnu/emacs/EmacsWindow;"
+ "IIIIZ)V");
+ eassert (constructor != NULL);
+
+ old = class;
+ class = (*android_java_env)->NewGlobalRef (android_java_env, class);
+ android_exception_check_1 (old);
+ ANDROID_DELETE_LOCAL_REF (old);
+ }
+
+ /* N.B. that ANDROID_CW_OVERRIDE_REDIRECT can only be set at window
+ creation time. */
+ override_redirect = ((value_mask
+ & ANDROID_CW_OVERRIDE_REDIRECT)
+ && attrs->override_redirect);
+
+ object = (*android_java_env)->NewObject (android_java_env, class,
+ constructor, (jshort) window,
+ parent_object, (jint) x, (jint) y,
+ (jint) width, (jint) height,
+ (jboolean) override_redirect);
+ if (!object)
+ {
+ (*android_java_env)->ExceptionClear (android_java_env);
+
+ max_handle = prev_max_handle;
+ memory_full (0);
+ }
+
+ android_handles[window].type = ANDROID_HANDLE_WINDOW;
+ android_handles[window].handle
+ = (*android_java_env)->NewGlobalRef (android_java_env,
+ object);
+ (*android_java_env)->ExceptionClear (android_java_env);
+ ANDROID_DELETE_LOCAL_REF (object);
+
+ if (!android_handles[window].handle)
+ memory_full (0);
+
+ android_change_window_attributes (window, value_mask, attrs);
+ return window;
+}
+
+void
+android_set_window_background (android_window window, unsigned long pixel)
+{
+ struct android_set_window_attributes attrs;
+
+ attrs.background_pixel = pixel;
+ android_change_window_attributes (window, ANDROID_CW_BACK_PIXEL,
+ &attrs);
+}
+
+void
+android_destroy_window (android_window window)
+{
+ if (android_handles[window].type != ANDROID_HANDLE_WINDOW)
+ {
+ __android_log_print (ANDROID_LOG_ERROR, __func__,
+ "Trying to destroy something not a window!");
+ emacs_abort ();
+ }
+
+ android_destroy_handle (window);
+}
+
+static void
+android_init_android_rect_class (void)
+{
+ jclass old;
+
+ if (android_rect_class)
+ /* Already initialized. */
+ return;
+
+ android_rect_class
+ = (*android_java_env)->FindClass (android_java_env,
+ "android/graphics/Rect");
+ eassert (android_rect_class);
+
+ android_rect_constructor
+ = (*android_java_env)->GetMethodID (android_java_env, android_rect_class,
+ "<init>", "(IIII)V");
+ eassert (emacs_gc_constructor);
+
+ old = android_rect_class;
+ android_rect_class
+ = (jclass) (*android_java_env)->NewGlobalRef (android_java_env,
+ (jobject) android_rect_class);
+ android_exception_check_1 (old);
+ ANDROID_DELETE_LOCAL_REF (old);
+}
+
+static void
+android_init_emacs_gc_class (void)
+{
+ jclass old;
+
+ if (emacs_gc_class)
+ /* Already initialized. */
+ return;
+
+ emacs_gc_class
+ = (*android_java_env)->FindClass (android_java_env,
+ "org/gnu/emacs/EmacsGC");
+ eassert (emacs_gc_class);
+
+ emacs_gc_constructor
+ = (*android_java_env)->GetMethodID (android_java_env,
+ emacs_gc_class,
+ "<init>", "(S)V");
+ eassert (emacs_gc_constructor);
+
+ emacs_gc_mark_dirty
+ = (*android_java_env)->GetMethodID (android_java_env,
+ emacs_gc_class,
+ "markDirty", "(Z)V");
+ eassert (emacs_gc_mark_dirty);
+
+ old = emacs_gc_class;
+ emacs_gc_class
+ = (jclass) (*android_java_env)->NewGlobalRef (android_java_env,
+ (jobject) emacs_gc_class);
+ android_exception_check_1 (old);
+ ANDROID_DELETE_LOCAL_REF (old);
+
+ emacs_gc_foreground
+ = (*android_java_env)->GetFieldID (android_java_env,
+ emacs_gc_class,
+ "foreground", "I");
+ emacs_gc_background
+ = (*android_java_env)->GetFieldID (android_java_env,
+ emacs_gc_class,
+ "background", "I");
+ emacs_gc_function
+ = (*android_java_env)->GetFieldID (android_java_env,
+ emacs_gc_class,
+ "function", "I");
+ emacs_gc_clip_rects
+ = (*android_java_env)->GetFieldID (android_java_env,
+ emacs_gc_class,
+ "clip_rects",
+ "[Landroid/graphics/Rect;");
+ emacs_gc_clip_x_origin
+ = (*android_java_env)->GetFieldID (android_java_env,
+ emacs_gc_class,
+ "clip_x_origin", "I");
+ emacs_gc_clip_y_origin
+ = (*android_java_env)->GetFieldID (android_java_env,
+ emacs_gc_class,
+ "clip_y_origin", "I");
+ emacs_gc_stipple
+ = (*android_java_env)->GetFieldID (android_java_env,
+ emacs_gc_class,
+ "stipple",
+ "Lorg/gnu/emacs/EmacsPixmap;");
+ emacs_gc_clip_mask
+ = (*android_java_env)->GetFieldID (android_java_env,
+ emacs_gc_class,
+ "clip_mask",
+ "Lorg/gnu/emacs/EmacsPixmap;");
+ emacs_gc_fill_style
+ = (*android_java_env)->GetFieldID (android_java_env,
+ emacs_gc_class,
+ "fill_style", "I");
+ emacs_gc_ts_origin_x
+ = (*android_java_env)->GetFieldID (android_java_env,
+ emacs_gc_class,
+ "ts_origin_x", "I");
+ emacs_gc_ts_origin_y
+ = (*android_java_env)->GetFieldID (android_java_env,
+ emacs_gc_class,
+ "ts_origin_y", "I");
+}
+
+struct android_gc *
+android_create_gc (enum android_gc_value_mask mask,
+ struct android_gc_values *values)
+{
+ struct android_gc *gc;
+ android_handle prev_max_handle;
+ jobject object;
+
+ android_init_emacs_gc_class ();
+
+ gc = xmalloc (sizeof *gc);
+ prev_max_handle = max_handle;
+ gc->gcontext = android_alloc_id ();
+ gc->foreground = 0;
+ gc->background = 0xffffff;
+ gc->clip_rects = NULL;
+
+ /* This means to not apply any clipping. */
+ gc->num_clip_rects = -1;
+
+ /* Apply the other default values. */
+ gc->function = ANDROID_GC_COPY;
+ gc->fill_style = ANDROID_FILL_SOLID;
+ gc->clip_x_origin = 0;
+ gc->clip_y_origin = 0;
+ gc->clip_mask = ANDROID_NONE;
+ gc->stipple = ANDROID_NONE;
+ gc->ts_x_origin = 0;
+ gc->ts_y_origin = 0;
+
+ if (!gc->gcontext)
+ {
+ xfree (gc);
+ error ("Out of GContext handles!");
+ }
+
+ object = (*android_java_env)->NewObject (android_java_env,
+ emacs_gc_class,
+ emacs_gc_constructor,
+ (jshort) gc->gcontext);
+
+ if (!object)
+ {
+ (*android_java_env)->ExceptionClear (android_java_env);
+
+ max_handle = prev_max_handle;
+ memory_full (0);
+ }
+
+ android_handles[gc->gcontext].type = ANDROID_HANDLE_GCONTEXT;
+ android_handles[gc->gcontext].handle
+ = (*android_java_env)->NewGlobalRef (android_java_env, object);
+ (*android_java_env)->ExceptionClear (android_java_env);
+ ANDROID_DELETE_LOCAL_REF (object);
+
+ if (!android_handles[gc->gcontext].handle)
+ memory_full (0);
+
+ android_change_gc (gc, mask, values);
+ return gc;
+}
+
+void
+android_free_gc (struct android_gc *gc)
+{
+ android_destroy_handle (gc->gcontext);
+
+ xfree (gc->clip_rects);
+ xfree (gc);
+}
+
+void
+android_change_gc (struct android_gc *gc,
+ enum android_gc_value_mask mask,
+ struct android_gc_values *values)
+{
+ jobject what, gcontext;
+ jboolean clip_changed;
+
+ clip_changed = false;
+
+ android_init_emacs_gc_class ();
+ gcontext = android_resolve_handle (gc->gcontext,
+ ANDROID_HANDLE_GCONTEXT);
+
+ if (mask & ANDROID_GC_FOREGROUND)
+ {
+ (*android_java_env)->SetIntField (android_java_env,
+ gcontext,
+ emacs_gc_foreground,
+ values->foreground);
+ gc->foreground = values->foreground;
+ }
+
+ if (mask & ANDROID_GC_BACKGROUND)
+ {
+ (*android_java_env)->SetIntField (android_java_env,
+ gcontext,
+ emacs_gc_background,
+ values->background);
+ gc->background = values->background;
+ }
+
+ if (mask & ANDROID_GC_FUNCTION)
+ {
+ (*android_java_env)->SetIntField (android_java_env,
+ gcontext,
+ emacs_gc_function,
+ values->function);
+ gc->function = values->function;
+ }
+
+ if (mask & ANDROID_GC_CLIP_X_ORIGIN)
+ {
+ (*android_java_env)->SetIntField (android_java_env,
+ gcontext,
+ emacs_gc_clip_x_origin,
+ values->clip_x_origin);
+ gc->clip_x_origin = values->clip_x_origin;
+ clip_changed = true;
+ }
+
+ if (mask & ANDROID_GC_CLIP_Y_ORIGIN)
+ {
+ (*android_java_env)->SetIntField (android_java_env,
+ gcontext,
+ emacs_gc_clip_y_origin,
+ values->clip_y_origin);
+ gc->clip_y_origin = values->clip_y_origin;
+ clip_changed = true;
+ }
+
+ if (mask & ANDROID_GC_CLIP_MASK)
+ {
+ what = android_resolve_handle (values->clip_mask,
+ ANDROID_HANDLE_PIXMAP);
+ (*android_java_env)->SetObjectField (android_java_env,
+ gcontext,
+ emacs_gc_clip_mask,
+ what);
+ gc->clip_mask = values->clip_mask;
+
+ /* Changing GCClipMask also clears the clip rectangles. */
+ (*android_java_env)->SetObjectField (android_java_env,
+ gcontext,
+ emacs_gc_clip_rects,
+ NULL);
+
+ xfree (gc->clip_rects);
+ gc->clip_rects = NULL;
+ gc->num_clip_rects = -1;
+ clip_changed = true;
+ }
+
+ if (mask & ANDROID_GC_STIPPLE)
+ {
+ what = android_resolve_handle (values->stipple,
+ ANDROID_HANDLE_PIXMAP);
+ (*android_java_env)->SetObjectField (android_java_env,
+ gcontext,
+ emacs_gc_stipple,
+ what);
+ gc->stipple = values->stipple;
+ }
+
+ if (mask & ANDROID_GC_FILL_STYLE)
+ {
+ (*android_java_env)->SetIntField (android_java_env,
+ gcontext,
+ emacs_gc_fill_style,
+ values->fill_style);
+ gc->fill_style = values->fill_style;
+ }
+
+ if (mask & ANDROID_GC_TILE_STIP_X_ORIGIN)
+ {
+ (*android_java_env)->SetIntField (android_java_env,
+ gcontext,
+ emacs_gc_ts_origin_x,
+ values->ts_x_origin);
+ gc->ts_x_origin = values->ts_x_origin;
+ }
+
+ if (mask & ANDROID_GC_TILE_STIP_Y_ORIGIN)
+ {
+ (*android_java_env)->SetIntField (android_java_env,
+ gcontext,
+ emacs_gc_ts_origin_y,
+ values->ts_y_origin);
+ gc->ts_y_origin = values->ts_y_origin;
+ }
+
+ if (mask)
+ {
+ (*android_java_env)->CallNonvirtualVoidMethod (android_java_env,
+ gcontext,
+ emacs_gc_class,
+ emacs_gc_mark_dirty,
+ (jboolean) clip_changed);
+ android_exception_check ();
+ }
+}
+
+void
+android_set_clip_rectangles (struct android_gc *gc, int clip_x_origin,
+ int clip_y_origin,
+ struct android_rectangle *clip_rects,
+ int n_clip_rects)
+{
+ jobjectArray array;
+ jobject rect, gcontext;
+ int i;
+
+ android_init_android_rect_class ();
+ android_init_emacs_gc_class ();
+
+ gcontext = android_resolve_handle (gc->gcontext,
+ ANDROID_HANDLE_GCONTEXT);
+
+ array = (*android_java_env)->NewObjectArray (android_java_env,
+ n_clip_rects,
+ android_rect_class,
+ NULL);
+ android_exception_check ();
+
+ for (i = 0; i < n_clip_rects; ++i)
+ {
+ rect = (*android_java_env)->NewObject (android_java_env,
+ android_rect_class,
+ android_rect_constructor,
+ (jint) clip_rects[i].x,
+ (jint) clip_rects[i].y,
+ (jint) (clip_rects[i].x
+ + clip_rects[i].width),
+ (jint) (clip_rects[i].y
+ + clip_rects[i].height));
+
+ /* The meaning of this call is to check whether or not an
+ allocation error happened, and to delete ARRAY and signal an
+ out-of-memory error if that is the case. */
+ android_exception_check_1 (array);
+
+ (*android_java_env)->SetObjectArrayElement (android_java_env,
+ array, i, rect);
+ ANDROID_DELETE_LOCAL_REF (rect);
+ }
+
+ (*android_java_env)->SetObjectField (android_java_env,
+ gcontext,
+ emacs_gc_clip_rects,
+ (jobject) array);
+ ANDROID_DELETE_LOCAL_REF (array);
+
+ (*android_java_env)->SetIntField (android_java_env,
+ gcontext,
+ emacs_gc_clip_x_origin,
+ clip_x_origin);
+ (*android_java_env)->SetIntField (android_java_env,
+ gcontext,
+ emacs_gc_clip_y_origin,
+ clip_y_origin);
+
+ (*android_java_env)->CallNonvirtualVoidMethod (android_java_env,
+ gcontext,
+ emacs_gc_class,
+ emacs_gc_mark_dirty,
+ (jboolean) true);
+ android_exception_check ();
+
+ /* Cache the clip rectangles on the C side for
+ sfntfont-android.c. */
+ if (gc->clip_rects)
+ xfree (gc->clip_rects);
+
+ /* If gc->num_clip_rects is 0, then no drawing will be performed at
+ all. */
+ gc->clip_rects = xmalloc (sizeof *gc->clip_rects
+ * n_clip_rects);
+ gc->num_clip_rects = n_clip_rects;
+ memcpy (gc->clip_rects, clip_rects,
+ n_clip_rects * sizeof *gc->clip_rects);
+}
+
+void
+android_reparent_window (android_window w, android_window parent_handle,
+ int x, int y)
+{
+ jobject window, parent;
+ jmethodID method;
+
+ window = android_resolve_handle (w, ANDROID_HANDLE_WINDOW);
+ parent = android_resolve_handle (parent_handle,
+ ANDROID_HANDLE_WINDOW);
+
+ method = window_class.reparent_to;
+ (*android_java_env)->CallNonvirtualVoidMethod (android_java_env, window,
+ window_class.class, method,
+ parent, (jint) x, (jint) y);
+ android_exception_check ();
+}
+
+void
+android_clear_window (android_window handle)
+{
+ jobject window;
+
+ window = android_resolve_handle (handle, ANDROID_HANDLE_WINDOW);
+
+ (*android_java_env)->CallNonvirtualVoidMethod (android_java_env,
+ window,
+ window_class.class,
+ window_class.clear_window);
+ android_exception_check ();
+}
+
+void
+android_map_window (android_window handle)
+{
+ jobject window;
+ jmethodID map_window;
+
+ window = android_resolve_handle (handle, ANDROID_HANDLE_WINDOW);
+ map_window = window_class.map_window;
+
+ (*android_java_env)->CallNonvirtualVoidMethod (android_java_env,
+ window,
+ window_class.class,
+ map_window);
+ android_exception_check ();
+}
+
+void
+android_unmap_window (android_window handle)
+{
+ jobject window;
+ jmethodID unmap_window;
+
+ window = android_resolve_handle (handle, ANDROID_HANDLE_WINDOW);
+ unmap_window = window_class.unmap_window;
+
+ (*android_java_env)->CallNonvirtualVoidMethod (android_java_env,
+ window,
+ window_class.class,
+ unmap_window);
+ android_exception_check ();
+}
+
+void
+android_resize_window (android_window handle, unsigned int width,
+ unsigned int height)
+{
+ jobject window;
+ jmethodID resize_window;
+
+ window = android_resolve_handle (handle, ANDROID_HANDLE_WINDOW);
+ resize_window = window_class.resize_window;
+
+ (*android_java_env)->CallNonvirtualVoidMethod (android_java_env,
+ window,
+ window_class.class,
+ resize_window,
+ (jint) width,
+ (jint) height);
+ android_exception_check ();
+}
+
+void
+android_move_window (android_window handle, int x, int y)
+{
+ jobject window;
+ jmethodID move_window;
+
+ window = android_resolve_handle (handle, ANDROID_HANDLE_WINDOW);
+ move_window = window_class.move_window;
+
+ (*android_java_env)->CallNonvirtualVoidMethod (android_java_env,
+ window,
+ window_class.class,
+ move_window,
+ (jint) x, (jint) y);
+ android_exception_check ();
+}
+
+void
+android_swap_buffers (struct android_swap_info *swap_info,
+ int num_windows)
+{
+ jobject window;
+ int i;
+
+ for (i = 0; i < num_windows; ++i)
+ {
+ window = android_resolve_handle (swap_info[i].swap_window,
+ ANDROID_HANDLE_WINDOW);
+ (*android_java_env)->CallNonvirtualVoidMethod (android_java_env,
+ window,
+ window_class.class,
+ window_class.swap_buffers);
+ android_exception_check ();
+ }
+}
+
+void
+android_get_gc_values (struct android_gc *gc,
+ enum android_gc_value_mask mask,
+ struct android_gc_values *values)
+{
+ if (mask & ANDROID_GC_FOREGROUND)
+ /* GCs never have 32 bit colors, so we don't have to worry about
+ sign extension here. */
+ values->foreground = gc->foreground;
+
+ if (mask & ANDROID_GC_BACKGROUND)
+ values->background = gc->background;
+
+ if (mask & ANDROID_GC_FUNCTION)
+ values->function = gc->function;
+
+ if (mask & ANDROID_GC_CLIP_X_ORIGIN)
+ values->clip_x_origin = gc->clip_x_origin;
+
+ if (mask & ANDROID_GC_CLIP_Y_ORIGIN)
+ values->clip_y_origin = gc->clip_y_origin;
+
+ if (mask & ANDROID_GC_FILL_STYLE)
+ values->fill_style = gc->fill_style;
+
+ if (mask & ANDROID_GC_TILE_STIP_X_ORIGIN)
+ values->ts_x_origin = gc->ts_x_origin;
+
+ if (mask & ANDROID_GC_TILE_STIP_Y_ORIGIN)
+ values->ts_y_origin = gc->ts_y_origin;
+
+ /* Fields involving handles are not used by Emacs, and thus not
+ implemented */
+}
+
+void
+android_set_foreground (struct android_gc *gc, unsigned long foreground)
+{
+ struct android_gc_values gcv;
+
+ gcv.foreground = foreground;
+ android_change_gc (gc, ANDROID_GC_FOREGROUND, &gcv);
+}
+
+void
+android_fill_rectangle (android_drawable handle, struct android_gc *gc,
+ int x, int y, unsigned int width,
+ unsigned int height)
+{
+ jobject drawable, gcontext;
+
+ drawable = android_resolve_handle2 (handle,
+ ANDROID_HANDLE_WINDOW,
+ ANDROID_HANDLE_PIXMAP);
+ gcontext = android_resolve_handle (gc->gcontext,
+ ANDROID_HANDLE_GCONTEXT);
+
+ (*android_java_env)->CallNonvirtualVoidMethod (android_java_env,
+ emacs_service,
+ service_class.class,
+ service_class.fill_rectangle,
+ drawable,
+ gcontext,
+ (jint) x, (jint) y,
+ (jint) width,
+ (jint) height);
+}
+
+android_pixmap
+android_create_pixmap_from_bitmap_data (char *data, unsigned int width,
+ unsigned int height,
+ unsigned long foreground,
+ unsigned long background,
+ unsigned int depth)
+{
+ android_pixmap pixmap;
+ jobject object;
+ AndroidBitmapInfo info;
+ unsigned int *depth_24;
+ unsigned char *depth_8;
+ void *bitmap_data;
+ unsigned int x, y;
+ unsigned int r, g, b;
+
+ /* Create a pixmap with the right dimensions and depth. */
+ pixmap = android_create_pixmap (width, height, depth);
+
+ /* Lock the bitmap data. */
+ bitmap_data = android_lock_bitmap (pixmap, &info, &object);
+
+ /* Merely return if locking the bitmap fails. */
+ if (!bitmap_data)
+ return pixmap;
+
+ eassert (info.format == ANDROID_BITMAP_FORMAT_RGBA_8888
+ || info.format == ANDROID_BITMAP_FORMAT_A_8);
+
+ /* Begin copying each line. */
+
+ switch (info.format)
+ {
+ case ANDROID_BITMAP_FORMAT_RGBA_8888:
+
+ /* Swizzle the pixels into ABGR format. Android uses Skia's
+ ``native color type'', which is ABGR. This is despite the
+ format being named ``ARGB'', and more confusingly
+ `ANDROID_BITMAP_FORMAT_RGBA_8888' in bitmap.h. */
+
+ r = background & 0x00ff0000;
+ g = background & 0x0000ff00;
+ b = background & 0x000000ff;
+ background = (r >> 16) | g | (b << 16) | 0xff000000;
+ r = foreground & 0x00ff0000;
+ g = foreground & 0x0000ff00;
+ b = foreground & 0x000000ff;
+ foreground = (r >> 16) | g | (b << 16) | 0xff000000;
+
+ for (y = 0; y < height; ++y)
+ {
+ depth_24 = (void *) ((char *) bitmap_data + y * info.stride);
+
+ for (x = 0; x < width; ++x)
+ depth_24[x] = ((data[x / 8] & (1 << (x % 8)))
+ ? foreground : background);
+
+ data += (width + 7) / 8;
+ }
+
+ break;
+
+ case ANDROID_BITMAP_FORMAT_A_8:
+
+ /* 8-bit pixmaps are created, but in spite of that they are
+ employed only to represent bitmaps. */
+
+ foreground = (foreground ? 255 : 0);
+ background = (background ? 255 : 0);
+
+ for (y = 0; y < height; ++y)
+ {
+ depth_8 = (void *) ((char *) bitmap_data + y * info.stride);
+
+ for (x = 0; x < width; ++x)
+ depth_8[x] = ((data[x / 8] & (1 << (x % 8)))
+ ? foreground : background);
+
+ data += (width + 7) / 8;
+ }
+
+ break;
+
+ default:
+ emacs_abort ();
+ }
+
+ /* Unlock the bitmap itself. */
+ AndroidBitmap_unlockPixels (android_java_env, object);
+ ANDROID_DELETE_LOCAL_REF (object);
+
+ /* Return the pixmap. */
+ return pixmap;
+}
+
+void
+android_set_clip_mask (struct android_gc *gc, android_pixmap pixmap)
+{
+ struct android_gc_values gcv;
+
+ gcv.clip_mask = pixmap;
+ android_change_gc (gc, ANDROID_GC_CLIP_MASK, &gcv);
+}
+
+void
+android_set_fill_style (struct android_gc *gc,
+ enum android_fill_style fill_style)
+{
+ struct android_gc_values gcv;
+
+ gcv.fill_style = fill_style;
+ android_change_gc (gc, ANDROID_GC_FILL_STYLE, &gcv);
+}
+
+
+
+/* Pixmap bit blit implementation. This exists as `Canvas.drawBitmap'
+ seems to have trouble with copying bitmap data from one bitmap back
+ to itself on Android 8.0. */
+
+/* Function called to actually perform the copy. */
+
+typedef void (*android_blit_func) (int, int, int, int, int, int,
+ struct android_gc *,
+ unsigned char *, AndroidBitmapInfo *,
+ unsigned char *, AndroidBitmapInfo *,
+ unsigned char *, AndroidBitmapInfo *);
+
+
+
+#ifdef __aarch64__
+
+/* Copy N pixels from SRC to DST, using MASK as a depth 1 clip
+ mask. */
+
+static void
+android_neon_mask_line (unsigned int *src, unsigned int *dst,
+ unsigned char *mask, int n)
+{
+ uint32x4_t src_low, src_high, dst_low, dst_high;
+ int16x8_t vmask;
+ int32x4_t ext_mask_low, ext_mask_high, low, high;
+ int rem, i;
+
+ /* Calculate the remainder. */
+ rem = n & 7, n &= ~7;
+
+ /* Process eight pixels at a time. */
+
+ if (n)
+ {
+ again:
+ /* Load the low and high four pixels from the source. */
+ src_low = vld1q_u32 (src);
+ src_high = vld1q_u32 (src + 4);
+
+ /* Do the same with the destination. */
+ dst_low = vld1q_u32 (dst);
+ dst_high = vld1q_u32 (dst + 4);
+
+ /* Load and sign extend the mask. */
+ vmask = vmovl_s8 (vld1_u8 (mask));
+ ext_mask_low = vmovl_s16 (vget_low_s16 (vmask));
+ ext_mask_high = vmovl_s16 (vget_high_s16 (vmask));
+
+ /* Reinterpret the mask. */
+ low = vreinterpretq_u32_s32 (ext_mask_low);
+ high = vreinterpretq_u32_s32 (ext_mask_high);
+
+ /* Apply the mask. */
+ dst_low = vbicq_u32 (dst_low, low);
+ src_low = vandq_u32 (src_low, low);
+ dst_high = vbicq_u32 (dst_high, high);
+ src_high = vandq_u32 (src_high, high);
+
+ /* Write the result after combining both masked vectors. */
+ vst1q_u32 (dst, vorrq_u32 (dst_low, src_low));
+ vst1q_u32 (dst + 4, vorrq_u32 (dst_high, src_high));
+
+ /* Adjust src, dst and mask. */
+ dst += 8;
+ src += 8;
+ mask += 8;
+
+ /* See if this loop should continue. */
+ n -= 8;
+ if (n > 0)
+ goto again;
+ }
+
+ /* Process the remaining pixels. */
+
+ for (i = 0; i < rem; ++i)
+ {
+ /* Sign extend the mask. */
+ n = ((signed char *) mask)[i];
+
+ /* Combine src and dst. */
+ dst[i] = ((src[i] & n) | (dst[i] & ~n));
+ }
+}
+
+#endif /* __aarch64__ */
+
+
+
+/* Copy a rectangle SRC_X, SRC_Y, WIDTH and HEIGHT from SRC, described
+ by SRC_INFO, to DST_X and DST_Y in DST, as described by DST_INFO.
+
+ If MASK is set, mask the source data using MASK_INFO, translating
+ it by GC->clip_x_origin and GC->clip_y_origin. MASK must be a
+ pixmap of depth 1.
+
+ N.B. that currently only copies between bitmaps of depth 24 are
+ implemented. */
+
+static void
+android_blit_copy (int src_x, int src_y, int width, int height,
+ int dst_x, int dst_y, struct android_gc *gc,
+ unsigned char *src, AndroidBitmapInfo *src_info,
+ unsigned char *dst, AndroidBitmapInfo *dst_info,
+ unsigned char *mask, AndroidBitmapInfo *mask_info)
+{
+ uintptr_t start, end;
+ int mask_offset;
+ size_t pixel, offset, offset1;
+ unsigned char *src_current, *dst_current;
+ unsigned char *mask_current;
+ int overflow, temp, i;
+#ifndef __aarch64__
+ int j;
+#endif /* __aarch64__ */
+ bool backwards;
+ unsigned int *long_src, *long_dst;
+
+ /* Assert that the specified coordinates are within bounds. */
+ eassert (src_x >= 0 && src_y >= 0
+ && dst_x >= 0 && dst_y >= 0);
+ eassert (src_x + width <= src_info->width);
+ eassert (src_y + height <= src_info->height);
+ eassert (dst_x + width <= dst_info->width);
+ eassert (dst_y + height <= dst_info->height);
+
+ /* Now check that each bitmap has the correct format. */
+ eassert (src_info->format == dst_info->format
+ && src_info->format == ANDROID_BITMAP_FORMAT_RGBA_8888);
+ pixel = sizeof (unsigned int);
+
+ /* Android doesn't have A1 bitmaps, so A8 is used to represent
+ packed bitmaps of depth 1. */
+ eassert (!mask || mask_info->format == ANDROID_BITMAP_FORMAT_A_8);
+
+ /* Calculate the address of the first pixel of the first row to be
+ copied in both src and dst. Compare them to determine the
+ direction in which the copy is to take place. */
+
+ overflow = ckd_mul (&start, src_y, src_info->stride);
+ overflow |= ckd_mul (&end, src_x, pixel);
+ overflow |= ckd_add (&start, end, start);
+ overflow |= ckd_add (&start, (uintptr_t) src, start);
+
+ if (overflow)
+ return;
+
+ src_current = (unsigned char *) start;
+
+ overflow = ckd_mul (&start, dst_y, dst_info->stride);
+ overflow |= ckd_mul (&end, dst_x, pixel);
+ overflow |= ckd_add (&start, end, start);
+ overflow |= ckd_add (&start, (uintptr_t) dst, start);
+
+ if (overflow)
+ return;
+
+ dst_current = (unsigned char *) start;
+ backwards = false;
+
+ /* Now see if copying should proceed from the bottom up. */
+
+ if (src == dst && dst_current >= src_current)
+ {
+ backwards = true;
+
+ /* Walk src and dst from bottom to top, in order to avoid
+ overlap. Calculate the coordinate of the last pixel of the
+ last row in both src and dst. */
+
+ overflow = ckd_mul (&start, src_y + height - 1,
+ src_info->stride);
+
+ if (mask)
+ /* If a mask is set, put the pointers before the end of the
+ row. */
+ overflow |= ckd_mul (&end, src_x + width - 1, pixel);
+ else
+ end = src_x * pixel;
+
+ overflow |= ckd_add (&start, start, end);
+ overflow |= ckd_add (&start, (uintptr_t) src, start);
+
+ if (overflow)
+ return;
+
+ src_current = (unsigned char *) start;
+
+ overflow = ckd_mul (&start, dst_y + height - 1,
+ dst_info->stride);
+
+ if (mask)
+ /* If a mask is set, put the pointers before the end of the
+ row. */
+ overflow |= ckd_mul (&end, dst_x + width - 1, pixel);
+ else
+ end = dst_x * pixel;
+
+ overflow |= ckd_add (&start, start, end);
+ overflow |= ckd_add (&start, (uintptr_t) dst, start);
+
+ if (overflow)
+ return;
+
+ dst_current = (unsigned char *) start;
+ }
+
+ if (!mask)
+ {
+ /* Change the direction of the copy depending on how SRC and DST
+ overlap. */
+
+ for (i = 0; i < height; ++i)
+ {
+ memmove (dst_current, src_current,
+ width * pixel);
+
+ if (backwards)
+ {
+ /* Proceed to the last row. */
+ src_current -= src_info->stride;
+ dst_current -= dst_info->stride;
+ }
+ else
+ {
+ /* Proceed to the next row. */
+ src_current += src_info->stride;
+ dst_current += dst_info->stride;
+ }
+ }
+ }
+ else
+ {
+ /* Adjust the source and destination Y. The start is MAX
+ (dst_y, gc->clip_y_origin); the difference between that value
+ and dst_y is the offset to apply to src_y. */
+
+ temp = dst_y;
+ dst_y = MAX (dst_y, gc->clip_y_origin);
+ src_y += dst_y - temp;
+ height -= dst_y - temp;
+
+ /* Verify that the bounds are correct. */
+ eassert (dst_y + height
+ <= gc->clip_y_origin + mask_info->height);
+ eassert (dst_y >= gc->clip_y_origin);
+
+ /* There is a mask. For each scan line... */
+
+ if (backwards)
+ {
+ /* Calculate the number of pixels at the end of the
+ mask. */
+
+ mask_offset = dst_x + width;
+ mask_offset -= mask_info->width + gc->clip_x_origin;
+
+ if (mask_offset < 0)
+ mask_offset = 0;
+
+ /* Calculate the last column of the mask that will be
+ consulted. */
+
+ temp = dst_x - gc->clip_x_origin;
+ temp += MIN (mask_info->width - temp,
+ width - mask_offset);
+
+ if (temp < 0)
+ return;
+
+ /* Now calculate the last row of the mask that will be
+ consulted. */
+ i = dst_y - gc->clip_y_origin + height;
+
+ /* Turn both into offsets. */
+
+ if (ckd_mul (&offset, temp, pixel)
+ || ckd_mul (&offset1, i, mask_info->stride)
+ || ckd_add (&offset, offset, offset1)
+ || ckd_add (&start, (uintptr_t) mask, offset))
+ return;
+
+ if (height <= 0)
+ return;
+
+ mask = mask_current = (unsigned char *) start;
+
+ while (height--)
+ {
+ /* Skip backwards past the end of the mask. */
+
+ long_src = (unsigned int *) (src_current - mask_offset * pixel);
+ long_dst = (unsigned int *) (dst_current - mask_offset * pixel);
+ mask = mask_current;
+
+ /* For each pixel covered by the mask... */
+ temp = MIN (mask_info->width - temp, width - mask_offset);
+ while (temp--)
+ {
+ /* Copy the destination it to the source, masked by
+ the mask. */
+
+ /* Sign extend the mask. */
+ i = *(signed char *) mask--;
+
+ /* Apply the mask. */
+ *long_dst = ((*long_src & i) | (*long_dst & ~i));
+
+ long_dst--;
+ long_src--;
+ }
+
+ /* Return to the last row. */
+ src_current -= src_info->stride;
+ dst_current -= dst_info->stride;
+ mask_current -= mask_info->stride;
+ }
+ }
+ else
+ {
+ /* Calculate the first column of the mask that will be
+ consulted. */
+
+ mask_offset = dst_x - gc->clip_x_origin;
+
+ /* Adjust the mask by that much. */
+
+ if (mask_offset > 0)
+ mask += mask_offset;
+ else
+ {
+ /* Offset src and dst by the mask offset. */
+ src_current += -mask_offset * pixel;
+ dst_current += -mask_offset * pixel;
+ width += mask_offset;
+ }
+
+ /* Make sure it's not out of bounds. */
+
+ eassert (dst_y - gc->clip_y_origin >= 0);
+ if ((dst_y - gc->clip_y_origin) + height > mask_info->height
+ || width <= 0)
+ return;
+
+ /* Now move mask to the position of the first row. */
+
+ mask += ((dst_y - gc->clip_y_origin)
+ * mask_info->stride);
+
+ /* Determine how many bytes need to be copied. */
+
+ if (mask_offset > 0)
+ temp = MIN (mask_info->width - mask_offset, width);
+ else
+ temp = MIN (mask_info->width, width);
+
+ if (temp <= 0 || height <= 0)
+ return;
+
+ /* Copy bytes according to the mask. */
+
+ while (height--)
+ {
+ long_src = (unsigned int *) src_current;
+ long_dst = (unsigned int *) dst_current;
+ mask_current = mask;
+
+#ifndef __aarch64__
+ for (j = 0; j < temp; ++j)
+ {
+ /* Sign extend the mask. */
+ i = *(signed char *) mask_current++;
+
+ /* Apply the mask. */
+ *long_dst = ((*long_src & i) | (*long_dst & ~i));
+ long_dst++;
+ long_src++;
+ }
+#else /* __aarch64__ */
+ android_neon_mask_line (long_src, long_dst, mask, temp);
+#endif /* __aarch64__ */
+
+ src_current += src_info->stride;
+ dst_current += dst_info->stride;
+ mask += mask_info->stride;
+ }
+ }
+ }
+}
+
+
+/* Xor a rectangle SRC_X, SRC_Y, WIDTH and HEIGHT from SRC, described
+ by SRC_INFO, to DST_X and DST_Y in DST, as described by DST_INFO.
+
+ Ignore the alpha channel when computing the exclusive-or of the
+ destination pixel.
+
+ If MASK is set, mask the source data using MASK_INFO, translating
+ it by GC->clip_x_origin and GC->clip_y_origin. MASK must be a
+ pixmap of depth 1.
+
+ N.B. that currently only copies between bitmaps of depth 24 are
+ implemented. */
+
+static void
+android_blit_xor (int src_x, int src_y, int width, int height,
+ int dst_x, int dst_y, struct android_gc *gc,
+ unsigned char *src, AndroidBitmapInfo *src_info,
+ unsigned char *dst, AndroidBitmapInfo *dst_info,
+ unsigned char *mask, AndroidBitmapInfo *mask_info)
+{
+#if 0
+ uintptr_t start, end;
+ int mask_offset;
+ size_t pixel, offset, offset1;
+ unsigned char *src_current, *dst_current;
+ unsigned char *mask_current;
+ int overflow, temp, i;
+ bool backwards;
+ unsigned int *long_src, *long_dst;
+#endif /* 0 */
+
+ /* Note that this alu hasn't been tested -- it probably does not
+ work! */
+ emacs_abort ();
+
+#if 0
+ /* Assert that the specified coordinates are within bounds. */
+ eassert (src_x >= 0 && src_y >= 0
+ && dst_x >= 0 && dst_y >= 0);
+ eassert (src_x + width <= src_info->width);
+ eassert (src_y + height <= src_info->height);
+ eassert (dst_x + width <= dst_info->width);
+ eassert (dst_y + height <= dst_info->height);
+
+ /* Now check that each bitmap has the correct format. */
+ eassert (src_info->format == dst_info->format
+ && src_info->format == ANDROID_BITMAP_FORMAT_RGBA_8888);
+ pixel = sizeof (unsigned int);
+
+ /* Android doesn't have A1 bitmaps, so A8 is used to represent
+ packed bitmaps of depth 1. */
+ eassert (!mask || mask_info->format == ANDROID_BITMAP_FORMAT_A_8);
+
+ /* Calculate the address of the first pixel of the first row to be
+ copied in both src and dst. Compare them to determine the
+ direction in which the copy is to take place. */
+
+ overflow = ckd_mul (&start, src_y, src_info->stride);
+ overflow |= ckd_mul (&end, src_x, pixel);
+ overflow |= ckd_add (&start, (uintptr_t) src, start);
+
+ if (overflow)
+ return;
+
+ src_current = (unsigned char *) start;
+
+ overflow = ckd_mul (&start, dst_y, src_info->stride);
+ overflow |= ckd_mul (&end, dst_x, pixel);
+ overflow |= ckd_add (&start, (uintptr_t) dst, start);
+
+ if (overflow)
+ return;
+
+ dst_current = (unsigned char *) start;
+ backwards = false;
+
+ /* Now see if copying should proceed from the bottom up. */
+
+ if (src == dst && dst_current >= src_current)
+ {
+ backwards = true;
+
+ /* Walk src and dst from bottom to top, in order to avoid
+ overlap. Calculate the coordinate of the last pixel of the
+ last row in both src and dst. */
+
+ overflow = ckd_mul (&start, src_y + height - 1,
+ src_info->stride);
+ if (mask) /* If a mask is set, put the pointers before the end
+ of the row. */
+ overflow |= ckd_mul (&end, src_x + width - 1, pixel);
+ else
+ overflow |= ckd_mul (&end, src_x, pixel);
+ overflow |= ckd_add (&start, start, end);
+ overflow |= ckd_add (&start, (uintptr_t) src, start);
+
+ if (overflow)
+ return;
+
+ src_current = (unsigned char *) start;
+
+ overflow = ckd_mul (&start, dst_y + height - 1,
+ dst_info->stride);
+ if (mask) /* If a mask is set, put the pointers before the end
+ of the row. */
+ overflow |= ckd_mul (&end, dst_x + width - 1, pixel);
+ else
+ overflow |= ckd_mul (&end, dst_x, pixel);
+ overflow |= ckd_add (&start, start, end);
+ overflow |= ckd_add (&start, (uintptr_t) dst, start);
+
+ if (overflow)
+ return;
+
+ dst_current = (unsigned char *) start;
+ }
+
+ if (!mask)
+ {
+ /* Change the direction of the copy depending on how SRC and DST
+ overlap. */
+
+ for (i = 0; i < height; ++i)
+ {
+ if (backwards)
+ {
+ for (i = width - 1; i <= 0; --i)
+ (((unsigned int *) dst_current)[i])
+ /* Keep the alpha channel intact. */
+ ^= (((unsigned int *) src_current)[i]) & 0xffffff;
+
+ /* Proceed to the last row. */
+ src_current -= src_info->stride;
+ dst_current -= dst_info->stride;
+ }
+ else
+ {
+ for (i = 0; i < width; ++i)
+ (((unsigned int *) dst_current)[i])
+ /* Keep the alpha channel intact. */
+ ^= (((unsigned int *) src_current)[i]) & 0xffffff;
+
+ /* Proceed to the next row. */
+ src_current += src_info->stride;
+ dst_current += dst_info->stride;
+ }
+ }
+ }
+ else
+ {
+ /* Adjust the source and destination Y. The start is MAX
+ (dst_y, gc->clip_y_origin); the difference between that value
+ and dst_y is the offset to apply to src_y. */
+
+ temp = dst_y;
+ dst_y = MAX (dst_y, gc->clip_y_origin);
+ src_y += dst_y - temp;
+ height -= dst_y - temp;
+
+ /* Verify that the bounds are correct. */
+ eassert (dst_y + height
+ <= gc->clip_y_origin + mask_info->height);
+ eassert (dst_y >= gc->clip_y_origin);
+
+ /* There is a mask. For each scan line... */
+
+ if (backwards)
+ {
+ /* Calculate the number of pixels at the end of the
+ mask. */
+
+ mask_offset = dst_x + width;
+ mask_offset -= mask_info->width + gc->clip_x_origin;
+
+ if (mask_info < 0)
+ mask_info = 0;
+
+ /* Calculate the last column of the mask that will be
+ consulted. */
+
+ temp = dst_x - gc->clip_x_origin;
+ temp += MIN (mask_info->width - temp,
+ width - mask_offset);
+
+ if (temp < 0)
+ return;
+
+ /* Now calculate the last row of the mask that will be
+ consulted. */
+ i = dst_y - gc->clip_y_origin + height;
+
+ /* Turn both into offsets. */
+
+ if (ckd_mul (&offset, temp, pixel)
+ || ckd_mul (&offset1, i, mask_info->stride)
+ || ckd_add (&offset, offset, offset1)
+ || ckd_add (&start, (uintptr_t) mask, offset))
+ return;
+
+ mask = mask_current = (unsigned char *) start;
+
+ for (i = 0; i < height; ++i)
+ {
+ /* Skip backwards past the end of the mask. */
+
+ long_src = (unsigned int *) (src_current - mask_offset * pixel);
+ long_dst = (unsigned int *) (dst_current - mask_offset * pixel);
+ mask = mask_current;
+
+ /* For each pixel covered by the mask... */
+ temp = MIN (mask_info->width - temp, width - mask_offset);
+ while (temp--)
+ /* XOR the source to the destination, masked by the
+ mask. */
+ *long_dst-- ^= ((*(long_src--) & (0u - (*(mask--) & 1)))
+ & 0xffffff);
+
+ /* Return to the last row. */
+ src_current -= src_info->stride;
+ dst_current -= dst_info->stride;
+ mask_current -= mask_info->stride;
+ }
+ }
+ else
+ {
+ /* Calculate the first column of the mask that will be
+ consulted. */
+
+ mask_offset = dst_x - gc->clip_x_origin;
+
+ /* Adjust the mask by that much. */
+
+ if (mask_offset > 0)
+ mask += mask_offset;
+ else
+ {
+ /* Offset src and dst by the mask offset. */
+ src_current += -mask_offset * pixel;
+ dst_current += -mask_offset * pixel;
+ width -= mask_offset;
+ }
+
+ /* Now move mask to the position of the first row. */
+
+ mask += gc->clip_y_origin * mask_info->stride;
+
+ for (i = 0; i < height; ++i)
+ {
+ long_src = (unsigned int *) src_current;
+ long_dst = (unsigned int *) dst_current;
+ mask_current = mask;
+
+ if (mask_offset > 0)
+ {
+ /* Copy bytes according to the mask. */
+ temp = MIN (mask_info->width - mask_offset, width);
+ while (temp--)
+ *long_dst++ ^= ((*(long_src++)
+ & (0u - (*(mask_current++) & 1)))
+ & 0xffffff);
+ }
+ else
+ {
+ /* Copy bytes according to the mask. */
+ temp = MIN (mask_info->width, width);
+ while (temp--)
+ *long_dst++ = ((*(long_src++)
+ & (0u - (*(mask_current++) & 1)))
+ & 0xffffff);
+ }
+
+ src_current += src_info->stride;
+ dst_current += dst_info->stride;
+ mask += mask_info->stride;
+ }
+ }
+ }
+#endif /* 0 */
+}
+
+void
+android_copy_area (android_drawable src, android_drawable dest,
+ struct android_gc *gc, int src_x, int src_y,
+ unsigned int width, unsigned int height,
+ int dest_x, int dest_y)
+{
+ jobject src_object, dest_object, mask;
+ android_blit_func do_blit;
+ AndroidBitmapInfo src_info, dest_info, mask_info;
+ void *src_data, *dest_data, *mask_data;
+ int n_clip_rects, i;
+ bool flag;
+ struct android_rectangle bounds, rect, temp, *clip_rectangles;
+
+ /* Perform the copy. Loop over each clip rectangle, unless none are
+ set. Also, obtain bitmaps for src and dst, and possibly the mask
+ as well if it is present. */
+
+ src_data = android_lock_bitmap (src, &src_info, &src_object);
+ if (!src_data)
+ return;
+
+ mask_data = mask = NULL;
+
+ if (src != dest)
+ {
+ dest_data = android_lock_bitmap (dest, &dest_info, &dest_object);
+ if (!dest_data)
+ goto fail;
+ }
+ else
+ {
+ dest_data = src_data;
+ dest_info = src_info;
+ }
+
+ /* Obtain the bitmap for the mask if necessary. */
+
+ if (gc->clip_mask)
+ {
+ mask_data = android_lock_bitmap (gc->clip_mask,
+ &mask_info, &mask);
+ if (!mask_data)
+ goto fail1;
+ }
+
+ /* Calculate the number of clip rectangles. */
+ n_clip_rects = gc->num_clip_rects;
+
+ /* If n_clip_rects is -1, then no clipping is in effect. Set rect
+ to the bounds of the destination. */
+
+ flag = n_clip_rects == -1;
+ if (flag)
+ {
+ n_clip_rects = 1;
+ clip_rectangles = &rect;
+ }
+ else if (!n_clip_rects)
+ goto fail2;
+ else
+ clip_rectangles = gc->clip_rects;
+
+ /* Set rect to the bounds of the destination. */
+
+ rect.x = 0;
+ rect.y = 0;
+ rect.width = dest_info.width;
+ rect.height = dest_info.height;
+
+ if (mask_data)
+ {
+ /* Clip width and height to that of the mask. */
+
+ if (src_x + width > mask_info.width)
+ width = mask_info.width - src_x;
+
+ if (src_y + height > mask_info.height)
+ height = mask_info.height - src_y;
+ }
+
+ /* Clip width and height to that of the source. */
+
+ if (src_x + width > src_info.width)
+ width = src_info.width - src_x;
+
+ if (src_y + height > src_info.height)
+ height = src_info.height - src_y;
+
+ /* Return if the copy is outside the source. */
+
+ if (width <= 0 || height <= 0)
+ goto fail2;
+
+ /* Look up the right function for the alu. */
+
+ switch (gc->function)
+ {
+ case ANDROID_GC_COPY:
+ do_blit = android_blit_copy;
+ break;
+
+ case ANDROID_GC_XOR:
+ do_blit = android_blit_xor;
+ break;
+
+ default:
+ emacs_abort ();
+ }
+
+ /* Load the bounds of the destination rectangle. */
+ bounds.x = dest_x;
+ bounds.y = dest_y;
+ bounds.width = width;
+ bounds.height = height;
+
+ /* For each clip rectangle... */
+ for (i = 0; i < n_clip_rects; ++i)
+ {
+ /* Calculate its intersection with the destination
+ rectangle. */
+
+ if (!gui_intersect_rectangles (&clip_rectangles[i], &bounds,
+ &temp))
+ continue;
+
+ /* And that of the destination itself. */
+
+ if (!flag && !gui_intersect_rectangles (&temp, &rect, &temp))
+ continue;
+
+ /* Now perform the copy. */
+ (*do_blit) (src_x + temp.x - dest_x, /* temp.x relative to src_x */
+ src_y + temp.y - dest_y, /* temp.y relative to src_y */
+ temp.width, /* Width of area to copy. */
+ temp.height, /* Height of area to copy. */
+ temp.x, temp.y, /* Coordinates to copy to. */
+ gc, /* GC. */
+ src_data, &src_info, /* Source drawable. */
+ dest_data, &dest_info, /* Destination drawable. */
+ mask_data, &mask_info); /* Mask drawable. */
+ }
+
+ /* Now damage the destination drawable accordingly, should it be a
+ window. */
+
+ if (android_handles[dest].type == ANDROID_HANDLE_WINDOW)
+ android_damage_window (dest, &bounds);
+
+ fail2:
+ if (mask)
+ {
+ AndroidBitmap_unlockPixels (android_java_env, mask);
+ ANDROID_DELETE_LOCAL_REF (mask);
+ }
+ fail1:
+ if (src != dest)
+ {
+ AndroidBitmap_unlockPixels (android_java_env, dest_object);
+ ANDROID_DELETE_LOCAL_REF (dest_object);
+ }
+ fail:
+ AndroidBitmap_unlockPixels (android_java_env, src_object);
+ ANDROID_DELETE_LOCAL_REF (src_object);
+}
+
+
+
+void
+android_free_pixmap (android_pixmap pixmap)
+{
+ android_destroy_handle (pixmap);
+}
+
+void
+android_set_background (struct android_gc *gc, unsigned long background)
+{
+ struct android_gc_values gcv;
+
+ gcv.background = background;
+ android_change_gc (gc, ANDROID_GC_BACKGROUND, &gcv);
+}
+
+void
+android_fill_polygon (android_drawable drawable, struct android_gc *gc,
+ struct android_point *points, int npoints,
+ enum android_shape shape, enum android_coord_mode mode)
+{
+ jobjectArray array;
+ jobject point, drawable_object, gcontext;
+ int i;
+
+ drawable_object = android_resolve_handle2 (drawable,
+ ANDROID_HANDLE_WINDOW,
+ ANDROID_HANDLE_PIXMAP);
+ gcontext = android_resolve_handle (gc->gcontext,
+ ANDROID_HANDLE_GCONTEXT);
+
+ array = (*android_java_env)->NewObjectArray (android_java_env,
+ npoints,
+ point_class.class,
+ NULL);
+ android_exception_check ();
+
+ for (i = 0; i < npoints; ++i)
+ {
+ point = (*android_java_env)->NewObject (android_java_env,
+ point_class.class,
+ point_class.constructor,
+ (jint) points[i].x,
+ (jint) points[i].y);
+ android_exception_check_1 (array);
+
+ (*android_java_env)->SetObjectArrayElement (android_java_env,
+ array, i, point);
+ ANDROID_DELETE_LOCAL_REF (point);
+ }
+
+ (*android_java_env)->CallNonvirtualVoidMethod (android_java_env,
+ emacs_service,
+ service_class.class,
+ service_class.fill_polygon,
+ drawable_object,
+ gcontext, array);
+ android_exception_check_1 (array);
+ ANDROID_DELETE_LOCAL_REF (array);
+}
+
+void
+android_draw_rectangle (android_drawable handle, struct android_gc *gc,
+ int x, int y, unsigned int width, unsigned int height)
+{
+ jobject drawable, gcontext;
+
+ drawable = android_resolve_handle2 (handle,
+ ANDROID_HANDLE_WINDOW,
+ ANDROID_HANDLE_PIXMAP);
+ gcontext = android_resolve_handle (gc->gcontext,
+ ANDROID_HANDLE_GCONTEXT);
+
+ (*android_java_env)->CallNonvirtualVoidMethod (android_java_env,
+ emacs_service,
+ service_class.class,
+ service_class.draw_rectangle,
+ drawable, gcontext,
+ (jint) x, (jint) y,
+ (jint) width, (jint) height);
+
+ /* In lieu of android_exception_check, clear all exceptions after
+ calling this frequently called graphics operation. */
+ (*android_java_env)->ExceptionClear (android_java_env);
+}
+
+void
+android_draw_point (android_drawable handle, struct android_gc *gc,
+ int x, int y)
+{
+ jobject drawable, gcontext;
+
+ drawable = android_resolve_handle2 (handle,
+ ANDROID_HANDLE_WINDOW,
+ ANDROID_HANDLE_PIXMAP);
+ gcontext = android_resolve_handle (gc->gcontext,
+ ANDROID_HANDLE_GCONTEXT);
+
+ (*android_java_env)->CallNonvirtualVoidMethod (android_java_env,
+ emacs_service,
+ service_class.class,
+ service_class.draw_point,
+ drawable, gcontext,
+ (jint) x, (jint) y);
+
+ /* In lieu of android_exception_check, clear all exceptions after
+ calling this frequently called graphics operation. */
+ (*android_java_env)->ExceptionClear (android_java_env);
+}
+
+void
+android_draw_line (android_drawable handle, struct android_gc *gc,
+ int x, int y, int x2, int y2)
+{
+ jobject drawable, gcontext;
+
+ drawable = android_resolve_handle2 (handle,
+ ANDROID_HANDLE_WINDOW,
+ ANDROID_HANDLE_PIXMAP);
+ gcontext = android_resolve_handle (gc->gcontext,
+ ANDROID_HANDLE_GCONTEXT);
+
+ (*android_java_env)->CallNonvirtualVoidMethod (android_java_env,
+ emacs_service,
+ service_class.class,
+ service_class.draw_line,
+ drawable, gcontext,
+ (jint) x, (jint) y,
+ (jint) x2, (jint) y2);
+
+ /* In lieu of android_exception_check, clear all exceptions after
+ calling this frequently called graphics operation. */
+ (*android_java_env)->ExceptionClear (android_java_env);
+}
+
+android_pixmap
+android_create_pixmap (unsigned int width, unsigned int height,
+ int depth)
+{
+ android_handle prev_max_handle;
+ jobject object;
+ android_pixmap pixmap;
+
+ /* First, allocate the pixmap handle. */
+ prev_max_handle = max_handle;
+ pixmap = android_alloc_id ();
+
+ if (!pixmap)
+ error ("Out of pixmap handles!");
+
+ object = (*android_java_env)->NewObject (android_java_env,
+ pixmap_class.class,
+ pixmap_class.constructor_mutable,
+ (jshort) pixmap,
+ (jint) width, (jint) height,
+ (jint) depth);
+
+ if (!object)
+ {
+ (*android_java_env)->ExceptionClear (android_java_env);
+ max_handle = prev_max_handle;
+ memory_full (0);
+ }
+
+ android_handles[pixmap].type = ANDROID_HANDLE_PIXMAP;
+ android_handles[pixmap].handle
+ = (*android_java_env)->NewGlobalRef (android_java_env, object);
+ (*android_java_env)->ExceptionClear (android_java_env);
+ ANDROID_DELETE_LOCAL_REF (object);
+
+ if (!android_handles[pixmap].handle)
+ memory_full (0);
+
+ return pixmap;
+}
+
+void
+android_set_ts_origin (struct android_gc *gc, int x, int y)
+{
+ struct android_gc_values gcv;
+
+ gcv.ts_x_origin = x;
+ gcv.ts_y_origin = y;
+ android_change_gc (gc, (ANDROID_GC_TILE_STIP_X_ORIGIN
+ | ANDROID_GC_TILE_STIP_Y_ORIGIN),
+ &gcv);
+}
+
+void
+android_clear_area (android_window handle, int x, int y,
+ unsigned int width, unsigned int height)
+{
+ jobject window;
+
+ window = android_resolve_handle (handle, ANDROID_HANDLE_WINDOW);
+
+ (*android_java_env)->CallNonvirtualVoidMethod (android_java_env,
+ window,
+ window_class.class,
+ window_class.clear_area,
+ (jint) x, (jint) y,
+ (jint) width, (jint) height);
+}
+
+android_pixmap
+android_create_bitmap_from_data (char *bits, unsigned int width,
+ unsigned int height)
+{
+ return android_create_pixmap_from_bitmap_data (bits, 1, 0,
+ width, height, 1);
+}
+
+struct android_image *
+android_create_image (unsigned int depth, enum android_image_format format,
+ char *data, unsigned int width, unsigned int height)
+{
+ struct android_image *image;
+
+ image = xmalloc (sizeof *image);
+
+ /* Fill in the fields required by image.c. N.B. that
+ android_destroy_image ostensibly will free data, but image.c
+ mostly sets and frees data itself. */
+ image->width = width;
+ image->height = height;
+ image->data = data;
+ image->depth = depth;
+ image->format = format;
+
+ /* Now fill in the image dimensions. There are only two depths
+ supported by this function. */
+
+ if (depth == 1)
+ {
+ image->bytes_per_line = (width + 7) / 8;
+ image->bits_per_pixel = 1;
+ }
+ else if (depth == 24)
+ {
+ image->bytes_per_line = width * 4;
+ image->bits_per_pixel = 32;
+ }
+ else
+ emacs_abort ();
+
+ return image;
+}
+
+void
+android_destroy_image (struct android_image *ximg)
+{
+ /* If XIMG->data is NULL, then it has already been freed by
+ image.c. */
+
+ if (ximg->data)
+ xfree (ximg->data);
+ xfree (ximg);
+}
+
+void
+android_put_pixel (struct android_image *ximg, int x, int y,
+ unsigned long pixel)
+{
+ char *byte, *word;
+ unsigned int r, g, b;
+ unsigned int pixel_int;
+
+ /* Ignore out-of-bounds accesses. */
+
+ if (x >= ximg->width || y >= ximg->height || x < 0 || y < 0)
+ return;
+
+ switch (ximg->depth)
+ {
+ case 1:
+ byte = ximg->data + y * ximg->bytes_per_line + x / 8;
+
+ if (pixel)
+ *byte |= (1 << x % 8);
+ else
+ *byte &= ~(1 << x % 8);
+ break;
+
+ case 24:
+ /* Unaligned accesses are problematic on Android devices. */
+ word = ximg->data + y * ximg->bytes_per_line + x * 4;
+
+ /* Swizzle the pixel into ABGR format. Android uses Skia's
+ ``native color type'', which is ABGR. This is despite the
+ format being named ``ARGB'', and more confusingly
+ `ANDROID_BITMAP_FORMAT_RGBA_8888' in bitmap.h. */
+ r = pixel & 0x00ff0000;
+ g = pixel & 0x0000ff00;
+ b = pixel & 0x000000ff;
+ pixel = (r >> 16) | g | (b << 16) | 0xff000000;
+
+ pixel_int = pixel;
+ memcpy (word, &pixel_int, sizeof pixel_int);
+ break;
+ }
+}
+
+unsigned long
+android_get_pixel (struct android_image *ximg, int x, int y)
+{
+ char *byte, *word;
+ unsigned int pixel, r, g, b;
+
+ if (x >= ximg->width || y >= ximg->height
+ || x < 0 || y < 0)
+ return 0;
+
+ switch (ximg->depth)
+ {
+ case 1:
+ byte = ximg->data + y * ximg->bytes_per_line + x / 8;
+ return (*byte & (1 << x % 8)) ? 1 : 0;
+
+ case 24:
+ word = ximg->data + y * ximg->bytes_per_line + x * 4;
+ memcpy (&pixel, word, sizeof pixel);
+
+ /* Convert the pixel back to RGB. */
+ b = pixel & 0x00ff0000;
+ g = pixel & 0x0000ff00;
+ r = pixel & 0x000000ff;
+ pixel = ((r << 16) | g | (b >> 16)) & ~0xff000000;
+
+ return pixel;
+ }
+
+ emacs_abort ();
+}
+
+struct android_image *
+android_get_image (android_drawable handle,
+ enum android_image_format format)
+{
+ jobject drawable, bitmap;
+ AndroidBitmapInfo bitmap_info;
+ size_t byte_size;
+ void *data;
+ struct android_image *image;
+ unsigned char *data1, *data2;
+ int i, x;
+
+ drawable = android_resolve_handle2 (handle, ANDROID_HANDLE_WINDOW,
+ ANDROID_HANDLE_PIXMAP);
+
+ /* Look up the drawable and get the bitmap corresponding to it.
+ Then, lock the bitmap's bits. */
+ bitmap = (*android_java_env)->CallObjectMethod (android_java_env,
+ drawable,
+ drawable_class.get_bitmap);
+ android_exception_check ();
+
+ /* Clear the bitmap info structure. */
+ memset (&bitmap_info, 0, sizeof bitmap_info);
+
+ /* The NDK doc seems to imply this function can fail but doesn't say
+ what value it gives when it does! */
+ AndroidBitmap_getInfo (android_java_env, bitmap, &bitmap_info);
+
+ if (!bitmap_info.stride)
+ {
+ ANDROID_DELETE_LOCAL_REF (bitmap);
+ memory_full (0);
+ }
+
+ /* Compute how big the image data will be. Fail if it would be too
+ big. */
+
+ if (bitmap_info.format != ANDROID_BITMAP_FORMAT_A_8)
+ {
+ if (ckd_mul (&byte_size,
+ (size_t) bitmap_info.stride,
+ (size_t) bitmap_info.height))
+ {
+ ANDROID_DELETE_LOCAL_REF (bitmap);
+ memory_full (0);
+ }
+ }
+ else
+ /* This A8 image will be packed into A1 later on. */
+ byte_size = (bitmap_info.width + 7) / 8;
+
+ /* Lock the image data. Once again, the NDK documentation says the
+ call can fail, but does not say how to determine whether or not
+ it has failed, nor how the address is aligned. */
+ data = NULL;
+ AndroidBitmap_lockPixels (android_java_env, bitmap, &data);
+
+ if (!data)
+ {
+ /* Take a NULL pointer to mean that AndroidBitmap_lockPixels
+ failed. */
+ ANDROID_DELETE_LOCAL_REF (bitmap);
+ memory_full (0);
+ }
+
+ /* Copy the data into a new struct android_image. */
+ image = xmalloc (sizeof *image);
+ image->width = bitmap_info.width;
+ image->height = bitmap_info.height;
+ image->data = malloc (byte_size);
+
+ if (!image->data)
+ {
+ ANDROID_DELETE_LOCAL_REF (bitmap);
+ xfree (image);
+ memory_full (byte_size);
+ }
+
+ /* Use the format of the bitmap to determine the image depth. */
+ switch (bitmap_info.format)
+ {
+ case ANDROID_BITMAP_FORMAT_RGBA_8888:
+ image->depth = 24;
+ image->bits_per_pixel = 32;
+ break;
+
+ /* A8 images are used by Emacs to represent bitmaps. They have
+ to be packed manually. */
+ case ANDROID_BITMAP_FORMAT_A_8:
+ image->depth = 1;
+ image->bits_per_pixel = 1;
+ break;
+
+ /* Other formats are currently not supported. */
+ default:
+ emacs_abort ();
+ }
+
+ image->format = format;
+
+ if (image->depth == 24)
+ {
+ image->bytes_per_line = bitmap_info.stride;
+
+ /* Copy the bitmap data over. */
+ memcpy (image->data, data, byte_size);
+ }
+ else
+ {
+ /* Pack the A8 image data into bits manually. */
+ image->bytes_per_line = (image->width + 7) / 8;
+
+ data1 = (unsigned char *) image->data;
+ data2 = data;
+
+ for (i = 0; i < image->height; ++i)
+ {
+ for (x = 0; x < image->width; ++x)
+ /* Some bits in data1 might be initialized at this point,
+ but they will all be set properly later. */
+ data1[x / 8] = (data2[x]
+ ? (data1[x / 8] | (1 << (x % 8)))
+ : (data1[x / 8] & ~(1 << (x % 8))));
+
+ data1 += image->bytes_per_line;
+ data2 += bitmap_info.stride;
+ }
+ }
+
+ /* Unlock the bitmap pixels. */
+ AndroidBitmap_unlockPixels (android_java_env, bitmap);
+
+ /* Delete the bitmap reference. */
+ ANDROID_DELETE_LOCAL_REF (bitmap);
+ return image;
+}
+
+void
+android_put_image (android_pixmap handle, struct android_image *image)
+{
+ jobject drawable, bitmap;
+ AndroidBitmapInfo bitmap_info;
+ void *data;
+ unsigned char *data_1, *data_2;
+ int i, x;
+
+ drawable = android_resolve_handle (handle, ANDROID_HANDLE_PIXMAP);
+
+ /* Look up the drawable and get the bitmap corresponding to it.
+ Then, lock the bitmap's bits. */
+ bitmap = (*android_java_env)->CallObjectMethod (android_java_env,
+ drawable,
+ drawable_class.get_bitmap);
+ android_exception_check ();
+
+ /* Clear the bitmap info structure. */
+ memset (&bitmap_info, 0, sizeof bitmap_info);
+
+ /* The NDK doc seems to imply this function can fail but doesn't say
+ what value it gives when it does! */
+ AndroidBitmap_getInfo (android_java_env, bitmap, &bitmap_info);
+
+ if (!bitmap_info.stride)
+ {
+ ANDROID_DELETE_LOCAL_REF (bitmap);
+ memory_full (0);
+ }
+
+ if (bitmap_info.width != image->width
+ || bitmap_info.height != image->height)
+ /* This is not yet supported. */
+ emacs_abort ();
+
+ /* Make sure the bitmap formats are compatible with each other. */
+
+ if ((image->depth == 24
+ && bitmap_info.format != ANDROID_BITMAP_FORMAT_RGBA_8888)
+ || (image->depth == 1
+ && bitmap_info.format != ANDROID_BITMAP_FORMAT_A_8))
+ emacs_abort ();
+
+ /* Lock the image data. Once again, the NDK documentation says the
+ call can fail, but does not say how to determine whether or not
+ it has failed, nor how the address is aligned. */
+ data = NULL;
+ AndroidBitmap_lockPixels (android_java_env, bitmap, &data);
+
+ if (!data)
+ {
+ /* Take a NULL pointer to mean that AndroidBitmap_lockPixels
+ failed. */
+ ANDROID_DELETE_LOCAL_REF (bitmap);
+ memory_full (0);
+ }
+
+ data_1 = data;
+ data_2 = (unsigned char *) image->data;
+
+ /* Copy the bitmap data over scanline-by-scanline. */
+ for (i = 0; i < image->height; ++i)
+ {
+ if (image->depth != 1)
+ memcpy (data_1, data_2,
+ image->width * (image->bits_per_pixel / 8));
+ else
+ {
+ /* Android internally uses a 1 byte-per-pixel format for
+ ALPHA_8 images. Expand the image from the 1
+ bit-per-pixel X format correctly. */
+
+ for (x = 0; x < image->width; ++x)
+ data_1[x] = (data_2[x / 8] & (1 << x % 8)) ? 0xff : 0;
+ }
+
+ data_1 += bitmap_info.stride;
+ data_2 += image->bytes_per_line;
+ }
+
+ /* Unlock the bitmap pixels. */
+ AndroidBitmap_unlockPixels (android_java_env, bitmap);
+
+ /* Delete the bitmap reference. */
+ ANDROID_DELETE_LOCAL_REF (bitmap);
+}
+
+void
+android_bell (void)
+{
+ jint duration;
+
+ /* Restrict android_keyboard_bell_duration to values between 10 and
+ 1000. */
+ duration = MIN (1000, MAX (0, android_keyboard_bell_duration));
+
+ (*android_java_env)->CallNonvirtualVoidMethod (android_java_env,
+ emacs_service,
+ service_class.class,
+ service_class.ring_bell,
+ duration);
+ android_exception_check ();
+}
+
+void
+android_set_input_focus (android_window handle, unsigned long time)
+{
+ jobject window;
+ jmethodID make_input_focus;
+
+ window = android_resolve_handle (handle, ANDROID_HANDLE_WINDOW);
+ make_input_focus = window_class.make_input_focus;
+
+ (*android_java_env)->CallNonvirtualVoidMethod (android_java_env,
+ window,
+ window_class.class,
+ make_input_focus,
+ (jlong) time);
+ android_exception_check ();
+}
+
+void
+android_raise_window (android_window handle)
+{
+ jobject window;
+ jmethodID raise;
+
+ window = android_resolve_handle (handle, ANDROID_HANDLE_WINDOW);
+ raise = window_class.raise;
+
+ (*android_java_env)->CallNonvirtualVoidMethod (android_java_env,
+ window,
+ window_class.class,
+ raise);
+ android_exception_check ();
+}
+
+void
+android_lower_window (android_window handle)
+{
+ jobject window;
+ jmethodID lower;
+
+ window = android_resolve_handle (handle, ANDROID_HANDLE_WINDOW);
+ lower = window_class.lower;
+
+ (*android_java_env)->CallNonvirtualVoidMethod (android_java_env,
+ window,
+ window_class.class,
+ lower);
+ android_exception_check ();
+}
+
+void
+android_reconfigure_wm_window (android_window handle,
+ enum android_wc_value_mask value_mask,
+ struct android_window_changes *values)
+{
+ jobject sibling, window;
+
+ window = android_resolve_handle (handle, ANDROID_HANDLE_WINDOW);
+
+ if (!(value_mask & ANDROID_CW_STACK_MODE))
+ return;
+
+ /* If value_mask & ANDROID_CW_SIBLING, place HANDLE above or below
+ values->sibling pursuant to values->stack_mode; else, reposition
+ it at the top or the bottom of its parent. */
+
+ sibling = NULL;
+
+ if (value_mask & ANDROID_CW_SIBLING)
+ sibling = android_resolve_handle (values->sibling,
+ ANDROID_HANDLE_WINDOW);
+
+ (*android_java_env)->CallNonvirtualVoidMethod (android_java_env,
+ window,
+ window_class.class,
+ window_class.reconfigure,
+ sibling,
+ (jint) values->stack_mode);
+ android_exception_check ();
+}
+
+int
+android_query_tree (android_window handle, android_window *root_return,
+ android_window *parent_return,
+ android_window **children_return,
+ unsigned int *nchildren_return)
+{
+ jobject window, array;
+ jsize nelements, i;
+ android_window *children;
+ jshort *shorts;
+ jmethodID method;
+
+ window = android_resolve_handle (handle, ANDROID_HANDLE_WINDOW);
+
+ /* window can be NULL, so this is a service method. */
+ method = service_class.query_tree;
+ array
+ = (*android_java_env)->CallNonvirtualObjectMethod (android_java_env,
+ emacs_service,
+ service_class.class,
+ method, window);
+ android_exception_check ();
+
+ /* The first element of the array is the parent window. The rest
+ are the children. */
+ nelements = (*android_java_env)->GetArrayLength (android_java_env,
+ array);
+ eassert (nelements);
+
+ /* Now fill in the children. */
+ children = xnmalloc (nelements - 1, sizeof *children);
+
+ shorts
+ = (*android_java_env)->GetShortArrayElements (android_java_env, array,
+ NULL);
+ android_exception_check_nonnull (shorts, array);
+
+ for (i = 1; i < nelements; ++i)
+ /* Subtract one from the index into children, since the parent is
+ not included. */
+ children[i - 1] = shorts[i];
+
+ /* Finally, return the parent and other values. */
+ *root_return = 0;
+ *parent_return = shorts[0];
+ *children_return = children;
+ *nchildren_return = nelements - 1;
+
+ /* Release the array contents. */
+ (*android_java_env)->ReleaseShortArrayElements (android_java_env, array,
+ shorts, JNI_ABORT);
+
+ ANDROID_DELETE_LOCAL_REF (array);
+ return 1;
+}
+
+void
+android_get_geometry (android_window handle,
+ android_window *root_return,
+ int *x_return, int *y_return,
+ unsigned int *width_return,
+ unsigned int *height_return,
+ unsigned int *border_width_return)
+{
+ jobject window;
+ jarray window_geometry;
+ jmethodID get_geometry;
+ jint *ints;
+
+ window = android_resolve_handle (handle, ANDROID_HANDLE_WINDOW);
+ get_geometry = window_class.get_window_geometry;
+
+ window_geometry
+ = (*android_java_env)->CallNonvirtualObjectMethod (android_java_env,
+ window,
+ window_class.class,
+ get_geometry);
+ android_exception_check ();
+
+ /* window_geometry is an array containing x, y, width and
+ height. border_width is always 0 on Android. */
+ eassert ((*android_java_env)->GetArrayLength (android_java_env,
+ window_geometry)
+ == 4);
+
+ *root_return = 0;
+ *border_width_return = 0;
+
+ ints
+ = (*android_java_env)->GetIntArrayElements (android_java_env,
+ window_geometry,
+ NULL);
+ android_exception_check_nonnull (ints, window_geometry);
+
+ *x_return = ints[0];
+ *y_return = ints[1];
+ *width_return = ints[2];
+ *height_return = ints[3];
+
+ (*android_java_env)->ReleaseIntArrayElements (android_java_env,
+ window_geometry,
+ ints, JNI_ABORT);
+
+ /* Now free the local reference. */
+ ANDROID_DELETE_LOCAL_REF (window_geometry);
+}
+
+void
+android_move_resize_window (android_window window, int x, int y,
+ unsigned int width, unsigned int height)
+{
+ android_move_window (window, x, y);
+ android_resize_window (window, width, height);
+}
+
+void
+android_map_raised (android_window window)
+{
+ android_raise_window (window);
+ android_map_window (window);
+}
+
+void
+android_translate_coordinates (android_window src, int x,
+ int y, int *root_x, int *root_y)
+{
+ jobject window;
+ jarray coordinates;
+ jmethodID method;
+ jint *ints;
+
+ window = android_resolve_handle (src, ANDROID_HANDLE_WINDOW);
+ method = window_class.translate_coordinates;
+ coordinates
+ = (*android_java_env)->CallNonvirtualObjectMethod (android_java_env,
+ window,
+ window_class.class,
+ method, (jint) x,
+ (jint) y);
+ android_exception_check ();
+
+ /* The array must contain two elements: X, Y translated to the root
+ window. */
+ eassert ((*android_java_env)->GetArrayLength (android_java_env,
+ coordinates)
+ == 2);
+
+ /* Obtain the coordinates from the array. */
+ ints = (*android_java_env)->GetIntArrayElements (android_java_env,
+ coordinates, NULL);
+ android_exception_check_nonnull (ints, coordinates);
+
+ *root_x = ints[0];
+ *root_y = ints[1];
+
+ /* Release the coordinates. */
+ (*android_java_env)->ReleaseIntArrayElements (android_java_env,
+ coordinates, ints,
+ JNI_ABORT);
+
+ /* And free the local reference. */
+ ANDROID_DELETE_LOCAL_REF (coordinates);
+}
+
+/* Return the character produced by combining the diacritic character
+ DCHAR with the key-producing character C in *VALUE. Value is 1 if
+ there is no character for this combination, 0 otherwise. */
+
+static int
+android_get_dead_char (unsigned int dchar, unsigned int c,
+ unsigned int *value)
+{
+ jmethodID method;
+ jclass class;
+ jint result;
+
+ /* Call getDeadChar. */
+ class = key_character_map_class.class;
+ method = key_character_map_class.get_dead_char;
+ result = (*android_java_env)->CallStaticIntMethod (android_java_env,
+ class, method,
+ (jint) dchar,
+ (jint) c);
+
+ if (result)
+ {
+ *value = result;
+ return 0;
+ }
+
+ return 1;
+}
+
+/* Return a Unicode string in BUFFER_RETURN, a buffer of size
+ WCHARS_BUFFER, from the key press event EVENT, much like
+ XmbLookupString. If EVENT represents a key press without a
+ corresponding Unicode character, return its keysym in *KEYSYM_RETURN.
+ Return the action taken in *STATUS_RETURN.
+
+ COMPOSE_STATUS, if non-NULL, should point to a structure for
+ temporary information to be stored in during dead key
+ composition. */
+
+int
+android_wc_lookup_string (android_key_pressed_event *event,
+ wchar_t *buffer_return, int wchars_buffer,
+ int *keysym_return,
+ enum android_lookup_status *status_return,
+ struct android_compose_status *compose_status)
+{
+ enum android_lookup_status status;
+ int rc;
+ jobject window, string;
+ const jchar *characters;
+ jsize size;
+ size_t i;
+ JNIEnv *env;
+ unsigned int unicode_char;
+
+ env = android_java_env;
+ status = ANDROID_LOOKUP_NONE;
+ rc = 0;
+
+ /* See if an actual lookup has to be made. Note that while
+ BUFFER_RETURN is wchar_t, the returned characters are always in
+ UCS. */
+
+ if (event->unicode_char != (uint32_t) -1)
+ {
+ if (event->unicode_char)
+ {
+ /* KeyCharacterMap.COMBINING_ACCENT. */
+ if ((event->unicode_char & 0x80000000) && compose_status)
+ goto dead_key;
+
+ /* Remove combining accent bits. */
+ unicode_char = event->unicode_char & ~0x80000000;
+
+ if (wchars_buffer < 1)
+ {
+ *status_return = ANDROID_BUFFER_OVERFLOW;
+ return 0;
+ }
+ else
+ {
+ /* If COMPOSE_STATUS holds a diacritic mark unicode_char
+ ought to be combined with, and this combination is
+ valid, return the result alone with no keysym. */
+
+ if (compose_status
+ && compose_status->chars_matched
+ && !android_get_dead_char (compose_status->accent,
+ unicode_char,
+ &unicode_char))
+ {
+ buffer_return[0] = unicode_char;
+ *status_return = ANDROID_LOOKUP_CHARS;
+ compose_status->chars_matched = 0;
+ return 1;
+ }
+ else if (compose_status && compose_status->chars_matched)
+ {
+ /* If the combination is valid the compose status must
+ be reset and no character returned. */
+ compose_status->chars_matched = 0;
+ status = ANDROID_LOOKUP_NONE;
+ return 0;
+ }
+
+ buffer_return[0] = unicode_char;
+ status = ANDROID_LOOKUP_CHARS;
+ rc = 1;
+ }
+ }
+
+ *keysym_return = event->keycode;
+
+ if (status == ANDROID_LOOKUP_CHARS)
+ status = ANDROID_LOOKUP_BOTH;
+ else
+ {
+ status = ANDROID_LOOKUP_KEYSYM;
+ rc = 0;
+ }
+
+ /* Terminate any ongoing character composition after a key is
+ registered. */
+ if (compose_status
+ /* Provided that a modifier key is not the key being
+ depressed. */
+ && !ANDROID_IS_MODIFIER_KEY (event->keycode))
+ compose_status->chars_matched = 0;
+ *status_return = status;
+ return rc;
+ }
+
+ /* Now look up the window. */
+ rc = 0;
+
+ if (!android_handles[event->window].handle
+ || (android_handles[event->window].type
+ != ANDROID_HANDLE_WINDOW))
+ status = ANDROID_LOOKUP_NONE;
+ else
+ {
+ window = android_handles[event->window].handle;
+ string
+ = (*env)->CallNonvirtualObjectMethod (env, window,
+ window_class.class,
+ window_class.lookup_string,
+ (jint) event->serial);
+ android_exception_check ();
+
+ if (!string)
+ status = ANDROID_LOOKUP_NONE;
+ else
+ {
+ /* Now return this input method string. */
+ characters = (*env)->GetStringChars (env, string, NULL);
+ android_exception_check_nonnull ((void *) characters, string);
+
+ /* Establish the size of the the string. */
+ size = (*env)->GetStringLength (env, string);
+
+ /* Copy over the string data. */
+ for (i = 0; i < MIN ((unsigned int) wchars_buffer, size); ++i)
+ buffer_return[i] = characters[i];
+
+ if (i < size)
+ status = ANDROID_BUFFER_OVERFLOW;
+ else
+ status = ANDROID_LOOKUP_CHARS;
+
+ /* Return the number of characters that should have been
+ written. */
+
+ if (size > INT_MAX)
+ rc = INT_MAX;
+ else
+ rc = size;
+
+ (*env)->ReleaseStringChars (env, string, characters);
+ ANDROID_DELETE_LOCAL_REF (string);
+ }
+ }
+
+ *status_return = status;
+ return rc;
+
+ dead_key:
+ /* event->unicode_char is a dead key, which are diacritic marks that
+ should not be directly inserted but instead be combined with a
+ subsequent character before insertion. */
+ *status_return = ANDROID_LOOKUP_NONE;
+ compose_status->chars_matched = 1;
+ compose_status->accent = event->unicode_char & ~0x80000000;
+ return 0;
+}
+
+
+
+/* Low level drawing primitives. */
+
+/* Lock the bitmap corresponding to the drawable DRAWABLE. Return the
+ bitmap data upon success, and store the bitmap object in
+ BITMAP_RETURN. Value is NULL upon failure.
+
+ The caller must take care to unlock the bitmap data afterwards. */
+
+unsigned char *
+android_lock_bitmap (android_drawable drawable,
+ AndroidBitmapInfo *bitmap_info,
+ jobject *bitmap_return)
+{
+ jobject object, bitmap;
+ void *data;
+
+ object = android_resolve_handle2 (drawable, ANDROID_HANDLE_WINDOW,
+ ANDROID_HANDLE_PIXMAP);
+
+ /* Look up the drawable and get the bitmap corresponding to it.
+ Then, lock the bitmap's bits. */
+ bitmap = (*android_java_env)->CallObjectMethod (android_java_env,
+ object,
+ drawable_class.get_bitmap);
+ if (!bitmap)
+ {
+ /* Report any exception signaled. */
+ android_exception_check ();
+
+ /* If no exception was signaled, then NULL was returned as the
+ bitmap does not presently exist due to window reconfiguration
+ on the main thread. */
+ return NULL;
+ }
+
+ memset (bitmap_info, 0, sizeof *bitmap_info);
+
+ /* Get the bitmap info. */
+ AndroidBitmap_getInfo (android_java_env, bitmap, bitmap_info);
+
+ if (!bitmap_info->stride)
+ {
+ ANDROID_DELETE_LOCAL_REF (bitmap);
+ return NULL;
+ }
+
+ /* Now lock the image data. */
+ data = NULL;
+ AndroidBitmap_lockPixels (android_java_env, bitmap, &data);
+
+ if (!data)
+ {
+ ANDROID_DELETE_LOCAL_REF (bitmap);
+ return NULL;
+ }
+
+ /* Give the bitmap to the caller. */
+ *bitmap_return = bitmap;
+
+ /* The bitmap data is now locked. */
+ return data;
+}
+
+/* Damage the window HANDLE by the given damage rectangle. */
+
+void
+android_damage_window (android_drawable handle,
+ struct android_rectangle *damage)
+{
+ jobject drawable;
+
+ drawable = android_resolve_handle (handle, ANDROID_HANDLE_WINDOW);
+
+ /* Post the damage to the drawable. */
+ (*android_java_env)->CallNonvirtualVoidMethod (android_java_env,
+ drawable,
+ window_class.class,
+ window_class.damage_rect,
+ (jint) damage->x,
+ (jint) damage->y,
+ (jint) (damage->x
+ + damage->width),
+ (jint) (damage->y
+ + damage->height));
+ android_exception_check ();
+}
+
+
+
+/* Other misc system routines. */
+
+int
+android_get_screen_width (void)
+{
+ int rc;
+ jmethodID method;
+
+ method = service_class.get_screen_width;
+ rc = (*android_java_env)->CallNonvirtualIntMethod (android_java_env,
+ emacs_service,
+ service_class.class,
+ method,
+ (jboolean) false);
+ android_exception_check ();
+ return rc;
+}
+
+int
+android_get_screen_height (void)
+{
+ int rc;
+ jmethodID method;
+
+ method = service_class.get_screen_height;
+ rc = (*android_java_env)->CallNonvirtualIntMethod (android_java_env,
+ emacs_service,
+ service_class.class,
+ method,
+ (jboolean) false);
+ android_exception_check ();
+ return rc;
+}
+
+int
+android_get_mm_width (void)
+{
+ int rc;
+ jmethodID method;
+
+ method = service_class.get_screen_width;
+ rc = (*android_java_env)->CallNonvirtualIntMethod (android_java_env,
+ emacs_service,
+ service_class.class,
+ method,
+ (jboolean) true);
+ android_exception_check ();
+ return rc;
+}
+
+int
+android_get_mm_height (void)
+{
+ int rc;
+ jmethodID method;
+
+ method = service_class.get_screen_height;
+ rc = (*android_java_env)->CallNonvirtualIntMethod (android_java_env,
+ emacs_service,
+ service_class.class,
+ method,
+ (jboolean) true);
+ android_exception_check ();
+ return rc;
+}
+
+bool
+android_detect_mouse (void)
+{
+ bool rc;
+ jmethodID method;
+
+ method = service_class.detect_mouse;
+ rc = (*android_java_env)->CallNonvirtualBooleanMethod (android_java_env,
+ emacs_service,
+ service_class.class,
+ method);
+ android_exception_check ();
+ return rc;
+}
+
+bool
+android_detect_keyboard (void)
+{
+ bool rc;
+ jmethodID method;
+
+ method = service_class.detect_keyboard;
+ rc = (*android_java_env)->CallNonvirtualBooleanMethod (android_java_env,
+ emacs_service,
+ service_class.class,
+ method);
+ android_exception_check ();
+ return rc;
+}
+
+void
+android_set_dont_focus_on_map (android_window handle,
+ bool no_focus_on_map)
+{
+ jmethodID method;
+ jobject window;
+
+ window = android_resolve_handle (handle, ANDROID_HANDLE_WINDOW);
+ method = window_class.set_dont_focus_on_map;
+
+ (*android_java_env)->CallNonvirtualVoidMethod (android_java_env, window,
+ window_class.class,
+ method,
+ (jboolean) no_focus_on_map);
+ android_exception_check ();
+}
+
+void
+android_set_dont_accept_focus (android_window handle,
+ bool no_accept_focus)
+{
+ jmethodID method;
+ jobject window;
+
+ window = android_resolve_handle (handle, ANDROID_HANDLE_WINDOW);
+ method = window_class.set_dont_accept_focus;
+
+ (*android_java_env)->CallNonvirtualVoidMethod (android_java_env, window,
+ window_class.class,
+ method,
+ (jboolean) no_accept_focus);
+ android_exception_check ();
+}
+
+void
+android_get_keysym_name (int keysym, char *name_return, size_t size)
+{
+ jobject string;
+ const char *buffer;
+ jmethodID method;
+
+ /* These keysyms are special editor actions sent by the input
+ method. */
+
+ switch (keysym)
+ {
+ case 65536 + 1:
+ strncpy (name_return, "select-all", size - 1);
+ name_return[size] = '\0';
+ return;
+
+ case 65536 + 2:
+ strncpy (name_return, "start-selecting-text", size - 1);
+ name_return[size] = '\0';
+ return;
+
+ case 65536 + 3:
+ strncpy (name_return, "stop-selecting-text", size - 1);
+ name_return[size] = '\0';
+ return;
+ }
+
+ method = service_class.name_keysym;
+ string
+ = (*android_java_env)->CallNonvirtualObjectMethod (android_java_env,
+ emacs_service,
+ service_class.class,
+ method,
+ (jint) keysym);
+ android_exception_check ();
+
+ if (!string)
+ {
+ strncpy (name_return, "stop-selecting-text", size - 1);
+ name_return[size] = '\0';
+ return;
+ }
+
+ buffer = (*android_java_env)->GetStringUTFChars (android_java_env,
+ (jstring) string,
+ NULL);
+ android_exception_check_nonnull ((void *) buffer, string);
+ strncpy (name_return, buffer, size - 1);
+ name_return[size] = '\0';
+
+ (*android_java_env)->ReleaseStringUTFChars (android_java_env,
+ (jstring) string,
+ buffer);
+ ANDROID_DELETE_LOCAL_REF (string);
+}
+
+/* Display the on screen keyboard on window WINDOW, or hide it if SHOW
+ is false. Ask the system to bring up or hide the on-screen
+ keyboard on behalf of WINDOW. The request may be rejected by the
+ system, especially when the window does not have the input
+ focus. */
+
+void
+android_toggle_on_screen_keyboard (android_window window, bool show)
+{
+ jobject object;
+ jmethodID method;
+
+ object = android_resolve_handle (window, ANDROID_HANDLE_WINDOW);
+ method = window_class.toggle_on_screen_keyboard;
+
+ /* Now display the on screen keyboard. */
+ (*android_java_env)->CallNonvirtualVoidMethod (android_java_env, object,
+ window_class.class,
+ method, (jboolean) show);
+
+ /* Check for out of memory errors. */
+ android_exception_check ();
+}
+
+
+
+#if defined __clang_major__ && __clang_major__ < 5
+# define HAS_BUILTIN_TRAP 0
+#elif 3 < __GNUC__ + (3 < __GNUC_MINOR__ + (4 <= __GNUC_PATCHLEVEL__))
+# define HAS_BUILTIN_TRAP 1
+#elif defined __has_builtin
+# define HAS_BUILTIN_TRAP __has_builtin (__builtin_trap)
+#else /* !__has_builtin */
+# define HAS_BUILTIN_TRAP 0
+#endif /* defined __clang_major__ && __clang_major__ < 5 */
+
+/* emacs_abort implementation for Android. This logs a stack
+ trace. */
+
+void
+emacs_abort (void)
+{
+#ifndef HAS_BUILTIN_TRAP
+ volatile char *foo;
+#endif /* !HAS_BUILTIN_TRAP */
+
+ __android_log_print (ANDROID_LOG_FATAL, __func__,
+ "emacs_abort called, please review the following"
+ " stack trace");
+
+#ifndef HAS_BUILTIN_TRAP
+ /* Induce a NULL pointer dereference to make debuggerd generate a
+ tombstone. */
+ foo = NULL;
+ *foo = '\0';
+#else /* HAS_BUILTIN_TRAP */
+ /* Crash through __builtin_trap instead. This appears to more
+ uniformly elicit crash reports from debuggerd. */
+ __builtin_trap ();
+#endif /* !HAS_BUILTIN_TRAP */
+
+ abort ();
+}
+
+
+
+/* Return whether or not TEXT, a string without multibyte
+ characters, has no bytes with the 8th bit set. */
+
+static bool
+android_check_string (Lisp_Object text)
+{
+ ptrdiff_t i;
+
+ for (i = 0; i < SBYTES (text); ++i)
+ {
+ if (SREF (text, i) & 128)
+ return false;
+ }
+
+ return true;
+}
+
+/* Verify that the specified NULL-terminated STRING is a valid JNI
+ ``UTF-8'' string. Return 0 if so, 1 otherwise.
+
+ Do not perform GC, enabling NAME to be a direct reference to string
+ data.
+
+ The native coding system used by the JVM to store strings derives
+ from UTF-8, but deviates from it in two aspects in an attempt to
+ better represent the UCS-16 based Java String format, and to let
+ strings contain NULL characters while remaining valid C strings:
+ NULL bytes are encoded as two-byte sequences, and Unicode surrogate
+ pairs encoded as two-byte sequences are preferred to four-byte
+ sequences when encoding characters above the BMP. */
+
+int
+android_verify_jni_string (const char *name)
+{
+ const unsigned char *chars;
+
+ chars = (unsigned char *) name;
+ while (*chars)
+ {
+ /* Switch on the high 4 bits. */
+
+ switch (*chars++ >> 4)
+ {
+ case 0 ... 7:
+ /* The 8th bit is clean, so this is a regular C
+ character. */
+ break;
+
+ case 8 ... 0xb:
+ /* Invalid starting byte! */
+ return 1;
+
+ case 0xf:
+ /* The start of a four byte sequence. These aren't allowed
+ in Java. */
+ return 1;
+
+ case 0xe:
+ /* The start of a three byte sequence. Verify that its
+ continued. */
+
+ if ((*chars++ & 0xc0) != 0x80)
+ return 1;
+
+ FALLTHROUGH;
+
+ case 0xc ... 0xd:
+ /* The start of a two byte sequence. Verify that the
+ next byte exists and has its high bit set. */
+
+ if ((*chars++ & 0xc0) != 0x80)
+ return 1;
+
+ break;
+ }
+ }
+
+ return 0;
+}
+
+/* Given a Lisp string TEXT, return a local reference to an equivalent
+ Java string. Each argument following TEXT should be NULL or a
+ local reference that will be freed if creating the string fails,
+ whereupon memory_full will also be signaled. */
+
+jstring
+android_build_string (Lisp_Object text, ...)
+{
+ Lisp_Object encoded;
+ jstring string;
+ size_t nchars;
+ jchar *characters;
+ va_list ap;
+ jobject object;
+
+ USE_SAFE_ALLOCA;
+
+ /* Directly encode TEXT if it contains no non-ASCII characters, or
+ is multibyte and a valid Modified UTF-8 string. This is okay
+ because the Java extended UTF format is compatible with
+ ASCII. */
+
+ if ((SBYTES (text) == SCHARS (text)
+ && android_check_string (text))
+ /* If TEXT is a multibyte string, then it's using Emacs's
+ internal UTF-8 coding system, a significant subset of which
+ is compatible with JNI. */
+ || (STRING_MULTIBYTE (text)
+ && !android_verify_jni_string (SSDATA (text))))
+ {
+ string = (*android_java_env)->NewStringUTF (android_java_env,
+ SSDATA (text));
+
+ if ((*android_java_env)->ExceptionCheck (android_java_env))
+ goto error;
+
+ SAFE_FREE ();
+ return string;
+ }
+
+ encoded = code_convert_string_norecord (text, Qutf_16le,
+ true);
+ nchars = (SBYTES (encoded) / sizeof (jchar));
+
+ /* Encode the string as UTF-16 prior to creating the string.
+ Copy the string to a separate buffer in order to preserve
+ alignment. */
+
+ characters = SAFE_ALLOCA (SBYTES (encoded));
+ memcpy (characters, SDATA (encoded), SBYTES (encoded));
+
+ /* Create the string. */
+ string
+ = (*android_java_env)->NewString (android_java_env,
+ characters, nchars);
+
+ if ((*android_java_env)->ExceptionCheck (android_java_env))
+ goto error;
+
+ SAFE_FREE ();
+ return string;
+
+ error:
+ /* An exception arose while creating the string. When this
+ transpires, an assumption is made that the error was induced by
+ running out of memory. Delete each of the local references
+ within AP. */
+
+ va_start (ap, text);
+
+ __android_log_print (ANDROID_LOG_WARN, __func__,
+ "Possible out of memory error. "
+ " The Java exception follows: ");
+ /* Describe exactly what went wrong. */
+ (*android_java_env)->ExceptionDescribe (android_java_env);
+ (*android_java_env)->ExceptionClear (android_java_env);
+
+ /* Now remove each and every local reference provided after
+ OBJECT. */
+
+ while ((object = va_arg (ap, jobject)))
+ ANDROID_DELETE_LOCAL_REF (object);
+
+ va_end (ap);
+ memory_full (0);
+}
+
+/* Do the same, except TEXT is constant string data in ASCII or
+ UTF-8 containing no characters outside the Basic Multilingual
+ Plane. */
+
+jstring
+android_build_jstring (const char *text)
+{
+ jstring string;
+
+ /* Note that Java expects this string to be in ``modified UTF
+ encoding'', which is actually UTF-8, except with NUL
+ encoded as a two-byte sequence, and surrogate pairs encoded
+ in the three-byte extended encoding. The only consequence
+ of passing an actual UTF-8 string is that NUL bytes and
+ characters requiring surrogate pairs cannot be represented,
+ which is not really of consequence. */
+
+ string = (*android_java_env)->NewStringUTF (android_java_env,
+ text);
+ android_exception_check ();
+
+ return string;
+}
+
+
+
+/* Exception checking functions. Most JNI functions which allocate
+ memory return NULL upon failure; they also set the JNI
+ environment's pending exception to an OutOfMemoryError.
+
+ These functions check for such errors and call memory_full wherever
+ appropriate. Three variants are provided: one which releases no
+ local references, one which releases a single local reference
+ before calling memory_full, and one which releases two local
+ references.
+
+ Typically, you use these functions by calling them immediately
+ after a JNI function which allocates memory, passing it any local
+ references that are already valid but should be deleted after
+ leaving the current scope. For example, to allocate foo, make
+ global_foo its global reference, and then release foo, you write:
+
+ jobject foo, global_foo;
+
+ foo = (*android_java_env)->New...;
+ android_exception_check ();
+
+ global_foo = (*android_java_env)->NewGlobalRef (..., foo);
+ android_exception_check_1 (foo);
+ ANDROID_DELETE_LOCAL_REF (foo);
+
+ where the first android_exception_check ensures that foo has been
+ allocated correctly, while the call to android_exception_check_1,
+ and the call to ANDROID_DELETE_LOCAL_REF afterwards, together
+ ensure the same of global_foo, and also that foo is released both
+ if global_foo cannot be allocated, and after the global reference
+ is created. */
+
+#if __GNUC__ >= 3
+#define likely(cond) __builtin_expect (cond, 1)
+#else /* __GNUC__ < 3 */
+#define likely(cond) (cond)
+#endif /* __GNUC__ >= 3 */
+
+/* Check for JNI exceptions and call memory_full in that
+ situation. */
+
+void
+android_exception_check (void)
+{
+ if (likely (!(*android_java_env)->ExceptionCheck (android_java_env)))
+ return;
+
+ __android_log_print (ANDROID_LOG_WARN, __func__,
+ "Possible out of memory error. "
+ " The Java exception follows: ");
+ /* Describe exactly what went wrong. */
+ (*android_java_env)->ExceptionDescribe (android_java_env);
+ (*android_java_env)->ExceptionClear (android_java_env);
+ memory_full (0);
+}
+
+/* Check for JNI exceptions. If there is one such exception, clear
+ it, then delete the local reference to OBJECT and call memory_full.
+ OBJECT can be NULL, which is a valid local reference to the Java
+ null object. */
+
+void
+android_exception_check_1 (jobject object)
+{
+ if (likely (!(*android_java_env)->ExceptionCheck (android_java_env)))
+ return;
+
+ __android_log_print (ANDROID_LOG_WARN, __func__,
+ "Possible out of memory error. "
+ " The Java exception follows: ");
+ /* Describe exactly what went wrong. */
+ (*android_java_env)->ExceptionDescribe (android_java_env);
+ (*android_java_env)->ExceptionClear (android_java_env);
+
+ if (object)
+ ANDROID_DELETE_LOCAL_REF (object);
+
+ memory_full (0);
+}
+
+/* Like android_exception_check_1, except it takes more than one local
+ reference argument. */
+
+void
+android_exception_check_2 (jobject object, jobject object1)
+{
+ if (likely (!(*android_java_env)->ExceptionCheck (android_java_env)))
+ return;
+
+ __android_log_print (ANDROID_LOG_WARN, __func__,
+ "Possible out of memory error. "
+ " The Java exception follows: ");
+ /* Describe exactly what went wrong. */
+ (*android_java_env)->ExceptionDescribe (android_java_env);
+ (*android_java_env)->ExceptionClear (android_java_env);
+
+ if (object)
+ ANDROID_DELETE_LOCAL_REF (object);
+
+ if (object1)
+ ANDROID_DELETE_LOCAL_REF (object1);
+
+ memory_full (0);
+}
+
+/* Like android_exception_check_2, except it takes more than two local
+ reference arguments. */
+
+void
+android_exception_check_3 (jobject object, jobject object1,
+ jobject object2)
+{
+ if (likely (!(*android_java_env)->ExceptionCheck (android_java_env)))
+ return;
+
+ __android_log_print (ANDROID_LOG_WARN, __func__,
+ "Possible out of memory error. "
+ " The Java exception follows: ");
+ /* Describe exactly what went wrong. */
+ (*android_java_env)->ExceptionDescribe (android_java_env);
+ (*android_java_env)->ExceptionClear (android_java_env);
+
+ if (object)
+ ANDROID_DELETE_LOCAL_REF (object);
+
+ if (object1)
+ ANDROID_DELETE_LOCAL_REF (object1);
+
+ if (object2)
+ ANDROID_DELETE_LOCAL_REF (object2);
+
+ memory_full (0);
+}
+
+/* Like android_exception_check_3, except it takes more than three
+ local reference arguments. */
+
+void
+android_exception_check_4 (jobject object, jobject object1,
+ jobject object2, jobject object3)
+{
+ if (likely (!(*android_java_env)->ExceptionCheck (android_java_env)))
+ return;
+
+ __android_log_print (ANDROID_LOG_WARN, __func__,
+ "Possible out of memory error. "
+ " The Java exception follows: ");
+ /* Describe exactly what went wrong. */
+ (*android_java_env)->ExceptionDescribe (android_java_env);
+ (*android_java_env)->ExceptionClear (android_java_env);
+
+ if (object)
+ ANDROID_DELETE_LOCAL_REF (object);
+
+ if (object1)
+ ANDROID_DELETE_LOCAL_REF (object1);
+
+ if (object2)
+ ANDROID_DELETE_LOCAL_REF (object2);
+
+ if (object3)
+ ANDROID_DELETE_LOCAL_REF (object3);
+
+ memory_full (0);
+}
+
+/* Like android_exception_check_4, except it takes more than four local
+ reference arguments. */
+
+void
+android_exception_check_5 (jobject object, jobject object1,
+ jobject object2, jobject object3,
+ jobject object4)
+{
+ if (likely (!(*android_java_env)->ExceptionCheck (android_java_env)))
+ return;
+
+ __android_log_print (ANDROID_LOG_WARN, __func__,
+ "Possible out of memory error. "
+ " The Java exception follows: ");
+ /* Describe exactly what went wrong. */
+ (*android_java_env)->ExceptionDescribe (android_java_env);
+ (*android_java_env)->ExceptionClear (android_java_env);
+
+ if (object)
+ ANDROID_DELETE_LOCAL_REF (object);
+
+ if (object1)
+ ANDROID_DELETE_LOCAL_REF (object1);
+
+ if (object2)
+ ANDROID_DELETE_LOCAL_REF (object2);
+
+ if (object3)
+ ANDROID_DELETE_LOCAL_REF (object3);
+
+ if (object4)
+ ANDROID_DELETE_LOCAL_REF (object4);
+
+ memory_full (0);
+}
+
+
+/* Like android_exception_check_5, except it takes more than five local
+ reference arguments. */
+
+void
+android_exception_check_6 (jobject object, jobject object1,
+ jobject object2, jobject object3,
+ jobject object4, jobject object5)
+{
+ if (likely (!(*android_java_env)->ExceptionCheck (android_java_env)))
+ return;
+
+ __android_log_print (ANDROID_LOG_WARN, __func__,
+ "Possible out of memory error. "
+ " The Java exception follows: ");
+ /* Describe exactly what went wrong. */
+ (*android_java_env)->ExceptionDescribe (android_java_env);
+ (*android_java_env)->ExceptionClear (android_java_env);
+
+ if (object)
+ ANDROID_DELETE_LOCAL_REF (object);
+
+ if (object1)
+ ANDROID_DELETE_LOCAL_REF (object1);
+
+ if (object2)
+ ANDROID_DELETE_LOCAL_REF (object2);
+
+ if (object3)
+ ANDROID_DELETE_LOCAL_REF (object3);
+
+ if (object4)
+ ANDROID_DELETE_LOCAL_REF (object4);
+
+ if (object5)
+ ANDROID_DELETE_LOCAL_REF (object5);
+
+ memory_full (0);
+}
+
+/* Check for JNI problems based on the value of OBJECT.
+
+ Signal out of memory if OBJECT is NULL. OBJECT1 means the
+ same as in `android_exception_check_1'.
+
+ This function is useful when checking for errors from JNI
+ functions that do not set exceptions on failure, such as
+ `GetIntArrayElements'. */
+
+void
+android_exception_check_nonnull (void *object, jobject object1)
+{
+ if (likely (object != NULL))
+ return;
+
+ if (object1)
+ ANDROID_DELETE_LOCAL_REF (object1);
+
+ memory_full (0);
+}
+
+/* Check for JNI problems based on the value of OBJECT.
+
+ Signal out of memory if OBJECT is NULL. OBJECT1 and OBJECT2 mean
+ the same as in `android_exception_check_2'. */
+
+void
+android_exception_check_nonnull_1 (void *object, jobject object1,
+ jobject object2)
+{
+ if (likely (object != NULL))
+ return;
+
+ if (object1)
+ ANDROID_DELETE_LOCAL_REF (object1);
+
+ if (object2)
+ ANDROID_DELETE_LOCAL_REF (object2);
+
+ memory_full (0);
+}
+
+
+
+/* Native image transforms. */
+
+/* Transform the coordinates X and Y by the specified affine
+ transformation MATRIX. Place the result in *XOUT and *YOUT. */
+
+static void
+android_transform_coordinates (int x, int y,
+ struct android_transform *transform,
+ float *xout, float *yout)
+{
+ /* Apply the specified affine transformation.
+ A transform looks like:
+
+ M1 M2 M3 X
+ M4 M5 M6 * Y
+
+ =
+
+ M1*X + M2*Y + M3*1 = X1
+ M4*X + M5*Y + M6*1 = Y1
+
+ (In most transforms, there is another row at the bottom for
+ mathematical reasons. Since Z1 is always 1.0, the row is simply
+ implied to be 0 0 1, because 0 * x + 0 * y + 1 * 1 = 1.0. See
+ the definition of matrix3x3 in image.c for some more explanations
+ about this.) */
+
+ *xout = transform->m1 * x + transform->m2 * y + transform->m3;
+ *yout = transform->m4 * x + transform->m5 * y + transform->m6;
+}
+
+/* Return the interpolation of the four pixels TL, TR, BL, and BR,
+ according to the weights DISTX and DISTY. */
+
+static unsigned int
+android_four_corners_bilinear (unsigned int tl, unsigned int tr,
+ unsigned int bl, unsigned int br,
+ int distx, int disty)
+{
+ int distxy, distxiy, distixy, distixiy;
+ uint32_t f, r;
+
+ distxy = distx * disty;
+ distxiy = (distx << 8) - distxy;
+ distixy = (disty << 8) - distxy;
+ distixiy = (256 * 256 - (disty << 8)
+ - (distx << 8) + distxy);
+
+ /* Red */
+ r = ((tl & 0x000000ff) * distixiy + (tr & 0x000000ff) * distxiy
+ + (bl & 0x000000ff) * distixy + (br & 0x000000ff) * distxy);
+
+ /* Green */
+ f = ((tl & 0x0000ff00) * distixiy + (tr & 0x0000ff00) * distxiy
+ + (bl & 0x0000ff00) * distixy + (br & 0x0000ff00) * distxy);
+ r |= f & 0xff000000;
+
+ /* Now do the upper two components. */
+ tl >>= 16;
+ tr >>= 16;
+ bl >>= 16;
+ br >>= 16;
+ r >>= 16;
+
+ /* Blue */
+ f = ((tl & 0x000000ff) * distixiy + (tr & 0x000000ff) * distxiy
+ + (bl & 0x000000ff) * distixy + (br & 0x000000ff) * distxy);
+ r |= f & 0x00ff0000;
+
+ /* Alpha */
+ f = ((tl & 0x0000ff00) * distixiy + (tr & 0x0000ff00) * distxiy
+ + (bl & 0x0000ff00) * distixy + (br & 0x0000ff00) * distxy);
+ r |= f & 0xff000000;
+
+ return r;
+}
+
+/* Return the interpolation of the four pixels closest to at X, Y in
+ IMAGE, according to weights in both axes computed from X and Y.
+ IMAGE must be depth 24, or the behavior is undefined. */
+
+static unsigned int
+android_fetch_pixel_bilinear (struct android_image *image,
+ float x, float y)
+{
+ int x1, y1, x2, y2;
+ float distx, disty;
+ unsigned int top_left, top_right;
+ unsigned int bottom_left, bottom_right;
+ char *word;
+
+ /* Compute the four closest corners to X and Y. */
+ x1 = (int) x;
+ x2 = x1 + 1;
+ y1 = (int) y;
+ y2 = y1 + 1;
+
+ /* Make sure all four corners are within range. */
+ x1 = MAX (0, MIN (image->width - 1, x1));
+ y1 = MAX (0, MIN (image->height - 1, y1));
+ x2 = MAX (0, MIN (image->width - 1, x2));
+ y2 = MAX (0, MIN (image->height - 1, y2));
+
+ /* Compute the X and Y biases. These are numbers between 0f and
+ 1f. */
+ distx = x - x1;
+ disty = y - y1;
+
+ /* Fetch the four closest pixels. */
+ word = image->data + y1 * image->bytes_per_line + x1 * 4;
+ memcpy (&top_left, word, sizeof top_left);
+ word = image->data + y1 * image->bytes_per_line + x2 * 4;
+ memcpy (&top_right, word, sizeof top_right);
+ word = image->data + y2 * image->bytes_per_line + x1 * 4;
+ memcpy (&bottom_left, word, sizeof bottom_left);
+ word = image->data + y2 * image->bytes_per_line + x2 * 4;
+ memcpy (&bottom_right, word, sizeof bottom_right);
+
+ /* Do the interpolation. */
+ return android_four_corners_bilinear (top_left, top_right, bottom_left,
+ bottom_right, distx * 256,
+ disty * 256);
+}
+
+/* Transform the depth 24 image IMAGE by the 3x2 affine transformation
+ matrix MATRIX utilizing a bilinear filter. Place the result in
+ OUT. The matrix maps from the coordinate space of OUT to
+ IMAGE. */
+
+void
+android_project_image_bilinear (struct android_image *image,
+ struct android_image *out,
+ struct android_transform *transform)
+{
+ int x, y;
+ unsigned int pixel;
+ float xout, yout;
+ char *word;
+
+ /* Loop through each pixel in OUT. Transform it by TRANSFORM, then
+ interpolate it to IMAGE, and place the result back in OUT. */
+
+ for (y = 0; y < out->height; ++y)
+ {
+ for (x = 0; x < out->width; ++x)
+ {
+ /* Transform the coordinates by TRANSFORM. */
+ android_transform_coordinates (x, y, transform,
+ &xout, &yout);
+
+ /* Interpolate back to IMAGE. */
+ pixel = android_fetch_pixel_bilinear (image, xout, yout);
+
+ /* Put the pixel back in OUT. */
+ word = out->data + y * out->bytes_per_line + x * 4;
+ memcpy (word, &pixel, sizeof pixel);
+ }
+ }
+}
+
+/* Return the interpolation of X, Y to IMAGE, a depth 24 image. */
+
+static unsigned int
+android_fetch_pixel_nearest_24 (struct android_image *image, float x,
+ float y)
+{
+ int x1, y1;
+ char *word;
+ unsigned int pixel;
+
+ x1 = MAX (0, MIN (image->width - 1, (int) roundf (x)));
+ y1 = MAX (0, MIN (image->height - 1, (int) roundf (y)));
+
+ word = image->data + y1 * image->bytes_per_line + x1 * 4;
+ memcpy (&pixel, word, sizeof pixel);
+
+ return pixel;
+}
+
+/* Return the interpolation of X, Y to IMAGE, a depth 1 image. */
+
+static unsigned int
+android_fetch_pixel_nearest_1 (struct android_image *image, float x,
+ float y)
+{
+ int x1, y1;
+ char *byte;
+
+ x1 = MAX (0, MIN (image->width - 1, (int) roundf (x)));
+ y1 = MAX (0, MIN (image->height - 1, (int) roundf (y)));
+
+ byte = image->data + y1 * image->bytes_per_line;
+ return (byte[x1 / 8] & (1 << x1 % 8)) ? 1 : 0;
+}
+
+/* Transform the depth 24 or 1 image IMAGE by the 3x2 affine
+ transformation matrix MATRIX. Place the result in OUT. The matrix
+ maps from the coordinate space of OUT to IMAGE. Use a
+ nearest-neighbor filter. */
+
+void
+android_project_image_nearest (struct android_image *image,
+ struct android_image *out,
+ struct android_transform *transform)
+{
+ int x, y;
+ unsigned int pixel;
+ float xout, yout;
+ char *word, *byte;
+
+ if (image->depth == 1)
+ {
+ for (y = 0; y < out->height; ++y)
+ {
+ for (x = 0; x < out->width; ++x)
+ {
+ /* Transform the coordinates by TRANSFORM. */
+ android_transform_coordinates (x, y, transform,
+ &xout, &yout);
+
+ /* Interpolate back to IMAGE. */
+ pixel = android_fetch_pixel_nearest_1 (image, xout, yout);
+
+ /* Put the pixel back in OUT. */
+ byte = out->data + y * out->bytes_per_line + x / 8;
+
+ if (pixel)
+ *byte |= (1 << x % 8);
+ else
+ *byte &= ~(1 << x % 8);
+ }
+ }
+
+ return;
+ }
+
+ for (y = 0; y < out->height; ++y)
+ {
+ for (x = 0; x < out->width; ++x)
+ {
+ /* Transform the coordinates by TRANSFORM. */
+ android_transform_coordinates (x, y, transform,
+ &xout, &yout);
+
+ /* Interpolate back to IMAGE. */
+ pixel = android_fetch_pixel_nearest_24 (image, xout, yout);
+
+ /* Put the pixel back in OUT. */
+ word = out->data + y * out->bytes_per_line + x * 4;
+ memcpy (word, &pixel, sizeof pixel);
+ }
+ }
+}
+
+
+
+/* Other miscellaneous functions. */
+
+/* Ask the system to start browsing the specified URL. Upon failure,
+ return a string describing the error. Else, value is nil. URL
+ should be encoded unless SEND.
+
+ If SEND, open the URL with applications that can ``send'' or
+ ``share'' the URL (through mail, for example.) */
+
+Lisp_Object
+android_browse_url (Lisp_Object url, Lisp_Object send)
+{
+ jobject value, string;
+ Lisp_Object tem;
+ const char *buffer;
+
+ string = android_build_string (url, NULL);
+ value
+ = (*android_java_env)->CallNonvirtualObjectMethod (android_java_env,
+ emacs_service,
+ service_class.class,
+ service_class.browse_url,
+ string,
+ (jboolean) !NILP (send));
+ android_exception_check ();
+
+ ANDROID_DELETE_LOCAL_REF (string);
+
+ /* If no string was returned, return Qnil. */
+ if (!value)
+ return Qnil;
+
+ buffer = (*android_java_env)->GetStringUTFChars (android_java_env,
+ (jstring) value,
+ NULL);
+ android_exception_check_1 (value);
+
+ /* Otherwise, build the string describing the error. */
+ tem = build_string_from_utf8 (buffer);
+
+ (*android_java_env)->ReleaseStringUTFChars (android_java_env,
+ (jstring) value,
+ buffer);
+
+ /* And return it. */
+ ANDROID_DELETE_LOCAL_REF (value);
+ return tem;
+}
+
+/* Tell the system to restart Emacs in a short amount of time, and
+ then kill Emacs. Never return. This is used to implement
+ `restart-emacs'. */
+
+_Noreturn void
+android_restart_emacs (void)
+{
+ /* Try to call the Java side function. Normally, this should call
+ System.exit to terminate this process. */
+ (*android_java_env)->CallNonvirtualVoidMethod (android_java_env,
+ emacs_service,
+ service_class.class,
+ service_class.restart_emacs);
+
+ /* Exit anyway, in case EmacsService did not do so. */
+ exit (0);
+}
+
+/* Return a number from 1 to 34 describing the version of Android
+ Emacs is running on.
+
+ This is different from __ANDROID_API__, as that describes the
+ minimum version of Android this build of Emacs will run on, and in
+ turn which APIs Emacs can safely use. */
+
+int
+(android_get_current_api_level) (void)
+{
+ return android_api_level;
+}
+
+/* Query the status of the battery, and place it in *STATUS.
+ Value is 1 upon failure, else 0. */
+
+int
+android_query_battery (struct android_battery_state *status)
+{
+ jlongArray array;
+ jlong *longs;
+ jmethodID method;
+
+ method = service_class.query_battery;
+ array
+ = (*android_java_env)->CallNonvirtualObjectMethod (android_java_env,
+ emacs_service,
+ service_class.class,
+ method);
+ android_exception_check ();
+
+ /* A NULL return with no exception means that battery information
+ could not be obtained. */
+
+ if (!array)
+ return 1;
+
+ longs = (*android_java_env)->GetLongArrayElements (android_java_env,
+ array, NULL);
+ android_exception_check_nonnull (longs, array);
+
+ status->capacity = longs[0];
+ status->charge_counter = longs[1];
+ status->current_average = longs[2];
+ status->current_now = longs[3];
+ status->remaining = longs[4];
+ status->status = longs[5];
+ status->plugged = longs[6];
+ status->temperature = longs[7];
+
+ (*android_java_env)->ReleaseLongArrayElements (android_java_env,
+ array, longs,
+ JNI_ABORT);
+ ANDROID_DELETE_LOCAL_REF (array);
+
+ return 0;
+}
+
+/* Display a file panel and grant Emacs access to the SAF directory
+ within it. Value is 1 upon failure and 0 upon success (which only
+ indicates that the panel has been displayed successfully; the panel
+ may still be dismissed without a file being selected.) */
+
+int
+android_request_directory_access (void)
+{
+ jint rc;
+ jmethodID method;
+
+ method = service_class.request_directory_access;
+ rc = (*android_java_env)->CallNonvirtualIntMethod (android_java_env,
+ emacs_service,
+ service_class.class,
+ method);
+ android_exception_check ();
+
+ return rc;
+}
+
+/* Return whether Emacs is entitled to access external storage.
+
+ On Android 5.1 and earlier, such permissions as are declared within
+ an application's manifest are granted during installation and are
+ irrevocable.
+
+ On Android 6.0 through Android 10.0, the right to read external
+ storage is a regular permission granted from the Permissions
+ panel.
+
+ On Android 11.0 and later, that right must be granted through an
+ independent ``Special App Access'' settings panel. */
+
+bool
+android_external_storage_available_p (void)
+{
+ jboolean rc;
+ jmethodID method;
+
+ if (android_api_level <= 22) /* LOLLIPOP_MR1 */
+ return true;
+
+ method = service_class.external_storage_available;
+ rc = (*android_java_env)->CallNonvirtualBooleanMethod (android_java_env,
+ emacs_service,
+ service_class.class,
+ method);
+ android_exception_check ();
+
+ return rc;
+}
+
+/* Display a dialog from which the aforementioned rights can be
+ granted. */
+
+void
+android_request_storage_access (void)
+{
+ jmethodID method;
+
+ if (android_api_level <= 22) /* LOLLIPOP_MR1 */
+ return;
+
+ method = service_class.request_storage_access;
+ (*android_java_env)->CallNonvirtualVoidMethod (android_java_env,
+ emacs_service,
+ service_class.class,
+ method);
+ android_exception_check ();
+}
+
+/* Recreate the activity to which WINDOW is attached to debug graphics
+ code executed in response to window attachment. */
+
+void
+android_recreate_activity (android_window window)
+{
+ jobject object;
+ jmethodID method;
+
+ object = android_resolve_handle (window, ANDROID_HANDLE_WINDOW);
+ method = window_class.recreate_activity;
+
+ (*android_java_env)->CallNonvirtualVoidMethod (android_java_env, object,
+ window_class.class,
+ method);
+ android_exception_check ();
+}
+
+
+
+/* The thread from which a query against a thread is currently being
+ made, if any. Value is 0 if no query is in progress, 1 if a query
+ is being made from the UI thread to the main thread, and 2 if a
+ query is being made the other way around. */
+static char android_servicing_query;
+
+/* Function that is waiting to be run in the Emacs thread. */
+static void (*android_query_function) (void *);
+
+/* Context for that function. */
+static void *android_query_context;
+
+/* Deadlock protection. The UI thread and the Emacs thread must
+ sometimes make synchronous queries to each other, which are
+ normally answered inside each thread's respective event loop.
+ Deadlocks can happen when both threads simultaneously make such
+ synchronous queries and block waiting for each others responses.
+
+ The Emacs thread can be interrupted to service any queries made by
+ the UI thread, but is not possible the other way around.
+
+ To avoid such deadlocks, an atomic counter is provided. This
+ counter is set to two every time a query starts from the main
+ thread, and is set to zero every time one ends. If the UI thread
+ tries to make a query and sees that the counter is two, it simply
+ returns so that its event loop can proceed to perform and respond
+ to the query. If the Emacs thread sees that the counter is one,
+ then it stops to service all queries being made by the input
+ method, then proceeds to make its query with the counter set to
+ 2.
+
+ The memory synchronization is simple: all writes to
+ `android_query_context' and `android_query_function' are depended
+ on by writes to the atomic counter. Loads of the new value from
+ the counter are then guaranteed to make those writes visible. The
+ separate flag `android_urgent_query' does not depend on anything
+ itself; however, the input signal handler executes a memory fence
+ to ensure that all query related writes become visible. */
+
+/* Run any function that the UI thread has asked to run, and then
+ signal its completion. */
+
+void
+android_check_query (void)
+{
+ void (*proc) (void *);
+ void *closure;
+
+ if (!__atomic_load_n (&android_servicing_query, __ATOMIC_ACQUIRE))
+ return;
+
+ /* First, load the procedure and closure. */
+ closure = android_query_context;
+ proc = android_query_function;
+
+ if (!proc)
+ return;
+
+ proc (closure);
+
+ /* Finish the query. */
+ android_query_context = NULL;
+ android_query_function = NULL;
+ __atomic_store_n (&android_servicing_query, 0, __ATOMIC_RELEASE);
+ __atomic_clear (&android_urgent_query, __ATOMIC_RELEASE);
+
+ /* Signal completion. */
+ sem_post (&android_query_sem);
+}
+
+/* Run any function that the UI thread has asked to run, if the UI
+ thread has been waiting for more than two seconds.
+
+ Call this from `process_pending_signals' to ensure that the UI
+ thread always receives an answer within a reasonable amount of
+ time. */
+
+void
+android_check_query_urgent (void)
+{
+ void (*proc) (void *);
+ void *closure;
+
+ if (!__atomic_load_n (&android_urgent_query, __ATOMIC_ACQUIRE))
+ return;
+
+ __android_log_print (ANDROID_LOG_VERBOSE, __func__,
+ "Responding to urgent query...");
+
+ if (!__atomic_load_n (&android_servicing_query, __ATOMIC_ACQUIRE))
+ return;
+
+ /* First, load the procedure and closure. */
+ closure = android_query_context;
+ proc = android_query_function;
+
+ if (!proc)
+ return;
+
+ proc (closure);
+
+ /* Finish the query. Don't clear `android_urgent_query'; instead,
+ do that the next time Emacs enters the keyboard loop. */
+
+ android_query_context = NULL;
+ android_query_function = NULL;
+ __atomic_store_n (&android_servicing_query, 0, __ATOMIC_RELEASE);
+
+ /* Signal completion. */
+ sem_post (&android_query_sem);
+}
+
+/* Run the function that the UI thread has asked to run, and then
+ signal its completion. Do not change `android_servicing_query'
+ after it completes. */
+
+static void
+android_answer_query (void)
+{
+ void (*proc) (void *);
+ void *closure;
+
+ eassert (__atomic_load_n (&android_servicing_query,
+ __ATOMIC_ACQUIRE)
+ == 1);
+
+ /* First, load the procedure and closure. */
+ closure = android_query_context;
+ proc = android_query_function;
+
+ if (!proc)
+ return;
+
+ proc (closure);
+
+ /* Finish the query. */
+ android_query_context = NULL;
+ android_query_function = NULL;
+ __atomic_clear (&android_urgent_query, __ATOMIC_RELEASE);
+
+ /* Signal completion. */
+ sem_post (&android_query_sem);
+}
+
+/* Like `android_answer_query'. However, the query may not have
+ begun; spin until it has. */
+
+static void
+android_answer_query_spin (void)
+{
+ int n;
+
+ while (!(n = __atomic_load_n (&android_servicing_query,
+ __ATOMIC_ACQUIRE)))
+ eassert (!n);
+
+ /* Note that this function is supposed to be called before
+ `android_begin_query' starts, so clear the service flag. */
+ android_check_query ();
+}
+
+/* Notice that the Emacs thread will start blocking waiting for a
+ response from the UI thread. Process any pending queries from the
+ UI thread.
+
+ This function may be called from Java. */
+
+static void
+android_begin_query (void)
+{
+ char old;
+
+ /* Load the previous value of `android_servicing_query' and then set
+ it to 2. */
+
+ old = __atomic_exchange_n (&android_servicing_query,
+ 2, __ATOMIC_ACQ_REL);
+
+ /* See if a query was previously in progress. */
+ if (old == 1)
+ {
+ /* Answer the query that is currently being made. */
+ eassert (android_query_function != NULL);
+ android_answer_query ();
+ }
+
+ /* `android_servicing_query' is now 2. */
+}
+
+/* Notice that a query has stopped. This function may be called from
+ Java. */
+
+static void
+android_end_query (void)
+{
+ __atomic_store_n (&android_servicing_query, 0, __ATOMIC_RELEASE);
+ __atomic_clear (&android_urgent_query, __ATOMIC_RELEASE);
+}
+
+/* Synchronously ask the Emacs thread to run the specified PROC with
+ the given CLOSURE. Return if this fails, or once PROC is run.
+
+ PROC may be run from inside maybe_quit.
+
+ It is not okay to run Lisp code which signals or performs non
+ trivial tasks inside PROC.
+
+ Return 1 if the Emacs thread is currently waiting for the UI thread
+ to respond and PROC could not be run, or 0 otherwise. */
+
+int
+android_run_in_emacs_thread (void (*proc) (void *), void *closure)
+{
+ union android_event event;
+ char old;
+ int rc;
+ struct timespec timeout;
+
+ event.xaction.type = ANDROID_WINDOW_ACTION;
+ event.xaction.serial = ++event_serial;
+ event.xaction.window = 0;
+ event.xaction.action = 0;
+
+ /* Set android_query_function and android_query_context. */
+ android_query_context = closure;
+ android_query_function = proc;
+
+ /* Don't allow deadlocks to happen; make sure the Emacs thread is
+ not waiting for something to be done (in that case,
+ `android_query_context' is 2.) */
+
+ old = 0;
+ if (!__atomic_compare_exchange_n (&android_servicing_query, &old,
+ 1, false, __ATOMIC_ACQ_REL,
+ __ATOMIC_ACQUIRE))
+ {
+ android_query_context = NULL;
+ android_query_function = NULL;
+
+ /* The two variables above may still be non-NULL from the POV of
+ the main thread, as no happens-before constraint is placed on
+ those stores wrt a future load from `android_servicing_query'. */
+
+ return 1;
+ }
+
+ /* Send a dummy event. `android_check_query' will be called inside
+ wait_reading_process_output after the event arrives.
+
+ Otherwise, android_select will call android_check_thread the next
+ time it is entered. */
+ android_write_event (&event);
+
+ /* Start waiting for the function to be executed. First, wait two
+ seconds for the query to execute normally. */
+
+ timeout.tv_sec = 2;
+ timeout.tv_nsec = 0;
+ timeout = timespec_add (current_timespec (), timeout);
+
+ /* See if an urgent query was recently answered without entering the
+ keyboard loop in between. When that happens, raise SIGIO to
+ continue processing queries as soon as possible. */
+
+ if (__atomic_load_n (&android_urgent_query, __ATOMIC_ACQUIRE))
+ kill (getpid (), SIGIO);
+
+ again:
+ rc = sem_timedwait (&android_query_sem, &timeout);
+
+ if (rc < 0)
+ {
+ if (errno == EINTR)
+ goto again;
+
+ eassert (errno == ETIMEDOUT);
+
+ __android_log_print (ANDROID_LOG_VERBOSE, __func__,
+ "Timed out waiting for response"
+ " from main thread...");
+
+ /* The query timed out. At this point, set
+ `android_urgent_query' to true. */
+ __atomic_store_n (&android_urgent_query, true,
+ __ATOMIC_RELEASE);
+
+ kill_again:
+
+ /* And raise SIGIO. Now that the query is considered urgent,
+ the main thread will reply while reading async input.
+
+ Normally, the main thread waits for the keyboard loop to be
+ entered before responding, in order to avoid responding with
+ inaccurate results taken during command executioon. */
+ kill (getpid (), SIGIO);
+
+ /* Wait for the query to complete. `android_urgent_query' is
+ only cleared by either `android_select' or
+ `android_check_query', so there's no need to worry about the
+ flag being cleared before the query is processed.
+
+ Send SIGIO again periodically until the query is answered, on
+ the off chance that SIGIO arrived too late to preempt a
+ system call, but too early for it to return EINTR. */
+
+ timeout.tv_sec = 4;
+ timeout.tv_nsec = 0;
+ timeout = timespec_add (current_timespec (), timeout);
+
+ while (sem_timedwait (&android_query_sem, &timeout) < 0)
+ {
+ /* If waiting timed out, send SIGIO to the main thread
+ again. */
+
+ if (errno == ETIMEDOUT)
+ goto kill_again;
+
+ /* Otherwise, continue waiting. */
+ eassert (errno == EINTR);
+ }
+ }
+
+ /* At this point, `android_servicing_query' should either be zero if
+ the query was answered or two if the main thread has started a
+ query. */
+
+ eassert (!__atomic_load_n (&android_servicing_query,
+ __ATOMIC_ACQUIRE)
+ || (__atomic_load_n (&android_servicing_query,
+ __ATOMIC_ACQUIRE) == 2));
+
+ return 0;
+}
+
+
+
+/* Input method related functions. */
+
+/* Change WINDOW's active selection to the characters between
+ SELECTION_START and SELECTION_END.
+
+ Also, update the composing region to COMPOSING_REGION_START and
+ COMPOSING_REGION_END.
+
+ If any value cannot fit in jint, then the behavior of the input
+ method is undefined. */
+
+void
+android_update_ic (android_window window, ptrdiff_t selection_start,
+ ptrdiff_t selection_end, ptrdiff_t composing_region_start,
+ ptrdiff_t composing_region_end)
+{
+ jobject object;
+
+ object = android_resolve_handle (window, ANDROID_HANDLE_WINDOW);
+
+ (*android_java_env)->CallNonvirtualVoidMethod (android_java_env,
+ emacs_service,
+ service_class.class,
+ service_class.update_ic,
+ object,
+ (jint) selection_start,
+ (jint) selection_end,
+ (jint) composing_region_start,
+ (jint) composing_region_end);
+ android_exception_check ();
+}
+
+/* Reinitialize any ongoing input method connection on WINDOW.
+
+ Any input method that is connected to WINDOW will invalidate its
+ cache of the buffer contents.
+
+ MODE controls certain aspects of the input method's behavior:
+
+ - If MODE is ANDROID_IC_MODE_NULL, the input method will be
+ deactivated, and an ASCII only keyboard will be displayed
+ instead.
+
+ - If MODE is ANDROID_IC_MODE_ACTION, the input method will
+ edit text normally, but send ``return'' as a key event.
+ This is useful inside the mini buffer.
+
+ - If MODE is ANDROID_IC_MODE_TEXT, the input method is free
+ to behave however it wants. */
+
+void
+android_reset_ic (android_window window, enum android_ic_mode mode)
+{
+ jobject object;
+
+ object = android_resolve_handle (window, ANDROID_HANDLE_WINDOW);
+
+ (*android_java_env)->CallNonvirtualVoidMethod (android_java_env,
+ emacs_service,
+ service_class.class,
+ service_class.reset_ic,
+ object, (jint) mode);
+ android_exception_check ();
+}
+
+/* Make updates to extracted text known to the input method on
+ WINDOW. TEXT should be a local reference to the new
+ extracted text. TOKEN should be the token specified by the
+ input method. */
+
+void
+android_update_extracted_text (android_window window, void *text,
+ int token)
+{
+ jobject object;
+ jmethodID method;
+
+ object = android_resolve_handle (window, ANDROID_HANDLE_WINDOW);
+ method = service_class.update_extracted_text;
+
+ (*android_java_env)->CallNonvirtualVoidMethod (android_java_env,
+ emacs_service,
+ service_class.class,
+ method, object,
+ /* N.B. that text is
+ not jobject,
+ because that type
+ is not available
+ in
+ androidgui.h. */
+ (jobject) text,
+ (jint) token);
+ android_exception_check_1 (text);
+}
+
+/* Report the position of the cursor to the input method connection on
+ WINDOW.
+
+ X is the horizontal position of the end of the insertion marker. Y
+ is the top of the insertion marker. Y_BASELINE is the baseline of
+ the row containing the insertion marker, and Y_BOTTOM is the bottom
+ of the insertion marker. */
+
+void
+android_update_cursor_anchor_info (android_window window, float x,
+ float y, float y_baseline,
+ float y_bottom)
+{
+ jobject object;
+ jmethodID method;
+
+ object = android_resolve_handle (window, ANDROID_HANDLE_WINDOW);
+ method = service_class.update_cursor_anchor_info;
+
+ (*android_java_env)->CallNonvirtualVoidMethod (android_java_env,
+ emacs_service,
+ service_class.class,
+ method,
+ object,
+ (jfloat) x,
+ (jfloat) y,
+ (jfloat) y_baseline,
+ (jfloat) y_bottom);
+ android_exception_check ();
+}
+
+
+
+/* Window decoration management functions. */
+
+/* Make the specified WINDOW fullscreen, i.e. obscure all of the
+ system navigation and status bars. If not FULLSCREEN, make it
+ maximized instead.
+
+ Value is 1 if the system does not support this, else 0. */
+
+int
+android_set_fullscreen (android_window window, bool fullscreen)
+{
+ jobject object;
+
+ /* Android 4.0 and earlier don't support fullscreen windows. */
+
+ if (android_api_level < 16)
+ return 1;
+
+ object = android_resolve_handle (window, ANDROID_HANDLE_WINDOW);
+
+ (*android_java_env)->CallNonvirtualVoidMethod (android_java_env,
+ object,
+ window_class.class,
+ window_class.set_fullscreen,
+ (jboolean) fullscreen);
+ android_exception_check ();
+ return 0;
+}
+
+
+
+/* Window cursor support. */
+
+android_cursor
+android_create_font_cursor (enum android_cursor_shape shape)
+{
+ android_cursor id;
+ short prev_max_handle;
+ jobject object;
+
+ /* First, allocate the cursor handle. */
+ prev_max_handle = max_handle;
+ id = android_alloc_id ();
+
+ if (!id)
+ error ("Out of cursor handles!");
+
+ /* Next, create the cursor. */
+ object = (*android_java_env)->NewObject (android_java_env,
+ cursor_class.class,
+ cursor_class.constructor,
+ (jshort) id,
+ (jint) shape);
+ if (!object)
+ {
+ (*android_java_env)->ExceptionClear (android_java_env);
+ max_handle = prev_max_handle;
+ memory_full (0);
+ }
+
+ android_handles[id].type = ANDROID_HANDLE_CURSOR;
+ android_handles[id].handle
+ = (*android_java_env)->NewGlobalRef (android_java_env, object);
+ (*android_java_env)->ExceptionClear (android_java_env);
+ ANDROID_DELETE_LOCAL_REF (object);
+
+ if (!android_handles[id].handle)
+ memory_full (0);
+
+ return id;
+}
+
+void
+android_define_cursor (android_window window, android_cursor cursor)
+{
+ jobject window1, cursor1;
+ jmethodID method;
+
+ window1 = android_resolve_handle (window, ANDROID_HANDLE_WINDOW);
+ cursor1 = android_resolve_handle (cursor, ANDROID_HANDLE_CURSOR);
+ method = window_class.define_cursor;
+
+ (*android_java_env)->CallNonvirtualVoidMethod (android_java_env,
+ window1,
+ window_class.class,
+ method, cursor1);
+ android_exception_check ();
+}
+
+void
+android_free_cursor (android_cursor cursor)
+{
+ if (android_handles[cursor].type != ANDROID_HANDLE_CURSOR)
+ {
+ __android_log_print (ANDROID_LOG_ERROR, __func__,
+ "Trying to destroy something not a CURSOR!");
+ emacs_abort ();
+ }
+
+ android_destroy_handle (cursor);
+}
+
+
+
+/* Process execution.
+
+ Newer Android systems use SELinux to restrict user programs from
+ executing programs installed in the application data directory for
+ security reasons. Emacs uses a `loader' binary installed in the
+ application data directory to manually load executables and replace
+ the `execve' system call. */
+
+enum
+ {
+ /* Maximum number of arguments available. */
+ MAXARGS = 1024,
+ };
+
+/* Rewrite the command line given in *ARGV to utilize the `exec1'
+ bootstrap binary if necessary.
+
+ Value is 0 upon success, else 1. Set errno upon failure.
+
+ ARGV holds a pointer to a NULL-terminated array of arguments given
+ to `emacs_spawn'. */
+
+int
+android_rewrite_spawn_argv (const char ***argv)
+{
+ static const char *new_args[MAXARGS];
+ static char exec1_name[PATH_MAX], loader_name[PATH_MAX];
+ size_t i, nargs;
+
+ /* This isn't required on Android 9 or earlier. */
+
+ if (android_api_level < 29 || !android_use_exec_loader)
+ return 0;
+
+ /* Get argv[0]; this should never be NULL.
+ Then, verify that it exists and is executable. */
+
+ eassert (**argv);
+ if (access (**argv, R_OK | X_OK))
+ return 1;
+
+ /* Count the number of arguments in *argv. */
+
+ nargs = 0;
+ while ((*argv)[nargs])
+ ++nargs;
+
+ /* nargs now holds the number of arguments in argv. If it's larger
+ than MAXARGS, return failure. */
+
+ if (nargs + 2 > MAXARGS)
+ {
+ errno = E2BIG;
+ return 1;
+ }
+
+ /* Fill in the name of `libexec1.so'. */
+ snprintf (exec1_name, PATH_MAX, "%s/libexec1.so",
+ android_lib_dir);
+
+ /* And libloader.so. */
+ snprintf (loader_name, PATH_MAX, "%s/libloader.so",
+ android_lib_dir);
+
+ /* Now fill in the first two arguments. */
+ new_args[0] = exec1_name;
+ new_args[1] = loader_name;
+
+ /* And insert the rest, including the trailing NULL. */
+ for (i = 0; i < nargs + 1; ++i)
+ new_args[i + 2] = (*argv)[i];
+
+ /* Replace argv. */
+ *argv = new_args;
+
+ /* Return success. */
+ return 0;
+}
+
+
+
+#else /* ANDROID_STUBIFY */
+
+/* X emulation functions for Android. */
+
+struct android_gc *
+android_create_gc (enum android_gc_value_mask mask,
+ struct android_gc_values *values)
+{
+ /* This function should never be called when building stubs. */
+ emacs_abort ();
+}
+
+void
+android_free_gc (struct android_gc *gc)
+{
+ /* This function should never be called when building stubs. */
+ emacs_abort ();
+}
+
+struct android_image *
+android_create_image (unsigned int depth, enum android_image_format format,
+ char *data, unsigned int width, unsigned int height)
+{
+ emacs_abort ();
+}
+
+void
+android_destroy_image (struct android_image *ximg)
+{
+ emacs_abort ();
+}
+
+void
+android_put_pixel (struct android_image *ximg, int x, int y,
+ unsigned long pixel)
+{
+ emacs_abort ();
+}
+
+unsigned long
+android_get_pixel (struct android_image *ximg, int x, int y)
+{
+ emacs_abort ();
+}
+
+struct android_image *
+android_get_image (android_drawable drawable,
+ enum android_image_format format)
+{
+ emacs_abort ();
+}
+
+void
+android_put_image (android_pixmap pixmap,
+ struct android_image *image)
+{
+ emacs_abort ();
+}
+
+void
+android_project_image_bilinear (struct android_image *image,
+ struct android_image *out,
+ struct android_transform *transform)
+{
+ emacs_abort ();
+}
+
+void
+android_project_image_nearest (struct android_image *image,
+ struct android_image *out,
+ struct android_transform *transform)
+{
+ emacs_abort ();
+}
+
+#endif /* !ANDROID_STUBIFY */
diff --git a/src/android.h b/src/android.h
new file mode 100644
index 00000000000..2ca3d7e1446
--- /dev/null
+++ b/src/android.h
@@ -0,0 +1,350 @@
+/* Android initialization for GNU Emacs.
+
+Copyright (C) 2023-2024 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 <https://www.gnu.org/licenses/>. */
+
+/* On Android, Emacs is built as a shared library loaded from Java
+ using the Java Native Interface. Emacs's `main' function is
+ renamed `android_emacs_init', and runs with some modifications
+ inside a separate thread, communicating with the Java code through
+ a table of function pointers. */
+
+#ifndef _ANDROID_H_
+#define _ANDROID_H_
+
+#ifndef ANDROID_STUBIFY
+#include <jni.h>
+#include <pwd.h>
+
+#include <sys/stat.h>
+#include <dirent.h>
+#include <stdio.h>
+
+#include <android/bitmap.h>
+
+#include "androidgui.h"
+#include "lisp.h"
+#endif /* ANDROID_STUBIFY */
+
+extern bool android_init_gui;
+
+#ifndef ANDROID_STUBIFY
+
+extern char *android_cache_dir;
+
+extern int android_emacs_init (int, char **, char *);
+extern int android_select (int, fd_set *, fd_set *, fd_set *,
+ struct timespec *);
+extern char *android_user_full_name (struct passwd *);
+
+
+
+/* File I/O operations. Many of these are defined in
+ androidvfs.c. */
+
+extern bool android_is_special_directory (const char *, const char *);
+extern const char *android_get_home_directory (void);
+
+extern void android_vfs_init (JNIEnv *, jobject);
+
+extern int android_open (const char *, int, mode_t);
+extern int android_fstat (int, struct stat *);
+extern int android_fstatat (int, const char *restrict,
+ struct stat *restrict, int);
+extern int android_faccessat (int, const char *, int, int);
+extern int android_close (int);
+extern FILE *android_fdopen (int, const char *);
+extern int android_fclose (FILE *);
+extern int android_unlink (const char *);
+extern int android_symlink (const char *, const char *);
+extern int android_rmdir (const char *);
+extern int android_mkdir (const char *, mode_t);
+extern int android_renameat_noreplace (int, const char *,
+ int, const char *);
+extern int android_rename (const char *, const char *);
+extern int android_fchmodat (int, const char *, mode_t, int);
+extern ssize_t android_readlinkat (int, const char *restrict, char *restrict,
+ size_t);
+
+
+
+extern double android_pixel_density_x, android_pixel_density_y;
+extern double android_scaled_pixel_density;
+
+enum android_handle_type
+ {
+ ANDROID_HANDLE_WINDOW,
+ ANDROID_HANDLE_GCONTEXT,
+ ANDROID_HANDLE_PIXMAP,
+ ANDROID_HANDLE_CURSOR,
+ };
+
+extern jobject android_resolve_handle (android_handle,
+ enum android_handle_type);
+extern unsigned char *android_lock_bitmap (android_drawable,
+ AndroidBitmapInfo *,
+ jobject *);
+extern void android_damage_window (android_window,
+ struct android_rectangle *);
+extern int android_get_screen_width (void);
+extern int android_get_screen_height (void);
+extern int android_get_mm_width (void);
+extern int android_get_mm_height (void);
+extern bool android_detect_mouse (void);
+extern bool android_detect_keyboard (void);
+
+extern void android_set_dont_focus_on_map (android_window, bool);
+extern void android_set_dont_accept_focus (android_window, bool);
+
+extern int android_verify_jni_string (const char *);
+extern jstring android_build_string (Lisp_Object, ...);
+extern jstring android_build_jstring (const char *);
+extern void android_exception_check (void);
+extern void android_exception_check_1 (jobject);
+extern void android_exception_check_2 (jobject, jobject);
+extern void android_exception_check_3 (jobject, jobject, jobject);
+extern void android_exception_check_4 (jobject, jobject, jobject, jobject);
+extern void android_exception_check_5 (jobject, jobject, jobject, jobject,
+ jobject);
+extern void android_exception_check_6 (jobject, jobject, jobject, jobject,
+ jobject, jobject);
+extern void android_exception_check_nonnull (void *, jobject);
+extern void android_exception_check_nonnull_1 (void *, jobject, jobject);
+
+extern void android_get_keysym_name (int, char *, size_t);
+extern void android_wait_event (void);
+extern void android_toggle_on_screen_keyboard (android_window, bool);
+extern _Noreturn void android_restart_emacs (void);
+extern int android_request_directory_access (void);
+extern bool android_external_storage_available_p (void);
+extern void android_request_storage_access (void);
+extern int android_get_current_api_level (void)
+ __attribute__ ((pure));
+
+/* Define `android_get_current_api_level' to a macro that the compiler
+ knows will always return at least __ANDROID_API__. */
+
+#define android_get_current_api_level() \
+ ({ int value; \
+ \
+ value = (android_get_current_api_level) (); \
+ eassume (value >= __ANDROID_API__); value; })
+
+
+
+/* Directory listing emulation. */
+
+struct android_vdir;
+
+extern struct android_vdir *android_opendir (const char *);
+extern int android_dirfd (struct android_vdir *);
+extern struct dirent *android_readdir (struct android_vdir *);
+extern void android_closedir (struct android_vdir *);
+
+
+
+/* External asset manager interface. */
+
+struct android_fd_or_asset
+{
+ /* The file descriptor. */
+ int fd;
+
+ /* The asset. If set, FD is not a real file descriptor. */
+ void *asset;
+};
+
+extern struct android_fd_or_asset android_open_asset (const char *,
+ int, mode_t);
+extern int android_close_asset (struct android_fd_or_asset);
+extern ssize_t android_asset_read_quit (struct android_fd_or_asset,
+ void *, size_t);
+extern ssize_t android_asset_read (struct android_fd_or_asset,
+ void *, size_t);
+extern off_t android_asset_lseek (struct android_fd_or_asset, off_t, int);
+extern int android_asset_fstat (struct android_fd_or_asset,
+ struct stat *);
+
+
+
+/* Very miscellaneous functions. */
+
+struct android_battery_state
+{
+ /* Battery charge level in integer percentage. */
+ intmax_t capacity;
+
+ /* Battery charge level in microampere-hours. */
+ intmax_t charge_counter;
+
+ /* Battery current in microampere-hours. */
+ intmax_t current_average;
+
+ /* Instantaneous battery current in microampere-hours. */
+ intmax_t current_now;
+
+ /* Estimate as to the amount of time remaining until the battery is
+ charged, in milliseconds. */
+ intmax_t remaining;
+
+ /* Battery status. The value is either:
+
+ 2, if the battery is charging.
+ 3, if the battery is discharging.
+ 5, if the battery is full.
+ 4, if the battery is not full or discharging,
+ but is not charging either.
+ 1, if the battery state is unknown. */
+ int status;
+
+ /* The power source of the battery. Value is:
+
+ 0, if on battery power.
+ 1, for line power.
+ 8, for dock power.
+ 2, for USB power.
+ 4, for wireless power. */
+ int plugged;
+
+ /* The temperature of the battery in 10 * degrees centigrade. */
+ int temperature;
+};
+
+extern Lisp_Object android_browse_url (Lisp_Object, Lisp_Object);
+extern int android_query_battery (struct android_battery_state *);
+extern void android_display_toast (const char *);
+
+
+
+/* Event loop functions. */
+
+extern void android_check_query (void);
+extern void android_check_query_urgent (void);
+extern int android_run_in_emacs_thread (void (*) (void *), void *);
+extern void android_write_event (union android_event *);
+
+extern unsigned int event_serial;
+
+
+
+/* Process related functions. */
+extern int android_rewrite_spawn_argv (const char ***);
+
+#else /* ANDROID_STUBIFY */
+
+/* Define a substitute for use during Emacs compilation. */
+
+#define android_is_special_directory(name, dir) (false)
+
+#endif /* !ANDROID_STUBIFY */
+
+/* JNI functions should not be built when Emacs is stubbed out for the
+ build. These should be documented in EmacsNative.java. */
+
+#ifndef ANDROID_STUBIFY
+#include <jni.h>
+
+struct android_emacs_service
+{
+ jclass class;
+ jmethodID fill_rectangle;
+ jmethodID fill_polygon;
+ jmethodID draw_rectangle;
+ jmethodID draw_line;
+ jmethodID draw_point;
+ jmethodID clear_window;
+ jmethodID clear_area;
+ jmethodID ring_bell;
+ jmethodID query_tree;
+ jmethodID get_screen_width;
+ jmethodID get_screen_height;
+ jmethodID detect_mouse;
+ jmethodID detect_keyboard;
+ jmethodID name_keysym;
+ jmethodID browse_url;
+ jmethodID restart_emacs;
+ jmethodID update_ic;
+ jmethodID reset_ic;
+ jmethodID open_content_uri;
+ jmethodID check_content_uri;
+ jmethodID query_battery;
+ jmethodID update_extracted_text;
+ jmethodID update_cursor_anchor_info;
+ jmethodID get_document_authorities;
+ jmethodID request_directory_access;
+ jmethodID get_document_trees;
+ jmethodID document_id_from_name;
+ jmethodID get_tree_uri;
+ jmethodID stat_document;
+ jmethodID access_document;
+ jmethodID open_document_directory;
+ jmethodID read_directory_entry;
+ jmethodID open_document;
+ jmethodID create_document;
+ jmethodID create_directory;
+ jmethodID delete_document;
+ jmethodID rename_document;
+ jmethodID move_document;
+ jmethodID valid_authority;
+ jmethodID external_storage_available;
+ jmethodID request_storage_access;
+ jmethodID cancel_notification;
+};
+
+extern JNIEnv *android_java_env;
+
+#ifdef THREADS_ENABLED
+extern JavaVM *android_jvm;
+#endif /* THREADS_ENABLED */
+
+/* The Java String class. */
+extern jclass java_string_class;
+
+/* The EmacsService object. */
+extern jobject emacs_service;
+
+/* Various methods associated with the EmacsService. */
+extern struct android_emacs_service service_class;
+
+/* The time at which Emacs was installed, which also supplies the
+ mtime of asset files. */
+extern struct timespec emacs_installation_time;
+
+#define ANDROID_DELETE_LOCAL_REF(ref) \
+ ((*android_java_env)->DeleteLocalRef (android_java_env, \
+ ref))
+
+#define NATIVE_NAME(name) Java_org_gnu_emacs_EmacsNative_##name
+
+/* Prologue which must be inserted before each JNI function.
+ See initEmacs for why. */
+
+#if defined __i386__
+extern void *unused_pointer;
+
+#define JNI_STACK_ALIGNMENT_PROLOGUE \
+ __attribute__ ((aligned (32))) char stack_align_buffer[32]; \
+ \
+ /* Trick GCC into not optimizing this variable away. */ \
+ unused_pointer = stack_align_buffer;
+
+#else /* !__i386__ */
+#define JNI_STACK_ALIGNMENT_PROLOGUE ((void) 0)
+#endif /* __i386__ */
+
+#endif /* !ANDROID_STUBIFY */
+#endif /* _ANDROID_H_ */
diff --git a/src/androidfns.c b/src/androidfns.c
new file mode 100644
index 00000000000..83cf81c1f07
--- /dev/null
+++ b/src/androidfns.c
@@ -0,0 +1,3694 @@
+/* Communication module for Android terminals.
+
+Copyright (C) 2023-2024 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 <https://www.gnu.org/licenses/>. */
+
+#include <config.h>
+#include <math.h>
+
+#include "lisp.h"
+#include "android.h"
+#include "androidterm.h"
+#include "blockinput.h"
+#include "keyboard.h"
+#include "buffer.h"
+#include "androidgui.h"
+#include "pdumper.h"
+
+#ifndef ANDROID_STUBIFY
+
+/* Some kind of reference count for the image cache. */
+static ptrdiff_t image_cache_refcount;
+
+/* The frame of the currently visible tooltip, or nil if none. */
+static Lisp_Object tip_frame;
+
+/* The window-system window corresponding to the frame of the
+ currently visible tooltip. */
+static android_window tip_window;
+
+/* The X and Y deltas of the last call to `x-show-tip'. */
+static Lisp_Object tip_dx, tip_dy;
+
+/* A timer that hides or deletes the currently visible tooltip when it
+ fires. */
+static Lisp_Object tip_timer;
+
+/* STRING argument of last `x-show-tip' call. */
+static Lisp_Object tip_last_string;
+
+/* Normalized FRAME argument of last `x-show-tip' call. */
+static Lisp_Object tip_last_frame;
+
+/* PARMS argument of last `x-show-tip' call. */
+static Lisp_Object tip_last_parms;
+
+#endif
+
+static struct android_display_info *
+android_display_info_for_name (Lisp_Object name)
+{
+ struct android_display_info *dpyinfo;
+
+ CHECK_STRING (name);
+
+ for (dpyinfo = x_display_list; dpyinfo; dpyinfo = dpyinfo->next)
+ {
+ if (!NILP (Fstring_equal (XCAR (dpyinfo->name_list_element),
+ name)))
+ return dpyinfo;
+ }
+
+ error ("Cannot connect to Android if it was not initialized"
+ " at startup");
+}
+
+static struct android_display_info *
+check_android_display_info (Lisp_Object object)
+{
+ struct android_display_info *dpyinfo;
+ struct frame *sf, *f;
+ struct terminal *t;
+
+ if (NILP (object))
+ {
+ sf = XFRAME (selected_frame);
+
+ if (FRAME_ANDROID_P (sf) && FRAME_LIVE_P (sf))
+ dpyinfo = FRAME_DISPLAY_INFO (sf);
+ else if (x_display_list)
+ dpyinfo = x_display_list;
+ else
+ error ("Android windows are not in use or not initialized");
+ }
+ else if (TERMINALP (object))
+ {
+ t = decode_live_terminal (object);
+
+ if (t->type != output_android)
+ error ("Terminal %d is not an Android display", t->id);
+
+ dpyinfo = t->display_info.android;
+ }
+ else if (STRINGP (object))
+ dpyinfo = android_display_info_for_name (object);
+ else
+ {
+ f = decode_window_system_frame (object);
+ dpyinfo = FRAME_DISPLAY_INFO (f);
+ }
+
+ return dpyinfo;
+}
+
+Display_Info *
+check_x_display_info (Lisp_Object object)
+{
+ return check_android_display_info (object);
+}
+
+
+
+#ifndef ANDROID_STUBIFY
+
+void
+gamma_correct (struct frame *f, Emacs_Color *color)
+{
+ if (f->gamma)
+ {
+ color->red = pow (color->red / 65535.0, f->gamma) * 65535.0 + 0.5;
+ color->green = pow (color->green / 65535.0, f->gamma) * 65535.0 + 0.5;
+ color->blue = pow (color->blue / 65535.0, f->gamma) * 65535.0 + 0.5;
+ }
+}
+
+/* Decide if color named COLOR_NAME is valid for use on frame F. If
+ so, return the RGB values in COLOR. If ALLOC_P, allocate the
+ color. Value is false if COLOR_NAME is invalid, or no color could
+ be allocated. MAKE_INDEX is some mysterious argument used on
+ NS. */
+
+bool
+android_defined_color (struct frame *f, const char *color_name,
+ Emacs_Color *color, bool alloc_p,
+ bool make_index)
+{
+ bool success_p;
+
+ success_p = false;
+
+ block_input ();
+ success_p = android_parse_color (f, color_name, color);
+ if (success_p && alloc_p)
+ success_p = android_alloc_nearest_color (f, color);
+ unblock_input ();
+
+ return success_p;
+}
+
+/* Return the pixel color value for color COLOR_NAME on frame F. If F
+ is a monochrome frame, return MONO_COLOR regardless of what ARG
+ says. Signal an error if color can't be allocated. */
+
+static unsigned long
+android_decode_color (struct frame *f, Lisp_Object color_name, int mono_color)
+{
+ Emacs_Color cdef;
+
+ CHECK_STRING (color_name);
+
+ if (android_defined_color (f, SSDATA (color_name), &cdef,
+ true, false))
+ return cdef.pixel;
+
+ signal_error ("Undefined color", color_name);
+}
+
+static void
+android_set_parent_frame (struct frame *f, Lisp_Object new_value,
+ Lisp_Object old_value)
+{
+ struct frame *p;
+
+ p = NULL;
+
+ if (!NILP (new_value)
+ && (!FRAMEP (new_value)
+ || !FRAME_LIVE_P (p = XFRAME (new_value))
+ || !FRAME_ANDROID_P (p)))
+ {
+ store_frame_param (f, Qparent_frame, old_value);
+ error ("Invalid specification of `parent-frame'");
+ }
+
+ if (p != FRAME_PARENT_FRAME (f))
+ {
+ block_input ();
+ android_reparent_window (FRAME_ANDROID_WINDOW (f),
+ (p ? FRAME_ANDROID_WINDOW (p)
+ : FRAME_DISPLAY_INFO (f)->root_window),
+ f->left_pos, f->top_pos);
+ unblock_input ();
+
+ fset_parent_frame (f, new_value);
+ }
+
+ /* Update the fullscreen frame parameter as well. */
+ FRAME_TERMINAL (f)->fullscreen_hook (f);
+}
+
+void
+android_implicitly_set_name (struct frame *f, Lisp_Object arg,
+ Lisp_Object oldval)
+{
+
+}
+
+void
+android_explicitly_set_name (struct frame *f, Lisp_Object arg,
+ Lisp_Object oldval)
+{
+
+}
+
+/* Set the number of lines used for the tool bar of frame F to VALUE.
+ VALUE not an integer, or < 0 means set the lines to zero. OLDVAL
+ is the old number of tool bar lines. This function changes the
+ height of all windows on frame F to match the new tool bar height.
+ The frame's height doesn't change. */
+
+static void
+android_set_tool_bar_lines (struct frame *f, Lisp_Object value,
+ Lisp_Object oldval)
+{
+ int nlines;
+
+ /* Treat tool bars like menu bars. */
+ if (FRAME_MINIBUF_ONLY_P (f))
+ return;
+
+ /* Use VALUE only if an int >= 0. */
+ if (RANGED_FIXNUMP (0, value, INT_MAX))
+ nlines = XFIXNAT (value);
+ else
+ nlines = 0;
+
+ android_change_tool_bar_height (f, nlines * FRAME_LINE_HEIGHT (f));
+}
+
+static void
+android_set_tool_bar_position (struct frame *f,
+ Lisp_Object new_value,
+ Lisp_Object old_value)
+{
+ if (!EQ (new_value, Qtop) && !EQ (new_value, Qbottom))
+ error ("Tool bar position must be either `top' or `bottom'");
+
+ if (EQ (new_value, old_value))
+ return;
+
+ /* Set the tool bar position. */
+ fset_tool_bar_position (f, new_value);
+
+ /* Now reconfigure frame glyphs to place the tool bar at the
+ bottom. While the inner height has not changed, call
+ `resize_frame_windows' to place each of the windows at its
+ new position. */
+
+ adjust_frame_size (f, -1, -1, 3, false, Qtool_bar_position);
+ adjust_frame_glyphs (f);
+ SET_FRAME_GARBAGED (f);
+
+ if (FRAME_ANDROID_WINDOW (f))
+ android_clear_under_internal_border (f);
+}
+
+void
+android_change_tool_bar_height (struct frame *f, int height)
+{
+ int unit = FRAME_LINE_HEIGHT (f);
+ int old_height = FRAME_TOOL_BAR_HEIGHT (f);
+ int lines = (height + unit - 1) / unit;
+ Lisp_Object fullscreen = get_frame_param (f, Qfullscreen);
+
+ /* Make sure we redisplay all windows in this frame. */
+ fset_redisplay (f);
+
+ FRAME_TOOL_BAR_HEIGHT (f) = height;
+ FRAME_TOOL_BAR_LINES (f) = lines;
+ store_frame_param (f, Qtool_bar_lines, make_fixnum (lines));
+
+ if (FRAME_ANDROID_WINDOW (f) && FRAME_TOOL_BAR_HEIGHT (f) == 0)
+ {
+ clear_frame (f);
+ clear_current_matrices (f);
+ }
+
+ if ((height < old_height) && WINDOWP (f->tool_bar_window))
+ clear_glyph_matrix (XWINDOW (f->tool_bar_window)->current_matrix);
+
+ if (!f->tool_bar_resized)
+ {
+ /* As long as tool_bar_resized is false, effectively try to change
+ F's native height. */
+ if (NILP (fullscreen) || EQ (fullscreen, Qfullwidth))
+ adjust_frame_size (f, FRAME_TEXT_WIDTH (f), FRAME_TEXT_HEIGHT (f),
+ 1, false, Qtool_bar_lines);
+ else
+ adjust_frame_size (f, -1, -1, 4, false, Qtool_bar_lines);
+
+ f->tool_bar_resized = f->tool_bar_redisplayed;
+ }
+ else
+ /* Any other change may leave the native size of F alone. */
+ adjust_frame_size (f, -1, -1, 3, false, Qtool_bar_lines);
+
+ /* adjust_frame_size might not have done anything, garbage frame
+ here. */
+ adjust_frame_glyphs (f);
+ SET_FRAME_GARBAGED (f);
+}
+
+/* Set the number of lines used for the tab bar of frame F to VALUE.
+ VALUE not an integer, or < 0 means set the lines to zero. OLDVAL
+ is the old number of tab bar lines. This function may change the
+ height of all windows on frame F to match the new tab bar height.
+ The frame's height may change if frame_inhibit_implied_resize was
+ set accordingly. */
+
+static void
+android_set_tab_bar_lines (struct frame *f, Lisp_Object value,
+ Lisp_Object oldval)
+{
+ int olines;
+ int nlines;
+
+ olines = FRAME_TAB_BAR_LINES (f);
+
+ /* Treat tab bars like menu bars. */
+ if (FRAME_MINIBUF_ONLY_P (f))
+ return;
+
+ /* Use VALUE only if an int >= 0. */
+ if (RANGED_FIXNUMP (0, value, INT_MAX))
+ nlines = XFIXNAT (value);
+ else
+ nlines = 0;
+
+ if (nlines != olines && (olines == 0 || nlines == 0))
+ android_change_tab_bar_height (f, nlines * FRAME_LINE_HEIGHT (f));
+}
+
+void
+android_change_tab_bar_height (struct frame *f, int height)
+{
+ int unit, old_height, lines;
+ Lisp_Object fullscreen;
+
+ unit = FRAME_LINE_HEIGHT (f);
+ old_height = FRAME_TAB_BAR_HEIGHT (f);
+ fullscreen = get_frame_param (f, Qfullscreen);
+
+ /* This differs from the tool bar code in that the tab bar height is
+ not rounded up. Otherwise, if redisplay_tab_bar decides to grow
+ the tab bar by even 1 pixel, FRAME_TAB_BAR_LINES will be changed,
+ leading to the tab bar height being incorrectly set upon the next
+ call to android_set_font. (bug#59285) */
+
+ lines = height / unit;
+
+ /* Even so, HEIGHT might be less than unit if the tab bar face is
+ not so tall as the frame's font height; which if true lines will
+ be set to 0 and the tab bar will thus vanish. */
+
+ if (lines == 0 && height != 0)
+ lines = 1;
+
+ /* Make sure we redisplay all windows in this frame. */
+ fset_redisplay (f);
+
+ /* Recalculate tab bar and frame text sizes. */
+ FRAME_TAB_BAR_HEIGHT (f) = height;
+ FRAME_TAB_BAR_LINES (f) = lines;
+ store_frame_param (f, Qtab_bar_lines, make_fixnum (lines));
+
+ if (FRAME_ANDROID_WINDOW (f) && FRAME_TAB_BAR_HEIGHT (f) == 0)
+ {
+ clear_frame (f);
+ clear_current_matrices (f);
+ }
+
+ if ((height < old_height) && WINDOWP (f->tab_bar_window))
+ clear_glyph_matrix (XWINDOW (f->tab_bar_window)->current_matrix);
+
+ if (!f->tab_bar_resized)
+ {
+ /* As long as tab_bar_resized is false, effectively try to change
+ F's native height. */
+ if (NILP (fullscreen) || EQ (fullscreen, Qfullwidth))
+ adjust_frame_size (f, FRAME_TEXT_WIDTH (f), FRAME_TEXT_HEIGHT (f),
+ 1, false, Qtab_bar_lines);
+ else
+ adjust_frame_size (f, -1, -1, 4, false, Qtab_bar_lines);
+
+ f->tab_bar_resized = f->tab_bar_redisplayed;
+ }
+ else
+ /* Any other change may leave the native size of F alone. */
+ adjust_frame_size (f, -1, -1, 3, false, Qtab_bar_lines);
+
+ /* adjust_frame_size might not have done anything, garbage frame
+ here. */
+ adjust_frame_glyphs (f);
+ SET_FRAME_GARBAGED (f);
+}
+
+void
+android_set_scroll_bar_default_height (struct frame *f)
+{
+ int height;
+
+ height = FRAME_LINE_HEIGHT (f);
+
+ /* The height of a non-toolkit scrollbar is 14 pixels. */
+ FRAME_CONFIG_SCROLL_BAR_LINES (f) = (14 + height - 1) / height;
+
+ /* Use all of that space (aside from required margins) for the
+ scroll bar. */
+ FRAME_CONFIG_SCROLL_BAR_HEIGHT (f) = 14;
+}
+
+void
+android_set_scroll_bar_default_width (struct frame *f)
+{
+ int unit;
+
+ unit = FRAME_COLUMN_WIDTH (f);
+
+ FRAME_CONFIG_SCROLL_BAR_COLS (f) = (14 + unit - 1) / unit;
+ FRAME_CONFIG_SCROLL_BAR_WIDTH (f)
+ = FRAME_CONFIG_SCROLL_BAR_COLS (f) * unit;
+}
+
+
+/* Verify that the icon position args for this window are valid. */
+
+static void
+android_icon_verify (struct frame *f, Lisp_Object parms)
+{
+ Lisp_Object icon_x, icon_y;
+
+ /* Set the position of the icon. Note that twm groups all
+ icons in an icon window. */
+ icon_x = gui_frame_get_and_record_arg (f, parms, Qicon_left, 0, 0,
+ RES_TYPE_NUMBER);
+ icon_y = gui_frame_get_and_record_arg (f, parms, Qicon_top, 0, 0,
+ RES_TYPE_NUMBER);
+
+ if (!BASE_EQ (icon_x, Qunbound) && !BASE_EQ (icon_y, Qunbound))
+ {
+ CHECK_FIXNUM (icon_x);
+ CHECK_FIXNUM (icon_y);
+ }
+ else if (!BASE_EQ (icon_x, Qunbound) || !BASE_EQ (icon_y, Qunbound))
+ error ("Both left and top icon corners of icon must be specified");
+}
+
+/* Handle the icon stuff for this window. Perhaps later we might
+ want an x_set_icon_position which can be called interactively as
+ well. */
+
+static void
+android_icon (struct frame *f, Lisp_Object parms)
+{
+ /* Set the position of the icon. Note that twm groups all
+ icons in an icon window. */
+ Lisp_Object icon_x
+ = gui_frame_get_and_record_arg (f, parms, Qicon_left, 0, 0,
+ RES_TYPE_NUMBER);
+ Lisp_Object icon_y
+ = gui_frame_get_and_record_arg (f, parms, Qicon_top, 0, 0,
+ RES_TYPE_NUMBER);
+
+ bool xgiven = !BASE_EQ (icon_x, Qunbound);
+ bool ygiven = !BASE_EQ (icon_y, Qunbound);
+
+ if (xgiven != ygiven)
+ error ("Both left and top icon corners of icon must be specified");
+
+ if (xgiven)
+ {
+ check_integer_range (icon_x, INT_MIN, INT_MAX);
+ check_integer_range (icon_y, INT_MIN, INT_MAX);
+ }
+
+ /* Now return as this is not supported on Android. */
+}
+
+/* Make the GCs needed for this window, setting the background
+ color. */
+
+static void
+android_make_gc (struct frame *f)
+{
+ struct android_gc_values gc_values;
+
+ block_input ();
+
+ /* Create the GCs of this frame.
+ Note that many default values are used. */
+
+ gc_values.foreground = FRAME_FOREGROUND_PIXEL (f);
+ gc_values.background = FRAME_BACKGROUND_PIXEL (f);
+ f->output_data.android->normal_gc
+ = android_create_gc (ANDROID_GC_FOREGROUND | ANDROID_GC_BACKGROUND,
+ &gc_values);
+
+ /* Reverse video style. */
+ gc_values.foreground = FRAME_BACKGROUND_PIXEL (f);
+ gc_values.background = FRAME_FOREGROUND_PIXEL (f);
+ f->output_data.android->reverse_gc
+ = android_create_gc (ANDROID_GC_FOREGROUND | ANDROID_GC_BACKGROUND,
+ &gc_values);
+
+ /* Cursor has cursor-color background, background-color foreground. */
+ gc_values.foreground = FRAME_BACKGROUND_PIXEL (f);
+ gc_values.background = f->output_data.android->cursor_pixel;
+ f->output_data.android->cursor_gc
+ = android_create_gc (ANDROID_GC_FOREGROUND | ANDROID_GC_BACKGROUND,
+ &gc_values);
+ unblock_input ();
+}
+
+
+/* Free what was allocated in android_make_gc. */
+
+void
+android_free_gcs (struct frame *f)
+{
+ block_input ();
+
+ if (f->output_data.android->normal_gc)
+ {
+ android_free_gc (f->output_data.android->normal_gc);
+ f->output_data.android->normal_gc = 0;
+ }
+
+ if (f->output_data.android->reverse_gc)
+ {
+ android_free_gc (f->output_data.android->reverse_gc);
+ f->output_data.android->reverse_gc = 0;
+ }
+
+ if (f->output_data.android->cursor_gc)
+ {
+ android_free_gc (f->output_data.android->cursor_gc);
+ f->output_data.android->cursor_gc = 0;
+ }
+
+ unblock_input ();
+}
+
+/* Handler for signals raised during x_create_frame and
+ Fx_create_tip_frame. FRAME is the frame which is partially
+ constructed. */
+
+static Lisp_Object
+unwind_create_frame (Lisp_Object frame)
+{
+ struct frame *f = XFRAME (frame);
+
+ /* If frame is already dead, nothing to do. This can happen if the
+ display is disconnected after the frame has become official, but
+ before Fx_create_frame removes the unwind protect. */
+ if (!FRAME_LIVE_P (f))
+ return Qnil;
+
+ /* If frame is ``official'', nothing to do. */
+ if (NILP (Fmemq (frame, Vframe_list)))
+ {
+ /* If the frame's image cache refcount is still the same as our
+ private shadow variable, it means we are unwinding a frame
+ for which we didn't yet call init_frame_faces, where the
+ refcount is incremented. Therefore, we increment it here, so
+ that free_frame_faces, called in x_free_frame_resources
+ below, will not mistakenly decrement the counter that was not
+ incremented yet to account for this new frame. */
+ if (FRAME_IMAGE_CACHE (f) != NULL
+ && FRAME_IMAGE_CACHE (f)->refcount == image_cache_refcount)
+ FRAME_IMAGE_CACHE (f)->refcount++;
+
+ android_free_frame_resources (f);
+ free_glyphs (f);
+ return Qt;
+ }
+
+ return Qnil;
+}
+
+static void
+do_unwind_create_frame (Lisp_Object frame)
+{
+ unwind_create_frame (frame);
+}
+
+void
+android_default_font_parameter (struct frame *f, Lisp_Object parms)
+{
+ struct android_display_info *dpyinfo = FRAME_DISPLAY_INFO (f);
+ Lisp_Object font_param = gui_display_get_arg (dpyinfo, parms, Qfont, NULL, NULL,
+ RES_TYPE_STRING);
+ Lisp_Object font = Qnil;
+ if (BASE_EQ (font_param, Qunbound))
+ font_param = Qnil;
+
+ if (NILP (font))
+ font = (!NILP (font_param)
+ ? font_param
+ : gui_display_get_arg (dpyinfo, parms,
+ Qfont, "font", "Font",
+ RES_TYPE_STRING));
+
+ if (! FONTP (font) && ! STRINGP (font))
+ {
+ const char *names[] = {
+ "Droid Sans Mono-12",
+ "Monospace-12",
+ "DroidSansMono-12",
+ NULL
+ };
+ int i;
+
+ for (i = 0; names[i]; i++)
+ {
+ font = font_open_by_name (f, build_unibyte_string (names[i]));
+ if (! NILP (font))
+ break;
+ }
+
+ if (NILP (font))
+ error ("No suitable font was found");
+ }
+
+ gui_default_parameter (f, parms, Qfont, font, "font", "Font", RES_TYPE_STRING);
+}
+
+static void
+android_create_frame_window (struct frame *f)
+{
+ struct android_set_window_attributes attributes;
+ enum android_window_value_mask attribute_mask;
+
+ attributes.background_pixel = FRAME_BACKGROUND_PIXEL (f);
+ attribute_mask = ANDROID_CW_BACK_PIXEL;
+
+ block_input ();
+ FRAME_ANDROID_WINDOW (f)
+ = android_create_window (FRAME_DISPLAY_INFO (f)->root_window,
+ f->left_pos,
+ f->top_pos,
+ FRAME_PIXEL_WIDTH (f),
+ FRAME_PIXEL_HEIGHT (f),
+ attribute_mask, &attributes);
+ unblock_input ();
+}
+
+#endif /* ANDROID_STUBIFY */
+
+
+
+DEFUN ("x-create-frame", Fx_create_frame, Sx_create_frame,
+ 1, 1, 0,
+ doc: /* SKIP: real doc in xfns.c. */)
+ (Lisp_Object parms)
+{
+#ifdef ANDROID_STUBIFY
+ error ("Android cross-compilation stub called!");
+ return Qnil;
+#else
+ struct frame *f;
+ Lisp_Object frame, tem;
+ Lisp_Object name;
+ bool minibuffer_only;
+ bool undecorated, override_redirect;
+ long window_prompting;
+ specpdl_ref count;
+ Lisp_Object display;
+ struct android_display_info *dpyinfo;
+ Lisp_Object parent, parent_frame;
+ struct kboard *kb;
+
+ minibuffer_only = false;
+ undecorated = false;
+ override_redirect = false;
+ window_prompting = 0;
+ count = SPECPDL_INDEX ();
+ dpyinfo = NULL;
+
+ /* Not actually used, but be consistent with X. */
+ ((void) window_prompting);
+
+ parms = Fcopy_alist (parms);
+
+ /* Use this general default value to start with
+ until we know if this frame has a specified name. */
+ Vx_resource_name = Vinvocation_name;
+
+ display = gui_display_get_arg (dpyinfo, parms, Qterminal, 0, 0,
+ RES_TYPE_NUMBER);
+ if (BASE_EQ (display, Qunbound))
+ display = gui_display_get_arg (dpyinfo, parms, Qdisplay, 0, 0,
+ RES_TYPE_STRING);
+ if (BASE_EQ (display, Qunbound))
+ display = Qnil;
+ dpyinfo = check_android_display_info (display);
+ kb = dpyinfo->terminal->kboard;
+
+ if (!dpyinfo->terminal->name)
+ error ("Terminal is not live, can't create new frames on it");
+
+ name = gui_display_get_arg (dpyinfo, parms, Qname, "name", "Name",
+ RES_TYPE_STRING);
+ if (!STRINGP (name)
+ && ! BASE_EQ (name, Qunbound)
+ && ! NILP (name))
+ error ("Invalid frame name--not a string or nil");
+
+ if (STRINGP (name))
+ Vx_resource_name = name;
+
+ /* See if parent window is specified. */
+ parent = gui_display_get_arg (dpyinfo, parms, Qparent_id, NULL, NULL,
+ RES_TYPE_NUMBER);
+ if (BASE_EQ (parent, Qunbound))
+ parent = Qnil;
+ if (! NILP (parent))
+ CHECK_FIXNUM (parent);
+
+ frame = Qnil;
+ tem = gui_display_get_arg (dpyinfo,
+ parms, Qminibuffer, "minibuffer", "Minibuffer",
+ RES_TYPE_SYMBOL);
+ if (EQ (tem, Qnone) || NILP (tem))
+ f = make_frame_without_minibuffer (Qnil, kb, display);
+ else if (EQ (tem, Qonly))
+ {
+ f = make_minibuffer_frame ();
+ minibuffer_only = true;
+ }
+ else if (WINDOWP (tem))
+ f = make_frame_without_minibuffer (tem, kb, display);
+ else
+ f = make_frame (true);
+
+ parent_frame = gui_display_get_arg (dpyinfo,
+ parms,
+ Qparent_frame,
+ NULL,
+ NULL,
+ RES_TYPE_SYMBOL);
+ /* Accept parent-frame iff parent-id was not specified. */
+ if (!NILP (parent)
+ || BASE_EQ (parent_frame, Qunbound)
+ || NILP (parent_frame)
+ || !FRAMEP (parent_frame)
+ || !FRAME_LIVE_P (XFRAME (parent_frame))
+ || !FRAME_ANDROID_P (XFRAME (parent_frame)))
+ parent_frame = Qnil;
+
+ fset_parent_frame (f, parent_frame);
+ store_frame_param (f, Qparent_frame, parent_frame);
+
+ if (!NILP (tem = (gui_display_get_arg (dpyinfo,
+ parms,
+ Qundecorated,
+ NULL,
+ NULL,
+ RES_TYPE_BOOLEAN)))
+ && !(BASE_EQ (tem, Qunbound)))
+ undecorated = true;
+
+ FRAME_UNDECORATED (f) = undecorated;
+ store_frame_param (f, Qundecorated, undecorated ? Qt : Qnil);
+
+ if (!NILP (tem = (gui_display_get_arg (dpyinfo,
+ parms,
+ Qoverride_redirect,
+ NULL,
+ NULL,
+ RES_TYPE_BOOLEAN)))
+ && !(BASE_EQ (tem, Qunbound)))
+ override_redirect = true;
+
+ FRAME_OVERRIDE_REDIRECT (f) = override_redirect;
+ store_frame_param (f, Qoverride_redirect, override_redirect ? Qt : Qnil);
+
+ XSETFRAME (frame, f);
+
+ f->terminal = dpyinfo->terminal;
+
+ f->output_method = output_android;
+ f->output_data.android = xzalloc (sizeof *f->output_data.android);
+ FRAME_FONTSET (f) = -1;
+ f->output_data.android->scroll_bar_foreground_pixel = -1;
+ f->output_data.android->scroll_bar_background_pixel = -1;
+ f->output_data.android->white_relief.pixel = -1;
+ f->output_data.android->black_relief.pixel = -1;
+
+ fset_icon_name (f, gui_display_get_arg (dpyinfo,
+ parms,
+ Qicon_name,
+ "iconName",
+ "Title",
+ RES_TYPE_STRING));
+ if (! STRINGP (f->icon_name))
+ fset_icon_name (f, Qnil);
+
+ FRAME_DISPLAY_INFO (f) = dpyinfo;
+
+ /* With FRAME_DISPLAY_INFO set up, this unwind-protect is safe. */
+ record_unwind_protect (do_unwind_create_frame, frame);
+
+ /* These colors will be set anyway later, but it's important
+ to get the color reference counts right, so initialize them!
+
+ (Not really on Android, but it's best to be consistent with
+ X.) */
+ {
+ Lisp_Object black;
+
+ /* Function x_decode_color can signal an error. Make
+ sure to initialize color slots so that we won't try
+ to free colors we haven't allocated. */
+ FRAME_FOREGROUND_PIXEL (f) = -1;
+ FRAME_BACKGROUND_PIXEL (f) = -1;
+ f->output_data.android->cursor_pixel = -1;
+ f->output_data.android->cursor_foreground_pixel = -1;
+ f->output_data.android->mouse_pixel = -1;
+
+ black = build_string ("black");
+ FRAME_FOREGROUND_PIXEL (f)
+ = android_decode_color (f, black, BLACK_PIX_DEFAULT (f));
+ FRAME_BACKGROUND_PIXEL (f)
+ = android_decode_color (f, black, BLACK_PIX_DEFAULT (f));
+ f->output_data.android->cursor_pixel
+ = android_decode_color (f, black, BLACK_PIX_DEFAULT (f));
+ f->output_data.android->cursor_foreground_pixel
+ = android_decode_color (f, black, BLACK_PIX_DEFAULT (f));
+ f->output_data.android->mouse_pixel
+ = android_decode_color (f, black, BLACK_PIX_DEFAULT (f));
+ }
+
+ /* Set the name; the functions to which we pass f expect the name to
+ be set. */
+ if (BASE_EQ (name, Qunbound) || NILP (name))
+ {
+ fset_name (f, build_string ("GNU Emacs"));
+ f->explicit_name = false;
+ }
+ else
+ {
+ fset_name (f, name);
+ f->explicit_name = true;
+ /* Use the frame's title when getting resources for this frame. */
+ specbind (Qx_resource_name, name);
+ }
+
+ register_font_driver (&androidfont_driver, f);
+ register_font_driver (&android_sfntfont_driver, f);
+
+ image_cache_refcount = (FRAME_IMAGE_CACHE (f)
+ ? FRAME_IMAGE_CACHE (f)->refcount
+ : 0);
+
+ gui_default_parameter (f, parms, Qfont_backend, Qnil,
+ "fontBackend", "FontBackend", RES_TYPE_STRING);
+
+ /* Extract the window parameters from the supplied values
+ that are needed to determine window geometry. */
+ android_default_font_parameter (f, parms);
+ if (!FRAME_FONT (f))
+ {
+ delete_frame (frame, Qnoelisp);
+ error ("Invalid frame font");
+ }
+
+ if (NILP (Fassq (Qinternal_border_width, parms)))
+ {
+ Lisp_Object value;
+
+ value = gui_display_get_arg (dpyinfo, parms, Qinternal_border_width,
+ "internalBorder", "internalBorder",
+ RES_TYPE_NUMBER);
+ if (! BASE_EQ (value, Qunbound))
+ parms = Fcons (Fcons (Qinternal_border_width, value),
+ parms);
+ }
+
+ gui_default_parameter (f, parms, Qinternal_border_width,
+ make_fixnum (0),
+ "internalBorderWidth", "internalBorderWidth",
+ RES_TYPE_NUMBER);
+
+ /* Same for child frames. */
+ if (NILP (Fassq (Qchild_frame_border_width, parms)))
+ {
+ Lisp_Object value;
+
+ value = gui_display_get_arg (dpyinfo, parms, Qchild_frame_border_width,
+ "childFrameBorder", "childFrameBorder",
+ RES_TYPE_NUMBER);
+ if (! BASE_EQ (value, Qunbound))
+ parms = Fcons (Fcons (Qchild_frame_border_width, value),
+ parms);
+ }
+
+ gui_default_parameter (f, parms, Qchild_frame_border_width, Qnil,
+ "childFrameBorderWidth", "childFrameBorderWidth",
+ RES_TYPE_NUMBER);
+ gui_default_parameter (f, parms, Qright_divider_width, make_fixnum (0),
+ NULL, NULL, RES_TYPE_NUMBER);
+ gui_default_parameter (f, parms, Qbottom_divider_width, make_fixnum (0),
+ NULL, NULL, RES_TYPE_NUMBER);
+
+ /* `vertical-scroll-bars' defaults to nil on Android as a
+ consequence of scroll bars not being supported at all. */
+
+ gui_default_parameter (f, parms, Qvertical_scroll_bars, Qnil,
+ "verticalScrollBars", "ScrollBars",
+ RES_TYPE_SYMBOL);
+ gui_default_parameter (f, parms, Qhorizontal_scroll_bars, Qnil,
+ "horizontalScrollBars", "ScrollBars",
+ RES_TYPE_SYMBOL);
+
+ /* Also do the stuff which must be set before the window exists. */
+ gui_default_parameter (f, parms, Qforeground_color, build_string ("black"),
+ "foreground", "Foreground", RES_TYPE_STRING);
+ gui_default_parameter (f, parms, Qbackground_color, build_string ("white"),
+ "background", "Background", RES_TYPE_STRING);
+ gui_default_parameter (f, parms, Qmouse_color, build_string ("black"),
+ "pointerColor", "Foreground", RES_TYPE_STRING);
+ gui_default_parameter (f, parms, Qborder_color, build_string ("black"),
+ "borderColor", "BorderColor", RES_TYPE_STRING);
+ gui_default_parameter (f, parms, Qscreen_gamma, Qnil,
+ "screenGamma", "ScreenGamma", RES_TYPE_FLOAT);
+ gui_default_parameter (f, parms, Qline_spacing, Qnil,
+ "lineSpacing", "LineSpacing", RES_TYPE_NUMBER);
+ gui_default_parameter (f, parms, Qleft_fringe, Qnil,
+ "leftFringe", "LeftFringe", RES_TYPE_NUMBER);
+ gui_default_parameter (f, parms, Qright_fringe, Qnil,
+ "rightFringe", "RightFringe", RES_TYPE_NUMBER);
+ gui_default_parameter (f, parms, Qno_special_glyphs, Qnil,
+ NULL, NULL, RES_TYPE_BOOLEAN);
+
+#if 0
+ android_default_scroll_bar_color_parameter (f, parms, Qscroll_bar_foreground,
+ "scrollBarForeground",
+ "ScrollBarForeground", true);
+ android_default_scroll_bar_color_parameter (f, parms, Qscroll_bar_background,
+ "scrollBarBackground",
+ "ScrollBarBackground", false);
+#endif
+
+ /* Init faces before gui_default_parameter is called for the
+ scroll-bar-width parameter because otherwise we end up in
+ init_iterator with a null face cache, which should not
+ happen. */
+
+ init_frame_faces (f);
+
+ tem = gui_display_get_arg (dpyinfo, parms, Qmin_width, NULL, NULL,
+ RES_TYPE_NUMBER);
+ if (FIXNUMP (tem))
+ store_frame_param (f, Qmin_width, tem);
+ tem = gui_display_get_arg (dpyinfo, parms, Qmin_height, NULL, NULL,
+ 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, true,
+ Qx_create_frame_1);
+
+ /* Set the menu-bar-lines and tool-bar-lines parameters. We don't
+ look up the X resources controlling the menu-bar and tool-bar
+ here; they are processed specially at startup, and reflected in
+ the values of the mode variables. */
+
+ gui_default_parameter (f, parms, Qmenu_bar_lines,
+ NILP (Vmenu_bar_mode)
+ ? make_fixnum (0) : make_fixnum (1),
+ NULL, NULL, RES_TYPE_NUMBER);
+ gui_default_parameter (f, parms, Qtab_bar_lines,
+ NILP (Vtab_bar_mode)
+ ? make_fixnum (0) : make_fixnum (1),
+ NULL, NULL, RES_TYPE_NUMBER);
+ gui_default_parameter (f, parms, Qtool_bar_lines,
+ NILP (Vtool_bar_mode)
+ ? make_fixnum (0) : make_fixnum (1),
+ NULL, NULL, RES_TYPE_NUMBER);
+
+ gui_default_parameter (f, parms, Qbuffer_predicate, Qnil,
+ "bufferPredicate", "BufferPredicate",
+ RES_TYPE_SYMBOL);
+ gui_default_parameter (f, parms, Qtitle, Qnil,
+ "title", "Title", RES_TYPE_STRING);
+ gui_default_parameter (f, parms, Qwait_for_wm, Qt,
+ "waitForWM", "WaitForWM", RES_TYPE_BOOLEAN);
+ gui_default_parameter (f, parms, Qtool_bar_position,
+ FRAME_TOOL_BAR_POSITION (f), 0, 0, RES_TYPE_SYMBOL);
+ gui_default_parameter (f, parms, Qinhibit_double_buffering, Qnil,
+ "inhibitDoubleBuffering", "InhibitDoubleBuffering",
+ RES_TYPE_BOOLEAN);
+
+ /* Compute the size of the X window. */
+ window_prompting = gui_figure_window_size (f, parms, true, true);
+
+ tem = gui_display_get_arg (dpyinfo, parms, Qunsplittable, 0, 0,
+ RES_TYPE_BOOLEAN);
+ f->no_split = minibuffer_only || EQ (tem, Qt);
+
+ android_icon_verify (f, parms);
+ android_create_frame_window (f);
+ android_icon (f, parms);
+ android_make_gc (f);
+
+ /* Now consider the frame official. */
+ f->terminal->reference_count++;
+ Vframe_list = Fcons (frame, Vframe_list);
+
+ /* We need to do this after creating the window, so that the
+ icon-creation functions can say whose icon they're
+ describing. */
+ gui_default_parameter (f, parms, Qicon_type, Qt,
+ "bitmapIcon", "BitmapIcon", RES_TYPE_BOOLEAN);
+
+ gui_default_parameter (f, parms, Qauto_raise, Qnil,
+ "autoRaise", "AutoRaiseLower", RES_TYPE_BOOLEAN);
+ gui_default_parameter (f, parms, Qauto_lower, Qnil,
+ "autoLower", "AutoRaiseLower", RES_TYPE_BOOLEAN);
+ gui_default_parameter (f, parms, Qcursor_type, Qbox,
+ "cursorType", "CursorType", RES_TYPE_SYMBOL);
+ /* Scroll bars are not supported on Android, as they are near
+ useless. */
+ gui_default_parameter (f, parms, Qscroll_bar_width, Qnil,
+ "scrollBarWidth", "ScrollBarWidth",
+ RES_TYPE_NUMBER);
+ gui_default_parameter (f, parms, Qscroll_bar_height, Qnil,
+ "scrollBarHeight", "ScrollBarHeight",
+ RES_TYPE_NUMBER);
+ gui_default_parameter (f, parms, Qalpha, Qnil,
+ "alpha", "Alpha", RES_TYPE_NUMBER);
+ gui_default_parameter (f, parms, Qalpha_background, Qnil,
+ "alphaBackground", "AlphaBackground", RES_TYPE_NUMBER);
+
+ if (!NILP (parent_frame))
+ {
+ struct frame *p = XFRAME (parent_frame);
+
+ block_input ();
+ android_reparent_window (FRAME_ANDROID_WINDOW (f),
+ FRAME_ANDROID_WINDOW (p),
+ f->left_pos, f->top_pos);
+ unblock_input ();
+ }
+
+ gui_default_parameter (f, parms, Qno_focus_on_map, Qnil,
+ NULL, NULL, RES_TYPE_BOOLEAN);
+ gui_default_parameter (f, parms, Qno_accept_focus, Qnil,
+ NULL, NULL, RES_TYPE_BOOLEAN);
+
+ /* Consider frame official, now. */
+ f->can_set_window_size = true;
+
+ adjust_frame_size (f, FRAME_TEXT_WIDTH (f), FRAME_TEXT_HEIGHT (f),
+ 0, true, Qx_create_frame_2);
+
+ /* Process fullscreen parameter here in the hope that normalizing a
+ fullheight/fullwidth frame will produce the size set by the last
+ adjust_frame_size call. Note that Android only supports the
+ `maximized' state. */
+ gui_default_parameter (f, parms, Qfullscreen, Qmaximized,
+ "fullscreen", "Fullscreen", RES_TYPE_SYMBOL);
+
+ /* When called from `x-create-frame-with-faces' visibility is
+ always explicitly nil. */
+ Lisp_Object visibility
+ = gui_display_get_arg (dpyinfo, parms, Qvisibility, 0, 0,
+ RES_TYPE_SYMBOL);
+ Lisp_Object height
+ = gui_display_get_arg (dpyinfo, parms, Qheight, 0, 0, RES_TYPE_NUMBER);
+ Lisp_Object width
+ = gui_display_get_arg (dpyinfo, parms, Qwidth, 0, 0, RES_TYPE_NUMBER);
+
+ if (EQ (visibility, Qicon))
+ {
+ f->was_invisible = true;
+ android_iconify_frame (f);
+ }
+ else
+ {
+ if (BASE_EQ (visibility, Qunbound))
+ visibility = Qt;
+
+ if (!NILP (visibility))
+ android_make_frame_visible (f);
+ else
+ f->was_invisible = true;
+ }
+
+ /* Leave f->was_invisible true only if height or width were
+ specified too. This takes effect only when we are not called
+ from `x-create-frame-with-faces' (see above comment). */
+ f->was_invisible
+ = (f->was_invisible
+ && (!BASE_EQ (height, Qunbound) || !BASE_EQ (width, Qunbound)));
+
+ store_frame_param (f, Qvisibility, visibility);
+
+ /* Set whether or not frame synchronization is enabled. */
+ gui_default_parameter (f, parms, Quse_frame_synchronization, Qt,
+ NULL, NULL, RES_TYPE_BOOLEAN);
+
+ /* Works iff frame has been already mapped. */
+ gui_default_parameter (f, parms, Qskip_taskbar, Qnil,
+ NULL, NULL, RES_TYPE_BOOLEAN);
+ /* The `z-group' parameter works only for visible frames. */
+ gui_default_parameter (f, parms, Qz_group, Qnil,
+ NULL, NULL, RES_TYPE_SYMBOL);
+
+ /* Initialize `default-minibuffer-frame' in case this is the first
+ frame on this terminal. */
+ if (FRAME_HAS_MINIBUF_P (f)
+ && (!FRAMEP (KVAR (kb, Vdefault_minibuffer_frame))
+ || !FRAME_LIVE_P (XFRAME (KVAR (kb, Vdefault_minibuffer_frame)))))
+ kset_default_minibuffer_frame (kb, frame);
+
+ /* All remaining specified parameters, which have not been "used" by
+ gui_display_get_arg and friends, now go in the misc. alist of the
+ frame. */
+ 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));
+
+ /* Make sure windows on this frame appear in calls to next-window
+ and similar functions. */
+ Vwindow_list = Qnil;
+
+ return unbind_to (count, frame);
+#endif
+}
+
+DEFUN ("xw-color-defined-p", Fxw_color_defined_p, Sxw_color_defined_p,
+ 1, 2, 0, doc: /* SKIP: real doc in xfns.c. */)
+ (Lisp_Object color, Lisp_Object frame)
+{
+#ifdef ANDROID_STUBIFY
+ error ("Android cross-compilation stub called!");
+ return Qnil;
+#else
+ Emacs_Color foo;
+ struct frame *f;
+
+ f = decode_window_system_frame (frame);
+
+ CHECK_STRING (color);
+
+ if (android_defined_color (f, SSDATA (color), &foo, false, false))
+ return Qt;
+ else
+ return Qnil;
+#endif
+}
+
+DEFUN ("xw-color-values", Fxw_color_values, Sxw_color_values, 1, 2,
+ 0, doc: /* SKIP: real doc in xfns.c. */)
+ (Lisp_Object color, Lisp_Object frame)
+{
+#ifdef ANDROID_STUBIFY
+ error ("Android cross-compilation stub called!");
+ return Qnil;
+#else
+ Emacs_Color foo;
+ struct frame *f;
+
+ f = decode_window_system_frame (frame);
+
+ CHECK_STRING (color);
+
+ if (android_defined_color (f, SSDATA (color), &foo, false, false))
+ return list3i (foo.red, foo.green, foo.blue);
+ else
+ return Qnil;
+#endif
+}
+
+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;
+}
+
+DEFUN ("x-display-grayscale-p", Fx_display_grayscale_p,
+ Sx_display_grayscale_p, 0, 1, 0,
+ doc: /* SKIP: real doc in xfns.c. */)
+ (Lisp_Object terminal)
+{
+ return Qnil;
+}
+
+DEFUN ("x-display-pixel-width", Fx_display_pixel_width,
+ Sx_display_pixel_width, 0, 1, 0,
+ doc: /* SKIP: real doc in xfns.c. */)
+ (Lisp_Object terminal)
+{
+#ifdef ANDROID_STUBIFY
+ error ("Android cross-compilation stub called!");
+ return Qnil;
+#else
+ return make_fixnum (android_get_screen_width ());
+#endif
+}
+
+DEFUN ("x-display-pixel-height", Fx_display_pixel_height,
+ Sx_display_pixel_height, 0, 1, 0,
+ doc: /* SKIP: real doc in xfns.c. */)
+ (Lisp_Object terminal)
+{
+#ifdef ANDROID_STUBIFY
+ error ("Android cross-compilation stub called!");
+ return Qnil;
+#else
+ return make_fixnum (android_get_screen_height ());
+#endif
+}
+
+DEFUN ("x-display-planes", Fx_display_planes, Sx_display_planes,
+ 0, 1, 0,
+ doc: /* SKIP: real doc in xfns.c. */)
+ (Lisp_Object terminal)
+{
+ struct android_display_info *dpyinfo;
+
+ dpyinfo = check_android_display_info (terminal);
+
+ return make_fixnum (dpyinfo->n_planes);
+}
+
+DEFUN ("x-display-color-cells", Fx_display_color_cells, Sx_display_color_cells,
+ 0, 1, 0,
+ doc: /* SKIP: real doc in xfns.c. */)
+ (Lisp_Object terminal)
+{
+ struct android_display_info *dpyinfo;
+ int nr_planes;
+
+ dpyinfo = check_android_display_info (terminal);
+ nr_planes = dpyinfo->n_planes;
+
+ /* Truncate nr_planes to 24 to avoid integer overflow. */
+
+ if (nr_planes > 24)
+ nr_planes = 24;
+
+ return make_fixnum (1 << nr_planes);
+}
+
+DEFUN ("x-server-vendor", Fx_server_vendor, Sx_server_vendor, 0, 1, 0,
+ doc: /* SKIP: real doc in xfns.c. */)
+ (Lisp_Object terminal)
+{
+#ifdef ANDROID_STUBIFY
+ error ("Android cross-compilation stub called!");
+ return Qnil;
+#else
+ check_android_display_info (terminal);
+ return Vandroid_build_manufacturer;
+#endif
+}
+
+DEFUN ("x-server-version", Fx_server_version, Sx_server_version, 0, 1, 0,
+ doc: /* SKIP: real doc in xfns.c. */)
+ (Lisp_Object terminal)
+{
+#ifdef ANDROID_STUBIFY
+ error ("Android cross-compilation stub called!");
+ return Qnil;
+#else
+ check_android_display_info (terminal);
+ return list3i (android_get_current_api_level (), 0, 0);
+#endif
+}
+
+DEFUN ("x-display-screens", Fx_display_screens, Sx_display_screens,
+ 0, 1, 0, doc: /* SKIP: real doc in xfns.c. */)
+ (Lisp_Object terminal)
+{
+ check_android_display_info (terminal);
+ return make_fixnum (1);
+}
+
+DEFUN ("x-display-mm-width", Fx_display_mm_width, Sx_display_mm_width,
+ 0, 1, 0, doc: /* SKIP: real doc in xfns.c. */)
+ (Lisp_Object terminal)
+{
+#ifdef ANDROID_STUBIFY
+ error ("Android cross-compilation stub called!");
+ return Qnil;
+#else
+ return make_fixnum (android_get_mm_width ());
+#endif
+}
+
+DEFUN ("x-display-mm-height", Fx_display_mm_height, Sx_display_mm_height,
+ 0, 1, 0, doc: /* SKIP: real doc in xfns.c. */)
+ (Lisp_Object terminal)
+{
+#ifdef ANDROID_STUBIFY
+ error ("Android cross-compilation stub called!");
+ return Qnil;
+#else
+ return make_fixnum (android_get_mm_height ());
+#endif
+}
+
+DEFUN ("x-display-backing-store", Fx_display_backing_store,
+ Sx_display_backing_store, 0, 1, 0,
+ doc: /* SKIP: real doc in xfns.c. */)
+ (Lisp_Object terminal)
+{
+ check_android_display_info (terminal);
+
+ /* Window contents are preserved insofar as they remain mapped, in a
+ fashion tantamount to WhenMapped. */
+ return Qwhen_mapped;
+}
+
+DEFUN ("x-display-visual-class", Fx_display_visual_class,
+ Sx_display_visual_class, 0, 1, 0,
+ doc: /* SKIP: real doc in xfns.c. */)
+ (Lisp_Object terminal)
+{
+ check_android_display_info (terminal);
+
+ return Qtrue_color;
+}
+
+#ifndef ANDROID_STUBIFY
+
+static Lisp_Object
+android_make_monitor_attribute_list (struct MonitorInfo *monitors,
+ int n_monitors,
+ int primary_monitor)
+{
+ Lisp_Object monitor_frames;
+ Lisp_Object frame, rest;
+ struct frame *f;
+
+ monitor_frames = make_nil_vector (n_monitors);
+
+ FOR_EACH_FRAME (rest, frame)
+ {
+ f = XFRAME (frame);
+
+ /* Associate all frames with the primary monitor. */
+
+ if (FRAME_WINDOW_P (f)
+ && !FRAME_TOOLTIP_P (f))
+ ASET (monitor_frames, primary_monitor,
+ Fcons (frame, AREF (monitor_frames,
+ primary_monitor)));
+ }
+
+ return make_monitor_attribute_list (monitors, n_monitors,
+ primary_monitor,
+ monitor_frames, NULL);
+}
+
+#endif
+
+DEFUN ("android-display-monitor-attributes-list",
+ Fandroid_display_monitor_attributes_list,
+ Sandroid_display_monitor_attributes_list,
+ 0, 1, 0,
+ doc: /* Return a list of physical monitor attributes on the X display TERMINAL.
+
+The optional argument TERMINAL specifies which display to ask about.
+TERMINAL should be a terminal object, a frame or a display name (a string).
+If omitted or nil, that stands for the selected frame's display.
+
+Internal use only, use `display-monitor-attributes-list' instead. */)
+ (Lisp_Object terminal)
+{
+#ifdef ANDROID_STUBIFY
+ error ("Android cross-compilation stub called!");
+ return Qnil;
+#else
+ struct MonitorInfo monitor;
+
+ memset (&monitor, 0, sizeof monitor);
+ monitor.geom.width = android_get_screen_width ();
+ monitor.geom.height = android_get_screen_height ();
+ monitor.mm_width = android_get_mm_width ();
+ monitor.mm_height = android_get_mm_height ();
+ monitor.work = monitor.geom;
+ monitor.name = (char *) "Android device monitor";
+
+ return android_make_monitor_attribute_list (&monitor, 1, 0);
+#endif
+}
+
+#ifndef ANDROID_STUBIFY
+
+static Lisp_Object
+frame_geometry (Lisp_Object frame, Lisp_Object attribute)
+{
+ struct frame *f = decode_live_frame (frame);
+ android_window rootw;
+ unsigned int native_width, native_height, x_border_width = 0;
+ int x_native = 0, y_native = 0, xptr = 0, yptr = 0;
+ int left_off = 0, right_off = 0, top_off = 0, bottom_off = 0;
+ int outer_left, outer_top, outer_right, outer_bottom;
+ int native_left, native_top, native_right, native_bottom;
+ int inner_left, inner_top, inner_right, inner_bottom;
+ int internal_border_width;
+ bool menu_bar_external = false, tool_bar_external = false;
+ int menu_bar_height = 0, menu_bar_width = 0;
+ int tab_bar_height = 0, tab_bar_width = 0;
+ int tool_bar_height = 0, tool_bar_width = 0;
+
+ if (FRAME_INITIAL_P (f) || !FRAME_ANDROID_P (f)
+ || !FRAME_ANDROID_WINDOW (f))
+ return Qnil;
+
+ block_input ();
+ android_get_geometry (FRAME_ANDROID_WINDOW (f),
+ &rootw, &x_native, &y_native,
+ &native_width, &native_height, &x_border_width);
+ unblock_input ();
+
+ if (FRAME_PARENT_FRAME (f))
+ {
+ Lisp_Object parent, edges;
+
+ XSETFRAME (parent, FRAME_PARENT_FRAME (f));
+ edges = Fandroid_frame_edges (parent, Qnative_edges);
+ if (!NILP (edges))
+ {
+ x_native += XFIXNUM (Fnth (make_fixnum (0), edges));
+ y_native += XFIXNUM (Fnth (make_fixnum (1), edges));
+ }
+
+ outer_left = x_native;
+ outer_top = y_native;
+ outer_right = outer_left + native_width + 2 * x_border_width;
+ outer_bottom = outer_top + native_height + 2 * x_border_width;
+
+ native_left = x_native + x_border_width;
+ native_top = y_native + x_border_width;
+ native_right = native_left + native_width;
+ native_bottom = native_top + native_height;
+ }
+ else
+ {
+ outer_left = xptr;
+ outer_top = yptr;
+ outer_right = outer_left + left_off + native_width + right_off;
+ outer_bottom = outer_top + top_off + native_height + bottom_off;
+
+ native_left = outer_left + left_off;
+ native_top = outer_top + top_off;
+ native_right = native_left + native_width;
+ native_bottom = native_top + native_height;
+ }
+
+ internal_border_width = FRAME_INTERNAL_BORDER_WIDTH (f);
+ inner_left = native_left + internal_border_width;
+ inner_top = native_top + internal_border_width;
+ inner_right = native_right - internal_border_width;
+ inner_bottom = native_bottom - internal_border_width;
+
+ menu_bar_height = FRAME_MENU_BAR_HEIGHT (f);
+ inner_top += menu_bar_height;
+ menu_bar_width = menu_bar_height ? native_width : 0;
+
+ tab_bar_height = FRAME_TAB_BAR_HEIGHT (f);
+ tab_bar_width = (tab_bar_height
+ ? native_width - 2 * internal_border_width
+ : 0);
+ inner_top += tab_bar_height;
+
+ tool_bar_height = FRAME_TOOL_BAR_HEIGHT (f);
+ tool_bar_width = (tool_bar_height
+ ? native_width - 2 * internal_border_width
+ : 0);
+
+ /* Subtract or add to the inner dimensions based on the tool bar
+ position. */
+
+ if (EQ (FRAME_TOOL_BAR_POSITION (f), Qtop))
+ inner_top += tool_bar_height;
+ else
+ inner_bottom -= tool_bar_height;
+
+ /* Construct list. */
+ if (EQ (attribute, Qouter_edges))
+ return list4i (outer_left, outer_top, outer_right, outer_bottom);
+ else if (EQ (attribute, Qnative_edges))
+ return list4i (native_left, native_top, native_right, native_bottom);
+ else if (EQ (attribute, Qinner_edges))
+ return list4i (inner_left, inner_top, inner_right, inner_bottom);
+ else
+ return
+ list (Fcons (Qouter_position,
+ Fcons (make_fixnum (outer_left),
+ make_fixnum (outer_top))),
+ Fcons (Qouter_size,
+ Fcons (make_fixnum (outer_right - outer_left),
+ make_fixnum (outer_bottom - outer_top))),
+ /* Approximate. */
+ Fcons (Qexternal_border_size,
+ Fcons (make_fixnum (right_off),
+ make_fixnum (bottom_off))),
+ Fcons (Qouter_border_width, make_fixnum (x_border_width)),
+ /* Approximate. */
+ Fcons (Qtitle_bar_size,
+ Fcons (make_fixnum (0),
+ make_fixnum (top_off - bottom_off))),
+ Fcons (Qmenu_bar_external, menu_bar_external ? Qt : Qnil),
+ Fcons (Qmenu_bar_size,
+ Fcons (make_fixnum (menu_bar_width),
+ make_fixnum (menu_bar_height))),
+ Fcons (Qtab_bar_size,
+ Fcons (make_fixnum (tab_bar_width),
+ make_fixnum (tab_bar_height))),
+ Fcons (Qtool_bar_external, tool_bar_external ? Qt : Qnil),
+ Fcons (Qtool_bar_position, FRAME_TOOL_BAR_POSITION (f)),
+ Fcons (Qtool_bar_size,
+ Fcons (make_fixnum (tool_bar_width),
+ make_fixnum (tool_bar_height))),
+ Fcons (Qinternal_border_width,
+ make_fixnum (internal_border_width)));
+}
+
+#endif
+
+DEFUN ("android-frame-geometry", Fandroid_frame_geometry,
+ Sandroid_frame_geometry,
+ 0, 1, 0,
+ doc: /* Return geometric attributes of FRAME.
+FRAME must be a live frame and defaults to the selected one. The return
+value is an association list of the attributes listed below. All height
+and width values are in pixels.
+
+`outer-position' is a cons of the outer left and top edges of FRAME
+ relative to the origin - the position (0, 0) - of FRAME's display.
+
+`outer-size' is a cons of the outer width and height of FRAME. The
+ outer size includes the title bar and the external borders as well as
+ any menu and/or tool bar of frame.
+
+`external-border-size' is a cons of the horizontal and vertical width of
+ FRAME's external borders as supplied by the window manager.
+
+`title-bar-size' is a cons of the width and height of the title bar of
+ FRAME as supplied by the window manager. If both of them are zero,
+ FRAME has no title bar. If only the width is zero, Emacs was not
+ able to retrieve the width information.
+
+`menu-bar-external', if non-nil, means the menu bar is external (never
+ included in the inner edges of FRAME).
+
+`menu-bar-size' is a cons of the width and height of the menu bar of
+ FRAME.
+
+`tool-bar-external', if non-nil, means the tool bar is external (never
+ included in the inner edges of FRAME).
+
+`tool-bar-position' tells on which side the tool bar on FRAME is and can
+ be one of `left', `top', `right' or `bottom'. If this is nil, FRAME
+ has no tool bar.
+
+`tool-bar-size' is a cons of the width and height of the tool bar of
+ FRAME.
+
+`internal-border-width' is the width of the internal border of
+ FRAME. */)
+ (Lisp_Object frame)
+{
+#ifdef ANDROID_STUBIFY
+ error ("Android cross-compilation stub called!");
+ return Qnil;
+#else
+ return frame_geometry (frame, Qnil);
+#endif
+}
+
+DEFUN ("android-frame-edges", Fandroid_frame_edges,
+ Sandroid_frame_edges, 0, 2, 0,
+ doc: /* Return edge coordinates of FRAME.
+FRAME must be a live frame and defaults to the selected one. The return
+value is a list of the form (LEFT, TOP, RIGHT, BOTTOM). All values are
+in pixels relative to the origin - the position (0, 0) - of FRAME's
+display.
+
+If optional argument TYPE is the symbol `outer-edges', return the outer
+edges of FRAME. The outer edges comprise the decorations of the window
+manager (like the title bar or external borders) as well as any external
+menu or tool bar of FRAME. If optional argument TYPE is the symbol
+`native-edges' or nil, return the native edges of FRAME. The native
+edges exclude the decorations of the window manager and any external
+menu or tool bar of FRAME. If TYPE is the symbol `inner-edges', return
+the inner edges of FRAME. These edges exclude title bar, any borders,
+menu bar or tool bar of FRAME. */)
+ (Lisp_Object frame, Lisp_Object type)
+{
+#ifndef ANDROID_STUBIFY
+ return frame_geometry (frame, ((EQ (type, Qouter_edges)
+ || EQ (type, Qinner_edges))
+ ? type
+ : Qnative_edges));
+#else
+ return Qnil;
+#endif
+}
+
+#ifndef ANDROID_STUBIFY
+
+static Lisp_Object
+android_frame_list_z_order (struct android_display_info *dpyinfo,
+ android_window window)
+{
+ android_window root, parent, *children;
+ unsigned int nchildren;
+ unsigned long i;
+ Lisp_Object frames;
+
+ frames = Qnil;
+
+ if (android_query_tree (window, &root, &parent,
+ &children, &nchildren))
+ {
+ for (i = 0; i < nchildren; i++)
+ {
+ Lisp_Object frame, tail;
+
+ FOR_EACH_FRAME (tail, frame)
+ {
+ struct frame *cf = XFRAME (frame);
+
+ if (FRAME_ANDROID_P (cf)
+ && (FRAME_ANDROID_WINDOW (cf) == children[i]))
+ frames = Fcons (frame, frames);
+ }
+ }
+
+ if (children)
+ xfree (children);
+ }
+
+ return frames;
+}
+
+#endif
+
+DEFUN ("android-frame-list-z-order", Fandroid_frame_list_z_order,
+ Sandroid_frame_list_z_order, 0, 1, 0,
+ doc: /* Return list of Emacs' frames, in Z (stacking) order.
+The optional argument TERMINAL specifies which display to ask about.
+TERMINAL should be either a frame or a display name (a string). If
+omitted or nil, that stands for the selected frame's display. Return
+nil if TERMINAL contains no Emacs frame.
+
+As a special case, if TERMINAL is non-nil and specifies a live frame,
+return the child frames of that frame in Z (stacking) order.
+
+Frames are listed from topmost (first) to bottommost (last).
+
+On Android, the order of the frames returned is undefined unless
+TERMINAL is a frame. */)
+ (Lisp_Object terminal)
+{
+#ifdef ANDROID_STUBIFY
+ error ("Android cross-compilation stub called!");
+ return Qnil;
+#else
+ struct android_display_info *dpyinfo;
+ android_window window;
+
+ dpyinfo = check_android_display_info (terminal);
+
+ if (FRAMEP (terminal) && FRAME_LIVE_P (XFRAME (terminal)))
+ window = FRAME_ANDROID_WINDOW (XFRAME (terminal));
+ else
+ window = dpyinfo->root_window;
+
+ return android_frame_list_z_order (dpyinfo, window);
+#endif
+}
+
+#ifndef ANDROID_STUBIFY
+
+static void
+android_frame_restack (struct frame *f1, struct frame *f2,
+ bool above_flag)
+{
+ android_window window1;
+ struct android_window_changes wc;
+ unsigned long mask;
+
+ window1 = FRAME_ANDROID_WINDOW (f1);
+ wc.sibling = FRAME_ANDROID_WINDOW (f2);
+ wc.stack_mode = above_flag ? ANDROID_ABOVE : ANDROID_BELOW;
+ mask = ANDROID_CW_SIBLING | ANDROID_CW_STACK_MODE;
+
+ block_input ();
+ android_reconfigure_wm_window (window1, mask, &wc);
+ unblock_input ();
+}
+
+#endif /* !ANDROID_STUBIFY */
+
+DEFUN ("android-frame-restack", Fandroid_frame_restack,
+ Sandroid_frame_restack, 2, 3, 0,
+ doc: /* Restack FRAME1 below FRAME2.
+This means that if both frames are visible and the display areas of
+these frames overlap, FRAME2 (partially) obscures FRAME1. If optional
+third argument ABOVE is non-nil, restack FRAME1 above FRAME2. This
+means that if both frames are visible and the display areas of these
+frames overlap, FRAME1 (partially) obscures FRAME2.
+
+This may be thought of as an atomic action performed in two steps: The
+first step removes FRAME1's window-step window from the display. The
+second step reinserts FRAME1's window below (above if ABOVE is true)
+that of FRAME2. Hence the position of FRAME2 in its display's Z
+\(stacking) order relative to all other frames excluding FRAME1 remains
+unaltered.
+
+Android does not facilitate restacking top-level windows managed by
+its own window manager; nor is it possible to restack frames that are
+children of different parents. Consequently, this function only
+functions when FRAME1 and FRAME2 are both child frames subordinate to
+the same parent frame. */)
+ (Lisp_Object frame1, Lisp_Object frame2, Lisp_Object above)
+{
+#ifdef ANDROID_STUBIFY
+ error ("Android cross-compilation stub called!");
+ return Qnil;
+#else /* !ANDROID_STUBIFY */
+ struct frame *f1 = decode_live_frame (frame1);
+ struct frame *f2 = decode_live_frame (frame2);
+
+ if (!(FRAME_ANDROID_WINDOW (f1) && FRAME_ANDROID_WINDOW (f2)))
+ error ("Cannot restack frames");
+ android_frame_restack (f1, f2, !NILP (above));
+ return Qt;
+#endif /* ANDROID_STUBIFY */
+}
+
+DEFUN ("android-mouse-absolute-pixel-position",
+ Fandroid_mouse_absolute_pixel_position,
+ Sandroid_mouse_absolute_pixel_position, 0, 0, 0,
+ doc: /* Return absolute position of mouse cursor in pixels.
+The position is returned as a cons cell (X . Y) of the coordinates of
+the mouse cursor position in pixels relative to a position (0, 0) of the
+selected frame's display. This does not work on Android. */)
+ (void)
+{
+ /* This cannot be implemented on Android. */
+ return Qnil;
+}
+
+DEFUN ("android-set-mouse-absolute-pixel-position",
+ Fandroid_set_mouse_absolute_pixel_position,
+ Sandroid_set_mouse_absolute_pixel_position, 2, 2, 0,
+ doc: /* Move mouse pointer to a pixel position at (X, Y). The
+coordinates X and Y are interpreted to start from the top-left corner
+of the screen. This does not work on Android. */)
+ (Lisp_Object x, Lisp_Object y)
+{
+ /* This cannot be implemented on Android. */
+ return Qnil;
+}
+
+DEFUN ("android-get-connection", Fandroid_get_connection,
+ Sandroid_get_connection, 0, 0, 0,
+ doc: /* Get the connection to the display server.
+Return the terminal if it exists, else nil.
+
+Emacs cannot open a connection to the display server itself under
+Android, so there is no equivalent of `x-open-connection'. */)
+ (void)
+{
+#ifdef ANDROID_STUBIFY
+ error ("Android cross-compilation stub called!");
+ return Qnil;
+#else
+ Lisp_Object terminal;
+
+ terminal = Qnil;
+
+ if (x_display_list)
+ XSETTERMINAL (terminal, x_display_list->terminal);
+
+ return terminal;
+#endif
+}
+
+DEFUN ("x-display-list", Fx_display_list, Sx_display_list, 0, 0, 0,
+ doc: /* SKIP: real doc in xfns.c. */)
+ (void)
+{
+ Lisp_Object result;
+
+ result = Qnil;
+
+ if (x_display_list)
+ result = Fcons (XCAR (x_display_list->name_list_element),
+ result);
+
+ return result;
+}
+
+#ifndef ANDROID_STUBIFY
+
+static void
+unwind_create_tip_frame (Lisp_Object frame)
+{
+ Lisp_Object deleted;
+
+ deleted = unwind_create_frame (frame);
+ if (EQ (deleted, Qt))
+ {
+ tip_window = ANDROID_NONE;
+ tip_frame = Qnil;
+ }
+}
+
+static Lisp_Object
+android_create_tip_frame (struct android_display_info *dpyinfo,
+ Lisp_Object parms)
+{
+ struct frame *f;
+ Lisp_Object frame;
+ Lisp_Object name;
+ specpdl_ref count = SPECPDL_INDEX ();
+ bool face_change_before = face_change;
+
+ if (!dpyinfo->terminal->name)
+ error ("Terminal is not live, can't create new frames on it");
+
+ parms = Fcopy_alist (parms);
+
+ /* Get the name of the frame to use for resource lookup. */
+ name = gui_display_get_arg (dpyinfo, parms, Qname, "name", "Name",
+ RES_TYPE_STRING);
+ if (!STRINGP (name)
+ && !BASE_EQ (name, Qunbound)
+ && !NILP (name))
+ error ("Invalid frame name--not a string or nil");
+
+ frame = Qnil;
+ f = make_frame (false);
+ f->wants_modeline = false;
+ XSETFRAME (frame, f);
+ record_unwind_protect (unwind_create_tip_frame, frame);
+
+ f->terminal = dpyinfo->terminal;
+
+ /* By setting the output method, we're essentially saying that
+ the frame is live, as per FRAME_LIVE_P. If we get a signal
+ from this point on, x_destroy_window might screw up reference
+ counts etc. */
+ f->output_method = output_android;
+ f->output_data.android = xzalloc (sizeof *f->output_data.android);
+ FRAME_FONTSET (f) = -1;
+ f->output_data.android->white_relief.pixel = -1;
+ f->output_data.android->black_relief.pixel = -1;
+
+ f->tooltip = true;
+ fset_icon_name (f, Qnil);
+ FRAME_DISPLAY_INFO (f) = dpyinfo;
+ f->output_data.android->parent_desc = FRAME_DISPLAY_INFO (f)->root_window;
+
+ /* These colors will be set anyway later, but it's important
+ to get the color reference counts right, so initialize them! */
+ {
+ Lisp_Object black;
+
+ /* Function android_decode_color can signal an error. Make sure
+ to initialize color slots so that we won't try to free colors
+ we haven't allocated. */
+ FRAME_FOREGROUND_PIXEL (f) = -1;
+ FRAME_BACKGROUND_PIXEL (f) = -1;
+ f->output_data.android->cursor_pixel = -1;
+ f->output_data.android->cursor_foreground_pixel = -1;
+ f->output_data.android->mouse_pixel = -1;
+
+ black = build_string ("black");
+ FRAME_FOREGROUND_PIXEL (f)
+ = android_decode_color (f, black, BLACK_PIX_DEFAULT (f));
+ FRAME_BACKGROUND_PIXEL (f)
+ = android_decode_color (f, black, BLACK_PIX_DEFAULT (f));
+ f->output_data.android->cursor_pixel
+ = android_decode_color (f, black, BLACK_PIX_DEFAULT (f));
+ f->output_data.android->cursor_foreground_pixel
+ = android_decode_color (f, black, BLACK_PIX_DEFAULT (f));
+ f->output_data.android->mouse_pixel
+ = android_decode_color (f, black, BLACK_PIX_DEFAULT (f));
+ }
+
+ /* Set the name; the functions to which we pass f expect the name to
+ be set. */
+ if (BASE_EQ (name, Qunbound) || NILP (name))
+ f->explicit_name = false;
+ else
+ {
+ fset_name (f, name);
+ f->explicit_name = true;
+ /* use the frame's title when getting resources for this frame. */
+ specbind (Qx_resource_name, name);
+ }
+
+ register_font_driver (&androidfont_driver, f);
+ register_font_driver (&android_sfntfont_driver, f);
+
+ image_cache_refcount
+ = FRAME_IMAGE_CACHE (f) ? FRAME_IMAGE_CACHE (f)->refcount : 0;
+
+ gui_default_parameter (f, parms, Qfont_backend, Qnil,
+ "fontBackend", "FontBackend", RES_TYPE_STRING);
+
+ /* Extract the window parameters from the supplied values that are
+ needed to determine window geometry. */
+ android_default_font_parameter (f, parms);
+
+ gui_default_parameter (f, parms, Qborder_width, make_fixnum (0),
+ "borderWidth", "BorderWidth", RES_TYPE_NUMBER);
+
+ /* This defaults to 1 in order to match xterm. We recognize either
+ internalBorderWidth or internalBorder (which is what xterm calls
+ it). */
+ if (NILP (Fassq (Qinternal_border_width, parms)))
+ {
+ Lisp_Object value;
+
+ value = gui_display_get_arg (dpyinfo, parms, Qinternal_border_width,
+ "internalBorder", "internalBorder",
+ RES_TYPE_NUMBER);
+ if (! BASE_EQ (value, Qunbound))
+ parms = Fcons (Fcons (Qinternal_border_width, value),
+ parms);
+ }
+
+ gui_default_parameter (f, parms, Qinternal_border_width, make_fixnum (1),
+ "internalBorderWidth", "internalBorderWidth",
+ RES_TYPE_NUMBER);
+ gui_default_parameter (f, parms, Qright_divider_width, make_fixnum (0),
+ NULL, NULL, RES_TYPE_NUMBER);
+ gui_default_parameter (f, parms, Qbottom_divider_width, make_fixnum (0),
+ NULL, NULL, RES_TYPE_NUMBER);
+
+ /* Also do the stuff which must be set before the window exists. */
+ gui_default_parameter (f, parms, Qforeground_color, build_string ("black"),
+ "foreground", "Foreground", RES_TYPE_STRING);
+ gui_default_parameter (f, parms, Qbackground_color, build_string ("white"),
+ "background", "Background", RES_TYPE_STRING);
+ gui_default_parameter (f, parms, Qmouse_color, build_string ("black"),
+ "pointerColor", "Foreground", RES_TYPE_STRING);
+ gui_default_parameter (f, parms, Qcursor_color, build_string ("black"),
+ "cursorColor", "Foreground", RES_TYPE_STRING);
+ gui_default_parameter (f, parms, Qborder_color, build_string ("black"),
+ "borderColor", "BorderColor", RES_TYPE_STRING);
+ gui_default_parameter (f, parms, Qno_special_glyphs, Qnil,
+ NULL, NULL, RES_TYPE_BOOLEAN);
+
+ {
+ struct android_set_window_attributes attrs;
+ unsigned long mask;
+
+ block_input ();
+ mask = ANDROID_CW_OVERRIDE_REDIRECT | ANDROID_CW_BACK_PIXEL;
+
+ attrs.override_redirect = true;
+ attrs.background_pixel = FRAME_BACKGROUND_PIXEL (f);
+ tip_window
+ = FRAME_ANDROID_WINDOW (f)
+ = android_create_window (FRAME_DISPLAY_INFO (f)->root_window,
+ /* x, y, width, height, value-mask,
+ attrs. */
+ 0, 0, 1, 1, mask, &attrs);
+ unblock_input ();
+ }
+
+ /* Init faces before gui_default_parameter is called for the
+ scroll-bar-width parameter because otherwise we end up in
+ init_iterator with a null face cache, which should not happen. */
+ init_frame_faces (f);
+
+ gui_default_parameter (f, parms, Qinhibit_double_buffering, Qnil,
+ "inhibitDoubleBuffering", "InhibitDoubleBuffering",
+ RES_TYPE_BOOLEAN);
+
+ gui_figure_window_size (f, parms, false, false);
+
+ f->output_data.android->parent_desc = FRAME_DISPLAY_INFO (f)->root_window;
+
+ android_make_gc (f);
+
+ gui_default_parameter (f, parms, Qauto_raise, Qnil,
+ "autoRaise", "AutoRaiseLower", RES_TYPE_BOOLEAN);
+ gui_default_parameter (f, parms, Qauto_lower, Qnil,
+ "autoLower", "AutoRaiseLower", RES_TYPE_BOOLEAN);
+ gui_default_parameter (f, parms, Qcursor_type, Qbox,
+ "cursorType", "CursorType", RES_TYPE_SYMBOL);
+ gui_default_parameter (f, parms, Qalpha, Qnil,
+ "alpha", "Alpha", RES_TYPE_NUMBER);
+ gui_default_parameter (f, parms, Qalpha_background, Qnil,
+ "alphaBackground", "AlphaBackground", RES_TYPE_NUMBER);
+
+ /* Add `tooltip' frame parameter's default value. */
+ if (NILP (Fframe_parameter (frame, Qtooltip)))
+ {
+ AUTO_FRAME_ARG (arg, Qtooltip, Qt);
+ Fmodify_frame_parameters (frame, arg);
+ }
+
+ /* FIXME - can this be done in a similar way to normal frames?
+ https://lists.gnu.org/r/emacs-devel/2007-10/msg00641.html */
+
+ /* Set the `display-type' frame parameter before setting up faces. */
+ {
+ Lisp_Object disptype;
+
+ disptype = Qcolor;
+
+ if (NILP (Fframe_parameter (frame, Qdisplay_type)))
+ {
+ AUTO_FRAME_ARG (arg, Qdisplay_type, disptype);
+ Fmodify_frame_parameters (frame, arg);
+ }
+ }
+
+ /* Set up faces after all frame parameters are known. This call
+ also merges in face attributes specified for new frames. */
+ {
+ Lisp_Object bg = Fframe_parameter (frame, Qbackground_color);
+
+ call2 (Qface_set_after_frame_default, frame, Qnil);
+
+ if (!EQ (bg, Fframe_parameter (frame, Qbackground_color)))
+ {
+ AUTO_FRAME_ARG (arg, Qbackground_color, bg);
+ Fmodify_frame_parameters (frame, arg);
+ }
+ }
+
+ f->no_split = true;
+
+ /* Now that the frame will be official, it counts as a reference to
+ its display and terminal. */
+ f->terminal->reference_count++;
+
+ /* It is now ok to make the frame official even if we get an error
+ below. And the frame needs to be on Vframe_list or making it
+ visible won't work. */
+ Vframe_list = Fcons (frame, Vframe_list);
+ f->can_set_window_size = true;
+ adjust_frame_size (f, FRAME_TEXT_WIDTH (f), FRAME_TEXT_HEIGHT (f),
+ 0, true, Qtip_frame);
+
+ /* Setting attributes of faces of the tooltip frame from resources
+ and similar will set face_change, which leads to the clearing of
+ all current matrices. Since this isn't necessary here, avoid it
+ by resetting face_change to the value it had before we created
+ the tip frame. */
+ face_change = face_change_before;
+
+ /* Discard the unwind_protect. */
+ return unbind_to (count, frame);
+}
+
+static Lisp_Object
+android_hide_tip (bool delete)
+{
+ if (!NILP (tip_timer))
+ {
+ call1 (Qcancel_timer, tip_timer);
+ tip_timer = Qnil;
+ }
+
+ if (NILP (tip_frame)
+ || (!delete
+ && !NILP (tip_frame)
+ && FRAME_LIVE_P (XFRAME (tip_frame))
+ && !FRAME_VISIBLE_P (XFRAME (tip_frame))))
+ return Qnil;
+ else
+ {
+ Lisp_Object was_open = Qnil;
+
+ specpdl_ref count = SPECPDL_INDEX ();
+ specbind (Qinhibit_redisplay, Qt);
+ specbind (Qinhibit_quit, Qt);
+
+ if (!NILP (tip_frame))
+ {
+ struct frame *f = XFRAME (tip_frame);
+
+ if (FRAME_LIVE_P (f))
+ {
+ if (delete)
+ {
+ delete_frame (tip_frame, Qnil);
+ tip_frame = Qnil;
+ }
+ else
+ android_make_frame_invisible (XFRAME (tip_frame));
+
+ was_open = Qt;
+ }
+ else
+ tip_frame = Qnil;
+ }
+ else
+ tip_frame = Qnil;
+
+ return unbind_to (count, was_open);
+ }
+}
+
+static void
+compute_tip_xy (struct frame *f, Lisp_Object parms, Lisp_Object dx,
+ Lisp_Object dy, int width, int height, int *root_x,
+ int *root_y)
+{
+ Lisp_Object left, top, right, bottom;
+ int min_x, min_y, max_x, max_y = -1;
+ android_window window;
+ struct frame *mouse_frame;
+
+ /* Initialize these values in case there is no mouse frame. */
+ *root_x = 0;
+ *root_y = 0;
+
+ /* User-specified position? */
+ left = CDR (Fassq (Qleft, parms));
+ top = CDR (Fassq (Qtop, parms));
+ right = CDR (Fassq (Qright, parms));
+ bottom = CDR (Fassq (Qbottom, parms));
+
+ /* Move the tooltip window where the mouse pointer was last seen.
+ Resize and show it. */
+ if ((!FIXNUMP (left) && !FIXNUMP (right))
+ || (!FIXNUMP (top) && !FIXNUMP (bottom)))
+ {
+ if (x_display_list->last_mouse_motion_frame)
+ {
+ *root_x = x_display_list->last_mouse_motion_x;
+ *root_y = x_display_list->last_mouse_motion_y;
+ mouse_frame = x_display_list->last_mouse_motion_frame;
+ window = FRAME_ANDROID_WINDOW (mouse_frame);
+
+ /* Translate the coordinates to the screen. */
+ android_translate_coordinates (window, *root_x, *root_y,
+ root_x, root_y);
+ }
+ }
+
+ min_x = 0;
+ min_y = 0;
+ max_x = android_get_screen_width ();
+ max_y = android_get_screen_height ();
+
+ if (FIXNUMP (top))
+ *root_y = XFIXNUM (top);
+ else if (FIXNUMP (bottom))
+ *root_y = XFIXNUM (bottom) - height;
+ else if (*root_y + XFIXNUM (dy) <= min_y)
+ *root_y = min_y; /* Can happen for negative dy */
+ else if (*root_y + XFIXNUM (dy) + height <= max_y)
+ /* It fits below the pointer */
+ *root_y += XFIXNUM (dy);
+ else if (height + XFIXNUM (dy) + min_y <= *root_y)
+ /* It fits above the pointer. */
+ *root_y -= height + XFIXNUM (dy);
+ else
+ /* Put it on the top. */
+ *root_y = min_y;
+
+ if (FIXNUMP (left))
+ *root_x = XFIXNUM (left);
+ else if (FIXNUMP (right))
+ *root_x = XFIXNUM (right) - width;
+ else if (*root_x + XFIXNUM (dx) <= min_x)
+ *root_x = 0; /* Can happen for negative dx */
+ else if (*root_x + XFIXNUM (dx) + width <= max_x)
+ /* It fits to the right of the pointer. */
+ *root_x += XFIXNUM (dx);
+ else if (width + XFIXNUM (dx) + min_x <= *root_x)
+ /* It fits to the left of the pointer. */
+ *root_x -= width + XFIXNUM (dx);
+ else
+ /* Put it left justified on the screen -- it ought to fit that way. */
+ *root_x = min_x;
+}
+
+#endif
+
+DEFUN ("x-show-tip", Fx_show_tip, Sx_show_tip, 1, 6, 0,
+ doc: /* SKIP: real doc in xfns.c. */)
+ (Lisp_Object string, Lisp_Object frame, Lisp_Object parms,
+ Lisp_Object timeout, Lisp_Object dx, Lisp_Object dy)
+{
+#ifdef ANDROID_STUBIFY
+ error ("Android cross-compilation stub called!");
+ return Qnil;
+#else
+ struct frame *f, *tip_f;
+ struct window *w;
+ int root_x, root_y;
+ struct buffer *old_buffer;
+ struct text_pos pos;
+ int width, height;
+ int old_windows_or_buffers_changed = windows_or_buffers_changed;
+ specpdl_ref count = SPECPDL_INDEX ();
+ Lisp_Object window, size, tip_buf;
+ bool displayed;
+#ifdef ENABLE_CHECKING
+ struct glyph_row *row, *end;
+#endif
+ AUTO_STRING (tip, " *tip*");
+
+ specbind (Qinhibit_redisplay, Qt);
+
+ CHECK_STRING (string);
+ if (SCHARS (string) == 0)
+ string = make_unibyte_string (" ", 1);
+
+ if (NILP (frame))
+ frame = selected_frame;
+ f = decode_window_system_frame (frame);
+
+ if (NILP (timeout))
+ timeout = Vx_show_tooltip_timeout;
+ CHECK_FIXNAT (timeout);
+
+ if (NILP (dx))
+ dx = make_fixnum (5);
+ else
+ CHECK_FIXNUM (dx);
+
+ if (NILP (dy))
+ dy = make_fixnum (-10);
+ else
+ CHECK_FIXNUM (dy);
+
+ tip_dx = dx;
+ tip_dy = dy;
+
+ if (!NILP (tip_frame) && FRAME_LIVE_P (XFRAME (tip_frame)))
+ {
+ if (FRAME_VISIBLE_P (XFRAME (tip_frame))
+ && !NILP (Fequal_including_properties (tip_last_string,
+ string))
+ && !NILP (Fequal (tip_last_parms, parms)))
+ {
+ /* Only DX and DY have changed. */
+ tip_f = XFRAME (tip_frame);
+ if (!NILP (tip_timer))
+ {
+ call1 (Qcancel_timer, tip_timer);
+ tip_timer = Qnil;
+ }
+
+ block_input ();
+ compute_tip_xy (tip_f, parms, dx, dy, FRAME_PIXEL_WIDTH (tip_f),
+ FRAME_PIXEL_HEIGHT (tip_f), &root_x, &root_y);
+ android_move_window (FRAME_ANDROID_WINDOW (tip_f),
+ root_x, root_y);
+ unblock_input ();
+
+ goto start_timer;
+ }
+ else if (tooltip_reuse_hidden_frame && BASE_EQ (frame, tip_last_frame))
+ {
+ bool delete = false;
+ Lisp_Object tail, elt, parm, last;
+
+ /* Check if every parameter in PARMS has the same value in
+ tip_last_parms. This may destruct tip_last_parms which,
+ however, will be recreated below. */
+ for (tail = parms; CONSP (tail); tail = XCDR (tail))
+ {
+ elt = XCAR (tail);
+ parm = CAR (elt);
+ /* The left, top, right and bottom parameters are handled
+ by compute_tip_xy so they can be ignored here. */
+ if (!EQ (parm, Qleft) && !EQ (parm, Qtop)
+ && !EQ (parm, Qright) && !EQ (parm, Qbottom))
+ {
+ last = Fassq (parm, tip_last_parms);
+ if (NILP (Fequal (CDR (elt), CDR (last))))
+ {
+ /* We lost, delete the old tooltip. */
+ delete = true;
+ break;
+ }
+ else
+ tip_last_parms
+ = call2 (Qassq_delete_all, parm, tip_last_parms);
+ }
+ else
+ tip_last_parms
+ = call2 (Qassq_delete_all, parm, tip_last_parms);
+ }
+
+ /* Now check if every parameter in what is left of
+ tip_last_parms with a non-nil value has an association in
+ PARMS. */
+ for (tail = tip_last_parms; CONSP (tail); tail = XCDR (tail))
+ {
+ elt = XCAR (tail);
+ parm = CAR (elt);
+ if (!EQ (parm, Qleft) && !EQ (parm, Qtop) && !EQ (parm, Qright)
+ && !EQ (parm, Qbottom) && !NILP (CDR (elt)))
+ {
+ /* We lost, delete the old tooltip. */
+ delete = true;
+ break;
+ }
+ }
+
+ android_hide_tip (delete);
+ }
+ else
+ android_hide_tip (true);
+ }
+ else
+ android_hide_tip (true);
+
+ tip_last_frame = frame;
+ tip_last_string = string;
+ tip_last_parms = parms;
+
+ if (NILP (tip_frame) || !FRAME_LIVE_P (XFRAME (tip_frame)))
+ {
+ /* Add default values to frame parameters. */
+ if (NILP (Fassq (Qname, parms)))
+ parms = Fcons (Fcons (Qname, build_string ("tooltip")), parms);
+ if (NILP (Fassq (Qinternal_border_width, parms)))
+ parms = Fcons (Fcons (Qinternal_border_width, make_fixnum (3)),
+ parms);
+ if (NILP (Fassq (Qborder_width, parms)))
+ parms = Fcons (Fcons (Qborder_width, make_fixnum (1)), parms);
+ if (NILP (Fassq (Qborder_color, parms)))
+ parms = Fcons (Fcons (Qborder_color, build_string ("lightyellow")),
+ parms);
+ if (NILP (Fassq (Qbackground_color, parms)))
+ parms = Fcons (Fcons (Qbackground_color,
+ build_string ("lightyellow")),
+ parms);
+
+ /* Create a frame for the tooltip, and record it in the global
+ variable tip_frame. */
+ if (NILP (tip_frame = android_create_tip_frame (FRAME_DISPLAY_INFO (f),
+ parms)))
+ /* Creating the tip frame failed. */
+ return unbind_to (count, Qnil);
+ }
+
+ tip_f = XFRAME (tip_frame);
+ window = FRAME_ROOT_WINDOW (tip_f);
+ tip_buf = Fget_buffer_create (tip, Qnil);
+ /* We will mark the tip window a "pseudo-window" below, and such
+ windows cannot have display margins. */
+ bset_left_margin_cols (XBUFFER (tip_buf), make_fixnum (0));
+ bset_right_margin_cols (XBUFFER (tip_buf), make_fixnum (0));
+ set_window_buffer (window, tip_buf, false, false);
+ w = XWINDOW (window);
+ w->pseudo_window_p = true;
+ /* Try to avoid that `other-window' select us (Bug#47207). */
+ Fset_window_parameter (window, Qno_other_window, Qt);
+
+ /* Set up the frame's root window. Note: The following code does not
+ try to size the window or its frame correctly. Its only purpose is
+ to make the subsequent text size calculations work. The right
+ sizes should get installed when the toolkit gets back to us. */
+ w->left_col = 0;
+ w->top_line = 0;
+ w->pixel_left = 0;
+ w->pixel_top = 0;
+
+ if (CONSP (Vx_max_tooltip_size)
+ && RANGED_FIXNUMP (1, XCAR (Vx_max_tooltip_size), INT_MAX)
+ && RANGED_FIXNUMP (1, XCDR (Vx_max_tooltip_size), INT_MAX))
+ {
+ w->total_cols = XFIXNAT (XCAR (Vx_max_tooltip_size));
+ w->total_lines = XFIXNAT (XCDR (Vx_max_tooltip_size));
+ }
+ else
+ {
+ w->total_cols = 80;
+ w->total_lines = 40;
+ }
+
+ w->pixel_width = w->total_cols * FRAME_COLUMN_WIDTH (tip_f);
+ w->pixel_height = w->total_lines * FRAME_LINE_HEIGHT (tip_f);
+ FRAME_TOTAL_COLS (tip_f) = w->total_cols;
+ adjust_frame_glyphs (tip_f);
+
+ /* Insert STRING into root window's buffer and fit the frame to the
+ buffer. */
+ specpdl_ref count_1 = SPECPDL_INDEX ();
+ old_buffer = current_buffer;
+ set_buffer_internal_1 (XBUFFER (w->contents));
+ bset_truncate_lines (current_buffer, Qnil);
+ specbind (Qinhibit_read_only, Qt);
+ specbind (Qinhibit_modification_hooks, Qt);
+ specbind (Qinhibit_point_motion_hooks, Qt);
+ Ferase_buffer ();
+ Finsert (1, &string);
+ clear_glyph_matrix (w->desired_matrix);
+ clear_glyph_matrix (w->current_matrix);
+ SET_TEXT_POS (pos, BEGV, BEGV_BYTE);
+ displayed = try_window (window, pos, TRY_WINDOW_IGNORE_FONTS_CHANGE);
+
+ if (!displayed && NILP (Vx_max_tooltip_size))
+ {
+#ifdef ENABLE_CHECKING
+ row = w->desired_matrix->rows;
+ end = w->desired_matrix->rows + w->desired_matrix->nrows;
+
+ while (row < end)
+ {
+ if (!row->displays_text_p
+ || row->ends_at_zv_p)
+ break;
+ ++row;
+ }
+
+ eassert (row < end && row->ends_at_zv_p);
+#endif
+ }
+
+ /* Calculate size of tooltip window. */
+ size = Fwindow_text_pixel_size (window, Qnil, Qnil, Qnil,
+ make_fixnum (w->pixel_height), Qnil,
+ Qnil);
+ /* Add the frame's internal border to calculated size. */
+ width = XFIXNUM (CAR (size)) + 2 * FRAME_INTERNAL_BORDER_WIDTH (tip_f);
+ height = XFIXNUM (CDR (size)) + 2 * FRAME_INTERNAL_BORDER_WIDTH (tip_f);
+
+ /* Calculate position of tooltip frame. */
+ compute_tip_xy (tip_f, parms, dx, dy, width, height, &root_x, &root_y);
+
+ /* Show tooltip frame. */
+ block_input ();
+ android_move_resize_window (FRAME_ANDROID_WINDOW (tip_f),
+ root_x, root_y, width,
+ height);
+ android_map_raised (FRAME_ANDROID_WINDOW (tip_f));
+ unblock_input ();
+
+ /* Garbage the tip frame too. */
+ SET_FRAME_GARBAGED (tip_f);
+
+ w->must_be_updated_p = true;
+ update_single_window (w);
+ flush_frame (tip_f);
+ set_buffer_internal_1 (old_buffer);
+ unbind_to (count_1, Qnil);
+ windows_or_buffers_changed = old_windows_or_buffers_changed;
+
+ /* MapNotify events are not sent on Android, so make the frame
+ visible. */
+
+ SET_FRAME_VISIBLE (tip_f, true);
+
+ start_timer:
+ /* Let the tip disappear after timeout seconds. */
+ tip_timer = call3 (Qrun_at_time, timeout, Qnil,
+ Qx_hide_tip);
+
+ return unbind_to (count, Qnil);
+#endif
+}
+
+DEFUN ("x-hide-tip", Fx_hide_tip, Sx_hide_tip, 0, 0, 0,
+ doc: /* SKIP: real doc in xfns.c. */)
+ (void)
+{
+#ifdef ANDROID_STUBIFY
+ /* Fx_hide_tip is called from pre-command-hook (in turn called from
+ the tests.) Since signaling here prevents any tests from being
+ run, refrain from protesting if this stub is called. */
+#if 0
+ error ("Android cross-compilation stub called!");
+#endif /* 0 */
+ return Qnil;
+#else /* !ANDROID_STUBIFY */
+ return android_hide_tip (!tooltip_reuse_hidden_frame);
+#endif /* ANDROID_STUBIFY */
+}
+
+DEFUN ("android-detect-mouse", Fandroid_detect_mouse,
+ Sandroid_detect_mouse, 0, 0, 0,
+ doc: /* Figure out whether or not there is a mouse.
+Return non-nil if a mouse is connected to this computer, and nil if
+there is no mouse. */)
+ (void)
+{
+#ifndef ANDROID_STUBIFY
+ /* If no display connection is present, just return nil. */
+
+ if (!android_init_gui)
+ return Qnil;
+
+ return android_detect_mouse () ? Qt : Qnil;
+#else
+ return Qnil;
+#endif
+}
+
+DEFUN ("android-detect-keyboard", Fandroid_detect_keyboard,
+ Sandroid_detect_keyboard, 0, 0, 0,
+ doc: /* Return whether a keyboard is connected.
+Return non-nil if a key is connected to this computer, or nil
+if there is no keyboard. */)
+ (void)
+{
+#ifndef ANDROID_STUBIFY
+ /* If no display connection is present, just return nil. */
+
+ if (!android_init_gui)
+ return Qnil;
+
+ return android_detect_keyboard () ? Qt : Qnil;
+#else /* ANDROID_STUBIFY */
+ return Qt;
+#endif /* ANDROID_STUBIFY */
+}
+
+DEFUN ("android-toggle-on-screen-keyboard",
+ Fandroid_toggle_on_screen_keyboard,
+ Sandroid_toggle_on_screen_keyboard, 2, 2, 0,
+ doc: /* Display or hide the on-screen keyboard.
+If HIDE is non-nil, hide the on screen keyboard if it is currently
+being displayed. Else, request that the system display it on behalf
+of FRAME. This request may be rejected if FRAME does not have the
+input focus. */)
+ (Lisp_Object frame, Lisp_Object hide)
+{
+#ifndef ANDROID_STUBIFY
+ struct frame *f;
+
+ f = decode_window_system_frame (frame);
+
+ block_input ();
+ android_toggle_on_screen_keyboard (FRAME_ANDROID_WINDOW (f),
+ NILP (hide));
+ unblock_input ();
+#endif
+
+ return Qnil;
+}
+
+
+
+#ifndef ANDROID_STUBIFY
+
+static void
+android_set_background_color (struct frame *f, Lisp_Object arg,
+ Lisp_Object oldval)
+{
+ struct android_output *x;
+ unsigned long bg;
+
+ x = f->output_data.android;
+ bg = android_decode_color (f, arg, WHITE_PIX_DEFAULT (f));
+ FRAME_BACKGROUND_PIXEL (f) = bg;
+
+ if (FRAME_ANDROID_WINDOW (f) != 0)
+ {
+ block_input ();
+ android_set_background (x->normal_gc, bg);
+ android_set_foreground (x->reverse_gc, bg);
+ android_set_window_background (FRAME_ANDROID_WINDOW (f), bg);
+ android_set_foreground (x->cursor_gc, bg);
+ unblock_input ();
+
+ update_face_from_frame_parameter (f, Qbackground_color, arg);
+
+ if (FRAME_VISIBLE_P (f))
+ redraw_frame (f);
+ }
+}
+
+static void
+android_set_border_color (struct frame *f, Lisp_Object arg,
+ Lisp_Object oldval)
+{
+ /* Left unimplemented because Android has no window borders. */
+ CHECK_STRING (arg);
+ android_decode_color (f, arg, BLACK_PIX_DEFAULT (f));
+ update_face_from_frame_parameter (f, Qborder_color, arg);
+}
+
+static void
+android_set_cursor_color (struct frame *f, Lisp_Object arg,
+ Lisp_Object oldval)
+{
+ unsigned long fore_pixel, pixel;
+ struct android_output *x;
+
+ x = f->output_data.android;
+
+ if (!NILP (Vx_cursor_fore_pixel))
+ fore_pixel = android_decode_color (f, Vx_cursor_fore_pixel,
+ WHITE_PIX_DEFAULT (f));
+ else
+ fore_pixel = FRAME_BACKGROUND_PIXEL (f);
+
+ pixel = android_decode_color (f, arg, BLACK_PIX_DEFAULT (f));
+
+ /* Make sure that the cursor color differs from the background color. */
+ if (pixel == FRAME_BACKGROUND_PIXEL (f))
+ {
+ pixel = FRAME_FOREGROUND_PIXEL (f);
+ if (pixel == fore_pixel)
+ fore_pixel = FRAME_BACKGROUND_PIXEL (f);
+ }
+
+ x->cursor_foreground_pixel = fore_pixel;
+ x->cursor_pixel = pixel;
+
+ if (FRAME_ANDROID_WINDOW (f) != 0)
+ {
+ block_input ();
+ android_set_background (x->cursor_gc, x->cursor_pixel);
+ android_set_foreground (x->cursor_gc, fore_pixel);
+ unblock_input ();
+
+ if (FRAME_VISIBLE_P (f))
+ {
+ gui_update_cursor (f, false);
+ gui_update_cursor (f, true);
+ }
+ }
+
+ update_face_from_frame_parameter (f, Qcursor_color, arg);
+}
+
+static void
+android_set_cursor_type (struct frame *f, Lisp_Object arg,
+ Lisp_Object oldval)
+{
+ set_frame_cursor_types (f, arg);
+}
+
+static void
+android_set_foreground_color (struct frame *f, Lisp_Object arg,
+ Lisp_Object oldval)
+{
+ struct android_output *x;
+ unsigned long fg, old_fg;
+
+ x = f->output_data.android;
+
+ fg = android_decode_color (f, arg, BLACK_PIX_DEFAULT (f));
+ old_fg = FRAME_FOREGROUND_PIXEL (f);
+ FRAME_FOREGROUND_PIXEL (f) = fg;
+
+ if (FRAME_ANDROID_WINDOW (f) != 0)
+ {
+ block_input ();
+ android_set_foreground (x->normal_gc, fg);
+ android_set_background (x->reverse_gc, fg);
+
+ if (x->cursor_pixel == old_fg)
+ {
+ x->cursor_pixel = fg;
+ android_set_background (x->cursor_gc, x->cursor_pixel);
+ }
+
+ unblock_input ();
+
+ update_face_from_frame_parameter (f, Qforeground_color, arg);
+
+ if (FRAME_VISIBLE_P (f))
+ redraw_frame (f);
+ }
+}
+
+static void
+android_set_child_frame_border_width (struct frame *f, Lisp_Object arg,
+ Lisp_Object oldval)
+{
+ int border;
+
+ if (NILP (arg))
+ border = -1;
+ else if (RANGED_FIXNUMP (0, arg, INT_MAX))
+ border = XFIXNAT (arg);
+ else
+ signal_error ("Invalid child frame border width", arg);
+
+ if (border != FRAME_CHILD_FRAME_BORDER_WIDTH (f))
+ {
+ f->child_frame_border_width = border;
+
+ if (FRAME_ANDROID_WINDOW (f))
+ {
+ adjust_frame_size (f, -1, -1, 3, false, Qchild_frame_border_width);
+ android_clear_under_internal_border (f);
+ }
+ }
+}
+
+static void
+android_set_internal_border_width (struct frame *f, Lisp_Object arg,
+ Lisp_Object oldval)
+{
+ int border = check_int_nonnegative (arg);
+
+ if (border != FRAME_INTERNAL_BORDER_WIDTH (f))
+ {
+ f->internal_border_width = border;
+
+ if (FRAME_ANDROID_WINDOW (f))
+ {
+ adjust_frame_size (f, -1, -1, 3, false, Qinternal_border_width);
+ android_clear_under_internal_border (f);
+ }
+ }
+}
+
+static void
+android_set_menu_bar_lines (struct frame *f, Lisp_Object value,
+ Lisp_Object oldval)
+{
+ int nlines;
+ int olines = FRAME_MENU_BAR_LINES (f);
+
+ /* Right now, menu bars don't work properly in minibuf-only frames;
+ most of the commands try to apply themselves to the minibuffer
+ frame itself, and get an error because you can't switch buffers
+ in or split the minibuffer window. */
+ if (FRAME_MINIBUF_ONLY_P (f) || FRAME_PARENT_FRAME (f))
+ return;
+
+ if (TYPE_RANGED_FIXNUMP (int, value))
+ nlines = XFIXNUM (value);
+ else
+ nlines = 0;
+
+ /* Make sure we redisplay all windows in this frame. */
+ fset_redisplay (f);
+
+ FRAME_MENU_BAR_LINES (f) = nlines;
+ FRAME_MENU_BAR_HEIGHT (f) = nlines * FRAME_LINE_HEIGHT (f);
+ if (FRAME_ANDROID_WINDOW (f))
+ android_clear_under_internal_border (f);
+
+ /* If the menu bar height gets changed, the internal border below
+ the top margin has to be cleared. Also, if the menu bar gets
+ larger, the area for the added lines has to be cleared except for
+ the first menu bar line that is to be drawn later. */
+ if (nlines != olines)
+ {
+ int height = FRAME_INTERNAL_BORDER_WIDTH (f);
+ int width = FRAME_PIXEL_WIDTH (f);
+ int y;
+
+ adjust_frame_size (f, -1, -1, 3, true, Qmenu_bar_lines);
+
+ /* height can be zero here. */
+ if (FRAME_ANDROID_WINDOW (f) && height > 0 && width > 0)
+ {
+ y = FRAME_TOP_MARGIN_HEIGHT (f);
+
+ block_input ();
+ android_clear_area (FRAME_ANDROID_DRAWABLE (f),
+ 0, y, width, height);
+ unblock_input ();
+ }
+
+ if (nlines > 1 && nlines > olines)
+ {
+ y = (olines == 0 ? 1 : olines) * FRAME_LINE_HEIGHT (f);
+ height = nlines * FRAME_LINE_HEIGHT (f) - y;
+
+ block_input ();
+ android_clear_area (FRAME_ANDROID_DRAWABLE (f), 0, y,
+ width, height);
+ unblock_input ();
+ }
+
+ if (nlines == 0 && WINDOWP (f->menu_bar_window))
+ clear_glyph_matrix (XWINDOW (f->menu_bar_window)->current_matrix);
+ }
+
+ adjust_frame_glyphs (f);
+}
+
+
+
+/* These enums must stay in sync with the mouse_cursor_types array
+ below! */
+
+enum mouse_cursor
+ {
+ mouse_cursor_text,
+ mouse_cursor_nontext,
+ mouse_cursor_hourglass,
+ mouse_cursor_mode,
+ mouse_cursor_hand,
+ mouse_cursor_horizontal_drag,
+ mouse_cursor_vertical_drag,
+ mouse_cursor_left_edge,
+ mouse_cursor_top_left_corner,
+ mouse_cursor_top_edge,
+ mouse_cursor_top_right_corner,
+ mouse_cursor_right_edge,
+ mouse_cursor_bottom_right_corner,
+ mouse_cursor_bottom_edge,
+ mouse_cursor_bottom_left_corner,
+ mouse_cursor_max
+ };
+
+struct mouse_cursor_types
+{
+ /* Printable name for error messages (optional). */
+ const char *name;
+
+ /* Lisp variable controlling the cursor shape. */
+ /* FIXME: A couple of these variables are defined in the C code but
+ are not actually accessible from Lisp. They should probably be
+ made accessible or removed. */
+ Lisp_Object *shape_var_ptr;
+
+ /* The default shape. */
+ int default_shape;
+};
+
+/* This array must stay in sync with enum mouse_cursor above! */
+
+static const struct mouse_cursor_types mouse_cursor_types[] =
+ {
+ {"text", &Vx_pointer_shape, ANDROID_XC_XTERM, },
+ {"nontext", &Vx_nontext_pointer_shape, ANDROID_XC_LEFT_PTR, },
+ {"hourglass", &Vx_hourglass_pointer_shape, ANDROID_XC_WATCH, },
+ {"modeline", &Vx_mode_pointer_shape, ANDROID_XC_XTERM, },
+ {NULL, &Vx_sensitive_text_pointer_shape, ANDROID_XC_HAND2, },
+ {NULL, &Vx_window_horizontal_drag_shape, ANDROID_XC_SB_H_DOUBLE_ARROW, },
+ {NULL, &Vx_window_vertical_drag_shape, ANDROID_XC_SB_V_DOUBLE_ARROW, },
+ {NULL, &Vx_window_left_edge_shape, ANDROID_XC_LEFT_SIDE, },
+ {NULL, &Vx_window_top_left_corner_shape, ANDROID_XC_TOP_LEFT_CORNER, },
+ {NULL, &Vx_window_top_edge_shape, ANDROID_XC_TOP_SIDE, },
+ {NULL, &Vx_window_top_right_corner_shape, ANDROID_XC_TOP_RIGHT_CORNER, },
+ {NULL, &Vx_window_right_edge_shape, ANDROID_XC_RIGHT_SIDE, },
+ {NULL, &Vx_window_bottom_right_corner_shape,
+ ANDROID_XC_BOTTOM_RIGHT_CORNER, },
+ {NULL, &Vx_window_bottom_edge_shape, ANDROID_XC_BOTTOM_SIDE, },
+ {NULL, &Vx_window_bottom_left_corner_shape,
+ ANDROID_XC_BOTTOM_LEFT_CORNER, },
+ };
+
+struct mouse_cursor_data
+{
+ /* Cursor numbers chosen. */
+ unsigned int cursor_num[mouse_cursor_max];
+
+ /* Allocated Cursor values, or zero for failed attempts. */
+ android_cursor cursor[mouse_cursor_max];
+};
+
+
+
+static void
+android_set_mouse_color (struct frame *f, Lisp_Object arg,
+ Lisp_Object oldval)
+{
+ struct android_output *x = f->output_data.android;
+ struct mouse_cursor_data cursor_data = { -1, -1 };
+ unsigned long pixel = android_decode_color (f, arg, BLACK_PIX_DEFAULT (f));
+ unsigned long mask_color = FRAME_BACKGROUND_PIXEL (f);
+ int i;
+
+ /* Don't let pointers be invisible. */
+ if (mask_color == pixel)
+ pixel = FRAME_FOREGROUND_PIXEL (f);
+
+ x->mouse_pixel = pixel;
+
+ for (i = 0; i < mouse_cursor_max; i++)
+ {
+ Lisp_Object shape_var = *mouse_cursor_types[i].shape_var_ptr;
+ cursor_data.cursor_num[i]
+ = (!NILP (shape_var)
+ ? check_uinteger_max (shape_var, UINT_MAX)
+ : mouse_cursor_types[i].default_shape);
+ }
+
+ block_input ();
+
+ for (i = 0; i < mouse_cursor_max; i++)
+ cursor_data.cursor[i]
+ = android_create_font_cursor (cursor_data.cursor_num[i]);
+
+ if (FRAME_ANDROID_WINDOW (f))
+ {
+ f->output_data.android->current_cursor
+ = cursor_data.cursor[mouse_cursor_text];
+ android_define_cursor (FRAME_ANDROID_WINDOW (f),
+ f->output_data.android->current_cursor);
+ }
+
+#define INSTALL_CURSOR(FIELD, SHORT_INDEX) \
+ eassert (x->FIELD \
+ != cursor_data.cursor[mouse_cursor_ ## SHORT_INDEX]); \
+ if (x->FIELD != 0) \
+ android_free_cursor (x->FIELD); \
+ x->FIELD = cursor_data.cursor[mouse_cursor_ ## SHORT_INDEX];
+
+ INSTALL_CURSOR (text_cursor, text);
+ INSTALL_CURSOR (nontext_cursor, nontext);
+ INSTALL_CURSOR (hourglass_cursor, hourglass);
+ INSTALL_CURSOR (modeline_cursor, mode);
+ INSTALL_CURSOR (hand_cursor, hand);
+ INSTALL_CURSOR (horizontal_drag_cursor, horizontal_drag);
+ INSTALL_CURSOR (vertical_drag_cursor, vertical_drag);
+ INSTALL_CURSOR (left_edge_cursor, left_edge);
+ INSTALL_CURSOR (top_left_corner_cursor, top_left_corner);
+ INSTALL_CURSOR (top_edge_cursor, top_edge);
+ INSTALL_CURSOR (top_right_corner_cursor, top_right_corner);
+ INSTALL_CURSOR (right_edge_cursor, right_edge);
+ INSTALL_CURSOR (bottom_right_corner_cursor, bottom_right_corner);
+ INSTALL_CURSOR (bottom_edge_cursor, bottom_edge);
+ INSTALL_CURSOR (bottom_left_corner_cursor, bottom_left_corner);
+
+#undef INSTALL_CURSOR
+
+ unblock_input ();
+
+ update_face_from_frame_parameter (f, Qmouse_color, arg);
+}
+
+static void
+android_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))
+ return;
+
+ update_mode_lines = 38;
+
+ fset_title (f, name);
+
+ if (NILP (name))
+ name = f->name;
+ else
+ CHECK_STRING (name);
+}
+
+static void
+android_set_alpha (struct frame *f, Lisp_Object arg, Lisp_Object oldval)
+{
+ double alpha = 1.0;
+ double newval[2];
+ int i;
+ Lisp_Object item;
+
+ /* N.B. that setting the window alpha is actually unsupported under
+ Android. */
+
+ for (i = 0; i < 2; i++)
+ {
+ newval[i] = 1.0;
+ if (CONSP (arg))
+ {
+ item = CAR (arg);
+ arg = CDR (arg);
+ }
+ else
+ item = arg;
+
+ if (NILP (item))
+ alpha = - 1.0;
+ else if (FLOATP (item))
+ {
+ alpha = XFLOAT_DATA (item);
+ if (! (0 <= alpha && alpha <= 1.0))
+ args_out_of_range (make_float (0.0), make_float (1.0));
+ }
+ else if (FIXNUMP (item))
+ {
+ EMACS_INT ialpha = XFIXNUM (item);
+ if (! (0 <= ialpha && ialpha <= 100))
+ args_out_of_range (make_fixnum (0), make_fixnum (100));
+ alpha = ialpha / 100.0;
+ }
+ else
+ wrong_type_argument (Qnumberp, item);
+ newval[i] = alpha;
+ }
+
+ for (i = 0; i < 2; i++)
+ f->alpha[i] = newval[i];
+
+ if (FRAME_TERMINAL (f)->set_frame_alpha_hook)
+ {
+ block_input ();
+ FRAME_TERMINAL (f)->set_frame_alpha_hook (f);
+ unblock_input ();
+ }
+}
+
+static void
+android_set_no_focus_on_map (struct frame *f, Lisp_Object new_value,
+ Lisp_Object old_value)
+{
+ if (!EQ (new_value, old_value))
+ {
+ android_set_dont_focus_on_map (FRAME_ANDROID_WINDOW (f),
+ !NILP (new_value));
+ FRAME_NO_FOCUS_ON_MAP (f) = !NILP (new_value);
+ }
+}
+
+static void
+android_set_no_accept_focus (struct frame *f, Lisp_Object new_value,
+ Lisp_Object old_value)
+{
+ if (!EQ (new_value, old_value))
+ {
+ android_set_dont_accept_focus (FRAME_ANDROID_WINDOW (f),
+ !NILP (new_value));
+ FRAME_NO_ACCEPT_FOCUS (f) = !NILP (new_value);
+ }
+}
+
+frame_parm_handler android_frame_parm_handlers[] =
+{
+ gui_set_autoraise,
+ gui_set_autolower,
+ android_set_background_color,
+ android_set_border_color,
+ gui_set_border_width,
+ android_set_cursor_color,
+ android_set_cursor_type,
+ gui_set_font,
+ android_set_foreground_color,
+ NULL,
+ NULL,
+ android_set_child_frame_border_width,
+ android_set_internal_border_width,
+ gui_set_right_divider_width,
+ gui_set_bottom_divider_width,
+ android_set_menu_bar_lines,
+ android_set_mouse_color,
+ android_explicitly_set_name,
+ gui_set_scroll_bar_width,
+ gui_set_scroll_bar_height,
+ android_set_title,
+ gui_set_unsplittable,
+ gui_set_vertical_scroll_bars,
+ gui_set_horizontal_scroll_bars,
+ gui_set_visibility,
+ android_set_tab_bar_lines,
+ android_set_tool_bar_lines,
+ NULL,
+ NULL,
+ gui_set_screen_gamma,
+ gui_set_line_spacing,
+ gui_set_left_fringe,
+ gui_set_right_fringe,
+ NULL,
+ gui_set_fullscreen,
+ gui_set_font_backend,
+ android_set_alpha,
+ NULL,
+ android_set_tool_bar_position,
+ NULL,
+ NULL,
+ android_set_parent_frame,
+ NULL,
+ android_set_no_focus_on_map,
+ android_set_no_accept_focus,
+ NULL,
+ NULL,
+ gui_set_no_special_glyphs,
+ NULL,
+ NULL,
+};
+
+
+
+/* Battery information support. */
+
+DEFUN ("android-query-battery", Fandroid_query_battery,
+ Sandroid_query_battery, 0, 0, 0,
+ doc: /* Perform a query for battery information.
+Value is nil upon failure, or a list of the form:
+
+ (CAPACITY CHARGE-COUNTER CURRENT-AVERAGE CURRENT-NOW STATUS
+ REMAINING PLUGGED TEMP)
+
+where REMAINING, CURRENT-AVERAGE, and CURRENT-NOW are undefined prior
+to Android 5.0.
+
+See the documentation at
+
+ https://developer.android.com/reference/android/os/BatteryManager
+
+for more details about these values. */)
+ (void)
+{
+ struct android_battery_state state;
+
+ /* Make sure the Android libraries have been initialized. */
+
+ if (!android_init_gui)
+ return Qnil;
+
+ /* Perform the query. */
+
+ if (android_query_battery (&state))
+ return Qnil;
+
+ return listn (8, make_int (state.capacity),
+ make_fixnum (state.charge_counter),
+ make_int (state.current_average),
+ make_int (state.current_now),
+ make_fixnum (state.status),
+ make_int (state.remaining),
+ make_fixnum (state.plugged),
+ make_fixnum (state.temperature));
+}
+
+
+
+/* Directory access requests. */
+
+DEFUN ("android-request-directory-access", Fandroid_request_directory_access,
+ Sandroid_request_directory_access, 0, 0, "",
+ doc: /* Request access to a directory within external storage.
+On Android 5.0 and later, prompt for a directory within external or
+application storage, and grant access to it; some of these directories
+cannot be accessed through the regular `/sdcard' filesystem.
+
+If access to the directory is granted, it will eventually appear
+within the directory `/content/storage'. */)
+ (void)
+{
+ if (android_get_current_api_level () < 21)
+ error ("Emacs can only access application storage on"
+ " Android 5.0 and later");
+
+ if (!android_init_gui)
+ return Qnil;
+
+ android_request_directory_access ();
+ return Qnil;
+}
+
+
+
+/* Functions concerning storage permissions. */
+
+DEFUN ("android-external-storage-available-p",
+ Fandroid_external_storage_available_p,
+ Sandroid_external_storage_available_p, 0, 0, 0,
+ doc: /* Return non-nil if Emacs is entitled to access external storage.
+Return nil if the requisite permissions for external storage access
+have not been granted to Emacs, t otherwise. Such permissions can be
+requested by means of the `android-request-storage-access'
+command.
+
+External storage on Android encompasses the `/sdcard' and
+`/storage/emulated' directories, access to which is denied to programs
+absent these permissions. */)
+ (void)
+{
+ return android_external_storage_available_p () ? Qt : Qnil;
+}
+
+DEFUN ("android-request-storage-access", Fandroid_request_storage_access,
+ Sandroid_request_storage_access, 0, 0, "",
+ doc: /* Request permissions to access external storage.
+
+Return nil regardless of whether access permissions are granted or not,
+immediately after displaying the permissions request dialog.
+
+Use `android-external-storage-available-p' (which see) to verify
+whether Emacs has actually received such access permissions. */)
+ (void)
+{
+ android_request_storage_access ();
+ return Qnil;
+}
+
+
+
+/* Miscellaneous input method related stuff. */
+
+/* Report X, Y, by the phys cursor width and height as the cursor
+ anchor rectangle for W's frame. */
+
+void
+android_set_preeditarea (struct window *w, int x, int y)
+{
+ struct frame *f;
+
+ f = WINDOW_XFRAME (w);
+
+ /* Convert the window coordinates to the frame's coordinate
+ space. */
+ x = (WINDOW_TO_FRAME_PIXEL_X (w, x)
+ + WINDOW_LEFT_FRINGE_WIDTH (w)
+ + WINDOW_LEFT_MARGIN_WIDTH (w));
+ y = WINDOW_TO_FRAME_PIXEL_Y (w, y);
+
+ /* Note that calculating the baseline is too hard, so the bottom of
+ the cursor is used instead. */
+ android_update_cursor_anchor_info (FRAME_ANDROID_WINDOW (f), x,
+ y, y + w->phys_cursor_height,
+ y + w->phys_cursor_height);
+}
+
+
+
+/* Debugging. */
+
+DEFUN ("android-recreate-activity", Fandroid_recreate_activity,
+ Sandroid_recreate_activity, 0, 0, "",
+ doc: /* Recreate the activity attached to the current frame.
+This function exists for debugging purposes and is of no interest to
+users. */)
+ (void)
+{
+ struct frame *f;
+
+ f = decode_window_system_frame (Qnil);
+ android_recreate_activity (FRAME_ANDROID_WINDOW (f));
+ return Qnil;
+}
+
+#endif /* !ANDROID_STUBIFY */
+
+
+
+#ifndef ANDROID_STUBIFY
+
+static void
+syms_of_androidfns_for_pdumper (void)
+{
+ jclass locale;
+ jmethodID method;
+ jobject object;
+ jstring string;
+ Lisp_Object language, country, script, variant;
+ const char *data;
+ FILE *fd;
+ char *line;
+ size_t size;
+ long pid;
+
+ /* Find the Locale class. */
+
+ locale = (*android_java_env)->FindClass (android_java_env,
+ "java/util/Locale");
+ if (!locale)
+ emacs_abort ();
+
+ /* And the method from which the default locale can be
+ extracted. */
+
+ method = (*android_java_env)->GetStaticMethodID (android_java_env,
+ locale,
+ "getDefault",
+ "()Ljava/util/Locale;");
+ if (!method)
+ emacs_abort ();
+
+ /* Retrieve the default locale. */
+
+ object = (*android_java_env)->CallStaticObjectMethod (android_java_env,
+ locale, method);
+ android_exception_check_1 (locale);
+
+ if (!object)
+ emacs_abort ();
+
+ /* Retrieve its language field. Each of these methods is liable to
+ return the empty string, though if language is empty, the locale
+ is malformed. */
+
+ method = (*android_java_env)->GetMethodID (android_java_env, locale,
+ "getLanguage",
+ "()Ljava/lang/String;");
+ if (!method)
+ emacs_abort ();
+
+ string = (*android_java_env)->CallObjectMethod (android_java_env, object,
+ method);
+ android_exception_check_2 (object, locale);
+
+ if (!string)
+ language = empty_unibyte_string;
+ else
+ {
+ data = (*android_java_env)->GetStringUTFChars (android_java_env,
+ string, NULL);
+ android_exception_check_3 (object, locale, string);
+
+ if (!data)
+ language = empty_unibyte_string;
+ else
+ {
+ language = build_unibyte_string (data);
+ (*android_java_env)->ReleaseStringUTFChars (android_java_env,
+ string, data);
+ }
+ }
+
+ /* Delete the reference to this string. */
+ ANDROID_DELETE_LOCAL_REF (string);
+
+ /* Proceed to retrieve the country code. */
+
+ method = (*android_java_env)->GetMethodID (android_java_env, locale,
+ "getCountry",
+ "()Ljava/lang/String;");
+ if (!method)
+ emacs_abort ();
+
+ string = (*android_java_env)->CallObjectMethod (android_java_env, object,
+ method);
+ android_exception_check_2 (object, locale);
+
+ if (!string)
+ country = empty_unibyte_string;
+ else
+ {
+ data = (*android_java_env)->GetStringUTFChars (android_java_env,
+ string, NULL);
+ android_exception_check_3 (object, locale, string);
+
+ if (!data)
+ country = empty_unibyte_string;
+ else
+ {
+ country = build_unibyte_string (data);
+ (*android_java_env)->ReleaseStringUTFChars (android_java_env,
+ string, data);
+ }
+ }
+
+ ANDROID_DELETE_LOCAL_REF (string);
+
+ /* Proceed to retrieve the script. */
+
+ if (android_get_current_api_level () < 21)
+ script = empty_unibyte_string;
+ else
+ {
+ method = (*android_java_env)->GetMethodID (android_java_env, locale,
+ "getScript",
+ "()Ljava/lang/String;");
+ if (!method)
+ emacs_abort ();
+
+ string = (*android_java_env)->CallObjectMethod (android_java_env,
+ object, method);
+ android_exception_check_2 (object, locale);
+
+ if (!string)
+ script = empty_unibyte_string;
+ else
+ {
+ data = (*android_java_env)->GetStringUTFChars (android_java_env,
+ string, NULL);
+ android_exception_check_3 (object, locale, string);
+
+ if (!data)
+ script = empty_unibyte_string;
+ else
+ {
+ script = build_unibyte_string (data);
+ (*android_java_env)->ReleaseStringUTFChars (android_java_env,
+ string, data);
+ }
+ }
+
+ ANDROID_DELETE_LOCAL_REF (string);
+ }
+
+ /* And variant. */
+
+ method = (*android_java_env)->GetMethodID (android_java_env, locale,
+ "getVariant",
+ "()Ljava/lang/String;");
+ if (!method)
+ emacs_abort ();
+
+ string = (*android_java_env)->CallObjectMethod (android_java_env, object,
+ method);
+ android_exception_check_2 (object, locale);
+
+ if (!string)
+ variant = empty_unibyte_string;
+ else
+ {
+ data = (*android_java_env)->GetStringUTFChars (android_java_env,
+ string, NULL);
+ android_exception_check_3 (object, locale, string);
+
+ if (!data)
+ variant = empty_unibyte_string;
+ else
+ {
+ variant = build_unibyte_string (data);
+ (*android_java_env)->ReleaseStringUTFChars (android_java_env,
+ string, data);
+ }
+ }
+
+ /* Delete the reference to this string. */
+ ANDROID_DELETE_LOCAL_REF (string);
+
+ /* And other remaining local references. */
+ ANDROID_DELETE_LOCAL_REF (object);
+ ANDROID_DELETE_LOCAL_REF (locale);
+
+ /* Set Vandroid_os_language. */
+ Vandroid_os_language = list4 (language, country, script, variant);
+
+ /* Detect whether Emacs is running under libloader.so or another
+ process tracing mechanism, and disable `android_use_exec_loader' if
+ so, leaving subprocesses started by Emacs to the care of that
+ loader instance. */
+
+ if (android_get_current_api_level () >= 29) /* Q */
+ {
+ fd = fopen ("/proc/self/status", "r");
+ if (!fd)
+ return;
+
+ line = NULL;
+ while (getline (&line, &size, fd) != -1)
+ {
+ if (strncmp (line, "TracerPid:", sizeof "TracerPid:" - 1))
+ continue;
+
+ pid = atol (line + sizeof "TracerPid:" - 1);
+
+ if (pid)
+ android_use_exec_loader = false;
+
+ break;
+ }
+
+ free (line);
+ fclose (fd);
+ }
+}
+
+#endif /* ANDROID_STUBIFY */
+
+void
+syms_of_androidfns (void)
+{
+ /* Miscellaneous symbols used by some functions here. */
+ DEFSYM (Qtrue_color, "true-color");
+ DEFSYM (Qwhen_mapped, "when-mapped");
+
+ DEFVAR_LISP ("x-pointer-shape", Vx_pointer_shape,
+ doc: /* SKIP: real text in xfns.c. */);
+ Vx_pointer_shape = Qnil;
+
+#if false /* This doesn't really do anything. */
+ DEFVAR_LISP ("x-nontext-pointer-shape", Vx_nontext_pointer_shape,
+ doc: /* SKIP: real doc in xfns.c. */);
+#endif
+ Vx_nontext_pointer_shape = Qnil;
+
+ DEFVAR_LISP ("x-hourglass-pointer-shape", Vx_hourglass_pointer_shape,
+ doc: /* SKIP: real text in xfns.c. */);
+ Vx_hourglass_pointer_shape = Qnil;
+
+ DEFVAR_LISP ("x-sensitive-text-pointer-shape",
+ Vx_sensitive_text_pointer_shape,
+ doc: /* SKIP: real text in xfns.c. */);
+ Vx_sensitive_text_pointer_shape = Qnil;
+
+ DEFVAR_LISP ("x-window-horizontal-drag-cursor",
+ Vx_window_horizontal_drag_shape,
+ doc: /* SKIP: real text in xfns.c. */);
+ Vx_window_horizontal_drag_shape = Qnil;
+
+ DEFVAR_LISP ("x-window-vertical-drag-cursor",
+ Vx_window_vertical_drag_shape,
+ doc: /* SKIP: real text in xfns.c. */);
+ Vx_window_vertical_drag_shape = Qnil;
+
+ DEFVAR_LISP ("x-window-left-edge-cursor",
+ Vx_window_left_edge_shape,
+ doc: /* SKIP: real text in xfns.c. */);
+ Vx_window_left_edge_shape = Qnil;
+
+ DEFVAR_LISP ("x-window-top-left-corner-cursor",
+ Vx_window_top_left_corner_shape,
+ doc: /* SKIP: real text in xfns.c. */);
+ Vx_window_top_left_corner_shape = Qnil;
+
+ DEFVAR_LISP ("x-window-top-edge-cursor",
+ Vx_window_top_edge_shape,
+ doc: /* SKIP: real text in xfns.c. */);
+ Vx_window_top_edge_shape = Qnil;
+
+ DEFVAR_LISP ("x-window-top-right-corner-cursor",
+ Vx_window_top_right_corner_shape,
+ doc: /* SKIP: real text in xfns.c. */);
+ Vx_window_top_right_corner_shape = Qnil;
+
+ DEFVAR_LISP ("x-window-right-edge-cursor",
+ Vx_window_right_edge_shape,
+ doc: /* SKIP: real text in xfns.c. */);
+ Vx_window_right_edge_shape = Qnil;
+
+ DEFVAR_LISP ("x-window-bottom-right-corner-cursor",
+ Vx_window_bottom_right_corner_shape,
+ doc: /* SKIP: real text in xfns.c. */);
+ Vx_window_bottom_right_corner_shape = Qnil;
+
+ DEFVAR_LISP ("x-window-bottom-edge-cursor",
+ Vx_window_bottom_edge_shape,
+ doc: /* SKIP: real text in xfns.c. */);
+ Vx_window_bottom_edge_shape = Qnil;
+
+#if false /* This doesn't really do anything. */
+ DEFVAR_LISP ("x-mode-pointer-shape", Vx_mode_pointer_shape,
+ doc: /* SKIP: real doc in xfns.c. */);
+#endif
+ Vx_mode_pointer_shape = Qnil;
+
+ DEFVAR_LISP ("x-window-bottom-left-corner-cursor",
+ Vx_window_bottom_left_corner_shape,
+ doc: /* SKIP: real text in xfns.c. */);
+ Vx_window_bottom_left_corner_shape = Qnil;
+
+ DEFVAR_LISP ("x-cursor-fore-pixel", Vx_cursor_fore_pixel,
+ doc: /* SKIP: real doc in xfns.c. */);
+ Vx_cursor_fore_pixel = Qnil;
+
+ /* Used by Fx_show_tip. */
+ DEFSYM (Qrun_at_time, "run-at-time");
+ DEFSYM (Qx_hide_tip, "x-hide-tip");
+ DEFSYM (Qcancel_timer, "cancel-timer");
+ DEFSYM (Qassq_delete_all, "assq-delete-all");
+ DEFSYM (Qcolor, "color");
+
+ DEFVAR_LISP ("x-max-tooltip-size", Vx_max_tooltip_size,
+ doc: /* SKIP: real doc in xfns.c. */);
+ Vx_max_tooltip_size = Qnil;
+
+ DEFVAR_BOOL ("android-pass-multimedia-buttons-to-system",
+ android_pass_multimedia_buttons_to_system,
+ doc: /* Whether or not to pass volume control buttons to the system.
+Generally, the `volume-up', `volume-down' and `volume-mute' keys are
+processed by Emacs, but setting this to non-nil they are passed to the
+operating system instead of being intercepted by Emacs.
+
+Note that if you set this, you will no longer be able to quit Emacs
+using the volume down button. */);
+ android_pass_multimedia_buttons_to_system = false;
+
+ DEFVAR_BOOL ("android-intercept-control-space",
+ android_intercept_control_space,
+ doc: /* Whether Emacs should intercept C-SPC.
+When this variable is set, Emacs intercepts C-SPC events as they are
+delivered to a frame before they are registered and filtered by the
+input method.
+
+For no apparent purpose, Android input methods customarily discard SPC
+events with the Ctrl modifier set without delivering them to Emacs
+afterwards, which is an impediment to typing key sequences
+incorporating such keys. */);
+ android_intercept_control_space = true;
+
+ DEFVAR_BOOL ("android-use-exec-loader", android_use_exec_loader,
+ doc: /* Whether or not to bypass system restrictions on program execution.
+
+Android 10 and later prevent programs from executing files installed
+in writable directories, such as the application data directory.
+
+When non-nil, Emacs will bypass this restriction by running such
+executables under system call tracing, and replacing the `execve'
+system call with a version which ignores the system's security
+restrictions.
+
+This option has no effect on Android 9 and earlier. */);
+ android_use_exec_loader = true;
+
+ DEFVAR_INT ("android-keyboard-bell-duration",
+ android_keyboard_bell_duration,
+ doc: /* Number of milliseconds to vibrate after ringing the keyboard bell.
+The keyboard bell under Android systems takes the form of a vibrating
+element that is activated for a given number of milliseconds upon the
+bell being rung. */);
+ android_keyboard_bell_duration = 50;
+
+ DEFVAR_LISP ("android-os-language", Vandroid_os_language,
+ doc: /* A list representing the configured system language on Android.
+This list has four elements: LANGUAGE, COUNTRY, SCRIPT and VARIANT, where:
+
+LANGUAGE and COUNTRY are ISO language and country codes identical to
+those found in POSIX locale specifications.
+
+SCRIPT is an ISO 15924 script tag, representing the script used
+if available, or if required to disambiguate between distinct
+writing systems for the same combination of language and country.
+
+VARIANT is an arbitrary string representing the variant of the
+LANGUAGE or SCRIPT.
+
+Each of these fields might be empty or nil, but the locale is invalid
+if LANGUAGE is empty. Users of this variable should consider the
+language to be US English if LANGUAGE is empty. */);
+ Vandroid_os_language = Qnil;
+
+ /* Functions defined. */
+ defsubr (&Sx_create_frame);
+ defsubr (&Sxw_color_defined_p);
+ defsubr (&Sxw_color_values);
+ defsubr (&Sxw_display_color_p);
+ defsubr (&Sx_display_grayscale_p);
+ defsubr (&Sx_display_pixel_width);
+ defsubr (&Sx_display_pixel_height);
+ defsubr (&Sx_display_planes);
+ defsubr (&Sx_display_color_cells);
+ defsubr (&Sx_display_screens);
+ defsubr (&Sx_display_mm_width);
+ defsubr (&Sx_display_mm_height);
+ defsubr (&Sx_display_backing_store);
+ defsubr (&Sx_display_visual_class);
+ defsubr (&Sandroid_display_monitor_attributes_list);
+ defsubr (&Sandroid_frame_geometry);
+ defsubr (&Sandroid_frame_edges);
+ defsubr (&Sandroid_frame_list_z_order);
+ defsubr (&Sandroid_frame_restack);
+ defsubr (&Sandroid_mouse_absolute_pixel_position);
+ defsubr (&Sandroid_set_mouse_absolute_pixel_position);
+ defsubr (&Sandroid_get_connection);
+ defsubr (&Sx_display_list);
+ defsubr (&Sx_show_tip);
+ defsubr (&Sx_hide_tip);
+ defsubr (&Sandroid_detect_mouse);
+ defsubr (&Sandroid_detect_keyboard);
+ defsubr (&Sandroid_toggle_on_screen_keyboard);
+ defsubr (&Sx_server_vendor);
+ defsubr (&Sx_server_version);
+#ifndef ANDROID_STUBIFY
+ defsubr (&Sandroid_query_battery);
+ defsubr (&Sandroid_request_directory_access);
+ defsubr (&Sandroid_external_storage_available_p);
+ defsubr (&Sandroid_request_storage_access);
+ defsubr (&Sandroid_recreate_activity);
+
+ tip_timer = Qnil;
+ staticpro (&tip_timer);
+ tip_frame = Qnil;
+ staticpro (&tip_frame);
+ tip_last_frame = Qnil;
+ staticpro (&tip_last_frame);
+ tip_last_string = Qnil;
+ staticpro (&tip_last_string);
+ tip_last_parms = Qnil;
+ staticpro (&tip_last_parms);
+ tip_dx = Qnil;
+ staticpro (&tip_dx);
+ tip_dy = Qnil;
+ staticpro (&tip_dy);
+
+ pdumper_do_now_and_after_load (syms_of_androidfns_for_pdumper);
+#endif /* !ANDROID_STUBIFY */
+}
diff --git a/src/androidfont.c b/src/androidfont.c
new file mode 100644
index 00000000000..5fd3018b6d4
--- /dev/null
+++ b/src/androidfont.c
@@ -0,0 +1,1104 @@
+/* Android fallback font driver.
+
+Copyright (C) 2023-2024 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 <https://www.gnu.org/licenses/>. */
+
+/* Due to the terrible nature of the Android Typeface subsystems, this
+ font driver is only used as a fallback when sfntfont-android.c
+ fails to enumerate any fonts at all. */
+
+#include <config.h>
+
+#include "lisp.h"
+#include "dispextern.h"
+#include "composite.h"
+#include "blockinput.h"
+#include "charset.h"
+#include "frame.h"
+#include "window.h"
+#include "fontset.h"
+#include "androidterm.h"
+#include "character.h"
+#include "coding.h"
+#include "font.h"
+#include "termchar.h"
+#include "pdumper.h"
+#include "android.h"
+
+#ifndef ANDROID_STUBIFY
+
+#include <android/log.h>
+
+struct android_emacs_font_driver
+{
+ jclass class;
+ jmethodID list;
+ jmethodID match;
+ jmethodID list_families;
+ jmethodID open_font;
+ jmethodID has_char;
+ jmethodID text_extents;
+ jmethodID encode_char;
+ jmethodID draw;
+
+ /* Static methods. */
+ jmethodID create_font_driver;
+};
+
+struct android_emacs_font_spec
+{
+ jclass class;
+ jfieldID foundry;
+ jfieldID family;
+ jfieldID adstyle;
+ jfieldID registry;
+ jfieldID width;
+ jfieldID weight;
+ jfieldID slant;
+ jfieldID size;
+ jfieldID spacing;
+ jfieldID avgwidth;
+ jfieldID dpi;
+};
+
+struct android_emacs_font_metrics
+{
+ jclass class;
+ jfieldID lbearing;
+ jfieldID rbearing;
+ jfieldID width;
+ jfieldID ascent;
+ jfieldID descent;
+};
+
+struct android_emacs_font_object
+{
+ jclass class;
+ jfieldID min_width;
+ jfieldID max_width;
+ jfieldID pixel_size;
+ jfieldID height;
+ jfieldID space_width;
+ jfieldID average_width;
+ jfieldID ascent;
+ jfieldID descent;
+ jfieldID underline_thickness;
+ jfieldID underline_position;
+ jfieldID baseline_offset;
+ jfieldID relative_compose;
+ jfieldID default_ascent;
+ jfieldID encoding_charset;
+ jfieldID repertory_charset;
+};
+
+struct android_integer
+{
+ jclass class;
+ jmethodID constructor;
+ jmethodID int_value;
+};
+
+struct androidfont_info
+{
+ /* The font pseudo-vector object. */
+ struct font font;
+
+ /* The Java-side font. */
+ jobject object;
+
+ /* Cached glyph metrics arranged in a two dimensional array. */
+ struct font_metrics **metrics;
+};
+
+struct androidfont_entity
+{
+ /* The font entity pvec. */
+ struct font_entity font;
+
+ /* The Java-side font entity. */
+ jobject object;
+};
+
+/* Method and class identifiers associated with the EmacsFontDriver
+ class. */
+
+struct android_emacs_font_driver font_driver_class;
+
+/* Field and class identifiers associated with the
+ EmacsFontDriver$FontSpec class. */
+
+struct android_emacs_font_spec font_spec_class;
+
+/* Method and class identifiers associated with the Integer class. */
+
+struct android_integer integer_class;
+
+/* Field and class identifiers associated with the
+ EmacsFontDriver$FontMetrics class. */
+
+struct android_emacs_font_metrics font_metrics_class;
+
+/* Field and class identifiers associated with the
+ EmacsFontDriver$FontObject class. */
+
+struct android_emacs_font_object font_object_class;
+
+/* The font cache. */
+
+static Lisp_Object font_cache;
+
+/* The Java-side font driver. */
+
+static jobject font_driver;
+
+
+
+/* Initialize the class and method identifiers for functions in the
+ EmacsFontDriver class, and place them in `font_driver_class'. */
+
+static void
+android_init_font_driver (void)
+{
+ jclass old;
+
+ font_driver_class.class
+ = (*android_java_env)->FindClass (android_java_env,
+ "org/gnu/emacs/EmacsFontDriver");
+ eassert (font_driver_class.class);
+
+ old = font_driver_class.class;
+ font_driver_class.class
+ = (jclass) (*android_java_env)->NewGlobalRef (android_java_env,
+ (jobject) old);
+ ANDROID_DELETE_LOCAL_REF (old);
+
+ if (!font_driver_class.class)
+ emacs_abort ();
+
+#define FIND_METHOD(c_name, name, signature) \
+ font_driver_class.c_name \
+ = (*android_java_env)->GetMethodID (android_java_env, \
+ font_driver_class.class, \
+ name, signature); \
+ eassert (font_driver_class.c_name);
+
+ FIND_METHOD (list, "list", "(Lorg/gnu/emacs/EmacsFontDriver$FontSpec;)"
+ "[Lorg/gnu/emacs/EmacsFontDriver$FontEntity;");
+ FIND_METHOD (match, "match", "(Lorg/gnu/emacs/EmacsFontDriver$FontSpec;)"
+ "Lorg/gnu/emacs/EmacsFontDriver$FontEntity;");
+ FIND_METHOD (list_families, "listFamilies", "()[Ljava/lang/String;");
+ FIND_METHOD (open_font, "openFont", "(Lorg/gnu/emacs/EmacsFontDriver$Font"
+ "Entity;I)Lorg/gnu/emacs/EmacsFontDriver$FontObject;");
+ FIND_METHOD (has_char, "hasChar", "(Lorg/gnu/emacs/EmacsFontDriver$Font"
+ "Spec;I)I");
+ FIND_METHOD (text_extents, "textExtents", "(Lorg/gnu/emacs/EmacsFontDriver"
+ "$FontObject;[ILorg/gnu/emacs/EmacsFontDriver$FontMetrics;)V");
+ FIND_METHOD (encode_char, "encodeChar", "(Lorg/gnu/emacs/EmacsFontDriver"
+ "$FontObject;I)I");
+ FIND_METHOD (draw, "draw", "(Lorg/gnu/emacs/EmacsFontDriver$FontObject;"
+ "Lorg/gnu/emacs/EmacsGC;Lorg/gnu/emacs/EmacsDrawable;[IIIIZ)I");
+
+ font_driver_class.create_font_driver
+ = (*android_java_env)->GetStaticMethodID (android_java_env,
+ font_driver_class.class,
+ "createFontDriver",
+ "()Lorg/gnu/emacs/"
+ "EmacsFontDriver;");
+ eassert (font_driver_class.create_font_driver);
+#undef FIND_METHOD
+}
+
+/* Initialize the class and field identifiers for functions in the
+ EmacsFontDriver$FontSpec class, and place them in
+ `font_spec_class'. */
+
+static void
+android_init_font_spec (void)
+{
+ jclass old;
+
+ font_spec_class.class
+ = (*android_java_env)->FindClass (android_java_env,
+ "org/gnu/emacs/EmacsFontDriver"
+ "$FontSpec");
+ eassert (font_spec_class.class);
+
+ old = font_spec_class.class;
+ font_spec_class.class
+ = (jclass) (*android_java_env)->NewGlobalRef (android_java_env,
+ (jobject) old);
+ ANDROID_DELETE_LOCAL_REF (old);
+
+ if (!font_spec_class.class)
+ emacs_abort ();
+
+#define FIND_FIELD(c_name, name, signature) \
+ font_spec_class.c_name \
+ = (*android_java_env)->GetFieldID (android_java_env, \
+ font_spec_class.class, \
+ name, signature); \
+ eassert (font_spec_class.c_name);
+
+ FIND_FIELD (foundry, "foundry", "Ljava/lang/String;");
+ FIND_FIELD (family, "family", "Ljava/lang/String;");
+ FIND_FIELD (adstyle, "adstyle", "Ljava/lang/String;");
+ FIND_FIELD (registry, "registry", "Ljava/lang/String;");
+ FIND_FIELD (width, "width", "Ljava/lang/Integer;");
+ FIND_FIELD (weight, "weight", "Ljava/lang/Integer;");
+ FIND_FIELD (slant, "slant", "Ljava/lang/Integer;");
+ FIND_FIELD (size, "size", "Ljava/lang/Integer;");
+ FIND_FIELD (spacing, "spacing", "Ljava/lang/Integer;");
+ FIND_FIELD (avgwidth, "avgwidth", "Ljava/lang/Integer;");
+ FIND_FIELD (dpi, "dpi", "Ljava/lang/Integer;");
+#undef FIND_FIELD
+}
+
+static void
+android_init_font_metrics (void)
+{
+ jclass old;
+
+ font_metrics_class.class
+ = (*android_java_env)->FindClass (android_java_env,
+ "org/gnu/emacs/EmacsFontDriver"
+ "$FontMetrics");
+ eassert (font_metrics_class.class);
+
+ old = font_metrics_class.class;
+ font_metrics_class.class
+ = (jclass) (*android_java_env)->NewGlobalRef (android_java_env,
+ (jobject) old);
+ ANDROID_DELETE_LOCAL_REF (old);
+
+ if (!font_metrics_class.class)
+ emacs_abort ();
+
+#define FIND_FIELD(c_name, name, signature) \
+ font_metrics_class.c_name \
+ = (*android_java_env)->GetFieldID (android_java_env, \
+ font_metrics_class.class, \
+ name, signature); \
+ eassert (font_metrics_class.c_name);
+
+ FIND_FIELD (lbearing, "lbearing", "S");
+ FIND_FIELD (rbearing, "rbearing", "S");
+ FIND_FIELD (width, "width", "S");
+ FIND_FIELD (ascent, "ascent", "S");
+ FIND_FIELD (descent, "descent", "S");
+#undef FIND_FIELD
+}
+
+static void
+android_init_integer (void)
+{
+ jclass old;
+
+ integer_class.class
+ = (*android_java_env)->FindClass (android_java_env,
+ "java/lang/Integer");
+ eassert (integer_class.class);
+
+ old = integer_class.class;
+ integer_class.class
+ = (jclass) (*android_java_env)->NewGlobalRef (android_java_env,
+ (jobject) old);
+ ANDROID_DELETE_LOCAL_REF (old);
+
+ if (!integer_class.class)
+ emacs_abort ();
+
+#define FIND_METHOD(c_name, name, signature) \
+ integer_class.c_name \
+ = (*android_java_env)->GetMethodID (android_java_env, \
+ integer_class.class, \
+ name, signature); \
+ eassert (integer_class.c_name);
+
+ FIND_METHOD (constructor, "<init>", "(I)V");
+ FIND_METHOD (int_value, "intValue", "()I");
+#undef FIND_METHOD
+}
+
+static void
+android_init_font_object (void)
+{
+ jclass old;
+
+ font_object_class.class
+ = (*android_java_env)->FindClass (android_java_env,
+ "org/gnu/emacs/EmacsFontDriver"
+ "$FontObject");
+ eassert (font_object_class.class);
+
+ old = font_object_class.class;
+ font_object_class.class
+ = (jclass) (*android_java_env)->NewGlobalRef (android_java_env,
+ (jobject) old);
+ ANDROID_DELETE_LOCAL_REF (old);
+
+ if (!font_object_class.class)
+ emacs_abort ();
+
+#define FIND_FIELD(c_name, name, signature) \
+ font_object_class.c_name \
+ = (*android_java_env)->GetFieldID (android_java_env, \
+ font_object_class.class, \
+ name, signature); \
+ eassert (font_object_class.c_name);
+
+ FIND_FIELD (min_width, "minWidth", "I");
+ FIND_FIELD (max_width, "maxWidth", "I");
+ FIND_FIELD (pixel_size, "pixelSize", "I");
+ FIND_FIELD (height, "height", "I");
+ FIND_FIELD (space_width, "spaceWidth", "I");
+ FIND_FIELD (average_width, "averageWidth", "I");
+ FIND_FIELD (ascent, "ascent", "I");
+ FIND_FIELD (descent, "descent", "I");
+ FIND_FIELD (underline_thickness, "underlineThickness", "I");
+ FIND_FIELD (underline_position, "underlinePosition", "I");
+ FIND_FIELD (baseline_offset, "baselineOffset", "I");
+ FIND_FIELD (relative_compose, "relativeCompose", "I");
+ FIND_FIELD (default_ascent, "defaultAscent", "I");
+ FIND_FIELD (encoding_charset, "encodingCharset", "I");
+ FIND_FIELD (repertory_charset, "repertoryCharset", "I");
+#undef FIND_FIELD
+}
+
+static Lisp_Object
+androidfont_get_cache (struct frame *frame)
+{
+ return font_cache;
+}
+
+/* Initialize the Java side of the font driver if it has not already
+ been initialized. This is only done whenever necessary because the
+ font driver otherwise uses a lot of memory, as it has to keep every
+ typeface open. */
+
+static void
+androidfont_check_init (void)
+{
+ jmethodID method;
+ jobject old;
+
+ if (font_driver)
+ return;
+
+ /* Log a loud message. This font driver really should not be
+ used. */
+ __android_log_print (ANDROID_LOG_WARN, __func__,
+ "The Android font driver is being used."
+ " Please investigate why this is so.");
+
+ method = font_driver_class.create_font_driver;
+
+ /* Initialize the font driver on the Java side. */
+ font_driver
+ = (*android_java_env)->CallStaticObjectMethod (android_java_env,
+ font_driver_class.class,
+ method);
+ android_exception_check ();
+
+ old = font_driver;
+ font_driver
+ = (*android_java_env)->NewGlobalRef (android_java_env, font_driver);
+ ANDROID_DELETE_LOCAL_REF (old);
+}
+
+/* Return a local reference to an instance of EmacsFontDriver$FontSpec
+ with the same values as FONT. */
+
+static jobject
+androidfont_from_lisp (Lisp_Object font)
+{
+ jobject spec, integer;
+ jstring string;
+ Lisp_Object tem;
+
+ spec = (*android_java_env)->AllocObject (android_java_env,
+ font_spec_class.class);
+ android_exception_check ();
+
+#define DO_SYMBOL_FIELD(field, index) \
+ tem = AREF (font, index); \
+ if (SYMBOLP (tem)) \
+ { \
+ /* Java seems to DTRT with the Emacs string encoding, so this does \
+ not matter at all. */ \
+ string = (*android_java_env)->NewStringUTF (android_java_env, \
+ SSDATA (SYMBOL_NAME (tem))); \
+ android_exception_check_1 (spec); \
+ \
+ (*android_java_env)->SetObjectField (android_java_env, spec, \
+ font_spec_class.field, \
+ string); \
+ ANDROID_DELETE_LOCAL_REF (string); \
+ } \
+
+ DO_SYMBOL_FIELD (foundry, FONT_FOUNDRY_INDEX);
+ DO_SYMBOL_FIELD (family, FONT_FAMILY_INDEX);
+ DO_SYMBOL_FIELD (adstyle, FONT_ADSTYLE_INDEX);
+ DO_SYMBOL_FIELD (registry, FONT_REGISTRY_INDEX);
+
+#undef DO_SYMBOL_FIELD
+
+#define DO_CARDINAL_FIELD(field, value) \
+ if (value != -1) \
+ { \
+ integer = (*android_java_env)->NewObject (android_java_env, \
+ integer_class.class, \
+ integer_class.constructor, \
+ (jint) value); \
+ android_exception_check_1 (spec); \
+ \
+ (*android_java_env)->SetObjectField (android_java_env, spec, \
+ font_spec_class.field, \
+ integer); \
+ ANDROID_DELETE_LOCAL_REF (integer); \
+ }
+
+ DO_CARDINAL_FIELD (width, FONT_WIDTH_NUMERIC (font));
+ DO_CARDINAL_FIELD (weight, FONT_WEIGHT_NUMERIC (font));
+ DO_CARDINAL_FIELD (slant, FONT_SLANT_NUMERIC (font));
+ DO_CARDINAL_FIELD (size, (FIXNUMP (AREF (font, FONT_SIZE_INDEX))
+ ? XFIXNUM (AREF (font, FONT_SIZE_INDEX))
+ : -1));
+ DO_CARDINAL_FIELD (spacing, (FIXNUMP (AREF (font, FONT_SPACING_INDEX))
+ ? XFIXNUM (AREF (font, FONT_SPACING_INDEX))
+ : -1));
+ DO_CARDINAL_FIELD (avgwidth, (FIXNUMP (AREF (font, FONT_AVGWIDTH_INDEX))
+ ? XFIXNUM (AREF (font, FONT_AVGWIDTH_INDEX))
+ : -1));
+ DO_CARDINAL_FIELD (dpi, (FIXNUMP (AREF (font, FONT_DPI_INDEX))
+ ? XFIXNUM (AREF (font, FONT_DPI_INDEX))
+ : -1));
+
+#undef DO_CARDINAL_FIELD
+
+ return spec;
+}
+
+static void
+androidfont_from_java (jobject spec, Lisp_Object entity)
+{
+ jobject tem;
+ jint value;
+ const char *string;
+
+#define DO_SYMBOL_FIELD(field, index) \
+ tem = (*android_java_env)->GetObjectField (android_java_env, \
+ spec, \
+ font_spec_class.field); \
+ if (tem) \
+ { \
+ string = (*android_java_env)->GetStringUTFChars (android_java_env, \
+ tem, NULL); \
+ if (!string) \
+ memory_full (0); \
+ ASET (entity, index, intern (string)); \
+ (*android_java_env)->ReleaseStringUTFChars (android_java_env, \
+ tem, string); \
+ ANDROID_DELETE_LOCAL_REF (tem); \
+ }
+
+ DO_SYMBOL_FIELD (foundry, FONT_FOUNDRY_INDEX);
+ DO_SYMBOL_FIELD (family, FONT_FAMILY_INDEX);
+ DO_SYMBOL_FIELD (adstyle, FONT_ADSTYLE_INDEX);
+ DO_SYMBOL_FIELD (registry, FONT_REGISTRY_INDEX);
+
+#undef DO_SYMBOL_FIELD
+#define DO_CARDINAL_FIELD(field, index, is_style) \
+ tem = (*android_java_env)->GetObjectField (android_java_env, \
+ spec, \
+ font_spec_class.field); \
+ if (tem) \
+ { \
+ value \
+ = (*android_java_env)->CallIntMethod (android_java_env, \
+ tem, \
+ integer_class.int_value); \
+ if (!is_style) \
+ ASET (entity, index, make_fixnum (value)); \
+ else \
+ FONT_SET_STYLE (entity, index, make_fixnum (value)); \
+ ANDROID_DELETE_LOCAL_REF (tem); \
+ }
+
+ DO_CARDINAL_FIELD (width, FONT_WIDTH_INDEX, true);
+ DO_CARDINAL_FIELD (weight, FONT_WEIGHT_INDEX, true);
+ DO_CARDINAL_FIELD (slant, FONT_SLANT_INDEX, true);
+ DO_CARDINAL_FIELD (size, FONT_SIZE_INDEX, false);
+ DO_CARDINAL_FIELD (spacing, FONT_SPACING_INDEX, false);
+ DO_CARDINAL_FIELD (avgwidth, FONT_AVGWIDTH_INDEX, false);
+ DO_CARDINAL_FIELD (dpi, FONT_DPI_INDEX, false);
+
+#undef DO_CARDINAL_FIELD
+}
+
+/* Transfer the values from FONT, which must be some kind of font
+ entity, */
+
+static Lisp_Object
+androidfont_list (struct frame *f, Lisp_Object font_spec)
+{
+ jobject spec, array, tem;
+ jarray entities;
+ jsize i, size;
+ Lisp_Object value, entity;
+ struct androidfont_entity *info;
+
+ /* Maybe initialize the font driver. */
+ androidfont_check_init ();
+
+ spec = androidfont_from_lisp (font_spec);
+ array = (*android_java_env)->CallObjectMethod (android_java_env,
+ font_driver,
+ font_driver_class.list,
+ spec);
+ android_exception_check_1 (spec);
+ ANDROID_DELETE_LOCAL_REF (spec);
+
+ entities = (jarray) array;
+ size = (*android_java_env)->GetArrayLength (android_java_env,
+ entities);
+ value = Qnil;
+
+ for (i = 0; i < size; ++i)
+ {
+ entity = font_make_entity_android (VECSIZE (struct androidfont_entity));
+ info = (struct androidfont_entity *) XFONT_ENTITY (entity);
+
+ /* The type must be set correctly, or font_open_entity won't be
+ able to find the right font driver. */
+ ASET (entity, FONT_TYPE_INDEX, Qandroid);
+
+ /* Clear this now in case GC happens without it set, which can
+ happen if androidfont_from_java runs out of memory. */
+ info->object = NULL;
+
+ tem = (*android_java_env)->GetObjectArrayElement (android_java_env,
+ entities, i);
+ androidfont_from_java (tem, entity);
+
+ /* Now, make a global reference to the Java font entity. */
+ info->object = (*android_java_env)->NewGlobalRef (android_java_env,
+ (jobject) tem);
+ android_exception_check_2 (tem, entities);
+ ANDROID_DELETE_LOCAL_REF (tem);
+
+ value = Fcons (entity, value);
+ }
+
+ ANDROID_DELETE_LOCAL_REF (entities);
+ return Fnreverse (value);
+}
+
+static Lisp_Object
+androidfont_match (struct frame *f, Lisp_Object font_spec)
+{
+ jobject spec, result;
+ Lisp_Object entity;
+ struct androidfont_entity *info;
+
+ /* Maybe initialize the font driver. */
+ androidfont_check_init ();
+
+ spec = androidfont_from_lisp (font_spec);
+ result = (*android_java_env)->CallObjectMethod (android_java_env,
+ font_driver,
+ font_driver_class.match,
+ spec);
+ android_exception_check_1 (spec);
+ ANDROID_DELETE_LOCAL_REF (spec);
+
+ entity = font_make_entity_android (VECSIZE (struct androidfont_entity));
+ info = (struct androidfont_entity *) XFONT_ENTITY (entity);
+
+ /* The type must be set correctly, or font_open_entity won't be able
+ to find the right font driver. */
+ ASET (entity, FONT_TYPE_INDEX, Qandroid);
+
+ info->object = NULL;
+ androidfont_from_java (result, entity);
+ info->object = (*android_java_env)->NewGlobalRef (android_java_env,
+ (jobject) result);
+ android_exception_check_1 (result);
+ ANDROID_DELETE_LOCAL_REF (result);
+
+ return entity;
+}
+
+static int
+androidfont_draw (struct glyph_string *s, int from, int to,
+ int x, int y, bool with_background)
+{
+ struct androidfont_info *info;
+ jarray chars;
+ int rc;
+ jobject gcontext, drawable;
+
+ /* Maybe initialize the font driver. */
+ androidfont_check_init ();
+
+ verify (sizeof (unsigned int) == sizeof (jint));
+ info = (struct androidfont_info *) s->font;
+
+ gcontext = android_resolve_handle (s->gc->gcontext,
+ ANDROID_HANDLE_GCONTEXT);
+ drawable = android_resolve_handle (FRAME_ANDROID_DRAWABLE (s->f),
+ ANDROID_HANDLE_WINDOW);
+ chars = (*android_java_env)->NewIntArray (android_java_env,
+ to - from);
+ android_exception_check ();
+
+ (*android_java_env)->SetIntArrayRegion (android_java_env, chars,
+ 0, to - from,
+ (jint *) s->char2b + from);
+
+ info = (struct androidfont_info *) s->font;
+ prepare_face_for_display (s->f, s->face);
+
+ rc = (*android_java_env)->CallIntMethod (android_java_env,
+ font_driver,
+ font_driver_class.draw,
+ info->object,
+ gcontext, drawable,
+ chars, (jint) x, (jint) y,
+ (jint) s->width,
+ (jboolean) with_background);
+ android_exception_check_1 (chars);
+ ANDROID_DELETE_LOCAL_REF (chars);
+
+ return rc;
+}
+
+static Lisp_Object
+androidfont_open_font (struct frame *f, Lisp_Object font_entity,
+ int pixel_size)
+{
+ struct androidfont_info *font_info;
+ struct androidfont_entity *entity;
+ struct font *font;
+ Lisp_Object font_object;
+ jobject old;
+ jint value;
+
+ /* Maybe initialize the font driver. */
+ androidfont_check_init ();
+
+ if (XFIXNUM (AREF (font_entity, FONT_SIZE_INDEX)) != 0)
+ pixel_size = XFIXNUM (AREF (font_entity, FONT_SIZE_INDEX));
+ else if (pixel_size == 0)
+ {
+ /* This bit was copied from xfont.c. The values might need
+ adjustment. */
+
+ if (FRAME_FONT (f))
+ pixel_size = FRAME_FONT (f)->pixel_size;
+ else
+ pixel_size = 12;
+ }
+
+ entity = (struct androidfont_entity *) XFONT_ENTITY (font_entity);
+
+ block_input ();
+ font_object = font_make_object (VECSIZE (struct androidfont_info),
+ font_entity, pixel_size);
+ ASET (font_object, FONT_TYPE_INDEX, Qandroid);
+ font_info = (struct androidfont_info *) XFONT_OBJECT (font_object);
+ font = &font_info->font;
+ font->driver = &androidfont_driver;
+
+ /* Clear font_info->object and font_info->metrics early in case GC
+ happens later on! */
+ font_info->object = NULL;
+ font_info->metrics = NULL;
+ unblock_input ();
+
+ font_info->object
+ = (*android_java_env)->CallObjectMethod (android_java_env,
+ font_driver,
+ font_driver_class.open_font,
+ entity->object,
+ (jint) pixel_size);
+ android_exception_check ();
+
+ old = font_info->object;
+ font_info->object
+ = (*android_java_env)->NewGlobalRef (android_java_env, old);
+ android_exception_check_1 (old);
+ ANDROID_DELETE_LOCAL_REF (old);
+
+ if (!font_info->object)
+ return Qnil;
+
+ /* Copy the font attributes from the Java object. */
+ androidfont_from_java (font_info->object, font_object);
+
+ /* Copy font attributes inside EmacsFontDriver$FontObject. */
+#define DO_CARDINAL_FIELD(field) \
+ value \
+ = (*android_java_env)->GetIntField (android_java_env, \
+ font_info->object, \
+ font_object_class.field); \
+ font->field = value;
+
+ DO_CARDINAL_FIELD (min_width);
+ DO_CARDINAL_FIELD (max_width);
+ DO_CARDINAL_FIELD (pixel_size);
+ DO_CARDINAL_FIELD (height);
+ DO_CARDINAL_FIELD (space_width);
+ DO_CARDINAL_FIELD (average_width);
+ DO_CARDINAL_FIELD (ascent);
+ DO_CARDINAL_FIELD (descent);
+ DO_CARDINAL_FIELD (underline_thickness);
+ DO_CARDINAL_FIELD (underline_position);
+ DO_CARDINAL_FIELD (baseline_offset);
+ DO_CARDINAL_FIELD (relative_compose);
+ DO_CARDINAL_FIELD (default_ascent);
+ DO_CARDINAL_FIELD (encoding_charset);
+ DO_CARDINAL_FIELD (repertory_charset);
+
+#undef DO_CARDINAL_FIELD
+
+ /* This should eventually become unnecessary. */
+ font->props[FONT_NAME_INDEX] = Ffont_xlfd_name (font_object, Qnil, Qt);
+
+ return font_object;
+}
+
+static void
+androidfont_close_font (struct font *font)
+{
+ struct androidfont_info *info;
+ int i;
+
+ /* Maybe initialize the font driver. */
+ androidfont_check_init ();
+
+ info = (struct androidfont_info *) font;
+
+ /* Free the font metrics cache if it exists. */
+
+ if (info->metrics)
+ {
+ for (i = 0; i < 256; ++i)
+ xfree (info->metrics[i]);
+ xfree (info->metrics);
+ }
+
+ info->metrics = NULL;
+
+ /* If info->object is NULL, then FONT was unsuccessfully created,
+ and there is no global reference that has to be deleted.
+
+ Alternatively, FONT may have been closed by font_close_object,
+ with this function called from GC. */
+
+ if (!info->object)
+ return;
+
+ (*android_java_env)->DeleteGlobalRef (android_java_env,
+ info->object);
+ info->object = NULL;
+}
+
+static int
+androidfont_has_char (Lisp_Object font, int c)
+{
+ struct androidfont_info *info;
+ struct androidfont_entity *entity;
+
+ /* Maybe initialize the font driver. */
+ androidfont_check_init ();
+
+ if (FONT_ENTITY_P (font))
+ {
+ entity = (struct androidfont_entity *) XFONT_ENTITY (font);
+
+ return (*android_java_env)->CallIntMethod (android_java_env,
+ font_driver,
+ font_driver_class.has_char,
+ entity->object, (jint) c);
+ }
+ else
+ {
+ info = (struct androidfont_info *) XFONT_OBJECT (font);
+
+ return (*android_java_env)->CallIntMethod (android_java_env,
+ font_driver,
+ font_driver_class.has_char,
+ info->object, (jint) c);
+ }
+}
+
+static unsigned
+androidfont_encode_char (struct font *font, int c)
+{
+ struct androidfont_info *info;
+
+ /* Maybe initialize the font driver. */
+ androidfont_check_init ();
+
+ info = (struct androidfont_info *) font;
+
+ return (*android_java_env)->CallIntMethod (android_java_env,
+ font_driver,
+ font_driver_class.encode_char,
+ info->object, (jchar) c);
+}
+
+static void
+androidfont_cache_text_extents (struct androidfont_info *info,
+ unsigned int glyph,
+ struct font_metrics *metrics)
+{
+ int i;
+
+ /* Glyphs larger than 65535 can't be cached. */
+ if (glyph >= 256 * 256)
+ return;
+
+ if (!info->metrics)
+ info->metrics = xzalloc (256 * sizeof *info->metrics);
+
+ if (!info->metrics[glyph / 256])
+ {
+ info->metrics[glyph / 256]
+ = xnmalloc (256, sizeof **info->metrics);
+
+ /* Now, all the metrics in that array as invalid by setting
+ lbearing to SHRT_MAX. */
+ for (i = 0; i < 256; ++i)
+ info->metrics[glyph / 256][i].lbearing = SHRT_MAX;
+ }
+
+ /* Finally, cache the glyph. */
+ info->metrics[glyph / 256][glyph % 256] = *metrics;
+}
+
+static bool
+androidfont_check_cached_extents (struct androidfont_info *info,
+ unsigned int glyph,
+ struct font_metrics *metrics)
+{
+ if (info->metrics && info->metrics[glyph / 256]
+ && info->metrics[glyph / 256][glyph % 256].lbearing != SHRT_MAX)
+ {
+ *metrics = info->metrics[glyph / 256][glyph % 256];
+ return true;
+ }
+
+ return false;
+}
+
+static void
+androidfont_text_extents (struct font *font, const unsigned int *code,
+ int nglyphs, struct font_metrics *metrics)
+{
+ struct androidfont_info *info;
+ jarray codepoint_array;
+ jobject metrics_object;
+ short value;
+
+ /* Maybe initialize the font driver. */
+ androidfont_check_init ();
+
+ info = (struct androidfont_info *) font;
+
+ if (nglyphs == 1
+ && androidfont_check_cached_extents (info, *code, metrics))
+ return;
+
+ /* Allocate the arrays of code points and font metrics. */
+ codepoint_array
+ = (*android_java_env)->NewIntArray (android_java_env,
+ nglyphs);
+ if (!codepoint_array)
+ {
+ (*android_java_env)->ExceptionClear (android_java_env);
+ memory_full (0);
+ }
+
+ verify (sizeof (unsigned int) == sizeof (jint));
+
+ /* Always true on every Android device. */
+ (*android_java_env)->SetIntArrayRegion (android_java_env,
+ codepoint_array,
+ 0, nglyphs,
+ (jint *) code);
+
+ metrics_object
+ = (*android_java_env)->AllocObject (android_java_env,
+ font_metrics_class.class);
+
+ (*android_java_env)->CallVoidMethod (android_java_env,
+ font_driver,
+ font_driver_class.text_extents,
+ info->object, codepoint_array,
+ metrics_object);
+
+ if ((*android_java_env)->ExceptionCheck (android_java_env))
+ {
+ (*android_java_env)->ExceptionClear (android_java_env);
+ ANDROID_DELETE_LOCAL_REF (metrics_object);
+ ANDROID_DELETE_LOCAL_REF (codepoint_array);
+ memory_full (0);
+ }
+
+#define DO_CARDINAL_FIELD(field) \
+ value \
+ = (*android_java_env)->GetShortField (android_java_env, \
+ metrics_object, \
+ font_metrics_class.field); \
+ metrics->field = value;
+
+ DO_CARDINAL_FIELD (lbearing);
+ DO_CARDINAL_FIELD (rbearing);
+ DO_CARDINAL_FIELD (width);
+ DO_CARDINAL_FIELD (ascent);
+ DO_CARDINAL_FIELD (descent);
+
+#undef DO_CARDINAL_FIELD
+
+ ANDROID_DELETE_LOCAL_REF (metrics_object);
+ ANDROID_DELETE_LOCAL_REF (codepoint_array);
+
+ /* Emacs spends a lot of time in androidfont_text_extents, which
+ makes calling JNI too slow. Cache the metrics for this single
+ glyph. */
+
+ if (nglyphs == 1)
+ androidfont_cache_text_extents (info, *code, metrics);
+}
+
+static Lisp_Object
+androidfont_list_family (struct frame *f)
+{
+ Lisp_Object families;
+ jarray family_array;
+ jobject string;
+ jsize i, length;
+ const char *family;
+
+ /* Return if the Android font driver is not initialized. Loading
+ every font under Android takes a non trivial amount of memory,
+ and is not something that should be done when the user tries to
+ list all of the font families. */
+
+ if (!font_driver)
+ return Qnil;
+
+ family_array
+ = (*android_java_env)->CallObjectMethod (android_java_env,
+ font_driver,
+ font_driver_class.list_families);
+ android_exception_check ();
+
+ length = (*android_java_env)->GetArrayLength (android_java_env,
+ family_array);
+ families = Qnil;
+
+ for (i = 0; i < length; ++i)
+ {
+ string = (*android_java_env)->GetObjectArrayElement (android_java_env,
+ family_array, i);
+ family = (*android_java_env)->GetStringUTFChars (android_java_env,
+ (jstring) string, NULL);
+
+ if (!family)
+ {
+ ANDROID_DELETE_LOCAL_REF (string);
+ ANDROID_DELETE_LOCAL_REF (family_array);
+ }
+
+ families = Fcons (build_string_from_utf8 (string), families);
+ (*android_java_env)->ReleaseStringUTFChars (android_java_env,
+ (jstring) string,
+ family);
+ ANDROID_DELETE_LOCAL_REF (string);
+ }
+
+ ANDROID_DELETE_LOCAL_REF (family_array);
+ return Fnreverse (families);
+}
+
+struct font_driver androidfont_driver =
+ {
+ .type = LISPSYM_INITIALLY (Qandroid),
+ .case_sensitive = true,
+ .get_cache = androidfont_get_cache,
+ .list = androidfont_list,
+ .match = androidfont_match,
+ .draw = androidfont_draw,
+ .open_font = androidfont_open_font,
+ .close_font = androidfont_close_font,
+ .has_char = androidfont_has_char,
+ .encode_char = androidfont_encode_char,
+ .text_extents = androidfont_text_extents,
+ .list_family = androidfont_list_family,
+ };
+
+static void
+syms_of_androidfont_for_pdumper (void)
+{
+ register_font_driver (&androidfont_driver, NULL);
+}
+
+void
+syms_of_androidfont (void)
+{
+ DEFSYM (Qfontsize, "fontsize");
+
+ pdumper_do_now_and_after_load (syms_of_androidfont_for_pdumper);
+
+ font_cache = list (Qnil);
+ staticpro (&font_cache);
+}
+
+void
+init_androidfont (void)
+{
+ if (!android_init_gui)
+ return;
+
+ android_init_font_driver ();
+ android_init_font_spec ();
+ android_init_font_metrics ();
+ android_init_font_object ();
+ android_init_integer ();
+
+ /* The Java font driver is not initialized here because it uses a lot
+ of memory. */
+}
+
+void
+android_finalize_font_entity (struct font_entity *entity)
+{
+ struct androidfont_entity *info;
+
+ info = (struct androidfont_entity *) entity;
+
+ if (info->object)
+ (*android_java_env)->DeleteGlobalRef (android_java_env,
+ info->object);
+
+ /* Not sure if this can be called twice. */
+ info->object = NULL;
+}
+
+#endif
diff --git a/src/androidgui.h b/src/androidgui.h
new file mode 100644
index 00000000000..f941c7cc577
--- /dev/null
+++ b/src/androidgui.h
@@ -0,0 +1,847 @@
+/* Android window system support.
+ Copyright (C) 2023-2024 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 <https://www.gnu.org/licenses/>. */
+
+#ifndef _ANDROID_GUI_H_
+#define _ANDROID_GUI_H_
+
+struct android_char_struct
+{
+ int rbearing;
+ int lbearing;
+ int width;
+ int ascent;
+ int descent;
+};
+
+typedef struct android_char_struct XCharStruct;
+
+typedef unsigned short android_handle;
+
+typedef android_handle android_pixmap, Emacs_Pixmap;
+typedef android_handle android_window, Emacs_Window;
+typedef android_handle android_gcontext, GContext;
+typedef android_handle android_drawable, Drawable;
+typedef android_handle android_cursor, Emacs_Cursor;
+
+typedef unsigned int android_time;
+
+struct android_rectangle
+{
+ int x, y;
+ unsigned width, height;
+};
+
+struct android_point
+{
+ int x, y;
+};
+
+/* Keep this in sync with EmacsGC.java! */
+
+enum android_gc_function
+ {
+ ANDROID_GC_COPY = 0,
+ ANDROID_GC_XOR = 1,
+ };
+
+enum android_gc_value_mask
+ {
+ ANDROID_GC_FOREGROUND = (1 << 0),
+ ANDROID_GC_BACKGROUND = (1 << 1),
+ ANDROID_GC_FUNCTION = (1 << 2),
+ ANDROID_GC_CLIP_X_ORIGIN = (1 << 3),
+ ANDROID_GC_CLIP_Y_ORIGIN = (1 << 4),
+ ANDROID_GC_CLIP_MASK = (1 << 5),
+ ANDROID_GC_STIPPLE = (1 << 6),
+ ANDROID_GC_FILL_STYLE = (1 << 7),
+ ANDROID_GC_TILE_STIP_X_ORIGIN = (1 << 8),
+ ANDROID_GC_TILE_STIP_Y_ORIGIN = (1 << 9),
+ };
+
+enum android_fill_style
+ {
+ ANDROID_FILL_SOLID = 0,
+ ANDROID_FILL_OPAQUE_STIPPLED = 1,
+ };
+
+enum android_window_value_mask
+ {
+ ANDROID_CW_BACK_PIXEL = (1 << 1),
+ ANDROID_CW_OVERRIDE_REDIRECT = (1 << 2),
+ };
+
+struct android_set_window_attributes
+{
+ /* The background pixel. */
+ unsigned long background_pixel;
+
+ /* Whether or not the window is override redirect. This cannot be
+ set after creation on Android. */
+ bool override_redirect;
+};
+
+struct android_gc_values
+{
+ /* The foreground and background. */
+ unsigned long foreground, background;
+
+ /* The function. */
+ enum android_gc_function function;
+
+ /* The fill style. */
+ enum android_fill_style fill_style;
+
+ /* The clip X and Y origin. */
+ int clip_x_origin, clip_y_origin;
+
+ /* The clip mask image and stipple. */
+ android_pixmap clip_mask, stipple;
+
+ /* The tile-stipple X and Y origins. */
+ int ts_x_origin, ts_y_origin;
+};
+
+/* X-like graphics context structure. This is implemented in
+ EmacsGC.java, but a copy is kept here to avoid sending changes all
+ the time. */
+
+struct android_gc
+{
+ /* Array of clip rectangles. */
+ struct android_rectangle *clip_rects;
+
+ /* Number of clip rectangles. When -1, it means clipping should not
+ be applied. */
+ int num_clip_rects;
+
+ /* The Java-side handle. */
+ android_gcontext gcontext;
+
+ /* Current foreground color. */
+ unsigned long foreground;
+
+ /* Current background color. */
+ unsigned long background;
+
+ /* The function. */
+ enum android_gc_function function;
+
+ /* The fill style. */
+ enum android_fill_style fill_style;
+
+ /* The clip X and Y origin. */
+ int clip_x_origin, clip_y_origin;
+
+ /* The clip mask image and stipple. */
+ android_pixmap clip_mask, stipple;
+
+ /* The tile-stipple X and Y origins. */
+ int ts_x_origin, ts_y_origin;
+};
+
+enum android_swap_action
+ {
+ ANDROID_COPIED,
+ };
+
+enum android_shape
+ {
+ ANDROID_CONVEX,
+ };
+
+enum android_coord_mode
+ {
+ ANDROID_COORD_MODE_ORIGIN,
+ };
+
+struct android_swap_info
+{
+ /* The window to swap. */
+ android_window swap_window;
+
+ /* Unused field present only for consistency with X. */
+ enum android_swap_action swap_action;
+};
+
+#define NativeRectangle Emacs_Rectangle
+#define CONVERT_TO_NATIVE_RECT(xr, nr) ((xr) = (nr))
+#define CONVERT_FROM_EMACS_RECT(xr, nr) ((nr) = (xr))
+
+#define STORE_NATIVE_RECT(nr, rx, ry, rwidth, rheight) \
+ ((nr).x = (rx), (nr).y = (ry), \
+ (nr).width = (rwidth), (nr).height = (rheight)) \
+
+#define ForgetGravity 0
+#define NorthWestGravity 1
+#define NorthGravity 2
+#define NorthEastGravity 3
+#define WestGravity 4
+#define CenterGravity 5
+#define EastGravity 6
+#define SouthWestGravity 7
+#define SouthGravity 8
+#define SouthEastGravity 9
+#define StaticGravity 10
+
+#define NoValue 0x0000
+#define XValue 0x0001
+#define YValue 0x0002
+#define WidthValue 0x0004
+#define HeightValue 0x0008
+#define AllValues 0x000F
+#define XNegative 0x0010
+#define YNegative 0x0020
+
+#define USPosition (1L << 0) /* user specified x, y */
+#define USSize (1L << 1) /* user specified width, height */
+#define PPosition (1L << 2) /* program specified position */
+#define PSize (1L << 3) /* program specified size */
+#define PMinSize (1L << 4) /* program specified minimum size */
+#define PMaxSize (1L << 5) /* program specified maximum size */
+#define PResizeInc (1L << 6) /* program specified resize increments */
+#define PAspect (1L << 7) /* program specified min, max aspect ratios */
+#define PBaseSize (1L << 8) /* program specified base for incrementing */
+#define PWinGravity (1L << 9) /* program specified window gravity */
+
+#ifndef ANDROID_STUBIFY
+
+/* Universal NULL handle. */
+static const int ANDROID_NONE, ANDROID_NO_SYMBOL;
+
+/* Keep these as conceptually close to X as possible: that makes
+ synchronizing code between the ports much easier. */
+
+enum android_event_type
+ {
+ ANDROID_KEY_PRESS,
+ ANDROID_KEY_RELEASE,
+ ANDROID_CONFIGURE_NOTIFY,
+ ANDROID_FOCUS_IN,
+ ANDROID_FOCUS_OUT,
+ ANDROID_WINDOW_ACTION,
+ ANDROID_ENTER_NOTIFY,
+ ANDROID_LEAVE_NOTIFY,
+ ANDROID_MOTION_NOTIFY,
+ ANDROID_BUTTON_PRESS,
+ ANDROID_BUTTON_RELEASE,
+ ANDROID_TOUCH_DOWN,
+ ANDROID_TOUCH_UP,
+ ANDROID_TOUCH_MOVE,
+ ANDROID_WHEEL,
+ ANDROID_ICONIFIED,
+ ANDROID_DEICONIFIED,
+ ANDROID_CONTEXT_MENU,
+ ANDROID_EXPOSE,
+ ANDROID_INPUT_METHOD,
+ ANDROID_DND_DRAG_EVENT,
+ ANDROID_DND_URI_EVENT,
+ ANDROID_DND_TEXT_EVENT,
+ ANDROID_NOTIFICATION_DELETED,
+ ANDROID_NOTIFICATION_ACTION,
+ };
+
+struct android_any_event
+{
+ enum android_event_type type;
+ unsigned long serial;
+ android_window window;
+};
+
+enum android_modifier_mask
+ {
+ ANDROID_SHIFT_MASK = 193,
+ ANDROID_CONTROL_MASK = 4096,
+ ANDROID_ALT_MASK = 2,
+ ANDROID_SUPER_MASK = 4,
+ ANDROID_META_MASK = 65536,
+ };
+
+struct android_key_event
+{
+ enum android_event_type type;
+ unsigned long serial;
+ android_window window;
+ android_time time;
+ unsigned int state;
+ unsigned int keycode;
+
+ /* If this field is -1, then android_lookup_string should be called
+ to retrieve the associated individual characters. */
+ unsigned int unicode_char;
+
+ /* If this field is non-zero, a text conversion barrier should be
+ generated with its value as the counter. */
+ unsigned long counter;
+};
+
+typedef struct android_key_event android_key_pressed_event;
+
+/* These hard coded values are Android modifier keycodes derived
+ through experimentation. */
+
+#define ANDROID_IS_MODIFIER_KEY(key) \
+ ((key) == 57 || (key) == 58 || (key) == 113 || (key) == 114 \
+ || (key) == 119 || (key) == 117 || (key) == 118 || (key) == 78 \
+ || (key) == 94 || (key) == 59 || (key) == 60 || (key) == 95 \
+ || (key) == 63 || (key) == 115)
+
+struct android_configure_event
+{
+ enum android_event_type type;
+ unsigned long serial;
+ android_window window;
+ android_time time;
+ int x, y;
+ int width, height;
+};
+
+struct android_focus_event
+{
+ enum android_event_type type;
+ unsigned long serial;
+ android_window window;
+ android_time time;
+};
+
+struct android_window_action_event
+{
+ enum android_event_type type;
+ unsigned long serial;
+
+ /* The window handle. This can be ANDROID_NONE. */
+ android_window window;
+
+ /* Numerical identifier for this action. If 0 and WINDOW is set,
+ then it means the frame associated with that window has been
+ destroyed. Otherwise, it means Emacs should create a new
+ frame. */
+ unsigned int action;
+};
+
+struct android_crossing_event
+{
+ enum android_event_type type;
+ unsigned long serial;
+ android_window window;
+ int x, y;
+ unsigned long time;
+};
+
+struct android_motion_event
+{
+ enum android_event_type type;
+ unsigned long serial;
+ android_window window;
+ int x, y;
+ unsigned long time;
+};
+
+struct android_button_event
+{
+ enum android_event_type type;
+ unsigned long serial;
+ android_window window;
+ int x, y;
+ unsigned long time;
+ unsigned int state;
+ unsigned int button;
+};
+
+struct android_expose_event
+{
+ enum android_event_type type;
+ unsigned long serial;
+ android_window window;
+ int x, y;
+ int width, height;
+};
+
+enum android_touch_event_flags
+ {
+ /* This touch sequence has been intercepted by the WM (probably
+ for back gesture navigation or some such.) */
+ ANDROID_TOUCH_SEQUENCE_CANCELED = 1,
+ };
+
+struct android_touch_event
+{
+ /* Type of the event. */
+ enum android_event_type type;
+
+ /* Serial identifying the event. */
+ unsigned long serial;
+
+ /* Window associated with the event. */
+ android_window window;
+
+ /* X and Y coordinates of the event. */
+ int x, y;
+
+ /* Time of the event, and the pointer identifier. */
+ unsigned long time;
+
+ /* Index of the pointer being tracked. */
+ unsigned int pointer_id;
+
+ /* Flags associated with this event. */
+ int flags;
+};
+
+struct android_wheel_event
+{
+ /* Type of the event. */
+ enum android_event_type type;
+
+ /* Serial identifying the event. */
+ unsigned long serial;
+
+ /* Window associated with the event. */
+ android_window window;
+
+ /* X and Y coordinates of the event. */
+ int x, y;
+
+ /* Time of the event, and the pointer identifier. */
+ unsigned long time;
+
+ /* Modifier state at the time of the event. */
+ int state;
+
+ /* Motion alongside the X and Y axes. */
+ double x_delta, y_delta;
+};
+
+struct android_iconify_event
+{
+ /* Type of the event. */
+ enum android_event_type type;
+
+ /* Serial identifying the event. */
+ unsigned long serial;
+
+ /* Window associated with the event. */
+ android_window window;
+};
+
+struct android_menu_event
+{
+ /* Type of the event. */
+ enum android_event_type type;
+
+ /* Serial identifying the event. */
+ unsigned long serial;
+
+ /* Window associated with the event. Always None. */
+ android_window window;
+
+ /* Menu event ID. */
+ int menu_event_id;
+
+ /* Menu event serial; this counter identifies the context menu. */
+ int menu_event_serial;
+};
+
+enum android_ime_operation
+ {
+ ANDROID_IME_COMMIT_TEXT,
+ ANDROID_IME_DELETE_SURROUNDING_TEXT,
+ ANDROID_IME_FINISH_COMPOSING_TEXT,
+ ANDROID_IME_SET_COMPOSING_TEXT,
+ ANDROID_IME_SET_COMPOSING_REGION,
+ ANDROID_IME_SET_POINT,
+ ANDROID_IME_START_BATCH_EDIT,
+ ANDROID_IME_END_BATCH_EDIT,
+ ANDROID_IME_REQUEST_SELECTION_UPDATE,
+ ANDROID_IME_REQUEST_CURSOR_UPDATES,
+ ANDROID_IME_REPLACE_TEXT,
+ };
+
+enum
+ {
+ ANDROID_CURSOR_UPDATE_IMMEDIATE = 1,
+ ANDROID_CURSOR_UPDATE_MONITOR = (1 << 1),
+ };
+
+struct android_ime_event
+{
+ /* Type of the event. */
+ enum android_event_type type;
+
+ /* The event serial. */
+ unsigned long serial;
+
+ /* The associated window. */
+ android_window window;
+
+ /* What operation is being performed. */
+ enum android_ime_operation operation;
+
+ /* The details of the operation. START and END provide buffer
+ indices, and may actually mean ``left'' and ``right''. */
+ ptrdiff_t start, end, position;
+
+ /* The number of characters in TEXT.
+
+ If OPERATION is ANDROID_IME_REQUEST_CURSOR_UPDATES, then this is
+ actually the cursor update mode associated with that
+ operation. */
+ size_t length;
+
+ /* TEXT is either NULL, or a pointer to LENGTH bytes of malloced
+ UTF-16 encoded text that must be decoded by Emacs.
+
+ POSITION is where point should end up after the text is
+ committed, relative to TEXT. If POSITION is less than 0, it is
+ relative to TEXT's start; otherwise, it is relative to its
+ end. */
+ unsigned short *text;
+
+ /* Value to set the counter to after the operation completes. */
+ unsigned long counter;
+};
+
+struct android_dnd_event
+{
+ /* Type of the event. */
+ enum android_event_type type;
+
+ /* The event serial. */
+ unsigned long serial;
+
+ /* The window that gave rise to the event. */
+ android_window window;
+
+ /* X and Y coordinates of the event. */
+ int x, y;
+
+ /* Data tied to this event, such as a URI or clipboard string.
+ Must be deallocated with `free'. */
+ unsigned short *uri_or_string;
+
+ /* Length of that data. */
+ size_t length;
+};
+
+struct android_notification_event
+{
+ /* Type of the event. */
+ enum android_event_type type;
+
+ /* The event serial. */
+ unsigned long serial;
+
+ /* The window that gave rise to the event (None). */
+ android_window window;
+
+ /* The identifier of the notification whose status changed.
+ Must be deallocated with `free'. */
+ char *tag;
+
+ /* The action that was activated, if any. Must be deallocated with
+ `free'. */
+ unsigned short *action;
+
+ /* Length of that data. */
+ size_t length;
+};
+
+union android_event
+{
+ enum android_event_type type;
+ struct android_any_event xany;
+ struct android_key_event xkey;
+ struct android_configure_event xconfigure;
+ struct android_focus_event xfocus;
+ struct android_window_action_event xaction;
+ struct android_crossing_event xcrossing;
+ struct android_motion_event xmotion;
+ struct android_button_event xbutton;
+ struct android_expose_event xexpose;
+
+ /* This has no parallel in X, since the X model of having
+ monotonically increasing touch IDs can't work on Android. */
+ struct android_touch_event touch;
+
+ /* This has no parallel in X outside the X Input Extension, and
+ emulating the input extension interface would be awfully
+ complicated. */
+ struct android_wheel_event wheel;
+
+ /* This has no parallel in X because Android doesn't have window
+ properties. */
+ struct android_iconify_event iconified;
+
+ /* This is only used to transmit selected menu items. */
+ struct android_menu_event menu;
+
+ /* This is used to dispatch input method editing requests. */
+ struct android_ime_event ime;
+
+ /* There is no analog under X because Android defines a strict DND
+ protocol, whereas there exist several competing X protocols
+ implemented in terms of X client messages. */
+ struct android_dnd_event dnd;
+
+ /* X provides no equivalent interface for displaying
+ notifications. */
+ struct android_notification_event notification;
+};
+
+enum
+ {
+ ANDROID_CURRENT_TIME = 0L,
+ };
+
+enum android_lookup_status
+ {
+ ANDROID_BUFFER_OVERFLOW,
+ ANDROID_LOOKUP_NONE,
+ ANDROID_LOOKUP_CHARS,
+ ANDROID_LOOKUP_KEYSYM,
+ ANDROID_LOOKUP_BOTH,
+ };
+
+enum android_ic_mode
+ {
+ ANDROID_IC_MODE_NULL = 0,
+ ANDROID_IC_MODE_ACTION = 1,
+ ANDROID_IC_MODE_TEXT = 2,
+ ANDROID_IC_MODE_PASSWORD = 3,
+ };
+
+enum android_stack_mode
+ {
+ ANDROID_ABOVE = 0,
+ ANDROID_BELOW = 1,
+ };
+
+enum android_wc_value_mask
+ {
+ ANDROID_CW_SIBLING = 0,
+ ANDROID_CW_STACK_MODE = 1,
+ };
+
+struct android_window_changes
+{
+ android_window sibling;
+ enum android_stack_mode stack_mode;
+};
+
+struct android_compose_status
+{
+ /* Accent character to be combined with another. */
+ unsigned int accent;
+
+ /* Number of characters matched. */
+ int chars_matched;
+};
+
+extern int android_pending (void);
+extern void android_next_event (union android_event *);
+extern bool android_check_if_event (union android_event *,
+ bool (*) (union android_event *,
+ void *),
+ void *);
+
+extern android_window android_create_window (android_window, int,
+ int, int, int,
+ enum android_window_value_mask,
+ struct
+ android_set_window_attributes *);
+extern void android_change_window_attributes (android_window,
+ enum android_window_value_mask,
+ struct
+ android_set_window_attributes *);
+extern void android_set_window_background (android_window, unsigned long);
+extern void android_destroy_window (android_window);
+extern void android_reparent_window (android_window, android_window,
+ int, int);
+extern void android_set_clip_rectangles (struct android_gc *,
+ int, int,
+ struct android_rectangle *,
+ int);
+extern void android_change_gc (struct android_gc *,
+ enum android_gc_value_mask,
+ struct android_gc_values *);
+
+extern void android_clear_window (android_window);
+extern void android_map_window (android_window);
+extern void android_unmap_window (android_window);
+extern void android_resize_window (android_window, unsigned int,
+ unsigned int);
+extern void android_move_window (android_window, int, int);
+extern void android_swap_buffers (struct android_swap_info *, int);
+extern void android_get_gc_values (struct android_gc *,
+ enum android_gc_value_mask,
+ struct android_gc_values *);
+extern void android_set_foreground (struct android_gc *,
+ unsigned long);
+extern void android_fill_rectangle (android_drawable, struct android_gc *,
+ int, int, unsigned int, unsigned int);
+extern android_pixmap android_create_pixmap_from_bitmap_data (char *,
+ unsigned int,
+ unsigned int,
+ unsigned long,
+ unsigned long,
+ unsigned int);
+extern void android_set_clip_mask (struct android_gc *, android_pixmap);
+extern void android_set_fill_style (struct android_gc *,
+ enum android_fill_style);
+extern void android_copy_area (android_drawable, android_drawable,
+ struct android_gc *, int, int,
+ unsigned int, unsigned int, int, int);
+extern void android_free_pixmap (android_drawable);
+
+extern void android_set_background (struct android_gc *, unsigned long);
+extern void android_fill_polygon (android_drawable, struct android_gc *,
+ struct android_point *, int,
+ enum android_shape,
+ enum android_coord_mode);
+extern void android_draw_rectangle (android_drawable, struct android_gc *,
+ int, int, unsigned int, unsigned int);
+extern void android_draw_point (android_window, struct android_gc *,
+ int, int);
+extern void android_draw_line (android_window, struct android_gc *,
+ int, int, int, int);
+extern android_pixmap android_create_pixmap (unsigned int, unsigned int,
+ int);
+extern void android_set_ts_origin (struct android_gc *, int, int);
+extern void android_clear_area (android_window, int, int, unsigned int,
+ unsigned int);
+extern android_pixmap android_create_bitmap_from_data (char *, unsigned int,
+ unsigned int);
+
+extern void android_bell (void);
+extern void android_set_input_focus (android_window, unsigned long);
+extern void android_raise_window (android_window);
+extern void android_lower_window (android_window);
+extern void android_reconfigure_wm_window (android_window,
+ enum android_wc_value_mask,
+ struct android_window_changes *);
+extern int android_query_tree (android_window, android_window *,
+ android_window *, android_window **,
+ unsigned int *);
+extern void android_get_geometry (android_window, android_window *,
+ int *, int *, unsigned int *,
+ unsigned int *, unsigned int *);
+extern void android_move_resize_window (android_window, int, int,
+ unsigned int, unsigned int);
+extern void android_map_raised (android_window);
+extern void android_translate_coordinates (android_window, int,
+ int, int *, int *);
+extern int android_wc_lookup_string (android_key_pressed_event *,
+ wchar_t *, int, int *,
+ enum android_lookup_status *,
+ struct android_compose_status *);
+extern void android_recreate_activity (android_window);
+extern void android_update_ic (android_window, ptrdiff_t, ptrdiff_t,
+ ptrdiff_t, ptrdiff_t);
+extern void android_reset_ic (android_window, enum android_ic_mode);
+extern void android_update_extracted_text (android_window, void *,
+ int);
+extern void android_update_cursor_anchor_info (android_window, float,
+ float, float, float);
+extern int android_set_fullscreen (android_window, bool);
+
+enum android_cursor_shape
+ {
+ ANDROID_XC_XTERM = 1008,
+ ANDROID_XC_LEFT_PTR = 1000,
+ ANDROID_XC_WATCH = 1004,
+ ANDROID_XC_HAND2 = 1002,
+ ANDROID_XC_SB_H_DOUBLE_ARROW = 1014,
+ ANDROID_XC_SB_V_DOUBLE_ARROW = 1015,
+ ANDROID_XC_LEFT_SIDE = 1020,
+ ANDROID_XC_TOP_LEFT_CORNER = 1020,
+ ANDROID_XC_TOP_SIDE = 1020,
+ ANDROID_XC_TOP_RIGHT_CORNER = 1020,
+ ANDROID_XC_RIGHT_SIDE = 1020,
+ ANDROID_XC_BOTTOM_RIGHT_CORNER = 1020,
+ ANDROID_XC_BOTTOM_SIDE = 1020,
+ ANDROID_XC_BOTTOM_LEFT_CORNER = 1020,
+ ANDROID_XC_NULL = 0,
+ };
+
+extern android_cursor android_create_font_cursor (enum android_cursor_shape);
+extern void android_define_cursor (android_window, android_cursor);
+extern void android_free_cursor (android_cursor);
+
+#endif
+
+
+
+/* Image support. Keep the API as similar to XImage as possible. To
+ avoid leaving a huge mess of "#ifndef ANDROID_STUBIFY" in image.c,
+ stubs should be defined for all functions. */
+
+enum android_image_format
+ {
+ ANDROID_Z_PIXMAP,
+ };
+
+struct android_image
+{
+ int width, height;
+ enum android_image_format format;
+ char *data;
+ int depth;
+ int bytes_per_line;
+ int bits_per_pixel;
+};
+
+extern struct android_image *android_create_image (unsigned int,
+ enum android_image_format,
+ char *, unsigned int,
+ unsigned int);
+extern void android_destroy_image (struct android_image *);
+
+extern void android_put_pixel (struct android_image *, int, int,
+ unsigned long);
+extern unsigned long android_get_pixel (struct android_image *, int, int);
+extern struct android_image *android_get_image (android_drawable,
+ enum android_image_format);
+extern void android_put_image (android_pixmap, struct android_image *);
+
+
+/* Native image transforms. */
+
+/* 3x2 matrix describing a projective transform. See
+ android_transform_coordinates for details. */
+
+struct android_transform
+{
+ float m1, m2, m3;
+ float m4, m5, m6;
+};
+
+extern void android_project_image_bilinear (struct android_image *,
+ struct android_image *,
+ struct android_transform *);
+extern void android_project_image_nearest (struct android_image *,
+ struct android_image *,
+ struct android_transform *);
+
+
+
+/* X emulation stuff also needed while building stubs. */
+
+extern struct android_gc *android_create_gc (enum android_gc_value_mask,
+ struct android_gc_values *);
+extern void android_free_gc (struct android_gc *);
+
+#endif /* _ANDROID_GUI_H_ */
diff --git a/src/androidmenu.c b/src/androidmenu.c
new file mode 100644
index 00000000000..362d500ac1a
--- /dev/null
+++ b/src/androidmenu.c
@@ -0,0 +1,861 @@
+/* Communication module for Android terminals.
+
+Copyright (C) 2023-2024 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 <https://www.gnu.org/licenses/>. */
+
+#include <config.h>
+
+#include "lisp.h"
+#include "androidterm.h"
+#include "android.h"
+#include "blockinput.h"
+#include "keyboard.h"
+#include "menu.h"
+
+#ifndef ANDROID_STUBIFY
+
+#include <android/log.h>
+
+/* Flag indicating whether or not a popup menu has been posted and not
+ yet popped down. */
+
+static int popup_activated_flag;
+
+/* Serial number used to identify which context menu events are
+ associated with the context menu currently being displayed. */
+
+unsigned int current_menu_serial;
+
+int
+popup_activated (void)
+{
+ return popup_activated_flag;
+}
+
+
+
+/* Toolkit menu implementation. */
+
+/* Structure describing the EmacsContextMenu class. */
+
+struct android_emacs_context_menu
+{
+ jclass class;
+ jmethodID create_context_menu;
+ jmethodID add_item;
+ jmethodID add_submenu;
+ jmethodID add_pane;
+ jmethodID parent;
+ jmethodID display;
+ jmethodID dismiss;
+};
+
+/* Identifiers associated with the EmacsContextMenu class. */
+static struct android_emacs_context_menu menu_class;
+
+static void
+android_init_emacs_context_menu (void)
+{
+ jclass old;
+
+ menu_class.class
+ = (*android_java_env)->FindClass (android_java_env,
+ "org/gnu/emacs/EmacsContextMenu");
+ eassert (menu_class.class);
+
+ old = menu_class.class;
+ menu_class.class
+ = (jclass) (*android_java_env)->NewGlobalRef (android_java_env,
+ (jobject) old);
+ ANDROID_DELETE_LOCAL_REF (old);
+
+ if (!menu_class.class)
+ emacs_abort ();
+
+#define FIND_METHOD(c_name, name, signature) \
+ menu_class.c_name \
+ = (*android_java_env)->GetMethodID (android_java_env, \
+ menu_class.class, \
+ name, signature); \
+ eassert (menu_class.c_name);
+
+#define FIND_METHOD_STATIC(c_name, name, signature) \
+ menu_class.c_name \
+ = (*android_java_env)->GetStaticMethodID (android_java_env, \
+ menu_class.class, \
+ name, signature); \
+ eassert (menu_class.c_name);
+
+ FIND_METHOD_STATIC (create_context_menu, "createContextMenu",
+ "(Ljava/lang/String;)"
+ "Lorg/gnu/emacs/EmacsContextMenu;");
+
+ FIND_METHOD (add_item, "addItem", "(ILjava/lang/String;ZZZ"
+ "Ljava/lang/String;Z)V");
+ FIND_METHOD (add_submenu, "addSubmenu", "(Ljava/lang/String;"
+ "Ljava/lang/String;)"
+ "Lorg/gnu/emacs/EmacsContextMenu;");
+ FIND_METHOD (add_pane, "addPane", "(Ljava/lang/String;)V");
+ FIND_METHOD (parent, "parent", "()Lorg/gnu/emacs/EmacsContextMenu;");
+ FIND_METHOD (display, "display", "(Lorg/gnu/emacs/EmacsWindow;III)Z");
+ FIND_METHOD (dismiss, "dismiss", "(Lorg/gnu/emacs/EmacsWindow;)V");
+
+#undef FIND_METHOD
+#undef FIND_METHOD_STATIC
+}
+
+static void
+android_unwind_local_frame (void)
+{
+ (*android_java_env)->PopLocalFrame (android_java_env, NULL);
+}
+
+/* Push a local reference frame to the JVM stack and record it on the
+ specpdl. Release local references created within that frame when
+ the specpdl is unwound past where it is after returning. */
+
+static void
+android_push_local_frame (void)
+{
+ int rc;
+
+ rc = (*android_java_env)->PushLocalFrame (android_java_env, 30);
+
+ /* This means the JVM ran out of memory. */
+ if (rc < 1)
+ android_exception_check ();
+
+ record_unwind_protect_void (android_unwind_local_frame);
+}
+
+/* Data for android_dismiss_menu. */
+
+struct android_dismiss_menu_data
+{
+ /* The menu object. */
+ jobject menu;
+
+ /* The window object. */
+ jobject window;
+};
+
+/* Cancel the context menu passed in POINTER. Also, clear
+ popup_activated_flag. */
+
+static void
+android_dismiss_menu (void *pointer)
+{
+ struct android_dismiss_menu_data *data;
+
+ data = pointer;
+ (*android_java_env)->CallNonvirtualVoidMethod (android_java_env,
+ data->menu,
+ menu_class.class,
+ menu_class.dismiss,
+ data->window);
+ popup_activated_flag = 0;
+}
+
+/* Recursively process events until a ANDROID_CONTEXT_MENU event
+ arrives. Then, return the item ID specified in the event in
+ *ID. */
+
+static void
+android_process_events_for_menu (int *id)
+{
+ int blocked;
+
+ /* Set menu_event_id to -1; handle_one_android_event will set it to
+ the event ID upon receiving a context menu event. This can cause
+ a non-local exit. */
+ x_display_list->menu_event_id = -1;
+
+ /* Unblock input completely. */
+ blocked = interrupt_input_blocked;
+ totally_unblock_input ();
+
+ /* Now wait for the menu event ID to change. */
+ while (x_display_list->menu_event_id == -1)
+ {
+ /* Wait for events to become available. */
+ android_wait_event ();
+
+ /* Process pending signals. */
+ process_pending_signals ();
+
+ /* Maybe quit. This is important because the framework (on
+ Android 4.0.3) can sometimes fail to deliver context menu
+ closed events if a submenu was opened, and the user still
+ needs to be able to quit. */
+ maybe_quit ();
+ }
+
+ /* Restore the input block. */
+ interrupt_input_blocked = blocked;
+
+ /* Return the ID. */
+ *id = x_display_list->menu_event_id;
+}
+
+/* Structure describing a ``subprefix'' in the menu. */
+
+struct android_menu_subprefix
+{
+ /* The subprefix above. */
+ struct android_menu_subprefix *last;
+
+ /* The subprefix itself. */
+ Lisp_Object subprefix;
+};
+
+/* Free the subprefixes starting from *DATA. */
+
+static void
+android_free_subprefixes (void *data)
+{
+ struct android_menu_subprefix **head, *subprefix;
+
+ head = data;
+
+ while (*head)
+ {
+ subprefix = *head;
+ *head = subprefix->last;
+
+ xfree (subprefix);
+ }
+}
+
+Lisp_Object
+android_menu_show (struct frame *f, int x, int y, int menuflags,
+ Lisp_Object title, const char **error_name)
+{
+ jobject context_menu, current_context_menu;
+ jobject title_string, help_string, temp;
+ size_t i;
+ Lisp_Object pane_name, prefix;
+ specpdl_ref count, count1;
+ Lisp_Object item_name, enable, def, tem, entry, type, selected;
+ Lisp_Object help;
+ jmethodID method;
+ jobject store;
+ bool rc;
+ jobject window;
+ int id, item_id, submenu_depth;
+ struct android_dismiss_menu_data data;
+ struct android_menu_subprefix *subprefix, *temp_subprefix;
+ struct android_menu_subprefix *subprefix_1;
+ bool checkmark;
+ unsigned int serial;
+ JNIEnv *env;
+
+ count = SPECPDL_INDEX ();
+ serial = ++current_menu_serial;
+ env = android_java_env;
+
+ block_input ();
+
+ /* Push the first local frame. */
+ android_push_local_frame ();
+
+ /* Set title_string to a Java string containing TITLE if non-nil.
+ If the menu consists of more than one pane, replace the title
+ with the pane header item so that the menu looks consistent. */
+
+ title_string = NULL;
+ if (STRINGP (title) && menu_items_n_panes < 2)
+ title_string = android_build_string (title, NULL);
+
+ /* Push the first local frame for the context menu. */
+ method = menu_class.create_context_menu;
+ current_context_menu = context_menu
+ = (*android_java_env)->CallStaticObjectMethod (android_java_env,
+ menu_class.class,
+ method,
+ title_string);
+
+ /* Delete the unused title reference. */
+
+ if (title_string)
+ ANDROID_DELETE_LOCAL_REF (title_string);
+
+ /* Push the second local frame for temporaries. */
+ count1 = SPECPDL_INDEX ();
+ android_push_local_frame ();
+
+ /* Iterate over the menu. */
+ i = 0, submenu_depth = 0;
+
+ while (i < menu_items_used)
+ {
+ if (NILP (AREF (menu_items, i)))
+ {
+ /* This is the start of a new submenu. However, it can be
+ ignored here. */
+ i += 1;
+ submenu_depth += 1;
+ }
+ else if (EQ (AREF (menu_items, i), Qlambda))
+ {
+ /* This is the end of a submenu. Go back to the previous
+ context menu. */
+ store = current_context_menu;
+ current_context_menu
+ = (*env)->CallNonvirtualObjectMethod (env,
+ current_context_menu,
+ menu_class.class,
+ menu_class.parent);
+ android_exception_check ();
+
+ if (store != context_menu)
+ ANDROID_DELETE_LOCAL_REF (store);
+ i += 1;
+ submenu_depth -= 1;
+
+ if (!current_context_menu || submenu_depth < 0)
+ {
+ __android_log_print (ANDROID_LOG_FATAL, __func__,
+ "unbalanced submenu pop in menu_items");
+ emacs_abort ();
+ }
+ }
+ else if (EQ (AREF (menu_items, i), Qt)
+ && submenu_depth != 0)
+ i += MENU_ITEMS_PANE_LENGTH;
+ else if (EQ (AREF (menu_items, i), Qquote))
+ i += 1;
+ else if (EQ (AREF (menu_items, i), Qt))
+ {
+ /* If the menu contains a single pane, then the pane is
+ actually TITLE. Don't duplicate the text within the
+ context menu title. */
+
+ if (menu_items_n_panes < 2)
+ goto next_item;
+
+ /* This is a new pane. Switch back to the topmost context
+ menu. */
+ if (current_context_menu != context_menu)
+ ANDROID_DELETE_LOCAL_REF (current_context_menu);
+ current_context_menu = context_menu;
+
+ /* Now figure out the title of this pane. */
+ pane_name = AREF (menu_items, i + MENU_ITEMS_PANE_NAME);
+ prefix = AREF (menu_items, i + MENU_ITEMS_PANE_PREFIX);
+
+ /* PANE_NAME may be nil, in which case it must be set to an
+ empty string. */
+
+ if (NILP (pane_name))
+ pane_name = empty_unibyte_string;
+
+ /* Remove the leading prefix character if need be. */
+
+ if ((menuflags & MENU_KEYMAPS) && !NILP (prefix)
+ && SCHARS (prefix))
+ pane_name = Fsubstring (pane_name, make_fixnum (1), Qnil);
+
+ /* Add the pane. */
+ temp = android_build_string (pane_name, NULL);
+ android_exception_check ();
+
+ (*env)->CallNonvirtualVoidMethod (env, current_context_menu,
+ menu_class.class,
+ menu_class.add_pane, temp);
+ android_exception_check ();
+ ANDROID_DELETE_LOCAL_REF (temp);
+
+ next_item:
+ i += MENU_ITEMS_PANE_LENGTH;
+ }
+ else
+ {
+ item_name = AREF (menu_items, i + MENU_ITEMS_ITEM_NAME);
+ enable = AREF (menu_items, i + MENU_ITEMS_ITEM_ENABLE);
+ def = AREF (menu_items, i + MENU_ITEMS_ITEM_DEFINITION);
+ type = AREF (menu_items, i + MENU_ITEMS_ITEM_TYPE);
+ selected = AREF (menu_items, i + MENU_ITEMS_ITEM_SELECTED);
+ help = AREF (menu_items, i + MENU_ITEMS_ITEM_HELP);
+
+ /* This is an actual menu item (or submenu). Add it to the
+ menu. */
+
+ if (i + MENU_ITEMS_ITEM_LENGTH < menu_items_used
+ && NILP (AREF (menu_items, i + MENU_ITEMS_ITEM_LENGTH)))
+ {
+ /* This is a submenu. Add it. */
+ title_string = (!NILP (item_name)
+ ? android_build_string (item_name, NULL)
+ : NULL);
+ help_string = NULL;
+
+ /* Menu items can have tool tips on Android 26 and
+ later. In this case, set it to the help string. */
+
+ if (android_get_current_api_level () >= 26
+ && STRINGP (help))
+ help_string = android_build_string (help, NULL);
+
+ store = current_context_menu;
+ current_context_menu
+ = (*env)->CallNonvirtualObjectMethod (env,
+ current_context_menu,
+ menu_class.class,
+ menu_class.add_submenu,
+ title_string,
+ help_string);
+ android_exception_check ();
+
+ if (store != context_menu)
+ ANDROID_DELETE_LOCAL_REF (store);
+
+ if (title_string)
+ ANDROID_DELETE_LOCAL_REF (title_string);
+
+ if (help_string)
+ ANDROID_DELETE_LOCAL_REF (help_string);
+ }
+ else if (NILP (def) && menu_separator_name_p (SSDATA (item_name)))
+ /* Ignore this separator item. */
+ ;
+ else
+ {
+ /* Compute the item ID. This is the index of value.
+ Make sure it doesn't overflow. */
+
+ if (ckd_add (&item_id, i + MENU_ITEMS_ITEM_VALUE, 0))
+ memory_full (i + MENU_ITEMS_ITEM_VALUE * sizeof (Lisp_Object));
+
+ /* Add this menu item with the appropriate state. */
+
+ title_string = (!NILP (item_name)
+ ? android_build_string (item_name, NULL)
+ : NULL);
+ help_string = NULL;
+
+ /* Menu items can have tool tips on Android 26 and
+ later. In this case, set it to the help string. */
+
+ if (android_get_current_api_level () >= 26
+ && STRINGP (help))
+ help_string = android_build_string (help, NULL);
+
+ /* Determine whether or not to display a check box. */
+
+ checkmark = (EQ (type, QCtoggle)
+ || EQ (type, QCradio));
+
+ (*env)->CallNonvirtualVoidMethod (env,
+ current_context_menu,
+ menu_class.class,
+ menu_class.add_item,
+ (jint) item_id,
+ title_string,
+ (jboolean) !NILP (enable),
+ (jboolean) checkmark,
+ (jboolean) !NILP (selected),
+ help_string,
+ (jboolean) (EQ (type,
+ QCradio)));
+ android_exception_check ();
+
+ if (title_string)
+ ANDROID_DELETE_LOCAL_REF (title_string);
+
+ if (help_string)
+ ANDROID_DELETE_LOCAL_REF (help_string);
+ }
+
+ i += MENU_ITEMS_ITEM_LENGTH;
+ }
+ }
+
+ /* The menu has now been built. Pop the second local frame. */
+ unbind_to (count1, Qnil);
+
+ /* Now, display the context menu. */
+ window = android_resolve_handle (FRAME_ANDROID_WINDOW (f),
+ ANDROID_HANDLE_WINDOW);
+ rc = (*env)->CallNonvirtualBooleanMethod (env, context_menu,
+ menu_class.class,
+ menu_class.display,
+ window, (jint) x,
+ (jint) y,
+ (jint) serial);
+ android_exception_check ();
+
+ if (!rc)
+ /* This means displaying the menu failed. */
+ goto finish;
+
+ /* Make sure the context menu is always dismissed. */
+ data.menu = context_menu;
+ data.window = window;
+ record_unwind_protect_ptr (android_dismiss_menu, &data);
+
+ /* Next, process events waiting for something to be selected. */
+ popup_activated_flag = 1;
+ android_process_events_for_menu (&id);
+
+ if (!id)
+ /* This means no menu item was selected. */
+ goto finish;
+
+ /* This means the id is invalid. */
+ if (id >= ASIZE (menu_items))
+ goto finish;
+
+ /* Now return the menu item at that location. */
+ tem = Qnil;
+ subprefix = NULL;
+ record_unwind_protect_ptr (android_free_subprefixes, &subprefix);
+
+ /* Find the selected item, and its pane, to return
+ the proper value. */
+
+ prefix = entry = Qnil;
+ i = 0;
+ while (i < menu_items_used)
+ {
+ if (NILP (AREF (menu_items, i)))
+ {
+ temp_subprefix = xmalloc (sizeof *temp_subprefix);
+ temp_subprefix->last = subprefix;
+ subprefix = temp_subprefix;
+ subprefix->subprefix = prefix;
+
+ prefix = entry;
+ i++;
+ }
+ else if (EQ (AREF (menu_items, i), Qlambda))
+ {
+ prefix = subprefix->subprefix;
+ temp_subprefix = subprefix->last;
+ xfree (subprefix);
+ subprefix = temp_subprefix;
+
+ i++;
+ }
+ else if (EQ (AREF (menu_items, i), Qt))
+ {
+ prefix
+ = AREF (menu_items, i + MENU_ITEMS_PANE_PREFIX);
+ i += MENU_ITEMS_PANE_LENGTH;
+ }
+ /* Ignore a nil in the item list.
+ It's meaningful only for dialog boxes. */
+ else if (EQ (AREF (menu_items, i), Qquote))
+ i += 1;
+ else
+ {
+ entry = AREF (menu_items, i + MENU_ITEMS_ITEM_VALUE);
+
+ if (i + MENU_ITEMS_ITEM_VALUE == id)
+ {
+ if (menuflags & MENU_KEYMAPS)
+ {
+ entry = list1 (entry);
+
+ if (!NILP (prefix))
+ entry = Fcons (prefix, entry);
+
+ for (subprefix_1 = subprefix; subprefix_1;
+ subprefix_1 = subprefix_1->last)
+ if (!NILP (subprefix_1->subprefix))
+ entry = Fcons (subprefix_1->subprefix, entry);
+ }
+
+ tem = entry;
+ }
+ i += MENU_ITEMS_ITEM_LENGTH;
+ }
+ }
+
+ unblock_input ();
+ return unbind_to (count, tem);
+
+ finish:
+ unblock_input ();
+ return unbind_to (count, Qnil);
+}
+
+
+
+/* Toolkit dialog implementation. */
+
+/* Structure describing the EmacsDialog class. */
+
+struct android_emacs_dialog
+{
+ jclass class;
+ jmethodID create_dialog;
+ jmethodID add_button;
+ jmethodID display;
+};
+
+/* Identifiers associated with the EmacsDialog class. */
+static struct android_emacs_dialog dialog_class;
+
+static void
+android_init_emacs_dialog (void)
+{
+ jclass old;
+
+ dialog_class.class
+ = (*android_java_env)->FindClass (android_java_env,
+ "org/gnu/emacs/EmacsDialog");
+ eassert (dialog_class.class);
+
+ old = dialog_class.class;
+ dialog_class.class
+ = (jclass) (*android_java_env)->NewGlobalRef (android_java_env,
+ (jobject) old);
+ ANDROID_DELETE_LOCAL_REF (old);
+
+ if (!dialog_class.class)
+ emacs_abort ();
+
+#define FIND_METHOD(c_name, name, signature) \
+ dialog_class.c_name \
+ = (*android_java_env)->GetMethodID (android_java_env, \
+ dialog_class.class, \
+ name, signature); \
+ eassert (dialog_class.c_name);
+
+#define FIND_METHOD_STATIC(c_name, name, signature) \
+ dialog_class.c_name \
+ = (*android_java_env)->GetStaticMethodID (android_java_env, \
+ dialog_class.class, \
+ name, signature); \
+
+ FIND_METHOD_STATIC (create_dialog, "createDialog", "(Ljava/lang/String;"
+ "Ljava/lang/String;I)Lorg/gnu/emacs/EmacsDialog;");
+ FIND_METHOD (add_button, "addButton", "(Ljava/lang/String;IZ)V");
+ FIND_METHOD (display, "display", "()Z");
+
+#undef FIND_METHOD
+#undef FIND_METHOD_STATIC
+}
+
+static Lisp_Object
+android_dialog_show (struct frame *f, Lisp_Object title,
+ Lisp_Object header, const char **error_name)
+{
+ specpdl_ref count;
+ jobject dialog, java_header, java_title, temp;
+ size_t i;
+ Lisp_Object item_name, enable, entry;
+ bool rc;
+ int id;
+ jmethodID method;
+ unsigned int serial;
+ JNIEnv *env;
+
+ /* Generate a unique ID for events from this dialog box. */
+ serial = ++current_menu_serial;
+
+ if (menu_items_n_panes > 1)
+ {
+ *error_name = "Multiple panes in dialog box";
+ return Qnil;
+ }
+
+ /* Do the initial setup. */
+ count = SPECPDL_INDEX ();
+ *error_name = NULL;
+
+ android_push_local_frame ();
+
+ /* Figure out what header to use. */
+ java_header = (!NILP (header)
+ ? android_build_jstring ("Information")
+ : android_build_jstring ("Question"));
+
+ /* And the title. */
+ java_title = android_build_string (title, NULL);
+
+ /* Now create the dialog. */
+ method = dialog_class.create_dialog;
+ dialog = (*android_java_env)->CallStaticObjectMethod (android_java_env,
+ dialog_class.class,
+ method, java_header,
+ java_title,
+ (jint) serial);
+ android_exception_check ();
+
+ /* Delete now unused local references. */
+ if (java_header)
+ ANDROID_DELETE_LOCAL_REF (java_header);
+ ANDROID_DELETE_LOCAL_REF (java_title);
+
+ /* Save the JNI environment pointer prior to constructing the
+ dialog, as typing (*android_java_env)->... gives rise to very
+ long lines. */
+ env = android_java_env;
+
+ /* Create the buttons. */
+ i = MENU_ITEMS_PANE_LENGTH;
+ while (i < menu_items_used)
+ {
+ item_name = AREF (menu_items, i + MENU_ITEMS_ITEM_NAME);
+ enable = AREF (menu_items, i + MENU_ITEMS_ITEM_ENABLE);
+
+ /* Verify that there is no submenu here. */
+
+ if (NILP (item_name))
+ {
+ *error_name = "Submenu in dialog items";
+ return unbind_to (count, Qnil);
+ }
+
+ /* Skip past boundaries between buttons on different sides. The
+ Android toolkit is too silly to understand this
+ distinction. */
+
+ if (EQ (item_name, Qquote))
+ ++i;
+ else
+ {
+ /* Make sure i is within bounds. */
+ if (i > TYPE_MAXIMUM (jint))
+ {
+ *error_name = "Dialog box too big";
+ return unbind_to (count, Qnil);
+ }
+
+ /* Add the button. */
+ temp = android_build_string (item_name, NULL);
+ (*env)->CallNonvirtualVoidMethod (env, dialog,
+ dialog_class.class,
+ dialog_class.add_button,
+ temp, (jint) i,
+ (jboolean) NILP (enable));
+ android_exception_check ();
+ ANDROID_DELETE_LOCAL_REF (temp);
+ i += MENU_ITEMS_ITEM_LENGTH;
+ }
+ }
+
+ /* The dialog is now built. Run it. */
+ rc = (*env)->CallNonvirtualBooleanMethod (env, dialog,
+ dialog_class.class,
+ dialog_class.display);
+ android_exception_check ();
+
+ if (!rc)
+ quit ();
+
+ /* Wait for the menu ID to arrive. */
+ android_process_events_for_menu (&id);
+
+ if (!id)
+ quit ();
+
+ /* Find the selected item, and its pane, to return
+ the proper value. */
+ i = 0;
+ while (i < menu_items_used)
+ {
+ if (EQ (AREF (menu_items, i), Qt))
+ i += MENU_ITEMS_PANE_LENGTH;
+ else if (EQ (AREF (menu_items, i), Qquote))
+ /* This is the boundary between left-side elts and right-side
+ elts. */
+ ++i;
+ else
+ {
+ entry = AREF (menu_items, i + MENU_ITEMS_ITEM_VALUE);
+
+ if (id == i)
+ return entry;
+
+ i += MENU_ITEMS_ITEM_LENGTH;
+ }
+ }
+
+ return Qnil;
+}
+
+Lisp_Object
+android_popup_dialog (struct frame *f, Lisp_Object header,
+ Lisp_Object contents)
+{
+ Lisp_Object title;
+ const char *error_name;
+ Lisp_Object selection;
+ specpdl_ref specpdl_count = SPECPDL_INDEX ();
+
+ check_window_system (f);
+
+ /* Decode the dialog items from what was specified. */
+ title = Fcar (contents);
+ CHECK_STRING (title);
+ record_unwind_protect_void (unuse_menu_items);
+
+ if (NILP (Fcar (Fcdr (contents))))
+ /* No buttons specified, add an "Ok" button so users can pop down
+ the dialog. */
+ contents = list2 (title, Fcons (build_string ("Ok"), Qt));
+
+ list_of_panes (list1 (contents));
+
+ /* Display them in a dialog box. */
+ block_input ();
+ selection = android_dialog_show (f, title, header, &error_name);
+ unblock_input ();
+
+ unbind_to (specpdl_count, Qnil);
+ discard_menu_items ();
+
+ if (error_name)
+ error ("%s", error_name);
+
+ return selection;
+}
+
+#else
+
+int
+popup_activated (void)
+{
+ return 0;
+}
+
+#endif
+
+DEFUN ("menu-or-popup-active-p", Fmenu_or_popup_active_p,
+ Smenu_or_popup_active_p, 0, 0, 0,
+ doc: /* SKIP: real doc in xfns.c. */)
+ (void)
+{
+ return (popup_activated ()) ? Qt : Qnil;
+}
+
+void
+init_androidmenu (void)
+{
+#ifndef ANDROID_STUBIFY
+ android_init_emacs_context_menu ();
+ android_init_emacs_dialog ();
+#endif
+}
+
+void
+syms_of_androidmenu (void)
+{
+ defsubr (&Smenu_or_popup_active_p);
+}
diff --git a/src/androidselect.c b/src/androidselect.c
new file mode 100644
index 00000000000..2f6114d0fcb
--- /dev/null
+++ b/src/androidselect.c
@@ -0,0 +1,1056 @@
+/* Communication module for Android terminals.
+
+Copyright (C) 2023-2024 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 <https://www.gnu.org/licenses/>. */
+
+#include <config.h>
+#include <assert.h>
+#include <minmax.h>
+#include <unistd.h>
+
+#include <boot-time.h>
+#include <sys/types.h>
+
+#include "lisp.h"
+#include "blockinput.h"
+#include "coding.h"
+#include "android.h"
+#include "androidterm.h"
+#include "termhooks.h"
+
+/* Selection support on Android is confined to copying and pasting of
+ plain text and MIME data from the clipboard. There is no primary
+ selection.
+
+ While newer versions of Android are supposed to have the necessary
+ interfaces for transferring other kinds of selection data, doing so
+ is too complicated, and involves registering ``content providers''
+ and all kinds of other stuff; for this reason, Emacs does not
+ support setting the clipboard contents to anything other than plain
+ text. */
+
+
+
+/* Structure describing the EmacsClipboard class. */
+
+struct android_emacs_clipboard
+{
+ jclass class;
+ jmethodID set_clipboard;
+ jmethodID owns_clipboard;
+ jmethodID clipboard_exists;
+ jmethodID get_clipboard;
+ jmethodID make_clipboard;
+ jmethodID get_clipboard_targets;
+ jmethodID get_clipboard_data;
+};
+
+/* Methods associated with the EmacsClipboard class. */
+static struct android_emacs_clipboard clipboard_class;
+
+/* Reference to the EmacsClipboard object. */
+static jobject clipboard;
+
+
+
+static void
+android_init_emacs_clipboard (void)
+{
+ jclass old;
+
+ clipboard_class.class
+ = (*android_java_env)->FindClass (android_java_env,
+ "org/gnu/emacs/EmacsClipboard");
+ eassert (clipboard_class.class);
+
+ old = clipboard_class.class;
+ clipboard_class.class
+ = (jclass) (*android_java_env)->NewGlobalRef (android_java_env,
+ old);
+ ANDROID_DELETE_LOCAL_REF (old);
+
+ if (!clipboard_class.class)
+ emacs_abort ();
+
+#define FIND_METHOD(c_name, name, signature) \
+ clipboard_class.c_name \
+ = (*android_java_env)->GetMethodID (android_java_env, \
+ clipboard_class.class, \
+ name, signature); \
+ eassert (clipboard_class.c_name);
+
+ FIND_METHOD (set_clipboard, "setClipboard", "([B)V");
+ FIND_METHOD (owns_clipboard, "ownsClipboard", "()I");
+ FIND_METHOD (clipboard_exists, "clipboardExists", "()Z");
+ FIND_METHOD (get_clipboard, "getClipboard", "()[B");
+ FIND_METHOD (get_clipboard_targets, "getClipboardTargets",
+ "()[[B");
+ FIND_METHOD (get_clipboard_data, "getClipboardData",
+ "([B)[J");
+
+ clipboard_class.make_clipboard
+ = (*android_java_env)->GetStaticMethodID (android_java_env,
+ clipboard_class.class,
+ "makeClipboard",
+ "()Lorg/gnu/emacs/"
+ "EmacsClipboard;");
+ eassert (clipboard_class.make_clipboard);
+
+#undef FIND_METHOD
+}
+
+
+
+
+DEFUN ("android-clipboard-owner-p", Fandroid_clipboard_owner_p,
+ Sandroid_clipboard_owner_p, 0, 0, 0,
+ doc: /* Return whether or not Emacs owns the clipboard.
+Alternatively, return the symbol `lambda' if that could not be
+determined. */)
+ (void)
+{
+ jint rc;
+
+ if (!android_init_gui)
+ error ("Accessing clipboard without display connection");
+
+ block_input ();
+ rc = (*android_java_env)->CallIntMethod (android_java_env,
+ clipboard,
+ clipboard_class.owns_clipboard);
+ android_exception_check ();
+ unblock_input ();
+
+ /* If rc is 0 or 1, then Emacs knows whether or not it owns the
+ clipboard. If rc is -1, then Emacs does not. */
+
+ if (rc < 0)
+ return Qlambda;
+
+ return rc ? Qt : Qnil;
+}
+
+DEFUN ("android-set-clipboard", Fandroid_set_clipboard,
+ Sandroid_set_clipboard, 1, 1, 0,
+ doc: /* Set the clipboard text to STRING. */)
+ (Lisp_Object string)
+{
+ jarray bytes;
+
+ if (!android_init_gui)
+ error ("Accessing clipboard without display connection");
+
+ CHECK_STRING (string);
+ string = ENCODE_UTF_8 (string);
+
+ bytes = (*android_java_env)->NewByteArray (android_java_env,
+ SBYTES (string));
+ android_exception_check ();
+
+ (*android_java_env)->SetByteArrayRegion (android_java_env, bytes,
+ 0, SBYTES (string),
+ (jbyte *) SDATA (string));
+ (*android_java_env)->CallVoidMethod (android_java_env,
+ clipboard,
+ clipboard_class.set_clipboard,
+ bytes);
+ android_exception_check_1 (bytes);
+
+ ANDROID_DELETE_LOCAL_REF (bytes);
+ return Qnil;
+}
+
+DEFUN ("android-get-clipboard", Fandroid_get_clipboard,
+ Sandroid_get_clipboard, 0, 0, 0,
+ doc: /* Return the current contents of the clipboard.
+Value is a multibyte string containing decoded clipboard
+text.
+Alternatively, return nil if the clipboard is empty. */)
+ (void)
+{
+ Lisp_Object string;
+ jarray bytes;
+ jmethodID method;
+ size_t length;
+ jbyte *data;
+
+ if (!android_init_gui)
+ error ("No Android display connection!");
+
+ method = clipboard_class.get_clipboard;
+ bytes
+ = (*android_java_env)->CallObjectMethod (android_java_env,
+ clipboard,
+ method);
+ android_exception_check ();
+
+ if (!bytes)
+ return Qnil;
+
+ length = (*android_java_env)->GetArrayLength (android_java_env,
+ bytes);
+ data = (*android_java_env)->GetByteArrayElements (android_java_env,
+ bytes, NULL);
+ android_exception_check_nonnull (data, bytes);
+
+ string = make_unibyte_string ((char *) data, length);
+
+ (*android_java_env)->ReleaseByteArrayElements (android_java_env,
+ bytes, data,
+ JNI_ABORT);
+ ANDROID_DELETE_LOCAL_REF (bytes);
+
+ /* Now decode the resulting string. */
+ return code_convert_string_norecord (string, Qutf_8, false);
+}
+
+DEFUN ("android-clipboard-exists-p", Fandroid_clipboard_exists_p,
+ Sandroid_clipboard_exists_p, 0, 0, 0,
+ doc: /* Return whether or not clipboard contents exist. */)
+ (void)
+{
+ jboolean rc;
+ jmethodID method;
+
+ if (!android_init_gui)
+ error ("No Android display connection");
+
+ method = clipboard_class.clipboard_exists;
+ rc = (*android_java_env)->CallBooleanMethod (android_java_env,
+ clipboard,
+ method);
+ android_exception_check ();
+
+ return rc ? Qt : Qnil;
+}
+
+DEFUN ("android-browse-url-internal", Fandroid_browse_url_internal,
+ Sandroid_browse_url_internal, 1, 2, 0,
+ doc: /* Open URL in an external application.
+
+URL should be a URL-encoded URL with a scheme specified unless SEND is
+non-nil. Signal an error upon failure.
+
+If SEND is nil, start a program that is able to display the URL, such
+as a web browser. Otherwise, try to share URL using programs such as
+email clients.
+
+If URL is a file URI, convert it into a `content' address accessible to
+other programs. Files inside the /content or /assets directories cannot
+be opened through such addresses, which this function does not provide
+for. Use `android-browse-url' instead. */)
+ (Lisp_Object url, Lisp_Object send)
+{
+ Lisp_Object value;
+
+ if (!android_init_gui)
+ error ("No Android display connection!");
+
+ CHECK_STRING (url);
+ value = android_browse_url (url, send);
+
+ /* Signal an error upon failure. */
+ if (!NILP (value))
+ signal_error ("Error browsing URL", value);
+
+ return Qnil;
+}
+
+
+
+/* MIME clipboard support. This provides support for reading MIME
+ data (but not text) from the clipboard. */
+
+DEFUN ("android-get-clipboard-targets", Fandroid_get_clipboard_targets,
+ Sandroid_get_clipboard_targets, 0, 0, 0,
+ doc: /* Return a list of data types in the clipboard.
+Value is a list of MIME types as strings, each defining a single extra
+data type available from the clipboard. */)
+ (void)
+{
+ jarray bytes_array;
+ jbyteArray bytes;
+ jmethodID method;
+ size_t length, length1, i;
+ jbyte *data;
+ Lisp_Object targets, tem;
+
+ if (!android_init_gui)
+ error ("No Android display connection!");
+
+ targets = Qnil;
+ block_input ();
+ method = clipboard_class.get_clipboard_targets;
+ bytes_array = (*android_java_env)->CallObjectMethod (android_java_env,
+ clipboard, method);
+ android_exception_check ();
+
+ if (!bytes_array)
+ goto fail;
+
+ length = (*android_java_env)->GetArrayLength (android_java_env,
+ bytes_array);
+ for (i = 0; i < length; ++i)
+ {
+ /* Retrieve the MIME type. */
+ bytes
+ = (*android_java_env)->GetObjectArrayElement (android_java_env,
+ bytes_array, i);
+ android_exception_check_nonnull (bytes, bytes_array);
+
+ /* Cons it onto the list of targets. */
+ length1 = (*android_java_env)->GetArrayLength (android_java_env,
+ bytes);
+ data = (*android_java_env)->GetByteArrayElements (android_java_env,
+ bytes, NULL);
+ android_exception_check_nonnull_1 (data, bytes, bytes_array);
+
+ /* Decode the string. */
+ tem = make_unibyte_string ((char *) data, length1);
+ tem = code_convert_string_norecord (tem, Qutf_8, false);
+ targets = Fcons (tem, targets);
+
+ /* Delete the retrieved data. */
+ (*android_java_env)->ReleaseByteArrayElements (android_java_env,
+ bytes, data,
+ JNI_ABORT);
+ ANDROID_DELETE_LOCAL_REF (bytes);
+ }
+ unblock_input ();
+
+ ANDROID_DELETE_LOCAL_REF (bytes_array);
+ return Fnreverse (targets);
+
+ fail:
+ unblock_input ();
+ return Qnil;
+}
+
+/* Free the memory inside PTR, a pointer to a char pointer. */
+
+static void
+android_xfree_inside (void *ptr)
+{
+ xfree (*(char **) ptr);
+}
+
+DEFUN ("android-get-clipboard-data", Fandroid_get_clipboard_data,
+ Sandroid_get_clipboard_data, 1, 1, 0,
+ doc: /* Return the clipboard data of the given MIME TYPE.
+Value is a unibyte string containing the entire contents of the
+clipboard, after its owner has converted the data to the given
+MIME type. Value is nil if the conversion fails, or if the data
+is not present.
+
+Value is also nil if the clipboard data consists of a single URL which
+does not have any corresponding data. In that case, use
+`android-get-clipboard' instead. */)
+ (Lisp_Object type)
+{
+ jlongArray array;
+ jbyteArray bytes;
+ jmethodID method;
+ int fd;
+ ptrdiff_t rc;
+ jlong offset, length, *longs;
+ specpdl_ref ref;
+ char *buffer, *start;
+
+ if (!android_init_gui)
+ error ("No Android display connection!");
+
+ /* Encode the string as UTF-8. */
+ CHECK_STRING (type);
+ type = ENCODE_UTF_8 (type);
+
+ /* Then give it to the selection code. */
+ block_input ();
+ bytes = (*android_java_env)->NewByteArray (android_java_env,
+ SBYTES (type));
+ (*android_java_env)->SetByteArrayRegion (android_java_env, bytes,
+ 0, SBYTES (type),
+ (jbyte *) SDATA (type));
+ android_exception_check ();
+
+ method = clipboard_class.get_clipboard_data;
+ array = (*android_java_env)->CallObjectMethod (android_java_env,
+ clipboard, method,
+ bytes);
+ android_exception_check_1 (bytes);
+ ANDROID_DELETE_LOCAL_REF (bytes);
+
+ if (!array)
+ goto fail;
+
+ longs = (*android_java_env)->GetLongArrayElements (android_java_env,
+ array, NULL);
+ android_exception_check_nonnull (longs, array);
+
+ /* longs[0] is the file descriptor.
+ longs[1] is an offset to apply to the file.
+ longs[2] is either -1, or the number of bytes to read from the
+ file. */
+ fd = longs[0];
+ offset = longs[1];
+ length = longs[2];
+
+ (*android_java_env)->ReleaseLongArrayElements (android_java_env,
+ array, longs,
+ JNI_ABORT);
+ ANDROID_DELETE_LOCAL_REF (array);
+ unblock_input ();
+
+ /* Now begin reading from longs[0]. */
+ ref = SPECPDL_INDEX ();
+ record_unwind_protect_int (close_file_unwind, fd);
+
+ if (length != -1)
+ {
+ buffer = xmalloc (MIN (length, PTRDIFF_MAX));
+ record_unwind_protect_ptr (xfree, buffer);
+
+ rc = emacs_read_quit (fd, buffer,
+ MIN (length, PTRDIFF_MAX));
+
+ /* Return nil upon an IO problem. */
+ if (rc < 0)
+ return unbind_to (ref, Qnil);
+
+ /* Return the data as a unibyte string. */
+ return unbind_to (ref, make_unibyte_string (buffer, rc));
+ }
+
+ /* Otherwise, read BUFSIZ bytes at a time. */
+ buffer = xmalloc (BUFSIZ);
+ length = 0;
+ start = buffer;
+
+ record_unwind_protect_ptr (android_xfree_inside, &buffer);
+
+ /* Seek to the start of the data. */
+
+ if (offset)
+ {
+ if (lseek (fd, offset, SEEK_SET) < 0)
+ return unbind_to (ref, Qnil);
+ }
+
+ while (true)
+ {
+ rc = emacs_read_quit (fd, start, BUFSIZ);
+
+ if (ckd_add (&length, length, rc)
+ || PTRDIFF_MAX - length < BUFSIZ)
+ memory_full (PTRDIFF_MAX);
+
+ if (rc < 0)
+ return unbind_to (ref, Qnil);
+
+ if (rc < BUFSIZ)
+ break;
+
+ buffer = xrealloc (buffer, length + BUFSIZ);
+ start = buffer + length;
+ }
+
+ return unbind_to (ref, make_unibyte_string (buffer, rc));
+
+ fail:
+ unblock_input ();
+ return Qnil;
+}
+
+
+
+/* Desktop notifications. `android-desktop-notify' implements a
+ facsimile of `notifications-notify'. */
+
+/* Structure describing the EmacsDesktopNotification class. */
+
+struct android_emacs_desktop_notification
+{
+ jclass class;
+ jmethodID init;
+ jmethodID display;
+};
+
+/* Methods provided by the EmacsDesktopNotification class. */
+static struct android_emacs_desktop_notification notification_class;
+
+/* Hash table pairing notification identifiers with callbacks. */
+static Lisp_Object notification_table;
+
+/* Initialize virtual function IDs and class pointers tied to the
+ EmacsDesktopNotification class. */
+
+static void
+android_init_emacs_desktop_notification (void)
+{
+ jclass old;
+
+ notification_class.class
+ = (*android_java_env)->FindClass (android_java_env,
+ "org/gnu/emacs/EmacsDesktopNotification");
+ eassert (notification_class.class);
+
+ old = notification_class.class;
+ notification_class.class
+ = (jclass) (*android_java_env)->NewGlobalRef (android_java_env,
+ old);
+ ANDROID_DELETE_LOCAL_REF (old);
+
+ if (!notification_class.class)
+ emacs_abort ();
+
+#define FIND_METHOD(c_name, name, signature) \
+ notification_class.c_name \
+ = (*android_java_env)->GetMethodID (android_java_env, \
+ notification_class.class, \
+ name, signature); \
+ eassert (notification_class.c_name);
+
+ FIND_METHOD (init, "<init>", "(Ljava/lang/String;"
+ "Ljava/lang/String;Ljava/lang/String;"
+ "Ljava/lang/String;II[Ljava/lang/String;"
+ "[Ljava/lang/String;J)V");
+ FIND_METHOD (display, "display", "()V");
+#undef FIND_METHOD
+}
+
+/* Return the numeric resource ID designating the icon within the
+ ``android.R.drawable'' package by the supplied NAME.
+
+ If no icon is found, return that of
+ ``android.R.drawable.ic_dialog_alert''. */
+
+static jint
+android_locate_icon (const char *name)
+{
+ jclass drawable;
+ jfieldID field;
+ jint rc;
+
+ if (android_verify_jni_string (name))
+ /* If NAME isn't valid, return the default value. */
+ return 17301543; /* android.R.drawable.ic_dialog_alert. */
+
+ drawable = (*android_java_env)->FindClass (android_java_env,
+ "android/R$drawable");
+ android_exception_check ();
+
+ field = (*android_java_env)->GetStaticFieldID (android_java_env,
+ drawable, name, "I");
+ (*android_java_env)->ExceptionClear (android_java_env);
+
+ if (!field)
+ rc = 17301543; /* android.R.drawable.ic_dialog_alert. */
+ else
+ rc = (*android_java_env)->GetStaticIntField (android_java_env,
+ drawable, field);
+
+ ANDROID_DELETE_LOCAL_REF (drawable);
+ return rc;
+}
+
+/* Display a desktop notification with the provided TITLE, BODY,
+ REPLACES_ID, GROUP, ICON, URGENCY, ACTIONS, TIMEOUT, RESIDENT,
+ ACTION_CB and CLOSE_CB. Return an identifier for the resulting
+ notification. */
+
+static intmax_t
+android_notifications_notify_1 (Lisp_Object title, Lisp_Object body,
+ Lisp_Object replaces_id,
+ Lisp_Object group, Lisp_Object icon,
+ Lisp_Object urgency, Lisp_Object actions,
+ Lisp_Object timeout, Lisp_Object resident,
+ Lisp_Object action_cb, Lisp_Object close_cb)
+{
+ static intmax_t counter;
+ intmax_t id;
+ jstring title1, body1, group1, identifier1;
+ jint type, icon1;
+ jobject notification;
+ jobjectArray action_keys, action_titles;
+ char identifier[INT_STRLEN_BOUND (int)
+ + INT_STRLEN_BOUND (long int)
+ + INT_STRLEN_BOUND (intmax_t)
+ + sizeof "..."];
+ struct timespec boot_time;
+ Lisp_Object key, value, tem;
+ jint nitems, i;
+ jstring item;
+ Lisp_Object length;
+ jlong timeout_val;
+
+ if (EQ (urgency, Qlow))
+ type = 2; /* IMPORTANCE_LOW */
+ else if (EQ (urgency, Qnormal))
+ type = 3; /* IMPORTANCE_DEFAULT */
+ else if (EQ (urgency, Qcritical))
+ type = 4; /* IMPORTANCE_HIGH */
+ else
+ signal_error ("Invalid notification importance given", urgency);
+
+ /* Decode the timeout. */
+
+ timeout_val = 0;
+
+ if (!NILP (timeout))
+ {
+ CHECK_INTEGER (timeout);
+
+ if (!integer_to_intmax (timeout, &id)
+ || id > TYPE_MAXIMUM (jlong)
+ || id < TYPE_MINIMUM (jlong))
+ signal_error ("Invalid timeout", timeout);
+
+ if (id > 0)
+ timeout_val = id;
+ }
+
+ nitems = 0;
+
+ /* If ACTIONS is provided, split it into two arrays of Java strings
+ holding keys and titles. */
+
+ if (!NILP (actions))
+ {
+ /* Count the number of items to be inserted. */
+
+ length = Flength (actions);
+ if (!TYPE_RANGED_FIXNUMP (jint, length))
+ error ("Action list too long");
+ nitems = XFIXNAT (length);
+ if (nitems & 1)
+ error ("Length of action list is invalid");
+ nitems /= 2;
+
+ /* Verify that the list consists exclusively of strings. */
+ tem = actions;
+ FOR_EACH_TAIL (tem)
+ CHECK_STRING (XCAR (tem));
+ }
+
+ if (NILP (replaces_id))
+ {
+ /* Generate a new identifier. */
+ ckd_add (&counter, counter, 1);
+ id = counter;
+ }
+ else
+ {
+ CHECK_INTEGER (replaces_id);
+ if (!integer_to_intmax (replaces_id, &id))
+ id = -1; /* Overflow. */
+ }
+
+ /* Locate the integer ID linked to ICON. */
+ icon1 = android_locate_icon (SSDATA (icon));
+
+ /* Generate a unique identifier for this notification. Because
+ Android persists notifications past system shutdown, also include
+ the boot time within IDENTIFIER. Scale it down to avoid being
+ perturbed by minor instabilities in the returned boot time,
+ however. */
+
+ boot_time.tv_sec = 0;
+ get_boot_time (&boot_time);
+ sprintf (identifier, "%d.%ld.%jd", (int) getpid (),
+ (long int) (boot_time.tv_sec / 2), id);
+
+ /* Encode all strings into their Java counterparts. */
+ title1 = android_build_string (title, NULL);
+ body1 = android_build_string (body, title1, NULL);
+ group1 = android_build_string (group, body1, title1, NULL);
+ identifier1
+ = (*android_java_env)->NewStringUTF (android_java_env, identifier);
+ android_exception_check_3 (title1, body1, group1);
+
+ /* Create the arrays for action identifiers and titles if
+ provided. */
+
+ if (nitems)
+ {
+ action_keys = (*android_java_env)->NewObjectArray (android_java_env,
+ nitems,
+ java_string_class,
+ NULL);
+ android_exception_check_4 (title, body1, group1, identifier1);
+ action_titles = (*android_java_env)->NewObjectArray (android_java_env,
+ nitems,
+ java_string_class,
+ NULL);
+ android_exception_check_5 (title, body1, group1, identifier1,
+ action_keys);
+
+ for (i = 0; i < nitems; ++i)
+ {
+ key = XCAR (actions);
+ value = XCAR (XCDR (actions));
+ actions = XCDR (XCDR (actions));
+
+ /* Create a string for this action. */
+ item = android_build_string (key, body1, group1, identifier1,
+ action_keys, action_titles, NULL);
+ (*android_java_env)->SetObjectArrayElement (android_java_env,
+ action_keys, i,
+ item);
+ ANDROID_DELETE_LOCAL_REF (item);
+
+ /* Create a string for this title. */
+ item = android_build_string (value, body1, group1, identifier1,
+ action_keys, action_titles, NULL);
+ (*android_java_env)->SetObjectArrayElement (android_java_env,
+ action_titles, i,
+ item);
+ ANDROID_DELETE_LOCAL_REF (item);
+ }
+ }
+ else
+ {
+ action_keys = NULL;
+ action_titles = NULL;
+ }
+
+ /* Create the notification. */
+ notification
+ = (*android_java_env)->NewObject (android_java_env,
+ notification_class.class,
+ notification_class.init,
+ title1, body1, group1,
+ identifier1, icon1, type,
+ action_keys, action_titles,
+ timeout_val);
+ android_exception_check_6 (title1, body1, group1, identifier1,
+ action_titles, action_keys);
+
+ /* Delete unused local references. */
+ ANDROID_DELETE_LOCAL_REF (title1);
+ ANDROID_DELETE_LOCAL_REF (body1);
+ ANDROID_DELETE_LOCAL_REF (group1);
+ ANDROID_DELETE_LOCAL_REF (identifier1);
+ ANDROID_DELETE_LOCAL_REF (action_keys);
+ ANDROID_DELETE_LOCAL_REF (action_titles);
+
+ /* Display the notification. */
+ (*android_java_env)->CallNonvirtualVoidMethod (android_java_env,
+ notification,
+ notification_class.class,
+ notification_class.display);
+ android_exception_check_1 (notification);
+ ANDROID_DELETE_LOCAL_REF (notification);
+
+ /* If callbacks are provided, save them into notification_table. */
+
+ if (!NILP (action_cb) || !NILP (close_cb) || !NILP (resident))
+ Fputhash (build_string (identifier), list3 (action_cb, close_cb,
+ resident),
+ notification_table);
+
+ /* Return the ID. */
+ return id;
+}
+
+DEFUN ("android-notifications-notify", Fandroid_notifications_notify,
+ Sandroid_notifications_notify, 0, MANY, 0, doc:
+ /* Display a desktop notification.
+ARGS must contain keywords followed by values. Each of the following
+keywords is understood:
+
+ :title The notification title.
+ :body The notification body.
+ :replaces-id The ID of a previous notification to supersede.
+ :group The notification group, or nil.
+ :urgency One of the symbols `low', `normal' or `critical',
+ defining the importance of the notification group.
+ :icon The name of a drawable resource to display as the
+ notification's icon.
+ :actions A list of actions of the form:
+ (KEY TITLE KEY TITLE ...)
+ where KEY and TITLE are both strings.
+ The action for which CALLBACK is called when the
+ notification itself is selected is named "default",
+ its existence is implied, and its TITLE is ignored.
+ No more than three actions defined here will be
+ displayed, not counting any with "default" as its
+ key.
+ :timeout Number of miliseconds from the display of the
+ notification at which it will be automatically
+ dismissed, or a value of zero or smaller if it
+ is to remain until user action is taken to dismiss
+ it.
+ :resident When set the notification will not be automatically
+ dismissed when it or an action is selected.
+ :on-action Function to call when an action is invoked.
+ The notification id and the key of the action are
+ provided as arguments to the function.
+ :on-close Function to call if the notification is dismissed,
+ with the notification id and the symbol `undefined'
+ for arguments.
+
+The notification group and timeout are ignored on Android 7.1 and
+earlier versions of Android. On more recent versions, the group
+identifies a category that will be displayed in the system Settings
+menu, and the urgency provided always extends to affect all
+notifications displayed within that category, though it may be ignored
+if higher than any previously-specified urgency or if the user have
+already configured a different urgency for this category from Settings.
+If the group is not provided, it defaults to the string "Desktop
+Notifications" with the urgency suffixed.
+
+Each caller should strive to provide one unchanging combination of
+notification group and urgency for each kind of notification it sends,
+inasmuch as the system may, subject to user configuration, disregard
+the urgency specified within a notification, should it not be the
+first notification sent to its notification group.
+
+The provided icon should be the name of a "drawable resource" present
+within the "android.R.drawable" class designating an icon with a
+transparent background. Should no icon be provided (or the icon is
+absent from this system), it defaults to "ic_dialog_alert".
+
+Actions specified with :actions cannot be displayed on Android 4.0 and
+earlier versions of the system.
+
+When the system is running Android 13 or later, notifications sent
+will be silently disregarded unless permission to display
+notifications is expressly granted from the "App Info" settings panel
+corresponding to Emacs.
+
+A title and body must be supplied. Value is an integer (fixnum or
+bignum) uniquely designating the notification displayed, which may
+subsequently be specified as the `:replaces-id' of another call to
+this function.
+
+usage: (android-notifications-notify &rest ARGS) */)
+ (ptrdiff_t nargs, Lisp_Object *args)
+{
+ Lisp_Object title, body, replaces_id, group, urgency, timeout, resident;
+ Lisp_Object icon;
+ Lisp_Object key, value, actions, action_cb, close_cb;
+ ptrdiff_t i;
+ AUTO_STRING (default_icon, "ic_dialog_alert");
+
+ if (!android_init_gui)
+ error ("No Android display connection!");
+
+ /* Clear each variable above. */
+ title = body = replaces_id = group = icon = urgency = actions = Qnil;
+ timeout = resident = action_cb = close_cb = Qnil;
+
+ /* If NARGS is odd, error. */
+
+ if (nargs & 1)
+ error ("Odd number of arguments in call to `android-notifications-notify'");
+
+ /* Next, iterate through ARGS, searching for arguments. */
+
+ for (i = 0; i < nargs; i += 2)
+ {
+ key = args[i];
+ value = args[i + 1];
+
+ if (EQ (key, QCtitle))
+ title = value;
+ else if (EQ (key, QCbody))
+ body = value;
+ else if (EQ (key, QCreplaces_id))
+ replaces_id = value;
+ else if (EQ (key, QCgroup))
+ group = value;
+ else if (EQ (key, QCurgency))
+ urgency = value;
+ else if (EQ (key, QCicon))
+ icon = value;
+ else if (EQ (key, QCactions))
+ actions = value;
+ else if (EQ (key, QCtimeout))
+ timeout = value;
+ else if (EQ (key, QCresident))
+ resident = value;
+ else if (EQ (key, QCon_action))
+ action_cb = value;
+ else if (EQ (key, QCon_close))
+ close_cb = value;
+ }
+
+ /* Demand at least TITLE and BODY be present. */
+
+ if (NILP (title) || NILP (body))
+ error ("Title or body not provided");
+
+ /* Now check the type and possibly expand each non-nil argument. */
+
+ CHECK_STRING (title);
+ CHECK_STRING (body);
+
+ if (NILP (urgency))
+ urgency = Qlow;
+
+ if (NILP (group))
+ {
+ AUTO_STRING (format, "Desktop Notifications (%s importance)");
+ group = CALLN (Fformat, format, urgency);
+ }
+
+ if (NILP (icon))
+ icon = default_icon;
+ else
+ CHECK_STRING (icon);
+
+ return make_int (android_notifications_notify_1 (title, body, replaces_id,
+ group, icon, urgency,
+ actions, timeout, resident,
+ action_cb, close_cb));
+}
+
+/* Run callbacks in response to a notification being deleted.
+ Save any input generated for the keyboard within *IE.
+ EVENT should be the notification deletion event. */
+
+void
+android_notification_deleted (struct android_notification_event *event,
+ struct input_event *ie)
+{
+ Lisp_Object item, tag;
+ intmax_t id;
+
+ tag = build_string (event->tag);
+ item = Fgethash (tag, notification_table, Qnil);
+
+ if (!NILP (item))
+ Fremhash (tag, notification_table);
+
+ if (CONSP (item) && FUNCTIONP (XCAR (XCDR (item)))
+ && sscanf (event->tag, "%*d.%*ld.%jd", &id) > 0)
+ {
+ ie->kind = NOTIFICATION_EVENT;
+ ie->arg = list3 (XCAR (XCDR (item)), make_int (id),
+ Qundefined);
+ }
+}
+
+/* Run callbacks in response to one of a notification's actions being
+ invoked, saving any input generated for the keyboard within *IE.
+ EVENT should be the notification deletion event, and ACTION the
+ action key. */
+
+void
+android_notification_action (struct android_notification_event *event,
+ struct input_event *ie, Lisp_Object action)
+{
+ Lisp_Object item, tag;
+ intmax_t id;
+ jstring tag_object;
+ jmethodID method;
+
+ tag = build_string (event->tag);
+ item = Fgethash (tag, notification_table, Qnil);
+
+ if (CONSP (item) && FUNCTIONP (XCAR (item))
+ && sscanf (event->tag, "%*d.%*ld.%jd", &id) > 0)
+ {
+ ie->kind = NOTIFICATION_EVENT;
+ ie->arg = list3 (XCAR (item), make_int (id), action);
+ }
+
+ /* Test whether ITEM is resident. Non-resident notifications must be
+ removed when activated. */
+
+ if (!CONSP (item) || NILP (XCAR (XCDR (XCDR (item)))))
+ {
+ method = service_class.cancel_notification;
+ tag_object
+ = (*android_java_env)->NewStringUTF (android_java_env,
+ event->tag);
+ android_exception_check ();
+
+ (*android_java_env)->CallNonvirtualVoidMethod (android_java_env,
+ emacs_service,
+ service_class.class,
+ method, tag_object);
+ android_exception_check_1 (tag_object);
+ ANDROID_DELETE_LOCAL_REF (tag_object);
+
+ /* Remove the notification from the callback table. */
+ if (!NILP (item))
+ Fremhash (tag, notification_table);
+ }
+}
+
+
+
+void
+init_androidselect (void)
+{
+ jobject tem;
+ jmethodID make_clipboard;
+
+ if (!android_init_gui)
+ return;
+
+ android_init_emacs_clipboard ();
+ android_init_emacs_desktop_notification ();
+
+ make_clipboard = clipboard_class.make_clipboard;
+ tem
+ = (*android_java_env)->CallStaticObjectMethod (android_java_env,
+ clipboard_class.class,
+ make_clipboard);
+ if (!tem)
+ emacs_abort ();
+
+ clipboard = (*android_java_env)->NewGlobalRef (android_java_env, tem);
+
+ if (!clipboard)
+ emacs_abort ();
+
+ ANDROID_DELETE_LOCAL_REF (tem);
+}
+
+void
+syms_of_androidselect (void)
+{
+ DEFSYM (QCtitle, ":title");
+ DEFSYM (QCbody, ":body");
+ DEFSYM (QCreplaces_id, ":replaces-id");
+ DEFSYM (QCgroup, ":group");
+ DEFSYM (QCurgency, ":urgency");
+ DEFSYM (QCicon, ":icon");
+ DEFSYM (QCactions, ":actions");
+ DEFSYM (QCtimeout, ":timeout");
+ DEFSYM (QCresident, ":resident");
+ DEFSYM (QCon_action, ":on-action");
+ DEFSYM (QCon_close, ":on-close");
+
+ DEFSYM (Qlow, "low");
+ DEFSYM (Qnormal, "normal");
+ DEFSYM (Qcritical, "critical");
+
+ defsubr (&Sandroid_clipboard_owner_p);
+ defsubr (&Sandroid_set_clipboard);
+ defsubr (&Sandroid_get_clipboard);
+ defsubr (&Sandroid_clipboard_exists_p);
+ defsubr (&Sandroid_browse_url_internal);
+ defsubr (&Sandroid_get_clipboard_targets);
+ defsubr (&Sandroid_get_clipboard_data);
+
+ defsubr (&Sandroid_notifications_notify);
+
+ notification_table = CALLN (Fmake_hash_table, QCtest, Qequal);
+ staticpro (&notification_table);
+}
diff --git a/src/androidterm.c b/src/androidterm.c
new file mode 100644
index 00000000000..c920375fdbe
--- /dev/null
+++ b/src/androidterm.c
@@ -0,0 +1,6756 @@
+/* Communication module for Android terminals.
+
+Copyright (C) 2023-2024 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 <https://www.gnu.org/licenses/>. */
+
+#include <config.h>
+#include <stdio.h>
+#include <math.h>
+#include <stdlib.h>
+#include <semaphore.h>
+
+#include "lisp.h"
+#include "androidterm.h"
+#include "keyboard.h"
+#include "blockinput.h"
+#include "android.h"
+#include "buffer.h"
+#include "window.h"
+#include "textconv.h"
+#include "coding.h"
+#include "pdumper.h"
+
+/* This is a chain of structures for all the X displays currently in
+ use. */
+
+struct android_display_info *x_display_list;
+
+
+
+/* Android terminal interface functions. */
+
+#ifndef ANDROID_STUBIFY
+
+#include <android/log.h>
+
+/* Non-zero means that a HELP_EVENT has been generated since Emacs
+ start. */
+
+static bool any_help_event_p;
+
+/* Counters for tallying up scroll wheel events if
+ mwheel_coalesce_scroll_events is true. */
+
+static double wheel_event_x, wheel_event_y;
+
+enum
+ {
+ ANDROID_EVENT_NORMAL,
+ ANDROID_EVENT_GOTO_OUT,
+ ANDROID_EVENT_DROP,
+ };
+
+/* Find the frame whose window has the identifier WDESC.
+
+ This is like x_window_to_frame in xterm.c, except that DPYINFO may
+ be NULL, as there is only at most one Android display, and is only
+ specified in order to stay consistent with X. */
+
+static struct frame *
+android_window_to_frame (struct android_display_info *dpyinfo,
+ android_window wdesc)
+{
+ Lisp_Object tail, frame;
+ struct frame *f;
+
+ if (wdesc == ANDROID_NONE)
+ return NULL;
+
+ FOR_EACH_FRAME (tail, frame)
+ {
+ f = XFRAME (frame);
+
+ if (!FRAME_ANDROID_P (f))
+ continue;
+
+ if (FRAME_ANDROID_WINDOW (f) == wdesc)
+ return f;
+ }
+
+ return NULL;
+}
+
+static void
+android_clear_frame (struct frame *f)
+{
+ /* Clearing the frame will erase any cursor, so mark them all as no
+ longer visible. */
+ mark_window_cursors_off (XWINDOW (FRAME_ROOT_WINDOW (f)));
+ android_clear_window (FRAME_ANDROID_DRAWABLE (f));
+}
+
+static void
+android_show_hourglass (struct frame *f)
+{
+ struct android_output *x;
+
+ /* This isn't implemented like X because a window brings alongside
+ too many unneeded resources. */
+
+ x = FRAME_ANDROID_OUTPUT (f);
+
+ /* If the hourglass window is mapped inside a popup menu, input
+ could be lost if the menu is popped down and the grab is
+ relinquished, but the hourglass window is still up. Just
+ avoid displaying the hourglass at all while popups are
+ active. */
+
+ if (popup_activated ())
+ return;
+
+ x->hourglass = true;
+
+ if (!f->pointer_invisible)
+ android_define_cursor (FRAME_ANDROID_WINDOW (f),
+ x->hourglass_cursor);
+}
+
+static void
+android_hide_hourglass (struct frame *f)
+{
+ struct android_output *x;
+
+ x = FRAME_ANDROID_OUTPUT (f);
+ x->hourglass = false;
+
+ if (!f->pointer_invisible)
+ android_define_cursor (FRAME_ANDROID_WINDOW (f),
+ x->current_cursor);
+}
+
+static void
+android_flash (struct frame *f)
+{
+ struct android_gc *gc;
+ struct android_gc_values values;
+ int rc;
+ fd_set fds;
+
+ block_input ();
+
+ values.function = ANDROID_GC_XOR;
+ values.foreground = (FRAME_FOREGROUND_PIXEL (f)
+ ^ FRAME_BACKGROUND_PIXEL (f));
+
+ gc = android_create_gc ((ANDROID_GC_FUNCTION
+ | ANDROID_GC_FOREGROUND),
+ &values);
+
+ /* 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))
+ {
+ android_fill_rectangle (FRAME_ANDROID_DRAWABLE (f), gc,
+ flash_left,
+ (FRAME_INTERNAL_BORDER_WIDTH (f)
+ + FRAME_TOP_MARGIN_HEIGHT (f)),
+ width, flash_height);
+ android_fill_rectangle (FRAME_ANDROID_DRAWABLE (f), gc,
+ flash_left,
+ (height - flash_height
+ - FRAME_INTERNAL_BORDER_WIDTH (f)
+ - FRAME_BOTTOM_MARGIN_HEIGHT (f)),
+ width, flash_height);
+
+ }
+ else
+ /* If it is short, flash it all. */
+ android_fill_rectangle (FRAME_ANDROID_DRAWABLE (f), gc,
+ flash_left, FRAME_INTERNAL_BORDER_WIDTH (f),
+ width, (height - 2
+ * FRAME_INTERNAL_BORDER_WIDTH (f)));
+
+ flush_frame (f);
+
+ struct timespec delay = make_timespec (0, 150 * 1000 * 1000);
+ struct timespec wakeup = timespec_add (current_timespec (), delay);
+
+ /* Keep waiting until past the time wakeup or any input gets
+ available. */
+ while (! detect_input_pending ())
+ {
+ struct timespec current = current_timespec ();
+ struct timespec timeout;
+
+ /* Break if result would not be positive. */
+ if (timespec_cmp (wakeup, current) <= 0)
+ break;
+
+ /* 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);
+
+ /* Try to wait that long--but we might wake up sooner. */
+ rc = pselect (0, &fds, NULL, NULL, &timeout, NULL);
+
+ /* Some input is available, exit the visible bell. */
+ if (rc >= 0)
+ break;
+ }
+
+ /* If window is tall, flash top and bottom line. */
+ if (height > 3 * FRAME_LINE_HEIGHT (f))
+ {
+ android_fill_rectangle (FRAME_ANDROID_DRAWABLE (f), gc,
+ flash_left,
+ (FRAME_INTERNAL_BORDER_WIDTH (f)
+ + FRAME_TOP_MARGIN_HEIGHT (f)),
+ width, flash_height);
+ android_fill_rectangle (FRAME_ANDROID_DRAWABLE (f), gc,
+ flash_left,
+ (height - flash_height
+ - FRAME_INTERNAL_BORDER_WIDTH (f)
+ - FRAME_BOTTOM_MARGIN_HEIGHT (f)),
+ width, flash_height);
+ }
+ else
+ /* If it is short, flash it all. */
+ android_fill_rectangle (FRAME_ANDROID_DRAWABLE (f), gc,
+ flash_left, FRAME_INTERNAL_BORDER_WIDTH (f),
+ width, (height - 2
+ * FRAME_INTERNAL_BORDER_WIDTH (f)));
+
+ android_free_gc (gc);
+ flush_frame (f);
+
+ unblock_input ();
+}
+
+static void
+android_ring_bell (struct frame *f)
+{
+ if (visible_bell)
+ android_flash (f);
+ else
+ {
+ block_input ();
+ android_bell ();
+ unblock_input ();
+ }
+}
+
+static android_cursor
+make_invisible_cursor (struct android_display_info *dpyinfo)
+{
+ return android_create_font_cursor (ANDROID_XC_NULL);
+}
+
+static void
+android_toggle_visible_pointer (struct frame *f, bool invisible)
+{
+ struct android_display_info *dpyinfo;
+
+ dpyinfo = FRAME_DISPLAY_INFO (f);
+
+ if (!dpyinfo->invisible_cursor)
+ dpyinfo->invisible_cursor = make_invisible_cursor (dpyinfo);
+
+ if (invisible)
+ android_define_cursor (FRAME_ANDROID_WINDOW (f),
+ dpyinfo->invisible_cursor);
+ else
+ android_define_cursor (FRAME_ANDROID_WINDOW (f),
+ (FRAME_ANDROID_OUTPUT (f)->hourglass
+ ? f->output_data.android->hourglass_cursor
+ : f->output_data.android->current_cursor));
+
+ f->pointer_invisible = invisible;
+}
+
+static void
+android_toggle_invisible_pointer (struct frame *f, bool invisible)
+{
+ block_input ();
+ android_toggle_visible_pointer (f, invisible);
+ unblock_input ();
+}
+
+/* Start an update of frame F. This function is installed as a hook
+ for update_begin, i.e. it is called when update_begin is called.
+ This function is called prior to calls to gui_update_window_begin
+ for each window being updated. Currently, there is nothing to do
+ here because all interesting stuff is done on a window basis. */
+
+static void
+android_update_begin (struct frame *f)
+{
+ /* The frame is no longer complete, as it is in the midst of an
+ update. */
+ FRAME_ANDROID_COMPLETE_P (f) = false;
+}
+
+/* End update of frame F. This function is installed as a hook in
+ update_end. */
+
+static void
+android_update_end (struct frame *f)
+{
+ /* Mouse highlight may be displayed again. */
+ MOUSE_HL_INFO (f)->mouse_face_defer = false;
+}
+
+static void
+show_back_buffer (struct frame *f)
+{
+ struct android_swap_info swap_info;
+
+ memset (&swap_info, 0, sizeof (swap_info));
+ swap_info.swap_window = FRAME_ANDROID_WINDOW (f);
+ swap_info.swap_action = ANDROID_COPIED;
+ android_swap_buffers (&swap_info, 1);
+
+ /* Now the back buffer no longer needs to be flipped. */
+ FRAME_ANDROID_NEED_BUFFER_FLIP (f) = false;
+}
+
+/* Flip back buffers on F if it has undrawn content. */
+
+static void
+android_flush_dirty_back_buffer_on (struct frame *f)
+{
+ if (FRAME_GARBAGED_P (f)
+ || buffer_flipping_blocked_p ()
+ /* If the frame is not already up to date, do not flush buffers
+ on input, as that will result in flicker. */
+ || !FRAME_ANDROID_COMPLETE_P (f)
+ || !FRAME_ANDROID_NEED_BUFFER_FLIP (f))
+ return;
+
+ show_back_buffer (f);
+}
+
+/* Convert between the modifier bits Android uses and the modifier
+ bits Emacs uses. */
+
+static int
+android_android_to_emacs_modifiers (struct android_display_info *dpyinfo,
+ int state)
+{
+ int mod_ctrl = ctrl_modifier;
+ int mod_meta = meta_modifier;
+ int mod_alt = alt_modifier;
+ int mod_super = super_modifier;
+ Lisp_Object tem;
+
+ tem = Fget (Vx_ctrl_keysym, Qmodifier_value);
+ if (FIXNUMP (tem)) mod_ctrl = XFIXNUM (tem) & INT_MAX;
+ tem = Fget (Vx_alt_keysym, Qmodifier_value);
+ if (FIXNUMP (tem)) mod_alt = XFIXNUM (tem) & INT_MAX;
+ tem = Fget (Vx_meta_keysym, Qmodifier_value);
+ if (FIXNUMP (tem)) mod_meta = XFIXNUM (tem) & INT_MAX;
+ tem = Fget (Vx_super_keysym, Qmodifier_value);
+ if (FIXNUMP (tem)) mod_super = XFIXNUM (tem) & INT_MAX;
+
+ return (((state & ANDROID_CONTROL_MASK) ? mod_ctrl : 0)
+ | ((state & ANDROID_SHIFT_MASK) ? shift_modifier : 0)
+ | ((state & ANDROID_ALT_MASK) ? mod_meta : 0)
+ | ((state & ANDROID_SUPER_MASK) ? mod_super : 0)
+ | ((state & ANDROID_META_MASK) ? mod_alt : 0));
+}
+
+static int
+android_emacs_to_android_modifiers (struct android_display_info *dpyinfo,
+ intmax_t state)
+{
+ EMACS_INT mod_ctrl = ctrl_modifier;
+ EMACS_INT mod_meta = meta_modifier;
+ EMACS_INT mod_alt = alt_modifier;
+ EMACS_INT mod_super = super_modifier;
+ Lisp_Object tem;
+
+ tem = Fget (Vx_ctrl_keysym, Qmodifier_value);
+ if (FIXNUMP (tem)) mod_ctrl = XFIXNUM (tem);
+ tem = Fget (Vx_alt_keysym, Qmodifier_value);
+ if (FIXNUMP (tem)) mod_alt = XFIXNUM (tem);
+ tem = Fget (Vx_meta_keysym, Qmodifier_value);
+ if (FIXNUMP (tem)) mod_meta = XFIXNUM (tem);
+ tem = Fget (Vx_super_keysym, Qmodifier_value);
+ if (FIXNUMP (tem)) mod_super = XFIXNUM (tem);
+
+ return (((state & mod_ctrl) ? ANDROID_CONTROL_MASK : 0)
+ | ((state & shift_modifier) ? ANDROID_SHIFT_MASK : 0)
+ | ((state & mod_meta) ? ANDROID_ALT_MASK : 0)
+ | ((state & mod_super) ? ANDROID_SUPER_MASK : 0)
+ | ((state & mod_alt) ? ANDROID_META_MASK : 0));
+}
+
+static void android_frame_rehighlight (struct android_display_info *);
+
+static void
+android_lower_frame (struct frame *f)
+{
+ android_lower_window (FRAME_ANDROID_WINDOW (f));
+}
+
+static void
+android_raise_frame (struct frame *f)
+{
+ android_raise_window (FRAME_ANDROID_WINDOW (f));
+}
+
+static void
+android_new_focus_frame (struct android_display_info *dpyinfo,
+ struct frame *frame)
+{
+ struct frame *old_focus;
+
+ old_focus = dpyinfo->focus_frame;
+
+ if (frame != dpyinfo->focus_frame)
+ {
+ /* Set this before calling other routines, so that they see
+ the correct value of x_focus_frame. */
+ dpyinfo->focus_frame = frame;
+
+ if (old_focus && old_focus->auto_lower)
+ android_lower_frame (old_focus);
+
+ if (dpyinfo->focus_frame && dpyinfo->focus_frame->auto_raise)
+ dpyinfo->pending_autoraise_frame = dpyinfo->focus_frame;
+ else
+ dpyinfo->pending_autoraise_frame = NULL;
+ }
+
+ android_frame_rehighlight (dpyinfo);
+}
+
+static void
+android_focus_changed (int type, int state,
+ struct android_display_info *dpyinfo,
+ struct frame *frame, struct input_event *bufp)
+{
+ if (type == ANDROID_FOCUS_IN)
+ {
+ if (dpyinfo->x_focus_event_frame != frame)
+ {
+ android_new_focus_frame (dpyinfo, frame);
+ dpyinfo->x_focus_event_frame = frame;
+ bufp->kind = FOCUS_IN_EVENT;
+ XSETFRAME (bufp->frame_or_window, frame);
+ }
+
+ frame->output_data.android->focus_state |= state;
+ }
+ else if (type == ANDROID_FOCUS_OUT)
+ {
+ frame->output_data.android->focus_state &= ~state;
+
+ if (dpyinfo->x_focus_event_frame == frame)
+ {
+ dpyinfo->x_focus_event_frame = 0;
+ android_new_focus_frame (dpyinfo, 0);
+
+ bufp->kind = FOCUS_OUT_EVENT;
+ XSETFRAME (bufp->frame_or_window, frame);
+ }
+
+ if (frame->pointer_invisible)
+ android_toggle_invisible_pointer (frame, false);
+ }
+}
+
+static void
+android_detect_focus_change (struct android_display_info *dpyinfo,
+ struct frame *frame,
+ union android_event *event,
+ struct input_event *bufp)
+{
+ if (!frame)
+ return;
+
+ switch (event->type)
+ {
+ case ANDROID_FOCUS_IN:
+ case ANDROID_FOCUS_OUT:
+ android_focus_changed (event->type, FOCUS_EXPLICIT,
+ dpyinfo, frame, bufp);
+ break;
+
+ default:
+ break;
+ }
+}
+
+static bool
+android_note_mouse_movement (struct frame *frame,
+ struct android_motion_event *event)
+{
+ struct android_display_info *dpyinfo;
+ Emacs_Rectangle *r;
+
+ if (!FRAME_ANDROID_OUTPUT (frame))
+ return false;
+
+ dpyinfo = FRAME_DISPLAY_INFO (frame);
+ dpyinfo->last_mouse_motion_frame = frame;
+ dpyinfo->last_mouse_motion_x = event->x;
+ dpyinfo->last_mouse_motion_y = event->y;
+ dpyinfo->last_mouse_movement_time = event->time;
+
+ /* Has the mouse moved off the glyph it was on at the last sighting? */
+ r = &dpyinfo->last_mouse_glyph;
+ if (frame != dpyinfo->last_mouse_glyph_frame
+ || event->x < r->x || event->x >= r->x + (int) r->width
+ || event->y < r->y || event->y >= r->y + (int) r->height)
+ {
+ frame->mouse_moved = true;
+ note_mouse_highlight (frame, event->x, event->y);
+ /* Remember which glyph we're now on. */
+ remember_mouse_glyph (frame, event->x, event->y, r);
+ dpyinfo->last_mouse_glyph_frame = frame;
+ return true;
+ }
+
+ return false;
+}
+
+static struct frame *
+mouse_or_wdesc_frame (struct android_display_info *dpyinfo, int wdesc)
+{
+ struct frame *lm_f = (gui_mouse_grabbed (dpyinfo)
+ ? dpyinfo->last_mouse_frame
+ : NULL);
+
+ if (lm_f && !EQ (track_mouse, Qdropping)
+ && !EQ (track_mouse, Qdrag_source))
+ return lm_f;
+ else
+ {
+ struct frame *w_f = android_window_to_frame (dpyinfo, wdesc);
+
+ /* Do not return a tooltip frame. */
+ if (!w_f || FRAME_TOOLTIP_P (w_f))
+ return EQ (track_mouse, Qdropping) ? lm_f : NULL;
+ else
+ /* When dropping it would be probably nice to raise w_f
+ here. */
+ return w_f;
+ }
+}
+
+static Lisp_Object
+android_construct_mouse_click (struct input_event *result,
+ struct android_button_event *event,
+ struct frame *f)
+{
+ struct android_display_info *dpyinfo;
+ int x, y;
+
+ dpyinfo = FRAME_DISPLAY_INFO (f);
+ x = event->x;
+ y = event->y;
+
+ /* Make the event type NO_EVENT; we'll change that when we decide
+ otherwise. */
+ result->kind = MOUSE_CLICK_EVENT;
+ result->code = event->button - 1;
+ result->timestamp = event->time;
+ result->modifiers = (android_android_to_emacs_modifiers (dpyinfo,
+ event->state)
+ | (event->type == ANDROID_BUTTON_RELEASE
+ ? up_modifier : down_modifier));
+
+ XSETINT (result->x, x);
+ XSETINT (result->y, y);
+ XSETFRAME (result->frame_or_window, f);
+ result->arg = Qnil;
+ return Qnil;
+}
+
+/* Generate a TOUCHSCREEN_UPDATE_EVENT for all pressed tools in FRAME.
+ Return the event in IE. Do not set IE->timestamp, as that is left
+ to the caller. */
+
+static void
+android_update_tools (struct frame *f, struct input_event *ie)
+{
+ struct android_touch_point *touchpoint;
+
+ ie->kind = TOUCHSCREEN_UPDATE_EVENT;
+ XSETFRAME (ie->frame_or_window, f);
+ ie->arg = Qnil;
+
+ /* Build the list of active touches. */
+ for (touchpoint = FRAME_OUTPUT_DATA (f)->touch_points;
+ touchpoint; touchpoint = touchpoint->next)
+ {
+ /* Skip touch points which originated on the tool bar. */
+
+ if (touchpoint->tool_bar_p)
+ continue;
+
+ ie->arg = Fcons (list3i (touchpoint->x,
+ touchpoint->y,
+ touchpoint->tool_id),
+ ie->arg);
+ }
+}
+
+/* Find and return an existing tool pressed against FRAME, identified
+ by POINTER_ID. Return NULL if no tool by that ID was found. */
+
+static struct android_touch_point *
+android_find_tool (struct frame *f, int pointer_id)
+{
+ struct android_touch_point *touchpoint;
+
+ for (touchpoint = FRAME_OUTPUT_DATA (f)->touch_points;
+ touchpoint; touchpoint = touchpoint->next)
+ {
+ if (touchpoint->tool_id == pointer_id)
+ return touchpoint;
+ }
+
+ return NULL;
+}
+
+/* Decode STRING, an array of N little endian UTF-16 characters, into
+ a Lisp string. Return Qnil if the string is too large, and the
+ encoded string otherwise. */
+
+static Lisp_Object
+android_decode_utf16 (unsigned short *utf16, size_t n)
+{
+ struct coding_system coding;
+ ptrdiff_t size;
+
+ if (ckd_mul (&size, n, sizeof *utf16))
+ return Qnil;
+
+ /* Set up the coding system. Decoding a UTF-16 string (with no BOM)
+ should not signal. */
+
+ memset (&coding, 0, sizeof coding);
+
+ setup_coding_system (Qutf_16le, &coding);
+ coding.source = (const unsigned char *) utf16;
+ decode_coding_object (&coding, Qnil, 0, 0, size,
+ size, Qt);
+
+ return coding.dst_object;
+}
+
+/* Handle a cursor update request for F from the input method.
+ MODE specifies whether or not an update should be sent immediately,
+ and whether or not they are needed in the future.
+
+ If MODE & ANDROID_CURSOR_UPDATE_IMMEDIATE, report the position of
+ F's old selected window's phys cursor now.
+
+ If MODE & ANDROID_CURSOR_UPDATE_MONITOR, set
+ `need_cursor_updates'. */
+
+static void
+android_request_cursor_updates (struct frame *f, int mode)
+{
+ struct window *w;
+
+ if (mode & ANDROID_CURSOR_UPDATE_IMMEDIATE
+ && WINDOWP (WINDOW_LIVE_P (f->old_selected_window)
+ ? f->old_selected_window
+ : f->selected_window))
+ {
+ /* Prefer the old selected window, as its selection is what was
+ reported to the IME previously. */
+
+ w = XWINDOW (WINDOW_LIVE_P (f->old_selected_window)
+ ? f->old_selected_window
+ : f->selected_window);
+ android_set_preeditarea (w, w->cursor.x, w->cursor.y);
+ }
+
+ /* Now say whether or not updates are needed in the future. */
+ FRAME_OUTPUT_DATA (f)->need_cursor_updates
+ = (mode & ANDROID_CURSOR_UPDATE_MONITOR);
+}
+
+/* Handle a single input method event EVENT, delivered to the frame
+ F.
+
+ Perform the text conversion action specified inside. */
+
+static void
+android_handle_ime_event (union android_event *event, struct frame *f)
+{
+ Lisp_Object text UNINIT;
+ struct android_output *output;
+
+ /* First, decode the text if necessary. */
+
+ switch (event->ime.operation)
+ {
+ case ANDROID_IME_COMMIT_TEXT:
+ case ANDROID_IME_SET_COMPOSING_TEXT:
+ case ANDROID_IME_REPLACE_TEXT:
+ text = android_decode_utf16 (event->ime.text,
+ event->ime.length);
+ xfree (event->ime.text);
+
+ /* Return should text be long enough that it overflows ptrdiff_t.
+ Such circumstances are detected within android_decode_utf16. */
+
+ if (NILP (text))
+ return;
+
+ break;
+
+ default:
+ break;
+ }
+
+ /* Finally, perform the appropriate conversion action. */
+
+ switch (event->ime.operation)
+ {
+ case ANDROID_IME_COMMIT_TEXT:
+ commit_text (f, text, event->ime.position,
+ event->ime.counter);
+ break;
+
+ case ANDROID_IME_DELETE_SURROUNDING_TEXT:
+ delete_surrounding_text (f, event->ime.start,
+ event->ime.end,
+ event->ime.counter);
+ break;
+
+ case ANDROID_IME_FINISH_COMPOSING_TEXT:
+
+ if (event->ime.length == 2)
+ {
+ output = FRAME_ANDROID_OUTPUT (f);
+
+ /* A new input method has connected to Emacs. Stop
+ reporting changes that the previous input method has
+ asked to monitor. */
+
+ output->extracted_text_flags = 0;
+ output->extracted_text_token = 0;
+ output->extracted_text_hint = 0;
+ output->need_cursor_updates = false;
+ }
+
+ finish_composing_text (f, event->ime.counter,
+ event->ime.length == 1);
+
+ if (event->ime.length == 2)
+ {
+ /* Now cancel outstanding batch edits if a new input method
+ has connected. */
+
+ f->conversion.batch_edit_flags = 0;
+ f->conversion.batch_edit_count = 0;
+ }
+
+ break;
+
+ case ANDROID_IME_SET_COMPOSING_TEXT:
+ set_composing_text (f, text, event->ime.position,
+ event->ime.counter);
+ break;
+
+ case ANDROID_IME_SET_COMPOSING_REGION:
+ set_composing_region (f, event->ime.start,
+ event->ime.end,
+ event->ime.counter);
+ break;
+
+ case ANDROID_IME_SET_POINT:
+ textconv_set_point_and_mark (f, event->ime.start,
+ event->ime.end,
+ event->ime.counter);
+ break;
+
+ case ANDROID_IME_START_BATCH_EDIT:
+ start_batch_edit (f, event->ime.counter);
+ break;
+
+ case ANDROID_IME_END_BATCH_EDIT:
+ end_batch_edit (f, event->ime.counter);
+ break;
+
+ case ANDROID_IME_REQUEST_SELECTION_UPDATE:
+ request_point_update (f, event->ime.counter);
+ break;
+
+ case ANDROID_IME_REQUEST_CURSOR_UPDATES:
+ android_request_cursor_updates (f, event->ime.length);
+ break;
+
+ case ANDROID_IME_REPLACE_TEXT:
+ replace_text (f, event->ime.start, event->ime.end,
+ text, event->ime.position,
+ event->ime.counter);
+ break;
+ }
+}
+
+
+
+/* Forward declaration. */
+static void android_notify_conversion (unsigned long);
+
+static int
+handle_one_android_event (struct android_display_info *dpyinfo,
+ union android_event *event, int *finish,
+ struct input_event *hold_quit)
+{
+ union android_event configureEvent;
+ struct frame *f, *any, *mouse_frame;
+ Mouse_HLInfo *hlinfo;
+ union buffered_input_event inev;
+ int modifiers, count, do_help;
+ struct android_touch_point *touchpoint, **last;
+ Lisp_Object window;
+ int scroll_height;
+ double scroll_unit;
+ int keysym;
+ ptrdiff_t nchars, i;
+ struct window *w;
+ static struct android_compose_status compose_status;
+
+ /* It is okay for this to not resemble handle_one_xevent so much.
+ Differences in event handling code are much less nasty than
+ stuble differences in the graphics code. */
+
+ do_help = count = 0;
+ hlinfo = &dpyinfo->mouse_highlight;
+ *finish = ANDROID_EVENT_NORMAL;
+ any = android_window_to_frame (dpyinfo, event->xany.window);
+ nchars = 0;
+
+ if (any && any->wait_event_type == event->type)
+ any->wait_event_type = 0; /* Indicates we got it. */
+
+ EVENT_INIT (inev.ie);
+
+ switch (event->type)
+ {
+ case ANDROID_CONFIGURE_NOTIFY:
+ configureEvent = *event;
+
+ f = android_window_to_frame (dpyinfo,
+ configureEvent.xconfigure.window);
+
+ if (!f)
+ goto OTHER;
+
+ if (FRAME_TOOLTIP_P (f))
+ {
+ if (FRAME_PIXEL_HEIGHT (f) != configureEvent.xconfigure.height
+ || FRAME_PIXEL_WIDTH (f) != configureEvent.xconfigure.width)
+ SET_FRAME_GARBAGED (f);
+
+ FRAME_PIXEL_HEIGHT (f) = configureEvent.xconfigure.height;
+ FRAME_PIXEL_WIDTH (f) = configureEvent.xconfigure.width;
+ }
+
+ int width = configureEvent.xconfigure.width;
+ int height = configureEvent.xconfigure.height;
+
+ if (CONSP (frame_size_history))
+ frame_size_history_extra (f, build_string ("ConfigureNotify"),
+ FRAME_PIXEL_WIDTH (f),
+ FRAME_PIXEL_HEIGHT (f),
+ width, height, f->new_width,
+ f->new_height);
+
+ /* 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
+ && ((f->new_width >= 0 && width != f->new_width)
+ || (f->new_height >= 0 && height != f->new_height))))
+ {
+ change_frame_size (f, width, height, false, true, false);
+ android_clear_under_internal_border (f);
+ SET_FRAME_GARBAGED (f);
+ cancel_mouse_face (f);
+ }
+
+ /* Now change the left and top position of this window. */
+
+ {
+ int old_left = f->left_pos;
+ int old_top = f->top_pos;
+ Lisp_Object frame;
+
+ XSETFRAME (frame, f);
+
+ {
+ android_window root;
+ unsigned int dummy_uint;
+
+ android_get_geometry (FRAME_ANDROID_WINDOW (f),
+ &root, &f->left_pos, &f->top_pos,
+ &dummy_uint, &dummy_uint,
+ &dummy_uint);
+ }
+
+ if (!FRAME_TOOLTIP_P (f)
+ && (old_left != f->left_pos || old_top != f->top_pos))
+ {
+ inev.ie.kind = MOVE_FRAME_EVENT;
+ XSETFRAME (inev.ie.frame_or_window, f);
+ }
+
+ if (f && FRAME_OUTPUT_DATA (f)->need_cursor_updates)
+ {
+ w = XWINDOW (f->selected_window);
+ android_set_preeditarea (w, w->cursor.x, w->cursor.y);
+ }
+ }
+
+ goto OTHER;
+
+ case ANDROID_KEY_PRESS:
+
+ /* Set f to any. There are no ``outer windows'' on Android. */
+ f = any;
+
+ /* If mouse-highlight is an integer, input clears out
+ mouse highlighting. */
+ if (!hlinfo->mouse_face_hidden && FIXNUMP (Vmouse_highlight)
+ && (any == 0
+ || !EQ (any->tool_bar_window, hlinfo->mouse_face_window)
+ || !EQ (any->tab_bar_window, hlinfo->mouse_face_window)))
+ {
+ mouse_frame = hlinfo->mouse_face_mouse_frame;
+
+ clear_mouse_face (hlinfo);
+ hlinfo->mouse_face_hidden = true;
+
+ if (mouse_frame)
+ android_flush_dirty_back_buffer_on (mouse_frame);
+ }
+
+ if (!f)
+ goto OTHER;
+
+ if (event->xkey.counter)
+ /* This event was generated by `performEditorAction'. Make
+ sure it is processed before any subsequent edits. */
+ textconv_barrier (f, event->xkey.counter);
+
+ wchar_t copy_buffer[512];
+ wchar_t *copy_bufptr = copy_buffer;
+ int copy_bufsiz = 512;
+
+ event->xkey.state
+ |= android_emacs_to_android_modifiers (dpyinfo,
+ extra_keyboard_modifiers);
+ modifiers = event->xkey.state;
+
+ /* In case Meta is ComposeCharacter, clear its status. According
+ to Markus Ehrnsperger
+ Markus.Ehrnsperger@lehrstuhl-bross.physik.uni-muenchen.de this
+ enables ComposeCharacter to work whether or not it is combined
+ with Meta. */
+ if (modifiers & ANDROID_ALT_MASK)
+ memset (&compose_status, 0, sizeof (compose_status));
+
+ /* Common for all keysym input events. */
+ XSETFRAME (inev.ie.frame_or_window, any);
+ inev.ie.modifiers
+ = android_android_to_emacs_modifiers (dpyinfo, modifiers);
+ inev.ie.timestamp = event->xkey.time;
+
+ keysym = event->xkey.keycode;
+
+ {
+ enum android_lookup_status status_return;
+
+ nchars = android_wc_lookup_string (&event->xkey, copy_bufptr,
+ copy_bufsiz, &keysym,
+ &status_return,
+ &compose_status);
+
+ /* android_lookup_string can't be called twice, so there's no
+ way to recover from buffer overflow. */
+ if (status_return == ANDROID_BUFFER_OVERFLOW)
+ goto done_keysym;
+ else if (status_return == ANDROID_LOOKUP_NONE)
+ {
+ /* Don't skip preedit text events. */
+ if (event->xkey.keycode != (uint32_t) -1)
+ goto done_keysym;
+ }
+ else if (status_return == ANDROID_LOOKUP_CHARS)
+ keysym = ANDROID_NO_SYMBOL;
+ else if (status_return != ANDROID_LOOKUP_KEYSYM
+ && status_return != ANDROID_LOOKUP_BOTH)
+ emacs_abort ();
+
+ /* Deal with pre-edit text events. On Android, these are
+ simply encoded as events with associated strings and a
+ keycode set to ``-1''. */
+
+ if (event->xkey.keycode == (uint32_t) -1)
+ {
+ inev.ie.kind = PREEDIT_TEXT_EVENT;
+ inev.ie.arg = Qnil;
+
+ /* If text was looked up, decode it and make it the
+ preedit text. */
+
+ if (status_return == ANDROID_LOOKUP_CHARS && nchars)
+ {
+ copy_bufptr[nchars] = 0;
+ inev.ie.arg = from_unicode_buffer (copy_bufptr);
+ }
+
+ goto done_keysym;
+ }
+ }
+
+ /* If a compose sequence is in progress, we break here.
+ Otherwise, chars_matched is always 0. */
+ if (compose_status.chars_matched > 0 && nchars == 0)
+ break;
+
+ memset (&compose_status, 0, sizeof (compose_status));
+
+ if (nchars == 1 && copy_bufptr[0] >= 32)
+ {
+ /* Deal with characters. */
+
+ if (copy_bufptr[0] < 128)
+ inev.ie.kind = ASCII_KEYSTROKE_EVENT;
+ else
+ inev.ie.kind = MULTIBYTE_CHAR_KEYSTROKE_EVENT;
+
+ inev.ie.code = copy_bufptr[0];
+ }
+ else if (nchars < 2 && keysym)
+ {
+ /* If the key is a modifier key, just return. */
+ if (ANDROID_IS_MODIFIER_KEY (keysym))
+ goto done_keysym;
+
+ /* Next, deal with special ``characters'' by giving the
+ keycode to keyboard.c. */
+ inev.ie.kind = NON_ASCII_KEYSTROKE_EVENT;
+ inev.ie.code = keysym;
+ }
+ else
+ {
+ /* Finally, deal with strings. */
+
+ for (i = 0; i < nchars; ++i)
+ {
+ inev.ie.kind = (SINGLE_BYTE_CHAR_P (copy_bufptr[i])
+ ? ASCII_KEYSTROKE_EVENT
+ : MULTIBYTE_CHAR_KEYSTROKE_EVENT);
+ inev.ie.code = copy_bufptr[i];
+
+ /* If the character is actually '\n', then change this
+ to RET. */
+
+ if (copy_bufptr[i] == '\n')
+ {
+ inev.ie.kind = NON_ASCII_KEYSTROKE_EVENT;
+ inev.ie.code = 66;
+ }
+
+ kbd_buffer_store_buffered_event (&inev, hold_quit);
+ }
+
+ count += nchars;
+ inev.ie.kind = NO_EVENT; /* Already stored above. */
+ }
+
+ goto done_keysym;
+
+ done_keysym:
+
+ /* Now proceed to tell the input method the current position of
+ the cursor, if required. */
+
+ if (f && FRAME_OUTPUT_DATA (f)->need_cursor_updates)
+ {
+ w = XWINDOW (f->selected_window);
+ android_set_preeditarea (w, w->cursor.x, w->cursor.y);
+ }
+
+ goto OTHER;
+
+ case ANDROID_FOCUS_IN:
+ case ANDROID_FOCUS_OUT:
+ android_detect_focus_change (dpyinfo, any, event, &inev.ie);
+ goto OTHER;
+
+ case ANDROID_WINDOW_ACTION:
+
+ /* This is a special event sent by android_run_in_emacs_thread
+ used to make Android run stuff. */
+
+ if (!event->xaction.window && !event->xaction.action)
+ /* Don't run queries here, as it may run inside editor
+ commands, which can expose an inconsistent view of buffer
+ contents to the input method during command execution.
+
+ Instead, wait for Emacs to return to `android_select'. */
+ goto OTHER;
+
+ f = any;
+
+ if (event->xaction.action == 0)
+ {
+ /* Action 0 either means that a window has been destroyed
+ and its associated frame should be as well. */
+
+ if (event->xaction.window)
+ {
+ if (!f)
+ goto OTHER;
+
+ inev.ie.kind = DELETE_WINDOW_EVENT;
+ XSETFRAME (inev.ie.frame_or_window, f);
+ }
+ }
+
+ case ANDROID_ENTER_NOTIFY:
+ f = any;
+
+ if (f)
+ android_note_mouse_movement (f, &event->xmotion);
+ goto OTHER;
+
+ case ANDROID_MOTION_NOTIFY:
+
+ previous_help_echo_string = help_echo_string;
+ help_echo_string = Qnil;
+
+ if (hlinfo->mouse_face_hidden)
+ {
+ hlinfo->mouse_face_hidden = false;
+ clear_mouse_face (hlinfo);
+ }
+
+ f = any;
+
+ if (f)
+ {
+ /* Maybe generate a SELECT_WINDOW_EVENT for
+ `mouse-autoselect-window' but don't let popup menus
+ interfere with this (Bug#1261). */
+ if (!NILP (Vmouse_autoselect_window)
+ && !popup_activated ()
+ /* Don't switch if we're currently in the minibuffer.
+ This tries to work around problems where the
+ minibuffer gets unselected unexpectedly, and where
+ you then have to move your mouse all the way down to
+ the minibuffer to select it. */
+ && !MINI_WINDOW_P (XWINDOW (selected_window))
+ /* With `focus-follows-mouse' non-nil create an event
+ also when the target window is on another frame. */
+ && (f == XFRAME (selected_frame)
+ || !NILP (focus_follows_mouse)))
+ {
+ static Lisp_Object last_mouse_window;
+ Lisp_Object window
+ = window_from_coordinates (f, event->xmotion.x,
+ event->xmotion.y, 0,
+ false, false, false);
+
+ /* A window will be autoselected only when it is not
+ selected now and the last mouse movement event was
+ not in it. The remainder of the code is a bit vague
+ wrt what a "window" is. For immediate autoselection,
+ the window is usually the entire window but for GTK
+ where the scroll bars don't count. For delayed
+ autoselection the window is usually the window's text
+ area including the margins. */
+ if (WINDOWP (window)
+ && !EQ (window, last_mouse_window)
+ && !EQ (window, selected_window))
+ {
+ inev.ie.kind = SELECT_WINDOW_EVENT;
+ inev.ie.frame_or_window = window;
+ }
+
+ /* Remember the last window where we saw the mouse. */
+ last_mouse_window = window;
+ }
+
+ if (!android_note_mouse_movement (f, &event->xmotion))
+ help_echo_string = previous_help_echo_string;
+ }
+
+ /* If the contents of the global variable help_echo_string
+ has changed, generate a HELP_EVENT. */
+ if (!NILP (help_echo_string)
+ || !NILP (previous_help_echo_string))
+ do_help = 1;
+
+ if (f)
+ android_flush_dirty_back_buffer_on (f);
+
+ goto OTHER;
+
+ case ANDROID_LEAVE_NOTIFY:
+ f = any;
+
+ if (f)
+ {
+ /* Now clear dpyinfo->last_mouse_motion_frame, or
+ gui_redo_mouse_highlight will end up highlighting the
+ last known position of the mouse if a tooltip frame is
+ later unmapped. */
+
+ if (f == dpyinfo->last_mouse_motion_frame)
+ dpyinfo->last_mouse_motion_frame = NULL;
+
+ /* Something similar applies to
+ dpyinfo->last_mouse_glyph_frame. */
+ if (f == dpyinfo->last_mouse_glyph_frame)
+ dpyinfo->last_mouse_glyph_frame = NULL;
+
+ if (f == hlinfo->mouse_face_mouse_frame)
+ {
+ /* If we move outside the frame, then we're
+ certainly no longer on any text in the frame. */
+ clear_mouse_face (hlinfo);
+ hlinfo->mouse_face_mouse_frame = 0;
+ android_flush_dirty_back_buffer_on (f);
+ }
+
+ /* Generate a nil HELP_EVENT to cancel a help-echo.
+ Do it only if there's something to cancel.
+ Otherwise, the startup message is cleared when
+ the mouse leaves the frame. */
+ if (any_help_event_p
+ /* But never if `mouse-drag-and-drop-region' is in
+ progress, since that results in the tooltip being
+ dismissed when the mouse moves on top. */
+ && !((EQ (track_mouse, Qdrag_source)
+ || EQ (track_mouse, Qdropping))
+ && gui_mouse_grabbed (dpyinfo)))
+ do_help = -1;
+ }
+
+ goto OTHER;
+
+ case ANDROID_EXPOSE:
+
+ f = any;
+
+ if (f)
+ {
+ if (!FRAME_VISIBLE_P (f))
+ {
+ f->output_data.android->has_been_visible = true;
+ SET_FRAME_GARBAGED (f);
+ }
+
+ if (!FRAME_GARBAGED_P (f))
+ {
+ expose_frame (f, event->xexpose.x, event->xexpose.y,
+ event->xexpose.width, event->xexpose.height);
+ show_back_buffer (f);
+ }
+ }
+
+ goto OTHER;
+
+ case ANDROID_BUTTON_PRESS:
+ case ANDROID_BUTTON_RELEASE:
+ /* If we decide we want to generate an event to be seen
+ by the rest of Emacs, we put it here. */
+
+ f = any;
+
+ Lisp_Object tab_bar_arg = Qnil;
+ bool tab_bar_p = false;
+ bool tool_bar_p = false;
+
+ dpyinfo->last_mouse_glyph_frame = NULL;
+
+ f = mouse_or_wdesc_frame (dpyinfo, event->xbutton.window);
+
+ if (f && event->xbutton.type == ANDROID_BUTTON_PRESS
+ && !popup_activated ()
+ /* && !x_window_to_scroll_bar (event->xbutton.display, */
+ /* event->xbutton.window, 2) */
+ && !FRAME_NO_ACCEPT_FOCUS (f))
+ {
+ /* When clicking into a child frame or when clicking
+ into a parent frame with the child frame selected and
+ `no-accept-focus' is not set, select the clicked
+ frame. */
+ struct frame *hf = dpyinfo->highlight_frame;
+
+ if (FRAME_PARENT_FRAME (f) || (hf && frame_ancestor_p (f, hf)))
+ {
+ android_set_input_focus (FRAME_ANDROID_WINDOW (f),
+ event->xbutton.time);
+
+ if (FRAME_PARENT_FRAME (f))
+ android_raise_window (FRAME_ANDROID_WINDOW (f));
+ }
+ }
+
+ if (f)
+ {
+ /* Is this in the tab-bar? */
+ if (WINDOWP (f->tab_bar_window)
+ && WINDOW_TOTAL_LINES (XWINDOW (f->tab_bar_window)))
+ {
+ Lisp_Object window;
+ int x = event->xbutton.x;
+ int y = event->xbutton.y;
+
+ window = window_from_coordinates (f, x, y, 0, true, true, true);
+ tab_bar_p = EQ (window, f->tab_bar_window);
+
+ if (tab_bar_p)
+ {
+ tab_bar_arg = handle_tab_bar_click
+ (f, x, y, (event->xbutton.type
+ == ANDROID_BUTTON_PRESS),
+ android_android_to_emacs_modifiers (dpyinfo,
+ event->xbutton.state));
+ android_flush_dirty_back_buffer_on (f);
+ }
+ }
+
+ /* Is this in the tool-bar? */
+ if (WINDOWP (f->tool_bar_window)
+ && WINDOW_TOTAL_LINES (XWINDOW (f->tool_bar_window)))
+ {
+ Lisp_Object window;
+ int x = event->xbutton.x;
+ int y = event->xbutton.y;
+
+ window = window_from_coordinates (f, x, y, 0, true, true, true);
+ tool_bar_p = (EQ (window, f->tool_bar_window)
+ && ((event->xbutton.type
+ != ANDROID_BUTTON_RELEASE)
+ || f->last_tool_bar_item != -1));
+
+ if (tool_bar_p && event->xbutton.button < 4)
+ {
+ handle_tool_bar_click
+ (f, x, y, (event->xbutton.type
+ == ANDROID_BUTTON_PRESS),
+ android_android_to_emacs_modifiers (dpyinfo,
+ event->xbutton.state));
+ android_flush_dirty_back_buffer_on (f);
+ }
+ }
+
+ if (!(tab_bar_p && NILP (tab_bar_arg)) && !tool_bar_p)
+ if (! popup_activated ())
+ {
+ android_construct_mouse_click (&inev.ie, &event->xbutton, f);
+
+ if (!NILP (tab_bar_arg))
+ inev.ie.arg = tab_bar_arg;
+ }
+ }
+
+ if (event->type == ANDROID_BUTTON_PRESS)
+ {
+ dpyinfo->grabbed |= (1 << event->xbutton.button);
+ dpyinfo->last_mouse_frame = f;
+ if (f && !tab_bar_p)
+ f->last_tab_bar_item = -1;
+ if (f && !tool_bar_p)
+ f->last_tool_bar_item = -1;
+ }
+ else
+ dpyinfo->grabbed &= ~(1 << event->xbutton.button);
+
+ /* Ignore any mouse motion that happened before this event;
+ any subsequent mouse-movement Emacs events should reflect
+ only motion after the ButtonPress/Release. */
+ if (f != 0)
+ f->mouse_moved = false;
+
+ goto OTHER;
+
+ /* Touch events. The events here don't parallel X so much. */
+ case ANDROID_TOUCH_DOWN:
+
+ if (!any)
+ goto OTHER;
+
+ /* This event is sent when a tool is put on the screen. X and Y
+ are the location of the finger, and pointer_id identifies the
+ tool for as long as it is still held down. First, see if the
+ touch point already exists and can be reused (this shouldn't
+ happen, but be safe.) */
+
+ touchpoint = android_find_tool (any, event->touch.pointer_id);
+
+ if (touchpoint)
+ {
+ /* Simply update the tool position and send an update. */
+ touchpoint->x = event->touch.x;
+ touchpoint->y = event->touch.y;
+ android_update_tools (any, &inev.ie);
+ inev.ie.timestamp = event->touch.time;
+
+ goto OTHER;
+ }
+
+ /* Otherwise, link a new touchpoint onto the output's list of
+ pressed tools. */
+
+ touchpoint = xmalloc (sizeof *touchpoint);
+ touchpoint->tool_id = event->touch.pointer_id;
+ touchpoint->x = event->touch.x;
+ touchpoint->y = event->touch.y;
+ touchpoint->next = FRAME_OUTPUT_DATA (any)->touch_points;
+ touchpoint->tool_bar_p = false;
+ FRAME_OUTPUT_DATA (any)->touch_points = touchpoint;
+
+ /* Figure out whether or not the tool was pressed on the tool
+ bar. Note that the code which runs when it was is more or
+ less an abuse of the mouse highlight machinery, but it works
+ well enough in practice. */
+
+ if (WINDOWP (any->tool_bar_window)
+ && WINDOW_TOTAL_LINES (XWINDOW (any->tool_bar_window)))
+ {
+ Lisp_Object window;
+ int x = event->touch.x;
+ int y = event->touch.y;
+
+ window = window_from_coordinates (any, x, y, 0, true,
+ true, true);
+
+ /* If this touch has started in the tool bar, do not
+ send it to Lisp. Instead, simulate a tool bar
+ click, releasing it once it goes away. */
+
+ if (EQ (window, any->tool_bar_window))
+ {
+ /* Call note_mouse_highlight on the tool bar
+ item. Otherwise, get_tool_bar_item will
+ return 1.
+
+ This is not necessary when mouse-highlight is
+ nil. */
+
+ if (!NILP (Vmouse_highlight))
+ {
+ /* Clear the pointer invisible flag to always make
+ note_mouse_highlight do its thing. */
+ any->pointer_invisible = false;
+ note_mouse_highlight (any, x, y);
+
+ /* Always allow future mouse motion to
+ update the mouse highlight, no matter
+ where it is. */
+ memset (&dpyinfo->last_mouse_glyph, 0,
+ sizeof dpyinfo->last_mouse_glyph);
+ dpyinfo->last_mouse_glyph_frame = any;
+ }
+
+ handle_tool_bar_click (any, x, y, true, 0);
+
+ /* Flush any changes made by that to the front
+ buffer. */
+ android_flush_dirty_back_buffer_on (any);
+
+ /* Mark the touch point as being grabbed by the tool
+ bar. */
+ touchpoint->tool_bar_p = true;
+ goto OTHER;
+ }
+ }
+
+ /* Now generate the Emacs event. */
+ inev.ie.kind = TOUCHSCREEN_BEGIN_EVENT;
+ inev.ie.timestamp = event->touch.time;
+ XSETFRAME (inev.ie.frame_or_window, any);
+ XSETINT (inev.ie.x, event->touch.x);
+ XSETINT (inev.ie.y, event->touch.y);
+ XSETINT (inev.ie.arg, event->touch.pointer_id);
+
+ goto OTHER;
+
+ case ANDROID_TOUCH_MOVE:
+
+ if (!any)
+ goto OTHER;
+
+ /* Look for the tool that moved. */
+
+ touchpoint = android_find_tool (any, event->touch.pointer_id);
+
+ /* If it doesn't exist or has been grabbed by the tool bar, skip
+ processing this event. */
+
+ if (!touchpoint || touchpoint->tool_bar_p)
+ goto OTHER;
+
+ /* Otherwise, update the position and send the update event. */
+
+ touchpoint->x = event->touch.x;
+ touchpoint->y = event->touch.y;
+ android_update_tools (any, &inev.ie);
+ inev.ie.timestamp = event->touch.time;
+
+ goto OTHER;
+
+ case ANDROID_TOUCH_UP:
+
+ if (!any)
+ goto OTHER;
+
+ /* Now find and unlink the tool in question. */
+
+ last = &FRAME_OUTPUT_DATA (any)->touch_points;
+ while ((touchpoint = *last))
+ {
+ if (touchpoint->tool_id == event->touch.pointer_id)
+ {
+ *last = touchpoint->next;
+
+ if (touchpoint->tool_bar_p)
+ {
+ xfree (touchpoint);
+
+ /* Do what is necessary to release the tool bar and
+ possibly trigger a click. */
+
+ if (any->last_tool_bar_item != -1)
+ handle_tool_bar_click (any, event->touch.x,
+ event->touch.y, false,
+ 0);
+
+ /* Cancel any outstanding mouse highlight. */
+ note_mouse_highlight (any, -1, -1);
+ android_flush_dirty_back_buffer_on (any);
+
+ goto OTHER;
+ }
+
+ /* The tool was unlinked. Free it and generate the
+ appropriate Emacs event (assuming that it was not
+ grabbed by the tool bar). */
+ xfree (touchpoint);
+
+ inev.ie.kind = TOUCHSCREEN_END_EVENT;
+ inev.ie.timestamp = event->touch.time;
+
+ /* Report whether the sequence has been canceled. */
+
+ if (event->touch.flags & ANDROID_TOUCH_SEQUENCE_CANCELED)
+ inev.ie.modifiers = 1;
+
+ XSETFRAME (inev.ie.frame_or_window, any);
+ XSETINT (inev.ie.x, event->touch.x);
+ XSETINT (inev.ie.y, event->touch.y);
+ XSETINT (inev.ie.arg, event->touch.pointer_id);
+
+ /* Break out of the loop. */
+ goto OTHER;
+ }
+ else
+ last = &touchpoint->next;
+ }
+
+ /* No touch point was found. This shouldn't happen. */
+ goto OTHER;
+
+ /* Wheel motion. The events here don't parallel X because
+ Android doesn't have scroll valuators. */
+
+ case ANDROID_WHEEL:
+
+ if (!any)
+ goto OTHER;
+
+ if (fabs (event->wheel.x_delta) > 0
+ || fabs (event->wheel.y_delta) > 0)
+ {
+ if (mwheel_coalesce_scroll_events)
+ {
+ if (signbit (event->wheel.x_delta)
+ != signbit (wheel_event_x))
+ wheel_event_x = 0.0;
+
+ if (signbit (event->wheel.y_delta)
+ != signbit (wheel_event_y))
+ wheel_event_y = 0.0;
+
+ /* Tally up deltas until one of them exceeds 1.0. */
+ wheel_event_x += event->wheel.x_delta;
+ wheel_event_y += event->wheel.y_delta;
+
+ if (fabs (wheel_event_x) < 1.0
+ && fabs (wheel_event_y) < 1.0)
+ goto OTHER;
+ }
+ else
+ {
+ /* Use the deltas in the event. */
+ wheel_event_x = event->wheel.x_delta;
+ wheel_event_y = event->wheel.y_delta;
+ }
+
+ /* Determine what kind of event to send. */
+ inev.ie.kind = ((fabs (wheel_event_y)
+ >= fabs (wheel_event_x))
+ ? WHEEL_EVENT : HORIZ_WHEEL_EVENT);
+ inev.ie.timestamp = event->wheel.time;
+
+ /* Set the event coordinates. */
+ XSETINT (inev.ie.x, event->wheel.x);
+ XSETINT (inev.ie.y, event->wheel.y);
+
+ /* Set the frame. */
+ XSETFRAME (inev.ie.frame_or_window, any);
+
+ /* Figure out the scroll direction. */
+ inev.ie.modifiers = (signbit ((fabs (wheel_event_x)
+ >= fabs (wheel_event_y))
+ ? wheel_event_x
+ : wheel_event_y)
+ ? down_modifier : up_modifier);
+
+ /* Figure out how much to scale the deltas by. */
+ window = window_from_coordinates (any, event->wheel.x,
+ event->wheel.y, NULL,
+ false, false, false);
+
+ if (WINDOWP (window))
+ scroll_height = XWINDOW (window)->pixel_height;
+ else
+ /* EVENT_X and EVENT_Y can be outside the
+ frame if F holds the input grab, so fall
+ back to the height of the frame instead. */
+ scroll_height = FRAME_PIXEL_HEIGHT (any);
+
+ scroll_unit = pow (scroll_height, 2.0 / 3.0);
+
+ /* Add the keyboard modifiers. */
+ inev.ie.modifiers
+ |= android_android_to_emacs_modifiers (dpyinfo,
+ event->wheel.state);
+
+ /* Finally include the scroll deltas. */
+ inev.ie.arg = list3 (Qnil,
+ make_float (wheel_event_x
+ * scroll_unit),
+ make_float (wheel_event_y
+ * scroll_unit));
+
+ wheel_event_x = 0.0;
+ wheel_event_y = 0.0;
+ }
+
+ goto OTHER;
+
+ /* Iconification. This is vastly simpler than on X. */
+ case ANDROID_ICONIFIED:
+
+ if (!any)
+ goto OTHER;
+
+ if (FRAME_ICONIFIED_P (any))
+ goto OTHER;
+
+ SET_FRAME_VISIBLE (any, false);
+ SET_FRAME_ICONIFIED (any, true);
+
+ inev.ie.kind = ICONIFY_EVENT;
+ XSETFRAME (inev.ie.frame_or_window, any);
+ goto OTHER;
+
+ case ANDROID_DEICONIFIED:
+
+ if (!any)
+ goto OTHER;
+
+ if (!FRAME_ICONIFIED_P (any))
+ goto OTHER;
+
+ SET_FRAME_VISIBLE (any, true);
+ SET_FRAME_ICONIFIED (any, false);
+
+ inev.ie.kind = DEICONIFY_EVENT;
+ XSETFRAME (inev.ie.frame_or_window, any);
+ goto OTHER;
+
+ /* Context menu handling. */
+ case ANDROID_CONTEXT_MENU:
+
+ if (dpyinfo->menu_event_id == -1
+ /* Previously displayed popup menus might generate events
+ after dismissal, which might interfere.
+ `current_menu_serial' is always set to an identifier
+ identifying the last context menu to be displayed. */
+ && event->menu.menu_event_serial == current_menu_serial)
+ dpyinfo->menu_event_id = event->menu.menu_event_id;
+
+ goto OTHER;
+
+ /* Input method events. textconv.c functions are called here to
+ queue events, which are then executed in a safe context
+ inside keyboard.c. */
+ case ANDROID_INPUT_METHOD:
+
+ if (!any)
+ {
+ /* Free any text allocated for this event. */
+ xfree (event->ime.text);
+
+ /* If edits associated with this event haven't been
+ processed yet, signal their completion to avoid delays
+ the next time a call to `android_sync_edit' is made.
+
+ If events for a deleted frame are interleaved with events
+ for another frame, the edit counter may be prematurely
+ incremented before edits associated with the other frames
+ are processed. This is not a problem in practice. */
+
+ android_notify_conversion (event->ime.counter);
+ }
+ else
+ android_handle_ime_event (event, any);
+
+ goto OTHER;
+
+ case ANDROID_DND_DRAG_EVENT:
+
+ if (!any)
+ goto OTHER;
+
+ /* Generate a drag and drop event to convey its position. */
+ inev.ie.kind = DRAG_N_DROP_EVENT;
+ XSETFRAME (inev.ie.frame_or_window, any);
+ inev.ie.timestamp = ANDROID_CURRENT_TIME;
+ XSETINT (inev.ie.x, event->dnd.x);
+ XSETINT (inev.ie.y, event->dnd.y);
+ inev.ie.arg = Fcons (inev.ie.x, inev.ie.y);
+ goto OTHER;
+
+ case ANDROID_DND_URI_EVENT:
+ case ANDROID_DND_TEXT_EVENT:
+
+ if (!any)
+ {
+ free (event->dnd.uri_or_string);
+ goto OTHER;
+ }
+
+ /* An item was dropped over ANY, and is a file in the form of a
+ content or file URI or a string to be inserted. Generate an
+ event with this information. */
+
+ inev.ie.kind = DRAG_N_DROP_EVENT;
+ XSETFRAME (inev.ie.frame_or_window, any);
+ inev.ie.timestamp = ANDROID_CURRENT_TIME;
+ XSETINT (inev.ie.x, event->dnd.x);
+ XSETINT (inev.ie.y, event->dnd.y);
+ inev.ie.arg = Fcons ((event->type == ANDROID_DND_TEXT_EVENT
+ ? Qtext : Quri),
+ android_decode_utf16 (event->dnd.uri_or_string,
+ event->dnd.length));
+ free (event->dnd.uri_or_string);
+ goto OTHER;
+
+ case ANDROID_NOTIFICATION_DELETED:
+ case ANDROID_NOTIFICATION_ACTION:
+
+ if (event->notification.type == ANDROID_NOTIFICATION_DELETED)
+ android_notification_deleted (&event->notification, &inev.ie);
+ else
+ {
+ Lisp_Object action;
+
+ action = android_decode_utf16 (event->notification.action,
+ event->notification.length);
+ android_notification_action (&event->notification, &inev.ie,
+ action);
+ }
+
+ /* Free dynamically allocated data. */
+ free (event->notification.tag);
+ free (event->notification.action);
+ goto OTHER;
+
+ default:
+ goto OTHER;
+ }
+
+ OTHER:
+ if (inev.ie.kind != NO_EVENT)
+ {
+ kbd_buffer_store_buffered_event (&inev, hold_quit);
+ count++;
+ }
+
+ if (do_help
+ && !(hold_quit && hold_quit->kind != NO_EVENT))
+ {
+ Lisp_Object frame;
+
+ if (f)
+ XSETFRAME (frame, f);
+ else
+ frame = Qnil;
+
+ if (do_help > 0)
+ {
+ any_help_event_p = true;
+ gen_help_event (help_echo_string, frame, help_echo_window,
+ help_echo_object, help_echo_pos);
+ }
+ else
+ {
+ help_echo_string = Qnil;
+ gen_help_event (Qnil, frame, Qnil, Qnil, 0);
+ }
+ count++;
+ }
+
+ return count;
+}
+
+static int
+android_read_socket (struct terminal *terminal,
+ struct input_event *hold_quit)
+{
+ int count = 0;
+ struct android_display_info *dpyinfo;
+
+ dpyinfo = terminal->display_info.android;
+
+ block_input ();
+ while (android_pending ())
+ {
+ int finish;
+ union android_event event;
+
+ android_next_event (&event);
+ count += handle_one_android_event (dpyinfo, &event, &finish,
+ hold_quit);
+
+ if (finish == ANDROID_EVENT_GOTO_OUT)
+ break;
+ }
+ unblock_input ();
+
+ /* If the focus was just given to an auto-raising frame, raise it
+ now. */
+ if (dpyinfo->pending_autoraise_frame)
+ {
+ android_raise_frame (dpyinfo->pending_autoraise_frame);
+ dpyinfo->pending_autoraise_frame = NULL;
+ }
+
+ return count;
+}
+
+static void
+android_frame_up_to_date (struct frame *f)
+{
+ eassert (FRAME_ANDROID_P (f));
+ block_input ();
+ FRAME_MOUSE_UPDATE (f);
+
+ if (!buffer_flipping_blocked_p ()
+ && FRAME_ANDROID_NEED_BUFFER_FLIP (f))
+ show_back_buffer (f);
+
+ /* The frame is now complete, as its contents have been drawn. */
+ FRAME_ANDROID_COMPLETE_P (f) = true;
+
+ /* Shrink the scanline buffer used by the font backend. */
+ sfntfont_android_shrink_scanline_buffer ();
+ unblock_input ();
+}
+
+static void
+android_buffer_flipping_unblocked_hook (struct frame *f)
+{
+ block_input ();
+
+ if (FRAME_ANDROID_NEED_BUFFER_FLIP (f))
+ show_back_buffer (f);
+
+ unblock_input ();
+}
+
+static void
+android_query_frame_background_color (struct frame *f, Emacs_Color *bgcolor)
+{
+ unsigned long background;
+
+ background = FRAME_BACKGROUND_PIXEL (f);
+ bgcolor->pixel = background;
+
+ android_query_colors (f, bgcolor, 1);
+}
+
+int
+android_parse_color (struct frame *f, const char *color_name,
+ Emacs_Color *color)
+{
+ unsigned short r, g, b;
+ Lisp_Object tem, tem1;
+ unsigned long lisp_color;
+
+ if (parse_color_spec (color_name, &r, &g, &b))
+ {
+ color->red = r;
+ color->green = g;
+ color->blue = b;
+
+ return 1;
+ }
+
+ tem = x_display_list->color_map;
+ for (; CONSP (tem); tem = XCDR (tem))
+ {
+ tem1 = XCAR (tem);
+
+ if (CONSP (tem1)
+ && !xstrcasecmp (SSDATA (XCAR (tem1)), color_name))
+ {
+ lisp_color = XFIXNUM (XCDR (tem1));
+ color->red = RED_FROM_ULONG (lisp_color) * 257;
+ color->green = GREEN_FROM_ULONG (lisp_color) * 257;
+ color->blue = BLUE_FROM_ULONG (lisp_color) * 257;
+ return 1;
+ }
+ }
+
+ return 0;
+}
+
+bool
+android_alloc_nearest_color (struct frame *f, Emacs_Color *color)
+{
+ gamma_correct (f, color);
+ color->pixel = RGB_TO_ULONG (color->red / 256,
+ color->green / 256,
+ color->blue / 256);
+
+ return true;
+}
+
+void
+android_query_colors (struct frame *f, Emacs_Color *colors, int ncolors)
+{
+ int i;
+
+ for (i = 0; i < ncolors; ++i)
+ {
+ colors[i].red = RED_FROM_ULONG (colors[i].pixel) * 257;
+ colors[i].green = RED_FROM_ULONG (colors[i].pixel) * 257;
+ colors[i].blue = RED_FROM_ULONG (colors[i].pixel) * 257;
+ }
+}
+
+static void
+android_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 tail, frame;
+ struct android_display_info *dpyinfo;
+
+ dpyinfo = FRAME_DISPLAY_INFO (*fp);
+
+ /* This is the best implementation possible on Android, where the
+ system doesn't let Emacs obtain any information about the mouse
+ pointer at all. */
+
+ if (dpyinfo->last_mouse_motion_frame)
+ {
+ *fp = dpyinfo->last_mouse_motion_frame;
+ *timestamp = dpyinfo->last_mouse_movement_time;
+ *x = make_fixnum (dpyinfo->last_mouse_motion_x);
+ *y = make_fixnum (dpyinfo->last_mouse_motion_y);
+ *bar_window = Qnil;
+ *part = scroll_bar_nowhere;
+
+ FOR_EACH_FRAME (tail, frame)
+ {
+ if (FRAME_ANDROID_P (XFRAME (frame)))
+ XFRAME (frame)->mouse_moved = false;
+ }
+
+ dpyinfo->last_mouse_motion_frame->mouse_moved = false;
+ }
+}
+
+static Lisp_Object
+android_get_focus_frame (struct frame *f)
+{
+ Lisp_Object lisp_focus;
+ struct frame *focus;
+
+ focus = FRAME_DISPLAY_INFO (f)->focus_frame;
+
+ if (!focus)
+ return Qnil;
+
+ XSETFRAME (lisp_focus, focus);
+ return lisp_focus;
+}
+
+static void
+android_focus_frame (struct frame *f, bool noactivate)
+{
+ /* Set the input focus to the frame's window. The system only lets
+ this work on child frames. */
+ android_set_input_focus (FRAME_ANDROID_WINDOW (f),
+ ANDROID_CURRENT_TIME);
+}
+
+/* The two procedures below only have to update the cursor on Android,
+ as there are no window borders there. */
+
+static void
+android_frame_highlight (struct frame *f)
+{
+ gui_update_cursor (f, true);
+}
+
+static void
+android_frame_unhighlight (struct frame *f)
+{
+ gui_update_cursor (f, true);
+}
+
+static void
+android_frame_rehighlight (struct android_display_info *dpyinfo)
+{
+ struct frame *old_highlight;
+
+ old_highlight = dpyinfo->highlight_frame;
+
+ if (dpyinfo->focus_frame)
+ {
+ dpyinfo->highlight_frame
+ = ((FRAMEP (FRAME_FOCUS_FRAME (dpyinfo->focus_frame)))
+ ? XFRAME (FRAME_FOCUS_FRAME (dpyinfo->focus_frame))
+ : dpyinfo->focus_frame);
+ if (!FRAME_LIVE_P (dpyinfo->highlight_frame))
+ {
+ fset_focus_frame (dpyinfo->focus_frame, Qnil);
+ dpyinfo->highlight_frame = dpyinfo->focus_frame;
+ }
+ }
+ else
+ dpyinfo->highlight_frame = 0;
+
+ if (dpyinfo->highlight_frame != old_highlight)
+ {
+ /* This is not yet required on Android. */
+ if (old_highlight)
+ android_frame_unhighlight (old_highlight);
+ if (dpyinfo->highlight_frame)
+ android_frame_highlight (dpyinfo->highlight_frame);
+ }
+}
+
+static void
+android_frame_rehighlight_hook (struct frame *f)
+{
+ android_frame_rehighlight (FRAME_DISPLAY_INFO (f));
+}
+
+static void
+android_frame_raise_lower (struct frame *f, bool raise_flag)
+{
+ if (raise_flag)
+ android_raise_frame (f);
+ else
+ android_lower_frame (f);
+}
+
+void
+android_make_frame_visible (struct frame *f)
+{
+ android_map_window (FRAME_ANDROID_WINDOW (f));
+
+ SET_FRAME_VISIBLE (f, true);
+ SET_FRAME_ICONIFIED (f, false);
+}
+
+void
+android_make_frame_invisible (struct frame *f)
+{
+ /* Don't keep the highlight on an invisible frame. */
+ if (FRAME_DISPLAY_INFO (f)->highlight_frame == f)
+ FRAME_DISPLAY_INFO (f)->highlight_frame = 0;
+
+ android_unmap_window (FRAME_ANDROID_WINDOW (f));
+
+ SET_FRAME_VISIBLE (f, false);
+ SET_FRAME_ICONIFIED (f, false);
+}
+
+static void
+android_make_frame_visible_invisible (struct frame *f, bool visible)
+{
+ if (visible)
+ android_make_frame_visible (f);
+ else
+ android_make_frame_invisible (f);
+}
+
+static void
+android_fullscreen_hook (struct frame *f)
+{
+ Lisp_Object wanted;
+
+ if (!FRAME_PARENT_FRAME (f))
+ {
+ /* Explicitly setting fullscreen is not supported on older
+ Android versions. */
+
+ wanted = (f->want_fullscreen == FULLSCREEN_BOTH
+ ? Qfullscreen : Qmaximized);
+
+ if (android_set_fullscreen (FRAME_ANDROID_WINDOW (f),
+ EQ (wanted, Qfullscreen)))
+ store_frame_param (f, Qfullscreen, Qmaximized);
+ else
+ store_frame_param (f, Qfullscreen, wanted);
+ }
+ else
+ {
+ store_frame_param (f, Qfullscreen, Qnil);
+
+ /* If this is a child frame, don't keep it fullscreen
+ anymore. */
+ android_set_fullscreen (FRAME_ANDROID_WINDOW (f), false);
+ }
+}
+
+void
+android_iconify_frame (struct frame *f)
+{
+ /* This really doesn't work on Android. */
+ error ("Can't notify window manager of iconification");
+}
+
+static void
+android_wait_for_event (struct frame *f, int eventtype)
+{
+ if (!FLOATP (Vandroid_wait_for_event_timeout))
+ return;
+
+ int level = interrupt_input_blocked;
+ struct timespec tmo, tmo_at, time_now;
+
+ f->wait_event_type = eventtype;
+
+ /* Default timeout is 0.1 second. Hopefully not noticeable. */
+ double timeout = XFLOAT_DATA (Vandroid_wait_for_event_timeout);
+ time_t timeout_seconds = (time_t) timeout;
+ tmo = make_timespec (timeout_seconds,
+ (long int) ((timeout - timeout_seconds)
+ * 1000 * 1000 * 1000));
+ tmo_at = timespec_add (current_timespec (), tmo);
+
+ while (f->wait_event_type)
+ {
+ pending_signals = true;
+ totally_unblock_input ();
+ /* XTread_socket is called after unblock. */
+ block_input ();
+ interrupt_input_blocked = level;
+
+ time_now = current_timespec ();
+ if (timespec_cmp (tmo_at, time_now) < 0)
+ break;
+
+ tmo = timespec_sub (tmo_at, time_now);
+ if (android_select (0, NULL, NULL, NULL, &tmo) == 0)
+ break; /* Timeout */
+ }
+
+ f->wait_event_type = 0;
+}
+
+static void
+android_set_window_size_1 (struct frame *f, bool change_gravity,
+ int width, int height)
+{
+ if (change_gravity)
+ f->win_gravity = NorthWestGravity;
+
+ android_resize_window (FRAME_ANDROID_WINDOW (f), width,
+ height);
+
+ SET_FRAME_GARBAGED (f);
+
+ if (FRAME_VISIBLE_P (f))
+ {
+ android_wait_for_event (f, ANDROID_CONFIGURE_NOTIFY);
+
+ if (CONSP (frame_size_history))
+ frame_size_history_extra (f, build_string ("set_window_size_1 visible"),
+ FRAME_PIXEL_WIDTH (f), FRAME_PIXEL_HEIGHT (f),
+ width, height, f->new_width, f->new_height);
+ }
+ else
+ {
+ if (CONSP (frame_size_history))
+ frame_size_history_extra (f, build_string ("set_window_size_1 "
+ "invisible"),
+ FRAME_PIXEL_WIDTH (f), FRAME_PIXEL_HEIGHT (f),
+ width, height, f->new_width, f->new_height);
+
+ adjust_frame_size (f, FRAME_PIXEL_TO_TEXT_WIDTH (f, width),
+ FRAME_PIXEL_TO_TEXT_HEIGHT (f, height),
+ 5, 0, Qx_set_window_size_1);
+ }
+}
+
+void
+android_set_window_size (struct frame *f, bool change_gravity,
+ int width, int height)
+{
+ block_input ();
+
+ android_set_window_size_1 (f, change_gravity, width, height);
+ android_clear_under_internal_border (f);
+
+ /* If cursor was outside the new size, mark it as off. */
+ mark_window_cursors_off (XWINDOW (f->root_window));
+
+ /* Clear out any recollection of where the mouse highlighting was,
+ since it might be in a place that's outside the new frame size.
+ Actually checking whether it is outside is a pain in the neck,
+ so don't try--just let the highlighting be done afresh with new size. */
+ cancel_mouse_face (f);
+
+ unblock_input ();
+
+ do_pending_window_change (false);
+}
+
+static void
+android_set_offset (struct frame *f, int xoff, int yoff,
+ int change_gravity)
+{
+ if (change_gravity > 0)
+ {
+ f->top_pos = yoff;
+ f->left_pos = xoff;
+ f->size_hint_flags &= ~ (XNegative | YNegative);
+ if (xoff < 0)
+ f->size_hint_flags |= XNegative;
+ if (yoff < 0)
+ f->size_hint_flags |= YNegative;
+ f->win_gravity = NorthWestGravity;
+ }
+
+ android_move_window (FRAME_ANDROID_WINDOW (f), xoff, yoff);
+}
+
+static void
+android_set_alpha (struct frame *f)
+{
+ /* Not supported on Android. */
+}
+
+static Lisp_Object
+android_new_font (struct frame *f, Lisp_Object font_object, int fontset)
+{
+ struct font *font = XFONT_OBJECT (font_object);
+ int unit, font_ascent, font_descent;
+
+ if (fontset < 0)
+ fontset = fontset_from_font (font_object);
+ FRAME_FONTSET (f) = fontset;
+ if (FRAME_FONT (f) == font)
+ /* This font is already set in frame F. There's nothing more to
+ do. */
+ return font_object;
+
+ FRAME_FONT (f) = font;
+ FRAME_BASELINE_OFFSET (f) = font->baseline_offset;
+ FRAME_COLUMN_WIDTH (f) = font->average_width;
+ get_font_ascent_descent (font, &font_ascent, &font_descent);
+ FRAME_LINE_HEIGHT (f) = font_ascent + font_descent;
+
+ /* We could use a more elaborate calculation here. */
+ FRAME_TAB_BAR_HEIGHT (f) = FRAME_TAB_BAR_LINES (f) * FRAME_LINE_HEIGHT (f);
+
+ /* Compute character columns occupied by scrollbar.
+
+ Don't do things differently for non-toolkit scrollbars
+ (Bug#17163). */
+ unit = FRAME_COLUMN_WIDTH (f);
+ if (FRAME_CONFIG_SCROLL_BAR_WIDTH (f) > 0)
+ FRAME_CONFIG_SCROLL_BAR_COLS (f)
+ = (FRAME_CONFIG_SCROLL_BAR_WIDTH (f) + unit - 1) / unit;
+ else
+ FRAME_CONFIG_SCROLL_BAR_COLS (f) = (14 + unit - 1) / unit;
+
+
+ /* Don't change the size of a tip frame; there's no point in doing it
+ because it's done in Fx_show_tip, and it leads to problems because
+ the tip frame has no widget. */
+ if (FRAME_ANDROID_WINDOW (f) != 0 && !FRAME_TOOLTIP_P (f))
+ adjust_frame_size (f, FRAME_COLS (f) * FRAME_COLUMN_WIDTH (f),
+ FRAME_LINES (f) * FRAME_LINE_HEIGHT (f), 3,
+ false, Qfont);
+
+ return font_object;
+}
+
+static bool
+android_bitmap_icon (struct frame *f, Lisp_Object file)
+{
+ return false;
+}
+
+static void
+android_free_pixmap_hook (struct frame *f, Emacs_Pixmap pixmap)
+{
+ android_free_pixmap (pixmap);
+}
+
+void
+android_free_frame_resources (struct frame *f)
+{
+ struct android_display_info *dpyinfo;
+ Mouse_HLInfo *hlinfo;
+ struct android_touch_point *last, *next;
+
+ dpyinfo = FRAME_DISPLAY_INFO (f);
+ hlinfo = &dpyinfo->mouse_highlight;
+
+ block_input ();
+ free_frame_faces (f);
+
+ /* FRAME_ANDROID_WINDOW can be 0 if frame creation failed. */
+ if (FRAME_ANDROID_WINDOW (f))
+ android_destroy_window (FRAME_ANDROID_WINDOW (f));
+
+ android_free_gcs (f);
+
+ /* Free cursors. */
+ if (f->output_data.android->text_cursor)
+ android_free_cursor (f->output_data.android->text_cursor);
+ if (f->output_data.android->nontext_cursor)
+ android_free_cursor (f->output_data.android->nontext_cursor);
+ if (f->output_data.android->modeline_cursor)
+ android_free_cursor (f->output_data.android->modeline_cursor);
+ if (f->output_data.android->hand_cursor)
+ android_free_cursor (f->output_data.android->hand_cursor);
+ if (f->output_data.android->hourglass_cursor)
+ android_free_cursor (f->output_data.android->hourglass_cursor);
+ if (f->output_data.android->horizontal_drag_cursor)
+ android_free_cursor (f->output_data.android->horizontal_drag_cursor);
+ if (f->output_data.android->vertical_drag_cursor)
+ android_free_cursor (f->output_data.android->vertical_drag_cursor);
+ if (f->output_data.android->left_edge_cursor)
+ android_free_cursor (f->output_data.android->left_edge_cursor);
+ if (f->output_data.android->top_left_corner_cursor)
+ android_free_cursor (f->output_data.android->top_left_corner_cursor);
+ if (f->output_data.android->top_edge_cursor)
+ android_free_cursor (f->output_data.android->top_edge_cursor);
+ if (f->output_data.android->top_right_corner_cursor)
+ android_free_cursor (f->output_data.android->top_right_corner_cursor);
+ if (f->output_data.android->right_edge_cursor)
+ android_free_cursor (f->output_data.android->right_edge_cursor);
+ if (f->output_data.android->bottom_right_corner_cursor)
+ android_free_cursor (f->output_data.android->bottom_right_corner_cursor);
+ if (f->output_data.android->bottom_edge_cursor)
+ android_free_cursor (f->output_data.android->bottom_edge_cursor);
+ if (f->output_data.android->bottom_left_corner_cursor)
+ android_free_cursor (f->output_data.android->bottom_left_corner_cursor);
+
+ /* Free extra GCs allocated by android_setup_relief_colors. */
+ if (f->output_data.android->white_relief.gc)
+ {
+ android_free_gc (f->output_data.android->white_relief.gc);
+ f->output_data.android->white_relief.gc = 0;
+ }
+ if (f->output_data.android->black_relief.gc)
+ {
+ android_free_gc (f->output_data.android->black_relief.gc);
+ f->output_data.android->black_relief.gc = 0;
+ }
+
+ if (f == dpyinfo->focus_frame)
+ dpyinfo->focus_frame = 0;
+ if (f == dpyinfo->x_focus_event_frame)
+ dpyinfo->x_focus_event_frame = 0;
+ if (f == dpyinfo->highlight_frame)
+ dpyinfo->highlight_frame = 0;
+ if (f == hlinfo->mouse_face_mouse_frame)
+ reset_mouse_highlight (hlinfo);
+
+ /* These two need to be freed now that they are used to compute the
+ mouse position, I think. */
+ if (f == dpyinfo->last_mouse_motion_frame)
+ dpyinfo->last_mouse_motion_frame = NULL;
+ if (f == dpyinfo->last_mouse_frame)
+ dpyinfo->last_mouse_frame = NULL;
+
+ /* Free all tool presses currently active on this frame. */
+ next = FRAME_OUTPUT_DATA (f)->touch_points;
+ while (next)
+ {
+ last = next;
+ next = next->next;
+ xfree (last);
+ }
+
+ /* Clear this in case unblock_input reads events. */
+ FRAME_OUTPUT_DATA (f)->touch_points = NULL;
+
+ unblock_input ();
+}
+
+static void
+android_delete_frame (struct frame *f)
+{
+ android_free_frame_resources (f);
+ xfree (f->output_data.android);
+ f->output_data.android = NULL;
+}
+
+static void
+android_delete_terminal (struct terminal *terminal)
+{
+ error ("Cannot terminate connection to Android display server");
+}
+
+
+
+/* RIF functions. */
+
+static void
+android_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;
+
+ /* Get frame-relative bounding box of the text display area of W,
+ without mode lines. Include in this box the left and right
+ fringe of W. */
+ window_box (w, ANY_AREA, &x, &y, &width, &height);
+
+ from_y = WINDOW_TO_FRAME_PIXEL_Y (w, run->current_y);
+ to_y = WINDOW_TO_FRAME_PIXEL_Y (w, run->desired_y);
+ bottom_y = y + height;
+
+ if (to_y < from_y)
+ {
+ /* Scrolling up. Make sure we don't copy part of the mode
+ line at the bottom. */
+ if (from_y + run->height > bottom_y)
+ height = bottom_y - from_y;
+ else
+ height = run->height;
+ }
+ else
+ {
+ /* Scrolling down. Make sure we don't copy over the mode line.
+ at the bottom. */
+ if (to_y + run->height > bottom_y)
+ height = bottom_y - to_y;
+ else
+ height = run->height;
+ }
+
+ block_input ();
+
+ /* Cursor off. Will be switched on again in gui_update_window_end. */
+ gui_clear_cursor (w);
+
+ /* To avoid sequence point problems, make sure to only call
+ FRAME_ANDROID_DRAWABLE once. */
+ android_copy_area (FRAME_ANDROID_DRAWABLE (f),
+ FRAME_ANDROID_WINDOW (f),
+ f->output_data.android->normal_gc,
+ x, from_y, width, height, x, to_y);
+
+ unblock_input ();
+}
+
+static void
+android_after_update_window_line (struct window *w, struct glyph_row *desired_row)
+{
+ eassert (w);
+
+ if (!desired_row->mode_line_p && !w->pseudo_window_p)
+ desired_row->redraw_fringe_bitmaps_p = true;
+}
+
+static void
+android_flip_and_flush (struct frame *f)
+{
+ block_input ();
+
+ if (FRAME_ANDROID_NEED_BUFFER_FLIP (f))
+ show_back_buffer (f);
+
+ /* The frame is complete again as its contents were just
+ flushed. */
+ FRAME_ANDROID_COMPLETE_P (f) = true;
+ unblock_input ();
+}
+
+static void
+android_clear_rectangle (struct frame *f, struct android_gc *gc, int x,
+ int y, int width, int height)
+{
+ struct android_gc_values xgcv;
+
+ android_get_gc_values (gc, (ANDROID_GC_BACKGROUND
+ | ANDROID_GC_FOREGROUND),
+ &xgcv);
+ android_set_foreground (gc, xgcv.background);
+ android_fill_rectangle (FRAME_ANDROID_DRAWABLE (f), gc,
+ x, y, width, height);
+ android_set_foreground (gc, xgcv.foreground);
+}
+
+static void
+android_reset_clip_rectangles (struct frame *f, struct android_gc *gc)
+{
+ android_set_clip_mask (gc, ANDROID_NONE);
+}
+
+static void
+android_clip_to_row (struct window *w, struct glyph_row *row,
+ enum glyph_row_area area, struct android_gc *gc,
+ struct android_rectangle *rect_return)
+{
+ struct android_rectangle clip_rect;
+ int window_x, window_y, window_width;
+
+ window_box (w, area, &window_x, &window_y, &window_width, 0);
+
+ clip_rect.x = window_x;
+ clip_rect.y = WINDOW_TO_FRAME_PIXEL_Y (w, max (0, row->y));
+ clip_rect.y = max (clip_rect.y, window_y);
+ clip_rect.width = window_width;
+ clip_rect.height = row->visible_height;
+
+ android_set_clip_rectangles (gc, 0, 0, &clip_rect, 1);
+
+ if (rect_return)
+ *rect_return = clip_rect;
+}
+
+static void
+android_draw_fringe_bitmap (struct window *w, struct glyph_row *row,
+ struct draw_fringe_bitmap_params *p)
+{
+ struct frame *f = XFRAME (WINDOW_FRAME (w));
+ struct android_gc *gc = f->output_data.android->normal_gc;
+ struct face *face = p->face;
+ struct android_rectangle clip_rect;
+
+ /* Must clip because of partially visible lines. */
+ android_clip_to_row (w, row, ANY_AREA, gc, &clip_rect);
+
+ 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
+ mono-displays, the fill style may have been changed to
+ ANDROID_FILL_SOLID in
+ android_draw_glyph_string_background. */
+ if (face->stipple)
+ {
+ android_set_fill_style (face->gc, ANDROID_FILL_OPAQUE_STIPPLED);
+ android_fill_rectangle (FRAME_ANDROID_DRAWABLE (f), face->gc,
+ p->bx, p->by, p->nx, p->ny);
+ android_set_fill_style (face->gc, ANDROID_FILL_SOLID);
+
+ row->stipple_p = true;
+ }
+ else
+ {
+ android_set_background (face->gc, face->background);
+ android_clear_rectangle (f, face->gc, p->bx, p->by, p->nx, p->ny);
+ android_set_foreground (face->gc, face->foreground);
+ }
+ }
+
+ if (p->which)
+ {
+ android_drawable drawable;
+ char *bits;
+ android_pixmap pixmap, clipmask;
+ struct android_gc_values gcv;
+ unsigned long background, cursor_pixel;
+ int depth;
+ struct android_rectangle image_rect, dest;
+ int px, py, pwidth, pheight;
+
+ drawable = FRAME_ANDROID_DRAWABLE (f);
+ clipmask = ANDROID_NONE;
+ background = face->background;
+ cursor_pixel = f->output_data.android->cursor_pixel;
+ depth = FRAME_DISPLAY_INFO (f)->n_planes;
+
+ /* Intersect the destination rectangle with that of the row.
+ Setting a clip mask overrides the clip rectangles provided by
+ android_clip_to_row, so clipping must be performed by
+ hand. */
+
+ image_rect.x = p->x;
+ image_rect.y = p->y;
+ image_rect.width = p->wd;
+ image_rect.height = p->h;
+
+ if (!gui_intersect_rectangles (&clip_rect, &image_rect, &dest))
+ /* The entire destination rectangle falls outside the row. */
+ goto undo_clip;
+
+ /* Extrapolate the source rectangle from the difference between
+ the destination and image rectangles. */
+
+ px = dest.x - image_rect.x;
+ py = dest.y - image_rect.y;
+ pwidth = dest.width;
+ pheight = dest.height;
+
+ if (p->wd > 8)
+ bits = (char *) (p->bits + p->dh);
+ else
+ bits = (char *) p->bits + p->dh;
+
+ pixmap = android_create_pixmap_from_bitmap_data (bits, p->wd, p->h,
+ (p->cursor_p
+ ? (p->overlay_p
+ ? face->background
+ : cursor_pixel)
+ : face->foreground),
+ background, depth);
+
+ if (p->overlay_p)
+ {
+ clipmask = android_create_pixmap_from_bitmap_data (bits, p->wd, p->h,
+ 1, 0, 1);
+
+ gcv.clip_mask = clipmask;
+ gcv.clip_x_origin = p->x;
+ gcv.clip_y_origin = p->y;
+ android_change_gc (gc, (ANDROID_GC_CLIP_MASK
+ | ANDROID_GC_CLIP_X_ORIGIN
+ | ANDROID_GC_CLIP_Y_ORIGIN),
+ &gcv);
+ }
+
+ android_copy_area (pixmap, drawable, gc, px, py,
+ pwidth, pheight, dest.x, dest.y);
+ android_free_pixmap (pixmap);
+
+ if (p->overlay_p)
+ {
+ gcv.clip_mask = ANDROID_NONE;
+ android_change_gc (gc, ANDROID_GC_CLIP_MASK, &gcv);
+ android_free_pixmap (clipmask);
+ }
+ }
+
+ undo_clip:
+ android_reset_clip_rectangles (f, gc);
+}
+
+/* Set S->gc to a suitable GC for drawing glyph string S in cursor
+ face. */
+
+static void
+android_set_cursor_gc (struct glyph_string *s)
+{
+ if (s->font == FRAME_FONT (s->f)
+ && s->face->background == FRAME_BACKGROUND_PIXEL (s->f)
+ && s->face->foreground == FRAME_FOREGROUND_PIXEL (s->f)
+ && !s->cmp)
+ s->gc = s->f->output_data.android->cursor_gc;
+ else
+ {
+ /* Cursor on non-default face: must merge. */
+ struct android_gc_values xgcv;
+ unsigned long mask;
+
+ xgcv.background = s->f->output_data.android->cursor_pixel;
+ xgcv.foreground = s->face->background;
+
+ /* If the glyph would be invisible, try a different foreground. */
+ if (xgcv.foreground == xgcv.background)
+ xgcv.foreground = s->face->foreground;
+ if (xgcv.foreground == xgcv.background)
+ xgcv.foreground = s->f->output_data.android->cursor_foreground_pixel;
+ if (xgcv.foreground == xgcv.background)
+ xgcv.foreground = s->face->foreground;
+
+ /* Make sure the cursor is distinct from text in this face. */
+ if (xgcv.background == s->face->background
+ && xgcv.foreground == s->face->foreground)
+ {
+ xgcv.background = s->face->foreground;
+ xgcv.foreground = s->face->background;
+ }
+
+ mask = (ANDROID_GC_FOREGROUND | ANDROID_GC_BACKGROUND);
+
+ if (FRAME_DISPLAY_INFO (s->f)->scratch_cursor_gc)
+ android_change_gc (FRAME_DISPLAY_INFO (s->f)->scratch_cursor_gc,
+ mask, &xgcv);
+ else
+ FRAME_DISPLAY_INFO (s->f)->scratch_cursor_gc
+ = android_create_gc (mask, &xgcv);
+
+ s->gc = FRAME_DISPLAY_INFO (s->f)->scratch_cursor_gc;
+ }
+}
+
+
+/* Set up S->gc of glyph string S for drawing text in mouse face. */
+
+static void
+android_set_mouse_face_gc (struct glyph_string *s)
+{
+ if (s->font == s->face->font)
+ s->gc = s->face->gc;
+ else
+ {
+ /* Otherwise construct scratch_cursor_gc with values from FACE
+ except for FONT. */
+ struct android_gc_values xgcv;
+ unsigned long mask;
+
+ xgcv.background = s->face->background;
+ xgcv.foreground = s->face->foreground;
+
+ mask = (ANDROID_GC_FOREGROUND | ANDROID_GC_BACKGROUND);
+
+ if (FRAME_DISPLAY_INFO (s->f)->scratch_cursor_gc)
+ android_change_gc (FRAME_DISPLAY_INFO (s->f)->scratch_cursor_gc,
+ mask, &xgcv);
+ else
+ FRAME_DISPLAY_INFO (s->f)->scratch_cursor_gc
+ = android_create_gc (mask, &xgcv);
+
+ s->gc = FRAME_DISPLAY_INFO (s->f)->scratch_cursor_gc;
+ }
+
+ eassert (s->gc != 0);
+}
+
+
+/* Set S->gc of glyph string S to a GC suitable for drawing a mode line.
+ Faces to use in the mode line have already been computed when the
+ matrix was built, so there isn't much to do, here. */
+
+static void
+android_set_mode_line_face_gc (struct glyph_string *s)
+{
+ s->gc = s->face->gc;
+}
+
+/* Set S->gc of glyph string S for drawing that glyph string. Set
+ S->stippled_p to a non-zero value if the face of S has a stipple
+ pattern. */
+
+static void
+android_set_glyph_string_gc (struct glyph_string *s)
+{
+ prepare_face_for_display (s->f, s->face);
+
+ if (s->hl == DRAW_NORMAL_TEXT)
+ {
+ s->gc = s->face->gc;
+ s->stippled_p = s->face->stipple != 0;
+ }
+ else if (s->hl == DRAW_INVERSE_VIDEO)
+ {
+ android_set_mode_line_face_gc (s);
+ s->stippled_p = s->face->stipple != 0;
+ }
+ else if (s->hl == DRAW_CURSOR)
+ {
+ android_set_cursor_gc (s);
+ s->stippled_p = false;
+ }
+ else if (s->hl == DRAW_MOUSE_FACE)
+ {
+ android_set_mouse_face_gc (s);
+ s->stippled_p = s->face->stipple != 0;
+ }
+ else if (s->hl == DRAW_IMAGE_RAISED
+ || s->hl == DRAW_IMAGE_SUNKEN)
+ {
+ s->gc = s->face->gc;
+ s->stippled_p = s->face->stipple != 0;
+ }
+ else
+ emacs_abort ();
+
+ /* GC must have been set. */
+ eassert (s->gc != 0);
+}
+
+
+/* Set clipping for output of glyph string S. S may be part of a mode
+ line or menu if we don't have X toolkit support. */
+
+static void
+android_set_glyph_string_clipping (struct glyph_string *s)
+{
+ struct android_rectangle *r = s->clip;
+ int n = get_glyph_string_clip_rects (s, r, 2);
+
+ if (n > 0)
+ android_set_clip_rectangles (s->gc, 0, 0, r, n);
+ s->num_clips = n;
+}
+
+
+/* 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
+android_set_glyph_string_clipping_exactly (struct glyph_string *src,
+ struct glyph_string *dst)
+{
+ struct android_rectangle r;
+
+ r.x = src->x;
+ r.width = src->width;
+ r.y = src->y;
+ r.height = src->height;
+ dst->clip[0] = r;
+ dst->num_clips = 1;
+ android_set_clip_rectangles (dst->gc, 0, 0, &r, 1);
+}
+
+static void
+android_compute_glyph_string_overhangs (struct glyph_string *s)
+{
+ if (s->cmp == NULL
+ && (s->first_glyph->type == CHAR_GLYPH
+ || s->first_glyph->type == COMPOSITE_GLYPH))
+ {
+ struct font_metrics metrics;
+
+ if (s->first_glyph->type == CHAR_GLYPH)
+ {
+ struct font *font = s->font;
+ font->driver->text_extents (font, s->char2b, s->nchars, &metrics);
+ }
+ else
+ {
+ Lisp_Object gstring = composition_gstring_from_id (s->cmp_id);
+
+ composition_gstring_width (gstring, s->cmp_from, s->cmp_to, &metrics);
+ }
+ s->right_overhang = (metrics.rbearing > metrics.width
+ ? metrics.rbearing - metrics.width : 0);
+ s->left_overhang = metrics.lbearing < 0 ? - metrics.lbearing : 0;
+ }
+ else if (s->cmp)
+ {
+ s->right_overhang = s->cmp->rbearing - s->cmp->pixel_width;
+ s->left_overhang = - s->cmp->lbearing;
+ }
+}
+
+static void
+android_clear_glyph_string_rect (struct glyph_string *s, int x, int y,
+ int w, int h)
+{
+ android_clear_rectangle (s->f, s->gc, x, y, w, h);
+}
+
+static void
+android_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. */
+ if (!s->background_filled_p)
+ {
+ int box_line_width = max (s->face->box_horizontal_line_width, 0);
+
+ if (s->stippled_p)
+ {
+ /* Fill background with a stipple pattern. */
+ android_set_fill_style (s->gc, ANDROID_FILL_OPAQUE_STIPPLED);
+ android_fill_rectangle (FRAME_ANDROID_DRAWABLE (s->f), s->gc,
+ s->x, s->y + box_line_width,
+ s->background_width,
+ s->height - 2 * box_line_width);
+ android_set_fill_style (s->gc, ANDROID_FILL_SOLID);
+ s->background_filled_p = true;
+ }
+ else if (FONT_HEIGHT (s->font) < s->height - 2 * box_line_width
+ /* When xdisp.c ignores FONT_HEIGHT, we cannot trust
+ font dimensions, since the actual glyphs might be
+ much smaller. So in that case we always clear the
+ rectangle with background color. */
+ || FONT_TOO_HIGH (s->font)
+ || s->font_not_found_p
+ || s->extends_to_end_of_line_p
+ || force_p)
+ {
+ android_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;
+ }
+ }
+}
+
+static void
+android_fill_triangle (struct frame *f, struct android_gc *gc,
+ struct android_point point1,
+ struct android_point point2,
+ struct android_point point3)
+{
+ struct android_point abc[3];
+
+ abc[0] = point1;
+ abc[1] = point2;
+ abc[2] = point3;
+
+ android_fill_polygon (FRAME_ANDROID_DRAWABLE (f),
+ gc, abc, 3, ANDROID_CONVEX,
+ ANDROID_COORD_MODE_ORIGIN);
+}
+
+static struct android_point
+android_make_point (int x, int y)
+{
+ struct android_point pt;
+
+ pt.x = x;
+ pt.y = y;
+
+ return pt;
+}
+
+static bool
+android_inside_rect_p (struct android_rectangle *rects, int nrects, int x,
+ int y)
+{
+ int i;
+
+ for (i = 0; i < nrects; ++i)
+ {
+ if (x >= rects[i].x && y >= rects[i].y
+ && x < rects[i].x + rects[i].width
+ && y < rects[i].y + rects[i].height)
+ return true;
+ }
+
+ return false;
+}
+
+static void
+android_clear_point (struct frame *f, struct android_gc *gc,
+ int x, int y)
+{
+ struct android_gc_values xgcv;
+
+ android_get_gc_values (gc, ANDROID_GC_BACKGROUND | ANDROID_GC_FOREGROUND,
+ &xgcv);
+ android_set_foreground (gc, xgcv.background);
+ android_draw_point (FRAME_ANDROID_DRAWABLE (f), gc, x, y);
+ android_set_foreground (gc, xgcv.foreground);
+}
+
+static void
+android_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,
+ struct android_rectangle *clip_rect)
+{
+ struct android_gc *gc, *white_gc, *black_gc, *normal_gc;
+ android_drawable drawable;
+
+ /* This code is more complicated than it has to be, because of two
+ minor hacks to make the boxes look nicer: (i) if width > 1, draw
+ the outermost line using the black relief. (ii) Omit the four
+ corner pixels. */
+
+ white_gc = f->output_data.android->white_relief.gc;
+ black_gc = f->output_data.android->black_relief.gc;
+ normal_gc = f->output_data.android->normal_gc;
+
+ drawable = FRAME_ANDROID_DRAWABLE (f);
+
+ android_set_clip_rectangles (white_gc, 0, 0, clip_rect, 1);
+ android_set_clip_rectangles (black_gc, 0, 0, clip_rect, 1);
+
+ if (raised_p)
+ gc = white_gc;
+ else
+ gc = black_gc;
+
+ /* Draw lines. */
+
+ if (top_p)
+ android_fill_rectangle (FRAME_ANDROID_DRAWABLE (f), gc, left_x, top_y,
+ right_x - left_x + 1, hwidth);
+
+ if (left_p)
+ android_fill_rectangle (FRAME_ANDROID_DRAWABLE (f), gc, left_x, top_y,
+ vwidth, bottom_y - top_y + 1);
+
+ if (raised_p)
+ gc = black_gc;
+ else
+ gc = white_gc;
+
+ if (bot_p)
+ android_fill_rectangle (FRAME_ANDROID_DRAWABLE (f), gc, left_x,
+ bottom_y - hwidth + 1,
+ right_x - left_x + 1, hwidth);
+
+ if (right_p)
+ android_fill_rectangle (FRAME_ANDROID_DRAWABLE (f), gc,
+ right_x - vwidth + 1,
+ top_y, vwidth, bottom_y - top_y + 1);
+
+ /* Draw corners. */
+
+ if (bot_p && left_p)
+ android_fill_triangle (f, raised_p ? white_gc : black_gc,
+ android_make_point (left_x, bottom_y - hwidth),
+ android_make_point (left_x + vwidth,
+ bottom_y - hwidth),
+ android_make_point (left_x, bottom_y));
+
+ if (top_p && right_p)
+ android_fill_triangle (f, raised_p ? white_gc : black_gc,
+ android_make_point (right_x - vwidth, top_y),
+ android_make_point (right_x, top_y),
+ android_make_point (right_x - vwidth,
+ top_y + hwidth));
+
+ /* Draw outer line. */
+
+ if (top_p && left_p && bot_p && right_p
+ && hwidth > 1 && vwidth > 1)
+ android_draw_rectangle (FRAME_ANDROID_DRAWABLE (f),
+ black_gc, left_x, top_y,
+ right_x - left_x, bottom_y - top_y);
+ else
+ {
+ if (top_p && hwidth > 1)
+ android_draw_line (drawable, black_gc, left_x, top_y,
+ right_x + 1, top_y);
+
+ if (bot_p && hwidth > 1)
+ android_draw_line (drawable, black_gc, left_x, bottom_y,
+ right_x + 1, bottom_y);
+
+ if (left_p && vwidth > 1)
+ android_draw_line (drawable, black_gc, left_x, top_y,
+ left_x, bottom_y + 1);
+
+ if (right_p && vwidth > 1)
+ android_draw_line (drawable, black_gc, right_x, top_y,
+ right_x, bottom_y + 1);
+ }
+
+ /* Erase corners. */
+
+ if (hwidth > 1 && vwidth > 1)
+ {
+ if (left_p && top_p && android_inside_rect_p (clip_rect, 1,
+ left_x, top_y))
+ android_clear_point (f, normal_gc, left_x, top_y);
+
+ if (left_p && bot_p && android_inside_rect_p (clip_rect, 1,
+ left_x, bottom_y))
+ android_clear_point (f, normal_gc, left_x, bottom_y);
+
+ if (right_p && top_p && android_inside_rect_p (clip_rect, 1,
+ right_x, top_y))
+ android_clear_point (f, normal_gc, right_x, top_y);
+
+ if (right_p && bot_p && android_inside_rect_p (clip_rect, 1,
+ right_x, bottom_y))
+ android_clear_point (f, normal_gc, right_x, bottom_y);
+ }
+
+ android_reset_clip_rectangles (f, white_gc);
+ android_reset_clip_rectangles (f, black_gc);
+}
+
+static void
+android_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,
+ struct android_rectangle *clip_rect)
+{
+ struct android_gc_values xgcv;
+
+ android_get_gc_values (s->gc, ANDROID_GC_FOREGROUND, &xgcv);
+ android_set_foreground (s->gc, s->face->box_color);
+ android_set_clip_rectangles (s->gc, 0, 0, clip_rect, 1);
+
+ /* Top. */
+ android_fill_rectangle (FRAME_ANDROID_DRAWABLE (s->f), s->gc, left_x,
+ top_y, right_x - left_x + 1, hwidth);
+
+ /* Left. */
+ if (left_p)
+ android_fill_rectangle (FRAME_ANDROID_DRAWABLE (s->f), s->gc, left_x,
+ top_y, vwidth, bottom_y - top_y + 1);
+
+ /* Bottom. */
+ android_fill_rectangle (FRAME_ANDROID_DRAWABLE (s->f), s->gc, left_x,
+ bottom_y - hwidth + 1, right_x - left_x + 1,
+ hwidth);
+
+ /* Right. */
+ if (right_p)
+ android_fill_rectangle (FRAME_ANDROID_DRAWABLE (s->f), s->gc,
+ right_x - vwidth + 1, top_y, vwidth,
+ bottom_y - top_y + 1);
+
+ android_set_foreground (s->gc, xgcv.foreground);
+ android_reset_clip_rectangles (s->f, s->gc);
+}
+
+#define HIGHLIGHT_COLOR_DARK_BOOST_LIMIT 48000
+
+static bool
+android_alloc_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;
+ android_query_colors (f, &color, 1);
+
+ /* Change RGB values by specified FACTOR. Avoid overflow! */
+ eassert (factor >= 0);
+ new.red = min (0xffff, factor * color.red);
+ new.green = min (0xffff, factor * color.green);
+ new.blue = min (0xffff, factor * color.blue);
+
+ /* Calculate brightness of COLOR. */
+ bright = (2 * color.red + 3 * color.green + color.blue) / 6;
+
+ /* We only boost colors that are darker than
+ HIGHLIGHT_COLOR_DARK_BOOST_LIMIT. */
+ if (bright < HIGHLIGHT_COLOR_DARK_BOOST_LIMIT)
+ /* Make an additive adjustment to NEW, because it's dark enough so
+ 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;
+ /* The additive adjustment. */
+ int min_delta = delta * dimness * factor / 2;
+
+ if (factor < 1)
+ {
+ new.red = max (0, new.red - min_delta);
+ new.green = max (0, new.green - min_delta);
+ new.blue = max (0, new.blue - min_delta);
+ }
+ else
+ {
+ new.red = min (0xffff, min_delta + new.red);
+ new.green = min (0xffff, min_delta + new.green);
+ new.blue = min (0xffff, min_delta + new.blue);
+ }
+ }
+
+ /* Try to allocate the color. */
+ success_p = android_alloc_nearest_color (f, &new);
+
+ if (success_p)
+ {
+ 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);
+ success_p = android_alloc_nearest_color (f, &new);
+ }
+ else
+ success_p = true;
+
+ *pixel = new.pixel;
+ }
+
+ return success_p;
+}
+
+/* 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.android->relief_background. If such a color
+ cannot be allocated, use DEFAULT_PIXEL, instead. */
+
+static void
+android_setup_relief_color (struct frame *f, struct relief *relief,
+ double factor, int delta,
+ unsigned long default_pixel)
+{
+ struct android_gc_values xgcv;
+ struct android_output *di = f->output_data.android;
+ unsigned long mask = ANDROID_GC_FOREGROUND;
+ unsigned long pixel;
+ unsigned long background = di->relief_background;
+ struct android_display_info *dpyinfo = FRAME_DISPLAY_INFO (f);
+
+ if (relief->gc && relief->pixel != -1)
+ relief->pixel = -1;
+
+ /* Allocate new color. */
+ xgcv.foreground = default_pixel;
+ pixel = background;
+
+ if (dpyinfo->n_planes != 1
+ && android_alloc_lighter_color (f, &pixel, factor, delta))
+ xgcv.foreground = relief->pixel = pixel;
+
+ if (relief->gc == 0)
+ relief->gc = android_create_gc (mask, &xgcv);
+ else
+ android_change_gc (relief->gc, mask, &xgcv);
+}
+
+/* Set up colors for the relief lines around glyph string S. */
+
+static void
+android_setup_relief_colors (struct glyph_string *s)
+{
+ struct android_output *di;
+ unsigned long color;
+
+ di = s->f->output_data.android;
+
+ if (s->face->use_box_color_for_shadows_p)
+ color = s->face->box_color;
+ else if (s->first_glyph->type == IMAGE_GLYPH
+ && s->img->pixmap
+ && !IMAGE_BACKGROUND_TRANSPARENT (s->img, s->f, 0))
+ color = IMAGE_BACKGROUND (s->img, s->f, 0);
+ else
+ {
+ struct android_gc_values xgcv;
+
+ /* Get the background color of the face. */
+ android_get_gc_values (s->gc, ANDROID_GC_BACKGROUND, &xgcv);
+ color = xgcv.background;
+ }
+
+ if (di->white_relief.gc == 0
+ || color != di->relief_background)
+ {
+ di->relief_background = color;
+ android_setup_relief_color (s->f, &di->white_relief, 1.2, 0x8000,
+ WHITE_PIX_DEFAULT (s->f));
+ android_setup_relief_color (s->f, &di->black_relief, 0.6, 0x4000,
+ BLACK_PIX_DEFAULT (s->f));
+ }
+}
+
+static void
+android_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;
+ struct glyph *last_glyph;
+ struct android_rectangle clip_rect;
+
+ last_x = ((s->row->full_width_p && !s->w->pseudo_window_p)
+ ? WINDOW_RIGHT_EDGE_X (s->w)
+ : window_box_right (s->w, s->area));
+
+ /* The glyph that may have a right box line. For static
+ compositions and images, the right-box flag is on the first glyph
+ of the glyph string; for other types it's on the last glyph. */
+ if (s->cmp || s->img)
+ last_glyph = s->first_glyph;
+ else if (s->first_glyph->type == COMPOSITE_GLYPH
+ && s->first_glyph->u.cmp.automatic)
+ {
+ /* For automatic compositions, we need to look up the last glyph
+ in the composition. */
+ struct glyph *end = s->row->glyphs[s->area] + s->row->used[s->area];
+ struct glyph *g = s->first_glyph;
+ for (last_glyph = g++;
+ g < end && g->u.cmp.automatic && g->u.cmp.id == s->cmp_id
+ && g->slice.cmp.to < s->cmp_to;
+ last_glyph = g++)
+ ;
+ }
+ else
+ last_glyph = s->first_glyph + s->nchars - 1;
+
+ vwidth = eabs (s->face->box_vertical_line_width);
+ hwidth = eabs (s->face->box_horizontal_line_width);
+ raised_p = s->face->box == FACE_RAISED_BOX;
+ left_x = s->x;
+ right_x = (s->row->full_width_p && s->extends_to_end_of_line_p
+ ? last_x - 1
+ : min (last_x, s->x + s->background_width) - 1);
+ top_y = s->y;
+ bottom_y = top_y + s->height - 1;
+
+ left_p = (s->first_glyph->left_box_line_p
+ || (s->hl == DRAW_MOUSE_FACE
+ && (s->prev == NULL
+ || s->prev->hl != s->hl)));
+ right_p = (last_glyph->right_box_line_p
+ || (s->hl == DRAW_MOUSE_FACE
+ && (s->next == NULL
+ || s->next->hl != s->hl)));
+
+ get_glyph_string_clip_rect (s, &clip_rect);
+
+ if (s->face->box == FACE_SIMPLE_BOX)
+ android_draw_box_rect (s, left_x, top_y, right_x, bottom_y, hwidth,
+ vwidth, left_p, right_p, &clip_rect);
+ else
+ {
+ android_setup_relief_colors (s);
+ android_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
+android_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. */
+ android_set_fill_style (s->gc, ANDROID_FILL_OPAQUE_STIPPLED);
+ android_fill_rectangle (FRAME_ANDROID_DRAWABLE (s->f), s->gc, x,
+ y, w, h);
+ android_set_fill_style (s->gc, ANDROID_FILL_SOLID);
+ }
+ else
+ android_clear_glyph_string_rect (s, x, y, w, h);
+}
+
+static void
+android_draw_image_relief (struct glyph_string *s)
+{
+ int x1, y1, thick;
+ bool raised_p, top_p, bot_p, left_p, right_p;
+ int extra_x, extra_y;
+ struct android_rectangle r;
+ int x = s->x;
+ int y = s->ybase - image_ascent (s->img, s->face, &s->slice);
+
+ /* If first glyph of S has a left box line, start drawing it to the
+ right of that line. */
+ if (s->face->box != FACE_NO_BOX
+ && s->first_glyph->left_box_line_p
+ && s->slice.x == 0)
+ x += max (s->face->box_vertical_line_width, 0);
+
+ /* If there is a margin around the image, adjust x- and y-position
+ by that margin. */
+ if (s->slice.x == 0)
+ x += s->img->hmargin;
+ if (s->slice.y == 0)
+ y += s->img->vmargin;
+
+ if (s->hl == DRAW_IMAGE_SUNKEN
+ || s->hl == DRAW_IMAGE_RAISED)
+ {
+ if (s->face->id == TAB_BAR_FACE_ID)
+ thick = (tab_bar_button_relief < 0
+ ? DEFAULT_TAB_BAR_BUTTON_RELIEF
+ : min (tab_bar_button_relief, 1000000));
+ else
+ thick = (tool_bar_button_relief < 0
+ ? DEFAULT_TOOL_BAR_BUTTON_RELIEF
+ : min (tool_bar_button_relief, 1000000));
+ raised_p = s->hl == DRAW_IMAGE_RAISED;
+ }
+ else
+ {
+ thick = eabs (s->img->relief);
+ raised_p = s->img->relief > 0;
+ }
+
+ x1 = x + s->slice.width - 1;
+ y1 = y + s->slice.height - 1;
+
+ extra_x = extra_y = 0;
+ if (s->face->id == TAB_BAR_FACE_ID)
+ {
+ if (CONSP (Vtab_bar_button_margin)
+ && FIXNUMP (XCAR (Vtab_bar_button_margin))
+ && FIXNUMP (XCDR (Vtab_bar_button_margin)))
+ {
+ extra_x = XFIXNUM (XCAR (Vtab_bar_button_margin)) - thick;
+ extra_y = XFIXNUM (XCDR (Vtab_bar_button_margin)) - thick;
+ }
+ else if (FIXNUMP (Vtab_bar_button_margin))
+ extra_x = extra_y = XFIXNUM (Vtab_bar_button_margin) - thick;
+ }
+
+ if (s->face->id == TOOL_BAR_FACE_ID)
+ {
+ if (CONSP (Vtool_bar_button_margin)
+ && FIXNUMP (XCAR (Vtool_bar_button_margin))
+ && FIXNUMP (XCDR (Vtool_bar_button_margin)))
+ {
+ extra_x = XFIXNUM (XCAR (Vtool_bar_button_margin));
+ extra_y = XFIXNUM (XCDR (Vtool_bar_button_margin));
+ }
+ else if (FIXNUMP (Vtool_bar_button_margin))
+ extra_x = extra_y = XFIXNUM (Vtool_bar_button_margin);
+ }
+
+ top_p = bot_p = left_p = right_p = false;
+
+ if (s->slice.x == 0)
+ x -= thick + extra_x, left_p = true;
+ if (s->slice.y == 0)
+ y -= thick + extra_y, top_p = true;
+ if (s->slice.x + s->slice.width == s->img->width)
+ x1 += thick + extra_x, right_p = true;
+ if (s->slice.y + s->slice.height == s->img->height)
+ y1 += thick + extra_y, bot_p = true;
+
+ android_setup_relief_colors (s);
+ get_glyph_string_clip_rect (s, &r);
+ android_draw_relief_rect (s->f, x, y, x1, y1, thick, thick, raised_p,
+ top_p, bot_p, left_p, right_p, &r);
+}
+
+static void
+android_draw_image_foreground (struct glyph_string *s)
+{
+ int x = s->x;
+ int y = s->ybase - image_ascent (s->img, s->face, &s->slice);
+
+ /* If first glyph of S has a left box line, start drawing it to the
+ right of that line. */
+ if (s->face->box != FACE_NO_BOX
+ && s->first_glyph->left_box_line_p
+ && s->slice.x == 0)
+ x += max (s->face->box_vertical_line_width, 0);
+
+ /* If there is a margin around the image, adjust x- and y-position
+ by that margin. */
+ if (s->slice.x == 0)
+ x += s->img->hmargin;
+ if (s->slice.y == 0)
+ y += s->img->vmargin;
+
+ if (s->img->pixmap)
+ {
+ unsigned long mask = (ANDROID_GC_CLIP_MASK
+ | ANDROID_GC_CLIP_X_ORIGIN
+ | ANDROID_GC_CLIP_Y_ORIGIN
+ | ANDROID_GC_FUNCTION);
+ struct android_gc_values xgcv;
+ struct android_rectangle clip_rect, image_rect, r;
+
+ xgcv.clip_mask = s->img->mask;
+ xgcv.clip_x_origin = x - s->slice.x;
+ xgcv.clip_y_origin = y - s->slice.y;
+ xgcv.function = ANDROID_GC_COPY;
+ android_change_gc (s->gc, mask, &xgcv);
+
+ get_glyph_string_clip_rect (s, &clip_rect);
+ image_rect.x = x;
+ image_rect.y = y;
+ image_rect.width = s->slice.width;
+ image_rect.height = s->slice.height;
+
+ if (gui_intersect_rectangles (&clip_rect, &image_rect, &r))
+ android_copy_area (s->img->pixmap,
+ FRAME_ANDROID_DRAWABLE (s->f),
+ s->gc, s->slice.x + r.x - x,
+ s->slice.y + r.y - y,
+ r.width, r.height, r.x, r.y);
+
+ /* When the image has a mask, we can expect that at least part
+ of a mouse highlight or a block cursor will be visible. If
+ the image doesn't have a mask, make a block cursor visible by
+ drawing a rectangle around the image. I believe it's looking
+ better if we do nothing here for mouse-face. */
+ if (s->hl == DRAW_CURSOR && !s->img->mask)
+ {
+ int relief = eabs (s->img->relief);
+ android_draw_rectangle (FRAME_ANDROID_DRAWABLE (s->f), s->gc,
+ x - relief, y - relief,
+ s->slice.width + relief*2 - 1,
+ s->slice.height + relief*2 - 1);
+ }
+
+ android_set_clip_mask (s->gc, ANDROID_NONE);
+ }
+ else
+ /* Draw a rectangle if image could not be loaded. */
+ android_draw_rectangle (FRAME_ANDROID_DRAWABLE (s->f), s->gc, x, y,
+ s->slice.width - 1, s->slice.height - 1);
+}
+
+static void
+android_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);
+ int height;
+
+ height = s->height;
+ if (s->slice.y == 0)
+ height -= box_line_vwidth;
+ if (s->slice.y + s->slice.height >= s->img->height)
+ height -= box_line_vwidth;
+
+ /* Fill background with face under the image. Do it only if row is
+ taller than image or if image has a clip mask to reduce
+ flickering. */
+ s->stippled_p = s->face->stipple != 0;
+ if (height > s->slice.height
+ || s->img->hmargin
+ || s->img->vmargin
+ || s->img->mask
+ || s->img->pixmap == 0
+ || s->width != s->background_width)
+ {
+ if (s->stippled_p)
+ s->row->stipple_p = true;
+
+ 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;
+
+ android_draw_glyph_string_bg_rect (s, x, y, width, height);
+
+ s->background_filled_p = true;
+ }
+
+ /* Draw the foreground. */
+ android_draw_image_foreground (s);
+ android_set_glyph_string_clipping (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)
+ android_draw_image_relief (s);
+}
+
+static void
+android_draw_stretch_glyph_string (struct glyph_string *s)
+{
+ eassert (s->first_glyph->type == STRETCH_GLYPH);
+
+ if (s->hl == DRAW_CURSOR && !x_stretch_cursor_p)
+ {
+ /* If `x-stretch-cursor' is nil, don't draw a block cursor as
+ wide as the stretch glyph. */
+ int width, background_width = s->background_width;
+ int x = s->x;
+
+ if (!s->row->reversed_p)
+ {
+ int left_x = window_box_left_offset (s->w, TEXT_AREA);
+
+ if (x < left_x)
+ {
+ background_width -= left_x - x;
+ x = left_x;
+ }
+ }
+ else
+ {
+ /* In R2L rows, draw the cursor on the right edge of the
+ stretch glyph. */
+ int right_x = window_box_right (s->w, TEXT_AREA);
+
+ if (x + background_width > right_x)
+ background_width -= x - right_x;
+ x += background_width;
+ }
+ width = min (FRAME_COLUMN_WIDTH (s->f), background_width);
+ if (s->row->reversed_p)
+ x -= width;
+
+ /* Draw cursor. */
+ android_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)
+ {
+ int y = s->y;
+ int w = background_width - width, h = s->height;
+ struct android_rectangle r;
+ struct android_gc *gc;
+
+ if (!s->row->reversed_p)
+ x += width;
+ else
+ x = s->x;
+ if (s->row->mouse_face_p
+ && cursor_in_mouse_face_p (s->w))
+ {
+ android_set_mouse_face_gc (s);
+ gc = s->gc;
+ }
+ else
+ gc = s->face->gc;
+
+ get_glyph_string_clip_rect (s, &r);
+ android_set_clip_rectangles (gc, 0, 0, &r, 1);
+
+ if (s->face->stipple)
+ {
+ /* Fill background with a stipple pattern. */
+ android_set_fill_style (gc, ANDROID_FILL_OPAQUE_STIPPLED);
+ android_fill_rectangle (FRAME_ANDROID_DRAWABLE (s->f),
+ gc, x, y, w, h);
+ android_set_fill_style (gc, ANDROID_FILL_SOLID);
+
+ s->row->stipple_p = true;
+ }
+ else
+ {
+ struct android_gc_values xgcv;
+ android_get_gc_values (gc, (ANDROID_GC_FOREGROUND
+ | ANDROID_GC_BACKGROUND),
+ &xgcv);
+ android_set_foreground (gc, xgcv.background);
+ android_fill_rectangle (FRAME_ANDROID_DRAWABLE (s->f),
+ gc, x, y, w, h);
+ android_set_foreground (gc, xgcv.foreground);
+ }
+
+ android_reset_clip_rectangles (s->f, gc);
+ }
+ }
+ else if (!s->background_filled_p)
+ {
+ int background_width = s->background_width;
+ int x = s->x, text_left_x = window_box_left (s->w, TEXT_AREA);
+
+ /* Don't draw into left fringe or scrollbar area except for
+ header line and mode line. */
+ if (s->area == TEXT_AREA
+ && x < text_left_x && !s->row->mode_line_p)
+ {
+ background_width -= text_left_x - x;
+ x = text_left_x;
+ }
+
+ if (!s->row->stipple_p)
+ s->row->stipple_p = s->stippled_p;
+
+ if (background_width > 0)
+ android_draw_glyph_string_bg_rect (s, x, s->y,
+ background_width,
+ s->height);
+ }
+
+ s->background_filled_p = true;
+}
+
+static void
+android_get_scale_factor (int *scale_x, int *scale_y)
+{
+ /* This is 96 everywhere else, but 160 on Android. */
+ const int base_res = 160;
+ struct android_display_info *dpyinfo;
+
+ dpyinfo = x_display_list;
+ *scale_x = *scale_y = 1;
+
+ if (dpyinfo)
+ {
+ if (dpyinfo->resx > base_res)
+ *scale_x = floor (dpyinfo->resx / base_res);
+ if (dpyinfo->resy > base_res)
+ *scale_y = floor (dpyinfo->resy / base_res);
+ }
+}
+
+static void
+android_draw_underwave (struct glyph_string *s, int decoration_width)
+{
+ int scale_x, scale_y;
+
+ android_get_scale_factor (&scale_x, &scale_y);
+
+ int wave_height = 3 * scale_y, wave_length = 2 * scale_x;
+
+ int dx, dy, x0, y0, width, x1, y1, x2, y2, xmax;
+ bool odd;
+ struct android_rectangle wave_clip, string_clip, final_clip;
+
+ dx = wave_length;
+ dy = wave_height - 1;
+ x0 = s->x;
+ y0 = s->ybase + wave_height / 2;
+ width = decoration_width;
+ xmax = x0 + width;
+
+ /* Find and set clipping rectangle */
+
+ wave_clip.x = x0;
+ wave_clip.y = y0;
+ wave_clip.width = width;
+ wave_clip.height = wave_height;
+ get_glyph_string_clip_rect (s, &string_clip);
+
+ if (!gui_intersect_rectangles (&wave_clip, &string_clip, &final_clip))
+ return;
+
+ android_set_clip_rectangles (s->gc, 0, 0, &final_clip, 1);
+
+ /* Draw the waves */
+
+ x1 = x0 - (x0 % dx);
+ x2 = x1 + dx;
+ odd = (x1 / dx) & 1;
+ y1 = y2 = y0;
+
+ if (odd)
+ y1 += dy;
+ else
+ y2 += dy;
+
+ if (INT_MAX - dx < xmax)
+ emacs_abort ();
+
+ while (x1 <= xmax)
+ {
+ android_draw_line (FRAME_ANDROID_DRAWABLE (s->f), s->gc,
+ x1, y1, x2, y2);
+ x1 = x2, y1 = y2;
+ x2 += dx, y2 = y0 + odd*dy;
+ odd = !odd;
+ }
+
+ /* Restore previous clipping rectangle(s) */
+ android_set_clip_rectangles (s->gc, 0, 0, s->clip, s->num_clips);
+}
+
+static void
+android_draw_glyph_string_foreground (struct glyph_string *s)
+{
+ int i, x;
+
+ /* 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->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;
+
+ /* Draw characters of S as rectangles if S's font could not be
+ loaded. */
+ if (s->font_not_found_p)
+ {
+ for (i = 0; i < s->nchars; ++i)
+ {
+ struct glyph *g = s->first_glyph + i;
+ android_draw_rectangle (FRAME_ANDROID_DRAWABLE (s->f),
+ s->gc, x, s->y,
+ g->pixel_width - 1,
+ s->height - 1);
+ x += g->pixel_width;
+ }
+ }
+ else
+ {
+ struct font *font = s->font;
+ int boff = font->baseline_offset;
+ int y;
+
+ if (font->vertical_centering)
+ boff = VCENTER_BASELINE_OFFSET (font, s->f) - boff;
+
+ y = s->ybase - boff;
+ if (s->for_overlaps
+ || (s->background_filled_p && s->hl != DRAW_CURSOR))
+ font->driver->draw (s, 0, s->nchars, x, y, false);
+ else
+ font->driver->draw (s, 0, s->nchars, x, y, true);
+ if (s->face->overstrike)
+ font->driver->draw (s, 0, s->nchars, x + 1, y, false);
+ }
+}
+
+static void
+android_draw_composite_glyph_string_foreground (struct glyph_string *s)
+{
+ int i, j, x;
+ struct font *font = s->font;
+
+ /* 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 is a glyph string for a composition. S->cmp_from is the index
+ of the first character drawn for glyphs of this composition.
+ S->cmp_from == 0 means we are drawing the very first character of
+ this composition. */
+
+ /* 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)
+ {
+ if (s->cmp_from == 0)
+ android_draw_rectangle (FRAME_ANDROID_DRAWABLE (s->f),
+ s->gc, x, s->y,
+ s->width - 1, s->height - 1);
+ }
+ else if (! s->first_glyph->u.cmp.automatic)
+ {
+ int y = s->ybase;
+
+ for (i = 0, j = s->cmp_from; i < s->nchars; i++, j++)
+ /* TAB in a composition means display glyphs with
+ padding space on the left or right. */
+ if (COMPOSITION_GLYPH (s->cmp, j) != '\t')
+ {
+ int xx = x + s->cmp->offsets[j * 2];
+ int yy = y - s->cmp->offsets[j * 2 + 1];
+
+ font->driver->draw (s, j, j + 1, xx, yy, false);
+ if (s->face->overstrike)
+ font->driver->draw (s, j, j + 1, xx + 1, yy, false);
+ }
+ }
+ else
+ {
+ Lisp_Object gstring = composition_gstring_from_id (s->cmp_id);
+ Lisp_Object glyph;
+ int y = s->ybase;
+ int width = 0;
+
+ for (i = j = s->cmp_from; i < s->cmp_to; i++)
+ {
+ glyph = LGSTRING_GLYPH (gstring, i);
+ if (NILP (LGLYPH_ADJUSTMENT (glyph)))
+ width += LGLYPH_WIDTH (glyph);
+ else
+ {
+ int xoff, yoff, wadjust;
+
+ if (j < i)
+ {
+ font->driver->draw (s, j, i, x, y, false);
+ if (s->face->overstrike)
+ font->driver->draw (s, j, i, x + 1, y, false);
+ x += width;
+ }
+ xoff = LGLYPH_XOFF (glyph);
+ yoff = LGLYPH_YOFF (glyph);
+ wadjust = LGLYPH_WADJUST (glyph);
+ font->driver->draw (s, i, i + 1, x + xoff, y + yoff, false);
+ if (s->face->overstrike)
+ font->driver->draw (s, i, i + 1, x + xoff + 1, y + yoff,
+ false);
+ x += wadjust;
+ j = i + 1;
+ width = 0;
+ }
+ }
+ if (j < i)
+ {
+ font->driver->draw (s, j, i, x, y, false);
+ if (s->face->overstrike)
+ font->driver->draw (s, j, i, x + 1, y, false);
+ }
+ }
+}
+
+static void
+android_draw_glyphless_glyph_string_foreground (struct glyph_string *s)
+{
+ struct glyph *glyph = s->first_glyph;
+ unsigned 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++)
+ {
+#ifdef GCC_LINT
+ enum { PACIFY_GCC_BUG_81401 = 1 };
+#else
+ enum { PACIFY_GCC_BUG_81401 = 0 };
+#endif
+ char buf[7 + PACIFY_GCC_BUG_81401];
+ 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 (CONSP (acronym))
+ acronym = XCAR (acronym);
+ 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)
+ android_draw_rectangle (FRAME_ANDROID_DRAWABLE (s->f), s->gc,
+ x, s->ybase - glyph->ascent,
+ glyph->pixel_width - 1,
+ glyph->ascent + glyph->descent - 1);
+ x += glyph->pixel_width;
+ }
+
+ /* Defend against hypothetical bad code elsewhere that uses
+ s->char2b after this function returns. */
+ s->char2b = NULL;
+}
+
+static void
+android_draw_glyph_string (struct glyph_string *s)
+{
+ bool relief_drawn_p = false;
+
+ /* If S draws into the background of its successors, draw the
+ background of the successors first so that S can draw into it.
+ This makes S->next use XDrawString instead of XDrawImageString. */
+ if (s->next && s->right_overhang && !s->for_overlaps)
+ {
+ int width;
+ struct glyph_string *next;
+
+ for (width = 0, next = s->next;
+ next && width < s->right_overhang;
+ width += next->width, next = next->next)
+ if (next->first_glyph->type != IMAGE_GLYPH)
+ {
+ android_set_glyph_string_gc (next);
+ android_set_glyph_string_clipping (next);
+ if (next->first_glyph->type == STRETCH_GLYPH)
+ android_draw_stretch_glyph_string (next);
+ else
+ android_draw_glyph_string_background (next, true);
+ next->num_clips = 0;
+ }
+ }
+
+ /* Set up S->gc, set clipping and draw S. */
+ android_set_glyph_string_gc (s);
+
+ /* Draw relief (if any) in advance for char/composition so that the
+ glyph string can be drawn over it. */
+ if (!s->for_overlaps
+ && s->face->box != FACE_NO_BOX
+ && (s->first_glyph->type == CHAR_GLYPH
+ || s->first_glyph->type == COMPOSITE_GLYPH))
+
+ {
+ android_set_glyph_string_clipping (s);
+ android_draw_glyph_string_background (s, true);
+ android_draw_glyph_string_box (s);
+ android_set_glyph_string_clipping (s);
+ relief_drawn_p = true;
+ }
+ else if (!s->clip_head /* draw_glyphs didn't specify a clip mask. */
+ && !s->clip_tail
+ && ((s->prev && s->prev->hl != s->hl && s->left_overhang)
+ || (s->next && s->next->hl != s->hl && s->right_overhang)))
+ /* 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. */
+ android_set_glyph_string_clipping_exactly (s, s);
+ else
+ android_set_glyph_string_clipping (s);
+
+ switch (s->first_glyph->type)
+ {
+ case IMAGE_GLYPH:
+ android_draw_image_glyph_string (s);
+ break;
+
+ case XWIDGET_GLYPH:
+ emacs_abort ();
+ break;
+
+ case STRETCH_GLYPH:
+ android_draw_stretch_glyph_string (s);
+ break;
+
+ case CHAR_GLYPH:
+ if (s->for_overlaps)
+ s->background_filled_p = true;
+ else
+ android_draw_glyph_string_background (s, false);
+ android_draw_glyph_string_foreground (s);
+ break;
+
+ case COMPOSITE_GLYPH:
+ if (s->for_overlaps || (s->cmp_from > 0
+ && ! s->first_glyph->u.cmp.automatic))
+ s->background_filled_p = true;
+ else
+ android_draw_glyph_string_background (s, true);
+ android_draw_composite_glyph_string_foreground (s);
+ break;
+
+ case GLYPHLESS_GLYPH:
+ if (s->for_overlaps)
+ s->background_filled_p = true;
+ else
+ android_draw_glyph_string_background (s, true);
+ android_draw_glyphless_glyph_string_foreground (s);
+ break;
+
+ default:
+ emacs_abort ();
+ }
+
+ if (!s->for_overlaps)
+ {
+ int area_x, area_y, area_width, area_height;
+ int area_max_x, decoration_width;
+
+ /* Prevent the underline from overwriting surrounding areas
+ and the fringe. */
+ window_box (s->w, s->area, &area_x, &area_y,
+ &area_width, &area_height);
+ area_max_x = area_x + area_width - 1;
+
+ decoration_width = s->width;
+ if (!s->row->mode_line_p
+ && !s->row->tab_line_p
+ && area_max_x < (s->x + decoration_width - 1))
+ decoration_width -= (s->x + decoration_width - 1) - area_max_x;
+
+ /* Draw relief if not yet drawn. */
+ if (!relief_drawn_p && s->face->box != FACE_NO_BOX)
+ android_draw_glyph_string_box (s);
+
+ /* Draw underline. */
+ if (s->face->underline)
+ {
+ if (s->face->underline == FACE_UNDER_WAVE)
+ {
+ if (s->face->underline_defaulted_p)
+ android_draw_underwave (s, decoration_width);
+ else
+ {
+ struct android_gc_values xgcv;
+ android_get_gc_values (s->gc, ANDROID_GC_FOREGROUND, &xgcv);
+ android_set_foreground (s->gc, s->face->underline_color);
+ android_draw_underwave (s, decoration_width);
+ android_set_foreground (s->gc, xgcv.foreground);
+ }
+ }
+ else if (s->face->underline == FACE_UNDER_LINE)
+ {
+ unsigned long thickness, position;
+ int y;
+
+ if (s->prev
+ && s->prev->face->underline == FACE_UNDER_LINE
+ && (s->prev->face->underline_at_descent_line_p
+ == s->face->underline_at_descent_line_p)
+ && (s->prev->face->underline_pixels_above_descent_line
+ == s->face->underline_pixels_above_descent_line))
+ {
+ /* We use the same underline style as the previous one. */
+ thickness = s->prev->underline_thickness;
+ position = s->prev->underline_position;
+ }
+ else
+ {
+ struct font *font = font_for_underline_metrics (s);
+ unsigned long minimum_offset;
+ bool underline_at_descent_line;
+ bool use_underline_position_properties;
+ Lisp_Object val = (WINDOW_BUFFER_LOCAL_VALUE
+ (Qunderline_minimum_offset, s->w));
+
+ if (FIXNUMP (val))
+ minimum_offset = max (0, XFIXNUM (val));
+ else
+ minimum_offset = 1;
+
+ val = (WINDOW_BUFFER_LOCAL_VALUE
+ (Qx_underline_at_descent_line, s->w));
+ underline_at_descent_line
+ = (!(NILP (val) || BASE_EQ (val, Qunbound))
+ || s->face->underline_at_descent_line_p);
+
+ val = (WINDOW_BUFFER_LOCAL_VALUE
+ (Qx_use_underline_position_properties, s->w));
+ use_underline_position_properties
+ = !(NILP (val) || BASE_EQ (val, Qunbound));
+
+ /* Get the underline thickness. Default is 1 pixel. */
+ if (font && font->underline_thickness > 0)
+ thickness = font->underline_thickness;
+ else
+ thickness = 1;
+ if (underline_at_descent_line)
+ position = ((s->height - thickness)
+ - (s->ybase - s->y)
+ - s->face->underline_pixels_above_descent_line);
+ else
+ {
+ /* Get the underline position. This is the
+ recommended vertical offset in pixels from
+ the baseline to the top of the underline.
+ This is a signed value according to the
+ specs, and its default is
+
+ ROUND ((maximum descent) / 2), with
+ ROUND(x) = floor (x + 0.5) */
+
+ if (use_underline_position_properties
+ && font && font->underline_position >= 0)
+ position = font->underline_position;
+ else if (font)
+ position = (font->descent + 1) / 2;
+ else
+ position = minimum_offset;
+ }
+
+ /* Ignore minimum_offset if the amount of pixels was
+ explicitly specified. */
+ if (!s->face->underline_pixels_above_descent_line)
+ position = max (position, minimum_offset);
+ }
+ /* Check the sanity of thickness and position. We should
+ avoid drawing underline out of the current line area. */
+ if (s->y + s->height <= s->ybase + position)
+ position = (s->height - 1) - (s->ybase - s->y);
+ if (s->y + s->height < s->ybase + position + thickness)
+ thickness = (s->y + s->height) - (s->ybase + position);
+ s->underline_thickness = thickness;
+ s->underline_position = position;
+ y = s->ybase + position;
+ if (s->face->underline_defaulted_p)
+ android_fill_rectangle (FRAME_ANDROID_DRAWABLE (s->f), s->gc,
+ s->x, y, decoration_width, thickness);
+ else
+ {
+ struct android_gc_values xgcv;
+ android_get_gc_values (s->gc, ANDROID_GC_FOREGROUND, &xgcv);
+ android_set_foreground (s->gc, s->face->underline_color);
+ android_fill_rectangle (FRAME_ANDROID_DRAWABLE (s->f), s->gc,
+ s->x, y, decoration_width, thickness);
+ android_set_foreground (s->gc, xgcv.foreground);
+ }
+ }
+ }
+ /* Draw overline. */
+ if (s->face->overline_p)
+ {
+ unsigned long dy = 0, h = 1;
+
+ if (s->face->overline_color_defaulted_p)
+ android_fill_rectangle (FRAME_ANDROID_DRAWABLE (s->f),
+ s->gc, s->x, s->y + dy,
+ decoration_width, h);
+ else
+ {
+ struct android_gc_values xgcv;
+ android_get_gc_values (s->gc, ANDROID_GC_FOREGROUND, &xgcv);
+ android_set_foreground (s->gc, s->face->overline_color);
+ android_fill_rectangle (FRAME_ANDROID_DRAWABLE (s->f), s->gc,
+ s->x, s->y + dy, decoration_width, h);
+ android_set_foreground (s->gc, xgcv.foreground);
+ }
+ }
+
+ /* Draw strike-through. */
+ if (s->face->strike_through_p)
+ {
+ /* Y-coordinate and height of the glyph string's first
+ glyph. We cannot use s->y and s->height because those
+ could be larger if there are taller display elements
+ (e.g., characters displayed with a larger font) in the
+ same glyph row. */
+ int glyph_y = s->ybase - s->first_glyph->ascent;
+ int glyph_height = s->first_glyph->ascent + s->first_glyph->descent;
+ /* Strike-through width and offset from the glyph string's
+ top edge. */
+ unsigned long h = 1;
+ unsigned long dy = (glyph_height - h) / 2;
+
+ if (s->face->strike_through_color_defaulted_p)
+ android_fill_rectangle (FRAME_ANDROID_WINDOW (s->f),
+ s->gc, s->x, glyph_y + dy,
+ s->width, h);
+ else
+ {
+ struct android_gc_values xgcv;
+ android_get_gc_values (s->gc, ANDROID_GC_FOREGROUND, &xgcv);
+ android_set_foreground (s->gc, s->face->strike_through_color);
+ android_fill_rectangle (FRAME_ANDROID_DRAWABLE (s->f), s->gc,
+ s->x, glyph_y + dy, decoration_width,
+ h);
+ android_set_foreground (s->gc, xgcv.foreground);
+ }
+ }
+
+ if (s->prev)
+ {
+ struct glyph_string *prev;
+
+ for (prev = s->prev; prev; prev = prev->prev)
+ if (prev->hl != s->hl
+ && prev->x + prev->width + prev->right_overhang > s->x)
+ {
+ /* As prev was drawn while clipped to its own area, we
+ must draw the right_overhang part using s->hl now. */
+ enum draw_glyphs_face save = prev->hl;
+
+ prev->hl = s->hl;
+ android_set_glyph_string_gc (prev);
+ android_set_glyph_string_clipping_exactly (s, prev);
+ if (prev->first_glyph->type == CHAR_GLYPH)
+ android_draw_glyph_string_foreground (prev);
+ else
+ android_draw_composite_glyph_string_foreground (prev);
+ android_reset_clip_rectangles (prev->f, prev->gc);
+ prev->hl = save;
+ prev->num_clips = 0;
+ }
+ }
+
+ if (s->next)
+ {
+ struct glyph_string *next;
+
+ for (next = s->next; next; next = next->next)
+ if (next->hl != s->hl
+ && next->x - next->left_overhang < s->x + s->width)
+ {
+ /* As next will be drawn while clipped to its own area,
+ we must draw the left_overhang part using s->hl now. */
+ enum draw_glyphs_face save = next->hl;
+
+ next->hl = s->hl;
+ android_set_glyph_string_gc (next);
+ android_set_glyph_string_clipping_exactly (s, next);
+ if (next->first_glyph->type == CHAR_GLYPH)
+ android_draw_glyph_string_foreground (next);
+ else
+ android_draw_composite_glyph_string_foreground (next);
+ android_reset_clip_rectangles (next->f, next->gc);
+ next->hl = save;
+ next->num_clips = 0;
+ next->clip_head = s->next;
+ }
+ }
+ }
+
+ /* Reset clipping. */
+ android_reset_clip_rectangles (s->f, s->gc);
+ s->num_clips = 0;
+
+ /* Set the stippled flag that tells redisplay whether or not a
+ stipple was actually draw. */
+
+ if (s->first_glyph->type != STRETCH_GLYPH
+ && s->first_glyph->type != IMAGE_GLYPH
+ && !s->row->stipple_p)
+ s->row->stipple_p = s->stippled_p;
+}
+
+static void
+android_define_frame_cursor (struct frame *f, Emacs_Cursor cursor)
+{
+ if (!f->pointer_invisible
+ && !FRAME_ANDROID_OUTPUT (f)->hourglass
+ && f->output_data.android->current_cursor != cursor)
+ android_define_cursor (FRAME_ANDROID_WINDOW (f), cursor);
+
+ f->output_data.android->current_cursor = cursor;
+}
+
+static void
+android_clear_frame_area (struct frame *f, int x, int y,
+ int width, int height)
+{
+ android_clear_area (FRAME_ANDROID_DRAWABLE (f),
+ x, y, width, height);
+}
+
+void
+android_clear_under_internal_border (struct frame *f)
+{
+ if (FRAME_INTERNAL_BORDER_WIDTH (f) > 0)
+ {
+ int border = FRAME_INTERNAL_BORDER_WIDTH (f);
+ int width = FRAME_PIXEL_WIDTH (f);
+ int height = FRAME_PIXEL_HEIGHT (f);
+ int margin = FRAME_TOP_MARGIN_HEIGHT (f);
+ int bottom_margin = FRAME_BOTTOM_MARGIN_HEIGHT (f);
+ int face_id = (FRAME_PARENT_FRAME (f)
+ ? (!NILP (Vface_remapping_alist)
+ ? lookup_basic_face (NULL, f,
+ CHILD_FRAME_BORDER_FACE_ID)
+ : CHILD_FRAME_BORDER_FACE_ID)
+ : (!NILP (Vface_remapping_alist)
+ ? lookup_basic_face (NULL, f,
+ INTERNAL_BORDER_FACE_ID)
+ : INTERNAL_BORDER_FACE_ID));
+ struct face *face = FACE_FROM_ID_OR_NULL (f, face_id);
+
+ if (face)
+ {
+ unsigned long color = face->background;
+ struct android_gc *gc = f->output_data.android->normal_gc;
+
+ android_set_foreground (gc, color);
+ android_fill_rectangle (FRAME_ANDROID_DRAWABLE (f), gc, 0, margin,
+ width, border);
+ android_fill_rectangle (FRAME_ANDROID_DRAWABLE (f), gc, 0, 0,
+ border, height);
+ android_fill_rectangle (FRAME_ANDROID_DRAWABLE (f), gc, width - border,
+ 0, border, height);
+ android_fill_rectangle (FRAME_ANDROID_DRAWABLE (f), gc, 0,
+ height - bottom_margin - border,
+ width, border);
+ android_set_foreground (gc, FRAME_FOREGROUND_PIXEL (f));
+ }
+ else
+ {
+ android_clear_area (FRAME_ANDROID_DRAWABLE (f), 0, 0,
+ border, height);
+ android_clear_area (FRAME_ANDROID_DRAWABLE (f), 0,
+ margin, width, border);
+ android_clear_area (FRAME_ANDROID_DRAWABLE (f), width - border,
+ 0, border, height);
+ android_clear_area (FRAME_ANDROID_DRAWABLE (f), 0,
+ height - bottom_margin - border,
+ width, border);
+ }
+ }
+}
+
+static void
+android_draw_hollow_cursor (struct window *w, struct glyph_row *row)
+{
+ struct frame *f = XFRAME (WINDOW_FRAME (w));
+ struct android_display_info *dpyinfo = FRAME_DISPLAY_INFO (f);
+ int x, y, wd, h;
+ struct android_gc_values xgcv;
+ struct glyph *cursor_glyph;
+ struct android_gc *gc;
+
+ /* Get the glyph the cursor is on. If we can't tell because
+ the current matrix is invalid or such, give up. */
+ cursor_glyph = get_phys_cursor_glyph (w);
+ if (cursor_glyph == NULL)
+ return;
+
+ /* Compute frame-relative coordinates for phys cursor. */
+ get_phys_cursor_geometry (w, row, cursor_glyph, &x, &y, &h);
+ wd = w->phys_cursor_width - 1;
+
+ /* The foreground of cursor_gc is typically the same as the normal
+ background color, which can cause the cursor box to be invisible. */
+ xgcv.foreground = f->output_data.android->cursor_pixel;
+ if (dpyinfo->scratch_cursor_gc)
+ android_change_gc (dpyinfo->scratch_cursor_gc,
+ ANDROID_GC_FOREGROUND, &xgcv);
+ else
+ dpyinfo->scratch_cursor_gc
+ = android_create_gc (ANDROID_GC_FOREGROUND, &xgcv);
+ gc = dpyinfo->scratch_cursor_gc;
+
+ /* When on R2L character, show cursor at the right edge of the
+ glyph, unless the cursor box is as wide as the glyph or wider
+ (the latter happens when x-stretch-cursor is non-nil). */
+ if ((cursor_glyph->resolved_level & 1) != 0
+ && cursor_glyph->pixel_width > wd)
+ {
+ x += cursor_glyph->pixel_width - wd;
+ if (wd > 0)
+ wd -= 1;
+ }
+ /* Set clipping, draw the rectangle, and reset clipping again. */
+ android_clip_to_row (w, row, TEXT_AREA, gc, NULL);
+ android_draw_rectangle (FRAME_ANDROID_DRAWABLE (f), gc, x, y, wd, h - 1);
+ android_reset_clip_rectangles (f, gc);
+}
+
+static void
+android_draw_bar_cursor (struct window *w, struct glyph_row *row, int width,
+ enum text_cursor_kinds kind)
+{
+ struct frame *f = XFRAME (w->frame);
+ struct glyph *cursor_glyph;
+ int cursor_start_y;
+
+ /* If cursor is out of bounds, don't draw garbage. This can happen
+ in mini-buffer windows when switching between echo area glyphs
+ and mini-buffer. */
+ cursor_glyph = get_phys_cursor_glyph (w);
+ if (cursor_glyph == NULL)
+ return;
+
+ /* Experimental avoidance of cursor on xwidget. */
+ if (cursor_glyph->type == XWIDGET_GLYPH)
+ return;
+
+ /* If on an image, draw like a normal cursor. That's usually better
+ visible than drawing a bar, esp. if the image is large so that
+ the bar might not be in the window. */
+ if (cursor_glyph->type == IMAGE_GLYPH)
+ {
+ struct glyph_row *r;
+ r = MATRIX_ROW (w->current_matrix, w->phys_cursor.vpos);
+ draw_phys_cursor_glyph (w, r, DRAW_CURSOR);
+ }
+ else
+ {
+ struct android_gc *gc = FRAME_DISPLAY_INFO (f)->scratch_cursor_gc;
+ unsigned long mask = ANDROID_GC_FOREGROUND | ANDROID_GC_BACKGROUND;
+ struct face *face = FACE_FROM_ID (f, cursor_glyph->face_id);
+ struct android_gc_values xgcv;
+
+ /* If the glyph's background equals the color we normally draw
+ the bars cursor in, the bar cursor in its normal color is
+ invisible. Use the glyph's foreground color instead in this
+ case, on the assumption that the glyph's colors are chosen so
+ that the glyph is legible. */
+ if (face->background == f->output_data.android->cursor_pixel)
+ xgcv.background = xgcv.foreground = face->foreground;
+ else
+ xgcv.background = xgcv.foreground = f->output_data.android->cursor_pixel;
+
+ if (gc)
+ android_change_gc (gc, mask, &xgcv);
+ else
+ {
+ gc = android_create_gc (mask, &xgcv);
+ FRAME_DISPLAY_INFO (f)->scratch_cursor_gc = gc;
+ }
+
+ android_clip_to_row (w, row, TEXT_AREA, gc, NULL);
+
+ if (kind == BAR_CURSOR)
+ {
+ int x = WINDOW_TEXT_TO_FRAME_PIXEL_X (w, w->phys_cursor.x);
+
+ if (width < 0)
+ width = FRAME_CURSOR_WIDTH (f);
+ width = min (cursor_glyph->pixel_width, width);
+
+ w->phys_cursor_width = width;
+
+ /* If the character under cursor is R2L, draw the bar cursor
+ on the right of its glyph, rather than on the left. */
+ if ((cursor_glyph->resolved_level & 1) != 0)
+ x += cursor_glyph->pixel_width - width;
+
+ android_fill_rectangle (FRAME_ANDROID_DRAWABLE (f), gc, x,
+ WINDOW_TO_FRAME_PIXEL_Y (w, w->phys_cursor.y),
+ width, row->height);
+ }
+ else /* HBAR_CURSOR */
+ {
+ int dummy_x, dummy_y, dummy_h;
+ int x = WINDOW_TEXT_TO_FRAME_PIXEL_X (w, w->phys_cursor.x);
+
+ if (width < 0)
+ width = row->height;
+
+ width = min (row->height, width);
+
+ get_phys_cursor_geometry (w, row, cursor_glyph, &dummy_x,
+ &dummy_y, &dummy_h);
+
+ cursor_start_y = WINDOW_TO_FRAME_PIXEL_Y (w, w->phys_cursor.y
+ + row->height - width);
+
+ if ((cursor_glyph->resolved_level & 1) != 0
+ && cursor_glyph->pixel_width > w->phys_cursor_width - 1)
+ x += cursor_glyph->pixel_width - w->phys_cursor_width + 1;
+ android_fill_rectangle (FRAME_ANDROID_DRAWABLE (f), gc, x,
+ cursor_start_y,
+ w->phys_cursor_width - 1, width);
+ }
+
+ android_reset_clip_rectangles (f, gc);
+ }
+}
+
+static void
+android_draw_window_cursor (struct window *w, struct glyph_row *glyph_row,
+ int x, int y, enum text_cursor_kinds cursor_type,
+ int cursor_width, bool on_p, bool active_p)
+{
+ struct frame *f;
+
+ f = WINDOW_XFRAME (w);
+
+ if (on_p)
+ {
+ w->phys_cursor_type = cursor_type;
+ w->phys_cursor_on_p = true;
+
+ if (glyph_row->exact_window_width_line_p
+ && (glyph_row->reversed_p
+ ? (w->phys_cursor.hpos < 0)
+ : (w->phys_cursor.hpos >= glyph_row->used[TEXT_AREA])))
+ {
+ glyph_row->cursor_in_fringe_p = true;
+ draw_fringe_bitmap (w, glyph_row, glyph_row->reversed_p);
+ }
+ else
+ {
+ switch (cursor_type)
+ {
+ case HOLLOW_BOX_CURSOR:
+ android_draw_hollow_cursor (w, glyph_row);
+ break;
+
+ case FILLED_BOX_CURSOR:
+ draw_phys_cursor_glyph (w, glyph_row, DRAW_CURSOR);
+ break;
+
+ case BAR_CURSOR:
+ android_draw_bar_cursor (w, glyph_row, cursor_width, BAR_CURSOR);
+ break;
+
+ case HBAR_CURSOR:
+ android_draw_bar_cursor (w, glyph_row, cursor_width, HBAR_CURSOR);
+ break;
+
+ case NO_CURSOR:
+ w->phys_cursor_width = 0;
+ break;
+
+ default:
+ emacs_abort ();
+ }
+ }
+
+ /* Now proceed to tell the input method the current position of
+ the cursor, if required. */
+
+ if (FRAME_OUTPUT_DATA (f)->need_cursor_updates
+ && w == XWINDOW (f->selected_window))
+ android_set_preeditarea (w, x, y);
+ }
+}
+
+static void
+android_draw_vertical_window_border (struct window *w, int x, int y0, int y1)
+{
+ struct frame *f = XFRAME (WINDOW_FRAME (w));
+ struct face *face;
+
+ face = FACE_FROM_ID_OR_NULL (f, VERTICAL_BORDER_FACE_ID);
+ if (face)
+ android_set_foreground (f->output_data.android->normal_gc,
+ face->foreground);
+
+ android_draw_line (FRAME_ANDROID_DRAWABLE (f),
+ f->output_data.android->normal_gc,
+ x, y0, x, y1);
+}
+
+static void
+android_draw_window_divider (struct window *w, int x0, int x1, int y0, int y1)
+{
+ struct frame *f = XFRAME (WINDOW_FRAME (w));
+ struct face *face = FACE_FROM_ID_OR_NULL (f, WINDOW_DIVIDER_FACE_ID);
+ struct face *face_first
+ = FACE_FROM_ID_OR_NULL (f, WINDOW_DIVIDER_FIRST_PIXEL_FACE_ID);
+ struct face *face_last
+ = FACE_FROM_ID_OR_NULL (f, WINDOW_DIVIDER_LAST_PIXEL_FACE_ID);
+ unsigned long color = face ? face->foreground : FRAME_FOREGROUND_PIXEL (f);
+ unsigned long color_first = (face_first
+ ? face_first->foreground
+ : FRAME_FOREGROUND_PIXEL (f));
+ unsigned long color_last = (face_last
+ ? face_last->foreground
+ : FRAME_FOREGROUND_PIXEL (f));
+
+ if ((y1 - y0 > x1 - x0) && (x1 - x0 >= 3))
+ /* A vertical divider, at least three pixels wide: Draw first and
+ last pixels differently. */
+ {
+ android_set_foreground (f->output_data.android->normal_gc,
+ color_first);
+ android_fill_rectangle (FRAME_ANDROID_DRAWABLE (f),
+ f->output_data.android->normal_gc,
+ x0, y0, 1, y1 - y0);
+ android_set_foreground (f->output_data.android->normal_gc,
+ color);
+ android_fill_rectangle (FRAME_ANDROID_DRAWABLE (f),
+ f->output_data.android->normal_gc,
+ x0 + 1, y0, x1 - x0 - 2, y1 - y0);
+ android_set_foreground (f->output_data.android->normal_gc,
+ color_last);
+ android_fill_rectangle (FRAME_ANDROID_DRAWABLE (f),
+ f->output_data.android->normal_gc,
+ x1 - 1, y0, 1, y1 - y0);
+ }
+ else if ((x1 - x0 > y1 - y0) && (y1 - y0 >= 3))
+ /* A horizontal divider, at least three pixels high: Draw first
+ and last pixels differently. */
+ {
+ android_set_foreground (f->output_data.android->normal_gc,
+ color_first);
+ android_fill_rectangle (FRAME_ANDROID_DRAWABLE (f),
+ f->output_data.android->normal_gc,
+ x0, y0, x1 - x0, 1);
+ android_set_foreground (f->output_data.android->normal_gc, color);
+ android_fill_rectangle (FRAME_ANDROID_DRAWABLE (f),
+ f->output_data.android->normal_gc,
+ x0, y0 + 1, x1 - x0, y1 - y0 - 2);
+ android_set_foreground (f->output_data.android->normal_gc,
+ color_last);
+ android_fill_rectangle (FRAME_ANDROID_DRAWABLE (f),
+ f->output_data.android->normal_gc,
+ x0, y1 - 1, x1 - x0, 1);
+ }
+ else
+ {
+ /* In any other case do not draw the first and last pixels
+ differently. */
+ android_set_foreground (f->output_data.android->normal_gc, color);
+ android_fill_rectangle (FRAME_ANDROID_DRAWABLE (f),
+ f->output_data.android->normal_gc,
+ x0, y0, x1 - x0, y1 - y0);
+ }
+}
+
+
+
+#ifdef __clang__
+#pragma clang diagnostic push
+#pragma clang diagnostic ignored "-Wmissing-prototypes"
+#else
+#pragma GCC diagnostic push
+#pragma GCC diagnostic ignored "-Wmissing-prototypes"
+#endif
+
+/* Input method related functions. Some of these are called from Java
+ within the UI thread. */
+
+/* A counter used to decide when an editing request completes. */
+static unsigned long edit_counter;
+
+/* The last counter known to have completed. */
+static unsigned long last_edit_counter;
+
+/* Semaphore posted every time the counter increases. */
+static sem_t edit_sem;
+
+/* Try to synchronize with the UI thread, waiting a certain amount of
+ time for outstanding editing requests to complete.
+
+ Every time one of the text retrieval functions is called and an
+ editing request is made, Emacs gives the main thread approximately
+ 100 ms to process it, in order to mostly keep the input method in
+ sync with the buffer contents. */
+
+static void
+android_sync_edit (void)
+{
+ struct timespec start, end, rem;
+ unsigned long counter;
+
+ counter = __atomic_load_n (&last_edit_counter,
+ __ATOMIC_SEQ_CST);
+
+ if (counter == edit_counter)
+ return;
+
+ start = current_timespec ();
+ end = timespec_add (start, make_timespec (0, 100000000));
+
+ while (true)
+ {
+ rem = timespec_sub (end, current_timespec ());
+
+ /* Timeout. */
+ if (timespec_sign (rem) < 0)
+ break;
+
+ if (__atomic_load_n (&last_edit_counter,
+ __ATOMIC_SEQ_CST)
+ == edit_counter)
+ break;
+
+ sem_timedwait (&edit_sem, &end);
+ }
+}
+
+/* Return a copy of the specified Java string and its length in
+ *LENGTH. Use the JNI environment ENV. Value is NULL if copying
+ the string fails. */
+
+static unsigned short *
+android_copy_java_string (JNIEnv *env, jstring string, size_t *length)
+{
+ jsize size, i;
+ const jchar *java;
+ unsigned short *buffer;
+
+ size = (*env)->GetStringLength (env, string);
+ buffer = malloc (size * sizeof *buffer);
+
+ if (!buffer)
+ return NULL;
+
+ java = (*env)->GetStringChars (env, string, NULL);
+
+ if (!java)
+ {
+ free (buffer);
+ return NULL;
+ }
+
+ for (i = 0; i < size; ++i)
+ buffer[i] = java[i];
+
+ *length = size;
+ (*env)->ReleaseStringChars (env, string, java);
+ return buffer;
+}
+
+JNIEXPORT void JNICALL
+NATIVE_NAME (beginBatchEdit) (JNIEnv *env, jobject object, jshort window)
+{
+ JNI_STACK_ALIGNMENT_PROLOGUE;
+
+ union android_event event;
+
+ event.ime.type = ANDROID_INPUT_METHOD;
+ event.ime.serial = ++event_serial;
+ event.ime.window = window;
+ event.ime.operation = ANDROID_IME_START_BATCH_EDIT;
+ event.ime.start = 0;
+ event.ime.end = 0;
+ event.ime.length = 0;
+ event.ime.position = 0;
+ event.ime.text = NULL;
+ event.ime.counter = ++edit_counter;
+
+ android_write_event (&event);
+}
+
+JNIEXPORT void JNICALL
+NATIVE_NAME (endBatchEdit) (JNIEnv *env, jobject object, jshort window)
+{
+ JNI_STACK_ALIGNMENT_PROLOGUE;
+
+ union android_event event;
+
+ event.ime.type = ANDROID_INPUT_METHOD;
+ event.ime.serial = ++event_serial;
+ event.ime.window = window;
+ event.ime.operation = ANDROID_IME_END_BATCH_EDIT;
+ event.ime.start = 0;
+ event.ime.end = 0;
+ event.ime.length = 0;
+ event.ime.position = 0;
+ event.ime.text = NULL;
+ event.ime.counter = ++edit_counter;
+
+ android_write_event (&event);
+}
+
+JNIEXPORT void JNICALL
+NATIVE_NAME (commitCompletion) (JNIEnv *env, jobject object, jshort window,
+ jstring completion_text, jint position)
+{
+ JNI_STACK_ALIGNMENT_PROLOGUE;
+
+ union android_event event;
+ unsigned short *text;
+ size_t length;
+
+ /* First, obtain a copy of the Java string. */
+ text = android_copy_java_string (env, completion_text, &length);
+
+ if (!text)
+ return;
+
+ /* Next, populate the event. Events will always eventually be
+ delivered on Android, so handle_one_android_event can be relied
+ on to free text. */
+
+ event.ime.type = ANDROID_INPUT_METHOD;
+ event.ime.serial = ++event_serial;
+ event.ime.window = window;
+ event.ime.operation = ANDROID_IME_COMMIT_TEXT;
+ event.ime.start = 0;
+ event.ime.end = 0;
+ event.ime.length = min (length, PTRDIFF_MAX);
+ event.ime.position = position;
+ event.ime.text = text;
+ event.ime.counter = ++edit_counter;
+
+ android_write_event (&event);
+}
+
+JNIEXPORT void JNICALL
+NATIVE_NAME (commitText) (JNIEnv *env, jobject object, jshort window,
+ jstring commit_text, jint position)
+{
+ JNI_STACK_ALIGNMENT_PROLOGUE;
+
+ union android_event event;
+ unsigned short *text;
+ size_t length;
+
+ /* First, obtain a copy of the Java string. */
+ text = android_copy_java_string (env, commit_text, &length);
+
+ if (!text)
+ return;
+
+ /* Next, populate the event. Events will always eventually be
+ delivered on Android, so handle_one_android_event can be relied
+ on to free text. */
+
+ event.ime.type = ANDROID_INPUT_METHOD;
+ event.ime.serial = ++event_serial;
+ event.ime.window = window;
+ event.ime.operation = ANDROID_IME_COMMIT_TEXT;
+ event.ime.start = 0;
+ event.ime.end = 0;
+ event.ime.length = min (length, PTRDIFF_MAX);
+ event.ime.position = position;
+ event.ime.text = text;
+ event.ime.counter = ++edit_counter;
+
+ android_write_event (&event);
+}
+
+JNIEXPORT void JNICALL
+NATIVE_NAME (deleteSurroundingText) (JNIEnv *env, jobject object,
+ jshort window, jint left_length,
+ jint right_length)
+{
+ JNI_STACK_ALIGNMENT_PROLOGUE;
+
+ union android_event event;
+
+ event.ime.type = ANDROID_INPUT_METHOD;
+ event.ime.serial = ++event_serial;
+ event.ime.window = window;
+ event.ime.operation = ANDROID_IME_DELETE_SURROUNDING_TEXT;
+ event.ime.start = left_length;
+ event.ime.end = right_length;
+ event.ime.length = 0;
+ event.ime.position = 0;
+ event.ime.text = NULL;
+ event.ime.counter = ++edit_counter;
+
+ android_write_event (&event);
+}
+
+JNIEXPORT void JNICALL
+NATIVE_NAME (finishComposingText) (JNIEnv *env, jobject object,
+ jshort window)
+{
+ JNI_STACK_ALIGNMENT_PROLOGUE;
+
+ union android_event event;
+
+ event.ime.type = ANDROID_INPUT_METHOD;
+ event.ime.serial = ++event_serial;
+ event.ime.window = window;
+ event.ime.operation = ANDROID_IME_FINISH_COMPOSING_TEXT;
+ event.ime.start = 0;
+ event.ime.end = 0;
+ event.ime.length = 0;
+ event.ime.position = 0;
+ event.ime.text = NULL;
+ event.ime.counter = ++edit_counter;
+
+ android_write_event (&event);
+}
+
+JNIEXPORT void JNICALL
+NATIVE_NAME (replaceText) (JNIEnv *env, jobject object, jshort window,
+ jint start, jint end, jobject text,
+ int new_cursor_position, jobject attribute)
+{
+ JNI_STACK_ALIGNMENT_PROLOGUE;
+
+ union android_event event;
+ size_t length;
+
+ /* First, obtain a copy of the Java string. */
+ text = android_copy_java_string (env, text, &length);
+
+ if (!text)
+ return;
+
+ /* Next, populate the event with the information in this function's
+ arguments. */
+
+ event.ime.type = ANDROID_INPUT_METHOD;
+ event.ime.serial = ++event_serial;
+ event.ime.window = window;
+ event.ime.operation = ANDROID_IME_REPLACE_TEXT;
+ event.ime.start = start + 1;
+ event.ime.end = end + 1;
+ event.ime.length = length;
+ event.ime.position = new_cursor_position;
+ event.ime.text = text;
+ event.ime.counter = ++edit_counter;
+
+ android_write_event (&event);
+}
+
+/* Structure describing the context used for a text query. */
+
+struct android_conversion_query_context
+{
+ /* The conversion request. */
+ struct textconv_callback_struct query;
+
+ /* The window the request is being made on. */
+ android_window window;
+
+ /* Whether or not the request was successful. */
+ bool success;
+};
+
+/* Obtain the text from the frame whose window is that specified in
+ DATA using the text conversion query specified there.
+
+ Set ((struct android_conversion_query_context *) DATA)->success on
+ success. */
+
+static void
+android_perform_conversion_query (void *data)
+{
+ struct android_conversion_query_context *context;
+ struct frame *f;
+
+ context = data;
+
+ /* Find the frame associated with the window. */
+ f = android_window_to_frame (NULL, context->window);
+
+ if (!f)
+ return;
+
+ textconv_query (f, &context->query, 0);
+
+ /* context->query.text will have been set even if textconv_query
+ returns 1. */
+
+ context->success = true;
+}
+
+/* Convert a string in BUFFER, containing N characters in Emacs's
+ internal multibyte encoding, to a Java string utilizing the
+ specified JNI environment ENV.
+
+ If N is equal to BYTES, then BUFFER holds unibyte or plain-ASCII
+ characters. Otherwise, BUFFER holds multibyte characters.
+
+ Make sure N and BYTES are absolutely correct, or you are asking for
+ trouble.
+
+ Value is a jstring upon success, NULL otherwise. Any exceptions
+ generated are not cleared. */
+
+static jstring
+android_text_to_string (JNIEnv *env, char *buffer, ptrdiff_t n,
+ ptrdiff_t bytes)
+{
+ jchar *utf16;
+ size_t size, index;
+ jstring string;
+ int encoded;
+
+ if (n == bytes)
+ {
+ /* This buffer holds no multibyte characters. */
+
+ if (ckd_mul (&size, n, sizeof *utf16))
+ return NULL;
+
+ utf16 = malloc (size);
+ index = 0;
+
+ if (!utf16)
+ return NULL;
+
+ while (n--)
+ {
+ utf16[index] = buffer[index];
+ index++;
+ }
+
+ string = (*env)->NewString (env, utf16, bytes);
+ free (utf16);
+
+ return string;
+ }
+
+ /* Allocate enough to hold N characters. */
+
+ if (ckd_mul (&size, n, sizeof *utf16))
+ return NULL;
+
+ utf16 = malloc (size);
+ index = 0;
+
+ if (!utf16)
+ return NULL;
+
+ while (n--)
+ {
+ eassert (CHAR_HEAD_P (*buffer));
+ encoded = STRING_CHAR ((unsigned char *) buffer);
+
+ /* Now establish how to save ENCODED into the string.
+ Emacs operates on multibyte characters, not UTF-16 characters
+ with surrogate pairs as Android does.
+
+ However, character positions in Java are represented as
+ character (rather than codepoint) indices into UTF-16
+ strings, meaning that text positions reported to Android can
+ become decoupled from their actual values if the text
+ returned incorporates characters that must be encoded as
+ surrogate pairs.
+
+ The hack used by Emacs is to simply replace each multibyte
+ character that doesn't fit in a jchar with the NULL
+ character. */
+
+ if (encoded >= 65536)
+ encoded = 0;
+
+ utf16[index++] = encoded;
+ buffer += BYTES_BY_CHAR_HEAD (*buffer);
+ }
+
+ /* Create the string. */
+ string = (*env)->NewString (env, utf16, index);
+ free (utf16);
+ return string;
+}
+
+JNIEXPORT jstring JNICALL
+NATIVE_NAME (getTextAfterCursor) (JNIEnv *env, jobject object, jshort window,
+ jint length, jint flags)
+{
+ JNI_STACK_ALIGNMENT_PROLOGUE;
+
+ struct android_conversion_query_context context;
+ jstring string;
+
+ /* First, set up the conversion query. */
+ context.query.position = EMACS_INT_MAX;
+ context.query.direction = TEXTCONV_FORWARD_CHAR;
+ context.query.factor = min (length, 65535);
+ context.query.operation = TEXTCONV_RETRIEVAL;
+
+ /* Next, set the rest of the context. */
+ context.window = window;
+ context.success = false;
+
+ /* Now try to perform the query. */
+ android_sync_edit ();
+ if (android_run_in_emacs_thread (android_perform_conversion_query,
+ &context))
+ return NULL;
+
+ if (!context.success)
+ return NULL;
+
+ /* context->query.text now contains the text in Emacs's internal
+ UTF-8 based encoding.
+
+ Convert it to Java's UTF-16 encoding, which is the same as
+ UTF-16, except that NULL bytes are encoded as surrogate pairs.
+
+ This assumes that `free' can free data allocated with xmalloc. */
+
+ string = android_text_to_string (env, context.query.text.text,
+ context.query.text.length,
+ context.query.text.bytes);
+ free (context.query.text.text);
+
+ return string;
+}
+
+JNIEXPORT jstring JNICALL
+NATIVE_NAME (getTextBeforeCursor) (JNIEnv *env, jobject object, jshort window,
+ jint length, jint flags)
+{
+ JNI_STACK_ALIGNMENT_PROLOGUE;
+
+ struct android_conversion_query_context context;
+ jstring string;
+
+ /* First, set up the conversion query. */
+ context.query.position = TYPE_MINIMUM (EMACS_INT);
+ context.query.direction = TEXTCONV_BACKWARD_CHAR;
+ context.query.factor = min (length, 65535);
+ context.query.operation = TEXTCONV_RETRIEVAL;
+
+ /* Next, set the rest of the context. */
+ context.window = window;
+ context.success = false;
+
+ /* Now try to perform the query. */
+ android_sync_edit ();
+ if (android_run_in_emacs_thread (android_perform_conversion_query,
+ &context))
+ return NULL;
+
+ if (!context.success)
+ return NULL;
+
+ /* context->query.text now contains the text in Emacs's internal
+ UTF-8 based encoding.
+
+ Convert it to Java's UTF-16 encoding, which is the same as
+ UTF-16, except that NULL bytes are encoded as surrogate pairs.
+
+ This assumes that `free' can free data allocated with xmalloc. */
+
+ string = android_text_to_string (env, context.query.text.text,
+ context.query.text.length,
+ context.query.text.bytes);
+ free (context.query.text.text);
+
+ return string;
+}
+
+JNIEXPORT void JNICALL
+NATIVE_NAME (setComposingText) (JNIEnv *env, jobject object, jshort window,
+ jstring composing_text,
+ jint new_cursor_position)
+{
+ JNI_STACK_ALIGNMENT_PROLOGUE;
+
+ union android_event event;
+ unsigned short *text;
+ size_t length;
+
+ /* First, obtain a copy of the Java string. */
+ text = android_copy_java_string (env, composing_text, &length);
+
+ if (!text)
+ return;
+
+ /* Next, populate the event. Events will always eventually be
+ delivered on Android, so handle_one_android_event can be relied
+ on to free text. */
+
+ event.ime.type = ANDROID_INPUT_METHOD;
+ event.ime.serial = ++event_serial;
+ event.ime.window = window;
+ event.ime.operation = ANDROID_IME_SET_COMPOSING_TEXT;
+ event.ime.start = 0;
+ event.ime.end = 0;
+ event.ime.length = min (length, PTRDIFF_MAX);
+ event.ime.position = new_cursor_position;
+ event.ime.text = text;
+ event.ime.counter = ++edit_counter;
+
+ android_write_event (&event);
+}
+
+JNIEXPORT void JNICALL
+NATIVE_NAME (setComposingRegion) (JNIEnv *env, jobject object, jshort window,
+ jint start, jint end)
+{
+ JNI_STACK_ALIGNMENT_PROLOGUE;
+
+ union android_event event;
+
+ event.ime.type = ANDROID_INPUT_METHOD;
+ event.ime.serial = ++event_serial;
+ event.ime.window = window;
+ event.ime.operation = ANDROID_IME_SET_COMPOSING_REGION;
+ event.ime.start = start + 1;
+ event.ime.end = end + 1;
+ event.ime.length = 0;
+ event.ime.position = 0;
+ event.ime.text = NULL;
+ event.ime.counter = ++edit_counter;
+
+ android_write_event (&event);
+}
+
+JNIEXPORT void JNICALL
+NATIVE_NAME (setSelection) (JNIEnv *env, jobject object, jshort window,
+ jint start, jint end)
+{
+ JNI_STACK_ALIGNMENT_PROLOGUE;
+
+ union android_event event;
+
+ /* While IMEs want access to the entire selection, Emacs only
+ supports setting the point. */
+
+ event.ime.type = ANDROID_INPUT_METHOD;
+ event.ime.serial = ++event_serial;
+ event.ime.window = window;
+ event.ime.operation = ANDROID_IME_SET_POINT;
+ event.ime.start = start + 1;
+ event.ime.end = end + 1;
+ event.ime.length = 0;
+ event.ime.position = start;
+ event.ime.text = NULL;
+ event.ime.counter = ++edit_counter;
+
+ android_write_event (&event);
+}
+
+/* Structure describing the context for `getSelection'. */
+
+struct android_get_selection_context
+{
+ /* The window in question. */
+ android_window window;
+
+ /* The position of the window's point when it was last
+ redisplayed, and its last mark if active. */
+ ptrdiff_t point, mark;
+};
+
+/* Function run on the main thread by `getSelection'.
+ Place the character position of point in PT. */
+
+static void
+android_get_selection (void *data)
+{
+ struct android_get_selection_context *context;
+ struct frame *f;
+ struct window *w;
+ struct buffer *b;
+
+ context = data;
+
+ /* Look up the associated frame and its selected window. */
+ f = android_window_to_frame (NULL, context->window);
+
+ if (!f)
+ context->point = -1;
+ else
+ {
+ w = XWINDOW (f->selected_window);
+
+ /* Return W's point as it is now. Then, set
+ W->ephemeral_last_point to match the current point. */
+ context->point = window_point (w);
+ w->ephemeral_last_point = context->point;
+
+ /* Default context->mark to w->last_point too. */
+ context->mark = context->point;
+
+ /* If the mark is active, then set it properly. Also, adjust
+ w->last_mark to match. */
+ b = XBUFFER (w->contents);
+ if (!NILP (BVAR (b, mark_active)))
+ {
+ context->mark = marker_position (BVAR (b, mark));
+ w->last_mark = context->mark;
+ }
+ }
+}
+
+JNIEXPORT jintArray JNICALL
+NATIVE_NAME (getSelection) (JNIEnv *env, jobject object, jshort window)
+{
+ JNI_STACK_ALIGNMENT_PROLOGUE;
+
+ struct android_get_selection_context context;
+ jintArray array;
+ jint contents[2];
+
+ context.window = window;
+
+ android_sync_edit ();
+ if (android_run_in_emacs_thread (android_get_selection,
+ &context))
+ return NULL;
+
+ if (context.point == -1)
+ return NULL;
+
+ /* Wraparound actually makes more sense than truncation; at least
+ editing will sort of work. Convert the positions to start from
+ index 0, as that is what Android expects. */
+ contents[0] = (unsigned int) min (context.point,
+ context.mark) - 1;
+ contents[1] = (unsigned int) max (context.point,
+ context.mark) - 1;
+
+ /* Now create the array. */
+ array = (*env)->NewIntArray (env, 2);
+
+ if (!array)
+ return NULL;
+
+ /* Set its contents. */
+ (*env)->SetIntArrayRegion (env, array, 0, 2, contents);
+ return array;
+}
+
+JNIEXPORT void JNICALL
+NATIVE_NAME (performEditorAction) (JNIEnv *env, jobject object,
+ jshort window, int action)
+{
+ JNI_STACK_ALIGNMENT_PROLOGUE;
+
+ union android_event event;
+
+ /* It's a good idea to call `android_sync_edit' before sending the
+ key event. Otherwise, if RET causes the current window to be
+ changed, any text previously committed might end up in the newly
+ selected window. */
+
+ android_sync_edit ();
+
+ /* Undocumented behavior: performEditorAction is apparently expected
+ to finish composing any text. */
+
+ event.ime.type = ANDROID_INPUT_METHOD;
+ event.ime.serial = ++event_serial;
+ event.ime.window = window;
+ event.ime.operation = ANDROID_IME_FINISH_COMPOSING_TEXT;
+ event.ime.start = 0;
+ event.ime.end = 0;
+
+ /* This value of `length' means that the input method should receive
+ an update containing the new conversion region. */
+
+ event.ime.length = 1;
+ event.ime.position = 0;
+ event.ime.text = NULL;
+ event.ime.counter = ++edit_counter;
+
+ android_write_event (&event);
+
+ /* Finally, send the return key press. `counter' is set; this means
+ that a text conversion barrier will be generated once the event
+ is read, which will cause subsequent edits to wait until the
+ edits associated with this key press complete. */
+
+ event.xkey.type = ANDROID_KEY_PRESS;
+ event.xkey.serial = ++event_serial;
+ event.xkey.window = window;
+ event.xkey.time = 0;
+ event.xkey.state = 0;
+ event.xkey.keycode = 66;
+ event.xkey.unicode_char = 0;
+ event.xkey.counter = ++edit_counter;
+
+ android_write_event (&event);
+}
+
+JNIEXPORT void JNICALL
+NATIVE_NAME (performContextMenuAction) (JNIEnv *env, jobject object,
+ jshort window, int action)
+{
+ JNI_STACK_ALIGNMENT_PROLOGUE;
+
+ union android_event event;
+ int key;
+
+ /* Note that ACTION is determined in EmacsInputConnection, and as
+ such they are not actual resource IDs. */
+
+ switch (action)
+ {
+ /* The subsequent three keycodes are addressed by
+ android_get_keysym_name rather than in keyboard.c. */
+
+ case 0: /* android.R.id.selectAll */
+ key = 65536 + 1;
+ break;
+
+ case 1: /* android.R.id.startSelectingText */
+ key = 65536 + 2;
+ break;
+
+ case 2: /* android.R.id.stopSelectingText */
+ key = 65536 + 3;
+ break;
+
+ default:
+ return;
+
+ case 3: /* android.R.id.cut */
+ key = 277;
+ break;
+
+ case 4: /* android.R.id.copy */
+ key = 278;
+ break;
+
+ case 5: /* android.R.id.paste */
+ key = 279;
+ break;
+ }
+
+ event.xkey.type = ANDROID_KEY_PRESS;
+ event.xkey.serial = ++event_serial;
+ event.xkey.window = window;
+ event.xkey.time = 0;
+ event.xkey.state = 0;
+ event.xkey.keycode = key;
+ event.xkey.unicode_char = 0;
+ event.xkey.counter = ++edit_counter;
+
+ android_write_event (&event);
+}
+
+
+
+/* Text extraction. */
+
+struct android_get_extracted_text_context
+{
+ /* The parameters of the request. */
+ int hint_max_chars;
+
+ /* Token for the request. */
+ int token;
+
+ /* Flags associated with the request. */
+ int flags;
+
+ /* The returned text, or NULL. */
+ char *text;
+
+ /* The size of that text in characters and bytes. */
+ ptrdiff_t length, bytes;
+
+ /* Offsets into that text. */
+ ptrdiff_t start, start_offset, end_offset;
+
+ /* The window. */
+ android_window window;
+
+ /* Whether or not the mark is active. */
+ bool mark_active;
+};
+
+/* Return the extracted text in the extracted text context specified
+ by DATA. Save its flags and token into its frame's state. */
+
+static void
+android_get_extracted_text (void *data)
+{
+ struct android_get_extracted_text_context *request;
+ struct frame *f;
+
+ request = data;
+
+ /* Find the frame associated with the window. */
+ f = android_window_to_frame (NULL, request->window);
+
+ if (!f)
+ return;
+
+ /* Now get the extracted text. */
+ request->text
+ = get_extracted_text (f, min (request->hint_max_chars, 600),
+ &request->start, &request->start_offset,
+ &request->end_offset, &request->length,
+ &request->bytes, &request->mark_active);
+
+ /* See if request->flags & GET_EXTRACTED_TEXT_MONITOR. If so, then
+ the input method has asked to monitor changes to the extracted
+ text until the next IM context reset. */
+
+ FRAME_ANDROID_OUTPUT (f)->extracted_text_flags = request->flags;
+ FRAME_ANDROID_OUTPUT (f)->extracted_text_token = request->token;
+ FRAME_ANDROID_OUTPUT (f)->extracted_text_hint = request->hint_max_chars;
+}
+
+/* Structure describing the `ExtractedTextRequest' class.
+ Valid only on the UI thread. */
+
+struct android_extracted_text_request_class
+{
+ bool initialized;
+ jfieldID hint_max_chars;
+ jfieldID token;
+};
+
+/* Structure describing the `ExtractedText' class.
+ Valid only on the UI thread. */
+
+struct android_extracted_text_class
+{
+ jclass class;
+ jmethodID constructor;
+ jfieldID flags;
+ jfieldID partial_start_offset;
+ jfieldID partial_end_offset;
+ jfieldID selection_start;
+ jfieldID selection_end;
+ jfieldID start_offset;
+ jfieldID text;
+};
+
+/* Fields and methods associated with the `ExtractedTextRequest'
+ class. */
+struct android_extracted_text_request_class request_class;
+
+/* Fields and methods associated with the `ExtractedText' class. */
+struct android_extracted_text_class text_class;
+
+/* Return an ExtractedText object corresponding to the extracted text
+ TEXT. START is a character position describing the offset of the
+ first character in TEXT. START_OFFSET is the offset of the lesser
+ of point or mark relative to START, and END_OFFSET is that of the
+ greater of point or mark relative to START. MARK_ACTIVE specifies
+ whether or not the mark is currently active.
+
+ Assume that request_class and text_class have already been
+ initialized.
+
+ Value is NULL if an error occurs; the exception is not cleared,
+ else a local reference to the ExtractedText object. */
+
+static jobject
+android_build_extracted_text (jstring text, ptrdiff_t start,
+ ptrdiff_t start_offset,
+ ptrdiff_t end_offset, bool mark_active)
+{
+ JNIEnv *env;
+ jobject object;
+
+ env = android_java_env;
+
+ /* Return NULL if the class has not yet been obtained. */
+ if (!text_class.class)
+ return NULL;
+
+ /* Create an ExtractedText object containing this information. */
+ object = (*env)->NewObject (env, text_class.class,
+ text_class.constructor);
+ if (!object)
+ return NULL;
+
+ (*env)->SetIntField (env, object, text_class.flags,
+ /* ExtractedText.FLAG_SELECTING */
+ mark_active ? 2 : 0);
+ (*env)->SetIntField (env, object, text_class.partial_start_offset, -1);
+ (*env)->SetIntField (env, object, text_class.partial_end_offset, -1);
+ (*env)->SetIntField (env, object, text_class.selection_start,
+ min (start_offset, TYPE_MAXIMUM (jint)));
+ (*env)->SetIntField (env, object, text_class.selection_end,
+ min (end_offset, TYPE_MAXIMUM (jint)));
+
+ /* Subtract 1 from start: point indices in Emacs start from 1, but
+ Android expects 0. */
+ (*env)->SetIntField (env, object, text_class.start_offset,
+ min (start - 1, TYPE_MAXIMUM (jint)));
+ (*env)->SetObjectField (env, object, text_class.text, text);
+ return object;
+}
+
+JNIEXPORT jobject JNICALL
+NATIVE_NAME (getExtractedText) (JNIEnv *env, jobject ignored_object,
+ jshort window, jobject request,
+ jint flags)
+{
+ JNI_STACK_ALIGNMENT_PROLOGUE;
+
+ struct android_get_extracted_text_context context;
+ jstring string;
+ jclass class;
+ jobject object;
+
+ /* Initialize both classes if necessary. */
+
+ if (!request_class.initialized)
+ {
+ class
+ = (*env)->FindClass (env, ("android/view/inputmethod"
+ "/ExtractedTextRequest"));
+ eassert (class);
+
+ request_class.hint_max_chars
+ = (*env)->GetFieldID (env, class, "hintMaxChars", "I");
+ eassert (request_class.hint_max_chars);
+
+ request_class.token
+ = (*env)->GetFieldID (env, class, "token", "I");
+ eassert (request_class.token);
+
+ request_class.initialized = true;
+ }
+
+ if (!text_class.class)
+ {
+ text_class.class
+ = (*env)->FindClass (env, ("android/view/inputmethod"
+ "/ExtractedText"));
+ eassert (text_class.class);
+
+ class
+ = text_class.class
+ = (*env)->NewGlobalRef (env, text_class.class);
+ eassert (text_class.class);
+
+ text_class.flags
+ = (*env)->GetFieldID (env, class, "flags", "I");
+ text_class.partial_start_offset
+ = (*env)->GetFieldID (env, class, "partialStartOffset", "I");
+ text_class.partial_end_offset
+ = (*env)->GetFieldID (env, class, "partialEndOffset", "I");
+ text_class.selection_start
+ = (*env)->GetFieldID (env, class, "selectionStart", "I");
+ text_class.selection_end
+ = (*env)->GetFieldID (env, class, "selectionEnd", "I");
+ text_class.start_offset
+ = (*env)->GetFieldID (env, class, "startOffset", "I");
+ text_class.text
+ = (*env)->GetFieldID (env, class, "text", "Ljava/lang/CharSequence;");
+ text_class.constructor
+ = (*env)->GetMethodID (env, class, "<init>", "()V");
+ }
+
+ context.hint_max_chars
+ = (*env)->GetIntField (env, request, request_class.hint_max_chars);
+ context.token
+ = (*env)->GetIntField (env, request, request_class.token);
+ context.flags = flags;
+ context.text = NULL;
+ context.window = window;
+
+ android_sync_edit ();
+ if (android_run_in_emacs_thread (android_get_extracted_text,
+ &context))
+ return NULL;
+
+ if (!context.text)
+ return NULL;
+
+ /* Encode the returned text. */
+ string = android_text_to_string (env, context.text, context.length,
+ context.bytes);
+ free (context.text);
+
+ if (!string)
+ return NULL;
+
+ /* Create an ExtractedText object containing this information. */
+ object = (*env)->NewObject (env, text_class.class,
+ text_class.constructor);
+ if (!object)
+ return NULL;
+
+ (*env)->SetIntField (env, object, text_class.flags,
+ /* ExtractedText.FLAG_SELECTING */
+ context.mark_active ? 2 : 0);
+ (*env)->SetIntField (env, object, text_class.partial_start_offset, -1);
+ (*env)->SetIntField (env, object, text_class.partial_end_offset, -1);
+ (*env)->SetIntField (env, object, text_class.selection_start,
+ min (context.start_offset, TYPE_MAXIMUM (jint)));
+ (*env)->SetIntField (env, object, text_class.selection_end,
+ min (context.end_offset, TYPE_MAXIMUM (jint)));
+
+ /* Subtract 1 from start: point indices in Emacs start from 1, but
+ Android expects 0. */
+ (*env)->SetIntField (env, object, text_class.start_offset,
+ min (context.start - 1, TYPE_MAXIMUM (jint)));
+ (*env)->SetObjectField (env, object, text_class.text, string);
+ return object;
+}
+
+
+
+JNIEXPORT jstring JNICALL
+NATIVE_NAME (getSelectedText) (JNIEnv *env, jobject object,
+ jshort window)
+{
+ JNI_STACK_ALIGNMENT_PROLOGUE;
+
+ struct android_get_extracted_text_context context;
+ jstring string;
+
+ context.hint_max_chars = -1;
+ context.token = 0;
+ context.text = NULL;
+ context.window = window;
+
+ android_sync_edit ();
+ if (android_run_in_emacs_thread (android_get_extracted_text,
+ &context))
+ return NULL;
+
+ if (!context.text)
+ return NULL;
+
+ /* Encode the returned text. */
+ string = android_text_to_string (env, context.text, context.length,
+ context.bytes);
+ free (context.text);
+
+ return string;
+}
+
+JNIEXPORT void JNICALL
+NATIVE_NAME (requestSelectionUpdate) (JNIEnv *env, jobject object,
+ jshort window)
+{
+ JNI_STACK_ALIGNMENT_PROLOGUE;
+
+ union android_event event;
+
+ event.ime.type = ANDROID_INPUT_METHOD;
+ event.ime.serial = ++event_serial;
+ event.ime.window = window;
+ event.ime.operation = ANDROID_IME_REQUEST_SELECTION_UPDATE;
+ event.ime.start = 0;
+ event.ime.end = 0;
+ event.ime.length = 0;
+ event.ime.position = 0;
+ event.ime.text = NULL;
+ event.ime.counter = ++edit_counter;
+
+ android_write_event (&event);
+}
+
+JNIEXPORT void JNICALL
+NATIVE_NAME (requestCursorUpdates) (JNIEnv *env, jobject object,
+ jshort window, jint mode)
+{
+ JNI_STACK_ALIGNMENT_PROLOGUE;
+
+ union android_event event;
+
+ event.ime.type = ANDROID_INPUT_METHOD;
+ event.ime.serial = ++event_serial;
+ event.ime.window = window;
+ event.ime.operation = ANDROID_IME_REQUEST_CURSOR_UPDATES;
+ event.ime.start = 0;
+ event.ime.end = 0;
+ event.ime.length = mode;
+ event.ime.position = 0;
+ event.ime.text = NULL;
+
+ /* Since this does not affect the state of the buffer text, there is
+ no need to apply synchronization to this event. */
+ event.ime.counter = 0;
+
+ android_write_event (&event);
+}
+
+/* Notice that a new input method connection has been initialized and
+ clear cursor update requests, extracted text requests, and the
+ composing region. */
+
+JNIEXPORT void JNICALL
+NATIVE_NAME (clearInputFlags) (JNIEnv *env, jobject object,
+ jshort window)
+{
+ JNI_STACK_ALIGNMENT_PROLOGUE;
+
+ union android_event event;
+
+ event.ime.type = ANDROID_INPUT_METHOD;
+ event.ime.serial = ++event_serial;
+ event.ime.window = window;
+ event.ime.operation = ANDROID_IME_FINISH_COMPOSING_TEXT;
+ event.ime.start = 0;
+ event.ime.end = 0;
+
+ /* This value of `length' means that updates to the cursor position
+ and extracted text should not be reported anymore. */
+
+ event.ime.length = 2;
+ event.ime.position = 0;
+ event.ime.text = NULL;
+ event.ime.counter = ++edit_counter;
+
+ android_write_event (&event);
+}
+
+
+
+/* Context for a call to `getSurroundingText'. */
+
+struct android_get_surrounding_text_context
+{
+ /* Number of characters before the region to return. */
+ int before_length;
+
+ /* Number of characters after the region to return. */
+ int after_length;
+
+ /* The returned text, or NULL. */
+ char *text;
+
+ /* The size of that text in characters and bytes. */
+ ptrdiff_t length, bytes;
+
+ /* Offsets into that text. */
+ ptrdiff_t offset, start, end;
+
+ /* The start and end indices of the conversion region.
+ -1 if it does not exist. */
+ ptrdiff_t conversion_start, conversion_end;
+
+ /* The window. */
+ android_window window;
+};
+
+/* Return the surrounding text in the surrounding text context
+ specified by DATA. */
+
+static void
+android_get_surrounding_text (void *data)
+{
+ struct android_get_surrounding_text_context *request;
+ struct frame *f;
+ ptrdiff_t temp;
+
+ request = data;
+
+ /* Find the frame associated with the window. */
+ f = android_window_to_frame (NULL, request->window);
+
+ if (!f)
+ return;
+
+ /* Now get the surrounding text. */
+ request->text
+ = get_surrounding_text (f, request->before_length,
+ request->after_length, &request->length,
+ &request->bytes, &request->offset,
+ &request->start, &request->end);
+
+ /* Sort request->start and request->end for compatibility with some
+ bad input methods. */
+
+ if (request->end < request->start)
+ {
+ temp = request->start;
+ request->start = request->end;
+ request->end = temp;
+ }
+
+ /* Retrieve the conversion region. */
+
+ request->conversion_start = -1;
+ request->conversion_end = -1;
+
+ if (MARKERP (f->conversion.compose_region_start))
+ {
+ request->conversion_start
+ = marker_position (f->conversion.compose_region_start) - 1;
+ request->conversion_end
+ = marker_position (f->conversion.compose_region_end) - 1;
+ }
+}
+
+/* Return a local reference to a `SurroundingText' object describing
+ WINDOW's surrounding text. ENV should be a valid JNI environment
+ for the current thread.
+
+ BEFORE_LENGTH and AFTER_LENGTH specify the number of characters
+ around point and mark to return.
+
+ Return the conversion region (or -1) in *CONVERSION_START and
+ *CONVERSION_END if non-NULL.
+
+ Value is the object upon success, else NULL. */
+
+static jobject
+android_get_surrounding_text_internal (JNIEnv *env, jshort window,
+ jint before_length,
+ jint after_length,
+ ptrdiff_t *conversion_start,
+ ptrdiff_t *conversion_end)
+{
+ struct android_get_surrounding_text_context context;
+ jstring string;
+ jobject object;
+
+ static jclass class;
+ static jmethodID constructor;
+
+ /* Initialize CLASS if it has not yet been initialized. */
+
+ if (!class)
+ {
+ class
+ = (*env)->FindClass (env, ("android/view/inputmethod"
+ "/SurroundingText"));
+
+#if __ANDROID_API__ < 31
+ /* If CLASS cannot be found, the version of Android currently
+ running is too old. */
+
+ if (!class)
+ {
+ (*env)->ExceptionClear (env);
+ return NULL;
+ }
+#else /* __ANDROID_API__ >= 31 */
+ eassert (class);
+#endif /* __ANDROID_API__ < 31 */
+
+ class = (*env)->NewGlobalRef (env, class);
+ if (!class)
+ /* Clear class to prevent a local reference from remaining in
+ `class'. */
+ return (class = NULL);
+
+ /* Now look for its constructor. */
+ constructor = (*env)->GetMethodID (env, class, "<init>",
+ "(Ljava/lang/CharSequence;III)V");
+ eassert (constructor);
+ }
+
+ context.before_length = before_length;
+ context.after_length = after_length;
+ context.window = window;
+ context.text = NULL;
+
+ android_sync_edit ();
+ if (android_run_in_emacs_thread (android_get_surrounding_text,
+ &context))
+ return NULL;
+
+ if (!context.text)
+ return NULL;
+
+ /* Encode the returned text. */
+ string = android_text_to_string (env, context.text, context.length,
+ context.bytes);
+ free (context.text);
+
+ if (!string)
+ return NULL;
+
+ /* Create an SurroundingText object containing this information. */
+ object = (*env)->NewObject (env, class, constructor, string,
+ (jint) min (context.start,
+ TYPE_MAXIMUM (jint)),
+ (jint) min (context.end,
+ TYPE_MAXIMUM (jint)),
+ /* Adjust point offsets to fit into
+ Android's 0-based indexing. */
+ (jint) min (context.offset - 1,
+ TYPE_MAXIMUM (jint)));
+ if (!object)
+ return NULL;
+
+ /* Now return the conversion region if that was requested. */
+
+ if (conversion_start)
+ {
+ *conversion_start = context.conversion_start;
+ *conversion_end = context.conversion_start;
+ }
+
+ return object;
+}
+
+JNIEXPORT jobject JNICALL
+NATIVE_NAME (getSurroundingText) (JNIEnv *env, jobject object,
+ jshort window, jint before_length,
+ jint after_length, jint flags)
+{
+ JNI_STACK_ALIGNMENT_PROLOGUE;
+
+ return android_get_surrounding_text_internal (env, window, before_length,
+ after_length, NULL, NULL);
+}
+
+JNIEXPORT jobject JNICALL
+NATIVE_NAME (takeSnapshot) (JNIEnv *env, jobject object, jshort window)
+{
+ JNI_STACK_ALIGNMENT_PROLOGUE;
+
+ jobject text;
+ ptrdiff_t start, end;
+
+ static jclass class;
+ static jmethodID constructor;
+
+ /* First, obtain the surrounding text and conversion region. */
+ text = android_get_surrounding_text_internal (env, window, 600, 600,
+ &start, &end);
+
+ /* If that fails, return NULL. */
+
+ if (!text)
+ return NULL;
+
+ /* Next, initialize the TextSnapshot class. */
+
+ if (!class)
+ {
+ class
+ = (*env)->FindClass (env, ("android/view/inputmethod"
+ "/TextSnapshot"));
+#if __ANDROID_API__ < 33
+ /* If CLASS cannot be found, the version of Android currently
+ running is too old. */
+
+ if (!class)
+ {
+ (*env)->ExceptionClear (env);
+ return NULL;
+ }
+#else /* __ANDROID_API__ >= 33 */
+ eassert (class);
+#endif /* __ANDROID_API__ < 33 */
+
+ class = (*env)->NewGlobalRef (env, class);
+ if (!class)
+ /* Clear class to prevent a local reference from remaining in
+ `class'. */
+ return (class = NULL);
+
+ constructor = (*env)->GetMethodID (env, class, "<init>",
+ "(Landroid/view/inputmethod"
+ "/SurroundingText;III)V");
+ eassert (constructor);
+ }
+
+ /* Try to create a TextSnapshot object. */
+ eassert (start <= end);
+ object = (*env)->NewObject (env, class, constructor, text,
+ (jint) min (start, TYPE_MAXIMUM (jint)),
+ (jint) min (end, TYPE_MAXIMUM (jint)),
+ (jint) 0);
+ return object;
+}
+
+#ifdef __clang__
+#pragma clang diagnostic pop
+#else /* GCC */
+#pragma GCC diagnostic pop
+#endif /* __clang__ */
+
+
+
+/* Tell the input method where the composing region and selection of
+ F's selected window is located. W should be F's selected window;
+ if it is NULL, then F->selected_window is used in its place. */
+
+static void
+android_update_selection (struct frame *f, struct window *w)
+{
+ ptrdiff_t start, end, point, mark, start_offset, end_offset;
+ ptrdiff_t length, bytes;
+ struct buffer *b;
+ int hint, token;
+ char *text;
+ jobject extracted;
+ jstring string;
+ bool mark_active;
+
+ if (MARKERP (f->conversion.compose_region_start))
+ {
+ eassert (MARKERP (f->conversion.compose_region_end));
+
+ /* Indexing in android starts from 0 instead of 1. */
+ start = marker_position (f->conversion.compose_region_start) - 1;
+ end = marker_position (f->conversion.compose_region_end) - 1;
+ }
+ else
+ start = -1, end = -1;
+
+ /* Now constrain START and END to the maximum size of a Java
+ integer. */
+ start = min (start, TYPE_MAXIMUM (jint));
+ end = min (end, TYPE_MAXIMUM (jint));
+
+ if (!w)
+ w = XWINDOW (f->selected_window);
+
+ /* Figure out where the point and mark are. If the mark is not
+ active, then point is set to equal mark. */
+ b = XBUFFER (w->contents);
+ point = min (w->ephemeral_last_point,
+ TYPE_MAXIMUM (jint));
+ mark = ((!NILP (BVAR (b, mark_active))
+ && w->last_mark != -1)
+ ? min (w->last_mark, TYPE_MAXIMUM (jint))
+ : point);
+
+ /* Send the update. Android doesn't employ a concept of ``point''
+ and ``mark''; instead, it only has a selection, where the start
+ of the selection is less than or equal to the end, and the region
+ is ``active'' when those two values differ. Also, convert the
+ indices from 1-based Emacs indices to 0-based Android ones. */
+ android_update_ic (FRAME_ANDROID_WINDOW (f), min (point, mark) - 1,
+ max (point, mark) - 1, start, end);
+
+ /* Update the extracted text as well, if the input method has asked
+ for updates. 1 is
+ InputConnection.GET_EXTRACTED_TEXT_MONITOR. */
+
+ if (FRAME_ANDROID_OUTPUT (f)->extracted_text_flags & 1)
+ {
+ hint = FRAME_ANDROID_OUTPUT (f)->extracted_text_hint;
+ token = FRAME_ANDROID_OUTPUT (f)->extracted_text_token;
+ text = get_extracted_text (f, min (hint, 600), &start,
+ &start_offset, &end_offset,
+ &length, &bytes, &mark_active);
+
+ if (text)
+ {
+ /* Make a string out of the extracted text. */
+ string = android_text_to_string (android_java_env,
+ text, length, bytes);
+ xfree (text);
+ android_exception_check ();
+
+ /* Make extracted text out of that string. */
+ extracted = android_build_extracted_text (string, start,
+ start_offset,
+ end_offset,
+ mark_active);
+ android_exception_check_1 (string);
+ ANDROID_DELETE_LOCAL_REF (string);
+
+ if (extracted)
+ {
+ /* extracted is now an associated ExtractedText object.
+ Perform the update. */
+ android_update_extracted_text (FRAME_ANDROID_WINDOW (f),
+ extracted, token);
+ ANDROID_DELETE_LOCAL_REF (extracted);
+ }
+ }
+ }
+}
+
+/* Return whether or not EVENT is an input method event destined for
+ the frame (struct frame *) ARG. */
+
+static bool
+android_event_is_for_frame (union android_event *event, void *arg)
+{
+ struct frame *f;
+
+ f = arg;
+ return (event->type == ANDROID_INPUT_METHOD
+ && event->ime.window == FRAME_ANDROID_WINDOW (f));
+}
+
+/* Notice that the input method connection to F should be reset as a
+ result of a change to its contents. */
+
+static void
+android_reset_conversion (struct frame *f)
+{
+ enum android_ic_mode mode;
+ struct window *w;
+ struct buffer *buffer;
+ Lisp_Object style;
+ union android_event event;
+
+ /* Reset the input method.
+
+ Select an appropriate ``input mode'' based on whether or not the
+ minibuffer window is selected, which in turn affects if ``RET''
+ inserts a newline or sends an editor action Emacs transforms into
+ a key event (refer to `performEditorAction'.) */
+
+ w = XWINDOW (f->selected_window);
+ buffer = XBUFFER (WINDOW_BUFFER (w));
+
+ style = (EQ (find_symbol_value (Qoverriding_text_conversion_style),
+ Qlambda)
+ ? BVAR (buffer, text_conversion_style)
+ : find_symbol_value (Qoverriding_text_conversion_style));
+
+ if (NILP (style) || conversion_disabled_p ())
+ mode = ANDROID_IC_MODE_NULL;
+ else if (EQ (style, Qpassword))
+ mode = ANDROID_IC_MODE_PASSWORD;
+ else if (EQ (style, Qaction) || EQ (f->selected_window,
+ f->minibuffer_window))
+ mode = ANDROID_IC_MODE_ACTION;
+ else
+ mode = ANDROID_IC_MODE_TEXT;
+
+ /* Remove any existing input method events that apply to FRAME from
+ the event queue.
+
+ There's a small window between this and the call to
+ android_reset_ic between which more events can be generated. */
+
+ while (android_check_if_event (&event, android_event_is_for_frame, f))
+ {
+ switch (event.ime.operation)
+ {
+ case ANDROID_IME_COMMIT_TEXT:
+ case ANDROID_IME_FINISH_COMPOSING_TEXT:
+ case ANDROID_IME_SET_COMPOSING_TEXT:
+ xfree (event.ime.text);
+ break;
+
+ default:
+ break;
+ }
+ }
+
+ android_reset_ic (FRAME_ANDROID_WINDOW (f), mode);
+
+ /* Clear extracted text flags. Since the IM has been reinitialized,
+ it should no longer be displaying extracted text. */
+ FRAME_ANDROID_OUTPUT (f)->extracted_text_flags = 0;
+
+ /* Move its selection to the specified position. */
+ android_update_selection (f, NULL);
+}
+
+/* Notice that point has moved in the F's selected window's selected
+ buffer. W is the window, and BUFFER is that buffer. */
+
+static void
+android_set_point (struct frame *f, struct window *w,
+ struct buffer *buffer)
+{
+ android_update_selection (f, w);
+}
+
+/* Notice that the composition region on F's old selected window has
+ changed. */
+
+static void
+android_compose_region_changed (struct frame *f)
+{
+ android_update_selection (f, XWINDOW (f->old_selected_window));
+}
+
+/* Notice that the text conversion has completed. */
+
+static void
+android_notify_conversion (unsigned long counter)
+{
+ int sval;
+
+ if (last_edit_counter < counter)
+ __atomic_store_n (&last_edit_counter, counter,
+ __ATOMIC_SEQ_CST);
+
+ sem_getvalue (&edit_sem, &sval);
+
+ if (sval <= 0)
+ sem_post (&edit_sem);
+}
+
+/* Android text conversion interface. */
+
+static struct textconv_interface text_conversion_interface =
+ {
+ android_reset_conversion,
+ android_set_point,
+ android_compose_region_changed,
+ android_notify_conversion,
+ };
+
+
+
+extern frame_parm_handler android_frame_parm_handlers[];
+
+#endif /* !ANDROID_STUBIFY */
+
+static struct redisplay_interface android_redisplay_interface =
+ {
+#ifndef ANDROID_STUBIFY
+ android_frame_parm_handlers,
+ gui_produce_glyphs,
+ gui_write_glyphs,
+ gui_insert_glyphs,
+ gui_clear_end_of_line,
+ android_scroll_run,
+ android_after_update_window_line,
+ NULL, /* update_window_begin */
+ NULL, /* update_window_end */
+ android_flip_and_flush,
+ gui_clear_window_mouse_face,
+ gui_get_glyph_overhangs,
+ gui_fix_overlapping_area,
+ android_draw_fringe_bitmap,
+ NULL, /* define_fringe_bitmap */
+ NULL, /* destroy_fringe_bitmap */
+ android_compute_glyph_string_overhangs,
+ android_draw_glyph_string,
+ android_define_frame_cursor,
+ android_clear_frame_area,
+ android_clear_under_internal_border,
+ android_draw_window_cursor,
+ android_draw_vertical_window_border,
+ android_draw_window_divider,
+ NULL,
+ android_show_hourglass,
+ android_hide_hourglass,
+ android_default_font_parameter,
+#endif
+ };
+
+
+
+void
+frame_set_mouse_pixel_position (struct frame *f, int pix_x, int pix_y)
+{
+ /* This cannot be implemented on Android, and as such is left
+ blank. */
+}
+
+char *
+get_keysym_name (int keysym)
+{
+ static char buffer[64];
+
+#ifndef ANDROID_STUBIFY
+ android_get_keysym_name (keysym, buffer, 64);
+#else
+ emacs_abort ();
+#endif
+ return buffer;
+}
+
+
+
+/* Create a struct terminal, initialize it with the Android specific
+ functions and make DISPLAY->TERMINAL point to it. */
+
+static struct terminal *
+android_create_terminal (struct android_display_info *dpyinfo)
+{
+ struct terminal *terminal;
+
+ terminal = create_terminal (output_android,
+ &android_redisplay_interface);
+ terminal->display_info.android = dpyinfo;
+ dpyinfo->terminal = terminal;
+
+ /* kboard is initialized in android_term_init. */
+
+#ifndef ANDROID_STUBIFY
+
+ terminal->clear_frame_hook = android_clear_frame;
+ terminal->ring_bell_hook = android_ring_bell;
+ terminal->toggle_invisible_pointer_hook
+ = android_toggle_invisible_pointer;
+ terminal->update_begin_hook = android_update_begin;
+ terminal->update_end_hook = android_update_end;
+ terminal->read_socket_hook = android_read_socket;
+ terminal->frame_up_to_date_hook = android_frame_up_to_date;
+ terminal->buffer_flipping_unblocked_hook
+ = android_buffer_flipping_unblocked_hook;
+ terminal->defined_color_hook = android_defined_color;
+ terminal->query_frame_background_color
+ = android_query_frame_background_color;
+ terminal->query_colors = android_query_colors;
+ terminal->mouse_position_hook = android_mouse_position;
+ terminal->get_focus_frame = android_get_focus_frame;
+ terminal->focus_frame_hook = android_focus_frame;
+ terminal->frame_rehighlight_hook = android_frame_rehighlight_hook;
+ terminal->frame_raise_lower_hook = android_frame_raise_lower;
+ terminal->frame_visible_invisible_hook
+ = android_make_frame_visible_invisible;
+ terminal->fullscreen_hook = android_fullscreen_hook;
+ terminal->iconify_frame_hook = android_iconify_frame;
+ terminal->set_window_size_hook = android_set_window_size;
+ terminal->set_frame_offset_hook = android_set_offset;
+ terminal->set_frame_alpha_hook = android_set_alpha;
+ terminal->set_new_font_hook = android_new_font;
+ terminal->set_bitmap_icon_hook = android_bitmap_icon;
+ terminal->implicit_set_name_hook = android_implicitly_set_name;
+ terminal->menu_show_hook = android_menu_show;
+ terminal->popup_dialog_hook = android_popup_dialog;
+ terminal->change_tab_bar_height_hook = android_change_tab_bar_height;
+ terminal->change_tool_bar_height_hook = android_change_tool_bar_height;
+ terminal->set_scroll_bar_default_width_hook
+ = android_set_scroll_bar_default_width;
+ terminal->set_scroll_bar_default_height_hook
+ = android_set_scroll_bar_default_height;
+ terminal->free_pixmap = android_free_pixmap_hook;
+ terminal->delete_frame_hook = android_delete_frame;
+ terminal->delete_terminal_hook = android_delete_terminal;
+
+#else
+ emacs_abort ();
+#endif
+
+ return terminal;
+}
+
+/* Initialize the Android terminal interface. The display connection
+ has already been set up by the system at this point. */
+
+void
+android_term_init (void)
+{
+ struct terminal *terminal;
+ struct android_display_info *dpyinfo;
+ Lisp_Object color_file, color_map;
+
+ dpyinfo = xzalloc (sizeof *dpyinfo);
+ terminal = android_create_terminal (dpyinfo);
+ terminal->kboard = allocate_kboard (Qandroid);
+ terminal->kboard->reference_count++;
+
+ dpyinfo->n_planes = 24;
+
+ /* This function should only be called once at startup. */
+ eassert (!x_display_list);
+ x_display_list = dpyinfo;
+
+ dpyinfo->name_list_element
+ = Fcons (build_pure_c_string ("android"), Qnil);
+
+ color_file = Fexpand_file_name (build_string ("rgb.txt"),
+ Vdata_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;
+
+#ifndef ANDROID_STUBIFY
+ dpyinfo->resx = android_pixel_density_x;
+ dpyinfo->resy = android_pixel_density_y;
+ dpyinfo->font_resolution = android_scaled_pixel_density;
+#endif /* ANDROID_STUBIFY */
+
+ /* https://lists.gnu.org/r/emacs-devel/2015-11/msg00194.html */
+ dpyinfo->smallest_font_height = 1;
+ dpyinfo->smallest_char_width = 1;
+
+ terminal->name = xstrdup ("android");
+
+ /* The display "connection" is now set up, and it must never go
+ away. */
+ terminal->reference_count = 30000;
+
+ /* Set the baud rate to the same value it gets set to on X. */
+ baud_rate = 19200;
+
+#ifndef ANDROID_STUBIFY
+ sem_init (&edit_sem, false, 0);
+ register_textconv_interface (&text_conversion_interface);
+#endif
+}
+
+
+
+/* Set Vandroid_build_fingerprint to a reasonable value, and also
+ Vandroid_build_manufacturer. */
+
+static void
+android_set_build_fingerprint (void)
+{
+#ifdef ANDROID_STUBIFY
+ Vandroid_build_fingerprint = Qnil;
+#else /* !ANDROID_STUBIFY */
+ jclass class;
+ jfieldID field;
+ jobject string;
+ const char *data;
+
+ /* Set class to NULL so freeing an uninitialized local ref can be
+ avoided. */
+ class = NULL;
+
+ /* Likewise for string. */
+ string = NULL;
+
+ if (!android_init_gui)
+ goto fail;
+ else
+ {
+ /* Obtain Build.FINGERPRINT. Clear exceptions after each query;
+ JNI can't find Build.FINGERPRINT on some systems. */
+
+ class = (*android_java_env)->FindClass (android_java_env,
+ "android/os/Build");
+ (*android_java_env)->ExceptionClear (android_java_env);
+
+ if (!class)
+ goto fail;
+
+ field = (*android_java_env)->GetStaticFieldID (android_java_env,
+ class,
+ "FINGERPRINT",
+ "Ljava/lang/String;");
+ (*android_java_env)->ExceptionClear (android_java_env);
+
+ if (!field)
+ goto fail;
+
+ string
+ = (*android_java_env)->GetStaticObjectField (android_java_env,
+ class, field);
+ (*android_java_env)->ExceptionClear (android_java_env);
+
+ if (!string)
+ goto fail;
+
+ data = (*android_java_env)->GetStringUTFChars (android_java_env,
+ string, NULL);
+ (*android_java_env)->ExceptionClear (android_java_env);
+
+ if (!data)
+ goto fail;
+
+ Vandroid_build_fingerprint = build_string_from_utf8 (data);
+ (*android_java_env)->ReleaseStringUTFChars (android_java_env,
+ string, data);
+
+ /* Now retrieve Build.MANUFACTURER. */
+
+ ANDROID_DELETE_LOCAL_REF (string);
+ string = NULL;
+
+ field = (*android_java_env)->GetStaticFieldID (android_java_env,
+ class,
+ "MANUFACTURER",
+ "Ljava/lang/String;");
+ (*android_java_env)->ExceptionClear (android_java_env);
+
+ if (!field)
+ goto fail;
+
+ string
+ = (*android_java_env)->GetStaticObjectField (android_java_env,
+ class, field);
+ (*android_java_env)->ExceptionClear (android_java_env);
+
+ if (!string)
+ goto fail;
+
+ data = (*android_java_env)->GetStringUTFChars (android_java_env,
+ string, NULL);
+ (*android_java_env)->ExceptionClear (android_java_env);
+
+ if (!data)
+ goto fail;
+
+ Vandroid_build_manufacturer = build_string_from_utf8 (data);
+ (*android_java_env)->ReleaseStringUTFChars (android_java_env,
+ string, data);
+ }
+
+ if (string)
+ ANDROID_DELETE_LOCAL_REF (string);
+
+ ANDROID_DELETE_LOCAL_REF (class);
+
+ return;
+
+ fail:
+ if (class)
+ ANDROID_DELETE_LOCAL_REF (class);
+
+ Vandroid_build_fingerprint = Qnil;
+ Vandroid_build_manufacturer = Qnil;
+#endif /* ANDROID_STUBIFY */
+}
+
+void
+syms_of_androidterm (void)
+{
+ Fprovide (Qandroid, Qnil);
+
+ DEFVAR_LISP ("android-wait-for-event-timeout",
+ Vandroid_wait_for_event_timeout,
+ doc: /* How long to wait for Android events.
+
+Emacs will wait up to this many seconds to receive events after
+making changes which affect the state of the graphical interface.
+Under some situations this can take an indefinite amount of time,
+so it is important to limit the wait.
+
+If set to a non-float value, there will be no wait at all. */);
+ Vandroid_wait_for_event_timeout = make_float (0.1);
+
+ DEFVAR_BOOL ("x-use-underline-position-properties",
+ x_use_underline_position_properties,
+ doc: /* SKIP: real doc in xterm.c. */);
+ x_use_underline_position_properties = true;
+ DEFSYM (Qx_use_underline_position_properties,
+ "x-use-underline-position-properties");
+
+ DEFVAR_BOOL ("x-underline-at-descent-line",
+ x_underline_at_descent_line,
+ doc: /* SKIP: real doc in xterm.c. */);
+ x_underline_at_descent_line = false;
+
+ DEFVAR_LISP ("android-build-fingerprint", Vandroid_build_fingerprint,
+ doc: /* String identifying the device's OS version.
+This is a string that uniquely identifies the version of Android
+Emacs is running on. */);
+ Vandroid_build_fingerprint = Qnil;
+
+ DEFVAR_LISP ("android-build-manufacturer", Vandroid_build_manufacturer,
+ doc: /* Name of the developer of the running version of Android. */);
+ Vandroid_build_manufacturer = Qnil;
+
+ DEFVAR_LISP ("x-ctrl-keysym", Vx_ctrl_keysym,
+ doc: /* SKIP: real doc in xterm.c. */);
+ Vx_ctrl_keysym = Qnil;
+
+ DEFVAR_LISP ("x-alt-keysym", Vx_alt_keysym,
+ doc: /* SKIP: real doc in xterm.c. */);
+ Vx_alt_keysym = Qnil;
+
+ DEFVAR_LISP ("x-hyper-keysym", Vx_hyper_keysym,
+ doc: /* SKIP: real doc in xterm.c. */);
+ Vx_hyper_keysym = Qnil;
+
+ DEFVAR_LISP ("x-meta-keysym", Vx_meta_keysym,
+ doc: /* SKIP: real doc in xterm.c. */);
+ Vx_meta_keysym = Qnil;
+
+ DEFVAR_LISP ("x-super-keysym", Vx_super_keysym,
+ doc: /* SKIP: real doc in xterm.c. */);
+ Vx_super_keysym = Qnil;
+
+ /* Only defined so loadup.el loads scroll-bar.el. */
+ DEFVAR_LISP ("x-toolkit-scroll-bars", Vx_toolkit_scroll_bars,
+ doc: /* SKIP: real doc in xterm.c. */);
+ Vx_toolkit_scroll_bars = Qnil;
+
+ /* Avoid dumping Vandroid_build_fingerprint. */
+ pdumper_do_now_and_after_load (android_set_build_fingerprint);
+
+ DEFSYM (Qx_underline_at_descent_line, "x-underline-at-descent-line");
+
+ /* Symbols defined for DND events. */
+ DEFSYM (Quri, "uri");
+ DEFSYM (Qtext, "text");
+
+ /* Symbols defined for modifier value reassignment. */
+ DEFSYM (Qmodifier_value, "modifier-value");
+ DEFSYM (Qctrl, "ctrl");
+ Fput (Qctrl, Qmodifier_value, make_fixnum (ctrl_modifier));
+ DEFSYM (Qalt, "alt");
+ Fput (Qalt, Qmodifier_value, make_fixnum (alt_modifier));
+ DEFSYM (Qmeta, "meta");
+ Fput (Qmeta, Qmodifier_value, make_fixnum (meta_modifier));
+ DEFSYM (Qsuper, "super");
+ Fput (Qsuper, Qmodifier_value, make_fixnum (super_modifier));
+}
+
+void
+mark_androidterm (void)
+{
+ if (x_display_list)
+ mark_object (x_display_list->color_map);
+}
diff --git a/src/androidterm.h b/src/androidterm.h
new file mode 100644
index 00000000000..fd4cc99f641
--- /dev/null
+++ b/src/androidterm.h
@@ -0,0 +1,490 @@
+/* Communication module for Android terminals.
+
+Copyright (C) 2023-2024 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 <https://www.gnu.org/licenses/>. */
+
+#ifndef _ANDROID_TERM_H_
+#define _ANDROID_TERM_H_
+
+#include "androidgui.h"
+#include "frame.h"
+#include "character.h"
+#include "dispextern.h"
+#include "font.h"
+#include "termhooks.h"
+
+struct android_bitmap_record
+{
+ /* The image backing the bitmap and its mask. */
+ android_pixmap pixmap, mask;
+
+ /* The file from which it comes. */
+ char *file;
+
+ /* The number of references to it. */
+ int refcount;
+
+ /* The height and width and the depth. */
+ int height, width, depth;
+
+ /* Whether or not there is a mask. */
+ bool have_mask;
+};
+
+struct android_display_info
+{
+ /* Chain of all struct android_display_info structures. */
+ struct android_display_info *next;
+
+ /* The terminal. */
+ struct terminal *terminal;
+
+ /* The root window. This field is unused. */
+ Emacs_Window root_window;
+
+ /* List possibly used only for the font cache but probably used for
+ something else too. */
+ Lisp_Object name_list_element;
+
+ /* List of predefined X colors. */
+ Lisp_Object color_map;
+
+ /* DPI of the display. */
+ double resx, resy;
+
+ /* DPI used to convert font point sizes into pixel dimensions.
+ This is resy adjusted by a fixed scaling factor specified by
+ the user. */
+ double font_resolution;
+
+ /* Scratch GC for drawing a cursor in a non-default face. */
+ struct android_gc *scratch_cursor_gc;
+
+ /* Mouse highlight information. */
+ Mouse_HLInfo mouse_highlight;
+
+ /* Number of planes on this screen. Always 24. */
+ int n_planes;
+
+ /* Mask of things causing the mouse to be grabbed. */
+ int grabbed;
+
+ /* Minimum width over all characters in all fonts in font_table. */
+ int smallest_char_width;
+
+ /* Minimum font height over all fonts in font_table. */
+ int smallest_font_height;
+
+ /* The number of fonts opened for this display. */
+ int n_fonts;
+
+ /* Pointer to bitmap records. */
+ struct android_bitmap_record *bitmaps;
+
+ /* Allocated size of bitmaps field. */
+ ptrdiff_t bitmaps_size;
+
+ /* Last used bitmap index. */
+ ptrdiff_t bitmaps_last;
+
+ /* The frame currently with the input focus. */
+ struct frame *focus_frame;
+
+ /* The last frame mentioned in a focus event. */
+ struct frame *x_focus_event_frame;
+
+ /* The frame which currently has the visual highlight, and should
+ get keyboard input. It points to the focus frame's selected
+ window's frame, but can differ. */
+ struct frame *highlight_frame;
+
+ /* The frame waiting to be auto-raised in android_read_socket. */
+ struct frame *pending_autoraise_frame;
+
+ /* The frame where the mouse was the last time a button event
+ happened. */
+ struct frame *last_mouse_frame;
+
+ /* The frame where the mouse was the last time the mouse glyph
+ changed. */
+ struct frame *last_mouse_glyph_frame;
+
+ /* The frame where the mouse was the last time mouse motion
+ happened. */
+ struct frame *last_mouse_motion_frame;
+
+ /* Position where the mouse was last time we reported a motion.
+ This is a position on last_mouse_motion_frame. It is used in to
+ report the mouse position as well: see
+ android_mouse_position. */
+ int last_mouse_motion_x, last_mouse_motion_y;
+
+ /* Where the mouse was the last time the mouse moved. */
+ Emacs_Rectangle last_mouse_glyph;
+
+ /* The time of the last mouse movement. */
+ Time last_mouse_movement_time;
+
+ /* ID of the last menu event received. -1 means Emacs is waiting
+ for a context menu event. */
+ int menu_event_id;
+
+ /* The invisible cursor used for pointer blanking. */
+ android_cursor invisible_cursor;
+};
+
+/* Structure representing a single tool (finger or stylus) pressed
+ onto a frame. */
+
+struct android_touch_point
+{
+ /* The next tool on this list. */
+ struct android_touch_point *next;
+
+ /* The tool ID and the last known X and Y positions. */
+ int tool_id, x, y;
+
+ /* Whether or not the tool is pressed on the tool bar. */
+ bool tool_bar_p;
+};
+
+struct android_output
+{
+ /* Graphics contexts for the default font. */
+ struct android_gc *normal_gc, *reverse_gc, *cursor_gc;
+
+ /* The window used for this frame. */
+ Emacs_Window window;
+
+ /* Unused field. */
+ Emacs_Window parent_desc;
+
+ /* Default ASCII font of this frame. */
+ struct font *font;
+
+ /* The baseline offset of the default ASCII font. */
+ int baseline_offset;
+
+ /* If a fontset is specified for this frame instead of font, this
+ value contains an ID of the fontset, else -1. */
+ int fontset;
+
+ /* Various colors. */
+ unsigned long cursor_pixel;
+ unsigned long mouse_pixel;
+ unsigned long cursor_foreground_pixel;
+
+ /* Foreground color for scroll bars. A value of -1 means use the
+ default (black for non-toolkit scroll bars). */
+ unsigned long scroll_bar_foreground_pixel;
+
+ /* Background color for scroll bars. A value of -1 means use the
+ default (background color of the frame for non-toolkit scroll
+ bars). */
+ unsigned long scroll_bar_background_pixel;
+
+ /* Cursors associated with this frame. */
+ 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 current_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;
+
+ /* Whether or not the hourglass cursor is being displayed. */
+ bool hourglass;
+
+ /* This is the Emacs structure for the display this frame is on. */
+ struct android_display_info *display_info;
+
+ /* True if this frame was ever previously visible. */
+ bool_bf has_been_visible : 1;
+
+ /* True if this frame's alpha value is the same for both the active
+ and inactive states. */
+ bool_bf alpha_identical_p : 1;
+
+ /* Flag that indicates whether or not the frame contents are
+ complete and can be safely flushed while handling async
+ input. */
+ bool_bf complete : 1;
+
+ /* True that indicates whether or not a buffer flip is required
+ because the frame contents have been dirtied. */
+ bool_bf need_buffer_flip : 1;
+
+ /* Whether or not the input method should be notified every time the
+ position of this frame's selected window changes. */
+ bool_bf need_cursor_updates : 1;
+
+ /* Relief GCs, colors etc. */
+ struct relief {
+ struct android_gc *gc;
+ unsigned long pixel;
+ } black_relief, white_relief;
+
+ /* The background for which the above relief GCs were set up.
+ They are changed only when a different background is involved. */
+ unsigned long relief_background;
+
+ /* Focus state. Only present for consistency with X; it is actually
+ a boolean. */
+ int focus_state;
+
+ /* List of all tools (either styluses or fingers) pressed onto the
+ frame. */
+ struct android_touch_point *touch_points;
+
+ /* Flags associated with the last request to obtain ``extracted
+ text''. */
+ int extracted_text_flags;
+
+ /* Token associated with that request. */
+ int extracted_text_token;
+
+ /* The number of characters of extracted text wanted by the IM. */
+ int extracted_text_hint;
+};
+
+enum
+ {
+ /* Values for focus_state, used as bit mask. EXPLICIT means we
+ received a FocusIn for the frame and know it has the focus.
+ IMPLICIT means we received an EnterNotify and the frame may
+ have the focus if no window manager is running. FocusOut and
+ LeaveNotify clears EXPLICIT/IMPLICIT. */
+ FOCUS_NONE = 0,
+ FOCUS_IMPLICIT = 1,
+ FOCUS_EXPLICIT = 2
+ };
+
+/* Return the Android output data for frame F. */
+#define FRAME_ANDROID_OUTPUT(f) ((f)->output_data.android)
+#define FRAME_OUTPUT_DATA(f) ((f)->output_data.android)
+
+/* Return the Android window used for displaying data in frame F. */
+#define FRAME_ANDROID_WINDOW(f) ((f)->output_data.android->window)
+#define FRAME_NATIVE_WINDOW(f) ((f)->output_data.android->window)
+
+/* Return the need-buffer-flip flag for frame F. */
+#define FRAME_ANDROID_NEED_BUFFER_FLIP(f) \
+ ((f)->output_data.android->need_buffer_flip)
+
+/* Return the drawable used for rendering to frame F and mark the
+ frame as needing a buffer flip later. There's no easy way to run
+ code after any drawing command, but code can be run whenever
+ someone asks for the handle necessary to draw. */
+#define FRAME_ANDROID_DRAWABLE(f) \
+ ((f)->output_data.android->need_buffer_flip = true, \
+ FRAME_ANDROID_WINDOW (f))
+
+/* Return whether or not the frame F has been completely drawn. Used
+ while handling async input. */
+#define FRAME_ANDROID_COMPLETE_P(f) \
+ ((f)->output_data.android->complete)
+
+#define FRAME_FONT(f) ((f)->output_data.android->font)
+#define FRAME_FONTSET(f) ((f)->output_data.android->fontset)
+
+#define FRAME_BASELINE_OFFSET(f) \
+ ((f)->output_data.android->baseline_offset)
+
+/* This gives the android_display_info structure for the display F is
+ on. */
+#define FRAME_DISPLAY_INFO(f) ((f)->output_data.android->display_info)
+
+/* Some things for X compatibility. */
+#define BLACK_PIX_DEFAULT(f) 0
+#define WHITE_PIX_DEFAULT(f) 0xffffffff
+
+/* Android-specific scroll bar stuff. */
+
+/* We represent scroll bars as lisp vectors. This allows us to place
+ references to them in windows without worrying about whether we'll
+ end up with windows referring to dead scroll bars; the garbage
+ collector will free it when its time comes.
+
+ We use struct scroll_bar as a template for accessing fields of the
+ vector. */
+
+struct scroll_bar
+{
+ /* These fields are shared by all vectors. */
+ union vectorlike_header header;
+
+ /* The window we're a scroll bar for. */
+ Lisp_Object window;
+
+ /* The next and previous in the chain of scroll bars in this frame. */
+ Lisp_Object next, prev;
+
+ /* Fields after 'prev' are not traced by the GC. */
+
+ /* The X window representing this scroll bar. */
+ Emacs_Window x_window;
+
+ /* The position and size of the scroll bar in pixels, relative to the
+ frame. */
+ int top, left, width, height;
+
+ /* The starting and ending positions of the handle, relative to the
+ handle area (i.e. zero is the top position, not
+ SCROLL_BAR_TOP_BORDER). If they're equal, that means the handle
+ hasn't been drawn yet.
+
+ These are not actually the locations where the beginning and end
+ are drawn; in order to keep handles from becoming invisible when
+ editing large files, we establish a minimum height by always
+ drawing handle bottoms VERTICAL_SCROLL_BAR_MIN_HANDLE pixels below
+ where they would be normally; the bottom and top are in a
+ different coordinate system. */
+ int start, end;
+
+ /* If the scroll bar handle is currently being dragged by the user,
+ this is the number of pixels from the top of the handle to the
+ place where the user grabbed it. If the handle isn't currently
+ being dragged, this is -1. */
+ int dragging;
+
+ /* True if the scroll bar is horizontal. */
+ bool horizontal;
+};
+
+/* Turning a lisp vector value into a pointer to a struct scroll_bar. */
+#define XSCROLL_BAR(vec) ((struct scroll_bar *) XVECTOR (vec))
+
+
+
+/* This is a chain of structures for all the Android displays
+ currently in use. There is only ever one, but the rest of Emacs is
+ written with systems on which there can be many in mind. */
+extern struct android_display_info *x_display_list;
+
+
+
+/* Start of function definitions. These should be a neat subset of
+ the same ones in xterm.h, and come in the same order. */
+
+/* From androidfns.c. */
+
+extern void android_free_gcs (struct frame *);
+extern void android_default_font_parameter (struct frame *, Lisp_Object);
+extern void android_set_preeditarea (struct window *, int, int);
+
+/* Defined in androidterm.c. */
+
+extern void android_term_init (void);
+extern void android_set_window_size (struct frame *, bool, int, int);
+extern void android_iconify_frame (struct frame *);
+extern void android_make_frame_visible (struct frame *);
+extern void android_make_frame_invisible (struct frame *);
+extern void android_free_frame_resources (struct frame *);
+
+extern int android_parse_color (struct frame *, const char *,
+ Emacs_Color *);
+extern bool android_alloc_nearest_color (struct frame *, Emacs_Color *);
+extern void android_query_colors (struct frame *, Emacs_Color *, int);
+extern void android_clear_under_internal_border (struct frame *);
+
+extern void syms_of_androidterm (void);
+extern void mark_androidterm (void);
+
+/* Defined in androidfns.c. */
+
+extern void android_change_tab_bar_height (struct frame *, int);
+extern void android_change_tool_bar_height (struct frame *, int);
+extern void android_set_scroll_bar_default_width (struct frame *);
+extern void android_set_scroll_bar_default_height (struct frame *);
+extern bool android_defined_color (struct frame *, const char *,
+ Emacs_Color *, bool, bool);
+extern void android_implicitly_set_name (struct frame *, Lisp_Object,
+ Lisp_Object);
+extern void android_explicitly_set_name (struct frame *, Lisp_Object,
+ Lisp_Object);
+
+extern void syms_of_androidfns (void);
+
+/* Defined in androidfont.c. */
+
+extern struct font_driver androidfont_driver;
+
+extern void init_androidfont (void);
+extern void syms_of_androidfont (void);
+
+extern void android_finalize_font_entity (struct font_entity *);
+
+/* Defined in androidmenu.c. */
+
+#ifndef ANDROID_STUBIFY
+
+extern unsigned int current_menu_serial;
+
+#endif
+
+extern Lisp_Object android_menu_show (struct frame *, int, int, int,
+ Lisp_Object, const char **);
+extern Lisp_Object android_popup_dialog (struct frame *, Lisp_Object,
+ Lisp_Object);
+
+extern void init_androidmenu (void);
+extern void syms_of_androidmenu (void);
+
+/* Defined in sfntfont-android.c. */
+
+extern const struct font_driver android_sfntfont_driver;
+
+extern void sfntfont_android_shrink_scanline_buffer (void);
+extern void init_sfntfont_android (void);
+extern void syms_of_sfntfont_android (void);
+
+/* Defined in androidselect.c. */
+
+#ifndef ANDROID_STUBIFY
+
+extern void android_notification_deleted (struct android_notification_event *,
+ struct input_event *);
+extern void android_notification_action (struct android_notification_event *,
+ struct input_event *, Lisp_Object);
+
+extern void init_androidselect (void);
+extern void syms_of_androidselect (void);
+
+/* Defined in androidvfs.c. */
+extern void syms_of_androidvfs (void);
+
+#endif
+
+
+
+#define RGB_TO_ULONG(r, g, b) (((r) << 16) | ((g) << 8) | (b))
+#define RED_FROM_ULONG(color) (((color) >> 16) & 0xff)
+#define GREEN_FROM_ULONG(color) (((color) >> 8) & 0xff)
+#define BLUE_FROM_ULONG(color) ((color) & 0xff)
+
+
+
+#endif /* _ANDROID_TERM_H_ */
diff --git a/src/androidvfs.c b/src/androidvfs.c
new file mode 100644
index 00000000000..a9035ae53c6
--- /dev/null
+++ b/src/androidvfs.c
@@ -0,0 +1,7707 @@
+/* Android virtual file-system support for GNU Emacs.
+
+Copyright (C) 2023-2024 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 <https://www.gnu.org/licenses/>. */
+
+#include <config.h>
+#include <fcntl.h>
+#include <unistd.h>
+#include <assert.h>
+#include <dlfcn.h>
+#include <dirent.h>
+#include <errno.h>
+#include <minmax.h>
+#include <string.h>
+#include <systime.h>
+#include <semaphore.h>
+
+#include <sys/stat.h>
+#include <sys/mman.h>
+
+#include <stat-time.h>
+#include <md5.h>
+
+#include <linux/ashmem.h>
+
+#include "android.h"
+#include "androidterm.h"
+#include "systime.h"
+#include "blockinput.h"
+#include "coding.h"
+
+#if __ANDROID_API__ >= 9
+#include <android/asset_manager.h>
+#include <android/asset_manager_jni.h>
+#else /* __ANDROID_API__ < 9 */
+#include "android-asset.h"
+#endif /* __ANDROID_API__ >= 9 */
+
+#include <android/log.h>
+
+/* This file implements support for the various special-purpose
+ directories found on Android systems through a series of functions
+ that substitute for Unix system call wrappers. Such directories
+ are not mounted in the Unix virtual file-system, but instead
+ require the use of special system APIs to access; Emacs pretends
+ they are mounted at specific folders within the root directory.
+
+ There are presently two directories: /assets, granting access to
+ asset files stored within the APK, and /content, providing direct
+ access to content URIs (in Android 4.4 and later) and content
+ directory trees (in Android 5.0 and later.)
+
+ Substitutes for the C library `open', `fstat', `close', `fclose',
+ `unlink', `symlink', `rmdir', `rename', `stat' system call wrappers
+ are implemented, which delegate their actions to function tables
+ contained inside ``VFS nodes''.
+
+ The functions of a VFS node are to provide the implementations of
+ the Unix file system operations that can be carried out on the file
+ designated by its name and to connect useful information (such as
+ internal file handles or identifiers) with those file names. To
+ those ends, there exist several different types of vnodes, each
+ with a different set of functions and supplementary attributes.
+
+ The key to locating the correct vnode for any given file name is an
+ additional file system operation, defined by each node, which
+ ``names'' children. This operation takes a relative file name and
+ returns a second node designating a constituent sub-file.
+
+ When a file system function is called, it invokes the `name'
+ operation of a special root vnode conceptually located at the top
+ of the Unix file system hierarchy, handing it the complete file
+ name given to it. This vnode's name operation examines the first
+ component of the relative file name it receives and creates either
+ an asset, content, or Unix vnode, and calls the new vnode's `name'
+ operation with the remainder of the file name.
+
+ The vnode(s) created by each `name' operation may in turn create
+ different vnodes based on the components of the names they have
+ been provided that are used to repeat this process until no
+ components remain. The vnode created for the last component of the
+ file name will provide its file system operations or be passed as
+ an argument to other file system operations to which the file has
+ been passed as an argument.
+
+ The substitute functions defined have two caveats, which however
+ don't prove problematic in an Emacs context: the first is that the
+ treatment of `..' is inconsistent with Unix, and has not really
+ been tested, while the second is that errno values do not always
+ conform to what the corresponding Unix system calls may return.
+ These caveats are described in more detail inside the last few
+ pages of this file. */
+
+/* Structure describing an array of VFS operations. */
+
+struct android_vnode;
+
+struct android_vdir
+{
+ /* Return a `struct dirent' describing the next file in this
+ directory stream, or NULL if the stream has reached its end. */
+ struct dirent *(*readdir) (struct android_vdir *);
+
+ /* Close and release all resources allocated for this directory
+ stream. */
+ void (*closedir) (struct android_vdir *);
+
+ /* Return a ``file descriptor'' tied to this directory stream. */
+ int (*dirfd) (struct android_vdir *);
+};
+
+struct android_vops
+{
+ /* Name a child of the given VFS node, which should be a
+ directory.
+
+ LENGTH should be the length of NAME, excluding that of any
+ trailing NULL byte.
+
+ NAME should be a normalized and NULL-terminated relative file
+ name; it may contain a leading separator characters, but no
+ consecutive ones.
+
+ If NAME is empty, create another VFS node designating the same
+ file instead.
+
+ NAME should also be located within writable storage; it may be
+ overwritten as the vnode sees fit.
+
+ Value is a VFS node corresponding to the child, or NULL upon
+ failure.
+
+ A VFS node may be returned even if NAME does not exist, the
+ expectation being that either a later filesystem operation will
+ fail, or will create the file. */
+ struct android_vnode *(*name) (struct android_vnode *, char *, size_t);
+
+ /* Open the specified VNODE, returning either a file descriptor or
+ an asset file descriptor.
+
+ FLAGS and MODE mean the same as they do to the Unix `open' system
+ call.
+
+ ASSET_P stipulates if an asset file descriptor may be returned;
+ if true, *ASSET may be set to an asset file descriptor.
+
+ If an asset file descriptor is unavailable or ASSET_P is false,
+ *FD will be set to a file descriptor.
+
+ If the vnode cannot be opened, value is -1 with errno set
+ accordingly. Otherwise, value is 0 if a file descriptor was
+ returned, and 1 if an asset file descriptor was returned. */
+ int (*open) (struct android_vnode *, int, mode_t, bool,
+ int *, AAsset **);
+
+ /* Close the specified VNODE, releasing all of its resources.
+ Save errno before making system calls that may set it, and
+ restore it to its original value before returning.
+
+ This is unrelated to `android_close', which primarily releases on
+ stat buffers linked to file or asset file descriptors. */
+ void (*close) (struct android_vnode *);
+
+ /* Unlink the file and the specified VNODE. Value and errno are the
+ same as Unix `unlink'. */
+ int (*unlink) (struct android_vnode *);
+
+ /* Create a symlink from the specified VNODE to the target TARGET.
+ Value and errno are the same as `symlink' on Linux (which notably
+ means that errno is set to EPERM if VNODE doesn't support
+ symlinks.) */
+ int (*symlink) (const char *, struct android_vnode *);
+
+ /* Remove VNODE from its parent directory. VNODE must be an empty
+ directory. Value and errno are the same as Unix `rmdir'. */
+ int (*rmdir) (struct android_vnode *);
+
+ /* Move the file designated by SRC to DST, overwriting DST if
+ KEEP_EXISTING is false.
+
+ If KEEP_EXISTING is true and DST already exists, value is -1 with
+ errno set to EEXIST.
+
+ If VNODE does not natively support checking for a preexisting DST
+ and KEEP_EXISTING is true, value is -1 with errno set to ENOSYS.
+
+ Value is otherwise the same as `rename'. */
+ int (*rename) (struct android_vnode *, struct android_vnode *, bool);
+
+ /* Return statistics for the specified VNODE.
+ Value and errno are the same as with Unix `stat'. */
+ int (*stat) (struct android_vnode *, struct stat *);
+
+ /* Return whether or not VNODE is accessible.
+ Value, errno and MODE are the same as with Unix `access'. */
+ int (*access) (struct android_vnode *, int);
+
+ /* Make a directory designated by VNODE, like Unix `mkdir'. */
+ int (*mkdir) (struct android_vnode *, mode_t);
+
+ /* Change the access mode of the provided VNODE to MODE. Value is
+ the same as with `chmod'. FLAGS is passed verbatim from the call
+ to the delegating at-func, and is probably
+ AT_SYMLINK_NOFOLLOW. */
+ int (*chmod) (struct android_vnode *, mode_t, int);
+
+ /* Return the target of VNODE if it is a symbolic link, or -1.
+ Value and errno are the same as with `readlink'. */
+ ssize_t (*readlink) (struct android_vnode *, char *, size_t);
+
+ /* Open the specified VNODE as a directory.
+ Value is a ``directory handle'', or NULL upon failure. */
+ struct android_vdir *(*opendir) (struct android_vnode *);
+};
+
+struct android_vnode
+{
+ /* Operations associated with this vnode. */
+ struct android_vops *ops;
+
+ /* Type of this vnode and its flags. */
+ short type, flags;
+};
+
+/* Structure describing a special named vnode relative to the root
+ vnode, or another directory vnode. */
+
+struct android_special_vnode
+{
+ /* The name of the special file. */
+ const char *name;
+
+ /* The length of that name. */
+ size_t length;
+
+ /* Function called to create the initial vnode from the rest of the
+ component. */
+ struct android_vnode *(*initial) (char *, size_t);
+
+ /* If non-nil, an encoding system into which file name buffers are to
+ be re-encoded before being handed to VFS functions. */
+ Lisp_Object special_coding_system;
+};
+
+verify (NIL_IS_ZERO); /* special_coding_system above. */
+
+enum android_vnode_type
+ {
+ ANDROID_VNODE_UNIX,
+ ANDROID_VNODE_AFS,
+ ANDROID_VNODE_CONTENT,
+ ANDROID_VNODE_CONTENT_AUTHORITY,
+ ANDROID_VNODE_CONTENT_AUTHORITY_NAMED,
+ ANDROID_VNODE_SAF_ROOT,
+ ANDROID_VNODE_SAF_TREE,
+ ANDROID_VNODE_SAF_FILE,
+ ANDROID_VNODE_SAF_NEW,
+ };
+
+
+
+/* Structure describing the android.database.Cursor class. */
+
+struct android_cursor_class
+{
+ jclass class;
+ jmethodID close;
+};
+
+/* Structure describing the EmacsDirectoryEntry class. */
+
+struct emacs_directory_entry_class
+{
+ jclass class;
+ jfieldID d_type;
+ jfieldID d_name;
+};
+
+/* Structure describing the android.os.ParcelFileDescriptor class used
+ to wrap file descriptors sent over IPC. */
+
+struct android_parcel_file_descriptor_class
+{
+ jclass class;
+ jmethodID close;
+ jmethodID get_fd;
+ jmethodID detach_fd;
+};
+
+/* The java.lang.String class. */
+jclass java_string_class;
+
+/* Fields and methods associated with the Cursor class. */
+static struct android_cursor_class cursor_class;
+
+/* Fields and methods associated with the EmacsDirectoryEntry
+ class. */
+static struct emacs_directory_entry_class entry_class;
+
+/* Fields and methods associated with the ParcelFileDescriptor
+ class. */
+static struct android_parcel_file_descriptor_class fd_class;
+
+/* Global references to several exception classes. */
+static jclass file_not_found_exception, security_exception;
+static jclass operation_canceled_exception;
+static jclass unsupported_operation_exception, out_of_memory_error;
+
+/* Initialize `cursor_class' using the given JNI environment ENV.
+ Calling this function is not necessary on Android 4.4 and
+ earlier. */
+
+static void
+android_init_cursor_class (JNIEnv *env)
+{
+ jclass old;
+
+ cursor_class.class
+ = (*env)->FindClass (env, "android/database/Cursor");
+ eassert (cursor_class.class);
+
+ old = cursor_class.class;
+ cursor_class.class
+ = (jclass) (*env)->NewGlobalRef (env, (jobject) old);
+ (*env)->DeleteLocalRef (env, old);
+
+ if (!cursor_class.class)
+ emacs_abort ();
+
+#define FIND_METHOD(c_name, name, signature) \
+ cursor_class.c_name \
+ = (*env)->GetMethodID (env, cursor_class.class, \
+ name, signature); \
+ assert (cursor_class.c_name);
+ FIND_METHOD (close, "close", "()V");
+#undef FIND_METHOD
+}
+
+/* Initialize `entry_class' using the given JNI environment ENV.
+ Calling this function is not necessary on Android 4.4 and
+ earlier. */
+
+static void
+android_init_entry_class (JNIEnv *env)
+{
+ jclass old;
+
+ entry_class.class
+ = (*env)->FindClass (env, "org/gnu/emacs/EmacsDirectoryEntry");
+ eassert (entry_class.class);
+
+ old = entry_class.class;
+ entry_class.class
+ = (jclass) (*env)->NewGlobalRef (env, (jobject) old);
+ (*env)->DeleteLocalRef (env, old);
+
+ if (!entry_class.class)
+ emacs_abort ();
+
+ entry_class.d_type = (*env)->GetFieldID (env, entry_class.class,
+ "d_type", "I");
+ entry_class.d_name = (*env)->GetFieldID (env, entry_class.class,
+ "d_name",
+ "Ljava/lang/String;");
+ assert (entry_class.d_type && entry_class.d_name);
+}
+
+
+/* Initialize `fd_class' using the given JNI environment ENV. Calling
+ this function is not necessary on Android 4.4 and earlier. */
+
+static void
+android_init_fd_class (JNIEnv *env)
+{
+ jclass old;
+
+ fd_class.class
+ = (*env)->FindClass (env, "android/os/ParcelFileDescriptor");
+ eassert (fd_class.class);
+
+ old = fd_class.class;
+ fd_class.class
+ = (jclass) (*env)->NewGlobalRef (env, (jobject) old);
+ (*env)->DeleteLocalRef (env, old);
+
+ if (!fd_class.class)
+ emacs_abort ();
+
+#define FIND_METHOD(c_name, name, signature) \
+ fd_class.c_name \
+ = (*env)->GetMethodID (env, fd_class.class, \
+ name, signature); \
+ assert (fd_class.c_name);
+ FIND_METHOD (close, "close", "()V");
+ FIND_METHOD (get_fd, "getFd", "()I");
+ FIND_METHOD (detach_fd, "detachFd", "()I");
+#undef FIND_METHOD
+}
+
+
+
+/* Account for SAF file names two times as large as PATH_MAX; larger
+ values are prohibitively slow, but smaller values can't face up to
+ some long file names within several nested layers of directories.
+
+ Buffers holding components or other similar file name constituents
+ which don't represent SAF files must continue to use PATH_MAX, for
+ that is the restriction imposed by the Unix file system. */
+
+#define EMACS_PATH_MAX (PATH_MAX * 2)
+
+/* Delete redundant instances of `.' and `..' from NAME in-place.
+ NAME must be *LENGTH long, excluding a mandatory trailing NULL
+ byte.
+
+ Transform each directory component in NAME to avoid instances
+ of the `.' and `..' directories. For example, turn:
+
+ a/../b/c/.
+
+ into
+
+ b/c/
+
+ and return NULL, writing the new length of NAME into *LENGTH.
+
+ If there are more `..' components in NAME than there are normal
+ file name components, return NAME incremented to the position after
+ the first `..' component that cannot be transformed. For example,
+ if NAME is
+
+ a/../../a
+
+ value will be
+
+ a
+
+ If NAME is a directory separator and LENGTH is 1, return without
+ modifying NAME. In any other case, omit any leading directory
+ separator when writing to NAME. This is useful when a vnode that
+ can only be opened as a directory is desired, as this status is
+ made clear by suffixing the file name with a trailing
+ directory separator. */
+
+static char *
+android_vfs_canonicalize_name (char *name, size_t *length)
+{
+ size_t nellipsis, i;
+ char *last_component, *prev_component, *fill, *orig_name;
+ size_t size;
+
+ /* Special case described in the last paragraph of the comment
+ above. */
+
+ size = *length;
+ orig_name = name;
+
+ if (*name == '/' && size == 1)
+ return NULL;
+ else if (*name == '/')
+ size -= 1;
+
+ nellipsis = 0; /* Number of ellipsis encountered within the current
+ file name component, or -1. */
+ prev_component = NULL; /* Pointer to the separator character of
+ the component immediately before the
+ component currently being written. */
+ last_component = name; /* Pointer to the separator character of
+ the component currently being read. */
+ fill = name; /* Pointer to the next character that will be written
+ within NAME. */
+
+ /* Adjust name to skip the leading directory separator. But only
+ after fill is set. */
+ if (*name == '/')
+ name++;
+
+ for (i = 0; i < size; ++i)
+ {
+ switch (name[i])
+ {
+ case '/':
+ /* See if the previous component was `..' or `.'.
+
+ If it is .., and if no previous directory separator was
+ encountered, return or look up a vnode representing the
+ parent. */
+
+ if (nellipsis == 2)
+ {
+ /* .. */
+
+ if (!prev_component)
+ goto parent_vnode;
+
+ /* Return to the last component. */
+ fill = prev_component;
+
+ /* Restore last_component to prev_component, and
+ prev_component back to the component before that. */
+ last_component = prev_component;
+
+ if (last_component != name)
+ prev_component = memrchr (name, '/',
+ last_component - name - 1);
+ else
+ prev_component = NULL;
+
+ /* prev_component may now be NULL. If last_component is
+ the same as NAME, then fill has really been returned
+ to the beginning of the string, so leave it be. But
+ if it's something else, then it must be the first
+ separator character in the string, so set
+ prev_component to NAME itself. */
+
+ if (!prev_component && last_component != name)
+ prev_component = name;
+ }
+ else if (nellipsis == 1)
+ /* If it's ., return to this component. */
+ fill = last_component;
+ else
+ {
+ /* Record the position of the last directory separator,
+ so NAME can be overwritten from there onwards if `..'
+ or `.' are encountered. */
+ prev_component = last_component;
+ last_component = fill;
+ }
+
+ /* Allow tracking ellipses again. */
+ nellipsis = 0;
+ break;
+
+ case '.':
+ if (nellipsis != -1)
+ nellipsis++;
+ break;
+
+ default:
+ nellipsis = -1;
+ break;
+ }
+
+ /* Now copy this character over from NAME. */
+ *fill++ = name[i];
+ }
+
+ /* See if the previous component was `..' or `.'.
+
+ If it is .., and if no previous directory separator was
+ encountered, return or look up a vnode representing the
+ parent. */
+
+ if (nellipsis == 2)
+ {
+ /* .. */
+
+ if (!prev_component)
+ /* Look up the rest of the vnode in its parent. */
+ goto parent_vnode;
+
+ /* Return to the last component. */
+ fill = prev_component;
+ nellipsis = -2;
+ }
+ else if (nellipsis == 1)
+ {
+ /* If it's ., return to this component. */
+ fill = last_component;
+ nellipsis = -2;
+ }
+
+ /* Now, if there's enough room and an ellipsis file name was the
+ last component of END, append a trailing `/' before NULL
+ terminating it, indicating that the file name must be a
+ directory. */
+
+ if (fill + 1 < name + size && nellipsis == -2)
+ *fill++ = '/';
+
+ /* NULL terminate fill. */
+ *fill = '\0';
+ *length = fill - orig_name;
+ return NULL;
+
+ parent_vnode:
+ /* .. was encountered and the parent couldn't be found through
+ stripping off preceding components.
+
+ Find the parent vnode and name the rest of NAME starting from
+ there. */
+ return name + i;
+}
+
+
+
+/* Unix vnode implementation. These VFS nodes directly wrap around
+ the Unix filesystem, with the exception of the root vnode. */
+
+struct android_unix_vnode
+{
+ /* The vnode data itself. */
+ struct android_vnode vnode;
+
+ /* Length of the name without a trailing null byte. */
+ size_t name_length;
+
+ /* Name of the vnode. */
+ char *name;
+};
+
+struct android_unix_vdir
+{
+ /* The directory function table. */
+ struct android_vdir vdir;
+
+ /* The directory stream. */
+ DIR *directory;
+};
+
+/* The vnode representing the root filesystem. */
+static struct android_unix_vnode root_vnode;
+
+static struct android_vnode *android_unix_name (struct android_vnode *,
+ char *, size_t);
+static int android_unix_open (struct android_vnode *, int,
+ mode_t, bool, int *, AAsset **);
+static void android_unix_close (struct android_vnode *);
+static int android_unix_unlink (struct android_vnode *);
+static int android_unix_symlink (const char *, struct android_vnode *);
+static int android_unix_rmdir (struct android_vnode *);
+static int android_unix_rename (struct android_vnode *,
+ struct android_vnode *, bool);
+static int android_unix_stat (struct android_vnode *, struct stat *);
+static int android_unix_access (struct android_vnode *, int);
+static int android_unix_mkdir (struct android_vnode *, mode_t);
+static int android_unix_chmod (struct android_vnode *, mode_t, int);
+static ssize_t android_unix_readlink (struct android_vnode *, char *,
+ size_t);
+static struct android_vdir *android_unix_opendir (struct android_vnode *);
+
+/* Vector of VFS operations associated with Unix filesystem VFS
+ nodes. */
+
+static struct android_vops unix_vfs_ops =
+ {
+ android_unix_name,
+ android_unix_open,
+ android_unix_close,
+ android_unix_unlink,
+ android_unix_symlink,
+ android_unix_rmdir,
+ android_unix_rename,
+ android_unix_stat,
+ android_unix_access,
+ android_unix_mkdir,
+ android_unix_chmod,
+ android_unix_readlink,
+ android_unix_opendir,
+ };
+
+static struct android_vnode *
+android_unix_name (struct android_vnode *vnode, char *name,
+ size_t length)
+{
+ struct android_unix_vnode *vp, *input, temp;
+ char *fill, *remainder;
+ size_t j;
+
+ /* Canonicalize NAME. */
+ input = (struct android_unix_vnode *) vnode;
+ remainder = android_vfs_canonicalize_name (name, &length);
+
+ /* If remainder is set, it's a name relative to the parent
+ vnode. */
+ if (remainder)
+ goto parent_vnode;
+
+ /* Create a new unix vnode. */
+ vp = xmalloc (sizeof *vp);
+
+ /* If name is empty, duplicate the current vnode. */
+
+ if (length < 1)
+ {
+ memcpy (vp, vnode, sizeof *vp);
+ vp->name = xstrdup (vp->name);
+ return &vp->vnode;
+ }
+
+ /* Otherwise, fill in the vnode. */
+
+ vp->vnode.ops = &unix_vfs_ops;
+ vp->vnode.type = ANDROID_VNODE_UNIX;
+ vp->vnode.flags = 0;
+
+ /* Generate the new name of the vnode. Remove any trailing slash
+ from vp->name. */
+
+ vp->name_length = input->name_length + length;
+ vp->name = xmalloc (vp->name_length + 2);
+
+ /* Copy the parent name over. */
+ fill = mempcpy (vp->name, input->name, input->name_length);
+
+ /* Check if it contains a trailing slash. input->name cannot be
+ empty, as the root vnode's name is `/'. */
+
+ if (fill[-1] != '/' && *name != '/')
+ /* If not, append a trailing slash and adjust vp->name_length
+ correspondingly. */
+ *fill++ = '/', vp->name_length++;
+ else if (fill[-1] == '/' && *name == '/')
+ /* If name has a leading slash and fill does too, move fill
+ backwards so that name's slash will override that of fill. */
+ fill--, vp->name_length--;
+
+ /* Now copy NAME. */
+ fill = mempcpy (fill, name, length);
+
+ /* And NULL terminate fill. */
+ *fill = '\0';
+ return &vp->vnode;
+
+ parent_vnode:
+ /* .. was encountered and the parent couldn't be found through
+ stripping off preceding components.
+
+ Find the parent vnode and name the rest of NAME starting from
+ there. */
+
+ if (input->name_length == 1)
+ /* This is the vnode representing the root directory; just look
+ within itself... */
+ vnode = &root_vnode.vnode;
+ else
+ {
+ /* Create a temporary asset vnode within the parent and use it
+ instead. First, establish the length of vp->name before its
+ last component. */
+
+ for (j = input->name_length - 1; j; --j)
+ {
+ if (input->name[j - 1] == '/')
+ break;
+ }
+
+ /* There must be at least one leading directory separator in an
+ asset vnode's `name' field. */
+
+ if (!j)
+ abort ();
+
+ /* j is now the length of the string minus the size of its last
+ component. Create a temporary vnode with that as its
+ name. */
+
+ temp.vnode.ops = &unix_vfs_ops;
+ temp.vnode.type = ANDROID_VNODE_UNIX;
+ temp.vnode.flags = 0;
+ temp.name_length = j;
+ temp.name = xmalloc (j + 1);
+ fill = mempcpy (temp.name, input->name, j);
+ *fill = '\0';
+
+ /* Search for the remainder of NAME relative to its parent. */
+ vnode = android_unix_name (&temp.vnode, remainder,
+ strlen (remainder));
+ xfree (temp.name);
+ return vnode;
+ }
+
+ return (*vnode->ops->name) (vnode, remainder, strlen (remainder));
+}
+
+/* Create a Unix vnode representing the given file NAME. Use this
+ function to create vnodes that aren't rooted in the root VFS
+ node. */
+
+static struct android_vnode *
+android_unix_vnode (const char *name)
+{
+ struct android_unix_vnode *vp;
+
+ vp = xmalloc (sizeof *vp);
+ vp->vnode.ops = &unix_vfs_ops;
+ vp->vnode.type = ANDROID_VNODE_UNIX;
+ vp->vnode.flags = 0;
+ vp->name_length = strlen (name);
+ vp->name = xstrdup (name);
+ return &vp->vnode;
+}
+
+static int
+android_unix_open (struct android_vnode *vnode, int flags,
+ mode_t mode, bool asset_p, int *fd,
+ AAsset **asset)
+{
+ struct android_unix_vnode *vp;
+ int fds;
+
+ vp = (struct android_unix_vnode *) vnode;
+ fds = open (vp->name, flags, mode);
+
+ if (fds < 0)
+ return -1;
+
+ *fd = fds;
+ return 0;
+}
+
+static void
+android_unix_close (struct android_vnode *vnode)
+{
+ struct android_unix_vnode *vp;
+ int save_errno;
+
+ save_errno = errno;
+ vp = (struct android_unix_vnode *) vnode;
+ xfree (vp->name);
+ xfree (vp);
+ errno = save_errno;
+}
+
+static int
+android_unix_unlink (struct android_vnode *vnode)
+{
+ struct android_unix_vnode *vp;
+
+ vp = (struct android_unix_vnode *) vnode;
+ return unlink (vp->name);
+}
+
+static int
+android_unix_symlink (const char *target, struct android_vnode *vnode)
+{
+ struct android_unix_vnode *vp;
+
+ vp = (struct android_unix_vnode *) vnode;
+ return symlink (target, vp->name);
+}
+
+static int
+android_unix_rmdir (struct android_vnode *vnode)
+{
+ struct android_unix_vnode *vp;
+
+ vp = (struct android_unix_vnode *) vnode;
+ return rmdir (vp->name);
+}
+
+static int
+android_unix_rename (struct android_vnode *src,
+ struct android_vnode *dst,
+ bool keep_existing)
+{
+ struct android_unix_vnode *vp, *dest;
+
+ if (src->type != dst->type)
+ {
+ /* If the types of both vnodes differ, complain that they're on
+ two different filesystems (which is correct from a abstract
+ viewpoint.) */
+ errno = EXDEV;
+ return -1;
+ }
+
+ vp = (struct android_unix_vnode *) src;
+ dest = (struct android_unix_vnode *) dst;
+
+ return (keep_existing
+ ? renameat_noreplace (AT_FDCWD, vp->name,
+ AT_FDCWD, dest->name)
+ : rename (vp->name, dest->name));
+}
+
+static int
+android_unix_stat (struct android_vnode *vnode, struct stat *statb)
+{
+ struct android_unix_vnode *vp;
+
+ vp = (struct android_unix_vnode *) vnode;
+ return stat (vp->name, statb);
+}
+
+static int
+android_unix_access (struct android_vnode *vnode, int mode)
+{
+ struct android_unix_vnode *vp;
+
+ vp = (struct android_unix_vnode *) vnode;
+ return access (vp->name, mode);
+}
+
+static int
+android_unix_mkdir (struct android_vnode *vnode, mode_t mode)
+{
+ struct android_unix_vnode *vp;
+
+ vp = (struct android_unix_vnode *) vnode;
+ return mkdir (vp->name, mode);
+}
+
+static int
+android_unix_chmod (struct android_vnode *vnode, mode_t mode,
+ int flags)
+{
+ struct android_unix_vnode *vp;
+
+ vp = (struct android_unix_vnode *) vnode;
+ return fchmodat (AT_FDCWD, vp->name, mode, flags);
+}
+
+static ssize_t
+android_unix_readlink (struct android_vnode *vnode, char *buffer,
+ size_t size)
+{
+ struct android_unix_vnode *vp;
+
+ vp = (struct android_unix_vnode *) vnode;
+ return readlink (vp->name, buffer, size);
+}
+
+static struct dirent *
+android_unix_readdir (struct android_vdir *vdir)
+{
+ struct android_unix_vdir *dir;
+
+ dir = (struct android_unix_vdir *) vdir;
+ return readdir (dir->directory);
+}
+
+static void
+android_unix_closedir (struct android_vdir *vdir)
+{
+ struct android_unix_vdir *dir;
+
+ dir = (struct android_unix_vdir *) vdir;
+ closedir (dir->directory);
+ xfree (vdir);
+}
+
+static int
+android_unix_dirfd (struct android_vdir *vdir)
+{
+ struct android_unix_vdir *dir;
+
+ dir = (struct android_unix_vdir *) vdir;
+ return dirfd (dir->directory);
+}
+
+static struct android_vdir *
+android_unix_opendir (struct android_vnode *vnode)
+{
+ struct android_unix_vnode *vp;
+ struct android_unix_vdir *dir;
+ DIR *directory;
+
+ /* Try to opendir the vnode. */
+ vp = (struct android_unix_vnode *) vnode;
+ directory = opendir (vp->name);
+
+ if (!directory)
+ return NULL;
+
+ dir = xmalloc (sizeof *dir);
+ dir->vdir.readdir = android_unix_readdir;
+ dir->vdir.closedir = android_unix_closedir;
+ dir->vdir.dirfd = android_unix_dirfd;
+ dir->directory = directory;
+ return &dir->vdir;
+}
+
+
+
+/* Asset directory handling functions. ``directory-tree'' is a file in
+ the root of the assets directory describing its contents.
+
+ See lib-src/asset-directory-tool for more details. */
+
+/* The Android directory tree. */
+static const char *directory_tree;
+
+/* The size of the directory tree. */
+static size_t directory_tree_size;
+
+/* The asset manager being used. */
+static AAssetManager *asset_manager;
+
+/* Read an unaligned (32-bit) long from the address POINTER. */
+
+static unsigned int
+android_extract_long (char *pointer)
+{
+ unsigned int number;
+
+ memcpy (&number, pointer, sizeof number);
+ return number;
+}
+
+/* Scan to the file FILE in the asset directory tree. Return a
+ pointer to the end of that file (immediately before any children)
+ in the directory tree, or NULL if that file does not exist.
+
+ If returning non-NULL, also return the offset to the end of the
+ last subdirectory or file in *LIMIT_RETURN. LIMIT_RETURN may be
+ NULL.
+
+ FILE must have less than 11 levels of nesting. If it ends with a
+ trailing slash, then NULL will be returned if it is not actually a
+ directory. */
+
+static const char *
+android_scan_directory_tree (char *file, size_t *limit_return)
+{
+ char *token, *saveptr, *copy, *start, *max, *limit;
+ size_t token_length, ntokens, i, len;
+ char *tokens[10];
+
+ USE_SAFE_ALLOCA;
+
+ /* Skip past the 5 byte header. */
+ start = (char *) directory_tree + 5;
+
+ /* Figure out the current limit. */
+ limit = (char *) directory_tree + directory_tree_size;
+
+ /* Now, split `file' into tokens, with the delimiter being the file
+ name separator. Look for the file and seek past it. Create a copy
+ of FILE for the enjoyment of `strtok_r'. */
+
+ ntokens = 0;
+ saveptr = NULL;
+ len = strlen (file) + 1;
+ copy = SAFE_ALLOCA (len);
+ memcpy (copy, file, len);
+ memset (tokens, 0, sizeof tokens);
+
+ while ((token = strtok_r (copy, "/", &saveptr)))
+ {
+ copy = NULL;
+
+ /* Make sure ntokens is within bounds. */
+ if (ntokens == ARRAYELTS (tokens))
+ goto fail;
+
+ len = strlen (token) + 1;
+ tokens[ntokens] = SAFE_ALLOCA (len);
+ memcpy (tokens[ntokens], token, len);
+ ntokens++;
+ }
+
+ /* If there are no tokens, just return the start of the directory
+ tree. */
+
+ if (!ntokens)
+ {
+ SAFE_FREE ();
+
+ /* Return the size of the directory tree as the limit.
+ Do not subtract the initial header bytes, as the limit
+ is an offset from the start of the file. */
+
+ if (limit_return)
+ *limit_return = directory_tree_size;
+
+ return start;
+ }
+
+ /* Loop through tokens, indexing the directory tree each time. */
+
+ for (i = 0; i < ntokens; ++i)
+ {
+ token = tokens[i];
+
+ /* Figure out how many bytes to compare. */
+ token_length = strlen (token);
+
+ again:
+
+ /* If this would be past the directory, return NULL. */
+ if (start + token_length > limit)
+ goto fail;
+
+ /* Now compare the file name. */
+ if (!memcmp (start, token, token_length))
+ {
+ /* They probably match. Find the NULL byte. It must be
+ either one byte past start + token_length, with the last
+ byte a trailing slash (indicating that it is a
+ directory), or just start + token_length. Return 4 bytes
+ past the next NULL byte. */
+
+ max = memchr (start, 0, limit - start);
+
+ if (max != start + token_length
+ && !(max == start + token_length + 1
+ && *(max - 1) == '/'))
+ goto false_positive;
+
+ /* Return it if it exists and is in range, and this is the
+ last token. Otherwise, set it as start and the limit as
+ start + the offset and continue the loop. */
+
+ if (max && max + 5 <= limit)
+ {
+ if (i < ntokens - 1)
+ {
+ start = max + 5;
+ limit = ((char *) directory_tree
+ + android_extract_long (max + 1));
+
+ /* Make sure limit is still in range. */
+ if (limit > directory_tree + directory_tree_size
+ || start > directory_tree + directory_tree_size)
+ goto fail;
+
+ continue;
+ }
+
+ /* Now see if max is not a directory and file is. If
+ file is a directory, then return NULL. */
+ if (*(max - 1) != '/' && file[strlen (file) - 1] == '/')
+ max = NULL;
+ else
+ {
+ /* Figure out the limit. */
+ if (limit_return)
+ *limit_return = android_extract_long (max + 1);
+
+ /* Go to the end of this file. */
+ max += 5;
+ }
+
+ SAFE_FREE ();
+ return max;
+ }
+
+ /* Return NULL otherwise. */
+ __android_log_print (ANDROID_LOG_WARN, __func__,
+ "could not scan to end of directory tree"
+ ": %s", file);
+ goto fail;
+ }
+
+ false_positive:
+
+ /* No match was found. Set start to the next sibling and try
+ again. */
+
+ start = memchr (start, 0, limit - start);
+
+ if (!start || start + 5 > limit)
+ goto fail;
+
+ start = ((char *) directory_tree
+ + android_extract_long (start + 1));
+
+ /* Make sure start is still in bounds. */
+
+ if (start > limit)
+ goto fail;
+
+ /* Continue the loop. */
+ goto again;
+ }
+
+ fail:
+ SAFE_FREE ();
+ return NULL;
+}
+
+/* Return whether or not the directory tree entry DIR is a
+ directory.
+
+ DIR should be a value returned by
+ `android_scan_directory_tree'. */
+
+static bool
+android_is_directory (const char *dir)
+{
+ /* If the directory is the directory tree, then it is a
+ directory. */
+ if (dir == directory_tree + 5)
+ return true;
+
+ /* Otherwise, look 5 bytes behind. If it is `/', then it is a
+ directory. */
+ return (dir - 6 >= directory_tree
+ && *(dir - 6) == '/');
+}
+
+/* Initialize asset retrieval. ENV should be a JNI environment for
+ the Emacs thread, and MANAGER should be a local reference to a Java
+ asset manager object created for the Emacs service context. */
+
+static void
+android_init_assets (JNIEnv *env, jobject manager)
+{
+ AAsset *asset;
+
+ /* Set the asset manager. */
+ asset_manager = AAssetManager_fromJava (env, manager);
+
+ /* Initialize the directory tree. */
+ asset = AAssetManager_open (asset_manager, "directory-tree",
+ AASSET_MODE_BUFFER);
+
+ if (!asset)
+ {
+ __android_log_print (ANDROID_LOG_FATAL, __func__,
+ "Failed to open directory tree");
+ emacs_abort ();
+ }
+
+ directory_tree = AAsset_getBuffer (asset);
+
+ if (!directory_tree)
+ emacs_abort ();
+
+ /* Now figure out how big the directory tree is, and compare the
+ first few bytes. */
+ directory_tree_size = AAsset_getLength (asset);
+ if (directory_tree_size < 5
+ || memcmp (directory_tree, "EMACS", 5))
+ {
+ __android_log_print (ANDROID_LOG_FATAL, __func__,
+ "Directory tree has bad magic");
+ emacs_abort ();
+ }
+
+ /* Hold a VM reference to the asset manager to prevent the native
+ object from being deleted. */
+ (*env)->NewGlobalRef (env, manager);
+
+ /* Abort if there's no more memory for the global reference. */
+ if ((*env)->ExceptionCheck (env))
+ abort ();
+}
+
+
+
+/* Asset-to-file descriptor conversion. */
+
+/* Pointer to the `ASharedMemory_create' function which is loaded
+ dynamically. */
+static int (*asharedmemory_create) (const char *, size_t);
+
+/* Do the same as android_hack_asset_fd, but use an unlinked temporary
+ file to cater to old Android kernels where ashmem files are not
+ readable. */
+
+static int
+android_hack_asset_fd_fallback (AAsset *asset)
+{
+ int fd;
+ char filename[PATH_MAX];
+ size_t size;
+ void *mem;
+
+ /* Assets must be small enough to fit in size_t, if off_t is
+ larger. */
+ size = AAsset_getLength (asset);
+
+ /* Get an unlinked file descriptor from a file in the cache
+ directory, which is guaranteed to only be written to by Emacs.
+ Creating an ashmem file descriptor and reading from it doesn't
+ work on these old Android versions. */
+
+ snprintf (filename, PATH_MAX, "%s/temp~unlinked.%d",
+ android_cache_dir, getpid ());
+ fd = open (filename, O_CREAT | O_RDWR | O_TRUNC,
+ S_IRUSR | S_IWUSR);
+
+ if (fd < 0)
+ return -1;
+
+ if (unlink (filename))
+ goto fail;
+
+ if (ftruncate (fd, size))
+ goto fail;
+
+ mem = mmap (NULL, size, PROT_WRITE, MAP_SHARED, fd, 0);
+ if (mem == MAP_FAILED)
+ {
+ __android_log_print (ANDROID_LOG_ERROR, __func__,
+ "mmap: %s", strerror (errno));
+ goto fail;
+ }
+
+ if (AAsset_read (asset, mem, size) != size)
+ {
+ /* Too little was read. Close the file descriptor and
+ report an error. */
+ __android_log_print (ANDROID_LOG_ERROR, __func__,
+ "AAsset_read: %s", strerror (errno));
+ goto fail;
+ }
+
+ munmap (mem, size);
+ return fd;
+
+ fail:
+ close (fd);
+ return -1;
+}
+
+/* Return whether or not shared memory file descriptors can also be
+ read from, and are thus suitable for creating asset files.
+
+ This does not work on some ancient Android systems running old
+ versions of the kernel. */
+
+static bool
+android_detect_ashmem (void)
+{
+ int fd, rc;
+ void *mem;
+ char test_buffer[10];
+
+ memcpy (test_buffer, "abcdefghi", 10);
+
+ /* Create the file descriptor to be used for the test. */
+
+ /* Android 28 and earlier let Emacs access /dev/ashmem directly, so
+ prefer that over using ASharedMemory. */
+
+ if (android_get_current_api_level () <= 28)
+ {
+ fd = open ("/dev/ashmem", O_RDWR);
+
+ if (fd < 0)
+ return false;
+
+ /* An empty name means the memory area will exist until the file
+ descriptor is closed, because no other process can
+ attach. */
+ rc = ioctl (fd, ASHMEM_SET_NAME, "");
+
+ if (rc < 0)
+ {
+ close (fd);
+ return false;
+ }
+
+ rc = ioctl (fd, ASHMEM_SET_SIZE, sizeof test_buffer);
+
+ if (rc < 0)
+ {
+ close (fd);
+ return false;
+ }
+ }
+ else
+ {
+ /* On the other hand, SELinux restrictions on Android 29 and
+ later require that Emacs use a system service to obtain
+ shared memory. Load this dynamically, as this service is not
+ available on all versions of the NDK. */
+
+ if (!asharedmemory_create)
+ {
+ *(void **) (&asharedmemory_create)
+ = dlsym (RTLD_DEFAULT, "ASharedMemory_create");
+
+ if (!asharedmemory_create)
+ {
+ __android_log_print (ANDROID_LOG_FATAL, __func__,
+ "dlsym: %s\n",
+ strerror (errno));
+ emacs_abort ();
+ }
+ }
+
+ fd = (*asharedmemory_create) ("", sizeof test_buffer);
+
+ if (fd < 0)
+ return false;
+ }
+
+ /* Now map the resource and write the test contents. */
+
+ mem = mmap (NULL, sizeof test_buffer, PROT_WRITE,
+ MAP_SHARED, fd, 0);
+ if (mem == MAP_FAILED)
+ {
+ close (fd);
+ return false;
+ }
+
+ /* Copy over the test contents. */
+ memcpy (mem, test_buffer, sizeof test_buffer);
+
+ /* Return anyway even if munmap fails. */
+ munmap (mem, sizeof test_buffer);
+
+ /* Try to read the content back into test_buffer. If this does not
+ compare equal to the original string, or the read fails, then
+ ashmem descriptors are not readable on this system. */
+
+ if ((read (fd, test_buffer, sizeof test_buffer)
+ != sizeof test_buffer)
+ || memcmp (test_buffer, "abcdefghi", sizeof test_buffer))
+ {
+ __android_log_print (ANDROID_LOG_WARN, __func__,
+ "/dev/ashmem does not produce real"
+ " temporary files on this system, so"
+ " Emacs will fall back to creating"
+ " unlinked temporary files.");
+ close (fd);
+ return false;
+ }
+
+ close (fd);
+ return true;
+}
+
+/* Get a file descriptor backed by a temporary in-memory file for the
+ given asset. */
+
+static int
+android_hack_asset_fd (AAsset *asset)
+{
+ static bool ashmem_readable_p;
+ static bool ashmem_initialized;
+ int fd, rc;
+ unsigned char *mem;
+ size_t size;
+
+ /* The first time this function is called, try to determine whether
+ or not ashmem file descriptors can be read from. */
+
+ if (!ashmem_initialized)
+ ashmem_readable_p
+ = android_detect_ashmem ();
+ ashmem_initialized = true;
+
+ /* If it isn't, fall back. */
+
+ if (!ashmem_readable_p)
+ return android_hack_asset_fd_fallback (asset);
+
+ /* Assets must be small enough to fit in size_t, if off_t is
+ larger. */
+ size = AAsset_getLength (asset);
+
+ /* Android 28 and earlier let Emacs access /dev/ashmem directly, so
+ prefer that over using ASharedMemory. */
+
+ if (android_get_current_api_level () <= 28)
+ {
+ fd = open ("/dev/ashmem", O_RDWR);
+
+ if (fd < 0)
+ return -1;
+
+ /* An empty name means the memory area will exist until the file
+ descriptor is closed, because no other process can
+ attach. */
+ rc = ioctl (fd, ASHMEM_SET_NAME, "");
+
+ if (rc < 0)
+ {
+ __android_log_print (ANDROID_LOG_ERROR, __func__,
+ "ioctl ASHMEM_SET_NAME: %s",
+ strerror (errno));
+ close (fd);
+ return -1;
+ }
+
+ rc = ioctl (fd, ASHMEM_SET_SIZE, size);
+
+ if (rc < 0)
+ {
+ __android_log_print (ANDROID_LOG_ERROR, __func__,
+ "ioctl ASHMEM_SET_SIZE: %s",
+ strerror (errno));
+ close (fd);
+ return -1;
+ }
+
+ if (!size)
+ return fd;
+
+ /* Now map the resource. */
+ mem = mmap (NULL, size, PROT_WRITE, MAP_SHARED, fd, 0);
+ if (mem == MAP_FAILED)
+ {
+ __android_log_print (ANDROID_LOG_ERROR, __func__,
+ "mmap: %s", strerror (errno));
+ close (fd);
+ return -1;
+ }
+
+ if (AAsset_read (asset, mem, size) != size)
+ {
+ /* Too little was read. Close the file descriptor and
+ report an error. */
+ __android_log_print (ANDROID_LOG_ERROR, __func__,
+ "AAsset_read: %s", strerror (errno));
+ close (fd);
+ return -1;
+ }
+
+ /* Return anyway even if munmap fails. */
+ munmap (mem, size);
+ return fd;
+ }
+
+ /* On the other hand, SELinux restrictions on Android 29 and later
+ require that Emacs use a system service to obtain shared memory.
+ Load this dynamically, as this service is not available on all
+ versions of the NDK. */
+
+ if (!asharedmemory_create)
+ {
+ *(void **) (&asharedmemory_create)
+ = dlsym (RTLD_DEFAULT, "ASharedMemory_create");
+
+ if (!asharedmemory_create)
+ {
+ __android_log_print (ANDROID_LOG_FATAL, __func__,
+ "dlsym: %s\n",
+ strerror (errno));
+ emacs_abort ();
+ }
+ }
+
+ fd = (*asharedmemory_create) ("", size);
+
+ if (fd < 0)
+ {
+ __android_log_print (ANDROID_LOG_ERROR, __func__,
+ "ASharedMemory_create: %s",
+ strerror (errno));
+ return -1;
+ }
+
+ /* Now map the resource. */
+ mem = mmap (NULL, size, PROT_WRITE, MAP_SHARED, fd, 0);
+ if (mem == MAP_FAILED)
+ {
+ __android_log_print (ANDROID_LOG_ERROR, __func__,
+ "mmap: %s", strerror (errno));
+ close (fd);
+ return -1;
+ }
+
+ if (AAsset_read (asset, mem, size) != size)
+ {
+ /* Too little was read. Close the file descriptor and
+ report an error. */
+ __android_log_print (ANDROID_LOG_ERROR, __func__,
+ "AAsset_read: %s", strerror (errno));
+ close (fd);
+ return -1;
+ }
+
+ /* Return anyway even if munmap fails. */
+ munmap (mem, size);
+ return fd;
+}
+
+
+
+/* ``Asset file system'' vnode implementation. These vnodes map to
+ asset files within the application package, provided by the Android
+ ``asset manager''. */
+
+struct android_afs_vnode
+{
+ /* The vnode data itself. */
+ struct android_vnode vnode;
+
+ /* Length of the name without a trailing null byte. */
+ size_t name_length;
+
+ /* Name of the vnode. */
+ char *name;
+};
+
+struct android_afs_vdir
+{
+ /* The directory function table. */
+ struct android_vdir vdir;
+
+ /* The next directory stream in `all_afs_vdirs'. */
+ struct android_afs_vdir *next;
+
+ /* Pointer to the directory in directory_tree. */
+ char *asset_dir;
+
+ /* And the end of the files in asset_dir. */
+ char *asset_limit;
+
+ /* Path to the directory relative to /. */
+ char *asset_file;
+
+ /* File descriptor representing this directory stream, or NULL. */
+ int fd;
+};
+
+struct android_afs_open_fd
+{
+ /* The next table entry. */
+ struct android_afs_open_fd *next;
+
+ /* The open file descriptor. */
+ int fd;
+
+ /* The stat buffer associated with this entry. */
+ struct stat statb;
+};
+
+static struct android_vnode *android_afs_name (struct android_vnode *,
+ char *, size_t);
+static int android_afs_open (struct android_vnode *, int,
+ mode_t, bool, int *, AAsset **);
+static void android_afs_close (struct android_vnode *);
+static int android_afs_unlink (struct android_vnode *);
+static int android_afs_symlink (const char *, struct android_vnode *);
+static int android_afs_rmdir (struct android_vnode *);
+static int android_afs_rename (struct android_vnode *,
+ struct android_vnode *, bool);
+static int android_afs_stat (struct android_vnode *, struct stat *);
+static int android_afs_access (struct android_vnode *, int);
+static int android_afs_mkdir (struct android_vnode *, mode_t);
+static int android_afs_chmod (struct android_vnode *, mode_t, int);
+static ssize_t android_afs_readlink (struct android_vnode *, char *,
+ size_t);
+static struct android_vdir *android_afs_opendir (struct android_vnode *);
+
+/* Vector of VFS operations associated with asset VFS nodes. */
+
+static struct android_vops afs_vfs_ops =
+ {
+ android_afs_name,
+ android_afs_open,
+ android_afs_close,
+ android_afs_unlink,
+ android_afs_symlink,
+ android_afs_rmdir,
+ android_afs_rename,
+ android_afs_stat,
+ android_afs_access,
+ android_afs_mkdir,
+ android_afs_chmod,
+ android_afs_readlink,
+ android_afs_opendir,
+ };
+
+/* Chain consisting of all open asset directory streams. */
+static struct android_afs_vdir *all_afs_vdirs;
+
+/* List linking open file descriptors to asset information. This
+ assumes Emacs does not use dup on regular files. */
+static struct android_afs_open_fd *afs_file_descriptors;
+
+static struct android_vnode *
+android_afs_name (struct android_vnode *vnode, char *name,
+ size_t length)
+{
+ size_t j;
+ char *remainder, *fill;
+ struct android_afs_vnode *vp, *input;
+ struct android_afs_vnode temp;
+
+ input = (struct android_afs_vnode *) vnode;
+
+ /* Canonicalize NAME. */
+ remainder = android_vfs_canonicalize_name (name, &length);
+
+ /* If remainder is set, it's a name relative to the parent
+ vnode. */
+ if (remainder)
+ goto parent_vnode;
+
+ /* Allocate a new vnode. */
+ vp = xmalloc (sizeof *vp);
+
+ /* See the specified name is empty. */
+
+ if (length < 1)
+ {
+ memcpy (vp, vnode, sizeof *vp);
+ vp->name = xstrdup (vp->name);
+ return &vp->vnode;
+ }
+
+ /* Recompute length. */
+ vp->vnode.ops = &afs_vfs_ops;
+ vp->vnode.type = ANDROID_VNODE_AFS;
+ vp->vnode.flags = 0;
+
+ /* Generate the new name of the vnode. Remove any trailing slash
+ from vp->name. */
+
+ vp->name_length = input->name_length + length;
+ vp->name = xmalloc (vp->name_length + 2);
+
+ /* Copy the parent name over. */
+ fill = mempcpy (vp->name, input->name, input->name_length);
+
+ /* Check if it contains a trailing slash. input->name cannot be
+ empty, as the root vnode's name is `/'. */
+
+ if (fill[-1] != '/' && *name != '/')
+ /* If not, append a trailing slash and adjust vp->name_length
+ correspondingly. */
+ *fill++ = '/', vp->name_length++;
+ else if (fill[-1] == '/' && *name == '/')
+ /* If name has a leading slash and fill does too, move fill
+ backwards so that name's slash will override that of fill. */
+ fill--, vp->name_length--;
+
+ /* Now copy NAME. */
+ fill = mempcpy (fill, name, length);
+
+ /* And NULL terminate fill. */
+ *fill = '\0';
+ return &vp->vnode;
+
+ parent_vnode:
+ /* .. was encountered and the parent couldn't be found through
+ stripping off preceding components.
+
+ Find the parent vnode and name the rest of NAME starting from
+ there. */
+
+ if (input->name_length == 1)
+ /* This is the vnode representing the /assets directory... */
+ vnode = &root_vnode.vnode;
+ else
+ {
+ /* Create a temporary asset vnode within the parent and use it
+ instead. First, establish the length of vp->name before its
+ last component. */
+
+ for (j = input->name_length - 1; j; --j)
+ {
+ if (input->name[j - 1] == '/')
+ break;
+ }
+
+ /* There must be at least one leading directory separator in an
+ asset vnode's `name' field. */
+
+ if (!j)
+ abort ();
+
+ /* j is now the length of the string minus the size of its last
+ component. Create a temporary vnode with that as its
+ name. */
+
+ temp.vnode.ops = &afs_vfs_ops;
+ temp.vnode.type = ANDROID_VNODE_AFS;
+ temp.vnode.flags = 0;
+ temp.name_length = j;
+ temp.name = xmalloc (j + 1);
+ fill = mempcpy (temp.name, input->name, j);
+ *fill = '\0';
+
+ /* Search for the remainder of NAME relative to its parent. */
+ vnode = android_afs_name (&temp.vnode, remainder,
+ strlen (remainder));
+ xfree (temp.name);
+ return vnode;
+ }
+
+ return (*vnode->ops->name) (vnode, remainder, strlen (remainder));
+}
+
+/* Find the vnode designated by the normalized NAME relative to the
+ root of the asset file system. NAME may be modified, and must be
+ LENGTH bytes long, excluding its terminating NULL byte. */
+
+static struct android_vnode *
+android_afs_initial (char *name, size_t length)
+{
+ struct android_afs_vnode temp;
+
+ /* Create a temporary vnode at the root of the asset file
+ system. */
+
+ temp.vnode.ops = &afs_vfs_ops;
+ temp.vnode.type = ANDROID_VNODE_AFS;
+ temp.vnode.flags = 0;
+ temp.name_length = 1;
+ temp.name = (char *) "/";
+
+ /* Try to name this vnode. If NAME is empty, it will be duplicated
+ instead. */
+ return android_afs_name (&temp.vnode, name, length);
+}
+
+/* Make FD close-on-exec. If any system call fails, do not abort, but
+ log a warning to the system log. */
+
+static void
+android_close_on_exec (int fd)
+{
+ int flags, rc;
+
+ flags = fcntl (fd, F_GETFD);
+
+ if (flags < 0)
+ {
+ __android_log_print (ANDROID_LOG_WARN, __func__,
+ "fcntl: %s", strerror (errno));
+ return;
+ }
+
+ rc = fcntl (fd, F_SETFD, flags | O_CLOEXEC);
+
+ if (rc < 0)
+ {
+ __android_log_print (ANDROID_LOG_WARN, __func__,
+ "fcntl: %s", strerror (errno));
+ return;
+ }
+}
+
+static int
+android_afs_open (struct android_vnode *vnode, int flags,
+ mode_t mode, bool asset_p, int *fd_return,
+ AAsset **asset_return)
+{
+ AAsset *asset;
+ struct android_afs_vnode *vp;
+ const char *asset_dir;
+ int fd;
+ struct android_afs_open_fd *info;
+
+ vp = (struct android_afs_vnode *) vnode;
+
+ /* Return suitable error indications for unsupported file
+ operations. */
+
+ if ((flags & O_WRONLY) || (flags & O_RDWR))
+ {
+ errno = EROFS;
+ return -1;
+ }
+
+ if (flags & O_DIRECTORY)
+ {
+ errno = ENOSYS;
+ return -1;
+ }
+
+ /* Now try to open this asset. Asset manager APIs expect there to
+ be no trailing directory separator. */
+ asset = AAssetManager_open (asset_manager, vp->name + 1,
+ AASSET_MODE_STREAMING);
+
+ /* If it can't be opened, return an error indication. */
+
+ if (!asset)
+ {
+ /* Scan the directory tree for this file. */
+ asset_dir = android_scan_directory_tree (vp->name, NULL);
+
+ /* Default errno to ENOTENT. */
+ errno = ENOENT;
+
+ /* Maybe the caller wants to open a directory vnode as a
+ file? */
+
+ if (asset_dir && android_is_directory (asset_dir))
+ /* In that case, set errno to ENOSYS. */
+ errno = ENOSYS;
+
+ return -1;
+ }
+
+ /* An asset has been opened. If the caller wants a file descriptor,
+ a temporary one must be created and the file contents read
+ inside. */
+
+ if (!asset_p)
+ {
+ /* Create a shared memory file descriptor containing the asset
+ contents.
+
+ The documentation misleads people into thinking that
+ AAsset_openFileDescriptor does precisely this. However, it
+ instead returns an offset into any uncompressed assets in the
+ ZIP archive. This cannot be found in its documentation. */
+
+ fd = android_hack_asset_fd (asset);
+
+ if (fd == -1)
+ {
+ AAsset_close (asset);
+ errno = EIO;
+ return -1;
+ }
+
+ /* If O_CLOEXEC is specified, make the file descriptor close on
+ exec too. */
+
+ if (flags & O_CLOEXEC)
+ android_close_on_exec (fd);
+
+ /* Keep a record linking ``hacked'' file descriptors with
+ their file status. */
+ info = xzalloc (sizeof *info);
+ info->fd = fd;
+ info->next = afs_file_descriptors;
+
+ /* Fill in some information that will be reported to
+ callers of android_fstat, among others. */
+ info->statb.st_mode = S_IFREG | S_IRUSR | S_IRGRP | S_IROTH;
+
+ /* Owned by root. */
+ info->statb.st_uid = 0;
+ info->statb.st_gid = 0;
+
+ /* Concoct a nonexistent device and an inode number. */
+ info->statb.st_dev = -1;
+ info->statb.st_ino = 0;
+
+ /* Size of the file. */
+ info->statb.st_size = AAsset_getLength (asset);
+
+ /* If the installation date can be ascertained, return that as
+ the file's modification time. */
+
+ if (timespec_valid_p (emacs_installation_time))
+ {
+#ifdef STAT_TIMESPEC
+ STAT_TIMESPEC (&info->statb, st_mtim) = emacs_installation_time;
+#else /* !STAT_TIMESPEC */
+ /* Headers supplied by the NDK r10b contain a `struct stat'
+ without POSIX fields for nano-second timestamps. */
+ info->statb.st_mtime = emacs_installation_time.tv_sec;
+ info->statb.st_mtime_nsec = emacs_installation_time.tv_nsec;
+#endif /* STAT_TIMESPEC */
+ }
+
+ /* Chain info onto afs_file_descriptors. */
+ afs_file_descriptors = info;
+
+ AAsset_close (asset);
+
+ /* Return the file descriptor. */
+ *fd_return = fd;
+ return 0;
+ }
+
+ /* Return the asset itself. */
+ *asset_return = asset;
+ return 1;
+}
+
+static void
+android_afs_close (struct android_vnode *vnode)
+{
+ struct android_afs_vnode *vp;
+ int save_errno;
+
+ save_errno = errno;
+ vp = (struct android_afs_vnode *) vnode;
+ xfree (vp->name);
+ xfree (vp);
+ errno = save_errno;
+}
+
+static int
+android_afs_unlink (struct android_vnode *vnode)
+{
+ const char *dir;
+ struct android_afs_vnode *vp;
+
+ /* If the vnode already exists, return EROFS. Else, return
+ ENOENT. */
+
+ vp = (struct android_afs_vnode *) vnode;
+ dir = android_scan_directory_tree (vp->name, NULL);
+
+ if (dir)
+ errno = EROFS;
+ else
+ errno = ENOENT;
+
+ return -1;
+}
+
+static int
+android_afs_symlink (const char *linkname, struct android_vnode *vnode)
+{
+ struct android_afs_vnode *vp;
+
+ /* If this vnode already exists, return EEXIST. */
+ vp = (struct android_afs_vnode *) vnode;
+
+ if (android_scan_directory_tree (vp->name, NULL))
+ {
+ errno = EEXIST;
+ return -1;
+ }
+
+ /* Symlinks aren't supported on this (read-only) ``file system'',
+ so return -1 with EROFS. */
+ errno = EROFS;
+ return -1;
+}
+
+static int
+android_afs_rmdir (struct android_vnode *vnode)
+{
+ const char *dir;
+ struct android_afs_vnode *vp;
+
+ /* If the vnode already exists and is a directory, return EROFS.
+ Else, return ENOTDIR or ENOENT. */
+
+ vp = (struct android_afs_vnode *) vnode;
+ dir = android_scan_directory_tree (vp->name, NULL);
+
+ if (dir && android_is_directory (dir))
+ errno = EROFS;
+ else if (dir)
+ errno = ENOTDIR;
+ else
+ errno = ENOENT;
+
+ return -1;
+}
+
+static int
+android_afs_rename (struct android_vnode *src, struct android_vnode *dst,
+ bool keep_existing)
+{
+ /* If src and dst are different kinds of vnodes, return EXDEV.
+ Else, return EROFS. */
+
+ errno = EROFS;
+ if (src->type != dst->type)
+ errno = EXDEV;
+
+ return -1;
+}
+
+static int
+android_afs_stat (struct android_vnode *vnode, struct stat *statb)
+{
+ const char *dir;
+ struct android_afs_vnode *vp;
+ AAsset *asset_desc;
+
+ /* Scan for the vnode to see whether or not it exists. */
+
+ vp = (struct android_afs_vnode *) vnode;
+ dir = android_scan_directory_tree (vp->name, NULL);
+
+ if (!dir)
+ {
+ /* Return ENOENT; whether the lookup failed because directory
+ components within vp->path weren't really directories is not
+ important to Emacs's error reporting. */
+ errno = ENOENT;
+ return -1;
+ }
+
+ if (android_is_directory (dir))
+ {
+ memset (statb, 0, sizeof *statb);
+
+ /* Fill in the stat buffer. */
+ statb->st_mode = S_IFDIR | S_IRUSR | S_IRGRP | S_IROTH;
+
+ /* Grant search permissions as well. */
+ statb->st_mode |= S_IXUSR | S_IXGRP | S_IXOTH;
+
+ /* Concoct a nonexistent device and an inode number. */
+ statb->st_dev = -1;
+ statb->st_ino = 0;
+ goto set_file_times;
+ }
+
+ /* AASSET_MODE_STREAMING is fastest here. */
+ asset_desc = AAssetManager_open (asset_manager, vp->name + 1,
+ AASSET_MODE_STREAMING);
+
+ if (!asset_desc)
+ {
+ /* If the asset exists in the directory tree but can't be
+ located by the asset manager, report OOM. */
+ errno = ENOMEM;
+ return 1;
+ }
+
+ memset (statb, 0, sizeof *statb);
+
+ /* Fill in the stat buffer. */
+ statb->st_mode = S_IFREG | S_IRUSR | S_IRGRP | S_IROTH;
+ statb->st_dev = -1;
+ statb->st_ino = 0;
+ statb->st_size = AAsset_getLength (asset_desc);
+
+ /* Close the asset. */
+ AAsset_close (asset_desc);
+
+ set_file_times:
+
+ /* If the installation date can be ascertained, return that as the
+ file's modification time. */
+
+ if (timespec_valid_p (emacs_installation_time))
+ {
+#ifdef STAT_TIMESPEC
+ STAT_TIMESPEC (statb, st_mtim) = emacs_installation_time;
+#else /* !STAT_TIMESPEC */
+ /* Headers supplied by the NDK r10b contain a `struct stat'
+ without POSIX fields for nano-second timestamps. */
+ statb->st_mtime = emacs_installation_time.tv_sec;
+ statb->st_mtime_nsec = emacs_installation_time.tv_nsec;
+#endif /* STAT_TIMESPEC */
+ }
+
+ return 0;
+}
+
+static int
+android_afs_access (struct android_vnode *vnode, int mode)
+{
+ const char *dir;
+ struct android_afs_vnode *vp;
+
+ /* Validate MODE. */
+
+ if (mode != F_OK && !(mode & (W_OK | X_OK | R_OK)))
+ {
+ errno = EINVAL;
+ return -1;
+ }
+
+ /* Scan for the vnode to see whether or not it exists. */
+
+ vp = (struct android_afs_vnode *) vnode;
+ dir = android_scan_directory_tree (vp->name, NULL);
+
+ if (dir)
+ {
+ /* It exists. If MODE contains W_OK or X_OK, return
+ EACCESS. */
+
+ if (mode & (W_OK | X_OK))
+ {
+ errno = EACCES;
+ return -1;
+ }
+
+ /* If vp->name is a directory and DIR isn't, return ENOTDIR. */
+
+ if (vp->name[vp->name_length] == '/'
+ && !android_is_directory (dir))
+ {
+ errno = ENOTDIR;
+ return -1;
+ }
+
+ return 0;
+ }
+
+ errno = ENOENT;
+ return -1;
+}
+
+static int
+android_afs_mkdir (struct android_vnode *vnode, mode_t mode)
+{
+ struct android_afs_vnode *vp;
+ const char *dir;
+
+ /* If the vnode already exists, return EEXIST in lieu of EROFS. */
+
+ vp = (struct android_afs_vnode *) vnode;
+ dir = android_scan_directory_tree (vp->name, NULL);
+
+ if (dir)
+ errno = EEXIST;
+ else
+ errno = EROFS;
+
+ return -1;
+}
+
+static int
+android_afs_chmod (struct android_vnode *vnode, mode_t mode,
+ int flags)
+{
+ errno = EROFS;
+ return -1;
+}
+
+static ssize_t
+android_afs_readlink (struct android_vnode *vnode, char *buffer,
+ size_t size)
+{
+ struct android_afs_vnode *vp;
+ const char *dir;
+
+ vp = (struct android_afs_vnode *) vnode;
+ dir = android_scan_directory_tree (vp->name, NULL);
+
+ /* As there are no symlinks in /assets, just return -1 with errno
+ set to a reasonable value contingent upon whether VP->name
+ actually exists. */
+
+ if (dir)
+ errno = EINVAL;
+ else
+ errno = ENOENT;
+
+ return -1;
+}
+
+static struct dirent *
+android_afs_readdir (struct android_vdir *vdir)
+{
+ static struct dirent dirent;
+ const char *last;
+ struct android_afs_vdir *dir;
+
+ dir = (struct android_afs_vdir *) vdir;
+
+ /* There are no more files to read. */
+ if (dir->asset_dir >= dir->asset_limit)
+ return NULL;
+
+ /* Otherwise, scan forward looking for the next NULL byte. */
+ last = memchr (dir->asset_dir, 0,
+ dir->asset_limit - dir->asset_dir);
+
+ /* No more NULL bytes remain. */
+ if (!last)
+ return NULL;
+
+ /* Forward last past the NULL byte. */
+ last++;
+
+ /* Make sure it is still within the directory tree. */
+ if (last >= directory_tree + directory_tree_size)
+ return NULL;
+
+ /* Now, fill in the dirent with the name. */
+ memset (&dirent, 0, sizeof dirent);
+ dirent.d_ino = 0;
+ dirent.d_off = 0;
+ dirent.d_reclen = sizeof dirent;
+
+ /* Note that dir->asset_dir is actually a NULL terminated
+ string. */
+ memcpy (dirent.d_name, dir->asset_dir,
+ MIN (sizeof dirent.d_name,
+ last - dir->asset_dir));
+ dirent.d_name[sizeof dirent.d_name - 1] = '\0';
+
+ /* Strip off the trailing slash, if any. */
+ if (dirent.d_name[MIN (sizeof dirent.d_name,
+ last - dir->asset_dir)
+ - 2] == '/')
+ dirent.d_name[MIN (sizeof dirent.d_name,
+ last - dir->asset_dir)
+ - 2] = '\0';
+
+ /* If this is not a directory, return DT_REG. Otherwise, return
+ DT_DIR. */
+
+ if (last - 2 >= directory_tree && last[-2] == '/')
+ dirent.d_type = DT_DIR;
+ else
+ dirent.d_type = DT_REG;
+
+ /* Forward dir->asset_dir to the file past last. */
+ dir->asset_dir = ((char *) directory_tree
+ + android_extract_long ((char *) last));
+
+ return &dirent;
+}
+
+static void
+android_afs_closedir (struct android_vdir *vdir)
+{
+ struct android_afs_vdir *dir, **next, *tem;
+
+ dir = (struct android_afs_vdir *) vdir;
+
+ /* If the ``directory file descriptor'' has been opened, close
+ it. */
+
+ if (dir->fd != -1)
+ close (dir->fd);
+
+ xfree (dir->asset_file);
+
+ /* Now unlink this directory. */
+
+ for (next = &all_afs_vdirs; (tem = *next);)
+ {
+ if (tem == dir)
+ *next = dir->next;
+ else
+ next = &(*next)->next;
+ }
+
+ /* Free the directory itself. */
+
+ xfree (dir);
+}
+
+static int
+android_afs_dirfd (struct android_vdir *vdir)
+{
+ struct android_afs_vdir *dir;
+
+ dir = (struct android_afs_vdir *) vdir;
+
+ /* Since `android_afs_opendir' tries to avoid opening a file
+ descriptor if readdir isn't called, dirfd can fail if open fails.
+
+ open sets errno to a set of errors different from what POSIX
+ stipulates for dirfd, but for ease of implementation the open
+ errors are used instead. */
+
+ if (dir->fd >= 0)
+ return dir->fd;
+
+ dir->fd = open ("/dev/null", O_RDONLY | O_CLOEXEC);
+ return dir->fd;
+}
+
+static struct android_vdir *
+android_afs_opendir (struct android_vnode *vnode)
+{
+ char *asset_dir;
+ struct android_afs_vdir *dir;
+ struct android_afs_vnode *vp;
+ size_t limit;
+
+ vp = (struct android_afs_vnode *) vnode;
+
+ /* Scan for the asset directory by vp->name. */
+
+ asset_dir
+ = (char *) android_scan_directory_tree (vp->name, &limit);
+
+ if (!asset_dir)
+ {
+ errno = ENOENT;
+ return NULL;
+ }
+
+ /* Verify that asset_dir is indeed a directory. */
+
+ if (!android_is_directory (asset_dir))
+ {
+ errno = ENOTDIR;
+ return NULL;
+ }
+
+ /* Fill in the directory stream. */
+ dir = xmalloc (sizeof *dir);
+ dir->vdir.readdir = android_afs_readdir;
+ dir->vdir.closedir = android_afs_closedir;
+ dir->vdir.dirfd = android_afs_dirfd;
+ dir->asset_dir = asset_dir;
+ dir->asset_limit = (char *) directory_tree + limit;
+ dir->fd = -1;
+ dir->asset_file = xzalloc (vp->name_length + 2);
+ strcpy (dir->asset_file, vp->name);
+
+ /* Make sure dir->asset_file is terminated with /. */
+ if (dir->asset_file[vp->name_length - 1] != '/')
+ dir->asset_file[vp->name_length] = '/';
+
+ /* Make sure dir->asset_limit is within bounds. It is a limit,
+ and as such can be exactly one byte past directory_tree. */
+ if (dir->asset_limit > directory_tree + directory_tree_size)
+ {
+ xfree (dir->asset_file);
+ xfree (dir);
+ errno = EACCES;
+ return NULL;
+ }
+
+ dir->next = all_afs_vdirs;
+ all_afs_vdirs = dir;
+ return &dir->vdir;
+}
+
+/* Return the file name corresponding to DIRFD if it is a
+ ``directory'' file descriptor returned by `android_afs_dirfd' or
+ NULL otherwise. These file names are relative to the `/assets'
+ directory, but with a leading separator character. */
+
+static char *
+android_afs_get_directory_name (int dirfd)
+{
+ struct android_afs_vdir *dir;
+
+ for (dir = all_afs_vdirs; dir; dir = dir->next)
+ {
+ if (dir->fd == dirfd && dirfd != -1)
+ return dir->asset_file;
+ }
+
+ return NULL;
+}
+
+
+
+struct android_content_vdir
+{
+ /* The directory function table. */
+ struct android_vdir vdir;
+
+ /* The next directory stream in `all_content_vdirs'. */
+ struct android_content_vdir *next;
+
+ /* Pointer to the next file to return. */
+ const char **next_name;
+
+ /* Temporary file descriptor used to identify this directory to
+ at-funcs, or -1. */
+ int fd;
+};
+
+static struct android_vnode *android_authority_initial (char *, size_t);
+static struct android_vnode *android_authority_initial_name (char *, size_t);
+static struct android_vnode *android_saf_root_initial (char *, size_t);
+
+/* Content provider meta-interface. This implements a vnode at
+ /content, which is a directory itself containing two additional
+ directories.
+
+ /content/storage only exists on Android 5.0 and later, and contains
+ a list of each directory tree Emacs has been granted permanent
+ access to through the Storage Access Framework.
+
+ /content/by-authority and /content/by-authority-named exists on
+ Android 4.4 and later; it contains no directories, but provides a
+ `name' function that converts children into content URIs. */
+
+static struct android_vnode *android_content_name (struct android_vnode *,
+ char *, size_t);
+static int android_content_open (struct android_vnode *, int,
+ mode_t, bool, int *, AAsset **);
+static void android_content_close (struct android_vnode *);
+static int android_content_unlink (struct android_vnode *);
+static int android_content_symlink (const char *, struct android_vnode *);
+static int android_content_rmdir (struct android_vnode *);
+static int android_content_rename (struct android_vnode *,
+ struct android_vnode *, bool);
+static int android_content_stat (struct android_vnode *, struct stat *);
+static int android_content_access (struct android_vnode *, int);
+static int android_content_mkdir (struct android_vnode *, mode_t);
+static int android_content_chmod (struct android_vnode *, mode_t, int);
+static ssize_t android_content_readlink (struct android_vnode *, char *,
+ size_t);
+static struct android_vdir *android_content_opendir (struct android_vnode *);
+
+/* Vector of VFS operations associated with the content VFS node. */
+
+static struct android_vops content_vfs_ops =
+ {
+ android_content_name,
+ android_content_open,
+ android_content_close,
+ android_content_unlink,
+ android_content_symlink,
+ android_content_rmdir,
+ android_content_rename,
+ android_content_stat,
+ android_content_access,
+ android_content_mkdir,
+ android_content_chmod,
+ android_content_readlink,
+ android_content_opendir,
+ };
+
+/* Table of directories contained within a top-level vnode. */
+
+static const char *content_directory_contents[] =
+ {
+ "storage", "by-authority", "by-authority-named",
+ };
+
+/* Chain consisting of all open content directory streams. */
+static struct android_content_vdir *all_content_vdirs;
+
+static struct android_vnode *
+android_content_name (struct android_vnode *vnode, char *name,
+ size_t length)
+{
+ char *remainder;
+ struct android_vnode *vp;
+ char *component_end;
+ struct android_special_vnode *special;
+ size_t i;
+ int api;
+
+ static struct android_special_vnode content_vnodes[] = {
+ { "storage", 7, android_saf_root_initial, },
+ { "by-authority", 12, android_authority_initial, },
+ { "by-authority-named", 18, android_authority_initial_name, },
+ };
+
+ /* Canonicalize NAME. */
+ remainder = android_vfs_canonicalize_name (name, &length);
+
+ /* If remainder is set, it's a name relative to the root vnode. */
+ if (remainder)
+ goto parent_vnode;
+
+ /* If LENGTH is empty or NAME is a single directory separator,
+ return a copy of this vnode. */
+
+ if (length < 1 || (*name == '/' && length == 1))
+ {
+ vp = xmalloc (sizeof *vp);
+ memcpy (vp, vnode, sizeof *vp);
+ return vp;
+ }
+
+ api = android_get_current_api_level ();
+
+ /* If NAME starts with a directory separator, move it past that. */
+
+ if (*name == '/')
+ name++, length -= 1;
+
+ /* Look for the first directory separator. */
+ component_end = strchr (name, '/');
+
+ /* If not there, use name + length. */
+
+ if (!component_end)
+ component_end = name + length;
+ else
+ /* Move past the separator character. */
+ component_end++;
+
+ /* Now, find out if the first component is a special vnode; if so,
+ call its root lookup function with the rest of NAME there. */
+
+ if (api < 19)
+ i = 3;
+ else if (api < 21)
+ i = 1;
+ else
+ i = 0;
+
+ for (; i < ARRAYELTS (content_vnodes); ++i)
+ {
+ special = &content_vnodes[i];
+
+ if (component_end - name == special->length
+ && !memcmp (special->name, name, special->length))
+ return (*special->initial) (component_end,
+ length - special->length);
+
+ /* Detect the case where a special is named with a trailing
+ directory separator. */
+
+ if (component_end - name == special->length + 1
+ && !memcmp (special->name, name, special->length)
+ && name[special->length] == '/')
+ /* Make sure to include the directory separator. */
+ return (*special->initial) (component_end - 1,
+ length - special->length);
+ }
+
+ errno = ENOENT;
+ return NULL;
+
+ parent_vnode:
+ /* The parent of this vnode is always the root filesystem. */
+ vp = &root_vnode.vnode;
+ return (*vnode->ops->name) (vnode, remainder, strlen (remainder));
+}
+
+static int
+android_content_open (struct android_vnode *vnode, int flags,
+ mode_t mode, bool asset_p, int *fd,
+ AAsset **asset)
+{
+ /* Don't allow opening this special directory. */
+ errno = ENOSYS;
+ return -1;
+}
+
+static void
+android_content_close (struct android_vnode *vnode)
+{
+ int save_errno;
+
+ save_errno = errno;
+ xfree (vnode);
+ errno = save_errno;
+}
+
+static int
+android_content_unlink (struct android_vnode *vnode)
+{
+ errno = ENOSYS;
+ return -1;
+}
+
+static int
+android_content_symlink (const char *target, struct android_vnode *vnode)
+{
+ errno = ENOSYS;
+ return -1;
+}
+
+static int
+android_content_rmdir (struct android_vnode *vnode)
+{
+ errno = ENOSYS;
+ return -1;
+}
+
+static int
+android_content_rename (struct android_vnode *src,
+ struct android_vnode *dst,
+ bool keep_existing)
+{
+ if (src->type != dst->type)
+ {
+ /* If the types of both vnodes differ, complain that they're on
+ two different filesystems (which is correct from a abstract
+ viewpoint.) */
+ errno = EXDEV;
+ return -1;
+ }
+
+ /* Otherwise, return ENOSYS. */
+ errno = ENOSYS;
+ return -1;
+}
+
+static int
+android_content_stat (struct android_vnode *vnode,
+ struct stat *statb)
+{
+ memset (statb, 0, sizeof *statb);
+
+ statb->st_uid = getuid ();
+ statb->st_gid = getgid ();
+ statb->st_ino = 0;
+ statb->st_dev = -2;
+ statb->st_mode = S_IFDIR | S_IRUSR | S_IXUSR;
+ return 0;
+}
+
+static int
+android_content_access (struct android_vnode *vnode, int mode)
+{
+ /* Validate MODE. */
+
+ if (mode != F_OK && !(mode & (W_OK | X_OK | R_OK)))
+ {
+ errno = EINVAL;
+ return -1;
+ }
+
+ /* Return EROFS if the caller is trying to check for write access to
+ this vnode. */
+
+ if (mode != F_OK && (mode & (W_OK | X_OK)))
+ {
+ errno = EROFS;
+ return -1;
+ }
+
+ return 0;
+}
+
+static int
+android_content_mkdir (struct android_vnode *vnode, mode_t mode)
+{
+ errno = EEXIST;
+ return -1;
+}
+
+static int
+android_content_chmod (struct android_vnode *vnode, mode_t mode,
+ int flags)
+{
+ errno = EACCES;
+ return -1;
+}
+
+static ssize_t
+android_content_readlink (struct android_vnode *vnode, char *buffer,
+ size_t size)
+{
+ errno = EINVAL;
+ return -1;
+}
+
+static struct dirent *
+android_content_readdir (struct android_vdir *vdir)
+{
+ static struct dirent dirent;
+ struct android_content_vdir *dir;
+ const char *name;
+
+ dir = (struct android_content_vdir *) vdir;
+
+ /* There are no more files to be read. */
+ if (dir->next_name == (content_directory_contents
+ + ARRAYELTS (content_directory_contents)))
+ return NULL;
+
+ /* Get the next child. */
+ name = *dir->next_name++;
+
+ /* Now, fill in the dirent with the name. */
+ memset (&dirent, 0, sizeof dirent);
+ dirent.d_ino = 0;
+ dirent.d_off = 0;
+ dirent.d_reclen = sizeof dirent;
+ dirent.d_type = DT_DIR;
+ strcpy (dirent.d_name, name);
+ return &dirent;
+}
+
+static void
+android_content_closedir (struct android_vdir *vdir)
+{
+ struct android_content_vdir *dir, **next, *tem;
+
+ dir = (struct android_content_vdir *) vdir;
+
+ /* If the ``directory file descriptor'' has been opened, close
+ it. */
+
+ if (dir->fd != -1)
+ close (dir->fd);
+
+ /* Now unlink this directory. */
+
+ for (next = &all_content_vdirs; (tem = *next);)
+ {
+ if (tem == dir)
+ *next = dir->next;
+ else
+ next = &(*next)->next;
+ }
+
+ xfree (dir);
+}
+
+static int
+android_content_dirfd (struct android_vdir *vdir)
+{
+ struct android_content_vdir *dir;
+
+ dir = (struct android_content_vdir *) vdir;
+
+ /* Since `android_content_opendir' tries to avoid opening a file
+ descriptor if readdir isn't called, dirfd can fail if open fails.
+
+ open sets errno to a set of errors different from what POSIX
+ stipulates for dirfd, but for ease of implementation the open
+ errors are used instead. */
+
+ if (dir->fd >= 0)
+ return dir->fd;
+
+ dir->fd = open ("/dev/null", O_RDONLY | O_CLOEXEC);
+ return dir->fd;
+}
+
+static struct android_vdir *
+android_content_opendir (struct android_vnode *vnode)
+{
+ struct android_content_vdir *dir;
+ int api;
+
+ /* Allocate the virtual directory. */
+ dir = xmalloc (sizeof *dir);
+ dir->vdir.readdir = android_content_readdir;
+ dir->vdir.closedir = android_content_closedir;
+ dir->vdir.dirfd = android_content_dirfd;
+ dir->fd = -1;
+
+ /* Fill in the directory contents. */
+ dir->next_name = content_directory_contents;
+ api = android_get_current_api_level ();
+
+ /* Android 4.4 and earlier don't support /content/storage. */
+
+ if (api < 21)
+ dir->next_name++;
+
+ /* Android 4.3 and earlier don't support /content/by-authority. */
+
+ if (api < 19)
+ dir->next_name++;
+
+ /* Link this stream onto the list of all content directory
+ streams. */
+ dir->next = all_content_vdirs;
+ all_content_vdirs = dir;
+ return &dir->vdir;
+}
+
+/* Return the file name corresponding to DIRFD if it is a
+ ``directory'' file descriptor returned by `android_content_dirfd'
+ or NULL otherwise. */
+
+static char *
+android_content_get_directory_name (int dirfd)
+{
+ struct android_content_vdir *dir;
+
+ for (dir = all_content_vdirs; dir; dir = dir->next)
+ {
+ if (dir->fd == dirfd && dirfd != -1)
+ return (char *) "/content";
+ }
+
+ return NULL;
+}
+
+/* Find the vnode designated by the normalized NAME relative to the
+ root of the content file system. NAME may be modified, and must be
+ LENGTH bytes long, excluding its terminating NULL byte. */
+
+static struct android_vnode *
+android_content_initial (char *name, size_t length)
+{
+ struct android_vnode temp;
+
+ /* Create a temporary vnode at the root of the asset file
+ system. */
+
+ temp.ops = &content_vfs_ops;
+ temp.type = ANDROID_VNODE_CONTENT;
+ temp.flags = 0;
+
+ /* Try to name this vnode. If NAME is empty, it will be duplicated
+ instead. */
+ return android_content_name (&temp, name, length);
+}
+
+
+
+#ifdef __clang__
+#pragma clang diagnostic push
+#pragma clang diagnostic ignored "-Wmissing-prototypes"
+#else /* GNUC */
+#pragma GCC diagnostic push
+#pragma GCC diagnostic ignored "-Wmissing-prototypes"
+#endif /* __clang__ */
+
+/* Content URI management functions. */
+
+JNIEXPORT jstring JNICALL
+NATIVE_NAME (displayNameHash) (JNIEnv *env, jobject object,
+ jbyteArray display_name)
+{
+ char checksum[9], block[MD5_DIGEST_SIZE];
+ jbyte *data;
+
+ data = (*env)->GetByteArrayElements (env, display_name, NULL);
+ if (!data)
+ return NULL;
+
+ /* Hash the buffer. */
+ md5_buffer ((char *) data, (*env)->GetArrayLength (env, display_name),
+ block);
+ (*env)->ReleaseByteArrayElements (env, display_name, data, JNI_ABORT);
+
+ /* Generate the digest string. */
+ hexbuf_digest (checksum, (char *) block, 4);
+ checksum[8] = '\0';
+ return (*env)->NewStringUTF (env, checksum);
+}
+
+#ifdef __clang__
+#pragma clang diagnostic pop
+#else /* GNUC */
+#pragma GCC diagnostic pop
+#endif /* __clang__ */
+
+/* Return the content URI corresponding to a `/content/by-authority'
+ file name, or NULL if it is invalid for some reason. FILENAME
+ should be relative to /content/by-authority, with no leading
+ directory separator character.
+
+ WITH_CHECKSUM should be true if FILENAME contains a display name and
+ a checksum for that display name. */
+
+static char *
+android_get_content_name (const char *filename, bool with_checksum)
+{
+ char *fill, *buffer;
+ size_t length;
+ char checksum[9], new_checksum[9], block[MD5_DIGEST_SIZE];
+ const char *p2, *p1;
+
+ /* Make sure FILENAME isn't obviously invalid: it must contain an
+ authority name and a file name component. */
+
+ fill = strchr (filename, '/');
+ if (!fill || *(fill + 1) == '\0')
+ {
+ errno = ENOENT;
+ return NULL;
+ }
+
+ /* FILENAME must also not be a directory. Accessing content
+ provider directories is not supported by this interface. */
+
+ length = strlen (filename);
+ if (filename[length] == '/')
+ {
+ errno = ENOTDIR;
+ return NULL;
+ }
+
+ if (!with_checksum)
+ goto no_checksum;
+
+ /* Content file names hold two components providing a display name and
+ a short checksum that protects against files being opened under
+ display names besides those provided in the content file name at
+ the time of generation. */
+
+ p1 = strrchr (filename, '/'); /* Display name. */
+ p2 = memrchr (filename, '/', p1 - filename); /* Start of checksum. */
+
+ /* If the name be excessively short or the checksum of an invalid
+ length, return. */
+ if (!p2 || (p1 - p2) != 9)
+ {
+ errno = ENOENT;
+ return NULL;
+ }
+
+ /* Copy the checksum into CHECKSUM. */
+ memcpy (checksum, p2 + 1, 8);
+ new_checksum[8] = checksum[8] = '\0';
+
+ /* Hash this string and store 8 bytes of the resulting digest into
+ new_checksum. */
+ md5_buffer (p1 + 1, strlen (p1 + 1), block);
+ hexbuf_digest (new_checksum, (char *) block, 4);
+
+ /* Compare both checksums. */
+ if (strcmp (new_checksum, checksum))
+ {
+ errno = ENOENT;
+ return NULL;
+ }
+
+ /* Remove the checksum and file display name from the URI. */
+ length = p2 - filename;
+
+ no_checksum:
+ if (length > INT_MAX)
+ {
+ errno = ENOMEM;
+ return NULL;
+ }
+
+ /* Prefix FILENAME with content:// and return the buffer containing
+ that URI. */
+ buffer = xmalloc (sizeof "content://" + length + 1);
+ sprintf (buffer, "content://%.*s", (int) length, filename);
+ return buffer;
+}
+
+/* Return whether or not the specified URI is an accessible content
+ URI. MODE specifies what to check.
+
+ URI must be a string in the JVM's extended UTF-8 format. */
+
+static bool
+android_check_content_access (const char *uri, int mode)
+{
+ jobject string;
+ jboolean rc, read, write;
+ jmethodID method;
+
+ string = (*android_java_env)->NewStringUTF (android_java_env, uri);
+ android_exception_check ();
+
+ /* Establish what is being checked. Checking for read access is
+ identical to checking if the file exists. */
+
+ read = (bool) (mode & R_OK || (mode == F_OK));
+ write = (bool) (mode & W_OK);
+ method = service_class.check_content_uri;
+
+ rc = (*android_java_env)->CallNonvirtualBooleanMethod (android_java_env,
+ emacs_service,
+ service_class.class,
+ method, string, read,
+ write);
+ android_exception_check_1 (string);
+ ANDROID_DELETE_LOCAL_REF (string);
+ return rc;
+}
+
+
+
+/* Content authority-based vnode implementation.
+
+ /content/by-authority is a simple vnode implementation that converts
+ components to content:// URIs.
+
+ It does not canonicalize file names by removing parent directory
+ separators, as these characters can appear in legitimate content
+ file names. */
+
+struct android_authority_vnode
+{
+ /* The vnode data itself. */
+ struct android_vnode vnode;
+
+ /* URI associated with this vnode, or NULL if this is the root of
+ the content authority tree. */
+ char *uri;
+};
+
+static struct android_vnode *android_authority_name (struct android_vnode *,
+ char *, size_t);
+static int android_authority_open (struct android_vnode *, int,
+ mode_t, bool, int *, AAsset **);
+static void android_authority_close (struct android_vnode *);
+static int android_authority_unlink (struct android_vnode *);
+static int android_authority_symlink (const char *, struct android_vnode *);
+static int android_authority_rmdir (struct android_vnode *);
+static int android_authority_rename (struct android_vnode *,
+ struct android_vnode *, bool);
+static int android_authority_stat (struct android_vnode *, struct stat *);
+static int android_authority_access (struct android_vnode *, int);
+static int android_authority_mkdir (struct android_vnode *, mode_t);
+static int android_authority_chmod (struct android_vnode *, mode_t, int);
+static ssize_t android_authority_readlink (struct android_vnode *, char *,
+ size_t);
+static struct android_vdir *android_authority_opendir (struct android_vnode *);
+
+/* Vector of VFS operations associated with the content VFS node. */
+
+static struct android_vops authority_vfs_ops =
+ {
+ android_authority_name,
+ android_authority_open,
+ android_authority_close,
+ android_authority_unlink,
+ android_authority_symlink,
+ android_authority_rmdir,
+ android_authority_rename,
+ android_authority_stat,
+ android_authority_access,
+ android_authority_mkdir,
+ android_authority_chmod,
+ android_authority_readlink,
+ android_authority_opendir,
+ };
+
+static struct android_vnode *
+android_authority_name (struct android_vnode *vnode, char *name,
+ size_t length)
+{
+ struct android_authority_vnode *vp;
+ char *uri_name;
+
+ if (!android_init_gui)
+ {
+ errno = EIO;
+ return NULL;
+ }
+
+ /* If NAME is empty or consists of a single directory separator
+ _and_ VP->uri is NULL, return a copy of VNODE. */
+
+ vp = (struct android_authority_vnode *) vnode;
+
+ if (length < 1 || (*name == '/' && length == 1 && !vp->uri))
+ {
+ vp = xmalloc (sizeof *vp);
+ memcpy (vp, vnode, sizeof *vp);
+
+ if (vp->uri)
+ vp->uri = xstrdup (vp->uri);
+
+ return &vp->vnode;
+ }
+
+ /* Else, if VP->uri is NULL, then it is the root of the by-authority
+ tree. If NAME starts with a directory separator character,
+ remove it. */
+
+ if (!vp->uri)
+ {
+ if (*name == '/')
+ name++, length -= 1;
+
+ /* If the provided URI is a directory, return NULL and set errno
+ to ENOTDIR. Content files are never directories. */
+
+ if (name[length - 1] == '/')
+ {
+ errno = ENOTDIR;
+ return NULL;
+ }
+
+ /* NAME must be a valid JNI string, so that it can be encoded
+ properly. */
+
+ if (android_verify_jni_string (name))
+ goto no_entry;
+
+ if (vp->vnode.type == ANDROID_VNODE_CONTENT_AUTHORITY_NAMED)
+ /* This indicates that the two trailing components of NAME
+ provide a checksum and a file display name, to be verified,
+ then excluded from the content URI. */
+ uri_name = android_get_content_name (name, true);
+ else
+ uri_name = android_get_content_name (name, false);
+
+ if (!uri_name)
+ goto error;
+
+ /* Now fill in the vnode. */
+ vp = xmalloc (sizeof *vp);
+ vp->vnode.ops = &authority_vfs_ops;
+ vp->vnode.type = ANDROID_VNODE_CONTENT_AUTHORITY;
+ vp->vnode.flags = 0;
+ vp->uri = uri_name;
+ return &vp->vnode;
+ }
+
+ /* Content files can't have children. */
+ no_entry:
+ errno = ENOENT;
+ error:
+ return NULL;
+}
+
+static int
+android_authority_open (struct android_vnode *vnode, int flags,
+ mode_t mode, bool asset_p, int *fd_return,
+ AAsset **asset)
+{
+ struct android_authority_vnode *vp;
+ size_t length;
+ jobject string;
+ int fd;
+ JNIEnv *env;
+
+ vp = (struct android_authority_vnode *) vnode;
+
+ if (vp->uri == NULL)
+ {
+ /* This is the `by-authority' directory itself, which can't be
+ opened. */
+ errno = ENOSYS;
+ return -1;
+ }
+
+ /* Save the JNI environment within `env', to make wrapping
+ subsequent lines referencing CallNonvirtualIntMethod
+ feasible. */
+ env = android_java_env;
+
+ /* Allocate a buffer to hold the file name. */
+ length = strlen (vp->uri);
+ string = (*env)->NewByteArray (env, length);
+ if (!string)
+ {
+ (*env)->ExceptionClear (env);
+ errno = ENOMEM;
+ return -1;
+ }
+
+ /* Copy the URI into this byte array. */
+ (*env)->SetByteArrayRegion (env, string, 0, length,
+ (jbyte *) vp->uri);
+
+ /* Try to open the file descriptor. */
+
+ fd = (*env)->CallNonvirtualIntMethod (env, emacs_service,
+ service_class.class,
+ service_class.open_content_uri,
+ string,
+ (jboolean) ((mode & O_WRONLY
+ || mode & O_RDWR)
+ != 0),
+ (jboolean) !(mode & O_WRONLY),
+ (jboolean) ((mode & O_TRUNC)
+ != 0));
+ if ((*env)->ExceptionCheck (env))
+ {
+ (*env)->ExceptionClear (env);
+ errno = ENOMEM;
+ ANDROID_DELETE_LOCAL_REF (string);
+ return -1;
+ }
+
+ /* If fd is -1, just assume that the file does not exist,
+ and return -1 with errno set to ENOENT. */
+
+ if (fd == -1)
+ {
+ errno = ENOENT;
+ goto skip;
+ }
+
+ if (mode & O_CLOEXEC)
+ android_close_on_exec (fd);
+
+ skip:
+ ANDROID_DELETE_LOCAL_REF (string);
+
+ if (fd == -1)
+ return -1;
+
+ *fd_return = fd;
+ return 0;
+}
+
+static void
+android_authority_close (struct android_vnode *vnode)
+{
+ struct android_authority_vnode *vp;
+ int save_errno;
+
+ vp = (struct android_authority_vnode *) vnode;
+ save_errno = errno;
+ xfree (vp->uri);
+ xfree (vp);
+ errno = save_errno;
+}
+
+static int
+android_authority_unlink (struct android_vnode *vnode)
+{
+ errno = EROFS;
+ return -1;
+}
+
+static int
+android_authority_symlink (const char *target,
+ struct android_vnode *vnode)
+{
+ errno = EROFS;
+ return -1;
+}
+
+static int
+android_authority_rmdir (struct android_vnode *vnode)
+{
+ errno = EROFS;
+ return -1;
+}
+
+static int
+android_authority_rename (struct android_vnode *src,
+ struct android_vnode *dst,
+ bool keep_existing)
+{
+ if (src->type != dst->type)
+ {
+ /* If the types of both vnodes differ, complain that they're on
+ two different filesystems (which is correct from a abstract
+ viewpoint.) */
+ errno = EXDEV;
+ return -1;
+ }
+
+ /* Otherwise, return ENOSYS. */
+ errno = ENOSYS;
+ return -1;
+}
+
+static int
+android_authority_stat (struct android_vnode *vnode,
+ struct stat *statb)
+{
+ int rc, fd, save_errno;
+ struct android_authority_vnode *vp;
+
+ /* If this is a vnode representing `by-authority', return some
+ information about this directory. */
+
+ vp = (struct android_authority_vnode *) vnode;
+
+ if (!vp->uri)
+ {
+ memset (statb, 0, sizeof *statb);
+ statb->st_uid = getuid ();
+ statb->st_gid = getgid ();
+ statb->st_ino = 0;
+ statb->st_dev = -3;
+ statb->st_mode = S_IFDIR | S_IRUSR;
+ return 0;
+ }
+
+ /* Try to open the file and call fstat. */
+ rc = (*vnode->ops->open) (vnode, O_RDONLY, 0, false, &fd, NULL);
+
+ if (rc < 0)
+ return -1;
+
+ /* If rc is 1, then an asset file descriptor has been returned.
+ This is impossible, so assert that it doesn't transpire. */
+ assert (rc != 1);
+
+ /* Now, try to stat the file. */
+ rc = fstat (fd, statb);
+ save_errno = errno;
+
+ /* Close the file descriptor. */
+ close (fd);
+
+ /* Restore errno. */
+ errno = save_errno;
+ return rc;
+}
+
+static int
+android_authority_access (struct android_vnode *vnode, int mode)
+{
+ struct android_authority_vnode *vp;
+
+ vp = (struct android_authority_vnode *) vnode;
+
+ /* Validate MODE. */
+
+ if (mode != F_OK && !(mode & (W_OK | X_OK | R_OK)))
+ {
+ errno = EINVAL;
+ return -1;
+ }
+
+ if (!vp->uri)
+ {
+ /* Return EACCES if the caller is trying to check for write
+ access to `by-authority'. */
+
+ if (mode != F_OK && (mode & (W_OK | X_OK)))
+ {
+ errno = EACCES;
+ return -1;
+ }
+
+ return 0;
+ }
+
+ return (android_check_content_access (vp->uri, mode)
+ ? 0 : -1);
+}
+
+static int
+android_authority_mkdir (struct android_vnode *vnode, mode_t mode)
+{
+ errno = EACCES;
+ return -1;
+}
+
+static int
+android_authority_chmod (struct android_vnode *vnode, mode_t mode,
+ int flags)
+{
+ errno = EACCES;
+ return -1;
+}
+
+static ssize_t
+android_authority_readlink (struct android_vnode *vnode, char *buffer,
+ size_t size)
+{
+ errno = EINVAL;
+ return -1;
+}
+
+static struct android_vdir *
+android_authority_opendir (struct android_vnode *vnode)
+{
+ struct android_authority_vnode *vp;
+
+ /* Forbid listing the `by-authority' directory. */
+ vp = (struct android_authority_vnode *) vnode;
+ errno = vp->uri ? ENOTDIR : EACCES;
+ return NULL;
+}
+
+/* Find the vnode designated by NAME relative to the root of the
+ by-authority directory.
+
+ If NAME is empty or a single leading separator character, return
+ a vnode representing the by-authority directory itself.
+
+ Otherwise, represent the remainder of NAME as a URI (without
+ normalizing it) and return a vnode corresponding to that.
+
+ Value may also be NULL with errno set if the designated vnode is
+ not available, such as when Android windowing has not been
+ initialized. */
+
+static struct android_vnode *
+android_authority_initial (char *name, size_t length)
+{
+ struct android_authority_vnode temp;
+
+ temp.vnode.ops = &authority_vfs_ops;
+ temp.vnode.type = ANDROID_VNODE_CONTENT_AUTHORITY;
+ temp.vnode.flags = 0;
+ temp.uri = NULL;
+
+ return android_authority_name (&temp.vnode, name, length);
+}
+
+/* Find the vnode designated by NAME relative to the root of the
+ by-authority-named directory.
+
+ If NAME is empty or a single leading separator character, return
+ a vnode representing the by-authority directory itself.
+
+ Otherwise, represent the remainder of NAME as a URI (without
+ normalizing it) and return a vnode corresponding to that.
+
+ Value may also be NULL with errno set if the designated vnode is
+ not available, such as when Android windowing has not been
+ initialized. */
+
+static struct android_vnode *
+android_authority_initial_name (char *name, size_t length)
+{
+ struct android_authority_vnode temp;
+
+ temp.vnode.ops = &authority_vfs_ops;
+ temp.vnode.type = ANDROID_VNODE_CONTENT_AUTHORITY_NAMED;
+ temp.vnode.flags = 0;
+ temp.uri = NULL;
+
+ return android_authority_name (&temp.vnode, name, length);
+}
+
+
+
+/* SAF ``root'' vnode implementation.
+
+ The Storage Access Framework is a system service that manages a
+ registry of document providers, which are a type of file system
+ server.
+
+ Normally, document providers can only provide individual files
+ through preestablished ``content URIs''. Android 5.0 and later add
+ to that ``tree URIs'', which designate entire file system trees.
+
+ Authorization to access document trees and content URIs is granted
+ transiently by default when an Intent is received, but Emacs can
+ also receive persistent authorization for a given document tree.
+
+ /content/storage returns a list of directories, each representing a
+ single authority providing at least one tree URI Emacs holds
+ persistent authorization for.
+
+ Each one of those directories then contains one document tree that
+ Emacs is authorized to access. */
+
+struct android_saf_root_vnode
+{
+ /* The vnode data. */
+ struct android_vnode vnode;
+
+ /* The name of the document authority this directory represents, or
+ NULL. */
+ char *authority;
+};
+
+struct android_saf_root_vdir
+{
+ /* The directory stream function table. */
+ struct android_vdir vdir;
+
+ /* The next directory stream in `all_saf_root_vdirs'. */
+ struct android_saf_root_vdir *next;
+
+ /* Array of strings, one for each directory to return. */
+ jobjectArray array;
+
+ /* Name of the authority this directory lists, or NULL. */
+ char *authority;
+
+ /* Length of that array, and the current within it. */
+ jsize length, i;
+
+ /* ``Directory'' file descriptor associated with this stream, or
+ -1. */
+ int fd;
+};
+
+static struct android_vnode *android_saf_root_name (struct android_vnode *,
+ char *, size_t);
+static int android_saf_root_open (struct android_vnode *, int,
+ mode_t, bool, int *, AAsset **);
+static void android_saf_root_close (struct android_vnode *);
+static int android_saf_root_unlink (struct android_vnode *);
+static int android_saf_root_symlink (const char *, struct android_vnode *);
+static int android_saf_root_rmdir (struct android_vnode *);
+static int android_saf_root_rename (struct android_vnode *,
+ struct android_vnode *, bool);
+static int android_saf_root_stat (struct android_vnode *, struct stat *);
+static int android_saf_root_access (struct android_vnode *, int);
+static int android_saf_root_mkdir (struct android_vnode *, mode_t);
+static int android_saf_root_chmod (struct android_vnode *, mode_t, int);
+static ssize_t android_saf_root_readlink (struct android_vnode *, char *,
+ size_t);
+static struct android_vdir *android_saf_root_opendir (struct android_vnode *);
+
+/* Vector of VFS operations associated with the SAF root VFS node. */
+
+static struct android_vops saf_root_vfs_ops =
+ {
+ android_saf_root_name,
+ android_saf_root_open,
+ android_saf_root_close,
+ android_saf_root_unlink,
+ android_saf_root_symlink,
+ android_saf_root_rmdir,
+ android_saf_root_rename,
+ android_saf_root_stat,
+ android_saf_root_access,
+ android_saf_root_mkdir,
+ android_saf_root_chmod,
+ android_saf_root_readlink,
+ android_saf_root_opendir,
+ };
+
+/* Chain containing all SAF root directories. */
+static struct android_saf_root_vdir *all_saf_root_vdirs;
+
+/* Defined in the next page. */
+static struct android_vnode *android_saf_tree_from_name (char *, const char *,
+ const char *);
+
+/* Ascertain and return whether or not AUTHORITY designates a content
+ provider offering at least one directory tree accessible to
+ Emacs. */
+
+static bool
+android_saf_valid_authority_p (const char *authority)
+{
+ jobject string;
+ jboolean valid;
+ jmethodID method;
+
+ /* Make certain AUTHORITY can actually be represented as a Java
+ string. */
+
+ if (android_verify_jni_string (authority))
+ return false;
+
+ /* Build a string containing AUTHORITY. */
+
+ string = (*android_java_env)->NewStringUTF (android_java_env,
+ authority);
+ android_exception_check ();
+
+ method = service_class.valid_authority;
+ valid
+ = (*android_java_env)->CallNonvirtualBooleanMethod (android_java_env,
+ emacs_service,
+ service_class.class,
+ method, string);
+ android_exception_check_1 (string);
+ ANDROID_DELETE_LOCAL_REF (string);
+ return valid;
+}
+
+static struct android_vnode *
+android_saf_root_name (struct android_vnode *vnode, char *name,
+ size_t length)
+{
+ char *remainder, *component_end;
+ struct android_saf_root_vnode *vp;
+ struct android_vnode *new;
+ char component[PATH_MAX];
+
+ /* Canonicalize NAME. */
+ remainder = android_vfs_canonicalize_name (name, &length);
+
+ /* If remainder is set, it's a name relative to the root vnode. */
+ if (remainder)
+ goto parent_vnode;
+
+ /* If LENGTH is empty or NAME is a single directory separator,
+ return a copy of this vnode. */
+
+ if (length < 1 || (*name == '/' && length == 1))
+ {
+ vp = xmalloc (sizeof *vp);
+ memcpy (vp, vnode, sizeof *vp);
+
+ if (vp->authority)
+ vp->authority = xstrdup (vp->authority);
+
+ return &vp->vnode;
+ }
+
+ vp = (struct android_saf_root_vnode *) vnode;
+
+ /* If NAME starts with a directory separator, move it past that. */
+
+ if (*name == '/')
+ name++, length -= 1;
+
+ /* Look for the first directory separator. */
+ component_end = strchr (name, '/');
+
+ /* If not there, use name + length. */
+
+ if (!component_end)
+ component_end = name + length;
+
+ if (component_end - name >= PATH_MAX)
+ {
+ errno = ENAMETOOLONG;
+ return NULL;
+ }
+
+ /* Copy the component over. */
+ memcpy (component, name, component_end - name);
+ component[component_end - name] = '\0';
+
+ /* Create a SAF document vnode for this tree if it represents an
+ authority. */
+
+ if (vp->authority)
+ return android_saf_tree_from_name (component_end, component,
+ vp->authority);
+
+ /* Create the vnode. */
+ vp = xmalloc (sizeof *vp);
+ vp->vnode.ops = &saf_root_vfs_ops;
+ vp->vnode.type = ANDROID_VNODE_SAF_ROOT;
+ vp->vnode.flags = 0;
+ vp->authority = xstrdup (component);
+
+ /* If there is more of this component to be named, name it through
+ the new vnode. */
+
+ if (component_end != name + length)
+ {
+ new = (*vp->vnode.ops->name) (&vp->vnode, component_end,
+ length - (component_end - name));
+ (*vp->vnode.ops->close) (&vp->vnode);
+
+ return new;
+ }
+
+ return &vp->vnode;
+
+ parent_vnode:
+ vp = (struct android_saf_root_vnode *) vnode;
+
+ /* .. was encountered and the parent couldn't be found through
+ stripping off preceding components.
+
+ Find the parent vnode and name the rest of NAME starting from
+ there. */
+
+ if (!vp->authority)
+ /* Look this file name up relative to the root of the contents
+ directory. */
+ return android_content_initial (remainder, strlen (remainder));
+ else
+ /* Look this file name up relative to the root of the storage
+ directory. */
+ return android_saf_root_initial (remainder, strlen (remainder));
+}
+
+static int
+android_saf_root_open (struct android_vnode *vnode, int flags,
+ mode_t mode, bool asset_p, int *fd_return,
+ AAsset **asset)
+{
+ /* /content/storage or one of its authority children cannot be
+ opened, as they are virtual directories. */
+
+ errno = ENOSYS;
+ return -1;
+}
+
+static void
+android_saf_root_close (struct android_vnode *vnode)
+{
+ struct android_saf_root_vnode *vp;
+ int save_errno;
+
+ vp = (struct android_saf_root_vnode *) vnode;
+ save_errno = errno;
+ xfree (vp->authority);
+ xfree (vp);
+ errno = save_errno;
+}
+
+static int
+android_saf_root_unlink (struct android_vnode *vnode)
+{
+ errno = EROFS;
+ return -1;
+}
+
+static int
+android_saf_root_symlink (const char *target,
+ struct android_vnode *vnode)
+{
+ errno = EROFS;
+ return -1;
+}
+
+static int
+android_saf_root_rmdir (struct android_vnode *vnode)
+{
+ errno = EROFS;
+ return -1;
+}
+
+static int
+android_saf_root_rename (struct android_vnode *src,
+ struct android_vnode *dst,
+ bool keep_existing)
+{
+ errno = EROFS;
+ return -1;
+}
+
+static int
+android_saf_root_stat (struct android_vnode *vnode,
+ struct stat *statb)
+{
+ struct android_saf_root_vnode *vp;
+
+ /* Verify that the authority actually exists and return ENOENT
+ otherwise, lest `locate-dominating-file' & co call an operation
+ that doesn't require listing URIs under this authority, such as
+ access. */
+
+ vp = (struct android_saf_root_vnode *) vnode;
+
+ if (vp->authority
+ && !android_saf_valid_authority_p (vp->authority))
+ {
+ errno = ENOENT;
+ return -1;
+ }
+
+ /* Make up some imaginary statistics for this vnode. */
+
+ memset (statb, 0, sizeof *statb);
+ statb->st_uid = getuid ();
+ statb->st_gid = getgid ();
+ statb->st_ino = 0;
+ statb->st_dev = -4;
+ statb->st_mode = S_IFDIR | S_IRUSR | S_IXUSR;
+ return 0;
+}
+
+static int
+android_saf_root_access (struct android_vnode *vnode, int mode)
+{
+ struct android_saf_root_vnode *vp;
+
+ /* Validate MODE. */
+
+ if (mode != F_OK && !(mode & (W_OK | X_OK | R_OK)))
+ {
+ errno = EINVAL;
+ return -1;
+ }
+
+ /* Now, don't allow writing or executing this directory. */
+
+ if (mode != F_OK && (mode & (W_OK | X_OK)))
+ {
+ errno = EROFS;
+ return -1;
+ }
+
+ /* Verify that the authority actually exists and return ENOENT
+ otherwise, lest `locate-dominating-file' & co call an operation
+ that doesn't require listing URIs under this authority, such as
+ access. */
+
+ vp = (struct android_saf_root_vnode *) vnode;
+
+ if (vp->authority
+ && !android_saf_valid_authority_p (vp->authority))
+ {
+ errno = ENOENT;
+ return -1;
+ }
+
+ return 0;
+}
+
+static int
+android_saf_root_mkdir (struct android_vnode *vnode, mode_t mode)
+{
+ errno = EROFS;
+ return -1;
+}
+
+static int
+android_saf_root_chmod (struct android_vnode *vnode, mode_t mode,
+ int flags)
+{
+ errno = EACCES;
+ return -1;
+}
+
+static ssize_t
+android_saf_root_readlink (struct android_vnode *vnode, char *buffer,
+ size_t size)
+{
+ errno = EINVAL;
+ return -1;
+}
+
+static struct dirent *
+android_saf_root_readdir (struct android_vdir *vdir)
+{
+ static struct dirent *dirent;
+ jobject string;
+ const char *chars;
+ size_t length, size;
+ struct android_saf_root_vdir *dir;
+
+ dir = (struct android_saf_root_vdir *) vdir;
+
+ if (dir->i == dir->length)
+ {
+ /* At the end of the stream. Free dirent and return NULL. */
+
+ xfree (dirent);
+ dirent = NULL;
+ return NULL;
+ }
+
+ /* Get this string. */
+ string = (*android_java_env)->GetObjectArrayElement (android_java_env,
+ dir->array, dir->i++);
+ android_exception_check ();
+ chars = (*android_java_env)->GetStringUTFChars (android_java_env,
+ (jstring) string,
+ NULL);
+ android_exception_check_nonnull ((void *) chars, string);
+
+ /* Figure out how large it is, and then resize dirent to fit--this
+ string is always ASCII. */
+ length = strlen (chars) + 1;
+ size = offsetof (struct dirent, d_name) + length;
+ dirent = xrealloc (dirent, size);
+
+ /* Clear dirent. */
+ memset (dirent, 0, size);
+
+ /* Fill in the generic directory information and copy the string
+ over. */
+ dirent->d_ino = 0;
+ dirent->d_off = 0;
+ dirent->d_reclen = size;
+ dirent->d_type = DT_DIR;
+ strcpy (dirent->d_name, chars);
+
+ /* Release the string data and the local reference to STRING. */
+ (*android_java_env)->ReleaseStringUTFChars (android_java_env,
+ (jstring) string, chars);
+ ANDROID_DELETE_LOCAL_REF (string);
+ return dirent;
+}
+
+static void
+android_saf_root_closedir (struct android_vdir *vdir)
+{
+ struct android_saf_root_vdir *dir, **next, *tem;
+
+ dir = (struct android_saf_root_vdir *) vdir;
+
+ /* If the ``directory file descriptor'' has been opened, close
+ it. */
+
+ if (dir->fd != -1)
+ close (dir->fd);
+
+ /* Delete the local reference to the file name array. */
+ ANDROID_DELETE_LOCAL_REF (dir->array);
+
+ /* Free the authority name if set. */
+ xfree (dir->authority);
+
+ /* Now unlink this directory. */
+
+ for (next = &all_saf_root_vdirs; (tem = *next);)
+ {
+ if (tem == dir)
+ *next = dir->next;
+ else
+ next = &(*next)->next;
+ }
+
+ /* Free the directory itself. */
+ xfree (dir);
+}
+
+static int
+android_saf_root_dirfd (struct android_vdir *vdir)
+{
+ struct android_saf_root_vdir *dir;
+
+ dir = (struct android_saf_root_vdir *) vdir;
+
+ /* Since `android_saf_root_opendir' tries to avoid opening a file
+ descriptor if readdir isn't called, dirfd can fail if open fails.
+
+ open sets errno to a set of errors different from what POSIX
+ stipulates for dirfd, but for ease of implementation the open
+ errors are used instead. */
+
+ if (dir->fd >= 0)
+ return dir->fd;
+
+ dir->fd = open ("/dev/null", O_RDONLY | O_CLOEXEC);
+ return dir->fd;
+}
+
+static struct android_vdir *
+android_saf_root_opendir (struct android_vnode *vnode)
+{
+ struct android_saf_root_vnode *vp;
+ jobjectArray array;
+ jmethodID method;
+ jbyteArray authority;
+ struct android_saf_root_vdir *dir;
+ size_t length;
+
+ vp = (struct android_saf_root_vnode *) vnode;
+
+ if (vp->authority)
+ {
+ /* Build a string containing the authority. */
+ length = strlen (vp->authority);
+ authority = (*android_java_env)->NewByteArray (android_java_env,
+ length);
+ android_exception_check ();
+
+ /* Copy the authority name to that byte array. */
+ (*android_java_env)->SetByteArrayRegion (android_java_env,
+ authority, 0, length,
+ (jbyte *) vp->authority);
+
+ /* Acquire a list of every tree provided by this authority. */
+
+ method = service_class.get_document_trees;
+ array
+ = (*android_java_env)->CallNonvirtualObjectMethod (android_java_env,
+ emacs_service,
+ service_class.class,
+ method, authority);
+ android_exception_check_1 (authority);
+ ANDROID_DELETE_LOCAL_REF (authority);
+
+ /* Ascertain the length of the array. If it is empty or NULL,
+ return ENOENT. */
+
+ if (!array)
+ {
+ errno = ENOENT;
+ return NULL;
+ }
+
+ length = (*android_java_env)->GetArrayLength (android_java_env, array);
+
+ if (!length)
+ {
+ ANDROID_DELETE_LOCAL_REF (array);
+ errno = ENOENT;
+ return NULL;
+ }
+
+ /* Now allocate the directory stream. It will retain a local
+ reference to the array, and should thus only be used within the
+ same JNI local reference frame. */
+
+ dir = xmalloc (sizeof *dir);
+ dir->vdir.readdir = android_saf_root_readdir;
+ dir->vdir.closedir = android_saf_root_closedir;
+ dir->vdir.dirfd = android_saf_root_dirfd;
+ dir->fd = -1;
+ dir->array = array;
+ dir->length = length;
+ dir->i = 0;
+ dir->authority = xstrdup (vp->authority);
+
+ /* Link this stream onto the list of all SAF root directory
+ streams. */
+ dir->next = all_saf_root_vdirs;
+ all_saf_root_vdirs = dir;
+ return &dir->vdir;
+ }
+
+ /* Acquire a list of every document authority. */
+
+ method = service_class.get_document_authorities;
+ array = (*android_java_env)->CallNonvirtualObjectMethod (android_java_env,
+ emacs_service,
+ service_class.class,
+ method);
+ android_exception_check ();
+
+ if (!array)
+ emacs_abort ();
+
+ /* Now allocate the directory stream. It will retain a local
+ reference to the array, and should thus only be used within the
+ same JNI local reference frame. */
+
+ dir = xmalloc (sizeof *dir);
+ dir->vdir.readdir = android_saf_root_readdir;
+ dir->vdir.closedir = android_saf_root_closedir;
+ dir->vdir.dirfd = android_saf_root_dirfd;
+ dir->fd = -1;
+ dir->array = array;
+ dir->length = (*android_java_env)->GetArrayLength (android_java_env,
+ array);
+ dir->i = 0;
+ dir->authority = NULL;
+
+ /* Link this stream onto the list of all SAF root directory
+ streams. */
+ dir->next = all_saf_root_vdirs;
+ all_saf_root_vdirs = dir;
+ return &dir->vdir;
+}
+
+/* Find the vnode designated by NAME relative to the root of the
+ storage directory.
+
+ If NAME is empty or a single leading separator character, return a
+ vnode representing the storage directory itself.
+
+ If NAME actually resides in a parent directory, look for it within
+ the vnode representing the content directory. */
+
+static struct android_vnode *
+android_saf_root_initial (char *name, size_t length)
+{
+ struct android_saf_root_vnode temp;
+
+ temp.vnode.ops = &saf_root_vfs_ops;
+ temp.vnode.type = ANDROID_VNODE_SAF_ROOT;
+ temp.vnode.flags = 0;
+ temp.authority = NULL;
+
+ return android_saf_root_name (&temp.vnode, name, length);
+}
+
+/* Return any open SAF root directory stream for which dirfd has
+ returned the file descriptor DIRFD. Return NULL otherwise. */
+
+static struct android_saf_root_vdir *
+android_saf_root_get_directory (int dirfd)
+{
+ struct android_saf_root_vdir *dir;
+
+ for (dir = all_saf_root_vdirs; dir; dir = dir->next)
+ {
+ if (dir->fd == dirfd && dirfd != -1)
+ return dir;
+ }
+
+ return NULL;
+}
+
+
+
+/* Functions common to both SAF directory and file nodes. */
+
+/* Whether or not Emacs is within an operation running from the SAF
+ thread. */
+static bool inside_saf_critical_section;
+
+/* Check for JNI exceptions, clear them, and set errno accordingly.
+ Also, free each of the N local references given as arguments if an
+ exception takes place.
+
+ Value is 1 if an exception has taken place, 0 otherwise.
+
+ If the exception thrown derives from FileNotFoundException, set
+ errno to ENOENT.
+
+ If the exception thrown derives from SecurityException, set errno
+ to EACCES.
+
+ If the exception thrown derives from OperationCanceledException,
+ set errno to EINTR.
+
+ If the exception thrown derives from UnsupportedOperationException,
+ set errno to ENOSYS.
+
+ If the exception thrown derives from OutOfMemoryException, call
+ `memory_full'.
+
+ If the exception thrown is anything else, set errno to EIO. */
+
+static int
+android_saf_exception_check (int n, ...)
+{
+ jthrowable exception;
+ JNIEnv *env;
+ va_list ap;
+ int new_errno;
+
+ env = android_java_env;
+ va_start (ap, n);
+
+ /* First, check for an exception. */
+
+ if (!(*env)->ExceptionCheck (env))
+ {
+ /* No exception has taken place. Return 0. */
+ va_end (ap);
+ return 0;
+ }
+
+ /* Print the exception. */
+ (*env)->ExceptionDescribe (env);
+
+ exception = (*env)->ExceptionOccurred (env);
+
+ if (!exception)
+ /* JNI couldn't return a local reference to the exception. */
+ memory_full (0);
+
+ /* Clear the exception, making it safe to subsequently call other
+ JNI functions. */
+ (*env)->ExceptionClear (env);
+
+ /* Delete each of the N arguments. */
+
+ while (n > 0)
+ {
+ ANDROID_DELETE_LOCAL_REF (va_arg (ap, jobject));
+ n--;
+ }
+
+ /* Now set errno or signal memory_full as required. */
+
+ if ((*env)->IsInstanceOf (env, (jobject) exception,
+ file_not_found_exception))
+ new_errno = ENOENT;
+ else if ((*env)->IsInstanceOf (env, (jobject) exception,
+ security_exception))
+ new_errno = EACCES;
+ else if ((*env)->IsInstanceOf (env, (jobject) exception,
+ operation_canceled_exception))
+ new_errno = EINTR;
+ else if ((*env)->IsInstanceOf (env, (jobject) exception,
+ unsupported_operation_exception))
+ new_errno = ENOSYS;
+ else if ((*env)->IsInstanceOf (env, (jobject) exception,
+ out_of_memory_error))
+ {
+ ANDROID_DELETE_LOCAL_REF ((jobject) exception);
+ memory_full (0);
+ }
+ else
+ new_errno = EIO;
+
+ /* expression is still a local reference! */
+ ANDROID_DELETE_LOCAL_REF ((jobject) exception);
+ errno = new_errno;
+ va_end (ap);
+ return 1;
+}
+
+/* Return file status for the document designated by ID_NAME within
+ the document tree identified by URI_NAME.
+
+ If NO_CACHE, don't cache the resulting file status. Enable this
+ option if the file status is subject to imminent change.
+
+ If the file status is available, place it within *STATB and return
+ 0. If not, return -1 and set errno to EPERM. */
+
+static int
+android_saf_stat (const char *uri_name, const char *id_name,
+ struct stat *statb, bool no_cache)
+{
+ jmethodID method;
+ jstring uri, id;
+ jobject status;
+ jlong mode, size, mtim, *longs;
+
+ /* Now guarantee that it is safe to call functions which
+ synchronize with the SAF thread. */
+
+ if (inside_saf_critical_section)
+ {
+ errno = EIO;
+ return -1;
+ }
+
+ /* Build strings for both URI and ID. */
+ uri = (*android_java_env)->NewStringUTF (android_java_env, uri_name);
+ android_exception_check ();
+
+ if (id_name)
+ {
+ id = (*android_java_env)->NewStringUTF (android_java_env,
+ id_name);
+ android_exception_check_1 (uri);
+ }
+ else
+ id = NULL;
+
+ /* Try to retrieve the file status. */
+ method = service_class.stat_document;
+ inside_saf_critical_section = true;
+ status
+ = (*android_java_env)->CallNonvirtualObjectMethod (android_java_env,
+ emacs_service,
+ service_class.class,
+ method, uri, id,
+ (jboolean) no_cache);
+ inside_saf_critical_section = false;
+
+ /* Check for exceptions and release unneeded local references. */
+
+ if (id)
+ {
+ if (android_saf_exception_check (2, uri, id))
+ return -1;
+
+ ANDROID_DELETE_LOCAL_REF (id);
+ }
+ else if (android_saf_exception_check (1, uri))
+ return -1;
+
+ ANDROID_DELETE_LOCAL_REF (uri);
+
+ /* Check for failure. */
+
+ if (!status)
+ {
+ errno = EPERM;
+ return -1;
+ }
+
+ /* Read the file status from the array returned. */
+
+ longs = (*android_java_env)->GetLongArrayElements (android_java_env,
+ status, NULL);
+ android_exception_check_nonnull (longs, status);
+ mode = longs[0];
+ size = longs[1];
+ mtim = longs[2];
+ (*android_java_env)->ReleaseLongArrayElements (android_java_env, status,
+ longs, JNI_ABORT);
+ ANDROID_DELETE_LOCAL_REF (status);
+
+ /* Fill in STATB with this information. */
+ memset (statb, 0, sizeof *statb);
+ statb->st_size = MAX (0, MIN (TYPE_MAXIMUM (off_t), size));
+ statb->st_mode = mode;
+ statb->st_dev = -4;
+#ifdef STAT_TIMESPEC
+ STAT_TIMESPEC (statb, st_mtim).tv_sec = mtim / 1000;
+ STAT_TIMESPEC (statb, st_mtim).tv_nsec = (mtim % 1000) * 1000000;
+#else /* !STAT_TIMESPEC */
+ /* Headers supplied by the NDK r10b contain a `struct stat' without
+ POSIX fields for nano-second timestamps. */
+ statb->st_mtime = mtim / 1000;
+ statb->st_mtime_nsec = (mtim % 1000) * 1000000;
+#endif /* STAT_TIMESPEC */
+ statb->st_uid = getuid ();
+ statb->st_gid = getgid ();
+ return 0;
+}
+
+/* Detect if Emacs has access to the document designated by the the
+ document ID ID_NAME within the tree URI_NAME. If ID_NAME is NULL,
+ use the document ID in URI_NAME itself.
+
+ If WRITABLE, also check that the file is writable, which is true
+ if it is either a directory or its flags contains
+ FLAG_SUPPORTS_WRITE.
+
+ Value is 0 if the file is accessible, and -1 with errno set
+ appropriately if not. */
+
+static int
+android_saf_access (const char *uri_name, const char *id_name,
+ bool writable)
+{
+ jmethodID method;
+ jstring uri, id;
+ jint rc;
+
+ /* Now guarantee that it is safe to call functions which
+ synchronize with the SAF thread. */
+
+ if (inside_saf_critical_section)
+ {
+ errno = EIO;
+ return -1;
+ }
+
+ /* Build strings for both URI and ID. */
+ uri = (*android_java_env)->NewStringUTF (android_java_env, uri_name);
+ android_exception_check ();
+
+ if (id_name)
+ {
+ id = (*android_java_env)->NewStringUTF (android_java_env,
+ id_name);
+ android_exception_check_1 (uri);
+ }
+ else
+ id = NULL;
+
+ /* Try to retrieve the file status. */
+ method = service_class.access_document;
+ inside_saf_critical_section = true;
+ rc = (*android_java_env)->CallNonvirtualIntMethod (android_java_env,
+ emacs_service,
+ service_class.class,
+ method, uri, id,
+ (jboolean) writable);
+ inside_saf_critical_section = false;
+
+ /* Check for exceptions and release unneeded local references. */
+
+ if (id)
+ {
+ if (android_saf_exception_check (2, uri, id))
+ return -1;
+
+ ANDROID_DELETE_LOCAL_REF (id);
+ }
+ else if (android_saf_exception_check (1, uri))
+ return -1;
+
+ ANDROID_DELETE_LOCAL_REF (uri);
+
+ switch (rc)
+ {
+ case -1:
+ /* -1 means it doesn't exist. */
+ errno = ENOENT;
+ return -1;
+
+ case -2:
+ /* -2 means access has been denied. */
+ errno = EACCES;
+ return -1;
+
+ case -3:
+ /* -3 refers to an internal error. */
+ errno = EIO;
+ return -1;
+ }
+
+ /* Return success. */
+ return 0;
+}
+
+/* Delete the document designated by DOC_ID within the tree identified
+ through the URI TREE. Return 0 if the document has been deleted,
+ set errno and return -1 upon failure.
+
+ DOC_NAME should be the name of the file itself, as a file name
+ whose constituent components lead to a document named DOC_ID. It
+ isn't used to search for a document ID, but is used to invalidate
+ the file cache. */
+
+static int
+android_saf_delete_document (const char *tree, const char *doc_id,
+ const char *doc_name)
+{
+ jobject id, uri, name;
+ jmethodID method;
+ jint rc;
+
+ /* Build the strings holding the ID, URI and NAME. */
+ id = (*android_java_env)->NewStringUTF (android_java_env,
+ doc_id);
+ android_exception_check ();
+ uri = (*android_java_env)->NewStringUTF (android_java_env,
+ tree);
+ android_exception_check_1 (id);
+ name = (*android_java_env)->NewStringUTF (android_java_env,
+ doc_name);
+ android_exception_check_2 (id, name);
+
+ /* Now, try to delete the document. */
+ method = service_class.delete_document;
+ rc = (*android_java_env)->CallNonvirtualIntMethod (android_java_env,
+ emacs_service,
+ service_class.class,
+ method, uri, id,
+ name);
+
+ if (android_saf_exception_check (3, id, uri, name))
+ return -1;
+
+ ANDROID_DELETE_LOCAL_REF (id);
+ ANDROID_DELETE_LOCAL_REF (uri);
+ ANDROID_DELETE_LOCAL_REF (name);
+
+ if (rc)
+ {
+ errno = EACCES;
+ return -1;
+ }
+
+ return 0;
+}
+
+/* Declared further below. */
+static int android_document_id_from_name (const char *, const char *,
+ char **);
+
+/* Rename the document designated by DOC_ID inside the directory tree
+ identified by URI, which should be within the directory by the name
+ of DIR, to NAME. If the document can't be renamed, return -1 and
+ set errno to a value describing the error. Return 0 if the rename
+ is successful.
+
+ Android permits the same document to appear in multiple
+ directories, but stores the display name inside the document
+ ``inode'' itself instead of the directory entries that refer to it.
+ Because of this, this operation may cause other directory entries
+ outside DIR to be renamed. */
+
+static int
+android_saf_rename_document (const char *uri, const char *doc_id,
+ const char *dir, const char *name)
+{
+ int rc;
+ jstring uri1, doc_id1, dir1, name1;
+ jmethodID method;
+
+ /* Now build the strings for the URI, document ID, directory name
+ and directory ID. */
+
+ uri1 = (*android_java_env)->NewStringUTF (android_java_env, uri);
+ android_exception_check ();
+ doc_id1 = (*android_java_env)->NewStringUTF (android_java_env, doc_id);
+ android_exception_check_1 (uri1);
+ dir1 = (*android_java_env)->NewStringUTF (android_java_env, dir);
+ android_exception_check_2 (doc_id1, uri1);
+ name1 = (*android_java_env)->NewStringUTF (android_java_env, name);
+ android_exception_check_3 (dir1, doc_id1, uri1);
+
+ method = service_class.rename_document;
+ rc = (*android_java_env)->CallNonvirtualIntMethod (android_java_env,
+ emacs_service,
+ service_class.class,
+ method, uri1, doc_id1,
+ dir1, name1);
+
+ /* Check for exceptions. */
+
+ if (android_saf_exception_check (4, uri1, doc_id1, dir1, name1))
+ {
+ /* Substitute EXDEV for ENOSYS, so callers fall back on
+ delete-then-copy. */
+
+ if (errno == ENOSYS)
+ errno = EXDEV;
+
+ return -1;
+ }
+
+ /* Delete unused local references. */
+ ANDROID_DELETE_LOCAL_REF (uri1);
+ ANDROID_DELETE_LOCAL_REF (doc_id1);
+ ANDROID_DELETE_LOCAL_REF (dir1);
+ ANDROID_DELETE_LOCAL_REF (name1);
+
+ /* Then check for errors handled within the Java code. */
+
+ if (rc == -1)
+ {
+ /* UnsupportedOperationException. Trick the caller into falling
+ back on delete-then-copy code. */
+ errno = EXDEV;
+ return -1;
+ }
+
+ return 0;
+}
+
+/* Move the document designated by *DOC_ID from the directory under
+ DIR_NAME to the directory designated by DST_ID. All three
+ directories are located within the tree identified by the given
+ URI.
+
+ If the document's ID changes as a result of the movement, free
+ *DOC_ID and store the new document ID within.
+
+ Value is 0 upon success, -1 otherwise with errno set. */
+
+static int
+android_saf_move_document (const char *uri, char **doc_id,
+ const char *dir_name, const char *dst_id)
+{
+ char *src_id, *id;
+ jobject uri1, doc_id1, dir_name1, dst_id1, src_id1;
+ jstring result;
+ jmethodID method;
+ int rc;
+ const char *new_id;
+
+ /* Obtain the name of the source directory. */
+ src_id = NULL;
+ rc = android_document_id_from_name (uri, dir_name, &src_id);
+
+ if (rc != 1)
+ {
+ /* This file is either not a directory or nonexistent. */
+ xfree (src_id);
+
+ switch (rc)
+ {
+ case 0:
+ errno = ENOTDIR;
+ return -1;
+
+ case -1:
+ case -2:
+ errno = ENOENT;
+ return -1;
+
+ default:
+ emacs_abort ();
+ }
+ }
+
+ /* Build Java strings for all five arguments. */
+ id = *doc_id;
+ uri1 = (*android_java_env)->NewStringUTF (android_java_env, uri);
+ android_exception_check ();
+ doc_id1 = (*android_java_env)->NewStringUTF (android_java_env, id);
+ android_exception_check_1 (uri1);
+ dir_name1 = (*android_java_env)->NewStringUTF (android_java_env, dir_name);
+ android_exception_check_2 (doc_id1, uri1);
+ dst_id1 = (*android_java_env)->NewStringUTF (android_java_env, dst_id);
+ android_exception_check_3 (dir_name1, doc_id1, uri1);
+ src_id1 = (*android_java_env)->NewStringUTF (android_java_env, src_id);
+ xfree (src_id);
+ android_exception_check_4 (dst_id1, dir_name1, doc_id1, uri1);
+
+ /* Do the rename. */
+ method = service_class.move_document;
+ result
+ = (*android_java_env)->CallNonvirtualObjectMethod (android_java_env,
+ emacs_service,
+ service_class.class,
+ method, uri1,
+ doc_id1, dir_name1,
+ dst_id1, src_id1);
+ if (android_saf_exception_check (5, src_id1, dst_id1, dir_name1,
+ doc_id1, uri1))
+ {
+ /* Substitute EXDEV for ENOSYS, so callers fall back on
+ delete-then-copy. */
+
+ if (errno == ENOSYS)
+ errno = EXDEV;
+
+ return -1;
+ }
+
+ /* Delete unused local references. */
+ ANDROID_DELETE_LOCAL_REF (src_id1);
+ ANDROID_DELETE_LOCAL_REF (dst_id1);
+ ANDROID_DELETE_LOCAL_REF (dir_name1);
+ ANDROID_DELETE_LOCAL_REF (doc_id1);
+ ANDROID_DELETE_LOCAL_REF (uri1);
+
+ if (result)
+ {
+ /* The document ID changed. Free id and replace *DOC_ID with
+ the new ID. */
+ xfree (id);
+ new_id = (*android_java_env)->GetStringUTFChars (android_java_env,
+ result, NULL);
+ android_exception_check_nonnull ((void *) new_id, result);
+ *doc_id = xstrdup (new_id);
+ (*android_java_env)->ReleaseStringUTFChars (android_java_env, result,
+ new_id);
+ ANDROID_DELETE_LOCAL_REF (result);
+ }
+
+ return 0;
+}
+
+
+
+/* SAF directory vnode. A file within a SAF directory tree is
+ identified by the URI of the directory tree itself, an opaque
+ ``file identifier'' value, and a display name. This information is
+ recorded in each vnode representing either a directory or a file
+ itself. */
+
+struct android_saf_tree_vnode
+{
+ /* The vnode data itself. */
+ struct android_vnode vnode;
+
+ /* The URI of the directory tree represented. This is Java string
+ data in ``modified UTF format'', which is essentially a modified
+ UTF-8 format capable of storing NULL bytes while also utilizing
+ NULL termination. */
+ const char *tree_uri;
+
+ /* The ID of the document tree designated by TREE_URI. */
+ char *tree_id;
+
+ /* The document ID of the directory represented, or NULL if this is
+ the root directory of the tree. Since file and new vnodes don't
+ represent the root directory, this field is always set in
+ them. */
+ char *document_id;
+
+ /* The file name of this tree vnode. This is a ``path'' to the
+ file, where each directory component consists of the display name
+ of a directory leading up to a file within, terminated with a
+ directory separator character. */
+ char *name;
+};
+
+struct android_saf_tree_vdir
+{
+ /* The virtual directory stream function table. */
+ struct android_vdir vdir;
+
+ /* The next directory in `all_saf_tree_vdirs'. */
+ struct android_saf_tree_vdir *next;
+
+ /* Name of this directory relative to the root file system. */
+ char *name;
+
+ /* Local reference to the cursor representing the directory
+ stream. */
+ jobject cursor;
+
+ /* The ``directory'' file descriptor used to identify this directory
+ stream, or -1. */
+ int fd;
+};
+
+static struct android_vnode *android_saf_tree_name (struct android_vnode *,
+ char *, size_t);
+static int android_saf_tree_open (struct android_vnode *, int,
+ mode_t, bool, int *, AAsset **);
+static void android_saf_tree_close (struct android_vnode *);
+static int android_saf_tree_unlink (struct android_vnode *);
+static int android_saf_tree_symlink (const char *, struct android_vnode *);
+static int android_saf_tree_rmdir (struct android_vnode *);
+static int android_saf_tree_rename (struct android_vnode *,
+ struct android_vnode *, bool);
+static int android_saf_tree_stat (struct android_vnode *, struct stat *);
+static int android_saf_tree_access (struct android_vnode *, int);
+static int android_saf_tree_mkdir (struct android_vnode *, mode_t);
+static int android_saf_tree_chmod (struct android_vnode *, mode_t, int);
+static ssize_t android_saf_tree_readlink (struct android_vnode *, char *,
+ size_t);
+static struct android_vdir *android_saf_tree_opendir (struct android_vnode *);
+
+/* Vector of VFS operations associated with SAF tree VFS nodes. */
+
+static struct android_vops saf_tree_vfs_ops =
+ {
+ android_saf_tree_name,
+ android_saf_tree_open,
+ android_saf_tree_close,
+ android_saf_tree_unlink,
+ android_saf_tree_symlink,
+ android_saf_tree_rmdir,
+ android_saf_tree_rename,
+ android_saf_tree_stat,
+ android_saf_tree_access,
+ android_saf_tree_mkdir,
+ android_saf_tree_chmod,
+ android_saf_tree_readlink,
+ android_saf_tree_opendir,
+ };
+
+/* Vector of VFS operations associated with SAF file VFS nodes.
+ Defined later in the next page. */
+static struct android_vops saf_file_vfs_ops;
+
+/* Vector of VFS operations associated with SAF ``new'' VFS nodes.
+ Defined two pages below. */
+static struct android_vops saf_new_vfs_ops;
+
+/* Chain of all open SAF directory streams. */
+static struct android_saf_tree_vdir *all_saf_tree_vdirs;
+
+/* Find the document ID of the file within TREE_URI designated by
+ NAME.
+
+ NAME is a ``file name'' comprised of the display names of
+ individual files. Each constituent component prior to the last
+ must name a directory file within TREE_URI.
+
+ If NAME is not correct for the Java ``modified UTF-8'' coding
+ system, return -1 and set errno to ENOENT.
+
+ Upon success, return 0 or 1 (contingent upon whether or not the
+ last component within NAME is a directory) and place the document
+ ID of the named file in ID.
+
+ If the designated file doesn't exist, but the penultimate component
+ within NAME does and is also a directory, return -2 and place the
+ document ID of that directory within *ID.
+
+ If the designated file can't be located, return -1 and set errno
+ accordingly. The reasons for which a file can't be located are not
+ all immediately obvious: quitting, for example, can cause document
+ ID lookup to be canceled. */
+
+static int
+android_document_id_from_name (const char *tree_uri, const char *name,
+ char **id)
+{
+ jobjectArray result;
+ jstring uri;
+ jbyteArray java_name;
+ jint rc;
+ jmethodID method;
+ const char *doc_id;
+
+ /* Verify the format of NAME. Don't allow creating files that
+ contain characters that can't be encoded in Java. */
+
+ if (android_verify_jni_string (name))
+ {
+ errno = ENOENT;
+ return -1;
+ }
+
+ /* Now guarantee that it is safe to call
+ `document_id_from_name'. */
+
+ if (inside_saf_critical_section)
+ {
+ errno = EIO;
+ return -1;
+ }
+
+ /* First, create the array that will hold the result. */
+ result = (*android_java_env)->NewObjectArray (android_java_env, 1,
+ java_string_class,
+ NULL);
+ android_exception_check ();
+
+ /* Next, create the string for the tree URI and name. */
+ java_name = (*android_java_env)->NewStringUTF (android_java_env,
+ name);
+ android_exception_check_1 (result);
+ uri = (*android_java_env)->NewStringUTF (android_java_env, tree_uri);
+ android_exception_check_2 (result, java_name);
+
+ /* Now, call documentIdFromName. This will synchronize with the SAF
+ thread, so make sure reentrant calls don't happen. */
+ method = service_class.document_id_from_name;
+ inside_saf_critical_section = true;
+ rc = (*android_java_env)->CallNonvirtualIntMethod (android_java_env,
+ emacs_service,
+ service_class.class,
+ method,
+ uri, java_name,
+ result);
+ inside_saf_critical_section = false;
+
+ if (android_saf_exception_check (3, result, uri, java_name))
+ return -1;
+
+ ANDROID_DELETE_LOCAL_REF (uri);
+ ANDROID_DELETE_LOCAL_REF (java_name);
+
+ /* If rc indicates failure, don't try to copy from result. */
+
+ if (rc == -1)
+ {
+ ANDROID_DELETE_LOCAL_REF (result);
+ errno = ENOENT;
+ return -1;
+ }
+
+ eassert (rc == -2 || rc >= 0);
+
+ /* Otherwise, obtain the contents of the string returned in Java
+ ``UTF-8'' encoding. */
+ uri = (*android_java_env)->GetObjectArrayElement (android_java_env,
+ result, 0);
+ android_exception_check_nonnull (uri, result);
+ ANDROID_DELETE_LOCAL_REF (result);
+
+ doc_id = (*android_java_env)->GetStringUTFChars (android_java_env,
+ uri, NULL);
+ android_exception_check_nonnull ((void *) doc_id, uri);
+
+ /* Make *ID its copy. */
+ *id = xstrdup (doc_id);
+
+ /* And release it. */
+ (*android_java_env)->ReleaseStringUTFChars (android_java_env,
+ (jstring) uri, doc_id);
+ ANDROID_DELETE_LOCAL_REF (uri);
+ return rc;
+}
+
+static struct android_vnode *
+android_saf_tree_name (struct android_vnode *vnode, char *name,
+ size_t length)
+{
+ char *remainder;
+ int rc;
+ struct android_saf_tree_vnode *vp, *new;
+ size_t vp_length;
+ char *filename, *fill, *doc_id, *end;
+ struct android_saf_root_vnode root;
+ struct android_saf_tree_vnode tree;
+
+ /* Canonicalize NAME. */
+ remainder = android_vfs_canonicalize_name (name, &length);
+
+ /* If remainder is set, it's a name relative to the root vnode. */
+ if (remainder)
+ goto parent_vnode;
+
+ /* If LENGTH is empty or NAME is a single directory separator,
+ return a copy of this vnode. */
+
+ if (length < 1 || (*name == '/' && length == 1))
+ {
+ vp = xmalloc (sizeof *vp);
+ memcpy (vp, vnode, sizeof *vp);
+
+ /* Duplicate the information contained within VNODE. */
+
+ vp->tree_uri = xstrdup (vp->tree_uri);
+ vp->tree_id = xstrdup (vp->tree_id);
+ vp->name = xstrdup (vp->name);
+
+ if (vp->document_id)
+ vp->document_id = xstrdup (vp->name);
+
+ return &vp->vnode;
+ }
+
+ /* Now, search for the document ID of the file designated by NAME
+ relative to this vnode. */
+
+ vp = (struct android_saf_tree_vnode *) vnode;
+ vp_length = strlen (vp->name);
+
+ /* If NAME starts with a directory separator, move it past that. */
+
+ if (*name == '/')
+ name++, length -= 1;
+
+ /* Concatenate VP->name with NAME. Leave one byte at the end for an
+ extra trailing directory separator. */
+
+ filename = xmalloc (vp_length + length + 2);
+ fill = stpcpy (filename, vp->name);
+ fill = stpcpy (fill, name);
+
+ /* And search for a document ID in the result. */
+ rc = android_document_id_from_name (vp->tree_uri, name,
+ &doc_id);
+
+ if (rc < 0)
+ {
+ if (rc == -2)
+ {
+ /* This is a vnode representing a nonexistent file in a real
+ directory, so create a vnode whose sole use is to create
+ the file. */
+
+ new = xmalloc (sizeof *new);
+ new->vnode.ops = &saf_new_vfs_ops;
+ new->vnode.type = ANDROID_VNODE_SAF_NEW;
+ new->vnode.flags = 0;
+
+ /* Here, doc_id is actually the ID of the penultimate
+ component in NAME. */
+
+ new->document_id = doc_id;
+ new->tree_uri = xstrdup (vp->tree_uri);
+ new->tree_id = xstrdup (vp->tree_id);
+ new->name = filename;
+ return &new->vnode;
+ }
+
+ /* The document ID can't be found. */
+ xfree (filename);
+ return NULL;
+ }
+
+ if (!rc)
+ {
+ /* rc set to 0 means that NAME is a regular file. Detect if
+ NAME is supposed to be a directory; if it is, set errno to
+ ENODIR. */
+
+ if (name[length - 1] == '/')
+ {
+ xfree (filename);
+ xfree (doc_id);
+ errno = ENOTDIR;
+ return NULL;
+ }
+ }
+
+ /* So this is either a directory or really a file. Fortunately,
+ directory and file vnodes share everything in common except for a
+ few file operations, so create a new directory vnode with the new
+ file name and return it. */
+
+ new = xmalloc (sizeof *new);
+ new->vnode.ops = (rc ? &saf_tree_vfs_ops
+ : &saf_file_vfs_ops);
+ new->vnode.type = (rc ? ANDROID_VNODE_SAF_TREE
+ : ANDROID_VNODE_SAF_FILE);
+ new->vnode.flags = 0;
+
+ if (rc)
+ {
+ /* If fill[-1] is not a directory separator character, append
+ one to the end of filename. */
+
+ if (fill[-1] != '/')
+ {
+ *fill++ = '/';
+ *fill = '\0';
+ }
+ }
+
+ new->document_id = doc_id;
+ new->tree_uri = xstrdup (vp->tree_uri);
+ new->tree_id = xstrdup (vp->tree_id);
+ new->name = filename;
+ return &new->vnode;
+
+ parent_vnode:
+ vp = (struct android_saf_tree_vnode *) vnode;
+
+ /* .. was encountered and the parent couldn't be found through
+ stripping off preceding components.
+
+ Find the parent vnode and name the rest of NAME starting from
+ there. */
+
+ if (!vp->document_id)
+ {
+ /* VP->document_id is NULL, meaning this is the root of this
+ directory tree. The parent vnode is an SAF root vnode with
+ VP->tree_uri's authority. */
+
+ root.vnode.ops = &saf_root_vfs_ops;
+ root.vnode.type = ANDROID_VNODE_SAF_ROOT;
+ root.vnode.flags = 0;
+
+ /* Find the authority from the URI. */
+
+ fill = (char *) vp->tree_uri;
+
+ if (strncmp (fill, "content://", 10))
+ emacs_abort ();
+
+ /* Skip the content header. */
+ fill += sizeof "content://" - 1;
+
+ /* The authority segment of the URI is between here and the
+ next slash. */
+
+ end = strchr (fill, '/');
+
+ if (!end)
+ emacs_abort ();
+
+ root.authority = xmalloc (end - fill + 1);
+ memcpy (root.authority, fill, end - fill);
+ root.authority[end - fill] = '\0';
+
+ /* Now search using this vnode. */
+ vnode = (*root.vnode.ops->name) (&root.vnode, remainder,
+ strlen (remainder));
+ xfree (root.authority);
+ return vnode;
+ }
+
+ /* Otherwise, strip off the last directory component. */
+
+ fill = strrchr (vp->name, '/');
+ if (!fill)
+ emacs_abort ();
+
+ /* Create a new vnode at the top of the directory tree, and search
+ for remainder from there. */
+
+ tree.vnode.ops = &saf_tree_vfs_ops;
+ tree.vnode.type = ANDROID_VNODE_SAF_TREE;
+ tree.vnode.flags = 0;
+ tree.document_id = NULL;
+ tree.name = (char *) "/";
+ tree.tree_uri = vp->tree_uri;
+ tree.tree_id = vp->tree_id;
+
+ length = strlen (remainder + (*remainder == '/'));
+ filename = xmalloc (fill - vp->name + length + 2);
+ fill = mempcpy (filename, vp->name,
+ /* Include the separator character (*FILL) within
+ this copy. */
+ fill - vp->name + 1);
+ /* Skip a leading separator in REMAINDER. */
+ strcpy (fill, remainder + (*remainder == '/'));
+
+ /* Use this filename to find a vnode relative to the start of this
+ tree. */
+
+ vnode = android_saf_tree_name (&tree.vnode, filename,
+ strlen (filename));
+ xfree (filename);
+ return vnode;
+}
+
+static int
+android_saf_tree_open (struct android_vnode *vnode, int flags,
+ mode_t mode, bool asset_p, int *fd,
+ AAsset **asset)
+{
+ /* Don't allow opening this special directory. */
+ errno = ENOSYS;
+ return -1;
+}
+
+static void
+android_saf_tree_close (struct android_vnode *vnode)
+{
+ struct android_saf_tree_vnode *vp;
+ int save_errno;
+
+ vp = (struct android_saf_tree_vnode *) vnode;
+
+ save_errno = errno;
+ xfree ((void *) vp->tree_uri);
+ xfree (vp->tree_id);
+ xfree (vp->name);
+ xfree (vp->document_id);
+ xfree (vp);
+ errno = save_errno;
+}
+
+static int
+android_saf_tree_unlink (struct android_vnode *vnode)
+{
+ errno = EISDIR;
+ return -1;
+}
+
+static int
+android_saf_tree_symlink (const char *target, struct android_vnode *vnode)
+{
+ errno = EPERM;
+ return -1;
+}
+
+static int
+android_saf_tree_rmdir (struct android_vnode *vnode)
+{
+ struct android_saf_tree_vnode *vp;
+
+ vp = (struct android_saf_tree_vnode *) vnode;
+
+ /* Don't allow deleting the root directory. */
+
+ if (!vp->document_id)
+ {
+ errno = EROFS;
+ return -1;
+ }
+
+ return android_saf_delete_document (vp->tree_uri,
+ vp->document_id,
+ vp->name);
+}
+
+static int
+android_saf_tree_rename (struct android_vnode *src,
+ struct android_vnode *dst,
+ bool keep_existing)
+{
+ char *last, *dst_last;
+ struct android_saf_tree_vnode *vp, *vdst;
+ char path[EMACS_PATH_MAX], path1[EMACS_PATH_MAX];
+ char *fill, *dst_id;
+ int rc;
+
+ /* If dst isn't a tree, file or new vnode, return EXDEV. */
+
+ if (dst->type != ANDROID_VNODE_SAF_TREE
+ && dst->type != ANDROID_VNODE_SAF_FILE
+ && dst->type != ANDROID_VNODE_SAF_NEW)
+ {
+ errno = EXDEV;
+ return -1;
+ }
+
+ vp = (struct android_saf_tree_vnode *) src;
+ vdst = (struct android_saf_tree_vnode *) dst;
+
+ /* if vp and vdst refer to different tree URIs, return EXDEV. */
+
+ if (strcmp (vp->tree_uri, vdst->tree_uri))
+ {
+ errno = EXDEV;
+ return -1;
+ }
+
+ /* If `keep_existing' and the destination vnode designates an
+ existing file, return EEXIST. */
+
+ if (keep_existing && dst->type != ANDROID_VNODE_SAF_NEW)
+ {
+ errno = EEXIST;
+ return -1;
+ }
+
+ /* Unix `rename' maps to two Android content provider operations.
+ The first case is a simple rename, where src and dst are both
+ located within the same directory. Compare the file names of
+ both up to the component before the last. */
+
+ last = strrchr (vp->name, '/');
+ eassert (last != NULL);
+
+ if (last[1] == '\0')
+ {
+ if (last == vp->name)
+ {
+ /* This means the caller is trying to rename the root
+ directory of the tree. */
+ errno = EROFS;
+ return -1;
+ }
+
+ /* The name is terminated by a trailing directory separator.
+ Search backwards for the preceding directory separator. */
+ last = memrchr (vp->name, '/', last - vp->name);
+ eassert (last != NULL);
+ }
+
+ /* Find the end of the second-to-last component in vdst's name. */
+
+ dst_last = strrchr (vdst->name, '/');
+ eassert (dst_last != NULL);
+
+ if (dst_last[1] == '\0')
+ {
+ if (dst_last == vdst->name)
+ {
+ /* Forbid overwriting the root of the tree either. */
+ errno = EROFS;
+ return -1;
+ }
+
+ dst_last = memrchr (vdst->name, '/', dst_last - vdst->name);
+ eassert (dst_last != NULL);
+ }
+
+ if (dst_last - vdst->name != last - vp->name
+ || memcmp (vp->name, vdst->name, last - vp->name))
+ {
+ /* The second case is where the file must be moved from one
+ directory to the other, and possibly then recreated under a
+ new name. */
+
+ /* The names of the source and destination directories will have
+ to be copied to path. */
+
+ if (last - vp->name >= EMACS_PATH_MAX
+ || dst_last - vdst->name >= EMACS_PATH_MAX)
+ {
+ errno = ENAMETOOLONG;
+ return -1;
+ }
+
+ fill = mempcpy (path, vp->name, last - vp->name);
+ *fill = '\0';
+
+ /* If vdst doesn't already exist, its document_id field is
+ already the name of its parent directory. */
+
+ if (dst->type == ANDROID_VNODE_SAF_NEW)
+ {
+ /* First, move the document. This will update
+ VP->document_id if it changes. */
+
+ if (android_saf_move_document (vp->tree_uri,
+ &vp->document_id,
+ path,
+ vdst->document_id))
+ return -1;
+
+ fill = mempcpy (path, vdst->name, dst_last - vdst->name);
+ *fill = '\0';
+
+ /* Next, rename the document, if its display name differs
+ from that of the source. */
+
+ if (strcmp (dst_last + 1, last + 1)
+ /* By now vp->document_id is already in the destination
+ directory. */
+ && android_saf_rename_document (vp->tree_uri,
+ vp->document_id,
+ path,
+ dst_last + 1))
+ return -1;
+
+ return 0;
+ }
+
+ /* Retrieve the ID designating the destination document's parent
+ directory. */
+
+ fill = mempcpy (path1, vdst->name, dst_last - vdst->name);
+ *fill = '\0';
+
+ rc = android_document_id_from_name (vp->tree_uri,
+ path1, &dst_id);
+
+ if (rc != 1)
+ {
+ /* This file is either not a directory or nonexistent. */
+
+ switch (rc)
+ {
+ case 0:
+ errno = ENOTDIR;
+ goto error;
+
+ case -1:
+ /* dst_id is not set here, as the penultimate component
+ also couldn't be located. */
+ errno = ENOENT;
+ return -1;
+
+ case -2:
+ errno = ENOENT;
+ goto error;
+
+ default:
+ emacs_abort ();
+ }
+ }
+
+ /* vdst already exists, so it needs to be deleted first. */
+
+ if (android_saf_delete_document (vdst->tree_uri,
+ vdst->document_id,
+ vdst->name))
+ goto error;
+
+ /* First, move the document. This will update
+ VP->document_id if it changes. */
+
+ if (android_saf_move_document (vp->tree_uri,
+ &vp->document_id,
+ path, dst_id))
+ goto error;
+
+ /* Next, rename the document, if its display name differs from
+ that of the source. */
+
+ if (strcmp (dst_last + 1, last + 1)
+ /* By now vp->document_id is already in the destination
+ directory. */
+ && android_saf_rename_document (vp->tree_uri,
+ vp->document_id,
+ path1,
+ dst_last + 1))
+ goto error;
+
+ xfree (dst_id);
+ return 0;
+
+ error:
+ xfree (dst_id);
+ return 1;
+ }
+
+ /* Otherwise, do this simple rename. The name of the parent
+ directory is required, as it provides the directory whose entries
+ will be modified. */
+
+ if (last - vp->name >= EMACS_PATH_MAX)
+ {
+ errno = ENAMETOOLONG;
+ return -1;
+ }
+
+ /* If the destination document exists, delete it. */
+
+ if (dst->type != ANDROID_VNODE_SAF_NEW
+ && android_saf_delete_document (vdst->tree_uri,
+ vdst->document_id,
+ vdst->name))
+ return -1;
+
+ fill = mempcpy (path, vp->name, last - vp->name);
+ *fill = '\0';
+ return android_saf_rename_document (vp->tree_uri,
+ vp->document_id,
+ path,
+ dst_last + 1);
+}
+
+static int
+android_saf_tree_stat (struct android_vnode *vnode,
+ struct stat *statb)
+{
+ struct android_saf_tree_vnode *vp;
+
+ vp = (struct android_saf_tree_vnode *) vnode;
+
+ return android_saf_stat (vp->tree_uri, vp->document_id,
+ statb, false);
+}
+
+static int
+android_saf_tree_access (struct android_vnode *vnode, int mode)
+{
+ struct android_saf_tree_vnode *vp;
+
+ vp = (struct android_saf_tree_vnode *) vnode;
+
+ /* Validate MODE. */
+
+ if (mode != F_OK && !(mode & (W_OK | X_OK | R_OK)))
+ {
+ errno = EINVAL;
+ return -1;
+ }
+
+ return android_saf_access (vp->tree_uri, vp->document_id,
+ mode & W_OK);
+}
+
+static int
+android_saf_tree_mkdir (struct android_vnode *vnode, mode_t mode)
+{
+ /* Since tree vnodes represent files that already exist, return
+ EEXIST. */
+ errno = EEXIST;
+ return -1;
+}
+
+static int
+android_saf_tree_chmod (struct android_vnode *vnode, mode_t mode,
+ int flags)
+{
+ /* Return EACCESS should MODE contain unusual bits besides the
+ standard file access permissions. */
+
+ if (mode & ~0777)
+ {
+ errno = EACCES;
+ return -1;
+ }
+
+ /* Otherwise, no further action is necessary, as SAF nodes already
+ pretend to be S_IRUSR | S_IWUSR. */
+ return 0;
+}
+
+static ssize_t
+android_saf_tree_readlink (struct android_vnode *vnode, char *buffer,
+ size_t size)
+{
+ /* Return EINVAL. Symlinks aren't exposed to clients by the
+ SAF. */
+ errno = EINVAL;
+ return -1;
+}
+
+/* Open a database Cursor containing each directory entry within the
+ supplied SAF tree vnode VP.
+
+ Value is NULL upon failure with errno set to a suitable value, a
+ local reference to the Cursor object otherwise. */
+
+static jobject
+android_saf_tree_opendir_1 (struct android_saf_tree_vnode *vp)
+{
+ jobject uri, id, cursor;
+ jmethodID method;
+
+ if (inside_saf_critical_section)
+ {
+ errno = EIO;
+ return NULL;
+ }
+
+ /* Build strings for both URI and ID. */
+ uri = (*android_java_env)->NewStringUTF (android_java_env,
+ vp->tree_uri);
+ android_exception_check ();
+
+ if (vp->document_id)
+ {
+ id = (*android_java_env)->NewStringUTF (android_java_env,
+ vp->document_id);
+ android_exception_check_1 (uri);
+ }
+ else
+ id = NULL;
+
+ /* Try to open the cursor. */
+ method = service_class.open_document_directory;
+ inside_saf_critical_section = true;
+ cursor
+ = (*android_java_env)->CallNonvirtualObjectMethod (android_java_env,
+ emacs_service,
+ service_class.class,
+ method, uri, id);
+ inside_saf_critical_section = false;
+
+ if (id)
+ {
+ if (android_saf_exception_check (2, id, uri))
+ return NULL;
+
+ ANDROID_DELETE_LOCAL_REF (id);
+ }
+ else if (android_saf_exception_check (1, uri))
+ return NULL;
+
+ ANDROID_DELETE_LOCAL_REF (uri);
+
+ /* Return the resulting cursor. */
+ return cursor;
+}
+
+static struct dirent *
+android_saf_tree_readdir (struct android_vdir *vdir)
+{
+ struct android_saf_tree_vdir *dir;
+ static struct dirent *dirent;
+ jobject entry, d_name;
+ jint d_type;
+ jmethodID method;
+ size_t length, size;
+ const char *chars;
+ struct coding_system coding;
+
+ dir = (struct android_saf_tree_vdir *) vdir;
+
+ /* Try to read one entry from the cursor. */
+ method = service_class.read_directory_entry;
+ entry
+ = (*android_java_env)->CallNonvirtualObjectMethod (android_java_env,
+ emacs_service,
+ service_class.class,
+ method, dir->cursor);
+ android_exception_check ();
+
+ /* If ENTRY is NULL, we're at the end of the directory. */
+
+ if (!entry)
+ {
+ xfree (entry);
+ entry = NULL;
+ return NULL;
+ }
+
+ /* Load both fields from ENTRY. */
+ d_name = (*android_java_env)->GetObjectField (android_java_env, entry,
+ entry_class.d_name);
+ if (!d_name)
+ {
+ /* If an error transpires, d_name is set to NULL. */
+ (*android_java_env)->ExceptionClear (android_java_env);
+ ANDROID_DELETE_LOCAL_REF (entry);
+
+ /* XXX: what would be a better error indication? */
+ errno = EIO;
+ return NULL;
+ }
+
+ /* d_type is 1 if this is a directory, and 0 if it's a regular
+ file. */
+ d_type = (*android_java_env)->GetIntField (android_java_env, entry,
+ entry_class.d_type);
+ ANDROID_DELETE_LOCAL_REF (entry);
+
+ /* Copy the name of the directory over. */
+ chars = (*android_java_env)->GetStringUTFChars (android_java_env,
+ (jstring) d_name,
+ NULL);
+ android_exception_check_nonnull ((void *) chars, d_name);
+
+ /* Decode this JNI string into utf-8-emacs; see
+ android_vfs_convert_name for considerations regarding coding
+ systems. */
+ length = strlen (chars);
+ setup_coding_system (Qandroid_jni, &coding);
+ coding.mode |= CODING_MODE_LAST_BLOCK;
+ coding.source = (const unsigned char *) chars;
+ coding.dst_bytes = 0;
+ coding.destination = NULL;
+ decode_coding_object (&coding, Qnil, 0, 0, length, length, Qnil);
+
+ /* Release the string data and the local reference to STRING. */
+ (*android_java_env)->ReleaseStringUTFChars (android_java_env,
+ (jstring) d_name,
+ chars);
+
+ /* Resize dirent to accommodate the decoded text. */
+ size = offsetof (struct dirent, d_name) + 1 + coding.produced;
+ dirent = xrealloc (dirent, size);
+
+ /* Clear dirent. */
+ memset (dirent, 0, size);
+
+ /* Fill in the generic directory information and copy the string
+ over. */
+ dirent->d_ino = 0;
+ dirent->d_off = 0;
+ dirent->d_reclen = size;
+ dirent->d_type = d_type ? DT_DIR : DT_UNKNOWN;
+ memcpy (dirent->d_name, coding.destination, coding.produced);
+ dirent->d_name[coding.produced] = '\0';
+
+ /* Free the coding system destination buffer. */
+ xfree (coding.destination);
+
+ ANDROID_DELETE_LOCAL_REF (d_name);
+ return dirent;
+}
+
+static void
+android_saf_tree_closedir (struct android_vdir *vdir)
+{
+ struct android_saf_tree_vdir *dir, **next, *tem;
+
+ dir = (struct android_saf_tree_vdir *) vdir;
+
+ /* dir->name is allocated by asprintf, which uses regular
+ malloc. */
+ free (dir->name);
+
+ /* Yes, DIR->cursor is a local reference. */
+ ANDROID_DELETE_LOCAL_REF (dir->cursor);
+
+ /* If the ``directory file descriptor'' has been opened, close
+ it. */
+ if (dir->fd != -1)
+ close (dir->fd);
+
+ /* Now unlink this directory. */
+
+ for (next = &all_saf_tree_vdirs; (tem = *next);)
+ {
+ if (tem == dir)
+ *next = dir->next;
+ else
+ next = &(*next)->next;
+ }
+
+ xfree (dir);
+}
+
+static int
+android_saf_tree_dirfd (struct android_vdir *vdir)
+{
+ struct android_saf_tree_vdir *dir;
+
+ dir = (struct android_saf_tree_vdir *) vdir;
+
+ /* Since `android_saf_tree_opendir' tries to avoid opening a file
+ descriptor if readdir isn't called, dirfd can fail if open fails.
+
+ open sets errno to a set of errors different from what POSIX
+ stipulates for dirfd, but for ease of implementation the open
+ errors are used instead. */
+
+ if (dir->fd >= 0)
+ return dir->fd;
+
+ dir->fd = open ("/dev/null", O_RDONLY | O_CLOEXEC);
+ return dir->fd;
+}
+
+static struct android_vdir *
+android_saf_tree_opendir (struct android_vnode *vnode)
+{
+ struct android_saf_tree_vnode *vp;
+ struct android_saf_tree_vdir *dir;
+ char *fill, *end;
+ jobject cursor;
+ char component[EMACS_PATH_MAX];
+
+ vp = (struct android_saf_tree_vnode *) vnode;
+
+ /* First, fill the directory stream with the right functions and
+ file name. */
+
+ dir = xmalloc (sizeof *dir);
+ dir->vdir.readdir = android_saf_tree_readdir;
+ dir->vdir.closedir = android_saf_tree_closedir;
+ dir->vdir.dirfd = android_saf_tree_dirfd;
+
+ /* Find the authority from the URI. */
+
+ fill = (char *) vp->tree_uri;
+
+ if (strncmp (fill, "content://", 10))
+ emacs_abort ();
+
+ /* Skip the content header. */
+ fill += sizeof "content://" - 1;
+
+ /* The authority segment of the URI is between here and the
+ next slash. */
+
+ end = strchr (fill, '/');
+
+ if (!end)
+ emacs_abort ();
+
+ if (end - fill >= EMACS_PATH_MAX)
+ {
+ errno = ENAMETOOLONG;
+ xfree (dir);
+ return NULL;
+ }
+
+ /* Copy the authority over. */
+
+ memcpy (component, fill, end - fill);
+ component[end - fill] = '\0';
+
+ if (asprintf (&dir->name, "/content/storage/%s/%s%s",
+ component, vp->tree_id, vp->name) < 0)
+ {
+ /* Out of memory. */
+ xfree (dir);
+ memory_full (0);
+ }
+
+ /* Now open a cursor that iterates through each file in this
+ directory. */
+
+ cursor = android_saf_tree_opendir_1 (vp);
+
+ if (!cursor)
+ {
+ xfree (dir->name);
+ xfree (dir);
+ return NULL;
+ }
+
+ dir->cursor = cursor;
+ dir->fd = -1;
+ dir->next = all_saf_tree_vdirs;
+ all_saf_tree_vdirs = dir;
+ return &dir->vdir;
+}
+
+/* Create a vnode designating the file NAME within a directory tree
+ whose identifier is TREE. As with all other `name' functions, NAME
+ may be modified.
+
+ AUTHORITY is the name of the content provider authority that is
+ offering TREE.
+
+ Value is NULL and errno is set if no document tree or provider by
+ those names exists, or some other error takes place (for example,
+ if TREE and AUTHORITY aren't encoded correctly.) */
+
+static struct android_vnode *
+android_saf_tree_from_name (char *name, const char *tree,
+ const char *authority)
+{
+ struct android_saf_tree_vnode root;
+ jobject tree_string, authority_string, result;
+ jmethodID method;
+ const char *uri;
+ struct android_vnode *vp;
+
+ /* It's not a given that NAME and TREE are actually in the modified
+ UTF-8 format used by the JVM to encode strings, and the JVM
+ aborts when encountering a string that is not. Make sure they
+ are valid before continuing. */
+
+ if (android_verify_jni_string (name)
+ || android_verify_jni_string (authority))
+ {
+ errno = ENOENT;
+ return NULL;
+ }
+
+ tree_string = (*android_java_env)->NewStringUTF (android_java_env,
+ tree);
+ android_exception_check ();
+
+ authority_string
+ = (*android_java_env)->NewStringUTF (android_java_env,
+ authority);
+ android_exception_check_1 (tree_string);
+
+ /* Now create the URI and detect if Emacs has the rights to access
+ it. */
+
+ method = service_class.get_tree_uri;
+ result
+ = (*android_java_env)->CallNonvirtualObjectMethod (android_java_env,
+ emacs_service,
+ service_class.class,
+ method, tree_string,
+ authority_string);
+ android_exception_check_2 (tree_string, authority_string);
+ ANDROID_DELETE_LOCAL_REF (tree_string);
+ ANDROID_DELETE_LOCAL_REF (authority_string);
+
+ /* If it doesn't, return NULL and set errno to ENOENT. */
+
+ if (!result)
+ {
+ errno = ENOENT;
+ return NULL;
+ }
+
+ /* Otherwise, decode this string. */
+ uri = (*android_java_env)->GetStringUTFChars (android_java_env, result,
+ NULL);
+ android_exception_check_nonnull ((void *) uri, result);
+
+ /* Fill in root.tree_uri with values that represent the root of this
+ document tree. */
+
+ root.vnode.ops = &saf_tree_vfs_ops;
+ root.vnode.type = ANDROID_VNODE_SAF_TREE;
+ root.vnode.flags = 0;
+ root.tree_uri = uri;
+ root.tree_id = (char *) tree;
+ root.document_id = NULL;
+ root.name = (char *) "/";
+
+ vp = (*root.vnode.ops->name) (&root.vnode, name, strlen (name));
+ (*android_java_env)->ReleaseStringUTFChars (android_java_env,
+ (jstring) result, uri);
+ ANDROID_DELETE_LOCAL_REF (result);
+ return vp;
+}
+
+/* Return any open SAF tree directory stream for which dirfd has
+ returned the file descriptor DIRFD. Return NULL otherwise. */
+
+static struct android_saf_tree_vdir *
+android_saf_tree_get_directory (int dirfd)
+{
+ struct android_saf_tree_vdir *dir;
+
+ for (dir = all_saf_tree_vdirs; dir; dir = dir->next)
+ {
+ if (dir->fd == dirfd && dirfd != -1)
+ return dir;
+ }
+
+ return NULL;
+}
+
+
+
+/* SAF file vnode. The information used to uniquely identify a file
+ is identical to that used to identify an SAF directory, but the
+ vnode operations are different. */
+
+/* Define `struct android_saf_file_vnode' to be identical to a file
+ vnode. */
+
+#define android_saf_file_vnode android_saf_tree_vnode
+
+/* Structure describing an open ParcelFileDescriptor. */
+
+struct android_parcel_fd
+{
+ /* The next open parcel file descriptor. */
+ struct android_parcel_fd *next;
+
+ /* Global reference to this parcel file descriptor. */
+ jobject descriptor;
+
+ /* The modification time of this parcel file descriptor, or
+ `invalid_timespec'. */
+ struct timespec mtime;
+
+ /* The file descriptor itself. */
+ int fd;
+};
+
+static struct android_vnode *android_saf_file_name (struct android_vnode *,
+ char *, size_t);
+static int android_saf_file_open (struct android_vnode *, int,
+ mode_t, bool, int *, AAsset **);
+static int android_saf_file_unlink (struct android_vnode *);
+static int android_saf_file_rmdir (struct android_vnode *);
+static struct android_vdir *android_saf_file_opendir (struct android_vnode *);
+
+/* Vector of VFS operations associated with SAF tree VFS nodes. */
+
+static struct android_vops saf_file_vfs_ops =
+ {
+ android_saf_file_name,
+ android_saf_file_open,
+ android_saf_tree_close,
+ android_saf_file_unlink,
+ android_saf_tree_symlink,
+ android_saf_file_rmdir,
+ android_saf_tree_rename,
+ android_saf_tree_stat,
+ android_saf_tree_access,
+ android_saf_tree_mkdir,
+ android_saf_tree_chmod,
+ android_saf_tree_readlink,
+ android_saf_file_opendir,
+ };
+
+/* Chain of all parcel file descriptors currently open. */
+static struct android_parcel_fd *open_parcel_fds;
+
+static struct android_vnode *
+android_saf_file_name (struct android_vnode *vnode, char *name,
+ size_t length)
+{
+ struct android_saf_file_vnode *vp;
+
+ /* If LENGTH is empty, make a copy of this vnode and return it. */
+
+ if (length < 1)
+ {
+ vp = xmalloc (sizeof *vp);
+ memcpy (vp, vnode, sizeof *vp);
+
+ /* Duplicate the information contained within VNODE. */
+
+ vp->tree_uri = xstrdup (vp->tree_uri);
+ vp->tree_id = xstrdup (vp->tree_id);
+ vp->name = xstrdup (vp->name);
+ vp->document_id = xstrdup (vp->name);
+
+ return &vp->vnode;
+ }
+
+ /* A file vnode has no children of its own. */
+ errno = ENOTDIR;
+ return NULL;
+}
+
+static int
+android_saf_file_open (struct android_vnode *vnode, int flags,
+ mode_t mode, bool asset_p, int *fd_return,
+ AAsset **asset)
+{
+ struct android_saf_file_vnode *vp;
+ jobject uri, id, descriptor;
+ jmethodID method;
+ jboolean read, trunc, write;
+ jint fd;
+ struct android_parcel_fd *info;
+ struct stat statb;
+
+ if (inside_saf_critical_section)
+ {
+ errno = EIO;
+ return -1;
+ }
+
+ /* O_APPEND isn't supported as a consequence of Android content
+ providers defaulting to truncating the file. */
+
+ if (flags & O_APPEND)
+ {
+ errno = EOPNOTSUPP;
+ return -1;
+ }
+
+ /* Build strings for both the URI and ID. */
+
+ vp = (struct android_saf_file_vnode *) vnode;
+ uri = (*android_java_env)->NewStringUTF (android_java_env,
+ vp->tree_uri);
+ android_exception_check ();
+ id = (*android_java_env)->NewStringUTF (android_java_env,
+ vp->document_id);
+ android_exception_check_1 (uri);
+
+ /* Open a parcel file descriptor according to flags. Documentation
+ for the SAF openDocument operation is scant and seldom helpful.
+ From observations made, it is clear that their file access modes
+ are inconsistently implemented, and that at least:
+
+ r = either an FIFO or a real file, without truncation.
+ w = either an FIFO or a real file, with OR without truncation.
+ wt = either an FIFO or a real file, with truncation.
+ rw = a real file, without truncation.
+ rwt = a real file, with truncation.
+
+ This diverges from the self-contradicting documentation, where
+ openDocument says nothing about truncation, and openFile mentions
+ that w can elect not to truncate and programs which rely on
+ truncation should use wt.
+
+ Since Emacs is prepared to handle FIFOs within fileio.c, simply
+ specify the straightforward relationship between FLAGS and the
+ file access modes listed above. */
+
+ method = service_class.open_document;
+ read = trunc = write = false;
+
+ if ((flags & O_RDWR) == O_RDWR || (flags & O_WRONLY))
+ write = true;
+
+ if (flags & O_TRUNC)
+ trunc = true;
+
+ if ((flags & O_RDWR) == O_RDWR || !write)
+ read = true;
+
+ inside_saf_critical_section = true;
+ descriptor
+ = (*android_java_env)->CallNonvirtualObjectMethod (android_java_env,
+ emacs_service,
+ service_class.class,
+ method, uri, id,
+ read, write, trunc);
+ inside_saf_critical_section = false;
+
+ if (android_saf_exception_check (2, uri, id))
+ return -1;
+
+ ANDROID_DELETE_LOCAL_REF (uri);
+ ANDROID_DELETE_LOCAL_REF (id);
+
+ if (!descriptor)
+ {
+ /* Assume that permission has been denied if DESCRIPTOR cannot
+ be opened. */
+ errno = EPERM;
+ return -1;
+ }
+
+ /* Allocate a record for this file descriptor. Parcel file
+ descriptors should be closed using their own `close' function,
+ which takes care of notifying the source that it has been
+ closed. */
+ info = xmalloc (sizeof *info);
+
+ /* Now obtain the file descriptor. */
+ fd = (*android_java_env)->CallIntMethod (android_java_env,
+ descriptor,
+ fd_class.get_fd);
+ android_exception_check_1 (descriptor);
+
+ /* Create a global reference to descriptor. */
+ info->descriptor
+ = (*android_java_env)->NewGlobalRef (android_java_env,
+ descriptor);
+
+ if (!info->descriptor)
+ {
+ /* If the global reference can't be created, delete
+ descriptor. */
+ (*android_java_env)->ExceptionClear (android_java_env);
+ (*android_java_env)->CallVoidMethod (android_java_env,
+ descriptor,
+ fd_class.close);
+ (*android_java_env)->ExceptionClear (android_java_env);
+ ANDROID_DELETE_LOCAL_REF (descriptor);
+
+ /* Free INFO. */
+ xfree (info);
+
+ /* Set errno to EMFILE and return. */
+ errno = EMFILE;
+ return -1;
+ }
+
+ /* Delete the local ref to DESCRIPTOR. */
+ ANDROID_DELETE_LOCAL_REF (descriptor);
+
+ /* Try to retrieve the modification time of this file from the
+ content provider.
+
+ Refrain from introducing the file status into the file status
+ cache if FLAGS & O_RDWR or FLAGS & O_WRONLY: the cached file
+ status will contain a size and modification time inconsistent
+ with the result of any modifications that later transpire. */
+
+ if (!android_saf_stat (vp->tree_uri, vp->document_id,
+ &statb, write))
+ info->mtime = get_stat_mtime (&statb);
+ else
+ info->mtime = invalid_timespec ();
+
+ /* Set info->fd and chain it onto the list. */
+ info->fd = fd;
+ info->next = open_parcel_fds;
+ open_parcel_fds = info;
+
+ /* Return the file descriptor. */
+ *fd_return = fd;
+ return 0;
+}
+
+static int
+android_saf_file_unlink (struct android_vnode *vnode)
+{
+ struct android_saf_file_vnode *vp;
+
+ vp = (struct android_saf_file_vnode *) vnode;
+ return android_saf_delete_document (vp->tree_uri,
+ vp->document_id,
+ vp->name);
+}
+
+static int
+android_saf_file_rmdir (struct android_vnode *vnode)
+{
+ errno = ENOTDIR;
+ return -1;
+}
+
+static struct android_vdir *
+android_saf_file_opendir (struct android_vnode *vnode)
+{
+ errno = ENOTDIR;
+ return NULL;
+}
+
+/* Close FD if it's a parcel file descriptor and return true.
+ If FD isn't, return false.
+
+ Such file descriptors need to be closed using a function
+ written in Java, to tell the sender that it has been
+ closed. */
+
+static bool
+android_close_parcel_fd (int fd)
+{
+ struct android_parcel_fd *tem, **next, *temp;
+
+ for (next = &open_parcel_fds; (tem = *next);)
+ {
+ if (tem->fd == fd)
+ {
+ (*android_java_env)->CallVoidMethod (android_java_env,
+ tem->descriptor,
+ fd_class.close);
+
+ /* Ignore exceptions for the same reason EINTR errors from
+ `close' should be ignored. */
+ (*android_java_env)->ExceptionClear (android_java_env);
+ (*android_java_env)->DeleteGlobalRef (android_java_env,
+ tem->descriptor);
+
+ temp = tem->next;
+ xfree (tem);
+ *next = temp;
+
+ return true;
+ }
+ else
+ next = &(*next)->next;
+ }
+
+ return false;
+}
+
+
+
+/* SAF ``new'' vnodes. These nodes share their data structures
+ with tree and file vnodes, but represent files that don't actually
+ exist within a directory. In them, the document ID represents not
+ the file designated by the vnode itself, but rather its parent
+ directory.
+
+ The only vops defined serve to create directories or files, at
+ which point the vnode becomes invalid. */
+
+#define android_saf_new_vnode android_saf_tree_vnode
+
+static struct android_vnode *android_saf_new_name (struct android_vnode *,
+ char *, size_t);
+static int android_saf_new_open (struct android_vnode *, int,
+ mode_t, bool, int *, AAsset **);
+static int android_saf_new_unlink (struct android_vnode *);
+static int android_saf_new_symlink (const char *, struct android_vnode *);
+static int android_saf_new_rmdir (struct android_vnode *);
+static int android_saf_new_rename (struct android_vnode *,
+ struct android_vnode *, bool);
+static int android_saf_new_stat (struct android_vnode *, struct stat *);
+static int android_saf_new_access (struct android_vnode *, int);
+static int android_saf_new_mkdir (struct android_vnode *, mode_t);
+static int android_saf_new_chmod (struct android_vnode *, mode_t, int);
+static ssize_t android_saf_new_readlink (struct android_vnode *, char *,
+ size_t);
+static struct android_vdir *android_saf_new_opendir (struct android_vnode *);
+
+/* Vector of VFS operations associated with SAF new VFS nodes. */
+
+static struct android_vops saf_new_vfs_ops =
+ {
+ android_saf_new_name,
+ android_saf_new_open,
+ android_saf_tree_close,
+ android_saf_new_unlink,
+ android_saf_new_symlink,
+ android_saf_new_rmdir,
+ android_saf_new_rename,
+ android_saf_new_stat,
+ android_saf_new_access,
+ android_saf_new_mkdir,
+ android_saf_new_chmod,
+ android_saf_new_readlink,
+ android_saf_new_opendir,
+ };
+
+static struct android_vnode *
+android_saf_new_name (struct android_vnode *vnode, char *name,
+ size_t length)
+{
+ struct android_saf_new_vnode *vp;
+
+ /* If LENGTH is empty, make a copy of this vnode and return it. */
+
+ if (length < 1)
+ {
+ vp = xmalloc (sizeof *vp);
+ memcpy (vp, vnode, sizeof *vp);
+
+ /* Duplicate the information contained within VNODE. */
+
+ vp->tree_uri = xstrdup (vp->tree_uri);
+ vp->tree_id = xstrdup (vp->tree_id);
+ vp->name = xstrdup (vp->name);
+ vp->document_id = xstrdup (vp->name);
+
+ return &vp->vnode;
+ }
+
+ /* A nonexistent vnode has no children of its own. */
+ errno = ENOTDIR;
+ return NULL;
+}
+
+static int
+android_saf_new_open (struct android_vnode *vnode, int flags,
+ mode_t mode, bool asset_p, int *fd_return,
+ AAsset **asset)
+{
+ struct android_saf_new_vnode *vp;
+ char *end;
+ jstring name, id, uri, new_id;
+ const char *new_doc_id;
+ jmethodID method;
+
+ /* If creating a file wasn't intended, return ENOENT. */
+
+ if (!(flags & O_CREAT))
+ {
+ errno = ENOENT;
+ return -1;
+ }
+
+ /* If vp->name indicates that it's a directory, return ENOENT. */
+
+ vp = (struct android_saf_new_vnode *) vnode;
+ end = strrchr (vp->name, '/');
+
+ /* VP->name must contain at least one directory separator. */
+ eassert (end);
+
+ if (end[1] == '\0')
+ {
+ errno = ENOENT;
+ return -1;
+ }
+
+ /* Otherwise, try to create a new document. First, build strings
+ for the name, ID and document URI. */
+
+ name = (*android_java_env)->NewStringUTF (android_java_env,
+ end + 1);
+ android_exception_check ();
+ id = (*android_java_env)->NewStringUTF (android_java_env,
+ vp->document_id);
+ android_exception_check_1 (name);
+ uri = (*android_java_env)->NewStringUTF (android_java_env,
+ vp->tree_uri);
+ android_exception_check_2 (name, id);
+
+ /* Next, try to create a new document and retrieve its ID. */
+
+ method = service_class.create_document;
+ new_id = (*android_java_env)->CallNonvirtualObjectMethod (android_java_env,
+ emacs_service,
+ service_class.class,
+ method, uri, id,
+ name);
+
+ if (android_saf_exception_check (3, name, id, uri))
+ return -1;
+
+ /* Delete unused local references. */
+ ANDROID_DELETE_LOCAL_REF (name);
+ ANDROID_DELETE_LOCAL_REF (id);
+ ANDROID_DELETE_LOCAL_REF (uri);
+
+ if (!new_id)
+ {
+ /* The file couldn't be created for some reason. */
+ errno = EIO;
+ return -1;
+ }
+
+ /* Now, free VP->document_id and replace it with the service
+ document ID. */
+
+ new_doc_id = (*android_java_env)->GetStringUTFChars (android_java_env,
+ new_id, NULL);
+ android_exception_check_nonnull ((void *) new_doc_id, new_id);
+
+ xfree (vp->document_id);
+ vp->document_id = xstrdup (new_doc_id);
+
+ (*android_java_env)->ReleaseStringUTFChars (android_java_env,
+ new_id, new_doc_id);
+ ANDROID_DELETE_LOCAL_REF (new_id);
+
+ /* Finally, transform this vnode into a file vnode and call its
+ `open' function. */
+ vp->vnode.type = ANDROID_VNODE_SAF_FILE;
+ vp->vnode.ops = &saf_file_vfs_ops;
+ return (*vp->vnode.ops->open) (vnode, flags, mode, asset_p,
+ fd_return, asset);
+}
+
+static int
+android_saf_new_unlink (struct android_vnode *vnode)
+{
+ errno = ENOENT;
+ return -1;
+}
+
+static int
+android_saf_new_symlink (const char *target, struct android_vnode *vnode)
+{
+ errno = EPERM;
+ return -1;
+}
+
+static int
+android_saf_new_rmdir (struct android_vnode *vnode)
+{
+ errno = ENOENT;
+ return -1;
+}
+
+static int
+android_saf_new_rename (struct android_vnode *src,
+ struct android_vnode *dst,
+ bool keep_existing)
+{
+ errno = ENOENT;
+ return -1;
+}
+
+static int
+android_saf_new_stat (struct android_vnode *vnode,
+ struct stat *statb)
+{
+ errno = ENOENT;
+ return -1;
+}
+
+static int
+android_saf_new_access (struct android_vnode *vnode, int mode)
+{
+ if (mode != F_OK && !(mode & (W_OK | X_OK | R_OK)))
+ errno = EINVAL;
+ else
+ errno = ENOENT;
+
+ return -1;
+}
+
+static int
+android_saf_new_mkdir (struct android_vnode *vnode, mode_t mode)
+{
+ struct android_saf_new_vnode *vp;
+ jstring name, id, uri, new_id;
+ jmethodID method;
+ const char *new_doc_id;
+ char *end;
+
+ vp = (struct android_saf_tree_vnode *) vnode;
+
+ /* Find the last component of vp->name. */
+ end = strrchr (vp->name, '/');
+
+ /* VP->name must contain at least one directory separator. */
+ eassert (end);
+
+ if (end[1] == '\0')
+ {
+ /* There's a trailing directory separator. Search
+ backwards. */
+
+ end--;
+ while (end != vp->name && *end != '/')
+ end--;
+
+ /* vp->name[0] is always a directory separator. */
+ eassert (*end == '/');
+ }
+
+ /* Otherwise, try to create a new document. First, build strings
+ for the name, ID and document URI. */
+
+ name = (*android_java_env)->NewStringUTF (android_java_env,
+ end + 1);
+ android_exception_check ();
+ id = (*android_java_env)->NewStringUTF (android_java_env,
+ vp->document_id);
+ android_exception_check_1 (name);
+ uri = (*android_java_env)->NewStringUTF (android_java_env,
+ vp->tree_uri);
+ android_exception_check_2 (name, id);
+
+ /* Next, try to create a new document and retrieve its ID. */
+
+ method = service_class.create_directory;
+ new_id = (*android_java_env)->CallNonvirtualObjectMethod (android_java_env,
+ emacs_service,
+ service_class.class,
+ method, uri, id,
+ name);
+
+ if (android_saf_exception_check (3, name, id, uri))
+ return -1;
+
+ /* Delete unused local references. */
+ ANDROID_DELETE_LOCAL_REF (name);
+ ANDROID_DELETE_LOCAL_REF (id);
+ ANDROID_DELETE_LOCAL_REF (uri);
+
+ if (!new_id)
+ {
+ /* The file couldn't be created for some reason. */
+ errno = EIO;
+ return -1;
+ }
+
+ /* Now, free VP->document_id and replace it with the service
+ document ID. */
+
+ new_doc_id = (*android_java_env)->GetStringUTFChars (android_java_env,
+ new_id, NULL);
+
+ if (android_saf_exception_check (3, name, id, uri))
+ return -1;
+
+ xfree (vp->document_id);
+ vp->document_id = xstrdup (new_doc_id);
+
+ (*android_java_env)->ReleaseStringUTFChars (android_java_env,
+ new_id, new_doc_id);
+ ANDROID_DELETE_LOCAL_REF (new_id);
+
+ /* Finally, transform this vnode into a directory vnode. */
+ vp->vnode.type = ANDROID_VNODE_SAF_TREE;
+ vp->vnode.ops = &saf_tree_vfs_ops;
+ return 0;
+}
+
+static int
+android_saf_new_chmod (struct android_vnode *vnode, mode_t mode,
+ int flags)
+{
+ errno = ENOENT;
+ return -1;
+}
+
+static ssize_t
+android_saf_new_readlink (struct android_vnode *vnode, char *buffer,
+ size_t size)
+{
+ errno = ENOENT;
+ return -1;
+}
+
+static struct android_vdir *
+android_saf_new_opendir (struct android_vnode *vnode)
+{
+ errno = ENOENT;
+ return NULL;
+}
+
+
+
+/* Synchronization between SAF and Emacs. Consult EmacsSafThread.java
+ for more details. */
+
+/* Semaphore posted upon the completion of an SAF operation. */
+static sem_t saf_completion_sem;
+
+#ifdef __clang__
+#pragma clang diagnostic push
+#pragma clang diagnostic ignored "-Wmissing-prototypes"
+#else /* GNUC */
+#pragma GCC diagnostic push
+#pragma GCC diagnostic ignored "-Wmissing-prototypes"
+#endif /* __clang__ */
+
+JNIEXPORT jint JNICALL
+NATIVE_NAME (safSyncAndReadInput) (JNIEnv *env, jobject object)
+{
+ JNI_STACK_ALIGNMENT_PROLOGUE;
+
+ while (sem_wait (&saf_completion_sem) < 0)
+ {
+ if (input_blocked_p ())
+ continue;
+
+ process_pending_signals ();
+
+ if (!NILP (Vquit_flag))
+ {
+ __android_log_print (ANDROID_LOG_VERBOSE, __func__,
+ "quitting from IO operation");
+ return 1;
+ }
+ }
+
+ return 0;
+}
+
+JNIEXPORT void JNICALL
+NATIVE_NAME (safSync) (JNIEnv *env, jobject object)
+{
+ JNI_STACK_ALIGNMENT_PROLOGUE;
+
+ while (sem_wait (&saf_completion_sem) < 0)
+ process_pending_signals ();
+}
+
+JNIEXPORT void JNICALL
+NATIVE_NAME (safPostRequest) (JNIEnv *env, jobject object)
+{
+ JNI_STACK_ALIGNMENT_PROLOGUE;
+
+ sem_post (&saf_completion_sem);
+}
+
+JNIEXPORT jboolean JNICALL
+NATIVE_NAME (ftruncate) (JNIEnv *env, jobject object, jint fd)
+{
+ JNI_STACK_ALIGNMENT_PROLOGUE;
+
+ if (ftruncate (fd, 0) < 0)
+ return false;
+
+ /* Reset the file pointer. */
+ if (lseek (fd, 0, SEEK_SET) < 0)
+ return false;
+
+ return true;
+}
+
+#ifdef __clang__
+#pragma clang diagnostic pop
+#else /* GNUC */
+#pragma GCC diagnostic pop
+#endif /* __clang__ */
+
+
+
+/* Root vnode. This vnode represents the root inode, and is a regular
+ Unix vnode with modifications to `name' that make it return asset
+ vnodes. */
+
+static struct android_vnode *android_root_name (struct android_vnode *,
+ char *, size_t);
+
+/* Vector of VFS operations associated with Unix root filesystem VFS
+ nodes. */
+
+static struct android_vops root_vfs_ops =
+ {
+ android_root_name,
+ android_unix_open,
+ android_unix_close,
+ android_unix_unlink,
+ android_unix_symlink,
+ android_unix_rmdir,
+ android_unix_rename,
+ android_unix_stat,
+ android_unix_access,
+ android_unix_mkdir,
+ android_unix_chmod,
+ android_unix_readlink,
+ android_unix_opendir,
+ };
+
+/* Array of special named vnodes. */
+
+static struct android_special_vnode special_vnodes[] =
+ {
+ { "assets", 6, android_afs_initial, },
+ { "content", 7, android_content_initial,
+ LISPSYM_INITIALLY (Qandroid_jni), },
+ };
+
+/* Convert the file name NAME from Emacs's internal character encoding
+ to CODING, and return a Lisp string with the data so produced.
+
+ Calling this function creates an implicit assumption that
+ file-name-coding-system is compatible with utf-8-emacs, which is not
+ unacceptable as users with cause to modify file-name-coding-system
+ should be aware and prepared for consequences towards files stored on
+ different filesystems, including virtual ones. */
+
+static Lisp_Object
+android_vfs_convert_name (const char *name, Lisp_Object coding)
+{
+ Lisp_Object name1;
+
+ /* Convert the contents of the buffer after BUFFER_END from the file
+ name coding system to special->special_coding_system. */
+ name1 = build_string (name);
+ name1 = code_convert_string (name1, coding, Qt, true, true, true);
+ return name1;
+}
+
+static struct android_vnode *
+android_root_name (struct android_vnode *vnode, char *name,
+ size_t length)
+{
+ char *component_end;
+ struct android_special_vnode *special;
+ size_t i;
+ Lisp_Object file_name;
+ struct android_vnode *vp;
+
+ /* Skip any leading separator in NAME. */
+
+ if (*name == '/')
+ name++, length--;
+
+ /* Look for the first directory separator. */
+ component_end = strchr (name, '/');
+
+ /* If not there, use name + length. */
+
+ if (!component_end)
+ component_end = name + length;
+ else
+ /* Move past the separator character. */
+ component_end++;
+
+ /* Now, find out if the first component is a special vnode; if so,
+ call its root lookup function with the rest of NAME there. */
+
+ for (i = 0; i < ARRAYELTS (special_vnodes); ++i)
+ {
+ special = &special_vnodes[i];
+
+ if (component_end - name == special->length
+ && !memcmp (special->name, name, special->length))
+ {
+ if (!NILP (special->special_coding_system))
+ {
+ USE_SAFE_ALLOCA;
+
+ file_name
+ = android_vfs_convert_name (component_end,
+ special->special_coding_system);
+
+ /* Allocate a buffer and copy file_name into the same. */
+ length = SBYTES (file_name) + 1;
+ name = SAFE_ALLOCA (length);
+
+ /* Copy the trailing NULL byte also. */
+ memcpy (name, SDATA (file_name), length);
+ vp = (*special->initial) (name, length - 1);
+ SAFE_FREE ();
+ return vp;
+ }
+
+ return (*special->initial) (component_end,
+ length - special->length);
+ }
+
+ /* Detect the case where a special is named with a trailing
+ directory separator. */
+
+ if (component_end - name == special->length + 1
+ && !memcmp (special->name, name, special->length)
+ && name[special->length] == '/')
+ {
+ if (!NILP (special->special_coding_system))
+ {
+ USE_SAFE_ALLOCA;
+
+ file_name
+ = android_vfs_convert_name (component_end - 1,
+ special->special_coding_system);
+
+ /* Allocate a buffer and copy file_name into the same. */
+ length = SBYTES (file_name) + 1;
+ name = SAFE_ALLOCA (length);
+
+ /* Copy the trailing NULL byte also. */
+ memcpy (name, SDATA (file_name), length);
+ vp = (*special->initial) (name, length - 1);
+ SAFE_FREE ();
+ return vp;
+ }
+
+ /* Make sure to include the directory separator. */
+ return (*special->initial) (component_end - 1,
+ length - special->length);
+ }
+ }
+
+ /* Otherwise, continue searching for a vnode normally. */
+ return android_unix_name (vnode, name, length);
+}
+
+
+
+/* File system lookup. */
+
+/* Look up the vnode that designates NAME, a file name that is at least
+ N bytes, converting between different file name coding systems as
+ necessary.
+
+ NAME may be either an absolute file name or a name relative to the
+ current working directory. It must not be longer than EMACS_PATH_MAX
+ bytes.
+
+ Value is NULL upon failure with errno set accordingly, or the
+ vnode. */
+
+static struct android_vnode *
+android_name_file (const char *name)
+{
+ char buffer[EMACS_PATH_MAX + 1], *head;
+ const char *end;
+ size_t len;
+ int nslash, c;
+ struct android_vnode *vp;
+
+ len = strlen (name);
+ if (len > EMACS_PATH_MAX)
+ {
+ errno = ENAMETOOLONG;
+ return NULL;
+ }
+
+ /* Now, try to ``normalize'' the file name by removing consecutive
+ slash characters while copying it to BUFFER. */
+
+ head = buffer;
+ nslash = 0;
+ for (end = name + len; name < end; ++name)
+ {
+ c = *name;
+
+ switch (c)
+ {
+ case '/':
+ /* This is a directory separator character. Two consecutive
+ separator characters should be replaced by a single
+ character; more than three in a row means that the
+ section of the file name before the last slash character
+ should be discarded. */
+
+ if (!nslash)
+ *head++ = '/';
+
+ nslash++;
+
+ if (nslash >= 3)
+ /* Return to the root directory. */
+ head = buffer, *head++ = '/', nslash = 0;
+ break;
+
+ default:
+ /* Otherwise, copy the file name over. */
+ nslash = 0;
+ *head++ = *name;
+ break;
+ }
+ }
+
+ /* Terminate the file name. */
+ *head = '\0';
+
+ /* If HEAD is a relative file name, it can't reside inside the
+ virtual mounts; create a Unix vnode instead. */
+
+ if (head == buffer || buffer[0] != '/')
+ return android_unix_vnode (buffer);
+
+ /* Start looking from the root vnode. */
+ vp = &root_vnode.vnode;
+
+ /* If buffer is empty, this will create a duplicate of the root
+ vnode. */
+ return (*vp->ops->name) (vp, buffer + 1, head - buffer - 1);
+}
+
+
+
+/* Initialize the virtual filesystem layer. Load the directory tree
+ from the given asset MANAGER (which should be a local reference
+ within ENV) that will be used to access assets in the future, and
+ create the root vnode.
+
+ ENV should be a JNI environment valid for future calls to VFS
+ functions. */
+
+void
+android_vfs_init (JNIEnv *env, jobject manager)
+{
+ jclass old;
+
+ android_init_assets (env, manager);
+
+ /* Create the root vnode, which is used to locate all other
+ vnodes. */
+ root_vnode.vnode.ops = &root_vfs_ops;
+ root_vnode.vnode.type = ANDROID_VNODE_UNIX;
+ root_vnode.vnode.flags = 0;
+ root_vnode.name_length = 1;
+ root_vnode.name = (char *) "/";
+
+ /* Initialize some required classes. */
+ java_string_class = (*env)->FindClass (env, "java/lang/String");
+ eassert (java_string_class);
+
+ old = java_string_class;
+ java_string_class = (jclass) (*env)->NewGlobalRef (env,
+ java_string_class);
+ eassert (java_string_class);
+ (*env)->DeleteLocalRef (env, old);
+
+ /* And initialize those used on Android 5.0 and later. */
+
+ if (android_get_current_api_level () < 21)
+ return;
+
+ android_init_cursor_class (env);
+ android_init_entry_class (env);
+ android_init_fd_class (env);
+
+ /* Initialize each of the exception classes used by
+ `android_saf_exception_check'. */
+
+ old = (*env)->FindClass (env, "java/io/FileNotFoundException");
+ file_not_found_exception = (*env)->NewGlobalRef (env, old);
+ (*env)->DeleteLocalRef (env, old);
+ eassert (file_not_found_exception);
+
+ old = (*env)->FindClass (env, "java/lang/SecurityException");
+ security_exception = (*env)->NewGlobalRef (env, old);
+ (*env)->DeleteLocalRef (env, old);
+ eassert (security_exception);
+
+ old = (*env)->FindClass (env, "android/os/OperationCanceledException");
+ operation_canceled_exception = (*env)->NewGlobalRef (env, old);
+ (*env)->DeleteLocalRef (env, old);
+ eassert (operation_canceled_exception);
+
+ old = (*env)->FindClass (env, "java/lang/UnsupportedOperationException");
+ unsupported_operation_exception = (*env)->NewGlobalRef (env, old);
+ (*env)->DeleteLocalRef (env, old);
+ eassert (unsupported_operation_exception);
+
+ old = (*env)->FindClass (env, "java/lang/OutOfMemoryError");
+ out_of_memory_error = (*env)->NewGlobalRef (env, old);
+ (*env)->DeleteLocalRef (env, old);
+ eassert (out_of_memory_error);
+
+ /* Initialize the semaphore used to wait for SAF operations to
+ complete. */
+
+ if (sem_init (&saf_completion_sem, 0, 0) < 0)
+ emacs_abort ();
+}
+
+/* The replacement functions that follow have several major
+ drawbacks:
+
+ The first is that CWD relative file names will always be Unix
+ vnodes, and looking up their parents will always return another
+ Unix vnode. For example, with the working directory set to
+ /sdcard:
+
+ ../content/storage
+
+ will find /sdcard/../content/storage on the Unix filesystem,
+ opposed to /content/storage within the ``content'' VFS.
+
+ Emacs only uses file names expanded through `expand-file-name', so
+ this is unproblematic in practice.
+
+ The second is that `..' components do not usually check that their
+ preceding component is a directory. This is a side effect of their
+ removal from file names as part of a pre-processing step before
+ they are opened. So, even if:
+
+ /sdcard/foo.txt
+
+ is a file, opening the directory:
+
+ /sdcard/foo.txt/..
+
+ will be successful.
+
+ The third is that the handling of `..' components relative to
+ another vnode hasn't been tested and is only assumed to work
+ because the code has been written. It does not pose a practical
+ problem, however, as Emacs only names files starting from the root
+ vnode.
+
+ The fourth is that errno values from vnode operations don't always
+ reflect what the Unix system calls they emulate can return: for
+ example, `open' may return EIO, while trying to `mkdir' within
+ /content will return ENOENT instead of EROFS. This is a
+ consequence of how accessing a non-existent file may fail at vnode
+ lookup, instead of when a vop is used. This problem hasn't made a
+ sufficient nuisance of itself to justify its fix yet.
+
+ The fifth is that trailing directory separators may be lost when
+ naming files relative to another vnode, as a consequence of an
+ optimization used to avoid allocating too much stack or heap
+ space.
+
+ The sixth is that flags and other argument checking is nowhere near
+ exhaustive on vnode types other than Unix vnodes.
+
+ The seventh is that certain vnode types may read async input and
+ return EINTR not upon the arrival of a signal itself, but instead
+ if subsequently read input causes Vquit_flag to be set. These
+ vnodes may not be reentrant, but operating on them from within an
+ async input handler will at worst cause an error to be returned.
+
+ The eight is that some vnode types do not support O_APPEND.
+
+ And the final drawback is that directories cannot be directly
+ opened. Instead, `dirfd' must be called on a directory stream used
+ by `openat'.
+
+ Caveat emptor! */
+
+/* Open the VFS node designated by NAME, taking into account FLAGS and
+ MODE, both of which mean the same as they do in a call to `open'.
+
+ Value is -1 upon failure with errno set accordingly, and a file
+ descriptor otherwise. */
+
+int
+android_open (const char *name, int flags, mode_t mode)
+{
+ struct android_vnode *vp;
+ int fd, rc;
+
+ vp = android_name_file (name);
+ if (!vp)
+ return -1;
+
+ rc = (*vp->ops->open) (vp, flags, mode, false, &fd, NULL);
+ (*vp->ops->close) (vp);
+
+ if (rc < 0)
+ return -1;
+
+ /* If rc is 1, then an asset file descriptor has been returned.
+ This is impossible, so assert that it doesn't transpire. */
+ assert (rc != 1);
+ return fd;
+}
+
+/* Unlink the VFS node designated by the specified FILE.
+ Value is -1 upon failure with errno set, and 0 otherwise. */
+
+int
+android_unlink (const char *name)
+{
+ struct android_vnode *vp;
+ int rc;
+
+ vp = android_name_file (name);
+ if (!vp)
+ return -1;
+
+ rc = (*vp->ops->unlink) (vp);
+ (*vp->ops->close) (vp);
+ return rc;
+}
+
+/* Symlink the VFS node designated by LINKPATH to TARGET.
+ Value is -1 upon failure with errno set, and 0 otherwise. */
+
+int
+android_symlink (const char *target, const char *linkpath)
+{
+ struct android_vnode *vp;
+ int rc;
+
+ vp = android_name_file (linkpath);
+ if (!vp)
+ return -1;
+
+ rc = (*vp->ops->symlink) (target, vp);
+ (*vp->ops->close) (vp);
+ return rc;
+}
+
+/* Remove the empty directory at the VFS node designated by NAME.
+ Value is -1 upon failure with errno set, and 0 otherwise. */
+
+int
+android_rmdir (const char *name)
+{
+ struct android_vnode *vp;
+ int rc;
+
+ vp = android_name_file (name);
+ if (!vp)
+ return -1;
+
+ rc = (*vp->ops->rmdir) (vp);
+ (*vp->ops->close) (vp);
+ return rc;
+}
+
+/* Create a directory at the VFS node designated by NAME and the given
+ access MODE. Value is -1 upon failure with errno set, 0
+ otherwise. */
+
+int
+android_mkdir (const char *name, mode_t mode)
+{
+ struct android_vnode *vp;
+ int rc;
+
+ vp = android_name_file (name);
+ if (!vp)
+ return -1;
+
+ rc = (*vp->ops->mkdir) (vp, mode);
+ (*vp->ops->close) (vp);
+ return rc;
+}
+
+/* Rename the vnode designated by SRC to the vnode designated by DST.
+ If DST already exists, return -1 and set errno to EEXIST.
+
+ SRCFD and DSTFD should be AT_FDCWD, or else value is -1 and errno
+ is ENOSYS.
+
+ If the filesystem or vnodes containing either DST or SRC does not
+ support rename operations that also check for a preexisting
+ destination, return -1 and set errno to ENOSYS.
+
+ Otherwise, value and errno are identical to that of Unix
+ `rename' with the same arguments. */
+
+int
+android_renameat_noreplace (int srcfd, const char *src,
+ int dstfd, const char *dst)
+{
+ struct android_vnode *vp, *vdst;
+ int rc;
+
+ if (srcfd != AT_FDCWD || dstfd != AT_FDCWD)
+ {
+ errno = ENOSYS;
+ return -1;
+ }
+
+ /* Find vnodes for both src and dst. */
+
+ vp = android_name_file (src);
+ if (!vp)
+ goto error;
+
+ vdst = android_name_file (dst);
+ if (!vdst)
+ goto error1;
+
+ /* Now try to rename vp to vdst. */
+ rc = (*vp->ops->rename) (vp, vdst, true);
+ (*vp->ops->close) (vp);
+ (*vdst->ops->close) (vdst);
+ return rc;
+
+ error1:
+ (*vp->ops->close) (vp);
+ error:
+ return -1;
+}
+
+/* Like `android_renameat_noreplace', but don't check for DST's
+ existence and don't accept placeholder SRCFD and DSTFD
+ arguments. */
+
+int
+android_rename (const char *src, const char *dst)
+{
+ struct android_vnode *vp, *vdst;
+ int rc;
+
+ /* Find vnodes for both src and dst. */
+
+ vp = android_name_file (src);
+ if (!vp)
+ goto error;
+
+ vdst = android_name_file (dst);
+ if (!vdst)
+ goto error1;
+
+ /* Now try to rename vp to vdst. */
+ rc = (*vp->ops->rename) (vp, vdst, false);
+ (*vp->ops->close) (vp);
+ (*vdst->ops->close) (vdst);
+ return rc;
+
+ error1:
+ (*vp->ops->close) (vp);
+ error:
+ return -1;
+}
+
+
+
+/* fstat, fstatat, faccessat, close/fclose etc. These functions are
+ somewhat tricky to wrap: they (at least partially) operate on file
+ descriptors, which sometimes provide a base directory for the
+ filesystem operations they perform. VFS nodes aren't mapped to
+ file descriptors opened through them, which makes this troublesome.
+
+ openat is not wrapped at all; uses are defined out when Emacs is
+ being built for Android. The other functions fall back to directly
+ making Unix system calls when their base directory arguments are
+ not AT_FDCWD and no directory stream returned from
+ `android_opendir' ever returned that file descriptor, which is
+ enough to satisfy Emacs's current requirements for those functions
+ when a directory file descriptor is supplied.
+
+ fclose and close are finally wrapped because they need to erase
+ information used to link file descriptors with file statistics from
+ their origins; fstat is also wrapped to take this information into
+ account, so that it can return correct file statistics for asset
+ directory files. */
+
+/* Like fstat. However, look up the asset corresponding to the file
+ descriptor. If it exists, return the right information. */
+
+int
+android_fstat (int fd, struct stat *statb)
+{
+ struct android_afs_open_fd *tem;
+ struct android_parcel_fd *parcel_fd;
+ int rc;
+
+ for (tem = afs_file_descriptors; tem; tem = tem->next)
+ {
+ if (tem->fd == fd)
+ {
+ memcpy (statb, &tem->statb, sizeof *statb);
+ return 0;
+ }
+ }
+
+ rc = fstat (fd, statb);
+
+ /* Now look for a matching parcel file descriptor and use its
+ mtime if available. */
+
+ parcel_fd = open_parcel_fds;
+ for (; parcel_fd; parcel_fd = parcel_fd->next)
+ {
+ if (parcel_fd->fd == fd)
+ /* Set STATB->st_dev to a negative device number, signifying
+ that it's contained within a content provider. */
+ statb->st_dev = -4;
+
+ if (parcel_fd->fd == fd
+ && timespec_valid_p (parcel_fd->mtime))
+ {
+#ifdef STAT_TIMESPEC
+ STAT_TIMESPEC (statb, st_mtim) = parcel_fd->mtime;
+#else /* !STAT_TIMESPEC */
+ statb->st_mtime = parcel_fd->mtime.tv_sec;
+ statb->st_mtime_nsec = parcel_fd->mtime.tv_nsec;
+#endif /* STAT_TIMESPEC */
+ break;
+ }
+ }
+
+ return rc;
+}
+
+/* If DIRFD is a file descriptor returned by `android_readdir' for a
+ non-Unix file stream, return FILENAME relative to the file name of
+ the directory represented by that stream within BUFFER, a buffer
+ SIZE bytes long.
+
+ Value is 0 if a file name is returned, 1 otherwise. */
+
+static int
+android_fstatat_1 (int dirfd, const char *filename,
+ char *restrict buffer, size_t size)
+{
+ char *dir_name;
+ struct android_saf_root_vdir *vdir;
+ struct android_saf_tree_vdir *vdir1;
+
+ /* Now establish whether DIRFD is a file descriptor corresponding to
+ an open asset directory stream. */
+
+ dir_name = android_afs_get_directory_name (dirfd);
+
+ if (dir_name)
+ {
+ /* Look for PATHNAME relative to this directory within an asset
+ vnode. */
+ snprintf (buffer, size, "/assets%s%s", dir_name,
+ filename);
+ return 0;
+ }
+
+ /* Do the same, but for /content directories instead. */
+
+ dir_name = android_content_get_directory_name (dirfd);
+
+ if (dir_name)
+ {
+ /* Look for PATHNAME relative to this directory within an asset
+ vnode. */
+ snprintf (buffer, size, "%s/%s", dir_name,
+ filename);
+ return 0;
+ }
+
+ /* And for /content/storage. */
+
+ vdir = android_saf_root_get_directory (dirfd);
+
+ if (vdir)
+ {
+ if (vdir->authority)
+ snprintf (buffer, size, "/content/storage/%s/%s",
+ vdir->authority, filename);
+ else
+ snprintf (buffer, size, "/content/storage/%s",
+ filename);
+
+ return 0;
+ }
+
+ /* /content/storage/foo/... */
+
+ vdir1 = android_saf_tree_get_directory (dirfd);
+
+ if (vdir1)
+ {
+ snprintf (buffer, size, "%s%s", vdir1->name, filename);
+ return 0;
+ }
+
+ return 1;
+}
+
+/* If DIRFD is AT_FDCWD or a file descriptor returned by
+ `android_dirfd', or PATHNAME is an absolute file name, return the
+ file status of the VFS node designated by PATHNAME relative to the
+ VFS node corresponding to DIRFD, or relative to the current working
+ directory if DIRFD is AT_FDCWD.
+
+ Otherwise, call `fstatat' with DIRFD, PATHNAME, STATBUF and
+ FLAGS. */
+
+int
+android_fstatat (int dirfd, const char *restrict pathname,
+ struct stat *restrict statbuf, int flags)
+{
+ char buffer[EMACS_PATH_MAX + 1];
+ struct android_vnode *vp;
+ int rc;
+
+ /* Emacs uses AT_SYMLINK_NOFOLLOW, but fortunately (?) DIRFD is
+ never known to Emacs or AT_FDCWD when it originates from a VFS
+ node representing a filesystem that supports symlinks. */
+
+ if (dirfd == AT_FDCWD || pathname[0] == '/')
+ goto vfs;
+
+ /* Now establish whether DIRFD is a file descriptor corresponding to
+ an open VFS directory stream. */
+
+ if (!android_fstatat_1 (dirfd, pathname, buffer, EMACS_PATH_MAX + 1))
+ {
+ pathname = buffer;
+ goto vfs;
+ }
+
+ /* Fall back to fstatat. */
+ return fstatat (dirfd, pathname, statbuf, flags);
+
+ vfs:
+ vp = android_name_file (pathname);
+ if (!vp)
+ return -1;
+
+ rc = (*vp->ops->stat) (vp, statbuf);
+ (*vp->ops->close) (vp);
+ return rc;
+}
+
+/* Like `android_fstatat', but check file accessibility instead of
+ status. */
+
+int
+android_faccessat (int dirfd, const char *restrict pathname,
+ int mode, int flags)
+{
+ char buffer[EMACS_PATH_MAX + 1];
+ struct android_vnode *vp;
+ int rc;
+
+ /* Emacs uses AT_SYMLINK_NOFOLLOW, but fortunately (?) DIRFD is
+ never known to Emacs or AT_FDCWD when it originates from a VFS
+ node representing a filesystem that supports symlinks. */
+
+ if (dirfd == AT_FDCWD || pathname[0] == '/')
+ goto vfs;
+
+ /* Now establish whether DIRFD is a file descriptor corresponding to
+ an open VFS directory stream. */
+
+ if (!android_fstatat_1 (dirfd, pathname, buffer, EMACS_PATH_MAX + 1))
+ {
+ pathname = buffer;
+ goto vfs;
+ }
+
+ /* Fall back to faccessat. */
+ return faccessat (dirfd, pathname, mode, flags);
+
+ vfs:
+ vp = android_name_file (pathname);
+ if (!vp)
+ return -1;
+
+ rc = (*vp->ops->access) (vp, mode);
+ (*vp->ops->close) (vp);
+ return rc;
+}
+
+/* Like `android_fstatat', but set file modes instead of
+ checking file status and respect FLAGS. */
+
+int
+android_fchmodat (int dirfd, const char *pathname, mode_t mode,
+ int flags)
+{
+ char buffer[EMACS_PATH_MAX + 1];
+ struct android_vnode *vp;
+ int rc;
+
+ if (dirfd == AT_FDCWD || pathname[0] == '/')
+ goto vfs;
+
+ /* Now establish whether DIRFD is a file descriptor corresponding to
+ an open VFS directory stream. */
+
+ if (!android_fstatat_1 (dirfd, pathname, buffer, EMACS_PATH_MAX + 1))
+ {
+ pathname = buffer;
+ goto vfs;
+ }
+
+ /* Fall back to fchmodat. */
+ return fchmodat (dirfd, pathname, mode, flags);
+
+ vfs:
+ vp = android_name_file (pathname);
+ if (!vp)
+ return -1;
+
+ rc = (*vp->ops->chmod) (vp, mode, flags);
+ (*vp->ops->close) (vp);
+ return rc;
+}
+
+/* Like `android_fstatat', but return the target of any symbolic link
+ at PATHNAME instead of checking file status. */
+
+ssize_t
+android_readlinkat (int dirfd, const char *restrict pathname,
+ char *restrict buf, size_t bufsiz)
+{
+ char buffer[EMACS_PATH_MAX + 1];
+ struct android_vnode *vp;
+ ssize_t rc;
+
+ if (dirfd == AT_FDCWD || pathname[0] == '/')
+ goto vfs;
+
+ /* Now establish whether DIRFD is a file descriptor corresponding to
+ an open VFS directory stream. */
+
+ if (!android_fstatat_1 (dirfd, pathname, buffer, EMACS_PATH_MAX + 1))
+ {
+ pathname = buffer;
+ goto vfs;
+ }
+
+ /* Fall back to readlinkat. */
+ return readlinkat (dirfd, pathname, buf, bufsiz);
+
+ vfs:
+ vp = android_name_file (pathname);
+ if (!vp)
+ return -1;
+
+ rc = (*vp->ops->readlink) (vp, buf, bufsiz);
+ (*vp->ops->close) (vp);
+ return rc;
+}
+
+/* Like `fdopen', but if FD is a parcel file descriptor, ``detach'' it
+ from the original.
+
+ This is necessary because ownership over parcel file descriptors is
+ retained by the ParcelFileDescriptor objects that return them,
+ while file streams also require ownership over file descriptors
+ they are created on behalf of.
+
+ Detaching the parcel file descriptor linked to FD consequently
+ prevents the owner from being notified when it is eventually
+ closed, but for now that hasn't been demonstrated to be problematic
+ yet, as Emacs doesn't write to file streams. */
+
+FILE *
+android_fdopen (int fd, const char *mode)
+{
+ struct android_parcel_fd *tem, **next, *temp;
+ int new_fd;
+
+ for (next = &open_parcel_fds; (tem = *next);)
+ {
+ if (tem->fd == fd)
+ {
+ new_fd
+ = (*android_java_env)->CallIntMethod (android_java_env,
+ tem->descriptor,
+ fd_class.detach_fd);
+ temp = tem->next;
+ xfree (tem);
+ *next = temp;
+ android_exception_check ();
+
+ /* Assert that FD (returned from `getFd') is identical to
+ the file descriptor returned by `detachFd'. */
+
+ if (fd != new_fd)
+ emacs_abort ();
+
+ break;
+ }
+ else
+ next = &(*next)->next;
+ }
+
+ return fdopen (fd, mode);
+}
+
+/* Like close. However, remove the file descriptor from the asset
+ table as well. */
+
+int
+android_close (int fd)
+{
+ struct android_afs_open_fd *tem, **next, *temp;
+
+ if (android_close_parcel_fd (fd))
+ return 0;
+
+ for (next = &afs_file_descriptors; (tem = *next);)
+ {
+ if (tem->fd == fd)
+ {
+ temp = tem->next;
+ xfree (tem);
+ *next = temp;
+
+ break;
+ }
+ else
+ next = &(*next)->next;
+ }
+
+ return close (fd);
+}
+
+/* Like fclose. However, remove any information associated with
+ FILE's file descriptor from the asset table as well. */
+
+int
+android_fclose (FILE *stream)
+{
+ int fd;
+ struct android_afs_open_fd *tem, **next, *temp;
+
+ fd = fileno (stream);
+
+ if (fd == -1)
+ goto skip;
+
+ for (next = &afs_file_descriptors; (tem = *next);)
+ {
+ if (tem->fd == fd)
+ {
+ temp = tem->next;
+ xfree (*next);
+ *next = temp;
+
+ break;
+ }
+ else
+ next = &(*next)->next;
+ }
+
+ skip:
+ return fclose (stream);
+}
+
+
+
+/* External asset management interface. By using functions here
+ to read and write from files, Emacs can avoid opening a
+ shared memory file descriptor for each ``asset'' file. */
+
+/* Like android_open. However, return a structure that can
+ either directly hold an AAsset or a file descriptor.
+
+ Value is the structure upon success. Upon failure, value
+ consists of an uninitialized file descriptor, but its asset
+ field is set to -1, and errno is set accordingly. */
+
+struct android_fd_or_asset
+android_open_asset (const char *filename, int oflag, mode_t mode)
+{
+ struct android_fd_or_asset fd;
+ AAsset *asset;
+ int rc;
+ struct android_vnode *vp;
+
+ /* Now name this file. */
+ vp = android_name_file (filename);
+ if (!vp)
+ goto failure;
+
+ rc = (*vp->ops->open) (vp, oflag, mode, true, &fd.fd,
+ &asset);
+ (*vp->ops->close) (vp);
+
+ /* Upon failure, return fd with its asset field set to (void *)
+ -1. */
+
+ if (rc < 0)
+ {
+ failure:
+ fd.asset = (void *) -1;
+ fd.fd = -1;
+ return fd;
+ }
+
+ if (rc == 1)
+ {
+ /* An asset file was returned. Return the structure containing
+ an asset. */
+ fd.asset = asset;
+ fd.fd = -1;
+ return fd;
+ }
+
+ /* Otherwise, a file descriptor has been returned. Set fd.asset to
+ NULL, signifying that it is a file descriptor. */
+ fd.asset = NULL;
+ return fd;
+}
+
+/* Like android_close. However, it takes a ``file descriptor''
+ opened using android_open_asset. */
+
+int
+android_close_asset (struct android_fd_or_asset asset)
+{
+ if (!asset.asset)
+ return android_close (asset.fd);
+
+ AAsset_close (asset.asset);
+ return 0;
+}
+
+/* Like `emacs_read_quit'. However, it handles file descriptors
+ opened using `android_open_asset' as well. */
+
+ssize_t
+android_asset_read_quit (struct android_fd_or_asset asset,
+ void *buffer, size_t size)
+{
+ if (!asset.asset)
+ return emacs_read_quit (asset.fd, buffer, size);
+
+ /* It doesn't seem possible to quit from inside AAsset_read,
+ sadly. */
+ return AAsset_read (asset.asset, buffer, size);
+}
+
+/* Like `read'. However, it handles file descriptors opened
+ using `android_open_asset' as well. */
+
+ssize_t
+android_asset_read (struct android_fd_or_asset asset,
+ void *buffer, size_t size)
+{
+ if (!asset.asset)
+ return read (asset.fd, buffer, size);
+
+ /* It doesn't seem possible to quit from inside AAsset_read,
+ sadly. */
+ return AAsset_read (asset.asset, buffer, size);
+}
+
+/* Like `lseek', but it handles ``file descriptors'' opened with
+ android_open_asset. */
+
+off_t
+android_asset_lseek (struct android_fd_or_asset asset, off_t off,
+ int whence)
+{
+ if (!asset.asset)
+ return lseek (asset.fd, off, whence);
+
+ return AAsset_seek (asset.asset, off, whence);
+}
+
+/* Like `fstat'. */
+
+int
+android_asset_fstat (struct android_fd_or_asset asset,
+ struct stat *statb)
+{
+ if (!asset.asset)
+ return android_fstat (asset.fd, statb);
+
+ /* Clear statb. */
+ memset (statb, 0, sizeof *statb);
+
+ /* Set the mode. */
+ statb->st_mode = S_IFREG | S_IRUSR | S_IRGRP | S_IROTH;
+
+ /* Concoct a nonexistent device and an inode number. */
+ statb->st_dev = -1;
+ statb->st_ino = 0;
+
+ /* Owned by root. */
+ statb->st_uid = 0;
+ statb->st_gid = 0;
+
+ /* If the installation date can be ascertained, return that as the
+ file's modification time. */
+
+ if (timespec_valid_p (emacs_installation_time))
+ {
+#ifdef STAT_TIMESPEC
+ STAT_TIMESPEC (statb, st_mtim) = emacs_installation_time;
+#else /* !STAT_TIMESPEC */
+ /* Headers supplied by the NDK r10b contain a `struct stat'
+ without POSIX fields for nano-second timestamps. */
+ statb->st_mtime = emacs_installation_time.tv_sec;
+ statb->st_mtime_nsec = emacs_installation_time.tv_nsec;
+#endif /* STAT_TIMESPEC */
+ }
+
+ /* Size of the file. */
+ statb->st_size = AAsset_getLength (asset.asset);
+ return 0;
+}
+
+
+
+/* Directory listing emulation. */
+
+/* Open a directory stream from the VFS node designated by NAME.
+ Value is NULL upon failure with errno set accordingly. `errno' may
+ be set to EINTR.
+
+ The directory stream returned holds local references to JNI objects
+ and shouldn't be used after the current local reference frame is
+ popped. */
+
+struct android_vdir *
+android_opendir (const char *name)
+{
+ struct android_vnode *vp;
+ struct android_vdir *dir;
+
+ vp = android_name_file (name);
+ if (!vp)
+ return NULL;
+
+ dir = (*vp->ops->opendir) (vp);
+ (*vp->ops->close) (vp);
+ return dir;
+}
+
+/* Like dirfd. However, value is not a real directory file descriptor
+ if DIR is an asset directory. */
+
+int
+android_dirfd (struct android_vdir *dirp)
+{
+ return (*dirp->dirfd) (dirp);
+}
+
+/* Like readdir, but for VFS directory streams instead. */
+
+struct dirent *
+android_readdir (struct android_vdir *dirp)
+{
+ return (*dirp->readdir) (dirp);
+}
+
+/* Like closedir, but for VFS directory streams instead. */
+
+void
+android_closedir (struct android_vdir *dirp)
+{
+ return (*dirp->closedir) (dirp);
+}
+
+
+
+void
+syms_of_androidvfs (void)
+{
+ DEFSYM (Qandroid_jni, "android-jni");
+}
diff --git a/src/bidi.c b/src/bidi.c
index 90c0061549a..bdf60001781 100644
--- a/src/bidi.c
+++ b/src/bidi.c
@@ -420,7 +420,7 @@ bidi_paired_bracket_type (int c)
static void
bidi_set_sos_type (struct bidi_it *bidi_it, int level_before, int level_after)
{
- int higher_level = (level_before > level_after ? level_before : level_after);
+ int higher_level = max (level_before, level_after);
/* FIXME: should the default sos direction be user selectable? */
bidi_it->sos = ((higher_level & 1) != 0 ? R2L : L2R); /* X10 */
@@ -754,6 +754,19 @@ bidi_cache_find_level_change (int level, int dir, bool before)
return -1;
}
+/* Find the previous character position where LEVEL changes to a lower
+ one. Return -1 if not found (which really shouldn't happen if this
+ function is called on a backward scan). */
+ptrdiff_t
+bidi_level_start (int level)
+{
+ ptrdiff_t slot = bidi_cache_find_level_change (level, -1, true);
+
+ if (slot >= 0)
+ return bidi_cache[slot].charpos;
+ return -1;
+}
+
static void
bidi_cache_ensure_space (ptrdiff_t idx)
{
diff --git a/src/bignum.c b/src/bignum.c
index b777e6c05aa..1fe195d78ea 100644
--- a/src/bignum.c
+++ b/src/bignum.c
@@ -354,7 +354,7 @@ emacs_mpz_pow_ui (mpz_t rop, mpz_t const base, unsigned long exp)
enum { lim = min (NLIMBS_LIMIT, GMP_NLIMBS_MAX - pow_ui_extra_limbs) };
int nbase = emacs_mpz_size (base), n;
- if (INT_MULTIPLY_WRAPV (nbase, exp, &n) || lim < n)
+ if (ckd_mul (&n, nbase, exp) || lim < n)
overflow_error ();
mpz_pow_ui (rop, base, exp);
}
diff --git a/src/buffer.c b/src/buffer.c
index 32a05010311..291c7d3f911 100644
--- a/src/buffer.c
+++ b/src/buffer.c
@@ -50,6 +50,14 @@ along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. */
#include "w32heap.h" /* for mmap_* */
#endif
+/* Work around GCC bug 109847
+ https://gcc.gnu.org/bugzilla/show_bug.cgi?id=109847
+ which causes GCC to mistakenly complain about
+ AUTO_STRING with "*scratch*". */
+#if GNUC_PREREQ (13, 0, 0)
+# pragma GCC diagnostic ignored "-Wanalyzer-out-of-bounds"
+#endif
+
/* This structure holds the default values of the buffer-local variables
defined with DEFVAR_PER_BUFFER, that have special slots in each buffer.
The default value occupies the same slot in this structure
@@ -202,11 +210,6 @@ bset_buffer_file_coding_system (struct buffer *b, Lisp_Object val)
b->buffer_file_coding_system_ = val;
}
static void
-bset_case_fold_search (struct buffer *b, Lisp_Object val)
-{
- b->case_fold_search_ = val;
-}
-static void
bset_ctl_arrow (struct buffer *b, Lisp_Object val)
{
b->ctl_arrow_ = val;
@@ -324,6 +327,11 @@ bset_name (struct buffer *b, Lisp_Object val)
b->name_ = val;
}
static void
+bset_last_name (struct buffer *b, Lisp_Object val)
+{
+ b->last_name_ = val;
+}
+static void
bset_overwrite_mode (struct buffer *b, Lisp_Object val)
{
b->overwrite_mode_ = val;
@@ -511,8 +519,11 @@ See also `find-buffer-visiting'. */)
return Qnil;
}
-Lisp_Object
-get_truename_buffer (register Lisp_Object filename)
+DEFUN ("get-truename-buffer", Fget_truename_buffer, Sget_truename_buffer, 1, 1, 0,
+ doc: /* Return the buffer with `file-truename' equal to FILENAME (a string).
+If there is no such live buffer, return nil.
+See also `find-buffer-visiting'. */)
+ (register Lisp_Object filename)
{
register Lisp_Object tail, buf;
@@ -525,6 +536,22 @@ get_truename_buffer (register Lisp_Object filename)
return Qnil;
}
+DEFUN ("find-buffer", Ffind_buffer, Sfind_buffer, 2, 2, 0,
+ doc: /* Return the buffer with buffer-local VARIABLE `equal' to VALUE.
+If there is no such live buffer, return nil.
+See also `find-buffer-visiting'. */)
+ (Lisp_Object variable, Lisp_Object value)
+{
+ register Lisp_Object tail, buf;
+
+ FOR_EACH_LIVE_BUFFER (tail, buf)
+ {
+ if (!NILP (Fequal (value, Fbuffer_local_value (variable, buf))))
+ return buf;
+ }
+ return Qnil;
+}
+
/* Run buffer-list-update-hook if Vrun_hooks is non-nil and BUF does
not have buffer hooks inhibited. */
@@ -625,6 +652,7 @@ even if it is dead. The return value is never nil. */)
name = Fcopy_sequence (buffer_or_name);
set_string_intervals (name, NULL);
bset_name (b, name);
+ bset_last_name (b, name);
b->inhibit_buffer_hooks = !NILP (inhibit_buffer_hooks);
bset_undo_list (b, SREF (name, 0) != ' ' ? Qnil : Qt);
@@ -844,6 +872,7 @@ Interactively, CLONE and INHIBIT-BUFFER-HOOKS are nil. */)
name = Fcopy_sequence (name);
set_string_intervals (name, NULL);
bset_name (b, name);
+ bset_last_name (b, name);
/* An indirect buffer shares undo list of its base (Bug#18180). */
bset_undo_list (b, BVAR (b->base_buffer, undo_list));
@@ -1260,6 +1289,17 @@ Return nil if BUFFER has been killed. */)
return BVAR (decode_buffer (buffer), name);
}
+DEFUN ("buffer-last-name", Fbuffer_last_name, Sbuffer_last_name, 0, 1, 0,
+ doc: /* Return last name of BUFFER, as a string.
+BUFFER defaults to the current buffer.
+
+This is the name BUFFER had before the last time it was renamed or
+immediately before it was killed. */)
+ (Lisp_Object buffer)
+{
+ return BVAR (decode_buffer (buffer), last_name);
+}
+
DEFUN ("buffer-file-name", Fbuffer_file_name, Sbuffer_file_name, 0, 1, 0,
doc: /* Return name of file BUFFER is visiting, or nil if none.
No argument or nil as argument means use the current buffer. */)
@@ -1313,7 +1353,7 @@ buffer_local_value (Lisp_Object variable, Lisp_Object buffer)
start:
switch (sym->u.s.redirect)
{
- case SYMBOL_VARALIAS: sym = indirect_variable (sym); goto start;
+ case SYMBOL_VARALIAS: sym = SYMBOL_ALIAS (sym); goto start;
case SYMBOL_PLAINVAL: result = SYMBOL_VAL (sym); break;
case SYMBOL_LOCALIZED:
{ /* Look in local_var_alist. */
@@ -1630,6 +1670,7 @@ This does not change the name of the visited file (if any). */)
(register Lisp_Object newname, Lisp_Object unique)
{
register Lisp_Object tem, buf;
+ Lisp_Object oldname = BVAR (current_buffer, name);
Lisp_Object requestedname = newname;
CHECK_STRING (newname);
@@ -1647,12 +1688,12 @@ This does not change the name of the visited file (if any). */)
if (NILP (unique) && XBUFFER (tem) == current_buffer)
return BVAR (current_buffer, name);
if (!NILP (unique))
- newname = Fgenerate_new_buffer_name (newname,
- BVAR (current_buffer, name));
+ newname = Fgenerate_new_buffer_name (newname, oldname);
else
error ("Buffer name `%s' is in use", SDATA (newname));
}
+ bset_last_name (current_buffer, oldname);
bset_name (current_buffer, newname);
/* Catch redisplay's attention. Unless we do this, the mode lines for
@@ -1737,7 +1778,7 @@ exists, return the buffer `*scratch*' (creating it if necessary). */)
if (!NILP (notsogood))
return notsogood;
else
- return safe_call (1, Qget_scratch_buffer_create);
+ return safe_calln (Qget_scratch_buffer_create);
}
/* The following function is a safe variant of Fother_buffer: It doesn't
@@ -1758,7 +1799,7 @@ other_buffer_safely (Lisp_Object buffer)
becoming dead under our feet. safe_call below could return nil
if recreating *scratch* in Lisp, which does some fancy stuff,
signals an error in some weird use case. */
- buf = safe_call (1, Qget_scratch_buffer_create);
+ buf = safe_calln (Qget_scratch_buffer_create);
if (NILP (buf))
{
AUTO_STRING (scratch, "*scratch*");
@@ -1949,8 +1990,16 @@ cleaning up all windows currently displaying the buffer to be killed. */)
Lisp_Object tail, other;
FOR_EACH_LIVE_BUFFER (tail, other)
- if (XBUFFER (other)->base_buffer == b)
- Fkill_buffer (other);
+ {
+ struct buffer *obuf = XBUFFER (other);
+ if (obuf->base_buffer == b)
+ {
+ Fkill_buffer (other);
+ if (BUFFER_LIVE_P (obuf))
+ error ("Unable to kill buffer whose indirect buffer `%s' cannot be killed",
+ SDATA (BVAR (obuf, name)));
+ }
+ }
/* Exit if we now have killed the base buffer (Bug#11665). */
if (!BUFFER_LIVE_P (b))
@@ -2065,6 +2114,7 @@ cleaning up all windows currently displaying the buffer to be killed. */)
This gets rid of them for certain. */
reset_buffer_local_variables (b, 1);
+ bset_last_name (b, BVAR (b, name));
bset_name (b, Qnil);
block_input ();
@@ -2986,7 +3036,7 @@ the normal hook `change-major-mode-hook'. */)
But still return the total number of overlays.
*/
-ptrdiff_t
+static ptrdiff_t
overlays_in (ptrdiff_t beg, ptrdiff_t end, bool extend,
Lisp_Object **vec_ptr, ptrdiff_t *len_ptr,
bool empty, bool trailing,
@@ -3109,56 +3159,38 @@ mouse_face_overlay_overlaps (Lisp_Object overlay)
{
ptrdiff_t start = OVERLAY_START (overlay);
ptrdiff_t end = OVERLAY_END (overlay);
- ptrdiff_t n, i, size;
- Lisp_Object *v, tem;
- Lisp_Object vbuf[10];
- USE_SAFE_ALLOCA;
+ Lisp_Object tem;
+ struct itree_node *node;
- size = ARRAYELTS (vbuf);
- v = vbuf;
- n = overlays_in (start, end, 0, &v, &size, true, false, NULL);
- if (n > size)
+ ITREE_FOREACH (node, current_buffer->overlays,
+ start, min (end, ZV) + 1,
+ ASCENDING)
{
- SAFE_NALLOCA (v, 1, n);
- overlays_in (start, end, 0, &v, &n, true, false, NULL);
+ if (node->begin < end && node->end > start
+ && node->begin < node->end
+ && !EQ (node->data, overlay)
+ && (tem = Foverlay_get (overlay, Qmouse_face),
+ !NILP (tem)))
+ return true;
}
-
- for (i = 0; i < n; ++i)
- if (!EQ (v[i], overlay)
- && (tem = Foverlay_get (overlay, Qmouse_face),
- !NILP (tem)))
- break;
-
- SAFE_FREE ();
- return i < n;
+ return false;
}
/* Return the value of the 'display-line-numbers-disable' property at
EOB, if there's an overlay at ZV with a non-nil value of that property. */
-Lisp_Object
+bool
disable_line_numbers_overlay_at_eob (void)
{
- ptrdiff_t n, i, size;
- Lisp_Object *v, tem = Qnil;
- Lisp_Object vbuf[10];
- USE_SAFE_ALLOCA;
+ Lisp_Object tem = Qnil;
+ struct itree_node *node;
- size = ARRAYELTS (vbuf);
- v = vbuf;
- n = overlays_in (ZV, ZV, 0, &v, &size, false, false, NULL);
- if (n > size)
+ ITREE_FOREACH (node, current_buffer->overlays, ZV, ZV, ASCENDING)
{
- SAFE_NALLOCA (v, 1, n);
- overlays_in (ZV, ZV, 0, &v, &n, false, false, NULL);
+ if ((tem = Foverlay_get (node->data, Qdisplay_line_numbers_disable),
+ !NILP (tem)))
+ return true;
}
-
- for (i = 0; i < n; ++i)
- if ((tem = Foverlay_get (v[i], Qdisplay_line_numbers_disable),
- !NILP (tem)))
- break;
-
- SAFE_FREE ();
- return tem;
+ return false;
}
@@ -3341,7 +3373,7 @@ record_overlay_string (struct sortstrlist *ssl, Lisp_Object str,
else
nbytes = SBYTES (str);
- if (INT_ADD_WRAPV (ssl->bytes, nbytes, &nbytes))
+ if (ckd_add (&nbytes, nbytes, ssl->bytes))
memory_full (SIZE_MAX);
ssl->bytes = nbytes;
@@ -3355,7 +3387,7 @@ record_overlay_string (struct sortstrlist *ssl, Lisp_Object str,
else
nbytes = SBYTES (str2);
- if (INT_ADD_WRAPV (ssl->bytes, nbytes, &nbytes))
+ if (ckd_add (&nbytes, nbytes, ssl->bytes))
memory_full (SIZE_MAX);
ssl->bytes = nbytes;
}
@@ -3427,7 +3459,7 @@ overlay_strings (ptrdiff_t pos, struct window *w, unsigned char **pstr)
unsigned char *p;
ptrdiff_t total;
- if (INT_ADD_WRAPV (overlay_heads.bytes, overlay_tails.bytes, &total))
+ if (ckd_add (&total, overlay_heads.bytes, overlay_tails.bytes))
memory_full (SIZE_MAX);
if (total > overlay_str_len)
overlay_str_buf = xpalloc (overlay_str_buf, &overlay_str_len,
@@ -4654,6 +4686,7 @@ init_buffer_once (void)
/* These used to be stuck at 0 by default, but now that the all-zero value
means Qnil, we have to initialize them explicitly. */
bset_name (&buffer_local_flags, make_fixnum (0));
+ bset_last_name (&buffer_local_flags, make_fixnum (0));
bset_mark (&buffer_local_flags, make_fixnum (0));
bset_local_var_alist (&buffer_local_flags, make_fixnum (0));
bset_keymap (&buffer_local_flags, make_fixnum (0));
@@ -4671,7 +4704,6 @@ init_buffer_once (void)
XSETFASTINT (BVAR (&buffer_local_flags, mode_line_format), idx); ++idx;
XSETFASTINT (BVAR (&buffer_local_flags, abbrev_mode), idx); ++idx;
XSETFASTINT (BVAR (&buffer_local_flags, overwrite_mode), idx); ++idx;
- XSETFASTINT (BVAR (&buffer_local_flags, case_fold_search), idx); ++idx;
XSETFASTINT (BVAR (&buffer_local_flags, auto_fill_function), idx); ++idx;
XSETFASTINT (BVAR (&buffer_local_flags, selective_display), idx); ++idx;
XSETFASTINT (BVAR (&buffer_local_flags, selective_display_ellipses), idx); ++idx;
@@ -4717,6 +4749,7 @@ init_buffer_once (void)
#ifdef HAVE_TREE_SITTER
XSETFASTINT (BVAR (&buffer_local_flags, ts_parser_list), idx); ++idx;
#endif
+ XSETFASTINT (BVAR (&buffer_local_flags, text_conversion_style), idx); ++idx;
XSETFASTINT (BVAR (&buffer_local_flags, cursor_in_non_selected_windows), idx); ++idx;
/* buffer_local_flags contains no pointers, so it's safe to treat it
@@ -4763,7 +4796,6 @@ init_buffer_once (void)
bset_tab_line_format (&buffer_defaults, Qnil);
bset_abbrev_mode (&buffer_defaults, Qnil);
bset_overwrite_mode (&buffer_defaults, Qnil);
- bset_case_fold_search (&buffer_defaults, Qt);
bset_auto_fill_function (&buffer_defaults, Qnil);
bset_selective_display (&buffer_defaults, Qnil);
bset_selective_display_ellipses (&buffer_defaults, Qt);
@@ -4788,6 +4820,7 @@ init_buffer_once (void)
#ifdef HAVE_TREE_SITTER
bset_ts_parser_list (&buffer_defaults, Qnil);
#endif
+ bset_text_conversion_style (&buffer_defaults, Qnil);
bset_cursor_in_non_selected_windows (&buffer_defaults, Qt);
bset_enable_multibyte_characters (&buffer_defaults, Qt);
@@ -5131,35 +5164,38 @@ A list whose car is an integer is processed by processing the cadr of
negative) to the width specified by that number.
A string is printed verbatim in the mode line except for %-constructs:
- %b -- print buffer name. %f -- print visited file name.
- %F -- print frame name.
- %* -- print %, * or hyphen. %+ -- print *, % or hyphen.
- %& is like %*, but ignore read-only-ness.
- % means buffer is read-only and * means it is modified.
- For a modified read-only buffer, %* gives % and %+ gives *.
- %s -- print process status. %l -- print the current line number.
+ %b -- print buffer name.
%c -- print the current column number (this makes editing slower).
Columns are numbered starting from the left margin, and the
leftmost column is displayed as zero.
To make the column number update correctly in all cases,
- `column-number-mode' must be non-nil.
+ `column-number-mode' must be non-nil.
%C -- Like %c, but the leftmost column is displayed as one.
+ %e -- print error message about full memory.
+ %f -- print visited file name.
+ %F -- print frame name.
%i -- print the size of the buffer.
%I -- like %i, but use k, M, G, etc., to abbreviate.
+ %l -- print the current line number.
+ %n -- print Narrow if appropriate.
%o -- print percent of window travel through buffer, or Top, Bot or All.
%p -- print percent of buffer above top of window, or Top, Bot or All.
%P -- print percent of buffer above bottom of window, perhaps plus Top,
or print Bottom or All.
%q -- print percent of buffer above both the top and the bottom of the
window, separated by ‘-’, or ‘All’.
- %n -- print Narrow if appropriate.
+ %s -- print process status.
%z -- print mnemonics of keyboard, terminal, and buffer coding systems.
%Z -- like %z, but including the end-of-line format.
- %e -- print error message about full memory.
- %@ -- print @ or hyphen. @ means that default-directory is on a
- remote machine.
- %[ -- print one [ for each recursive editing level. %] similar.
- %% -- print %. %- -- print infinitely many dashes.
+ %& -- print * if the buffer is modified, otherwise hyphen.
+ %+ -- print *, % or hyphen (modified, read-only, neither).
+ %* -- print %, * or hyphen (read-only, modified, neither).
+ For a modified read-only buffer, %+ prints * and %* prints %.
+ %@ -- print @ if default-directory is on a remote machine, else hyphen.
+ %[ -- print one [ for each recursive editing level.
+ %] -- print one ] for each recursive editing level.
+ %- -- print enough dashes to fill the mode line.
+ %% -- print %.
Decimal digits after the % specify field width to which to pad. */);
DEFVAR_PER_BUFFER ("major-mode", &BVAR (current_buffer, major_mode),
@@ -5189,10 +5225,6 @@ Format with `format-mode-line' to produce a string value. */);
doc: /* Non-nil if Abbrev mode is enabled.
Use the command `abbrev-mode' to change this variable. */);
- DEFVAR_PER_BUFFER ("case-fold-search", &BVAR (current_buffer, case_fold_search),
- Qnil,
- doc: /* Non-nil if searches and matches should ignore case. */);
-
DEFVAR_PER_BUFFER ("fill-column", &BVAR (current_buffer, fill_column),
Qintegerp,
doc: /* Column beyond which automatic line-wrapping should happen.
@@ -5861,6 +5893,36 @@ If t, displays a cursor related to the usual cursor type
You can also specify the cursor type as in the `cursor-type' variable.
Use Custom to set this variable and update the display. */);
+ /* While this is defined here, each *term.c module must implement
+ the logic itself. */
+
+ DEFVAR_PER_BUFFER ("text-conversion-style", &BVAR (current_buffer,
+ text_conversion_style),
+ Qnil,
+ doc: /* How the on screen keyboard's input method should insert in this buffer.
+
+If nil, the input method will be disabled and an ordinary keyboard
+will be displayed in its place.
+
+If the value is the symbol `action', the input method will insert text
+directly, but will send `return' key events instead of inserting new
+line characters.
+
+If the value is the symbol `password', an input method capable of ASCII
+input will be enabled, and will not save the entered text where it will
+be retrieved for text suggestions or other features not suitable for
+handling sensitive information, in addition to reporting `return' as
+when `action'.
+
+Any other value means that the input method will insert text directly.
+
+If you need to make non-buffer local changes to this variable, use
+`overriding-text-conversion-style', which see.
+
+This variable does not take immediate effect when set; rather, it
+takes effect upon the next redisplay after the selected window or
+its buffer changes. */);
+
DEFVAR_LISP ("kill-buffer-query-functions", Vkill_buffer_query_functions,
doc: /* List of functions called with no args to query before killing a buffer.
The buffer being killed will be current while the functions are running.
@@ -5905,6 +5967,12 @@ If `delete-auto-save-files' is nil, any autosave deletion is inhibited. */);
This is the default. If nil, auto-save file deletion is inhibited. */);
delete_auto_save_files = 1;
+ DEFVAR_LISP ("case-fold-search", Vcase_fold_search,
+ doc: /* Non-nil if searches and matches should ignore case. */);
+ Vcase_fold_search = Qt;
+ DEFSYM (Qcase_fold_search, "case-fold-search");
+ Fmake_variable_buffer_local (Qcase_fold_search);
+
DEFVAR_LISP ("clone-indirect-buffer-hook", Vclone_indirect_buffer_hook,
doc: /* Normal hook to run in the new buffer at the end of `make-indirect-buffer'.
@@ -5983,10 +6051,13 @@ There is no reason to change that value except for debugging purposes. */);
defsubr (&Sbuffer_list);
defsubr (&Sget_buffer);
defsubr (&Sget_file_buffer);
+ defsubr (&Sget_truename_buffer);
+ defsubr (&Sfind_buffer);
defsubr (&Sget_buffer_create);
defsubr (&Smake_indirect_buffer);
defsubr (&Sgenerate_new_buffer_name);
defsubr (&Sbuffer_name);
+ defsubr (&Sbuffer_last_name);
defsubr (&Sbuffer_file_name);
defsubr (&Sbuffer_base_buffer);
defsubr (&Sbuffer_local_value);
diff --git a/src/buffer.h b/src/buffer.h
index 9604f4afa20..bbe1aeff668 100644
--- a/src/buffer.h
+++ b/src/buffer.h
@@ -216,7 +216,7 @@ extern ptrdiff_t advance_to_char_boundary (ptrdiff_t byte_pos);
/* Return the byte at byte position N.
Do not check that the position is in range. */
-#define FETCH_BYTE(n) *(BYTE_POS_ADDR ((n)))
+#define FETCH_BYTE(n) (*BYTE_POS_ADDR (n))
/* Define the actual buffer data structures. */
@@ -309,6 +309,9 @@ struct buffer
/* The name of this buffer. */
Lisp_Object name_;
+ /* The last name of this buffer before it was renamed or killed. */
+ Lisp_Object last_name_;
+
/* The name of the file visited in this buffer, or nil. */
Lisp_Object filename_;
@@ -379,7 +382,6 @@ struct buffer
/* Values of several buffer-local variables. */
/* tab-width is buffer-local so that redisplay can find it
in buffers that are not current. */
- Lisp_Object case_fold_search_;
Lisp_Object tab_width_;
Lisp_Object fill_column_;
Lisp_Object left_margin_;
@@ -566,6 +568,11 @@ struct buffer
/* A list of tree-sitter parsers for this buffer. */
Lisp_Object ts_parser_list_;
#endif
+
+ /* What type of text conversion the input method should apply to
+ this buffer. */
+ Lisp_Object text_conversion_style_;
+
/* Cursor type to display in non-selected windows.
t means to use hollow box cursor.
See `cursor-type' for other values. */
@@ -842,6 +849,12 @@ bset_width_table (struct buffer *b, Lisp_Object val)
b->width_table_ = val;
}
+INLINE void
+bset_text_conversion_style (struct buffer *b, Lisp_Object val)
+{
+ b->text_conversion_style_ = val;
+}
+
/* BUFFER_CEILING_OF (resp. BUFFER_FLOOR_OF), when applied to n, return
the max (resp. min) p such that
@@ -1164,8 +1177,6 @@ extern void delete_all_overlays (struct buffer *);
extern void reset_buffer (struct buffer *);
extern void compact_buffer (struct buffer *);
extern ptrdiff_t overlays_at (ptrdiff_t, bool, Lisp_Object **, ptrdiff_t *, ptrdiff_t *);
-extern ptrdiff_t overlays_in (ptrdiff_t, ptrdiff_t, bool, Lisp_Object **,
- ptrdiff_t *, bool, bool, ptrdiff_t *);
extern ptrdiff_t previous_overlay_change (ptrdiff_t);
extern ptrdiff_t next_overlay_change (ptrdiff_t);
extern ptrdiff_t sort_overlays (Lisp_Object *, ptrdiff_t, struct window *);
@@ -1266,8 +1277,7 @@ set_buffer_intervals (struct buffer *b, INTERVAL i)
INLINE bool
buffer_has_overlays (void)
{
- return current_buffer->overlays
- && (current_buffer->overlays->root != NULL);
+ return !itree_empty_p (current_buffer->overlays);
}
/* Functions for accessing a character or byte,
diff --git a/src/bytecode.c b/src/bytecode.c
index 828f0ea3726..8d7240b9966 100644
--- a/src/bytecode.c
+++ b/src/bytecode.c
@@ -625,9 +625,10 @@ exec_byte_code (Lisp_Object fun, ptrdiff_t args_template,
varref:
{
Lisp_Object v1 = vectorp[op], v2;
- if (!SYMBOLP (v1)
- || XSYMBOL (v1)->u.s.redirect != SYMBOL_PLAINVAL
- || (v2 = SYMBOL_VAL (XSYMBOL (v1)), BASE_EQ (v2, Qunbound)))
+ if (!BARE_SYMBOL_P (v1)
+ || XBARE_SYMBOL (v1)->u.s.redirect != SYMBOL_PLAINVAL
+ || (v2 = XBARE_SYMBOL (v1)->u.s.val.value,
+ BASE_EQ (v2, Qunbound)))
v2 = Fsymbol_value (v1);
PUSH (v2);
NEXT;
@@ -646,7 +647,10 @@ exec_byte_code (Lisp_Object fun, ptrdiff_t args_template,
if (CONSP (TOP))
TOP = XCAR (TOP);
else if (!NILP (TOP))
- wrong_type_argument (Qlistp, TOP);
+ {
+ record_in_backtrace (Qcar, &TOP, 1);
+ wrong_type_argument (Qlistp, TOP);
+ }
NEXT;
CASE (Beq):
@@ -668,7 +672,10 @@ exec_byte_code (Lisp_Object fun, ptrdiff_t args_template,
if (CONSP (TOP))
TOP = XCDR (TOP);
else if (!NILP (TOP))
- wrong_type_argument (Qlistp, TOP);
+ {
+ record_in_backtrace (Qcdr, &TOP, 1);
+ wrong_type_argument (Qlistp, TOP);
+ }
NEXT;
}
@@ -693,11 +700,11 @@ exec_byte_code (Lisp_Object fun, ptrdiff_t args_template,
Lisp_Object val = POP;
/* Inline the most common case. */
- if (SYMBOLP (sym)
+ if (BARE_SYMBOL_P (sym)
&& !BASE_EQ (val, Qunbound)
- && XSYMBOL (sym)->u.s.redirect == SYMBOL_PLAINVAL
- && !SYMBOL_TRAPPED_WRITE_P (sym))
- SET_SYMBOL_VAL (XSYMBOL (sym), val);
+ && XBARE_SYMBOL (sym)->u.s.redirect == SYMBOL_PLAINVAL
+ && !XBARE_SYMBOL (sym)->u.s.trapped_write)
+ SET_SYMBOL_VAL (XBARE_SYMBOL (sym), val);
else
set_internal (sym, val, Qnil, SET_INTERNAL_SET);
}
@@ -784,24 +791,22 @@ exec_byte_code (Lisp_Object fun, ptrdiff_t args_template,
do_debug_on_call (Qlambda, count1);
Lisp_Object original_fun = call_fun;
- if (SYMBOLP (call_fun))
- call_fun = XSYMBOL (call_fun)->u.s.function;
- Lisp_Object template;
- Lisp_Object bytecode;
- if (COMPILEDP (call_fun)
- /* Lexical binding only. */
- && (template = AREF (call_fun, COMPILED_ARGLIST),
- FIXNUMP (template))
- /* No autoloads. */
- && (bytecode = AREF (call_fun, COMPILED_BYTECODE),
- !CONSP (bytecode)))
+ /* Calls to symbols-with-pos don't need to be on the fast path. */
+ if (BARE_SYMBOL_P (call_fun))
+ call_fun = XBARE_SYMBOL (call_fun)->u.s.function;
+ if (COMPILEDP (call_fun))
{
- fun = call_fun;
- bytestr = bytecode;
- args_template = XFIXNUM (template);
- nargs = call_nargs;
- args = call_args;
- goto setup_frame;
+ Lisp_Object template = AREF (call_fun, COMPILED_ARGLIST);
+ if (FIXNUMP (template))
+ {
+ /* Fast path for lexbound functions. */
+ fun = call_fun;
+ bytestr = AREF (call_fun, COMPILED_BYTECODE),
+ args_template = XFIXNUM (template);
+ nargs = call_nargs;
+ args = call_args;
+ goto setup_frame;
+ }
}
Lisp_Object val;
@@ -1032,7 +1037,15 @@ exec_byte_code (Lisp_Object fun, ptrdiff_t args_template,
{
for (EMACS_INT n = XFIXNUM (v1); 0 < n && CONSP (v2); n--)
v2 = XCDR (v2);
- TOP = CAR (v2);
+ if (CONSP (v2))
+ TOP = XCAR (v2);
+ else if (NILP (v2))
+ TOP = Qnil;
+ else
+ {
+ record_in_backtrace (Qnth, &TOP, 2);
+ wrong_type_argument (Qlistp, v2);
+ }
}
else
TOP = Fnth (v1, v2);
@@ -1101,14 +1114,24 @@ exec_byte_code (Lisp_Object fun, ptrdiff_t args_template,
{
Lisp_Object idxval = POP;
Lisp_Object arrayval = TOP;
+ if (!FIXNUMP (idxval))
+ {
+ record_in_backtrace (Qaref, &TOP, 2);
+ wrong_type_argument (Qfixnump, idxval);
+ }
ptrdiff_t size;
- ptrdiff_t idx;
if (((VECTORP (arrayval) && (size = ASIZE (arrayval), true))
- || (RECORDP (arrayval) && (size = PVSIZE (arrayval), true)))
- && FIXNUMP (idxval)
- && (idx = XFIXNUM (idxval),
- idx >= 0 && idx < size))
- TOP = AREF (arrayval, idx);
+ || (RECORDP (arrayval) && (size = PVSIZE (arrayval), true))))
+ {
+ ptrdiff_t idx = XFIXNUM (idxval);
+ if (idx >= 0 && idx < size)
+ TOP = AREF (arrayval, idx);
+ else
+ {
+ record_in_backtrace (Qaref, &TOP, 2);
+ args_out_of_range (arrayval, idxval);
+ }
+ }
else
TOP = Faref (arrayval, idxval);
NEXT;
@@ -1119,16 +1142,26 @@ exec_byte_code (Lisp_Object fun, ptrdiff_t args_template,
Lisp_Object newelt = POP;
Lisp_Object idxval = POP;
Lisp_Object arrayval = TOP;
+ if (!FIXNUMP (idxval))
+ {
+ record_in_backtrace (Qaset, &TOP, 3);
+ wrong_type_argument (Qfixnump, idxval);
+ }
ptrdiff_t size;
- ptrdiff_t idx;
if (((VECTORP (arrayval) && (size = ASIZE (arrayval), true))
- || (RECORDP (arrayval) && (size = PVSIZE (arrayval), true)))
- && FIXNUMP (idxval)
- && (idx = XFIXNUM (idxval),
- idx >= 0 && idx < size))
+ || (RECORDP (arrayval) && (size = PVSIZE (arrayval), true))))
{
- ASET (arrayval, idx, newelt);
- TOP = newelt;
+ ptrdiff_t idx = XFIXNUM (idxval);
+ if (idx >= 0 && idx < size)
+ {
+ ASET (arrayval, idx, newelt);
+ TOP = newelt;
+ }
+ else
+ {
+ record_in_backtrace (Qaset, &TOP, 3);
+ args_out_of_range (arrayval, idxval);
+ }
}
else
TOP = Faset (arrayval, idxval, newelt);
@@ -1327,7 +1360,7 @@ exec_byte_code (Lisp_Object fun, ptrdiff_t args_template,
Lisp_Object v1 = TOP;
intmax_t res;
if (FIXNUMP (v1) && FIXNUMP (v2)
- && !INT_MULTIPLY_WRAPV (XFIXNUM (v1), XFIXNUM (v2), &res)
+ && !ckd_mul (&res, XFIXNUM (v1), XFIXNUM (v2))
&& !FIXNUM_OVERFLOW_P (res))
TOP = make_fixnum (res);
else
@@ -1552,7 +1585,15 @@ exec_byte_code (Lisp_Object fun, ptrdiff_t args_template,
/* Like the fast case for Bnth, but with args reversed. */
for (EMACS_INT n = XFIXNUM (v2); 0 < n && CONSP (v1); n--)
v1 = XCDR (v1);
- TOP = CAR (v1);
+ if (CONSP (v1))
+ TOP = XCAR (v1);
+ else if (NILP (v1))
+ TOP = Qnil;
+ else
+ {
+ record_in_backtrace (Qelt, &TOP, 2);
+ wrong_type_argument (Qlistp, v1);
+ }
}
else
TOP = Felt (v1, v2);
@@ -1581,7 +1622,11 @@ exec_byte_code (Lisp_Object fun, ptrdiff_t args_template,
{
Lisp_Object newval = POP;
Lisp_Object cell = TOP;
- CHECK_CONS (cell);
+ if (!CONSP (cell))
+ {
+ record_in_backtrace (Qsetcar, &TOP, 2);
+ wrong_type_argument (Qconsp, cell);
+ }
CHECK_IMPURE (cell, XCONS (cell));
XSETCAR (cell, newval);
TOP = newval;
@@ -1592,7 +1637,11 @@ exec_byte_code (Lisp_Object fun, ptrdiff_t args_template,
{
Lisp_Object newval = POP;
Lisp_Object cell = TOP;
- CHECK_CONS (cell);
+ if (!CONSP (cell))
+ {
+ record_in_backtrace (Qsetcdr, &TOP, 2);
+ wrong_type_argument (Qconsp, cell);
+ }
CHECK_IMPURE (cell, XCONS (cell));
XSETCDR (cell, newval);
TOP = newval;
@@ -1688,28 +1737,29 @@ exec_byte_code (Lisp_Object fun, ptrdiff_t args_template,
if (BYTE_CODE_SAFE && !HASH_TABLE_P (jmp_table))
emacs_abort ();
Lisp_Object v1 = POP;
- ptrdiff_t i;
struct Lisp_Hash_Table *h = XHASH_TABLE (jmp_table);
-
- /* h->count is a faster approximation for HASH_TABLE_SIZE (h)
- here. */
- if (h->count <= 5 && !h->test.cmpfn)
- { /* Do a linear search if there are not many cases
- FIXME: 5 is arbitrarily chosen. */
- for (i = h->count; 0 <= --i; )
- if (EQ (v1, HASH_KEY (h, i)))
- break;
+ /* Do a linear search if there are few cases and the test is `eq'.
+ (The table is assumed to be sized exactly; all entries are
+ consecutive at the beginning.)
+ FIXME: 5 is arbitrarily chosen. */
+ if (h->count <= 5 && !h->test->cmpfn && !symbols_with_pos_enabled)
+ {
+ eassume (h->count >= 2);
+ for (ptrdiff_t i = h->count - 1; i >= 0; i--)
+ if (BASE_EQ (v1, HASH_KEY (h, i)))
+ {
+ op = XFIXNUM (HASH_VALUE (h, i));
+ goto op_branch;
+ }
}
else
- i = hash_lookup (h, v1, NULL);
-
- if (i >= 0)
{
- Lisp_Object val = HASH_VALUE (h, i);
- if (BYTE_CODE_SAFE && !FIXNUMP (val))
- emacs_abort ();
- op = XFIXNUM (val);
- goto op_branch;
+ ptrdiff_t i = hash_lookup (h, v1);
+ if (i >= 0)
+ {
+ op = XFIXNUM (HASH_VALUE (h, i));
+ goto op_branch;
+ }
}
}
NEXT;
diff --git a/src/callint.c b/src/callint.c
index 8105945d6ab..b31faba8704 100644
--- a/src/callint.c
+++ b/src/callint.c
@@ -537,7 +537,8 @@ invoke it (via an `interactive' spec that contains, for instance, an
make_fixnum (SCHARS (callint_message)),
Qface, Qminibuffer_prompt, callint_message);
args[i] = Fread_key_sequence (callint_message,
- Qnil, Qnil, Qnil, Qnil);
+ Qnil, Qnil, Qnil, Qnil,
+ Qnil);
unbind_to (speccount1, Qnil);
visargs[i] = Fkey_description (args[i], Qnil);
@@ -567,7 +568,8 @@ invoke it (via an `interactive' spec that contains, for instance, an
make_fixnum (SCHARS (callint_message)),
Qface, Qminibuffer_prompt, callint_message);
args[i] = Fread_key_sequence_vector (callint_message,
- Qnil, Qt, Qnil, Qnil);
+ Qnil, Qt, Qnil, Qnil,
+ Qnil);
visargs[i] = Fkey_description (args[i], Qnil);
unbind_to (speccount1, Qnil);
diff --git a/src/callproc.c b/src/callproc.c
index 073d0ce2b59..db36ef569e6 100644
--- a/src/callproc.c
+++ b/src/callproc.c
@@ -92,6 +92,10 @@ extern char **environ;
#include "pgtkterm.h"
#endif
+#ifdef HAVE_ANDROID
+#include "android.h"
+#endif /* HAVE_ANDROID */
+
/* Pattern used by call-process-region to make temp files. */
static Lisp_Object Vtemp_file_name_pattern;
@@ -144,7 +148,11 @@ static CHILD_SETUP_TYPE child_setup (int, int, int, char **, char **,
directory if it's unreachable. If ENCODE is true, return as a string
suitable for a system call; otherwise, return a string in its
internal representation. Signal an error if the result would not be
- an accessible directory. */
+ an accessible directory.
+
+ If the default directory lies inside a special directory which
+ cannot be made the current working directory, and ENCODE is also
+ set, simply return the home directory. */
Lisp_Object
get_current_directory (bool encode)
@@ -157,6 +165,20 @@ get_current_directory (bool encode)
if (NILP (dir))
dir = build_string ("~");
+#if defined HAVE_ANDROID && !defined ANDROID_STUBIFY
+
+ /* If DIR is an asset directory or a content directory, return
+ the home directory instead. */
+
+ if (encode
+ && (android_is_special_directory (SSDATA (dir),
+ "/assets")
+ || android_is_special_directory (SSDATA (dir),
+ "/content")))
+ dir = build_string ("~");
+
+#endif /* HAVE_ANDROID && ANDROID_STUBIFY */
+
dir = expand_and_dir_to_file (dir);
Lisp_Object encoded_dir = ENCODE_FILE (remove_slash_colon (dir));
@@ -193,7 +215,7 @@ record_kill_process (struct Lisp_Process *p, Lisp_Object tempfile)
static void
delete_temp_file (Lisp_Object name)
{
- unlink (SSDATA (name));
+ emacs_unlink (SSDATA (name));
}
static void
@@ -499,7 +521,7 @@ call_process (ptrdiff_t nargs, Lisp_Object *args, int filefd,
int ok;
ok = openp (Vexec_path, args[0], Vexec_suffixes, &path,
- make_fixnum (X_OK), false, false);
+ make_fixnum (X_OK), false, false, NULL);
if (ok < 0)
report_file_error ("Searching for program", args[0]);
}
@@ -1421,6 +1443,18 @@ emacs_spawn (pid_t *newpid, int std_in, int std_out, int std_err,
const char *pty_name, bool pty_in, bool pty_out,
const sigset_t *oldset)
{
+#if defined HAVE_ANDROID && !defined ANDROID_STUBIFY
+ /* Android 10 and later don't allow directly executing programs
+ installed in the application data directory. Emacs provides a
+ loader binary which replaces the `execve' system call for it and
+ all its children. On these systems, rewrite the command line to
+ call that loader binary instead. */
+
+ if (android_rewrite_spawn_argv ((const char ***) &argv))
+ return 1;
+#endif /* defined HAVE_ANDROID && !defined ANDROID_STUBIFY */
+
+
#if USABLE_POSIX_SPAWN
/* Prefer the simpler `posix_spawn' if available. `posix_spawn'
doesn't yet support setting up pseudoterminals, so we fall back
@@ -1701,6 +1735,10 @@ getenv_internal (const char *var, ptrdiff_t varlen, char **value,
}
#endif
+ /* Setting DISPLAY under Android hinders attempts to display other
+ programs within X servers that are available for Android. */
+
+#ifndef HAVE_ANDROID
/* For DISPLAY try to get the values from the frame or the initial env. */
if (strcmp (var, "DISPLAY") == 0)
{
@@ -1713,12 +1751,13 @@ getenv_internal (const char *var, ptrdiff_t varlen, char **value,
*valuelen = SBYTES (display);
return 1;
}
-#endif
+#endif /* !HAVE_PGTK */
/* If still not found, Look for DISPLAY in Vinitial_environment. */
if (getenv_internal_1 (var, varlen, value, valuelen,
Vinitial_environment))
return *value ? 1 : 0;
}
+#endif /* !HAVE_ANDROID */
return 0;
}
@@ -1811,7 +1850,9 @@ make_environment_block (Lisp_Object current_dir)
register char **new_env;
char **p, **q;
register int new_length;
+#ifndef HAVE_ANDROID
Lisp_Object display = Qnil;
+#endif /* !HAVE_ANDROID */
new_length = 0;
@@ -1819,14 +1860,20 @@ make_environment_block (Lisp_Object current_dir)
CONSP (tem) && STRINGP (XCAR (tem));
tem = XCDR (tem))
{
+#ifndef HAVE_ANDROID
if (strncmp (SSDATA (XCAR (tem)), "DISPLAY", 7) == 0
&& (SDATA (XCAR (tem)) [7] == '\0'
|| SDATA (XCAR (tem)) [7] == '='))
/* DISPLAY is specified in process-environment. */
display = Qt;
+#endif /* !HAVE_ANDROID */
new_length++;
}
+ /* Setting DISPLAY under Android hinders attempts to display other
+ programs within X servers that are available for Android. */
+
+#ifndef HAVE_ANDROID
/* If not provided yet, use the frame's DISPLAY. */
if (NILP (display))
{
@@ -1841,7 +1888,7 @@ make_environment_block (Lisp_Object current_dir)
&& strcmp (G_OBJECT_TYPE_NAME (FRAME_X_DISPLAY (SELECTED_FRAME ())),
"GdkX11Display"))
tmp = Qnil;
-#endif
+#endif /* HAVE_PGTK */
if (!STRINGP (tmp) && CONSP (Vinitial_environment))
/* If still not found, Look for DISPLAY in Vinitial_environment. */
@@ -1853,6 +1900,7 @@ make_environment_block (Lisp_Object current_dir)
new_length++;
}
}
+#endif /* !HAVE_ANDROID */
/* new_length + 2 to include PWD and terminating 0. */
env = new_env = xnmalloc (new_length + 2, sizeof *env);
@@ -1862,6 +1910,7 @@ make_environment_block (Lisp_Object current_dir)
if (egetenv ("PWD"))
*new_env++ = pwd_var;
+#ifndef HAVE_ANDROID
if (STRINGP (display))
{
char *vdata = xmalloc (sizeof "DISPLAY=" + SBYTES (display));
@@ -1869,6 +1918,7 @@ make_environment_block (Lisp_Object current_dir)
lispstpcpy (stpcpy (vdata, "DISPLAY="), display);
new_env = add_env (env, new_env, vdata);
}
+#endif /* !HAVE_ANDROID */
/* Overrides. */
for (tem = Vprocess_environment;
@@ -1988,7 +2038,12 @@ init_callproc (void)
dir_warning ("arch-independent data dir", Vdata_directory);
sh = getenv ("SHELL");
+#if defined HAVE_ANDROID && !defined ANDROID_STUBIFY
+ /* The Android shell is found under /system/bin, not /bin. */
+ Vshell_file_name = build_string (sh ? sh : "/system/bin/sh");
+#else
Vshell_file_name = build_string (sh ? sh : "/bin/sh");
+#endif
Lisp_Object gamedir = Qnil;
if (PATH_GAME)
@@ -2111,6 +2166,83 @@ use.
See `setenv' and `getenv'. */);
Vprocess_environment = Qnil;
+ DEFVAR_LISP ("ctags-program-name", Vctags_program_name,
+ doc: /* Name of the `ctags' program distributed with Emacs.
+Use this instead of calling `ctags' directly, as `ctags' may have been
+renamed to comply with executable naming restrictions on the system. */);
+#if !defined HAVE_ANDROID || defined ANDROID_STUBIFY
+ Vctags_program_name = build_pure_c_string ("ctags");
+#else
+ Vctags_program_name = build_pure_c_string ("libctags.so");
+#endif
+
+ DEFVAR_LISP ("etags-program-name", Vetags_program_name,
+ doc: /* Name of the `etags' program distributed with Emacs.
+Use this instead of calling `etags' directly, as `etags' may have been
+renamed to comply with executable naming restrictions on the system. */);
+#if !defined HAVE_ANDROID || defined ANDROID_STUBIFY
+ Vetags_program_name = build_pure_c_string ("etags");
+#else
+ Vetags_program_name = build_pure_c_string ("libetags.so");
+#endif
+
+ DEFVAR_LISP ("hexl-program-name", Vhexl_program_name,
+ doc: /* Name of the `hexl' program distributed with Emacs.
+Use this instead of calling `hexl' directly, as `hexl' may have been
+renamed to comply with executable naming restrictions on the system. */);
+#if !defined HAVE_ANDROID || defined ANDROID_STUBIFY
+ Vhexl_program_name = build_pure_c_string ("hexl");
+#else
+ Vhexl_program_name = build_pure_c_string ("libhexl.so");
+#endif
+
+ DEFVAR_LISP ("emacsclient-program-name", Vemacsclient_program_name,
+ doc: /* Name of the `emacsclient' program distributed with Emacs.
+Use this instead of calling `emacsclient' directly, as `emacsclient'
+may have been renamed to comply with executable naming restrictions on
+the system. */);
+#if !defined HAVE_ANDROID || defined ANDROID_STUBIFY
+ Vemacsclient_program_name = build_pure_c_string ("emacsclient");
+#else
+ Vemacsclient_program_name = build_pure_c_string ("libemacsclient.so");
+#endif
+
+ DEFVAR_LISP ("movemail-program-name", Vmovemail_program_name,
+ doc: /* Name of the `movemail' program distributed with Emacs.
+Use this instead of calling `movemail' directly, as `movemail'
+may have been renamed to comply with executable naming restrictions on
+the system. */);
+ /* Don't change the name of `movemail' if Emacs is being built to
+ use movemail from another source. */
+#if !defined HAVE_ANDROID || defined ANDROID_STUBIFY \
+ || defined HAVE_MAILUTILS
+ Vmovemail_program_name = build_pure_c_string ("movemail");
+#else
+ Vmovemail_program_name = build_pure_c_string ("libmovemail.so");
+#endif
+
+ DEFVAR_LISP ("ebrowse-program-name", Vebrowse_program_name,
+ doc: /* Name of the `ebrowse' program distributed with Emacs.
+Use this instead of calling `ebrowse' directly, as `ebrowse'
+may have been renamed to comply with executable naming restrictions on
+the system. */);
+#if !defined HAVE_ANDROID || defined ANDROID_STUBIFY
+ Vebrowse_program_name = build_pure_c_string ("ebrowse");
+#else
+ Vebrowse_program_name = build_pure_c_string ("libebrowse.so");
+#endif
+
+ DEFVAR_LISP ("rcs2log-program-name", Vrcs2log_program_name,
+ doc: /* Name of the `rcs2log' program distributed with Emacs.
+Use this instead of calling `rcs2log' directly, as `rcs2log'
+may have been renamed to comply with executable naming restrictions on
+the system. */);
+#if !defined HAVE_ANDROID || defined ANDROID_STUBIFY
+ Vrcs2log_program_name = build_pure_c_string ("rcs2log");
+#else /* HAVE_ANDROID && !ANDROID_STUBIFY */
+ Vrcs2log_program_name = build_pure_c_string ("librcs2log.so");
+#endif /* !HAVE_ANDROID || ANDROID_STUBIFY */
+
defsubr (&Scall_process);
defsubr (&Sgetenv_internal);
defsubr (&Scall_process_region);
diff --git a/src/casefiddle.c b/src/casefiddle.c
index 7e445703901..b252f07ae13 100644
--- a/src/casefiddle.c
+++ b/src/casefiddle.c
@@ -92,6 +92,12 @@ prepare_casing_context (struct casing_context *ctx,
SETUP_BUFFER_SYNTAX_TABLE (); /* For syntax_prefix_flag_p. */
}
+static bool
+case_ch_is_word (enum syntaxcode syntax)
+{
+ return syntax == Sword || (case_symbols_as_words && syntax == Ssymbol);
+}
+
struct casing_str_buf
{
unsigned char data[max (6, MAX_MULTIBYTE_LENGTH)];
@@ -115,7 +121,7 @@ case_character_impl (struct casing_str_buf *buf,
/* Update inword state */
bool was_inword = ctx->inword;
- ctx->inword = SYNTAX (ch) == Sword &&
+ ctx->inword = case_ch_is_word (SYNTAX (ch)) &&
(!ctx->inbuffer || was_inword || !syntax_prefix_flag_p (ch));
/* Normalize flag so its one of CASE_UP, CASE_DOWN or CASE_CAPITALIZE. */
@@ -222,7 +228,7 @@ case_character (struct casing_str_buf *buf, struct casing_context *ctx,
has a word syntax (i.e. current character is end of word), use final
sigma. */
if (was_inword && ch == GREEK_CAPITAL_LETTER_SIGMA && changed
- && (!next || SYNTAX (STRING_CHAR (next)) != Sword))
+ && (!next || !case_ch_is_word (SYNTAX (STRING_CHAR (next)))))
{
buf->len_bytes = CHAR_STRING (GREEK_SMALL_LETTER_FINAL_SIGMA, buf->data);
buf->len_chars = 1;
@@ -283,8 +289,8 @@ do_casify_multibyte_string (struct casing_context *ctx, Lisp_Object obj)
ptrdiff_t size = SCHARS (obj), n;
USE_SAFE_ALLOCA;
- if (INT_MULTIPLY_WRAPV (size, MAX_MULTIBYTE_LENGTH, &n)
- || INT_ADD_WRAPV (n, sizeof (struct casing_str_buf), &n))
+ if (ckd_mul (&n, size, MAX_MULTIBYTE_LENGTH)
+ || ckd_add (&n, n, sizeof (struct casing_str_buf)))
n = PTRDIFF_MAX;
unsigned char *dst = SAFE_ALLOCA (n);
unsigned char *dst_end = dst + n;
@@ -720,6 +726,21 @@ Called with one argument METHOD which can be:
3rd argument. */);
Vregion_extract_function = Qnil; /* simple.el sets this. */
+ DEFVAR_BOOL ("case-symbols-as-words", case_symbols_as_words,
+ doc: /* If non-nil, case functions treat symbol syntax as part of words.
+
+Functions such as `upcase-initials' and `replace-match' check or modify
+the case pattern of sequences of characters. Normally, these operate on
+sequences of characters whose syntax is word constituent. If this
+variable is non-nil, then they operate on sequences of characters whose
+syntax is either word constituent or symbol constituent.
+
+This is useful for programming languages and styles where only the first
+letter of a symbol's name is ever capitalized.*/);
+ case_symbols_as_words = 0;
+ DEFSYM (Qcase_symbols_as_words, "case-symbols-as-words");
+ Fmake_variable_buffer_local (Qcase_symbols_as_words);
+
defsubr (&Supcase);
defsubr (&Sdowncase);
defsubr (&Scapitalize);
diff --git a/src/category.c b/src/category.c
index b539bad31eb..498b6a2a1c9 100644
--- a/src/category.c
+++ b/src/category.c
@@ -51,12 +51,10 @@ hash_get_category_set (Lisp_Object table, Lisp_Object category_set)
if (NILP (XCHAR_TABLE (table)->extras[1]))
set_char_table_extras
(table, 1,
- make_hash_table (hashtest_equal, DEFAULT_HASH_SIZE,
- DEFAULT_REHASH_SIZE, DEFAULT_REHASH_THRESHOLD,
- Qnil, false));
+ make_hash_table (&hashtest_equal, DEFAULT_HASH_SIZE, Weak_None, false));
struct Lisp_Hash_Table *h = XHASH_TABLE (XCHAR_TABLE (table)->extras[1]);
- Lisp_Object hash;
- ptrdiff_t i = hash_lookup (h, category_set, &hash);
+ hash_hash_t hash;
+ ptrdiff_t i = hash_lookup_get_hash (h, category_set, &hash);
if (i >= 0)
return HASH_KEY (h, i);
hash_put (h, category_set, Qnil, hash);
diff --git a/src/ccl.c b/src/ccl.c
index b3423e852e1..8bb8a78fe3d 100644
--- a/src/ccl.c
+++ b/src/ccl.c
@@ -35,11 +35,6 @@ along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. */
#include "coding.h"
#include "keyboard.h"
-/* Avoid GCC 12 bug <https://gcc.gnu.org/bugzilla/show_bug.cgi?id=105784>. */
-#if GNUC_PREREQ (12, 0, 0)
-# pragma GCC diagnostic ignored "-Wanalyzer-use-of-uninitialized-value"
-#endif
-
/* Table of registered CCL programs. Each element is a vector of
NAME, CCL_PROG, RESOLVEDP, and UPDATEDP, where NAME (symbol) is the
name of the program, CCL_PROG (vector) is the compiled code of the
@@ -51,7 +46,7 @@ static Lisp_Object Vccl_program_table;
/* Return a hash table of id number ID. */
#define GET_HASH_TABLE(id) \
- (XHASH_TABLE (XCDR (AREF (Vtranslation_hash_table_vector, (id)))))
+ XHASH_TABLE (XCDR (AREF (Vtranslation_hash_table_vector, id)))
/* CCL (Code Conversion Language) is a simple language which has
operations on one input buffer, one output buffer, and 7 registers.
@@ -605,6 +600,14 @@ do \
} \
while (0)
+/* Work around GCC bug 109579
+ https://gcc.gnu.org/bugzilla/show_bug.cgi?id=109579
+ which causes GCC to mistakenly complain about
+ popping the mapping stack. */
+#if __GNUC__ == 13
+# pragma GCC diagnostic ignored "-Wanalyzer-out-of-bounds"
+#endif
+
#define POP_MAPPING_STACK(restlen, orig) \
do \
{ \
@@ -619,7 +622,7 @@ do \
{ \
struct ccl_program called_ccl; \
if (stack_idx >= 256 \
- || ! setup_ccl_program (&called_ccl, (symbol))) \
+ || ! setup_ccl_program (&called_ccl, symbol)) \
{ \
if (stack_idx > 0) \
{ \
@@ -810,7 +813,7 @@ while (0)
#define CCL_DECODE_CHAR(id, code) \
((id) == 0 ? (code) \
- : (charset = CHARSET_FROM_ID ((id)), DECODE_CHAR (charset, (code))))
+ : (charset = CHARSET_FROM_ID (id), DECODE_CHAR (charset, code)))
/* Encode character C by some of charsets in CHARSET_LIST. Set ID to
the id of the used charset, ENCODED to the result of encoding.
@@ -820,9 +823,9 @@ while (0)
do { \
unsigned ncode; \
\
- charset = char_charset ((c), (charset_list), &ncode); \
+ charset = char_charset (c, charset_list, &ncode); \
if (! charset && ! NILP (charset_list)) \
- charset = char_charset ((c), Qnil, &ncode); \
+ charset = char_charset (c, Qnil, &ncode); \
if (charset) \
{ \
(id) = CHARSET_ID (charset); \
@@ -865,7 +868,7 @@ static struct ccl_prog_stack ccl_prog_stack_struct[256];
static inline Lisp_Object
GET_TRANSLATION_TABLE (int id)
{
- return XCDR (XVECTOR (Vtranslation_table_vector)->contents[id]);
+ return XCDR (AREF (Vtranslation_table_vector, id));
}
void
@@ -1148,9 +1151,9 @@ ccl_driver (struct ccl_program *ccl, int *source, int *destination, int src_size
ccl_expr_self:
switch (op)
{
- case CCL_PLUS: INT_ADD_WRAPV (reg[rrr], i, &reg[rrr]); break;
- case CCL_MINUS: INT_SUBTRACT_WRAPV (reg[rrr], i, &reg[rrr]); break;
- case CCL_MUL: INT_MULTIPLY_WRAPV (reg[rrr], i, &reg[rrr]); break;
+ case CCL_PLUS: ckd_add (&reg[rrr], reg[rrr], i); break;
+ case CCL_MINUS: ckd_sub (&reg[rrr], reg[rrr], i); break;
+ case CCL_MUL: ckd_mul (&reg[rrr], reg[rrr], i); break;
case CCL_DIV:
if (!i)
CCL_INVALID_CMD;
@@ -1186,7 +1189,7 @@ ccl_driver (struct ccl_program *ccl, int *source, int *destination, int src_size
if (i == -1)
{
reg[7] = 0;
- INT_SUBTRACT_WRAPV (0, reg[rrr], &reg[rrr]);
+ ckd_sub (&reg[rrr], 0, reg[rrr]);
}
else
{
@@ -1243,9 +1246,9 @@ ccl_driver (struct ccl_program *ccl, int *source, int *destination, int src_size
ccl_set_expr:
switch (op)
{
- case CCL_PLUS: INT_ADD_WRAPV (i, j, &reg[rrr]); break;
- case CCL_MINUS: INT_SUBTRACT_WRAPV (i, j, &reg[rrr]); break;
- case CCL_MUL: INT_MULTIPLY_WRAPV (i, j, &reg[rrr]); break;
+ case CCL_PLUS: ckd_add (&reg[rrr], i, j); break;
+ case CCL_MINUS: ckd_sub (&reg[rrr], i, j); break;
+ case CCL_MUL: ckd_mul (&reg[rrr], i, j); break;
case CCL_DIV:
if (!j)
CCL_INVALID_CMD;
@@ -1280,7 +1283,7 @@ ccl_driver (struct ccl_program *ccl, int *source, int *destination, int src_size
CCL_INVALID_CMD;
if (j == -1)
{
- INT_SUBTRACT_WRAPV (0, reg[rrr], &reg[rrr]);
+ ckd_sub (&reg[rrr], 0, reg[rrr]);
reg[7] = 0;
}
else
@@ -1372,7 +1375,7 @@ ccl_driver (struct ccl_program *ccl, int *source, int *destination, int src_size
eop = (FIXNUM_OVERFLOW_P (reg[RRR])
? -1
- : hash_lookup (h, make_fixnum (reg[RRR]), NULL));
+ : hash_lookup (h, make_fixnum (reg[RRR])));
if (eop >= 0)
{
Lisp_Object opl;
@@ -1401,7 +1404,7 @@ ccl_driver (struct ccl_program *ccl, int *source, int *destination, int src_size
eop = (FIXNUM_OVERFLOW_P (i)
? -1
- : hash_lookup (h, make_fixnum (i), NULL));
+ : hash_lookup (h, make_fixnum (i)));
if (eop >= 0)
{
Lisp_Object opl;
@@ -2161,8 +2164,8 @@ usage: (ccl-execute-on-string CCL-PROGRAM STATUS STRING &optional CONTINUE UNIBY
buf_magnification = ccl.buf_magnification ? ccl.buf_magnification : 1;
outbufsize = str_bytes;
- if (INT_MULTIPLY_WRAPV (buf_magnification, outbufsize, &outbufsize)
- || INT_ADD_WRAPV (256, outbufsize, &outbufsize))
+ if (ckd_mul (&outbufsize, outbufsize, buf_magnification)
+ || ckd_add (&outbufsize, outbufsize, 256))
memory_full (SIZE_MAX);
outp = outbuf = xmalloc (outbufsize);
diff --git a/src/ccl.h b/src/ccl.h
index 8eb9d7eb2e8..b8bdcad4c32 100644
--- a/src/ccl.h
+++ b/src/ccl.h
@@ -82,7 +82,7 @@ extern void ccl_driver (struct ccl_program *, int *, int *, int, int,
#define CHECK_CCL_PROGRAM(x) \
do { \
if (NILP (Fccl_program_p (x))) \
- wrong_type_argument (Qcclp, (x)); \
+ wrong_type_argument (Qcclp, x); \
} while (false);
#endif /* EMACS_CCL_H */
diff --git a/src/character.c b/src/character.c
index ba68fe2acac..dcad8f83793 100644
--- a/src/character.c
+++ b/src/character.c
@@ -250,7 +250,7 @@ char_width (int c, struct Lisp_Char_Table *dp)
if (c >= 0)
{
int w = CHARACTER_WIDTH (c);
- if (INT_ADD_WRAPV (width, w, &width))
+ if (ckd_add (&width, width, w))
string_overflow ();
}
}
@@ -305,7 +305,7 @@ c_string_width (const unsigned char *str, ptrdiff_t len, int precision,
*nbytes = i_byte;
return width;
}
- if (INT_ADD_WRAPV (thiswidth, width, &width))
+ if (ckd_add (&width, width, thiswidth))
string_overflow ();
i++;
i_byte += bytes;
@@ -445,7 +445,7 @@ lisp_string_width (Lisp_Object string, ptrdiff_t from, ptrdiff_t to,
*nbytes = i_byte - from_byte;
return width;
}
- if (INT_ADD_WRAPV (thiswidth, width, &width))
+ if (ckd_add (&width, width, thiswidth))
string_overflow ();
i += chars;
i_byte += bytes;
@@ -674,7 +674,7 @@ count_size_as_multibyte (const unsigned char *str, ptrdiff_t len)
for (ptrdiff_t i = 0; i < len; i++)
nonascii += str[i] >> 7;
ptrdiff_t bytes;
- if (INT_ADD_WRAPV (len, nonascii, &bytes))
+ if (ckd_add (&bytes, len, nonascii))
string_overflow ();
return bytes;
}
@@ -790,21 +790,21 @@ string_escape_byte8 (Lisp_Object string)
if (byte8_count == 0)
return string;
- if (INT_MULTIPLY_WRAPV (byte8_count, 3, &thrice_byte8_count))
+ if (ckd_mul (&thrice_byte8_count, byte8_count, 3))
string_overflow ();
if (multibyte)
{
/* Convert 2-byte sequence of byte8 chars to 4-byte octal. */
- if (INT_ADD_WRAPV (nchars, thrice_byte8_count, &uninit_nchars)
- || INT_ADD_WRAPV (nbytes, 2 * byte8_count, &uninit_nbytes))
+ if (ckd_add (&uninit_nchars, nchars, thrice_byte8_count)
+ || ckd_add (&uninit_nbytes, nbytes, 2 * byte8_count))
string_overflow ();
val = make_uninit_multibyte_string (uninit_nchars, uninit_nbytes);
}
else
{
/* Convert 1-byte sequence of byte8 chars to 4-byte octal. */
- if (INT_ADD_WRAPV (thrice_byte8_count, nbytes, &uninit_nbytes))
+ if (ckd_add (&uninit_nbytes, thrice_byte8_count, nbytes))
string_overflow ();
val = make_uninit_string (uninit_nbytes);
}
@@ -1117,6 +1117,14 @@ A char-table for width (columns) of each character. */);
char_table_set_range (Vchar_width_table, MAX_5_BYTE_CHAR + 1, MAX_CHAR,
make_fixnum (4));
+ DEFVAR_LISP ("ambiguous-width-chars", Vambiguous_width_chars,
+ doc: /*
+A char-table for characters whose width (columns) can be 1 or 2.
+
+The actual width depends on the language-environment and on the
+value of `cjk-ambiguous-chars-are-wide'. */);
+ Vambiguous_width_chars = Fmake_char_table (Qnil, Qnil);
+
DEFVAR_LISP ("printable-chars", Vprintable_chars,
doc: /* A char-table for each printable character. */);
Vprintable_chars = Fmake_char_table (Qnil, Qnil);
diff --git a/src/charset.c b/src/charset.c
index e605fc50bf6..4bacc011e85 100644
--- a/src/charset.c
+++ b/src/charset.c
@@ -486,8 +486,9 @@ load_charset_map_from_file (struct charset *charset, Lisp_Object mapfile,
specpdl_ref count = SPECPDL_INDEX ();
record_unwind_protect_nothing ();
specbind (Qfile_name_handler_alist, Qnil);
- fd = openp (Vcharset_map_path, mapfile, suffixes, NULL, Qnil, false, false);
- fp = fd < 0 ? 0 : fdopen (fd, "r");
+ fd = openp (Vcharset_map_path, mapfile, suffixes, NULL, Qnil, false, false,
+ NULL);
+ fp = fd < 0 ? 0 : emacs_fdopen (fd, "r");
if (!fp)
{
int open_errno = errno;
@@ -544,7 +545,7 @@ load_charset_map_from_file (struct charset *charset, Lisp_Object mapfile,
entries->entry[idx].c = c;
n_entries++;
}
- fclose (fp);
+ emacs_fclose (fp);
clear_unwind_protect (count);
load_charset_map (charset, head, n_entries, control_flag);
@@ -849,7 +850,6 @@ usage: (define-charset-internal ...) */)
/* Charset attr vector. */
Lisp_Object attrs;
Lisp_Object val;
- Lisp_Object hash_code;
struct Lisp_Hash_Table *hash_table = XHASH_TABLE (Vcharset_hash_table);
int i, j;
struct charset charset;
@@ -1107,18 +1107,19 @@ usage: (define-charset-internal ...) */)
CHECK_LIST (args[charset_arg_plist]);
ASET (attrs, charset_plist, args[charset_arg_plist]);
- charset.hash_index = hash_lookup (hash_table, args[charset_arg_name],
- &hash_code);
- if (charset.hash_index >= 0)
+ hash_hash_t hash_code;
+ ptrdiff_t hash_index
+ = hash_lookup_get_hash (hash_table, args[charset_arg_name],
+ &hash_code);
+ if (hash_index >= 0)
{
- new_definition_p = 0;
+ new_definition_p = false;
id = XFIXNAT (CHARSET_SYMBOL_ID (args[charset_arg_name]));
- set_hash_value_slot (hash_table, charset.hash_index, attrs);
+ set_hash_value_slot (hash_table, hash_index, attrs);
}
else
{
- charset.hash_index = hash_put (hash_table, args[charset_arg_name], attrs,
- hash_code);
+ hash_put (hash_table, args[charset_arg_name], attrs, hash_code);
if (charset_table_used == charset_table_size)
{
/* Ensure that charset IDs fit into 'int' as well as into the
@@ -1149,6 +1150,7 @@ usage: (define-charset-internal ...) */)
ASET (attrs, charset_id, make_fixnum (id));
charset.id = id;
+ charset.attributes = attrs;
charset_table[id] = charset;
if (charset.method == CHARSET_METHOD_MAP)
@@ -1789,7 +1791,7 @@ encode_char (struct charset *charset, int c)
return CHARSET_INVALID_CODE (charset);
}
- if (! CHARSET_FAST_MAP_REF ((c), charset->fast_map)
+ if (! CHARSET_FAST_MAP_REF (c, charset->fast_map)
|| c < CHARSET_MIN_CHAR (charset) || c > CHARSET_MAX_CHAR (charset))
return CHARSET_INVALID_CODE (charset);
@@ -2268,6 +2270,15 @@ See also `charset-priority-list' and `set-charset-priority'. */)
return charsets;
}
+/* Not strictly necessary, because all charset attributes are also
+ reachable from `Vcharset_hash_table`. */
+void
+mark_charset (void)
+{
+ for (int i = 0; i < charset_table_used; i++)
+ mark_object (charset_table[i].attributes);
+}
+
void
init_charset (void)
diff --git a/src/charset.h b/src/charset.h
index 1743eb4c909..1edb4a248ac 100644
--- a/src/charset.h
+++ b/src/charset.h
@@ -150,8 +150,7 @@ struct charset
/* Index to charset_table. */
int id;
- /* Index to Vcharset_hash_table. */
- ptrdiff_t hash_index;
+ Lisp_Object attributes;
/* Dimension of the charset: 1, 2, 3, or 4. */
int dimension;
@@ -267,18 +266,18 @@ extern int emacs_mule_charset[256];
/* Return the attribute vector of charset whose symbol is SYMBOL. */
#define CHARSET_SYMBOL_ATTRIBUTES(symbol) \
- Fgethash ((symbol), Vcharset_hash_table, Qnil)
-
-#define CHARSET_ATTR_ID(attrs) AREF ((attrs), charset_id)
-#define CHARSET_ATTR_NAME(attrs) AREF ((attrs), charset_name)
-#define CHARSET_ATTR_PLIST(attrs) AREF ((attrs), charset_plist)
-#define CHARSET_ATTR_MAP(attrs) AREF ((attrs), charset_map)
-#define CHARSET_ATTR_DECODER(attrs) AREF ((attrs), charset_decoder)
-#define CHARSET_ATTR_ENCODER(attrs) AREF ((attrs), charset_encoder)
-#define CHARSET_ATTR_SUBSET(attrs) AREF ((attrs), charset_subset)
-#define CHARSET_ATTR_SUPERSET(attrs) AREF ((attrs), charset_superset)
-#define CHARSET_ATTR_UNIFY_MAP(attrs) AREF ((attrs), charset_unify_map)
-#define CHARSET_ATTR_DEUNIFIER(attrs) AREF ((attrs), charset_deunifier)
+ Fgethash (symbol, Vcharset_hash_table, Qnil)
+
+#define CHARSET_ATTR_ID(attrs) AREF (attrs, charset_id)
+#define CHARSET_ATTR_NAME(attrs) AREF (attrs, charset_name)
+#define CHARSET_ATTR_PLIST(attrs) AREF (attrs, charset_plist)
+#define CHARSET_ATTR_MAP(attrs) AREF (attrs, charset_map)
+#define CHARSET_ATTR_DECODER(attrs) AREF (attrs, charset_decoder)
+#define CHARSET_ATTR_ENCODER(attrs) AREF (attrs, charset_encoder)
+#define CHARSET_ATTR_SUBSET(attrs) AREF (attrs, charset_subset)
+#define CHARSET_ATTR_SUPERSET(attrs) AREF (attrs, charset_superset)
+#define CHARSET_ATTR_UNIFY_MAP(attrs) AREF (attrs, charset_unify_map)
+#define CHARSET_ATTR_DEUNIFIER(attrs) AREF (attrs, charset_deunifier)
#define CHARSET_SYMBOL_ID(symbol) \
CHARSET_ATTR_ID (CHARSET_SYMBOL_ATTRIBUTES (symbol))
@@ -286,14 +285,12 @@ extern int emacs_mule_charset[256];
/* Return an index to Vcharset_hash_table of the charset whose symbol
is SYMBOL. */
#define CHARSET_SYMBOL_HASH_INDEX(symbol) \
- hash_lookup (XHASH_TABLE (Vcharset_hash_table), symbol, NULL)
+ hash_lookup (XHASH_TABLE (Vcharset_hash_table), symbol)
/* Return the attribute vector of CHARSET. */
-#define CHARSET_ATTRIBUTES(charset) \
- (HASH_VALUE (XHASH_TABLE (Vcharset_hash_table), (charset)->hash_index))
+#define CHARSET_ATTRIBUTES(charset) (charset)->attributes
#define CHARSET_ID(charset) ((charset)->id)
-#define CHARSET_HASH_INDEX(charset) ((charset)->hash_index)
#define CHARSET_DIMENSION(charset) ((charset)->dimension)
#define CHARSET_CODE_SPACE(charset) ((charset)->code_space)
#define CHARSET_CODE_LINEAR_P(charset) ((charset)->code_linear_p)
@@ -314,21 +311,21 @@ extern int emacs_mule_charset[256];
#define CHARSET_UNIFIED_P(charset) ((charset)->unified_p)
#define CHARSET_NAME(charset) \
- (CHARSET_ATTR_NAME (CHARSET_ATTRIBUTES (charset)))
+ CHARSET_ATTR_NAME (CHARSET_ATTRIBUTES (charset))
#define CHARSET_MAP(charset) \
- (CHARSET_ATTR_MAP (CHARSET_ATTRIBUTES (charset)))
+ CHARSET_ATTR_MAP (CHARSET_ATTRIBUTES (charset))
#define CHARSET_DECODER(charset) \
- (CHARSET_ATTR_DECODER (CHARSET_ATTRIBUTES (charset)))
+ CHARSET_ATTR_DECODER (CHARSET_ATTRIBUTES (charset))
#define CHARSET_ENCODER(charset) \
- (CHARSET_ATTR_ENCODER (CHARSET_ATTRIBUTES (charset)))
+ CHARSET_ATTR_ENCODER (CHARSET_ATTRIBUTES (charset))
#define CHARSET_SUBSET(charset) \
- (CHARSET_ATTR_SUBSET (CHARSET_ATTRIBUTES (charset)))
+ CHARSET_ATTR_SUBSET (CHARSET_ATTRIBUTES (charset))
#define CHARSET_SUPERSET(charset) \
- (CHARSET_ATTR_SUPERSET (CHARSET_ATTRIBUTES (charset)))
+ CHARSET_ATTR_SUPERSET (CHARSET_ATTRIBUTES (charset))
#define CHARSET_UNIFY_MAP(charset) \
- (CHARSET_ATTR_UNIFY_MAP (CHARSET_ATTRIBUTES (charset)))
+ CHARSET_ATTR_UNIFY_MAP (CHARSET_ATTRIBUTES (charset))
#define CHARSET_DEUNIFIER(charset) \
- (CHARSET_ATTR_DEUNIFIER (CHARSET_ATTRIBUTES (charset)))
+ CHARSET_ATTR_DEUNIFIER (CHARSET_ATTRIBUTES (charset))
INLINE void
set_charset_attr (struct charset *charset, enum charset_attr_index idx,
@@ -345,7 +342,7 @@ set_charset_attr (struct charset *charset, enum charset_attr_index idx,
#define CHECK_CHARSET(x) \
do { \
if (! SYMBOLP (x) || CHARSET_SYMBOL_HASH_INDEX (x) < 0) \
- wrong_type_argument (Qcharsetp, (x)); \
+ wrong_type_argument (Qcharsetp, x); \
} while (false)
@@ -356,7 +353,7 @@ set_charset_attr (struct charset *charset, enum charset_attr_index idx,
ptrdiff_t idx; \
\
if (! SYMBOLP (x) || (idx = CHARSET_SYMBOL_HASH_INDEX (x)) < 0) \
- wrong_type_argument (Qcharsetp, (x)); \
+ wrong_type_argument (Qcharsetp, x); \
id = XFIXNUM (AREF (HASH_VALUE (XHASH_TABLE (Vcharset_hash_table), idx), \
charset_id)); \
} while (false)
@@ -367,7 +364,7 @@ set_charset_attr (struct charset *charset, enum charset_attr_index idx,
#define CHECK_CHARSET_GET_ATTR(x, attr) \
do { \
if (!SYMBOLP (x) || NILP (attr = CHARSET_SYMBOL_ATTRIBUTES (x))) \
- wrong_type_argument (Qcharsetp, (x)); \
+ wrong_type_argument (Qcharsetp, x); \
} while (false)
@@ -383,7 +380,7 @@ set_charset_attr (struct charset *charset, enum charset_attr_index idx,
contains the character C. */
#define CHAR_CHARSET(c) \
((c) < 0x80 ? CHARSET_FROM_ID (charset_ascii) \
- : char_charset ((c), Qnil, NULL))
+ : char_charset (c, Qnil, NULL))
#if false
/* Char-table of charset-sets. Each element is a bool vector indexed
@@ -410,18 +407,18 @@ extern Lisp_Object Vchar_charset_set;
: ((code) < (charset)->min_code || (code) > (charset)->max_code) \
? -1 \
: (charset)->unified_p \
- ? decode_char ((charset), (code)) \
+ ? decode_char (charset, code) \
: (charset)->method == CHARSET_METHOD_OFFSET \
? ((charset)->code_linear_p \
? (int) ((code) - (charset)->min_code) + (charset)->code_offset \
- : decode_char ((charset), (code))) \
+ : decode_char (charset, code)) \
: (charset)->method == CHARSET_METHOD_MAP \
? (((charset)->code_linear_p \
&& VECTORP (CHARSET_DECODER (charset))) \
? XFIXNUM (AREF (CHARSET_DECODER (charset), \
(code) - (charset)->min_code)) \
- : decode_char ((charset), (code))) \
- : decode_char ((charset), (code)))
+ : decode_char (charset, code)) \
+ : decode_char (charset, code))
extern Lisp_Object charset_work;
@@ -462,7 +459,7 @@ extern bool charset_map_loaded;
/* Set CHARSET to the charset highest priority of C, CODE to the
code-point of C in CHARSET. */
#define SPLIT_CHAR(c, charset, code) \
- ((charset) = char_charset ((c), Qnil, &(code)))
+ ((charset) = char_charset (c, Qnil, &(code)))
#define ISO_MAX_DIMENSION 3
@@ -501,15 +498,15 @@ extern int iso_charset_table[ISO_MAX_DIMENSION][ISO_MAX_CHARS][ISO_MAX_FINAL];
|| ((CHARSET_UNIFIED_P (charset) \
|| (charset)->method == CHARSET_METHOD_SUBSET \
|| (charset)->method == CHARSET_METHOD_SUPERSET) \
- ? encode_char ((charset), (c)) != (charset)->invalid_code \
- : (CHARSET_FAST_MAP_REF ((c), (charset)->fast_map) \
+ ? encode_char (charset, c) != (charset)->invalid_code \
+ : (CHARSET_FAST_MAP_REF (c, (charset)->fast_map) \
&& ((charset)->method == CHARSET_METHOD_OFFSET \
? (c) >= (charset)->min_char && (c) <= (charset)->max_char \
: ((charset)->method == CHARSET_METHOD_MAP \
&& (charset)->compact_codes_p \
&& CHAR_TABLE_P (CHARSET_ENCODER (charset))) \
- ? ! NILP (CHAR_TABLE_REF (CHARSET_ENCODER (charset), (c))) \
- : encode_char ((charset), (c)) != (charset)->invalid_code))))
+ ? ! NILP (CHAR_TABLE_REF (CHARSET_ENCODER (charset), c)) \
+ : encode_char (charset, c) != (charset)->invalid_code))))
/* Special macros for emacs-mule encoding. */
diff --git a/src/cmds.c b/src/cmds.c
index 6656e6c0c9c..81788b07242 100644
--- a/src/cmds.c
+++ b/src/cmds.c
@@ -453,7 +453,7 @@ internal_self_insert (int c, EMACS_INT n)
}
ptrdiff_t to;
- if (INT_ADD_WRAPV (PT, chars_to_delete, &to))
+ if (ckd_add (&to, PT, chars_to_delete))
to = PTRDIFF_MAX;
replace_range (PT, to, string, 1, 1, 1, 0, false);
Fforward_char (make_fixnum (n));
diff --git a/src/coding.c b/src/coding.c
index a2b3ad9a49b..c51ceb95475 100644
--- a/src/coding.c
+++ b/src/coding.c
@@ -314,9 +314,9 @@ static Lisp_Object Vbig5_coding_system;
/* ISO2022 section */
#define CODING_ISO_INITIAL(coding, reg) \
- (XFIXNUM (AREF (AREF (CODING_ID_ATTRS ((coding)->id), \
- coding_attr_iso_initial), \
- reg)))
+ XFIXNUM (AREF (AREF (CODING_ID_ATTRS ((coding)->id), \
+ coding_attr_iso_initial), \
+ reg))
#define CODING_ISO_REQUEST(coding, charset_id) \
@@ -466,7 +466,7 @@ enum iso_code_class_type
#define CODING_CCL_ENCODER(coding) \
AREF (CODING_ID_ATTRS ((coding)->id), coding_attr_ccl_encoder)
#define CODING_CCL_VALIDS(coding) \
- (SDATA (AREF (CODING_ID_ATTRS ((coding)->id), coding_attr_ccl_valids)))
+ SDATA (AREF (CODING_ID_ATTRS ((coding)->id), coding_attr_ccl_valids))
/* Index for each coding category in `coding_categories' */
@@ -614,10 +614,11 @@ inhibit_flag (int encoded_flag, bool var)
static bool
growable_destination (struct coding_system *coding)
{
- return STRINGP (coding->dst_object) || BUFFERP (coding->dst_object);
+ return (STRINGP (coding->dst_object)
+ || BUFFERP (coding->dst_object)
+ || NILP (coding->dst_object));
}
-
/* Safely get one byte from the source text pointed by SRC which ends
at SRC_END, and set C to that byte. If there are not enough bytes
in the source, it jumps to 'no_more_source'. If MULTIBYTEP,
@@ -651,6 +652,12 @@ growable_destination (struct coding_system *coding)
consumed_chars++; \
} while (0)
+/* Suppress clang warnings about consumed_chars never being used.
+ Although correct, the warnings are too much trouble to code around. */
+#if 13 <= __clang_major__ - defined __apple_build_version__
+# pragma clang diagnostic ignored "-Wunused-but-set-variable"
+#endif
+
/* Safely get two bytes from the source text pointed by SRC which ends
at SRC_END, and set C1 and C2 to those bytes while skipping the
heading multibyte characters. If there are not enough bytes in the
@@ -983,7 +990,7 @@ static void
coding_alloc_by_realloc (struct coding_system *coding, ptrdiff_t bytes)
{
ptrdiff_t newbytes;
- if (INT_ADD_WRAPV (coding->dst_bytes, bytes, &newbytes)
+ if (ckd_add (&newbytes, coding->dst_bytes, bytes)
|| SIZE_MAX < newbytes)
string_overflow ();
coding->destination = xrealloc (coding->destination, newbytes);
@@ -4192,12 +4199,12 @@ decode_coding_iso_2022 (struct coding_system *coding)
#define ENCODE_ISO_CHARACTER(charset, c) \
do { \
unsigned code; \
- CODING_ENCODE_CHAR (coding, dst, dst_end, (charset), (c), code); \
+ CODING_ENCODE_CHAR (coding, dst, dst_end, charset, c, code); \
\
if (CHARSET_DIMENSION (charset) == 1) \
- ENCODE_ISO_CHARACTER_DIMENSION1 ((charset), code); \
+ ENCODE_ISO_CHARACTER_DIMENSION1 (charset, code); \
else \
- ENCODE_ISO_CHARACTER_DIMENSION2 ((charset), code >> 8, code & 0xFF); \
+ ENCODE_ISO_CHARACTER_DIMENSION2 (charset, code >> 8, code & 0xFF); \
} while (0)
@@ -5482,7 +5489,7 @@ decode_coding_charset (struct coding_system *coding)
{
int c;
Lisp_Object val;
- struct charset *charset;
+ struct charset *charset UNINIT;
int dim;
int len = 1;
unsigned code;
@@ -6999,7 +7006,6 @@ get_translation (Lisp_Object trans, int *buf, int *buf_end, ptrdiff_t *nchars)
return Qnil;
}
-
static int
produce_chars (struct coding_system *coding, Lisp_Object translation_table,
bool last_block)
@@ -7053,12 +7059,14 @@ produce_chars (struct coding_system *coding, Lisp_Object translation_table,
{
eassert (growable_destination (coding));
ptrdiff_t dst_size;
- if (INT_MULTIPLY_WRAPV (to_nchars, MAX_MULTIBYTE_LENGTH,
- &dst_size)
- || INT_ADD_WRAPV (buf_end - buf, dst_size, &dst_size))
+ if (ckd_mul (&dst_size, to_nchars, MAX_MULTIBYTE_LENGTH)
+ || ckd_add (&dst_size, dst_size, buf_end - buf))
memory_full (SIZE_MAX);
dst = alloc_destination (coding, dst_size, dst);
- if (EQ (coding->src_object, coding->dst_object))
+ if (EQ (coding->src_object, coding->dst_object)
+ /* Input and output are not C buffers, which are safe to
+ assume to be different. */
+ && !NILP (coding->src_object))
{
coding_set_source (coding);
dst_end = (((unsigned char *) coding->source)
@@ -7093,7 +7101,10 @@ produce_chars (struct coding_system *coding, Lisp_Object translation_table,
const unsigned char *src = coding->source;
const unsigned char *src_end = src + coding->consumed;
- if (EQ (coding->dst_object, coding->src_object))
+ if (EQ (coding->dst_object, coding->src_object)
+ /* Input and output are not C buffers, which are safe to
+ assume to be different. */
+ && !NILP (coding->src_object))
{
eassert (growable_destination (coding));
dst_end = (unsigned char *) src;
@@ -7114,7 +7125,8 @@ produce_chars (struct coding_system *coding, Lisp_Object translation_table,
if (dst == dst_end)
{
eassert (growable_destination (coding));
- if (EQ (coding->src_object, coding->dst_object))
+ if (EQ (coding->src_object, coding->dst_object)
+ && !NILP (coding->src_object))
dst_end = (unsigned char *) src;
if (dst == dst_end)
{
@@ -7126,7 +7138,8 @@ produce_chars (struct coding_system *coding, Lisp_Object translation_table,
coding_set_source (coding);
src = coding->source + offset;
src_end = coding->source + coding->consumed;
- if (EQ (coding->src_object, coding->dst_object))
+ if (EQ (coding->src_object, coding->dst_object)
+ && !NILP (coding->src_object))
dst_end = (unsigned char *) src;
}
}
@@ -7145,14 +7158,16 @@ produce_chars (struct coding_system *coding, Lisp_Object translation_table,
if (dst >= dst_end - 1)
{
eassert (growable_destination (coding));
- if (EQ (coding->src_object, coding->dst_object))
+ if (EQ (coding->src_object, coding->dst_object)
+ && !NILP (coding->src_object))
dst_end = (unsigned char *) src;
if (dst >= dst_end - 1)
{
ptrdiff_t offset = src - coding->source;
ptrdiff_t more_bytes;
- if (EQ (coding->src_object, coding->dst_object))
+ if (EQ (coding->src_object, coding->dst_object)
+ && !NILP (coding->src_object))
more_bytes = ((src_end - src) / 2) + 2;
else
more_bytes = src_end - src + 2;
@@ -7161,7 +7176,8 @@ produce_chars (struct coding_system *coding, Lisp_Object translation_table,
coding_set_source (coding);
src = coding->source + offset;
src_end = coding->source + coding->consumed;
- if (EQ (coding->src_object, coding->dst_object))
+ if (EQ (coding->src_object, coding->dst_object)
+ && !NILP (coding->src_object))
dst_end = (unsigned char *) src;
}
}
@@ -7170,7 +7186,8 @@ produce_chars (struct coding_system *coding, Lisp_Object translation_table,
}
else
{
- if (!EQ (coding->src_object, coding->dst_object))
+ if (!(EQ (coding->src_object, coding->dst_object)
+ && !NILP (coding->src_object)))
{
ptrdiff_t require = coding->src_bytes - coding->dst_bytes;
@@ -7653,8 +7670,7 @@ consume_chars (struct coding_system *coding, Lisp_Object translation_table,
if (pos == stop_charset)
buf = handle_charset_annotation (pos, end_pos, coding,
buf, &stop_charset);
- stop = (stop_composition < stop_charset
- ? stop_composition : stop_charset);
+ stop = min (stop_composition, stop_charset);
}
if (! multibytep)
@@ -8165,7 +8181,7 @@ decode_coding_object (struct coding_system *coding,
Fcons (undo_list, Fcurrent_buffer ()));
bset_undo_list (current_buffer, Qt);
TEMP_SET_PT_BOTH (coding->dst_pos, coding->dst_pos_byte);
- val = safe_call1 (CODING_ATTR_POST_READ (attrs),
+ val = safe_calln (CODING_ATTR_POST_READ (attrs),
make_fixnum (coding->produced_char));
CHECK_FIXNAT (val);
coding->produced_char += Z - prev_Z;
@@ -8331,7 +8347,7 @@ encode_coding_object (struct coding_system *coding,
set_buffer_internal (XBUFFER (coding->src_object));
}
- safe_call2 (CODING_ATTR_PRE_WRITE (attrs),
+ safe_calln (CODING_ATTR_PRE_WRITE (attrs),
make_fixnum (BEG), make_fixnum (Z));
if (XBUFFER (coding->src_object) != current_buffer)
kill_src_buffer = 1;
@@ -8489,7 +8505,7 @@ preferred_coding_system (void)
return CODING_ID_NAME (id);
}
-#if defined (WINDOWSNT) || defined (CYGWIN)
+#if defined (WINDOWSNT) || defined (CYGWIN) || defined HAVE_ANDROID
Lisp_Object
from_unicode (Lisp_Object str)
@@ -8507,10 +8523,31 @@ from_unicode (Lisp_Object str)
Lisp_Object
from_unicode_buffer (const wchar_t *wstr)
{
+#if defined WINDOWSNT || defined CYGWIN
/* We get one of the two final null bytes for free. */
ptrdiff_t len = 1 + sizeof (wchar_t) * wcslen (wstr);
AUTO_STRING_WITH_LEN (str, (char *) wstr, len);
return from_unicode (str);
+#else
+ /* This code is used only on Android, where little endian UTF-16
+ strings are extended to 32-bit wchar_t. */
+
+ uint16_t *words;
+ size_t length, i;
+
+ length = wcslen (wstr) + 1;
+
+ USE_SAFE_ALLOCA;
+ SAFE_NALLOCA (words, sizeof *words, length);
+
+ for (i = 0; i < length - 1; ++i)
+ words[i] = wstr[i];
+
+ words[i] = '\0';
+ AUTO_STRING_WITH_LEN (str, (char *) words,
+ (length - 1) * sizeof *words);
+ return unbind_to (sa_count, from_unicode (str));
+#endif
}
wchar_t *
@@ -8530,7 +8567,7 @@ to_unicode (Lisp_Object str, Lisp_Object *buf)
return WCSDATA (*buf);
}
-#endif /* WINDOWSNT || CYGWIN */
+#endif /* WINDOWSNT || CYGWIN || HAVE_ANDROID */
/*** 8. Emacs Lisp library functions ***/
@@ -11740,7 +11777,7 @@ syms_of_coding (void)
DEFSYM (Qutf_8_unix, "utf-8-unix");
DEFSYM (Qutf_8_emacs, "utf-8-emacs");
-#if defined (WINDOWSNT) || defined (CYGWIN)
+#if defined (WINDOWSNT) || defined (CYGWIN) || defined HAVE_ANDROID
/* No, not utf-16-le: that one has a BOM. */
DEFSYM (Qutf_16le, "utf-16le");
#endif
diff --git a/src/coding.h b/src/coding.h
index 9e93d55bc83..8905e36838d 100644
--- a/src/coding.h
+++ b/src/coding.h
@@ -166,35 +166,35 @@ enum coding_attr_index
/* Return the name of a coding system specified by ID. */
#define CODING_ID_NAME(id) \
- (HASH_KEY (XHASH_TABLE (Vcoding_system_hash_table), id))
+ HASH_KEY (XHASH_TABLE (Vcoding_system_hash_table), id)
/* Return the attribute vector of a coding system specified by ID. */
#define CODING_ID_ATTRS(id) \
- (AREF (HASH_VALUE (XHASH_TABLE (Vcoding_system_hash_table), id), 0))
+ AREF (HASH_VALUE (XHASH_TABLE (Vcoding_system_hash_table), id), 0)
/* Return the list of aliases of a coding system specified by ID. */
#define CODING_ID_ALIASES(id) \
- (AREF (HASH_VALUE (XHASH_TABLE (Vcoding_system_hash_table), id), 1))
+ AREF (HASH_VALUE (XHASH_TABLE (Vcoding_system_hash_table), id), 1)
/* Return the eol-type of a coding system specified by ID. */
#define CODING_ID_EOL_TYPE(id) \
- (AREF (HASH_VALUE (XHASH_TABLE (Vcoding_system_hash_table), id), 2))
+ AREF (HASH_VALUE (XHASH_TABLE (Vcoding_system_hash_table), id), 2)
/* Return the spec vector of CODING_SYSTEM_SYMBOL. */
#define CODING_SYSTEM_SPEC(coding_system_symbol) \
- (Fgethash (coding_system_symbol, Vcoding_system_hash_table, Qnil))
+ Fgethash (coding_system_symbol, Vcoding_system_hash_table, Qnil)
/* Return the ID of CODING_SYSTEM_SYMBOL. */
#define CODING_SYSTEM_ID(coding_system_symbol) \
hash_lookup (XHASH_TABLE (Vcoding_system_hash_table), \
- coding_system_symbol, NULL)
+ coding_system_symbol)
/* Return true if CODING_SYSTEM_SYMBOL is a coding system. */
@@ -209,7 +209,7 @@ enum coding_attr_index
do { \
if (CODING_SYSTEM_ID (x) < 0 \
&& NILP (Fcheck_coding_system (x))) \
- wrong_type_argument (Qcoding_system_p, (x)); \
+ wrong_type_argument (Qcoding_system_p, x); \
} while (false)
@@ -225,7 +225,7 @@ enum coding_attr_index
spec = CODING_SYSTEM_SPEC (x); \
} \
if (NILP (spec)) \
- wrong_type_argument (Qcoding_system_p, (x)); \
+ wrong_type_argument (Qcoding_system_p, x); \
} while (false)
@@ -242,7 +242,7 @@ enum coding_attr_index
id = CODING_SYSTEM_ID (x); \
} \
if (id < 0) \
- wrong_type_argument (Qcoding_system_p, (x)); \
+ wrong_type_argument (Qcoding_system_p, x); \
} while (false)
@@ -709,7 +709,7 @@ extern void encode_coding_object (struct coding_system *,
/* Defined in this file. */
INLINE int surrogates_to_codepoint (int, int);
-#if defined (WINDOWSNT) || defined (CYGWIN)
+#if defined (WINDOWSNT) || defined (CYGWIN) || defined HAVE_ANDROID
/* These functions use Lisp string objects to store the UTF-16LE
strings that modern versions of Windows expect. These strings are
@@ -732,7 +732,7 @@ extern Lisp_Object from_unicode (Lisp_Object str);
/* Convert WSTR to an Emacs string. */
extern Lisp_Object from_unicode_buffer (const wchar_t *wstr);
-#endif /* WINDOWSNT || CYGWIN */
+#endif /* WINDOWSNT || CYGWIN || HAVE_ANDROID */
/* Macros for backward compatibility. */
@@ -745,10 +745,9 @@ extern Lisp_Object from_unicode_buffer (const wchar_t *wstr);
#define decode_coding_c_string(coding, src, bytes, dst_object) \
do { \
- (coding)->source = (src); \
- (coding)->src_chars = (coding)->src_bytes = (bytes); \
- decode_coding_object ((coding), Qnil, 0, 0, (bytes), (bytes), \
- (dst_object)); \
+ (coding)->source = src; \
+ (coding)->src_chars = (coding)->src_bytes = bytes; \
+ decode_coding_object (coding, Qnil, 0, 0, bytes, bytes, dst_object); \
} while (false)
diff --git a/src/comp.c b/src/comp.c
index 8428cf9020e..99f51e07048 100644
--- a/src/comp.c
+++ b/src/comp.c
@@ -469,7 +469,7 @@ load_gccjit_if_necessary (bool mandatory)
/* Increase this number to force a new Vcomp_abi_hash to be generated. */
-#define ABI_VERSION "5"
+#define ABI_VERSION "6"
/* Length of the hashes used for eln file naming. */
#define HASH_LENGTH 8
@@ -520,7 +520,7 @@ load_gccjit_if_necessary (bool mandatory)
#define DECL_BLOCK(name, func) \
gcc_jit_block *(name) = \
- gcc_jit_function_new_block ((func), STR (name))
+ gcc_jit_function_new_block (func, STR (name))
#ifndef WINDOWSNT
# ifdef HAVE__SETJMP
@@ -535,7 +535,7 @@ load_gccjit_if_necessary (bool mandatory)
#define SETJMP_NAME SETJMP
/* Max number function importable by native compiled code. */
-#define F_RELOC_MAX_SIZE 1500
+#define F_RELOC_MAX_SIZE 1600
typedef struct {
void *link_table[F_RELOC_MAX_SIZE];
@@ -700,6 +700,8 @@ 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);
+static Lisp_Object
+helper_sanitizer_assert (Lisp_Object, Lisp_Object);
/* Note: helper_link_table must match the list created by
`declare_runtime_imported_funcs'. */
@@ -712,6 +714,7 @@ static void *helper_link_table[] =
helper_unbind_n,
helper_save_restriction,
helper_GET_SYMBOL_WITH_POSITION,
+ helper_sanitizer_assert,
record_unwind_current_buffer,
set_internal,
helper_unwind_protect,
@@ -774,7 +777,7 @@ comp_hash_source_file (Lisp_Object filename)
#else
int res = md5_stream (f, SSDATA (digest));
#endif
- fclose (f);
+ emacs_fclose (f);
if (res)
xsignal2 (Qfile_notify_error, build_string ("hashing failed"), filename);
@@ -2440,7 +2443,7 @@ emit_limple_insn (Lisp_Object insn)
{
Lisp_Object arg1 = arg[1];
- if (EQ (Ftype_of (arg1), Qcomp_mvar))
+ if (EQ (Fcl_type_of (arg1), Qcomp_mvar))
res = emit_mvar_rval (arg1);
else if (EQ (FIRST (arg1), Qcall))
res = emit_limple_call (XCDR (arg1));
@@ -2973,6 +2976,10 @@ declare_runtime_imported_funcs (void)
ADD_IMPORTED (helper_GET_SYMBOL_WITH_POSITION, comp.lisp_symbol_with_position_ptr_type,
1, args);
+ args[0] = comp.lisp_obj_type;
+ args[1] = comp.lisp_obj_type;
+ ADD_IMPORTED (helper_sanitizer_assert, comp.lisp_obj_type, 2, args);
+
ADD_IMPORTED (record_unwind_current_buffer, comp.void_type, 0, NULL);
args[0] = args[1] = args[2] = comp.lisp_obj_type;
@@ -4328,11 +4335,10 @@ compile_function (Lisp_Object func)
declare_block (Qentry);
Lisp_Object blocks = CALL1I (comp-func-blocks, func);
struct Lisp_Hash_Table *ht = XHASH_TABLE (blocks);
- for (ptrdiff_t i = 0; i < HASH_TABLE_SIZE (ht); i++)
+ DOHASH_SAFE (ht, i)
{
Lisp_Object block_name = HASH_KEY (ht, i);
- if (!EQ (block_name, Qentry)
- && !BASE_EQ (block_name, Qunbound))
+ if (!EQ (block_name, Qentry))
declare_block (block_name);
}
@@ -4342,24 +4348,21 @@ compile_function (Lisp_Object func)
gcc_jit_lvalue_as_rvalue (comp.func_relocs));
- for (ptrdiff_t i = 0; i < HASH_TABLE_SIZE (ht); i++)
+ DOHASH_SAFE (ht, i)
{
Lisp_Object block_name = HASH_KEY (ht, i);
- if (!BASE_EQ (block_name, Qunbound))
+ Lisp_Object block = HASH_VALUE (ht, i);
+ Lisp_Object insns = CALL1I (comp-block-insns, block);
+ if (NILP (block) || NILP (insns))
+ xsignal1 (Qnative_ice,
+ build_string ("basic block is missing or empty"));
+
+ comp.block = retrive_block (block_name);
+ while (CONSP (insns))
{
- Lisp_Object block = HASH_VALUE (ht, i);
- Lisp_Object insns = CALL1I (comp-block-insns, block);
- if (NILP (block) || NILP (insns))
- xsignal1 (Qnative_ice,
- build_string ("basic block is missing or empty"));
-
- comp.block = retrive_block (block_name);
- while (CONSP (insns))
- {
- Lisp_Object insn = XCAR (insns);
- emit_limple_insn (insn);
- insns = XCDR (insns);
- }
+ Lisp_Object insn = XCAR (insns);
+ emit_limple_insn (insn);
+ insns = XCDR (insns);
}
}
const char *err = gcc_jit_context_get_first_error (comp.ctxt);
@@ -4621,6 +4624,8 @@ Return t on success. */)
emit_simple_limple_call_void_ret);
register_emitter (Qhelper_save_restriction,
emit_simple_limple_call_void_ret);
+ register_emitter (Qhelper_sanitizer_assert,
+ emit_simple_limple_call_lisp_ret);
/* Inliners. */
register_emitter (Qadd1, emit_add1);
register_emitter (Qsub1, emit_sub1);
@@ -4747,7 +4752,7 @@ DEFUN ("comp--release-ctxt", Fcomp__release_ctxt, Scomp__release_ctxt,
gcc_jit_context_release (comp.ctxt);
if (logfile)
- fclose (logfile);
+ emacs_fclose (logfile);
comp.ctxt = NULL;
return Qt;
@@ -4861,8 +4866,8 @@ add_compiler_options (void)
#endif
}
-DEFUN ("comp--compile-ctxt-to-file", Fcomp__compile_ctxt_to_file,
- Scomp__compile_ctxt_to_file,
+DEFUN ("comp--compile-ctxt-to-file0", Fcomp__compile_ctxt_to_file0,
+ Scomp__compile_ctxt_to_file0,
1, 1, 0,
doc: /* Compile the current context as native code to file FILENAME. */)
(Lisp_Object filename)
@@ -4963,14 +4968,12 @@ DEFUN ("comp--compile-ctxt-to-file", Fcomp__compile_ctxt_to_file,
struct Lisp_Hash_Table *func_h =
XHASH_TABLE (CALL1I (comp-ctxt-funcs-h, Vcomp_ctxt));
- for (ptrdiff_t i = 0; i < HASH_TABLE_SIZE (func_h); i++)
- if (!BASE_EQ (HASH_KEY (func_h, i), Qunbound))
- declare_function (HASH_VALUE (func_h, i));
+ DOHASH_SAFE (func_h, i)
+ declare_function (HASH_VALUE (func_h, i));
/* Compile all functions. Can't be done before because the
relocation structs has to be already defined. */
- for (ptrdiff_t i = 0; i < HASH_TABLE_SIZE (func_h); i++)
- if (!BASE_EQ (HASH_KEY (func_h, i), Qunbound))
- compile_function (HASH_VALUE (func_h, i));
+ DOHASH_SAFE (func_h, i)
+ compile_function (HASH_VALUE (func_h, i));
/* Work around bug#46495 (GCC PR99126). */
#if defined (WIDE_EMACS_INT) \
@@ -5086,6 +5089,21 @@ helper_GET_SYMBOL_WITH_POSITION (Lisp_Object a)
return XUNTAG (a, Lisp_Vectorlike, struct Lisp_Symbol_With_Pos);
}
+static Lisp_Object
+helper_sanitizer_assert (Lisp_Object val, Lisp_Object type)
+{
+ if (!comp_sanitizer_active
+ || !NILP ((CALL2I (cl-typep, val, type))))
+ return Qnil;
+
+ AUTO_STRING (format, "Comp sanitizer FAIL for %s with type %s");
+ CALLN (Fmessage, format, val, type);
+ CALL0I (backtrace);
+ xsignal2 (Qcomp_sanitizer_error, val, type);
+
+ return Qnil;
+}
+
/* `native-comp-eln-load-path' clean-up support code. */
@@ -5199,17 +5217,9 @@ maybe_defer_native_compilation (Lisp_Object function_name,
Fputhash (function_name, definition, Vcomp_deferred_pending_h);
- /* This is so deferred compilation is able to compile comp
- dependencies breaking circularity. */
- if (comp__compilable)
- {
- /* Startup is done, comp is usable. */
- CALL0I (startup--require-comp-safely);
- CALLN (Ffuncall, intern_c_string ("native--compile-async"),
- src, Qnil, Qlate);
- }
- else
- Vcomp__delayed_sources = Fcons (src, Vcomp__delayed_sources);
+ pending_funcalls
+ = Fcons (list (Qnative__compile_async, src, Qnil, Qlate),
+ pending_funcalls);
}
@@ -5674,13 +5684,6 @@ void
syms_of_comp (void)
{
#ifdef HAVE_NATIVE_COMP
- DEFVAR_LISP ("comp--delayed-sources", Vcomp__delayed_sources,
- doc: /* List of sources to be native-compiled when startup is finished.
-For internal use. */);
- DEFVAR_BOOL ("comp--compilable", comp__compilable,
- doc: /* Non-nil when comp.el can be native compiled.
-For internal use. */);
- /* Compiler control customizes. */
DEFVAR_BOOL ("native-comp-jit-compilation", native_comp_jit_compilation,
doc: /* If non-nil, compile loaded .elc files asynchronously.
@@ -5728,6 +5731,7 @@ natively-compiled one. */);
DEFSYM (Qhelper_unbind_n, "helper_unbind_n");
DEFSYM (Qhelper_unwind_protect, "helper_unwind_protect");
DEFSYM (Qhelper_save_restriction, "helper_save_restriction");
+ DEFSYM (Qhelper_sanitizer_assert, "helper_sanitizer_assert");
/* Inliners. */
DEFSYM (Qadd1, "1+");
DEFSYM (Qsub1, "1-");
@@ -5798,6 +5802,14 @@ natively-compiled one. */);
build_pure_c_string ("eln file inconsistent with current runtime "
"configuration, please recompile"));
+ DEFSYM (Qcomp_sanitizer_error, "comp-sanitizer-error");
+ Fput (Qcomp_sanitizer_error, Qerror_conditions,
+ pure_list (Qcomp_sanitizer_error, Qerror));
+ Fput (Qcomp_sanitizer_error, Qerror_message,
+ build_pure_c_string ("Native code sanitizer runtime error"));
+
+ DEFSYM (Qnative__compile_async, "native--compile-async");
+
defsubr (&Scomp__subr_signature);
defsubr (&Scomp_el_to_eln_rel_filename);
defsubr (&Scomp_el_to_eln_filename);
@@ -5806,7 +5818,7 @@ natively-compiled one. */);
defsubr (&Scomp__install_trampoline);
defsubr (&Scomp__init_ctxt);
defsubr (&Scomp__release_ctxt);
- defsubr (&Scomp__compile_ctxt_to_file);
+ defsubr (&Scomp__compile_ctxt_to_file0);
defsubr (&Scomp_libgccjit_version);
defsubr (&Scomp__register_lambda);
defsubr (&Scomp__register_subr);
@@ -5918,6 +5930,14 @@ subr-name -> arity
For internal use. */);
Vcomp_subr_arities_h = CALLN (Fmake_hash_table, QCtest, Qequal);
+ DEFVAR_BOOL ("comp-sanitizer-active", comp_sanitizer_active,
+ doc: /* If non-nil, enable runtime execution of native-compiler sanitizer.
+For this to be effective, Lisp code must be compiled
+with `comp-sanitizer-emit' non-nil.
+This is intended to be used only for development and
+verification of the native compiler. */);
+ comp_sanitizer_active = false;
+
Fprovide (intern_c_string ("native-compile"), Qnil);
#endif /* #ifdef HAVE_NATIVE_COMP */
diff --git a/src/composite.c b/src/composite.c
index 84cea8bcad6..e89d923168a 100644
--- a/src/composite.c
+++ b/src/composite.c
@@ -166,7 +166,7 @@ ptrdiff_t
get_composition_id (ptrdiff_t charpos, ptrdiff_t bytepos, ptrdiff_t nchars,
Lisp_Object prop, Lisp_Object string)
{
- Lisp_Object id, length, components, key, *key_contents, hash_code;
+ Lisp_Object id, length, components, key, *key_contents;
ptrdiff_t glyph_len;
struct Lisp_Hash_Table *hash_table = XHASH_TABLE (composition_hash_table);
ptrdiff_t hash_index;
@@ -240,7 +240,8 @@ get_composition_id (ptrdiff_t charpos, ptrdiff_t bytepos, ptrdiff_t nchars,
else
goto invalid_composition;
- hash_index = hash_lookup (hash_table, key, &hash_code);
+ hash_hash_t hash_code;
+ hash_index = hash_lookup_get_hash (hash_table, key, &hash_code);
if (hash_index >= 0)
{
/* We have already registered the same composition. Change PROP
@@ -320,7 +321,7 @@ get_composition_id (ptrdiff_t charpos, ptrdiff_t bytepos, ptrdiff_t nchars,
cmp = xmalloc (sizeof *cmp);
cmp->method = method;
- cmp->hash_index = hash_index;
+ cmp->key = key;
cmp->glyph_len = glyph_len;
cmp->offsets = xnmalloc (glyph_len, 2 * sizeof *cmp->offsets);
cmp->font = NULL;
@@ -642,10 +643,7 @@ static Lisp_Object gstring_hash_table;
Lisp_Object
composition_gstring_lookup_cache (Lisp_Object header)
{
- struct Lisp_Hash_Table *h = XHASH_TABLE (gstring_hash_table);
- ptrdiff_t i = hash_lookup (h, header, NULL);
-
- return (i >= 0 ? HASH_VALUE (h, i) : Qnil);
+ return Fgethash (header, gstring_hash_table, Qnil);
}
Lisp_Object
@@ -653,7 +651,7 @@ composition_gstring_put_cache (Lisp_Object gstring, ptrdiff_t len)
{
struct Lisp_Hash_Table *h = XHASH_TABLE (gstring_hash_table);
Lisp_Object header = LGSTRING_HEADER (gstring);
- Lisp_Object hash = h->test.hashfn (header, h);
+ EMACS_UINT hash = hash_from_key (h, header);
if (len < 0)
{
ptrdiff_t glyph_len = LGSTRING_GLYPH_LEN (gstring);
@@ -675,7 +673,7 @@ Lisp_Object
composition_gstring_from_id (ptrdiff_t id)
{
struct Lisp_Hash_Table *h = XHASH_TABLE (gstring_hash_table);
-
+ /* FIXME: The stability of this value depends on the hash table internals! */
return HASH_VALUE (h, id);
}
@@ -686,18 +684,9 @@ composition_gstring_cache_clear_font (Lisp_Object font_object)
{
struct Lisp_Hash_Table *h = XHASH_TABLE (gstring_hash_table);
- for (ptrdiff_t i = 0; i < HASH_TABLE_SIZE (h); ++i)
- {
- Lisp_Object k = HASH_KEY (h, i);
-
- if (!BASE_EQ (k, Qunbound))
- {
- Lisp_Object gstring = HASH_VALUE (h, i);
-
- if (EQ (LGSTRING_FONT (gstring), font_object))
- hash_remove_from_table (h, k);
- }
- }
+ DOHASH (h, k, gstring)
+ if (EQ (LGSTRING_FONT (gstring), font_object))
+ hash_remove_from_table (h, k);
}
DEFUN ("clear-composition-cache", Fclear_composition_cache,
@@ -987,7 +976,7 @@ autocmp_chars (Lisp_Object rule, ptrdiff_t charpos, ptrdiff_t bytepos,
if (NILP (string))
record_unwind_protect (restore_point_unwind,
build_marker (current_buffer, pt, pt_byte));
- lgstring = safe_call (7, Vauto_composition_function, AREF (rule, 2),
+ lgstring = safe_calln (Vauto_composition_function, AREF (rule, 2),
pos, make_fixnum (to), font_object, string,
direction);
}
@@ -1040,7 +1029,9 @@ inhibit_auto_composition (void)
composition closest to CHARPOS is found, set cmp_it->stop_pos to
the last character of the composition. STRING, if non-nil, is
the string (as opposed to a buffer) whose characters should be
- tested for being composable.
+ tested for being composable. INCLUDE_STATIC non-zero means
+ consider both static and automatic compositions; if zero, look
+ only for potential automatic compositions.
If no composition is found, set cmp_it->ch to -2. If a static
composition is found, set cmp_it->ch to -1. Otherwise, set
@@ -1050,7 +1041,7 @@ inhibit_auto_composition (void)
void
composition_compute_stop_pos (struct composition_it *cmp_it, ptrdiff_t charpos,
ptrdiff_t bytepos, ptrdiff_t endpos,
- Lisp_Object string)
+ Lisp_Object string, bool include_static)
{
ptrdiff_t start, end;
int c;
@@ -1084,8 +1075,10 @@ composition_compute_stop_pos (struct composition_it *cmp_it, ptrdiff_t charpos,
cmp_it->stop_pos = endpos;
if (charpos == endpos)
return;
+ /* Look for static compositions. */
/* FIXME: Bidi is not yet handled well in static composition. */
- if (charpos < endpos
+ if (include_static
+ && charpos < endpos
&& find_composition (charpos, endpos, &start, &end, &prop, string)
&& start >= charpos
&& composition_valid_p (start, end, prop))
@@ -1106,6 +1099,7 @@ composition_compute_stop_pos (struct composition_it *cmp_it, ptrdiff_t charpos,
bytepos = string_char_to_byte (string, charpos);
}
+ /* Look for automatic compositions. */
start = charpos;
if (charpos < endpos)
{
@@ -1301,7 +1295,8 @@ composition_reseat_it (struct composition_it *cmp_it, ptrdiff_t charpos,
{
if (cmp_it->ch == -2)
{
- composition_compute_stop_pos (cmp_it, charpos, bytepos, endpos, string);
+ composition_compute_stop_pos (cmp_it, charpos, bytepos, endpos, string,
+ true);
if (cmp_it->ch == -2 || cmp_it->stop_pos != charpos)
/* The current position is not composed. */
return 0;
@@ -1440,7 +1435,7 @@ composition_reseat_it (struct composition_it *cmp_it, ptrdiff_t charpos,
}
if (cmp_it->reversed_p)
endpos = -1;
- composition_compute_stop_pos (cmp_it, charpos, bytepos, endpos, string);
+ composition_compute_stop_pos (cmp_it, charpos, bytepos, endpos, string, true);
return 0;
}
@@ -2169,6 +2164,16 @@ of the way buffer text is examined for matching one of the rules. */)
}
+/* Not strictly necessary, because all those "keys" are also
+ reachable from `composition_hash_table`. */
+void
+mark_composite (void)
+{
+ for (int i = 0; i < n_compositions; i++)
+ mark_object (composition_table[i]->key);
+}
+
+
void
syms_of_composite (void)
{
diff --git a/src/composite.h b/src/composite.h
index afe9ae0ba32..4b412cea696 100644
--- a/src/composite.h
+++ b/src/composite.h
@@ -84,23 +84,20 @@ composition_registered_p (Lisp_Object prop)
? XCDR (XCDR (XCDR (prop))) \
: CONSP (prop) ? XCDR (prop) : Qnil)
+#define COMPOSITION_KEY(cmp) (cmp)->key
+
/* Return the Nth glyph of composition specified by CMP. CMP is a
pointer to `struct composition'. */
#define COMPOSITION_GLYPH(cmp, n) \
- XFIXNUM (XVECTOR (XVECTOR (XHASH_TABLE (composition_hash_table) \
- ->key_and_value) \
- ->contents[cmp->hash_index * 2]) \
- ->contents[cmp->method == COMPOSITION_WITH_RULE_ALTCHARS \
- ? (n) * 2 : (n)])
+ XFIXNUM (AREF (COMPOSITION_KEY (cmp), \
+ (cmp)->method == COMPOSITION_WITH_RULE_ALTCHARS \
+ ? (n) * 2 : (n)))
/* Return the encoded composition rule to compose the Nth glyph of
rule-base composition specified by CMP. CMP is a pointer to
`struct composition'. */
-#define COMPOSITION_RULE(cmp, n) \
- XFIXNUM (XVECTOR (XVECTOR (XHASH_TABLE (composition_hash_table) \
- ->key_and_value) \
- ->contents[cmp->hash_index * 2]) \
- ->contents[(n) * 2 - 1])
+#define COMPOSITION_RULE(cmp, n) \
+ XFIXNUM (AREF (COMPOSITION_KEY (cmp), (n) * 2 - 1))
/* Decode encoded composition rule RULE_CODE into GREF (global
reference point code), NREF (new ref. point code). Don't check RULE_CODE;
@@ -165,8 +162,8 @@ struct composition {
/* Method of the composition. */
enum composition_method method;
- /* Index to the composition hash table. */
- ptrdiff_t hash_index;
+ /* The key under which it's found in the composition hash table. */
+ Lisp_Object key;
/* For which font we have calculated the remaining members. The
actual type is device dependent. */
@@ -202,6 +199,7 @@ extern bool find_composition (ptrdiff_t, ptrdiff_t, ptrdiff_t *, ptrdiff_t *,
extern void update_compositions (ptrdiff_t, ptrdiff_t, int);
extern void make_composition_value_copy (Lisp_Object);
extern void syms_of_composite (void);
+extern void mark_composite (void);
extern void compose_text (ptrdiff_t, ptrdiff_t, Lisp_Object, Lisp_Object,
Lisp_Object);
@@ -262,8 +260,8 @@ composition_valid_p (ptrdiff_t start, ptrdiff_t end, Lisp_Object prop)
#define LGSTRING_CHAR(lgs, i) AREF (LGSTRING_HEADER (lgs), (i) + 1)
#define LGSTRING_CHAR_LEN(lgs) (ASIZE (LGSTRING_HEADER (lgs)) - 1)
-#define LGSTRING_SET_FONT(lgs, val) ASET (LGSTRING_HEADER (lgs), 0, (val))
-#define LGSTRING_SET_CHAR(lgs, i, c) ASET (LGSTRING_HEADER (lgs), (i) + 1, (c))
+#define LGSTRING_SET_FONT(lgs, val) ASET (LGSTRING_HEADER (lgs), 0, val)
+#define LGSTRING_SET_CHAR(lgs, i, c) ASET (LGSTRING_HEADER (lgs), (i) + 1, c)
#define LGSTRING_ID(lgs) AREF (lgs, 1)
#define LGSTRING_SET_ID(lgs, id) ASET (lgs, 1, id)
@@ -272,9 +270,9 @@ composition_valid_p (ptrdiff_t start, ptrdiff_t end, Lisp_Object prop)
LGSTRING can hold. This is NOT the actual number of valid LGLYPHs;
to find the latter, walk the glyphs returned by LGSTRING_GLYPH
until the first one that is nil. */
-#define LGSTRING_GLYPH_LEN(lgs) (ASIZE ((lgs)) - 2)
-#define LGSTRING_GLYPH(lgs, idx) AREF ((lgs), (idx) + 2)
-#define LGSTRING_SET_GLYPH(lgs, idx, val) ASET ((lgs), (idx) + 2, (val))
+#define LGSTRING_GLYPH_LEN(lgs) (ASIZE (lgs) - 2)
+#define LGSTRING_GLYPH(lgs, idx) AREF (lgs, (idx) + 2)
+#define LGSTRING_SET_GLYPH(lgs, idx, val) ASET (lgs, (idx) + 2, val)
INLINE Lisp_Object *
lgstring_glyph_addr (Lisp_Object lgs, ptrdiff_t idx)
{
@@ -300,33 +298,33 @@ enum lglyph_indices
contributed to the glyph (since there isn't a 1:1 correspondence
between composed characters and the font glyphs). */
#define LGLYPH_NEW() make_nil_vector (LGLYPH_SIZE)
-#define LGLYPH_FROM(g) XFIXNUM (AREF ((g), LGLYPH_IX_FROM))
-#define LGLYPH_TO(g) XFIXNUM (AREF ((g), LGLYPH_IX_TO))
-#define LGLYPH_CHAR(g) XFIXNUM (AREF ((g), LGLYPH_IX_CHAR))
+#define LGLYPH_FROM(g) XFIXNUM (AREF (g, LGLYPH_IX_FROM))
+#define LGLYPH_TO(g) XFIXNUM (AREF (g, LGLYPH_IX_TO))
+#define LGLYPH_CHAR(g) XFIXNUM (AREF (g, LGLYPH_IX_CHAR))
#define LGLYPH_CODE(g) \
- (NILP (AREF ((g), LGLYPH_IX_CODE)) \
+ (NILP (AREF (g, LGLYPH_IX_CODE)) \
? FONT_INVALID_CODE \
: cons_to_unsigned (AREF (g, LGLYPH_IX_CODE), TYPE_MAXIMUM (unsigned)))
-#define LGLYPH_WIDTH(g) XFIXNUM (AREF ((g), LGLYPH_IX_WIDTH))
-#define LGLYPH_LBEARING(g) XFIXNUM (AREF ((g), LGLYPH_IX_LBEARING))
-#define LGLYPH_RBEARING(g) XFIXNUM (AREF ((g), LGLYPH_IX_RBEARING))
-#define LGLYPH_ASCENT(g) XFIXNUM (AREF ((g), LGLYPH_IX_ASCENT))
-#define LGLYPH_DESCENT(g) XFIXNUM (AREF ((g), LGLYPH_IX_DESCENT))
-#define LGLYPH_ADJUSTMENT(g) AREF ((g), LGLYPH_IX_ADJUSTMENT)
-#define LGLYPH_SET_FROM(g, val) ASET ((g), LGLYPH_IX_FROM, make_fixnum (val))
-#define LGLYPH_SET_TO(g, val) ASET ((g), LGLYPH_IX_TO, make_fixnum (val))
-#define LGLYPH_SET_CHAR(g, val) ASET ((g), LGLYPH_IX_CHAR, make_fixnum (val))
+#define LGLYPH_WIDTH(g) XFIXNUM (AREF (g, LGLYPH_IX_WIDTH))
+#define LGLYPH_LBEARING(g) XFIXNUM (AREF (g, LGLYPH_IX_LBEARING))
+#define LGLYPH_RBEARING(g) XFIXNUM (AREF (g, LGLYPH_IX_RBEARING))
+#define LGLYPH_ASCENT(g) XFIXNUM (AREF (g, LGLYPH_IX_ASCENT))
+#define LGLYPH_DESCENT(g) XFIXNUM (AREF (g, LGLYPH_IX_DESCENT))
+#define LGLYPH_ADJUSTMENT(g) AREF (g, LGLYPH_IX_ADJUSTMENT)
+#define LGLYPH_SET_FROM(g, val) ASET (g, LGLYPH_IX_FROM, make_fixnum (val))
+#define LGLYPH_SET_TO(g, val) ASET (g, LGLYPH_IX_TO, make_fixnum (val))
+#define LGLYPH_SET_CHAR(g, val) ASET (g, LGLYPH_IX_CHAR, make_fixnum (val))
/* Callers must assure that VAL is not negative! */
#define LGLYPH_SET_CODE(g, val) \
ASET (g, LGLYPH_IX_CODE, \
val == FONT_INVALID_CODE ? Qnil : INT_TO_INTEGER (val))
-#define LGLYPH_SET_WIDTH(g, val) ASET ((g), LGLYPH_IX_WIDTH, make_fixnum (val))
-#define LGLYPH_SET_LBEARING(g, val) ASET ((g), LGLYPH_IX_LBEARING, make_fixnum (val))
-#define LGLYPH_SET_RBEARING(g, val) ASET ((g), LGLYPH_IX_RBEARING, make_fixnum (val))
-#define LGLYPH_SET_ASCENT(g, val) ASET ((g), LGLYPH_IX_ASCENT, make_fixnum (val))
-#define LGLYPH_SET_DESCENT(g, val) ASET ((g), LGLYPH_IX_DESCENT, make_fixnum (val))
-#define LGLYPH_SET_ADJUSTMENT(g, val) ASET ((g), LGLYPH_IX_ADJUSTMENT, (val))
+#define LGLYPH_SET_WIDTH(g, val) ASET (g, LGLYPH_IX_WIDTH, make_fixnum (val))
+#define LGLYPH_SET_LBEARING(g, val) ASET (g, LGLYPH_IX_LBEARING, make_fixnum (val))
+#define LGLYPH_SET_RBEARING(g, val) ASET (g, LGLYPH_IX_RBEARING, make_fixnum (val))
+#define LGLYPH_SET_ASCENT(g, val) ASET (g, LGLYPH_IX_ASCENT, make_fixnum (val))
+#define LGLYPH_SET_DESCENT(g, val) ASET (g, LGLYPH_IX_DESCENT, make_fixnum (val))
+#define LGLYPH_SET_ADJUSTMENT(g, val) ASET (g, LGLYPH_IX_ADJUSTMENT, val)
#define LGLYPH_XOFF(g) (VECTORP (LGLYPH_ADJUSTMENT (g)) \
? XFIXNUM (AREF (LGLYPH_ADJUSTMENT (g), 0)) : 0)
@@ -348,7 +346,7 @@ extern bool find_automatic_composition (ptrdiff_t, ptrdiff_t, ptrdiff_t,
extern void composition_compute_stop_pos (struct composition_it *,
ptrdiff_t, ptrdiff_t, ptrdiff_t,
- Lisp_Object);
+ Lisp_Object, bool);
extern bool composition_reseat_it (struct composition_it *, ptrdiff_t,
ptrdiff_t, ptrdiff_t, struct window *,
signed char, struct face *, Lisp_Object);
diff --git a/src/conf_post.h b/src/conf_post.h
index d6ad6bab06e..f2353803074 100644
--- a/src/conf_post.h
+++ b/src/conf_post.h
@@ -178,8 +178,8 @@ You lose; /* Emacs for DOS must be compiled with DJGPP */
/* Things that lib/reg* wants. */
-#define mbrtowc(pwc, s, n, ps) mbtowc ((pwc), (s), (n))
-#define wcrtomb(s, wc, ps) wctomb ((s), (wc))
+#define mbrtowc(pwc, s, n, ps) mbtowc (pwc, s, n)
+#define wcrtomb(s, wc, ps) wctomb (s, wc)
#define btowc(b) ((wchar_t) (b))
#define towupper(chr) toupper (chr)
#define towlower(chr) tolower (chr)
@@ -317,7 +317,7 @@ extern int emacs_setenv_TZ (char const *);
type _GL_ATTRIBUTE_MAY_ALIAS *name = (type *) (addr)
#if 3 <= __GNUC__
-# define ATTRIBUTE_SECTION(name) __attribute__((section (name)))
+# define ATTRIBUTE_SECTION(name) __attribute__ ((section (name)))
#else
# define ATTRIBUTE_SECTION(name)
#endif
@@ -461,3 +461,17 @@ extern int emacs_setenv_TZ (char const *);
#else
# define UNINIT /* empty */
#endif
+
+/* MB_CUR_MAX is often broken on systems which copy-paste LLVM
+ headers, so replace its definition with a working one if
+ necessary. */
+
+#ifdef REPLACEMENT_MB_CUR_MAX
+#include <stdlib.h>
+#undef MB_CUR_MAX
+#define MB_CUR_MAX REPLACEMENT_MB_CUR_MAX
+#endif /* REPLACEMENT_MB_CUR_MAX */
+
+/* Emacs does not need glibc strftime behavior for AM and PM
+ indicators. */
+#define REQUIRE_GNUISH_STRFTIME_AM_PM false
diff --git a/src/data.c b/src/data.c
index 2c82d3e20ce..c4b9cff8ae0 100644
--- a/src/data.c
+++ b/src/data.c
@@ -23,7 +23,6 @@ along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. */
#include <math.h>
#include <stdio.h>
-#include <byteswap.h>
#include <count-one-bits.h>
#include <count-trailing-zeros.h>
#include <intprops.h>
@@ -193,16 +192,37 @@ DEFUN ("null", Fnull, Snull, 1, 1, 0,
DEFUN ("type-of", Ftype_of, Stype_of, 1, 1, 0,
doc: /* Return a symbol representing the type of OBJECT.
The symbol returned names the object's basic type;
-for example, (type-of 1) returns `integer'. */)
+for example, (type-of 1) returns `integer'.
+Contrary to `cl-type-of', the returned type is not always the most
+precise type possible, because instead this function tries to preserve
+compatibility with the return value of previous Emacs versions. */)
+ (Lisp_Object object)
+{
+ return SYMBOLP (object) ? Qsymbol
+ : INTEGERP (object) ? Qinteger
+ : SUBRP (object) ? Qsubr
+ : Fcl_type_of (object);
+}
+
+DEFUN ("cl-type-of", Fcl_type_of, Scl_type_of, 1, 1, 0,
+ doc: /* Return a symbol representing the type of OBJECT.
+The returned symbol names the most specific possible type of the object.
+for example, (cl-type-of nil) returns `null'.
+The specific type returned may change depending on Emacs versions,
+so we recommend you use `cl-typep', `cl-typecase', or other predicates
+rather than compare the return value of this function against
+a fixed set of types. */)
(Lisp_Object object)
{
switch (XTYPE (object))
{
case_Lisp_Int:
- return Qinteger;
+ return Qfixnum;
case Lisp_Symbol:
- return Qsymbol;
+ return NILP (object) ? Qnull
+ : EQ (object, Qt) ? Qboolean
+ : Qsymbol;
case Lisp_String:
return Qstring;
@@ -211,11 +231,11 @@ for example, (type-of 1) returns `integer'. */)
return Qcons;
case Lisp_Vectorlike:
- /* WARNING!! Keep 'cl--typeof-types' in sync with this code!! */
+ /* WARNING!! Keep 'cl--type-hierarchy' in sync with this code!! */
switch (PSEUDOVECTOR_TYPE (XVECTOR (object)))
{
case PVEC_NORMAL_VECTOR: return Qvector;
- case PVEC_BIGNUM: return Qinteger;
+ case PVEC_BIGNUM: return Qbignum;
case PVEC_MARKER: return Qmarker;
case PVEC_SYMBOL_WITH_POS: return Qsymbol_with_pos;
case PVEC_OVERLAY: return Qoverlay;
@@ -224,13 +244,17 @@ for example, (type-of 1) returns `integer'. */)
case PVEC_WINDOW_CONFIGURATION: return Qwindow_configuration;
case PVEC_PROCESS: return Qprocess;
case PVEC_WINDOW: return Qwindow;
- case PVEC_SUBR: return Qsubr;
+ case PVEC_SUBR:
+ return XSUBR (object)->max_args == UNEVALLED ? Qspecial_form
+ : SUBR_NATIVE_COMPILEDP (object) ? Qsubr_native_elisp
+ : Qprimitive_function;
case PVEC_COMPILED: return Qcompiled_function;
case PVEC_BUFFER: return Qbuffer;
case PVEC_CHAR_TABLE: return Qchar_table;
case PVEC_BOOL_VECTOR: return Qbool_vector;
case PVEC_FRAME: return Qframe;
case PVEC_HASH_TABLE: return Qhash_table;
+ case PVEC_OBARRAY: return Qobarray;
case PVEC_FONT:
if (FONT_SPEC_P (object))
return Qfont_spec;
@@ -269,10 +293,11 @@ for example, (type-of 1) returns `integer'. */)
return Qtreesit_compiled_query;
case PVEC_SQLITE:
return Qsqlite;
+ case PVEC_SUB_CHAR_TABLE:
+ return Qsub_char_table;
/* "Impossible" cases. */
case PVEC_MISC_PTR:
case PVEC_OTHER:
- case PVEC_SUB_CHAR_TABLE:
case PVEC_FREE: ;
}
emacs_abort ();
@@ -337,7 +362,8 @@ DEFUN ("bare-symbol-p", Fbare_symbol_p, Sbare_symbol_p, 1, 1, 0,
}
DEFUN ("symbol-with-pos-p", Fsymbol_with_pos_p, Ssymbol_with_pos_p, 1, 1, 0,
- doc: /* Return t if OBJECT is a symbol together with position. */
+ doc: /* Return t if OBJECT is a symbol together with position.
+Ignore `symbols-with-pos-enabled'. */
attributes: const)
(Lisp_Object object)
{
@@ -683,7 +709,7 @@ global value outside of any lexical scope. */)
switch (sym->u.s.redirect)
{
case SYMBOL_PLAINVAL: valcontents = SYMBOL_VAL (sym); break;
- case SYMBOL_VARALIAS: sym = indirect_variable (sym); goto start;
+ case SYMBOL_VARALIAS: sym = SYMBOL_ALIAS (sym); goto start;
case SYMBOL_LOCALIZED:
{
struct Lisp_Buffer_Local_Value *blv = SYMBOL_BLV (sym);
@@ -787,55 +813,54 @@ Doing that might make Emacs dysfunctional, and might even crash Emacs. */)
}
DEFUN ("bare-symbol", Fbare_symbol, Sbare_symbol, 1, 1, 0,
- doc: /* Extract, if need be, the bare symbol from SYM, a symbol. */)
+ doc: /* Extract, if need be, the bare symbol from SYM.
+SYM is either a symbol or a symbol with position.
+Ignore `symbols-with-pos-enabled'. */)
(register Lisp_Object sym)
{
if (BARE_SYMBOL_P (sym))
return sym;
- /* Type checking is done in the following macro. */
- return SYMBOL_WITH_POS_SYM (sym);
+ if (SYMBOL_WITH_POS_P (sym))
+ return XSYMBOL_WITH_POS_SYM (sym);
+ xsignal2 (Qwrong_type_argument, list2 (Qsymbolp, Qsymbol_with_pos_p), sym);
}
DEFUN ("symbol-with-pos-pos", Fsymbol_with_pos_pos, Ssymbol_with_pos_pos, 1, 1, 0,
- doc: /* Extract the position from a symbol with position. */)
- (register Lisp_Object ls)
+ doc: /* Extract the position from the symbol with position SYMPOS.
+Ignore `symbols-with-pos-enabled'. */)
+ (register Lisp_Object sympos)
{
- /* Type checking is done in the following macro. */
- return SYMBOL_WITH_POS_POS (ls);
+ CHECK_TYPE (SYMBOL_WITH_POS_P (sympos), Qsymbol_with_pos_p, sympos);
+ return XSYMBOL_WITH_POS_POS (sympos);
}
DEFUN ("remove-pos-from-symbol", Fremove_pos_from_symbol,
Sremove_pos_from_symbol, 1, 1, 0,
doc: /* If ARG is a symbol with position, return it without the position.
-Otherwise, return ARG unchanged. Compare with `bare-symbol'. */)
+Otherwise, return ARG unchanged. Ignore `symbols-with-pos-enabled'.
+Compare with `bare-symbol'. */)
(register Lisp_Object arg)
{
if (SYMBOL_WITH_POS_P (arg))
- return (SYMBOL_WITH_POS_SYM (arg));
+ return XSYMBOL_WITH_POS_SYM (arg);
return arg;
}
DEFUN ("position-symbol", Fposition_symbol, Sposition_symbol, 2, 2, 0,
- doc: /* Create a new symbol with position.
+ doc: /* Make a new symbol with position.
SYM is a symbol, with or without position, the symbol to position.
-POS, the position, is either a fixnum or a symbol with position from which
-the position will be taken. */)
+POS, the position, is either a nonnegative fixnum,
+or a symbol with position from which the position will be taken.
+Ignore `symbols-with-pos-enabled'. */)
(register Lisp_Object sym, register Lisp_Object pos)
{
- Lisp_Object bare;
+ Lisp_Object bare = Fbare_symbol (sym);
Lisp_Object position;
- if (BARE_SYMBOL_P (sym))
- bare = sym;
- else if (SYMBOL_WITH_POS_P (sym))
- bare = XSYMBOL_WITH_POS (sym)->sym;
- else
- wrong_type_argument (Qsymbolp, sym);
-
if (FIXNUMP (pos))
position = pos;
else if (SYMBOL_WITH_POS_P (pos))
- position = XSYMBOL_WITH_POS (pos)->pos;
+ position = XSYMBOL_WITH_POS_POS (pos);
else
wrong_type_argument (Qfixnum_or_symbol_with_pos_p, pos);
@@ -843,7 +868,9 @@ the position will be taken. */)
}
DEFUN ("fset", Ffset, Sfset, 2, 2, 0,
- doc: /* Set SYMBOL's function definition to DEFINITION, and return DEFINITION. */)
+ doc: /* Set SYMBOL's function definition to DEFINITION, and return DEFINITION.
+If the resulting chain of function definitions would contain a loop,
+signal a `cyclic-function-indirection' error. */)
(register Lisp_Object symbol, Lisp_Object definition)
{
CHECK_SYMBOL (symbol);
@@ -855,6 +882,12 @@ DEFUN ("fset", Ffset, Sfset, 2, 2, 0,
eassert (valid_lisp_object_p (definition));
+ /* Ensure non-circularity. */
+ for (Lisp_Object s = definition; SYMBOLP (s) && !NILP (s);
+ s = XSYMBOL (s)->u.s.function)
+ if (EQ (s, symbol))
+ xsignal1 (Qcyclic_function_indirection, symbol);
+
#ifdef HAVE_NATIVE_COMP
register Lisp_Object function = XSYMBOL (symbol)->u.s.function;
@@ -1081,7 +1114,7 @@ If CMD is not a command, the return value is nil.
Value, if non-nil, is a list (interactive SPEC). */)
(Lisp_Object cmd)
{
- Lisp_Object fun = indirect_function (cmd); /* Check cycles. */
+ Lisp_Object fun = indirect_function (cmd);
bool genfun = false;
if (NILP (fun))
@@ -1171,7 +1204,7 @@ If COMMAND is not a command, the return value is nil.
The value, if non-nil, is a list of mode name symbols. */)
(Lisp_Object command)
{
- Lisp_Object fun = indirect_function (command); /* Check cycles. */
+ Lisp_Object fun = indirect_function (command);
if (NILP (fun))
return Qnil;
@@ -1241,51 +1274,20 @@ The value, if non-nil, is a list of mode name symbols. */)
Getting and Setting Values of Symbols
***********************************************************************/
-/* Return the symbol holding SYMBOL's value. Signal
- `cyclic-variable-indirection' if SYMBOL's chain of variable
- indirections contains a loop. */
-
-struct Lisp_Symbol *
-indirect_variable (struct Lisp_Symbol *symbol)
-{
- struct Lisp_Symbol *tortoise, *hare;
-
- hare = tortoise = symbol;
-
- while (hare->u.s.redirect == SYMBOL_VARALIAS)
- {
- hare = SYMBOL_ALIAS (hare);
- if (hare->u.s.redirect != SYMBOL_VARALIAS)
- break;
-
- hare = SYMBOL_ALIAS (hare);
- tortoise = SYMBOL_ALIAS (tortoise);
-
- if (hare == tortoise)
- {
- Lisp_Object tem;
- XSETSYMBOL (tem, symbol);
- xsignal1 (Qcyclic_variable_indirection, tem);
- }
- }
-
- return hare;
-}
-
-
DEFUN ("indirect-variable", Findirect_variable, Sindirect_variable, 1, 1, 0,
doc: /* Return the variable at the end of OBJECT's variable chain.
If OBJECT is a symbol, follow its variable indirections (if any), and
return the variable at the end of the chain of aliases. See Info node
`(elisp)Variable Aliases'.
-If OBJECT is not a symbol, just return it. If there is a loop in the
-chain of aliases, signal a `cyclic-variable-indirection' error. */)
+If OBJECT is not a symbol, just return it. */)
(Lisp_Object object)
{
if (SYMBOLP (object))
{
- struct Lisp_Symbol *sym = indirect_variable (XSYMBOL (object));
+ struct Lisp_Symbol *sym = XSYMBOL (object);
+ while (sym->u.s.redirect == SYMBOL_VARALIAS)
+ sym = SYMBOL_ALIAS (sym);
XSETSYMBOL (object, sym);
}
return object;
@@ -1574,7 +1576,7 @@ find_symbol_value (Lisp_Object symbol)
start:
switch (sym->u.s.redirect)
{
- case SYMBOL_VARALIAS: sym = indirect_variable (sym); goto start;
+ case SYMBOL_VARALIAS: sym = SYMBOL_ALIAS (sym); goto start;
case SYMBOL_PLAINVAL: return SYMBOL_VAL (sym);
case SYMBOL_LOCALIZED:
{
@@ -1629,8 +1631,6 @@ set_internal (Lisp_Object symbol, Lisp_Object newval, Lisp_Object where,
bool voide = BASE_EQ (newval, Qunbound);
/* If restoring in a dead buffer, do nothing. */
- /* if (BUFFERP (where) && NILP (XBUFFER (where)->name))
- return; */
CHECK_SYMBOL (symbol);
struct Lisp_Symbol *sym = XSYMBOL (symbol);
@@ -1663,7 +1663,7 @@ set_internal (Lisp_Object symbol, Lisp_Object newval, Lisp_Object where,
start:
switch (sym->u.s.redirect)
{
- case SYMBOL_VARALIAS: sym = indirect_variable (sym); goto start;
+ case SYMBOL_VARALIAS: sym = SYMBOL_ALIAS (sym); goto start;
case SYMBOL_PLAINVAL: SET_SYMBOL_VAL (sym , newval); return;
case SYMBOL_LOCALIZED:
{
@@ -1917,7 +1917,7 @@ default_value (Lisp_Object symbol)
start:
switch (sym->u.s.redirect)
{
- case SYMBOL_VARALIAS: sym = indirect_variable (sym); goto start;
+ case SYMBOL_VARALIAS: sym = SYMBOL_ALIAS (sym); goto start;
case SYMBOL_PLAINVAL: return SYMBOL_VAL (sym);
case SYMBOL_LOCALIZED:
{
@@ -2011,7 +2011,7 @@ set_default_internal (Lisp_Object symbol, Lisp_Object value,
start:
switch (sym->u.s.redirect)
{
- case SYMBOL_VARALIAS: sym = indirect_variable (sym); goto start;
+ case SYMBOL_VARALIAS: sym = SYMBOL_ALIAS (sym); goto start;
case SYMBOL_PLAINVAL: set_internal (symbol, value, Qnil, bindflag); return;
case SYMBOL_LOCALIZED:
{
@@ -2149,7 +2149,7 @@ See also `defvar-local'. */)
start:
switch (sym->u.s.redirect)
{
- case SYMBOL_VARALIAS: sym = indirect_variable (sym); goto start;
+ case SYMBOL_VARALIAS: sym = SYMBOL_ALIAS (sym); goto start;
case SYMBOL_PLAINVAL:
forwarded = 0; valcontents.value = SYMBOL_VAL (sym);
if (BASE_EQ (valcontents.value, Qunbound))
@@ -2217,7 +2217,7 @@ Instead, use `add-hook' and specify t for the LOCAL argument. */)
start:
switch (sym->u.s.redirect)
{
- case SYMBOL_VARALIAS: sym = indirect_variable (sym); goto start;
+ case SYMBOL_VARALIAS: sym = SYMBOL_ALIAS (sym); goto start;
case SYMBOL_PLAINVAL:
forwarded = 0; valcontents.value = SYMBOL_VAL (sym); break;
case SYMBOL_LOCALIZED:
@@ -2235,17 +2235,18 @@ Instead, use `add-hook' and specify t for the LOCAL argument. */)
if (sym->u.s.trapped_write == SYMBOL_NOWRITE)
xsignal1 (Qsetting_constant, variable);
- if (blv ? blv->local_if_set
- : (forwarded && BUFFER_OBJFWDP (valcontents.fwd)))
- {
- tem = Fboundp (variable);
- /* Make sure the symbol has a local value in this particular buffer,
- by setting it to the same value it already has. */
- Fset (variable, (EQ (tem, Qt) ? Fsymbol_value (variable) : Qunbound));
- return variable;
- }
if (!blv)
{
+ if (forwarded && BUFFER_OBJFWDP (valcontents.fwd))
+ {
+ int offset = XBUFFER_OBJFWD (valcontents.fwd)->offset;
+ int idx = PER_BUFFER_IDX (offset);
+ eassert (idx);
+ if (idx > 0)
+ /* If idx < 0, it's always buffer local, like `mode-name`. */
+ SET_PER_BUFFER_VALUE_P (current_buffer, idx, true);
+ return variable;
+ }
blv = make_blv (sym, forwarded, valcontents);
sym->u.s.redirect = SYMBOL_LOCALIZED;
SET_SYMBOL_BLV (sym, blv);
@@ -2303,7 +2304,7 @@ From now on the default value will apply in this buffer. Return VARIABLE. */)
start:
switch (sym->u.s.redirect)
{
- case SYMBOL_VARALIAS: sym = indirect_variable (sym); goto start;
+ case SYMBOL_VARALIAS: sym = SYMBOL_ALIAS (sym); goto start;
case SYMBOL_PLAINVAL: return variable;
case SYMBOL_FORWARDED:
{
@@ -2370,7 +2371,7 @@ Also see `buffer-local-boundp'.*/)
start:
switch (sym->u.s.redirect)
{
- case SYMBOL_VARALIAS: sym = indirect_variable (sym); goto start;
+ case SYMBOL_VARALIAS: sym = SYMBOL_ALIAS (sym); goto start;
case SYMBOL_PLAINVAL: return Qnil;
case SYMBOL_LOCALIZED:
{
@@ -2420,7 +2421,7 @@ value in BUFFER, or if VARIABLE is automatically buffer-local (see
start:
switch (sym->u.s.redirect)
{
- case SYMBOL_VARALIAS: sym = indirect_variable (sym); goto start;
+ case SYMBOL_VARALIAS: sym = SYMBOL_ALIAS (sym); goto start;
case SYMBOL_PLAINVAL: return Qnil;
case SYMBOL_LOCALIZED:
{
@@ -2455,7 +2456,7 @@ If the current binding is global (the default), the value is nil. */)
start:
switch (sym->u.s.redirect)
{
- case SYMBOL_VARALIAS: sym = indirect_variable (sym); goto start;
+ case SYMBOL_VARALIAS: sym = SYMBOL_ALIAS (sym); goto start;
case SYMBOL_PLAINVAL: return Qnil;
case SYMBOL_FORWARDED:
{
@@ -2485,55 +2486,22 @@ If the current binding is global (the default), the value is nil. */)
/* If OBJECT is a symbol, find the end of its function chain and
return the value found there. If OBJECT is not a symbol, just
- return it. If there is a cycle in the function chain, signal a
- cyclic-function-indirection error.
-
- This is like Findirect_function, except that it doesn't signal an
- error if the chain ends up unbound. */
+ return it. */
Lisp_Object
-indirect_function (register Lisp_Object object)
+indirect_function (Lisp_Object object)
{
- Lisp_Object tortoise, hare;
-
- hare = tortoise = object;
-
- for (;;)
- {
- if (!SYMBOLP (hare) || NILP (hare))
- break;
- hare = XSYMBOL (hare)->u.s.function;
- if (!SYMBOLP (hare) || NILP (hare))
- break;
- hare = XSYMBOL (hare)->u.s.function;
-
- tortoise = XSYMBOL (tortoise)->u.s.function;
-
- if (EQ (hare, tortoise))
- xsignal1 (Qcyclic_function_indirection, object);
- }
-
- return hare;
+ while (SYMBOLP (object) && !NILP (object))
+ object = XSYMBOL (object)->u.s.function;
+ return object;
}
DEFUN ("indirect-function", Findirect_function, Sindirect_function, 1, 2, 0,
doc: /* Return the function at the end of OBJECT's function chain.
If OBJECT is not a symbol, just return it. Otherwise, follow all
-function indirections to find the final function binding and return it.
-Signal a cyclic-function-indirection error if there is a loop in the
-function chain of symbols. */)
- (register Lisp_Object object, Lisp_Object noerror)
+function indirections to find the final function binding and return it. */)
+ (Lisp_Object object, Lisp_Object noerror)
{
- Lisp_Object result;
-
- /* Optimize for no indirection. */
- result = object;
- if (SYMBOLP (result) && !NILP (result)
- && (result = XSYMBOL (result)->u.s.function, SYMBOLP (result)))
- result = indirect_function (result);
- if (!NILP (result))
- return result;
-
- return Qnil;
+ return indirect_function (object);
}
/* Extract and set vector and string elements. */
@@ -2622,6 +2590,7 @@ bool-vector. IDX starts at 0. */)
}
else if (RECORDP (array))
{
+ CHECK_IMPURE (array, XVECTOR (array));
if (idxval < 0 || idxval >= PVSIZE (array))
args_out_of_range (array, idx);
ASET (array, idxval, newelt);
@@ -3087,7 +3056,8 @@ If the base used is not 10, STRING is always parsed as an integer. */)
p++;
Lisp_Object val = string_to_number (p, b, 0);
- return NILP (val) ? make_fixnum (0) : val;
+ return ((IEEE_FLOATING_POINT ? NILP (val) : !NUMBERP (val))
+ ? make_fixnum (0) : val);
}
enum arithop
@@ -3245,9 +3215,9 @@ arith_driver (enum arithop code, ptrdiff_t nargs, Lisp_Object *args,
intmax_t a;
switch (code)
{
- case Aadd : overflow = INT_ADD_WRAPV (accum, next, &a); break;
- case Amult: overflow = INT_MULTIPLY_WRAPV (accum, next, &a); break;
- case Asub : overflow = INT_SUBTRACT_WRAPV (accum, next, &a); break;
+ case Aadd : overflow = ckd_add (&a, accum, next); break;
+ case Amult: overflow = ckd_mul (&a, accum, next); break;
+ case Asub : overflow = ckd_sub (&a, accum, next); break;
case Adiv:
if (next == 0)
xsignal0 (Qarith_error);
@@ -3864,30 +3834,6 @@ count_trailing_zero_bits (bits_word val)
}
}
-static bits_word
-bits_word_to_host_endian (bits_word val)
-{
-#ifndef WORDS_BIGENDIAN
- return val;
-#else
- if (BITS_WORD_MAX >> 31 == 1)
- return bswap_32 (val);
- if (BITS_WORD_MAX >> 31 >> 31 >> 1 == 1)
- return bswap_64 (val);
- {
- int i;
- bits_word r = 0;
- for (i = 0; i < sizeof val; i++)
- {
- r = ((r << 1 << (CHAR_BIT - 1))
- | (val & ((1u << 1 << (CHAR_BIT - 1)) - 1)));
- val = val >> 1 >> (CHAR_BIT - 1);
- }
- return r;
- }
-#endif
-}
-
DEFUN ("bool-vector-exclusive-or", Fbool_vector_exclusive_or,
Sbool_vector_exclusive_or, 2, 3, 0,
doc: /* Return A ^ B, bitwise exclusive or.
@@ -4101,6 +4047,7 @@ syms_of_data (void)
DEFSYM (Qminibuffer_quit, "minibuffer-quit");
DEFSYM (Qwrong_length_argument, "wrong-length-argument");
DEFSYM (Qwrong_type_argument, "wrong-type-argument");
+ DEFSYM (Qtype_mismatch, "type-mismatch")
DEFSYM (Qargs_out_of_range, "args-out-of-range");
DEFSYM (Qvoid_function, "void-function");
DEFSYM (Qcyclic_function_indirection, "cyclic-function-indirection");
@@ -4163,7 +4110,14 @@ syms_of_data (void)
DEFSYM (Qunevalled, "unevalled");
DEFSYM (Qmany, "many");
+ DEFSYM (Qcar, "car");
DEFSYM (Qcdr, "cdr");
+ DEFSYM (Qnth, "nth");
+ DEFSYM (Qelt, "elt");
+ DEFSYM (Qsetcar, "setcar");
+ DEFSYM (Qsetcdr, "setcdr");
+ DEFSYM (Qaref, "aref");
+ DEFSYM (Qaset, "aset");
error_tail = pure_cons (Qerror, Qnil);
@@ -4185,6 +4139,7 @@ syms_of_data (void)
PUT_ERROR (Quser_error, error_tail, "");
PUT_ERROR (Qwrong_length_argument, error_tail, "Wrong length argument");
PUT_ERROR (Qwrong_type_argument, error_tail, "Wrong type argument");
+ PUT_ERROR (Qtype_mismatch, error_tail, "Types do not match");
PUT_ERROR (Qargs_out_of_range, error_tail, "Args out of range");
PUT_ERROR (Qvoid_function, error_tail,
"Symbol's function definition is void");
@@ -4241,13 +4196,16 @@ syms_of_data (void)
Fput (Qrecursion_error, Qerror_message, build_pure_c_string
("Excessive recursive calling error"));
- PUT_ERROR (Qexcessive_variable_binding, recursion_tail,
- "Variable binding depth exceeds max-specpdl-size");
PUT_ERROR (Qexcessive_lisp_nesting, recursion_tail,
"Lisp nesting exceeds `max-lisp-eval-depth'");
+ /* Error obsolete (from 29.1), kept for compatibility. */
+ PUT_ERROR (Qexcessive_variable_binding, recursion_tail,
+ "Variable binding depth exceeds max-specpdl-size");
/* Types that type-of returns. */
+ DEFSYM (Qboolean, "boolean");
DEFSYM (Qinteger, "integer");
+ DEFSYM (Qbignum, "bignum");
DEFSYM (Qsymbol, "symbol");
DEFSYM (Qstring, "string");
DEFSYM (Qcons, "cons");
@@ -4263,12 +4221,16 @@ syms_of_data (void)
DEFSYM (Qprocess, "process");
DEFSYM (Qwindow, "window");
DEFSYM (Qsubr, "subr");
+ DEFSYM (Qspecial_form, "special-form");
+ DEFSYM (Qprimitive_function, "primitive-function");
+ DEFSYM (Qsubr_native_elisp, "subr-native-elisp");
DEFSYM (Qcompiled_function, "compiled-function");
DEFSYM (Qbuffer, "buffer");
DEFSYM (Qframe, "frame");
DEFSYM (Qvector, "vector");
DEFSYM (Qrecord, "record");
DEFSYM (Qchar_table, "char-table");
+ DEFSYM (Qsub_char_table, "sub-char-table");
DEFSYM (Qbool_vector, "bool-vector");
DEFSYM (Qhash_table, "hash-table");
DEFSYM (Qthread, "thread");
@@ -4283,6 +4245,7 @@ syms_of_data (void)
DEFSYM (Qtreesit_parser, "treesit-parser");
DEFSYM (Qtreesit_node, "treesit-node");
DEFSYM (Qtreesit_compiled_query, "treesit-compiled-query");
+ DEFSYM (Qobarray, "obarray");
DEFSYM (Qdefun, "defun");
@@ -4298,6 +4261,7 @@ syms_of_data (void)
defsubr (&Seq);
defsubr (&Snull);
defsubr (&Stype_of);
+ defsubr (&Scl_type_of);
defsubr (&Slistp);
defsubr (&Snlistp);
defsubr (&Sconsp);
@@ -4412,8 +4376,6 @@ syms_of_data (void)
defsubr (&Sbool_vector_count_consecutive);
defsubr (&Sbool_vector_count_population);
- set_symbol_function (Qwholenump, XSYMBOL (Qnatnump)->u.s.function);
-
DEFVAR_LISP ("most-positive-fixnum", Vmost_positive_fixnum,
doc: /* The greatest integer that is represented efficiently.
This variable cannot be set; trying to do so will signal an error. */);
@@ -4428,7 +4390,7 @@ This variable cannot be set; trying to do so will signal an error. */);
DEFSYM (Qsymbols_with_pos_enabled, "symbols-with-pos-enabled");
DEFVAR_BOOL ("symbols-with-pos-enabled", symbols_with_pos_enabled,
- doc: /* Non-nil when "symbols with position" can be used as symbols.
+ doc: /* If non-nil, a symbol with position ordinarily behaves as its bare symbol.
Bind this to non-nil in applications such as the byte compiler. */);
symbols_with_pos_enabled = false;
diff --git a/src/dired.c b/src/dired.c
index e7eafc6ea5d..bfbacf70917 100644
--- a/src/dired.c
+++ b/src/dired.c
@@ -44,6 +44,21 @@ along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. */
#include "msdos.h" /* for fstatat */
#endif
+#if !(defined HAVE_ANDROID && !defined ANDROID_STUBIFY)
+typedef DIR emacs_dir;
+#define emacs_readdir readdir
+#define emacs_closedir closedir
+#else
+
+#include "android.h"
+
+/* The Android emulation of dirent stuff is required to be able to
+ list the /assets special directory. */
+typedef struct android_vdir emacs_dir;
+#define emacs_readdir android_readdir
+#define emacs_closedir android_closedir
+#endif
+
#ifdef WINDOWSNT
extern int is_slow_fs (const char *);
#endif
@@ -78,19 +93,42 @@ dirent_type (struct dirent *dp)
#endif
}
-static DIR *
+static emacs_dir *
open_directory (Lisp_Object dirname, Lisp_Object encoded_dirname, int *fdp)
{
char *name = SSDATA (encoded_dirname);
- DIR *d;
+ emacs_dir *d;
int fd, opendir_errno;
-#ifdef DOS_NT
- /* Directories cannot be opened. The emulation assumes that any
- file descriptor other than AT_FDCWD corresponds to the most
- recently opened directory. This hack is good enough for Emacs. */
+#if defined DOS_NT || (defined HAVE_ANDROID && !defined ANDROID_STUBIFY)
+ /* On DOS_NT, directories cannot be opened. The emulation assumes
+ that any file descriptor other than AT_FDCWD corresponds to the
+ most recently opened directory. This hack is good enough for
+ Emacs.
+
+ This code is also used on Android for a different reason: a
+ special `assets' directory outside the normal file system is used
+ to open assets inside the Android application package, and must
+ be listed using the opendir-like interface provided in
+ android.h. */
fd = 0;
+#ifndef HAVE_ANDROID
d = opendir (name);
+#else
+ /* `android_opendir' can return EINTR if DIRNAME designates a file
+ within a slow-to-respond document provider. */
+
+ again:
+ d = android_opendir (name);
+
+ if (d)
+ fd = android_dirfd (d);
+ else if (errno == EINTR)
+ {
+ maybe_quit ();
+ goto again;
+ }
+#endif
opendir_errno = errno;
#else
fd = emacs_open (name, O_RDONLY | O_DIRECTORY, 0);
@@ -125,7 +163,7 @@ directory_files_internal_w32_unwind (Lisp_Object arg)
static void
directory_files_internal_unwind (void *d)
{
- closedir (d);
+ emacs_closedir (d);
}
/* Return the next directory entry from DIR; DIR's name is DIRNAME.
@@ -133,12 +171,12 @@ directory_files_internal_unwind (void *d)
Signal any unrecoverable errors. */
static struct dirent *
-read_dirent (DIR *dir, Lisp_Object dirname)
+read_dirent (emacs_dir *dir, Lisp_Object dirname)
{
while (true)
{
errno = 0;
- struct dirent *dp = readdir (dir);
+ struct dirent *dp = emacs_readdir (dir);
if (dp || errno == 0)
return dp;
if (! (errno == EAGAIN || errno == EINTR))
@@ -190,7 +228,10 @@ directory_files_internal (Lisp_Object directory, Lisp_Object full,
Lisp_Object encoded_dirfilename = ENCODE_FILE (dirfilename);
int fd;
- DIR *d = open_directory (dirfilename, encoded_dirfilename, &fd);
+
+ /* Keep in mind that FD is not always a real file descriptor on
+ Android. */
+ emacs_dir *d = open_directory (dirfilename, encoded_dirfilename, &fd);
/* Unfortunately, we can now invoke expand-file-name and
file-attributes on filenames, both of which can throw, so we must
@@ -300,7 +341,7 @@ directory_files_internal (Lisp_Object directory, Lisp_Object full,
list = Fcons (attrs ? Fcons (finalname, fileattrs) : finalname, list);
}
- closedir (d);
+ emacs_closedir (d);
#ifdef WINDOWSNT
if (attrs)
Vw32_get_true_file_attributes = w32_save;
@@ -310,7 +351,7 @@ directory_files_internal (Lisp_Object directory, Lisp_Object full,
specpdl_ptr = specpdl_ref_to_ptr (count);
if (NILP (nosort))
- list = Fsort (Fnreverse (list),
+ list = CALLN (Fsort, Fnreverse (list),
attrs ? Qfile_attributes_lessp : Qstring_lessp);
(void) directory_volatile;
@@ -514,7 +555,7 @@ file_name_completion (Lisp_Object file, Lisp_Object dirname, bool all_flag,
}
}
int fd;
- DIR *d = open_directory (dirname, encoded_dir, &fd);
+ emacs_dir *d = open_directory (dirname, encoded_dir, &fd);
record_unwind_protect_ptr (directory_files_internal_unwind, d);
/* Loop reading directory entries. */
@@ -855,7 +896,9 @@ file_name_completion_dirp (int fd, struct dirent *dp, ptrdiff_t len)
char *subdir_name = SAFE_ALLOCA (len + 2);
memcpy (subdir_name, dp->d_name, len);
strcpy (subdir_name + len, "/");
- bool dirp = faccessat (fd, subdir_name, F_OK, AT_EACCESS) == 0;
+
+ bool dirp = sys_faccessat (fd, subdir_name,
+ F_OK, AT_EACCESS) == 0;
SAFE_FREE ();
return dirp;
}
@@ -979,14 +1022,15 @@ file_attributes (int fd, char const *name,
int err = EINVAL;
-#if defined O_PATH && !defined HAVE_CYGWIN_O_PATH_BUG
+#if defined O_PATH && !defined HAVE_CYGWIN_O_PATH_BUG \
+ && !(defined HAVE_ANDROID && !defined ANDROID_STUBIFY)
int namefd = emacs_openat (fd, name, O_PATH | O_CLOEXEC | O_NOFOLLOW, 0);
if (namefd < 0)
err = errno;
else
{
record_unwind_protect_int (close_file_unwind, namefd);
- if (fstat (namefd, &s) != 0)
+ if (sys_fstat (namefd, &s) != 0)
{
err = errno;
/* The Linux kernel before version 3.6 does not support
diff --git a/src/dispextern.h b/src/dispextern.h
index de46658dc0a..1c3232fae3d 100644
--- a/src/dispextern.h
+++ b/src/dispextern.h
@@ -53,8 +53,14 @@ typedef struct
unsigned short red, green, blue;
} Emacs_Color;
+#ifndef HAVE_ANDROID
/* Accommodate X's usage of None as a null resource ID. */
#define No_Cursor (NULL)
+#else
+#define No_Cursor 0
+#endif
+
+#ifndef HAVE_ANDROID
/* XRectangle-like struct used by non-X GUI code. */
typedef struct
@@ -63,6 +69,12 @@ typedef struct
unsigned width, height;
} Emacs_Rectangle;
+#else
+
+typedef struct android_rectangle Emacs_Rectangle;
+
+#endif
+
/* XGCValues-like struct used by non-X GUI code. */
typedef struct
{
@@ -144,6 +156,13 @@ typedef Emacs_Pixmap Emacs_Pix_Container;
typedef Emacs_Pixmap Emacs_Pix_Context;
#endif
+#ifdef HAVE_ANDROID
+#include "androidgui.h"
+typedef struct android_display_info Display_Info;
+typedef struct android_image *Emacs_Pix_Container;
+typedef struct android_image *Emacs_Pix_Context;
+#endif
+
#ifdef HAVE_WINDOW_SYSTEM
# include <time.h>
# include "fontset.h"
@@ -157,6 +176,22 @@ typedef void *Emacs_Cursor;
#define NativeRectangle int
#endif
+#ifdef HAVE_WINDOW_SYSTEM
+
+/* ``box'' structure similar to that found in the X sample server,
+ meaning that X2 and Y2 are not actually the end of the box, but one
+ pixel past the end of the box, which makes checking for overlaps
+ less necessary. This is convenient to use in every GUI port. */
+
+struct gui_box
+{
+ /* Bounds of the box. */
+ int x1, y1;
+ int x2, y2;
+};
+
+#endif
+
/* Text cursor types. */
enum text_cursor_kinds
@@ -280,7 +315,7 @@ struct text_pos
/* Set marker MARKER from text position POS. */
#define SET_MARKER_FROM_TEXT_POS(MARKER, POS) \
- set_marker_both ((MARKER), Qnil, CHARPOS ((POS)), BYTEPOS ((POS)))
+ set_marker_both (MARKER, Qnil, CHARPOS (POS), BYTEPOS (POS))
/* Value is non-zero if character and byte positions of POS1 and POS2
are equal. */
@@ -364,7 +399,7 @@ GLYPH_CODE_FACE (Lisp_Object gc)
SET_GLYPH (glyph, XFIXNUM (XCAR (gc)), XFIXNUM (XCDR (gc))); \
else \
SET_GLYPH (glyph, (XFIXNUM (gc) & ((1 << CHARACTERBITS)-1)), \
- (XFIXNUM (gc) >> CHARACTERBITS)); \
+ XFIXNUM (gc) >> CHARACTERBITS); \
} \
while (false)
@@ -641,9 +676,9 @@ struct glyph
defined in lisp.h. */
#define SET_CHAR_GLYPH_FROM_GLYPH(GLYPH, FROM) \
- SET_CHAR_GLYPH ((GLYPH), \
- GLYPH_CHAR ((FROM)), \
- GLYPH_FACE ((FROM)), \
+ SET_CHAR_GLYPH (GLYPH, \
+ GLYPH_CHAR (FROM), \
+ GLYPH_FACE (FROM), \
false)
/* Construct a glyph code from a character glyph GLYPH. If the
@@ -654,9 +689,9 @@ struct glyph
do \
{ \
if ((GLYPH).u.ch < 256) \
- SET_GLYPH ((G), (GLYPH).u.ch, ((GLYPH).face_id)); \
+ SET_GLYPH (G, (GLYPH).u.ch, (GLYPH).face_id); \
else \
- SET_GLYPH ((G), -1, 0); \
+ SET_GLYPH (G, -1, 0); \
} \
while (false)
@@ -802,7 +837,7 @@ struct glyph_matrix
#ifdef GLYPH_DEBUG
void check_matrix_pointer_lossage (struct glyph_matrix *);
-#define CHECK_MATRIX(MATRIX) check_matrix_pointer_lossage ((MATRIX))
+#define CHECK_MATRIX(MATRIX) check_matrix_pointer_lossage (MATRIX)
#else
#define CHECK_MATRIX(MATRIX) ((void) 0)
#endif
@@ -1095,7 +1130,7 @@ struct glyph_row
#ifdef GLYPH_DEBUG
struct glyph_row *matrix_row (struct glyph_matrix *, int);
-#define MATRIX_ROW(MATRIX, ROW) matrix_row ((MATRIX), (ROW))
+#define MATRIX_ROW(MATRIX, ROW) matrix_row (MATRIX, ROW)
#else
#define MATRIX_ROW(MATRIX, ROW) ((MATRIX)->rows + (ROW))
#endif
@@ -1131,12 +1166,12 @@ struct glyph_row *matrix_row (struct glyph_matrix *, int);
MATRIX. */
#define MATRIX_ROW_GLYPH_START(MATRIX, ROW) \
- (MATRIX_ROW ((MATRIX), (ROW))->glyphs[TEXT_AREA])
+ (MATRIX_ROW (MATRIX, ROW)->glyphs[TEXT_AREA])
/* Return the number of used glyphs in the text area of a row. */
#define MATRIX_ROW_USED(MATRIX, ROW) \
- (MATRIX_ROW ((MATRIX), (ROW))->used[TEXT_AREA])
+ (MATRIX_ROW (MATRIX, ROW)->used[TEXT_AREA])
/* Return the character/ byte position at which the display of ROW
starts. BIDI Note: this is the smallest character/byte position
@@ -1166,7 +1201,7 @@ struct glyph_row *matrix_row (struct glyph_matrix *, int);
#define MATRIX_BOTTOM_TEXT_ROW(MATRIX, W) \
((MATRIX)->rows \
+ (MATRIX)->nrows \
- - (window_wants_mode_line ((W)) ? 1 : 0))
+ - (window_wants_mode_line (W) ? 1 : 0))
/* Non-zero if the face of the last glyph in ROW's text area has
to be drawn to the end of the text area. */
@@ -1176,7 +1211,7 @@ struct glyph_row *matrix_row (struct glyph_matrix *, int);
/* Set and query the enabled_p flag of glyph row ROW in MATRIX. */
#define SET_MATRIX_ROW_ENABLED_P(MATRIX, ROW, VALUE) \
- (MATRIX_ROW (MATRIX, ROW)->enabled_p = (VALUE))
+ (MATRIX_ROW (MATRIX, ROW)->enabled_p = VALUE)
#define MATRIX_ROW_ENABLED_P(MATRIX, ROW) \
(MATRIX_ROW (MATRIX, ROW)->enabled_p)
@@ -1197,28 +1232,28 @@ struct glyph_row *matrix_row (struct glyph_matrix *, int);
#define MR_PARTIALLY_VISIBLE_AT_BOTTOM(W, ROW) \
(((ROW)->y + (ROW)->height - (ROW)->extra_line_spacing) \
- > WINDOW_BOX_HEIGHT_NO_MODE_LINE ((W)))
+ > WINDOW_BOX_HEIGHT_NO_MODE_LINE (W))
/* Non-zero if ROW is not completely visible in window W. */
#define MATRIX_ROW_PARTIALLY_VISIBLE_P(W, ROW) \
- (MR_PARTIALLY_VISIBLE ((ROW)) \
- && (MR_PARTIALLY_VISIBLE_AT_TOP ((W), (ROW)) \
- || MR_PARTIALLY_VISIBLE_AT_BOTTOM ((W), (ROW))))
+ (MR_PARTIALLY_VISIBLE (ROW) \
+ && (MR_PARTIALLY_VISIBLE_AT_TOP (W, ROW) \
+ || MR_PARTIALLY_VISIBLE_AT_BOTTOM (W, ROW)))
/* Non-zero if ROW is partially visible at the top of window W. */
#define MATRIX_ROW_PARTIALLY_VISIBLE_AT_TOP_P(W, ROW) \
- (MR_PARTIALLY_VISIBLE ((ROW)) \
- && MR_PARTIALLY_VISIBLE_AT_TOP ((W), (ROW)))
+ (MR_PARTIALLY_VISIBLE (ROW) \
+ && MR_PARTIALLY_VISIBLE_AT_TOP (W, ROW))
/* Non-zero if ROW is partially visible at the bottom of window W. */
#define MATRIX_ROW_PARTIALLY_VISIBLE_AT_BOTTOM_P(W, ROW) \
- (MR_PARTIALLY_VISIBLE ((ROW)) \
- && MR_PARTIALLY_VISIBLE_AT_BOTTOM ((W), (ROW)))
+ (MR_PARTIALLY_VISIBLE (ROW) \
+ && MR_PARTIALLY_VISIBLE_AT_BOTTOM (W, ROW))
/* Return the bottom Y + 1 of ROW. */
@@ -1228,7 +1263,7 @@ struct glyph_row *matrix_row (struct glyph_matrix *, int);
iterator structure pointed to by IT?. */
#define MATRIX_ROW_LAST_VISIBLE_P(ROW, IT) \
- (MATRIX_ROW_BOTTOM_Y ((ROW)) >= (IT)->last_visible_y)
+ (MATRIX_ROW_BOTTOM_Y (ROW) >= (IT)->last_visible_y)
/* Non-zero if ROW displays a continuation line. */
@@ -1401,6 +1436,8 @@ struct glyph_string
/* The GC to use for drawing this glyph string. */
#if defined (HAVE_X_WINDOWS)
GC gc;
+#elif defined HAVE_ANDROID
+ struct android_gc *gc;
#endif
#if defined (HAVE_NTGUI)
Emacs_GC *gc;
@@ -1500,9 +1537,9 @@ struct glyph_string
/* Return the desired face id for the mode line of window W. */
#define CURRENT_MODE_LINE_ACTIVE_FACE_ID(W) \
- (CURRENT_MODE_LINE_ACTIVE_FACE_ID_3((W), \
+ CURRENT_MODE_LINE_ACTIVE_FACE_ID_3(W, \
XWINDOW (selected_window), \
- (W)))
+ W)
/* Return the current height of the mode line of window W. If not known
from W->mode_line_height, look at W's current glyph matrix, or return
@@ -1588,8 +1625,8 @@ struct glyph_string
#define VCENTER_BASELINE_OFFSET(FONT, F) \
(FONT_DESCENT (FONT) \
- + (FRAME_LINE_HEIGHT ((F)) - FONT_HEIGHT ((FONT)) \
- + (FRAME_LINE_HEIGHT ((F)) > FONT_HEIGHT ((FONT)))) / 2 \
+ + (FRAME_LINE_HEIGHT (F) - FONT_HEIGHT (FONT) \
+ + (FRAME_LINE_HEIGHT (F) > FONT_HEIGHT (FONT))) / 2 \
- (FONT_DESCENT (FRAME_FONT (F)) - FRAME_BASELINE_OFFSET (F)))
/* A heuristic test for fonts that claim they need a preposterously
@@ -1681,6 +1718,8 @@ struct face
drawing the characters in this face. */
# ifdef HAVE_X_WINDOWS
GC gc;
+# elif defined HAVE_ANDROID
+ struct android_gc *gc;
# else
Emacs_GC *gc;
# endif
@@ -2713,6 +2752,16 @@ struct it
pixel_width with each call to produce_glyphs. */
int current_x;
+ /* Pixel position within a display line with a wrap prefix. Updated
+ to reflect current_x in produce_glyphs when producing glyphs from
+ a prefix string and continuation_lines_width > 0, which is to
+ say, from a wrap prefix.
+
+ Such updates are unnecessary where it is impossible for a wrap
+ prefix to be active, e.g. when continuation lines are being
+ produced. */
+ int wrap_prefix_width;
+
/* Accumulated width of continuation lines. If > 0, this means we
are currently in a continuation line. This is initially zero and
incremented/reset by display_line, move_it_to etc. */
@@ -2819,12 +2868,12 @@ struct it
if ((IT)->glyph_row != NULL && (IT)->bidi_p) \
(IT)->glyph_row->reversed_p = (IT)->bidi_it.paragraph_dir == R2L; \
if (FRAME_RIF ((IT)->f) != NULL) \
- FRAME_RIF ((IT)->f)->produce_glyphs ((IT)); \
+ FRAME_RIF ((IT)->f)->produce_glyphs (IT); \
else \
- produce_glyphs ((IT)); \
+ produce_glyphs (IT); \
if ((IT)->glyph_row != NULL) \
inhibit_free_realized_faces =true; \
- reset_box_start_end_flags ((IT)); \
+ reset_box_start_end_flags (IT); \
} while (false)
/* Bit-flags indicating what operation move_it_to should perform. */
@@ -3057,8 +3106,9 @@ struct redisplay_interface
#ifdef HAVE_WINDOW_SYSTEM
-# if (defined USE_CAIRO || defined HAVE_XRENDER \
- || defined HAVE_NS || defined HAVE_NTGUI || defined HAVE_HAIKU)
+# if (defined USE_CAIRO || defined HAVE_XRENDER \
+ || defined HAVE_NS || defined HAVE_NTGUI || defined HAVE_HAIKU \
+ || defined HAVE_ANDROID)
# define HAVE_NATIVE_TRANSFORMS
# endif
@@ -3094,6 +3144,13 @@ struct image
int original_width, original_height;
# endif
#endif /* HAVE_X_WINDOWS */
+#ifdef HAVE_ANDROID
+ /* Android images of the image, corresponding to the above Pixmaps.
+ Non-NULL means it and its Pixmap counterpart may be out of sync
+ and the latter is outdated. NULL means the X image has been
+ synchronized to Pixmap. */
+ struct android_image *ximg, *mask_img;
+#endif /* HAVE_ANDROID */
#ifdef HAVE_NTGUI
XFORM xform;
#endif
@@ -3316,9 +3373,13 @@ enum tool_bar_item_idx
/* If we shall show the label only below the icon and not beside it. */
TOOL_BAR_ITEM_VERT_ONLY,
+ /* Whether or not this tool bar item is hidden and should cause
+ subsequent items to be displayed on a new line. */
+ TOOL_BAR_ITEM_WRAP,
+
/* Sentinel = number of slots in tool_bar_items occupied by one
tool-bar item. */
- TOOL_BAR_ITEM_NSLOTS
+ TOOL_BAR_ITEM_NSLOTS,
};
@@ -3377,6 +3438,7 @@ extern void bidi_pop_it (struct bidi_it *);
extern void *bidi_shelve_cache (void);
extern void bidi_unshelve_cache (void *, bool);
extern ptrdiff_t bidi_find_first_overridden (struct bidi_it *);
+extern ptrdiff_t bidi_level_start (int);
/* Defined in xdisp.c */
@@ -3480,6 +3542,7 @@ extern void get_glyph_string_clip_rect (struct glyph_string *,
NativeRectangle *nr);
extern Lisp_Object find_hot_spot (Lisp_Object, int, int);
+extern int get_tab_bar_item_kbd (struct frame *, int, int, int *, bool *);
extern Lisp_Object handle_tab_bar_click (struct frame *,
int, int, bool, int);
extern void handle_tool_bar_click (struct frame *,
@@ -3491,6 +3554,9 @@ extern void expose_frame (struct frame *, int, int, int, int);
extern bool gui_intersect_rectangles (const Emacs_Rectangle *,
const Emacs_Rectangle *,
Emacs_Rectangle *);
+extern void gui_union_rectangles (const Emacs_Rectangle *,
+ const Emacs_Rectangle *,
+ Emacs_Rectangle *);
extern void gui_consider_frame_title (Lisp_Object);
#endif /* HAVE_WINDOW_SYSTEM */
@@ -3499,9 +3565,11 @@ extern void gui_clear_window_mouse_face (struct window *);
extern void cancel_mouse_face (struct frame *);
extern bool clear_mouse_face (Mouse_HLInfo *);
extern bool cursor_in_mouse_face_p (struct window *w);
+#ifndef HAVE_ANDROID
extern void tty_draw_row_with_mouse_face (struct window *, struct glyph_row *,
int, int, enum draw_glyphs_face);
extern void display_tty_menu_item (const char *, int, int, int, int, bool);
+#endif
extern struct glyph *x_y_to_hpos_vpos (struct window *, int, int, int *, int *,
int *, int *, int *);
/* Flags passed to try_window. */
@@ -3561,9 +3629,10 @@ void image_prune_animation_caches (bool);
bool valid_image_p (Lisp_Object);
void prepare_image_for_display (struct frame *, struct image *);
ptrdiff_t lookup_image (struct frame *, Lisp_Object, int);
+Lisp_Object image_spec_value (Lisp_Object, Lisp_Object, bool *);
#if defined HAVE_X_WINDOWS || defined USE_CAIRO || defined HAVE_NS \
- || defined HAVE_HAIKU
+ || defined HAVE_HAIKU || defined HAVE_ANDROID
#define RGB_PIXEL_COLOR unsigned long
#endif
@@ -3644,6 +3713,9 @@ void gamma_correct (struct frame *, COLORREF *);
#ifdef HAVE_HAIKU
void gamma_correct (struct frame *, Emacs_Color *);
#endif
+#ifdef HAVE_ANDROID
+extern void gamma_correct (struct frame *, Emacs_Color *);
+#endif
#ifdef HAVE_WINDOW_SYSTEM
diff --git a/src/dispnew.c b/src/dispnew.c
index 7cf2b49273c..c204a9dbf1b 100644
--- a/src/dispnew.c
+++ b/src/dispnew.c
@@ -43,6 +43,10 @@ along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. */
#include "xwidget.h"
#include "pdumper.h"
+#ifdef HAVE_ANDROID
+#include "android.h"
+#endif
+
#ifdef HAVE_WINDOW_SYSTEM
#include TERM_HEADER
#endif /* HAVE_WINDOW_SYSTEM */
@@ -130,8 +134,8 @@ static struct frame *frame_matrix_frame;
static int window_to_frame_vpos (struct window *, int);
static int window_to_frame_hpos (struct window *, int);
-#define WINDOW_TO_FRAME_VPOS(W, VPOS) window_to_frame_vpos ((W), (VPOS))
-#define WINDOW_TO_FRAME_HPOS(W, HPOS) window_to_frame_hpos ((W), (HPOS))
+#define WINDOW_TO_FRAME_VPOS(W, VPOS) window_to_frame_vpos (W, VPOS)
+#define WINDOW_TO_FRAME_HPOS(W, HPOS) window_to_frame_hpos (W, HPOS)
/* One element of the ring buffer containing redisplay history
information. */
@@ -788,7 +792,7 @@ clear_current_matrices (register struct frame *f)
if (f->current_matrix)
clear_glyph_matrix (f->current_matrix);
-#if defined (HAVE_X_WINDOWS) && ! defined (USE_X_TOOLKIT) && ! defined (USE_GTK)
+#if defined HAVE_WINDOW_SYSTEM && !defined HAVE_EXT_MENU_BAR
/* Clear the matrix of the menu bar window, if such a window exists.
The menu bar window is currently used to display menus on X when
no toolkit support is compiled in. */
@@ -822,7 +826,7 @@ clear_desired_matrices (register struct frame *f)
if (f->desired_matrix)
clear_glyph_matrix (f->desired_matrix);
-#if defined (HAVE_X_WINDOWS) && ! defined (USE_X_TOOLKIT) && ! defined (USE_GTK)
+#if defined HAVE_WINDOW_SYSTEM && !defined HAVE_EXT_MENU_BAR
if (WINDOWP (f->menu_bar_window))
clear_glyph_matrix (XWINDOW (f->menu_bar_window)->desired_matrix);
#endif
@@ -1156,6 +1160,7 @@ prepare_desired_row (struct window *w, struct glyph_row *row, bool mode_line_p)
}
}
+#ifndef HAVE_ANDROID
/* Return a hash code for glyph row ROW, which may
be from current or desired matrix of frame F. */
@@ -1248,6 +1253,7 @@ line_draw_cost (struct frame *f, struct glyph_matrix *matrix, int vpos)
return len;
}
+#endif
/* Return true if the glyph rows A and B have equal contents.
MOUSE_FACE_P means compare the mouse_face_p flags of A and B, too. */
@@ -1385,7 +1391,7 @@ realloc_glyph_pool (struct glyph_pool *pool, struct dim matrix_dim)
|| matrix_dim.width != pool->ncolumns);
/* Enlarge the glyph pool. */
- if (INT_MULTIPLY_WRAPV (matrix_dim.height, matrix_dim.width, &needed))
+ if (ckd_mul (&needed, matrix_dim.height, matrix_dim.width))
memory_full (SIZE_MAX);
if (needed > pool->nglyphs)
{
@@ -2160,7 +2166,7 @@ adjust_frame_glyphs_for_window_redisplay (struct frame *f)
/* Allocate/reallocate window matrices. */
allocate_matrices_for_window_redisplay (XWINDOW (FRAME_ROOT_WINDOW (f)));
-#if defined (HAVE_X_WINDOWS) && ! defined (USE_X_TOOLKIT) && ! defined (USE_GTK)
+#if defined HAVE_WINDOW_SYSTEM && !defined HAVE_EXT_MENU_BAR
/* Allocate/ reallocate matrices of the dummy window used to display
the menu bar under X when no X toolkit support is available. */
{
@@ -2212,10 +2218,16 @@ adjust_frame_glyphs_for_window_redisplay (struct frame *f)
w->pixel_left = 0;
w->left_col = 0;
- w->pixel_top = FRAME_MENU_BAR_HEIGHT (f)
- + (!NILP (Vtab_bar_position) ? FRAME_TOOL_BAR_HEIGHT (f) : 0);
- w->top_line = FRAME_MENU_BAR_LINES (f)
- + (!NILP (Vtab_bar_position) ? FRAME_TOOL_BAR_LINES (f) : 0);
+
+ /* Note that tab and tool bar windows appear above the internal
+ border, as enforced by WINDOW_TOP_EDGE_Y. */
+
+ w->pixel_top = (FRAME_MENU_BAR_HEIGHT (f)
+ + (!NILP (Vtab_bar_position)
+ ? FRAME_TOOL_BAR_TOP_HEIGHT (f) : 0));
+ w->top_line = (FRAME_MENU_BAR_LINES (f)
+ + (!NILP (Vtab_bar_position)
+ ? FRAME_TOOL_BAR_TOP_LINES (f) : 0));
w->total_cols = FRAME_TOTAL_COLS (f);
w->pixel_width = (FRAME_PIXEL_WIDTH (f)
- 2 * FRAME_INTERNAL_BORDER_WIDTH (f));
@@ -2244,10 +2256,29 @@ adjust_frame_glyphs_for_window_redisplay (struct frame *f)
w->pixel_left = 0;
w->left_col = 0;
- w->pixel_top = FRAME_MENU_BAR_HEIGHT (f)
- + (NILP (Vtab_bar_position) ? FRAME_TAB_BAR_HEIGHT (f) : 0);
- w->top_line = FRAME_MENU_BAR_LINES (f)
- + (NILP (Vtab_bar_position) ? FRAME_TAB_BAR_LINES (f) : 0);
+
+ /* If the tool bar should be placed at the bottom of the frame,
+ place it there instead, outside the internal border. */
+
+ if (EQ (FRAME_TOOL_BAR_POSITION (f), Qbottom))
+ {
+ w->pixel_top = (FRAME_PIXEL_HEIGHT (f)
+ - FRAME_TOOL_BAR_HEIGHT (f));
+ w->top_line = (FRAME_LINES (f)
+ - FRAME_TOOL_BAR_LINES (f));
+ }
+ else
+ {
+ /* Otherwise, place the window at the top of the frame. */
+
+ w->pixel_top = (FRAME_MENU_BAR_HEIGHT (f)
+ + (NILP (Vtab_bar_position)
+ ? FRAME_TAB_BAR_HEIGHT (f) : 0));
+ w->top_line = (FRAME_MENU_BAR_LINES (f)
+ + (NILP (Vtab_bar_position)
+ ? FRAME_TAB_BAR_LINES (f) : 0));
+ }
+
w->total_cols = FRAME_TOTAL_COLS (f);
w->pixel_width = (FRAME_PIXEL_WIDTH (f)
- 2 * FRAME_INTERNAL_BORDER_WIDTH (f));
@@ -2296,7 +2327,7 @@ free_glyphs (struct frame *f)
if (!NILP (f->root_window))
free_window_matrices (XWINDOW (f->root_window));
-#if defined (HAVE_X_WINDOWS) && ! defined (USE_X_TOOLKIT) && ! defined (USE_GTK)
+#if defined HAVE_WINDOW_SYSTEM && !defined HAVE_EXT_MENU_BAR
/* Free the dummy window for menu bars without X toolkit and its
glyph matrices. */
if (!NILP (f->menu_bar_window))
@@ -3169,6 +3200,7 @@ redraw_frame (struct frame *f)
its redisplay done. */
mark_window_display_accurate (FRAME_ROOT_WINDOW (f), 0);
set_window_update_flags (XWINDOW (FRAME_ROOT_WINDOW (f)), true);
+
f->garbaged = false;
}
@@ -3188,7 +3220,7 @@ DEFUN ("redraw-display", Fredraw_display, Sredraw_display, 0, 0, "",
Lisp_Object tail, frame;
FOR_EACH_FRAME (tail, frame)
- if (FRAME_VISIBLE_P (XFRAME (frame)))
+ if (FRAME_REDISPLAY_P (XFRAME (frame)))
redraw_frame (XFRAME (frame));
return Qnil;
@@ -3234,7 +3266,7 @@ update_frame (struct frame *f, bool force_p, bool inhibit_hairy_id_p)
when pending input is detected. */
update_begin (f);
-#if defined (HAVE_X_WINDOWS) && ! defined (USE_X_TOOLKIT) && ! defined (USE_GTK)
+#if defined HAVE_WINDOW_SYSTEM && !defined HAVE_EXT_MENU_BAR
/* Update the menu bar on X frames that don't have toolkit
support. */
if (WINDOWP (f->menu_bar_window))
@@ -5071,6 +5103,10 @@ update_frame_1 (struct frame *f, bool force_p, bool inhibit_id_p,
static bool
scrolling (struct frame *frame)
{
+ /* In fact this code should never be reached at all under
+ Android. */
+
+#ifndef HAVE_ANDROID
int unchanged_at_top, unchanged_at_bottom;
int window_size;
int changed_lines;
@@ -5161,6 +5197,7 @@ scrolling (struct frame *frame)
free_at_end_vpos - unchanged_at_top);
SAFE_FREE ();
+#endif
return false;
}
@@ -5202,7 +5239,9 @@ count_match (struct glyph *str1, struct glyph *end1, struct glyph *str2, struct
/* Char insertion/deletion cost vector, from term.c */
-#define char_ins_del_cost(f) (&char_ins_del_vector[FRAME_TOTAL_COLS ((f))])
+#ifndef HAVE_ANDROID
+#define char_ins_del_cost(f) (&char_ins_del_vector[FRAME_TOTAL_COLS (f)])
+#endif
/* Perform a frame-based update on line VPOS in frame FRAME. */
@@ -5407,7 +5446,10 @@ update_frame_line (struct frame *f, int vpos, bool updating_menu_p)
tem = (nlen - nsp) - (olen - osp);
if (endmatch && tem
&& (!FRAME_CHAR_INS_DEL_OK (f)
- || endmatch <= char_ins_del_cost (f)[tem]))
+#ifndef HAVE_ANDROID
+ || endmatch <= char_ins_del_cost (f)[tem]
+#endif
+ ))
endmatch = 0;
/* nsp - osp is the distance to insert or delete.
@@ -5417,7 +5459,10 @@ update_frame_line (struct frame *f, int vpos, bool updating_menu_p)
if (nsp != osp
&& (!FRAME_CHAR_INS_DEL_OK (f)
- || begmatch + endmatch <= char_ins_del_cost (f)[nsp - osp]))
+#ifndef HAVE_ANDROID
+ || begmatch + endmatch <= char_ins_del_cost (f)[nsp - osp]
+#endif
+ ))
{
begmatch = 0;
endmatch = 0;
@@ -5611,6 +5656,15 @@ buffer_posn_from_coords (struct window *w, int *x, int *y, struct display_pos *p
argument is ZV to prevent move_it_in_display_line from matching
based on buffer positions. */
move_it_in_display_line (&it, ZV, to_x, MOVE_TO_X);
+ if (mouse_prefer_closest_glyph)
+ {
+ int next_x = it.current_x + it.pixel_width;
+ int before_dx = to_x - it.current_x;
+ int after_dx = next_x - to_x;
+ if (before_dx > after_dx)
+ move_it_in_display_line (&it, ZV, next_x, MOVE_TO_X);
+ }
+
bidi_unshelve_cache (itdata, 0);
Fset_buffer (old_current_buffer);
@@ -6046,7 +6100,7 @@ FILE = nil means just close any termscript file currently open. */)
if (tty->termscript != 0)
{
block_input ();
- fclose (tty->termscript);
+ emacs_fclose (tty->termscript);
tty->termscript = 0;
unblock_input ();
}
@@ -6152,9 +6206,9 @@ bitch_at_user (void)
DEFUN ("sleep-for", Fsleep_for, Ssleep_for, 1, 2, 0,
doc: /* Pause, without updating display, for SECONDS seconds.
SECONDS may be a floating-point value, meaning that you can wait for a
-fraction of a second. Optional second arg MILLISECONDS specifies an
-additional wait period, in milliseconds; this is for backwards compatibility.
-\(Not all operating systems support waiting for a fraction of a second.) */)
+fraction of a second.
+An optional second arg MILLISECONDS can be provided but is deprecated:
+it specifies an additional wait period, in milliseconds. */)
(Lisp_Object seconds, Lisp_Object milliseconds)
{
double duration = extract_float (seconds);
@@ -6540,6 +6594,15 @@ init_display_interactive (void)
}
#endif /* HAVE_X_WINDOWS */
+#ifdef HAVE_ANDROID
+ if (!inhibit_window_system && android_init_gui)
+ {
+ Vinitial_window_system = Qandroid;
+ android_term_init ();
+ return;
+ }
+#endif
+
#ifdef HAVE_NTGUI
if (!inhibit_window_system)
{
@@ -6594,6 +6657,7 @@ init_display_interactive (void)
exit (1);
}
+#ifndef HAVE_ANDROID
{
struct terminal *t;
struct frame *f = XFRAME (selected_frame);
@@ -6636,6 +6700,11 @@ init_display_interactive (void)
: Qnil));
Fmodify_frame_parameters (selected_frame, tty_arg);
}
+#else
+ fatal ("Could not establish a connection to the Android application.\n"
+ "Emacs does not work on text terminals when built to run as"
+ " part of an Android application package.");
+#endif
{
struct frame *sf = SELECTED_FRAME ();
@@ -6647,8 +6716,8 @@ init_display_interactive (void)
change. It's not clear what better we could do. The rest of
the code assumes that (width + 2) * height * sizeof (struct glyph)
does not overflow and does not exceed PTRDIFF_MAX or SIZE_MAX. */
- if (INT_ADD_WRAPV (width, 2, &area)
- || INT_MULTIPLY_WRAPV (height, area, &area)
+ if (ckd_add (&area, width, 2)
+ || ckd_mul (&area, area, height)
|| min (PTRDIFF_MAX, SIZE_MAX) / sizeof (struct glyph) < area)
fatal ("screen size %dx%d too big", width, height);
}
@@ -6780,6 +6849,7 @@ The value is a symbol:
`pc' for a direct-write MS-DOS frame.
`pgtk' for an Emacs frame using pure GTK facilities.
`haiku' for an Emacs frame running in Haiku.
+ `android' for an Emacs frame running in Android.
Use of this variable as a boolean is deprecated. Instead,
use `display-graphic-p' or any of the other `display-*-p'
@@ -6788,6 +6858,14 @@ predicates which report frame's specific UI-related capabilities. */);
DEFVAR_BOOL ("cursor-in-echo-area", cursor_in_echo_area,
doc: /* Non-nil means put cursor in minibuffer, at end of any message there. */);
+ DEFVAR_BOOL ("mouse-prefer-closest-glyph", mouse_prefer_closest_glyph,
+ doc: /* Non-nil means mouse click position is taken from glyph closest to click.
+
+When non-nil, mouse position lists will report buffer position set to
+the position of the glyph that is the closest to the mouse pointer
+at the time of the click, instead of the glyph immediately under it. */);
+ mouse_prefer_closest_glyph = false;
+
DEFVAR_LISP ("glyph-table", Vglyph_table,
doc: /* Table defining how to output a glyph code to the frame.
If not nil, this is a vector indexed by glyph code to define the glyph.
diff --git a/src/disptab.h b/src/disptab.h
index d63d19ae754..2080181610a 100644
--- a/src/disptab.h
+++ b/src/disptab.h
@@ -39,13 +39,13 @@ along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. */
extern Lisp_Object disp_char_vector (struct Lisp_Char_Table *, int);
#define DISP_CHAR_VECTOR(dp, c) \
- (ASCII_CHAR_P(c) \
+ (ASCII_CHAR_P (c) \
? (NILP ((dp)->ascii) \
? (dp)->defalt \
: (SUB_CHAR_TABLE_P ((dp)->ascii) \
? XSUB_CHAR_TABLE ((dp)->ascii)->contents[c] \
: (dp)->ascii)) \
- : disp_char_vector ((dp), (c)))
+ : disp_char_vector (dp, c))
/* Defined in window.c. */
extern struct Lisp_Char_Table *window_display_table (struct window *);
@@ -78,8 +78,8 @@ extern struct Lisp_Char_Table *buffer_display_table (void);
LENGTH), and set G to the final glyph. */
#define GLYPH_FOLLOW_ALIASES(base, length, g) \
do { \
- while (GLYPH_ALIAS_P ((base), (length), (g))) \
- SET_GLYPH_CHAR ((g), XFIXNUM ((base)[GLYPH_CHAR (g)])); \
+ while (GLYPH_ALIAS_P (base, length, g)) \
+ SET_GLYPH_CHAR (g, XFIXNUM ((base)[GLYPH_CHAR (g)])); \
if (!GLYPH_CHAR_VALID_P (g)) \
SET_GLYPH_CHAR (g, ' '); \
} while (false)
diff --git a/src/doc.c b/src/doc.c
index 6dae67b0c25..b5a9ed498af 100644
--- a/src/doc.c
+++ b/src/doc.c
@@ -37,6 +37,39 @@ along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. */
#include "intervals.h"
#include "keymap.h"
+
+
+#if !defined HAVE_ANDROID || defined ANDROID_STUBIFY \
+ || (__ANDROID_API__ < 9)
+#define doc_fd int
+#define doc_fd_p(fd) ((fd) >= 0)
+#define doc_open emacs_open
+#define doc_read_quit emacs_read_quit
+#define doc_lseek lseek
+#else /* HAVE_ANDROID && !defined ANDROID_STUBIFY
+ && __ANDROID_API__ >= 9 */
+
+#include "android.h"
+
+/* Use an Android file descriptor under Android instead, as this
+ allows loading directly from asset files without loading each asset
+ into memory and creating a separate file descriptor every time.
+
+ However, lread requires the ability to seek inside asset files,
+ which is not provided under Android 2.2. So when building for that
+ particular system, fall back to the usual file descriptor-based
+ code. */
+
+#define doc_fd struct android_fd_or_asset
+#define doc_fd_p(fd) ((fd).asset != (void *) -1)
+#define doc_open android_open_asset
+#define doc_read_quit android_asset_read_quit
+#define doc_lseek android_asset_lseek
+#define USE_ANDROID_ASSETS
+#endif /* !HAVE_ANDROID || ANDROID_STUBIFY || __ANDROID_API__ < 9 */
+
+
+
/* Buffer used for reading from documentation file. */
static char *get_doc_string_buffer;
static ptrdiff_t get_doc_string_buffer_size;
@@ -59,6 +92,22 @@ read_bytecode_char (bool unreadflag)
return *read_bytecode_pointer++;
}
+#ifdef USE_ANDROID_ASSETS
+
+/* Like `close_file_unwind'. However, PTR is a pointer to an Android
+ file descriptor instead of a system file descriptor. */
+
+static void
+close_file_unwind_android_fd (void *ptr)
+{
+ struct android_fd_or_asset *fd;
+
+ fd = ptr;
+ android_close_asset (*fd);
+}
+
+#endif /* USE_ANDROID_ASSETS */
+
/* Extract a doc string from a file. FILEPOS says where to get it.
If it is an integer, use that position in the standard DOC file.
If it is (FILE . INTEGER), use FILE as the file name
@@ -123,8 +172,8 @@ get_doc_string (Lisp_Object filepos, bool unibyte, bool definition)
name = SAFE_ALLOCA (docdir_sizemax + SBYTES (file));
lispstpcpy (lispstpcpy (name, docdir), file);
- int fd = emacs_open (name, O_RDONLY, 0);
- if (fd < 0)
+ doc_fd fd = doc_open (name, O_RDONLY, 0);
+ if (!doc_fd_p (fd))
{
if (will_dump_p ())
{
@@ -132,9 +181,9 @@ get_doc_string (Lisp_Object filepos, bool unibyte, bool definition)
So check in ../etc. */
lispstpcpy (stpcpy (name, sibling_etc), file);
- fd = emacs_open (name, O_RDONLY, 0);
+ fd = doc_open (name, O_RDONLY, 0);
}
- if (fd < 0)
+ if (!doc_fd_p (fd))
{
if (errno != ENOENT && errno != ENOTDIR)
report_file_error ("Read error on documentation file", file);
@@ -145,14 +194,18 @@ get_doc_string (Lisp_Object filepos, bool unibyte, bool definition)
return concat3 (cannot_open, file, quote_nl);
}
}
+#ifndef USE_ANDROID_ASSETS
record_unwind_protect_int (close_file_unwind, fd);
+#else /* USE_ANDROID_ASSETS */
+ record_unwind_protect_ptr (close_file_unwind_android_fd, &fd);
+#endif /* !USE_ANDROID_ASSETS */
/* Seek only to beginning of disk block. */
/* Make sure we read at least 1024 bytes before `position'
so we can check the leading text for consistency. */
int offset = min (position, max (1024, position % (8 * 1024)));
if (TYPE_MAXIMUM (off_t) < position
- || lseek (fd, position - offset, 0) < 0)
+ || doc_lseek (fd, position - offset, 0) < 0)
error ("Position %"pI"d out of range in doc string file \"%s\"",
position, name);
@@ -181,7 +234,7 @@ get_doc_string (Lisp_Object filepos, bool unibyte, bool definition)
If we read the same block last time, maybe skip this? */
if (space_left > 1024 * 8)
space_left = 1024 * 8;
- int nread = emacs_read_quit (fd, p, space_left);
+ int nread = doc_read_quit (fd, p, space_left);
if (nread < 0)
report_file_error ("Read error on documentation file", file);
p[nread] = 0;
@@ -304,6 +357,20 @@ reread_doc_file (Lisp_Object file)
return 1;
}
+DEFUN ("documentation-stringp", Fdocumentation_stringp, Sdocumentation_stringp,
+ 1, 1, 0,
+ doc: /* Return non-nil if OBJECT is a well-formed docstring object.
+OBJECT can be either a string or a reference if it's kept externally. */)
+ (Lisp_Object object)
+{
+ return (STRINGP (object)
+ || FIXNUMP (object) /* Reference to DOC. */
+ || (CONSP (object) /* Reference to .elc. */
+ && STRINGP (XCAR (object))
+ && FIXNUMP (XCDR (object)))
+ ? Qt : Qnil);
+}
+
DEFUN ("documentation", Fdocumentation, Sdocumentation, 1, 2, 0,
doc: /* Return the documentation string of FUNCTION.
Unless a non-nil second argument RAW is given, the
@@ -330,19 +397,7 @@ string is passed through `substitute-command-keys'. */)
xsignal1 (Qvoid_function, function);
if (CONSP (fun) && EQ (XCAR (fun), Qmacro))
fun = XCDR (fun);
-#ifdef HAVE_NATIVE_COMP
- if (!NILP (Fsubr_native_elisp_p (fun)))
- doc = native_function_doc (fun);
- else
-#endif
- if (SUBRP (fun))
- doc = make_fixnum (XSUBR (fun)->doc);
-#ifdef HAVE_MODULES
- else if (MODULE_FUNCTIONP (fun))
- doc = module_function_documentation (XMODULE_FUNCTION (fun));
-#endif
- else
- doc = call1 (Qfunction_documentation, fun);
+ doc = call1 (Qfunction_documentation, fun);
/* If DOC is 0, it's typically because of a dumped file missing
from the DOC file (bug in src/Makefile.in). */
@@ -371,6 +426,25 @@ string is passed through `substitute-command-keys'. */)
return doc;
}
+DEFUN ("internal-subr-documentation", Fsubr_documentation, Ssubr_documentation, 1, 1, 0,
+ doc: /* Return the raw documentation info of a C primitive. */)
+ (Lisp_Object function)
+{
+#ifdef HAVE_NATIVE_COMP
+ if (!NILP (Fsubr_native_elisp_p (function)))
+ return native_function_doc (function);
+ else
+#endif
+ if (SUBRP (function))
+ return make_fixnum (XSUBR (function)->doc);
+#ifdef HAVE_MODULES
+ else if (MODULE_FUNCTIONP (function))
+ return module_function_documentation (XMODULE_FUNCTION (function));
+#endif
+ else
+ return Qt;
+}
+
DEFUN ("documentation-property", Fdocumentation_property,
Sdocumentation_property, 2, 3, 0,
doc: /* Return the documentation string that is SYMBOL's PROP property.
@@ -442,46 +516,13 @@ store_function_docstring (Lisp_Object obj, EMACS_INT offset)
/* If it's a lisp form, stick it in the form. */
if (CONSP (fun) && EQ (XCAR (fun), Qmacro))
fun = XCDR (fun);
- if (CONSP (fun))
- {
- Lisp_Object tem = XCAR (fun);
- if (EQ (tem, Qlambda) || EQ (tem, Qautoload)
- || (EQ (tem, Qclosure) && (fun = XCDR (fun), 1)))
- {
- tem = Fcdr (Fcdr (fun));
- if (CONSP (tem) && FIXNUMP (XCAR (tem)))
- /* FIXME: This modifies typically pure hash-cons'd data, so its
- correctness is quite delicate. */
- XSETCAR (tem, make_fixnum (offset));
- }
- }
/* Lisp_Subrs have a slot for it. */
- else if (SUBRP (fun) && !SUBR_NATIVE_COMPILEDP (fun))
- {
- XSUBR (fun)->doc = offset;
- }
-
- /* Bytecode objects sometimes have slots for it. */
- else if (COMPILEDP (fun))
+ if (SUBRP (fun) && !SUBR_NATIVE_COMPILEDP (fun))
+ XSUBR (fun)->doc = offset;
+ else
{
- /* This bytecode object must have a slot for the
- docstring, since we've found a docstring for it. */
- 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,
- (PVSIZE (fun) > COMPILED_DOC_STRING
- ? "Docstring slot busy for %s"
- : "No docstring slot for %s"));
- CALLN (Fmessage, format,
- (SYMBOLP (obj)
- ? SYMBOL_NAME (obj)
- : build_string ("<anonymous>")));
- }
+ AUTO_STRING (format, "Ignoring DOC string on non-subr: %S");
+ CALLN (Fmessage, format, obj);
}
}
@@ -497,7 +538,7 @@ That file is found in `../etc' now; later, when the dumped Emacs is run,
the same file name is found in the `doc-directory'. */)
(Lisp_Object filename)
{
- int fd;
+ doc_fd fd;
char buf[1024 + 1];
int filled;
EMACS_INT pos;
@@ -544,21 +585,25 @@ the same file name is found in the `doc-directory'. */)
Vbuild_files = Fpurecopy (Vbuild_files);
}
- fd = emacs_open (name, O_RDONLY, 0);
- if (fd < 0)
+ fd = doc_open (name, O_RDONLY, 0);
+ if (!doc_fd_p (fd))
{
int open_errno = errno;
report_file_errno ("Opening doc string file", build_string (name),
open_errno);
}
+#ifndef USE_ANDROID_ASSETS
record_unwind_protect_int (close_file_unwind, fd);
+#else /* USE_ANDROID_ASSETS */
+ record_unwind_protect_ptr (close_file_unwind_android_fd, &fd);
+#endif /* !USE_ANDROID_ASSETS */
Vdoc_file_name = filename;
filled = 0;
pos = 0;
while (true)
{
if (filled < 512)
- filled += emacs_read_quit (fd, &buf[filled], sizeof buf - 1 - filled);
+ filled += doc_read_quit (fd, &buf[filled], sizeof buf - 1 - filled);
if (!filled)
break;
@@ -712,7 +757,9 @@ compute the correct value for the current terminal in the nil case. */);
doc: /* If nil, a nil `text-quoting-style' is treated as `grave'. */);
/* Initialized by ‘main’. */
+ defsubr (&Sdocumentation_stringp);
defsubr (&Sdocumentation);
+ defsubr (&Ssubr_documentation);
defsubr (&Sdocumentation_property);
defsubr (&Ssnarf_documentation);
defsubr (&Stext_quoting_style);
diff --git a/src/doprnt.c b/src/doprnt.c
index ddf3ba39177..d764f25c6f7 100644
--- a/src/doprnt.c
+++ b/src/doprnt.c
@@ -134,8 +134,8 @@ parse_format_integer (char const *fmt, int *value)
bool overflow = false;
for (; '0' <= *fmt && *fmt <= '9'; fmt++)
{
- overflow |= INT_MULTIPLY_WRAPV (n, 10, &n);
- overflow |= INT_ADD_WRAPV (n, *fmt - '0', &n);
+ overflow |= ckd_mul (&n, n, 10);
+ overflow |= ckd_add (&n, n, *fmt - '0');
}
if (overflow || min (PTRDIFF_MAX, SIZE_MAX) - SIZE_BOUND_EXTRA < n)
error ("Format width or precision too large");
diff --git a/src/dosfns.c b/src/dosfns.c
index 3eb3b34145e..96087116c19 100644
--- a/src/dosfns.c
+++ b/src/dosfns.c
@@ -652,10 +652,7 @@ dos_memory_info (unsigned long *totalram, unsigned long *freeram,
mem2 *= 4096;
/* Surely, the available memory is at least what we have physically
available, right? */
- if (mem1 >= mem2)
- freemem = mem1;
- else
- freemem = mem2;
+ freemem = max (mem1, mem2);
*freeram = freemem;
*totalswap =
((long)info.max_pages_in_paging_file == -1L)
diff --git a/src/editfns.c b/src/editfns.c
index 85f7739df07..4ccf765bd4b 100644
--- a/src/editfns.c
+++ b/src/editfns.c
@@ -33,6 +33,10 @@ along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. */
#include <sys/utsname.h>
#endif
+#ifdef HAVE_ANDROID
+#include "android.h"
+#endif
+
#include "lisp.h"
#include <float.h>
@@ -268,24 +272,6 @@ If you set the marker not to point anywhere, the buffer will have no mark. */)
}
-/* Find all the overlays in the current buffer that touch position POS.
- Return the number found, and store them in a vector in VEC
- of length LEN.
-
- Note: this can return overlays that do not touch POS. The caller
- should filter these out. */
-
-static ptrdiff_t
-overlays_around (ptrdiff_t pos, Lisp_Object *vec, ptrdiff_t len)
-{
- /* Find all potentially rear-advance overlays at (POS - 1). Find
- all overlays at POS, so end at (POS + 1). Find even empty
- overlays, which due to the way 'overlays-in' works implies that
- we might also fetch empty overlays starting at (POS + 1). */
- return overlays_in (pos - 1, pos + 1, false, &vec, &len,
- true, false, NULL);
-}
-
DEFUN ("get-pos-property", Fget_pos_property, Sget_pos_property, 2, 3, 0,
doc: /* Return the value of POSITION's property PROP, in OBJECT.
Almost identical to `get-char-property' except for the following difference:
@@ -311,53 +297,44 @@ at POSITION. */)
else
{
EMACS_INT posn = XFIXNUM (position);
- ptrdiff_t noverlays;
- Lisp_Object *overlay_vec, tem;
+ Lisp_Object tem;
struct buffer *obuf = current_buffer;
- USE_SAFE_ALLOCA;
+ struct itree_node *node;
+ struct sortvec items[2];
+ struct buffer *b = XBUFFER (object);
+ struct sortvec *result = NULL;
+ Lisp_Object res = Qnil;
- set_buffer_temp (XBUFFER (object));
+ set_buffer_temp (b);
- /* First try with room for 40 overlays. */
- Lisp_Object overlay_vecbuf[40];
- noverlays = ARRAYELTS (overlay_vecbuf);
- overlay_vec = overlay_vecbuf;
- noverlays = overlays_around (posn, overlay_vec, noverlays);
-
- /* If there are more than 40,
- make enough space for all, and try again. */
- if (ARRAYELTS (overlay_vecbuf) < noverlays)
+ ITREE_FOREACH (node, b->overlays, posn - 1, posn + 1, ASCENDING)
{
- SAFE_ALLOCA_LISP (overlay_vec, noverlays);
- noverlays = overlays_around (posn, overlay_vec, noverlays);
- }
- noverlays = sort_overlays (overlay_vec, noverlays, NULL);
-
- set_buffer_temp (obuf);
-
- /* Now check the overlays in order of decreasing priority. */
- while (--noverlays >= 0)
- {
- Lisp_Object ol = overlay_vec[noverlays];
+ Lisp_Object ol = node->data;
tem = Foverlay_get (ol, prop);
- if (!NILP (tem))
- {
+ if (NILP (tem)
/* Check the overlay is indeed active at point. */
- if ((OVERLAY_START (ol) == posn
+ || ((node->begin == posn
&& OVERLAY_FRONT_ADVANCE_P (ol))
- || (OVERLAY_END (ol) == posn
+ || (node->end == posn
&& ! OVERLAY_REAR_ADVANCE_P (ol))
- || OVERLAY_START (ol) > posn
- || OVERLAY_END (ol) < posn)
- ; /* The overlay will not cover a char inserted at point. */
- else
- {
- SAFE_FREE ();
- return tem;
- }
- }
+ || node->begin > posn
+ || node->end < posn))
+ /* The overlay will not cover a char inserted at point. */
+ continue;
+
+ struct sortvec *this = (result == items ? items + 1 : items);
+ if (NILP (res)
+ || (make_sortvec_item (this, node->data),
+ compare_overlays (result, this) < 0))
+ {
+ result = this;
+ res = tem;
+ }
}
- SAFE_FREE ();
+ set_buffer_temp (obuf);
+
+ if (!NILP (res))
+ return res;
{ /* Now check the text properties. */
int stickiness = text_property_stickiness (prop, position, object);
@@ -1270,7 +1247,11 @@ is in general a comma-separated list. */)
if (!pw)
return Qnil;
+#if defined HAVE_ANDROID && !defined ANDROID_STUBIFY
+ p = android_user_full_name (pw);
+#else
p = USER_FULL_NAME;
+#endif
/* Chop off everything after the first comma, since 'pw_gecos' is a
comma-separated list. */
q = strchr (p, ',');
@@ -1777,7 +1758,7 @@ determines whether case is significant or ignored. */)
register EMACS_INT begp1, endp1, begp2, endp2, temp;
register struct buffer *bp1, *bp2;
register Lisp_Object trt
- = (!NILP (BVAR (current_buffer, case_fold_search))
+ = (!NILP (Vcase_fold_search)
? BVAR (current_buffer, case_canon_table) : Qnil);
ptrdiff_t chars = 0;
ptrdiff_t i1, i2, i1_byte, i2_byte;
@@ -1900,7 +1881,7 @@ determines whether case is significant or ignored. */)
#define USE_HEURISTIC
#define XVECREF_YVECREF_EQUAL(ctx, xoff, yoff) \
- buffer_chars_equal ((ctx), (xoff), (yoff))
+ buffer_chars_equal (ctx, xoff, yoff)
#define OFFSET ptrdiff_t
@@ -2033,8 +2014,8 @@ nil. */)
ptrdiff_t ins_bytes = size_b / CHAR_BIT + 1;
ptrdiff_t *buffer;
ptrdiff_t bytes_needed;
- if (INT_MULTIPLY_WRAPV (diags, 2 * sizeof *buffer, &bytes_needed)
- || INT_ADD_WRAPV (del_bytes + ins_bytes, bytes_needed, &bytes_needed))
+ if (ckd_mul (&bytes_needed, diags, 2 * sizeof *buffer)
+ || ckd_add (&bytes_needed, bytes_needed, del_bytes + ins_bytes))
memory_full (SIZE_MAX);
USE_SAFE_ALLOCA;
buffer = SAFE_ALLOCA (bytes_needed);
@@ -2773,7 +2754,7 @@ labeled_restrictions_pop (Lisp_Object buf)
Lisp_Object restrictions = assq_no_quit (buf, labeled_restrictions);
if (NILP (restrictions))
return;
- if (EQ (labeled_restrictions_peek_label (buf), Qoutermost_restriction))
+ if (BASE_EQ (labeled_restrictions_peek_label (buf), Qoutermost_restriction))
labeled_restrictions_remove (buf);
else
XSETCDR (restrictions, list1 (XCDR (XCAR (XCDR (restrictions)))));
@@ -2913,7 +2894,7 @@ To gain access to other portions of the buffer, use
current_buffer are the bounds that were set by the user, no
labeled restriction is in effect in current_buffer anymore:
remove it from the labeled_restrictions alist. */
- if (EQ (label, Qoutermost_restriction))
+ if (BASE_EQ (label, Qoutermost_restriction))
labeled_restrictions_pop (buf);
}
/* Changing the buffer bounds invalidates any recorded current column. */
@@ -3309,7 +3290,7 @@ str2num (char *str, char **str_end)
{
ptrdiff_t n = 0;
for (; c_isdigit (*str); str++)
- if (INT_MULTIPLY_WRAPV (n, 10, &n) || INT_ADD_WRAPV (n, *str - '0', &n))
+ if (ckd_mul (&n, n, 10) || ckd_add (&n, n, *str - '0'))
n = PTRDIFF_MAX;
*str_end = str;
return n;
@@ -3477,8 +3458,8 @@ styled_format (ptrdiff_t nargs, Lisp_Object *args, bool message)
/* Allocate the info and discarded tables. */
ptrdiff_t info_size, alloca_size;
- if (INT_MULTIPLY_WRAPV (nspec_bound, sizeof *info, &info_size)
- || INT_ADD_WRAPV (formatlen, info_size, &alloca_size)
+ if (ckd_mul (&info_size, nspec_bound, sizeof *info)
+ || ckd_add (&alloca_size, formatlen, info_size)
|| SIZE_MAX < alloca_size)
memory_full (SIZE_MAX);
info = SAFE_ALLOCA (alloca_size);
@@ -4025,8 +4006,8 @@ styled_format (ptrdiff_t nargs, Lisp_Object *args, bool message)
/* Compute the total bytes needed for this item, including
excess precision and padding. */
ptrdiff_t numwidth;
- if (INT_ADD_WRAPV (prefixlen + sprintf_bytes, excess_precision,
- &numwidth))
+ if (ckd_add (&numwidth, prefixlen + sprintf_bytes,
+ excess_precision))
numwidth = PTRDIFF_MAX;
ptrdiff_t padding
= numwidth < field_width ? field_width - numwidth : 0;
@@ -4186,7 +4167,7 @@ styled_format (ptrdiff_t nargs, Lisp_Object *args, bool message)
ptrdiff_t used = p - buf;
ptrdiff_t buflen_needed;
- if (INT_ADD_WRAPV (used, convbytes, &buflen_needed))
+ if (ckd_add (&buflen_needed, used, convbytes))
string_overflow ();
if (bufsize <= buflen_needed)
{
@@ -4359,7 +4340,7 @@ Case is ignored if `case-fold-search' is non-nil in the current buffer. */)
if (XFIXNUM (c1) == XFIXNUM (c2))
return Qt;
- if (NILP (BVAR (current_buffer, case_fold_search)))
+ if (NILP (Vcase_fold_search))
return Qnil;
i1 = XFIXNAT (c1);
diff --git a/src/emacs-module.c b/src/emacs-module.c
index 9625c4be9ed..08db39b0b0d 100644
--- a/src/emacs-module.c
+++ b/src/emacs-module.c
@@ -206,7 +206,7 @@ static void module_non_local_exit_signal_1 (emacs_env *,
static void module_non_local_exit_throw_1 (emacs_env *,
Lisp_Object, Lisp_Object);
static void module_out_of_memory (emacs_env *);
-static void module_reset_handlerlist (struct handler **);
+static void module_reset_handlerlist (struct handler *);
static bool value_storage_contains_p (const struct emacs_value_storage *,
emacs_value, ptrdiff_t *);
@@ -246,10 +246,6 @@ module_decode_utf_8 (const char *str, ptrdiff_t len)
of `internal_condition_case' etc., and to avoid worrying about
passing information to the handler functions. */
-#if !HAS_ATTRIBUTE (cleanup)
- #error "__attribute__ ((cleanup)) not supported by this compiler; try GCC"
-#endif
-
/* Place this macro at the beginning of a function returning a number
or a pointer to handle non-local exits. The function must have an
ENV parameter. The function will return the specified value if a
@@ -257,8 +253,8 @@ module_decode_utf_8 (const char *str, ptrdiff_t len)
/* It is very important that pushing the handler doesn't itself raise
a signal. Install the cleanup only after the handler has been
- pushed. Use __attribute__ ((cleanup)) to avoid
- non-local-exit-prone manual cleanup.
+ pushed. All code following this point should use
+ MODULE_INTERNAL_CLEANUP before each return.
The do-while forces uses of the macro to be followed by a semicolon.
This macro cannot enclose its entire body inside a do-while, as the
@@ -278,17 +274,20 @@ module_decode_utf_8 (const char *str, ptrdiff_t len)
return retval; \
} \
struct handler *internal_cleanup \
- __attribute__ ((cleanup (module_reset_handlerlist))) \
= internal_handler; \
if (sys_setjmp (internal_cleanup->jmp)) \
{ \
module_handle_nonlocal_exit (env, \
internal_cleanup->nonlocal_exit, \
internal_cleanup->val); \
+ module_reset_handlerlist (internal_cleanup); \
return retval; \
} \
do { } while (false)
+#define MODULE_INTERNAL_CLEANUP() \
+ module_reset_handlerlist (internal_cleanup)
+
/* Implementation of runtime and environment functions.
@@ -315,7 +314,10 @@ module_decode_utf_8 (const char *str, ptrdiff_t len)
Emacs functions, by placing the macro
MODULE_HANDLE_NONLOCAL_EXIT right after the above 2 tests.
- 5. Do NOT use 'eassert' for checking validity of user code in the
+ 5. Finally, any code which expands MODULE_HANDLE_NONLOCAL_EXIT
+ should use MODULE_INTERNAL_CLEANUP prior to returning.
+
+ 6. Do NOT use 'eassert' for checking validity of user code in the
module. Instead, make those checks part of the code, and if the
check fails, call 'module_non_local_exit_signal_1' or
'module_non_local_exit_throw_1' to report the error. This is
@@ -408,15 +410,12 @@ module_global_reference_p (emacs_value v, ptrdiff_t *n)
struct Lisp_Hash_Table *h = XHASH_TABLE (Vmodule_refs_hash);
/* Note that we can't use `hash_lookup' because V might be a local
reference that's identical to some global reference. */
- for (ptrdiff_t i = 0; i < HASH_TABLE_SIZE (h); ++i)
- {
- if (!BASE_EQ (HASH_KEY (h, i), Qunbound)
- && &XMODULE_GLOBAL_REFERENCE (HASH_VALUE (h, i))->value == v)
- return true;
- }
+ DOHASH (h, k, val)
+ if (&XMODULE_GLOBAL_REFERENCE (val)->value == v)
+ return true;
/* Only used for debugging, so we don't care about overflow, just
make sure the operation is defined. */
- INT_ADD_WRAPV (*n, h->count, n);
+ ckd_add (n, *n, h->count);
return false;
}
@@ -425,8 +424,9 @@ module_make_global_ref (emacs_env *env, emacs_value value)
{
MODULE_FUNCTION_BEGIN (NULL);
struct Lisp_Hash_Table *h = XHASH_TABLE (Vmodule_refs_hash);
- Lisp_Object new_obj = value_to_lisp (value), hashcode;
- ptrdiff_t i = hash_lookup (h, new_obj, &hashcode);
+ Lisp_Object new_obj = value_to_lisp (value);
+ hash_hash_t hashcode;
+ ptrdiff_t i = hash_lookup_get_hash (h, new_obj, &hashcode);
/* Note: This approach requires the garbage collector to never move
objects. */
@@ -435,9 +435,10 @@ module_make_global_ref (emacs_env *env, emacs_value value)
{
Lisp_Object value = HASH_VALUE (h, i);
struct module_global_reference *ref = XMODULE_GLOBAL_REFERENCE (value);
- bool overflow = INT_ADD_WRAPV (ref->refcount, 1, &ref->refcount);
+ bool overflow = ckd_add (&ref->refcount, ref->refcount, 1);
if (overflow)
overflow_error ();
+ MODULE_INTERNAL_CLEANUP ();
return &ref->value;
}
else
@@ -450,6 +451,7 @@ module_make_global_ref (emacs_env *env, emacs_value value)
Lisp_Object value;
XSETPSEUDOVECTOR (value, ref, PVEC_OTHER);
hash_put (h, new_obj, value, hashcode);
+ MODULE_INTERNAL_CLEANUP ();
return &ref->value;
}
}
@@ -463,7 +465,7 @@ module_free_global_ref (emacs_env *env, emacs_value global_value)
MODULE_FUNCTION_BEGIN ();
struct Lisp_Hash_Table *h = XHASH_TABLE (Vmodule_refs_hash);
Lisp_Object obj = value_to_lisp (global_value);
- ptrdiff_t i = hash_lookup (h, obj, NULL);
+ ptrdiff_t i = hash_lookup (h, obj);
if (module_assertions)
{
@@ -481,6 +483,8 @@ module_free_global_ref (emacs_env *env, emacs_value global_value)
if (--ref->refcount == 0)
hash_remove_from_table (h, obj);
}
+
+ MODULE_INTERNAL_CLEANUP ();
}
static enum emacs_funcall_exit
@@ -574,6 +578,8 @@ static emacs_value
module_make_function (emacs_env *env, ptrdiff_t min_arity, ptrdiff_t max_arity,
emacs_function func, const char *docstring, void *data)
{
+ emacs_value value;
+
MODULE_FUNCTION_BEGIN (NULL);
if (! (0 <= min_arity
@@ -598,7 +604,9 @@ module_make_function (emacs_env *env, ptrdiff_t min_arity, ptrdiff_t max_arity,
XSET_MODULE_FUNCTION (result, function);
eassert (MODULE_FUNCTIONP (result));
- return lisp_to_value (env, result);
+ value = lisp_to_value (env, result);
+ MODULE_INTERNAL_CLEANUP ();
+ return value;
}
static emacs_finalizer
@@ -607,6 +615,7 @@ module_get_function_finalizer (emacs_env *env, emacs_value arg)
MODULE_FUNCTION_BEGIN (NULL);
Lisp_Object lisp = value_to_lisp (arg);
CHECK_MODULE_FUNCTION (lisp);
+ MODULE_INTERNAL_CLEANUP ();
return XMODULE_FUNCTION (lisp)->finalizer;
}
@@ -618,6 +627,7 @@ module_set_function_finalizer (emacs_env *env, emacs_value arg,
Lisp_Object lisp = value_to_lisp (arg);
CHECK_MODULE_FUNCTION (lisp);
XMODULE_FUNCTION (lisp)->finalizer = fin;
+ MODULE_INTERNAL_CLEANUP ();
}
void
@@ -637,6 +647,7 @@ module_make_interactive (emacs_env *env, emacs_value function, emacs_value spec)
/* Normalize (interactive nil) to (interactive). */
XMODULE_FUNCTION (lisp_fun)->interactive_form
= NILP (lisp_spec) ? list1 (Qinteractive) : list2 (Qinteractive, lisp_spec);
+ MODULE_INTERNAL_CLEANUP ();
}
Lisp_Object
@@ -662,7 +673,7 @@ module_funcall (emacs_env *env, emacs_value func, ptrdiff_t nargs,
Lisp_Object *newargs;
USE_SAFE_ALLOCA;
ptrdiff_t nargs1;
- if (INT_ADD_WRAPV (nargs, 1, &nargs1))
+ if (ckd_add (&nargs1, nargs, 1))
overflow_error ();
SAFE_ALLOCA_LISP (newargs, nargs1);
newargs[0] = value_to_lisp (func);
@@ -670,21 +681,30 @@ module_funcall (emacs_env *env, emacs_value func, ptrdiff_t nargs,
newargs[1 + i] = value_to_lisp (args[i]);
emacs_value result = lisp_to_value (env, Ffuncall (nargs1, newargs));
SAFE_FREE ();
+ MODULE_INTERNAL_CLEANUP ();
return result;
}
static emacs_value
module_intern (emacs_env *env, const char *name)
{
+ emacs_value tem;
+
MODULE_FUNCTION_BEGIN (NULL);
- return lisp_to_value (env, intern (name));
+ tem = lisp_to_value (env, intern (name));
+ MODULE_INTERNAL_CLEANUP ();
+ return tem;
}
static emacs_value
module_type_of (emacs_env *env, emacs_value arg)
{
+ emacs_value tem;
+
MODULE_FUNCTION_BEGIN (NULL);
- return lisp_to_value (env, Ftype_of (value_to_lisp (arg)));
+ tem = lisp_to_value (env, Ftype_of (value_to_lisp (arg)));
+ MODULE_INTERNAL_CLEANUP ();
+ return tem;
}
static bool
@@ -710,14 +730,20 @@ module_extract_integer (emacs_env *env, emacs_value arg)
intmax_t i;
if (! integer_to_intmax (lisp, &i))
xsignal1 (Qoverflow_error, lisp);
+ MODULE_INTERNAL_CLEANUP ();
return i;
}
static emacs_value
module_make_integer (emacs_env *env, intmax_t n)
{
+ emacs_value value;
+
MODULE_FUNCTION_BEGIN (NULL);
- return lisp_to_value (env, make_int (n));
+ value = lisp_to_value (env, make_int (n));
+ MODULE_INTERNAL_CLEANUP ();
+
+ return value;
}
static double
@@ -726,14 +752,21 @@ module_extract_float (emacs_env *env, emacs_value arg)
MODULE_FUNCTION_BEGIN (0);
Lisp_Object lisp = value_to_lisp (arg);
CHECK_TYPE (FLOATP (lisp), Qfloatp, lisp);
+ MODULE_INTERNAL_CLEANUP ();
+
return XFLOAT_DATA (lisp);
}
static emacs_value
module_make_float (emacs_env *env, double d)
{
+ emacs_value value;
+
MODULE_FUNCTION_BEGIN (NULL);
- return lisp_to_value (env, make_float (d));
+ value = lisp_to_value (env, make_float (d));
+ MODULE_INTERNAL_CLEANUP ();
+
+ return value;
}
static bool
@@ -765,6 +798,7 @@ module_copy_string_contents (emacs_env *env, emacs_value value, char *buf,
if (buf == NULL)
{
*len = required_buf_size;
+ MODULE_INTERNAL_CLEANUP ();
return true;
}
@@ -780,36 +814,51 @@ module_copy_string_contents (emacs_env *env, emacs_value value, char *buf,
*len = required_buf_size;
memcpy (buf, SDATA (lisp_str_utf8), raw_size + 1);
+ MODULE_INTERNAL_CLEANUP ();
return true;
}
static emacs_value
module_make_string (emacs_env *env, const char *str, ptrdiff_t len)
{
+ emacs_value value;
+
MODULE_FUNCTION_BEGIN (NULL);
if (! (0 <= len && len <= STRING_BYTES_BOUND))
overflow_error ();
Lisp_Object lstr
= len == 0 ? empty_multibyte_string : module_decode_utf_8 (str, len);
- return lisp_to_value (env, lstr);
+ value = lisp_to_value (env, lstr);
+ MODULE_INTERNAL_CLEANUP ();
+ return value;
}
static emacs_value
module_make_unibyte_string (emacs_env *env, const char *str, ptrdiff_t length)
{
+ emacs_value value;
+
MODULE_FUNCTION_BEGIN (NULL);
if (! (0 <= length && length <= STRING_BYTES_BOUND))
overflow_error ();
Lisp_Object lstr
= length == 0 ? empty_unibyte_string : make_unibyte_string (str, length);
- return lisp_to_value (env, lstr);
+ value = lisp_to_value (env, lstr);
+ MODULE_INTERNAL_CLEANUP ();
+
+ return value;
}
static emacs_value
module_make_user_ptr (emacs_env *env, emacs_finalizer fin, void *ptr)
{
+ emacs_value value;
+
MODULE_FUNCTION_BEGIN (NULL);
- return lisp_to_value (env, make_user_ptr (fin, ptr));
+ value = lisp_to_value (env, make_user_ptr (fin, ptr));
+ MODULE_INTERNAL_CLEANUP ();
+
+ return value;
}
static void *
@@ -818,6 +867,8 @@ module_get_user_ptr (emacs_env *env, emacs_value arg)
MODULE_FUNCTION_BEGIN (NULL);
Lisp_Object lisp = value_to_lisp (arg);
CHECK_USER_PTR (lisp);
+ MODULE_INTERNAL_CLEANUP ();
+
return XUSER_PTR (lisp)->p;
}
@@ -828,6 +879,7 @@ module_set_user_ptr (emacs_env *env, emacs_value arg, void *ptr)
Lisp_Object lisp = value_to_lisp (arg);
CHECK_USER_PTR (lisp);
XUSER_PTR (lisp)->p = ptr;
+ MODULE_INTERNAL_CLEANUP ();
}
static emacs_finalizer
@@ -836,6 +888,7 @@ module_get_user_finalizer (emacs_env *env, emacs_value arg)
MODULE_FUNCTION_BEGIN (NULL);
Lisp_Object lisp = value_to_lisp (arg);
CHECK_USER_PTR (lisp);
+ MODULE_INTERNAL_CLEANUP ();
return XUSER_PTR (lisp)->finalizer;
}
@@ -847,6 +900,7 @@ module_set_user_finalizer (emacs_env *env, emacs_value arg,
Lisp_Object lisp = value_to_lisp (arg);
CHECK_USER_PTR (lisp);
XUSER_PTR (lisp)->finalizer = fin;
+ MODULE_INTERNAL_CLEANUP ();
}
static void
@@ -866,15 +920,21 @@ module_vec_set (emacs_env *env, emacs_value vector, ptrdiff_t index,
Lisp_Object lisp = value_to_lisp (vector);
check_vec_index (lisp, index);
ASET (lisp, index, value_to_lisp (value));
+ MODULE_INTERNAL_CLEANUP ();
}
static emacs_value
module_vec_get (emacs_env *env, emacs_value vector, ptrdiff_t index)
{
+ emacs_value value;
+
MODULE_FUNCTION_BEGIN (NULL);
Lisp_Object lisp = value_to_lisp (vector);
check_vec_index (lisp, index);
- return lisp_to_value (env, AREF (lisp, index));
+ value = lisp_to_value (env, AREF (lisp, index));
+ MODULE_INTERNAL_CLEANUP ();
+
+ return value;
}
static ptrdiff_t
@@ -883,6 +943,8 @@ module_vec_size (emacs_env *env, emacs_value vector)
MODULE_FUNCTION_BEGIN (0);
Lisp_Object lisp = value_to_lisp (vector);
CHECK_VECTOR (lisp);
+ MODULE_INTERNAL_CLEANUP ();
+
return ASIZE (lisp);
}
@@ -898,23 +960,37 @@ module_should_quit (emacs_env *env)
static enum emacs_process_input_result
module_process_input (emacs_env *env)
{
+ enum emacs_process_input_result rc;
+
MODULE_FUNCTION_BEGIN (emacs_process_input_quit);
maybe_quit ();
- return emacs_process_input_continue;
+ rc = emacs_process_input_continue;
+ MODULE_INTERNAL_CLEANUP ();
+ return rc;
}
static struct timespec
module_extract_time (emacs_env *env, emacs_value arg)
{
+ struct timespec value;
+
MODULE_FUNCTION_BEGIN ((struct timespec) {0});
- return lisp_time_argument (value_to_lisp (arg));
+ value = lisp_time_argument (value_to_lisp (arg));
+ MODULE_INTERNAL_CLEANUP ();
+
+ return value;
}
static emacs_value
module_make_time (emacs_env *env, struct timespec time)
{
+ emacs_value value;
+
MODULE_FUNCTION_BEGIN (NULL);
- return lisp_to_value (env, timespec_to_lisp (time));
+ value = lisp_to_value (env, timespec_to_lisp (time));
+ MODULE_INTERNAL_CLEANUP ();
+
+ return value;
}
/*
@@ -991,7 +1067,10 @@ module_extract_big_integer (emacs_env *env, emacs_value arg, int *sign,
EMACS_INT x = XFIXNUM (o);
*sign = (0 < x) - (x < 0);
if (x == 0 || count == NULL)
- return true;
+ {
+ MODULE_INTERNAL_CLEANUP ();
+ return true;
+ }
/* As a simplification we don't check how many array elements
are exactly required, but use a reasonable static upper
bound. For most architectures exactly one element should
@@ -1002,6 +1081,7 @@ module_extract_big_integer (emacs_env *env, emacs_value arg, int *sign,
if (magnitude == NULL)
{
*count = required;
+ MODULE_INTERNAL_CLEANUP ();
return true;
}
if (*count < required)
@@ -1020,12 +1100,16 @@ module_extract_big_integer (emacs_env *env, emacs_value arg, int *sign,
verify (required * bits < PTRDIFF_MAX);
for (ptrdiff_t i = 0; i < required; ++i)
magnitude[i] = (emacs_limb_t) (u >> (i * bits));
+ MODULE_INTERNAL_CLEANUP ();
return true;
}
const mpz_t *x = xbignum_val (o);
*sign = mpz_sgn (*x);
if (count == NULL)
- return true;
+ {
+ MODULE_INTERNAL_CLEANUP ();
+ return true;
+ }
size_t required_size = (mpz_sizeinbase (*x, 2) + numb - 1) / numb;
eassert (required_size <= PTRDIFF_MAX);
ptrdiff_t required = (ptrdiff_t) required_size;
@@ -1033,6 +1117,7 @@ module_extract_big_integer (emacs_env *env, emacs_value arg, int *sign,
if (magnitude == NULL)
{
*count = required;
+ MODULE_INTERNAL_CLEANUP ();
return true;
}
if (*count < required)
@@ -1045,6 +1130,7 @@ module_extract_big_integer (emacs_env *env, emacs_value arg, int *sign,
size_t written;
mpz_export (magnitude, &written, order, size, endian, nails, *x);
eassert (written == required_size);
+ MODULE_INTERNAL_CLEANUP ();
return true;
}
@@ -1052,21 +1138,34 @@ static emacs_value
module_make_big_integer (emacs_env *env, int sign,
ptrdiff_t count, const emacs_limb_t *magnitude)
{
+ emacs_value value;
+
MODULE_FUNCTION_BEGIN (NULL);
if (sign == 0)
- return lisp_to_value (env, make_fixed_natnum (0));
+ {
+ value = lisp_to_value (env, make_fixed_natnum (0));
+ MODULE_INTERNAL_CLEANUP ();
+ return value;
+ }
enum { order = -1, size = sizeof *magnitude, endian = 0, nails = 0 };
mpz_import (mpz[0], count, order, size, endian, nails, magnitude);
if (sign < 0)
mpz_neg (mpz[0], mpz[0]);
- return lisp_to_value (env, make_integer_mpz ());
+ value = lisp_to_value (env, make_integer_mpz ());
+ MODULE_INTERNAL_CLEANUP ();
+ return value;
}
static int
module_open_channel (emacs_env *env, emacs_value pipe_process)
{
+ int rc;
+
MODULE_FUNCTION_BEGIN (-1);
- return open_channel_for_module (value_to_lisp (pipe_process));
+ rc = open_channel_for_module (value_to_lisp (pipe_process));
+ MODULE_INTERNAL_CLEANUP ();
+
+ return rc;
}
@@ -1519,12 +1618,13 @@ finalize_runtime_unwind (void *raw_ert)
/* Must be called after setting up a handler immediately before
returning from the function. See the comments in lisp.h and the
code in eval.c for details. The macros below arrange for this
- function to be called automatically. PHANDLERLIST points to a word
- containing the handler list, for sanity checking. */
+ function to be called automatically. IHANDLERLIST points to the
+ handler list. */
+
static void
-module_reset_handlerlist (struct handler **phandlerlist)
+module_reset_handlerlist (struct handler *ihandlerlist)
{
- eassert (handlerlist == *phandlerlist);
+ eassert (handlerlist == ihandlerlist);
handlerlist = handlerlist->next;
}
@@ -1595,9 +1695,7 @@ syms_of_module (void)
{
staticpro (&Vmodule_refs_hash);
Vmodule_refs_hash
- = make_hash_table (hashtest_eq, DEFAULT_HASH_SIZE,
- DEFAULT_REHASH_SIZE, DEFAULT_REHASH_THRESHOLD,
- Qnil, false);
+ = make_hash_table (&hashtest_eq, DEFAULT_HASH_SIZE, Weak_None, false);
DEFSYM (Qmodule_load_failed, "module-load-failed");
Fput (Qmodule_load_failed, Qerror_conditions,
diff --git a/src/emacs-module.h.in b/src/emacs-module.h.in
index e7f571ed22a..690254bd28c 100644
--- a/src/emacs-module.h.in
+++ b/src/emacs-module.h.in
@@ -183,6 +183,21 @@ struct emacs_env_29
@module_env_snippet_29@
};
+struct emacs_env_30
+{
+@module_env_snippet_25@
+
+@module_env_snippet_26@
+
+@module_env_snippet_27@
+
+@module_env_snippet_28@
+
+@module_env_snippet_29@
+
+@module_env_snippet_30@
+};
+
/* Every module should define a function as follows. */
extern int emacs_module_init (struct emacs_runtime *runtime)
EMACS_NOEXCEPT
diff --git a/src/emacs.c b/src/emacs.c
index 712826d57b7..87f12d3fa86 100644
--- a/src/emacs.c
+++ b/src/emacs.c
@@ -33,6 +33,14 @@ along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. */
#include "lisp.h"
#include "sysstdio.h"
+#ifdef HAVE_ANDROID
+#include "androidterm.h"
+#endif
+
+#if defined HAVE_ANDROID && !defined ANDROID_STUBIFY
+#include "sfntfont.h"
+#endif
+
#ifdef WINDOWSNT
#include <fcntl.h>
#include <sys/socket.h>
@@ -137,6 +145,10 @@ extern char etext;
#include <sys/resource.h>
#endif
+#if defined HAVE_ANDROID && !defined ANDROID_STUBIFY
+#include "android.h"
+#endif
+
/* We don't guard this with HAVE_TREE_SITTER because treesit.o is
always compiled (to provide treesit-available-p). */
#include "treesit.h"
@@ -389,11 +401,6 @@ section of the Emacs manual or the file BUGS.\n"
/* True if handling a fatal error already. */
bool fatal_error_in_progress;
-#ifdef HAVE_NS
-/* NS autorelease pool, for memory management. */
-static void *ns_pool;
-#endif
-
#if !HAVE_SETLOCALE
static char *
setlocale (int cat, char const *locale)
@@ -411,7 +418,15 @@ using_utf8 (void)
the result is known in advance anyway... */
#if defined HAVE_WCHAR_H && !defined WINDOWSNT
wchar_t wc;
+#ifndef HAVE_ANDROID
mbstate_t mbs = { 0 };
+#else
+ mbstate_t mbs;
+
+ /* Not sure how mbstate works on Android, but this seems to be
+ required. */
+ memset (&mbs, 0, sizeof mbs);
+#endif
return mbrtowc (&wc, "\xc4\x80", 2, &mbs) == 2 && wc == 0x100;
#else
return false;
@@ -511,7 +526,8 @@ init_cmdargs (int argc, char **argv, int skip_args, char const *original_pwd)
{
Lisp_Object found;
int yes = openp (Vexec_path, Vinvocation_name, Vexec_suffixes,
- &found, make_fixnum (X_OK), false, false);
+ &found, make_fixnum (X_OK), false, false,
+ NULL);
if (yes == 1)
{
/* Add /: to the front of the name
@@ -724,6 +740,8 @@ argmatch (char **argv, int argc, const char *sstr, const char *lstr,
}
}
+#if !defined HAVE_ANDROID || defined ANDROID_STUBIFY
+
/* 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
@@ -823,6 +841,8 @@ find_emacs_executable (char const *argv0, ptrdiff_t *candidate_size)
#endif /* !WINDOWSNT */
}
+#endif
+
#ifdef HAVE_PDUMPER
static const char *
@@ -851,10 +871,38 @@ dump_error_to_string (int result)
}
}
-/* This function returns the Emacs executable. */
+/* This function returns the Emacs executable. DUMP_FILE is ignored
+ outside of Android. Otherwise, it is the name of the dump file to
+ use, or NULL if Emacs should look for a ``--dump-file'' argument
+ instead. */
+
static char *
-load_pdump (int argc, char **argv)
+load_pdump (int argc, char **argv, char *dump_file)
{
+#if defined HAVE_ANDROID && !defined ANDROID_STUBIFY
+ int skip_args = 0, result;
+
+ while (skip_args < argc - 1)
+ {
+ if (argmatch (argv, argc, "-dump-file", "--dump-file",
+ 6, &dump_file, &skip_args)
+ || argmatch (argv, argc, "--", NULL, 2, NULL,
+ &skip_args))
+ break;
+ skip_args++;
+ }
+
+ if (!dump_file)
+ return argv[0];
+
+ result = pdumper_load (dump_file, argv[0]);
+
+ if (result != PDUMPER_LOAD_SUCCESS)
+ fatal ("could not load dump file \"%s\": %s",
+ dump_file, dump_error_to_string (result));
+ return argv[0];
+#else
+
const char *const suffix = ".pdmp";
int result;
char *emacs_executable = argv[0];
@@ -885,7 +933,7 @@ load_pdump (int argc, char **argv)
/* Look for an explicitly-specified dump file. */
const char *path_exec = PATH_EXEC;
- char *dump_file = NULL;
+ dump_file = NULL;
int skip_args = 0;
while (skip_args < argc - 1)
{
@@ -1047,6 +1095,7 @@ load_pdump (int argc, char **argv)
xfree (dump_file);
return emacs_executable;
+#endif
}
#endif /* HAVE_PDUMPER */
@@ -1123,7 +1172,7 @@ load_seccomp (const char *file)
goto out;
}
struct stat stat;
- if (fstat (fd, &stat) != 0)
+ if (sys_fstat (fd, &stat) != 0)
{
emacs_perror ("fstat");
goto out;
@@ -1225,12 +1274,24 @@ maybe_load_seccomp (int argc, char **argv)
#endif /* SECCOMP_USABLE */
+#if defined HAVE_ANDROID && !defined ANDROID_STUBIFY
+int
+android_emacs_init (int argc, char **argv, char *dump_file)
+#else
int
main (int argc, char **argv)
+#endif
{
/* Variable near the bottom of the stack, and aligned appropriately
for pointers. */
void *stack_bottom_variable;
+ int old_argc;
+#if defined HAVE_PDUMPER && !(defined HAVE_ANDROID && !defined ANDROID_STUBIFY)
+ char *dump_file;
+
+ /* This is just a dummy argument used to avoid extra defines. */
+ dump_file = NULL;
+#endif
/* First, check whether we should apply a seccomp filter. This
should come at the very beginning to allow the filter to protect
@@ -1358,9 +1419,14 @@ main (int argc, char **argv)
w32_init_main_thread ();
#endif
+#ifdef HAVE_NS
+ /* Initialize the Obj C autorelease pool. */
+ ns_init_pool ();
+#endif
+
#ifdef HAVE_PDUMPER
if (attempt_load_pdump)
- initial_emacs_executable = load_pdump (argc, argv);
+ initial_emacs_executable = load_pdump (argc, argv, dump_file);
#else
ptrdiff_t bufsize;
initial_emacs_executable = find_emacs_executable (argv[0], &bufsize);
@@ -1425,8 +1491,9 @@ main (int argc, char **argv)
bool only_version = false;
sort_args (argc, argv);
- argc = 0;
- while (argv[argc]) argc++;
+ old_argc = argc, argc = 0;
+ /* Don't allow going past argv. */
+ while (argc < old_argc && argv[argc]) argc++;
skip_args = 0;
if (argmatch (argv, argc, "-version", "--version", 3, NULL, &skip_args))
@@ -1576,7 +1643,6 @@ main (int argc, char **argv)
if (! (lc_all && strcmp (lc_all, "C") == 0))
{
#ifdef HAVE_NS
- ns_pool = ns_alloc_autorelease_pool ();
ns_init_locale ();
#endif
setlocale (LC_ALL, "");
@@ -1934,6 +2000,9 @@ Using an Emacs configured with --with-x-toolkit=lucid does not have this problem
#ifdef HAVE_WINDOW_SYSTEM
init_fringe_once (); /* Swap bitmaps if necessary. */
#endif /* HAVE_WINDOW_SYSTEM */
+#ifdef HAVE_TEXT_CONVERSION
+ syms_of_textconv ();
+#endif
}
init_alloc ();
@@ -2367,6 +2436,19 @@ Using an Emacs configured with --with-x-toolkit=lucid does not have this problem
#endif
syms_of_fontset ();
#endif /* HAVE_HAIKU */
+#ifdef HAVE_ANDROID
+ syms_of_androidterm ();
+ syms_of_androidfns ();
+ syms_of_androidmenu ();
+ syms_of_fontset ();
+#if !defined ANDROID_STUBIFY
+ syms_of_androidfont ();
+ syms_of_androidselect ();
+ syms_of_androidvfs ();
+ syms_of_sfntfont ();
+ syms_of_sfntfont_android ();
+#endif /* !ANDROID_STUBIFY */
+#endif /* HAVE_ANDROID */
syms_of_gnutls ();
@@ -2439,7 +2521,8 @@ Using an Emacs configured with --with-x-toolkit=lucid does not have this problem
#ifdef HAVE_DBUS
init_dbusbind ();
#endif
-#if defined(USE_GTK) && !defined(HAVE_PGTK)
+
+#ifdef HAVE_X_WINDOWS
init_xterm ();
#endif
@@ -2462,6 +2545,17 @@ Using an Emacs configured with --with-x-toolkit=lucid does not have this problem
init_window ();
init_font ();
+#ifdef HAVE_ANDROID
+ init_androidmenu ();
+#endif
+
+#if defined HAVE_ANDROID && !defined ANDROID_STUBIFY
+ init_androidfont ();
+ init_androidselect ();
+ init_sfntfont ();
+ init_sfntfont_android ();
+#endif
+
if (!initialized)
{
char *file;
@@ -2516,6 +2610,16 @@ Using an Emacs configured with --with-x-toolkit=lucid does not have this problem
safe_run_hooks (Qafter_pdump_load_hook);
#endif
+#if defined HAVE_ANDROID && !defined ANDROID_STUBIFY && 0
+ /* This comes very late in the startup process because it requires
+ most of lisp/international to be loaded. This approach doesn't
+ work because normal-top-level runs and creates the initial frame
+ before fonts are initialized. So this is done in
+ normal-top-level instead. */
+ Vtop_level = list3 (Qprogn, Vtop_level,
+ list1 (Qandroid_enumerate_fonts));
+#endif
+
/* Enter editor command loop. This never returns. */
set_initial_minibuffer_mode ();
Frecursive_edit ();
@@ -2797,7 +2901,7 @@ sort_args (int argc, char **argv)
new[to++] = argv[best + i + 1];
}
- incoming_used += 1 + (options[best] > 0 ? options[best] : 0);
+ incoming_used += 1 + max (options[best], 0);
/* Clear out this option in ARGV. */
argv[best] = 0;
@@ -2841,7 +2945,14 @@ killed. */
#ifndef WINDOWSNT
/* Do some checking before shutting down Emacs, because errors
can't be meaningfully reported afterwards. */
- if (!NILP (restart))
+ if (!NILP (restart)
+ /* Don't perform the following checks when Emacs is running as
+ an Android GUI application, because there the system is
+ relied on to restart Emacs. */
+#if defined HAVE_ANDROID && !defined ANDROID_STUBIFY
+ && !android_init_gui
+#endif
+ )
{
/* This is very unlikely, but it's possible to execute a binary
(on some systems) with no argv. */
@@ -2882,10 +2993,6 @@ killed. */
shut_down_emacs (0, (STRINGP (arg) && !feof (stdin)) ? arg : Qnil);
-#ifdef HAVE_NS
- ns_release_autorelease_pool (ns_pool);
-#endif
-
/* If we have an auto-save list file,
kill it because we are exiting Emacs deliberately (not crashing).
Do it after shut_down_emacs, which does an auto-save. */
@@ -2893,7 +3000,7 @@ killed. */
{
Lisp_Object listfile;
listfile = Fexpand_file_name (Vauto_save_list_file_name, Qnil);
- unlink (SSDATA (listfile));
+ emacs_unlink (SSDATA (listfile));
}
#ifdef HAVE_NATIVE_COMP
@@ -2903,6 +3010,13 @@ killed. */
if (!NILP (restart))
{
turn_on_atimers (false);
+#if defined HAVE_ANDROID && !defined ANDROID_STUBIFY
+ /* Re-executing the Emacs process created by the system doesn't
+ work. Instead, schedule a restart for a few hundered
+ milliseconds and exit Emacs. */
+ if (android_init_gui)
+ android_restart_emacs ();
+#endif
#ifdef WINDOWSNT
if (w32_reexec_emacs (initial_cmdline, initial_wd) < 0)
#else
@@ -2943,31 +3057,38 @@ shut_down_emacs (int sig, Lisp_Object stuff)
Vinhibit_redisplay = Qt;
/* If we are controlling the terminal, reset terminal modes. */
-#ifndef DOS_NT
+#if !defined DOS_NT && !(defined HAVE_ANDROID && !defined ANDROID_STUBIFY)
pid_t tpgrp = tcgetpgrp (STDIN_FILENO);
if (tpgrp != -1 && tpgrp == getpgrp ())
{
reset_all_sys_modes ();
if (sig && sig != SIGTERM)
{
- static char const fmt[] = "Fatal error %d: %n%s\n";
#ifdef HAVE_HAIKU
if (haiku_debug_on_fatal_error)
debugger ("Fatal error in Emacs");
#endif
- char buf[max ((sizeof fmt - sizeof "%d%n%s\n"
+ /* Output a "Fatal error NUM: DESC\n" diagnostic with a single write,
+ but use multiple writes if the diagnosic is absurdly long
+ and likely couldn't be written atomically anyway. */
+ static char const fmt[] = "Fatal error %d: ";
+ char buf[max ((sizeof fmt - sizeof "%d"
+ INT_STRLEN_BOUND (int) + 1),
min (PIPE_BUF, MAX_ALLOCA))];
char const *sig_desc = safe_strsignal (sig);
- int nlen;
- int buflen = snprintf (buf, sizeof buf, fmt, sig, &nlen, sig_desc);
- if (0 <= buflen && buflen < sizeof buf)
- emacs_write (STDERR_FILENO, buf, buflen);
+ size_t sig_desclen = strlen (sig_desc);
+ int nlen = sprintf (buf, fmt, sig);
+ if (nlen + sig_desclen < sizeof buf - 1)
+ {
+ char *p = mempcpy (buf + nlen, sig_desc, sig_desclen);
+ *p++ = '\n';
+ emacs_write (STDERR_FILENO, buf, p - buf);
+ }
else
{
emacs_write (STDERR_FILENO, buf, nlen);
- emacs_write (STDERR_FILENO, sig_desc, strlen (sig_desc));
- emacs_write (STDERR_FILENO, fmt + sizeof fmt - 2, 1);
+ emacs_write (STDERR_FILENO, sig_desc, sig_desclen);
+ emacs_write (STDERR_FILENO, "\n", 1);
}
}
}
@@ -2996,10 +3117,6 @@ shut_down_emacs (int sig, Lisp_Object stuff)
check_message_stack ();
}
-#ifdef HAVE_NATIVE_COMP
- eln_load_path_final_clean_up ();
-#endif
-
#ifdef MSDOS
dos_cleanup ();
#endif
@@ -3206,9 +3323,6 @@ 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 (".");
@@ -3236,8 +3350,6 @@ 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;
@@ -3341,10 +3453,6 @@ decode_env_path (const char *evarname, const char *defalt, bool empty)
break;
}
-#ifdef NS_SELF_CONTAINED
- if (autorelease)
- ns_release_autorelease_pool (autorelease);
-#endif
return Fnreverse (lpath);
}
@@ -3462,6 +3570,7 @@ Special values:
`windows-nt' compiled as a native W32 application.
`cygwin' compiled using the Cygwin library.
`haiku' compiled for a Haiku system.
+ `android' compiled for Android.
Anything else (in Emacs 26, the possibilities are: aix, berkeley-unix,
hpux, usg-unix-v) indicates some sort of Unix system. */);
Vsystem_type = intern_c_string (SYSTEM_TYPE);
diff --git a/src/emacsgtkfixed.h b/src/emacsgtkfixed.h
index 9fa9ef79278..2db78fd00b5 100644
--- a/src/emacsgtkfixed.h
+++ b/src/emacsgtkfixed.h
@@ -28,8 +28,8 @@ struct frame;
G_BEGIN_DECLS
#ifdef HAVE_PGTK
-#define EMACS_TYPE_FIXED (emacs_fixed_get_type ())
-#define EMACS_IS_FIXED(obj) (G_TYPE_CHECK_INSTANCE_TYPE ((obj), EMACS_TYPE_FIXED))
+#define EMACS_TYPE_FIXED emacs_fixed_get_type ()
+#define EMACS_IS_FIXED(obj) G_TYPE_CHECK_INSTANCE_TYPE (obj, EMACS_TYPE_FIXED)
#endif
struct frame;
diff --git a/src/epaths.in b/src/epaths.in
index e43e430bdb8..275d13985aa 100644
--- a/src/epaths.in
+++ b/src/epaths.in
@@ -18,6 +18,7 @@ GNU General Public License for more details.
You should have received a copy of the GNU General Public License
along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. */
+#if !defined HAVE_ANDROID || defined ANDROID_STUBIFY
/* Together with PATH_SITELOADSEARCH, this gives the default value of
load-path, which is the search path for the Lisp function "load".
@@ -79,3 +80,24 @@ along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. */
/* Where Emacs should look for the application default file. */
#define PATH_X_DEFAULTS "/usr/lib/X11/%L/%T/%N%C%S:/usr/lib/X11/%l/%T/%N%C%S:/usr/lib/X11/%T/%N%C%S:/usr/lib/X11/%L/%T/%N%S:/usr/lib/X11/%l/%T/%N%S:/usr/lib/X11/%T/%N%S"
+
+#else
+
+/* Replace the defines above with links to files in the assets
+ pseudo-directory. Preserve the extra spaces, or epaths.in will not
+ be generated correctly. */
+
+ # define PATH_EXEC (android_lib_dir)
+ # define PATH_LOADSEARCH "/assets/lisp/"
+ # define PATH_SITELOADSEARCH (android_site_load_path)
+ # define PATH_DUMPLOADSEARCH "/assets/lisp/"
+ # define PATH_DATA "/assets/etc/"
+ # define PATH_DOC "/assets/etc/"
+ # define PATH_INFO "/assets/info/"
+ # define PATH_GAME ""
+ # define PATH_BITMAPS ""
+
+extern char *android_site_load_path;
+extern char *android_lib_dir;
+
+#endif
diff --git a/src/eval.c b/src/eval.c
index 3500014a224..f48d7b0682f 100644
--- a/src/eval.c
+++ b/src/eval.c
@@ -57,12 +57,6 @@ Lisp_Object Vrun_hooks;
/* FIXME: We should probably get rid of this! */
Lisp_Object Vsignaling_function;
-/* The handler structure which will catch errors in Lisp hooks called
- from redisplay. We do not use it for this; we compare it with the
- handler which is about to be used in signal_or_quit, and if it
- matches, cause a backtrace to be generated. */
-static struct handler *redisplay_deep_handler;
-
/* These would ordinarily be static, but they need to be visible to GDB. */
bool backtrace_p (union specbinding *) EXTERNALLY_VISIBLE;
Lisp_Object *backtrace_args (union specbinding *) EXTERNALLY_VISIBLE;
@@ -212,7 +206,6 @@ void
init_eval_once (void)
{
/* Don't forget to update docs (lispref node "Eval"). */
- max_lisp_eval_depth = 1600;
Vrun_hooks = Qnil;
pdumper_do_now_and_after_load (init_eval_once_for_pdumper);
}
@@ -245,25 +238,31 @@ init_eval (void)
lisp_eval_depth = 0;
/* This is less than the initial value of num_nonmacro_input_events. */
when_entered_debugger = -1;
- redisplay_deep_handler = NULL;
}
-/* Ensure that *M is at least A + B if possible, or is its maximum
- value otherwise. */
-
static void
-max_ensure_room (intmax_t *m, intmax_t a, intmax_t b)
+restore_stack_limits (Lisp_Object data)
{
- intmax_t sum = INT_ADD_WRAPV (a, b, &sum) ? INTMAX_MAX : sum;
- *m = max (*m, sum);
+ intmax_t old_depth;
+ integer_to_intmax (data, &old_depth);
+ lisp_eval_depth_reserve += max_lisp_eval_depth - old_depth;
+ max_lisp_eval_depth = old_depth;
}
-/* Unwind-protect function used by call_debugger. */
+/* Try and ensure that we have at least B dpeth available. */
static void
-restore_stack_limits (Lisp_Object data)
+max_ensure_room (intmax_t b)
{
- integer_to_intmax (data, &max_lisp_eval_depth);
+ intmax_t sum = ckd_add (&sum, lisp_eval_depth, b) ? INTMAX_MAX : sum;
+ intmax_t diff = min (sum - max_lisp_eval_depth, lisp_eval_depth_reserve);
+ if (diff <= 0)
+ return;
+ intmax_t old_depth = max_lisp_eval_depth;
+ max_lisp_eval_depth += diff;
+ lisp_eval_depth_reserve -= diff;
+ /* Restore limits after leaving the debugger. */
+ record_unwind_protect (restore_stack_limits, make_int (old_depth));
}
/* Call the Lisp debugger, giving it argument ARG. */
@@ -274,16 +273,12 @@ call_debugger (Lisp_Object arg)
bool debug_while_redisplaying;
specpdl_ref count = SPECPDL_INDEX ();
Lisp_Object val;
- intmax_t old_depth = max_lisp_eval_depth;
/* The previous value of 40 is too small now that the debugger
prints using cl-prin1 instead of prin1. Printing lists nested 8
deep (which is the value of print-level used in the debugger)
currently requires 77 additional frames. See bug#31919. */
- max_ensure_room (&max_lisp_eval_depth, lisp_eval_depth, 100);
-
- /* Restore limits after leaving the debugger. */
- record_unwind_protect (restore_stack_limits, make_int (old_depth));
+ max_ensure_room (100);
#ifdef HAVE_WINDOW_SYSTEM
if (display_hourglass_p)
@@ -317,6 +312,7 @@ call_debugger (Lisp_Object arg)
/* Interrupting redisplay and resuming it later is not safe under
all circumstances. So, when the debugger returns, abort the
interrupted redisplay by going back to the top-level. */
+ /* FIXME: Move this to the redisplay code? */
if (debug_while_redisplaying
&& !EQ (Vdebugger, Qdebug_early))
Ftop_level ();
@@ -571,11 +567,12 @@ omitted or nil, NEW-ALIAS gets the documentation string of BASE-VARIABLE,
or of the variable at the end of the chain of aliases, if BASE-VARIABLE is
itself an alias. If NEW-ALIAS is bound, and BASE-VARIABLE is not,
then the value of BASE-VARIABLE is set to that of NEW-ALIAS.
-The return value is BASE-VARIABLE. */)
+The return value is BASE-VARIABLE.
+
+If the resulting chain of variable definitions would contain a loop,
+signal a `cyclic-variable-indirection' error. */)
(Lisp_Object new_alias, Lisp_Object base_variable, Lisp_Object docstring)
{
- struct Lisp_Symbol *sym;
-
CHECK_SYMBOL (new_alias);
CHECK_SYMBOL (base_variable);
@@ -584,7 +581,18 @@ The return value is BASE-VARIABLE. */)
error ("Cannot make a constant an alias: %s",
SDATA (SYMBOL_NAME (new_alias)));
- sym = XSYMBOL (new_alias);
+ struct Lisp_Symbol *sym = XSYMBOL (new_alias);
+
+ /* Ensure non-circularity. */
+ struct Lisp_Symbol *s = XSYMBOL (base_variable);
+ for (;;)
+ {
+ if (s == sym)
+ xsignal1 (Qcyclic_variable_indirection, base_variable);
+ if (s->u.s.redirect != SYMBOL_VARALIAS)
+ break;
+ s = SYMBOL_ALIAS (s);
+ }
switch (sym->u.s.redirect)
{
@@ -677,7 +685,7 @@ lexbound_p (Lisp_Object symbol)
{
case SPECPDL_LET_DEFAULT:
case SPECPDL_LET:
- if (EQ (specpdl_symbol (pdl), Qinternal_interpreter_environment))
+ if (BASE_EQ (specpdl_symbol (pdl), Qinternal_interpreter_environment))
{
Lisp_Object env = specpdl_old_value (pdl);
if (CONSP (env) && !NILP (Fassq (symbol, env)))
@@ -780,8 +788,7 @@ DEFUN ("defvar", Fdefvar, Sdefvar, 1, UNEVALLED, 0,
You are not required to define a variable in order to use it, but
defining it lets you supply an initial value and documentation, which
can be referred to by the Emacs help facilities and other programming
-tools. The `defvar' form also declares the variable as \"special\",
-so that it is always dynamically bound even if `lexical-binding' is t.
+tools.
If SYMBOL's value is void and the optional argument INITVALUE is
provided, INITVALUE is evaluated and the result used to set SYMBOL's
@@ -789,6 +796,13 @@ value. If SYMBOL is buffer-local, its default value is what is set;
buffer-local values are not affected. If INITVALUE is missing,
SYMBOL's value is not set.
+If INITVALUE is provided, the `defvar' form also declares the variable
+as \"special\", so that it is always dynamically bound even if
+`lexical-binding' is t. If INITVALUE is missing, the form marks the
+variable \"special\" locally (i.e., within the current
+lexical scope, or the current file, if the form is at top-level),
+and does nothing if `lexical-binding' is nil.
+
If SYMBOL is let-bound, then this form does not affect the local let
binding but the toplevel default binding instead, like
`set-toplevel-default-binding`.
@@ -1180,6 +1194,12 @@ usage: (catch TAG BODY...) */)
#define clobbered_eassert(E) verify (sizeof (E) != 0)
+void
+pop_handler (void)
+{
+ handlerlist = handlerlist->next;
+}
+
/* Set up a catch, then call C function FUNC on argument ARG.
FUNC should return a Lisp_Object.
This is how catches are done from within C code. */
@@ -1343,6 +1363,49 @@ usage: (condition-case VAR BODYFORM &rest HANDLERS) */)
return internal_lisp_condition_case (var, bodyform, handlers);
}
+void
+push_handler_bind (Lisp_Object conditions, Lisp_Object handler, int skip)
+{
+ if (!CONSP (conditions))
+ conditions = Fcons (conditions, Qnil);
+ struct handler *c = push_handler (conditions, HANDLER_BIND);
+ c->val = handler;
+ c->bytecode_dest = skip;
+}
+
+DEFUN ("handler-bind-1", Fhandler_bind_1, Shandler_bind_1, 1, MANY, 0,
+ doc: /* Set up error handlers around execution of BODYFUN.
+BODYFUN should be a function and it is called with no arguments.
+CONDITIONS should be a list of condition names (symbols).
+When an error is signaled during execution of BODYFUN, if that
+error matches one of CONDITIONS, then the associated HANDLER is
+called with the error as argument.
+HANDLER should either transfer the control via a non-local exit,
+or return normally.
+If it returns normally, the search for an error handler continues
+from where it left off.
+
+usage: (handler-bind BODYFUN [CONDITIONS HANDLER]...) */)
+ (ptrdiff_t nargs, Lisp_Object *args)
+{
+ eassert (nargs >= 1);
+ Lisp_Object bodyfun = args[0];
+ int count = 0;
+ if (nargs % 2 == 0)
+ error ("Trailing CONDITIONS without HANDLER in `handler-bind`");
+ for (ptrdiff_t i = nargs - 2; i > 0; i -= 2)
+ {
+ Lisp_Object conditions = args[i], handler = args[i + 1];
+ if (NILP (conditions))
+ continue;
+ push_handler_bind (conditions, handler, count++);
+ }
+ Lisp_Object ret = call0 (bodyfun);
+ for (; count > 0; count--)
+ pop_handler ();
+ return ret;
+}
+
/* Like Fcondition_case, but the args are separate
rather than passed in a list. Used by Fbyte_code. */
@@ -1367,7 +1430,7 @@ internal_lisp_condition_case (Lisp_Object var, Lisp_Object bodyform,
error ("Invalid condition handler: %s",
SDATA (Fprin1_to_string (tem, Qt, Qnil)));
if (CONSP (tem) && EQ (XCAR (tem), QCsuccess))
- success_handler = XCDR (tem);
+ success_handler = tem;
else
clausenb++;
}
@@ -1430,7 +1493,7 @@ internal_lisp_condition_case (Lisp_Object var, Lisp_Object bodyform,
if (!NILP (success_handler))
{
if (NILP (var))
- return Fprogn (success_handler);
+ return Fprogn (XCDR (success_handler));
Lisp_Object handler_var = var;
if (!NILP (Vinternal_interpreter_environment))
@@ -1442,7 +1505,7 @@ internal_lisp_condition_case (Lisp_Object var, Lisp_Object bodyform,
specpdl_ref count = SPECPDL_INDEX ();
specbind (handler_var, result);
- return unbind_to (count, Fprogn (success_handler));
+ return unbind_to (count, Fprogn (XCDR (success_handler)));
}
return result;
}
@@ -1541,16 +1604,12 @@ internal_condition_case_n (Lisp_Object (*bfun) (ptrdiff_t, Lisp_Object *),
ptrdiff_t nargs,
Lisp_Object *args))
{
- struct handler *old_deep = redisplay_deep_handler;
struct handler *c = push_handler (handlers, CONDITION_CASE);
- if (redisplaying_p)
- redisplay_deep_handler = c;
if (sys_setjmp (c->jmp))
{
Lisp_Object val = handlerlist->val;
clobbered_eassert (handlerlist == c);
handlerlist = handlerlist->next;
- redisplay_deep_handler = old_deep;
return hfun (val, nargs, args);
}
else
@@ -1558,7 +1617,6 @@ internal_condition_case_n (Lisp_Object (*bfun) (ptrdiff_t, Lisp_Object *),
Lisp_Object val = bfun (nargs, args);
eassert (handlerlist == c);
handlerlist = c->next;
- redisplay_deep_handler = old_deep;
return val;
}
}
@@ -1636,8 +1694,7 @@ push_handler_nosignal (Lisp_Object tag_ch_val, enum handlertype handlertype)
static Lisp_Object signal_or_quit (Lisp_Object, Lisp_Object, bool);
static Lisp_Object find_handler_clause (Lisp_Object, Lisp_Object);
-static bool maybe_call_debugger (Lisp_Object conditions, Lisp_Object sig,
- Lisp_Object data);
+static bool maybe_call_debugger (Lisp_Object conditions, Lisp_Object error);
static void
process_quit_flag (void)
@@ -1697,28 +1754,29 @@ quit (void)
return signal_or_quit (Qquit, Qnil, true);
}
-/* Has an error in redisplay giving rise to a backtrace occurred as
- yet in the current command? This gets reset in the command
- loop. */
-bool backtrace_yet = false;
-
/* Signal an error, or quit. ERROR_SYMBOL and DATA are as with Fsignal.
- If KEYBOARD_QUIT, this is a quit; ERROR_SYMBOL should be
- Qquit and DATA should be Qnil, and this function may return.
+ If CONTINUABLE, the caller allows this function to return
+ (presumably after calling the debugger);
Otherwise this function is like Fsignal and does not return. */
static Lisp_Object
-signal_or_quit (Lisp_Object error_symbol, Lisp_Object data, bool keyboard_quit)
+signal_or_quit (Lisp_Object error_symbol, Lisp_Object data, bool continuable)
{
/* When memory is full, ERROR-SYMBOL is nil,
and DATA is (REAL-ERROR-SYMBOL . REAL-DATA).
That is a special case--don't do this in other situations. */
+ bool oom = NILP (error_symbol);
+ Lisp_Object error /* The error object. */
+ = oom ? data
+ : (!SYMBOLP (error_symbol) && NILP (data)) ? error_symbol
+ : Fcons (error_symbol, data);
Lisp_Object conditions;
Lisp_Object string;
Lisp_Object real_error_symbol
- = (NILP (error_symbol) ? Fcar (data) : error_symbol);
+ = CONSP (error) ? XCAR (error) : error_symbol;
Lisp_Object clause = Qnil;
struct handler *h;
+ int skip;
if (gc_in_progress || waiting_for_input)
emacs_abort ();
@@ -1733,15 +1791,15 @@ signal_or_quit (Lisp_Object error_symbol, Lisp_Object data, bool keyboard_quit)
/* This hook is used by edebug. */
if (! NILP (Vsignal_hook_function)
- && ! NILP (error_symbol)
- /* Don't try to call a lisp function if we've already overflowed
- the specpdl stack. */
- && specpdl_ptr < specpdl_end)
+ && !oom)
{
- /* Edebug takes care of restoring these variables when it exits. */
- max_ensure_room (&max_lisp_eval_depth, lisp_eval_depth, 20);
-
+ specpdl_ref count = SPECPDL_INDEX ();
+ max_ensure_room (20);
+ /* FIXME: 'handler-bind' makes `signal-hook-function' obsolete? */
+ /* FIXME: Here we still "split" the error object
+ into its error-symbol and its error-data? */
call2 (Vsignal_hook_function, error_symbol, data);
+ unbind_to (count, Qnil);
}
conditions = Fget (real_error_symbol, Qerror_conditions);
@@ -1751,7 +1809,7 @@ signal_or_quit (Lisp_Object error_symbol, Lisp_Object data, bool keyboard_quit)
too. Don't do this when ERROR_SYMBOL is nil, because that
is a memory-full error. */
Vsignaling_function = Qnil;
- if (!NILP (error_symbol))
+ if (!oom)
{
union specbinding *pdl = backtrace_next (backtrace_top ());
if (backtrace_p (pdl) && EQ (backtrace_function (pdl), Qerror))
@@ -1760,16 +1818,42 @@ signal_or_quit (Lisp_Object error_symbol, Lisp_Object data, bool keyboard_quit)
Vsignaling_function = backtrace_function (pdl);
}
- for (h = handlerlist; h; h = h->next)
+ for (skip = 0, h = handlerlist; h; skip++, h = h->next)
{
- if (h->type == CATCHER_ALL)
+ switch (h->type)
{
+ case CATCHER_ALL:
clause = Qt;
break;
- }
- if (h->type != CONDITION_CASE)
- continue;
- clause = find_handler_clause (h->tag_or_ch, conditions);
+ case CATCHER:
+ continue;
+ case CONDITION_CASE:
+ clause = find_handler_clause (h->tag_or_ch, conditions);
+ break;
+ case HANDLER_BIND:
+ {
+ if (!NILP (find_handler_clause (h->tag_or_ch, conditions)))
+ {
+ specpdl_ref count = SPECPDL_INDEX ();
+ max_ensure_room (20);
+ push_handler (make_fixnum (skip + h->bytecode_dest),
+ SKIP_CONDITIONS);
+ call1 (h->val, error);
+ unbind_to (count, Qnil);
+ pop_handler ();
+ }
+ continue;
+ }
+ case SKIP_CONDITIONS:
+ {
+ int toskip = XFIXNUM (h->tag_or_ch);
+ while (toskip-- >= 0)
+ h = h->next;
+ continue;
+ }
+ default:
+ abort ();
+ }
if (!NILP (clause))
break;
}
@@ -1777,7 +1861,7 @@ signal_or_quit (Lisp_Object error_symbol, Lisp_Object data, bool keyboard_quit)
bool debugger_called = false;
if (/* Don't run the debugger for a memory-full error.
(There is no room in memory to do that!) */
- !NILP (error_symbol)
+ !oom
&& (!NILP (Vdebug_on_signal)
/* If no handler is present now, try to run the debugger. */
|| NILP (clause)
@@ -1786,85 +1870,25 @@ signal_or_quit (Lisp_Object error_symbol, Lisp_Object data, bool keyboard_quit)
|| (CONSP (clause) && !NILP (Fmemq (Qdebug, clause)))
/* Special handler that means "print a message and run debugger
if requested". */
- || EQ (h->tag_or_ch, Qerror)))
+ || EQ (clause, Qerror)))
{
debugger_called
- = maybe_call_debugger (conditions, error_symbol, data);
+ = maybe_call_debugger (conditions, error);
/* We can't return values to code which signaled an error, but we
can continue code which has signaled a quit. */
- if (keyboard_quit && debugger_called && EQ (real_error_symbol, Qquit))
+ if (continuable && debugger_called)
return Qnil;
}
- /* If we're in batch mode, print a backtrace unconditionally to help
- with debugging. Make sure to use `debug-early' unconditionally
- to not interfere with ERT or other packages that install custom
- debuggers. */
- if (!debugger_called && !NILP (error_symbol)
- && (NILP (clause) || EQ (h->tag_or_ch, Qerror))
- && noninteractive && backtrace_on_error_noninteractive
- && NILP (Vinhibit_debugger)
- && !NILP (Ffboundp (Qdebug_early)))
- {
- max_ensure_room (&max_lisp_eval_depth, lisp_eval_depth, 100);
- specpdl_ref count = SPECPDL_INDEX ();
- specbind (Qdebugger, Qdebug_early);
- call_debugger (list2 (Qerror, Fcons (error_symbol, data)));
- unbind_to (count, Qnil);
- }
-
- /* If an error is signaled during a Lisp hook in redisplay, write a
- backtrace into the buffer *Redisplay-trace*. */
- if (!debugger_called && !NILP (error_symbol)
- && backtrace_on_redisplay_error
- && (NILP (clause) || h == redisplay_deep_handler)
- && NILP (Vinhibit_debugger)
- && !NILP (Ffboundp (Qdebug_early)))
- {
- max_ensure_room (&max_lisp_eval_depth, lisp_eval_depth, 100);
- specpdl_ref count = SPECPDL_INDEX ();
- AUTO_STRING (redisplay_trace, "*Redisplay_trace*");
- Lisp_Object redisplay_trace_buffer;
- AUTO_STRING (gap, "\n\n\n\n"); /* Separates things in *Redisplay-trace* */
- Lisp_Object delayed_warning;
- redisplay_trace_buffer = Fget_buffer_create (redisplay_trace, Qnil);
- current_buffer = XBUFFER (redisplay_trace_buffer);
- if (!backtrace_yet) /* Are we on the first backtrace of the command? */
- Ferase_buffer ();
- else
- Finsert (1, &gap);
- backtrace_yet = true;
- specbind (Qstandard_output, redisplay_trace_buffer);
- specbind (Qdebugger, Qdebug_early);
- call_debugger (list2 (Qerror, Fcons (error_symbol, data)));
- unbind_to (count, Qnil);
- delayed_warning = make_string
- ("Error in a redisplay Lisp hook. See buffer *Redisplay_trace*", 61);
-
- Vdelayed_warnings_list = Fcons (list2 (Qerror, delayed_warning),
- Vdelayed_warnings_list);
- }
-
if (!NILP (clause))
- {
- Lisp_Object unwind_data
- = (NILP (error_symbol) ? data : Fcons (error_symbol, data));
-
- unwind_to_catch (h, NONLOCAL_EXIT_SIGNAL, unwind_data);
- }
- else
- {
- if (handlerlist != handlerlist_sentinel)
- /* FIXME: This will come right back here if there's no `top-level'
- catcher. A better solution would be to abort here, and instead
- add a catch-all condition handler so we never come here. */
- Fthrow (Qtop_level, Qt);
- }
-
- if (! NILP (error_symbol))
- data = Fcons (error_symbol, data);
-
- string = Ferror_message_string (data);
+ unwind_to_catch (h, NONLOCAL_EXIT_SIGNAL, error);
+ else if (handlerlist != handlerlist_sentinel)
+ /* FIXME: This will come right back here if there's no `top-level'
+ catcher. A better solution would be to abort here, and instead
+ add a catch-all condition handler so we never come here. */
+ Fthrow (Qtop_level, Qt);
+
+ string = Ferror_message_string (error);
fatal ("%s", SDATA (string));
}
@@ -1989,14 +2013,15 @@ skip_debugger (Lisp_Object conditions, Lisp_Object data)
return 0;
}
-/* Say whether SIGNAL is a `quit' symbol (or inherits from it). */
+/* Say whether SIGNAL is a `quit' error (or inherits from it). */
bool
-signal_quit_p (Lisp_Object signal)
+signal_quit_p (Lisp_Object error)
{
+ Lisp_Object signal = CONSP (error) ? XCAR (error) : Qnil;
Lisp_Object list;
return EQ (signal, Qquit)
- || (!NILP (Fsymbolp (signal))
+ || (SYMBOLP (signal)
&& CONSP (list = Fget (signal, Qerror_conditions))
&& !NILP (Fmemq (Qquit, list)));
}
@@ -2007,27 +2032,23 @@ signal_quit_p (Lisp_Object signal)
= SIG is nil, and DATA is (SYMBOL . REST-OF-DATA).
This is for memory-full errors only. */
static bool
-maybe_call_debugger (Lisp_Object conditions, Lisp_Object sig, Lisp_Object data)
+maybe_call_debugger (Lisp_Object conditions, Lisp_Object error)
{
- Lisp_Object combined_data;
-
- combined_data = Fcons (sig, data);
-
if (
/* Don't try to run the debugger with interrupts blocked.
The editing loop would return anyway. */
! input_blocked_p ()
&& NILP (Vinhibit_debugger)
/* Does user want to enter debugger for this kind of error? */
- && (signal_quit_p (sig)
+ && (signal_quit_p (error)
? debug_on_quit
: wants_debugger (Vdebug_on_error, conditions))
- && ! skip_debugger (conditions, combined_data)
+ && ! skip_debugger (conditions, error)
/* See commentary on definition of
`internal-when-entered-debugger'. */
&& when_entered_debugger < num_nonmacro_input_events)
{
- call_debugger (list2 (Qerror, combined_data));
+ call_debugger (list2 (Qerror, error));
return 1;
}
@@ -2040,13 +2061,10 @@ find_handler_clause (Lisp_Object handlers, Lisp_Object conditions)
register Lisp_Object h;
/* t is used by handlers for all conditions, set up by C code. */
- if (EQ (handlers, Qt))
- return Qt;
-
/* error is used similarly, but means print an error message
and run the debugger if that is enabled. */
- if (EQ (handlers, Qerror))
- return Qt;
+ if (!CONSP (handlers))
+ return handlers;
for (h = handlers; CONSP (h); h = XCDR (h))
{
@@ -2120,7 +2138,7 @@ then strings and vectors are not accepted. */)
fun = function;
- fun = indirect_function (fun); /* Check cycles. */
+ fun = indirect_function (fun);
if (NILP (fun))
return Qnil;
@@ -2352,16 +2370,22 @@ it defines a macro. */)
}
+static Lisp_Object list_of_t; /* Never-modified constant containing (t). */
+
DEFUN ("eval", Feval, Seval, 1, 2, 0,
doc: /* Evaluate FORM and return its value.
-If LEXICAL is t, evaluate using lexical scoping.
-LEXICAL can also be an actual lexical environment, in the form of an
-alist mapping symbols to their value. */)
+If LEXICAL is `t', evaluate using lexical binding by default.
+This is the recommended value.
+
+If absent or `nil', use dynamic scoping only.
+
+LEXICAL can also represent an actual lexical environment; see the Info
+node `(elisp)Eval' for details. */)
(Lisp_Object form, Lisp_Object lexical)
{
specpdl_ref count = SPECPDL_INDEX ();
specbind (Qinternal_interpreter_environment,
- CONSP (lexical) || NILP (lexical) ? lexical : list1 (Qt));
+ CONSP (lexical) || NILP (lexical) ? lexical : list_of_t);
return unbind_to (count, eval_sub (form));
}
@@ -2375,8 +2399,7 @@ grow_specpdl_allocation (void)
union specbinding *pdlvec = specpdl - 1;
ptrdiff_t size = specpdl_end - specpdl;
ptrdiff_t pdlvecsize = size + 1;
- if (max_size <= size)
- xsignal0 (Qexcessive_variable_binding); /* Can't happen, essentially. */
+ eassert (max_size > size);
pdlvec = xpalloc (pdlvec, &pdlvecsize, 1, max_size + 1, sizeof *specpdl);
specpdl = pdlvec + 1;
specpdl_end = specpdl + pdlvecsize - 1;
@@ -3006,6 +3029,35 @@ usage: (funcall FUNCTION &rest ARGUMENTS) */)
}
+static Lisp_Object
+safe_eval_handler (Lisp_Object arg, ptrdiff_t nargs, Lisp_Object *args)
+{
+ add_to_log ("Error muted by safe_call: %S signaled %S",
+ Flist (nargs, args), arg);
+ return Qnil;
+}
+
+Lisp_Object
+safe_funcall (ptrdiff_t nargs, Lisp_Object *args)
+{
+ specpdl_ref count = SPECPDL_INDEX ();
+ /* FIXME: This function started its life in 'xdisp.c' for use internally
+ by the redisplay. So it was important to inhibit redisplay.
+ Not clear if we still need this 'specbind' now that 'xdisp.c' has its
+ own version of this code. */
+ specbind (Qinhibit_redisplay, Qt);
+ /* Use Qt to ensure debugger does not run. */
+ Lisp_Object val = internal_condition_case_n (Ffuncall, nargs, args, Qt,
+ safe_eval_handler);
+ return unbind_to (count, val);
+}
+
+Lisp_Object
+safe_eval (Lisp_Object sexp)
+{
+ return safe_calln (Qeval, sexp, Qt);
+}
+
/* Apply a C subroutine SUBR to the NUMARGS evaluated arguments in ARG_VECTOR
and return the result of evaluation. */
@@ -3016,21 +3068,21 @@ funcall_subr (struct Lisp_Subr *subr, ptrdiff_t numargs, Lisp_Object *args)
if (numargs >= subr->min_args)
{
/* Conforming call to finite-arity subr. */
- if (numargs <= subr->max_args
- && subr->max_args <= 8)
+ ptrdiff_t maxargs = subr->max_args;
+ if (numargs <= maxargs && maxargs <= 8)
{
Lisp_Object argbuf[8];
Lisp_Object *a;
- if (numargs < subr->max_args)
+ if (numargs < maxargs)
{
- eassume (subr->max_args <= ARRAYELTS (argbuf));
+ eassume (maxargs <= ARRAYELTS (argbuf));
a = argbuf;
memcpy (a, args, numargs * word_size);
- memclear (a + numargs, (subr->max_args - numargs) * word_size);
+ memclear (a + numargs, (maxargs - numargs) * word_size);
}
else
a = args;
- switch (subr->max_args)
+ switch (maxargs)
{
case 0:
return subr->function.a0 ();
@@ -3052,14 +3104,12 @@ funcall_subr (struct Lisp_Subr *subr, ptrdiff_t numargs, Lisp_Object *args)
case 8:
return subr->function.a8 (a[0], a[1], a[2], a[3], a[4], a[5],
a[6], a[7]);
- default:
- emacs_abort (); /* Can't happen. */
}
+ eassume (false); /* In case the compiler is too stupid. */
}
/* Call to n-adic subr. */
- if (subr->max_args == MANY
- || subr->max_args > 8)
+ if (maxargs == MANY || maxargs > 8)
return subr->function.aMANY (numargs, args);
}
@@ -3072,19 +3122,6 @@ funcall_subr (struct Lisp_Subr *subr, ptrdiff_t numargs, Lisp_Object *args)
xsignal2 (Qwrong_number_of_arguments, fun, make_fixnum (numargs));
}
-/* Call the compiled Lisp function FUN. If we have not yet read FUN's
- bytecode string and constants vector, fetch them from the file first. */
-
-static Lisp_Object
-fetch_and_exec_byte_code (Lisp_Object fun, ptrdiff_t args_template,
- ptrdiff_t nargs, Lisp_Object *args)
-{
- if (CONSP (AREF (fun, COMPILED_BYTECODE)))
- Ffetch_bytecode (fun);
-
- return exec_byte_code (fun, args_template, nargs, args);
-}
-
static Lisp_Object
apply_lambda (Lisp_Object fun, Lisp_Object args, specpdl_ref count)
{
@@ -3154,8 +3191,7 @@ funcall_lambda (Lisp_Object fun, ptrdiff_t nargs,
ARGLIST slot value: pass the arguments to the byte-code
engine directly. */
if (FIXNUMP (syms_left))
- return fetch_and_exec_byte_code (fun, XFIXNUM (syms_left),
- nargs, arg_vector);
+ return exec_byte_code (fun, XFIXNUM (syms_left), nargs, arg_vector);
/* Otherwise the bytecode object uses dynamic binding and the
ARGLIST slot contains a standard formal argument list whose
variables are bound dynamically below. */
@@ -3243,7 +3279,7 @@ funcall_lambda (Lisp_Object fun, ptrdiff_t nargs,
val = XSUBR (fun)->function.a0 ();
}
else
- val = fetch_and_exec_byte_code (fun, 0, 0, NULL);
+ val = exec_byte_code (fun, 0, 0, NULL);
return unbind_to (count, val);
}
@@ -3361,48 +3397,8 @@ lambda_arity (Lisp_Object fun)
return Fcons (make_fixnum (minargs), make_fixnum (maxargs));
}
-DEFUN ("fetch-bytecode", Ffetch_bytecode, Sfetch_bytecode,
- 1, 1, 0,
- doc: /* If byte-compiled OBJECT is lazy-loaded, fetch it now. */)
- (Lisp_Object object)
-{
- Lisp_Object tem;
-
- if (COMPILEDP (object))
- {
- if (CONSP (AREF (object, COMPILED_BYTECODE)))
- {
- tem = read_doc_string (AREF (object, COMPILED_BYTECODE));
- if (! (CONSP (tem) && STRINGP (XCAR (tem))
- && VECTORP (XCDR (tem))))
- {
- tem = AREF (object, COMPILED_BYTECODE);
- if (CONSP (tem) && STRINGP (XCAR (tem)))
- error ("Invalid byte code in %s", SDATA (XCAR (tem)));
- else
- error ("Invalid byte code");
- }
-
- Lisp_Object bytecode = XCAR (tem);
- if (STRING_MULTIBYTE (bytecode))
- {
- /* BYTECODE must have been produced by Emacs 20.2 or earlier
- because it produced a raw 8-bit string for byte-code and now
- such a byte-code string is loaded as multibyte with raw 8-bit
- characters converted to multibyte form. Convert them back to
- the original unibyte form. */
- bytecode = Fstring_as_unibyte (bytecode);
- }
-
- pin_string (bytecode);
- ASET (object, COMPILED_BYTECODE, bytecode);
- ASET (object, COMPILED_CONSTANTS, XCDR (tem));
- }
- }
- return object;
-}
-/* Return true if SYMBOL currently has a let-binding
+/* Return true if SYMBOL's default currently has a let-binding
which was made in the buffer that is now current. */
bool
@@ -3417,6 +3413,7 @@ let_shadows_buffer_binding_p (struct Lisp_Symbol *symbol)
struct Lisp_Symbol *let_bound_symbol = XSYMBOL (specpdl_symbol (p));
eassert (let_bound_symbol->u.s.redirect != SYMBOL_VARALIAS);
if (symbol == let_bound_symbol
+ && p->kind != SPECPDL_LET_LOCAL /* bug#62419 */
&& EQ (specpdl_where (p), buf))
return 1;
}
@@ -3478,7 +3475,7 @@ specbind (Lisp_Object symbol, Lisp_Object value)
switch (sym->u.s.redirect)
{
case SYMBOL_VARALIAS:
- sym = indirect_variable (sym); XSETSYMBOL (symbol, sym); goto start;
+ sym = SYMBOL_ALIAS (sym); XSETSYMBOL (symbol, sym); goto start;
case SYMBOL_PLAINVAL:
/* The most common case is that of a non-constant symbol with a
trivial value. Make that as fast as we can. */
@@ -3788,10 +3785,18 @@ get_backtrace_starting_at (Lisp_Object base)
if (!NILP (base))
{ /* Skip up to `base'. */
+ int offset = 0;
+ if (CONSP (base) && FIXNUMP (XCAR (base)))
+ {
+ offset = XFIXNUM (XCAR (base));
+ base = XCDR (base);
+ }
base = Findirect_function (base, Qt);
while (backtrace_p (pdl)
&& !EQ (base, Findirect_function (backtrace_function (pdl), Qt)))
pdl = backtrace_next (pdl);
+ while (backtrace_p (pdl) && offset-- > 0)
+ pdl = backtrace_next (pdl);
}
return pdl;
@@ -3831,13 +3836,14 @@ backtrace_frame_apply (Lisp_Object function, union specbinding *pdl)
}
}
-DEFUN ("backtrace-debug", Fbacktrace_debug, Sbacktrace_debug, 2, 2, 0,
+DEFUN ("backtrace-debug", Fbacktrace_debug, Sbacktrace_debug, 2, 3, 0,
doc: /* Set the debug-on-exit flag of eval frame LEVEL levels down to FLAG.
+LEVEL and BASE specify the activation frame to use, as in `backtrace-frame'.
The debugger is entered when that frame exits, if the flag is non-nil. */)
- (Lisp_Object level, Lisp_Object flag)
+ (Lisp_Object level, Lisp_Object flag, Lisp_Object base)
{
CHECK_FIXNUM (level);
- union specbinding *pdl = get_backtrace_frame(level, Qnil);
+ union specbinding *pdl = get_backtrace_frame (level, base);
if (backtrace_p (pdl))
set_backtrace_debug_on_exit (pdl, !NILP (flag));
@@ -4093,7 +4099,7 @@ NFRAMES and BASE specify the activation frame to use, as in `backtrace-frame'.
{
Lisp_Object sym = specpdl_symbol (tmp);
Lisp_Object val = specpdl_old_value (tmp);
- if (EQ (sym, Qinternal_interpreter_environment))
+ if (BASE_EQ (sym, Qinternal_interpreter_environment))
{
Lisp_Object env = val;
for (; CONSP (env); env = XCDR (env))
@@ -4190,23 +4196,18 @@ mark_specpdl (union specbinding *first, union specbinding *ptr)
}
}
+/* Fill ARRAY of size SIZE with backtrace entries, most recent call first.
+ Truncate the backtrace if longer than SIZE; pad with nil if shorter. */
void
-get_backtrace (Lisp_Object array)
+get_backtrace (Lisp_Object *array, ptrdiff_t size)
{
- union specbinding *pdl = backtrace_next (backtrace_top ());
- ptrdiff_t i = 0, asize = ASIZE (array);
-
/* Copy the backtrace contents into working memory. */
- for (; i < asize; i++)
- {
- if (backtrace_p (pdl))
- {
- ASET (array, i, backtrace_function (pdl));
- pdl = backtrace_next (pdl);
- }
- else
- ASET (array, i, Qnil);
- }
+ union specbinding *pdl = backtrace_top ();
+ ptrdiff_t i = 0;
+ for (; i < size && backtrace_p (pdl); i++, pdl = backtrace_next (pdl))
+ array[i] = backtrace_function (pdl);
+ for (; i < size; i++)
+ array[i] = Qnil;
}
Lisp_Object backtrace_top_function (void)
@@ -4226,6 +4227,13 @@ actual stack overflow in C, which would be fatal for Emacs.
You can safely make it considerably larger than its default value,
if that proves inconveniently small. However, if you increase it too far,
Emacs could overflow the real C stack, and crash. */);
+ max_lisp_eval_depth = 1600;
+
+ DEFVAR_INT ("lisp-eval-depth-reserve", lisp_eval_depth_reserve,
+ doc: /* Extra depth that can be allocated to handle errors.
+This is the max depth that the system will add to `max-lisp-eval-depth'
+when calling debuggers or `handler-bind' handlers. */);
+ lisp_eval_depth_reserve = 200;
DEFVAR_LISP ("quit-flag", Vquit_flag,
doc: /* Non-nil causes `eval' to abort, unless `inhibit-quit' is non-nil.
@@ -4262,6 +4270,7 @@ before making `inhibit-quit' nil. */);
DEFSYM (QCdocumentation, ":documentation");
DEFSYM (Qdebug, "debug");
DEFSYM (Qdebug_early, "debug-early");
+ DEFSYM (Qdebug_early__handler, "debug-early--handler");
DEFVAR_LISP ("inhibit-debugger", Vinhibit_debugger,
doc: /* Non-nil means never enter the debugger.
@@ -4286,6 +4295,10 @@ See also the variable `debug-on-quit' and `inhibit-debugger'. */);
Each element may be a condition-name or a regexp that matches error messages.
If any element applies to a given error, that error skips the debugger
and just returns to top level.
+If you invoke Emacs with --debug-init, and want to remove some
+elements from the default value of this variable, use `setq' to
+change the value of the variable to a new list, rather than `delq'
+to remove some errors from the list.
This overrides the variable `debug-on-error'.
It does not apply to errors handled by `condition-case'. */);
Vdebug_ignored_errors = Qnil;
@@ -4316,11 +4329,14 @@ might not be safe to continue. */);
DEFSYM (Qdebugger, "debugger");
DEFVAR_LISP ("debugger", Vdebugger,
doc: /* Function to call to invoke debugger.
-If due to frame exit, args are `exit' and the value being returned;
+If due to frame exit, arguments are `exit' and the value being returned;
this function's value will be returned instead of that.
-If due to error, args are `error' and a list of the args to `signal'.
-If due to `apply' or `funcall' entry, one arg, `lambda'.
-If due to `eval' entry, one arg, t. */);
+If due to error, arguments are `error' and a list of arguments to `signal'.
+If due to `apply' or `funcall' entry, one argument, `lambda'.
+If due to `eval' entry, one argument, t.
+IF the desired entry point of the debugger is higher in the call stack,
+it can be specified with the keyword argument `:backtrace-base', whose
+format should be the same as the BASE argument of `backtrace-frame'. */);
Vdebugger = Qdebug_early;
DEFVAR_LISP ("signal-hook-function", Vsignal_hook_function,
@@ -4396,6 +4412,9 @@ alist of active lexical bindings. */);
Qcatch_all_memory_full
= Fmake_symbol (build_pure_c_string ("catch-all-memory-full"));
+ staticpro (&list_of_t);
+ list_of_t = list1 (Qt);
+
defsubr (&Sor);
defsubr (&Sand);
defsubr (&Sif);
@@ -4424,6 +4443,7 @@ alist of active lexical bindings. */);
defsubr (&Sthrow);
defsubr (&Sunwind_protect);
defsubr (&Scondition_case);
+ defsubr (&Shandler_bind_1);
DEFSYM (QCsuccess, ":success");
defsubr (&Ssignal);
defsubr (&Scommandp);
@@ -4438,7 +4458,6 @@ alist of active lexical bindings. */);
defsubr (&Srun_hook_with_args_until_success);
defsubr (&Srun_hook_with_args_until_failure);
defsubr (&Srun_hook_wrapped);
- defsubr (&Sfetch_bytecode);
defsubr (&Sbacktrace_debug);
DEFSYM (QCdebug_on_exit, ":debug-on-exit");
defsubr (&Smapbacktrace);
diff --git a/src/fileio.c b/src/fileio.c
index a5d29d81fb7..12da7a9ed3a 100644
--- a/src/fileio.c
+++ b/src/fileio.c
@@ -56,6 +56,10 @@ along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. */
#include "region-cache.h"
#include "frame.h"
+#ifdef HAVE_ANDROID
+#include "android.h"
+#endif /* HAVE_ANDROID */
+
#ifdef HAVE_LINUX_FS_H
# include <sys/ioctl.h>
# include <linux/fs.h>
@@ -109,6 +113,42 @@ along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. */
#include "commands.h"
+#if !defined HAVE_ANDROID || defined ANDROID_STUBIFY
+
+/* Type describing a file descriptor used by functions such as
+ `insert-file-contents'. */
+
+typedef int emacs_fd;
+
+/* Function used to read and open from such a file descriptor. */
+
+#define emacs_fd_open emacs_open
+#define emacs_fd_close emacs_close
+#define emacs_fd_read emacs_read_quit
+#define emacs_fd_lseek lseek
+#define emacs_fd_fstat sys_fstat
+#define emacs_fd_valid_p(fd) ((fd) >= 0)
+
+/* This is not used on MS Windows. */
+
+#ifndef WINDOWSNT
+#define emacs_fd_to_int(fds) (fds)
+#endif /* WINDOWSNT */
+
+#else /* HAVE_ANDROID && !defined ANDROID_STUBIFY */
+
+typedef struct android_fd_or_asset emacs_fd;
+
+#define emacs_fd_open android_open_asset
+#define emacs_fd_close android_close_asset
+#define emacs_fd_read android_asset_read_quit
+#define emacs_fd_lseek android_asset_lseek
+#define emacs_fd_fstat android_asset_fstat
+#define emacs_fd_valid_p(fd) ((fd).asset != ((void *) -1))
+#define emacs_fd_to_int(fds) ((fds).asset ? -1 : (fds).fd)
+
+#endif /* !defined HAVE_ANDROID || defined ANDROID_STUBIFY */
+
/* True during writing of auto-save files. */
static bool auto_saving;
@@ -134,13 +174,52 @@ static dev_t timestamp_file_system;
is added here. */
static Lisp_Object Vwrite_region_annotation_buffers;
-static Lisp_Object file_name_directory (Lisp_Object);
+static Lisp_Object emacs_readlinkat (int, char const *);
static bool a_write (int, Lisp_Object, ptrdiff_t, ptrdiff_t,
Lisp_Object *, struct coding_system *);
static bool e_write (int, Lisp_Object, ptrdiff_t, ptrdiff_t,
struct coding_system *);
+
+/* Establish that ENCODED is not contained within a special directory
+ whose contents are not eligible for Unix VFS operations. Signal a
+ `file-error' with REASON if it does. */
+
+static void
+check_vfs_filename (Lisp_Object encoded, const char *reason)
+{
+#if defined HAVE_ANDROID && !defined ANDROID_STUBIFY
+ const char *name;
+
+ name = SSDATA (encoded);
+
+ if (android_is_special_directory (name, "/assets")
+ || android_is_special_directory (name, "/content"))
+ xsignal2 (Qfile_error, build_string (reason), encoded);
+#endif /* defined HAVE_ANDROID && !defined ANDROID_STUBIFY */
+}
+
+#ifdef HAVE_LIBSELINUX
+
+/* Return whether SELinux is enabled and pertinent to FILE. Provide
+ for cases where FILE is or is a constituent of a special
+ directory, such as /assets or /content on Android. */
+
+static bool
+selinux_enabled_p (const char *file)
+{
+ return (is_selinux_enabled ()
+#if defined HAVE_ANDROID && !defined ANDROID_STUBIFY
+ && !android_is_special_directory (file, "/assets")
+ && !android_is_special_directory (file, "/content")
+#endif /* defined HAVE_ANDROID && !defined ANDROID_STUBIFY */
+ );
+}
+
+#endif /* HAVE_LIBSELINUX */
+
+
/* Test whether FILE is accessible for AMODE.
Return true if successful, false (setting errno) otherwise. */
@@ -159,7 +238,7 @@ file_access_p (char const *file, int amode)
}
#endif
- if (faccessat (AT_FDCWD, file, amode, AT_EACCESS) == 0)
+ if (sys_faccessat (AT_FDCWD, file, amode, AT_EACCESS) == 0)
return true;
#ifdef CYGWIN
@@ -263,11 +342,20 @@ close_file_unwind (int fd)
emacs_close (fd);
}
+static void
+close_file_unwind_emacs_fd (void *ptr)
+{
+ emacs_fd *fd;
+
+ fd = ptr;
+ emacs_fd_close (*fd);
+}
+
void
fclose_unwind (void *arg)
{
FILE *stream = arg;
- fclose (stream);
+ emacs_fclose (stream);
}
/* Restore point, having saved it as a marker. */
@@ -369,7 +457,7 @@ Given a Unix syntax file name, returns a string ending in slash. */)
/* Return the directory component of FILENAME, or nil if FILENAME does
not contain a directory component. */
-static Lisp_Object
+Lisp_Object
file_name_directory (Lisp_Object filename)
{
char *beg = SSDATA (filename);
@@ -755,7 +843,7 @@ For that reason, you should normally use `make-temp-file' instead. */)
DEFUN ("file-name-concat", Ffile_name_concat, Sfile_name_concat, 1, MANY, 0,
doc: /* Append COMPONENTS to DIRECTORY and return the resulting string.
-Elements in COMPONENTS must be a string or nil.
+Each element in COMPONENTS must be a string or nil.
DIRECTORY or the non-final elements in COMPONENTS may or may not end
with a slash -- if they don't end with a slash, a slash will be
inserted before concatenating.
@@ -888,6 +976,10 @@ user_homedir (char const *name)
p[length] = 0;
struct passwd *pw = getpwnam (p);
SAFE_FREE ();
+#if defined HAVE_ANDROID && !defined ANDROID_STUBIFY
+ if (pw && !pw->pw_dir && pw->pw_uid == getuid ())
+ return (char *) android_get_home_directory ();
+#endif
if (!pw || (pw->pw_dir && !IS_ABSOLUTE_FILE_NAME (pw->pw_dir)))
return NULL;
return pw->pw_dir;
@@ -1878,6 +1970,11 @@ get_homedir (void)
pw = getpwuid (getuid ());
if (pw)
home = pw->pw_dir;
+
+#if defined HAVE_ANDROID && !defined ANDROID_STUBIFY
+ if (!home && pw && pw->pw_uid == getuid ())
+ return android_get_home_directory ();
+#endif
if (!home)
return "";
}
@@ -2176,7 +2273,8 @@ permissions. */)
#else
bool already_exists = false;
mode_t new_mask;
- int ifd, ofd;
+ emacs_fd ifd;
+ int ofd;
struct stat st;
#endif
@@ -2219,26 +2317,31 @@ permissions. */)
report_file_error ("Copying permissions to", newname);
}
#else /* not WINDOWSNT */
- ifd = emacs_open (SSDATA (encoded_file), O_RDONLY, 0);
+ ifd = emacs_fd_open (SSDATA (encoded_file), O_RDONLY | O_NONBLOCK, 0);
- if (ifd < 0)
+ if (!emacs_fd_valid_p (ifd))
report_file_error ("Opening input file", file);
- record_unwind_protect_int (close_file_unwind, ifd);
+ record_unwind_protect_ptr (close_file_unwind_emacs_fd, &ifd);
- if (fstat (ifd, &st) != 0)
+ if (emacs_fd_fstat (ifd, &st) != 0)
report_file_error ("Input file status", file);
if (!NILP (preserve_permissions))
{
#if HAVE_LIBSELINUX
- if (is_selinux_enabled ())
+ if (selinux_enabled_p (SSDATA (encoded_file))
+ /* Eschew copying SELinux contexts if they're inapplicable
+ to the destination file. */
+ && selinux_enabled_p (SSDATA (encoded_newname))
+ && emacs_fd_to_int (ifd) != -1)
{
- conlength = fgetfilecon (ifd, &con);
+ conlength = fgetfilecon (emacs_fd_to_int (ifd),
+ &con);
if (conlength == -1)
report_file_error ("Doing fgetfilecon", file);
}
-#endif
+#endif /* HAVE_LIBSELINUX */
}
/* We can copy only regular files. */
@@ -2272,7 +2375,7 @@ permissions. */)
if (already_exists)
{
struct stat out_st;
- if (fstat (ofd, &out_st) != 0)
+ if (sys_fstat (ofd, &out_st) != 0)
report_file_error ("Output file status", newname);
if (st.st_dev == out_st.st_dev && st.st_ino == out_st.st_ino)
report_file_errno ("Input and output files are the same",
@@ -2283,7 +2386,8 @@ permissions. */)
maybe_quit ();
- if (clone_file (ofd, ifd))
+ if (emacs_fd_to_int (ifd) != -1
+ && clone_file (ofd, emacs_fd_to_int (ifd)))
newsize = st.st_size;
else
{
@@ -2291,30 +2395,38 @@ permissions. */)
ssize_t copied;
#ifndef MSDOS
- for (newsize = 0; newsize < insize; newsize += copied)
+ newsize = 0;
+
+ if (emacs_fd_to_int (ifd) != -1)
{
- /* Copy at most COPY_MAX bytes at a time; this is min
- (PTRDIFF_MAX, SIZE_MAX) truncated to a value that is
- surely aligned well. */
- ssize_t ssize_max = TYPE_MAXIMUM (ssize_t);
- ptrdiff_t copy_max = min (ssize_max, SIZE_MAX) >> 30 << 30;
- off_t intail = insize - newsize;
- ptrdiff_t len = min (intail, copy_max);
- copied = copy_file_range (ifd, NULL, ofd, NULL, len, 0);
- if (copied <= 0)
- break;
- maybe_quit ();
+ for (; newsize < insize; newsize += copied)
+ {
+ /* Copy at most COPY_MAX bytes at a time; this is min
+ (PTRDIFF_MAX, SIZE_MAX) truncated to a value that is
+ surely aligned well. */
+ ssize_t ssize_max = TYPE_MAXIMUM (ssize_t);
+ ptrdiff_t copy_max = min (ssize_max, SIZE_MAX) >> 30 << 30;
+ off_t intail = insize - newsize;
+ ptrdiff_t len = min (intail, copy_max);
+ copied = copy_file_range (emacs_fd_to_int (ifd), NULL,
+ ofd, NULL, len, 0);
+ if (copied <= 0)
+ break;
+ maybe_quit ();
+ }
}
#endif /* MSDOS */
/* Fall back on read+write if copy_file_range failed, or if the
- input is empty and so could be a /proc file. read+write will
- either succeed, or report an error more precisely than
- copy_file_range would. */
+ input is empty and so could be a /proc file, or if ifd is an
+ invention of android.c. read+write will either succeed, or
+ report an error more precisely than copy_file_range
+ would. */
if (newsize != insize || insize == 0)
{
char buf[MAX_ALLOCA];
- for (; (copied = emacs_read_quit (ifd, buf, sizeof buf));
+
+ for (; (copied = emacs_fd_read (ifd, buf, sizeof buf));
newsize += copied)
{
if (copied < 0)
@@ -2362,8 +2474,10 @@ permissions. */)
}
}
- switch (!NILP (preserve_permissions)
- ? qcopy_acl (SSDATA (encoded_file), ifd,
+ switch ((!NILP (preserve_permissions)
+ && emacs_fd_to_int (ifd) != -1)
+ ? qcopy_acl (SSDATA (encoded_file),
+ emacs_fd_to_int (ifd),
SSDATA (encoded_newname), ofd,
preserved_permissions)
: (already_exists
@@ -2382,11 +2496,18 @@ permissions. */)
{
/* Set the modified context back to the file. */
bool fail = fsetfilecon (ofd, con) != 0;
+ freecon (con);
+
/* See https://debbugs.gnu.org/11245 for ENOTSUP. */
- if (fail && errno != ENOTSUP)
+ if (fail
+#if defined HAVE_ANDROID && !defined ANDROID_STUBIFY
+ /* Treat SELinux errors copying files leniently on Android,
+ since the system usually forbids user programs from
+ changing file contexts. */
+ && errno != EACCES
+#endif /* defined HAVE_ANDROID && !defined ANDROID_STUBIFY */
+ && errno != ENOTSUP)
report_file_error ("Doing fsetfilecon", newname);
-
- freecon (con);
}
#endif
@@ -2395,7 +2516,17 @@ permissions. */)
struct timespec ts[2];
ts[0] = get_stat_atime (&st);
ts[1] = get_stat_mtime (&st);
- if (futimens (ofd, ts) != 0)
+ if (futimens (ofd, ts) != 0
+ /* Various versions of the Android C library are missing
+ futimens, prompting Gnulib to install a fallback that
+ uses fdutimens instead. However, fdutimens is not
+ supported on many Android kernels, so just silently fail
+ if errno is ENOTSUP or ENOSYS. */
+#if defined HAVE_ANDROID && !defined ANDROID_STUBIFY
+ && errno != ENOTSUP
+ && errno != ENOSYS
+#endif
+ )
xsignal2 (Qfile_date_error,
build_string ("Cannot set file date"), newname);
}
@@ -2403,7 +2534,9 @@ permissions. */)
if (emacs_close (ofd) < 0)
report_file_error ("Write error", newname);
- emacs_close (ifd);
+ /* Note that ifd is not closed twice because unwind_protects are
+ discarded at the end of this function. */
+ emacs_fd_close (ifd);
#ifdef MSDOS
/* In DJGPP v2.0 and later, fstat usually returns true file mode bits,
@@ -2436,7 +2569,7 @@ DEFUN ("make-directory-internal", Fmake_directory_internal,
dir = SSDATA (encoded_dir);
- if (mkdir (dir, 0777 & ~auto_saving_dir_umask) != 0)
+ if (emacs_mkdir (dir, 0777 & ~auto_saving_dir_umask) != 0)
report_file_error ("Creating directory", directory);
return Qnil;
@@ -2455,47 +2588,26 @@ DEFUN ("delete-directory-internal", Fdelete_directory_internal,
encoded_dir = ENCODE_FILE (directory);
dir = SSDATA (encoded_dir);
- if (rmdir (dir) != 0)
+ if (emacs_rmdir (dir) != 0)
report_file_error ("Removing directory", directory);
return Qnil;
}
-DEFUN ("delete-file", Fdelete_file, Sdelete_file, 1, 2,
- "(list (read-file-name \
- (if (and delete-by-moving-to-trash (null current-prefix-arg)) \
- \"Move file to trash: \" \"Delete file: \") \
- nil default-directory (confirm-nonexistent-file-or-buffer)) \
- (null current-prefix-arg))",
- doc: /* Delete file named FILENAME. If it is a symlink, remove the symlink.
-If file has multiple names, it continues to exist with the other names.
-TRASH non-nil means to trash the file instead of deleting, provided
-`delete-by-moving-to-trash' is non-nil.
-
-When called interactively, TRASH is t if no prefix argument is given.
-With a prefix argument, TRASH is nil. */)
- (Lisp_Object filename, Lisp_Object trash)
+DEFUN ("delete-file-internal", Fdelete_file_internal, Sdelete_file_internal, 1, 1, 0,
+ doc: /* Delete file named FILENAME; internal use only.
+If it is a symlink, remove the symlink.
+If file has multiple names, it continues to exist with the other names. */)
+ (Lisp_Object filename)
{
- Lisp_Object handler;
Lisp_Object encoded_file;
- if (!NILP (Ffile_directory_p (filename))
- && NILP (Ffile_symlink_p (filename)))
- xsignal2 (Qfile_error,
- build_string ("Removing old name: is a directory"),
- filename);
+ CHECK_STRING (filename);
filename = Fexpand_file_name (filename, Qnil);
-
- handler = Ffind_file_name_handler (filename, Qdelete_file);
- if (!NILP (handler))
- return call3 (handler, Qdelete_file, filename, trash);
-
- if (delete_by_moving_to_trash && !NILP (trash))
- return call1 (Qmove_file_to_trash, filename);
-
encoded_file = ENCODE_FILE (filename);
- if (unlink (SSDATA (encoded_file)) != 0 && errno != ENOENT)
+ if (emacs_unlink (SSDATA (encoded_file)) != 0
+ && errno != ENOENT)
report_file_error ("Removing old name", filename);
return Qnil;
}
@@ -2516,7 +2628,7 @@ internal_delete_file (Lisp_Object filename)
{
Lisp_Object tem;
- tem = internal_condition_case_2 (Fdelete_file, filename, Qnil,
+ tem = internal_condition_case_1 (Fdelete_file_internal, filename,
Qt, internal_delete_file_1);
return NILP (tem);
}
@@ -2524,7 +2636,7 @@ internal_delete_file (Lisp_Object filename)
#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. */
+ and 1 if the result cannot be determined. */
static int
file_name_case_insensitive_err (Lisp_Object file)
@@ -2558,7 +2670,7 @@ file_name_case_insensitive_err (Lisp_Object file)
return - (res == 0);
# endif
if (errno != EINVAL)
- return errno;
+ return 1;
#endif
#if defined CYGWIN || defined DOS_NT
@@ -2658,8 +2770,10 @@ This is what happens in interactive use with M-x. */)
int rename_errno UNINIT;
if (!plain_rename)
{
- if (renameat_noreplace (AT_FDCWD, SSDATA (encoded_file),
- AT_FDCWD, SSDATA (encoded_newname))
+ if (emacs_renameat_noreplace (AT_FDCWD,
+ SSDATA (encoded_file),
+ AT_FDCWD,
+ SSDATA (encoded_newname))
== 0)
return Qnil;
@@ -2681,7 +2795,8 @@ This is what happens in interactive use with M-x. */)
if (plain_rename)
{
- if (rename (SSDATA (encoded_file), SSDATA (encoded_newname)) == 0)
+ if (emacs_rename (SSDATA (encoded_file),
+ SSDATA (encoded_newname)) == 0)
return Qnil;
rename_errno = errno;
/* Don't prompt again. */
@@ -2705,38 +2820,26 @@ This is what happens in interactive use with M-x. */)
}
if (dirp)
call4 (Qcopy_directory, file, newname, Qt, Qnil);
- else
- {
- Lisp_Object symlink_target
- = (S_ISLNK (file_st.st_mode)
- ? check_emacs_readlinkat (AT_FDCWD, file, SSDATA (encoded_file))
- : Qnil);
- if (!NILP (symlink_target))
- Fmake_symbolic_link (symlink_target, newname, ok_if_already_exists);
- else if (S_ISFIFO (file_st.st_mode))
- {
- /* If it's a FIFO, calling `copy-file' will hang if it's a
- inter-file system move, so do it here. (It will signal
- an error in that case, but it won't hang in any case.) */
- if (!NILP (ok_if_already_exists))
- barf_or_query_if_file_exists (newname, false,
- "rename to it",
- FIXNUMP (ok_if_already_exists),
- false);
- if (rename (SSDATA (encoded_file), SSDATA (encoded_newname)) != 0)
- report_file_errno ("Renaming", list2 (file, newname), errno);
- return Qnil;
- }
+ else if (S_ISREG (file_st.st_mode))
+ Fcopy_file (file, newname, ok_if_already_exists, Qt, Qt, Qt);
+ else if (S_ISLNK (file_st.st_mode))
+ {
+ Lisp_Object target = emacs_readlinkat (AT_FDCWD,
+ SSDATA (encoded_file));
+ if (!NILP (target))
+ Fmake_symbolic_link (target, newname, ok_if_already_exists);
else
- Fcopy_file (file, newname, ok_if_already_exists, Qt, Qt, Qt);
+ report_file_error ("Renaming", list2 (file, newname));
}
+ else
+ report_file_errno ("Renaming", list2 (file, newname), rename_errno);
specpdl_ref count = SPECPDL_INDEX ();
specbind (Qdelete_by_moving_to_trash, Qnil);
if (dirp)
call2 (Qdelete_directory, file, Qt);
else
- Fdelete_file (file, Qnil);
+ call2 (Qdelete_file, file, Qnil);
return unbind_to (count, Qnil);
}
@@ -2774,6 +2877,10 @@ This is what happens in interactive use with M-x. */)
encoded_file = ENCODE_FILE (file);
encoded_newname = ENCODE_FILE (newname);
+ check_vfs_filename (encoded_file, "Trying to create hard link to "
+ "file within special directory");
+ check_vfs_filename (encoded_newname, "Trying to create hard link"
+ " within special directory");
if (link (SSDATA (encoded_file), SSDATA (encoded_newname)) == 0)
return Qnil;
@@ -2784,7 +2891,7 @@ This is what happens in interactive use with M-x. */)
|| FIXNUMP (ok_if_already_exists))
barf_or_query_if_file_exists (newname, true, "make it a new name",
FIXNUMP (ok_if_already_exists), false);
- unlink (SSDATA (newname));
+ emacs_unlink (SSDATA (newname));
if (link (SSDATA (encoded_file), SSDATA (encoded_newname)) == 0)
return Qnil;
}
@@ -2828,7 +2935,8 @@ This happens for interactive use with M-x. */)
encoded_target = ENCODE_FILE (target);
encoded_linkname = ENCODE_FILE (linkname);
- if (symlink (SSDATA (encoded_target), SSDATA (encoded_linkname)) == 0)
+ if (emacs_symlink (SSDATA (encoded_target),
+ SSDATA (encoded_linkname)) == 0)
return Qnil;
if (errno == ENOSYS)
@@ -2841,8 +2949,9 @@ This happens for interactive use with M-x. */)
|| FIXNUMP (ok_if_already_exists))
barf_or_query_if_file_exists (linkname, true, "make it a link",
FIXNUMP (ok_if_already_exists), false);
- unlink (SSDATA (encoded_linkname));
- if (symlink (SSDATA (encoded_target), SSDATA (encoded_linkname)) == 0)
+ emacs_unlink (SSDATA (encoded_linkname));
+ if (emacs_symlink (SSDATA (encoded_target),
+ SSDATA (encoded_linkname)) == 0)
return Qnil;
}
@@ -2982,7 +3091,8 @@ If there is no error, returns nil. */)
encoded_filename = ENCODE_FILE (absname);
- if (faccessat (AT_FDCWD, SSDATA (encoded_filename), R_OK, AT_EACCESS) != 0)
+ if (sys_faccessat (AT_FDCWD, SSDATA (encoded_filename), R_OK,
+ AT_EACCESS) != 0)
report_file_error (SSDATA (string), filename);
return Qnil;
@@ -2990,15 +3100,29 @@ If there is no error, returns nil. */)
/* Relative to directory FD, return the symbolic link value of FILENAME.
On failure, return nil (setting errno). */
+
static Lisp_Object
emacs_readlinkat (int fd, char const *filename)
{
- static struct allocator const emacs_norealloc_allocator =
- { xmalloc, NULL, xfree, memory_full };
+ static struct allocator const emacs_norealloc_allocator = {
+ xmalloc,
+ NULL,
+ xfree,
+ memory_full,
+ };
+
Lisp_Object val;
char readlink_buf[1024];
- char *buf = careadlinkat (fd, filename, readlink_buf, sizeof readlink_buf,
- &emacs_norealloc_allocator, readlinkat);
+ char *buf;
+
+ buf = careadlinkat (fd, filename, readlink_buf, sizeof readlink_buf,
+ &emacs_norealloc_allocator,
+#if defined HAVE_ANDROID && !defined ANDROID_STUBIFY
+ android_readlinkat
+#else /* !HAVE_ANDROID || ANDROID_STUBIFY */
+ readlinkat
+#endif /* HAVE_ANDROID && !ANDROID_STUBIFY */
+ );
if (!buf)
return Qnil;
@@ -3084,12 +3208,13 @@ file_directory_p (Lisp_Object file)
{
#ifdef DOS_NT
/* This is cheaper than 'stat'. */
- bool retval = faccessat (AT_FDCWD, SSDATA (file), D_OK, AT_EACCESS) == 0;
+ bool retval = sys_faccessat (AT_FDCWD, SSDATA (file),
+ D_OK, AT_EACCESS) == 0;
if (!retval && errno == EACCES)
errno = ENOTDIR; /* like the non-DOS_NT branch below does */
return retval;
#else
-# ifdef O_PATH
+# if defined O_PATH && !(defined HAVE_ANDROID && !defined ANDROID_STUBIFY)
/* Use O_PATH if available, as it avoids races and EOVERFLOW issues. */
int fd = emacs_openat (AT_FDCWD, SSDATA (file),
O_PATH | O_CLOEXEC | O_DIRECTORY, 0);
@@ -3198,7 +3323,11 @@ file_accessible_directory_p (Lisp_Object file)
There are three exceptions: "", "/", and "//". Leave "" alone,
as it's invalid. Append only "." to the other two exceptions as
"/" and "//" are distinct on some platforms, whereas "/", "///",
- "////", etc. are all equivalent. */
+ "////", etc. are all equivalent.
+
+ Android has a special directory named "/assets". There is no "."
+ directory there, but appending a "/" is sufficient to check
+ whether or not it is a directory. */
if (! len)
dir = data;
else
@@ -3208,6 +3337,7 @@ file_accessible_directory_p (Lisp_Object file)
special cases "/" and "//", and it's a safe optimization
here. After appending '.', append another '/' to work around
a macOS bug (Bug#30350). */
+
static char const appended[] = "/./";
char *buf = SAFE_ALLOCA (len + sizeof appended);
memcpy (buf, data, len);
@@ -3267,6 +3397,9 @@ or if SELinux is disabled, or if Emacs lacks SELinux support. */)
{
Lisp_Object user = Qnil, role = Qnil, type = Qnil, range = Qnil;
Lisp_Object absname = expand_and_dir_to_file (filename);
+#ifdef HAVE_LIBSELINUX
+ const char *file;
+#endif /* HAVE_LIBSELINUX */
/* If the file name has special constructs in it,
call the corresponding file name handler. */
@@ -3275,11 +3408,13 @@ or if SELinux is disabled, or if Emacs lacks SELinux support. */)
if (!NILP (handler))
return call2 (handler, Qfile_selinux_context, absname);
-#if HAVE_LIBSELINUX
- if (is_selinux_enabled ())
+#ifdef HAVE_LIBSELINUX
+ file = SSDATA (ENCODE_FILE (absname));
+
+ if (selinux_enabled_p (file))
{
char *con;
- int conlength = lgetfilecon (SSDATA (ENCODE_FILE (absname)), &con);
+ int conlength = lgetfilecon (file, &con);
if (conlength > 0)
{
context_t context = context_new (con);
@@ -3298,7 +3433,7 @@ or if SELinux is disabled, or if Emacs lacks SELinux support. */)
|| errno == ENOTSUP))
report_file_error ("getting SELinux context", absname);
}
-#endif
+#endif /* HAVE_LIBSELINUX */
return list4 (user, role, type, range);
}
@@ -3324,10 +3459,11 @@ or if Emacs was not compiled with SELinux support. */)
Lisp_Object type = CAR_SAFE (CDR_SAFE (CDR_SAFE (context)));
Lisp_Object range = CAR_SAFE (CDR_SAFE (CDR_SAFE (CDR_SAFE (context))));
char *con;
+ const char *name;
bool fail;
int conlength;
context_t parsed_con;
-#endif
+#endif /* HAVE_LIBSELINUX */
absname = Fexpand_file_name (filename, BVAR (current_buffer, directory));
@@ -3338,11 +3474,13 @@ or if Emacs was not compiled with SELinux support. */)
return call3 (handler, Qset_file_selinux_context, absname, context);
#if HAVE_LIBSELINUX
- if (is_selinux_enabled ())
+ encoded_absname = ENCODE_FILE (absname);
+ name = SSDATA (encoded_absname);
+
+ if (selinux_enabled_p (name))
{
/* Get current file context. */
- encoded_absname = ENCODE_FILE (absname);
- conlength = lgetfilecon (SSDATA (encoded_absname), &con);
+ conlength = lgetfilecon (name, &con);
if (conlength > 0)
{
parsed_con = context_new (con);
@@ -3372,18 +3510,18 @@ or if Emacs was not compiled with SELinux support. */)
fail = (lsetfilecon (SSDATA (encoded_absname),
context_str (parsed_con))
!= 0);
+ context_free (parsed_con);
+ freecon (con);
+
/* See https://debbugs.gnu.org/11245 for ENOTSUP. */
if (fail && errno != ENOTSUP)
report_file_error ("Doing lsetfilecon", absname);
-
- context_free (parsed_con);
- freecon (con);
return fail ? Qnil : Qt;
}
else
report_file_error ("Doing lgetfilecon", absname);
}
-#endif
+#endif /* HAVE_LIBSELINUX */
return Qnil;
}
@@ -3479,10 +3617,10 @@ support. */)
fail = (acl_set_file (SSDATA (encoded_absname), ACL_TYPE_ACCESS,
acl)
!= 0);
+ acl_free (acl);
if (fail && acl_errno_valid (errno))
report_file_error ("Setting ACL", absname);
- acl_free (acl);
return fail ? Qnil : Qt;
}
# endif
@@ -3532,6 +3670,8 @@ Interactively, prompt for FILENAME, and read MODE with
command from GNU Coreutils. */)
(Lisp_Object filename, Lisp_Object mode, Lisp_Object flag)
{
+ Lisp_Object encoded;
+
CHECK_FIXNUM (mode);
int nofollow = symlink_nofollow_flag (flag);
Lisp_Object absname = Fexpand_file_name (filename,
@@ -3543,9 +3683,10 @@ command from GNU Coreutils. */)
if (!NILP (handler))
return call4 (handler, Qset_file_modes, absname, mode, flag);
- char *fname = SSDATA (ENCODE_FILE (absname));
+ encoded = ENCODE_FILE (absname);
+ char *fname = SSDATA (encoded);
mode_t imode = XFIXNUM (mode) & 07777;
- if (fchmodat (AT_FDCWD, fname, imode, nofollow) != 0)
+ if (emacs_fchmodat (AT_FDCWD, fname, imode, nofollow) != 0)
report_file_error ("Doing chmod", absname);
return Qnil;
@@ -3562,7 +3703,9 @@ in the permissions of newly created files will be disabled.
Note that when `write-region' creates a file, it resets the
execute bit, even if the mask set by this function allows that bit
-by having the corresponding bit in the mask reset. */)
+by having the corresponding bit in the mask reset.
+
+See also `with-file-modes'. */)
(Lisp_Object mode)
{
mode_t oldrealmask, oldumask, newumask;
@@ -3615,6 +3758,8 @@ TIMESTAMP is in the format of `current-time'. */)
return call4 (handler, Qset_file_times, absname, timestamp, flag);
Lisp_Object encoded_absname = ENCODE_FILE (absname);
+ check_vfs_filename (encoded_absname, "Trying to set access times of"
+ " file within special directory");
if (utimensat (AT_FDCWD, SSDATA (encoded_absname), ts, nofollow) != 0)
{
@@ -3647,6 +3792,7 @@ otherwise, if FILE2 does not exist, the answer is t. */)
(Lisp_Object file1, Lisp_Object file2)
{
struct stat st1, st2;
+ Lisp_Object encoded;
CHECK_STRING (file1);
CHECK_STRING (file2);
@@ -3663,8 +3809,10 @@ otherwise, if FILE2 does not exist, the answer is t. */)
if (!NILP (handler))
return call3 (handler, Qfile_newer_than_file_p, absname1, absname2);
+ encoded = ENCODE_FILE (absname1);
+
int err1;
- if (emacs_fstatat (AT_FDCWD, SSDATA (ENCODE_FILE (absname1)), &st1, 0) == 0)
+ if (emacs_fstatat (AT_FDCWD, SSDATA (encoded), &st1, 0) == 0)
err1 = 0;
else
{
@@ -3753,7 +3901,7 @@ union read_non_regular
{
struct
{
- int fd;
+ emacs_fd fd;
ptrdiff_t inserted, trytry;
} s;
GCALIGNED_UNION_MEMBER
@@ -3764,11 +3912,12 @@ static Lisp_Object
read_non_regular (Lisp_Object state)
{
union read_non_regular *data = XFIXNUMPTR (state);
- int nbytes = emacs_read_quit (data->s.fd,
- ((char *) BEG_ADDR + PT_BYTE - BEG_BYTE
- + data->s.inserted),
- data->s.trytry);
- return make_fixnum (nbytes);
+ intmax_t nbytes
+ = emacs_fd_read (data->s.fd,
+ ((char *) BEG_ADDR + PT_BYTE - BEG_BYTE
+ + data->s.inserted),
+ data->s.trytry);
+ return make_int (nbytes);
}
@@ -3896,15 +4045,22 @@ characters in the buffer. If VISIT is non-nil, BEG and END must be nil.
When inserting data from a special file (e.g., /dev/urandom), you
can't specify VISIT or BEG, and END should be specified to avoid
-inserting unlimited data into the buffer.
-
-If optional fifth argument REPLACE is non-nil, replace the current
-buffer contents (in the accessible portion) with the file contents.
-This is better than simply deleting and inserting the whole thing
-because (1) it preserves some marker positions (in unchanged portions
-at the start and end of the buffer) and (2) it puts less data in the
-undo list. When REPLACE is non-nil, the second return value is the
-number of characters that replace previous buffer contents.
+inserting unlimited data into the buffer from some special files
+which otherwise could supply infinite amounts of data.
+
+If optional fifth argument REPLACE is non-nil and FILENAME names a
+regular file, replace the current buffer contents (in the accessible
+portion) with the file's contents. This is better than simply
+deleting and inserting the whole thing because (1) it preserves some
+marker positions (in unchanged portions at the start and end of the
+buffer) and (2) it puts less data in the undo list. When REPLACE is
+non-nil, the second element of the return value is the number of
+characters that replace the previous buffer contents.
+
+If FILENAME is not a regular file and REPLACE is `if-regular', erase
+the accessible portion of the buffer and insert the new contents. Any
+other non-nil value of REPLACE will signal an error if FILENAME is not
+a regular file.
This function does code conversion according to the value of
`coding-system-for-read' or `file-coding-system-alist', and sets the
@@ -3912,14 +4068,13 @@ variable `last-coding-system-used' to the coding system actually used.
In addition, this function decodes the inserted text from known formats
by calling `format-decode', which see. */)
- (Lisp_Object filename, Lisp_Object visit, Lisp_Object beg, Lisp_Object end, Lisp_Object replace)
+ (Lisp_Object filename, Lisp_Object visit, Lisp_Object beg, Lisp_Object end,
+ Lisp_Object replace)
{
struct stat st;
struct timespec mtime;
- int fd;
+ emacs_fd fd;
ptrdiff_t inserted = 0;
- ptrdiff_t how_much;
- off_t beg_offset, end_offset;
int unprocessed;
specpdl_ref count = SPECPDL_INDEX ();
Lisp_Object handler, val, insval, orig_filename, old_undo;
@@ -3932,7 +4087,8 @@ by calling `format-decode', which see. */)
bool replace_handled = false;
bool set_coding_system = false;
Lisp_Object coding_system;
- bool read_quit = false;
+ /* Negative if read error, 0 if OK so far, positive if quit. */
+ ptrdiff_t read_quit = 0;
/* If the undo log only contains the insertion, there's no point
keeping it. It's typically when we first fill a file-buffer. */
bool empty_undo_list_p
@@ -3981,11 +4137,22 @@ by calling `format-decode', which see. */)
goto handled;
}
+ if (!NILP (visit))
+ {
+ if (!NILP (beg) || !NILP (end))
+ error ("Attempt to visit less than an entire file");
+ if (BEG < Z && NILP (replace))
+ error ("Cannot do file visiting in a non-empty buffer");
+ }
+
+ off_t beg_offset = !NILP (beg) ? file_offset (beg) : 0;
+ off_t end_offset = !NILP (end) ? file_offset (end) : -1;
+
orig_filename = filename;
filename = ENCODE_FILE (filename);
- fd = emacs_open (SSDATA (filename), O_RDONLY, 0);
- if (fd < 0)
+ fd = emacs_fd_open (SSDATA (filename), O_RDONLY, 0);
+ if (!emacs_fd_valid_p (fd))
{
save_errno = errno;
if (NILP (visit))
@@ -4003,7 +4170,7 @@ by calling `format-decode', which see. */)
}
specpdl_ref fd_index = SPECPDL_INDEX ();
- record_unwind_protect_int (close_file_unwind, fd);
+ record_unwind_protect_ptr (close_file_unwind_emacs_fd, &fd);
/* Replacement should preserve point as it preserves markers. */
if (!NILP (replace))
@@ -4013,50 +4180,45 @@ by calling `format-decode', which see. */)
XCAR (XCAR (window_markers)));
}
- if (fstat (fd, &st) != 0)
+ if (emacs_fd_fstat (fd, &st) != 0)
report_file_error ("Input file status", orig_filename);
mtime = get_stat_mtime (&st);
- /* This code will need to be changed in order to work on named
- pipes, and it's probably just not worth it. So we should at
- least signal an error. */
+ /* The REPLACE code will need to be changed in order to work on
+ named pipes, and it's probably just not worth it. So we should
+ at least signal an error. */
+
if (!S_ISREG (st.st_mode))
{
regular = false;
- seekable = lseek (fd, 0, SEEK_CUR) != (off_t) -1;
- if (! NILP (visit))
- {
- eassert (inserted == 0);
- goto notfound;
- }
+ if (!NILP (replace))
+ {
+ if (!EQ (replace, Qif_regular))
+ xsignal2 (Qfile_error,
+ build_string ("not a regular file"), orig_filename);
+ else
+ /* Set REPLACE to Qunbound, indicating that we are trying
+ to replace the buffer contents with that of a
+ non-regular file. */
+ replace = Qunbound;
+ }
- if (!NILP (beg) && !seekable)
+ /* Forbid specifying BEG together with a special file, as per
+ the doc string. */
+
+ if (!NILP (beg))
xsignal2 (Qfile_error,
build_string ("cannot use a start position in a non-seekable file/device"),
orig_filename);
- if (!NILP (replace))
- xsignal2 (Qfile_error,
- build_string ("not a regular file"), orig_filename);
+ /* Now ascertain if this file is seekable, by detecting if
+ seeking leads to -1 being returned. */
+ seekable
+ = emacs_fd_lseek (fd, 0, SEEK_CUR) != (off_t) -1;
}
- if (!NILP (visit))
- {
- if (!NILP (beg) || !NILP (end))
- error ("Attempt to visit less than an entire file");
- if (BEG < Z && NILP (replace))
- error ("Cannot do file visiting in a non-empty buffer");
- }
-
- if (!NILP (beg))
- beg_offset = file_offset (beg);
- else
- beg_offset = 0;
-
- if (!NILP (end))
- end_offset = file_offset (end);
- else
+ if (end_offset < 0)
{
if (!regular)
end_offset = TYPE_MAXIMUM (off_t);
@@ -4117,7 +4279,7 @@ by calling `format-decode', which see. */)
else
{
/* Don't try looking inside a file for a coding system
- specification if it is not seekable. */
+ specification if it is not a regular file. */
if (regular && !NILP (Vset_auto_coding_function))
{
/* Find a coding system specified in the heading two
@@ -4128,17 +4290,17 @@ by calling `format-decode', which see. */)
int nread;
if (st.st_size <= (1024 * 4))
- nread = emacs_read_quit (fd, read_buf, 1024 * 4);
+ nread = emacs_fd_read (fd, read_buf, 1024 * 4);
else
{
- nread = emacs_read_quit (fd, read_buf, 1024);
+ nread = emacs_fd_read (fd, read_buf, 1024);
if (nread == 1024)
{
int ntail;
- if (lseek (fd, - (1024 * 3), SEEK_END) < 0)
+ if (emacs_fd_lseek (fd, st.st_size - 1024 * 3, SEEK_CUR) < 0)
report_file_error ("Setting file position",
orig_filename);
- ntail = emacs_read_quit (fd, read_buf + nread, 1024 * 3);
+ ntail = emacs_fd_read (fd, read_buf + nread, 1024 * 3);
nread = ntail < 0 ? ntail : nread + ntail;
}
}
@@ -4179,7 +4341,7 @@ by calling `format-decode', which see. */)
specpdl_ptr--;
/* Rewind the file for the actual read done later. */
- if (lseek (fd, 0, SEEK_SET) < 0)
+ if (emacs_fd_lseek (fd, 0, SEEK_SET) < 0)
report_file_error ("Setting file position", orig_filename);
}
}
@@ -4225,7 +4387,8 @@ by calling `format-decode', which see. */)
method and hope for the best.
But if we discover the need for conversion, we give up on this method
and let the following if-statement handle the replace job. */
- if (!NILP (replace)
+ if ((!NILP (replace)
+ && !BASE_EQ (replace, Qunbound))
&& BEGV < ZV
&& (NILP (coding_system)
|| ! CODING_REQUIRE_DECODING (&coding)))
@@ -4238,7 +4401,7 @@ by calling `format-decode', which see. */)
if (beg_offset != 0)
{
- if (lseek (fd, beg_offset, SEEK_SET) < 0)
+ if (emacs_fd_lseek (fd, beg_offset, SEEK_SET) < 0)
report_file_error ("Setting file position", orig_filename);
}
@@ -4246,7 +4409,7 @@ by calling `format-decode', which see. */)
match the text at the beginning of the buffer. */
while (true)
{
- int nread = emacs_read_quit (fd, read_buf, sizeof read_buf);
+ int nread = emacs_fd_read (fd, read_buf, sizeof read_buf);
if (nread < 0)
report_file_error ("Read error", orig_filename);
else if (nread == 0)
@@ -4281,7 +4444,7 @@ by calling `format-decode', which see. */)
there's no need to replace anything. */
if (same_at_start - BEGV_BYTE == end_offset - beg_offset)
{
- emacs_close (fd);
+ emacs_fd_close (fd);
clear_unwind_protect (fd_index);
/* Truncate the buffer to the size of the file. */
@@ -4304,14 +4467,14 @@ by calling `format-decode', which see. */)
break;
/* How much can we scan in the next step? */
trial = min (curpos, sizeof read_buf);
- if (lseek (fd, curpos - trial, SEEK_SET) < 0)
+ if (emacs_fd_lseek (fd, curpos - trial, SEEK_SET) < 0)
report_file_error ("Setting file position", orig_filename);
total_read = nread = 0;
while (total_read < trial)
{
- nread = emacs_read_quit (fd, read_buf + total_read,
- trial - total_read);
+ nread = emacs_fd_read (fd, read_buf + total_read,
+ trial - total_read);
if (nread < 0)
report_file_error ("Read error", orig_filename);
else if (nread == 0)
@@ -4412,7 +4575,9 @@ by calling `format-decode', which see. */)
is needed, in a simple way that needs a lot of memory.
The preceding if-statement handles the case of no conversion
in a more optimized way. */
- if (!NILP (replace) && ! replace_handled && BEGV < ZV)
+ if ((!NILP (replace)
+ && !BASE_EQ (replace, Qunbound))
+ && ! replace_handled && BEGV < ZV)
{
ptrdiff_t same_at_start_charpos;
ptrdiff_t inserted_chars;
@@ -4420,7 +4585,7 @@ by calling `format-decode', which see. */)
ptrdiff_t bufpos;
unsigned char *decoded;
ptrdiff_t temp;
- ptrdiff_t this = 0;
+ ptrdiff_t this;
specpdl_ref this_count = SPECPDL_INDEX ();
bool multibyte
= ! NILP (BVAR (current_buffer, enable_multibyte_characters));
@@ -4431,7 +4596,7 @@ by calling `format-decode', which see. */)
/* First read the whole file, performing code conversion into
CONVERSION_BUFFER. */
- if (lseek (fd, beg_offset, SEEK_SET) < 0)
+ if (emacs_fd_lseek (fd, beg_offset, SEEK_SET) < 0)
report_file_error ("Setting file position", orig_filename);
inserted = 0; /* Bytes put into CONVERSION_BUFFER so far. */
@@ -4442,8 +4607,8 @@ by calling `format-decode', which see. */)
/* Read at most READ_BUF_SIZE bytes at a time, to allow
quitting while reading a huge file. */
- this = emacs_read_quit (fd, read_buf + unprocessed,
- READ_BUF_SIZE - unprocessed);
+ this = emacs_fd_read (fd, read_buf + unprocessed,
+ READ_BUF_SIZE - unprocessed);
if (this <= 0)
break;
@@ -4458,7 +4623,7 @@ by calling `format-decode', which see. */)
if (this < 0)
report_file_error ("Read error", orig_filename);
- emacs_close (fd);
+ emacs_fd_close (fd);
clear_unwind_protect (fd_index);
if (unprocessed > 0)
@@ -4597,22 +4762,28 @@ by calling `format-decode', which see. */)
prepare_to_modify_buffer (PT, PT, NULL);
}
+ /* If REPLACE is Qunbound, buffer contents are being replaced with
+ text read from a FIFO or a device. Erase the entire accessible
+ portion of the buffer. */
+
+ if (BASE_EQ (replace, Qunbound))
+ del_range (BEGV, ZV);
+
move_gap_both (PT, PT_BYTE);
- if (GAP_SIZE < total)
- make_gap (total - GAP_SIZE);
- if (beg_offset != 0 || !NILP (replace))
+ /* Ensure the gap is at least one byte larger than needed for the
+ estimated file size, so that in the usual case we read to EOF
+ without reallocating. */
+ if (GAP_SIZE <= total)
+ make_gap (total - GAP_SIZE + 1);
+
+ if (beg_offset != 0 || (!NILP (replace)
+ && !BASE_EQ (replace, Qunbound)))
{
- if (lseek (fd, beg_offset, SEEK_SET) < 0)
+ if (emacs_fd_lseek (fd, beg_offset, SEEK_SET) < 0)
report_file_error ("Setting file position", orig_filename);
}
- /* In the following loop, HOW_MUCH contains the total bytes read so
- far for a regular file, and not changed for a special file. But,
- before exiting the loop, it is set to a negative value if I/O
- error occurs. */
- how_much = 0;
-
/* Total bytes inserted. */
inserted = 0;
@@ -4621,22 +4792,26 @@ by calling `format-decode', which see. */)
{
ptrdiff_t gap_size = GAP_SIZE;
- while (how_much < total)
+ while (NILP (end) || inserted < total)
{
- /* `try' is reserved in some compilers (Microsoft C). */
- ptrdiff_t trytry = min (total - how_much, READ_BUF_SIZE);
ptrdiff_t this;
+ if (gap_size == 0)
+ {
+ /* The size estimate was wrong. Make the gap 50% larger. */
+ make_gap (GAP_SIZE >> 1);
+ gap_size = GAP_SIZE - inserted;
+ }
+
+ /* 'try' is reserved in some compilers (Microsoft C). */
+ ptrdiff_t trytry = min (gap_size, READ_BUF_SIZE);
+ if (seekable || !NILP (end))
+ trytry = min (trytry, total - inserted);
+
if (!seekable && NILP (end))
{
Lisp_Object nbytes;
-
- /* Maybe make more room. */
- if (gap_size < trytry)
- {
- make_gap (trytry - gap_size);
- gap_size = GAP_SIZE - inserted;
- }
+ intmax_t number;
/* Read from the file, capturing `quit'. When an
error occurs, end the loop, and arrange for a quit
@@ -4648,38 +4823,32 @@ by calling `format-decode', which see. */)
if (NILP (nbytes))
{
- read_quit = true;
+ read_quit = 1;
break;
}
- this = XFIXNUM (nbytes);
+ if (!integer_to_intmax (nbytes, &number)
+ && number > PTRDIFF_MAX)
+ buffer_overflow ();
+
+ this = number;
}
else
- {
- /* Allow quitting out of the actual I/O. We don't make text
- part of the buffer until all the reading is done, so a C-g
- here doesn't do any harm. */
- this = emacs_read_quit (fd,
- ((char *) BEG_ADDR + PT_BYTE - BEG_BYTE
- + inserted),
- trytry);
- }
+ /* Allow quitting out of the actual I/O. We don't make text
+ part of the buffer until all the reading is done, so a
+ C-g here doesn't do any harm. */
+ this = emacs_fd_read (fd,
+ ((char *) BEG_ADDR + PT_BYTE - BEG_BYTE
+ + inserted),
+ trytry);
if (this <= 0)
{
- how_much = this;
+ read_quit = this;
break;
}
gap_size -= this;
-
- /* For a regular file, where TOTAL is the real size,
- count HOW_MUCH to compare with it.
- For a special file, where TOTAL is just a buffer size,
- so don't bother counting in HOW_MUCH.
- (INSERTED is where we count the number of characters inserted.) */
- if (seekable || !NILP (end))
- how_much += this;
inserted += this;
}
}
@@ -4697,10 +4866,10 @@ by calling `format-decode', which see. */)
else
Fset (Qdeactivate_mark, Qt);
- emacs_close (fd);
+ emacs_fd_close (fd);
clear_unwind_protect (fd_index);
- if (how_much < 0)
+ if (read_quit < 0)
report_file_error ("Read error", orig_filename);
notfound:
@@ -4856,9 +5025,14 @@ by calling `format-decode', which see. */)
Funlock_file (BVAR (current_buffer, file_truename));
Funlock_file (filename);
}
+
+#if !defined HAVE_ANDROID || defined ANDROID_STUBIFY
+ /* Under Android, modtime and st.st_size can be valid even if FD
+ is not a regular file. */
if (!regular)
xsignal2 (Qfile_error,
build_string ("not a regular file"), orig_filename);
+#endif /* !defined HAVE_ANDROID || defined ANDROID_STUBIFY */
}
if (set_coding_system)
@@ -4876,8 +5050,10 @@ by calling `format-decode', which see. */)
}
}
- /* Decode file format. */
- if (inserted > 0)
+ /* Decode file format. Don't do this if Qformat_decode is not
+ bound, which can happen when called early during loadup. */
+
+ if (inserted > 0 && !NILP (Ffboundp (Qformat_decode)))
{
/* Don't run point motion or modification hooks when decoding. */
specpdl_ref count1 = SPECPDL_INDEX ();
@@ -5322,6 +5498,7 @@ write_region (Lisp_Object start, Lisp_Object end, Lisp_Object filename,
}
encoded_filename = ENCODE_FILE (filename);
+
fn = SSDATA (encoded_filename);
open_flags = O_WRONLY | O_CREAT;
open_flags |= EQ (mustbenew, Qexcl) ? O_EXCL : !NILP (append) ? 0 : O_TRUNC;
@@ -5408,7 +5585,7 @@ write_region (Lisp_Object start, Lisp_Object end, Lisp_Object filename,
modtime = invalid_timespec ();
if (visiting)
{
- if (fstat (desc, &st) == 0)
+ if (sys_fstat (desc, &st) == 0)
modtime = get_stat_mtime (&st);
else
ok = 0, save_errno = errno;
@@ -5442,42 +5619,52 @@ write_region (Lisp_Object start, Lisp_Object end, Lisp_Object filename,
if (timespec_valid_p (modtime)
&& ! (valid_timestamp_file_system && st.st_dev == timestamp_file_system))
{
- int desc1 = emacs_open (fn, O_WRONLY, 0);
- if (desc1 >= 0)
+ struct stat st1;
+
+ /* The code below previously tried to open FN O_WRONLY,
+ subsequently calling fstat on the opened file descriptor.
+ This proved inefficient and resulted in FN being truncated
+ under several Android filesystems, and as such has been
+ changed to a call to `stat'. */
+
+ if (emacs_fstatat (AT_FDCWD, fn, &st1, 0) == 0
+ && st.st_dev == st1.st_dev
+ && (st.st_ino == st1.st_ino
+#if defined HAVE_ANDROID && !defined ANDROID_STUBIFY
+ /* `st1.st_ino' == 0 indicates that the inode number
+ cannot be extracted from this document file, despite
+ `st' potentially being backed by a real file. */
+ || st1.st_ino == 0
+#endif /* defined HAVE_ANDROID && !defined ANDROID_STUBIFY */
+ ))
{
- struct stat st1;
- if (fstat (desc1, &st1) == 0
- && st.st_dev == st1.st_dev && st.st_ino == st1.st_ino)
+ /* Use the heuristic if it appears to be valid. With neither
+ O_EXCL nor O_TRUNC, if Emacs happened to write nothing to the
+ file, the time stamp won't change. Also, some non-POSIX
+ systems don't update an empty file's time stamp when
+ truncating it. Finally, file systems with 100 ns or worse
+ resolution sometimes seem to have bugs: on a system with ns
+ resolution, checking ns % 100 incorrectly avoids the heuristic
+ 1% of the time, but the problem should be temporary as we will
+ try again on the next time stamp. */
+ bool use_heuristic
+ = ((open_flags & (O_EXCL | O_TRUNC)) != 0
+ && st.st_size != 0
+ && modtime.tv_nsec % 100 != 0);
+
+ struct timespec modtime1 = get_stat_mtime (&st1);
+ if (use_heuristic
+ && timespec_cmp (modtime, modtime1) == 0
+ && st.st_size == st1.st_size)
{
- /* Use the heuristic if it appears to be valid. With neither
- O_EXCL nor O_TRUNC, if Emacs happened to write nothing to the
- file, the time stamp won't change. Also, some non-POSIX
- systems don't update an empty file's time stamp when
- truncating it. Finally, file systems with 100 ns or worse
- resolution sometimes seem to have bugs: on a system with ns
- resolution, checking ns % 100 incorrectly avoids the heuristic
- 1% of the time, but the problem should be temporary as we will
- try again on the next time stamp. */
- bool use_heuristic
- = ((open_flags & (O_EXCL | O_TRUNC)) != 0
- && st.st_size != 0
- && modtime.tv_nsec % 100 != 0);
-
- struct timespec modtime1 = get_stat_mtime (&st1);
- if (use_heuristic
- && timespec_cmp (modtime, modtime1) == 0
- && st.st_size == st1.st_size)
- {
- timestamp_file_system = st.st_dev;
- valid_timestamp_file_system = 1;
- }
- else
- {
- st.st_size = st1.st_size;
- modtime = modtime1;
- }
+ timestamp_file_system = st.st_dev;
+ valid_timestamp_file_system = 1;
+ }
+ else
+ {
+ st.st_size = st1.st_size;
+ modtime = modtime1;
}
- emacs_close (desc1);
}
}
@@ -5823,7 +6010,6 @@ See Info node `(elisp)Modification Time' for more details. */)
return call2 (handler, Qverify_visited_file_modtime, buf);
filename = ENCODE_FILE (BVAR (b, filename));
-
mtime = (emacs_fstatat (AT_FDCWD, SSDATA (filename), &st, 0) == 0
? get_stat_mtime (&st)
: time_error_value (errno));
@@ -5883,7 +6069,7 @@ in `current-time' or an integer flag as returned by `visited-file-modtime'. */)
error ("An indirect buffer does not have a visited file");
else
{
- register Lisp_Object filename;
+ register Lisp_Object filename, encoded;
struct stat st;
Lisp_Object handler;
@@ -5896,7 +6082,9 @@ in `current-time' or an integer flag as returned by `visited-file-modtime'. */)
/* The handler can find the file name the same way we did. */
return call2 (handler, Qset_visited_file_modtime, Qnil);
- if (emacs_fstatat (AT_FDCWD, SSDATA (ENCODE_FILE (filename)), &st, 0)
+ encoded = ENCODE_FILE (filename);
+
+ if (emacs_fstatat (AT_FDCWD, SSDATA (encoded), &st, 0)
== 0)
{
current_buffer->modtime = get_stat_mtime (&st);
@@ -5969,7 +6157,7 @@ do_auto_save_unwind (void *arg)
if (stream != NULL)
{
block_input ();
- fclose (stream);
+ emacs_fclose (stream);
unblock_input ();
}
}
@@ -6295,13 +6483,18 @@ effect except for flushing STREAM's data. */)
#ifndef DOS_NT
+#if defined STAT_STATFS2_BSIZE || defined STAT_STATFS2_FRSIZE \
+ || defined STAT_STATFS2_FSIZE || defined STAT_STATFS3_OSF1 \
+ || defined STAT_STATFS4 || defined STAT_STATVFS \
+ || defined STAT_STATVFS64
+
/* Yield a Lisp number equal to BLOCKSIZE * BLOCKS, with the result
negated if NEGATE. */
static Lisp_Object
blocks_to_bytes (uintmax_t blocksize, uintmax_t blocks, bool negate)
{
intmax_t n;
- if (!INT_MULTIPLY_WRAPV (blocksize, blocks, &n))
+ if (!ckd_mul (&n, blocksize, blocks))
return make_int (negate ? -n : n);
Lisp_Object bs = make_uint (blocksize);
if (negate)
@@ -6309,6 +6502,8 @@ blocks_to_bytes (uintmax_t blocksize, uintmax_t blocks, bool negate)
return CALLN (Ftimes, bs, make_uint (blocks));
}
+#endif
+
DEFUN ("file-system-info", Ffile_system_info, Sfile_system_info, 1, 1, 0,
doc: /* Return storage information about the file system FILENAME is on.
Value is a list of numbers (TOTAL FREE AVAIL), where TOTAL is the total
@@ -6330,6 +6525,11 @@ If the underlying system call fails, value is nil. */)
error ("Invalid handler in `file-name-handler-alist'");
}
+ /* Try to detect whether or not fsusage.o is actually built. */
+#if defined STAT_STATFS2_BSIZE || defined STAT_STATFS2_FRSIZE \
+ || defined STAT_STATFS2_FSIZE || defined STAT_STATFS3_OSF1 \
+ || defined STAT_STATFS4 || defined STAT_STATVFS \
+ || defined STAT_STATVFS64
struct fs_usage u;
if (get_fs_usage (SSDATA (ENCODE_FILE (filename)), NULL, &u) != 0)
return errno == ENOSYS ? Qnil : file_attribute_errno (filename, errno);
@@ -6337,6 +6537,9 @@ If the underlying system call fails, value is nil. */)
blocks_to_bytes (u.fsu_blocksize, u.fsu_bfree, false),
blocks_to_bytes (u.fsu_blocksize, u.fsu_bavail,
u.fsu_bavail_top_bit_set));
+#else
+ return Qnil;
+#endif
}
#endif /* !DOS_NT */
@@ -6348,24 +6551,6 @@ init_fileio (void)
umask (realmask);
valid_timestamp_file_system = 0;
-
- /* fsync can be a significant performance hit. Often it doesn't
- suffice to make the file-save operation survive a crash. For
- batch scripts, which are typically part of larger shell commands
- that don't fsync other files, its effect on performance can be
- significant so its utility is particularly questionable.
- Hence, for now by default fsync is used only when interactive.
-
- For more on why fsync often fails to work on today's hardware, see:
- Zheng M et al. Understanding the robustness of SSDs under power fault.
- 11th USENIX Conf. on File and Storage Technologies, 2013 (FAST '13), 271-84
- https://www.usenix.org/system/files/conference/fast13/fast13-final80.pdf
-
- For more on why fsync does not suffice even if it works properly, see:
- Roche X. Necessary step(s) to synchronize filename operations on disk.
- Austin Group Defect 672, 2013-03-19
- https://austingroupbugs.net/view.php?id=672 */
- write_region_inhibit_fsync = noninteractive;
}
void
@@ -6385,7 +6570,7 @@ syms_of_fileio (void)
DEFSYM (Qcopy_file, "copy-file");
DEFSYM (Qmake_directory_internal, "make-directory-internal");
DEFSYM (Qmake_directory, "make-directory");
- DEFSYM (Qdelete_file, "delete-file");
+ DEFSYM (Qdelete_file_internal, "delete-file-internal");
DEFSYM (Qfile_name_case_insensitive_p, "file-name-case-insensitive-p");
DEFSYM (Qrename_file, "rename-file");
DEFSYM (Qadd_name_to_file, "add-name-to-file");
@@ -6623,9 +6808,22 @@ file is usually more useful if it contains the deleted text. */);
DEFVAR_BOOL ("write-region-inhibit-fsync", write_region_inhibit_fsync,
doc: /* Non-nil means don't call fsync in `write-region'.
This variable affects calls to `write-region' as well as save commands.
-Setting this to nil may avoid data loss if the system loses power or
-the operating system crashes. By default, it is non-nil in batch mode. */);
- write_region_inhibit_fsync = 0; /* See also `init_fileio' above. */
+By default, it is non-nil.
+
+Although setting this to nil may avoid data loss if the system loses power,
+it can be a significant performance hit in the usual case, and it doesn't
+necessarily cause file-save operations to actually survive a crash. */);
+
+ /* For more on why fsync often fails to work on today's hardware, see:
+ Zheng M et al. Understanding the robustness of SSDs under power fault.
+ 11th USENIX Conf. on File and Storage Technologies, 2013 (FAST '13), 271-84
+ https://www.usenix.org/system/files/conference/fast13/fast13-final80.pdf
+
+ For more on why fsync does not suffice even if it works properly, see:
+ Roche X. Necessary step(s) to synchronize filename operations on disk.
+ Austin Group Defect 672, 2013-03-19
+ https://austingroupbugs.net/view.php?id=672 */
+ write_region_inhibit_fsync = true;
DEFVAR_BOOL ("delete-by-moving-to-trash", delete_by_moving_to_trash,
doc: /* Specifies whether to use the system's trash can.
@@ -6636,8 +6834,8 @@ This includes interactive calls to `delete-file' and
delete_by_moving_to_trash = 0;
DEFSYM (Qdelete_by_moving_to_trash, "delete-by-moving-to-trash");
- /* Lisp function for moving files to trash. */
- DEFSYM (Qmove_file_to_trash, "move-file-to-trash");
+ /* Lisp function for interactive file delete with trashing */
+ DEFSYM (Qdelete_file, "delete-file");
/* Lisp function for recursively copying directories. */
DEFSYM (Qcopy_directory, "copy-directory");
@@ -6667,7 +6865,7 @@ This includes interactive calls to `delete-file' and
defsubr (&Scopy_file);
defsubr (&Smake_directory_internal);
defsubr (&Sdelete_directory_internal);
- defsubr (&Sdelete_file);
+ defsubr (&Sdelete_file_internal);
defsubr (&Sfile_name_case_insensitive_p);
defsubr (&Srename_file);
defsubr (&Sadd_name_to_file);
@@ -6709,9 +6907,11 @@ This includes interactive calls to `delete-file' and
#ifndef DOS_NT
defsubr (&Sfile_system_info);
-#endif
+#endif /* DOS_NT */
#ifdef HAVE_SYNC
defsubr (&Sunix_sync);
-#endif
+#endif /* HAVE_SYNC */
+
+ DEFSYM (Qif_regular, "if-regular");
}
diff --git a/src/filelock.c b/src/filelock.c
index 7acee1f8ddd..8c27b226900 100644
--- a/src/filelock.c
+++ b/src/filelock.c
@@ -36,13 +36,9 @@ along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. */
#include <sys/file.h>
#include <fcntl.h>
#include <unistd.h>
-
-#ifdef __FreeBSD__
-#include <sys/sysctl.h>
-#endif /* __FreeBSD__ */
-
#include <errno.h>
+#include <boot-time.h>
#include <c-ctype.h>
#include "lisp.h"
@@ -55,19 +51,9 @@ along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. */
#ifndef MSDOS
-#ifdef HAVE_UTMP_H
-#include <utmp.h>
-#endif
-
-/* A file whose last-modified time is just after the most recent boot.
- Define this to be NULL to disable checking for this file. */
-#ifndef BOOT_TIME_FILE
-#define BOOT_TIME_FILE "/var/run/random-seed"
-#endif
-
-#if !defined WTMP_FILE && !defined WINDOWSNT && defined BOOT_TIME
-#define WTMP_FILE "/var/log/wtmp"
-#endif
+#ifdef HAVE_ANDROID
+#include "android.h" /* For `android_is_special_directory'. */
+#endif /* HAVE_ANDROID */
/* Normally use a symbolic link to represent a lock.
The strategy: to lock a file FN, create a symlink .#FN in FN's
@@ -121,157 +107,22 @@ along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. */
hard nor symbolic links. */
-/* Return the time of the last system boot. */
-
-static time_t boot_time;
-static bool boot_time_initialized;
-
-#ifdef BOOT_TIME
-static void get_boot_time_1 (const char *, bool);
-#endif
+/* Return the time of the last system boot, or 0 if that information
+ is unavailable. */
static time_t
-get_boot_time (void)
+get_boot_sec (void)
{
-#if defined (BOOT_TIME)
- int counter;
-#endif
-
- if (boot_time_initialized)
- return boot_time;
- boot_time_initialized = 1;
-
-#if defined (CTL_KERN) && defined (KERN_BOOTTIME)
- {
- int mib[2];
- size_t size;
- struct timeval boottime_val;
-
- mib[0] = CTL_KERN;
- mib[1] = KERN_BOOTTIME;
- size = sizeof (boottime_val);
-
- if (sysctl (mib, 2, &boottime_val, &size, NULL, 0) >= 0 && size != 0)
- {
- boot_time = boottime_val.tv_sec;
- return boot_time;
- }
- }
-#endif /* defined (CTL_KERN) && defined (KERN_BOOTTIME) */
-
- if (BOOT_TIME_FILE)
- {
- struct stat st;
- if (stat (BOOT_TIME_FILE, &st) == 0)
- {
- boot_time = st.st_mtime;
- return boot_time;
- }
- }
-
-#if defined (BOOT_TIME)
- /* The utmp routines maintain static state. Don't touch that state
+ /* get_boot_time maintains static state. Don't touch that state
if we are going to dump, since it might not survive dumping. */
if (will_dump_p ())
- return boot_time;
-
- /* Try to get boot time from utmp before wtmp,
- since utmp is typically much smaller than wtmp.
- Passing a null pointer causes get_boot_time_1
- to inspect the default file, namely utmp. */
- get_boot_time_1 (0, 0);
- if (boot_time)
- return boot_time;
-
- /* Try to get boot time from the current wtmp file. */
- get_boot_time_1 (WTMP_FILE, 1);
-
- /* If we did not find a boot time in wtmp, look at wtmp, and so on. */
- for (counter = 0; counter < 20 && ! boot_time; counter++)
- {
- Lisp_Object filename = Qnil;
- bool delete_flag = false;
- char cmd_string[sizeof WTMP_FILE ".19.gz"];
- AUTO_STRING_WITH_LEN (tempname, cmd_string,
- sprintf (cmd_string, "%s.%d", WTMP_FILE, counter));
- if (! NILP (Ffile_exists_p (tempname)))
- filename = tempname;
- else
- {
- tempname = make_formatted_string (cmd_string, "%s.%d.gz",
- WTMP_FILE, counter);
- if (! NILP (Ffile_exists_p (tempname)))
- {
- /* The utmp functions on older systems accept only file
- names up to 8 bytes long. Choose a 2 byte prefix, so
- the 6-byte suffix does not make the name too long. */
- filename = Fmake_temp_file_internal (build_string ("wt"), Qnil,
- empty_unibyte_string, Qnil);
- CALLN (Fcall_process, build_string ("gzip"), Qnil,
- list2 (QCfile, filename), Qnil,
- build_string ("-cd"), tempname);
- delete_flag = true;
- }
- }
-
- if (! NILP (filename))
- {
- get_boot_time_1 (SSDATA (filename), 1);
- if (delete_flag)
- unlink (SSDATA (filename));
- }
- }
-
- return boot_time;
-#else
- return 0;
-#endif
-}
-
-#ifdef BOOT_TIME
-/* Try to get the boot time from wtmp file FILENAME.
- This succeeds if that file contains a reboot record.
-
- If FILENAME is zero, use the same file as before;
- if no FILENAME has ever been specified, this is the utmp file.
- Use the newest reboot record if NEWEST,
- the first reboot record otherwise.
- Ignore all reboot records on or before BOOT_TIME.
- Success is indicated by setting BOOT_TIME to a larger value. */
-
-void
-get_boot_time_1 (const char *filename, bool newest)
-{
- struct utmp ut, *utp;
-
- if (filename)
- utmpname (filename);
-
- setutent ();
+ return 0;
- while (1)
- {
- /* Find the next reboot record. */
- ut.ut_type = BOOT_TIME;
- utp = getutid (&ut);
- if (! utp)
- break;
- /* Compare reboot times and use the newest one. */
- if (utp->ut_time > boot_time)
- {
- boot_time = utp->ut_time;
- if (! newest)
- break;
- }
- /* Advance on element in the file
- so that getutid won't repeat the same one. */
- utp = getutent ();
- if (! utp)
- break;
- }
- endutent ();
+ struct timespec boot_time;
+ boot_time.tv_sec = 0;
+ get_boot_time (&boot_time);
+ return boot_time.tv_sec;
}
-#endif /* BOOT_TIME */
/* An arbitrary limit on lock contents length. 8 K should be plenty
big enough in practice. */
@@ -313,11 +164,12 @@ rename_lock_file (char const *old, char const *new, bool force)
{
struct stat st;
- int r = renameat_noreplace (AT_FDCWD, old, AT_FDCWD, new);
+ int r = emacs_renameat_noreplace (AT_FDCWD, old,
+ AT_FDCWD, new);
if (! (r < 0 && errno == ENOSYS))
return r;
if (link (old, new) == 0)
- return unlink (old) == 0 || errno == ENOENT ? 0 : -1;
+ return emacs_unlink (old) == 0 || errno == ENOENT ? 0 : -1;
if (errno != ENOSYS && errno != LINKS_MIGHT_NOT_WORK)
return -1;
@@ -337,7 +189,7 @@ rename_lock_file (char const *old, char const *new, bool force)
return -1;
}
- return rename (old, new);
+ return emacs_rename (old, new);
#endif
}
@@ -355,13 +207,13 @@ create_lock_file (char *lfname, char *lock_info_str, bool force)
pretending that 'symlink' does not work. */
int err = ENOSYS;
#else
- int err = symlink (lock_info_str, lfname) == 0 ? 0 : errno;
+ int err = emacs_symlink (lock_info_str, lfname) == 0 ? 0 : errno;
#endif
if (err == EEXIST && force)
{
- unlink (lfname);
- err = symlink (lock_info_str, lfname) == 0 ? 0 : errno;
+ emacs_unlink (lfname);
+ err = emacs_symlink (lock_info_str, lfname) == 0 ? 0 : errno;
}
if (err == ENOSYS || err == LINKS_MIGHT_NOT_WORK || err == ENAMETOOLONG)
@@ -399,7 +251,7 @@ create_lock_file (char *lfname, char *lock_info_str, bool force)
if (!err && rename_lock_file (nonce, lfname, force) != 0)
err = errno;
if (err)
- unlink (nonce);
+ emacs_unlink (nonce);
}
SAFE_FREE ();
@@ -415,7 +267,7 @@ create_lock_file (char *lfname, char *lock_info_str, bool force)
static int
lock_file_1 (Lisp_Object lfname, bool force)
{
- intmax_t boot = get_boot_time ();
+ intmax_t boot = get_boot_sec ();
Lisp_Object luser_name = Fuser_login_name (Qnil);
Lisp_Object lhost_name = Fsystem_name ();
@@ -431,18 +283,12 @@ lock_file_1 (Lisp_Object lfname, bool force)
char lock_info_str[MAX_LFINFO + 1];
intmax_t pid = getpid ();
- if (boot)
- {
- if (sizeof lock_info_str
- <= snprintf (lock_info_str, sizeof lock_info_str,
- "%s@%s.%"PRIdMAX":%"PRIdMAX,
- user_name, host_name, pid, boot))
- return ENAMETOOLONG;
- }
- else if (sizeof lock_info_str
- <= snprintf (lock_info_str, sizeof lock_info_str,
- "%s@%s.%"PRIdMAX,
- user_name, host_name, pid))
+ char const *lock_info_fmt = (boot
+ ? "%s@%s.%"PRIdMAX":%"PRIdMAX
+ : "%s@%s.%"PRIdMAX);
+ int len = snprintf (lock_info_str, sizeof lock_info_str,
+ lock_info_fmt, user_name, host_name, pid, boot);
+ if (! (0 <= len && len < sizeof lock_info_str))
return ENAMETOOLONG;
return create_lock_file (SSDATA (lfname), lock_info_str, force);
@@ -607,12 +453,12 @@ current_lock_owner (lock_info_type *owner, Lisp_Object lfname)
&& (kill (pid, 0) >= 0 || errno == EPERM)
&& (boot_time == 0
|| (boot_time <= TYPE_MAXIMUM (time_t)
- && within_one_second (boot_time, get_boot_time ()))))
+ && within_one_second (boot_time, get_boot_sec ()))))
return ANOTHER_OWNS_IT;
/* The owner process is dead or has a strange pid, so try to
zap the lockfile. */
else
- return unlink (SSDATA (lfname)) < 0 ? errno : 0;
+ return emacs_unlink (SSDATA (lfname)) < 0 ? errno : 0;
}
else
{ /* If we wanted to support the check for stale locks on remote machines,
@@ -653,8 +499,27 @@ lock_if_free (lock_info_type *clasher, Lisp_Object lfname)
static Lisp_Object
make_lock_file_name (Lisp_Object fn)
{
- Lisp_Object lock_file_name = call1 (Qmake_lock_file_name,
- Fexpand_file_name (fn, Qnil));
+ Lisp_Object lock_file_name;
+#if defined HAVE_ANDROID && !defined ANDROID_STUBIFY
+ char *name;
+#endif
+
+ fn = Fexpand_file_name (fn, Qnil);
+
+#if defined HAVE_ANDROID && !defined ANDROID_STUBIFY
+ /* Files in /assets and /contents can't have lock files on Android
+ as these directories are fabrications of android.c, and backed by
+ read only data. */
+
+ name = SSDATA (fn);
+
+ if (android_is_special_directory (name, "/assets")
+ || android_is_special_directory (name, "/content"))
+ return Qnil;
+#endif /* defined HAVE_ANDROID && !defined ANDROID_STUBIFY */
+
+ lock_file_name = call1 (Qmake_lock_file_name, fn);
+
return !NILP (lock_file_name) ? ENCODE_FILE (lock_file_name) : Qnil;
}
@@ -698,7 +563,7 @@ lock_file (Lisp_Object fn)
/* See if this file is visited and has changed on disk since it was
visited. */
- Lisp_Object subject_buf = get_truename_buffer (fn);
+ Lisp_Object subject_buf = Fget_truename_buffer (fn);
if (!NILP (subject_buf)
&& NILP (Fverify_visited_file_modtime (subject_buf))
&& !NILP (Ffile_exists_p (fn))
@@ -741,7 +606,8 @@ unlock_file (Lisp_Object fn)
int err = current_lock_owner (0, lfname);
if (! (err == 0 || err == ANOTHER_OWNS_IT
|| (err == I_OWN_IT
- && (unlink (SSDATA (lfname)) == 0 || (err = errno) == ENOENT))))
+ && (emacs_unlink (SSDATA (lfname)) == 0
+ || (err = errno) == ENOENT))))
report_file_errno ("Unlocking file", fn, err);
return Qnil;
diff --git a/src/floatfns.c b/src/floatfns.c
index 2eab38803d7..4492815c765 100644
--- a/src/floatfns.c
+++ b/src/floatfns.c
@@ -27,19 +27,22 @@ along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. */
frexp, ldexp, log, log10 [via (log X 10)], *modf, pow, sin, *sinh,
sqrt, tan, *tanh.
- C99 and C11 require the following math.h functions in addition to
+ C99, C11 and C17 require the following math.h functions in addition to
the C89 functions. Of these, Emacs currently exports only the
starred ones to Lisp, since we haven't found a use for the others.
Also, it uses the ones marked "+" internally:
acosh, atanh, cbrt, copysign (implemented by signbit), erf, erfc,
exp2, expm1, fdim, fma, fmax, fmin, fpclassify, hypot, +ilogb,
- isfinite, isgreater, isgreaterequal, isinf, isless, islessequal,
+ +isfinite, isgreater, isgreaterequal, +isinf, isless, islessequal,
islessgreater, *isnan, isnormal, isunordered, lgamma, log1p, *log2
[via (log X 2)], logb (approximately; implemented by frexp),
+lrint/llrint, +lround/llround, nan, nearbyint, nextafter,
nexttoward, remainder, remquo, *rint, round, scalbln, +scalbn,
+signbit, tgamma, *trunc.
+ C23 requires many more math.h functions. Emacs does not yet export
+ or use them.
+
The C standard also requires functions for float and long double
that are not listed above. Of these functions, Emacs uses only the
following internally: fabsf, powf, sprintf.
@@ -52,8 +55,6 @@ along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. */
#include <math.h>
-#include <count-leading-zeros.h>
-
/* Emacs needs proper handling of +/-inf; correct printing as well as
important packages depend on it. Make sure the user didn't specify
-ffinite-math-only, either directly or implicitly with -Ofast or
@@ -301,14 +302,6 @@ DEFUN ("float", Ffloat, Sfloat, 1, 1, 0,
return FLOATP (arg) ? arg : make_float (XFLOATINT (arg));
}
-static int
-ecount_leading_zeros (EMACS_UINT x)
-{
- return (EMACS_UINT_WIDTH == UINT_WIDTH ? count_leading_zeros (x)
- : EMACS_UINT_WIDTH == ULONG_WIDTH ? count_leading_zeros_l (x)
- : count_leading_zeros_ll (x));
-}
-
DEFUN ("logb", Flogb, Slogb, 1, 1, 0,
doc: /* Returns largest integer <= the base 2 log of the magnitude of ARG.
This is the same as the exponent of a float. */)
@@ -335,7 +328,7 @@ This is the same as the exponent of a float. */)
EMACS_INT i = XFIXNUM (arg);
if (i == 0)
return make_float (-HUGE_VAL);
- value = EMACS_UINT_WIDTH - 1 - ecount_leading_zeros (eabs (i));
+ value = elogb (eabs (i));
}
return make_fixnum (value);
diff --git a/src/fns.c b/src/fns.c
index 0a9029503a3..db5e856d5bd 100644
--- a/src/fns.c
+++ b/src/fns.c
@@ -26,6 +26,8 @@ along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. */
#include <intprops.h>
#include <vla.h>
#include <errno.h>
+#include <ctype.h>
+#include <math.h>
#include "lisp.h"
#include "bignum.h"
@@ -140,6 +142,10 @@ efficient. */)
if (STRINGP (sequence))
val = SCHARS (sequence);
+ else if (CONSP (sequence))
+ val = list_length (sequence);
+ else if (NILP (sequence))
+ val = 0;
else if (VECTORP (sequence))
val = ASIZE (sequence);
else if (CHAR_TABLE_P (sequence))
@@ -148,10 +154,6 @@ efficient. */)
val = bool_vector_size (sequence);
else if (COMPILEDP (sequence) || RECORDP (sequence))
val = PVSIZE (sequence);
- else if (CONSP (sequence))
- val = list_length (sequence);
- else if (NILP (sequence))
- val = 0;
else
wrong_type_argument (Qsequencep, sequence);
@@ -439,36 +441,36 @@ If string STR1 is greater, the value is a positive number N;
}
/* Check whether the platform allows access to unaligned addresses for
- size_t integers without trapping or undue penalty (a few cycles is OK).
+ size_t integers without trapping or undue penalty (a few cycles is OK),
+ and that a word-sized memcpy can be used to generate such an access.
This whitelist is incomplete but since it is only used to improve
performance, omitting cases is safe. */
-#if defined __x86_64__|| defined __amd64__ \
- || defined __i386__ || defined __i386 \
- || defined __arm64__ || defined __aarch64__ \
- || defined __powerpc__ || defined __powerpc \
- || defined __ppc__ || defined __ppc \
- || defined __s390__ || defined __s390x__
+#if (defined __x86_64__|| defined __amd64__ \
+ || defined __i386__ || defined __i386 \
+ || defined __arm64__ || defined __aarch64__ \
+ || defined __powerpc__ || defined __powerpc \
+ || defined __ppc__ || defined __ppc \
+ || defined __s390__ || defined __s390x__) \
+ && defined __OPTIMIZE__
#define HAVE_FAST_UNALIGNED_ACCESS 1
#else
#define HAVE_FAST_UNALIGNED_ACCESS 0
#endif
-DEFUN ("string-lessp", Fstring_lessp, Sstring_lessp, 2, 2, 0,
- doc: /* Return non-nil if STRING1 is less than STRING2 in lexicographic order.
-Case is significant.
-Symbols are also allowed; their print names are used instead. */)
- (Lisp_Object string1, Lisp_Object string2)
+/* Load a word from a possibly unaligned address. */
+static inline size_t
+load_unaligned_size_t (const void *p)
{
- if (SYMBOLP (string1))
- string1 = SYMBOL_NAME (string1);
- else
- CHECK_STRING (string1);
- if (SYMBOLP (string2))
- string2 = SYMBOL_NAME (string2);
- else
- CHECK_STRING (string2);
+ size_t x;
+ memcpy (&x, p, sizeof x);
+ return x;
+}
+/* Return -1/0/1 to indicate the relation </=/> between string1 and string2. */
+static int
+string_cmp (Lisp_Object string1, Lisp_Object string2)
+{
ptrdiff_t n = min (SCHARS (string1), SCHARS (string2));
if ((!STRING_MULTIBYTE (string1) || SCHARS (string1) == SBYTES (string1))
@@ -477,7 +479,9 @@ Symbols are also allowed; their print names are used instead. */)
/* Each argument is either unibyte or all-ASCII multibyte:
we can compare bytewise. */
int d = memcmp (SSDATA (string1), SSDATA (string2), n);
- return d < 0 || (d == 0 && n < SCHARS (string2)) ? Qt : Qnil;
+ if (d)
+ return d;
+ return n < SCHARS (string2) ? -1 : n > SCHARS (string2);
}
else if (STRING_MULTIBYTE (string1) && STRING_MULTIBYTE (string2))
{
@@ -497,11 +501,11 @@ Symbols are also allowed; their print names are used instead. */)
if (HAVE_FAST_UNALIGNED_ACCESS)
{
/* First compare entire machine words. */
- typedef size_t word_t;
- int ws = sizeof (word_t);
- const word_t *w1 = (const word_t *) SDATA (string1);
- const word_t *w2 = (const word_t *) SDATA (string2);
- while (b < nb - ws + 1 && w1[b / ws] == w2[b / ws])
+ int ws = sizeof (size_t);
+ const char *w1 = SSDATA (string1);
+ const char *w2 = SSDATA (string2);
+ while (b < nb - ws + 1 && load_unaligned_size_t (w1 + b)
+ == load_unaligned_size_t (w2 + b))
b += ws;
}
@@ -511,7 +515,7 @@ Symbols are also allowed; their print names are used instead. */)
if (b >= nb)
/* One string is a prefix of the other. */
- return b < nb2 ? Qt : Qnil;
+ return b < nb2 ? -1 : b > nb2;
/* Now back up to the start of the differing characters:
it's the last byte not having the bit pattern 10xxxxxx. */
@@ -523,7 +527,7 @@ Symbols are also allowed; their print names are used instead. */)
ptrdiff_t i1_byte = b, i2_byte = b;
int c1 = fetch_string_char_advance_no_check (string1, &i1, &i1_byte);
int c2 = fetch_string_char_advance_no_check (string2, &i2, &i2_byte);
- return c1 < c2 ? Qt : Qnil;
+ return c1 < c2 ? -1 : c1 > c2;
}
else if (STRING_MULTIBYTE (string1))
{
@@ -534,9 +538,9 @@ Symbols are also allowed; their print names are used instead. */)
int c1 = fetch_string_char_advance_no_check (string1, &i1, &i1_byte);
int c2 = SREF (string2, i2++);
if (c1 != c2)
- return c1 < c2 ? Qt : Qnil;
+ return c1 < c2 ? -1 : 1;
}
- return i1 < SCHARS (string2) ? Qt : Qnil;
+ return i1 < SCHARS (string2) ? -1 : i1 > SCHARS (string2);
}
else
{
@@ -547,12 +551,30 @@ Symbols are also allowed; their print names are used instead. */)
int c1 = SREF (string1, i1++);
int c2 = fetch_string_char_advance_no_check (string2, &i2, &i2_byte);
if (c1 != c2)
- return c1 < c2 ? Qt : Qnil;
+ return c1 < c2 ? -1 : 1;
}
- return i1 < SCHARS (string2) ? Qt : Qnil;
+ return i1 < SCHARS (string2) ? -1 : i1 > SCHARS (string2);
}
}
+DEFUN ("string-lessp", Fstring_lessp, Sstring_lessp, 2, 2, 0,
+ doc: /* Return non-nil if STRING1 is less than STRING2 in lexicographic order.
+Case is significant.
+Symbols are also allowed; their print names are used instead. */)
+ (Lisp_Object string1, Lisp_Object string2)
+{
+ if (SYMBOLP (string1))
+ string1 = SYMBOL_NAME (string1);
+ else
+ CHECK_STRING (string1);
+ if (SYMBOLP (string2))
+ string2 = SYMBOL_NAME (string2);
+ else
+ CHECK_STRING (string2);
+
+ return string_cmp (string1, string2) < 0 ? Qt : Qnil;
+}
+
DEFUN ("string-version-lessp", Fstring_version_lessp,
Sstring_version_lessp, 2, 2, 0,
doc: /* Return non-nil if S1 is less than S2, as version strings.
@@ -1956,6 +1978,20 @@ assq_no_quit (Lisp_Object key, Lisp_Object alist)
return Qnil;
}
+/* Assq but doesn't signal. Unlike assq_no_quit, this function still
+ detects circular lists; like assq_no_quit, this function does not
+ allow quits and never signals. If anything goes wrong, it returns
+ Qnil. */
+Lisp_Object
+assq_no_signal (Lisp_Object key, Lisp_Object alist)
+{
+ Lisp_Object tail = alist;
+ FOR_EACH_TAIL_SAFE (tail)
+ if (CONSP (XCAR (tail)) && EQ (XCAR (XCAR (tail)), key))
+ return XCAR (tail);
+ return Qnil;
+}
+
DEFUN ("assoc", Fassoc, Sassoc, 2, 3, 0,
doc: /* Return non-nil if KEY is equal to the car of an element of ALIST.
The value is actually the first element of ALIST whose car equals KEY.
@@ -2078,7 +2114,27 @@ changing the value of a sequence `foo'. See also `remove', which
does not modify the argument. */)
(Lisp_Object elt, Lisp_Object seq)
{
- if (VECTORP (seq))
+ if (NILP (seq))
+ ;
+ else if (CONSP (seq))
+ {
+ Lisp_Object prev = Qnil, tail = seq;
+
+ FOR_EACH_TAIL (tail)
+ {
+ if (!NILP (Fequal (elt, XCAR (tail))))
+ {
+ if (NILP (prev))
+ seq = XCDR (tail);
+ else
+ Fsetcdr (prev, XCDR (tail));
+ }
+ else
+ prev = tail;
+ }
+ CHECK_LIST_END (tail, seq);
+ }
+ else if (VECTORP (seq))
{
ptrdiff_t n = 0;
ptrdiff_t size = ASIZE (seq);
@@ -2167,23 +2223,7 @@ does not modify the argument. */)
}
}
else
- {
- Lisp_Object prev = Qnil, tail = seq;
-
- FOR_EACH_TAIL (tail)
- {
- if (!NILP (Fequal (elt, XCAR (tail))))
- {
- if (NILP (prev))
- seq = XCDR (tail);
- else
- Fsetcdr (prev, XCDR (tail));
- }
- else
- prev = tail;
- }
- CHECK_LIST_END (tail, seq);
- }
+ wrong_type_argument (Qsequencep, seq);
return seq;
}
@@ -2196,8 +2236,6 @@ This function may destructively modify SEQ to produce the value. */)
{
if (NILP (seq))
return seq;
- else if (STRINGP (seq))
- return Freverse (seq);
else if (CONSP (seq))
{
Lisp_Object prev, tail, next;
@@ -2237,6 +2275,8 @@ This function may destructively modify SEQ to produce the value. */)
bool_vector_set (seq, size - i - 1, tem);
}
}
+ else if (STRINGP (seq))
+ return Freverse (seq);
else
wrong_type_argument (Qarrayp, seq);
return seq;
@@ -2307,17 +2347,17 @@ See also the function `nreverse', which is used more often. */)
}
-/* 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. */
-
+/* Stably sort LIST ordered by PREDICATE and KEYFUNC, optionally reversed.
+ This converts the list to a vector, sorts the vector, and returns the
+ result converted back to a list. If INPLACE, the input list is
+ reused to hold the sorted result; otherwise a new list is returned. */
static Lisp_Object
-sort_list (Lisp_Object list, Lisp_Object predicate)
+sort_list (Lisp_Object list, Lisp_Object predicate, Lisp_Object keyfunc,
+ bool reverse, bool inplace)
{
ptrdiff_t length = list_length (list);
if (length < 2)
- return list;
+ return inplace ? list : list1 (XCAR (list));
else
{
Lisp_Object *result;
@@ -2329,49 +2369,109 @@ sort_list (Lisp_Object list, Lisp_Object predicate)
result[i] = Fcar (tail);
tail = XCDR (tail);
}
- tim_sort (predicate, result, length);
+ tim_sort (predicate, keyfunc, result, length, reverse);
- ptrdiff_t i = 0;
- tail = list;
- while (CONSP (tail))
+ if (inplace)
{
- XSETCAR (tail, result[i]);
- tail = XCDR (tail);
- i++;
+ /* Copy sorted vector contents back onto the original list. */
+ ptrdiff_t i = 0;
+ tail = list;
+ while (CONSP (tail))
+ {
+ XSETCAR (tail, result[i]);
+ tail = XCDR (tail);
+ i++;
+ }
+ }
+ else
+ {
+ /* Create a new list for the sorted vector contents. */
+ list = Qnil;
+ for (ptrdiff_t i = length - 1; i >= 0; i--)
+ list = Fcons (result[i], list);
}
SAFE_FREE ();
return list;
}
}
-/* Stably sort VECTOR ordered by PREDICATE using the TIMSORT
- algorithm. */
-
-static void
-sort_vector (Lisp_Object vector, Lisp_Object predicate)
+/* Stably sort VECTOR in-place ordered by PREDICATE and KEYFUNC,
+ optionally reversed. */
+static Lisp_Object
+sort_vector (Lisp_Object vector, Lisp_Object predicate, Lisp_Object keyfunc,
+ bool reverse)
{
ptrdiff_t length = ASIZE (vector);
- if (length < 2)
- return;
-
- tim_sort (predicate, XVECTOR (vector)->contents, length);
+ if (length >= 2)
+ tim_sort (predicate, keyfunc, XVECTOR (vector)->contents, length, reverse);
+ return vector;
}
-DEFUN ("sort", Fsort, Ssort, 2, 2, 0,
- doc: /* Sort SEQ, stably, comparing elements using PREDICATE.
-Returns the sorted sequence. SEQ should be a list or vector. SEQ is
-modified by side effects. PREDICATE is called with two elements of
-SEQ, and should return non-nil if the first element should sort before
-the second. */)
- (Lisp_Object seq, Lisp_Object predicate)
+DEFUN ("sort", Fsort, Ssort, 1, MANY, 0,
+ doc: /* Sort SEQ, stably, and return the sorted sequence.
+SEQ should be a list or vector.
+Optional arguments are specified as keyword/argument pairs. The following
+arguments are defined:
+
+:key FUNC -- FUNC is a function that takes a single element from SEQ and
+ returns the key value to be used in comparison. If absent or nil,
+ `identity' is used.
+
+:lessp FUNC -- FUNC is a function that takes two arguments and returns
+ non-nil if the first element should come before the second.
+ If absent or nil, `value<' is used.
+
+:reverse BOOL -- if BOOL is non-nil, the sorting order implied by FUNC is
+ reversed. This does not affect stability: equal elements still retain
+ their order in the input sequence.
+
+:in-place BOOL -- if BOOL is non-nil, SEQ is sorted in-place and returned.
+ Otherwise, a sorted copy of SEQ is returned and SEQ remains unmodified;
+ this is the default.
+
+For compatibility, the calling convention (sort SEQ LESSP) can also be used;
+in this case, sorting is always done in-place.
+
+usage: (sort SEQ &key KEY LESSP REVERSE IN-PLACE) */)
+ (ptrdiff_t nargs, Lisp_Object *args)
{
+ Lisp_Object seq = args[0];
+ Lisp_Object key = Qnil;
+ Lisp_Object lessp = Qnil;
+ bool inplace = false;
+ bool reverse = false;
+ if (nargs == 2)
+ {
+ /* old-style invocation without keywords */
+ lessp = args[1];
+ inplace = true;
+ }
+ else if ((nargs & 1) == 0)
+ error ("Invalid argument list");
+ else
+ for (ptrdiff_t i = 1; i < nargs - 1; i += 2)
+ {
+ if (EQ (args[i], QCkey))
+ key = args[i + 1];
+ else if (EQ (args[i], QClessp))
+ lessp = args[i + 1];
+ else if (EQ (args[i], QCin_place))
+ inplace = !NILP (args[i + 1]);
+ else if (EQ (args[i], QCreverse))
+ reverse = !NILP (args[i + 1]);
+ else
+ signal_error ("Invalid keyword argument", args[i]);
+ }
+
if (CONSP (seq))
- seq = sort_list (seq, predicate);
+ return sort_list (seq, lessp, key, reverse, inplace);
+ else if (NILP (seq))
+ return seq;
else if (VECTORP (seq))
- sort_vector (seq, predicate);
- else if (!NILP (seq))
+ return sort_vector (inplace ? seq : Fcopy_sequence (seq),
+ lessp, key, reverse);
+ else
wrong_type_argument (Qlist_or_vector_p, seq);
- return seq;
}
Lisp_Object
@@ -2701,6 +2801,10 @@ equal_no_quit (Lisp_Object o1, Lisp_Object o2)
return internal_equal (o1, o2, EQUAL_NO_QUIT, 0, Qnil);
}
+static ptrdiff_t hash_lookup_with_hash (struct Lisp_Hash_Table *h,
+ Lisp_Object key, hash_hash_t hash);
+
+
/* Return true if O1 and O2 are equal. EQUAL_KIND specifies what kind
of equality test to use: if it is EQUAL_NO_QUIT, do not check for
cycles or large arguments or quits; if EQUAL_PLAIN, do ordinary
@@ -2729,8 +2833,8 @@ internal_equal (Lisp_Object o1, Lisp_Object o2, enum equal_kind equal_kind,
case Lisp_Cons: case Lisp_Vectorlike:
{
struct Lisp_Hash_Table *h = XHASH_TABLE (ht);
- Lisp_Object hash;
- ptrdiff_t i = hash_lookup (h, o1, &hash);
+ hash_hash_t hash = hash_from_key (h, o1);
+ ptrdiff_t i = hash_lookup_with_hash (h, o1, hash);
if (i >= 0)
{ /* `o1' was seen already. */
Lisp_Object o2s = HASH_VALUE (h, i);
@@ -2748,10 +2852,8 @@ internal_equal (Lisp_Object o1, Lisp_Object o2, enum equal_kind equal_kind,
/* A symbol with position compares the contained symbol, and is
`equal' to the corresponding ordinary symbol. */
- if (SYMBOL_WITH_POS_P (o1))
- o1 = SYMBOL_WITH_POS_SYM (o1);
- if (SYMBOL_WITH_POS_P (o2))
- o2 = SYMBOL_WITH_POS_SYM (o2);
+ o1 = maybe_remove_pos_from_symbol (o1);
+ o2 = maybe_remove_pos_from_symbol (o2);
if (BASE_EQ (o1, o2))
return true;
@@ -2799,8 +2901,8 @@ internal_equal (Lisp_Object o1, Lisp_Object o2, enum equal_kind equal_kind,
if (ASIZE (o2) != size)
return false;
- /* Compare bignums, overlays, markers, and boolvectors
- specially, by comparing their values. */
+ /* Compare bignums, overlays, markers, boolvectors, and
+ symbols with position specially, by comparing their values. */
if (BIGNUMP (o1))
return mpz_cmp (*xbignum_val (o1), *xbignum_val (o2)) == 0;
if (OVERLAYP (o1))
@@ -2832,6 +2934,14 @@ internal_equal (Lisp_Object o1, Lisp_Object o2, enum equal_kind equal_kind,
if (TS_NODEP (o1))
return treesit_node_eq (o1, o2);
#endif
+ if (SYMBOL_WITH_POS_P (o1))
+ {
+ eassert (!symbols_with_pos_enabled);
+ return (BASE_EQ (XSYMBOL_WITH_POS_SYM (o1),
+ XSYMBOL_WITH_POS_SYM (o2))
+ && BASE_EQ (XSYMBOL_WITH_POS_POS (o1),
+ XSYMBOL_WITH_POS_POS (o2)));
+ }
/* Aside from them, only true vectors, char-tables, compiled
functions, and fonts (font-spec, font-entity, font-object)
@@ -2868,6 +2978,233 @@ internal_equal (Lisp_Object o1, Lisp_Object o2, enum equal_kind equal_kind,
return false;
}
+
+/* Return -1/0/1 for the </=/> lexicographic relation between bool-vectors. */
+static int
+bool_vector_cmp (Lisp_Object a, Lisp_Object b)
+{
+ ptrdiff_t na = bool_vector_size (a);
+ ptrdiff_t nb = bool_vector_size (b);
+ /* Skip equal words. */
+ ptrdiff_t words_min = min (na, nb) / BITS_PER_BITS_WORD;
+ bits_word *ad = bool_vector_data (a);
+ bits_word *bd = bool_vector_data (b);
+ ptrdiff_t i = 0;
+ while (i < words_min && ad[i] == bd[i])
+ i++;
+ na -= i * BITS_PER_BITS_WORD;
+ nb -= i * BITS_PER_BITS_WORD;
+ eassume (na >= 0 && nb >= 0);
+ if (nb == 0)
+ return na != 0;
+ if (na == 0)
+ return -1;
+
+ bits_word aw = bits_word_to_host_endian (ad[i]);
+ bits_word bw = bits_word_to_host_endian (bd[i]);
+ bits_word xw = aw ^ bw;
+ if (xw == 0)
+ return na < nb ? -1 : na > nb;
+
+ bits_word d = xw & -xw; /* Isolate first difference. */
+ eassume (d != 0);
+ return (d & aw) ? 1 : -1;
+}
+
+/* Return -1, 0 or 1 to indicate whether a<b, a=b or a>b in the sense of value<.
+ In particular 0 does not mean equality in the sense of Fequal, only
+ that the arguments cannot be ordered yet they can be compared (same
+ type). */
+static int
+value_cmp (Lisp_Object a, Lisp_Object b, int maxdepth)
+{
+ if (maxdepth < 0)
+ error ("Maximum depth exceeded in comparison");
+
+ tail_recurse:
+ /* Shortcut for a common case. */
+ if (BASE_EQ (a, b))
+ return 0;
+
+ switch (XTYPE (a))
+ {
+ case_Lisp_Int:
+ {
+ EMACS_INT ia = XFIXNUM (a);
+ if (FIXNUMP (b))
+ return ia < XFIXNUM (b) ? -1 : 1; /* we know that a≠b */
+ if (FLOATP (b))
+ return ia < XFLOAT_DATA (b) ? -1 : ia > XFLOAT_DATA (b);
+ if (BIGNUMP (b))
+ return -mpz_sgn (*xbignum_val (b));
+ }
+ goto type_mismatch;
+
+ case Lisp_Symbol:
+ if (BARE_SYMBOL_P (b))
+ return string_cmp (XBARE_SYMBOL (a)->u.s.name,
+ XBARE_SYMBOL (b)->u.s.name);
+ if (CONSP (b) && NILP (a))
+ return -1;
+ if (SYMBOLP (b))
+ /* Slow-path branch when B is a symbol-with-pos. */
+ return string_cmp (XBARE_SYMBOL (a)->u.s.name, XSYMBOL (b)->u.s.name);
+ goto type_mismatch;
+
+ case Lisp_String:
+ if (STRINGP (b))
+ return string_cmp (a, b);
+ goto type_mismatch;
+
+ case Lisp_Cons:
+ /* FIXME: Optimise for difference in the first element? */
+ FOR_EACH_TAIL (b)
+ {
+ int cmp = value_cmp (XCAR (a), XCAR (b), maxdepth - 1);
+ if (cmp != 0)
+ return cmp;
+ a = XCDR (a);
+ if (!CONSP (a))
+ {
+ b = XCDR (b);
+ goto tail_recurse;
+ }
+ }
+ if (NILP (b))
+ return 1;
+ else
+ goto type_mismatch;
+ goto tail_recurse;
+
+ case Lisp_Vectorlike:
+ if (VECTORLIKEP (b))
+ {
+ enum pvec_type ta = PSEUDOVECTOR_TYPE (XVECTOR (a));
+ enum pvec_type tb = PSEUDOVECTOR_TYPE (XVECTOR (b));
+ if (ta == tb)
+ switch (ta)
+ {
+ case PVEC_NORMAL_VECTOR:
+ case PVEC_RECORD:
+ {
+ ptrdiff_t len_a = ASIZE (a);
+ ptrdiff_t len_b = ASIZE (b);
+ if (ta == PVEC_RECORD)
+ {
+ len_a &= PSEUDOVECTOR_SIZE_MASK;
+ len_b &= PSEUDOVECTOR_SIZE_MASK;
+ }
+ ptrdiff_t len_min = min (len_a, len_b);
+ for (ptrdiff_t i = 0; i < len_min; i++)
+ {
+ int cmp = value_cmp (AREF (a, i), AREF (b, i),
+ maxdepth - 1);
+ if (cmp != 0)
+ return cmp;
+ }
+ return len_a < len_b ? -1 : len_a > len_b;
+ }
+
+ case PVEC_BOOL_VECTOR:
+ return bool_vector_cmp (a, b);
+
+ case PVEC_MARKER:
+ {
+ Lisp_Object buf_a = Fmarker_buffer (a);
+ Lisp_Object buf_b = Fmarker_buffer (b);
+ if (NILP (buf_a))
+ return NILP (buf_b) ? 0 : -1;
+ if (NILP (buf_b))
+ return 1;
+ int cmp = value_cmp (buf_a, buf_b, maxdepth - 1);
+ if (cmp != 0)
+ return cmp;
+ ptrdiff_t pa = XMARKER (a)->charpos;
+ ptrdiff_t pb = XMARKER (b)->charpos;
+ return pa < pb ? -1 : pa > pb;
+ }
+
+ case PVEC_PROCESS:
+ a = Fprocess_name (a);
+ b = Fprocess_name (b);
+ goto tail_recurse;
+
+ case PVEC_BUFFER:
+ {
+ /* Killed buffers lack names and sort before those alive. */
+ Lisp_Object na = Fbuffer_name (a);
+ Lisp_Object nb = Fbuffer_name (b);
+ if (NILP (na))
+ return NILP (nb) ? 0 : -1;
+ if (NILP (nb))
+ return 1;
+ a = na;
+ b = nb;
+ goto tail_recurse;
+ }
+
+ case PVEC_BIGNUM:
+ return mpz_cmp (*xbignum_val (a), *xbignum_val (b));
+
+ case PVEC_SYMBOL_WITH_POS:
+ /* Compare by name, enabled or not. */
+ a = XSYMBOL_WITH_POS_SYM (a);
+ b = XSYMBOL_WITH_POS_SYM (b);
+ goto tail_recurse;
+
+ default:
+ /* Treat other types as unordered. */
+ return 0;
+ }
+ }
+ else if (BIGNUMP (a))
+ return -value_cmp (b, a, maxdepth);
+ else if (SYMBOL_WITH_POS_P (a) && symbols_with_pos_enabled)
+ {
+ a = XSYMBOL_WITH_POS_SYM (a);
+ goto tail_recurse;
+ }
+
+ goto type_mismatch;
+
+ case Lisp_Float:
+ {
+ double fa = XFLOAT_DATA (a);
+ if (FLOATP (b))
+ return fa < XFLOAT_DATA (b) ? -1 : fa > XFLOAT_DATA (b);
+ if (FIXNUMP (b))
+ return fa < XFIXNUM (b) ? -1 : fa > XFIXNUM (b);
+ if (BIGNUMP (b))
+ {
+ if (isnan (fa))
+ return 0;
+ return -mpz_cmp_d (*xbignum_val (b), fa);
+ }
+ }
+ goto type_mismatch;
+
+ default:
+ eassume (0);
+ }
+ type_mismatch:
+ xsignal2 (Qtype_mismatch, a, b);
+}
+
+DEFUN ("value<", Fvaluelt, Svaluelt, 2, 2, 0,
+ doc: /* Return non-nil if A precedes B in standard value order.
+A and B must have the same basic type.
+Numbers are compared with `<'.
+Strings and symbols are compared with `string-lessp'.
+Lists, vectors, bool-vectors and records are compared lexicographically.
+Markers are compared lexicographically by buffer and position.
+Buffers and processes are compared by name.
+Other types are considered unordered and the return value will be `nil'. */)
+ (Lisp_Object a, Lisp_Object b)
+{
+ int maxdepth = 200; /* FIXME: arbitrary value */
+ return value_cmp (a, b, maxdepth) < 0 ? Qt : Qnil;
+}
+
DEFUN ("fillarray", Ffillarray, Sfillarray, 2, 2, 0,
@@ -2913,8 +3250,7 @@ ARRAY is a vector, string, char-table, or bool-vector. */)
else
{
ptrdiff_t product;
- if (INT_MULTIPLY_WRAPV (size, len, &product)
- || product != size_byte)
+ if (ckd_mul (&product, size, len) || product != size_byte)
error ("Attempt to change byte length of a string");
for (idx = 0; idx < size_byte; idx++)
*p++ = str[idx % len];
@@ -3170,7 +3506,7 @@ SEQUENCE may be a list, a vector, a bool-vector, or a string. */)
Lisp_Object
do_yes_or_no_p (Lisp_Object prompt)
{
- return call1 (intern ("yes-or-no-p"), prompt);
+ return call1 (Qyes_or_no_p, prompt);
}
DEFUN ("yes-or-no-p", Fyes_or_no_p, Syes_or_no_p, 1, 1, 0,
@@ -3178,13 +3514,16 @@ DEFUN ("yes-or-no-p", Fyes_or_no_p, Syes_or_no_p, 1, 1, 0,
Return t if answer is yes, and nil if the answer is no.
PROMPT is the string to display to ask the question; `yes-or-no-p'
-adds \"(yes or no) \" to it.
+appends `yes-or-no-prompt' (default \"(yes or no) \") to it. If
+PROMPT is a non-empty string, and it ends with a non-space character,
+a space character will be appended to it.
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\".
+\"yes\" or \"no\", this function will ask for \"y\" or \"n\" (and
+ignore the value of `yes-or-no-prompt').
If dialog boxes are supported, this function will use a dialog box
if `use-dialog-box' is non-nil and the last input event was produced
@@ -3199,7 +3538,7 @@ by a mouse, or by some window-system gesture, or via a menu. */)
&& (CONSP (last_nonmenu_event)
|| (NILP (last_nonmenu_event) && CONSP (last_input_event))
|| (val = find_symbol_value (Qfrom__tty_menu_p),
- (!NILP (val) && !EQ (val, Qunbound))))
+ (!NILP (val) && !BASE_EQ (val, Qunbound))))
&& use_dialog_box)
{
Lisp_Object pane, menu, obj;
@@ -3212,10 +3551,15 @@ by a mouse, or by some window-system gesture, or via a menu. */)
}
if (use_short_answers)
- return call1 (intern ("y-or-n-p"), prompt);
+ return call1 (Qy_or_n_p, prompt);
- AUTO_STRING (yes_or_no, "(yes or no) ");
- prompt = CALLN (Fconcat, prompt, yes_or_no);
+ {
+ char *s = SSDATA (prompt);
+ ptrdiff_t len = strlen (s);
+ if ((len > 0) && !isspace (s[len - 1]))
+ prompt = CALLN (Fconcat, prompt, build_string (" "));
+ }
+ prompt = CALLN (Fconcat, prompt, Vyes_or_no_prompt);
specpdl_ref count = SPECPDL_INDEX ();
specbind (Qenable_recursive_minibuffers, Qt);
@@ -3528,6 +3872,10 @@ The data read from the system are decoded using `locale-coding-system'. */)
(Lisp_Object item)
{
char *str = NULL;
+
+ /* STR is apparently unused on Android. */
+ ((void) str);
+
#ifdef HAVE_LANGINFO_CODESET
if (EQ (item, Qcodeset))
{
@@ -4226,17 +4574,20 @@ CHECK_HASH_TABLE (Lisp_Object x)
static void
set_hash_next_slot (struct Lisp_Hash_Table *h, ptrdiff_t idx, ptrdiff_t val)
{
- gc_aset (h->next, idx, make_fixnum (val));
+ eassert (idx >= 0 && idx < h->table_size);
+ h->next[idx] = val;
}
static void
-set_hash_hash_slot (struct Lisp_Hash_Table *h, ptrdiff_t idx, Lisp_Object val)
+set_hash_hash_slot (struct Lisp_Hash_Table *h, ptrdiff_t idx, hash_hash_t val)
{
- gc_aset (h->hash, idx, val);
+ eassert (idx >= 0 && idx < h->table_size);
+ h->hash[idx] = val;
}
static void
set_hash_index_slot (struct Lisp_Hash_Table *h, ptrdiff_t idx, ptrdiff_t val)
{
- gc_aset (h->index, idx, make_fixnum (val));
+ eassert (idx >= 0 && idx < hash_table_index_size (h));
+ h->index[idx] = val;
}
/* If OBJ is a Lisp hash table, return a pointer to its struct
@@ -4290,11 +4641,10 @@ get_key_arg (Lisp_Object key, ptrdiff_t nargs, Lisp_Object *args, char *used)
/* Return a Lisp vector which has the same contents as VEC but has
at least INCR_MIN more entries, where INCR_MIN is positive.
If NITEMS_MAX is not -1, do not grow the vector to be any larger
- than NITEMS_MAX. New entries in the resulting vector are
- uninitialized. */
+ than NITEMS_MAX. New entries in the resulting vector are nil. */
-static Lisp_Object
-larger_vecalloc (Lisp_Object vec, ptrdiff_t incr_min, ptrdiff_t nitems_max)
+Lisp_Object
+larger_vector (Lisp_Object vec, ptrdiff_t incr_min, ptrdiff_t nitems_max)
{
struct Lisp_Vector *v;
ptrdiff_t incr, incr_max, old_size, new_size;
@@ -4311,23 +4661,11 @@ larger_vecalloc (Lisp_Object vec, ptrdiff_t incr_min, ptrdiff_t nitems_max)
new_size = old_size + incr;
v = allocate_vector (new_size);
memcpy (v->contents, XVECTOR (vec)->contents, old_size * sizeof *v->contents);
+ memclear (v->contents + old_size, (new_size - old_size) * word_size);
XSETVECTOR (vec, v);
return vec;
}
-/* Likewise, except set new entries in the resulting vector to nil. */
-
-Lisp_Object
-larger_vector (Lisp_Object vec, ptrdiff_t incr_min, ptrdiff_t nitems_max)
-{
- ptrdiff_t old_size = ASIZE (vec);
- Lisp_Object v = larger_vecalloc (vec, incr_min, nitems_max);
- ptrdiff_t new_size = ASIZE (v);
- memclear (XVECTOR (v)->contents + old_size,
- (new_size - old_size) * word_size);
- return v;
-}
-
/***********************************************************************
Low-level Functions
@@ -4339,7 +4677,8 @@ larger_vector (Lisp_Object vec, ptrdiff_t incr_min, ptrdiff_t nitems_max)
static ptrdiff_t
HASH_NEXT (struct Lisp_Hash_Table *h, ptrdiff_t idx)
{
- return XFIXNUM (AREF (h->next, idx));
+ eassert (idx >= 0 && idx < h->table_size);
+ return h->next[idx];
}
/* Return the index of the element in hash table H that is the start
@@ -4348,7 +4687,8 @@ HASH_NEXT (struct Lisp_Hash_Table *h, ptrdiff_t idx)
static ptrdiff_t
HASH_INDEX (struct Lisp_Hash_Table *h, ptrdiff_t idx)
{
- return XFIXNUM (AREF (h->index, idx));
+ eassert (idx >= 0 && idx < hash_table_index_size (h));
+ return h->index[idx];
}
/* Restore a hash table's mutability after the critical section exits. */
@@ -4403,89 +4743,93 @@ static Lisp_Object
cmpfn_user_defined (Lisp_Object key1, Lisp_Object key2,
struct Lisp_Hash_Table *h)
{
- Lisp_Object args[] = { h->test.user_cmp_function, key1, key2 };
+ Lisp_Object args[] = { h->test->user_cmp_function, key1, key2 };
return hash_table_user_defined_call (ARRAYELTS (args), args, h);
}
+static EMACS_INT
+sxhash_eq (Lisp_Object key)
+{
+ Lisp_Object k = maybe_remove_pos_from_symbol (key);
+ return XHASH (k) ^ XTYPE (k);
+}
+
+static EMACS_INT
+sxhash_eql (Lisp_Object key)
+{
+ return FLOATP (key) || BIGNUMP (key) ? sxhash (key) : sxhash_eq (key);
+}
+
/* Ignore H and return a hash code for KEY which uses 'eq' to compare keys. */
-static Lisp_Object
+static hash_hash_t
hashfn_eq (Lisp_Object key, struct Lisp_Hash_Table *h)
{
- if (symbols_with_pos_enabled && SYMBOL_WITH_POS_P (key))
- key = SYMBOL_WITH_POS_SYM (key);
- return make_ufixnum (XHASH (key) ^ XTYPE (key));
+ return reduce_emacs_uint_to_hash_hash (sxhash_eq (key));
}
-/* Ignore H and return a hash code for KEY which uses 'equal' to compare keys.
- The hash code is at most INTMASK. */
-
-static Lisp_Object
+/* Ignore H and return a hash code for KEY which uses 'equal' to
+ compare keys. */
+static hash_hash_t
hashfn_equal (Lisp_Object key, struct Lisp_Hash_Table *h)
{
- return make_ufixnum (sxhash (key));
+ return reduce_emacs_uint_to_hash_hash (sxhash (key));
}
-/* Ignore H and return a hash code for KEY which uses 'eql' to compare keys.
- The hash code is at most INTMASK. */
-
-static Lisp_Object
+/* Ignore H and return a hash code for KEY which uses 'eql' to compare keys. */
+static hash_hash_t
hashfn_eql (Lisp_Object key, struct Lisp_Hash_Table *h)
{
- return (FLOATP (key) || BIGNUMP (key) ? hashfn_equal : hashfn_eq) (key, h);
+ return reduce_emacs_uint_to_hash_hash (sxhash_eql (key));
}
/* Given H, return a hash code for KEY which uses a user-defined
function to compare keys. */
-Lisp_Object
+static hash_hash_t
hashfn_user_defined (Lisp_Object key, struct Lisp_Hash_Table *h)
{
- Lisp_Object args[] = { h->test.user_hash_function, key };
+ Lisp_Object args[] = { h->test->user_hash_function, key };
Lisp_Object hash = hash_table_user_defined_call (ARRAYELTS (args), args, h);
- return FIXNUMP (hash) ? hash : make_ufixnum (sxhash (hash));
+ return reduce_emacs_uint_to_hash_hash (FIXNUMP (hash)
+ ? XUFIXNUM(hash) : sxhash (hash));
}
struct hash_table_test const
- hashtest_eq = { LISPSYM_INITIALLY (Qeq), LISPSYM_INITIALLY (Qnil),
- LISPSYM_INITIALLY (Qnil), 0, hashfn_eq },
- hashtest_eql = { LISPSYM_INITIALLY (Qeql), LISPSYM_INITIALLY (Qnil),
- LISPSYM_INITIALLY (Qnil), cmpfn_eql, hashfn_eql },
- hashtest_equal = { LISPSYM_INITIALLY (Qequal), LISPSYM_INITIALLY (Qnil),
- LISPSYM_INITIALLY (Qnil), cmpfn_equal, hashfn_equal };
+ hashtest_eq = { .name = LISPSYM_INITIALLY (Qeq),
+ .cmpfn = 0, .hashfn = hashfn_eq },
+ hashtest_eql = { .name = LISPSYM_INITIALLY (Qeql),
+ .cmpfn = cmpfn_eql, .hashfn = hashfn_eql },
+ hashtest_equal = { .name = LISPSYM_INITIALLY (Qequal),
+ .cmpfn = cmpfn_equal, .hashfn = hashfn_equal };
/* Allocate basically initialized hash table. */
static struct Lisp_Hash_Table *
allocate_hash_table (void)
{
- return ALLOCATE_PSEUDOVECTOR (struct Lisp_Hash_Table,
- index, PVEC_HASH_TABLE);
+ return ALLOCATE_PLAIN_PSEUDOVECTOR (struct Lisp_Hash_Table, PVEC_HASH_TABLE);
}
-/* An upper bound on the size of a hash table index. It must fit in
- ptrdiff_t and be a valid Emacs fixnum. This is an upper bound on
- VECTOR_ELTS_MAX (see alloc.c) and gets as close as we can without
- violating modularity. */
-#define INDEX_SIZE_BOUND \
- ((ptrdiff_t) min (MOST_POSITIVE_FIXNUM, \
- ((min (PTRDIFF_MAX, SIZE_MAX) \
- - header_size - GCALIGNMENT) \
- / word_size)))
-
-static ptrdiff_t
-hash_index_size (struct Lisp_Hash_Table *h, ptrdiff_t size)
-{
- double threshold = h->rehash_threshold;
- double index_float = size / threshold;
- ptrdiff_t index_size = (index_float < INDEX_SIZE_BOUND + 1
- ? next_almost_prime (index_float)
- : INDEX_SIZE_BOUND + 1);
- if (INDEX_SIZE_BOUND < index_size)
+/* Compute the size of the index (as log2) from the table capacity. */
+static int
+compute_hash_index_bits (hash_idx_t size)
+{
+ /* An upper bound on the size of a hash table index index. */
+ hash_idx_t upper_bound = min (MOST_POSITIVE_FIXNUM,
+ min (TYPE_MAXIMUM (hash_idx_t),
+ PTRDIFF_MAX / sizeof (hash_idx_t)));
+ /* Use next higher power of 2. This works even for size=0. */
+ int bits = elogb (size) + 1;
+ if (bits >= TYPE_WIDTH (uintmax_t) || ((uintmax_t)1 << bits) > upper_bound)
error ("Hash table too large");
- return index_size;
+ return bits;
}
+/* Constant hash index vector used when the table size is zero.
+ This avoids allocating it from the heap. */
+static const hash_idx_t empty_hash_index_vector[] = {-1};
+
/* Create and initialize a new hash table.
TEST specifies the test the hash table will use to compare keys.
@@ -4495,68 +4839,63 @@ hash_index_size (struct Lisp_Hash_Table *h, ptrdiff_t size)
Give the table initial capacity SIZE, 0 <= SIZE <= MOST_POSITIVE_FIXNUM.
- If REHASH_SIZE is equal to a negative integer, this hash table's
- new size when it becomes full is computed by subtracting
- REHASH_SIZE from its old size. Otherwise it must be positive, and
- the table's new size is computed by multiplying its old size by
- REHASH_SIZE + 1.
-
- REHASH_THRESHOLD must be a float <= 1.0, and > 0. The table will
- be resized when the approximate ratio of table entries to table
- size exceeds REHASH_THRESHOLD.
-
- WEAK specifies the weakness of the table. If non-nil, it must be
- one of the symbols `key', `value', `key-or-value', or `key-and-value'.
+ WEAK specifies the weakness of the table.
If PURECOPY is non-nil, the table can be copied to pure storage via
`purecopy' when Emacs is being dumped. Such tables can no longer be
changed after purecopy. */
Lisp_Object
-make_hash_table (struct hash_table_test test, EMACS_INT size,
- float rehash_size, float rehash_threshold,
- Lisp_Object weak, bool purecopy)
+make_hash_table (const struct hash_table_test *test, EMACS_INT size,
+ hash_table_weakness_t weak, bool purecopy)
{
- struct Lisp_Hash_Table *h;
- Lisp_Object table;
- ptrdiff_t i;
+ eassert (SYMBOLP (test->name));
+ eassert (0 <= size && size <= min (MOST_POSITIVE_FIXNUM, PTRDIFF_MAX));
- /* Preconditions. */
- eassert (SYMBOLP (test.name));
- eassert (0 <= size && size <= MOST_POSITIVE_FIXNUM);
- eassert (rehash_size <= -1 || 0 < rehash_size);
- eassert (0 < rehash_threshold && rehash_threshold <= 1);
+ struct Lisp_Hash_Table *h = allocate_hash_table ();
+
+ h->test = test;
+ h->weakness = weak;
+ h->count = 0;
+ h->table_size = size;
if (size == 0)
- size = 1;
+ {
+ h->key_and_value = NULL;
+ h->hash = NULL;
+ h->next = NULL;
+ h->index_bits = 0;
+ h->index = (hash_idx_t *)empty_hash_index_vector;
+ h->next_free = -1;
+ }
+ else
+ {
+ h->key_and_value = hash_table_alloc_bytes (2 * size
+ * sizeof *h->key_and_value);
+ for (ptrdiff_t i = 0; i < 2 * size; i++)
+ h->key_and_value[i] = HASH_UNUSED_ENTRY_KEY;
- /* Allocate a table and initialize it. */
- h = allocate_hash_table ();
+ h->hash = hash_table_alloc_bytes (size * sizeof *h->hash);
- /* Initialize hash table slots. */
- h->test = test;
- h->weak = weak;
- h->rehash_threshold = rehash_threshold;
- h->rehash_size = rehash_size;
- h->count = 0;
- h->key_and_value = make_vector (2 * size, Qunbound);
- h->hash = make_nil_vector (size);
- h->next = make_vector (size, make_fixnum (-1));
- h->index = make_vector (hash_index_size (h, size), make_fixnum (-1));
- h->next_weak = NULL;
- h->purecopy = purecopy;
- h->mutable = true;
+ h->next = hash_table_alloc_bytes (size * sizeof *h->next);
+ for (ptrdiff_t i = 0; i < size - 1; i++)
+ h->next[i] = i + 1;
+ h->next[size - 1] = -1;
- /* Set up the free list. */
- for (i = 0; i < size - 1; ++i)
- set_hash_next_slot (h, i, i + 1);
- h->next_free = 0;
+ int index_bits = compute_hash_index_bits (size);
+ h->index_bits = index_bits;
+ ptrdiff_t index_size = hash_table_index_size (h);
+ h->index = hash_table_alloc_bytes (index_size * sizeof *h->index);
+ for (ptrdiff_t i = 0; i < index_size; i++)
+ h->index[i] = -1;
- XSET_HASH_TABLE (table, h);
- eassert (HASH_TABLE_P (table));
- eassert (XHASH_TABLE (table) == h);
+ h->next_free = 0;
+ }
- return table;
+ h->next_weak = NULL;
+ h->purecopy = purecopy;
+ h->mutable = true;
+ return make_lisp_hash_table (h);
}
@@ -4566,21 +4905,39 @@ make_hash_table (struct hash_table_test test, EMACS_INT size,
static Lisp_Object
copy_hash_table (struct Lisp_Hash_Table *h1)
{
- Lisp_Object table;
struct Lisp_Hash_Table *h2;
h2 = allocate_hash_table ();
*h2 = *h1;
h2->mutable = true;
- h2->key_and_value = Fcopy_sequence (h1->key_and_value);
- h2->hash = Fcopy_sequence (h1->hash);
- h2->next = Fcopy_sequence (h1->next);
- h2->index = Fcopy_sequence (h1->index);
- XSET_HASH_TABLE (table, h2);
- return table;
+ if (h1->table_size > 0)
+ {
+ ptrdiff_t kv_bytes = 2 * h1->table_size * sizeof *h1->key_and_value;
+ h2->key_and_value = hash_table_alloc_bytes (kv_bytes);
+ memcpy (h2->key_and_value, h1->key_and_value, kv_bytes);
+
+ ptrdiff_t hash_bytes = h1->table_size * sizeof *h1->hash;
+ h2->hash = hash_table_alloc_bytes (hash_bytes);
+ memcpy (h2->hash, h1->hash, hash_bytes);
+
+ ptrdiff_t next_bytes = h1->table_size * sizeof *h1->next;
+ h2->next = hash_table_alloc_bytes (next_bytes);
+ memcpy (h2->next, h1->next, next_bytes);
+
+ ptrdiff_t index_bytes = hash_table_index_size (h1) * sizeof *h1->index;
+ h2->index = hash_table_alloc_bytes (index_bytes);
+ memcpy (h2->index, h1->index, index_bytes);
+ }
+ return make_lisp_hash_table (h2);
}
+/* Compute index into the index vector from a hash value. */
+static inline ptrdiff_t
+hash_index_index (struct Lisp_Hash_Table *h, hash_hash_t hash)
+{
+ return knuth_hash (hash, h->index_bits);
+}
/* Resize hash table H if it's too full. If H cannot be resized
because it's already too large, throw an error. */
@@ -4591,121 +4948,168 @@ maybe_resize_hash_table (struct Lisp_Hash_Table *h)
if (h->next_free < 0)
{
ptrdiff_t old_size = HASH_TABLE_SIZE (h);
- EMACS_INT new_size;
- double rehash_size = h->rehash_size;
-
- if (rehash_size < 0)
- new_size = old_size - rehash_size;
- else
- {
- double float_new_size = old_size * (rehash_size + 1);
- if (float_new_size < EMACS_INT_MAX)
- new_size = float_new_size;
- else
- new_size = EMACS_INT_MAX;
- }
- if (PTRDIFF_MAX < new_size)
- new_size = PTRDIFF_MAX;
- if (new_size <= old_size)
- new_size = old_size + 1;
+ ptrdiff_t min_size = 6;
+ ptrdiff_t base_size = min (max (old_size, min_size), PTRDIFF_MAX / 2);
+ /* Grow aggressively at small sizes, then just double. */
+ ptrdiff_t new_size =
+ old_size == 0
+ ? min_size
+ : (base_size <= 64 ? base_size * 4 : base_size * 2);
/* Allocate all the new vectors before updating *H, to
- avoid problems if memory is exhausted. larger_vecalloc
- finishes computing the size of the replacement vectors. */
- Lisp_Object next = larger_vecalloc (h->next, new_size - old_size,
- new_size);
- ptrdiff_t next_size = ASIZE (next);
- for (ptrdiff_t i = old_size; i < next_size - 1; i++)
- ASET (next, i, make_fixnum (i + 1));
- ASET (next, next_size - 1, make_fixnum (-1));
-
- /* Build the new&larger key_and_value vector, making sure the new
- fields are initialized to `unbound`. */
- Lisp_Object key_and_value
- = larger_vecalloc (h->key_and_value, 2 * (next_size - old_size),
- 2 * next_size);
- for (ptrdiff_t i = 2 * old_size; i < 2 * next_size; i++)
- ASET (key_and_value, i, Qunbound);
-
- Lisp_Object hash = larger_vector (h->hash, next_size - old_size,
- next_size);
- ptrdiff_t index_size = hash_index_size (h, next_size);
- h->index = make_vector (index_size, make_fixnum (-1));
+ avoid problems if memory is exhausted. */
+ hash_idx_t *next = hash_table_alloc_bytes (new_size * sizeof *next);
+ for (ptrdiff_t i = old_size; i < new_size - 1; i++)
+ next[i] = i + 1;
+ next[new_size - 1] = -1;
+
+ Lisp_Object *key_and_value
+ = hash_table_alloc_bytes (2 * new_size * sizeof *key_and_value);
+ memcpy (key_and_value, h->key_and_value,
+ 2 * old_size * sizeof *key_and_value);
+ for (ptrdiff_t i = 2 * old_size; i < 2 * new_size; i++)
+ key_and_value[i] = HASH_UNUSED_ENTRY_KEY;
+
+ hash_hash_t *hash = hash_table_alloc_bytes (new_size * sizeof *hash);
+ memcpy (hash, h->hash, old_size * sizeof *hash);
+
+ ptrdiff_t old_index_size = hash_table_index_size (h);
+ ptrdiff_t index_bits = compute_hash_index_bits (new_size);
+ ptrdiff_t index_size = (ptrdiff_t)1 << index_bits;
+ hash_idx_t *index = hash_table_alloc_bytes (index_size * sizeof *index);
+ for (ptrdiff_t i = 0; i < index_size; i++)
+ index[i] = -1;
+
+ h->index_bits = index_bits;
+ h->table_size = new_size;
+ h->next_free = old_size;
+
+ if (old_index_size > 1)
+ hash_table_free_bytes (h->index, old_index_size * sizeof *h->index);
+ h->index = index;
+
+ hash_table_free_bytes (h->key_and_value,
+ 2 * old_size * sizeof *h->key_and_value);
h->key_and_value = key_and_value;
+
+ hash_table_free_bytes (h->hash, old_size * sizeof *h->hash);
h->hash = hash;
+
+ hash_table_free_bytes (h->next, old_size * sizeof *h->next);
h->next = next;
- h->next_free = old_size;
- /* Rehash. */
+ h->key_and_value = key_and_value;
+
+ /* Rehash: all data occupy entries 0..old_size-1. */
for (ptrdiff_t i = 0; i < old_size; i++)
- if (!NILP (HASH_HASH (h, i)))
- {
- EMACS_UINT hash_code = XUFIXNUM (HASH_HASH (h, i));
- ptrdiff_t start_of_bucket = hash_code % ASIZE (h->index);
- set_hash_next_slot (h, i, HASH_INDEX (h, start_of_bucket));
- set_hash_index_slot (h, start_of_bucket, i);
- }
+ {
+ hash_hash_t hash_code = HASH_HASH (h, i);
+ ptrdiff_t start_of_bucket = hash_index_index (h, hash_code);
+ set_hash_next_slot (h, i, HASH_INDEX (h, start_of_bucket));
+ set_hash_index_slot (h, start_of_bucket, i);
+ }
#ifdef ENABLE_CHECKING
if (HASH_TABLE_P (Vpurify_flag) && XHASH_TABLE (Vpurify_flag) == h)
- message ("Growing hash table to: %"pD"d", next_size);
+ message ("Growing hash table to: %"pD"d", new_size);
#endif
}
}
-/* Recompute the hashes (and hence also the "next" pointers).
- Normally there's never a need to recompute hashes.
- This is done only on first access to a hash-table loaded from
- the "pdump", because the objects' addresses may have changed, thus
- affecting their hashes. */
+static const struct hash_table_test *
+hash_table_test_from_std (hash_table_std_test_t test)
+{
+ switch (test)
+ {
+ case Test_eq: return &hashtest_eq;
+ case Test_eql: return &hashtest_eql;
+ case Test_equal: return &hashtest_equal;
+ }
+ emacs_abort();
+}
+
+/* Rebuild a hash table from its frozen (dumped) form. */
void
-hash_table_rehash (Lisp_Object hash)
+hash_table_thaw (Lisp_Object hash_table)
{
- struct Lisp_Hash_Table *h = XHASH_TABLE (hash);
- ptrdiff_t i, count = h->count;
+ struct Lisp_Hash_Table *h = XHASH_TABLE (hash_table);
+
+ /* Freezing discarded most non-essential information; recompute it.
+ The allocation is minimal with no room for growth. */
+ h->test = hash_table_test_from_std (h->frozen_test);
+ ptrdiff_t size = h->count;
+ h->table_size = size;
+ h->next_free = -1;
- /* Recompute the actual hash codes for each entry in the table.
- Order is still invalid. */
- for (i = 0; i < count; i++)
+ if (size == 0)
{
- Lisp_Object key = HASH_KEY (h, i);
- Lisp_Object hash_code = h->test.hashfn (key, h);
- ptrdiff_t start_of_bucket = XUFIXNUM (hash_code) % ASIZE (h->index);
- set_hash_hash_slot (h, i, hash_code);
- set_hash_next_slot (h, i, HASH_INDEX (h, start_of_bucket));
- set_hash_index_slot (h, start_of_bucket, i);
- eassert (HASH_NEXT (h, i) != i); /* Stop loops. */
+ h->key_and_value = NULL;
+ h->hash = NULL;
+ h->next = NULL;
+ h->index_bits = 0;
+ h->index = (hash_idx_t *)empty_hash_index_vector;
}
+ else
+ {
+ ptrdiff_t index_bits = compute_hash_index_bits (size);
+ h->index_bits = index_bits;
- ptrdiff_t size = ASIZE (h->next);
- for (; i + 1 < size; i++)
- set_hash_next_slot (h, i, i + 1);
-}
+ h->hash = hash_table_alloc_bytes (size * sizeof *h->hash);
-/* Lookup KEY in hash table H. If HASH is non-null, return in *HASH
- the hash code of KEY. Value is the index of the entry in H
- matching KEY, or -1 if not found. */
+ h->next = hash_table_alloc_bytes (size * sizeof *h->next);
-ptrdiff_t
-hash_lookup (struct Lisp_Hash_Table *h, Lisp_Object key, Lisp_Object *hash)
-{
- ptrdiff_t start_of_bucket, i;
-
- Lisp_Object hash_code;
- hash_code = h->test.hashfn (key, h);
- if (hash)
- *hash = hash_code;
+ ptrdiff_t index_size = hash_table_index_size (h);
+ h->index = hash_table_alloc_bytes (index_size * sizeof *h->index);
+ for (ptrdiff_t i = 0; i < index_size; i++)
+ h->index[i] = -1;
- start_of_bucket = XUFIXNUM (hash_code) % ASIZE (h->index);
+ /* Recompute the hash codes for each entry in the table. */
+ for (ptrdiff_t i = 0; i < size; i++)
+ {
+ Lisp_Object key = HASH_KEY (h, i);
+ hash_hash_t hash_code = hash_from_key (h, key);
+ ptrdiff_t start_of_bucket = hash_index_index (h, hash_code);
+ set_hash_hash_slot (h, i, hash_code);
+ set_hash_next_slot (h, i, HASH_INDEX (h, start_of_bucket));
+ set_hash_index_slot (h, start_of_bucket, i);
+ }
+ }
+}
- for (i = HASH_INDEX (h, start_of_bucket); 0 <= i; i = HASH_NEXT (h, i))
+/* Look up KEY with hash HASH in table H.
+ Return entry index or -1 if none. */
+static ptrdiff_t
+hash_lookup_with_hash (struct Lisp_Hash_Table *h,
+ Lisp_Object key, hash_hash_t hash)
+{
+ ptrdiff_t start_of_bucket = hash_index_index (h, hash);
+ for (ptrdiff_t i = HASH_INDEX (h, start_of_bucket);
+ 0 <= i; i = HASH_NEXT (h, i))
if (EQ (key, HASH_KEY (h, i))
- || (h->test.cmpfn
- && EQ (hash_code, HASH_HASH (h, i))
- && !NILP (h->test.cmpfn (key, HASH_KEY (h, i), h))))
- break;
+ || (h->test->cmpfn
+ && hash == HASH_HASH (h, i)
+ && !NILP (h->test->cmpfn (key, HASH_KEY (h, i), h))))
+ return i;
- return i;
+ return -1;
+}
+
+/* Look up KEY in table H. Return entry index or -1 if none. */
+ptrdiff_t
+hash_lookup (struct Lisp_Hash_Table *h, Lisp_Object key)
+{
+ return hash_lookup_with_hash (h, key, hash_from_key (h, key));
+}
+
+/* Look up KEY in hash table H. Return its hash value in *PHASH.
+ Value is the index of the entry in H matching KEY, or -1 if not found. */
+ptrdiff_t
+hash_lookup_get_hash (struct Lisp_Hash_Table *h, Lisp_Object key,
+ hash_hash_t *phash)
+{
+ EMACS_UINT hash = hash_from_key (h, key);
+ *phash = hash;
+ return hash_lookup_with_hash (h, key, hash);
}
static void
@@ -4716,33 +5120,22 @@ check_mutable_hash_table (Lisp_Object obj, struct Lisp_Hash_Table *h)
eassert (!PURE_P (h));
}
-static void
-collect_interval (INTERVAL interval, Lisp_Object collector)
-{
- nconc2 (collector,
- list1(list3 (make_fixnum (interval->position),
- make_fixnum (interval->position + LENGTH (interval)),
- interval->plist)));
-}
-
/* Put an entry into hash table H that associates KEY with VALUE.
HASH is a previously computed hash code of KEY.
Value is the index of the entry in H matching KEY. */
ptrdiff_t
hash_put (struct Lisp_Hash_Table *h, Lisp_Object key, Lisp_Object value,
- Lisp_Object hash)
+ hash_hash_t hash)
{
- ptrdiff_t start_of_bucket, i;
-
+ eassert (!hash_unused_entry_key_p (key));
/* Increment count after resizing because resizing may fail. */
maybe_resize_hash_table (h);
h->count++;
/* Store key/value in the key_and_value vector. */
- i = h->next_free;
- eassert (NILP (HASH_HASH (h, i)));
- eassert (BASE_EQ (Qunbound, (HASH_KEY (h, i))));
+ ptrdiff_t i = h->next_free;
+ eassert (hash_unused_entry_key_p (HASH_KEY (h, i)));
h->next_free = HASH_NEXT (h, i);
set_hash_key_slot (h, i, key);
set_hash_value_slot (h, i, value);
@@ -4751,7 +5144,7 @@ hash_put (struct Lisp_Hash_Table *h, Lisp_Object key, Lisp_Object value,
set_hash_hash_slot (h, i, hash);
/* Add new entry to its collision chain. */
- start_of_bucket = XUFIXNUM (hash) % ASIZE (h->index);
+ ptrdiff_t start_of_bucket = hash_index_index (h, hash);
set_hash_next_slot (h, i, HASH_INDEX (h, start_of_bucket));
set_hash_index_slot (h, start_of_bucket, i);
return i;
@@ -4763,8 +5156,8 @@ hash_put (struct Lisp_Hash_Table *h, Lisp_Object key, Lisp_Object value,
void
hash_remove_from_table (struct Lisp_Hash_Table *h, Lisp_Object key)
{
- Lisp_Object hash_code = h->test.hashfn (key, h);
- ptrdiff_t start_of_bucket = XUFIXNUM (hash_code) % ASIZE (h->index);
+ hash_hash_t hashval = hash_from_key (h, key);
+ ptrdiff_t start_of_bucket = hash_index_index (h, hashval);
ptrdiff_t prev = -1;
for (ptrdiff_t i = HASH_INDEX (h, start_of_bucket);
@@ -4772,9 +5165,9 @@ hash_remove_from_table (struct Lisp_Hash_Table *h, Lisp_Object key)
i = HASH_NEXT (h, i))
{
if (EQ (key, HASH_KEY (h, i))
- || (h->test.cmpfn
- && EQ (hash_code, HASH_HASH (h, i))
- && !NILP (h->test.cmpfn (key, HASH_KEY (h, i), h))))
+ || (h->test->cmpfn
+ && hashval == HASH_HASH (h, i)
+ && !NILP (h->test->cmpfn (key, HASH_KEY (h, i), h))))
{
/* Take entry out of collision chain. */
if (prev < 0)
@@ -4784,9 +5177,8 @@ hash_remove_from_table (struct Lisp_Hash_Table *h, Lisp_Object key)
/* Clear slots in key_and_value and add the slots to
the free list. */
- set_hash_key_slot (h, i, Qunbound);
+ set_hash_key_slot (h, i, HASH_UNUSED_ENTRY_KEY);
set_hash_value_slot (h, i, Qnil);
- set_hash_hash_slot (h, i, Qnil);
set_hash_next_slot (h, i, h->next_free);
h->next_free = i;
h->count--;
@@ -4807,16 +5199,16 @@ hash_clear (struct Lisp_Hash_Table *h)
if (h->count > 0)
{
ptrdiff_t size = HASH_TABLE_SIZE (h);
- memclear (xvector_contents (h->hash), size * word_size);
for (ptrdiff_t i = 0; i < size; i++)
{
set_hash_next_slot (h, i, i < size - 1 ? i + 1 : -1);
- set_hash_key_slot (h, i, Qunbound);
+ set_hash_key_slot (h, i, HASH_UNUSED_ENTRY_KEY);
set_hash_value_slot (h, i, Qnil);
}
- for (ptrdiff_t i = 0; i < ASIZE (h->index); i++)
- ASET (h->index, i, make_fixnum (-1));
+ ptrdiff_t index_size = hash_table_index_size (h);
+ for (ptrdiff_t i = 0; i < index_size; i++)
+ h->index[i] = -1;
h->next_free = 0;
h->count = 0;
@@ -4829,6 +5221,23 @@ hash_clear (struct Lisp_Hash_Table *h)
Weak Hash Tables
************************************************************************/
+/* Whether to keep an entry whose key and value are known to be retained
+ if STRONG_KEY and STRONG_VALUE, respectively, are true. */
+static inline bool
+keep_entry_p (hash_table_weakness_t weakness,
+ bool strong_key, bool strong_value)
+{
+ switch (weakness)
+ {
+ case Weak_None: return true;
+ case Weak_Key: return strong_key;
+ case Weak_Value: return strong_value;
+ case Weak_Key_Or_Value: return strong_key || strong_value;
+ case Weak_Key_And_Value: return strong_key && strong_value;
+ }
+ emacs_abort();
+}
+
/* Sweep weak hash table H. REMOVE_ENTRIES_P means remove
entries from the table that don't survive the current GC.
!REMOVE_ENTRIES_P means mark entries that are in use. Value is
@@ -4837,7 +5246,7 @@ hash_clear (struct Lisp_Hash_Table *h)
bool
sweep_weak_table (struct Lisp_Hash_Table *h, bool remove_entries_p)
{
- ptrdiff_t n = gc_asize (h->index);
+ ptrdiff_t n = hash_table_index_size (h);
bool marked = false;
for (ptrdiff_t bucket = 0; bucket < n; ++bucket)
@@ -4850,18 +5259,9 @@ sweep_weak_table (struct Lisp_Hash_Table *h, bool remove_entries_p)
{
bool key_known_to_survive_p = survives_gc_p (HASH_KEY (h, i));
bool value_known_to_survive_p = survives_gc_p (HASH_VALUE (h, i));
- bool remove_p;
-
- if (EQ (h->weak, Qkey))
- remove_p = !key_known_to_survive_p;
- else if (EQ (h->weak, Qvalue))
- remove_p = !value_known_to_survive_p;
- else if (EQ (h->weak, Qkey_or_value))
- remove_p = !(key_known_to_survive_p || value_known_to_survive_p);
- else if (EQ (h->weak, Qkey_and_value))
- remove_p = !(key_known_to_survive_p && value_known_to_survive_p);
- else
- emacs_abort ();
+ bool remove_p = !keep_entry_p (h->weakness,
+ key_known_to_survive_p,
+ value_known_to_survive_p);
next = HASH_NEXT (h, i);
@@ -4881,11 +5281,9 @@ sweep_weak_table (struct Lisp_Hash_Table *h, bool remove_entries_p)
set_hash_next_slot (h, i, h->next_free);
h->next_free = i;
- /* Clear key, value, and hash. */
- set_hash_key_slot (h, i, Qunbound);
+ /* Clear key and value. */
+ set_hash_key_slot (h, i, HASH_UNUSED_ENTRY_KEY);
set_hash_value_slot (h, i, Qnil);
- if (!NILP (h->hash))
- set_hash_hash_slot (h, i, Qnil);
eassert (h->count != 0);
h->count--;
@@ -4944,39 +5342,57 @@ hash_string (char const *ptr, ptrdiff_t len)
EMACS_UINT hash = len;
/* At most 8 steps. We could reuse SXHASH_MAX_LEN, of course,
* but dividing by 8 is cheaper. */
- ptrdiff_t step = sizeof hash + ((end - p) >> 3);
+ ptrdiff_t step = max (sizeof hash, ((end - p) >> 3));
- while (p + sizeof hash <= end)
+ if (p + sizeof hash <= end)
{
+ do
+ {
+ EMACS_UINT c;
+ /* We presume that the compiler will replace this `memcpy` with
+ a single load/move instruction when applicable. */
+ memcpy (&c, p, sizeof hash);
+ p += step;
+ hash = sxhash_combine (hash, c);
+ }
+ while (p + sizeof hash <= end);
+ /* Hash the last wordful of bytes in the string, because that is
+ is often the part where strings differ. This may cause some
+ bytes to be hashed twice but we assume that's not a big problem. */
EMACS_UINT c;
- /* We presume that the compiler will replace this `memcpy` with
- a single load/move instruction when applicable. */
- memcpy (&c, p, sizeof hash);
- p += step;
+ memcpy (&c, end - sizeof c, sizeof c);
hash = sxhash_combine (hash, c);
}
- /* A few last bytes may remain (smaller than an EMACS_UINT). */
- /* FIXME: We could do this without a loop, but it'd require
- endian-dependent code :-( */
- while (p < end)
+ else
{
- unsigned char c = *p++;
- hash = sxhash_combine (hash, c);
+ /* String is shorter than an EMACS_UINT. Use smaller loads. */
+ eassume (p <= end && end - p < sizeof (EMACS_UINT));
+ EMACS_UINT tail = 0;
+ verify (sizeof tail <= 8);
+#if EMACS_INT_MAX > INT32_MAX
+ if (end - p >= 4)
+ {
+ uint32_t c;
+ memcpy (&c, p, sizeof c);
+ tail = (tail << (8 * sizeof c)) + c;
+ p += sizeof c;
+ }
+#endif
+ if (end - p >= 2)
+ {
+ uint16_t c;
+ memcpy (&c, p, sizeof c);
+ tail = (tail << (8 * sizeof c)) + c;
+ p += sizeof c;
+ }
+ if (p < end)
+ tail = (tail << 8) + (unsigned char)*p;
+ hash = sxhash_combine (hash, tail);
}
return hash;
}
-/* Return a hash for string PTR which has length LEN. The hash
- code returned is at most INTMASK. */
-
-static EMACS_UINT
-sxhash_string (char const *ptr, ptrdiff_t len)
-{
- EMACS_UINT hash = hash_string (ptr, len);
- return SXHASH_REDUCE (hash);
-}
-
/* Return a hash for the floating point value VAL. */
static EMACS_UINT
@@ -4986,7 +5402,7 @@ sxhash_float (double val)
union double_and_words u = { .val = val };
for (int i = 0; i < WORDS_PER_DOUBLE; i++)
hash = sxhash_combine (hash, u.word[i]);
- return SXHASH_REDUCE (hash);
+ return hash;
}
/* Return a hash for list LIST. DEPTH is the current depth in the
@@ -5013,7 +5429,7 @@ sxhash_list (Lisp_Object list, int depth)
hash = sxhash_combine (hash, hash2);
}
- return SXHASH_REDUCE (hash);
+ return hash;
}
@@ -5033,7 +5449,7 @@ sxhash_vector (Lisp_Object vec, int depth)
hash = sxhash_combine (hash, hash2);
}
- return SXHASH_REDUCE (hash);
+ return hash;
}
/* Return a hash for bool-vector VECTOR. */
@@ -5049,7 +5465,7 @@ sxhash_bool_vector (Lisp_Object vec)
for (i = 0; i < n; ++i)
hash = sxhash_combine (hash, bool_vector_data (vec)[i]);
- return SXHASH_REDUCE (hash);
+ return hash;
}
/* Return a hash for a bignum. */
@@ -5059,24 +5475,23 @@ sxhash_bignum (Lisp_Object bignum)
{
mpz_t const *n = xbignum_val (bignum);
size_t i, nlimbs = mpz_size (*n);
- EMACS_UINT hash = 0;
+ EMACS_UINT hash = mpz_sgn(*n) < 0;
for (i = 0; i < nlimbs; ++i)
hash = sxhash_combine (hash, mpz_getlimbn (*n, i));
- return SXHASH_REDUCE (hash);
+ return hash;
}
-
-/* Return a hash code for OBJ. DEPTH is the current depth in the Lisp
- structure. Value is an unsigned integer clipped to INTMASK. */
-
EMACS_UINT
sxhash (Lisp_Object obj)
{
return sxhash_obj (obj, 0);
}
+/* Return a hash code for OBJ. DEPTH is the current depth in the Lisp
+ structure. */
+
static EMACS_UINT
sxhash_obj (Lisp_Object obj, int depth)
{
@@ -5092,7 +5507,7 @@ sxhash_obj (Lisp_Object obj, int depth)
return XHASH (obj);
case Lisp_String:
- return sxhash_string (SSDATA (obj), SBYTES (obj));
+ return hash_string (SSDATA (obj), SBYTES (obj));
case Lisp_Vectorlike:
{
@@ -5119,7 +5534,7 @@ sxhash_obj (Lisp_Object obj, int depth)
= XMARKER (obj)->buffer ? XMARKER (obj)->bytepos : 0;
EMACS_UINT hash
= sxhash_combine ((intptr_t) XMARKER (obj)->buffer, bytepos);
- return SXHASH_REDUCE (hash);
+ return hash;
}
else if (pvec_type == PVEC_BOOL_VECTOR)
return sxhash_bool_vector (obj);
@@ -5128,14 +5543,17 @@ sxhash_obj (Lisp_Object obj, int depth)
EMACS_UINT hash = OVERLAY_START (obj);
hash = sxhash_combine (hash, OVERLAY_END (obj));
hash = sxhash_combine (hash, sxhash_obj (XOVERLAY (obj)->plist, depth));
- return SXHASH_REDUCE (hash);
+ return hash;
}
- else if (symbols_with_pos_enabled && pvec_type == PVEC_SYMBOL_WITH_POS)
- return sxhash_obj (XSYMBOL_WITH_POS (obj)->sym, depth + 1);
else
- /* Others are 'equal' if they are 'eq', so take their
- address as hash. */
- return XHASH (obj);
+ {
+ if (symbols_with_pos_enabled && pvec_type == PVEC_SYMBOL_WITH_POS)
+ obj = XSYMBOL_WITH_POS_SYM (obj);
+
+ /* Others are 'equal' if they are 'eq', so take their
+ address as hash. */
+ return XHASH (obj);
+ }
}
case Lisp_Cons:
@@ -5149,12 +5567,41 @@ sxhash_obj (Lisp_Object obj, int depth)
}
}
+static void
+hash_interval (INTERVAL interval, void *arg)
+{
+ EMACS_UINT *phash = arg;
+ EMACS_UINT hash = *phash;
+ hash = sxhash_combine (hash, interval->position);
+ hash = sxhash_combine (hash, LENGTH (interval));
+ hash = sxhash_combine (hash, sxhash_obj (interval->plist, 0));
+ *phash = hash;
+}
+
+static void
+collect_interval (INTERVAL interval, void *arg)
+{
+ Lisp_Object *collector = arg;
+ *collector = Fcons (list3 (make_fixnum (interval->position),
+ make_fixnum (interval->position
+ + LENGTH (interval)),
+ interval->plist),
+ *collector);
+}
+
/***********************************************************************
Lisp Interface
***********************************************************************/
+/* Reduce the hash value X to a Lisp fixnum. */
+static inline Lisp_Object
+reduce_emacs_uint_to_fixnum (EMACS_UINT x)
+{
+ return make_ufixnum (SXHASH_REDUCE (x));
+}
+
DEFUN ("sxhash-eq", Fsxhash_eq, Ssxhash_eq, 1, 1, 0,
doc: /* Return an integer hash code for OBJ suitable for `eq'.
If (eq A B), then (= (sxhash-eq A) (sxhash-eq B)).
@@ -5162,7 +5609,7 @@ If (eq A B), then (= (sxhash-eq A) (sxhash-eq B)).
Hash codes are not guaranteed to be preserved across Emacs sessions. */)
(Lisp_Object obj)
{
- return hashfn_eq (obj, NULL);
+ return reduce_emacs_uint_to_fixnum (sxhash_eq (obj));
}
DEFUN ("sxhash-eql", Fsxhash_eql, Ssxhash_eql, 1, 1, 0,
@@ -5173,7 +5620,7 @@ isn't necessarily true.
Hash codes are not guaranteed to be preserved across Emacs sessions. */)
(Lisp_Object obj)
{
- return hashfn_eql (obj, NULL);
+ return reduce_emacs_uint_to_fixnum (sxhash_eql (obj));
}
DEFUN ("sxhash-equal", Fsxhash_equal, Ssxhash_equal, 1, 1, 0,
@@ -5184,7 +5631,7 @@ opposite isn't necessarily true.
Hash codes are not guaranteed to be preserved across Emacs sessions. */)
(Lisp_Object obj)
{
- return hashfn_equal (obj, NULL);
+ return reduce_emacs_uint_to_fixnum (sxhash (obj));
}
DEFUN ("sxhash-equal-including-properties", Fsxhash_equal_including_properties,
@@ -5197,18 +5644,65 @@ If (sxhash-equal-including-properties A B), then
Hash codes are not guaranteed to be preserved across Emacs sessions. */)
(Lisp_Object obj)
{
+ EMACS_UINT hash = sxhash (obj);
if (STRINGP (obj))
+ traverse_intervals (string_intervals (obj), 0, hash_interval, &hash);
+ return reduce_emacs_uint_to_fixnum (hash);
+}
+
+
+/* This is a cache of hash_table_test structures so that they can be
+ shared between hash tables using the same test.
+ FIXME: This way of storing and looking up hash_table_test structs
+ isn't wonderful. Find a better solution. */
+struct hash_table_user_test
+{
+ struct hash_table_test test;
+ struct hash_table_user_test *next;
+};
+
+static struct hash_table_user_test *hash_table_user_tests = NULL;
+
+void
+mark_fns (void)
+{
+ for (struct hash_table_user_test *ut = hash_table_user_tests;
+ ut; ut = ut->next)
{
- Lisp_Object collector = Fcons (Qnil, Qnil);
- traverse_intervals (string_intervals (obj), 0, collect_interval,
- collector);
- return
- make_ufixnum (
- SXHASH_REDUCE (sxhash_combine (sxhash (obj),
- sxhash (CDR (collector)))));
+ mark_object (ut->test.name);
+ mark_object (ut->test.user_cmp_function);
+ mark_object (ut->test.user_hash_function);
}
+}
+
+/* Find the hash_table_test object corresponding to the (bare) symbol TEST,
+ creating one if none existed. */
+static struct hash_table_test *
+get_hash_table_user_test (Lisp_Object test)
+{
+ Lisp_Object prop = Fget (test, Qhash_table_test);
+ if (!CONSP (prop) || !CONSP (XCDR (prop)))
+ signal_error ("Invalid hash table test", test);
- return hashfn_equal (obj, NULL);
+ Lisp_Object equal_fn = XCAR (prop);
+ Lisp_Object hash_fn = XCAR (XCDR (prop));
+ struct hash_table_user_test *ut = hash_table_user_tests;
+ while (ut && !(BASE_EQ (test, ut->test.name)
+ && EQ (equal_fn, ut->test.user_cmp_function)
+ && EQ (hash_fn, ut->test.user_hash_function)))
+ ut = ut->next;
+ if (!ut)
+ {
+ ut = xmalloc (sizeof *ut);
+ ut->test.name = test;
+ ut->test.user_cmp_function = equal_fn;
+ ut->test.user_hash_function = hash_fn;
+ ut->test.hashfn = hashfn_user_defined;
+ ut->test.cmpfn = cmpfn_user_defined;
+ ut->next = hash_table_user_tests;
+ hash_table_user_tests = ut;
+ }
+ return &ut->test;
}
DEFUN ("make-hash-table", Fmake_hash_table, Smake_hash_table, 0, MANY, 0,
@@ -5223,16 +5717,8 @@ keys. Default is `eql'. Predefined are the tests `eq', `eql', and
`define-hash-table-test'.
:size SIZE -- A hint as to how many elements will be put in the table.
-Default is 65.
-
-:rehash-size REHASH-SIZE - Indicates how to expand the table when it
-fills up. If REHASH-SIZE is an integer, increase the size by that
-amount. If it is a float, it must be > 1.0, and the new size is the
-old size multiplied by that factor. Default is 1.5.
-
-:rehash-threshold THRESHOLD -- THRESHOLD must a float > 0, and <= 1.0.
-Resize the hash table when the ratio (table entries / table size)
-exceeds an approximation to THRESHOLD. Default is 0.8125.
+The table will always grow as needed; this argument may help performance
+slightly if the size is known in advance but is never required.
:weakness WEAK -- WEAK must be one of nil, t, `key', `value',
`key-or-value', or `key-and-value'. If WEAK is not nil, the table
@@ -5247,13 +5733,12 @@ to pure storage when Emacs is being dumped, making the contents of the
table read only. Any further changes to purified tables will result
in an error.
+The keywords arguments :rehash-threshold and :rehash-size are obsolete
+and ignored.
+
usage: (make-hash-table &rest KEYWORD-ARGS) */)
(ptrdiff_t nargs, Lisp_Object *args)
{
- Lisp_Object test, weak;
- bool purecopy;
- struct hash_table_test testdesc;
- ptrdiff_t i;
USE_SAFE_ALLOCA;
/* The vector `used' is used to keep track of arguments that
@@ -5262,32 +5747,21 @@ usage: (make-hash-table &rest KEYWORD-ARGS) */)
memset (used, 0, nargs * sizeof *used);
/* See if there's a `:test TEST' among the arguments. */
- i = get_key_arg (QCtest, nargs, args, used);
- test = i ? args[i] : Qeql;
- if (EQ (test, Qeq))
- testdesc = hashtest_eq;
- else if (EQ (test, Qeql))
- testdesc = hashtest_eql;
- else if (EQ (test, Qequal))
- testdesc = hashtest_equal;
+ ptrdiff_t i = get_key_arg (QCtest, nargs, args, used);
+ Lisp_Object test = i ? maybe_remove_pos_from_symbol (args[i]) : Qeql;
+ const struct hash_table_test *testdesc;
+ if (BASE_EQ (test, Qeq))
+ testdesc = &hashtest_eq;
+ else if (BASE_EQ (test, Qeql))
+ testdesc = &hashtest_eql;
+ else if (BASE_EQ (test, Qequal))
+ testdesc = &hashtest_equal;
else
- {
- /* See if it is a user-defined test. */
- Lisp_Object prop;
-
- prop = Fget (test, Qhash_table_test);
- if (!CONSP (prop) || !CONSP (XCDR (prop)))
- signal_error ("Invalid hash table test", test);
- testdesc.name = test;
- testdesc.user_cmp_function = XCAR (prop);
- testdesc.user_hash_function = XCAR (XCDR (prop));
- testdesc.hashfn = hashfn_user_defined;
- testdesc.cmpfn = cmpfn_user_defined;
- }
+ testdesc = get_hash_table_user_test (test);
/* See if there's a `:purecopy PURECOPY' argument. */
i = get_key_arg (QCpurecopy, nargs, args, used);
- purecopy = i && !NILP (args[i]);
+ bool purecopy = i && !NILP (args[i]);
/* See if there's a `:size SIZE' argument. */
i = get_key_arg (QCsize, nargs, args, used);
Lisp_Object size_arg = i ? args[i] : Qnil;
@@ -5299,46 +5773,36 @@ usage: (make-hash-table &rest KEYWORD-ARGS) */)
else
signal_error ("Invalid hash table size", size_arg);
- /* Look for `:rehash-size SIZE'. */
- float rehash_size;
- i = get_key_arg (QCrehash_size, nargs, args, used);
- if (!i)
- rehash_size = DEFAULT_REHASH_SIZE;
- else if (FIXNUMP (args[i]) && 0 < XFIXNUM (args[i]))
- rehash_size = - XFIXNUM (args[i]);
- else if (FLOATP (args[i]) && 0 < (float) (XFLOAT_DATA (args[i]) - 1))
- rehash_size = (float) (XFLOAT_DATA (args[i]) - 1);
- else
- signal_error ("Invalid hash table rehash size", args[i]);
-
- /* Look for `:rehash-threshold THRESHOLD'. */
- i = get_key_arg (QCrehash_threshold, nargs, args, used);
- float rehash_threshold = (!i ? DEFAULT_REHASH_THRESHOLD
- : !FLOATP (args[i]) ? 0
- : (float) XFLOAT_DATA (args[i]));
- if (! (0 < rehash_threshold && rehash_threshold <= 1))
- signal_error ("Invalid hash table rehash threshold", args[i]);
-
/* Look for `:weakness WEAK'. */
i = get_key_arg (QCweakness, nargs, args, used);
- weak = i ? args[i] : Qnil;
- if (EQ (weak, Qt))
- weak = Qkey_and_value;
- if (!NILP (weak)
- && !EQ (weak, Qkey)
- && !EQ (weak, Qvalue)
- && !EQ (weak, Qkey_or_value)
- && !EQ (weak, Qkey_and_value))
- signal_error ("Invalid hash table weakness", weak);
+ Lisp_Object weakness = i ? args[i] : Qnil;
+ hash_table_weakness_t weak;
+ if (NILP (weakness))
+ weak = Weak_None;
+ else if (EQ (weakness, Qkey))
+ weak = Weak_Key;
+ else if (EQ (weakness, Qvalue))
+ weak = Weak_Value;
+ else if (EQ (weakness, Qkey_or_value))
+ weak = Weak_Key_Or_Value;
+ else if (EQ (weakness, Qt) || EQ (weakness, Qkey_and_value))
+ weak = Weak_Key_And_Value;
+ else
+ signal_error ("Invalid hash table weakness", weakness);
/* Now, all args should have been used up, or there's a problem. */
for (i = 0; i < nargs; ++i)
if (!used[i])
- signal_error ("Invalid argument list", args[i]);
+ {
+ /* Ignore obsolete arguments. */
+ if (EQ (args[i], QCrehash_threshold) || EQ (args[i], QCrehash_size))
+ i++;
+ else
+ signal_error ("Invalid argument list", args[i]);
+ }
SAFE_FREE ();
- return make_hash_table (testdesc, size, rehash_size, rehash_threshold, weak,
- purecopy);
+ return make_hash_table (testdesc, size, weak, purecopy);
}
@@ -5361,34 +5825,37 @@ DEFUN ("hash-table-count", Fhash_table_count, Shash_table_count, 1, 1, 0,
DEFUN ("hash-table-rehash-size", Fhash_table_rehash_size,
Shash_table_rehash_size, 1, 1, 0,
- doc: /* Return the current rehash size of TABLE. */)
+ doc: /* Return the rehash size of TABLE.
+This function is for compatibility only; it returns a nominal value
+without current significance. */)
(Lisp_Object table)
{
- double rehash_size = check_hash_table (table)->rehash_size;
- if (rehash_size < 0)
- {
- EMACS_INT s = -rehash_size;
- return make_fixnum (min (s, MOST_POSITIVE_FIXNUM));
- }
- else
- return make_float (rehash_size + 1);
+ CHECK_HASH_TABLE (table);
+ return make_float (1.5); /* The old default rehash-size value. */
}
DEFUN ("hash-table-rehash-threshold", Fhash_table_rehash_threshold,
Shash_table_rehash_threshold, 1, 1, 0,
- doc: /* Return the current rehash threshold of TABLE. */)
+ doc: /* Return the rehash threshold of TABLE.
+This function is for compatibility only; it returns a nominal value
+without current significance. */)
(Lisp_Object table)
{
- return make_float (check_hash_table (table)->rehash_threshold);
+ CHECK_HASH_TABLE (table);
+ return make_float (0.8125); /* The old default rehash-threshold value. */
}
DEFUN ("hash-table-size", Fhash_table_size, Shash_table_size, 1, 1, 0,
- doc: /* Return the size of TABLE.
-The size can be used as an argument to `make-hash-table' to create
-a hash table than can hold as many elements as TABLE holds
-without need for resizing. */)
+ doc: /* Return the current allocation size of TABLE.
+
+This is probably not the function that you are looking for. To get the
+number of entries in a table, use `hash-table-count' instead.
+
+The returned value is the number of entries that TABLE can currently
+hold without growing, but since hash tables grow automatically, this
+number is rarely of interest. */)
(Lisp_Object table)
{
struct Lisp_Hash_Table *h = check_hash_table (table);
@@ -5400,16 +5867,29 @@ DEFUN ("hash-table-test", Fhash_table_test, Shash_table_test, 1, 1, 0,
doc: /* Return the test TABLE uses. */)
(Lisp_Object table)
{
- return check_hash_table (table)->test.name;
+ return check_hash_table (table)->test->name;
}
+Lisp_Object
+hash_table_weakness_symbol (hash_table_weakness_t weak)
+{
+ switch (weak)
+ {
+ case Weak_None: return Qnil;
+ case Weak_Key: return Qkey;
+ case Weak_Value: return Qvalue;
+ case Weak_Key_And_Value: return Qkey_and_value;
+ case Weak_Key_Or_Value: return Qkey_or_value;
+ }
+ emacs_abort ();
+}
DEFUN ("hash-table-weakness", Fhash_table_weakness, Shash_table_weakness,
1, 1, 0,
doc: /* Return the weakness of TABLE. */)
(Lisp_Object table)
{
- return check_hash_table (table)->weak;
+ return hash_table_weakness_symbol (check_hash_table (table)->weakness);
}
@@ -5439,7 +5919,7 @@ If KEY is not found, return DFLT which defaults to nil. */)
(Lisp_Object key, Lisp_Object table, Lisp_Object dflt)
{
struct Lisp_Hash_Table *h = check_hash_table (table);
- ptrdiff_t i = hash_lookup (h, key, NULL);
+ ptrdiff_t i = hash_lookup (h, key);
return i >= 0 ? HASH_VALUE (h, i) : dflt;
}
@@ -5453,8 +5933,8 @@ VALUE. In any case, return VALUE. */)
struct Lisp_Hash_Table *h = check_hash_table (table);
check_mutable_hash_table (table, h);
- Lisp_Object hash;
- ptrdiff_t i = hash_lookup (h, key, &hash);
+ EMACS_UINT hash = hash_from_key (h, key);
+ ptrdiff_t i = hash_lookup_with_hash (h, key, hash);
if (i >= 0)
set_hash_value_slot (h, i, value);
else
@@ -5478,18 +5958,17 @@ DEFUN ("remhash", Fremhash, Sremhash, 2, 2, 0,
DEFUN ("maphash", Fmaphash, Smaphash, 2, 2, 0,
doc: /* Call FUNCTION for all entries in hash table TABLE.
FUNCTION is called with two arguments, KEY and VALUE.
+It should not alter TABLE in any way other than using `puthash' to
+set a new value for KEY, or `remhash' to remove KEY.
`maphash' always returns nil. */)
(Lisp_Object function, Lisp_Object table)
{
struct Lisp_Hash_Table *h = check_hash_table (table);
-
- for (ptrdiff_t i = 0; i < HASH_TABLE_SIZE (h); ++i)
- {
- Lisp_Object k = HASH_KEY (h, i);
- if (!BASE_EQ (k, Qunbound))
- call2 (function, k, HASH_VALUE (h, i));
- }
-
+ /* We can't use DOHASH here since FUNCTION may violate the rules and
+ we shouldn't crash as a result (although the effects are
+ unpredictable). */
+ DOHASH_SAFE (h, i)
+ call2 (function, HASH_KEY (h, i), HASH_VALUE (h, i));
return Qnil;
}
@@ -5511,6 +5990,67 @@ returns nil, then (funcall TEST x1 x2) also returns nil. */)
return Fput (name, Qhash_table_test, list2 (test, hash));
}
+DEFUN ("internal--hash-table-histogram",
+ Finternal__hash_table_histogram,
+ Sinternal__hash_table_histogram,
+ 1, 1, 0,
+ doc: /* Bucket size histogram of HASH-TABLE. Internal use only. */)
+ (Lisp_Object hash_table)
+{
+ struct Lisp_Hash_Table *h = check_hash_table (hash_table);
+ ptrdiff_t size = HASH_TABLE_SIZE (h);
+ ptrdiff_t *freq = xzalloc (size * sizeof *freq);
+ ptrdiff_t index_size = hash_table_index_size (h);
+ for (ptrdiff_t i = 0; i < index_size; i++)
+ {
+ ptrdiff_t n = 0;
+ for (ptrdiff_t j = HASH_INDEX (h, i); j != -1; j = HASH_NEXT (h, j))
+ n++;
+ if (n > 0)
+ freq[n - 1]++;
+ }
+ Lisp_Object ret = Qnil;
+ for (ptrdiff_t i = 0; i < size; i++)
+ if (freq[i] > 0)
+ ret = Fcons (Fcons (make_int (i + 1), make_int (freq[i])),
+ ret);
+ xfree (freq);
+ return Fnreverse (ret);
+}
+
+DEFUN ("internal--hash-table-buckets",
+ Finternal__hash_table_buckets,
+ Sinternal__hash_table_buckets,
+ 1, 1, 0,
+ doc: /* (KEY . HASH) in HASH-TABLE, grouped by bucket.
+Internal use only. */)
+ (Lisp_Object hash_table)
+{
+ struct Lisp_Hash_Table *h = check_hash_table (hash_table);
+ Lisp_Object ret = Qnil;
+ ptrdiff_t index_size = hash_table_index_size (h);
+ for (ptrdiff_t i = 0; i < index_size; i++)
+ {
+ Lisp_Object bucket = Qnil;
+ for (ptrdiff_t j = HASH_INDEX (h, i); j != -1; j = HASH_NEXT (h, j))
+ bucket = Fcons (Fcons (HASH_KEY (h, j), make_int (HASH_HASH (h, j))),
+ bucket);
+ if (!NILP (bucket))
+ ret = Fcons (Fnreverse (bucket), ret);
+ }
+ return Fnreverse (ret);
+}
+
+DEFUN ("internal--hash-table-index-size",
+ Finternal__hash_table_index_size,
+ Sinternal__hash_table_index_size,
+ 1, 1, 0,
+ doc: /* Index size of HASH-TABLE. Internal use only. */)
+ (Lisp_Object hash_table)
+{
+ struct Lisp_Hash_Table *h = check_hash_table (hash_table);
+ return make_int (hash_table_index_size (h));
+}
/************************************************************************
@@ -6093,7 +6633,6 @@ Altering this copy does not change the layout of the text properties
in OBJECT. */)
(register Lisp_Object object)
{
- Lisp_Object collector = Fcons (Qnil, Qnil);
INTERVAL intervals;
if (STRINGP (object))
@@ -6106,8 +6645,9 @@ in OBJECT. */)
if (! intervals)
return Qnil;
- traverse_intervals (intervals, 0, collect_interval, collector);
- return CDR (collector);
+ Lisp_Object collector = Qnil;
+ traverse_intervals (intervals, 0, collect_interval, &collector);
+ return Fnreverse (collector);
}
DEFUN ("line-number-at-pos", Fline_number_at_pos,
@@ -6201,6 +6741,9 @@ syms_of_fns (void)
defsubr (&Sremhash);
defsubr (&Smaphash);
defsubr (&Sdefine_hash_table_test);
+ defsubr (&Sinternal__hash_table_histogram);
+ defsubr (&Sinternal__hash_table_buckets);
+ defsubr (&Sinternal__hash_table_index_size);
defsubr (&Sstring_search);
defsubr (&Sobject_intervals);
defsubr (&Sline_number_at_pos);
@@ -6281,9 +6824,15 @@ When non-nil, `yes-or-no-p' will use `y-or-n-p' to read the answer.
We recommend against setting this variable non-nil, because `yes-or-no-p'
is intended to be used when users are expected not to respond too
quickly, but to take their time and perhaps think about the answer.
-The same variable also affects the function `read-answer'. */);
+The same variable also affects the function `read-answer'. See also
+`yes-or-no-prompt'. */);
use_short_answers = false;
+ DEFVAR_LISP ("yes-or-no-prompt", Vyes_or_no_prompt,
+ doc: /* String to append when `yes-or-no-p' asks a question.
+For best results this should end in a space. */);
+ Vyes_or_no_prompt = build_unibyte_string ("(yes or no) ");
+
defsubr (&Sidentity);
defsubr (&Srandom);
defsubr (&Slength);
@@ -6337,6 +6886,7 @@ The same variable also affects the function `read-answer'. */);
defsubr (&Seql);
defsubr (&Sequal);
defsubr (&Sequal_including_properties);
+ defsubr (&Svaluelt);
defsubr (&Sfillarray);
defsubr (&Sclear_string);
defsubr (&Snconc);
@@ -6368,4 +6918,12 @@ The same variable also affects the function `read-answer'. */);
DEFSYM (Qreal_this_command, "real-this-command");
DEFSYM (Qfrom__tty_menu_p, "from--tty-menu-p");
+ DEFSYM (Qyes_or_no_p, "yes-or-no-p");
+ DEFSYM (Qy_or_n_p, "y-or-n-p");
+
+ DEFSYM (QCkey, ":key");
+ DEFSYM (QClessp, ":lessp");
+ DEFSYM (QCin_place, ":in-place");
+ DEFSYM (QCreverse, ":reverse");
+ DEFSYM (Qvaluelt, "value<");
}
diff --git a/src/font.c b/src/font.c
index 7a3206a169a..0a0ac5f8030 100644
--- a/src/font.c
+++ b/src/font.c
@@ -177,9 +177,35 @@ font_make_entity (void)
allocate_pseudovector (VECSIZE (struct font_entity),
FONT_ENTITY_MAX, FONT_ENTITY_MAX, PVEC_FONT));
XSETFONT (font_entity, entity);
+
+#if defined HAVE_ANDROID && !defined ANDROID_STUBIFY
+ entity->is_android = false;
+#endif
+
return font_entity;
}
+#ifdef HAVE_ANDROID
+
+Lisp_Object
+font_make_entity_android (int size)
+{
+ Lisp_Object font_entity;
+ struct font_entity *entity
+ = ((struct font_entity *)
+ allocate_pseudovector (size, FONT_ENTITY_MAX, FONT_ENTITY_MAX,
+ PVEC_FONT));
+
+#if defined HAVE_ANDROID && !defined ANDROID_STUBIFY
+ entity->is_android = true;
+#endif
+
+ XSETFONT (font_entity, entity);
+ return font_entity;
+}
+
+#endif
+
/* Create a font-object whose structure size is SIZE. If ENTITY is
not nil, copy properties from ENTITY to the font-object. If
PIXELSIZE is positive, set the `size' property to PIXELSIZE. */
@@ -226,12 +252,20 @@ font_build_object (int vectorsize, Lisp_Object type,
{
int len;
char name[256];
- Lisp_Object font_object = font_make_object (vectorsize, entity, pixelsize);
+ char *xlfd_name;
+ Lisp_Object font_object;
+
+ font_object = font_make_object (vectorsize, entity, pixelsize);
ASET (font_object, FONT_TYPE_INDEX, type);
- len = font_unparse_xlfd (entity, pixelsize, name, sizeof name);
- if (len > 0)
- ASET (font_object, FONT_NAME_INDEX, make_string (name, len));
+ xlfd_name = font_dynamic_unparse_xlfd (entity, pixelsize);
+
+ if (xlfd_name)
+ {
+ ASET (font_object, FONT_NAME_INDEX, build_string (xlfd_name));
+ xfree (xlfd_name);
+ }
+
len = font_unparse_fcname (entity, pixelsize, name, sizeof name);
if (len > 0)
ASET (font_object, FONT_FULLNAME_INDEX, make_string (name, len));
@@ -279,7 +313,7 @@ font_intern_prop (const char *str, ptrdiff_t len, bool force_symbol)
{
if (i == len)
return make_fixnum (n);
- if (INT_MULTIPLY_WRAPV (n, 10, &n))
+ if (ckd_mul (&n, n, 10))
break;
}
@@ -322,7 +356,7 @@ font_pixel_size (struct frame *f, Lisp_Object spec)
if (FIXNUMP (val))
dpi = XFIXNUM (val);
else
- dpi = FRAME_RES_Y (f);
+ dpi = FRAME_RES (f);
pixel_size = POINT_TO_PIXEL (point_size, dpi);
return pixel_size;
}
@@ -1041,8 +1075,8 @@ font_parse_xlfd_1 (char *name, ptrdiff_t len, Lisp_Object font, int segments)
Lisp_Object val;
char *p;
- if (len > 255 || !len)
- /* Maximum XLFD name length is 255. */
+ /* Reject empty XLFDs. */
+ if (!len)
return -1;
/* Accept "*-.." as a fully specified XLFD. */
@@ -1250,6 +1284,167 @@ font_parse_xlfd (char *name, ptrdiff_t len, Lisp_Object font)
return -1;
}
+/* Return the XLFD name of FONT as a NULL terminated string, or NULL
+ if the font is invalid. If FONT is a scalable font, return
+ PIXEL_SIZE as the XLFD's pixel size in lieu of its
+ FONT_SIZE_INDEX. */
+
+char *
+font_dynamic_unparse_xlfd (Lisp_Object font, int pixel_size)
+{
+ char *p;
+ const char *f[XLFD_REGISTRY_INDEX + 1];
+ Lisp_Object val;
+ int i, j;
+ char *name;
+ USE_SAFE_ALLOCA;
+
+ eassert (FONTP (font));
+
+ for (i = FONT_FOUNDRY_INDEX, j = XLFD_FOUNDRY_INDEX; i <= FONT_REGISTRY_INDEX;
+ i++, j++)
+ {
+ if (i == FONT_ADSTYLE_INDEX)
+ j = XLFD_ADSTYLE_INDEX;
+ else if (i == FONT_REGISTRY_INDEX)
+ j = XLFD_REGISTRY_INDEX;
+ val = AREF (font, i);
+ if (NILP (val))
+ {
+ if (j == XLFD_REGISTRY_INDEX)
+ f[j] = "*-*";
+ else
+ f[j] = "*";
+ }
+ else
+ {
+ if (SYMBOLP (val))
+ val = SYMBOL_NAME (val);
+ if (j == XLFD_REGISTRY_INDEX
+ && ! strchr (SSDATA (val), '-'))
+ {
+ ptrdiff_t alloc = SBYTES (val) + 4;
+
+ /* Change "jisx0208*" and "jisx0208" to "jisx0208*-*". */
+ f[j] = p = SAFE_ALLOCA (alloc);
+ sprintf (p, "%s%s-*", SDATA (val),
+ &"*"[SDATA (val)[SBYTES (val) - 1] == '*']);
+ }
+ else
+ f[j] = SSDATA (val);
+ }
+ }
+
+ for (i = FONT_WEIGHT_INDEX, j = XLFD_WEIGHT_INDEX; i <= FONT_WIDTH_INDEX;
+ i++, j++)
+ {
+ val = font_style_symbolic (font, i, 0);
+ if (NILP (val))
+ f[j] = "*";
+ else
+ {
+ int c, k, l;
+ ptrdiff_t alloc;
+
+ val = SYMBOL_NAME (val);
+ alloc = SBYTES (val) + 1;
+ f[j] = p = SAFE_ALLOCA (alloc);
+ /* Copy the name while excluding '-', '?', ',', and '"'. */
+ for (k = l = 0; k < alloc; k++)
+ {
+ c = SREF (val, k);
+ if (c != '-' && c != '?' && c != ',' && c != '"')
+ p[l++] = c;
+ }
+ }
+ }
+
+ val = AREF (font, FONT_SIZE_INDEX);
+ eassert (NUMBERP (val) || NILP (val));
+ char font_size_index_buf[sizeof "-*"
+ + max (INT_STRLEN_BOUND (EMACS_INT),
+ 1 + DBL_MAX_10_EXP + 1)];
+ if (INTEGERP (val))
+ {
+ intmax_t v;
+ if (! (integer_to_intmax (val, &v) && 0 < v))
+ v = pixel_size;
+ if (v > 0)
+ {
+ f[XLFD_PIXEL_INDEX] = p = font_size_index_buf;
+ sprintf (p, "%"PRIdMAX"-*", v);
+ }
+ else
+ f[XLFD_PIXEL_INDEX] = "*-*";
+ }
+ else if (FLOATP (val))
+ {
+ double v = XFLOAT_DATA (val) * 10;
+ f[XLFD_PIXEL_INDEX] = p = font_size_index_buf;
+ sprintf (p, "*-%.0f", v);
+ }
+ else
+ f[XLFD_PIXEL_INDEX] = "*-*";
+
+ char dpi_index_buf[sizeof "-" + 2 * INT_STRLEN_BOUND (EMACS_INT)];
+ if (FIXNUMP (AREF (font, FONT_DPI_INDEX)))
+ {
+ EMACS_INT v = XFIXNUM (AREF (font, FONT_DPI_INDEX));
+ f[XLFD_RESX_INDEX] = p = dpi_index_buf;
+ sprintf (p, "%"pI"d-%"pI"d", v, v);
+ }
+ else
+ f[XLFD_RESX_INDEX] = "*-*";
+
+ if (FIXNUMP (AREF (font, FONT_SPACING_INDEX)))
+ {
+ EMACS_INT spacing = XFIXNUM (AREF (font, FONT_SPACING_INDEX));
+
+ f[XLFD_SPACING_INDEX] = (spacing <= FONT_SPACING_PROPORTIONAL ? "p"
+ : spacing <= FONT_SPACING_DUAL ? "d"
+ : spacing <= FONT_SPACING_MONO ? "m"
+ : "c");
+ }
+ else
+ f[XLFD_SPACING_INDEX] = "*";
+
+ char avgwidth_index_buf[INT_BUFSIZE_BOUND (EMACS_INT)];
+ if (FIXNUMP (AREF (font, FONT_AVGWIDTH_INDEX)))
+ {
+ f[XLFD_AVGWIDTH_INDEX] = p = avgwidth_index_buf;
+ sprintf (p, "%"pI"d", XFIXNUM (AREF (font, FONT_AVGWIDTH_INDEX)));
+ }
+ else
+ f[XLFD_AVGWIDTH_INDEX] = "*";
+
+ /* Allocate a buffer large enough to accommodate the entire
+ XLFD. */
+
+ name = xmalloc (strlen (f[XLFD_FOUNDRY_INDEX])
+ + strlen (f[XLFD_FAMILY_INDEX])
+ + strlen (f[XLFD_WEIGHT_INDEX])
+ + strlen (f[XLFD_SLANT_INDEX])
+ + strlen (f[XLFD_SWIDTH_INDEX])
+ + strlen (f[XLFD_ADSTYLE_INDEX])
+ + strlen (f[XLFD_PIXEL_INDEX])
+ + strlen (f[XLFD_RESX_INDEX])
+ + strlen (f[XLFD_SPACING_INDEX])
+ + strlen (f[XLFD_AVGWIDTH_INDEX])
+ + strlen (f[XLFD_REGISTRY_INDEX])
+ + sizeof "-----------");
+
+ /* Return the XLFD. */
+
+ sprintf (name, "-%s-%s-%s-%s-%s-%s-%s-%s-%s-%s-%s",
+ f[XLFD_FOUNDRY_INDEX], f[XLFD_FAMILY_INDEX],
+ f[XLFD_WEIGHT_INDEX], f[XLFD_SLANT_INDEX],
+ f[XLFD_SWIDTH_INDEX], f[XLFD_ADSTYLE_INDEX],
+ f[XLFD_PIXEL_INDEX], f[XLFD_RESX_INDEX],
+ f[XLFD_SPACING_INDEX], f[XLFD_AVGWIDTH_INDEX],
+ f[XLFD_REGISTRY_INDEX]);
+ SAFE_FREE ();
+ return name;
+}
/* Store XLFD name of FONT (font-spec or font-entity) in NAME (NBYTES
length), and return the name length. If FONT_SIZE_INDEX of FONT is
@@ -1852,8 +2047,12 @@ font_rescale_ratio (Lisp_Object font_entity)
if (STRINGP (XCAR (elt)))
{
if (NILP (name))
- name = Ffont_xlfd_name (font_entity, Qnil);
- if (fast_string_match_ignore_case (XCAR (elt), name) >= 0)
+ name = Ffont_xlfd_name (font_entity, Qnil, Qt);
+
+ /* N.B. that `name' is set to nil if the resulting XLFD
+ is too long. */
+ if (!NILP (name)
+ && fast_string_match_ignore_case (XCAR (elt), name) >= 0)
return XFLOAT_DATA (XCDR (elt));
}
else if (FONT_SPEC_P (XCAR (elt)))
@@ -2460,12 +2659,30 @@ font_delete_unmatched (Lisp_Object vec, Lisp_Object spec, int size)
entity = AREF (vec, i);
if (! NILP (Vface_ignored_fonts))
{
- char name[256];
+ char name[256], *xlfd;
ptrdiff_t namelen;
namelen = font_unparse_xlfd (entity, 0, name, 256);
+
if (namelen >= 0)
- if (font_is_ignored (name, namelen))
+ {
+ if (font_is_ignored (name, namelen))
continue;
+ }
+ else
+ {
+ /* The font family or foundry is too long for a 256
+ character xlfd to accommodate. */
+
+ xlfd = font_dynamic_unparse_xlfd (entity, 0);
+
+ if (xlfd && font_is_ignored (xlfd, sizeof (xlfd)))
+ {
+ xfree (xlfd);
+ continue;
+ }
+
+ xfree (xlfd);
+ }
}
if (NILP (spec))
{
@@ -2997,7 +3214,7 @@ font_find_for_lface (struct frame *f, Lisp_Object *attrs, Lisp_Object spec, int
{
double pt = XFIXNUM (attrs[LFACE_HEIGHT_INDEX]);
- pixel_size = POINT_TO_PIXEL (pt / 10, FRAME_RES_Y (f));
+ pixel_size = POINT_TO_PIXEL (pt / 10, FRAME_RES (f));
if (pixel_size < 1)
pixel_size = 1;
}
@@ -3149,13 +3366,13 @@ font_open_for_lface (struct frame *f, Lisp_Object entity, Lisp_Object *attrs, Li
}
pt /= 10;
- size = POINT_TO_PIXEL (pt, FRAME_RES_Y (f));
+ size = POINT_TO_PIXEL (pt, FRAME_RES (f));
#ifdef HAVE_NS
if (size == 0)
{
Lisp_Object ffsize = get_frame_param (f, Qfontsize);
size = (NUMBERP (ffsize)
- ? POINT_TO_PIXEL (XFLOATINT (ffsize), FRAME_RES_Y (f))
+ ? POINT_TO_PIXEL (XFLOATINT (ffsize), FRAME_RES (f))
: 0);
}
#endif
@@ -4056,7 +4273,7 @@ are to be displayed on. If omitted, the selected frame is used. */)
if (FIXNUMP (val))
{
Lisp_Object font_dpi = AREF (font, FONT_DPI_INDEX);
- int dpi = FIXNUMP (font_dpi) ? XFIXNUM (font_dpi) : FRAME_RES_Y (f);
+ int dpi = FIXNUMP (font_dpi) ? XFIXNUM (font_dpi) : FRAME_RES (f);
plist[n++] = QCheight;
plist[n++] = make_fixnum (PIXEL_TO_POINT (XFIXNUM (val) * 10, dpi));
}
@@ -4209,16 +4426,20 @@ Optional 2nd argument FRAME, if non-nil, specifies the target frame. */)
return val;
}
-DEFUN ("font-xlfd-name", Ffont_xlfd_name, Sfont_xlfd_name, 1, 2, 0,
+DEFUN ("font-xlfd-name", Ffont_xlfd_name, Sfont_xlfd_name, 1, 3, 0,
doc: /* Return XLFD name of FONT.
FONT is a font-spec, font-entity, or font-object.
-If the name is too long for XLFD (maximum 255 chars), return nil.
+
+If the name is too long to be represented as an XLFD (maximum 255
+chars) and LONG_XLFDS is nil, return nil.
+
If the 2nd optional arg FOLD-WILDCARDS is non-nil,
the consecutive wildcards are folded into one. */)
- (Lisp_Object font, Lisp_Object fold_wildcards)
+ (Lisp_Object font, Lisp_Object fold_wildcards, Lisp_Object long_xlfds)
{
- char name[256];
+ char name_buffer[256], *name;
int namelen, pixel_size = 0;
+ Lisp_Object string;
CHECK_FONT (font);
@@ -4231,15 +4452,32 @@ the consecutive wildcards are folded into one. */)
{
if (NILP (fold_wildcards))
return font_name;
+ name = name_buffer;
lispstpcpy (name, font_name);
namelen = SBYTES (font_name);
goto done;
}
pixel_size = XFONT_OBJECT (font)->pixel_size;
}
- namelen = font_unparse_xlfd (font, pixel_size, name, 256);
- if (namelen < 0)
- return Qnil;
+
+ if (NILP (long_xlfds))
+ {
+ name = name_buffer;
+ namelen = font_unparse_xlfd (font, pixel_size, name, 256);
+ if (namelen < 0)
+ return Qnil;
+ }
+ else
+ {
+ /* Dynamically allocate the XLFD. */
+ name = font_dynamic_unparse_xlfd (font, pixel_size);
+
+ if (!name)
+ return Qnil;
+
+ namelen = strlen (name);
+ }
+
done:
if (! NILP (fold_wildcards))
{
@@ -4253,7 +4491,14 @@ the consecutive wildcards are folded into one. */)
}
}
- return make_string (name, namelen);
+ /* If NAME is dynamically allocated, free it. */
+
+ string = make_string (name, namelen);
+
+ if (name != name_buffer)
+ xfree (name);
+
+ return string;
}
void
@@ -4960,7 +5205,7 @@ DEFUN ("open-font", Fopen_font, Sopen_font, 1, 3, 0,
{
CHECK_NUMBER (size);
if (FLOATP (size))
- isize = POINT_TO_PIXEL (XFLOAT_DATA (size), FRAME_RES_Y (f));
+ isize = POINT_TO_PIXEL (XFLOAT_DATA (size), FRAME_RES (f));
else if (! integer_to_intmax (size, &isize))
args_out_of_range (font_entity, size);
if (! (INT_MIN <= isize && isize <= INT_MAX))
@@ -5457,7 +5702,7 @@ font_add_log (const char *action, Lisp_Object arg, Lisp_Object result)
Lisp_Object tail, elt;
AUTO_STRING (equal, "=");
- val = Ffont_xlfd_name (arg, Qt);
+ val = Ffont_xlfd_name (arg, Qt, Qt);
for (tail = AREF (arg, FONT_EXTRA_INDEX); CONSP (tail);
tail = XCDR (tail))
{
@@ -5485,7 +5730,7 @@ font_add_log (const char *action, Lisp_Object arg, Lisp_Object result)
result = font_vconcat_entity_vectors (result);
if (FONTP (result))
{
- val = Ffont_xlfd_name (result, Qt);
+ val = Ffont_xlfd_name (result, Qt, Qt);
if (! FONT_SPEC_P (result))
{
AUTO_STRING (colon, ":");
@@ -5502,7 +5747,7 @@ font_add_log (const char *action, Lisp_Object arg, Lisp_Object result)
{
val = XCAR (tail);
if (FONTP (val))
- val = Ffont_xlfd_name (val, Qt);
+ val = Ffont_xlfd_name (val, Qt, Qt);
XSETCAR (tail, val);
}
}
@@ -5513,7 +5758,7 @@ font_add_log (const char *action, Lisp_Object arg, Lisp_Object result)
{
val = AREF (result, i);
if (FONTP (val))
- val = Ffont_xlfd_name (val, Qt);
+ val = Ffont_xlfd_name (val, Qt, Qt);
ASET (result, i, val);
}
}
diff --git a/src/font.h b/src/font.h
index 9f418b7f0b8..8ee1940be0a 100644
--- a/src/font.h
+++ b/src/font.h
@@ -191,16 +191,16 @@ enum font_property_index
/* Return the numeric weight value of FONT. */
#define FONT_WEIGHT_NUMERIC(font) \
- (FIXNUMP (AREF ((font), FONT_WEIGHT_INDEX)) \
- ? (XFIXNUM (AREF ((font), FONT_WEIGHT_INDEX)) >> 8) : -1)
+ (FIXNUMP (AREF (font, FONT_WEIGHT_INDEX)) \
+ ? (XFIXNUM (AREF (font, FONT_WEIGHT_INDEX)) >> 8) : -1)
/* Return the numeric slant value of FONT. */
#define FONT_SLANT_NUMERIC(font) \
- (FIXNUMP (AREF ((font), FONT_SLANT_INDEX)) \
- ? (XFIXNUM (AREF ((font), FONT_SLANT_INDEX)) >> 8) : -1)
+ (FIXNUMP (AREF (font, FONT_SLANT_INDEX)) \
+ ? (XFIXNUM (AREF (font, FONT_SLANT_INDEX)) >> 8) : -1)
/* Return the numeric width value of FONT. */
#define FONT_WIDTH_NUMERIC(font) \
- (FIXNUMP (AREF ((font), FONT_WIDTH_INDEX)) \
- ? (XFIXNUM (AREF ((font), FONT_WIDTH_INDEX)) >> 8) : -1)
+ (FIXNUMP (AREF (font, FONT_WIDTH_INDEX)) \
+ ? (XFIXNUM (AREF (font, FONT_WIDTH_INDEX)) >> 8) : -1)
/* Return the symbolic weight value of FONT. */
#define FONT_WEIGHT_SYMBOLIC(font) \
font_style_symbolic (font, FONT_WEIGHT_INDEX, false)
@@ -222,19 +222,19 @@ enum font_property_index
/* Return the numeric weight value corresponding to the symbol NAME. */
#define FONT_WEIGHT_NAME_NUMERIC(name) \
- (font_style_to_value (FONT_WEIGHT_INDEX, (name), false) >> 8)
+ (font_style_to_value (FONT_WEIGHT_INDEX, name, false) >> 8)
/* Return the numeric slant value corresponding to the symbol NAME. */
#define FONT_SLANT_NAME_NUMERIC(name) \
- (font_style_to_value (FONT_SLANT_INDEX, (name), false) >> 8)
+ (font_style_to_value (FONT_SLANT_INDEX, name, false) >> 8)
/* Return the numeric width value corresponding to the symbol NAME. */
#define FONT_WIDTH_NAME_NUMERIC(name) \
- (font_style_to_value (FONT_WIDTH_INDEX, (name), false) >> 8)
+ (font_style_to_value (FONT_WIDTH_INDEX, name, false) >> 8)
/* Set the font property PROP of FONT to VAL. PROP is one of
style-related font property index (FONT_WEIGHT/SLANT/WIDTH_INDEX).
VAL (integer or symbol) is the numeric or symbolic style value. */
#define FONT_SET_STYLE(font, prop, val) \
- ASET ((font), prop, make_fixnum (font_style_to_value (prop, val, true)))
+ ASET (font, prop, make_fixnum (font_style_to_value (prop, val, true)))
#ifndef MSDOS
#define FONT_WIDTH(f) ((f)->max_width)
@@ -260,6 +260,11 @@ struct font_entity
{
union vectorlike_header header;
Lisp_Object props[FONT_ENTITY_MAX];
+
+#if defined HAVE_ANDROID && !defined ANDROID_STUBIFY
+ /* Whether or not this is an Android font entity. */
+ bool is_android;
+#endif
};
/* A value which may appear in the member `encoding' of struct font
@@ -544,7 +549,7 @@ GC_XFONT_OBJECT (Lisp_Object p)
return XUNTAG (p, Lisp_Vectorlike, struct font);
}
-#define XSETFONT(a, b) (XSETPSEUDOVECTOR (a, b, PVEC_FONT))
+#define XSETFONT(a, b) XSETPSEUDOVECTOR (a, b, PVEC_FONT)
INLINE struct font *
CHECK_FONT_GET_OBJECT (Lisp_Object x)
@@ -553,8 +558,14 @@ CHECK_FONT_GET_OBJECT (Lisp_Object x)
return XFONT_OBJECT (x);
}
+#ifndef HAVE_ANDROID
/* Number of pt per inch (from the TeXbook). */
#define PT_PER_INCH 72.27
+#else
+/* Android uses this value instead to compensate for different device
+ dimensions. */
+#define PT_PER_INCH 160.00
+#endif
/* Return a pixel size (integer) corresponding to POINT size (double)
on resolution DPI. */
@@ -829,6 +840,9 @@ extern Lisp_Object copy_font_spec (Lisp_Object);
extern Lisp_Object merge_font_spec (Lisp_Object, Lisp_Object);
extern Lisp_Object font_make_entity (void);
+#ifdef HAVE_ANDROID
+extern Lisp_Object font_make_entity_android (int);
+#endif
extern Lisp_Object font_make_object (int, Lisp_Object, int);
#if defined (HAVE_XFT) || defined (HAVE_FREETYPE) || defined (HAVE_NS)
extern Lisp_Object font_build_object (int, Lisp_Object, Lisp_Object, double);
@@ -877,8 +891,8 @@ extern void font_parse_family_registry (Lisp_Object family,
Lisp_Object spec);
extern int font_parse_xlfd (char *name, ptrdiff_t len, Lisp_Object font);
-extern ptrdiff_t font_unparse_xlfd (Lisp_Object font, int pixel_size,
- char *name, int bytes);
+extern char *font_dynamic_unparse_xlfd (Lisp_Object, int);
+extern ptrdiff_t font_unparse_xlfd (Lisp_Object, int, char *, int);
extern void register_font_driver (struct font_driver const *, struct frame *);
extern void free_font_driver_list (struct frame *f);
#ifdef ENABLE_CHECKING
@@ -990,13 +1004,13 @@ extern void font_deferred_log (const char *, Lisp_Object, Lisp_Object);
#define FONT_ADD_LOG(ACTION, ARG, RESULT) \
do { \
if (! EQ (Vfont_log, Qt)) \
- font_add_log ((ACTION), (ARG), (RESULT)); \
+ font_add_log (ACTION, ARG, RESULT); \
} while (false)
#define FONT_DEFERRED_LOG(ACTION, ARG, RESULT) \
do { \
if (! EQ (Vfont_log, Qt)) \
- font_deferred_log ((ACTION), (ARG), (RESULT)); \
+ font_deferred_log (ACTION, ARG, RESULT); \
} while (false)
/* FIXME: This is for use in functions that can be called while
diff --git a/src/fontset.c b/src/fontset.c
index 7af6782a37c..d27fa22015e 100644
--- a/src/fontset.c
+++ b/src/fontset.c
@@ -266,19 +266,19 @@ font_def_new (Lisp_Object font_spec, Lisp_Object encoding,
#define RFONT_DEF_FACE(rfont_def) AREF (rfont_def, 0)
#define RFONT_DEF_SET_FACE(rfont_def, face_id) \
- ASET ((rfont_def), 0, make_fixnum (face_id))
+ ASET (rfont_def, 0, make_fixnum (face_id))
#define RFONT_DEF_FONT_DEF(rfont_def) AREF (rfont_def, 1)
#define RFONT_DEF_SPEC(rfont_def) FONT_DEF_SPEC (AREF (rfont_def, 1))
#define RFONT_DEF_OBJECT(rfont_def) AREF (rfont_def, 2)
#define RFONT_DEF_SET_OBJECT(rfont_def, object) \
- ASET ((rfont_def), 2, (object))
+ ASET (rfont_def, 2, object)
/* Score of RFONT_DEF is an integer value; the lowest 8 bits represent
the order of listing by font backends, the higher bits represents
the order given by charset priority list. The smaller value is
preferable. */
#define RFONT_DEF_SCORE(rfont_def) XFIXNUM (AREF (rfont_def, 3))
#define RFONT_DEF_SET_SCORE(rfont_def, score) \
- ASET ((rfont_def), 3, make_fixnum (score))
+ ASET (rfont_def, 3, make_fixnum (score))
#define RFONT_DEF_NEW(rfont_def, font_def) \
do { \
(rfont_def) = make_nil_vector (4); \
@@ -295,7 +295,7 @@ font_def_new (Lisp_Object font_spec, Lisp_Object encoding,
#define FONTSET_REF(fontset, c) \
(EQ (fontset, Vdefault_fontset) \
? CHAR_TABLE_REF (fontset, c) \
- : fontset_ref ((fontset), (c)))
+ : fontset_ref (fontset, c))
static Lisp_Object
fontset_ref (Lisp_Object fontset, int c)
@@ -315,7 +315,7 @@ fontset_ref (Lisp_Object fontset, int c)
specifying a range. */
#define FONTSET_SET(fontset, range, elt) \
- Fset_char_table_range ((fontset), (range), (elt))
+ Fset_char_table_range (fontset, range, elt)
/* Modify the elements of FONTSET for characters in RANGE by replacing
@@ -329,7 +329,7 @@ fontset_ref (Lisp_Object fontset, int c)
? (NILP (range) \
? set_fontset_fallback (fontset, make_vector (1, elt)) \
: (void) Fset_char_table_range (fontset, range, make_vector (1, elt))) \
- : fontset_add ((fontset), (range), (elt), (add)))
+ : fontset_add (fontset, range, elt, add))
static void
fontset_add (Lisp_Object fontset, Lisp_Object range, Lisp_Object elt, Lisp_Object add)
@@ -667,8 +667,35 @@ fontset_find_font (Lisp_Object fontset, int c, struct face *face,
}
font_object = font_open_for_lface (f, font_entity, face->lface,
FONT_DEF_SPEC (font_def));
+
+ /* If the font registry is not the same as explicitly
+ specified in the font spec, do not cache the font.
+ TrueType fonts have contrived character map selection
+ semantics which makes determining the repertory at font
+ spec matching time unduly expensive. */
+
+ {
+ Lisp_Object spec;
+
+ spec = FONT_DEF_SPEC (font_def);
+
+ if (!NILP (font_object)
+ && !NILP (AREF (spec, FONT_REGISTRY_INDEX))
+ && !NILP (AREF (font_object, FONT_REGISTRY_INDEX))
+ && !EQ (AREF (spec, FONT_REGISTRY_INDEX),
+ AREF (font_object, FONT_REGISTRY_INDEX))
+ /* See sfntfont_registries_compatible_p in
+ sfntfont.c. */
+ && !(EQ (AREF (spec, FONT_REGISTRY_INDEX),
+ Qiso8859_1)
+ && EQ (AREF (font_object, FONT_REGISTRY_INDEX),
+ Qiso10646_1)))
+ goto strangeness;
+ }
+
if (NILP (font_object))
{
+ strangeness:
/* Something strange happened, perhaps because of a
Font-backend problem. To avoid crashing, record
that this spec is unusable. It may be better to find
@@ -1519,7 +1546,7 @@ overwrites the previous settings. */)
font_parse_family_registry (XCAR (font_spec), XCDR (font_spec), spec);
font_spec = spec;
- fontname = Ffont_xlfd_name (font_spec, Qnil);
+ fontname = Ffont_xlfd_name (font_spec, Qnil, Qt);
}
else if (STRINGP (font_spec))
{
@@ -1527,7 +1554,7 @@ overwrites the previous settings. */)
font_spec = CALLN (Ffont_spec, QCname, fontname);
}
else if (FONT_SPEC_P (font_spec))
- fontname = Ffont_xlfd_name (font_spec, Qnil);
+ fontname = Ffont_xlfd_name (font_spec, Qnil, Qt);
else if (! NILP (font_spec))
Fsignal (Qfont, list2 (build_string ("Invalid font-spec"), font_spec));
@@ -1713,6 +1740,7 @@ FONT-SPEC is a vector, a cons, or a string. See the documentation of
{
Lisp_Object fontset, tail;
int id;
+ char *string;
CHECK_STRING (name);
@@ -1722,8 +1750,6 @@ FONT-SPEC is a vector, a cons, or a string. See the documentation of
{
Lisp_Object font_spec = Ffont_spec (0, NULL);
Lisp_Object short_name;
- char xlfd[256];
- int len;
if (font_parse_xlfd (SSDATA (name), SBYTES (name), font_spec) < 0)
error ("Fontset name must be in XLFD format");
@@ -1735,10 +1761,11 @@ FONT-SPEC is a vector, a cons, or a string. See the documentation of
Vfontset_alias_alist);
ASET (font_spec, FONT_REGISTRY_INDEX, Qiso8859_1);
fontset = make_fontset (Qnil, name, Qnil);
- len = font_unparse_xlfd (font_spec, 0, xlfd, 256);
- if (len < 0)
+ string = font_dynamic_unparse_xlfd (font_spec, 0);
+ if (!string)
error ("Invalid fontset name (perhaps too long): %s", SDATA (name));
- set_fontset_ascii (fontset, make_unibyte_string (xlfd, len));
+ set_fontset_ascii (fontset, build_unibyte_string (string));
+ xfree (string);
}
else
{
@@ -1789,7 +1816,7 @@ fontset_from_font (Lisp_Object font_object)
Lisp_Object font_spec = copy_font_spec (font_object);
Lisp_Object registry = AREF (font_spec, FONT_REGISTRY_INDEX);
Lisp_Object fontset_spec, alias, name, fontset;
- Lisp_Object val;
+ Lisp_Object val, xlfd;
val = assoc_no_quit (font_spec, auto_fontset_alist);
if (CONSP (val))
@@ -1805,14 +1832,19 @@ fontset_from_font (Lisp_Object font_object)
}
fontset_spec = copy_font_spec (font_spec);
ASET (fontset_spec, FONT_REGISTRY_INDEX, alias);
- name = Ffont_xlfd_name (fontset_spec, Qnil);
+ name = Ffont_xlfd_name (fontset_spec, Qnil, Qt);
eassert (!NILP (name));
fontset = make_fontset (Qnil, name, Qnil);
Vfontset_alias_alist = Fcons (Fcons (name, SYMBOL_NAME (alias)),
Vfontset_alias_alist);
- alias = Fdowncase (AREF (font_object, FONT_NAME_INDEX));
- Vfontset_alias_alist = Fcons (Fcons (name, alias), Vfontset_alias_alist);
- auto_fontset_alist = Fcons (Fcons (font_spec, fontset), auto_fontset_alist);
+
+ xlfd = AREF (font_object, FONT_NAME_INDEX);
+ alias = Fdowncase (xlfd);
+ Vfontset_alias_alist
+ = Fcons (Fcons (name, alias), Vfontset_alias_alist);
+ auto_fontset_alist
+ = Fcons (Fcons (font_spec, fontset), auto_fontset_alist);
+
font_spec = Ffont_spec (0, NULL);
ASET (font_spec, FONT_REGISTRY_INDEX, registry);
{
@@ -1979,7 +2011,7 @@ format is the same as above. */)
for (; CONSP (alist); alist = XCDR (alist))
{
elt = XCAR (alist);
- XSETCAR (elt, Ffont_xlfd_name (XCAR (elt), Qnil));
+ XSETCAR (elt, Ffont_xlfd_name (XCAR (elt), Qnil, Qt));
}
}
c = to + 1;
diff --git a/src/frame.c b/src/frame.c
index 5ee74bda42b..abd6ef00901 100644
--- a/src/frame.c
+++ b/src/frame.c
@@ -228,6 +228,7 @@ Value is:
`pc' for a direct-write MS-DOS frame,
`pgtk' for an Emacs frame running on pure GTK.
`haiku' for an Emacs frame running in Haiku.
+ `android' for an Emacs frame running in Android.
See also `frame-live-p'. */)
(Lisp_Object object)
{
@@ -250,6 +251,8 @@ See also `frame-live-p'. */)
return Qpgtk;
case output_haiku:
return Qhaiku;
+ case output_android:
+ return Qandroid;
default:
emacs_abort ();
}
@@ -279,6 +282,7 @@ The value is a symbol:
`pc' for a direct-write MS-DOS frame.
`pgtk' for an Emacs frame using pure GTK facilities.
`haiku' for an Emacs frame running in Haiku.
+ `android' for an Emacs frame running in Android.
FRAME defaults to the currently selected frame.
@@ -710,10 +714,10 @@ adjust_frame_size (struct frame *f, int new_text_width, int new_text_height,
? old_native_height
: max (FRAME_TEXT_TO_PIXEL_HEIGHT (f, new_text_height),
min_inner_height
- + FRAME_TOP_MARGIN_HEIGHT (f)
+ + FRAME_MARGIN_HEIGHT (f)
+ 2 * FRAME_INTERNAL_BORDER_WIDTH (f)));
new_inner_height = (new_native_height
- - FRAME_TOP_MARGIN_HEIGHT (f)
+ - FRAME_MARGIN_HEIGHT (f)
- 2 * FRAME_INTERNAL_BORDER_WIDTH (f));
new_text_height = FRAME_PIXEL_TO_TEXT_HEIGHT (f, new_native_height);
new_text_lines = new_text_height / unit_height;
@@ -940,11 +944,9 @@ make_frame (bool mini_p)
f = allocate_frame ();
XSETFRAME (frame, f);
-#ifdef USE_GTK
/* Initialize Lisp data. Note that allocate_frame initializes all
Lisp data to nil, so do it only for slots which should not be nil. */
fset_tool_bar_position (f, Qtop);
-#endif
/* Initialize non-Lisp data. Note that allocate_frame zeroes out all
non-Lisp data, so do it only for slots which should not be zero.
@@ -984,6 +986,7 @@ make_frame (bool mini_p)
f->last_tab_bar_item = -1;
#ifndef HAVE_EXT_TOOL_BAR
f->last_tool_bar_item = -1;
+ f->tool_bar_wraps_p = false;
#endif
#ifdef NS_IMPL_COCOA
f->ns_appearance = ns_appearance_system_default;
@@ -993,6 +996,16 @@ make_frame (bool mini_p)
f->select_mini_window_flag = false;
/* This one should never be zero. */
f->change_stamp = 1;
+
+#ifdef HAVE_TEXT_CONVERSION
+ f->conversion.compose_region_start = Qnil;
+ f->conversion.compose_region_end = Qnil;
+ f->conversion.compose_region_overlay = Qnil;
+ f->conversion.batch_edit_count = 0;
+ f->conversion.batch_edit_flags = 0;
+ f->conversion.actions = NULL;
+#endif
+
root_window = make_window ();
rw = XWINDOW (root_window);
if (mini_p)
@@ -1027,8 +1040,7 @@ make_frame (bool mini_p)
rw->pixel_height = rw->total_lines * FRAME_LINE_HEIGHT (f);
fset_face_hash_table
- (f, make_hash_table (hashtest_eq, DEFAULT_HASH_SIZE, DEFAULT_REHASH_SIZE,
- DEFAULT_REHASH_THRESHOLD, Qnil, false));
+ (f, make_hash_table (&hashtest_eq, DEFAULT_HASH_SIZE, Weak_None, false));
if (mini_p)
{
@@ -1228,6 +1240,7 @@ make_initial_frame (void)
return f;
}
+#ifndef HAVE_ANDROID
static struct frame *
make_terminal_frame (struct terminal *terminal)
@@ -1317,6 +1330,8 @@ get_future_frame_param (Lisp_Object parameter,
return result;
}
+#endif
+
DEFUN ("make-terminal-frame", Fmake_terminal_frame, Smake_terminal_frame,
1, 1, 0,
doc: /* Create an additional terminal frame, possibly on another terminal.
@@ -1336,6 +1351,10 @@ Note that changing the size of one terminal frame automatically
affects all frames on the same terminal device. */)
(Lisp_Object parms)
{
+#ifdef HAVE_ANDROID
+ error ("Text terminals are not supported on this platform");
+ return Qnil;
+#else
struct frame *f;
struct terminal *t = NULL;
Lisp_Object frame;
@@ -1436,6 +1455,7 @@ affects all frames on the same terminal device. */)
f->after_make_frame = true;
return frame;
+#endif
}
@@ -1568,7 +1588,7 @@ do_switch_frame (Lisp_Object frame, int track, int for_deletion, Lisp_Object nor
if (f->select_mini_window_flag
&& !NILP (Fminibufferp (XWINDOW (f->minibuffer_window)->contents, Qt)))
- f->selected_window = f->minibuffer_window;
+ fset_selected_window (f, f->minibuffer_window);
f->select_mini_window_flag = false;
if (! FRAME_MINIBUF_ONLY_P (XFRAME (selected_frame)))
@@ -1934,12 +1954,61 @@ other_frames (struct frame *f, bool invisible, bool force)
if (f != f1)
{
+ /* The following code is defined out because it is
+ responsible for a performance drop under X connections
+ over a network, and its purpose is unclear. XSync does
+ not handle events (or call any callbacks defined by
+ Emacs), and as such it should not note any "recent change
+ in visibility".
+
+ When writing new code, please try as hard as possible to
+ avoid calls that require a roundtrip to the X server.
+ When such calls are inevitable, use the XCB library to
+ handle multiple consecutive requests with a data reply in
+ a more asynchronous fashion. The following code
+ demonstrates why:
+
+ rc = XGetWindowProperty (dpyinfo->display, window, ...
+ status = XGrabKeyboard (dpyinfo->display, ...
+
+ here, `XGetWindowProperty' will wait for a reply from the
+ X server before returning, and thus allowing Emacs to
+ make the XGrabKeyboard request, which in itself also
+ requires waiting a reply. When XCB is available, this
+ code could be written:
+
+#ifdef HAVE_XCB
+ xcb_get_property_cookie_t cookie1;
+ xcb_get_property_reply_t *reply1;
+ xcb_grab_keyboard_cookie_t cookie2;
+ xcb_grab_keyboard_reply_t *reply2;
+
+ cookie1 = xcb_get_property (dpyinfo->xcb_connection, window, ...
+ cookie2 = xcb_grab_keyboard (dpyinfo->xcb_connection, ...
+ reply1 = xcb_get_property_reply (dpyinfo->xcb_connection,
+ cookie1);
+ reply2 = xcb_grab_keyboard_reply (dpyinfo->xcb_connection,
+ cookie2);
+#endif
+
+ In this code, the GetProperty and GrabKeyboard requests
+ are made simultaneously, and replies are then obtained
+ from the server at once, avoiding the extraneous
+ roundtrip to the X server after the call to
+ `XGetWindowProperty'.
+
+ However, please keep an alternative implementation
+ available for use when Emacs is built without XCB. */
+
+#if 0
/* Verify that we can still talk to the frame's X window, and
note any recent change in visibility. */
#ifdef HAVE_X_WINDOWS
if (FRAME_WINDOW_P (f1))
x_sync (f1);
#endif
+#endif
+
if (!FRAME_TOOLTIP_P (f1)
/* Tooltips and child frames count neither for
invisibility nor for deletions. */
@@ -2079,7 +2148,7 @@ delete_frame (Lisp_Object frame, Lisp_Object force)
x_clipboard_manager_save_frame (frame);
#endif
- safe_call2 (Qrun_hook_with_args, Qdelete_frame_functions, frame);
+ safe_calln (Qrun_hook_with_args, Qdelete_frame_functions, frame);
}
/* delete_frame_functions may have deleted any frame, including this
@@ -2142,12 +2211,15 @@ delete_frame (Lisp_Object frame, Lisp_Object force)
}
#ifdef NS_IMPL_COCOA
else
- /* Under NS, there is no system mechanism for choosing a new
- window to get focus -- it is left to application code.
- So the portion of THIS application interfacing with NS
- needs to know about it. We call Fraise_frame, but the
- purpose is really to transfer focus. */
- Fraise_frame (frame1);
+ {
+ /* Under NS, there is no system mechanism for choosing a new
+ window to get focus -- it is left to application code.
+ So the portion of THIS application interfacing with NS
+ needs to make the frame we switch to the key window. */
+ struct frame *f1 = XFRAME (frame1);
+ if (FRAME_NS_P (f1))
+ ns_make_frame_key_window (f1);
+ }
#endif
do_switch_frame (frame1, 0, 1, Qnil);
@@ -2245,6 +2317,13 @@ delete_frame (Lisp_Object frame, Lisp_Object force)
f->terminal = 0; /* Now the frame is dead. */
unblock_input ();
+ /* Clear markers and overlays set by F on behalf of an input
+ method. */
+#ifdef HAVE_TEXT_CONVERSION
+ if (FRAME_WINDOW_P (f))
+ reset_frame_state (f);
+#endif
+
/* If needed, delete the terminal that this frame was on.
(This must be done after the frame is killed.) */
terminal->reference_count--;
@@ -2381,7 +2460,7 @@ delete_frame (Lisp_Object frame, Lisp_Object force)
= Fcons (list3 (Qrun_hook_with_args, Qafter_delete_frame_functions, frame),
pending_funcalls);
else
- safe_call2 (Qrun_hook_with_args, Qafter_delete_frame_functions, frame);
+ safe_calln (Qrun_hook_with_args, Qafter_delete_frame_functions, frame);
if (!NILP (minibuffer_child_frame))
/* If minibuffer_child_frame is non-nil, it was FRAME's minibuffer
@@ -3722,7 +3801,7 @@ check_frame_pixels (Lisp_Object size, Lisp_Object pixelwise, int item_size)
item_size = 1;
if (!integer_to_intmax (size, &sz)
- || INT_MULTIPLY_WRAPV (sz, item_size, &pixel_size))
+ || ckd_mul (&pixel_size, sz, item_size))
args_out_of_range_3 (size, make_int (INT_MIN / item_size),
make_int (INT_MAX / item_size));
@@ -5296,16 +5375,23 @@ gui_display_get_resource (Display_Info *dpyinfo, Lisp_Object attribute,
*nz++ = '.';
lispstpcpy (nz, attribute);
- const char *value =
- dpyinfo->terminal->get_string_resource_hook (&dpyinfo->rdb,
- name_key,
- class_key);
- SAFE_FREE();
+#ifndef HAVE_ANDROID
+ const char *value
+ = dpyinfo->terminal->get_string_resource_hook (&dpyinfo->rdb,
+ name_key,
+ class_key);
+
+ SAFE_FREE ();
if (value && *value)
return build_string (value);
else
return Qnil;
+#else
+
+ SAFE_FREE ();
+ return Qnil;
+#endif
}
@@ -5640,6 +5726,8 @@ On Nextstep, this just calls `ns-parse-geometry'. */)
int x UNINIT, y UNINIT;
unsigned int width, height;
+ width = height = 0;
+
CHECK_STRING (string);
#ifdef HAVE_NS
@@ -6112,8 +6200,11 @@ make_monitor_attribute_list (struct MonitorInfo *monitors,
mi->work.width, mi->work.height);
geometry = list4i (mi->geom.x, mi->geom.y,
mi->geom.width, mi->geom.height);
- attributes = Fcons (Fcons (Qsource, build_string (source)),
- attributes);
+
+ if (source)
+ attributes = Fcons (Fcons (Qsource, build_string (source)),
+ attributes);
+
attributes = Fcons (Fcons (Qframes, AREF (monitor_frames, i)),
attributes);
#ifdef HAVE_PGTK
@@ -6211,6 +6302,7 @@ syms_of_frame (void)
DEFSYM (Qns, "ns");
DEFSYM (Qpgtk, "pgtk");
DEFSYM (Qhaiku, "haiku");
+ DEFSYM (Qandroid, "android");
DEFSYM (Qvisible, "visible");
DEFSYM (Qbuffer_predicate, "buffer-predicate");
DEFSYM (Qbuffer_list, "buffer-list");
@@ -6399,7 +6491,7 @@ Setting this variable does not affect existing frames, only new ones. */);
DEFVAR_LISP ("default-frame-scroll-bars", Vdefault_frame_scroll_bars,
doc: /* Default position of vertical scroll bars on this window-system. */);
-#ifdef HAVE_WINDOW_SYSTEM
+#if defined HAVE_WINDOW_SYSTEM && !defined HAVE_ANDROID
#if defined (HAVE_NTGUI) || defined (NS_IMPL_COCOA) || (defined (USE_GTK) && defined (USE_TOOLKIT_SCROLL_BARS))
/* MS-Windows, macOS, and GTK have scroll bars on the right by
default. */
@@ -6407,9 +6499,9 @@ Setting this variable does not affect existing frames, only new ones. */);
#else
Vdefault_frame_scroll_bars = Qleft;
#endif
-#else
+#else /* !HAVE_WINDOW_SYSTEM || HAVE_ANDROID */
Vdefault_frame_scroll_bars = Qnil;
-#endif
+#endif /* HAVE_WINDOW_SYSTEM && !HAVE_ANDROID */
DEFVAR_BOOL ("scroll-bar-adjust-thumb-portion",
scroll_bar_adjust_thumb_portion_p,
@@ -6617,7 +6709,7 @@ implicitly when there's no window system support.
Note that when a frame is not large enough to accommodate a change of
any of the parameters listed above, Emacs may try to enlarge the frame
even if this option is non-nil. */);
-#if defined (HAVE_WINDOW_SYSTEM)
+#if defined (HAVE_WINDOW_SYSTEM) && !defined (HAVE_ANDROID)
#if defined (USE_GTK) || defined (HAVE_NS)
frame_inhibit_implied_resize = list1 (Qtab_bar_lines);
#else
@@ -6762,4 +6854,17 @@ iconify the top level frame instead. */);
defsubr (&Sx_parse_geometry);
defsubr (&Sreconsider_frame_fonts);
#endif
+
+#ifdef HAVE_WINDOW_SYSTEM
+ DEFSYM (Qmove_toolbar, "move-toolbar");
+
+ /* The `tool-bar-position' frame parameter is supported on GTK and
+ builds using the internal tool bar. Providing this feature
+ causes menu-bar.el to provide `tool-bar-position' as a user
+ option. */
+
+#if !defined HAVE_EXT_TOOL_BAR || defined USE_GTK
+ Fprovide (Qmove_toolbar, Qnil);
+#endif /* !HAVE_EXT_TOOL_BAR || USE_GTK */
+#endif /* HAVE_WINDOW_SYSTEM */
}
diff --git a/src/frame.h b/src/frame.h
index abde824a9fb..e03362361a7 100644
--- a/src/frame.h
+++ b/src/frame.h
@@ -76,6 +76,66 @@ enum ns_appearance_type
#endif
#endif /* HAVE_WINDOW_SYSTEM */
+#ifdef HAVE_TEXT_CONVERSION
+
+enum text_conversion_operation
+ {
+ TEXTCONV_START_BATCH_EDIT,
+ TEXTCONV_END_BATCH_EDIT,
+ TEXTCONV_COMMIT_TEXT,
+ TEXTCONV_FINISH_COMPOSING_TEXT,
+ TEXTCONV_SET_COMPOSING_TEXT,
+ TEXTCONV_SET_COMPOSING_REGION,
+ TEXTCONV_SET_POINT_AND_MARK,
+ TEXTCONV_DELETE_SURROUNDING_TEXT,
+ TEXTCONV_REQUEST_POINT_UPDATE,
+ TEXTCONV_BARRIER,
+ TEXTCONV_REPLACE_TEXT,
+ };
+
+/* Structure describing a single edit being performed by the input
+ method that should be executed in the context of
+ kbd_buffer_get_event. */
+
+struct text_conversion_action
+{
+ /* The next text conversion action. */
+ struct text_conversion_action *next;
+
+ /* Any associated data. */
+ Lisp_Object data;
+
+ /* The operation being performed. */
+ enum text_conversion_operation operation;
+
+ /* Counter value. */
+ unsigned long counter;
+};
+
+/* Structure describing the text conversion state associated with a
+ frame. */
+
+struct text_conversion_state
+{
+ /* List of text conversion actions associated with this frame. */
+ struct text_conversion_action *actions;
+
+ /* Markers representing the composing region. */
+ Lisp_Object compose_region_start, compose_region_end;
+
+ /* Overlay representing the composing region. */
+ Lisp_Object compose_region_overlay;
+
+ /* The number of ongoing ``batch edits'' that are causing point
+ reporting to be delayed. */
+ int batch_edit_count;
+
+ /* Mask containing what must be updated after batch edits end. */
+ int batch_edit_flags;
+};
+
+#endif
+
/* The structure representing a frame. */
struct frame
@@ -181,7 +241,7 @@ struct frame
most recently buried buffer is first. For last-buffer. */
Lisp_Object buried_buffer_list;
-#if defined (HAVE_X_WINDOWS) && ! defined (USE_X_TOOLKIT) && ! defined (USE_GTK)
+#if defined HAVE_WINDOW_SYSTEM && !defined HAVE_EXT_MENU_BAR
/* A dummy window used to display menu bars under X when no X
toolkit support is available. */
Lisp_Object menu_bar_window;
@@ -205,11 +265,9 @@ struct frame
Lisp_Object current_tool_bar_string;
#endif
-#ifdef USE_GTK
/* Where tool bar is, can be left, right, top or bottom.
Except with GTK, the only supported position is `top'. */
Lisp_Object tool_bar_position;
-#endif
#if defined (HAVE_XFT) || defined (HAVE_FREETYPE)
/* List of data specific to font-driver and frame, but common to faces. */
@@ -287,6 +345,10 @@ struct frame
/* Set to true to minimize tool-bar height even when
auto-resize-tool-bar is set to grow-only. */
bool_bf minimize_tool_bar_window_p : 1;
+
+ /* Whether or not the tool bar contains a ``new line'' item. If
+ true, tool bar rows will be allowed to differ in height. */
+ bool_bf tool_bar_wraps_p : 1;
#endif
#ifdef HAVE_EXT_TOOL_BAR
@@ -377,7 +439,7 @@ struct frame
/* The output method says how the contents of this frame are
displayed. It could be using termcap, or using an X window.
This must be the same as the terminal->type. */
- ENUM_BF (output_method) output_method : 3;
+ ENUM_BF (output_method) output_method : 4;
#ifdef HAVE_WINDOW_SYSTEM
/* True if this frame is a tooltip frame. */
@@ -586,20 +648,22 @@ struct frame
well. */
union output_data
{
- struct tty_output *tty; /* From termchar.h. */
- struct x_output *x; /* From xterm.h. */
- struct w32_output *w32; /* From w32term.h. */
- struct ns_output *ns; /* From nsterm.h. */
- struct pgtk_output *pgtk; /* From pgtkterm.h. */
- struct haiku_output *haiku; /* From haikuterm.h. */
+ struct tty_output *tty; /* From termchar.h. */
+ struct x_output *x; /* From xterm.h. */
+ struct w32_output *w32; /* From w32term.h. */
+ struct ns_output *ns; /* From nsterm.h. */
+ struct pgtk_output *pgtk; /* From pgtkterm.h. */
+ struct haiku_output *haiku; /* From haikuterm.h. */
+ struct android_output *android; /* From androidterm.h. */
}
output_data;
/* List of font-drivers available on the frame. */
struct font_driver_list *font_driver_list;
-#if defined (HAVE_X_WINDOWS)
- /* Used by x_wait_for_event when watching for an X event on this frame. */
+#if defined HAVE_X_WINDOWS || defined HAVE_ANDROID
+ /* Used by x_wait_for_event when watching for an X event on this
+ frame. */
int wait_event_type;
#endif
@@ -662,6 +726,11 @@ struct frame
enum ns_appearance_type ns_appearance;
bool_bf ns_transparent_titlebar;
#endif
+
+#ifdef HAVE_TEXT_CONVERSION
+ /* Text conversion state used by certain input methods. */
+ struct text_conversion_state conversion;
+#endif
} GCALIGNED_STRUCT;
/* Most code should use these functions to set Lisp fields in struct frame. */
@@ -713,7 +782,7 @@ fset_menu_bar_vector (struct frame *f, Lisp_Object val)
{
f->menu_bar_vector = val;
}
-#if defined (HAVE_X_WINDOWS) && ! defined (USE_X_TOOLKIT) && ! defined (USE_GTK)
+#if defined HAVE_WINDOW_SYSTEM && !defined HAVE_EXT_MENU_BAR
INLINE void
fset_menu_bar_window (struct frame *f, Lisp_Object val)
{
@@ -782,14 +851,9 @@ fset_tool_bar_items (struct frame *f, Lisp_Object val)
{
f->tool_bar_items = val;
}
-#ifdef USE_GTK
-INLINE void
-fset_tool_bar_position (struct frame *f, Lisp_Object val)
-{
- f->tool_bar_position = val;
-}
-#endif /* USE_GTK */
+
#if defined (HAVE_WINDOW_SYSTEM) && ! defined (HAVE_EXT_TOOL_BAR)
+
INLINE void
fset_tool_bar_window (struct frame *f, Lisp_Object val)
{
@@ -805,7 +869,14 @@ fset_desired_tool_bar_string (struct frame *f, Lisp_Object val)
{
f->desired_tool_bar_string = val;
}
-#endif /* HAVE_WINDOW_SYSTEM && !USE_GTK && !HAVE_NS */
+
+#endif /* HAVE_WINDOW_SYSTEM && !HAVE_EXT_TOOL_BAR */
+
+INLINE void
+fset_tool_bar_position (struct frame *f, Lisp_Object val)
+{
+ f->tool_bar_position = val;
+}
INLINE double
NUMVAL (Lisp_Object x)
@@ -838,7 +909,7 @@ default_pixels_per_inch_y (void)
#define XFRAME(p) \
(eassert (FRAMEP (p)), XUNTAG (p, Lisp_Vectorlike, struct frame))
-#define XSETFRAME(a, b) (XSETPSEUDOVECTOR (a, b, PVEC_FRAME))
+#define XSETFRAME(a, b) XSETPSEUDOVECTOR (a, b, PVEC_FRAME)
/* Given a window, return its frame as a Lisp_Object. */
#define WINDOW_FRAME(w) ((w)->frame)
@@ -872,6 +943,11 @@ default_pixels_per_inch_y (void)
#else
#define FRAME_HAIKU_P(f) ((f)->output_method == output_haiku)
#endif
+#ifndef HAVE_ANDROID
+#define FRAME_ANDROID_P(f) false
+#else
+#define FRAME_ANDROID_P(f) ((f)->output_method == output_android)
+#endif
/* FRAME_WINDOW_P tests whether the frame is a graphical window system
frame. */
@@ -890,6 +966,9 @@ default_pixels_per_inch_y (void)
#ifdef HAVE_HAIKU
#define FRAME_WINDOW_P(f) FRAME_HAIKU_P (f)
#endif
+#ifdef HAVE_ANDROID
+#define FRAME_WINDOW_P(f) FRAME_ANDROID_P (f)
+#endif
#ifndef FRAME_WINDOW_P
#define FRAME_WINDOW_P(f) ((void) (f), false)
#endif
@@ -903,12 +982,26 @@ default_pixels_per_inch_y (void)
#define FRAME_RES_Y(f) \
(eassert (FRAME_WINDOW_P (f)), FRAME_DISPLAY_INFO (f)->resy)
+#ifdef HAVE_ANDROID
+
+/* Android systems use a font scaling factor independent from the
+ display DPI. */
+
+#define FRAME_RES(f) \
+ (eassert (FRAME_WINDOW_P (f)), \
+ FRAME_DISPLAY_INFO (f)->font_resolution)
+
+#else /* !HAVE_ANDROID */
+#define FRAME_RES(f) FRAME_RES_Y (f)
+#endif /* HAVE_ANDROID */
+
#else /* !HAVE_WINDOW_SYSTEM */
/* Defaults when no window system available. */
-#define FRAME_RES_X(f) default_pixels_per_inch_x ()
-#define FRAME_RES_Y(f) default_pixels_per_inch_y ()
+#define FRAME_RES_X(f) default_pixels_per_inch_x ()
+#define FRAME_RES_Y(f) default_pixels_per_inch_y ()
+#define FRAME_RES(f) default_pixels_per_inch_y ()
#endif /* HAVE_WINDOW_SYSTEM */
@@ -917,11 +1010,17 @@ default_pixels_per_inch_y (void)
frame F. We need to define two versions because a TTY-only build
does not have FRAME_DISPLAY_INFO. */
#ifdef HAVE_WINDOW_SYSTEM
+#ifndef HAVE_ANDROID
# define MOUSE_HL_INFO(F) \
- (FRAME_WINDOW_P(F) \
+ (FRAME_WINDOW_P (F) \
? &FRAME_DISPLAY_INFO(F)->mouse_highlight \
: &(F)->output_data.tty->display_info->mouse_highlight)
#else
+/* There is no "struct tty_output" on Android at all. */
+# define MOUSE_HL_INFO(F) \
+ (&FRAME_DISPLAY_INFO(F)->mouse_highlight)
+#endif
+#else
# define MOUSE_HL_INFO(F) \
(&(F)->output_data.tty->display_info->mouse_highlight)
#endif
@@ -984,32 +1083,89 @@ default_pixels_per_inch_y (void)
#define FRAME_EXTERNAL_TOOL_BAR(f) false
#endif
-/* This is really supported only with GTK. */
-#ifdef USE_GTK
+/* Position of F's tool bar; one of Qtop, Qleft, Qright, or
+ Qbottom.
+
+ Qleft and Qright are not supported outside GTK+. */
#define FRAME_TOOL_BAR_POSITION(f) (f)->tool_bar_position
-#else
-#define FRAME_TOOL_BAR_POSITION(f) ((void) (f), Qtop)
-#endif
/* Size of frame F's internal tool bar in frame lines and pixels. */
#define FRAME_TOOL_BAR_LINES(f) (f)->tool_bar_lines
#define FRAME_TOOL_BAR_HEIGHT(f) (f)->tool_bar_height
+/* Size of F's tool bar if it is placed at the top of the
+ frame, else 0. */
+
+#define FRAME_TOOL_BAR_TOP_HEIGHT(f) \
+ ((BASE_EQ ((f)->tool_bar_position, Qtop)) \
+ ? (f)->tool_bar_height : 0)
+
+#define FRAME_TOOL_BAR_TOP_LINES(f) \
+ ((BASE_EQ ((f)->tool_bar_position, Qtop)) \
+ ? (f)->tool_bar_lines : 0)
+
+/* Size of F's tool bar if it is placed at the bottom of the
+ frame. */
+#define FRAME_TOOL_BAR_BOTTOM_HEIGHT(f) \
+ ((BASE_EQ ((f)->tool_bar_position, Qbottom)) \
+ ? (f)->tool_bar_height : 0)
+
+#define FRAME_TOOL_BAR_BOTTOM_LINES(f) \
+ ((BASE_EQ ((f)->tool_bar_position, Qbottom)) \
+ ? (f)->tool_bar_lines : 0)
+
/* Height of frame F's top margin in frame lines. */
#define FRAME_TOP_MARGIN(F) \
(FRAME_MENU_BAR_LINES (F) \
+ FRAME_TAB_BAR_LINES (F) \
- + FRAME_TOOL_BAR_LINES (F))
+ + FRAME_TOOL_BAR_TOP_LINES (F))
/* Pixel height of frame F's top margin. */
+
#define FRAME_TOP_MARGIN_HEIGHT(F) \
(FRAME_MENU_BAR_HEIGHT (F) \
+ FRAME_TAB_BAR_HEIGHT (F) \
+ + FRAME_TOOL_BAR_TOP_HEIGHT (F))
+
+/* Height of F's bottom margin in frame lines. */
+
+#define FRAME_BOTTOM_MARGIN(f) \
+ FRAME_TOOL_BAR_BOTTOM_LINES (f)
+
+/* Pixel height of frame F's bottom margin. */
+
+#define FRAME_BOTTOM_MARGIN_HEIGHT(f) \
+ FRAME_TOOL_BAR_BOTTOM_HEIGHT (f)
+
+/* Size of both vertical margins combined. */
+
+#define FRAME_MARGINS(F) \
+ (FRAME_MENU_BAR_LINES (F) \
+ + FRAME_TAB_BAR_LINES (F) \
+ + FRAME_TOOL_BAR_LINES (F))
+
+#define FRAME_MARGIN_HEIGHT(F) \
+ (FRAME_MENU_BAR_HEIGHT (F) \
+ + FRAME_TAB_BAR_HEIGHT (F) \
+ FRAME_TOOL_BAR_HEIGHT (F))
/* True if frame F is currently visible. */
#define FRAME_VISIBLE_P(f) (f)->visible
+/* True if frame F should be redisplayed. This is normally the same
+ as FRAME_VISIBLE_P (f). Under X, frames can continue to be
+ displayed to the user by the compositing manager even if they are
+ invisible, so this also checks whether or not the frame is reported
+ visible by the X server. */
+
+#ifndef HAVE_X_WINDOWS
+#define FRAME_REDISPLAY_P(f) FRAME_VISIBLE_P (f)
+#else
+#define FRAME_REDISPLAY_P(f) (FRAME_VISIBLE_P (f) \
+ || (FRAME_X_P (f) \
+ && FRAME_X_VISIBLE (f)))
+#endif
+
/* True if frame F is currently visible but hidden. */
#define FRAME_OBSCURED_P(f) ((f)->visible > 1)
@@ -1366,6 +1522,10 @@ extern Lisp_Object mouse_position (bool);
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);
+#ifdef NS_IMPL_COCOA
+/* Implemented in nsfns.m. */
+extern void ns_make_frame_key_window (struct frame *);
+#endif
extern Lisp_Object Vframe_list;
/* Value is a pointer to the selected frame. If the selected frame
@@ -1611,7 +1771,7 @@ IMAGE_OPT_FROM_ID (struct frame *f, int id)
#define FRAME_PIXEL_HEIGHT_TO_TEXT_LINES(f, height) \
(((height) \
- - FRAME_TOP_MARGIN_HEIGHT (f) \
+ - FRAME_MARGIN_HEIGHT (f) \
- FRAME_SCROLL_BAR_AREA_HEIGHT (f) \
- 2 * FRAME_INTERNAL_BORDER_WIDTH (f)) \
/ FRAME_LINE_HEIGHT (f))
@@ -1626,7 +1786,7 @@ IMAGE_OPT_FROM_ID (struct frame *f, int id)
#define FRAME_TEXT_TO_PIXEL_HEIGHT(f, height) \
((height) \
- + FRAME_TOP_MARGIN_HEIGHT (f) \
+ + FRAME_MARGIN_HEIGHT (f) \
+ FRAME_SCROLL_BAR_AREA_HEIGHT (f) \
+ 2 * FRAME_INTERNAL_BORDER_WIDTH (f))
@@ -1640,7 +1800,7 @@ IMAGE_OPT_FROM_ID (struct frame *f, int id)
#define FRAME_PIXEL_TO_TEXT_HEIGHT(f, height) \
((height) \
- - FRAME_TOP_MARGIN_HEIGHT (f) \
+ - FRAME_MARGIN_HEIGHT (f) \
- FRAME_SCROLL_BAR_AREA_HEIGHT (f) \
- 2 * FRAME_INTERNAL_BORDER_WIDTH (f))
@@ -1650,7 +1810,7 @@ IMAGE_OPT_FROM_ID (struct frame *f, int id)
#define FRAME_INNER_HEIGHT(f) \
(FRAME_PIXEL_HEIGHT (f) \
- - FRAME_TOP_MARGIN_HEIGHT (f) \
+ - FRAME_MARGIN_HEIGHT (f) \
- 2 * FRAME_INTERNAL_BORDER_WIDTH (f))
/* Value is the smallest width of any character in any font on frame F. */
@@ -1718,7 +1878,6 @@ extern void x_wm_set_icon_position (struct frame *, int, int);
#if !defined USE_X_TOOLKIT
extern const char *x_get_resource_string (const char *, const char *);
#endif
-extern void x_sync (struct frame *);
#endif /* HAVE_X_WINDOWS */
#if !defined (HAVE_NS) && !defined (HAVE_PGTK)
diff --git a/src/fringe.c b/src/fringe.c
index c62e2f54e97..0642de5f772 100644
--- a/src/fringe.c
+++ b/src/fringe.c
@@ -1422,25 +1422,30 @@ If BITMAP overrides a standard fringe bitmap, the original bitmap is restored.
On X, we bit-swap the built-in bitmaps and reduce bitmap
from short to char array if width is <= 8 bits.
+ The Android port tries to follow X as closely as possible, so do
+ that there too.
+
On MAC with big-endian CPU, we need to byte-swap each short.
On W32 and MAC (little endian), there's no need to do this.
*/
-#if defined (HAVE_X_WINDOWS) || defined (HAVE_PGTK)
-static const unsigned char swap_nibble[16] = {
- 0x0, 0x8, 0x4, 0xc, /* 0000 1000 0100 1100 */
- 0x2, 0xa, 0x6, 0xe, /* 0010 1010 0110 1110 */
- 0x1, 0x9, 0x5, 0xd, /* 0001 1001 0101 1101 */
- 0x3, 0xb, 0x7, 0xf}; /* 0011 1011 0111 1111 */
-#endif /* HAVE_X_WINDOWS */
+#if defined (HAVE_X_WINDOWS) || defined (HAVE_PGTK) || defined (HAVE_ANDROID)
+static const unsigned char swap_nibble[16] =
+ {
+ 0x0, 0x8, 0x4, 0xc, /* 0000 1000 0100 1100 */
+ 0x2, 0xa, 0x6, 0xe, /* 0010 1010 0110 1110 */
+ 0x1, 0x9, 0x5, 0xd, /* 0001 1001 0101 1101 */
+ 0x3, 0xb, 0x7, 0xf, /* 0011 1011 0111 1111 */
+ };
+#endif
static void
init_fringe_bitmap (int which, struct fringe_bitmap *fb, int once_p)
{
if (once_p || fb->dynamic)
{
-#if defined (HAVE_X_WINDOWS)
+#if defined (HAVE_X_WINDOWS) || defined (HAVE_ANDROID)
unsigned short *bits = fb->bits;
int j;
@@ -1488,7 +1493,7 @@ init_fringe_bitmap (int which, struct fringe_bitmap *fb, int once_p)
}
}
#endif /* not USE_CAIRO */
-#endif /* HAVE_X_WINDOWS */
+#endif /* HAVE_X_WINDOWS || HAVE_ANDROID */
#if !defined(HAVE_X_WINDOWS) && defined (HAVE_PGTK)
unsigned short *bits = fb->bits;
diff --git a/src/ftfont.c b/src/ftfont.c
index b1173f07f0a..0d10de5408f 100644
--- a/src/ftfont.c
+++ b/src/ftfont.c
@@ -1572,6 +1572,12 @@ ftfont_glyph_metrics (FT_Face ft_face, int c, int *advance, int *lbearing,
if (FT_Load_Glyph (ft_face, c, FT_LOAD_DEFAULT) == 0)
{
FT_Glyph_Metrics *m = &ft_face->glyph->metrics;
+
+ /* At first glance this might appear to truncate the glyph's
+ horizontal advance, but FreeType internally rounds the
+ advance width to a pixel boundary prior to returning these
+ metrics. */
+
*advance = m->horiAdvance >> 6;
*lbearing = m->horiBearingX >> 6;
*rbearing = (m->horiBearingX + m->width) >> 6;
diff --git a/src/gfilenotify.c b/src/gfilenotify.c
index b54dbdfe649..8733db11997 100644
--- a/src/gfilenotify.c
+++ b/src/gfilenotify.c
@@ -88,7 +88,9 @@ dir_monitor_callback (GFileMonitor *monitor,
&& !NILP (Fmember (symbol, list5 (Qchanged, Qchanges_done_hint,
Qdeleted, Qcreated, Qmoved))))
|| (!NILP (Fmember (Qattribute_change, flags))
- && EQ (symbol, Qattribute_changed)))
+ && EQ (symbol, Qattribute_changed))
+ || (!NILP (Fmember (Qwatch_mounts, flags))
+ && EQ (symbol, Qunmounted)))
{
/* Construct an event. */
EVENT_INIT (event);
@@ -105,8 +107,8 @@ dir_monitor_callback (GFileMonitor *monitor,
/* XD_DEBUG_MESSAGE ("%s", XD_OBJECT_TO_STRING (event.arg)); */
}
- /* Cancel monitor if file or directory is deleted. */
- if (!NILP (Fmember (symbol, list2 (Qdeleted, Qmoved)))
+ /* Cancel monitor if file or directory is deleted or unmounted. */
+ if (!NILP (Fmember (symbol, list3 (Qdeleted, Qmoved, Qunmounted)))
&& strcmp (name, SSDATA (XCAR (XCDR (watch_object)))) == 0
&& !g_file_monitor_is_cancelled (monitor))
g_file_monitor_cancel (monitor);
diff --git a/src/gnutls.c b/src/gnutls.c
index 52e96791ff0..54b7eb4c90e 100644
--- a/src/gnutls.c
+++ b/src/gnutls.c
@@ -34,6 +34,7 @@ along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. */
# endif
# if GNUTLS_VERSION_NUMBER >= 0x030200
+# define HAVE_GNUTLS_CERTIFICATE_SET_X509_KEY_FILE2
# define HAVE_GNUTLS_CIPHER_GET_IV_SIZE
# endif
@@ -50,6 +51,10 @@ along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. */
# define HAVE_GNUTLS_ETM_STATUS
# endif
+# if GNUTLS_VERSION_NUMBER >= 0x030401
+# define HAVE_GNUTLS_KEYID_USE_SHA256
+# endif
+
# if GNUTLS_VERSION_NUMBER < 0x030600
# define HAVE_GNUTLS_COMPRESSION_GET
# endif
@@ -121,6 +126,11 @@ DEF_DLL_FN (int, gnutls_certificate_set_x509_crl_file,
DEF_DLL_FN (int, gnutls_certificate_set_x509_key_file,
(gnutls_certificate_credentials_t, const char *, const char *,
gnutls_x509_crt_fmt_t));
+# ifdef HAVE_GNUTLS_CERTIFICATE_SET_X509_KEY_FILE2
+DEF_DLL_FN (int, gnutls_certificate_set_x509_key_file2,
+ (gnutls_certificate_credentials_t, const char *, const char *,
+ gnutls_x509_crt_fmt_t, const char *, unsigned int));
+# endif
# ifdef HAVE_GNUTLS_X509_SYSTEM_TRUST
DEF_DLL_FN (int, gnutls_certificate_set_x509_system_trust,
(gnutls_certificate_credentials_t));
@@ -314,6 +324,9 @@ init_gnutls_functions (void)
LOAD_DLL_FN (library, gnutls_certificate_set_verify_flags);
LOAD_DLL_FN (library, gnutls_certificate_set_x509_crl_file);
LOAD_DLL_FN (library, gnutls_certificate_set_x509_key_file);
+# ifdef HAVE_GNUTLS_CERTIFICATE_SET_X509_KEY_FILE2
+ LOAD_DLL_FN (library, gnutls_certificate_set_x509_key_file2);
+# endif
# ifdef HAVE_GNUTLS_X509_SYSTEM_TRUST
LOAD_DLL_FN (library, gnutls_certificate_set_x509_system_trust);
# endif
@@ -455,6 +468,9 @@ init_gnutls_functions (void)
# define gnutls_certificate_set_verify_flags fn_gnutls_certificate_set_verify_flags
# define gnutls_certificate_set_x509_crl_file fn_gnutls_certificate_set_x509_crl_file
# define gnutls_certificate_set_x509_key_file fn_gnutls_certificate_set_x509_key_file
+# ifdef HAVE_GNUTLS_CERTIFICATE_SET_X509_KEY_FILE2
+# define gnutls_certificate_set_x509_key_file2 fn_gnutls_certificate_set_x509_key_file2
+# endif
# define gnutls_certificate_set_x509_system_trust fn_gnutls_certificate_set_x509_system_trust
# define gnutls_certificate_set_x509_trust_file fn_gnutls_certificate_set_x509_trust_file
# define gnutls_certificate_type_get fn_gnutls_certificate_type_get
@@ -1071,8 +1087,8 @@ gnutls_hex_string (unsigned char *buf, ptrdiff_t buf_size, const char *prefix)
{
ptrdiff_t prefix_length = strlen (prefix);
ptrdiff_t retlen;
- if (INT_MULTIPLY_WRAPV (buf_size, 3, &retlen)
- || INT_ADD_WRAPV (prefix_length - (buf_size != 0), retlen, &retlen))
+ if (ckd_mul (&retlen, buf_size, 3)
+ || ckd_add (&retlen, retlen, prefix_length - (buf_size != 0)))
string_overflow ();
Lisp_Object ret = make_uninit_string (retlen);
char *string = SSDATA (ret);
@@ -1266,6 +1282,23 @@ emacs_gnutls_certificate_details (gnutls_x509_crt_t cert)
xfree (buf);
}
+#ifdef HAVE_GNUTLS_KEYID_USE_SHA256
+ /* Public key ID, SHA-256 version. */
+ buf_size = 0;
+ err = gnutls_x509_crt_get_key_id (cert, GNUTLS_KEYID_USE_SHA256, NULL, &buf_size);
+ check_memory_full (err);
+ if (err == GNUTLS_E_SHORT_MEMORY_BUFFER)
+ {
+ void *buf = xmalloc (buf_size);
+ err = gnutls_x509_crt_get_key_id (cert, GNUTLS_KEYID_USE_SHA256, buf, &buf_size);
+ check_memory_full (err);
+ if (err >= GNUTLS_E_SUCCESS)
+ res = nconc2 (res, list2 (intern (":public-key-id-sha256"),
+ gnutls_hex_string (buf, buf_size, "sha256:")));
+ xfree (buf);
+ }
+#endif
+
/* Certificate fingerprint. */
buf_size = 0;
err = gnutls_x509_crt_get_fingerprint (cert, GNUTLS_DIG_SHA1,
@@ -1774,6 +1807,88 @@ gnutls_verify_boot (Lisp_Object proc, Lisp_Object proplist)
return gnutls_make_error (ret);
}
+#ifdef HAVE_GNUTLS_CERTIFICATE_SET_X509_KEY_FILE2
+
+/* Helper function for gnutls-boot.
+
+ The key :flags receives a list of symbols, each of which
+ corresponds to a GnuTLS C flag, the ORed result is to be passed to
+ the function `gnutls_certificate_set_x509_key_file2' as its last
+ argument. */
+static unsigned int
+key_file2_aux (Lisp_Object flags)
+{
+ unsigned int rv = 0;
+ Lisp_Object tail = flags;
+ FOR_EACH_TAIL_SAFE (tail)
+ {
+ Lisp_Object flag = XCAR (tail);
+ if (EQ (flag, Qgnutls_pkcs_plain))
+ rv |= GNUTLS_PKCS_PLAIN;
+#ifdef GNUTLS_PKCS_PKCS12_3DES
+ else if (EQ (flag, Qgnutls_pkcs_pkcs12_3des))
+ rv |= GNUTLS_PKCS_PKCS12_3DES;
+#endif
+#ifdef GNUTLS_PKCS_PKCS12_ARCFOUR
+ else if (EQ (flag, Qgnutls_pkcs_pkcs12_arcfour))
+ rv |= GNUTLS_PKCS_PKCS12_ARCFOUR;
+#endif
+#ifdef GNUTLS_PKCS_PKCS12_RC2_40
+ else if (EQ (flag, Qgnutls_pkcs_pkcs12_rc2_40))
+ rv |= GNUTLS_PKCS_PKCS12_RC2_40;
+#endif
+#ifdef GNUTLS_PKCS_PBES2_3DES
+ else if (EQ (flag, Qgnutls_pkcs_pbes2_3des))
+ rv |= GNUTLS_PKCS_PBES2_3DES;
+#endif
+#ifdef GNUTLS_PKCS_PBES2_AES_128
+ else if (EQ (flag, Qgnutls_pkcs_pbes2_aes_128))
+ rv |= GNUTLS_PKCS_PBES2_AES_128;
+#endif
+#ifdef GNUTLS_PKCS_PBES2_AES_192
+ else if (EQ (flag, Qgnutls_pkcs_pbes2_aes_192))
+ rv |= GNUTLS_PKCS_PBES2_AES_192;
+#endif
+#ifdef GNUTLS_PKCS_PBES2_AES_256
+ else if (EQ (flag, Qgnutls_pkcs_pbes2_aes_256))
+ rv |= GNUTLS_PKCS_PBES2_AES_256;
+#endif
+ else if (EQ (flag, Qgnutls_pkcs_null_password))
+ rv |= GNUTLS_PKCS_NULL_PASSWORD;
+#ifdef GNUTLS_PKCS_PBES2_DES
+ else if (EQ (flag, Qgnutls_pkcs_pbes2_des))
+ rv |= GNUTLS_PKCS_PBES2_DES;
+#endif
+#ifdef GNUTLS_PKCS_PBES1_DES_MD5
+ else if (EQ (flag, Qgnutls_pkcs_pbes1_des_md5))
+ rv |= GNUTLS_PKCS_PBES1_DES_MD5;
+#endif
+#ifdef GNUTLS_PKCS_PBES2_GOST_TC26Z
+ else if (EQ (flag, Qgnutls_pkcs_pbes2_gost_tc26z))
+ rv |= GNUTLS_PKCS_PBES2_GOST_TC26Z;
+#endif
+#ifdef GNUTLS_PKCS_PBES2_GOST_CPA
+ else if (EQ (flag, Qgnutls_pkcs_pbes2_gost_cpa))
+ rv |= GNUTLS_PKCS_PBES2_GOST_CPA;
+#endif
+#ifdef GNUTLS_PKCS_PBES2_GOST_CPB
+ else if (EQ (flag, Qgnutls_pkcs_pbes2_gost_cpb))
+ rv |= GNUTLS_PKCS_PBES2_GOST_CPB;
+#endif
+#ifdef GNUTLS_PKCS_PBES2_GOST_CPC
+ else if (EQ (flag, Qgnutls_pkcs_pbes2_gost_cpc))
+ rv |= GNUTLS_PKCS_PBES2_GOST_CPC;
+#endif
+#ifdef GNUTLS_PKCS_PBES2_GOST_CPD
+ else if (EQ (flag, Qgnutls_pkcs_pbes2_gost_cpd))
+ rv |= GNUTLS_PKCS_PBES2_GOST_CPD;
+#endif
+ }
+ return rv;
+}
+
+#endif /* HAVE_GNUTLS_CERTIFICATE_SET_X509_KEY_FILE2 */
+
DEFUN ("gnutls-boot", Fgnutls_boot, Sgnutls_boot, 3, 3, 0,
doc: /* Initialize GnuTLS client for process PROC with TYPE+PROPLIST.
Currently only client mode is supported. Return a success/failure
@@ -1813,6 +1928,22 @@ accept in Diffie-Hellman key exchange.
:complete-negotiation, if non-nil, will make negotiation complete
before returning even on non-blocking sockets.
+:pass, the password of the private key as per GnuTLS'
+gnutls_certificate_set_x509_key_file2. Specify as nil to have a NULL
+password.
+
+:flags, a list of symbols relating to :pass, each specifying a flag:
+GNUTLS_PKCS_PLAIN, GNUTLS_PKCS_PKCS12_3DES,
+GNUTLS_PKCS_PKCS12_ARCFOUR, GNUTLS_PKCS_PKCS12_RC2_40,
+GNUTLS_PKCS_PBES2_3DES, GNUTLS_PKCS_PBES2_AES_128,
+GNUTLS_PKCS_PBES2_AES_192, GNUTLS_PKCS_PBES2_AES_256,
+GNUTLS_PKCS_NULL_PASSWORD, GNUTLS_PKCS_PBES2_DES,
+GNUTLS_PKCS_PBES2_DES_MD5, GNUTLS_PKCS_PBES2_GOST_TC26Z,
+GNUTLS_PKCS_PBES2_GOST_CPA, GNUTLS_PKCS_PBES2_GOST_CPB,
+GNUTLS_PKCS_PBES2_GOST_CPC, GNUTLS_PKCS_PBES2_GOST_CPD. If not
+specified, or if nil, the bitflag with value 0 is used.
+Note that some of these are only supported since GnuTLS 3.6.3.
+
The debug level will be set for this process AND globally for GnuTLS.
So if you set it higher or lower at any point, it affects global
debugging.
@@ -1825,6 +1956,9 @@ Processes must be initialized with this function before other GnuTLS
functions are used. This function allocates resources which can only
be deallocated by calling `gnutls-deinit' or by calling it again.
+The :pass and :flags keys are ignored with old versions of GnuTLS, and
+:flags is ignored if :pass is not specified.
+
The callbacks alist can have a `verify' key, associated with a
verification function (UNUSED).
@@ -1842,16 +1976,22 @@ one trustfile (usually a CA bundle). */)
Lisp_Object global_init;
char const *priority_string_ptr = "NORMAL"; /* default priority string. */
char *c_hostname;
+ const char *c_pass;
/* Placeholders for the property list elements. */
Lisp_Object priority_string;
Lisp_Object trustfiles;
Lisp_Object crlfiles;
Lisp_Object keylist;
+ Lisp_Object pass;
+ Lisp_Object flags;
/* Lisp_Object callbacks; */
Lisp_Object loglevel;
Lisp_Object hostname;
Lisp_Object prime_bits;
+#ifdef HAVE_GNUTLS_CERTIFICATE_SET_X509_KEY_FILE2
+ unsigned int aux_key_file;
+#endif
struct Lisp_Process *p = XPROCESS (proc);
CHECK_PROCESS (proc);
@@ -1877,6 +2017,13 @@ one trustfile (usually a CA bundle). */)
crlfiles = plist_get (proplist, QCcrlfiles);
loglevel = plist_get (proplist, QCloglevel);
prime_bits = plist_get (proplist, QCmin_prime_bits);
+ pass = plist_get (proplist, QCpass);
+ flags = plist_get (proplist, QCflags);
+
+ if (STRINGP (pass))
+ c_pass = SSDATA (pass);
+ else
+ c_pass = NULL;
if (!STRINGP (hostname))
{
@@ -2038,6 +2185,20 @@ one trustfile (usually a CA bundle). */)
keyfile = ansi_encode_filename (keyfile);
certfile = ansi_encode_filename (certfile);
# endif
+# ifdef HAVE_GNUTLS_CERTIFICATE_SET_X509_KEY_FILE2
+ if (!NILP (plist_member (proplist, QCpass)))
+ {
+ aux_key_file = key_file2_aux (flags);
+ ret
+ = gnutls_certificate_set_x509_key_file2 (x509_cred,
+ SSDATA (certfile),
+ SSDATA (keyfile),
+ file_format,
+ c_pass,
+ aux_key_file);
+ }
+ else
+# endif
ret = gnutls_certificate_set_x509_key_file
(x509_cred, SSDATA (certfile), SSDATA (keyfile), file_format);
@@ -2238,7 +2399,7 @@ gnutls_symmetric_aead (bool encrypting, gnutls_cipher_algorithm_t gca,
ptrdiff_t cipher_tag_size = gnutls_cipher_get_tag_size (gca);
ptrdiff_t tagged_size;
- if (INT_ADD_WRAPV (isize, cipher_tag_size, &tagged_size)
+ if (ckd_add (&tagged_size, isize, cipher_tag_size)
|| SIZE_MAX < tagged_size)
memory_full (SIZE_MAX);
size_t storage_length = tagged_size;
@@ -2265,6 +2426,9 @@ gnutls_symmetric_aead (bool encrypting, gnutls_cipher_algorithm_t gca,
aead_auth_size = aend_byte - astart_byte;
}
+ /* Only block ciphers require that ISIZE be a multiple of the block
+ size, and AEAD ciphers are not block ciphers. */
+#if 0
ptrdiff_t expected_remainder = encrypting ? 0 : cipher_tag_size;
ptrdiff_t cipher_block_size = gnutls_cipher_get_block_size (gca);
@@ -2274,6 +2438,7 @@ gnutls_symmetric_aead (bool encrypting, gnutls_cipher_algorithm_t gca,
"is not %"pD"d greater than a multiple of the required %"pD"d"),
gnutls_cipher_get_name (gca), desc,
isize, expected_remainder, cipher_block_size);
+#endif
ret = ((encrypting ? gnutls_aead_cipher_encrypt : gnutls_aead_cipher_decrypt)
(acipher, vdata, vsize, aead_auth_data, aead_auth_size,
@@ -2282,7 +2447,7 @@ gnutls_symmetric_aead (bool encrypting, gnutls_cipher_algorithm_t gca,
Lisp_Object output;
if (GNUTLS_E_SUCCESS <= ret)
output = make_unibyte_string (storage, storage_length);
- explicit_bzero (storage, storage_length);
+ memset_explicit (storage, 0, storage_length);
gnutls_aead_cipher_deinit (acipher);
if (ret < GNUTLS_E_SUCCESS)
@@ -2862,8 +3027,26 @@ level in the ones. For builds without libgnutls, the value is -1. */);
DEFSYM (QCmin_prime_bits, ":min-prime-bits");
DEFSYM (QCloglevel, ":loglevel");
DEFSYM (QCcomplete_negotiation, ":complete-negotiation");
+ DEFSYM (QCpass, ":pass");
+ DEFSYM (QCflags, ":flags");
DEFSYM (QCverify_flags, ":verify-flags");
DEFSYM (QCverify_error, ":verify-error");
+ DEFSYM (Qgnutls_pkcs_plain, "GNUTLS_PKCS_PLAIN");
+ DEFSYM (Qgnutls_pkcs_pkcs12_3des, "GNUTLS_PKCS_PKCS12_3DES");
+ DEFSYM (Qgnutls_pkcs_pkcs12_arcfour, "GNUTLS_PKCS_PKCS12_ARCFOUR");
+ DEFSYM (Qgnutls_pkcs_pkcs12_rc2_40, "GNUTLS_PKCS_PKCS12_RC2_40");
+ DEFSYM (Qgnutls_pkcs_pbes2_3des, "GNUTLS_PKCS_PBES2_3DES");
+ DEFSYM (Qgnutls_pkcs_pbes2_aes_128, "GNUTLS_PKCS_PBES2_AES_128");
+ DEFSYM (Qgnutls_pkcs_pbes2_aes_192, "GNUTLS_PKCS_PBES2_AES_192");
+ DEFSYM (Qgnutls_pkcs_pbes2_aes_256, "GNUTLS_PKCS_PBES2_AES_256");
+ DEFSYM (Qgnutls_pkcs_null_password, "GNUTLS_PKCS_NULL_PASSWORD");
+ DEFSYM (Qgnutls_pkcs_pbes2_des, "GNUTLS_PKCS_PBES2_DES");
+ DEFSYM (Qgnutls_pkcs_pbes1_des_md5, "GNUTLS_PKCS_PBES1_DES_MD5");
+ DEFSYM (Qgnutls_pkcs_pbes2_gost_tc26z, "GNUTLS_PKCS_PBES2_GOST_TC26Z");
+ DEFSYM (Qgnutls_pkcs_pbes2_gost_cpa, "GNUTLS_PKCS_PBES2_GOST_CPA");
+ DEFSYM (Qgnutls_pkcs_pbes2_gost_cpb, "GNUTLS_PKCS_PBES2_GOST_CPB");
+ DEFSYM (Qgnutls_pkcs_pbes2_gost_cpc, "GNUTLS_PKCS_PBES2_GOST_CPC");
+ DEFSYM (Qgnutls_pkcs_pbes2_gost_cpd, "GNUTLS_PKCS_PBES2_GOST_CPD");
DEFSYM (QCcipher_id, ":cipher-id");
DEFSYM (QCcipher_aead_capable, ":cipher-aead-capable");
diff --git a/src/gtkutil.c b/src/gtkutil.c
index c4dc8e28c7a..c067f7b53ac 100644
--- a/src/gtkutil.c
+++ b/src/gtkutil.c
@@ -117,10 +117,10 @@ static void xg_widget_style_updated (GtkWidget *, gpointer);
#define gtk_box_new(ori, spacing) \
((ori) == GTK_ORIENTATION_HORIZONTAL \
- ? gtk_hbox_new (FALSE, (spacing)) : gtk_vbox_new (FALSE, (spacing)))
+ ? gtk_hbox_new (FALSE, spacing) : gtk_vbox_new (FALSE, spacing))
#define gtk_scrollbar_new(ori, spacing) \
((ori) == GTK_ORIENTATION_HORIZONTAL \
- ? gtk_hscrollbar_new ((spacing)) : gtk_vscrollbar_new ((spacing)))
+ ? gtk_hscrollbar_new (spacing) : gtk_vscrollbar_new (spacing))
#endif /* HAVE_GTK3 */
#define XG_BIN_CHILD(x) gtk_bin_get_child (GTK_BIN (x))
@@ -694,8 +694,8 @@ get_utf8_string (const char *str)
len = strlen (str);
ptrdiff_t alloc;
- if (INT_MULTIPLY_WRAPV (nr_bad, 4, &alloc)
- || INT_ADD_WRAPV (len + 1, alloc, &alloc)
+ if (ckd_mul (&alloc, nr_bad, 4)
+ || ckd_add (&alloc, alloc, len + 1)
|| SIZE_MAX < alloc)
memory_full (SIZE_MAX);
up = utf8_str = xmalloc (alloc);
@@ -2103,7 +2103,7 @@ xg_frame_restack (struct frame *f1, struct frame *f2, bool above_flag)
gdk_window_restack (gwin1, gwin2, above_flag);
#ifndef HAVE_PGTK
- x_sync (f1);
+ XSync (FRAME_X_DISPLAY (f1), False);
#else
gdk_flush ();
#endif
@@ -4141,7 +4141,7 @@ xg_update_frame_menubar (struct frame *f)
g_signal_connect (x->menubar_widget, "map", G_CALLBACK (menubar_map_cb), f);
gtk_widget_show_all (x->menubar_widget);
gtk_widget_get_preferred_size (x->menubar_widget, NULL, &req);
- req.height *= xg_get_scale (f);
+ req.height *= scale;
#if !defined HAVE_PGTK && defined HAVE_GTK3
if (FRAME_DISPLAY_INFO (f)->n_planes == 32)
@@ -4154,9 +4154,9 @@ xg_update_frame_menubar (struct frame *f)
}
#endif
- if (FRAME_MENUBAR_HEIGHT (f) != (req.height * scale))
+ if (FRAME_MENUBAR_HEIGHT (f) != req.height)
{
- FRAME_MENUBAR_HEIGHT (f) = req.height * scale;
+ FRAME_MENUBAR_HEIGHT (f) = req.height;
adjust_frame_size (f, -1, -1, 2, 0, Qmenu_bar_lines);
}
unblock_input ();
@@ -4793,7 +4793,7 @@ xg_update_scrollbar_pos (struct frame *f,
here to get some events. */
#ifndef HAVE_PGTK
- x_sync (f);
+ XSync (FRAME_X_DISPLAY (f), False);
#else
gdk_flush ();
#endif
@@ -4894,7 +4894,7 @@ xg_update_horizontal_scrollbar_pos (struct frame *f,
}
#ifndef HAVE_PGTK
- x_sync (f);
+ XSync (FRAME_X_DISPLAY (f), False);
#else
gdk_flush ();
#endif
diff --git a/src/haiku_io.c b/src/haiku_io.c
index 29e497e6e5b..f0862965bd8 100644
--- a/src/haiku_io.c
+++ b/src/haiku_io.c
@@ -111,6 +111,8 @@ haiku_len (enum haiku_event_type type)
return sizeof (struct haiku_clipboard_changed_event);
case FONT_CHANGE_EVENT:
return sizeof (struct haiku_font_change_event);
+ case NOTIFICATION_CLICK_EVENT:
+ return sizeof (struct haiku_notification_click_event);
}
emacs_abort ();
diff --git a/src/haiku_select.cc b/src/haiku_select.cc
index 6855f9d5a50..f497eb3d24b 100644
--- a/src/haiku_select.cc
+++ b/src/haiku_select.cc
@@ -17,15 +17,25 @@ You should have received a copy of the GNU General Public License
along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. */
#include <config.h>
+#include <intprops.h>
+#include <stdckdint.h>
#include <Application.h>
+#include <Bitmap.h>
#include <Clipboard.h>
+#include <Entry.h>
#include <Message.h>
+#include <Notification.h>
+#include <OS.h>
#include <Path.h>
-#include <Entry.h>
+#include <String.h>
+
+#include <translation/TranslationUtils.h>
#include <cstdlib>
#include <cstring>
+#include <cstdint>
+#include <cstdio>
#include "haikuselect.h"
@@ -58,6 +68,10 @@ static bool owned_secondary;
/* And the clipboard. */
static bool owned_clipboard;
+
+
+/* C++ clipboard support. */
+
static BClipboard *
get_clipboard_object (enum haiku_clipboard clipboard)
{
@@ -517,3 +531,133 @@ be_get_clipboard_count (enum haiku_clipboard id)
clipboard = get_clipboard_object (id);
return clipboard->SystemCount ();
}
+
+
+
+/* C++ notifications support.
+
+ Desktop notifications on Haiku lack some of the features furnished
+ by notifications.el, specifically displaying multiple titled
+ actions within a single notification, sending callbacks when the
+ notification is dismissed, and providing a timeout after which the
+ notification is hidden.
+
+ Other features, such as notification categories and identifiers,
+ have clean straightforward relationships with their counterparts in
+ notifications.el. */
+
+/* The last notification ID allocated. */
+static intmax_t last_notification_id;
+
+/* Return the `enum notification_type' for TYPE. TYPE is the TYPE
+ argument to a call to `be_display_notification'. */
+
+static enum notification_type
+type_for_type (int type)
+{
+ switch (type)
+ {
+ case 0:
+ return B_INFORMATION_NOTIFICATION;
+
+ case 1:
+ return B_IMPORTANT_NOTIFICATION;
+
+ case 2:
+ return B_ERROR_NOTIFICATION;
+ }
+
+ abort ();
+}
+
+/* Return the ID of this team. */
+
+static team_id
+my_team_id (void)
+{
+ thread_id id;
+ thread_info info;
+
+ id = find_thread (NULL);
+ get_thread_info (id, &info);
+
+ return info.team;
+}
+
+/* Display a desktop notification and return its identifier.
+
+ TITLE is the title text of the notification, encoded as UTF-8 text.
+
+ BODY is the text to be displayed within the body of the
+ notification.
+
+ SUPERSEDES is the identifier of a previous notification to replace,
+ or -1 if a new notification should be displayed.
+
+ TYPE states the urgency of the notification. If 0, the
+ notification is displayed without special decoration. If 1, the
+ notification is displayed with a blue band to its left, identifying
+ it as a notification of medium importance. If 2, the notification
+ is displayed with a red band to its left, marking it as one of
+ critical importance.
+
+ ICON is the name of a file containing the icon of the notification,
+ or NULL, in which case Emacs's app icon will be displayed. */
+
+intmax_t
+be_display_notification (const char *title, const char *body,
+ intmax_t supersedes, int type, const char *icon)
+{
+ intmax_t id;
+ BNotification notification (type_for_type (type));
+ char buffer[INT_STRLEN_BOUND (team_id)
+ + INT_STRLEN_BOUND (intmax_t)
+ + sizeof "."];
+ BBitmap *bitmap;
+
+ if (supersedes < 0)
+ {
+ /* SUPERSEDES hasn't been provided, so allocate a new
+ notification ID. */
+
+ ckd_add (&last_notification_id, last_notification_id, 1);
+ id = last_notification_id;
+ }
+ else
+ id = supersedes;
+
+ /* Set the title and body text. */
+ notification.SetTitle (title);
+ notification.SetContent (body);
+
+ /* Derive the notification ID from the ID of this team, so as to
+ avoid abrogating notifications from other Emacs sessions. */
+ sprintf (buffer, "%d.%jd", my_team_id (), id);
+ notification.SetMessageID (BString (buffer));
+
+ /* Now set the bitmap icon, if given. */
+
+ if (icon)
+ {
+ bitmap = BTranslationUtils::GetBitmap (icon);
+
+ if (bitmap)
+ {
+ notification.SetIcon (bitmap);
+ delete bitmap;
+ }
+ }
+
+ /* After this, Emacs::ArgvReceived should be called when the
+ notification is clicked. Lamentably, this does not come about,
+ probably because arguments are only passed to applications if
+ they are not yet running. */
+#if 0
+ notification.SetOnClickApp ("application/x-vnd.GNU-emacs");
+ notification.AddOnClickArg (BString ("-Notification,") += buffer);
+#endif /* 0 */
+
+ /* Finally, send the notification. */
+ notification.Send ();
+ return id;
+}
diff --git a/src/haiku_support.cc b/src/haiku_support.cc
index 7ffc52896b9..1b9c5acdf14 100644
--- a/src/haiku_support.cc
+++ b/src/haiku_support.cc
@@ -581,6 +581,24 @@ public:
}
};
+#if 0
+
+/* Return the ID of this team. */
+
+static team_id
+my_team_id (void)
+{
+ thread_id id;
+ thread_info info;
+
+ id = find_thread (NULL);
+ get_thread_info (id, &info);
+
+ return info.team;
+}
+
+#endif /* 0 */
+
class Emacs : public BApplication
{
public:
@@ -621,7 +639,8 @@ public:
{
BAlert *about = new BAlert (PACKAGE_NAME,
PACKAGE_STRING
- "\nThe extensible, self-documenting, real-time display editor.",
+ "\nThe extensible, self-documenting, "
+ "real-time display editor.",
"Close");
about->Go ();
}
@@ -674,6 +693,39 @@ public:
else
BApplication::MessageReceived (msg);
}
+
+ /* The code below doesn't function; see `be_display_notification'
+ for further specifics. */
+
+#if 0
+ void
+ ArgvReceived (int32 argc, char **argv)
+ {
+ struct haiku_notification_click_event rq;
+ intmax_t id;
+ team_id team;
+
+ /* ArgvReceived is called after Emacs is first started, with each
+ command line argument passed to Emacs. It is, moreover, called
+ with ARGC set to 1 and ARGV[0] a string starting with
+ -Notification, after a notification is clicked. This string
+ both incorporates the team ID and the notification ID. */
+
+ if (argc == 1
+ && sscanf (argv[0], "-Notification,%d.%jd", &team, &id) == 2)
+ {
+ /* Since this is a valid notification message, generate an
+ event if the team ID matches. */
+ if (team == my_team_id ())
+ {
+ rq.id = id;
+ haiku_write (NOTIFICATION_CLICK_EVENT, &rq);
+ }
+ }
+
+ BApplication::ArgvReceived (argc, argv);
+ }
+#endif /* 0 */
};
class EmacsWindow : public BWindow
@@ -689,8 +741,6 @@ public:
EmacsWindow *parent;
BRect pre_fullscreen_rect;
BRect pre_zoom_rect;
- int x_before_zoom;
- int y_before_zoom;
bool shown_flag;
volatile bool was_shown_p;
bool menu_bar_active_p;
@@ -708,8 +758,6 @@ public:
B_NORMAL_WINDOW_FEEL, B_NO_SERVER_SIDE_WINDOW_MODIFIERS),
subset_windows (NULL),
parent (NULL),
- x_before_zoom (INT_MIN),
- y_before_zoom (INT_MIN),
shown_flag (false),
was_shown_p (false),
menu_bar_active_p (false),
@@ -1011,6 +1059,8 @@ public:
msg->FindInt64 ("when", &rq.time);
rq.modifiers = 0;
+ rq.keysym = 0;
+
uint32_t mods = modifiers ();
if (mods & B_SHIFT_KEY)
@@ -1025,10 +1075,39 @@ public:
if (mods & B_OPTION_KEY)
rq.modifiers |= HAIKU_MODIFIER_SUPER;
- ret = keysym_from_raw_char (raw, key, &rq.keysym);
+ /* mods & B_SHIFT_KEY should be inverted if keycode is
+ situated in the numeric keypad and Num Lock is set, for
+ this transformation is not effected on key events
+ themselves. */
- if (!ret)
- rq.keysym = 0;
+ if (mods & B_NUM_LOCK)
+ {
+ switch (key)
+ {
+ case 0x37:
+ case 0x38:
+ case 0x39:
+ case 0x48:
+ case 0x49:
+ case 0x4a:
+ case 0x58:
+ case 0x59:
+ case 0x5a:
+ case 0x64:
+ case 0x65:
+ mods ^= B_SHIFT_KEY;
+
+ /* If shift is set at this juncture, map these keys to
+ the digits they represent. Because raw is not
+ affected by Num Lock, keysym_from_raw_char will map
+ this to the keysym yielded by this key in the
+ absence of any modifiers. */
+ if (mods & B_SHIFT_KEY)
+ goto map_keysym;
+ }
+ }
+
+ ret = keysym_from_raw_char (raw, key, &rq.keysym);
if (ret < 0)
return;
@@ -1039,6 +1118,7 @@ public:
{
if (mods & B_SHIFT_KEY)
{
+ map_keysym:
if (mods & B_CAPS_LOCK)
map_caps_shift (key, &rq.multibyte_char);
else
@@ -3263,9 +3343,7 @@ class EmacsFilePanelCallbackLooper : public BLooper
{
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);
+ sprintf (str_buf, "%s/%s", str_path, name);
file_name = strdup (str_buf);
}
}
diff --git a/src/haiku_support.h b/src/haiku_support.h
index 628a8c1f49b..e9ac7005d75 100644
--- a/src/haiku_support.h
+++ b/src/haiku_support.h
@@ -116,6 +116,7 @@ enum haiku_event_type
MENU_BAR_LEFT,
CLIPBOARD_CHANGED_EVENT,
FONT_CHANGE_EVENT,
+ NOTIFICATION_CLICK_EVENT,
};
struct haiku_clipboard_changed_event
@@ -464,6 +465,12 @@ struct haiku_font_change_event
enum haiku_what_font what;
};
+struct haiku_notification_click_event
+{
+ /* ID uniquely designating a single notification. */
+ intmax_t id;
+};
+
struct haiku_session_manager_reply
{
bool quit_reply;
diff --git a/src/haikufns.c b/src/haikufns.c
index 0b01c0a18a1..173c1e369df 100644
--- a/src/haikufns.c
+++ b/src/haikufns.c
@@ -184,6 +184,11 @@ haiku_change_tab_bar_height (struct frame *f, int height)
leading to the tab bar height being incorrectly set upon the next
call to x_set_font. (bug#59285) */
int lines = height / unit;
+
+ /* Even so, HEIGHT might be less than unit if the tab bar face is
+ not so tall as the frame's font height; which if true lines will
+ be set to 0 and the tab bar will thus vanish. */
+
if (lines == 0 && height != 0)
lines = 1;
@@ -259,6 +264,33 @@ haiku_set_tool_bar_lines (struct frame *f, Lisp_Object value, Lisp_Object oldval
}
static void
+haiku_set_tool_bar_position (struct frame *f,
+ Lisp_Object new_value,
+ Lisp_Object old_value)
+{
+ if (!EQ (new_value, Qtop) && !EQ (new_value, Qbottom))
+ error ("Tool bar position must be either `top' or `bottom'");
+
+ if (EQ (new_value, old_value))
+ return;
+
+ /* Set the tool bar position. */
+ fset_tool_bar_position (f, new_value);
+
+ /* Now reconfigure frame glyphs to place the tool bar at the bottom.
+ While the inner height has not changed, call
+ `resize_frame_windows' to place each of the windows at its new
+ position. */
+
+ adjust_frame_size (f, -1, -1, 3, false, Qtool_bar_position);
+ adjust_frame_glyphs (f);
+ SET_FRAME_GARBAGED (f);
+
+ if (FRAME_HAIKU_WINDOW (f))
+ haiku_clear_under_internal_border (f);
+}
+
+static void
haiku_set_tab_bar_lines (struct frame *f, Lisp_Object value, Lisp_Object oldval)
{
if (FRAME_TOOLTIP_P (f))
@@ -1420,10 +1452,11 @@ haiku_set_menu_bar_lines (struct frame *f, Lisp_Object value, Lisp_Object oldval
}
/* Return geometric attributes of FRAME. According to the value of
- ATTRIBUTES return the outer edges of FRAME (Qouter_edges), the inner
- edges of FRAME, the root window edges of frame (Qroot_edges). Any
- other value means to return the geometry as returned by
+ ATTRIBUTES return the outer edges of FRAME (Qouter_edges), the
+ inner edges of FRAME, the root window edges of frame (Qroot_edges).
+ Any other value means to return the geometry as returned by
Fx_frame_geometry. */
+
static Lisp_Object
frame_geometry (Lisp_Object frame, Lisp_Object attribute)
{
@@ -1432,6 +1465,9 @@ frame_geometry (Lisp_Object frame, Lisp_Object attribute)
int outer_x, outer_y, outer_width, outer_height;
int right_off, bottom_off, top_off;
int native_x, native_y;
+ int inner_left, inner_top, inner_right, inner_bottom;
+ int internal_border_width, tab_bar_height;
+ int tool_bar_height, tab_bar_width;
f = decode_window_system_frame (frame);
parent = FRAME_PARENT_FRAME (f);
@@ -1457,6 +1493,31 @@ frame_geometry (Lisp_Object frame, Lisp_Object attribute)
native_y -= FRAME_OUTPUT_DATA (parent)->frame_y;
}
+ internal_border_width = FRAME_INTERNAL_BORDER_WIDTH (f);
+ inner_left = native_x + internal_border_width;
+ inner_top = native_y + internal_border_width;
+ inner_right = (native_x + FRAME_PIXEL_WIDTH (f)
+ - internal_border_width);
+ inner_bottom = (native_y + FRAME_PIXEL_HEIGHT (f)
+ - internal_border_width);
+
+ tab_bar_height = FRAME_TAB_BAR_HEIGHT (f);
+ tab_bar_width = (tab_bar_height
+ ? (FRAME_PIXEL_WIDTH (f) - 2
+ * internal_border_width)
+ : 0);
+ inner_top += tab_bar_height;
+
+ tool_bar_height = FRAME_TOOL_BAR_HEIGHT (f);
+
+ /* Subtract or add to the inner dimensions based on the tool bar
+ position. */
+
+ if (EQ (FRAME_TOOL_BAR_POSITION (f), Qtop))
+ inner_top += tool_bar_height;
+ else
+ inner_bottom -= tool_bar_height;
+
if (EQ (attribute, Qouter_edges))
return list4i (outer_x, outer_y,
outer_x + outer_width,
@@ -1466,14 +1527,7 @@ frame_geometry (Lisp_Object frame, Lisp_Object attribute)
native_x + FRAME_PIXEL_WIDTH (f),
native_y + FRAME_PIXEL_HEIGHT (f));
else if (EQ (attribute, Qinner_edges))
- return list4i (native_x + FRAME_INTERNAL_BORDER_WIDTH (f),
- native_y + FRAME_INTERNAL_BORDER_WIDTH (f)
- + FRAME_MENU_BAR_HEIGHT (f) + FRAME_TOOL_BAR_HEIGHT (f),
- native_x - FRAME_INTERNAL_BORDER_WIDTH (f)
- + FRAME_PIXEL_WIDTH (f),
- native_y + FRAME_PIXEL_HEIGHT (f)
- - FRAME_INTERNAL_BORDER_WIDTH (f));
-
+ return list4i (inner_left, inner_top, inner_right, inner_bottom);
else
return list (Fcons (Qouter_position,
Fcons (make_fixnum (outer_x),
@@ -1490,13 +1544,18 @@ frame_geometry (Lisp_Object frame, Lisp_Object attribute)
Fcons (Qmenu_bar_external, Qnil),
Fcons (Qmenu_bar_size,
Fcons (make_fixnum (FRAME_PIXEL_WIDTH (f)
- - (FRAME_INTERNAL_BORDER_WIDTH (f) * 2)),
+ - (FRAME_INTERNAL_BORDER_WIDTH (f)
+ * 2)),
make_fixnum (FRAME_MENU_BAR_HEIGHT (f)))),
+ Fcons (Qtab_bar_size,
+ Fcons (make_fixnum (tab_bar_width),
+ make_fixnum (tab_bar_height))),
Fcons (Qtool_bar_external, Qnil),
- Fcons (Qtool_bar_position, Qtop),
+ Fcons (Qtool_bar_position, FRAME_TOOL_BAR_POSITION (f)),
Fcons (Qtool_bar_size,
Fcons (make_fixnum (FRAME_PIXEL_WIDTH (f)
- - (FRAME_INTERNAL_BORDER_WIDTH (f) * 2)),
+ - (FRAME_INTERNAL_BORDER_WIDTH (f)
+ * 2)),
make_fixnum (FRAME_TOOL_BAR_HEIGHT (f)))),
Fcons (Qinternal_border_width,
make_fixnum (FRAME_INTERNAL_BORDER_WIDTH (f))));
@@ -3136,7 +3195,7 @@ frame_parm_handler haiku_frame_parm_handlers[] =
gui_set_font_backend,
gui_set_alpha,
haiku_set_sticky,
- NULL, /* set tool bar pos */
+ haiku_set_tool_bar_position,
haiku_set_inhibit_double_buffering,
haiku_set_undecorated,
haiku_set_parent_frame,
diff --git a/src/haikufont.c b/src/haikufont.c
index 029f277983f..5d14dab3d4b 100644
--- a/src/haikufont.c
+++ b/src/haikufont.c
@@ -754,22 +754,30 @@ haikufont_encode_char (struct font *font, int c)
}
static Lisp_Object
-haikufont_open (struct frame *f, Lisp_Object font_entity, int x)
+haikufont_open (struct frame *f, Lisp_Object font_entity, int pixel_size)
{
struct haikufont_info *font_info;
struct haiku_font_pattern ptn;
struct font *font;
void *be_font;
- Lisp_Object font_object, tem, extra, indices, antialias;
+ Lisp_Object font_object, extra, indices, antialias;
int px_size, min_width, max_width;
int avg_width, height, space_width, ascent;
int descent, underline_pos, underline_thickness;
- if (x <= 0)
+ if (XFIXNUM (AREF (font_entity, FONT_SIZE_INDEX)) != 0)
+ pixel_size = XFIXNUM (AREF (font_entity, FONT_SIZE_INDEX));
+ else if (pixel_size == 0)
{
- /* Get pixel size from frame instead. */
- tem = get_frame_param (f, Qfontsize);
- x = NILP (tem) ? 0 : XFIXNAT (tem);
+ /* Try to resolve a suitable size for the font, if the font size
+ has not already been specified. First, if FRAME_FONT is set,
+ use its size. Otherwise, use 12, which is the default on
+ Haiku. */
+
+ if (FRAME_FONT (f))
+ pixel_size = FRAME_FONT (f)->pixel_size;
+ else
+ pixel_size = 12;
}
extra = AREF (font_entity, FONT_EXTRA_INDEX);
@@ -788,7 +796,8 @@ haikufont_open (struct frame *f, Lisp_Object font_entity, int x)
{
block_input ();
be_font = be_open_font_at_index (XFIXNUM (XCAR (indices)),
- XFIXNUM (XCDR (indices)), x);
+ XFIXNUM (XCDR (indices)),
+ pixel_size);
unblock_input ();
if (!be_font)
@@ -799,7 +808,7 @@ haikufont_open (struct frame *f, Lisp_Object font_entity, int x)
block_input ();
haikufont_spec_or_entity_to_pattern (font_entity, 1, &ptn);
- if (BFont_open_pattern (&ptn, &be_font, x))
+ if (BFont_open_pattern (&ptn, &be_font, pixel_size))
{
haikufont_done_with_query_pattern (&ptn);
unblock_input ();
@@ -813,7 +822,7 @@ haikufont_open (struct frame *f, Lisp_Object font_entity, int x)
block_input ();
font_object = font_make_object (VECSIZE (struct haikufont_info),
- font_entity, x);
+ font_entity, pixel_size);
ASET (font_object, FONT_TYPE_INDEX, Qhaiku);
font_info = (struct haikufont_info *) XFONT_OBJECT (font_object);
@@ -864,7 +873,8 @@ haikufont_open (struct frame *f, Lisp_Object font_entity, int x)
font->baseline_offset = 0;
font->relative_compose = 0;
- font->props[FONT_NAME_INDEX] = Ffont_xlfd_name (font_object, Qnil);
+ font->props[FONT_NAME_INDEX]
+ = Ffont_xlfd_name (font_object, Qnil, Qt);
unblock_input ();
return font_object;
@@ -1118,7 +1128,6 @@ haikufont_draw (struct glyph_string *s, int from, int to,
haiku_draw_background_rect (s, s->face, x, y - ascent,
s->width, height);
- s->background_filled_p = 1;
}
BView_SetHighColor (view, foreground);
diff --git a/src/haikuselect.c b/src/haikuselect.c
index c539c781e40..9a178acf618 100644
--- a/src/haikuselect.c
+++ b/src/haikuselect.c
@@ -1189,7 +1189,7 @@ haiku_note_drag_wheel (struct input_event *ie)
if (!NILP (Vhaiku_drag_wheel_function)
&& (haiku_dnd_allow_same_frame
|| XFRAME (ie->frame_or_window) != haiku_dnd_frame))
- safe_call (7, Vhaiku_drag_wheel_function, ie->frame_or_window,
+ safe_calln (Vhaiku_drag_wheel_function, ie->frame_or_window,
ie->x, ie->y, horizontal ? Qt : Qnil, up ? Qt : Qnil,
make_int (ie->modifiers));
@@ -1255,6 +1255,120 @@ haiku_start_watching_selections (void)
be_start_watching_selection (CLIPBOARD_SECONDARY);
}
+
+
+/* Notification support. */
+
+static intmax_t
+haiku_notifications_notify_1 (Lisp_Object title, Lisp_Object body,
+ Lisp_Object replaces_id,
+ Lisp_Object app_icon, Lisp_Object urgency)
+{
+ int type;
+ intmax_t supersedes;
+ const char *icon;
+
+ if (EQ (urgency, Qlow))
+ type = 0;
+ else if (EQ (urgency, Qnormal))
+ type = 1;
+ else if (EQ (urgency, Qcritical))
+ type = 2;
+ else
+ signal_error ("Invalid notification type provided", urgency);
+
+ supersedes = -1;
+
+ if (!NILP (replaces_id))
+ {
+ CHECK_INTEGER (replaces_id);
+ if (!integer_to_intmax (replaces_id, &supersedes))
+ supersedes = -1;
+ }
+
+ icon = NULL;
+
+ if (!NILP (app_icon))
+ icon = SSDATA (ENCODE_FILE (app_icon));
+
+ /* GC should not transpire from here onwards. */
+ return be_display_notification (SSDATA (title), SSDATA (body),
+ supersedes, type, icon);
+}
+
+DEFUN ("haiku-notifications-notify", Fhaiku_notifications_notify,
+ Shaiku_notifications_notify, 0, MANY, 0, doc:
+ /* Display a desktop notification.
+ARGS must contain keywords followed by values. Each of the following
+keywords is understood:
+
+ :title The notification title.
+ :body The notification body.
+ :replaces-id The ID of a previous notification to supersede.
+ :app-icon The file name of the notification's icon, if any.
+ :urgency One of the symbols `low', `normal' or `critical',
+ specifying the importance of the notification.
+
+:title and :body must be provided. Value is an integer (fixnum or
+bignum) identifying the notification displayed.
+
+usage: (haiku-notifications-notify &rest ARGS) */)
+ (ptrdiff_t nargs, Lisp_Object *args)
+{
+ Lisp_Object title, body, replaces_id, app_icon, urgency;
+ Lisp_Object key, value;
+ ptrdiff_t i;
+
+ /* First, clear each of the variables above. */
+ title = body = replaces_id = app_icon = urgency = Qnil;
+
+ /* If NARGS is odd, error. */
+
+ if (nargs & 1)
+ error ("Odd number of arguments in call to `haiku-notifications-notify'");
+
+ /* Next, iterate through ARGS, searching for arguments. */
+
+ for (i = 0; i < nargs; i += 2)
+ {
+ key = args[i];
+ value = args[i + 1];
+
+ if (EQ (key, QCtitle))
+ title = value;
+ else if (EQ (key, QCbody))
+ body = value;
+ else if (EQ (key, QCreplaces_id))
+ replaces_id = value;
+ else if (EQ (key, QCapp_icon))
+ app_icon = value;
+ else if (EQ (key, QCurgency))
+ urgency = value;
+ }
+
+ /* Demand at least TITLE and BODY be present. */
+
+ if (NILP (title) || NILP (body))
+ error ("Title or body not provided");
+
+ /* Now check the type and possibly expand each non-nil argument. */
+
+ CHECK_STRING (title);
+ title = ENCODE_UTF_8 (title);
+ CHECK_STRING (body);
+ body = ENCODE_UTF_8 (body);
+
+ if (NILP (urgency))
+ urgency = Qlow;
+
+ if (!NILP (app_icon))
+ app_icon = Fexpand_file_name (app_icon, Qnil);
+
+ return make_int (haiku_notifications_notify_1 (title, body,
+ replaces_id,
+ app_icon, urgency));
+}
+
void
syms_of_haikuselect (void)
{
@@ -1312,6 +1426,16 @@ keyboard modifiers currently held down. */);
DEFSYM (Qdouble, "double");
DEFSYM (Qalready_running, "already-running");
+ DEFSYM (QCtitle, ":title");
+ DEFSYM (QCbody, ":body");
+ DEFSYM (QCreplaces_id, ":replaces-id");
+ DEFSYM (QCapp_icon, ":app-icon");
+ DEFSYM (QCurgency, ":urgency");
+
+ DEFSYM (Qlow, "low");
+ DEFSYM (Qnormal, "normal");
+ DEFSYM (Qcritical, "critical");
+
defsubr (&Shaiku_selection_data);
defsubr (&Shaiku_selection_timestamp);
defsubr (&Shaiku_selection_put);
@@ -1320,6 +1444,7 @@ keyboard modifiers currently held down. */);
defsubr (&Shaiku_roster_launch);
defsubr (&Shaiku_write_node_attribute);
defsubr (&Shaiku_send_message);
+ defsubr (&Shaiku_notifications_notify);
haiku_dnd_frame = NULL;
}
diff --git a/src/haikuselect.h b/src/haikuselect.h
index 368d386cb6b..76c637b569a 100644
--- a/src/haikuselect.h
+++ b/src/haikuselect.h
@@ -21,9 +21,11 @@ along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. */
#ifdef __cplusplus
#include <cstdio>
-#else
+#include <cstdint>
+#else /* !__cplusplus */
#include <stdio.h>
-#endif
+#include <stdint.h>
+#endif /* __cplusplus */
#include <SupportDefs.h>
@@ -37,15 +39,16 @@ enum haiku_clipboard
#ifdef __cplusplus
extern "C"
{
-#endif
+#endif /* __cplusplus */
/* Defined in haikuselect.c. */
extern void haiku_selection_disowned (enum haiku_clipboard, int64);
/* Defined in haiku_select.cc. */
extern void be_clipboard_init (void);
-extern char *be_find_clipboard_data (enum haiku_clipboard, const char *, ssize_t *);
-extern void be_set_clipboard_data (enum haiku_clipboard, const char *, const char *,
- ssize_t, bool);
+extern char *be_find_clipboard_data (enum haiku_clipboard, const char *,
+ ssize_t *);
+extern void be_set_clipboard_data (enum haiku_clipboard, const char *,
+ const char *, ssize_t, bool);
extern bool be_clipboard_owner_p (enum haiku_clipboard);
extern void be_update_clipboard_count (enum haiku_clipboard);
@@ -58,7 +61,8 @@ 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_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 *);
@@ -69,9 +73,14 @@ extern void be_start_watching_selection (enum haiku_clipboard);
extern bool be_selection_outdated_p (enum haiku_clipboard, int64);
extern int64 be_get_clipboard_count (enum haiku_clipboard);
+
+
+extern intmax_t be_display_notification (const char *, const char *,
+ intmax_t, int, const char *);
+
#ifdef __cplusplus
};
-#endif
+#endif /* __cplusplus */
#endif /* _HAIKU_SELECT_H_ */
// Local Variables:
diff --git a/src/haikuterm.c b/src/haikuterm.c
index 01ddcd0e8bb..135f99dbdcb 100644
--- a/src/haikuterm.c
+++ b/src/haikuterm.c
@@ -1219,7 +1219,7 @@ static void
haiku_draw_glyphless_glyph_string_foreground (struct glyph_string *s)
{
struct glyph *glyph = s->first_glyph;
- unsigned char2b[8];
+ static unsigned char2b[8];
int x, i, j;
struct face *face = s->face;
unsigned long color;
@@ -3472,7 +3472,7 @@ haiku_read_socket (struct terminal *terminal, struct input_event *hold_quit)
if (!NILP (Vmouse_autoselect_window))
{
static Lisp_Object last_mouse_window;
- Lisp_Object window = window_from_coordinates (f, b->x, b->y, 0, 0, 0);
+ Lisp_Object window = window_from_coordinates (f, b->x, b->y, 0, 0, 0, 0);
if (WINDOWP (window)
&& !EQ (window, last_mouse_window)
@@ -3555,7 +3555,7 @@ haiku_read_socket (struct terminal *terminal, struct input_event *hold_quit)
int x = b->x;
int y = b->y;
- window = window_from_coordinates (f, x, y, 0, true, true);
+ window = window_from_coordinates (f, x, y, 0, true, true, true);
tab_bar_p = EQ (window, f->tab_bar_window);
if (tab_bar_p)
@@ -3573,7 +3573,7 @@ haiku_read_socket (struct terminal *terminal, struct input_event *hold_quit)
int x = b->x;
int y = b->y;
- window = window_from_coordinates (f, x, y, 0, true, true);
+ window = window_from_coordinates (f, x, y, 0, true, true, true);
tool_bar_p = (EQ (window, f->tool_bar_window)
&& (type != BUTTON_UP
|| f->last_tool_bar_item != -1));
@@ -3834,7 +3834,7 @@ haiku_read_socket (struct terminal *terminal, struct input_event *hold_quit)
BView_get_mouse (FRAME_HAIKU_VIEW (f), &x, &y);
- wheel_window = window_from_coordinates (f, x, y, 0, false, false);
+ wheel_window = window_from_coordinates (f, x, y, 0, false, false, false);
if (NILP (wheel_window))
{
@@ -4042,6 +4042,19 @@ haiku_read_socket (struct terminal *terminal, struct input_event *hold_quit)
handled in Lisp. */
haiku_handle_font_change_event (buf, &inev);
break;
+
+ case NOTIFICATION_CLICK_EVENT:
+ /* This code doesn't function, but the why is unknown. */
+#if 0
+ {
+ struct haiku_notification_click_event *b = buf;
+
+ inev.kind = NOTIFICATION_CLICKED_EVENT;
+ inev.arg = make_int (b->id);
+ break;
+ }
+#endif /* 0 */
+
case KEY_UP:
case DUMMY_EVENT:
default:
@@ -4165,7 +4178,8 @@ haiku_flash (struct frame *f)
BView_InvertRect (view, flash_left,
(height - flash_height
- - FRAME_INTERNAL_BORDER_WIDTH (f)),
+ - FRAME_INTERNAL_BORDER_WIDTH (f)
+ - FRAME_BOTTOM_MARGIN_HEIGHT (f)),
width, flash_height);
}
else
@@ -4210,7 +4224,8 @@ haiku_flash (struct frame *f)
BView_InvertRect (view, flash_left,
(height - flash_height
- - FRAME_INTERNAL_BORDER_WIDTH (f)),
+ - FRAME_INTERNAL_BORDER_WIDTH (f)
+ - FRAME_BOTTOM_MARGIN_HEIGHT (f)),
width, flash_height);
}
else
@@ -4420,7 +4435,7 @@ haiku_term_init (void)
{
nbytes = sizeof "GNU Emacs" + sizeof " at ";
- if (INT_ADD_WRAPV (nbytes, SBYTES (system_name), &nbytes))
+ if (ckd_add (&nbytes, nbytes, SBYTES (system_name)))
memory_full (SIZE_MAX);
name_buffer = alloca (nbytes);
@@ -4465,14 +4480,16 @@ haiku_clear_under_internal_border (struct frame *f)
int width = FRAME_PIXEL_WIDTH (f);
int height = FRAME_PIXEL_HEIGHT (f);
int margin = FRAME_TOP_MARGIN_HEIGHT (f);
- int face_id =
- (FRAME_PARENT_FRAME (f)
- ? (!NILP (Vface_remapping_alist)
- ? lookup_basic_face (NULL, f, CHILD_FRAME_BORDER_FACE_ID)
- : CHILD_FRAME_BORDER_FACE_ID)
- : (!NILP (Vface_remapping_alist)
- ? lookup_basic_face (NULL, f, INTERNAL_BORDER_FACE_ID)
- : INTERNAL_BORDER_FACE_ID));
+ int bottom_margin = FRAME_BOTTOM_MARGIN_HEIGHT (f);
+ int face_id = (FRAME_PARENT_FRAME (f)
+ ? (!NILP (Vface_remapping_alist)
+ ? lookup_basic_face (NULL, f,
+ CHILD_FRAME_BORDER_FACE_ID)
+ : CHILD_FRAME_BORDER_FACE_ID)
+ : (!NILP (Vface_remapping_alist)
+ ? lookup_basic_face (NULL, f,
+ INTERNAL_BORDER_FACE_ID)
+ : INTERNAL_BORDER_FACE_ID));
struct face *face = FACE_FROM_ID_OR_NULL (f, face_id);
void *view = FRAME_HAIKU_DRAWABLE (f);
@@ -4492,7 +4509,8 @@ haiku_clear_under_internal_border (struct frame *f)
BView_FillRectangle (view, 0, 0, border, height);
BView_FillRectangle (view, 0, margin, width, border);
BView_FillRectangle (view, width - border, 0, border, height);
- BView_FillRectangle (view, 0, height - border, width, border);
+ BView_FillRectangle (view, 0, height - bottom_margin - border,
+ width, border);
BView_EndClip (view);
BView_draw_unlock (view);
unblock_input ();
diff --git a/src/image.c b/src/image.c
index 911dfc4763d..41d72964631 100644
--- a/src/image.c
+++ b/src/image.c
@@ -175,6 +175,31 @@ typedef struct haiku_bitmap_record Bitmap_Record;
#endif
+#ifdef HAVE_ANDROID
+#include "androidterm.h"
+
+typedef struct android_bitmap_record Bitmap_Record;
+
+typedef struct android_image XImage;
+typedef android_pixmap Pixmap;
+
+#define GET_PIXEL(ximg, x, y) android_get_pixel (ximg, x, y)
+#define PUT_PIXEL(ximg, x, y, pixel) android_put_pixel (ximg, x, y, pixel)
+#define NO_PIXMAP 0
+
+#define PIX_MASK_RETAIN 0
+#define PIX_MASK_DRAW 1
+
+#define RGB_TO_ULONG(r, g, b) (((r) << 16) | ((g) << 8) | (b))
+#define RED_FROM_ULONG(color) (((color) >> 16) & 0xff)
+#define GREEN_FROM_ULONG(color) (((color) >> 8) & 0xff)
+#define BLUE_FROM_ULONG(color) ((color) & 0xff)
+#define RED16_FROM_ULONG(color) (RED_FROM_ULONG (color) * 0x101)
+#define GREEN16_FROM_ULONG(color) (GREEN_FROM_ULONG (color) * 0x101)
+#define BLUE16_FROM_ULONG(color) (BLUE_FROM_ULONG (color) * 0x101)
+
+#endif
+
static void image_disable_image (struct frame *, struct image *);
static void image_edge_detection (struct frame *, struct image *, Lisp_Object,
Lisp_Object);
@@ -441,32 +466,101 @@ image_reference_bitmap (struct frame *f, ptrdiff_t id)
}
#ifdef HAVE_PGTK
+
+/* Create a Cairo pattern from the bitmap BITS, which should be WIDTH
+ and HEIGHT in size. BITS's fill order is LSB first, meaning that
+ the value of the left most pixel within a byte is its least
+ significant bit. */
+
static cairo_pattern_t *
-image_create_pattern_from_pixbuf (struct frame *f, GdkPixbuf * pixbuf)
+image_bitmap_to_cr_pattern (char *bits, int width, int height)
{
- GdkPixbuf *pb = gdk_pixbuf_add_alpha (pixbuf, TRUE, 255, 255, 255);
- cairo_surface_t *surface =
- cairo_surface_create_similar_image (cairo_get_target
- (f->output_data.pgtk->cr_context),
- CAIRO_FORMAT_A1,
- gdk_pixbuf_get_width (pb),
- gdk_pixbuf_get_height (pb));
+ cairo_surface_t *surface;
+ unsigned char *data;
+ int stride;
+ cairo_pattern_t *pattern;
+#ifdef WORDS_BIGENDIAN
+ int x;
+ static const unsigned char table[] = {
+ 0x00, 0x80, 0x40, 0xc0, 0x20, 0xa0, 0x60, 0xe0,
+ 0x10, 0x90, 0x50, 0xd0, 0x30, 0xb0, 0x70, 0xf0,
+ 0x08, 0x88, 0x48, 0xc8, 0x28, 0xa8, 0x68, 0xe8,
+ 0x18, 0x98, 0x58, 0xd8, 0x38, 0xb8, 0x78, 0xf8,
+ 0x04, 0x84, 0x44, 0xc4, 0x24, 0xa4, 0x64, 0xe4,
+ 0x14, 0x94, 0x54, 0xd4, 0x34, 0xb4, 0x74, 0xf4,
+ 0x0c, 0x8c, 0x4c, 0xcc, 0x2c, 0xac, 0x6c, 0xec,
+ 0x1c, 0x9c, 0x5c, 0xdc, 0x3c, 0xbc, 0x7c, 0xfc,
+ 0x02, 0x82, 0x42, 0xc2, 0x22, 0xa2, 0x62, 0xe2,
+ 0x12, 0x92, 0x52, 0xd2, 0x32, 0xb2, 0x72, 0xf2,
+ 0x0a, 0x8a, 0x4a, 0xca, 0x2a, 0xaa, 0x6a, 0xea,
+ 0x1a, 0x9a, 0x5a, 0xda, 0x3a, 0xba, 0x7a, 0xfa,
+ 0x06, 0x86, 0x46, 0xc6, 0x26, 0xa6, 0x66, 0xe6,
+ 0x16, 0x96, 0x56, 0xd6, 0x36, 0xb6, 0x76, 0xf6,
+ 0x0e, 0x8e, 0x4e, 0xce, 0x2e, 0xae, 0x6e, 0xee,
+ 0x1e, 0x9e, 0x5e, 0xde, 0x3e, 0xbe, 0x7e, 0xfe,
+ 0x01, 0x81, 0x41, 0xc1, 0x21, 0xa1, 0x61, 0xe1,
+ 0x11, 0x91, 0x51, 0xd1, 0x31, 0xb1, 0x71, 0xf1,
+ 0x09, 0x89, 0x49, 0xc9, 0x29, 0xa9, 0x69, 0xe9,
+ 0x19, 0x99, 0x59, 0xd9, 0x39, 0xb9, 0x79, 0xf9,
+ 0x05, 0x85, 0x45, 0xc5, 0x25, 0xa5, 0x65, 0xe5,
+ 0x15, 0x95, 0x55, 0xd5, 0x35, 0xb5, 0x75, 0xf5,
+ 0x0d, 0x8d, 0x4d, 0xcd, 0x2d, 0xad, 0x6d, 0xed,
+ 0x1d, 0x9d, 0x5d, 0xdd, 0x3d, 0xbd, 0x7d, 0xfd,
+ 0x03, 0x83, 0x43, 0xc3, 0x23, 0xa3, 0x63, 0xe3,
+ 0x13, 0x93, 0x53, 0xd3, 0x33, 0xb3, 0x73, 0xf3,
+ 0x0b, 0x8b, 0x4b, 0xcb, 0x2b, 0xab, 0x6b, 0xeb,
+ 0x1b, 0x9b, 0x5b, 0xdb, 0x3b, 0xbb, 0x7b, 0xfb,
+ 0x07, 0x87, 0x47, 0xc7, 0x27, 0xa7, 0x67, 0xe7,
+ 0x17, 0x97, 0x57, 0xd7, 0x37, 0xb7, 0x77, 0xf7,
+ 0x0f, 0x8f, 0x4f, 0xcf, 0x2f, 0xaf, 0x6f, 0xef,
+ };
+#endif /* WORDS_BIGENDIAN */
- cairo_t *cr = cairo_create (surface);
- gdk_cairo_set_source_pixbuf (cr, pb, 0, 0);
- cairo_set_operator (cr, CAIRO_OPERATOR_SOURCE);
- cairo_paint (cr);
- cairo_destroy (cr);
+ surface = cairo_image_surface_create (CAIRO_FORMAT_A1, width,
+ height);
- cairo_pattern_t *pat = cairo_pattern_create_for_surface (surface);
- cairo_pattern_set_extend (pat, CAIRO_EXTEND_REPEAT);
+ if (cairo_surface_status (surface) != CAIRO_STATUS_SUCCESS)
+ memory_full (0);
- cairo_surface_destroy (surface);
- g_object_unref (pb);
+ cairo_surface_flush (surface);
+ data = cairo_image_surface_get_data (surface);
+ stride = cairo_image_surface_get_stride (surface);
+
+#ifdef WORDS_BIGENDIAN
+ /* Big endian systems require that individual bytes be inverted to
+ compensate for the different fill order used by Cairo. */
+ while (height--)
+ {
+ memcpy (data, bits, (width + 7) / 8);
+ for (x = 0; x < (width + 7) / 8; ++x)
+ data[x] = table[data[x]];
+ data += stride;
+ bits += (width + 7) / 8;
+ }
+#else /* !WORDS_BIGENDIAN */
+ /* Cairo uses LSB first fill order for bitmaps on little-endian
+ systems, so copy each row over. */
+
+ while (height--)
+ {
+ memcpy (data, bits, (width + 7) / 8);
+ data += stride;
+ bits += (width + 7) / 8;
+ }
+#endif /* WORDS_BIGENDIAN */
+
+ cairo_surface_mark_dirty (surface);
+ pattern = cairo_pattern_create_for_surface (surface);
+ if (cairo_pattern_status (pattern) != CAIRO_STATUS_SUCCESS)
+ memory_full (0);
- return pat;
+ /* The pattern now holds a reference to the surface. */
+ cairo_surface_destroy (surface);
+ cairo_pattern_set_extend (pattern, CAIRO_EXTEND_REPEAT);
+ return pattern;
}
-#endif
+
+#endif /* HAVE_PGTK */
/* Create a bitmap for frame F from a HEIGHT x WIDTH array of bits at BITS. */
@@ -486,6 +580,18 @@ image_create_bitmap_from_data (struct frame *f, char *bits,
return -1;
#endif /* HAVE_X_WINDOWS */
+#if defined HAVE_ANDROID && !defined ANDROID_STUBIFY
+ android_pixmap bitmap;
+
+ bitmap = android_create_bitmap_from_data (bits, width, height);
+
+ if (!bitmap)
+ return -1;
+#elif defined HAVE_ANDROID
+ ((void) dpyinfo);
+ emacs_abort ();
+#endif /* HAVE_ANDROID && !defined ANDROID_STUBIFY */
+
#ifdef HAVE_NTGUI
Lisp_Object frame UNINIT; /* The value is not used. */
Emacs_Pixmap bitmap;
@@ -504,46 +610,9 @@ image_create_bitmap_from_data (struct frame *f, char *bits,
#endif
#ifdef HAVE_PGTK
- GdkPixbuf *pixbuf = gdk_pixbuf_new (GDK_COLORSPACE_RGB,
- FALSE,
- 8,
- width,
- height);
- {
- char *sp = bits;
- int mask = 0x01;
- unsigned char *buf = gdk_pixbuf_get_pixels (pixbuf);
- int rowstride = gdk_pixbuf_get_rowstride (pixbuf);
- for (int y = 0; y < height; y++)
- {
- unsigned char *dp = buf + rowstride * y;
- for (int x = 0; x < width; x++)
- {
- if (*sp & mask)
- {
- *dp++ = 0xff;
- *dp++ = 0xff;
- *dp++ = 0xff;
- }
- else
- {
- *dp++ = 0x00;
- *dp++ = 0x00;
- *dp++ = 0x00;
- }
- if ((mask <<= 1) >= 0x100)
- {
- mask = 0x01;
- sp++;
- }
- }
- if (mask != 0x01)
- {
- mask = 0x01;
- sp++;
- }
- }
- }
+ cairo_pattern_t *pattern;
+
+ pattern = image_bitmap_to_cr_pattern (bits, width, height);
#endif /* HAVE_PGTK */
#ifdef HAVE_HAIKU
@@ -577,10 +646,8 @@ image_create_bitmap_from_data (struct frame *f, char *bits,
#endif
#ifdef HAVE_PGTK
- dpyinfo->bitmaps[id - 1].img = pixbuf;
dpyinfo->bitmaps[id - 1].depth = 1;
- dpyinfo->bitmaps[id - 1].pattern =
- image_create_pattern_from_pixbuf (f, pixbuf);
+ dpyinfo->bitmaps[id - 1].pattern = pattern;
#endif
#ifdef HAVE_HAIKU
@@ -598,14 +665,16 @@ image_create_bitmap_from_data (struct frame *f, char *bits,
dpyinfo->bitmaps[id - 1].width = width;
dpyinfo->bitmaps[id - 1].refcount = 1;
-#ifdef HAVE_X_WINDOWS
+#if defined HAVE_X_WINDOWS || defined HAVE_ANDROID
+#ifndef ANDROID_STUBIFY
dpyinfo->bitmaps[id - 1].pixmap = bitmap;
+#endif /* ANDROID_STUBIFY */
dpyinfo->bitmaps[id - 1].have_mask = false;
dpyinfo->bitmaps[id - 1].depth = 1;
#ifdef USE_CAIRO
dpyinfo->bitmaps[id - 1].stipple = NULL;
#endif /* USE_CAIRO */
-#endif /* HAVE_X_WINDOWS */
+#endif /* HAVE_X_WINDOWS || HAVE_ANDROID */
#ifdef HAVE_NTGUI
dpyinfo->bitmaps[id - 1].pixmap = bitmap;
@@ -616,9 +685,20 @@ image_create_bitmap_from_data (struct frame *f, char *bits,
return id;
}
-#if defined HAVE_HAIKU || defined HAVE_NS
-static char *slurp_file (int, ptrdiff_t *);
-static Lisp_Object image_find_image_fd (Lisp_Object, int *);
+#if defined HAVE_ANDROID && !defined ANDROID_STUBIFY
+#include "android.h"
+
+/* This abstraction allows directly loading images from assets without
+ copying them to a file descriptor first. */
+typedef struct android_fd_or_asset image_fd;
+#else /* !defined HAVE_ANDROID || defined ANDROID_STUBIFY */
+typedef int image_fd;
+#endif /* defined HAVE_ANDROID && !defined ANDROID_STUBIFY */
+
+#if defined HAVE_HAIKU || defined HAVE_NS || defined HAVE_PGTK \
+ || defined HAVE_ANDROID
+static char *slurp_file (image_fd, ptrdiff_t *);
+static Lisp_Object image_find_image_fd (Lisp_Object, image_fd *);
static bool xbm_read_bitmap_data (struct frame *, char *, char *,
int *, int *, char **, bool);
#endif
@@ -680,25 +760,38 @@ image_create_bitmap_from_file (struct frame *f, Lisp_Object file)
#endif
#ifdef HAVE_PGTK
- GError *err = NULL;
- ptrdiff_t id;
- void * bitmap = gdk_pixbuf_new_from_file (SSDATA (file), &err);
+ ptrdiff_t id, size;
+ int fd, width, height, rc;
+ char *contents, *data;
+ void *bitmap;
- if (!bitmap)
+ if (!STRINGP (image_find_image_fd (file, &fd)))
+ return -1;
+
+ contents = slurp_file (fd, &size);
+
+ if (!contents)
+ return -1;
+
+ rc = xbm_read_bitmap_data (f, contents, contents + size,
+ &width, &height, &data, 0);
+
+ if (!rc)
{
- g_error_free (err);
+ xfree (contents);
return -1;
}
id = image_allocate_bitmap_record (f);
- dpyinfo->bitmaps[id - 1].img = bitmap;
dpyinfo->bitmaps[id - 1].refcount = 1;
dpyinfo->bitmaps[id - 1].file = xlispstrdup (file);
- dpyinfo->bitmaps[id - 1].height = gdk_pixbuf_get_width (bitmap);
- dpyinfo->bitmaps[id - 1].width = gdk_pixbuf_get_height (bitmap);
+ dpyinfo->bitmaps[id - 1].height = width;
+ dpyinfo->bitmaps[id - 1].width = height;
dpyinfo->bitmaps[id - 1].pattern
- = image_create_pattern_from_pixbuf (f, bitmap);
+ = image_bitmap_to_cr_pattern (data, width, height);
+ xfree (contents);
+ xfree (data);
return id;
#endif
@@ -724,7 +817,7 @@ image_create_bitmap_from_file (struct frame *f, Lisp_Object file)
/* Search bitmap-file-path for the file, if appropriate. */
if (openp (Vx_bitmap_file_path, file, Qnil, &found,
- make_fixnum (R_OK), false, false)
+ make_fixnum (R_OK), false, false, NULL)
< 0)
return -1;
@@ -773,7 +866,7 @@ image_create_bitmap_from_file (struct frame *f, Lisp_Object file)
/* Search bitmap-file-path for the file, if appropriate. */
if (openp (Vx_bitmap_file_path, file, Qnil, &found,
- make_fixnum (R_OK), false, false)
+ make_fixnum (R_OK), false, false, NULL)
< 0)
return -1;
@@ -834,6 +927,73 @@ image_create_bitmap_from_file (struct frame *f, Lisp_Object file)
xfree (contents);
return id;
#endif
+
+#ifdef HAVE_ANDROID
+#ifdef ANDROID_STUBIFY
+ ((void) dpyinfo);
+
+ /* This function should never be called when building stubs. */
+ emacs_abort ();
+#else
+ ptrdiff_t id, size;
+ int width, height, rc;
+ image_fd fd;
+ char *contents, *data;
+ Lisp_Object found;
+ android_pixmap bitmap;
+
+ /* Look for an existing bitmap with the same name. */
+ for (id = 0; id < dpyinfo->bitmaps_last; ++id)
+ {
+ if (dpyinfo->bitmaps[id].refcount
+ && dpyinfo->bitmaps[id].file
+ && !strcmp (dpyinfo->bitmaps[id].file, SSDATA (file)))
+ {
+ ++dpyinfo->bitmaps[id].refcount;
+ return id + 1;
+ }
+ }
+
+ /* Search bitmap-file-path for the file, if appropriate. */
+ if (openp (Vx_bitmap_file_path, file, Qnil, &found,
+ make_fixnum (R_OK), false, false, NULL)
+ < 0)
+ return -1;
+
+ if (!STRINGP (image_find_image_fd (file, &fd))
+ && !STRINGP (image_find_image_fd (found, &fd)))
+ return -1;
+
+ contents = slurp_file (fd, &size);
+
+ if (!contents)
+ return -1;
+
+ rc = xbm_read_bitmap_data (f, contents, contents + size,
+ &width, &height, &data, 0);
+
+ if (!rc)
+ {
+ xfree (contents);
+ return -1;
+ }
+
+ xfree (contents);
+ bitmap = android_create_bitmap_from_data (data, width, height);
+ xfree (data);
+
+ id = image_allocate_bitmap_record (f);
+ dpyinfo->bitmaps[id - 1].pixmap = bitmap;
+ dpyinfo->bitmaps[id - 1].have_mask = false;
+ dpyinfo->bitmaps[id - 1].refcount = 1;
+ dpyinfo->bitmaps[id - 1].file = xlispstrdup (file);
+ dpyinfo->bitmaps[id - 1].depth = 1;
+ dpyinfo->bitmaps[id - 1].height = height;
+ dpyinfo->bitmaps[id - 1].width = width;
+
+ return id;
+#endif
+#endif
}
/* Free bitmap B. */
@@ -842,15 +1002,30 @@ static void
free_bitmap_record (Display_Info *dpyinfo, Bitmap_Record *bm)
{
#ifdef HAVE_X_WINDOWS
- XFreePixmap (dpyinfo->display, bm->pixmap);
- if (bm->have_mask)
- XFreePixmap (dpyinfo->display, bm->mask);
+ /* Free the pixmap and mask. Only do this if DPYINFO->display is
+ still set, which may not be the case if the connection has
+ already been closed in response to an IO error. */
+
+ if (dpyinfo->display)
+ {
+ XFreePixmap (dpyinfo->display, bm->pixmap);
+ if (bm->have_mask)
+ XFreePixmap (dpyinfo->display, bm->mask);
+ }
+
#ifdef USE_CAIRO
if (bm->stipple)
cairo_pattern_destroy (bm->stipple);
#endif /* USE_CAIRO */
#endif /* HAVE_X_WINDOWS */
+#if defined HAVE_ANDROID && !defined ANDROID_STUBIFY
+ android_free_pixmap (bm->pixmap);
+
+ if (bm->have_mask)
+ android_free_pixmap (bm->pixmap);
+#endif
+
#ifdef HAVE_NTGUI
DeleteObject (bm->pixmap);
#endif /* HAVE_NTGUI */
@@ -938,7 +1113,7 @@ static void image_unget_x_image (struct image *, bool, Emacs_Pix_Container);
image_unget_x_image (img, mask_p, ximg)
#endif
-#ifdef HAVE_X_WINDOWS
+#if defined HAVE_X_WINDOWS || defined HAVE_ANDROID
#ifndef USE_CAIRO
static void image_sync_to_pixmaps (struct frame *, struct image *);
@@ -952,6 +1127,8 @@ static bool x_create_x_image_and_pixmap (struct frame *, int, int, int,
XImage **, Pixmap *);
static void x_destroy_x_image (XImage *);
+#if defined HAVE_X_WINDOWS
+
/* Create a mask of a bitmap. Note is this not a perfect mask.
It's nicer with some borders in this context */
@@ -1048,7 +1225,9 @@ x_create_bitmap_mask (struct frame *f, ptrdiff_t id)
x_destroy_x_image (mask_img);
}
-#endif /* HAVE_X_WINDOWS */
+#endif
+
+#endif /* HAVE_X_WINDOWS || defined HAVE_ANDROID*/
/***********************************************************************
Image types
@@ -1082,7 +1261,7 @@ struct image_type
#if defined HAVE_RSVG || defined HAVE_PNG || defined HAVE_GIF || \
defined HAVE_TIFF || defined HAVE_JPEG || defined HAVE_XPM || \
defined HAVE_NS || defined HAVE_HAIKU || defined HAVE_PGTK || \
- defined HAVE_WEBP
+ defined HAVE_WEBP || defined HAVE_ANDROID
# ifdef WINDOWSNT
# define IMAGE_TYPE_INIT(f) f
# else
@@ -1158,6 +1337,18 @@ image_error (const char *format, ...)
}
static void
+image_invalid_data_error (Lisp_Object data)
+{
+ image_error ("Invalid image data `%s'", data);
+}
+
+static void
+image_not_found_error (Lisp_Object filename)
+{
+ image_error ("Cannot find image file `%s'", filename);
+}
+
+static void
image_size_error (void)
{
image_error ("Invalid image size (see `max-image-size')");
@@ -1352,7 +1543,7 @@ parse_image_spec (Lisp_Object spec, struct image_keyword *keywords,
if KEY is not present in SPEC. Set *FOUND depending on whether KEY
was found in SPEC. */
-static Lisp_Object
+Lisp_Object
image_spec_value (Lisp_Object spec, Lisp_Object key, bool *found)
{
Lisp_Object tail;
@@ -1584,7 +1775,7 @@ prepare_image_for_display (struct frame *f, struct image *img)
}
unblock_input ();
}
-#elif defined HAVE_X_WINDOWS
+#elif defined HAVE_X_WINDOWS || defined HAVE_ANDROID
if (!img->load_failed_p)
{
block_input ();
@@ -1791,7 +1982,7 @@ image_clear_image_1 (struct frame *f, struct image *img, int flags)
/* NOTE (HAVE_NS): background color is NOT an indexed color! */
img->background_valid = 0;
}
-#if defined HAVE_X_WINDOWS && !defined USE_CAIRO
+#if (defined HAVE_X_WINDOWS || defined HAVE_ANDROID) && !defined USE_CAIRO
if (img->ximg)
{
image_destroy_x_image (img->ximg);
@@ -1809,7 +2000,7 @@ image_clear_image_1 (struct frame *f, struct image *img, int flags)
img->mask = NO_PIXMAP;
img->background_transparent_valid = 0;
}
-#if defined HAVE_X_WINDOWS && !defined USE_CAIRO
+#if (defined HAVE_X_WINDOWS || defined HAVE_ANDROID) && !defined USE_CAIRO
if (img->mask_img)
{
image_destroy_x_image (img->mask_img);
@@ -2151,6 +2342,7 @@ evicted. */)
{
if (!NILP (animation_cache))
{
+ CHECK_CONS (animation_cache);
#if defined (HAVE_WEBP) || defined (HAVE_GIF)
anim_prune_animation_cache (XCDR (animation_cache));
#endif
@@ -2181,11 +2373,11 @@ image_size_in_bytes (struct image *img)
if (msk)
size += msk->height * msk->bytes_per_line;
-#elif defined HAVE_X_WINDOWS
- /* Use a nominal depth of 24 bpp for pixmap and 1 bpp for mask,
- to avoid having to query the server. */
+#elif defined HAVE_X_WINDOWS || defined HAVE_ANDROID
+ /* Use a nominal depth of 24 and a bpp of 32 for pixmap and 1 bpp
+ for mask, to avoid having to query the server. */
if (img->pixmap != NO_PIXMAP)
- size += img->width * img->height * 3;
+ size += img->width * img->height * 4;
if (img->mask != NO_PIXMAP)
size += img->width * img->height / 8;
@@ -2520,11 +2712,11 @@ compute_image_size (double width, double height,
finally move the origin back to the top left of the image, which
may now be a different corner.
- Note that different GUI backends (X, Cairo, w32, NS, Haiku) want
- the transform matrix defined as transform from the original image
- to the transformed image, while others want the matrix to describe
- the transform of the space, which boils down to inverting the
- matrix.
+ Note that different GUI backends (X, Cairo, w32, NS, Haiku,
+ Android) want the transform matrix defined as transform from the
+ original image to the transformed image, while others want the
+ matrix to describe the transform of the space, which boils down to
+ inverting the matrix.
It's possible to pre-calculate the matrix multiplications and just
generate one transform matrix that will do everything we need in a
@@ -2566,6 +2758,96 @@ compute_image_rotation (struct image *img, double *rotation)
*rotation = XFIXNUM (reduced_angle);
}
+#ifdef HAVE_ANDROID
+
+static void
+matrix_identity (matrix3x3 matrix)
+{
+ memset (matrix, 0, sizeof (matrix3x3));
+
+ matrix[0][0] = 1.0;
+ matrix[1][1] = 1.0;
+ matrix[2][2] = 1.0;
+}
+
+/* Translate the matrix TRANSFORM to X, Y, and then perform clockwise
+ rotation by the given angle THETA in radians and translate back.
+ As the transform is being performed in a coordinate system where Y
+ grows downwards, the given angle describes a clockwise
+ rotation. */
+
+static void
+matrix_rotate (matrix3x3 transform, double theta, double x, double y)
+{
+ matrix3x3 temp, copy;
+
+ /* 1. Translate the matrix so X and Y are in the center. */
+
+ matrix_identity (temp);
+ memcpy (copy, transform, sizeof copy);
+
+ temp[0][2] = x;
+ temp[1][2] = y;
+
+ matrix3x3_mult (copy, temp, transform);
+ matrix_identity (temp);
+ memcpy (copy, transform, sizeof copy);
+
+ /* 2. Rotate the matrix counter-clockwise, assuming a coordinate
+ system where Y grows downwards. */
+
+ temp[0][0] = cos (theta);
+ temp[0][1] = -sin (theta);
+ temp[1][0] = sinf (theta);
+ temp[1][1] = cosf (theta);
+
+ matrix3x3_mult (copy, temp, transform);
+ matrix_identity (temp);
+ memcpy (copy, transform, sizeof copy);
+
+ /* 3. Translate back. */
+
+ temp[0][2] = -x;
+ temp[1][2] = -y;
+
+ matrix3x3_mult (copy, temp, transform);
+}
+
+/* Scale the matrix TRANSFORM by -1, and then apply a TX of width, in
+ effect flipping the image horizontally. */
+
+static void
+matrix_mirror_horizontal (matrix3x3 transform, double width)
+{
+ matrix3x3 temp, copy;
+
+ matrix_identity (temp);
+ memcpy (copy, transform, sizeof copy);
+
+ temp[0][0] = -1.0f;
+ temp[0][2] = width;
+
+ matrix3x3_mult (copy, temp, transform);
+}
+
+static void
+matrix_translate (matrix3x3 transform, float tx, float ty)
+{
+ matrix3x3 temp, copy;
+
+ matrix_identity (temp);
+ memcpy (copy, transform, sizeof copy);
+
+ /* Set the tx and ty. */
+ temp[0][2] = tx;
+ temp[1][2] = ty;
+
+ /* Multiply it with the transform. */
+ matrix3x3_mult (copy, temp, transform);
+}
+
+#endif
+
static void
image_set_transform (struct frame *f, struct image *img)
{
@@ -2585,6 +2867,14 @@ image_set_transform (struct frame *f, struct image *img)
memcpy (&img->transform, identity, sizeof identity);
#endif
+#if defined HAVE_ANDROID
+ matrix3x3 identity = {
+ { 1, 0, 0 },
+ { 0, 1, 0 },
+ { 0, 0, 1 },
+ };
+#endif
+
# if (defined HAVE_IMAGEMAGICK \
&& !defined DONT_CREATE_TRANSFORMED_IMAGEMAGICK_IMAGE)
/* ImageMagick images already have the correct transform. */
@@ -2622,7 +2912,8 @@ image_set_transform (struct frame *f, struct image *img)
/* Determine flipping. */
flip = !NILP (image_spec_value (img->spec, QCflip, NULL));
-# if defined USE_CAIRO || defined HAVE_XRENDER || defined HAVE_NS || defined HAVE_HAIKU
+# if defined USE_CAIRO || defined HAVE_XRENDER || defined HAVE_NS || defined HAVE_HAIKU \
+ || defined HAVE_ANDROID
/* We want scale up operations to use a nearest neighbor filter to
show real pixels instead of munging them, but scale down
operations to use a blended filter, to avoid aliasing and the like.
@@ -2644,7 +2935,7 @@ image_set_transform (struct frame *f, struct image *img)
matrix3x3 matrix
= {
-# if defined USE_CAIRO || defined HAVE_XRENDER
+# if defined USE_CAIRO || defined HAVE_XRENDER || defined HAVE_ANDROID
[0][0] = (!IEEE_FLOATING_POINT && width == 0 ? DBL_MAX
: img->width / (double) width),
[1][1] = (!IEEE_FLOATING_POINT && height == 0 ? DBL_MAX
@@ -2667,7 +2958,7 @@ image_set_transform (struct frame *f, struct image *img)
/* Haiku needs this, since the transformation is done on the basis
of the view, and not the image. */
-#ifdef HAVE_HAIKU
+#if defined HAVE_HAIKU
int extra_tx, extra_ty;
extra_tx = 0;
@@ -2678,8 +2969,9 @@ image_set_transform (struct frame *f, struct image *img)
rotate_flag = 0;
else
{
-# if (defined USE_CAIRO || defined HAVE_XRENDER \
- || defined HAVE_NTGUI || defined HAVE_NS \
+#ifndef HAVE_ANDROID
+# if (defined USE_CAIRO || defined HAVE_XRENDER \
+ || defined HAVE_NTGUI || defined HAVE_NS \
|| defined HAVE_HAIKU)
int cos_r, sin_r;
if (rotation == 0)
@@ -2706,7 +2998,7 @@ image_set_transform (struct frame *f, struct image *img)
sin_r = 1;
rotate_flag = 1;
-#ifdef HAVE_HAIKU
+#if defined HAVE_HAIKU
if (!flip)
extra_ty = height;
extra_tx = 0;
@@ -2742,7 +3034,7 @@ image_set_transform (struct frame *f, struct image *img)
if (0 < rotate_flag)
{
-# if defined USE_CAIRO || defined HAVE_XRENDER
+# if defined USE_CAIRO || defined HAVE_XRENDER || defined HAVE_ANDROID
/* 1. Translate so (0, 0) is in the center of the image. */
matrix3x3 t
= { [0][0] = 1,
@@ -2793,6 +3085,93 @@ image_set_transform (struct frame *f, struct image *img)
img->height = height;
}
# endif
+#else
+ /* Calculate the inverse transform from the destination to the
+ source. The matrix is currently identity with scale
+ applied.
+
+ This code makes more sense to me than what lies above. But
+ I'm not touching what works. */
+
+ if (rotation != 0 && rotation != 90
+ && rotation != 180 && rotation != 270)
+ {
+ rotate_flag = 0;
+ goto bail;
+ }
+
+ rotate_flag = 1;
+
+ switch ((int) rotation + (flip ? 1 : 0))
+ {
+ case 0:
+ break;
+
+ case 90:
+ /* Rotate the image 90 degrees clockwise. IOW, rotate the
+ destination by 90 degrees counterclockwise, which is 270
+ degrees clockwise. */
+ matrix_rotate (matrix, M_PI * 1.5, 0, 0);
+ matrix_translate (matrix, -height, 0);
+ break;
+
+ case 180:
+ /* Apply clockwise 180 degree rotation around the
+ center. */
+ matrix_rotate (matrix, M_PI, width / 2.0, height / 2.0);
+ break;
+
+ case 270:
+ /* Apply 270 degree counterclockwise rotation to the
+ destination, which is 90 degrees clockwise. */
+ matrix_rotate (matrix, M_PI * 0.5, 0, 0);
+ matrix_translate (matrix, 0, -width);
+ break;
+
+ case 1:
+ /* Flipped. Apply horizontal flip. */
+ matrix_mirror_horizontal (matrix, width);
+ break;
+
+ case 91:
+ /* Apply a flip but otherwise treat this the same as 90. */
+ matrix_rotate (matrix, M_PI * 1.5, 0, 0);
+ matrix_translate (matrix, -height, 0);
+ matrix_mirror_horizontal (matrix, height);
+ break;
+
+ case 181:
+ /* Flipped 180 degrees. Apply a flip and treat this the
+ same as 180. */
+ matrix_rotate (matrix, M_PI, width / 2.0, height / 2.0);
+ matrix_mirror_horizontal (matrix, width);
+ break;
+
+ case 271:
+ /* Flipped 270 degrees. Apply a flip and treat this the
+ same as 270. */
+ matrix_rotate (matrix, M_PI * 0.5, 0, 0);
+ matrix_translate (matrix, 0, -width);
+ matrix_mirror_horizontal (matrix, height);
+ break;
+ }
+
+ /* Now set img->width and img->height. Flip them if the
+ rotation being applied requires so. */
+
+ if (rotation != 270 && rotation != 90)
+ {
+ img->width = width;
+ img->height = height;
+ }
+ else
+ {
+ img->height = width;
+ img->width = height;
+ }
+ bail:
+ ;
+#endif
}
if (rotate_flag < 0)
@@ -2857,6 +3236,103 @@ image_set_transform (struct frame *f, struct image *img)
img->transform[0][2] = extra_tx;
img->transform[1][2] = extra_ty;
}
+# elif defined HAVE_ANDROID
+ /* Create a new image of the right size, then turn it into a pixmap
+ and set that as img->pixmap. Destroy img->mask for now (this is
+ not right.) */
+
+ struct android_image *transformed_image, *image;
+ struct android_transform transform;
+
+ /* If there is no transform, simply return. */
+ if (!memcmp (&matrix, &identity, sizeof matrix))
+ return;
+
+ /* First, get the source image. */
+ image = image_get_x_image (f, img, false);
+
+ /* Make the transformed image. */
+ transformed_image = android_create_image (image->depth,
+ ANDROID_Z_PIXMAP,
+ NULL, img->width,
+ img->height);
+
+ /* Allocate memory for that image. */
+ transformed_image->data
+ = xmalloc (transformed_image->bytes_per_line
+ * transformed_image->height);
+
+ /* Do the transform. */
+ transform.m1 = matrix[0][0];
+ transform.m2 = matrix[0][1];
+ transform.m3 = matrix[0][2];
+ transform.m4 = matrix[1][0];
+ transform.m5 = matrix[1][1];
+ transform.m6 = matrix[1][2];
+
+ if (image->depth == 24 && smoothing)
+ android_project_image_bilinear (image, transformed_image,
+ &transform);
+ else
+ android_project_image_nearest (image, transformed_image,
+ &transform);
+
+ image_unget_x_image (img, false, image);
+
+ /* Now replace the image. */
+
+ if (img->ximg)
+ image_destroy_x_image (img->ximg);
+
+ img->ximg = transformed_image;
+
+#ifndef ANDROID_STUBIFY
+ /* Then replace the pixmap. */
+ android_free_pixmap (img->pixmap);
+
+ /* In case android_create_pixmap signals. */
+ img->pixmap = ANDROID_NONE;
+ img->pixmap = android_create_pixmap (img->width, img->height,
+ transformed_image->depth);
+ android_put_image (img->pixmap, transformed_image);
+#else
+ emacs_abort ();
+#endif
+
+ /* Now, transform the mask. The mask should be depth 1, and is
+ always transformed using a nearest neighbor filter. */
+
+ if (img->mask_img || img->mask)
+ {
+ image = image_get_x_image (f, img, true);
+ transformed_image = android_create_image (1, ANDROID_Z_PIXMAP,
+ NULL, img->width,
+ img->height);
+ transformed_image->data
+ = xmalloc (transformed_image->bytes_per_line
+ * transformed_image->height);
+ android_project_image_nearest (image, transformed_image,
+ &transform);
+ image_unget_x_image (img, true, image);
+
+ /* Now replace the image. */
+
+ if (img->mask_img)
+ image_destroy_x_image (img->mask_img);
+
+ img->mask_img = transformed_image;
+
+#ifndef ANDROID_STUBIFY
+ if (img->mask)
+ android_free_pixmap (img->mask);
+
+ img->mask = ANDROID_NONE;
+ img->mask = android_create_pixmap (img->width, img->height, 1);
+ android_put_image (img->mask, transformed_image);
+#endif
+ }
+
+ /* Done! */
#endif
}
@@ -3085,7 +3561,7 @@ anim_prune_animation_cache (Lisp_Object clear)
{
struct anim_cache *cache = *pcache;
if (EQ (clear, Qt)
- || (EQ (clear, Qnil) && timespec_cmp (old, cache->update_time) > 0)
+ || (NILP (clear) && timespec_cmp (old, cache->update_time) > 0)
|| EQ (clear, cache->spec))
{
if (cache->handle)
@@ -3164,9 +3640,12 @@ mark_image_cache (struct image_cache *c)
/***********************************************************************
X / NS / W32 support code
+ Most of this code is shared with Android to make
+ it easier to maintain.
***********************************************************************/
-#ifdef HAVE_X_WINDOWS
+#if defined HAVE_X_WINDOWS || defined HAVE_ANDROID
+
static bool
x_check_image_size (XImage *ximg, int width, int height)
{
@@ -3182,7 +3661,11 @@ x_check_image_size (XImage *ximg, int width, int height)
int bitmap_pad, depth, bytes_per_line;
if (ximg)
{
+#ifndef HAVE_ANDROID
bitmap_pad = ximg->bitmap_pad;
+#else
+ bitmap_pad = (ximg->depth == 1 ? 8 : 32);
+#endif
depth = ximg->depth;
bytes_per_line = ximg->bytes_per_line;
}
@@ -3200,16 +3683,23 @@ static bool
x_create_x_image_and_pixmap (struct frame *f, int width, int height, int depth,
XImage **ximg, Pixmap *pixmap)
{
+#ifndef HAVE_ANDROID
Display *display = FRAME_X_DISPLAY (f);
Drawable drawable = FRAME_X_DRAWABLE (f);
+#endif
eassert (input_blocked_p ());
if (depth <= 0)
depth = FRAME_DISPLAY_INFO (f)->n_planes;
+#ifndef HAVE_ANDROID
*ximg = XCreateImage (display, FRAME_X_VISUAL (f),
depth, ZPixmap, 0, NULL, width, height,
depth > 16 ? 32 : depth > 8 ? 16 : 8, 0);
+#else
+ *ximg = android_create_image (depth, ANDROID_Z_PIXMAP, NULL, width,
+ height);
+#endif
if (*ximg == NULL)
{
image_error ("Unable to allocate X image");
@@ -3229,7 +3719,15 @@ x_create_x_image_and_pixmap (struct frame *f, int width, int height, int depth,
(*ximg)->data = xmalloc ((*ximg)->bytes_per_line * height);
/* Allocate a pixmap of the same size. */
+#ifndef HAVE_ANDROID
*pixmap = XCreatePixmap (display, drawable, width, height, depth);
+#else
+#ifndef ANDROID_STUBIFY
+ *pixmap = android_create_pixmap (width, height, depth);
+#else
+ emacs_abort ();
+#endif
+#endif
if (*pixmap == NO_PIXMAP)
{
x_destroy_x_image (*ximg);
@@ -3250,7 +3748,11 @@ x_destroy_x_image (XImage *ximg)
ximg->data = NULL;
}
+#ifndef HAVE_ANDROID
XDestroyImage (ximg);
+#else
+ android_destroy_image (ximg);
+#endif
}
# if !defined USE_CAIRO && defined HAVE_XRENDER
@@ -3317,7 +3819,7 @@ x_create_xrender_picture (struct frame *f, Emacs_Pixmap pixmap, int depth)
static bool
image_check_image_size (Emacs_Pix_Container ximg, int width, int height)
{
-#if defined HAVE_X_WINDOWS && !defined USE_CAIRO
+#if (defined HAVE_X_WINDOWS || defined HAVE_ANDROID) && !defined USE_CAIRO
return x_check_image_size (ximg, width, height);
#else
/* FIXME: Implement this check for the HAVE_NS and HAVE_NTGUI cases.
@@ -3349,13 +3851,13 @@ image_create_x_image_and_pixmap_1 (struct frame *f, int width, int height, int d
if (*pixmap == NO_PIXMAP)
{
*pimg = NULL;
- image_error ("Unable to create X pixmap", Qnil, Qnil);
- return 0;
+ image_error ("Unable to create X pixmap");
+ return false;
}
*pimg = *pixmap;
return 1;
-#elif defined HAVE_X_WINDOWS
+#elif defined HAVE_X_WINDOWS || defined HAVE_ANDROID
if (!x_create_x_image_and_pixmap (f, width, height, depth, pimg, pixmap))
return 0;
# ifdef HAVE_XRENDER
@@ -3382,8 +3884,8 @@ image_create_x_image_and_pixmap_1 (struct frame *f, int width, int height, int d
if (*pixmap == NO_PIXMAP)
{
*pimg = NULL;
- image_error ("Unable to create pixmap", Qnil, Qnil);
- return 0;
+ image_error ("Unable to create pixmap");
+ return false;
}
*pimg = *pixmap;
@@ -3501,7 +4003,7 @@ image_create_x_image_and_pixmap_1 (struct frame *f, int width, int height, int d
static void
image_destroy_x_image (Emacs_Pix_Container pimg)
{
-#if defined HAVE_X_WINDOWS && !defined USE_CAIRO
+#if (defined HAVE_X_WINDOWS || defined HAVE_ANDROID) && !defined USE_CAIRO
x_destroy_x_image (pimg);
#else
eassert (input_blocked_p ());
@@ -3540,7 +4042,9 @@ gui_put_x_image (struct frame *f, Emacs_Pix_Container pimg,
XPutImage (FRAME_X_DISPLAY (f), pixmap, gc, pimg, 0, 0, 0, 0,
pimg->width, pimg->height);
XFreeGC (FRAME_X_DISPLAY (f), gc);
-#endif /* HAVE_X_WINDOWS */
+#elif defined HAVE_ANDROID
+ android_put_image (pixmap, pimg);
+#endif
#ifdef HAVE_NS
eassert (pimg == pixmap);
@@ -3577,7 +4081,7 @@ static void
image_put_x_image (struct frame *f, struct image *img, Emacs_Pix_Container ximg,
bool mask_p)
{
-#if defined HAVE_X_WINDOWS && !defined USE_CAIRO
+#if (defined HAVE_X_WINDOWS || defined HAVE_ANDROID) && !defined USE_CAIRO
if (!mask_p)
{
eassert (img->ximg == NULL);
@@ -3595,7 +4099,7 @@ image_put_x_image (struct frame *f, struct image *img, Emacs_Pix_Container ximg,
#endif
}
-#if defined HAVE_X_WINDOWS && !defined USE_CAIRO
+#if (defined HAVE_X_WINDOWS || defined HAVE_ANDROID) && !defined USE_CAIRO
/* Put the X images recorded in IMG on frame F into pixmaps, then free
the X images and their buffers. */
@@ -3651,7 +4155,7 @@ image_get_x_image (struct frame *f, struct image *img, bool mask_p)
{
#if defined USE_CAIRO || defined (HAVE_HAIKU)
return !mask_p ? img->pixmap : img->mask;
-#elif defined HAVE_X_WINDOWS
+#elif defined HAVE_X_WINDOWS || defined HAVE_ANDROID
XImage *ximg_in_img = !mask_p ? img->ximg : img->mask_img;
if (ximg_in_img)
@@ -3661,9 +4165,15 @@ image_get_x_image (struct frame *f, struct image *img, bool mask_p)
return XGetImage (FRAME_X_DISPLAY (f), !mask_p ? img->pixmap : img->mask,
0, 0, img->original_width, img->original_height, ~0, ZPixmap);
#endif
+#ifndef HAVE_ANDROID
else
return XGetImage (FRAME_X_DISPLAY (f), !mask_p ? img->pixmap : img->mask,
0, 0, img->width, img->height, ~0, ZPixmap);
+#else
+ else
+ return android_get_image (!mask_p ? img->pixmap : img->mask,
+ ANDROID_Z_PIXMAP);
+#endif
#elif defined (HAVE_NS)
Emacs_Pix_Container pixmap = !mask_p ? img->pixmap : img->mask;
@@ -3676,13 +4186,18 @@ static void
image_unget_x_image (struct image *img, bool mask_p, Emacs_Pix_Container ximg)
{
#ifdef USE_CAIRO
-#elif defined HAVE_X_WINDOWS
+#elif defined HAVE_X_WINDOWS || defined HAVE_ANDROID
XImage *ximg_in_img = !mask_p ? img->ximg : img->mask_img;
if (ximg_in_img)
eassert (ximg == ximg_in_img);
+#ifdef HAVE_ANDROID
+ else
+ android_destroy_image (ximg);
+#else
else
XDestroyImage (ximg);
+#endif
#elif defined (HAVE_NS)
ns_release_object (ximg);
#endif
@@ -3701,10 +4216,11 @@ image_unget_x_image (struct image *img, bool mask_p, Emacs_Pix_Container ximg)
PFD is null, do not open the file. */
static Lisp_Object
-image_find_image_fd (Lisp_Object file, int *pfd)
+image_find_image_fd (Lisp_Object file, image_fd *pfd)
{
Lisp_Object file_found, search_path;
int fd;
+ void *platform;
/* TODO I think this should use something like image-load-path
instead. Unfortunately, that can contain non-string elements. */
@@ -3713,8 +4229,10 @@ image_find_image_fd (Lisp_Object file, int *pfd)
Vx_bitmap_file_path);
/* Try to find FILE in data-directory/images, then x-bitmap-file-path. */
+ platform = NULL;
fd = openp (search_path, file, Qnil, &file_found,
- pfd ? Qt : make_fixnum (R_OK), false, false);
+ pfd ? Qt : make_fixnum (R_OK), false, false,
+ pfd ? &platform : NULL);
if (fd == -2)
{
/* The file exists locally, but has a file name handler.
@@ -3724,10 +4242,23 @@ image_find_image_fd (Lisp_Object file, int *pfd)
Lisp_Object encoded_name = ENCODE_FILE (file_found);
fd = emacs_open (SSDATA (encoded_name), O_RDONLY, 0);
}
- else if (fd < 0)
+ /* FD is -3 if PLATFORM is set to a valid asset file descriptor on
+ Android. */
+ else if (fd < 0 && fd != -3)
return Qnil;
+
+#if !defined HAVE_ANDROID || defined ANDROID_STUBIFY
if (pfd)
*pfd = fd;
+#else
+ /* Construct an asset file descriptor. */
+
+ if (pfd)
+ {
+ pfd->fd = fd;
+ pfd->asset = platform;
+ }
+#endif
return file_found;
}
@@ -3741,15 +4272,26 @@ image_find_image_file (Lisp_Object file)
return image_find_image_fd (file, 0);
}
+#if defined HAVE_ANDROID && !defined ANDROID_STUBIFY
+
+static void
+close_android_fd (void *ptr)
+{
+ android_close_asset (*(struct android_fd_or_asset *) ptr);
+}
+
+#endif
+
/* Read FILE into memory. Value is a pointer to a buffer allocated
with xmalloc holding FILE's contents. Value is null if an error
occurred. FD is a file descriptor open for reading FILE. Set
*SIZE to the size of the file. */
static char *
-slurp_file (int fd, ptrdiff_t *size)
+slurp_file (image_fd fd, ptrdiff_t *size)
{
- FILE *fp = fdopen (fd, "rb");
+#if !defined HAVE_ANDROID || defined ANDROID_STUBIFY
+ FILE *fp = emacs_fdopen (fd, "rb");
char *buf = NULL;
struct stat st;
@@ -3759,7 +4301,7 @@ slurp_file (int fd, ptrdiff_t *size)
specpdl_ref count = SPECPDL_INDEX ();
record_unwind_protect_ptr (fclose_unwind, fp);
- if (fstat (fileno (fp), &st) == 0
+ if (sys_fstat (fileno (fp), &st) == 0
&& 0 <= st.st_size && st.st_size < min (PTRDIFF_MAX, SIZE_MAX))
{
/* Report an error if we read past the purported EOF.
@@ -3777,10 +4319,64 @@ slurp_file (int fd, ptrdiff_t *size)
unbind_to (count, Qnil);
}
+#else
+ char *buf;
+ struct stat st;
+ specpdl_ref count;
+
+ if (!android_asset_fstat (fd, &st)
+ && (0 <= st.st_size
+ && st.st_size < min (PTRDIFF_MAX, SIZE_MAX)))
+ {
+ count = SPECPDL_INDEX ();
+ record_unwind_protect_ptr (close_android_fd, &fd);
+ buf = xmalloc (st.st_size + 1);
+
+ /* Read one byte past the end of the file. That allows
+ detecting if the file grows as it is being read. */
+
+ if (android_asset_read (fd, buf,
+ st.st_size + 1) == st.st_size)
+ *size = st.st_size;
+ else
+ {
+ xfree (buf);
+ buf = NULL;
+ }
+
+ unbind_to (count, Qnil);
+ }
+ else
+ {
+ buf = NULL;
+ android_close_asset (fd);
+ }
+#endif
return buf;
}
+/* Like slurp_file above, but with added error handling. Value is
+ null if an error occurred. Set SIZE to the size of the file.
+ IMAGE_TYPE describes the image type (e.g. "PNG"). */
+
+static char *
+slurp_image (Lisp_Object filename, ptrdiff_t *size, const char *image_type)
+{
+ image_fd fd;
+ Lisp_Object file = image_find_image_fd (filename, &fd);
+ if (!STRINGP (file))
+ {
+ image_not_found_error (filename);
+ return NULL;
+ }
+ char *result = slurp_file (fd, size);
+ if (result == NULL)
+ image_error ("Error loading %s image `%s'",
+ build_unibyte_string (image_type),
+ file);
+ return result;
+}
/***********************************************************************
@@ -4003,7 +4599,7 @@ xbm_scan (char **s, char *end, char *sval, int *ival)
digit = char_hexdigit (c);
if (digit < 0)
break;
- overflow |= INT_MULTIPLY_WRAPV (value, 16, &value);
+ overflow |= ckd_mul (&value, value, 16);
value += digit;
}
}
@@ -4013,7 +4609,7 @@ xbm_scan (char **s, char *end, char *sval, int *ival)
while (*s < end
&& (c = *(*s)++, '0' <= c && c <= '7'))
{
- overflow |= INT_MULTIPLY_WRAPV (value, 8, &value);
+ overflow |= ckd_mul (&value, value, 8);
value += c - '0';
}
}
@@ -4024,8 +4620,8 @@ xbm_scan (char **s, char *end, char *sval, int *ival)
while (*s < end
&& (c = *(*s)++, c_isdigit (c)))
{
- overflow |= INT_MULTIPLY_WRAPV (value, 10, &value);
- overflow |= INT_ADD_WRAPV (value, c - '0', &value);
+ overflow |= ckd_mul (&value, value, 10);
+ overflow |= ckd_add (&value, value, c - '0');
}
}
@@ -4069,7 +4665,7 @@ xbm_scan (char **s, char *end, char *sval, int *ival)
if (digit < 0)
return 0;
- overflow |= INT_MULTIPLY_WRAPV (value, 16, &value);
+ overflow |= ckd_mul (&value, value, 16);
value += digit;
}
}
@@ -4205,6 +4801,15 @@ Create_Pixmap_From_Bitmap_Data (struct frame *f, struct image *img, char *data,
img->picture = x_create_xrender_picture (f, img->pixmap, 0);
# endif
+#elif defined HAVE_ANDROID
+#ifndef ANDROID_STUBIFY
+ img->pixmap
+ = android_create_pixmap_from_bitmap_data (data, img->width, img->height,
+ fg, bg,
+ FRAME_DISPLAY_INFO (f)->n_planes);
+#else
+ emacs_abort ();
+#endif
#elif defined HAVE_NTGUI
img->pixmap
= w32_create_pixmap_from_bitmap_data (img->width, img->height, data);
@@ -4270,7 +4875,7 @@ xbm_read_bitmap_data (struct frame *f, char *contents, char *end,
while (0)
#define expect_ident(IDENT) \
- if (LA1 == XBM_TK_IDENT && strcmp (buffer, (IDENT)) == 0) \
+ if (LA1 == XBM_TK_IDENT && strcmp (buffer, IDENT) == 0) \
match (); \
else \
goto failure
@@ -4490,22 +5095,10 @@ xbm_load (struct frame *f, struct image *img)
file_name = image_spec_value (img->spec, QCfile, NULL);
if (STRINGP (file_name))
{
- int fd;
- Lisp_Object file = image_find_image_fd (file_name, &fd);
- if (!STRINGP (file))
- {
- image_error ("Cannot find image file `%s'", file_name);
- return 0;
- }
-
ptrdiff_t size;
- char *contents = slurp_file (fd, &size);
+ char *contents = slurp_image (file_name, &size, "XBM");
if (contents == NULL)
- {
- image_error ("Error loading XBM image `%s'", file);
- return 0;
- }
-
+ return false;
success_p = xbm_load_image (f, img, contents, contents + size);
xfree (contents);
}
@@ -4635,7 +5228,8 @@ xbm_load (struct frame *f, struct image *img)
XPM images
***********************************************************************/
-#if defined (HAVE_XPM) || defined (HAVE_NS) || defined (HAVE_PGTK)
+#if defined (HAVE_XPM) || defined (HAVE_NS) || defined (HAVE_PGTK) \
+ || defined (HAVE_ANDROID)
static bool xpm_image_p (Lisp_Object object);
static bool xpm_load (struct frame *f, struct image *img);
@@ -4665,7 +5259,8 @@ static bool xpm_load (struct frame *f, struct image *img);
#endif /* not HAVE_NTGUI */
#endif /* HAVE_XPM */
-#if defined HAVE_XPM || defined USE_CAIRO || defined HAVE_NS || defined HAVE_HAIKU
+#if defined HAVE_XPM || defined USE_CAIRO || defined HAVE_NS \
+ || defined HAVE_HAIKU || defined HAVE_ANDROID
/* Indices of image specification fields in xpm_format, below. */
@@ -4685,7 +5280,8 @@ enum xpm_keyword_index
XPM_LAST
};
-#if defined HAVE_XPM || defined HAVE_NS || defined HAVE_HAIKU || defined HAVE_PGTK
+#if defined HAVE_XPM || defined HAVE_NS || defined HAVE_HAIKU \
+ || defined HAVE_PGTK || defined HAVE_ANDROID
/* Vector of image_keyword structures describing the format
of valid XPM image specifications. */
@@ -4927,7 +5523,8 @@ init_xpm_functions (void)
#endif /* WINDOWSNT */
-#if defined HAVE_XPM || defined HAVE_NS || defined HAVE_HAIKU || defined HAVE_PGTK
+#if defined HAVE_XPM || defined HAVE_NS || defined HAVE_HAIKU \
+ || defined HAVE_PGTK || defined HAVE_ANDROID
/* Value is true if COLOR_SYMBOLS is a valid color symbols list
for XPM images. Such a list must consist of conses whose car and
cdr are strings. */
@@ -4963,9 +5560,9 @@ xpm_image_p (Lisp_Object object)
&& (! fmt[XPM_COLOR_SYMBOLS].count
|| xpm_valid_color_symbols_p (fmt[XPM_COLOR_SYMBOLS].value)));
}
-#endif /* HAVE_XPM || HAVE_NS || HAVE_HAIKU || HAVE_PGTK */
+#endif /* HAVE_XPM || HAVE_NS || HAVE_HAIKU || HAVE_PGTK || HAVE_ANDROID */
-#endif /* HAVE_XPM || USE_CAIRO || HAVE_NS || HAVE_HAIKU */
+#endif /* HAVE_XPM || USE_CAIRO || HAVE_NS || HAVE_HAIKU || HAVE_ANDROID */
#if defined HAVE_XPM && defined HAVE_X_WINDOWS && !defined USE_GTK
ptrdiff_t
@@ -5142,12 +5739,12 @@ xpm_load (struct frame *f, struct image *img)
Lisp_Object file = image_find_image_file (specified_file);
if (!STRINGP (file))
{
- image_error ("Cannot find image file `%s'", specified_file);
+ image_not_found_error (specified_file);
#ifdef ALLOC_XPM_COLORS
xpm_free_color_cache ();
#endif
SAFE_FREE ();
- return 0;
+ return false;
}
file = ENCODE_FILE (file);
@@ -5174,7 +5771,7 @@ xpm_load (struct frame *f, struct image *img)
Lisp_Object buffer = image_spec_value (img->spec, QCdata, NULL);
if (!STRINGP (buffer))
{
- image_error ("Invalid image data `%s'", buffer);
+ image_invalid_data_error (buffer);
#ifdef ALLOC_XPM_COLORS
xpm_free_color_cache ();
#endif
@@ -5338,10 +5935,12 @@ xpm_load (struct frame *f, struct image *img)
#if (defined USE_CAIRO && defined HAVE_XPM) \
|| (defined HAVE_NS && !defined HAVE_XPM) \
|| (defined HAVE_HAIKU && !defined HAVE_XPM) \
- || (defined HAVE_PGTK && !defined HAVE_XPM)
+ || (defined HAVE_PGTK && !defined HAVE_XPM) \
+ || (defined HAVE_ANDROID && !defined HAVE_XPM)
-/* XPM support functions for NS and Haiku where libxpm is not available, and for
- Cairo. Only XPM version 3 (without any extensions) is supported. */
+/* XPM support functions for NS, Haiku and Android where libxpm is not
+ available, and for Cairo. Only XPM version 3 (without any
+ extensions) is supported. */
static void xpm_put_color_table_v (Lisp_Object, const char *,
int, Lisp_Object);
@@ -5470,9 +6069,7 @@ xpm_make_color_table_h (void (**put_func) (Lisp_Object, const char *, int,
{
*put_func = xpm_put_color_table_h;
*get_func = xpm_get_color_table_h;
- return make_hash_table (hashtest_equal, DEFAULT_HASH_SIZE,
- DEFAULT_REHASH_SIZE, DEFAULT_REHASH_THRESHOLD,
- Qnil, false);
+ return make_hash_table (&hashtest_equal, DEFAULT_HASH_SIZE, Weak_None, false);
}
static void
@@ -5482,9 +6079,10 @@ xpm_put_color_table_h (Lisp_Object color_table,
Lisp_Object color)
{
struct Lisp_Hash_Table *table = XHASH_TABLE (color_table);
- Lisp_Object chars = make_unibyte_string (chars_start, chars_len), hash_code;
+ Lisp_Object chars = make_unibyte_string (chars_start, chars_len);
- hash_lookup (table, chars, &hash_code);
+ hash_hash_t hash_code;
+ hash_lookup_get_hash (table, chars, &hash_code);
hash_put (table, chars, color, hash_code);
}
@@ -5495,7 +6093,7 @@ xpm_get_color_table_h (Lisp_Object color_table,
{
struct Lisp_Hash_Table *table = XHASH_TABLE (color_table);
ptrdiff_t i =
- hash_lookup (table, make_unibyte_string (chars_start, chars_len), NULL);
+ hash_lookup (table, make_unibyte_string (chars_start, chars_len));
return i >= 0 ? HASH_VALUE (table, i) : Qnil;
}
@@ -5556,7 +6154,7 @@ xpm_load_image (struct frame *f,
#define expect_ident(IDENT) \
if (LA1 == XPM_TK_IDENT \
- && strlen ((IDENT)) == len && memcmp ((IDENT), beg, len) == 0) \
+ && strlen (IDENT) == len && memcmp (IDENT, beg, len) == 0) \
match (); \
else \
goto failure
@@ -5780,21 +6378,10 @@ xpm_load (struct frame *f,
file_name = image_spec_value (img->spec, QCfile, NULL);
if (STRINGP (file_name))
{
- int fd;
- Lisp_Object file = image_find_image_fd (file_name, &fd);
- if (!STRINGP (file))
- {
- image_error ("Cannot find image file `%s'", file_name);
- return 0;
- }
-
ptrdiff_t size;
- char *contents = slurp_file (fd, &size);
+ char *contents = slurp_image (file_name, &size, "XPM");
if (contents == NULL)
- {
- image_error ("Error loading XPM image `%s'", file);
- return 0;
- }
+ return false;
success_p = xpm_load_image (f, img, contents, contents + size);
xfree (contents);
@@ -5806,8 +6393,8 @@ xpm_load (struct frame *f,
data = image_spec_value (img->spec, QCdata, NULL);
if (!STRINGP (data))
{
- image_error ("Invalid image data `%s'", data);
- return 0;
+ image_invalid_data_error (data);
+ return false;
}
success_p = xpm_load_image (f, img, SSDATA (data),
SSDATA (data) + SBYTES (data));
@@ -6077,7 +6664,8 @@ lookup_rgb_color (struct frame *f, int r, int g, int b)
{
#ifdef HAVE_NTGUI
return PALETTERGB (r >> 8, g >> 8, b >> 8);
-#elif defined USE_CAIRO || defined HAVE_NS || defined HAVE_HAIKU
+#elif defined USE_CAIRO || defined HAVE_NS || defined HAVE_HAIKU \
+ || defined HAVE_ANDROID
return RGB_TO_ULONG (r >> 8, g >> 8, b >> 8);
#else
xsignal1 (Qfile_error,
@@ -6136,8 +6724,8 @@ image_to_emacs_colors (struct frame *f, struct image *img, bool rgb_p)
HGDIOBJ prev;
#endif /* HAVE_NTGUI */
- if (INT_MULTIPLY_WRAPV (sizeof *colors, img->width, &nbytes)
- || INT_MULTIPLY_WRAPV (img->height, nbytes, &nbytes)
+ if (ckd_mul (&nbytes, sizeof *colors, img->width)
+ || ckd_mul (&nbytes, nbytes, img->height)
|| SIZE_MAX < nbytes)
memory_full (SIZE_MAX);
colors = xmalloc (nbytes);
@@ -6150,7 +6738,8 @@ image_to_emacs_colors (struct frame *f, struct image *img, bool rgb_p)
p = colors;
for (y = 0; y < img->height; ++y)
{
-#if !defined USE_CAIRO && !defined HAVE_NS && !defined HAVE_HAIKU
+#if !defined USE_CAIRO && !defined HAVE_NS && !defined HAVE_HAIKU \
+ && !defined HAVE_ANDROID
Emacs_Color *row = p;
for (x = 0; x < img->width; ++x, ++p)
p->pixel = GET_PIXEL (ximg, x, y);
@@ -6158,7 +6747,7 @@ image_to_emacs_colors (struct frame *f, struct image *img, bool rgb_p)
{
FRAME_TERMINAL (f)->query_colors (f, row, img->width);
}
-#else /* USE_CAIRO || HAVE_NS || HAVE_HAIKU */
+#else /* USE_CAIRO || HAVE_NS || HAVE_HAIKU || HAVE_ANDROID */
for (x = 0; x < img->width; ++x, ++p)
{
p->pixel = GET_PIXEL (ximg, x, y);
@@ -6169,7 +6758,7 @@ image_to_emacs_colors (struct frame *f, struct image *img, bool rgb_p)
p->blue = BLUE16_FROM_ULONG (p->pixel);
}
}
-#endif /* USE_CAIRO || HAVE_NS */
+#endif /* USE_CAIRO || HAVE_NS || HAVE_ANDROID */
}
image_unget_x_image_or_dc (img, 0, ximg, prev);
@@ -6234,7 +6823,11 @@ image_from_emacs_colors (struct frame *f, struct image *img, Emacs_Color *colors
Emacs_Pix_Container ximage;
Emacs_Color *p;
+#ifndef HAVE_ANDROID
ximage = NULL;
+#else
+ ximage = 0;
+#endif
init_color_table ();
@@ -6282,8 +6875,8 @@ image_detect_edges (struct frame *f, struct image *img,
#define COLOR(A, X, Y) ((A) + (Y) * img->width + (X))
- if (INT_MULTIPLY_WRAPV (sizeof *new, img->width, &nbytes)
- || INT_MULTIPLY_WRAPV (img->height, nbytes, &nbytes))
+ if (ckd_mul (&nbytes, sizeof *new, img->width)
+ || ckd_mul (&nbytes, nbytes, img->height))
memory_full (SIZE_MAX);
new = xmalloc (nbytes);
@@ -6396,7 +6989,9 @@ image_edge_detection (struct frame *f, struct image *img,
}
-#if defined HAVE_X_WINDOWS || defined USE_CAIRO || defined HAVE_HAIKU
+#if defined HAVE_X_WINDOWS || defined USE_CAIRO || defined HAVE_HAIKU \
+ || defined HAVE_ANDROID
+
static void
image_pixmap_draw_cross (struct frame *f, Emacs_Pixmap pixmap,
int x, int y, unsigned int width, unsigned int height,
@@ -6432,8 +7027,21 @@ image_pixmap_draw_cross (struct frame *f, Emacs_Pixmap pixmap,
XFreeGC (dpy, gc);
#elif HAVE_HAIKU
be_draw_cross_on_pixmap (pixmap, x, y, width, height, color);
+#elif HAVE_ANDROID
+#ifndef ANDROID_STUBIFY
+ struct android_gc *gc;
+
+ gc = android_create_gc (0, NULL);
+ android_set_foreground (gc, color);
+ android_draw_line (pixmap, gc, x, y, x + width - 1, y + height - 1);
+ android_draw_line (pixmap, gc, x, y + height - 1, x + width - 1, y);
+ android_free_gc (gc);
+#else
+ emacs_abort ();
+#endif
#endif
}
+
#endif /* HAVE_X_WINDOWS || USE_CAIRO || HAVE_HAIKU */
/* Transform image IMG on frame F so that it looks disabled. */
@@ -6477,7 +7085,7 @@ image_disable_image (struct frame *f, struct image *img)
#ifndef HAVE_NTGUI
#ifndef HAVE_NS /* TODO: NS support, however this not needed for toolbars */
-#if !defined USE_CAIRO && !defined HAVE_HAIKU
+#if !defined USE_CAIRO && !defined HAVE_HAIKU && !defined HAVE_ANDROID
#define CrossForeground(f) BLACK_PIX_DEFAULT (f)
#define MaskForeground(f) WHITE_PIX_DEFAULT (f)
#else /* USE_CAIRO || HAVE_HAIKU */
@@ -6788,21 +7396,10 @@ pbm_load (struct frame *f, struct image *img)
if (STRINGP (specified_file))
{
- int fd;
- Lisp_Object file = image_find_image_fd (specified_file, &fd);
- if (!STRINGP (file))
- {
- image_error ("Cannot find image file `%s'", specified_file);
- return 0;
- }
-
ptrdiff_t size;
- contents = slurp_file (fd, &size);
+ contents = slurp_image (specified_file, &size, "PBM");
if (contents == NULL)
- {
- image_error ("Error reading `%s'", file);
- return 0;
- }
+ return false;
p = contents;
end = contents + size;
@@ -6813,8 +7410,8 @@ pbm_load (struct frame *f, struct image *img)
data = image_spec_value (img->spec, QCdata, NULL);
if (!STRINGP (data))
{
- image_error ("Invalid image data `%s'", data);
- return 0;
+ image_invalid_data_error (data);
+ return false;
}
p = SSDATA (data);
end = p + SBYTES (data);
@@ -7456,15 +8053,18 @@ png_load_body (struct frame *f, struct image *img, struct png_load_context *c)
if (NILP (specified_data))
{
int fd;
- Lisp_Object file = image_find_image_fd (specified_file, &fd);
- if (!STRINGP (file))
+ Lisp_Object file = image_find_image_file (specified_file);
+
+ if (!STRINGP (file)
+ || (fd = emacs_open (SSDATA (ENCODE_FILE (file)),
+ O_RDONLY, 0)) < 0)
{
- image_error ("Cannot find image file `%s'", specified_file);
- return 0;
+ image_not_found_error (specified_file);
+ return false;
}
/* Open the image file. */
- fp = fdopen (fd, "rb");
+ fp = emacs_fdopen (fd, "rb");
if (!fp)
{
image_error ("Cannot open image file `%s'", file);
@@ -7475,7 +8075,7 @@ png_load_body (struct frame *f, struct image *img, struct png_load_context *c)
if (fread (sig, 1, sizeof sig, fp) != sizeof sig
|| png_sig_cmp (sig, 0, sizeof sig))
{
- fclose (fp);
+ emacs_fclose (fp);
image_error ("Not a PNG file: `%s'", file);
return 0;
}
@@ -7484,8 +8084,8 @@ png_load_body (struct frame *f, struct image *img, struct png_load_context *c)
{
if (!STRINGP (specified_data))
{
- image_error ("Invalid image data `%s'", specified_data);
- return 0;
+ image_invalid_data_error (specified_data);
+ return false;
}
/* Read from memory. */
@@ -7529,7 +8129,7 @@ png_load_body (struct frame *f, struct image *img, struct png_load_context *c)
}
if (! png_ptr)
{
- if (fp) fclose (fp);
+ if (fp) emacs_fclose (fp);
return 0;
}
@@ -7543,7 +8143,7 @@ png_load_body (struct frame *f, struct image *img, struct png_load_context *c)
xfree (c->pixels);
xfree (c->rows);
if (c->fp)
- fclose (c->fp);
+ emacs_fclose (c->fp);
return 0;
}
@@ -7611,7 +8211,6 @@ png_load_body (struct frame *f, struct image *img, struct png_load_context *c)
simple transparency, we prefer a clipping mask. */
if (!transparent_p)
{
- /* png_color_16 *image_bg; */
Lisp_Object specified_bg
= image_spec_value (img->spec, QCbackground, NULL);
Emacs_Color color;
@@ -7655,8 +8254,8 @@ png_load_body (struct frame *f, struct image *img, struct png_load_context *c)
row_bytes = png_get_rowbytes (png_ptr, info_ptr);
/* Allocate memory for the image. */
- if (INT_MULTIPLY_WRAPV (row_bytes, sizeof *pixels, &nbytes)
- || INT_MULTIPLY_WRAPV (nbytes, height, &nbytes))
+ if (ckd_mul (&nbytes, row_bytes, sizeof *pixels)
+ || ckd_mul (&nbytes, nbytes, height))
memory_full (SIZE_MAX);
c->pixels = pixels = xmalloc (nbytes);
c->rows = rows = xmalloc (height * sizeof *rows);
@@ -7668,7 +8267,7 @@ png_load_body (struct frame *f, struct image *img, struct png_load_context *c)
png_read_end (png_ptr, info_ptr);
if (fp)
{
- fclose (fp);
+ emacs_fclose (fp);
c->fp = NULL;
}
@@ -8184,14 +8783,16 @@ jpeg_load_body (struct frame *f, struct image *img,
if (NILP (specified_data))
{
int fd;
- Lisp_Object file = image_find_image_fd (specified_file, &fd);
- if (!STRINGP (file))
+ Lisp_Object file = image_find_image_file (specified_file);
+ if (!STRINGP (file)
+ || (fd = emacs_open (SSDATA (ENCODE_FILE (file)),
+ O_RDONLY, 0)) < 0)
{
- image_error ("Cannot find image file `%s'", specified_file);
- return 0;
+ image_not_found_error (specified_file);
+ return false;
}
- fp = fdopen (fd, "rb");
+ fp = emacs_fdopen (fd, "rb");
if (fp == NULL)
{
image_error ("Cannot open `%s'", file);
@@ -8200,8 +8801,8 @@ jpeg_load_body (struct frame *f, struct image *img,
}
else if (!STRINGP (specified_data))
{
- image_error ("Invalid image data `%s'", specified_data);
- return 0;
+ image_invalid_data_error (specified_data);
+ return false;
}
/* Customize libjpeg's error handling to call my_error_exit when an
@@ -8231,11 +8832,12 @@ jpeg_load_body (struct frame *f, struct image *img,
/* Close the input file and destroy the JPEG object. */
if (fp)
- fclose (fp);
+ emacs_fclose (fp);
jpeg_destroy_decompress (&mgr->cinfo);
/* If we already have an XImage, free that. */
- image_destroy_x_image (ximg);
+ if (ximg)
+ image_destroy_x_image (ximg);
/* Free pixmap and colors. */
image_clear_image (f, img);
return 0;
@@ -8326,7 +8928,7 @@ jpeg_load_body (struct frame *f, struct image *img,
jpeg_finish_decompress (&mgr->cinfo);
jpeg_destroy_decompress (&mgr->cinfo);
if (fp)
- fclose (fp);
+ emacs_fclose (fp);
/* Maybe fill in the background field while we have ximg handy. */
if (NILP (image_spec_value (img->spec, QCbackground, NULL)))
@@ -8641,8 +9243,8 @@ tiff_load (struct frame *f, struct image *img)
Lisp_Object file = image_find_image_file (specified_file);
if (!STRINGP (file))
{
- image_error ("Cannot find image file `%s'", specified_file);
- return 0;
+ image_not_found_error (specified_file);
+ return false;
}
Lisp_Object encoded_file = ENCODE_FILE (file);
@@ -8662,8 +9264,8 @@ tiff_load (struct frame *f, struct image *img)
{
if (!STRINGP (specified_data))
{
- image_error ("Invalid image data `%s'", specified_data);
- return 0;
+ image_invalid_data_error (specified_data);
+ return false;
}
/* Memory source! */
@@ -9070,7 +9672,7 @@ gif_load (struct frame *f, struct image *img)
Lisp_Object file = image_find_image_file (specified_file);
if (!STRINGP (file))
{
- image_error ("Cannot find image file `%s'", specified_file);
+ image_not_found_error (specified_file);
return false;
}
@@ -9100,17 +9702,22 @@ gif_load (struct frame *f, struct image *img)
/* Get the file size so that we can report it in
`image-cache-size'. */
- struct stat st;
- FILE *fp = fopen (SSDATA (encoded_file), "rb");
- if (fstat (fileno (fp), &st) == 0)
- byte_size = st.st_size;
- fclose (fp);
+ {
+ struct stat st;
+ int fd;
+
+ fd = emacs_open (SSDATA (encoded_file), O_RDONLY,
+ 0);
+ if (!sys_fstat (fd, &st))
+ byte_size = st.st_size;
+ emacs_close (fd);
+ }
}
else
{
if (!STRINGP (specified_data))
{
- image_error ("Invalid image data `%s'", specified_data);
+ image_invalid_data_error (specified_data);
return false;
}
@@ -9682,26 +10289,15 @@ webp_load (struct frame *f, struct image *img)
if (NILP (specified_data))
{
- int fd;
- file = image_find_image_fd (specified_file, &fd);
- if (!STRINGP (file))
- {
- image_error ("Cannot find image file `%s'", specified_file);
- return false;
- }
-
- contents = (uint8_t *) slurp_file (fd, &size);
+ contents = (uint8_t *) slurp_image (specified_file, &size, "WebP");
if (contents == NULL)
- {
- image_error ("Error loading WebP image `%s'", file);
- return false;
- }
+ return false;
}
else
{
if (!STRINGP (specified_data))
{
- image_error ("Invalid image data `%s'", specified_data);
+ image_invalid_data_error (specified_data);
return false;
}
contents = SDATA (specified_data);
@@ -9842,22 +10438,36 @@ webp_load (struct frame *f, struct image *img)
}
/* Create the x image and pixmap. */
- Emacs_Pix_Container ximg, mask_img = NULL;
+ Emacs_Pix_Container ximg;
if (!image_create_x_image_and_pixmap (f, img, width, height, 0, &ximg, false))
goto webp_error2;
- /* 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))
+ /* Find the background to use if the WebP image contains an alpha
+ channel. */
+ Emacs_Color bg_color;
+ if (features.has_alpha)
{
- image_destroy_x_image (ximg);
- image_clear_image_1 (f, img, CLEAR_IMAGE_PIXMAP);
- goto webp_error2;
+ Lisp_Object specified_bg
+ = image_spec_value (img->spec, QCbackground, NULL);
+
+ /* If the user specified a color, try to use it; if not, use the
+ current frame background, ignoring any default background
+ color set by the image. */
+ if (STRINGP (specified_bg))
+ FRAME_TERMINAL (f)->defined_color_hook (f,
+ SSDATA (specified_bg),
+ &bg_color,
+ false,
+ false);
+ else
+ FRAME_TERMINAL (f)->query_frame_background_color (f, &bg_color);
+ bg_color.red >>= 8;
+ bg_color.green >>= 8;
+ bg_color.blue >>= 8;
}
- /* Fill the X image and mask from WebP data. */
+ /* Fill the X image from WebP data. */
+
init_color_table ();
img->corners[TOP_CORNER] = 0;
@@ -9872,21 +10482,24 @@ webp_load (struct frame *f, struct image *img)
{
for (int x = 0; x < width; ++x)
{
- int r = *p++ << 8;
- int g = *p++ << 8;
- int b = *p++ << 8;
- PUT_PIXEL (ximg, x, y, lookup_rgb_color (f, r, g, b));
-
- /* An alpha channel associates variable transparency with an
- 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. */
+ int r, g, b;
+ /* The WebP alpha channel allows 256 levels of partial
+ transparency. Blend it with the background manually. */
if (features.has_alpha || anim)
{
- if (mask_img)
- PUT_PIXEL (mask_img, x, y, *p > 0 ? PIX_MASK_DRAW : PIX_MASK_RETAIN);
- ++p;
+ float a = (float) p[3] / UINT8_MAX;
+ r = (int)(a * p[0] + (1 - a) * bg_color.red) << 8;
+ g = (int)(a * p[1] + (1 - a) * bg_color.green) << 8;
+ b = (int)(a * p[2] + (1 - a) * bg_color.blue) << 8;
+ p += 4;
+ }
+ else
+ {
+ r = *p++ << 8;
+ g = *p++ << 8;
+ b = *p++ << 8;
}
+ PUT_PIXEL (ximg, x, y, lookup_rgb_color (f, r, g, b));
}
}
@@ -9899,16 +10512,6 @@ webp_load (struct frame *f, struct image *img)
/* Put ximg into the image. */
image_put_x_image (f, img, ximg, 0);
- /* Same for the mask. */
- if (mask_img)
- {
- /* Fill in the background_transparent field while we have the
- mask handy. Casting avoids a GCC warning. */
- image_background_transparent (img, f, (Emacs_Pix_Context)mask_img);
-
- image_put_x_image (f, img, mask_img, 1);
- }
-
img->width = width;
img->height = height;
@@ -10365,7 +10968,8 @@ imagemagick_load_image (struct frame *f, struct image *img,
return 0;
}
-#ifdef HAVE_MAGICKAUTOORIENTIMAGE
+#if defined HAVE_MAGICKAUTOORIENTIMAGE \
+ || HAVE_DECL_MAGICKAUTOORIENTIMAGE
/* If no :rotation is explicitly specified, apply the automatic
rotation from EXIF. */
if (NILP (image_spec_value (img->spec, QCrotation, NULL)))
@@ -10522,7 +11126,8 @@ imagemagick_load_image (struct frame *f, struct image *img,
{
MagickWand *new_wand;
MagickSetImageBackgroundColor (image_wand, bg_wand);
-#ifdef HAVE_MAGICKMERGEIMAGELAYERS
+#if defined HAVE_MAGICKMERGEIMAGELAYERS \
+ || HAVE_DECL_MAGICKMERGEIMAGELAYERS
new_wand = MagickMergeImageLayers (image_wand, MergeLayer);
#else
new_wand = MagickFlattenImages (image_wand);
@@ -10551,8 +11156,9 @@ imagemagick_load_image (struct frame *f, struct image *img,
init_color_table ();
-#if defined (HAVE_MAGICKEXPORTIMAGEPIXELS) && \
- ! defined (HAVE_NS) && ! defined (HAVE_HAIKU)
+#if (defined (HAVE_MAGICKEXPORTIMAGEPIXELS) \
+ || HAVE_DECL_MAGICKEXPORTIMAGEPIXELS) \
+ && ! defined (HAVE_NS) && ! defined (HAVE_HAIKU)
if (imagemagick_render_type != 0)
{
/* Magicexportimage is normally faster than pixelpushing. This
@@ -10700,8 +11306,8 @@ imagemagick_load (struct frame *f, struct image *img)
Lisp_Object file = image_find_image_file (file_name);
if (!STRINGP (file))
{
- image_error ("Cannot find image file `%s'", file_name);
- return 0;
+ image_not_found_error (file_name);
+ return false;
}
file = ENCODE_FILE (file);
#ifdef WINDOWSNT
@@ -10718,8 +11324,8 @@ imagemagick_load (struct frame *f, struct image *img)
data = image_spec_value (img->spec, QCdata, NULL);
if (!STRINGP (data))
{
- image_error ("Invalid image data `%s'", data);
- return 0;
+ image_invalid_data_error (data);
+ return false;
}
success_p = imagemagick_load_image (f, img, SDATA (data),
SBYTES (data), NULL);
@@ -11078,12 +11684,12 @@ svg_load (struct frame *f, struct image *img)
base_uri = image_spec_value (img->spec, QCbase_uri, NULL);
if (STRINGP (file_name))
{
- int fd;
+ image_fd fd;
Lisp_Object file = image_find_image_fd (file_name, &fd);
if (!STRINGP (file))
{
- image_error ("Cannot find image file `%s'", file_name);
- return 0;
+ image_not_found_error (file_name);
+ return false;
}
/* Read the entire file into memory. */
@@ -11092,7 +11698,7 @@ svg_load (struct frame *f, struct image *img)
if (contents == NULL)
{
image_error ("Error loading SVG image `%s'", file);
- return 0;
+ return false;
}
/* If the file was slurped into memory properly, parse it. */
if (!STRINGP (base_uri))
@@ -11110,8 +11716,8 @@ svg_load (struct frame *f, struct image *img)
data = image_spec_value (img->spec, QCdata, NULL);
if (!STRINGP (data))
{
- image_error ("Invalid image data `%s'", data);
- return 0;
+ image_invalid_data_error (data);
+ return false;
}
if (!STRINGP (base_uri))
base_uri = BVAR (current_buffer, filename);
@@ -11129,6 +11735,12 @@ svg_css_length_to_pixels (RsvgLength length, double dpi, int font_size)
{
double value = length.length;
+#if ! LIBRSVG_CHECK_VERSION (2, 48, 0)
+ /* librsvg 2.48 lets us define the font size, but earlier versions
+ default to 12 pixels. */
+ font_size = 12;
+#endif
+
switch (length.unit)
{
case RSVG_UNIT_PX:
@@ -11153,16 +11765,31 @@ svg_css_length_to_pixels (RsvgLength length, double dpi, int font_size)
case RSVG_UNIT_IN:
value *= dpi;
break;
-#if LIBRSVG_CHECK_VERSION (2, 48, 0)
- /* We don't know exactly what font size is used on older librsvg
- versions. */
case RSVG_UNIT_EM:
value *= font_size;
break;
-#endif
+ case RSVG_UNIT_EX:
+ /* librsvg uses an ex height of half the em height, so we match
+ that here. */
+ value = value * font_size / 2.0;
+ break;
+ case RSVG_UNIT_PERCENT:
+ /* Percent is a ratio of the containing "viewport". We don't
+ have a viewport, as such, as we try to draw the image to it's
+ 'natural' size rather than dictate the size as if we were
+ drawing icons on a toolbar or similar. This means that
+ percent values are useless to us and we are best off just
+ drawing the image according to whatever other sizes we can
+ derive.
+
+ If we do set explicit width and height values in the image
+ spec, this will work out correctly as librsvg will still
+ honor the percentage sizes in its final rendering no matter
+ what size we make the image. */
+ value = 0;
+ break;
default:
- /* Probably ex or %. We can't know what the pixel value is
- without more information. */
+ /* We should never reach this. */
value = 0;
}
@@ -11176,7 +11803,17 @@ svg_css_length_to_pixels (RsvgLength length, double dpi, int font_size)
Use librsvg to do most of the image processing.
- Return true when successful. */
+ Return true when successful.
+
+ The basic process, which is used for all versions of librsvg, is to
+ load the SVG and parse it, then extract the image dimensions. We
+ then use those image dimensions to calculate the final size and
+ wrap the SVG data inside another SVG we build on the fly. This
+ wrapper does the necessary resizing and setting of foreground and
+ background colors and is then parsed and rasterized.
+
+ It should also be noted that setting up the SVG prior to 2.32 was
+ done differently, but the overall process is the same. */
static bool
svg_load_image (struct frame *f, struct image *img, char *contents,
ptrdiff_t size, char *filename)
@@ -11230,7 +11867,13 @@ svg_load_image (struct frame *f, struct image *img, char *contents,
Lisp_Object lcss = image_spec_value (img->spec, QCcss, NULL);
if (!STRINGP (lcss))
{
- /* Generate the CSS for the SVG image. */
+ /* Generate the CSS for the SVG image.
+
+ We use this to set the font (font-family in CSS lingo) and
+ the font size. We can extend this to handle any CSS values
+ SVG supports, however it's only available in librsvg 2.48 and
+ above so some things we could set here are handled in the
+ wrapper below. */
/* FIXME: The below calculations leave enough space for a font
size up to 9999, if it overflows we just throw an error but
should probably increase the buffer size. */
@@ -11276,7 +11919,23 @@ svg_load_image (struct frame *f, struct image *img, char *contents,
if (err) goto rsvg_error;
#endif
- /* Get the image dimensions. */
+ /* Get the image dimensions.
+
+ There are a couple of approaches used here, depending on the
+ contents of the SVG, and which version of librsvg we're using.
+ With librsvg versions prior to 2.46 we ask librsvg for the size
+ of the image, however this may include pats of the image that are
+ outside of the viewbox.
+
+ librsvg 2.46 allows us to request the image's "intrinsic
+ dimensions", which are the sizes given in the SVG in CSS units.
+ So, for example, if the image defines it's width as "10mm", we
+ are given a struct that we need to translate into pixel values
+ ourself (see svg_css_length_to_pixels).
+
+ 2.52 introduces a function that will give us the pixel sizes
+ directly, assuming we provide the correct screen DPI values.
+ */
#if LIBRSVG_CHECK_VERSION (2, 46, 0)
gdouble gviewbox_width = 0, gviewbox_height = 0;
gboolean has_viewbox = FALSE;
@@ -11293,7 +11952,8 @@ svg_load_image (struct frame *f, struct image *img, char *contents,
}
else
{
- RsvgRectangle zero_rect, viewbox, out_logical_rect;
+ RsvgRectangle viewbox;
+ double explicit_width = 0, explicit_height = 0;
/* Try the intrinsic dimensions first. */
gboolean has_width, has_height;
@@ -11305,34 +11965,27 @@ svg_load_image (struct frame *f, struct image *img, char *contents,
&has_height, &iheight,
&has_viewbox, &viewbox);
- if (has_width && has_height)
- {
- /* Success! We can use these values directly. */
- viewbox_width = svg_css_length_to_pixels (iwidth, dpi,
+ if (has_width)
+ explicit_width = svg_css_length_to_pixels (iwidth, dpi,
+ img->face_font_size);
+ if (has_height)
+ explicit_height = svg_css_length_to_pixels (iheight, dpi,
img->face_font_size);
- viewbox_height = svg_css_length_to_pixels (iheight, dpi,
- img->face_font_size);
- /* Here one dimension could be zero because in percent unit.
- So calculate this dimension with the other. */
- if (! (0 < viewbox_width) && (iwidth.unit == RSVG_UNIT_PERCENT))
- viewbox_width = (viewbox_height * viewbox.width / viewbox.height)
- * iwidth.length;
- else if (! (0 < viewbox_height) && (iheight.unit == RSVG_UNIT_PERCENT))
- viewbox_height = (viewbox_width * viewbox.height / viewbox.width)
- * iheight.length;
+ if (explicit_width > 0 && explicit_height > 0)
+ {
+ viewbox_width = explicit_width;
+ viewbox_height = explicit_height;
}
- else if (has_width && has_viewbox)
+ else if (explicit_width > 0 && has_viewbox)
{
- viewbox_width = svg_css_length_to_pixels (iwidth, dpi,
- img->face_font_size);
- viewbox_height = viewbox_width * viewbox.height / viewbox.width;
+ viewbox_width = explicit_width;
+ viewbox_height = explicit_width * viewbox.height / viewbox.width;
}
- else if (has_height && has_viewbox)
+ else if (explicit_height > 0 && has_viewbox)
{
- viewbox_height = svg_css_length_to_pixels (iheight, dpi,
- img->face_font_size);
- viewbox_width = viewbox_height * viewbox.width / viewbox.height;
+ viewbox_height = explicit_height;
+ viewbox_width = explicit_height * viewbox.width / viewbox.height;
}
else if (has_viewbox)
{
@@ -11346,8 +11999,15 @@ svg_load_image (struct frame *f, struct image *img, char *contents,
{
/* We haven't found a usable set of sizes, so try working out
the visible area. */
+
+ /* FIXME: I'm not sure exactly how librsvg uses this
+ viewport input here, so I'm not sure what values I should
+ set. */
+ RsvgRectangle max_viewport_rect = {0, 0, UINT_MAX, UINT_MAX};
+ RsvgRectangle out_logical_rect;
+
rsvg_handle_get_geometry_for_layer (rsvg_handle, NULL,
- &zero_rect, &viewbox,
+ &max_viewport_rect, &viewbox,
&out_logical_rect, NULL);
viewbox_width = viewbox.x + viewbox.width;
viewbox_height = viewbox.y + viewbox.height;
@@ -11467,6 +12127,8 @@ svg_load_image (struct frame *f, struct image *img, char *contents,
FRAME_DISPLAY_INFO (f)->resy);
#if LIBRSVG_CHECK_VERSION (2, 48, 0)
+ /* Set the CSS for the wrapped SVG. See the comment above the
+ previous use of 'css'. */
rsvg_handle_set_stylesheet (rsvg_handle, (guint8 *)css, strlen (css), NULL);
#endif
#else
@@ -11913,7 +12575,7 @@ The list of capabilities can include one or more of the following:
{
#ifdef HAVE_NATIVE_TRANSFORMS
# if defined HAVE_IMAGEMAGICK || defined (USE_CAIRO) || defined (HAVE_NS) \
- || defined (HAVE_HAIKU)
+ || defined (HAVE_HAIKU) | defined HAVE_ANDROID
return list2 (Qscale, Qrotate90);
# elif defined (HAVE_X_WINDOWS) && defined (HAVE_XRENDER)
if (FRAME_DISPLAY_INFO (f)->xrender_supported_p)
@@ -12024,7 +12686,8 @@ static struct image_type const image_types[] =
{ SYMBOL_INDEX (Qjpeg), jpeg_image_p, jpeg_load, image_clear_image,
IMAGE_TYPE_INIT (init_jpeg_functions) },
#endif
-#if defined HAVE_XPM || defined HAVE_NS || defined HAVE_HAIKU || defined HAVE_PGTK
+#if defined HAVE_XPM || defined HAVE_NS || defined HAVE_HAIKU \
+ || defined HAVE_PGTK || defined HAVE_ANDROID
{ SYMBOL_INDEX (Qxpm), xpm_image_p, xpm_load, image_clear_image,
IMAGE_TYPE_INIT (init_xpm_functions) },
#endif
@@ -12186,7 +12849,8 @@ non-numeric, there is no explicit limit on the size of images. */);
add_image_type (Qxbm);
#if defined (HAVE_XPM) || defined (HAVE_NS) \
- || defined (HAVE_HAIKU) || defined (HAVE_PGTK)
+ || defined (HAVE_HAIKU) || defined (HAVE_PGTK) \
+ || defined (HAVE_ANDROID)
DEFSYM (Qxpm, "xpm");
add_image_type (Qxpm);
#endif
@@ -12211,8 +12875,10 @@ non-numeric, there is no explicit limit on the size of images. */);
add_image_type (Qpng);
#endif
-#if defined (HAVE_WEBP) || (defined (HAVE_NATIVE_IMAGE_API) \
- && defined (HAVE_HAIKU))
+#if defined (HAVE_WEBP) \
+ || (defined (HAVE_NATIVE_IMAGE_API) \
+ && ((defined (HAVE_NS) && defined (NS_IMPL_COCOA)) \
+ || defined (HAVE_HAIKU)))
DEFSYM (Qwebp, "webp");
DEFSYM (Qwebpdemux, "webpdemux");
add_image_type (Qwebp);
diff --git a/src/indent.c b/src/indent.c
index 8c6d689ccfa..3094a9d3089 100644
--- a/src/indent.c
+++ b/src/indent.c
@@ -616,7 +616,7 @@ scan_for_column (ptrdiff_t *endpos, EMACS_INT *goalcol,
memset (&cmp_it, 0, sizeof cmp_it);
cmp_it.id = -1;
- composition_compute_stop_pos (&cmp_it, scan, scan_byte, end, Qnil);
+ composition_compute_stop_pos (&cmp_it, scan, scan_byte, end, Qnil, true);
/* Scan forward to the target position. */
while (scan < end)
@@ -681,7 +681,7 @@ scan_for_column (ptrdiff_t *endpos, EMACS_INT *goalcol,
{
cmp_it.id = -1;
composition_compute_stop_pos (&cmp_it, scan, scan_byte, end,
- Qnil);
+ Qnil, true);
}
else
cmp_it.from = cmp_it.to;
@@ -1290,7 +1290,7 @@ compute_motion (ptrdiff_t from, ptrdiff_t frombyte, EMACS_INT fromvpos,
prev_tab_offset = tab_offset;
memset (&cmp_it, 0, sizeof cmp_it);
cmp_it.id = -1;
- composition_compute_stop_pos (&cmp_it, pos, pos_byte, to, Qnil);
+ composition_compute_stop_pos (&cmp_it, pos, pos_byte, to, Qnil, true);
unsigned short int quit_count = 0;
@@ -1600,7 +1600,7 @@ compute_motion (ptrdiff_t from, ptrdiff_t frombyte, EMACS_INT fromvpos,
{
cmp_it.id = -1;
composition_compute_stop_pos (&cmp_it, pos, pos_byte, to,
- Qnil);
+ Qnil, true);
}
else
cmp_it.from = cmp_it.to;
@@ -2031,7 +2031,7 @@ vmotion (ptrdiff_t from, ptrdiff_t from_byte,
}
/* Return the width taken by line-number display in window W. */
-static void
+void
line_number_display_width (struct window *w, int *width, int *pixel_width)
{
if (NILP (Vdisplay_line_numbers))
@@ -2101,7 +2101,7 @@ numbers on display. */)
{
int width, pixel_width;
struct window *w = XWINDOW (selected_window);
- line_number_display_width (XWINDOW (selected_window), &width, &pixel_width);
+ line_number_display_width (w, &width, &pixel_width);
if (EQ (pixelwise, Qcolumns))
{
struct frame *f = XFRAME (w->frame);
diff --git a/src/inotify.c b/src/inotify.c
index bba9ce19c22..7140568f1b6 100644
--- a/src/inotify.c
+++ b/src/inotify.c
@@ -26,6 +26,8 @@ along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. */
#include "termhooks.h"
#include <errno.h>
+#include <fcntl.h>
+
#include <sys/inotify.h>
#include <sys/ioctl.h>
@@ -40,6 +42,10 @@ along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. */
# define IN_ONLYDIR 0
#endif
+#ifdef HAVE_ANDROID
+#include "android.h" /* For `android_is_special_directory'. */
+#endif /* HAVE_ANDROID */
+
/* File handle for inotify. */
static int inotifyfd = -1;
@@ -144,6 +150,11 @@ symbol_to_inotifymask (Lisp_Object symb)
else if (EQ (symb, Qonlydir))
return IN_ONLYDIR;
+ else if (EQ (symb, Qignored))
+ return IN_IGNORED;
+ else if (EQ (symb, Qunmount))
+ return IN_UNMOUNT;
+
else if (EQ (symb, Qt) || EQ (symb, Qall_events))
return IN_ALL_EVENTS;
else
@@ -419,12 +430,21 @@ IN_ONESHOT */)
int wd = -1;
uint32_t imask = aspect_to_inotifymask (aspect);
uint32_t mask = imask | IN_MASK_ADD | IN_EXCL_UNLINK;
+ char *name;
CHECK_STRING (filename);
if (inotifyfd < 0)
{
+#ifdef HAVE_INOTIFY_INIT1
inotifyfd = inotify_init1 (IN_NONBLOCK | IN_CLOEXEC);
+#else /* !HAVE_INOTIFY_INIT1 */
+ /* This is prey to race conditions with other threads calling
+ exec. */
+ inotifyfd = inotify_init ();
+ fcntl (inotifyfd, F_SETFL, O_NONBLOCK);
+ fcntl (inotifyfd, F_SETFD, O_CLOEXEC);
+#endif /* HAVE_INOTIFY_INIT1 */
if (inotifyfd < 0)
report_file_notify_error ("File watching is not available", Qnil);
watch_list = Qnil;
@@ -432,7 +452,19 @@ IN_ONESHOT */)
}
encoded_file_name = ENCODE_FILE (filename);
- wd = inotify_add_watch (inotifyfd, SSDATA (encoded_file_name), mask);
+ name = SSDATA (encoded_file_name);
+
+#if defined HAVE_ANDROID && !defined ANDROID_STUBIFY
+ /* If FILENAME actually lies in a special directory, return now
+ instead of letting inotify fail. These directories cannot
+ receive file notifications as they are read only. */
+
+ if (android_is_special_directory (name, "/assets")
+ || android_is_special_directory (name, "/content"))
+ return Qnil;
+#endif /* defined HAVE_ANDROID && !defined ANDROID_STUBIFY */
+
+ wd = inotify_add_watch (inotifyfd, name, mask);
if (wd < 0)
report_file_notify_error ("Could not add watch for file", filename);
@@ -495,12 +527,14 @@ it invalid. */)
#ifdef INOTIFY_DEBUG
DEFUN ("inotify-watch-list", Finotify_watch_list, Sinotify_watch_list, 0, 0, 0,
doc: /* Return a copy of the internal watch_list. */)
+ (void)
{
return Fcopy_sequence (watch_list);
}
DEFUN ("inotify-allocated-p", Finotify_allocated_p, Sinotify_allocated_p, 0, 0, 0,
doc: /* Return non-nil, if an inotify instance is allocated. */)
+ (void)
{
return inotifyfd < 0 ? Qnil : Qt;
}
diff --git a/src/insdel.c b/src/insdel.c
index 773b2c85eb8..3809f8bc060 100644
--- a/src/insdel.c
+++ b/src/insdel.c
@@ -803,7 +803,7 @@ count_combining_before (const unsigned char *string, ptrdiff_t length,
while (!CHAR_HEAD_P (*p) && p < string + length)
p++;
- return (combining_bytes < p - string ? combining_bytes : p - string);
+ return min (combining_bytes, p - string);
}
/* See if the bytes after POS/POS_BYTE combine with bytes
@@ -865,7 +865,7 @@ count_combining_after (const unsigned char *string,
bufp++, pos_byte++;
while (!CHAR_HEAD_P (*bufp)) bufp++, pos_byte++;
- return (bytes <= pos_byte - opos_byte ? bytes : pos_byte - opos_byte);
+ return min (bytes, pos_byte - opos_byte);
}
#endif
@@ -1568,9 +1568,8 @@ replace_range (ptrdiff_t from, ptrdiff_t to, Lisp_Object new,
/* Relocate point as if it were a marker. */
if (from < PT)
- adjust_point ((from + inschars - (PT < to ? PT : to)),
- (from_byte + outgoing_insbytes
- - (PT_BYTE < to_byte ? PT_BYTE : to_byte)));
+ adjust_point ((from + inschars - min (PT, to)),
+ (from_byte + outgoing_insbytes - min (PT_BYTE, to_byte)));
check_markers ();
@@ -1715,6 +1714,44 @@ del_range (ptrdiff_t from, ptrdiff_t to)
del_range_1 (from, to, 1, 0);
}
+struct safe_del_range_context
+{
+ /* From and to positions. */
+ ptrdiff_t from, to;
+};
+
+static Lisp_Object
+safe_del_range_1 (void *ptr)
+{
+ struct safe_del_range_context *context;
+
+ context = ptr;
+ del_range (context->from, context->to);
+ return Qnil;
+}
+
+static Lisp_Object
+safe_del_range_2 (enum nonlocal_exit type, Lisp_Object value)
+{
+ return Qt;
+}
+
+/* Like del_range; however, catch all non-local exits. Value is 0 if
+ the buffer contents were really deleted. Otherwise, it is 1. */
+
+int
+safe_del_range (ptrdiff_t from, ptrdiff_t to)
+{
+ struct safe_del_range_context context;
+
+ context.from = from;
+ context.to = to;
+
+ return !NILP (internal_catch_all (safe_del_range_1,
+ &context,
+ safe_del_range_2));
+}
+
/* Like del_range; PREPARE says whether to call prepare_to_modify_buffer.
RET_STRING says to return the deleted text. */
@@ -1881,8 +1918,8 @@ del_range_2 (ptrdiff_t from, ptrdiff_t from_byte,
/* Relocate point as if it were a marker. */
if (from < PT)
- adjust_point (from - (PT < to ? PT : to),
- from_byte - (PT_BYTE < to_byte ? PT_BYTE : to_byte));
+ adjust_point (from - min (PT, to),
+ from_byte - min (PT_BYTE, to_byte));
offset_intervals (current_buffer, from, - nchars_del);
diff --git a/src/intervals.c b/src/intervals.c
index 1b1fb3b8181..2ab19c2cc56 100644
--- a/src/intervals.c
+++ b/src/intervals.c
@@ -256,7 +256,7 @@ traverse_intervals_noorder (INTERVAL tree, void (*function) (INTERVAL, void *),
void
traverse_intervals (INTERVAL tree, ptrdiff_t position,
- void (*function) (INTERVAL, Lisp_Object), Lisp_Object arg)
+ void (*function) (INTERVAL, void *), void *arg)
{
while (tree)
{
diff --git a/src/intervals.h b/src/intervals.h
index aa7502b4f68..610c803cc77 100644
--- a/src/intervals.h
+++ b/src/intervals.h
@@ -245,8 +245,8 @@ extern INTERVAL create_root_interval (Lisp_Object);
extern void copy_properties (INTERVAL, INTERVAL);
extern bool intervals_equal (INTERVAL, INTERVAL);
extern void traverse_intervals (INTERVAL, ptrdiff_t,
- void (*) (INTERVAL, Lisp_Object),
- Lisp_Object);
+ void (*) (INTERVAL, void *),
+ void *);
extern void traverse_intervals_noorder (INTERVAL,
void (*) (INTERVAL, void *), void *);
extern INTERVAL split_interval_right (INTERVAL, ptrdiff_t)
diff --git a/src/itree.c b/src/itree.c
index 7842c6b1842..da51b3c61fd 100644
--- a/src/itree.c
+++ b/src/itree.c
@@ -278,7 +278,7 @@ check_subtree (struct itree_node *node,
This runs in constant time when ENABLE_OVERLAY_CHECKING is 0
(i.e. Emacs is not configured with
- "--enable_checking=yes,overlays"). In this mode it can't check all
+ "--enable-checking=yes,overlays"). In this mode it can't check all
the invariants. When ENABLE_OVERLAY_CHECKING is 1 it checks the
entire tree and validates all invariants.
*/
@@ -817,14 +817,13 @@ itree_remove_fix (struct itree_tree *tree,
{
struct itree_node *other = parent->right;
- if (null_safe_is_red (other)) /* case 1.a */
+ if (other->red) /* case 1.a */
{
other->red = false;
parent->red = true;
itree_rotate_left (tree, parent);
other = parent->right;
}
- eassume (other != NULL);
if (null_safe_is_black (other->left) /* 2.a */
&& null_safe_is_black (other->right))
@@ -855,14 +854,13 @@ itree_remove_fix (struct itree_tree *tree,
{
struct itree_node *other = parent->left;
- if (null_safe_is_red (other)) /* 1.b */
+ if (other->red) /* 1.b */
{
other->red = false;
parent->red = true;
itree_rotate_right (tree, parent);
other = parent->left;
}
- eassume (other != NULL);
if (null_safe_is_black (other->right) /* 2.b */
&& null_safe_is_black (other->left))
@@ -1376,7 +1374,7 @@ itree_iterator_first_node (struct itree_tree *tree,
return node;
}
-/* Start a iterator enumerating all intervals in [BEGIN,END) in the
+/* Start an iterator enumerating all intervals in [BEGIN,END) in the
given ORDER. */
struct itree_iterator *
diff --git a/src/itree.h b/src/itree.h
index b055522a192..f54dbd7f07e 100644
--- a/src/itree.h
+++ b/src/itree.h
@@ -25,6 +25,8 @@ along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. */
#include "lisp.h"
+INLINE_HEADER_BEGIN
+
/* The tree and node structs are mainly here, so they can be
allocated.
@@ -114,6 +116,11 @@ extern void itree_node_set_region (struct itree_tree *, struct itree_node *,
ptrdiff_t, ptrdiff_t);
extern struct itree_tree *itree_create (void);
extern void itree_destroy (struct itree_tree *);
+INLINE bool
+itree_empty_p (struct itree_tree *tree)
+{
+ return !tree || !tree->root;
+}
extern intmax_t itree_size (struct itree_tree *);
extern void itree_clear (struct itree_tree *);
extern void itree_insert (struct itree_tree *, struct itree_node *,
@@ -178,4 +185,6 @@ struct itree_iterator
#define ITREE_FOREACH_NARROW(beg, end) \
itree_iterator_narrow (itree_iter_, beg, end)
+INLINE_HEADER_END
+
#endif
diff --git a/src/json.c b/src/json.c
index af5f30c7275..afc48c59d5a 100644
--- a/src/json.c
+++ b/src/json.c
@@ -23,6 +23,7 @@ along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. */
#include <stddef.h>
#include <stdint.h>
#include <stdlib.h>
+#include <math.h>
#include <jansson.h>
@@ -30,8 +31,6 @@ along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. */
#include "buffer.h"
#include "coding.h"
-#define JSON_HAS_ERROR_CODE (JANSSON_VERSION_HEX >= 0x020B00)
-
#ifdef WINDOWSNT
# include <windows.h>
# include "w32common.h"
@@ -56,23 +55,7 @@ DEF_DLL_FN (char *, json_dumps, (const json_t *json, size_t flags));
DEF_DLL_FN (int, json_dump_callback,
(const json_t *json, json_dump_callback_t callback, void *data,
size_t flags));
-DEF_DLL_FN (json_int_t, json_integer_value, (const json_t *integer));
-DEF_DLL_FN (double, json_real_value, (const json_t *real));
-DEF_DLL_FN (const char *, json_string_value, (const json_t *string));
-DEF_DLL_FN (size_t, json_string_length, (const json_t *string));
-DEF_DLL_FN (json_t *, json_array_get, (const json_t *array, size_t index));
DEF_DLL_FN (json_t *, json_object_get, (const json_t *object, const char *key));
-DEF_DLL_FN (size_t, json_object_size, (const json_t *object));
-DEF_DLL_FN (const char *, json_object_iter_key, (void *iter));
-DEF_DLL_FN (void *, json_object_iter, (json_t *object));
-DEF_DLL_FN (json_t *, json_object_iter_value, (void *iter));
-DEF_DLL_FN (void *, json_object_key_to_iter, (const char *key));
-DEF_DLL_FN (void *, json_object_iter_next, (json_t *object, void *iter));
-DEF_DLL_FN (json_t *, json_loads,
- (const char *input, size_t flags, json_error_t *error));
-DEF_DLL_FN (json_t *, json_load_callback,
- (json_load_callback_t callback, void *data, size_t flags,
- json_error_t *error));
/* This is called by json_decref, which is an inline function. */
void json_delete(json_t *json)
@@ -105,20 +88,7 @@ init_json_functions (void)
LOAD_DLL_FN (library, json_stringn);
LOAD_DLL_FN (library, json_dumps);
LOAD_DLL_FN (library, json_dump_callback);
- LOAD_DLL_FN (library, json_integer_value);
- LOAD_DLL_FN (library, json_real_value);
- LOAD_DLL_FN (library, json_string_value);
- LOAD_DLL_FN (library, json_string_length);
- LOAD_DLL_FN (library, json_array_get);
LOAD_DLL_FN (library, json_object_get);
- LOAD_DLL_FN (library, json_object_size);
- LOAD_DLL_FN (library, json_object_iter_key);
- LOAD_DLL_FN (library, json_object_iter);
- LOAD_DLL_FN (library, json_object_iter_value);
- LOAD_DLL_FN (library, json_object_key_to_iter);
- LOAD_DLL_FN (library, json_object_iter_next);
- LOAD_DLL_FN (library, json_loads);
- LOAD_DLL_FN (library, json_load_callback);
init_json ();
@@ -139,20 +109,7 @@ init_json_functions (void)
#define json_stringn fn_json_stringn
#define json_dumps fn_json_dumps
#define json_dump_callback fn_json_dump_callback
-#define json_integer_value fn_json_integer_value
-#define json_real_value fn_json_real_value
-#define json_string_value fn_json_string_value
-#define json_string_length fn_json_string_length
-#define json_array_get fn_json_array_get
#define json_object_get fn_json_object_get
-#define json_object_size fn_json_object_size
-#define json_object_iter_key fn_json_object_iter_key
-#define json_object_iter fn_json_object_iter
-#define json_object_iter_value fn_json_object_iter_value
-#define json_object_key_to_iter fn_json_object_key_to_iter
-#define json_object_iter_next fn_json_object_iter_next
-#define json_loads fn_json_loads
-#define json_load_callback fn_json_load_callback
#endif /* WINDOWSNT */
@@ -190,29 +147,6 @@ init_json (void)
json_set_alloc_funcs (json_malloc, json_free);
}
-#if !JSON_HAS_ERROR_CODE
-
-/* Return whether STRING starts with PREFIX. */
-
-static bool
-json_has_prefix (const char *string, const char *prefix)
-{
- return strncmp (string, prefix, strlen (prefix)) == 0;
-}
-
-/* Return whether STRING ends with SUFFIX. */
-
-static bool
-json_has_suffix (const char *string, const char *suffix)
-{
- size_t string_len = strlen (string);
- size_t suffix_len = strlen (suffix);
- return string_len >= suffix_len
- && memcmp (string + string_len - suffix_len, suffix, suffix_len) == 0;
-}
-
-#endif
-
/* Note that all callers of make_string_from_utf8 and build_string_from_utf8
below either pass only value UTF-8 strings or use the functionf for
formatting error messages; in the latter case correctness isn't
@@ -237,41 +171,6 @@ json_out_of_memory (void)
xsignal0 (Qjson_out_of_memory);
}
-/* Signal a Lisp error corresponding to the JSON ERROR. */
-
-static AVOID
-json_parse_error (const json_error_t *error)
-{
- Lisp_Object symbol;
-#if JSON_HAS_ERROR_CODE
- switch (json_error_code (error))
- {
- case json_error_premature_end_of_input:
- symbol = Qjson_end_of_file;
- break;
- case json_error_end_of_input_expected:
- symbol = Qjson_trailing_content;
- break;
- default:
- symbol = Qjson_parse_error;
- break;
- }
-#else
- if (json_has_suffix (error->text, "expected near end of file"))
- symbol = Qjson_end_of_file;
- else if (json_has_prefix (error->text, "end of file expected"))
- symbol = Qjson_trailing_content;
- else
- symbol = Qjson_parse_error;
-#endif
- xsignal (symbol,
- list5 (build_string_from_utf8 (error->text),
- build_string_from_utf8 (error->source),
- INT_TO_INTEGER (error->line),
- INT_TO_INTEGER (error->column),
- INT_TO_INTEGER (error->position)));
-}
-
static void
json_release_object (void *object)
{
@@ -361,33 +260,29 @@ lisp_to_json_nonscalar_1 (Lisp_Object lisp,
json = json_check (json_object ());
count = SPECPDL_INDEX ();
record_unwind_protect_ptr (json_release_object, json);
- for (ptrdiff_t i = 0; i < HASH_TABLE_SIZE (h); ++i)
+ DOHASH (h, key, v)
{
- Lisp_Object key = HASH_KEY (h, i);
- if (!BASE_EQ (key, Qunbound))
- {
- CHECK_STRING (key);
- Lisp_Object ekey = json_encode (key);
- /* We can't specify the length, so the string must be
- null-terminated. */
- check_string_without_embedded_nulls (ekey);
- const char *key_str = SSDATA (ekey);
- /* Reject duplicate keys. These are possible if the hash
- table test is not `equal'. */
- if (json_object_get (json, key_str) != NULL)
- wrong_type_argument (Qjson_value_p, lisp);
- int status
- = json_object_set_new (json, key_str,
- lisp_to_json (HASH_VALUE (h, i), conf));
- if (status == -1)
- {
- /* A failure can be caused either by an invalid key or
- by low memory. */
- json_check_utf8 (ekey);
- json_out_of_memory ();
- }
- }
- }
+ CHECK_STRING (key);
+ Lisp_Object ekey = json_encode (key);
+ /* We can't specify the length, so the string must be
+ null-terminated. */
+ check_string_without_embedded_nulls (ekey);
+ const char *key_str = SSDATA (ekey);
+ /* Reject duplicate keys. These are possible if the hash
+ table test is not `equal'. */
+ if (json_object_get (json, key_str) != NULL)
+ wrong_type_argument (Qjson_value_p, lisp);
+ int status
+ = json_object_set_new (json, key_str,
+ lisp_to_json (v, conf));
+ if (status == -1)
+ {
+ /* A failure can be caused either by an invalid key or
+ by low memory. */
+ json_check_utf8 (ekey);
+ json_out_of_memory ();
+ }
+ }
}
else if (NILP (lisp))
return json_check (json_object ());
@@ -798,144 +693,1087 @@ usage: (json-insert OBJECT &rest ARGS) */)
return unbind_to (count, Qnil);
}
-/* Convert a JSON object to a Lisp object. */
+#define JSON_PARSER_INTERNAL_OBJECT_WORKSPACE_SIZE 64
+#define JSON_PARSER_INTERNAL_BYTE_WORKSPACE_SIZE 512
+
+struct json_parser
+{
+ /* Because of a possible gap in the input (an emacs buffer can have
+ a gap), the input is described by [input_begin;input_end) and
+ [secondary_input_begin;secondary_input_end). If the input is
+ continuous, then secondary_input_begin and secondary_input_end
+ should be NULL */
+ const unsigned char *input_current;
+ const unsigned char *input_begin;
+ const unsigned char *input_end;
+
+ const unsigned char *secondary_input_begin;
+ const unsigned char *secondary_input_end;
+
+ ptrdiff_t current_line;
+ ptrdiff_t current_column;
+ ptrdiff_t point_of_current_line;
+
+ /* The parser has a maximum allowed depth. available_depth
+ decreases at each object/array begin. If reaches zero, then an
+ error is generated */
+ int available_depth;
+
+ struct json_configuration conf;
+
+ size_t additional_bytes_count;
+
+ /* Lisp_Objects are collected in this area during object/array
+ parsing. To avoid allocations, initially
+ internal_object_workspace is used. If it runs out of space then
+ we switch to allocated space. Important note: with this design,
+ GC must not run during JSON parsing, otherwise Lisp_Objects in
+ the workspace may get incorrectly collected. */
+ Lisp_Object internal_object_workspace
+ [JSON_PARSER_INTERNAL_OBJECT_WORKSPACE_SIZE];
+ Lisp_Object *object_workspace;
+ size_t object_workspace_size;
+ size_t object_workspace_current;
+
+ /* String and number parsing uses this workspace. The idea behind
+ internal_byte_workspace is the same as the idea behind
+ internal_object_workspace */
+ unsigned char
+ internal_byte_workspace[JSON_PARSER_INTERNAL_BYTE_WORKSPACE_SIZE];
+ unsigned char *byte_workspace;
+ unsigned char *byte_workspace_end;
+ unsigned char *byte_workspace_current;
+};
+
+static AVOID
+json_signal_error (struct json_parser *parser, Lisp_Object error)
+{
+ xsignal3 (error, INT_TO_INTEGER (parser->current_line),
+ INT_TO_INTEGER (parser->current_column),
+ INT_TO_INTEGER (parser->point_of_current_line
+ + parser->current_column));
+}
+
+static void
+json_parser_init (struct json_parser *parser,
+ struct json_configuration conf,
+ const unsigned char *input,
+ const unsigned char *input_end,
+ const unsigned char *secondary_input,
+ const unsigned char *secondary_input_end)
+{
+ if (secondary_input >= secondary_input_end)
+ {
+ secondary_input = NULL;
+ secondary_input_end = NULL;
+ }
+
+ if (input < input_end)
+ {
+ parser->input_begin = input;
+ parser->input_end = input_end;
+
+ parser->secondary_input_begin = secondary_input;
+ parser->secondary_input_end = secondary_input_end;
+ }
+ else
+ {
+ parser->input_begin = secondary_input;
+ parser->input_end = secondary_input_end;
+
+ parser->secondary_input_begin = NULL;
+ parser->secondary_input_end = NULL;
+ }
+
+ parser->input_current = parser->input_begin;
+
+ parser->current_line = 1;
+ parser->current_column = 0;
+ parser->point_of_current_line = 0;
+ parser->available_depth = 10000;
+ parser->conf = conf;
+
+ parser->additional_bytes_count = 0;
+
+ parser->object_workspace = parser->internal_object_workspace;
+ parser->object_workspace_size
+ = JSON_PARSER_INTERNAL_OBJECT_WORKSPACE_SIZE;
+ parser->object_workspace_current = 0;
+
+ parser->byte_workspace = parser->internal_byte_workspace;
+ parser->byte_workspace_end
+ = (parser->byte_workspace
+ + JSON_PARSER_INTERNAL_BYTE_WORKSPACE_SIZE);
+}
+
+static void
+json_parser_done (void *parser)
+{
+ struct json_parser *p = (struct json_parser *) parser;
+ if (p->object_workspace != p->internal_object_workspace)
+ xfree (p->object_workspace);
+ if (p->byte_workspace != p->internal_byte_workspace)
+ xfree (p->byte_workspace);
+}
+
+/* Makes sure that the object_workspace has 'size' available space for
+ Lisp_Objects */
+NO_INLINE static void
+json_make_object_workspace_for_slow_path (struct json_parser *parser,
+ size_t size)
+{
+ size_t needed_workspace_size
+ = (parser->object_workspace_current + size);
+ size_t new_workspace_size = parser->object_workspace_size;
+ while (new_workspace_size < needed_workspace_size)
+ {
+ if (ckd_mul (&new_workspace_size, new_workspace_size, 2))
+ {
+ json_signal_error (parser, Qjson_out_of_memory);
+ }
+ }
+
+ Lisp_Object *new_workspace_ptr;
+ if (parser->object_workspace_size
+ == JSON_PARSER_INTERNAL_OBJECT_WORKSPACE_SIZE)
+ {
+ new_workspace_ptr
+ = xnmalloc (new_workspace_size, sizeof (Lisp_Object));
+ memcpy (new_workspace_ptr, parser->object_workspace,
+ (sizeof (Lisp_Object)
+ * parser->object_workspace_current));
+ }
+ else
+ {
+ new_workspace_ptr
+ = xnrealloc (parser->object_workspace, new_workspace_size,
+ sizeof (Lisp_Object));
+ }
+
+ parser->object_workspace = new_workspace_ptr;
+ parser->object_workspace_size = new_workspace_size;
+}
+
+INLINE void
+json_make_object_workspace_for (struct json_parser *parser,
+ size_t size)
+{
+ if (parser->object_workspace_size - parser->object_workspace_current
+ < size)
+ {
+ json_make_object_workspace_for_slow_path (parser, size);
+ }
+}
+
+static void
+json_byte_workspace_reset (struct json_parser *parser)
+{
+ parser->byte_workspace_current = parser->byte_workspace;
+}
+
+/* Puts 'value' into the byte_workspace. If there is no space
+ available, it allocates space */
+NO_INLINE static void
+json_byte_workspace_put_slow_path (struct json_parser *parser,
+ unsigned char value)
+{
+ size_t new_workspace_size
+ = parser->byte_workspace_end - parser->byte_workspace;
+ if (ckd_mul (&new_workspace_size, new_workspace_size, 2))
+ {
+ json_signal_error (parser, Qjson_out_of_memory);
+ }
+
+ size_t offset
+ = parser->byte_workspace_current - parser->byte_workspace;
+
+ if (parser->byte_workspace == parser->internal_byte_workspace)
+ {
+ parser->byte_workspace = xmalloc (new_workspace_size);
+ memcpy (parser->byte_workspace, parser->internal_byte_workspace,
+ offset);
+ }
+ else
+ {
+ parser->byte_workspace
+ = xrealloc (parser->byte_workspace, new_workspace_size);
+ }
+ parser->byte_workspace_end
+ = parser->byte_workspace + new_workspace_size;
+ parser->byte_workspace_current = parser->byte_workspace + offset;
+ *parser->byte_workspace_current++ = value;
+}
+
+INLINE void
+json_byte_workspace_put (struct json_parser *parser,
+ unsigned char value)
+{
+ if (parser->byte_workspace_current < parser->byte_workspace_end)
+ {
+ *parser->byte_workspace_current++ = value;
+ }
+ else
+ {
+ json_byte_workspace_put_slow_path (parser, value);
+ }
+}
+
+static bool
+json_input_at_eof (struct json_parser *parser)
+{
+ if (parser->input_current < parser->input_end)
+ return false;
+ return parser->secondary_input_end == NULL;
+}
+
+/* If there is a secondary buffer, this switches to it */
+static int
+json_input_switch_to_secondary (struct json_parser *parser)
+{
+ if (parser->secondary_input_begin < parser->secondary_input_end)
+ {
+ parser->additional_bytes_count
+ = parser->input_end - parser->input_begin;
+ parser->input_begin = parser->secondary_input_begin;
+ parser->input_end = parser->secondary_input_end;
+ parser->input_current = parser->secondary_input_begin;
+ parser->secondary_input_begin = NULL;
+ parser->secondary_input_end = NULL;
+ return 0;
+ }
+ else
+ return -1;
+}
+
+/* Reads a byte from the JSON input stream */
+NO_INLINE static unsigned char
+json_input_get_slow_path (struct json_parser *parser)
+{
+ if (json_input_switch_to_secondary (parser) < 0)
+ json_signal_error (parser, Qjson_end_of_file);
+ return *parser->input_current++;
+}
+
+static unsigned char
+json_input_get (struct json_parser *parser)
+{
+ if (parser->input_current < parser->input_end)
+ return *parser->input_current++;
+ return json_input_get_slow_path (parser);
+}
+
+/* Reads a byte from the JSON input stream, if the stream is not at
+ * eof. At eof, returns -1 */
+static int
+json_input_get_if_possible (struct json_parser *parser)
+{
+ if (parser->input_current >= parser->input_end
+ && json_input_switch_to_secondary (parser) < 0)
+ return -1;
+ return *parser->input_current++;
+}
+
+/* Puts back the last read input byte. Only one byte can be put back,
+ because otherwise this code would need to handle switching from
+ the secondary buffer to the initial */
+static void
+json_input_put_back (struct json_parser *parser)
+{
+ parser->input_current--;
+}
+
+static bool
+json_skip_whitespace_internal (struct json_parser *parser, int c)
+{
+ parser->current_column++;
+ if (c == 0x20 || c == 0x09 || c == 0x0d)
+ return false;
+ else if (c == 0x0a)
+ {
+ parser->current_line++;
+ parser->point_of_current_line += parser->current_column;
+ parser->current_column = 0;
+ return false;
+ }
+ else
+ return true;
+}
+
+/* Skips JSON whitespace, and returns with the first non-whitespace
+ * character */
+static int
+json_skip_whitespace (struct json_parser *parser)
+{
+ for (;;)
+ {
+ int c = json_input_get (parser);
+ if (json_skip_whitespace_internal (parser, c))
+ return c;
+ }
+}
+
+/* Skips JSON whitespace, and returns with the first non-whitespace
+ * character, if possible. If there is no non-whitespace character
+ * (because we reached the end), it returns -1 */
+static int
+json_skip_whitespace_if_possible (struct json_parser *parser)
+{
+ for (;;)
+ {
+ int c = json_input_get_if_possible (parser);
+ if (c < 0)
+ return c;
+ if (json_skip_whitespace_internal (parser, c))
+ return c;
+ }
+}
-static Lisp_Object ARG_NONNULL ((1))
-json_to_lisp (json_t *json, const struct json_configuration *conf)
+static int
+json_hex_value (int c)
+{
+ if (c >= '0' && c <= '9')
+ return c - '0';
+ else if (c >= 'A' && c <= 'F')
+ return c - 'A' + 10;
+ else if (c >= 'a' && c <= 'f')
+ return c - 'a' + 10;
+ else
+ return -1;
+}
+
+/* Parses the CCCC part of the unicode escape sequence \uCCCC */
+static int
+json_parse_unicode (struct json_parser *parser)
{
- switch (json_typeof (json))
+ unsigned char v[4];
+ for (int i = 0; i < 4; i++)
{
- case JSON_NULL:
- return conf->null_object;
- case JSON_FALSE:
- return conf->false_object;
- case JSON_TRUE:
- return Qt;
- case JSON_INTEGER:
+ int c = json_hex_value (json_input_get (parser));
+ parser->current_column++;
+ if (c < 0)
+ json_signal_error (parser, Qjson_escape_sequence_error);
+ v[i] = c;
+ }
+
+ return v[0] << 12 | v[1] << 8 | v[2] << 4 | v[3];
+}
+
+/* Parses an utf-8 code-point encoding (except the first byte), and
+ returns the numeric value of the code-point (without considering
+ the first byte) */
+static int
+json_handle_utf8_tail_bytes (struct json_parser *parser, int n)
+{
+ int v = 0;
+ for (int i = 0; i < n; i++)
+ {
+ int c = json_input_get (parser);
+ json_byte_workspace_put (parser, c);
+ if ((c & 0xc0) != 0x80)
+ json_signal_error (parser, Qjson_utf8_decode_error);
+ v = (v << 6) | (c & 0x3f);
+ }
+ return v;
+}
+
+/* Reads a JSON string, and puts the result into the byte workspace */
+static void
+json_parse_string (struct json_parser *parser)
+{
+ /* a single_uninteresting byte can be simply copied from the input
+ to output, it doesn't need any extra care. This means all the
+ characters between [0x20;0x7f], except the double quote and
+ the backslash */
+ static const char is_single_uninteresting[256] = {
+ /* 0 1 2 3 4 5 6 7 8 9 a b c d e f */
+ /* 0 */ 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
+ /* 1 */ 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
+ /* 2 */ 1, 1, 0, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1,
+ /* 3 */ 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1,
+ /* 4 */ 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1,
+ /* 5 */ 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 0, 1, 1, 1,
+ /* 6 */ 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1,
+ /* 7 */ 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1,
+ /* 8 */ 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
+ /* 9 */ 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
+ /* a */ 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
+ /* b */ 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
+ /* c */ 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
+ /* d */ 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
+ /* e */ 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
+ /* f */ 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
+ };
+
+ for (;;)
+ {
+ /* This if is only here for a possible speedup. If there are 4
+ bytes available, and all of them are single_uninteresting,
+ then we can just copy these 4 bytes to output */
+ if (parser->input_end - parser->input_current >= 4)
+ {
+ int c0 = parser->input_current[0];
+ int c1 = parser->input_current[1];
+ int c2 = parser->input_current[2];
+ int c3 = parser->input_current[3];
+ bool v0 = is_single_uninteresting[c0];
+ bool v1 = is_single_uninteresting[c1];
+ bool v2 = is_single_uninteresting[c2];
+ bool v3 = is_single_uninteresting[c3];
+ if (v0 && v1 && v2 && v3)
+ {
+ json_byte_workspace_put (parser, c0);
+ json_byte_workspace_put (parser, c1);
+ json_byte_workspace_put (parser, c2);
+ json_byte_workspace_put (parser, c3);
+ parser->input_current += 4;
+ parser->current_column += 4;
+ continue;
+ }
+ }
+
+ int c = json_input_get (parser);
+ parser->current_column++;
+ if (is_single_uninteresting[c])
+ {
+ json_byte_workspace_put (parser, c);
+ continue;
+ }
+
+ if (c == '"')
+ return;
+ else if (c & 0x80)
+ {
+ /* Handle utf-8 encoding */
+ json_byte_workspace_put (parser, c);
+ if (c < 0xc0)
+ json_signal_error (parser, Qjson_utf8_decode_error);
+ else if (c < 0xe0)
+ {
+ int n = ((c & 0x1f) << 6
+ | json_handle_utf8_tail_bytes (parser, 1));
+ if (n < 0x80)
+ json_signal_error (parser, Qjson_utf8_decode_error);
+ }
+ else if (c < 0xf0)
+ {
+ int n = ((c & 0xf) << 12
+ | json_handle_utf8_tail_bytes (parser, 2));
+ if (n < 0x800 || (n >= 0xd800 && n < 0xe000))
+ json_signal_error (parser, Qjson_utf8_decode_error);
+ }
+ else if (c < 0xf8)
+ {
+ int n = ((c & 0x7) << 18
+ | json_handle_utf8_tail_bytes (parser, 3));
+ if (n < 0x10000 || n > 0x10ffff)
+ json_signal_error (parser, Qjson_utf8_decode_error);
+ }
+ else
+ json_signal_error (parser, Qjson_utf8_decode_error);
+ }
+ else if (c == '\\')
+ {
+ /* Handle escape sequences */
+ c = json_input_get (parser);
+ parser->current_column++;
+ if (c == '"')
+ json_byte_workspace_put (parser, '"');
+ else if (c == '\\')
+ json_byte_workspace_put (parser, '\\');
+ else if (c == '/')
+ json_byte_workspace_put (parser, '/');
+ else if (c == 'b')
+ json_byte_workspace_put (parser, '\b');
+ else if (c == 'f')
+ json_byte_workspace_put (parser, '\f');
+ else if (c == 'n')
+ json_byte_workspace_put (parser, '\n');
+ else if (c == 'r')
+ json_byte_workspace_put (parser, '\r');
+ else if (c == 't')
+ json_byte_workspace_put (parser, '\t');
+ else if (c == 'u')
+ {
+ int num = json_parse_unicode (parser);
+ /* is the first half of the surrogate pair */
+ if (num >= 0xd800 && num < 0xdc00)
+ {
+ parser->current_column++;
+ if (json_input_get (parser) != '\\')
+ json_signal_error (parser,
+ Qjson_invalid_surrogate_error);
+ parser->current_column++;
+ if (json_input_get (parser) != 'u')
+ json_signal_error (parser,
+ Qjson_invalid_surrogate_error);
+ int num2 = json_parse_unicode (parser);
+ if (num2 < 0xdc00 || num2 >= 0xe000)
+ json_signal_error (parser,
+ Qjson_invalid_surrogate_error);
+ num = (0x10000
+ + ((num - 0xd800) << 10 | (num2 - 0xdc00)));
+ }
+ else if (num >= 0xdc00 && num < 0xe000)
+ /* is the second half of the surrogate pair without
+ the first half */
+ json_signal_error (parser,
+ Qjson_invalid_surrogate_error);
+
+ /* utf-8 encode the code-point */
+ if (num < 0x80)
+ json_byte_workspace_put (parser, num);
+ else if (num < 0x800)
+ {
+ json_byte_workspace_put (parser, 0xc0 | num >> 6);
+ json_byte_workspace_put (parser,
+ 0x80 | (num & 0x3f));
+ }
+ else if (num < 0x10000)
+ {
+ json_byte_workspace_put (parser, 0xe0 | num >> 12);
+ json_byte_workspace_put (parser,
+ (0x80
+ | ((num >> 6) & 0x3f)));
+ json_byte_workspace_put (parser,
+ 0x80 | (num & 0x3f));
+ }
+ else
+ {
+ json_byte_workspace_put (parser, 0xf0 | num >> 18);
+ json_byte_workspace_put (parser,
+ (0x80
+ | ((num >> 12) & 0x3f)));
+ json_byte_workspace_put (parser,
+ (0x80
+ | ((num >> 6) & 0x3f)));
+ json_byte_workspace_put (parser,
+ 0x80 | (num & 0x3f));
+ }
+ }
+ else
+ json_signal_error (parser, Qjson_escape_sequence_error);
+ }
+ else
+ json_signal_error (parser, Qjson_parse_error);
+ }
+}
+
+/* If there was no integer overflow during parsing the integer, this
+ puts 'value' to the output. Otherwise this calls string_to_number
+ to parse integer on the byte workspace. This could just always
+ call string_to_number, but for performance reasons, during parsing
+ the code tries to calculate the value, so in most cases, we can
+ save call of string_to_number */
+static Lisp_Object
+json_create_integer (struct json_parser *parser,
+ bool integer_overflow, bool negative,
+ EMACS_UINT value)
+{
+ if (!integer_overflow)
+ {
+ if (negative)
+ {
+ uintmax_t v = value;
+ if (v <= (uintmax_t) INTMAX_MAX + 1)
+ return INT_TO_INTEGER ((intmax_t) -v);
+ }
+ else
+ return INT_TO_INTEGER (value);
+ }
+
+ json_byte_workspace_put (parser, 0);
+ ptrdiff_t len;
+ Lisp_Object result
+ = string_to_number ((const char *) parser->byte_workspace, 10,
+ &len);
+ if (len
+ != parser->byte_workspace_current - parser->byte_workspace - 1)
+ json_signal_error (parser, Qjson_error);
+ return result;
+}
+
+/* Parses a float using the byte workspace */
+static Lisp_Object
+json_create_float (struct json_parser *parser)
+{
+ json_byte_workspace_put (parser, 0);
+ errno = 0;
+ char *e;
+ double value = strtod ((const char *) parser->byte_workspace, &e);
+ bool out_of_range
+ = (errno != 0 && (value == HUGE_VAL || value == -HUGE_VAL));
+ if (out_of_range)
+ json_signal_error (parser, Qjson_number_out_of_range);
+ else if ((const unsigned char *) e
+ != parser->byte_workspace_current - 1)
+ json_signal_error (parser, Qjson_error);
+ else
+ return make_float (value);
+}
+
+/* Parses a number. The first character is the input parameter 'c'.
+ */
+static Lisp_Object
+json_parse_number (struct json_parser *parser, int c)
+{
+ json_byte_workspace_reset (parser);
+ json_byte_workspace_put (parser, c);
+
+ bool negative = false;
+ if (c == '-')
+ {
+ negative = true;
+ c = json_input_get (parser);
+ json_byte_workspace_put (parser, c);
+ parser->current_column++;
+ }
+ if (c < '0' || c > '9')
+ json_signal_error (parser, Qjson_parse_error);
+
+ /* The idea is that during finding the last character of the
+ number, the for loop below also tries to calculate the value. If
+ the parsed number is an integer which fits into unsigned long,
+ then the parser can use the value of 'integer' right away,
+ instead of having to re-parse the byte workspace later.
+ Ideally, this integer should have the same size as a CPU general
+ purpose register. */
+ EMACS_UINT integer = c - '0';
+ bool integer_overflow = false;
+
+ if (integer == 0)
+ {
+ if (json_input_at_eof (parser))
+ return INT_TO_INTEGER (0);
+ c = json_input_get (parser);
+ }
+ else
+ {
+ for (;;)
+ {
+ if (json_input_at_eof (parser))
+ return json_create_integer (parser, integer_overflow,
+ negative, integer);
+ c = json_input_get (parser);
+ if (c < '0' || c > '9')
+ break;
+ json_byte_workspace_put (parser, c);
+ parser->current_column++;
+
+ integer_overflow |= ckd_mul (&integer, integer, 10);
+ integer_overflow |= ckd_add (&integer, integer, c - '0');
+ }
+ }
+
+ bool is_float = false;
+ if (c == '.')
+ {
+ json_byte_workspace_put (parser, c);
+ parser->current_column++;
+
+ is_float = true;
+ c = json_input_get (parser);
+ json_byte_workspace_put (parser, c);
+ parser->current_column++;
+ if (c < '0' || c > '9')
+ json_signal_error (parser, Qjson_parse_error);
+ for (;;)
+ {
+ if (json_input_at_eof (parser))
+ return json_create_float (parser);
+ c = json_input_get (parser);
+ if (c < '0' || c > '9')
+ break;
+ json_byte_workspace_put (parser, c);
+ parser->current_column++;
+ }
+ }
+ if (c == 'e' || c == 'E')
+ {
+ json_byte_workspace_put (parser, c);
+ parser->current_column++;
+
+ is_float = true;
+ c = json_input_get (parser);
+ json_byte_workspace_put (parser, c);
+ parser->current_column++;
+ if (c == '-' || c == '+')
+ {
+ c = json_input_get (parser);
+ json_byte_workspace_put (parser, c);
+ parser->current_column++;
+ }
+ if (c < '0' || c > '9')
+ json_signal_error (parser, Qjson_parse_error);
+ for (;;)
+ {
+ if (json_input_at_eof (parser))
+ return json_create_float (parser);
+ c = json_input_get (parser);
+ if (c < '0' || c > '9')
+ break;
+ json_byte_workspace_put (parser, c);
+ parser->current_column++;
+ }
+ }
+
+ /* 'c' contains a character which is not part of the number,
+ so it is need to be put back */
+ json_input_put_back (parser);
+
+ if (is_float)
+ return json_create_float (parser);
+ else
+ return json_create_integer (parser, integer_overflow, negative,
+ integer);
+}
+
+static Lisp_Object json_parse_value (struct json_parser *parser,
+ int c);
+
+/* Parses a JSON array. */
+static Lisp_Object
+json_parse_array (struct json_parser *parser)
+{
+ int c = json_skip_whitespace (parser);
+
+ const size_t first = parser->object_workspace_current;
+ Lisp_Object result = Qnil;
+
+ if (c != ']')
+ {
+ parser->available_depth--;
+ if (parser->available_depth < 0)
+ json_signal_error (parser, Qjson_object_too_deep);
+
+ size_t number_of_elements = 0;
+ Lisp_Object *cdr = &result;
+ /* This loop collects the array elements in the object workspace
+ */
+ for (;;)
+ {
+ Lisp_Object element = json_parse_value (parser, c);
+ switch (parser->conf.array_type)
+ {
+ case json_array_array:
+ json_make_object_workspace_for (parser, 1);
+ parser->object_workspace[parser->object_workspace_current]
+ = element;
+ parser->object_workspace_current++;
+ break;
+ case json_array_list:
+ {
+ Lisp_Object nc = Fcons (element, Qnil);
+ *cdr = nc;
+ cdr = xcdr_addr (nc);
+ break;
+ }
+ default:
+ emacs_abort ();
+ }
+
+ c = json_skip_whitespace (parser);
+
+ number_of_elements++;
+ if (c == ']')
+ {
+ parser->available_depth++;
+ break;
+ }
+
+ if (c != ',')
+ json_signal_error (parser, Qjson_parse_error);
+
+ c = json_skip_whitespace (parser);
+ }
+ }
+
+ switch (parser->conf.array_type)
+ {
+ case json_array_array:
{
- json_int_t i = json_integer_value (json);
- return INT_TO_INTEGER (i);
+ size_t number_of_elements
+ = parser->object_workspace_current - first;
+ result = make_vector (number_of_elements, Qnil);
+ for (size_t i = 0; i < number_of_elements; i++)
+ {
+ rarely_quit (i);
+ ASET (result, i, parser->object_workspace[first + i]);
+ }
+ parser->object_workspace_current = first;
+ break;
}
- case JSON_REAL:
- return make_float (json_real_value (json));
- case JSON_STRING:
- return make_string_from_utf8 (json_string_value (json),
- json_string_length (json));
- case JSON_ARRAY:
+ case json_array_list:
+ break;
+ default:
+ emacs_abort ();
+ }
+
+ return result;
+}
+
+/* Parses the ": value" part of a JSON object member. */
+static Lisp_Object
+json_parse_object_member_value (struct json_parser *parser)
+{
+ int c = json_skip_whitespace (parser);
+ if (c != ':')
+ json_signal_error (parser, Qjson_parse_error);
+
+ c = json_skip_whitespace (parser);
+
+ return json_parse_value (parser, c);
+}
+
+/* Parses a JSON object. */
+static Lisp_Object
+json_parse_object (struct json_parser *parser)
+{
+ int c = json_skip_whitespace (parser);
+
+ const size_t first = parser->object_workspace_current;
+ Lisp_Object result = Qnil;
+
+ if (c != '}')
+ {
+ parser->available_depth--;
+ if (parser->available_depth < 0)
+ json_signal_error (parser, Qjson_object_too_deep);
+
+ Lisp_Object *cdr = &result;
+
+ /* This loop collects the object members (key/value pairs) in
+ * the object workspace */
+ for (;;)
+ {
+ if (c != '"')
+ json_signal_error (parser, Qjson_parse_error);
+
+ json_byte_workspace_reset (parser);
+ switch (parser->conf.object_type)
+ {
+ case json_object_hashtable:
+ {
+ json_parse_string (parser);
+ Lisp_Object key
+ = make_string_from_utf8 ((char *)
+ parser->byte_workspace,
+ (parser->byte_workspace_current
+ - parser->byte_workspace));
+ Lisp_Object value
+ = json_parse_object_member_value (parser);
+ json_make_object_workspace_for (parser, 2);
+ parser->object_workspace[parser->object_workspace_current]
+ = key;
+ parser->object_workspace_current++;
+ parser->object_workspace[parser->object_workspace_current]
+ = value;
+ parser->object_workspace_current++;
+ break;
+ }
+ case json_object_alist:
+ {
+ json_parse_string (parser);
+ Lisp_Object key
+ = Fintern (make_string_from_utf8 (
+ (char *) parser->byte_workspace,
+ (parser->byte_workspace_current
+ - parser->byte_workspace)),
+ Qnil);
+ Lisp_Object value
+ = json_parse_object_member_value (parser);
+ Lisp_Object nc = Fcons (Fcons (key, value), Qnil);
+ *cdr = nc;
+ cdr = xcdr_addr (nc);
+ break;
+ }
+ case json_object_plist:
+ {
+ json_byte_workspace_put (parser, ':');
+ json_parse_string (parser);
+ Lisp_Object key
+ = intern_1 ((char *) parser->byte_workspace,
+ (parser->byte_workspace_current
+ - parser->byte_workspace));
+ Lisp_Object value
+ = json_parse_object_member_value (parser);
+ Lisp_Object nc = Fcons (key, Qnil);
+ *cdr = nc;
+ cdr = xcdr_addr (nc);
+
+ nc = Fcons (value, Qnil);
+ *cdr = nc;
+ cdr = xcdr_addr (nc);
+ break;
+ }
+ default:
+ emacs_abort ();
+ }
+
+ c = json_skip_whitespace (parser);
+
+ if (c == '}')
+ {
+ parser->available_depth++;
+ break;
+ }
+
+ if (c != ',')
+ json_signal_error (parser, Qjson_parse_error);
+
+ c = json_skip_whitespace (parser);
+ }
+ }
+
+ switch (parser->conf.object_type)
+ {
+ case json_object_hashtable:
{
- if (++lisp_eval_depth > max_lisp_eval_depth)
- xsignal0 (Qjson_object_too_deep);
- size_t size = json_array_size (json);
- if (PTRDIFF_MAX < size)
- overflow_error ();
- Lisp_Object result;
- switch (conf->array_type)
- {
- case json_array_array:
- {
- result = make_vector (size, Qunbound);
- for (ptrdiff_t i = 0; i < size; ++i)
- {
- rarely_quit (i);
- ASET (result, i,
- json_to_lisp (json_array_get (json, i), conf));
- }
- break;
- }
- case json_array_list:
- {
- result = Qnil;
- for (ptrdiff_t i = size - 1; i >= 0; --i)
- {
- rarely_quit (i);
- result = Fcons (json_to_lisp (json_array_get (json, i), conf),
- result);
- }
- break;
- }
- default:
- /* Can't get here. */
- emacs_abort ();
- }
- --lisp_eval_depth;
- return result;
+ result
+ = CALLN (Fmake_hash_table, QCtest, Qequal, QCsize,
+ make_fixed_natnum (
+ (parser->object_workspace_current - first) / 2));
+ struct Lisp_Hash_Table *h = XHASH_TABLE (result);
+ for (size_t i = first; i < parser->object_workspace_current;
+ i += 2)
+ {
+ hash_hash_t hash;
+ Lisp_Object key = parser->object_workspace[i];
+ Lisp_Object value = parser->object_workspace[i + 1];
+ ptrdiff_t i = hash_lookup_get_hash (h, key, &hash);
+ if (i < 0)
+ hash_put (h, key, value, hash);
+ else
+ set_hash_value_slot (h, i, value);
+ }
+ parser->object_workspace_current = first;
+ break;
}
- case JSON_OBJECT:
+ case json_object_alist:
+ case json_object_plist:
+ break;
+ default:
+ emacs_abort ();
+ }
+
+ return result;
+}
+
+/* Token-char is not a JSON terminology. When parsing
+ null/false/true, this function tells the character set that is need
+ to be considered as part of a token. For example, if the input is
+ "truesomething", then the parser shouldn't consider it as "true",
+ and an additional later "something" token. An additional example:
+ if the input is "truetrue", then calling (json-parse-buffer) twice
+ shouldn't produce two successful calls which return t, but a
+ parsing error */
+static bool
+json_is_token_char (int c)
+{
+ return ((c >= 'A' && c <= 'Z') || (c >= 'a' && c <= 'z')
+ || (c >= '0' && c <= '9') || (c == '-'));
+}
+
+/* This is the entry point to the value parser, this parses a JSON
+ * value */
+Lisp_Object
+json_parse_value (struct json_parser *parser, int c)
+{
+ if (c == '{')
+ return json_parse_object (parser);
+ else if (c == '[')
+ return json_parse_array (parser);
+ else if (c == '"')
+ {
+ json_byte_workspace_reset (parser);
+ json_parse_string (parser);
+ Lisp_Object result
+ = make_string_from_utf8 ((const char *)
+ parser->byte_workspace,
+ (parser->byte_workspace_current
+ - parser->byte_workspace));
+ return result;
+ }
+ else if ((c >= '0' && c <= '9') || (c == '-'))
+ return json_parse_number (parser, c);
+ else
+ {
+ int c2 = json_input_get (parser);
+ int c3 = json_input_get (parser);
+ int c4 = json_input_get (parser);
+ int c5 = json_input_get_if_possible (parser);
+
+ if (c == 't' && c2 == 'r' && c3 == 'u' && c4 == 'e'
+ && (c5 < 0 || !json_is_token_char (c5)))
+ {
+ if (c5 >= 0)
+ json_input_put_back (parser);
+ parser->current_column += 3;
+ return Qt;
+ }
+ if (c == 'n' && c2 == 'u' && c3 == 'l' && c4 == 'l'
+ && (c5 < 0 || !json_is_token_char (c5)))
+ {
+ if (c5 >= 0)
+ json_input_put_back (parser);
+ parser->current_column += 3;
+ return parser->conf.null_object;
+ }
+ if (c == 'f' && c2 == 'a' && c3 == 'l' && c4 == 's'
+ && c5 == 'e')
+ {
+ int c6 = json_input_get_if_possible (parser);
+ if (c6 < 0 || !json_is_token_char (c6))
+ {
+ if (c6 >= 0)
+ json_input_put_back (parser);
+ parser->current_column += 4;
+ return parser->conf.false_object;
+ }
+ }
+
+ json_signal_error (parser, Qjson_parse_error);
+ }
+}
+
+enum ParseEndBehavior
+ {
+ PARSEENDBEHAVIOR_CheckForGarbage,
+ PARSEENDBEHAVIOR_MovePoint
+ };
+
+static Lisp_Object
+json_parse (struct json_parser *parser,
+ enum ParseEndBehavior parse_end_behavior)
+{
+ int c = json_skip_whitespace (parser);
+
+ Lisp_Object result = json_parse_value (parser, c);
+
+ switch (parse_end_behavior)
+ {
+ case PARSEENDBEHAVIOR_CheckForGarbage:
+ c = json_skip_whitespace_if_possible (parser);
+ if (c >= 0)
+ json_signal_error (parser, Qjson_trailing_content);
+ break;
+ case PARSEENDBEHAVIOR_MovePoint:
{
- if (++lisp_eval_depth > max_lisp_eval_depth)
- xsignal0 (Qjson_object_too_deep);
- Lisp_Object result;
- switch (conf->object_type)
- {
- case json_object_hashtable:
- {
- size_t size = json_object_size (json);
- if (FIXNUM_OVERFLOW_P (size))
- overflow_error ();
- result = CALLN (Fmake_hash_table, QCtest, Qequal, QCsize,
- make_fixed_natnum (size));
- struct Lisp_Hash_Table *h = XHASH_TABLE (result);
- const char *key_str;
- json_t *value;
- json_object_foreach (json, key_str, value)
- {
- Lisp_Object key = build_string_from_utf8 (key_str), hash;
- ptrdiff_t i = hash_lookup (h, key, &hash);
- /* Keys in JSON objects are unique, so the key can't
- be present yet. */
- eassert (i < 0);
- hash_put (h, key, json_to_lisp (value, conf), hash);
- }
- break;
- }
- case json_object_alist:
- {
- result = Qnil;
- const char *key_str;
- json_t *value;
- json_object_foreach (json, key_str, value)
- {
- Lisp_Object key
- = Fintern (build_string_from_utf8 (key_str), Qnil);
- result
- = Fcons (Fcons (key, json_to_lisp (value, conf)),
- result);
- }
- result = Fnreverse (result);
- break;
- }
- case json_object_plist:
- {
- result = Qnil;
- const char *key_str;
- json_t *value;
- json_object_foreach (json, key_str, value)
- {
- USE_SAFE_ALLOCA;
- ptrdiff_t key_str_len = strlen (key_str);
- char *keyword_key_str = SAFE_ALLOCA (1 + key_str_len + 1);
- keyword_key_str[0] = ':';
- strcpy (&keyword_key_str[1], key_str);
- Lisp_Object key = intern_1 (keyword_key_str, key_str_len + 1);
- /* Build the plist as value-key since we're going to
- reverse it in the end.*/
- result = Fcons (key, result);
- result = Fcons (json_to_lisp (value, conf), result);
- SAFE_FREE ();
- }
- result = Fnreverse (result);
- break;
- }
- default:
- /* Can't get here. */
- emacs_abort ();
- }
- --lisp_eval_depth;
- return result;
+ ptrdiff_t byte
+ = (PT_BYTE + parser->input_current - parser->input_begin
+ + parser->additional_bytes_count);
+ ptrdiff_t position;
+ if (NILP (BVAR (current_buffer, enable_multibyte_characters)))
+ position = byte;
+ else
+ position
+ = PT + parser->point_of_current_line + parser->current_column;
+
+ SET_PT_BOTH (position, byte);
+ break;
}
}
- /* Can't get here. */
- emacs_abort ();
+
+ return result;
}
DEFUN ("json-parse-string", Fjson_parse_string, Sjson_parse_string, 1, MANY,
@@ -953,7 +1791,9 @@ The arguments ARGS are a list of keyword/argument pairs:
The keyword argument `:object-type' specifies which Lisp type is used
to represent objects; it can be `hash-table', `alist' or `plist'. It
-defaults to `hash-table'.
+defaults to `hash-table'. If an object has members with the same
+key, `hash-table' keeps only the last value of such keys, while
+`alist' and `plist' keep all the members.
The keyword argument `:array-type' specifies which Lisp type is used
to represent arrays; it can be `array' (the default) or `list'.
@@ -964,62 +1804,27 @@ to represent a JSON null value. It defaults to `:null'.
The keyword argument `:false-object' specifies which object to use to
represent a JSON false value. It defaults to `:false'.
usage: (json-parse-string STRING &rest ARGS) */)
- (ptrdiff_t nargs, Lisp_Object *args)
+(ptrdiff_t nargs, Lisp_Object *args)
{
specpdl_ref count = SPECPDL_INDEX ();
-#ifdef WINDOWSNT
- ensure_json_available ();
-#endif
-
Lisp_Object string = args[0];
CHECK_STRING (string);
Lisp_Object encoded = json_encode (string);
- check_string_without_embedded_nulls (encoded);
- struct json_configuration conf =
- {json_object_hashtable, json_array_array, QCnull, QCfalse};
+ struct json_configuration conf
+ = { json_object_hashtable, json_array_array, QCnull, QCfalse };
json_parse_args (nargs - 1, args + 1, &conf, true);
- json_error_t error;
- json_t *object
- = json_loads (SSDATA (encoded), JSON_DECODE_ANY | JSON_ALLOW_NUL, &error);
- if (object == NULL)
- json_parse_error (&error);
-
- /* Avoid leaking the object in case of further errors. */
- if (object != NULL)
- record_unwind_protect_ptr (json_release_object, object);
+ struct json_parser p;
+ const unsigned char *begin
+ = (const unsigned char *) SSDATA (encoded);
+ json_parser_init (&p, conf, begin, begin + SBYTES (encoded), NULL,
+ NULL);
+ record_unwind_protect_ptr (json_parser_done, &p);
- return unbind_to (count, json_to_lisp (object, &conf));
-}
-
-struct json_read_buffer_data
-{
- /* Byte position of position to read the next chunk from. */
- ptrdiff_t point;
-};
-
-/* Callback for json_load_callback that reads from the current buffer.
- DATA must point to a structure of type json_read_buffer_data.
- data->point must point to the byte position to read from; after
- reading, data->point is advanced accordingly. The buffer point
- itself is ignored. This function may not exit nonlocally. */
-
-static size_t
-json_read_buffer_callback (void *buffer, size_t buflen, void *data)
-{
- struct json_read_buffer_data *d = data;
-
- /* First, parse from point to the gap or the end of the accessible
- portion, whatever is closer. */
- ptrdiff_t point = d->point;
- ptrdiff_t end = BUFFER_CEILING_OF (point) + 1;
- ptrdiff_t count = end - point;
- if (buflen < count)
- count = buflen;
- memcpy (buffer, BYTE_POS_ADDR (point), count);
- d->point += count;
- return count;
+ return unbind_to (count,
+ json_parse (&p,
+ PARSEENDBEHAVIOR_CheckForGarbage));
}
DEFUN ("json-parse-buffer", Fjson_parse_buffer, Sjson_parse_buffer,
@@ -1041,7 +1846,9 @@ The arguments ARGS are a list of keyword/argument pairs:
The keyword argument `:object-type' specifies which Lisp type is used
to represent objects; it can be `hash-table', `alist' or `plist'. It
-defaults to `hash-table'.
+defaults to `hash-table'. If an object has members with the same
+key, `hash-table' keeps only the last value of such keys, while
+`alist' and `plist' keep all the members.
The keyword argument `:array-type' specifies which Lisp type is used
to represent arrays; it can be `array' (the default) or `list'.
@@ -1052,42 +1859,33 @@ to represent a JSON null value. It defaults to `:null'.
The keyword argument `:false-object' specifies which object to use to
represent a JSON false value. It defaults to `:false'.
usage: (json-parse-buffer &rest args) */)
- (ptrdiff_t nargs, Lisp_Object *args)
+(ptrdiff_t nargs, Lisp_Object *args)
{
specpdl_ref count = SPECPDL_INDEX ();
-#ifdef WINDOWSNT
- ensure_json_available ();
-#endif
-
- struct json_configuration conf =
- {json_object_hashtable, json_array_array, QCnull, QCfalse};
+ struct json_configuration conf
+ = { json_object_hashtable, json_array_array, QCnull, QCfalse };
json_parse_args (nargs, args, &conf, true);
- ptrdiff_t point = PT_BYTE;
- struct json_read_buffer_data data = {.point = point};
- json_error_t error;
- json_t *object
- = json_load_callback (json_read_buffer_callback, &data,
- JSON_DECODE_ANY
- | JSON_DISABLE_EOF_CHECK
- | JSON_ALLOW_NUL,
- &error);
-
- if (object == NULL)
- json_parse_error (&error);
-
- /* Avoid leaking the object in case of further errors. */
- record_unwind_protect_ptr (json_release_object, object);
-
- /* Convert and then move point only if everything succeeded. */
- Lisp_Object lisp = json_to_lisp (object, &conf);
+ struct json_parser p;
+ unsigned char *begin = PT_ADDR;
+ unsigned char *end = GPT_ADDR;
+ unsigned char *secondary_begin = NULL;
+ unsigned char *secondary_end = NULL;
+ if (GPT_ADDR < Z_ADDR)
+ {
+ secondary_begin = GAP_END_ADDR;
+ if (secondary_begin < PT_ADDR)
+ secondary_begin = PT_ADDR;
+ secondary_end = Z_ADDR;
+ }
- /* Adjust point by how much we just read. */
- point += error.position;
- SET_PT_BOTH (BYTE_TO_CHAR (point), point);
+ json_parser_init (&p, conf, begin, end, secondary_begin,
+ secondary_end);
+ record_unwind_protect_ptr (json_parser_done, &p);
- return unbind_to (count, lisp);
+ return unbind_to (count,
+ json_parse (&p, PARSEENDBEHAVIOR_MovePoint));
}
void
@@ -1105,6 +1903,10 @@ syms_of_json (void)
DEFSYM (Qjson_end_of_file, "json-end-of-file");
DEFSYM (Qjson_trailing_content, "json-trailing-content");
DEFSYM (Qjson_object_too_deep, "json-object-too-deep");
+ DEFSYM (Qjson_utf8_decode_error, "json-utf8-decode-error")
+ DEFSYM (Qjson_invalid_surrogate_error, "json-invalid-surrogate-error")
+ DEFSYM (Qjson_number_out_of_range, "json-number-out-of-range-error")
+ DEFSYM (Qjson_escape_sequence_error, "json-escape-sequence-error")
DEFSYM (Qjson_unavailable, "json-unavailable");
define_error (Qjson_error, "generic JSON error", Qerror);
define_error (Qjson_out_of_memory,
@@ -1116,6 +1918,14 @@ syms_of_json (void)
Qjson_parse_error);
define_error (Qjson_object_too_deep,
"object cyclic or Lisp evaluation too deep", Qjson_error);
+ define_error (Qjson_utf8_decode_error,
+ "invalid utf-8 encoding", Qjson_error);
+ define_error (Qjson_invalid_surrogate_error,
+ "invalid surrogate pair", Qjson_error);
+ define_error (Qjson_number_out_of_range,
+ "number out of range", Qjson_error);
+ define_error (Qjson_escape_sequence_error,
+ "invalid escape sequence", Qjson_parse_error);
DEFSYM (Qpure, "pure");
DEFSYM (Qside_effect_free, "side-effect-free");
diff --git a/src/keyboard.c b/src/keyboard.c
index 4053f532b80..91faf4582fa 100644
--- a/src/keyboard.c
+++ b/src/keyboard.c
@@ -44,6 +44,15 @@ along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. */
#include "atimer.h"
#include "process.h"
#include "menu.h"
+
+#ifdef HAVE_TEXT_CONVERSION
+#include "textconv.h"
+#endif /* HAVE_TEXT_CONVERSION */
+
+#ifdef HAVE_ANDROID
+#include "android.h"
+#endif /* HAVE_ANDROID */
+
#include <errno.h>
#ifdef HAVE_PTHREAD
@@ -62,6 +71,10 @@ along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. */
#include "syssignal.h"
+#if defined HAVE_STACK_OVERFLOW_HANDLING && !defined WINDOWSNT
+#include <setjmp.h>
+#endif
+
#include <sys/types.h>
#include <unistd.h>
#include <fcntl.h>
@@ -102,6 +115,13 @@ static KBOARD *all_kboards;
/* True in the single-kboard state, false in the any-kboard state. */
static bool single_kboard;
+#ifdef HAVE_TEXT_CONVERSION
+
+/* True if a key sequence is currently being read. */
+bool reading_key_sequence;
+
+#endif /* HAVE_TEXT_CONVERSION */
+
/* Minimum allowed size of the recent_keys vector. */
#define MIN_NUM_RECENT_KEYS (100)
@@ -348,6 +368,10 @@ static struct timespec timer_last_idleness_start_time;
static Lisp_Object virtual_core_pointer_name;
static Lisp_Object virtual_core_keyboard_name;
+/* If not nil, ID of the last TOUCHSCREEN_END_EVENT to land on the
+ menu bar. */
+static Lisp_Object menu_bar_touch_id;
+
/* Global variable declarations. */
@@ -556,7 +580,10 @@ echo_dash (void)
idx = make_fixnum (SCHARS (KVAR (current_kboard, echo_string)) - 1);
last_char = Faref (KVAR (current_kboard, echo_string), idx);
- if (XFIXNUM (last_char) == '-' && XFIXNUM (prev_char) != ' ')
+ if ((XFIXNUM (last_char) == '-' && XFIXNUM (prev_char) != ' ')
+ /* Or a keystroke help message. */
+ || (echo_keystrokes_help
+ && XFIXNUM (last_char) == ')' && XFIXNUM (prev_char) == 'p'))
return;
}
@@ -565,6 +592,12 @@ echo_dash (void)
AUTO_STRING (dash, "-");
kset_echo_string (current_kboard,
concat2 (KVAR (current_kboard, echo_string), dash));
+
+ if (echo_keystrokes_help)
+ kset_echo_string (current_kboard,
+ calln (Qhelp__append_keystrokes_help,
+ KVAR (current_kboard, echo_string)));
+
echo_now ();
}
@@ -1002,7 +1035,7 @@ cmd_error_internal (Lisp_Object data, const char *context)
{
/* The immediate context is not interesting for Quits,
since they are asynchronous. */
- if (signal_quit_p (XCAR (data)))
+ if (signal_quit_p (data))
Vsignaling_function = Qnil;
Vquit_flag = Qnil;
@@ -1043,8 +1076,9 @@ Default value of `command-error-function'. */)
write to stderr and quit. In daemon mode, there are
many other potential errors that do not prevent frames
from being created, so continuing as normal is better in
- that case. */
- || (!IS_DAEMON && FRAME_INITIAL_P (sf))
+ that case, as long as the daemon has actually finished
+ initialization. */
+ || (!(IS_DAEMON && !DAEMON_RUNNING) && FRAME_INITIAL_P (sf))
|| noninteractive))
{
print_error_message (data, Qexternal_debugging_output,
@@ -1139,7 +1173,18 @@ command_loop_2 (Lisp_Object handlers)
static Lisp_Object
top_level_2 (void)
{
- return Feval (Vtop_level, Qnil);
+ /* If we're in batch mode, print a backtrace unconditionally when
+ encountering an error, to help with debugging. */
+ bool setup_handler = noninteractive;
+ if (setup_handler)
+ /* FIXME: Should we (re)use `list_of_error` from `xdisp.c`? */
+ push_handler_bind (list1 (Qerror), Qdebug_early__handler, 0);
+
+ Lisp_Object res = Feval (Vtop_level, Qt);
+
+ if (setup_handler)
+ pop_handler ();
+ return res;
}
static Lisp_Object
@@ -1270,7 +1315,7 @@ some_mouse_moved (void)
enum { READ_KEY_ELTS = 30 };
static int read_key_sequence (Lisp_Object *, Lisp_Object,
- bool, bool, bool, bool);
+ bool, bool, bool, bool, bool);
static void adjust_point_for_property (ptrdiff_t, bool);
static Lisp_Object
@@ -1331,7 +1376,6 @@ command_loop_1 (void)
display_malloc_warning ();
Vdeactivate_mark = Qnil;
- backtrace_yet = false;
/* Don't ignore mouse movements for more than a single command
loop. (This flag is set in xdisp.c whenever the tool bar is
@@ -1381,7 +1425,8 @@ command_loop_1 (void)
/* Read next key sequence; i gets its length. */
raw_keybuf_count = 0;
Lisp_Object keybuf[READ_KEY_ELTS];
- int i = read_key_sequence (keybuf, Qnil, false, true, true, false);
+ int i = read_key_sequence (keybuf, Qnil, false, true, true, false,
+ false);
/* A filter may have run while we were reading the input. */
if (! FRAME_LIVE_P (XFRAME (selected_frame)))
@@ -1436,6 +1481,7 @@ command_loop_1 (void)
prev_buffer = current_buffer;
prev_modiff = MODIFF;
last_point_position = PT;
+ ptrdiff_t last_pt = PT;
/* By default, we adjust point to a boundary of a region that
has such a property that should be treated intangible
@@ -1513,6 +1559,9 @@ command_loop_1 (void)
unbind_to (scount, Qnil);
#endif
}
+ /* Restore last PT position value, possibly clobbered by
+ recursive-edit invoked by the command we just executed. */
+ last_point_position = last_pt;
kset_last_prefix_arg (current_kboard, Vcurrent_prefix_arg);
safe_run_hooks_maybe_narrowed (Qpost_command_hook,
@@ -1572,7 +1621,7 @@ command_loop_1 (void)
if ((!NILP (Fwindow_system (Qnil))
|| ((symval =
find_symbol_value (Qtty_select_active_regions),
- (!EQ (symval, Qunbound) && !NILP (symval)))
+ (!BASE_EQ (symval, Qunbound) && !NILP (symval)))
&& !NILP (Fterminal_parameter (Qnil,
Qxterm__set_selection))))
/* Even if mark_active is non-nil, the actual buffer
@@ -1652,7 +1701,8 @@ read_menu_command (void)
specbind (Qecho_keystrokes, make_fixnum (0));
Lisp_Object keybuf[READ_KEY_ELTS];
- int i = read_key_sequence (keybuf, Qnil, false, true, true, true);
+ int i = read_key_sequence (keybuf, Qnil, false, true, true, true,
+ false);
unbind_to (count, Qnil);
@@ -2196,7 +2246,7 @@ show_help_echo (Lisp_Object help, Lisp_Object window, Lisp_Object object,
if (!NILP (help) && !STRINGP (help))
{
if (FUNCTIONP (help))
- help = safe_call (4, help, window, object, pos);
+ help = safe_calln (help, window, object, pos);
else
help = safe_eval (help);
@@ -2570,7 +2620,8 @@ read_char (int commandflag, Lisp_Object map,
goto reread_for_input_method;
}
- if (!NILP (Vexecuting_kbd_macro))
+ /* If we're executing a macro, process it unless we are at its end. */
+ if (!NILP (Vexecuting_kbd_macro) && !at_end_of_macro_p ())
{
/* We set this to Qmacro; since that's not a frame, nobody will
try to switch frames on us, and the selected window will
@@ -2584,16 +2635,6 @@ read_char (int commandflag, Lisp_Object map,
selected. */
Vlast_event_frame = internal_last_event_frame = Qmacro;
- /* Exit the macro if we are at the end.
- Also, some things replace the macro with t
- to force an early exit. */
- if (EQ (Vexecuting_kbd_macro, Qt)
- || executing_kbd_macro_index >= XFIXNAT (Flength (Vexecuting_kbd_macro)))
- {
- XSETINT (c, -1);
- goto exit;
- }
-
c = Faref (Vexecuting_kbd_macro, make_int (executing_kbd_macro_index));
if (STRINGP (Vexecuting_kbd_macro)
&& (XFIXNAT (c) & 0x80) && (XFIXNAT (c) <= 0xff))
@@ -3022,6 +3063,7 @@ read_char (int commandflag, Lisp_Object map,
{
struct buffer *prev_buffer = current_buffer;
last_input_event = c;
+
call4 (Qcommand_execute, tem, Qnil, Fvector (1, &last_input_event), Qt);
if (CONSP (c) && !NILP (Fmemq (XCAR (c), Vwhile_no_input_ignore_events))
@@ -3584,6 +3626,11 @@ readable_events (int flags)
return 1;
#endif
+#ifdef HAVE_TEXT_CONVERSION
+ if (detect_conversion_events ())
+ return 1;
+#endif
+
if (!(flags & READABLE_EVENTS_IGNORE_SQUEEZABLES) && some_mouse_moved ())
return 1;
if (single_kboard)
@@ -3916,6 +3963,11 @@ kbd_buffer_get_event (KBOARD **kbp,
had_pending_selection_requests = false;
#endif
+#ifdef HAVE_TEXT_CONVERSION
+ bool had_pending_conversion_events;
+
+ had_pending_conversion_events = false;
+#endif
#ifdef subprocesses
if (kbd_on_hold_p () && kbd_buffer_nr_stored () < KBD_BUFFER_SIZE / 4)
@@ -3952,6 +4004,19 @@ kbd_buffer_get_event (KBOARD **kbp,
if (CONSP (Vunread_command_events))
break;
+#ifdef HAVE_TEXT_CONVERSION
+ /* That text conversion events take priority over keyboard
+ events, since input methods frequently send them immediately
+ after edits, with the assumption that this order of events
+ will be observed. */
+
+ if (detect_conversion_events ())
+ {
+ had_pending_conversion_events = true;
+ break;
+ }
+#endif /* HAVE_TEXT_CONVERSION */
+
if (kbd_fetch_ptr != kbd_store_ptr)
break;
if (some_mouse_moved ())
@@ -4035,6 +4100,24 @@ kbd_buffer_get_event (KBOARD **kbp,
return first;
}
+#ifdef HAVE_TEXT_CONVERSION
+ /* There are pending text conversion operations. Text conversion
+ events should be generated before processing any other keyboard
+ input. */
+ if (had_pending_conversion_events)
+ {
+ handle_pending_conversion_events ();
+ obj = Qtext_conversion;
+
+ /* See the comment in handle_pending_conversion_events_1.
+ Note that in addition, text conversion events are not
+ generated if no edits were actually made. */
+ if (conversion_disabled_p ()
+ || NILP (Vtext_conversion_edits))
+ obj = Qnil;
+ }
+ else
+#endif
/* At this point, we know that there is a readable event available
somewhere. If the event queue is empty, then there must be a
mouse movement enabled and available. */
@@ -4104,6 +4187,16 @@ kbd_buffer_get_event (KBOARD **kbp,
break;
}
+#ifdef HAVE_ANDROID
+ case NOTIFICATION_EVENT:
+ {
+ kbd_fetch_ptr = next_kbd_event (event);
+ input_pending = readable_events (0);
+ CALLN (Fapply, XCAR (event->ie.arg), XCDR (event->ie.arg));
+ break;
+ }
+#endif /* HAVE_ANDROID */
+
#ifdef HAVE_EXT_MENU_BAR
case MENU_BAR_ACTIVATE_EVENT:
{
@@ -4582,7 +4675,7 @@ timer_check_2 (Lisp_Object timers, Lisp_Object idle_timers)
{
Lisp_Object funcall = XCAR (pending_funcalls);
pending_funcalls = XCDR (pending_funcalls);
- safe_call2 (Qapply, XCAR (funcall), XCDR (funcall));
+ safe_calln (Qapply, XCAR (funcall), XCDR (funcall));
}
if (CONSP (timers) || CONSP (idle_timers))
@@ -4920,7 +5013,88 @@ static const char *const lispy_accent_keys[] =
"dead-horn",
};
-#ifdef HAVE_NTGUI
+#ifdef HAVE_ANDROID
+#define FUNCTION_KEY_OFFSET 0
+
+/* Mind that Android designates 23 KEYCODE_DPAD_CENTER, but it is
+ merely abstruse terminology for the ``select'' key frequently
+ located in certain physical keyboards. */
+
+const char *const lispy_function_keys[] =
+ {
+ /* All elements in this array default to 0, except for the few
+ function keys that Emacs recognizes. */
+ [111] = "escape",
+ [112] = "delete",
+ [116] = "scroll",
+ [120] = "sysrq",
+ [121] = "break",
+ [122] = "home",
+ [123] = "end",
+ [124] = "insert",
+ [126] = "media-play",
+ [127] = "media-pause",
+ [130] = "media-record",
+ [131] = "f1",
+ [132] = "f2",
+ [133] = "f3",
+ [134] = "f4",
+ [135] = "f5",
+ [136] = "f6",
+ [137] = "f7",
+ [138] = "f8",
+ [139] = "f9",
+ [140] = "f10",
+ [141] = "f11",
+ [142] = "f12",
+ [143] = "kp-numlock",
+ [160] = "kp-ret",
+ [164] = "volume-mute",
+ [165] = "info",
+ [19] = "up",
+ [20] = "down",
+ [211] = "zenkaku-hankaku",
+ [213] = "muhenkan",
+ [214] = "henkan",
+ [215] = "hiragana-katakana",
+ [218] = "kana",
+ [21] = "left",
+ [223] = "sleep",
+ [22] = "right",
+ [23] = "select",
+ [24] = "volume-up",
+ [259] = "help",
+ [25] = "volume-down",
+ [268] = "kp-up-left",
+ [269] = "kp-down-left",
+ [26] = "power",
+ [270] = "kp-up-right",
+ [271] = "kp-down-right",
+ [272] = "media-skip-forward",
+ [273] = "media-skip-backward",
+ [277] = "cut",
+ [278] = "copy",
+ [279] = "paste",
+ [285] = "browser-refresh",
+ [28] = "clear",
+ [300] = "XF86Forward",
+ [4] = "XF86Back",
+ [61] = "tab",
+ [66] = "return",
+ [67] = "backspace",
+ [82] = "menu",
+ [84] = "find",
+ [85] = "media-play-pause",
+ [86] = "media-stop",
+ [87] = "media-next",
+ [88] = "media-previous",
+ [89] = "media-rewind",
+ [92] = "prior",
+ [93] = "next",
+ [95] = "mode-change",
+ };
+
+#elif defined HAVE_NTGUI
#define FUNCTION_KEY_OFFSET 0x0
const char *const lispy_function_keys[] =
@@ -5384,6 +5558,10 @@ static Lisp_Object button_down_location;
the down mouse event. */
static Lisp_Object frame_relative_event_pos;
+/* The line-number display width, in columns, at the time of most
+ recent down mouse event. */
+static int down_mouse_line_number_width;
+
/* Information about the most recent up-going button event: Which
button, what location, and what time. */
@@ -5410,9 +5588,10 @@ make_lispy_position (struct frame *f, Lisp_Object x, Lisp_Object y,
/* Coordinate pixel positions to return. */
int xret = 0, yret = 0;
/* The window or frame under frame pixel coordinates (x,y) */
- Lisp_Object window_or_frame = f
- ? window_from_coordinates (f, mx, my, &part, true, true)
- : Qnil;
+ Lisp_Object window_or_frame = (f != NULL
+ ? window_from_coordinates (f, mx, my, &part,
+ false, true, true)
+ : Qnil);
#ifdef HAVE_WINDOW_SYSTEM
bool tool_bar_p = false;
bool menu_bar_p = false;
@@ -5757,6 +5936,80 @@ coords_in_menu_bar_window (struct frame *f, int x, int y)
#endif
+#ifdef HAVE_WINDOW_SYSTEM
+
+/* Return whether or not the coordinates X and Y are inside the
+ tab-bar window of the given frame F. */
+
+static bool
+coords_in_tab_bar_window (struct frame *f, int x, int y)
+{
+ struct window *window;
+
+ if (!WINDOWP (f->tab_bar_window))
+ return false;
+
+ window = XWINDOW (f->tab_bar_window);
+
+ return (y >= WINDOW_TOP_EDGE_Y (window)
+ && x >= WINDOW_LEFT_EDGE_X (window)
+ && y <= WINDOW_BOTTOM_EDGE_Y (window)
+ && x <= WINDOW_RIGHT_EDGE_X (window));
+}
+
+#endif /* HAVE_WINDOW_SYSTEM */
+
+static void
+save_line_number_display_width (struct input_event *event)
+{
+ struct window *w;
+ int pixel_width;
+
+ if (WINDOWP (event->frame_or_window))
+ w = XWINDOW (event->frame_or_window);
+ else if (FRAMEP (event->frame_or_window))
+ w = XWINDOW (XFRAME (event->frame_or_window)->selected_window);
+ else
+ w = XWINDOW (selected_window);
+ line_number_display_width (w, &down_mouse_line_number_width, &pixel_width);
+}
+
+/* Return non-zero if the change of position from START_POS to END_POS
+ is likely to be the effect of horizontal scrolling due to a change
+ in line-number width produced by redisplay between two mouse
+ events, like mouse-down followed by mouse-up, at those positions.
+ This is used to decide whether to converts mouse-down followed by
+ mouse-up event into a mouse-drag event. */
+static bool
+line_number_mode_hscroll (Lisp_Object start_pos, Lisp_Object end_pos)
+{
+ if (!EQ (Fcar (start_pos), Fcar (end_pos)) /* different window */
+ || list_length (start_pos) < 7 /* no COL/ROW info */
+ || list_length (end_pos) < 7)
+ return false;
+
+ Lisp_Object start_col_row = Fnth (make_fixnum (6), start_pos);
+ Lisp_Object end_col_row = Fnth (make_fixnum (6), end_pos);
+ Lisp_Object window = Fcar (end_pos);
+ int col_width, pixel_width;
+ Lisp_Object start_col, end_col;
+ struct window *w;
+ if (!WINDOW_VALID_P (window))
+ {
+ if (WINDOW_LIVE_P (window))
+ window = XFRAME (window)->selected_window;
+ else
+ window = selected_window;
+ }
+ w = XWINDOW (window);
+ line_number_display_width (w, &col_width, &pixel_width);
+ start_col = Fcar (start_col_row);
+ end_col = Fcar (end_col_row);
+ return EQ (start_col, end_col)
+ && down_mouse_line_number_width >= 0
+ && col_width != down_mouse_line_number_width;
+}
+
/* Given a struct input_event, build the lisp event which represents
it. If EVENT is 0, build a mouse movement event from the mouse
movement buffer, which should have a movement event in it.
@@ -6066,6 +6319,11 @@ make_lispy_event (struct input_event *event)
}
}
+ /* Don't generate a menu bar event if ITEM is
+ nil. */
+ if (NILP (item))
+ return Qnil;
+
/* ELisp manual 2.4b says (x y) are window
relative but code says they are
frame-relative. */
@@ -6154,6 +6412,8 @@ make_lispy_event (struct input_event *event)
*start_pos_ptr = Fcopy_alist (position);
frame_relative_event_pos = Fcons (event->x, event->y);
ignore_mouse_drag_p = false;
+ /* Squirrel away the line-number width, if any. */
+ save_line_number_display_width (event);
}
/* Now we're releasing a button - check the coordinates to
@@ -6199,12 +6459,18 @@ make_lispy_event (struct input_event *event)
it's probably OK to ignore it as well. */
&& (EQ (Fcar (Fcdr (start_pos)),
Fcar (Fcdr (position))) /* Same buffer pos */
+ /* Redisplay hscrolled text between down- and
+ up-events due to display-line-numbers-mode. */
+ || line_number_mode_hscroll (start_pos, position)
|| !EQ (Fcar (start_pos),
Fcar (position))))) /* Different window */
+
{
/* Mouse has moved enough. */
button_down_time = 0;
click_or_drag_modifier = drag_modifier;
+ /* Reset the value for future clicks. */
+ down_mouse_line_number_width = -1;
}
else if (((!EQ (Fcar (start_pos), Fcar (position)))
|| (!EQ (Fcar (Fcdr (start_pos)),
@@ -6401,22 +6667,206 @@ make_lispy_event (struct input_event *event)
}
case TOUCHSCREEN_BEGIN_EVENT:
+ {
+ Lisp_Object x, y, id, position;
+ struct frame *f;
+#ifdef HAVE_WINDOW_SYSTEM
+ int tab_bar_item;
+ bool close;
+#endif /* HAVE_WINDOW_SYSTEM */
+
+ f = XFRAME (event->frame_or_window);
+
+ if (!FRAME_LIVE_P (f))
+ return Qnil;
+
+ id = event->arg;
+ x = event->x;
+ y = event->y;
+
+#if defined HAVE_WINDOW_SYSTEM && !defined HAVE_EXT_MENU_BAR
+ if (coords_in_menu_bar_window (f, XFIXNUM (x), XFIXNUM (y)))
+ {
+ /* If the tap began in the menu bar window, then save the
+ id. */
+ menu_bar_touch_id = id;
+ return Qnil;
+ }
+#endif /* defined HAVE_WINDOW_SYSTEM && !defined HAVE_EXT_MENU_BAR */
+
+ position = make_lispy_position (f, x, y, event->timestamp);
+
+#ifdef HAVE_WINDOW_SYSTEM
+
+ /* Now check if POSITION lies on the tab bar. If so, look up
+ the corresponding tab bar item's propertized string as the
+ OBJECT. */
+
+ if (coords_in_tab_bar_window (f, XFIXNUM (event->x),
+ XFIXNUM (event->y))
+ /* `get_tab_bar_item_kbd' returns 0 if the item was
+ previously highlighted, 1 otherwise, and -1 if there is
+ no tab bar item. */
+ && get_tab_bar_item_kbd (f, XFIXNUM (event->x),
+ XFIXNUM (event->y), &tab_bar_item,
+ &close) >= 0)
+ {
+ /* First, obtain the propertized string. */
+ x = Fcopy_sequence (AREF (f->tab_bar_items,
+ (tab_bar_item
+ + TAB_BAR_ITEM_CAPTION)));
+
+ /* Next, add the key binding. */
+ AUTO_LIST2 (y, Qmenu_item, list3 (AREF (f->tab_bar_items,
+ (tab_bar_item
+ + TAB_BAR_ITEM_KEY)),
+ AREF (f->tab_bar_items,
+ (tab_bar_item
+ + TAB_BAR_ITEM_BINDING)),
+ close ? Qt : Qnil));
+
+ /* And add the new properties to the propertized string. */
+ Fadd_text_properties (make_fixnum (0),
+ make_fixnum (SCHARS (x)),
+ y, x);
+
+ /* Set the position to 0. */
+ x = Fcons (x, make_fixnum (0));
+
+ /* Finally, add the OBJECT. */
+ position = nconc2 (position, Fcons (x, Qnil));
+ }
+
+#endif /* HAVE_WINDOW_SYSTEM */
+
+ return list2 (Qtouchscreen_begin,
+ Fcons (id, position));
+ }
+
case TOUCHSCREEN_END_EVENT:
{
Lisp_Object x, y, id, position;
struct frame *f = XFRAME (event->frame_or_window);
+#if defined HAVE_WINDOW_SYSTEM && !defined HAVE_EXT_MENU_BAR
+ int column, row, dummy;
+#endif /* defined HAVE_WINDOW_SYSTEM && !defined HAVE_EXT_MENU_BAR */
+#ifdef HAVE_WINDOW_SYSTEM
+ int tab_bar_item;
+ bool close;
+#endif /* HAVE_WINDOW_SYSTEM */
+
+ if (!FRAME_LIVE_P (f))
+ return Qnil;
id = event->arg;
x = event->x;
y = event->y;
+#if defined HAVE_WINDOW_SYSTEM && !defined HAVE_EXT_MENU_BAR
+ if (EQ (menu_bar_touch_id, id))
+ {
+ /* This touch should activate the menu bar. Generate the
+ menu bar event. */
+ menu_bar_touch_id = Qnil;
+
+ if (!NILP (f->menu_bar_window))
+ {
+ x_y_to_hpos_vpos (XWINDOW (f->menu_bar_window), XFIXNUM (x),
+ XFIXNUM (y), &column, &row, NULL, NULL,
+ &dummy);
+
+ if (row >= 0 && row < FRAME_MENU_BAR_LINES (f))
+ {
+ Lisp_Object items, item;
+
+ /* Find the menu bar item under `column'. */
+ item = Qnil;
+ items = FRAME_MENU_BAR_ITEMS (f);
+ for (i = 0; i < ASIZE (items); i += 4)
+ {
+ Lisp_Object pos, string;
+ string = AREF (items, i + 1);
+ pos = AREF (items, i + 3);
+ if (NILP (string))
+ break;
+ if (column >= XFIXNUM (pos)
+ && column < XFIXNUM (pos) + SCHARS (string))
+ {
+ item = AREF (items, i);
+ break;
+ }
+ }
+
+ /* Don't generate a menu bar event if ITEM is
+ nil. */
+ if (NILP (item))
+ return Qnil;
+
+ /* ELisp manual 2.4b says (x y) are window
+ relative but code says they are
+ frame-relative. */
+ position = list4 (event->frame_or_window,
+ Qmenu_bar,
+ Fcons (event->x, event->y),
+ INT_TO_INTEGER (event->timestamp));
+
+ return list2 (item, position);
+ }
+ }
+
+ return Qnil;
+ }
+#endif /* defined HAVE_WINDOW_SYSTEM && !defined HAVE_EXT_MENU_BAR */
+
position = make_lispy_position (f, x, y, event->timestamp);
- return list2 (((event->kind
- == TOUCHSCREEN_BEGIN_EVENT)
- ? Qtouchscreen_begin
- : Qtouchscreen_end),
- Fcons (id, position));
+#ifdef HAVE_WINDOW_SYSTEM
+
+ /* Now check if POSITION lies on the tab bar. If so, look up
+ the corresponding tab bar item's propertized string as the
+ OBJECT. */
+
+ if (coords_in_tab_bar_window (f, XFIXNUM (event->x),
+ XFIXNUM (event->y))
+ /* `get_tab_bar_item_kbd' returns 0 if the item was
+ previously highlighted, 1 otherwise, and -1 if there is
+ no tab bar item. */
+ && get_tab_bar_item_kbd (f, XFIXNUM (event->x),
+ XFIXNUM (event->y), &tab_bar_item,
+ &close) >= 0)
+ {
+ /* First, obtain the propertized string. */
+ x = Fcopy_sequence (AREF (f->tab_bar_items,
+ (tab_bar_item
+ + TAB_BAR_ITEM_CAPTION)));
+
+ /* Next, add the key binding. */
+ AUTO_LIST2 (y, Qmenu_item, list3 (AREF (f->tab_bar_items,
+ (tab_bar_item
+ + TAB_BAR_ITEM_KEY)),
+ AREF (f->tab_bar_items,
+ (tab_bar_item
+ + TAB_BAR_ITEM_BINDING)),
+ close ? Qt : Qnil));
+
+ /* And add the new properties to the propertized string. */
+ Fadd_text_properties (make_fixnum (0),
+ make_fixnum (SCHARS (x)),
+ y, x);
+
+ /* Set the position to 0. */
+ x = Fcons (x, make_fixnum (0));
+
+ /* Finally, add the OBJECT. */
+ position = nconc2 (position, Fcons (x, Qnil));
+ }
+
+#endif /* HAVE_WINDOW_SYSTEM */
+
+ position = make_lispy_position (f, x, y, event->timestamp);
+
+ return list3 (Qtouchscreen_end, Fcons (id, position),
+ event->modifiers ? Qt : Qnil);
}
case PINCH_EVENT:
@@ -6441,6 +6891,9 @@ make_lispy_event (struct input_event *event)
struct frame *f = XFRAME (event->frame_or_window);
evt = Qnil;
+ if (!FRAME_LIVE_P (f))
+ return Qnil;
+
for (tem = event->arg; CONSP (tem); tem = XCDR (tem))
{
it = XCAR (tem);
@@ -6449,10 +6902,19 @@ make_lispy_event (struct input_event *event)
y = XCAR (XCDR (it));
id = XCAR (XCDR (XCDR (it)));
+ /* Don't report touches to the menu bar. */
+ if (EQ (id, menu_bar_touch_id))
+ continue;
+
position = make_lispy_position (f, x, y, event->timestamp);
evt = Fcons (Fcons (id, position), evt);
}
+ if (NILP (evt))
+ /* Don't return an event if the touchpoint list is
+ empty. */
+ return Qnil;
+
return list2 (Qtouchscreen_update, evt);
}
@@ -7652,6 +8114,14 @@ tty_read_avail_input (struct terminal *terminal,
static void
handle_async_input (void)
{
+#if defined HAVE_ANDROID && !defined ANDROID_STUBIFY
+ /* Check and respond to an ``urgent'' query from the UI thread.
+ A query becomes urgent once the UI thread has been waiting
+ for more than two seconds. */
+
+ android_check_query_urgent ();
+#endif /* HAVE_ANDROID && !ANDROID_STUBIFY */
+
#ifndef DOS_NT
while (1)
{
@@ -7720,6 +8190,16 @@ totally_unblock_input (void)
void
handle_input_available_signal (int sig)
{
+#if defined HAVE_ANDROID && !defined ANDROID_STUBIFY
+ /* Make all writes from the Android UI thread visible. If
+ `android_urgent_query' has been set, preceding writes to query
+ related variables should become observable here on as well. */
+#if defined __aarch64__
+ asm ("dmb ishst");
+#else /* !defined __aarch64__ */
+ __atomic_thread_fence (__ATOMIC_SEQ_CST);
+#endif /* defined __aarch64__ */
+#endif /* HAVE_ANDROID && !ANDROID_STUBIFY */
pending_signals = true;
if (input_available_clear_time)
@@ -8150,7 +8630,7 @@ menu_item_eval_property_1 (Lisp_Object arg)
{
/* If we got a quit from within the menu computation,
quit all the way out of it. This takes care of C-] in the debugger. */
- if (CONSP (arg) && signal_quit_p (XCAR (arg)))
+ if (signal_quit_p (arg))
quit ();
return Qnil;
@@ -8613,7 +9093,7 @@ process_tab_bar_item (Lisp_Object key, Lisp_Object def, Lisp_Object data, void *
}
/* Access slot with index IDX of vector tab_bar_item_properties. */
-#define PROP(IDX) AREF (tab_bar_item_properties, (IDX))
+#define PROP(IDX) AREF (tab_bar_item_properties, IDX)
static void
set_prop_tab_bar (ptrdiff_t idx, Lisp_Object val)
{
@@ -8997,7 +9477,7 @@ process_tool_bar_item (Lisp_Object key, Lisp_Object def, Lisp_Object data, void
}
/* Access slot with index IDX of vector tool_bar_item_properties. */
-#define PROP(IDX) AREF (tool_bar_item_properties, (IDX))
+#define PROP(IDX) AREF (tool_bar_item_properties, IDX)
static void
set_prop (ptrdiff_t idx, Lisp_Object val)
{
@@ -9049,7 +9529,13 @@ set_prop (ptrdiff_t idx, Lisp_Object val)
- `:label LABEL-STRING'.
- A text label to show with the tool bar button if labels are enabled. */
+ A text label to show with the tool bar button if labels are
+ enabled.
+
+ - `:wrap WRAP'
+
+ WRAP specifies whether to hide this item but display subsequent
+ tool bar items on a new line. */
static bool
parse_tool_bar_item (Lisp_Object key, Lisp_Object item)
@@ -9057,7 +9543,15 @@ parse_tool_bar_item (Lisp_Object key, Lisp_Object item)
Lisp_Object filter = Qnil;
Lisp_Object caption;
int i;
- bool have_label = false;
+ bool have_label;
+#ifndef HAVE_EXT_TOOL_BAR
+ bool is_wrap;
+#endif /* HAVE_EXT_TOOL_BAR */
+
+ have_label = false;
+#ifndef HAVE_EXT_TOOL_BAR
+ is_wrap = false;
+#endif /* HAVE_EXT_TOOL_BAR */
/* Definition looks like `(menu-item CAPTION BINDING PROPS...)'.
Rule out items that aren't lists, don't start with
@@ -9193,6 +9687,20 @@ parse_tool_bar_item (Lisp_Object key, Lisp_Object item)
else if (EQ (ikey, QCrtl))
/* ':rtl STRING' */
set_prop (TOOL_BAR_ITEM_RTL_IMAGE, value);
+ else if (EQ (ikey, QCwrap))
+ {
+#ifndef HAVE_EXT_TOOL_BAR
+ /* This specifies whether the tool bar item should be hidden
+ but cause subsequent items to be displayed on a new
+ line. */
+ set_prop (TOOL_BAR_ITEM_WRAP, value);
+ is_wrap = !NILP (value);
+#else /* HAVE_EXT_TOOL_BAR */
+ /* Line wrapping isn't supported on builds utilizing
+ external tool bars. */
+ return false;
+#endif /* !HAVE_EXT_TOOL_BAR */
+ }
}
@@ -9253,6 +9761,15 @@ parse_tool_bar_item (Lisp_Object key, Lisp_Object item)
if (CONSP (get_keymap (PROP (TOOL_BAR_ITEM_BINDING), 0, 1)))
return 0;
+
+#ifndef HAVE_EXT_TOOL_BAR
+ /* If the menu item is actually a line wrap, make sure it isn't
+ visible or enabled. */
+
+ if (is_wrap)
+ set_prop (TOOL_BAR_ITEM_ENABLED_P, Qnil);
+#endif /* !HAVE_EXT_TOOL_BAR */
+
/* If there is a key binding, add it to the help, which will be
displayed as a tooltip for this entry. */
Lisp_Object binding = PROP (TOOL_BAR_ITEM_BINDING);
@@ -9674,13 +10191,18 @@ typedef struct keyremap
If the mapping is a function and DO_FUNCALL is true,
the function is called with PROMPT as parameter and its return
value is used as the return value of this function (after checking
- that it is indeed a vector). */
+ that it is indeed a vector).
+
+ START and END are the indices of the first and last key of the
+ sequence being remapped within the keyboard buffer KEYBUF. */
static Lisp_Object
access_keymap_keyremap (Lisp_Object map, Lisp_Object key, Lisp_Object prompt,
- bool do_funcall)
+ bool do_funcall, unsigned int start, unsigned int end,
+ Lisp_Object *keybuf)
{
Lisp_Object next;
+ specpdl_ref count;
next = access_keymap (map, key, 1, 0, 1);
@@ -9696,10 +10218,18 @@ access_keymap_keyremap (Lisp_Object map, Lisp_Object key, Lisp_Object prompt,
its value instead. */
if (do_funcall && FUNCTIONP (next))
{
- Lisp_Object tem;
+ Lisp_Object tem, remap;
tem = next;
- next = call1 (next, prompt);
+ /* Build Vcurrent_key_remap_sequence. */
+ remap = Fvector (end - start + 1, keybuf + start);
+
+ /* Bind `current-key-remap-sequence' to the key sequence being
+ remapped. */
+ count = SPECPDL_INDEX ();
+ specbind (Qcurrent_key_remap_sequence, remap);
+ next = unbind_to (count, call1 (next, prompt));
+
/* If the function returned something invalid,
barf--don't ignore it. */
if (! (NILP (next) || VECTORP (next) || STRINGP (next)))
@@ -9724,11 +10254,17 @@ keyremap_step (Lisp_Object *keybuf, volatile keyremap *fkey,
int input, bool doit, int *diff, Lisp_Object prompt)
{
Lisp_Object next, key;
+ ptrdiff_t buf_start, buf_end;
+
+ /* Save the key sequence being translated. */
+ buf_start = fkey->start;
+ buf_end = fkey->end;
key = keybuf[fkey->end++];
if (KEYMAPP (fkey->parent))
- next = access_keymap_keyremap (fkey->map, key, prompt, doit);
+ next = access_keymap_keyremap (fkey->map, key, prompt, doit,
+ buf_start, buf_end, keybuf);
else
next = Qnil;
@@ -9789,6 +10325,24 @@ void init_raw_keybuf_count (void)
raw_keybuf_count = 0;
}
+
+
+#ifdef HAVE_TEXT_CONVERSION
+
+static void
+restore_reading_key_sequence (int old_reading_key_sequence)
+{
+ reading_key_sequence = old_reading_key_sequence;
+
+ /* If a key sequence is no longer being read, reset input methods
+ whose state changes were postponed. */
+
+ if (!old_reading_key_sequence)
+ check_postponed_buffers ();
+}
+
+#endif /* HAVE_TEXT_CONVERSION */
+
/* Read a sequence of keys that ends with a non prefix character,
storing it in KEYBUF, a buffer of size READ_KEY_ELTS.
Prompt with PROMPT.
@@ -9827,12 +10381,16 @@ void init_raw_keybuf_count (void)
read_char will return it.
If FIX_CURRENT_BUFFER, we restore current_buffer
- from the selected window's buffer. */
+ from the selected window's buffer.
+
+ If DISABLE_TEXT_CONVERSION_P, disable text conversion so the input
+ method will always send key events. */
static int
read_key_sequence (Lisp_Object *keybuf, Lisp_Object prompt,
bool dont_downcase_last, bool can_return_switch_frame,
- bool fix_current_buffer, bool prevent_redisplay)
+ bool fix_current_buffer, bool prevent_redisplay,
+ bool disable_text_conversion_p)
{
specpdl_ref count = SPECPDL_INDEX ();
@@ -9894,8 +10452,12 @@ read_key_sequence (Lisp_Object *keybuf, Lisp_Object prompt,
Lisp_Object original_uppercase UNINIT;
int original_uppercase_position = -1;
- /* Gets around Microsoft compiler limitations. */
- bool dummyflag = false;
+#ifdef HAVE_TEXT_CONVERSION
+ bool disabled_conversion;
+
+ /* Whether or not text conversion has already been disabled. */
+ disabled_conversion = false;
+#endif /* HAVE_TEXT_CONVERSION */
struct buffer *starting_buffer;
@@ -9941,6 +10503,16 @@ read_key_sequence (Lisp_Object *keybuf, Lisp_Object prompt,
keys_start = this_command_key_count;
this_single_command_key_start = keys_start;
+#ifdef HAVE_TEXT_CONVERSION
+ /* Set `reading_key_sequence' to true. This variable is used by
+ Fset_text_conversion_style to determine if it should postpone
+ resetting the input method until this function completes. */
+
+ record_unwind_protect_int (restore_reading_key_sequence,
+ reading_key_sequence);
+ reading_key_sequence = true;
+#endif /* HAVE_TEXT_CONVERSION */
+
/* We jump here when we need to reinitialize fkey and keytran; this
happens if we switch keyboards between rescans. */
replay_entire_sequence:
@@ -9979,6 +10551,18 @@ read_key_sequence (Lisp_Object *keybuf, Lisp_Object prompt,
if (INTERACTIVE && t < mock_input)
echo_truncate (echo_start);
+ /* If text conversion is supposed to be disabled immediately, do it
+ now. */
+
+#ifdef HAVE_TEXT_CONVERSION
+ if (disable_text_conversion_p)
+ {
+ disable_text_conversion ();
+ record_unwind_protect_void (resume_text_conversion);
+ disabled_conversion = true;
+ }
+#endif /* HAVE_TEXT_CONVERSION */
+
/* If the best binding for the current key sequence is a keymap, or
we may be looking at a function key's escape sequence, keep on
reading. */
@@ -10046,6 +10630,43 @@ read_key_sequence (Lisp_Object *keybuf, Lisp_Object prompt,
echo_local_start = echo_length ();
keys_local_start = this_command_key_count;
+#ifdef HAVE_TEXT_CONVERSION
+ /* When reading a key sequence while text conversion is in
+ effect, turn it off after the first actual character read.
+ This makes input methods send actual key events instead.
+
+ Make sure only to do this once. Also, disabling text
+ conversion seems to interact badly with menus, so don't
+ disable text conversion if a menu was displayed. */
+
+ if (!disabled_conversion && t && !used_mouse_menu
+ && !disable_inhibit_text_conversion)
+ {
+ int i;
+
+ /* used_mouse_menu isn't set if a menu bar prefix key has
+ just been stored. It appears necessary to look for a
+ prefix key itself. Don't look through too many keys for
+ efficiency reasons. */
+
+ for (i = 0; i < min (t, 10); ++i)
+ {
+ if (NUMBERP (keybuf[i])
+ || (SYMBOLP (keybuf[i])
+ && EQ (Fget (keybuf[i], Qevent_kind),
+ Qfunction_key)))
+ goto disable_text_conversion;
+ }
+
+ goto replay_key;
+
+ disable_text_conversion:
+ disable_text_conversion ();
+ record_unwind_protect_void (resume_text_conversion);
+ disabled_conversion = true;
+ }
+#endif
+
replay_key:
/* These are no-ops, unless we throw away a keystroke below and
jumped back up to replay_key; in that case, these restore the
@@ -10072,8 +10693,16 @@ read_key_sequence (Lisp_Object *keybuf, Lisp_Object prompt,
}
used_mouse_menu = used_mouse_menu_history[t];
}
-
- /* If not, we should actually read a character. */
+ /* If we're at the end of a macro, exit it by returning 0,
+ unless there are unread events pending. */
+ else if (!NILP (Vexecuting_kbd_macro)
+ && at_end_of_macro_p ()
+ && !requeued_events_pending_p ())
+ {
+ t = 0;
+ goto done;
+ }
+ /* Otherwise, we should actually read a character. */
else
{
{
@@ -10165,18 +10794,6 @@ read_key_sequence (Lisp_Object *keybuf, Lisp_Object prompt,
return -1;
}
- /* read_char returns -1 at the end of a macro.
- Emacs 18 handles this by returning immediately with a
- zero, so that's what we'll do. */
- if (FIXNUMP (key) && XFIXNUM (key) == -1)
- {
- t = 0;
- /* The Microsoft C compiler can't handle the goto that
- would go here. */
- dummyflag = true;
- break;
- }
-
/* If the current buffer has been changed from under us, the
keymap may have changed, so replay the sequence. */
if (BUFFERP (key))
@@ -10273,7 +10890,7 @@ read_key_sequence (Lisp_Object *keybuf, Lisp_Object prompt,
if (EVENT_HAS_PARAMETERS (key))
{
Lisp_Object kind = EVENT_HEAD_KIND (EVENT_HEAD (key));
- if (EQ (kind, Qmouse_click))
+ if (EQ (kind, Qmouse_click) || EQ (kind, Qtouchscreen))
{
Lisp_Object window = POSN_WINDOW (EVENT_START (key));
Lisp_Object posn = POSN_POSN (EVENT_START (key));
@@ -10351,7 +10968,15 @@ read_key_sequence (Lisp_Object *keybuf, Lisp_Object prompt,
posn = POSN_POSN (xevent_start (key));
/* Handle menu-bar events:
insert the dummy prefix event `menu-bar'. */
- if (EQ (posn, Qmenu_bar) || EQ (posn, Qtab_bar) || EQ (posn, Qtool_bar))
+ if ((EQ (posn, Qmenu_bar) || EQ (posn, Qtab_bar)
+ || EQ (posn, Qtool_bar))
+ /* Only insert the prefix key if the event comes
+ directly from the keyboard buffer. Key
+ translation functions might return events with a
+ `posn-area' of tool-bar or tab-bar without
+ intending for these prefix events to be
+ generated. */
+ && (mock_input <= t))
{
if (READ_KEY_ELTS - t <= 1)
error ("Key sequence too long");
@@ -10670,10 +11295,7 @@ read_key_sequence (Lisp_Object *keybuf, Lisp_Object prompt,
&& help_char_p (EVENT_HEAD (key)) && t > 1)
{
read_key_sequence_cmd = Vprefix_help_command;
- /* The Microsoft C compiler can't handle the goto that
- would go here. */
- dummyflag = true;
- break;
+ goto done;
}
/* If KEY is not defined in any of the keymaps,
@@ -10722,8 +11344,9 @@ read_key_sequence (Lisp_Object *keybuf, Lisp_Object prompt,
}
}
}
- if (!dummyflag)
- read_key_sequence_cmd = current_binding;
+ read_key_sequence_cmd = current_binding;
+
+ done:
read_key_sequence_remapped
/* Remap command through active keymaps.
Do the remapping here, before the unbind_to so it uses the keymaps
@@ -10768,7 +11391,8 @@ static Lisp_Object
read_key_sequence_vs (Lisp_Object prompt, Lisp_Object continue_echo,
Lisp_Object dont_downcase_last,
Lisp_Object can_return_switch_frame,
- Lisp_Object cmd_loop, bool allow_string)
+ Lisp_Object cmd_loop, bool allow_string,
+ bool disable_text_conversion)
{
specpdl_ref count = SPECPDL_INDEX ();
@@ -10795,7 +11419,8 @@ read_key_sequence_vs (Lisp_Object prompt, Lisp_Object continue_echo,
raw_keybuf_count = 0;
Lisp_Object keybuf[READ_KEY_ELTS];
int i = read_key_sequence (keybuf, prompt, ! NILP (dont_downcase_last),
- ! NILP (can_return_switch_frame), false, false);
+ ! NILP (can_return_switch_frame), false, false,
+ disable_text_conversion);
#if 0 /* The following is fine for code reading a key sequence and
then proceeding with a lengthy computation, but it's not good
@@ -10817,7 +11442,7 @@ read_key_sequence_vs (Lisp_Object prompt, Lisp_Object continue_echo,
(i, keybuf)));
}
-DEFUN ("read-key-sequence", Fread_key_sequence, Sread_key_sequence, 1, 5, 0,
+DEFUN ("read-key-sequence", Fread_key_sequence, Sread_key_sequence, 1, 6, 0,
doc: /* Read a sequence of keystrokes and return as a string or vector.
The sequence is sufficient to specify a non-prefix command in the
current local and global maps.
@@ -10863,20 +11488,31 @@ sequences, where they wouldn't conflict with ordinary bindings. See
The optional fifth argument CMD-LOOP, if non-nil, means
that this key sequence is being read by something that will
read commands one after another. It should be nil if the caller
-will read just one key sequence. */)
- (Lisp_Object prompt, Lisp_Object continue_echo, Lisp_Object dont_downcase_last, Lisp_Object can_return_switch_frame, Lisp_Object cmd_loop)
+will read just one key sequence.
+
+The optional sixth argument DISABLE-TEXT-CONVERSION, if non-nil, means
+disable input method text conversion for the duration of reading this
+key sequence, and that keyboard input will always result in key events
+being sent. */)
+ (Lisp_Object prompt, Lisp_Object continue_echo, Lisp_Object dont_downcase_last,
+ Lisp_Object can_return_switch_frame, Lisp_Object cmd_loop,
+ Lisp_Object disable_text_conversion)
{
return read_key_sequence_vs (prompt, continue_echo, dont_downcase_last,
- can_return_switch_frame, cmd_loop, true);
+ can_return_switch_frame, cmd_loop, true,
+ !NILP (disable_text_conversion));
}
DEFUN ("read-key-sequence-vector", Fread_key_sequence_vector,
- Sread_key_sequence_vector, 1, 5, 0,
+ Sread_key_sequence_vector, 1, 6, 0,
doc: /* Like `read-key-sequence' but always return a vector. */)
- (Lisp_Object prompt, Lisp_Object continue_echo, Lisp_Object dont_downcase_last, Lisp_Object can_return_switch_frame, Lisp_Object cmd_loop)
+ (Lisp_Object prompt, Lisp_Object continue_echo, Lisp_Object dont_downcase_last,
+ Lisp_Object can_return_switch_frame, Lisp_Object cmd_loop,
+ Lisp_Object disable_text_conversion)
{
return read_key_sequence_vs (prompt, continue_echo, dont_downcase_last,
- can_return_switch_frame, cmd_loop, false);
+ can_return_switch_frame, cmd_loop, false,
+ !NILP (disable_text_conversion));
}
/* Return true if input events are pending. */
@@ -10922,18 +11558,26 @@ clear_input_pending (void)
input_pending = false;
}
-/* Return true if there are pending requeued events.
- This isn't used yet. The hope is to make wait_reading_process_output
- call it, and return if it runs Lisp code that unreads something.
- The problem is, kbd_buffer_get_event needs to be fixed to know what
- to do in that case. It isn't trivial. */
+/* Return true if there are pending requeued command events. */
bool
-requeued_events_pending_p (void)
+requeued_command_events_pending_p (void)
{
return (CONSP (Vunread_command_events));
}
+/* Return true if there are any pending requeued events (command events
+ or events to be processed by other levels of the input processing
+ stages). */
+
+bool
+requeued_events_pending_p (void)
+{
+ return (requeued_command_events_pending_p ()
+ || !NILP (Vunread_post_input_method_events)
+ || !NILP (Vunread_input_method_events));
+}
+
DEFUN ("input-pending-p", Finput_pending_p, Sinput_pending_p, 0, 1, 0,
doc: /* Return t if command input is currently available with no wait.
Actually, the value is nil only if we can be sure that no input is available;
@@ -10942,9 +11586,7 @@ if there is a doubt, the value is t.
If CHECK-TIMERS is non-nil, timers that are ready to run will do so. */)
(Lisp_Object check_timers)
{
- if (CONSP (Vunread_command_events)
- || !NILP (Vunread_post_input_method_events)
- || !NILP (Vunread_input_method_events))
+ if (requeued_events_pending_p ())
return (Qt);
/* Process non-user-visible events (Bug#10195). */
@@ -11162,7 +11804,7 @@ DEFUN ("recursion-depth", Frecursion_depth, Srecursion_depth, 0, 0, 0,
(void)
{
EMACS_INT sum;
- INT_ADD_WRAPV (command_loop_level, minibuf_level, &sum);
+ ckd_add (&sum, command_loop_level, minibuf_level);
return make_fixnum (sum);
}
@@ -11185,7 +11827,7 @@ This may include sensitive information such as passwords. */)
if (dribble)
{
block_input ();
- fclose (dribble);
+ emacs_fclose (dribble);
unblock_input ();
dribble = 0;
}
@@ -11198,9 +11840,9 @@ This may include sensitive information such as passwords. */)
encfile = ENCODE_FILE (file);
fd = emacs_open (SSDATA (encfile), O_WRONLY | O_CREAT | O_EXCL, 0600);
if (fd < 0 && errno == EEXIST
- && (unlink (SSDATA (encfile)) == 0 || errno == ENOENT))
+ && (emacs_unlink (SSDATA (encfile)) == 0 || errno == ENOENT))
fd = emacs_open (SSDATA (encfile), O_WRONLY | O_CREAT | O_EXCL, 0600);
- dribble = fd < 0 ? 0 : fdopen (fd, "w");
+ dribble = fd < 0 ? 0 : emacs_fdopen (fd, "w");
if (dribble == 0)
report_file_error ("Opening dribble", file);
}
@@ -12084,7 +12726,10 @@ static const struct event_head head_table[] = {
{SYMBOL_INDEX (Qmake_frame_visible), SYMBOL_INDEX (Qmake_frame_visible)},
/* `select-window' should be handled just like `switch-frame'
in read_key_sequence. */
- {SYMBOL_INDEX (Qselect_window), SYMBOL_INDEX (Qswitch_frame)}
+ {SYMBOL_INDEX (Qselect_window), SYMBOL_INDEX (Qswitch_frame)},
+ /* Touchscreen events should be prefixed by the posn. */
+ {SYMBOL_INDEX (Qtouchscreen_begin), SYMBOL_INDEX (Qtouchscreen)},
+ {SYMBOL_INDEX (Qtouchscreen_end), SYMBOL_INDEX (Qtouchscreen)},
};
static Lisp_Object
@@ -12160,6 +12805,7 @@ syms_of_keyboard (void)
DEFSYM (Qhelp_echo, "help-echo");
DEFSYM (Qhelp_echo_inhibit_substitution, "help-echo-inhibit-substitution");
DEFSYM (QCrtl, ":rtl");
+ DEFSYM (QCwrap, ":wrap");
staticpro (&item_properties);
item_properties = Qnil;
@@ -12310,6 +12956,8 @@ syms_of_keyboard (void)
DEFSYM (Qhelp_key_binding, "help-key-binding");
+ DEFSYM (Qhelp__append_keystrokes_help, "help--append-keystrokes-help");
+
DEFSYM (Qecho_keystrokes, "echo-keystrokes");
Fset (Qinput_method_exit_on_first_char, Qnil);
@@ -12430,6 +13078,9 @@ syms_of_keyboard (void)
virtual_core_keyboard_name = Qnil;
staticpro (&virtual_core_keyboard_name);
+ menu_bar_touch_id = Qnil;
+ staticpro (&menu_bar_touch_id);
+
defsubr (&Scurrent_idle_time);
defsubr (&Sevent_symbol_parse_modifiers);
defsubr (&Sevent_convert_list);
@@ -12582,11 +13233,17 @@ Emacs also does a garbage collection if that seems to be warranted. */);
XSETFASTINT (Vauto_save_timeout, 30);
DEFVAR_LISP ("echo-keystrokes", Vecho_keystrokes,
- doc: /* Nonzero means echo unfinished commands after this many seconds of pause.
+ doc: /* Nonzero means echo unfinished commands after this many seconds of pause.
The value may be integer or floating point.
If the value is zero, don't echo at all. */);
Vecho_keystrokes = make_fixnum (1);
+ DEFVAR_BOOL ("echo-keystrokes-help", echo_keystrokes_help,
+ doc: /* Whether to append help text to echoed commands.
+When non-nil, a reference to `C-h' is printed after echoed
+keystrokes. */);
+ echo_keystrokes_help = true;
+
DEFVAR_LISP ("polling-period", Vpolling_period,
doc: /* Interval between polling for input during Lisp execution.
The reason for polling is to make C-g work to stop a running program.
@@ -12789,6 +13446,10 @@ See also `pre-command-hook'. */);
"display-monitors-changed-functions");
DEFSYM (Qcoding, "coding");
+ DEFSYM (Qtouchscreen, "touchscreen");
+#ifdef HAVE_TEXT_CONVERSION
+ DEFSYM (Qtext_conversion, "text-conversion");
+#endif
Fset (Qecho_area_clear_hook, Qnil);
@@ -13163,9 +13824,25 @@ which see. */);
DEFVAR_LISP ("post-select-region-hook", Vpost_select_region_hook,
doc: /* Abnormal hook run after the region is selected.
This usually happens as a result of `select-active-regions'. The hook
-is called with one argument, the string that was selected. */);;
+is called with one argument, the string that was selected. */);
Vpost_select_region_hook = Qnil;
+ DEFVAR_BOOL ("disable-inhibit-text-conversion",
+ disable_inhibit_text_conversion,
+ doc: /* Don't disable text conversion inside `read-key-sequence'.
+If non-nil, text conversion will continue to happen after a prefix
+key has been read inside `read-key-sequence'. */);
+ disable_inhibit_text_conversion = false;
+
+ DEFVAR_LISP ("current-key-remap-sequence",
+ Vcurrent_key_remap_sequence,
+ doc: /* The key sequence currently being remap, or nil.
+Bound to a vector containing the sub-sequence matching a binding
+within `input-decode-map' or `local-function-key-map' when its bound
+function is called to remap that sequence. */);
+ Vcurrent_key_remap_sequence = Qnil;
+ DEFSYM (Qcurrent_key_remap_sequence, "current-key-remap-sequence");
+
pdumper_do_now_and_after_load (syms_of_keyboard_for_pdumper);
}
diff --git a/src/keyboard.h b/src/keyboard.h
index f451fa2dac4..2ce003fd444 100644
--- a/src/keyboard.h
+++ b/src/keyboard.h
@@ -246,6 +246,14 @@ extern KBOARD *initial_kboard;
kboard, but doing so requires throwing to wrong_kboard_jmpbuf. */
extern KBOARD *current_kboard;
+
+#ifdef HAVE_TEXT_CONVERSION
+
+/* True if a key sequence is currently being read. */
+extern bool reading_key_sequence;
+
+#endif /* HAVE_TEXT_CONVERSION */
+
/* Total number of times read_char has returned, modulo UINTMAX_MAX + 1. */
extern uintmax_t num_input_events;
@@ -388,41 +396,50 @@ extern void unuse_menu_items (void);
/* Macros for dealing with lispy events. */
/* True if EVENT has data fields describing it (i.e. a mouse click). */
-#define EVENT_HAS_PARAMETERS(event) (CONSP (event))
+#define EVENT_HAS_PARAMETERS(event) CONSP (event)
/* Extract the head from an event.
This works on composite and simple events. */
#define EVENT_HEAD(event) \
(EVENT_HAS_PARAMETERS (event) ? XCAR (event) : (event))
-/* Extract the starting and ending positions from a composite event. */
-#define EVENT_START(event) (CAR_SAFE (CDR_SAFE (event)))
-#define EVENT_END(event) (CAR_SAFE (CDR_SAFE (CDR_SAFE (event))))
+/* Extract the starting and ending positions from a composite event. */
+
+/* Unlike Lisp `event-start', this also handles touch screen events,
+ which are not actually mouse events in the general sense. */
+#define EVENT_START(event) \
+ ((EQ (EVENT_HEAD (event), Qtouchscreen_begin) \
+ || EQ (EVENT_HEAD (event), Qtouchscreen_end)) \
+ ? CDR_SAFE (CAR_SAFE (CDR_SAFE (event))) \
+ : CAR_SAFE (CDR_SAFE (event)))
+
+/* This does not handle touchscreen events. */
+#define EVENT_END(event) CAR_SAFE (CDR_SAFE (CDR_SAFE (event)))
/* Extract the click count from a multi-click event. */
-#define EVENT_CLICK_COUNT(event) (Fnth (make_fixnum (2), (event)))
+#define EVENT_CLICK_COUNT(event) Fnth (make_fixnum (2), event)
/* Extract the fields of a position. */
-#define POSN_WINDOW(posn) (CAR_SAFE (posn))
-#define POSN_POSN(posn) (CAR_SAFE (CDR_SAFE (posn)))
-#define POSN_SET_POSN(posn,x) (XSETCAR (XCDR (posn), (x)))
-#define POSN_WINDOW_POSN(posn) (CAR_SAFE (CDR_SAFE (CDR_SAFE (posn))))
-#define POSN_TIMESTAMP(posn) (CAR_SAFE (CDR_SAFE (CDR_SAFE (CDR_SAFE (posn)))))
-#define POSN_SCROLLBAR_PART(posn) (Fnth (make_fixnum (4), (posn)))
+#define POSN_WINDOW(posn) CAR_SAFE (posn)
+#define POSN_POSN(posn) CAR_SAFE (CDR_SAFE (posn))
+#define POSN_SET_POSN(posn,x) XSETCAR (XCDR (posn), x)
+#define POSN_WINDOW_POSN(posn) CAR_SAFE (CDR_SAFE (CDR_SAFE (posn)))
+#define POSN_TIMESTAMP(posn) CAR_SAFE (CDR_SAFE (CDR_SAFE (CDR_SAFE (posn))))
+#define POSN_SCROLLBAR_PART(posn) Fnth (make_fixnum (4), posn)
/* A cons (STRING . STRING-CHARPOS), or nil in mouse-click events.
It's a cons if the click is over a string in the mode line. */
-#define POSN_STRING(posn) (Fnth (make_fixnum (4), (posn)))
+#define POSN_STRING(posn) Fnth (make_fixnum (4), posn)
/* If POSN_STRING is nil, event refers to buffer location. */
-#define POSN_INBUFFER_P(posn) (NILP (POSN_STRING (posn)))
-#define POSN_BUFFER_POSN(posn) (Fnth (make_fixnum (5), (posn)))
+#define POSN_INBUFFER_P(posn) NILP (POSN_STRING (posn))
+#define POSN_BUFFER_POSN(posn) Fnth (make_fixnum (5), posn)
/* Getting the kind of an event head. */
#define EVENT_HEAD_KIND(event_head) \
- (Fget ((event_head), Qevent_kind))
+ Fget (event_head, Qevent_kind)
/* Address (if not 0) of struct timespec to zero out if a SIGIO interrupt
happens. */
@@ -466,6 +483,7 @@ extern void set_poll_suppress_count (int);
extern int gobble_input (void);
extern bool input_polling_used (void);
extern void clear_input_pending (void);
+extern bool requeued_command_events_pending_p (void);
extern bool requeued_events_pending_p (void);
extern void bind_polling_period (int);
extern int make_ctrl_char (int) ATTRIBUTE_CONST;
diff --git a/src/keymap.c b/src/keymap.c
index ae3dca3227b..10378767c65 100644
--- a/src/keymap.c
+++ b/src/keymap.c
@@ -610,7 +610,7 @@ map_keymap_canonical (Lisp_Object map, map_keymap_function_t fun, Lisp_Object ar
{
/* map_keymap_canonical may be used from redisplay (e.g. when building menus)
so be careful to ignore errors and to inhibit redisplay. */
- map = safe_call1 (Qkeymap_canonicalize, map);
+ map = safe_calln (Qkeymap_canonicalize, map);
/* No need to use `map_keymap' here because canonical map has no parent. */
map_keymap_internal (map, fun, args, data);
}
@@ -1367,7 +1367,7 @@ recognize the default bindings, just as `read-key-sequence' does. */)
{
USE_SAFE_ALLOCA;
ptrdiff_t size = SCHARS (key_item), n;
- if (INT_MULTIPLY_WRAPV (size, MAX_MULTIBYTE_LENGTH, &n))
+ if (ckd_mul (&n, size, MAX_MULTIBYTE_LENGTH))
n = PTRDIFF_MAX;
unsigned char *dst = SAFE_ALLOCA (n);
unsigned char *p = dst;
@@ -1415,7 +1415,7 @@ recognize the default bindings, just as `read-key-sequence' does. */)
USE_SAFE_ALLOCA;
ptrdiff_t size = SCHARS (lc_key), n;
- if (INT_MULTIPLY_WRAPV (size, MAX_MULTIBYTE_LENGTH, &n))
+ if (ckd_mul (&n, size, MAX_MULTIBYTE_LENGTH))
n = PTRDIFF_MAX;
unsigned char *dst = SAFE_ALLOCA (n);
@@ -2101,7 +2101,7 @@ For an approximate inverse of this, see `kbd'. */)
/* This has one extra element at the end that we don't pass to Fconcat. */
ptrdiff_t size4;
- if (INT_MULTIPLY_WRAPV (nkeys + nprefix, 4, &size4))
+ if (ckd_mul (&size4, nkeys + nprefix, 4))
memory_full (SIZE_MAX);
SAFE_ALLOCA_LISP (args, size4);
@@ -2885,7 +2885,7 @@ You type Translation\n\
{
Lisp_Object msg = build_unibyte_string ("Key translations");
CALLN (Ffuncall,
- Qdescribe_map_tree,
+ Qhelp__describe_map_tree,
Vkey_translation_map, Qnil, Qnil, prefix,
msg, nomenu, Qt, Qnil, Qnil, buffer);
}
@@ -2899,7 +2899,7 @@ You type Translation\n\
{
Lisp_Object msg = build_unibyte_string ("\f\nOverriding Bindings");
CALLN (Ffuncall,
- Qdescribe_map_tree,
+ Qhelp__describe_map_tree,
start1, Qt, shadow, prefix,
msg, nomenu, Qnil, Qnil, Qnil, buffer);
shadow = Fcons (start1, shadow);
@@ -2912,7 +2912,7 @@ You type Translation\n\
{
Lisp_Object msg = build_unibyte_string ("\f\nOverriding Bindings");
CALLN (Ffuncall,
- Qdescribe_map_tree,
+ Qhelp__describe_map_tree,
start1, Qt, shadow, prefix,
msg, nomenu, Qnil, Qnil, Qnil, buffer);
shadow = Fcons (start1, shadow);
@@ -2935,7 +2935,7 @@ You type Translation\n\
{
Lisp_Object msg = build_unibyte_string ("\f\n`keymap' Property Bindings");
CALLN (Ffuncall,
- Qdescribe_map_tree,
+ Qhelp__describe_map_tree,
start1, Qt, shadow, prefix,
msg, nomenu, Qnil, Qnil, Qnil, buffer);
shadow = Fcons (start1, shadow);
@@ -2946,7 +2946,7 @@ You type Translation\n\
{
/* The title for a minor mode keymap
is constructed at run time.
- We let describe-map-tree do the actual insertion
+ We let `help--describe-map-tree' do the actual insertion
because it takes care of other features when doing so. */
char *title, *p;
@@ -2968,7 +2968,7 @@ You type Translation\n\
Lisp_Object msg = build_unibyte_string (title);
CALLN (Ffuncall,
- Qdescribe_map_tree,
+ Qhelp__describe_map_tree,
maps[i], Qt, shadow, prefix,
msg, nomenu, Qnil, Qnil, Qnil, buffer);
shadow = Fcons (maps[i], shadow);
@@ -2986,7 +2986,7 @@ You type Translation\n\
build_unibyte_string ("\f\n`%s' Major Mode Bindings"),
XBUFFER (buffer)->major_mode_);
CALLN (Ffuncall,
- Qdescribe_map_tree,
+ Qhelp__describe_map_tree,
start1, Qt, shadow, prefix,
msg, nomenu, Qnil, Qnil, Qnil, buffer);
}
@@ -2994,7 +2994,7 @@ You type Translation\n\
{
Lisp_Object msg = build_unibyte_string ("\f\n`local-map' Property Bindings");
CALLN (Ffuncall,
- Qdescribe_map_tree,
+ Qhelp__describe_map_tree,
start1, Qt, shadow, prefix,
msg, nomenu, Qnil, Qnil, Qnil, buffer);
}
@@ -3005,7 +3005,7 @@ You type Translation\n\
Lisp_Object msg = build_unibyte_string ("\f\nGlobal Bindings");
CALLN (Ffuncall,
- Qdescribe_map_tree,
+ Qhelp__describe_map_tree,
current_global_map, Qt, shadow, prefix,
msg, nomenu, Qnil, Qt, Qnil, buffer);
@@ -3014,7 +3014,7 @@ You type Translation\n\
{
Lisp_Object msg = build_unibyte_string ("\f\nFunction key map translations");
CALLN (Ffuncall,
- Qdescribe_map_tree,
+ Qhelp__describe_map_tree,
KVAR (current_kboard, Vlocal_function_key_map), Qnil, Qnil, prefix,
msg, nomenu, Qt, Qnil, Qnil, buffer);
}
@@ -3024,7 +3024,7 @@ You type Translation\n\
{
Lisp_Object msg = build_unibyte_string ("\f\nInput decoding map translations");
CALLN (Ffuncall,
- Qdescribe_map_tree,
+ Qhelp__describe_map_tree,
KVAR (current_kboard, Vinput_decode_map), Qnil, Qnil, prefix,
msg, nomenu, Qt, Qnil, Qnil, buffer);
}
@@ -3341,7 +3341,7 @@ void
syms_of_keymap (void)
{
DEFSYM (Qkeymap, "keymap");
- DEFSYM (Qdescribe_map_tree, "describe-map-tree");
+ DEFSYM (Qhelp__describe_map_tree, "help--describe-map-tree");
DEFSYM (Qkeymap_canonicalize, "keymap-canonicalize");
diff --git a/src/kqueue.c b/src/kqueue.c
index d748f66aca3..4693e130208 100644
--- a/src/kqueue.c
+++ b/src/kqueue.c
@@ -320,13 +320,16 @@ kqueue_callback (int fd, void *data)
directory is monitored. */
if (kev.fflags & NOTE_RENAME)
actions = Fcons (Qrename, actions);
+ if (kev.fflags & NOTE_REVOKE)
+ actions = Fcons (Qrevoke, actions);
/* Create the event. */
if (! NILP (actions))
kqueue_generate_event (watch_object, actions, file, Qnil);
- /* Cancel monitor if file or directory is deleted or renamed. */
- if (kev.fflags & (NOTE_DELETE | NOTE_RENAME))
+ /* Cancel monitor if file or directory is deleted or renamed or
+ the file system is unmounted. */
+ if (kev.fflags & (NOTE_DELETE | NOTE_RENAME | NOTE_REVOKE))
Fkqueue_rm_watch (descriptor);
}
return;
@@ -351,6 +354,7 @@ following symbols:
`attrib' -- a FILE attribute was changed
`link' -- a FILE's link count was changed
`rename' -- FILE was moved to FILE1
+ `revoke' -- FILE was unmounted
When any event happens, Emacs will call the CALLBACK function passing
it a single argument EVENT, which is of the form
@@ -437,6 +441,7 @@ only when the upper directory of the renamed file is watched. */)
if (! NILP (Fmember (Qattrib, flags))) fflags |= NOTE_ATTRIB;
if (! NILP (Fmember (Qlink, flags))) fflags |= NOTE_LINK;
if (! NILP (Fmember (Qrename, flags))) fflags |= NOTE_RENAME;
+ if (! NILP (Fmember (Qrevoke, flags))) fflags |= NOTE_REVOKE;
/* Register event. */
EV_SET (&kev, fd, EVFILT_VNODE, EV_ADD | EV_ENABLE | EV_CLEAR,
@@ -526,6 +531,7 @@ syms_of_kqueue (void)
DEFSYM (Qattrib, "attrib"); /* NOTE_ATTRIB */
DEFSYM (Qlink, "link"); /* NOTE_LINK */
DEFSYM (Qrename, "rename"); /* NOTE_RENAME */
+ DEFSYM (Qrevoke, "revoke"); /* NOTE_REVOKE */
staticpro (&watch_list);
diff --git a/src/lisp.h b/src/lisp.h
index 5fa48cec2f0..f066c876619 100644
--- a/src/lisp.h
+++ b/src/lisp.h
@@ -22,15 +22,22 @@ along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. */
#include <alloca.h>
#include <setjmp.h>
-#include <stdalign.h>
#include <stdarg.h>
+#include <stdckdint.h>
#include <stddef.h>
#include <string.h>
#include <float.h>
#include <inttypes.h>
#include <limits.h>
+#include <stdio.h>
+
+#ifdef HAVE_SYS_STAT_H
+#include <sys/stat.h>
+#endif
#include <attribute.h>
+#include <byteswap.h>
+#include <count-leading-zeros.h>
#include <intprops.h>
#include <verify.h>
@@ -273,7 +280,7 @@ DEFINE_GDB_SYMBOL_END (VALMASK)
emacs_align_type union in alloc.c.
Although these macros are reasonably portable, they are not
- guaranteed on non-GCC platforms, as C11 does not require support
+ guaranteed on non-GCC platforms, as the C standard does not require support
for alignment to GCALIGNMENT and older compilers may ignore
alignment requests. For any type T where garbage collection
requires alignment, use verify (GCALIGNED (T)) to verify the
@@ -297,6 +304,9 @@ DEFINE_GDB_SYMBOL_END (VALMASK)
#define LISP_WORDS_ARE_POINTERS (EMACS_INT_MAX == INTPTR_MAX)
#if LISP_WORDS_ARE_POINTERS
+/* TAG_PTR_INITIALLY casts to Lisp_Word and can be used in static initializers
+ so this typedef assumes static initializers can contain casts to pointers.
+ All Emacs targets support this extension to the C standard. */
typedef struct Lisp_X *Lisp_Word;
#else
typedef EMACS_INT Lisp_Word;
@@ -321,7 +331,8 @@ typedef EMACS_INT Lisp_Word;
without worrying about the implementations diverging, since
lisp_h_OP defines the actual implementation. The lisp_h_OP macros
are intended to be private to this include file, and should not be
- used elsewhere.
+ used elsewhere. They should evaluate each argument exactly once,
+ so that they behave like their functional counterparts.
FIXME: Remove the lisp_h_OP macros, and define just the inline OP
functions, once "gcc -Og" (new to GCC 4.8) or equivalent works well
@@ -363,39 +374,12 @@ typedef EMACS_INT Lisp_Word;
# define lisp_h_Qnil {0}
#endif
-#define lisp_h_PSEUDOVECTORP(a,code) \
- (lisp_h_VECTORLIKEP((a)) && \
- ((XUNTAG ((a), Lisp_Vectorlike, union vectorlike_header)->size \
- & (PSEUDOVECTOR_FLAG | PVEC_TYPE_MASK)) \
- == (PSEUDOVECTOR_FLAG | ((code) << PSEUDOVECTOR_AREA_BITS))))
-
#define lisp_h_CHECK_FIXNUM(x) CHECK_TYPE (FIXNUMP (x), Qfixnump, x)
#define lisp_h_CHECK_SYMBOL(x) CHECK_TYPE (SYMBOLP (x), Qsymbolp, x)
#define lisp_h_CHECK_TYPE(ok, predicate, x) \
((ok) ? (void) 0 : wrong_type_argument (predicate, x))
#define lisp_h_CONSP(x) TAGGEDP (x, Lisp_Cons)
#define lisp_h_BASE_EQ(x, y) (XLI (x) == XLI (y))
-#define lisp_h_BASE2_EQ(x, y) \
- (BASE_EQ (x, y) \
- || (symbols_with_pos_enabled \
- && SYMBOL_WITH_POS_P (x) \
- && BASE_EQ (XSYMBOL_WITH_POS (x)->sym, y)))
-
-/* FIXME: Do we really need to inline the whole thing?
- * What about keeping the part after `symbols_with_pos_enabled` in
- * a separate function? */
-#define lisp_h_EQ(x, y) \
- ((XLI ((x)) == XLI ((y))) \
- || (symbols_with_pos_enabled \
- && (SYMBOL_WITH_POS_P ((x)) \
- ? (BARE_SYMBOL_P ((y)) \
- ? XLI (XSYMBOL_WITH_POS((x))->sym) == XLI (y) \
- : SYMBOL_WITH_POS_P((y)) \
- && (XLI (XSYMBOL_WITH_POS((x))->sym) \
- == XLI (XSYMBOL_WITH_POS((y))->sym))) \
- : (SYMBOL_WITH_POS_P ((y)) \
- && BARE_SYMBOL_P ((x)) \
- && (XLI (x) == XLI ((XSYMBOL_WITH_POS ((y)))->sym))))))
#define lisp_h_FIXNUMP(x) \
(! (((unsigned) (XLI (x) >> (USE_LSB_TAG ? 0 : FIXNUM_BITS)) \
@@ -403,18 +387,11 @@ typedef EMACS_INT Lisp_Word;
& ((1 << INTTYPEBITS) - 1)))
#define lisp_h_FLOATP(x) TAGGEDP (x, Lisp_Float)
#define lisp_h_NILP(x) BASE_EQ (x, Qnil)
-#define lisp_h_SET_SYMBOL_VAL(sym, v) \
- (eassert ((sym)->u.s.redirect == SYMBOL_PLAINVAL), \
- (sym)->u.s.val.value = (v))
#define lisp_h_SYMBOL_CONSTANT_P(sym) \
(XSYMBOL (sym)->u.s.trapped_write == SYMBOL_NOWRITE)
#define lisp_h_SYMBOL_TRAPPED_WRITE_P(sym) (XSYMBOL (sym)->u.s.trapped_write)
-#define lisp_h_SYMBOL_VAL(sym) \
- (eassert ((sym)->u.s.redirect == SYMBOL_PLAINVAL), (sym)->u.s.val.value)
-#define lisp_h_SYMBOL_WITH_POS_P(x) PSEUDOVECTORP ((x), PVEC_SYMBOL_WITH_POS)
-#define lisp_h_BARE_SYMBOL_P(x) TAGGEDP ((x), Lisp_Symbol)
-#define lisp_h_SYMBOLP(x) ((BARE_SYMBOL_P ((x)) || \
- (symbols_with_pos_enabled && (SYMBOL_WITH_POS_P ((x))))))
+#define lisp_h_SYMBOL_WITH_POS_P(x) PSEUDOVECTORP (x, PVEC_SYMBOL_WITH_POS)
+#define lisp_h_BARE_SYMBOL_P(x) TAGGEDP (x, Lisp_Symbol)
#define lisp_h_TAGGEDP(a, tag) \
(! (((unsigned) (XLI (a) >> (USE_LSB_TAG ? 0 : VALBITS)) \
- (unsigned) (tag)) \
@@ -422,8 +399,6 @@ typedef EMACS_INT Lisp_Word;
#define lisp_h_VECTORLIKEP(x) TAGGEDP (x, Lisp_Vectorlike)
#define lisp_h_XCAR(c) XCONS (c)->u.s.car
#define lisp_h_XCDR(c) XCONS (c)->u.s.u.cdr
-#define lisp_h_XCONS(a) \
- (eassert (CONSP (a)), XUNTAG (a, Lisp_Cons, struct Lisp_Cons))
#define lisp_h_XHASH(a) XUFIXNUM_RAW (a)
#if USE_LSB_TAG
# define lisp_h_make_fixnum_wrap(n) \
@@ -465,20 +440,15 @@ typedef EMACS_INT Lisp_Word;
# define CHECK_TYPE(ok, predicate, x) lisp_h_CHECK_TYPE (ok, predicate, x)
# define CONSP(x) lisp_h_CONSP (x)
# define BASE_EQ(x, y) lisp_h_BASE_EQ (x, y)
-# define BASE2_EQ(x, y) lisp_h_BASE2_EQ (x, y)
# define FLOATP(x) lisp_h_FLOATP (x)
# define FIXNUMP(x) lisp_h_FIXNUMP (x)
# define NILP(x) lisp_h_NILP (x)
-# define SET_SYMBOL_VAL(sym, v) lisp_h_SET_SYMBOL_VAL (sym, v)
# define SYMBOL_CONSTANT_P(sym) lisp_h_SYMBOL_CONSTANT_P (sym)
# define SYMBOL_TRAPPED_WRITE_P(sym) lisp_h_SYMBOL_TRAPPED_WRITE_P (sym)
-# define SYMBOL_VAL(sym) lisp_h_SYMBOL_VAL (sym)
-/* # define SYMBOLP(x) lisp_h_SYMBOLP (x) */ /* X is accessed more than once. */
# define TAGGEDP(a, tag) lisp_h_TAGGEDP (a, tag)
# define VECTORLIKEP(x) lisp_h_VECTORLIKEP (x)
# define XCAR(c) lisp_h_XCAR (c)
# define XCDR(c) lisp_h_XCDR (c)
-# define XCONS(a) lisp_h_XCONS (a)
# define XHASH(a) lisp_h_XHASH (a)
# if USE_LSB_TAG
# define make_fixnum(n) lisp_h_make_fixnum (n)
@@ -509,6 +479,16 @@ typedef EMACS_INT Lisp_Word;
#endif
+/* Lisp_Object tagging scheme:
+ Tag location
+ Upper bits Lower bits Type Payload
+ 000....... .......000 symbol offset from lispsym to struct Lisp_Symbol
+ 001....... .......001 unused
+ 01........ ........10 fixnum signed integer of FIXNUM_BITS
+ 110....... .......011 cons pointer to struct Lisp_Cons
+ 100....... .......100 string pointer to struct Lisp_String
+ 101....... .......101 vectorlike pointer to union vectorlike_header
+ 111....... .......111 float pointer to struct Lisp_Float */
enum Lisp_Type
{
/* Symbol. XSYMBOL (object) points to a struct Lisp_Symbol. */
@@ -590,10 +570,8 @@ enum Lisp_Fwd_Type
your object -- this way, the same object could be used to represent
several disparate C structures.
- In addition, you need to add switch branches in data.c for Ftype_of.
-
- You also need to add the new type to the constant
- `cl--typeof-types' in lisp/emacs-lisp/cl-preloaded.el. */
+ In addition, you need to add switch branches in data.c for Fcl_type_of
+ and `cl--define-builtin-type` in lisp/emacs-lisp/cl-preloaded.el. */
/* A Lisp_Object is a tagged pointer or integer. Ordinarily it is a
@@ -802,10 +780,11 @@ INLINE void
}
/* Extract A's pointer value, assuming A's Lisp type is TYPE and the
- extracted pointer's type is CTYPE *. */
-
-#define XUNTAG(a, type, ctype) ((ctype *) \
- ((char *) XLP (a) - LISP_WORD_TAG (type)))
+ extracted pointer's type is CTYPE *. When !USE_LSB_TAG this simply
+ extracts A's low-order bits, as (uintptr_t) LISP_WORD_TAG (type) is
+ always zero then. */
+#define XUNTAG(a, type, ctype) \
+ ((ctype *) ((uintptr_t) XLP (a) - (uintptr_t) LISP_WORD_TAG (type)))
/* A forwarding pointer to a value. It uses a generic pointer to
avoid alignment bugs that could occur if it used a pointer to a
@@ -818,24 +797,24 @@ typedef struct { void const *fwdptr; } lispfwd;
enum symbol_interned
{
- SYMBOL_UNINTERNED = 0,
- SYMBOL_INTERNED = 1,
- SYMBOL_INTERNED_IN_INITIAL_OBARRAY = 2
+ SYMBOL_UNINTERNED, /* not interned anywhere */
+ SYMBOL_INTERNED, /* interned but not in initial obarray */
+ SYMBOL_INTERNED_IN_INITIAL_OBARRAY /* interned in initial obarray */
};
enum symbol_redirect
{
- SYMBOL_PLAINVAL = 4,
- SYMBOL_VARALIAS = 1,
- SYMBOL_LOCALIZED = 2,
- SYMBOL_FORWARDED = 3
+ SYMBOL_PLAINVAL, /* plain var, value is in the `value' field */
+ SYMBOL_VARALIAS, /* var alias, value is really in the `alias' symbol */
+ SYMBOL_LOCALIZED, /* localized var, value is in the `blv' object */
+ SYMBOL_FORWARDED /* forwarding var, value is in `forward' */
};
enum symbol_trapped_write
{
- SYMBOL_UNTRAPPED_WRITE = 0,
- SYMBOL_NOWRITE = 1,
- SYMBOL_TRAPPED_WRITE = 2
+ SYMBOL_UNTRAPPED_WRITE, /* normal case, just set the value */
+ SYMBOL_NOWRITE, /* constant, cannot set, e.g. nil, t, :keyword */
+ SYMBOL_TRAPPED_WRITE /* trap the write, call watcher functions */
};
struct Lisp_Symbol
@@ -846,21 +825,13 @@ struct Lisp_Symbol
{
bool_bf gcmarkbit : 1;
- /* Indicates where the value can be found:
- 0 : it's a plain var, the value is in the `value' field.
- 1 : it's a varalias, the value is really in the `alias' symbol.
- 2 : it's a localized var, the value is in the `blv' object.
- 3 : it's a forwarding variable, the value is in `forward'. */
- ENUM_BF (symbol_redirect) redirect : 3;
+ /* Indicates where the value can be found. */
+ ENUM_BF (symbol_redirect) redirect : 2;
- /* 0 : normal case, just set the value
- 1 : constant, cannot set, e.g. nil, t, :keywords.
- 2 : trap the write, call watcher functions. */
ENUM_BF (symbol_trapped_write) trapped_write : 2;
- /* Interned state of the symbol. This is an enumerator from
- enum symbol_interned. */
- unsigned interned : 2;
+ /* Interned state of the symbol. */
+ ENUM_BF (symbol_interned) interned : 2;
/* True means that this variable has been explicitly declared
special (with `defvar' etc), and shouldn't be lexically bound. */
@@ -920,20 +891,11 @@ verify (GCALIGNED (struct Lisp_Symbol));
#define DEFUN_ARGS_8 (Lisp_Object, Lisp_Object, Lisp_Object, Lisp_Object, \
Lisp_Object, Lisp_Object, Lisp_Object, Lisp_Object)
-/* untagged_ptr represents a pointer before tagging, and Lisp_Word_tag
- contains a possibly-shifted tag to be added to an untagged_ptr to
- convert it to a Lisp_Word. */
+/* Lisp_Word_tag is big enough for a possibly-shifted tag, to be
+ added to a pointer value for conversion to a Lisp_Word. */
#if LISP_WORDS_ARE_POINTERS
-/* untagged_ptr is a pointer so that the compiler knows that TAG_PTR
- yields a pointer. It is char * so that adding a tag uses simple
- machine addition. */
-typedef char *untagged_ptr;
typedef uintptr_t Lisp_Word_tag;
#else
-/* untagged_ptr is an unsigned integer instead of a pointer, so that
- it can be added to the possibly-wider Lisp_Word_tag type without
- losing information. */
-typedef uintptr_t untagged_ptr;
typedef EMACS_UINT Lisp_Word_tag;
#endif
@@ -941,14 +903,16 @@ typedef EMACS_UINT Lisp_Word_tag;
#define LISP_WORD_TAG(tag) \
((Lisp_Word_tag) (tag) << (USE_LSB_TAG ? 0 : VALBITS))
-/* An initializer for a Lisp_Object that contains TAG along with PTR. */
-#define TAG_PTR(tag, ptr) \
- LISP_INITIALLY ((Lisp_Word) ((untagged_ptr) (ptr) + LISP_WORD_TAG (tag)))
+/* An initializer for a Lisp_Object that contains TAG along with P.
+ P can be a pointer or an integer. The result is usable in a static
+ initializer if TAG and P are both integer constant expressions. */
+#define TAG_PTR_INITIALLY(tag, p) \
+ LISP_INITIALLY ((Lisp_Word) ((uintptr_t) (p) + LISP_WORD_TAG (tag)))
/* LISPSYM_INITIALLY (Qfoo) is equivalent to Qfoo except it is
- designed for use as an initializer, even for a constant initializer. */
+ designed for use as a (possibly static) initializer. */
#define LISPSYM_INITIALLY(name) \
- TAG_PTR (Lisp_Symbol, (char *) (intptr_t) ((i##name) * sizeof *lispsym))
+ TAG_PTR_INITIALLY (Lisp_Symbol, (intptr_t) ((i##name) * sizeof *lispsym))
/* Declare extern constants for Lisp symbols. These can be helpful
when using a debugger like GDB, on older platforms where the debug
@@ -996,25 +960,35 @@ typedef EMACS_UINT Lisp_Word_tag;
number of members has been reduced to one. */
union vectorlike_header
{
- /* The main member contains various pieces of information:
- - The MSB (ARRAY_MARK_FLAG) holds the gcmarkbit.
- - The next bit (PSEUDOVECTOR_FLAG) indicates whether this is a plain
- vector (0) or a pseudovector (1).
- - If PSEUDOVECTOR_FLAG is 0, the rest holds the size (number
- of slots) of the vector.
- - If PSEUDOVECTOR_FLAG is 1, the rest is subdivided into three fields:
- - a) pseudovector subtype held in PVEC_TYPE_MASK field;
- - b) number of Lisp_Objects slots at the beginning of the object
- held in PSEUDOVECTOR_SIZE_MASK field. These objects are always
- traced by the GC;
- - c) size of the rest fields held in PSEUDOVECTOR_REST_MASK and
- measured in word_size units. Rest fields may also include
- Lisp_Objects, but these objects usually needs some special treatment
- during GC.
- There are some exceptions. For PVEC_FREE, b) is always zero. For
- PVEC_BOOL_VECTOR and PVEC_SUBR, both b) and c) are always zero.
- Current layout limits the pseudovectors to 63 PVEC_xxx subtypes,
- 4095 Lisp_Objects in GC-ed area and 4095 word-sized other slots. */
+ /* The `size' header word, W bits wide, has one of two forms
+ discriminated by the second-highest bit (PSEUDOVECTOR_FLAG):
+
+ 1 1 W-2
+ +---+---+-------------------------------------+
+ | M | 0 | SIZE | vector
+ +---+---+-------------------------------------+
+
+ 1 1 W-32 6 12 12
+ +---+---+--------+------+----------+----------+
+ | M | 1 | unused | TYPE | RESTSIZE | LISPSIZE | pseudovector
+ +---+---+--------+------+----------+----------+
+
+ M (ARRAY_MARK_FLAG) holds the GC mark bit.
+
+ SIZE is the length (number of slots) of a regular Lisp vector,
+ and the object layout is struct Lisp_Vector.
+
+ TYPE is the pseudovector subtype (enum pvec_type).
+
+ LISPSIZE is the number of Lisp_Object fields at the beginning of the
+ object (after the header). These are always traced by the GC.
+
+ RESTSIZE is the number of fields (in word_size units) following.
+ These are not automatically traced by the GC.
+ For PVEC_BOOL and statically allocated PVEC_SUBR, RESTSIZE is 0.
+ (The block size for PVEC_BOOL is computed from its own size
+ field, to avoid being restricted by the 12-bit RESTSIZE field.)
+ */
ptrdiff_t size;
};
@@ -1057,6 +1031,7 @@ enum pvec_type
PVEC_BOOL_VECTOR,
PVEC_BUFFER,
PVEC_HASH_TABLE,
+ PVEC_OBARRAY,
PVEC_TERMINAL,
PVEC_WINDOW_CONFIGURATION,
PVEC_SUBR,
@@ -1078,7 +1053,8 @@ enum pvec_type
PVEC_CHAR_TABLE,
PVEC_SUB_CHAR_TABLE,
PVEC_RECORD,
- PVEC_FONT /* Should be last because it's used for range checking. */
+ PVEC_FONT,
+ PVEC_TAG_MAX = PVEC_FONT /* Keep this equal to the highest member. */
};
enum More_Lisp_Bits
@@ -1115,7 +1091,10 @@ enum More_Lisp_Bits
INLINE bool
PSEUDOVECTORP (Lisp_Object a, int code)
{
- return lisp_h_PSEUDOVECTORP (a, code);
+ return (lisp_h_VECTORLIKEP (a)
+ && ((XUNTAG (a, Lisp_Vectorlike, union vectorlike_header)->size
+ & (PSEUDOVECTOR_FLAG | PVEC_TYPE_MASK))
+ == (PSEUDOVECTOR_FLAG | (code << PSEUDOVECTOR_AREA_BITS))));
}
INLINE bool
@@ -1131,9 +1110,10 @@ INLINE bool
}
INLINE bool
-(SYMBOLP) (Lisp_Object x)
+SYMBOLP (Lisp_Object x)
{
- return lisp_h_SYMBOLP (x);
+ return (BARE_SYMBOL_P (x)
+ || (symbols_with_pos_enabled && SYMBOL_WITH_POS_P (x)));
}
INLINE struct Lisp_Symbol_With_Pos *
@@ -1143,8 +1123,29 @@ XSYMBOL_WITH_POS (Lisp_Object a)
return XUNTAG (a, Lisp_Vectorlike, struct Lisp_Symbol_With_Pos);
}
+INLINE Lisp_Object
+XSYMBOL_WITH_POS_SYM (Lisp_Object a)
+{
+ Lisp_Object sym = XSYMBOL_WITH_POS (a)->sym;
+ eassume (BARE_SYMBOL_P (sym));
+ return sym;
+}
+
+INLINE Lisp_Object
+XSYMBOL_WITH_POS_POS (Lisp_Object a)
+{
+ return XSYMBOL_WITH_POS (a)->pos;
+}
+
+INLINE Lisp_Object
+maybe_remove_pos_from_symbol (Lisp_Object x)
+{
+ return (symbols_with_pos_enabled && SYMBOL_WITH_POS_P (x)
+ ? XSYMBOL_WITH_POS_SYM (x) : x);
+}
+
INLINE struct Lisp_Symbol * ATTRIBUTE_NO_SANITIZE_UNDEFINED
-(XBARE_SYMBOL) (Lisp_Object a)
+XBARE_SYMBOL (Lisp_Object a)
{
eassert (BARE_SYMBOL_P (a));
intptr_t i = (intptr_t) XUNTAG (a, Lisp_Symbol, struct Lisp_Symbol);
@@ -1153,29 +1154,41 @@ INLINE struct Lisp_Symbol * ATTRIBUTE_NO_SANITIZE_UNDEFINED
}
INLINE struct Lisp_Symbol * ATTRIBUTE_NO_SANITIZE_UNDEFINED
-(XSYMBOL) (Lisp_Object a)
+XSYMBOL (Lisp_Object a)
{
- eassert (SYMBOLP ((a)));
- if (!symbols_with_pos_enabled || BARE_SYMBOL_P (a))
- return XBARE_SYMBOL (a);
- return XBARE_SYMBOL (XSYMBOL_WITH_POS (a)->sym);
+ if (!BARE_SYMBOL_P (a))
+ {
+ eassume (symbols_with_pos_enabled);
+ a = XSYMBOL_WITH_POS_SYM (a);
+ }
+ return XBARE_SYMBOL (a);
}
+/* Internal use only. */
INLINE Lisp_Object
-make_lisp_symbol (struct Lisp_Symbol *sym)
+make_lisp_symbol_internal (struct Lisp_Symbol *sym)
{
/* GCC 7 x86-64 generates faster code if lispsym is
- cast to char * rather than to intptr_t. */
+ cast to char * rather than to intptr_t.
+ Do not use eassert here, so that builtin symbols like Qnil compile to
+ constants; this is needed for some circa-2024 GCCs even with -O2. */
char *symoffset = (char *) ((char *) sym - (char *) lispsym);
- Lisp_Object a = TAG_PTR (Lisp_Symbol, symoffset);
- eassert (XSYMBOL (a) == sym);
+ Lisp_Object a = TAG_PTR_INITIALLY (Lisp_Symbol, symoffset);
+ return a;
+}
+
+INLINE Lisp_Object
+make_lisp_symbol (struct Lisp_Symbol *sym)
+{
+ Lisp_Object a = make_lisp_symbol_internal (sym);
+ eassert (XBARE_SYMBOL (a) == sym);
return a;
}
INLINE Lisp_Object
builtin_lisp_symbol (int index)
{
- return make_lisp_symbol (&lispsym[index]);
+ return make_lisp_symbol_internal (&lispsym[index]);
}
INLINE bool
@@ -1334,20 +1347,15 @@ INLINE bool
return lisp_h_BASE_EQ (x, y);
}
-/* Return true if X and Y are the same object, reckoning X to be the
- same as a bare symbol Y if X is Y with position. */
-INLINE bool
-(BASE2_EQ) (Lisp_Object x, Lisp_Object y)
-{
- return lisp_h_BASE2_EQ (x, y);
-}
-
/* Return true if X and Y are the same object, reckoning a symbol with
position as being the same as the bare symbol. */
INLINE bool
-(EQ) (Lisp_Object x, Lisp_Object y)
+EQ (Lisp_Object x, Lisp_Object y)
{
- return lisp_h_EQ (x, y);
+ return BASE_EQ ((symbols_with_pos_enabled && SYMBOL_WITH_POS_P (x)
+ ? XSYMBOL_WITH_POS_SYM (x) : x),
+ (symbols_with_pos_enabled && SYMBOL_WITH_POS_P (y)
+ ? XSYMBOL_WITH_POS_SYM (y) : y));
}
INLINE intmax_t
@@ -1361,7 +1369,7 @@ clip_to_bounds (intmax_t lower, intmax_t num, intmax_t upper)
INLINE Lisp_Object
make_lisp_ptr (void *ptr, enum Lisp_Type type)
{
- Lisp_Object a = TAG_PTR (type, ptr);
+ Lisp_Object a = TAG_PTR_INITIALLY (type, ptr);
eassert (TAGGEDP (a, type) && XUNTAG (a, type, char) == ptr);
return a;
}
@@ -1406,19 +1414,19 @@ dead_object (void)
== (PSEUDOVECTOR_FLAG | (code << PSEUDOVECTOR_AREA_BITS))))
#define XSETWINDOW_CONFIGURATION(a, b) \
- (XSETPSEUDOVECTOR (a, b, PVEC_WINDOW_CONFIGURATION))
-#define XSETPROCESS(a, b) (XSETPSEUDOVECTOR (a, b, PVEC_PROCESS))
-#define XSETWINDOW(a, b) (XSETPSEUDOVECTOR (a, b, PVEC_WINDOW))
-#define XSETTERMINAL(a, b) (XSETPSEUDOVECTOR (a, b, PVEC_TERMINAL))
-#define XSETSUBR(a, b) (XSETPSEUDOVECTOR (a, b, PVEC_SUBR))
-#define XSETBUFFER(a, b) (XSETPSEUDOVECTOR (a, b, PVEC_BUFFER))
-#define XSETCHAR_TABLE(a, b) (XSETPSEUDOVECTOR (a, b, PVEC_CHAR_TABLE))
-#define XSETBOOL_VECTOR(a, b) (XSETPSEUDOVECTOR (a, b, PVEC_BOOL_VECTOR))
-#define XSETSUB_CHAR_TABLE(a, b) (XSETPSEUDOVECTOR (a, b, PVEC_SUB_CHAR_TABLE))
-#define XSETTHREAD(a, b) (XSETPSEUDOVECTOR (a, b, PVEC_THREAD))
-#define XSETMUTEX(a, b) (XSETPSEUDOVECTOR (a, b, PVEC_MUTEX))
-#define XSETCONDVAR(a, b) (XSETPSEUDOVECTOR (a, b, PVEC_CONDVAR))
-#define XSETNATIVE_COMP_UNIT(a, b) (XSETPSEUDOVECTOR (a, b, PVEC_NATIVE_COMP_UNIT))
+ XSETPSEUDOVECTOR (a, b, PVEC_WINDOW_CONFIGURATION)
+#define XSETPROCESS(a, b) XSETPSEUDOVECTOR (a, b, PVEC_PROCESS)
+#define XSETWINDOW(a, b) XSETPSEUDOVECTOR (a, b, PVEC_WINDOW)
+#define XSETTERMINAL(a, b) XSETPSEUDOVECTOR (a, b, PVEC_TERMINAL)
+#define XSETSUBR(a, b) XSETPSEUDOVECTOR (a, b, PVEC_SUBR)
+#define XSETBUFFER(a, b) XSETPSEUDOVECTOR (a, b, PVEC_BUFFER)
+#define XSETCHAR_TABLE(a, b) XSETPSEUDOVECTOR (a, b, PVEC_CHAR_TABLE)
+#define XSETBOOL_VECTOR(a, b) XSETPSEUDOVECTOR (a, b, PVEC_BOOL_VECTOR)
+#define XSETSUB_CHAR_TABLE(a, b) XSETPSEUDOVECTOR (a, b, PVEC_SUB_CHAR_TABLE)
+#define XSETTHREAD(a, b) XSETPSEUDOVECTOR (a, b, PVEC_THREAD)
+#define XSETMUTEX(a, b) XSETPSEUDOVECTOR (a, b, PVEC_MUTEX)
+#define XSETCONDVAR(a, b) XSETPSEUDOVECTOR (a, b, PVEC_CONDVAR)
+#define XSETNATIVE_COMP_UNIT(a, b) XSETPSEUDOVECTOR (a, b, PVEC_NATIVE_COMP_UNIT)
/* Efficiently convert a pointer to a Lisp object and back. The
pointer is represented as a fixnum, so the garbage collector
@@ -1434,7 +1442,7 @@ XFIXNUMPTR (Lisp_Object a)
INLINE Lisp_Object
make_pointer_integer_unsafe (void *p)
{
- Lisp_Object a = TAG_PTR (Lisp_Int0, p);
+ Lisp_Object a = TAG_PTR_INITIALLY (Lisp_Int0, p);
return a;
}
@@ -1492,9 +1500,10 @@ CHECK_CONS (Lisp_Object x)
}
INLINE struct Lisp_Cons *
-(XCONS) (Lisp_Object a)
+XCONS (Lisp_Object a)
{
- return lisp_h_XCONS (a);
+ eassert (CONSP (a));
+ return XUNTAG (a, Lisp_Cons, struct Lisp_Cons);
}
/* Take the car or cdr of something known to be a cons cell. */
@@ -1874,6 +1883,30 @@ bool_vector_bytes (EMACS_INT size)
return (size + BOOL_VECTOR_BITS_PER_CHAR - 1) / BOOL_VECTOR_BITS_PER_CHAR;
}
+INLINE bits_word
+bits_word_to_host_endian (bits_word val)
+{
+#ifndef WORDS_BIGENDIAN
+ return val;
+#else
+ if (BITS_WORD_MAX >> 31 == 1)
+ return bswap_32 (val);
+ if (BITS_WORD_MAX >> 31 >> 31 >> 1 == 1)
+ return bswap_64 (val);
+ {
+ int i;
+ bits_word r = 0;
+ for (i = 0; i < sizeof val; i++)
+ {
+ r = ((r << 1 << (CHAR_BIT - 1))
+ | (val & ((1u << 1 << (CHAR_BIT - 1)) - 1)));
+ val = val >> 1 >> (CHAR_BIT - 1);
+ }
+ return r;
+ }
+#endif
+}
+
INLINE bool
BOOL_VECTOR_P (Lisp_Object a)
{
@@ -2025,9 +2058,7 @@ ASCII_CHAR_P (intmax_t c)
range of characters. A sub-char-table is like a vector, but with
two integer fields between the header and Lisp data, which means
that it has to be marked with some precautions (see mark_char_table
- in alloc.c). A sub-char-table appears only in an element of a
- char-table, and there's no way to access it directly from a Lisp
- program. */
+ in alloc.c). A sub-char-table appears in an element of a char-table. */
enum CHARTAB_SIZE_BITS
{
@@ -2281,9 +2312,10 @@ typedef jmp_buf sys_jmp_buf;
/* Value is name of symbol. */
INLINE Lisp_Object
-(SYMBOL_VAL) (struct Lisp_Symbol *sym)
+SYMBOL_VAL (struct Lisp_Symbol *sym)
{
- return lisp_h_SYMBOL_VAL (sym);
+ eassert (sym->u.s.redirect == SYMBOL_PLAINVAL);
+ return sym->u.s.val.value;
}
INLINE struct Lisp_Symbol *
@@ -2306,9 +2338,10 @@ SYMBOL_FWD (struct Lisp_Symbol *sym)
}
INLINE void
-(SET_SYMBOL_VAL) (struct Lisp_Symbol *sym, Lisp_Object v)
+SET_SYMBOL_VAL (struct Lisp_Symbol *sym, Lisp_Object v)
{
- lisp_h_SET_SYMBOL_VAL (sym, v);
+ eassert (sym->u.s.redirect == SYMBOL_PLAINVAL);
+ sym->u.s.val.value = v;
}
INLINE void
@@ -2377,6 +2410,118 @@ INLINE int
definition is done by lread.c's define_symbol. */
#define DEFSYM(sym, name) /* empty */
+
+struct Lisp_Obarray
+{
+ union vectorlike_header header;
+
+ /* Array of 2**size_bits values, each being either a (bare) symbol or
+ the fixnum 0. The symbols for each bucket are chained via
+ their s.next field. */
+ Lisp_Object *buckets;
+
+ unsigned size_bits; /* log2(size of buckets vector) */
+ unsigned count; /* number of symbols in obarray */
+};
+
+INLINE bool
+OBARRAYP (Lisp_Object a)
+{
+ return PSEUDOVECTORP (a, PVEC_OBARRAY);
+}
+
+INLINE struct Lisp_Obarray *
+XOBARRAY (Lisp_Object a)
+{
+ eassert (OBARRAYP (a));
+ return XUNTAG (a, Lisp_Vectorlike, struct Lisp_Obarray);
+}
+
+INLINE void
+CHECK_OBARRAY (Lisp_Object x)
+{
+ CHECK_TYPE (OBARRAYP (x), Qobarrayp, x);
+}
+
+INLINE Lisp_Object
+make_lisp_obarray (struct Lisp_Obarray *o)
+{
+ eassert (PSEUDOVECTOR_TYPEP (&o->header, PVEC_OBARRAY));
+ return make_lisp_ptr (o, Lisp_Vectorlike);
+}
+
+INLINE ptrdiff_t
+obarray_size (const struct Lisp_Obarray *o)
+{
+ return (ptrdiff_t)1 << o->size_bits;
+}
+
+Lisp_Object check_obarray_slow (Lisp_Object);
+
+/* Return an obarray object from OBARRAY or signal an error. */
+INLINE Lisp_Object
+check_obarray (Lisp_Object obarray)
+{
+ return OBARRAYP (obarray) ? obarray : check_obarray_slow (obarray);
+}
+
+/* Obarray iterator state. Don't access these members directly.
+ The iterator functions must be called in the order followed by DOOBARRAY. */
+typedef struct {
+ struct Lisp_Obarray *o;
+ ptrdiff_t idx; /* Current bucket index. */
+ struct Lisp_Symbol *symbol; /* Current symbol, or NULL if at end
+ of current bucket. */
+} obarray_iter_t;
+
+INLINE obarray_iter_t
+make_obarray_iter (struct Lisp_Obarray *oa)
+{
+ return (obarray_iter_t){.o = oa, .idx = -1, .symbol = NULL};
+}
+
+/* Whether IT has reached the end and there are no more symbols.
+ If true, IT is dead and cannot be used any more. */
+INLINE bool
+obarray_iter_at_end (obarray_iter_t *it)
+{
+ if (it->symbol)
+ return false;
+ ptrdiff_t size = obarray_size (it->o);
+ while (++it->idx < size)
+ {
+ Lisp_Object obj = it->o->buckets[it->idx];
+ if (!BASE_EQ (obj, make_fixnum (0)))
+ {
+ it->symbol = XBARE_SYMBOL (obj);
+ return false;
+ }
+ }
+ return true;
+}
+
+/* Advance IT to the next symbol if any. */
+INLINE void
+obarray_iter_step (obarray_iter_t *it)
+{
+ it->symbol = it->symbol->u.s.next;
+}
+
+/* The Lisp symbol at IT, if obarray_iter_at_end returned false. */
+INLINE Lisp_Object
+obarray_iter_symbol (obarray_iter_t *it)
+{
+ return make_lisp_symbol (it->symbol);
+}
+
+/* Iterate IT over the symbols of the obarray OA.
+ The body shouldn't add or remove symbols in OA, but disobeying that rule
+ only risks symbols to be iterated more than once or not at all,
+ not crashes or data corruption. */
+#define DOOBARRAY(oa, it) \
+ for (obarray_iter_t it = make_obarray_iter (oa); \
+ !obarray_iter_at_end (&it); obarray_iter_step (&it))
+
/***********************************************************************
Hash Tables
@@ -2386,10 +2531,23 @@ INLINE int
struct Lisp_Hash_Table;
+/* The type of a hash value stored in the table.
+ It's unsigned and a subtype of EMACS_UINT. */
+typedef uint32_t hash_hash_t;
+
+typedef enum {
+ Test_eql,
+ Test_eq,
+ Test_equal,
+} hash_table_std_test_t;
+
struct hash_table_test
{
- /* Name of the function used to compare keys. */
- Lisp_Object name;
+ /* C function to compute hash code. */
+ hash_hash_t (*hashfn) (Lisp_Object, struct Lisp_Hash_Table *);
+
+ /* C function to compare two keys. */
+ Lisp_Object (*cmpfn) (Lisp_Object, Lisp_Object, struct Lisp_Hash_Table *);
/* User-supplied hash function, or nil. */
Lisp_Object user_hash_function;
@@ -2397,78 +2555,109 @@ struct hash_table_test
/* User-supplied key comparison function, or nil. */
Lisp_Object user_cmp_function;
- /* C function to compare two keys. */
- Lisp_Object (*cmpfn) (Lisp_Object, Lisp_Object, struct Lisp_Hash_Table *);
-
- /* C function to compute hash code. */
- Lisp_Object (*hashfn) (Lisp_Object, struct Lisp_Hash_Table *);
+ /* Function used to compare keys; always a bare symbol. */
+ Lisp_Object name;
};
+typedef enum {
+ Weak_None, /* No weak references. */
+ Weak_Key, /* Reference to key is weak. */
+ Weak_Value, /* Reference to value is weak. */
+ Weak_Key_Or_Value, /* References to key or value are weak:
+ element kept as long as strong reference to
+ either key or value remains. */
+ Weak_Key_And_Value, /* References to key and value are weak:
+ element kept as long as strong references to
+ both key and value remain. */
+} hash_table_weakness_t;
+
+/* The type of a hash table index, both for table indices and index
+ (hash) indices. It's signed and a subtype of ptrdiff_t. */
+typedef int32_t hash_idx_t;
+
struct Lisp_Hash_Table
{
- /* Change pdumper.c if you change the fields here. */
-
- /* This is for Lisp; the hash table code does not refer to it. */
union vectorlike_header header;
- /* Nil if table is non-weak. Otherwise a symbol describing the
- weakness of the table. */
- Lisp_Object weak;
+ /* Hash table internal structure:
+
+ Lisp key index table
+ | vector
+ | hash fn hash key value next
+ v +--+ +------+-------+------+----+
+ hash value |-1| | C351 | cow | moo | -1 |<-
+ | +--+ +------+-------+------+----+ |
+ ------------>| -------->| 07A8 | cat | meow | -1 | |
+ range +--+ +------+-------+------+----+ |
+ reduction |-1| ->| 91D2 | dog | woof | ----
+ +--+ | +------+-------+------+----+
+ | ------ | ? |unbound| ? | -1 |<-
+ +--+ +------+-------+------+----+ |
+ | -------->| F6B0 | duck |quack | -1 | |
+ +--+ +------+-------+------+----+ |
+ |-1| ->| ? |unbound| ? | ----
+ +--+ | +------+-------+------+----+
+ : : | : : : : :
+ |
+ next_free
+
+ The table is physically split into three vectors (hash, next,
+ key_and_value) which may or may not be beneficial. */
+
+ /* Bucket vector. An entry of -1 indicates no item is present,
+ and a nonnegative entry is the index of the first item in
+ a collision chain.
+ This vector is 2**index_bits entries long.
+ If index_bits is 0 (and table_size is 0), then this is the
+ constant read-only vector {-1}, shared between all instances.
+ Otherwise it is heap-allocated. */
+ hash_idx_t *index;
+
+ /* Vector of hash codes. Unused entries have undefined values.
+ This vector is table_size entries long. */
+ hash_hash_t *hash;
- /* Vector of hash codes, or nil if the table needs rehashing.
- If the I-th entry is unused, then hash[I] should be nil. */
- Lisp_Object hash;
+ /* Vector of keys and values. The key of item I is found at index
+ 2 * I, the value is found at index 2 * I + 1.
+ If the key is HASH_UNUSED_ENTRY_KEY, then this slot is unused.
+ This is gc_marked specially if the table is weak.
+ This vector is 2 * table_size entries long. */
+ Lisp_Object *key_and_value;
+
+ /* The comparison and hash functions. */
+ const struct hash_table_test *test;
/* Vector used to chain entries. If entry I is free, next[I] is the
entry number of the next free item. If entry I is non-free,
next[I] is the index of the next entry in the collision chain,
- or -1 if there is such entry. */
- Lisp_Object next;
-
- /* Bucket vector. An entry of -1 indicates no item is present,
- and a nonnegative entry is the index of the first item in
- a collision chain. This vector's size can be larger than the
- hash table size to reduce collisions. */
- Lisp_Object index;
-
- /* Only the fields above are traced normally by the GC. The ones after
- 'index' are special and are either ignored by the GC or traced in
- a special way (e.g. because of weakness). */
+ or -1 if there is no such entry.
+ This vector is table_size entries long. */
+ hash_idx_t *next;
/* Number of key/value entries in the table. */
- ptrdiff_t count;
+ hash_idx_t count;
/* Index of first free entry in free list, or -1 if none. */
- ptrdiff_t next_free;
+ hash_idx_t next_free;
+
+ hash_idx_t table_size; /* Size of the next and hash vectors. */
+
+ unsigned char index_bits; /* log2 (size of the index vector). */
+
+ /* Weakness of the table. */
+ hash_table_weakness_t weakness : 3;
+
+ /* Hash table test (only used when frozen in dump) */
+ hash_table_std_test_t frozen_test : 2;
/* True if the table can be purecopied. The table cannot be
changed afterwards. */
- bool purecopy;
+ bool_bf purecopy : 1;
/* True if the table is mutable. Ordinarily tables are mutable, but
pure tables are not, and while a table is being mutated it is
immutable for recursive attempts to mutate it. */
- bool mutable;
-
- /* Resize hash table when number of entries / table size is >= this
- ratio. */
- float rehash_threshold;
-
- /* Used when the table is resized. If equal to a negative integer,
- the user rehash-size is the integer -REHASH_SIZE, and the new
- size is the old size plus -REHASH_SIZE. If positive, the user
- rehash-size is the floating-point value REHASH_SIZE + 1, and the
- new size is the old size times REHASH_SIZE + 1. */
- float rehash_size;
-
- /* Vector of keys and values. The key of item I is found at index
- 2 * I, the value is found at index 2 * I + 1.
- If the key is equal to Qunbound, then this slot is unused.
- This is gc_marked specially if the table is weak. */
- Lisp_Object key_and_value;
-
- /* The comparison and hash functions. */
- struct hash_table_test test;
+ bool_bf mutable : 1;
/* Next weak hash table if this is a weak hash table. The head of
the list is in weak_hash_tables. Used only during garbage
@@ -2476,8 +2665,20 @@ struct Lisp_Hash_Table
struct Lisp_Hash_Table *next_weak;
} GCALIGNED_STRUCT;
-/* Sanity-check pseudovector layout. */
-verify (offsetof (struct Lisp_Hash_Table, weak) == header_size);
+/* A specific Lisp_Object that is not a valid Lisp value.
+ We need to be careful not to leak this value into machinery
+ where it may be treated as one; we'd get a segfault if lucky. */
+#define INVALID_LISP_VALUE make_lisp_ptr (NULL, Lisp_Float)
+
+/* Key value that marks an unused hash table entry. */
+#define HASH_UNUSED_ENTRY_KEY INVALID_LISP_VALUE
+
+/* KEY is a key of an unused hash table entry. */
+INLINE bool
+hash_unused_entry_key_p (Lisp_Object key)
+{
+ return BASE_EQ (key, HASH_UNUSED_ENTRY_KEY);
+}
INLINE bool
HASH_TABLE_P (Lisp_Object a)
@@ -2492,54 +2693,97 @@ XHASH_TABLE (Lisp_Object a)
return XUNTAG (a, Lisp_Vectorlike, struct Lisp_Hash_Table);
}
-#define XSET_HASH_TABLE(VAR, PTR) \
- (XSETPSEUDOVECTOR (VAR, PTR, PVEC_HASH_TABLE))
+INLINE Lisp_Object
+make_lisp_hash_table (struct Lisp_Hash_Table *h)
+{
+ eassert (PSEUDOVECTOR_TYPEP (&h->header, PVEC_HASH_TABLE));
+ return make_lisp_ptr (h, Lisp_Vectorlike);
+}
/* Value is the key part of entry IDX in hash table H. */
INLINE Lisp_Object
HASH_KEY (const struct Lisp_Hash_Table *h, ptrdiff_t idx)
{
- return AREF (h->key_and_value, 2 * idx);
+ eassert (idx >= 0 && idx < h->table_size);
+ return h->key_and_value[2 * idx];
}
/* Value is the value part of entry IDX in hash table H. */
INLINE Lisp_Object
HASH_VALUE (const struct Lisp_Hash_Table *h, ptrdiff_t idx)
{
- return AREF (h->key_and_value, 2 * idx + 1);
+ eassert (idx >= 0 && idx < h->table_size);
+ return h->key_and_value[2 * idx + 1];
}
/* Value is the hash code computed for entry IDX in hash table H. */
-INLINE Lisp_Object
+INLINE hash_hash_t
HASH_HASH (const struct Lisp_Hash_Table *h, ptrdiff_t idx)
{
- return AREF (h->hash, idx);
+ eassert (idx >= 0 && idx < h->table_size);
+ return h->hash[idx];
}
/* Value is the size of hash table H. */
INLINE ptrdiff_t
HASH_TABLE_SIZE (const struct Lisp_Hash_Table *h)
{
- ptrdiff_t size = ASIZE (h->next);
- eassume (0 < size);
- return size;
+ return h->table_size;
}
-void hash_table_rehash (Lisp_Object);
+/* Size of the index vector in hash table H. */
+INLINE ptrdiff_t
+hash_table_index_size (const struct Lisp_Hash_Table *h)
+{
+ return (ptrdiff_t)1 << h->index_bits;
+}
+
+/* Hash value for KEY in hash table H. */
+INLINE hash_hash_t
+hash_from_key (struct Lisp_Hash_Table *h, Lisp_Object key)
+{
+ return h->test->hashfn (key, h);
+}
+
+/* Iterate K and V as key and value of valid entries in hash table H.
+ The body may remove the current entry or alter its value slot, but not
+ mutate TABLE in any other way. */
+#define DOHASH(h, k, v) \
+ for (Lisp_Object *dohash_##k##_##v##_kv = (h)->key_and_value, \
+ *dohash_##k##_##v##_end = dohash_##k##_##v##_kv \
+ + 2 * HASH_TABLE_SIZE (h), \
+ *dohash_##k##_##v##_base = dohash_##k##_##v##_kv, \
+ k, v; \
+ dohash_##k##_##v##_kv < dohash_##k##_##v##_end \
+ && (k = dohash_##k##_##v##_kv[0], \
+ v = dohash_##k##_##v##_kv[1], /*maybe unused*/ (void)v, \
+ true); \
+ eassert (dohash_##k##_##v##_base == (h)->key_and_value \
+ && dohash_##k##_##v##_end \
+ == dohash_##k##_##v##_base \
+ + 2 * HASH_TABLE_SIZE (h)), \
+ dohash_##k##_##v##_kv += 2) \
+ if (hash_unused_entry_key_p (k)) \
+ ; \
+ else
+
+/* Iterate I as index of valid entries in hash table H.
+ Unlike DOHASH, this construct copes with arbitrary table mutations
+ in the body. The consequences of such mutations are limited to
+ whether and in what order entries are encountered by the loop
+ (which is usually bad enough), but not crashing or corrupting the
+ Lisp state. */
+#define DOHASH_SAFE(h, i) \
+ for (ptrdiff_t i = 0; i < HASH_TABLE_SIZE (h); i++) \
+ if (hash_unused_entry_key_p (HASH_KEY (h, i))) \
+ ; \
+ else
+
+void hash_table_thaw (Lisp_Object hash_table);
/* Default size for hash tables if not specified. */
-enum DEFAULT_HASH_SIZE { DEFAULT_HASH_SIZE = 65 };
-
-/* Default threshold specifying when to resize a hash table. The
- value gives the ratio of current entries in the hash table and the
- size of the hash table. */
-
-static float const DEFAULT_REHASH_THRESHOLD = 0.8125;
-
-/* Default factor by which to increase the size of a hash table, minus 1. */
-
-static float const DEFAULT_REHASH_SIZE = 1.5 - 1;
+enum DEFAULT_HASH_SIZE { DEFAULT_HASH_SIZE = 0 };
/* Combine two integers X and Y for hashing. The result might exceed
INTMASK. */
@@ -2558,6 +2802,28 @@ SXHASH_REDUCE (EMACS_UINT x)
return (x ^ x >> (EMACS_INT_WIDTH - FIXNUM_BITS)) & INTMASK;
}
+/* Reduce an EMACS_UINT hash value to hash_hash_t. */
+INLINE hash_hash_t
+reduce_emacs_uint_to_hash_hash (EMACS_UINT x)
+{
+ verify (sizeof x <= 2 * sizeof (hash_hash_t));
+ return (sizeof x == sizeof (hash_hash_t)
+ ? x
+ : x ^ (x >> (8 * (sizeof x - sizeof (hash_hash_t)))));
+}
+
+/* Reduce HASH to a value BITS wide. */
+INLINE ptrdiff_t
+knuth_hash (hash_hash_t hash, unsigned bits)
+{
+ /* Knuth multiplicative hashing, tailored for 32-bit indices
+ (avoiding a 64-bit multiply). */
+ uint32_t alpha = 2654435769; /* 2**32/phi */
+ /* Note the cast to uint64_t, to make it work for bits=0. */
+ return (uint64_t)((uint32_t)hash * alpha) >> (32 - bits);
+}
+
+
struct Lisp_Marker
{
union vectorlike_header header;
@@ -2642,7 +2908,7 @@ extern Lisp_Object make_misc_ptr (void *);
INLINE Lisp_Object
make_mint_ptr (void *a)
{
- Lisp_Object val = TAG_PTR (Lisp_Int0, a);
+ Lisp_Object val = TAG_PTR_INITIALLY (Lisp_Int0, a);
return FIXNUMP (val) && XFIXNUMPTR (val) == a ? val : make_misc_ptr (a);
}
@@ -2736,22 +3002,6 @@ XOVERLAY (Lisp_Object a)
return XUNTAG (a, Lisp_Vectorlike, struct Lisp_Overlay);
}
-INLINE Lisp_Object
-SYMBOL_WITH_POS_SYM (Lisp_Object a)
-{
- if (!SYMBOL_WITH_POS_P (a))
- wrong_type_argument (Qsymbol_with_pos_p, a);
- return XSYMBOL_WITH_POS (a)->sym;
-}
-
-INLINE Lisp_Object
-SYMBOL_WITH_POS_POS (Lisp_Object a)
-{
- if (!SYMBOL_WITH_POS_P (a))
- wrong_type_argument (Qsymbol_with_pos_p, a);
- return XSYMBOL_WITH_POS (a)->pos;
-}
-
INLINE bool
USER_PTRP (Lisp_Object x)
{
@@ -2964,9 +3214,10 @@ XFLOAT_DATA (Lisp_Object f)
/* Most hosts nowadays use IEEE floating point, so they use IEC 60559
representations, have infinities and NaNs, and do not trap on
exceptions. Define IEEE_FLOATING_POINT to 1 if this host is one of the
- typical ones. The C11 macro __STDC_IEC_559__ is close to what is
+ typical ones. The C23 macro __STDC_IEC_60559_BFP__ (or its
+ obsolescent C11 counterpart __STDC_IEC_559__) is close to what is
wanted here, but is not quite right because Emacs does not require
- all the features of C11 Annex F (and does not require C11 at all,
+ all the features of C23 Annex F (and does not require C11 or later,
for that matter). */
#define IEEE_FLOATING_POINT (FLT_RADIX == 2 && FLT_MANT_DIG == 24 \
@@ -3233,77 +3484,25 @@ enum maxargs
empty initializers), and is overkill for simple usages like
'Finsert (1, &text);'. */
#define CALLN(f, ...) CALLMANY (f, ((Lisp_Object []) {__VA_ARGS__}))
-
-/* Call function fn on no arguments. */
+#define calln(...) CALLN (Ffuncall, __VA_ARGS__)
+/* Compatibility aliases. */
+#define call1 calln
+#define call2 calln
+#define call3 calln
+#define call4 calln
+#define call5 calln
+#define call6 calln
+#define call7 calln
+#define call8 calln
+
+/* Define 'call0' as a function rather than a CPP macro because we
+ sometimes want to pass it as a first class function. */
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 *);
@@ -3595,7 +3794,8 @@ record_in_backtrace (Lisp_Object function, Lisp_Object *args, ptrdiff_t nargs)
}
/* This structure helps implement the `catch/throw' and `condition-case/signal'
- control structures. A struct handler contains all the information needed to
+ control structures as well as 'handler-bind'.
+ A struct handler contains all the information needed to
restore the state of the interpreter after a non-local jump.
Handler structures are chained together in a doubly linked list; the `next'
@@ -3616,9 +3816,41 @@ record_in_backtrace (Lisp_Object function, Lisp_Object *args, ptrdiff_t nargs)
state.
Members are volatile if their values need to survive _longjmp when
- a 'struct handler' is a local variable. */
-
-enum handlertype { CATCHER, CONDITION_CASE, CATCHER_ALL };
+ a 'struct handler' is a local variable.
+
+ When running the HANDLER of a 'handler-bind', we need to
+ temporarily "mute" the CONDITION_CASEs and HANDLERs that are "below"
+ the current handler, but without hiding any CATCHERs. We do that by
+ installing a SKIP_CONDITIONS which tells the search to skip the
+ N next conditions. */
+
+enum handlertype {
+ CATCHER, /* Entry for 'catch'.
+ 'tag_or_ch' holds the catch's tag.
+ 'val' holds the retval during longjmp. */
+ CONDITION_CASE, /* Entry for 'condition-case'.
+ 'tag_or_ch' holds the list of conditions.
+ 'val' holds the retval during longjmp. */
+ CATCHER_ALL, /* Wildcard which catches all 'throw's.
+ 'tag_or_ch' is unused.
+ 'val' holds the retval during longjmp. */
+ HANDLER_BIND, /* Entry for 'handler-bind'.
+ 'tag_or_ch' holds the list of conditions.
+ 'val' holds the handler function.
+ The rest of the handler is unused,
+ except for 'bytecode_dest' that holds
+ the number of preceding HANDLER_BIND
+ entries which belong to the same
+ 'handler-bind' (and hence need to
+ be muted together). */
+ SKIP_CONDITIONS /* Mask out the N preceding entries.
+ Used while running the handler of
+ a HANDLER_BIND to hides the condition
+ handlers underneath (and including)
+ the 'handler-bind'.
+ 'tag_or_ch' holds that number, the rest
+ is unused. */
+};
enum nonlocal_exit
{
@@ -3764,13 +3996,15 @@ vcopy (Lisp_Object v, ptrdiff_t offset, Lisp_Object const *args,
INLINE void
set_hash_key_slot (struct Lisp_Hash_Table *h, ptrdiff_t idx, Lisp_Object val)
{
- gc_aset (h->key_and_value, 2 * idx, val);
+ eassert (idx >= 0 && idx < h->table_size);
+ h->key_and_value[2 * idx] = val;
}
INLINE void
set_hash_value_slot (struct Lisp_Hash_Table *h, ptrdiff_t idx, Lisp_Object val)
{
- gc_aset (h->key_and_value, 2 * idx + 1, val);
+ eassert (idx >= 0 && idx < h->table_size);
+ h->key_and_value[2 * idx + 1] = val;;
}
/* Use these functions to set Lisp_Object
@@ -3913,6 +4147,13 @@ integer_to_uintmax (Lisp_Object num, uintmax_t *n)
}
}
+/* Return floor (log2 (N)) as an int, where 0 < N <= ULLONG_MAX. */
+INLINE int
+elogb (unsigned long long int n)
+{
+ return ULLONG_WIDTH - 1 - count_leading_zeros_ll (n);
+}
+
/* A modification count. These are wide enough, and incremented
rarely enough, so that they should never overflow a 60-bit counter
in practice, and the code below assumes this so a compiler can
@@ -3922,12 +4163,13 @@ typedef intmax_t modiff_count;
INLINE modiff_count
modiff_incr (modiff_count *a, ptrdiff_t len)
{
- modiff_count a0 = *a; int incr = len ? 1 : 0;
+ modiff_count a0 = *a;
/* Increase the counter more for a large modification and less for a
small modification. Increase it logarithmically to avoid
increasing it too much. */
- while (len >>= 1) incr++;
- bool modiff_overflow = INT_ADD_WRAPV (a0, incr, a);
+ verify (PTRDIFF_MAX <= ULLONG_MAX);
+ int incr = len == 0 ? 1 : elogb (len) + 1;
+ bool modiff_overflow = ckd_add (a, a0, incr);
eassert (!modiff_overflow && *a >> 30 >> 30 == 0);
return a0;
}
@@ -3966,7 +4208,6 @@ extern Lisp_Object arithcompare (Lisp_Object num1, Lisp_Object num2,
extern intmax_t cons_to_signed (Lisp_Object, intmax_t, intmax_t);
extern uintmax_t cons_to_unsigned (Lisp_Object, uintmax_t);
-extern struct Lisp_Symbol *indirect_variable (struct Lisp_Symbol *);
extern AVOID args_out_of_range (Lisp_Object, Lisp_Object);
extern AVOID circular_list (Lisp_Object);
extern Lisp_Object do_symval_forwarding (lispfwd);
@@ -4001,6 +4242,7 @@ extern ptrdiff_t multibyte_chars_in_text (const unsigned char *, ptrdiff_t);
extern void syms_of_character (void);
/* Defined in charset.c. */
+extern void mark_charset (void);
extern void init_charset (void);
extern void init_charset_once (void);
extern void syms_of_charset (void);
@@ -4021,12 +4263,14 @@ 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_user_defined (Lisp_Object, struct Lisp_Hash_Table *);
-Lisp_Object make_hash_table (struct hash_table_test, EMACS_INT, float, float,
- Lisp_Object, bool);
-ptrdiff_t hash_lookup (struct Lisp_Hash_Table *, Lisp_Object, Lisp_Object *);
+Lisp_Object make_hash_table (const struct hash_table_test *, EMACS_INT,
+ hash_table_weakness_t, bool);
+Lisp_Object hash_table_weakness_symbol (hash_table_weakness_t weak);
+ptrdiff_t hash_lookup (struct Lisp_Hash_Table *, Lisp_Object);
+ptrdiff_t hash_lookup_get_hash (struct Lisp_Hash_Table *h, Lisp_Object key,
+ hash_hash_t *phash);
ptrdiff_t hash_put (struct Lisp_Hash_Table *, Lisp_Object, Lisp_Object,
- Lisp_Object);
+ hash_hash_t);
void hash_remove_from_table (struct Lisp_Hash_Table *, Lisp_Object);
extern struct hash_table_test const hashtest_eq, hashtest_eql, hashtest_equal;
extern void validate_subarray (Lisp_Object, Lisp_Object, Lisp_Object,
@@ -4041,6 +4285,7 @@ extern Lisp_Object concat3 (Lisp_Object, Lisp_Object, Lisp_Object);
extern bool equal_no_quit (Lisp_Object, Lisp_Object);
extern Lisp_Object nconc2 (Lisp_Object, Lisp_Object);
extern Lisp_Object assq_no_quit (Lisp_Object, Lisp_Object);
+extern Lisp_Object assq_no_signal (Lisp_Object, Lisp_Object);
extern Lisp_Object assoc_no_quit (Lisp_Object, Lisp_Object);
extern void clear_string_char_byte_cache (void);
extern ptrdiff_t string_char_to_byte (Lisp_Object, ptrdiff_t);
@@ -4052,9 +4297,11 @@ extern Lisp_Object plist_put (Lisp_Object plist, Lisp_Object prop,
Lisp_Object val);
extern Lisp_Object plist_member (Lisp_Object plist, Lisp_Object prop);
extern void syms_of_fns (void);
+extern void mark_fns (void);
/* Defined in sort.c */
-extern void tim_sort (Lisp_Object, Lisp_Object *, const ptrdiff_t);
+extern void tim_sort (Lisp_Object, Lisp_Object, Lisp_Object *, const ptrdiff_t,
+ bool);
/* Defined in floatfns.c. */
verify (FLT_RADIX == 2 || FLT_RADIX == 16);
@@ -4117,6 +4364,7 @@ extern void del_range_byte (ptrdiff_t, ptrdiff_t);
extern void del_range_both (ptrdiff_t, ptrdiff_t, ptrdiff_t, ptrdiff_t, bool);
extern Lisp_Object del_range_2 (ptrdiff_t, ptrdiff_t,
ptrdiff_t, ptrdiff_t, bool);
+extern int safe_del_range (ptrdiff_t, ptrdiff_t);
extern void modify_text (ptrdiff_t, ptrdiff_t);
extern void prepare_to_modify_buffer (ptrdiff_t, ptrdiff_t, ptrdiff_t *);
extern void prepare_to_modify_buffer_1 (ptrdiff_t, ptrdiff_t, ptrdiff_t *);
@@ -4432,6 +4680,9 @@ extern void syms_of_alloc (void);
extern struct buffer *allocate_buffer (void) ATTRIBUTE_RETURNS_NONNULL;
extern int valid_lisp_object_p (Lisp_Object);
+void *hash_table_alloc_bytes (ptrdiff_t nbytes) ATTRIBUTE_MALLOC_SIZE ((1));
+void hash_table_free_bytes (void *p, ptrdiff_t nbytes);
+
/* Defined in gmalloc.c. */
#if !defined DOUG_LEA_MALLOC && !defined HYBRID_MALLOC && !defined SYSTEM_MALLOC
extern size_t __malloc_extra_blocks;
@@ -4493,7 +4744,6 @@ extern ptrdiff_t evxprintf (char **, ptrdiff_t *, char *, ptrdiff_t,
ATTRIBUTE_FORMAT_PRINTF (5, 0);
/* Defined in lread.c. */
-extern Lisp_Object check_obarray (Lisp_Object);
extern Lisp_Object intern_1 (const char *, ptrdiff_t);
extern Lisp_Object intern_c_string_1 (const char *, ptrdiff_t);
extern Lisp_Object intern_driver (Lisp_Object, Lisp_Object, Lisp_Object);
@@ -4509,7 +4759,8 @@ extern bool suffix_p (Lisp_Object, const char *);
extern Lisp_Object save_match_data_load (Lisp_Object, Lisp_Object, Lisp_Object,
Lisp_Object, Lisp_Object);
extern int openp (Lisp_Object, Lisp_Object, Lisp_Object,
- Lisp_Object *, Lisp_Object, bool, bool);
+ Lisp_Object *, Lisp_Object, bool, bool,
+ void **);
enum { S2N_IGNORE_TRAILING = 1 };
extern Lisp_Object string_to_number (char const *, int, ptrdiff_t *);
extern void map_obarray (Lisp_Object, void (*) (Lisp_Object, Lisp_Object),
@@ -4538,7 +4789,6 @@ extern Lisp_Object Vrun_hooks;
extern Lisp_Object Vsignaling_function;
extern Lisp_Object inhibit_lisp_code;
extern bool signal_quit_p (Lisp_Object);
-extern bool backtrace_yet;
/* To run a normal hook, use the appropriate function from the list below.
The calling convention:
@@ -4579,6 +4829,8 @@ extern Lisp_Object internal_condition_case_n
extern Lisp_Object internal_catch_all (Lisp_Object (*) (void *), void *, Lisp_Object (*) (enum nonlocal_exit, Lisp_Object));
extern struct handler *push_handler (Lisp_Object, enum handlertype)
ATTRIBUTE_RETURNS_NONNULL;
+extern void pop_handler (void);
+extern void push_handler_bind (Lisp_Object, Lisp_Object, int);
extern struct handler *push_handler_nosignal (Lisp_Object, enum handlertype);
extern void specbind (Lisp_Object, Lisp_Object);
extern void record_unwind_protect (void (*) (Lisp_Object), Lisp_Object);
@@ -4608,14 +4860,15 @@ extern Lisp_Object load_with_autoload_queue
Lisp_Object nosuffix, Lisp_Object must_suffix);
extern Lisp_Object call_debugger (Lisp_Object arg);
extern void init_eval_once (void);
-extern Lisp_Object safe_call (ptrdiff_t, Lisp_Object, ...);
-extern Lisp_Object safe_call1 (Lisp_Object, Lisp_Object);
-extern Lisp_Object safe_call2 (Lisp_Object, Lisp_Object, Lisp_Object);
+extern Lisp_Object safe_funcall (ptrdiff_t, Lisp_Object*);
+#define safe_calln(...) \
+ CALLMANY (safe_funcall, ((Lisp_Object []) {__VA_ARGS__}))
+
extern void init_eval (void);
extern void syms_of_eval (void);
extern void prog_ignore (Lisp_Object);
extern void mark_specpdl (union specbinding *first, union specbinding *ptr);
-extern void get_backtrace (Lisp_Object array);
+extern void get_backtrace (Lisp_Object *array, ptrdiff_t size);
Lisp_Object backtrace_top_function (void);
extern bool let_shadows_buffer_binding_p (struct Lisp_Symbol *symbol);
void do_debug_on_call (Lisp_Object code, specpdl_ref count);
@@ -4696,7 +4949,7 @@ extern void syms_of_editfns (void);
/* Defined in buffer.c. */
extern bool mouse_face_overlay_overlaps (Lisp_Object);
-extern Lisp_Object disable_line_numbers_overlay_at_eob (void);
+extern bool disable_line_numbers_overlay_at_eob (void);
extern AVOID nsberror (Lisp_Object);
extern void adjust_overlays_for_insert (ptrdiff_t, ptrdiff_t, bool);
extern void adjust_overlays_for_delete (ptrdiff_t, ptrdiff_t);
@@ -4705,7 +4958,6 @@ extern void report_overlay_modification (Lisp_Object, Lisp_Object, bool,
Lisp_Object, Lisp_Object, Lisp_Object);
extern bool overlay_touches_p (ptrdiff_t);
extern Lisp_Object other_buffer_safely (Lisp_Object);
-extern Lisp_Object get_truename_buffer (Lisp_Object);
extern void init_buffer_once (void);
extern void init_buffer (void);
extern void syms_of_buffer (void);
@@ -4728,6 +4980,7 @@ extern void syms_of_marker (void);
/* Defined in fileio.c. */
+extern Lisp_Object file_name_directory (Lisp_Object);
extern char *splice_dir_file (char *, char const *, char const *)
ATTRIBUTE_RETURNS_NONNULL;
extern bool file_name_absolute_p (const char *);
@@ -4806,7 +5059,7 @@ extern ptrdiff_t find_before_next_newline (ptrdiff_t, ptrdiff_t,
ptrdiff_t, ptrdiff_t *);
extern EMACS_INT search_buffer (Lisp_Object, ptrdiff_t, ptrdiff_t,
ptrdiff_t, ptrdiff_t, EMACS_INT,
- int, Lisp_Object, Lisp_Object, bool);
+ bool, Lisp_Object, Lisp_Object, bool);
extern void syms_of_search (void);
extern void clear_regexp_cache (void);
@@ -4872,6 +5125,7 @@ extern void keys_of_keyboard (void);
/* Defined in indent.c. */
extern ptrdiff_t current_column (void);
+extern void line_number_display_width (struct window *, int *, int *);
extern void invalidate_current_column (void);
extern bool indented_beyond_p (ptrdiff_t, ptrdiff_t, EMACS_INT);
extern void syms_of_indent (void);
@@ -4923,6 +5177,7 @@ extern bool build_details;
/* 0 not a daemon, 1 foreground daemon, 2 background daemon. */
extern int daemon_type;
#define IS_DAEMON (daemon_type != 0)
+/* Non-zero means daemon-initialized has not yet been called. */
#define DAEMON_RUNNING (daemon_type >= 0)
#else /* WINDOWSNT */
extern void *w32_daemon_event;
@@ -5067,11 +5322,34 @@ extern void init_random (void);
extern void emacs_backtrace (int);
extern AVOID emacs_abort (void) NO_INLINE;
extern int emacs_fstatat (int, char const *, void *, int);
+#ifdef HAVE_SYS_STAT_H
+extern int sys_fstat (int, struct stat *);
+#endif
+extern int sys_faccessat (int, const char *, int, int);
+#if !(defined HAVE_ANDROID && !defined ANDROID_STUBIFY)
extern int emacs_openat (int, char const *, int, int);
+#endif
extern int emacs_open (const char *, int, int);
extern int emacs_open_noquit (const char *, int, int);
extern int emacs_pipe (int[2]);
extern int emacs_close (int);
+#if !(defined HAVE_ANDROID && !defined ANDROID_STUBIFY)
+# define emacs_fclose fclose
+#else
+extern int emacs_fclose (FILE *);
+#endif
+extern FILE *emacs_fdopen (int, const char *)
+ ATTRIBUTE_MALLOC ATTRIBUTE_DEALLOC (emacs_fclose, 1);
+extern FILE *emacs_fopen (char const *, char const *)
+ ATTRIBUTE_MALLOC ATTRIBUTE_DEALLOC (emacs_fclose, 1);
+extern int emacs_unlink (const char *);
+extern int emacs_symlink (const char *, const char *);
+extern int emacs_rmdir (const char *);
+extern int emacs_mkdir (const char *, mode_t);
+extern int emacs_renameat_noreplace (int, const char *, int,
+ const char *);
+extern int emacs_rename (const char *, const char *);
+extern int emacs_fchmodat (int, const char *, mode_t, int);
extern ptrdiff_t emacs_read (int, void *, ptrdiff_t);
extern ptrdiff_t emacs_read_quit (int, void *, ptrdiff_t);
extern ptrdiff_t emacs_write (int, void const *, ptrdiff_t);
@@ -5105,7 +5383,9 @@ extern Lisp_Object directory_files_internal (Lisp_Object, Lisp_Object,
bool, Lisp_Object, Lisp_Object);
/* Defined in term.c. */
+#ifndef HAVE_ANDROID
extern int *char_ins_del_vector;
+#endif
extern void syms_of_term (void);
extern AVOID fatal (const char *msgid, ...) ATTRIBUTE_FORMAT_PRINTF (1, 2);
@@ -5206,6 +5486,7 @@ void syms_of_dbusbind (void);
extern bool profiler_memory_running;
extern void malloc_probe (size_t);
extern void syms_of_profiler (void);
+extern void mark_profiler (void);
#ifdef DOS_NT
@@ -5213,6 +5494,17 @@ extern void syms_of_profiler (void);
extern char *emacs_root_dir (void);
#endif /* DOS_NT */
+#ifdef HAVE_TEXT_CONVERSION
+/* Defined in textconv.c. */
+extern void reset_frame_state (struct frame *);
+extern void report_selected_window_change (struct frame *);
+extern void report_point_change (struct frame *, struct window *,
+ struct buffer *);
+extern void disable_text_conversion (void);
+extern void resume_text_conversion (void);
+extern void syms_of_textconv (void);
+#endif
+
#ifdef HAVE_NATIVE_COMP
INLINE bool
SUBR_NATIVE_COMPILEDP (Lisp_Object a)
@@ -5402,14 +5694,22 @@ safe_free_unbind_to (specpdl_ref count, specpdl_ref sa_count, Lisp_Object val)
return unbind_to (count, val);
}
+/* Work around GCC bug 109577
+ https://gcc.gnu.org/bugzilla/show_bug.cgi?id=109577
+ which causes GCC to mistakenly complain about the
+ memory allocation in SAFE_ALLOCA_LISP_EXTRA. */
+#if GNUC_PREREQ (13, 0, 0) && !GNUC_PREREQ (14, 0, 0)
+# pragma GCC diagnostic ignored "-Wanalyzer-allocation-size"
+#endif
+
/* Set BUF to point to an allocated array of NELT Lisp_Objects,
immediately followed by EXTRA spare bytes. */
#define SAFE_ALLOCA_LISP_EXTRA(buf, nelt, extra) \
do { \
ptrdiff_t alloca_nbytes; \
- if (INT_MULTIPLY_WRAPV (nelt, word_size, &alloca_nbytes) \
- || INT_ADD_WRAPV (alloca_nbytes, extra, &alloca_nbytes) \
+ if (ckd_mul (&alloca_nbytes, nelt, word_size) \
+ || ckd_add (&alloca_nbytes, alloca_nbytes, extra) \
|| SIZE_MAX < alloca_nbytes) \
memory_full (SIZE_MAX); \
else if (alloca_nbytes <= sa_avail) \
diff --git a/src/lread.c b/src/lread.c
index 7574e45f3dd..1cb941e84fc 100644
--- a/src/lread.c
+++ b/src/lread.c
@@ -62,6 +62,24 @@ along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. */
#include <fcntl.h>
+#if !defined HAVE_ANDROID || defined ANDROID_STUBIFY \
+ || (__ANDROID_API__ < 9)
+
+#define lread_fd int
+#define lread_fd_cmp(n) (fd == (n))
+#define lread_fd_p (fd >= 0)
+#define lread_close emacs_close
+#define lread_fstat fstat
+#define lread_read_quit emacs_read_quit
+#define lread_lseek lseek
+
+#define file_stream FILE *
+#define file_seek fseek
+#define file_stream_valid_p(p) (p)
+#define file_stream_close emacs_fclose
+#define file_stream_invalid NULL
+#define file_get_char getc
+
#ifdef HAVE_FSEEKO
#define file_offset off_t
#define file_tell ftello
@@ -70,11 +88,88 @@ along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. */
#define file_tell ftell
#endif
+#else
+
+#include "android.h"
+
+/* Use an Android file descriptor under Android instead, as this
+ allows loading directly from asset files without loading each asset
+ into memory and creating a separate file descriptor every time.
+
+ Note that `struct android_fd_or_asset' as used here is different
+ from that returned from `android_open_asset'; if fd.asset is NULL,
+ then fd.fd is either a valid file descriptor or -1, meaning that
+ the file descriptor is invalid.
+
+ However, lread requires the ability to seek inside asset files,
+ which is not provided under Android 2.2. So when building for that
+ particular system, fall back to the usual file descriptor-based
+ code. */
+
+#define lread_fd struct android_fd_or_asset
+#define lread_fd_cmp(n) (!fd.asset && fd.fd == (n))
+#define lread_fd_p (fd.asset || fd.fd >= 0)
+#define lread_close android_close_asset
+#define lread_fstat android_asset_fstat
+#define lread_read_quit android_asset_read_quit
+#define lread_lseek android_asset_lseek
+
+/* The invalid file stream. */
+
+static struct android_fd_or_asset invalid_file_stream =
+ {
+ -1,
+ NULL,
+ };
+
+#define file_stream struct android_fd_or_asset
+#define file_offset off_t
+#define file_tell(n) android_asset_lseek (n, 0, SEEK_CUR)
+#define file_seek android_asset_lseek
+#define file_stream_valid_p(p) ((p).asset || (p).fd >= 0)
+#define file_stream_close android_close_asset
+#define file_stream_invalid invalid_file_stream
+
+/* Return a single character from the file input stream STREAM.
+ Value and errors are the same as getc. */
+
+static int
+file_get_char (file_stream stream)
+{
+ int c;
+ char byte;
+ ssize_t rc;
+
+ retry:
+ rc = android_asset_read (stream, &byte, 1);
+
+ if (rc == 0)
+ c = EOF;
+ else if (rc == -1)
+ {
+ if (errno == EINTR)
+ goto retry;
+ else
+ c = EOF;
+ }
+ else
+ c = (unsigned char) byte;
+
+ return c;
+}
+
+#define USE_ANDROID_ASSETS
+#endif
+
#if IEEE_FLOATING_POINT
# include <ieee754.h>
# ifndef INFINITY
# define INFINITY ((union ieee754_double) {.ieee = {.exponent = -1}}.d)
# endif
+#else
+# ifndef INFINITY
+# define INFINITY HUGE_VAL
+# endif
#endif
/* The objects or placeholders read with the #n=object form.
@@ -113,7 +208,7 @@ static Lisp_Object read_objects_completed;
static struct infile
{
/* The input stream. */
- FILE *stream;
+ file_stream stream;
/* Lookahead byte count. */
signed char lookahead;
@@ -375,7 +470,7 @@ skip_dyn_bytes (Lisp_Object readcharfun, ptrdiff_t n)
if (FROM_FILE_P (readcharfun))
{
block_input (); /* FIXME: Not sure if it's needed. */
- fseek (infile->stream, n - infile->lookahead, SEEK_CUR);
+ file_seek (infile->stream, n - infile->lookahead, SEEK_CUR);
unblock_input ();
infile->lookahead = 0;
}
@@ -399,7 +494,7 @@ skip_dyn_eof (Lisp_Object readcharfun)
if (FROM_FILE_P (readcharfun))
{
block_input (); /* FIXME: Not sure if it's needed. */
- fseek (infile->stream, 0, SEEK_END);
+ file_seek (infile->stream, 0, SEEK_END);
unblock_input ();
infile->lookahead = 0;
}
@@ -480,10 +575,12 @@ readbyte_from_stdio (void)
return infile->buf[--infile->lookahead];
int c;
- FILE *instream = infile->stream;
+ file_stream instream = infile->stream;
block_input ();
+#if !defined USE_ANDROID_ASSETS
+
/* Interrupted reads have been observed while reading over the network. */
while ((c = getc (instream)) == EOF && errno == EINTR && ferror (instream))
{
@@ -493,6 +590,35 @@ readbyte_from_stdio (void)
clearerr (instream);
}
+#else
+
+ {
+ char byte;
+ ssize_t rc;
+
+ retry:
+ rc = android_asset_read (instream, &byte, 1);
+
+ if (rc == 0)
+ c = EOF;
+ else if (rc == -1)
+ {
+ if (errno == EINTR)
+ {
+ unblock_input ();
+ maybe_quit ();
+ block_input ();
+ goto retry;
+ }
+ else
+ c = EOF;
+ }
+ else
+ c = (unsigned char) byte;
+ }
+
+#endif
+
unblock_input ();
return (c == EOF ? -1 : c);
@@ -672,7 +798,11 @@ static void substitute_in_interval (INTERVAL, void *);
if the character warrants that.
If SECONDS is a number, wait that many seconds for input, and
- return Qnil if no input arrives within that time. */
+ return Qnil if no input arrives within that time.
+
+ If text conversion is enabled and ASCII_REQUIRED, temporarily
+ disable any input method which wants to perform edits, unless
+ `disable-inhibit-text-conversion'. */
static Lisp_Object
read_filtered_event (bool no_switch_frame, bool ascii_required,
@@ -680,12 +810,28 @@ read_filtered_event (bool no_switch_frame, bool ascii_required,
{
Lisp_Object val, delayed_switch_frame;
struct timespec end_time;
+#ifdef HAVE_TEXT_CONVERSION
+ specpdl_ref count;
+#endif
#ifdef HAVE_WINDOW_SYSTEM
if (display_hourglass_p)
cancel_hourglass ();
#endif
+#ifdef HAVE_TEXT_CONVERSION
+ count = SPECPDL_INDEX ();
+
+ /* Don't use text conversion when trying to just read a
+ character. */
+
+ if (ascii_required && !disable_inhibit_text_conversion)
+ {
+ disable_text_conversion ();
+ record_unwind_protect_void (resume_text_conversion);
+ }
+#endif
+
delayed_switch_frame = Qnil;
/* Compute timeout. */
@@ -761,7 +907,11 @@ read_filtered_event (bool no_switch_frame, bool ascii_required,
#endif
+#ifdef HAVE_TEXT_CONVERSION
+ return unbind_to (count, val);
+#else
return val;
+#endif
}
DEFUN ("read-char", Fread_char, Sread_char, 0, 3, 0,
@@ -1038,7 +1188,7 @@ lisp_file_lexically_bound_p (Lisp_Object readcharfun)
safe to load. Only files compiled with Emacs can be loaded. */
static int
-safe_to_load_version (Lisp_Object file, int fd)
+safe_to_load_version (Lisp_Object file, lread_fd fd)
{
struct stat st;
char buf[512];
@@ -1047,12 +1197,12 @@ safe_to_load_version (Lisp_Object file, int fd)
/* If the file is not regular, then we cannot safely seek it.
Assume that it is not safe to load as a compiled file. */
- if (fstat (fd, &st) == 0 && !S_ISREG (st.st_mode))
+ if (lread_fstat (fd, &st) == 0 && !S_ISREG (st.st_mode))
return 0;
/* Read the first few bytes from the file, and look for a line
specifying the byte compiler version used. */
- nbytes = emacs_read_quit (fd, buf, sizeof buf);
+ nbytes = lread_read_quit (fd, buf, sizeof buf);
if (nbytes > 0)
{
/* Skip to the next newline, skipping over the initial `ELC'
@@ -1067,7 +1217,7 @@ safe_to_load_version (Lisp_Object file, int fd)
version = 0;
}
- if (lseek (fd, 0, SEEK_SET) < 0)
+ if (lread_lseek (fd, 0, SEEK_SET) < 0)
report_file_error ("Seeking to start of file", file);
return version;
@@ -1141,7 +1291,7 @@ close_infile_unwind (void *arg)
{
struct infile *prev_infile = arg;
eassert (infile && infile != prev_infile);
- fclose (infile->stream);
+ file_stream_close (infile->stream);
infile = prev_infile;
}
@@ -1170,6 +1320,22 @@ loadhist_initialize (Lisp_Object filename)
specbind (Qcurrent_load_list, Fcons (filename, Qnil));
}
+#ifdef USE_ANDROID_ASSETS
+
+/* Like `close_file_unwind'. However, PTR is a pointer to an Android
+ file descriptor instead of a system file descriptor. */
+
+static void
+close_file_unwind_android_fd (void *ptr)
+{
+ struct android_fd_or_asset *fd;
+
+ fd = ptr;
+ android_close_asset (*fd);
+}
+
+#endif
+
DEFUN ("load", Fload, Sload, 1, 5, 0,
doc: /* Execute a file of Lisp code named FILE.
First try FILE with `.elc' appended, then try with `.el', then try
@@ -1218,8 +1384,12 @@ Return t if the file exists and loads successfully. */)
(Lisp_Object file, Lisp_Object noerror, Lisp_Object nomessage,
Lisp_Object nosuffix, Lisp_Object must_suffix)
{
- FILE *stream UNINIT;
- int fd;
+ file_stream stream UNINIT;
+ lread_fd fd;
+#ifdef USE_ANDROID_ASSETS
+ int rc;
+ void *asset;
+#endif
specpdl_ref fd_index UNINIT;
specpdl_ref count = SPECPDL_INDEX ();
Lisp_Object found, efound, hist_file_name;
@@ -1260,7 +1430,12 @@ Return t if the file exists and loads successfully. */)
since it would try to load a directory as a Lisp file. */
if (SCHARS (file) == 0)
{
+#if !defined USE_ANDROID_ASSETS
fd = -1;
+#else
+ fd.asset = NULL;
+ fd.fd = -1;
+#endif
errno = ENOENT;
}
else
@@ -1299,12 +1474,22 @@ Return t if the file exists and loads successfully. */)
suffixes = CALLN (Fappend, suffixes, Vload_file_rep_suffixes);
}
- fd =
- openp (Vload_path, file, suffixes, &found, Qnil, load_prefer_newer,
- no_native);
+#if !defined USE_ANDROID_ASSETS
+ fd = openp (Vload_path, file, suffixes, &found, Qnil,
+ load_prefer_newer, no_native, NULL);
+#else
+ asset = NULL;
+ rc = openp (Vload_path, file, suffixes, &found, Qnil,
+ load_prefer_newer, no_native, &asset);
+ fd.fd = rc;
+ fd.asset = asset;
+
+ /* fd.asset will be non-NULL if this is actually an asset
+ file. */
+#endif
}
- if (fd == -1)
+ if (lread_fd_cmp (-1))
{
if (NILP (noerror))
report_file_error ("Cannot open load file", file);
@@ -1316,7 +1501,7 @@ Return t if the file exists and loads successfully. */)
Vuser_init_file = found;
/* If FD is -2, that means openp found a magic file. */
- if (fd == -2)
+ if (lread_fd_cmp (-2))
{
if (NILP (Fequal (found, file)))
/* If FOUND is a different file name from FILE,
@@ -1345,11 +1530,21 @@ Return t if the file exists and loads successfully. */)
#endif
}
+#if !defined USE_ANDROID_ASSETS
if (0 <= fd)
{
fd_index = SPECPDL_INDEX ();
record_unwind_protect_int (close_file_unwind, fd);
}
+#else
+ if (fd.asset || fd.fd >= 0)
+ {
+ /* Use a different kind of unwind_protect here. */
+ fd_index = SPECPDL_INDEX ();
+ record_unwind_protect_ptr (close_file_unwind_android_fd,
+ &fd);
+ }
+#endif
#ifdef HAVE_MODULES
bool is_module =
@@ -1415,11 +1610,12 @@ Return t if the file exists and loads successfully. */)
if (is_elc
/* version = 1 means the file is empty, in which case we can
treat it as not byte-compiled. */
- || (fd >= 0 && (version = safe_to_load_version (file, fd)) > 1))
+ || (lread_fd_p
+ && (version = safe_to_load_version (file, fd)) > 1))
/* Load .elc files directly, but not when they are
remote and have no handler! */
{
- if (fd != -2)
+ if (!lread_fd_cmp (-2))
{
struct stat s1, s2;
int result;
@@ -1476,9 +1672,9 @@ Return t if the file exists and loads successfully. */)
{
Lisp_Object val;
- if (fd >= 0)
+ if (lread_fd_p)
{
- emacs_close (fd);
+ lread_close (fd);
clear_unwind_protect (fd_index);
}
val = call4 (Vload_source_file_function, found, hist_file_name,
@@ -1488,12 +1684,12 @@ Return t if the file exists and loads successfully. */)
}
}
- if (fd < 0)
+ if (!lread_fd_p)
{
/* We somehow got here with fd == -2, meaning the file is deemed
to be remote. Don't even try to reopen the file locally;
just force a failure. */
- stream = NULL;
+ stream = file_stream_invalid;
errno = EINVAL;
}
else if (!is_module && !is_native_elisp)
@@ -1504,7 +1700,15 @@ Return t if the file exists and loads successfully. */)
efound = ENCODE_FILE (found);
stream = emacs_fopen (SSDATA (efound), fmode);
#else
- stream = fdopen (fd, fmode);
+#if !defined USE_ANDROID_ASSETS
+ stream = emacs_fdopen (fd, fmode);
+#else
+ /* Android systems use special file descriptors which can point
+ into compressed data and double as file streams. FMODE is
+ unused. */
+ ((void) fmode);
+ stream = fd;
+#endif
#endif
}
@@ -1516,15 +1720,15 @@ Return t if the file exists and loads successfully. */)
{
/* `module-load' uses the file name, so we can close the stream
now. */
- if (fd >= 0)
+ if (lread_fd_p)
{
- emacs_close (fd);
+ lread_close (fd);
clear_unwind_protect (fd_index);
}
}
else
{
- if (! stream)
+ if (!file_stream_valid_p (stream))
report_file_error ("Opening stdio stream", file);
set_unwind_protect_ptr (fd_index, close_infile_unwind, infile);
input.stream = stream;
@@ -1660,7 +1864,8 @@ 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, true);
+ int fd = openp (path, filename, suffixes, &file, predicate, false, true,
+ NULL);
if (NILP (predicate) && fd >= 0)
emacs_close (fd);
return file;
@@ -1676,7 +1881,7 @@ maybe_swap_for_eln1 (Lisp_Object src_name, Lisp_Object eln_name,
if (eln_fd > 0)
{
- if (fstat (eln_fd, &eln_st) || S_ISDIR (eln_st.st_mode))
+ if (sys_fstat (eln_fd, &eln_st) || S_ISDIR (eln_st.st_mode))
emacs_close (eln_fd);
else
{
@@ -1801,14 +2006,20 @@ maybe_swap_for_eln (bool no_native, Lisp_Object *filename, int *fd,
If NEWER is true, try all SUFFIXes and return the result for the
newest file that exists. Does not apply to remote files,
- or if a non-nil and non-t PREDICATE is specified.
+ platform-specific files, or if a non-nil and non-t PREDICATE is
+ specified.
- if NO_NATIVE is true do not try to load native code. */
+ If NO_NATIVE is true do not try to load native code.
+
+ If PLATFORM is non-NULL and the file being loaded lies in a special
+ directory, such as the Android `/assets' directory, return a handle
+ to that directory in *PLATFORM instead of a file descriptor; in
+ that case, value is -3. */
int
openp (Lisp_Object path, Lisp_Object str, Lisp_Object suffixes,
Lisp_Object *storeptr, Lisp_Object predicate, bool newer,
- bool no_native)
+ bool no_native, void **platform)
{
ptrdiff_t fn_size = 100;
char buf[100];
@@ -1820,6 +2031,9 @@ openp (Lisp_Object path, Lisp_Object str, Lisp_Object suffixes,
ptrdiff_t max_suffix_len = 0;
int last_errno = ENOENT;
int save_fd = -1;
+#ifdef USE_ANDROID_ASSETS
+ struct android_fd_or_asset platform_fd;
+#endif
USE_SAFE_ALLOCA;
/* The last-modified time of the newest matching file found.
@@ -1964,8 +2178,8 @@ openp (Lisp_Object path, Lisp_Object str, Lisp_Object suffixes,
fd = -1;
if (INT_MAX < XFIXNAT (predicate))
last_errno = EINVAL;
- else if (faccessat (AT_FDCWD, pfn, XFIXNAT (predicate),
- AT_EACCESS)
+ else if (sys_faccessat (AT_FDCWD, pfn, XFIXNAT (predicate),
+ AT_EACCESS)
== 0)
{
if (file_directory_p (encoded_fn))
@@ -1985,11 +2199,34 @@ openp (Lisp_Object path, Lisp_Object str, Lisp_Object suffixes,
it. Only open the file when we are sure that it
exists. */
#ifdef WINDOWSNT
- if (faccessat (AT_FDCWD, pfn, R_OK, AT_EACCESS))
+ if (sys_faccessat (AT_FDCWD, pfn, R_OK, AT_EACCESS))
fd = -1;
else
#endif
- fd = emacs_open (pfn, O_RDONLY, 0);
+ {
+#if !defined USE_ANDROID_ASSETS
+ fd = emacs_open (pfn, O_RDONLY, 0);
+#else
+ if (platform)
+ {
+ platform_fd = android_open_asset (pfn, O_RDONLY, 0);
+
+ if (platform_fd.asset
+ && platform_fd.asset != (void *) -1)
+ {
+ *storeptr = string;
+ goto handle_platform_fd;
+ }
+
+ if (platform_fd.asset == (void *) -1)
+ fd = -1;
+ else
+ fd = platform_fd.fd;
+ }
+ else
+ fd = emacs_open (pfn, O_RDONLY, 0);
+#endif
+ }
if (fd < 0)
{
@@ -1998,7 +2235,7 @@ openp (Lisp_Object path, Lisp_Object str, Lisp_Object suffixes,
}
else
{
- int err = (fstat (fd, &st) != 0 ? errno
+ int err = (sys_fstat (fd, &st) != 0 ? errno
: S_ISDIR (st.st_mode) ? EISDIR : 0);
if (err)
{
@@ -2057,6 +2294,16 @@ openp (Lisp_Object path, Lisp_Object str, Lisp_Object suffixes,
SAFE_FREE ();
errno = last_errno;
return -1;
+
+#ifdef USE_ANDROID_ASSETS
+ handle_platform_fd:
+
+ /* Here, openp found a platform specific file descriptor. It can't
+ be a directory under Android, so return it in *PLATFORM and then
+ -3 as the file descriptor. */
+ *platform = platform_fd.asset;
+ return -3;
+#endif
}
@@ -2088,7 +2335,7 @@ build_load_history (Lisp_Object filename, bool entire)
{
foundit = 1;
- /* If we're loading the entire file, remove old data. */
+ /* If we're loading the entire file, remove old data. */
if (entire)
{
if (NILP (prev))
@@ -2096,8 +2343,8 @@ build_load_history (Lisp_Object filename, bool entire)
else
Fsetcdr (prev, XCDR (tail));
}
-
- /* Otherwise, cons on new symbols that are not already members. */
+ /* Otherwise, cons on new symbols that are not already
+ members. */
else
{
tem2 = Vcurrent_load_list;
@@ -2122,8 +2369,14 @@ build_load_history (Lisp_Object filename, bool entire)
front of load-history, the most-recently-loaded position. Also
do this if we didn't find an existing member for the file. */
if (entire || !foundit)
- Vload_history = Fcons (Fnreverse (Vcurrent_load_list),
- Vload_history);
+ {
+ Lisp_Object tem = Fnreverse (Vcurrent_load_list);
+ eassert (EQ (filename, Fcar (tem)));
+ Vload_history = Fcons (tem, Vload_history);
+ /* FIXME: There should be an unbind_to right after calling us which
+ should re-establish the previous value of Vcurrent_load_list. */
+ Vcurrent_load_list = Qt;
+ }
}
static void
@@ -2190,11 +2443,13 @@ readevalloop (Lisp_Object readcharfun,
bool whole_buffer = 0;
/* True on the first time around. */
bool first_sexp = 1;
- Lisp_Object macroexpand = intern ("internal-macroexpand-for-load");
+ Lisp_Object macroexpand;
if (!NILP (sourcename))
CHECK_STRING (sourcename);
+ macroexpand = Qinternal_macroexpand_for_load;
+
if (NILP (Ffboundp (macroexpand))
|| (STRINGP (sourcename) && suffix_p (sourcename, ".elc")))
/* Don't macroexpand before the corresponding function is defined
@@ -2297,15 +2552,11 @@ readevalloop (Lisp_Object readcharfun,
if (! HASH_TABLE_P (read_objects_map)
|| XHASH_TABLE (read_objects_map)->count)
read_objects_map
- = make_hash_table (hashtest_eq, DEFAULT_HASH_SIZE,
- DEFAULT_REHASH_SIZE, DEFAULT_REHASH_THRESHOLD,
- Qnil, false);
+ = make_hash_table (&hashtest_eq, DEFAULT_HASH_SIZE, Weak_None, false);
if (! HASH_TABLE_P (read_objects_completed)
|| XHASH_TABLE (read_objects_completed)->count)
read_objects_completed
- = make_hash_table (hashtest_eq, DEFAULT_HASH_SIZE,
- DEFAULT_REHASH_SIZE, DEFAULT_REHASH_THRESHOLD,
- Qnil, false);
+ = make_hash_table (&hashtest_eq, DEFAULT_HASH_SIZE, Weak_None, false);
if (!NILP (Vpurify_flag) && c == '(')
val = read0 (readcharfun, false);
else
@@ -2549,13 +2800,11 @@ read_internal_start (Lisp_Object stream, Lisp_Object start, Lisp_Object end,
if (! HASH_TABLE_P (read_objects_map)
|| XHASH_TABLE (read_objects_map)->count)
read_objects_map
- = make_hash_table (hashtest_eq, DEFAULT_HASH_SIZE, DEFAULT_REHASH_SIZE,
- DEFAULT_REHASH_THRESHOLD, Qnil, false);
+ = make_hash_table (&hashtest_eq, DEFAULT_HASH_SIZE, Weak_None, false);
if (! HASH_TABLE_P (read_objects_completed)
|| XHASH_TABLE (read_objects_completed)->count)
read_objects_completed
- = make_hash_table (hashtest_eq, DEFAULT_HASH_SIZE, DEFAULT_REHASH_SIZE,
- DEFAULT_REHASH_THRESHOLD, Qnil, false);
+ = make_hash_table (&hashtest_eq, DEFAULT_HASH_SIZE, Weak_None, false);
if (STRINGP (stream)
|| ((CONSP (stream) && STRINGP (XCAR (stream)))))
@@ -2640,154 +2889,131 @@ character_name_to_code (char const *name, ptrdiff_t name_len,
Unicode 9.0.0 the maximum is 83, so this should be safe. */
enum { UNICODE_CHARACTER_NAME_LENGTH_BOUND = 200 };
-/* Read a \-escape sequence, assuming we already read the `\'.
- If the escape sequence forces unibyte, return eight-bit char. */
-
+/* Read a character escape sequence, assuming we just read a backslash
+ and one more character (next_char). */
static int
-read_escape (Lisp_Object readcharfun)
+read_char_escape (Lisp_Object readcharfun, int next_char)
{
- int c = READCHAR;
- /* \u allows up to four hex digits, \U up to eight. Default to the
- behavior for \u, and change this value in the case that \U is seen. */
- int unicode_hex_count = 4;
+ int modifiers = 0;
+ ptrdiff_t ncontrol = 0;
+ int chr;
+
+ again: ;
+ int c = next_char;
+ int unicode_hex_count;
+ int mod;
switch (c)
{
case -1:
end_of_file_error ();
- case 'a':
- return '\007';
- case 'b':
- return '\b';
- case 'd':
- return 0177;
- case 'e':
- return 033;
- case 'f':
- return '\f';
- case 'n':
- return '\n';
- case 'r':
- return '\r';
- case 't':
- return '\t';
- case 'v':
- return '\v';
+ case 'a': chr = '\a'; break;
+ case 'b': chr = '\b'; break;
+ case 'd': chr = 127; break;
+ case 'e': chr = 27; break;
+ case 'f': chr = '\f'; break;
+ case 'n': chr = '\n'; break;
+ case 'r': chr = '\r'; break;
+ case 't': chr = '\t'; break;
+ case 'v': chr = '\v'; break;
case '\n':
/* ?\LF is an error; it's probably a user mistake. */
- error ("Invalid escape character syntax");
-
- case 'M':
- c = READCHAR;
- if (c != '-')
- error ("Invalid escape character syntax");
- c = READCHAR;
- if (c == '\\')
- c = read_escape (readcharfun);
- return c | meta_modifier;
-
- case 'S':
- c = READCHAR;
- if (c != '-')
- error ("Invalid escape character syntax");
- c = READCHAR;
- if (c == '\\')
- c = read_escape (readcharfun);
- return c | shift_modifier;
+ error ("Invalid escape char syntax: \\<newline>");
- case 'H':
- c = READCHAR;
- if (c != '-')
- error ("Invalid escape character syntax");
- c = READCHAR;
- if (c == '\\')
- c = read_escape (readcharfun);
- return c | hyper_modifier;
-
- case 'A':
- c = READCHAR;
- if (c != '-')
- error ("Invalid escape character syntax");
- c = READCHAR;
- if (c == '\\')
- c = read_escape (readcharfun);
- return c | alt_modifier;
+ /* \M-x etc: set modifier bit and parse the char to which it applies,
+ allowing for chains such as \M-\S-\A-\H-\s-\C-q. */
+ case 'M': mod = meta_modifier; goto mod_key;
+ case 'S': mod = shift_modifier; goto mod_key;
+ case 'H': mod = hyper_modifier; goto mod_key;
+ case 'A': mod = alt_modifier; goto mod_key;
+ case 's': mod = super_modifier; goto mod_key;
- case 's':
- c = READCHAR;
- if (c != '-')
- {
- UNREAD (c);
- return ' ';
- }
- c = READCHAR;
- if (c == '\\')
- c = read_escape (readcharfun);
- return c | super_modifier;
+ mod_key:
+ {
+ int c1 = READCHAR;
+ if (c1 != '-')
+ {
+ if (c == 's')
+ {
+ /* \s not followed by a hyphen is SPC. */
+ UNREAD (c1);
+ chr = ' ';
+ break;
+ }
+ else
+ /* \M, \S, \H, \A not followed by a hyphen is an error. */
+ error ("Invalid escape char syntax: \\%c not followed by -", c);
+ }
+ modifiers |= mod;
+ c1 = READCHAR;
+ if (c1 == '\\')
+ {
+ next_char = READCHAR;
+ goto again;
+ }
+ chr = c1;
+ break;
+ }
+ /* Control modifiers (\C-x or \^x) are messy and not actually idempotent.
+ For example, ?\C-\C-a = ?\C-\001 = 0x4000001.
+ Keep a count of them and apply them separately. */
case 'C':
- c = READCHAR;
- if (c != '-')
- error ("Invalid escape character syntax");
+ {
+ int c1 = READCHAR;
+ if (c1 != '-')
+ error ("Invalid escape char syntax: \\%c not followed by -", c);
+ }
FALLTHROUGH;
+ /* The prefixes \C- and \^ are equivalent. */
case '^':
- c = READCHAR;
- if (c == '\\')
- c = read_escape (readcharfun);
- if ((c & ~CHAR_MODIFIER_MASK) == '?')
- return 0177 | (c & CHAR_MODIFIER_MASK);
- else if (! ASCII_CHAR_P ((c & ~CHAR_MODIFIER_MASK)))
- return c | ctrl_modifier;
- /* ASCII control chars are made from letters (both cases),
- as well as the non-letters within 0100...0137. */
- else if ((c & 0137) >= 0101 && (c & 0137) <= 0132)
- return (c & (037 | ~0177));
- else if ((c & 0177) >= 0100 && (c & 0177) <= 0137)
- return (c & (037 | ~0177));
- else
- return c | ctrl_modifier;
-
- case '0':
- case '1':
- case '2':
- case '3':
- case '4':
- case '5':
- case '6':
- case '7':
- /* An octal escape, as in ANSI C. */
{
- register int i = c - '0';
- register int count = 0;
- while (++count < 3)
+ ncontrol++;
+ int c1 = READCHAR;
+ if (c1 == '\\')
{
- if ((c = READCHAR) >= '0' && c <= '7')
- {
- i *= 8;
- i += c - '0';
- }
- else
+ next_char = READCHAR;
+ goto again;
+ }
+ chr = c1;
+ break;
+ }
+
+ /* 1-3 octal digits. Values in 0x80..0xff are encoded as raw bytes. */
+ case '0': case '1': case '2': case '3':
+ case '4': case '5': case '6': case '7':
+ {
+ int i = c - '0';
+ int count = 0;
+ while (count < 2)
+ {
+ int c = READCHAR;
+ if (c < '0' || c > '7')
{
UNREAD (c);
break;
}
+ i = (i << 3) + (c - '0');
+ count++;
}
if (i >= 0x80 && i < 0x100)
i = BYTE8_TO_CHAR (i);
- return i;
+ chr = i;
+ break;
}
+ /* 1 or more hex digits. Values may encode modifiers.
+ Values in 0x80..0xff using 2 hex digits are encoded as raw bytes. */
case 'x':
- /* A hex escape, as in ANSI C. */
{
unsigned int i = 0;
int count = 0;
while (1)
{
- c = READCHAR;
+ int c = READCHAR;
int digit = char_hexdigit (c);
if (digit < 0)
{
@@ -2797,40 +3023,37 @@ read_escape (Lisp_Object readcharfun)
i = (i << 4) + digit;
/* Allow hex escapes as large as ?\xfffffff, because some
packages use them to denote characters with modifiers. */
- if ((CHAR_META | (CHAR_META - 1)) < i)
+ if (i > (CHAR_META | (CHAR_META - 1)))
error ("Hex character out of range: \\x%x...", i);
count += count < 3;
}
+ if (count == 0)
+ error ("Invalid escape char syntax: \\x not followed by hex digit");
if (count < 3 && i >= 0x80)
- return BYTE8_TO_CHAR (i);
- return i;
+ i = BYTE8_TO_CHAR (i);
+ modifiers |= i & CHAR_MODIFIER_MASK;
+ chr = i & ~CHAR_MODIFIER_MASK;
+ break;
}
+ /* 8-digit Unicode hex escape: \UHHHHHHHH */
case 'U':
- /* Post-Unicode-2.0: Up to eight hex chars. */
unicode_hex_count = 8;
- FALLTHROUGH;
- case 'u':
+ goto unicode_hex;
- /* A Unicode escape. We only permit them in strings and characters,
- not arbitrarily in the source code, as in some other languages. */
+ /* 4-digit Unicode hex escape: \uHHHH */
+ case 'u':
+ unicode_hex_count = 4;
+ unicode_hex:
{
unsigned int i = 0;
- int count = 0;
-
- while (++count <= unicode_hex_count)
+ for (int count = 0; count < unicode_hex_count; count++)
{
- c = READCHAR;
+ int c = READCHAR;
if (c < 0)
- {
- if (unicode_hex_count > 4)
- error ("Malformed Unicode escape: \\U%x", i);
- else
- error ("Malformed Unicode escape: \\u%x", i);
- }
- /* `isdigit' and `isalpha' may be locale-specific, which we don't
- want. */
+ error ("Malformed Unicode escape: \\%c%x",
+ unicode_hex_count == 4 ? 'u' : 'U', i);
int digit = char_hexdigit (c);
if (digit < 0)
error ("Non-hex character used for Unicode escape: %c (%d)",
@@ -2839,13 +3062,14 @@ read_escape (Lisp_Object readcharfun)
}
if (i > 0x10FFFF)
error ("Non-Unicode character: 0x%x", i);
- return i;
+ chr = i;
+ break;
}
+ /* Named character: \N{name} */
case 'N':
- /* Named character. */
{
- c = READCHAR;
+ int c = READCHAR;
if (c != '{')
invalid_syntax ("Expected opening brace after \\N", readcharfun);
char name[UNICODE_CHARACTER_NAME_LENGTH_BOUND + 1];
@@ -2853,12 +3077,12 @@ read_escape (Lisp_Object readcharfun)
ptrdiff_t length = 0;
while (true)
{
- c = READCHAR;
+ int c = READCHAR;
if (c < 0)
end_of_file_error ();
if (c == '}')
break;
- if (! (0 < c && c < 0x80))
+ if (c >= 0x80)
{
AUTO_STRING (format,
"Invalid character U+%04X in character name");
@@ -2887,13 +3111,41 @@ read_escape (Lisp_Object readcharfun)
name[length] = '\0';
/* character_name_to_code can invoke read0, recursively.
- This is why read0's buffer is not static. */
- return character_name_to_code (name, length, readcharfun);
+ This is why read0 needs to be re-entrant. */
+ chr = character_name_to_code (name, length, readcharfun);
+ break;
}
default:
- return c;
+ chr = c;
+ break;
}
+ eassert (chr >= 0 && chr < (1 << CHARACTERBITS));
+
+ /* Apply Control modifiers, using the rules:
+ \C-X = ascii_ctrl(nomod(X)) | mods(X) if nomod(X) is one of:
+ A-Z a-z ? @ [ \ ] ^ _
+
+ X | ctrl_modifier otherwise
+
+ where
+ nomod(c) = c without modifiers
+ mods(c) = the modifiers of c
+ ascii_ctrl(c) = 127 if c = '?'
+ c & 0x1f otherwise
+ */
+ while (ncontrol > 0)
+ {
+ if ((chr >= '@' && chr <= '_') || (chr >= 'a' && chr <= 'z'))
+ chr &= 0x1f;
+ else if (chr == '?')
+ chr = 127;
+ else
+ modifiers |= ctrl_modifier;
+ ncontrol--;
+ }
+
+ return chr | modifiers;
}
/* Return the digit that CHARACTER stands for in the given BASE.
@@ -3015,7 +3267,7 @@ read_char_literal (Lisp_Object readcharfun)
}
if (ch == '\\')
- ch = read_escape (readcharfun);
+ ch = read_char_escape (readcharfun, READCHAR);
int modifiers = ch & CHAR_MODIFIER_MASK;
ch &= ~CHAR_MODIFIER_MASK;
@@ -3081,8 +3333,7 @@ read_string_literal (Lisp_Object readcharfun)
/* `\SPC' and `\LF' generate no characters at all. */
continue;
default:
- UNREAD (ch);
- ch = read_escape (readcharfun);
+ ch = read_char_escape (readcharfun, ch);
break;
}
@@ -3163,7 +3414,7 @@ read_string_literal (Lisp_Object readcharfun)
static Lisp_Object
hash_table_from_plist (Lisp_Object plist)
{
- Lisp_Object params[12];
+ Lisp_Object params[4 * 2];
Lisp_Object *par = params;
/* This is repetitive but fast and simple. */
@@ -3177,31 +3428,30 @@ hash_table_from_plist (Lisp_Object plist)
} \
} while (0)
- ADDPARAM (size);
ADDPARAM (test);
ADDPARAM (weakness);
- ADDPARAM (rehash_size);
- ADDPARAM (rehash_threshold);
ADDPARAM (purecopy);
Lisp_Object data = plist_get (plist, Qdata);
+ if (!(NILP (data) || CONSP (data)))
+ error ("Hash table data is not a list");
+ ptrdiff_t data_len = list_length (data);
+ if (data_len & 1)
+ error ("Hash table data length is odd");
+ *par++ = QCsize;
+ *par++ = make_fixnum (data_len / 2);
/* Now use params to make a new hash table and fill it. */
Lisp_Object ht = Fmake_hash_table (par - params, params);
- Lisp_Object last = data;
- FOR_EACH_TAIL_SAFE (data)
+ while (!NILP (data))
{
Lisp_Object key = XCAR (data);
data = XCDR (data);
- if (!CONSP (data))
- break;
Lisp_Object val = XCAR (data);
- last = XCDR (data);
Fputhash (key, val, ht);
+ data = XCDR (data);
}
- if (!NILP (last))
- error ("Hash table data is not a list of even length");
return ht;
}
@@ -3239,6 +3489,8 @@ vector_from_rev_list (Lisp_Object elems)
return obj;
}
+static Lisp_Object get_lazy_string (Lisp_Object val);
+
static Lisp_Object
bytecode_from_rev_list (Lisp_Object elems, Lisp_Object readcharfun)
{
@@ -3246,49 +3498,50 @@ bytecode_from_rev_list (Lisp_Object elems, Lisp_Object readcharfun)
Lisp_Object *vec = XVECTOR (obj)->contents;
ptrdiff_t size = ASIZE (obj);
+ if (infile && size >= COMPILED_CONSTANTS)
+ {
+ /* Always read 'lazily-loaded' bytecode (generated by the
+ `byte-compile-dynamic' feature prior to Emacs 30) eagerly, to
+ avoid code in the fast path during execution. */
+ if (CONSP (vec[COMPILED_BYTECODE])
+ && FIXNUMP (XCDR (vec[COMPILED_BYTECODE])))
+ vec[COMPILED_BYTECODE] = get_lazy_string (vec[COMPILED_BYTECODE]);
+
+ /* Lazily-loaded bytecode is represented by the constant slot being nil
+ and the bytecode slot a (lazily loaded) string containing the
+ print representation of (BYTECODE . CONSTANTS). Unpack the
+ pieces by coerceing the string to unibyte and reading the result. */
+ if (NILP (vec[COMPILED_CONSTANTS]) && STRINGP (vec[COMPILED_BYTECODE]))
+ {
+ Lisp_Object enc = vec[COMPILED_BYTECODE];
+ Lisp_Object pair = Fread (Fcons (enc, readcharfun));
+ if (!CONSP (pair))
+ invalid_syntax ("Invalid byte-code object", readcharfun);
+
+ vec[COMPILED_BYTECODE] = XCAR (pair);
+ vec[COMPILED_CONSTANTS] = XCDR (pair);
+ }
+ }
+
if (!(size >= COMPILED_STACK_DEPTH + 1 && size <= COMPILED_INTERACTIVE + 1
&& (FIXNUMP (vec[COMPILED_ARGLIST])
|| CONSP (vec[COMPILED_ARGLIST])
|| NILP (vec[COMPILED_ARGLIST]))
+ && STRINGP (vec[COMPILED_BYTECODE])
+ && VECTORP (vec[COMPILED_CONSTANTS])
&& FIXNATP (vec[COMPILED_STACK_DEPTH])))
invalid_syntax ("Invalid byte-code object", readcharfun);
- if (load_force_doc_strings
- && NILP (vec[COMPILED_CONSTANTS])
- && STRINGP (vec[COMPILED_BYTECODE]))
- {
- /* Lazily-loaded bytecode is represented by the constant slot being nil
- and the bytecode slot a (lazily loaded) string containing the
- print representation of (BYTECODE . CONSTANTS). Unpack the
- pieces by coerceing the string to unibyte and reading the result. */
- Lisp_Object enc = vec[COMPILED_BYTECODE];
- Lisp_Object pair = Fread (Fcons (enc, readcharfun));
- if (!CONSP (pair))
- invalid_syntax ("Invalid byte-code object", readcharfun);
+ if (STRING_MULTIBYTE (vec[COMPILED_BYTECODE]))
+ /* BYTESTR must have been produced by Emacs 20.2 or earlier
+ because it produced a raw 8-bit string for byte-code and
+ now such a byte-code string is loaded as multibyte with
+ raw 8-bit characters converted to multibyte form.
+ Convert them back to the original unibyte form. */
+ vec[COMPILED_BYTECODE] = Fstring_as_unibyte (vec[COMPILED_BYTECODE]);
- vec[COMPILED_BYTECODE] = XCAR (pair);
- vec[COMPILED_CONSTANTS] = XCDR (pair);
- }
-
- if (!((STRINGP (vec[COMPILED_BYTECODE])
- && VECTORP (vec[COMPILED_CONSTANTS]))
- || CONSP (vec[COMPILED_BYTECODE])))
- invalid_syntax ("Invalid byte-code object", readcharfun);
-
- if (STRINGP (vec[COMPILED_BYTECODE]))
- {
- if (STRING_MULTIBYTE (vec[COMPILED_BYTECODE]))
- {
- /* BYTESTR must have been produced by Emacs 20.2 or earlier
- because it produced a raw 8-bit string for byte-code and
- now such a byte-code string is loaded as multibyte with
- raw 8-bit characters converted to multibyte form.
- Convert them back to the original unibyte form. */
- vec[COMPILED_BYTECODE] = Fstring_as_unibyte (vec[COMPILED_BYTECODE]);
- }
- /* Bytecode must be immovable. */
- pin_string (vec[COMPILED_BYTECODE]);
- }
+ /* Bytecode must be immovable. */
+ pin_string (vec[COMPILED_BYTECODE]);
XSETPVECTYPE (XVECTOR (obj), PVEC_COMPILED);
return obj;
@@ -3375,8 +3628,8 @@ read_bool_vector (Lisp_Object readcharfun)
invalid_syntax ("#&", readcharfun);
break;
}
- if (INT_MULTIPLY_WRAPV (length, 10, &length)
- || INT_ADD_WRAPV (length, c - '0', &length))
+ if (ckd_mul (&length, length, 10)
+ || ckd_add (&length, length, c - '0'))
invalid_syntax ("#&", readcharfun);
}
@@ -3422,8 +3675,8 @@ skip_lazy_string (Lisp_Object readcharfun)
UNREAD (c);
break;
}
- if (INT_MULTIPLY_WRAPV (nskip, 10, &nskip)
- || INT_ADD_WRAPV (nskip, c - '0', &nskip))
+ if (ckd_mul (&nskip, nskip, 10)
+ || ckd_add (&nskip, nskip, c - '0'))
invalid_syntax ("#@", readcharfun);
digits++;
if (digits == 2 && nskip == 0)
@@ -3459,7 +3712,7 @@ skip_lazy_string (Lisp_Object readcharfun)
ss->string = xrealloc (ss->string, ss->size);
}
- FILE *instream = infile->stream;
+ file_stream instream = infile->stream;
ss->position = (file_tell (instream) - infile->lookahead);
/* Copy that many bytes into the saved string. */
@@ -3469,7 +3722,7 @@ skip_lazy_string (Lisp_Object readcharfun)
ss->string[i++] = c = infile->buf[--infile->lookahead];
block_input ();
for (; i < nskip && c >= 0; i++)
- ss->string[i] = c = getc (instream);
+ ss->string[i] = c = file_get_char (instream);
unblock_input ();
ss->length = i;
@@ -3991,8 +4244,8 @@ read0 (Lisp_Object readcharfun, bool locate_syms)
c = READCHAR;
if (c < '0' || c > '9')
break;
- if (INT_MULTIPLY_WRAPV (n, 10, &n)
- || INT_ADD_WRAPV (n, c - '0', &n))
+ if (ckd_mul (&n, n, 10)
+ || ckd_add (&n, n, c - '0'))
invalid_syntax ("#", readcharfun);
}
if (c == 'r' || c == 'R')
@@ -4013,8 +4266,8 @@ read0 (Lisp_Object readcharfun, bool locate_syms)
struct Lisp_Hash_Table *h
= XHASH_TABLE (read_objects_map);
Lisp_Object number = make_fixnum (n);
- Lisp_Object hash;
- ptrdiff_t i = hash_lookup (h, number, &hash);
+ hash_hash_t hash;
+ ptrdiff_t i = hash_lookup_get_hash (h, number, &hash);
if (i >= 0)
/* Not normal, but input could be malformed. */
set_hash_value_slot (h, i, placeholder);
@@ -4032,7 +4285,7 @@ read0 (Lisp_Object readcharfun, bool locate_syms)
/* #N# -- reference to numbered object */
struct Lisp_Hash_Table *h
= XHASH_TABLE (read_objects_map);
- ptrdiff_t i = hash_lookup (h, make_fixnum (n), NULL);
+ ptrdiff_t i = hash_lookup (h, make_fixnum (n));
if (i < 0)
invalid_syntax ("#", readcharfun);
obj = HASH_VALUE (h, i);
@@ -4227,7 +4480,7 @@ read0 (Lisp_Object readcharfun, bool locate_syms)
&longhand_chars,
&longhand_bytes);
- if (SYMBOLP (found))
+ if (BARE_SYMBOL_P (found))
result = found;
else if (longhand)
{
@@ -4329,8 +4582,8 @@ read0 (Lisp_Object readcharfun, bool locate_syms)
struct Lisp_Hash_Table *h2
= XHASH_TABLE (read_objects_completed);
- Lisp_Object hash;
- ptrdiff_t i = hash_lookup (h2, placeholder, &hash);
+ hash_hash_t hash;
+ ptrdiff_t i = hash_lookup_get_hash (h2, placeholder, &hash);
eassert (i < 0);
hash_put (h2, placeholder, Qnil, hash);
obj = placeholder;
@@ -4344,8 +4597,8 @@ read0 (Lisp_Object readcharfun, bool locate_syms)
{
struct Lisp_Hash_Table *h2
= XHASH_TABLE (read_objects_completed);
- Lisp_Object hash;
- ptrdiff_t i = hash_lookup (h2, obj, &hash);
+ hash_hash_t hash;
+ ptrdiff_t i = hash_lookup_get_hash (h2, obj, &hash);
eassert (i < 0);
hash_put (h2, obj, Qnil, hash);
}
@@ -4356,8 +4609,9 @@ read0 (Lisp_Object readcharfun, bool locate_syms)
/* ...and #n# will use the real value from now on. */
struct Lisp_Hash_Table *h = XHASH_TABLE (read_objects_map);
- Lisp_Object hash;
- ptrdiff_t i = hash_lookup (h, e->u.numbered.number, &hash);
+ hash_hash_t hash;
+ ptrdiff_t i = hash_lookup_get_hash (h, e->u.numbered.number,
+ &hash);
eassert (i >= 0);
set_hash_value_slot (h, i, obj);
}
@@ -4411,7 +4665,7 @@ substitute_object_recurse (struct subst *subst, Lisp_Object subtree)
by #n=, which means that we can find it as a value in
COMPLETED. */
if (EQ (subst->completed, Qt)
- || hash_lookup (XHASH_TABLE (subst->completed), subtree, NULL) >= 0)
+ || hash_lookup (XHASH_TABLE (subst->completed), subtree) >= 0)
subst->seen = Fcons (subtree, subst->seen);
/* Recurse according to subtree's type.
@@ -4475,10 +4729,17 @@ substitute_in_interval (INTERVAL interval, void *arg)
}
+#if !IEEE_FLOATING_POINT
+/* Strings that stand in for +NaN, -NaN, respectively. */
+static Lisp_Object not_a_number[2];
+#endif
+
/* Convert the initial prefix of STRING to a number, assuming base BASE.
If the prefix has floating point syntax and BASE is 10, return a
nearest float; otherwise, if the prefix has integer syntax, return
- the integer; otherwise, return nil. If PLEN, set *PLEN to the
+ the integer; otherwise, return nil. (On antique platforms that lack
+ support for NaNs, if the prefix has NaN syntax return a Lisp object that
+ will provoke an error if used as a number.) If PLEN, set *PLEN to the
length of the numeric prefix if there is one, otherwise *PLEN is
unspecified. */
@@ -4543,7 +4804,6 @@ string_to_number (char const *string, int base, ptrdiff_t *plen)
cp++;
while ('0' <= *cp && *cp <= '9');
}
-#if IEEE_FLOATING_POINT
else if (cp[-1] == '+'
&& cp[0] == 'I' && cp[1] == 'N' && cp[2] == 'F')
{
@@ -4556,12 +4816,17 @@ string_to_number (char const *string, int base, ptrdiff_t *plen)
{
state |= E_EXP;
cp += 3;
+#if IEEE_FLOATING_POINT
union ieee754_double u
= { .ieee_nan = { .exponent = 0x7ff, .quiet_nan = 1,
.mantissa0 = n >> 31 >> 1, .mantissa1 = n }};
value = u.d;
- }
+#else
+ if (plen)
+ *plen = cp - string;
+ return not_a_number[negative];
#endif
+ }
else
cp = ecp;
}
@@ -4621,49 +4886,65 @@ static Lisp_Object initial_obarray;
static size_t oblookup_last_bucket_number;
-/* Get an error if OBARRAY is not an obarray.
- If it is one, return it. */
+static Lisp_Object make_obarray (unsigned bits);
+/* Slow path obarray check: return the obarray to use or signal an error. */
Lisp_Object
-check_obarray (Lisp_Object obarray)
+check_obarray_slow (Lisp_Object obarray)
{
- /* We don't want to signal a wrong-type-argument error when we are
- shutting down due to a fatal error, and we don't want to hit
- assertions in VECTORP and ASIZE if the fatal error was during GC. */
- if (!fatal_error_in_progress
- && (!VECTORP (obarray) || ASIZE (obarray) == 0))
+ /* For compatibility, we accept vectors whose first element is 0,
+ and store an obarray object there. */
+ if (VECTORP (obarray) && ASIZE (obarray) > 0)
{
- /* If Vobarray is now invalid, force it to be valid. */
- if (EQ (Vobarray, obarray)) Vobarray = initial_obarray;
- wrong_type_argument (Qvectorp, obarray);
+ Lisp_Object obj = AREF (obarray, 0);
+ if (OBARRAYP (obj))
+ return obj;
+ if (BASE_EQ (obj, make_fixnum (0)))
+ {
+ /* Put an actual obarray object in the first slot.
+ The rest of the vector remains unused. */
+ obj = make_obarray (0);
+ ASET (obarray, 0, obj);
+ return obj;
+ }
}
- return obarray;
+ /* Reset Vobarray to the standard obarray for nicer error handling. */
+ if (BASE_EQ (Vobarray, obarray)) Vobarray = initial_obarray;
+
+ wrong_type_argument (Qobarrayp, obarray);
}
+static void grow_obarray (struct Lisp_Obarray *o);
+
/* Intern symbol SYM in OBARRAY using bucket INDEX. */
+/* FIXME: retype arguments as pure C types */
static Lisp_Object
intern_sym (Lisp_Object sym, Lisp_Object obarray, Lisp_Object index)
{
- Lisp_Object *ptr;
-
- XSYMBOL (sym)->u.s.interned = (EQ (obarray, initial_obarray)
- ? SYMBOL_INTERNED_IN_INITIAL_OBARRAY
- : SYMBOL_INTERNED);
+ eassert (BARE_SYMBOL_P (sym) && OBARRAYP (obarray) && FIXNUMP (index));
+ struct Lisp_Symbol *s = XBARE_SYMBOL (sym);
+ s->u.s.interned = (BASE_EQ (obarray, initial_obarray)
+ ? SYMBOL_INTERNED_IN_INITIAL_OBARRAY
+ : SYMBOL_INTERNED);
- if (SREF (SYMBOL_NAME (sym), 0) == ':' && EQ (obarray, initial_obarray))
+ if (SREF (s->u.s.name, 0) == ':' && BASE_EQ (obarray, initial_obarray))
{
- make_symbol_constant (sym);
- XSYMBOL (sym)->u.s.redirect = SYMBOL_PLAINVAL;
+ s->u.s.trapped_write = SYMBOL_NOWRITE;
+ s->u.s.redirect = SYMBOL_PLAINVAL;
/* Mark keywords as special. This makes (let ((:key 'foo)) ...)
in lexically bound elisp signal an error, as documented. */
- XSYMBOL (sym)->u.s.declared_special = true;
- SET_SYMBOL_VAL (XSYMBOL (sym), sym);
+ s->u.s.declared_special = true;
+ SET_SYMBOL_VAL (s, sym);
}
- ptr = aref_addr (obarray, XFIXNUM (index));
- set_symbol_next (sym, SYMBOLP (*ptr) ? XSYMBOL (*ptr) : NULL);
+ struct Lisp_Obarray *o = XOBARRAY (obarray);
+ Lisp_Object *ptr = o->buckets + XFIXNUM (index);
+ s->u.s.next = BARE_SYMBOL_P (*ptr) ? XBARE_SYMBOL (*ptr) : NULL;
*ptr = sym;
+ o->count++;
+ if (o->count > obarray_size (o))
+ grow_obarray (o);
return sym;
}
@@ -4672,7 +4953,7 @@ intern_sym (Lisp_Object sym, Lisp_Object obarray, Lisp_Object index)
Lisp_Object
intern_driver (Lisp_Object string, Lisp_Object obarray, Lisp_Object index)
{
- SET_SYMBOL_VAL (XSYMBOL (Qobarray_cache), Qnil);
+ SET_SYMBOL_VAL (XBARE_SYMBOL (Qobarray_cache), Qnil);
return intern_sym (Fmake_symbol (string), obarray, index);
}
@@ -4685,7 +4966,7 @@ intern_1 (const char *str, ptrdiff_t len)
Lisp_Object obarray = check_obarray (Vobarray);
Lisp_Object tem = oblookup (obarray, str, len, len);
- return (SYMBOLP (tem) ? tem
+ return (BARE_SYMBOL_P (tem) ? tem
/* The above `oblookup' was done on the basis of nchars==nbytes, so
the string has to be unibyte. */
: intern_driver (make_unibyte_string (str, len),
@@ -4698,7 +4979,7 @@ intern_c_string_1 (const char *str, ptrdiff_t len)
Lisp_Object obarray = check_obarray (Vobarray);
Lisp_Object tem = oblookup (obarray, str, len, len);
- if (!SYMBOLP (tem))
+ if (!BARE_SYMBOL_P (tem))
{
Lisp_Object string;
@@ -4750,7 +5031,7 @@ it defaults to the value of `obarray'. */)
&longhand, &longhand_chars,
&longhand_bytes);
- if (!SYMBOLP (tem))
+ if (!BARE_SYMBOL_P (tem))
{
if (longhand)
{
@@ -4799,10 +5080,11 @@ it defaults to the value of `obarray'. */)
{
/* If already a symbol, we don't do shorthand-longhand translation,
as promised in the docstring. */
- string = SYMBOL_NAME (name);
+ Lisp_Object sym = maybe_remove_pos_from_symbol (name);
+ string = XSYMBOL (name)->u.s.name;
tem
= oblookup (obarray, SSDATA (string), SCHARS (string), SBYTES (string));
- return EQ (name, tem) ? name : Qnil;
+ return BASE_EQ (sym, tem) ? name : Qnil;
}
}
@@ -4817,13 +5099,16 @@ usage: (unintern NAME OBARRAY) */)
{
register Lisp_Object tem;
Lisp_Object string;
- size_t hash;
if (NILP (obarray)) obarray = Vobarray;
obarray = check_obarray (obarray);
if (SYMBOLP (name))
- string = SYMBOL_NAME (name);
+ {
+ if (!BARE_SYMBOL_P (name))
+ name = XSYMBOL_WITH_POS (name)->sym;
+ string = SYMBOL_NAME (name);
+ }
else
{
CHECK_STRING (name);
@@ -4843,7 +5128,7 @@ usage: (unintern NAME OBARRAY) */)
if (FIXNUMP (tem))
return Qnil;
/* If arg was a symbol, don't delete anything but that symbol itself. */
- if (SYMBOLP (name) && !EQ (name, tem))
+ if (BARE_SYMBOL_P (name) && !BASE_EQ (name, tem))
return Qnil;
/* There are plenty of other symbols which will screw up the Emacs
@@ -4853,41 +5138,42 @@ usage: (unintern NAME OBARRAY) */)
/* if (NILP (tem) || EQ (tem, Qt))
error ("Attempt to unintern t or nil"); */
- XSYMBOL (tem)->u.s.interned = SYMBOL_UNINTERNED;
+ struct Lisp_Symbol *sym = XBARE_SYMBOL (tem);
+ sym->u.s.interned = SYMBOL_UNINTERNED;
- hash = oblookup_last_bucket_number;
+ ptrdiff_t idx = oblookup_last_bucket_number;
+ Lisp_Object *loc = &XOBARRAY (obarray)->buckets[idx];
- if (EQ (AREF (obarray, hash), tem))
- {
- if (XSYMBOL (tem)->u.s.next)
- {
- Lisp_Object sym;
- XSETSYMBOL (sym, XSYMBOL (tem)->u.s.next);
- ASET (obarray, hash, sym);
- }
- else
- ASET (obarray, hash, make_fixnum (0));
- }
+ eassert (BARE_SYMBOL_P (*loc));
+ struct Lisp_Symbol *prev = XBARE_SYMBOL (*loc);
+ if (sym == prev)
+ *loc = sym->u.s.next ? make_lisp_symbol (sym->u.s.next) : make_fixnum (0);
else
- {
- Lisp_Object tail, following;
+ while (1)
+ {
+ struct Lisp_Symbol *next = prev->u.s.next;
+ if (next == sym)
+ {
+ prev->u.s.next = next->u.s.next;
+ break;
+ }
+ prev = next;
+ }
- for (tail = AREF (obarray, hash);
- XSYMBOL (tail)->u.s.next;
- tail = following)
- {
- XSETSYMBOL (following, XSYMBOL (tail)->u.s.next);
- if (EQ (following, tem))
- {
- set_symbol_next (tail, XSYMBOL (following)->u.s.next);
- break;
- }
- }
- }
+ XOBARRAY (obarray)->count--;
return Qt;
}
+
+/* Bucket index of the string STR of length SIZE_BYTE bytes in obarray OA. */
+static ptrdiff_t
+obarray_index (struct Lisp_Obarray *oa, const char *str, ptrdiff_t size_byte)
+{
+ EMACS_UINT hash = hash_string (str, size_byte);
+ return knuth_hash (reduce_emacs_uint_to_hash_hash (hash), oa->size_bits);
+}
+
/* Return the symbol in OBARRAY whose names matches the string
of SIZE characters (SIZE_BYTE bytes) at PTR.
If there is no such symbol, return the integer bucket number of
@@ -4898,35 +5184,27 @@ usage: (unintern NAME OBARRAY) */)
Lisp_Object
oblookup (Lisp_Object obarray, register const char *ptr, ptrdiff_t size, ptrdiff_t size_byte)
{
- size_t hash;
- size_t obsize;
- register Lisp_Object tail;
- Lisp_Object bucket, tem;
+ struct Lisp_Obarray *o = XOBARRAY (obarray);
+ ptrdiff_t idx = obarray_index (o, ptr, size_byte);
+ Lisp_Object bucket = o->buckets[idx];
- obarray = check_obarray (obarray);
- /* This is sometimes needed in the middle of GC. */
- obsize = gc_asize (obarray);
- hash = hash_string (ptr, size_byte) % obsize;
- bucket = AREF (obarray, hash);
- oblookup_last_bucket_number = hash;
- if (BASE_EQ (bucket, make_fixnum (0)))
- ;
- else if (!SYMBOLP (bucket))
- /* Like CADR error message. */
- xsignal2 (Qwrong_type_argument, Qobarrayp,
- build_string ("Bad data in guts of obarray"));
- else
- for (tail = bucket; ; XSETSYMBOL (tail, XSYMBOL (tail)->u.s.next))
- {
- if (SBYTES (SYMBOL_NAME (tail)) == size_byte
- && SCHARS (SYMBOL_NAME (tail)) == size
- && !memcmp (SDATA (SYMBOL_NAME (tail)), ptr, size_byte))
- return tail;
- else if (XSYMBOL (tail)->u.s.next == 0)
- break;
- }
- XSETINT (tem, hash);
- return tem;
+ oblookup_last_bucket_number = idx;
+ if (!BASE_EQ (bucket, make_fixnum (0)))
+ {
+ Lisp_Object sym = bucket;
+ while (1)
+ {
+ struct Lisp_Symbol *s = XBARE_SYMBOL (sym);
+ Lisp_Object name = s->u.s.name;
+ if (SBYTES (name) == size_byte && SCHARS (name) == size
+ && memcmp (SDATA (name), ptr, size_byte) == 0)
+ return sym;
+ if (s->u.s.next == NULL)
+ break;
+ sym = make_lisp_symbol(s->u.s.next);
+ }
+ }
+ return make_fixnum (idx);
}
/* Like 'oblookup', but considers 'Vread_symbol_shorthands',
@@ -4993,24 +5271,134 @@ oblookup_considering_shorthand (Lisp_Object obarray, const char *in,
}
-void
-map_obarray (Lisp_Object obarray, void (*fn) (Lisp_Object, Lisp_Object), Lisp_Object arg)
+static struct Lisp_Obarray *
+allocate_obarray (void)
{
- ptrdiff_t i;
- register Lisp_Object tail;
- CHECK_VECTOR (obarray);
- for (i = ASIZE (obarray) - 1; i >= 0; i--)
+ return ALLOCATE_PLAIN_PSEUDOVECTOR (struct Lisp_Obarray, PVEC_OBARRAY);
+}
+
+static Lisp_Object
+make_obarray (unsigned bits)
+{
+ struct Lisp_Obarray *o = allocate_obarray ();
+ o->count = 0;
+ o->size_bits = bits;
+ ptrdiff_t size = (ptrdiff_t)1 << bits;
+ o->buckets = hash_table_alloc_bytes (size * sizeof *o->buckets);
+ for (ptrdiff_t i = 0; i < size; i++)
+ o->buckets[i] = make_fixnum (0);
+ return make_lisp_obarray (o);
+}
+
+enum {
+ obarray_default_bits = 3,
+ word_size_log2 = word_size < 8 ? 5 : 6, /* good enough */
+ obarray_max_bits = min (8 * sizeof (int),
+ 8 * sizeof (ptrdiff_t) - word_size_log2) - 1,
+};
+
+static void
+grow_obarray (struct Lisp_Obarray *o)
+{
+ ptrdiff_t old_size = obarray_size (o);
+ eassert (o->count > old_size);
+ Lisp_Object *old_buckets = o->buckets;
+
+ int new_bits = o->size_bits + 1;
+ if (new_bits > obarray_max_bits)
+ error ("Obarray too big");
+ ptrdiff_t new_size = (ptrdiff_t)1 << new_bits;
+ o->buckets = hash_table_alloc_bytes (new_size * sizeof *o->buckets);
+ for (ptrdiff_t i = 0; i < new_size; i++)
+ o->buckets[i] = make_fixnum (0);
+ o->size_bits = new_bits;
+
+ /* Rehash symbols.
+ FIXME: this is expensive since we need to recompute the hash for every
+ symbol name. Would it be reasonable to store it in the symbol? */
+ for (ptrdiff_t i = 0; i < old_size; i++)
{
- tail = AREF (obarray, i);
- if (SYMBOLP (tail))
- while (1)
- {
- (*fn) (tail, arg);
- if (XSYMBOL (tail)->u.s.next == 0)
- break;
- XSETSYMBOL (tail, XSYMBOL (tail)->u.s.next);
- }
+ Lisp_Object obj = old_buckets[i];
+ if (BARE_SYMBOL_P (obj))
+ {
+ struct Lisp_Symbol *s = XBARE_SYMBOL (obj);
+ while (1)
+ {
+ Lisp_Object name = s->u.s.name;
+ ptrdiff_t idx = obarray_index (o, SSDATA (name), SBYTES (name));
+ Lisp_Object *loc = o->buckets + idx;
+ struct Lisp_Symbol *next = s->u.s.next;
+ s->u.s.next = BARE_SYMBOL_P (*loc) ? XBARE_SYMBOL (*loc) : NULL;
+ *loc = make_lisp_symbol (s);
+ if (next == NULL)
+ break;
+ s = next;
+ }
+ }
+ }
+
+ hash_table_free_bytes (old_buckets, old_size * sizeof *old_buckets);
+}
+
+DEFUN ("obarray-make", Fobarray_make, Sobarray_make, 0, 1, 0,
+ doc: /* Return a new obarray of size SIZE.
+The obarray will grow to accommodate any number of symbols; the size, if
+given, is only a hint for the expected number. */)
+ (Lisp_Object size)
+{
+ int bits;
+ if (NILP (size))
+ bits = obarray_default_bits;
+ else
+ {
+ CHECK_FIXNAT (size);
+ EMACS_UINT n = XFIXNUM (size);
+ bits = elogb (n) + 1;
+ if (bits > obarray_max_bits)
+ xsignal (Qargs_out_of_range, size);
}
+ return make_obarray (bits);
+}
+
+DEFUN ("obarrayp", Fobarrayp, Sobarrayp, 1, 1, 0,
+ doc: /* Return t iff OBJECT is an obarray. */)
+ (Lisp_Object object)
+{
+ return OBARRAYP (object) ? Qt : Qnil;
+}
+
+DEFUN ("obarray-clear", Fobarray_clear, Sobarray_clear, 1, 1, 0,
+ doc: /* Remove all symbols from OBARRAY. */)
+ (Lisp_Object obarray)
+{
+ CHECK_OBARRAY (obarray);
+ struct Lisp_Obarray *o = XOBARRAY (obarray);
+
+ /* This function does not bother setting the status of its contained symbols
+ to uninterned. It doesn't matter very much. */
+ int new_bits = obarray_default_bits;
+ int new_size = (ptrdiff_t)1 << new_bits;
+ Lisp_Object *new_buckets
+ = hash_table_alloc_bytes (new_size * sizeof *new_buckets);
+ for (ptrdiff_t i = 0; i < new_size; i++)
+ new_buckets[i] = make_fixnum (0);
+
+ int old_size = obarray_size (o);
+ hash_table_free_bytes (o->buckets, old_size * sizeof *o->buckets);
+ o->buckets = new_buckets;
+ o->size_bits = new_bits;
+ o->count = 0;
+
+ return Qnil;
+}
+
+void
+map_obarray (Lisp_Object obarray,
+ void (*fn) (Lisp_Object, Lisp_Object), Lisp_Object arg)
+{
+ CHECK_OBARRAY (obarray);
+ DOOBARRAY (XOBARRAY (obarray), it)
+ (*fn) (obarray_iter_symbol (&it), arg);
}
static void
@@ -5031,12 +5419,37 @@ OBARRAY defaults to the value of `obarray'. */)
return Qnil;
}
-#define OBARRAY_SIZE 15121
+DEFUN ("internal--obarray-buckets",
+ Finternal__obarray_buckets, Sinternal__obarray_buckets, 1, 1, 0,
+ doc: /* Symbols in each bucket of OBARRAY. Internal use only. */)
+ (Lisp_Object obarray)
+{
+ obarray = check_obarray (obarray);
+ ptrdiff_t size = obarray_size (XOBARRAY (obarray));
+
+ Lisp_Object ret = Qnil;
+ for (ptrdiff_t i = 0; i < size; i++)
+ {
+ Lisp_Object bucket = Qnil;
+ Lisp_Object sym = XOBARRAY (obarray)->buckets[i];
+ if (BARE_SYMBOL_P (sym))
+ while (1)
+ {
+ bucket = Fcons (sym, bucket);
+ struct Lisp_Symbol *s = XBARE_SYMBOL (sym)->u.s.next;
+ if (!s)
+ break;
+ sym = make_lisp_symbol (s);
+ }
+ ret = Fcons (Fnreverse (bucket), ret);
+ }
+ return Fnreverse (ret);
+}
void
init_obarray_once (void)
{
- Vobarray = make_vector (OBARRAY_SIZE, make_fixnum (0));
+ Vobarray = make_obarray (15);
initial_obarray = Vobarray;
staticpro (&initial_obarray);
@@ -5046,14 +5459,14 @@ init_obarray_once (void)
DEFSYM (Qunbound, "unbound");
DEFSYM (Qnil, "nil");
- SET_SYMBOL_VAL (XSYMBOL (Qnil), Qnil);
+ SET_SYMBOL_VAL (XBARE_SYMBOL (Qnil), Qnil);
make_symbol_constant (Qnil);
- XSYMBOL (Qnil)->u.s.declared_special = true;
+ XBARE_SYMBOL (Qnil)->u.s.declared_special = true;
DEFSYM (Qt, "t");
- SET_SYMBOL_VAL (XSYMBOL (Qt), Qt);
+ SET_SYMBOL_VAL (XBARE_SYMBOL (Qt), Qt);
make_symbol_constant (Qt);
- XSYMBOL (Qt)->u.s.declared_special = true;
+ XBARE_SYMBOL (Qt)->u.s.declared_special = true;
/* Qt is correct even if not dumping. loadup.el will set to nil at end. */
Vpurify_flag = Qt;
@@ -5077,16 +5490,6 @@ defsubr (union Aligned_Lisp_Subr *aname)
#endif
}
-#ifdef NOTDEF /* Use fset in subr.el now! */
-void
-defalias (struct Lisp_Subr *sname, char *string)
-{
- Lisp_Object sym;
- sym = intern (string);
- XSETSUBR (XSYMBOL (sym)->u.s.function, sname);
-}
-#endif /* NOTDEF */
-
/* Define an "integer variable"; a symbol whose value is forwarded to a
C variable of type intmax_t. Sample call (with "xx" to fool make-docfile):
DEFxxVAR_INT ("emacs-priority", &emacs_priority, "Documentation"); */
@@ -5094,9 +5497,9 @@ void
defvar_int (struct Lisp_Intfwd const *i_fwd, char const *namestring)
{
Lisp_Object sym = intern_c_string (namestring);
- XSYMBOL (sym)->u.s.declared_special = true;
- XSYMBOL (sym)->u.s.redirect = SYMBOL_FORWARDED;
- SET_SYMBOL_FWD (XSYMBOL (sym), i_fwd);
+ XBARE_SYMBOL (sym)->u.s.declared_special = true;
+ XBARE_SYMBOL (sym)->u.s.redirect = SYMBOL_FORWARDED;
+ SET_SYMBOL_FWD (XBARE_SYMBOL (sym), i_fwd);
}
/* Similar but define a variable whose value is t if 1, nil if 0. */
@@ -5104,9 +5507,9 @@ void
defvar_bool (struct Lisp_Boolfwd const *b_fwd, char const *namestring)
{
Lisp_Object sym = intern_c_string (namestring);
- XSYMBOL (sym)->u.s.declared_special = true;
- XSYMBOL (sym)->u.s.redirect = SYMBOL_FORWARDED;
- SET_SYMBOL_FWD (XSYMBOL (sym), b_fwd);
+ XBARE_SYMBOL (sym)->u.s.declared_special = true;
+ XBARE_SYMBOL (sym)->u.s.redirect = SYMBOL_FORWARDED;
+ SET_SYMBOL_FWD (XBARE_SYMBOL (sym), b_fwd);
Vbyte_boolean_vars = Fcons (sym, Vbyte_boolean_vars);
}
@@ -5119,9 +5522,9 @@ void
defvar_lisp_nopro (struct Lisp_Objfwd const *o_fwd, char const *namestring)
{
Lisp_Object sym = intern_c_string (namestring);
- XSYMBOL (sym)->u.s.declared_special = true;
- XSYMBOL (sym)->u.s.redirect = SYMBOL_FORWARDED;
- SET_SYMBOL_FWD (XSYMBOL (sym), o_fwd);
+ XBARE_SYMBOL (sym)->u.s.declared_special = true;
+ XBARE_SYMBOL (sym)->u.s.redirect = SYMBOL_FORWARDED;
+ SET_SYMBOL_FWD (XBARE_SYMBOL (sym), o_fwd);
}
void
@@ -5138,9 +5541,9 @@ void
defvar_kboard (struct Lisp_Kboard_Objfwd const *ko_fwd, char const *namestring)
{
Lisp_Object sym = intern_c_string (namestring);
- XSYMBOL (sym)->u.s.declared_special = true;
- XSYMBOL (sym)->u.s.redirect = SYMBOL_FORWARDED;
- SET_SYMBOL_FWD (XSYMBOL (sym), ko_fwd);
+ XBARE_SYMBOL (sym)->u.s.declared_special = true;
+ XBARE_SYMBOL (sym)->u.s.redirect = SYMBOL_FORWARDED;
+ SET_SYMBOL_FWD (XBARE_SYMBOL (sym), ko_fwd);
}
/* Check that the elements of lpath exist. */
@@ -5428,6 +5831,10 @@ syms_of_lread (void)
defsubr (&Sget_file_char);
defsubr (&Smapatoms);
defsubr (&Slocate_file_internal);
+ defsubr (&Sinternal__obarray_buckets);
+ defsubr (&Sobarray_make);
+ defsubr (&Sobarrayp);
+ defsubr (&Sobarray_clear);
DEFVAR_LISP ("obarray", Vobarray,
doc: /* Symbol table for use by `intern' and `read'.
@@ -5439,7 +5846,7 @@ to find all the symbols in an obarray, use `mapatoms'. */);
doc: /* List of values of all expressions which were read, evaluated and printed.
Order is reverse chronological.
This variable is obsolete as of Emacs 28.1 and should not be used. */);
- XSYMBOL (intern ("values"))->u.s.declared_special = false;
+ XBARE_SYMBOL (intern ("values"))->u.s.declared_special = false;
DEFVAR_LISP ("standard-input", Vstandard_input,
doc: /* Stream for read to get input from.
@@ -5705,6 +6112,14 @@ that are loaded before your customizations are read! */);
DEFSYM (Qcomma, ",");
DEFSYM (Qcomma_at, ",@");
+#if !IEEE_FLOATING_POINT
+ for (int negative = 0; negative < 2; negative++)
+ {
+ not_a_number[negative] = build_pure_c_string (&"-0.0e+NaN"[!negative]);
+ staticpro (&not_a_number[negative]);
+ }
+#endif
+
DEFSYM (Qinhibit_file_name_operation, "inhibit-file-name-operation");
DEFSYM (Qascii_character, "ascii-character");
DEFSYM (Qfunction, "function");
@@ -5729,8 +6144,6 @@ that are loaded before your customizations are read! */);
DEFSYM (Qsize, "size");
DEFSYM (Qpurecopy, "purecopy");
DEFSYM (Qweakness, "weakness");
- DEFSYM (Qrehash_size, "rehash-size");
- DEFSYM (Qrehash_threshold, "rehash-threshold");
DEFSYM (Qchar_from_name, "char-from-name");
@@ -5747,4 +6160,7 @@ See Info node `(elisp)Shorthands' for more details. */);
doc: /* List of variables declared dynamic in the current scope.
Only valid during macro-expansion. Internal use only. */);
Vmacroexp__dynvars = Qnil;
+
+ DEFSYM (Qinternal_macroexpand_for_load,
+ "internal-macroexpand-for-load");
}
diff --git a/src/macfont.h b/src/macfont.h
index 77426f6f198..45cb1eaa7e4 100644
--- a/src/macfont.h
+++ b/src/macfont.h
@@ -75,7 +75,7 @@ enum {
#define kCTVersionNumber10_9 0x00060000
#endif
#define MAC_FONT_CHARACTER_SET_STRING_ATTRIBUTE \
- (CFSTR ("MAC_FONT_CHARACTER_SET_STRING_ATTRIBUTE"))
+ CFSTR ("MAC_FONT_CHARACTER_SET_STRING_ATTRIBUTE")
typedef const struct _EmacsScreenFont *ScreenFontRef; /* opaque */
@@ -85,4 +85,4 @@ extern void macfont_update_antialias_threshold (void);
/* This is an undocumented function. */
extern void CGContextSetFontSmoothingStyle(CGContextRef, int)
- __attribute__((weak_import));
+ __attribute__ ((weak_import));
diff --git a/src/macfont.m b/src/macfont.m
index 8aba440d196..e3b3d40df43 100644
--- a/src/macfont.m
+++ b/src/macfont.m
@@ -855,21 +855,42 @@ macfont_store_descriptor_attributes (CTFontDescriptorRef desc,
struct {
enum font_property_index index;
CFStringRef trait;
- CGPoint points[6];
- CGFloat (*adjust_func) (CTFontDescriptorRef, CGFloat);
- } numeric_traits[] =
- {{FONT_WEIGHT_INDEX, kCTFontWeightTrait,
- {{-0.4, 50}, /* light */
- {-0.24, 87.5}, /* (semi-light + normal) / 2 */
- {0, 80}, /* normal */
- {0.24, 140}, /* (semi-bold + normal) / 2 */
- {0.4, 200}, /* bold */
- {CGFLOAT_MAX, CGFLOAT_MAX}},
- mac_font_descriptor_get_adjusted_weight},
- {FONT_SLANT_INDEX, kCTFontSlantTrait,
- {{0, 100}, {0.1, 200}, {CGFLOAT_MAX, CGFLOAT_MAX}}, NULL},
- {FONT_WIDTH_INDEX, kCTFontWidthTrait,
- {{0, 100}, {1, 200}, {CGFLOAT_MAX, CGFLOAT_MAX}}, NULL}};
+ CGPoint points[12];
+ CGFloat (*adjust_func) (CTFontDescriptorRef, CGFloat);
+ } numeric_traits[] = {
+ { FONT_WEIGHT_INDEX,
+ kCTFontWeightTrait,
+ { { -0.6, 0 }, /* thin */
+ { -0.4, 40 }, /* ultra-light, ultralight, extra-light, extralight */
+ { -0.23, 50 }, /* light */
+ { -0.115, 55 }, /* semi-light, semilight, demilight */
+ { 0, 80 }, /* regular, normal, unspecified, book */
+ { 0.2, 100 }, /* medium */
+ { 0.3, 180 }, /* semi-bold, semibold, demibold, demi-bold, demi */
+ { 0.4, 200 }, /* bold */
+ { 0.6, 205 }, /* extra-bold, extrabold, ultra-bold, ultrabold */
+ { 0.8, 210 }, /* black, heavy */
+ { 1, 250 }, /* ultra-heavy, ultraheavy */
+ { CGFLOAT_MAX, CGFLOAT_MAX } },
+ mac_font_descriptor_get_adjusted_weight },
+ { FONT_SLANT_INDEX,
+ kCTFontSlantTrait,
+ { { 0, 100 }, { 0.1, 200 }, { CGFLOAT_MAX, CGFLOAT_MAX } },
+ NULL },
+ { FONT_WIDTH_INDEX,
+ kCTFontWidthTrait,
+ { { -0.4, 50 }, /* ultra-condensed, ultracondensed */
+ { -0.3, 63 }, /* extra-condensed, extracondensed */
+ { -0.2, 75 }, /* condensed, compressed, narrow */
+ { -0.1, 87 }, /* semi-condensed, semicondensed, demicondensed */
+ { 0, 100 }, /* normal, medium, regular, unspecified */
+ { 0.1, 113 }, /* semi-expanded, semiexpanded, demiexpanded */
+ { 0.2, 125 }, /* expanded */
+ { 0.3, 150 }, /* extra-expanded, extraexpanded */
+ { 0.4, 200 }, /* ultra-expanded, ultraexpanded, wide */
+ { CGFLOAT_MAX, CGFLOAT_MAX } },
+ NULL }
+ };
int i;
for (i = 0; i < ARRAYELTS (numeric_traits); i++)
@@ -980,7 +1001,7 @@ macfont_invalidate_family_cache (void)
ptrdiff_t i, size = HASH_TABLE_SIZE (h);
for (i = 0; i < size; ++i)
- if (!NILP (HASH_HASH (h, i)))
+ if (!hash_unused_entry_key_p (HASH_KEY (h, i)))
{
Lisp_Object value = HASH_VALUE (h, i);
@@ -997,7 +1018,7 @@ macfont_get_family_cache_if_present (Lisp_Object symbol, CFStringRef *string)
if (HASH_TABLE_P (macfont_family_cache))
{
struct Lisp_Hash_Table *h = XHASH_TABLE (macfont_family_cache);
- ptrdiff_t i = hash_lookup (h, symbol, NULL);
+ ptrdiff_t i = hash_lookup (h, symbol);
if (i >= 0)
{
@@ -1017,13 +1038,14 @@ macfont_set_family_cache (Lisp_Object symbol, CFStringRef string)
{
struct Lisp_Hash_Table *h;
ptrdiff_t i;
- Lisp_Object hash, value;
+ Lisp_Object value;
if (!HASH_TABLE_P (macfont_family_cache))
macfont_family_cache = CALLN (Fmake_hash_table, QCtest, Qeq);
h = XHASH_TABLE (macfont_family_cache);
- i = hash_lookup (h, symbol, &hash);
+ hash_hash_t hash;
+ i = hash_lookup_get_hash (h, symbol, &hash);
value = string ? make_mint_ptr ((void *) CFRetain (string)) : Qnil;
if (i >= 0)
{
@@ -1940,19 +1962,38 @@ macfont_create_attributes_with_spec (Lisp_Object spec)
struct {
enum font_property_index index;
CFStringRef trait;
- CGPoint points[6];
- } numeric_traits[] =
- {{FONT_WEIGHT_INDEX, kCTFontWeightTrait,
- {{-0.4, 50}, /* light */
- {-0.24, 87.5}, /* (semi-light + normal) / 2 */
- {0, 100}, /* normal */
- {0.24, 140}, /* (semi-bold + normal) / 2 */
- {0.4, 200}, /* bold */
- {CGFLOAT_MAX, CGFLOAT_MAX}}},
- {FONT_SLANT_INDEX, kCTFontSlantTrait,
- {{0, 100}, {0.1, 200}, {CGFLOAT_MAX, CGFLOAT_MAX}}},
- {FONT_WIDTH_INDEX, kCTFontWidthTrait,
- {{0, 100}, {1, 200}, {CGFLOAT_MAX, CGFLOAT_MAX}}}};
+ CGPoint points[12];
+ } numeric_traits[] = {
+ { FONT_WEIGHT_INDEX,
+ kCTFontWeightTrait,
+ { { -0.6, 0 }, /* thin */
+ { -0.4, 40 }, /* ultra-light, ultralight, extra-light, extralight */
+ { -0.23, 50 }, /* light */
+ { -0.115, 55 }, /* semi-light, semilight, demilight */
+ { 0, 80 }, /* regular, normal, unspecified, book */
+ { 0.2, 100 }, /* medium */
+ { 0.3, 180 }, /* semi-bold, semibold, demibold, demi-bold, demi */
+ { 0.4, 200 }, /* bold */
+ { 0.6, 205 }, /* extra-bold, extrabold, ultra-bold, ultrabold */
+ { 0.8, 210 }, /* black, heavy */
+ { 1, 250 }, /* ultra-heavy, ultraheavy */
+ { CGFLOAT_MAX, CGFLOAT_MAX } } },
+ { FONT_SLANT_INDEX,
+ kCTFontSlantTrait,
+ { { 0, 100 }, { 0.1, 200 }, { CGFLOAT_MAX, CGFLOAT_MAX } } },
+ { FONT_WIDTH_INDEX,
+ kCTFontWidthTrait,
+ { { -0.4, 50 }, /* ultra-condensed, ultracondensed */
+ { -0.3, 63 }, /* extra-condensed, extracondensed */
+ { -0.2, 75 }, /* condensed, compressed, narrow */
+ { -0.1, 87 }, /* semi-condensed, semicondensed, demicondensed */
+ { 0, 100 }, /* normal, medium, regular, unspecified */
+ { 0.1, 113 }, /* semi-expanded, semiexpanded, demiexpanded */
+ { 0.2, 125 }, /* expanded */
+ { 0.3, 150 }, /* extra-expanded, extraexpanded */
+ { 0.4, 200 }, /* ultra-expanded, ultraexpanded, wide */
+ { CGFLOAT_MAX, CGFLOAT_MAX } } }
+ };
registry = AREF (spec, FONT_REGISTRY_INDEX);
if (NILP (registry)
diff --git a/src/macros.c b/src/macros.c
index 424e86044af..230195d9488 100644
--- a/src/macros.c
+++ b/src/macros.c
@@ -128,9 +128,9 @@ end_kbd_macro (void)
update_mode_lines = 20;
kset_last_kbd_macro
(current_kboard,
- make_event_array ((current_kboard->kbd_macro_end
- - current_kboard->kbd_macro_buffer),
- current_kboard->kbd_macro_buffer));
+ Fvector ((current_kboard->kbd_macro_end
+ - current_kboard->kbd_macro_buffer),
+ current_kboard->kbd_macro_buffer));
}
DEFUN ("end-kbd-macro", Fend_kbd_macro, Send_kbd_macro, 0, 2, "p",
@@ -314,6 +314,48 @@ buffer before the macro is executed. */)
Vreal_this_command));
record_unwind_protect (pop_kbd_macro, tem);
+ /* The following loop starts the execution of possibly multiple
+ iterations of the macro.
+
+ The state variables that control the execution of a single
+ iteration are Vexecuting_kbd_macro and executing_kbd_macro_index,
+ which can be accessed from lisp. The purpose of the variables
+ executing_kbd_macro and executing_kbd_macro_iteration is to
+ remember the most recently started macro and its iteration count.
+ This makes it possible to produce a meaningful message in case of
+ errors during the execution of the macro.
+
+ In a single iteration, individual characters from the macro are
+ read by read_char, which takes care of incrementing
+ executing_kbd_macro_index after each character.
+
+ The end of a macro iteration is handled as follows:
+ - read_key_sequence asks at_end_of_macro_p whether the end of the
+ iteration has been reached. If so, it returns the magic value 0
+ to command_loop_1.
+ - command_loop_1 returns Qnil to command_loop_2.
+ - command_loop_2 returns Qnil to this function
+ (but only the returning is relevant, not the actual value).
+
+ Macro executions form a stack. After the last iteration of the
+ execution of one stack item, or in case of an error during one of
+ the iterations, pop_kbd_macro (invoked via unwind-protect) will
+ restore Vexecuting_kbd_macro and executing_kbd_macro_index, and
+ run 'kbd-macro-termination-hook'.
+
+ If read_char happens to be called at the end of a macro interation,
+ but before read_key_sequence could handle the end (e.g., when lisp
+ code calls 'read-event', 'read-char', or 'read-char-exclusive'),
+ read_char will simply continue reading other available input
+ (Bug#68272). Vexecuting_kbd_macro and executing_kbd_macro remain
+ untouched until the end of the iteration is handled.
+
+ This is similar (in observable behavior) to a posibly simpler
+ implementation of keyboard macros in which this function pushed all
+ characters of the macro into the incoming event queue and returned
+ immediately. Maybe this is the implementation that we ideally
+ would like to have, but switching to it will require a larger code
+ change. */
do
{
Vexecuting_kbd_macro = final;
@@ -353,6 +395,18 @@ init_macros (void)
executing_kbd_macro = Qnil;
}
+/* Whether the execution of a macro has reached its end.
+ This should be called only while executing a macro. */
+
+bool
+at_end_of_macro_p (void)
+{
+ eassume (!NILP (Vexecuting_kbd_macro));
+ /* Some things replace the macro with t to force an early exit. */
+ return EQ (Vexecuting_kbd_macro, Qt)
+ || executing_kbd_macro_index >= XFIXNAT (Flength (Vexecuting_kbd_macro));
+}
+
void
syms_of_macros (void)
{
diff --git a/src/macros.h b/src/macros.h
index 51599a29bcd..cb6ac8aa206 100644
--- a/src/macros.h
+++ b/src/macros.h
@@ -47,4 +47,9 @@ extern void finalize_kbd_macro_chars (void);
extern void store_kbd_macro_char (Lisp_Object);
+/* Whether the execution of a macro has reached its end.
+ This should be called only while executing a macro. */
+
+extern bool at_end_of_macro_p (void);
+
#endif /* EMACS_MACROS_H */
diff --git a/src/marker.c b/src/marker.c
index d220dd82692..2abc951fc76 100644
--- a/src/marker.c
+++ b/src/marker.c
@@ -20,9 +20,15 @@ along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. */
#include <config.h>
+/* Work around GCC bug 113253. */
+#if __GNUC__ == 13
+# pragma GCC diagnostic ignored "-Wanalyzer-deref-before-check"
+#endif
+
#include "lisp.h"
#include "character.h"
#include "buffer.h"
+#include "window.h"
/* Record one cached position found recently by
buf_charpos_to_bytepos or buf_bytepos_to_charpos. */
@@ -457,6 +463,18 @@ DEFUN ("marker-position", Fmarker_position, Smarker_position, 1, 1, 0,
return Qnil;
}
+DEFUN ("marker-last-position", Fmarker_last_position, Smarker_last_position, 1, 1, 0,
+ doc: /* Return last position of MARKER in its buffer.
+This is like `marker-position' with one exception: If the buffer of
+MARKER is dead, it returns the last position of MARKER in that buffer
+before it was killed. */)
+ (Lisp_Object marker)
+{
+ CHECK_MARKER (marker);
+
+ return make_fixnum (XMARKER (marker)->charpos);
+}
+
/* Change M so it points to B at CHARPOS and BYTEPOS. */
static void
@@ -566,6 +584,31 @@ set_marker_internal (Lisp_Object marker, Lisp_Object position,
attach_marker (m, b, charpos, bytepos);
}
+
+#ifdef HAVE_TEXT_CONVERSION
+
+ /* If B is the buffer's mark and there is a window displaying B, and
+ text conversion is enabled while the mark is active, redisplay
+ the buffer.
+
+ propagate_window_redisplay will propagate this redisplay to the
+ window, which will eventually reach
+ mark_window_display_accurate_1. At that point,
+ report_point_change will be told to update the mark as seen by
+ the input method.
+
+ This is done all the way in (the seemingly irrelevant) redisplay
+ because the selection reported to the input method is actually what
+ is visible on screen, namely w->last_point. */
+
+ if (m->buffer
+ && EQ (marker, BVAR (m->buffer, mark))
+ && !NILP (BVAR (m->buffer, mark_active))
+ && buffer_window_count (m->buffer))
+ bset_redisplay (m->buffer);
+
+#endif
+
return marker;
}
@@ -799,6 +842,7 @@ void
syms_of_marker (void)
{
defsubr (&Smarker_position);
+ defsubr (&Smarker_last_position);
defsubr (&Smarker_buffer);
defsubr (&Sset_marker);
defsubr (&Scopy_marker);
diff --git a/src/menu.c b/src/menu.c
index 1fc5a7de9cc..de4d0964e9c 100644
--- a/src/menu.c
+++ b/src/menu.c
@@ -48,7 +48,7 @@ static bool
have_boxes (void)
{
#if defined (USE_X_TOOLKIT) || defined (USE_GTK) || defined (HAVE_NTGUI) || defined (HAVE_NS) \
- || defined (HAVE_HAIKU)
+ || defined (HAVE_HAIKU) || defined (HAVE_ANDROID)
if (FRAME_WINDOW_P (XFRAME (Vmenu_updating_frame)))
return 1;
#endif
@@ -167,7 +167,7 @@ ensure_menu_items (int items)
}
}
-#ifdef HAVE_EXT_MENU_BAR
+#if defined HAVE_EXT_MENU_BAR || defined HAVE_ANDROID
/* Begin a submenu. */
@@ -191,7 +191,7 @@ push_submenu_end (void)
menu_items_submenu_depth--;
}
-#endif /* HAVE_EXT_MENU_BAR */
+#endif /* HAVE_EXT_MENU_BAR || HAVE_ANDROID */
/* Indicate boundary between left and right. */
@@ -420,8 +420,9 @@ single_menu_item (Lisp_Object key, Lisp_Object item, Lisp_Object dummy, void *sk
AREF (item_properties, ITEM_PROPERTY_SELECTED),
AREF (item_properties, ITEM_PROPERTY_HELP));
-#if defined (USE_X_TOOLKIT) || defined (USE_GTK) || defined (HAVE_NS) \
- || defined (HAVE_NTGUI) || defined (HAVE_HAIKU) || defined (HAVE_PGTK)
+#if defined (USE_X_TOOLKIT) || defined (USE_GTK) || defined (HAVE_NS) \
+ || defined (HAVE_NTGUI) || defined (HAVE_HAIKU) || defined (HAVE_PGTK) \
+ || defined (HAVE_ANDROID)
/* Display a submenu using the toolkit. */
if (FRAME_WINDOW_P (XFRAME (Vmenu_updating_frame))
&& ! (NILP (map) || NILP (enabled)))
@@ -1151,7 +1152,7 @@ x_popup_menu_1 (Lisp_Object position, Lisp_Object menu)
else
{
menuflags |= MENU_FOR_CLICK;
- tem = Fcar (XCDR (position)); /* EVENT_START (position) */
+ tem = EVENT_START (position); /* EVENT_START (position) */
window = Fcar (tem); /* POSN_WINDOW (tem) */
tem2 = Fcar (Fcdr (tem)); /* POSN_POSN (tem) */
/* The MENU_KBD_NAVIGATION field is set when the menu
@@ -1465,9 +1466,10 @@ cached information about equivalent key sequences.
If the user gets rid of the menu without making a valid choice, for
instance by clicking the mouse away from a valid choice or by typing
keyboard input, then this normally results in a quit and
-`x-popup-menu' does not return. But if POSITION is a mouse button
-event (indicating that the user invoked the menu with the mouse) then
-no quit occurs and `x-popup-menu' returns nil. */)
+`x-popup-menu' does not return. But if POSITION is a mouse button or
+touch screen event (indicating that the user invoked the menu with the
+a pointing device) then no quit occurs and `x-popup-menu' returns
+nil. */)
(Lisp_Object position, Lisp_Object menu)
{
init_raw_keybuf_count ();
diff --git a/src/minibuf.c b/src/minibuf.c
index 6784c4be68c..51816133fb2 100644
--- a/src/minibuf.c
+++ b/src/minibuf.c
@@ -1615,13 +1615,15 @@ or from one of the possible completions. */)
ptrdiff_t bestmatchsize = 0;
/* These are in bytes, too. */
ptrdiff_t compare, matchsize;
+ if (VECTORP (collection))
+ collection = check_obarray (collection);
enum { function_table, list_table, obarray_table, hash_table}
type = (HASH_TABLE_P (collection) ? hash_table
- : VECTORP (collection) ? obarray_table
+ : OBARRAYP (collection) ? obarray_table
: ((NILP (collection)
|| (CONSP (collection) && !FUNCTIONP (collection)))
? list_table : function_table));
- ptrdiff_t idx = 0, obsize = 0;
+ ptrdiff_t idx = 0;
int matchcount = 0;
Lisp_Object bucket, zero, end, tem;
@@ -1634,12 +1636,9 @@ or from one of the possible completions. */)
/* If COLLECTION is not a list, set TAIL just for gc pro. */
tail = collection;
+ obarray_iter_t obit;
if (type == obarray_table)
- {
- collection = check_obarray (collection);
- obsize = ASIZE (collection);
- bucket = AREF (collection, idx);
- }
+ obit = make_obarray_iter (XOBARRAY (collection));
while (1)
{
@@ -1658,30 +1657,16 @@ or from one of the possible completions. */)
}
else if (type == obarray_table)
{
- if (!EQ (bucket, zero))
- {
- if (!SYMBOLP (bucket))
- error ("Bad data in guts of obarray");
- elt = bucket;
- eltstring = elt;
- if (XSYMBOL (bucket)->u.s.next)
- XSETSYMBOL (bucket, XSYMBOL (bucket)->u.s.next);
- else
- XSETFASTINT (bucket, 0);
- }
- else if (++idx >= obsize)
+ if (obarray_iter_at_end (&obit))
break;
- else
- {
- bucket = AREF (collection, idx);
- continue;
- }
+ elt = eltstring = obarray_iter_symbol (&obit);
+ obarray_iter_step (&obit);
}
else /* if (type == hash_table) */
{
while (idx < HASH_TABLE_SIZE (XHASH_TABLE (collection))
- && BASE_EQ (HASH_KEY (XHASH_TABLE (collection), idx),
- Qunbound))
+ && hash_unused_entry_key_p (HASH_KEY (XHASH_TABLE (collection),
+ idx)))
idx++;
if (idx >= HASH_TABLE_SIZE (XHASH_TABLE (collection)))
break;
@@ -1716,11 +1701,12 @@ or from one of the possible completions. */)
tem = Fcommandp (elt, Qnil);
else
{
- tem = (type == hash_table
- ? call2 (predicate, elt,
- HASH_VALUE (XHASH_TABLE (collection),
- idx - 1))
- : call1 (predicate, elt));
+ if (type == hash_table)
+ tem = call2 (predicate, elt,
+ HASH_VALUE (XHASH_TABLE (collection),
+ idx - 1));
+ else
+ tem = call1 (predicate, elt);
}
if (NILP (tem)) continue;
}
@@ -1858,10 +1844,15 @@ with a space are ignored unless STRING itself starts with a space. */)
{
Lisp_Object tail, elt, eltstring;
Lisp_Object allmatches;
- int type = HASH_TABLE_P (collection) ? 3
- : VECTORP (collection) ? 2
- : NILP (collection) || (CONSP (collection) && !FUNCTIONP (collection));
- ptrdiff_t idx = 0, obsize = 0;
+ if (VECTORP (collection))
+ collection = check_obarray (collection);
+ int type = (HASH_TABLE_P (collection)
+ ? 3 : (OBARRAYP (collection)
+ ? 2 : ((NILP (collection)
+ || (CONSP (collection)
+ && !FUNCTIONP (collection)))
+ ? 1 : 0)));
+ ptrdiff_t idx = 0;
Lisp_Object bucket, tem, zero;
CHECK_STRING (string);
@@ -1872,12 +1863,9 @@ with a space are ignored unless STRING itself starts with a space. */)
/* If COLLECTION is not a list, set TAIL just for gc pro. */
tail = collection;
+ obarray_iter_t obit;
if (type == 2)
- {
- collection = check_obarray (collection);
- obsize = ASIZE (collection);
- bucket = AREF (collection, idx);
- }
+ obit = make_obarray_iter (XOBARRAY (collection));
while (1)
{
@@ -1896,30 +1884,16 @@ with a space are ignored unless STRING itself starts with a space. */)
}
else if (type == 2)
{
- if (!EQ (bucket, zero))
- {
- if (!SYMBOLP (bucket))
- error ("Bad data in guts of obarray");
- elt = bucket;
- eltstring = elt;
- if (XSYMBOL (bucket)->u.s.next)
- XSETSYMBOL (bucket, XSYMBOL (bucket)->u.s.next);
- else
- XSETFASTINT (bucket, 0);
- }
- else if (++idx >= obsize)
+ if (obarray_iter_at_end (&obit))
break;
- else
- {
- bucket = AREF (collection, idx);
- continue;
- }
+ elt = eltstring = obarray_iter_symbol (&obit);
+ obarray_iter_step (&obit);
}
else /* if (type == 3) */
{
while (idx < HASH_TABLE_SIZE (XHASH_TABLE (collection))
- && BASE_EQ (HASH_KEY (XHASH_TABLE (collection), idx),
- Qunbound))
+ && hash_unused_entry_key_p (HASH_KEY (XHASH_TABLE (collection),
+ idx)))
idx++;
if (idx >= HASH_TABLE_SIZE (XHASH_TABLE (collection)))
break;
@@ -1961,10 +1935,12 @@ with a space are ignored unless STRING itself starts with a space. */)
tem = Fcommandp (elt, Qnil);
else
{
- tem = type == 3
- ? call2 (predicate, elt,
- HASH_VALUE (XHASH_TABLE (collection), idx - 1))
- : call1 (predicate, elt);
+ if (type == 3)
+ tem = call2 (predicate, elt,
+ HASH_VALUE (XHASH_TABLE (collection),
+ idx - 1));
+ else
+ tem = call1 (predicate, elt);
}
if (NILP (tem)) continue;
}
@@ -2059,8 +2035,7 @@ If COLLECTION is a function, it is called with three arguments:
the values STRING, PREDICATE and `lambda'. */)
(Lisp_Object string, Lisp_Object collection, Lisp_Object predicate)
{
- Lisp_Object tail, tem = Qnil;
- ptrdiff_t i = 0;
+ Lisp_Object tem = Qnil, arg = Qnil;
CHECK_STRING (string);
@@ -2070,61 +2045,56 @@ the values STRING, PREDICATE and `lambda'. */)
if (NILP (tem))
return Qnil;
}
- else if (VECTORP (collection))
+ else if (OBARRAYP (collection) || VECTORP (collection))
{
+ collection = check_obarray (collection);
/* Bypass intern-soft as that loses for nil. */
tem = oblookup (collection,
SSDATA (string),
SCHARS (string),
SBYTES (string));
- if (completion_ignore_case && !SYMBOLP (tem))
- {
- for (i = ASIZE (collection) - 1; i >= 0; i--)
- {
- tail = AREF (collection, i);
- if (SYMBOLP (tail))
- while (1)
- {
- if (BASE_EQ (Fcompare_strings (string, make_fixnum (0),
- Qnil,
- Fsymbol_name (tail),
- make_fixnum (0) , Qnil, Qt),
- Qt))
- {
- tem = tail;
- break;
- }
- if (XSYMBOL (tail)->u.s.next == 0)
- break;
- XSETSYMBOL (tail, XSYMBOL (tail)->u.s.next);
- }
- }
- }
+ if (completion_ignore_case && !BARE_SYMBOL_P (tem))
+ DOOBARRAY (XOBARRAY (collection), it)
+ {
+ Lisp_Object obj = obarray_iter_symbol (&it);
+ if (BASE_EQ (Fcompare_strings (string, make_fixnum (0),
+ Qnil,
+ Fsymbol_name (obj),
+ make_fixnum (0) , Qnil, Qt),
+ Qt))
+ {
+ tem = obj;
+ break;
+ }
+ }
- if (!SYMBOLP (tem))
+ if (!BARE_SYMBOL_P (tem))
return Qnil;
}
else if (HASH_TABLE_P (collection))
{
struct Lisp_Hash_Table *h = XHASH_TABLE (collection);
- i = hash_lookup (h, string, NULL);
+ ptrdiff_t i = hash_lookup (h, string);
if (i >= 0)
{
tem = HASH_KEY (h, i);
+ arg = HASH_VALUE (h, i);
goto found_matching_key;
}
else
- for (i = 0; i < HASH_TABLE_SIZE (h); ++i)
+ DOHASH (h, k, v)
{
- tem = HASH_KEY (h, i);
- if (BASE_EQ (tem, Qunbound)) continue;
+ tem = k;
Lisp_Object strkey = (SYMBOLP (tem) ? Fsymbol_name (tem) : tem);
if (!STRINGP (strkey)) continue;
if (BASE_EQ (Fcompare_strings (string, Qnil, Qnil,
strkey, Qnil, Qnil,
completion_ignore_case ? Qt : Qnil),
- Qt))
- goto found_matching_key;
+ Qt))
+ {
+ arg = v;
+ goto found_matching_key;
+ }
}
return Qnil;
found_matching_key: ;
@@ -2141,7 +2111,7 @@ the values STRING, PREDICATE and `lambda'. */)
if (!NILP (predicate))
{
return HASH_TABLE_P (collection)
- ? call2 (predicate, tem, HASH_VALUE (XHASH_TABLE (collection), i))
+ ? call2 (predicate, tem, arg)
: call1 (predicate, tem);
}
else
@@ -2320,7 +2290,6 @@ syms_of_minibuf (void)
DEFSYM (Qcurrent_input_method, "current-input-method");
DEFSYM (Qactivate_input_method, "activate-input-method");
- DEFSYM (Qcase_fold_search, "case-fold-search");
DEFSYM (Qmetadata, "metadata");
DEFSYM (Qcycle_sort_function, "cycle-sort-function");
diff --git a/src/module-env-29.h b/src/module-env-29.h
index 6ca03773181..e69de29bb2d 100644
--- a/src/module-env-29.h
+++ b/src/module-env-29.h
@@ -1,3 +0,0 @@
- /* Add module environment functions newly added in Emacs 29 here.
- Before Emacs 29 is released, remove this comment and start
- module-env-30.h on the master branch. */
diff --git a/src/module-env-30.h b/src/module-env-30.h
new file mode 100644
index 00000000000..e75210c7f8e
--- /dev/null
+++ b/src/module-env-30.h
@@ -0,0 +1,3 @@
+ /* Add module environment functions newly added in Emacs 30 here.
+ Before Emacs 30 is released, remove this comment and start
+ module-env-31.h on the master branch. */
diff --git a/src/msdos.c b/src/msdos.c
index 8d1b0958265..7e78c35027e 100644
--- a/src/msdos.c
+++ b/src/msdos.c
@@ -979,11 +979,15 @@ tty_draw_row_with_mouse_face (struct window *w, struct glyph_row *row,
if (hl == DRAW_MOUSE_FACE)
{
int vpos = row->y + WINDOW_TOP_EDGE_Y (w);
- int kstart = start_hpos + WINDOW_LEFT_EDGE_X (w);
+ int kstart = (start_hpos + WINDOW_LEFT_EDGE_X (w)
+ + row->used[LEFT_MARGIN_AREA]);
int nglyphs = end_hpos - start_hpos;
int offset = ScreenPrimary + 2*(vpos*screen_size_X + kstart) + 1;
int start_offset = offset;
+ if (end_hpos >= row->used[TEXT_AREA])
+ nglyphs = row->used[TEXT_AREA] - start_hpos;
+
if (tty->termscript)
fprintf (tty->termscript, "\n<MH+ %d-%d:%d>",
kstart, kstart + nglyphs - 1, vpos);
@@ -1021,6 +1025,9 @@ tty_draw_row_with_mouse_face (struct window *w, struct glyph_row *row,
temporarily move cursor coordinates to the beginning of
the highlight region. */
new_pos_X = start_hpos + WINDOW_LEFT_EDGE_X (w);
+ /* The coordinates supplied by the caller are relative to the
+ text area, not the window itself. */
+ new_pos_X += row->used[LEFT_MARGIN_AREA];
new_pos_Y = row->y + WINDOW_TOP_EDGE_Y (w);
if (tty->termscript)
@@ -2655,7 +2662,7 @@ dos_rawgetc (void)
static Lisp_Object last_mouse_window;
mouse_window = window_from_coordinates
- (SELECTED_FRAME (), mouse_last_x, mouse_last_y, 0, 0, 0);
+ (SELECTED_FRAME (), mouse_last_x, mouse_last_y, 0, 0, 0, 0);
/* A window will be selected only when it is not
selected now, and the last mouse movement event was
not in it. A minibuffer window will be selected iff
@@ -2804,14 +2811,10 @@ IT_menu_make_room (XMenu *menu)
else if (menu->allocated == menu->count)
{
int count = menu->allocated = menu->allocated + 10;
- menu->text
- = (char **) xrealloc (menu->text, count * sizeof (char *));
- menu->submenu
- = (XMenu **) xrealloc (menu->submenu, count * sizeof (XMenu *));
- menu->panenumber
- = (int *) xrealloc (menu->panenumber, count * sizeof (int));
- menu->help_text
- = (const char **) xrealloc (menu->help_text, count * sizeof (char *));
+ menu->text = xrealloc (menu->text, count * sizeof (char *));
+ menu->submenu = xrealloc (menu->submenu, count * sizeof (XMenu *));
+ menu->panenumber = xrealloc (menu->panenumber, count * sizeof (int));
+ menu->help_text = xrealloc (menu->help_text, count * sizeof (char *));
}
}
@@ -2862,7 +2865,7 @@ IT_menu_calc_size (XMenu *menu, int *width, int *height)
do \
{ \
(GLYPH).type = CHAR_GLYPH; \
- SET_CHAR_GLYPH ((GLYPH), CODE, FACE_ID, PADDING_P); \
+ SET_CHAR_GLYPH (GLYPH, CODE, FACE_ID, PADDING_P); \
(GLYPH).charpos = -1; \
} \
while (0)
diff --git a/src/nsfns.m b/src/nsfns.m
index b0281aac257..c521140bd68 100644
--- a/src/nsfns.m
+++ b/src/nsfns.m
@@ -641,6 +641,11 @@ ns_change_tab_bar_height (struct frame *f, int height)
leading to the tab bar height being incorrectly set upon the next
call to x_set_font. (bug#59285) */
int lines = height / unit;
+
+ /* Even so, HEIGHT might be less than unit if the tab bar face is
+ not so tall as the frame's font height; which if true lines will
+ be set to 0 and the tab bar will thus vanish. */
+
if (lines == 0 && height != 0)
lines = 1;
@@ -685,6 +690,12 @@ ns_change_tab_bar_height (struct frame *f, int height)
SET_FRAME_GARBAGED (f);
}
+void
+ns_make_frame_key_window (struct frame *f)
+{
+ [[FRAME_NS_VIEW (f) window] makeKeyWindow];
+}
+
/* tabbar support */
static void
ns_set_tab_bar_lines (struct frame *f, Lisp_Object value, Lisp_Object oldval)
@@ -706,8 +717,10 @@ ns_set_tab_bar_lines (struct frame *f, Lisp_Object value, Lisp_Object oldval)
ns_change_tab_bar_height (f, nlines * FRAME_LINE_HEIGHT (f));
}
+
+
+/* Tool bar support. */
-/* toolbar support */
static void
ns_set_tool_bar_lines (struct frame *f, Lisp_Object value, Lisp_Object oldval)
{
@@ -760,7 +773,16 @@ ns_set_tool_bar_lines (struct frame *f, Lisp_Object value, Lisp_Object oldval)
}
static void
-ns_set_child_frame_border_width (struct frame *f, Lisp_Object arg, Lisp_Object oldval)
+ns_set_tool_bar_position (struct frame *f, Lisp_Object arg,
+ Lisp_Object oldval)
+{
+ if (!EQ (arg, Qtop))
+ error ("Tool bar position must be `top'");
+}
+
+static void
+ns_set_child_frame_border_width (struct frame *f, Lisp_Object arg,
+ Lisp_Object oldval)
{
int border;
@@ -783,6 +805,26 @@ ns_set_child_frame_border_width (struct frame *f, Lisp_Object arg, Lisp_Object o
}
static void
+ns_set_inhibit_double_buffering (struct frame *f,
+ Lisp_Object new_value,
+ Lisp_Object old_value)
+{
+#if defined (NS_IMPL_COCOA) && MAC_OS_X_VERSION_MIN_REQUIRED >= 101400
+ if (!EQ (new_value, old_value))
+ {
+ FRAME_DOUBLE_BUFFERED (f) = NILP (new_value);
+
+ /* If the view or layer haven't been created yet this will be a
+ noop. */
+ [(EmacsLayer *)[FRAME_NS_VIEW (f) layer]
+ setDoubleBuffered:FRAME_DOUBLE_BUFFERED (f)];
+
+ SET_FRAME_GARBAGED (f);
+ }
+#endif
+}
+
+static void
ns_set_internal_border_width (struct frame *f, Lisp_Object arg, Lisp_Object oldval)
{
int old_width = FRAME_INTERNAL_BORDER_WIDTH (f);
@@ -1055,8 +1097,8 @@ frame_parm_handler ns_frame_parm_handlers[] =
gui_set_font_backend, /* generic OK */
gui_set_alpha,
0, /* x_set_sticky */
- 0, /* x_set_tool_bar_position */
- 0, /* x_set_inhibit_double_buffering */
+ ns_set_tool_bar_position,
+ ns_set_inhibit_double_buffering,
ns_set_undecorated,
ns_set_parent_frame,
0, /* x_set_skip_taskbar */
@@ -1444,6 +1486,14 @@ DEFUN ("x-create-frame", Fx_create_frame, Sx_create_frame,
gui_default_parameter (f, parms, Qtitle, Qnil, "title", "Title",
RES_TYPE_STRING);
+#if defined (NS_IMPL_COCOA) && MAC_OS_X_VERSION_MIN_REQUIRED >= 101400
+ tem = gui_display_get_arg (dpyinfo, parms, Qinhibit_double_buffering, NULL, NULL,
+ RES_TYPE_BOOLEAN);
+ FRAME_DOUBLE_BUFFERED (f) = NILP (tem) || EQ (tem, Qunbound);
+ store_frame_param (f, Qinhibit_double_buffering,
+ FRAME_DOUBLE_BUFFERED (f) ? Qnil : Qt);
+#endif
+
parms = get_geometry_from_preferences (dpyinfo, parms);
window_prompting = gui_figure_window_size (f, parms, false, true);
@@ -3785,6 +3835,27 @@ all_nonzero_ascii (unsigned char *str, ptrdiff_t n)
return true;
}
+/* Count the number of characters in STR, NBYTES long.
+ The string must be valid UTF-8. */
+static ptrdiff_t
+count_utf8_chars (const char *str, ptrdiff_t nbytes)
+{
+ /* This is faster than parse_str_as_multibyte, and much faster than
+ [NSString lengthOfBytesUsingEncoding: NSUTF32StringEncoding]. */
+ const char *end = str + nbytes;
+ ptrdiff_t nc = 0;
+ while (str < end)
+ {
+ nc++;
+ unsigned char c = *str;
+ str += ( c <= 0x7f ? 1 // 0xxxxxxx
+ : c <= 0xdf ? 2 // 110xxxxx 10xxxxxx
+ : c <= 0xef ? 3 // 1110xxxx 10xxxxxx 10xxxxxx
+ : 4); // 11110xxx 10xxxxxx 10xxxxxx 10xxxxxx
+ }
+ return nc;
+}
+
@implementation NSString (EmacsString)
/* Make an NSString from a Lisp string. STRING must not be in an
encoded form (e.g. UTF-8). */
@@ -3829,9 +3900,11 @@ all_nonzero_ascii (unsigned char *str, ptrdiff_t n)
/* Make a Lisp string from an NSString. */
- (Lisp_Object)lispString
{
- // make_string behaves predictably and correctly with UTF-8 input.
- return make_string ([self UTF8String],
- [self lengthOfBytesUsingEncoding: NSUTF8StringEncoding]);
+ /* If the input string includes unpaired surrogates, then the result
+ will be an empty string. */
+ const char *utf8 = [self UTF8String];
+ ptrdiff_t bytes = [self lengthOfBytesUsingEncoding: NSUTF8StringEncoding];
+ return make_multibyte_string (utf8, count_utf8_chars (utf8, bytes), bytes);
}
@end
diff --git a/src/nsfont.m b/src/nsfont.m
index 1205fbe5263..4e1d85a5c4a 100644
--- a/src/nsfont.m
+++ b/src/nsfont.m
@@ -601,7 +601,7 @@ static NSString
{
Lisp_Object script = assq_no_quit (XCAR (otf), Votf_script_alist);
return CONSP (script)
- ? [NSString stringWithLispString: SYMBOL_NAME (XCDR ((script)))]
+ ? [NSString stringWithLispString: SYMBOL_NAME (XCDR (script))]
: @"";
}
@@ -1035,7 +1035,7 @@ nsfont_open (struct frame *f, Lisp_Object font_entity, int pixel_size)
font->underline_position = lrint (font_info->underpos);
font->underline_thickness = lrint (font_info->underwidth);
- font->props[FONT_NAME_INDEX] = Ffont_xlfd_name (font_object, Qnil);
+ font->props[FONT_NAME_INDEX] = Ffont_xlfd_name (font_object, Qnil, Qnil);
font->props[FONT_FULLNAME_INDEX] = build_unibyte_string (font_info->name);
}
unblock_input ();
diff --git a/src/nsimage.m b/src/nsimage.m
index d1ac6b074ea..ee72d6e0ea1 100644
--- a/src/nsimage.m
+++ b/src/nsimage.m
@@ -78,6 +78,10 @@ ns_can_use_native_image_api (Lisp_Object type)
else if (EQ (type, Qsvg))
imageType = @"public.svg-image";
#endif
+#ifndef HAVE_WEBP
+ else if (EQ (type, Qwebp))
+ imageType = @"org.webmproject.webp";
+#endif
else if (EQ (type, Qheic))
imageType = @"public.heic";
diff --git a/src/nsmenu.m b/src/nsmenu.m
index 1a75735bacd..0d21f7d03d3 100644
--- a/src/nsmenu.m
+++ b/src/nsmenu.m
@@ -768,6 +768,10 @@ prettify_key (const char *key)
pressure: 0];
context_menu_value = -1;
+#ifdef NS_IMPL_COCOA
+ /* Don't let the system add a Services menu here. */
+ self.allowsContextMenuPlugIns = NO;
+#endif
[NSMenu popUpContextMenu: self withEvent: event forView: view];
retVal = context_menu_value;
context_menu_value = 0;
diff --git a/src/nsterm.h b/src/nsterm.h
index c2965cfcc0f..ae940ec5b4f 100644
--- a/src/nsterm.h
+++ b/src/nsterm.h
@@ -278,9 +278,9 @@ char const * nstrace_fullscreen_type_name (int);
#define NSTRACE_WHEN(cond, ...) \
- __attribute__((cleanup(nstrace_restore_global_trace_state))) \
+ __attribute__ ((cleanup (nstrace_restore_global_trace_state))) \
int nstrace_saved_enabled_global = nstrace_enabled_global; \
- __attribute__((cleanup(nstrace_leave))) \
+ __attribute__ ((cleanup (nstrace_leave))) \
int nstrace_enabled = nstrace_enabled_global && (cond); \
if (nstrace_enabled) { ++nstrace_depth; } \
else { nstrace_enabled_global = 0; } \
@@ -746,9 +746,11 @@ enum ns_return_frame_mode
CGColorSpaceRef colorSpace;
IOSurfaceRef currentSurface;
CGContextRef context;
+ bool doubleBuffered;
}
-- (id) initWithColorSpace: (CGColorSpaceRef)cs;
+- (id) initWithDoubleBuffered: (bool)db;
- (void) setColorSpace: (CGColorSpaceRef)cs;
+- (void) setDoubleBuffered: (bool)db;
- (CGContextRef) getContext;
@end
#endif
@@ -996,6 +998,11 @@ struct ns_output
/* Non-zero if we are doing an animation, e.g. toggling the tool bar. */
int in_animation;
+#if defined (NS_IMPL_COCOA) && MAC_OS_X_VERSION_MIN_REQUIRED >= 101400
+ /* Is the frame double buffered? */
+ bool double_buffered;
+#endif
+
#ifdef NS_IMPL_GNUSTEP
/* Zero if this is the first time a toolbar has been updated on this
frame. */
@@ -1030,6 +1037,10 @@ struct x_output
#define FRAME_FONT(f) ((f)->output_data.ns->font)
+#if defined (NS_IMPL_COCOA) && MAC_OS_X_VERSION_MIN_REQUIRED >= 101400
+#define FRAME_DOUBLE_BUFFERED(f) ((f)->output_data.ns->double_buffered)
+#endif
+
#ifdef __OBJC__
#define XNS_SCROLL_BAR(vec) ((id) xmint_pointer (vec))
#else
@@ -1169,6 +1180,7 @@ extern void ns_retain_object (void *obj);
extern void *ns_alloc_autorelease_pool (void);
extern void ns_release_autorelease_pool (void *);
extern const char *ns_get_defaults_value (const char *key);
+extern void ns_init_pool (void);
extern void ns_init_locale (void);
/* in nsmenu */
@@ -1278,7 +1290,7 @@ extern char gnustep_base_version[]; /* version tracking */
/* Little utility macros */
#define IN_BOUND(min, x, max) (((x) < (min)) \
? (min) : (((x)>(max)) ? (max) : (x)))
-#define SCREENMAXBOUND(x) (IN_BOUND (-SCREENMAX, x, SCREENMAX))
+#define SCREENMAXBOUND(x) IN_BOUND (-SCREENMAX, x, SCREENMAX)
#ifdef NS_IMPL_COCOA
diff --git a/src/nsterm.m b/src/nsterm.m
index 518b38658d1..faf9324402b 100644
--- a/src/nsterm.m
+++ b/src/nsterm.m
@@ -550,6 +550,15 @@ ns_relocate (const char *epath)
void
+ns_init_pool (void)
+/* Initialize the 'outerpool' autorelease pool. This should be called
+ from main before any Objective C code is run. */
+{
+ outerpool = [[NSAutoreleasePool alloc] init];
+}
+
+
+void
ns_init_locale (void)
/* macOS doesn't set any environment variables for the locale when run
from the GUI. Get the locale from the OS and set LANG. */
@@ -1627,7 +1636,7 @@ ns_free_frame_resources (struct frame *f)
[f->output_data.ns->miniimage release];
[[view window] close];
- [view release];
+ [view removeFromSuperview];
xfree (f->output_data.ns);
f->output_data.ns = NULL;
@@ -2707,12 +2716,11 @@ ns_scroll_run (struct window *w, struct run *run)
{
NSRect srcRect = NSMakeRect (x, from_y, width, height);
NSPoint dest = NSMakePoint (x, to_y);
- NSRect destRect = NSMakeRect (x, from_y, width, height);
EmacsView *view = FRAME_NS_VIEW (f);
[view copyRect:srcRect to:dest];
-#ifdef NS_IMPL_COCOA
- [view setNeedsDisplayInRect:destRect];
+#if defined (NS_IMPL_COCOA) && MAC_OS_X_VERSION_MAX_ALLOWED < 101400
+ [view setNeedsDisplayInRect:srcRect];
#endif
}
@@ -2731,6 +2739,7 @@ ns_clear_under_internal_border (struct frame *f)
int width = FRAME_PIXEL_WIDTH (f);
int height = FRAME_PIXEL_HEIGHT (f);
int margin = FRAME_TOP_MARGIN_HEIGHT (f);
+ int bottom_margin = FRAME_BOTTOM_MARGIN_HEIGHT (f);
int face_id =
(FRAME_PARENT_FRAME (f)
? (!NILP (Vface_remapping_alist)
@@ -2756,7 +2765,8 @@ ns_clear_under_internal_border (struct frame *f)
NSRectFill (NSMakeRect (0, 0, border, height));
NSRectFill (NSMakeRect (0, margin, width, border));
NSRectFill (NSMakeRect (width - border, 0, border, height));
- NSRectFill (NSMakeRect (0, height - border, width, border));
+ NSRectFill (NSMakeRect (0, height - bottom_margin - border,
+ width, border));
ns_unfocus (f);
}
}
@@ -4562,21 +4572,6 @@ ns_send_appdefined (int value)
/* Only post this event if we haven't already posted one. This will end
the [NXApp run] main loop after having processed all events queued at
this moment. */
-
-#ifdef NS_IMPL_COCOA
- if (! send_appdefined)
- {
- /* OS X 10.10.1 swallows the AppDefined event we are sending ourselves
- in certain situations (rapid incoming events).
- So check if we have one, if not add one. */
- NSEvent *appev = [NSApp nextEventMatchingMask:NSEventMaskApplicationDefined
- untilDate:[NSDate distantPast]
- inMode:NSDefaultRunLoopMode
- dequeue:NO];
- if (! appev) send_appdefined = YES;
- }
-#endif
-
if (send_appdefined)
{
NSEvent *nxev;
@@ -4611,7 +4606,7 @@ ns_send_appdefined (int value)
#if defined (NS_IMPL_COCOA) && MAC_OS_X_VERSION_MAX_ALLOWED >= 1070
static void
-check_native_fs ()
+check_native_fs (void)
{
Lisp_Object frame, tail;
@@ -4744,12 +4739,15 @@ ns_select_1 (int nfds, fd_set *readfds, fd_set *writefds,
check_native_fs ();
#endif
- if (hold_event_q.nr > 0 && !run_loop_only)
+ /* If there are input events pending, store them so that Emacs can
+ recognize C-g. (And we must make sure [NSApp run] is called in
+ this function, so that C-g has a chance to land in
+ hold_event_q.) */
+ if (hold_event_q.nr > 0)
{
- /* We already have events pending. */
- raise (SIGIO);
- errno = EINTR;
- return -1;
+ for (int i = 0; i < hold_event_q.nr; ++i)
+ kbd_buffer_store_event_hold (&hold_event_q.q[i], NULL);
+ hold_event_q.nr = 0;
}
eassert (nfds <= FD_SETSIZE);
@@ -4759,11 +4757,15 @@ ns_select_1 (int nfds, fd_set *readfds, fd_set *writefds,
if (writefds && FD_ISSET(k, writefds)) ++nr;
}
- if (NSApp == nil
- || ![NSThread isMainThread]
+ /* emacs -nw doesn't have an NSApp, so we're done. */
+ if (NSApp == nil)
+ return thread_select (pselect, nfds, readfds, writefds, exceptfds,
+ timeout, sigmask);
+
+ if (![NSThread isMainThread]
|| (timeout && timeout->tv_sec == 0 && timeout->tv_nsec == 0))
- return thread_select (pselect, nfds, readfds, writefds,
- exceptfds, timeout, sigmask);
+ thread_select (pselect, nfds, readfds, writefds,
+ exceptfds, timeout, sigmask);
else
{
struct timespec t = {0, 0};
@@ -6716,16 +6718,8 @@ ns_create_font_panel_buttons (id target, SEL select, SEL cancel_action)
- (void)resetCursorRects
{
- NSRect visible;
- NSCursor *currentCursor;
-
- /* On macOS 13, [resetCursorRects:] could be called even after the
- window is closed. */
- if (! emacsframe || ! FRAME_OUTPUT_DATA (emacsframe))
- return;
-
- visible = [self visibleRect];
- currentCursor = FRAME_POINTER_TYPE (emacsframe);
+ NSRect visible = [self visibleRect];
+ NSCursor *currentCursor = FRAME_POINTER_TYPE (emacsframe);
NSTRACE ("[EmacsView resetCursorRects]");
if (currentCursor == nil)
@@ -7080,13 +7074,9 @@ ns_create_font_panel_buttons (id target, SEL select, SEL cancel_action)
static Lisp_Object
ns_in_echo_area_1 (void *ptr)
{
- Lisp_Object in_echo_area;
- specpdl_ref count;
-
- count = SPECPDL_INDEX ();
+ const specpdl_ref count = SPECPDL_INDEX ();
specbind (Qinhibit_quit, Qt);
- in_echo_area = safe_call (1, Qns_in_echo_area);
-
+ const Lisp_Object in_echo_area = safe_calln (Qns_in_echo_area);
return unbind_to (count, in_echo_area);
}
@@ -7434,7 +7424,7 @@ ns_in_echo_area (void)
int x = lrint (p.x);
int y = lrint (p.y);
- window = window_from_coordinates (emacsframe, x, y, 0, true, true);
+ window = window_from_coordinates (emacsframe, x, y, 0, true, true, true);
tab_bar_p = EQ (window, emacsframe->tab_bar_window);
if (tab_bar_p)
@@ -7540,7 +7530,7 @@ ns_in_echo_area (void)
NSTRACE_MSG ("mouse_autoselect_window");
static Lisp_Object last_mouse_window;
Lisp_Object window
- = window_from_coordinates (emacsframe, pt.x, pt.y, 0, 0, 0);
+ = window_from_coordinates (emacsframe, pt.x, pt.y, 0, 0, 0, 0);
if (WINDOWP (window)
&& !EQ (window, last_mouse_window)
@@ -7936,8 +7926,6 @@ ns_in_echo_area (void)
maximizing_resize = NO;
#endif
- [[EmacsWindow alloc] initWithEmacsFrame:f];
-
#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
@@ -7948,9 +7936,16 @@ ns_in_echo_area (void)
NSViewLayerContentsRedrawOnSetNeedsDisplay];
[self setLayerContentsPlacement:NSViewLayerContentsPlacementTopLeft];
- /* initWithEmacsFrame can't create the toolbar before the layer is
- set, so have another go at creating the toolbar here. */
- [(EmacsWindow*)[self window] createToolbar:f];
+ [[EmacsWindow alloc] initWithEmacsFrame:f];
+
+ /* Now the NSWindow has been created, we can finish up configuring
+ the layer. */
+ [(EmacsLayer *)[self layer] setColorSpace:
+ [[[self window] colorSpace] CGColorSpace]];
+ [(EmacsLayer *)[self layer] setContentsScale:
+ [[self window] backingScaleFactor]];
+#else
+ [[EmacsWindow alloc] initWithEmacsFrame:f];
#endif
if (ns_drag_types)
@@ -8621,9 +8616,9 @@ ns_in_echo_area (void)
- (CALayer *)makeBackingLayer
{
EmacsLayer *l = [[EmacsLayer alloc]
- initWithColorSpace:[[[self window] colorSpace] CGColorSpace]];
+ initWithDoubleBuffered:FRAME_DOUBLE_BUFFERED (emacsframe)];
+
[l setDelegate:(id)self];
- [l setContentsScale:[[self window] backingScaleFactor]];
return l;
}
@@ -8678,8 +8673,10 @@ ns_in_echo_area (void)
NSHeight (srcRect));
#if defined (NS_IMPL_COCOA) && MAC_OS_X_VERSION_MIN_REQUIRED >= 101400
- double scale = [[self window] backingScaleFactor];
CGContextRef context = [(EmacsLayer *)[self layer] getContext];
+ CGContextFlush (context);
+
+ double scale = [[self window] backingScaleFactor];
int bpp = CGBitmapContextGetBitsPerPixel (context) / 8;
void *pixels = CGBitmapContextGetData (context);
int rowSize = CGBitmapContextGetBytesPerRow (context);
@@ -8844,8 +8841,8 @@ ns_in_echo_area (void)
so call this function instead. */
XSETFRAME (frame, emacsframe);
- safe_call (4, Vns_drag_motion_function, frame,
- make_fixnum (x), make_fixnum (y));
+ safe_calln (Vns_drag_motion_function, frame,
+ make_fixnum (x), make_fixnum (y));
redisplay ();
#endif
@@ -10449,22 +10446,19 @@ nswindow_orderedIndex_sort (id w1, id w2, void *c)
cache. If no free surfaces are found in the cache then a new one
is created. */
-#define CACHE_MAX_SIZE 2
-
-- (id) initWithColorSpace: (CGColorSpaceRef)cs
+- (id) initWithDoubleBuffered: (bool)db
{
- NSTRACE ("[EmacsLayer initWithColorSpace:]");
+ NSTRACE ("[EmacsLayer initWithDoubleBuffered:]");
self = [super init];
if (self)
{
- cache = [[NSMutableArray arrayWithCapacity:CACHE_MAX_SIZE] retain];
- [self setColorSpace:cs];
+ [self setColorSpace:nil];
+ [self setDoubleBuffered:db];
+ cache = [[NSMutableArray arrayWithCapacity:(doubleBuffered ? 2 : 1)] retain];
}
else
- {
- return nil;
- }
+ return nil;
return self;
}
@@ -10481,6 +10475,15 @@ nswindow_orderedIndex_sort (id w1, id w2, void *c)
}
+- (void) setDoubleBuffered: (bool)db
+{
+ if (doubleBuffered != db)
+ [self releaseSurfaces];
+
+ doubleBuffered = db;
+}
+
+
- (void) dealloc
{
[self releaseSurfaces];
@@ -10552,7 +10555,7 @@ nswindow_orderedIndex_sort (id w1, id w2, void *c)
}
}
- if (!surface && [cache count] >= CACHE_MAX_SIZE)
+ if (!surface && [cache count] >= (doubleBuffered ? 2 : 1))
{
/* Just grab the first one off the cache. This may result
in tearing effects. The alternative is to wait for one
@@ -10605,7 +10608,7 @@ nswindow_orderedIndex_sort (id w1, id w2, void *c)
return nil;
}
- CGContextTranslateCTM(context, 0, IOSurfaceGetHeight (currentSurface));
+ CGContextTranslateCTM(context, 0, IOSurfaceGetHeight (surface));
CGContextScaleCTM(context, scale, -scale);
}
@@ -10622,6 +10625,7 @@ nswindow_orderedIndex_sort (id w1, id w2, void *c)
if (!context)
return;
+ CGContextFlush (context);
CGContextRelease (context);
context = NULL;
@@ -10635,26 +10639,18 @@ nswindow_orderedIndex_sort (id w1, id w2, void *c)
{
NSTRACE_WHEN (NSTRACE_GROUP_FOCUS, "[EmacsLayer display]");
- if (context)
+ if (context && context != [[NSGraphicsContext currentContext] CGContext])
{
[self releaseContext];
-#if CACHE_MAX_SIZE == 1
- /* This forces the layer to see the surface as updated. */
+ /* This forces the layer to see the surface as updated even if
+ we replace it with itself. */
[self setContents:nil];
-#endif
-
[self setContents:(id)currentSurface];
/* Put currentSurface back on the end of the cache. */
[cache addObject:(id)currentSurface];
currentSurface = NULL;
-
- /* Schedule a run of getContext so that if Emacs is idle it will
- perform the buffer copy, etc. */
- [self performSelectorOnMainThread:@selector (getContext)
- withObject:nil
- waitUntilDone:NO];
}
}
diff --git a/src/pdumper.c b/src/pdumper.c
index 1b5ead5fb4a..ac8bf6f31f4 100644
--- a/src/pdumper.c
+++ b/src/pdumper.c
@@ -103,7 +103,6 @@ verify (sizeof (intptr_t) == sizeof (ptrdiff_t));
verify (sizeof (void (*) (void)) == sizeof (void *));
verify (sizeof (ptrdiff_t) <= sizeof (Lisp_Object));
verify (sizeof (ptrdiff_t) <= sizeof (EMACS_INT));
-verify (CHAR_BIT == 8);
static size_t
divide_round_up (size_t x, size_t y)
@@ -133,6 +132,7 @@ static int nr_remembered_data = 0;
typedef int_least32_t dump_off;
#define DUMP_OFF_MIN INT_LEAST32_MIN
#define DUMP_OFF_MAX INT_LEAST32_MAX
+#define DUMP_OFF_WIDTH INT_LEAST32_WIDTH
#define PRIdDUMP_OFF PRIdLEAST32
enum { EMACS_INT_XDIGITS = (EMACS_INT_WIDTH + 3) / 4 };
@@ -222,8 +222,7 @@ enum emacs_reloc_type
enum
{
EMACS_RELOC_TYPE_BITS = 3,
- EMACS_RELOC_LENGTH_BITS = (sizeof (dump_off) * CHAR_BIT
- - EMACS_RELOC_TYPE_BITS)
+ EMACS_RELOC_LENGTH_BITS = DUMP_OFF_WIDTH - EMACS_RELOC_TYPE_BITS
};
struct emacs_reloc
@@ -273,7 +272,7 @@ enum
dump. Always suitable for heap objects; may be more aligned. */
DUMP_ALIGNMENT = max (GCALIGNMENT, DUMP_RELOCATION_ALIGNMENT),
- DUMP_RELOC_OFFSET_BITS = sizeof (dump_off) * CHAR_BIT - DUMP_RELOC_TYPE_BITS
+ DUMP_RELOC_OFFSET_BITS = DUMP_OFF_WIDTH - DUMP_RELOC_TYPE_BITS
};
verify (RELOC_DUMP_TO_EMACS_LV + 8 < (1 << DUMP_RELOC_TYPE_BITS));
@@ -1227,7 +1226,7 @@ dump_queue_dequeue (struct dump_queue *dump_queue, dump_off basis)
dump_tailq_length (&dump_queue->zero_weight_objects),
dump_tailq_length (&dump_queue->one_weight_normal_objects),
dump_tailq_length (&dump_queue->one_weight_strong_objects),
- XHASH_TABLE (dump_queue->link_weights)->count);
+ (ptrdiff_t) XHASH_TABLE (dump_queue->link_weights)->count);
static const int nr_candidates = 3;
struct candidate
@@ -1332,13 +1331,7 @@ dump_queue_dequeue (struct dump_queue *dump_queue, dump_off basis)
static bool
dump_object_needs_dumping_p (Lisp_Object object)
{
- /* Some objects, like symbols, are self-representing because they
- have invariant bit patterns, but sometimes these objects have
- associated data too, and these data-carrying objects need to be
- included in the dump despite all references to them being
- bitwise-invariant. */
- return (!dump_object_self_representing_p (object)
- || dump_object_emacs_ptr (object));
+ return !(FIXNUMP (object));
}
static void
@@ -1865,11 +1858,10 @@ dump_field_lv_or_rawptr (struct dump_context *ctx,
/* Set a pointer field on an output object during dump.
- CTX is the dump context. OFFSET is the offset at which the current
- object starts. OUT is a pointer to the dump output object.
- IN_START is the start of the current Emacs object. IN_FIELD is a
- pointer to the field in that object. TYPE is the type of pointer
- to which IN_FIELD points.
+ CTX is the dump context. OUT is a pointer to the dump output
+ object. IN_START is the start of the current Emacs object.
+ IN_FIELD is a pointer to the field in that object. TYPE is the
+ type of pointer to which IN_FIELD points.
*/
static void
dump_field_lv_rawptr (struct dump_context *ctx,
@@ -1884,8 +1876,7 @@ dump_field_lv_rawptr (struct dump_context *ctx,
/* Set a Lisp_Object field on an output object during dump.
- CTX is a dump context. OFFSET is the offset at which the current
- object starts. OUT is a pointer to the dump output object.
+ CTX is a dump context. OUT is a pointer to the dump output object.
IN_START is the start of the current Emacs object. IN_FIELD is a
pointer to a Lisp_Object field in that object.
@@ -2459,10 +2450,10 @@ dump_symbol (struct dump_context *ctx,
Lisp_Object object,
dump_off offset)
{
-#if CHECK_STRUCTS && !defined HASH_Lisp_Symbol_999DC26DEC
+#if CHECK_STRUCTS && !defined HASH_Lisp_Symbol_61B174C9F4
# error "Lisp_Symbol changed. See CHECK_STRUCTS comment in config.h."
#endif
-#if CHECK_STRUCTS && !defined (HASH_symbol_redirect_ADB4F5B113)
+#if CHECK_STRUCTS && !defined (HASH_symbol_redirect_EA72E4BFF5)
# error "symbol_redirect changed. See CHECK_STRUCTS comment in config.h."
#endif
@@ -2556,7 +2547,7 @@ static dump_off
dump_vectorlike_generic (struct dump_context *ctx,
const union vectorlike_header *header)
{
-#if CHECK_STRUCTS && !defined (HASH_vectorlike_header_00A5A4BFB2)
+#if CHECK_STRUCTS && !defined (HASH_vectorlike_header_785E52047B)
# error "vectorlike_header changed. See CHECK_STRUCTS comment in config.h."
#endif
const struct Lisp_Vector *v = (const struct Lisp_Vector *) header;
@@ -2647,73 +2638,88 @@ dump_vectorlike_generic (struct dump_context *ctx,
return offset;
}
-/* Return a vector of KEY, VALUE pairs in the given hash table H. The
- first H->count pairs are valid, and the rest are unbound. */
-static Lisp_Object
+/* Return a vector of KEY, VALUE pairs in the given hash table H.
+ No room for growth is included. */
+static Lisp_Object *
hash_table_contents (struct Lisp_Hash_Table *h)
{
- if (h->test.hashfn == hashfn_user_defined)
- error ("cannot dump hash tables with user-defined tests"); /* Bug#36769 */
-
- ptrdiff_t size = HASH_TABLE_SIZE (h);
- Lisp_Object key_and_value = make_uninit_vector (2 * size);
+ ptrdiff_t size = h->count;
+ Lisp_Object *key_and_value = hash_table_alloc_bytes (2 * size
+ * sizeof *key_and_value);
ptrdiff_t n = 0;
- /* Make sure key_and_value ends up in the same order; charset.c
- relies on it by expecting hash table indices to stay constant
- across the dump. */
- for (ptrdiff_t i = 0; i < size; i++)
- if (!NILP (HASH_HASH (h, i)))
- {
- ASET (key_and_value, n++, HASH_KEY (h, i));
- ASET (key_and_value, n++, HASH_VALUE (h, i));
- }
-
- while (n < 2 * size)
+ DOHASH (h, k, v)
{
- ASET (key_and_value, n++, Qunbound);
- ASET (key_and_value, n++, Qnil);
+ key_and_value[n++] = k;
+ key_and_value[n++] = v;
}
return key_and_value;
}
-static dump_off
+static void
dump_hash_table_list (struct dump_context *ctx)
{
if (!NILP (ctx->hash_tables))
- return dump_object (ctx, CALLN (Fapply, Qvector, ctx->hash_tables));
- else
- return 0;
+ dump_object (ctx, CALLN (Fvconcat, ctx->hash_tables));
}
+static hash_table_std_test_t
+hash_table_std_test (const struct hash_table_test *t)
+{
+ if (BASE_EQ (t->name, Qeq))
+ return Test_eq;
+ if (BASE_EQ (t->name, Qeql))
+ return Test_eql;
+ if (BASE_EQ (t->name, Qequal))
+ return Test_equal;
+ error ("cannot dump hash tables with user-defined tests"); /* Bug#36769 */
+}
+
+/* Compact contents and discard inessential information from a hash table,
+ preparing it for dumping.
+ See `hash_table_thaw' for the code that restores the object to a usable
+ state. */
static void
hash_table_freeze (struct Lisp_Hash_Table *h)
{
- ptrdiff_t npairs = ASIZE (h->key_and_value) / 2;
h->key_and_value = hash_table_contents (h);
- h->next = h->hash = make_fixnum (npairs);
- h->index = make_fixnum (ASIZE (h->index));
- h->next_free = (npairs == h->count ? -1 : h->count);
+ h->next = NULL;
+ h->hash = NULL;
+ h->index = NULL;
+ h->table_size = 0;
+ h->index_bits = 0;
+ h->frozen_test = hash_table_std_test (h->test);
+ h->test = NULL;
}
-static void
-hash_table_thaw (Lisp_Object hash)
+static dump_off
+dump_hash_table_contents (struct dump_context *ctx, struct Lisp_Hash_Table *h)
{
- struct Lisp_Hash_Table *h = XHASH_TABLE (hash);
- h->hash = make_nil_vector (XFIXNUM (h->hash));
- h->next = Fmake_vector (h->next, make_fixnum (-1));
- h->index = Fmake_vector (h->index, make_fixnum (-1));
+ dump_align_output (ctx, DUMP_ALIGNMENT);
+ dump_off start_offset = ctx->offset;
+ ptrdiff_t n = 2 * h->count;
+
+ struct dump_flags old_flags = ctx->flags;
+ ctx->flags.pack_objects = true;
+
+ for (ptrdiff_t i = 0; i < n; i++)
+ {
+ Lisp_Object out;
+ const Lisp_Object *slot = &h->key_and_value[i];
+ dump_object_start (ctx, &out, sizeof out);
+ dump_field_lv (ctx, &out, slot, slot, WEIGHT_STRONG);
+ dump_object_finish (ctx, &out, sizeof out);
+ }
- hash_table_rehash (hash);
+ ctx->flags = old_flags;
+ return start_offset;
}
static dump_off
-dump_hash_table (struct dump_context *ctx,
- Lisp_Object object,
- dump_off offset)
+dump_hash_table (struct dump_context *ctx, Lisp_Object object)
{
-#if CHECK_STRUCTS && !defined HASH_Lisp_Hash_Table_6D63EDB618
+#if CHECK_STRUCTS && !defined HASH_Lisp_Hash_Table_0360833954
# error "Lisp_Hash_Table changed. See CHECK_STRUCTS comment in config.h."
#endif
const struct Lisp_Hash_Table *hash_in = XHASH_TABLE (object);
@@ -2725,30 +2731,72 @@ dump_hash_table (struct dump_context *ctx,
START_DUMP_PVEC (ctx, &hash->header, struct Lisp_Hash_Table, out);
dump_pseudovector_lisp_fields (ctx, &out->header, &hash->header);
- /* TODO: dump the hash bucket vectors synchronously here to keep
- them as close to the hash table as possible. */
DUMP_FIELD_COPY (out, hash, count);
- DUMP_FIELD_COPY (out, hash, next_free);
+ DUMP_FIELD_COPY (out, hash, weakness);
DUMP_FIELD_COPY (out, hash, purecopy);
DUMP_FIELD_COPY (out, hash, mutable);
- DUMP_FIELD_COPY (out, hash, rehash_threshold);
- DUMP_FIELD_COPY (out, hash, rehash_size);
- dump_field_lv (ctx, out, hash, &hash->key_and_value, WEIGHT_STRONG);
- dump_field_lv (ctx, out, hash, &hash->test.name, WEIGHT_STRONG);
- dump_field_lv (ctx, out, hash, &hash->test.user_hash_function,
- WEIGHT_STRONG);
- dump_field_lv (ctx, out, hash, &hash->test.user_cmp_function,
- WEIGHT_STRONG);
- dump_field_emacs_ptr (ctx, out, hash, &hash->test.cmpfn);
- dump_field_emacs_ptr (ctx, out, hash, &hash->test.hashfn);
+ DUMP_FIELD_COPY (out, hash, frozen_test);
+ if (hash->key_and_value)
+ dump_field_fixup_later (ctx, out, hash, &hash->key_and_value);
eassert (hash->next_weak == NULL);
- return finish_dump_pvec (ctx, &out->header);
+ dump_off offset = finish_dump_pvec (ctx, &out->header);
+ if (hash->key_and_value)
+ dump_remember_fixup_ptr_raw
+ (ctx,
+ offset + dump_offsetof (struct Lisp_Hash_Table, key_and_value),
+ dump_hash_table_contents (ctx, hash));
+ return offset;
+}
+
+static dump_off
+dump_obarray_buckets (struct dump_context *ctx, const struct Lisp_Obarray *o)
+{
+ dump_align_output (ctx, DUMP_ALIGNMENT);
+ dump_off start_offset = ctx->offset;
+ ptrdiff_t n = obarray_size (o);
+
+ struct dump_flags old_flags = ctx->flags;
+ ctx->flags.pack_objects = true;
+
+ for (ptrdiff_t i = 0; i < n; i++)
+ {
+ Lisp_Object out;
+ const Lisp_Object *slot = &o->buckets[i];
+ dump_object_start (ctx, &out, sizeof out);
+ dump_field_lv (ctx, &out, slot, slot, WEIGHT_STRONG);
+ dump_object_finish (ctx, &out, sizeof out);
+ }
+
+ ctx->flags = old_flags;
+ return start_offset;
+}
+
+static dump_off
+dump_obarray (struct dump_context *ctx, Lisp_Object object)
+{
+#if CHECK_STRUCTS && !defined HASH_Lisp_Obarray_D2757E61AD
+# error "Lisp_Obarray changed. See CHECK_STRUCTS comment in config.h."
+#endif
+ const struct Lisp_Obarray *in_oa = XOBARRAY (object);
+ struct Lisp_Obarray munged_oa = *in_oa;
+ struct Lisp_Obarray *oa = &munged_oa;
+ START_DUMP_PVEC (ctx, &oa->header, struct Lisp_Obarray, out);
+ dump_pseudovector_lisp_fields (ctx, &out->header, &oa->header);
+ DUMP_FIELD_COPY (out, oa, count);
+ DUMP_FIELD_COPY (out, oa, size_bits);
+ dump_field_fixup_later (ctx, out, oa, &oa->buckets);
+ dump_off offset = finish_dump_pvec (ctx, &out->header);
+ dump_remember_fixup_ptr_raw
+ (ctx,
+ offset + dump_offsetof (struct Lisp_Obarray, buckets),
+ dump_obarray_buckets (ctx, oa));
+ return offset;
}
static dump_off
dump_buffer (struct dump_context *ctx, const struct buffer *in_buffer)
{
-#if CHECK_STRUCTS && !defined HASH_buffer_9E96D7C4B4
+#if CHECK_STRUCTS && !defined HASH_buffer_B02F648B82
# error "buffer changed. See CHECK_STRUCTS comment in config.h."
#endif
struct buffer munged_buffer = *in_buffer;
@@ -2760,6 +2808,7 @@ dump_buffer (struct dump_context *ctx, const struct buffer *in_buffer)
else
eassert (buffer->window_count == -1);
buffer->local_minor_modes_ = Qnil;
+ buffer->last_name_ = Qnil;
buffer->last_selected_window_ = Qnil;
buffer->display_count_ = make_fixnum (0);
buffer->clip_changed = 0;
@@ -2862,9 +2911,11 @@ dump_buffer (struct dump_context *ctx, const struct buffer *in_buffer)
DUMP_FIELD_COPY (out, buffer, inhibit_buffer_hooks);
DUMP_FIELD_COPY (out, buffer, long_line_optimizations_p);
- if (buffer->overlays && buffer->overlays->root != NULL)
- /* We haven't implemented the code to dump overlays. */
- emacs_abort ();
+ if (!itree_empty_p (buffer->overlays))
+ {
+ /* We haven't implemented the code to dump overlays. */
+ error ("dumping overlays is not yet implemented");
+ }
else
out->overlays = NULL;
@@ -2907,17 +2958,17 @@ dump_subr (struct dump_context *ctx, const struct Lisp_Subr *subr)
dump_object_start (ctx, &out, sizeof (out));
DUMP_FIELD_COPY (&out, subr, header.size);
#ifdef HAVE_NATIVE_COMP
- bool native_comp = !NILP (subr->native_comp_u);
+ bool non_primitive = !NILP (subr->native_comp_u);
#else
- bool native_comp = false;
+ bool non_primitive = false;
#endif
- if (native_comp)
+ if (non_primitive)
out.function.a0 = NULL;
else
dump_field_emacs_ptr (ctx, &out, subr, &subr->function.a0);
DUMP_FIELD_COPY (&out, subr, min_args);
DUMP_FIELD_COPY (&out, subr, max_args);
- if (native_comp)
+ if (non_primitive)
{
dump_field_fixup_later (ctx, &out, subr, &subr->symbol_name);
dump_remember_cold_op (ctx,
@@ -2942,7 +2993,7 @@ dump_subr (struct dump_context *ctx, const struct Lisp_Subr *subr)
dump_field_lv (ctx, &out, subr, &subr->type, WEIGHT_NORMAL);
#endif
dump_off subr_off = dump_object_finish (ctx, &out, sizeof (out));
- if (native_comp && ctx->flags.dump_object_contents)
+ if (non_primitive && ctx->flags.dump_object_contents)
/* We'll do the final addr relocation during VERY_LATE_RELOCS time
after the compilation units has been loaded. */
dump_push (&ctx->dump_relocs[VERY_LATE_RELOCS],
@@ -2957,7 +3008,7 @@ dump_native_comp_unit (struct dump_context *ctx,
struct Lisp_Native_Comp_Unit *comp_u)
{
if (!CONSP (comp_u->file))
- error ("Trying to dump non fixed-up eln file");
+ error ("trying to dump non fixed-up eln file");
/* Have function documentation always lazy loaded to optimize load-time. */
comp_u->data_fdoc_v = Qnil;
@@ -2999,11 +3050,12 @@ dump_vectorlike (struct dump_context *ctx,
Lisp_Object lv,
dump_off offset)
{
-#if CHECK_STRUCTS && !defined HASH_pvec_type_5F2059C47E
+#if CHECK_STRUCTS && !defined HASH_pvec_type_2D583AC566
# error "pvec_type changed. See CHECK_STRUCTS comment in config.h."
#endif
const struct Lisp_Vector *v = XVECTOR (lv);
- switch (PSEUDOVECTOR_TYPE (v))
+ enum pvec_type ptype = PSEUDOVECTOR_TYPE (v);
+ switch (ptype)
{
case PVEC_FONT:
/* There are three kinds of font objects that all use PVEC_FONT,
@@ -3020,76 +3072,62 @@ dump_vectorlike (struct dump_context *ctx,
case PVEC_CHAR_TABLE:
case PVEC_SUB_CHAR_TABLE:
case PVEC_RECORD:
- offset = dump_vectorlike_generic (ctx, &v->header);
- break;
+ return dump_vectorlike_generic (ctx, &v->header);
case PVEC_BOOL_VECTOR:
- offset = dump_bool_vector(ctx, v);
- break;
+ return dump_bool_vector(ctx, v);
case PVEC_HASH_TABLE:
- offset = dump_hash_table (ctx, lv, offset);
- break;
+ return dump_hash_table (ctx, lv);
+ case PVEC_OBARRAY:
+ return dump_obarray (ctx, lv);
case PVEC_BUFFER:
- offset = dump_buffer (ctx, XBUFFER (lv));
- break;
+ return dump_buffer (ctx, XBUFFER (lv));
case PVEC_SUBR:
- offset = dump_subr (ctx, XSUBR (lv));
- break;
+ return dump_subr (ctx, XSUBR (lv));
case PVEC_FRAME:
case PVEC_WINDOW:
case PVEC_PROCESS:
case PVEC_TERMINAL:
- offset = dump_nilled_pseudovec (ctx, &v->header);
- break;
+ return dump_nilled_pseudovec (ctx, &v->header);
case PVEC_MARKER:
- offset = dump_marker (ctx, XMARKER (lv));
- break;
+ return dump_marker (ctx, XMARKER (lv));
case PVEC_OVERLAY:
- offset = dump_overlay (ctx, XOVERLAY (lv));
- break;
+ return dump_overlay (ctx, XOVERLAY (lv));
case PVEC_FINALIZER:
- offset = dump_finalizer (ctx, XFINALIZER (lv));
- break;
+ return dump_finalizer (ctx, XFINALIZER (lv));
case PVEC_BIGNUM:
- offset = dump_bignum (ctx, lv);
- break;
-#ifdef HAVE_NATIVE_COMP
+ return dump_bignum (ctx, lv);
case PVEC_NATIVE_COMP_UNIT:
- offset = dump_native_comp_unit (ctx, XNATIVE_COMP_UNIT (lv));
- break;
+#ifdef HAVE_NATIVE_COMP
+ return dump_native_comp_unit (ctx, XNATIVE_COMP_UNIT (lv));
#endif
- case PVEC_WINDOW_CONFIGURATION:
- error_unsupported_dump_object (ctx, lv, "window configuration");
- case PVEC_OTHER:
- error_unsupported_dump_object (ctx, lv, "other?!");
- case PVEC_XWIDGET:
- error_unsupported_dump_object (ctx, lv, "xwidget");
- case PVEC_XWIDGET_VIEW:
- error_unsupported_dump_object (ctx, lv, "xwidget view");
- case PVEC_MISC_PTR:
- case PVEC_USER_PTR:
- error_unsupported_dump_object (ctx, lv, "smuggled pointers");
+ break;
case PVEC_THREAD:
if (main_thread_p (v))
{
eassert (dump_object_emacs_ptr (lv));
return DUMP_OBJECT_IS_RUNTIME_MAGIC;
}
- error_unsupported_dump_object (ctx, lv, "thread");
+ break;
+ case PVEC_WINDOW_CONFIGURATION:
+ case PVEC_OTHER:
+ case PVEC_XWIDGET:
+ case PVEC_XWIDGET_VIEW:
+ case PVEC_MISC_PTR:
+ case PVEC_USER_PTR:
case PVEC_MUTEX:
- error_unsupported_dump_object (ctx, lv, "mutex");
case PVEC_CONDVAR:
- error_unsupported_dump_object (ctx, lv, "condvar");
case PVEC_SQLITE:
- error_unsupported_dump_object (ctx, lv, "sqlite");
case PVEC_MODULE_FUNCTION:
- error_unsupported_dump_object (ctx, lv, "module function");
case PVEC_SYMBOL_WITH_POS:
- error_unsupported_dump_object (ctx, lv, "symbol with pos");
- default:
- error_unsupported_dump_object(ctx, lv, "weird pseudovector");
+ case PVEC_FREE:
+ case PVEC_TS_PARSER:
+ case PVEC_TS_NODE:
+ case PVEC_TS_COMPILED_QUERY:
+ break;
}
-
- return offset;
+ char msg[60];
+ snprintf (msg, sizeof msg, "pseudovector type %d", (int) ptype);
+ error_unsupported_dump_object (ctx, lv, msg);
}
/* Add an object to the dump.
@@ -3219,37 +3257,42 @@ dump_object_for_offset (struct dump_context *ctx, Lisp_Object object)
static dump_off
dump_charset (struct dump_context *ctx, int cs_i)
{
-#if CHECK_STRUCTS && !defined (HASH_charset_317C49E291)
+#if CHECK_STRUCTS && !defined (HASH_charset_E31F4B5D96)
# error "charset changed. See CHECK_STRUCTS comment in config.h."
#endif
- dump_align_output (ctx, alignof (struct charset));
+ /* We can't change the alignment here, because ctx->offset is what
+ will be used for the whole array. */
+ eassert (ctx->offset % alignof (struct charset) == 0);
const struct charset *cs = charset_table + cs_i;
struct charset out;
dump_object_start (ctx, &out, sizeof (out));
- DUMP_FIELD_COPY (&out, cs, id);
- DUMP_FIELD_COPY (&out, cs, hash_index);
- DUMP_FIELD_COPY (&out, cs, dimension);
- memcpy (out.code_space, &cs->code_space, sizeof (cs->code_space));
- if (cs_i < charset_table_used && cs->code_space_mask)
- dump_field_fixup_later (ctx, &out, cs, &cs->code_space_mask);
- DUMP_FIELD_COPY (&out, cs, code_linear_p);
- DUMP_FIELD_COPY (&out, cs, iso_chars_96);
- DUMP_FIELD_COPY (&out, cs, ascii_compatible_p);
- DUMP_FIELD_COPY (&out, cs, supplementary_p);
- DUMP_FIELD_COPY (&out, cs, compact_codes_p);
- DUMP_FIELD_COPY (&out, cs, unified_p);
- DUMP_FIELD_COPY (&out, cs, iso_final);
- DUMP_FIELD_COPY (&out, cs, iso_revision);
- DUMP_FIELD_COPY (&out, cs, emacs_mule_id);
- DUMP_FIELD_COPY (&out, cs, method);
- DUMP_FIELD_COPY (&out, cs, min_code);
- DUMP_FIELD_COPY (&out, cs, max_code);
- DUMP_FIELD_COPY (&out, cs, char_index_offset);
- DUMP_FIELD_COPY (&out, cs, min_char);
- DUMP_FIELD_COPY (&out, cs, max_char);
- DUMP_FIELD_COPY (&out, cs, invalid_code);
- memcpy (out.fast_map, &cs->fast_map, sizeof (cs->fast_map));
- DUMP_FIELD_COPY (&out, cs, code_offset);
+ if (cs_i < charset_table_used) /* Don't look at uninitialized data. */
+ {
+ DUMP_FIELD_COPY (&out, cs, id);
+ dump_field_lv (ctx, &out, cs, &cs->attributes, WEIGHT_NORMAL);
+ DUMP_FIELD_COPY (&out, cs, dimension);
+ memcpy (out.code_space, &cs->code_space, sizeof (cs->code_space));
+ if (cs->code_space_mask)
+ dump_field_fixup_later (ctx, &out, cs, &cs->code_space_mask);
+ DUMP_FIELD_COPY (&out, cs, code_linear_p);
+ DUMP_FIELD_COPY (&out, cs, iso_chars_96);
+ DUMP_FIELD_COPY (&out, cs, ascii_compatible_p);
+ DUMP_FIELD_COPY (&out, cs, supplementary_p);
+ DUMP_FIELD_COPY (&out, cs, compact_codes_p);
+ DUMP_FIELD_COPY (&out, cs, unified_p);
+ DUMP_FIELD_COPY (&out, cs, iso_final);
+ DUMP_FIELD_COPY (&out, cs, iso_revision);
+ DUMP_FIELD_COPY (&out, cs, emacs_mule_id);
+ DUMP_FIELD_COPY (&out, cs, method);
+ DUMP_FIELD_COPY (&out, cs, min_code);
+ DUMP_FIELD_COPY (&out, cs, max_code);
+ DUMP_FIELD_COPY (&out, cs, char_index_offset);
+ DUMP_FIELD_COPY (&out, cs, min_char);
+ DUMP_FIELD_COPY (&out, cs, max_char);
+ DUMP_FIELD_COPY (&out, cs, invalid_code);
+ memcpy (out.fast_map, &cs->fast_map, sizeof (cs->fast_map));
+ DUMP_FIELD_COPY (&out, cs, code_offset);
+ }
dump_off offset = dump_object_finish (ctx, &out, sizeof (out));
if (cs_i < charset_table_used && cs->code_space_mask)
dump_remember_cold_op (ctx, COLD_OP_CHARSET,
@@ -3263,14 +3306,17 @@ dump_charset_table (struct dump_context *ctx)
{
struct dump_flags old_flags = ctx->flags;
ctx->flags.pack_objects = true;
- dump_align_output (ctx, DUMP_ALIGNMENT);
+ dump_align_output (ctx, alignof (struct charset));
dump_off offset = ctx->offset;
+ if (dump_set_referrer (ctx))
+ ctx->current_referrer = build_string ("charset_table");
/* We are dumping the entire table, not just the used slots, because
otherwise when we restore from the pdump file, the actual size of
the table will be smaller than charset_table_size, and we will
crash if/when a new charset is defined. */
for (int i = 0; i < charset_table_size; ++i)
dump_charset (ctx, i);
+ dump_clear_referrer (ctx);
dump_emacs_reloc_to_dump_ptr_raw (ctx, &charset_table, offset);
ctx->flags = old_flags;
return offset;
@@ -3322,7 +3368,7 @@ dump_sort_copied_objects (struct dump_context *ctx)
file and the copy into Emacs in-order, where prefetch will be
most effective. */
ctx->copied_queue =
- Fsort (Fnreverse (ctx->copied_queue),
+ CALLN (Fsort, Fnreverse (ctx->copied_queue),
Qdump_emacs_portable__sort_predicate_copied);
}
@@ -3889,7 +3935,7 @@ drain_reloc_list (struct dump_context *ctx,
{
struct dump_flags old_flags = ctx->flags;
ctx->flags.pack_objects = true;
- Lisp_Object relocs = Fsort (Fnreverse (*reloc_list),
+ Lisp_Object relocs = CALLN (Fsort, Fnreverse (*reloc_list),
Qdump_emacs_portable__sort_predicate);
*reloc_list = Qnil;
dump_align_output (ctx, max (alignof (struct dump_reloc),
@@ -4011,7 +4057,7 @@ static void
dump_do_fixups (struct dump_context *ctx)
{
dump_off saved_offset = ctx->offset;
- Lisp_Object fixups = Fsort (Fnreverse (ctx->fixups),
+ Lisp_Object fixups = CALLN (Fsort, Fnreverse (ctx->fixups),
Qdump_emacs_portable__sort_predicate);
Lisp_Object prev_fixup = Qnil;
ctx->fixups = Qnil;
@@ -4072,10 +4118,12 @@ types. */)
{
eassert (initialized);
+#ifndef HAVE_ANDROID
if (! noninteractive)
error ("Dumping Emacs currently works only in batch mode. "
"If you'd like it to work interactively, please consider "
"contributing a patch to Emacs.");
+#endif
if (will_dump_with_unexec_p ())
error ("This Emacs instance was started under the assumption "
@@ -4089,6 +4137,10 @@ types. */)
if (!NILP (XCDR (Fall_threads ())))
error ("No other Lisp threads can be running when this function is called");
+#ifdef HAVE_NATIVE_COMP
+ CALLN (Ffuncall, intern_c_string ("load--fixup-all-elns"));
+#endif
+
check_pure_size ();
/* Clear out any detritus in memory. */
@@ -4220,22 +4272,19 @@ types. */)
dump_drain_deferred_symbols (ctx);
dump_drain_normal_queue (ctx);
}
- while (!dump_queue_empty_p (&ctx->dump_queue)
- || !NILP (ctx->deferred_hash_tables)
- || !NILP (ctx->deferred_symbols));
+ while (!(dump_queue_empty_p (&ctx->dump_queue)
+ && NILP (ctx->deferred_hash_tables)
+ && NILP (ctx->deferred_symbols)));
ctx->header.hash_list = ctx->offset;
dump_hash_table_list (ctx);
- do
- {
- dump_drain_deferred_hash_tables (ctx);
- dump_drain_deferred_symbols (ctx);
- dump_drain_normal_queue (ctx);
- }
- while (!dump_queue_empty_p (&ctx->dump_queue)
- || !NILP (ctx->deferred_hash_tables)
- || !NILP (ctx->deferred_symbols));
+ /* dump_hash_table_list just adds a new vector to the dump but all
+ its content should already have been in the dump, so it doesn't
+ add anything to any queue. */
+ eassert (dump_queue_empty_p (&ctx->dump_queue)
+ && NILP (ctx->deferred_hash_tables)
+ && NILP (ctx->deferred_symbols));
dump_sort_copied_objects (ctx);
@@ -4745,7 +4794,9 @@ dump_discard_mem (void *mem, size_t size)
# ifdef HAVE_POSIX_MADVISE
/* Discard COWed pages. */
(void) posix_madvise (mem, size, POSIX_MADV_DONTNEED);
-# endif
+# elif defined HAVE_MADVISE
+ (void) madvise (mem, size, MADV_DONTNEED);
+#endif
/* Release the commit charge for the mapping. */
(void) mprotect (mem, size, PROT_NONE);
#endif
@@ -4997,6 +5048,7 @@ dump_mmap_contiguous (struct dump_memory_map *maps, int nr_maps)
}
typedef uint_fast32_t dump_bitset_word;
+#define DUMP_BITSET_WORD_WIDTH UINT_FAST32_WIDTH
struct dump_bitset
{
@@ -5007,9 +5059,9 @@ struct dump_bitset
static bool
dump_bitsets_init (struct dump_bitset bitset[2], size_t number_bits)
{
- int xword_size = sizeof (bitset[0].bits[0]);
- int bits_per_word = xword_size * CHAR_BIT;
- ptrdiff_t words_needed = divide_round_up (number_bits, bits_per_word);
+ int xword_size = sizeof (dump_bitset_word);
+ ptrdiff_t words_needed = divide_round_up (number_bits,
+ DUMP_BITSET_WORD_WIDTH);
dump_bitset_word *bits = calloc (words_needed, 2 * xword_size);
if (!bits)
return false;
@@ -5024,9 +5076,7 @@ static dump_bitset_word *
dump_bitset__bit_slot (const struct dump_bitset *bitset,
size_t bit_number)
{
- int xword_size = sizeof (bitset->bits[0]);
- int bits_per_word = xword_size * CHAR_BIT;
- ptrdiff_t word_number = bit_number / bits_per_word;
+ ptrdiff_t word_number = bit_number / DUMP_BITSET_WORD_WIDTH;
eassert (word_number < bitset->number_words);
return &bitset->bits[word_number];
}
@@ -5035,10 +5085,8 @@ static bool
dump_bitset_bit_set_p (const struct dump_bitset *bitset,
size_t bit_number)
{
- unsigned xword_size = sizeof (bitset->bits[0]);
- unsigned bits_per_word = xword_size * CHAR_BIT;
dump_bitset_word bit = 1;
- bit <<= bit_number % bits_per_word;
+ bit <<= bit_number % DUMP_BITSET_WORD_WIDTH;
return *dump_bitset__bit_slot (bitset, bit_number) & bit;
}
@@ -5047,11 +5095,9 @@ dump_bitset__set_bit_value (struct dump_bitset *bitset,
size_t bit_number,
bool bit_is_set)
{
- int xword_size = sizeof (bitset->bits[0]);
- int bits_per_word = xword_size * CHAR_BIT;
dump_bitset_word *slot = dump_bitset__bit_slot (bitset, bit_number);
dump_bitset_word bit = 1;
- bit <<= bit_number % bits_per_word;
+ bit <<= bit_number % DUMP_BITSET_WORD_WIDTH;
if (bit_is_set)
*slot = *slot | bit;
else
@@ -5352,11 +5398,11 @@ dump_do_dump_relocation (const uintptr_t dump_base,
dump_ptr (dump_base, reloc_offset);
comp_u->lambda_gc_guard_h = CALLN (Fmake_hash_table, QCtest, Qeq);
if (STRINGP (comp_u->file))
- error ("Trying to load incoherent dumped eln file %s",
+ error ("trying to load incoherent dumped eln file %s",
SSDATA (comp_u->file));
if (!CONSP (comp_u->file))
- error ("Incoherent compilation unit for dump was dumped");
+ error ("incoherent compilation unit for dump was dumped");
/* emacs_execdir is always unibyte, but the file names in
comp_u->file could be multibyte, so we need to encode
@@ -5595,10 +5641,7 @@ pdumper_load (const char *dump_filename, char *argv0)
struct dump_header header_buf = { 0 };
struct dump_header *header = &header_buf;
- struct dump_memory_map sections[NUMBER_DUMP_SECTIONS];
-
- /* Use memset instead of "= { 0 }" to work around GCC bug 105961. */
- memset (sections, 0, sizeof sections);
+ struct dump_memory_map sections[NUMBER_DUMP_SECTIONS] = { 0 };
const struct timespec start_time = current_timespec ();
char *dump_filename_copy;
@@ -5620,7 +5663,7 @@ pdumper_load (const char *dump_filename, char *argv0)
}
err = PDUMPER_LOAD_FILE_NOT_FOUND;
- if (fstat (dump_fd, &stat) < 0)
+ if (sys_fstat (dump_fd, &stat) < 0)
goto out;
err = PDUMPER_LOAD_BAD_FILE_TYPE;
@@ -5842,6 +5885,10 @@ void
syms_of_pdumper (void)
{
#ifdef HAVE_PDUMPER
+ unsigned char desired[sizeof fingerprint];
+ int i;
+ char hexbuf[2 * sizeof fingerprint];
+
defsubr (&Sdump_emacs_portable);
defsubr (&Sdump_emacs_portable__sort_predicate);
defsubr (&Sdump_emacs_portable__sort_predicate_copied);
@@ -5854,5 +5901,17 @@ syms_of_pdumper (void)
DEFSYM (Qdump_file_name, "dump-file-name");
DEFSYM (Qafter_pdump_load_hook, "after-pdump-load-hook");
defsubr (&Spdumper_stats);
+
+ for (i = 0; i < sizeof fingerprint; i++)
+ desired[i] = fingerprint[i];
+
+ hexbuf_digest (hexbuf, desired, sizeof desired);
+
+ DEFVAR_LISP ("pdumper-fingerprint", Vpdumper_fingerprint,
+ doc: /* The fingerprint of this Emacs binary.
+It is a string that is supposed to be unique to each build of
+Emacs. */);
+ Vpdumper_fingerprint = make_unibyte_string ((char *) hexbuf,
+ sizeof hexbuf);
#endif /* HAVE_PDUMPER */
}
diff --git a/src/pdumper.h b/src/pdumper.h
index 726805efdac..0d5e4c2d45f 100644
--- a/src/pdumper.h
+++ b/src/pdumper.h
@@ -128,7 +128,7 @@ pdumper_do_now_and_after_late_load (pdumper_hook hook)
if (dumped_with_pdumper_p ()) \
(variable) = (value); \
else \
- eassert (EQ ((variable), (value))); \
+ eassert (EQ (variable, value)); \
} while (0)
/* Actually load a dump. */
diff --git a/src/pgtkfns.c b/src/pgtkfns.c
index 5f806e18090..f43eed6ad23 100644
--- a/src/pgtkfns.c
+++ b/src/pgtkfns.c
@@ -398,13 +398,6 @@ pgtk_set_title (struct frame *f, Lisp_Object name, Lisp_Object old_name)
pgtk_set_name_internal (f, name);
}
-
-void
-pgtk_set_doc_edited (void)
-{
-}
-
-
static void
pgtk_set_menu_bar_lines (struct frame *f, Lisp_Object value, Lisp_Object oldval)
{
@@ -482,6 +475,11 @@ pgtk_change_tab_bar_height (struct frame *f, int height)
leading to the tab bar height being incorrectly set upon the next
call to x_set_font. (bug#59285) */
int lines = height / unit;
+
+ /* Even so, HEIGHT might be less than unit if the tab bar face is
+ not so tall as the frame's font height; which if true lines will
+ be set to 0 and the tab bar will thus vanish. */
+
if (lines == 0 && height != 0)
lines = 1;
@@ -3458,7 +3456,6 @@ frame_geometry (Lisp_Object frame, Lisp_Object attribute)
tab_bar_height = FRAME_TAB_BAR_HEIGHT (f);
tab_bar_width = (tab_bar_height
? native_width - 2 * internal_border_width : 0);
- /* inner_top += tab_bar_height; */
/* Construct list. */
if (EQ (attribute, Qouter_edges))
@@ -3471,10 +3468,12 @@ frame_geometry (Lisp_Object frame, Lisp_Object attribute)
else if (EQ (attribute, Qinner_edges))
return list4 (make_fixnum (native_left + internal_border_width),
make_fixnum (native_top
- + tool_bar_height
+ + tab_bar_height
+ + FRAME_TOOL_BAR_TOP_HEIGHT (f)
+ internal_border_width),
make_fixnum (native_right - internal_border_width),
- make_fixnum (native_bottom - internal_border_width));
+ make_fixnum (native_bottom - internal_border_width
+ - FRAME_TOOL_BAR_BOTTOM_HEIGHT (f)));
else
return
list (Fcons (Qouter_position,
@@ -3571,7 +3570,9 @@ menu bar or tool bar of FRAME. */)
? type : Qnative_edges));
}
-DEFUN ("pgtk-set-mouse-absolute-pixel-position", Fpgtk_set_mouse_absolute_pixel_position, Spgtk_set_mouse_absolute_pixel_position, 2, 2, 0,
+DEFUN ("pgtk-set-mouse-absolute-pixel-position",
+ Fpgtk_set_mouse_absolute_pixel_position,
+ Spgtk_set_mouse_absolute_pixel_position, 2, 2, 0,
doc: /* Move mouse pointer to absolute pixel position (X, Y).
The coordinates X and Y are interpreted in pixels relative to a position
\(0, 0) of the selected frame's display. */)
@@ -3590,7 +3591,9 @@ The coordinates X and Y are interpreted in pixels relative to a position
return Qnil;
}
-DEFUN ("pgtk-mouse-absolute-pixel-position", Fpgtk_mouse_absolute_pixel_position, Spgtk_mouse_absolute_pixel_position, 0, 0, 0,
+DEFUN ("pgtk-mouse-absolute-pixel-position",
+ Fpgtk_mouse_absolute_pixel_position,
+ Spgtk_mouse_absolute_pixel_position, 0, 0, 0,
doc: /* Return absolute position of mouse cursor in pixels.
The position is returned as a cons cell (X . Y) of the
coordinates of the mouse cursor position in pixels relative to a
@@ -3612,7 +3615,8 @@ position (0, 0) of the selected frame's terminal. */)
}
-DEFUN ("pgtk-page-setup-dialog", Fpgtk_page_setup_dialog, Spgtk_page_setup_dialog, 0, 0, 0,
+DEFUN ("pgtk-page-setup-dialog", Fpgtk_page_setup_dialog,
+ Spgtk_page_setup_dialog, 0, 0, 0,
doc: /* Pop up a page setup dialog.
The current page setup can be obtained using `x-get-page-setup'. */)
(void)
@@ -3624,7 +3628,8 @@ The current page setup can be obtained using `x-get-page-setup'. */)
return Qnil;
}
-DEFUN ("pgtk-get-page-setup", Fpgtk_get_page_setup, Spgtk_get_page_setup, 0, 0, 0,
+DEFUN ("pgtk-get-page-setup", Fpgtk_get_page_setup,
+ Spgtk_get_page_setup, 0, 0, 0,
doc: /* Return the value of the current page setup.
The return value is an alist containing the following keys:
diff --git a/src/pgtkterm.c b/src/pgtkterm.c
index 9f82b9d972a..1ec6bfcda4e 100644
--- a/src/pgtkterm.c
+++ b/src/pgtkterm.c
@@ -3150,11 +3150,15 @@ pgtk_scroll_run (struct window *w, struct run *run)
/* Icons. */
-/* Make the x-window of frame F use the gnu icon bitmap. */
-
static bool
pgtk_bitmap_icon (struct frame *f, Lisp_Object file)
{
+ /* This code has never worked anyway for the reason that Wayland
+ uses icons set within desktop files, and has been disabled
+ because leaving it intact would require image.c to retain a
+ reference to a GdkPixbuf (which are no longer used) within new
+ bitmaps. */
+#if 0
ptrdiff_t bitmap_id;
if (FRAME_GTK_WIDGET (f) == 0)
@@ -3210,12 +3214,8 @@ pgtk_bitmap_icon (struct frame *f, Lisp_Object file)
bitmap_id = FRAME_DISPLAY_INFO (f)->icon_bitmap_id;
}
- 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);
-
f->output_data.pgtk->icon_bitmap = bitmap_id;
-
+#endif /* 0 */
return false;
}
@@ -3471,9 +3471,7 @@ 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 *));
+ = xrealloc (fringe_bmp, max_fringe_bmp * sizeof (cairo_pattern_t *));
while (i < max_fringe_bmp)
fringe_bmp[i++] = 0;
}
@@ -3769,7 +3767,8 @@ pgtk_flash (struct frame *f)
cairo_rectangle (cr,
flash_left,
(height - flash_height
- - FRAME_INTERNAL_BORDER_WIDTH (f)),
+ - FRAME_INTERNAL_BORDER_WIDTH (f)
+ - FRAME_BOTTOM_MARGIN_HEIGHT (f)),
width, flash_height);
cairo_fill (cr);
}
@@ -4950,36 +4949,38 @@ pgtk_clear_under_internal_border (struct frame *f)
int width = FRAME_PIXEL_WIDTH (f);
int height = FRAME_PIXEL_HEIGHT (f);
int margin = FRAME_TOP_MARGIN_HEIGHT (f);
- int face_id =
- (FRAME_PARENT_FRAME (f)
- ? (!NILP (Vface_remapping_alist)
- ? lookup_basic_face (NULL, f, CHILD_FRAME_BORDER_FACE_ID)
- : CHILD_FRAME_BORDER_FACE_ID)
- : (!NILP (Vface_remapping_alist)
- ? lookup_basic_face (NULL, f, INTERNAL_BORDER_FACE_ID)
- : INTERNAL_BORDER_FACE_ID));
+ int bottom_margin = FRAME_BOTTOM_MARGIN_HEIGHT (f);
+ int face_id = (FRAME_PARENT_FRAME (f)
+ ? (!NILP (Vface_remapping_alist)
+ ? lookup_basic_face (NULL, f,
+ CHILD_FRAME_BORDER_FACE_ID)
+ : CHILD_FRAME_BORDER_FACE_ID)
+ : (!NILP (Vface_remapping_alist)
+ ? lookup_basic_face (NULL, f,
+ INTERNAL_BORDER_FACE_ID)
+ : INTERNAL_BORDER_FACE_ID));
struct face *face = FACE_FROM_ID_OR_NULL (f, face_id);
block_input ();
if (face)
{
-#define x_fill_rectangle(f, gc, x, y, w, h) \
- fill_background_by_face (f, face, x, y, w, h)
- x_fill_rectangle (f, gc, 0, margin, width, border);
- x_fill_rectangle (f, gc, 0, 0, border, height);
- x_fill_rectangle (f, gc, width - border, 0, border, height);
- x_fill_rectangle (f, gc, 0, height - border, width, border);
-#undef x_fill_rectangle
+ fill_background_by_face (f, face, 0, margin, width, border);
+ fill_background_by_face (f, face, 0, 0, border, height);
+ fill_background_by_face (f, face, width - border, 0, border,
+ height);
+ fill_background_by_face (f, face, 0, (height
+ - bottom_margin
+ - border),
+ width, border);
}
else
{
-#define x_clear_area(f, x, y, w, h) pgtk_clear_area (f, x, y, w, h)
- x_clear_area (f, 0, 0, border, height);
- x_clear_area (f, 0, margin, width, border);
- x_clear_area (f, width - border, 0, border, height);
- x_clear_area (f, 0, height - border, width, border);
-#undef x_clear_area
+ pgtk_clear_area (f, 0, 0, border, height);
+ pgtk_clear_area (f, 0, margin, width, border);
+ pgtk_clear_area (f, width - border, 0, border, height);
+ pgtk_clear_area (f, 0, height - bottom_margin - border,
+ width, border);
}
unblock_input ();
@@ -5824,8 +5825,8 @@ note_mouse_movement (struct frame *frame,
/* Has the mouse moved off the glyph it was on at the last sighting? */
r = &dpyinfo->last_mouse_glyph;
if (frame != dpyinfo->last_mouse_glyph_frame
- || event->x < r->x || event->x >= r->x + r->width
- || event->y < r->y || event->y >= r->y + r->height)
+ || event->x < r->x || event->x >= r->x + (int) r->width
+ || event->y < r->y || event->y >= r->y + (int) r->height)
{
frame->mouse_moved = true;
dpyinfo->last_mouse_scroll_bar = NULL;
@@ -5891,7 +5892,7 @@ motion_notify_event (GtkWidget *widget, GdkEvent *event,
{
static Lisp_Object last_mouse_window;
Lisp_Object window = window_from_coordinates
- (f, event->motion.x, event->motion.y, 0, false, false);
+ (f, event->motion.x, event->motion.y, 0, false, false, false);
/* A window will be autoselected only when it is not
selected now and the last mouse movement event was
@@ -6044,7 +6045,7 @@ button_event (GtkWidget *widget, GdkEvent *event,
int x = event->button.x;
int y = event->button.y;
- window = window_from_coordinates (f, x, y, 0, true, true);
+ window = window_from_coordinates (f, x, y, 0, true, true, true);
tab_bar_p = EQ (window, f->tab_bar_window);
if (tab_bar_p)
@@ -6685,12 +6686,12 @@ pgtk_display_x_warning (GdkDisplay *display)
gtk_window_set_title (window, "Warning");
gtk_window_set_screen (window, screen);
- label = gtk_label_new ("You are trying to run Emacs configured with"
- " the \"pure-GTK\" interface under the X Window"
- " System. That configuration is unsupported and"
- " will lead to sporadic crashes during transfer of"
- " large selection data. It will also lead to"
- " various problems with keyboard input.");
+ label = gtk_label_new ("You are trying to run Emacs configured with\n"
+ " the \"pure-GTK\" interface under the X Window\n"
+ " System. That configuration is unsupported and\n"
+ " will lead to sporadic crashes during transfer of\n"
+ " large selection data. It will also lead to\n"
+ " various problems with keyboard input.\n");
gtk_label_set_line_wrap (GTK_LABEL (label), TRUE);
gtk_container_add (GTK_CONTAINER (content_area), label);
gtk_widget_show (label);
@@ -6845,8 +6846,7 @@ pgtk_term_init (Lisp_Object display_name, char *resource_name)
Lisp_Object system_name = Fsystem_name ();
ptrdiff_t nbytes;
- if (INT_ADD_WRAPV (SBYTES (Vinvocation_name), SBYTES (system_name) + 2,
- &nbytes))
+ if (ckd_add (&nbytes, SBYTES (Vinvocation_name), SBYTES (system_name) + 2))
memory_full (SIZE_MAX);
dpyinfo->x_id = ++x_display_id;
dpyinfo->x_id_name = xmalloc (nbytes);
@@ -7178,8 +7178,7 @@ If set to a non-float value, there will be no wait at all. */);
DEFVAR_LISP ("pgtk-keysym-table", Vpgtk_keysym_table,
doc: /* Hash table of character codes indexed by X keysym codes. */);
- Vpgtk_keysym_table = make_hash_table (hashtest_eql, 900, DEFAULT_REHASH_SIZE,
- DEFAULT_REHASH_THRESHOLD, Qnil, false);
+ Vpgtk_keysym_table = make_hash_table (&hashtest_eql, 900, Weak_None, false);
window_being_scrolled = Qnil;
staticpro (&window_being_scrolled);
diff --git a/src/pgtkterm.h b/src/pgtkterm.h
index e03bd1e23f7..8072d963691 100644
--- a/src/pgtkterm.h
+++ b/src/pgtkterm.h
@@ -42,7 +42,6 @@ along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. */
struct pgtk_bitmap_record
{
- void *img;
char *file;
int refcount;
int height, width, depth;
@@ -463,7 +462,7 @@ enum
#define FRAME_X_WINDOW(f) FRAME_GTK_OUTER_WIDGET (f)
#define FRAME_NATIVE_WINDOW(f) GTK_WINDOW (FRAME_X_WINDOW (f))
#define FRAME_GDK_WINDOW(f) \
- (gtk_widget_get_window (FRAME_GTK_WIDGET (f)))
+ gtk_widget_get_window (FRAME_GTK_WIDGET (f))
#define FRAME_X_DISPLAY(f) (FRAME_DISPLAY_INFO (f)->gdpy)
@@ -553,7 +552,6 @@ extern void pgtk_clear_frame (struct frame *);
extern char *pgtk_xlfd_to_fontname (const char *);
/* Implemented in pgtkfns.c. */
-extern void pgtk_set_doc_edited (void);
extern const char *pgtk_get_defaults_value (const char *);
extern const char *pgtk_get_string_resource (XrmDatabase, const char *, const char *);
extern void pgtk_implicitly_set_name (struct frame *, Lisp_Object, Lisp_Object);
diff --git a/src/print.c b/src/print.c
index d52d98ad371..76c577ec800 100644
--- a/src/print.c
+++ b/src/print.c
@@ -87,7 +87,7 @@ static struct print_buffer print_buffer;
print_number_index holds the largest N already used.
N has to be strictly larger than 0 since we need to distinguish -N. */
static ptrdiff_t print_number_index;
-static void print_interval (INTERVAL interval, Lisp_Object printcharfun);
+static void print_interval (INTERVAL interval, void *pprintcharfun);
/* GDB resets this to zero on W32 to disable OutputDebugString calls. */
bool print_output_debug_flag EXTERNALLY_VISIBLE = 1;
@@ -1094,7 +1094,7 @@ print_error_message (Lisp_Object data, Lisp_Object stream, const char *context,
/* `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);
+ Lisp_Object subs = safe_calln (Qsubstitute_command_keys, errmsg);
if (!NILP (subs))
errmsg = subs;
}
@@ -1285,15 +1285,9 @@ print (Lisp_Object obj, Lisp_Object printcharfun, bool escapeflag)
{ /* Remove unnecessary objects, which appear only once in OBJ;
that is, whose status is Qt. */
struct Lisp_Hash_Table *h = XHASH_TABLE (Vprint_number_table);
- ptrdiff_t i;
-
- for (i = 0; i < HASH_TABLE_SIZE (h); ++i)
- {
- Lisp_Object key = HASH_KEY (h, i);
- if (!BASE_EQ (key, Qunbound)
- && EQ (HASH_VALUE (h, i), Qt))
- Fremhash (key, Vprint_number_table);
- }
+ DOHASH (h, k, v)
+ if (EQ (v, Qt))
+ Fremhash (k, Vprint_number_table);
}
}
@@ -1397,6 +1391,9 @@ static void
print_preprocess (Lisp_Object obj)
{
eassert (!NILP (Vprint_circle));
+ /* The ppstack may contain HASH_UNUSED_ENTRY_KEY which is an invalid
+ Lisp value. Make sure that our filter stops us from traversing it. */
+ eassert (!PRINT_CIRCLE_CANDIDATE_P (HASH_UNUSED_ENTRY_KEY));
ptrdiff_t base_sp = ppstack.sp;
for (;;)
@@ -1415,7 +1412,7 @@ print_preprocess (Lisp_Object obj)
&& SYMBOLP (obj)
&& !SYMBOL_INTERNED_P (obj)))
{ /* OBJ appears more than once. Let's remember that. */
- if (!FIXNUMP (num))
+ if (SYMBOLP (num)) /* In practice, nil or t. */
{
print_number_index++;
/* Negative number indicates it hasn't been printed yet. */
@@ -1455,8 +1452,10 @@ print_preprocess (Lisp_Object obj)
if (HASH_TABLE_P (obj))
{
struct Lisp_Hash_Table *h = XHASH_TABLE (obj);
- obj = h->key_and_value;
- continue;
+ /* The values pushed here may include
+ HASH_UNUSED_ENTRY_KEY; see top of this function. */
+ pp_stack_push_values (h->key_and_value,
+ 2 * h->table_size);
}
break;
}
@@ -1493,8 +1492,6 @@ print_preprocess_string (INTERVAL interval, void *arg)
print_preprocess (interval->plist);
}
-static void print_check_string_charset_prop (INTERVAL interval, Lisp_Object string);
-
#define PRINT_STRING_NON_CHARSET_FOUND 1
#define PRINT_STRING_UNSAFE_CHARSET_FOUND 2
@@ -1502,7 +1499,7 @@ static void print_check_string_charset_prop (INTERVAL interval, Lisp_Object stri
static int print_check_string_result;
static void
-print_check_string_charset_prop (INTERVAL interval, Lisp_Object string)
+print_check_string_charset_prop (INTERVAL interval, void *pstring)
{
Lisp_Object val;
@@ -1526,6 +1523,7 @@ print_check_string_charset_prop (INTERVAL interval, Lisp_Object string)
if (! (print_check_string_result & PRINT_STRING_UNSAFE_CHARSET_FOUND))
{
ptrdiff_t charpos = interval->position;
+ Lisp_Object string = *(Lisp_Object *)pstring;
ptrdiff_t bytepos = string_char_to_byte (string, charpos);
Lisp_Object charset = XCAR (XCDR (val));
@@ -1550,7 +1548,7 @@ print_prune_string_charset (Lisp_Object string)
{
print_check_string_result = 0;
traverse_intervals (string_intervals (string), 0,
- print_check_string_charset_prop, string);
+ print_check_string_charset_prop, &string);
if (NILP (Vprint_charset_text_property)
|| ! (print_check_string_result & PRINT_STRING_UNSAFE_CHARSET_FOUND))
{
@@ -1599,76 +1597,69 @@ print_pointer (Lisp_Object printcharfun, char *buf, const char *prefix,
}
#endif
-static bool
-print_vectorlike (Lisp_Object obj, Lisp_Object printcharfun, bool escapeflag,
- char *buf)
+static void
+print_bignum (Lisp_Object obj, Lisp_Object printcharfun)
{
- /* First do all the vectorlike types that have a readable syntax. */
- switch (PSEUDOVECTOR_TYPE (XVECTOR (obj)))
- {
- case PVEC_BIGNUM:
- {
- ptrdiff_t size = bignum_bufsize (obj, 10);
- USE_SAFE_ALLOCA;
- char *str = SAFE_ALLOCA (size);
- ptrdiff_t len = bignum_to_c_string (str, size, obj, 10);
- strout (str, len, len, printcharfun);
- SAFE_FREE ();
- }
- return true;
-
- case PVEC_BOOL_VECTOR:
- {
- EMACS_INT size = bool_vector_size (obj);
- ptrdiff_t size_in_bytes = bool_vector_bytes (size);
- ptrdiff_t real_size_in_bytes = size_in_bytes;
- unsigned char *data = bool_vector_uchar_data (obj);
-
- int len = sprintf (buf, "#&%"pI"d\"", size);
- strout (buf, len, len, printcharfun);
+ ptrdiff_t size = bignum_bufsize (obj, 10);
+ USE_SAFE_ALLOCA;
+ char *str = SAFE_ALLOCA (size);
+ ptrdiff_t len = bignum_to_c_string (str, size, obj, 10);
+ strout (str, len, len, printcharfun);
+ SAFE_FREE ();
+}
- /* Don't print more bytes than the specified maximum.
- Negative values of print-length are invalid. Treat them
- like a print-length of nil. */
- if (FIXNATP (Vprint_length)
- && XFIXNAT (Vprint_length) < size_in_bytes)
- size_in_bytes = XFIXNAT (Vprint_length);
+static void
+print_bool_vector (Lisp_Object obj, Lisp_Object printcharfun)
+{
+ EMACS_INT size = bool_vector_size (obj);
+ ptrdiff_t size_in_bytes = bool_vector_bytes (size);
+ ptrdiff_t real_size_in_bytes = size_in_bytes;
+ unsigned char *data = bool_vector_uchar_data (obj);
- for (ptrdiff_t i = 0; i < size_in_bytes; i++)
- {
- maybe_quit ();
- unsigned char c = data[i];
- if (c == '\n' && print_escape_newlines)
- print_c_string ("\\n", printcharfun);
- else if (c == '\f' && print_escape_newlines)
- print_c_string ("\\f", printcharfun);
- else if (c > '\177'
- || (print_escape_control_characters && c_iscntrl (c)))
- {
- /* Use octal escapes to avoid encoding issues. */
- octalout (c, data, i + 1, size_in_bytes, printcharfun);
- }
- else
- {
- if (c == '\"' || c == '\\')
- printchar ('\\', printcharfun);
- printchar (c, printcharfun);
- }
- }
+ char buf[sizeof "#&\"" + INT_STRLEN_BOUND (ptrdiff_t)];
+ int len = sprintf (buf, "#&%"pI"d\"", size);
+ strout (buf, len, len, printcharfun);
- if (size_in_bytes < real_size_in_bytes)
- print_c_string (" ...", printcharfun);
- printchar ('\"', printcharfun);
- }
- return true;
+ /* Don't print more bytes than the specified maximum.
+ Negative values of print-length are invalid. Treat them
+ like a print-length of nil. */
+ if (FIXNATP (Vprint_length)
+ && XFIXNAT (Vprint_length) < size_in_bytes)
+ size_in_bytes = XFIXNAT (Vprint_length);
- default:
- break;
+ for (ptrdiff_t i = 0; i < size_in_bytes; i++)
+ {
+ maybe_quit ();
+ unsigned char c = data[i];
+ if (c == '\n' && print_escape_newlines)
+ print_c_string ("\\n", printcharfun);
+ else if (c == '\f' && print_escape_newlines)
+ print_c_string ("\\f", printcharfun);
+ else if (c > '\177'
+ || (print_escape_control_characters && c_iscntrl (c)))
+ {
+ /* Use octal escapes to avoid encoding issues. */
+ octalout (c, data, i + 1, size_in_bytes, printcharfun);
+ }
+ else
+ {
+ if (c == '\"' || c == '\\')
+ printchar ('\\', printcharfun);
+ printchar (c, printcharfun);
+ }
}
- /* Then do all the pseudovector types that don't have a readable
- syntax. First check whether this is handled by
- `print-unreadable-function'. */
+ if (size_in_bytes < real_size_in_bytes)
+ print_c_string (" ...", printcharfun);
+ printchar ('\"', printcharfun);
+}
+
+/* Print a pseudovector that has no readable syntax. */
+static void
+print_vectorlike_unreadable (Lisp_Object obj, Lisp_Object printcharfun,
+ bool escapeflag, char *buf)
+{
+ /* First check whether this is handled by `print-unreadable-function'. */
if (!NILP (Vprint_unreadable_function)
&& FUNCTIONP (Vprint_unreadable_function))
{
@@ -1697,7 +1688,7 @@ print_vectorlike (Lisp_Object obj, Lisp_Object printcharfun, bool escapeflag,
if (STRINGP (result))
print_string (result, printcharfun);
/* It's handled, so stop processing here. */
- return true;
+ return;
}
}
@@ -1718,7 +1709,7 @@ print_vectorlike (Lisp_Object obj, Lisp_Object printcharfun, bool escapeflag,
print_string (BVAR (XMARKER (obj)->buffer, name), printcharfun);
}
printchar ('>', printcharfun);
- break;
+ return;
case PVEC_SYMBOL_WITH_POS:
{
@@ -1742,7 +1733,7 @@ print_vectorlike (Lisp_Object obj, Lisp_Object printcharfun, bool escapeflag,
printchar ('>', printcharfun);
}
}
- break;
+ return;
case PVEC_OVERLAY:
print_c_string ("#<overlay ", printcharfun);
@@ -1758,7 +1749,7 @@ print_vectorlike (Lisp_Object obj, Lisp_Object printcharfun, bool escapeflag,
printcharfun);
}
printchar ('>', printcharfun);
- break;
+ return;
case PVEC_USER_PTR:
{
@@ -1769,14 +1760,14 @@ print_vectorlike (Lisp_Object obj, Lisp_Object printcharfun, bool escapeflag,
strout (buf, i, i, printcharfun);
printchar ('>', printcharfun);
}
- break;
+ return;
case PVEC_FINALIZER:
print_c_string ("#<finalizer", printcharfun);
if (NILP (XFINALIZER (obj)->function))
print_c_string (" used", printcharfun);
printchar ('>', printcharfun);
- break;
+ return;
case PVEC_MISC_PTR:
{
@@ -1785,7 +1776,7 @@ print_vectorlike (Lisp_Object obj, Lisp_Object printcharfun, bool escapeflag,
int i = sprintf (buf, "#<ptr %p>", xmint_pointer (obj));
strout (buf, i, i, printcharfun);
}
- break;
+ return;
case PVEC_PROCESS:
if (escapeflag)
@@ -1796,13 +1787,13 @@ print_vectorlike (Lisp_Object obj, Lisp_Object printcharfun, bool escapeflag,
}
else
print_string (XPROCESS (obj)->name, printcharfun);
- break;
+ return;
case PVEC_SUBR:
print_c_string ("#<subr ", printcharfun);
print_c_string (XSUBR (obj)->symbol_name, printcharfun);
printchar ('>', printcharfun);
- break;
+ return;
case PVEC_XWIDGET:
#ifdef HAVE_XWIDGETS
@@ -1822,15 +1813,15 @@ print_vectorlike (Lisp_Object obj, Lisp_Object printcharfun, bool escapeflag,
#endif
strout (buf, len, len, printcharfun);
}
- break;
+ return;
}
-#else
- emacs_abort ();
#endif
+ break;
+
case PVEC_XWIDGET_VIEW:
print_c_string ("#<xwidget view", printcharfun);
printchar ('>', printcharfun);
- break;
+ return;
case PVEC_WINDOW:
{
@@ -1845,7 +1836,7 @@ print_vectorlike (Lisp_Object obj, Lisp_Object printcharfun, bool escapeflag,
}
printchar ('>', printcharfun);
}
- break;
+ return;
case PVEC_TERMINAL:
{
@@ -1859,7 +1850,7 @@ print_vectorlike (Lisp_Object obj, Lisp_Object printcharfun, bool escapeflag,
}
printchar ('>', printcharfun);
}
- break;
+ return;
case PVEC_BUFFER:
if (!BUFFER_LIVE_P (XBUFFER (obj)))
@@ -1872,11 +1863,11 @@ print_vectorlike (Lisp_Object obj, Lisp_Object printcharfun, bool escapeflag,
}
else
print_string (BVAR (XBUFFER (obj), name), printcharfun);
- break;
+ return;
case PVEC_WINDOW_CONFIGURATION:
print_c_string ("#<window-configuration>", printcharfun);
- break;
+ return;
case PVEC_FRAME:
{
@@ -1900,7 +1891,7 @@ print_vectorlike (Lisp_Object obj, Lisp_Object printcharfun, bool escapeflag,
int len = sprintf (buf, " %p>", ptr);
strout (buf, len, len, printcharfun);
}
- break;
+ return;
case PVEC_FONT:
{
@@ -1912,12 +1903,17 @@ print_vectorlike (Lisp_Object obj, Lisp_Object printcharfun, bool escapeflag,
print_c_string ("#<font-entity", printcharfun);
for (int i = 0; i < FONT_SPEC_MAX; i++)
{
- printchar (' ', printcharfun);
- if (i < FONT_WEIGHT_INDEX || i > FONT_WIDTH_INDEX)
- print_object (AREF (obj, i), printcharfun, escapeflag);
- else
- print_object (font_style_symbolic (obj, i, 0),
- printcharfun, escapeflag);
+ /* FONT_EXTRA_INDEX can contain private information in
+ font entities which isn't safe to print. */
+ if (i != FONT_EXTRA_INDEX || !FONT_ENTITY_P (obj))
+ {
+ printchar (' ', printcharfun);
+ if (i < FONT_WEIGHT_INDEX || i > FONT_WIDTH_INDEX)
+ print_object (AREF (obj, i), printcharfun, escapeflag);
+ else
+ print_object (font_style_symbolic (obj, i, 0),
+ printcharfun, escapeflag);
+ }
}
}
else
@@ -1928,7 +1924,7 @@ print_vectorlike (Lisp_Object obj, Lisp_Object printcharfun, bool escapeflag,
}
printchar ('>', printcharfun);
}
- break;
+ return;
case PVEC_THREAD:
print_c_string ("#<thread ", printcharfun);
@@ -1941,7 +1937,7 @@ print_vectorlike (Lisp_Object obj, Lisp_Object printcharfun, bool escapeflag,
strout (buf, len, len, printcharfun);
}
printchar ('>', printcharfun);
- break;
+ return;
case PVEC_MUTEX:
print_c_string ("#<mutex ", printcharfun);
@@ -1954,7 +1950,7 @@ print_vectorlike (Lisp_Object obj, Lisp_Object printcharfun, bool escapeflag,
strout (buf, len, len, printcharfun);
}
printchar ('>', printcharfun);
- break;
+ return;
case PVEC_CONDVAR:
print_c_string ("#<condvar ", printcharfun);
@@ -1967,10 +1963,10 @@ print_vectorlike (Lisp_Object obj, Lisp_Object printcharfun, bool escapeflag,
strout (buf, len, len, printcharfun);
}
printchar ('>', printcharfun);
- break;
+ return;
-#ifdef HAVE_MODULES
case PVEC_MODULE_FUNCTION:
+#ifdef HAVE_MODULES
{
print_c_string ("#<module function ", printcharfun);
const struct Lisp_Module_Function *function = XMODULE_FUNCTION (obj);
@@ -1995,39 +1991,46 @@ print_vectorlike (Lisp_Object obj, Lisp_Object printcharfun, bool escapeflag,
}
printchar ('>', printcharfun);
+ return;
}
- break;
#endif
-#ifdef HAVE_NATIVE_COMP
+ break;
+
case PVEC_NATIVE_COMP_UNIT:
+#ifdef HAVE_NATIVE_COMP
{
struct Lisp_Native_Comp_Unit *cu = XNATIVE_COMP_UNIT (obj);
print_c_string ("#<native compilation unit: ", printcharfun);
- print_string (cu->file, printcharfun);
+ print_object (cu->file, printcharfun, escapeflag);
printchar (' ', printcharfun);
print_object (cu->optimize_qualities, printcharfun, escapeflag);
printchar ('>', printcharfun);
+ return;
}
- break;
#endif
+ break;
-#ifdef HAVE_TREE_SITTER
case PVEC_TS_PARSER:
+#ifdef HAVE_TREE_SITTER
print_c_string ("#<treesit-parser for ", printcharfun);
Lisp_Object language = XTS_PARSER (obj)->language_symbol;
/* No need to print the buffer because it's not that useful: we
usually know which buffer a parser belongs to. */
print_string (Fsymbol_name (language), printcharfun);
printchar ('>', printcharfun);
+ return;
+#endif
break;
+
case PVEC_TS_NODE:
+#ifdef HAVE_TREE_SITTER
/* Prints #<treesit-node (identifier) in 12-15> or
#<treesit-node "keyword" in 28-31>. */
print_c_string ("#<treesit-node", printcharfun);
if (!treesit_node_uptodate_p (obj))
{
print_c_string ("-outdated>", printcharfun);
- break;
+ return;
}
printchar (' ', printcharfun);
/* Now the node must be up-to-date, and calling functions like
@@ -2048,11 +2051,16 @@ print_vectorlike (Lisp_Object obj, Lisp_Object printcharfun, bool escapeflag,
printchar ('-', printcharfun);
print_object (Ftreesit_node_end (obj), printcharfun, escapeflag);
printchar ('>', printcharfun);
+ return;
+#endif
break;
+
case PVEC_TS_COMPILED_QUERY:
+#ifdef HAVE_TREE_SITTER
print_c_string ("#<treesit-compiled-query>", printcharfun);
- break;
+ return;
#endif
+ break;
case PVEC_SQLITE:
{
@@ -2068,13 +2076,33 @@ print_vectorlike (Lisp_Object obj, Lisp_Object printcharfun, bool escapeflag,
print_c_string (XSQLITE (obj)->name, printcharfun);
printchar ('>', printcharfun);
}
- break;
+ return;
- default:
- emacs_abort ();
- }
+ case PVEC_OBARRAY:
+ {
+ struct Lisp_Obarray *o = XOBARRAY (obj);
+ /* FIXME: Would it make sense to print the actual symbols (up to
+ a limit)? */
+ int i = sprintf (buf, "#<obarray n=%u>", o->count);
+ strout (buf, i, i, printcharfun);
+ return;
+ }
- return true;
+ /* Types handled earlier. */
+ case PVEC_NORMAL_VECTOR:
+ case PVEC_RECORD:
+ case PVEC_COMPILED:
+ case PVEC_CHAR_TABLE:
+ case PVEC_SUB_CHAR_TABLE:
+ case PVEC_HASH_TABLE:
+ case PVEC_BIGNUM:
+ case PVEC_BOOL_VECTOR:
+ /* Impossible cases. */
+ case PVEC_FREE:
+ case PVEC_OTHER:
+ break;
+ }
+ emacs_abort ();
}
static char
@@ -2201,9 +2229,9 @@ print_object (Lisp_Object obj, Lisp_Object printcharfun, bool escapeflag)
char buf[max (sizeof "from..to..in " + 2 * INT_STRLEN_BOUND (EMACS_INT),
max (sizeof " . #" + INT_STRLEN_BOUND (intmax_t),
max ((sizeof " with data 0x"
- + (sizeof (uintmax_t) * CHAR_BIT + 4 - 1) / 4),
+ + (UINTMAX_WIDTH + 4 - 1) / 4),
40)))];
- current_thread->stack_top = buf;
+ current_thread->stack_top = NEAR_STACK_TOP (buf);
print_obj:
maybe_quit ();
@@ -2247,6 +2275,11 @@ print_object (Lisp_Object obj, Lisp_Object printcharfun, bool escapeflag)
goto next_obj;
}
}
+ else if (STRINGP (num))
+ {
+ strout (SSDATA (num), SCHARS (num), SBYTES (num), printcharfun);
+ goto next_obj;
+ }
}
print_depth++;
@@ -2381,8 +2414,9 @@ print_object (Lisp_Object obj, Lisp_Object printcharfun, bool escapeflag)
if (string_intervals (obj))
{
+ Lisp_Object pcf = printcharfun;
traverse_intervals (string_intervals (obj),
- 0, print_interval, printcharfun);
+ 0, print_interval, &pcf);
printchar (')', printcharfun);
}
}
@@ -2518,36 +2552,23 @@ print_object (Lisp_Object obj, Lisp_Object printcharfun, bool escapeflag)
switch (PSEUDOVECTOR_TYPE (XVECTOR (obj)))
{
case PVEC_NORMAL_VECTOR:
- {
- print_stack_push_vector ("[", "]", obj, 0, ASIZE (obj),
- printcharfun);
- goto next_obj;
- }
+ print_stack_push_vector ("[", "]", obj, 0, ASIZE (obj),
+ printcharfun);
+ goto next_obj;
case PVEC_RECORD:
- {
- print_stack_push_vector ("#s(", ")", obj, 0, PVSIZE (obj),
- printcharfun);
- goto next_obj;
- }
+ print_stack_push_vector ("#s(", ")", obj, 0, PVSIZE (obj),
+ printcharfun);
+ goto next_obj;
case PVEC_COMPILED:
- {
- print_stack_push_vector ("#[", "]", obj, 0, PVSIZE (obj),
- printcharfun);
- goto next_obj;
- }
+ print_stack_push_vector ("#[", "]", obj, 0, PVSIZE (obj),
+ printcharfun);
+ goto next_obj;
case PVEC_CHAR_TABLE:
- {
- print_stack_push_vector ("#^[", "]", obj, 0, PVSIZE (obj),
- printcharfun);
- goto next_obj;
- }
+ print_stack_push_vector ("#^[", "]", obj, 0, PVSIZE (obj),
+ printcharfun);
+ goto next_obj;
case PVEC_SUB_CHAR_TABLE:
{
- /* Make each lowest sub_char_table start a new line.
- Otherwise we'll make a line extremely long, which
- results in slow redisplay. */
- if (XSUB_CHAR_TABLE (obj)->depth == 3)
- printchar ('\n', printcharfun);
print_c_string ("#^^[", printcharfun);
int n = sprintf (buf, "%d %d",
XSUB_CHAR_TABLE (obj)->depth,
@@ -2562,77 +2583,68 @@ print_object (Lisp_Object obj, Lisp_Object printcharfun, bool escapeflag)
{
struct Lisp_Hash_Table *h = XHASH_TABLE (obj);
/* Implement a readable output, e.g.:
- #s(hash-table size 2 test equal data (k1 v1 k2 v2)) */
- /* Always print the size. */
- int len = sprintf (buf, "#s(hash-table size %"pD"d",
- HASH_TABLE_SIZE (h));
- strout (buf, len, len, printcharfun);
+ #s(hash-table test equal data (k1 v1 k2 v2)) */
+ print_c_string ("#s(hash-table", printcharfun);
- if (!NILP (h->test.name))
+ if (!BASE_EQ (h->test->name, Qeql))
{
print_c_string (" test ", printcharfun);
- print_object (h->test.name, printcharfun, escapeflag);
+ print_object (h->test->name, printcharfun, escapeflag);
}
- if (!NILP (h->weak))
+ if (h->weakness != Weak_None)
{
print_c_string (" weakness ", printcharfun);
- print_object (h->weak, printcharfun, escapeflag);
+ print_object (hash_table_weakness_symbol (h->weakness),
+ printcharfun, escapeflag);
}
- print_c_string (" rehash-size ", printcharfun);
- print_object (Fhash_table_rehash_size (obj),
- printcharfun, escapeflag);
-
- print_c_string (" rehash-threshold ", printcharfun);
- print_object (Fhash_table_rehash_threshold (obj),
- printcharfun, escapeflag);
-
if (h->purecopy)
print_c_string (" purecopy t", printcharfun);
- print_c_string (" data (", printcharfun);
-
ptrdiff_t size = h->count;
- /* Don't print more elements than the specified maximum. */
- if (FIXNATP (Vprint_length) && XFIXNAT (Vprint_length) < size)
- size = XFIXNAT (Vprint_length);
-
- print_stack_push ((struct print_stack_entry){
- .type = PE_hash,
- .u.hash.obj = obj,
- .u.hash.nobjs = size * 2,
- .u.hash.idx = 0,
- .u.hash.printed = 0,
- .u.hash.truncated = (size < h->count),
- });
+ if (size > 0)
+ {
+ print_c_string (" data (", printcharfun);
+
+ /* Don't print more elements than the specified maximum. */
+ if (FIXNATP (Vprint_length) && XFIXNAT (Vprint_length) < size)
+ size = XFIXNAT (Vprint_length);
+
+ print_stack_push ((struct print_stack_entry){
+ .type = PE_hash,
+ .u.hash.obj = obj,
+ .u.hash.nobjs = size * 2,
+ .u.hash.idx = 0,
+ .u.hash.printed = 0,
+ .u.hash.truncated = (size < h->count),
+ });
+ }
+ else
+ {
+ /* Empty table: we can omit the data entirely. */
+ printchar (')', printcharfun);
+ --print_depth; /* Done with this. */
+ }
goto next_obj;
}
+ case PVEC_BIGNUM:
+ print_bignum (obj, printcharfun);
+ break;
+
+ case PVEC_BOOL_VECTOR:
+ print_bool_vector (obj, printcharfun);
+ break;
+
default:
+ print_vectorlike_unreadable (obj, printcharfun, escapeflag, buf);
break;
}
-
- if (print_vectorlike (obj, printcharfun, escapeflag, buf))
break;
- FALLTHROUGH;
default:
- {
- int len;
- /* We're in trouble if this happens!
- Probably should just emacs_abort (). */
- print_c_string ("#<EMACS BUG: INVALID DATATYPE ", printcharfun);
- if (VECTORLIKEP (obj))
- len = sprintf (buf, "(PVEC 0x%08zx)", (size_t) ASIZE (obj));
- else
- len = sprintf (buf, "(0x%02x)", (unsigned) XTYPE (obj));
- strout (buf, len, len, printcharfun);
- print_c_string ((" Save your buffers immediately"
- " and please report this bug>"),
- printcharfun);
- break;
- }
+ emacs_abort ();
}
print_depth--;
@@ -2662,7 +2674,7 @@ print_object (Lisp_Object obj, Lisp_Object printcharfun, bool escapeflag)
/* With the print-circle feature. */
Lisp_Object num = Fgethash (next, Vprint_number_table,
Qnil);
- if (FIXNUMP (num))
+ if (!(NILP (num) || EQ (num, Qt)))
{
print_c_string (" . ", printcharfun);
obj = next;
@@ -2766,7 +2778,7 @@ print_object (Lisp_Object obj, Lisp_Object printcharfun, bool escapeflag)
{
Lisp_Object key;
ptrdiff_t idx = e->u.hash.idx;
- while (BASE_EQ ((key = HASH_KEY (h, idx)), Qunbound))
+ while (hash_unused_entry_key_p ((key = HASH_KEY (h, idx))))
idx++;
e->u.hash.idx = idx;
obj = key;
@@ -2789,10 +2801,11 @@ print_object (Lisp_Object obj, Lisp_Object printcharfun, bool escapeflag)
This is part of printing a string that has text properties. */
static void
-print_interval (INTERVAL interval, Lisp_Object printcharfun)
+print_interval (INTERVAL interval, void *pprintcharfun)
{
if (NILP (interval->plist))
return;
+ Lisp_Object printcharfun = *(Lisp_Object *)pprintcharfun;
printchar (' ', printcharfun);
print_object (make_fixnum (interval->position), printcharfun, 1);
printchar (' ', printcharfun);
@@ -2925,7 +2938,10 @@ This variable should not be set with `setq'; bind it with a `let' instead. */);
DEFVAR_LISP ("print-number-table", Vprint_number_table,
doc: /* A vector used internally to produce `#N=' labels and `#N#' references.
The Lisp printer uses this vector to detect Lisp objects referenced more
-than once.
+than once. If an entry contains a number, then the corresponding key is
+referenced more than once: a positive sign indicates that it's already been
+printed, and the absolute value indicates the number to use when printing.
+If an entry contains a string, that string is printed instead.
When you bind `print-continuous-numbering' to t, you should probably
also bind `print-number-table' to nil. This ensures that the value of
diff --git a/src/process.c b/src/process.c
index cec0acc4236..6b8b483cdf7 100644
--- a/src/process.c
+++ b/src/process.c
@@ -119,6 +119,11 @@ static struct rlimit nofile_limit;
#include "gnutls.h"
#endif
+#ifdef HAVE_ANDROID
+#include "android.h"
+#include "androidterm.h"
+#endif
+
#ifdef HAVE_WINDOW_SYSTEM
#include TERM_HEADER
#endif /* HAVE_WINDOW_SYSTEM */
@@ -876,7 +881,8 @@ allocate_pty (char pty_name[PTY_NAME_SIZE])
/* Check to make certain that both sides are available.
This avoids a nasty yet stupid bug in rlogins. */
- if (faccessat (AT_FDCWD, pty_name, R_OK | W_OK, AT_EACCESS) != 0)
+ if (sys_faccessat (AT_FDCWD, pty_name,
+ R_OK | W_OK, AT_EACCESS) != 0)
{
emacs_close (fd);
continue;
@@ -1732,6 +1738,18 @@ DEFUN ("process-list", Fprocess_list, Sprocess_list, 0, 0, 0,
}
+static Lisp_Object
+get_required_string_keyword_param (Lisp_Object kwargs, Lisp_Object keyword)
+{
+ Lisp_Object arg = plist_member (kwargs, keyword);
+ if (NILP (arg) || !CONSP (arg) || !CONSP (XCDR (arg)))
+ error ("Missing %s keyword parameter", SSDATA (SYMBOL_NAME (keyword)));
+ Lisp_Object val = XCAR (XCDR (arg));
+ if (!STRINGP (val))
+ error ("%s value not a string", SSDATA (SYMBOL_NAME (keyword)));
+ return val;
+}
+
/* Starting asynchronous inferior processes. */
DEFUN ("make-process", Fmake_process, Smake_process, 0, MANY, 0,
@@ -1796,7 +1814,7 @@ such handler, proceed as if FILE-HANDLER were nil.
usage: (make-process &rest ARGS) */)
(ptrdiff_t nargs, Lisp_Object *args)
{
- Lisp_Object buffer, name, command, program, proc, contact, current_dir, tem;
+ Lisp_Object buffer, command, program, proc, contact, current_dir, tem;
Lisp_Object xstderr, stderrproc;
specpdl_ref count = SPECPDL_INDEX ();
@@ -1825,8 +1843,7 @@ usage: (make-process &rest ARGS) */)
chdir, since it's in a vfork. */
current_dir = get_current_directory (true);
- name = plist_get (contact, QCname);
- CHECK_STRING (name);
+ Lisp_Object name = get_required_string_keyword_param (contact, QCname);
command = plist_get (contact, QCcommand);
if (CONSP (command))
@@ -2003,7 +2020,7 @@ usage: (make-process &rest ARGS) */)
{
tem = Qnil;
openp (Vexec_path, program, Vexec_suffixes, &tem,
- make_fixnum (X_OK), false, false);
+ make_fixnum (X_OK), false, false, NULL);
if (NILP (tem))
report_file_error ("Searching for program", program);
tem = Fexpand_file_name (tem, Qnil);
@@ -2409,7 +2426,7 @@ usage: (make-pipe-process &rest ARGS) */)
{
Lisp_Object proc, contact;
struct Lisp_Process *p;
- Lisp_Object name, buffer;
+ Lisp_Object buffer;
Lisp_Object tem;
int inchannel, outchannel;
@@ -2418,8 +2435,7 @@ usage: (make-pipe-process &rest ARGS) */)
contact = Flist (nargs, args);
- name = plist_get (contact, QCname);
- CHECK_STRING (name);
+ Lisp_Object name = get_required_string_keyword_param (contact, QCname);
proc = make_process (name);
specpdl_ref specpdl_count = SPECPDL_INDEX ();
record_unwind_protect (remove_process, proc);
@@ -3939,7 +3955,7 @@ usage: (make-network-process &rest ARGS) */)
#endif
EMACS_INT port = 0;
Lisp_Object tem;
- Lisp_Object name, buffer, host, service, address;
+ Lisp_Object buffer, host, service, address;
Lisp_Object filter, sentinel, use_external_socket_p;
Lisp_Object addrinfos = Qnil;
int socktype;
@@ -3976,7 +3992,7 @@ usage: (make-network-process &rest ARGS) */)
else
error ("Unsupported connection type");
- name = plist_get (contact, QCname);
+ Lisp_Object name = get_required_string_keyword_param (contact, QCname);
buffer = plist_get (contact, QCbuffer);
filter = plist_get (contact, QCfilter);
sentinel = plist_get (contact, QCsentinel);
@@ -3986,7 +4002,6 @@ usage: (make-network-process &rest ARGS) */)
if (!NILP (server) && nowait)
error ("`:server' is incompatible with `:nowait'");
- CHECK_STRING (name);
/* :local ADDRESS or :remote ADDRESS */
if (NILP (server))
@@ -5194,6 +5209,27 @@ wait_reading_process_output_1 (void)
{
}
+#if defined HAVE_ANDROID && !defined ANDROID_STUBIFY \
+ && defined THREADS_ENABLED
+
+/* Wrapper around `android_select' that exposes a calling interface with
+ an extra argument for compatibility with `thread_pselect'. */
+
+static int
+android_select_wrapper (int nfds, fd_set *readfds, fd_set *writefds,
+ fd_set *exceptfds, const struct timespec *timeout,
+ const sigset_t *sigmask)
+{
+ /* sigmask is not supported. */
+ if (sigmask)
+ emacs_abort ();
+
+ return android_select (nfds, readfds, writefds, exceptfds,
+ (struct timespec *) timeout);
+}
+
+#endif /* HAVE_ANDROID && !ANDROID_STUBIFY && THREADS_ENABLED */
+
/* Read and dispose of subprocess output while waiting for timeout to
elapse and/or keyboard input to be available.
@@ -5403,7 +5439,7 @@ wait_reading_process_output (intmax_t time_limit, int nsecs, int read_kbd,
/* If there is unread keyboard input, also return. */
if (read_kbd != 0
- && requeued_events_pending_p ())
+ && requeued_command_events_pending_p ())
break;
/* This is so a breakpoint can be put here. */
@@ -5686,7 +5722,23 @@ wait_reading_process_output (intmax_t time_limit, int nsecs, int read_kbd,
timeout = short_timeout;
#endif
- /* Non-macOS HAVE_GLIB builds call thread_select in xgselect.c. */
+ /* Android requires using a replacement for pselect in
+ android.c to poll for events. */
+#if defined HAVE_ANDROID && !defined ANDROID_STUBIFY
+#ifndef THREADS_ENABLED
+ nfds = android_select (max_desc + 1,
+ &Available, (check_write ? &Writeok : 0),
+ NULL, &timeout);
+#else /* THREADS_ENABLED */
+ nfds = thread_select (android_select_wrapper,
+ max_desc + 1,
+ &Available, (check_write ? &Writeok : 0),
+ NULL, &timeout, NULL);
+#endif /* THREADS_ENABLED */
+#else
+
+ /* Non-macOS HAVE_GLIB builds call thread_select in
+ xgselect.c. */
#if defined HAVE_GLIB && !defined HAVE_NS
nfds = xg_select (max_desc + 1,
&Available, (check_write ? &Writeok : 0),
@@ -5702,6 +5754,7 @@ wait_reading_process_output (intmax_t time_limit, int nsecs, int read_kbd,
(check_write ? &Writeok : 0),
NULL, &timeout, NULL);
#endif /* !HAVE_GLIB */
+#endif /* HAVE_ANDROID && !ANDROID_STUBIFY */
#ifdef HAVE_GNUTLS
/* Merge tls_available into Available. */
@@ -5796,7 +5849,7 @@ wait_reading_process_output (intmax_t time_limit, int nsecs, int read_kbd,
/* If there is unread keyboard input, also return. */
if (read_kbd != 0
- && requeued_events_pending_p ())
+ && requeued_command_events_pending_p ())
break;
/* If we are not checking for keyboard input now,
@@ -7137,7 +7190,8 @@ See function `signal-process' for more details on usage. */)
{
ptrdiff_t len;
tem = string_to_number (SSDATA (process), 10, &len);
- if (NILP (tem) || len != SBYTES (process))
+ if ((IEEE_FLOATING_POINT ? NILP (tem) : !NUMBERP (tem))
+ || len != SBYTES (process))
return Qnil;
}
process = tem;
@@ -7240,10 +7294,10 @@ process has been transmitted to the serial port. */)
send_process (proc, "\004", 1, Qnil);
else if (EQ (XPROCESS (proc)->type, Qserial))
{
-#ifndef WINDOWSNT
+#if !defined WINDOWSNT && defined HAVE_TCDRAIN
if (tcdrain (XPROCESS (proc)->outfd) != 0)
report_file_error ("Failed tcdrain", Qnil);
-#endif /* not WINDOWSNT */
+#endif /* not WINDOWSNT && not TCDRAIN */
/* Do nothing on Windows because writes are blocking. */
}
else
@@ -7396,8 +7450,31 @@ child_signal_notify (void)
int fd = child_signal_write_fd;
eassert (0 <= fd);
char dummy = 0;
- if (emacs_write (fd, &dummy, 1) != 1)
- emacs_perror ("writing to child signal FD");
+ /* We used to error out here, like this:
+
+ if (emacs_write (fd, &dummy, 1) != 1)
+ emacs_perror ("writing to child signal FD");
+
+ But this calls `emacs_perror', which in turn invokes a localized
+ version of strerror, which is not reentrant and must not be
+ called within a signal handler:
+
+ __lll_lock_wait_private () at /lib64/libc.so.6
+ malloc () at /lib64/libc.so.6
+ _nl_make_l10nflist.localalias () at /lib64/libc.so.6
+ _nl_find_domain () at /lib64/libc.so.6
+ __dcigettext () at /lib64/libc.so.6
+ strerror_l () at /lib64/libc.so.6
+ emacs_perror (message=message@entry=0x6babc2)
+ child_signal_notify () at process.c:7419
+ handle_child_signal (sig=17) at process.c:7533
+ deliver_process_signal (sig=17, handler=0x6186b0>)
+ <signal handler called> () at /lib64/libc.so.6
+ _int_malloc () at /lib64/libc.so.6
+ in malloc () at /lib64/libc.so.6.
+
+ So we no longer check errors of emacs_write here. */
+ emacs_write (fd, &dummy, 1);
#endif
}
@@ -7463,6 +7540,16 @@ handle_child_signal (int sig)
{
changed = true;
if (STRINGP (XCDR (head)))
+ /* handle_child_signal is called in an async signal
+ handler but needs to unlink temporary files which
+ might've been created in an Android content
+ provider.
+
+ emacs_unlink is not async signal safe because
+ deleting files from content providers must proceed
+ through Java code. Consequently, if XCDR (head)
+ lies on a content provider it will not be removed,
+ which is a bug. */
unlink (SSDATA (XCDR (head)));
XSETCAR (tail, Qnil);
}
@@ -7949,7 +8036,7 @@ wait_reading_process_output (intmax_t time_limit, int nsecs, int read_kbd,
/* If there is unread keyboard input, also return. */
if (read_kbd != 0
- && requeued_events_pending_p ())
+ && requeued_command_events_pending_p ())
break;
if (timespec_valid_p (timer_delay))
@@ -8022,7 +8109,7 @@ wait_reading_process_output (intmax_t time_limit, int nsecs, int read_kbd,
/* If there is unread keyboard input, also return. */
if (read_kbd
- && requeued_events_pending_p ())
+ && requeued_command_events_pending_p ())
break;
/* If wait_for_cell. check for keyboard input
diff --git a/src/profiler.c b/src/profiler.c
index 0ee57c424e2..5a6a8b48f6b 100644
--- a/src/profiler.c
+++ b/src/profiler.c
@@ -34,46 +34,175 @@ saturated_add (EMACS_INT a, EMACS_INT b)
/* Logs. */
-typedef struct Lisp_Hash_Table log_t;
+/* A fully associative cache of size SIZE, mapping vectors of DEPTH
+ Lisp objects to counts. */
+typedef struct {
+ /* We use `int' throughout for table indices because anything bigger
+ is overkill. (Maybe we should make a typedef, but int is short.) */
+ int size; /* number of entries */
+ int depth; /* elements in each key vector */
+ int index_size; /* size of index */
+ Lisp_Object *trace; /* working trace, `depth' elements */
+ int *index; /* `index_size' indices or -1 if nothing */
+ int *next; /* `size' indices to next bucket or -1 */
+ EMACS_UINT *hash; /* `size' hash values */
+ Lisp_Object *keys; /* `size' keys of `depth' objects each */
+ EMACS_INT *counts; /* `size' entries, 0 indicates unused entry */
+ int next_free; /* next free entry, -1 if all taken */
+} log_t;
-static Lisp_Object cmpfn_profiler (Lisp_Object, Lisp_Object,
- struct Lisp_Hash_Table *);
-static Lisp_Object hashfn_profiler (Lisp_Object, struct Lisp_Hash_Table *);
+static void
+mark_log (log_t *log)
+{
+ if (log == NULL)
+ return;
+ int size = log->size;
+ int depth = log->depth;
+ for (int i = 0; i < size; i++)
+ if (log->counts[i] > 0) /* Only mark valid keys. */
+ mark_objects (log->keys + i * depth, depth);
+}
+
+static log_t *
+make_log (int size, int depth)
+{
+ log_t *log = xmalloc (sizeof *log);
+ log->size = size;
+ log->depth = depth;
-static const struct hash_table_test hashtest_profiler =
- {
- LISPSYM_INITIALLY (Qprofiler_backtrace_equal),
- LISPSYM_INITIALLY (Qnil) /* user_hash_function */,
- LISPSYM_INITIALLY (Qnil) /* user_cmp_function */,
- cmpfn_profiler,
- hashfn_profiler,
- };
+ /* The index size is arbitrary but for there to be any point it should be
+ bigger than SIZE. FIXME: make it a power of 2 or a (pseudo)prime. */
+ int index_size = size * 2 + 1;
+ log->index_size = index_size;
+
+ log->trace = xmalloc (depth * sizeof *log->trace);
+
+ log->index = xmalloc (index_size * sizeof *log->index);
+ for (int i = 0; i < index_size; i++)
+ log->index[i] = -1;
+
+ log->next = xmalloc (size * sizeof *log->next);
+ for (int i = 0; i < size - 1; i++)
+ log->next[i] = i + 1;
+ log->next[size - 1] = -1;
+ log->next_free = 0;
+
+ log->hash = xmalloc (size * sizeof *log->hash);
+ log->keys = xzalloc (size * depth * sizeof *log->keys);
+ log->counts = xzalloc (size * sizeof *log->counts);
-static Lisp_Object
-make_log (void)
-{
- /* We use a standard Elisp hash-table object, but we use it in
- a special way. This is OK as long as the object is not exposed
- to Elisp, i.e. until it is returned by *-profiler-log, after which
- it can't be used any more. */
- EMACS_INT heap_size
- = clip_to_bounds (0, profiler_log_size, MOST_POSITIVE_FIXNUM);
- ptrdiff_t max_stack_depth
- = clip_to_bounds (0, profiler_max_stack_depth, PTRDIFF_MAX);;
- Lisp_Object log = make_hash_table (hashtest_profiler, heap_size,
- DEFAULT_REHASH_SIZE,
- DEFAULT_REHASH_THRESHOLD,
- Qnil, false);
- struct Lisp_Hash_Table *h = XHASH_TABLE (log);
-
- /* What is special about our hash-tables is that the values are pre-filled
- with the vectors we'll use as keys. */
- ptrdiff_t i = ASIZE (h->key_and_value) >> 1;
- while (i > 0)
- set_hash_value_slot (h, --i, make_nil_vector (max_stack_depth));
return log;
}
+static void
+free_log (log_t *log)
+{
+ xfree (log->trace);
+ xfree (log->index);
+ xfree (log->next);
+ xfree (log->hash);
+ xfree (log->keys);
+ xfree (log->counts);
+ xfree (log);
+}
+
+static inline EMACS_INT
+get_log_count (log_t *log, int idx)
+{
+ eassume (idx >= 0 && idx < log->size);
+ return log->counts[idx];
+}
+
+static inline void
+set_log_count (log_t *log, int idx, EMACS_INT val)
+{
+ eassume (idx >= 0 && idx < log->size && val >= 0);
+ log->counts[idx] = val;
+}
+
+static inline Lisp_Object *
+get_key_vector (log_t *log, int idx)
+{
+ eassume (idx >= 0 && idx < log->size);
+ return log->keys + idx * log->depth;
+}
+
+static inline int
+log_hash_index (log_t *log, EMACS_UINT hash)
+{
+ /* FIXME: avoid division. */
+ return hash % log->index_size;
+}
+
+static void
+remove_log_entry (log_t *log, int idx)
+{
+ eassume (idx >= 0 && idx < log->size);
+ /* Remove from index. */
+ int hidx = log_hash_index (log, log->hash[idx]);
+ int *p = &log->index[hidx];
+ while (*p != idx)
+ {
+ eassert (*p >= 0 && *p < log->size);
+ p = &log->next[*p];
+ }
+ *p = log->next[*p];
+ /* Invalidate entry and put it on the free list. */
+ log->counts[idx] = 0;
+ log->next[idx] = log->next_free;
+ log->next_free = idx;
+}
+
+static bool
+trace_equal (Lisp_Object *bt1, Lisp_Object *bt2, int depth)
+{
+ for (int i = 0; i < depth; i++)
+ if (!BASE_EQ (bt1[i], bt2[i]) && NILP (Ffunction_equal (bt1[i], bt2[i])))
+ return false;
+ return true;
+}
+
+static EMACS_UINT
+trace_hash (Lisp_Object *trace, int depth)
+{
+ EMACS_UINT hash = 0;
+ for (int i = 0; i < depth; i++)
+ {
+ Lisp_Object f = trace[i];
+ EMACS_UINT hash1
+ = (COMPILEDP (f) ? XHASH (AREF (f, COMPILED_BYTECODE))
+ : (CONSP (f) && CONSP (XCDR (f)) && BASE_EQ (Qclosure, XCAR (f)))
+ ? XHASH (XCDR (XCDR (f))) : XHASH (f));
+ hash = sxhash_combine (hash, hash1);
+ }
+ return hash;
+}
+
+struct profiler_log {
+ log_t *log;
+ EMACS_INT gc_count; /* Samples taken during GC. */
+ EMACS_INT discarded; /* Samples evicted during table overflow. */
+};
+
+static Lisp_Object export_log (struct profiler_log *);
+
+static struct profiler_log
+make_profiler_log (void)
+{
+ int size = clip_to_bounds (0, profiler_log_size,
+ min (MOST_POSITIVE_FIXNUM, INT_MAX));
+ int max_stack_depth = clip_to_bounds (0, profiler_max_stack_depth, INT_MAX);
+ return (struct profiler_log){make_log (size, max_stack_depth), 0, 0};
+}
+
+static void
+free_profiler_log (struct profiler_log *plog)
+{
+ free_log (plog->log);
+ plog->log = NULL;
+}
+
+
/* Evict the least used half of the hash_table.
When the table is full, we have to evict someone.
@@ -90,22 +219,22 @@ make_log (void)
cost of O(1) and we get O(N) time for a new entry to grow larger
than the other least counts before a new round of eviction. */
-static EMACS_INT approximate_median (log_t *log,
- ptrdiff_t start, ptrdiff_t size)
+static EMACS_INT
+approximate_median (log_t *log, int start, int size)
{
eassert (size > 0);
if (size < 2)
- return XFIXNUM (HASH_VALUE (log, start));
+ return get_log_count (log, start);
if (size < 3)
/* Not an actual median, but better for our application than
choosing either of the two numbers. */
- return ((XFIXNUM (HASH_VALUE (log, start))
- + XFIXNUM (HASH_VALUE (log, start + 1)))
+ return ((get_log_count (log, start)
+ + get_log_count (log, start + 1))
/ 2);
else
{
- ptrdiff_t newsize = size / 3;
- ptrdiff_t start2 = start + newsize;
+ int newsize = size / 3;
+ int start2 = start + newsize;
EMACS_INT i1 = approximate_median (log, start, newsize);
EMACS_INT i2 = approximate_median (log, start2, newsize);
EMACS_INT i3 = approximate_median (log, start2 + newsize,
@@ -116,31 +245,24 @@ static EMACS_INT approximate_median (log_t *log,
}
}
-static void evict_lower_half (log_t *log)
+static void
+evict_lower_half (struct profiler_log *plog)
{
- ptrdiff_t size = ASIZE (log->key_and_value) / 2;
+ log_t *log = plog->log;
+ int size = log->size;
EMACS_INT median = approximate_median (log, 0, size);
- for (ptrdiff_t i = 0; i < size; i++)
- /* Evict not only values smaller but also values equal to the median,
- so as to make sure we evict something no matter what. */
- if (XFIXNUM (HASH_VALUE (log, i)) <= median)
- {
- Lisp_Object key = HASH_KEY (log, i);
- { /* FIXME: we could make this more efficient. */
- Lisp_Object tmp;
- XSET_HASH_TABLE (tmp, log); /* FIXME: Use make_lisp_ptr. */
- Fremhash (key, tmp);
+ for (int i = 0; i < size; i++)
+ {
+ EMACS_INT count = get_log_count (log, i);
+ /* Evict not only values smaller but also values equal to the median,
+ so as to make sure we evict something no matter what. */
+ if (count <= median)
+ {
+ plog->discarded = saturated_add (plog->discarded, count);
+ remove_log_entry (log, i);
}
- eassert (BASE_EQ (Qunbound, HASH_KEY (log, i)));
- eassert (log->next_free == i);
-
- eassert (VECTORP (key));
- for (ptrdiff_t j = 0; j < ASIZE (key); j++)
- ASET (key, j, Qnil);
-
- set_hash_value_slot (log, i, key);
- }
+ }
}
/* Record the current backtrace in LOG. COUNT is the weight of this
@@ -148,62 +270,80 @@ static void evict_lower_half (log_t *log)
size for memory. */
static void
-record_backtrace (log_t *log, EMACS_INT count)
+record_backtrace (struct profiler_log *plog, EMACS_INT count)
{
+ log_t *log = plog->log;
+ get_backtrace (log->trace, log->depth);
+ EMACS_UINT hash = trace_hash (log->trace, log->depth);
+ int hidx = log_hash_index (log, hash);
+ int idx = log->index[hidx];
+ while (idx >= 0)
+ {
+ if (log->hash[idx] == hash
+ && trace_equal (log->trace, get_key_vector (log, idx), log->depth))
+ {
+ /* Found existing entry. */
+ set_log_count (log, idx,
+ saturated_add (get_log_count (log, idx), count));
+ return;
+ }
+ idx = log->next[idx];
+ }
+
+ /* Add new entry. */
if (log->next_free < 0)
- /* FIXME: transfer the evicted counts to a special entry rather
- than dropping them on the floor. */
- evict_lower_half (log);
- ptrdiff_t index = log->next_free;
-
- /* Get a "working memory" vector. */
- Lisp_Object backtrace = HASH_VALUE (log, index);
- eassert (BASE_EQ (Qunbound, HASH_KEY (log, index)));
- get_backtrace (backtrace);
-
- { /* We basically do a `gethash+puthash' here, except that we have to be
- careful to avoid memory allocation since we're in a signal
- handler, and we optimize the code to try and avoid computing the
- hash+lookup twice. See fns.c:Fputhash for reference. */
- Lisp_Object hash;
- ptrdiff_t j = hash_lookup (log, backtrace, &hash);
- if (j >= 0)
- {
- EMACS_INT old_val = XFIXNUM (HASH_VALUE (log, j));
- EMACS_INT new_val = saturated_add (old_val, count);
- set_hash_value_slot (log, j, make_fixnum (new_val));
- }
- else
- { /* BEWARE! hash_put in general can allocate memory.
- But currently it only does that if log->next_free is -1. */
- eassert (0 <= log->next_free);
- ptrdiff_t j = hash_put (log, backtrace, make_fixnum (count), hash);
- /* Let's make sure we've put `backtrace' right where it
- already was to start with. */
- eassert (index == j);
-
- /* FIXME: If the hash-table is almost full, we should set
- some global flag so that some Elisp code can offload its
- data elsewhere, so as to avoid the eviction code.
- There are 2 ways to do that, AFAICT:
- - Set a flag checked in maybe_quit, such that maybe_quit can then
- call Fprofiler_cpu_log and stash the full log for later use.
- - Set a flag check in post-gc-hook, so that Elisp code can call
- profiler-cpu-log. That gives us more flexibility since that
- Elisp code can then do all kinds of fun stuff like write
- the log to disk. Or turn it right away into a call tree.
- Of course, using Elisp is generally preferable, but it may
- take longer until we get a chance to run the Elisp code, so
- there's more risk that the table will get full before we
- get there. */
- }
- }
+ evict_lower_half (plog);
+ idx = log->next_free;
+ eassert (idx >= 0);
+ log->next_free = log->next[idx];
+ log->next[idx] = log->index[hidx];
+ log->index[hidx] = idx;
+ eassert (log->counts[idx] == 0);
+ log->hash[idx] = hash;
+ memcpy (get_key_vector (log, idx), log->trace,
+ log->depth * sizeof *log->trace);
+ log->counts[idx] = count;
+
+ /* FIXME: If the hash-table is almost full, we should set
+ some global flag so that some Elisp code can offload its
+ data elsewhere, so as to avoid the eviction code.
+ There are 2 ways to do that:
+ - Set a flag checked in maybe_quit, such that maybe_quit can then
+ call Fprofiler_cpu_log and stash the full log for later use.
+ - Set a flag check in post-gc-hook, so that Elisp code can call
+ profiler-cpu-log. That gives us more flexibility since that
+ Elisp code can then do all kinds of fun stuff like write
+ the log to disk. Or turn it right away into a call tree.
+ Of course, using Elisp is generally preferable, but it may
+ take longer until we get a chance to run the Elisp code, so
+ there's more risk that the table will get full before we
+ get there. */
}
/* Sampling profiler. */
+/* Signal handler for sampling profiler. */
+
+static void
+add_sample (struct profiler_log *plog, EMACS_INT count)
+{
+ if (EQ (backtrace_top_function (), QAutomatic_GC)) /* bug#60237 */
+ /* Special case the time-count inside GC because the hash-table
+ code is not prepared to be used while the GC is running.
+ More specifically it uses ASIZE at many places where it does
+ not expect the ARRAY_MARK_FLAG to be set. We could try and
+ harden the hash-table code, but it doesn't seem worth the
+ effort. */
+ plog->gc_count = saturated_add (plog->gc_count, count);
+ else
+ record_backtrace (plog, count);
+}
+
#ifdef PROFILER_CPU_SUPPORT
+/* The sampling interval specified. */
+static Lisp_Object profiler_cpu_interval = LISPSYM_INITIALLY (Qnil);
+
/* The profiler timer and whether it was properly initialized, if
POSIX timers are available. */
#ifdef HAVE_ITIMERSPEC
@@ -222,41 +362,24 @@ static enum profiler_cpu_running
profiler_cpu_running;
/* Hash-table log of CPU profiler. */
-static Lisp_Object cpu_log;
-
-/* Separate counter for the time spent in the GC. */
-static EMACS_INT cpu_gc_count;
+static struct profiler_log cpu;
/* The current sampling interval in nanoseconds. */
static EMACS_INT current_sampling_interval;
-/* Signal handler for sampling profiler. */
-
static void
handle_profiler_signal (int signal)
{
- if (EQ (backtrace_top_function (), QAutomatic_GC))
- /* Special case the time-count inside GC because the hash-table
- code is not prepared to be used while the GC is running.
- More specifically it uses ASIZE at many places where it does
- not expect the ARRAY_MARK_FLAG to be set. We could try and
- harden the hash-table code, but it doesn't seem worth the
- effort. */
- cpu_gc_count = saturated_add (cpu_gc_count, 1);
- else
- {
- EMACS_INT count = 1;
+ EMACS_INT count = 1;
#if defined HAVE_ITIMERSPEC && defined HAVE_TIMER_GETOVERRUN
- if (profiler_timer_ok)
- {
- int overruns = timer_getoverrun (profiler_timer);
- eassert (overruns >= 0);
- count += overruns;
- }
-#endif
- eassert (HASH_TABLE_P (cpu_log));
- record_backtrace (XHASH_TABLE (cpu_log), count);
+ if (profiler_timer_ok)
+ {
+ int overruns = timer_getoverrun (profiler_timer);
+ eassert (overruns >= 0);
+ count += overruns;
}
+#endif
+ add_sample (&cpu, count);
}
static void
@@ -343,11 +466,8 @@ See also `profiler-log-size' and `profiler-max-stack-depth'. */)
if (profiler_cpu_running)
error ("CPU profiler is already running");
- if (NILP (cpu_log))
- {
- cpu_gc_count = 0;
- cpu_log = make_log ();
- }
+ if (cpu.log == NULL)
+ cpu = make_profiler_log ();
int status = setup_cpu_timer (sampling_interval);
if (status < 0)
@@ -357,6 +477,7 @@ See also `profiler-log-size' and `profiler-max-stack-depth'. */)
}
else
{
+ profiler_cpu_interval = sampling_interval;
profiler_cpu_running = status;
if (! profiler_cpu_running)
error ("Unable to start profiler timer");
@@ -418,26 +539,59 @@ of functions, where the last few elements may be nil.
Before returning, a new log is allocated for future samples. */)
(void)
{
- Lisp_Object result = cpu_log;
- /* Here we're making the log visible to Elisp, so it's not safe any
- more for our use afterwards since we can't rely on its special
- pre-allocated keys anymore. So we have to allocate a new one. */
- cpu_log = profiler_cpu_running ? make_log () : Qnil;
- Fputhash (make_vector (1, QAutomatic_GC),
- make_fixnum (cpu_gc_count),
- result);
- cpu_gc_count = 0;
- return result;
+ /* Temporarily stop profiling to avoid it interfering with our data
+ access. */
+ bool prof_cpu = profiler_cpu_running;
+ if (prof_cpu)
+ Fprofiler_cpu_stop ();
+
+ Lisp_Object ret = export_log (&cpu);
+
+ if (prof_cpu)
+ Fprofiler_cpu_start (profiler_cpu_interval);
+
+ return ret;
}
#endif /* PROFILER_CPU_SUPPORT */
+
+/* Extract log data to a Lisp hash table. The log data is then erased. */
+static Lisp_Object
+export_log (struct profiler_log *plog)
+{
+ log_t *log = plog->log;
+ /* The returned hash table uses `equal' as key equivalence predicate
+ which is more discriminating than the `function-equal' used by
+ the log but close enough, and will never confuse two distinct
+ keys in the log. */
+ Lisp_Object h = make_hash_table (&hashtest_equal, DEFAULT_HASH_SIZE,
+ Weak_None, false);
+ for (int i = 0; i < log->size; i++)
+ {
+ int count = get_log_count (log, i);
+ if (count > 0)
+ Fputhash (Fvector (log->depth, get_key_vector (log, i)),
+ make_fixnum (count), h);
+ }
+ if (plog->gc_count)
+ Fputhash (CALLN (Fvector, QAutomatic_GC, Qnil),
+ make_fixnum (plog->gc_count),
+ h);
+ if (plog->discarded)
+ Fputhash (CALLN (Fvector, QDiscarded_Samples, Qnil),
+ make_fixnum (plog->discarded),
+ h);
+ free_profiler_log (plog);
+ return h;
+}
/* Memory profiler. */
+/* Hash-table log of Memory profiler. */
+static struct profiler_log memory;
+
/* True if memory profiler is running. */
bool profiler_memory_running;
-static Lisp_Object memory_log;
-
DEFUN ("profiler-memory-start", Fprofiler_memory_start, Sprofiler_memory_start,
0, 0, 0,
doc: /* Start/restart the memory profiler.
@@ -450,8 +604,8 @@ See also `profiler-log-size' and `profiler-max-stack-depth'. */)
if (profiler_memory_running)
error ("Memory profiler is already running");
- if (NILP (memory_log))
- memory_log = make_log ();
+ if (memory.log == NULL)
+ memory = make_profiler_log ();
profiler_memory_running = true;
@@ -490,12 +644,16 @@ of functions, where the last few elements may be nil.
Before returning, a new log is allocated for future samples. */)
(void)
{
- Lisp_Object result = memory_log;
- /* Here we're making the log visible to Elisp , so it's not safe any
- more for our use afterwards since we can't rely on its special
- pre-allocated keys anymore. So we have to allocate a new one. */
- memory_log = profiler_memory_running ? make_log () : Qnil;
- return result;
+ bool prof_mem = profiler_memory_running;
+ if (prof_mem)
+ Fprofiler_memory_stop ();
+
+ Lisp_Object ret = export_log (&memory);
+
+ if (prof_mem)
+ Fprofiler_memory_start ();
+
+ return ret;
}
@@ -505,11 +663,7 @@ Before returning, a new log is allocated for future samples. */)
void
malloc_probe (size_t size)
{
- if (EQ (backtrace_top_function (), QAutomatic_GC)) /* bug#60237 */
- /* FIXME: We should do something like what we did with `cpu_gc_count`. */
- return;
- eassert (HASH_TABLE_P (memory_log));
- record_backtrace (XHASH_TABLE (memory_log), min (size, MOST_POSITIVE_FIXNUM));
+ add_sample (&memory, min (size, MOST_POSITIVE_FIXNUM));
}
DEFUN ("function-equal", Ffunction_equal, Sfunction_equal, 2, 2, 0,
@@ -532,50 +686,15 @@ the same lambda expression, or are really unrelated function. */)
return res ? Qt : Qnil;
}
-static Lisp_Object
-cmpfn_profiler (Lisp_Object bt1, Lisp_Object bt2, struct Lisp_Hash_Table *h)
-{
- if (EQ (bt1, bt2))
- return Qt;
- else if (VECTORP (bt1) && VECTORP (bt2))
- {
- ptrdiff_t l = ASIZE (bt1);
- if (l != ASIZE (bt2))
- return Qnil;
- for (ptrdiff_t i = 0; i < l; i++)
- if (NILP (Ffunction_equal (AREF (bt1, i), AREF (bt2, i))))
- return Qnil;
- return Qt;
- }
- else
- return Qnil;
-}
-
-static Lisp_Object
-hashfn_profiler (Lisp_Object bt, struct Lisp_Hash_Table *h)
+void
+mark_profiler (void)
{
- EMACS_UINT hash;
- if (VECTORP (bt))
- {
- hash = 0;
- ptrdiff_t l = ASIZE (bt);
- for (ptrdiff_t i = 0; i < l; i++)
- {
- Lisp_Object f = AREF (bt, i);
- EMACS_UINT hash1
- = (COMPILEDP (f) ? XHASH (AREF (f, COMPILED_BYTECODE))
- : (CONSP (f) && CONSP (XCDR (f)) && EQ (Qclosure, XCAR (f)))
- ? XHASH (XCDR (XCDR (f))) : XHASH (f));
- hash = sxhash_combine (hash, hash1);
- }
- }
- else
- hash = XHASH (bt);
- return make_ufixnum (SXHASH_REDUCE (hash));
+#ifdef PROFILER_CPU_SUPPORT
+ mark_log (cpu.log);
+#endif
+ mark_log (memory.log);
}
-static void syms_of_profiler_for_pdumper (void);
-
void
syms_of_profiler (void)
{
@@ -588,46 +707,20 @@ If the log gets full, some of the least-seen call-stacks will be evicted
to make room for new entries. */);
profiler_log_size = 10000;
- DEFSYM (Qprofiler_backtrace_equal, "profiler-backtrace-equal");
+ DEFSYM (QDiscarded_Samples, "Discarded Samples");
defsubr (&Sfunction_equal);
#ifdef PROFILER_CPU_SUPPORT
profiler_cpu_running = NOT_RUNNING;
- cpu_log = Qnil;
- staticpro (&cpu_log);
defsubr (&Sprofiler_cpu_start);
defsubr (&Sprofiler_cpu_stop);
defsubr (&Sprofiler_cpu_running_p);
defsubr (&Sprofiler_cpu_log);
#endif
profiler_memory_running = false;
- memory_log = Qnil;
- staticpro (&memory_log);
defsubr (&Sprofiler_memory_start);
defsubr (&Sprofiler_memory_stop);
defsubr (&Sprofiler_memory_running_p);
defsubr (&Sprofiler_memory_log);
-
- pdumper_do_now_and_after_load (syms_of_profiler_for_pdumper);
-}
-
-static void
-syms_of_profiler_for_pdumper (void)
-{
- if (dumped_with_pdumper_p ())
- {
-#ifdef PROFILER_CPU_SUPPORT
- cpu_log = Qnil;
-#endif
- memory_log = Qnil;
- }
- else
- {
-#ifdef PROFILER_CPU_SUPPORT
- eassert (NILP (cpu_log));
-#endif
- eassert (NILP (memory_log));
- }
-
}
diff --git a/src/puresize.h b/src/puresize.h
index ac5d2da30dc..2a716872832 100644
--- a/src/puresize.h
+++ b/src/puresize.h
@@ -47,7 +47,7 @@ INLINE_HEADER_BEGIN
#endif
#ifndef BASE_PURESIZE
-#define BASE_PURESIZE (2750000 + SYSTEM_PURESIZE_EXTRA + SITELOAD_PURESIZE_EXTRA)
+#define BASE_PURESIZE (3000000 + SYSTEM_PURESIZE_EXTRA + SITELOAD_PURESIZE_EXTRA)
#endif
/* Increase BASE_PURESIZE by a ratio depending on the machine's word size. */
diff --git a/src/regex-emacs.c b/src/regex-emacs.c
index f4fe93210f7..0ec0c6eb63f 100644
--- a/src/regex-emacs.c
+++ b/src/regex-emacs.c
@@ -47,12 +47,8 @@
/* Make syntax table lookup grant data in gl_state. */
#define SYNTAX(c) syntax_property (c, 1)
-/* Convert the pointer to the char to BEG-based offset from the start. */
-#define PTR_TO_OFFSET(d) POS_AS_IN_BUFFER (POINTER_TO_OFFSET (d))
-/* Strings are 0-indexed, buffers are 1-indexed; pun on the boolean
- result to get the right base index. */
-#define POS_AS_IN_BUFFER(p) \
- ((p) + (NILP (gl_state.object) || BUFFERP (gl_state.object)))
+/* Explicit syntax lookup using the buffer-local table. */
+#define BUFFER_SYNTAX(c) syntax_property (c, 0)
#define RE_MULTIBYTE_P(bufp) ((bufp)->multibyte)
#define RE_TARGET_MULTIBYTE_P(bufp) ((bufp)->target_multibyte)
@@ -103,7 +99,7 @@
#define IS_REAL_ASCII(c) ((c) < 0200)
/* 1 if C is a unibyte character. */
-#define ISUNIBYTE(c) (SINGLE_BYTE_CHAR_P ((c)))
+#define ISUNIBYTE(c) SINGLE_BYTE_CHAR_P (c)
/* The Emacs definitions should not be directly affected by locales. */
@@ -139,18 +135,22 @@
#define ISLOWER(c) lowercasep (c)
+#define ISUPPER(c) uppercasep (c)
+
+/* The following predicates use the buffer-local syntax table and
+ ignore syntax properties, for consistency with the up-front
+ assumptions made at compile time. */
+
#define ISPUNCT(c) (IS_REAL_ASCII (c) \
? ((c) > ' ' && (c) < 0177 \
&& !(((c) >= 'a' && (c) <= 'z') \
|| ((c) >= 'A' && (c) <= 'Z') \
|| ((c) >= '0' && (c) <= '9'))) \
- : SYNTAX (c) != Sword)
+ : BUFFER_SYNTAX (c) != Sword)
-#define ISSPACE(c) (SYNTAX (c) == Swhitespace)
+#define ISSPACE(c) (BUFFER_SYNTAX (c) == Swhitespace)
-#define ISUPPER(c) uppercasep (c)
-
-#define ISWORD(c) (SYNTAX (c) == Sword)
+#define ISWORD(c) (BUFFER_SYNTAX (c) == Sword)
/* Use alloca instead of malloc. This is because using malloc in
re_search* or re_match* could cause memory leaks when C-g is used
@@ -268,7 +268,9 @@ typedef enum
on_failure_jump,
/* Like on_failure_jump, but pushes a placeholder instead of the
- current string position when executed. */
+ current string position when executed. Upon failure,
+ the current string position is thus not restored.
+ Used only for single-char loops that don't require backtracking. */
on_failure_keep_string_jump,
/* Just like 'on_failure_jump', except that it checks that we
@@ -338,11 +340,12 @@ typedef enum
/* Store NUMBER in two contiguous bytes starting at DESTINATION. */
-#define STORE_NUMBER(destination, number) \
- do { \
- (destination)[0] = (number) & 0377; \
- (destination)[1] = (number) >> 8; \
- } while (false)
+static void
+STORE_NUMBER (unsigned char *destination, int16_t number)
+{
+ (destination)[0] = (number) & 0377;
+ (destination)[1] = (number) >> 8;
+}
/* Same as STORE_NUMBER, except increment DESTINATION to
the byte after where the number is stored. Therefore, DESTINATION
@@ -367,6 +370,12 @@ extract_number (re_char *source)
return leading_byte * 256 + source[0];
}
+static re_char *
+extract_address (re_char *source)
+{
+ return source + 2 + extract_number (source);
+}
+
/* Same as EXTRACT_NUMBER, except increment SOURCE to after the number.
SOURCE must be an lvalue. */
@@ -434,38 +443,27 @@ extract_number_and_incr (re_char **source)
/* If REGEX_EMACS_DEBUG is defined, print many voluminous messages
(if the variable regex_emacs_debug is positive). */
-#ifdef REGEX_EMACS_DEBUG
+#if defined REGEX_EMACS_DEBUG || ENABLE_CHECKING
/* Use standard I/O for debugging. */
# include "sysstdio.h"
-static int regex_emacs_debug = -100000;
-
-# define DEBUG_STATEMENT(e) e
-# define DEBUG_PRINT(...) \
- if (regex_emacs_debug > 0) fprintf (stderr, __VA_ARGS__)
-# define DEBUG_COMPILES_ARGUMENTS
-# define DEBUG_PRINT_COMPILED_PATTERN(p, s, e) \
- if (regex_emacs_debug > 0) print_partial_compiled_pattern (s, e)
-# define DEBUG_PRINT_DOUBLE_STRING(w, s1, sz1, s2, sz2) \
- if (regex_emacs_debug > 0) print_double_string (w, s1, sz1, s2, sz2)
-
static void
-debug_putchar (int c)
+debug_putchar (FILE *dest, int c)
{
if (c >= 32 && c <= 126)
- putc (c, stderr);
+ putc (c, dest);
else
{
unsigned int uc = c;
- fprintf (stderr, "{%02x}", uc);
+ fprintf (dest, "{%02x}", uc);
}
}
/* Print the fastmap in human-readable form. */
static void
-print_fastmap (char *fastmap)
+print_fastmap (FILE *dest, char *fastmap)
{
bool was_a_range = false;
int i = 0;
@@ -475,7 +473,7 @@ print_fastmap (char *fastmap)
if (fastmap[i++])
{
was_a_range = false;
- debug_putchar (i - 1);
+ debug_putchar (dest, i - 1);
while (i < (1 << BYTEWIDTH) && fastmap[i])
{
was_a_range = true;
@@ -483,12 +481,12 @@ print_fastmap (char *fastmap)
}
if (was_a_range)
{
- debug_putchar ('-');
- debug_putchar (i - 1);
+ debug_putchar (dest, '-');
+ debug_putchar (dest, i - 1);
}
}
}
- putc ('\n', stderr);
+ putc ('\n', dest);
}
@@ -496,7 +494,7 @@ print_fastmap (char *fastmap)
the START pointer into it and ending just before the pointer END. */
static void
-print_partial_compiled_pattern (re_char *start, re_char *end)
+print_partial_compiled_pattern (FILE *dest, re_char *start, re_char *end)
{
int mcnt, mcnt2;
re_char *p = start;
@@ -504,50 +502,50 @@ print_partial_compiled_pattern (re_char *start, re_char *end)
if (start == NULL)
{
- fputs ("(null)\n", stderr);
+ fputs ("(null)\n", dest);
return;
}
/* Loop over pattern commands. */
while (p < pend)
{
- fprintf (stderr, "%td:\t", p - start);
+ fprintf (dest, "%td:\t", p - start);
switch ((re_opcode_t) *p++)
{
case no_op:
- fputs ("/no_op", stderr);
+ fputs ("/no_op", dest);
break;
case succeed:
- fputs ("/succeed", stderr);
+ fputs ("/succeed", dest);
break;
case exactn:
mcnt = *p++;
- fprintf (stderr, "/exactn/%d", mcnt);
+ fprintf (dest, "/exactn/%d", mcnt);
do
{
- debug_putchar ('/');
- debug_putchar (*p++);
+ debug_putchar (dest, '/');
+ debug_putchar (dest, *p++);
}
while (--mcnt);
break;
case start_memory:
- fprintf (stderr, "/start_memory/%d", *p++);
+ fprintf (dest, "/start_memory/%d", *p++);
break;
case stop_memory:
- fprintf (stderr, "/stop_memory/%d", *p++);
+ fprintf (dest, "/stop_memory/%d", *p++);
break;
case duplicate:
- fprintf (stderr, "/duplicate/%d", *p++);
+ fprintf (dest, "/duplicate/%d", *p++);
break;
case anychar:
- fputs ("/anychar", stderr);
+ fputs ("/anychar", dest);
break;
case charset:
@@ -558,11 +556,11 @@ print_partial_compiled_pattern (re_char *start, re_char *end)
int length = CHARSET_BITMAP_SIZE (p - 1);
bool has_range_table = CHARSET_RANGE_TABLE_EXISTS_P (p - 1);
- fprintf (stderr, "/charset [%s",
+ fprintf (dest, "/charset [%s",
(re_opcode_t) *(p - 1) == charset_not ? "^" : "");
- if (p + *p >= pend)
- fputs (" !extends past end of pattern! ", stderr);
+ if (p + (*p & 0x7f) >= pend)
+ fputs (" !extends past end of pattern! ", dest);
for (c = 0; c < 256; c++)
if (c / 8 < length
@@ -571,33 +569,33 @@ print_partial_compiled_pattern (re_char *start, re_char *end)
/* Are we starting a range? */
if (last + 1 == c && ! in_range)
{
- debug_putchar ('-');
+ debug_putchar (dest, '-');
in_range = true;
}
/* Have we broken a range? */
else if (last + 1 != c && in_range)
{
- debug_putchar (last);
+ debug_putchar (dest, last);
in_range = false;
}
if (! in_range)
- debug_putchar (c);
+ debug_putchar (dest, c);
last = c;
}
if (in_range)
- debug_putchar (last);
+ debug_putchar (dest, last);
- debug_putchar (']');
+ debug_putchar (dest, ']');
p += 1 + length;
if (has_range_table)
{
int count;
- fputs ("has-range-table", stderr);
+ fputs ("has-range-table", dest);
/* ??? Should print the range table; for now, just skip it. */
p += 2; /* skip range table bits */
@@ -608,160 +606,175 @@ print_partial_compiled_pattern (re_char *start, re_char *end)
break;
case begline:
- fputs ("/begline", stderr);
+ fputs ("/begline", dest);
break;
case endline:
- fputs ("/endline", stderr);
+ fputs ("/endline", dest);
break;
case on_failure_jump:
EXTRACT_NUMBER_AND_INCR (mcnt, p);
- fprintf (stderr, "/on_failure_jump to %td", p + mcnt - start);
+ fprintf (dest, "/on_failure_jump to %td", p + mcnt - start);
break;
case on_failure_keep_string_jump:
EXTRACT_NUMBER_AND_INCR (mcnt, p);
- fprintf (stderr, "/on_failure_keep_string_jump to %td",
+ fprintf (dest, "/on_failure_keep_string_jump to %td",
p + mcnt - start);
break;
case on_failure_jump_nastyloop:
EXTRACT_NUMBER_AND_INCR (mcnt, p);
- fprintf (stderr, "/on_failure_jump_nastyloop to %td",
+ fprintf (dest, "/on_failure_jump_nastyloop to %td",
p + mcnt - start);
break;
case on_failure_jump_loop:
EXTRACT_NUMBER_AND_INCR (mcnt, p);
- fprintf (stderr, "/on_failure_jump_loop to %td",
+ fprintf (dest, "/on_failure_jump_loop to %td",
p + mcnt - start);
break;
case on_failure_jump_smart:
EXTRACT_NUMBER_AND_INCR (mcnt, p);
- fprintf (stderr, "/on_failure_jump_smart to %td",
+ fprintf (dest, "/on_failure_jump_smart to %td",
p + mcnt - start);
break;
case jump:
EXTRACT_NUMBER_AND_INCR (mcnt, p);
- fprintf (stderr, "/jump to %td", p + mcnt - start);
+ fprintf (dest, "/jump to %td", p + mcnt - start);
break;
case succeed_n:
EXTRACT_NUMBER_AND_INCR (mcnt, p);
EXTRACT_NUMBER_AND_INCR (mcnt2, p);
- fprintf (stderr, "/succeed_n to %td, %d times",
+ fprintf (dest, "/succeed_n to %td, %d times",
p - 2 + mcnt - start, mcnt2);
break;
case jump_n:
EXTRACT_NUMBER_AND_INCR (mcnt, p);
EXTRACT_NUMBER_AND_INCR (mcnt2, p);
- fprintf (stderr, "/jump_n to %td, %d times",
+ fprintf (dest, "/jump_n to %td, %d times",
p - 2 + mcnt - start, mcnt2);
break;
case set_number_at:
EXTRACT_NUMBER_AND_INCR (mcnt, p);
EXTRACT_NUMBER_AND_INCR (mcnt2, p);
- fprintf (stderr, "/set_number_at location %td to %d",
+ fprintf (dest, "/set_number_at location %td to %d",
p - 2 + mcnt - start, mcnt2);
break;
case wordbound:
- fputs ("/wordbound", stderr);
+ fputs ("/wordbound", dest);
break;
case notwordbound:
- fputs ("/notwordbound", stderr);
+ fputs ("/notwordbound", dest);
break;
case wordbeg:
- fputs ("/wordbeg", stderr);
+ fputs ("/wordbeg", dest);
break;
case wordend:
- fputs ("/wordend", stderr);
+ fputs ("/wordend", dest);
break;
case symbeg:
- fputs ("/symbeg", stderr);
+ fputs ("/symbeg", dest);
break;
case symend:
- fputs ("/symend", stderr);
+ fputs ("/symend", dest);
break;
case syntaxspec:
- fputs ("/syntaxspec", stderr);
+ fputs ("/syntaxspec", dest);
mcnt = *p++;
- fprintf (stderr, "/%d", mcnt);
+ fprintf (dest, "/%d", mcnt);
break;
case notsyntaxspec:
- fputs ("/notsyntaxspec", stderr);
+ fputs ("/notsyntaxspec", dest);
mcnt = *p++;
- fprintf (stderr, "/%d", mcnt);
+ fprintf (dest, "/%d", mcnt);
break;
case at_dot:
- fputs ("/at_dot", stderr);
+ fputs ("/at_dot", dest);
break;
case categoryspec:
- fputs ("/categoryspec", stderr);
+ fputs ("/categoryspec", dest);
mcnt = *p++;
- fprintf (stderr, "/%d", mcnt);
+ fprintf (dest, "/%d", mcnt);
break;
case notcategoryspec:
- fputs ("/notcategoryspec", stderr);
+ fputs ("/notcategoryspec", dest);
mcnt = *p++;
- fprintf (stderr, "/%d", mcnt);
+ fprintf (dest, "/%d", mcnt);
break;
case begbuf:
- fputs ("/begbuf", stderr);
+ fputs ("/begbuf", dest);
break;
case endbuf:
- fputs ("/endbuf", stderr);
+ fputs ("/endbuf", dest);
break;
default:
- fprintf (stderr, "?%d", *(p-1));
+ fprintf (dest, "?%d", *(p-1));
}
- putc ('\n', stderr);
+ putc ('\n', dest);
}
- fprintf (stderr, "%td:\tend of pattern.\n", p - start);
+ fprintf (dest, "%td:\tend of pattern.\n", p - start);
}
-
-static void
-print_compiled_pattern (struct re_pattern_buffer *bufp)
+void
+print_compiled_pattern (FILE *dest, struct re_pattern_buffer *bufp)
{
+ if (!dest)
+ dest = stderr;
re_char *buffer = bufp->buffer;
- print_partial_compiled_pattern (buffer, buffer + bufp->used);
- fprintf (stderr, "%td bytes used/%td bytes allocated.\n",
+ print_partial_compiled_pattern (dest, buffer, buffer + bufp->used);
+ fprintf (dest, "%td bytes used/%td bytes allocated.\n",
bufp->used, bufp->allocated);
if (bufp->fastmap_accurate && bufp->fastmap)
{
- fputs ("fastmap: ", stderr);
- print_fastmap (bufp->fastmap);
+ fputs ("fastmap: ", dest);
+ print_fastmap (dest, bufp->fastmap);
}
- fprintf (stderr, "re_nsub: %td\t", bufp->re_nsub);
- fprintf (stderr, "regs_alloc: %d\t", bufp->regs_allocated);
- fprintf (stderr, "can_be_null: %d\n", bufp->can_be_null);
+ fprintf (dest, "re_nsub: %td\t", bufp->re_nsub);
+ fprintf (dest, "regs_alloc: %d\t", bufp->regs_allocated);
+ fprintf (dest, "can_be_null: %d\n", bufp->can_be_null);
/* Perhaps we should print the translate table? */
}
+#endif
+
+#ifdef REGEX_EMACS_DEBUG
+
+static int regex_emacs_debug = -100000;
+
+# define DEBUG_STATEMENT(e) e
+# define DEBUG_PRINT(...) \
+ if (regex_emacs_debug > 0) fprintf (stderr, __VA_ARGS__)
+# define DEBUG_COMPILES_ARGUMENTS
+# define DEBUG_PRINT_COMPILED_PATTERN(p, s, e) \
+ if (regex_emacs_debug > 0) print_partial_compiled_pattern (stderr, s, e)
+# define DEBUG_PRINT_DOUBLE_STRING(w, s1, sz1, s2, sz2) \
+ if (regex_emacs_debug > 0) print_double_string (w, s1, sz1, s2, sz2)
static void
print_double_string (re_char *where, re_char *string1, ptrdiff_t size1,
@@ -775,12 +788,12 @@ print_double_string (re_char *where, re_char *string1, ptrdiff_t size1,
if (FIRST_STRING_P (where))
{
for (i = 0; i < string1 + size1 - where; i++)
- debug_putchar (where[i]);
+ debug_putchar (stderr, where[i]);
where = string2;
}
for (i = 0; i < string2 + size2 - where; i++)
- debug_putchar (where[i]);
+ debug_putchar (stderr, where[i]);
}
}
@@ -1166,8 +1179,8 @@ static void insert_op2 (re_opcode_t op, unsigned char *loc,
static bool at_begline_loc_p (re_char *pattern, re_char *p);
static bool at_endline_loc_p (re_char *p, re_char *pend);
static re_char *skip_one_char (re_char *p);
-static int analyze_first (re_char *p, re_char *pend,
- char *fastmap, bool multibyte);
+static bool analyze_first (struct re_pattern_buffer *bufp,
+ re_char *p, re_char *pend, char *fastmap);
/* Fetch the next character in the uncompiled pattern, with no
translation. */
@@ -1332,7 +1345,7 @@ struct range_table_work_area
/* Set a range (RANGE_START, RANGE_END) to WORK_AREA. */
#define SET_RANGE_TABLE_WORK_AREA(work_area, range_start, range_end) \
do { \
- EXTEND_RANGE_TABLE ((work_area), 2); \
+ EXTEND_RANGE_TABLE (work_area, 2); \
(work_area).table[(work_area).used++] = (range_start); \
(work_area).table[(work_area).used++] = (range_end); \
} while (false)
@@ -1367,7 +1380,7 @@ struct range_table_work_area
/* Set the bit for character C in a list. */
-#define SET_LIST_BIT(c) (b[((c)) / BYTEWIDTH] |= 1 << ((c) % BYTEWIDTH))
+#define SET_LIST_BIT(c) (b[(c) / BYTEWIDTH] |= 1 << ((c) % BYTEWIDTH))
/* Store characters in the range FROM to TO in the bitmap at B (for
@@ -1390,7 +1403,7 @@ struct range_table_work_area
C1 = TRANSLATE (C0); \
if (! ASCII_CHAR_P (C1)) \
{ \
- SET_RANGE_TABLE_WORK_AREA ((work_area), C1, C1); \
+ SET_RANGE_TABLE_WORK_AREA (work_area, C1, C1); \
if ((C1 = RE_CHAR_TO_UNIBYTE (C1)) < 0) \
C1 = C0; \
} \
@@ -1433,7 +1446,7 @@ struct range_table_work_area
} \
} \
if (I < USED) \
- SET_RANGE_TABLE_WORK_AREA ((work_area), C2, C2); \
+ SET_RANGE_TABLE_WORK_AREA (work_area, C2, C2); \
} \
} \
} while (false)
@@ -1445,7 +1458,7 @@ struct range_table_work_area
do { \
int C0, C1, C2, I, USED = RANGE_TABLE_WORK_USED (work_area); \
\
- SET_RANGE_TABLE_WORK_AREA ((work_area), (FROM), (TO)); \
+ SET_RANGE_TABLE_WORK_AREA (work_area, FROM, TO); \
for (C0 = (FROM); C0 <= (TO); C0++) \
{ \
C1 = TRANSLATE (C0); \
@@ -1469,7 +1482,7 @@ struct range_table_work_area
} \
} \
if (I < USED) \
- SET_RANGE_TABLE_WORK_AREA ((work_area), C1, C1); \
+ SET_RANGE_TABLE_WORK_AREA (work_area, C1, C1); \
} \
} while (false)
@@ -1723,7 +1736,8 @@ regex_compile (re_char *pattern, ptrdiff_t size,
/* Address of start of the most recently finished expression.
This tells, e.g., postfix * where to find the start of its
- operand. Reset at the beginning of groups and alternatives. */
+ operand. Reset at the beginning of groups and alternatives,
+ and after ^ and \` for dusty-deck compatibility. */
unsigned char *laststart = 0;
/* Address of beginning of regexp, or inside of last group. */
@@ -1759,7 +1773,7 @@ regex_compile (re_char *pattern, ptrdiff_t size,
if (regex_emacs_debug > 0)
{
for (ptrdiff_t debug_count = 0; debug_count < size; debug_count++)
- debug_putchar (pattern[debug_count]);
+ debug_putchar (stderr, pattern[debug_count]);
putc ('\n', stderr);
}
#endif
@@ -1854,12 +1868,16 @@ regex_compile (re_char *pattern, ptrdiff_t size,
case '^':
if (! (p == pattern + 1 || at_begline_loc_p (pattern, p)))
goto normal_char;
+ /* Special case for compatibility: postfix ops after ^ become
+ literals. */
+ laststart = 0;
BUF_PUSH (begline);
break;
case '$':
if (! (p == pend || at_endline_loc_p (p, pend)))
goto normal_char;
+ laststart = b;
BUF_PUSH (endline);
break;
@@ -1899,7 +1917,7 @@ regex_compile (re_char *pattern, ptrdiff_t size,
/* Star, etc. applied to an empty pattern is equivalent
to an empty pattern. */
- if (!laststart || laststart == b)
+ if (laststart == b)
break;
/* Now we know whether or not zero matches is allowed
@@ -1912,18 +1930,28 @@ regex_compile (re_char *pattern, ptrdiff_t size,
ptrdiff_t startoffset = 0;
re_opcode_t ofj =
/* Check if the loop can match the empty string. */
- (simple || !analyze_first (laststart, b, NULL, false))
+ (simple || !analyze_first (bufp, laststart, b, NULL))
? on_failure_jump : on_failure_jump_loop;
eassert (skip_one_char (laststart) <= b);
if (!zero_times_ok && simple)
{ /* Since simple * loops can be made faster by using
- on_failure_keep_string_jump, we turn simple P+
- into PP* if P is simple. */
+ on_failure_keep_string_jump, we turn P+ into PP*
+ if P is simple.
+ We can't use `top: <BODY>; OFJS exit; J top; exit:`
+ because the OFJS needs to be at the beginning
+ so we can replace
+ top: OFJS exit; <BODY>; J top; exit
+ with
+ OFKSJ exit; loop: <BODY>; J loop; exit
+ i.e. a single OFJ at the beginning of the loop
+ rather than once per iteration. */
unsigned char *p1, *p2;
startoffset = b - laststart;
GET_BUFFER_SPACE (startoffset);
p1 = b; p2 = laststart;
+ /* We presume that the code skipped
+ by `skip_one_char` is position-independent. */
while (p2 < p1)
*b++ = *p2++;
zero_times_ok = 1;
@@ -1959,7 +1987,7 @@ regex_compile (re_char *pattern, ptrdiff_t size,
GET_BUFFER_SPACE (7); /* We might use less. */
if (many_times_ok)
{
- bool emptyp = !!analyze_first (laststart, b, NULL, false);
+ bool emptyp = analyze_first (bufp, laststart, b, NULL);
/* The non-greedy multiple match looks like
a repeat..until: we only need a conditional jump
@@ -2050,13 +2078,6 @@ regex_compile (re_char *pattern, ptrdiff_t size,
is_xdigit, since they can only match ASCII characters.
We don't need to handle them for multibyte. */
- /* Setup the gl_state object to its buffer-defined value.
- This hardcodes the buffer-global syntax-table for ASCII
- chars, while the other chars will obey syntax-table
- properties. It's not ideal, but it's the way it's been
- done until now. */
- SETUP_BUFFER_SYNTAX_TABLE ();
-
for (c = 0; c < 0x80; ++c)
if (re_iswctype (c, cc))
{
@@ -2209,9 +2230,8 @@ regex_compile (re_char *pattern, ptrdiff_t size,
FALLTHROUGH;
case '1': case '2': case '3': case '4':
case '5': case '6': case '7': case '8': case '9':
- if (INT_MULTIPLY_WRAPV (regnum, 10, &regnum)
- || INT_ADD_WRAPV (regnum, c - '0',
- &regnum))
+ if (ckd_mul (&regnum, regnum, 10)
+ || ckd_add (&regnum, regnum, c - '0'))
FREE_STACK_RETURN (REG_ESIZE);
break;
default:
@@ -2552,18 +2572,24 @@ regex_compile (re_char *pattern, ptrdiff_t size,
break;
case 'b':
+ laststart = b;
BUF_PUSH (wordbound);
break;
case 'B':
+ laststart = b;
BUF_PUSH (notwordbound);
break;
case '`':
+ /* Special case for compatibility: postfix ops after \` become
+ literals, as for ^ (see above). */
+ laststart = 0;
BUF_PUSH (begbuf);
break;
case '\'':
+ laststart = b;
BUF_PUSH (endbuf);
break;
@@ -2605,7 +2631,7 @@ regex_compile (re_char *pattern, ptrdiff_t size,
/* If followed by a repetition operator. */
|| (p != pend
- && (*p == '*' || *p == '+' || *p == '?' || *p == '^'))
+ && (*p == '*' || *p == '+' || *p == '?'))
|| (p + 1 < pend && p[0] == '\\' && p[1] == '{'))
{
/* Start building a new exactn. */
@@ -2667,7 +2693,7 @@ regex_compile (re_char *pattern, ptrdiff_t size,
{
re_compile_fastmap (bufp);
DEBUG_PRINT ("\nCompiled pattern:\n");
- print_compiled_pattern (bufp);
+ print_compiled_pattern (stderr, bufp);
}
regex_emacs_debug--;
#endif
@@ -2796,309 +2822,486 @@ group_in_compile_stack (compile_stack_type compile_stack, regnum_t regnum)
return false;
}
-/* analyze_first.
- If fastmap is non-NULL, go through the pattern and fill fastmap
- with all the possible leading chars. If fastmap is NULL, don't
- bother filling it up (obviously) and only return whether the
- pattern could potentially match the empty string.
+/* Iterate through all the char-matching operations directly reachable from P.
+ This is the inner loop of `forall_firstchar`, which see.
+ LOOP_BEG..LOOP_END delimit the currently "block" of code (we assume
+ the code is made of syntactically nested loops).
+ LOOP_END is blindly assumed to be "safe".
+ To guarantee termination, at each iteration, either LOOP_BEG should
+ get bigger, or it should stay the same and P should get bigger. */
+static bool
+forall_firstchar_1 (re_char *p, re_char *pend,
+ re_char *loop_beg, re_char *loop_end,
+ bool f (const re_char *p, void *arg), void *arg)
+{
+ eassert (p >= loop_beg);
+ eassert (p <= loop_end);
- Return 1 if p..pend might match the empty string.
- Return 0 if p..pend matches at least one char.
- Return -1 if fastmap was not updated accurately. */
+ while (true)
+ {
+ re_char *newp1, *newp2, *tmp;
+ re_char *p_orig = p;
+ int offset;
-static int
-analyze_first (re_char *p, re_char *pend, char *fastmap, bool multibyte)
-{
- int j, k;
- int nbits;
- bool not;
+ if (p == pend)
+ return false;
+ else if (p == loop_end)
+ return true;
+ else if (p > loop_end)
+ {
+#if ENABLE_CHECKING
+ fprintf (stderr, "FORALL_FIRSTCHAR: Broken assumption1!!\n");
+#endif
+ return false; /* FIXME: Broken assumption about the code shape. */
+ }
+ else
+ switch (*p)
+ {
+ case no_op:
+ p++; continue;
+
+ /* Cases which stop the iteration. */
+ case succeed:
+ case exactn:
+ case charset:
+ case charset_not:
+ case anychar:
+ case syntaxspec:
+ case notsyntaxspec:
+ case categoryspec:
+ case notcategoryspec:
+ return f (p, arg);
+
+ /* Cases which may match the empty string. */
+ case at_dot:
+ case begbuf:
+ case wordbound:
+ case notwordbound:
+ case begline:
+ case endline:
+ case endbuf:
+ case wordbeg:
+ case wordend:
+ case symbeg:
+ case symend:
+ if (f (p, arg))
+ return true;
+ p++;
+ continue;
+
+ case jump:
+ case jump_n:
+ newp1 = extract_address (p + 1);
+ if (newp1 > p)
+ { /* Forward jump, boring. */
+ p = newp1;
+ continue;
+ }
+ switch (*newp1)
+ {
+ case on_failure_jump:
+ case on_failure_keep_string_jump:
+ case on_failure_jump_nastyloop:
+ case on_failure_jump_loop:
+ case on_failure_jump_smart:
+ case succeed_n:
+ newp2 = extract_address (newp1 + 1);
+ goto do_twoway_jump;
+ default:
+ newp2 = loop_end; /* "Safe" choice. */
+ goto do_jump;
+ }
- /* If all elements for base leading-codes in fastmap is set, this
- flag is set true. */
- bool match_any_multibyte_characters = false;
-
- eassert (p);
-
- /* The loop below works as follows:
- - It has a working-list kept in the PATTERN_STACK and which basically
- starts by only containing a pointer to the first operation.
- - If the opcode we're looking at is a match against some set of
- chars, then we add those chars to the fastmap and go on to the
- next work element from the worklist (done via 'break').
- - If the opcode is a control operator on the other hand, we either
- ignore it (if it's meaningless at this point, such as 'start_memory')
- or execute it (if it's a jump). If the jump has several destinations
- (i.e. 'on_failure_jump'), then we push the other destination onto the
- worklist.
- We guarantee termination by ignoring backward jumps (more or less),
- so that P is monotonically increasing. More to the point, we
- never set P (or push) anything '<= p1'. */
+ case on_failure_jump:
+ case on_failure_keep_string_jump:
+ case on_failure_jump_nastyloop:
+ case on_failure_jump_loop:
+ case on_failure_jump_smart:
+ newp1 = extract_address (p + 1);
+ newp2 = p + 3;
+ /* For `+` loops, we often have an `on_failure_jump` that skips
+ forward over a subsequent `jump`. Recognize this pattern
+ since that subsequent `jump` is the one that jumps to the
+ loop-entry. */
+ if ((re_opcode_t) *newp2 == jump)
+ {
+ re_char *p3 = extract_address (newp2 + 1);
+ /* Only recognize this pattern if one of the two destinations
+ is going forward, otherwise we'll fall into the pessimistic
+ "Both destinations go backward" below.
+ This is important if the `jump` at newp2 is the end of an
+ outer loop while the `on_failure_jump` is the end of an
+ inner loop. */
+ if (p3 > p_orig || newp1 > p_orig)
+ newp2 = p3;
+ }
- while (p < pend)
- {
- /* P1 is used as a marker of how far back a 'on_failure_jump'
- can go without being ignored. It is normally equal to P
- (which prevents any backward 'on_failure_jump') except right
- after a plain 'jump', to allow patterns such as:
- 0: jump 10
- 3..9: <body>
- 10: on_failure_jump 3
- as used for the *? operator. */
- re_char *p1 = p;
+ do_twoway_jump:
+ /* We have to check that both destinations are safe.
+ Arrange for `newp1` to be the smaller of the two. */
+ if (newp1 > newp2)
+ (tmp = newp1, newp1 = newp2, newp2 = tmp);
- switch (*p++)
- {
- case succeed:
- return 1;
+ if (newp2 <= p_orig) /* Both destinations go backward! */
+ {
+#if ENABLE_CHECKING
+ fprintf (stderr, "FORALL_FIRSTCHAR: Broken assumption2!!\n");
+#endif
+ return false;
+ }
- case duplicate:
- /* If the first character has to match a backreference, that means
- that the group was empty (since it already matched). Since this
- is the only case that interests us here, we can assume that the
- backreference must match the empty string. */
- p++;
- continue;
+ if (!forall_firstchar_1 (newp2, pend, loop_beg, loop_end, f, arg))
+ return false;
+ do_jump:
+ eassert (newp2 <= loop_end);
+ if (newp1 <= p_orig)
+ {
+ if (newp1 < loop_beg)
+ {
+#if ENABLE_CHECKING
+ fprintf (stderr, "FORALL_FIRSTCHAR: Broken assumption3!!\n");
+#endif
+ return false;
+ }
+ else if (newp1 == loop_beg)
+ /* If we jump backward to the entry point of the current loop
+ it means it's a zero-length cycle through that loop;
+ this cycle itself does not break safety. */
+ return true;
+ else
+ /* We jump backward to a new loop, nested within the current
+ one. `newp1` is the entry point and `newp2` the exit of
+ that inner loop. */
+ /* `p` gets smaller, but termination is still ensured because
+ `loop_beg` gets bigger. */
+ (loop_beg = newp1, loop_end = newp2);
+ }
+ p = newp1;
+ continue;
+
+ case succeed_n:
+ newp1 = extract_address (p + 1);
+ newp2 = p + 5; /* Skip the two bytes containing the count. */
+ goto do_twoway_jump;
+
+ case set_number_at:
+ offset = extract_number (p + 1);
+ DEBUG_STATEMENT (eassert (extract_number (p + 3)));
+ /* If we're setting the counter of an immediately following
+ `succeed_n`, then this next execution of `succeed_n` will do
+ nothing but decrement its counter and "fall through".
+ So we do the fall through here to avoid considering the
+ "on failure" part of the `succeed_n` which should only be
+ considered when coming from the `jump(_n)` at the end of
+ the loop. */
+ p += (offset == 5 && p[5] == succeed_n) ? 10 : 5;
+ continue;
+
+ case start_memory:
+ case stop_memory:
+ p += 2;
+ continue;
+
+ /* This could match the empty string, so we may need to continue,
+ but in most cases, this can match "anything", so we should
+ return `false` unless told otherwise. */
+ case duplicate:
+ if (!f (p, arg))
+ return false;
+ p += 2;
+ continue;
+
+ default:
+ abort (); /* We have listed all the cases. */
+ }
+ }
+}
- /* Following are the cases which match a character. These end
- with 'break'. */
+/* Iterate through all the char-matching operations directly reachable from P.
+ Return true if P is "safe", meaning that PEND cannot be reached directly
+ from P and all calls to F returned true.
+ Return false if PEND *may* be directly reachable from P or if one of
+ the calls to F returned false.
+ PEND can be NULL (and hence never reachable).
+
+ Call `F (POS, ARG)` for every POS directly reachable from P,
+ before reaching PEND, where POS is the position of a char-matching
+ operation (`exactn`, `charset`, ...).
+
+ For operations that match the empty string (`wordbeg`, ...), if F
+ returns true we stop going down that path immediately but if it returns
+ false we don't consider it as a failure and we simply look for the
+ next char-matching operations on that path.
+ For `duplicate`, it is the reverse: a false is an immediate failure
+ whereas a true just lets the analysis continue with the rest of the path.
+
+ This function can be used while building the bytecode (in which case
+ you should pass NULL for bufp), but if so, P and PEND need to delimit
+ a valid block such that there is not jump to a location outside
+ of [P...PEND]. */
+static bool
+forall_firstchar (struct re_pattern_buffer *bufp, re_char *p, re_char *pend,
+ bool f (re_char *p, void *arg), void *arg)
+{
+ eassert (!bufp || bufp->used);
+ eassert (pend || bufp->used);
+ return forall_firstchar_1 (p, pend,
+ bufp ? bufp->buffer - 1 : p,
+ bufp ? bufp->buffer + bufp->used + 1 : pend,
+ f, arg);
+}
- case exactn:
- if (fastmap)
- {
- /* If multibyte is nonzero, the first byte of each
- character is an ASCII or a leading code. Otherwise,
- each byte is a character. Thus, this works in both
- cases. */
- fastmap[p[1]] = 1;
- if (multibyte)
- {
- /* Cover the case of matching a raw char in a
- multibyte regexp against unibyte. */
- if (CHAR_BYTE8_HEAD_P (p[1]))
- fastmap[CHAR_TO_BYTE8 (STRING_CHAR (p + 1))] = 1;
- }
- else
- {
- /* For the case of matching this unibyte regex
- against multibyte, we must set a leading code of
- the corresponding multibyte character. */
- int c = RE_CHAR_TO_MULTIBYTE (p[1]);
+struct anafirst_data {
+ bool multibyte;
+ char *fastmap;
+ bool match_any_multibyte_characters;
+};
- fastmap[CHAR_LEADING_CODE (c)] = 1;
- }
- }
- break;
+static bool
+analyze_first_fastmap (const re_char *p, void *arg)
+{
+ struct anafirst_data *data = arg;
+ int j, k;
+ int nbits;
+ bool not;
- case anychar:
- /* We could put all the chars except for \n (and maybe \0)
- but we don't bother since it is generally not worth it. */
- if (!fastmap) break;
- return -1;
+ switch (*p)
+ {
+ case succeed:
+ return false;
+ case duplicate:
+ /* If the first character has to match a backreference, that means
+ that the group was empty (since it already matched). Since this
+ is the only case that interests us here, we can assume that the
+ backreference must match the empty string and we need to
+ build the fastmap from the rest of the path. */
+ return true;
- case charset_not:
- if (!fastmap) break;
- {
- /* Chars beyond end of bitmap are possible matches. */
- for (j = CHARSET_BITMAP_SIZE (&p[-1]) * BYTEWIDTH;
- j < (1 << BYTEWIDTH); j++)
- fastmap[j] = 1;
- }
- FALLTHROUGH;
- case charset:
- if (!fastmap) break;
- not = (re_opcode_t) *(p - 1) == charset_not;
- nbits = CHARSET_BITMAP_SIZE (&p[-1]) * BYTEWIDTH;
- p++;
- for (j = 0; j < nbits; j++)
- if (!!(p[j / BYTEWIDTH] & (1 << (j % BYTEWIDTH))) ^ not)
- fastmap[j] = 1;
-
- /* To match raw bytes (in the 80..ff range) against multibyte
- strings, add their leading bytes to the fastmap. */
- for (j = 0x80; j < nbits; j++)
- if (!!(p[j / BYTEWIDTH] & (1 << (j % BYTEWIDTH))) ^ not)
- fastmap[CHAR_LEADING_CODE (BYTE8_TO_CHAR (j))] = 1;
-
- if (/* Any leading code can possibly start a character
- which doesn't match the specified set of characters. */
- not
- ||
- /* If we can match a character class, we can match any
- multibyte characters. */
- (CHARSET_RANGE_TABLE_EXISTS_P (&p[-2])
- && CHARSET_RANGE_TABLE_BITS (&p[-2]) != 0))
+ /* Following are the cases which match a character. These end
+ with 'break'. */
- {
- if (match_any_multibyte_characters == false)
- {
- for (j = MIN_MULTIBYTE_LEADING_CODE;
- j <= MAX_MULTIBYTE_LEADING_CODE; j++)
- fastmap[j] = 1;
- match_any_multibyte_characters = true;
- }
- }
+ case exactn:
+ p++;
+ /* If multibyte is nonzero, the first byte of each
+ character is an ASCII or a leading code. Otherwise,
+ each byte is a character. Thus, this works in both
+ cases. */
+ data->fastmap[p[1]] = 1;
+ if (data->multibyte)
+ {
+ /* Cover the case of matching a raw char in a
+ multibyte regexp against unibyte. */
+ if (CHAR_BYTE8_HEAD_P (p[1]))
+ data->fastmap[CHAR_TO_BYTE8 (STRING_CHAR (p + 1))] = 1;
+ }
+ else
+ {
+ /* For the case of matching this unibyte regex
+ against multibyte, we must set a leading code of
+ the corresponding multibyte character. */
+ int c = RE_CHAR_TO_MULTIBYTE (p[1]);
- else if (!not && CHARSET_RANGE_TABLE_EXISTS_P (&p[-2])
- && match_any_multibyte_characters == false)
- {
- /* Set fastmap[I] to 1 where I is a leading code of each
- multibyte character in the range table. */
- int c, count;
- unsigned char lc1, lc2;
-
- /* Make P points the range table. '+ 2' is to skip flag
- bits for a character class. */
- p += CHARSET_BITMAP_SIZE (&p[-2]) + 2;
-
- /* Extract the number of ranges in range table into COUNT. */
- EXTRACT_NUMBER_AND_INCR (count, p);
- for (; count > 0; count--, p += 3)
- {
- /* Extract the start and end of each range. */
- EXTRACT_CHARACTER (c, p);
- lc1 = CHAR_LEADING_CODE (c);
- p += 3;
- EXTRACT_CHARACTER (c, p);
- lc2 = CHAR_LEADING_CODE (c);
- for (j = lc1; j <= lc2; j++)
- fastmap[j] = 1;
- }
- }
- break;
+ data->fastmap[CHAR_LEADING_CODE (c)] = 1;
+ }
+ return true;
- case syntaxspec:
- case notsyntaxspec:
- if (!fastmap) break;
- /* This match depends on text properties. These end with
- aborting optimizations. */
- return -1;
+ case anychar:
+ /* We could put all the chars except for \n (and maybe \0)
+ but we don't bother since it is generally not worth it. */
+ return false;
- case categoryspec:
- case notcategoryspec:
- if (!fastmap) break;
- not = (re_opcode_t)p[-1] == notcategoryspec;
- k = *p++;
- for (j = (1 << BYTEWIDTH); j >= 0; j--)
- if ((CHAR_HAS_CATEGORY (j, k)) ^ not)
- fastmap[j] = 1;
-
- /* Any leading code can possibly start a character which
- has or doesn't has the specified category. */
- if (match_any_multibyte_characters == false)
+ case charset_not:
+ {
+ /* Chars beyond end of bitmap are possible matches. */
+ for (j = CHARSET_BITMAP_SIZE (p) * BYTEWIDTH;
+ j < (1 << BYTEWIDTH); j++)
+ data->fastmap[j] = 1;
+ }
+ FALLTHROUGH;
+ case charset:
+ not = (re_opcode_t) *(p) == charset_not;
+ nbits = CHARSET_BITMAP_SIZE (p) * BYTEWIDTH;
+ p += 2;
+ for (j = 0; j < nbits; j++)
+ if (!!(p[j / BYTEWIDTH] & (1 << (j % BYTEWIDTH))) ^ not)
+ data->fastmap[j] = 1;
+
+ /* To match raw bytes (in the 80..ff range) against multibyte
+ strings, add their leading bytes to the fastmap. */
+ for (j = 0x80; j < nbits; j++)
+ if (!!(p[j / BYTEWIDTH] & (1 << (j % BYTEWIDTH))) ^ not)
+ data->fastmap[CHAR_LEADING_CODE (BYTE8_TO_CHAR (j))] = 1;
+
+ if (/* Any leading code can possibly start a character
+ which doesn't match the specified set of characters. */
+ not
+ ||
+ /* If we can match a character class, we can match any
+ multibyte characters. */
+ (CHARSET_RANGE_TABLE_EXISTS_P (&p[-2])
+ && CHARSET_RANGE_TABLE_BITS (&p[-2]) != 0))
+
+ {
+ if (!data->match_any_multibyte_characters)
{
for (j = MIN_MULTIBYTE_LEADING_CODE;
- j <= MAX_MULTIBYTE_LEADING_CODE; j++)
- fastmap[j] = 1;
- match_any_multibyte_characters = true;
+ j <= MAX_MULTIBYTE_LEADING_CODE; j++)
+ data->fastmap[j] = 1;
+ data->match_any_multibyte_characters = true;
}
- break;
-
- /* All cases after this match the empty string. These end with
- 'continue'. */
-
- case at_dot:
- case no_op:
- case begline:
- case endline:
- case begbuf:
- case endbuf:
- case wordbound:
- case notwordbound:
- case wordbeg:
- case wordend:
- case symbeg:
- case symend:
- continue;
-
+ }
- case jump:
- EXTRACT_NUMBER_AND_INCR (j, p);
- if (j < 0)
- /* Backward jumps can only go back to code that we've already
- visited. 're_compile' should make sure this is true. */
- break;
- p += j;
- switch (*p)
+ else if (!not && CHARSET_RANGE_TABLE_EXISTS_P (&p[-2])
+ && data->match_any_multibyte_characters == false)
+ {
+ /* Set fastmap[I] to 1 where I is a leading code of each
+ multibyte character in the range table. */
+ int c, count;
+ unsigned char lc1, lc2;
+
+ /* Make P points the range table. '+ 2' is to skip flag
+ bits for a character class. */
+ p += CHARSET_BITMAP_SIZE (&p[-2]) + 2;
+
+ /* Extract the number of ranges in range table into COUNT. */
+ EXTRACT_NUMBER_AND_INCR (count, p);
+ for (; count > 0; count--, p += 3)
{
- case on_failure_jump:
- case on_failure_keep_string_jump:
- case on_failure_jump_loop:
- case on_failure_jump_nastyloop:
- case on_failure_jump_smart:
- p++;
- break;
- default:
- continue;
- };
- /* Keep P1 to allow the 'on_failure_jump' we are jumping to
- to jump back to "just after here". */
- FALLTHROUGH;
- case on_failure_jump:
- case on_failure_keep_string_jump:
- case on_failure_jump_nastyloop:
- case on_failure_jump_loop:
- case on_failure_jump_smart:
- EXTRACT_NUMBER_AND_INCR (j, p);
- if (p + j <= p1)
- ; /* Backward jump to be ignored. */
- else
- { /* We have to look down both arms.
- We first go down the "straight" path so as to minimize
- stack usage when going through alternatives. */
- int r = analyze_first (p, pend, fastmap, multibyte);
- if (r) return r;
- p += j;
+ /* Extract the start and end of each range. */
+ EXTRACT_CHARACTER (c, p);
+ lc1 = CHAR_LEADING_CODE (c);
+ p += 3;
+ EXTRACT_CHARACTER (c, p);
+ lc2 = CHAR_LEADING_CODE (c);
+ for (j = lc1; j <= lc2; j++)
+ data->fastmap[j] = 1;
}
- continue;
+ }
+ return true;
+ case syntaxspec:
+ case notsyntaxspec:
+ /* This match depends on text properties. These end with
+ aborting optimizations. */
+ return false;
- case jump_n:
- /* This code simply does not properly handle forward jump_n. */
- DEBUG_STATEMENT (EXTRACT_NUMBER (j, p); eassert (j < 0));
- p += 4;
- /* jump_n can either jump or fall through. The (backward) jump
- case has already been handled, so we only need to look at the
- fallthrough case. */
- continue;
+ case categoryspec:
+ case notcategoryspec:
+ not = (re_opcode_t)p[0] == notcategoryspec;
+ p++;
+ k = *p++;
+ for (j = (1 << BYTEWIDTH); j >= 0; j--)
+ if ((CHAR_HAS_CATEGORY (j, k)) ^ not)
+ data->fastmap[j] = 1;
+
+ /* Any leading code can possibly start a character which
+ has or doesn't has the_malloc_fn specified category. */
+ if (!data->match_any_multibyte_characters)
+ {
+ for (j = MIN_MULTIBYTE_LEADING_CODE;
+ j <= MAX_MULTIBYTE_LEADING_CODE; j++)
+ data->fastmap[j] = 1;
+ data->match_any_multibyte_characters = true;
+ }
+ return true;
- case succeed_n:
- /* If N == 0, it should be an on_failure_jump_loop instead. */
- DEBUG_STATEMENT (EXTRACT_NUMBER (j, p + 2); eassert (j > 0));
- p += 4;
- /* We only care about one iteration of the loop, so we don't
- need to consider the case where this behaves like an
- on_failure_jump. */
- continue;
+ case at_dot:
+ case begbuf:
+ case wordbound:
+ case notwordbound:
+ case begline:
+ case endline:
+ case endbuf:
+ case wordbeg:
+ case wordend:
+ case symbeg:
+ case symend:
+ /* This false doesn't mean failure but rather "not succeeded yet". */
+ return false;
+ default:
+#if ENABLE_CHECKING
+ abort (); /* We have listed all the cases. */
+#endif
+ return false;
+ }
+}
- case set_number_at:
- p += 4;
- continue;
+static bool
+analyze_first_null (const re_char *p, void *arg)
+{
+ switch (*p)
+ {
+ case succeed:
+ /* This is safe: we can't reach `pend` at all from here. */
+ return true;
+ case duplicate:
+ /* Either `duplicate` ends up matching a non-empty string, in which
+ case we're good, or it matches the empty string, in which case we
+ need to continue checking the rest of this path, which is exactly
+ what returning `true` does, here. */
+ return true;
- case start_memory:
- case stop_memory:
- p += 1;
- continue;
+ case exactn:
+ case anychar:
+ case charset_not:
+ case charset:
+ case syntaxspec:
+ case notsyntaxspec:
+ case categoryspec:
+ case notcategoryspec:
+ return true;
+ case at_dot:
+ case begbuf:
+ case wordbound:
+ case notwordbound:
+ case begline:
+ case endline:
+ case endbuf:
+ case wordbeg:
+ case wordend:
+ case symbeg:
+ case symend:
+ /* This false doesn't mean failure but rather "not succeeded yet". */
+ return false;
- default:
- abort (); /* We have listed all the cases. */
- } /* switch *p++ */
+ default:
+#if ENABLE_CHECKING
+ abort (); /* We have listed all the cases. */
+#endif
+ return false;
+ }
+}
+
+/* analyze_first.
+ If fastmap is non-NULL, go through the pattern and fill fastmap
+ with all the possible leading chars. If fastmap is NULL, don't
+ bother filling it up (obviously) and only return whether the
+ pattern could potentially match the empty string.
- /* Getting here means we have found the possible starting
- characters for one path of the pattern -- and that the empty
- string does not match. We need not follow this path further. */
- return 0;
- } /* while p */
+ Return false if p matches at least one char before reaching pend.
+ Return true if p..pend might match the empty string
+ or if fastmap was not updated accurately. */
- /* We reached the end without matching anything. */
- return 1;
+static bool
+analyze_first (struct re_pattern_buffer *bufp,
+ re_char *p, re_char *pend, char *fastmap)
+{
+ eassert (pend);
+ struct anafirst_data data = { bufp ? bufp->multibyte : false,
+ fastmap, false };
+ bool safe = forall_firstchar (bufp->used ? bufp : NULL, p, pend,
+ fastmap ? analyze_first_fastmap
+ : analyze_first_null,
+ &data);
+ return !safe;
+}
-} /* analyze_first */
/* Compute a fastmap for the compiled pattern in BUFP.
A fastmap records which of the (1 << BYTEWIDTH) possible
@@ -3119,7 +3322,6 @@ static void
re_compile_fastmap (struct re_pattern_buffer *bufp)
{
char *fastmap = bufp->fastmap;
- int analysis;
eassert (fastmap && bufp->buffer);
@@ -3128,9 +3330,8 @@ re_compile_fastmap (struct re_pattern_buffer *bufp)
/* FIXME: Is the following assignment correct even when ANALYSIS < 0? */
bufp->fastmap_accurate = 1; /* It will be when we're done. */
- analysis = analyze_first (bufp->buffer, bufp->buffer + bufp->used,
- fastmap, RE_MULTIBYTE_P (bufp));
- bufp->can_be_null = (analysis != 0);
+ bufp->can_be_null = analyze_first (bufp, bufp->buffer,
+ bufp->buffer + bufp->used, fastmap);
} /* re_compile_fastmap */
/* Set REGS to hold NUM_REGS registers, storing them in STARTS and
@@ -3168,7 +3369,7 @@ re_set_registers (struct re_pattern_buffer *bufp, struct re_registers *regs,
/* Searching routines. */
/* Like re_search_2, below, but only one string is specified, and
- doesn't let you say where to stop matching. */
+ doesn't let you say where to stop matching. */
ptrdiff_t
re_search (struct re_pattern_buffer *bufp, const char *string, ptrdiff_t size,
@@ -3258,12 +3459,7 @@ re_search_2 (struct re_pattern_buffer *bufp, const char *str1, ptrdiff_t size1,
/* See whether the pattern is anchored. */
anchored_start = (bufp->buffer[0] == begline);
- gl_state.object = re_match_object; /* Used by SYNTAX_TABLE_BYTE_TO_CHAR. */
- {
- ptrdiff_t charpos = SYNTAX_TABLE_BYTE_TO_CHAR (POS_AS_IN_BUFFER (startpos));
-
- SETUP_SYNTAX_TABLE_FOR_OBJECT (re_match_object, charpos, 1);
- }
+ RE_SETUP_SYNTAX_TABLE_FOR_OBJECT (re_match_object, startpos);
/* Loop through the string, looking for a place to start matching. */
for (;;)
@@ -3550,33 +3746,6 @@ skip_one_char (re_char *p)
}
-/* Jump over non-matching operations. */
-static re_char *
-skip_noops (re_char *p, re_char *pend)
-{
- int mcnt;
- while (p < pend)
- {
- switch (*p)
- {
- case start_memory:
- case stop_memory:
- p += 2; break;
- case no_op:
- p += 1; break;
- case jump:
- p += 1;
- EXTRACT_NUMBER_AND_INCR (mcnt, p);
- p += mcnt;
- break;
- default:
- return p;
- }
- }
- eassert (p == pend);
- return p;
-}
-
/* Test if C matches charset op. *PP points to the charset or charset_not
opcode. When the function finishes, *PP will be advanced past that opcode.
C is character to test (possibly after translations) and CORIG is original
@@ -3596,7 +3765,7 @@ execute_charset (re_char **pp, int c, int corig, bool unibyte,
int count;
rtp = CHARSET_RANGE_TABLE (p);
EXTRACT_NUMBER_AND_INCR (count, rtp);
- *pp = CHARSET_RANGE_TABLE_END ((rtp), (count));
+ *pp = CHARSET_RANGE_TABLE_END (rtp, count);
}
else
*pp += 2 + CHARSET_BITMAP_SIZE (p);
@@ -3645,92 +3814,55 @@ execute_charset (re_char **pp, int c, int corig, bool unibyte,
return not;
}
-/* True if "p1 matches something" implies "p2 fails". */
+/* Case where `p2` points to an `exactn` or `endline`. */
static bool
-mutually_exclusive_p (struct re_pattern_buffer *bufp, re_char *p1,
- re_char *p2)
+mutually_exclusive_exactn (struct re_pattern_buffer *bufp, re_char *p1,
+ re_char *p2)
{
- re_opcode_t op2;
bool multibyte = RE_MULTIBYTE_P (bufp);
- unsigned char *pend = bufp->buffer + bufp->used;
- re_char *p2_orig = p2;
+ int c
+ = (re_opcode_t) *p2 == endline ? '\n'
+ : RE_STRING_CHAR (p2 + 2, multibyte);
- eassert (p1 >= bufp->buffer && p1 < pend
- && p2 >= bufp->buffer && p2 <= pend);
-
- /* Skip over open/close-group commands.
- If what follows this loop is a ...+ construct,
- look at what begins its body, since we will have to
- match at least one of that. */
- p2 = skip_noops (p2, pend);
- /* The same skip can be done for p1, except that this function
- is only used in the case where p1 is a simple match operator. */
- /* p1 = skip_noops (p1, pend); */
-
- eassert (p1 >= bufp->buffer && p1 < pend
- && p2 >= bufp->buffer && p2 <= pend);
-
- op2 = p2 == pend ? succeed : *p2;
-
- switch (op2)
+ if ((re_opcode_t) *p1 == exactn)
{
- case succeed:
- case endbuf:
- /* If we're at the end of the pattern, we can change. */
- if (skip_one_char (p1))
+ if (c != RE_STRING_CHAR (p1 + 2, multibyte))
{
- DEBUG_PRINT (" End of pattern: fast loop.\n");
+ DEBUG_PRINT (" '%c' != '%c' => fast loop.\n", c, p1[2]);
return true;
}
- break;
-
- case endline:
- case exactn:
- {
- int c
- = (re_opcode_t) *p2 == endline ? '\n'
- : RE_STRING_CHAR (p2 + 2, multibyte);
-
- if ((re_opcode_t) *p1 == exactn)
- {
- if (c != RE_STRING_CHAR (p1 + 2, multibyte))
- {
- DEBUG_PRINT (" '%c' != '%c' => fast loop.\n", c, p1[2]);
- return true;
- }
- }
-
- else if ((re_opcode_t) *p1 == charset
- || (re_opcode_t) *p1 == charset_not)
- {
- if (!execute_charset (&p1, c, c, !multibyte || ASCII_CHAR_P (c),
- Qnil))
- {
- DEBUG_PRINT (" No match => fast loop.\n");
- return true;
- }
- }
- else if ((re_opcode_t) *p1 == anychar
- && c == '\n')
- {
- DEBUG_PRINT (" . != \\n => fast loop.\n");
- return true;
- }
- }
- break;
+ }
- case charset:
- {
- if ((re_opcode_t) *p1 == exactn)
- /* Reuse the code above. */
- return mutually_exclusive_p (bufp, p2, p1);
-
- /* It is hard to list up all the character in charset
- P2 if it includes multibyte character. Give up in
- such case. */
- else if (!multibyte || !CHARSET_RANGE_TABLE_EXISTS_P (p2))
+ else if ((re_opcode_t) *p1 == charset
+ || (re_opcode_t) *p1 == charset_not)
+ {
+ if (!execute_charset (&p1, c, c, !multibyte || ASCII_CHAR_P (c),
+ Qnil))
{
- /* Now, we are sure that P2 has no range table.
+ DEBUG_PRINT (" No match => fast loop.\n");
+ return true;
+ }
+ }
+ else if ((re_opcode_t) *p1 == anychar
+ && c == '\n')
+ {
+ DEBUG_PRINT (" . != \\n => fast loop.\n");
+ return true;
+ }
+ return false;
+}
+
+/* Case where `p2` points to an `charset`. */
+static bool
+mutually_exclusive_charset (struct re_pattern_buffer *bufp, re_char *p1,
+ re_char *p2)
+{
+ /* It is hard to list up all the character in charset
+ P2 if it includes multibyte character. Give up in
+ such case. */
+ if (!RE_MULTIBYTE_P (bufp) || !CHARSET_RANGE_TABLE_EXISTS_P (p2))
+ {
+ /* Now, we are sure that P2 has no range table.
So, for the size of bitmap in P2, 'p2[1]' is
enough. But P1 may have range table, so the
size of bitmap table of P1 is extracted by
@@ -3741,113 +3873,161 @@ mutually_exclusive_p (struct re_pattern_buffer *bufp, re_char *p1,
bitmap table. So, in both cases, it is enough to test
only the bitmap table of P1. */
- if ((re_opcode_t) *p1 == charset)
- {
- int idx;
- /* We win if the charset inside the loop
+ if ((re_opcode_t) *p1 == charset)
+ {
+ int idx;
+ /* We win if the charset inside the loop
has no overlap with the one after the loop. */
- for (idx = 0;
- (idx < (int) p2[1]
- && idx < CHARSET_BITMAP_SIZE (p1));
- idx++)
- if ((p2[2 + idx] & p1[2 + idx]) != 0)
- break;
+ for (idx = 0;
+ (idx < (int) p2[1]
+ && idx < CHARSET_BITMAP_SIZE (p1));
+ idx++)
+ if ((p2[2 + idx] & p1[2 + idx]) != 0)
+ break;
- if (idx == p2[1]
- || idx == CHARSET_BITMAP_SIZE (p1))
- {
- DEBUG_PRINT (" No match => fast loop.\n");
- return true;
- }
- }
- else if ((re_opcode_t) *p1 == charset_not)
+ if (idx == p2[1]
+ || idx == CHARSET_BITMAP_SIZE (p1))
{
- int idx;
- /* We win if the charset_not inside the loop lists
+ DEBUG_PRINT (" No match => fast loop.\n");
+ return true;
+ }
+ }
+ else if ((re_opcode_t) *p1 == charset_not)
+ {
+ int idx;
+ /* We win if the charset_not inside the loop lists
every character listed in the charset after. */
- for (idx = 0; idx < (int) p2[1]; idx++)
- if (! (p2[2 + idx] == 0
- || (idx < CHARSET_BITMAP_SIZE (p1)
- && ((p2[2 + idx] & ~ p1[2 + idx]) == 0))))
- break;
+ for (idx = 0; idx < (int) p2[1]; idx++)
+ if (! (p2[2 + idx] == 0
+ || (idx < CHARSET_BITMAP_SIZE (p1)
+ && ((p2[2 + idx] & ~ p1[2 + idx]) == 0))))
+ break;
- if (idx == p2[1])
- {
- DEBUG_PRINT (" No match => fast loop.\n");
- return true;
- }
- }
- }
+ if (idx == p2[1])
+ {
+ DEBUG_PRINT (" No match => fast loop.\n");
+ return true;
+ }
+ }
+ }
+ return false;
+}
+
+struct mutexcl_data {
+ struct re_pattern_buffer *bufp;
+ re_char *p1;
+ bool unconstrained;
+};
+
+static bool
+mutually_exclusive_one (re_char *p2, void *arg)
+{
+ struct mutexcl_data *data = arg;
+ switch (*p2)
+ {
+ case succeed:
+ /* If `p1` matches, `succeed` can still match, so we should return
+ `false`. *BUT* when N iterations of `p1` and N+1 iterations of `p1`
+ match, the `succeed` that comes after N+1 always takes precedence
+ over the one after N because we always prefer a longer match, so
+ the succeed after N can actually be replaced by a "fail" without
+ changing the end result.
+ In this sense, "if `p1` matches, `succeed` can't match".
+ So we can return `true`.
+ *BUT* this only holds if we're sure that the N+1 will indeed succeed,
+ so we need to make sure there is no other matching operator between
+ the exit of the iteration and the `succeed`. */
+ return data->unconstrained;
+
+/* Remember that there may be an empty matching operator on the way.
+ If we return true, this is the "end" of this control flow path,
+ so it can't get in the way of a subsequent `succeed. */
+#define RETURN_CONSTRAIN(v) \
+ { bool tmp = (v); \
+ if (!tmp) \
+ data->unconstrained = false; \
+ return tmp; \
+ }
+
+ case endline:
+ RETURN_CONSTRAIN (mutually_exclusive_exactn (data->bufp, data->p1, p2));
+ case exactn:
+ return mutually_exclusive_exactn (data->bufp, data->p1, p2);
+ case charset:
+ {
+ if (*data->p1 == exactn)
+ return mutually_exclusive_exactn (data->bufp, p2, data->p1);
+ else
+ return mutually_exclusive_charset (data->bufp, data->p1, p2);
}
- break;
case charset_not:
- switch (*p1)
+ switch (*data->p1)
{
case exactn:
+ return mutually_exclusive_exactn (data->bufp, p2, data->p1);
case charset:
- /* Reuse the code above. */
- return mutually_exclusive_p (bufp, p2, p1);
+ return mutually_exclusive_charset (data->bufp, p2, data->p1);
case charset_not:
/* When we have two charset_not, it's very unlikely that
they don't overlap. The union of the two sets of excluded
chars should cover all possible chars, which, as a matter of
fact, is virtually impossible in multibyte buffers. */
- break;
+ return false;
}
- break;
-
- case wordend:
- return ((re_opcode_t) *p1 == syntaxspec && p1[1] == Sword);
- case symend:
- return ((re_opcode_t) *p1 == syntaxspec
- && (p1[1] == Ssymbol || p1[1] == Sword));
+ return false;
+ case anychar:
+ return false; /* FIXME: exactn \n ? */
+ case syntaxspec:
+ return (*data->p1 == notsyntaxspec && data->p1[1] == p2[1]);
case notsyntaxspec:
- return ((re_opcode_t) *p1 == syntaxspec && p1[1] == p2[1]);
+ return (*data->p1 == syntaxspec && data->p1[1] == p2[1]);
+ case categoryspec:
+ return (*data->p1 == notcategoryspec && data->p1[1] == p2[1]);
+ case notcategoryspec:
+ return (*data->p1 == categoryspec && data->p1[1] == p2[1]);
+ case endbuf:
+ return true;
case wordbeg:
- return ((re_opcode_t) *p1 == notsyntaxspec && p1[1] == Sword);
+ RETURN_CONSTRAIN (*data->p1 == notsyntaxspec && data->p1[1] == Sword);
+ case wordend:
+ RETURN_CONSTRAIN (*data->p1 == syntaxspec && data->p1[1] == Sword);
case symbeg:
- return ((re_opcode_t) *p1 == notsyntaxspec
- && (p1[1] == Ssymbol || p1[1] == Sword));
- case syntaxspec:
- return ((re_opcode_t) *p1 == notsyntaxspec && p1[1] == p2[1]);
+ RETURN_CONSTRAIN (*data->p1 == notsyntaxspec
+ && (data->p1[1] == Ssymbol || data->p1[1] == Sword));
+ case symend:
+ RETURN_CONSTRAIN (*data->p1 == syntaxspec
+ && (data->p1[1] == Ssymbol || data->p1[1] == Sword));
+ case at_dot:
+ case begbuf:
case wordbound:
- return (((re_opcode_t) *p1 == notsyntaxspec
- || (re_opcode_t) *p1 == syntaxspec)
- && p1[1] == Sword);
-
- case categoryspec:
- return ((re_opcode_t) *p1 == notcategoryspec && p1[1] == p2[1]);
- case notcategoryspec:
- return ((re_opcode_t) *p1 == categoryspec && p1[1] == p2[1]);
+ case notwordbound:
+ case begline:
+ RETURN_CONSTRAIN (false);
- case on_failure_jump_nastyloop:
- case on_failure_jump_smart:
- case on_failure_jump_loop:
- case on_failure_keep_string_jump:
- case on_failure_jump:
- {
- int mcnt;
- p2++;
- EXTRACT_NUMBER_AND_INCR (mcnt, p2);
- /* Don't just test `mcnt > 0` because non-greedy loops have
- their test at the end with an unconditional jump at the start. */
- if (p2 > p2_orig && mcnt >= 0) /* Ensure forward progress. */
- return (mutually_exclusive_p (bufp, p1, p2)
- && mutually_exclusive_p (bufp, p1, p2 + mcnt));
- break;
- }
+ case duplicate:
+ /* At this point, we know nothing about what this can match, sadly. */
+ return false;
default:
- ;
+#if ENABLE_CHECKING
+ abort (); /* We have listed all the cases. */
+#endif
+ return false;
}
-
- /* Safe default. */
- return false;
}
+/* True if "p1 matches something" implies "p2 fails". */
+
+static bool
+mutually_exclusive_p (struct re_pattern_buffer *bufp, re_char *p1,
+ re_char *p2)
+{
+ struct mutexcl_data data = { bufp, p1, true };
+ return forall_firstchar (bufp, p2, NULL, mutually_exclusive_one, &data);
+}
/* Matching routines. */
@@ -3871,10 +4051,7 @@ re_match_2 (struct re_pattern_buffer *bufp,
{
ptrdiff_t result;
- ptrdiff_t charpos;
- gl_state.object = re_match_object; /* Used by SYNTAX_TABLE_BYTE_TO_CHAR. */
- charpos = SYNTAX_TABLE_BYTE_TO_CHAR (POS_AS_IN_BUFFER (pos));
- SETUP_SYNTAX_TABLE_FOR_OBJECT (re_match_object, charpos, 1);
+ RE_SETUP_SYNTAX_TABLE_FOR_OBJECT (re_match_object, pos);
result = re_match_2_internal (bufp, (re_char *) string1, size1,
(re_char *) string2, size2,
@@ -3979,6 +4156,9 @@ re_match_2_internal (struct re_pattern_buffer *bufp,
/* This keeps track of how many buffer/string positions we examined. */
ptrdiff_t nchars = 0;
+ /* Final return value of the function. */
+ ptrdiff_t retval = -1; /* Presumes failure to match for now. */
+
#ifdef DEBUG_COMPILES_ARGUMENTS
/* Counts the total number of registers pushed. */
ptrdiff_t num_regs_pushed = 0;
@@ -4233,15 +4413,8 @@ re_match_2_internal (struct re_pattern_buffer *bufp,
DEBUG_PRINT ("Returning %td from re_match_2.\n", dcnt);
- unbind_to (count, Qnil);
- SAFE_FREE ();
- /* The factor of 50 below is a heuristic that needs to be tuned. It
- means we consider 50 buffer positions examined by this function
- roughly equivalent to the display engine iterating over a single
- buffer position. */
- if (max_redisplay_ticks > 0 && nchars > 0)
- update_redisplay_ticks (nchars / 50 + 1, NULL);
- return dcnt;
+ retval = dcnt;
+ goto endof_re_match;
}
/* Otherwise match next pattern command. */
@@ -4734,7 +4907,7 @@ re_match_2_internal (struct re_pattern_buffer *bufp,
/* Have to succeed matching what follows at least n times.
- After that, handle like 'on_failure_jump'. */
+ After that, handle like 'on_failure_jump_loop'. */
case succeed_n:
/* Signedness doesn't matter since we only compare MCNT to 0. */
EXTRACT_NUMBER (mcnt, p + 2);
@@ -4806,8 +4979,8 @@ re_match_2_internal (struct re_pattern_buffer *bufp,
int c1, c2;
int s1, s2;
int dummy;
- ptrdiff_t offset = PTR_TO_OFFSET (d);
- ptrdiff_t charpos = SYNTAX_TABLE_BYTE_TO_CHAR (offset) - 1;
+ ptrdiff_t offset = POINTER_TO_OFFSET (d);
+ ptrdiff_t charpos = RE_SYNTAX_TABLE_BYTE_TO_CHAR (offset) - 1;
UPDATE_SYNTAX_TABLE (charpos);
GET_CHAR_BEFORE_2 (c1, d, string1, end1, string2, end2);
nchars++;
@@ -4846,8 +5019,8 @@ re_match_2_internal (struct re_pattern_buffer *bufp,
int c1, c2;
int s1, s2;
int dummy;
- ptrdiff_t offset = PTR_TO_OFFSET (d);
- ptrdiff_t charpos = SYNTAX_TABLE_BYTE_TO_CHAR (offset);
+ ptrdiff_t offset = POINTER_TO_OFFSET (d);
+ ptrdiff_t charpos = RE_SYNTAX_TABLE_BYTE_TO_CHAR (offset);
UPDATE_SYNTAX_TABLE (charpos);
PREFETCH ();
GET_CHAR_AFTER (c2, d, dummy);
@@ -4889,8 +5062,8 @@ re_match_2_internal (struct re_pattern_buffer *bufp,
int c1, c2;
int s1, s2;
int dummy;
- ptrdiff_t offset = PTR_TO_OFFSET (d);
- ptrdiff_t charpos = SYNTAX_TABLE_BYTE_TO_CHAR (offset) - 1;
+ ptrdiff_t offset = POINTER_TO_OFFSET (d);
+ ptrdiff_t charpos = RE_SYNTAX_TABLE_BYTE_TO_CHAR (offset) - 1;
UPDATE_SYNTAX_TABLE (charpos);
GET_CHAR_BEFORE_2 (c1, d, string1, end1, string2, end2);
nchars++;
@@ -4931,8 +5104,8 @@ re_match_2_internal (struct re_pattern_buffer *bufp,
is the character at D, and S2 is the syntax of C2. */
int c1, c2;
int s1, s2;
- ptrdiff_t offset = PTR_TO_OFFSET (d);
- ptrdiff_t charpos = SYNTAX_TABLE_BYTE_TO_CHAR (offset);
+ ptrdiff_t offset = POINTER_TO_OFFSET (d);
+ ptrdiff_t charpos = RE_SYNTAX_TABLE_BYTE_TO_CHAR (offset);
UPDATE_SYNTAX_TABLE (charpos);
PREFETCH ();
c2 = RE_STRING_CHAR (d, target_multibyte);
@@ -4972,8 +5145,8 @@ re_match_2_internal (struct re_pattern_buffer *bufp,
is the character at D, and S2 is the syntax of C2. */
int c1, c2;
int s1, s2;
- ptrdiff_t offset = PTR_TO_OFFSET (d);
- ptrdiff_t charpos = SYNTAX_TABLE_BYTE_TO_CHAR (offset) - 1;
+ ptrdiff_t offset = POINTER_TO_OFFSET (d);
+ ptrdiff_t charpos = RE_SYNTAX_TABLE_BYTE_TO_CHAR (offset) - 1;
UPDATE_SYNTAX_TABLE (charpos);
GET_CHAR_BEFORE_2 (c1, d, string1, end1, string2, end2);
nchars++;
@@ -5008,8 +5181,8 @@ re_match_2_internal (struct re_pattern_buffer *bufp,
mcnt);
PREFETCH ();
{
- ptrdiff_t offset = PTR_TO_OFFSET (d);
- ptrdiff_t pos1 = SYNTAX_TABLE_BYTE_TO_CHAR (offset);
+ ptrdiff_t offset = POINTER_TO_OFFSET (d);
+ ptrdiff_t pos1 = RE_SYNTAX_TABLE_BYTE_TO_CHAR (offset);
UPDATE_SYNTAX_TABLE (pos1);
}
{
@@ -5082,8 +5255,7 @@ re_match_2_internal (struct re_pattern_buffer *bufp,
case succeed_n:
d = str;
continue_failure_jump:
- EXTRACT_NUMBER_AND_INCR (mcnt, pat);
- p = pat + mcnt;
+ p = extract_address (pat);
break;
case no_op:
@@ -5106,13 +5278,18 @@ re_match_2_internal (struct re_pattern_buffer *bufp,
if (best_regs_set)
goto restore_best_regs;
+endof_re_match:
unbind_to (count, Qnil);
SAFE_FREE ();
+ /* The factor of 50 below is a heuristic that needs to be tuned.
+ It means we consider 50 buffer positions examined by this function
+ roughly equivalent to the display engine iterating over a single
+ buffer position. */
if (max_redisplay_ticks > 0 && nchars > 0)
update_redisplay_ticks (nchars / 50 + 1, NULL);
- return -1; /* Failure to match. */
+ return retval;
}
/* Subroutine definitions for re_match_2. */
diff --git a/src/regex-emacs.h b/src/regex-emacs.h
index 652aab44c41..2402e539e64 100644
--- a/src/regex-emacs.h
+++ b/src/regex-emacs.h
@@ -187,11 +187,16 @@ typedef enum { RECC_ERROR = 0,
RECC_DIGIT, RECC_XDIGIT,
RECC_BLANK, RECC_SPACE,
RECC_MULTIBYTE, RECC_NONASCII,
- RECC_ASCII, RECC_UNIBYTE
+ RECC_ASCII, RECC_UNIBYTE,
+ RECC_NUM_CLASSES = RECC_UNIBYTE
} re_wctype_t;
extern bool re_iswctype (int ch, re_wctype_t cc);
extern re_wctype_t re_wctype_parse (const unsigned char **strp,
ptrdiff_t limit);
+#if ENABLE_CHECKING
+extern void print_compiled_pattern (FILE *dest, struct re_pattern_buffer *bufp);
+#endif
+
#endif /* EMACS_REGEX_H */
diff --git a/src/scroll.c b/src/scroll.c
index 3c20c26deae..fd2a9e71207 100644
--- a/src/scroll.c
+++ b/src/scroll.c
@@ -21,6 +21,11 @@ along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. */
#include <config.h>
+/* The entire file is defined out under Android, where there is no
+ text terminal support of any kind. */
+
+#ifndef HAVE_ANDROID
+
#include "lisp.h"
#include "termchar.h"
#include "dispextern.h"
@@ -984,3 +989,5 @@ do_line_insertion_deletion_costs (struct frame *frame,
FRAME_DELETE_COST (frame), FRAME_DELETEN_COST (frame),
coefficient);
}
+
+#endif
diff --git a/src/search.c b/src/search.c
index f042e60c15a..f2d1f1f5449 100644
--- a/src/search.c
+++ b/src/search.c
@@ -162,7 +162,7 @@ clear_regexp_cache (void)
/* It's tempting to compare with the syntax-table we've actually changed,
but it's not sufficient because char-table inheritance means that
modifying one syntax-table can change others at the same time. */
- if (!searchbufs[i].busy && !EQ (searchbufs[i].syntax_table, Qt))
+ if (!searchbufs[i].busy && !BASE_EQ (searchbufs[i].syntax_table, Qt))
searchbufs[i].regexp = Qnil;
}
@@ -214,10 +214,11 @@ compile_pattern (Lisp_Object pattern, struct re_registers *regp,
&& !cp->busy
&& STRING_MULTIBYTE (cp->regexp) == STRING_MULTIBYTE (pattern)
&& !NILP (Fstring_equal (cp->regexp, pattern))
- && EQ (cp->buf.translate, translate)
+ && BASE_EQ (cp->buf.translate, translate)
&& cp->posix == posix
- && (EQ (cp->syntax_table, Qt)
- || EQ (cp->syntax_table, BVAR (current_buffer, syntax_table)))
+ && (BASE_EQ (cp->syntax_table, Qt)
+ || BASE_EQ (cp->syntax_table,
+ BVAR (current_buffer, syntax_table)))
&& !NILP (Fequal (cp->f_whitespace_regexp, Vsearch_spaces_regexp))
&& cp->buf.charset_unibyte == charset_unibyte)
break;
@@ -280,7 +281,7 @@ looking_at_1 (Lisp_Object string, bool posix, bool modify_data)
struct regexp_cache *cache_entry = compile_pattern (
string,
modify_match_data ? &search_regs : NULL,
- (!NILP (BVAR (current_buffer, case_fold_search))
+ (!NILP (Vcase_fold_search)
? BVAR (current_buffer, case_canon_table) : Qnil),
posix,
!NILP (BVAR (current_buffer, enable_multibyte_characters)));
@@ -401,7 +402,7 @@ string_match_1 (Lisp_Object regexp, Lisp_Object string, Lisp_Object start,
struct regexp_cache *cache_entry
= compile_pattern (regexp,
modify_match_data ? &search_regs : NULL,
- (!NILP (BVAR (current_buffer, case_fold_search))
+ (!NILP (Vcase_fold_search)
? BVAR (current_buffer, case_canon_table)
: Qnil),
posix,
@@ -1027,7 +1028,7 @@ find_before_next_newline (ptrdiff_t from, ptrdiff_t to,
static Lisp_Object
search_command (Lisp_Object string, Lisp_Object bound, Lisp_Object noerror,
- Lisp_Object count, int direction, int RE, bool posix)
+ Lisp_Object count, int direction, bool RE, bool posix)
{
EMACS_INT np;
EMACS_INT lim;
@@ -1067,10 +1068,10 @@ search_command (Lisp_Object string, Lisp_Object bound, Lisp_Object noerror,
BVAR (current_buffer, case_eqv_table));
np = search_buffer (string, PT, PT_BYTE, lim, lim_byte, n, RE,
- (!NILP (BVAR (current_buffer, case_fold_search))
+ (!NILP (Vcase_fold_search)
? BVAR (current_buffer, case_canon_table)
: Qnil),
- (!NILP (BVAR (current_buffer, case_fold_search))
+ (!NILP (Vcase_fold_search)
? BVAR (current_buffer, case_eqv_table)
: Qnil),
posix);
@@ -1130,21 +1131,6 @@ trivial_regexp_p (Lisp_Object regexp)
return 1;
}
-/* Search for the n'th occurrence of STRING in the current buffer,
- starting at position POS and stopping at position LIM,
- treating STRING as a literal string if RE is false or as
- a regular expression if RE is true.
-
- If N is positive, searching is forward and LIM must be greater than POS.
- If N is negative, searching is backward and LIM must be less than POS.
-
- Returns -x if x occurrences remain to be found (x > 0),
- or else the position at the beginning of the Nth occurrence
- (if searching backward) or the end (if searching forward).
-
- POSIX is nonzero if we want full backtracking (POSIX style)
- for this pattern. 0 means backtrack only enough to get a valid match. */
-
#define TRANSLATE(out, trt, d) \
do \
{ \
@@ -1308,7 +1294,7 @@ search_buffer_re (Lisp_Object string, ptrdiff_t pos, ptrdiff_t pos_byte,
static EMACS_INT
search_buffer_non_re (Lisp_Object string, ptrdiff_t pos,
ptrdiff_t pos_byte, ptrdiff_t lim, ptrdiff_t lim_byte,
- EMACS_INT n, int RE, Lisp_Object trt, Lisp_Object inverse_trt,
+ EMACS_INT n, bool RE, Lisp_Object trt, Lisp_Object inverse_trt,
bool posix)
{
unsigned char *raw_pattern, *pat;
@@ -1507,10 +1493,28 @@ search_buffer_non_re (Lisp_Object string, ptrdiff_t pos,
return result;
}
+/* Search for the Nth occurrence of STRING in the current buffer,
+ from buffer position POS/POS_BYTE until LIM/LIM_BYTE.
+
+ If RE, look for matches against the regular expression STRING instead;
+ if POSIX, enable POSIX style backtracking within that regular
+ expression.
+
+ If N is positive, search forward; in this case, LIM must be greater
+ than POS.
+
+ If N is negative, search backward; LIM must be less than POS.
+
+ Return -X if there are X remaining occurrences or matches,
+ or else the position at the beginning (if N is negative) or the end
+ (if N is positive) of the Nth occurrence or match against STRING.
+
+ Use TRT and INVERSE_TRT as character translation tables. */
+
EMACS_INT
search_buffer (Lisp_Object string, ptrdiff_t pos, ptrdiff_t pos_byte,
ptrdiff_t lim, ptrdiff_t lim_byte, EMACS_INT n,
- int RE, Lisp_Object trt, Lisp_Object inverse_trt, bool posix)
+ bool RE, Lisp_Object trt, Lisp_Object inverse_trt, bool posix)
{
if (running_asynch_code)
save_search_regs ();
@@ -2219,7 +2223,7 @@ Search case-sensitivity is determined by the value of the variable
See also the functions `match-beginning', `match-end' and `replace-match'. */)
(Lisp_Object string, Lisp_Object bound, Lisp_Object noerror, Lisp_Object count)
{
- return search_command (string, bound, noerror, count, -1, 0, 0);
+ return search_command (string, bound, noerror, count, -1, false, false);
}
DEFUN ("search-forward", Fsearch_forward, Ssearch_forward, 1, 4, "MSearch: ",
@@ -2244,7 +2248,7 @@ Search case-sensitivity is determined by the value of the variable
See also the functions `match-beginning', `match-end' and `replace-match'. */)
(Lisp_Object string, Lisp_Object bound, Lisp_Object noerror, Lisp_Object count)
{
- return search_command (string, bound, noerror, count, 1, 0, 0);
+ return search_command (string, bound, noerror, count, 1, false, false);
}
DEFUN ("re-search-backward", Fre_search_backward, Sre_search_backward, 1, 4,
@@ -2260,7 +2264,7 @@ because REGEXP is still matched in the forward direction. See Info
anchor `(elisp) re-search-backward' for details. */)
(Lisp_Object regexp, Lisp_Object bound, Lisp_Object noerror, Lisp_Object count)
{
- return search_command (regexp, bound, noerror, count, -1, 1, 0);
+ return search_command (regexp, bound, noerror, count, -1, true, false);
}
DEFUN ("re-search-forward", Fre_search_forward, Sre_search_forward, 1, 4,
@@ -2291,7 +2295,7 @@ See also the functions `match-beginning', `match-end', `match-string',
and `replace-match'. */)
(Lisp_Object regexp, Lisp_Object bound, Lisp_Object noerror, Lisp_Object count)
{
- return search_command (regexp, bound, noerror, count, 1, 1, 0);
+ return search_command (regexp, bound, noerror, count, 1, true, false);
}
DEFUN ("posix-search-backward", Fposix_search_backward, Sposix_search_backward, 1, 4,
@@ -2319,7 +2323,7 @@ See also the functions `match-beginning', `match-end', `match-string',
and `replace-match'. */)
(Lisp_Object regexp, Lisp_Object bound, Lisp_Object noerror, Lisp_Object count)
{
- return search_command (regexp, bound, noerror, count, -1, 1, 1);
+ return search_command (regexp, bound, noerror, count, -1, true, true);
}
DEFUN ("posix-search-forward", Fposix_search_forward, Sposix_search_forward, 1, 4,
@@ -2347,7 +2351,7 @@ See also the functions `match-beginning', `match-end', `match-string',
and `replace-match'. */)
(Lisp_Object regexp, Lisp_Object bound, Lisp_Object noerror, Lisp_Object count)
{
- return search_command (regexp, bound, noerror, count, 1, 1, 1);
+ return search_command (regexp, bound, noerror, count, 1, true, true);
}
DEFUN ("replace-match", Freplace_match, Sreplace_match, 1, 5, 0,
@@ -2361,7 +2365,7 @@ text has only capital letters and has at least one multiletter word,
convert NEWTEXT to all caps. Otherwise if all words are capitalized
in the replaced text, capitalize each word in NEWTEXT. Note that
what exactly is a word is determined by the syntax tables in effect
-in the current buffer.
+in the current buffer, and the variable `case-symbols-as-words'.
If optional third arg LITERAL is non-nil, insert NEWTEXT literally.
Otherwise treat `\\' as special:
@@ -2475,7 +2479,8 @@ since only regular expressions have distinguished subexpressions. */)
/* Cannot be all caps if any original char is lower case */
some_lowercase = 1;
- if (SYNTAX (prevc) != Sword)
+ if (SYNTAX (prevc) != Sword
+ && !(case_symbols_as_words && SYNTAX (prevc) == Ssymbol))
some_nonuppercase_initial = 1;
else
some_multiletter_word = 1;
@@ -2483,7 +2488,8 @@ since only regular expressions have distinguished subexpressions. */)
else if (uppercasep (c))
{
some_uppercase = 1;
- if (SYNTAX (prevc) != Sword)
+ if (SYNTAX (prevc) != Sword
+ && !(case_symbols_as_words && SYNTAX (prevc) == Ssymbol))
;
else
some_multiletter_word = 1;
@@ -2492,7 +2498,8 @@ since only regular expressions have distinguished subexpressions. */)
{
/* If the initial is a caseless word constituent,
treat that like a lowercase initial. */
- if (SYNTAX (prevc) != Sword)
+ if (SYNTAX (prevc) != Sword
+ && !(case_symbols_as_words && SYNTAX (prevc) == Ssymbol))
some_nonuppercase_initial = 1;
}
@@ -2891,7 +2898,7 @@ Return value is undefined if the last search failed. */)
ptrdiff_t start = search_regs.start[i];
if (start >= 0)
{
- if (EQ (last_thing_searched, Qt)
+ if (BASE_EQ (last_thing_searched, Qt)
|| ! NILP (integers))
{
XSETFASTINT (data[2 * i], start);
@@ -3133,11 +3140,25 @@ update_search_regs (ptrdiff_t oldstart, ptrdiff_t oldend, ptrdiff_t newend)
ptrdiff_t change = newend - oldend;
ptrdiff_t i;
+ /* When replacing subgroup 3 in a match for regexp '\(\)\(\(\)\)\(\)'
+ start[i] should ideally stay unchanged for all but i=4 and end[i]
+ should move for all but i=1.
+ We don't have enough info here to distinguish those different subgroups
+ (except for subgroup 0), so instead we lean towards leaving the start[i]s
+ unchanged and towards moving the end[i]s. */
+
for (i = 0; i < search_regs.num_regs; i++)
{
- if (search_regs.start[i] >= oldend)
+ if (search_regs.start[i] <= oldstart)
+ /* If the subgroup that 'replace-match' is modifying encloses the
+ subgroup 'i', then its 'start' position should stay unchanged.
+ That's always true for subgroup 0.
+ For other subgroups it depends on details we don't have, so
+ we optimistically assume that it also holds for them. */
+ ;
+ else if (search_regs.start[i] >= oldend)
search_regs.start[i] += change;
- else if (search_regs.start[i] > oldstart)
+ else
search_regs.start[i] = oldstart;
if (search_regs.end[i] >= oldend)
search_regs.end[i] += change;
@@ -3372,6 +3393,46 @@ the buffer. If the buffer doesn't have a cache, the value is nil. */)
set_buffer_internal_1 (old);
return val;
}
+
+DEFUN ("re--describe-compiled", Fre__describe_compiled, Sre__describe_compiled,
+ 1, 2, 0,
+ doc: /* Return a string describing the compiled form of REGEXP.
+If RAW is non-nil, just return the actual bytecode. */)
+ (Lisp_Object regexp, Lisp_Object raw)
+{
+ struct regexp_cache *cache_entry
+ = compile_pattern (regexp, NULL,
+ (!NILP (Vcase_fold_search)
+ ? BVAR (current_buffer, case_canon_table) : Qnil),
+ false,
+ !NILP (BVAR (current_buffer,
+ enable_multibyte_characters)));
+ if (!NILP (raw))
+ return make_unibyte_string ((char *) cache_entry->buf.buffer,
+ cache_entry->buf.used);
+ else
+ { /* FIXME: Why ENABLE_CHECKING? */
+#if !defined ENABLE_CHECKING
+ error ("Not available: rebuild with --enable-checking");
+#elif HAVE_OPEN_MEMSTREAM
+ char *buffer = NULL;
+ size_t size = 0;
+ FILE* f = open_memstream (&buffer, &size);
+ if (!f)
+ report_file_error ("open_memstream failed", regexp);
+ print_compiled_pattern (f, &cache_entry->buf);
+ fclose (f);
+ if (!buffer)
+ return Qnil;
+ Lisp_Object description = make_unibyte_string (buffer, size);
+ free (buffer);
+ return description;
+#else /* ENABLE_CHECKING && !HAVE_OPEN_MEMSTREAM */
+ print_compiled_pattern (stderr, &cache_entry->buf);
+ return build_string ("Description was sent to standard error");
+#endif /* !ENABLE_CHECKING */
+ }
+}
static void syms_of_search_for_pdumper (void);
@@ -3451,6 +3512,7 @@ is to bind it with `let' around a small expression. */);
defsubr (&Smatch_data__translate);
defsubr (&Sregexp_quote);
defsubr (&Snewline_cache_check);
+ defsubr (&Sre__describe_compiled);
pdumper_do_now_and_after_load (syms_of_search_for_pdumper);
}
diff --git a/src/sfnt.c b/src/sfnt.c
new file mode 100644
index 00000000000..8598b052044
--- /dev/null
+++ b/src/sfnt.c
@@ -0,0 +1,21539 @@
+/* TrueType format font support for GNU Emacs.
+
+Copyright (C) 2023-2024 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 <https://www.gnu.org/licenses/>. */
+
+#include <config.h>
+
+#include "sfnt.h"
+
+#include <assert.h>
+#include <attribute.h>
+#include <byteswap.h>
+#include <fcntl.h>
+#include <intprops.h>
+#include <inttypes.h>
+#include <stdckdint.h>
+#include <stdint.h>
+#include <stdio.h>
+#include <stdlib.h>
+#include <string.h>
+#include <unistd.h>
+#include <setjmp.h>
+#include <errno.h>
+#include <alloca.h>
+
+#ifdef HAVE_MMAP
+#include <sys/mman.h>
+#endif
+
+#if defined __GNUC__ && !defined __clang__
+#pragma GCC diagnostic ignored "-Wstringop-overflow"
+#endif
+
+#ifdef TEST
+
+#include <time.h>
+#include <timespec.h>
+#include <sys/wait.h>
+#include <errno.h>
+
+#include <X11/Xlib.h>
+#include <X11/extensions/Xrender.h>
+
+static void *
+xmalloc (size_t size)
+{
+ void *ptr;
+
+ ptr = malloc (size);
+
+ if (!ptr)
+ abort ();
+
+ return ptr;
+}
+
+MAYBE_UNUSED static void *
+xzalloc (size_t size)
+{
+ void *ptr;
+
+ ptr = calloc (1, size);
+
+ if (!ptr)
+ abort ();
+
+ return ptr;
+}
+
+static void *
+xrealloc (void *ptr, size_t size)
+{
+ void *new_ptr;
+
+ new_ptr = realloc (ptr, size);
+
+ if (!new_ptr)
+ abort ();
+
+ return new_ptr;
+}
+
+static void
+xfree (void *ptr)
+{
+ free (ptr);
+}
+
+/* Use this for functions that are static while building in test mode,
+ but are used outside as well. */
+#define TEST_STATIC static
+
+/* Needed for tests. */
+#define ARRAYELTS(arr) (sizeof (arr) / sizeof (arr)[0])
+
+/* Also necessary. */
+#define AVOID _Noreturn ATTRIBUTE_COLD void
+
+#else
+#define TEST_STATIC
+#include "lisp.h"
+#endif
+
+#define MIN(a, b) ((a) < (b) ? (a) : (b))
+#define MAX(a, b) ((a) > (b) ? (a) : (b))
+
+/* This file provides generic support for reading most TrueType fonts,
+ and some OpenType fonts with TrueType outlines, along with glyph
+ lookup, outline decomposition, and alpha mask generation from those
+ glyphs. It is intended to be used on any platform where proper
+ libraries such as FreeType are not easily available, and the native
+ font library is too limited for Emacs to support properly.
+
+ Unlike most popular libraries for handling fonts, no ``font'' or
+ ``face'' type is provided. Instead, routines and structure
+ definitions for accessing and making use of individual tables in a
+ font file are exported, which allows for flexibility in the rest of
+ Emacs.
+
+ Try not to keep this file too dependent on Emacs. Everything Lisp
+ related goes in sfntfont.c. The author wants to keep using it for
+ some other (free) software.
+
+ The source of reference is the TrueType Reference Manual, published
+ by Apple Computer, which is currently found at:
+
+ https://developer.apple.com/fonts/TrueType-Reference-Manual/
+
+ Apple's TrueType implementation is notably missing features
+ provided by Microsoft's extended OpenType scaler, such as the two
+ additional phantom points on the Y axis, and also behaves
+ differently, especially when it comes to considering phantom points
+ as anchors in compound glyphs.
+
+ As a result, do not expect this scaler to work well with Microsoft
+ fonts such as Arial. */
+
+
+
+/* Mapping between sfnt table names and their identifiers. */
+
+static uint32_t sfnt_table_names[] =
+ {
+ [SFNT_TABLE_CMAP] = 0x636d6170,
+ [SFNT_TABLE_GLYF] = 0x676c7966,
+ [SFNT_TABLE_HEAD] = 0x68656164,
+ [SFNT_TABLE_HHEA] = 0x68686561,
+ [SFNT_TABLE_HMTX] = 0x686d7478,
+ [SFNT_TABLE_LOCA] = 0x6c6f6361,
+ [SFNT_TABLE_MAXP] = 0x6d617870,
+ [SFNT_TABLE_NAME] = 0x6e616d65,
+ [SFNT_TABLE_META] = 0x6d657461,
+ [SFNT_TABLE_CVT ] = 0x63767420,
+ [SFNT_TABLE_FPGM] = 0x6670676d,
+ [SFNT_TABLE_PREP] = 0x70726570,
+ [SFNT_TABLE_FVAR] = 0x66766172,
+ [SFNT_TABLE_GVAR] = 0x67766172,
+ [SFNT_TABLE_CVAR] = 0x63766172,
+ [SFNT_TABLE_AVAR] = 0x61766172,
+ [SFNT_TABLE_OS_2] = 0x4f532f32,
+ [SFNT_TABLE_POST] = 0x706f7374,
+ };
+
+/* Swap values from TrueType to system byte order. */
+
+static void
+sfnt_swap16_1 (uint16_t *value)
+{
+#ifndef WORDS_BIGENDIAN
+ *value = bswap_16 (*value);
+#endif
+}
+
+static void
+sfnt_swap32_1 (uint32_t *value)
+{
+#ifndef WORDS_BIGENDIAN
+ *value = bswap_32 (*value);
+#endif
+}
+
+#define sfnt_swap16(what) (sfnt_swap16_1 ((uint16_t *) (what)))
+#define sfnt_swap32(what) (sfnt_swap32_1 ((uint32_t *) (what)))
+
+/* Read the table directory from the file FD. FD must currently be at
+ the start of the file (or an offset defined in the TTC header, if
+ applicable), and must be seekable. Return the table directory upon
+ success, else NULL.
+
+ Value is NULL upon failure, and the offset subtable upon success.
+ If FD is actually a TrueType collection file, value is -1. */
+
+TEST_STATIC struct sfnt_offset_subtable *
+sfnt_read_table_directory (int fd)
+{
+ struct sfnt_offset_subtable *subtable;
+ ssize_t rc;
+ size_t offset, subtable_size;
+ int i;
+
+ subtable = xmalloc (sizeof *subtable);
+ offset = SFNT_ENDOF (struct sfnt_offset_subtable,
+ range_shift, uint16_t);
+ rc = read (fd, subtable, offset);
+
+ if (rc == -1 || rc < offset)
+ {
+ if (rc != -1 && rc >= sizeof (uint32_t))
+ {
+ /* Detect a TTC file. In that case, the first long will be
+ ``ttcf''. */
+ sfnt_swap32 (&subtable->scaler_type);
+
+ if (subtable->scaler_type == SFNT_TTC_TTCF)
+ {
+ xfree (subtable);
+ return (struct sfnt_offset_subtable *) -1;
+ }
+ }
+
+ xfree (subtable);
+ return NULL;
+ }
+
+ sfnt_swap32 (&subtable->scaler_type);
+
+ /* Bail out early if this font is actually a TrueType collection
+ file. */
+
+ if (subtable->scaler_type == SFNT_TTC_TTCF)
+ {
+ xfree (subtable);
+ return (struct sfnt_offset_subtable *) -1;
+ }
+
+ sfnt_swap16 (&subtable->num_tables);
+ sfnt_swap16 (&subtable->search_range);
+ sfnt_swap16 (&subtable->entry_selector);
+ sfnt_swap16 (&subtable->range_shift);
+
+ /* Figure out how many more tables have to be read, and read each
+ one of them. */
+ subtable_size = (subtable->num_tables
+ * sizeof (struct sfnt_table_directory));
+ subtable = xrealloc (subtable, sizeof *subtable + subtable_size);
+ subtable->subtables
+ = (struct sfnt_table_directory *) (subtable + 1);
+
+ rc = read (fd, subtable->subtables, subtable_size);
+
+ if (rc == -1 || rc < offset)
+ {
+ xfree (subtable);
+ return NULL;
+ }
+
+ /* Swap each of the subtables. */
+
+ for (i = 0; i < subtable->num_tables; ++i)
+ {
+ sfnt_swap32 (&subtable->subtables[i].tag);
+ sfnt_swap32 (&subtable->subtables[i].checksum);
+ sfnt_swap32 (&subtable->subtables[i].offset);
+ sfnt_swap32 (&subtable->subtables[i].length);
+ }
+
+ return subtable;
+}
+
+/* Return a pointer to the table directory entry for TABLE in
+ SUBTABLE, or NULL if it was not found. */
+
+static struct sfnt_table_directory *
+sfnt_find_table (struct sfnt_offset_subtable *subtable,
+ enum sfnt_table table)
+{
+ int i;
+
+ for (i = 0; i < subtable->num_tables; ++i)
+ {
+ if (subtable->subtables[i].tag == sfnt_table_names[table])
+ return &subtable->subtables[i];
+ }
+
+ return NULL;
+}
+
+
+
+/* Character mapping routines. */
+
+/* Read a format 0 cmap subtable from FD. HEADER has already been
+ read. */
+
+static struct sfnt_cmap_format_0 *
+sfnt_read_cmap_format_0 (int fd,
+ struct sfnt_cmap_encoding_subtable_data *header)
+{
+ struct sfnt_cmap_format_0 *format0;
+ ssize_t rc;
+ size_t wanted_size;
+
+ format0 = xmalloc (sizeof *format0);
+
+ /* Fill in fields that have already been read. */
+ format0->format = header->format;
+ format0->length = header->length;
+
+ /* Read the rest. */
+ wanted_size = (sizeof *format0
+ - offsetof (struct sfnt_cmap_format_0,
+ language));
+ rc = read (fd, &format0->language, wanted_size);
+
+ if (rc == -1 || rc < wanted_size)
+ {
+ xfree (format0);
+ return (struct sfnt_cmap_format_0 *) -1;
+ }
+
+ /* Swap fields and return. */
+ sfnt_swap16 (&format0->language);
+ return format0;
+}
+
+/* Read a format 2 cmap subtable from FD. HEADER has already been
+ read. */
+
+static struct sfnt_cmap_format_2 *
+sfnt_read_cmap_format_2 (int fd,
+ struct sfnt_cmap_encoding_subtable_data *header)
+{
+ struct sfnt_cmap_format_2 *format2;
+ ssize_t rc;
+ size_t min_bytes;
+ int i, nsub;
+
+ /* Reject contents that are too small. */
+ min_bytes = SFNT_ENDOF (struct sfnt_cmap_format_2,
+ sub_header_keys, uint16_t[256]);
+ if (header->length < min_bytes)
+ return NULL;
+
+ /* Add enough bytes at the end to fit the two variable length
+ pointers. */
+ format2 = xmalloc (header->length + sizeof *format2);
+ format2->format = header->format;
+ format2->length = header->length;
+
+ /* Read the part before the variable length data. */
+ min_bytes -= offsetof (struct sfnt_cmap_format_2, language);
+ rc = read (fd, &format2->language, min_bytes);
+ if (rc == -1 || rc < min_bytes)
+ {
+ xfree (format2);
+ return (struct sfnt_cmap_format_2 *) -1;
+ }
+
+ /* Swap the fields now. */
+
+ sfnt_swap16 (&format2->language);
+
+ /* At the same time, look for the largest value in sub_header_keys.
+ That will be the number of subheaders and elements in the glyph
+ index array. */
+
+ nsub = 0;
+
+ for (i = 0; i < 256; ++i)
+ {
+ sfnt_swap16 (&format2->sub_header_keys[i]);
+
+ if (format2->sub_header_keys[i] > nsub)
+ nsub = format2->sub_header_keys[i];
+ }
+
+ if (!nsub)
+ /* If there are no subheaders, then things are finished. */
+ return format2;
+
+ /* Otherwise, read the rest of the variable length data to the end
+ of format2. */
+ min_bytes = (format2->length
+ - SFNT_ENDOF (struct sfnt_cmap_format_2,
+ sub_header_keys, uint16_t[256]));
+ rc = read (fd, format2 + 1, min_bytes);
+ if (rc == -1 || rc < min_bytes)
+ {
+ xfree (format2);
+ return (struct sfnt_cmap_format_2 *) -1;
+ }
+
+ /* Check whether or not the data is of the correct size. */
+ if (min_bytes < nsub * sizeof *format2->subheaders)
+ {
+ xfree (format2);
+ return (struct sfnt_cmap_format_2 *) -1;
+ }
+
+ /* Point the data pointers to the right location, swap everything,
+ and return. */
+
+ format2->subheaders
+ = (struct sfnt_cmap_format_2_subheader *) (format2 + 1);
+ format2->glyph_index_array
+ = (uint16_t *) (format2->subheaders + nsub);
+
+ for (i = 0; i < nsub; ++i)
+ {
+ sfnt_swap16 (&format2->subheaders[i].first_code);
+ sfnt_swap16 (&format2->subheaders[i].entry_count);
+ sfnt_swap16 (&format2->subheaders[i].id_delta);
+ sfnt_swap16 (&format2->subheaders[i].id_range_offset);
+ }
+
+ /* Figure out how big the glyph index array is, and swap everything
+ there. */
+ format2->num_glyphs
+ = (min_bytes - nsub * sizeof *format2->subheaders) / 2;
+
+ for (i = 0; i < format2->num_glyphs; ++i)
+ sfnt_swap16 (&format2->glyph_index_array[i]);
+
+ return format2;
+}
+
+/* Read a format 4 cmap subtable from FD. HEADER has already been
+ read. */
+
+static struct sfnt_cmap_format_4 *
+sfnt_read_cmap_format_4 (int fd,
+ struct sfnt_cmap_encoding_subtable_data *header)
+{
+ struct sfnt_cmap_format_4 *format4;
+ size_t min_bytes, variable_size;
+ ssize_t rc;
+ size_t bytes_minus_format4;
+ int seg_count, i;
+
+ min_bytes = SFNT_ENDOF (struct sfnt_cmap_format_4,
+ range_shift, uint16_t);
+
+ /* Check that the length is at least min_bytes. */
+ if (header->length < min_bytes)
+ return NULL;
+
+ /* Allocate the format4 buffer, making it the size of the buffer
+ itself plus that of the data. */
+ format4 = xmalloc (header->length + sizeof *format4);
+
+ /* Copy over fields that have already been read. */
+ format4->format = header->format;
+ format4->length = header->length;
+
+ /* Read the initial data. */
+ min_bytes -= offsetof (struct sfnt_cmap_format_4, language);
+ rc = read (fd, &format4->language, min_bytes);
+ if (rc == -1 || rc < min_bytes)
+ {
+ xfree (format4);
+ return (struct sfnt_cmap_format_4 *) -1;
+ }
+
+ /* Swap fields that have been read. */
+ sfnt_swap16 (&format4->language);
+ sfnt_swap16 (&format4->seg_count_x2);
+ sfnt_swap16 (&format4->search_range);
+ sfnt_swap16 (&format4->entry_selector);
+ sfnt_swap16 (&format4->range_shift);
+
+ /* Get the number of segments to read. */
+ seg_count = format4->seg_count_x2 / 2;
+
+ /* Now calculate whether or not the size is sufficiently large. */
+ bytes_minus_format4
+ = format4->length - SFNT_ENDOF (struct sfnt_cmap_format_4,
+ range_shift, uint16_t);
+ variable_size = (seg_count * sizeof *format4->end_code
+ + sizeof *format4->reserved_pad
+ + seg_count * sizeof *format4->start_code
+ + seg_count * sizeof *format4->id_delta
+ + seg_count * sizeof *format4->id_range_offset);
+
+ if (bytes_minus_format4 < variable_size)
+ {
+ /* Not enough bytes to fit the entire implied table
+ contents. */
+ xfree (format4);
+ return NULL;
+ }
+
+ /* Read the rest of the bytes to the end of format4. */
+ rc = read (fd, format4 + 1, bytes_minus_format4);
+ if (rc == -1 || rc < bytes_minus_format4)
+ {
+ xfree (format4);
+ return (struct sfnt_cmap_format_4 *) -1;
+ }
+
+ /* Set data pointers to the right locations. */
+ format4->end_code = (uint16_t *) (format4 + 1);
+ format4->reserved_pad = format4->end_code + seg_count;
+ format4->start_code = format4->reserved_pad + 1;
+ format4->id_delta = (int16_t *) (format4->start_code + seg_count);
+ format4->id_range_offset = format4->id_delta + seg_count;
+ format4->glyph_index_array = (uint16_t *) (format4->id_range_offset
+ + seg_count);
+
+ /* N.B. that the number of elements in glyph_index_array is
+ (bytes_minus_format4 - variable_size) / 2. Swap all the
+ data. */
+
+ sfnt_swap16 (format4->reserved_pad);
+
+ for (i = 0; i < seg_count; ++i)
+ {
+ sfnt_swap16 (&format4->end_code[i]);
+ sfnt_swap16 (&format4->start_code[i]);
+ sfnt_swap16 (&format4->id_delta[i]);
+ sfnt_swap16 (&format4->id_range_offset[i]);
+ }
+
+ format4->glyph_index_size
+ = (bytes_minus_format4 - variable_size) / 2;
+
+ for (i = 0; i < format4->glyph_index_size; ++i)
+ sfnt_swap16 (&format4->glyph_index_array[i]);
+
+ /* Done. Return the format 4 character map. */
+ return format4;
+}
+
+/* Read a format 6 cmap subtable from FD. HEADER has already been
+ read. */
+
+static struct sfnt_cmap_format_6 *
+sfnt_read_cmap_format_6 (int fd,
+ struct sfnt_cmap_encoding_subtable_data *header)
+{
+ struct sfnt_cmap_format_6 *format6;
+ size_t min_size;
+ ssize_t rc;
+ uint16_t i;
+
+ min_size = SFNT_ENDOF (struct sfnt_cmap_format_6, entry_count,
+ uint16_t);
+
+ /* See if header->length is big enough. */
+ if (header->length < min_size)
+ return NULL;
+
+ /* Allocate the buffer to hold header->size and enough for at least
+ the glyph index array pointer. */
+ format6 = xmalloc (header->length + sizeof *format6);
+
+ /* Fill in data that has already been read. */
+ format6->format = header->format;
+ format6->length = header->length;
+
+ /* Read the fixed size data. */
+ min_size -= offsetof (struct sfnt_cmap_format_6, language);
+ rc = read (fd, &format6->language, min_size);
+ if (rc == -1 || rc < min_size)
+ {
+ xfree (format6);
+ return (struct sfnt_cmap_format_6 *) -1;
+ }
+
+ /* Swap what was read. */
+ sfnt_swap16 (&format6->language);
+ sfnt_swap16 (&format6->first_code);
+ sfnt_swap16 (&format6->entry_count);
+
+ /* Figure out whether or not header->length is sufficient to hold
+ the variable length data. */
+ if (header->length
+ < format6->entry_count * sizeof *format6->glyph_index_array)
+ {
+ xfree (format6);
+ return NULL;
+ }
+
+ /* Read the variable length data. */
+ rc = read (fd, format6 + 1,
+ (format6->entry_count
+ * sizeof *format6->glyph_index_array));
+ if (rc == -1 || (rc < (format6->entry_count
+ * sizeof *format6->glyph_index_array)))
+ {
+ xfree (format6);
+ return (struct sfnt_cmap_format_6 *) -1;
+ }
+
+ /* Set the data pointer and swap everything. */
+ format6->glyph_index_array = (uint16_t *) (format6 + 1);
+ for (i = 0; i < format6->entry_count; ++i)
+ sfnt_swap16 (&format6->glyph_index_array[i]);
+
+ /* All done! */
+ return format6;
+}
+
+/* Read a format 8 cmap subtable from FD. HEADER has already been
+ read. */
+
+static struct sfnt_cmap_format_8 *
+sfnt_read_cmap_format_8 (int fd,
+ struct sfnt_cmap_encoding_subtable_data *header)
+{
+ struct sfnt_cmap_format_8 *format8;
+ size_t min_size, temp;
+ ssize_t rc;
+ uint32_t length, i;
+
+ /* Read the 32-bit length field. */
+ if (read (fd, &length, sizeof length) < (int) sizeof length)
+ return (struct sfnt_cmap_format_8 *) -1;
+
+ /* Swap the 32-bit length field. */
+ sfnt_swap32 (&length);
+
+ min_size = SFNT_ENDOF (struct sfnt_cmap_format_8, num_groups,
+ uint32_t);
+
+ /* Make sure the header is at least as large as min_size. */
+ if (length < min_size)
+ return NULL;
+
+ /* Allocate a buffer of sufficient size. */
+ format8 = xmalloc (length + sizeof *format8);
+ format8->format = header->format;
+ format8->reserved = header->length;
+ format8->length = length;
+
+ /* Read the fixed length data. */
+ min_size -= offsetof (struct sfnt_cmap_format_8, language);
+ rc = read (fd, &format8->language, min_size);
+ if (rc == -1 || rc < min_size)
+ {
+ xfree (format8);
+ return (struct sfnt_cmap_format_8 *) -1;
+ }
+
+ /* Swap what was read. */
+ sfnt_swap32 (&format8->language);
+ sfnt_swap32 (&format8->num_groups);
+
+ /* See if the size is sufficient to read the variable length
+ data. */
+ min_size = SFNT_ENDOF (struct sfnt_cmap_format_8, num_groups,
+ uint32_t);
+
+ if (ckd_mul (&temp, format8->num_groups, sizeof *format8->groups))
+ {
+ xfree (format8);
+ return NULL;
+ }
+
+ if (ckd_add (&min_size, min_size, temp))
+ {
+ xfree (format8);
+ return NULL;
+ }
+
+ if (length < min_size)
+ {
+ xfree (format8);
+ return NULL;
+ }
+
+ /* Now read the variable length data. */
+ rc = read (fd, format8 + 1, temp);
+ if (rc == -1 || rc < temp)
+ {
+ xfree (format8);
+ return (struct sfnt_cmap_format_8 *) -1;
+ }
+
+ /* Set the pointer to the variable length data. */
+ format8->groups
+ = (struct sfnt_cmap_format_8_or_12_group *) (format8 + 1);
+
+ for (i = 0; i < format8->num_groups; ++i)
+ {
+ sfnt_swap32 (&format8->groups[i].start_char_code);
+ sfnt_swap32 (&format8->groups[i].end_char_code);
+ sfnt_swap32 (&format8->groups[i].start_glyph_code);
+ }
+
+ /* All done. */
+ return format8;
+}
+
+/* Read a format 12 cmap subtable from FD. HEADER has already been
+ read. */
+
+static struct sfnt_cmap_format_12 *
+sfnt_read_cmap_format_12 (int fd,
+ struct sfnt_cmap_encoding_subtable_data *header)
+{
+ struct sfnt_cmap_format_12 *format12;
+ size_t min_size, temp;
+ ssize_t rc;
+ uint32_t length, i;
+
+ /* Read the 32-bit length field. */
+ if (read (fd, &length, sizeof length) < (int) sizeof length)
+ return (struct sfnt_cmap_format_12 *) -1;
+
+ /* Swap the 32-bit length field. */
+ sfnt_swap32 (&length);
+
+ min_size = SFNT_ENDOF (struct sfnt_cmap_format_12, num_groups,
+ uint32_t);
+
+ /* Make sure the header is at least as large as min_size. */
+ if (length < min_size)
+ return NULL;
+
+ /* Allocate a buffer of sufficient size. */
+ format12 = xmalloc (length + sizeof *format12);
+ format12->format = header->format;
+ format12->reserved = header->length;
+ format12->length = length;
+
+ /* Read the fixed length data. */
+ min_size -= offsetof (struct sfnt_cmap_format_12, language);
+ rc = read (fd, &format12->language, min_size);
+ if (rc == -1 || rc < min_size)
+ {
+ xfree (format12);
+ return (struct sfnt_cmap_format_12 *) -1;
+ }
+
+ /* Swap what was read. */
+ sfnt_swap32 (&format12->language);
+ sfnt_swap32 (&format12->num_groups);
+
+ /* See if the size is sufficient to read the variable length
+ data. */
+ min_size = SFNT_ENDOF (struct sfnt_cmap_format_12, num_groups,
+ uint32_t);
+
+ if (ckd_mul (&temp, format12->num_groups, sizeof *format12->groups))
+ {
+ xfree (format12);
+ return NULL;
+ }
+
+ if (ckd_add (&min_size, min_size, temp))
+ {
+ xfree (format12);
+ return NULL;
+ }
+
+ if (length < min_size)
+ {
+ xfree (format12);
+ return NULL;
+ }
+
+ /* Now read the variable length data. */
+ rc = read (fd, format12 + 1, temp);
+ if (rc == -1 || rc < temp)
+ {
+ xfree (format12);
+ return (struct sfnt_cmap_format_12 *) -1;
+ }
+
+ /* Set the pointer to the variable length data. */
+ format12->groups
+ = (struct sfnt_cmap_format_8_or_12_group *) (format12 + 1);
+
+ for (i = 0; i < format12->num_groups; ++i)
+ {
+ sfnt_swap32 (&format12->groups[i].start_char_code);
+ sfnt_swap32 (&format12->groups[i].end_char_code);
+ sfnt_swap32 (&format12->groups[i].start_glyph_code);
+ }
+
+ /* All done. */
+ return format12;
+}
+
+/* Read a 3-byte big endian number from BYTES. */
+
+static unsigned int
+sfnt_read_24 (unsigned char *bytes)
+{
+ return (bytes[0] << 16u) | (bytes[1] << 8u) | bytes[2];
+}
+
+/* Read a format 14 cmap table from FD. HEADER->format will be 14 and
+ HEADER->length will be 0; the 16-bit length field is not read.
+ OFFSET is the offset of the table's header in the font file.
+
+ Only variation selector records will be read. UVS tables will
+ not. */
+
+static struct sfnt_cmap_format_14 *
+sfnt_read_cmap_format_14 (int fd,
+ struct sfnt_cmap_encoding_subtable_data *header,
+ off_t offset)
+{
+ struct sfnt_cmap_format_14 *format14;
+ uint32_t length;
+ uint32_t num_records;
+ uint32_t buffer1[2];
+ size_t size, temp;
+ char buffer[3 + 4 + 4];
+ uint32_t i;
+
+ /* Read the length field and number of variation selector
+ records. */
+
+ if (read (fd, buffer1, sizeof buffer1) < (int) sizeof buffer1)
+ return NULL;
+
+ length = buffer1[0];
+ num_records = buffer1[1];
+
+ sfnt_swap32 (&length);
+ sfnt_swap32 (&num_records);
+
+ /* Now, the number of records present is known. Allocate the format
+ 14 cmap table. */
+
+ size = sizeof *format14;
+ if (ckd_mul (&temp, num_records, sizeof *format14->records)
+ || ckd_add (&size, size, temp))
+ return NULL;
+
+ format14 = xmalloc (size);
+
+ /* Fill in the data already read. */
+ format14->format = header->format;
+ format14->length = length;
+ format14->num_var_selector_records = num_records;
+ format14->offset = offset;
+
+ /* Set the pointer to the remaining record data. */
+ format14->records
+ = (struct sfnt_variation_selector_record *) (format14 + 1);
+
+ /* Read each variation selector record. */
+
+ for (i = 0; i < num_records; ++i)
+ {
+ if (read (fd, buffer, sizeof buffer) < (int) sizeof buffer)
+ {
+ xfree (format14);
+ return NULL;
+ }
+
+ /* First, read the 24 bit variation selector. */
+ format14->records[i].var_selector
+ = sfnt_read_24 ((unsigned char *) buffer);
+
+ /* Next, read the two unaligned longs. */
+ memcpy (&format14->records[i].default_uvs_offset,
+ buffer + 3,
+ sizeof format14->records[i].default_uvs_offset);
+ memcpy (&format14->records[i].nondefault_uvs_offset,
+ buffer + 7,
+ sizeof format14->records[i].nondefault_uvs_offset);
+
+ /* And swap them. */
+ sfnt_swap32 (&format14->records[i].default_uvs_offset);
+ sfnt_swap32 (&format14->records[i].nondefault_uvs_offset);
+ }
+
+ /* Return the format 14 character mapping table. */
+ return format14;
+}
+
+/* Read the CMAP subtable data from a given file FD at TABLE_OFFSET
+ bytes from DIRECTORY_OFFSET. Return the subtable data if it is
+ supported. Else, value is NULL if the format is unsupported, or -1
+ upon an IO error. */
+
+static struct sfnt_cmap_encoding_subtable_data *
+sfnt_read_cmap_table_1 (int fd, uint32_t directory_offset,
+ uint32_t table_offset)
+{
+ off_t offset;
+ struct sfnt_cmap_encoding_subtable_data header;
+
+ if (ckd_add (&offset, directory_offset, table_offset))
+ return (struct sfnt_cmap_encoding_subtable_data *) -1;
+
+ if (lseek (fd, offset, SEEK_SET) == (off_t) -1)
+ return (struct sfnt_cmap_encoding_subtable_data *) -1;
+
+ if (read (fd, &header.format, sizeof header.format)
+ < (int) sizeof header.format)
+ return (struct sfnt_cmap_encoding_subtable_data *) -1;
+
+ sfnt_swap16 (&header.format);
+
+ /* Format 14 tables are rather special: they do not have a 16-bit
+ `length' field. When these tables are encountered, leave reading
+ the rest of the header to `sfnt_read_cmap_table_14'. */
+
+ if (header.format != 14)
+ {
+ if (read (fd, &header.length, sizeof header.length)
+ < (int) sizeof header.length)
+ return (struct sfnt_cmap_encoding_subtable_data *) -1;
+
+ sfnt_swap16 (&header.length);
+ }
+ else
+ header.length = 0;
+
+ switch (header.format)
+ {
+ case 0:
+ /* If the length changes, then something has changed to the
+ format. */
+ if (header.length != 262)
+ return NULL;
+
+ return ((struct sfnt_cmap_encoding_subtable_data *)
+ sfnt_read_cmap_format_0 (fd, &header));
+
+ case 2:
+ return ((struct sfnt_cmap_encoding_subtable_data *)
+ sfnt_read_cmap_format_2 (fd, &header));
+
+ case 4:
+ return ((struct sfnt_cmap_encoding_subtable_data *)
+ sfnt_read_cmap_format_4 (fd, &header));
+
+ case 6:
+ return ((struct sfnt_cmap_encoding_subtable_data *)
+ sfnt_read_cmap_format_6 (fd, &header));
+
+ case 8:
+ return ((struct sfnt_cmap_encoding_subtable_data *)
+ sfnt_read_cmap_format_8 (fd, &header));
+
+ case 12:
+ return ((struct sfnt_cmap_encoding_subtable_data *)
+ sfnt_read_cmap_format_12 (fd, &header));
+
+ case 14:
+ return ((struct sfnt_cmap_encoding_subtable_data *)
+ sfnt_read_cmap_format_14 (fd, &header, offset));
+
+ default:
+ return NULL;
+ }
+}
+
+/* Read the CMAP table of a given font from the file FD. Use the
+ table directory specified in SUBTABLE.
+
+ Return the CMAP table and a list of encoding subtables in
+ *SUBTABLES and *DATA upon success, else NULL. If DATA is NULL, do
+ not read the subtable data. */
+
+TEST_STATIC struct sfnt_cmap_table *
+sfnt_read_cmap_table (int fd, struct sfnt_offset_subtable *subtable,
+ struct sfnt_cmap_encoding_subtable **subtables,
+ struct sfnt_cmap_encoding_subtable_data ***data)
+{
+ struct sfnt_table_directory *directory;
+ struct sfnt_cmap_table *cmap;
+ ssize_t rc;
+ int i, j;
+
+ /* Find the CMAP table in the table directory. */
+ directory = sfnt_find_table (subtable, SFNT_TABLE_CMAP);
+
+ if (!directory)
+ return NULL;
+
+ /* Seek to the start of the CMAP table. */
+ if (lseek (fd, directory->offset, SEEK_SET) == (off_t) -1)
+ return NULL;
+
+ /* Read the table header. */
+ cmap = xmalloc (sizeof *cmap);
+ rc = read (fd, cmap, sizeof *cmap);
+
+ if (rc < (int) sizeof *cmap)
+ {
+ xfree (cmap);
+ return NULL;
+ }
+
+ /* Swap the header data. */
+ sfnt_swap16 (&cmap->version);
+ sfnt_swap16 (&cmap->num_subtables);
+
+ if (cmap->version != 0)
+ {
+ xfree (cmap);
+ return NULL;
+ }
+
+ *subtables = xmalloc (cmap->num_subtables
+ * sizeof **subtables);
+
+
+ /* First, read the common parts of each encoding subtable. */
+
+ for (i = 0; i < cmap->num_subtables; ++i)
+ {
+ /* Read the common part of the new subtable. */
+ rc = read (fd, &(*subtables)[i], sizeof (*subtables)[i]);
+
+ if (rc < (int) sizeof (*subtables)[i])
+ {
+ xfree (cmap);
+ xfree (*subtables);
+ return NULL;
+ }
+
+ sfnt_swap16 (&(*subtables)[i].platform_id);
+ sfnt_swap16 (&(*subtables)[i].platform_specific_id);
+ sfnt_swap32 (&(*subtables)[i].offset);
+ }
+
+ /* If data is NULL, the caller only wants the table headers. */
+
+ if (!data)
+ return cmap;
+
+ /* Second, read each encoding subtable itself. */
+ *data = xmalloc (cmap->num_subtables * sizeof *data);
+
+ for (i = 0; i < cmap->num_subtables; ++i)
+ {
+ (*data)[i] = sfnt_read_cmap_table_1 (fd, directory->offset,
+ (*subtables)[i].offset);
+
+ if ((*data)[i] == (void *) -1)
+ {
+ /* An IO error occurred (as opposed to the subtable format
+ being unsupported.) Return now. */
+
+ for (j = 0; j < i; ++j)
+ xfree ((*data)[j]);
+
+ xfree (*data);
+ xfree (*subtables);
+ xfree (cmap);
+ return NULL;
+ }
+ }
+
+ return cmap;
+}
+
+/* Look up the glyph corresponding to CHARACTER in the format 0 cmap
+ FORMAT0. Return 0 if no glyph was found. */
+
+static sfnt_glyph
+sfnt_lookup_glyph_0 (sfnt_char character,
+ struct sfnt_cmap_format_0 *format0)
+{
+ if (character >= 256)
+ return 0;
+
+ return format0->glyph_index_array[character];
+}
+
+/* Look up the glyph corresponding to CHARACTER in the format 2 cmap
+ FORMAT2. Return 0 if no glyph was found. */
+
+static sfnt_glyph
+sfnt_lookup_glyph_2 (sfnt_char character,
+ struct sfnt_cmap_format_2 *format2)
+{
+ unsigned char i, k, j;
+ struct sfnt_cmap_format_2_subheader *subheader;
+ unsigned char *slice;
+ uint16_t glyph;
+
+ if (character > 65335)
+ return 0;
+
+ i = character >> 16;
+ j = character & 0xff;
+ k = format2->sub_header_keys[i] / 8;
+
+ if (k)
+ {
+ subheader = &format2->subheaders[k];
+
+ if (subheader->first_code <= j
+ && j <= ((int) subheader->first_code
+ + (int) subheader->entry_count))
+ {
+ /* id_range_offset is actually the number of bytes past
+ itself containing the uint16_t ``slice''. It is possibly
+ unaligned. */
+ slice = (unsigned char *) &subheader->id_range_offset;
+ slice += subheader->id_range_offset;
+ slice += (j - subheader->first_code) * sizeof (uint16_t);
+
+ if (slice < (unsigned char *) format2->glyph_index_array
+ || (slice + 1
+ > (unsigned char *) (format2->glyph_index_array
+ + format2->num_glyphs)))
+ /* The character is out of bounds. */
+ return 0;
+
+ memcpy (&glyph, slice, sizeof glyph);
+ return (glyph + subheader->id_delta) % 65536;
+ }
+ else
+ return 0;
+ }
+
+ /* k is 0, so glyph_index_array[i] is the glyph. */
+ return (i < format2->num_glyphs
+ ? format2->glyph_index_array[i]
+ : 0);
+}
+
+/* Like `bsearch', but return the element ordered exactly above KEY if
+ one exists and KEY itself cannot be located. */
+
+static void *
+sfnt_bsearch_above (const void *key, const void *base,
+ size_t nmemb, size_t size,
+ int (*compar) (const void *,
+ const void *))
+{
+ const unsigned char *bytes, *sample;
+ size_t low, high, mid;
+
+ bytes = base;
+ low = 0;
+ high = nmemb - 1;
+
+ if (!nmemb)
+ return NULL;
+
+ while (low != high)
+ {
+ mid = low + (high - low) / 2;
+ sample = bytes + mid * size;
+
+ if ((*compar) (key, sample) > 0)
+ low = mid + 1;
+ else
+ high = mid;
+ }
+
+ sample = bytes + low * size;
+
+ if (low == nmemb - 1
+ && (*compar) (key, sample) > 0)
+ return NULL;
+
+ return (unsigned char *) bytes + low * size;
+}
+
+/* Compare two uint16_t's. Used to bisect through a format 4
+ table. */
+
+static int
+sfnt_compare_uint16 (const void *a, const void *b)
+{
+ return ((int) *((uint16_t *) a)) - ((int) *((uint16_t *) b));
+}
+
+/* Look up the glyph corresponding to CODE in the format 4 cmap
+ FORMAT4, using the table segment SEGMENT. Value is 0 if no glyph
+ was found. */
+
+static sfnt_glyph
+sfnt_lookup_glyph_4_1 (uint16_t code, uint16_t segment,
+ struct sfnt_cmap_format_4 *format4)
+{
+ uint16_t *index;
+
+ if (format4->id_range_offset[segment])
+ {
+ /* id_range_offset is not 0, so the glyph mapping depends on
+ it. */
+ index = (uint16_t *) (&format4->id_range_offset[segment]
+ + format4->id_range_offset[segment] / 2
+ + (code - format4->start_code[segment]));
+
+ /* Check that index is not out of bounds. */
+ if (index >= (format4->glyph_index_array
+ + format4->glyph_index_size)
+ || index < format4->glyph_index_array)
+ return 0;
+
+ /* Return what is in index. */
+ return (*index ? (format4->id_delta[segment]
+ + *index) % 65536 : 0);
+ }
+
+ /* Otherwise, just add id_delta. */
+ return (format4->id_delta[segment] + code) % 65536;
+}
+
+/* Look up the glyph corresponding to CHARACTER in the format 4 cmap
+ FORMAT4. Return 0 if no glyph was found. */
+
+static sfnt_glyph
+sfnt_lookup_glyph_4 (sfnt_char character,
+ struct sfnt_cmap_format_4 *format4)
+{
+ uint16_t *segment_address;
+ uint16_t code, segment;
+ sfnt_glyph glyph;
+
+ if (character > 65535)
+ return 0;
+
+ code = character;
+
+ /* Find the segment ending above or at CHARACTER. */
+ segment_address = sfnt_bsearch_above (&code, format4->end_code,
+ format4->seg_count_x2 / 2,
+ sizeof code,
+ sfnt_compare_uint16);
+ segment = segment_address - format4->end_code;
+
+ /* If the segment starts too late, return 0. */
+ if (!segment_address || format4->start_code[segment] > character)
+ return 0;
+
+ glyph = sfnt_lookup_glyph_4_1 (character, segment, format4);
+
+ if (glyph)
+ return glyph;
+
+ /* Fail. */
+ return 0;
+}
+
+/* Look up the glyph corresponding to CHARACTER in the format 6 cmap
+ FORMAT6. Return 0 if no glyph was found. */
+
+static sfnt_glyph
+sfnt_lookup_glyph_6 (sfnt_char character,
+ struct sfnt_cmap_format_6 *format6)
+{
+ if (character < format6->first_code
+ || character >= (format6->first_code
+ + (int) format6->entry_count))
+ return 0;
+
+ return format6->glyph_index_array[character - format6->first_code];
+}
+
+/* Compare the sfnt_char A with B's end code. Employed to bisect
+ through a format 8 or 12 table. */
+
+static int
+sfnt_compare_char (const void *a, const void *b)
+{
+ struct sfnt_cmap_format_8_or_12_group *group;
+
+ group = (struct sfnt_cmap_format_8_or_12_group *) b;
+
+ return ((int) *((sfnt_char *) a)) - group->end_char_code;
+}
+
+/* Look up the glyph corresponding to CHARACTER in the format 8 cmap
+ FORMAT8. Return 0 if no glyph was found. */
+
+static sfnt_glyph
+sfnt_lookup_glyph_8 (sfnt_char character,
+ struct sfnt_cmap_format_8 *format8)
+{
+ uint32_t i;
+ struct sfnt_cmap_format_8_or_12_group *group;
+
+ if (character > 0xffffffff)
+ return 0;
+
+ if (format8->num_groups > 64)
+ {
+ /* This table is large, likely supplied by a CJK or similar
+ font. Perform a binary search. */
+
+ /* Find the group whose END_CHAR_CODE is greater than or equal
+ to CHARACTER. */
+
+ group = sfnt_bsearch_above (&character, format8->groups,
+ format8->num_groups,
+ sizeof format8->groups[0],
+ sfnt_compare_char);
+
+ if (!group || group->start_char_code > character)
+ /* No glyph matches this group. */
+ return 0;
+
+ /* Otherwise, use this group to map the character to a
+ glyph. */
+ return (group->start_glyph_code
+ + character
+ - group->start_char_code);
+ }
+
+ for (i = 0; i < format8->num_groups; ++i)
+ {
+ if (format8->groups[i].start_char_code <= character
+ && format8->groups[i].end_char_code >= character)
+ return (format8->groups[i].start_glyph_code
+ + (character
+ - format8->groups[i].start_char_code));
+ }
+
+ return 0;
+}
+
+/* Look up the glyph corresponding to CHARACTER in the format 12 cmap
+ FORMAT12. Return 0 if no glyph was found. */
+
+static sfnt_glyph
+sfnt_lookup_glyph_12 (sfnt_char character,
+ struct sfnt_cmap_format_12 *format12)
+{
+ uint32_t i;
+ struct sfnt_cmap_format_8_or_12_group *group;
+
+ if (character > 0xffffffff)
+ return 0;
+
+ if (format12->num_groups > 64)
+ {
+ /* This table is large, likely supplied by a CJK or similar
+ font. Perform a binary search. */
+
+ /* Find the group whose END_CHAR_CODE is greater than or equal
+ to CHARACTER. */
+
+ group = sfnt_bsearch_above (&character, format12->groups,
+ format12->num_groups,
+ sizeof format12->groups[0],
+ sfnt_compare_char);
+
+ if (!group || group->start_char_code > character)
+ /* No glyph matches this group. */
+ return 0;
+
+ /* Otherwise, use this group to map the character to a
+ glyph. */
+ return (group->start_glyph_code
+ + character
+ - group->start_char_code);
+ }
+
+ for (i = 0; i < format12->num_groups; ++i)
+ {
+ if (format12->groups[i].start_char_code <= character
+ && format12->groups[i].end_char_code >= character)
+ return (format12->groups[i].start_glyph_code
+ + (character
+ - format12->groups[i].start_char_code));
+ }
+
+ return 0;
+}
+
+/* Look up the glyph index corresponding to the character CHARACTER,
+ which must be in the correct encoding for the cmap table pointed to
+ by DATA.
+
+ DATA must be either a format 0, 2, 4, 6, 8 or 12 cmap table, else
+ behavior is undefined. */
+
+TEST_STATIC sfnt_glyph
+sfnt_lookup_glyph (sfnt_char character,
+ struct sfnt_cmap_encoding_subtable_data *data)
+{
+ switch (data->format)
+ {
+ case 0:
+ return sfnt_lookup_glyph_0 (character,
+ (struct sfnt_cmap_format_0 *) data);
+
+ case 2:
+ return sfnt_lookup_glyph_2 (character,
+ (struct sfnt_cmap_format_2 *) data);
+
+ case 4:
+ return sfnt_lookup_glyph_4 (character,
+ (struct sfnt_cmap_format_4 *) data);
+
+ case 6:
+ return sfnt_lookup_glyph_6 (character,
+ (struct sfnt_cmap_format_6 *) data);
+
+ case 8:
+ return sfnt_lookup_glyph_8 (character,
+ (struct sfnt_cmap_format_8 *) data);
+
+ case 12:
+ return sfnt_lookup_glyph_12 (character,
+ (struct sfnt_cmap_format_12 *) data);
+ }
+
+ return 0;
+}
+
+
+
+/* Header reading routines. */
+
+/* Read the head table of a given font FD. Use the table directory
+ specified in SUBTABLE.
+
+ Return the head table upon success, else NULL. */
+
+TEST_STATIC struct sfnt_head_table *
+sfnt_read_head_table (int fd, struct sfnt_offset_subtable *subtable)
+{
+ struct sfnt_table_directory *directory;
+ struct sfnt_head_table *head;
+ ssize_t rc;
+
+ /* Find the table in the directory. */
+
+ directory = sfnt_find_table (subtable, SFNT_TABLE_HEAD);
+
+ if (!directory)
+ return NULL;
+
+ /* Seek to the location given in the directory. */
+ if (lseek (fd, directory->offset, SEEK_SET) == (off_t) -1)
+ return NULL;
+
+ /* Read the entire table. */
+ head = xmalloc (sizeof *head);
+ rc = read (fd, head, sizeof *head);
+
+ if (rc < (int) sizeof *head)
+ {
+ xfree (head);
+ return NULL;
+ }
+
+ /* Swap the header data. */
+ sfnt_swap32 (&head->version);
+ sfnt_swap32 (&head->revision);
+
+ if (head->version != 0x00010000)
+ {
+ xfree (head);
+ return NULL;
+ }
+
+ /* Swap the rest of the data. */
+ sfnt_swap32 (&head->checksum_adjustment);
+ sfnt_swap32 (&head->magic);
+
+ if (head->magic != 0x5f0f3cf5)
+ {
+ xfree (head);
+ return NULL;
+ }
+
+ sfnt_swap16 (&head->flags);
+ sfnt_swap16 (&head->units_per_em);
+ sfnt_swap32 (&head->created_high);
+ sfnt_swap32 (&head->created_low);
+ sfnt_swap32 (&head->modified_high);
+ sfnt_swap32 (&head->modified_low);
+ sfnt_swap16 (&head->xmin);
+ sfnt_swap16 (&head->xmax);
+ sfnt_swap16 (&head->ymin);
+ sfnt_swap16 (&head->ymax);
+ sfnt_swap16 (&head->mac_style);
+ sfnt_swap16 (&head->lowest_rec_ppem);
+ sfnt_swap16 (&head->font_direction_hint);
+ sfnt_swap16 (&head->index_to_loc_format);
+ sfnt_swap16 (&head->glyph_data_format);
+
+ return head;
+}
+
+/* Read the hhea table of a given font FD. Use the table directory
+ specified in SUBTABLE.
+
+ Return the head table upon success, else NULL. */
+
+TEST_STATIC struct sfnt_hhea_table *
+sfnt_read_hhea_table (int fd, struct sfnt_offset_subtable *subtable)
+{
+ struct sfnt_table_directory *directory;
+ struct sfnt_hhea_table *hhea;
+ ssize_t rc;
+
+ /* Find the table in the directory. */
+
+ directory = sfnt_find_table (subtable, SFNT_TABLE_HHEA);
+
+ if (!directory)
+ return NULL;
+
+ /* Check the length is right. */
+ if (directory->length != sizeof *hhea)
+ return NULL;
+
+ /* Seek to the location given in the directory. */
+ if (lseek (fd, directory->offset, SEEK_SET) == (off_t) -1)
+ return NULL;
+
+ /* Read the entire table. */
+ hhea = xmalloc (sizeof *hhea);
+ rc = read (fd, hhea, sizeof *hhea);
+
+ if (rc < (int) sizeof *hhea)
+ {
+ xfree (hhea);
+ return NULL;
+ }
+
+ /* Swap the header data. */
+ sfnt_swap32 (&hhea->version);
+
+ if (hhea->version != 0x00010000)
+ {
+ xfree (hhea);
+ return NULL;
+ }
+
+ /* Swap the rest of the data. */
+ sfnt_swap16 (&hhea->ascent);
+ sfnt_swap16 (&hhea->descent);
+ sfnt_swap16 (&hhea->line_gap);
+ sfnt_swap16 (&hhea->advance_width_max);
+ sfnt_swap16 (&hhea->min_left_side_bearing);
+ sfnt_swap16 (&hhea->min_right_side_bearing);
+ sfnt_swap16 (&hhea->x_max_extent);
+ sfnt_swap16 (&hhea->caret_slope_rise);
+ sfnt_swap16 (&hhea->caret_slope_run);
+ sfnt_swap16 (&hhea->reserved1);
+ sfnt_swap16 (&hhea->reserved2);
+ sfnt_swap16 (&hhea->reserved3);
+ sfnt_swap16 (&hhea->reserved4);
+ sfnt_swap16 (&hhea->metric_data_format);
+ sfnt_swap16 (&hhea->num_of_long_hor_metrics);
+
+ return hhea;
+}
+
+/* Read a short loca table from the given font FD. Use the table
+ directory specified in SUBTABLE.
+
+ Return the short table upon success, else NULL. */
+
+TEST_STATIC struct sfnt_loca_table_short *
+sfnt_read_loca_table_short (int fd, struct sfnt_offset_subtable *subtable)
+{
+ struct sfnt_table_directory *directory;
+ struct sfnt_loca_table_short *loca;
+ ssize_t rc;
+ int i;
+
+ /* Find the table in the directory. */
+
+ directory = sfnt_find_table (subtable, SFNT_TABLE_LOCA);
+
+ if (!directory)
+ return NULL;
+
+ /* Seek to the location given in the directory. */
+ if (lseek (fd, directory->offset, SEEK_SET) == (off_t) -1)
+ return NULL;
+
+ /* Figure out how many glyphs there are based on the length. */
+ loca = xmalloc (sizeof *loca + directory->length);
+ loca->offsets = (uint16_t *) (loca + 1);
+ loca->num_offsets = directory->length / 2;
+
+ /* Read the variable-length table data. */
+ rc = read (fd, loca->offsets, directory->length);
+ if (rc < directory->length)
+ {
+ xfree (loca);
+ return NULL;
+ }
+
+ /* Swap each of the offsets. */
+ for (i = 0; i < loca->num_offsets; ++i)
+ sfnt_swap16 (&loca->offsets[i]);
+
+ /* Return the table. */
+ return loca;
+}
+
+/* Read a long loca table from the given font FD. Use the table
+ directory specified in SUBTABLE.
+
+ Return the long table upon success, else NULL. */
+
+TEST_STATIC struct sfnt_loca_table_long *
+sfnt_read_loca_table_long (int fd, struct sfnt_offset_subtable *subtable)
+{
+ struct sfnt_table_directory *directory;
+ struct sfnt_loca_table_long *loca;
+ ssize_t rc;
+ int i;
+
+ /* Find the table in the directory. */
+
+ directory = sfnt_find_table (subtable, SFNT_TABLE_LOCA);
+
+ if (!directory)
+ return NULL;
+
+ /* Seek to the location given in the directory. */
+ if (lseek (fd, directory->offset, SEEK_SET) == (off_t) -1)
+ return NULL;
+
+ /* Figure out how many glyphs there are based on the length. */
+ loca = xmalloc (sizeof *loca + directory->length);
+ loca->offsets = (uint32_t *) (loca + 1);
+ loca->num_offsets = directory->length / 4;
+
+ /* Read the variable-length table data. */
+ rc = read (fd, loca->offsets, directory->length);
+ if (rc < directory->length)
+ {
+ xfree (loca);
+ return NULL;
+ }
+
+ /* Swap each of the offsets. */
+ for (i = 0; i < loca->num_offsets; ++i)
+ sfnt_swap32 (&loca->offsets[i]);
+
+ /* Return the table. */
+ return loca;
+}
+
+/* Read the maxp table from the given font FD. Use the table
+ directory specified in SUBTABLE.
+
+ Return the maxp table upon success, else NULL. If the version is
+ 0.5, fields past num_glyphs will not be populated. */
+
+TEST_STATIC struct sfnt_maxp_table *
+sfnt_read_maxp_table (int fd, struct sfnt_offset_subtable *subtable)
+{
+ struct sfnt_table_directory *directory;
+ struct sfnt_maxp_table *maxp;
+ size_t size;
+ ssize_t rc;
+
+ /* Find the table in the directory. */
+
+ directory = sfnt_find_table (subtable, SFNT_TABLE_MAXP);
+
+ if (!directory)
+ return NULL;
+
+ /* Seek to the location given in the directory. */
+ if (lseek (fd, directory->offset, SEEK_SET) == (off_t) -1)
+ return NULL;
+
+ /* If directory->length is not big enough for version 0.5, punt. */
+ if (directory->length < SFNT_ENDOF (struct sfnt_maxp_table,
+ num_glyphs, uint16_t))
+ return NULL;
+
+ /* Allocate the buffer to hold the data. Then, read
+ directory->length or sizeof *maxp bytes into it, whichever is
+ smaller. */
+
+ maxp = xmalloc (sizeof *maxp);
+ size = MIN (directory->length, sizeof *maxp);
+ rc = read (fd, maxp, size);
+
+ if (rc == -1 || rc < size)
+ {
+ xfree (maxp);
+ return NULL;
+ }
+
+ /* Now, swap version and num_glyphs. */
+ sfnt_swap32 (&maxp->version);
+ sfnt_swap16 (&maxp->num_glyphs);
+
+ /* Reject version 1.0 tables that are too small. */
+ if (maxp->version > 0x00005000 && size < sizeof *maxp)
+ {
+ xfree (maxp);
+ return NULL;
+ }
+
+ /* If the table is version 0.5, then this function is done. */
+ if (maxp->version == 0x00005000)
+ return maxp;
+ else if (maxp->version != 0x00010000)
+ {
+ /* Reject invalid versions. */
+ xfree (maxp);
+ return NULL;
+ }
+
+ /* Otherwise, swap the rest of the fields. */
+ sfnt_swap16 (&maxp->max_points);
+ sfnt_swap16 (&maxp->max_contours);
+ sfnt_swap16 (&maxp->max_composite_points);
+ sfnt_swap16 (&maxp->max_composite_contours);
+ sfnt_swap16 (&maxp->max_zones);
+ sfnt_swap16 (&maxp->max_twilight_points);
+ sfnt_swap16 (&maxp->max_storage);
+ sfnt_swap16 (&maxp->max_function_defs);
+ sfnt_swap16 (&maxp->max_instruction_defs);
+ sfnt_swap16 (&maxp->max_stack_elements);
+ sfnt_swap16 (&maxp->max_size_of_instructions);
+ sfnt_swap16 (&maxp->max_component_elements);
+ sfnt_swap16 (&maxp->max_component_depth);
+
+ /* All done. */
+ return maxp;
+}
+
+
+
+/* Glyph outlining generation. */
+
+/* Read a glyf table from the given font FD. Use the table directory
+ specified in SUBTABLE. The glyph data is not swapped.
+
+ Return the glyf table upon success, else NULL. */
+
+TEST_STATIC struct sfnt_glyf_table *
+sfnt_read_glyf_table (int fd, struct sfnt_offset_subtable *subtable)
+{
+ struct sfnt_table_directory *directory;
+ struct sfnt_glyf_table *glyf;
+ ssize_t rc;
+
+ /* Find the table in the directory. */
+
+ directory = sfnt_find_table (subtable, SFNT_TABLE_GLYF);
+
+ if (!directory)
+ return NULL;
+
+ /* Seek to the location given in the directory. */
+ if (lseek (fd, directory->offset, SEEK_SET) == (off_t) -1)
+ return NULL;
+
+ /* Allocate enough to hold everything. */
+ glyf = xmalloc (sizeof *glyf + directory->length);
+ glyf->size = directory->length;
+ glyf->glyphs = (unsigned char *) (glyf + 1);
+
+ /* Read the glyph data. */
+ rc = read (fd, glyf->glyphs, glyf->size);
+ if (rc == -1 || rc < glyf->size)
+ {
+ xfree (glyf);
+ return NULL;
+ }
+
+ /* Return the table. */
+ return glyf;
+}
+
+#if defined HAVE_MMAP && !defined TEST
+
+/* Map a glyph table from the given font FD. Use the table directory
+ specified in SUBTABLE. The glyph data is not byte-swapped.
+
+ Value is the glyf table upon success, else NULL.
+ A mapped glyf table must be unmapped using `sfnt_unmap_glyf_table'.
+ The caller must correctly handle bus errors in between glyf->table
+ and glyf->size. */
+
+struct sfnt_glyf_table *
+sfnt_map_glyf_table (int fd, struct sfnt_offset_subtable *subtable)
+{
+ struct sfnt_table_directory *directory;
+ struct sfnt_glyf_table *glyf;
+ void *glyphs;
+ size_t offset, page, map_offset;
+
+ /* Find the table in the directory. */
+
+ directory = sfnt_find_table (subtable, SFNT_TABLE_GLYF);
+
+ if (!directory)
+ return NULL;
+
+ /* Now try to map the glyph data. Make sure offset is a multiple of
+ the page size. */
+
+ page = getpagesize ();
+ offset = directory->offset & ~(page - 1);
+
+ /* Figure out how much larger the mapping should be. */
+ map_offset = directory->offset - offset;
+
+ /* Do the mmap. */
+ glyphs = mmap (NULL, directory->length + map_offset,
+ PROT_READ, MAP_PRIVATE, fd, offset);
+
+ if (glyphs == MAP_FAILED)
+ return NULL;
+
+ /* An observation is that glyphs tend to be accessed in sequential
+ order and immediately after the font's glyph table is loaded. */
+
+#ifdef HAVE_POSIX_MADVISE
+ posix_madvise (glyphs, directory->length,
+ POSIX_MADV_WILLNEED);
+#elif defined HAVE_MADVISE
+ madvise (glyphs, directory->length, MADV_WILLNEED);
+#endif
+
+ /* Allocate the glyf table. */
+ glyf = xmalloc (sizeof *glyf);
+ glyf->size = directory->length;
+ glyf->glyphs = (unsigned char *) glyphs + map_offset;
+ glyf->start = glyphs;
+
+ return glyf;
+}
+
+/* Unmap the mmap'ed glyf table GLYF, then free its associated data.
+ Value is 0 upon success, else 1, in which case GLYF is still freed
+ all the same. */
+
+int
+sfnt_unmap_glyf_table (struct sfnt_glyf_table *glyf)
+{
+ int rc;
+ size_t size;
+
+ /* Calculate the size of the mapping. */
+ size = glyf->size + (glyf->glyphs - glyf->start);
+
+ rc = munmap (glyf->start, size);
+ xfree (glyf);
+
+ return rc != 0;
+}
+
+#endif /* HAVE_MMAP */
+
+/* Read the simple glyph outline from the glyph GLYPH from the
+ specified glyf table at the given offset. Set GLYPH->simple to a
+ non-NULL value upon success, else set it to NULL. */
+
+static void
+sfnt_read_simple_glyph (struct sfnt_glyph *glyph,
+ struct sfnt_glyf_table *glyf,
+ size_t offset)
+{
+ struct sfnt_simple_glyph *simple;
+ ssize_t min_size, min_size_2;
+ int i, number_of_points, repeat_count;
+ unsigned char *instructions_start;
+ unsigned char *flags_start, *flags_end;
+ unsigned char *vec_start;
+ int16_t delta, x, y;
+
+ /* Calculate the minimum size of the glyph data. This is the size
+ of the instruction length field followed by
+ glyph->number_of_contours * sizeof (uint16_t). */
+
+ min_size = (glyph->number_of_contours * sizeof (uint16_t)
+ + sizeof (uint16_t));
+
+ /* Check that the size is big enough. */
+ if (glyf->size < offset + min_size)
+ {
+ glyph->simple = NULL;
+ return;
+ }
+
+ /* Allocate enough to read at least that. */
+ simple = xmalloc (sizeof *simple + min_size);
+ simple->end_pts_of_contours = (uint16_t *) (simple + 1);
+ memcpy (simple->end_pts_of_contours, glyf->glyphs + offset,
+ min_size);
+
+ /* This is not really an index into simple->end_pts_of_contours.
+ Rather, it is reading the first word past it. */
+ simple->instruction_length
+ = simple->end_pts_of_contours[glyph->number_of_contours];
+
+ /* Swap the contour end point indices and the instruction
+ length. */
+
+ for (i = 0; i < glyph->number_of_contours; ++i)
+ sfnt_swap16 (&simple->end_pts_of_contours[i]);
+
+ sfnt_swap16 (&simple->instruction_length);
+
+ /* Based on those values, calculate the maximum size of the
+ following data. This is the instruction length + the last
+ contour point + the last contour point * uint16_t * 2. */
+
+ if (glyph->number_of_contours)
+ number_of_points
+ = simple->end_pts_of_contours[glyph->number_of_contours - 1] + 1;
+ else
+ number_of_points = 0;
+
+ min_size_2 = (simple->instruction_length
+ + number_of_points
+ + (number_of_points
+ * sizeof (uint16_t) * 2));
+
+ /* Set simple->number_of_points. */
+ simple->number_of_points = number_of_points;
+
+ /* Make simple big enough. */
+ simple = xrealloc (simple, sizeof *simple + min_size + min_size_2);
+ simple->end_pts_of_contours = (uint16_t *) (simple + 1);
+
+ /* Set the instruction data pointer and other pointers.
+ simple->instructions comes one word past number_of_contours,
+ because end_pts_of_contours also contains the instruction
+ length. */
+
+ simple->x_coordinates = (int16_t *) (simple->end_pts_of_contours
+ + glyph->number_of_contours + 1);
+ simple->y_coordinates = simple->x_coordinates + number_of_points;
+ simple->instructions = (uint8_t *) (simple->y_coordinates + number_of_points);
+ simple->flags = simple->instructions + simple->instruction_length;
+
+ /* Read instructions into the glyph. */
+ instructions_start = glyf->glyphs + offset + min_size;
+
+ if (instructions_start >= glyf->glyphs + glyf->size
+ || (instructions_start + simple->instruction_length
+ >= glyf->glyphs + glyf->size))
+ {
+ glyph->simple = NULL;
+ xfree (simple);
+ return;
+ }
+
+ memcpy (simple->instructions, instructions_start,
+ simple->instruction_length);
+
+ /* Start reading flags. */
+ flags_start = (glyf->glyphs + offset
+ + min_size + simple->instruction_length);
+ flags_end = flags_start + number_of_points;
+
+ if (flags_start >= glyf->glyphs + glyf->size)
+ {
+ glyph->simple = NULL;
+ xfree (simple);
+ return;
+ }
+
+ i = 0;
+
+ while (flags_start < flags_end)
+ {
+ if (i == number_of_points)
+ break;
+
+ if (flags_start >= glyf->glyphs + glyf->size)
+ break;
+
+ simple->flags[i++] = *flags_start;
+
+ if (*flags_start & 010) /* REPEAT_FLAG */
+ {
+ /* The next byte specifies how many times this byte is to be
+ repeated. Check that it is in range. */
+
+ if (flags_start + 1 >= glyf->glyphs + glyf->size)
+ {
+ glyph->simple = NULL;
+ xfree (simple);
+ return;
+ }
+
+ /* Repeat the current flag until
+ glyph->number_of_points. */
+
+ repeat_count = *(flags_start + 1);
+
+ while (i < number_of_points && repeat_count)
+ {
+ simple->flags[i++] = *flags_start;
+ repeat_count--;
+ }
+
+ /* Skip one byte in flags_start. */
+ flags_start++;
+ }
+
+ flags_start++;
+ }
+
+ /* If an insufficient number of flags have been read, then the
+ outline is invalid. */
+
+ if (i != number_of_points)
+ {
+ glyph->simple = NULL;
+ xfree (simple);
+ return;
+ }
+
+ /* Now that the flags have been decoded, start decoding the
+ vectors. */
+ vec_start = flags_start;
+ i = 0;
+ x = 0;
+
+ /* flags_start is now repurposed to act as a pointer to the flags
+ for the current vector! */
+ flags_start = simple->flags;
+
+ while (i < number_of_points)
+ {
+ delta = 0;
+
+ if ((*flags_start) & 02) /* X_SHORT_VECTOR */
+ {
+ /* The next byte is a delta to apply to the previous
+ value. Make sure it is in bounds. */
+
+ if (vec_start + 1 > glyf->glyphs + glyf->size)
+ {
+ glyph->simple = NULL;
+ xfree (simple);
+ return;
+ }
+
+ delta = *vec_start++;
+
+ if (!(*flags_start & 020)) /* SAME_X */
+ delta = -delta;
+ }
+ else if (!(*flags_start & 020)) /* SAME_X */
+ {
+ /* The next word is a delta to apply to the previous value.
+ Make sure it is in bounds. */
+
+ if (vec_start + 2 > glyf->glyphs + glyf->size)
+ {
+ glyph->simple = NULL;
+ xfree (simple);
+ return;
+ }
+
+ /* Read the unaligned word and swap it. */
+ memcpy (&delta, vec_start, sizeof delta);
+ sfnt_swap16 (&delta);
+ vec_start += 2;
+ }
+
+ /* Apply the delta and set the X value. */
+ x += delta;
+ simple->x_coordinates[i++] = x;
+ flags_start++;
+ }
+
+ /* Decode the Y vector. flags_start is again repurposed to act as a
+ pointer to the flags for the current vector. */
+ flags_start = simple->flags;
+ y = 0;
+ i = 0;
+
+ while (i < number_of_points)
+ {
+ delta = 0;
+
+ if (*flags_start & 04) /* Y_SHORT_VECTOR */
+ {
+ /* The next byte is a delta to apply to the previous
+ value. Make sure it is in bounds. */
+
+ if (vec_start + 1 > glyf->glyphs + glyf->size)
+ {
+ glyph->simple = NULL;
+ xfree (simple);
+ return;
+ }
+
+ delta = *vec_start++;
+
+ if (!(*flags_start & 040)) /* SAME_Y */
+ delta = -delta;
+ }
+ else if (!(*flags_start & 040)) /* SAME_Y */
+ {
+ /* The next word is a delta to apply to the previous value.
+ Make sure it is in bounds. */
+
+ if (vec_start + 2 > glyf->glyphs + glyf->size)
+ {
+ glyph->simple = NULL;
+ xfree (simple);
+ return;
+ }
+
+ /* Read the unaligned word and swap it. */
+ memcpy (&delta, vec_start, sizeof delta);
+ sfnt_swap16 (&delta);
+ vec_start += 2;
+ }
+
+ /* Apply the delta and set the X value. */
+ y += delta;
+ simple->y_coordinates[i++] = y;
+ flags_start++;
+ }
+
+ /* All done. */
+ simple->y_coordinates_end = simple->y_coordinates + i;
+ glyph->simple = simple;
+ return;
+}
+
+/* Read the compound glyph outline from the glyph GLYPH from the
+ specified glyf table at the given offset. Set GLYPH->compound to a
+ non-NULL value upon success, else set it to NULL. */
+
+static void
+sfnt_read_compound_glyph (struct sfnt_glyph *glyph,
+ struct sfnt_glyf_table *glyf,
+ size_t offset)
+{
+ uint16_t flags, instruction_length, words[2], words4[4];
+ size_t required_bytes, num_components, i;
+ unsigned char *data, *instruction_base;
+
+ /* Assume failure for now. Figure out how many bytes have to be
+ allocated by reading the compound data. */
+ glyph->compound = NULL;
+ required_bytes = 0;
+ num_components = 0;
+ data = glyf->glyphs + offset;
+
+ /* Offset could be unaligned. */
+ do
+ {
+ if (data + 2 > glyf->glyphs + glyf->size)
+ return;
+
+ memcpy (&flags, data, sizeof flags);
+ sfnt_swap16 (&flags);
+ data += sizeof flags;
+
+ /* Require at least one structure to hold this data. */
+ required_bytes += sizeof (struct sfnt_compound_glyph_component);
+ num_components++;
+
+ /* Skip past unused data. */
+ data += 2;
+
+ if (flags & 01) /* ARG_1_AND_2_ARE_WORDS */
+ data += sizeof (int16_t) * 2;
+ else
+ data += sizeof (int8_t) * 2;
+
+ if (flags & 010) /* WE_HAVE_A_SCALE */
+ data += sizeof (uint16_t);
+ else if (flags & 0100) /* WE_HAVE_AN_X_AND_Y_SCALE */
+ data += sizeof (uint16_t) * 2;
+ else if (flags & 0200) /* WE_HAVE_A_TWO_BY_TWO */
+ data += sizeof (uint16_t) * 4;
+ }
+ while (flags & 040); /* MORE_COMPONENTS */
+
+ if (flags & 0400) /* WE_HAVE_INSTRUCTIONS */
+ {
+ /* Figure out the instruction length. */
+ if (data + 2 > glyf->glyphs + glyf->size)
+ return;
+
+ /* Now see how much is required to hold the instruction
+ data. */
+ memcpy (&instruction_length, data,
+ sizeof instruction_length);
+ sfnt_swap16 (&instruction_length);
+ required_bytes += instruction_length;
+ data += sizeof data + instruction_length;
+ }
+
+ /* Now allocate the buffer to hold all the glyph data. */
+ glyph->compound = xmalloc (sizeof *glyph->compound
+ + required_bytes);
+ glyph->compound->components
+ = (struct sfnt_compound_glyph_component *) (glyph->compound + 1);
+ glyph->compound->num_components = num_components;
+
+ /* Figure out where instruction data starts. It comes after
+ glyph->compound->components ends. */
+ instruction_base
+ = (unsigned char *) (glyph->compound->components
+ + glyph->compound->num_components);
+
+ /* Start reading. */
+ i = 0;
+ data = glyf->glyphs + offset;
+ do
+ {
+ if (data + 4 > glyf->glyphs + glyf->size)
+ {
+ xfree (glyph->compound);
+ glyph->compound = NULL;
+ return;
+ }
+
+ memcpy (&flags, data, sizeof flags);
+ sfnt_swap16 (&flags);
+ data += sizeof flags;
+ glyph->compound->components[i].flags = flags;
+
+ memcpy (&glyph->compound->components[i].glyph_index,
+ data, sizeof glyph->compound->components[i].glyph_index);
+ sfnt_swap16 (&glyph->compound->components[i].glyph_index);
+ data += sizeof glyph->compound->components[i].glyph_index;
+
+ if (flags & 01) /* ARG_1_AND_2_ARE_WORDS. */
+ {
+ if (data + 4 > glyf->glyphs + glyf->size)
+ {
+ xfree (glyph->compound);
+ glyph->compound = NULL;
+ return;
+ }
+
+ /* Read two words into arg1 and arg2. */
+ memcpy (words, data, sizeof words);
+ sfnt_swap16 (&words[0]);
+ sfnt_swap16 (&words[1]);
+
+ glyph->compound->components[i].argument1.c = words[0];
+ glyph->compound->components[i].argument2.c = words[1];
+ data += sizeof words;
+ }
+ else
+ {
+ if (data + 2 > glyf->glyphs + glyf->size)
+ {
+ xfree (glyph->compound);
+ glyph->compound = NULL;
+ return;
+ }
+
+ /* Read two bytes into arg1 and arg2. */
+ glyph->compound->components[i].argument1.a = data[0];
+ glyph->compound->components[i].argument2.a = data[1];
+ data += 2;
+ }
+
+ if (flags & 010) /* WE_HAVE_A_SCALE */
+ {
+ if (data + 2 > glyf->glyphs + glyf->size)
+ {
+ xfree (glyph->compound);
+ glyph->compound = NULL;
+ return;
+ }
+
+ /* Read one word into scale. */
+ memcpy (&glyph->compound->components[i].u.scale, data,
+ sizeof glyph->compound->components[i].u.scale);
+ sfnt_swap16 (&glyph->compound->components[i].u.scale);
+ data += sizeof glyph->compound->components[i].u.scale;
+ }
+ else if (flags & 0100) /* WE_HAVE_AN_X_AND_Y_SCALE. */
+ {
+ if (data + 4 > glyf->glyphs + glyf->size)
+ {
+ xfree (glyph->compound);
+ glyph->compound = NULL;
+ return;
+ }
+
+ /* Read two words into xscale and yscale. */
+ memcpy (words, data, sizeof words);
+ sfnt_swap16 (&words[0]);
+ sfnt_swap16 (&words[1]);
+
+ glyph->compound->components[i].u.a.xscale = words[0];
+ glyph->compound->components[i].u.a.yscale = words[1];
+ data += sizeof words;
+ }
+ else if (flags & 0200) /* WE_HAVE_A_TWO_BY_TWO */
+ {
+ if (data + 8 > glyf->glyphs + glyf->size)
+ {
+ xfree (glyph->compound);
+ glyph->compound = NULL;
+ return;
+ }
+
+ /* Read 4 words into the transformation matrix. */
+ memcpy (words4, data, sizeof words4);
+ sfnt_swap16 (&words4[0]);
+ sfnt_swap16 (&words4[1]);
+ sfnt_swap16 (&words4[2]);
+ sfnt_swap16 (&words4[3]);
+
+ glyph->compound->components[i].u.b.xscale = words4[0];
+ glyph->compound->components[i].u.b.scale01 = words4[1];
+ glyph->compound->components[i].u.b.scale10 = words4[2];
+ glyph->compound->components[i].u.b.yscale = words4[3];
+ data += sizeof words4;
+ }
+
+ /* Record the component flags. */
+ glyph->compound->components[i].flags = flags;
+
+ i++;
+ }
+ while (flags & 040); /* MORE_COMPONENTS */
+
+ if (flags & 0400) /* WE_HAVE_INSTR */
+ {
+ /* Figure out the instruction length. */
+ if (data + 2 > glyf->glyphs + glyf->size)
+ {
+ xfree (glyph->compound);
+ glyph->compound = NULL;
+ return;
+ }
+
+ /* Now see how much is required to hold the instruction
+ data. */
+ memcpy (&glyph->compound->instruction_length,
+ data,
+ sizeof glyph->compound->instruction_length);
+ sfnt_swap16 (&glyph->compound->instruction_length);
+ data += 2;
+
+ /* Read the instructions. */
+ glyph->compound->instructions = instruction_base;
+
+ if (data + glyph->compound->instruction_length
+ > glyf->glyphs + glyf->size)
+ {
+ xfree (glyph->compound);
+ glyph->compound = NULL;
+ return;
+ }
+
+ memcpy (instruction_base, data,
+ glyph->compound->instruction_length);
+ }
+ else
+ {
+ glyph->compound->instructions = NULL;
+ glyph->compound->instruction_length = 0;
+ }
+
+ /* Data read successfully. */
+ return;
+}
+
+/* Read the description of the glyph GLYPH_CODE from the specified
+ glyf table, using the offsets of LOCA_SHORT or LOCA_LONG, depending
+ on which is non-NULL. */
+
+TEST_STATIC struct sfnt_glyph *
+sfnt_read_glyph (sfnt_glyph glyph_code,
+ struct sfnt_glyf_table *glyf,
+ struct sfnt_loca_table_short *loca_short,
+ struct sfnt_loca_table_long *loca_long)
+{
+ struct sfnt_glyph glyph, *memory;
+ size_t offset, next_offset;
+
+ /* Check the glyph code is within bounds. */
+ if (glyph_code > 65535)
+ return NULL;
+
+ if (loca_short)
+ {
+ /* Check that the glyph is within bounds. glyph_code + 1 is the
+ entry in the table which defines the length of the glyph. */
+ if (glyph_code + 1 >= loca_short->num_offsets)
+ return NULL;
+
+ offset = loca_short->offsets[glyph_code] * 2;
+ next_offset = loca_short->offsets[glyph_code + 1] * 2;
+ }
+ else if (loca_long)
+ {
+ if (glyph_code + 1 >= loca_long->num_offsets)
+ return NULL;
+
+ offset = loca_long->offsets[glyph_code];
+ next_offset = loca_long->offsets[glyph_code + 1];
+ }
+ else
+ abort ();
+
+ /* If offset - next_offset is 0, then the glyph is empty. Its
+ horizontal advance may still be provided by the hmtx table. */
+
+ if (offset == next_offset)
+ {
+ glyph.number_of_contours = 0;
+ glyph.xmin = 0;
+ glyph.ymin = 0;
+ glyph.xmax = 0;
+ glyph.ymax = 0;
+ glyph.advance_distortion = 0;
+ glyph.origin_distortion = 0;
+ glyph.simple = xmalloc (sizeof *glyph.simple);
+ glyph.compound = NULL;
+ memset (glyph.simple, 0, sizeof *glyph.simple);
+ memory = xmalloc (sizeof *memory);
+ *memory = glyph;
+ return memory;
+ }
+
+ /* Verify that GLYF is big enough to hold a glyph at OFFSET. */
+ if (glyf->size < offset + SFNT_ENDOF (struct sfnt_glyph,
+ ymax, sfnt_fword))
+ return NULL;
+
+ /* Copy over the glyph data. */
+ memcpy (&glyph, glyf->glyphs + offset,
+ SFNT_ENDOF (struct sfnt_glyph,
+ ymax, sfnt_fword));
+
+ /* Swap the glyph data. */
+ sfnt_swap16 (&glyph.number_of_contours);
+ sfnt_swap16 (&glyph.xmin);
+ sfnt_swap16 (&glyph.ymin);
+ sfnt_swap16 (&glyph.xmax);
+ sfnt_swap16 (&glyph.ymax);
+
+ /* This is set later on after `sfnt_vary_X_glyph'. */
+ glyph.advance_distortion = 0;
+ glyph.origin_distortion = 0;
+
+ /* Figure out what needs to be read based on
+ glyph.number_of_contours. */
+ if (glyph.number_of_contours >= 0)
+ {
+ /* Read the simple glyph. */
+
+ glyph.compound = NULL;
+ sfnt_read_simple_glyph (&glyph, glyf,
+ offset + SFNT_ENDOF (struct sfnt_glyph,
+ ymax, sfnt_fword));
+
+ if (glyph.simple)
+ {
+ memory = xmalloc (sizeof glyph);
+ *memory = glyph;
+
+ return memory;
+ }
+ }
+ else
+ {
+ /* Read the compound glyph. */
+
+ glyph.simple = NULL;
+ sfnt_read_compound_glyph (&glyph, glyf,
+ offset + SFNT_ENDOF (struct sfnt_glyph,
+ ymax, sfnt_fword));
+
+ if (glyph.compound)
+ {
+ memory = xmalloc (sizeof glyph);
+ *memory = glyph;
+
+ return memory;
+ }
+ }
+
+ return NULL;
+}
+
+/* Free a glyph returned from sfnt_read_glyph. GLYPH may be NULL. */
+
+TEST_STATIC void
+sfnt_free_glyph (struct sfnt_glyph *glyph)
+{
+ if (!glyph)
+ return;
+
+ xfree (glyph->simple);
+ xfree (glyph->compound);
+ xfree (glyph);
+}
+
+
+
+/* Glyph outline decomposition. */
+
+/* Apply the transform in the compound glyph component COMPONENT to
+ the array of points of length NUM_COORDINATES given as X and Y.
+
+ Also, apply the fixed point offsets X_OFF and Y_OFF to each X and Y
+ coordinate after transforms within COMPONENT are effected. */
+
+static void
+sfnt_transform_coordinates (struct sfnt_compound_glyph_component *component,
+ sfnt_fixed *restrict x, sfnt_fixed *restrict y,
+ size_t num_coordinates,
+ sfnt_fixed x_off, sfnt_fixed y_off)
+{
+ double m1, m2, m3;
+ double m4, m5, m6;
+ size_t i;
+
+ if (component->flags & 010) /* WE_HAVE_A_SCALE */
+ {
+ m1 = component->u.scale / 16384.0;
+ m2 = m3 = m4 = 0;
+ m5 = component->u.scale / 16384.0;
+ m6 = 0;
+ }
+ else if (component->flags & 0100) /* WE_HAVE_AN_X_AND_Y_SCALE */
+ {
+ m1 = component->u.a.xscale / 16384.0;
+ m2 = m3 = m4 = 0;
+ m5 = component->u.a.yscale / 16384.0;
+ m6 = 0;
+ }
+ else if (component->flags & 0200) /* WE_HAVE_A_TWO_BY_TWO */
+ {
+ m1 = component->u.b.xscale / 16384.0;
+ m2 = component->u.b.scale01 / 16384.0;
+ m3 = 0;
+ m4 = component->u.b.scale10 / 16384.0;
+ m5 = component->u.b.yscale / 16384.0;
+ m6 = 0;
+ }
+ else /* No scale, just apply x_off and y_off. */
+ {
+ for (i = 0; i < num_coordinates; ++i)
+ x[i] += x_off, y[i] += y_off;
+
+ return;
+ }
+
+ m3 = x_off;
+ m6 = y_off;
+
+ /* Apply the specified affine transformation.
+ A transform looks like:
+
+ M1 M2 M3 X
+ M4 M5 M6 * Y
+
+ =
+
+ M1*X + M2*Y + M3*1 = X1
+ M4*X + M5*Y + M6*1 = Y1
+
+ (In most transforms, there is another row at the bottom for
+ mathematical reasons. Since Z1 is always 1.0, the row is simply
+ implied to be 0 0 1, because 0 * x + 0 * y + 1 * 1 = 1.0. See
+ the definition of matrix3x3 in image.c for some more explanations
+ about this.) */
+
+ for (i = 0; i < num_coordinates; ++i)
+ {
+ x[i] = m1 * x[i] + m2 * y[i] + m3 * 1;
+ y[i] = m4 * x[i] + m5 * y[i] + m6 * 1;
+ }
+}
+
+struct sfnt_compound_glyph_context
+{
+ /* Arrays of points. The underlying type is actually sfnt_f26dot6
+ when instructing a compound glyph. */
+ sfnt_fixed *x_coordinates, *y_coordinates;
+
+ /* Array of flags for the points. */
+ unsigned char *flags;
+
+ /* Number of points in that array, and the size of that array. */
+ size_t num_points, points_size;
+
+ /* Array of contour end points. */
+ size_t *contour_end_points;
+
+ /* Number of elements in and the size of that array. */
+ size_t num_end_points, end_points_size;
+
+ /* The X positions of two phantom points marking this glyph's origin
+ and advance position, only used while interpreting the glyph. */
+ sfnt_f26dot6 phantom_point_1_x, phantom_point_2_x;
+
+ /* Y positions. */
+ sfnt_f26dot6 phantom_point_1_y, phantom_point_2_y;
+
+ /* Unrounded X positions. */
+ sfnt_f26dot6 phantom_point_1_s, phantom_point_2_s;
+};
+
+/* Extend the arrays inside the compound glyph decomposition context
+ CONTEXT. NUMBER_OF_CONTOURS is the number of contours to add.
+ NUMBER_OF_POINTS is the number of points to add.
+
+ Return pointers to the beginning of the extension in *X_BASE,
+ *Y_BASE, *FLAGS_BASE and *CONTOUR_BASE. Value zero upon success,
+ and something else on failure. */
+
+static int
+sfnt_expand_compound_glyph_context (struct sfnt_compound_glyph_context *context,
+ size_t number_of_contours,
+ size_t number_of_points,
+ sfnt_fixed **x_base, sfnt_fixed **y_base,
+ unsigned char **flags_base,
+ size_t **contour_base)
+{
+ size_t size_bytes;
+
+ /* Add each field while checking for overflow. */
+ if (ckd_add (&context->num_end_points, number_of_contours,
+ context->num_end_points))
+ return 1;
+
+ if (ckd_add (&context->num_points, number_of_points, context->num_points))
+ return 1;
+
+ /* Reallocate each array to the new size if necessary. */
+ if (context->points_size < context->num_points)
+ {
+ if (ckd_mul (&context->points_size, context->num_points, 2))
+ context->points_size = context->num_points;
+
+ if (ckd_mul (&size_bytes, context->points_size,
+ sizeof *context->x_coordinates))
+ return 1;
+
+ context->x_coordinates = xrealloc (context->x_coordinates,
+ size_bytes);
+ context->y_coordinates = xrealloc (context->y_coordinates,
+ size_bytes);
+ context->flags = xrealloc (context->flags,
+ context->points_size);
+ }
+
+ /* Set x_base and y_base. */
+ *x_base = (context->x_coordinates
+ + context->num_points
+ - number_of_points);
+ *y_base = (context->y_coordinates
+ + context->num_points
+ - number_of_points);
+ *flags_base = (context->flags
+ + context->num_points
+ - number_of_points);
+
+ if (context->end_points_size < context->num_end_points)
+ {
+ if (ckd_mul (&context->end_points_size, context->num_end_points, 2))
+ context->end_points_size = context->num_end_points;
+
+ if (ckd_mul (&size_bytes, context->end_points_size,
+ sizeof *context->contour_end_points))
+ return 1;
+
+ context->contour_end_points
+ = xrealloc (context->contour_end_points,
+ size_bytes);
+ }
+
+ /* Set contour_base. */
+ *contour_base = (context->contour_end_points
+ + context->num_end_points
+ - number_of_contours);
+ return 0;
+}
+
+/* Round the 16.16 fixed point number NUMBER to the nearest integral
+ value. */
+
+static int32_t
+sfnt_round_fixed (int32_t number)
+{
+ /* Add 0.5... */
+ number += (1 << 15);
+
+ /* Remove the fractional. */
+ return number & ~0xffff;
+}
+
+/* Decompose GLYPH, a compound glyph, into an array of points and
+ contours.
+
+ CONTEXT should be zeroed and put on the stack. RECURSION_COUNT
+ should be initialized to 0. GET_GLYPH, FREE_GLYPH, and
+ GET_METRICS, along with DCONTEXT, mean the same as in
+ sfnt_decompose_glyph.
+
+ If it has been arranged that a component's metrics (or those of an
+ innermore component also with the flag set) replace the metrics of
+ GLYPH, set *METRICS_RETURN to those metrics. Mind that such
+ metrics are not scaled in any manner.
+
+ Value is 1 upon failure, else 0. */
+
+static int
+sfnt_decompose_compound_glyph (struct sfnt_glyph *glyph,
+ struct sfnt_compound_glyph_context *context,
+ struct sfnt_glyph_metrics *metrics_return,
+ sfnt_get_glyph_proc get_glyph,
+ sfnt_free_glyph_proc free_glyph,
+ sfnt_get_metrics_proc get_metrics,
+ int recursion_count,
+ void *dcontext)
+{
+ struct sfnt_glyph *subglyph;
+ int i, j, rc;
+ bool need_free;
+ struct sfnt_compound_glyph_component *component;
+ sfnt_fixed x, y, xtemp, ytemp;
+ size_t point UNINIT, point2 UNINIT, index;
+ uint16_t last_point, number_of_contours;
+ sfnt_fixed *x_base, *y_base;
+ size_t *contour_base;
+ unsigned char *flags_base;
+ size_t base_index, contour_start;
+ bool defer_offsets;
+ struct sfnt_glyph_metrics sub_metrics;
+ sfnt_fixed f1, f2;
+
+ /* Set up the base index. This is the index from where on point
+ renumbering starts.
+
+ In other words, point 0 in this glyph will be 0 + base_index,
+ point 1 will be 1 + base_index, and so on. */
+ base_index = context->num_points;
+
+ /* Prevent infinite loops. Simply limit the level of nesting to the
+ maximum valid value of `max_component_depth', which is 16. */
+
+ if (recursion_count > 16)
+ return 1;
+
+ for (j = 0; j < glyph->compound->num_components; ++j)
+ {
+ /* Look up the associated subglyph. */
+ component = &glyph->compound->components[j];
+ subglyph = get_glyph (component->glyph_index,
+ dcontext, &need_free);
+
+ if (!subglyph)
+ return 1;
+
+ /* Don't defer offsets. This variable is set if the component
+ glyph is a compound glyph that is anchored to a previously
+ decomposed point, and needs its coordinates adjusted after
+ decomposition completes. */
+ defer_offsets = false;
+
+ /* Record the size of the point array before expansion. This
+ will be the base to apply to all points coming from this
+ subglyph. */
+ contour_start = context->num_points;
+
+ /* Compute the offset for the component. */
+ if (component->flags & 02) /* ARGS_ARE_XY_VALUES */
+ {
+ /* Component offsets are X/Y values as opposed to points
+ GLYPH. */
+
+ if (!(component->flags & 01)) /* ARG_1_AND_2_ARE_WORDS */
+ {
+ /* X and Y are signed bytes. */
+ x = component->argument1.b * 65536;
+ y = component->argument2.b * 65536;
+ }
+ else
+ {
+ /* X and Y are signed words. */
+ x = component->argument1.d * 65536;
+ y = component->argument2.d * 65536;
+ }
+
+ /* If there is some kind of scale and component offsets are
+ scaled, then apply the transform to the offset. */
+ if (component->flags & 04000) /* SCALED_COMPONENT_OFFSET */
+ sfnt_transform_coordinates (component, &x, &y, 1,
+ 0, 0);
+ }
+ else
+ {
+ /* The offset is determined by matching a point location in
+ a preceding component with a point location in the
+ current component. The index of the point in the
+ previous component can be determined by adding
+ component->argument1.a or component->argument1.c to
+ point. argument2 contains the index of the point in the
+ current component. */
+
+ if (!(component->flags & 01)) /* ARG_1_AND_2_ARE_WORDS */
+ {
+ point = base_index + component->argument1.a;
+ point2 = component->argument2.a;
+ }
+ else
+ {
+ point = base_index + component->argument1.c;
+ point2 = component->argument2.c;
+ }
+
+ /* Now, check that the anchor point specified lies inside
+ the glyph. */
+
+ if (point >= contour_start)
+ {
+ if (need_free)
+ free_glyph (subglyph, dcontext);
+
+ return 1;
+ }
+
+ if (!subglyph->compound)
+ {
+ if (point2 >= subglyph->simple->number_of_points)
+ {
+ if (point2 < subglyph->simple->number_of_points + 2)
+ {
+ /* POINT2 is one of SUBGLYPH's phantom points.
+ Retrieve the glyph's metrics. */
+
+ if ((*get_metrics) (component->glyph_index, &sub_metrics,
+ dcontext))
+ {
+ if (need_free)
+ free_glyph (subglyph, dcontext);
+
+ return 1;
+ }
+
+ /* Derive the phantom points from those metrics. */
+ f1 = glyph->xmin - sub_metrics.lbearing;
+ f2 = f1 + sub_metrics.advance;
+
+ /* Apply the metrics distortion. */
+ f1 += glyph->origin_distortion;
+ f2 += glyph->advance_distortion;
+
+ /* Get the points and use them to compute the offsets. */
+
+ if (!(point2 - subglyph->simple->number_of_points))
+ x = f1 * 65536;
+ else
+ x = f2 * 65536;
+
+ x = context->x_coordinates[point] - x;
+ y = context->y_coordinates[point];
+
+ /* X and Y offsets have been ascertained. */
+ goto skip_computation;
+ }
+
+ if (need_free)
+ free_glyph (subglyph, dcontext);
+
+ return 1;
+ }
+
+ /* Get the points and use them to compute the offsets. */
+ xtemp = context->x_coordinates[point];
+ ytemp = context->y_coordinates[point];
+ x = (xtemp - subglyph->simple->x_coordinates[point2] * 65536);
+ y = (ytemp - subglyph->simple->y_coordinates[point2] * 65536);
+
+ skip_computation:
+ ;
+ }
+ else
+ {
+ /* First, set offsets to 0, because it is not yet
+ possible to determine the position of the anchor
+ point in the child. */
+ x = 0;
+ y = 0;
+
+ /* Set a flag which indicates that offsets must be
+ resolved from the child glyph after it is loaded, but
+ before it is incorporated into the parent glyph. */
+ defer_offsets = true;
+ }
+ }
+
+ if (subglyph->simple)
+ {
+ /* Simple subglyph. Copy over the points and contours, and
+ transform them. */
+ if (subglyph->number_of_contours)
+ {
+ index = subglyph->number_of_contours - 1;
+ last_point
+ = subglyph->simple->end_pts_of_contours[index];
+ number_of_contours = subglyph->number_of_contours;
+
+
+ /* Grow various arrays. */
+ rc = sfnt_expand_compound_glyph_context (context,
+ /* Number of
+ new contours
+ required. */
+ number_of_contours,
+ /* Number of new
+ points
+ required. */
+ last_point + 1,
+ &x_base,
+ &y_base,
+ &flags_base,
+ &contour_base);
+ if (rc)
+ {
+ if (need_free)
+ free_glyph (subglyph, dcontext);
+
+ return 1;
+ }
+
+ for (i = 0; i <= last_point; ++i)
+ {
+ x_base[i] = (subglyph->simple->x_coordinates[i] * 65536);
+ y_base[i] = (subglyph->simple->y_coordinates[i] * 65536);
+ flags_base[i] = subglyph->simple->flags[i];
+ }
+
+ /* Apply the transform to the points. */
+ sfnt_transform_coordinates (component, x_base, y_base,
+ last_point + 1, x, y);
+
+ /* Copy over the contours. */
+ for (i = 0; i < number_of_contours; ++i)
+ contour_base[i]
+ = (contour_start
+ + subglyph->simple->end_pts_of_contours[i]);
+
+ /* If USE_MY_METRICS is present within this component,
+ save its metrics within *METRICS_RETURN. */
+
+ if (component->flags & 01000 /* USE_MY_METRICS */)
+ {
+ if ((*get_metrics) (component->glyph_index,
+ metrics_return, dcontext))
+ {
+ if (need_free)
+ free_glyph (subglyph, dcontext);
+
+ return 1;
+ }
+
+ /* Refer to the comment above sfnt_decompose_glyph
+ for reasons and manner in which these offsets are
+ applied. */
+ metrics_return->lbearing -= subglyph->origin_distortion;
+ metrics_return->advance += subglyph->advance_distortion;
+ }
+ }
+ }
+ else
+ {
+ /* If USE_MY_METRICS, save this subglyph's metrics within
+ sub_metrics; they might be overwritten by metrics for
+ subglyphs of this compound subglyph in turn. */
+
+ if (component->flags & 01000 /* USE_MY_METRICS */)
+ {
+ if ((*get_metrics) (component->glyph_index,
+ &sub_metrics, dcontext))
+ {
+ if (need_free)
+ free_glyph (subglyph, dcontext);
+
+ return 1;
+ }
+
+ /* Refer to the comment above sfnt_decompose_glyph for
+ reasons and manner in which these offsets are
+ applied. */
+ sub_metrics.lbearing -= subglyph->origin_distortion;
+ sub_metrics.advance += subglyph->advance_distortion;
+ }
+
+ /* Compound subglyph. Decompose the glyph recursively, and
+ then apply the transform. */
+ rc = sfnt_decompose_compound_glyph (subglyph,
+ context,
+ &sub_metrics,
+ get_glyph,
+ free_glyph,
+ get_metrics,
+ recursion_count + 1,
+ dcontext);
+
+ if (rc)
+ {
+ if (need_free)
+ free_glyph (subglyph, dcontext);
+
+ return 1;
+ }
+
+ if (component->flags & 01000 /* USE_MY_METRICS */)
+ /* Save sub_metrics inside *metrics_return as stated
+ above. */
+ *metrics_return = sub_metrics;
+
+ /* When an anchor point is being used to translate the
+ glyph, and the subglyph in question is actually a
+ compound glyph, it is impossible to know which offset to
+ use until the compound subglyph has actually been loaded.
+
+ defer_offsets is set to true if these conditions apply,
+ whereupon the offset is calculated here, using the points
+ in the loaded child compound glyph. */
+
+ if (defer_offsets)
+ {
+ /* Renumber the non renumbered point2 to point into the
+ decomposed component. */
+ point2 += contour_start;
+
+ /* Next, check that the non-renumbered point being
+ anchored lies inside the glyph data that was
+ decomposed. */
+
+ if (point2 >= context->num_points)
+ {
+ /* POINT2 might fall within the phantom points of
+ that glyph. */
+
+ if (point2 - context->num_points < 2)
+ {
+ if ((*get_metrics) (component->glyph_index, &sub_metrics,
+ dcontext))
+ goto error_in_defer_offsets;
+
+ /* Derive the phantom points from those metrics. */
+ f1 = glyph->xmin - sub_metrics.lbearing;
+ f2 = f1 + sub_metrics.advance;
+
+ /* Apply the metrics distortion. */
+ f1 += glyph->origin_distortion;
+ f2 += glyph->advance_distortion;
+
+ /* Get the points and use them to compute the offsets. */
+
+ if (!(point2 - context->num_points))
+ x = f1 * 65536;
+ else
+ x = f2 * 65536;
+
+ x = context->x_coordinates[point] - x;
+ y = context->y_coordinates[point];
+
+ /* X and Y offsets have been ascertained. */
+ goto skip_computation_from_defer_offsets;
+ }
+
+ error_in_defer_offsets:
+ if (need_free)
+ free_glyph (subglyph, dcontext);
+
+ return 1;
+ }
+
+ /* Get the points and use them to compute the
+ offsets. */
+
+ xtemp = context->x_coordinates[point];
+ ytemp = context->y_coordinates[point];
+ x = (xtemp - context->x_coordinates[point2]);
+ y = (ytemp - context->y_coordinates[point2]);
+
+ skip_computation_from_defer_offsets:
+ ;
+ }
+
+ sfnt_transform_coordinates (component,
+ context->x_coordinates + contour_start,
+ context->y_coordinates + contour_start,
+ context->num_points - contour_start,
+ x, y);
+ }
+
+ if (need_free)
+ free_glyph (subglyph, dcontext);
+ }
+
+ /* Decomposition is complete. CONTEXT now contains the adjusted
+ outlines of the entire compound glyph. */
+ return 0;
+}
+
+/* Linear-interpolate to a point halfway between the points specified
+ by CONTROL1 and CONTROL2. Put the result in RESULT. */
+
+static void
+sfnt_lerp_half (struct sfnt_point *control1, struct sfnt_point *control2,
+ struct sfnt_point *result)
+{
+ result->x = control1->x + ((control2->x - control1->x) / 2);
+ result->y = control1->y + ((control2->y - control1->y) / 2);
+}
+
+/* Decompose contour data inside X, Y and FLAGS, between the indices
+ HERE and LAST. Call LINE_TO, CURVE_TO and MOVE_TO as appropriate,
+ with DCONTEXT as an argument. Apply SCALE to each point; SCALE
+ should be the factor necessary to turn points into 16.16 fixed
+ point.
+
+ Value is 1 upon failure, else 0. */
+
+static int
+sfnt_decompose_glyph_1 (size_t here, size_t last,
+ sfnt_move_to_proc move_to,
+ sfnt_line_to_proc line_to,
+ sfnt_curve_to_proc curve_to,
+ void *dcontext,
+ sfnt_fword *x,
+ sfnt_fword *y, unsigned char *flags,
+ int scale)
+{
+ struct sfnt_point control1, control2, start, mid;
+ size_t i;
+
+ /* The contour is empty. */
+
+ if (here == last)
+ /* An empty contour, if redundant, is not necessarily invalid. */
+ return 0;
+
+ /* Move the pen to the start of the contour. Apparently some fonts
+ have off the curve points as the start of a contour, so when that
+ happens lerp between the first and last points. */
+
+ if (flags[here] & 01) /* On Curve */
+ {
+ control1.x = x[here] * scale;
+ control1.y = y[here] * scale;
+ start = control1;
+ }
+ else if (flags[last] & 01)
+ {
+ /* Start at the last point if it is on the curve. Here, the
+ start really becomes the middle of a spline. */
+ control1.x = x[last] * scale;
+ control1.y = y[last] * scale;
+ start = control1;
+
+ /* Curve back one point early. */
+ last -= 1;
+ here -= 1;
+ }
+ else
+ {
+ /* Lerp between the start and the end. */
+ control1.x = x[here] * scale;
+ control1.y = y[here] * scale;
+ control2.x = x[last] * scale;
+ control2.y = y[last] * scale;
+ sfnt_lerp_half (&control1, &control2, &start);
+
+ /* In either of these cases, start iterating from just here as
+ opposed to here + 1, since logically the contour now starts
+ from the last curve. */
+ here -= 1;
+ }
+
+ /* Move to the start. */
+ move_to (start, dcontext);
+
+ /* Now handle each point between here + 1 and last. */
+
+ i = here;
+ while (++i <= last)
+ {
+ /* If the point is on the curve, then draw a line here from the
+ last control point. */
+
+ if (flags[i] & 01)
+ {
+ control1.x = x[i] * scale;
+ control1.y = y[i] * scale;
+
+ line_to (control1, dcontext);
+
+ /* Move to the next point. */
+ continue;
+ }
+
+ /* Off the curve points are more interesting. They are handled
+ one by one, with points in between being interpolated, until
+ either the last point is reached or an on-curve point is
+ processed. First, load the initial control points. */
+
+ control1.x = x[i] * scale;
+ control1.y = y[i] * scale;
+
+ while (++i <= last)
+ {
+ /* Load this point. */
+ control2.x = x[i] * scale;
+ control2.y = y[i] * scale;
+
+ /* If this point is on the curve, curve directly to this
+ point. */
+
+ if (flags[i] & 01)
+ {
+ curve_to (control1, control2, dcontext);
+ goto continue_loop;
+ }
+
+ /* Calculate the point between here and the previous
+ point. */
+ sfnt_lerp_half (&control1, &control2, &mid);
+
+ /* Curve over there. */
+ curve_to (control1, mid, dcontext);
+
+ /* Reload the control point. */
+ control1 = control2;
+ }
+
+ /* Close the contour by curving back to start. */
+ curve_to (control1, start, dcontext);
+
+ /* Don't close the contour twice. */
+ goto exit;
+
+ continue_loop:
+ continue;
+ }
+
+ /* Close the contour with a line back to start. */
+ line_to (start, dcontext);
+
+ exit:
+ return 0;
+}
+
+/* Decompose contour data inside X, Y and FLAGS, between the indices
+ HERE and LAST. Call LINE_TO, CURVE_TO and MOVE_TO as appropriate,
+ with DCONTEXT as an argument. Apply SCALE to each point; SCALE
+ should be the factor necessary to turn points into 16.16 fixed
+ point.
+
+ This is the version of sfnt_decompose_glyph_1 which takes
+ sfnt_fixed (or sfnt_f26dot6) as opposed to sfnt_fword.
+
+ Value is 1 upon failure, else 0. */
+
+static int
+sfnt_decompose_glyph_2 (size_t here, size_t last,
+ sfnt_move_to_proc move_to,
+ sfnt_line_to_proc line_to,
+ sfnt_curve_to_proc curve_to,
+ void *dcontext,
+ sfnt_fixed *x,
+ sfnt_fixed *y, unsigned char *flags,
+ int scale)
+{
+ struct sfnt_point control1, control2, start, mid;
+ size_t i;
+
+ /* The contour is empty. */
+
+ if (here == last)
+ /* An empty contour, if redundant, is not necessarily invalid. */
+ return 0;
+
+ /* Move the pen to the start of the contour. Apparently some fonts
+ have off the curve points as the start of a contour, so when that
+ happens lerp between the first and last points. */
+
+ if (flags[here] & 01) /* On Curve */
+ {
+ control1.x = x[here] * scale;
+ control1.y = y[here] * scale;
+ start = control1;
+ }
+ else if (flags[last] & 01)
+ {
+ /* Start at the last point if it is on the curve. Here, the
+ start really becomes the middle of a spline. */
+ control1.x = x[last] * scale;
+ control1.y = y[last] * scale;
+ start = control1;
+
+ /* Curve back one point early. */
+ last -= 1;
+ here -= 1;
+ }
+ else
+ {
+ /* Lerp between the start and the end. */
+ control1.x = x[here] * scale;
+ control1.y = y[here] * scale;
+ control2.x = x[last] * scale;
+ control2.y = y[last] * scale;
+ sfnt_lerp_half (&control1, &control2, &start);
+
+ /* In either of these cases, start iterating from just here as
+ opposed to here + 1, since logically the contour now starts
+ from the last curve. */
+ here -= 1;
+ }
+
+ /* Move to the start. */
+ move_to (start, dcontext);
+
+ /* Now handle each point between here + 1 and last. */
+
+ i = here;
+ while (++i <= last)
+ {
+ /* If the point is on the curve, then draw a line here from the
+ last control point. */
+
+ if (flags[i] & 01)
+ {
+ control1.x = x[i] * scale;
+ control1.y = y[i] * scale;
+
+ line_to (control1, dcontext);
+
+ /* Move to the next point. */
+ continue;
+ }
+
+ /* Off the curve points are more interesting. They are handled
+ one by one, with points in between being interpolated, until
+ either the last point is reached or an on-curve point is
+ processed. First, load the initial control points. */
+
+ control1.x = x[i] * scale;
+ control1.y = y[i] * scale;
+
+ while (++i <= last)
+ {
+ /* Load this point. */
+ control2.x = x[i] * scale;
+ control2.y = y[i] * scale;
+
+ /* If this point is on the curve, curve directly to this
+ point. */
+
+ if (flags[i] & 01)
+ {
+ curve_to (control1, control2, dcontext);
+ goto continue_loop;
+ }
+
+ /* Calculate the point between here and the previous
+ point. */
+ sfnt_lerp_half (&control1, &control2, &mid);
+
+ /* Curve over there. */
+ curve_to (control1, mid, dcontext);
+
+ /* Reload the control point. */
+ control1 = control2;
+ }
+
+ /* Close the contour by curving back to start. */
+ curve_to (control1, start, dcontext);
+
+ /* Don't close the contour twice. */
+ goto exit;
+
+ continue_loop:
+ continue;
+ }
+
+ /* Close the contour with a line back to start. */
+ line_to (start, dcontext);
+
+ exit:
+ return 0;
+}
+
+/* Decompose GLYPH into its individual components. Call MOVE_TO to
+ move to a specific location. For each line encountered, call
+ LINE_TO to draw a line to that location. For each spline
+ encountered, call CURVE_TO to draw the curves comprising the
+ spline.
+
+ If GLYPH is compound, use GET_GLYPH to obtain subglyphs. PROC must
+ return whether or not FREE_GLYPH will be called with the glyph
+ after sfnt_decompose_glyph is done with it. If GLYPH moreover
+ incorporates components whose anchor points are phantom points, use
+ GET_METRICS to obtain glyph metrics prerequisite for establishing
+ their coordinates.
+
+ When glyphs originate from a GX font with an active set of
+ transforms, the correct manner of applying such transforms is to
+ apply them within GET_GLYPH, while returning unaltered metrics from
+ GET_METRICS.
+
+ If there is a component glyph within GLYPH whose metrics have been
+ indicated as replacing those of its parent glyph, the variable
+ *METRICS_RETURN will be set to its metrics with GX-induced offsets
+ applied.
+
+ *METRICS_RETURN must initially hold metrics with GX offsets
+ applied, if any.
+
+ All functions will be called with DCONTEXT as an argument.
+
+ The winding rule used to fill the resulting lines is described in
+ chapter 2 of the TrueType reference manual, under the heading
+ "distinguishing the inside from the outside of a glyph."
+
+ Value is 0 upon success, or some non-zero value upon failure, which
+ can happen if the glyph is invalid. */
+
+static int
+sfnt_decompose_glyph (struct sfnt_glyph *glyph,
+ struct sfnt_glyph_metrics *metrics_return,
+ sfnt_move_to_proc move_to,
+ sfnt_line_to_proc line_to,
+ sfnt_curve_to_proc curve_to,
+ sfnt_get_glyph_proc get_glyph,
+ sfnt_free_glyph_proc free_glyph,
+ sfnt_get_metrics_proc get_metrics,
+ void *dcontext)
+{
+ size_t here, last, n;
+ struct sfnt_compound_glyph_context context;
+ struct sfnt_glyph_metrics compound_metrics;
+
+ if (glyph->simple)
+ {
+ if (!glyph->number_of_contours)
+ /* No contours. Nothing needs to be decomposed. */
+ return 0;
+
+ here = 0;
+
+ for (n = 0; n < glyph->number_of_contours; ++n)
+ {
+ /* here is the first index into the glyph's point arrays
+ belonging to the contour in question. last is the index
+ of the last point in the contour. */
+ last = glyph->simple->end_pts_of_contours[n];
+
+ /* Make sure here and last make sense. */
+
+ if (here > last || last >= glyph->simple->number_of_points)
+ return 1;
+
+ /* Now perform the decomposition. */
+ if (sfnt_decompose_glyph_1 (here, last, move_to,
+ line_to, curve_to,
+ dcontext,
+ glyph->simple->x_coordinates,
+ glyph->simple->y_coordinates,
+ glyph->simple->flags,
+ 65536))
+ return 1;
+
+ /* Move forward to the start of the next contour. */
+ here = last + 1;
+ }
+
+ return 0;
+ }
+
+ /* Decompose the specified compound glyph. */
+ memset (&context, 0, sizeof context);
+
+ /* Rather than handing METRICS_RETURN over to
+ sfnt_decompose_compound_glyph, save metrics within a temporary
+ variable and postpone returning them until it is certain the
+ decomposition has succeeded. */
+
+ compound_metrics = *metrics_return;
+
+ if (sfnt_decompose_compound_glyph (glyph, &context,
+ &compound_metrics,
+ get_glyph, free_glyph,
+ get_metrics, 0,
+ dcontext))
+ {
+ xfree (context.x_coordinates);
+ xfree (context.y_coordinates);
+ xfree (context.flags);
+ xfree (context.contour_end_points);
+
+ return 1;
+ }
+
+ *metrics_return = compound_metrics;
+
+ /* Now, generate the outlines. */
+
+ if (!context.num_end_points)
+ /* No contours. */
+ goto early;
+
+ here = 0;
+
+ for (n = 0; n < context.num_end_points; ++n)
+ {
+ /* here is the first index into the glyph's point arrays
+ belonging to the contour in question. last is the index
+ of the last point in the contour. */
+ last = context.contour_end_points[n];
+
+ /* Make sure here and last make sense. */
+
+ if (here > last || last >= context.num_points)
+ goto fail;
+
+ /* Now perform the decomposition. */
+ if (sfnt_decompose_glyph_2 (here, last, move_to,
+ line_to, curve_to,
+ dcontext,
+ context.x_coordinates,
+ context.y_coordinates,
+ context.flags, 1))
+ goto fail;
+
+ /* Move forward. */
+ here = last + 1;
+ }
+
+ early:
+ xfree (context.x_coordinates);
+ xfree (context.y_coordinates);
+ xfree (context.flags);
+ xfree (context.contour_end_points);
+ return 0;
+
+ fail:
+ xfree (context.x_coordinates);
+ xfree (context.y_coordinates);
+ xfree (context.flags);
+ xfree (context.contour_end_points);
+ return 1;
+}
+
+struct sfnt_build_glyph_outline_context
+{
+ /* The outline being built. */
+ struct sfnt_glyph_outline *outline;
+
+ /* Factor to multiply positions by to get the pixel width. */
+ sfnt_fixed factor;
+
+ /* The position of the pen in 16.16 fixed point format. */
+ sfnt_fixed x, y;
+};
+
+/* Global state for sfnt_build_glyph_outline and related
+ functions. */
+static struct sfnt_build_glyph_outline_context build_outline_context;
+
+/* Append the given three words FLAGS, X, and Y to the outline
+ currently being built. Value is the new pointer to outline
+ memory. */
+
+static struct sfnt_glyph_outline *
+sfnt_build_append (int flags, sfnt_fixed x, sfnt_fixed y)
+{
+ struct sfnt_glyph_outline *outline;
+
+ outline = build_outline_context.outline;
+
+ if (x == build_outline_context.x
+ && y == build_outline_context.y
+ /* If the outline is presently empty, the first move_to must be
+ recorded even if its X and Y are set to origin. Without this
+ initial vertex, edges will be generated from the next vertex
+ onward, and thus be misaligned. */
+ && outline->outline_used)
+ /* Ignore redundant motion. */
+ return build_outline_context.outline;
+
+ outline->outline_used++;
+
+ /* See if the outline has to be extended. Checking for overflow
+ should not be necessary. */
+
+ if (outline->outline_used > outline->outline_size)
+ {
+ outline->outline_size = outline->outline_used * 2;
+
+ /* Extend the outline to some size past the new size. */
+ outline = xrealloc (outline, (sizeof *outline
+ + (outline->outline_size
+ * sizeof *outline->outline)));
+ outline->outline
+ = (struct sfnt_glyph_outline_command *) (outline + 1);
+ }
+
+ /* Write the outline data. */
+ outline->outline[outline->outline_used - 1].flags = flags;
+ outline->outline[outline->outline_used - 1].x = x;
+ outline->outline[outline->outline_used - 1].y = y;
+
+ /* Extend outline bounding box. */
+
+ if (outline->outline_used == 1)
+ {
+ /* These are the first points in the outline. */
+ outline->xmin = outline->xmax = x;
+ outline->ymin = outline->ymax = y;
+ }
+ else
+ {
+ outline->xmin = MIN ((sfnt_fixed) x, outline->xmin);
+ outline->ymin = MIN ((sfnt_fixed) y, outline->ymin);
+ outline->xmax = MAX ((sfnt_fixed) x, outline->xmax);
+ outline->ymax = MAX ((sfnt_fixed) y, outline->ymax);
+ }
+
+ return outline;
+}
+
+#ifndef INT64_MAX
+
+/* 64 bit integer type. */
+
+struct sfnt_large_integer
+{
+ unsigned int high, low;
+};
+
+/* Calculate (A * B), placing the result in *VALUE. */
+
+static void
+sfnt_multiply_divide_1 (unsigned int a, unsigned int b,
+ struct sfnt_large_integer *value)
+{
+ unsigned int lo1, hi1, lo2, hi2, lo, hi, i1, i2;
+
+ lo1 = a & 0x0000ffffu;
+ hi1 = a >> 16;
+ lo2 = b & 0x0000ffffu;
+ hi2 = b >> 16;
+
+ lo = lo1 * lo2;
+ i1 = lo1 * hi2;
+ i2 = lo2 * hi1;
+ hi = hi1 * hi2;
+
+ /* Check carry overflow of i1 + i2. */
+ i1 += i2;
+ hi += (unsigned int) (i1 < i2) << 16;
+
+ hi += i1 >> 16;
+ i1 = i1 << 16;
+
+ /* Check carry overflow of i1 + lo. */
+ lo += i1;
+ hi += (lo < i1);
+
+ value->low = lo;
+ value->high = hi;
+}
+
+/* Count the number of most significant zero bits in N. */
+
+static unsigned int
+sfnt_count_leading_zero_bits (unsigned int n)
+{
+ int shift;
+
+ shift = 0;
+
+ if (n & 0xffff0000ul)
+ {
+ n >>= 16;
+ shift += 16;
+ }
+
+ if (n & 0x0000ff00ul)
+ {
+ n >>= 8;
+ shift += 8;
+ }
+
+ if (n & 0x000000f0ul)
+ {
+ n >>= 4;
+ shift += 4;
+ }
+
+ if (n & 0x0000000cul)
+ {
+ n >>= 2;
+ shift += 2;
+ }
+
+ if (n & 0x00000002ul)
+ shift += 1;
+
+ return shift;
+}
+
+/* Calculate AB / C. Value is a 32 bit unsigned integer. */
+
+static unsigned int
+sfnt_multiply_divide_2 (struct sfnt_large_integer *ab,
+ unsigned int c)
+{
+ unsigned int hi, lo;
+ int i;
+ unsigned int r, q; /* Remainder and quotient. */
+
+ hi = ab->high;
+ lo = ab->low;
+
+ i = 31 - sfnt_count_leading_zero_bits (hi);
+ r = (hi << i) | (lo >> (32 - i));
+ lo <<= i;
+ q = r / c;
+ r -= q * c;
+ i = 32 - i;
+
+ do
+ {
+ q <<= 1;
+ r = (r << 1) | (lo >> 31);
+ lo <<= 1;
+
+ if (r >= c)
+ {
+ r -= c;
+ q |= 1;
+ }
+ }
+ while (--i);
+
+ return q;
+}
+
+/* Add the specified unsigned 32-bit N to the large integer
+ INTEGER. */
+
+static void
+sfnt_large_integer_add (struct sfnt_large_integer *integer,
+ uint32_t n)
+{
+ struct sfnt_large_integer number;
+
+ number.low = integer->low + n;
+ number.high = integer->high + (number.low
+ < integer->low);
+
+ *integer = number;
+}
+
+#endif /* !INT64_MAX */
+
+/* Calculate (A * B) / C with no rounding and return the result, using
+ a 64 bit integer if necessary. */
+
+static unsigned int
+sfnt_multiply_divide (unsigned int a, unsigned int b, unsigned int c)
+{
+#ifndef INT64_MAX
+ struct sfnt_large_integer temp;
+
+ sfnt_multiply_divide_1 (a, b, &temp);
+ return sfnt_multiply_divide_2 (&temp, c);
+#else /* INT64_MAX */
+ uint64_t temp;
+
+ temp = (uint64_t) a * (uint64_t) b;
+ return temp / c;
+#endif /* !INT64_MAX */
+}
+
+/* Calculate (A * B) / C with rounding and return the result, using a
+ 64 bit integer if necessary. */
+
+static unsigned int
+sfnt_multiply_divide_rounded (unsigned int a, unsigned int b,
+ unsigned int c)
+{
+#ifndef INT64_MAX
+ struct sfnt_large_integer temp;
+
+ sfnt_multiply_divide_1 (a, b, &temp);
+ sfnt_large_integer_add (&temp, c / 2);
+ return sfnt_multiply_divide_2 (&temp, c);
+#else /* INT64_MAX */
+ uint64_t temp;
+
+ temp = (uint64_t) a * (uint64_t) b + c / 2;
+ return temp / c;
+#endif /* !INT64_MAX */
+}
+
+#ifndef INT64_MAX
+
+/* Calculate (A * B) / C, rounding the result with a threshold of N.
+ Use a 64 bit temporary. */
+
+static unsigned int
+sfnt_multiply_divide_round (unsigned int a, unsigned int b,
+ unsigned int n, unsigned int c)
+{
+ struct sfnt_large_integer temp;
+
+ sfnt_multiply_divide_1 (a, b, &temp);
+ sfnt_large_integer_add (&temp, n);
+ return sfnt_multiply_divide_2 (&temp, c);
+}
+
+#endif /* !INT64_MAX */
+
+/* The same as sfnt_multiply_divide_rounded, but handle signed values
+ instead. */
+
+MAYBE_UNUSED static int
+sfnt_multiply_divide_signed (int a, int b, int c)
+{
+ int sign;
+
+ sign = 1;
+
+ if (a < 0)
+ sign = -sign;
+
+ if (b < 0)
+ sign = -sign;
+
+ if (c < 0)
+ sign = -sign;
+
+ return (sfnt_multiply_divide_rounded (abs (a), abs (b),
+ abs (c)) * sign);
+}
+
+/* Multiply the two 16.16 fixed point numbers X and Y. Return the
+ result regardless of overflow. */
+
+static sfnt_fixed
+sfnt_mul_fixed (sfnt_fixed x, sfnt_fixed y)
+{
+#ifdef INT64_MAX
+ int64_t product;
+
+ product = (int64_t) x * (int64_t) y;
+
+ /* This can be done quickly with int64_t. */
+ return product / (int64_t) 65536;
+#else /* !INT64_MAX */
+ int sign;
+
+ sign = 1;
+
+ if (x < 0)
+ sign = -sign;
+
+ if (y < 0)
+ sign = -sign;
+
+ return sfnt_multiply_divide (abs (x), abs (y),
+ 65536) * sign;
+#endif /* INT64_MAX */
+}
+
+/* Multiply the two 16.16 fixed point numbers X and Y, with rounding
+ of the result. */
+
+static sfnt_fixed
+sfnt_mul_fixed_round (sfnt_fixed x, sfnt_fixed y)
+{
+#ifdef INT64_MAX
+ int64_t product, round;
+
+ product = (int64_t) x * (int64_t) y;
+ round = product < 0 ? -32768 : 32768;
+
+ /* This can be done quickly with int64_t. */
+ return (product + round) / (int64_t) 65536;
+#else /* !INT64_MAX */
+ int sign;
+
+ sign = 1;
+
+ if (x < 0)
+ sign = -sign;
+
+ if (y < 0)
+ sign = -sign;
+
+ return sfnt_multiply_divide_round (abs (x), abs (y),
+ 32768, 65536) * sign;
+#endif /* INT64_MAX */
+}
+
+/* Set the pen size to the specified point and return. POINT will be
+ scaled up to the pixel size. */
+
+static void
+sfnt_move_to_and_build (struct sfnt_point point, void *dcontext)
+{
+ sfnt_fixed x, y;
+
+ x = sfnt_mul_fixed (build_outline_context.factor, point.x);
+ y = sfnt_mul_fixed (build_outline_context.factor, point.y);
+
+ build_outline_context.outline = sfnt_build_append (0, x, y);
+ build_outline_context.x = x;
+ build_outline_context.y = y;
+}
+
+/* Record a line to the specified point and return. POINT will be
+ scaled up to the pixel size. */
+
+static void
+sfnt_line_to_and_build (struct sfnt_point point, void *dcontext)
+{
+ sfnt_fixed x, y;
+
+ x = sfnt_mul_fixed (build_outline_context.factor, point.x);
+ y = sfnt_mul_fixed (build_outline_context.factor, point.y);
+
+ build_outline_context.outline
+ = sfnt_build_append (SFNT_GLYPH_OUTLINE_LINETO,
+ x, y);
+ build_outline_context.x = x;
+ build_outline_context.y = y;
+}
+
+/* Divide the two 16.16 fixed point numbers X and Y. Return the
+ result regardless of overflow. */
+
+static sfnt_fixed
+sfnt_div_fixed (sfnt_fixed x, sfnt_fixed y)
+{
+#ifdef INT64_MAX
+ int64_t result;
+
+ result = ((int64_t) x * 65536) / y;
+
+ return result;
+#else
+ int sign;
+ unsigned int a, b;
+
+ sign = 1;
+
+ if (x < 0)
+ sign = -sign;
+
+ if (y < 0)
+ sign = -sign;
+
+ a = abs (x);
+ b = abs (y);
+
+ return sfnt_multiply_divide (a, 65536, b) * sign;
+#endif
+}
+
+/* Return the ceiling value of the specified fixed point number X. */
+
+static sfnt_fixed
+sfnt_ceil_fixed (sfnt_fixed x)
+{
+ return (x + 0177777) & 037777600000;
+}
+
+/* Return the floor value of the specified fixed point number X. */
+
+static sfnt_fixed
+sfnt_floor_fixed (sfnt_fixed x)
+{
+ return x & 037777600000;
+}
+
+/* Given a curve consisting of three points CONTROL0, CONTROL1 and
+ ENDPOINT, return whether or not the curve is sufficiently small to
+ be approximated by a line between CONTROL0 and ENDPOINT. */
+
+static bool
+sfnt_curve_is_flat (struct sfnt_point control0,
+ struct sfnt_point control1,
+ struct sfnt_point endpoint)
+{
+ struct sfnt_point g, h;
+
+ g.x = control1.x - control0.x;
+ g.y = control1.y - control0.y;
+ h.x = endpoint.x - control0.x;
+ h.y = endpoint.y - control0.y;
+
+ /* 1.0 is a constant representing the area covered at which point
+ the curve is considered "flat". */
+ return (abs (sfnt_mul_fixed (g.x, h.y)
+ - sfnt_mul_fixed (g.y, h.x))
+ <= 0200000);
+}
+
+/* Recursively split the splines in the bezier curve formed from
+ CONTROL0, CONTROL1 and ENDPOINT until the area between the curve's
+ two ends is small enough to be considered ``flat''. Then, turn
+ those ``flat'' curves into lines. */
+
+static void
+sfnt_curve_to_and_build_1 (struct sfnt_point control0,
+ struct sfnt_point control1,
+ struct sfnt_point endpoint)
+{
+ struct sfnt_point ab, bc, abbc;
+
+ /* control0, control and endpoint make up the spline. Figure out
+ its distance from a line. */
+ if (sfnt_curve_is_flat (control0, control1, endpoint))
+ {
+ /* Draw a line to endpoint. */
+ build_outline_context.outline
+ = sfnt_build_append (SFNT_GLYPH_OUTLINE_LINETO,
+ endpoint.x, endpoint.y);
+ build_outline_context.x = endpoint.x;
+ build_outline_context.y = endpoint.y;
+ }
+ else
+ {
+ /* Calculate new control points.
+ Maybe apply a recursion limit here? */
+ sfnt_lerp_half (&control0, &control1, &ab);
+ sfnt_lerp_half (&control1, &endpoint, &bc);
+ sfnt_lerp_half (&ab, &bc, &abbc);
+
+ /* Keep splitting until a flat enough spline results. */
+ sfnt_curve_to_and_build_1 (control0, ab, abbc);
+
+ /* Then go on with the spline between control1 and endpoint. */
+ sfnt_curve_to_and_build_1 (abbc, bc, endpoint);
+ }
+}
+
+/* Scale and decompose the specified bezier curve into individual
+ lines. Then, record each of those lines into the outline being
+ built. */
+
+static void
+sfnt_curve_to_and_build (struct sfnt_point control,
+ struct sfnt_point endpoint,
+ void *dcontext)
+{
+ struct sfnt_point control0;
+
+ control0.x = build_outline_context.x;
+ control0.y = build_outline_context.y;
+ control.x = sfnt_mul_fixed (control.x,
+ build_outline_context.factor);
+ control.y = sfnt_mul_fixed (control.y,
+ build_outline_context.factor);
+ endpoint.x = sfnt_mul_fixed (endpoint.x,
+ build_outline_context.factor);
+ endpoint.y = sfnt_mul_fixed (endpoint.y,
+ build_outline_context.factor);
+
+ sfnt_curve_to_and_build_1 (control0, control, endpoint);
+}
+
+/* Non-reentrantly build the outline for the specified GLYPH at the
+ given scale factor. Return the outline data with a refcount of 0
+ upon success, or NULL upon failure.
+
+ SCALE is a scale factor that converts between em space and device
+ space.
+
+ Use the unscaled glyph METRICS to determine the origin point of the
+ outline, or those of compound glyph components within *GLYPH
+ configured to replace their parents', which if existent are
+ returned in *METRICS. METRICS should not be altered by GX-derived
+ offsets, as they will be applied to *METRICS if present, following
+ this formula:
+
+ LBEARING = LBEARING - GLYPH->origin_distortion
+ ADVANCE = ADVANCE + GLYPH->advance_distortion
+
+ Call GET_GLYPH and FREE_GLYPH with the specified DCONTEXT to obtain
+ glyphs for compound glyph subcomponents, and GET_METRICS with the
+ provided DCONTEXT for unscaled glyph metrics. */
+
+TEST_STATIC struct sfnt_glyph_outline *
+sfnt_build_glyph_outline (struct sfnt_glyph *glyph,
+ sfnt_fixed scale,
+ struct sfnt_glyph_metrics *metrics,
+ sfnt_get_glyph_proc get_glyph,
+ sfnt_free_glyph_proc free_glyph,
+ sfnt_get_metrics_proc get_metrics,
+ void *dcontext)
+{
+ struct sfnt_glyph_outline *outline;
+ int rc;
+ sfnt_fword origin;
+
+ memset (&build_outline_context, 0, sizeof build_outline_context);
+
+ /* Allocate the outline now with enough for 44 words at the end. */
+ outline = xmalloc (sizeof *outline + 40 * sizeof (*outline->outline));
+ outline->outline_size = 40;
+ outline->outline_used = 0;
+ outline->refcount = 0;
+ outline->outline
+ = (struct sfnt_glyph_outline_command *) (outline + 1);
+
+ /* DCONTEXT will be passed to GET_GLYPH and FREE_GLYPH, so global
+ variables must be used to communicate with the decomposition
+ functions. */
+ build_outline_context.outline = outline;
+
+ /* Clear outline bounding box. */
+ outline->xmin = 0;
+ outline->ymin = 0;
+ outline->xmax = 0;
+ outline->ymax = 0;
+
+ /* Set the scale factor. */
+ build_outline_context.factor = scale;
+
+ /* Apply the glyph's advance and origin distortion to METRICS in
+ advance of constructing the glyph outline, which might replace
+ METRICS with the metrics of a compound subglyph. */
+ metrics->lbearing -= glyph->origin_distortion;
+ metrics->advance += glyph->advance_distortion;
+
+ /* Decompose the outline. */
+ rc = sfnt_decompose_glyph (glyph, metrics,
+ sfnt_move_to_and_build,
+ sfnt_line_to_and_build,
+ sfnt_curve_to_and_build,
+ get_glyph, free_glyph, get_metrics,
+ dcontext);
+
+ /* Synchronize the outline object with what might have changed
+ inside sfnt_decompose_glyph. */
+ outline = build_outline_context.outline;
+
+ if (rc)
+ {
+ xfree (outline);
+ return NULL;
+ }
+
+ /* Compute the origin position. Note that the original glyph xmin
+ is first used to calculate the origin point, and the origin
+ distortion is applied to it to get the distorted origin. */
+
+ origin = glyph->xmin - metrics->lbearing;
+ outline->origin = sfnt_mul_fixed (origin, scale);
+
+ return outline;
+}
+
+
+
+/* Glyph rasterization. The algorithm used here is fairly simple.
+ Each contour is decomposed into lines, which turn into a polygon.
+ Then, a bog standard edge filler is used to turn them into
+ spans. */
+
+/* Coverage table. This is a four dimensional array indiced by the Y,
+ then X axis fractional, shifted down to 2 bits. */
+
+static const unsigned char sfnt_poly_coverage[8][9] =
+ {
+ { 0, 4, 8, 12, 16, 20, 24, 28, 32, },
+ { 0, 4, 8, 12, 16, 20, 24, 28, 32, },
+ { 0, 4, 8, 12, 16, 20, 24, 28, 32, },
+ { 0, 3, 7, 11, 15, 19, 23, 27, 31, },
+ { 0, 4, 8, 12, 16, 20, 24, 28, 32, },
+ { 0, 4, 8, 12, 16, 20, 24, 28, 32, },
+ { 0, 4, 8, 12, 16, 20, 24, 28, 32, },
+ { 0, 4, 8, 12, 16, 20, 24, 28, 32, },
+ };
+
+/* Return the nearest coordinate on the sample grid no less than
+ F. */
+
+static sfnt_fixed
+sfnt_poly_grid_ceil (sfnt_fixed f)
+{
+ return (((f + (SFNT_POLY_START - 1))
+ & ~(SFNT_POLY_STEP - 1)) + SFNT_POLY_START);
+}
+
+enum
+ {
+ SFNT_POLY_ALIGNMENT = 4,
+ };
+
+/* Initialize the specified RASTER in preparation for displaying spans
+ for OUTLINE, and set RASTER->refcount to 0. The caller must then
+ set RASTER->cells to a zeroed array of size RASTER->stride *
+ RASTER->height, aligned to RASTER. */
+
+TEST_STATIC void
+sfnt_prepare_raster (struct sfnt_raster *raster,
+ struct sfnt_glyph_outline *outline)
+{
+ raster->width
+ = (sfnt_ceil_fixed (outline->xmax)
+ - sfnt_floor_fixed (outline->xmin)) / 65536;
+ raster->height
+ = (sfnt_ceil_fixed (outline->ymax)
+ - sfnt_floor_fixed (outline->ymin)) / 65536;
+ raster->refcount = 0;
+
+ /* Align the raster to a SFNT_POLY_ALIGNMENT byte boundary. */
+ raster->stride = ((raster->width
+ + (SFNT_POLY_ALIGNMENT - 1))
+ & ~(SFNT_POLY_ALIGNMENT - 1));
+
+ /* Apply outline->origin. This is 0 by convention in most fonts.
+ However, variable fonts typically change this as variations are
+ applied. */
+ raster->offx = sfnt_floor_fixed (outline->xmin
+ - outline->origin) / 65536;
+ raster->offy = sfnt_floor_fixed (outline->ymin) / 65536;
+}
+
+typedef void (*sfnt_edge_proc) (struct sfnt_edge *, size_t,
+ void *);
+typedef void (*sfnt_span_proc) (struct sfnt_edge *, sfnt_fixed, void *);
+
+/* Move EDGE->x forward, assuming that the scanline has moved upwards
+ by SFNT_POLY_STEP. */
+
+static void
+sfnt_step_edge (struct sfnt_edge *edge)
+{
+ /* Add step. */
+ edge->x += edge->step_x;
+}
+
+/* Build a list of edges for each contour in OUTLINE, applying xmin
+ and ymin as the offset to each edge. Call EDGE_PROC with DCONTEXT
+ and the resulting edges as arguments. It is OK to modify the edges
+ given to EDGE_PROC. Align all edges to the sub-pixel grid. */
+
+static void
+sfnt_build_outline_edges (struct sfnt_glyph_outline *outline,
+ sfnt_edge_proc edge_proc, void *dcontext)
+{
+ struct sfnt_edge *edges;
+ size_t i, edge, next_vertex;
+ sfnt_fixed dx, dy, bot, step_x, ymin, xmin;
+ size_t top, bottom, y;
+
+ edges = alloca (outline->outline_used * sizeof *edges);
+ edge = 0;
+
+ /* ymin and xmin must be the same as the offset used to set offy and
+ offx in rasters. */
+ ymin = sfnt_floor_fixed (outline->ymin);
+ xmin = sfnt_floor_fixed (outline->xmin);
+
+ for (i = 0; i < outline->outline_used; ++i)
+ {
+ /* Set NEXT_VERTEX to the next point (vertex) in this contour.
+
+ If i is past the end of the contour, then don't build edges
+ for this point. */
+ next_vertex = i + 1;
+
+ if (next_vertex == outline->outline_used
+ || !(outline->outline[next_vertex].flags
+ & SFNT_GLYPH_OUTLINE_LINETO))
+ continue;
+
+ /* Skip past horizontal vertices. */
+ if (outline->outline[next_vertex].y == outline->outline[i].y)
+ continue;
+
+ /* Figure out the winding direction. */
+ if (outline->outline[next_vertex].y < outline->outline[i].y)
+ /* Vector will cross imaginary ray from its bottom from the
+ left of the ray. Winding is thus 1. */
+ edges[edge].winding = 1;
+ else
+ /* Moving clockwise. Winding is thus -1. */
+ edges[edge].winding = -1;
+
+ /* Figure out the top and bottom values of this edge. If the
+ next edge is below, top is here and bot is the edge below.
+ If the next edge is above, then top is there and this is the
+ bottom. */
+
+ if (outline->outline[next_vertex].y < outline->outline[i].y)
+ {
+ /* End of edge is below this one (keep in mind this is a
+ cartesian coordinate system, so smaller values are below
+ larger ones.) */
+ top = i;
+ bottom = next_vertex;
+ }
+ else
+ {
+ /* End of edge is above this one. */
+ bottom = i;
+ top = next_vertex;
+ }
+
+ bot = (outline->outline[bottom].y - ymin);
+ edges[edge].top = (outline->outline[top].y - ymin);
+
+ /* Record the edge. Rasterization happens from bottom to
+ up, so record the X at the bottom. */
+ edges[edge].x = (outline->outline[bottom].x - xmin);
+ dx = (outline->outline[top].x - outline->outline[bottom].x);
+ dy = abs (outline->outline[top].y
+ - outline->outline[bottom].y);
+
+ /* Step to first grid point. */
+ y = sfnt_poly_grid_ceil (bot);
+
+ /* If rounding would make the edge not cover any area, skip this
+ edge. */
+
+ if (y >= edges[edge].top)
+ continue;
+
+ /* Compute the step X. This is how much X changes for each
+ increase in Y. */
+ step_x = sfnt_div_fixed (dx, dy);
+ edges[edge].next = NULL;
+
+ /* Compute the step X scaled to the poly step. */
+ edges[edge].step_x
+ = sfnt_mul_fixed (step_x, SFNT_POLY_STEP);
+
+ /* Step to the grid point. */
+ edges[edge].x += sfnt_mul_fixed (step_x, bot - y);
+
+ /* Set the bottom position. */
+ edges[edge].bottom = y;
+
+ edge++;
+ }
+
+ if (edge)
+ edge_proc (edges, edge, dcontext);
+}
+
+/* Sort an array of SIZE edges to increase by bottom Y position, in
+ preparation for building spans.
+
+ Insertion sort is used because there are usually not very many
+ edges, and anything larger would bloat up the code. */
+
+static void
+sfnt_edge_sort (struct sfnt_edge *edges, size_t size)
+{
+ ssize_t i, j;
+ struct sfnt_edge edge;
+
+ for (i = 1; i < size; ++i)
+ {
+ edge = edges[i];
+ j = i - 1;
+
+ while (j >= 0 && (edges[j].bottom > edge.bottom))
+ {
+ edges[j + 1] = edges[j];
+ j--;
+ }
+
+ edges[j + 1] = edge;
+ }
+}
+
+/* Draw EDGES, an unsorted array of polygon edges of size SIZE. For
+ each scanline, call SPAN_FUNC with a list of active edges and
+ coverage information, and DCONTEXT.
+
+ Sort each edge in ascending order by the bottommost Y coordinate to
+ which it applies. Start a loop on the Y coordinate, which starts
+ out at that of the bottommost edge. For each iteration, add edges
+ that now overlap with Y, keeping them sorted by X. Poly those
+ edges through SPAN_FUNC. Then, move upwards by SFNT_POLY_STEP,
+ remove edges that no longer apply, and interpolate the remaining
+ edges' X coordinates. Repeat until all the edges have been polyed.
+
+ Or alternatively, think of this as such: each edge is actually a
+ vector from its bottom position towards its top most position.
+ Every time Y moves upwards, the position of each edge intersecting
+ with Y is interpolated and added to a list of spans along with
+ winding information that is then given to EDGE_FUNC.
+
+ Anti-aliasing is performed using a coverage map for fractional
+ coordinates, and incrementing the Y axis by SFNT_POLY_STEP instead
+ of 1. SFNT_POLY_STEP is chosen to always keep Y aligned to a grid
+ placed such that there are always 1 << SFNT_POLY_SHIFT positions
+ available for each integral pixel coordinate. */
+
+static void
+sfnt_poly_edges (struct sfnt_edge *edges, size_t size,
+ sfnt_span_proc span_func, void *dcontext)
+{
+ sfnt_fixed y;
+ size_t e;
+ struct sfnt_edge *active, **prev, *a, *n;
+
+ if (!size)
+ return;
+
+ /* Sort edges to ascend by Y-order. Once again, remember: cartesian
+ coordinates. */
+ sfnt_edge_sort (edges, size);
+
+ /* Step down line by line. Find active edges. */
+
+ y = edges[0].bottom;
+ active = NULL;
+ e = 0;
+
+ for (;;)
+ {
+ /* Add in new edges keeping them sorted. */
+ for (; e < size && edges[e].bottom <= y; ++e)
+ {
+ /* Find where to place this edge. */
+ for (prev = &active; (a = *prev); prev = &(a->next))
+ {
+ if (a->x > edges[e].x)
+ break;
+ }
+
+ edges[e].next = *prev;
+ *prev = &edges[e];
+ }
+
+ /* Draw this span at the current position. Y axis antialiasing
+ is expected to be handled by SPAN_FUNC. */
+ span_func (active, y, dcontext);
+
+ /* Compute the next Y position. */
+ y += SFNT_POLY_STEP;
+
+ /* Strip out edges that no longer have effect. */
+
+ for (prev = &active; (a = *prev);)
+ {
+ if (a->top <= y)
+ *prev = a->next;
+ else
+ prev = &a->next;
+ }
+
+ /* Break if all is done. */
+ if (!active && e == size)
+ break;
+
+ /* Step all edges. */
+ for (a = active; a; a = a->next)
+ sfnt_step_edge (a);
+
+ /* Resort on X axis. */
+ for (prev = &active; (a = *prev) && (n = a->next);)
+ {
+ if (a->x > n->x)
+ {
+ a->next = n->next;
+ n->next = a;
+ *prev = n;
+ prev = &active;
+ }
+ else
+ prev = &a->next;
+ }
+ }
+}
+
+/* Saturate and convert the given unsigned short value X to an
+ unsigned char. */
+
+static unsigned char
+sfnt_saturate_short (unsigned short x)
+{
+ if (x > 255)
+ return 255;
+
+ return x;
+}
+
+/* Fill a single span of pixels between X0 and X1 at Y, a raster
+ coordinate, onto RASTER. */
+
+static void
+sfnt_fill_span (struct sfnt_raster *raster, sfnt_fixed y,
+ sfnt_fixed x0, sfnt_fixed x1)
+{
+ unsigned char *start;
+ const unsigned char *coverage;
+ sfnt_fixed left, right, end;
+ unsigned short w, a;
+ int row;
+#ifndef NDEBUG
+ unsigned char *row_end;
+#endif /* NDEBUG */
+
+ /* Clip bounds to pixmap. */
+
+ if (x0 < 0)
+ x0 = 0;
+
+ /* If x1 is greater than the raster width, make sure the last pixel
+ is filled and no more after that. */
+
+ if (x1 > raster->width * 65536)
+ x1 = raster->width * 65536;
+
+ /* Check for empty spans. */
+ if (x1 <= x0)
+ return;
+
+ /* Figure out coverage based on Y axis fractional. */
+ coverage = sfnt_poly_coverage[(y >> (16 - SFNT_POLY_SHIFT))
+ & SFNT_POLY_MASK];
+ row = y >> 16;
+
+ /* Don't fill out of bounds rows. */
+ if (row < 0 || row >= raster->height)
+ return;
+
+ /* Set start, then start filling according to coverage. left and
+ right are now .3. */
+ left = x0 >> (16 - SFNT_POLY_SHIFT);
+ right = x1 >> (16 - SFNT_POLY_SHIFT);
+ start = raster->cells + row * raster->stride;
+#ifndef NDEBUG
+ row_end = start + raster->width;
+#endif /* NDEBUG */
+ start += left >> SFNT_POLY_SHIFT;
+
+ /* If left and right actually lie in the same pixel, just fill with
+ the coverage of both and return. */
+
+ if ((left & ~SFNT_POLY_MASK) == (right & ~SFNT_POLY_MASK))
+ {
+ /* Assert that start does not exceed the end of the row. */
+ assert (start <= row_end);
+
+ w = coverage[right - left];
+ a = *start + w;
+
+ *start = sfnt_saturate_short (a);
+ return;
+ }
+
+ /* Compute coverage for first pixel, then poly. The code from here
+ onwards assumes that left and right are on two different
+ pixels. */
+
+ if (left & SFNT_POLY_MASK)
+ {
+ /* Assert that start does not exceed the end of the row. */
+ assert (start <= row_end);
+
+ /* Compute the coverage for the first pixel, and move left past
+ it. The coverage is a number from 1 to 7 describing how
+ ``partially'' covered this pixel is. */
+
+ end = (left + SFNT_POLY_SAMPLE - 1) & ~SFNT_POLY_MASK;
+ end = MIN (right, end);
+
+ w = coverage[end - left];
+ a = *start + w;
+
+ /* Now move left past. */
+ left = end;
+ *start++ = sfnt_saturate_short (a);
+ }
+
+ /* Clear coverage info for first pixel. Compute coverage for center
+ pixels. Note that SFNT_POLY_SAMPLE is used and not
+ SFNT_POLY_MASK, because coverage has a blank column at the
+ start. */
+ w = coverage[SFNT_POLY_SAMPLE];
+
+ /* Fill pixels between left and right. */
+ while (left + SFNT_POLY_MASK < right)
+ {
+ /* Assert that start does not exceed the end of the row. */
+ assert (start <= row_end);
+
+ a = *start + w;
+ *start++ = sfnt_saturate_short (a);
+ left += SFNT_POLY_SAMPLE;
+ }
+
+ /* Fill rightmost pixel with any partial coverage. */
+
+ if (right & SFNT_POLY_MASK)
+ {
+ /* Assert that start does not exceed the end of the row. */
+ assert (start <= row_end);
+
+ w = coverage[right - left];
+ a = *start + w;
+ *start = sfnt_saturate_short (a);
+ }
+}
+
+/* Poly each span starting from START onto RASTER, at position Y. Y
+ here is still a cartesian coordinate, where the bottom of the
+ raster is 0. But that is no longer true by the time sfnt_span_fill
+ is called. */
+
+static void
+sfnt_poly_span (struct sfnt_edge *start, sfnt_fixed y,
+ struct sfnt_raster *raster)
+{
+ struct sfnt_edge *edge;
+ int winding;
+ sfnt_fixed x0, x1;
+
+ /* Pacify -Wmaybe-uninitialized; x1 and x0 are only used when edge
+ != start, at which point x0 has already been set. */
+ x0 = x1 = 0;
+
+ /* Generate the X axis coverage map. Then poly it onto RASTER.
+ winding on each edge determines the winding direction: when it is
+ positive, winding is 1. When it is negative, winding is -1.
+
+ Fill each consecutive stretch of spans that are inside the glyph;
+ otherwise, coverage will overlap for some spans, but not
+ others.
+
+ The spans must be terminated with an edge that causes an
+ off-transition, or some spans will not be filled. */
+
+ winding = 0;
+
+ for (edge = start; edge; edge = edge->next)
+ {
+ if (!winding)
+ {
+ if (edge != start && x0 != x1)
+ /* Draw this section of spans that are on. */
+ sfnt_fill_span (raster, (raster->height << 16) - y,
+ x0, x1);
+
+ x0 = x1 = edge->x;
+ }
+ else
+ x1 = edge->x;
+
+ winding += edge->winding;
+ }
+
+ /* Draw the last span following the last off-transition. */
+
+ if (!winding && edge != start && x0 != x1)
+ sfnt_fill_span (raster, (raster->height << 16) - y,
+ x0, x1);
+}
+
+
+
+/* Main entry point for outline rasterization. */
+
+/* Raster the spans between START and its end to the raster specified
+ as DCONTEXT. The span's position is Y. */
+
+static void
+sfnt_raster_span (struct sfnt_edge *start, sfnt_fixed y,
+ void *dcontext)
+{
+ sfnt_poly_span (start, y, dcontext);
+}
+
+/* Generate and poly each span in EDGES onto the raster specified as
+ DCONTEXT. */
+
+static void
+sfnt_raster_edge (struct sfnt_edge *edges, size_t num_edges,
+ void *dcontext)
+{
+ sfnt_poly_edges (edges, num_edges, sfnt_raster_span,
+ dcontext);
+}
+
+/* Generate an alpha mask for the glyph outline OUTLINE. Value is the
+ alpha mask upon success, NULL upon failure. */
+
+TEST_STATIC struct sfnt_raster *
+sfnt_raster_glyph_outline (struct sfnt_glyph_outline *outline)
+{
+ struct sfnt_raster raster, *data;
+
+ /* Get the raster parameters. */
+ sfnt_prepare_raster (&raster, outline);
+
+ /* Allocate the raster data. */
+ data = xmalloc (sizeof *data + raster.stride * raster.height);
+ *data = raster;
+ data->cells = (unsigned char *) (data + 1);
+ memset (data->cells, 0, raster.stride * raster.height);
+
+ /* Generate edges for the outline, polying each array of edges to
+ the raster. */
+ sfnt_build_outline_edges (outline, sfnt_raster_edge, data);
+
+ /* All done. */
+ return data;
+}
+
+
+
+#define sfnt_add(a, b) \
+ ((int) ((unsigned int) (a) + (unsigned int) (b)))
+
+#define sfnt_sub(a, b) \
+ ((int) ((unsigned int) (a) - (unsigned int) (b)))
+
+#define sfnt_mul(a, b) \
+ ((int) ((unsigned int) (a) * (unsigned int) (b)))
+
+
+
+/* Exact coverage scaler.
+
+ The foregoing routines calculate partial coverage for each pixel by
+ increasing each span in increments finer than a single pixel, then
+ merging active spans into the raster.
+
+ Experience has proven this yields imperfect display results,
+ particularly when combined with glyph instruction code which aligns
+ points in a certain and as yet undetermined manner.
+
+ The scaler implemented in this page attains greater precision,
+ generating at length an array of scanlines, in which each is
+ represented by a list of steps. Each step holds an X coordinate
+ and a coverage value, which contributes to the coverage of each
+ pixel within the scanline rightwards or equal to the pixel with its
+ X coordinate.
+
+ Such a coverage value can be positive or negative; when the winding
+ direction of the span it derives from is positive, so is the
+ coverage value, that the pixels to its right (thus further into the
+ polygon it demarcates) might be painted in. In the other case, the
+ value is negative, thus negating the effect of preceding steps and
+ marking the outer boundary of the section of the polygon's
+ intersection with the scanline.
+
+ The procedure for producing this array of scanlines is largely an
+ adaptation of that which sfnt_poly_edges implements; in particular
+ the process of sorting and filtering edges remains untouched.
+
+ Rather than advancing through the edges SFNT_POLY_STEP at a time,
+ the edges are iterated over scanline-by-scanline. Every edge
+ overlapping with a particular scanline is considered piecemeal to
+ generate its array of steps.
+
+ An edge might overlap pixels within the scanline in one of four
+ fashions; each is illustrated with a graphic below:
+
+ +--------ee-----+------------------------------------------------+ (I)
+ | ee.......|................................................|
+ | ee.........|................................................|
+ | ee...........|................................................|
+ |ee.............|................................................|
+ ee---------------+------------------------------------------------+
+
+ In this instance, the edge partially overlaps its first pixel, but
+ the remainder all receive complete coverage.
+
+ +---------------+---------eeeeee+--------------------------------+ (II)
+ | | eeeeee......|................................|
+ | eeeee............|................................|
+ | eeeeee.|...............|................................|
+ | eeeeee.......|...............|................................|
+ eee-------------+---------------+--------------------------------+
+
+ In this instance, the edge partially overlaps two or more pixels on
+ this scanline. These pixels are referred to as a run.
+
+ +---------------+---------------+----------------+---------------+ (III)
+ | eeeeeee.|...............|................|...............|
+ | eeeeeeee..|...............|................|...............|
+ | eeeeeeee....|...............|................|...............|
+ | eeeeeee......|...............|................|...............|
+ +---------------+---------------+----------------+---------------+
+
+ This instance is much like the first instance, save that the
+ covered vertical area does not span the entire scanline.
+
+ +---------------+---------------+----------------+---------------+ (IV)
+ | | | | eeeeeeeeeee...|
+ | | eeeeeeeeeeeeeeeeeeeeeeeeeeeeeee...|
+ | eeeeeeeeeeeeeeeeeeeeeeeeeeeeeeeeeeeeee|...............|
+ |eeeeeeeeeeeeeeeeeeeeeee........|................|...............|
+ +---------------+---------------+----------------+---------------+
+
+ And this the second, again with the same distinction therefrom.
+
+ In each of these instances, a trapezoid is formed within every
+ pixel of the scanline, between:
+
+ - The point of the span's entry into the first pixel, either that
+ point itself or, for subsequent pixels, its projection onto
+ those pixels.
+
+ - The point of the span's exit or its termination.
+
+ - Both those points projected into the outer boundary of the
+ pertinent pixel.
+
+ The proportion formed by the area of this trapezoid and that of the
+ pixel then constitutes the coverage value to be recorded. */
+
+/* Structure representing a step, as above. */
+
+struct sfnt_step
+{
+ /* The next step in this list. */
+ struct sfnt_step *next;
+
+ /* X coordinate of the step. This value affects all pixels at and
+ beyond this X coordinate. */
+ int x;
+
+ /* Coverage value between -1 and 1. */
+ float coverage;
+};
+
+/* Structure representing an array of steps, one for each
+ scanline. */
+
+struct sfnt_step_raster
+{
+ /* Number of scanlines within this raster. */
+ size_t scanlines;
+
+ /* Array of steps with one element for each scanline. */
+ struct sfnt_step **steps;
+
+ /* Linked list of chunks of steps allocated for this raster. */
+ struct sfnt_step_chunk *chunks;
+};
+
+enum
+ {
+ SFNT_BLOCK_STEPS = 128,
+ };
+
+/* Structure representing a block of steps, which are allocated
+ SFNT_BLOCK_STEPS at a time. */
+
+struct sfnt_step_chunk
+{
+ /* The next chunk in this list, or NULL. */
+ struct sfnt_step_chunk *next;
+
+ /* Number of steps used within this chunk thus far. */
+ size_t nused;
+
+ /* The steps themselves. */
+ struct sfnt_step steps[SFNT_BLOCK_STEPS];
+};
+
+/* Structure representing an edge as consumed by the exact coverage
+ scaler. This structure is much like struct sfnt_edge, albeit with
+ all fractionals replaced by floating point numbers and an extra
+ field holding a Y delta. */
+
+struct sfnt_fedge
+{
+ /* Next edge in this chain. */
+ struct sfnt_fedge *next;
+
+ /* Winding direction. 1 if clockwise, -1 if counterclockwise. */
+ int winding;
+
+ /* X position, top and bottom of edges. */
+ float x, top, bottom;
+
+ /* Amount to move X by upon each change of Y, and vice versa. */
+ float step_x, step_y;
+};
+
+typedef void (*sfnt_fedge_proc) (struct sfnt_fedge *, size_t,
+ void *);
+
+/* Build a list of edges for each contour in OUTLINE, displacing each
+ edge by xmin and ymin. Call EDGE_PROC with DCONTEXT and the edges
+ produced as arguments. */
+
+static void
+sfnt_build_outline_fedges (struct sfnt_glyph_outline *outline,
+ sfnt_fedge_proc edge_proc, void *dcontext)
+{
+ struct sfnt_fedge *edges;
+ size_t i, edge, next_vertex;
+ sfnt_fixed dx, dy, step_x, step_y, ymin, xmin;
+ size_t top, bottom;
+
+ edges = alloca (outline->outline_used * sizeof *edges);
+ edge = 0;
+
+ /* ymin and xmin must be the same as the offset used to set offy and
+ offx in rasters. */
+ ymin = sfnt_floor_fixed (outline->ymin);
+ xmin = sfnt_floor_fixed (outline->xmin);
+
+ for (i = 0; i < outline->outline_used; ++i)
+ {
+ /* Set NEXT_VERTEX to the next point (vertex) in this contour.
+
+ If i is past the end of the contour, then don't build edges
+ for this point. */
+ next_vertex = i + 1;
+
+ if (next_vertex == outline->outline_used
+ || !(outline->outline[next_vertex].flags
+ & SFNT_GLYPH_OUTLINE_LINETO))
+ continue;
+
+ /* Skip past horizontal vertices. */
+ if (outline->outline[next_vertex].y == outline->outline[i].y)
+ continue;
+
+ /* Figure out the winding direction. */
+ if (outline->outline[next_vertex].y < outline->outline[i].y)
+ /* Vector will cross imaginary ray from its bottom from the
+ left of the ray. Winding is thus 1. */
+ edges[edge].winding = 1;
+ else
+ /* Moving clockwise. Winding is thus -1. */
+ edges[edge].winding = -1;
+
+ /* Figure out the top and bottom values of this edge. If the
+ next edge is below, top is here and bot is the edge below.
+ If the next edge is above, then top is there and this is the
+ bottom. */
+
+ if (outline->outline[next_vertex].y < outline->outline[i].y)
+ {
+ /* End of edge is below this one (keep in mind this is a
+ cartesian coordinate system, so smaller values are below
+ larger ones.) */
+ top = i;
+ bottom = next_vertex;
+ }
+ else
+ {
+ /* End of edge is above this one. */
+ bottom = i;
+ top = next_vertex;
+ }
+
+ /* Record the edge. Rasterization happens from bottom to
+ up, so record the X at the bottom. */
+ dx = (outline->outline[top].x - outline->outline[bottom].x);
+ dy = abs (outline->outline[top].y
+ - outline->outline[bottom].y);
+
+ /* Compute the step X. This is how much X changes for each
+ increase in Y. */
+ step_x = sfnt_div_fixed (dx, dy);
+
+ /* And the step Y, which is the amount of movement to Y an
+ increase in X will incur. */
+ step_y = dx ? sfnt_div_fixed (dy, dx) : 0;
+
+ /* Save information computed above into the edge. */
+ edges[edge].top
+ = sfnt_fixed_float (outline->outline[top].y - ymin);
+ edges[edge].bottom
+ = sfnt_fixed_float (outline->outline[bottom].y - ymin);
+ edges[edge].x
+ = sfnt_fixed_float (outline->outline[bottom].x - xmin);
+ edges[edge].step_x = sfnt_fixed_float (step_x);
+ edges[edge].step_y = sfnt_fixed_float (step_y);
+ edges[edge].next = NULL;
+
+ /* Increment the edge index. */
+ edge++;
+ }
+
+ if (edge)
+ edge_proc (edges, edge, dcontext);
+}
+
+typedef void (*sfnt_step_raster_proc) (struct sfnt_step_raster *, void *);
+
+/* Append a step with the supplied COVERAGE at X to the sorted list of
+ scanline steps within the container RASTER. Y is the scanline to
+ append to. */
+
+static void
+sfnt_insert_raster_step (struct sfnt_step_raster *raster,
+ int x, float coverage, size_t scanline)
+{
+ struct sfnt_step_chunk *chunk;
+ struct sfnt_step *step, **p_next;
+
+ if (scanline >= raster->scanlines)
+ return;
+
+ if (x < 0)
+ x = 0;
+
+ /* Search within RASTER->steps[scanline] for a step at X. */
+
+ p_next = &raster->steps[scanline];
+
+ while ((step = *p_next))
+ {
+ if (step->x > x)
+ break;
+
+ if (step->x == x)
+ goto found;
+
+ p_next = &step->next;
+ }
+
+ if (!raster->chunks
+ || raster->chunks->nused == SFNT_BLOCK_STEPS)
+ {
+ /* All chunks have been consumed, and consequently a new chunk
+ must be allocated. */
+ chunk = xmalloc (sizeof *chunk);
+ chunk->next = raster->chunks;
+ chunk->nused = 0;
+ raster->chunks = chunk;
+ }
+ else
+ chunk = raster->chunks;
+
+ step = &chunk->steps[chunk->nused++];
+ step->next = *p_next;
+ *p_next = step;
+ step->x = x;
+ step->coverage = 0;
+
+ found:
+ step->coverage += coverage;
+}
+
+/* Draw EDGES, an unsorted array of polygon edges of size NEDGES.
+
+ Transform EDGES into an array of steps representing a raster with
+ HEIGHT scanlines, then call POLY_FUNC with DCONTEXT and the
+ resulting struct sfnt_step_raster to transfer it onto an actual
+ raster.
+
+ WIDTH must be the width of the raster. Although there is no
+ guarantee that no steps generated extend past WIDTH, steps starting
+ after width might be omitted, and as such it must be accurate. */
+
+static void
+sfnt_poly_edges_exact (struct sfnt_fedge *edges, size_t nedges,
+ size_t height, size_t width,
+ sfnt_step_raster_proc proc, void *dcontext)
+{
+ int y;
+ size_t size, e, edges_processed;
+ struct sfnt_fedge *active, **prev, *a, sentinel;
+ struct sfnt_step_raster raster;
+ struct sfnt_step_chunk *next, *last;
+
+ if (!height)
+ return;
+
+ /* Step down line by line. Find active edges. */
+
+ y = sfnt_floor_fixed (MAX (0, edges[0].bottom));
+ e = edges_processed = 0;
+ active = &sentinel;
+
+ /* Allocate the array of edges. */
+
+ raster.scanlines = height;
+ raster.chunks = NULL;
+
+ if (ckd_mul (&size, height, sizeof *raster.steps))
+ abort ();
+
+ raster.steps = xzalloc (size);
+
+ for (; y != height; y += 1)
+ {
+ /* Run over the whole array on each iteration of this loop;
+ experiments demonstrate this is faster for the majority of
+ glyphs. */
+ for (e = 0; e < nedges; ++e)
+ {
+ /* Although edges is unsorted, edges which have already been
+ processed will see their next fields set, and can thus be
+ disregarded. */
+ if (!edges[e].next
+ && (edges[e].bottom < y + 1)
+ && (edges[e].top > y))
+ {
+ /* As steps generated from each edge are sorted at the
+ time of their insertion, sorting the list of active
+ edges itself is redundant. */
+ edges[e].next = active;
+ active = &edges[e];
+
+ /* Increment the counter recording the number of edges
+ processed, which is used to terminate this loop early
+ once all have been processed. */
+ edges_processed++;
+ }
+ }
+
+ /* Iterate through each active edge, appending steps for it, and
+ removing it if it does not overlap with the next
+ scanline. */
+
+ for (prev = &active; (a = *prev) != &sentinel;)
+ {
+ float x_top, x_bot, x_min, x_max;
+ float y_top, y_bot;
+ int x_pixel_min, x_pixel_max;
+
+#define APPEND_STEP(x, coverage) \
+ sfnt_insert_raster_step (&raster, x, coverage, y);
+
+ /* Calculate several values to establish which overlap
+ category this edge falls into. */
+
+ y_top = y + 1; /* Topmost coordinate covered by this
+ edge in this scanline. */
+ y_bot = y; /* Bottom-most coordinate covered by this
+ edge in this scanline. */
+
+ /* III or IV? If the edge terminates before the next
+ scanline, make its terminus y_top. */
+
+ if (y_top > a->top)
+ y_top = a->top;
+
+ /* Same goes for y_bottom. */
+
+ if (a->bottom > y_bot)
+ y_bot = a->bottom;
+
+ /* y_top should never equal y_bottom, but check to be on the
+ safe side. */
+ if (y_top == y_bot)
+ goto next;
+
+ /* x_top and x_bot are the X positions where the edge enters
+ and exits this scanline. */
+
+ /*
+ (x_top)
+ +--------ee-----+------------------------------------------------+ (y_top)
+ | ee.......|................................................|
+ | ee.........|................................................|
+ | ee...........|................................................|
+ |ee.............|................................................|
+ ee---------------+------------------------------------------------+ (y_bot)
+(x_bot)
+ (y_bot might be further below.)
+ */
+
+ x_top = (y_top - a->bottom) * a->step_x + a->x;
+ x_bot = (y_bot - a->bottom) * a->step_x + a->x;
+
+ x_min = MIN (x_top, x_bot);
+ x_max = MAX (x_top, x_bot);
+
+ /* Pixels containing x_bot and x_top respectively. */
+ x_pixel_min = (int) (x_min);
+ x_pixel_max = (int) (x_max);
+
+#define TRAPEZOID_AREA(height, top_start, top_end, bot_start, bot_end) \
+ ((((float) (top_end) - (top_start)) \
+ + ((float) (bot_end) - (bot_start))) \
+ / 2.0f * (float) (height))
+
+ /* I, III? These two instances' criteria are that the edge
+ enters and exits within one pixel. */
+
+ if (x_pixel_min == x_pixel_max)
+ {
+ float xmin, xmax, ytop, ybot, height;
+ float coverage, delta;
+
+ /* Partial coverage for the first pixel. */
+
+ xmin = (x_min);
+ xmax = (x_max);
+ ytop = (y_top);
+ ybot = (y_bot);
+ height = ytop - ybot;
+
+ /* The trapezoid here is one of the following two:
+
+ ytop+------xmax--+-----------+---------------------------------------------+
+ | /................................................................|
+ | /.......|...........|.............................................|
+ | /........|...........|.............................................|
+ | /.........|...........|.............................................|
+ | / ...................................................................|
+ xmin+------------+-----------+---------------------------------------------+
+ ybot
+ ytop+------------+-----------+---------------------------------------------+
+ |\ xmin................................................................|
+ | \..........|...........|.............................................|
+ | \.........|...........|.............................................|
+ | \........|...........|.............................................|
+ | \.......|...........|.............................................|
+ | \................................................................|
+ +------xmax--+-----------+---------------------------------------------+
+
+ In either situation, the first pixel's coverage is
+ the space occupied by a trapezoid whose corners are
+ xmin and x_pixel_min + 1 and xmax and x_pixel_min +
+ 1, and whose height is ytop - ybot. The coverage for
+ the remainder is the height alone. */
+
+ coverage = (TRAPEZOID_AREA (height,
+ xmin, (int) xmin + 1,
+ xmax, (int) xmax + 1)
+ * a->winding);
+ APPEND_STEP (x_pixel_min, coverage);
+
+ /* Then if the next pixel isn't beyond the raster,
+ append complete coverage for it. */
+
+ if (x_pixel_min + 1 < width)
+ {
+ delta = (y_top - y_bot) * a->winding;
+ APPEND_STEP (x_pixel_max + 1, delta - coverage);
+ }
+ }
+ else
+ {
+ float dy, y_crossing, coverage;
+ float ytop, ybot, xtop, xbot, increment;
+ float x, last, here;
+
+ ytop = (y_top);
+ ybot = (y_bot);
+ xtop = (x_top);
+ xbot = (x_bot);
+
+#define TRIANGLE_AREA(width, height) \
+ ((width) * (height) / 2.0f)
+
+ /* II, IV. Coverage must be computed for each pixel
+ from x_pixel_min to x_pixel_max, with the latter
+ treated much as in I or III. */
+
+ if (x_bot < x_top)
+ {
+ /*
+
+
+ y_top x_top
+ +-----------+-----------+-----------+------------+-------/------+-------------------------------+
+ | | | | | /--.......|...............................|
+ |x_pixel_min| | | | /--..........|...............................|
+ | | | | /+-y_crossing...|...............................|
+ | | | | /--.|..............|...............................|
+ | | | | /-....|..............|...............................|
+ | | | | /--......|..x_pixel_max.|...............................|
+ | | | |/--.........|..............|...............................|
+ | | | /-+............|..............|...............................|
+ | | | /--..|............|..............|...............................|
+ | | | /--.....|............|..............|...............................|
+ | | |/--........|............|..............|...............................|
+ | | /-+...........|............|..............|...............................|
+ | | /--..|...........|............|..............|...............................|
+ | | /--.....|...........|............|..............|...............................|
+ | | /-........|...........|............|..............|...............................|
+ | /+-y_crossing|...........|............|..............|...............................|
+ | /--.|...........|...........|............|..............|...............................|
+ | /--....|...........|...........|............|..............|...............................|
+ | /--.......|...........|...........|............|..............|...............................|
+ +-----------+-----------+-----------+------------+--------------+-------------------------------+
+ y_bot x_bot
+
+
+The purpose of this code is to calculate the area occupied by dots of
+each pixel in between x_pixel_min and x_pixel_max + 1.
+
+The area occupied in the first pixel is a triangle comprising [x_bot,
+y_bot], [x_bot + 1, y_bot], and [x_bot + 1, y_crossing].
+
+The area occupied in the second pixel through x_pixel_max - 1 is that
+of a rectangle comprising [y_bot, pixel], [the previous rectangle's
+y_crossing, pixel], [the previous rectangle's y_crossing, pixel + 1],
+and [pixel + 1, y_bot] summed with the area the remaining triangle.
+
+The area occupied in the last pixel is a trapezoid proper.
+
+Thus the procedure is roughly as follows: dy is computed, which is the
+increase to the Y of the edge for each increase in scanline X. */
+
+ dy = a->step_y;
+
+ /* As is y_crossing for the first pixel. */
+ y_crossing = ybot + dy * ((int) xbot + 1 - xbot);
+
+ /* And the area of the first triangle.
+
+ The width is (int) xbot + 1 - xbot, and the
+ height is y_crossing - ybot. */
+ last = ((TRIANGLE_AREA (y_crossing - ybot,
+ (int) xbot + 1 - xbot))
+ * a->winding);
+ APPEND_STEP (x_pixel_min, last);
+
+ /* Coverage value for subsequent rectangles. The
+ value set here is for the next pixel, which is
+ filled from ybot to y_crossing. */
+
+ coverage = (y_crossing - ybot) * a->winding;
+ increment = dy * a->winding;
+
+ for (x = x_pixel_min + 1; x < x_pixel_max; x++)
+ {
+ here = coverage + increment / 2;
+ APPEND_STEP (x, here - last);
+ last = here;
+ coverage += increment;
+ }
+
+ /* The y_crossing for the last pixel. */
+ y_crossing = ybot + dy * ((int) xtop - xbot);
+
+ /* And calculate the area of the trapezoid in the
+ last pixel. */
+
+ coverage += a->winding * TRAPEZOID_AREA (ytop - y_crossing,
+ xtop,
+ (int) xtop + 1,
+ (int) xtop,
+ (int) xtop + 1);
+ here = coverage;
+ APPEND_STEP (x_pixel_max, here - last);
+ last = here;
+
+ /* Fill the remainder of the scanline with
+ height-derived coverage. */
+
+ if (x_pixel_max + 1 < width)
+ APPEND_STEP (x_pixel_max + 1, ((y_top - y_bot)
+ * a->winding - last));
+ }
+ else /* if (x_bot > x_top) */
+ {
+ /*
+
+ y_top x_top
+ +----------------+----------------+-----------------+-----------------+-----------------------------+
+ | \--........|................|.................|.................|.............................|
+ | \--.....|................|.................|.................|.............................|
+ | \--..|................|.................|.................|.............................|
+ | \-+.y_crossing.....|.................|.................|.............................|
+ | |\--.............|.................|.................|.............................|
+ | | \--..........|.................|.................|.............................|
+ | x_pixel_min | \---......|.................|.................|.............................|
+ | | \--...|.................|.................|.............................|
+ | | \--|y_crossing.......|.................|.............................|
+ | | \--...............|.................|.............................|
+ | | | \--............|.................|.............................|
+ | | | \--.........|.................|.............................|
+ | | | \--......|.................|.............................|
+ +----------------+----------------+-----------\-----+-----------------+-----------------------------+
+ y_bot x_bot
+
+Whereas in this situation the trapezoid is inverted, and the code must
+be as well. */
+
+ /* The edge's Y decreases as the edge's X increases,
+ yielding a negative a->step_x. */
+ dy = a->step_y;
+
+ /* Calculate y_crossing for the first pixel. */
+ y_crossing = ytop + dy * ((int) xtop + 1 - xtop);
+
+ /* And the area of the first triangle. */
+ last = ((TRIANGLE_AREA ((int) xtop + 1 - xtop,
+ ytop - y_crossing))
+ * a->winding);
+ APPEND_STEP (x_pixel_min, last);
+
+ /* Coverage value for subsequent rectangles. The
+ value set here is for the next pixel, which is
+ filled from ytop to y_crossing. */
+ coverage = (ytop - y_crossing) * a->winding;
+ increment = -dy * a->winding;
+
+ for (x = x_pixel_min + 1; x < x_pixel_max; x ++)
+ {
+ here = coverage + increment / 2;
+ APPEND_STEP (x, here - last);
+ last = here;
+ coverage += increment;
+ }
+
+ /* The y_crossing for the last pixel. */
+ y_crossing = ytop + dy * ((int) xbot - xtop);
+
+ /* And calculate the area of the trapezoid in the
+ last pixel. */
+
+ coverage += a->winding * TRAPEZOID_AREA (y_crossing - ybot,
+ (int) xbot,
+ (int) xbot + 1,
+ xbot,
+ (int) xbot + 1);
+ here = coverage;
+ APPEND_STEP (x_pixel_max, here - last);
+ last = here;
+
+ /* Fill the remainder of the scanline with
+ height-derived coverage. */
+
+ if (x_pixel_max + 1 < width)
+ APPEND_STEP (x_pixel_max + 1, ((y_top - y_bot)
+ * a->winding - last));
+ }
+
+#undef TRIANGLE_AREA
+ }
+
+#undef APPEND_STEP
+#undef TRAPEZOID_AREA
+
+ /* When an edge is created, its a->bottom (and by extension
+ a->y) is not aligned to a->x. Since this iteration can
+ only affect the scan line Y, align a to the next
+ scanline, that the next iteration of this loop to
+ consider it might consider its entire intersection. */
+ a->x += a->step_x * (y + 1 - a->bottom);
+ a->bottom = y + 1;
+ next:
+
+ if (a->top < y + 1)
+ *prev = a->next;
+ else
+ /* This edge doesn't intersect with the next scanline;
+ remove it from the list. After the edge at hand is so
+ deleted from the list, its next field remains set,
+ excluding it from future consideration. */
+ prev = &a->next;
+ }
+
+ /* Break if all is done. */
+ if (active == &sentinel && edges_processed == nedges)
+ break;
+ }
+
+ (*proc) (&raster, dcontext);
+ xfree (raster.steps);
+
+ /* Free each block of steps allocated. */
+ next = raster.chunks;
+ while (next)
+ {
+ last = next;
+ next = next->next;
+ xfree (last);
+ }
+}
+
+/* Apply winding rule to the coverage value VALUE. Convert VALUE to a
+ number between 0 and 255. If VALUE is negative, invert it. If it
+ exceeds 255 afterwards, truncate it to 255. */
+
+static int
+sfnt_compute_fill (float value)
+{
+ if (value < 0)
+ value = -value;
+
+ return MIN (value * 255, 255);
+}
+
+/* Set N pixels at DATA to the value VALUE. If N is large, call
+ memset; otherwise set this by hand. */
+
+static void
+sfnt_poly_set_steps (unsigned char *data, int value, int n)
+{
+ unsigned char *p;
+
+ p = data;
+ switch (n)
+ {
+ case 7:
+ *p++ = value;
+ FALLTHROUGH;
+ case 6:
+ *p++ = value;
+ FALLTHROUGH;
+ case 5:
+ *p++ = value;
+ FALLTHROUGH;
+ case 4:
+ *p++ = value;
+ FALLTHROUGH;
+ case 3:
+ *p++ = value;
+ FALLTHROUGH;
+ case 2:
+ *p++ = value;
+ FALLTHROUGH;
+ case 1:
+ *p++ = value;
+ FALLTHROUGH;
+ case 0:
+ break;
+ default:
+ memset (data, value, n);
+ }
+}
+
+/* Transfer steps generated by sfnt_poly_edges_exact from STEPS to the
+ provided raster RASTER. */
+
+static void
+sfnt_poly_steps (struct sfnt_step_raster *steps,
+ struct sfnt_raster *raster)
+{
+ int y;
+ unsigned char *data;
+ int x, xend, fill;
+ float total;
+ struct sfnt_step *step;
+
+ y = 0; /* This y is an X-style coordinate in RASTER's space.
+
+ Its counterpart array of steps is STEPS->steps[
+ raster->height - y - 1]. */
+ data = raster->cells;
+
+ for (y = 0; y < raster->height; ++y, data += raster->stride)
+ {
+ fill = total = x = 0;
+
+ for (step = steps->steps[raster->height - y - 1];
+ step && x < raster->width; step = step->next)
+ {
+ xend = MIN (step->x, raster->width);
+
+ if (fill)
+ sfnt_poly_set_steps (data + x, fill, xend - x);
+
+ total += step->coverage;
+ fill = sfnt_compute_fill (total);
+ x = xend;
+ }
+
+ if (x < raster->width)
+ sfnt_poly_set_steps (data + x, fill, raster->width - x);
+ }
+}
+
+/* Poly each edge in EDGES onto the raster supplied in DCONTEXT. */
+
+static void
+sfnt_raster_steps (struct sfnt_step_raster *steps, void *dcontext)
+{
+ sfnt_poly_steps (steps, dcontext);
+}
+
+/* Call sfnt_poly_edges_exact with suitable arguments for polying
+ EDGES onto DCONTEXT, a raster structure. */
+
+static void
+sfnt_raster_edges_exact (struct sfnt_fedge *edges, size_t size,
+ void *dcontext)
+{
+ struct sfnt_raster *raster;
+
+ raster = dcontext;
+ sfnt_poly_edges_exact (edges, size, raster->height,
+ raster->width, sfnt_raster_steps,
+ dcontext);
+}
+
+/* Generate an alpha mask for the glyph outline OUTLINE by means of
+ the exact coverage scaler. Value is the alpha mask upon success,
+ NULL upon failure. */
+
+TEST_STATIC struct sfnt_raster *
+sfnt_raster_glyph_outline_exact (struct sfnt_glyph_outline *outline)
+{
+ struct sfnt_raster raster, *data;
+
+ /* Get the raster parameters. */
+ sfnt_prepare_raster (&raster, outline);
+
+ /* Allocate the raster data. */
+ data = xmalloc (sizeof *data + raster.stride * raster.height);
+ *data = raster;
+ data->cells = (unsigned char *) (data + 1);
+ memset (data->cells, 0, raster.stride * raster.height);
+
+ /* Generate edges for the outline, polying each array of edges to
+ the raster. */
+ sfnt_build_outline_fedges (outline, sfnt_raster_edges_exact, data);
+
+ /* All done. */
+ return data;
+}
+
+
+
+/* Glyph metrics computation. */
+
+/* Read an hmtx table from the font FD, using the table directory
+ specified as SUBTABLE, the maxp table MAXP, and the hhea table
+ HHEA.
+
+ Return NULL upon failure, and the hmtx table otherwise.
+ HHEA->num_of_long_hor_metrics determines the number of horizontal
+ metrics present, and MAXP->num_glyphs -
+ HHEA->num_of_long_hor_metrics determines the number of left-side
+ bearings present. */
+
+TEST_STATIC struct sfnt_hmtx_table *
+sfnt_read_hmtx_table (int fd, struct sfnt_offset_subtable *subtable,
+ struct sfnt_hhea_table *hhea,
+ struct sfnt_maxp_table *maxp)
+{
+ struct sfnt_table_directory *directory;
+ struct sfnt_hmtx_table *hmtx;
+ size_t size;
+ ssize_t rc;
+ int i;
+
+ /* Find the table in the directory. */
+
+ directory = sfnt_find_table (subtable, SFNT_TABLE_HMTX);
+
+ if (!directory)
+ return NULL;
+
+ /* Figure out how many bytes are required. */
+ size = ((hhea->num_of_long_hor_metrics
+ * sizeof (struct sfnt_long_hor_metric))
+ + (MAX (0, ((int) maxp->num_glyphs
+ - hhea->num_of_long_hor_metrics))
+ * sizeof (int16_t)));
+
+ /* Check the length matches exactly. */
+ if (directory->length != size)
+ return NULL;
+
+ /* Seek to the location given in the directory. */
+ if (lseek (fd, directory->offset, SEEK_SET) == (off_t) -1)
+ return NULL;
+
+ /* Now allocate enough to hold all of that along with the table
+ directory structure. */
+
+ hmtx = xmalloc (sizeof *hmtx + size);
+
+ /* Read into hmtx + 1. */
+ rc = read (fd, hmtx + 1, size);
+ if (rc == -1 || rc < size)
+ {
+ xfree (hmtx);
+ return NULL;
+ }
+
+ /* Set pointers to data. */
+ hmtx->h_metrics = (struct sfnt_long_hor_metric *) (hmtx + 1);
+ hmtx->left_side_bearing
+ = (int16_t *) (hmtx->h_metrics
+ + hhea->num_of_long_hor_metrics);
+
+ /* Swap what was read. */
+
+ for (i = 0; i < hhea->num_of_long_hor_metrics; ++i)
+ {
+ sfnt_swap16 (&hmtx->h_metrics[i].advance_width);
+ sfnt_swap16 (&hmtx->h_metrics[i].left_side_bearing);
+ }
+
+ for (; i < maxp->num_glyphs; ++i)
+ sfnt_swap16 (&hmtx->left_side_bearing[i - hhea->num_of_long_hor_metrics]);
+
+ /* All done. */
+ return hmtx;
+}
+
+/* Obtain unscaled glyph metrics for the glyph indexed by GLYPH.
+ Return 0 and the metrics in *METRICS if metrics could be found,
+ else 1.
+
+ HMTX, HHEA and MAXP should be the hmtx, hhea, head, and maxp tables
+ of the font respectively. */
+
+TEST_STATIC int
+sfnt_lookup_glyph_metrics (sfnt_glyph glyph,
+ struct sfnt_glyph_metrics *metrics,
+ struct sfnt_hmtx_table *hmtx,
+ struct sfnt_hhea_table *hhea,
+ struct sfnt_maxp_table *maxp)
+{
+ short lbearing;
+ unsigned short advance;
+
+ if (glyph < hhea->num_of_long_hor_metrics)
+ {
+ /* There is a long entry in the hmtx table. */
+ lbearing = hmtx->h_metrics[glyph].left_side_bearing;
+ advance = hmtx->h_metrics[glyph].advance_width;
+ }
+ else if (hhea->num_of_long_hor_metrics
+ && glyph < maxp->num_glyphs)
+ {
+ /* There is a short entry in the hmtx table. */
+ lbearing
+ = hmtx->left_side_bearing[glyph
+ - hhea->num_of_long_hor_metrics];
+ advance
+ = hmtx->h_metrics[hhea->num_of_long_hor_metrics - 1].advance_width;
+ }
+ else
+ /* No entry corresponds to the glyph. */
+ return 1;
+
+ /* Return unscaled metrics. */
+ metrics->lbearing = lbearing;
+ metrics->advance = advance;
+ return 0;
+}
+
+/* Scale the specified glyph metrics by FACTOR. Set METRICS->lbearing
+ and METRICS->advance to their current values times factor; take the
+ floor of the left bearing and round the advance width. */
+
+MAYBE_UNUSED TEST_STATIC void
+sfnt_scale_metrics (struct sfnt_glyph_metrics *metrics,
+ sfnt_fixed factor)
+{
+ sfnt_fixed lbearing, advance;
+
+ lbearing = sfnt_mul_fixed (metrics->lbearing * 65536, factor);
+ advance = sfnt_mul_fixed (metrics->advance * 65536, factor);
+
+ metrics->lbearing = sfnt_floor_fixed (lbearing);
+ metrics->advance = sfnt_round_fixed (advance);
+}
+
+/* Calculate the factor used to convert em space to device space for a
+ font with the specified HEAD table and PPEM value. */
+
+MAYBE_UNUSED TEST_STATIC sfnt_fixed
+sfnt_get_scale (struct sfnt_head_table *head, int ppem)
+{
+ /* Figure out how to convert from font unit-space to pixel space.
+ To turn one unit to its corresponding pixel size given a ppem of
+ 1, the unit must be divided by head->units_per_em. Then, it must
+ be multiplied by the ppem. So,
+
+ PIXEL = UNIT / UPEM * PPEM
+
+ which means:
+
+ PIXEL = UNIT * PPEM / UPEM */
+
+ return sfnt_div_fixed (ppem, head->units_per_em);
+}
+
+
+
+/* Font style parsing. */
+
+/* Read the name table from the given font FD, using the table
+ directory specified as SUBTABLE. Perform validation on the offsets
+ in the name records. Return NULL upon failure, else the name
+ table. */
+
+TEST_STATIC struct sfnt_name_table *
+sfnt_read_name_table (int fd, struct sfnt_offset_subtable *subtable)
+{
+ struct sfnt_table_directory *directory;
+ struct sfnt_name_table *name;
+ size_t required;
+ ssize_t rc;
+ int i;
+
+ /* Find the table in the directory. */
+
+ directory = sfnt_find_table (subtable, SFNT_TABLE_NAME);
+
+ if (!directory)
+ return NULL;
+
+ /* Seek to the location given in the directory. */
+ if (lseek (fd, directory->offset, SEEK_SET) == (off_t) -1)
+ return NULL;
+
+ /* Figure out the minimum that has to be read. */
+ required = SFNT_ENDOF (struct sfnt_name_table,
+ string_offset, uint16_t);
+
+ if (directory->length < required)
+ return NULL;
+
+ /* Allocate enough to hold the name table and variable length
+ data. */
+ name = xmalloc (sizeof *name + directory->length);
+
+ /* Read the fixed length data. */
+ rc = read (fd, name, required);
+ if (rc == -1 || rc < required)
+ {
+ xfree (name);
+ return NULL;
+ }
+
+ /* Swap what was read. */
+ sfnt_swap16 (&name->format);
+ sfnt_swap16 (&name->count);
+ sfnt_swap16 (&name->string_offset);
+
+ /* Reject unsupported formats. */
+ if (name->format)
+ {
+ xfree (name);
+ return NULL;
+ }
+
+ /* Set the pointer to the start of the variable length data. */
+ name->name_records
+ = (struct sfnt_name_record *) (name + 1);
+
+ /* Check there is enough for the name records. */
+ required = directory->length - required;
+ if (required < name->count * sizeof *name->name_records)
+ {
+ xfree (name);
+ return NULL;
+ }
+
+ /* Read the variable length data. First, read the name records. */
+ rc = read (fd, name->name_records,
+ (name->count
+ * sizeof *name->name_records));
+ if (rc == -1 || (rc < (name->count
+ * sizeof *name->name_records)))
+ {
+ xfree (name);
+ return NULL;
+ }
+
+ /* Swap each of the name records. */
+ for (i = 0; i < name->count; ++i)
+ {
+ sfnt_swap16 (&name->name_records[i].platform_id);
+ sfnt_swap16 (&name->name_records[i].platform_specific_id);
+ sfnt_swap16 (&name->name_records[i].language_id);
+ sfnt_swap16 (&name->name_records[i].name_id);
+ sfnt_swap16 (&name->name_records[i].length);
+ sfnt_swap16 (&name->name_records[i].offset);
+ }
+
+ /* Now, read the name data. */
+
+ if (name->string_offset > directory->length)
+ {
+ xfree (name);
+ return NULL;
+ }
+
+ required = directory->length - name->string_offset;
+
+ /* It can happen that the string offset comes before the name
+ records, and as a result exceeds the number of bytes
+ previously allocated. Extend name if that is the case. */
+
+ if (required > (directory->length
+ - (name->count
+ * sizeof *name->name_records)))
+ {
+ name = xrealloc (name, (sizeof *name
+ + (name->count
+ * sizeof *name->name_records)
+ + required));
+ name->name_records = (struct sfnt_name_record *) (name + 1);
+ }
+
+ /* There is enough space past name->name_records to hold REQUIRED
+ bytes. Seek to the right offset. */
+
+ if (lseek (fd, directory->offset + name->string_offset,
+ SEEK_SET) == (off_t) -1)
+ {
+ xfree (name);
+ return NULL;
+ }
+
+ /* Read REQUIRED bytes into the string data. */
+ name->data = (unsigned char *) (name->name_records
+ + name->count);
+ rc = read (fd, name->data, required);
+ if (rc == -1 || rc < required)
+ {
+ xfree (name);
+ return NULL;
+ }
+
+ /* Now validate each of the name records. */
+ for (i = 0; i < name->count; ++i)
+ {
+ if (((int) name->name_records[i].offset
+ + name->name_records[i].length) > required)
+ {
+ /* The name is out of bounds! */
+ xfree (name);
+ return NULL;
+ }
+ }
+
+ /* Return the name table. */
+ return name;
+}
+
+/* Return a pointer to the name data corresponding with CODE under the
+ name table NAME. Return the start of the data and the name record
+ under *RECORD upon success, and NULL otherwise. */
+
+TEST_STATIC unsigned char *
+sfnt_find_name (struct sfnt_name_table *name,
+ enum sfnt_name_identifier_code code,
+ struct sfnt_name_record *record)
+{
+ int i;
+
+ for (i = 0; i < name->count; ++i)
+ {
+ if (name->name_records[i].name_id == code)
+ {
+ /* The offsets within have already been validated. */
+ *record = name->name_records[i];
+ return name->data + record->offset;
+ }
+ }
+
+ return NULL;
+}
+
+/* Read the meta table from the given font FD, using the table
+ directory specified as SUBTABLE. Perform validation on the offsets
+ in each metadata record. Return NULL upon failure, else the meta
+ table. */
+
+TEST_STATIC struct sfnt_meta_table *
+sfnt_read_meta_table (int fd, struct sfnt_offset_subtable *subtable)
+{
+ struct sfnt_table_directory *directory;
+ struct sfnt_meta_table *meta;
+ size_t required, i, data_size, map_size, offset;
+ ssize_t rc;
+
+ /* Find the table in the directory. */
+
+ directory = sfnt_find_table (subtable, SFNT_TABLE_META);
+
+ if (!directory)
+ return NULL;
+
+ /* Seek to the location given in the directory. */
+ if (lseek (fd, directory->offset, SEEK_SET) == (off_t) -1)
+ return NULL;
+
+ /* Figure out the minimum that has to be read. */
+ required = SFNT_ENDOF (struct sfnt_meta_table,
+ num_data_maps, uint32_t);
+
+ if (directory->length < required)
+ return NULL;
+
+ /* Allocate enough to hold it. */
+ meta = xmalloc (sizeof *meta);
+
+ /* Read the header. */
+ rc = read (fd, meta, required);
+ if (rc == -1 || rc < required)
+ {
+ xfree (meta);
+ return NULL;
+ }
+
+ /* Swap what has been read so far. */
+ sfnt_swap32 (&meta->version);
+ sfnt_swap32 (&meta->flags);
+ sfnt_swap32 (&meta->data_offset);
+ sfnt_swap32 (&meta->num_data_maps);
+
+ /* Make sure the meta is supported. */
+ if (meta->version != 1)
+ {
+ xfree (meta);
+ return NULL;
+ }
+
+ /* Reallocate the table to hold sizeof *meta + meta->num_data_maps
+ times sizeof meta->data_maps + directory->length bytes. This is
+ because it is ok for metadata to point into the data map itself,
+ so an unswapped copy of the whole meta contents must be
+ retained. */
+
+ if (ckd_mul (&map_size, sizeof *meta->data_maps, meta->num_data_maps)
+ /* Do so while checking for overflow from bad sfnt files. */
+ || ckd_add (&data_size, map_size, sizeof *meta)
+ || ckd_add (&data_size, data_size, directory->length))
+ {
+ xfree (meta);
+ return NULL;
+ }
+
+ /* Do the reallocation. */
+ meta = xrealloc (meta, data_size);
+
+ /* Check that the remaining data is big enough to hold the data
+ maps. */
+ if (directory->length - required < map_size)
+ {
+ xfree (meta);
+ return NULL;
+ }
+
+ /* Set pointers to data_maps and data. */
+ meta->data_maps = (struct sfnt_meta_data_map *) (meta + 1);
+ meta->data = (unsigned char *) (meta->data_maps
+ + meta->num_data_maps);
+
+ /* Now, seek back. Read the entire table into meta->data. */
+ if (lseek (fd, directory->offset, SEEK_SET) == (off_t) -1)
+ {
+ xfree (meta);
+ return NULL;
+ }
+
+ rc = read (fd, meta->data, directory->length);
+ if (rc < directory->length)
+ {
+ xfree (meta);
+ return NULL;
+ }
+
+ /* Copy the data maps into meta->data_maps and swap them one by
+ one. */
+ memcpy (meta->data_maps, meta->data + required,
+ map_size);
+
+ for (i = 0; i < meta->num_data_maps; ++i)
+ {
+ sfnt_swap32 (&meta->data_maps[i].tag);
+ sfnt_swap32 (&meta->data_maps[i].data_offset);
+ sfnt_swap32 (&meta->data_maps[i].data_length);
+
+ /* Verify the data offsets. Overflow checking is particularly
+ important here. */
+
+ if (ckd_add (&offset, meta->data_maps[i].data_offset,
+ meta->data_maps[i].data_length))
+ {
+ xfree (meta);
+ return NULL;
+ }
+
+ if (offset > directory->length)
+ {
+ xfree (meta);
+ return NULL;
+ }
+ }
+
+ /* All done. */
+ return meta;
+}
+
+/* Return a pointer to the metadata corresponding to TAG under the
+ meta table META. Return the start of the data and the metadata map
+ under *MAP upon success, and NULL otherwise. */
+
+MAYBE_UNUSED TEST_STATIC char *
+sfnt_find_metadata (struct sfnt_meta_table *meta,
+ enum sfnt_meta_data_tag tag,
+ struct sfnt_meta_data_map *map)
+{
+ int i;
+
+ for (i = 0; i < meta->num_data_maps; ++i)
+ {
+ if (meta->data_maps[i].tag == tag)
+ {
+ *map = meta->data_maps[i];
+ return (char *) meta->data + map->data_offset;
+ }
+ }
+
+ return NULL;
+}
+
+
+
+/* TrueType collection format support. */
+
+/* Read a TrueType collection header from the font file FD.
+ FD must currently at the start of the file.
+
+ Value is the header upon success, else NULL. */
+
+TEST_STATIC struct sfnt_ttc_header *
+sfnt_read_ttc_header (int fd)
+{
+ struct sfnt_ttc_header *ttc;
+ size_t size, i;
+ ssize_t rc;
+
+ /* First, allocate only as much as required. */
+
+ ttc = xmalloc (sizeof *ttc);
+
+ /* Read the version 1.0 data. */
+
+ size = SFNT_ENDOF (struct sfnt_ttc_header, num_fonts,
+ uint32_t);
+ rc = read (fd, ttc, size);
+ if (rc == -1 || rc < size)
+ {
+ xfree (ttc);
+ return NULL;
+ }
+
+ /* Now swap what was read. */
+ sfnt_swap32 (&ttc->ttctag);
+ sfnt_swap32 (&ttc->version);
+ sfnt_swap32 (&ttc->num_fonts);
+
+ /* Verify that the tag is as expected. */
+ if (ttc->ttctag != SFNT_TTC_TTCF)
+ {
+ xfree (ttc);
+ return NULL;
+ }
+
+ /* Now, read the variable length data. Make sure to check for
+ overflow. */
+
+ if (ckd_mul (&size, ttc->num_fonts, sizeof *ttc->offset_table))
+ {
+ xfree (ttc);
+ return NULL;
+ }
+
+ ttc = xrealloc (ttc, sizeof *ttc + size);
+ ttc->offset_table = (uint32_t *) (ttc + 1);
+ rc = read (fd, ttc->offset_table, size);
+ if (rc == -1 || rc < size)
+ {
+ xfree (ttc);
+ return NULL;
+ }
+
+ /* Swap each of the offsets read. */
+ for (i = 0; i < ttc->num_fonts; ++i)
+ sfnt_swap32 (&ttc->offset_table[i]);
+
+ /* Now, look at the version. If it is earlier than 2.0, then
+ reading is finished. */
+
+ if (ttc->version < 0x00020000)
+ return ttc;
+
+ /* If it is 2.0 or later, then continue to read ul_dsig_tag to
+ ul_dsig_offset. */
+
+ size = (SFNT_ENDOF (struct sfnt_ttc_header, ul_dsig_offset,
+ uint32_t)
+ - offsetof (struct sfnt_ttc_header, ul_dsig_tag));
+ rc = read (fd, &ttc->ul_dsig_tag, size);
+ if (rc == -1 || rc < size)
+ {
+ xfree (ttc);
+ return NULL;
+ }
+
+ /* Swap what was read. */
+ sfnt_swap32 (&ttc->ul_dsig_tag);
+ sfnt_swap32 (&ttc->ul_dsig_length);
+ sfnt_swap32 (&ttc->ul_dsig_offset);
+
+ /* All done. */
+ return ttc;
+}
+
+
+
+/* TrueType hinting support.
+
+ If you do not read the code in this section in conjunction with
+ Apple's TrueType Reference Manual, you will get very confused!
+
+ TrueType fonts don't provide simple hinting meta data, unlike Type
+ 2 or CFF fonts.
+
+ Instead, they come with a ``font program'', a bytecode program
+ which is executed upon loading the font, a ``control value
+ program'', executed upon font metrics changing, and then a ``glyph
+ program'' for each glyph, which is run to fit its glyph after
+ scaling.
+
+ The virtual machine which runs this bytecode is arranged as such:
+
+ Firstly, there is a set of registers known as the ``graphics
+ state''. Each time the point size of a font changes, the ``control
+ value program'' is run to establish the default values of the
+ ``graphics state''. Then, before each glyph program is run, the
+ ``graphics state'' is set back to the default values.
+
+ Secondly, there is an address space which contains all instructions
+ being run for the current program, which is addressed by the
+ interpreter through its program counter and also by the
+ instructions which push data on to the stack.
+
+ Thirdly, there is a single stack, from which most instructions take
+ their operands and store data.
+
+ Then, there is some memory set aside for each font, the ``storage
+ area'', which is addressed through the RS[] and WS[] instructions,
+ and a ``control value table'', which is the `cvt ' table of the
+ font.
+
+ And finally, there is a ``glyph zone'' which holds points from a
+ scaled glyph outline, and a ``twilight zone'', which holds points
+ used by the font program itself. Both are addressed indirectly
+ through one of three ``zone pointer'' registers, and are accessible
+ only when a program is being run on behalf of a glyph. */
+
+
+
+/* Functions for reading tables used by the TrueType interpreter. */
+
+/* Read the cvt table (control value table) from the given font FD,
+ using the table directory specified as SUBTABLE. Swap all values
+ in the control value table. Return NULL upon failure, else the cvt
+ table. */
+
+TEST_STATIC struct sfnt_cvt_table *
+sfnt_read_cvt_table (int fd, struct sfnt_offset_subtable *subtable)
+{
+ struct sfnt_table_directory *directory;
+ size_t required, i;
+ ssize_t rc;
+ struct sfnt_cvt_table *cvt;
+
+ /* Find the table in the directory. */
+
+ directory = sfnt_find_table (subtable, SFNT_TABLE_CVT );
+
+ if (!directory)
+ return NULL;
+
+ /* Seek to the location given in the directory. */
+ if (lseek (fd, directory->offset, SEEK_SET) == (off_t) -1)
+ return NULL;
+
+ /* Figure out the minimum amount that has to be read. */
+ if (ckd_add (&required, directory->length, sizeof *cvt))
+ return NULL;
+
+ /* Allocate enough for that much data. */
+ cvt = xmalloc (required);
+
+ /* Now set cvt->num_elements as appropriate, and make cvt->values
+ point into the values. */
+ cvt->num_elements = directory->length / 2;
+ cvt->values = (sfnt_fword *) (cvt + 1);
+
+ /* Read into cvt. */
+ rc = read (fd, cvt->values, directory->length);
+ if (rc != directory->length)
+ {
+ xfree (cvt);
+ return NULL;
+ }
+
+ /* Swap each element in the control value table. */
+ for (i = 0; i < cvt->num_elements; ++i)
+ sfnt_swap16 (&cvt->values[i]);
+
+ /* All done. */
+ return cvt;
+}
+
+/* Read the fpgm table from the given font FD, using the table
+ directory specified as SUBTABLE. Value is NULL upon failure, else
+ the fpgm table. */
+
+TEST_STATIC struct sfnt_fpgm_table *
+sfnt_read_fpgm_table (int fd, struct sfnt_offset_subtable *subtable)
+{
+ struct sfnt_table_directory *directory;
+ size_t required;
+ ssize_t rc;
+ struct sfnt_fpgm_table *fpgm;
+
+ /* Find the table in the directory. */
+
+ directory = sfnt_find_table (subtable, SFNT_TABLE_FPGM);
+
+ if (!directory)
+ return NULL;
+
+ /* Seek to the location given in the directory. */
+ if (lseek (fd, directory->offset, SEEK_SET) == (off_t) -1)
+ return NULL;
+
+ /* Figure out the minimum amount that has to be read. */
+ if (ckd_add (&required, directory->length, sizeof *fpgm))
+ return NULL;
+
+ /* Allocate enough for that much data. */
+ fpgm = xmalloc (sizeof *fpgm + directory->length);
+
+ /* Now set fpgm->num_instructions as appropriate, and make
+ fpgm->instructions point to the right place. */
+
+ fpgm->num_instructions = directory->length;
+ fpgm->instructions = (unsigned char *) (fpgm + 1);
+
+ /* Read into fpgm. */
+ rc = read (fd, fpgm->instructions, directory->length);
+ if (rc != directory->length)
+ {
+ xfree (fpgm);
+ return NULL;
+ }
+
+ /* All done. */
+ return fpgm;
+}
+
+/* Read the prep table from the given font FD, using the table
+ directory specified as SUBTABLE. Value is NULL upon failure, else
+ the prep table. */
+
+TEST_STATIC struct sfnt_prep_table *
+sfnt_read_prep_table (int fd, struct sfnt_offset_subtable *subtable)
+{
+ struct sfnt_table_directory *directory;
+ size_t required;
+ ssize_t rc;
+ struct sfnt_prep_table *prep;
+
+ /* Find the table in the directory. */
+
+ directory = sfnt_find_table (subtable, SFNT_TABLE_PREP);
+
+ if (!directory)
+ return NULL;
+
+ /* Seek to the location given in the directory. */
+ if (lseek (fd, directory->offset, SEEK_SET) == (off_t) -1)
+ return NULL;
+
+ /* Figure out the minimum amount that has to be read. */
+ if (ckd_add (&required, directory->length, sizeof *prep))
+ return NULL;
+
+ /* Allocate enough for that much data. */
+ prep = xmalloc (sizeof *prep + directory->length);
+
+ /* Now set prep->num_instructions as appropriate, and make
+ prep->instructions point to the right place. */
+
+ prep->num_instructions = directory->length;
+ prep->instructions = (unsigned char *) (prep + 1);
+
+ /* Read into prep. */
+ rc = read (fd, prep->instructions, directory->length);
+ if (rc != directory->length)
+ {
+ xfree (prep);
+ return NULL;
+ }
+
+ /* All done. */
+ return prep;
+}
+
+
+
+/* Interpreter execution environment. */
+
+/* Divide the specified two 26.6 fixed point numbers X and Y.
+ Return the result. */
+
+static sfnt_f26dot6
+sfnt_div_f26dot6 (sfnt_f26dot6 x, sfnt_f26dot6 y)
+{
+#ifdef INT64_MAX
+ int64_t result;
+
+ result = ((int64_t) x * 64) / y;
+
+ return result;
+#else
+ int sign;
+ unsigned int a, b;
+
+ sign = 1;
+
+ if (x < 0)
+ sign = -sign;
+
+ if (y < 0)
+ sign = -sign;
+
+ a = abs (x);
+ b = abs (y);
+
+ return sfnt_multiply_divide (a, 64, b) * sign;
+#endif
+}
+
+/* Multiply the specified two 26.6 fixed point numbers A and B.
+ Return the result, or an undefined value upon overflow. */
+
+static sfnt_f26dot6
+sfnt_mul_f26dot6 (sfnt_f26dot6 a, sfnt_f26dot6 b)
+{
+#ifdef INT64_MAX
+ int64_t product;
+
+ product = (int64_t) a * (int64_t) b;
+
+ /* This can be done quickly with int64_t. */
+ return product / (int64_t) 64;
+#else
+ int sign;
+
+ sign = 1;
+
+ if (a < 0)
+ sign = -sign;
+
+ if (b < 0)
+ sign = -sign;
+
+ return sfnt_multiply_divide (abs (a), abs (b),
+ 64) * sign;
+#endif
+}
+
+/* Multiply the specified two 26.6 fixed point numbers A and B, with
+ rounding. Return the result, or an undefined value upon
+ overflow. */
+
+static sfnt_f26dot6
+sfnt_mul_f26dot6_round (sfnt_f26dot6 a, sfnt_f26dot6 b)
+{
+#ifdef INT64_MAX
+ int64_t product;
+
+ product = (int64_t) a * (int64_t) b;
+
+ /* This can be done quickly with int64_t. */
+ return (product + 32) / (int64_t) 64;
+#else /* !INT64_MAX */
+ int sign;
+
+ sign = 1;
+
+ if (a < 0)
+ sign = -sign;
+
+ if (b < 0)
+ sign = -sign;
+
+ return sfnt_multiply_divide_round (abs (a), abs (b),
+ 32, 64) * sign;
+#endif /* INT64_MAX */
+}
+
+/* Multiply the specified 2.14 number with another signed 32 bit
+ number. Return the result as a signed 32 bit number. */
+
+static int32_t
+sfnt_mul_f2dot14 (sfnt_f2dot14 a, int32_t b)
+{
+#ifdef INT64_MAX
+ int64_t product;
+
+ product = (int64_t) a * (int64_t) b;
+
+ return product / (int64_t) 16384;
+#else
+ int sign;
+
+ sign = 1;
+
+ if (a < 0)
+ sign = -sign;
+
+ if (b < 0)
+ sign = -sign;
+
+ return sfnt_multiply_divide (abs (a), abs (b),
+ 16384) * sign;
+#endif
+}
+
+/* Multiply the specified 26.6 fixed point number X by the specified
+ 16.16 fixed point number Y with rounding. */
+
+static sfnt_f26dot6
+sfnt_mul_f26dot6_fixed (sfnt_f26dot6 x, sfnt_fixed y)
+{
+ return sfnt_mul_fixed_round (x, y);
+}
+
+/* Return the floor of the specified 26.6 fixed point value X. */
+
+static sfnt_f26dot6
+sfnt_floor_f26dot6 (sfnt_f26dot6 x)
+{
+ return x & 037777777700;
+}
+
+/* Return the ceiling of the specified 26.6 fixed point value X. */
+
+static sfnt_f26dot6
+sfnt_ceil_f26dot6 (sfnt_f26dot6 x)
+{
+ return (x + 077) & ~077;
+}
+
+/* Return the 26.6 fixed point value X rounded to the nearest integer
+ value. */
+
+static sfnt_f26dot6
+sfnt_round_f26dot6 (sfnt_f26dot6 x)
+{
+ /* Add 0.5. */
+ x += 040;
+
+ /* Remove the fractional. */
+ return x & ~077;
+}
+
+/* Needed by sfnt_init_graphics_state. */
+
+static void sfnt_validate_gs (struct sfnt_graphics_state *);
+
+/* Set up default values for the interpreter graphics state. Return
+ them in STATE. */
+
+static void
+sfnt_init_graphics_state (struct sfnt_graphics_state *state)
+{
+ state->auto_flip = true;
+ state->cvt_cut_in = 0104;
+ state->delta_base = 9;
+ state->delta_shift = 3;
+ state->dual_projection_vector.x = 040000; /* 1.0 */
+ state->dual_projection_vector.y = 0;
+ state->freedom_vector.x = 040000; /* 1.0 */
+ state->freedom_vector.y = 0;
+ state->instruct_control = 0;
+ state->loop = 1;
+ state->minimum_distance = 0100;
+ state->projection_vector.x = 040000; /* 1.0 */
+ state->projection_vector.y = 0;
+ state->round_state = 1;
+ state->rp0 = 0;
+ state->rp1 = 0;
+ state->rp2 = 0;
+ state->scan_control = 0;
+ state->sw_cut_in = 0;
+ state->single_width_value = 0;
+ state->zp0 = 1;
+ state->zp1 = 1;
+ state->zp2 = 1;
+
+ /* Validate the graphics state. */
+ sfnt_validate_gs (state);
+}
+
+/* Set up an interpreter to be used with a font. Use the resource
+ limits specified in the MAXP table, the values specified in the
+ CVT, HEAD and FVAR tables, the pixel size PIXEL_SIZE, and the point
+ size POINT_SIZE. CVT may be NULL, in which case the interpreter
+ will not have access to a control value table.
+
+ POINT_SIZE should be PIXEL_SIZE, converted to 1/72ths of an inch.
+
+ Value is the interpreter, with all state initialized to default
+ values, or NULL upon failure. */
+
+TEST_STATIC struct sfnt_interpreter *
+sfnt_make_interpreter (struct sfnt_maxp_table *maxp,
+ struct sfnt_cvt_table *cvt,
+ struct sfnt_head_table *head,
+ struct sfnt_fvar_table *fvar,
+ int pixel_size, int point_size)
+{
+ size_t size, temp, i, storage_size, pad;
+ struct sfnt_interpreter *interpreter;
+
+ /* Detect CFF maxp tables. */
+ if (maxp->version != 0x00010000)
+ return NULL;
+
+ /* Use the contents of the MAXP table to determine the size of the
+ interpreter structure. */
+ size = sizeof (*interpreter);
+
+ /* Add program stack. */
+ if (ckd_add (&size, size, (maxp->max_stack_elements
+ * sizeof *interpreter->stack)))
+ return NULL;
+
+ /* Add twilight zone. */
+
+ if (ckd_add (&size, size, (maxp->max_twilight_points
+ * sizeof *interpreter->twilight_x)))
+ return NULL;
+
+ if (ckd_add (&size, size, (maxp->max_twilight_points
+ * sizeof *interpreter->twilight_y)))
+ return NULL;
+
+ if (ckd_add (&size, size, (maxp->max_twilight_points
+ * sizeof *interpreter->twilight_y)))
+ return NULL;
+
+ if (ckd_add (&size, size, (maxp->max_twilight_points
+ * sizeof *interpreter->twilight_y)))
+ return NULL;
+
+ /* Add the storage area. */
+ storage_size = maxp->max_storage * sizeof *interpreter->storage;
+ if (ckd_add (&size, size, storage_size))
+ return NULL;
+
+ /* Add padding for the storage area. */
+ pad = alignof (struct sfnt_interpreter_definition);
+ pad -= size & (pad - 1);
+ if (ckd_add (&size, size, pad))
+ return NULL;
+
+ /* Add function and instruction definitions. */
+ if (ckd_add (&size, size, (((int) maxp->max_instruction_defs
+ + maxp->max_function_defs)
+ * sizeof *interpreter->function_defs)))
+ return NULL;
+
+ /* Add control value table. */
+
+ if (cvt)
+ {
+ if (ckd_mul (&temp, cvt->num_elements, sizeof *interpreter->cvt)
+ || ckd_add (&size, size, temp))
+ return NULL;
+ }
+
+ /* Allocate the interpreter. */
+ interpreter = xmalloc (size);
+
+#ifdef TEST
+ interpreter->run_hook = NULL;
+ interpreter->push_hook = NULL;
+ interpreter->pop_hook = NULL;
+#endif /* TEST */
+
+ /* Fill in pointers and default values. */
+ interpreter->max_stack_elements = maxp->max_stack_elements;
+ interpreter->num_instructions = 0;
+ interpreter->IP = 0;
+ interpreter->storage_size = maxp->max_storage;
+ interpreter->function_defs_size = maxp->max_function_defs;
+ interpreter->instruction_defs_size = maxp->max_instruction_defs;
+ interpreter->twilight_zone_size = maxp->max_twilight_points;
+ interpreter->scale = 0; /* This should be set later. */
+
+ interpreter->stack = (uint32_t *) (interpreter + 1);
+ interpreter->SP = interpreter->stack;
+ interpreter->instructions = NULL;
+ interpreter->twilight_x
+ = (sfnt_f26dot6 *) (interpreter->stack
+ + maxp->max_stack_elements);
+ interpreter->twilight_y = (interpreter->twilight_x
+ + maxp->max_twilight_points);
+ interpreter->twilight_original_x = (interpreter->twilight_y
+ + maxp->max_twilight_points);
+ interpreter->twilight_original_y
+ = (interpreter->twilight_original_x
+ + maxp->max_twilight_points);
+ interpreter->glyph_zone = NULL;
+ interpreter->advance_width = 0;
+ interpreter->storage
+ = (uint32_t *) (interpreter->twilight_original_y
+ + maxp->max_twilight_points);
+ interpreter->function_defs
+ = (struct sfnt_interpreter_definition *) (interpreter->storage
+ + maxp->max_storage);
+ interpreter->function_defs
+ = ((struct sfnt_interpreter_definition *)
+ ((unsigned char *) interpreter->function_defs + pad));
+ interpreter->instruction_defs = (interpreter->function_defs
+ + maxp->max_function_defs);
+ interpreter->cvt
+ = (sfnt_f26dot6 *) (interpreter->instruction_defs
+ + maxp->max_instruction_defs);
+
+ if (cvt)
+ interpreter->cvt_size = cvt->num_elements;
+ else
+ interpreter->cvt_size = 0;
+
+ /* Now compute the scale. Then, scale up the control value table
+ values. */
+ interpreter->scale
+ = sfnt_div_fixed (pixel_size * 64, head->units_per_em);
+
+ /* Set the PPEM. */
+ interpreter->ppem = pixel_size;
+ interpreter->point_size = point_size;
+
+ /* Zero out the interpreter state from the stack to the end of the
+ instruction definitions. */
+ memset (interpreter->stack, 0, size - sizeof *interpreter);
+
+ /* Initialize the interpreter graphics state. */
+ sfnt_init_graphics_state (&interpreter->state);
+
+ /* Load the control value table. */
+ for (i = 0; i < interpreter->cvt_size; ++i)
+ interpreter->cvt[i]
+ = sfnt_mul_f26dot6_fixed (cvt->values[i],
+ interpreter->scale);
+
+ /* Fill in the default values for phase, period and threshold. */
+ interpreter->period = 64;
+ interpreter->phase = 0;
+ interpreter->threshold = 0;
+
+ /* Fill in the current call depth. */
+ interpreter->call_depth = 0;
+
+ /* Clear variation axes. They will be set upon a call to
+ `sfnt_vary_interpreter'. */
+ interpreter->n_axis = 0;
+ interpreter->norm_coords = NULL;
+
+ /* Set n_axis now if a fvar table was provided. This way, GXAXIS
+ pushes the correct number of values even if no blend is
+ provided. */
+
+ if (fvar)
+ interpreter->n_axis = fvar->axis_count;
+
+ /* Return the interpreter. */
+ return interpreter;
+}
+
+/* These enums are used to determine why the interpreter is being
+ run. They have the following meanings:
+
+ - The interpreter is being run to interpret a font program.
+ - The interpreter is being run to interpret the control
+ value program.
+ - The interpreter is being run to fit a glyph.
+ - The interpreter is being run as part of an automated test. */
+
+enum sfnt_interpreter_run_context
+ {
+ SFNT_RUN_CONTEXT_FONT_PROGRAM,
+ SFNT_RUN_CONTEXT_CONTROL_VALUE_PROGRAM,
+ SFNT_RUN_CONTEXT_GLYPH_PROGRAM,
+#ifdef TEST
+ SFNT_RUN_CONTEXT_TEST,
+#endif
+ };
+
+/* Cancel execution of the program in INTERPRETER with the specified
+ error REASON and reset the loop counter to 1.
+
+ After this is called, it is probably okay to reuse INTERPRETER.
+ However, instructions must always be reloaded. */
+
+static AVOID
+sfnt_interpret_trap (struct sfnt_interpreter *interpreter,
+ const char *reason)
+{
+ interpreter->trap_reason = reason;
+ interpreter->call_depth = 0;
+ interpreter->state.loop = 1;
+ longjmp (interpreter->trap, 1);
+}
+
+#define STACKSIZE() \
+ (interpreter->SP - interpreter->stack)
+
+#define TRAP(why) \
+ sfnt_interpret_trap (interpreter, why)
+
+#define MOVE(a, b, n) \
+ memmove (a, b, (n) * sizeof (uint32_t))
+
+#define CHECK_STACK_ELEMENTS(n) \
+ { \
+ if ((interpreter->SP \
+ - interpreter->stack) < n) \
+ TRAP ("stack underflow"); \
+ }
+
+#define CHECK_STACK_AVAILABLE(n) \
+ { \
+ char *stack_end; \
+ \
+ stack_end \
+ = (char *) interpreter->twilight_x; \
+ if (((char *) (interpreter->SP + (n)) \
+ > stack_end)) \
+ TRAP ("stack overflow"); \
+ }
+
+#define CHECK_PREP() \
+ if (!is_prep) \
+ TRAP ("instruction executed not valid" \
+ " outside control value program") \
+
+
+
+/* Register, alu and logic instructions. */
+
+#ifndef TEST
+
+#define POP() \
+ (interpreter->SP == interpreter->stack \
+ ? (TRAP ("stack underflow"), 0) \
+ : (*(--interpreter->SP)))
+
+#define POP_UNCHECKED() (*(--interpreter->SP))
+
+#else
+
+#define POP() \
+ (interpreter->SP == interpreter->stack \
+ ? (TRAP ("stack underflow"), 0) \
+ : ({uint32_t _value; \
+ _value = *(--interpreter->SP); \
+ if (interpreter->pop_hook) \
+ interpreter->pop_hook (interpreter, \
+ _value); \
+ _value;}))
+
+#define POP_UNCHECKED() POP ()
+
+#endif
+
+#define LOOK() \
+ (interpreter->SP == interpreter->stack \
+ ? (TRAP ("stack underflow"), 0) \
+ : *(interpreter->SP - 1))
+
+#if !defined TEST
+
+#define PUSH(value) \
+ { \
+ if ((char *) (interpreter->SP + 1) \
+ > (char *) interpreter->twilight_x) \
+ TRAP ("stack overflow"); \
+ \
+ *interpreter->SP = (value); \
+ interpreter->SP++; \
+ }
+
+#define PUSH_UNCHECKED(value) \
+ { \
+ *interpreter->SP = (value); \
+ interpreter->SP++; \
+ }
+
+#else /* TEST */
+
+#define PUSH(value) \
+ { \
+ if ((char *) (interpreter->SP + 1) \
+ > (char *) interpreter->twilight_x) \
+ TRAP ("stack overflow"); \
+ \
+ if (interpreter->push_hook) \
+ interpreter->push_hook (interpreter, \
+ value); \
+ \
+ *interpreter->SP = value; \
+ interpreter->SP++; \
+ }
+
+#define PUSH_UNCHECKED(value) PUSH (value)
+
+#endif /* TEST && 0 */
+
+#define PUSH2_UNCHECKED(high, low) \
+ { \
+ int16_t word; \
+ \
+ word = (((uint8_t) high) << 8 | low); \
+ PUSH_UNCHECKED (word); \
+ } \
+
+#define SRP0() \
+ { \
+ uint32_t p; \
+ \
+ p = POP (); \
+ interpreter->state.rp0 = p; \
+ }
+
+#define SRP1() \
+ { \
+ uint32_t p; \
+ \
+ p = POP (); \
+ interpreter->state.rp1 = p; \
+ }
+
+#define SRP2() \
+ { \
+ uint32_t p; \
+ \
+ p = POP (); \
+ interpreter->state.rp2 = p; \
+ }
+
+#define SZP0() \
+ { \
+ uint32_t zone; \
+ \
+ zone = POP (); \
+ \
+ if (zone > 1) \
+ TRAP ("invalid zone"); \
+ \
+ interpreter->state.zp0 = zone; \
+ }
+
+#define SZP1() \
+ { \
+ uint32_t zone; \
+ \
+ zone = POP (); \
+ \
+ if (zone > 1) \
+ TRAP ("invalid zone"); \
+ \
+ interpreter->state.zp1 = zone; \
+ }
+
+#define SZP2() \
+ { \
+ uint32_t zone; \
+ \
+ zone = POP (); \
+ \
+ if (zone > 1) \
+ TRAP ("invalid zone"); \
+ \
+ interpreter->state.zp2 = zone; \
+ }
+
+#define SZPS() \
+ { \
+ uint32_t zone; \
+ \
+ zone = POP (); \
+ \
+ if (zone > 1) \
+ TRAP ("invalid zone"); \
+ \
+ interpreter->state.zp0 = zone; \
+ interpreter->state.zp1 = zone; \
+ interpreter->state.zp2 = zone; \
+ }
+
+#define SLOOP() \
+ { \
+ int32_t loop; \
+ \
+ loop = POP (); \
+ \
+ if (loop < 0) \
+ TRAP ("loop set to invalid value"); \
+ \
+ /* N.B. loop might be greater than 65535, \
+ but no reasonable font should define \
+ such values. */ \
+ interpreter->state.loop \
+ = MIN (65535, loop); \
+ }
+
+#define SMD() \
+ { \
+ sfnt_f26dot6 md; \
+ \
+ md = POP (); \
+ \
+ interpreter->state.minimum_distance = md; \
+ }
+
+#define ELSE() \
+ { \
+ sfnt_interpret_else (interpreter); \
+ goto skip_step; \
+ }
+
+#define JMPR() \
+ { \
+ int32_t offset; \
+ \
+ offset = POP (); \
+ \
+ if (interpreter->IP + offset < 0 \
+ || (interpreter->IP + offset \
+ > interpreter->num_instructions)) \
+ TRAP ("JMPR out of bounds"); \
+ \
+ interpreter->IP += offset; \
+ goto skip_step; \
+ }
+
+#define SCVTCI() \
+ { \
+ sfnt_f26dot6 cutin; \
+ \
+ cutin = POP (); \
+ \
+ interpreter->state.cvt_cut_in = cutin; \
+ }
+
+#define SSWCI() \
+ { \
+ sfnt_f26dot6 cutin; \
+ \
+ cutin = POP (); \
+ \
+ interpreter->state.sw_cut_in = cutin; \
+ }
+
+#define SSW() \
+ { \
+ int32_t single_width; \
+ \
+ single_width = POP (); \
+ \
+ interpreter->state.single_width_value \
+ = sfnt_mul_fixed (single_width, \
+ interpreter->scale); \
+ }
+
+#define DUP() \
+ { \
+ uint32_t value; \
+ \
+ value = LOOK (); \
+ PUSH (value); \
+ }
+
+#define CLEAR() \
+ { \
+ interpreter->SP = interpreter->stack; \
+ }
+
+#define SWAP() \
+ { \
+ uint32_t a, b; \
+ \
+ a = POP (); \
+ b = POP (); \
+ \
+ PUSH_UNCHECKED (a); \
+ PUSH_UNCHECKED (b); \
+ }
+
+#define DEPTH() \
+ { \
+ ptrdiff_t diff; \
+ \
+ diff = (interpreter->SP \
+ - interpreter->stack); \
+ PUSH (diff); \
+ }
+
+#define CINDEX() \
+ { \
+ int32_t index; \
+ \
+ index = POP (); \
+ \
+ if (index <= 0 || index > STACKSIZE ()) \
+ TRAP ("stack overflow"); \
+ \
+ PUSH_UNCHECKED (*(interpreter->SP \
+ - index)); \
+ }
+
+#define MINDEX() \
+ { \
+ int32_t index, what; \
+ \
+ index = POP (); \
+ \
+ if (index <= 0 || index > STACKSIZE ()) \
+ TRAP ("stack overflow"); \
+ \
+ what = *(interpreter->SP - index); \
+ MOVE (interpreter->SP - index, \
+ interpreter->SP - index + 1, \
+ index - 1); \
+ *(interpreter->SP - 1) = what; \
+ }
+
+#define RAW() \
+ { \
+ if (why != SFNT_RUN_CONTEXT_GLYPH_PROGRAM) \
+ TRAP ("Read Advance Width without loaded" \
+ " glyph"); \
+ PUSH (interpreter->advance_width); \
+ }
+
+#define CALL() \
+ { \
+ uint32_t id, i; \
+ struct sfnt_interpreter_definition *def; \
+ \
+ id = POP (); \
+ \
+ for (i = 0; \
+ i < interpreter->function_defs_size; \
+ ++i) \
+ { \
+ def = &interpreter->function_defs[i]; \
+ \
+ if (!def->instructions) \
+ TRAP ("invalid function"); \
+ \
+ if (def->opcode == id) \
+ { \
+ sfnt_interpret_call (def, \
+ interpreter, \
+ why); \
+ goto next_instruction; \
+ } \
+ } \
+ \
+ TRAP ("invalid function"); \
+ }
+
+#define LOOPCALL() \
+ { \
+ uint32_t id; \
+ int32_t n; \
+ int i; \
+ struct sfnt_interpreter_definition *def; \
+ \
+ id = POP (); \
+ n = POP (); \
+ \
+ if (n > 65535) \
+ TRAP ("invalid LOOPCALL count"); \
+ \
+ for (i = 0; \
+ i < interpreter->function_defs_size; \
+ ++i) \
+ { \
+ def = &interpreter->function_defs[i]; \
+ \
+ if (!def->instructions) \
+ TRAP ("invalid function"); \
+ \
+ if (def->opcode == id) \
+ goto loopcall_begin; \
+ } \
+ \
+ TRAP ("invalid function"); \
+ \
+ loopcall_begin: \
+ if (n-- <= 0) \
+ break; \
+ \
+ sfnt_interpret_call (def, interpreter, \
+ why); \
+ goto loopcall_begin; \
+ }
+
+#define FDEF() \
+ { \
+ if (why == SFNT_RUN_CONTEXT_GLYPH_PROGRAM) \
+ TRAP ("FDEF inside glyph program"); \
+ \
+ sfnt_interpret_fdef (interpreter, POP ()); \
+ goto skip_step; \
+ }
+
+#define ENDF() \
+ { \
+ TRAP ("stray ENDF"); \
+ }
+
+#define NPUSHB() \
+ { \
+ int b, nbytes, IP; \
+ unsigned char *ip; \
+ \
+ if ((IP = interpreter->IP + 1) \
+ >= interpreter->num_instructions) \
+ TRAP ("Missing arg to NPUSHB"); \
+ \
+ nbytes \
+ = interpreter->instructions[IP]; \
+ \
+ if (IP + 1 + nbytes \
+ > interpreter->num_instructions) \
+ TRAP ("args to NPUSHB lie outside IS"); \
+ \
+ CHECK_STACK_AVAILABLE (nbytes); \
+ ip = interpreter->instructions; \
+ for (b = IP + 1; b < IP + 1 + nbytes; ++b) \
+ PUSH_UNCHECKED (ip[b]); \
+ \
+ interpreter->IP += nbytes + 1; \
+ }
+
+#define NPUSHW() \
+ { \
+ int b, nbytes, IP; \
+ unsigned char *ip; \
+ \
+ if ((IP = interpreter->IP + 1) \
+ >= interpreter->num_instructions) \
+ TRAP ("Missing arg to NPUSHW"); \
+ \
+ nbytes \
+ = interpreter->instructions[IP] * 2; \
+ \
+ if (IP + 1 + nbytes \
+ > interpreter->num_instructions) \
+ TRAP ("args to NPUSHW lie outside IS"); \
+ \
+ CHECK_STACK_AVAILABLE (nbytes / 2); \
+ ip = interpreter->instructions; \
+ for (b = IP + 1; b < IP + 1 + nbytes; \
+ b += 2) \
+ PUSH2_UNCHECKED (ip[b], ip[b + 1]); \
+ \
+ interpreter->IP += nbytes + 1; \
+ }
+
+#define WS() \
+ { \
+ uint32_t address, value; \
+ \
+ value = POP (); \
+ address = POP (); \
+ \
+ if (address >= interpreter->storage_size) \
+ TRAP ("invalid WS"); \
+ \
+ interpreter->storage[address] = value; \
+ }
+
+#define RS() \
+ { \
+ uint32_t address, value; \
+ \
+ address = POP (); \
+ \
+ if (address >= interpreter->storage_size) \
+ TRAP ("invalid RS"); \
+ \
+ value = interpreter->storage[address]; \
+ PUSH_UNCHECKED (value); \
+ }
+
+#define WCVTP() \
+ { \
+ sfnt_f26dot6 value; \
+ uint32_t location; \
+ \
+ value = POP (); \
+ location = POP (); \
+ \
+ if (location >= interpreter->cvt_size) \
+ TRAP ("WCVTP out of bounds"); \
+ \
+ interpreter->cvt[location] = value; \
+ }
+
+#define RCVT() \
+ { \
+ sfnt_f26dot6 value; \
+ uint32_t location; \
+ \
+ location = POP (); \
+ \
+ if (location >= interpreter->cvt_size) \
+ TRAP ("out of bounds RCVT"); \
+ \
+ value = interpreter->cvt[location]; \
+ PUSH_UNCHECKED (value); \
+ }
+
+#define MPPEM() \
+ { \
+ PUSH (interpreter->ppem); \
+ }
+
+#define MPS() \
+ { \
+ PUSH (interpreter->point_size); \
+ }
+
+#define FLIPON() \
+ { \
+ interpreter->state.auto_flip = true; \
+ }
+
+#define FLIPOFF() \
+ { \
+ interpreter->state.auto_flip = false; \
+ }
+
+#define DEBUG() \
+ { \
+ POP (); /* Value is ignored. */ \
+ }
+
+#define LT() \
+ { \
+ int32_t e1, e2; \
+ \
+ e2 = POP (); \
+ e1 = POP (); \
+ \
+ PUSH_UNCHECKED (e1 < e2 ? 1 : 0); \
+ }
+
+#define LTEQ() \
+ { \
+ int32_t e1, e2; \
+ \
+ e2 = POP (); \
+ e1 = POP (); \
+ \
+ PUSH_UNCHECKED (e1 <= e2 ? 1 : 0); \
+ }
+
+#define GT() \
+ { \
+ int32_t e1, e2; \
+ \
+ e2 = POP (); \
+ e1 = POP (); \
+ \
+ PUSH_UNCHECKED (e1 > e2 ? 1 : 0); \
+ }
+
+#define GTEQ() \
+ { \
+ int32_t e1, e2; \
+ \
+ e2 = POP (); \
+ e1 = POP (); \
+ \
+ PUSH_UNCHECKED (e1 >= e2 ? 1 : 0); \
+ }
+
+#define EQ() \
+ { \
+ uint32_t e1, e2; \
+ \
+ e1 = POP (); \
+ e2 = POP (); \
+ \
+ PUSH_UNCHECKED (e1 == e2 ? 1 : 0); \
+ }
+
+#define NEQ() \
+ { \
+ uint32_t e1, e2; \
+ \
+ e1 = POP (); \
+ e2 = POP (); \
+ \
+ PUSH_UNCHECKED (e1 != e2 ? 1 : 0); \
+ }
+
+#define ODD() \
+ { \
+ sfnt_f26dot6 e1, result; \
+ \
+ e1 = POP (); \
+ result = abs (e1); \
+ \
+ result \
+ = interpreter->state.round (result, \
+ interpreter); \
+ PUSH_UNCHECKED (((result & 127) \
+ == 64) ? 1 : 0); \
+ }
+
+#define EVEN() \
+ { \
+ sfnt_f26dot6 e1, result; \
+ uint32_t value; \
+ \
+ e1 = POP (); \
+ result = abs (e1); \
+ \
+ result \
+ = interpreter->state.round (result, \
+ interpreter); \
+ value = ((result & 127) == 64) ? 0 : 1; \
+ PUSH_UNCHECKED (value); \
+ }
+
+#define IF() \
+ { \
+ uint32_t condition; \
+ \
+ condition = POP (); \
+ sfnt_interpret_if (interpreter, condition); \
+ goto skip_step; \
+ }
+
+#define EIF() \
+ { \
+ \
+ }
+
+#define AND() \
+ { \
+ uint32_t e1, e2; \
+ \
+ e1 = POP (); \
+ e2 = POP (); \
+ \
+ PUSH_UNCHECKED (e1 && e2 ? 1 : 0); \
+ }
+
+#define OR() \
+ { \
+ uint32_t e1, e2; \
+ \
+ e1 = POP (); \
+ e2 = POP (); \
+ \
+ PUSH_UNCHECKED (e1 || e2 ? 1 : 0); \
+ }
+
+#define NOT() \
+ { \
+ uint32_t e1; \
+ \
+ e1 = POP (); \
+ \
+ PUSH_UNCHECKED (!e1 ? 1 : 0); \
+ }
+
+#define SDB() \
+ { \
+ uint32_t base; \
+ \
+ base = POP (); \
+ \
+ interpreter->state.delta_base = base; \
+ }
+
+#define SDS() \
+ { \
+ uint32_t shift; \
+ \
+ shift = POP (); \
+ \
+ if (shift > 6) \
+ TRAP ("invalid delta shift"); \
+ \
+ interpreter->state.delta_shift = shift; \
+ }
+
+#define ADD() \
+ { \
+ sfnt_f26dot6 n1, n2; \
+ \
+ n1 = POP (); \
+ n2 = POP (); \
+ \
+ PUSH_UNCHECKED (sfnt_add (n1, n2)); \
+ }
+
+#define SUB() \
+ { \
+ sfnt_f26dot6 n2, n1; \
+ \
+ n2 = POP (); \
+ n1 = POP (); \
+ \
+ PUSH_UNCHECKED (sfnt_sub (n1, n2)); \
+ }
+
+#define DIV() \
+ { \
+ sfnt_f26dot6 n2, n1; \
+ \
+ n2 = POP (); \
+ n1 = POP (); \
+ \
+ if (!n2) \
+ TRAP ("DIV by 0"); \
+ \
+ PUSH_UNCHECKED (sfnt_div_f26dot6 (n1, n2)); \
+ }
+
+#define MUL() \
+ { \
+ sfnt_f26dot6 n2, n1, r; \
+ \
+ n2 = POP (); \
+ n1 = POP (); \
+ \
+ r = sfnt_mul_f26dot6_round (n2, n1); \
+ PUSH_UNCHECKED (r); \
+ }
+
+#define ABS() \
+ { \
+ sfnt_f26dot6 n; \
+ \
+ n = POP (); \
+ \
+ if (n == INT32_MIN) \
+ PUSH_UNCHECKED (0) \
+ else \
+ PUSH_UNCHECKED (n < 0 ? -n : n) \
+ }
+
+#define NEG() \
+ { \
+ sfnt_f26dot6 n; \
+ \
+ n = POP (); \
+ \
+ if (n == INT32_MIN) \
+ PUSH_UNCHECKED (0) \
+ else \
+ PUSH_UNCHECKED (-n) \
+ }
+
+#define FLOOR() \
+ { \
+ sfnt_f26dot6 n; \
+ \
+ n = POP (); \
+ PUSH_UNCHECKED (sfnt_floor_f26dot6 (n)); \
+ }
+
+#define CEILING() \
+ { \
+ sfnt_f26dot6 n; \
+ \
+ n = POP (); \
+ PUSH_UNCHECKED (sfnt_ceil_f26dot6 (n)); \
+ }
+
+#define WCVTF() \
+ { \
+ int32_t value; \
+ uint32_t location; \
+ \
+ value = POP (); \
+ location = POP (); \
+ \
+ if (location >= interpreter->cvt_size) \
+ TRAP ("WCVTF out of bounds"); \
+ \
+ interpreter->cvt[location] \
+ = sfnt_mul_fixed (value, \
+ interpreter->scale); \
+ }
+
+#define JROT() \
+ { \
+ uint32_t e; \
+ int32_t offset; \
+ \
+ e = POP (); \
+ offset = POP (); \
+ \
+ if (!e) \
+ break; \
+ \
+ if (interpreter->IP + offset < 0 \
+ || (interpreter->IP + offset \
+ > interpreter->num_instructions)) \
+ TRAP ("JMPR out of bounds"); \
+ \
+ interpreter->IP += offset; \
+ goto skip_step; \
+ }
+
+#define JROF() \
+ { \
+ uint32_t e; \
+ int32_t offset; \
+ \
+ e = POP (); \
+ offset = POP (); \
+ \
+ if (e) \
+ break; \
+ \
+ if (interpreter->IP + offset < 0 \
+ || (interpreter->IP + offset \
+ > interpreter->num_instructions)) \
+ TRAP ("JMPR out of bounds"); \
+ \
+ interpreter->IP += offset; \
+ goto skip_step; \
+ }
+
+#define ILLEGAL_INSTRUCTION() \
+ { \
+ TRAP ("MS reserved illegal instruction"); \
+ }
+
+#define SCANCTRL() \
+ { \
+ uint32_t value; \
+ \
+ value = POP (); \
+ interpreter->state.scan_control = value; \
+ }
+
+/* Selector bit 3 is undocumented, but present in the Macintosh
+ rasterizer. 02000 is returned if there is a variation axis in
+ use.
+
+ Selector bit 5 is undocumented, but relied on by several fonts.
+ 010000 is returned if a grayscale rasterizer is in use. */
+
+#define GETINFO() \
+ { \
+ uint32_t selector, k; \
+ \
+ selector = POP (); \
+ \
+ k = 0; \
+ \
+ if (selector & 1) \
+ k |= 02; \
+ \
+ if (selector & 8 \
+ && interpreter->norm_coords) \
+ k |= 02000; \
+ \
+ if (selector & 32) \
+ k |= 010000; \
+ \
+ PUSH_UNCHECKED (k); \
+ }
+
+#define IDEF() \
+ { \
+ if (why == SFNT_RUN_CONTEXT_GLYPH_PROGRAM) \
+ TRAP ("IDEF inside glyph program"); \
+ \
+ sfnt_interpret_idef (interpreter, POP ()); \
+ goto skip_step; \
+ }
+
+#define ROLL() \
+ { \
+ uint32_t a, b, c; \
+ \
+ CHECK_STACK_ELEMENTS (3); \
+ \
+ a = POP_UNCHECKED (); \
+ b = POP_UNCHECKED (); \
+ c = POP_UNCHECKED (); \
+ \
+ PUSH_UNCHECKED (b); \
+ PUSH_UNCHECKED (a); \
+ PUSH_UNCHECKED (c); \
+ }
+
+#define _MAX() \
+ { \
+ int32_t e1, e2; \
+ \
+ e1 = POP (); \
+ e2 = POP (); \
+ \
+ PUSH_UNCHECKED (MAX (e1, e2)); \
+ }
+
+#define _MIN() \
+ { \
+ int32_t e1, e2; \
+ \
+ e1 = POP (); \
+ e2 = POP (); \
+ \
+ PUSH_UNCHECKED (MIN (e1, e2)); \
+ }
+
+#define SCANTYPE() \
+ { \
+ POP (); \
+ }
+
+#define INSTCTRL() \
+ { \
+ uint32_t s, v; \
+ \
+ CHECK_PREP (); \
+ s = POP (); \
+ v = POP (); \
+ \
+ if (!s || s > 2) \
+ break; \
+ \
+ interpreter->state.instruct_control \
+ &= ~(1 << s); \
+ \
+ if (v) \
+ interpreter->state.instruct_control \
+ |= (1 << s); \
+ }
+
+/* GXAXIS is undocumented. It seems to return each axis in shortFrac
+ format. */
+
+#define GXAXIS() \
+ { \
+ uint32_t v; \
+ int i, naxis; \
+ \
+ naxis = interpreter->n_axis; \
+ CHECK_STACK_AVAILABLE (naxis); \
+ \
+ for (i = 0; i < naxis; ++i) \
+ { \
+ if (interpreter->norm_coords) \
+ v = interpreter->norm_coords[i] / 4; \
+ else \
+ v = 0; \
+ \
+ PUSH_UNCHECKED (v); \
+ } \
+ }
+
+#define PUSHB() \
+ { \
+ int b, nbytes, IP; \
+ unsigned char *ip; \
+ \
+ IP = interpreter->IP; \
+ nbytes = opcode - 0xb0 + 1; \
+ \
+ if (IP + nbytes + 1 \
+ > interpreter->num_instructions) \
+ TRAP ("args to PUSHB lie outside IS"); \
+ \
+ CHECK_STACK_AVAILABLE (nbytes); \
+ ip = interpreter->instructions; \
+ for (b = IP + 1; b < IP + nbytes + 1; ++b) \
+ PUSH_UNCHECKED (ip[b]); \
+ \
+ interpreter->IP += nbytes; \
+ }
+
+#define PUSHW() \
+ { \
+ int b, nbytes, IP; \
+ unsigned char *ip; \
+ \
+ IP = interpreter->IP; \
+ nbytes = (opcode - 0xb8 + 1) * 2; \
+ \
+ if (IP + 1 + nbytes \
+ > interpreter->num_instructions) \
+ TRAP ("args to PUSHW lie outside IS"); \
+ \
+ CHECK_STACK_AVAILABLE (nbytes / 2); \
+ ip = interpreter->instructions; \
+ for (b = IP + 1; b < IP + nbytes + 1; \
+ b += 2) \
+ PUSH2_UNCHECKED (ip[b], ip[b + 1]); \
+ \
+ interpreter->IP += nbytes; \
+ }
+
+
+
+/* Rounding instructions. */
+
+#define ROUND() \
+ { \
+ sfnt_f26dot6 n, result; \
+ \
+ n = POP (); \
+ result = abs (n); \
+ \
+ result \
+ = interpreter->state.round (result, \
+ interpreter); \
+ PUSH_UNCHECKED (n < 0 ? -result : result); \
+ }
+
+#define NROUND() \
+ { \
+ sfnt_f26dot6 n; \
+ \
+ n = POP (); \
+ PUSH_UNCHECKED (n); \
+ }
+
+#define ROFF() \
+ { \
+ interpreter->state.round_state = 5; \
+ sfnt_validate_gs (&interpreter->state); \
+ }
+
+#define RUTG() \
+ { \
+ interpreter->state.round_state = 4; \
+ sfnt_validate_gs (&interpreter->state); \
+ }
+
+#define RDTG() \
+ { \
+ interpreter->state.round_state = 3; \
+ sfnt_validate_gs (&interpreter->state); \
+ }
+
+#define RTG() \
+ { \
+ interpreter->state.round_state = 1; \
+ sfnt_validate_gs (&interpreter->state); \
+ }
+
+#define RTHG() \
+ { \
+ interpreter->state.round_state = 0; \
+ sfnt_validate_gs (&interpreter->state); \
+ }
+
+#define RTDG() \
+ { \
+ interpreter->state.round_state = 2; \
+ sfnt_validate_gs (&interpreter->state); \
+ }
+
+#define SROUND() \
+ { \
+ uint32_t operand; \
+ \
+ operand = POP (); \
+ sfnt_set_srounding_state (interpreter, \
+ operand, \
+ 0x4000); \
+ interpreter->state.round_state = 6; \
+ sfnt_validate_gs (&interpreter->state); \
+ }
+
+#define S45ROUND() \
+ { \
+ uint32_t operand; \
+ \
+ operand = POP (); \
+ sfnt_set_srounding_state (interpreter, \
+ operand, \
+ 0x5a82); \
+ interpreter->state.round_state = 7; \
+ sfnt_validate_gs (&interpreter->state); \
+ }
+
+
+
+/* CVT and point delta exception instructions.
+
+ ``Exceptions'' can be placed directly inside the control value
+ table, as it is reloaded every time the point size changes. */
+
+#define DELTAC1() \
+ { \
+ uint32_t operand1, operand2, n; \
+ \
+ n = POP (); \
+ \
+ deltac1_start: \
+ if (!n) \
+ break; \
+ \
+ operand1 = POP (); \
+ operand2 = POP (); \
+ sfnt_deltac (1, interpreter, operand1, \
+ operand2); \
+ n--; \
+ goto deltac1_start; \
+ }
+
+#define DELTAC2() \
+ { \
+ uint32_t operand1, operand2, n; \
+ \
+ n = POP (); \
+ \
+ deltac2_start: \
+ if (!n) \
+ break; \
+ \
+ operand1 = POP (); \
+ operand2 = POP (); \
+ sfnt_deltac (2, interpreter, operand1, \
+ operand2); \
+ n--; \
+ goto deltac2_start; \
+ }
+
+#define DELTAC3() \
+ { \
+ uint32_t operand1, operand2, n; \
+ \
+ n = POP (); \
+ \
+ deltac3_start: \
+ if (!n) \
+ break; \
+ \
+ operand1 = POP (); \
+ operand2 = POP (); \
+ sfnt_deltac (3, interpreter, operand1, \
+ operand2); \
+ n--; \
+ goto deltac3_start; \
+ }
+
+#define DELTAP1() \
+ { \
+ uint32_t n, argn, pn; \
+ \
+ n = POP (); \
+ \
+ deltap1_start: \
+ if (!n) \
+ break; \
+ \
+ pn = POP (); \
+ argn = POP (); \
+ sfnt_deltap (1, interpreter, argn, pn); \
+ n--; \
+ goto deltap1_start; \
+ }
+
+#define DELTAP2() \
+ { \
+ uint32_t n, argn, pn; \
+ \
+ n = POP (); \
+ \
+ deltap2_start: \
+ if (!n) \
+ break; \
+ \
+ pn = POP (); \
+ argn = POP (); \
+ sfnt_deltap (2, interpreter, argn, pn); \
+ n--; \
+ goto deltap2_start; \
+ }
+
+#define DELTAP3() \
+ { \
+ uint32_t n, argn, pn; \
+ \
+ n = POP (); \
+ \
+ deltap3_start: \
+ if (!n) \
+ break; \
+ \
+ pn = POP (); \
+ argn = POP (); \
+ sfnt_deltap (3, interpreter, argn, pn); \
+ n--; \
+ goto deltap3_start; \
+ }
+
+
+
+/* Anachronistic angle instructions. */
+
+#define AA() \
+ { \
+ POP (); \
+ }
+
+#define SANGW() \
+ { \
+ POP (); \
+ }
+
+
+
+/* Projection and freedom vector operations. */
+
+#define PROJECT(x, y) \
+ sfnt_project_vector (interpreter, x, y)
+
+#define DUAL_PROJECT(x, y) \
+ sfnt_dual_project_vector (interpreter, x, y)
+
+#define SVTCAy() \
+ { \
+ sfnt_set_freedom_vector (interpreter, \
+ 0, 040000); \
+ sfnt_set_projection_vector (interpreter, \
+ 0, 040000); \
+ }
+
+#define SVTCAx() \
+ { \
+ sfnt_set_freedom_vector (interpreter, \
+ 040000, 0); \
+ sfnt_set_projection_vector (interpreter, \
+ 040000, 0); \
+ }
+
+#define SPvTCAy() \
+ { \
+ sfnt_set_projection_vector (interpreter, \
+ 0, 040000); \
+ }
+
+#define SPvTCAx() \
+ { \
+ sfnt_set_projection_vector (interpreter, \
+ 040000, 0); \
+ }
+
+#define SFvTCAy() \
+ { \
+ sfnt_set_freedom_vector (interpreter, \
+ 0, 040000); \
+ }
+
+#define SFvTCAx() \
+ { \
+ sfnt_set_freedom_vector (interpreter, \
+ 040000, 0); \
+ }
+
+#define SPVTL() \
+ { \
+ struct sfnt_unit_vector vector; \
+ uint32_t p2, p1; \
+ \
+ p2 = POP (); \
+ p1 = POP (); \
+ \
+ sfnt_line_to_vector (interpreter, \
+ p2, p1, &vector, \
+ opcode == 0x07, \
+ false); \
+ \
+ sfnt_save_projection_vector (interpreter, \
+ &vector, \
+ false); \
+ }
+
+#define SFVTL() \
+ { \
+ struct sfnt_unit_vector vector; \
+ uint32_t p2, p1; \
+ \
+ p2 = POP (); \
+ p1 = POP (); \
+ \
+ sfnt_line_to_vector (interpreter, \
+ p2, p1, &vector, \
+ opcode == 0x09, \
+ false); \
+ \
+ sfnt_save_freedom_vector (interpreter, \
+ &vector); \
+ }
+
+#define SPVFS() \
+ { \
+ uint32_t y, x; \
+ \
+ y = POP (); \
+ x = POP (); \
+ \
+ sfnt_set_projection_vector (interpreter, x, \
+ y); \
+ }
+
+#define SFVFS() \
+ { \
+ uint16_t y, x; \
+ \
+ y = POP (); \
+ x = POP (); \
+ \
+ sfnt_set_freedom_vector (interpreter, x, \
+ y); \
+ }
+
+#define GPV() \
+ { \
+ struct sfnt_unit_vector vector; \
+ \
+ vector \
+ = interpreter->state.projection_vector; \
+ \
+ PUSH ((int32_t) vector.x); \
+ PUSH ((int32_t) vector.y); \
+ }
+
+#define GFV() \
+ { \
+ struct sfnt_unit_vector vector; \
+ \
+ vector \
+ = interpreter->state.freedom_vector; \
+ \
+ PUSH ((int32_t) vector.x); \
+ PUSH ((int32_t) vector.y); \
+ }
+
+#define SFVTPV() \
+ { \
+ interpreter->state.freedom_vector \
+ = interpreter->state.projection_vector; \
+ \
+ sfnt_validate_gs (&interpreter->state); \
+ }
+
+#define ISECT() \
+ { \
+ uint32_t a0, a1, b0, b1, p; \
+ \
+ CHECK_STACK_ELEMENTS (5); \
+ \
+ a0 = POP_UNCHECKED (); \
+ a1 = POP_UNCHECKED (); \
+ b0 = POP_UNCHECKED (); \
+ b1 = POP_UNCHECKED (); \
+ p = POP_UNCHECKED (); \
+ \
+ sfnt_interpret_isect (interpreter, \
+ a0, a1, b0, b1, p); \
+ }
+
+#define ALIGNPTS() \
+ { \
+ uint32_t p1, p2; \
+ \
+ p1 = POP (); \
+ p2 = POP (); \
+ \
+ sfnt_interpret_alignpts (interpreter, p1, \
+ p2); \
+ }
+
+#define UTP() \
+ { \
+ uint32_t p; \
+ \
+ p = POP (); \
+ sfnt_interpret_utp (interpreter, p); \
+ }
+
+#define MDAP() \
+ { \
+ uint32_t p; \
+ \
+ p = POP (); \
+ sfnt_interpret_mdap (interpreter, p, \
+ opcode); \
+ }
+
+#define IUP() \
+ { \
+ sfnt_interpret_iup (interpreter, opcode); \
+ }
+
+#define SHP() \
+ { \
+ sfnt_interpret_shp (interpreter, opcode); \
+ }
+
+#define SHC() \
+ { \
+ uint32_t contour; \
+ \
+ contour = POP (); \
+ \
+ sfnt_interpret_shc (interpreter, contour, \
+ opcode); \
+ }
+
+#define SHZ() \
+ { \
+ uint32_t e; \
+ \
+ e = POP (); \
+ \
+ if (e > 1) \
+ TRAP ("invalid zone!"); \
+ \
+ sfnt_interpret_shz (interpreter, e, \
+ opcode); \
+ }
+
+#define SHPIX() \
+ { \
+ sfnt_f26dot6 pixels, dx, dy; \
+ uint32_t p; \
+ \
+ pixels = POP (); \
+ sfnt_scale_by_freedom_vector (interpreter, \
+ pixels, &dx, \
+ &dy); \
+ \
+ while (interpreter->state.loop--) \
+ { \
+ p = POP (); \
+ sfnt_direct_move_zp2 (interpreter, \
+ p, dx, dy); \
+ } \
+ \
+ interpreter->state.loop = 1; \
+ }
+
+#define IP() \
+ { \
+ sfnt_interpret_ip (interpreter); \
+ }
+
+#define MSIRP() \
+ { \
+ sfnt_f26dot6 d; \
+ uint32_t p; \
+ \
+ d = POP (); \
+ p = POP (); \
+ \
+ sfnt_interpret_msirp (interpreter, d, p, \
+ opcode); \
+ }
+
+#define ALIGNRP() \
+ { \
+ sfnt_interpret_alignrp (interpreter); \
+ }
+
+#define MIAP() \
+ { \
+ uint32_t cvt; \
+ uint32_t p; \
+ \
+ cvt = POP (); \
+ p = POP (); \
+ \
+ sfnt_interpret_miap (interpreter, cvt, p, \
+ opcode); \
+ }
+
+#define GC() \
+ { \
+ uint32_t p; \
+ sfnt_f26dot6 x, y, value; \
+ sfnt_f26dot6 org_x, org_y; \
+ \
+ p = POP (); \
+ \
+ sfnt_address_zp2 (interpreter, p, &x, &y, \
+ &org_x, &org_y); \
+ \
+ if (opcode == 0x47) \
+ value = DUAL_PROJECT (org_x, org_y); \
+ else \
+ value = PROJECT (x, y); \
+ \
+ PUSH_UNCHECKED (value); \
+ }
+
+#define SCFS() \
+ { \
+ uint32_t p; \
+ sfnt_f26dot6 c; \
+ \
+ c = POP (); \
+ p = POP (); \
+ \
+ sfnt_interpret_scfs (interpreter, p, c); \
+ }
+
+#define MD() \
+ { \
+ uint32_t p1, p2; \
+ sfnt_f26dot6 distance; \
+ \
+ p2 = POP (); \
+ p1 = POP (); \
+ \
+ distance \
+ = sfnt_measure_distance (interpreter, \
+ p1, p2, \
+ opcode); \
+ PUSH_UNCHECKED (distance); \
+ }
+
+#define FLIPPT() \
+ { \
+ sfnt_interpret_flippt (interpreter); \
+ }
+
+#define FLIPRGOFF() \
+ { \
+ uint32_t h, l; \
+ \
+ h = POP (); \
+ l = POP (); \
+ \
+ sfnt_interpret_fliprgoff (interpreter, \
+ h, l); \
+ }
+
+#define FLIPRGON() \
+ { \
+ uint32_t h, l; \
+ \
+ h = POP (); \
+ l = POP (); \
+ \
+ sfnt_interpret_fliprgon (interpreter, \
+ h, l); \
+ }
+
+#define SDPVTL() \
+ { \
+ struct sfnt_unit_vector vector; \
+ uint32_t p2, p1; \
+ \
+ p2 = POP (); \
+ p1 = POP (); \
+ \
+ sfnt_line_to_vector (interpreter, \
+ p2, p1, &vector, \
+ opcode == 0x87, \
+ false); \
+ \
+ sfnt_save_projection_vector (interpreter, \
+ &vector, \
+ false); \
+ \
+ sfnt_line_to_vector (interpreter, \
+ p2, p1, &vector, \
+ opcode == 0x87, \
+ true); \
+ \
+ sfnt_save_projection_vector (interpreter, \
+ &vector, \
+ true); \
+ }
+
+#define MIRP() \
+ { \
+ sfnt_interpret_mirp (interpreter, opcode); \
+ }
+
+#define MDRP() \
+ { \
+ sfnt_interpret_mdrp (interpreter, opcode); \
+ }
+
+
+
+#define NOT_IMPLEMENTED() \
+ sfnt_interpret_unimplemented (interpreter, \
+ opcode, why)
+
+
+
+/* Multiply the specified MAGNITUDE by the contents of INTERPRETER's
+ freedom vector and return the result in *DX and *DY. */
+
+static void
+sfnt_scale_by_freedom_vector (struct sfnt_interpreter *interpreter,
+ sfnt_f26dot6 magnitude, sfnt_f26dot6 *dx,
+ sfnt_f26dot6 *dy)
+{
+ struct sfnt_unit_vector *vector;
+
+ vector = &interpreter->state.freedom_vector;
+ *dx = sfnt_mul_f2dot14 (vector->x, magnitude);
+ *dy = sfnt_mul_f2dot14 (vector->y, magnitude);
+}
+
+/* Interpret a UTP instruction with the point P in INTERPRETER.
+ Unset any ``touched'' flag inside the point P, relative to the
+ zone in INTERPRETER's ZP0 register.
+
+ Trap upon encountering an out of bounds point. */
+
+static void
+sfnt_interpret_utp (struct sfnt_interpreter *interpreter,
+ uint32_t p)
+{
+ unsigned char mask;
+
+ if (!interpreter->state.zp0)
+ {
+ if (p >= interpreter->twilight_zone_size)
+ TRAP ("UTP[] p lies outside twilight zone");
+
+ /* There are no flags in the twilight zone. */
+ return;
+ }
+
+ if (!interpreter->glyph_zone
+ || p >= interpreter->glyph_zone->num_points)
+ TRAP ("UTP[] p lies outside glyph zone");
+
+ /* The flags unset by UTP are subject to which axes in the freedom
+ vector are significant, as stated in the TrueType reference
+ manual by this needless mouthful:
+
+ A point may be touched in the x-direction, the y-direction, or
+ in both the x and y-directions. The position of the freedom
+ vector determines whether the point is untouched in the
+ x-direction, the y-direction, or both. If the vector is set to
+ the x-axis, the point will be untouched in the x-direction. If
+ the vector is set to the y-axis, the point will be untouched in
+ the y-direction. Otherwise the point will be untouched in both
+ directions.
+
+ A points that is marked as untouched will be moved by an IUP[]
+ instruction even if the point was previously touched. */
+
+ mask = 0xff;
+
+ if (interpreter->state.freedom_vector.x)
+ mask &= ~SFNT_POINT_TOUCHED_X;
+
+ if (interpreter->state.freedom_vector.y)
+ mask &= ~SFNT_POINT_TOUCHED_Y;
+
+ interpreter->glyph_zone->flags[p] &= mask;
+}
+
+/* Save the specified unit VECTOR into INTERPRETER's graphics state as
+ both the projection and the dual projection vectors.
+
+ If not DUAL_ONLY, set VECTOR as both the projection and dual
+ projection vectors. Otherwise, only set VECTOR as the dual
+ projection vector. */
+
+static void
+sfnt_save_projection_vector (struct sfnt_interpreter *interpreter,
+ struct sfnt_unit_vector *vector,
+ bool dual_only)
+{
+ if (!dual_only)
+ interpreter->state.projection_vector = *vector;
+
+ interpreter->state.dual_projection_vector = *vector;
+
+ sfnt_validate_gs (&interpreter->state);
+}
+
+/* Save the specified unit VECTOR into INTERPRETER's graphics
+ state. */
+
+static void
+sfnt_save_freedom_vector (struct sfnt_interpreter *interpreter,
+ struct sfnt_unit_vector *vector)
+{
+ interpreter->state.freedom_vector = *vector;
+
+ sfnt_validate_gs (&interpreter->state);
+}
+
+/* Return the values of the point NUMBER in the zone pointed to by
+ INTERPRETER's ZP2 register.
+
+ If X_ORG and Y_ORG are set, return the original values (prior to
+ any instruction interpretations) in those two locations.
+
+ Trap if NUMBER is out of bounds or the zone is inaccessible. */
+
+static void
+sfnt_address_zp2 (struct sfnt_interpreter *interpreter,
+ uint32_t number,
+ sfnt_f26dot6 *x, sfnt_f26dot6 *y,
+ sfnt_f26dot6 *x_org, sfnt_f26dot6 *y_org)
+{
+ if (!interpreter->state.zp2)
+ {
+ /* Address the twilight zone. */
+ if (number >= interpreter->twilight_zone_size)
+ TRAP ("address to ZP2 (twilight zone) out of bounds");
+
+ if (!x || !y)
+ goto next;
+
+ *x = interpreter->twilight_x[number];
+ *y = interpreter->twilight_y[number];
+ next:
+
+ if (!x_org || !y_org)
+ return;
+
+ /* The twilight zone is initially all zero, but initial
+ positions can still be changed. */
+ *x_org = interpreter->twilight_original_x[number];
+ *y_org = interpreter->twilight_original_y[number];
+ return;
+ }
+
+ /* Address the glyph zone. */
+ if (!interpreter->glyph_zone)
+ TRAP ("address to ZP2 (glyph zone) points into unset"
+ " zone");
+
+ if (number >= interpreter->glyph_zone->num_points)
+ TRAP ("address to ZP2 (glyph zone) out of bounds");
+
+ if (x && y)
+ {
+ *x = interpreter->glyph_zone->x_current[number];
+ *y = interpreter->glyph_zone->y_current[number];
+ }
+
+ if (x_org && y_org)
+ {
+ *x_org = interpreter->glyph_zone->x_points[number];
+ *y_org = interpreter->glyph_zone->y_points[number];
+ }
+}
+
+/* Return the values of the point NUMBER in the zone pointed to by
+ INTERPRETER's ZP1 register.
+
+ Trap if NUMBER is out of bounds or the zone is inaccessible. */
+
+static void
+sfnt_address_zp1 (struct sfnt_interpreter *interpreter,
+ uint32_t number,
+ sfnt_f26dot6 *x, sfnt_f26dot6 *y,
+ sfnt_f26dot6 *x_org, sfnt_f26dot6 *y_org)
+{
+ if (!interpreter->state.zp1)
+ {
+ /* Address the twilight zone. */
+ if (number >= interpreter->twilight_zone_size)
+ TRAP ("address to ZP1 (twilight zone) out of bounds");
+
+ if (!x || !y)
+ goto next;
+
+ *x = interpreter->twilight_x[number];
+ *y = interpreter->twilight_y[number];
+ next:
+
+ if (!x_org || !y_org)
+ return;
+
+ /* The twilight zone is initially all zero, but initial
+ positions can still be changed. */
+ *x_org = interpreter->twilight_original_x[number];
+ *y_org = interpreter->twilight_original_y[number];
+ return;
+ }
+
+ /* Address the glyph zone. */
+ if (!interpreter->glyph_zone)
+ TRAP ("address to ZP1 (glyph zone) points into unset"
+ " zone");
+
+ if (number >= interpreter->glyph_zone->num_points)
+ TRAP ("address to ZP1 (glyph zone) out of bounds");
+
+ if (x && y)
+ {
+ *x = interpreter->glyph_zone->x_current[number];
+ *y = interpreter->glyph_zone->y_current[number];
+ }
+
+ if (x_org && y_org)
+ {
+ *x_org = interpreter->glyph_zone->x_points[number];
+ *y_org = interpreter->glyph_zone->y_points[number];
+ }
+}
+
+/* Return the values of the point NUMBER in the zone pointed to by
+ INTERPRETER's ZP0 register.
+
+ Trap if NUMBER is out of bounds or the zone is inaccessible. */
+
+static void
+sfnt_address_zp0 (struct sfnt_interpreter *interpreter,
+ uint32_t number,
+ sfnt_f26dot6 *x, sfnt_f26dot6 *y,
+ sfnt_f26dot6 *x_org, sfnt_f26dot6 *y_org)
+{
+ if (!interpreter->state.zp0)
+ {
+ /* Address the twilight zone. */
+ if (number >= interpreter->twilight_zone_size)
+ TRAP ("address to ZP0 (twilight zone) out of bounds");
+
+ if (!x || !y)
+ goto next;
+
+ *x = interpreter->twilight_x[number];
+ *y = interpreter->twilight_y[number];
+ next:
+
+ if (!x_org || !y_org)
+ return;
+
+ /* The twilight zone is initially all zero, but initial
+ positions can still be changed. */
+ *x_org = interpreter->twilight_original_x[number];
+ *y_org = interpreter->twilight_original_y[number];
+ return;
+ }
+
+ /* Address the glyph zone. */
+ if (!interpreter->glyph_zone)
+ TRAP ("address to ZP0 (glyph zone) points into unset"
+ " zone");
+
+ if (number >= interpreter->glyph_zone->num_points)
+ TRAP ("address to ZP0 (glyph zone) out of bounds");
+
+ if (x && y)
+ {
+ *x = interpreter->glyph_zone->x_current[number];
+ *y = interpreter->glyph_zone->y_current[number];
+ }
+
+ if (x_org && y_org)
+ {
+ *x_org = interpreter->glyph_zone->x_points[number];
+ *y_org = interpreter->glyph_zone->y_points[number];
+ }
+}
+
+/* Set the point NUMBER in the zone referenced by INTERPRETER's ZP2
+ register to the specified X and Y.
+
+ Apply FLAGS to NUMBER's flags in that zone. Trap if NUMBER is out
+ of bounds. */
+
+static void
+sfnt_store_zp2 (struct sfnt_interpreter *interpreter,
+ uint32_t number, sfnt_f26dot6 x, sfnt_f26dot6 y,
+ int flags)
+{
+ if (!interpreter->state.zp2)
+ {
+ /* Address the twilight zone. */
+ if (number >= interpreter->twilight_zone_size)
+ TRAP ("address to ZP2 (twilight zone) out of bounds");
+
+ interpreter->twilight_x[number] = x;
+ interpreter->twilight_y[number] = y;
+ return;
+ }
+
+ /* Address the glyph zone. */
+ if (!interpreter->glyph_zone)
+ TRAP ("address to ZP0 (glyph zone) points into unset"
+ " zone");
+
+ if (number >= interpreter->glyph_zone->num_points)
+ TRAP ("address to ZP0 (glyph zone) out of bounds");
+
+ interpreter->glyph_zone->x_current[number] = x;
+ interpreter->glyph_zone->y_current[number] = y;
+ interpreter->glyph_zone->flags[number] |= flags;
+}
+
+#if 0
+
+/* Convert the line between the points X1, Y1 and X2, Y2 to standard
+ form.
+
+ Return the two coefficients in *A0 and *B0, and the constant in
+ *C. */
+
+static void
+sfnt_line_to_standard_form (sfnt_f26dot6 x1, sfnt_f26dot6 y1,
+ sfnt_f26dot6 x2, sfnt_f26dot6 y2,
+ sfnt_f26dot6 *a, sfnt_f26dot6 *b,
+ sfnt_f26dot6 *c)
+{
+ sfnt_f26dot6 a_temp, b_temp, c_temp;
+
+ a_temp = sfnt_sub (y2, y1);
+ b_temp = sfnt_sub (x1, x2);
+ c_temp = sfnt_sub (sfnt_mul_f26dot6 (x1, y2),
+ sfnt_mul_f26dot6 (x2, y1));
+
+ *a = a_temp;
+ *b = b_temp;
+ *c = c_temp;
+}
+
+#endif
+
+/* Check that the specified POINT lies within the zone addressed by
+ INTERPRETER's ZP2 register. Trap if it does not. */
+
+static void
+sfnt_check_zp2 (struct sfnt_interpreter *interpreter, uint32_t point)
+{
+ if (!interpreter->state.zp2)
+ {
+ if (point >= interpreter->twilight_zone_size)
+ TRAP ("point lies outside twilight zone (ZP2)");
+ }
+ else if (!interpreter->glyph_zone
+ || point >= interpreter->glyph_zone->num_points)
+ TRAP ("point lies outside glyph zone (ZP2)");
+}
+
+/* Check that the specified POINT lies within the zone addressed by
+ INTERPRETER's ZP0 register. Trap if it does not. */
+
+static void
+sfnt_check_zp0 (struct sfnt_interpreter *interpreter, uint32_t point)
+{
+ if (!interpreter->state.zp0)
+ {
+ if (point >= interpreter->twilight_zone_size)
+ TRAP ("point lies outside twilight zone (ZP0)");
+ }
+ else if (!interpreter->glyph_zone
+ || point >= interpreter->glyph_zone->num_points)
+ TRAP ("point lies outside glyph zone (ZP0)");
+}
+
+/* Check that the specified POINT lies within the zone addressed by
+ INTERPRETER's ZP1 register. Trap if it does not. */
+
+static void
+sfnt_check_zp1 (struct sfnt_interpreter *interpreter, uint32_t point)
+{
+ if (!interpreter->state.zp1)
+ {
+ if (point >= interpreter->twilight_zone_size)
+ TRAP ("point lies outside twilight zone (ZP0)");
+ }
+ else if (!interpreter->glyph_zone
+ || point >= interpreter->glyph_zone->num_points)
+ TRAP ("point lies outside glyph zone (ZP0)");
+}
+
+/* Move N points starting from the specified POINT in the zone
+ addressed by INTERPRETER's ZP0 register by the given DISTANCE along
+ the freedom vector.
+
+ No checking is done to ensure that POINT lies inside the zone, or
+ even that the zone exists at all. */
+
+static void
+sfnt_move_zp0 (struct sfnt_interpreter *interpreter, uint32_t point,
+ size_t n, sfnt_f26dot6 distance)
+{
+ if (!interpreter->state.zp0)
+ interpreter->state.move (&interpreter->twilight_x[point],
+ &interpreter->twilight_y[point],
+ n, interpreter, distance, NULL);
+ else
+ interpreter->state.move (&interpreter->glyph_zone->x_current[point],
+ &interpreter->glyph_zone->y_current[point],
+ n, interpreter, distance,
+ &interpreter->glyph_zone->flags[point]);
+}
+
+/* Move N points starting from the specified POINT in the zone
+ addressed by INTERPRETER's ZP1 register by the given DISTANCE along
+ the freedom vector.
+
+ No checking is done to ensure that POINT lies inside the zone, or
+ even that the zone exists at all. */
+
+static void
+sfnt_move_zp1 (struct sfnt_interpreter *interpreter, uint32_t point,
+ size_t n, sfnt_f26dot6 distance)
+{
+ if (!interpreter->state.zp1)
+ interpreter->state.move (&interpreter->twilight_x[point],
+ &interpreter->twilight_y[point],
+ n, interpreter, distance, NULL);
+ else
+ interpreter->state.move (&interpreter->glyph_zone->x_current[point],
+ &interpreter->glyph_zone->y_current[point],
+ n, interpreter, distance,
+ &interpreter->glyph_zone->flags[point]);
+}
+
+/* Move N points starting from the specified POINT in the zone
+ addressed by INTERPRETER's ZP2 register by the given DISTANCE along
+ the freedom vector.
+
+ No checking is done to ensure that POINT lies inside the zone, or
+ even that the zone exists at all. */
+
+static void
+sfnt_move_zp2 (struct sfnt_interpreter *interpreter, uint32_t point,
+ size_t n, sfnt_f26dot6 distance)
+{
+ if (!interpreter->state.zp2)
+ interpreter->state.move (&interpreter->twilight_x[point],
+ &interpreter->twilight_y[point],
+ n, interpreter, distance, NULL);
+ else
+ interpreter->state.move (&interpreter->glyph_zone->x_current[point],
+ &interpreter->glyph_zone->y_current[point],
+ n, interpreter, distance,
+ &interpreter->glyph_zone->flags[point]);
+}
+
+/* Move N points from the specified POINT in INTERPRETER's glyph zone
+ by the given DISTANCE along the freedom vector.
+
+ Do not touch the points that are moved.
+
+ No checking is done to ensure that POINT lies inside the zone, or
+ even that the zone exists at all. */
+
+static void
+sfnt_move_glyph_zone (struct sfnt_interpreter *interpreter, uint32_t point,
+ size_t n, sfnt_f26dot6 distance)
+{
+ interpreter->state.move (&interpreter->glyph_zone->x_current[point],
+ &interpreter->glyph_zone->y_current[point],
+ n, interpreter, distance, NULL);
+}
+
+/* Move N points from the specified POINT in INTERPRETER's twilight
+ zone by the given DISTANCE along the freedom vector.
+
+ Do not touch the points that are moved.
+
+ No checking is done to ensure that POINT lies inside the zone, or
+ even that the zone exists at all. */
+
+static void
+sfnt_move_twilight_zone (struct sfnt_interpreter *interpreter, uint32_t point,
+ size_t n, sfnt_f26dot6 distance)
+{
+ interpreter->state.move (&interpreter->twilight_x[point],
+ &interpreter->twilight_y[point],
+ n, interpreter, distance, NULL);
+}
+
+/* Move the point P in the zone pointed to by the ZP2 register in
+ INTERPRETER's graphics state by DX, and DY.
+
+ Touch the point P in the directions of the movement.
+
+ Check that P is valid; if not, trap. Else, perform the move
+ directly without converting it from the projection vector or to the
+ freedom vector. */
+
+static void
+sfnt_direct_move_zp2 (struct sfnt_interpreter *interpreter, uint32_t p,
+ sfnt_f26dot6 dx, sfnt_f26dot6 dy)
+{
+ if (!interpreter->state.zp2)
+ {
+ if (p >= interpreter->twilight_zone_size)
+ TRAP ("point out of bounds");
+
+ interpreter->twilight_x[p]
+ = sfnt_add (interpreter->twilight_x[p], dx);
+ interpreter->twilight_y[p]
+ = sfnt_add (interpreter->twilight_y[p], dy);
+ }
+ else
+ {
+ if (!interpreter->glyph_zone
+ || p >= interpreter->glyph_zone->num_points)
+ TRAP ("point out of bounds");
+
+ interpreter->glyph_zone->x_current[p]
+ = sfnt_add (interpreter->glyph_zone->x_current[p], dx);
+ interpreter->glyph_zone->y_current[p]
+ = sfnt_add (interpreter->glyph_zone->y_current[p], dy);
+
+ if (dx)
+ interpreter->glyph_zone->flags[p] |= SFNT_POINT_TOUCHED_X;
+
+ if (dy)
+ interpreter->glyph_zone->flags[p] |= SFNT_POINT_TOUCHED_Y;
+ }
+}
+
+/* Project the vector VX, VY onto INTERPRETER's projection vector.
+ Return the magnitude of the projection. */
+
+static sfnt_f26dot6
+sfnt_project_vector (struct sfnt_interpreter *interpreter,
+ sfnt_f26dot6 vx, sfnt_f26dot6 vy)
+{
+ return interpreter->state.project (vx, vy, interpreter);
+}
+
+/* Project the vector VX, VY onto INTERPRETER's dual projection
+ vector. Return the magnitude of the projection. */
+
+static sfnt_f26dot6
+sfnt_dual_project_vector (struct sfnt_interpreter *interpreter,
+ sfnt_f26dot6 vx, sfnt_f26dot6 vy)
+{
+ return interpreter->state.dual_project (vx, vy, interpreter);
+}
+
+/* Interpret a FLIPRGOFF instruction in INTERPRTER. Make each point
+ in ZP0 between L and H an off-curve point. */
+
+static void
+sfnt_interpret_fliprgoff (struct sfnt_interpreter *interpreter,
+ uint32_t h, uint32_t l)
+{
+ uint32_t i;
+
+ sfnt_check_zp0 (interpreter, l);
+ sfnt_check_zp0 (interpreter, h);
+
+ if (!interpreter->state.zp0)
+ return;
+
+ for (i = l; i <= h; ++i)
+ interpreter->glyph_zone->flags[i] &= ~01;
+}
+
+/* Interpret a FLIPRGON instruction in INTERPRTER. Make each point in
+ ZP0 between L and H an on-curve point. */
+
+static void
+sfnt_interpret_fliprgon (struct sfnt_interpreter *interpreter,
+ uint32_t h, uint32_t l)
+{
+ uint32_t i;
+
+ sfnt_check_zp0 (interpreter, l);
+ sfnt_check_zp0 (interpreter, h);
+
+ if (!interpreter->state.zp0)
+ return;
+
+ for (i = l; i <= h; ++i)
+ interpreter->glyph_zone->flags[i] |= 01;
+}
+
+/* Interpret a FLIPPT instruction in INTERPRETER. For loop times, pop
+ a point in ZP0. If it is an on-curve point, make it an off-curve
+ one, and vice versa. */
+
+static void
+sfnt_interpret_flippt (struct sfnt_interpreter *interpreter)
+{
+ uint32_t point;
+
+ while (interpreter->state.loop--)
+ {
+ point = POP ();
+
+ /* There are no flags in the twilight zone.
+ But first check that the point is within bounds. */
+
+ sfnt_check_zp0 (interpreter, point);
+
+ if (!interpreter->state.zp0)
+ continue;
+
+ /* If POINT is on the curve, make it off the curve and vice
+ versa. */
+
+ if (interpreter->glyph_zone->flags[point] & 01)
+ interpreter->glyph_zone->flags[point] &= ~01;
+ else
+ interpreter->glyph_zone->flags[point] |= 01;
+ }
+
+ /* Restore loop. */
+ interpreter->state.loop = 1;
+}
+
+/* Interpret an SCFS instruction.
+ Move P in ZP2 along the freedom vector until its projection is
+ equal to C.
+
+ If ZP2 is the twilight zone, ``create'' P by setting its original
+ position to the projection. */
+
+static void
+sfnt_interpret_scfs (struct sfnt_interpreter *interpreter,
+ uint32_t p, sfnt_f26dot6 c)
+{
+ sfnt_f26dot6 x, y, distance;
+
+ sfnt_address_zp2 (interpreter, p, &x, &y, NULL, NULL);
+ distance = PROJECT (x, y);
+ sfnt_move_zp2 (interpreter, p, 1, sfnt_sub (c, distance));
+
+ if (!interpreter->state.zp2)
+ {
+ interpreter->twilight_original_x[p] = interpreter->twilight_x[p];
+ interpreter->twilight_original_y[p] = interpreter->twilight_y[p];
+ }
+}
+
+/* Symmetrically round the 26.6 fixed point value X using the rounding
+ mode in INTERPRETER. Return the result. */
+
+static sfnt_f26dot6
+sfnt_round_symmetric (struct sfnt_interpreter *interpreter, sfnt_f26dot6 x)
+{
+ int sign;
+
+ sign = 1;
+
+ if (x < 0)
+ {
+ sign = -1;
+ x = -x;
+ }
+
+ return interpreter->state.round (x, interpreter) * sign;
+}
+
+/* Interpret an MIAP (``Move Indirect Absolute Point'') instruction
+ using INTERPRETER.
+
+ Move P in ZP0 along the freedom vector until its projection on the
+ projection vector is equal to CVT units in the projection vector.
+
+ Finally, set RP0 and RP1 to P.
+
+ If ZP0 is the twilight zone, then first create that point in the
+ twilight zone by setting its ``original position'' to the
+ projection of the value.
+
+ If OPCODE is 0x3f, then in addition check the CVT value against the
+ control value cut-in, and round the magnitudes of the movement. */
+
+static void
+sfnt_interpret_miap (struct sfnt_interpreter *interpreter,
+ uint32_t cvt, uint32_t p, unsigned char opcode)
+{
+ sfnt_f26dot6 x, y, distance, value, delta;
+
+ /* Read the cvt value. */
+
+ if (cvt >= interpreter->cvt_size)
+ TRAP ("out of bounds read to cvt");
+
+ value = interpreter->cvt[cvt];
+
+ /* Now load the point. */
+ sfnt_address_zp0 (interpreter, p, &x, &y, NULL, NULL);
+
+ /* Create the twilight zone point if necessary.
+ Note that the value used is not rounded. */
+
+ if (!interpreter->state.zp0)
+ {
+ x = interpreter->twilight_x[p]
+ = interpreter->twilight_original_x[p]
+ = sfnt_mul_f2dot14 (interpreter->state.projection_vector.x,
+ value);
+
+ y = interpreter->twilight_y[p]
+ = interpreter->twilight_original_y[p]
+ = sfnt_mul_f2dot14 (interpreter->state.projection_vector.y,
+ value);
+ }
+
+ /* Obtain the original distance. */
+ distance = sfnt_project_vector (interpreter, x, y);
+
+ /* Round the distance and apply the cvt cut in if necessary. */
+
+ if (opcode == 0x3f)
+ {
+ delta = sfnt_sub (value, distance);
+
+ if (delta < 0)
+ delta = -delta;
+
+ /* If delta is more than the cvt cut in (more aptly named ``cut
+ out''), use the original distance. */
+
+ if (delta > interpreter->state.cvt_cut_in)
+ value = distance;
+
+ /* Round value. */
+ value = sfnt_round_symmetric (interpreter, value);
+ }
+
+ /* Move the point by the distance. */
+ sfnt_move_zp0 (interpreter, p, 1, sfnt_sub (value, distance));
+
+ /* Set reference points. */
+ interpreter->state.rp0 = p;
+ interpreter->state.rp1 = p;
+}
+
+/* Perform a single iteration of sfnt_interpret_alignrp. RP0X and
+ RP0Y should be the position of the reference point RP0 in ZP0. */
+
+static void
+sfnt_interpret_alignrp_1 (struct sfnt_interpreter *interpreter,
+ sfnt_f26dot6 rp0x, sfnt_f26dot6 rp0y)
+{
+ sfnt_f26dot6 distance, x, y;
+ uint32_t point;
+
+ point = POP ();
+
+ /* Load this point. */
+ sfnt_address_zp1 (interpreter, point, &x, &y, NULL, NULL);
+
+ /* Measure the distance from here to rp0. */
+ distance = sfnt_project_vector (interpreter, sfnt_sub (x, rp0x),
+ sfnt_sub (y, rp0y));
+
+ /* Move by the opposite. */
+ sfnt_move_zp1 (interpreter, point, 1, -distance);
+}
+
+/* For loop times, pop a point in ZP1 and align it to RP0 in ZP0 by
+ moving it along the freedom vector until its projected distance
+ from RP0 becomes 0. */
+
+static void
+sfnt_interpret_alignrp (struct sfnt_interpreter *interpreter)
+{
+ sfnt_f26dot6 rp0x, rp0y;
+
+ sfnt_address_zp0 (interpreter, interpreter->state.rp0,
+ &rp0x, &rp0y, NULL, NULL);
+
+ while (interpreter->state.loop--)
+ {
+ sfnt_interpret_alignrp_1 (interpreter, rp0x, rp0y);
+
+ /* Reload RP0 if it is in the same zone as ZP1. */
+ if (interpreter->state.zp0 == interpreter->state.zp1)
+ sfnt_address_zp0 (interpreter, interpreter->state.rp0,
+ &rp0x, &rp0y, NULL, NULL);
+ }
+
+ interpreter->state.loop = 1;
+}
+
+/* Align the two points P1 and P2 relative to the projection vector.
+ P1 is addressed relative to ZP0, and P2 is addressed relative to
+ ZP1.
+
+ Move both points along the freedom vector by half the magnitude of
+ the the projection of a vector formed by P1.x - P2.x, P1.y - P2.y,
+ upon the projection vector. */
+
+static void
+sfnt_interpret_alignpts (struct sfnt_interpreter *interpreter,
+ uint32_t p1, uint32_t p2)
+{
+ sfnt_f26dot6 p1x, p1y, p2x, p2y;
+ sfnt_f26dot6 magnitude;
+
+ sfnt_address_zp0 (interpreter, p1, &p1x, &p1y, NULL, NULL);
+ sfnt_address_zp1 (interpreter, p2, &p2x, &p2y, NULL, NULL);
+
+ magnitude = sfnt_project_vector (interpreter,
+ sfnt_sub (p1x, p2x),
+ sfnt_sub (p1y, p2y));
+ magnitude = magnitude / 2;
+
+ /* Now move both points along the freedom vector. */
+ sfnt_move_zp0 (interpreter, p1, 1, magnitude);
+ sfnt_move_zp1 (interpreter, p2, 1, -magnitude);
+}
+
+/* Set the point P in the zone referenced in INTERPRETER's ZP2
+ register to the intersection between the line formed by the points
+ POINT_A0 to POINT_A1 in ZP0 and another line formed by POINT_B0 to
+ POINT_B1 in ZP1.
+
+ Touch the point P. */
+
+static void
+sfnt_interpret_isect (struct sfnt_interpreter *interpreter,
+ uint32_t point_a0, uint32_t point_a1,
+ uint32_t point_b0, uint32_t point_b1,
+ uint32_t p)
+{
+ sfnt_f26dot6 a0x, a0y, a1x, a1y;
+ sfnt_f26dot6 b0x, b0y, b1x, b1y;
+#if 0
+ sfnt_f26dot6 determinant, dx, dy;
+ sfnt_f26dot6 a0, b0, a1, b1;
+ sfnt_f26dot6 c0, c1, px, py;
+#else
+ sfnt_f26dot6 dx, dy, dax, day, dbx, dby;
+ sfnt_f26dot6 discriminant, val, dot_product;
+ sfnt_f26dot6 px, py;
+#endif
+
+ /* Load points. */
+ sfnt_address_zp0 (interpreter, point_a0, &a0x, &a0y, NULL, NULL);
+ sfnt_address_zp0 (interpreter, point_a1, &a1x, &a1y, NULL, NULL);
+ sfnt_address_zp1 (interpreter, point_b0, &b0x, &b0y, NULL, NULL);
+ sfnt_address_zp1 (interpreter, point_b1, &b1x, &b1y, NULL, NULL);
+
+#if 0
+ /* The system is determined from the standard form (look this up) of
+ both lines.
+
+ (the variables below have no relation to C identifiers
+ unless otherwise specified.)
+
+ a0*x + b0*y = c0
+ a1*x + b1*y = c1
+
+ The coefficient matrix is thus
+
+ [ a0 b0
+ a1 b1 ]
+
+ the vector of constants (also just dubbed the ``column vector''
+ by some people)
+
+ [ c0
+ c1 ]
+
+ and the solution vector becomes
+
+ [ x
+ y ]
+
+ Since there are exactly two equations and two unknowns, Cramer's
+ rule applies, and there is no need for any Gaussian elimination.
+
+ The determinant for the coefficient matrix is:
+
+ D = a0*b1 - b0*a1
+
+ the first and second determinants are:
+
+ Dx = c0*b1 - a0*c1
+ Dy = a1*c1 - c0*b1
+
+ and x = Dx / D, y = Dy / D.
+
+ If the system is indeterminate, D will be 0. */
+
+ sfnt_line_to_standard_form (a0x, a0y, a1x, a1y,
+ &a0, &b0, &c0);
+ sfnt_line_to_standard_form (b0x, b0y, b1x, b1y,
+ &a1, &b1, &c1);
+
+
+ /* Compute determinants. */
+ determinant = sfnt_sub (sfnt_mul_fixed (a0, b1),
+ sfnt_mul_fixed (b0, a1));
+ dx = sfnt_sub (sfnt_mul_fixed (c0, b1),
+ sfnt_mul_fixed (a1, c1));
+ dy = sfnt_sub (sfnt_mul_fixed (a0, c1),
+ sfnt_mul_fixed (c0, b0));
+
+ /* Detect degenerate cases. */
+
+ if (determinant == 0)
+ goto degenerate_case;
+#else
+ /* The algorithm above would work with floating point, but overflows
+ too easily with fixed point numbers.
+
+ Instead, use the modified vector projection algorithm found in
+ FreeType. */
+
+ dbx = sfnt_sub (b1x, b0x);
+ dby = sfnt_sub (b1y, b0y);
+ dax = sfnt_sub (a1x, a0x);
+ day = sfnt_sub (a1y, a0y);
+
+ /* Compute vector cross product. */
+ discriminant = sfnt_add (sfnt_mul_f26dot6 (dax, -dby),
+ sfnt_mul_f26dot6 (day, dbx));
+ dot_product = sfnt_add (sfnt_mul_f26dot6 (dax, dbx),
+ sfnt_mul_f26dot6 (day, dby));
+
+ /* Reject any non-intersections and grazing intersections. */
+ if (!(sfnt_mul (19, abs (discriminant)) > abs (dot_product)))
+ return;
+
+ /* Reject any non-intersections. */
+ if (!discriminant)
+ goto degenerate_case;
+
+ dx = sfnt_sub (b0x, a0x);
+ dy = sfnt_sub (b0y, a0y);
+ val = sfnt_add (sfnt_mul_f26dot6 (dx, -dby),
+ sfnt_mul_f26dot6 (dy, dbx));
+
+ /* Project according to these values. */
+ dx = sfnt_add (a0x, sfnt_multiply_divide_signed (val, dax,
+ discriminant));
+ dy = sfnt_add (a0y, sfnt_multiply_divide_signed (val, day,
+ discriminant));
+#endif
+
+ sfnt_store_zp2 (interpreter, p,
+#if 0
+ sfnt_div_fixed (dx, determinant),
+ sfnt_div_fixed (dy, determinant),
+#else
+ dx, dy,
+#endif
+ SFNT_POINT_TOUCHED_BOTH);
+ return;
+
+ degenerate_case:
+
+ /* Apple says that in this case:
+
+ Px = (a0x + a1x) / 2 + (b0x + b1x) / 2
+ ---------------------------------
+ 2
+ Py = (a0y + a1y) / 2 + (b0y + b1y) / 2
+ ---------------------------------
+ 2 */
+
+ px = (sfnt_add (a0x, a1x) / 2 + sfnt_add (b0x, b1x) / 2) / 2;
+ py = (sfnt_add (a0y, a1y) / 2 + sfnt_add (b0y, b1y) / 2) / 2;
+ sfnt_store_zp2 (interpreter, p, px, py,
+ SFNT_POINT_TOUCHED_BOTH);
+}
+
+/* Compute the square root of the 16.16 fixed point number N. */
+
+static sfnt_fixed
+sfnt_sqrt_fixed (sfnt_fixed n)
+{
+ int count;
+ unsigned int root, rem_hi, rem_lo, possible;
+
+ root = 0;
+
+ if (n > 0)
+ {
+ rem_hi = 0;
+ rem_lo = n;
+ count = 24;
+
+ do
+ {
+ rem_hi = (rem_hi << 2) | (rem_lo >> 30);
+ rem_lo <<= 2;
+ root <<= 1;
+ possible = (root << 1) + 1;
+
+ if (rem_hi >= possible)
+ {
+ rem_hi -= possible;
+ root += 1;
+ }
+ }
+ while (--count);
+ }
+
+ return root;
+}
+
+/* Compute a unit vector describing a vector VX, VY. Return the value
+ in *VECTOR. */
+
+static void
+sfnt_normalize_vector (sfnt_f26dot6 vx, sfnt_f26dot6 vy,
+ struct sfnt_unit_vector *vector)
+{
+ sfnt_f26dot6 x_squared, y_squared;
+ sfnt_fixed n, magnitude;
+
+ if (!vx && !vy)
+ {
+ /* If vx and vy are both zero, then just project
+ horizontally. */
+
+ fail:
+ vector->x = 04000;
+ vector->y = 0;
+ return;
+ }
+
+ /* Scale vx and vy up if they won't at least make 1. */
+
+ while (!(vx < -32 || vx > 32) && !(vy < -32 || vy > 32))
+ {
+ vx = vx * 2;
+ vy = vy * 2;
+ }
+
+ /* Compute the magnitude of this vector. */
+ x_squared = sfnt_mul_f26dot6 (vx, vx);
+ y_squared = sfnt_mul_f26dot6 (vy, vy);
+
+ /* x_squared and y_squared can end up too large to fit in a 16.16
+ fixed. Scale both values down until they fit. */
+
+ while (x_squared > 0x200000 || y_squared > 0x200000
+ || x_squared < -0x200000 || y_squared < -0x200000)
+ {
+ x_squared /= 2;
+ y_squared /= 2;
+ }
+
+ /* Convert to 16.16 for greater precision. */
+ n = sfnt_add (x_squared, y_squared) * 1024;
+
+ /* Get hypotenuse of the triangle from vx, 0, to 0, vy. */
+ magnitude = sfnt_sqrt_fixed (n);
+
+ /* Avoid division by zero. */
+ if (!magnitude)
+ goto fail;
+
+ /* Long division.. eek! */
+ vector->x = (sfnt_div_fixed (vx * 1024, magnitude) / 4);
+ vector->y = (sfnt_div_fixed (vy * 1024, magnitude) / 4);
+}
+
+/* Compute a unit vector describing the direction of a line from the
+ point P2 to the point P1. Save the result in *VECTOR.
+
+ P2 is the address of a point in the zone specified in the ZP2
+ register. P1 is the address of a point in the zone specified in
+ the ZP1 register. Take the values of both registers from the
+ specified INTERPRETER's graphics state.
+
+ If PERPENDICULAR, then *VECTOR will be rotated 90 degrees
+ counter-clockwise. Else, *VECTOR will be parallel to the line.
+
+ If ORIGINAL, then the coordinates used to calculate the line will
+ be those prior to instructing. Otherwise, the current coordinates
+ will be used. */
+
+static void
+sfnt_line_to_vector (struct sfnt_interpreter *interpreter,
+ uint32_t p2, uint32_t p1,
+ struct sfnt_unit_vector *vector,
+ bool perpendicular, bool original)
+{
+ sfnt_f26dot6 x2, y2, original_x2, original_y2;
+ sfnt_f26dot6 x1, y1, original_x1, original_y1;
+ sfnt_f26dot6 a, b, temp;
+
+ sfnt_address_zp2 (interpreter, p2, &x2, &y2, &original_x2,
+ &original_y2);
+ sfnt_address_zp1 (interpreter, p1, &x1, &y1, &original_x1,
+ &original_y1);
+
+ /* Use original coordinates if specified. */
+
+ if (original)
+ {
+ x2 = original_x2;
+ y2 = original_y2;
+ x1 = original_x1;
+ y1 = original_y1;
+ }
+
+ /* Calculate the vector between X2, Y2, and X1, Y1. */
+ a = sfnt_sub (x1, x2);
+ b = sfnt_sub (y1, y2);
+
+ /* Rotate counterclockwise if necessary. */
+
+ if (perpendicular)
+ {
+ temp = b;
+ b = a;
+ a = -temp;
+ }
+
+ /* Normalize this vector, turning it into a unit vector. */
+ sfnt_normalize_vector (a, b, vector);
+}
+
+/* Measure the distance between P1 in ZP0 and P2 in ZP1,
+ relative to the projection or dual projection vector.
+
+ Return the distance of P1 and P2 relative to their original
+ un-instructed positions should OPCODE be 0x4A, and to their
+ instructed positions should OPCODE be 0x49. */
+
+static sfnt_f26dot6
+sfnt_measure_distance (struct sfnt_interpreter *interpreter,
+ uint32_t p1, uint32_t p2,
+ unsigned char opcode)
+{
+ sfnt_f26dot6 p1x, p1y, p1_original_x, p1_original_y;
+ sfnt_f26dot6 p2x, p2y, p2_original_x, p2_original_y;
+
+ /* P1 is relative to ZP0 and P2 is relative to ZP1.
+ Apple's manual says this, Microsoft's does not. */
+
+ sfnt_address_zp0 (interpreter, p1, &p1x, &p1y,
+ &p1_original_x, &p1_original_y);
+ sfnt_address_zp1 (interpreter, p2, &p2x, &p2y,
+ &p2_original_x, &p2_original_y);
+
+ if (opcode == 0x4A)
+ return DUAL_PROJECT (sfnt_sub (p1_original_x, p2_original_x),
+ sfnt_sub (p1_original_y, p2_original_y));
+
+ return PROJECT (sfnt_sub (p1x, p2x),
+ sfnt_sub (p1y, p2y));
+}
+
+/* Interpret an MSIRP instruction in INTERPRETER.
+ Take a point P, and make the distance between P in ZP1 and the
+ current position of RP0 in ZP0 equal to D.
+
+ If ZP1 is the twilight zone, then create the point P by setting its
+ position and relative positions.
+
+ Then, if OPCODE is equal to 0x3b, make P RP0. */
+
+static void
+sfnt_interpret_msirp (struct sfnt_interpreter *interpreter,
+ sfnt_f26dot6 d, uint32_t p, unsigned char opcode)
+{
+ sfnt_f26dot6 rp0x, rp0y, rp0_original_x, rp0_original_y;
+ sfnt_f26dot6 x, y;
+ sfnt_f26dot6 old_distance, temp;
+
+ sfnt_address_zp0 (interpreter, interpreter->state.rp0,
+ &rp0x, &rp0y, &rp0_original_x,
+ &rp0_original_y);
+ sfnt_address_zp1 (interpreter, p, &x, &y, NULL, NULL);
+
+ if (!interpreter->state.zp1)
+ {
+ /* Create this point in the twilight zone at RP0. */
+
+ x = interpreter->twilight_x[p] = rp0x;
+ y = interpreter->twilight_y[p] = rp0y;
+
+ /* Now set the original positions to the projected difference
+ from rp0. This makes sense once you think about it. */
+ temp = sfnt_mul_f2dot14 (interpreter->state.projection_vector.x, d);
+ temp = sfnt_add (temp, rp0_original_x);
+ interpreter->twilight_original_x[p] = temp;
+
+ temp = sfnt_mul_f2dot14 (interpreter->state.projection_vector.y, d);
+ temp = sfnt_add (temp, rp0_original_y);
+ interpreter->twilight_original_y[p] = temp;
+ }
+
+ /* Compute the original distance. */
+ old_distance = sfnt_project_vector (interpreter,
+ sfnt_sub (x, rp0x),
+ sfnt_sub (y, rp0y));
+
+ /* Move the point. */
+ sfnt_move_zp1 (interpreter, p, 1, sfnt_sub (d, old_distance));
+
+ /* Nothing in the TrueType reference manual says directly that this
+ instruction should change rp1 and rp2. However, it says this
+ instruction is ``very similar to the MIRP[] instruction
+ except...'', and FreeType seems to do this, so do it as well. */
+
+ interpreter->state.rp1 = interpreter->state.rp0;
+ interpreter->state.rp2 = p;
+
+ if (opcode == 0x3b)
+ interpreter->state.rp0 = p;
+}
+
+/* Interpret an IP instruction in INTERPRETER. For loop times, pop a
+ single point in ZP2, and interpolate it so that its original
+ relationship to the points RP1 in ZP0 and RP2 in ZP1 as measured
+ along the dual projection vector continues to hold true. */
+
+static void
+sfnt_interpret_ip (struct sfnt_interpreter *interpreter)
+{
+ sfnt_f26dot6 rp1x, rp1y, rp1_original_x, rp1_original_y;
+ sfnt_f26dot6 rp2x, rp2y, rp2_original_x, rp2_original_y;
+ sfnt_f26dot6 range, new_range, org_distance, cur_distance;
+ sfnt_f26dot6 new_distance;
+ uint32_t p;
+ sfnt_f26dot6 x, y, original_x, original_y;
+ struct sfnt_interpreter_zone *zone;
+ bool scale;
+
+ /* First load both reference points. */
+ sfnt_address_zp0 (interpreter, interpreter->state.rp1,
+ &rp1x, &rp1y, &rp1_original_x,
+ &rp1_original_y);
+ sfnt_address_zp1 (interpreter, interpreter->state.rp2,
+ &rp2x, &rp2y, &rp2_original_x,
+ &rp2_original_y);
+
+ /* If RP1, RP2, and all arguments all fall within the glyph zone and
+ a simple glyph is loaded, replace their original coordinates as
+ loaded here with coordinates from the unscaled glyph outline. */
+
+ zone = interpreter->glyph_zone;
+ scale = false;
+
+ if (zone && zone->simple
+ && interpreter->state.zp0
+ && interpreter->state.zp1
+ && interpreter->state.zp2)
+ {
+ p = interpreter->state.rp1;
+
+ /* If P is a phantom point... */
+ if (p >= zone->simple->number_of_points)
+ {
+ /* ...scale the phantom point to the size of the original
+ outline. */
+ rp1_original_x = sfnt_div_fixed (rp1_original_x,
+ interpreter->scale);
+ rp1_original_y = sfnt_div_fixed (rp1_original_y,
+ interpreter->scale);
+ }
+ else
+ {
+ rp1_original_x = zone->simple->x_coordinates[p];
+ rp1_original_y = zone->simple->y_coordinates[p];
+ }
+
+ p = interpreter->state.rp2;
+
+ /* If P is a phantom point... */
+ if (p >= zone->simple->number_of_points)
+ {
+ /* ...scale the phantom point to the size of the original
+ outline. */
+ rp2_original_x = sfnt_div_fixed (rp2_original_x,
+ interpreter->scale);
+ rp2_original_y = sfnt_div_fixed (rp2_original_y,
+ interpreter->scale);
+ }
+ else
+ {
+ rp2_original_x = zone->simple->x_coordinates[p];
+ rp2_original_y = zone->simple->y_coordinates[p];
+ }
+
+ scale = true;
+ }
+
+ /* Get the original distance between of RP1 and RP2 measured
+ relative to the dual projection vector. */
+ range = sfnt_dual_project_vector (interpreter,
+ sfnt_sub (rp2_original_x,
+ rp1_original_x),
+ sfnt_sub (rp2_original_y,
+ rp1_original_y));
+
+ if (scale)
+ range = sfnt_mul_fixed_round (range, interpreter->scale);
+
+ /* Get the new distance. */
+ new_range = sfnt_dual_project_vector (interpreter,
+ sfnt_sub (rp2x, rp1x),
+ sfnt_sub (rp2y, rp1y));
+
+ while (interpreter->state.loop--)
+ {
+ p = POP ();
+
+ /* Load this point relative to zp2. */
+ sfnt_address_zp2 (interpreter, p, &x, &y, &original_x,
+ &original_y);
+
+ if (scale)
+ {
+ /* If P is a phantom point... */
+ if (p >= zone->simple->number_of_points)
+ {
+ /* ...scale the phantom point to the size of the original
+ outline. */
+ original_x = sfnt_div_fixed (original_x,
+ interpreter->scale);
+ original_y = sfnt_div_fixed (original_y,
+ interpreter->scale);
+ }
+ else
+ {
+ original_x = zone->simple->x_coordinates[p];
+ original_y = zone->simple->y_coordinates[p];
+ }
+ }
+
+ /* Now compute the old distance from this point to rp1. */
+ org_distance
+ = sfnt_dual_project_vector (interpreter,
+ sfnt_sub (original_x,
+ rp1_original_x),
+ sfnt_sub (original_y,
+ rp1_original_y));
+
+ if (scale)
+ org_distance = sfnt_mul_fixed_round (org_distance,
+ interpreter->scale);
+
+ /* And the current distance from this point to rp1, so
+ how much to move can be determined. */
+ cur_distance
+ = sfnt_project_vector (interpreter,
+ sfnt_sub (x, rp1x),
+ sfnt_sub (y, rp1y));
+
+ /* Finally, apply the ratio of the new distance between RP1 and
+ RP2 to that of the old distance between the two reference
+ points to org_distance, making new_distance.
+
+ If both reference points occupy the same position on the dual
+ projection vector, then simply use the old distance. */
+
+ if (org_distance)
+ {
+ if (range)
+ new_distance
+ = sfnt_multiply_divide_signed (org_distance,
+ new_range, range);
+ else
+ new_distance = org_distance;
+ }
+ else
+ new_distance = 0;
+
+ /* And move the point along the freedom vector to reflect the
+ change in distance. */
+ sfnt_move_zp2 (interpreter, p, 1,
+ sfnt_sub (new_distance, cur_distance));
+ }
+
+ interpreter->state.loop = 1;
+}
+
+/* Apply the delta specified by OPERAND to the control value table
+ entry at INDEX currently loaded inside INTERPRETER.
+
+ Trap if INDEX is out of bounds.
+
+ NUMBER is the number of the specific DELTAC instruction this delta
+ is being applied on behalf of. It must be between 1 and 3. */
+
+static void
+sfnt_deltac (int number, struct sfnt_interpreter *interpreter,
+ unsigned int index, unsigned char operand)
+{
+ int ppem, delta;
+
+ /* Make sure INDEX is a valid cvt entry. */
+
+ if (index >= interpreter->cvt_size)
+ TRAP ("DELTACn instruction out of bounds");
+
+ /* operand is an 8 bit number. The most significant 4 bits
+ represent a specific PPEM size at which to apply the delta
+ specified in the low 4 bits, summed with an instruction specific
+ delta, and the current delta base. */
+
+ ppem = (operand >> 4) + interpreter->state.delta_base;
+
+ switch (number)
+ {
+ case 1:
+ break;
+
+ case 2:
+ ppem += 16;
+ break;
+
+ case 3:
+ ppem += 32;
+ break;
+ }
+
+ /* Don't apply the delta if the ppem size doesn't match. */
+
+ if (interpreter->ppem != ppem)
+ return;
+
+ /* Now, determine the delta using the low 4 bits. The low 4 bits
+ actually specify a ``magnitude'' to apply to the delta, and do
+ not have an encoding for the delta 0. */
+
+ switch (operand & 0xf)
+ {
+ case 0:
+ delta = -8;
+ break;
+
+ case 1:
+ delta = -7;
+ break;
+
+ case 2:
+ delta = -6;
+ break;
+
+ case 3:
+ delta = -5;
+ break;
+
+ case 4:
+ delta = -4;
+ break;
+
+ case 5:
+ delta = -3;
+ break;
+
+ case 6:
+ delta = -2;
+ break;
+
+ case 7:
+ delta = -1;
+ break;
+
+ case 8:
+ delta = 1;
+ break;
+
+ case 9:
+ delta = 2;
+ break;
+
+ case 10:
+ delta = 3;
+ break;
+
+ case 11:
+ delta = 4;
+ break;
+
+ case 12:
+ delta = 5;
+ break;
+
+ case 13:
+ delta = 6;
+ break;
+
+ case 14:
+ delta = 7;
+ break;
+
+ case 15:
+ delta = 8;
+ break;
+
+ /* To pacify -fanalyzer. */
+ default:
+ abort ();
+ }
+
+ /* Now, scale up the delta by the step size, which is determined by
+ the delta shift. */
+ delta *= 1l << (6 - interpreter->state.delta_shift);
+
+ /* Finally, apply the delta to the CVT entry. */
+ interpreter->cvt[index] = sfnt_add (interpreter->cvt[index],
+ delta);
+}
+
+/* Interpret an MDAP (Move Direct Absolute Point) instruction with the
+ opcode OPCODE and the operand P in INTERPRETER.
+
+ Touch the point P (within the zone specified in zp0) in the
+ directions specified in the freedom vector. Then, if OPCODE is
+ 0x2f, round the point and move it the rounded distance along the
+ freedom vector.
+
+ Finally, set the RP0 and RP1 registers to P. */
+
+static void
+sfnt_interpret_mdap (struct sfnt_interpreter *interpreter,
+ uint32_t p, uint32_t opcode)
+{
+ sfnt_f26dot6 here, distance, px, py;
+
+ sfnt_address_zp0 (interpreter, p, &px, &py, NULL, NULL);
+
+ /* Measure the current distance. */
+ here = sfnt_project_vector (interpreter, px, py);
+
+ if (opcode == 0x2f)
+ {
+ /* Measure distance, round, then move to the distance. */
+ distance = sfnt_project_vector (interpreter, px, py);
+ distance = sfnt_round_symmetric (interpreter, distance);
+ distance = sfnt_sub (distance, here);
+ }
+ else
+ /* Don't move. Just touch the point. */
+ distance = 0;
+
+ sfnt_move_zp0 (interpreter, p, 1, distance);
+
+ interpreter->state.rp0 = p;
+ interpreter->state.rp1 = p;
+}
+
+/* Apply the delta specified by OPERAND to the point P in ZP0
+ currently loaded inside INTERPRETER.
+
+ Trap if P is out of bounds.
+
+ NUMBER is the number of the specific DELTAP instruction this delta
+ is being applied on behalf of. It must be between 1 and 3. */
+
+static void
+sfnt_deltap (int number, struct sfnt_interpreter *interpreter,
+ unsigned char operand, unsigned int p)
+{
+ int ppem, delta;
+
+ /* Extract the ppem from OPERAND. The format is the same as in
+ sfnt_deltac. */
+
+ ppem = (operand >> 4) + interpreter->state.delta_base;
+
+ switch (number)
+ {
+ case 1:
+ break;
+
+ case 2:
+ ppem += 16;
+ break;
+
+ case 3:
+ ppem += 32;
+ break;
+ }
+
+ /* Don't apply the delta if the ppem size doesn't match. */
+
+ if (interpreter->ppem != ppem)
+ return;
+
+ /* Now, determine the magnitude of the movement and find the
+ delta. */
+
+ switch (operand & 0xf)
+ {
+ case 0:
+ delta = -8;
+ break;
+
+ case 1:
+ delta = -7;
+ break;
+
+ case 2:
+ delta = -6;
+ break;
+
+ case 3:
+ delta = -5;
+ break;
+
+ case 4:
+ delta = -4;
+ break;
+
+ case 5:
+ delta = -3;
+ break;
+
+ case 6:
+ delta = -2;
+ break;
+
+ case 7:
+ delta = -1;
+ break;
+
+ case 8:
+ delta = 1;
+ break;
+
+ case 9:
+ delta = 2;
+ break;
+
+ case 10:
+ delta = 3;
+ break;
+
+ case 11:
+ delta = 4;
+ break;
+
+ case 12:
+ delta = 5;
+ break;
+
+ case 13:
+ delta = 6;
+ break;
+
+ case 14:
+ delta = 7;
+ break;
+
+ case 15:
+ delta = 8;
+ break;
+
+ /* To pacify -fanalyzer. */
+ default:
+ abort ();
+ }
+
+ /* Now, scale up the delta by the step size, which is determined by
+ the delta shift. */
+ delta *= 1l << (6 - interpreter->state.delta_shift);
+
+ /* Move the point. */
+ sfnt_check_zp0 (interpreter, p);
+ sfnt_move_zp0 (interpreter, p, 1, delta);
+}
+
+/* Needed by sfnt_interpret_call. */
+static void sfnt_interpret_run (struct sfnt_interpreter *,
+ enum sfnt_interpreter_run_context);
+
+/* Call DEFINITION inside INTERPRETER.
+
+ Save INTERPRETER->IP, INTERPRETER->instructions, and
+ INTERPRETER->num_instructions onto the C stack.
+
+ Then, load the instructions in DEFINITION, and run the interpreter
+ again with the context CONTEXT.
+
+ Finally, restore all values. */
+
+static void
+sfnt_interpret_call (struct sfnt_interpreter_definition *definition,
+ struct sfnt_interpreter *interpreter,
+ enum sfnt_interpreter_run_context context)
+{
+ uint16_t num_instructions;
+ int IP;
+ unsigned char *instructions;
+
+ /* Check that no recursion is going on. */
+ if (interpreter->call_depth++ >= 128)
+ TRAP ("CALL called CALL more than 127 times");
+
+ /* Save the old IP, instructions and number of instructions. */
+ num_instructions = interpreter->num_instructions;
+ IP = interpreter->IP;
+ instructions = interpreter->instructions;
+
+ /* Load and run the definition. */
+ interpreter->num_instructions = definition->instruction_count;
+ interpreter->instructions = definition->instructions;
+ interpreter->IP = 0;
+ sfnt_interpret_run (interpreter, context);
+
+ /* Restore the old values. */
+ interpreter->num_instructions = num_instructions;
+ interpreter->IP = IP;
+ interpreter->instructions = instructions;
+ interpreter->call_depth--;
+}
+
+/* Set the detailed rounding state in interpreter, on behalf of either
+ an SROUND or S45ROUND instruction that has been given the operand
+ OPERAND.
+
+ Use the specified GRID_PERIOD to determine the period. It is is a
+ 18.14 fixed point number, but the rounding state set will be a 26.6
+ fixed point number. */
+
+static void
+sfnt_set_srounding_state (struct sfnt_interpreter *interpreter,
+ uint32_t operand, sfnt_f18dot14 grid_period)
+{
+ sfnt_f18dot14 period, phase, threshold;
+
+ /* The most significant 2 bits in the 8 bit OPERAND determine the
+ period. */
+
+ switch ((operand & 0xc0) >> 6)
+ {
+ case 0:
+ period = grid_period / 2;
+ break;
+
+ case 1:
+ period = grid_period;
+ break;
+
+ case 2:
+ period = grid_period * 2;
+ break;
+
+ case 3:
+ default:
+ TRAP ("reserved period given to SROUND");
+ }
+
+ /* The next two bits determine the phase. */
+
+ switch ((operand & 0x30) >> 4)
+ {
+ case 0:
+ phase = 0;
+ break;
+
+ case 1:
+ phase = period / 4;
+ break;
+
+ case 2:
+ phase = period / 2;
+ break;
+
+ case 3:
+ default:
+ phase = period * 3 / 2;
+ break;
+ }
+
+ /* And the least significant 4 bits determine the threshold. */
+
+ if (operand & 0x0f)
+ threshold = (((int) (operand & 0x0f) - 4)
+ * period / 8);
+ else
+ threshold = period - 1;
+
+ /* Now extend these values to 26.6 format and set them. */
+ interpreter->period = period >> 8;
+ interpreter->phase = phase >> 8;
+ interpreter->threshold = threshold >> 8;
+}
+
+/* Move to the next opcode in INTERPRETER's instruction stream.
+ Value is the opcode originally at INTERPRETER->IP. */
+
+static unsigned char
+sfnt_skip_code (struct sfnt_interpreter *interpreter)
+{
+ unsigned char opcode;
+ int nbytes;
+
+ if (interpreter->IP == interpreter->num_instructions)
+ TRAP ("IP at end of instruction stream");
+
+ /* Load opcode at IP. */
+ opcode = interpreter->instructions[interpreter->IP];
+
+ if (opcode == 0x40 || opcode == 0x41)
+ {
+ if (interpreter->IP + 1 >= interpreter->num_instructions)
+ TRAP ("Missing arg to NPUSHB or NPUSHW");
+
+ /* Figure out how many bytes or words to push. */
+
+ nbytes = interpreter->instructions[interpreter->IP + 1];
+
+ if (opcode == 0x41)
+ nbytes *= 2;
+
+ if (interpreter->IP + 2 + nbytes > interpreter->num_instructions)
+ TRAP ("args to NPUSH instruction lie outside IS");
+
+ /* Increment IP by so much. */
+ interpreter->IP += 2 + nbytes;
+ }
+ else if (opcode >= 0xb0 && opcode <= 0xb7)
+ {
+ nbytes = opcode - 0xb0 + 1;
+
+ if (interpreter->IP + 1 + nbytes > interpreter->num_instructions)
+ TRAP ("args to PUSHB instruction lie outide IS");
+
+ interpreter->IP += 1 + nbytes;
+ }
+ else if (opcode >= 0xb8 && opcode <= 0xbf)
+ {
+ nbytes = (opcode - 0xb8 + 1) * 2;
+
+ if (interpreter->IP + 1 + nbytes > interpreter->num_instructions)
+ TRAP ("args to PUSHW instruction lie outide IS");
+
+ interpreter->IP += 1 + nbytes;
+ }
+ else
+ interpreter->IP++;
+
+ return opcode;
+}
+
+/* Interpret the unimplemented operation OPCODE using INTERPRETER, and
+ the context WHY. If there is no instruction definition named
+ OPCODE, trap. */
+
+static void
+sfnt_interpret_unimplemented (struct sfnt_interpreter *interpreter,
+ unsigned char opcode,
+ enum sfnt_interpreter_run_context why)
+{
+ uint32_t i;
+ struct sfnt_interpreter_definition *def;
+
+ for (i = 0; i < interpreter->instruction_defs_size; ++i)
+ {
+ def = &interpreter->instruction_defs[i];
+
+ if (def->opcode == opcode)
+ {
+ if (!def->instructions)
+ TRAP ("** ERROR ** malformed internal instruction"
+ " definition");
+
+ sfnt_interpret_call (def, interpreter, why);
+ return;
+ }
+ }
+
+ TRAP ("invalid instruction");
+}
+
+/* Start a function definition in INTERPRETER, with the function
+ opcode OPCODE. */
+
+static void
+sfnt_interpret_fdef (struct sfnt_interpreter *interpreter,
+ uint32_t opcode)
+{
+ size_t i, num_fdefs;
+ int IP;
+ unsigned char instruction;
+
+ IP = interpreter->IP + 1;
+ num_fdefs = 0;
+
+ /* Now find an ENDF. */
+
+ while ((instruction = sfnt_skip_code (interpreter)) != 0x2d)
+ {
+ if (interpreter->IP >= interpreter->num_instructions)
+ TRAP ("missing ENDF");
+
+ /* If this is an FDEF or IDEF instruction, increment num_fdefs.
+ Prohibit nested FDEFs or IDEFS. */
+ if (instruction == 0x2c || instruction == 0x89)
+ ++num_fdefs;
+
+ if (num_fdefs > 1)
+ TRAP ("IDEF or FDEF before ENDF");
+ }
+
+ /* ENDF has been found. Now save the function definition. Try to
+ find an existing function definition with this opcode. If that
+ fails, make i the first available function definition. */
+
+ for (i = 0; i < interpreter->function_defs_size; ++i)
+ {
+ if (interpreter->function_defs[i].opcode == opcode
+ || !interpreter->function_defs[i].instructions)
+ break;
+ }
+
+ if (i == interpreter->function_defs_size)
+ TRAP ("number of fdefs exceeded maxp->max_function_defs");
+
+ /* Save the opcode of this function definition. */
+ interpreter->function_defs[i].opcode = opcode;
+
+ /* Make sure to ignore the trailing ENDF instruction. */
+ interpreter->function_defs[i].instruction_count
+ = interpreter->IP - IP - 1;
+
+ /* Now save a pointer to the instructions. */
+ interpreter->function_defs[i].instructions = interpreter->instructions + IP;
+}
+
+/* Start an instruction definition in INTERPRETER, with the
+ instruction opcode OPCODE. */
+
+static void
+sfnt_interpret_idef (struct sfnt_interpreter *interpreter,
+ uint32_t opcode)
+{
+ size_t i, num_fdefs;
+ int IP;
+ unsigned char instruction;
+
+ IP = interpreter->IP + 1;
+ num_fdefs = 0;
+
+ /* Now find an ENDF. */
+
+ while ((instruction = sfnt_skip_code (interpreter)) != 0x2d)
+ {
+ if (interpreter->IP >= interpreter->num_instructions)
+ TRAP ("missing ENDF");
+
+ /* If this is an FDEF or IDEF instruction, increment num_fdefs.
+ Prohibit nested FDEFs or IDEFS. */
+ if (instruction == 0x2c || instruction == 0x89)
+ ++num_fdefs;
+
+ if (num_fdefs > 1)
+ TRAP ("IDEF or FDEF before ENDF");
+ }
+
+ /* ENDF has been found. Now save the instruction definition. Try to
+ find an existing instruction definition with this opcode. If that
+ fails, make i the first available instruction definition. */
+
+ for (i = 0; i < interpreter->instruction_defs_size; ++i)
+ {
+ if (interpreter->instruction_defs[i].opcode == opcode
+ || !interpreter->instruction_defs[i].instructions)
+ break;
+ }
+
+ if (i == interpreter->instruction_defs_size)
+ TRAP ("number of defs exceeded maxp->max_instruction_defs");
+
+ /* Save the opcode of this instruction definition. */
+ interpreter->instruction_defs[i].opcode = opcode;
+
+ /* Make sure to ignore the trailing ENDF instruction. */
+ interpreter->instruction_defs[i].instruction_count
+ = interpreter->IP - IP - 1;
+
+ /* Now save a pointer to the instructions. */
+ interpreter->instruction_defs[i].instructions
+ = interpreter->instructions + IP;
+}
+
+/* Interpret the specified conditional at INTERPRETER->IP.
+ If CONDITION, evaluate this branch up until the next ELSE or ENDIF.
+ Else, evaluate the branch from a matching ELSE condition, if
+ one exists. */
+
+static void
+sfnt_interpret_if (struct sfnt_interpreter *interpreter,
+ bool condition)
+{
+ int nifs;
+ bool need_break;
+ unsigned char opcode;
+
+ if (condition)
+ {
+ interpreter->IP++;
+ return;
+ }
+
+ /* Number of ifs. */
+ nifs = 0;
+ need_break = false;
+
+ /* Break past the matching else condition. */
+ do
+ {
+ /* Load the current opcode, then increase IP. */
+ opcode = sfnt_skip_code (interpreter);
+
+ if (interpreter->IP >= interpreter->num_instructions)
+ break;
+
+ switch (opcode)
+ {
+ case 0x58: /* IF */
+ nifs++;
+ break;
+
+ case 0x1B: /* ELSE */
+ if (nifs == 1)
+ need_break = true;
+
+ break;
+
+ case 0x59: /* EIF */
+ nifs--;
+ if (nifs == 0)
+ need_break = true;
+
+ break;
+ }
+ }
+ while (!need_break);
+}
+
+/* Interpret the specified ELSE branch at INTERPRETER->IP.
+ Evaluate starting from a matching ENDIF instruction.
+
+ If IF has set INTERPRETER->IP to a code within an ELSE branch, this
+ will not be called. */
+
+static void
+sfnt_interpret_else (struct sfnt_interpreter *interpreter)
+{
+ int nifs;
+ unsigned char opcode;
+
+ /* Number of ifs. */
+ nifs = 1;
+
+ /* Break past the matching ENDIF condition. */
+ do
+ {
+ /* Load the current opcode, then increase IP. */
+ opcode = sfnt_skip_code (interpreter);
+
+ if (interpreter->IP >= interpreter->num_instructions)
+ break;
+
+ switch (opcode)
+ {
+ case 0x58: /* IF */
+ nifs++;
+ break;
+
+ case 0x59: /* EIF */
+ nifs--;
+
+ break;
+ }
+ }
+ while (nifs > 0);
+}
+
+/* ``Add engine compensation to X''. Since engine compensation is not
+ implemented here, this simply returns X. INTERPRETER is
+ unused. */
+
+static sfnt_f26dot6
+sfnt_round_none (sfnt_f26dot6 x, struct sfnt_interpreter *interpreter)
+{
+ return x;
+}
+
+/* Round X to the grid after adding engine compensation. Return the
+ result. INTERPRETER is unused. */
+
+static sfnt_f26dot6
+sfnt_round_to_grid (sfnt_f26dot6 x, struct sfnt_interpreter *interpreter)
+{
+ return sfnt_round_f26dot6 (x);
+}
+
+/* Round X to the nearest half integer or integer and return the
+ result. INTERPRETER is unused. */
+
+static sfnt_f26dot6
+sfnt_round_to_double_grid (sfnt_f26dot6 x,
+ struct sfnt_interpreter *interpreter)
+{
+ return (x + 020) & ~037;
+}
+
+/* Take the floor of X and return the result. INTERPRETER is
+ unused. */
+
+static sfnt_f26dot6
+sfnt_round_down_to_grid (sfnt_f26dot6 x,
+ struct sfnt_interpreter *interpreter)
+{
+ return sfnt_floor_f26dot6 (x);
+}
+
+/* Take the ceiling of X and return the result. INTERPRETER is
+ unused. */
+
+static sfnt_f26dot6
+sfnt_round_up_to_grid (sfnt_f26dot6 x,
+ struct sfnt_interpreter *interpreter)
+{
+ return sfnt_ceil_f26dot6 (x);
+}
+
+/* Round X to only the nearest half integer and return the result.
+ INTERPRETER is unused. */
+
+static sfnt_f26dot6
+sfnt_round_to_half_grid (sfnt_f26dot6 x,
+ struct sfnt_interpreter *interpreter)
+{
+ return sfnt_floor_f26dot6 (x) + 32;
+}
+
+/* Round X using the detailed rounding information ``super rounding
+ state'' in INTERPRETER. Value is the result. */
+
+static sfnt_f26dot6
+sfnt_round_super (sfnt_f26dot6 x,
+ struct sfnt_interpreter *interpreter)
+{
+ sfnt_f26dot6 value;
+
+ /* Compute the rounded value. */
+ value = sfnt_add ((interpreter->threshold
+ - interpreter->phase), x);
+ value = sfnt_add (value & -interpreter->period,
+ interpreter->phase);
+
+ /* Remember that since the phase is specified by font instructions,
+ it is possible for the sign to be changed. In that case, return
+ the phase itself. */
+
+ return value < 0 ? interpreter->phase : value;
+}
+
+/* Round X using the detailed rounding information ``super rounding
+ state'' in INTERPRETER, but suitably for values that are multiples
+ of the sqrt of 2. Value is the result. */
+
+static sfnt_f26dot6
+sfnt_round_super45 (sfnt_f26dot6 x,
+ struct sfnt_interpreter *interpreter)
+{
+ sfnt_f26dot6 value;
+
+ /* Compute the rounded value. */
+
+ value = ((sfnt_add (x, (interpreter->threshold
+ - interpreter->phase))
+ / interpreter->period)
+ * interpreter->period);
+ value = sfnt_add (value, interpreter->phase);
+
+ /* Remember that since the phase is specified by font instructions,
+ it is possible for the sign to be changed. In that case, return
+ the phase itself. */
+
+ return value < 0 ? interpreter->phase : value;
+}
+
+/* Project the specified vector VX and VY onto the unit vector that is
+ INTERPRETER's projection vector, assuming that INTERPRETER's
+ projection vector is on the X axis.
+
+ Value is the magnitude of the projected vector. */
+
+static sfnt_f26dot6
+sfnt_project_onto_x_axis_vector (sfnt_f26dot6 vx, sfnt_f26dot6 vy,
+ struct sfnt_interpreter *interpreter)
+{
+ return vx;
+}
+
+/* Project the specified vector VX and VY onto the unit vector that is
+ INTERPRETER's projection vector, assuming that INTERPRETER's
+ projection vector is on the Y axis.
+
+ Value is the magnitude of the projected vector. */
+
+static sfnt_f26dot6
+sfnt_project_onto_y_axis_vector (sfnt_f26dot6 vx, sfnt_f26dot6 vy,
+ struct sfnt_interpreter *interpreter)
+{
+ return vy;
+}
+
+/* Calculate AX * BX + AY * BY divided by 16384. */
+
+static int32_t
+sfnt_dot_fix_14 (int32_t ax, int32_t ay, int bx, int by)
+{
+#ifndef INT64_MAX
+ int32_t m, s, hi1, hi2, hi;
+ uint32_t l, lo1, lo2, lo;
+
+
+ /* Compute ax*bx as 64-bit value. */
+ l = (uint32_t) ((ax & 0xffffu) * bx);
+ m = (ax >> 16) * bx;
+
+ lo1 = l + ((uint32_t) m << 16);
+ hi1 = (m >> 16) + ((int32_t) l >> 31) + (lo1 < l);
+
+ /* Compute ay*by as 64-bit value. */
+ l = (uint32_t) ((ay & 0xffffu) * by);
+ m = (ay >> 16) * by;
+
+ lo2 = l + ((uint32_t) m << 16);
+ hi2 = (m >> 16) + ((int32_t) l >> 31) + (lo2 < l);
+
+ /* Add them. */
+ lo = lo1 + lo2;
+ hi = hi1 + hi2 + (lo < lo1);
+
+ /* Divide the result by 2^14 with rounding. */
+ s = hi >> 31;
+ l = lo + (uint32_t) s;
+ hi += s + (l < lo);
+ lo = l;
+
+ l = lo + 0x2000u;
+ hi += (l < lo);
+
+ return (int32_t) (((uint32_t) hi << 18) | (l >> 14));
+#else
+ int64_t xx, yy;
+ int64_t temp;
+
+ xx = (int64_t) ax * bx;
+ yy = (int64_t) ay * by;
+
+ xx += yy;
+ yy = xx >> 63;
+ xx += 0x2000 + yy;
+
+ /* TrueType fonts rely on "division" here truncating towards
+ negative infinity, so compute the arithmetic right shift in place
+ of division. */
+ temp = -(xx < 0);
+ temp = (temp ^ xx) >> 14 ^ temp;
+ return (int32_t) (temp);
+#endif
+}
+
+/* Project the specified vector VX and VY onto the unit vector that is
+ INTERPRETER's projection vector, making only the assumption that the
+ projection vector is a valid unit vector.
+
+ Value is the magnitude of the projected vector. */
+
+static sfnt_f26dot6
+sfnt_project_onto_any_vector (sfnt_f26dot6 vx, sfnt_f26dot6 vy,
+ struct sfnt_interpreter *interpreter)
+{
+ return sfnt_dot_fix_14 (vx, vy,
+ interpreter->state.projection_vector.x,
+ interpreter->state.projection_vector.y);
+}
+
+/* Project the specified vector VX and VY onto the unit vector that is
+ INTERPRETER's dual projection vector, making only the assumption
+ that the dual projection vector is a valid unit vector.
+
+ The dual projection vector is a vector that is normally the
+ projection vector, but can be set using the original unscaled
+ coordinates of two points as well.
+
+ Value is the magnitude of the projected vector. */
+
+static sfnt_f26dot6
+sfnt_dual_project_onto_any_vector (sfnt_f26dot6 vx, sfnt_f26dot6 vy,
+ struct sfnt_interpreter *interpreter)
+{
+ return sfnt_dot_fix_14 (vx, vy,
+ interpreter->state.dual_projection_vector.x,
+ interpreter->state.dual_projection_vector.y);
+}
+
+/* Move N points at *X, *Y by DISTANCE along INTERPRETER's freedom
+ vector. Set N flags in *FLAGS where appropriate and when non-NULL.
+
+ Assume both vectors are aligned to the X axis. */
+
+static void
+sfnt_move_x (sfnt_f26dot6 *restrict x, sfnt_f26dot6 *restrict y,
+ size_t n, struct sfnt_interpreter *interpreter,
+ sfnt_f26dot6 distance, unsigned char *flags)
+{
+ while (n--)
+ {
+ *x = sfnt_add (*x, distance);
+ x++;
+
+ if (flags)
+ *flags++ |= SFNT_POINT_TOUCHED_X;
+ }
+}
+
+/* Move N points at *X, *Y by DISTANCE along INTERPRETER's freedom
+ vector. Set N flags in *FLAGS where appropriate and when non-NULL.
+
+ Assume both vectors are aligned to the Y axis. */
+
+static void
+sfnt_move_y (sfnt_f26dot6 *restrict x, sfnt_f26dot6 *restrict y,
+ size_t n, struct sfnt_interpreter *interpreter,
+ sfnt_f26dot6 distance, unsigned char *flags)
+{
+ while (n--)
+ {
+ *y = sfnt_add (*y, distance);
+ y++;
+
+ if (flags)
+ *flags++ |= SFNT_POINT_TOUCHED_Y;
+ }
+}
+
+/* Move N points at *X, *Y by DISTANCE along INTERPRETER's freedom
+ vector. Set N flags in *FLAGS where appropriate and when
+ non-NULL. */
+
+static void
+sfnt_move (sfnt_f26dot6 *restrict x, sfnt_f26dot6 *restrict y,
+ size_t n, struct sfnt_interpreter *interpreter,
+ sfnt_f26dot6 distance, unsigned char *flags)
+{
+ sfnt_f26dot6 versor, k;
+ sfnt_f2dot14 dot_product;
+ size_t num;
+ unsigned char *flags_start;
+
+ dot_product = interpreter->state.vector_dot_product;
+
+ /* If the vectors are orthogonal, it is impossible to move anywhere,
+ so simply return. */
+ if (!dot_product)
+ return;
+
+ /* Not actually 26.6, but the multiply-divisions below cancel each
+ other out, so the result is 26.6. */
+ versor = interpreter->state.freedom_vector.x;
+
+ /* Save flags that it may be restored for the second Y axis
+ loop. */
+ flags_start = flags;
+
+ if (versor)
+ {
+ /* Move along X axis, converting the distance to the freedom
+ vector. */
+ num = n;
+ k = sfnt_multiply_divide_signed (distance,
+ versor,
+ dot_product);
+
+ while (num--)
+ {
+ *x = sfnt_add (*x, k);
+ x++;
+
+ if (flags)
+ *flags++ |= SFNT_POINT_TOUCHED_X;
+ }
+ }
+
+ flags = flags_start;
+ versor = interpreter->state.freedom_vector.y;
+
+ if (versor)
+ {
+ /* Move along Y axis, converting the distance to the freedom
+ vector. */
+ num = n;
+ k = sfnt_multiply_divide_signed (distance,
+ versor,
+ dot_product);
+
+ while (num--)
+ {
+ *y = sfnt_add (*y, k);
+ y++;
+
+ if (flags)
+ *flags++ |= SFNT_POINT_TOUCHED_Y;
+ }
+ }
+}
+
+/* Compute the dot product of the two versors A and B with
+ rounding. */
+
+static sfnt_f2dot14
+sfnt_short_frac_dot (sfnt_f2dot14 a, sfnt_f2dot14 b)
+{
+ return (sfnt_f2dot14) ((((long) a * b) + 8192) / 16384);
+}
+
+/* Validate the graphics state GS.
+ Establish function pointers for rounding and projection.
+ Establish dot product used to convert vector distances between
+ each other. */
+
+static void
+sfnt_validate_gs (struct sfnt_graphics_state *gs)
+{
+ /* Establish the function used for rounding based on the round
+ state. */
+
+ switch (gs->round_state)
+ {
+ case 5: /* Rounding off. */
+ gs->round = sfnt_round_none;
+ break;
+
+ case 0: /* Round to half grid. */
+ gs->round = sfnt_round_to_half_grid;
+ break;
+
+ case 1: /* Round to grid. */
+ gs->round = sfnt_round_to_grid;
+ break;
+
+ case 2: /* Round to double grid. */
+ gs->round = sfnt_round_to_double_grid;
+ break;
+
+ case 4: /* Round up to grid. */
+ gs->round = sfnt_round_up_to_grid;
+ break;
+
+ case 3: /* Round down to grid. */
+ gs->round = sfnt_round_down_to_grid;
+ break;
+
+ case 6: /* Fine grained rounding. */
+ gs->round = sfnt_round_super;
+ break;
+
+ case 7: /* Fine grained rounding 45 degree variant. */
+ gs->round = sfnt_round_super45;
+ break;
+ }
+
+ /* Establish the function used for vector projection.
+ When the projection vector is an axis vector, a fast
+ version can be used. */
+
+ if (gs->projection_vector.x == 040000)
+ gs->project = sfnt_project_onto_x_axis_vector;
+ else if (gs->projection_vector.y == 040000)
+ gs->project = sfnt_project_onto_y_axis_vector;
+ else
+ gs->project = sfnt_project_onto_any_vector;
+
+ /* Do the same for the dual projection vector. */
+
+ if (gs->dual_projection_vector.x == 040000)
+ gs->dual_project = sfnt_project_onto_x_axis_vector;
+ else if (gs->dual_projection_vector.y == 040000)
+ gs->dual_project = sfnt_project_onto_y_axis_vector;
+ else
+ gs->dual_project = sfnt_dual_project_onto_any_vector;
+
+ /* Compute dot product of the freedom and projection vectors.
+ Handle the common case where the freedom vector is aligned
+ to an axis. */
+
+ if (gs->freedom_vector.x == 040000)
+ gs->vector_dot_product = gs->projection_vector.x;
+ else if (gs->freedom_vector.y == 040000)
+ gs->vector_dot_product = gs->projection_vector.y;
+ else
+ /* Actually calculate the dot product. */
+ gs->vector_dot_product = (sfnt_short_frac_dot (gs->projection_vector.x,
+ gs->freedom_vector.x)
+ + sfnt_short_frac_dot (gs->projection_vector.y,
+ gs->freedom_vector.y));
+
+ /* If the product is less than 1/16th of a vector, prevent overflow
+ by resetting it to 1. */
+
+ if (gs->vector_dot_product > -0x400
+ && gs->vector_dot_product < 0x400)
+ gs->vector_dot_product = (gs->vector_dot_product < 0
+ ? -0x4000 : 0x4000);
+
+ /* Now figure out which function to use to move distances. Handle
+ the common case where both the freedom and projection vectors are
+ aligned to an axis. */
+
+ if (gs->freedom_vector.x == 040000
+ && gs->projection_vector.x == 040000)
+ gs->move = sfnt_move_x;
+ else if (gs->freedom_vector.y == 040000
+ && gs->projection_vector.y == 040000)
+ gs->move = sfnt_move_y;
+ else
+ gs->move = sfnt_move;
+}
+
+/* Set the X and Y versors of the freedom vector of INTERPRETER's
+ graphics state to the specified X and Y, in 2.14 fixed point
+ format. */
+
+static void
+sfnt_set_freedom_vector (struct sfnt_interpreter *interpreter,
+ sfnt_f2dot14 x, sfnt_f2dot14 y)
+{
+ interpreter->state.freedom_vector.x = x;
+ interpreter->state.freedom_vector.y = y;
+
+ sfnt_validate_gs (&interpreter->state);
+}
+
+/* Set the X and Y versors of the projection vector of INTERPRETER's
+ graphics state to the specified X and Y, in 2.14 fixed point
+ format. */
+
+static void
+sfnt_set_projection_vector (struct sfnt_interpreter *interpreter,
+ sfnt_f2dot14 x, sfnt_f2dot14 y)
+{
+ interpreter->state.projection_vector.x = x;
+ interpreter->state.projection_vector.y = y;
+ interpreter->state.dual_projection_vector.x = x;
+ interpreter->state.dual_projection_vector.y = y;
+
+ sfnt_validate_gs (&interpreter->state);
+}
+
+/* Interpret an SHZ instruction with the specified OPCODE. Like
+ sfnt_interpret_shc, but do the move for each point in the entire
+ specified ZONE. */
+
+static void
+sfnt_interpret_shz (struct sfnt_interpreter *interpreter,
+ uint32_t zone, unsigned int opcode)
+{
+ sfnt_f26dot6 x, y, original_x, original_y;
+ sfnt_f26dot6 magnitude;
+
+ if (zone != 0 && !interpreter->glyph_zone)
+ /* There are no points in the glyph zone. */
+ return;
+
+ if (opcode == 0x37)
+ sfnt_address_zp0 (interpreter, interpreter->state.rp1,
+ &x, &y, &original_x, &original_y);
+ else
+ sfnt_address_zp1 (interpreter, interpreter->state.rp2,
+ &x, &y, &original_x, &original_y);
+
+ magnitude = sfnt_project_vector (interpreter,
+ sfnt_sub (x, original_x),
+ sfnt_sub (y, original_y));
+
+ if (zone == 0)
+ sfnt_move_twilight_zone (interpreter, 0,
+ interpreter->twilight_zone_size,
+ magnitude);
+ else
+ sfnt_move_glyph_zone (interpreter, 0,
+ interpreter->glyph_zone->num_points,
+ magnitude);
+}
+
+/* Interpret an SHC instruction with the specified OPCODE and CONTOUR.
+ Like sfnt_interpret_shp, but do the move for each point in the
+ specified contour. */
+
+static void
+sfnt_interpret_shc (struct sfnt_interpreter *interpreter,
+ uint32_t contour, unsigned int opcode)
+{
+ sfnt_f26dot6 x, y, original_x, original_y;
+ sfnt_f26dot6 magnitude;
+ uint16_t reference_point;
+ size_t start, end, start1, end1, n;
+
+ if (!interpreter->glyph_zone)
+ TRAP ("SHC without glyph zone");
+
+ /* Check that the contour is within bounds. */
+ if (contour >= interpreter->glyph_zone->num_contours)
+ TRAP ("contour out of bounds");
+
+ /* Figure out the magnitude of the change, measured from the
+ projection vector. */
+
+ if (opcode == 0x35)
+ sfnt_address_zp0 (interpreter,
+ (reference_point = interpreter->state.rp1),
+ &x, &y, &original_x, &original_y);
+ else
+ sfnt_address_zp1 (interpreter,
+ (reference_point = interpreter->state.rp2),
+ &x, &y, &original_x, &original_y);
+
+ magnitude = sfnt_project_vector (interpreter,
+ sfnt_sub (x, original_x),
+ sfnt_sub (y, original_y));
+
+ /* Now obtain the start and end of the contour.
+ Verify that both are valid. */
+
+ if (contour)
+ start = interpreter->glyph_zone->contour_end_points[contour - 1] + 1;
+ else
+ start = 0;
+
+ end = interpreter->glyph_zone->contour_end_points[contour];
+
+ if (start > end || end >= interpreter->glyph_zone->num_points)
+ TRAP ("invalid contour data in glyph");
+
+ /* If the reference point falls between end and start, split the
+ range formed by end and start at the reference point and keep the
+ latter intact. */
+
+ if (start <= reference_point && reference_point <= end)
+ {
+ /* Do the points between start and rpN. */
+ start1 = start;
+ end1 = reference_point - 1;
+
+ if (start1 <= end1)
+ sfnt_move_glyph_zone (interpreter, start1,
+ end1 - start1 + 1, magnitude);
+
+ /* Now the points between rpN + 1 and end. */
+ start1 = reference_point + 1;
+ end1 = end;
+
+ if (start1 <= end1)
+ sfnt_move_glyph_zone (interpreter, start1,
+ end1 - start1 + 1, magnitude);
+
+ return;
+ }
+
+ /* Compute the number of points to move. */
+ n = end - start + 1;
+
+ /* Move that many points. */
+ sfnt_move_glyph_zone (interpreter, start, n, magnitude);
+}
+
+/* Interpret an SHP instruction with the specified OPCODE. Move a
+ popped point in ZP2 along the freedom vector by the distance
+ between a specified point from its original position, which is RP1
+ in ZP0 if OPCODE is 0x33, and RP2 in ZP1 if OPCODE is 0x32.
+
+ Repeat for the number of iterations specified by a prior SLOOP
+ instruction. */
+
+static void
+sfnt_interpret_shp (struct sfnt_interpreter *interpreter,
+ unsigned int opcode)
+{
+ sfnt_f26dot6 x, y, original_x, original_y;
+ sfnt_f26dot6 magnitude;
+ uint32_t point;
+
+ /* Figure out the magnitude of the change, measured from the
+ projection vector. */
+
+ if (opcode == 0x33)
+ sfnt_address_zp0 (interpreter, interpreter->state.rp1,
+ &x, &y, &original_x, &original_y);
+ else
+ sfnt_address_zp1 (interpreter, interpreter->state.rp2,
+ &x, &y, &original_x, &original_y);
+
+ magnitude = sfnt_project_vector (interpreter,
+ sfnt_sub (x, original_x),
+ sfnt_sub (y, original_y));
+
+ /* Now project it onto the freedom vector and move the point that
+ much for loop variable times. */
+
+ while (interpreter->state.loop--)
+ {
+ point = POP ();
+
+ sfnt_check_zp2 (interpreter, point);
+ sfnt_move_zp2 (interpreter, point, 1, magnitude);
+ }
+
+ /* Restore interpreter->state.loop to 1. */
+ interpreter->state.loop = 1;
+}
+
+#define load_point(p) \
+ (opcode == 0x31 \
+ ? interpreter->glyph_zone->x_current[p] \
+ : interpreter->glyph_zone->y_current[p])
+
+#define store_point(p, val) \
+ (opcode == 0x31 \
+ ? (interpreter->glyph_zone->x_current[p] = (val)) \
+ : (interpreter->glyph_zone->y_current[p] = (val)))
+
+#define load_original(p) \
+ (opcode == 0x31 \
+ ? interpreter->glyph_zone->x_points[p] \
+ : interpreter->glyph_zone->y_points[p])
+
+#define load_unscaled(p) \
+ (opcode == 0x31 \
+ ? interpreter->glyph_zone->simple->x_coordinates[p] \
+ : interpreter->glyph_zone->simple->y_coordinates[p])
+
+#define IUP_SINGLE_PAIR() \
+ /* Now make touch_start the first point before, i.e. the first \
+ touched point in this pair. */ \
+ \
+ if (touch_start == start) \
+ touch_start = end; \
+ else \
+ touch_start = touch_start - 1; \
+ \
+ /* Set point_min and point_max based on which glyph is at a \
+ lower value. */ \
+ \
+ if (load_original (touch_start) < load_original (touch_end)) \
+ { \
+ point_min = touch_start; \
+ point_max = touch_end; \
+ } \
+ else \
+ { \
+ point_max = touch_start; \
+ point_min = touch_end; \
+ } \
+ \
+ min_pos = load_point (point_min); \
+ max_pos = load_point (point_max); \
+ \
+ /* This is needed for interpolation. */ \
+ original_max_pos = load_original (point_max); \
+ original_min_pos = load_original (point_min); \
+ \
+ /* Now process points between touch_start and touch_end. */ \
+ \
+ i = touch_start + 1; \
+ \
+ /* touch_start might be the last point in the contour. */ \
+ \
+ if (i > end) \
+ i = start; \
+ \
+ while (i != touch_end) \
+ { \
+ /* Movement is always relative to the original position of \
+ the point. */ \
+ position = load_original (i); \
+ \
+ /* If i is in between touch_start and touch_end... */ \
+ if (position >= original_min_pos \
+ && position <= original_max_pos) \
+ { \
+ /* Compute the ratio between the two touched point positions \
+ and the original position of the point being touched with \
+ positions from the unscaled outline, if at all \
+ possible. */ \
+ \
+ if (interpreter->glyph_zone->simple) \
+ { \
+ org_max_pos = load_unscaled (point_max); \
+ org_min_pos = load_unscaled (point_min); \
+ position = load_unscaled (i); \
+ } \
+ else \
+ { \
+ org_max_pos = original_max_pos; \
+ org_min_pos = original_min_pos; \
+ } \
+ \
+ /* Handle the degenerate case where original_min_pos and \
+ original_max_pos have not changed by placing the point in \
+ the middle. */ \
+ if (org_min_pos == org_max_pos) \
+ ratio = 077777; \
+ else \
+ /* ... preserve the ratio of i between min_pos and \
+ max_pos... */ \
+ ratio = sfnt_div_fixed ((sfnt_sub (position, \
+ org_min_pos) \
+ * 1024), \
+ (sfnt_sub (org_max_pos, \
+ org_min_pos) \
+ * 1024)); \
+ \
+ delta = sfnt_sub (max_pos, min_pos); \
+ delta = sfnt_mul_fixed_round (ratio, delta); \
+ store_point (i, sfnt_add (min_pos, delta)); \
+ } \
+ else \
+ { \
+ /* ... otherwise, move i by how much the nearest touched \
+ point moved. */ \
+ \
+ if (position >= original_max_pos) \
+ delta = sfnt_sub (max_pos, original_max_pos); \
+ else \
+ delta = sfnt_sub (min_pos, original_min_pos); \
+ \
+ store_point (i, sfnt_add (position, delta)); \
+ } \
+ \
+ if (++i > end) \
+ i = start; \
+ } \
+
+/* Interpolate untouched points in the contour between and including
+ START and END inside INTERPRETER's glyph zone according to the
+ rules specified for an IUP instruction. Perform interpolation on
+ the axis specified by OPCODE and MASK. */
+
+static void
+sfnt_interpret_iup_1 (struct sfnt_interpreter *interpreter,
+ size_t start, size_t end,
+ unsigned char opcode, int mask)
+{
+ size_t point;
+ size_t touch_start, touch_end;
+ size_t first_point;
+ size_t point_min, point_max, i;
+ sfnt_f26dot6 position, min_pos, max_pos, delta, ratio;
+ sfnt_f26dot6 original_max_pos, org_max_pos;
+ sfnt_f26dot6 original_min_pos, org_min_pos;
+
+ /* Find the first touched point. If none is found, simply
+ return. */
+
+ for (point = start; point <= end; ++point)
+ {
+ if (interpreter->glyph_zone->flags[point] & mask)
+ goto touched;
+ }
+
+ goto untouched;
+
+ touched:
+
+ point = start;
+
+ /* Find the first touched point. */
+ while (!(interpreter->glyph_zone->flags[point] & mask))
+ {
+ point++;
+
+ /* There are no touched points. */
+ if (point > end)
+ goto untouched;
+ }
+
+ first_point = point;
+
+ while (point <= end)
+ {
+ /* Find the next untouched point. */
+ while (interpreter->glyph_zone->flags[point] & mask)
+ {
+ point++;
+
+ if (point > end)
+ goto wraparound;
+ }
+
+ /* touch_start is now the first untouched point. */
+ touch_start = point;
+
+ /* Find the next touched point. */
+ while (!(interpreter->glyph_zone->flags[point] & mask))
+ {
+ point++;
+
+ /* Move back to start if point has gone past the end of the
+ contour. */
+ if (point > end)
+ goto wraparound_1;
+ }
+
+ /* touch_end is now the next touched point. */
+ touch_end = point;
+
+ /* Do the interpolation. */
+ IUP_SINGLE_PAIR ();
+ }
+
+ goto untouched;
+
+ wraparound:
+ /* This is like wraparound_1, except that no untouched points have
+ yet to be found.
+
+ This means the first untouched point is start. */
+ touch_start = start;
+
+ wraparound_1:
+ /* If point > end, wrap around. Here, touch_start is set
+ properly, so touch_end must be first_point. */
+
+ touch_end = first_point;
+ IUP_SINGLE_PAIR ();
+
+ untouched:
+ /* No points were touched or all points have been considered, so
+ return immediately. */
+ return;
+}
+
+#undef load_point
+#undef store_point
+#undef load_original
+#undef load_unscaled
+
+/* Interpret an IUP (``interpolate untouched points'') instruction.
+ INTERPRETER is the interpreter, and OPCODE is the instruction
+ number. See the TrueType Reference Manual for more details. */
+
+static void
+sfnt_interpret_iup (struct sfnt_interpreter *interpreter,
+ unsigned char opcode)
+{
+ int mask;
+ size_t i, point, end, first_point;
+
+ /* Check that the zone is the glyph zone. */
+
+ if (!interpreter->state.zp2)
+ TRAP ("trying to iup in twilight zone");
+
+ if (!interpreter->glyph_zone)
+ TRAP ("iup without loaded glyph!");
+
+ /* Figure out what axis to interpolate in based on the opcode. */
+ if (opcode == 0x30)
+ mask = SFNT_POINT_TOUCHED_Y;
+ else
+ mask = SFNT_POINT_TOUCHED_X;
+
+ /* Now, for each contour, interpolate untouched points. */
+ point = 0;
+ for (i = 0; i < interpreter->glyph_zone->num_contours; ++i)
+ {
+ first_point = point;
+ end = interpreter->glyph_zone->contour_end_points[i];
+
+ if (point >= interpreter->glyph_zone->num_points
+ || end >= interpreter->glyph_zone->num_points)
+ TRAP ("glyph contains out of bounds contour end point"
+ " data!");
+
+ sfnt_interpret_iup_1 (interpreter, first_point, end,
+ opcode, mask);
+ point = end + 1;
+
+ /* Skip the subsequent phantom points, which may end up
+ intermixed with contours inside a compound glyph. */
+
+ while (point < interpreter->glyph_zone->num_points
+ && interpreter->glyph_zone->flags[point] & SFNT_POINT_PHANTOM)
+ point++;
+ }
+}
+
+/* Interpret an MIRP instruction with the specified OPCODE in
+ INTERPRETER. Pop a point in ZP1 and CVT index, and move the point
+ until its distance from RP0 in ZP0 is the same as in the control
+ value. If the point lies in the twilight zone, then ``create'' it
+ as well.
+
+ OPCODE contains a great many flags.
+ They are all described in the TrueType reference manual. */
+
+static void
+sfnt_interpret_mirp (struct sfnt_interpreter *interpreter,
+ uint32_t opcode)
+{
+ uint32_t n;
+ uint32_t p;
+ sfnt_f26dot6 distance, delta, temp;
+ sfnt_f26dot6 current_projection, original_projection;
+ sfnt_f26dot6 x, y, org_x, org_y;
+ sfnt_f26dot6 rx, ry, org_rx, org_ry;
+
+ /* CVT index. */
+ n = POP ();
+
+ /* Point number. */
+ p = POP ();
+
+ /* Now get the distance from the CVT. */
+ if (n >= interpreter->cvt_size)
+ TRAP ("cvt index out of bounds");
+
+ distance = interpreter->cvt[n];
+
+ /* Test against the single width value. */
+
+ delta = sfnt_sub (distance,
+ interpreter->state.single_width_value);
+
+ if (delta < 0)
+ delta = -delta;
+
+ if (delta < interpreter->state.sw_cut_in)
+ {
+ /* Use the single width instead, as the CVT entry is too
+ small. */
+
+ if (distance >= 0)
+ distance = interpreter->state.single_width_value;
+ else
+ distance = -interpreter->state.single_width_value;
+ }
+
+ /* Load the reference point. */
+ sfnt_address_zp0 (interpreter, interpreter->state.rp0,
+ &rx, &ry, &org_rx, &org_ry);
+
+ /* Create the point in the twilight zone, should that be ZP1. */
+
+ if (!interpreter->state.zp1)
+ {
+ /* Since P hasn't been loaded yet, whether or not it is valid is
+ not known. */
+ sfnt_check_zp1 (interpreter, p);
+
+ interpreter->twilight_x[p] = rx;
+ interpreter->twilight_y[p] = ry;
+
+ temp = sfnt_mul_f2dot14 (interpreter->state.projection_vector.x,
+ distance);
+ temp = sfnt_add (temp, org_rx);
+ interpreter->twilight_original_x[p] = temp;
+
+ temp = sfnt_mul_f2dot14 (interpreter->state.projection_vector.y,
+ distance);
+ temp = sfnt_add (temp, org_ry);
+ interpreter->twilight_original_y[p] = temp;
+ }
+
+ /* Load P. */
+ sfnt_address_zp1 (interpreter, p, &x, &y, &org_x, &org_y);
+
+ /* If distance would be negative and auto_flip is on, flip it. */
+
+ original_projection = DUAL_PROJECT (org_x - org_rx,
+ org_y - org_ry);
+ current_projection = PROJECT (x - rx, y - ry);
+
+ if (interpreter->state.auto_flip)
+ {
+ if ((original_projection ^ distance) < 0)
+ distance = -distance;
+ }
+
+ /* Flag B means look at the cvt cut in and round the
+ distance. */
+
+ if (opcode & 4)
+ {
+ delta = sfnt_sub (distance, original_projection);
+
+ if (delta < 0)
+ delta = -delta;
+
+ if (delta > interpreter->state.cvt_cut_in)
+ distance = original_projection;
+
+ /* Now, round the distance. */
+ distance = sfnt_round_symmetric (interpreter, distance);
+ }
+
+ /* Flag C means look at the minimum distance. */
+
+ if (opcode & 8)
+ {
+ if (original_projection >= 0
+ && distance < interpreter->state.minimum_distance)
+ distance = interpreter->state.minimum_distance;
+ else if (original_projection < 0
+ && distance > -interpreter->state.minimum_distance)
+ distance = -interpreter->state.minimum_distance;
+ }
+
+ /* Finally, move the point. */
+ sfnt_move_zp1 (interpreter, p, 1,
+ sfnt_sub (distance, current_projection));
+
+ /* Set RP1 to RP0 and RP2 to the point. If flag 3 is set, also make
+ it RP0. */
+ interpreter->state.rp1 = interpreter->state.rp0;
+ interpreter->state.rp2 = p;
+
+ if (opcode & 16)
+ interpreter->state.rp0 = p;
+}
+
+/* Return the projection of the two points P1 and P2's original values
+ along the dual projection vector, with P1 inside ZP0 and P2 inside
+ ZP1. If this zone is the glyph zone and the outline positions of
+ those points are directly accessible, project their original
+ positions and scale the result with rounding, so as to prevent
+ rounding-introduced inaccuracies.
+
+ The scenario where such inaccuracies are significant is generally
+ where an Italic glyph is being instructed at small PPEM sizes,
+ during which a point moved by MDAP[rN] is within 1/64th of a
+ pixel's distance from a point on the grid, yet the measurements
+ taken between such a point and the reference point against which
+ the distance to move is computed is such that the position of the
+ point after applying their rounded values differs by one grid
+ coordinate from the font designer's intentions, either exaggerating
+ or neutralizing the slant of the stem to which it belongs.
+
+ This behavior applies only to MDRP (which see), although a similar
+ strategy is also applied while interpreting IP instructions. */
+
+static sfnt_f26dot6
+sfnt_project_zp1_zp0_org (struct sfnt_interpreter *interpreter,
+ uint32_t p1, uint32_t p2)
+{
+ sfnt_fword x1, y1, x2, y2, projection;
+ struct sfnt_simple_glyph *simple;
+ sfnt_f26dot6 org_x1, org_y1, org_x2, org_y2;
+
+ /* Addressing the twilight zone, perhaps only partially. */
+ if (!interpreter->state.zp0
+ || !interpreter->state.zp1
+ /* Not interpreting a glyph. */
+ || !interpreter->glyph_zone
+ /* Not interpreting a simple glyph. */
+ || !interpreter->glyph_zone->simple
+ /* P1 or P2 are phantom points. */
+ || p1 >= interpreter->glyph_zone->simple->number_of_points
+ || p2 >= interpreter->glyph_zone->simple->number_of_points)
+ goto project_normally;
+
+ simple = interpreter->glyph_zone->simple;
+ x1 = simple->x_coordinates[p1];
+ y1 = simple->y_coordinates[p1];
+ x2 = simple->x_coordinates[p2];
+ y2 = simple->y_coordinates[p2];
+
+ /* Compute the projection. */
+ projection = DUAL_PROJECT (x1 - x2, y1 - y2);
+
+ /* Return the projection, scaled with rounding. */
+ return sfnt_mul_fixed_round (projection, interpreter->scale);
+
+ project_normally:
+ sfnt_address_zp1 (interpreter, p1, NULL, NULL, &org_x1, &org_y1);
+ sfnt_address_zp0 (interpreter, p2, NULL, NULL, &org_x2, &org_y2);
+ return DUAL_PROJECT (org_x1 - org_x2, org_y1 - org_y2);
+}
+
+/* Interpret an MDRP instruction with the specified OPCODE in
+ INTERPRETER. Pop a point in ZP1, and move the point until its
+ distance from RP0 in ZP0 is the same as in the original outline.
+
+ This is almost like MIRP[abcde].
+
+ OPCODE contains a great many flags.
+ They are all described in the TrueType reference manual. */
+
+static void
+sfnt_interpret_mdrp (struct sfnt_interpreter *interpreter,
+ uint32_t opcode)
+{
+ uint32_t p;
+ sfnt_f26dot6 distance, applied;
+ sfnt_f26dot6 current_projection;
+ sfnt_f26dot6 x, y, rx, ry;
+
+ /* Point number. */
+ p = POP ();
+
+ /* Load the points. */
+ sfnt_address_zp1 (interpreter, p, &x, &y, NULL, NULL);
+ sfnt_address_zp0 (interpreter, interpreter->state.rp0,
+ &rx, &ry, NULL, NULL);
+
+ /* Calculate the distance between P and rp0 prior to hinting. */
+ distance = sfnt_project_zp1_zp0_org (interpreter, p,
+ interpreter->state.rp0);
+
+ /* Calculate the distance between P and rp0 as of now in the hinting
+ process. */
+ current_projection = PROJECT (x - rx, y - ry);
+
+ /* Test against the single width value. */
+
+ if (interpreter->state.sw_cut_in > 0
+ && distance < (interpreter->state.single_width_value
+ + interpreter->state.sw_cut_in)
+ && distance > (interpreter->state.single_width_value
+ - interpreter->state.sw_cut_in))
+ {
+ /* Use the single width instead, as the CVT entry is too
+ small. */
+
+ if (distance >= 0)
+ distance = interpreter->state.single_width_value;
+ else
+ distance = -interpreter->state.single_width_value;
+ }
+
+ /* Flag B implies that the distance should be rounded. The CVT cut
+ in is not taken into account by MDRP, contrary to earlier
+ presumptions. */
+
+ if (opcode & 4)
+ applied = sfnt_round_symmetric (interpreter, distance);
+ else
+ applied = distance;
+
+ /* Flag C means look at the minimum distance. */
+
+ if (opcode & 8)
+ {
+ /* Test the sign of the initial distance, but compare the
+ distance that will be applied in reality against the minimum
+ distance. */
+
+ if (distance >= 0
+ && applied < interpreter->state.minimum_distance)
+ applied = interpreter->state.minimum_distance;
+ else if (distance < 0
+ && applied > -interpreter->state.minimum_distance)
+ applied = -interpreter->state.minimum_distance;
+ }
+
+ /* Finally, move the point. */
+ sfnt_move_zp1 (interpreter, p, 1,
+ sfnt_sub (applied, current_projection));
+
+ /* Set RP1 to RP0 and RP2 to the point. If flag 3 is set, also make
+ it RP0. */
+ interpreter->state.rp1 = interpreter->state.rp0;
+ interpreter->state.rp2 = p;
+
+ if (opcode & 16)
+ interpreter->state.rp0 = p;
+}
+
+/* Execute the program now loaded into INTERPRETER.
+ WHY specifies why the interpreter is being run, and is used to
+ control the behavior of instructions such IDEF[] and FDEF[].
+
+ Transfer control to INTERPRETER->trap if interpretation is aborted
+ due to an error, and set INTERPRETER->trap_reason to a string
+ describing the error.
+
+ INTERPRETER->glyph_zone should be cleared before calling this
+ function. */
+
+static void
+sfnt_interpret_run (struct sfnt_interpreter *interpreter,
+ enum sfnt_interpreter_run_context why)
+{
+ unsigned char opcode;
+ bool is_prep;
+
+ /* Determine whether or not this is the control value program. */
+ is_prep = (why == SFNT_RUN_CONTEXT_CONTROL_VALUE_PROGRAM);
+
+#ifdef TEST
+ /* Allow testing control value program instructions as well. */
+ if (why == SFNT_RUN_CONTEXT_TEST)
+ is_prep = true;
+#endif
+
+ while (interpreter->IP < interpreter->num_instructions)
+ {
+ opcode = interpreter->instructions[interpreter->IP];
+
+#ifdef TEST
+ if (interpreter->run_hook)
+ interpreter->run_hook (interpreter);
+#endif
+
+ switch (opcode)
+ {
+ case 0x00: /* SVTCA y */
+ SVTCAy ();
+ break;
+
+ case 0x01: /* SVTCA x */
+ SVTCAx ();
+ break;
+
+ case 0x02: /* SPvTCA y */
+ SPvTCAy ();
+ break;
+
+ case 0x03: /* SPvTCA x */
+ SPvTCAx ();
+ break;
+
+ case 0x04: /* SFvTCA y */
+ SFvTCAy ();
+ break;
+
+ case 0x05: /* SFvTCA x */
+ SFvTCAx ();
+ break;
+
+ case 0x06: /* SPvTL // */
+ case 0x07: /* SPvTL + */
+ SPVTL ();
+ break;
+
+ case 0x08: /* SFvTL // */
+ case 0x09: /* SFvTL + */
+ SFVTL ();
+ break;
+
+ case 0x0A: /* SPvFS */
+ SPVFS ();
+ break;
+
+ case 0x0B: /* SFvFS */
+ SFVFS ();
+ break;
+
+ case 0x0C: /* GPv */
+ GPV ();
+ break;
+
+ case 0x0D: /* GFv */
+ GFV ();
+ break;
+
+ case 0x0E: /* SFvTPv */
+ SFVTPV ();
+ break;
+
+ case 0x0F: /* ISECT */
+ ISECT ();
+ break;
+
+ case 0x10: /* SRP0 */
+ SRP0 ();
+ break;
+
+ case 0x11: /* SRP1 */
+ SRP1 ();
+ break;
+
+ case 0x12: /* SRP2 */
+ SRP2 ();
+ break;
+
+ case 0x13: /* SZP0 */
+ SZP0 ();
+ break;
+
+ case 0x14: /* SZP1 */
+ SZP1 ();
+ break;
+
+ case 0x15: /* SZP2 */
+ SZP2 ();
+ break;
+
+ case 0x16: /* SZPS */
+ SZPS ();
+ break;
+
+ case 0x17: /* SLOOP */
+ SLOOP ();
+ break;
+
+ case 0x18: /* RTG */
+ RTG ();
+ break;
+
+ case 0x19: /* RTHG */
+ RTHG ();
+ break;
+
+ case 0x1A: /* SMD */
+ SMD ();
+ break;
+
+ case 0x1B: /* ELSE */
+ ELSE ();
+ break;
+
+ case 0x1C: /* JMPR */
+ JMPR ();
+ break;
+
+ case 0x1D: /* SCVTCI */
+ SCVTCI ();
+ break;
+
+ case 0x1E: /* SSWCI */
+ SSWCI ();
+ break;
+
+ case 0x1F: /* SSW */
+ SSW ();
+ break;
+
+ case 0x20: /* DUP */
+ DUP ();
+ break;
+
+ case 0x21: /* POP */
+ POP ();
+ break;
+
+ case 0x22: /* CLEAR */
+ CLEAR ();
+ break;
+
+ case 0x23: /* SWAP */
+ SWAP ();
+ break;
+
+ case 0x24: /* DEPTH */
+ DEPTH ();
+ break;
+
+ case 0x25: /* CINDEX */
+ CINDEX ();
+ break;
+
+ case 0x26: /* MINDEX */
+ MINDEX ();
+ break;
+
+ case 0x27: /* ALIGNPTS */
+ ALIGNPTS ();
+ break;
+
+ case 0x28: /* RAW */
+ RAW ();
+ break;
+
+ case 0x29: /* UTP */
+ UTP ();
+ break;
+
+ case 0x2A: /* LOOPCALL */
+ LOOPCALL ();
+ break;
+
+ case 0x2B: /* CALL */
+ CALL ();
+ break;
+
+ case 0x2C: /* FDEF */
+ FDEF ();
+ break;
+
+ case 0x2D: /* ENDF */
+ ENDF ();
+ break;
+
+ case 0x2E: /* MDAP */
+ case 0x2F: /* MDAP */
+ MDAP ();
+ break;
+
+ case 0x30: /* IUP */
+ case 0x31: /* IUP */
+ IUP ();
+ break;
+
+ case 0x32: /* SHP */
+ case 0x33: /* SHP */
+ SHP ();
+ break;
+
+ case 0x34: /* SHC */
+ case 0x35: /* SHC */
+ SHC ();
+ break;
+
+ case 0x36: /* SHZ */
+ case 0x37: /* SHZ */
+ SHZ ();
+ break;
+
+ case 0x38: /* SHPIX */
+ SHPIX ();
+ break;
+
+ case 0x39: /* IP */
+ IP ();
+ break;
+
+ case 0x3A: /* MSIRP */
+ case 0x3B: /* MSIRP */
+ MSIRP ();
+ break;
+
+ case 0x3C: /* ALIGNRP */
+ ALIGNRP ();
+ break;
+
+ case 0x3D: /* RTDG */
+ RTDG ();
+ break;
+
+ case 0x3E: /* MIAP */
+ case 0x3F: /* MIAP */
+ MIAP ();
+ break;
+
+ case 0x40: /* NPUSHB */
+ NPUSHB ();
+ break;
+
+ case 0x41: /* NPUSHW */
+ NPUSHW ();
+ break;
+
+ case 0x42: /* WS */
+ WS ();
+ break;
+
+ case 0x43: /* RS */
+ RS ();
+ break;
+
+ case 0x44: /* WCVTP */
+ WCVTP ();
+ break;
+
+ case 0x45: /* RCVT */
+ RCVT ();
+ break;
+
+ case 0x46: /* GC */
+ case 0x47: /* GC */
+ GC ();
+ break;
+
+ case 0x48: /* SCFS */
+ SCFS ();
+ break;
+
+ case 0x49: /* MD */
+ case 0x4A: /* MD */
+ MD ();
+ break;
+
+ case 0x4B: /* MPPEM */
+ MPPEM ();
+ break;
+
+ case 0x4C: /* MPS */
+ MPS ();
+ break;
+
+ case 0x4D: /* FLIPON */
+ FLIPON ();
+ break;
+
+ case 0x4E: /* FLIPOFF */
+ FLIPOFF ();
+ break;
+
+ case 0x4F: /* DEBUG */
+ DEBUG ();
+ break;
+
+ case 0x50: /* LT */
+ LT ();
+ break;
+
+ case 0x51: /* LTEQ */
+ LTEQ ();
+ break;
+
+ case 0x52: /* GT */
+ GT ();
+ break;
+
+ case 0x53: /* GTEQ */
+ GTEQ ();
+ break;
+
+ case 0x54: /* EQ */
+ EQ ();
+ break;
+
+ case 0x55: /* NEQ */
+ NEQ ();
+ break;
+
+ case 0x56: /* ODD */
+ ODD ();
+ break;
+
+ case 0x57: /* EVEN */
+ EVEN ();
+ break;
+
+ case 0x58: /* IF */
+ IF ();
+ break;
+
+ case 0x59: /* EIF */
+ EIF ();
+ break;
+
+ case 0x5A: /* AND */
+ AND ();
+ break;
+
+ case 0x5B: /* OR */
+ OR ();
+ break;
+
+ case 0x5C: /* NOT */
+ NOT ();
+ break;
+
+ case 0x5D: /* DELTAP1 */
+ DELTAP1 ();
+ break;
+
+ case 0x5E: /* SDB */
+ SDB ();
+ break;
+
+ case 0x5F: /* SDS */
+ SDS ();
+ break;
+
+ case 0x60: /* ADD */
+ ADD ();
+ break;
+
+ case 0x61: /* SUB */
+ SUB ();
+ break;
+
+ case 0x62: /* DIV */
+ DIV ();
+ break;
+
+ case 0x63: /* MUL */
+ MUL ();
+ break;
+
+ case 0x64: /* ABS */
+ ABS ();
+ break;
+
+ case 0x65: /* NEG */
+ NEG ();
+ break;
+
+ case 0x66: /* FLOOR */
+ FLOOR ();
+ break;
+
+ case 0x67: /* CEILING */
+ CEILING ();
+ break;
+
+ case 0x68: /* ROUND */
+ case 0x69: /* ROUND */
+ case 0x6A: /* ROUND */
+ case 0x6B: /* ROUND */
+ ROUND ();
+ break;
+
+ case 0x6C: /* NROUND */
+ case 0x6D: /* NROUND */
+ case 0x6E: /* NRRUND */
+ case 0x6F: /* NROUND */
+ NROUND ();
+ break;
+
+ case 0x70: /* WCVTF */
+ WCVTF ();
+ break;
+
+ case 0x71: /* DELTAP2 */
+ DELTAP2 ();
+ break;
+
+ case 0x72: /* DELTAP3 */
+ DELTAP3 ();
+ break;
+
+ case 0x73: /* DELTAC1 */
+ DELTAC1 ();
+ break;
+
+ case 0x74: /* DELTAC2 */
+ DELTAC2 ();
+ break;
+
+ case 0x75: /* DELTAC3 */
+ DELTAC3 ();
+ break;
+
+ case 0x76: /* SROUND */
+ SROUND ();
+ break;
+
+ case 0x77: /* S45Round */
+ S45ROUND ();
+ break;
+
+ case 0x78: /* JROT */
+ JROT ();
+ break;
+
+ case 0x79: /* JROF */
+ JROF ();
+ break;
+
+ case 0x7A: /* ROFF */
+ ROFF ();
+ break;
+
+ case 0x7B: /* ILLEGAL_INSTRUCTION */
+ ILLEGAL_INSTRUCTION ();
+ break;
+
+ case 0x7C: /* RUTG */
+ RUTG ();
+ break;
+
+ case 0x7D: /* RDTG */
+ RDTG ();
+ break;
+
+ case 0x7E: /* SANGW */
+ SANGW ();
+ break;
+
+ case 0x7F: /* AA */
+ AA ();
+ break;
+
+ case 0x80: /* FLIPPT */
+ FLIPPT ();
+ break;
+
+ case 0x81: /* FLIPRGON */
+ FLIPRGON ();
+ break;
+
+ case 0x82: /* FLIPRGOFF */
+ FLIPRGOFF ();
+ break;
+
+ case 0x83: /* RMVT */
+ case 0x84: /* WMVT */
+ NOT_IMPLEMENTED ();
+ break;
+
+ case 0x85: /* SCANCTRL */
+ SCANCTRL ();
+ break;
+
+ case 0x86: /* SDPVTL */
+ case 0x87: /* SDPVTL */
+ SDPVTL ();
+ break;
+
+ case 0x88: /* GETINFO */
+ GETINFO ();
+ break;
+
+ case 0x89: /* IDEF */
+ IDEF ();
+ break;
+
+ case 0x8A: /* ROLL */
+ ROLL ();
+ break;
+
+ case 0x8B: /* MAX */
+ _MAX ();
+ break;
+
+ case 0x8C: /* MIN */
+ _MIN ();
+ break;
+
+ /* Scan or dropout control is not implemented. Instead, 256
+ grays are used to display pixels which are partially
+ turned on. */
+ case 0x8D: /* SCANTYPE */
+ SCANTYPE ();
+ break;
+
+ case 0x8E: /* INSTCTRL */
+ INSTCTRL ();
+ break;
+
+ case 0x8F: /* ADJUST */
+ case 0x90: /* ADJUST */
+ NOT_IMPLEMENTED ();
+ break;
+
+ case 0x91: /* GXAXIS */
+ GXAXIS ();
+ break;
+
+ default:
+ if (opcode >= 0xE0) /* MIRP */
+ {
+ MIRP ();
+ }
+ else if (opcode >= 0xC0) /* MDRP */
+ {
+ MDRP ();
+ }
+ else if (opcode >= 0xB8) /* PUSHW */
+ {
+ PUSHW ();
+ }
+ else if (opcode >= 0xB0) /* PUSHB */
+ {
+ PUSHB ();
+ }
+ else
+ NOT_IMPLEMENTED ();
+ }
+
+ next_instruction:
+ /* In the case of an NPUSHB or NPUSHW instruction,
+ interpreter->IP has only been increased to skip over the
+ extra bytes, and not the byte containing the instruction
+ itself. */
+ interpreter->IP++;
+
+ /* This label is used by instructions to continue without
+ incrementing IP. It is used by instructions which set IP
+ themselves, such as ELSE, IF, FDEF, IDEF and JMPR. */
+ skip_step:
+ continue;
+ }
+}
+
+/* Execute the font program FPGM using INTERPRETER.
+ This must only be called once per interpreter, else behavior is
+ undefined.
+
+ Value is NULL upon success, else it is a string describing the
+ reason for failure.
+
+ The caller must save the graphics state after interpreting the font
+ program and restore it prior to instructing each glyph. */
+
+TEST_STATIC const char *
+sfnt_interpret_font_program (struct sfnt_interpreter *interpreter,
+ struct sfnt_fpgm_table *fpgm)
+{
+ if (setjmp (interpreter->trap))
+ return interpreter->trap_reason;
+
+ /* Set up the interpreter to evaluate the font program. */
+ interpreter->IP = 0;
+ interpreter->SP = interpreter->stack;
+ interpreter->instructions = fpgm->instructions;
+ interpreter->num_instructions = fpgm->num_instructions;
+ interpreter->glyph_zone = NULL;
+
+ sfnt_interpret_run (interpreter, SFNT_RUN_CONTEXT_FONT_PROGRAM);
+ return NULL;
+}
+
+/* Execute the control value program PREP using INTERPRETER.
+
+ Return NULL and the graphics state after the execution of the
+ program in *STATE, or a string describing the reason for a failure
+ to interpret the program.
+
+ The caller must save the graphics state after interpreting the
+ control value program and restore it prior to instructing each
+ glyph. */
+
+TEST_STATIC const char *
+sfnt_interpret_control_value_program (struct sfnt_interpreter *interpreter,
+ struct sfnt_prep_table *prep,
+ struct sfnt_graphics_state *state)
+{
+ if (setjmp (interpreter->trap))
+ return interpreter->trap_reason;
+
+ /* Set up the interpreter to evaluate the control value program. */
+ interpreter->IP = 0;
+ interpreter->SP = interpreter->stack;
+ interpreter->instructions = prep->instructions;
+ interpreter->num_instructions = prep->num_instructions;
+ interpreter->glyph_zone = NULL;
+
+ sfnt_interpret_run (interpreter,
+ SFNT_RUN_CONTEXT_CONTROL_VALUE_PROGRAM);
+
+ /* If instruct_control & 2, then changes to the graphics state made
+ in this program should be reverted. */
+
+ if (interpreter->state.instruct_control & 2)
+ sfnt_init_graphics_state (&interpreter->state);
+ else
+ {
+ /* And even if not, reset the following graphics state
+ variables, to which both the Apple and MS scalers don't
+ permit modifications from the preprogram.
+
+ Not only is such reversion undocumented, it is also
+ inefficient, for modern fonts at large only move points on
+ the Y axis. As such, these fonts must issue a redundant
+ SVTCA[Y] instruction within each glyph program, in place of
+ initializing the projection and freedom vectors once and for
+ all in prep. Unfortunately many fonts which do instruct on
+ the X axis now rely on this ill-conceived behavior, so Emacs
+ must, reluctantly, follow suit. */
+
+ interpreter->state.dual_projection_vector.x = 040000; /* 1.0 */
+ interpreter->state.dual_projection_vector.y = 0;
+ interpreter->state.freedom_vector.x = 040000; /* 1.0 */
+ interpreter->state.freedom_vector.y = 0;
+ interpreter->state.projection_vector.x = 040000; /* 1.0 */
+ interpreter->state.projection_vector.y = 0;
+ interpreter->state.rp0 = 0;
+ interpreter->state.rp1 = 0;
+ interpreter->state.rp2 = 0;
+ interpreter->state.zp0 = 1;
+ interpreter->state.zp1 = 1;
+ interpreter->state.zp2 = 1;
+ interpreter->state.loop = 1;
+
+ /* Validate the graphics state. */
+ sfnt_validate_gs (&interpreter->state);
+ }
+
+ /* Save the graphics state upon success. */
+ memcpy (state, &interpreter->state, sizeof *state);
+ return NULL;
+}
+
+
+
+/* Glyph hinting. The routines here perform hinting on simple and
+ compound glyphs.
+
+ In order to keep the hinting mechanism separate from the rest of
+ the code, the routines here perform outline decomposition and
+ scaling separately. It might be nice to fix that in the
+ future. */
+
+/* Instructed glyph outline decomposition. This is separate from
+ sfnt_decompose_glyph because this file should be able to be built
+ with instructions disabled. */
+
+/* Decompose OUTLINE, an instructed outline, into its individual
+ components.
+
+ Call MOVE_TO to move to a specific location. For each line
+ encountered, call LINE_TO to draw a line to that location. For
+ each spline encountered, call CURVE_TO to draw the curves
+ comprising the spline. Call each of those functions with 16.16
+ fixed point coordinates.
+
+ Call all functions with DCONTEXT as an argument.
+
+ The winding rule used to fill the resulting lines is described in
+ chapter 2 of the TrueType reference manual, under the heading
+ "distinguishing the inside from the outside of a glyph."
+
+ Value is 0 upon success, or some non-zero value upon failure, which
+ can happen if the glyph is invalid. */
+
+static int
+sfnt_decompose_instructed_outline (struct sfnt_instructed_outline *outline,
+ sfnt_move_to_proc move_to,
+ sfnt_line_to_proc line_to,
+ sfnt_curve_to_proc curve_to,
+ void *dcontext)
+{
+ size_t here, last, n;
+
+ if (!outline->num_contours)
+ return 0;
+
+ here = 0;
+
+ for (n = 0; n < outline->num_contours; ++n)
+ {
+ /* here is the first index into the glyph's point arrays
+ belonging to the contour in question. last is the index
+ of the last point in the contour. */
+ last = outline->contour_end_points[n];
+
+ /* Make sure here and last make sense. */
+
+ if (here > last || last >= outline->num_points)
+ goto fail;
+
+ if (sfnt_decompose_glyph_2 (here, last, move_to,
+ line_to, curve_to, dcontext,
+ outline->x_points,
+ outline->y_points,
+ outline->flags, 1024))
+ goto fail;
+
+ /* Move forward to the start of the next contour. */
+ here = last + 1;
+
+ /* here may be a phantom point when outlining a compound glyph,
+ as they can have phantom points mixed in with contours.
+
+ When that happens, skip past all the phantom points. */
+
+ while (here < outline->num_points
+ && outline->flags[here] & SFNT_POINT_PHANTOM)
+ here++;
+ }
+
+ return 0;
+
+ fail:
+ return 1;
+}
+
+/* Decompose and build an outline for the specified instructed outline
+ INSTRUCTED. Return the outline data with a refcount of 0 upon
+ success, and the advance width of the instructed glyph in
+ *ADVANCE_WIDTH, or NULL upon failure.
+
+ This function is not reentrant. */
+
+TEST_STATIC struct sfnt_glyph_outline *
+sfnt_build_instructed_outline (struct sfnt_instructed_outline *instructed,
+ sfnt_fixed *advance_width)
+{
+ struct sfnt_glyph_outline *outline;
+ int rc;
+ sfnt_f26dot6 x1, x2;
+
+ memset (&build_outline_context, 0, sizeof build_outline_context);
+
+ /* Allocate the outline now with enough for 44 words at the end. */
+ outline = xmalloc (sizeof *outline + 40 * sizeof (*outline->outline));
+ outline->outline_size = 40;
+ outline->outline_used = 0;
+ outline->refcount = 0;
+ outline->outline
+ = (struct sfnt_glyph_outline_command *) (outline + 1);
+
+ /* Clear outline bounding box. */
+ outline->xmin = 0;
+ outline->ymin = 0;
+ outline->xmax = 0;
+ outline->ymax = 0;
+
+ /* Set up the context. */
+ build_outline_context.outline = outline;
+ build_outline_context.factor = 0177777;
+
+ /* Start decomposing. */
+ rc = sfnt_decompose_instructed_outline (instructed,
+ sfnt_move_to_and_build,
+ sfnt_line_to_and_build,
+ sfnt_curve_to_and_build,
+ NULL);
+
+ /* Synchronize the outline object with what might have changed
+ inside sfnt_decompose_glyph. */
+ outline = build_outline_context.outline;
+
+ /* Finally, obtain the origin point of the glyph after it has been
+ instructed. */
+
+ if (instructed->num_points > 1)
+ {
+ x1 = instructed->x_points[instructed->num_points - 2];
+ x2 = instructed->x_points[instructed->num_points - 1];
+
+ /* Convert the origin point to a 16.16 fixed point number. */
+ outline->origin = x1 * 1024;
+
+ /* Do the same for the advance width. */
+ *advance_width = (x2 - x1) * 1024;
+ }
+ else
+ {
+ /* Phantom points are absent from this outline, which is
+ impossible. */
+ *advance_width = 0;
+ outline->origin = 0;
+ }
+
+ if (rc)
+ {
+ xfree (outline);
+ return NULL;
+ }
+
+ return outline;
+}
+
+
+
+/* Compute phantom points for the specified glyph GLYPH. Use the
+ unscaled metrics specified in METRICS, and the 16.16 fixed point
+ scale SCALE.
+
+ Place the X and Y coordinates of the first phantom point in *X1 and
+ *Y1, and those of the second phantom point in *X2 and *Y2.
+
+ Place the unrounded X coordinates of both phantom points in *S1 and
+ *S2 respectively. */
+
+static void
+sfnt_compute_phantom_points (struct sfnt_glyph *glyph,
+ struct sfnt_glyph_metrics *metrics,
+ sfnt_fixed scale,
+ sfnt_f26dot6 *x1, sfnt_f26dot6 *y1,
+ sfnt_f26dot6 *x2, sfnt_f26dot6 *y2,
+ sfnt_f26dot6 *s1, sfnt_f26dot6 *s2)
+{
+ sfnt_fword f1, f2;
+
+ /* Two ``phantom points'' are appended to each outline by the scaler
+ prior to instruction interpretation. One of these points
+ represents the left-side bearing distance from xmin, while the
+ other represents the advance width. Both are then used after the
+ hinting process to ensure that the reported glyph metrics are
+ consistent with the instructed outline. */
+
+ /* First compute both values in fwords. */
+ f1 = glyph->xmin - metrics->lbearing;
+ f2 = f1 + metrics->advance;
+
+ /* Apply the metrics distortion. */
+ f1 += glyph->origin_distortion;
+ f2 += glyph->advance_distortion;
+
+ /* Next, scale both up. */
+ *s1 = sfnt_mul_f26dot6_fixed (f1, scale);
+ *s2 = sfnt_mul_f26dot6_fixed (f2, scale);
+
+ /* While not expressly provided in the manual, the phantom points
+ (at times termed the advance and origin points) represent pixel
+ coordinates within the raster, and are therefore rounded. */
+ *x1 = sfnt_round_f26dot6 (*s1);
+ *x2 = sfnt_round_f26dot6 (*s2);
+
+ /* Clear y1 and y2. */
+ *y1 = 0;
+ *y2 = 0;
+}
+
+/* Load the simple glyph GLYPH into the specified INTERPRETER, scaling
+ it up by INTERPRETER's scale, and run its glyph program if
+ present. Use the unscaled metrics specified in METRICS.
+
+ Upon success, return NULL and the resulting points and contours in
+ *VALUE. Else, value is the reason interpretation failed. */
+
+TEST_STATIC const char *
+sfnt_interpret_simple_glyph (struct sfnt_glyph *glyph,
+ struct sfnt_interpreter *interpreter,
+ struct sfnt_glyph_metrics *metrics,
+ struct sfnt_instructed_outline **value)
+{
+ size_t zone_size, temp, outline_size, i;
+ struct sfnt_interpreter_zone *zone;
+ struct sfnt_interpreter_zone *volatile preserved_zone;
+ sfnt_f26dot6 phantom_point_1_y;
+ sfnt_f26dot6 phantom_point_2_y;
+ sfnt_f26dot6 tem;
+ volatile bool zone_was_allocated;
+ struct sfnt_instructed_outline *outline;
+
+ zone_size = 0;
+ zone_was_allocated = false;
+
+ /* Calculate the size of the zone structure. */
+
+ if (ckd_mul (&temp, glyph->simple->number_of_points + 2,
+ sizeof *zone->x_points * 4)
+ || ckd_add (&zone_size, zone_size, temp)
+ || ckd_mul (&temp, glyph->number_of_contours,
+ sizeof *zone->contour_end_points)
+ || ckd_add (&zone_size, zone_size, temp)
+ || ckd_mul (&temp, glyph->simple->number_of_points + 2,
+ sizeof *zone->flags)
+ || ckd_add (&zone_size, zone_size, temp)
+ || ckd_add (&zone_size, zone_size, sizeof *zone))
+ return "Glyph exceeded maximum permissible size";
+
+ /* Don't use malloc if possible. */
+
+ if (zone_size <= 1024 * 16)
+ zone = alloca (zone_size);
+ else
+ {
+ zone = xmalloc (zone_size);
+ zone_was_allocated = true;
+ }
+
+ /* Now load the zone with data. */
+ zone->num_points = glyph->simple->number_of_points + 2;
+ zone->num_contours = glyph->number_of_contours;
+ zone->contour_end_points = (size_t *) (zone + 1);
+ zone->x_points = (sfnt_f26dot6 *) (zone->contour_end_points
+ + zone->num_contours);
+ zone->x_current = zone->x_points + zone->num_points;
+ zone->y_points = zone->x_current + zone->num_points;
+ zone->y_current = zone->y_points + zone->num_points;
+ zone->flags = (unsigned char *) (zone->y_current
+ + zone->num_points);
+ zone->simple = glyph->simple;
+
+ /* Load x_points and x_current. */
+ for (i = 0; i < glyph->simple->number_of_points; ++i)
+ {
+ /* Load the fword. */
+ tem = glyph->simple->x_coordinates[i];
+
+ /* Scale that fword. */
+ tem = sfnt_mul_f26dot6_fixed (tem, interpreter->scale);
+
+ /* Set x_points and x_current. */
+ zone->x_points[i] = tem;
+ zone->x_current[i] = tem;
+ }
+
+ /* Compute and load phantom points. */
+ sfnt_compute_phantom_points (glyph, metrics, interpreter->scale,
+ &zone->x_current[i], &phantom_point_1_y,
+ &zone->x_current[i + 1], &phantom_point_2_y,
+ /* Phantom points are rounded to the
+ pixel grid once they are inserted
+ into the glyph zone, but the
+ original coordinates must remain
+ untouched, as fonts rely on this to
+ interpolate points by this
+ scale. */
+ &zone->x_points[i], &zone->x_points[i + 1]);
+
+ /* Load y_points and y_current, along with flags. */
+ for (i = 0; i < glyph->simple->number_of_points; ++i)
+ {
+ /* Load the fword. */
+ tem = glyph->simple->y_coordinates[i];
+
+ /* Scale that fword. Make sure not to round Y, as this could
+ lead to Y spilling over to the next line. */
+ tem = sfnt_mul_f26dot6_fixed (tem, interpreter->scale);
+
+ /* Set y_points and y_current. */
+ zone->y_points[i] = tem;
+ zone->y_current[i] = tem;
+
+ /* Set flags. */
+ zone->flags[i] = (glyph->simple->flags[i]
+ & ~SFNT_POINT_TOUCHED_BOTH);
+
+ /* Make sure to clear the phantom points flag. */
+ zone->flags[i] &= ~SFNT_POINT_PHANTOM;
+ }
+
+ /* Load phantom points. */
+ zone->y_points[i] = phantom_point_1_y;
+ zone->y_points[i + 1] = phantom_point_2_y;
+ zone->y_current[i] = phantom_point_1_y;
+ zone->y_current[i + 1] = phantom_point_2_y;
+
+ /* Load phantom point flags. */
+ zone->flags[i] = SFNT_POINT_PHANTOM;
+ zone->flags[i + 1] = SFNT_POINT_PHANTOM;
+
+ /* Load contour end points. */
+ for (i = 0; i < zone->num_contours; ++i)
+ zone->contour_end_points[i]
+ = glyph->simple->end_pts_of_contours[i];
+
+ /* Load the glyph program. */
+ interpreter->IP = 0;
+ interpreter->SP = interpreter->stack;
+ interpreter->instructions = glyph->simple->instructions;
+ interpreter->num_instructions = glyph->simple->instruction_length;
+ interpreter->glyph_zone = zone;
+
+ /* Copy zone over to this volatile variable. */
+ preserved_zone = zone;
+
+ if (setjmp (interpreter->trap))
+ {
+ if (zone_was_allocated)
+ xfree (preserved_zone);
+
+ interpreter->glyph_zone = NULL;
+ return interpreter->trap_reason;
+ }
+
+ sfnt_interpret_run (interpreter, SFNT_RUN_CONTEXT_GLYPH_PROGRAM);
+ interpreter->glyph_zone = NULL;
+
+ /* Move preserved_zone back to zone. */
+ zone = preserved_zone;
+
+ /* Now that the program has been run, build the scaled outline. */
+
+ outline_size = sizeof (*outline);
+ outline_size += (zone->num_contours
+ * sizeof *outline->contour_end_points);
+ outline_size += (zone->num_points
+ * sizeof *outline->x_points * 2);
+ outline_size += zone->num_points;
+
+ /* Allocate the outline. */
+ outline = xmalloc (outline_size);
+ outline->num_points = zone->num_points;
+ outline->num_contours = zone->num_contours;
+ outline->contour_end_points = (size_t *) (outline + 1);
+ outline->x_points = (sfnt_f26dot6 *) (outline->contour_end_points
+ + outline->num_contours);
+ outline->y_points = outline->x_points + outline->num_points;
+ outline->flags = (unsigned char *) (outline->y_points
+ + outline->num_points);
+
+ /* Copy over the contour endpoints, points, and flags. */
+ memcpy (outline->contour_end_points, zone->contour_end_points,
+ zone->num_contours * sizeof *outline->contour_end_points);
+ memcpy (outline->x_points, zone->x_current,
+ zone->num_points * sizeof *outline->x_points);
+ memcpy (outline->y_points, zone->y_current,
+ zone->num_points * sizeof *outline->y_points);
+ memcpy (outline->flags, zone->flags, zone->num_points);
+
+ /* Free the zone if necessary. */
+ if (zone_was_allocated)
+ xfree (zone);
+
+ /* Return the outline and NULL. */
+ *value = outline;
+ return NULL;
+}
+
+/* Apply the transform in the compound glyph component COMPONENT to
+ the array of points of length NUM_COORDINATES given as X and Y.
+
+ Treat X and Y as arrays of 26.6 fixed point values.
+
+ Also, apply the 26.6 fixed point offsets X_OFF and Y_OFF to each X
+ and Y coordinate after the transforms in COMPONENT are
+ effected. */
+
+static void
+sfnt_transform_f26dot6 (struct sfnt_compound_glyph_component *component,
+ sfnt_f26dot6 *restrict x, sfnt_f26dot6 *restrict y,
+ size_t num_coordinates,
+ sfnt_f26dot6 x_off, sfnt_f26dot6 y_off)
+{
+ double m1, m2, m3;
+ double m4, m5, m6;
+ size_t i;
+
+ if (component->flags & 010) /* WE_HAVE_A_SCALE */
+ {
+ m1 = component->u.scale / 16384.0;
+ m2 = m3 = m4 = 0;
+ m5 = component->u.scale / 16384.0;
+ m6 = 0;
+ }
+ else if (component->flags & 0100) /* WE_HAVE_AN_X_AND_Y_SCALE */
+ {
+ m1 = component->u.a.xscale / 16384.0;
+ m2 = m3 = m4 = 0;
+ m5 = component->u.a.yscale / 16384.0;
+ m6 = 0;
+ }
+ else if (component->flags & 0200) /* WE_HAVE_A_TWO_BY_TWO */
+ {
+ m1 = component->u.b.xscale / 16384.0;
+ m2 = component->u.b.scale01 / 16384.0;
+ m3 = 0;
+ m4 = component->u.b.scale10 / 16384.0;
+ m5 = component->u.b.yscale / 16384.0;
+ m6 = 0;
+ }
+ else /* No scale, just apply x_off and y_off. */
+ {
+ if (x_off || y_off)
+ {
+ for (i = 0; i < num_coordinates; ++i)
+ x[i] += x_off, y[i] += y_off;
+ }
+
+ return;
+ }
+
+ m3 = x_off;
+ m6 = y_off;
+
+ /* Apply the specified affine transformation.
+ A transform looks like:
+
+ M1 M2 M3 X
+ M4 M5 M6 * Y
+
+ =
+
+ M1*X + M2*Y + M3*1 = X1
+ M4*X + M5*Y + M6*1 = Y1
+
+ (In most transforms, there is another row at the bottom for
+ mathematical reasons. Since Z1 is always 1.0, the row is simply
+ implied to be 0 0 1, because 0 * x + 0 * y + 1 * 1 = 1.0. See
+ the definition of matrix3x3 in image.c for some more explanations
+ about this.) */
+
+ for (i = 0; i < num_coordinates; ++i)
+ {
+ x[i] = m1 * x[i] + m2 * y[i] + m3 * 1;
+ y[i] = m4 * x[i] + m5 * y[i] + m6 * 1;
+ }
+}
+
+/* Internal helper for sfnt_interpret_compound_glyph_3.
+
+ Instruct the compound glyph GLYPH using INTERPRETER after all of
+ its components have been instructed. Save the resulting points
+ within CONTEXT, and set its phantom point fields to match as well.
+
+ Use the unscaled METRICS to compute the phantom points of this
+ glyph.
+
+ CONTEXT contains the points and contours of this compound glyph,
+ numbered starting from BASE_INDEX and BASE_CONTOUR respectively.
+ In addition, CONTEXT also contains two additional ``phantom
+ points'' supplying the left and right side bearings of GLYPH.
+
+ S1 and S2 are the unrounded values of the last two phantom points,
+ which supply the original values saved into the glyph zone. In
+ practical terms, they are set as the last two values of the glyph
+ zone's original position array.
+
+ Value is NULL upon success, or a description of the error upon
+ failure. */
+
+static const char *
+sfnt_interpret_compound_glyph_2 (struct sfnt_glyph *glyph,
+ struct sfnt_interpreter *interpreter,
+ struct sfnt_compound_glyph_context *context,
+ size_t base_index, size_t base_contour,
+ struct sfnt_glyph_metrics *metrics,
+ sfnt_f26dot6 s1, sfnt_f26dot6 s2)
+{
+ size_t num_points, num_contours, i;
+ size_t zone_size, temp;
+ struct sfnt_interpreter_zone *zone;
+ struct sfnt_interpreter_zone *volatile preserved_zone;
+ volatile bool zone_was_allocated;
+ sfnt_f26dot6 *x_base, *y_base;
+
+ /* Figure out how many points and contours there are to instruct. A
+ minimum of two points must be present, namely: the origin and
+ advance phantom points. */
+ num_points = context->num_points - base_index;
+ num_contours = context->num_end_points - base_contour;
+ assert (num_points >= 2);
+
+ /* Nothing to instruct! */
+ if (!num_points && !num_contours)
+ return NULL;
+
+ /* Build the zone. First, calculate the size of the zone
+ structure. */
+
+ zone_size = 0;
+ zone_was_allocated = false;
+
+ if (ckd_mul (&temp, num_points + 2, sizeof *zone->x_points * 4)
+ || ckd_add (&zone_size, zone_size, temp)
+ || ckd_mul (&temp, num_contours, sizeof *zone->contour_end_points)
+ || ckd_add (&zone_size, zone_size, temp)
+ || ckd_mul (&temp, num_points + 2, sizeof *zone->flags)
+ || ckd_add (&zone_size, zone_size, temp)
+ || ckd_add (&zone_size, zone_size, sizeof *zone))
+ return "Glyph exceeded maximum permissible size";
+
+ /* Don't use malloc if possible. */
+
+ if (zone_size <= 1024 * 16)
+ zone = alloca (zone_size);
+ else
+ {
+ zone = xmalloc (zone_size);
+ zone_was_allocated = true;
+ }
+
+ /* Now load the zone with data. */
+ zone->num_points = num_points;
+ zone->num_contours = num_contours;
+ zone->contour_end_points = (size_t *) (zone + 1);
+ zone->x_points = (sfnt_f26dot6 *) (zone->contour_end_points
+ + zone->num_contours);
+ zone->x_current = zone->x_points + zone->num_points;
+ zone->y_points = zone->x_current + zone->num_points;
+ zone->y_current = zone->y_points + zone->num_points;
+ zone->flags = (unsigned char *) (zone->y_current
+ + zone->num_points);
+ zone->simple = NULL;
+
+ /* Copy and renumber all contour end points to start from
+ base_index. */
+
+ for (i = 0; i < zone->num_contours; ++i)
+ zone->contour_end_points[i]
+ = (context->contour_end_points[base_contour + i]
+ - base_index);
+
+ /* Now copy over x_points, x_current, y_points and y_current. */
+
+ for (i = 0; i < num_points; ++i)
+ {
+ zone->x_current[i] = context->x_coordinates[i + base_index];
+ zone->x_points[i] = context->x_coordinates[i + base_index];
+ }
+
+ for (i = 0; i < num_points; ++i)
+ {
+ zone->y_current[i] = context->y_coordinates[i + base_index];
+ zone->y_points[i] = context->y_coordinates[i + base_index];
+
+ /* Set flags. */
+ zone->flags[i] = (context->flags[i + base_index]
+ & ~SFNT_POINT_TOUCHED_BOTH);
+ }
+
+ /* Copy S1 and S2 into the glyph zone. */
+ assert (num_points >= 2);
+ zone->x_points[num_points - 1] = s2;
+ zone->x_points[num_points - 2] = s1;
+
+ /* Load the compound glyph program. */
+ interpreter->IP = 0;
+ interpreter->SP = interpreter->stack;
+ interpreter->instructions = glyph->compound->instructions;
+ interpreter->num_instructions = glyph->compound->instruction_length;
+ interpreter->glyph_zone = zone;
+
+ /* Copy zone over to this volatile variable. */
+ preserved_zone = zone;
+
+ if (setjmp (interpreter->trap))
+ {
+ if (zone_was_allocated)
+ xfree (preserved_zone);
+
+ interpreter->glyph_zone = NULL;
+ return interpreter->trap_reason;
+ }
+
+ sfnt_interpret_run (interpreter, SFNT_RUN_CONTEXT_GLYPH_PROGRAM);
+ interpreter->glyph_zone = NULL;
+
+ /* Move preserved_zone back to zone. */
+ zone = preserved_zone;
+
+ /* Now copy the instructed points back, and add the two phantom
+ points to the end. */
+
+ for (i = 0; i < num_points; ++i)
+ {
+ context->x_coordinates[base_index + i] = zone->x_current[i];
+ context->y_coordinates[base_index + i] = zone->y_current[i];
+ }
+
+ /* Return the phantom points after instructing completes to the
+ context's coordinate arrays. */
+ x_base = &context->x_coordinates[i - 2];
+ y_base = &context->y_coordinates[i - 2];
+ x_base[0] = zone->x_current[num_points - 2];
+ x_base[1] = zone->x_current[num_points - 1];
+ y_base[0] = zone->y_current[num_points - 2];
+ y_base[1] = zone->y_current[num_points - 1];
+ context->phantom_point_1_x = x_base[0];
+ context->phantom_point_1_y = y_base[0];
+ context->phantom_point_1_s = x_base[0];
+ context->phantom_point_2_x = x_base[1];
+ context->phantom_point_2_y = y_base[1];
+ context->phantom_point_2_s = x_base[1];
+
+ /* Free the zone if needed. */
+ if (zone_was_allocated)
+ xfree (zone);
+
+ return NULL;
+}
+
+/* Internal helper for sfnt_interpret_compound_glyph.
+ RECURSION_COUNT is the number of times this function has called itself.
+
+ METRICS are the unscaled metrics of this compound glyph.
+
+ Other arguments mean the same as they do in
+ `sfnt_interpret_compound_glyph'. Value is NULL upon success, or a
+ string describing the reason for failure. */
+
+static const char *
+sfnt_interpret_compound_glyph_1 (struct sfnt_glyph *glyph,
+ struct sfnt_interpreter *interpreter,
+ struct sfnt_graphics_state *state,
+ struct sfnt_compound_glyph_context *context,
+ sfnt_get_glyph_proc get_glyph,
+ sfnt_free_glyph_proc free_glyph,
+ struct sfnt_hmtx_table *hmtx,
+ struct sfnt_hhea_table *hhea,
+ struct sfnt_maxp_table *maxp,
+ struct sfnt_glyph_metrics *metrics,
+ int recursion_count,
+ void *dcontext)
+{
+ struct sfnt_glyph *subglyph;
+ int i, j, rc;
+ const char *error;
+ bool need_free;
+ struct sfnt_compound_glyph_component *component;
+ sfnt_f26dot6 x, y, xtemp, ytemp;
+ size_t point, point2;
+ size_t last_point, number_of_contours;
+ sfnt_f26dot6 *x_base, *y_base;
+ size_t *contour_base;
+ unsigned char *flags_base;
+ size_t base_index, contour_start, base_contour;
+ bool defer_offsets;
+ struct sfnt_instructed_outline *value;
+ struct sfnt_glyph_metrics sub_metrics;
+ sfnt_f26dot6 pp1x, pp1y, pp1s;
+ sfnt_f26dot6 pp2x, pp2y, pp2s;
+
+ error = NULL;
+
+ /* Set up the base index. This is the index from where on point
+ renumbering starts.
+
+ In other words, point 0 in this glyph will be 0 + base_index,
+ point 1 will be 1 + base_index, and so on. */
+ base_index = context->num_points;
+
+ /* And this is the index of the first contour in this glyph. */
+ base_contour = context->num_end_points;
+
+ /* Prevent infinite loops. Simply limit the level of nesting to the
+ maximum valid value of `max_component_depth', which is 16. */
+
+ if (recursion_count > 16)
+ return "Excessive recursion in compound glyph data";
+
+ /* Pacify -Wmaybe-uninitialized. */
+ point = point2 = 0;
+
+ /* Compute phantom points for this glyph here. They will be
+ subsequently overridden if a component glyph's metrics must be
+ used instead. */
+ sfnt_compute_phantom_points (glyph, metrics, interpreter->scale,
+ &context->phantom_point_1_x,
+ &context->phantom_point_1_y,
+ &context->phantom_point_2_x,
+ &context->phantom_point_2_y,
+ &context->phantom_point_1_s,
+ &context->phantom_point_2_s);
+
+ for (j = 0; j < glyph->compound->num_components; ++j)
+ {
+ /* Look up the associated subglyph. */
+ component = &glyph->compound->components[j];
+ subglyph = get_glyph (component->glyph_index,
+ dcontext, &need_free);
+
+ if (!subglyph)
+ return "Failed to obtain component glyph";
+
+ /* Don't defer offsets. This variable is set if the component
+ glyph is a compound glyph that is anchored to a previously
+ decomposed point, and needs its coordinates adjusted after
+ decomposition completes. */
+ defer_offsets = false;
+
+ /* Record the size of the point array before expansion. This
+ will be the base to apply to all points coming from this
+ subglyph. */
+ contour_start = context->num_points;
+
+ /* Compute the offset for the component. */
+ if (component->flags & 02) /* ARGS_ARE_XY_VALUES */
+ {
+ /* Component offsets are X/Y values as opposed to points
+ GLYPH. */
+
+ if (!(component->flags & 01)) /* ARG_1_AND_2_ARE_WORDS */
+ {
+ /* X and Y are signed bytes. */
+ x = component->argument1.b;
+ y = component->argument2.b;
+ }
+ else
+ {
+ /* X and Y are signed words. */
+ x = component->argument1.d;
+ y = component->argument2.d;
+ }
+
+ /* Now convert X and Y into device coordinates. */
+ x = sfnt_mul_f26dot6_fixed (x, interpreter->scale);
+ y = sfnt_mul_f26dot6_fixed (y, interpreter->scale);
+
+ /* If there is some kind of scale and component offsets are
+ scaled, then apply the transform to the offset. */
+ if (component->flags & 04000) /* SCALED_COMPONENT_OFFSET */
+ sfnt_transform_f26dot6 (component, &x, &y, 1,
+ 0, 0);
+
+ if (component->flags & 04) /* ROUND_XY_TO_GRID */
+ {
+ x = sfnt_round_f26dot6 (x);
+ y = sfnt_round_f26dot6 (y);
+ }
+ }
+ else
+ {
+ /* The offset is determined by matching a point location in
+ a preceding component with a point location in the
+ current component. The index of the point in the
+ previous component is established by adding
+ component->argument1.a or component->argument1.c to
+ point. argument2 contains the index of the point in the
+ current component. */
+
+ if (!(component->flags & 01)) /* ARG_1_AND_2_ARE_WORDS */
+ {
+ point = base_index + component->argument1.a;
+ point2 = component->argument2.a;
+ }
+ else
+ {
+ point = base_index + component->argument1.c;
+ point2 = component->argument2.c;
+ }
+
+ /* Now, check that the anchor point specified lies inside
+ the glyph. */
+
+ if (point >= contour_start)
+ {
+ if (need_free)
+ free_glyph (subglyph, dcontext);
+
+ return "Invalid anchor reference point";
+ }
+
+ if (!subglyph->compound)
+ {
+ /* Detect invalid child anchor points within simple
+ glyphs in advance. */
+
+ if (point2 >= subglyph->simple->number_of_points + 2)
+ {
+ if (need_free)
+ free_glyph (subglyph, dcontext);
+
+ return "Invalid component anchor point";
+ }
+ }
+
+ /* First, set offsets to 0, because it is not yet possible
+ to ascertain the position of the anchor point in the
+ child. That position cannot be established prior to the
+ completion of grid-fitting. */
+ x = 0;
+ y = 0;
+
+ /* Set a flag which indicates that offsets must be resolved
+ from the child glyph after it is loaded, but before it is
+ incorporated into the parent glyph. */
+ defer_offsets = true;
+ }
+
+ /* Obtain the glyph metrics. If doing so fails, then cancel
+ decomposition. */
+
+ if (sfnt_lookup_glyph_metrics (component->glyph_index,
+ &sub_metrics, hmtx, hhea,
+ maxp))
+ {
+ if (need_free)
+ free_glyph (subglyph, dcontext);
+
+ return "Failed to obtain component metrics";
+ }
+
+ if (subglyph->simple)
+ {
+ /* Simple subglyph. Copy over the points and contours,
+ then transform and instruct them.
+
+ Skip this step for glyphs without contours. */
+
+ if (subglyph->number_of_contours)
+ {
+ /* Now instruct the simple glyph, and copy it over,
+ including the two phantom points at the end. */
+ interpreter->state = *state;
+ error = sfnt_interpret_simple_glyph (subglyph, interpreter,
+ &sub_metrics, &value);
+
+ /* Cancel instructing if an error occurs. */
+
+ if (error)
+ {
+ if (need_free)
+ free_glyph (subglyph, dcontext);
+
+ return error;
+ }
+
+ /* Figure out how many more points and contours are
+ needed. While phantom points are not included within
+ the outline ultimately produced, they are temporarily
+ appended to the outline here, so as to enable
+ defer_offsets below to refer to them. */
+ assert (value->num_points >= 2);
+ last_point = value->num_points - 2;
+ number_of_contours = value->num_contours;
+
+ /* Grow various arrays. */
+ rc = sfnt_expand_compound_glyph_context (context,
+ /* Number of
+ new contours
+ required. */
+ number_of_contours,
+ /* Number of new
+ points
+ required. */
+ last_point,
+ &x_base,
+ &y_base,
+ &flags_base,
+ &contour_base);
+ if (rc)
+ {
+ xfree (value);
+
+ if (need_free)
+ free_glyph (subglyph, dcontext);
+
+ return "Failed to grow arrays";
+ }
+
+ /* Copy the values in VALUE into the context and free
+ VALUE, including phantom points. */
+
+ for (i = 0; i < last_point; ++i)
+ {
+ x_base[i] = value->x_points[i];
+ y_base[i] = value->y_points[i];
+ flags_base[i] = value->flags[i];
+ }
+
+ /* Copy over the contours. */
+ for (i = 0; i < number_of_contours; ++i)
+ contour_base[i] = (contour_start
+ + value->contour_end_points[i]);
+
+ /* Establish offsets for anchor points here. It is
+ possible for glyph anchors to be set to phantom
+ points, whose coordinates cannot be established until
+ grid fitting completes. */
+
+ if (defer_offsets)
+ {
+ x = 0;
+ y = 0;
+
+ /* Assert the child anchor is within the confines of
+ the zone. */
+ assert (point2 < value->num_points);
+
+ /* Get the points and use them to compute the
+ offsets. */
+
+ xtemp = context->x_coordinates[point];
+ ytemp = context->y_coordinates[point];
+ x = (xtemp - value->x_points[point2]);
+ y = (ytemp - value->y_points[point2]);
+ }
+
+ /* If USE_MY_METRICS is present in this component, save
+ the instructed phantom points inside CONTEXT.
+
+ N.B. such points replace even the unrounded points
+ within the context, as this distinction is lost in
+ phantom points sourced from instructed glyphs. */
+
+ if (component->flags & 01000) /* USE_MY_METRICS */
+ {
+ context->phantom_point_1_x
+ = context->phantom_point_1_s
+ = value->x_points[last_point];
+ context->phantom_point_1_y
+ = value->y_points[last_point];
+ context->phantom_point_2_x
+ = context->phantom_point_2_s
+ = value->x_points[last_point + 1];
+ context->phantom_point_2_y
+ = value->y_points[last_point + 1];
+ }
+
+ xfree (value);
+
+ /* Apply the transform to the points, excluding phantom
+ points within. */
+ sfnt_transform_f26dot6 (component, x_base, y_base,
+ last_point, x, y);
+ }
+ }
+ else
+ {
+ /* Compound subglyph. Decompose and instruct the glyph
+ recursively, and then apply the transform.
+
+ If USE_MY_METRICS is not set, save the phantom points
+ presently in CONTEXT, then restore them afterwards. */
+
+ pp1x = context->phantom_point_1_x;
+ pp1y = context->phantom_point_1_y;
+ pp1s = context->phantom_point_1_s;
+ pp2x = context->phantom_point_2_x;
+ pp2y = context->phantom_point_2_y;
+ pp2s = context->phantom_point_2_s;
+
+ error = sfnt_interpret_compound_glyph_1 (subglyph, interpreter,
+ state,
+ context, get_glyph,
+ free_glyph, hmtx, hhea,
+ maxp, &sub_metrics,
+ recursion_count + 1,
+ dcontext);
+
+ if (error)
+ {
+ if (need_free)
+ free_glyph (subglyph, dcontext);
+
+ return error;
+ }
+
+ if (!(component->flags & 01000)) /* USE_MY_METRICS */
+ {
+ context->phantom_point_1_x = pp1x;
+ context->phantom_point_1_y = pp1y;
+ context->phantom_point_1_s = pp1s;
+ context->phantom_point_2_x = pp2x;
+ context->phantom_point_2_y = pp2y;
+ context->phantom_point_2_s = pp2s;
+ }
+
+ /* Anchor points for glyphs with instructions must be
+ computed after grid fitting completes.
+
+ As such, the offset is calculated here, using the points
+ in the loaded child compound glyph. At present, CONTEXT
+ incorporates the two phantom points after the end of the
+ last component within SUBGLYPH. */
+
+ if (defer_offsets)
+ {
+ x = 0;
+ y = 0;
+
+ /* Renumber the non renumbered point2 to point into the
+ decomposed component. */
+ point2 += contour_start;
+
+ /* Next, check that the non-renumbered point being
+ anchored lies inside the glyph data that was
+ decomposed. */
+
+ if (point2 >= context->num_points)
+ {
+ if (need_free)
+ free_glyph (subglyph, dcontext);
+
+ return "Invalid anchor reference point";
+ }
+
+ /* Get the points and use them to compute the
+ offsets. */
+
+ xtemp = context->x_coordinates[point];
+ ytemp = context->y_coordinates[point];
+ x = (xtemp - context->x_coordinates[point2]);
+ y = (ytemp - context->y_coordinates[point2]);
+ }
+
+ /* Subtract the two phantom points from context->num_points.
+ This behavior is correct, as only the subglyph's phantom
+ points may be provided as anchor points. */
+ assert (context->num_points - contour_start >= 2);
+ context->num_points -= 2;
+
+ sfnt_transform_f26dot6 (component,
+ context->x_coordinates + contour_start,
+ context->y_coordinates + contour_start,
+ /* Exclude phantom points from
+ transformations. */
+ context->num_points - contour_start,
+ x, y);
+ }
+
+ /* Finally, free the subglyph. */
+ if (need_free)
+ free_glyph (subglyph, dcontext);
+ }
+
+ /* Run the program for the entire compound glyph, if any. CONTEXT
+ should not contain phantom points by this point, so append the
+ points for this glyph as a whole. */
+
+ /* Grow various arrays to include those points. */
+ rc = sfnt_expand_compound_glyph_context (context,
+ /* Number of new contours
+ required. */
+ 0,
+ /* Number of new points
+ required. */
+ 2,
+ &x_base, &y_base,
+ &flags_base, &contour_base);
+
+ /* Store the phantom points within the compound glyph. */
+ x_base[0] = context->phantom_point_1_x;
+ x_base[1] = context->phantom_point_2_x;
+ y_base[0] = context->phantom_point_1_y;
+ y_base[1] = context->phantom_point_2_y;
+ flags_base[0] = SFNT_POINT_PHANTOM;
+ flags_base[1] = SFNT_POINT_PHANTOM;
+
+ if (glyph->compound->instruction_length)
+ {
+ interpreter->state = *state;
+ error = sfnt_interpret_compound_glyph_2 (glyph, interpreter,
+ context, base_index,
+ base_contour,
+ metrics,
+ context->phantom_point_1_s,
+ context->phantom_point_2_s);
+ }
+
+ return error;
+}
+
+/* Interpret the compound glyph GLYPH using the specified INTERPRETER.
+ Load each component of the compound glyph GLYPH. CONTEXT should be
+ a reference to a `struct sfnt_compound_glyph_context' that is on
+ the stack.
+
+ Use glyph metrics specified in the HMTX, HHEA and MAXP tables, and
+ the unscaled metrics for GLYPH specified in METRICS.
+
+ If the component is a simple glyph, scale and instruct it
+ immediately.
+
+ If the component is a compound glyph, then load it recursively
+ until a predetermined recursion level is exceeded.
+
+ Set INTERPRETER's state to STATE prior to instructing each
+ component.
+
+ Load component glyphs using GET_GLYPH, which should return whether
+ or not FREE_GLYPH should be called with the glyph that was loaded.
+ Call both functions with DCONTEXT as an argument.
+
+ Finally, append the resulting contours, run any compound glyph
+ program, and return the instructed outline in *VALUE.
+
+ Value is NULL upon success, and the type of error upon failure. */
+
+TEST_STATIC const char *
+sfnt_interpret_compound_glyph (struct sfnt_glyph *glyph,
+ struct sfnt_interpreter *interpreter,
+ struct sfnt_graphics_state *state,
+ sfnt_get_glyph_proc get_glyph,
+ sfnt_free_glyph_proc free_glyph,
+ struct sfnt_hmtx_table *hmtx,
+ struct sfnt_hhea_table *hhea,
+ struct sfnt_maxp_table *maxp,
+ struct sfnt_glyph_metrics *metrics,
+ void *dcontext,
+ struct sfnt_instructed_outline **value)
+{
+ struct sfnt_compound_glyph_context context;
+ const char *error;
+ struct sfnt_instructed_outline *outline;
+ size_t outline_size, temp;
+
+ /* Set up the glyph decomposition context. */
+ memset (&context, 0, sizeof context);
+
+ /* Now start decomposing the glyph. */
+ error = sfnt_interpret_compound_glyph_1 (glyph, interpreter,
+ state, &context,
+ get_glyph, free_glyph,
+ hmtx, hhea, maxp,
+ metrics, 0, dcontext);
+
+ /* If an error occurs, free the data in the context and return. */
+
+ if (error)
+ {
+ xfree (context.x_coordinates);
+ xfree (context.y_coordinates);
+ xfree (context.flags);
+ xfree (context.contour_end_points);
+ return error;
+ }
+
+ /* Copy the compound glyph data into an instructed outline. */
+ outline_size = sizeof (*outline);
+
+ if (ckd_mul (&temp, context.num_end_points,
+ sizeof *outline->contour_end_points)
+ || ckd_add (&outline_size, outline_size, temp)
+ || ckd_mul (&temp, context.num_points, sizeof *outline->x_points * 2)
+ || ckd_add (&outline_size, outline_size, temp)
+ || ckd_add (&outline_size, outline_size, context.num_points))
+ {
+ xfree (context.x_coordinates);
+ xfree (context.y_coordinates);
+ xfree (context.flags);
+ xfree (context.contour_end_points);
+ return "Glyph exceeds maximum permissible size";
+ }
+
+ /* Allocate the outline. */
+ outline = xmalloc (outline_size);
+ outline->num_points = context.num_points;
+ outline->num_contours = context.num_end_points;
+ outline->contour_end_points = (size_t *) (outline + 1);
+ outline->x_points = (sfnt_f26dot6 *) (outline->contour_end_points
+ + outline->num_contours);
+ outline->y_points = outline->x_points + outline->num_points;
+ outline->flags = (unsigned char *) (outline->y_points
+ + outline->num_points);
+
+ /* Copy over the contour endpoints, points, and flags. Note that
+ all arrays in `context' are NULL unless num_contours is
+ non-zero. */
+
+ if (context.num_end_points)
+ memcpy (outline->contour_end_points, context.contour_end_points,
+ outline->num_contours * sizeof *outline->contour_end_points);
+
+ if (context.num_points)
+ {
+ memcpy (outline->x_points, context.x_coordinates,
+ outline->num_points * sizeof *outline->x_points);
+ memcpy (outline->y_points, context.y_coordinates,
+ outline->num_points * sizeof *outline->y_points);
+ memcpy (outline->flags, context.flags, context.num_points);
+ }
+
+ /* Free the context data. */
+ xfree (context.x_coordinates);
+ xfree (context.y_coordinates);
+ xfree (context.flags);
+ xfree (context.contour_end_points);
+
+ *value = outline;
+ return NULL;
+}
+
+
+
+
+/* Unicode Variation Sequence (UVS) support.
+
+ Unicode defines a mechanism by which two-codepoint sequences
+ comprising a ``base character'' and ``variation selector'' combine
+ to produce a glyph besides that which is mapped to the ``base
+ character'' itself.
+
+ TrueType stores variation selector sequences inside a special type
+ of character mapping table that is given the format 14. The
+ character mapping table consists of an array of variation
+ selectors, each of which is assigned a ``default UVS table''
+ recording ranges of ``base characters'' absent special variant
+ glyphs, and a ``non-default UVS table'', linking ``base
+ characters'' to their respective variant glyphs.
+
+ Unicode variation selectors occupy the range formed between 0xfe00
+ and 0xfe0f, along with that from 0xe0100 to 0xe01ef, within the
+ Unicode codespace. When a variation selector is encountered as
+ text is being examined for display with a particular font, that
+ font's character mapping table is indexed by it, yielding a default
+ and non-default UVS table. If the base character (which is
+ directly behind the variation selector) is subsequently located
+ within the default UVS table, then the glyph represented by this
+ union of base character and variation selector is that designated
+ by the base character within any UCS-4 or BMP character mapping
+ table in the font. Since this glyph is at variance with that
+ derived from the base character only when the character set of the
+ character mapping table otherwise consulted is not UCS-4 or BMP,
+ the distinction between those two glyphs is largely notional.
+ Should the nondefault UVS table hold the base character, then the
+ glyph is conversely that enumerated in said table, whose indexing
+ is facilitated by sfnt_variation_glyph_for_char. And if the base
+ character isn't present within either table or the tables for the
+ variation selector are absent in the first place, then the two
+ codepoints constituting the sequence are immiscible and therefore
+ the sequence cannot apply to the font.
+
+ The approach taken by Emacs character composition routines is
+ diametric to the approach illustrated above: in place of searching
+ for variation glyphs each time a variation selector character is
+ encountered, these routines ascertain which glyphs are linked to
+ each base character that they have adjudged subject to variation in
+ advance. See sfntfont_get_variation_glyphs. */
+
+/* Read a default UVS table from the font file FD, at the specified
+ OFFSET. Value is the default UVS table upon success, else
+ NULL. */
+
+static struct sfnt_default_uvs_table *
+sfnt_read_default_uvs_table (int fd, off_t offset)
+{
+ struct sfnt_default_uvs_table *uvs;
+ uint32_t num_ranges, i, j;
+ ssize_t size, temp;
+ char data[512];
+
+ /* First, seek to the given offset. */
+
+ if (lseek (fd, offset, SEEK_SET) != offset)
+ return NULL;
+
+ /* Next, read the number of ranges present. */
+
+ if (read (fd, &num_ranges, sizeof num_ranges)
+ != (int) sizeof num_ranges)
+ return NULL;
+
+ /* Swap the number of ranges present. */
+ sfnt_swap32 (&num_ranges);
+
+ /* Now, allocate enough to hold the UVS table. */
+
+ size = sizeof *uvs;
+ if (ckd_mul (&temp, num_ranges, sizeof *uvs->ranges)
+ || ckd_add (&size, size, temp))
+ return NULL;
+
+ uvs = xmalloc (size);
+
+ /* Fill in the data which was already read. */
+ uvs->num_unicode_value_ranges = num_ranges;
+
+ /* Fill in the pointer to the ranges. */
+ uvs->ranges = (struct sfnt_unicode_value_range *) (uvs + 1);
+ i = 0;
+
+ /* Read each default UVS range in multiples of 512 bytes. Then,
+ fill in uvs->ranges. */
+
+ while (num_ranges)
+ {
+ size = (num_ranges > 128 ? 512 : num_ranges * 4);
+
+ if (read (fd, data, size) != size)
+ {
+ xfree (uvs);
+ return NULL;
+ }
+
+ for (j = 0; j < size / 4; ++j)
+ {
+ uvs->ranges[i + j].start_unicode_value
+ = sfnt_read_24 ((unsigned char *) data + j * 4);
+ uvs->ranges[i + j].additional_count = data[j * 4 + 1];
+ }
+
+ i += j;
+ num_ranges -= size / 4;
+ }
+
+ /* Return the resulting default UVS table. */
+ return uvs;
+}
+
+/* Read a non-default UVS table from the font file FD, at the
+ specified OFFSET. Value is the non-default UVS table upon success,
+ else NULL. */
+
+static struct sfnt_nondefault_uvs_table *
+sfnt_read_nondefault_uvs_table (int fd, off_t offset)
+{
+ struct sfnt_nondefault_uvs_table *uvs;
+ uint32_t num_mappings, i, j;
+ ssize_t size, temp;
+ char data[500];
+
+ /* First, seek to the given offset. */
+
+ if (lseek (fd, offset, SEEK_SET) != offset)
+ return NULL;
+
+ /* Next, read the number of mappings present. */
+
+ if (read (fd, &num_mappings, sizeof num_mappings)
+ != sizeof num_mappings)
+ return NULL;
+
+ /* Swap the number of mappings present. */
+ sfnt_swap32 (&num_mappings);
+
+ /* Now, allocate enough to hold the UVS table. */
+
+ size = sizeof *uvs;
+ if (ckd_mul (&temp, num_mappings, sizeof *uvs->mappings)
+ || ckd_add (&size, size, temp))
+ return NULL;
+
+ uvs = xmalloc (size);
+
+ /* Fill in the data which was already read. */
+ uvs->num_uvs_mappings = num_mappings;
+
+ /* Fill in the pointer to the mappings. */
+ uvs->mappings = (struct sfnt_uvs_mapping *) (uvs + 1);
+
+ i = 0;
+
+ /* Read each nondefault UVS mapping in multiples of 500 bytes.
+ Then, fill in uvs->ranges. */
+
+ while (num_mappings)
+ {
+ size = (num_mappings > 100 ? 500 : num_mappings * 5);
+
+ if (read (fd, data, size) != size)
+ {
+ xfree (uvs);
+ return NULL;
+ }
+
+ for (j = 0; j < size / 5; ++j)
+ {
+ uvs->mappings[i + j].unicode_value
+ = sfnt_read_24 ((unsigned char *) data + j * 5);
+ memcpy (&uvs->mappings[i + j].base_character_value,
+ data + j * 5 + 3,
+ sizeof uvs->mappings[i + j].base_character_value);
+ sfnt_swap16 (&uvs->mappings[i + j].base_character_value);
+ }
+
+ i += j;
+ num_mappings -= size / 5;
+ }
+
+ /* Return the nondefault UVS table. */
+ return uvs;
+}
+
+/* Perform comparison of A and B, two table offsets. */
+
+static int
+sfnt_compare_table_offsets (const void *a, const void *b)
+{
+ const struct sfnt_table_offset_rec *rec_a, *rec_b;
+
+ rec_a = a;
+ rec_b = b;
+
+ if (rec_a->offset < rec_b->offset)
+ return -1;
+ else if (rec_a->offset > rec_b->offset)
+ return 1;
+
+ return 0;
+}
+
+/* Create a variation selection context based on the format 14 cmap
+ subtable CMAP.
+
+ FD is the font file to which the table belongs.
+
+ Value is the variation selection context upon success, else NULL.
+ The context contains each variation selector record and their
+ associated default and nondefault UVS tables. Free the context
+ with `sfnt_free_uvs_context'. */
+
+TEST_STATIC struct sfnt_uvs_context *
+sfnt_create_uvs_context (struct sfnt_cmap_format_14 *cmap, int fd)
+{
+ struct sfnt_table_offset_rec *table_offsets, *rec, template;
+ size_t size, i, nmemb, j;
+ off_t offset;
+ struct sfnt_uvs_context *context;
+
+ if (ckd_mul (&size, cmap->num_var_selector_records,
+ sizeof *table_offsets)
+ || ckd_mul (&size, size, 2))
+ return NULL;
+
+ context = NULL;
+
+ /* First, record and sort the UVS and nondefault UVS table offsets
+ in ascending order. */
+
+ table_offsets = xmalloc (size);
+ memset (table_offsets, 0, size);
+ nmemb = cmap->num_var_selector_records * 2;
+ j = 0;
+
+ for (i = 0; i < cmap->num_var_selector_records; ++i)
+ {
+ /* Note that either offset may be 0, meaning there is no such
+ table. */
+
+ if (cmap->records[i].default_uvs_offset)
+ {
+ if (ckd_add (&table_offsets[j].offset, cmap->offset,
+ cmap->records[i].default_uvs_offset))
+ goto bail;
+
+ table_offsets[j++].is_nondefault_table = false;
+ }
+
+ if (cmap->records[i].nondefault_uvs_offset)
+ {
+ if (ckd_add (&table_offsets[j].offset, cmap->offset,
+ cmap->records[i].nondefault_uvs_offset))
+ goto bail;
+
+ table_offsets[j++].is_nondefault_table = true;
+ }
+ }
+
+ /* Make nmemb the number of offsets actually looked up. */
+ nmemb = j;
+
+ qsort (table_offsets, nmemb, sizeof *table_offsets,
+ sfnt_compare_table_offsets);
+
+ /* Now go through table_offsets, and read everything. nmemb is the
+ number of elements in table_offsets[i]; it is kept up to date
+ when duplicate members are removed. */
+ offset = -1;
+
+ for (i = 0; i < nmemb; ++i)
+ {
+ /* Skip past duplicate tables. */
+
+ while (table_offsets[i].offset == offset && i < nmemb)
+ {
+ nmemb--;
+ table_offsets[i] = table_offsets[i + 1];
+ }
+
+ /* If the last element of the array is a duplicate, break out of
+ the loop. */
+
+ if (i == nmemb)
+ break;
+
+ /* Read the correct type of table depending on
+ table_offsets[i].is_nondefault_table. Then skip past
+ duplicate tables. Don't handle the case where two different
+ kind of tables share the same offset, because that is not
+ possible in a valid variation selector record. */
+
+ offset = table_offsets[i].offset;
+
+ if (table_offsets[i].is_nondefault_table)
+ table_offsets[i].table
+ = sfnt_read_nondefault_uvs_table (fd, offset);
+ else
+ table_offsets[i].table
+ = sfnt_read_default_uvs_table (fd, offset);
+ }
+
+ /* Now make the context. */
+ context = xmalloc (sizeof *context);
+ context->num_records = cmap->num_var_selector_records;
+ context->nmemb = nmemb;
+ context->records = xmalloc (sizeof *context->records
+ * cmap->num_var_selector_records);
+
+ for (i = 0; i < cmap->num_var_selector_records; ++i)
+ {
+ context->records[i].selector = cmap->records[i].var_selector;
+
+ /* Either offset may be 0, meaning no such table exists. Also,
+ the code below will lose if more than one kind of table
+ shares the same offset, because that is impossible. */
+
+ if (cmap->records[i].default_uvs_offset)
+ {
+ /* Resolve the default table. */
+ template.offset = (cmap->records[i].default_uvs_offset
+ + cmap->offset);
+ rec = bsearch (&template, table_offsets,
+ nmemb, sizeof *table_offsets,
+ sfnt_compare_table_offsets);
+
+ /* Make sure this record is the right type. */
+ if (!rec || rec->is_nondefault_table || !rec->table)
+ goto bail;
+
+ context->records[i].default_uvs = rec->table;
+ }
+ else
+ context->records[i].default_uvs = NULL;
+
+ if (cmap->records[i].nondefault_uvs_offset)
+ {
+ /* Resolve the nondefault table. */
+ template.offset = (cmap->records[i].nondefault_uvs_offset
+ + cmap->offset);
+ rec = bsearch (&template, table_offsets,
+ nmemb, sizeof *table_offsets,
+ sfnt_compare_table_offsets);
+
+ if (!rec)
+ goto bail;
+
+ /* Make sure this record is the right type. */
+ if (!rec || !rec->is_nondefault_table || !rec->table)
+ goto bail;
+
+ context->records[i].nondefault_uvs = rec->table;
+ }
+ else
+ context->records[i].nondefault_uvs = NULL;
+ }
+
+ context->tables = table_offsets;
+ return context;
+
+ bail:
+
+ if (context)
+ {
+ xfree (context->records);
+ xfree (context);
+ }
+
+ /* Loop through and free any tables that might have been read
+ already. */
+
+ for (i = 0; i < nmemb; ++i)
+ xfree (table_offsets[i].table);
+
+ xfree (table_offsets);
+ return NULL;
+}
+
+/* Free the specified variation selection context C. */
+
+TEST_STATIC void
+sfnt_free_uvs_context (struct sfnt_uvs_context *c)
+{
+ size_t i;
+
+ xfree (c->records);
+
+ for (i = 0; i < c->nmemb; ++i)
+ xfree (c->tables[i].table);
+
+ xfree (c->tables);
+ xfree (c);
+}
+
+/* Compare *(sfnt_char *) K to ((struct sfnt_uvs_mapping *)
+ V)->unicode_value appropriately for bsearch. */
+
+static int
+sfnt_compare_uvs_mapping (const void *k, const void *v)
+{
+ const sfnt_char *key;
+ const struct sfnt_uvs_mapping *value;
+
+ key = k;
+ value = v;
+
+ if (*key < value->unicode_value)
+ return -1;
+ else if (*key == value->unicode_value)
+ return 0;
+
+ return 1;
+}
+
+/* Compare *(sfnt_char *) K to the Unicode value range V. */
+
+static int
+sfnt_compare_unicode_value_range (const void *k, const void *v)
+{
+ const sfnt_char *key;
+ const struct sfnt_unicode_value_range *value;
+
+ key = k;
+ value = v;
+
+ if (*key < value->start_unicode_value)
+ return -1;
+ else if ((*key - value->start_unicode_value
+ <= value->additional_count))
+ return 0;
+
+ return 1;
+}
+
+/* Return the ID of a variation glyph for the character C in the
+ nondefault UVS mapping table UVS.
+
+ Value is the glyph ID upon success, or 0 if there is no variation
+ glyph for the base character C. */
+
+TEST_STATIC sfnt_glyph
+sfnt_variation_glyph_for_char (struct sfnt_nondefault_uvs_table *uvs,
+ sfnt_char c)
+{
+ struct sfnt_uvs_mapping *mapping;
+
+ mapping = bsearch (&c, uvs->mappings, uvs->num_uvs_mappings,
+ sizeof *uvs->mappings,
+ sfnt_compare_uvs_mapping);
+
+ return mapping ? mapping->base_character_value : 0;
+}
+
+/* Return whether the character C is present in the default UVS
+ mapping table UVS. */
+
+TEST_STATIC bool
+sfnt_is_character_default (struct sfnt_default_uvs_table *uvs,
+ sfnt_char c)
+{
+ /* UVS->ranges comprises ranges of characters sorted in increasing
+ order; these ranges cannot overlap. */
+
+ return (bsearch (&c, uvs->ranges, uvs->num_unicode_value_ranges,
+ sizeof *uvs->ranges,
+ sfnt_compare_unicode_value_range) != NULL);
+}
+
+
+
+#if defined HAVE_MMAP && !defined TEST
+
+/* Memory mapping support.
+ It useful to map OpenType layout tables prior to using them in
+ an external shaping engine such as HarfBuzz. */
+
+/* Map a table identified by TAG into the structure *TABLE.
+ TAG is swapped into host byte order.
+
+ Use the table directory SUBTABLE, which corresponds to the font
+ file FD.
+
+ Return 0 upon success, and set TABLE->data to the table data,
+ TABLE->mapping to the start of the mapped area, TABLE->length to
+ the length of the table contents, and TABLE->size to the size of
+ the mapping.
+
+ Return 1 upon failure. */
+
+int
+sfnt_map_table (int fd, struct sfnt_offset_subtable *subtable,
+ uint32_t tag, struct sfnt_mapped_table *table)
+{
+ struct sfnt_table_directory *directory;
+ size_t offset, page, map_offset;
+ void *data;
+ int i;
+
+ /* Find the table in the directory. */
+
+ for (i = 0; i < subtable->num_tables; ++i)
+ {
+ if (subtable->subtables[i].tag == tag)
+ {
+ directory = &subtable->subtables[i];
+ break;
+ }
+ }
+
+ if (i == subtable->num_tables)
+ return 1;
+
+ /* Now try to map the glyph data. Make sure offset is a multiple of
+ the page size. */
+
+ page = getpagesize ();
+ offset = directory->offset & ~(page - 1);
+
+ /* Figure out how much larger the mapping should be. */
+ map_offset = directory->offset - offset;
+
+ /* Do the mmap. */
+ data = mmap (NULL, directory->length + map_offset,
+ PROT_READ, MAP_PRIVATE, fd, offset);
+
+ if (data == MAP_FAILED)
+ return 1;
+
+ /* Fill in *TABLE. */
+ table->data = (unsigned char *) data + map_offset;
+ table->mapping = data;
+ table->length = directory->length;
+ table->size = directory->length + map_offset;
+ return 0;
+}
+
+/* Unmap the table inside *TABLE.
+ Value is 0 upon success, 1 otherwise. */
+
+int
+sfnt_unmap_table (struct sfnt_mapped_table *table)
+{
+ return munmap (table->mapping, table->size) != 0;
+}
+
+#endif /* HAVE_MMAP && !TEST */
+
+
+
+#ifndef TEST
+
+/* Reading table contents. */
+
+/* Read the table with the specified TAG from the font file FD.
+ Return its length in *LENGTH, and its data upon success, else
+ NULL. */
+
+void *
+sfnt_read_table (int fd, struct sfnt_offset_subtable *subtable,
+ uint32_t tag, size_t *length)
+{
+ struct sfnt_table_directory *directory;
+ void *data;
+ int i;
+
+ /* Find the table in the directory. */
+
+ for (i = 0; i < subtable->num_tables; ++i)
+ {
+ if (subtable->subtables[i].tag == tag)
+ {
+ directory = &subtable->subtables[i];
+ break;
+ }
+ }
+
+ if (i == subtable->num_tables)
+ return NULL;
+
+ /* Seek to the table. */
+
+ if (lseek (fd, directory->offset, SEEK_SET) != directory->offset)
+ return NULL;
+
+ /* Now allocate enough to hold the data and read into it. */
+
+ data = xmalloc (directory->length);
+ if (read (fd, data, directory->length) != directory->length)
+ {
+ xfree (data);
+ return NULL;
+ }
+
+ /* Return the length and table data. */
+ *length = directory->length;
+ return data;
+}
+
+#endif /* !TEST */
+
+
+
+/* Glyph variations. Instead of defining separate fonts for each
+ combination of weight, width and slant (bold, condensed, italic,
+ etc), some fonts specify a list of ``variation axes'', which are
+ options that accept values consisting of numbers on scales
+ governing deltas applied to select points in their glyphs.
+
+ Particular styles within the font are then supplied as sets of
+ values on these scales to which their respective axes are set,
+ termed ``instances''.
+
+ This optional information is specified in the `fvar' (font
+ variation), `gvar' (glyph variation) and `cvar' (CVT variation)
+ tables in a font file. */
+
+/* Read an fvar table from the given font FD. Use the table directory
+ specified in SUBTABLE.
+
+ Return the fvar table upon success, else NULL. */
+
+TEST_STATIC struct sfnt_fvar_table *
+sfnt_read_fvar_table (int fd, struct sfnt_offset_subtable *subtable)
+{
+ struct sfnt_table_directory *directory;
+ struct sfnt_fvar_table *fvar;
+ ssize_t rc;
+ size_t min_bytes, ps_size, non_ps_size, temp, pad;
+ off_t offset;
+ int i, j;
+ char *buffer;
+ sfnt_fixed *coords;
+
+ /* Find the table in the directory. */
+
+ directory = sfnt_find_table (subtable, SFNT_TABLE_FVAR);
+
+ if (!directory)
+ return NULL;
+
+ min_bytes = SFNT_ENDOF (struct sfnt_fvar_table,
+ instance_size, uint16_t);
+
+ /* Check that the length is at least min_bytes. */
+ if (directory->length < min_bytes)
+ return NULL;
+
+ /* Seek to the location given in the directory. */
+ if (lseek (fd, directory->offset, SEEK_SET) == (off_t) -1)
+ return NULL;
+
+ /* Allocate enough to hold the fvar table header. */
+ fvar = xmalloc (sizeof *fvar);
+
+ /* Read the fvar table header. */
+ buffer = NULL;
+ rc = read (fd, fvar, min_bytes);
+ if (rc == -1 || rc != min_bytes)
+ goto bail;
+
+ /* Swap what was read. */
+ sfnt_swap16 (&fvar->major_version);
+ sfnt_swap16 (&fvar->minor_version);
+ sfnt_swap16 (&fvar->offset_to_data);
+ sfnt_swap16 (&fvar->count_size_pairs);
+ sfnt_swap16 (&fvar->axis_count);
+ sfnt_swap16 (&fvar->axis_size);
+ sfnt_swap16 (&fvar->instance_count);
+ sfnt_swap16 (&fvar->instance_size);
+
+ /* major_version should be 1, and minor_version 0. */
+
+ if (fvar->major_version != 1 || fvar->minor_version)
+ goto bail;
+
+ /* count_size_pairs should be more than 2. */
+
+ if (fvar->count_size_pairs < 2)
+ goto bail;
+
+ /* Don't try to read tables where the axis format differs. */
+
+ if (fvar->axis_size != 20)
+ goto bail;
+
+ /* The instance size must either be 2 * sizeof (uint16_t) +
+ axisCount * sizeof (sfnt_fixed), meaning there is no PostScript
+ name identifier, or 3 * sizeof (uint16_t) + axisCount * sizeof
+ (sfnt_fixed), meaning there is. */
+
+ if (ckd_mul (&temp, fvar->axis_count, sizeof (sfnt_fixed))
+ || ckd_add (&non_ps_size, temp, 2 * sizeof (uint16_t)))
+ goto bail;
+
+ if (ckd_mul (&temp, fvar->axis_count, sizeof (sfnt_fixed))
+ || ckd_add (&ps_size, temp, 3 * sizeof (uint16_t)))
+ goto bail;
+
+ if (fvar->instance_size != non_ps_size
+ && fvar->instance_size != ps_size)
+ goto bail;
+
+ /* Now compute the offset of the axis data from the start of the
+ font file. */
+
+ if (ckd_add (&offset, fvar->offset_to_data, directory->offset))
+ goto bail;
+
+ /* Seek there. */
+
+ if (lseek (fd, offset, SEEK_SET) != offset)
+ goto bail;
+
+ min_bytes = sizeof *fvar;
+
+ /* Now, read each axis and instance. Calculate how much extra data
+ needs to be allocated for the axes and instances: this is
+ fvar->axis_count * sizeof (struct sfnt_variation_axis), some
+ padding, and finally fvar->instance_count * sizeof (struct
+ sfnt_instance) + sizeof (sfnt_fixed) * fvar->instance_count *
+ fvar->axis_count. */
+
+ if (ckd_mul (&temp, fvar->axis_count, sizeof *fvar->axis)
+ || ckd_add (&min_bytes, min_bytes, temp))
+ goto bail;
+
+ pad = alignof (struct sfnt_instance);
+ pad -= min_bytes & (pad - 1);
+
+ if (ckd_add (&min_bytes, min_bytes, pad))
+ goto bail;
+
+ if (ckd_mul (&temp, fvar->instance_count, sizeof *fvar->instance)
+ || ckd_add (&min_bytes, min_bytes, temp))
+ goto bail;
+
+ if (ckd_mul (&temp, fvar->instance_count, sizeof *fvar->instance->coords)
+ || ckd_mul (&temp, temp, fvar->axis_count)
+ || ckd_add (&min_bytes, min_bytes, temp))
+ goto bail;
+
+ /* Reallocate fvar. */
+ fvar = xrealloc (fvar, min_bytes);
+
+ /* Fill in offsets. */
+ fvar->axis = (struct sfnt_variation_axis *) (fvar + 1);
+ fvar->instance
+ = (struct sfnt_instance *) (((char *) (fvar->axis
+ + fvar->axis_count))
+ + pad);
+
+ /* Read axes. */
+
+ if (directory->length - SFNT_ENDOF (struct sfnt_fvar_table,
+ instance_size, uint16_t)
+ < sizeof *fvar->axis * fvar->axis_count)
+ goto bail;
+
+ rc = read (fd, fvar->axis, sizeof *fvar->axis * fvar->axis_count);
+ if (rc == -1 || rc != sizeof *fvar->axis * fvar->axis_count)
+ goto bail;
+
+ /* Swap each axis. */
+
+ for (i = 0; i < fvar->axis_count; ++i)
+ {
+ sfnt_swap32 (&fvar->axis[i].axis_tag);
+ sfnt_swap32 (&fvar->axis[i].min_value);
+ sfnt_swap32 (&fvar->axis[i].default_value);
+ sfnt_swap32 (&fvar->axis[i].max_value);
+ sfnt_swap16 (&fvar->axis[i].flags);
+ sfnt_swap16 (&fvar->axis[i].name_id);
+ }
+
+ /* Read each instance. */
+
+ if (fvar->instance_size < 1024 * 16)
+ buffer = alloca (fvar->instance_size);
+ else
+ buffer = xmalloc (fvar->instance_size);
+
+ coords = (sfnt_fixed *) (fvar->instance + fvar->instance_count);
+
+ for (i = 0; i < fvar->instance_count; ++i)
+ {
+ rc = read (fd, buffer, fvar->instance_size);
+ if (rc != fvar->instance_size)
+ goto bail;
+
+ /* Fill in various fields. */
+
+ fvar->instance[i].name_id = *((uint16_t *) buffer);
+ fvar->instance[i].flags = *((uint16_t *) buffer + 1);
+ fvar->instance[i].ps_name_id = 0;
+
+ sfnt_swap16 (&fvar->instance[i].name_id);
+ sfnt_swap16 (&fvar->instance[i].flags);
+
+ /* Read coordinates. */
+
+ fvar->instance[i].coords = coords;
+ coords += fvar->axis_count;
+
+ memcpy (fvar->instance[i].coords, buffer + 4,
+ sizeof *fvar->instance[i].coords * fvar->axis_count);
+
+ /* Swap coordinates. */
+
+ for (j = 0; j < fvar->axis_count; ++j)
+ sfnt_swap32 (&fvar->instance[i].coords[j]);
+
+ /* Read the PostScript name ID if necessary. If not, set it to
+ nil. */
+
+ if (fvar->instance_size == ps_size)
+ {
+ fvar->instance[i].ps_name_id
+ = *(uint16_t *) (buffer + 4 + (sizeof *fvar->instance[i].coords
+ * fvar->axis_count));
+ sfnt_swap16 (&fvar->instance[i].ps_name_id);
+ }
+ }
+
+ /* Free the temporary buffer. */
+ if (buffer && fvar->instance_size >= 1024 * 16)
+ xfree (buffer);
+
+ /* Return the fvar table. */
+ return fvar;
+
+ bail:
+ if (buffer && fvar->instance_size >= 1024 * 16)
+ xfree (buffer);
+
+ xfree (fvar);
+ return NULL;
+}
+
+
+
+/* Read a gvar table from the given font FD. Use the table directory
+ specified in SUBTABLE.
+
+ Return the gvar table upon success, else NULL. */
+
+TEST_STATIC struct sfnt_gvar_table *
+sfnt_read_gvar_table (int fd, struct sfnt_offset_subtable *subtable)
+{
+ struct sfnt_table_directory *directory;
+ struct sfnt_gvar_table *gvar;
+ ssize_t rc;
+ size_t min_bytes, off_size, coordinate_size, data_size;
+ int i;
+ off_t offset;
+
+ /* Find the table in the directory. */
+
+ directory = sfnt_find_table (subtable, SFNT_TABLE_GVAR);
+
+ if (!directory)
+ return NULL;
+
+ min_bytes = SFNT_ENDOF (struct sfnt_gvar_table,
+ offset_to_data, uint32_t);
+
+ /* Check that the length is at least min_bytes. */
+ if (directory->length < min_bytes)
+ return NULL;
+
+ /* Seek to the location given in the directory. */
+ if (lseek (fd, directory->offset, SEEK_SET) == (off_t) -1)
+ return NULL;
+
+ /* Allocate enough to hold the gvar table header. */
+ gvar = xmalloc (sizeof *gvar);
+
+ /* Read the gvar table header. */
+ rc = read (fd, gvar, min_bytes);
+ if (rc == -1 || rc != min_bytes)
+ goto bail;
+
+ /* Swap what was read. */
+ sfnt_swap16 (&gvar->version);
+ sfnt_swap16 (&gvar->reserved);
+ sfnt_swap16 (&gvar->axis_count);
+ sfnt_swap16 (&gvar->shared_coord_count);
+ sfnt_swap32 (&gvar->offset_to_coord);
+ sfnt_swap16 (&gvar->glyph_count);
+ sfnt_swap16 (&gvar->flags);
+ sfnt_swap32 (&gvar->offset_to_data);
+
+ if (gvar->version != 1)
+ goto bail;
+
+ if (gvar->offset_to_data > directory->length)
+ goto bail;
+
+ /* Figure out the size required for the offset array. Note that
+ there is one extra offset at the end of the array to mark the
+ size of the last glyph. */
+
+ if (gvar->flags & 1)
+ /* Offsets are long words. */
+ off_size = sizeof (uint32_t) * (gvar->glyph_count + 1);
+ else
+ /* Offsets are words. */
+ off_size = sizeof (uint16_t) * (gvar->glyph_count + 1);
+
+ /* Now figure out the size of the shared coordinates. */
+ coordinate_size = (gvar->shared_coord_count * gvar->axis_count
+ * sizeof (uint16_t));
+
+ /* And the size of the glyph variation data. */
+ data_size = directory->length - gvar->offset_to_data;
+
+ /* Wraparound. */
+ if (data_size > directory->length)
+ goto bail;
+
+ /* Figure out how big gvar needs to be. */
+ if (ckd_add (&min_bytes, coordinate_size, sizeof *gvar)
+ || ckd_add (&min_bytes, min_bytes, off_size)
+ || ckd_add (&min_bytes, min_bytes, data_size))
+ goto bail;
+
+ /* Now allocate enough for all of this extra data. */
+ gvar = xrealloc (gvar, min_bytes);
+
+ /* Start reading offsets. */
+
+ if (!(gvar->flags & 1))
+ {
+ gvar->u.offset_word = (uint16_t *) (gvar + 1);
+ rc = read (fd, gvar->u.offset_word, off_size);
+ if (rc != off_size)
+ goto bail;
+
+ for (i = 0; i <= gvar->glyph_count; ++i)
+ sfnt_swap16 (&gvar->u.offset_word[i]);
+ }
+ else
+ {
+ gvar->u.offset_long = (uint32_t *) (gvar + 1);
+ rc = read (fd, gvar->u.offset_long, off_size);
+ if (rc == -1 || rc != off_size)
+ goto bail;
+
+ for (i = 0; i <= gvar->glyph_count; ++i)
+ sfnt_swap32 (&gvar->u.offset_long[i]);
+ }
+
+ /* Start reading shared coordinates. */
+
+ gvar->global_coords = ((sfnt_f2dot14 *) ((char *) (gvar + 1)
+ + off_size));
+
+ if (gvar->shared_coord_count)
+ {
+ if (ckd_add (&offset, gvar->offset_to_coord, directory->offset))
+ goto bail;
+
+ if (lseek (fd, offset, SEEK_SET) != offset)
+ goto bail;
+
+ rc = read (fd, gvar->global_coords, coordinate_size);
+
+ if (rc == -1 || rc != coordinate_size)
+ goto bail;
+
+ for (i = 0; i < coordinate_size / sizeof *gvar->global_coords; ++i)
+ sfnt_swap16 (&gvar->global_coords[i]);
+ }
+
+ /* Finally, read the rest of the glyph variation data. */
+ gvar->data_size = data_size;
+ gvar->glyph_variation_data
+ = (unsigned char *) (gvar->global_coords
+ + (coordinate_size
+ / sizeof *gvar->global_coords));
+
+ if (gvar->data_size)
+ {
+ if (ckd_add (&offset, gvar->offset_to_data, directory->offset))
+ goto bail;
+
+ if (lseek (fd, offset, SEEK_SET) != offset)
+ goto bail;
+
+ rc = read (fd, gvar->glyph_variation_data, gvar->data_size);
+
+ if (rc == -1 || rc != gvar->data_size)
+ goto bail;
+ }
+
+ /* Return the read gvar table. */
+ return gvar;
+
+ bail:
+ xfree (gvar);
+ return NULL;
+}
+
+
+
+/* Read an avar table from the given font FD. Use the table directory
+ specified in SUBTABLE.
+
+ Return the avar table upon success, else NULL. */
+
+TEST_STATIC struct sfnt_avar_table *
+sfnt_read_avar_table (int fd, struct sfnt_offset_subtable *subtable)
+{
+ struct sfnt_table_directory *directory;
+ struct sfnt_avar_table *avar;
+ ssize_t rc;
+ size_t min_size, size, i, k, j;
+ uint16_t *buffer;
+ struct sfnt_short_frac_correspondence *correspondences;
+
+ /* Find the table in the directory. */
+
+ directory = sfnt_find_table (subtable, SFNT_TABLE_AVAR);
+
+ if (!directory)
+ return NULL;
+
+ min_size = SFNT_ENDOF (struct sfnt_avar_table, axis_count, uint32_t);
+
+ /* Check that the length is at least min_size. */
+ if (directory->length < min_size)
+ return NULL;
+
+ /* Seek to the location given in the directory. */
+ if (lseek (fd, directory->offset, SEEK_SET) == (off_t) -1)
+ return NULL;
+
+ /* Allocate enough to hold the avar table header. */
+ avar = xmalloc (sizeof *avar);
+
+ /* Read the avar table header. */
+ rc = read (fd, avar, min_size);
+ if (rc == -1 || rc != min_size)
+ goto bail;
+
+ /* Swap what was read. */
+ sfnt_swap32 (&avar->version);
+ sfnt_swap32 (&avar->axis_count);
+
+ if (avar->version != 0x00010000)
+ goto bail;
+
+ if (avar->axis_count < 0)
+ goto bail;
+
+ /* Allocate a buffer that holds the rest of the data. */
+ size = directory->length - min_size;
+ buffer = xmalloc (size);
+ rc = read (fd, buffer, size);
+ if (rc == -1 || rc != size)
+ goto bail1;
+
+ /* Swap each word. */
+ for (i = 0; i < size / sizeof *buffer; ++i)
+ sfnt_swap16 (&buffer[i]);
+
+ /* Now, determine how big the resulting data needs to be. Each
+ struct has a pointer field, and that should be its alignment. */
+
+ k = 0;
+ min_size = sizeof *avar;
+ for (i = 0; i < avar->axis_count; ++i)
+ {
+ /* Check that k remains within bounds. */
+ if (k >= size / sizeof *buffer)
+ goto bail1;
+
+ /* Now add one struct sfnt_short_frac_segment for each axis and
+ each of its correspondences. */
+ if (ckd_add (&min_size, min_size, sizeof (struct sfnt_short_frac_segment))
+ || ckd_add (&min_size, min_size,
+ (sizeof (struct sfnt_short_frac_correspondence)
+ * buffer[k])))
+ goto bail1;
+
+ /* Verify that words from here to buffer[1 + buffer[k] * 2], the
+ next pairCount field, are within bounds. */
+ j = k + 1 + buffer[k] * 2;
+ if (j > size / sizeof *buffer)
+ goto bail1;
+
+ /* Move to the next pairCount field. */
+ k = j;
+ }
+
+ /* Resize avar to min_size and start filling in various
+ pointers. */
+ avar = xrealloc (avar, min_size);
+ avar->segments = (struct sfnt_short_frac_segment *) (avar + 1);
+ correspondences
+ = ((struct sfnt_short_frac_correspondence *) (avar->segments
+ + avar->axis_count));
+
+ k = 0;
+ for (i = 0; i < avar->axis_count; ++i)
+ {
+ avar->segments[i].pair_count = buffer[k++];
+ avar->segments[i].correspondence = correspondences;
+
+ for (j = 0; j < avar->segments[i].pair_count; ++j)
+ {
+ correspondences->from_coord = buffer[k++];
+ correspondences->to_coord = buffer[k++];
+ correspondences++;
+ }
+ }
+
+ /* Return the read avar table. Free buffer. */
+ xfree (buffer);
+ return avar;
+
+ bail1:
+ xfree (buffer);
+ bail:
+ xfree (avar);
+ return NULL;
+}
+
+
+
+/* Read a sequence of packed points starting from DATA. Return the
+ number of points read in *NPOINTS_RETURN and the array of unpacked
+ points, or NULL upon failure.
+
+ If non-NULL, set LOCATION to DATA plus the number of bytes read
+ upon success.
+
+ Return (uint16_t *) -1 if there are no points at all.
+ In this case, deltas will apply to all points in the glyph,
+ and *NPOINTS_RETURN will be UINT16_MAX.
+
+ END is one byte past the last byte in DATA. */
+
+static uint16_t *
+sfnt_read_packed_points (unsigned char *restrict data,
+ uint16_t *npoints_return,
+ unsigned char *restrict end,
+ unsigned char *restrict *location)
+{
+ int npoints;
+ uint16_t *points;
+ int i, first, control;
+
+ points = NULL;
+ npoints = 0;
+
+ if (data >= end)
+ return NULL;
+
+ /* Load the control byte. */
+ control = *data++;
+
+ if (!control)
+ {
+ *npoints_return = UINT16_MAX;
+ *location = data;
+ return (uint16_t *) -1;
+ }
+
+ /* Now figure out the number of points within. */
+
+ if (control & 0x80)
+ {
+ npoints = control & 0x7f;
+ npoints <<= 8;
+
+ if (data >= end)
+ return NULL;
+
+ npoints |= *data++;
+ }
+ else
+ npoints = control;
+
+ /* Start reading points. */
+ first = 0;
+ i = 0;
+ points = xmalloc (sizeof *points * npoints);
+
+ while (i < npoints)
+ {
+ if (data >= end)
+ goto bail;
+
+ control = *data++;
+
+ if (control & 0x80)
+ {
+ /* Next control & 0x7f words are points. */
+
+ control &= 0x7f;
+
+ while (control != -1 && i < npoints)
+ {
+ if (data >= end || data + 1 >= end)
+ goto bail;
+
+ first += *data++ << 8u;
+ first += *data++;
+ points[i] = first;
+ control -= 1, ++i;
+ }
+ }
+ else
+ {
+ /* Next control bytes are points. */
+
+ while (control != -1 && i < npoints)
+ {
+ if (data >= end)
+ goto bail;
+
+ first += *data++;
+ points[i] = first;
+ control -= 1, ++i;
+ }
+ }
+ }
+
+ /* Return the points read. */
+ *npoints_return = npoints;
+ *location = data;
+ return points;
+
+ bail:
+ xfree (points);
+ return NULL;
+}
+
+/* Read and return N packed deltas from DATA. Set *DATA_RETURN to
+ DATA plus the number of bytes read.
+
+ END is the end of the glyph variation data. Value is an array of N
+ deltas upon success, and NULL upon failure. */
+
+static sfnt_fword *
+sfnt_read_packed_deltas (unsigned char *restrict data,
+ unsigned char *restrict end,
+ int n,
+ unsigned char *restrict *data_return)
+{
+ sfnt_fword *deltas;
+ int i, count;
+ unsigned char control;
+ uint16_t value;
+
+ if (data >= end)
+ return NULL;
+
+ deltas = xmalloc (sizeof *deltas * n);
+ i = 0;
+
+ while (i < n)
+ {
+ if (data >= end)
+ goto fail;
+
+ control = *data++;
+ count = control & 0x3f;
+
+ while (count != -1 && i < n)
+ {
+ if (control & 0x80)
+ deltas[i++] = 0;
+ else if (control & 0x40)
+ {
+ if (data + 1 >= end)
+ goto fail;
+
+ value = *data++ << 8;
+ value |= *data++;
+ deltas[i++] = value;
+ }
+ else
+ {
+ if (data >= end)
+ goto fail;
+
+ deltas[i++] = (signed char) *data++;
+ }
+
+ --count;
+ }
+ }
+
+ *data_return = data;
+ return deltas;
+
+ fail:
+ xfree (deltas);
+ return NULL;
+}
+
+/* Read a cvar table from the given font FD. Use the table directory
+ specified in SUBTABLE, axis information provided in the fvar table
+ FVAR, and CVT information provided in the cvt table CVT.
+
+ Return the cvar table upon success, else NULL. */
+
+TEST_STATIC struct sfnt_cvar_table *
+sfnt_read_cvar_table (int fd, struct sfnt_offset_subtable *subtable,
+ struct sfnt_fvar_table *fvar,
+ struct sfnt_cvt_table *cvt)
+{
+ struct sfnt_table_directory *directory;
+ struct sfnt_cvar_table *cvar;
+ ssize_t rc;
+ size_t ntuples, size;
+ int i, j;
+ sfnt_f2dot14 *coords;
+ uint16_t *local, *points, npoints, data_size, min_size, index;
+ unsigned char *buffer, *data, *end, *tuple;
+ ptrdiff_t data_offset;
+ sfnt_fword *deltas;
+
+ /* Find the table in the directory. */
+
+ directory = sfnt_find_table (subtable, SFNT_TABLE_CVAR);
+
+ if (!directory)
+ return NULL;
+
+ min_size = SFNT_ENDOF (struct sfnt_cvar_table, data_offset,
+ uint16_t);
+
+ /* Check that the length is at least min_size. */
+ if (directory->length < min_size)
+ return NULL;
+
+ /* Seek to the location given in the directory. */
+ if (lseek (fd, directory->offset, SEEK_SET) == (off_t) -1)
+ return NULL;
+
+ /* Allocate enough to hold the cvar table header. */
+ cvar = xmalloc (sizeof *cvar);
+
+ /* Read the cvar table header. */
+ rc = read (fd, cvar, min_size);
+ if (rc != min_size)
+ goto bail;
+
+ /* Swap what was read. */
+ sfnt_swap32 (&cvar->version);
+ sfnt_swap16 (&cvar->tuple_count);
+ sfnt_swap16 (&cvar->data_offset);
+
+ /* Read the rest of the table. */
+ size = directory->length - min_size;
+ buffer = xmalloc (size);
+ rc = read (fd, buffer, size);
+ if (rc == -1 || rc != size)
+ goto bail;
+
+ /* Now figure out how large cvar must be by reading the tuples. */
+
+ ntuples = cvar->tuple_count & 0x0fff;
+ data_offset = ((ptrdiff_t) cvar->data_offset
+ - (ptrdiff_t) min_size);
+ end = buffer + size;
+
+ if (data_offset < 0)
+ goto bail1;
+
+ /* See if there are shared points, and read them if there are. */
+
+ data = buffer + data_offset;
+ tuple = buffer;
+ points = NULL;
+
+ /* Initialize `npoints' to zero. The specification doesn't say what
+ should happen with tuples using shared point numbers if it is not
+ set later on; simply assume no points at all apply to such a
+ tuple. */
+
+ npoints = 0;
+
+ /* Initialize `size' to 0. */
+ size = 0;
+
+ if (cvar->tuple_count & 0x8000)
+ {
+ points = sfnt_read_packed_points (data, &npoints, end,
+ &tuple);
+ if (!points)
+ goto bail1;
+
+ /* Add npoints words to the size. If npoints is UINT16_MAX, no
+ coordinates will actually be allocated. */
+
+ if (npoints != UINT16_MAX)
+ size = npoints * sizeof *points;
+ }
+
+ while (ntuples--)
+ {
+ data = buffer + data_offset;
+
+ /* Read the tuple. */
+ if (tuple + 3 >= end)
+ goto bail2;
+
+ memcpy (&data_size, tuple, sizeof data_size);
+ tuple += sizeof data_size;
+ memcpy (&index, tuple, sizeof index);
+ tuple += sizeof index;
+ sfnt_swap16 (&data_size);
+ sfnt_swap16 (&index);
+
+ /* Increment the offset to the data by the data size specified
+ here. */
+ data_offset += data_size;
+
+ if (index & 0x8000)
+ {
+ /* Embedded coordinates are present. Read each coordinate
+ and add it to the size. */
+
+ if (tuple + fvar->axis_count * sizeof *coords - 1 >= end)
+ goto bail2;
+
+ tuple += sizeof *coords * fvar->axis_count;
+ if (ckd_add (&size, size, sizeof *coords * fvar->axis_count))
+ goto bail2;
+ }
+ else
+ /* This table is invalid, as cvar tables don't have global
+ coordinates. */
+ goto bail2;
+
+ /* Now read indeterminate tuples if required. */
+ if (index & 0x4000)
+ {
+ tuple += fvar->axis_count * 4;
+ if (ckd_add (&size, size, fvar->axis_count * 4))
+ goto bail2;
+ }
+
+ /* Add one point and one delta for each CVT element. */
+ if (ckd_add (&size, size, cvt->num_elements * 4))
+ goto bail2;
+
+ /* Now add the size of the tuple. */
+ if (ckd_add (&size, size, sizeof *cvar->variation))
+ goto bail2;
+ }
+
+ if (ckd_add (&size, size, sizeof *cvar))
+ goto bail2;
+
+ /* Reallocate cvar. */
+ cvar = xrealloc (cvar, size);
+ ntuples = cvar->tuple_count & 0x0fff;
+ cvar->variation = (struct sfnt_tuple_variation *) (cvar + 1);
+ coords = (sfnt_f2dot14 *) (cvar->variation + ntuples);
+ tuple = buffer;
+
+ data_offset = ((ptrdiff_t) cvar->data_offset
+ - (ptrdiff_t) min_size);
+
+ /* Start reading the tuples into cvar. */
+ for (i = 0; i < ntuples; ++i)
+ {
+ data = buffer + data_offset;
+
+ /* Read the tuple. */
+ if (tuple + 3 >= end)
+ goto bail2;
+
+ memcpy (&data_size, tuple, sizeof data_size);
+ tuple += sizeof data_size;
+ memcpy (&index, tuple, sizeof index);
+ tuple += sizeof index;
+ sfnt_swap16 (&data_size);
+ sfnt_swap16 (&index);
+
+ /* Increment the offset to the data by the data size specified
+ here. */
+ data_offset += data_size;
+
+ cvar->variation[i].intermediate_start = NULL;
+ cvar->variation[i].intermediate_end = NULL;
+
+ if (index & 0x8000)
+ {
+ /* Embedded coordinates are present. Read each
+ coordinate. */
+ cvar->variation[i].coordinates = coords;
+
+ for (j = 0; j < fvar->axis_count; ++j)
+ {
+ if (tuple + 1 >= end)
+ goto bail2;
+
+ memcpy (coords++, tuple, sizeof *coords);
+ tuple += sizeof *coords;
+ sfnt_swap16 (coords);
+ }
+ }
+ else
+ goto bail2;
+
+ /* Now read indeterminate tuples if required. */
+ if (index & 0x4000)
+ {
+ cvar->variation[i].intermediate_start = coords;
+
+ for (j = 0; j < fvar->axis_count; ++j)
+ {
+ if (tuple + 1 >= end)
+ goto bail2;
+
+ memcpy (coords++, tuple, sizeof *coords);
+ tuple += sizeof *coords;
+ sfnt_swap16 (coords);
+ }
+
+ cvar->variation[i].intermediate_end = coords;
+
+ for (j = 0; j < fvar->axis_count; ++j)
+ {
+ if (tuple + 1 >= end)
+ goto bail2;
+
+ memcpy (coords++, tuple, sizeof *coords);
+ tuple += sizeof *coords;
+ sfnt_swap16 (coords);
+ }
+ }
+
+ /* Finally, read private ``point'' numbers. If this flag is not
+ set, use shared point numbers previously read.
+
+ Read at most CVT->num_elements points, as that is all the
+ storage allocated. */
+
+ if (index & 0x2000)
+ {
+ local = sfnt_read_packed_points (data, &cvar->variation[i].num_points,
+ end, &data);
+ if (!local)
+ goto bail2;
+
+ /* If points apply to all CVT indices, skip this part. */
+
+ if (cvar->variation[i].num_points != UINT16_MAX)
+ {
+ if (cvar->variation[i].num_points > cvt->num_elements)
+ cvar->variation[i].num_points = cvt->num_elements;
+
+ cvar->variation[i].points = (uint16_t *) coords;
+ for (j = 0; j < cvar->variation[i].num_points; ++j)
+ *coords++ = local[j];
+ xfree (local);
+ }
+ else
+ cvar->variation[i].points = NULL;
+ }
+ else
+ {
+ /* Copy in the shared point numbers instead. */
+ cvar->variation[i].num_points = npoints;
+
+ if (npoints != UINT16_MAX)
+ {
+ if (cvar->variation[i].num_points > cvt->num_elements)
+ cvar->variation[i].num_points = cvt->num_elements;
+
+ cvar->variation[i].points = (uint16_t *) coords;
+ for (j = 0; j < cvar->variation[i].num_points; ++j)
+ *coords++ = points[j];
+ }
+ else
+ cvar->variation[i].points = NULL;
+ }
+
+ /* And read packed deltas. If cvar->variation[i].num_points is
+ UINT16_MAX, then there is one delta for each CVT entry.
+ Otherwise, there are that many deltas. */
+
+ if (cvar->variation[i].num_points == UINT16_MAX)
+ {
+ deltas = sfnt_read_packed_deltas (data, end, cvt->num_elements,
+ &data);
+
+ if (!deltas)
+ goto bail2;
+
+ cvar->variation[i].deltas = coords;
+
+ for (j = 0; j < cvt->num_elements; ++j)
+ *coords++ = deltas[j];
+ xfree (deltas);
+ }
+ else
+ {
+ deltas = sfnt_read_packed_deltas (data, end,
+ cvar->variation[i].num_points,
+ &data);
+ if (!deltas)
+ goto bail2;
+
+ cvar->variation[i].deltas = coords;
+
+ for (j = 0; j < cvar->variation[i].num_points; ++j)
+ *coords++ = deltas[j];
+ xfree (deltas);
+ }
+ }
+
+ /* Free data and return the read cvar table. */
+ if (points != (void *) -1)
+ xfree (points);
+ xfree (buffer);
+ return cvar;
+
+ bail2:
+ if (points != (void *) -1)
+ xfree (points);
+ bail1:
+ xfree (buffer);
+ bail:
+ xfree (cvar);
+ return NULL;
+}
+
+
+
+/* Initialize the specified BLEND with the given FVAR and GVAR tables.
+ If non-NULL, adjust normalized coordinates using the axis variation
+ table AVAR; similarly, adjust interpreter CVT values using CVAR, if
+ specified. */
+
+TEST_STATIC void
+sfnt_init_blend (struct sfnt_blend *blend, struct sfnt_fvar_table *fvar,
+ struct sfnt_gvar_table *gvar, struct sfnt_avar_table *avar,
+ struct sfnt_cvar_table *cvar)
+{
+ size_t size;
+
+ blend->fvar = fvar;
+ blend->gvar = gvar;
+ blend->avar = avar;
+ blend->cvar = cvar;
+
+ /* Allocate a single array to hold both coords and norm_coords. */
+ size = (fvar->axis_count * sizeof *blend->coords * 2);
+ blend->coords = xmalloc (size);
+ blend->norm_coords = blend->coords + fvar->axis_count;
+}
+
+/* Free what was initialized in the specified BLEND. */
+
+TEST_STATIC void
+sfnt_free_blend (struct sfnt_blend *blend)
+{
+ xfree (blend->coords);
+}
+
+/* Normalize BLEND->fvar->axis_count coordinates in BLEND->coords and
+ place the result in BLEND->norm_coords. */
+
+TEST_STATIC void
+sfnt_normalize_blend (struct sfnt_blend *blend)
+{
+ struct sfnt_variation_axis *axis;
+ int i, j;
+ sfnt_fixed from, coord, j0, j1, j2;
+ sfnt_fixed from_last, coord_last;
+ struct sfnt_short_frac_segment *segment;
+
+ /* For each axis... */
+ for (i = 0; i < blend->fvar->axis_count; ++i)
+ {
+ /* Normalize based on [min, default, max], into [-1, 0, 1]. */
+ axis = &blend->fvar->axis[i];
+
+ /* Load the current design coordinate. */
+ coord = blend->coords[i];
+
+ /* Keep it within bounds. */
+
+ if (coord > axis->max_value)
+ coord = axis->max_value;
+ else if (coord < axis->min_value)
+ coord = axis->min_value;
+
+ if (coord > axis->default_value)
+ {
+ /* Avoid division by 0. */
+ if (axis->max_value != axis->default_value)
+ blend->norm_coords[i]
+ = sfnt_div_fixed (sfnt_sub (coord, axis->default_value),
+ sfnt_sub (axis->max_value,
+ axis->default_value));
+ else
+ blend->norm_coords[i] = 0;
+ }
+ else if (coord < axis->default_value)
+ {
+ if (axis->default_value != axis->min_value)
+ blend->norm_coords[i]
+ = sfnt_div_fixed (sfnt_sub (coord, axis->default_value),
+ sfnt_sub (axis->default_value,
+ axis->min_value));
+ else
+ blend->norm_coords[i] = 0;
+ }
+ else
+ blend->norm_coords[i] = 0;
+ }
+
+ /* Now, apply axis variations, but only if the avar table has the
+ right number of axes. */
+
+ if (blend->avar && (blend->fvar->axis_count
+ == blend->avar->axis_count))
+ {
+ for (i = 0; i < blend->fvar->axis_count; ++i)
+ {
+ segment = &blend->avar->segments[i];
+
+ /* Search for a correspondence record above the normalized
+ coordinate of this axis. */
+
+ for (j = 1; j < segment->pair_count; ++j)
+ {
+ from = segment->correspondence[j].from_coord * 4;
+ coord = segment->correspondence[j].to_coord * 4;
+
+ if (blend->norm_coords[i] < from)
+ {
+ from_last
+ = segment->correspondence[j - 1].from_coord * 4;
+ coord_last
+ = segment->correspondence[j - 1].to_coord * 4;
+
+ j0 = blend->norm_coords[i] - from_last;
+ j1 = coord - coord_last;
+ j2 = from - from_last;
+
+ blend->norm_coords[i]
+ = (sfnt_multiply_divide_signed (j0, j1, j2) + coord_last);
+ break;
+ }
+ }
+ }
+ }
+}
+
+
+
+struct sfnt_gvar_glyph_header
+{
+ /* A packed field. The high 4 bits are flags and the low 12 bits are
+ the number of tuples for this glyph. The number of tuples can be
+ any number between 1 and 4095. */
+ uint16_t tuple_count;
+
+ /* Offset from the start of the GlyphVariationData table to the
+ serialized data. */
+ uint16_t data_offset;
+};
+
+/* Given a BLEND containing normalized coordinates, an array of
+ BLEND->gvar->axis_count tuple coordinates, and, if INTERMEDIATE_P,
+ a range of tuple coordinates from INTERMEDIATE_START to
+ INTERMEDIATE_END, return the scaling factor to apply to deltas for
+ each corresponding point. */
+
+static sfnt_fixed
+sfnt_compute_tuple_scale (struct sfnt_blend *blend, bool intermediate_p,
+ sfnt_f2dot14 *coords,
+ sfnt_f2dot14 *intermediate_start,
+ sfnt_f2dot14 *intermediate_end)
+{
+ int i;
+ sfnt_fixed coord, start UNINIT, end UNINIT;
+ sfnt_fixed scale;
+
+ /* scale is initially 1.0. */
+ scale = 0200000;
+
+ for (i = 0; i < blend->gvar->axis_count; ++i)
+ {
+ /* Load values for this axis, scaled up to sfnt_fixed. */
+ coord = coords[i] * 4;
+
+ /* GCC warns about start and end being used when uninitialized,
+ but they are used only if intermediate_p. */
+
+ if (intermediate_p)
+ {
+ start = intermediate_start[i] * 4;
+ end = intermediate_end[i] * 4;
+ }
+
+ /* Ignore tuples that can be skipped. */
+
+ if (!coord)
+ continue;
+
+ /* If the coordinate is set to 0, then deltas should not be
+ applied. Return 0. */
+
+ if (!blend->norm_coords[i])
+ return 0;
+
+ /* If no scaling need take place, continue. */
+
+ if (blend->norm_coords[i] == coord)
+ continue;
+
+ if (!intermediate_p)
+ {
+ /* Not an intermediate tuple; if coord is less than 0 and
+ blend->norm_coords[i] < coord, or coord is more than 0
+ and blend->norm_coords[i] > coord, then it doesn't fit,
+ so return. */
+
+ if (blend->norm_coords[i] < MIN (0, coord)
+ || blend->norm_coords[i] > MAX (0, coord))
+ return 0;
+
+ scale = sfnt_multiply_divide_signed (scale,
+ blend->norm_coords[i],
+ coord);
+ }
+ else
+ {
+ /* Otherwise, renormalize between start and end. */
+
+ if (blend->norm_coords[i] < start
+ || blend->norm_coords[i] > end)
+ return 0;
+
+ if (blend->norm_coords[i] < coord)
+ scale = sfnt_multiply_divide (scale,
+ blend->norm_coords[i] - start,
+ coord - start);
+ else
+ scale = sfnt_multiply_divide (scale,
+ end - blend->norm_coords[i],
+ end - coord);
+ }
+ }
+
+ return scale;
+}
+
+/* Move each point in the simple glyph GLYPH between PAIR_START and
+ PAIR_END to agree with the positions of those two anchor points as
+ compared with their initial positions recorded within the arrays X
+ and Y.
+
+ The range formed between PAIR_START and PAIR_END may encompass the
+ upper extreme of the contour between START and END. */
+
+static void
+sfnt_infer_deltas_2 (struct sfnt_glyph *glyph, size_t pair_start,
+ size_t pair_end, size_t start, size_t end,
+ sfnt_fword *x, sfnt_fword *y)
+{
+ size_t j;
+ sfnt_fword min_pos, max_pos, position, d1, d2;
+ sfnt_fixed ratio, delta;
+
+ j = pair_start + 1;
+
+ while (j != pair_end)
+ {
+ /* Reset j to the contour's start position if it is about to
+ overrun this contour. */
+
+ if (j > end)
+ {
+ /* The start of the contour might also be the end of this
+ reference point. */
+ if (start == pair_end)
+ return;
+
+ j = start;
+ }
+
+ /* Consider the X axis. Set min_pos and max_pos to the
+ smallest and greatest values along that axis. */
+ min_pos = MIN (x[pair_start], x[pair_end]);
+ max_pos = MAX (x[pair_start], x[pair_end]);
+
+ /* Now see if the current point lies between min and
+ max...
+
+ GX interpolation differs from IUP in one important detail:
+ points are shifted to follow the movement of their reference
+ points if their positions are identical to those of any of
+ their reference points, whereas IUP considers such points to
+ fall within their reference points. */
+ if (x[j] > min_pos && x[j] < max_pos)
+ {
+ /* Interpolate between min_pos and max_pos. */
+ ratio = sfnt_div_fixed ((sfnt_sub (x[j], min_pos)
+ * 65536),
+ (sfnt_sub (max_pos, min_pos)
+ * 65536));
+
+ /* Load the current positions of pair_start and pair_end
+ along this axis. */
+ min_pos = MIN (glyph->simple->x_coordinates[pair_start],
+ glyph->simple->x_coordinates[pair_end]);
+ max_pos = MAX (glyph->simple->x_coordinates[pair_start],
+ glyph->simple->x_coordinates[pair_end]);
+
+ /* Lerp in between. */
+ delta = sfnt_sub (max_pos, min_pos);
+ delta = sfnt_mul_fixed (ratio, delta);
+ glyph->simple->x_coordinates[j] = min_pos + delta;
+ }
+ else
+ {
+ /* ... otherwise, move point j by the delta of the
+ nearest touched point. */
+
+ /* If min_pos and max_pos are the same, apply
+ pair_start's delta if it is identical to that of
+ pair_end, or apply nothing at all otherwise. */
+
+ if (min_pos == max_pos)
+ {
+ d1 = (glyph->simple->x_coordinates[pair_start]
+ - x[pair_start]);
+ d2 = (glyph->simple->x_coordinates[pair_end]
+ - x[pair_end]);
+
+ if (d1 == d2)
+ glyph->simple->x_coordinates[j] += d1;
+
+ goto consider_y;
+ }
+
+ if (x[j] >= max_pos)
+ {
+ position = MAX (glyph->simple->x_coordinates[pair_start],
+ glyph->simple->x_coordinates[pair_end]);
+ delta = position - max_pos;
+ }
+ else
+ {
+ position = MIN (glyph->simple->x_coordinates[pair_start],
+ glyph->simple->x_coordinates[pair_end]);
+ delta = position - min_pos;
+ }
+
+ glyph->simple->x_coordinates[j] = x[j] + delta;
+ }
+
+ consider_y:
+
+ /* Now, consider the Y axis. */
+ min_pos = MIN (y[pair_start], y[pair_end]);
+ max_pos = MAX (y[pair_start], y[pair_end]);
+
+ /* Now see if the current point lies between min and
+ max...
+
+ GX interpolation differs from IUP in one important detail:
+ points are shifted to follow the movement of their reference
+ points if their positions are identical to those of any of
+ their reference points, whereas IUP considers such points to
+ fall within their reference points. */
+ if (y[j] > min_pos && y[j] < max_pos)
+ {
+ /* Interpolate between min_pos and max_pos. */
+ ratio = sfnt_div_fixed ((sfnt_sub (y[j], min_pos)
+ * 65536),
+ (sfnt_sub (max_pos, min_pos)
+ * 65536));
+
+ /* Load the current positions of pair_start and pair_end
+ along this axis. */
+ min_pos = MIN (glyph->simple->y_coordinates[pair_start],
+ glyph->simple->y_coordinates[pair_end]);
+ max_pos = MAX (glyph->simple->y_coordinates[pair_start],
+ glyph->simple->y_coordinates[pair_end]);
+
+ /* Lerp in between. */
+ delta = sfnt_sub (max_pos, min_pos);
+ delta = sfnt_mul_fixed (ratio, delta);
+ glyph->simple->y_coordinates[j] = min_pos + delta;
+ }
+ else
+ {
+ /* ... otherwise, move point j by the delta of the
+ nearest touched point. */
+
+ /* If min_pos and max_pos are the same, apply
+ pair_start's delta if it is identical to that of
+ pair_end, or apply nothing at all otherwise. */
+
+ if (min_pos == max_pos)
+ {
+ d1 = (glyph->simple->y_coordinates[pair_start]
+ - y[pair_start]);
+ d2 = (glyph->simple->y_coordinates[pair_end]
+ - y[pair_end]);
+
+ if (d1 == d2)
+ glyph->simple->y_coordinates[j] += d1;
+
+ goto next;
+ }
+
+ if (y[j] >= max_pos)
+ {
+ position = MAX (glyph->simple->y_coordinates[pair_start],
+ glyph->simple->y_coordinates[pair_end]);
+ delta = position - max_pos;
+ }
+ else
+ {
+ position = MIN (glyph->simple->y_coordinates[pair_start],
+ glyph->simple->y_coordinates[pair_end]);
+ delta = position - min_pos;
+ }
+
+ glyph->simple->y_coordinates[j] = y[j] + delta;
+ }
+
+ next:
+ j++;
+ }
+}
+
+/* Infer point positions for points that have been partially moved
+ within the contour in GLYPH denoted by START and END. */
+
+static void
+sfnt_infer_deltas_1 (struct sfnt_glyph *glyph, size_t start,
+ size_t end, bool *touched, sfnt_fword *x,
+ sfnt_fword *y)
+{
+ size_t i, pair_start, pair_end, pair_first;
+
+ pair_start = pair_first = -1;
+
+ /* Look for pairs of touched points. */
+
+ for (i = start; i <= end; ++i)
+ {
+ if (!touched[i])
+ continue;
+
+ if (pair_start == -1)
+ {
+ pair_first = i;
+ goto next;
+ }
+
+ pair_end = i;
+
+ /* pair_start to pair_end are now a pair of points whose
+ intermediates should be interpolated. */
+ sfnt_infer_deltas_2 (glyph, pair_start, pair_end,
+ start, end, x, y);
+
+ next:
+ pair_start = i;
+ }
+
+ /* If pair_start is set, then lerp points between it and
+ pair_first. */
+
+ if (pair_start != (size_t) -1)
+ {
+ pair_end = pair_first;
+
+ /* pair_start to pair_end are now a pair of points whose
+ intermediates should be interpolated. */
+ sfnt_infer_deltas_2 (glyph, pair_start, pair_end,
+ start, end, x, y);
+ }
+}
+
+/* Infer point positions for contours that have been partially moved
+ by variation. For each contour in GLYPH, find pairs of points
+ which have had deltas applied. For each such pair, interpolate
+ points between the first point in the pair and the second by
+ considering each point along every one of the two axes (X and Y)
+ like so:
+
+ - For each point that lies between the first point and the last
+ on the axis currently being considered, interpolate its
+ position in that axis so that the ratio formed by its position
+ relative to the first and last points of the pair in the
+ original outline still holds.
+
+ - For each point that lies to the left or top of the first point
+ on the axis being considered, use the delta of the first point.
+
+ - And finally, for each point that lies to the right or bottom of
+ the last point on that axis, use the delta of the last
+ point.
+
+ X and Y contain the original positions of each point.
+ TOUCHED contains whether or not each point within GLYPH has been
+ changed through variation.
+
+ Apply the inferred deltas back to GLYPH. */
+
+static void
+sfnt_infer_deltas (struct sfnt_glyph *glyph, bool *touched,
+ sfnt_fword *x, sfnt_fword *y)
+{
+ size_t i;
+ int point, first, end;
+
+ point = 0;
+ for (i = 0; i < glyph->number_of_contours; ++i)
+ {
+ first = point;
+ end = glyph->simple->end_pts_of_contours[i];
+
+ /* Return if the glyph is invalid. */
+
+ if (first >= glyph->simple->number_of_points
+ || end >= glyph->simple->number_of_points
+ || first > end)
+ return;
+
+ sfnt_infer_deltas_1 (glyph, first, end, touched, x, y);
+ point = end + 1;
+ }
+}
+
+/* Read the glyph variation data for the specified glyph ID from
+ BLEND's gvar table. Apply the offsets to each point in the
+ specified simple GLYPH, based on the specified BLEND.
+
+ Value is 0 upon success, else 1.
+
+ The glyph variation data consists of a number of elements, each of
+ which has its own associated point numbers and deltas, and a list
+ of one or two coordinates for each axis. Each such list is
+ referred to as a ``tuple''.
+
+ The deltas, one for each point, are multiplied by the normalized
+ value of each axis and applied to those points for each tuple that
+ is found to be applicable.
+
+ Each element of the glyph variation data is applicable to an axis
+ if its list of coordinates:
+
+ - contains one element for each axis, and its axis has a value
+ between 0 and that element.
+
+ - contains two elements for each axis, and its axis has a value
+ between the first element and the second.
+
+ Return the deltas that would normally be applied to the two phantom
+ points describing horizontal bounds in *DISTORTION. Do not
+ transform the outline to reflect adjustments to the origin
+ point. */
+
+TEST_STATIC int
+sfnt_vary_simple_glyph (struct sfnt_blend *blend, sfnt_glyph id,
+ struct sfnt_glyph *glyph,
+ struct sfnt_metrics_distortion *distortion)
+{
+ uint32_t offset;
+ struct sfnt_gvar_glyph_header header;
+ uint16_t *points, npoints;
+ int i, ntuples, j, point_count;
+ unsigned char *tuple, *end, *data;
+ uint16_t data_size, index, *glyph_points;
+ sfnt_f2dot14 *restrict coords;
+ sfnt_f2dot14 *restrict intermediate_start;
+ sfnt_f2dot14 *restrict intermediate_end;
+ sfnt_fword *restrict dx, *restrict dy, fword;
+ struct sfnt_gvar_table *gvar;
+ uint16_t *local_points, n_local_points;
+ sfnt_fixed scale;
+ ptrdiff_t data_offset;
+ bool *touched;
+ sfnt_fword *restrict original_x, *restrict original_y;
+
+ gvar = blend->gvar;
+
+ if (gvar->axis_count != blend->fvar->axis_count)
+ return 1;
+
+ if (gvar->glyph_count <= id)
+ return 1;
+
+ if (gvar->flags & 1)
+ offset = gvar->u.offset_long[id];
+ else
+ offset = gvar->u.offset_word[id] * 2u;
+
+ if (offset >= gvar->data_size)
+ return 1;
+
+ end = gvar->glyph_variation_data + gvar->data_size;
+
+ /* Start reading the header. */
+
+ if (offset + sizeof header > gvar->data_size)
+ return 1;
+
+ /* Clear the distortion. */
+ distortion->origin = 0;
+ distortion->advance = 0;
+
+ memcpy (&header, gvar->glyph_variation_data + offset,
+ sizeof header);
+
+ /* Swap the header. */
+ sfnt_swap16 (&header.tuple_count);
+ sfnt_swap16 (&header.data_offset);
+
+ /* Prepare to read each tuple. */
+ ntuples = header.tuple_count & 0x0fff;
+
+ /* Initialize the data offset. This is incremented with each tuple
+ read. */
+ data_offset = header.data_offset;
+
+ /* If gvar->flags & tuples_share_point_numbers, read the shared
+ point numbers. Initialize `npoints' to zero. The specification
+ doesn't say what should happen with tuples using shared point
+ numbers if it is not set later on; simply assume no points at all
+ apply to such a tuple. */
+
+ npoints = 0;
+
+ if (header.tuple_count & 0x8000)
+ {
+ data = gvar->glyph_variation_data + offset + data_offset;
+ points = sfnt_read_packed_points (data, &npoints, end,
+ &tuple);
+
+ if (!points)
+ return 1;
+
+ /* Shared point numbers are part of the data after the tuple
+ array. Thus, increment data_offset by tuple - data. `tuple'
+ here holds no relation to a pointer to the current part of
+ the tuple array that is being read later on. */
+ data_offset += tuple - data;
+ }
+ else
+ points = NULL;
+
+ /* Start reading each tuple. */
+ tuple = gvar->glyph_variation_data + offset + sizeof header;
+
+ if (gvar->axis_count * sizeof *coords * 3 >= 1024 * 16)
+ coords = xmalloc (gvar->axis_count * sizeof *coords * 3);
+ else
+ coords = alloca (gvar->axis_count * sizeof *coords * 3);
+
+ intermediate_start = coords + gvar->axis_count;
+ intermediate_end = intermediate_start + gvar->axis_count;
+
+ /* Allocate arrays of booleans and fwords to keep track of which
+ points have been touched. */
+ touched = NULL;
+ original_x = NULL;
+ original_y = NULL;
+
+ while (ntuples--)
+ {
+ data = gvar->glyph_variation_data + offset + data_offset;
+
+ if (tuple + 3 >= end)
+ goto fail1;
+
+ memcpy (&data_size, tuple, sizeof data_size);
+ tuple += sizeof data_size;
+ memcpy (&index, tuple, sizeof index);
+ tuple += sizeof index;
+ sfnt_swap16 (&data_size);
+ sfnt_swap16 (&index);
+
+ /* Increment the offset to the data by the data size specified
+ here. */
+ data_offset += data_size;
+
+ if (index & 0x8000)
+ {
+ /* Embedded coordinates are present. Read each
+ coordinate and add it to the tuple. */
+ for (j = 0; j < gvar->axis_count; ++j)
+ {
+ if (tuple + 1 >= end)
+ goto fail1;
+
+ memcpy (&coords[j], tuple, sizeof *coords);
+ tuple += sizeof *coords;
+ sfnt_swap16 (&coords[j]);
+ }
+ }
+ else if ((index & 0xfff) > gvar->shared_coord_count)
+ /* index exceeds the number of shared tuples present. */
+ goto fail1;
+ else
+ /* index points into gvar->axis_count coordinates making up
+ the tuple. */
+ memcpy (coords, (gvar->global_coords
+ + ((index & 0xfff) * gvar->axis_count)),
+ gvar->axis_count * sizeof *coords);
+
+ /* Now read indeterminate tuples if required. */
+ if (index & 0x4000)
+ {
+ for (j = 0; j < gvar->axis_count; ++j)
+ {
+ if (tuple + 1 >= end)
+ goto fail1;
+
+ memcpy (&intermediate_start[j], tuple,
+ sizeof *intermediate_start);
+ tuple += sizeof *intermediate_start;
+ sfnt_swap16 (&intermediate_start[j]);
+ }
+
+ for (j = 0; j < gvar->axis_count; ++j)
+ {
+ if (tuple + 1 >= end)
+ goto fail1;
+
+ memcpy (&intermediate_end[j], tuple,
+ sizeof *intermediate_end);
+ tuple += sizeof *intermediate_end;
+ sfnt_swap16 (&intermediate_end[j]);
+ }
+ }
+
+ /* See whether or not the tuple applies to the current variation
+ configuration, and how much to scale them by. */
+
+ scale = sfnt_compute_tuple_scale (blend, index & 0x4000,
+ coords, intermediate_start,
+ intermediate_end);
+
+ if (!scale)
+ continue;
+
+ local_points = NULL;
+
+ /* Finally, read private point numbers.
+ Set local_points to those numbers; it will be freed
+ once the loop ends. */
+
+ if (index & 0x2000)
+ {
+ local_points = sfnt_read_packed_points (data, &n_local_points,
+ end, &data);
+ if (!local_points)
+ goto fail1;
+
+ point_count = n_local_points;
+ glyph_points = local_points;
+ }
+ else
+ {
+ /* If there are no private point numbers, use global
+ points. */
+ point_count = npoints;
+ glyph_points = points;
+ }
+
+ /* Now, read packed deltas. */
+
+ dx = NULL;
+ dy = NULL;
+
+ switch (point_count)
+ {
+ case UINT16_MAX:
+ /* Deltas are provided for all points in the glyph.
+ No glyph should have more than 65535 points. */
+
+ /* Add 4 phantom points to each end. */
+ dx = sfnt_read_packed_deltas (data, end,
+ glyph->simple->number_of_points + 4,
+ &data);
+ dy = sfnt_read_packed_deltas (data, end,
+ glyph->simple->number_of_points + 4,
+ &data);
+
+ if (!dx || !dy)
+ goto fail3;
+
+ /* Apply each delta to the simple glyph. */
+
+ for (i = 0; i < glyph->simple->number_of_points; ++i)
+ {
+ fword = sfnt_mul_fixed_round (dx[i], scale);
+ glyph->simple->x_coordinates[i] += fword;
+ fword = sfnt_mul_fixed_round (dy[i], scale);
+ glyph->simple->y_coordinates[i] += fword;
+ }
+
+ /* Apply the deltas for the two phantom points. */
+ distortion->origin += sfnt_mul_fixed_round (dx[i++], scale);
+ distortion->advance += sfnt_mul_fixed_round (dx[i], scale);
+ break;
+
+ default:
+ dx = sfnt_read_packed_deltas (data, end, point_count, &data);
+ dy = sfnt_read_packed_deltas (data, end, point_count, &data);
+
+ if (!dx || !dy)
+ goto fail3;
+
+ /* Deltas are only applied for each point number read. */
+
+ if (!original_x)
+ {
+ if ((glyph->simple->number_of_points
+ * sizeof *touched) >= 1024 * 16)
+ touched = xmalloc (sizeof *touched
+ * glyph->simple->number_of_points);
+ else
+ touched = alloca (sizeof *touched
+ * glyph->simple->number_of_points);
+
+ if ((sizeof *original_x * 2
+ * glyph->simple->number_of_points) >= 1024 * 16)
+ original_x = xmalloc (sizeof *original_x * 2
+ * glyph->simple->number_of_points);
+ else
+ original_x = alloca (sizeof *original_x * 2
+ * glyph->simple->number_of_points);
+
+ original_y = original_x + glyph->simple->number_of_points;
+ }
+
+ /* The array of original coordinates should reflect the
+ state of the glyph immediately before deltas from this
+ tuple are applied, in contrast to the state before any
+ deltas are applied. */
+
+ memcpy (original_x, glyph->simple->x_coordinates,
+ (sizeof *original_x
+ * glyph->simple->number_of_points));
+ memcpy (original_y, glyph->simple->y_coordinates,
+ (sizeof *original_y
+ * glyph->simple->number_of_points));
+
+ memset (touched, 0, (sizeof *touched
+ * glyph->simple->number_of_points));
+
+ for (i = 0; i < point_count; ++i)
+ {
+ /* Apply deltas to phantom points. */
+
+ if (glyph_points[i] == glyph->simple->number_of_points)
+ {
+ distortion->origin += sfnt_mul_fixed_round (dx[i], scale);
+ continue;
+ }
+
+ if (glyph_points[i] == glyph->simple->number_of_points + 1)
+ {
+ distortion->advance += sfnt_mul_fixed_round (dx[i], scale);
+ continue;
+ }
+
+ /* Make sure the point doesn't end up out of bounds. */
+ if (glyph_points[i] >= glyph->simple->number_of_points)
+ continue;
+
+ fword = sfnt_mul_fixed_round (dx[i], scale);
+ glyph->simple->x_coordinates[glyph_points[i]] += fword;
+ fword = sfnt_mul_fixed_round (dy[i], scale);
+ glyph->simple->y_coordinates[glyph_points[i]] += fword;
+ touched[glyph_points[i]] = true;
+ }
+
+ sfnt_infer_deltas (glyph, touched, original_x,
+ original_y);
+ break;
+ }
+
+ xfree (dx);
+ xfree (dy);
+
+ if (local_points != (uint16_t *) -1)
+ xfree (local_points);
+ }
+
+ /* Return success. */
+
+ if ((glyph->simple->number_of_points
+ * sizeof *touched) >= 1024 * 16)
+ xfree (touched);
+
+ if (gvar->axis_count * sizeof *coords * 3 >= 1024 * 16)
+ xfree (coords);
+
+ if ((sizeof *original_x * 2
+ * glyph->simple->number_of_points) >= 1024 * 16)
+ xfree (original_x);
+
+ if (points != (uint16_t *) -1)
+ xfree (points);
+
+ /* Set the glyph metrics distortion as well. */
+ glyph->advance_distortion = distortion->advance;
+ glyph->origin_distortion = distortion->origin;
+
+ return 0;
+
+ fail3:
+ xfree (dx);
+ xfree (dy);
+ xfree (local_points);
+ fail1:
+
+ if ((glyph->simple->number_of_points
+ * sizeof *touched) >= 1024 * 16)
+ xfree (touched);
+
+ if (gvar->axis_count * sizeof *coords * 3 >= 1024 * 16)
+ xfree (coords);
+
+ if ((sizeof *original_x * 2
+ * glyph->simple->number_of_points) >= 1024 * 16)
+ xfree (original_x);
+
+ if (points != (uint16_t *) -1)
+ xfree (points);
+
+ return 1;
+}
+
+/* Read the glyph variation data for the specified glyph ID from
+ BLEND's gvar table. Apply the deltas specified within to each
+ component with offsets in the specified compound GLYPH, based on
+ the specified BLEND. Return distortions to phantom points in
+ *DISTORTION.
+
+ Value is 0 upon success, 1 otherwise. */
+
+TEST_STATIC int
+sfnt_vary_compound_glyph (struct sfnt_blend *blend, sfnt_glyph id,
+ struct sfnt_glyph *glyph,
+ struct sfnt_metrics_distortion *distortion)
+{
+ uint32_t offset;
+ struct sfnt_gvar_glyph_header header;
+ uint16_t *points, npoints;
+ int i, ntuples, j, point_count;
+ unsigned char *tuple, *end, *data;
+ uint16_t data_size, index, *glyph_points;
+ sfnt_f2dot14 *restrict coords;
+ sfnt_f2dot14 *restrict intermediate_start;
+ sfnt_f2dot14 *restrict intermediate_end;
+ sfnt_fword *restrict dx, *restrict dy, fword, word;
+ struct sfnt_gvar_table *gvar;
+ uint16_t *local_points, n_local_points;
+ sfnt_fixed scale;
+ ptrdiff_t data_offset;
+ struct sfnt_compound_glyph_component *component;
+
+ gvar = blend->gvar;
+
+ if (gvar->axis_count != blend->fvar->axis_count)
+ return 1;
+
+ if (gvar->glyph_count <= id)
+ return 1;
+
+ if (gvar->flags & 1)
+ offset = gvar->u.offset_long[id];
+ else
+ offset = gvar->u.offset_word[id] * 2u;
+
+ if (offset >= gvar->data_size)
+ return 1;
+
+ end = gvar->glyph_variation_data + gvar->data_size;
+
+ /* Start reading the header. */
+
+ if (offset + sizeof header > gvar->data_size)
+ return 1;
+
+ /* Clear the distortion. */
+ distortion->origin = 0;
+ distortion->advance = 0;
+
+ memcpy (&header, gvar->glyph_variation_data + offset,
+ sizeof header);
+
+ /* Swap the header. */
+ sfnt_swap16 (&header.tuple_count);
+ sfnt_swap16 (&header.data_offset);
+
+ /* Prepare to read each tuple. */
+ ntuples = header.tuple_count & 0x0fff;
+
+ /* Initialize the data offset. This is incremented with each tuple
+ read. */
+ data_offset = header.data_offset;
+
+ /* If gvar->flags & tuples_share_point_numbers, read the shared
+ point numbers. */
+
+ npoints = 0;
+
+ if (header.tuple_count & 0x8000)
+ {
+ data = gvar->glyph_variation_data + offset + data_offset;
+ points = sfnt_read_packed_points (data, &npoints, end,
+ &tuple);
+
+ if (!points)
+ return 1;
+
+ /* Shared point numbers are part of the data after the tuple
+ array. Thus, increment data_offset by tuple - data. `tuple'
+ here holds no relation to a pointer to the current part of
+ the tuple array that is being read later on. */
+ data_offset += tuple - data;
+ }
+ else
+ points = NULL;
+
+ /* Start reading each tuple. */
+ tuple = gvar->glyph_variation_data + offset + sizeof header;
+
+ if (gvar->axis_count * sizeof *coords * 3 >= 1024 * 16)
+ coords = xmalloc (gvar->axis_count * sizeof *coords * 3);
+ else
+ coords = alloca (gvar->axis_count * sizeof *coords * 3);
+
+ intermediate_start = coords + gvar->axis_count;
+ intermediate_end = intermediate_start + gvar->axis_count;
+
+ while (ntuples--)
+ {
+ data = gvar->glyph_variation_data + offset + data_offset;
+
+ if (tuple + 3 >= end)
+ goto fail1;
+
+ memcpy (&data_size, tuple, sizeof data_size);
+ tuple += sizeof data_size;
+ memcpy (&index, tuple, sizeof index);
+ tuple += sizeof index;
+ sfnt_swap16 (&data_size);
+ sfnt_swap16 (&index);
+
+ /* Increment the offset to the data by the data size specified
+ here. */
+ data_offset += data_size;
+
+ if (index & 0x8000)
+ {
+ /* Embedded coordinates are present. Read each
+ coordinate and add it to the tuple. */
+ for (j = 0; j < gvar->axis_count; ++j)
+ {
+ if (tuple + 1 >= end)
+ goto fail1;
+
+ memcpy (&coords[j], tuple, sizeof *coords);
+ tuple += sizeof *coords;
+ sfnt_swap16 (&coords[j]);
+ }
+ }
+ else if ((index & 0xfff) > gvar->shared_coord_count)
+ /* index exceeds the number of shared tuples present. */
+ goto fail1;
+ else
+ /* index points into gvar->axis_count coordinates making up
+ the tuple. */
+ memcpy (coords, (gvar->global_coords
+ + ((index & 0xfff) * gvar->axis_count)),
+ gvar->axis_count * sizeof *coords);
+
+ /* Now read indeterminate tuples if required. */
+ if (index & 0x4000)
+ {
+ for (j = 0; j < gvar->axis_count; ++j)
+ {
+ if (tuple + 1 >= end)
+ goto fail1;
+
+ memcpy (&intermediate_start[j], tuple,
+ sizeof *intermediate_start);
+ tuple += sizeof *intermediate_start;
+ sfnt_swap16 (&intermediate_start[j]);
+ }
+
+ for (j = 0; j < gvar->axis_count; ++j)
+ {
+ if (tuple + 1 >= end)
+ goto fail1;
+
+ memcpy (&intermediate_end[j], tuple,
+ sizeof *intermediate_end);
+ tuple += sizeof *intermediate_end;
+ sfnt_swap16 (&intermediate_end[j]);
+ }
+ }
+
+ /* See whether or not the tuple applies to the current variation
+ configuration, and how much to scale them by. */
+
+ scale = sfnt_compute_tuple_scale (blend, index & 0x4000,
+ coords, intermediate_start,
+ intermediate_end);
+
+ if (!scale)
+ continue;
+
+ local_points = NULL;
+
+ /* Finally, read private point numbers.
+ Set local_points to those numbers; it will be freed
+ once the loop ends. */
+
+ if (index & 0x2000)
+ {
+ local_points = sfnt_read_packed_points (data, &n_local_points,
+ end, &data);
+ if (!local_points)
+ goto fail1;
+
+ point_count = n_local_points;
+ glyph_points = local_points;
+ }
+ else
+ {
+ /* If there are no private point numbers, use global
+ points. */
+ point_count = npoints;
+ glyph_points = points;
+ }
+
+ /* Now, read packed deltas. */
+
+ dx = NULL;
+ dy = NULL;
+
+ switch (point_count)
+ {
+ case UINT16_MAX:
+ /* Deltas are provided for all components in the glyph. */
+
+ /* Add 4 phantom points to each end. */
+ dx = sfnt_read_packed_deltas (data, end,
+ glyph->compound->num_components + 4,
+ &data);
+ dy = sfnt_read_packed_deltas (data, end,
+ glyph->compound->num_components + 4,
+ &data);
+
+ if (!dx || !dy)
+ goto fail3;
+
+ /* Apply each delta to the compound glyph. */
+
+ for (i = 0; i < glyph->compound->num_components; ++i)
+ {
+ component = &glyph->compound->components[i];
+
+ /* Check if the component uses deltas at all. */
+ if (!(component->flags & 02))
+ continue;
+
+ /* Vary the X offset. */
+
+ if (!(component->flags & 01))
+ word = component->argument1.b;
+ else
+ word = component->argument1.d;
+
+ fword = sfnt_mul_fixed_round (dx[i], scale);
+ component->argument1.d = word + fword;
+
+ /* Vary the Y offset. */
+
+ if (!(component->flags & 01))
+ word = component->argument2.b;
+ else
+ word = component->argument2.d;
+
+ fword = sfnt_mul_fixed_round (dy[i], scale);
+
+ /* Set the flag that says offsets are words. */
+ component->flags |= 01;
+ component->argument2.d = word + fword;
+ }
+
+ /* Apply the deltas for the two phantom points. */
+ distortion->origin += sfnt_mul_fixed_round (dx[i++], scale);
+ distortion->advance += sfnt_mul_fixed_round (dx[i], scale);
+ break;
+
+ default:
+ dx = sfnt_read_packed_deltas (data, end, point_count, &data);
+ dy = sfnt_read_packed_deltas (data, end, point_count, &data);
+
+ if (!dx || !dy)
+ goto fail3;
+
+ /* Deltas are only applied for each point number read. */
+
+ for (i = 0; i < point_count; ++i)
+ {
+ /* Apply deltas to phantom points. */
+
+ if (glyph_points[i] == glyph->compound->num_components)
+ {
+ distortion->origin += sfnt_mul_fixed_round (dx[i], scale);
+ continue;
+ }
+
+ if (glyph_points[i] == glyph->compound->num_components + 1)
+ {
+ distortion->advance += sfnt_mul_fixed_round (dx[i], scale);
+ continue;
+ }
+
+ /* Make sure the point doesn't end up out of bounds. */
+ if (glyph_points[i] >= glyph->compound->num_components)
+ continue;
+
+ component = &glyph->compound->components[glyph_points[i]];
+
+ /* Check if the component uses deltas at all. */
+ if (!(component->flags & 02))
+ continue;
+
+ /* Vary the X offset. */
+
+ if (!(component->flags & 01))
+ word = component->argument1.b;
+ else
+ word = component->argument1.d;
+
+ fword = sfnt_mul_fixed_round (dx[i], scale);
+ component->argument1.d = word + fword;
+
+ /* Vary the Y offset. */
+
+ if (!(component->flags & 01))
+ word = component->argument2.b;
+ else
+ word = component->argument2.d;
+
+ fword = sfnt_mul_fixed_round (dy[i], scale);
+
+ /* Set the flag that says offsets are words. */
+ component->flags |= 01;
+ component->argument2.d = word + fword;
+ }
+
+ break;
+ }
+
+ xfree (dx);
+ xfree (dy);
+
+ if (local_points != (uint16_t *) -1)
+ xfree (local_points);
+ }
+
+ /* Return success. */
+
+ if (gvar->axis_count * sizeof *coords * 3 >= 1024 * 16)
+ xfree (coords);
+
+ if (points != (uint16_t *) -1)
+ xfree (points);
+
+ /* Set the glyph metrics distortion as well. */
+ glyph->advance_distortion = distortion->advance;
+ glyph->origin_distortion = distortion->origin;
+
+ return 0;
+
+ fail3:
+ xfree (dx);
+ xfree (dy);
+ xfree (local_points);
+ fail1:
+
+ if (gvar->axis_count * sizeof *coords * 3 >= 1024 * 16)
+ xfree (coords);
+
+ if (points != (uint16_t *) -1)
+ xfree (points);
+
+ return 1;
+}
+
+/* Vary the specified INTERPRETER's control value table using the
+ variations in BLEND's CVT variations table, then record the blend's
+ normalized coordinates and axis count in the interpreter.
+
+ The CVT table used to create INTERPRETER must be the same used
+ to read BLEND->cvar. If not, behavior is undefined. */
+
+TEST_STATIC void
+sfnt_vary_interpreter (struct sfnt_interpreter *interpreter,
+ struct sfnt_blend *blend)
+{
+ sfnt_fixed scale;
+ int i;
+ struct sfnt_tuple_variation *variation;
+ size_t ndeltas, j, index;
+ sfnt_f26dot6 delta;
+
+ /* Return if there's no cvar table. */
+ if (!blend->cvar)
+ return;
+
+ /* For each tuple in the cvar table... */
+ for (i = 0; i < (blend->cvar->tuple_count & 0x0fff); ++i)
+ {
+ /* See if the tuple applies. */
+ variation = &blend->cvar->variation[i];
+ scale = sfnt_compute_tuple_scale (blend,
+ variation->intermediate_start != NULL,
+ variation->coordinates,
+ variation->intermediate_start,
+ variation->intermediate_end);
+ if (!scale)
+ continue;
+
+ /* Figure out how many deltas there are. If variation->points,
+ there are num_points deltas. Otherwise, there are
+ interpreter->cvt->num_elements deltas. */
+
+ ndeltas = (variation->points
+ ? variation->num_points
+ : interpreter->cvt_size);
+
+ for (j = 0; j < ndeltas; ++j)
+ {
+ /* Figure out which CVT entry this applies to. */
+ index = variation->points ? variation->points[j] : j;
+
+ if (index > interpreter->cvt_size)
+ continue;
+
+ /* Multiply the delta by the interpreter scale factor and
+ then the tuple scale factor. */
+ delta = sfnt_mul_f26dot6_fixed (variation->deltas[j],
+ interpreter->scale);
+ delta = sfnt_mul_fixed_round (delta, scale);
+
+ /* Apply the delta to the control value table. */
+ interpreter->cvt[i] += delta;
+ }
+ }
+
+ interpreter->n_axis = blend->fvar->axis_count;
+ interpreter->norm_coords = blend->norm_coords;
+}
+
+
+
+/* OS/2 metadata retrieval.
+
+ A font's `OS/2' table incorporates some miscellaneous information
+ that is consulted by the font scaler on MS-Windows. Emacs requires
+ one fragment of this information: the font foundry name. */
+
+/* Read an OS/2 table from the given font FD. Use the table directory
+ provided in SUBTABLE.
+
+ Return the OS/2 table if successful, NULL otherwise. */
+
+TEST_STATIC struct sfnt_OS_2_table *
+sfnt_read_OS_2_table (int fd, struct sfnt_offset_subtable *subtable)
+{
+ struct sfnt_OS_2_table *OS_2;
+ struct sfnt_table_directory *directory;
+ ssize_t rc;
+ size_t minimum, wanted;
+
+ /* Search for the OS/2 table within SUBTABLE. */
+
+ directory = sfnt_find_table (subtable, SFNT_TABLE_OS_2);
+
+ if (!directory)
+ return NULL;
+
+ /* Calculate how large the table must be. The field `panose' is the
+ last field aligned to natural boundaries, and thus contents must
+ be read twice: once to populate the table with information up to
+ `panose', and once again to retrieve the information
+ afterwards. */
+
+ minimum = (SFNT_ENDOF (struct sfnt_OS_2_table, panose,
+ unsigned char[10])
+ + SFNT_ENDOF (struct sfnt_OS_2_table, fs_last_char_index,
+ uint16_t)
+ - offsetof (struct sfnt_OS_2_table, ul_unicode_range));
+
+ /* If the table is too short, return. */
+ if (directory->length < minimum)
+ return NULL;
+
+ /* Seek to the location given in the directory. */
+ if (lseek (fd, directory->offset, SEEK_SET) == (off_t) -1)
+ return NULL;
+
+ OS_2 = xmalloc (sizeof *OS_2);
+
+ /* Read data up to the end of `panose'. */
+
+ wanted = SFNT_ENDOF (struct sfnt_OS_2_table, panose,
+ unsigned char[10]);
+ rc = read (fd, OS_2, wanted);
+
+ if (rc == -1 || rc != wanted)
+ {
+ xfree (OS_2);
+ return NULL;
+ }
+
+ /* Byte swap that data. */
+
+ sfnt_swap16 (&OS_2->version);
+ sfnt_swap16 (&OS_2->x_avg_char_width);
+ sfnt_swap16 (&OS_2->us_weight_class);
+ sfnt_swap16 (&OS_2->us_width_class);
+ sfnt_swap16 (&OS_2->fs_type);
+ sfnt_swap16 (&OS_2->y_subscript_x_size);
+ sfnt_swap16 (&OS_2->y_subscript_y_size);
+ sfnt_swap16 (&OS_2->y_subscript_x_offset);
+ sfnt_swap16 (&OS_2->y_subscript_y_offset);
+ sfnt_swap16 (&OS_2->y_superscript_x_size);
+ sfnt_swap16 (&OS_2->y_superscript_y_size);
+ sfnt_swap16 (&OS_2->y_superscript_x_offset);
+ sfnt_swap16 (&OS_2->y_superscript_y_offset);
+ sfnt_swap16 (&OS_2->y_strikeout_size);
+ sfnt_swap16 (&OS_2->y_strikeout_position);
+ sfnt_swap16 (&OS_2->s_family_class);
+
+ /* Read fields between ul_unicode_range and fs_last_char_index. */
+ wanted = (SFNT_ENDOF (struct sfnt_OS_2_table, fs_last_char_index,
+ uint16_t)
+ - offsetof (struct sfnt_OS_2_table, ul_unicode_range));
+ rc = read (fd, &OS_2->ul_unicode_range, wanted);
+
+ if (rc == -1 || rc != wanted)
+ {
+ xfree (OS_2);
+ return NULL;
+ }
+
+ /* Swap the remainder and return the table. */
+ sfnt_swap32 (&OS_2->ul_unicode_range[0]);
+ sfnt_swap32 (&OS_2->ul_unicode_range[1]);
+ sfnt_swap32 (&OS_2->ul_unicode_range[2]);
+ sfnt_swap32 (&OS_2->ul_unicode_range[3]);
+ sfnt_swap16 (&OS_2->fs_selection);
+ sfnt_swap16 (&OS_2->fs_first_char_index);
+ sfnt_swap16 (&OS_2->fs_last_char_index);
+ return OS_2;
+}
+
+
+
+/* PostScript metadata retrieval.
+
+ TrueType fonts electively incorporate a table of miscellaneous
+ information concerning such matters as the underline position or
+ whether the font is fixed pitch. This table also assigns
+ human-readable names to glyphs, subject to the table format, but
+ these names are not read by the functions defined below. */
+
+/* Read the header of a post table from the given font FD. Refer to
+ the table directory SUBTABLE for its location.
+
+ Return the post table header if successful, NULL otherwise. */
+
+TEST_STATIC struct sfnt_post_table *
+sfnt_read_post_table (int fd, struct sfnt_offset_subtable *subtable)
+{
+ struct sfnt_post_table *post;
+ struct sfnt_table_directory *directory;
+ ssize_t rc;
+
+ /* Search for the post table within SUBTABLE. */
+
+ directory = sfnt_find_table (subtable, SFNT_TABLE_POST);
+
+ if (!directory)
+ return NULL;
+
+ /* Although the size of the table is affected by its format, this
+ function is meant to read only its header; guarantee that the
+ directory is that large. */
+
+ if (directory->length < sizeof *post)
+ return NULL;
+
+ /* Seek to the location given in the directory. */
+ if (lseek (fd, directory->offset, SEEK_SET) == (off_t) -1)
+ return NULL;
+
+ post = xmalloc (sizeof *post);
+ rc = read (fd, post, sizeof *post);
+
+ if (rc == -1 || rc != sizeof *post)
+ {
+ xfree (post);
+ return NULL;
+ }
+
+ /* Byte swap the data retrieved. */
+ sfnt_swap32 (&post->format);
+ sfnt_swap32 (&post->italic_angle);
+ sfnt_swap16 (&post->underline_position);
+ sfnt_swap16 (&post->underline_thickness);
+ sfnt_swap32 (&post->is_fixed_pitch);
+ sfnt_swap32 (&post->min_mem_type_42);
+ sfnt_swap32 (&post->max_mem_type_42);
+ sfnt_swap32 (&post->min_mem_type_1);
+ sfnt_swap32 (&post->max_mem_type_1);
+
+ return post;
+}
+
+
+
+#ifdef TEST
+
+struct sfnt_test_dcontext
+{
+ /* Context for sfnt_test_get_glyph. */
+ struct sfnt_glyf_table *glyf;
+ struct sfnt_loca_table_short *loca_short;
+ struct sfnt_loca_table_long *loca_long;
+ struct sfnt_hmtx_table *hmtx;
+ struct sfnt_hhea_table *hhea;
+ struct sfnt_maxp_table *maxp;
+ struct sfnt_blend *blend;
+};
+
+/* Global context for test functions. Height of glyph. */
+static sfnt_fixed sfnt_test_max;
+
+static void
+sfnt_test_move_to (struct sfnt_point point, void *dcontext)
+{
+ printf ("move_to: %g, %g\n", sfnt_coerce_fixed (point.x),
+ sfnt_coerce_fixed (point.y));
+}
+
+static void
+sfnt_test_line_to (struct sfnt_point point, void *dcontext)
+{
+ printf ("line_to: %g, %g\n", sfnt_coerce_fixed (point.x),
+ sfnt_coerce_fixed (point.y));
+}
+
+static void
+sfnt_test_curve_to (struct sfnt_point control,
+ struct sfnt_point endpoint,
+ void *dcontext)
+{
+ printf ("curve_to: %g, %g - %g, %g\n",
+ sfnt_coerce_fixed (control.x),
+ sfnt_coerce_fixed (control.y),
+ sfnt_coerce_fixed (endpoint.x),
+ sfnt_coerce_fixed (endpoint.y));
+}
+
+static struct sfnt_glyph *
+sfnt_test_get_glyph (sfnt_glyph id, void *dcontext,
+ bool *need_free)
+{
+ struct sfnt_test_dcontext *tables;
+ struct sfnt_glyph *glyph;
+ struct sfnt_metrics_distortion distortion;
+
+ tables = dcontext;
+ *need_free = true;
+
+ glyph = sfnt_read_glyph (id, tables->glyf,
+ tables->loca_short,
+ tables->loca_long);
+
+ if (tables->blend && glyph)
+ {
+ if (glyph->simple)
+ sfnt_vary_simple_glyph (tables->blend, id, glyph,
+ &distortion);
+ else
+ sfnt_vary_compound_glyph (tables->blend, id, glyph,
+ &distortion);
+ }
+
+ return glyph;
+}
+
+static void
+sfnt_test_free_glyph (struct sfnt_glyph *glyph, void *dcontext)
+{
+ sfnt_free_glyph (glyph);
+}
+
+static int
+sfnt_test_get_metrics (sfnt_glyph glyph, struct sfnt_glyph_metrics *metrics,
+ void *dcontext)
+{
+ struct sfnt_test_dcontext *tables;
+
+ tables = dcontext;
+ return sfnt_lookup_glyph_metrics (glyph, metrics,
+ tables->hmtx, tables->hhea,
+ tables->maxp);
+}
+
+static void
+sfnt_test_span (struct sfnt_edge *edge, sfnt_fixed y,
+ void *dcontext)
+{
+#if 1
+ printf ("/* span at %g */\n", sfnt_coerce_fixed (y));
+ for (; edge; edge = edge->next)
+ {
+ if (y >= edge->bottom && y < edge->top)
+ printf ("ctx.fillRect (%g, %g, 1, 1); "
+ "/* %g top: %g bot: %g stepx: %g winding: %d */\n",
+ sfnt_coerce_fixed (edge->x),
+ sfnt_coerce_fixed (sfnt_test_max - y),
+ sfnt_coerce_fixed (y),
+ sfnt_coerce_fixed (edge->top),
+ sfnt_coerce_fixed (edge->bottom),
+ sfnt_coerce_fixed (edge->step_x),
+ edge->winding);
+ else
+ printf ("STRIPPED BAD SPAN!!! %g %g %"PRIi32
+ " %"PRIi32" (winding: %d)\n",
+ sfnt_coerce_fixed (edge->top),
+ sfnt_coerce_fixed (edge->bottom),
+ edge->top, y, edge->winding);
+ }
+#elif 0
+ int winding;
+ short x, dx;
+
+ winding = 0;
+ x = 0;
+
+ for (; edge; edge = edge->next)
+ {
+ dx = (edge->x >> 16) - x;
+ x = edge->x >> 16;
+
+ for (; dx > 0; --dx)
+ putc (winding ? '.' : ' ', stdout);
+
+ winding = !winding;
+ }
+
+ putc ('\n', stdout);
+#elif 0
+ for (; edge; edge = edge->next)
+ printf ("%g-", sfnt_coerce_fixed (edge->x));
+ puts ("");
+#endif
+}
+
+static void
+sfnt_test_edge_ignore (struct sfnt_edge *edges, size_t num_edges,
+ void *dcontext)
+{
+
+}
+
+/* The same debugger stuff is used here. */
+static void sfnt_setup_debugger (void);
+
+/* The debugger's X display. */
+static Display *display;
+
+/* The debugger window. */
+static Window window;
+
+/* The GC. */
+static GC point_gc, background_gc;
+
+static void
+sfnt_test_edges (struct sfnt_edge *edges, size_t num_edges)
+{
+ static sfnt_fixed y;
+ size_t i;
+
+ for (i = 0; i < num_edges; ++i)
+ {
+ if (y >= edges[i].bottom && y < edges[i].top)
+ {
+ XDrawPoint (display, window, point_gc,
+ edges[i].x / 65536, 100 - (y / 65536));
+ printf ("sfnt_test_edges: %d %d\n",
+ edges[i].x / 65536, 100 - (y / 65536));
+ }
+ }
+
+ y += SFNT_POLY_STEP;
+
+ for (i = 0; i < num_edges; ++i)
+ sfnt_step_edge (&edges[i]);
+}
+
+static void
+sfnt_debug_edges (struct sfnt_edge *edges, size_t num_edges)
+{
+ XEvent event;
+
+ sfnt_setup_debugger ();
+
+ while (true)
+ {
+ XNextEvent (display, &event);
+
+ switch (event.type)
+ {
+ case KeyPress:
+ XDestroyWindow (display, window);
+ XCloseDisplay (display);
+ exit (0);
+ break;
+
+ case Expose:
+
+ while (true)
+ {
+ sfnt_test_edges (edges, num_edges);
+ XFlush (display);
+ usleep (50000);
+ }
+
+ break;
+ }
+ }
+}
+
+static void
+sfnt_test_edge (struct sfnt_edge *edges, size_t num_edges,
+ void *dcontext)
+{
+ size_t i;
+
+ printf ("built %zu edges\n", num_edges);
+
+ for (i = 0; i < num_edges; ++i)
+ {
+ printf ("/* edge x, top, bot: %g, %g - %g. winding: %d */\n"
+ "/* edge step_x: %g */\n",
+ sfnt_coerce_fixed (edges[i].x),
+ sfnt_coerce_fixed (edges[i].top),
+ sfnt_coerce_fixed (edges[i].bottom),
+ edges[i].winding,
+ sfnt_coerce_fixed (edges[i].step_x));
+#ifdef TEST_VERTEX
+ printf ("ctx.fillRect (%g, %g, 1, 1);\n",
+ sfnt_coerce_fixed (edges[i].x),
+ sfnt_coerce_fixed (sfnt_test_max
+ - edges[i].y));
+#else
+ printf ("ctx.fillRect (%g, %g, 1, 1);\n",
+ sfnt_coerce_fixed (edges[i].x),
+ sfnt_coerce_fixed (sfnt_test_max
+ - edges[i].bottom));
+#endif
+ }
+
+ if (getenv ("SFNT_DEBUG_STEP"))
+ {
+ if (!fork ())
+ sfnt_debug_edges (edges, num_edges);
+ }
+
+ printf ("==end of edges==\n");
+
+ sfnt_poly_edges (edges, num_edges, sfnt_test_span, NULL);
+}
+
+static void
+sfnt_x_raster (struct sfnt_raster **rasters,
+ int *advances,
+ int nrasters,
+ struct sfnt_hhea_table *hhea,
+ sfnt_fixed scale)
+{
+ Display *display;
+ Window window;
+ Pixmap *pixmaps;
+ Picture *glyphs, drawable, solid;
+ int event_base, error_base;
+ int major, minor, *depths, count;
+ XRenderPictFormat *format, *glyph_format;
+ Visual *visual;
+ XImage image;
+ GC gc;
+ XGCValues gcvalues;
+ XEvent event;
+ XRenderColor white, black;
+ int i, ascent, origin, x, y;
+ Font font;
+
+ if (!nrasters)
+ exit (0);
+
+ display = XOpenDisplay (NULL);
+
+ if (!display)
+ exit (0);
+
+ if (!XRenderQueryExtension (display, &event_base, &error_base)
+ || !XRenderQueryVersion (display, &major, &minor))
+ exit (0);
+
+ if (major == 0 && minor < 10)
+ exit (0);
+
+ window = XCreateSimpleWindow (display, DefaultRootWindow (display),
+ 0, 0, 100, 150, 0, 0,
+ WhitePixel (display,
+ DefaultScreen (display)));
+ XSelectInput (display, window, ExposureMask);
+ XMapWindow (display, window);
+
+ visual = DefaultVisual (display, DefaultScreen (display));
+ format = XRenderFindVisualFormat (display, visual);
+
+ if (!format)
+ exit (0);
+
+ glyph_format = XRenderFindStandardFormat (display, PictStandardA8);
+ depths = XListDepths (display, DefaultScreen (display), &count);
+
+ for (i = 0; i < count; ++i)
+ {
+ if (depths[i] == 8)
+ goto depth_found;
+ }
+
+ exit (0);
+
+ depth_found:
+
+ XFree (depths);
+ pixmaps = alloca (sizeof *pixmaps * nrasters);
+ glyphs = alloca (sizeof *glyphs * nrasters);
+ gc = None;
+
+ for (i = 0; i < nrasters; ++i)
+ {
+ pixmaps[i] = XCreatePixmap (display, DefaultRootWindow (display),
+ rasters[i]->width, rasters[i]->height, 8);
+ if (!gc)
+ gc = XCreateGC (display, pixmaps[i], 0, &gcvalues);
+
+ /* Upload the raster. */
+ image.width = rasters[i]->width;
+ image.height = rasters[i]->height;
+ image.xoffset = 0;
+ image.format = ZPixmap;
+ image.data = (char *) rasters[i]->cells;
+ image.byte_order = MSBFirst;
+ image.bitmap_unit = 8;
+ image.bitmap_bit_order = LSBFirst;
+ image.bitmap_pad = SFNT_POLY_ALIGNMENT * 8;
+ image.depth = 8;
+ image.bytes_per_line = rasters[i]->stride;
+ image.bits_per_pixel = 8;
+ image.red_mask = 0;
+ image.green_mask = 0;
+ image.blue_mask = 0;
+
+ if (!XInitImage (&image))
+ abort ();
+
+ XPutImage (display, pixmaps[i], gc, &image,
+ 0, 0, 0, 0, image.width, image.height);
+
+ glyphs[i] = XRenderCreatePicture (display, pixmaps[i],
+ glyph_format, 0, NULL);
+ }
+
+ XFreeGC (display, gc);
+
+ font = XLoadFont (display, "6x13");
+
+ if (!font)
+ exit (1);
+
+ gcvalues.font = font;
+ gcvalues.foreground = BlackPixel (display, DefaultScreen (display));
+ gc = XCreateGC (display, window, GCForeground | GCFont, &gcvalues);
+
+ drawable = XRenderCreatePicture (display, window, format,
+ 0, NULL);
+ memset (&black, 0, sizeof black);
+ black.alpha = 65535;
+
+ solid = XRenderCreateSolidFill (display, &black);
+
+ while (true)
+ {
+ XNextEvent (display, &event);
+
+ if (event.type == Expose)
+ {
+ white.red = 65535;
+ white.green = 65535;
+ white.blue = 65535;
+ white.alpha = 65535;
+
+ /* Clear the background. */
+ XRenderFillRectangle (display, PictOpSrc, drawable,
+ &white, 0, 0, 65535, 65535);
+
+ /* Compute ascent line. */
+ ascent = sfnt_mul_fixed (hhea->ascent * 65536,
+ scale) / 65536;
+
+ origin = 5;
+
+ for (i = 0; i < nrasters; ++i)
+ {
+ /* Compute the base position. */
+ x = origin + rasters[i]->offx;
+ y = ascent - rasters[i]->height - rasters[i]->offy;
+
+ /* Draw the solid fill with the glyph as clip mask. */
+ XRenderComposite (display, PictOpOver, solid, glyphs[i],
+ drawable, 0, 0, 0, 0, x, y,
+ rasters[i]->width, rasters[i]->height);
+
+ origin += advances[i];
+ }
+ }
+ }
+}
+
+static void
+sfnt_test_raster (struct sfnt_raster *raster,
+ struct sfnt_hhea_table *hhea,
+ sfnt_fixed scale)
+{
+ int x, y, i;
+
+ for (y = 0; y < raster->height; ++y)
+ {
+ for (x = 0; x < raster->width; ++x)
+ printf ("%3d ", (int) raster->cells[y * raster->stride + x]);
+ puts ("");
+ }
+
+ if (hhea && getenv ("SFNT_X"))
+ {
+ i = 0;
+
+ if (!fork ())
+ sfnt_x_raster (&raster, &i, 1, hhea, scale);
+ }
+}
+
+
+
+/* Instruction execution tests. */
+
+static struct sfnt_maxp_table test_interpreter_profile =
+ {
+ 0x00010000,
+ 650,
+ 100,
+ 100,
+ 100,
+ 100,
+ 2,
+ 100,
+ 255,
+ 12,
+ 12,
+ 100,
+ 5000,
+ 100,
+ 1,
+ };
+
+static sfnt_fword test_cvt_values[] =
+ {
+ 100, 100, -100, -100, 50, 50, 50, 50, 0, 0,
+ };
+
+static struct sfnt_cvt_table test_interpreter_cvt =
+ {
+ 10,
+ test_cvt_values,
+ };
+
+static struct sfnt_head_table test_interpreter_head =
+ {
+ 0x00010000,
+ 0x00010000,
+ 0,
+ 0x5f0f3cf5,
+ 0,
+ 800,
+ 0,
+ 0,
+ 0,
+ 0,
+ -312,
+ -555,
+ 1315,
+ 2163,
+ 0,
+ 12,
+ 0,
+ 0,
+ 0,
+ };
+
+static struct sfnt_interpreter *
+sfnt_make_test_interpreter (void)
+{
+ return sfnt_make_interpreter (&test_interpreter_profile,
+ &test_interpreter_cvt,
+ &test_interpreter_head,
+ NULL, 17, 17);
+}
+
+struct sfnt_interpreter_test
+{
+ const char *name;
+ unsigned char *instructions;
+ int num_instructions;
+ void *arg;
+ void (*check) (struct sfnt_interpreter *, void *, bool);
+};
+
+static void
+sfnt_run_interpreter_test (struct sfnt_interpreter_test *test,
+ struct sfnt_interpreter *interpreter)
+{
+ fprintf (stderr, "Testing %s: ", test->name);
+
+ if (setjmp (interpreter->trap))
+ test->check (interpreter, test->arg, true);
+ else
+ {
+ interpreter->IP = 0;
+ interpreter->SP = interpreter->stack;
+ interpreter->instructions = test->instructions;
+ interpreter->num_instructions = test->num_instructions;
+
+ sfnt_interpret_run (interpreter, SFNT_RUN_CONTEXT_TEST);
+ test->check (interpreter, test->arg, false);
+ }
+}
+
+struct sfnt_generic_test_args
+{
+ uint32_t *expected_stack;
+ int expected_stack_elements;
+ bool expected_trap;
+ int expected_IP;
+};
+
+static void
+sfnt_generic_check (struct sfnt_interpreter *interpreter,
+ void *arg, bool trap)
+{
+ struct sfnt_generic_test_args *args;
+ int i;
+
+ args = arg;
+
+ if (((interpreter->SP - interpreter->stack)
+ != args->expected_stack_elements))
+ {
+ fprintf (stderr,
+ "failed at IP %d:%d (expected %d stack elements,"
+ " got %td); last trap string: %s\n",
+ interpreter->call_depth, interpreter->IP,
+ args->expected_stack_elements,
+ interpreter->SP - interpreter->stack,
+ ((trap && interpreter->trap_reason)
+ ? interpreter->trap_reason
+ : "NULL"));
+
+ for (i = 0; i < interpreter->SP - interpreter->stack; ++i)
+ fprintf (stderr, "%8d ", (int) interpreter->stack[i]);
+ fprintf (stderr, "\n");
+ return;
+ }
+
+ if (memcmp (interpreter->stack, args->expected_stack,
+ ((char *) interpreter->SP
+ - (char *) interpreter->stack)))
+ {
+ fprintf (stderr, "failed (inconsistent stack elements)\n"
+ "machine stack ------------------------->\n");
+
+ for (i = 0; i < args->expected_stack_elements; ++i)
+ fprintf (stderr, "%8d ", (int) interpreter->stack[i]);
+
+ fprintf (stderr,
+ "\nexpected stack ------------------------>\n");
+
+ for (i = 0; i < args->expected_stack_elements; ++i)
+ fprintf (stderr, "%8d ", (int) args->expected_stack[i]);
+
+ fprintf (stderr, "\n");
+ return;
+ }
+
+ if (args->expected_IP != -1
+ && interpreter->IP != args->expected_IP)
+ {
+ fprintf (stderr, "failed (IP is %d, not %d)\n",
+ interpreter->IP, args->expected_IP);
+ return;
+ }
+
+ if (trap)
+ {
+ if (args->expected_trap)
+ fprintf (stderr, "passed (with trap %s)\n",
+ interpreter->trap_reason);
+ else
+ fprintf (stderr, "failed (unexpected trap %s)\n",
+ interpreter->trap_reason);
+
+ return;
+ }
+
+ if (args->expected_trap)
+ fprintf (stderr, "failed, trap not encountered\n");
+ else
+ fprintf (stderr, "passed\n");
+
+ return;
+}
+
+static void
+sfnt_check_srp0 (struct sfnt_interpreter *interpreter,
+ void *arg, bool trap)
+{
+ if (trap)
+ {
+ fprintf (stderr, "failed (unexpected trap %s)\n",
+ interpreter->trap_reason);
+ return;
+ }
+
+ if (interpreter->state.rp0 != 0)
+ {
+ fprintf (stderr, "failed, rp0 is not 0, but %d\n",
+ interpreter->state.rp0);
+ return;
+ }
+
+ if (interpreter->state.rp1 != 1)
+ {
+ fprintf (stderr, "failed, rp1 is not 1, but %d\n",
+ interpreter->state.rp1);
+ return;
+ }
+
+ if (interpreter->state.rp2 != 2)
+ {
+ fprintf (stderr, "failed, rp2 is not 2, but %d\n",
+ interpreter->state.rp2);
+ return;
+ }
+
+ if (interpreter->SP != interpreter->stack)
+ {
+ fprintf (stderr, "failed, stack not empty\n");
+ return;
+ }
+
+ fprintf (stderr, "passed\n");
+ return;
+}
+
+static void
+sfnt_check_szp0 (struct sfnt_interpreter *interpreter,
+ void *arg, bool trap)
+{
+ if (!trap)
+ {
+ fprintf (stderr, "failed, expected trap\n");
+ return;
+ }
+
+ if (interpreter->state.zp0 != 1
+ || interpreter->state.zp1 != 1
+ || interpreter->state.zp2 != 0)
+ {
+ fprintf (stderr,
+ "failed, unexpected values of zone pointers: %d %d %d\n",
+ interpreter->state.zp0, interpreter->state.zp1,
+ interpreter->state.zp2);
+ return;
+ }
+
+ if (interpreter->SP != interpreter->stack)
+ {
+ fprintf (stderr, "failed, stack not empty\n");
+ return;
+ }
+
+ fprintf (stderr, "passed with expected trap %s\n",
+ interpreter->trap_reason);
+ return;
+}
+
+static void
+sfnt_check_sloop (struct sfnt_interpreter *interpreter,
+ void *arg, bool trap)
+{
+ if (interpreter->state.loop != 1)
+ {
+ /* The trap should've restored GS->loop to 1. */
+ fprintf (stderr, "failed, GS->loop should be 1, not %d\n",
+ interpreter->state.loop);
+ return;
+ }
+
+ if (!trap)
+ {
+ fprintf (stderr, "failed, expected trap\n");
+ return;
+ }
+
+ if (interpreter->SP != interpreter->stack)
+ {
+ fprintf (stderr, "failed, stack not empty\n");
+ return;
+ }
+
+ fprintf (stderr, "passed with expected trap %s\n",
+ interpreter->trap_reason);
+ return;
+}
+
+struct sfnt_rounding_test_args
+{
+ sfnt_f26dot6 value;
+};
+
+static void
+sfnt_check_rounding (struct sfnt_interpreter *interpreter,
+ void *arg, bool trap)
+{
+ sfnt_f26dot6 value;
+ struct sfnt_rounding_test_args *args;
+
+ if (trap)
+ {
+ fprintf (stderr, "failed, unexpected trap: %s\n",
+ interpreter->trap_reason);
+ return;
+ }
+
+ if (interpreter->SP == interpreter->stack)
+ {
+ fprintf (stderr, "failed, empty stack\n");
+ return;
+ }
+
+ value = *(interpreter->SP - 1);
+ args = arg;
+
+ if (value != args->value)
+ {
+ fprintf (stderr, "failed. value is: %d %d, but wanted: %d %d\n",
+ value >> 6, value & 63, args->value >> 6,
+ args->value & 63);
+ return;
+ }
+
+ fprintf (stderr, "passed, expected value %d\n", value);
+ return;
+}
+
+static void
+sfnt_check_smd (struct sfnt_interpreter *interpreter,
+ void *arg, bool trap)
+{
+ if (trap)
+ {
+ fprintf (stderr, "failed, unexpected trap\n");
+ return;
+ }
+
+ if (interpreter->state.minimum_distance != 32)
+ {
+ fprintf (stderr, "failed, expected minimum distance"
+ " of 32, got %d\n",
+ interpreter->state.minimum_distance);
+ return;
+ }
+
+ fprintf (stderr, "passed\n");
+ return;
+}
+
+static void
+sfnt_check_scvtci (struct sfnt_interpreter *interpreter,
+ void *arg, bool trap)
+{
+ if (trap)
+ {
+ fprintf (stderr, "failed, unexpected trap\n");
+ return;
+ }
+
+ if (interpreter->state.cvt_cut_in != 128)
+ {
+ fprintf (stderr, "failed, expected 128, got %d\n",
+ interpreter->state.cvt_cut_in);
+ return;
+ }
+
+ fprintf (stderr, "passed\n");
+ return;
+}
+
+static void
+sfnt_check_sswci (struct sfnt_interpreter *interpreter,
+ void *arg, bool trap)
+{
+ if (trap)
+ {
+ fprintf (stderr, "failed, unexpected trap\n");
+ return;
+ }
+
+ if (interpreter->state.sw_cut_in != 512)
+ {
+ fprintf (stderr, "failed, expected 512, got %d\n",
+ interpreter->state.sw_cut_in);
+ return;
+ }
+
+ fprintf (stderr, "passed\n");
+ return;
+}
+
+static void
+sfnt_check_ssw (struct sfnt_interpreter *interpreter,
+ void *arg, bool trap)
+{
+ if (trap)
+ {
+ fprintf (stderr, "failed, unexpected trap\n");
+ return;
+ }
+
+ if (interpreter->state.single_width_value
+ != sfnt_mul_f26dot6_fixed (-1, interpreter->scale))
+ {
+ fprintf (stderr, "failed, got %d at scale %d,"
+ " expected %d\n",
+ interpreter->state.single_width_value,
+ interpreter->scale,
+ sfnt_mul_f26dot6_fixed (-1, interpreter->scale));
+ return;
+ }
+
+ fprintf (stderr, "passed\n");
+ return;
+}
+
+static void
+sfnt_check_flipon (struct sfnt_interpreter *interpreter,
+ void *arg, bool trap)
+{
+ if (trap)
+ {
+ fprintf (stderr, "failed, unexpected trap\n");
+ return;
+ }
+
+ if (!interpreter->state.auto_flip)
+ fprintf (stderr, "failed, auto flip not enabled\n");
+ else
+ fprintf (stderr, "pass\n");
+
+ return;
+}
+
+static void
+sfnt_check_flipoff (struct sfnt_interpreter *interpreter,
+ void *arg, bool trap)
+{
+ if (trap)
+ {
+ fprintf (stderr, "failed, unexpected trap\n");
+ return;
+ }
+
+ if (interpreter->state.auto_flip)
+ fprintf (stderr, "failed, auto flip not disabled\n");
+ else
+ fprintf (stderr, "pass\n");
+
+ return;
+}
+
+static void
+sfnt_check_sdb (struct sfnt_interpreter *interpreter,
+ void *arg, bool trap)
+{
+ if (trap)
+ {
+ fprintf (stderr, "failed, unexpected trap %s\n",
+ interpreter->trap_reason);
+ return;
+ }
+
+ if (interpreter->state.delta_base != 8)
+ fprintf (stderr, "failed, delta base is %d, not 8\n",
+ interpreter->state.delta_base);
+ else
+ fprintf (stderr, "pass\n");
+
+ return;
+}
+
+static void
+sfnt_check_sds (struct sfnt_interpreter *interpreter,
+ void *arg, bool trap)
+{
+ if (trap)
+ {
+ fprintf (stderr, "failed, unexpected trap %s\n",
+ interpreter->trap_reason);
+ return;
+ }
+
+ if (interpreter->state.delta_shift != 1)
+ fprintf (stderr, "failed, delta shift is %d, not 1\n",
+ interpreter->state.delta_shift);
+ else
+ fprintf (stderr, "pass\n");
+
+ return;
+}
+
+static void
+sfnt_check_scanctrl (struct sfnt_interpreter *interpreter,
+ void *arg, bool trap)
+{
+ if (trap)
+ {
+ fprintf (stderr, "failed, unexpected trap %s\n",
+ interpreter->trap_reason);
+ return;
+ }
+
+ if (interpreter->SP != interpreter->stack)
+ {
+ fprintf (stderr, "failed, expected empty stack\n");
+ return;
+ }
+
+ if (interpreter->state.scan_control != 1)
+ fprintf (stderr, "failed, scan control is %d, not 1\n",
+ interpreter->state.scan_control);
+ else
+ fprintf (stderr, "pass\n");
+
+ return;
+}
+
+static void
+sfnt_check_instctrl (struct sfnt_interpreter *interpreter,
+ void *arg, bool trap)
+{
+ if (trap)
+ {
+ fprintf (stderr, "failed, unexpected trap %s\n",
+ interpreter->trap_reason);
+ return;
+ }
+
+ if (interpreter->SP != interpreter->stack)
+ {
+ fprintf (stderr, "failed, expected empty stack\n");
+ return;
+ }
+
+ if (interpreter->state.instruct_control != 2)
+ fprintf (stderr, "failed, inst control is %d, not 2\n",
+ interpreter->state.instruct_control);
+ else
+ fprintf (stderr, "pass\n");
+
+ return;
+}
+
+static struct sfnt_generic_test_args npushb_test_args =
+ {
+ (uint32_t []) { 1U, 2U, 3U, 4U, },
+ 4,
+ true,
+ 6,
+ };
+
+static struct sfnt_generic_test_args npushw_test_args =
+ {
+ (uint32_t []) { 0x101U, 0x202U, 0x303U, 0x404U, },
+ 4,
+ true,
+ 10,
+ };
+
+static struct sfnt_generic_test_args pushb_test_args =
+ {
+ (uint32_t []) { 1U, 2U, 3U, 4U, 5U, 6U, 7U, 8U,
+ 1U, },
+ 9,
+ true,
+ 11,
+ };
+
+static struct sfnt_generic_test_args pushw_test_args =
+ {
+ (uint32_t []) { 0x203U, 0x204U, 0x205U, 0x206U, 0x207U, 0x208U,
+ 0x909U, 0x909U, (uint32_t) -1, },
+ 9,
+ true,
+ 20,
+ };
+
+static struct sfnt_generic_test_args stack_overflow_test_args =
+ {
+ NULL,
+ 0,
+ true,
+ 0,
+ };
+
+static struct sfnt_generic_test_args stack_underflow_test_args =
+ {
+ NULL,
+ 0,
+ true,
+ 4,
+ };
+
+static struct sfnt_rounding_test_args rtg_test_args =
+ {
+ 64,
+ };
+
+static struct sfnt_rounding_test_args rtg_symmetric_test_args =
+ {
+ -64,
+ };
+
+static struct sfnt_rounding_test_args rtg_1_test_args =
+ {
+ 0,
+ };
+
+static struct sfnt_rounding_test_args rtg_1_symmetric_test_args =
+ {
+ 0,
+ };
+
+static struct sfnt_rounding_test_args rthg_test_args =
+ {
+ 32,
+ };
+
+static struct sfnt_rounding_test_args rthg_1_test_args =
+ {
+ 96,
+ };
+
+static struct sfnt_rounding_test_args rtdg_test_args =
+ {
+ 32,
+ };
+
+static struct sfnt_rounding_test_args rtdg_1_test_args =
+ {
+ 0,
+ };
+
+static struct sfnt_rounding_test_args rtdg_2_test_args =
+ {
+ 32,
+ };
+
+static struct sfnt_rounding_test_args rtdg_3_test_args =
+ {
+ 64,
+ };
+
+static struct sfnt_generic_test_args else_test_args =
+ {
+ (uint32_t []) { 77U, 90U, 83U, },
+ 3,
+ false,
+ 40,
+ };
+
+static struct sfnt_generic_test_args jmpr_test_args =
+ {
+ /* What ends up on the stack?
+
+ First, there are the three words that the first PUSHW[2]
+ instruction has pushed:
+
+ 0, 0xb2, -3
+
+ After those three words are pushed, JMPR[] is called, and pops an
+ offset:
+
+ -3
+
+ so now the stack is:
+
+ 0, 0xb2
+
+ as a result of the relative jump, IP is now at the least
+ significant byte of the word inside what was originally a
+ PUSHW[2] instruction, 0xb2, which itself is PUSHB[2]!
+
+ As a result of that instruction, three more bytes, including
+ JMPR[] itself are pushed onto the stack, making it:
+
+ 0, 0xb2, 255, 253, 0x1c
+
+ Then, execution continues as usual. 4 is pushed on to the
+ stack, making it:
+
+ 0, 0xb2, 255, 253, 0x1c, 4
+
+ Another JMPR[] pops:
+
+ 4
+
+ making the stack:
+
+ 0, 0xb2, 255, 253, 0x1c
+
+ And skips the next three padding bytes, finally reaching a
+ PUSHW[0] instruction which pushes -30 onto the stack:
+
+ 0, 0xb2, 255, 253, 0x1c, -30
+
+ and a JMPR[] instruction, which pops:
+
+ -30
+
+ making:
+
+ 0, 0xb2, 255, 253,
+
+ and subsequently traps, as -30 would underflow the instruction
+ stream. */
+ (uint32_t []) { 0, 0xb2, 255, 253, 0x1c, },
+ 5,
+ true,
+ 17,
+ };
+
+static struct sfnt_generic_test_args dup_test_args =
+ {
+ NULL,
+ 0,
+ true,
+ 5,
+ };
+
+static struct sfnt_generic_test_args pop_test_args =
+ {
+ (uint32_t []) { 70, 70, },
+ 2,
+ false,
+ 5,
+ };
+
+static struct sfnt_generic_test_args clear_test_args =
+ {
+ NULL,
+ 0,
+ false,
+ 10,
+ };
+
+static struct sfnt_generic_test_args swap_test_args =
+ {
+ (uint32_t []) { 2, 1, },
+ 2,
+ false,
+ 4,
+ };
+
+static struct sfnt_generic_test_args depth_test_args =
+ {
+ (uint32_t []) { 3, 3, 3, 3, },
+ 4,
+ false,
+ 5,
+ };
+
+static struct sfnt_generic_test_args cindex_test_args =
+ {
+ (uint32_t []) { 0, 3, 3, 4, 0, },
+ 5,
+ true,
+ 10,
+ };
+
+static struct sfnt_generic_test_args mindex_test_args =
+ {
+ (uint32_t []) { 0, 3, 7, 4, 4, },
+ 5,
+ false,
+ 10,
+ };
+
+static struct sfnt_generic_test_args raw_test_args =
+ {
+ NULL,
+ 0,
+ true,
+ 0,
+ };
+
+static struct sfnt_generic_test_args loopcall_test_args =
+ {
+ (uint32_t []) { 10, },
+ 1,
+ false,
+ 12,
+ };
+
+static struct sfnt_generic_test_args call_test_args =
+ {
+ (uint32_t []) { 11, },
+ 1,
+ true,
+ 2,
+ };
+
+static struct sfnt_generic_test_args fdef_test_args =
+ {
+ NULL,
+ 0,
+ true,
+ 4,
+ };
+
+static struct sfnt_generic_test_args fdef_1_test_args =
+ {
+ NULL,
+ 0,
+ true,
+ 9,
+ };
+
+static struct sfnt_generic_test_args endf_test_args =
+ {
+ NULL,
+ 0,
+ true,
+ 0,
+ };
+
+static struct sfnt_generic_test_args ws_test_args =
+ {
+ (uint32_t []) { 40, },
+ 1,
+ true,
+ 10,
+ };
+
+static struct sfnt_generic_test_args rs_test_args =
+ {
+ NULL,
+ 0,
+ true,
+ 2,
+ };
+
+static struct sfnt_generic_test_args wcvtp_test_args =
+ {
+ (uint32_t []) { 32, },
+ 1,
+ true,
+ 10,
+ };
+
+static struct sfnt_generic_test_args rcvt_test_args =
+ {
+ (uint32_t []) { 136, },
+ 1,
+ true,
+ 5,
+ };
+
+static struct sfnt_generic_test_args mppem_test_args =
+ {
+ (uint32_t []) { 17, },
+ 1,
+ false,
+ 1,
+ };
+
+static struct sfnt_generic_test_args mps_test_args =
+ {
+ (uint32_t []) { 17, },
+ 1,
+ false,
+ 1,
+ };
+
+static struct sfnt_generic_test_args debug_test_args =
+ {
+ NULL,
+ 0,
+ false,
+ 3,
+ };
+
+static struct sfnt_generic_test_args lt_test_args =
+ {
+ (uint32_t []) { 1, 0, 0, },
+ 3,
+ false,
+ 12,
+ };
+
+static struct sfnt_generic_test_args lteq_test_args =
+ {
+ (uint32_t []) { 1, 0, 1, },
+ 3,
+ false,
+ 12,
+ };
+
+static struct sfnt_generic_test_args gt_test_args =
+ {
+ (uint32_t []) { 0, 1, 0, },
+ 3,
+ false,
+ 12,
+ };
+
+static struct sfnt_generic_test_args gteq_test_args =
+ {
+ (uint32_t []) { 0, 1, 1, },
+ 3,
+ false,
+ 12,
+ };
+
+static struct sfnt_generic_test_args eq_test_args =
+ {
+ (uint32_t []) { 0, 1, 0, },
+ 3,
+ false,
+ 18,
+ };
+
+static struct sfnt_generic_test_args neq_test_args =
+ {
+ (uint32_t []) { 1, 0, 1, },
+ 3,
+ false,
+ 18,
+ };
+
+static struct sfnt_generic_test_args odd_test_args =
+ {
+ (uint32_t []) { 1, 0, },
+ 2,
+ false,
+ 9,
+ };
+
+static struct sfnt_generic_test_args even_test_args =
+ {
+ (uint32_t []) { 0, 1, },
+ 2,
+ false,
+ 9,
+ };
+
+static struct sfnt_generic_test_args if_test_args =
+ {
+ (uint32_t []) { 17, 24, 1, 2, 3, 4, 5, -1, -1,
+ 88, 1, 3, },
+ 12,
+ false,
+ 185,
+ };
+
+static struct sfnt_generic_test_args eif_test_args =
+ {
+ NULL,
+ 0,
+ false,
+ 3,
+ };
+
+static struct sfnt_generic_test_args and_test_args =
+ {
+ (uint32_t []) { 0, 0, 1, 0, },
+ 4,
+ false,
+ 16,
+ };
+
+static struct sfnt_generic_test_args or_test_args =
+ {
+ (uint32_t []) { 1, 1, 1, 0, },
+ 4,
+ false,
+ 16,
+ };
+
+static struct sfnt_generic_test_args not_test_args =
+ {
+ (uint32_t []) { 0, 1, },
+ 2,
+ false,
+ 6,
+ };
+
+static struct sfnt_generic_test_args sds_test_args =
+ {
+ NULL,
+ 0,
+ true,
+ 5,
+ };
+
+static struct sfnt_generic_test_args add_test_args =
+ {
+ (uint32_t []) { 96, -1, },
+ 2,
+ false,
+ 10,
+ };
+
+static struct sfnt_generic_test_args sub_test_args =
+ {
+ (uint32_t []) { 64, -64, 431, },
+ 3,
+ false,
+ 14,
+ };
+
+static struct sfnt_generic_test_args div_test_args =
+ {
+ (uint32_t []) { 32, -64, },
+ 2,
+ true,
+ 15,
+ };
+
+static struct sfnt_generic_test_args mul_test_args =
+ {
+ (uint32_t []) { 255, -255, 255, },
+ 3,
+ false,
+ 16,
+ };
+
+static struct sfnt_generic_test_args abs_test_args =
+ {
+ (uint32_t []) { 1, 1, },
+ 2,
+ false,
+ 7,
+ };
+
+static struct sfnt_generic_test_args neg_test_args =
+ {
+ (uint32_t []) { 1, -1, },
+ 2,
+ false,
+ 7,
+ };
+
+static struct sfnt_generic_test_args floor_test_args =
+ {
+ (uint32_t []) { -128, -64, 0, 64, 128, },
+ 5,
+ false,
+ 17,
+ };
+
+static struct sfnt_generic_test_args ceiling_test_args =
+ {
+ (uint32_t []) { -128, -128, -64, 0, 64, 128, 128, },
+ 7,
+ false,
+ 25,
+ };
+
+static struct sfnt_generic_test_args round_test_args =
+ {
+ NULL,
+ 0,
+ true,
+ 0,
+ };
+
+static struct sfnt_generic_test_args nround_test_args =
+ {
+ (uint32_t []) { 63, },
+ 1,
+ false,
+ 3,
+ };
+
+static struct sfnt_generic_test_args wcvtf_test_args =
+ {
+ (uint32_t []) { (63 * 17 * 65535 / 800) >> 10, },
+ 1,
+ false,
+ 7,
+ };
+
+static struct sfnt_generic_test_args jrot_test_args =
+ {
+ (uint32_t []) { 40, 40, },
+ 2,
+ false,
+ 13,
+ };
+
+static struct sfnt_generic_test_args jrof_test_args =
+ {
+ (uint32_t []) { 4, },
+ 1,
+ false,
+ 13,
+ };
+
+static struct sfnt_generic_test_args deltac1_test_args =
+ {
+ (uint32_t []) { ((((50 * 17 * 65535) + 32767) / 800) >> 10) + 8,
+ ((((50 * 17 * 65535) + 32767) / 800) >> 10) + 8, },
+ 2,
+ false,
+ 22,
+ };
+
+static struct sfnt_generic_test_args deltac2_test_args =
+ {
+ (uint32_t []) { ((((50 * 17 * 65535) + 32767) / 800) >> 10) + 8,
+ ((((50 * 17 * 65535) + 32767) / 800) >> 10) + 8, },
+ 2,
+ false,
+ 22,
+ };
+
+static struct sfnt_generic_test_args deltac3_test_args =
+ {
+ (uint32_t []) { ((((50 * 17 * 65535) + 32767) / 800) >> 10) + 8,
+ ((((50 * 17 * 65535) + 32767) / 800) >> 10) + 8, },
+ 2,
+ false,
+ 22,
+ };
+
+/* Macros and instructions for detailed rounding tests. */
+
+/* PUSHB[0] period:phase:threshold
+ SROUND[] */
+#define SFNT_ROUNDING_OPERAND(period, phase, threshold) \
+ 0xb0, (((unsigned char) period << 6) \
+ | ((unsigned char) phase & 3) << 4 \
+ | ((unsigned char) threshold & 15)), 0x76
+
+/* PUSHB[0] period:phase:threshold
+ S45ROUND[] */
+#define SFNT_ROUNDING_OPERAND_45(period, phase, threshold) \
+ 0xb0, (((unsigned char) period << 6) \
+ | ((unsigned char) phase & 3) << 4 \
+ | ((unsigned char) threshold & 15)), 0x77
+
+/* PUSHB[0] value
+ ROUND[] */
+#define SFNT_ROUND_VALUE(value) 0xb0, value, 0x68
+
+static unsigned char sfnt_sround_instructions[] =
+ {
+ SFNT_ROUNDING_OPERAND (0, 0, 8),
+ SFNT_ROUND_VALUE (15),
+ SFNT_ROUND_VALUE (17),
+ SFNT_ROUNDING_OPERAND (1, 0, 8),
+ SFNT_ROUND_VALUE (32),
+ SFNT_ROUND_VALUE (16),
+ SFNT_ROUNDING_OPERAND (2, 0, 8),
+ SFNT_ROUND_VALUE (64),
+ SFNT_ROUND_VALUE (63),
+ SFNT_ROUNDING_OPERAND (0, 1, 8),
+ SFNT_ROUND_VALUE (16),
+ SFNT_ROUND_VALUE (24),
+ SFNT_ROUNDING_OPERAND (0, 2, 8),
+ SFNT_ROUND_VALUE (20),
+ SFNT_ROUND_VALUE (48),
+ SFNT_ROUNDING_OPERAND (0, 3, 8),
+ SFNT_ROUND_VALUE (7),
+ SFNT_ROUND_VALUE (70),
+ };
+
+static uint32_t sfnt_sround_values[] =
+ {
+ /* 0, 0, 8 = RTDG; 15 rounded to the double grid and becomes 0, 17
+ is 32. */
+ 0, 32,
+ /* 1, 0, 8 = RTG; 32 rounded to the grid is 64, 16 is 0. */
+ 64, 0,
+ /* 2, 0, 8 = round to a grid separated by 128s. 64 is 128, 63 is
+ 0. */
+ 128, 0,
+ /* 0, 1, 8 = round to a double grid with a phase of 8. 16 rounds
+ down to 8, 24 rounds up to 40. */
+ 8, 40,
+ /* 0, 2, 8 = round to a double grid with a phase of 16. 20 rounds
+ down to 16, 40 rounds up to 48. */
+ 16, 48,
+ /* 0, 3, 8 = round to a double grid with a phase of 48. 7 rounds
+ up to 16, 70 rounds up to 80. */
+ 16, 80,
+ };
+
+static struct sfnt_generic_test_args sround_test_args =
+ {
+ sfnt_sround_values,
+ ARRAYELTS (sfnt_sround_values),
+ false,
+ ARRAYELTS (sfnt_sround_instructions),
+ };
+
+static unsigned char sfnt_s45round_instructions[] =
+ {
+ SFNT_ROUNDING_OPERAND_45 (0, 0, 0),
+ SFNT_ROUND_VALUE (1),
+ SFNT_ROUND_VALUE (45),
+ };
+
+static uint32_t sfnt_s45round_values[] =
+ {
+ /* 0, 0, 0: 1 rounded to the double cubic grid becomes 45, and 46
+ rounded to the double cubic grid becomes 90. */
+ 45, 90,
+ };
+
+static struct sfnt_generic_test_args s45round_test_args =
+ {
+ sfnt_s45round_values,
+ ARRAYELTS (sfnt_s45round_values),
+ false,
+ ARRAYELTS (sfnt_s45round_instructions),
+ };
+
+static struct sfnt_generic_test_args rutg_test_args =
+ {
+ (uint32_t []) { 64, 64, 0, },
+ 3,
+ false,
+ 10,
+ };
+
+static struct sfnt_generic_test_args rdtg_test_args =
+ {
+ (uint32_t []) { 0, 0, 64, },
+ 3,
+ false,
+ 10,
+ };
+
+static struct sfnt_generic_test_args sangw_test_args =
+ {
+ NULL,
+ 0,
+ false,
+ 3,
+ };
+
+static struct sfnt_generic_test_args aa_test_args =
+ {
+ NULL,
+ 0,
+ false,
+ 3,
+ };
+
+static struct sfnt_generic_test_args getinfo_test_args =
+ {
+ /* Pretend to be the Macintosh System 7 scaler.
+
+ This lets the interpreter get away with only two phantom
+ points, as specified in Apple's TrueType reference manual. */
+ (uint32_t []) { 2, 0, },
+ 2,
+ false,
+ 6,
+ };
+
+static struct sfnt_generic_test_args idef_test_args =
+ {
+ (uint32_t []) { 1, 2, 3, },
+ 3,
+ false,
+ 11,
+ };
+
+static struct sfnt_generic_test_args roll_test_args =
+ {
+ (uint32_t []) { 1, 2, 4, 5, 3, },
+ 5,
+ false,
+ 7,
+ };
+
+static struct sfnt_generic_test_args roll_1_test_args =
+ {
+ (uint32_t []) { 1, 2, },
+ 2,
+ true,
+ 3,
+ };
+
+static struct sfnt_generic_test_args max_test_args =
+ {
+ (uint32_t []) { 70, },
+ 1,
+ false,
+ 6,
+ };
+
+static struct sfnt_generic_test_args min_test_args =
+ {
+ (uint32_t []) { -70, },
+ 1,
+ false,
+ 6,
+ };
+
+static struct sfnt_generic_test_args scantype_test_args =
+ {
+ NULL,
+ 0,
+ false,
+ 3,
+ };
+
+static struct sfnt_interpreter_test all_tests[] =
+ {
+ {
+ "NPUSHB",
+ /* NPUSHB[] 4 1 2 3 4
+ NPUSHB[] 5 1 2 3 4 */
+ (unsigned char []) { 0x40, 4, 1, 2, 3, 4,
+ 0x40, 5, 1, 2, 3, 4, },
+ 10,
+ &npushb_test_args,
+ sfnt_generic_check,
+ },
+ {
+ "NPUSHW",
+ /* NPUSHW[] 4 0x101 0x202 0x303 0x404
+ NPUSHW[] 4 0x101 0x202 0x303 0x4?? */
+ (unsigned char []) { 0x41, 4, 1, 1, 2, 2, 3, 3, 4, 4,
+ 0x41, 4, 1, 1, 2, 2, 3, 3, 4, },
+ 19,
+ &npushw_test_args,
+ sfnt_generic_check,
+ },
+ {
+ "PUSHB",
+ /* PUSHB[7] 1 2 3 4 5 6 7 8
+ PUSHB[0] 1
+ PUSHB[5] 1 2 3 4 5 ? */
+ (unsigned char []) { 0xb7, 1, 2, 3, 4, 5, 6, 7, 8,
+ 0xb0, 1,
+ 0xb5, 1, 2, 3, 4, 5, },
+ 17,
+ &pushb_test_args,
+ sfnt_generic_check,
+ },
+ {
+ "PUSHW",
+ /* PUSHW[7] 2 3 2 4 2 5 2 6 2 7 2 8 9 9 9 9
+ PUSHW[0] 255 255 -- this should get sign-extended
+ PUSHW[5] 1 1 2 2 3 3 4 4 5 5 6 ? */
+ (unsigned char []) { 0xbf, 2, 3, 2, 4, 2, 5, 2, 6, 2, 7, 2, 8, 9, 9, 9, 9,
+ 0xb8, 255, 255,
+ 0xbc, 1, 1, 2, 2, 3, 3, 4, 4, 5, 5, 6, },
+ 28,
+ &pushw_test_args,
+ sfnt_generic_check,
+ },
+ {
+ "that stack overflow is handled correctly",
+ /* NPUSHB[] 101 0... */
+ (unsigned char [103]) { 0x40, 101, },
+ 103,
+ &stack_overflow_test_args,
+ sfnt_generic_check,
+ },
+ {
+ "that stack underflow is handled correctly",
+ /* PUSHW[0] 100 100
+ POP[]
+ POP[] */
+ (unsigned char []) { 0xb8, 100, 100,
+ 0x21,
+ 0x21, },
+ 5,
+ &stack_underflow_test_args,
+ sfnt_generic_check,
+ },
+ {
+ "SRP0, SRP1, SRP2",
+ /* PUSHB[0] 0
+ SRP0[]
+ PUSHB[0] 1
+ SRP1[]
+ PUSHB[0] 2
+ SRP2[] */
+ (unsigned char []) { 0xb0, 0,
+ 0x10,
+ 0xb0, 1,
+ 0x11,
+ 0xb0, 2,
+ 0x12, },
+ 9,
+ NULL,
+ sfnt_check_srp0,
+ },
+ {
+ "SZP0, SZP1, SZP2, SZPS",
+ /* PUSHB[0] 1
+ SZP0[]
+ PUSHB[0] 1
+ SZP1[]
+ PUSHB[0] 0
+ SZP2[]
+ PUSHB[0] 5
+ SZPS[] */
+ (unsigned char []) { 0xb0, 1,
+ 0x13,
+ 0xb0, 1,
+ 0x14,
+ 0xb0, 0,
+ 0x15,
+ 0xb0, 5,
+ 0x16, },
+ 12,
+ NULL,
+ sfnt_check_szp0,
+ },
+ {
+ "SLOOP",
+ /* PUSHB[0] 2
+ SLOOP[]
+ PUSHW[0] 255 255 (-1)
+ SLOOP[] */
+ (unsigned char []) { 0xb0, 2,
+ 0x17,
+ 0xb8, 255, 255,
+ 0x17, },
+ 7,
+ NULL,
+ sfnt_check_sloop,
+ },
+ {
+ "RTG",
+ /* RTG[]
+ PUSHB[0] 32
+ ROUND[] */
+ (unsigned char []) { 0x18,
+ 0xb0, 32,
+ 0x68, },
+ 4,
+ &rtg_test_args,
+ sfnt_check_rounding,
+ },
+ {
+ "rounding symmetry",
+ /* RTG[]
+ PUSHW[0] 255 -32
+ ROUND[] */
+ (unsigned char []) { 0x18,
+ 0xb8, 255, - (signed char) 32,
+ 0x68, },
+ 5,
+ &rtg_symmetric_test_args,
+ sfnt_check_rounding,
+ },
+ {
+ "RTG to 0",
+ /* RTG[]
+ PUSHB[0] 31
+ ROUND[] */
+ (unsigned char []) { 0x18,
+ 0xb0, 31,
+ 0x68, },
+ 4,
+ &rtg_1_test_args,
+ sfnt_check_rounding,
+ },
+ {
+ "rounding symmetry to 0",
+ /* RTG[]
+ PUSHB[0] 255 -31
+ ROUND[] */
+ (unsigned char []) { 0x18,
+ 0xb8, 255, - (signed char) 31,
+ 0x68, },
+ 5,
+ &rtg_1_symmetric_test_args,
+ sfnt_check_rounding,
+ },
+ {
+ "RTHG",
+ /* RTHG[]
+ PUSHB[0] 0
+ ROUND[] */
+ (unsigned char []) { 0x19,
+ 0xb0, 0,
+ 0x68, },
+ 4,
+ &rthg_test_args,
+ sfnt_check_rounding,
+ },
+ {
+ "RTHG to 96",
+ /* RTHG[]
+ PUSHB[0] 64
+ ROUND[] */
+ (unsigned char []) { 0x19,
+ 0xb0, 64,
+ 0x68, },
+ 4,
+ &rthg_1_test_args,
+ sfnt_check_rounding,
+ },
+ {
+ "SMD",
+ /* PUSHB[0] 32
+ SMD[] */
+ (unsigned char []) { 0xb0, 32,
+ 0x1a, },
+ 3,
+ NULL,
+ sfnt_check_smd,
+ },
+ {
+ "ELSE",
+ /* ELSE[]
+ ;; Lots of variable length instructions
+ ;; which will not be executed, like:
+ NPUSHW[] 3 11 22 33 44 55 66
+ NPUSHB[] 1 3
+ PUSHW[2] 1 1 2 2 3 3
+ PUSHB[2] 1 2 3
+ ;; Also test nested ifs.
+ PUSHW[0] 1 1
+ IF[]
+ PUSHW[0] 1 1
+ ELSE[]
+ PUSHW[0] 1 1
+ EIF[]
+ EIF[]
+ PUSHW[0] 1 1
+ ;; the actual contents of the stack.
+ PUSHB[2] 77 90 83 */
+ (unsigned char []) { 0x1b,
+ 0x41, 3, 11, 22, 33, 44, 55, 66,
+ 0x40, 1, 3,
+ 0xba, 1, 1, 2, 2, 3, 3,
+ 0xb2, 1, 2, 3,
+ 0xb8, 1, 1,
+ 0x58,
+ 0xb8, 1, 1,
+ 0x1b,
+ 0xb8, 1, 1,
+ 0x59,
+ 0x59,
+ 0xb2, 77, 90, 83, },
+ 40,
+ &else_test_args,
+ sfnt_generic_check,
+ },
+ {
+ "JMPR",
+ /* PUSHW[2] 00 00 00 PUSHB[2] 255 253 JMPR[]
+ PUSHB[0] 4
+ JMPR[]
+ 255 255 255
+ PUSHW[0] 255 -30
+ JMPR[] */
+ (unsigned char []) { 0xba, 00, 00, 00, 0xb2, 255, 253, 0x1c,
+ 0xb0, 4,
+ 0x1c,
+ 255, 255, 255,
+ 0xb8, 255, -30,
+ 0x1c, },
+ 18,
+ &jmpr_test_args,
+ sfnt_generic_check,
+ },
+ {
+ "SCVTCI",
+ /* PUSHB[0] 128
+ SCVTCI[] */
+ (unsigned char []) { 0xb0, 128,
+ 0x1d, },
+ 3,
+ NULL,
+ sfnt_check_scvtci,
+ },
+ {
+ "SSWCI",
+ /* PUSHW[0] 2 0 ;; 512
+ SSWCI[] */
+ (unsigned char []) { 0xb8, 2, 0,
+ 0x1e, },
+ 4,
+ NULL,
+ sfnt_check_sswci,
+ },
+ {
+ "SSW",
+ /* PUSHW[0] 255 255 ; -1
+ SSW[] ; this should be converted to device-space */
+ (unsigned char []) { 0xb8, 255, 255,
+ 0x1f, },
+ 4,
+ NULL,
+ sfnt_check_ssw,
+ },
+ {
+ "DUP",
+ /* PUSHB[0] 70
+ DUP[]
+ POP[]
+ POP[]
+ DUP[] */
+ (unsigned char []) { 0xb0, 70,
+ 0x20,
+ 0x21,
+ 0x21,
+ 0x70, },
+ 6,
+ &dup_test_args,
+ sfnt_generic_check,
+ },
+ {
+ "POP",
+ /* PUSHB[0] 70
+ DUP[]
+ DUP[]
+ POP[] */
+ (unsigned char []) { 0xb0, 70,
+ 0x20,
+ 0x20,
+ 0x21, },
+ 5,
+ &pop_test_args,
+ sfnt_generic_check,
+ },
+ {
+ "CLEAR",
+ /* PUSHB[7] 1 2 3 4 5 6 7 8
+ CLEAR[] */
+ (unsigned char []) { 0xb7, 1, 2, 3, 4, 5, 6, 7, 8,
+ 0x22, },
+ 10,
+ &clear_test_args,
+ sfnt_generic_check,
+ },
+ {
+ "SWAP",
+ /* PUSHB[1] 1 2
+ SWAP[] */
+ (unsigned char []) { 0xb1, 1, 2,
+ 0x23, },
+ 4,
+ &swap_test_args,
+ sfnt_generic_check,
+ },
+ {
+ "DEPTH",
+ /* PUSHB[2] 3 3 3
+ DEPTH[] */
+ (unsigned char []) { 0xb2, 3, 3, 3,
+ 0x24, },
+ 5,
+ &depth_test_args,
+ sfnt_generic_check,
+ },
+ {
+ "CINDEX",
+ /* PUSHB[4] 0 3 3 4 1
+ CINDEX[] ; pops 1, indices 4
+ CINDEX[] ; pops 4, indices 0
+ PUSHB[0] 6
+ CINDEX[] ; pops 6, trap */
+ (unsigned char []) { 0xb4, 0, 3, 3, 4, 1,
+ 0x25,
+ 0x25,
+ 0xb0, 6,
+ 0x25, },
+ 11,
+ &cindex_test_args,
+ sfnt_generic_check,
+ },
+ {
+ "MINDEX",
+ /* PUSHB[6] 0 3 4 7 3 4 2
+ MINDEX[] ; pops 2, array becomes 0 3 4 7 4 3
+ MINDEX[] ; pops 3, array becomes 0 3 7 4 4 */
+ (unsigned char []) { 0xb6, 0, 3, 4, 7, 3, 4, 2,
+ 0x26,
+ 0x26, },
+ 10,
+ &mindex_test_args,
+ sfnt_generic_check,
+ },
+ {
+ "RAW",
+ /* RAW[] */
+ (unsigned char []) { 0x28, },
+ 1,
+ &raw_test_args,
+ sfnt_generic_check,
+ },
+ {
+ "LOOPCALL",
+ /* PUSHB[1] 0 2
+ FDEF[]
+ PUSHB[0] 1
+ ADD[]
+ ENDF[]
+ PUSHB[1] 10 2
+ LOOPCALL[] */
+ (unsigned char []) { 0xb1, 0, 2,
+ 0x2c,
+ 0xb0, 1,
+ 0x60,
+ 0x2d,
+ 0xb1, 10, 2,
+ 0x2a, },
+ 12,
+ &loopcall_test_args,
+ sfnt_generic_check,
+ },
+ {
+ "CALL",
+ /* PUSHB[1] 7 2
+ FDEF[]
+ PUSHB[0] 1
+ ADD[]
+ ENDF[]
+ PUSHB[0] 2
+ CALL[]
+ PUSHB[0] 3
+ ADD[]
+ ;; Test that infinite recursion fails.
+ PUSHB[0] 3
+ FDEF[]
+ PUSHB[0] 3
+ CALL[]
+ ENDF[]
+ PUSHB[0] 3
+ CALL[] */
+ (unsigned char []) { 0xb1, 7, 2,
+ 0x2c,
+ 0xb0, 1,
+ 0x60,
+ 0x2d,
+ 0xb0, 2,
+ 0x2b,
+ 0xb0, 3,
+ 0x60,
+ 0xb0, 3,
+ 0x2c,
+ 0xb0, 3,
+ 0x2b,
+ 0x2d,
+ 0xb0, 3,
+ 0x2b, },
+ 24,
+ &call_test_args,
+ sfnt_generic_check,
+ },
+ {
+ "that FDEF traps inside nested definitions",
+ /* PUSHB[0] 1
+ FDEF[]
+ FDEF[]
+ ENDF[]
+ ENDF[] */
+ (unsigned char []) { 0xb0, 1,
+ 0x2c,
+ 0x2c,
+ 0x2d,
+ 0x2d, },
+ 6,
+ &fdef_test_args,
+ sfnt_generic_check,
+ },
+ {
+ "that FDEF traps upon missing ENDF",
+ /* PUSHB[0] 1
+ FDEF[]
+ PUSHB[3] 1 2 3 4
+ POP[] */
+ (unsigned char []) { 0xb0, 1,
+ 0x2c,
+ 0xb3, 1, 2, 3, 4,
+ 0x21, },
+ 9,
+ &fdef_1_test_args,
+ sfnt_generic_check,
+ },
+ {
+ "ENDF",
+ /* ENDF[] */
+ (unsigned char []) { 0x2d, },
+ 1,
+ &endf_test_args,
+ sfnt_generic_check,
+ },
+ {
+ "RTDG",
+ /* RTDG[]
+ PUSHB[0] 16
+ ROUND[] */
+ (unsigned char []) { 0x3d,
+ 0xb0, 16,
+ 0x68, },
+ 4,
+ &rtdg_test_args,
+ sfnt_check_rounding,
+ },
+ {
+ "RTDG down to 0",
+ /* RTDG[]
+ PUSHB[0] 15
+ ROUND[] */
+ (unsigned char []) { 0x3d,
+ 0xb0, 15,
+ 0x68, },
+ 4,
+ &rtdg_1_test_args,
+ sfnt_check_rounding,
+ },
+ {
+ "RTDG down to 32",
+ /* RTDG[]
+ PUSHB[0] 47
+ ROUND[] */
+ (unsigned char []) { 0x3d,
+ 0xb0, 47,
+ 0x68, },
+ 4,
+ &rtdg_2_test_args,
+ sfnt_check_rounding,
+ },
+ {
+ "RTDG up to 64",
+ /* RTDG[]
+ PUSHB[0] 48
+ ROUND[] */
+ (unsigned char []) { 0x3d,
+ 0xb0, 48,
+ 0x68, },
+ 4,
+ &rtdg_3_test_args,
+ sfnt_check_rounding,
+ },
+ {
+ "WS",
+ /* PUSHB[1] 240 40
+ WS[]
+ PUSHB[0] 240
+ RS[]
+ PUSHB[1] 255 40
+ WS[] */
+ (unsigned char []) { 0xb1, 240, 40,
+ 0x42,
+ 0xb0, 240,
+ 0x43,
+ 0xb1, 255, 40,
+ 0x42, },
+ 11,
+ &ws_test_args,
+ sfnt_generic_check,
+ },
+ {
+ "RS",
+ /* PUSHB[0] 255
+ RS[] */
+ (unsigned char []) { 0xb0, 255,
+ 0x43, },
+ 3,
+ &rs_test_args,
+ sfnt_generic_check,
+ },
+ {
+ "WCVTP",
+ /* PUSHB[1] 9 32
+ WCVTP[]
+ PUSHB[0] 9
+ RCVT[]
+ PUSHB[1] 10 10
+ WCVTP[] */
+ (unsigned char []) { 0xb1, 9, 32,
+ 0x44,
+ 0xb0, 9,
+ 0x45,
+ 0xb1, 10, 10,
+ 0x44, },
+ 11,
+ &wcvtp_test_args,
+ sfnt_generic_check,
+ },
+ {
+ "RCVT",
+ /* PUSHB[0] 1
+ RCVT[]
+ PUSHB[0] 10
+ RCVT[] */
+ (unsigned char []) { 0xb0, 1,
+ 0x45,
+ 0xb0, 10,
+ 0x45, },
+ 6,
+ &rcvt_test_args,
+ sfnt_generic_check,
+ },
+ {
+ "MPPEM",
+ /* MPPEM[] */
+ (unsigned char []) { 0x4b, },
+ 1,
+ &mppem_test_args,
+ sfnt_generic_check,
+ },
+ {
+ "MPS",
+ /* MPS[] */
+ (unsigned char []) { 0x4c, },
+ 1,
+ &mps_test_args,
+ sfnt_generic_check,
+ },
+ {
+ "FLIPON",
+ /* FLIPON[] */
+ (unsigned char []) { 0x4d, },
+ 1,
+ NULL,
+ sfnt_check_flipon,
+ },
+ {
+ "FLIPOFF",
+ /* FLIPOFF[] */
+ (unsigned char []) { 0x4e, },
+ 1,
+ NULL,
+ sfnt_check_flipoff,
+ },
+ {
+ "DEBUG",
+ /* PUSHB[0] 1
+ DEBUG[] */
+ (unsigned char []) { 0xb0, 1,
+ 0x4f, },
+ 3,
+ &debug_test_args,
+ sfnt_generic_check,
+ },
+ {
+ "LT",
+ /* PUSHB[1] 47 48
+ LT[]
+ PUSHB[1] 48 47
+ LT[]
+ PUSHB[1] 47 47
+ LT[] */
+ (unsigned char []) { 0xb1, 47, 48,
+ 0x50,
+ 0xb1, 48, 47,
+ 0x50,
+ 0xb1, 47, 47,
+ 0x50, },
+ 12,
+ &lt_test_args,
+ sfnt_generic_check,
+ },
+ {
+ "LTEQ",
+ /* PUSHB[1] 47 48
+ LTEQ[]
+ PUSHB[1] 48 47
+ LTEQ[]
+ PUSHB[1] 47 47
+ LTEQ[] */
+ (unsigned char []) { 0xb1, 47, 48,
+ 0x51,
+ 0xb1, 48, 47,
+ 0x51,
+ 0xb1, 47, 47,
+ 0x51, },
+ 12,
+ &lteq_test_args,
+ sfnt_generic_check,
+ },
+ {
+ "GT",
+ /* PUSHB[1] 47 48
+ GT[]
+ PUSHB[1] 48 47
+ GT[]
+ GT[1] 47 47
+ LTEQ[] */
+ (unsigned char []) { 0xb1, 47, 48,
+ 0x52,
+ 0xb1, 48, 47,
+ 0x52,
+ 0xb1, 47, 47,
+ 0x52, },
+ 12,
+ &gt_test_args,
+ sfnt_generic_check,
+ },
+ {
+ "GTEQ",
+ /* PUSHB[1] 47 48
+ GTEQ[]
+ PUSHB[1] 48 47
+ GTEQ[]
+ GTEQ[1] 47 47
+ LTEQ[] */
+ (unsigned char []) { 0xb1, 47, 48,
+ 0x53,
+ 0xb1, 48, 47,
+ 0x53,
+ 0xb1, 47, 47,
+ 0x53, },
+ 12,
+ &gteq_test_args,
+ sfnt_generic_check,
+ },
+ {
+ "EQ",
+ /* PUSHW[1] 255 253 255 255
+ EQ[]
+ PUSHW[1] 27 27 27 27
+ EQ[]
+ PUSHB[0] 3
+ PUSHW[0] 255 254
+ EQ[] */
+ (unsigned char []) { 0xb9, 255, 253, 255, 255,
+ 0x54,
+ 0xb9, 27, 27, 27, 27,
+ 0x54,
+ 0xb0, 3,
+ 0xb8, 255, 254,
+ 0x54, },
+ 18,
+ &eq_test_args,
+ sfnt_generic_check,
+ },
+ {
+ "NEQ",
+ /* PUSHW[1] 255 253 255 255
+ NEQ[]
+ PUSHW[1] 27 27 27 27
+ NEQ[]
+ PUSHB[0] 3
+ PUSHW[0] 255 254
+ NEQ[] */
+ (unsigned char []) { 0xb9, 255, 253, 255, 255,
+ 0x55,
+ 0xb9, 27, 27, 27, 27,
+ 0x55,
+ 0xb0, 3,
+ 0xb8, 255, 254,
+ 0x55, },
+ 18,
+ &neq_test_args,
+ sfnt_generic_check,
+ },
+ {
+ "ODD",
+ /* RTG[]
+ PUSHW[1] 255 224 ;; -32
+ ODD[] ;; Rounds symmetrically to -64, which is odd.
+ PUSHW[1] 255 159 ;; -96
+ ODD[] ;; Rounds symmetrically to -128, which is even. */
+ (unsigned char []) { 0x18,
+ 0xb8, 255, 224,
+ 0x56,
+ 0xb8, 255, 159,
+ 0x56, },
+ 9,
+ &odd_test_args,
+ sfnt_generic_check,
+ },
+ {
+ "EVEN",
+ /* RTG[]
+ PUSHW[1] 255 224 ;; -32
+ EVEN[] ;; Rounds symmetrically to -64, which is odd.
+ PUSHW[1] 255 159 ;; -96
+ EVEN[] ;; Rounds symmetrically to -128, which is even. */
+ (unsigned char []) { 0x18,
+ 0xb8, 255, 224,
+ 0x57,
+ 0xb8, 255, 159,
+ 0x57, },
+ 9,
+ &even_test_args,
+ sfnt_generic_check,
+ },
+ {
+ "IF",
+ /* NPUSHB[] 1 0
+ IF[]
+ PUSHW[0] 1 1
+ PUSHW[1] 1 1 2 2
+ PUSHW[2] 1 1 2 2 3 3
+ PUSHW[3] 1 1 2 2 3 3 4 4
+ PUSHW[4] 1 1 2 2 3 3 4 4 5 5
+ PUSHW[5] 1 1 2 2 3 3 4 4 5 5 6 6
+ PUSHW[6] 1 1 2 2 3 3 4 4 5 5 6 6 7 7
+ PUSHW[7] 1 1 2 2 3 3 4 4 5 5 6 6 7 7 8 8
+ PUSHB[0] 1
+ PUSHB[1] 2 1
+ PUSHB[2] 3 2 1
+ PUSHB[3] 4 3 2 1
+ PUSHB[4] 5 4 3 2 1
+ PUSHB[5] 6 5 4 3 2 1
+ PUSHB[6] 7 6 5 4 3 2 1
+ PUSHB[7] 8 7 6 5 4 3 2 1
+ DEBUG[]
+ IF[]
+ PUSHB[7] 12 12 12 12 12 12 12 12
+ ELSE[]
+ EIF[]
+ ELSE[]
+ PUSHB[1] 17 24
+ NPUSHB[] 5 1 2 3 4 5
+ NPUSHW[] 2 255 255 255 255
+ EIF[]
+
+ PUSHB[0] 1
+ IF[]
+ NPUSHB[] 2 43 43
+ IF[]
+ PUSHB[0] 45
+ ELSE[]
+ PUSHB[0] 14
+ EIF[]
+ ADD[]
+ ELSE[]
+ NPUSHB[] 4 3 2 1 0
+ EIF[]
+ PUSHB[1] 1 3 */
+ (unsigned char []) { 0x40, 1, 0,
+ 0x58,
+ 0xb8, 1, 1,
+ 0xb9, 1, 1, 2, 2,
+ 0xba, 1, 1, 2, 2, 3, 3,
+ 0xbb, 1, 1, 2, 2, 3, 3, 4, 4,
+ 0xbc, 1, 1, 2, 2, 3, 3, 4, 4, 5, 5,
+ 0xbd, 1, 1, 2, 2, 3, 3, 4, 4, 5, 5, 6, 6,
+ 0xbe, 1, 1, 2, 2, 3, 3, 4, 4, 5, 5, 6, 6, 7, 7,
+ 0xbf, 1, 1, 2, 2, 3, 3, 4, 4, 5, 5, 6, 6, 7, 7, 8, 8,
+ 0xb0, 1,
+ 0xb1, 2, 1,
+ 0xb2, 3, 2, 1,
+ 0xb3, 4, 3, 2, 1,
+ 0xb4, 5, 4, 3, 2, 1,
+ 0xb5, 6, 5, 4, 3, 2, 1,
+ 0xb6, 7, 6, 5, 4, 3, 2, 1,
+ 0xb7, 8, 7, 6, 5, 4, 3, 2, 1,
+ 0x4f,
+ 0x58,
+ 0xb7, 12, 12, 12, 12, 12, 12, 12, 12,
+ 0x1b,
+ 0x59,
+ 0x1b,
+ 0xb1, 17, 24,
+ 0x40, 5, 1, 2, 3, 4, 5,
+ 0x41, 2, 255, 255, 255, 255,
+ 0x59,
+ 0xb0, 1,
+ 0x58,
+ 0x40, 2, 43, 43,
+ 0x58,
+ 0xb0, 45,
+ 0x1b,
+ 0xb0, 14,
+ 0x59,
+ 0x60,
+ 0x1b,
+ 0x40, 4, 3, 2, 1, 0,
+ 0x59,
+ 0xb1, 1, 3, },
+ 185,
+ &if_test_args,
+ sfnt_generic_check,
+ },
+ {
+ "EIF",
+ /* PUSHB[0] 1
+ IF[]
+ EIF[] */
+ (unsigned char []) { 0xb0, 1,
+ 0x58,
+ 0x59, },
+ 3,
+ &eif_test_args,
+ sfnt_generic_check,
+ },
+ {
+ "AND",
+ /* PUSHB[1] 0 1
+ AND[]
+ PUSHB[1] 37 0
+ AND[]
+ PUSHB[1] 40 1
+ AND[]
+ PUSHB[1] 0 0
+ AND[] */
+ (unsigned char []) { 0xb1, 0, 1,
+ 0x5a,
+ 0xb1, 37, 0,
+ 0x5a,
+ 0xb1, 40, 1,
+ 0x5a,
+ 0xb1, 0, 0,
+ 0x5a, },
+ 16,
+ &and_test_args,
+ sfnt_generic_check,
+ },
+ {
+ "OR",
+ /* PUSHB[1] 0 1
+ OR[]
+ PUSHB[1] 37 0
+ OR[]
+ PUSHB[1] 40 1
+ OR[]
+ PUSHB[1] 0 0
+ OR[] */
+ (unsigned char []) { 0xb1, 0, 1,
+ 0x5b,
+ 0xb1, 37, 0,
+ 0x5b,
+ 0xb1, 40, 1,
+ 0x5b,
+ 0xb1, 0, 0,
+ 0x5b, },
+ 16,
+ &or_test_args,
+ sfnt_generic_check,
+ },
+ {
+ "NOT",
+ /* PUSHB[0] 1
+ NOT[]
+ PUSHB[0] 0
+ NOT[] */
+ (unsigned char []) { 0xb0, 1,
+ 0x5c,
+ 0xb0, 0,
+ 0x5c, },
+ 6,
+ &not_test_args,
+ sfnt_generic_check,
+ },
+ {
+ "SDB",
+ /* PUSHB[0] 8
+ SDB[] */
+ (unsigned char []) { 0xb0, 8,
+ 0x5e, },
+ 3,
+ NULL,
+ sfnt_check_sdb,
+ },
+ {
+ "SDS",
+ /* PUSHB[0] 1
+ SDS[] */
+ (unsigned char []) { 0xb0, 1,
+ 0x5f, },
+ 3,
+ NULL,
+ sfnt_check_sds,
+ },
+ {
+ "that SDS rejects invalid values",
+ /* PUSHB[0] 1,
+ SDS[]
+ PUSHB[0] 7
+ SDS[] */
+ (unsigned char []) { 0xb0, 1,
+ 0x5f,
+ 0xb0, 7,
+ 0x5f, },
+ 6,
+ &sds_test_args,
+ sfnt_generic_check,
+ },
+ {
+ "ADD",
+ /* PUSHB[1] 64 32
+ ADD[]
+ PUSHW[1] 255 40 0 215 ;; -216 + 215
+ ADD[] */
+ (unsigned char []) { 0xb1, 64, 32,
+ 0x60,
+ 0xb9, 255, 40, 0, 215,
+ 0x60, },
+ 10,
+ &add_test_args,
+ sfnt_generic_check,
+ },
+ {
+ "SUB",
+ /* PUSHB[1] 96 32
+ SUB[]
+ PUSHB[1] 32 96
+ SUB[]
+ PUSHW[1] 0 215 255 40 ;; 215 - -216
+ SUB[] */
+ (unsigned char []) { 0xb1, 96, 32,
+ 0x61,
+ 0xb1, 32, 96,
+ 0x61,
+ 0xb9, 0, 215, 255, 40,
+ 0x61, },
+ 14,
+ &sub_test_args,
+ sfnt_generic_check,
+ },
+ {
+ "DIV",
+ /* PUSHB[1] 64 128
+ DIV[] ; 1 / 2 = 0.5
+ PUSHW[1] 0 32 255 224
+ DIV[] ; 0.5 / -0.5 = -1.0
+ PUSHW[1] 255 255 0 0
+ DIV[] ; -1 / 0 = trap */
+ (unsigned char []) { 0xb1, 64, 128,
+ 0x62,
+ 0xb9, 0, 32, 255, 224,
+ 0x62,
+ 0xb9, 255, 255, 0, 0,
+ 0x62, },
+ 16,
+ &div_test_args,
+ sfnt_generic_check,
+ },
+ {
+ "MUL",
+ /* PUSHB[1] 255 64
+ MUL[] ; 255 * 1 = 255
+ PUSHW[1] 0 255 255 192
+ MUL[] ; 255 * -1 = -255
+ PUSHW[1] 255 1 255 192
+ MUL[] ; -255 * -1 = 255 */
+ (unsigned char []) { 0xb1, 255, 64,
+ 0x63,
+ 0xb9, 0, 255, 255, 192,
+ 0x63,
+ 0xb9, 255, 1, 255, 192,
+ 0x63, },
+ 16,
+ &mul_test_args,
+ sfnt_generic_check,
+ },
+ {
+ "ABS",
+ /* PUSHW[0] 255 255
+ ABS[] ;; abs (-1) == 1
+ PUSHB[0] 1
+ ABS[] ;; abs (1) == 1 */
+ (unsigned char []) { 0xb8, 255, 255,
+ 0x64,
+ 0xb0, 1,
+ 0x64, },
+ 7,
+ &abs_test_args,
+ sfnt_generic_check,
+ },
+ {
+ "NEG",
+ /* PUSHW[0] 255 255
+ NEG[] ;; neg (-1) == 1
+ PUSHB[0] 1
+ NEG[] ;; neg (1) == -1 */
+ (unsigned char []) { 0xb8, 255, 255,
+ 0x65,
+ 0xb0, 1,
+ 0x65, },
+ 7,
+ &neg_test_args,
+ sfnt_generic_check,
+ },
+ {
+ "FLOOR",
+ /* PUSHW[0] 255 129 ; -127
+ FLOOR[] ; floor (-127) == -128
+ PUSHW[0] 255 193 ; -63
+ FLOOR[] ; floor (-63) == -64
+ PUSHB[0] 63
+ FLOOR[] ; floor (63) == 0
+ PUSHB[0] 127
+ FLOOR[] ; floor (127) == 64
+ PUSHB[0] 191
+ FLOOR[] ; floor (191) == 128 */
+ (unsigned char []) { 0xb8, 255, 129,
+ 0x66,
+ 0xb8, 255, 193,
+ 0x66,
+ 0xb0, 63,
+ 0x66,
+ 0xb0, 127,
+ 0x66,
+ 0xb0, 191,
+ 0x66, },
+ 17,
+ &floor_test_args,
+ sfnt_generic_check,
+ },
+ {
+ "CEILING",
+ /* PUSHW[0] 255 128 ; -128
+ CEILING[] ; ceiling (-128) == -128
+ PUSHW[0] 255 127 ; -129
+ CEILING[] ; ceiling (-129) == -128
+ PUSHW[0] 255 191 ; -65
+ CEILING[] ; ceiling (-65) == -64
+ PUSHW[0] 255 255 ; -1
+ CEILING[] ; ceiling (-1) == 0
+ PUSHB[0] 63
+ CEILING[] ; ceiling (63) == 64
+ PUSHB[0] 65
+ CEILING[] ; ceiling (65) == 128
+ PUSHB[0] 128
+ CEILING[] ; ceiling (128) == 128 */
+ (unsigned char []) { 0xb8, 255, 128,
+ 0x67,
+ 0xb8, 255, 127,
+ 0x67,
+ 0xb8, 255, 191,
+ 0x67,
+ 0xb8, 255, 255,
+ 0x67,
+ 0xb0, 63,
+ 0x67,
+ 0xb0, 65,
+ 0x67,
+ 0xb0, 128,
+ 0x67, },
+ 25,
+ &ceiling_test_args,
+ sfnt_generic_check,
+ },
+ {
+ "ROUND",
+ /* ROUND[] */
+ (unsigned char []) { 0x68, },
+ 1,
+ &round_test_args,
+ sfnt_generic_check,
+ },
+ {
+ "NROUND",
+ /* PUSHB[0] 63
+ NROUND[] */
+ (unsigned char []) { 0xb0, 63,
+ 0x6c, },
+ 3,
+ &nround_test_args,
+ sfnt_generic_check,
+ },
+ {
+ "WCVTF",
+ /* PUSHB[1] 1 63
+ WCVTF[]
+ PUSHB[0] 1
+ RCVT[] */
+ (unsigned char []) { 0xb1, 1, 63,
+ 0x70,
+ 0xb0, 1,
+ 0x45, },
+ 7,
+ &wcvtf_test_args,
+ sfnt_generic_check,
+ },
+ {
+ "JROT",
+ /* PUSHB[1] 4 0
+ JROT[] ; this should not skip past the next instruction
+ PUSHB[1] 40 40
+ PUSHB[1] 3 1
+ JROT[] ; this should skip past the next instruction
+ PUSHB[0] 4 */
+ (unsigned char []) { 0xb1, 4, 0,
+ 0x78,
+ 0xb1, 40, 40,
+ 0xb1, 3, 1,
+ 0x78,
+ 0xb0, 4, },
+ 13,
+ &jrot_test_args,
+ sfnt_generic_check,
+ },
+ {
+ "JROF",
+ /* PUSHB[1] 4 0
+ JROF[] ; this should skip past the next instruction
+ PUSHB[1] 40 40
+ PUSHB[1] 3 1
+ JROF[] ; this should not skip past the next instruction
+ PUSHB[0] 4 */
+ (unsigned char []) { 0xb1, 4, 0,
+ 0x79,
+ 0xb1, 40, 40,
+ 0xb1, 3, 1,
+ 0x79,
+ 0xb0, 4, },
+ 13,
+ &jrof_test_args,
+ sfnt_generic_check,
+ },
+ {
+ "DELTAC1",
+ /* PUSHB[0] 2
+ SDB[] ; delta base now 2
+ PUSHB[0] 6
+ SDS[] ; delta shift now 6
+ PUSHB[2] 0xff 5 1 ; CVT index 5, ppem 15 + 2, magnitude 15
+ DELTAC1[]
+ PUSHB[0] 1
+ RCVT[] ; CVT index 5 should now be greater by 8 / 64
+
+ PUSHB[2] 0xef 5 1 ; CVT index 5, ppem 14 + 2, magnitude 15
+ DELTAC1[]
+ PUSHB[0] 1
+ RCVT[] ; CVT index 5 should be unchanged */
+ (unsigned char []) { 0xb0, 2,
+ 0x5e,
+ 0xb0, 6,
+ 0x5f,
+ 0xb2, 255, 5, 1,
+ 0x73,
+ 0xb0, 5,
+ 0x45,
+ 0xb2, 239, 5, 1,
+ 0x73,
+ 0xb0, 5,
+ 0x45, },
+ 22,
+ &deltac1_test_args,
+ sfnt_generic_check,
+ },
+ {
+ "DELTAC2",
+ /* PUSHB[0] 2
+ SDB[] ; delta base now 2
+ PUSHB[0] 6
+ SDS[] ; delta shift now 6
+ PUSHB[2] 0xff 5 1 ; CVT index 5, ppem 15 + 2 + 16, magnitude 15
+ DELTAC2[]
+ PUSHB[0] 1
+ RCVT[] ; CVT index 5 should be unchanged
+
+ PUSHB[2] 0xef 5 1 ; CVT index 5, ppem 14 + 2 + 16, magnitude 15
+ DELTAC2[]
+ PUSHB[0] 1
+ RCVT[] ; CVT index 5 should be unchanged */
+ (unsigned char []) { 0xb0, 2,
+ 0x5e,
+ 0xb0, 6,
+ 0x5f,
+ 0xb2, 255, 5, 1,
+ 0x74,
+ 0xb0, 5,
+ 0x45,
+ 0xb2, 239, 5, 1,
+ 0x74,
+ 0xb0, 5,
+ 0x45, },
+ 22,
+ &deltac2_test_args,
+ sfnt_generic_check,
+ },
+ {
+ "DELTAC3",
+ /* PUSHB[0] 2
+ SDB[] ; delta base now 2
+ PUSHB[0] 6
+ SDS[] ; delta shift now 6
+ PUSHB[2] 0xff 5 1 ; CVT index 5, ppem 15 + 2 + 32, magnitude 15
+ DELTAC3[]
+ PUSHB[0] 1
+ RCVT[] ; CVT index 5 should be unchanged
+
+ PUSHB[2] 0xef 5 1 ; CVT index 5, ppem 14 + 2 + 32, magnitude 15
+ DELTAC3[]
+ PUSHB[0] 1
+ RCVT[] ; CVT index 5 should be unchanged */
+ (unsigned char []) { 0xb0, 2,
+ 0x5e,
+ 0xb0, 6,
+ 0x5f,
+ 0xb2, 255, 5, 1,
+ 0x75,
+ 0xb0, 5,
+ 0x45,
+ 0xb2, 239, 5, 1,
+ 0x75,
+ 0xb0, 5,
+ 0x45, },
+ 22,
+ &deltac3_test_args,
+ sfnt_generic_check,
+ },
+ {
+ "SROUND",
+ sfnt_sround_instructions,
+ ARRAYELTS (sfnt_sround_instructions),
+ &sround_test_args,
+ sfnt_generic_check,
+ },
+ {
+ "S45ROUND",
+ sfnt_s45round_instructions,
+ ARRAYELTS (sfnt_s45round_instructions),
+ &s45round_test_args,
+ sfnt_generic_check,
+ },
+ {
+ "RUTG",
+ /* RUTG[]
+ PUSHB[0] 1
+ ROUND[]
+ PUSHB[0] 64
+ ROUND[]
+ PUSHB[0] 0
+ ROUND[] */
+ (unsigned char []) { 0x7c,
+ 0xb0, 1,
+ 0x68,
+ 0xb0, 64,
+ 0x68,
+ 0xb0, 0,
+ 0x68, },
+ 10,
+ &rutg_test_args,
+ sfnt_generic_check,
+ },
+ {
+ "RDTG",
+ /* RUTG[]
+ PUSHB[0] 1
+ ROUND[]
+ PUSHB[0] 63
+ ROUND[]
+ PUSHB[0] 64
+ ROUND[] */
+ (unsigned char []) { 0x7d,
+ 0xb0, 1,
+ 0x68,
+ 0xb0, 63,
+ 0x68,
+ 0xb0, 64,
+ 0x68, },
+ 10,
+ &rdtg_test_args,
+ sfnt_generic_check,
+ },
+ {
+ "SANGW",
+ /* PUSHB[0] 3
+ SANGW[] */
+ (unsigned char []) { 0xb0, 3,
+ 0x7e, },
+ 3,
+ &sangw_test_args,
+ sfnt_generic_check,
+ },
+ {
+ "AA",
+ /* PUSHB[0] 3
+ AA[] */
+ (unsigned char []) { 0xb0, 3,
+ 0x7f, },
+ 3,
+ &aa_test_args,
+ sfnt_generic_check,
+ },
+ {
+ "SCANCTRL",
+ /* PUSHB[0] 1
+ SCANCTRL[] */
+ (unsigned char []) { 0xb0, 1,
+ 0x85, },
+ 3,
+ NULL,
+ sfnt_check_scanctrl,
+ },
+ {
+ "GETINFO",
+ /* PUSHB[0] 1
+ GETINFO[]
+ PUSHB[0] 6
+ GETINFO[] */
+ (unsigned char []) { 0xb0, 1,
+ 0x88,
+ 0xb0, 6,
+ 0x88, },
+ 6,
+ &getinfo_test_args,
+ sfnt_generic_check,
+ },
+ {
+ "IDEF",
+ /* PUSHB[0] 0x83
+ IDEF[]
+ PUSHB[3] 1 2 3 4
+ POP[]
+ ENDF[]
+ 0x83 */
+ (unsigned char []) { 0xb0, 0x83,
+ 0x89,
+ 0xb3, 1, 2, 3, 4,
+ 0x21,
+ 0x2d,
+ 0x83, },
+ 11,
+ &idef_test_args,
+ sfnt_generic_check,
+ },
+ {
+ "ROLL",
+ /* PUSHB[4] 1 2 3 4 5
+ ROLL[] ; this should become 1 2 4 5 3 */
+ (unsigned char []) { 0xb4, 1, 2, 3, 4, 5,
+ 0x8a, },
+ 7,
+ &roll_test_args,
+ sfnt_generic_check,
+ },
+ {
+ "that ROLL correctly handles underflow",
+ /* PUSHB[1] 1 2
+ ROLL[] */
+ (unsigned char []) { 0xb1, 1, 2,
+ 0x8a, },
+ 4,
+ &roll_1_test_args,
+ sfnt_generic_check,
+ },
+ {
+ "MAX",
+ /* PUSHW[1] 0 70 255 186 ; 70, -70
+ MAX[] */
+ (unsigned char []) { 0xb9, 0, 70, 255, 186,
+ 0x8b, },
+ 6,
+ &max_test_args,
+ sfnt_generic_check,
+ },
+ {
+ "MIN",
+ /* PUSHW[1] 0 70 255 186 ; 70, -70
+ MIN[] */
+ (unsigned char []) { 0xb9, 0, 70, 255, 186,
+ 0x8c, },
+ 6,
+ &min_test_args,
+ sfnt_generic_check,
+ },
+ {
+ "SCANTYPE",
+ /* PUSHB[0] 0
+ SCANTYPE[] */
+ (unsigned char []) { 0xb0, 0,
+ 0x8d, },
+ 3,
+ &scantype_test_args,
+ sfnt_generic_check,
+ },
+ {
+ "INSTCTRL",
+ /* PUSHB[1] 1 1
+ INSTCTRL[] ; (1 << 1) should now be set
+ PUSHB[1] 2 1
+ INSTCTRL[] ; (1 << 2) should now be set
+ PUSHB[1] 2 0
+ INSTCTRL[] ; (1 << 2) should no longer be set */
+ (unsigned char []) { 0xb1, 1, 1,
+ 0x8e,
+ 0xb1, 2, 1,
+ 0x8e,
+ 0xb1, 2, 0,
+ 0x8e, },
+ 12,
+ NULL,
+ sfnt_check_instctrl,
+ },
+ };
+
+
+
+/* Instruction debugger. */
+
+static void
+sfnt_setup_debugger (void)
+{
+ XGCValues gcv;
+ Font font;
+
+ display = XOpenDisplay (NULL);
+
+ if (!display)
+ exit (1);
+
+ window = XCreateSimpleWindow (display, DefaultRootWindow (display),
+ 0, 0, 200, 200, 0, 0,
+ WhitePixel (display,
+ DefaultScreen (display)));
+ XMapWindow (display, window);
+
+ /* Select for the appropriate events. */
+ XSelectInput (display, window, KeyPressMask | ExposureMask);
+
+ /* Find an appropriate font. */
+ font = XLoadFont (display, "6x13");
+
+ if (!font)
+ exit (1);
+
+ /* The debugger has been set up. Set up the GCs for drawing points
+ and backgrounds. */
+
+ gcv.foreground = BlackPixel (display, DefaultScreen (display));
+ gcv.font = font;
+ point_gc = XCreateGC (display, window, GCForeground | GCFont,
+ &gcv);
+ gcv.foreground = WhitePixel (display, DefaultScreen (display));
+ background_gc = XCreateGC (display, window, GCForeground, &gcv);
+}
+
+static const char *
+sfnt_name_instruction (unsigned char opcode)
+{
+ static const char *const opcode_names[256] = {
+ "7 SVTCA y",
+ "7 SVTCA x",
+ "8 SPvTCA y",
+ "8 SPvTCA x",
+ "8 SFvTCA y",
+ "8 SFvTCA x",
+ "8 SPvTL ||",
+ "7 SPvTL +",
+ "8 SFvTL ||",
+ "7 SFvTL +",
+ "5 SPvFS",
+ "5 SFvFS",
+ "3 GPv",
+ "3 GFv",
+ "6 SFvTPv",
+ "5 ISECT",
+
+ "4 SRP0",
+ "4 SRP1",
+ "4 SRP2",
+ "4 SZP0",
+ "4 SZP1",
+ "4 SZP2",
+ "4 SZPS",
+ "5 SLOOP",
+ "3 RTG",
+ "4 RTHG",
+ "3 SMD",
+ "4 ELSE",
+ "4 JMPR",
+ "6 SCvTCi",
+ "5 SSwCi",
+ "3 SSW",
+
+ "3 DUP",
+ "3 POP",
+ "5 CLEAR",
+ "4 SWAP",
+ "5 DEPTH",
+ "6 CINDEX",
+ "6 MINDEX",
+ "8 AlignPTS",
+ "7 INS_$28",
+ "3 UTP",
+ "8 LOOPCALL",
+ "4 CALL",
+ "4 FDEF",
+ "4 ENDF",
+ "7 MDAP[0]",
+ "7 MDAP[1]",
+
+ "6 IUP[0]",
+ "6 IUP[1]",
+ "6 SHP[0]",
+ "6 SHP[1]",
+ "6 SHC[0]",
+ "6 SHC[1]",
+ "6 SHZ[0]",
+ "6 SHZ[1]",
+ "5 SHPIX",
+ "2 IP",
+ "8 MSIRP[0]",
+ "8 MSIRP[1]",
+ "7 AlignRP",
+ "4 RTDG",
+ "7 MIAP[0]",
+ "7 MIAP[1]",
+
+ "6 NPushB",
+ "6 NPushW",
+ "2 WS",
+ "2 RS",
+ "5 WCvtP",
+ "4 RCvt",
+ "5 GC[0]",
+ "5 GC[1]",
+ "4 SCFS",
+ "5 MD[0]",
+ "5 MD[1]",
+ "5 MPPEM",
+ "3 MPS",
+ "6 FlipON",
+ "7 FlipOFF",
+ "5 DEBUG",
+
+ "2 LT",
+ "4 LTEQ",
+ "2 GT",
+ "4 GTEQ",
+ "2 EQ",
+ "3 NEQ",
+ "3 ODD",
+ "4 EVEN",
+ "2 IF",
+ "3 EIF",
+ "3 AND",
+ "2 OR",
+ "3 NOT",
+ "7 DeltaP1",
+ "3 SDB",
+ "3 SDS",
+
+ "3 ADD",
+ "3 SUB",
+ "3 DIV",
+ "3 MUL",
+ "3 ABS",
+ "3 NEG",
+ "5 FLOOR",
+ "7 CEILING",
+ "8 ROUND[0]",
+ "8 ROUND[1]",
+ "8 ROUND[2]",
+ "8 ROUND[3]",
+ "9 NROUND[0]",
+ "9 NROUND[1]",
+ "9 NROUND[2]",
+ "9 NROUND[3]",
+
+ "5 WCvtF",
+ "7 DeltaP2",
+ "7 DeltaP3",
+ "A DeltaCn[0]",
+ "A DeltaCn[1]",
+ "A DeltaCn[2]",
+ "6 SROUND",
+ "8 S45Round",
+ "4 JROT",
+ "4 JROF",
+ "4 ROFF",
+ "7 INS_$7B",
+ "4 RUTG",
+ "4 RDTG",
+ "5 SANGW",
+ "2 AA",
+
+ "6 FlipPT",
+ "8 FlipRgON",
+ "9 FlipRgOFF",
+ "7 INS_$83",
+ "7 INS_$84",
+ "8 ScanCTRL",
+ "9 SDPvTL[0]",
+ "9 SDPvTL[1]",
+ "7 GetINFO",
+ "4 IDEF",
+ "4 ROLL",
+ "3 MAX",
+ "3 MIN",
+ "8 ScanTYPE",
+ "8 InstCTRL",
+ "7 INS_$8F",
+
+ "7 INS_$90",
+ "7 GXAXIS",
+ "7 INS_$92",
+ "7 INS_$93",
+ "7 INS_$94",
+ "7 INS_$95",
+ "7 INS_$96",
+ "7 INS_$97",
+ "7 INS_$98",
+ "7 INS_$99",
+ "7 INS_$9A",
+ "7 INS_$9B",
+ "7 INS_$9C",
+ "7 INS_$9D",
+ "7 INS_$9E",
+ "7 INS_$9F",
+
+ "7 INS_$A0",
+ "7 INS_$A1",
+ "7 INS_$A2",
+ "7 INS_$A3",
+ "7 INS_$A4",
+ "7 INS_$A5",
+ "7 INS_$A6",
+ "7 INS_$A7",
+ "7 INS_$A8",
+ "7 INS_$A9",
+ "7 INS_$AA",
+ "7 INS_$AB",
+ "7 INS_$AC",
+ "7 INS_$AD",
+ "7 INS_$AE",
+ "7 INS_$AF",
+
+ "8 PushB[0]",
+ "8 PushB[1]",
+ "8 PushB[2]",
+ "8 PushB[3]",
+ "8 PushB[4]",
+ "8 PushB[5]",
+ "8 PushB[6]",
+ "8 PushB[7]",
+ "8 PushW[0]",
+ "8 PushW[1]",
+ "8 PushW[2]",
+ "8 PushW[3]",
+ "8 PushW[4]",
+ "8 PushW[5]",
+ "8 PushW[6]",
+ "8 PushW[7]",
+
+ "7 MDRP[G]",
+ "7 MDRP[B]",
+ "7 MDRP[W]",
+ "7 MDRP[?]",
+ "8 MDRP[rG]",
+ "8 MDRP[rB]",
+ "8 MDRP[rW]",
+ "8 MDRP[r?]",
+ "8 MDRP[mG]",
+ "8 MDRP[mB]",
+ "8 MDRP[mW]",
+ "8 MDRP[m?]",
+ "9 MDRP[mrG]",
+ "9 MDRP[mrB]",
+ "9 MDRP[mrW]",
+ "9 MDRP[mr?]",
+
+ "8 MDRP[pG]",
+ "8 MDRP[pB]",
+ "8 MDRP[pW]",
+ "8 MDRP[p?]",
+ "9 MDRP[prG]",
+ "9 MDRP[prB]",
+ "9 MDRP[prW]",
+ "9 MDRP[pr?]",
+ "9 MDRP[pmG]",
+ "9 MDRP[pmB]",
+ "9 MDRP[pmW]",
+ "9 MDRP[pm?]",
+ "A MDRP[pmrG]",
+ "A MDRP[pmrB]",
+ "A MDRP[pmrW]",
+ "A MDRP[pmr?]",
+
+ "7 MIRP[G]",
+ "7 MIRP[B]",
+ "7 MIRP[W]",
+ "7 MIRP[?]",
+ "8 MIRP[rG]",
+ "8 MIRP[rB]",
+ "8 MIRP[rW]",
+ "8 MIRP[r?]",
+ "8 MIRP[mG]",
+ "8 MIRP[mB]",
+ "8 MIRP[mW]",
+ "8 MIRP[m?]",
+ "9 MIRP[mrG]",
+ "9 MIRP[mrB]",
+ "9 MIRP[mrW]",
+ "9 MIRP[mr?]",
+
+ "8 MIRP[pG]",
+ "8 MIRP[pB]",
+ "8 MIRP[pW]",
+ "8 MIRP[p?]",
+ "9 MIRP[prG]",
+ "9 MIRP[prB]",
+ "9 MIRP[prW]",
+ "9 MIRP[pr?]",
+ "9 MIRP[pmG]",
+ "9 MIRP[pmB]",
+ "9 MIRP[pmW]",
+ "9 MIRP[pm?]",
+ "A MIRP[pmrG]",
+ "A MIRP[pmrB]",
+ "A MIRP[pmrW]",
+ "A MIRP[pmr?]"
+ };
+
+ return opcode_names[opcode];
+}
+
+static void
+sfnt_draw_debugger (struct sfnt_interpreter *interpreter)
+{
+ int x, y, i;
+ char buffer[80];
+ const char *name;
+ int opcode;
+
+ sprintf (buffer, "opcode:IP:depth: 0x%x:%d:%d",
+ interpreter->instructions[interpreter->IP],
+ interpreter->IP,
+ interpreter->call_depth);
+
+ /* Clear the window. */
+ XFillRectangle (display, window, background_gc,
+ 0, 0, 65535, 65535);
+
+ /* Draw some information about the opcode. */
+ XDrawString (display, window, point_gc, 0, 13, buffer,
+ strlen (buffer));
+
+ opcode = interpreter->instructions[interpreter->IP];
+
+ sprintf (buffer, "opcode: %s",
+ sfnt_name_instruction (opcode));
+
+ XDrawString (display, window, point_gc, 14, 27, buffer,
+ strlen (buffer));
+
+ if (interpreter->state.project
+ == sfnt_project_onto_x_axis_vector)
+ name = "X axis";
+ else if (interpreter->state.project
+ == sfnt_project_onto_y_axis_vector)
+ name = "Y axis";
+ else
+ name = "Any";
+
+ sprintf (buffer, "projection function: %s", name);
+
+ XDrawString (display, window, point_gc, 28, 42, buffer,
+ strlen (buffer));
+
+ /* Draw each point onto the window. */
+ for (i = 0; i < interpreter->glyph_zone->num_points; ++i)
+ {
+ x = interpreter->glyph_zone->x_current[i] / 16;
+ y = (200 - interpreter->glyph_zone->y_current[i] / 16);
+
+ XFillRectangle (display, window, point_gc, x, y, 4, 4);
+ }
+}
+
+static void
+sfnt_run_hook (struct sfnt_interpreter *interpreter)
+{
+ pid_t pid;
+ XEvent event;
+
+#ifdef TEST_BREAK_AFTER
+ static unsigned int instructions;
+
+ if (++instructions < TEST_BREAK_AFTER)
+ return;
+#endif
+
+ pid = fork ();
+
+ if (pid == 0)
+ {
+ sfnt_setup_debugger ();
+
+ while (true)
+ {
+ XNextEvent (display, &event);
+
+ switch (event.type)
+ {
+ case KeyPress:
+ XDestroyWindow (display, window);
+ XCloseDisplay (display);
+ exit (0);
+ break;
+
+ case Expose:
+ sfnt_draw_debugger (interpreter);
+ break;
+ }
+ }
+ }
+ else
+ {
+ while (waitpid (pid, NULL, 0) != pid && errno == EINTR)
+ /* Spin. */;
+ }
+}
+
+static struct sfnt_prep_table *exec_prep;
+static struct sfnt_fpgm_table *exec_fpgm;
+
+static const char *
+sfnt_identify_instruction (struct sfnt_interpreter *interpreter)
+{
+ static char buffer[256];
+ unsigned char *where;
+
+ where = interpreter->instructions + interpreter->IP;
+
+ if (exec_prep
+ && where >= exec_prep->instructions
+ && where < (exec_prep->instructions
+ + exec_prep->num_instructions))
+ {
+ sprintf (buffer, "prep+%td",
+ where - exec_prep->instructions);
+ return buffer;
+ }
+
+ if (exec_fpgm
+ && exec_fpgm->instructions
+ && where >= exec_fpgm->instructions
+ && where < (exec_fpgm->instructions
+ + exec_fpgm->num_instructions))
+ {
+ sprintf (buffer, "fpgm+%td",
+ where - exec_fpgm->instructions);
+ return buffer;
+ }
+
+ sprintf (buffer, "IP+%td", where - interpreter->instructions);
+ return buffer;
+}
+
+/* Function called to rasterize a glyph outline. */
+#define TYPE struct sfnt_glyph_outline *
+static struct sfnt_raster *(*test_raster_glyph_outline) (TYPE);
+#undef TYPE
+
+static void
+sfnt_verbose (struct sfnt_interpreter *interpreter)
+{
+ struct sfnt_instructed_outline temp;
+ struct sfnt_glyph_outline *outline;
+ struct sfnt_raster *raster;
+ unsigned char opcode;
+ const char *name;
+ static unsigned int instructions;
+ sfnt_fixed advance;
+
+ /* Build a temporary outline containing the values of the
+ interpreter's glyph zone. */
+
+ if (interpreter->glyph_zone)
+ {
+ temp.num_points = interpreter->glyph_zone->num_points;
+ temp.num_contours = interpreter->glyph_zone->num_contours;
+ temp.contour_end_points = interpreter->glyph_zone->contour_end_points;
+ temp.x_points = interpreter->glyph_zone->x_current;
+ temp.y_points = interpreter->glyph_zone->y_current;
+ temp.flags = interpreter->glyph_zone->flags;
+
+ outline = sfnt_build_instructed_outline (&temp, &advance);
+
+ if (!outline)
+ return;
+
+ printf ("outline bounds: %g %g, %g %g\n",
+ sfnt_coerce_fixed (outline->xmin),
+ sfnt_coerce_fixed (outline->ymin),
+ sfnt_coerce_fixed (outline->xmax),
+ sfnt_coerce_fixed (outline->ymax));
+
+ raster = (*test_raster_glyph_outline) (outline);
+
+ if (raster)
+ sfnt_test_raster (raster, NULL, 0);
+
+ xfree (outline);
+ xfree (raster);
+ }
+
+ opcode = interpreter->instructions[interpreter->IP];
+ printf ("opcode, number of instructions: %s %u\n",
+ sfnt_name_instruction (opcode), instructions++);
+ printf ("instruction: %s\n",
+ sfnt_identify_instruction (interpreter));
+
+ if (interpreter->state.project
+ == sfnt_project_onto_x_axis_vector)
+ name = "X axis";
+ else if (interpreter->state.project
+ == sfnt_project_onto_y_axis_vector)
+ name = "Y axis";
+ else
+ name = "Any";
+
+ printf ("projection function: %s\n", name);
+
+ printf ("proj and free vecs: %d %d %d %d\n",
+ interpreter->state.projection_vector.x,
+ interpreter->state.projection_vector.y,
+ interpreter->state.freedom_vector.x,
+ interpreter->state.freedom_vector.y);
+}
+
+static void
+sfnt_push_hook (struct sfnt_interpreter *interpreter,
+ uint32_t value)
+{
+ int32_t alternate;
+
+ alternate = value;
+
+ fprintf (stderr, "--> %"PRIi32"\n", alternate);
+}
+
+static void
+sfnt_pop_hook (struct sfnt_interpreter *interpreter,
+ uint32_t value)
+{
+ int32_t alternate;
+
+ alternate = value;
+
+ fprintf (stderr, "<<- %"PRIi32"\n", alternate);
+}
+
+
+
+static void
+sfnt_test_uvs (int fd, struct sfnt_cmap_format_14 *format14)
+{
+ struct sfnt_uvs_context *context;
+ size_t i, j, k;
+ sfnt_glyph glyph;
+ sfnt_char c;
+ struct sfnt_nondefault_uvs_table *uvs;
+ struct sfnt_default_uvs_table *default_uvs;
+
+ context = sfnt_create_uvs_context (format14, fd);
+
+ /* Print each variation selector and its associated ranges. */
+
+ if (!context)
+ fprintf (stderr, "failed to read uvs data\n");
+ else
+ {
+ fprintf (stderr, "UVS context with %zu records and %zu tables\n",
+ context->num_records, context->nmemb);
+
+ for (i = 0; i < context->num_records; ++i)
+ {
+ if (context->records[i].default_uvs)
+ {
+ default_uvs = context->records[i].default_uvs;
+
+ for (j = 0; j < default_uvs->num_unicode_value_ranges; ++j)
+ {
+ fprintf (stderr, " Default UVS: %u, %u\n",
+ default_uvs->ranges[j].start_unicode_value,
+ default_uvs->ranges[j].additional_count);
+
+ c = default_uvs->ranges[j].start_unicode_value;
+ k = 0;
+
+ for (; k <= default_uvs->ranges[j].additional_count; ++k)
+ {
+ if (!sfnt_is_character_default (default_uvs, c + k))
+ abort ();
+ }
+ }
+ }
+
+ if (!context->records[i].nondefault_uvs)
+ continue;
+
+ uvs = context->records[i].nondefault_uvs;
+
+ for (j = 0; j < uvs->num_uvs_mappings; ++j)
+ {
+ c = uvs->mappings[j].unicode_value;
+ glyph = sfnt_variation_glyph_for_char (uvs, c);
+
+ if (glyph != uvs->mappings[j].base_character_value)
+ abort ();
+
+ fprintf (stderr, " UVS: %"PRIx32" (%"PRIx32") -> %"PRIu32"\n",
+ c, context->records[i].selector, glyph);
+ }
+ }
+
+ sfnt_free_uvs_context (context);
+ }
+}
+
+
+
+/* Main entry point. */
+
+/* Simple tests that were used while developing this file. By the
+ time you are reading this, they probably no longer work.
+
+ Compile like so in this directory:
+
+ gcc -Demacs -I. -I. -I../lib -I../lib -MMD -MF deps/.d -MP
+ -fno-common -Wall -Warith-conversion -Wdate-time
+ -Wdisabled-optimization -Wdouble-promotion -Wduplicated-cond
+ -Wextra -Wformat-signedness -Winit-self -Winvalid-pch -Wlogical-op
+ -Wmissing-declarations -Wmissing-include-dirs -Wmissing-prototypes
+ -Wnested-externs -Wnull-dereference -Wold-style-definition
+ -Wopenmp-simd -Wpacked -Wpointer-arith -Wstrict-prototypes
+ -Wsuggest-attribute=format -Wsuggest-final-methods
+ -Wsuggest-final-types -Wtrampolines -Wuninitialized
+ -Wunknown-pragmas -Wunused-macros -Wvariadic-macros
+ -Wvector-operation-performance -Wwrite-strings -Warray-bounds=2
+ -Wattribute-alias=2 -Wformat=2 -Wformat-truncation=2
+ -Wimplicit-fallthrough=5 -Wshift-overflow=2 -Wuse-after-free=3
+ -Wvla-larger-than=4031 -Wredundant-decls
+ -Wno-missing-field-initializers -Wno-override-init
+ -Wno-sign-compare -Wno-type-limits -Wno-unused-parameter
+ -Wno-format-nonliteral -Wno-bidi-chars -g3 -O0 -DTEST sfnt.c -o
+ sfnt ../lib/libgnu.a -lX11 -lXrender
+
+ after gnulib has been built. Then, run ./sfnt
+ /path/to/font.ttf. */
+
+int
+main (int argc, char **argv)
+{
+ struct sfnt_offset_subtable *font;
+ struct sfnt_cmap_encoding_subtable *subtables;
+ struct sfnt_cmap_encoding_subtable_data **data;
+ struct sfnt_cmap_table *table;
+ int fd, i, j;
+ sfnt_char character;
+ struct sfnt_head_table *head;
+ struct sfnt_hhea_table *hhea;
+ struct sfnt_loca_table_short *loca_short;
+ struct sfnt_loca_table_long *loca_long;
+ struct sfnt_glyf_table *glyf;
+ struct sfnt_glyph *glyph;
+ sfnt_glyph code;
+ struct sfnt_test_dcontext dcontext;
+ struct sfnt_glyph_outline *outline;
+ struct timespec start, end, sub, sub1, sub2, sub3;
+ static struct sfnt_maxp_table *maxp;
+ struct sfnt_raster *raster;
+ struct sfnt_hmtx_table *hmtx;
+ struct sfnt_glyph_metrics metrics;
+ struct sfnt_name_table *name;
+ unsigned char *string;
+ struct sfnt_name_record record;
+ struct sfnt_meta_table *meta;
+ struct sfnt_ttc_header *ttc;
+ struct sfnt_interpreter *interpreter;
+ struct sfnt_cvt_table *cvt;
+ struct sfnt_fpgm_table *fpgm;
+ const char *trap;
+ struct sfnt_prep_table *prep;
+ struct sfnt_graphics_state state;
+ struct sfnt_instructed_outline *value;
+ struct sfnt_fvar_table *fvar;
+ struct sfnt_gvar_table *gvar;
+ struct sfnt_avar_table *avar;
+ struct sfnt_cvar_table *cvar;
+ struct sfnt_OS_2_table *OS_2;
+ struct sfnt_post_table *post;
+ sfnt_fixed scale;
+ char *fancy;
+ int *advances;
+ struct sfnt_raster **rasters;
+ size_t length;
+ char *axis_name;
+ struct sfnt_instance *instance;
+ struct sfnt_blend blend;
+ struct sfnt_metrics_distortion distortion;
+ sfnt_fixed advance;
+
+ if (argc < 2)
+ return 1;
+
+ instance = NULL;
+
+ if (!strcmp (argv[1], "--check-interpreter"))
+ {
+ interpreter = sfnt_make_test_interpreter ();
+
+ if (!interpreter)
+ abort ();
+
+ if (getenv ("SFNT_VERBOSE"))
+ {
+ interpreter->run_hook = sfnt_verbose;
+ interpreter->push_hook = sfnt_push_hook;
+ interpreter->pop_hook = sfnt_pop_hook;
+ }
+
+ for (i = 0; i < ARRAYELTS (all_tests); ++i)
+ sfnt_run_interpreter_test (&all_tests[i], interpreter);
+
+ exit (0);
+ }
+
+ if (getenv ("SFNT_EXACT_SCALING"))
+ test_raster_glyph_outline = sfnt_raster_glyph_outline_exact;
+ else
+ test_raster_glyph_outline = sfnt_raster_glyph_outline;
+
+ fd = open (argv[1], O_RDONLY);
+
+ if (fd < 0)
+ return 1;
+
+ ttc = NULL;
+
+ font = sfnt_read_table_directory (fd);
+
+ if (font == (struct sfnt_offset_subtable *) -1)
+ {
+ if (lseek (fd, 0, SEEK_SET) != 0)
+ return 1;
+
+ ttc = sfnt_read_ttc_header (fd);
+
+ if (!ttc)
+ return 1;
+
+ fprintf (stderr, "TrueType collection: %"PRIu32" fonts installed\n",
+ ttc->num_fonts);
+ fflush (stderr);
+
+ printf ("Which font? ");
+ if (scanf ("%d", &i) == EOF)
+ return 1;
+
+ if (i >= ttc->num_fonts || i < 0)
+ {
+ printf ("out of range\n");
+ return 1;
+ }
+
+ if (lseek (fd, ttc->offset_table[i], SEEK_SET)
+ != ttc->offset_table[i])
+ return 1;
+
+ font = sfnt_read_table_directory (fd);
+ }
+
+ if (!font || font == (struct sfnt_offset_subtable *) -1)
+ {
+ close (fd);
+ return 1;
+ }
+
+ for (i = 0; i < font->num_tables; ++i)
+ fprintf (stderr, "Found new subtable with tag %"PRIx32
+ " at offset %"PRIu32"\n",
+ font->subtables[i].tag,
+ font->subtables[i].offset);
+
+ table = sfnt_read_cmap_table (fd, font, &subtables, &data);
+
+ if (!table)
+ {
+ close (fd);
+ xfree (font);
+ return 1;
+ }
+
+ fprintf (stderr, "number of subtables: %"PRIu16"\n",
+ table->num_subtables);
+
+ for (i = 0; i < table->num_subtables; ++i)
+ {
+ fprintf (stderr, "Found cmap table %"PRIu32": %p\n",
+ subtables[i].offset, (void *) data[i]);
+
+ if (data[i])
+ fprintf (stderr, " format: %"PRIu16"\n",
+ data[i]->format);
+ }
+
+ if (argc >= 3 && !strcmp (argv[2], "--check-variation-selectors"))
+ {
+ /* Look for a format 14 cmap table. */
+
+ for (i = 0; i < table->num_subtables; ++i)
+ {
+ if (data[i]->format == 14)
+ {
+ fprintf (stderr, "format 14 subtable found\n");
+ sfnt_test_uvs (fd, (struct sfnt_cmap_format_14 *) data[i]);
+ return 0;
+ }
+ }
+
+ return 1;
+ }
+
+#define FANCY_PPEM 18
+#define EASY_PPEM 18
+
+ interpreter = NULL;
+ head = sfnt_read_head_table (fd, font);
+ hhea = sfnt_read_hhea_table (fd, font);
+ glyf = sfnt_read_glyf_table (fd, font);
+ maxp = sfnt_read_maxp_table (fd, font);
+ name = sfnt_read_name_table (fd, font);
+ meta = sfnt_read_meta_table (fd, font);
+ cvt = sfnt_read_cvt_table (fd, font);
+ fpgm = sfnt_read_fpgm_table (fd, font);
+ prep = sfnt_read_prep_table (fd, font);
+ fvar = sfnt_read_fvar_table (fd, font);
+ gvar = sfnt_read_gvar_table (fd, font);
+ avar = sfnt_read_avar_table (fd, font);
+ OS_2 = sfnt_read_OS_2_table (fd, font);
+ post = sfnt_read_post_table (fd, font);
+ cvar = NULL;
+ hmtx = NULL;
+
+ if (fvar && cvt)
+ cvar = sfnt_read_cvar_table (fd, font, fvar, cvt);
+
+ if (cvar)
+ fprintf (stderr, "cvar table found\n");
+
+ exec_prep = prep;
+ exec_fpgm = fpgm;
+ fancy = getenv ("SFNT_FANCY_TEST");
+
+ loca_long = NULL;
+ loca_short = NULL;
+
+ if (OS_2)
+ fprintf (stderr, "OS/2 table found!\nach_vendor_id: %.4s\n",
+ OS_2->ach_vendor_id);
+
+ if (post)
+ fprintf (stderr, "post table: format: %g; italic-angle: %g;\n"
+ "underline_position: %"PRIi16"; underline_thickness: %"
+ PRIi16";\n"
+ "is_fixed_pitch: %"PRIu32"\n",
+ sfnt_coerce_fixed (post->format),
+ sfnt_coerce_fixed (post->italic_angle),
+ post->underline_position,
+ post->underline_thickness,
+ post->is_fixed_pitch);
+
+ if (fvar)
+ {
+ fprintf (stderr, "FVAR table found!\n"
+ "version: %"PRIu16".%"PRIu16"\n"
+ "axis_count: %"PRIu16"\n"
+ "axis_size: %"PRIu16"\n"
+ "instance_count: %"PRIu16"\n"
+ "instance_size: %"PRIu16"\n",
+ fvar->major_version,
+ fvar->minor_version,
+ fvar->axis_count,
+ fvar->axis_size,
+ fvar->instance_count,
+ fvar->instance_size);
+
+ for (i = 0; i < fvar->axis_count; ++i)
+ {
+ if (name)
+ {
+ axis_name
+ = (char *) sfnt_find_name (name, fvar->axis[i].name_id,
+ &record);
+
+ if (axis_name)
+ fprintf (stderr, "axis no: %d; name: %.*s\n",
+ i, record.length, axis_name);
+ }
+
+ fprintf (stderr, " axis: %"PRIx32" %g %g %g\n",
+ fvar->axis[i].axis_tag,
+ sfnt_coerce_fixed (fvar->axis[i].min_value),
+ sfnt_coerce_fixed (fvar->axis[i].default_value),
+ sfnt_coerce_fixed (fvar->axis[i].max_value));
+ }
+
+ for (i = 0; i < fvar->instance_count; ++i)
+ {
+ if (name)
+ {
+ axis_name
+ = (char *) sfnt_find_name (name, fvar->instance[i].name_id,
+ &record);
+
+ if (axis_name)
+ fprintf (stderr, "instance no: %d; name: %.*s\n",
+ i, record.length, axis_name);
+ }
+ }
+
+ if (fvar->instance_count > 1)
+ {
+ printf ("instance? ");
+
+ if (scanf ("%d", &i) == EOF)
+ goto free_lab;
+
+ if (i >= fvar->instance_count)
+ goto free_lab;
+
+ if (i >= 0)
+ instance = &fvar->instance[i];
+ }
+ }
+
+ if (gvar)
+ fprintf (stderr, "gvar table found\n");
+
+ if (avar)
+ {
+ fprintf (stderr, "avar table found\n");
+
+ for (i = 0; i < avar->axis_count; ++i)
+ {
+ fprintf (stderr, "axis: %d, %"PRIu16" pairs\n",
+ i, avar->segments[i].pair_count);
+
+ for (j = 0; j < avar->segments[i].pair_count; ++j)
+ fprintf (stderr, "pair: %g, %g\n",
+ (avar->segments[i].correspondence[j].from_coord
+ / 16384.0),
+ (avar->segments[i].correspondence[j].to_coord
+ / 16384.0));
+ }
+ }
+
+ memset (&blend, 0, sizeof blend);
+
+ if (instance && gvar)
+ {
+ sfnt_init_blend (&blend, fvar, gvar, avar,
+ cvar);
+
+ for (i = 0; i < fvar->axis_count; ++i)
+ blend.coords[i] = instance->coords[i];
+
+ sfnt_normalize_blend (&blend);
+ }
+
+ if (fancy)
+ {
+ length = strlen (fancy);
+ scale = sfnt_div_fixed (FANCY_PPEM, head->units_per_em);
+
+ if (hhea && maxp)
+ hmtx = sfnt_read_hmtx_table (fd, font, hhea, maxp);
+
+ if (!maxp || !head || !prep || !hmtx || !hhea
+ || table->num_subtables < 1)
+ exit (1);
+
+ if (head->index_to_loc_format)
+ {
+ loca_long = sfnt_read_loca_table_long (fd, font);
+ if (!loca_long)
+ return 1;
+
+ fprintf (stderr, "long loca table has %zu glyphs\n",
+ loca_long->num_offsets);
+ }
+ else
+ {
+ loca_short = sfnt_read_loca_table_short (fd, font);
+ if (!loca_short)
+ return 1;
+
+ fprintf (stderr, "short loca table has %zu glyphs\n",
+ loca_short->num_offsets);
+ }
+
+ interpreter = sfnt_make_interpreter (maxp, cvt, head, fvar,
+ FANCY_PPEM, FANCY_PPEM);
+ if (instance && gvar)
+ sfnt_vary_interpreter (interpreter, &blend);
+
+ if (!interpreter)
+ exit (1);
+
+ if (fpgm)
+ {
+ fprintf (stderr, "interpreting the font program, with"
+ " %zu instructions\n", fpgm->num_instructions);
+ trap = sfnt_interpret_font_program (interpreter, fpgm);
+
+ if (trap)
+ fprintf (stderr, "**TRAP**: %s\n", trap);
+ }
+
+ if (prep)
+ {
+ fprintf (stderr, "interpreting the control value program, with"
+ " %zu instructions\n", prep->num_instructions);
+ trap = sfnt_interpret_control_value_program (interpreter, prep,
+ &state);
+
+ if (trap)
+ fprintf (stderr, "**TRAP**: %s\n", trap);
+ }
+
+ state = interpreter->state;
+
+ advances = alloca (sizeof *advances * length);
+ rasters = alloca (sizeof *rasters * length);
+
+ for (i = 0; i < length; ++i)
+ {
+ code = sfnt_lookup_glyph (fancy[i], data[0]);
+
+ if (!code)
+ exit (2);
+
+ glyph = sfnt_read_glyph (code, glyf, loca_short,
+ loca_long);
+
+ if (!glyph || !glyph->simple)
+ exit (3);
+
+ if (instance && gvar)
+ sfnt_vary_simple_glyph (&blend, code, glyph,
+ &distortion);
+ else
+ memset (&distortion, 0, sizeof distortion);
+
+ if (sfnt_lookup_glyph_metrics (code, &metrics,
+ hmtx, hhea, maxp))
+ exit (4);
+
+ interpreter->state = state;
+ trap = sfnt_interpret_simple_glyph (glyph, interpreter,
+ &metrics, &value);
+
+ if (trap)
+ {
+ fprintf (stderr, "*TRAP*: %s\n", trap);
+ exit (5);
+ }
+
+ outline = sfnt_build_instructed_outline (value, &advance);
+ advances[i] = (advance / 65536);
+
+ fprintf (stderr, "advance: %d\n", advances[i]);
+
+ if (!outline)
+ exit (6);
+
+ xfree (value);
+
+ raster = (*test_raster_glyph_outline) (outline);
+
+ if (!raster)
+ exit (7);
+
+ xfree (outline);
+
+ rasters[i] = raster;
+ }
+
+ sfnt_x_raster (rasters, advances, length, hhea, scale);
+ exit (0);
+ }
+
+ if (hhea && maxp)
+ hmtx = sfnt_read_hmtx_table (fd, font, hhea, maxp);
+
+ if (maxp)
+ fprintf (stderr, "maxp says num glyphs is %"PRIu16"\n",
+ maxp->num_glyphs);
+
+ if (name)
+ {
+ fprintf (stderr, "name table of format: %"PRIu16" count: %"
+ PRIu16"\n", name->format, name->count);
+
+ string = sfnt_find_name (name, SFNT_NAME_FONT_FAMILY,
+ &record);
+
+ if (string)
+ fprintf (stderr, "FONT_FAMILY: %"PRIu16", %"PRIu16"\n",
+ record.platform_id, record.length);
+ }
+
+ if (meta)
+ {
+ fprintf (stderr, "meta table with count: %"PRIu32"\n",
+ meta->num_data_maps);
+
+ for (i = 0; i < meta->num_data_maps; ++i)
+ fprintf (stderr, " meta tag: %"PRIx32"\n",
+ meta->data_maps[i].tag);
+ }
+
+ loca_long = NULL;
+ loca_short = NULL;
+
+ if (head)
+ {
+ fprintf (stderr, "HEAD table:\n"
+ "version: \t\t\t%g\n"
+ "revision: \t\t\t%g\n"
+ "checksum_adjustment: \t\t%"PRIu32"\n"
+ "magic: \t\t\t\t%"PRIx32"\n"
+ "flags: \t\t\t\t%"PRIx16"\n"
+ "units_per_em: \t\t\t%"PRIu16"\n"
+ "xmin, ymin, xmax, ymax: \t%d, %d, %d, %d\n"
+ "mac_style: \t\t\t%"PRIx16"\n"
+ "lowest_rec_ppem: \t\t%"PRIu16"\n"
+ "font_direction_hint: \t\t%"PRIi16"\n"
+ "index_to_loc_format: \t\t%"PRIi16"\n"
+ "glyph_data_format: \t\t%"PRIi16"\n",
+ sfnt_coerce_fixed (head->version),
+ sfnt_coerce_fixed (head->revision),
+ head->checksum_adjustment,
+ head->magic,
+ head->flags,
+ head->units_per_em,
+ (int) head->xmin,
+ (int) head->ymin,
+ (int) head->xmax,
+ (int) head->ymax,
+ head->mac_style,
+ head->lowest_rec_ppem,
+ head->font_direction_hint,
+ head->index_to_loc_format,
+ head->glyph_data_format);
+
+ if (head->index_to_loc_format)
+ {
+ loca_long = sfnt_read_loca_table_long (fd, font);
+ if (!loca_long)
+ return 1;
+
+ fprintf (stderr, "long loca table has %zu glyphs\n",
+ loca_long->num_offsets);
+ }
+ else
+ {
+ loca_short = sfnt_read_loca_table_short (fd, font);
+ if (!loca_short)
+ return 1;
+
+ fprintf (stderr, "short loca table has %zu glyphs\n",
+ loca_short->num_offsets);
+ }
+ }
+
+ if (hhea)
+ fprintf (stderr, "HHEA table:\n"
+ "version: \t\t\t%g\n"
+ "ascent, descent: \t\t%d %d\n"
+ "line_gap: \t\t\t%d\n"
+ "advance_width_max: \t\t%u\n"
+ "min_lsb: \t\t\t%d\n"
+ "min_rsb: \t\t\t%d\n"
+ "caret_srise: \t\t\t%d\n"
+ "caret_srun: \t\t\t%d\n",
+ sfnt_coerce_fixed (hhea->version),
+ (int) hhea->ascent,
+ (int) hhea->descent,
+ (int) hhea->line_gap,
+ (unsigned int) hhea->advance_width_max,
+ (int) hhea->min_left_side_bearing,
+ (int) hhea->min_right_side_bearing,
+ (int) hhea->caret_slope_rise,
+ (int) hhea->caret_slope_run);
+
+ if (head && maxp && maxp->version >= 0x00010000)
+ {
+ fprintf (stderr, "creating interpreter\n"
+ "the size of the stack is %"PRIu16"\n"
+ "the size of the twilight zone is %"PRIu16"\n"
+ "the size of the storage area is %"PRIu16"\n"
+ "there are at most %"PRIu16" idefs\n"
+ "there are at most %"PRIu16" fdefs\n"
+ "the cvt is %zu fwords in length\n",
+ maxp->max_stack_elements,
+ maxp->max_twilight_points,
+ maxp->max_storage,
+ maxp->max_instruction_defs,
+ maxp->max_function_defs,
+ cvt ? cvt->num_elements : 0ul);
+
+ interpreter = sfnt_make_interpreter (maxp, cvt, head,
+ fvar, FANCY_PPEM,
+ FANCY_PPEM);
+
+ if (getenv ("SFNT_DEBUG"))
+ interpreter->run_hook = sfnt_run_hook;
+ else if (getenv ("SFNT_VERBOSE"))
+ {
+ interpreter->run_hook = sfnt_verbose;
+ interpreter->push_hook = sfnt_push_hook;
+ interpreter->pop_hook = sfnt_pop_hook;
+ }
+
+ state = interpreter->state;
+
+ if (instance && gvar)
+ sfnt_vary_interpreter (interpreter, &blend);
+
+ if (fpgm)
+ {
+ fprintf (stderr, "interpreting the font program, with"
+ " %zu instructions\n", fpgm->num_instructions);
+
+ trap = sfnt_interpret_font_program (interpreter, fpgm);
+
+ if (trap)
+ fprintf (stderr, "**TRAP**: %s\n", trap);
+ }
+
+ if (prep)
+ {
+ fprintf (stderr, "interpreting the control value program, with"
+ " %zu instructions\n", prep->num_instructions);
+
+ trap = sfnt_interpret_control_value_program (interpreter, prep,
+ &state);
+
+ if (trap)
+ fprintf (stderr, "**TRAP**: %s\n", trap);
+ }
+ }
+
+ while (true)
+ {
+ printf ("table, character? ");
+
+ if (scanf ("%d %"SCNu32"", &i, &character) == EOF)
+ break;
+
+ if (i < 0 || i >= table->num_subtables)
+ {
+ printf ("table out of range\n");
+ continue;
+ }
+
+ if (!data[i])
+ {
+ printf ("table not present\n");
+ continue;
+ }
+
+ code = sfnt_lookup_glyph (character, data[i]);
+ printf ("glyph is %"PRIu32"\n", code);
+
+ if ((loca_long || loca_short) && glyf)
+ {
+ scale = sfnt_div_fixed (EASY_PPEM, head->units_per_em);
+ glyph = sfnt_read_glyph (code, glyf, loca_short,
+ loca_long);
+
+ if (glyph)
+ {
+ printf ("glyph is: %s\n",
+ glyph->simple ? "simple" : "compound");
+
+ dcontext.glyf = glyf;
+ dcontext.loca_short = loca_short;
+ dcontext.loca_long = loca_long;
+ dcontext.hmtx = hmtx;
+ dcontext.hhea = hhea;
+ dcontext.maxp = maxp;
+
+ if (instance && gvar)
+ dcontext.blend = &blend;
+ else
+ dcontext.blend = NULL;
+
+ if (glyph->simple && instance && gvar)
+ {
+ printf ("applying variations to simple glyph...\n");
+
+ clock_gettime (CLOCK_THREAD_CPUTIME_ID, &start);
+ if (sfnt_vary_simple_glyph (&blend, code, glyph,
+ &distortion))
+ printf ("variation failed!\n");
+ clock_gettime (CLOCK_THREAD_CPUTIME_ID, &end);
+ sub = timespec_sub (end, start);
+
+ printf ("time spent varying: %lld sec %ld nsec\n",
+ (long long) sub.tv_sec, sub.tv_nsec);
+ printf ("distortions: %"PRIi16", %"PRIi16"\n",
+ distortion.origin, distortion.advance);
+ }
+ else if (instance && gvar)
+ {
+ printf ("applying variations to compound glyph...\n");
+
+ if (sfnt_vary_compound_glyph (&blend, code, glyph,
+ &distortion))
+ printf ("variation failed!\n");
+ }
+
+ if (sfnt_lookup_glyph_metrics (code, &metrics,
+ hmtx, hhea, maxp))
+ {
+ printf ("metrics lookup failure");
+ memset (&metrics, 0, sizeof metrics);
+ }
+
+ if (sfnt_decompose_glyph (glyph, &metrics,
+ sfnt_test_move_to,
+ sfnt_test_line_to,
+ sfnt_test_curve_to,
+ sfnt_test_get_glyph,
+ sfnt_test_free_glyph,
+ sfnt_test_get_metrics,
+ &dcontext))
+ printf ("decomposition failure\n");
+
+ if (sfnt_lookup_glyph_metrics (code, &metrics,
+ hmtx, hhea, maxp))
+ {
+ printf ("metrics lookup failure");
+ memset (&metrics, 0, sizeof metrics);
+ }
+
+ /* Time this important bit. */
+ clock_gettime (CLOCK_THREAD_CPUTIME_ID, &start);
+ outline = sfnt_build_glyph_outline (glyph, scale,
+ &metrics,
+ sfnt_test_get_glyph,
+ sfnt_test_free_glyph,
+ sfnt_test_get_metrics,
+ &dcontext);
+
+ clock_gettime (CLOCK_THREAD_CPUTIME_ID, &end);
+ sub = timespec_sub (end, start);
+ memset (&sub1, 0, sizeof sub1);
+
+ if (outline)
+ {
+ fprintf (stderr, "outline origin, rbearing: %"
+ PRIi32" %"PRIi32"\n",
+ outline->origin,
+ outline->xmax - outline->origin);
+ sfnt_test_max = outline->ymax - outline->ymin;
+
+ for (i = 0; i < outline->outline_used; i++)
+ printf ("ctx.%s (%g, %g) /* %g, %g */\n",
+ ((outline->outline[i].flags
+ & SFNT_GLYPH_OUTLINE_LINETO)
+ ? "lineTo" : "moveTo"),
+ sfnt_coerce_fixed (outline->outline[i].x
+ - outline->xmin),
+ sfnt_coerce_fixed (sfnt_test_max
+ - (outline->outline[i].y
+ - outline->ymin)),
+ sfnt_coerce_fixed (outline->outline[i].x
+ - outline->xmin),
+ sfnt_coerce_fixed (outline->outline[i].y
+ - outline->ymin));
+
+ clock_gettime (CLOCK_THREAD_CPUTIME_ID, &start);
+ sfnt_build_outline_edges (outline, sfnt_test_edge_ignore,
+ NULL);
+ clock_gettime (CLOCK_THREAD_CPUTIME_ID, &end);
+ sub1 = timespec_sub (end, start);
+
+ sfnt_build_outline_edges (outline, sfnt_test_edge,
+ NULL);
+
+ raster = NULL;
+
+ clock_gettime (CLOCK_THREAD_CPUTIME_ID, &start);
+
+ for (i = 0; i < 12800; ++i)
+ {
+ xfree (raster);
+ raster = (*test_raster_glyph_outline) (outline);
+ }
+
+ clock_gettime (CLOCK_THREAD_CPUTIME_ID, &end);
+ sub2 = timespec_sub (end, start);
+
+ /* Print out the raster. */
+ sfnt_test_raster (raster, hhea, scale);
+ printf ("raster offsets: %d, %d\n",
+ raster->offx, raster->offy);
+
+ xfree (raster);
+
+ printf ("outline bounds: %g %g, %g %g\n",
+ sfnt_coerce_fixed (outline->xmin),
+ sfnt_coerce_fixed (outline->ymin),
+ sfnt_coerce_fixed (outline->xmax),
+ sfnt_coerce_fixed (outline->ymax));
+ }
+
+ if (hmtx && head)
+ {
+ sfnt_scale_metrics (&metrics, scale);
+ printf ("scaled lbearing, advance: %g, %g\n",
+ sfnt_coerce_fixed (metrics.lbearing),
+ sfnt_coerce_fixed (metrics.advance));
+
+ if (!sfnt_lookup_glyph_metrics (code, &metrics, hmtx,
+ hhea, maxp))
+ {
+ sfnt_scale_metrics (&metrics, scale);
+ printf ("lbearing, advance: %g, %g\n",
+ sfnt_coerce_fixed (metrics.lbearing),
+ sfnt_coerce_fixed (metrics.advance));
+ }
+
+ if (interpreter)
+ {
+ if (!sfnt_lookup_glyph_metrics (code, &metrics,
+ hmtx, hhea, maxp))
+ {
+ printf ("interpreting glyph\n");
+ interpreter->state = state;
+ clock_gettime (CLOCK_THREAD_CPUTIME_ID, &start);
+ if (glyph->simple)
+ trap
+ = sfnt_interpret_simple_glyph (glyph,
+ interpreter,
+ &metrics,
+ &value);
+ else
+#define GG sfnt_test_get_glyph
+#define FG sfnt_test_free_glyph
+ trap
+ = sfnt_interpret_compound_glyph (glyph,
+ interpreter,
+ &state,
+ GG, FG,
+ hmtx, hhea,
+ maxp,
+ &metrics,
+ &dcontext,
+ &value);
+#undef GG
+#undef FG
+ clock_gettime (CLOCK_THREAD_CPUTIME_ID, &end);
+ sub3 = timespec_sub (end, start);
+
+ if (trap)
+ printf ("**TRAP**: %s\n", trap);
+ else
+ {
+ printf ("rasterizing instructed outline\n");
+ if (outline)
+ xfree (outline);
+ outline
+ = sfnt_build_instructed_outline (value,
+ &advance);
+ xfree (value);
+
+#define LB outline->xmin - outline->origin
+#define RB outline->xmax - outline->origin
+ printf ("instructed advance, lb, rb: %g %g %g\n",
+ sfnt_coerce_fixed (advance),
+ sfnt_coerce_fixed (LB),
+ sfnt_coerce_fixed (RB));
+#undef LB
+#undef RB
+
+ if (outline)
+ {
+ raster
+ = (*test_raster_glyph_outline) (outline);
+
+ if (raster)
+ {
+ sfnt_test_raster (raster, hhea, scale);
+ printf ("raster offsets: %d, %d\n",
+ raster->offx, raster->offy);
+ xfree (raster);
+ }
+ }
+ }
+
+ fprintf (stderr, "execution time: %lld sec %ld nse"
+ "c\n",
+ (long long) sub3.tv_sec, sub3.tv_nsec);
+ }
+
+ interpreter->run_hook = NULL;
+ }
+ }
+
+ printf ("time spent outlining: %lld sec %ld nsec\n",
+ (long long) sub.tv_sec, sub.tv_nsec);
+ printf ("time spent building edges: %lld sec %ld nsec\n",
+ (long long) sub1.tv_sec, sub1.tv_nsec);
+ printf ("time spent rasterizing: %lld sec %ld nsec\n",
+ (long long) sub2.tv_sec / 12800,
+ sub2.tv_nsec / 12800);
+
+ xfree (outline);
+ }
+
+ sfnt_free_glyph (glyph);
+ }
+ }
+
+ free_lab:
+
+ xfree (font);
+
+ for (i = 0; i < table->num_subtables; ++i)
+ xfree (data[i]);
+
+ if (instance && gvar)
+ sfnt_free_blend (&blend);
+
+ xfree (table);
+ xfree (data);
+ xfree (subtables);
+ xfree (head);
+ xfree (hhea);
+ xfree (loca_long);
+ xfree (loca_short);
+ xfree (glyf);
+ xfree (maxp);
+ xfree (hmtx);
+ xfree (name);
+ xfree (meta);
+ xfree (ttc);
+ xfree (cvt);
+ xfree (fpgm);
+ xfree (interpreter);
+ xfree (prep);
+ xfree (fvar);
+ xfree (gvar);
+ xfree (avar);
+ xfree (cvar);
+ xfree (OS_2);
+ xfree (post);
+
+ return 0;
+}
+
+#endif
diff --git a/src/sfnt.h b/src/sfnt.h
new file mode 100644
index 00000000000..444b1dfe427
--- /dev/null
+++ b/src/sfnt.h
@@ -0,0 +1,2151 @@
+/* sfnt format font support for GNU Emacs.
+
+Copyright (C) 2023-2024 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 <https://www.gnu.org/licenses/>. */
+
+#ifndef _SFNT_H_
+#define _SFNT_H_
+
+#include <stdint.h>
+#include <stddef.h>
+#include <setjmp.h>
+
+#include <sys/types.h>
+
+
+
+/* Container structure and enumerator definitions. */
+
+/* The sfnt container format is organized into different tables, such
+ as ``cmap'' or ``glyf''. Each of these tables has a specific
+ format and use. These are all the tables known to Emacs. */
+
+enum sfnt_table
+ {
+ SFNT_TABLE_CMAP,
+ SFNT_TABLE_GLYF,
+ SFNT_TABLE_HEAD,
+ SFNT_TABLE_HHEA,
+ SFNT_TABLE_HMTX,
+ SFNT_TABLE_LOCA,
+ SFNT_TABLE_MAXP,
+ SFNT_TABLE_NAME,
+ SFNT_TABLE_META,
+ SFNT_TABLE_CVT ,
+ SFNT_TABLE_FPGM,
+ SFNT_TABLE_PREP,
+ SFNT_TABLE_FVAR,
+ SFNT_TABLE_GVAR,
+ SFNT_TABLE_CVAR,
+ SFNT_TABLE_AVAR,
+ SFNT_TABLE_OS_2,
+ SFNT_TABLE_POST,
+ };
+
+#define SFNT_ENDOF(type, field, type1) \
+ ((size_t) offsetof (type, field) + sizeof (type1))
+
+/* Each of these structures must be aligned so that no compiler will
+ ever generate padding bytes on platforms where the alignment
+ requirements for uint32_t and uint16_t are no larger than 4 and 2
+ bytes respectively.
+
+ Pointer types are assumed to impose an alignmnent requirement no
+ less than that of uint32_t.
+
+ If a table has more than one kind of variable-length subtable array
+ at the end, make sure to pad subsequent subtables
+ appropriately. */
+
+struct sfnt_offset_subtable
+{
+ /* The scaler type. */
+ uint32_t scaler_type;
+
+ /* The number of tables. */
+ uint16_t num_tables;
+
+ /* (Maximum power of 2 <= numTables) * 16. */
+ uint16_t search_range;
+
+ /* log2 (maximum power of 2 <= numTables) */
+ uint16_t entry_selector;
+
+ /* numTables * 16 - searchRange. */
+ uint16_t range_shift;
+
+ /* Variable length data. */
+ struct sfnt_table_directory *subtables;
+};
+
+/* The table directory. Follows the offset subtable, with one for
+ each table. */
+
+struct sfnt_table_directory
+{
+ /* 4-byte identifier for each table. See sfnt_table_names. */
+ uint32_t tag;
+
+ /* Table checksum. */
+ uint32_t checksum;
+
+ /* Offset from the start of the file. */
+ uint32_t offset;
+
+ /* Length of the table in bytes, not subject to padding. */
+ uint32_t length;
+};
+
+enum sfnt_scaler_type
+ {
+ SFNT_SCALER_TRUE = 0x74727565,
+ SFNT_SCALER_VER1 = 0x00010000,
+ SFNT_SCALER_TYP1 = 0x74797031,
+ SFNT_SCALER_OTTO = 0x4F54544F,
+ };
+
+typedef int32_t sfnt_fixed;
+typedef int16_t sfnt_fword;
+typedef uint16_t sfnt_ufword;
+
+#define sfnt_coerce_fixed(fixed) ((sfnt_fixed) (fixed) / 65535.0)
+#define sfnt_fixed_float(fixed) ((sfnt_fixed) (fixed) / 65535.0f)
+
+typedef unsigned int sfnt_glyph;
+typedef unsigned int sfnt_char;
+
+struct sfnt_head_table
+{
+ /* The version. This is a 16.16 fixed point number. */
+ sfnt_fixed version;
+
+ /* The revision. */
+ sfnt_fixed revision;
+
+ /* Checksum adjustment. */
+ uint32_t checksum_adjustment;
+
+ /* Magic number, should be 0x5F0F3CF5. */
+ uint32_t magic;
+
+ /* Flags for the font. */
+ uint16_t flags;
+
+ /* Units per em. */
+ uint16_t units_per_em;
+
+ /* Time of creation. */
+ uint32_t created_high, created_low;
+
+ /* Time of modification. */
+ uint32_t modified_high, modified_low;
+
+ /* Minimum bounds. */
+ sfnt_fword xmin, ymin, xmax, ymax;
+
+ /* Mac specific stuff. */
+ uint16_t mac_style;
+
+ /* Smallest readable size in pixels. */
+ uint16_t lowest_rec_ppem;
+
+ /* Font direction hint. */
+ int16_t font_direction_hint;
+
+ /* Index to loc format. 0 for short offsets, 1 for long. */
+ int16_t index_to_loc_format;
+
+ /* Unused. */
+ int16_t glyph_data_format;
+};
+
+struct sfnt_hhea_table
+{
+ /* The version. This is a 16.16 fixed point number. */
+ sfnt_fixed version;
+
+ /* The maximum ascent and descent values for this font. */
+ sfnt_fword ascent, descent;
+
+ /* The typographic line gap. */
+ sfnt_fword line_gap;
+
+ /* The maximum advance width. */
+ sfnt_ufword advance_width_max;
+
+ /* The minimum bearings on either side. */
+ sfnt_fword min_left_side_bearing, min_right_side_bearing;
+
+ /* The maximum extent. */
+ sfnt_fword x_max_extent;
+
+ /* Caret slope. */
+ int16_t caret_slope_rise, caret_slope_run;
+
+ /* Caret offset for non slanted fonts. */
+ sfnt_fword caret_offset;
+
+ /* Reserved values. */
+ int16_t reserved1, reserved2, reserved3, reserved4;
+
+ /* Should always be zero. */
+ int16_t metric_data_format;
+
+ /* Number of advanced widths in metrics table. */
+ uint16_t num_of_long_hor_metrics;
+};
+
+struct sfnt_cmap_table
+{
+ /* Should be zero. */
+ uint16_t version;
+
+ /* Number of subtables. */
+ uint16_t num_subtables;
+};
+
+enum sfnt_platform_id
+ {
+ SFNT_PLATFORM_UNICODE = 0,
+ SFNT_PLATFORM_MACINTOSH = 1,
+ SFNT_PLATFORM_RESERVED = 2,
+ SFNT_PLATFORM_MICROSOFT = 3,
+ };
+
+enum sfnt_unicode_platform_specific_id
+ {
+ SFNT_UNICODE_1_0 = 0,
+ SFNT_UNICODE_1_1 = 1,
+ SFNT_UNICODE_ISO_10646_1993 = 2,
+ SFNT_UNICODE_2_0_BMP = 3,
+ SFNT_UNICODE_2_0 = 4,
+ SFNT_UNICODE_VARIATION_SEQUENCES = 5,
+ SFNT_UNICODE_LAST_RESORT = 6,
+ };
+
+enum sfnt_macintosh_platform_specific_id
+ {
+ SFNT_MACINTOSH_ROMAN = 0,
+ SFNT_MACINTOSH_JAPANESE = 1,
+ SFNT_MACINTOSH_TRADITIONAL_CHINESE = 2,
+ SFNT_MACINTOSH_KOREAN = 3,
+ SFNT_MACINTOSH_ARABIC = 4,
+ SFNT_MACINTOSH_HEBREW = 5,
+ SFNT_MACINTOSH_GREEK = 6,
+ SFNT_MACINTOSH_RUSSIAN = 7,
+ SFNT_MACINTOSH_RSYMBOL = 8,
+ SFNT_MACINTOSH_DEVANAGARI = 9,
+ SFNT_MACINTOSH_GURMUKHI = 10,
+ SFNT_MACINTOSH_GUJARATI = 11,
+ SFNT_MACINTOSH_ORIYA = 12,
+ SFNT_MACINTOSH_BENGALI = 13,
+ SFNT_MACINTOSH_TAMIL = 14,
+ SFNT_MACINTOSH_TELUGU = 15,
+ SFNT_MACINTOSH_KANNADA = 16,
+ SFNT_MACINTOSH_MALAYALAM = 17,
+ SFNT_MACINTOSH_SINHALESE = 18,
+ SFNT_MACINTOSH_BURMESE = 19,
+ SFNT_MACINTOSH_KHMER = 20,
+ SFNT_MACINTOSH_THAI = 21,
+ SFNT_MACINTOSH_LAOTIAN = 22,
+ SFNT_MACINTOSH_GEORGIAN = 23,
+ SFNT_MACINTOSH_ARMENIAN = 24,
+ SFNT_MACINTOSH_SIMPLIFIED_CHINESE = 25,
+ SFNT_MACINTOSH_TIBETIAN = 26,
+ SFNT_MACINTOSH_MONGOLIAN = 27,
+ SFNT_MACINTOSH_GEEZ = 28,
+ SFNT_MACINTOSH_SLAVIC = 29,
+ SFNT_MACINTOSH_VIETNAMESE = 30,
+ SFNT_MACINTOSH_SINDHI = 31,
+ SFNT_MACINTOSH_UNINTERPRETED = 32,
+ };
+
+enum sfnt_microsoft_platform_specific_id
+ {
+ SFNT_MICROSOFT_SYMBOL = 0,
+ SFNT_MICROSOFT_UNICODE_BMP = 1,
+ SFNT_MICROSOFT_SHIFT_JIS = 2,
+ SFNT_MICROSOFT_PRC = 3,
+ SFNT_MICROSOFT_BIG_FIVE = 4,
+ SFNT_MICROSOFT_WANSUNG = 5,
+ SFNT_MICROSOFT_JOHAB = 6,
+ SFNT_MICROSOFT_UNICODE_UCS_4 = 10,
+ };
+
+struct sfnt_cmap_encoding_subtable
+{
+ /* The platform ID. */
+ uint16_t platform_id;
+
+ /* Platform specific ID. */
+ uint16_t platform_specific_id;
+
+ /* Mapping table offset. */
+ uint32_t offset;
+};
+
+struct sfnt_cmap_encoding_subtable_data
+{
+ /* Format and possibly the length in bytes. */
+ uint16_t format, length;
+};
+
+struct sfnt_cmap_format_0
+{
+ /* Format, set to 0. */
+ uint16_t format;
+
+ /* Length in bytes. Should be 262. */
+ uint16_t length;
+
+ /* Language code. */
+ uint16_t language;
+
+ /* Character code to glyph index map. */
+ uint8_t glyph_index_array[256];
+};
+
+struct sfnt_cmap_format_2_subheader
+{
+ uint16_t first_code;
+ uint16_t entry_count;
+ int16_t id_delta;
+ uint16_t id_range_offset;
+};
+
+struct sfnt_cmap_format_2
+{
+ /* Format, set to 2. */
+ uint16_t format;
+
+ /* Length in bytes. */
+ uint16_t length;
+
+ /* Language code. */
+ uint16_t language;
+
+ /* Array mapping high bytes to subheaders. */
+ uint16_t sub_header_keys[256];
+
+ /* Variable length data. */
+ struct sfnt_cmap_format_2_subheader *subheaders;
+ uint16_t *glyph_index_array;
+ uint16_t num_glyphs;
+};
+
+struct sfnt_cmap_format_4
+{
+ /* Format, set to 4. */
+ uint16_t format;
+
+ /* Length in bytes. */
+ uint16_t length;
+
+ /* Language code. */
+ uint16_t language;
+
+ /* 2 * seg_count. */
+ uint16_t seg_count_x2;
+
+ /* 2 * (2**FLOOR(log2(segCount))) */
+ uint16_t search_range;
+
+ /* log2(searchRange/2) */
+ uint16_t entry_selector;
+
+ /* (2 * segCount) - searchRange */
+ uint16_t range_shift;
+
+ /* Variable-length data. */
+ uint16_t *end_code;
+ uint16_t *reserved_pad;
+ uint16_t *start_code;
+ int16_t *id_delta;
+ int16_t *id_range_offset;
+ uint16_t *glyph_index_array;
+
+ /* The number of elements in glyph_index_array. */
+ size_t glyph_index_size;
+};
+
+struct sfnt_cmap_format_6
+{
+ /* Format, set to 6. */
+ uint16_t format;
+
+ /* Length in bytes. */
+ uint16_t length;
+
+ /* Language code. */
+ uint16_t language;
+
+ /* First character code in subrange. */
+ uint16_t first_code;
+
+ /* Number of character codes. */
+ uint16_t entry_count;
+
+ /* Variable-length data. */
+ uint16_t *glyph_index_array;
+};
+
+struct sfnt_cmap_format_8_or_12_group
+{
+ uint32_t start_char_code;
+ uint32_t end_char_code;
+ uint32_t start_glyph_code;
+};
+
+struct sfnt_cmap_format_8
+{
+ /* Format, set to 8. */
+ uint16_t format;
+
+ /* Reserved. */
+ uint16_t reserved;
+
+ /* Length in bytes. */
+ uint32_t length;
+
+ /* Language code. */
+ uint32_t language;
+
+ /* Tightly packed array of bits (8K bytes total) indicating whether
+ the particular 16-bit (index) value is the start of a 32-bit
+ character code. */
+ uint8_t is32[65536];
+
+ /* Number of groups. */
+ uint32_t num_groups;
+
+ /* Variable length data. */
+ struct sfnt_cmap_format_8_or_12_group *groups;
+};
+
+/* cmap formats 10, 13 unsupported. */
+
+struct sfnt_cmap_format_12
+{
+ /* Format, set to 12. */
+ uint16_t format;
+
+ /* Reserved. */
+ uint16_t reserved;
+
+ /* Length in bytes. */
+ uint32_t length;
+
+ /* Language code. */
+ uint32_t language;
+
+ /* Number of groups. */
+ uint32_t num_groups;
+
+ /* Variable length data. */
+ struct sfnt_cmap_format_8_or_12_group *groups;
+};
+
+struct sfnt_cmap_format_14
+{
+ /* Format, set to 14. */
+ uint16_t format;
+
+ /* The length of the table in bytes. */
+ uint32_t length;
+
+ /* Number of variation selector records. */
+ uint16_t num_var_selector_records;
+
+ /* The offset of this table in the font file. */
+ off_t offset;
+
+ /* Variable length data. */
+ struct sfnt_variation_selector_record *records;
+};
+
+struct sfnt_variation_selector_record
+{
+ /* 24-bit unsigned variation selector. */
+ unsigned int var_selector;
+
+ /* Offset to default UVS table. */
+ uint32_t default_uvs_offset;
+
+ /* Offset to non-default UVS table. */
+ uint32_t nondefault_uvs_offset;
+};
+
+struct sfnt_maxp_table
+{
+ /* Table version. */
+ sfnt_fixed version;
+
+ /* The number of glyphs in this font - 1. Set at version 0.5 or
+ later. */
+ uint16_t num_glyphs;
+
+ /* These fields are only set in version 1.0 or later. Maximum
+ points in a non-composite glyph. */
+ uint16_t max_points;
+
+ /* Maximum contours in a non-composite glyph. */
+ uint16_t max_contours;
+
+ /* Maximum points in a composite glyph. */
+ uint16_t max_composite_points;
+
+ /* Maximum contours in a composite glyph. */
+ uint16_t max_composite_contours;
+
+ /* 1 if instructions do not use the twilight zone (Z0), or 2 if
+ instructions do use Z0; should be set to 2 in most cases. */
+ uint16_t max_zones;
+
+ /* Maximum points used in Z0. */
+ uint16_t max_twilight_points;
+
+ /* Number of Storage Area locations. */
+ uint16_t max_storage;
+
+ /* Number of FDEFs, equal to the highest function number + 1. */
+ uint16_t max_function_defs;
+
+ /* Number of IDEFs. */
+ uint16_t max_instruction_defs;
+
+ /* Maximum stack depth across Font Program ('fpgm' table), CVT
+ Program ('prep' table) and all glyph instructions (in the 'glyf'
+ table). */
+ uint16_t max_stack_elements;
+
+ /* Maximum byte count for glyph instructions. */
+ uint16_t max_size_of_instructions;
+
+ /* Maximum number of components referenced at ``top level'' for any
+ composite glyph. */
+ uint16_t max_component_elements;
+
+ /* Maximum levels of recursion; 1 for simple components. */
+ uint16_t max_component_depth;
+};
+
+struct sfnt_loca_table_short
+{
+ /* Offsets to glyph data divided by two. */
+ uint16_t *offsets;
+
+ /* Size of the offsets list. */
+ size_t num_offsets;
+};
+
+struct sfnt_loca_table_long
+{
+ /* Offsets to glyph data. */
+ uint32_t *offsets;
+
+ /* Size of the offsets list. */
+ size_t num_offsets;
+};
+
+struct sfnt_glyf_table
+{
+ /* Size of the glyph data. */
+ size_t size;
+
+ /* Pointer to possibly unaligned glyph data. */
+ unsigned char *glyphs;
+
+ /* Pointer to the start of the mapping.
+ Only initialized if this table was mmapped. */
+ unsigned char *start;
+};
+
+struct sfnt_simple_glyph
+{
+ /* The total number of points in this glyph. */
+ size_t number_of_points;
+
+ /* Array containing the last points of each contour. */
+ uint16_t *restrict end_pts_of_contours;
+
+ /* Total number of bytes needed for instructions. */
+ uint16_t instruction_length;
+
+ /* Instruction data. */
+ uint8_t *restrict instructions;
+
+ /* Array of flags. */
+ uint8_t *restrict flags;
+
+ /* Array of X coordinates. */
+ int16_t *restrict x_coordinates;
+
+ /* Array of Y coordinates. */
+ int16_t *restrict y_coordinates;
+
+ /* Pointer to the end of that array. */
+ int16_t *restrict y_coordinates_end;
+};
+
+struct sfnt_compound_glyph_component
+{
+ /* Compound glyph flags. */
+ uint16_t flags;
+
+ /* Component glyph index. */
+ uint16_t glyph_index;
+
+ /* X-offset for component or point number; type depends on bits 0
+ and 1 in component flags. */
+ union {
+ uint8_t a;
+ int8_t b;
+ uint16_t c;
+ int16_t d;
+ } argument1;
+
+ /* Y-offset for component or point number; type depends on bits 0
+ and 1 in component flags. */
+ union {
+ uint8_t a;
+ int8_t b;
+ uint16_t c;
+ int16_t d;
+ } argument2;
+
+ /* Various scale formats. */
+ union {
+ int16_t scale;
+ struct {
+ int16_t xscale;
+ int16_t yscale;
+ } a;
+ struct {
+ int16_t xscale;
+ int16_t scale01;
+ int16_t scale10;
+ int16_t yscale;
+ } b;
+ } u;
+};
+
+struct sfnt_compound_glyph
+{
+ /* Pointer to array of components. */
+ struct sfnt_compound_glyph_component *components;
+
+ /* Number of elements in that array. */
+ size_t num_components;
+
+ /* Instruction data. */
+ uint8_t *instructions;
+
+ /* Length of instructions. */
+ uint16_t instruction_length;
+};
+
+struct sfnt_glyph
+{
+ /* Number of contours in this glyph. */
+ int16_t number_of_contours;
+
+ /* Coordinate bounds. */
+ sfnt_fword xmin, ymin, xmax, ymax;
+
+ /* Distortion applied to the right side phantom point. */
+ sfnt_fword advance_distortion;
+
+ /* Distortion applied to the origin point. */
+ sfnt_fword origin_distortion;
+
+ /* Either a simple glyph or a compound glyph, depending on which is
+ set. */
+ struct sfnt_simple_glyph *simple;
+ struct sfnt_compound_glyph *compound;
+};
+
+
+
+/* Glyph outline decomposition. */
+
+struct sfnt_point
+{
+ /* X and Y in em space. */
+ sfnt_fixed x, y;
+};
+
+typedef void (*sfnt_move_to_proc) (struct sfnt_point, void *);
+typedef void (*sfnt_line_to_proc) (struct sfnt_point, void *);
+typedef void (*sfnt_curve_to_proc) (struct sfnt_point,
+ struct sfnt_point,
+ void *);
+
+/* Forward declaration for use in sfnt_get_metrics_proc. */
+struct sfnt_glyph_metrics;
+
+typedef struct sfnt_glyph *(*sfnt_get_glyph_proc) (sfnt_glyph, void *,
+ bool *);
+typedef void (*sfnt_free_glyph_proc) (struct sfnt_glyph *, void *);
+typedef int (*sfnt_get_metrics_proc) (sfnt_glyph,
+ struct sfnt_glyph_metrics *,
+ void *);
+
+
+
+/* Decomposed glyph outline. */
+
+struct sfnt_glyph_outline_command
+{
+ /* Flags for this outline command. */
+ int flags;
+
+ /* X and Y position of this command. */
+ sfnt_fixed x, y;
+};
+
+/* Structure describing a single recorded outline in fixed pixel
+ space. */
+
+struct sfnt_glyph_outline
+{
+ /* Array of outlines elements. */
+ struct sfnt_glyph_outline_command *outline;
+
+ /* Size of the outline data, and how much is full. */
+ size_t outline_size, outline_used;
+
+ /* Rectangle defining bounds of the outline. Namely, the minimum
+ and maximum X and Y positions. */
+ sfnt_fixed xmin, ymin, xmax, ymax;
+
+ /* The origin point of the outline on the X axis. Value defaults to
+ 0. */
+ sfnt_fixed origin;
+
+ /* Reference count. Initially zero. */
+ short refcount;
+};
+
+enum sfnt_glyph_outline_flags
+ {
+ SFNT_GLYPH_OUTLINE_LINETO = (1 << 1),
+ };
+
+
+
+/* Glyph rasterization. */
+
+struct sfnt_raster
+{
+ /* Pointer to coverage data. */
+ unsigned char *cells;
+
+ /* Basic dimensions of the raster. */
+ unsigned short width, height;
+
+ /* Integer offset to apply to positions in the raster so that they
+ start from the origin point of the glyph. */
+ short offx, offy;
+
+ /* The raster stride. */
+ unsigned short stride;
+
+ /* Reference count. Initially zero. */
+ unsigned short refcount;
+};
+
+struct sfnt_edge
+{
+ /* Next edge in this chain. */
+ struct sfnt_edge *next;
+
+ /* Winding direction. 1 if clockwise, -1 if counterclockwise. */
+ int winding;
+
+ /* X position, top and bottom of edges. */
+ sfnt_fixed x, top, bottom;
+
+ /* Amount to move X by upon each change of Y, and vice versa. */
+ sfnt_fixed step_x;
+};
+
+
+
+/* Polygon rasterization constants. */
+
+enum
+ {
+ SFNT_POLY_SHIFT = 3,
+ SFNT_POLY_SAMPLE = (1 << SFNT_POLY_SHIFT),
+ SFNT_POLY_MASK = (SFNT_POLY_SAMPLE - 1),
+ SFNT_POLY_STEP = (0x10000 >> SFNT_POLY_SHIFT),
+ SFNT_POLY_START = (SFNT_POLY_STEP >> 1),
+ };
+
+
+
+/* Glyph metrics computation. */
+
+struct sfnt_long_hor_metric
+{
+ uint16_t advance_width;
+ int16_t left_side_bearing;
+};
+
+struct sfnt_hmtx_table
+{
+ /* Array of horizontal metrics for each glyph. */
+ struct sfnt_long_hor_metric *h_metrics;
+
+ /* Lbearing for remaining glyphs. */
+ int16_t *left_side_bearing;
+};
+
+/* Structure describing the metrics of a single glyph. The fields
+ mean the same as in XCharStruct, except they are 16.16 fixed point
+ values, and are missing significant information. */
+
+struct sfnt_glyph_metrics
+{
+ /* Distance between origin and left edge of raster. Positive
+ changes move rightwards.
+
+ If sfnt_lookup_glyph_metrics is given a pixel size of -1,
+ this is actually a sign extended fword. */
+ sfnt_fixed lbearing;
+
+ /* Advance to next glyph's origin.
+
+ If sfnt_lookup_glyph_metrics is given a pixel size of -1, this is
+ actually a sign extended fword. */
+ sfnt_fixed advance;
+};
+
+
+
+/* Font style parsing. */
+
+struct sfnt_name_record
+{
+ /* Platform identifier code. */
+ uint16_t platform_id;
+
+ /* Platform specific ID. */
+ uint16_t platform_specific_id;
+
+ /* Language identifier. */
+ uint16_t language_id;
+
+ /* Name identifier. */
+ uint16_t name_id;
+
+ /* String length in bytes. */
+ uint16_t length;
+
+ /* Offset from start of storage area. */
+ uint16_t offset;
+};
+
+struct sfnt_name_table
+{
+ /* Format selector of name table. */
+ uint16_t format;
+
+ /* Number of name records. */
+ uint16_t count;
+
+ /* Offset to start of string data. */
+ uint16_t string_offset;
+
+ /* Variable length data. */
+ struct sfnt_name_record *name_records;
+
+ /* Start of string data. */
+ unsigned char *data;
+};
+
+/* Name identifier codes. These are Apple's codes, not
+ Microsoft's. */
+
+enum sfnt_name_identifier_code
+ {
+ SFNT_NAME_COPYRIGHT_NOTICE = 0,
+ SFNT_NAME_FONT_FAMILY = 1,
+ SFNT_NAME_FONT_SUBFAMILY = 2,
+ SFNT_NAME_UNIQUE_SUBFAMILY_IDENTIFICATION = 3,
+ SFNT_NAME_FULL_NAME = 4,
+ SFNT_NAME_NAME_TABLE_VERSION = 5,
+ SFNT_NAME_POSTSCRIPT_NAME = 6,
+ SFNT_NAME_TRADEMARK_NOTICE = 7,
+ SFNT_NAME_MANUFACTURER_NAME = 8,
+ SFNT_NAME_DESIGNER = 9,
+ SFNT_NAME_DESCRIPTION = 10,
+ SFNT_NAME_FONT_VENDOR_URL = 11,
+ SFNT_NAME_FONT_DESIGNER_URL = 12,
+ SFNT_NAME_LICENSE_DESCRIPTION = 13,
+ SFNT_NAME_LICENSE_INFORMATION_URL = 14,
+ SFNT_NAME_PREFERRED_FAMILY = 16,
+ SFNT_NAME_PREFERRED_SUBFAMILY = 17,
+ SFNT_NAME_COMPATIBLE_FULL = 18,
+ SFNT_NAME_SAMPLE_TEXT = 19,
+ SFNT_NAME_VARIATIONS_POSTSCRIPT_NAME_PREFIX = 25,
+ };
+
+struct sfnt_meta_data_map
+{
+ /* Identifier for the tag. */
+ uint32_t tag;
+
+ /* Offset from start of table to data. */
+ uint32_t data_offset;
+
+ /* Length of the data. */
+ uint32_t data_length;
+};
+
+struct sfnt_meta_table
+{
+ /* Version of the table. Currently set to 1. */
+ uint32_t version;
+
+ /* Flags. Currently 0. */
+ uint32_t flags;
+
+ /* Offset from start of table to beginning of variable length
+ data. */
+ uint32_t data_offset;
+
+ /* Number of data maps in the table. */
+ uint32_t num_data_maps;
+
+ /* Beginning of variable length data. */
+ struct sfnt_meta_data_map *data_maps;
+
+ /* The whole table contents. */
+ unsigned char *data;
+};
+
+enum sfnt_meta_data_tag
+ {
+ SFNT_META_DATA_TAG_DLNG = 0x646c6e67,
+ SFNT_META_DATA_TAG_SLNG = 0x736c6e67,
+ };
+
+
+
+/* TrueType collection format support. */
+
+struct sfnt_ttc_header
+{
+ /* TrueType collection ID tag. */
+ uint32_t ttctag;
+
+ /* Version of the TTC header. */
+ uint32_t version;
+
+ /* Number of fonts in the TTC header. */
+ uint32_t num_fonts;
+
+ /* Array of offsets to the offset table for each font in the
+ file. */
+ uint32_t *offset_table;
+
+ /* Tag indicating that a DSIG table exists, or 0. Fields from here
+ on are only set on version 2.0 headers or later. */
+ uint32_t ul_dsig_tag;
+
+ /* Length in bytes of the signature table, or 0 if there is no
+ signature. */
+ uint32_t ul_dsig_length;
+
+ /* Offset in bytes of the dsig table from the beginning of the TTC
+ file. */
+ uint32_t ul_dsig_offset;
+};
+
+enum sfnt_ttc_tag
+ {
+ SFNT_TTC_TTCF = 0x74746366,
+ SFNT_TTC_DSIG = 0x44534947,
+ };
+
+
+
+/* Unicode Variation Sequence (UVS) support. */
+
+struct sfnt_default_uvs_table
+{
+ /* Number of ranges that follow. */
+ uint32_t num_unicode_value_ranges;
+
+ /* Variable length data. */
+ struct sfnt_unicode_value_range *ranges;
+};
+
+struct sfnt_unicode_value_range
+{
+ /* First value in this range. */
+ unsigned int start_unicode_value;
+
+ /* Number of additional values in this range. */
+ unsigned char additional_count;
+};
+
+struct sfnt_nondefault_uvs_table
+{
+ /* Number of UVS mappings which follow. */
+ uint32_t num_uvs_mappings;
+
+ /* Variable length data. */
+ struct sfnt_uvs_mapping *mappings;
+};
+
+struct sfnt_uvs_mapping
+{
+ /* Base character value. */
+ unsigned int unicode_value;
+
+ /* Glyph ID of the base character value. */
+ uint16_t base_character_value;
+};
+
+struct sfnt_mapped_variation_selector_record
+{
+ /* The variation selector. */
+ unsigned int selector;
+
+ /* Its default UVS table. */
+ struct sfnt_default_uvs_table *default_uvs;
+
+ /* Its nondefault UVS table. */
+ struct sfnt_nondefault_uvs_table *nondefault_uvs;
+};
+
+/* Structure describing a single offset to load into a variation
+ selection context. */
+
+struct sfnt_table_offset_rec
+{
+ /* The offset from the start of the font file. */
+ off_t offset;
+
+ /* Whether or not the offset points to a non-default UVS table. */
+ bool is_nondefault_table;
+
+ /* Pointer to the UVS table. */
+ void *table;
+};
+
+struct sfnt_uvs_context
+{
+ /* Number of records and tables. */
+ size_t num_records, nmemb;
+
+ /* Array of UVS tables. */
+ struct sfnt_table_offset_rec *tables;
+
+ /* Array of variation selector records mapped to
+ their corresponding tables. */
+ struct sfnt_mapped_variation_selector_record *records;
+};
+
+
+
+#if defined HAVE_MMAP && !defined TEST
+
+/* Memory mapping support. */
+
+struct sfnt_mapped_table
+{
+ /* Pointer to table data. */
+ void *data;
+
+ /* Pointer to table mapping. */
+ void *mapping;
+
+ /* Size of mapped data and size of mapping. */
+ size_t length, size;
+};
+
+#endif /* HAVE_MMAP && !TEST */
+
+
+
+/* Glyph variation support. */
+
+/* 2.14 fixed point type used to represent versors of unit
+ vectors. */
+typedef int16_t sfnt_f2dot14;
+
+/* Forward declaration used only for the distortable font stuff. */
+struct sfnt_cvt_table;
+
+struct sfnt_variation_axis
+{
+ /* The axis tag. */
+ uint32_t axis_tag;
+
+ /* The minimum style coordinate for the axis. */
+ sfnt_fixed min_value;
+
+ /* The default style coordinate for the axis. */
+ sfnt_fixed default_value;
+
+ /* The maximum style coordinate for the axis. */
+ sfnt_fixed max_value;
+
+ /* Set to zero. */
+ uint16_t flags;
+
+ /* Identifier under which this axis's name will be found in the
+ `name' table. */
+ uint16_t name_id;
+};
+
+struct sfnt_instance
+{
+ /* The instance name ID. */
+ uint16_t name_id;
+
+ /* Flags. */
+ uint16_t flags;
+
+ /* Optional PostScript name. */
+ uint16_t ps_name_id;
+
+ /* Coordinates of each defined instance. */
+ sfnt_fixed *coords;
+};
+
+struct sfnt_fvar_table
+{
+ /* Major version; should be 1. */
+ uint16_t major_version;
+
+ /* Minor version; should be 0. */
+ uint16_t minor_version;
+
+ /* Offset in bytes from the beginning of the table to the beginning
+ of the first axis data. */
+ uint16_t offset_to_data;
+
+ /* Reserved field; always 2. */
+ uint16_t count_size_pairs;
+
+ /* Number of style axes in this font. */
+ uint16_t axis_count;
+
+ /* The number of bytes in each variation axis record. Currently 20
+ bytes. */
+ uint16_t axis_size;
+
+ /* The number of named instances for the font found in the
+ instance array. */
+ uint16_t instance_count;
+
+ /* The size of each instance record. */
+ uint16_t instance_size;
+
+ /* Variable length data. */
+ struct sfnt_variation_axis *axis;
+ struct sfnt_instance *instance;
+};
+
+struct sfnt_short_frac_correspondence
+{
+ /* Value in normalized user space. */
+ sfnt_f2dot14 from_coord;
+
+ /* Value in normalized axis space. */
+ sfnt_f2dot14 to_coord;
+};
+
+struct sfnt_short_frac_segment
+{
+ /* The number of pairs for this axis. */
+ uint16_t pair_count;
+
+ /* Variable length data. */
+ struct sfnt_short_frac_correspondence *correspondence;
+};
+
+struct sfnt_avar_table
+{
+ /* The version of the table. Should be 1.0. */
+ sfnt_fixed version;
+
+ /* Number of variation axes defined in this table.
+ XXX: why is this signed? */
+ int32_t axis_count;
+
+ /* Variable length data. */
+ struct sfnt_short_frac_segment *segments;
+};
+
+struct sfnt_tuple_variation
+{
+ /* Tuple point numbers. */
+ uint16_t *points;
+
+ /* Deltas. */
+ sfnt_fword *deltas;
+
+ /* Tuple coordinates. One for each axis specified in the [gaf]var
+ tables. */
+ sfnt_f2dot14 *coordinates;
+
+ /* Intermediate start and end coordinates. */
+ sfnt_f2dot14 *restrict intermediate_start;
+
+ /* Intermediate start and end coordinates. */
+ sfnt_f2dot14 *restrict intermediate_end;
+
+ /* The number of points and deltas present.
+
+ UINT16_MAX and POINTS set to NULL means there are deltas for each
+ CVT entry. */
+ uint16_t num_points;
+};
+
+struct sfnt_cvar_table
+{
+ /* The version of this CVT variations table. */
+ sfnt_fixed version;
+
+ /* Flags. */
+ uint16_t tuple_count;
+
+ /* Offset from the beginning of the table to the tuple data. */
+ uint16_t data_offset;
+
+ /* Variable length data. */
+ struct sfnt_tuple_variation *variation;
+};
+
+struct sfnt_gvar_table
+{
+ /* Version of the glyph variations table. */
+ uint16_t version;
+
+ /* Reserved, currently 0. */
+ uint16_t reserved;
+
+ /* The number of style axes for this font. This must be the same
+ number as axisCount in the 'fvar' table. */
+ uint16_t axis_count;
+
+ /* The number of shared coordinates. */
+ uint16_t shared_coord_count;
+
+ /* Byte offset from the beginning of this table to the list of
+ shared style coordinates. */
+ uint32_t offset_to_coord;
+
+ /* The number of glyphs in this font; this should match the number
+ of the glyphs store elsewhere in the font. */
+ uint16_t glyph_count;
+
+ /* Bit-field that gives the format of the offset array that
+ follows. If the flag is 0, the type is uint16. If the flag is 1,
+ the type is unit 32. */
+ uint16_t flags;
+
+ /* Byte offset from the beginning of this table to the first glyph
+ glyphVariationData. */
+ uint32_t offset_to_data;
+
+ /* Number of bytes in the glyph variation data. */
+ size_t data_size;
+
+ /* Byte offsets from the beginning of the glyphVariationData array
+ to the glyphVariationData for each glyph in the font. The format
+ of this field is set by the flags field. */
+ union {
+ uint16_t *offset_word;
+ uint32_t *offset_long;
+ } u;
+
+ /* Other variable length data. */
+ sfnt_f2dot14 *global_coords;
+ unsigned char *glyph_variation_data;
+};
+
+/* Structure representing a set of axis coordinates and their
+ normalized equivalents.
+
+ To use this structure, call
+
+ sfnt_init_blend (&blend, fvar, gvar)
+
+ on a `struct sfnt_blend *', with an appropriate fvar and gvar
+ table.
+
+ Then, fill in blend.coords with the un-normalized coordinates,
+ and call
+
+ sfnt_normalize_blend (&blend)
+
+ finally, call sfnt_vary_simple_glyph and related functions. */
+
+struct sfnt_blend
+{
+ /* The fvar table. This determines the number of elements in each
+ of the arrays below. */
+ struct sfnt_fvar_table *fvar;
+
+ /* The gvar table. This provides the glyph variation data. */
+ struct sfnt_gvar_table *gvar;
+
+ /* The avar table. This provides adjustments to normalized axis
+ values, and may be NULL. */
+ struct sfnt_avar_table *avar;
+
+ /* The cvar table. This provides adjustments to CVT values, and may
+ be NULL. */
+ struct sfnt_cvar_table *cvar;
+
+ /* Un-normalized coordinates. */
+ sfnt_fixed *coords;
+
+ /* Normalized coordinates. */
+ sfnt_fixed *norm_coords;
+};
+
+struct sfnt_metrics_distortion
+{
+ /* Distortion applied to the origin point. */
+ sfnt_fword origin;
+
+ /* Distortion applied to the advance point. */
+ sfnt_fword advance;
+};
+
+
+
+/* OS/2 font metadata. */
+
+struct sfnt_OS_2_table
+{
+ /* Table version number. */
+ uint16_t version;
+
+ /* Average weighted advance width of lower case letters and
+ space. */
+ int16_t x_avg_char_width;
+
+ /* Wisual weight (degree of blackness or thickness) of stroke in
+ glyphs. */
+ uint16_t us_weight_class;
+
+ /* Relative change from the normal aspect ratio (width to height
+ ratio) as specified by a font designer for the glyphs in the
+ font. */
+ uint16_t us_width_class;
+
+ /* Miscellaneous font attributes. */
+ int16_t fs_type;
+
+ /* Recommended horizontal size in pixels for subscripts. */
+ int16_t y_subscript_x_size;
+
+ /* Recommended vertical subscript size. */
+ int16_t y_subscript_y_size;
+
+ /* Recommended horizontal offset for subscripts. */
+ int16_t y_subscript_x_offset;
+
+ /* Recommended vertical offset from the baseline for subscripts. */
+ int16_t y_subscript_y_offset;
+
+ /* Recommended horizontal size in pixels for superscripts. */
+ int16_t y_superscript_x_size;
+
+ /* Recommended vertical superscript size. */
+ int16_t y_superscript_y_size;
+
+ /* Recommended horizontal offset for superscripts. */
+ int16_t y_superscript_x_offset;
+
+ /* Recommended vertical offset from the baseline for superscripts. */
+ int16_t y_superscript_y_offset;
+
+ /* Width of the strikeout stroke. */
+ int16_t y_strikeout_size;
+
+ /* Position of the strikeout stroke relative to the baseline. */
+ int16_t y_strikeout_position;
+
+ /* Font family classification. */
+ int16_t s_family_class;
+
+ /* Microsoft ``panose'' classification. */
+ unsigned char panose[10];
+
+ /* Alignment boundary! */
+
+ /* Unicode range specification. */
+ uint32_t ul_unicode_range[4];
+
+ /* Font foundry name. */
+ char ach_vendor_id[4];
+
+ /* Two byte bitfield providing the nature of font patterns. */
+ uint16_t fs_selection;
+
+ /* The minimum Unicode codepoint covered. */
+ uint16_t fs_first_char_index;
+
+ /* The maximum Unicode codepoint covered. */
+ uint16_t fs_last_char_index;
+};
+
+
+
+/* PostScript metadata. */
+
+struct sfnt_post_table
+{
+ /* Format of this table. This is a fixed point number rather than
+ an integer. */
+ sfnt_fixed format;
+
+ /* Italic angle in degrees. */
+ sfnt_fixed italic_angle;
+
+ /* Underline position. */
+ sfnt_fword underline_position;
+
+ /* Underline thickness. */
+ sfnt_fword underline_thickness;
+
+ /* Whether the font is monospaced. */
+ uint32_t is_fixed_pitch;
+
+ /* Minimum memory usage (on a PostScript printer) when a TrueType
+ font is downloaded as a Type 42 font. */
+ uint32_t min_mem_type_42;
+
+ /* Maximum memory usage (on a PostScript printer) when a TrueType
+ font is downloaded as a Type 42 font. */
+ uint32_t max_mem_type_42;
+
+ /* Minimum memory usage (on a PostScript printer) when a TrueType
+ font is downloaded as a Type 42 font. */
+ uint32_t min_mem_type_1;
+
+ /* Maximum memory usage (on a PostScript printer) when a TrueType
+ font is downloaded as a Type 42 font. */
+ uint32_t max_mem_type_1;
+};
+
+
+
+#define SFNT_CEIL_FIXED(fixed) (((fixed) + 0177777) & 037777600000)
+#define SFNT_ROUND_FIXED(fixed) (((fixed) + 0100000) & 037777600000)
+#define SFNT_FLOOR_FIXED(fixed) ((fixed) & 037777600000)
+
+
+
+/* Function declarations. Keep these sorted by the order in which
+ they appear in sfnt.c. Keep each line no longer than 80
+ columns. */
+
+#ifndef TEST
+
+extern struct sfnt_offset_subtable *sfnt_read_table_directory (int);
+
+#define PROTOTYPE \
+ int, struct sfnt_offset_subtable *, \
+ struct sfnt_cmap_encoding_subtable **, \
+ struct sfnt_cmap_encoding_subtable_data ***
+extern struct sfnt_cmap_table *sfnt_read_cmap_table (PROTOTYPE);
+#undef PROTOTYPE
+
+extern sfnt_glyph sfnt_lookup_glyph (sfnt_char,
+ struct sfnt_cmap_encoding_subtable_data *);
+
+#define PROTOTYPE int, struct sfnt_offset_subtable *
+extern struct sfnt_head_table *sfnt_read_head_table (PROTOTYPE);
+extern struct sfnt_hhea_table *sfnt_read_hhea_table (PROTOTYPE);
+extern struct sfnt_loca_table_short *sfnt_read_loca_table_short (PROTOTYPE);
+extern struct sfnt_loca_table_long *sfnt_read_loca_table_long (PROTOTYPE);
+extern struct sfnt_maxp_table *sfnt_read_maxp_table (PROTOTYPE);
+extern struct sfnt_glyf_table *sfnt_read_glyf_table (PROTOTYPE);
+
+#ifdef HAVE_MMAP
+extern struct sfnt_glyf_table *sfnt_map_glyf_table (PROTOTYPE);
+extern int sfnt_unmap_glyf_table (struct sfnt_glyf_table *);
+#endif /* HAVE_MMAP */
+#undef PROTOTYPE
+
+extern struct sfnt_glyph *sfnt_read_glyph (sfnt_glyph, struct sfnt_glyf_table *,
+ struct sfnt_loca_table_short *,
+ struct sfnt_loca_table_long *);
+extern void sfnt_free_glyph (struct sfnt_glyph *);
+
+#define PROTOTYPE \
+ struct sfnt_glyph *, \
+ sfnt_fixed, \
+ struct sfnt_glyph_metrics *, \
+ sfnt_get_glyph_proc, \
+ sfnt_free_glyph_proc, \
+ sfnt_get_metrics_proc, \
+ void *
+extern struct sfnt_glyph_outline *sfnt_build_glyph_outline (PROTOTYPE);
+#undef PROTOTYPE
+
+extern void sfnt_prepare_raster (struct sfnt_raster *,
+ struct sfnt_glyph_outline *);
+
+#define PROTOTYPE struct sfnt_glyph_outline *
+extern struct sfnt_raster *sfnt_raster_glyph_outline (PROTOTYPE);
+extern struct sfnt_raster *sfnt_raster_glyph_outline_exact (PROTOTYPE);
+#undef PROTOTYPE
+
+#define PROTOTYPE \
+ int, \
+ struct sfnt_offset_subtable *, \
+ struct sfnt_hhea_table *, \
+ struct sfnt_maxp_table *
+extern struct sfnt_hmtx_table *sfnt_read_hmtx_table (PROTOTYPE);
+#undef PROTOTYPE
+
+extern int sfnt_lookup_glyph_metrics (sfnt_glyph,
+ struct sfnt_glyph_metrics *,
+ struct sfnt_hmtx_table *,
+ struct sfnt_hhea_table *,
+ struct sfnt_maxp_table *);
+
+extern void sfnt_scale_metrics (struct sfnt_glyph_metrics *,
+ sfnt_fixed);
+extern sfnt_fixed sfnt_get_scale (struct sfnt_head_table *, int);
+
+#define PROTOTYPE int, struct sfnt_offset_subtable *
+extern struct sfnt_name_table *sfnt_read_name_table (PROTOTYPE);
+#undef PROTOTYPE
+
+extern unsigned char *sfnt_find_name (struct sfnt_name_table *,
+ enum sfnt_name_identifier_code,
+ struct sfnt_name_record *);
+
+#define PROTOTYPE int, struct sfnt_offset_subtable *
+extern struct sfnt_meta_table *sfnt_read_meta_table (PROTOTYPE);
+#undef PROTOTYPE
+
+extern char *sfnt_find_metadata (struct sfnt_meta_table *,
+ enum sfnt_meta_data_tag,
+ struct sfnt_meta_data_map *);
+
+extern struct sfnt_ttc_header *sfnt_read_ttc_header (int);
+
+
+
+#define PROTOTYPE struct sfnt_cmap_format_14 *, int
+
+extern struct sfnt_uvs_context *sfnt_create_uvs_context (PROTOTYPE);
+
+#undef PROTOTYPE
+
+extern void sfnt_free_uvs_context (struct sfnt_uvs_context *);
+
+#define PROTOTYPE struct sfnt_nondefault_uvs_table *, sfnt_char
+
+extern sfnt_glyph sfnt_variation_glyph_for_char (PROTOTYPE);
+
+#undef PROTOTYPE
+
+#define PROTOTYPE struct sfnt_default_uvs_table *, sfnt_char
+
+extern bool sfnt_is_character_default (PROTOTYPE);
+
+#undef PROTOTYPE
+
+
+
+#ifdef HAVE_MMAP
+
+extern int sfnt_map_table (int, struct sfnt_offset_subtable *,
+ uint32_t, struct sfnt_mapped_table *);
+extern int sfnt_unmap_table (struct sfnt_mapped_table *);
+
+#endif /* HAVE_MMAP */
+
+
+
+extern void *sfnt_read_table (int, struct sfnt_offset_subtable *,
+ uint32_t, size_t *);
+
+
+
+#define PROTOTYPE int, struct sfnt_offset_subtable *
+
+extern struct sfnt_fvar_table *sfnt_read_fvar_table (PROTOTYPE);
+extern struct sfnt_gvar_table *sfnt_read_gvar_table (PROTOTYPE);
+extern struct sfnt_avar_table *sfnt_read_avar_table (PROTOTYPE);
+
+#undef PROTOTYPE
+
+#define PROTOTYPE \
+ int, \
+ struct sfnt_offset_subtable *, \
+ struct sfnt_fvar_table *, \
+ struct sfnt_cvt_table *
+
+extern struct sfnt_cvar_table *sfnt_read_cvar_table (PROTOTYPE);
+
+#undef PROTOTYPE
+
+
+
+extern void sfnt_init_blend (struct sfnt_blend *,
+ struct sfnt_fvar_table *,
+ struct sfnt_gvar_table *,
+ struct sfnt_avar_table *,
+ struct sfnt_cvar_table *);
+extern void sfnt_free_blend (struct sfnt_blend *);
+extern void sfnt_normalize_blend (struct sfnt_blend *);
+
+
+
+extern int sfnt_vary_simple_glyph (struct sfnt_blend *, sfnt_glyph,
+ struct sfnt_glyph *,
+ struct sfnt_metrics_distortion *);
+extern int sfnt_vary_compound_glyph (struct sfnt_blend *, sfnt_glyph,
+ struct sfnt_glyph *,
+ struct sfnt_metrics_distortion *);
+
+
+
+#define PROTOTYPE int, struct sfnt_offset_subtable *
+
+extern struct sfnt_OS_2_table *sfnt_read_OS_2_table (PROTOTYPE);
+
+#undef PROTOTYPE
+
+
+
+#define PROTOTYPE int, struct sfnt_offset_subtable *
+
+extern struct sfnt_post_table *sfnt_read_post_table (PROTOTYPE);
+
+#undef PROTOTYPE
+
+#endif /* TEST */
+
+
+
+/* TrueType hinting support. */
+
+/* Structure definitions for tables used by the TrueType
+ interpreter. */
+
+struct sfnt_cvt_table
+{
+ /* Number of elements in the control value table. */
+ size_t num_elements;
+
+ /* Pointer to elements in the control value table. */
+ sfnt_fword *values;
+};
+
+struct sfnt_fpgm_table
+{
+ /* Number of instructions in the font program table. */
+ size_t num_instructions;
+
+ /* Pointer to elements in the font program table. */
+ unsigned char *instructions;
+};
+
+struct sfnt_prep_table
+{
+ /* Number of instructions in the control value program (pre-program)
+ table. */
+ size_t num_instructions;
+
+ /* Pointer to elements in the preprogram table. */
+ unsigned char *instructions;
+};
+
+
+
+/* Fixed point types used by the TrueType interpreter. */
+
+/* 26.6 fixed point type used within the interpreter. */
+typedef int32_t sfnt_f26dot6;
+
+/* 18.14 fixed point type used to calculate rounding details. */
+typedef int32_t sfnt_f18dot14;
+
+
+
+/* Interpreter execution environment. */
+
+struct sfnt_unit_vector
+{
+ /* X and Y versors of the 2d unit vector. */
+ sfnt_f2dot14 x, y;
+};
+
+struct sfnt_interpreter_definition
+{
+ /* The opcode of this instruction or function. */
+ uint16_t opcode;
+
+ /* The number of instructions. */
+ uint16_t instruction_count;
+
+ /* Pointer to instructions belonging to the definition. This
+ pointer points directly into the control value or font program.
+ Make sure both programs are kept around as long as the
+ interpreter continues to exist. */
+ unsigned char *instructions;
+};
+
+/* This structure represents a ``struct sfnt_glyph'' that has been
+ scaled to a given pixel size.
+
+ It can either contain a simple glyph, or a decomposed compound
+ glyph; instructions are interpreted for both simple glyphs, simple
+ glyph components inside a compound glyph, and compound glyphs as a
+ whole.
+
+ In addition to the glyph data itself, it also records various
+ information for the instruction interpretation process:
+
+ - ``current'' point coordinates, which have been modified
+ by the instructing process.
+
+ - two phantom points at the origin and the advance of the
+ glyph. */
+
+struct sfnt_interpreter_zone
+{
+ /* The number of points in this zone, including the two phantom
+ points at the end. */
+ size_t num_points;
+
+ /* The number of contours in this zone. */
+ size_t num_contours;
+
+ /* The end points of each contour. */
+ size_t *contour_end_points;
+
+ /* Pointer to the X axis point data. */
+ sfnt_f26dot6 *restrict x_points;
+
+ /* Pointer to the X axis current point data. */
+ sfnt_f26dot6 *restrict x_current;
+
+ /* Pointer to the Y axis point data. */
+ sfnt_f26dot6 *restrict y_points;
+
+ /* Pointer to the Y axis current point data. */
+ sfnt_f26dot6 *restrict y_current;
+
+ /* Pointer to the flags associated with this data. */
+ unsigned char *flags;
+
+ /* If this structure was produced from a simple glyph, pointer to
+ the simple glyph itself. NULL otherwise. */
+ struct sfnt_simple_glyph *simple;
+};
+
+enum
+ {
+ /* Bits 1 stands for X_SHORT_VECTOR on disk and in the tables, but
+ this representation is not useful in memory. Inside an
+ instructed glyph, this bit is repurposed to mean that the
+ corresponding point is a phantom point. */
+ SFNT_POINT_PHANTOM = (1 << 1),
+ /* Bits 7 and 6 of a glyph point's flags is reserved. This scaler
+ uses it to mean that the point has been touched in one axis or
+ another. */
+ SFNT_POINT_TOUCHED_X = (1 << 7),
+ SFNT_POINT_TOUCHED_Y = (1 << 6),
+ SFNT_POINT_TOUCHED_BOTH = (SFNT_POINT_TOUCHED_X
+ | SFNT_POINT_TOUCHED_Y),
+ };
+
+/* This is needed because `round' below needs an interpreter
+ argument. */
+struct sfnt_interpreter;
+
+struct sfnt_graphics_state
+{
+ /* Pointer to the function used for rounding. This function is
+ asymmetric, so -0.5 rounds up to 0, not -1. It is up to the
+ caller to handle negative values.
+
+ Value is undefined unless sfnt_validate_gs has been called, and
+ the second argument may be used to provide detailed rounding
+ information (``super rounding state''.) */
+ sfnt_f26dot6 (*round) (sfnt_f26dot6, struct sfnt_interpreter *);
+
+ /* Pointer to the function used to project euclidean vectors onto
+ the projection vector. Value is the magnitude of the projected
+ vector. */
+ sfnt_f26dot6 (*project) (sfnt_f26dot6, sfnt_f26dot6,
+ struct sfnt_interpreter *);
+
+ /* Pointer to the function used to project euclidean vectors onto
+ the dual projection vector. Value is the magnitude of the
+ projected vector. */
+ sfnt_f26dot6 (*dual_project) (sfnt_f26dot6, sfnt_f26dot6,
+ struct sfnt_interpreter *);
+
+ /* Pointer to the function used to move specified points
+ along the freedom vector by a distance specified in terms
+ of the projection vector. */
+ void (*move) (sfnt_f26dot6 *restrict,
+ sfnt_f26dot6 *restrict, size_t,
+ struct sfnt_interpreter *,
+ sfnt_f26dot6, unsigned char *);
+
+ /* Dot product between the freedom and the projection vectors. */
+ sfnt_f2dot14 vector_dot_product;
+
+ /* Controls whether the sign of control value table entries will be
+ changed to match the sign of the actual distance measurement with
+ which it is compared. Setting auto flip to TRUE makes it
+ possible to control distances measured with or against the
+ projection vector with a single control value table entry. When
+ auto flip is set to FALSE, distances must be measured with the
+ projection vector. */
+ bool auto_flip;
+
+ /* Limits the regularizing effects of control value table entries to
+ cases where the difference between the table value and the
+ measurement taken from the original outline is sufficiently
+ small. */
+ sfnt_f26dot6 cvt_cut_in;
+
+ /* Establishes the base value used to calculate the range of point
+ sizes to which a given DELTAC[] or DELTAP[] instruction will
+ apply. The formulas given below are used to calculate the range
+ of the various DELTA instructions.
+
+ DELTAC1 DELTAP1 (delta_base) through (delta_base + 15)
+ DELTAC2 DELTAP2 (delta_base + 16) through (delta_base + 31)
+ DELTAC3 DELTAP3 (delta_base + 32) through (delta_base + 47)
+
+ Please keep this documentation in sync with the TrueType
+ reference manual. */
+ unsigned short delta_base;
+
+ /* Determines the range of movement and smallest magnitude of
+ movement (the step) in a DELTAC[] or DELTAP[] instruction.
+ Changing the value of the delta shift makes it possible to trade
+ off fine control of point movement for range of movement. A low
+ delta shift favors range of movement over fine control. A high
+ delta shift favors fine control over range of movement. The step
+ has the value 1/2 to the power delta shift. The range of
+ movement is calculated by taking the number of steps allowed (16)
+ and multiplying it by the step.
+
+ The legal range for delta shift is zero through six. Negative
+ values are illegal. */
+ unsigned short delta_shift;
+
+ /* A second projection vector set to a line defined by the original
+ outline location of two points. The dual projection vector is
+ used when it is necessary to measure distances from the scaled
+ outline before any instructions were executed. */
+ struct sfnt_unit_vector dual_projection_vector;
+
+ /* A unit vector that establishes an axis along which points can
+ move. */
+ struct sfnt_unit_vector freedom_vector;
+
+ /* Makes it possible to turn off instructions under some
+ circumstances. When flag 1 is set, changes to the graphics state
+ made in the control value program will be ignored. When flag is
+ 1, grid fitting instructions will be ignored. */
+ unsigned char instruct_control;
+
+ /* Makes it possible to repeat certain instructions a designated
+ number of times. The default value of one assures that unless
+ the value of loop is altered, these instructions will execute one
+ time. */
+ unsigned short loop;
+
+ /* Establishes the smallest possible value to which a distance will
+ be rounded. */
+ sfnt_f26dot6 minimum_distance;
+
+ /* A unit vector whose direction establishes an axis along which
+ distances are measured. */
+ struct sfnt_unit_vector projection_vector;
+
+ /* Determines the manner in which values are rounded. Can be set to
+ a number of predefined states or to a customized state with the
+ SROUND or S45ROUND instructions. */
+ int round_state;
+
+ /* Reference points. These reference point numbers, which together
+ with a zone designation, specify a point in either the glyph zone
+ or the twilight zone. */
+ uint16_t rp0, rp1, rp2;
+
+ /* Flags which determine whether the interpreter will activate
+ dropout control for the current glyph. */
+ int scan_control;
+
+ /* The distance difference below which the interpreter will replace
+ a CVT distance or an actual distance in favor of the single width
+ value. */
+ sfnt_f26dot6 sw_cut_in;
+
+ /* The value used in place of the control value table distance or
+ the actual distance value when the difference between that
+ distance and the single width value is less than the single width
+ cut-in. */
+ sfnt_f26dot6 single_width_value;
+
+ /* Zone pointers, which reference a zone. */
+ int zp0, zp1, zp2;
+};
+
+struct sfnt_interpreter
+{
+ /* The number of elements in the stack. */
+ uint16_t max_stack_elements;
+
+ /* The number of instructions in INSTRUCTIONS. */
+ uint16_t num_instructions;
+
+ /* Size of the storage area. */
+ uint16_t storage_size;
+
+ /* Size of the function definition area. */
+ uint16_t function_defs_size;
+
+ /* Size of the instruction definition area. */
+ uint16_t instruction_defs_size;
+
+ /* Size of the twilight zone. */
+ uint16_t twilight_zone_size;
+
+ /* The instruction pointer. This points to the instruction
+ currently being executed. */
+ int IP;
+
+ /* The current scale. */
+ sfnt_fixed scale;
+
+ /* The current ppem and point size. */
+ int ppem, point_size;
+
+ /* The execution stack. This has at most max_stack_elements
+ elements. */
+ uint32_t *stack;
+
+ /* Pointer past the top of the stack. */
+ uint32_t *SP;
+
+ /* The size of the control value table. */
+ size_t cvt_size;
+
+ /* Pointer to instructions currently being executed. */
+ unsigned char *restrict instructions;
+
+ /* The twilight zone. May not be NULL. */
+ sfnt_f26dot6 *restrict twilight_x, *restrict twilight_y;
+
+ /* The original X positions of points in the twilight zone. */
+ sfnt_f26dot6 *restrict twilight_original_x;
+
+ /* The original Y positions of points in the twilight zone.
+
+ Apple does not directly say whether or not points in the twilight
+ zone can have their original positions changed. But this is
+ implied by ``create points in the twilight zone''. */
+ sfnt_f26dot6 *restrict twilight_original_y;
+
+ /* The scaled outlines being manipulated. May be NULL. */
+ struct sfnt_interpreter_zone *glyph_zone;
+
+ /* The glyph advance width. Value is undefined unless GLYPH_ZONE is
+ set. */
+ sfnt_f26dot6 advance_width;
+
+ /* The storage area. */
+ uint32_t *storage;
+
+ /* Control value table values. */
+ sfnt_f26dot6 *cvt;
+
+ /* Function definitions. */
+ struct sfnt_interpreter_definition *function_defs;
+
+ /* Instruction definitions. */
+ struct sfnt_interpreter_definition *instruction_defs;
+
+ /* Interpreter registers. */
+ struct sfnt_graphics_state state;
+
+ /* Detailed rounding state used when state.round_state indicates
+ that fine grained rounding should be used.
+
+ PERIOD says how often a round value occurs, for numbers
+ increasing from PHASE to infinity.
+
+ THRESHOLD says when to round a value between two increasing
+ periods towards the larger period. */
+ sfnt_f26dot6 period, phase, threshold;
+
+ /* The depth of any ongoing calls. */
+ int call_depth;
+
+ /* Jump buffer for traps. */
+ jmp_buf trap;
+
+ /* What was the trap. */
+ const char *trap_reason;
+
+ /* Number of variation axes provided by this distortable font. */
+ int n_axis;
+
+ /* Normalized axis coordinates set for this distortable font. */
+ sfnt_fixed *norm_coords;
+
+#ifdef TEST
+ /* If non-NULL, function called before each instruction is
+ executed. */
+ void (*run_hook) (struct sfnt_interpreter *);
+
+ /* If non-NULL, function called before each stack element is
+ pushed. */
+ void (*push_hook) (struct sfnt_interpreter *, uint32_t);
+
+ /* If non-NULL, function called before each stack element is
+ popped. */
+ void (*pop_hook) (struct sfnt_interpreter *, uint32_t);
+#endif
+};
+
+
+
+/* Glyph hinting. */
+
+/* Structure describing a single scaled and fitted outline. */
+
+struct sfnt_instructed_outline
+{
+ /* The number of points in this contour, including the two phantom
+ points at the end. */
+ size_t num_points;
+
+ /* The number of contours in this outline. */
+ size_t num_contours;
+
+ /* The end points of each contour. */
+ size_t *contour_end_points;
+
+ /* The points of each contour, with two additional phantom points at
+ the end. */
+ sfnt_f26dot6 *restrict x_points, *restrict y_points;
+
+ /* The flags of each point. */
+ unsigned char *flags;
+};
+
+
+
+/* Functions used to read tables used by the TrueType interpreter. */
+
+#ifndef TEST
+
+#define PROTOTYPE int, struct sfnt_offset_subtable *
+
+extern struct sfnt_cvt_table *sfnt_read_cvt_table (PROTOTYPE);
+extern struct sfnt_fpgm_table *sfnt_read_fpgm_table (PROTOTYPE);
+extern struct sfnt_prep_table *sfnt_read_prep_table (PROTOTYPE);
+
+#undef PROTOTYPE
+
+#define PROTOTYPE \
+ struct sfnt_maxp_table *, \
+ struct sfnt_cvt_table *, \
+ struct sfnt_head_table *, \
+ struct sfnt_fvar_table *, \
+ int, int
+
+extern struct sfnt_interpreter *sfnt_make_interpreter (PROTOTYPE);
+
+#undef PROTOTYPE
+
+#define PROTOTYPE \
+ struct sfnt_interpreter *, \
+ struct sfnt_fpgm_table *
+
+extern const char *sfnt_interpret_font_program (PROTOTYPE);
+
+#undef PROTOTYPE
+
+#define PROTOTYPE \
+ struct sfnt_interpreter *, \
+ struct sfnt_prep_table *, \
+ struct sfnt_graphics_state *
+
+extern const char *sfnt_interpret_control_value_program (PROTOTYPE);
+
+#undef PROTOTYPE
+
+#define PROTOTYPE struct sfnt_instructed_outline *, sfnt_fixed *
+
+extern struct sfnt_glyph_outline *sfnt_build_instructed_outline (PROTOTYPE);
+
+#undef PROTOTYPE
+
+#define PROTOTYPE \
+ struct sfnt_glyph *, \
+ struct sfnt_interpreter *, \
+ struct sfnt_glyph_metrics *, \
+ struct sfnt_instructed_outline **
+
+extern const char *sfnt_interpret_simple_glyph (PROTOTYPE);
+
+#undef PROTOTYPE
+
+#define PROTOTYPE \
+ struct sfnt_glyph *, \
+ struct sfnt_interpreter *, \
+ struct sfnt_graphics_state *, \
+ sfnt_get_glyph_proc, \
+ sfnt_free_glyph_proc, \
+ struct sfnt_hmtx_table *, \
+ struct sfnt_hhea_table *, \
+ struct sfnt_maxp_table *, \
+ struct sfnt_glyph_metrics *, \
+ void *, \
+ struct sfnt_instructed_outline **
+
+extern const char *sfnt_interpret_compound_glyph (PROTOTYPE);
+
+#undef PROTOTYPE
+
+
+
+extern void sfnt_vary_interpreter (struct sfnt_interpreter *,
+ struct sfnt_blend *);
+
+#endif /* TEST */
+
+
+
+#endif /* _SFNT_H_ */
diff --git a/src/sfntfont-android.c b/src/sfntfont-android.c
new file mode 100644
index 00000000000..1ed394b9458
--- /dev/null
+++ b/src/sfntfont-android.c
@@ -0,0 +1,817 @@
+/* sfnt format font driver for Android.
+
+Copyright (C) 2023-2024 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 <https://www.gnu.org/licenses/>. */
+
+#include <config.h>
+#include <dirent.h>
+#include <string.h>
+#include <stdio.h>
+#include <stdlib.h>
+
+#ifdef __aarch64__
+#include <arm_neon.h>
+#endif
+
+#include <android/api-level.h>
+#include <android/log.h>
+
+#include "androidterm.h"
+#include "sfntfont.h"
+#include "pdumper.h"
+#include "blockinput.h"
+#include "android.h"
+
+/* Structure describing a temporary buffer. */
+
+struct sfntfont_android_scanline_buffer
+{
+ /* Size of this buffer. */
+ size_t buffer_size;
+
+ /* Pointer to the buffer data. */
+ void *buffer_data;
+};
+
+/* Array of directories to search for system fonts. */
+static char *system_font_directories[] =
+ {
+ (char *) "/system/fonts",
+ (char *) "/product/fonts",
+ /* This should be filled in by init_sfntfont_android. */
+ (char[PATH_MAX]) { },
+ };
+
+/* The font cache. */
+static Lisp_Object font_cache;
+
+/* The scanline buffer. */
+static struct sfntfont_android_scanline_buffer scanline_buffer;
+
+/* The largest size of the scanline buffer since the last window
+ update. */
+static size_t max_scanline_buffer_size;
+
+
+
+/* Return a temporary buffer for storing scan lines.
+ Set BUFFER to the buffer upon success. */
+
+#ifndef __aarch64__
+
+#define GET_SCANLINE_BUFFER(buffer, height, stride) \
+ do \
+ { \
+ size_t _size; \
+ \
+ if (ckd_mul (&_size, height, stride)) \
+ memory_full (SIZE_MAX); \
+ \
+ if (_size < MAX_ALLOCA) \
+ (buffer) = alloca (_size); \
+ else \
+ { \
+ if (_size > scanline_buffer.buffer_size) \
+ { \
+ (buffer) \
+ = scanline_buffer.buffer_data \
+ = xrealloc (scanline_buffer.buffer_data, \
+ _size); \
+ scanline_buffer.buffer_size = _size; \
+ } \
+ else if (_size <= scanline_buffer.buffer_size) \
+ (buffer) = scanline_buffer.buffer_data; \
+ /* This is unreachable but clang says it is. */ \
+ else \
+ emacs_abort (); \
+ \
+ max_scanline_buffer_size \
+ = max (_size, max_scanline_buffer_size); \
+ } \
+ } while (false);
+
+#else
+
+#define GET_SCANLINE_BUFFER(buffer, height, stride) \
+ do \
+ { \
+ size_t _size; \
+ void *_temp; \
+ \
+ if (ckd_mul (&_size, height, stride)) \
+ memory_full (SIZE_MAX); \
+ \
+ if (_size > scanline_buffer.buffer_size) \
+ { \
+ if (posix_memalign (&_temp, 16, _size)) \
+ memory_full (_size); \
+ free (scanline_buffer.buffer_data); \
+ (buffer) \
+ = scanline_buffer.buffer_data \
+ = _temp; \
+ scanline_buffer.buffer_size = _size; \
+ } \
+ else if (_size <= scanline_buffer.buffer_size) \
+ (buffer) = scanline_buffer.buffer_data; \
+ /* This is unreachable but clang says it is. */ \
+ else \
+ emacs_abort (); \
+ \
+ max_scanline_buffer_size \
+ = max (_size, max_scanline_buffer_size); \
+ } while (false);
+
+#endif
+
+
+
+/* Scale each of the four packed bytes in P in the low 16 bits of P by
+ SCALE. Return the result.
+
+ SCALE is an integer between 0 and 256. */
+
+static unsigned int
+sfntfont_android_scale32 (unsigned int scale, unsigned int p)
+{
+ uint32_t ag, rb;
+ uint32_t scaled_ag, scaled_rb;
+
+ ag = (p & 0xFF00FF00) >> 8;
+ rb = (p & 0x00FF00FF);
+
+ scaled_ag = (scale * ag) & 0xFF00FF00;
+ scaled_rb = (scale * rb) >> 8 & 0x00FF00FF;
+
+ return scaled_ag | scaled_rb;
+}
+
+static unsigned int
+sfntfont_android_mul8x2 (unsigned int a8, unsigned int b32)
+{
+ unsigned int i;
+
+ b32 &= 0xff00ff;
+ i = a8 * b32 + 0x800080;
+
+ return (i + ((i >> 8) & 0xff00ff)) >> 8 & 0xff00ff;
+}
+
+#define U255TO256(x) ((unsigned short) (x) + ((x) >> 7))
+
+/* Blend two pixels SRC and DST without utilizing any control flow.
+ Both SRC and DST are expected to be in premultiplied ABGB8888
+ format. Value is returned in premultiplied ARGB8888 format. */
+
+static unsigned int
+sfntfont_android_blend (unsigned int src, unsigned int dst)
+{
+ unsigned int a, br_part, ag_part, both;
+
+ a = (src >> 24);
+ br_part = sfntfont_android_mul8x2 (255 - a, dst);
+ ag_part = sfntfont_android_mul8x2 (255 - a, dst >> 8) << 8;
+
+ both = ag_part | br_part;
+
+ /* This addition need not be saturating because both has already
+ been multiplied by 255 - a. */
+ return both + src;
+}
+
+#ifdef __aarch64__
+
+/* Like U255TO256, but operates on vectors. */
+
+static uint16x8_t
+sfntfont_android_u255to256 (uint8x8_t in)
+{
+ return vaddl_u8 (vshr_n_u8 (in, 7), in);
+}
+
+/* Use processor features to efficiently composite four pixels at SRC
+ to DST. */
+
+static void
+sfntfont_android_over_8888_1 (unsigned int *src, unsigned int *dst)
+{
+ uint8x8_t alpha;
+ uint16x8_t alpha_c16, v1, v3, v4;
+ uint8x8_t b, g, r, a, v2, v5;
+ uint8x8x4_t _src, _dst;
+
+ /* Pull in src and dst.
+
+ This loads bytes, not words, so little endian ABGR becomes
+ RGBA. */
+ _src = vld4_u8 ((const uint8_t *) src);
+ _dst = vld4_u8 ((const uint8_t *) dst);
+
+ /* Load constants. */
+ v4 = vdupq_n_u16 (256);
+ v5 = vdup_n_u8 (0);
+
+ /* Load src alpha. */
+ alpha = _src.val[3];
+
+ /* alpha_c16 = 256 - 255TO256 (alpha). */
+ alpha_c16 = sfntfont_android_u255to256 (alpha);
+ alpha_c16 = vsubq_u16 (v4, alpha_c16);
+
+ /* Cout = Csrc + Cdst * alpha_c. */
+ v1 = vaddl_u8 (_dst.val[2], v5);
+ v2 = _src.val[2];
+ v3 = vmulq_u16 (v1, alpha_c16);
+ b = vqadd_u8 (v2, vshrn_n_u16 (v3, 8));
+
+ v1 = vaddl_u8 (_dst.val[1], v5);
+ v2 = _src.val[1];
+ v3 = vmulq_u16 (v1, alpha_c16);
+ g = vqadd_u8 (v2, vshrn_n_u16 (v3, 8));
+
+ v1 = vaddl_u8 (_dst.val[0], v5);
+ v2 = _src.val[0];
+ v3 = vmulq_u16 (v1, alpha_c16);
+ r = vqadd_u8 (v2, vshrn_n_u16 (v3, 8));
+
+#if 0
+ /* Aout = Asrc + Adst * alpha_c. */
+ v1 = vaddl_u8 (_dst.val[3], v5);
+ v2 = _src.val[3];
+ v3 = vmulq_u16 (v1, alpha_c16);
+ a = vqadd_u8 (v2, vshrn_n_u16 (v3, 8));
+#else
+ /* We know that Adst is always 1, so Asrc + Adst * (1 - Asrc) is
+ always 1. */
+ a = vdup_n_u8 (255);
+#endif
+
+ /* Store back in dst. */
+ _dst.val[0] = r;
+ _dst.val[1] = g;
+ _dst.val[2] = b;
+ _dst.val[3] = a;
+ vst4_u8 ((uint8_t *) dst, _dst);
+}
+
+/* Use processor features to efficiently composite the buffer at SRC
+ to DST. Composite at most MAX - SRC words.
+
+ If either SRC or DST are not yet properly aligned, value is 1.
+ Otherwise, value is 0, and *X is incremented to the start of any
+ trailing data which could not be composited due to data alignment
+ constraints. */
+
+static int
+sfntfont_android_over_8888 (unsigned int *src, unsigned int *dst,
+ unsigned int *max, unsigned int *x)
+{
+ size_t i;
+ ptrdiff_t how_much;
+ void *s, *d;
+
+ /* Figure out how much can be composited by this loop. */
+ how_much = (max - src) & ~7;
+
+ /* Return if there is not enough to vectorize. */
+ if (!how_much)
+ return 1;
+
+ /* Now increment *X by that much so the containing loop can process
+ the remaining pixels one-by-one. */
+
+ *x += how_much;
+
+ for (i = 0; i < how_much; i += 8)
+ {
+ s = (src + i);
+ d = (dst + i);
+
+ sfntfont_android_over_8888_1 (s, d);
+ }
+
+ return 0;
+}
+
+#endif
+
+/* Composite the bitmap described by BUFFER, STRIDE and TEXT_RECTANGLE
+ onto the native-endian ABGR8888 bitmap described by DEST and
+ BITMAP_INFO. RECT is the subset of the bitmap to composite. */
+
+static void
+sfntfont_android_composite_bitmap (unsigned char *restrict buffer,
+ size_t stride,
+ unsigned char *restrict dest,
+ AndroidBitmapInfo *bitmap_info,
+ struct android_rectangle *text_rectangle,
+ struct android_rectangle *rect)
+{
+ unsigned int *src_row;
+ unsigned int *dst_row;
+ unsigned int i, src_y, x, src_x, max_x, dst_x;
+#ifdef __aarch64__
+ unsigned int lim_x;
+#endif
+
+ if ((intptr_t) dest & 3 || bitmap_info->stride & 3)
+ /* This shouldn't be possible as Android is supposed to align the
+ bitmap to at least a 4 byte boundary. */
+ emacs_abort ();
+ else
+ {
+ for (i = 0; i < rect->height; ++i)
+ {
+ if (i + rect->y >= bitmap_info->height)
+ /* Done. */
+ return;
+
+ src_y = i + (rect->y - text_rectangle->y);
+
+ if (src_y > text_rectangle->height)
+ /* Huh? */
+ return;
+
+ src_row = (unsigned int *) ((buffer + src_y * stride));
+ dst_row = (unsigned int *) (dest + ((i + rect->y)
+ * bitmap_info->stride));
+
+ /* Figure out where the loop below should end. */
+ max_x = min (rect->width, bitmap_info->width - rect->x);
+
+ /* Keep this loop simple! */
+ for (x = 0; x < max_x; ++x)
+ {
+ src_x = x + (rect->x - text_rectangle->x);
+ dst_x = x + rect->x;
+
+#ifdef __aarch64__
+ /* This is the largest value of src_x. */
+ lim_x = max_x + (rect->x - text_rectangle->x);
+
+ if (!sfntfont_android_over_8888 (src_row + src_x,
+ dst_row + dst_x,
+ src_row + lim_x,
+ &x))
+ {
+ /* Decrement X by one so the for loop can increment
+ it again. */
+ x--;
+ continue;
+ }
+#endif
+ dst_row[dst_x]
+ = sfntfont_android_blend (src_row[src_x],
+ dst_row[dst_x]);
+ }
+ }
+ }
+}
+
+/* Calculate the union containing both A and B, both boxes. Place the
+ result in RESULT. */
+
+static void
+sfntfont_android_union_boxes (struct gui_box a, struct gui_box b,
+ struct gui_box *result)
+{
+ result->x1 = min (a.x1, b.x1);
+ result->y1 = min (a.y1, b.y1);
+ result->x2 = max (a.x2, b.x2);
+ result->y2 = max (a.y2, b.y2);
+}
+
+/* Draw the specified glyph rasters from FROM to TO on behalf of S,
+ using S->gc. Fill the background if WITH_BACKGROUND is true.
+
+ See init_sfntfont_vendor and sfntfont_draw for more details. */
+
+static void
+sfntfont_android_put_glyphs (struct glyph_string *s, int from,
+ int to, int x, int y, bool with_background,
+ struct sfnt_raster **rasters,
+ int *x_coords)
+{
+ struct android_rectangle background, text_rectangle, rect;
+ struct gui_box text, character;
+ unsigned int *buffer, *row;
+ unsigned char *restrict raster_row;
+ size_t stride, i;
+ AndroidBitmapInfo bitmap_info;
+ unsigned char *bitmap_data;
+ jobject bitmap;
+ int left, top, temp_y;
+ unsigned int prod, raster_y;
+ unsigned long foreground, back_pixel, rb;
+
+ if (!s->gc->num_clip_rects)
+ /* Clip region is empty. */
+ return;
+
+ if (from == to)
+ /* Nothing to draw. */
+ return;
+
+ /* Swizzle the foreground and background in s->gc into BGR, then add
+ an alpha channel. */
+ foreground = s->gc->foreground;
+ back_pixel = s->gc->background;
+ rb = foreground & 0x00ff00ff;
+ foreground &= ~0x00ff00ff;
+ foreground |= rb >> 16 | rb << 16 | 0xff000000;
+ rb = back_pixel & 0x00ff00ff;
+ back_pixel &= ~0x00ff00ff;
+ back_pixel |= rb >> 16 | rb << 16 | 0xff000000;
+
+ prepare_face_for_display (s->f, s->face);
+
+ /* Build the scanline buffer. Figure out the bounds of the
+ background. */
+ memset (&background, 0, sizeof background);
+
+ if (with_background)
+ {
+ background.x = x;
+ background.y = y - FONT_BASE (s->font);
+ background.width = s->width;
+ background.height = FONT_HEIGHT (s->font);
+ }
+
+ /* Now figure out the bounds of the text. */
+
+ if (rasters[0])
+ {
+ text.x1 = x_coords[0] + rasters[0]->offx;
+ text.x2 = text.x1 + rasters[0]->width;
+ text.y1 = y - rasters[0]->height - rasters[0]->offy;
+ text.y2 = y - rasters[0]->offy;
+ }
+ else
+ memset (&text, 0, sizeof text);
+
+ for (i = 1; i < to - from; ++i)
+ {
+ /* See if text has to be extended. */
+
+ if (!rasters[i])
+ continue;
+
+ character.x1 = x_coords[i] + rasters[i]->offx;
+ character.x2 = character.x1 + rasters[i]->width;
+ character.y1 = y - rasters[i]->height - rasters[i]->offy;
+ character.y2 = y - rasters[i]->offy;
+
+ sfntfont_android_union_boxes (text, character, &text);
+ }
+
+ /* Union the background rect with the text rectangle. */
+ text_rectangle.x = text.x1;
+ text_rectangle.y = text.y1;
+ text_rectangle.width = text.x2 - text.x1;
+ text_rectangle.height = text.y2 - text.y1;
+ gui_union_rectangles (&background, &text_rectangle,
+ &text_rectangle);
+
+ /* Allocate enough to hold text_rectangle.height, aligned to 8 (or
+ 16) bytes. Then fill it with the background. */
+#ifndef __aarch64__
+ stride = ((text_rectangle.width * sizeof *buffer) + 7) & ~7;
+#else
+ stride = ((text_rectangle.width * sizeof *buffer) + 15) & ~15;
+#endif
+ GET_SCANLINE_BUFFER (buffer, text_rectangle.height, stride);
+
+ /* Try to optimize out this memset if the background rectangle
+ contains the whole text rectangle. */
+
+ if (!with_background || memcmp (&background, &text_rectangle,
+ sizeof text_rectangle))
+ memset (buffer, 0, text_rectangle.height * stride);
+
+ if (with_background)
+ {
+ /* Fill the background. First, offset the background rectangle
+ to become relative from text_rectangle.x,
+ text_rectangle.y. */
+ background.x = background.x - text_rectangle.x;
+ background.y = background.y - text_rectangle.y;
+ eassert (background.x >= 0 && background.y >= 0);
+
+ for (temp_y = background.y; (temp_y
+ < (background.y
+ + background.height));
+ ++temp_y)
+ {
+ row = (unsigned int *) ((unsigned char *) buffer
+ + stride * temp_y);
+
+ for (x = background.x; x < background.x + background.width; ++x)
+ row[x] = back_pixel;
+ }
+ }
+
+ /* Draw all the rasters onto the buffer. */
+ for (i = 0; i < to - from; ++i)
+ {
+ if (!rasters[i])
+ continue;
+
+ /* Figure out the top and left of the raster relative to
+ text_rectangle. */
+ left = x_coords[i] + rasters[i]->offx - text_rectangle.x;
+
+ /* Note that negative offy represents the part of the text that
+ lies below the baseline. */
+ top = (y - (rasters[i]->height + rasters[i]->offy)
+ - text_rectangle.y);
+ eassert (left >= 0 && top >= 0);
+
+ /* Draw the raster onto the temporary bitmap using the
+ foreground color scaled by the alpha map. */
+
+ for (raster_y = 0; raster_y < rasters[i]->height; ++raster_y)
+ {
+ row = (unsigned int *) ((unsigned char *) buffer
+ + stride * (raster_y + top));
+ raster_row = &rasters[i]->cells[raster_y * rasters[i]->stride];
+
+ for (x = 0; x < rasters[i]->width; ++x)
+ {
+ prod
+ = sfntfont_android_scale32 (U255TO256 (raster_row[x]),
+ foreground);
+ row[left + x]
+ = sfntfont_android_blend (prod, row[left + x]);
+ }
+ }
+ }
+
+ /* Lock the bitmap. It must be unlocked later. */
+ bitmap_data = android_lock_bitmap (FRAME_ANDROID_DRAWABLE (s->f),
+ &bitmap_info, &bitmap);
+
+ /* If locking the bitmap fails, just discard the data that was
+ allocated. */
+ if (!bitmap_data)
+ return;
+
+ /* Loop over each clip rect in the GC. */
+ eassert (bitmap_info.format == ANDROID_BITMAP_FORMAT_RGBA_8888);
+
+ if (s->gc->num_clip_rects > 0)
+ {
+ for (i = 0; i < s->gc->num_clip_rects; ++i)
+ {
+ if (!gui_intersect_rectangles (&s->gc->clip_rects[i],
+ &text_rectangle, &rect))
+ /* Outside the clip region. */
+ continue;
+
+ /* Composite the intersection onto the buffer. */
+ sfntfont_android_composite_bitmap ((unsigned char *) buffer,
+ stride, bitmap_data,
+ &bitmap_info,
+ &text_rectangle, &rect);
+ }
+ }
+ else /* gc->num_clip_rects < 0 */
+ sfntfont_android_composite_bitmap ((unsigned char *) buffer,
+ stride, bitmap_data,
+ &bitmap_info,
+ &text_rectangle,
+ &text_rectangle);
+
+ /* Release the bitmap. */
+ AndroidBitmap_unlockPixels (android_java_env, bitmap);
+ ANDROID_DELETE_LOCAL_REF (bitmap);
+
+ /* Damage the window by the text rectangle. */
+ android_damage_window (FRAME_ANDROID_DRAWABLE (s->f),
+ &text_rectangle);
+
+#undef MAX_ALLOCA
+}
+
+
+
+/* Shrink the scanline buffer after a window update. If
+ max_scanline_buffer_size is not zero, and is less than
+ scanline_buffer.buffer_size / 2, then resize the scanline buffer to
+ max_scanline_buffer_size. */
+
+void
+sfntfont_android_shrink_scanline_buffer (void)
+{
+ if (!max_scanline_buffer_size)
+ return;
+
+ if (max_scanline_buffer_size
+ < scanline_buffer.buffer_size / 2)
+ {
+ scanline_buffer.buffer_size
+ = max_scanline_buffer_size;
+ scanline_buffer.buffer_data
+ = xrealloc (scanline_buffer.buffer_data,
+ max_scanline_buffer_size);
+ }
+
+ max_scanline_buffer_size = 0;
+}
+
+
+
+/* Font driver definition. */
+
+/* Return the font cache for this font driver. F is ignored. */
+
+static Lisp_Object
+sfntfont_android_get_cache (struct frame *f)
+{
+ return font_cache;
+}
+
+/* The Android sfntfont driver. */
+const struct font_driver android_sfntfont_driver =
+ {
+ .type = LISPSYM_INITIALLY (Qsfnt_android),
+ .case_sensitive = true,
+ .get_cache = sfntfont_android_get_cache,
+ .list = sfntfont_list,
+ .match = sfntfont_match,
+ .draw = sfntfont_draw,
+ .open_font = sfntfont_open,
+ .close_font = sfntfont_close,
+ .encode_char = sfntfont_encode_char,
+ .text_extents = sfntfont_text_extents,
+ .list_family = sfntfont_list_family,
+ .get_variation_glyphs = sfntfont_get_variation_glyphs,
+
+#ifdef HAVE_HARFBUZZ
+ /* HarfBuzz support is enabled transparently on Android without
+ using a separate font driver. */
+ .begin_hb_font = sfntfont_begin_hb_font,
+ .combining_capability = hbfont_combining_capability,
+ .shape = hbfont_shape,
+ .otf_capability = hbfont_otf_capability,
+#endif /* HAVE_HARFBUZZ */
+ };
+
+
+
+/* This is an ugly hack that should go away, but I can't think of
+ how. */
+
+DEFUN ("android-enumerate-fonts", Fandroid_enumerate_fonts,
+ Sandroid_enumerate_fonts, 0, 0, 0,
+ doc: /* Enumerate fonts present on the system.
+
+Signal an error if fonts have already been enumerated. This would
+normally have been done in C, but reading fonts require Lisp to be
+loaded before character sets are made available. */)
+ (void)
+{
+ DIR *dir;
+ int i;
+ struct dirent *dirent;
+ char name[PATH_MAX * 2];
+ static bool enumerated;
+
+ if (enumerated)
+ error ("Fonts have already been enumerated");
+ enumerated = true;
+
+ block_input ();
+
+ /* Scan through each of the system font directories. Enumerate each
+ font that looks like a TrueType font. */
+ for (i = 0; i < ARRAYELTS (system_font_directories); ++i)
+ {
+ dir = opendir (system_font_directories[i]);
+
+ __android_log_print (ANDROID_LOG_VERBOSE, __func__,
+ "Loading fonts from: %s",
+ system_font_directories[i]);
+
+ if (!dir)
+ continue;
+
+ while ((dirent = readdir (dir)))
+ {
+ /* If it contains (not ends with!) with .ttf or .ttc, then
+ enumerate it. */
+
+ if ((strstr (dirent->d_name, ".ttf")
+ || strstr (dirent->d_name, ".ttc"))
+ /* Ignore the non-variable Roboto font. */
+ && (i != 0 || strcmp (dirent->d_name,
+ "RobotoStatic-Regular.ttf")))
+ {
+ sprintf (name, "%s/%s", system_font_directories[i],
+ dirent->d_name);
+ sfnt_enum_font (name);
+ }
+ }
+
+ closedir (dir);
+ }
+
+ unblock_input ();
+
+ return Qnil;
+}
+
+
+
+static void
+syms_of_sfntfont_android_for_pdumper (void)
+{
+ init_sfntfont_vendor (Qsfnt_android, &android_sfntfont_driver,
+ sfntfont_android_put_glyphs);
+ register_font_driver (&android_sfntfont_driver, NULL);
+}
+
+void
+init_sfntfont_android (void)
+{
+ int api_level;
+
+ if (!android_init_gui)
+ return;
+
+ api_level = android_get_current_api_level ();
+
+ /* Make sure to pick the proper Sans Serif and Serif fonts for the
+ version of Android the device is running. */
+
+ if (api_level >= 21)
+ /* Android 5.0 and later distribute Noto Serif in lieu of Droid
+ Serif. */
+ Vsfnt_default_family_alist
+ = list4 (Fcons (build_string ("Monospace"),
+ build_string ("Droid Sans Mono")),
+ /* Android doesn't come with a Monospace Serif font, so
+ this will have to do. */
+ Fcons (build_string ("Monospace Serif"),
+ build_string ("Droid Sans Mono")),
+ Fcons (build_string ("Sans Serif"),
+ build_string ("Roboto")),
+ Fcons (build_string ("DejaVu Serif"),
+ build_string ("Noto Serif")));
+ else if (api_level >= 14)
+ /* Android 4.0 and later distribute Roboto in lieu of Droid
+ Sans. */
+ Vsfnt_default_family_alist
+ = list4 (Fcons (build_string ("Monospace"),
+ build_string ("Droid Sans Mono")),
+ /* Android doesn't come with a Monospace Serif font, so
+ this will have to do. */
+ Fcons (build_string ("Monospace Serif"),
+ build_string ("Droid Sans Mono")),
+ Fcons (build_string ("Sans Serif"),
+ build_string ("Roboto")),
+ Fcons (build_string ("DejaVu Serif"),
+ build_string ("Droid Serif")));
+ else
+ Vsfnt_default_family_alist
+ = list4 (Fcons (build_string ("Monospace"),
+ build_string ("Droid Sans Mono")),
+ Fcons (build_string ("Monospace Serif"),
+ build_string ("Droid Sans Mono")),
+ Fcons (build_string ("Sans Serif"),
+ build_string ("Droid Sans")),
+ Fcons (build_string ("DejaVu Serif"),
+ build_string ("Droid Serif")));
+
+ /* Set up the user fonts directory. This directory is ``fonts'' in
+ the Emacs files directory. */
+ snprintf (system_font_directories[2], PATH_MAX, "%s/fonts",
+ android_get_home_directory ());
+}
+
+void
+syms_of_sfntfont_android (void)
+{
+ DEFSYM (Qsfnt_android, "sfnt-android");
+ DEFSYM (Qandroid_enumerate_fonts, "android-enumerate-fonts");
+ Fput (Qandroid, Qfont_driver_superseded_by, Qsfnt_android);
+
+ font_cache = list (Qnil);
+ staticpro (&font_cache);
+
+ defsubr (&Sandroid_enumerate_fonts);
+
+ pdumper_do_now_and_after_load (syms_of_sfntfont_android_for_pdumper);
+}
diff --git a/src/sfntfont.c b/src/sfntfont.c
new file mode 100644
index 00000000000..fb3feaeaf79
--- /dev/null
+++ b/src/sfntfont.c
@@ -0,0 +1,4229 @@
+/* sfnt format font driver for GNU Emacs.
+
+Copyright (C) 2023-2024 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 <https://www.gnu.org/licenses/>. */
+
+#include <config.h>
+
+#include <fcntl.h>
+#include <ctype.h>
+
+#include "lisp.h"
+
+#include "blockinput.h"
+#include "charset.h"
+#include "coding.h"
+#include "font.h"
+#include "frame.h"
+#include "math.h"
+#include "sfnt.h"
+#include "sfntfont.h"
+
+#ifdef HAVE_HARFBUZZ
+#include <hb.h>
+#include <hb-ot.h>
+#endif /* HAVE_HARFBUZZ */
+
+/* For FRAME_FONT. */
+#include TERM_HEADER
+
+/* Generic font driver for sfnt-based fonts (currently TrueType, but
+ it would be easy to add CFF support in the future with a PostScript
+ renderer.)
+
+ This is not a complete font driver. Hooks must be supplied by the
+ platform implementer to draw glyphs. */
+
+
+
+/* Tables associated with each font, be it distortable or not. This
+ allows different font objects sharing the same underlying font file
+ to share tables. */
+
+struct sfnt_font_tables
+{
+ /* Various tables required to use the font. */
+ struct sfnt_cmap_table *cmap;
+ struct sfnt_hhea_table *hhea;
+ struct sfnt_maxp_table *maxp;
+ struct sfnt_head_table *head;
+ struct sfnt_hmtx_table *hmtx;
+ struct sfnt_glyf_table *glyf;
+ struct sfnt_loca_table_short *loca_short;
+ struct sfnt_loca_table_long *loca_long;
+ struct sfnt_prep_table *prep;
+ struct sfnt_fpgm_table *fpgm;
+ struct sfnt_cvt_table *cvt;
+ struct sfnt_fvar_table *fvar;
+ struct sfnt_avar_table *avar;
+ struct sfnt_gvar_table *gvar;
+ struct sfnt_cvar_table *cvar;
+
+ /* The selected character map. */
+ struct sfnt_cmap_encoding_subtable_data *cmap_data;
+
+ /* Data identifying that character map. */
+ struct sfnt_cmap_encoding_subtable cmap_subtable;
+
+ /* The UVS context. */
+ struct sfnt_uvs_context *uvs;
+
+#ifdef HAVE_MMAP
+ /* Whether or not the glyph table has been mmapped. */
+ bool glyf_table_mapped;
+#endif /* HAVE_MMAP */
+
+#ifdef HAVE_HARFBUZZ
+ /* File descriptor associated with this font. */
+ int fd;
+
+ /* The table directory of the font file. */
+ struct sfnt_offset_subtable *directory;
+#endif /* HAVE_HARFBUZZ */
+};
+
+/* Description of a font that hasn't been opened. */
+
+struct sfnt_font_desc
+{
+ /* Next font in this list. */
+ struct sfnt_font_desc *next;
+
+ /* Family name of the font. */
+ Lisp_Object family;
+
+ /* Style name of the font. */
+ Lisp_Object style;
+
+ /* The font foundry name, or `misc' if not present. */
+ Lisp_Object designer;
+
+ /* Style tokens that could not be parsed. */
+ Lisp_Object adstyle;
+
+ /* List of design languages. */
+ Lisp_Object languages;
+
+ /* Font registry that this font supports. */
+ Lisp_Object registry;
+
+ /* Vector of instances. Each element is another of the instance's
+ `style', `adstyle', and numeric width, weight, and slant. May be
+ nil. */
+ Lisp_Object instances;
+
+ /* Numeric width, weight, slant and spacing. */
+ int width, weight, slant, spacing;
+
+ /* Path to the font file. */
+ char *path;
+
+ /* char table consisting of characters already known to be
+ present in the font. */
+ Lisp_Object char_cache;
+
+ /* The header of the cmap being used. May be invalid, in which case
+ platform_id will be 500. */
+ struct sfnt_cmap_encoding_subtable subtable;
+
+ /* The offset of the table directory within PATH. */
+ off_t offset;
+
+ /* List of font tables. */
+ struct sfnt_font_tables *tables;
+
+ /* The number of glyphs in this font. Used to catch invalid cmap
+ tables. This is actually the number of glyphs - 1. */
+ int num_glyphs;
+
+ /* The number of references to the font tables below. */
+ int refcount;
+
+ /* The underline position and thickness if a post table supplies
+ this information. */
+ sfnt_fword underline_position, underline_thickness;
+
+ /* Whether an underline position is available. */
+ bool_bf underline_position_set : 1;
+
+ /* Whether or not the character map can't be used by Emacs. */
+ bool cmap_invalid : 1;
+};
+
+/* List of fonts. */
+
+static struct sfnt_font_desc *system_fonts;
+
+/* Font enumeration and matching. The sfnt driver assumes it can read
+ data from each font at startup. It then reads the head, meta and
+ name tables to determine font data, and records the font in a list
+ of system fonts that is then matched against. */
+
+/* Set up the coding system CODING to decode string data from the
+ given platform id ID and platform specific id PLATFORM_SPECIFIC_ID.
+ Value is 0 upon success, 1 upon failure. */
+
+static int
+sfnt_setup_coding_system (enum sfnt_platform_id id, int platform_specific_id,
+ struct coding_system *coding)
+{
+ Lisp_Object system;
+
+ system = Qnil;
+
+ /* Figure out what coding system to use. */
+
+ switch (id)
+ {
+ case SFNT_PLATFORM_UNICODE:
+ system = Qutf_16be;
+ break;
+
+ case SFNT_PLATFORM_MACINTOSH:
+
+ if (platform_specific_id == SFNT_MACINTOSH_ROMAN)
+ system = Qmac_roman;
+ else
+ /* MULE doesn't support the rest... */
+ system = Qnil;
+
+ break;
+
+ case SFNT_PLATFORM_MICROSOFT:
+ system = Qutf_16be;
+
+ /* Not sure if this is right. */
+ if (platform_specific_id == SFNT_MICROSOFT_BIG_FIVE)
+ system = Qchinese_big5;
+
+ break;
+
+ default:
+ system = Qnil;
+ }
+
+ if (NILP (system))
+ return 1;
+
+ setup_coding_system (system, coding);
+ return 0;
+}
+
+/* Globals used to communicate inside the condition-case wrapper. */
+static struct coding_system *sfnt_font_coding;
+
+/* The src_object being encoded from. This should be on the stack as
+ well, or it will get garbage collected. */
+static Lisp_Object sfnt_font_src_object;
+
+/* From-position. */
+static ptrdiff_t sfnt_font_from, sfnt_font_from_byte;
+
+/* To-position. */
+static ptrdiff_t sfnt_font_to, sfnt_font_to_byte;
+
+/* Destination object. Once again, this should also be on the
+ stack. */
+static Lisp_Object sfnt_font_dst_object;
+
+/* Error flag. Set to true if a signal was caught. */
+static bool sfnt_font_signal;
+
+static Lisp_Object
+sfnt_safe_decode_coding_object_1 (void)
+{
+ decode_coding_object (sfnt_font_coding,
+ sfnt_font_src_object,
+ sfnt_font_from,
+ sfnt_font_from_byte,
+ sfnt_font_to,
+ sfnt_font_to_byte,
+ sfnt_font_dst_object);
+ return Qnil;
+}
+
+static Lisp_Object
+sfnt_safe_decode_coding_object_2 (Lisp_Object error)
+{
+ sfnt_font_signal = true;
+
+ return Qnil;
+}
+
+/* Like decode_coding_object, but return 1 if a signal happens. Value
+ is otherwise 0. */
+
+static int
+sfnt_safe_decode_coding_object (struct coding_system *coding,
+ Lisp_Object src_object,
+ ptrdiff_t from, ptrdiff_t from_byte,
+ ptrdiff_t to, ptrdiff_t to_byte,
+ Lisp_Object dst_object)
+{
+ sfnt_font_coding = coding;
+ sfnt_font_src_object = src_object;
+ sfnt_font_from = from;
+ sfnt_font_from_byte = from_byte;
+ sfnt_font_to = to;
+ sfnt_font_to_byte = to_byte;
+ sfnt_font_dst_object = dst_object;
+ sfnt_font_signal = false;
+
+ internal_condition_case (sfnt_safe_decode_coding_object_1,
+ Qt,
+ sfnt_safe_decode_coding_object_2);
+
+ return (int) sfnt_font_signal;
+}
+
+/* Decode the specified string DATA. The encoding is determined based
+ on PLATFORM_ID, PLATFORM_SPECIFIC_ID and LANGUAGE_ID. Consult
+ sfnt.h and the TrueType Reference Manual for more details. LENGTH
+ is the length of DATA in bytes.
+
+ Value is nil upon failure, else the decoded string. */
+
+static Lisp_Object
+sfnt_decode_font_string (unsigned char *data, enum sfnt_platform_id id,
+ int platform_specific_id, int language_id,
+ size_t length)
+{
+ struct coding_system coding;
+
+ memset (&coding, 0, sizeof coding);
+ sfnt_setup_coding_system (id, platform_specific_id, &coding);
+ coding.mode |= CODING_MODE_SAFE_ENCODING;
+ coding.mode |= CODING_MODE_LAST_BLOCK;
+ /* Suppress producing escape sequences for composition. */
+ coding.common_flags &= ~CODING_ANNOTATION_MASK;
+ coding.source = data;
+
+ if (sfnt_safe_decode_coding_object (&coding, Qnil, 0, 0,
+ length, length, Qt))
+ return Qnil;
+
+ return coding.dst_object;
+}
+
+/* Decode the family and style names from the name table NAME. Return
+ 0 and the family and style names upon success, else 1. */
+
+static int
+sfnt_decode_family_style (struct sfnt_name_table *name,
+ Lisp_Object *family, Lisp_Object *style)
+{
+ struct sfnt_name_record family_rec, style_rec;
+ unsigned char *family_data, *style_data;
+
+ /* Because MS-Windows is incapable of treating font families
+ comprising more than four styles correctly, the TrueType
+ specification incorporates additional PREFERRED_FAMILY and
+ PREFERRED_SUBFAMILY name resources that are meant to be consulted
+ over the traditional family and subfamily resources. When
+ present within fonts supplying unusual styles, these names hold
+ the ``actual'' typographic family and style of the font, in lieu
+ of the font family with the style affixed to the front and
+ Regular. */
+
+ family_data = sfnt_find_name (name, SFNT_NAME_PREFERRED_FAMILY,
+ &family_rec);
+
+ if (!family_data)
+ family_data = sfnt_find_name (name, SFNT_NAME_FONT_FAMILY,
+ &family_rec);
+
+ style_data = sfnt_find_name (name, SFNT_NAME_PREFERRED_SUBFAMILY,
+ &style_rec);
+
+ if (!style_data)
+ style_data = sfnt_find_name (name, SFNT_NAME_FONT_SUBFAMILY,
+ &style_rec);
+
+ if (!family_data || !style_data)
+ return 1;
+
+ /* Now decode the data. */
+ *family = sfnt_decode_font_string (family_data,
+ family_rec.platform_id,
+ family_rec.platform_specific_id,
+ family_rec.language_id,
+ family_rec.length);
+ *style = sfnt_decode_font_string (style_data,
+ style_rec.platform_id,
+ style_rec.platform_specific_id,
+ style_rec.language_id,
+ style_rec.length);
+
+ /* Return whether or not it was successful. */
+ return (!NILP (*family) && !NILP (*style)) ? 0 : 1;
+}
+
+/* Decode the name of the specified font INSTANCE using the given NAME
+ table. Return the name of that instance, or nil upon failure. */
+
+static Lisp_Object
+sfnt_decode_instance_name (struct sfnt_instance *instance,
+ struct sfnt_name_table *name)
+{
+ struct sfnt_name_record name_rec;
+ unsigned char *name_data;
+
+ name_data = sfnt_find_name (name, instance->name_id,
+ &name_rec);
+
+ if (!name_data)
+ return Qnil;
+
+ return sfnt_decode_font_string (name_data,
+ name_rec.platform_id,
+ name_rec.platform_specific_id,
+ name_rec.language_id,
+ name_rec.length);
+}
+
+struct sfnt_style_desc
+{
+ /* The C string to match against. */
+ const char *c_string;
+
+ /* The value of the style field. */
+ int value;
+};
+
+/* Array of style descriptions describing weight. */
+static struct sfnt_style_desc sfnt_weight_descriptions[] =
+ {
+ { "thin", 0, },
+ { "extralight", 40, },
+ { "ultralight", 40, },
+ { "light", 50, },
+ { "demilight", 55, },
+ { "semilight", 55, },
+ { "book", 75, },
+ { "medium", 100, },
+ { "demibold", 180, },
+ { "semibold", 180, },
+ { "bold", 200, },
+ { "extrabold", 205, },
+ { "ultrabold", 205, },
+ { "black", 210, },
+ { "heavy", 210, },
+ { "extrablack", 215, },
+ { "ultrablack", 215, },
+ };
+
+/* Array of style descriptions describing slant. */
+static struct sfnt_style_desc sfnt_slant_descriptions[] =
+ {
+ { "italic", 200, },
+ { "oblique", 210, },
+ };
+
+/* Array of style descriptions describing width. */
+static struct sfnt_style_desc sfnt_width_descriptions[] =
+ {
+ { "ultracondensed", 50, },
+ { "extracondensed", 63, },
+ { "condensed", 75, },
+ { "semicondensed", 87, },
+ { "semiexpanded", 113, },
+ { "expanded", 125, },
+ { "extraexpanded", 150, },
+ { "ultraexpanded", 200, },
+ };
+
+/* Figure out DESC->width, DESC->weight, DESC->slant and DESC->spacing
+ based on the style name passed as STYLE_NAME.
+
+ Also append any unknown tokens to DESC->adstyle. */
+
+static void
+sfnt_parse_style (Lisp_Object style_name, struct sfnt_font_desc *desc)
+{
+ char *style, *single, *saveptr;
+ int i;
+ USE_SAFE_ALLOCA;
+
+ /* Fill in default values. slant seems to not be consistent with
+ Fontconfig. */
+ desc->weight = 80;
+ desc->slant = 100;
+ desc->width = 100;
+
+ /* Split the style into tokens delimited by spaces. Attempt to find
+ a token specifying each of the weight, slant, or width attributes
+ using their respective descriptions arrays as a reference. */
+
+ SAFE_ALLOCA_STRING (style, Fdowncase (style_name));
+ saveptr = NULL;
+
+ while ((single = strtok_r (style, " ", &saveptr)))
+ {
+ style = NULL;
+
+ if (!strcmp (single, "regular"))
+ /* ``Regular'' within a font family can represent either the
+ weight, slant or width of the font. Leave each value as
+ its default, but never append it to the adstyle. */
+ goto next;
+
+ if (desc->weight == 80)
+ {
+ /* Weight hasn't been found yet. Scan through the weight
+ table. */
+ for (i = 0; i < ARRAYELTS (sfnt_weight_descriptions); ++i)
+ {
+ if (!strcmp (sfnt_weight_descriptions[i].c_string,
+ single))
+ {
+ /* Weight found. Continue on reading the slant and
+ width. */
+ desc->weight = sfnt_weight_descriptions[i].value;
+ goto next;
+ }
+ }
+ }
+
+ if (desc->slant == 100)
+ {
+ /* Slant hasn't been found yet. Scan through the slant
+ table. */
+ for (i = 0; i < ARRAYELTS (sfnt_slant_descriptions); ++i)
+ {
+ if (!strcmp (sfnt_slant_descriptions[i].c_string,
+ single))
+ {
+ /* Slant found. Continue on reading the weight and
+ width. */
+ desc->slant = sfnt_slant_descriptions[i].value;
+ goto next;
+ }
+ }
+ }
+
+ if (desc->width == 100)
+ {
+ /* Width hasn't been found yet. Scan through the width
+ table. */
+ for (i = 0; i < ARRAYELTS (sfnt_width_descriptions); ++i)
+ {
+ if (!strcmp (sfnt_width_descriptions[i].c_string,
+ single))
+ {
+ /* Width found. Continue on reading the slant and
+ weight. */
+ desc->width = sfnt_width_descriptions[i].value;
+ goto next;
+ }
+ }
+ }
+
+ /* This token is extraneous or was not recognized. Capitalize
+ the first letter and set it as the adstyle. */
+
+ if (strlen (single))
+ {
+ if (islower (single[0]))
+ single[0] = toupper (single[0]);
+
+ if (NILP (desc->adstyle))
+ desc->adstyle = build_string (single);
+ else
+ desc->adstyle = CALLN (Fconcat, desc->adstyle,
+ build_string (" "),
+ build_string (single));
+ }
+
+ next:
+ continue;
+ }
+
+ /* The adstyle must be a symbol, so intern it if it is set. */
+
+ if (!NILP (desc->adstyle))
+ desc->adstyle = Fintern (desc->adstyle, Qnil);
+
+ SAFE_FREE ();
+}
+
+/* Parse the list of design languages in META, a font metadata table,
+ and place the results in DESC->languages. Do nothing if there is
+ no such metadata. */
+
+static void
+sfnt_parse_languages (struct sfnt_meta_table *meta,
+ struct sfnt_font_desc *desc)
+{
+ char *data, *metadata, *tag;
+ struct sfnt_meta_data_map map;
+ char *saveptr;
+
+ /* Look up the ``design languages'' metadata. This is a comma (and
+ possibly space) separated list of scripts that the font was
+ designed for. Here is an example of one such tag:
+
+ zh-Hans,Jpan,Kore
+
+ for a font that covers Simplified Chinese, along with Japanese
+ and Korean text. */
+
+ saveptr = NULL;
+ data = sfnt_find_metadata (meta, SFNT_META_DATA_TAG_DLNG,
+ &map);
+
+ if (!data)
+ {
+ /* Fall back to the supported languages metadata. */
+ data = sfnt_find_metadata (meta, SFNT_META_DATA_TAG_SLNG,
+ &map);
+
+ if (!data)
+ return;
+ }
+
+ USE_SAFE_ALLOCA;
+
+ /* Now copy metadata and add a trailing NULL byte. */
+
+ if (map.data_length >= SIZE_MAX)
+ memory_full (SIZE_MAX);
+
+ metadata = SAFE_ALLOCA ((size_t) map.data_length + 1);
+ memcpy (metadata, data, map.data_length);
+ metadata[map.data_length] = '\0';
+
+ /* Loop through each script-language tag. Note that there may be
+ extra leading spaces. */
+ while ((tag = strtok_r (metadata, ",", &saveptr)))
+ {
+ metadata = NULL;
+
+ if (strstr (tag, "Hans") || strstr (tag, "Hant"))
+ desc->languages = Fcons (Qzh, desc->languages);
+
+ if (strstr (tag, "Japn"))
+ desc->languages = Fcons (Qja, desc->languages);
+
+ if (strstr (tag, "Kore"))
+ desc->languages = Fcons (Qko, desc->languages);
+ }
+
+ SAFE_FREE ();
+}
+
+/* Return the font registry corresponding to the encoding subtable
+ SUBTABLE.
+
+ Under X, the font registry is an atom registered with the Open
+ Group uniquely identifying the organization which defines the
+ font's character set.
+
+ In practice, the registry overlaps with the character set itself.
+ So Emacs just uses the ``registry'' field of each font object and
+ entity to represent both instead. */
+
+static Lisp_Object
+sfnt_registry_for_subtable (struct sfnt_cmap_encoding_subtable *subtable)
+{
+ switch (subtable->platform_id)
+ {
+ case SFNT_PLATFORM_UNICODE:
+ /* Reject variation selector and last resort tables. */
+ if ((subtable->platform_specific_id
+ == SFNT_UNICODE_VARIATION_SEQUENCES)
+ || (subtable->platform_specific_id
+ == SFNT_UNICODE_LAST_RESORT))
+ return Qnil;
+
+ return Qiso10646_1;
+
+ case SFNT_PLATFORM_MACINTOSH:
+
+ switch (subtable->platform_specific_id)
+ {
+ case SFNT_MACINTOSH_ROMAN:
+ /* X calls mac-roman ``apple-roman''. */
+ return Qapple_roman;
+
+ default:
+ /* Some other Macintosh charset not supported by Emacs. */
+ return Qnil;
+ }
+
+ case SFNT_PLATFORM_MICROSOFT:
+
+ /* Microsoft specific encodings. */
+
+ switch (subtable->platform_specific_id)
+ {
+ case SFNT_MICROSOFT_SYMBOL:
+ case SFNT_MICROSOFT_UNICODE_BMP:
+ /* Symbols in the Unicode PUA are still Unicode. */
+ return Qiso10646_1;
+
+ case SFNT_MICROSOFT_SHIFT_JIS:
+ return Qjisx0208_1983_0;
+
+ case SFNT_MICROSOFT_PRC:
+ return Qgbk;
+
+ case SFNT_MICROSOFT_JOHAB:
+ return Qksc5601_1987_0;
+
+ case SFNT_MICROSOFT_UNICODE_UCS_4:
+ return Qiso10646_1;
+ }
+
+ default:
+ return Qnil;
+ }
+}
+
+/* Return the type of characters that the cmap subtable SUBTABLE maps
+ from. Value is:
+
+ 2 if SUBTABLE maps from Unicode characters, including those outside
+ the Unicode Basic Multilingual Plane (BMP).
+
+ 1 if SUBTABLE maps from Unicode characters within the BMP.
+
+ 0 if SUBTABLE maps from some other character set that Emacs knows
+ about.
+
+ 3 if SUBTABLE cannot be used by Emacs. */
+
+static int
+sfntfont_identify_cmap (struct sfnt_cmap_encoding_subtable subtable)
+{
+ switch (subtable.platform_id)
+ {
+ case SFNT_PLATFORM_UNICODE:
+
+ /* Reject variation selector and last resort tables. */
+ if ((subtable.platform_specific_id
+ == SFNT_UNICODE_VARIATION_SEQUENCES)
+ || (subtable.platform_specific_id
+ == SFNT_UNICODE_LAST_RESORT))
+ return 3;
+
+ /* 1.0, 1.1, ISO-10646-1993, and 2.0_BMP tables are all within
+ the BMP. */
+ if (subtable.platform_specific_id < SFNT_UNICODE_2_0)
+ return 1;
+
+ return 2;
+
+ case SFNT_PLATFORM_MACINTOSH:
+
+ switch (subtable.platform_specific_id)
+ {
+ case SFNT_MACINTOSH_ROMAN:
+ /* mac-roman */
+ return 0;
+
+ default:
+ /* Some other Macintosh charset not supported by Emacs. */
+ return 3;
+ }
+
+ case SFNT_PLATFORM_MICROSOFT:
+
+ /* Microsoft specific encodings. */
+
+ switch (subtable.platform_specific_id)
+ {
+ case SFNT_MICROSOFT_SYMBOL:
+ /* Symbols in the Unicode PUA are still Unicode. */
+ return 1;
+
+ case SFNT_MICROSOFT_UNICODE_BMP:
+ return 1;
+
+ case SFNT_MICROSOFT_SHIFT_JIS:
+ /* PCK aka japanese-jisx0208. */
+ return 0;
+
+ case SFNT_MICROSOFT_PRC:
+ /* GBK, GB2312 or GB18030. */
+ return 0;
+
+ case SFNT_MICROSOFT_JOHAB:
+ /* KS C 5601-1992, aka korean-ksc5601. */
+ return 0;
+
+ case SFNT_MICROSOFT_UNICODE_UCS_4:
+ /* Unicode past the BMP. */
+ return 2;
+ }
+
+ default:
+ return 3;
+ }
+}
+
+/* Figure out which registry DESC, backed by FD, whose table directory
+ is SUBTABLE, is likely to support.
+
+ Read the header of each subtable in the character map and compute
+ the registry to use; then, set DESC->registry to that value. */
+
+static void
+sfnt_grok_registry (int fd, struct sfnt_font_desc *desc,
+ struct sfnt_offset_subtable *subtable)
+{
+ struct sfnt_cmap_table *cmap;
+ struct sfnt_cmap_encoding_subtable *subtables;
+ int i;
+
+ cmap = sfnt_read_cmap_table (fd, subtable, &subtables, NULL);
+
+ if (!cmap)
+ return;
+
+ /* Now pick the ``best'' character map the same way as sfntfont_open
+ does. The caveat is that since the subtable data has not been
+ read, Emacs cannot determine whether or not the encoding subtable
+ is valid.
+
+ Once platform_id is set, that value becomes much more
+ reliable. */
+
+ /* First look for a non-BMP Unicode cmap. */
+
+ for (i = 0; i < cmap->num_subtables; ++i)
+ {
+ if (sfntfont_identify_cmap (subtables[i]) == 2)
+ {
+ desc->registry
+ = sfnt_registry_for_subtable (&subtables[i]);
+ goto done;
+ }
+ }
+
+ /* Next, look for a BMP only Unicode cmap. */
+
+ for (i = 0; i < cmap->num_subtables; ++i)
+ {
+ if (sfntfont_identify_cmap (subtables[i]) == 1)
+ {
+ desc->registry
+ = sfnt_registry_for_subtable (&subtables[i]);
+ goto done;
+ }
+ }
+
+ /* Finally, use the first cmap that appears and can be
+ identified. */
+
+ for (i = 0; i < cmap->num_subtables; ++i)
+ {
+ if (sfntfont_identify_cmap (subtables[i]) == 0)
+ {
+ desc->registry
+ = sfnt_registry_for_subtable (&subtables[i]);
+ goto done;
+ }
+ }
+
+ /* There are no cmaps available to Emacs. */
+ done:
+ xfree (cmap);
+ xfree (subtables);
+}
+
+/* Return whether or not the font description PREV conflicts with the
+ newer font description DESC, and should be removed from the list of
+ system fonts.
+
+ If both PREV and DESC are variable fonts, remove styles within PREV
+ that overlap with DESC and return false.
+
+ If PREV is a variable font, potentially adjust its list of
+ instances. */
+
+static bool
+sfnt_replace_fonts_p (struct sfnt_font_desc *prev,
+ struct sfnt_font_desc *desc)
+{
+ int i, j, width, weight, slant, count_instance;
+ Lisp_Object tem, tem1;
+ bool family_equal_p;
+
+ family_equal_p = !NILP (Fstring_equal (prev->family,
+ desc->family));
+
+ if ((!NILP (desc->instances)
+ || !NILP (Fstring_equal (prev->style, desc->style)))
+ && family_equal_p)
+ {
+ /* If both inputs are GX fonts... */
+ if (!NILP (desc->instances) && !NILP (prev->instances))
+ {
+ /* ...iterate over each of the styles provided by PREV. If
+ they match any styles within DESC, remove the old style
+ from PREV. */
+
+ count_instance = 0;
+ for (i = 0; i < ASIZE (prev->instances); ++i)
+ {
+ tem = AREF (prev->instances, i);
+
+ if (NILP (tem))
+ continue;
+
+ for (j = 0; j < ASIZE (desc->instances); ++j)
+ {
+ tem1 = AREF (desc->instances, j);
+
+ if (NILP (tem1))
+ continue;
+
+ if (!NILP (Fequal (tem1, tem)))
+ {
+ /* tem1 is identical to tem, so opt for it over
+ tem. */
+ ASET (prev->instances, i, Qnil);
+ goto next;
+ }
+ }
+
+ /* Increment the number of instances remaining within
+ PREV. */
+ count_instance++;
+
+ next:
+ ;
+ }
+
+ /* Return true if no instances remain inside
+ PREV->instances, so that the now purposeless desc may be
+ removed. */
+ return !count_instance;
+ }
+
+ return true;
+ }
+
+ if (NILP (prev->instances) || !family_equal_p)
+ return false;
+
+ /* Look through instances in PREV to see if DESC provides the same
+ thing. */
+
+ count_instance = 0;
+ for (i = 0; i < ASIZE (prev->instances); ++i)
+ {
+ tem = AREF (prev->instances, i);
+
+ if (NILP (tem))
+ continue;
+
+ width = XFIXNUM (AREF (tem, 2));
+ weight = XFIXNUM (AREF (tem, 3));
+ slant = XFIXNUM (AREF (tem, 4));
+
+ if (desc->width == width
+ && desc->weight == weight
+ && desc->slant == slant)
+ {
+ /* Remove this instance. */
+ ASET (prev->instances, i, Qnil);
+ continue;
+ }
+
+ count_instance++;
+ }
+
+ /* Remove this desc if there are no more instances. */
+ return count_instance < 1;
+}
+
+/* Enumerate the offset subtable SUBTABLES in the file FD, whose file
+ name is FILE. OFFSET should be the offset of the subtable within
+ the font file, and is recorded for future use. Value is 1 upon
+ failure, else 0. */
+
+static int
+sfnt_enum_font_1 (int fd, const char *file,
+ struct sfnt_offset_subtable *subtables,
+ off_t offset)
+{
+ struct sfnt_font_desc *desc, **next, *prev;
+ struct sfnt_head_table *head;
+ struct sfnt_name_table *name;
+ struct sfnt_meta_table *meta;
+ struct sfnt_maxp_table *maxp;
+ struct sfnt_fvar_table *fvar;
+ struct sfnt_OS_2_table *OS_2;
+ struct sfnt_post_table *post;
+ struct sfnt_font_desc temp;
+ Lisp_Object family, style, instance, style1;
+ int i;
+ char buffer[5];
+
+ /* Create the font desc and copy in the file name. */
+ desc = xzalloc (sizeof *desc + strlen (file) + 1);
+ desc->path = (char *) (desc + 1);
+ memcpy (desc->path, file, strlen (file) + 1);
+ desc->offset = offset;
+
+ /* Check that this is a TrueType font. */
+ if (subtables->scaler_type != SFNT_SCALER_TRUE
+ && subtables->scaler_type != SFNT_SCALER_VER1)
+ goto bail1;
+
+ /* Read required tables. */
+ head = sfnt_read_head_table (fd, subtables);
+ if (!head)
+ goto bail1;
+
+ name = sfnt_read_name_table (fd, subtables);
+ if (!name)
+ goto bail2;
+
+ maxp = sfnt_read_maxp_table (fd, subtables);
+ if (!maxp)
+ goto bail3;
+
+ /* meta is not required, nor present on many non-Apple fonts. */
+ meta = sfnt_read_meta_table (fd, subtables);
+
+ /* Decode the family and style from the name table. */
+ if (sfnt_decode_family_style (name, &family, &style))
+ goto bail4;
+
+ /* See if this is a distortable/variable/multiple master font (all
+ three terms mean the same time.) */
+ fvar = sfnt_read_fvar_table (fd, subtables);
+
+ /* Set the family. */
+ desc->family = family;
+ desc->char_cache = Qnil;
+ desc->subtable.platform_id = 500;
+
+ /* Now set the font foundry name. This information is located
+ within the OS/2 table's `ach_vendor_id' field, but use `misc' as
+ a recourse if it is not present. */
+
+ OS_2 = sfnt_read_OS_2_table (fd, subtables);
+
+ if (OS_2)
+ {
+ memcpy (buffer, OS_2->ach_vendor_id,
+ sizeof OS_2->ach_vendor_id);
+ buffer[sizeof OS_2->ach_vendor_id] = '\0';
+
+ /* If the foundry name is empty, use `misc' instead. */
+
+ if (!buffer[0])
+ desc->designer = Qmisc;
+ else
+ desc->designer = intern (buffer);
+
+ xfree (OS_2);
+ }
+ else
+ desc->designer = Qmisc;
+
+ /* Set the largest glyph identifier. */
+ desc->num_glyphs = maxp->num_glyphs;
+
+ /* Parse the style. */
+ sfnt_parse_style (style, desc);
+
+ /* If the meta table exists, parse the list of design languages. */
+ if (meta)
+ sfnt_parse_languages (meta, desc);
+
+ /* Check whether the font claims to be a fixed pitch font and forgo
+ the rudimentary detection below if so. */
+
+ post = sfnt_read_post_table (fd, subtables);
+
+ if (post)
+ {
+ desc->spacing = (post->is_fixed_pitch ? 100 : 0);
+ desc->underline_position = post->underline_position;
+ desc->underline_thickness = post->underline_thickness;
+ desc->underline_position_set = true;
+ xfree (post);
+ }
+ else
+ {
+ /* Figure out the spacing. Some fancy test like what Fontconfig
+ does is probably in order but not really necessary. */
+ if (!NILP (Fstring_search (Fdowncase (family),
+ build_string ("mono"),
+ Qnil)))
+ desc->spacing = 100; /* FC_MONO */
+ }
+
+ /* Finally add mac-style flags. Allow them to override styles that
+ have not been found. */
+
+ if (head->mac_style & 01 && desc->weight == 80) /* Bold */
+ desc->weight = 200;
+
+ if (head->mac_style & 02 && desc->slant == 0) /* Italic */
+ desc->slant = 100;
+
+ /* Figure out what registry this font is likely to support. */
+ sfnt_grok_registry (fd, desc, subtables);
+
+ if (fvar && fvar->instance_count)
+ {
+ /* If there is an fvar table with instances, then this is a font
+ which defines different axes along which the points in each
+ glyph can be changed.
+
+ Instead of enumerating the font itself, enumerate each
+ instance within, which specifies how to configure each axis
+ to achieve a specified style. */
+
+ desc->instances = make_vector (fvar->instance_count, Qnil);
+
+ for (i = 0; i < fvar->instance_count; ++i)
+ {
+ style1 = sfnt_decode_instance_name (&fvar->instance[i],
+ name);
+
+ if (NILP (style1))
+ continue;
+
+ /* Now parse the style. */
+ temp.adstyle = Qnil;
+ sfnt_parse_style (style1, &temp);
+
+ /* Set each field of the vector. */
+ instance = make_vector (5, Qnil);
+ ASET (instance, 0, style1);
+ ASET (instance, 1, temp.adstyle);
+ ASET (instance, 2, make_fixnum (temp.width));
+ ASET (instance, 3, make_fixnum (temp.weight));
+ ASET (instance, 4, make_fixnum (temp.slant));
+
+ /* Place the vector in desc->instances. */
+ ASET (desc->instances, i, instance);
+ }
+ }
+
+ /* Set the style, link the desc onto system_fonts and return. */
+ desc->style = style;
+ desc->next = system_fonts;
+ system_fonts = desc;
+
+ /* Remove any fonts which have the same style as this one. For
+ distortable fonts, only remove overlapping styles, unless this is
+ also a distortable font. */
+
+ next = &system_fonts->next;
+ prev = *next;
+ for (; *next; prev = *next)
+ {
+ if (sfnt_replace_fonts_p (prev, desc))
+ {
+ *next = prev->next;
+ xfree (prev);
+ }
+ else
+ next = &prev->next;
+ }
+
+ xfree (fvar);
+ xfree (meta);
+ xfree (maxp);
+ xfree (name);
+ xfree (head);
+ return 0;
+
+ bail4:
+ xfree (meta);
+ xfree (maxp);
+ bail3:
+ xfree (name);
+ bail2:
+ xfree (head);
+ bail1:
+ xfree (desc);
+ return 1;
+}
+
+/* Enumerate the font FILE into the list of system fonts. Return 1 if
+ it could not be enumerated, 0 otherwise.
+
+ Remove any font whose family and style is a duplicate of this one.
+
+ FILE can either be a TrueType collection file containing TrueType
+ fonts, or a TrueType font itself. */
+
+int
+sfnt_enum_font (const char *file)
+{
+ int fd;
+ int rc;
+ off_t seek;
+ struct sfnt_offset_subtable *subtables;
+ struct sfnt_ttc_header *ttc;
+ size_t i;
+
+ /* Now open the font for reading. */
+ fd = emacs_open (file, O_RDONLY, 0);
+
+ if (fd == -1)
+ goto bail;
+
+ /* Read the table directory. */
+ subtables = sfnt_read_table_directory (fd);
+
+ if (subtables == (struct sfnt_offset_subtable *) -1)
+ {
+ /* This is actually a TrueType container file. Go back to the
+ beginning and read the TTC header. */
+
+ if (lseek (fd, 0, SEEK_SET))
+ goto bail0;
+
+ ttc = sfnt_read_ttc_header (fd);
+
+ if (!ttc)
+ goto bail0;
+
+ /* Enumerate each of the fonts in the collection. */
+
+ for (i = 0; i < ttc->num_fonts; ++i)
+ {
+ seek = lseek (fd, ttc->offset_table[i], SEEK_SET);
+
+ if (seek == -1 || seek != ttc->offset_table[i])
+ continue;
+
+ subtables = sfnt_read_table_directory (fd);
+
+ if (!subtables
+ /* This value means that FD was pointing at a TTC
+ header. Since FD should already have been moved to
+ the beginning of the TrueType header above, it
+ follows that the font format is invalid. */
+ || (subtables == (struct sfnt_offset_subtable *) -1))
+ continue;
+
+ sfnt_enum_font_1 (fd, file, subtables,
+ ttc->offset_table[i]);
+ xfree (subtables);
+ }
+
+ /* Always treat reading containers as having been
+ successful. */
+
+ emacs_close (fd);
+ xfree (ttc);
+ return 0;
+ }
+
+ if (!subtables)
+ goto bail0;
+
+ /* Now actually enumerate this font. */
+ rc = sfnt_enum_font_1 (fd, file, subtables, 0);
+ xfree (subtables);
+ emacs_close (fd);
+ return rc;
+
+ bail0:
+ emacs_close (fd);
+ bail:
+ return 1;
+}
+
+
+
+/* Font discovery and matching. */
+
+static struct charset *
+sfntfont_charset_for_name (Lisp_Object symbol)
+{
+ ptrdiff_t idx;
+ int id;
+
+ idx = CHARSET_SYMBOL_HASH_INDEX (symbol);
+
+ if (idx == -1)
+ return NULL;
+
+ /* Vcharset_hash_table is not a real variable, so Lisp programs
+ can't clobber it. */
+ id = XFIXNUM (AREF (HASH_VALUE (XHASH_TABLE (Vcharset_hash_table),
+ idx),
+ charset_id));
+
+ return CHARSET_FROM_ID (id);
+}
+
+/* Return the character set corresponding to a cmap subtable SUBTABLE.
+ Value is NULL if the subtable is not supported. */
+
+static struct charset *
+sfntfont_charset_for_cmap (struct sfnt_cmap_encoding_subtable subtable)
+{
+ switch (subtable.platform_id)
+ {
+ case SFNT_PLATFORM_UNICODE:
+ /* Reject variation selector and last resort tables. */
+ if ((subtable.platform_specific_id
+ == SFNT_UNICODE_VARIATION_SEQUENCES)
+ || (subtable.platform_specific_id
+ == SFNT_UNICODE_LAST_RESORT))
+ return NULL;
+
+ /* 1.0, 1.1, ISO-10646-1993, and 2.0_BMP tables are all within
+ the BMP. */
+ if (subtable.platform_specific_id < SFNT_UNICODE_2_0)
+ return sfntfont_charset_for_name (Qunicode_bmp);
+
+ return sfntfont_charset_for_name (Qunicode);
+
+ case SFNT_PLATFORM_MACINTOSH:
+
+ switch (subtable.platform_specific_id)
+ {
+ case SFNT_MACINTOSH_ROMAN:
+ return sfntfont_charset_for_name (Qmac_roman);
+
+ default:
+ /* Some other Macintosh charset not supported by Emacs. */
+ return NULL;
+ }
+
+ case SFNT_PLATFORM_MICROSOFT:
+
+ /* Microsoft specific encodings. */
+
+ switch (subtable.platform_specific_id)
+ {
+ case SFNT_MICROSOFT_SYMBOL:
+ /* Symbols in the Unicode PUA are still Unicode. */
+ return sfntfont_charset_for_name (Qunicode);
+
+ case SFNT_MICROSOFT_UNICODE_BMP:
+ return sfntfont_charset_for_name (Qunicode_bmp);
+
+ case SFNT_MICROSOFT_SHIFT_JIS:
+ /* PCK aka japanese-jisx0208. */
+ return sfntfont_charset_for_name (Qjapanese_jisx0208);
+
+ case SFNT_MICROSOFT_PRC:
+ /* GBK, GB2312 or GB18030. */
+ return sfntfont_charset_for_name (Qgbk);
+
+ case SFNT_MICROSOFT_JOHAB:
+ /* KS C 5601-1992, aka korean-ksc5601. */
+ return sfntfont_charset_for_name (Qkorean_ksc5601);
+
+ case SFNT_MICROSOFT_UNICODE_UCS_4:
+ /* Unicode past the BMP. */
+ return sfntfont_charset_for_name (Qucs);
+ }
+
+ default:
+ return NULL;
+ }
+}
+
+/* Pick the best character map in the cmap table CMAP. Use the
+ subtables in SUBTABLES and DATA. Return the subtable data and the
+ subtable in *SUBTABLE upon success, NULL otherwise.
+
+ If FORMAT14 is non-NULL, return any associated format 14 variation
+ selection context in *FORMAT14 should the selected character map be
+ a Unicode character map. */
+
+static struct sfnt_cmap_encoding_subtable_data *
+sfntfont_select_cmap (struct sfnt_cmap_table *cmap,
+ struct sfnt_cmap_encoding_subtable *subtables,
+ struct sfnt_cmap_encoding_subtable_data **data,
+ struct sfnt_cmap_encoding_subtable *subtable,
+ struct sfnt_cmap_format_14 **format14)
+{
+ int i, j;
+
+ /* First look for a non-BMP Unicode cmap. */
+
+ for (i = 0; i < cmap->num_subtables; ++i)
+ {
+ if (data[i] && sfntfont_identify_cmap (subtables[i]) == 2)
+ {
+ *subtable = subtables[i];
+
+ if (!format14)
+ return data[i];
+
+ /* Search for a corresponding format 14 character map.
+ This is used in conjunction with the selected character
+ map to map variation sequences. */
+
+ for (j = 0; j < cmap->num_subtables; ++j)
+ {
+ if (data[j]
+ && subtables[j].platform_id == SFNT_PLATFORM_UNICODE
+ && (subtables[j].platform_specific_id
+ == SFNT_UNICODE_VARIATION_SEQUENCES)
+ && data[j]->format == 14)
+ *format14 = (struct sfnt_cmap_format_14 *) data[j];
+ }
+
+ return data[i];
+ }
+ }
+
+ /* Next, look for a BMP only Unicode cmap. */
+
+ for (i = 0; i < cmap->num_subtables; ++i)
+ {
+ if (data[i] && sfntfont_identify_cmap (subtables[i]) == 1)
+ {
+ *subtable = subtables[i];
+
+ if (!format14)
+ return data[i];
+
+ /* Search for a corresponding format 14 character map.
+ This is used in conjunction with the selected character
+ map to map variation sequences. */
+
+ for (j = 0; j < cmap->num_subtables; ++j)
+ {
+ if (data[j]
+ && subtables[j].platform_id == SFNT_PLATFORM_UNICODE
+ && (subtables[j].platform_specific_id
+ == SFNT_UNICODE_VARIATION_SEQUENCES)
+ && data[j]->format == 14)
+ *format14 = (struct sfnt_cmap_format_14 *) data[j];
+ }
+
+ return data[i];
+ }
+ }
+
+ /* Finally, use the first cmap that appears and can be
+ identified. */
+
+ for (i = 0; i < cmap->num_subtables; ++i)
+ {
+ if (data[i] && sfntfont_identify_cmap (subtables[i]) == 0)
+ {
+ *subtable = subtables[i];
+ return data[i];
+ }
+ }
+
+ /* There are no cmaps available to Emacs. */
+ return NULL;
+}
+
+/* Read the cmap from the font descriptor DESC, and place it in CMAP.
+ Keep *CMAP untouched if opening the cmap fails. Set SUBTABLE to
+ the cmap's header upon success. */
+
+static void
+sfntfont_read_cmap (struct sfnt_font_desc *desc,
+ struct sfnt_cmap_encoding_subtable_data **cmap,
+ struct sfnt_cmap_encoding_subtable *subtable)
+{
+ struct sfnt_offset_subtable *font;
+ struct sfnt_cmap_encoding_subtable *subtables;
+ struct sfnt_cmap_encoding_subtable_data **data;
+ struct sfnt_cmap_table *table;
+ int fd, i;
+
+ /* Pick a character map and place it in *CMAP. */
+ fd = emacs_open (desc->path, O_RDONLY, 0);
+
+ if (fd < 0)
+ return;
+
+ /* Seek to the start of the font itself within its collection. */
+
+ if (desc->offset
+ && lseek (fd, desc->offset, SEEK_SET) != desc->offset)
+ {
+ emacs_close (fd);
+ return;
+ }
+
+ font = sfnt_read_table_directory (fd);
+
+ /* Return if FONT is a TrueType collection: the file pointer should
+ already have been moved to the start of the table directory if
+ so. */
+
+ if (!font || (font == (struct sfnt_offset_subtable *) -1))
+ {
+ emacs_close (fd);
+ return;
+ }
+
+ table = sfnt_read_cmap_table (fd, font, &subtables,
+ &data);
+ xfree (font);
+
+ if (!table)
+ {
+ emacs_close (fd);
+ return;
+ }
+
+ /* Now pick the best character map. */
+
+ *cmap = sfntfont_select_cmap (table, subtables, data,
+ subtable, NULL);
+
+ /* Free the cmap data. */
+
+ for (i = 0; i < table->num_subtables; ++i)
+ {
+ if (data[i] != *cmap)
+ xfree (data[i]);
+ }
+
+ xfree (data);
+ xfree (subtables);
+ xfree (table);
+ emacs_close (fd);
+}
+
+/* Return whether or not CHARACTER has an associated mapping in CMAP,
+ and the mapping points to a valid glyph. DESC is the font
+ descriptor associated with the font. */
+
+static bool
+sfntfont_glyph_valid (struct sfnt_font_desc *desc,
+ sfnt_char font_character,
+ struct sfnt_cmap_encoding_subtable_data *cmap)
+{
+ sfnt_glyph glyph;
+
+ glyph = sfnt_lookup_glyph (font_character, cmap);
+
+ if (!glyph)
+ return false;
+
+ return glyph <= desc->num_glyphs;
+}
+
+/* Look up a character CHARACTER in the font description DESC. Cache
+ the results. Return true if the character exists, false otherwise.
+
+ If *CMAP is NULL, select a character map for the font and save it
+ there. Otherwise, use the character map in *CMAP. Save data
+ associated with the character map in *SUBTABLE. */
+
+static bool
+sfntfont_lookup_char (struct sfnt_font_desc *desc, Lisp_Object character,
+ struct sfnt_cmap_encoding_subtable_data **cmap,
+ struct sfnt_cmap_encoding_subtable *subtable)
+{
+ Lisp_Object cached;
+ sfnt_char font_character;
+ struct charset *charset;
+ bool present;
+
+ /* Return false for characters that don't fit in a char table. */
+ if (XFIXNUM (character) > INT_MAX || XFIXNUM (character) < 0)
+ return false;
+
+ if (!NILP (desc->char_cache))
+ {
+ cached = char_table_ref (desc->char_cache,
+ XFIXNUM (character));
+ if (!NILP (cached))
+ return (EQ (cached, Qlambda) ? false : true);
+ }
+
+ if (!*cmap && !desc->cmap_invalid)
+ sfntfont_read_cmap (desc, cmap, subtable);
+
+ /* Check that a cmap is now present. */
+ if (!*cmap)
+ {
+ /* Opening the cmap failed. Set desc->cmap_invalid to avoid
+ opening it again. */
+ desc->cmap_invalid = true;
+ return false;
+ }
+
+ /* Otherwise, encode the character. */
+
+ charset = sfntfont_charset_for_cmap (*subtable);
+ if (!charset)
+ /* Emacs missing charsets? */
+ return false;
+
+ font_character = ENCODE_CHAR (charset, (int) XFIXNUM (character));
+
+ if (font_character == CHARSET_INVALID_CODE (charset))
+ return false;
+
+ /* Now return whether or not the glyph is present. Noto Sans
+ Georgian comes with a corrupt format 4 cmap table that somehow
+ tries to express glyphs greater than 65565. */
+ present = sfntfont_glyph_valid (desc, font_character, *cmap);
+
+ /* Cache the result. Store Qlambda when not present, Qt
+ otherwise. */
+
+ if (NILP (desc->char_cache))
+ desc->char_cache = Fmake_char_table (Qfont_lookup_cache,
+ Qnil);
+
+ Fset_char_table_range (desc->char_cache, character,
+ present ? Qt : Qlambda);
+ return present;
+}
+
+/* Return whether or not the specified registry A is ``compatible''
+ with registry B.
+
+ Compatibility does not refer to whether or not the font registries
+ have an identical character set or repertory of characters.
+
+ Instead, it refers to whether or not Emacs expects looking for A to
+ result in fonts used with B. */
+
+static bool
+sfntfont_registries_compatible_p (Lisp_Object a, Lisp_Object b)
+{
+ if (EQ (a, Qiso8859_1) && EQ (b, Qiso10646_1))
+ return true;
+
+ return EQ (a, b);
+}
+
+/* Return whether or not the font description DESC satisfactorily
+ matches the font specification FONT_SPEC.
+
+ Value is 0 if there is no match, -1 if there is a match against
+ DESC itself, and the number of matching instances if the style
+ matches one or more instances defined in in DESC. Return the index
+ of each matching instance in INSTANCES; it should be SIZE big. */
+
+static int
+sfntfont_list_1 (struct sfnt_font_desc *desc, Lisp_Object spec,
+ int *instances, int size)
+{
+ Lisp_Object tem, extra, tail;
+ struct sfnt_cmap_encoding_subtable_data *cmap;
+ size_t i;
+ struct sfnt_cmap_encoding_subtable subtable;
+ int instance, num_instance;
+ Lisp_Object item;
+
+ /* cmap and subtable are caches for sfntfont_lookup_char. */
+
+ /* Check that the family name in SPEC matches DESC->family if it is
+ specified. */
+
+ tem = AREF (spec, FONT_FAMILY_INDEX);
+
+ /* If TEM is a family listed in Vsfnt_default_family_alist,
+ then use that instead. */
+
+ if (SYMBOLP (tem) && CONSP (Vsfnt_default_family_alist))
+ {
+ tail = Vsfnt_default_family_alist;
+ FOR_EACH_TAIL_SAFE (tail)
+ {
+ if (!CONSP (XCAR (tail)))
+ continue;
+
+ if (STRINGP (XCAR (XCAR (tail)))
+ && STRINGP (XCDR (XCAR (tail)))
+ && !NILP (Fstring_equal (SYMBOL_NAME (tem),
+ XCAR (XCAR (tail)))))
+ {
+ /* Special family found. */
+ tem = Fintern (XCDR (XCAR (tail)), Qnil);
+ break;
+ }
+ }
+ }
+
+ if (!NILP (tem) && NILP (Fstring_equal (SYMBOL_NAME (tem),
+ desc->family)))
+ return 0;
+
+ instance = -1;
+
+ /* If a registry is set and wrong, then reject the font desc
+ immediately. This detects 50% of mismatches from fontset.c.
+
+ If DESC->registry is nil, then the registry couldn't be
+ determined beforehand. */
+
+ tem = AREF (spec, FONT_REGISTRY_INDEX);
+ if (!NILP (tem) && !NILP (desc->registry)
+ && !sfntfont_registries_compatible_p (tem, desc->registry))
+ return 0;
+
+ /* If the font spacings disagree, reject this font also. */
+
+ tem = AREF (spec, FONT_SPACING_INDEX);
+ if (FIXNUMP (tem) && (XFIXNUM (tem) != desc->spacing))
+ return 0;
+
+ /* Check the style. If DESC is a fixed font, just check once.
+ Otherwise, check each instance. */
+
+ if (NILP (desc->instances))
+ {
+ tem = AREF (spec, FONT_ADSTYLE_INDEX);
+ if (!NILP (tem) && !EQ (tem, desc->adstyle))
+ return 0;
+
+ if (FONT_WIDTH_NUMERIC (spec) != -1
+ && FONT_WIDTH_NUMERIC (spec) != desc->width)
+ return 0;
+
+ if (FONT_WEIGHT_NUMERIC (spec) != -1
+ && FONT_WEIGHT_NUMERIC (spec) != desc->weight)
+ return 0;
+
+ if (FONT_SLANT_NUMERIC (spec) != -1
+ && FONT_SLANT_NUMERIC (spec) != desc->slant)
+ return 0;
+ }
+ else
+ {
+ num_instance = 0;
+
+ /* Find the indices of instances in this distortable font which
+ match the given font spec. */
+
+ for (i = 0; i < ASIZE (desc->instances); ++i)
+ {
+ item = AREF (desc->instances, i);
+
+ if (NILP (item))
+ continue;
+
+ /* Check that the adstyle specified matches. */
+
+ tem = AREF (spec, FONT_ADSTYLE_INDEX);
+ if (!NILP (tem) && NILP (Fequal (tem, AREF (item, 1))))
+ continue;
+
+ /* Check the style. */
+
+ if (FONT_WIDTH_NUMERIC (spec) != -1
+ && (FONT_WIDTH_NUMERIC (spec)
+ != XFIXNUM (AREF (item, 2))))
+ continue;
+
+ if (FONT_WEIGHT_NUMERIC (spec) != -1
+ && (FONT_WEIGHT_NUMERIC (spec)
+ != XFIXNUM (AREF (item, 3))))
+ continue;
+
+ if (FONT_SLANT_NUMERIC (spec) != -1
+ && (FONT_SLANT_NUMERIC (spec)
+ != XFIXNUM (AREF (item, 4))))
+ continue;
+
+ if (num_instance == size)
+ break;
+
+ /* A matching instance has been found. Set its index, then
+ go back to the rest of the font matching. */
+ instances[num_instance++] = i;
+ }
+
+ instance = num_instance;
+ }
+
+ /* Handle extras. */
+ extra = AREF (spec, FONT_EXTRA_INDEX);
+
+ if (NILP (extra))
+ return instance;
+
+ tem = assq_no_quit (QCscript, extra);
+ cmap = NULL;
+
+ if (!NILP (tem))
+ {
+ /* If a script has been specified, look up its representative
+ characters and see if they are present in the font. This
+ requires reading the cmap. */
+ tem = assq_no_quit (XCDR (tem), Vscript_representative_chars);
+
+ if (CONSP (tem) && VECTORP (XCDR (tem)))
+ {
+ tem = XCDR (tem);
+
+ /* The vector contains characters, of which one must be
+ present in the font. */
+ for (i = 0; i < ASIZE (tem); ++i)
+ {
+ if (FIXNUMP (AREF (tem, i)))
+ {
+ if (!sfntfont_lookup_char (desc, AREF (tem, i),
+ &cmap, &subtable))
+ goto fail;
+
+ /* One character is enough to pass a font. Don't
+ look at too many. */
+ break;
+ }
+ }
+ }
+ else if (CONSP (tem) && CONSP (XCDR (tem)))
+ {
+ tem = XCDR (tem);
+
+ /* tem is a list of each characters, all of which must be
+ present in the font. */
+ FOR_EACH_TAIL_SAFE (tem)
+ {
+ if (FIXNUMP (XCAR (tem))
+ && !sfntfont_lookup_char (desc, XCAR (tem), &cmap,
+ &subtable))
+ goto fail;
+ }
+
+ /* One or more characters are missing. */
+ if (!NILP (tem))
+ goto fail;
+ }
+ /* Fail if there are no matching fonts at all. */
+ else if (NILP (tem))
+ goto fail;
+ }
+
+ /* Now check that the language is supported. */
+ tem = assq_no_quit (QClang, extra);
+ if (!NILP (tem) && NILP (Fmemq (tem, desc->languages)))
+ goto fail;
+
+ /* Set desc->subtable if cmap was specified. */
+ if (cmap)
+ desc->subtable = subtable;
+
+ xfree (cmap);
+ return instance;
+
+ fail:
+ /* The cmap might've been read in and require deallocation. */
+ xfree (cmap);
+ return 0;
+}
+
+/* Type of font entities and font objects created. */
+static Lisp_Object sfnt_vendor_name;
+
+/* Font driver used in font objects created. */
+static const struct font_driver *sfnt_font_driver;
+
+/* Return the font registry corresponding to the font descriptor DESC.
+ Under X, the font registry is an atom registered with the Open
+ Group uniquely identifying the organization which defines the
+ font's character set.
+
+ In practice, the registry overlaps with the character set itself.
+ So Emacs just uses the ``registry'' field to represent both
+ instead. */
+
+static Lisp_Object
+sfntfont_registry_for_desc (struct sfnt_font_desc *desc)
+{
+ struct sfnt_cmap_encoding_subtable_data *cmap;
+
+ cmap = NULL;
+
+ if (desc->cmap_invalid)
+ return Qnil;
+
+ if (desc->subtable.platform_id == 500)
+ {
+ /* Read in the cmap to determine the registry. */
+ sfntfont_read_cmap (desc, &cmap, &desc->subtable);
+
+ if (!cmap)
+ {
+ desc->cmap_invalid = true;
+ return Qnil;
+ }
+ }
+
+ xfree (cmap);
+
+ if (desc->subtable.platform_id != 500)
+ /* desc->subtable.platform_id is now set. CMAP is already free,
+ because it is not actually used. */
+ return sfnt_registry_for_subtable (&desc->subtable);
+
+ return Qnil;
+}
+
+/* Return a font-entity that represents the font descriptor (unopened
+ font) DESC. If INSTANCE is more than or equal to 1, then it is the
+ index of the instance in DESC that should be opened plus 1; in that
+ case, DESC must be a distortable font. */
+
+static Lisp_Object
+sfntfont_desc_to_entity (struct sfnt_font_desc *desc, int instance)
+{
+ Lisp_Object entity, vector;
+
+ entity = font_make_entity ();
+
+ ASET (entity, FONT_TYPE_INDEX, sfnt_vendor_name);
+ ASET (entity, FONT_FOUNDRY_INDEX, desc->designer);
+ ASET (entity, FONT_FAMILY_INDEX, Fintern (desc->family, Qnil));
+ ASET (entity, FONT_ADSTYLE_INDEX, Qnil);
+ ASET (entity, FONT_REGISTRY_INDEX,
+ sfntfont_registry_for_desc (desc));
+
+ /* Size of 0 means the font is scalable. */
+ ASET (entity, FONT_SIZE_INDEX, make_fixnum (0));
+ ASET (entity, FONT_AVGWIDTH_INDEX, make_fixnum (0));
+ ASET (entity, FONT_SPACING_INDEX, make_fixnum (desc->spacing));
+
+ if (instance >= 1)
+ {
+ if (NILP (desc->instances)
+ || instance > ASIZE (desc->instances))
+ emacs_abort ();
+
+ vector = AREF (desc->instances, instance - 1);
+ FONT_SET_STYLE (entity, FONT_WIDTH_INDEX,
+ AREF (vector, 2));
+ FONT_SET_STYLE (entity, FONT_WEIGHT_INDEX,
+ AREF (vector, 3));
+ FONT_SET_STYLE (entity, FONT_SLANT_INDEX,
+ AREF (vector, 4));
+ ASET (entity, FONT_ADSTYLE_INDEX, AREF (vector, 1));
+ }
+ else
+ {
+ FONT_SET_STYLE (entity, FONT_WIDTH_INDEX,
+ make_fixnum (desc->width));
+ FONT_SET_STYLE (entity, FONT_WEIGHT_INDEX,
+ make_fixnum (desc->weight));
+ FONT_SET_STYLE (entity, FONT_SLANT_INDEX,
+ make_fixnum (desc->slant));
+ ASET (entity, FONT_ADSTYLE_INDEX, desc->adstyle);
+ }
+
+ /* Set FONT_EXTRA_INDEX to a pointer to the font description. Font
+ descriptions are never supposed to be freed. */
+
+ ASET (entity, FONT_EXTRA_INDEX,
+ (instance >= 1
+ ? list2 (Fcons (Qfont_entity, make_mint_ptr (desc)),
+ Fcons (Qfont_instance, make_fixnum (instance - 1)))
+ : list1 (Fcons (Qfont_entity, make_mint_ptr (desc)))));
+
+ return entity;
+}
+
+/* Return whether fewer fields inside the font entity A are set than
+ there are set inside the font entity B. */
+
+static Lisp_Object
+sfntfont_compare_font_entities (Lisp_Object a, Lisp_Object b)
+{
+ ptrdiff_t count_a, count_b, i;
+
+ count_a = 0;
+ count_b = 0;
+
+ for (i = 0; i < FONT_ENTITY_MAX; ++i)
+ {
+ if (!NILP (AREF (a, i)))
+ count_a++;
+ }
+
+ for (i = 0; i < FONT_ENTITY_MAX; ++i)
+ {
+ if (!NILP (AREF (b, i)))
+ count_b++;
+ }
+
+ return count_a < count_b ? Qt : Qnil;
+}
+
+/* Function that compares two font entities to return whether fewer
+ fields are set within the first than in the second. */
+
+static union Aligned_Lisp_Subr Scompare_font_entities =
+ {
+ {
+ { PSEUDOVECTOR_FLAG | (PVEC_SUBR << PSEUDOVECTOR_AREA_BITS), },
+ { .a2 = sfntfont_compare_font_entities, },
+ 2, 2, "sfntfont_compare_font_entities", {0}, lisp_h_Qnil,
+ },
+ };
+
+/* Return a list of font-entities matching the specified
+ FONT_SPEC. */
+
+Lisp_Object
+sfntfont_list (struct frame *f, Lisp_Object font_spec)
+{
+ Lisp_Object matching, tem, compare_font_entities;
+ struct sfnt_font_desc *desc;
+ int i, rc, instances[100];
+
+ matching = 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. */
+ tem = assq_no_quit (QCotf, AREF (font_spec, FONT_EXTRA_INDEX));
+ if (CONSP (tem) && !NILP (XCDR (tem)))
+ {
+ unblock_input ();
+ return Qnil;
+ }
+
+ /* Loop through known system fonts and add them one-by-one. */
+
+ for (desc = system_fonts; desc; desc = desc->next)
+ {
+ rc = sfntfont_list_1 (desc, font_spec, instances,
+ ARRAYELTS (instances));
+
+ if (rc < 0)
+ matching = Fcons (sfntfont_desc_to_entity (desc, 0),
+ matching);
+ else if (rc)
+ {
+ /* Add each matching instance. */
+
+ for (i = 0; i < rc; ++i)
+ matching = Fcons (sfntfont_desc_to_entity (desc,
+ instances[i] + 1),
+ matching);
+ }
+ }
+ unblock_input ();
+
+ /* Sort matching by the number of fields set inside each element, so
+ that values of FONT_SPECs that leave a number of fields
+ unspecified will yield a list with the closest matches (that is
+ to say, those whose fields are precisely as specified by the
+ caller) ordered first. */
+
+ XSETSUBR (compare_font_entities, &Scompare_font_entities.s);
+ matching = CALLN (Fsort, matching, compare_font_entities);
+ return matching;
+}
+
+/* Return the first font-entity matching the specified FONT_SPEC. */
+
+Lisp_Object
+sfntfont_match (struct frame *f, Lisp_Object font_spec)
+{
+ Lisp_Object matches;
+
+ matches = sfntfont_list (f, font_spec);
+
+ if (!NILP (matches))
+ return XCAR (matches);
+
+ return Qnil;
+}
+
+
+
+enum
+ {
+ SFNT_OUTLINE_CACHE_SIZE = 256,
+ SFNT_RASTER_CACHE_SIZE = 128,
+ };
+
+/* Caching subsystem. Generating outlines from glyphs is expensive,
+ and so is rasterizing them, so two caches are maintained for both
+ glyph outlines and rasters.
+
+ Computing metrics also requires some expensive processing if the
+ glyph has instructions or distortions. */
+
+struct sfnt_outline_cache
+{
+ /* Next and last cache buckets. */
+ struct sfnt_outline_cache *next, *last;
+
+ /* Pointer to outline. */
+ struct sfnt_glyph_outline *outline;
+
+ /* Reference to glyph metrics. */
+ struct sfnt_glyph_metrics metrics;
+
+ /* What glyph this caches. */
+ sfnt_glyph glyph;
+};
+
+struct sfnt_raster_cache
+{
+ /* Next and last cache buckets. */
+ struct sfnt_raster_cache *next, *last;
+
+ /* Pointer to raster. */
+ struct sfnt_raster *raster;
+
+ /* What glyph this caches. */
+ sfnt_glyph glyph;
+};
+
+struct sfntfont_get_glyph_outline_dcontext
+{
+ /* Long and short loca tables. */
+ struct sfnt_loca_table_long *loca_long;
+ struct sfnt_loca_table_short *loca_short;
+
+ /* glyf table. */
+ struct sfnt_glyf_table *glyf;
+
+ /* hmtx, hhea and maxp tables utilized to acquire glyph metrics. */
+ struct sfnt_hmtx_table *hmtx;
+ struct sfnt_hhea_table *hhea;
+ struct sfnt_maxp_table *maxp;
+
+ /* Variation settings, or NULL. */
+ struct sfnt_blend *blend;
+};
+
+/* Return the glyph identified by GLYPH_ID from the glyf and loca
+ table specified in DCONTEXT. Set *NEED_FREE to true. */
+
+static struct sfnt_glyph *
+sfntfont_get_glyph (sfnt_glyph glyph_id, void *dcontext,
+ bool *need_free)
+{
+ struct sfntfont_get_glyph_outline_dcontext *tables;
+ struct sfnt_glyph *glyph;
+ struct sfnt_metrics_distortion distortion;
+
+ tables = dcontext;
+ *need_free = true;
+
+ glyph = sfnt_read_glyph (glyph_id, tables->glyf,
+ tables->loca_short,
+ tables->loca_long);
+
+ if (tables->blend && glyph)
+ {
+ if (glyph->simple)
+ sfnt_vary_simple_glyph (tables->blend, glyph_id, glyph,
+ &distortion);
+ else
+ sfnt_vary_compound_glyph (tables->blend, glyph_id, glyph,
+ &distortion);
+ }
+
+ /* Note that the distortion is not relevant for compound glyphs. */
+ return glyph;
+}
+
+/* Free the glyph identified by GLYPH. */
+
+static void
+sfntfont_free_glyph (struct sfnt_glyph *glyph, void *dcontext)
+{
+ sfnt_free_glyph (glyph);
+}
+
+/* Return unscaled glyph metrics for the glyph designated by the ID
+ GLYPH within *METRICS, utilizing tables within DCONTEXT.
+
+ Value is 1 upon failure, 0 otherwise. */
+
+static int
+sfntfont_get_metrics (sfnt_glyph glyph, struct sfnt_glyph_metrics *metrics,
+ void *dcontext)
+{
+ struct sfntfont_get_glyph_outline_dcontext *tables;
+
+ tables = dcontext;
+ return sfnt_lookup_glyph_metrics (glyph, metrics, tables->hmtx,
+ tables->hhea, tables->maxp);
+}
+
+/* Dereference the outline OUTLINE. Free it once refcount reaches
+ 0. */
+
+static void
+sfntfont_dereference_outline (struct sfnt_glyph_outline *outline)
+{
+ eassert (outline->refcount > 0);
+
+ if (--outline->refcount)
+ return;
+
+ xfree (outline);
+}
+
+/* Get the outline corresponding to the specified GLYPH_CODE in CACHE.
+ Use the scale factor SCALE, the glyf table GLYF, and the head table
+ HEAD. Keep *CACHE_SIZE updated with the number of elements in the
+ cache.
+
+ Distort the glyph using BLEND if INDEX is not -1.
+
+ Use the offset information in the long or short loca tables
+ LOCA_LONG and LOCA_SHORT, whichever is set.
+
+ Use the specified HMTX, HEAD, HHEA and MAXP tables when instructing
+ compound glyphs.
+
+ If INTERPRETER is non-NULL, then possibly use it and the
+ interpreter graphics STATE to instruct the glyph.
+
+ If METRICS is non-NULL, return the scaled glyph metrics after
+ variation and instructing.
+
+ Return the outline with an incremented reference count and enter
+ the generated outline into CACHE upon success, possibly discarding
+ any older outlines, or NULL on failure. */
+
+static struct sfnt_glyph_outline *
+sfntfont_get_glyph_outline (sfnt_glyph glyph_code,
+ struct sfnt_outline_cache *cache,
+ sfnt_fixed scale, int *cache_size,
+ struct sfnt_blend *blend,
+ int index,
+ struct sfnt_glyf_table *glyf,
+ struct sfnt_head_table *head,
+ struct sfnt_hmtx_table *hmtx,
+ struct sfnt_hhea_table *hhea,
+ struct sfnt_maxp_table *maxp,
+ struct sfnt_loca_table_short *loca_short,
+ struct sfnt_loca_table_long *loca_long,
+ struct sfnt_interpreter *interpreter,
+ struct sfnt_glyph_metrics *metrics,
+ struct sfnt_graphics_state *state)
+{
+ struct sfnt_outline_cache *start;
+ struct sfnt_glyph_outline *outline;
+ struct sfnt_glyph *glyph;
+ struct sfntfont_get_glyph_outline_dcontext dcontext;
+ struct sfnt_instructed_outline *value;
+ const char *error;
+ struct sfnt_glyph_metrics temp;
+ struct sfnt_metrics_distortion distortion;
+ sfnt_fixed advance;
+
+ start = cache->next;
+ distortion.advance = 0;
+
+ /* See if the outline is already cached. */
+ for (; start != cache; start = start->next)
+ {
+ if (start->glyph == glyph_code)
+ {
+ /* Move start to the start of the ring. Then increase
+ start->outline->refcount and return it. */
+
+ start->last->next = start->next;
+ start->next->last = start->last;
+
+ start->next = cache->next;
+ start->last = cache;
+ start->next->last = start;
+ start->last->next = start;
+ start->outline->refcount++;
+
+ if (metrics)
+ *metrics = start->metrics;
+
+ return start->outline;
+ }
+ }
+
+ /* Not already cached. Get the glyph. */
+ glyph = sfnt_read_glyph (glyph_code, glyf,
+ loca_short, loca_long);
+
+ if (!glyph)
+ return NULL;
+
+ /* Distort the glyph if necessary. */
+
+ if (index != -1)
+ {
+ if (glyph->simple)
+ {
+ if (sfnt_vary_simple_glyph (blend, glyph_code,
+ glyph, &distortion))
+ {
+ sfnt_free_glyph (glyph);
+ return NULL;
+ }
+ }
+ else if (sfnt_vary_compound_glyph (blend, glyph_code,
+ glyph, &distortion))
+ {
+ sfnt_free_glyph (glyph);
+ return NULL;
+ }
+ }
+
+ /* Try to instruct the glyph if INTERPRETER is specified. */
+
+ outline = NULL;
+
+ dcontext.loca_long = loca_long;
+ dcontext.loca_short = loca_short;
+ dcontext.glyf = glyf;
+ dcontext.hhea = hhea;
+ dcontext.hmtx = hmtx;
+ dcontext.maxp = maxp;
+ dcontext.blend = (index != -1 ? blend : NULL);
+
+ /* Now load the glyph's unscaled metrics into TEMP. */
+
+ if (sfnt_lookup_glyph_metrics (glyph_code, &temp, hmtx, hhea, maxp))
+ goto fail;
+
+ if (interpreter)
+ {
+ if (glyph->simple)
+ {
+ /* Restore the interpreter state from the snapshot taken
+ after loading the preprogram. */
+ interpreter->state = *state;
+
+ error = sfnt_interpret_simple_glyph (glyph, interpreter,
+ &temp, &value);
+ }
+ else
+ /* Restoring the interpreter state is done by
+ sfnt_interpret_compound_glyph; all that must be done here
+ is to give the graphics state to that function. */
+ error = sfnt_interpret_compound_glyph (glyph, interpreter,
+ state,
+ sfntfont_get_glyph,
+ sfntfont_free_glyph,
+ hmtx, hhea, maxp,
+ &temp, &dcontext,
+ &value);
+
+ if (!error)
+ {
+ /* Now record the advance with that measured from the
+ phantom points within the instructed glyph outline, and
+ subsequently replace it once metrics are scaled. */
+
+ outline = sfnt_build_instructed_outline (value,
+ &advance);
+ xfree (value);
+
+ if (outline)
+ {
+ /* Save the new advance width. This advance width is
+ rounded again, as the instruction code executed might
+ have moved both phantom points such that they no
+ longer measure a fractional distance. */
+ temp.advance = SFNT_ROUND_FIXED (advance);
+
+ /* Finally, adjust the left side bearing of the glyph
+ metrics by the origin point of the outline, should a
+ transformation have been applied by either
+ instruction code or glyph variation. The left side
+ bearing is the distance from the origin point to the
+ left most point on the X axis. */
+ temp.lbearing
+ = SFNT_FLOOR_FIXED (outline->xmin - outline->origin);
+ }
+ }
+ }
+
+ if (!outline)
+ {
+ /* Build the outline. This will apply GX offsets within *GLYPH
+ to TEMP. */
+ outline = sfnt_build_glyph_outline (glyph, scale,
+ &temp,
+ sfntfont_get_glyph,
+ sfntfont_free_glyph,
+ sfntfont_get_metrics,
+ &dcontext);
+
+ /* At this point, the glyph metrics are unscaled. Scale them
+ up. If INTERPRETER is set, use the scale placed within. */
+ sfnt_scale_metrics (&temp, scale);
+ }
+
+ fail:
+
+ xfree (glyph);
+
+ if (!outline)
+ return NULL;
+
+ start = xmalloc (sizeof *start);
+ start->glyph = glyph_code;
+ start->outline = outline;
+ start->metrics = temp;
+
+ /* One reference goes to the cache. The second reference goes to
+ the caller. */
+ outline->refcount = 2;
+
+ /* Link start onto the cache. */
+ start->next = cache->next;
+ start->last = cache;
+ start->next->last = start;
+ start->last->next = start;
+
+ /* Update the cache size. */
+ (*cache_size)++;
+
+ /* Figure out if the least recently used element has to be
+ evicted. */
+ if (*cache_size > SFNT_OUTLINE_CACHE_SIZE)
+ {
+ start = cache->last;
+ eassert (start != cache);
+
+ /* Free the least recently used entry in the cache. */
+ start->last->next = start->next;
+ start->next->last = start->last;
+ sfntfont_dereference_outline (start->outline);
+ xfree (start);
+
+ (*cache_size)--;
+ }
+
+ /* Return the cached outline and metrics. */
+
+ if (metrics)
+ *metrics = temp;
+
+ return outline;
+}
+
+/* Free the outline cache referred to by CACHE. Dereference each
+ outline contained therein. */
+
+static void
+sfntfont_free_outline_cache (struct sfnt_outline_cache *cache)
+{
+ struct sfnt_outline_cache *next, *last;
+
+ /* Handle partly initialized fonts. */
+ if (!cache->next)
+ return;
+
+ for (next = cache->next; next != cache;)
+ {
+ last = next;
+ next = next->next;
+
+ sfntfont_dereference_outline (last->outline);
+ xfree (last);
+ }
+
+ cache->next = cache;
+ cache->last = cache;
+}
+
+/* Dereference the raster RASTER. Free it once refcount reaches
+ 0. */
+
+static void
+sfntfont_dereference_raster (struct sfnt_raster *raster)
+{
+ eassert (raster->refcount > 0);
+
+ if (--raster->refcount)
+ return;
+
+ xfree (raster);
+}
+
+/* Get the raster corresponding to the specified GLYPH_CODE in CACHE.
+ Use the outline named OUTLINE. Keep *CACHE_SIZE updated with the
+ number of elements in the cache. */
+
+static struct sfnt_raster *
+sfntfont_get_glyph_raster (sfnt_glyph glyph_code,
+ struct sfnt_raster_cache *cache,
+ struct sfnt_glyph_outline *outline,
+ int *cache_size)
+{
+ struct sfnt_raster_cache *start;
+ struct sfnt_raster *raster;
+
+ /* See if the raster is already cached. */
+ start = cache->next;
+
+ for (; start != cache; start = start->next)
+ {
+ if (start->glyph == glyph_code)
+ {
+ /* Move start to the start of the ring. Them, increase
+ start->raster->refcount and return it. */
+
+ start->last->next = start->next;
+ start->next->last = start->last;
+
+ start->next = cache->next;
+ start->last = cache;
+ start->next->last = start;
+ start->last->next = start;
+ start->raster->refcount++;
+
+ return start->raster;
+ }
+ }
+
+ /* Not already cached. Raster the outline. */
+
+ if (!sfnt_raster_glyphs_exactly)
+ raster = sfnt_raster_glyph_outline (outline);
+ else
+ raster = sfnt_raster_glyph_outline_exact (outline);
+
+ if (!raster)
+ return NULL;
+
+ start = xmalloc (sizeof *start);
+ start->glyph = glyph_code;
+ start->raster = raster;
+
+ /* One reference goes to the cache. The second reference goes to
+ the caller. */
+ raster->refcount = 2;
+
+ /* Link start onto the cache. */
+ start->next = cache->next;
+ start->last = cache;
+ start->next->last = start;
+ start->last->next = start;
+
+ /* Update the cache size. */
+ (*cache_size)++;
+
+ /* Figure out if the least recently used element has to be
+ evicted. */
+ if (*cache_size > SFNT_OUTLINE_CACHE_SIZE)
+ {
+ start = cache->last;
+ eassert (start != cache);
+
+ /* Free the least recently used entry in the cache. */
+ start->last->next = start->next;
+ start->next->last = start->last;
+ sfntfont_dereference_raster (start->raster);
+ xfree (start);
+
+ (*cache_size)--;
+ }
+
+ /* Return the cached raster. */
+ return raster;
+}
+
+/* Free the raster cache referred to by CACHE. Dereference each
+ raster contained therein. */
+
+static void
+sfntfont_free_raster_cache (struct sfnt_raster_cache *cache)
+{
+ struct sfnt_raster_cache *next, *last;
+
+ /* Handle partly initialized fonts. */
+ if (!cache->next)
+ return;
+
+ for (next = cache->next; next != cache;)
+ {
+ last = next;
+ next = next->next;
+
+ sfntfont_dereference_raster (last->raster);
+ xfree (last);
+ }
+
+ cache->next = cache;
+ cache->last = cache;
+}
+
+
+
+/* Opening fonts. */
+
+struct sfnt_font_info
+{
+ /* Parent font structure. */
+ struct font font;
+
+#ifdef HAVE_MMAP
+ /* The next font in this chain. */
+ struct sfnt_font_info *next;
+#endif /* HAVE_MMAP */
+
+ /* The font description used to create this font. Used to
+ dereference tables associated with this font. */
+ struct sfnt_font_desc *desc;
+
+ /* Various tables required to use the font. */
+ struct sfnt_cmap_table *cmap;
+ struct sfnt_hhea_table *hhea;
+ struct sfnt_maxp_table *maxp;
+ struct sfnt_head_table *head;
+ struct sfnt_hmtx_table *hmtx;
+ struct sfnt_glyf_table *glyf;
+ struct sfnt_loca_table_short *loca_short;
+ struct sfnt_loca_table_long *loca_long;
+ struct sfnt_prep_table *prep;
+ struct sfnt_fpgm_table *fpgm;
+ struct sfnt_cvt_table *cvt;
+
+ /* The selected character map. */
+ struct sfnt_cmap_encoding_subtable_data *cmap_data;
+
+ /* Data identifying that character map. */
+ struct sfnt_cmap_encoding_subtable cmap_subtable;
+
+ /* The UVS context. */
+ struct sfnt_uvs_context *uvs;
+
+ /* Outline cache. */
+ struct sfnt_outline_cache outline_cache;
+
+ /* Number of elements in the outline cache. */
+ int outline_cache_size;
+
+ /* Raster cache. */
+ struct sfnt_raster_cache raster_cache;
+
+ /* Number of elements in the raster cache. */
+ int raster_cache_size;
+
+ /* Interpreter for grid fitting (if enabled). */
+ struct sfnt_interpreter *interpreter;
+
+ /* Graphics state after the execution of the font and control value
+ programs. */
+ struct sfnt_graphics_state state;
+
+ /* Factor used to convert from em space to pixel space. */
+ sfnt_fixed scale;
+
+ /* The blend (configuration of this multiple master font). */
+ struct sfnt_blend blend;
+
+ /* The index of the named instance used to initialize BLEND.
+ -1 if BLEND is not initialized. */
+ int instance;
+
+#ifdef HAVE_MMAP
+ /* Whether or not the glyph table has been mmapped. */
+ bool glyf_table_mapped;
+#endif /* HAVE_MMAP */
+
+#ifdef HAVE_HARFBUZZ
+ /* HarfBuzz font object. */
+ hb_font_t *hb_font;
+
+ /* File descriptor associated with this font. */
+ int fd;
+
+ /* The table directory of the font file. */
+ struct sfnt_offset_subtable *directory;
+#endif /* HAVE_HARFBUZZ */
+};
+
+#ifdef HAVE_MMAP
+
+/* List of all open fonts. */
+
+static struct sfnt_font_info *open_fonts;
+
+#endif /* HAVE_MMAP */
+
+/* Look up the glyph corresponding to the character C in FONT. Return
+ 0 upon failure, and the glyph otherwise. */
+
+static sfnt_glyph
+sfntfont_lookup_glyph (struct sfnt_font_info *font_info, int c)
+{
+ struct charset *charset;
+ sfnt_char character;
+ sfnt_glyph glyph;
+
+ charset = CHARSET_FROM_ID (font_info->font.encoding_charset);
+
+ if (!charset)
+ return 0;
+
+ character = ENCODE_CHAR (charset, c);
+
+ if (character == CHARSET_INVALID_CODE (charset))
+ return 0;
+
+ /* Do the actual lookup with the encoded character. */
+ glyph = sfnt_lookup_glyph (character, font_info->cmap_data);
+
+ return glyph;
+}
+
+static int sfntfont_measure_pcm (struct sfnt_font_info *, sfnt_glyph,
+ struct font_metrics *);
+
+/* Probe and set FONT_INFO->font.average_width,
+ FONT_INFO->font.space_width, and FONT_INFO->font.min_width
+ according to the tables contained therein.
+
+ As this function generates outlines for all glyphs, outlines for
+ all ASCII characters will be entered into the outline cache as
+ well. */
+
+static void
+sfntfont_probe_widths (struct sfnt_font_info *font_info)
+{
+ int i, num_characters, total_width;
+ sfnt_glyph glyph;
+ struct font_metrics pcm;
+
+ num_characters = 0;
+ total_width = 0;
+
+ /* First set some reasonable default values. */
+ font_info->font.average_width = font_info->font.pixel_size;
+ font_info->font.space_width = font_info->font.pixel_size;
+ font_info->font.min_width = 1;
+
+ /* Next, loop through the common ASCII characters. Tally up their
+ advance widths and set space_width if necessary. */
+ for (i = 32; i < 127; ++i)
+ {
+ glyph = sfntfont_lookup_glyph (font_info, i);
+
+ if (!glyph)
+ continue;
+
+ /* Now look up the metrics of this glyph. Data from the metrics
+ table doesn't fit the bill, since variations and instruction
+ code is not applied to it. */
+ if (sfntfont_measure_pcm (font_info, glyph, &pcm))
+ continue;
+
+ /* Increase the number of characters. */
+ num_characters++;
+
+ /* Add the advance to total_width. */
+ total_width += pcm.width;
+
+ /* Update min_width if it hasn't been set yet or is wider. */
+ if (font_info->font.min_width == 1
+ || font_info->font.min_width > pcm.width)
+ font_info->font.min_width = pcm.width;
+
+ /* If i is the space character, set the space width. Make sure
+ to round this up. */
+ if (i == 32)
+ font_info->font.space_width = pcm.width;
+ }
+
+ /* Now, if characters were found, set average_width. */
+ if (num_characters)
+ font_info->font.average_width = total_width / num_characters;
+}
+
+/* Initialize the instruction interpreter for INFO. Load the font and
+ preprogram for the pixel size in INFO and its corresponding point
+ size POINT_SIZE. Use the FVAR table in DESC.
+
+ The font tables in INFO must already have been initialized.
+
+ Set INFO->interpreter upon success, and leave that field intact
+ otherwise. */
+
+static void
+sfntfont_setup_interpreter (struct sfnt_font_info *info,
+ struct sfnt_font_desc *desc,
+ int point_size)
+{
+ struct sfnt_cvt_table *cvt;
+ struct sfnt_fpgm_table *fpgm;
+ struct sfnt_prep_table *prep;
+ struct sfnt_interpreter *interpreter;
+ const char *error;
+ struct sfnt_graphics_state state;
+ Lisp_Object regexp;
+
+ /* If Vsfnt_uninstructable_family_regexp matches this font, then
+ return. */
+
+ regexp = Vsfnt_uninstructable_family_regexp;
+
+ if (STRINGP (regexp)
+ && (fast_string_match_ignore_case (regexp,
+ desc->family)
+ >= 0))
+ return;
+
+ /* Load the cvt, fpgm and prep already read. */
+
+ cvt = info->cvt ;
+ fpgm = info->fpgm;
+ prep = info->prep;
+
+ /* If both fpgm and prep are NULL, this font likely has no
+ instructions, so don't bother setting up the interpreter. */
+
+ if (!fpgm && !prep)
+ goto bail;
+
+ /* If the interpreter does not use the operand stack at all, it is
+ useless. In addition, some broken fonts specify some unnecessary
+ instructions in prep and set head->max_stack_elements to 0.
+
+ Don't create the interpreter in that case. */
+
+ if (!info->maxp->max_stack_elements)
+ goto bail;
+
+ /* Now, create the interpreter using the limits in info->maxp and
+ info->head. CVT can be NULL. */
+
+ interpreter = sfnt_make_interpreter (info->maxp, cvt, info->head,
+ desc->tables->fvar,
+ info->font.pixel_size,
+ point_size);
+
+ /* Bail if the interpreter couldn't be created. */
+ if (!interpreter)
+ goto bail;
+
+ if (fpgm)
+ {
+ /* Otherwise, evaluate the font and cvt programs.
+
+ FIXME: make sure infinite loops inside these programs
+ cannot lock up Emacs. */
+
+ error = sfnt_interpret_font_program (interpreter, fpgm);
+
+ if (error)
+ {
+ /* If an error occurs, log it to the *Messages* buffer. */
+ message_with_string ("While interpreting font program: %s",
+ build_string (error), true);
+ goto bail1;
+ }
+
+ /* Save the graphics state. */
+ state = interpreter->state;
+ }
+
+ if (prep)
+ {
+ /* This will overwrite state if the instruction control is set
+ appropriately. */
+ error = sfnt_interpret_control_value_program (interpreter, prep,
+ &state);
+
+ if (error)
+ {
+ /* If an error occurs, log it to the *Messages* buffer. */
+ message_with_string ("While interpreting preprogram: %s",
+ build_string (error), true);
+ goto bail1;
+ }
+ }
+
+ /* The interpreter has been properly set up. */
+ info->fpgm = fpgm;
+ info->prep = prep;
+ info->cvt = cvt;
+ info->state = state;
+ info->interpreter = interpreter;
+
+ return;
+
+ bail1:
+ xfree (interpreter);
+ bail:
+ return;
+}
+
+/* Free each of the tables opened by `sfnt_open_tables', and possibly
+ file descriptors as well. Then, free TABLES itself. */
+
+static void
+sfnt_close_tables (struct sfnt_font_tables *tables)
+{
+#ifdef HAVE_MMAP
+ int rc;
+#endif /* HAVE_MMAP */
+
+ xfree (tables->cmap);
+ xfree (tables->hhea);
+ xfree (tables->maxp);
+ xfree (tables->head);
+ xfree (tables->hmtx);
+#ifdef HAVE_MMAP
+ if (tables->glyf_table_mapped)
+ {
+ rc = sfnt_unmap_glyf_table (tables->glyf);
+
+ if (rc)
+ emacs_abort ();
+ }
+ else
+#endif /* HAVE_MMAP */
+ xfree (tables->glyf);
+ xfree (tables->loca_short);
+ xfree (tables->loca_long);
+ xfree (tables->prep);
+ xfree (tables->fpgm);
+ xfree (tables->cvt);
+ xfree (tables->fvar);
+ xfree (tables->avar);
+ xfree (tables->gvar);
+ xfree (tables->cvar);
+ xfree (tables->cmap_data);
+
+ if (tables->uvs)
+ sfnt_free_uvs_context (tables->uvs);
+
+#ifdef HAVE_HARFBUZZ
+ /* Close the font file. */
+
+ if (tables->fd != -1)
+ {
+ emacs_close (tables->fd);
+ tables->fd = -1;
+ }
+
+ /* Free its table directory. */
+ xfree (tables->directory);
+ tables->directory = NULL;
+#endif
+}
+
+/* Open font tables associated with the specified font description
+ DESC. Return the font tables, or NULL upon failure. */
+
+static struct sfnt_font_tables *
+sfnt_open_tables (struct sfnt_font_desc *desc)
+{
+ struct sfnt_font_tables *tables;
+ struct sfnt_offset_subtable *subtable;
+ int fd, i;
+#ifdef HAVE_MMAP
+ int rc;
+#endif /* HAVE_MMAP */
+ struct sfnt_cmap_encoding_subtable *subtables;
+ struct sfnt_cmap_encoding_subtable_data **data;
+ struct sfnt_cmap_format_14 *format14;
+
+ tables = xzalloc (sizeof *tables);
+
+ /* Open the font. */
+ fd = emacs_open (desc->path, O_RDONLY, 0);
+
+ if (fd == -1)
+ goto bail;
+
+ /* Seek to the offset specified to the table directory. */
+
+ if (desc->offset
+ && lseek (fd, desc->offset, SEEK_SET) != desc->offset)
+ goto bail;
+
+ /* Read the offset subtable. */
+ subtable = sfnt_read_table_directory (fd);
+
+ if (!subtable || (subtable == (struct sfnt_offset_subtable *) -1))
+ goto bail1;
+
+ /* Read required tables. This font backend is supposed to be used
+ mostly on devices with flash memory, so the order in which they
+ are read is insignificant. */
+
+ tables->cmap = sfnt_read_cmap_table (fd, subtable, &subtables,
+ &data);
+ if (!tables->cmap)
+ goto bail2;
+
+ format14 = NULL;
+ tables->cmap_data
+ = sfntfont_select_cmap (tables->cmap,
+ subtables, data,
+ &tables->cmap_subtable,
+ &format14);
+
+ if (format14)
+ {
+ /* Build a UVS context from this format 14 mapping table. A UVS
+ context contains each variation selector supported by the
+ font, and a list of ``non-default'' mappings between base
+ characters and variation glyph IDs. */
+
+ tables->uvs = sfnt_create_uvs_context (format14, fd);
+ xfree (format14);
+ }
+
+ for (i = 0; i < tables->cmap->num_subtables; ++i)
+ {
+ if (data[i] != tables->cmap_data
+ /* format14 has already been freed. */
+ && data[i] != (struct sfnt_cmap_encoding_subtable_data *) format14)
+ xfree (data[i]);
+ }
+
+ xfree (subtables);
+ xfree (data);
+
+ if (!tables->cmap_data)
+ goto bail3;
+
+ /* Read the hhea, maxp, glyf, and head tables. */
+ tables->hhea = sfnt_read_hhea_table (fd, subtable);
+ tables->maxp = sfnt_read_maxp_table (fd, subtable);
+
+#ifdef HAVE_MMAP
+
+ /* First try to map the glyf table. If that fails, then read the
+ glyf table. */
+
+ tables->glyf = sfnt_map_glyf_table (fd, subtable);
+
+ /* Next, if this fails, read the glyf table. */
+
+ if (!tables->glyf)
+#endif /* HAVE_MMAP */
+ tables->glyf = sfnt_read_glyf_table (fd, subtable);
+#ifdef HAVE_MMAP
+ else
+ tables->glyf_table_mapped = true;
+#endif /* HAVE_MMAP */
+
+ tables->head = sfnt_read_head_table (fd, subtable);
+
+ /* If any of those tables couldn't be read, bail. */
+ if (!tables->hhea || !tables->maxp || !tables->glyf
+ || !tables->head)
+ goto bail4;
+
+ /* Now figure out which kind of loca table must be read based on
+ head->index_to_loc_format. */
+
+ if (tables->head->index_to_loc_format)
+ {
+ tables->loca_long
+ = sfnt_read_loca_table_long (fd, subtable);
+
+ if (!tables->loca_long)
+ goto bail4;
+ }
+ else
+ {
+ tables->loca_short
+ = sfnt_read_loca_table_short (fd, subtable);
+
+ if (!tables->loca_short)
+ goto bail4;
+ }
+
+ /* Read the horizontal metrics table. */
+ tables->hmtx = sfnt_read_hmtx_table (fd, subtable,
+ tables->hhea,
+ tables->maxp);
+ if (!tables->hmtx)
+ goto bail5;
+
+ /* Read instruction related font tables. These might not be
+ present, which is OK, since instructing fonts is optional. */
+ tables->prep = sfnt_read_prep_table (fd, subtable);
+ tables->fpgm = sfnt_read_fpgm_table (fd, subtable);
+ tables->cvt = sfnt_read_cvt_table (fd, subtable);
+
+ /* Read distortion related tables. These might not be present. */
+ tables->fvar = sfnt_read_fvar_table (fd, subtable);
+ tables->avar = sfnt_read_avar_table (fd, subtable);
+ tables->gvar = sfnt_read_gvar_table (fd, subtable);
+
+ if (tables->cvt && tables->fvar)
+ tables->cvar = sfnt_read_cvar_table (fd, subtable, tables->fvar,
+ tables->cvt);
+
+#ifdef HAVE_HARFBUZZ
+ /* Now copy over the subtable if necessary, as it is needed to read
+ extra font tables required by HarfBuzz. */
+ tables->directory = subtable;
+ tables->fd = fd;
+#else /* !HAVE_HARFBUZZ */
+ /* Otherwise, close the fd and free the table directory. */
+ xfree (subtable);
+ emacs_close (fd);
+#endif /* HAVE_HARFBUZZ */
+
+ return tables;
+
+ bail5:
+ xfree (tables->loca_long);
+ xfree (tables->loca_short);
+ bail4:
+ xfree (tables->hhea);
+ xfree (tables->maxp);
+
+#ifdef HAVE_MMAP
+ if (tables->glyf_table_mapped)
+ {
+ rc = sfnt_unmap_glyf_table (tables->glyf);
+
+ if (rc)
+ emacs_abort ();
+ }
+ else
+#endif /* HAVE_MMAP */
+ xfree (tables->glyf);
+
+ xfree (tables->head);
+
+ /* This comes under bail4 due to a peculiarity of how the four
+ tables above are validated. */
+ xfree (tables->cmap_data);
+ bail3:
+ if (tables->uvs)
+ sfnt_free_uvs_context (tables->uvs);
+
+ xfree (tables->cmap);
+ bail2:
+ xfree (subtable);
+ bail1:
+ emacs_close (fd);
+ bail:
+ xfree (tables);
+ return NULL;
+}
+
+/* Open or reference font tables corresponding to the specified font
+ DESC. Return NULL upon failure. */
+
+static struct sfnt_font_tables *
+sfnt_reference_font_tables (struct sfnt_font_desc *desc)
+{
+ if (desc->refcount)
+ {
+ desc->refcount++;
+ return desc->tables;
+ }
+
+ desc->tables = sfnt_open_tables (desc);
+
+ if (!desc->tables)
+ return NULL;
+
+ desc->refcount++;
+ return desc->tables;
+}
+
+/* Dereference font tables corresponding to the specified font
+ DESC. */
+
+static void
+sfnt_dereference_font_tables (struct sfnt_font_desc *desc)
+{
+ if (!desc->refcount)
+ emacs_abort ();
+
+ if (--desc->refcount)
+ return;
+
+ sfnt_close_tables (desc->tables);
+ desc->tables = NULL;
+ return;
+}
+
+/* Open the font corresponding to the font-entity FONT_ENTITY. Return
+ nil upon failure, else the opened font-object. */
+
+Lisp_Object
+sfntfont_open (struct frame *f, Lisp_Object font_entity,
+ int pixel_size)
+{
+ struct sfnt_font_info *font_info;
+ struct font *font;
+ struct sfnt_font_desc *desc;
+ Lisp_Object font_object;
+ struct charset *charset;
+ int point_size, instance, i;
+ Display_Info *dpyinfo;
+ struct sfnt_font_tables *tables;
+ Lisp_Object tem;
+
+ if (XFIXNUM (AREF (font_entity, FONT_SIZE_INDEX)) != 0)
+ pixel_size = XFIXNUM (AREF (font_entity, FONT_SIZE_INDEX));
+ else if (pixel_size == 0)
+ {
+ /* This bit was copied from xfont.c. The values might need
+ adjustment. */
+
+ if (FRAME_FONT (f))
+ pixel_size = FRAME_FONT (f)->pixel_size;
+ else
+ pixel_size = 12;
+ }
+
+ /* Now find the font description corresponding to FONT_ENTITY. */
+
+ tem = AREF (font_entity, FONT_EXTRA_INDEX);
+ if (NILP (tem))
+ return Qnil;
+
+ desc = xmint_pointer (XCDR (XCAR (tem)));
+
+ /* Finally, see if a specific instance is associated with
+ FONT_ENTITY. */
+
+ instance = -1;
+ if (!NILP (XCDR (tem)))
+ instance = XFIXNUM (XCDR (XCAR (XCDR (tem))));
+
+ /* Build the font object. */
+ font_object = font_make_object (VECSIZE (struct sfnt_font_info),
+ font_entity, pixel_size);
+ font_info = (struct sfnt_font_info *) XFONT_OBJECT (font_object);
+
+ block_input ();
+
+ /* Initialize all the font driver specific data. */
+
+ font_info->cmap = NULL;
+ font_info->hhea = NULL;
+ font_info->maxp = NULL;
+ font_info->head = NULL;
+ font_info->glyf = NULL;
+ font_info->hmtx = NULL;
+ font_info->loca_short = NULL;
+ font_info->loca_long = NULL;
+ font_info->cmap_data = NULL;
+ font_info->prep = NULL;
+ font_info->fpgm = NULL;
+ font_info->cvt = NULL;
+ font_info->uvs = NULL;
+
+ font_info->outline_cache.next = &font_info->outline_cache;
+ font_info->outline_cache.last = &font_info->outline_cache;
+ font_info->outline_cache_size = 0;
+ font_info->raster_cache.next = &font_info->raster_cache;
+ font_info->raster_cache.last = &font_info->raster_cache;
+ font_info->raster_cache_size = 0;
+ font_info->interpreter = NULL;
+ font_info->scale = 0;
+ font_info->instance = -1;
+ font_info->blend.coords = NULL;
+#ifdef HAVE_MMAP
+ font_info->glyf_table_mapped = false;
+#endif /* HAVE_MMAP */
+#ifdef HAVE_HARFBUZZ
+ font_info->hb_font = NULL;
+ font_info->fd = -1;
+ font_info->directory = NULL;
+#endif /* HAVE_HARFBUZZ */
+
+ /* Read required tables. This font backend is supposed to be used
+ mostly on devices with flash memory, so the order in which they
+ are read is insignificant. */
+
+ tables = sfnt_reference_font_tables (desc);
+
+ if (!tables)
+ goto bail;
+
+ /* Copy fields from the table structure to the font for fast
+ access. */
+ font_info->cmap = tables->cmap;
+ font_info->hhea = tables->hhea;
+ font_info->maxp = tables->maxp;
+ font_info->head = tables->head;
+ font_info->hmtx = tables->hmtx;
+ font_info->glyf = tables->glyf;
+ font_info->loca_short = tables->loca_short;
+ font_info->loca_long = tables->loca_long;
+ font_info->prep = tables->prep;
+ font_info->fpgm = tables->fpgm;
+ font_info->cvt = tables->cvt ;
+ font_info->cmap_data = tables->cmap_data;
+ font_info->cmap_subtable = tables->cmap_subtable;
+ font_info->uvs = tables->uvs;
+
+ /* Calculate the font's scaling factor. */
+ font_info->scale = sfnt_get_scale (font_info->head, pixel_size);
+
+ /* Fill in font data. */
+ font = &font_info->font;
+ font->pixel_size = pixel_size;
+ font->driver = sfnt_font_driver;
+ font->encoding_charset = font->repertory_charset = -1;
+
+ /* Figure out which character set to use. */
+ charset = sfntfont_charset_for_cmap (font_info->cmap_subtable);
+
+ if (!charset)
+ goto bail6;
+
+ /* Set the character set IDs. */
+ font->encoding_charset = charset->id;
+ font->repertory_charset = charset->id;
+
+ /* Figure out the font ascent and descent. */
+ font->ascent
+ = ceil (font_info->hhea->ascent
+ * pixel_size
+ * (1.0 / font_info->head->units_per_em));
+ font->descent
+ = ceil ((-font_info->hhea->descent)
+ * pixel_size
+ * (1.0 / font_info->head->units_per_em));
+ font->height = font->ascent + font->descent;
+
+ /* Set font->max_width to the maximum advance width. */
+ font->max_width = (font_info->hhea->advance_width_max
+ * pixel_size * 1.0 / font_info->head->units_per_em);
+
+ /* Set generic attributes such as type and style. */
+ ASET (font_object, FONT_TYPE_INDEX, sfnt_vendor_name);
+ ASET (font_object, FONT_FOUNDRY_INDEX, desc->designer);
+ ASET (font_object, FONT_FAMILY_INDEX, Fintern (desc->family, Qnil));
+ ASET (font_object, FONT_ADSTYLE_INDEX, desc->adstyle);
+ ASET (font_object, FONT_REGISTRY_INDEX,
+ sfntfont_registry_for_desc (desc));
+
+ /* Size of 0 means the font is scalable. */
+ ASET (font_object, FONT_SIZE_INDEX, make_fixnum (0));
+ ASET (font_object, FONT_AVGWIDTH_INDEX, make_fixnum (0));
+ ASET (font_object, FONT_SPACING_INDEX, make_fixnum (desc->spacing));
+
+ /* Set the font style. */
+
+ FONT_SET_STYLE (font_object, FONT_WIDTH_INDEX,
+ make_fixnum (desc->width));
+ FONT_SET_STYLE (font_object, FONT_WEIGHT_INDEX,
+ make_fixnum (desc->weight));
+ FONT_SET_STYLE (font_object, FONT_SLANT_INDEX,
+ make_fixnum (desc->slant));
+
+ /* Clear various offsets. */
+ font_info->font.baseline_offset = 0;
+ font_info->font.relative_compose = 0;
+ font_info->font.default_ascent = 0;
+ font_info->font.vertical_centering = 0;
+
+ if (!desc->underline_position_set)
+ {
+ font_info->font.underline_position = -1;
+ font_info->font.underline_thickness = 0;
+ }
+ else
+ {
+ font_info->font.underline_position
+ = sfnt_coerce_fixed (-desc->underline_position
+ * font_info->scale) + 0.5;
+ font_info->font.underline_thickness
+ = sfnt_coerce_fixed (desc->underline_thickness
+ * font_info->scale) + 0.5;
+ }
+
+ /* Now try to set up grid fitting for this font. */
+ dpyinfo = FRAME_DISPLAY_INFO (f);
+ point_size = PIXEL_TO_POINT (pixel_size, (dpyinfo->resx
+ * dpyinfo->resy
+ / 2));
+ sfntfont_setup_interpreter (font_info, desc, point_size);
+
+ /* If an instance was specified and the font is distortable, set up
+ the blend. */
+
+ if (instance != -1
+ && desc->tables->fvar && desc->tables->gvar
+ /* Make sure the instance is within range. */
+ && instance < desc->tables->fvar->instance_count)
+ {
+ tem = AREF (desc->instances, instance);
+
+ if (!NILP (tem))
+ {
+ sfnt_init_blend (&font_info->blend, desc->tables->fvar,
+ desc->tables->gvar, desc->tables->avar,
+ desc->tables->cvar);
+
+ /* Copy over the coordinates. */
+ for (i = 0; i < desc->tables->fvar->axis_count; ++i)
+ font_info->blend.coords[i]
+ = desc->tables->fvar->instance[instance].coords[i];
+
+ sfnt_normalize_blend (&font_info->blend);
+
+ /* Test whether or not the instance is actually redundant,
+ as all of its axis are at their default values. If so,
+ free the instance. */
+
+ for (i = 0; i < desc->tables->fvar->axis_count; ++i)
+ {
+ if (font_info->blend.norm_coords[i])
+ break;
+ }
+
+ if (i == desc->tables->fvar->axis_count)
+ {
+ sfnt_free_blend (&font_info->blend);
+ goto cancel_blend;
+ }
+
+ /* If an interpreter was specified, distort it now. */
+
+ if (font_info->interpreter)
+ sfnt_vary_interpreter (font_info->interpreter,
+ &font_info->blend);
+
+ font_info->instance = instance;
+
+ /* Replace the style information with that of the
+ instance. */
+
+ FONT_SET_STYLE (font_object, FONT_WIDTH_INDEX,
+ AREF (tem, 2));
+ FONT_SET_STYLE (font_object, FONT_WEIGHT_INDEX,
+ AREF (tem, 3));
+ FONT_SET_STYLE (font_object, FONT_SLANT_INDEX,
+ AREF (tem, 4));
+ ASET (font_object, FONT_ADSTYLE_INDEX, AREF (tem, 1));
+ }
+ }
+
+ cancel_blend:
+
+ /* Find out the minimum, maximum and average widths. */
+ sfntfont_probe_widths (font_info);
+
+ /* Calculate the xfld name. */
+ font->props[FONT_NAME_INDEX] = Ffont_xlfd_name (font_object, Qnil, Qt);
+
+#ifdef HAVE_HARFBUZZ
+ /* HarfBuzz will potentially read font tables after the font has
+ been opened by Emacs. Keep the font open, and record its offset
+ subtable. */
+ font_info->fd = tables->fd;
+ font_info->directory = tables->directory;
+#endif /* HAVE_HARFBUZZ */
+
+ /* Set font->desc so that font tables can be dereferenced if
+ anything goes wrong. */
+ font_info->desc = desc;
+
+#ifdef HAVE_MMAP
+ /* Link the font onto the font table. */
+ font_info->next = open_fonts;
+ open_fonts = font_info;
+#endif /* HAVE_MMAP */
+
+ /* Now ascertain if vertical centering is desired by matching the
+ font XLFD against vertical-centering-font-regexp. */
+
+ if (!NILP (font->props[FONT_NAME_INDEX]))
+ font->vertical_centering
+ = (STRINGP (Vvertical_centering_font_regexp)
+ && (fast_string_match_ignore_case
+ (Vvertical_centering_font_regexp,
+ font->props[FONT_NAME_INDEX]) >= 0));
+
+ /* Set the name of the font file. */
+ font->props[FONT_FILE_INDEX]
+ = DECODE_FILE (build_unibyte_string (desc->path));
+
+ /* Encapsulate some information on the font useful while debugging
+ (along with being informative in general) in the font name. */
+
+ AUTO_STRING (format, "%s %s interpreted: %s upem: %s charset: %s"
+ " instance: %s");
+ font->props[FONT_FULLNAME_INDEX]
+ = CALLN (Fformat, format, desc->family, desc->style,
+ font_info->interpreter ? Qt : Qnil,
+ make_fixnum (font_info->head->units_per_em),
+ CHARSET_NAME (charset),
+ make_fixnum (instance));
+
+ /* All done. */
+ unblock_input ();
+ return font_object;
+
+ bail6:
+ sfnt_dereference_font_tables (desc);
+ font_info->desc = NULL;
+ bail:
+ unblock_input ();
+ return Qnil;
+}
+
+
+
+/* Metrics computation and other similar font backend functions. */
+
+/* Return the glyph code corresponding to C inside the font-object
+ FONT. Value is the glyph code upon success, else
+ FONT_INVALID_CODE. */
+
+unsigned int
+sfntfont_encode_char (struct font *font, int c)
+{
+ sfnt_glyph glyph;
+
+ /* Now look up the glyph. */
+ glyph = sfntfont_lookup_glyph ((struct sfnt_font_info *) font, c);
+
+ if (!glyph)
+ return FONT_INVALID_CODE;
+
+ return glyph;
+}
+
+/* Measure the single glyph GLYPH in the font FONT and return its
+ metrics in *PCM.
+
+ Instruct the glyph if possible.
+
+ Value is 0 upon success, 1 otherwise. */
+
+static int
+sfntfont_measure_pcm (struct sfnt_font_info *font, sfnt_glyph glyph,
+ struct font_metrics *pcm)
+{
+ struct sfnt_glyph_metrics metrics;
+ struct sfnt_glyph_outline *outline;
+
+ /* Now get the glyph outline, which is required to obtain the rsb,
+ ascent and descent. */
+ outline = sfntfont_get_glyph_outline (glyph, &font->outline_cache,
+ font->scale,
+ &font->outline_cache_size,
+ &font->blend,
+ font->instance,
+ font->glyf, font->head,
+ font->hmtx, font->hhea,
+ font->maxp,
+ font->loca_short,
+ font->loca_long,
+ font->interpreter, &metrics,
+ &font->state);
+
+ if (!outline)
+ return 1;
+
+ /* The left side bearing has already been floored. */
+ pcm->lbearing = metrics.lbearing / 65536;
+ pcm->rbearing = SFNT_CEIL_FIXED (outline->xmax) / 65536;
+
+ /* The advance is already rounded; ceil the ascent and descent. */
+ pcm->width = metrics.advance / 65536;
+ pcm->ascent = SFNT_CEIL_FIXED (outline->ymax) / 65536;
+ pcm->descent = SFNT_CEIL_FIXED (-outline->ymin) / 65536;
+
+ sfntfont_dereference_outline (outline);
+ return 0;
+}
+
+/* Return the total text extents of NGLYPHS glyphs given as CODE in
+ the single font metrics array METRICS. */
+
+void
+sfntfont_text_extents (struct font *font, const unsigned int *code,
+ int nglyphs, struct font_metrics *metrics)
+{
+ int i, total_width;
+ struct font_metrics pcm;
+
+ total_width = 0;
+
+ /* First clear the metrics array. */
+ memset (metrics, 0, sizeof *metrics);
+
+ /* Get the metrcs one by one, then sum them up. */
+ for (i = 0; i < nglyphs; ++i)
+ {
+ if (!sfntfont_measure_pcm ((struct sfnt_font_info *) font,
+ code[i], &pcm))
+ {
+ /* Add the per-char metric (PCM) to the metrics in
+ METRICS. */
+
+ if (total_width + pcm.lbearing < metrics->lbearing)
+ metrics->lbearing = total_width + pcm.lbearing;
+
+ if (total_width + pcm.rbearing > metrics->rbearing)
+ metrics->rbearing = total_width + pcm.rbearing;
+
+ if (pcm.ascent > metrics->ascent)
+ metrics->ascent = pcm.ascent;
+
+ if (pcm.descent > metrics->descent)
+ metrics->descent = pcm.descent;
+
+ total_width += pcm.width;
+ }
+ }
+
+ metrics->width = total_width;
+}
+
+/* Close the font FONT, discarding all tables inside it and
+ dereferencing all cached outlines and rasters. */
+
+void
+sfntfont_close (struct font *font)
+{
+ struct sfnt_font_info *info;
+#ifdef HAVE_MMAP
+ struct sfnt_font_info **next;
+#endif /* HAVE_MMAP */
+
+ info = (struct sfnt_font_info *) font;
+
+ /* If info->desc is still set, dereference the font tables. */
+ if (info->desc)
+ sfnt_dereference_font_tables (info->desc);
+ info->desc = NULL;
+
+ /* Free the interpreter, which is created on a per font basis. */
+ xfree (info->interpreter);
+
+ /* Clear these fields. It seems that close can be called twice,
+ once during font driver destruction, and once during GC. */
+
+ info->cmap = NULL;
+ info->hhea = NULL;
+ info->maxp = NULL;
+ info->head = NULL;
+ info->hhea = NULL;
+ info->glyf = NULL;
+ info->loca_short = NULL;
+ info->loca_long = NULL;
+ info->cmap_data = NULL;
+ info->prep = NULL;
+ info->fpgm = NULL;
+ info->cvt = NULL;
+ info->interpreter = NULL;
+ info->uvs = NULL;
+
+ /* Deinitialize the blend. */
+ if (info->instance != -1 && info->blend.coords)
+ sfnt_free_blend (&info->blend);
+ info->instance = -1;
+
+#ifdef HAVE_MMAP
+
+ /* Unlink INFO. */
+
+ next = &open_fonts;
+ while (*next && (*next) != info)
+ next = &(*next)->next;
+
+ if (*next)
+ *next = info->next;
+ info->next = NULL;
+
+#endif /* HAVE_MMAP */
+
+#ifdef HAVE_HARFBUZZ
+ /* These fields will be freed or closed by
+ sfnt_dereference_font_tables, but clear them here for good
+ measure. */
+ info->directory = NULL;
+ info->fd = -1;
+
+ /* Free any hb_font created. */
+
+ if (info->hb_font)
+ {
+ hb_font_destroy (info->hb_font);
+ info->hb_font = NULL;
+ }
+#endif
+
+ sfntfont_free_outline_cache (&info->outline_cache);
+ sfntfont_free_raster_cache (&info->raster_cache);
+}
+
+
+
+/* Glyph display. */
+
+/* Function called to actually draw rasters to the glass. */
+static sfntfont_put_glyph_proc sfnt_put_glyphs;
+
+/* Draw glyphs in S->char2b starting from FROM to TO, with the origin
+ at X and baseline at Y. Fill the background from X, Y +
+ FONT_DESCENT to X + S->background_width, Y - FONT_ASCENT with the
+ background color if necessary. Use the foreground and background
+ colors in S->gc. */
+
+int
+sfntfont_draw (struct glyph_string *s, int from, int to,
+ int x, int y, bool with_background)
+{
+ int length;
+ struct sfnt_raster **rasters;
+ int *x_coords, current_x, i;
+ struct sfnt_glyph_outline *outline;
+ struct font *font;
+ struct sfnt_font_info *info;
+ struct sfnt_glyph_metrics metrics;
+
+ length = to - from;
+ font = s->font;
+ info = (struct sfnt_font_info *) font;
+
+ rasters = alloca (length * sizeof *rasters);
+ x_coords = alloca (length * sizeof *x_coords);
+ current_x = x;
+
+ /* Get rasters and outlines for them. */
+ for (i = from; i < to; ++i)
+ {
+ /* Look up the outline. */
+ outline = sfntfont_get_glyph_outline (s->char2b[i],
+ &info->outline_cache,
+ info->scale,
+ &info->outline_cache_size,
+ &info->blend,
+ info->instance,
+ info->glyf, info->head,
+ info->hmtx, info->hhea,
+ info->maxp,
+ info->loca_short,
+ info->loca_long,
+ info->interpreter,
+ &metrics,
+ &info->state);
+ x_coords[i - from] = 0;
+
+ if (!outline)
+ {
+ rasters[i - from] = NULL;
+ continue;
+ }
+
+ /* Rasterize the outline. */
+ rasters[i - from] = sfntfont_get_glyph_raster (s->char2b[i],
+ &info->raster_cache,
+ outline,
+ &info->raster_cache_size);
+ sfntfont_dereference_outline (outline);
+
+ if (!rasters[i - from])
+ continue;
+
+ /* Now work out where to put the outline. */
+ x_coords[i - from] = current_x;
+
+ if (s->padding_p)
+ current_x += 1;
+ else
+ current_x += metrics.advance / 65536;
+ }
+
+ /* Call the window system function to put the glyphs to the
+ frame. */
+ sfnt_put_glyphs (s, from, to, x, y, with_background,
+ rasters, x_coords);
+
+ /* Dereference all the rasters. */
+ for (i = 0; i < from - to; ++i)
+ {
+ if (rasters[i])
+ sfntfont_dereference_raster (rasters[i]);
+ }
+
+ return 1;
+}
+
+
+
+/* Other callbacks. */
+
+/* Return a list of each font family known to Emacs. F is supposed to
+ be a frame but is ignored. */
+
+Lisp_Object
+sfntfont_list_family (struct frame *f)
+{
+ Lisp_Object families, tem, next;
+ struct sfnt_font_desc *desc;
+
+ families = Qnil;
+
+ for (desc = system_fonts; desc; desc = desc->next)
+ /* Add desc->family to the list. */
+ families = Fcons (desc->family, families);
+
+ /* Sort families in preparation for removing duplicates. */
+ families = CALLN (Fsort, families, Qstring_lessp);
+
+ /* Remove each duplicate within families. */
+
+ tem = families;
+ while (!NILP (tem) && !NILP ((next = XCDR (tem))))
+ {
+ /* If the two strings are equal. */
+ if (!NILP (Fstring_equal (XCAR (tem), XCAR (next))))
+ /* Set tem's cdr to the cons after the next item. */
+ XSETCDR (tem, XCDR (next));
+ else
+ /* Otherwise, start considering the next item. */
+ tem = next;
+ }
+
+ /* Intern each font family. */
+
+ tem = families;
+
+ FOR_EACH_TAIL (tem)
+ XSETCAR (tem, Fintern (XCAR (tem), Qnil));
+
+ return families;
+}
+
+
+
+/* Unicode Variation Selector (UVS) support. This is typically
+ required for Harfbuzz. */
+
+/* Given a FONT object, a character C, and VARIATIONS, return the
+ number of non-default variation glyphs, and their glyph ids in
+ VARIATIONS.
+
+ For each variation selector character K with a non-default glyph in
+ the variation selector range 0xFE00 to 0xFE0F, set variations[K -
+ 0xFE0] to its ID.
+
+ For each variation selector character K with a non-default glyph in
+ the variation selector range 0xE0100 to 0xE01EF, set variations[K -
+ 0xE0100 + 16] to its ID.
+
+ If value is more than 0, set all other members of VARIATIONS to 0.
+ Else, the contents of VARIATIONS are undefined. */
+
+int
+sfntfont_get_variation_glyphs (struct font *font, int c,
+ unsigned variations[256])
+{
+ struct sfnt_font_info *info;
+ size_t i, index;
+ int n;
+ struct sfnt_mapped_variation_selector_record *record;
+ sfnt_glyph default_glyph;
+
+ info = (struct sfnt_font_info *) font;
+ n = 0;
+
+ /* Return 0 if there is no UVS mapping table. */
+
+ if (!info->uvs)
+ return 0;
+
+ /* Clear the variations array. */
+
+ memset (variations, 0, sizeof *variations * 256);
+
+ /* Find the first 0xFExx selector. */
+
+ i = 0;
+ while (i < info->uvs->num_records
+ && info->uvs->records[i].selector < 0xfe00)
+ ++i;
+
+ /* Get the glyph represented by C, used when C is present within a
+ default value table. */
+
+ default_glyph = sfntfont_lookup_glyph (info, c);
+
+ /* Fill in selectors 0 to 15. */
+
+ while (i < info->uvs->num_records
+ && info->uvs->records[i].selector <= 0xfe0f)
+ {
+ record = &info->uvs->records[i];
+ index = info->uvs->records[i].selector - 0xfe00 + 16;
+
+ /* Handle invalid unsorted tables. */
+
+ if (record->selector < 0xfe00)
+ return 0;
+
+ /* If there are default mappings in this record, ascertain if
+ this glyph matches one of them. */
+
+ if (record->default_uvs
+ && sfnt_is_character_default (record->default_uvs, c))
+ {
+ variations[index] = default_glyph;
+
+ if (default_glyph)
+ ++n;
+
+ goto next_selector;
+ }
+
+ /* If record has no non-default mappings, continue on to the
+ next selector. */
+
+ if (!record->nondefault_uvs)
+ goto next_selector;
+
+ /* Find the glyph ID associated with C and put it in
+ VARIATIONS. */
+
+ variations[index]
+ = sfnt_variation_glyph_for_char (record->nondefault_uvs, c);
+
+ if (variations[index])
+ ++n;
+
+ next_selector:
+ ++i;
+ }
+
+ /* Find the first 0xE0100 selector. */
+
+ i = 0;
+ while (i < info->uvs->num_records
+ && info->uvs->records[i].selector < 0xe0100)
+ ++i;
+
+ /* Fill in selectors 16 to 255. */
+
+ while (i < info->uvs->num_records
+ && info->uvs->records[i].selector <= 0xe01ef)
+ {
+ record = &info->uvs->records[i];
+ index = info->uvs->records[i].selector - 0xe0100 + 16;
+
+ /* Handle invalid unsorted tables. */
+
+ if (record->selector < 0xe0100)
+ return 0;
+
+ /* If there are default mappings in this record, ascertain if
+ this glyph matches one of them. */
+
+ if (record->default_uvs
+ && sfnt_is_character_default (record->default_uvs, c))
+ {
+ variations[index] = default_glyph;
+
+ if (default_glyph)
+ ++n;
+
+ goto next_selector_1;
+ }
+
+ /* If record has no non-default mappings, continue on to the
+ next selector. */
+
+ if (!record->nondefault_uvs)
+ goto next_selector_1;
+
+ /* Find the glyph ID associated with C and put it in
+ VARIATIONS. */
+
+ variations[index]
+ = sfnt_variation_glyph_for_char (record->nondefault_uvs, c);
+
+ if (variations[index])
+ ++n;
+
+ next_selector_1:
+ ++i;
+ }
+
+ return n;
+}
+
+
+
+/* mmap specific stuff. */
+
+#ifdef HAVE_MMAP
+
+/* Return whether or not ADDR lies in a mapped glyph, and bus faults
+ should be ignored. */
+
+bool
+sfntfont_detect_sigbus (void *addr)
+{
+ struct sfnt_font_info *info;
+
+ for (info = open_fonts; info; info = info->next)
+ {
+ if (info->glyf_table_mapped
+ && (unsigned char *) addr >= info->glyf->glyphs
+ && (unsigned char *) addr < (info->glyf->glyphs
+ + info->glyf->size))
+ return true;
+ }
+
+ return false;
+}
+
+#endif /* HAVE_MMAP */
+
+
+
+/* Harfbuzz font support. */
+
+#ifdef HAVE_HARFBUZZ
+
+#ifdef HAVE_MMAP
+
+/* Unmap the specified table. */
+
+static void
+sfntfont_unmap_blob (void *ptr)
+{
+ if (sfnt_unmap_table (ptr))
+ emacs_abort ();
+
+ xfree (ptr);
+}
+
+#endif /* HAVE_MMAP */
+
+/* Given a font DATA and a tag TAG, return the data of the
+ corresponding font table as a HarfBuzz blob. */
+
+static hb_blob_t *
+sfntfont_get_font_table (hb_face_t *face, hb_tag_t tag, void *data)
+{
+ size_t size;
+ struct sfnt_font_info *info;
+#ifdef HAVE_MMAP
+ struct sfnt_mapped_table *table;
+ hb_blob_t *blob;
+
+ info = data;
+ table = xmalloc (sizeof *table);
+
+ if (!sfnt_map_table (info->fd, info->directory, tag,
+ table))
+ {
+ /* Create an hb_blob_t and return it.
+ TODO: record this mapping properly so that SIGBUS can
+ be handled. */
+
+ blob = hb_blob_create (table->data, table->length,
+ HB_MEMORY_MODE_READONLY,
+ table, sfntfont_unmap_blob);
+
+ /* Note that sfntfont_unmap_blob will be called if the empty
+ blob is returned. */
+ return blob;
+ }
+
+ xfree (table);
+#else /* !HAVE_MMAP */
+
+ /* Try to read the table conventionally. */
+ info = data;
+#endif /* HAVE_MMAP */
+
+ data = sfnt_read_table (info->fd, info->directory, tag,
+ &size);
+
+ if (!data)
+ return NULL;
+
+ return hb_blob_create (data, size, HB_MEMORY_MODE_WRITABLE,
+ data, xfree);
+}
+
+/* Create or return a HarfBuzz font object corresponding to the
+ specified FONT. Return the scale to convert between fwords and
+ pixels in POSITION_UNIT. */
+
+hb_font_t *
+sfntfont_begin_hb_font (struct font *font, double *position_unit)
+{
+ struct sfnt_font_info *info;
+ hb_face_t *face;
+ int factor;
+
+ info = (struct sfnt_font_info *) font;
+
+ if (info->hb_font)
+ {
+ /* Calculate the scale factor. */
+ *position_unit = 1.0 / 64.0;
+ return info->hb_font;
+ }
+
+ /* Create a face and then a font. */
+ face = hb_face_create_for_tables (sfntfont_get_font_table, font,
+ NULL);
+
+ if (hb_face_get_glyph_count (face) > 0)
+ {
+ info->hb_font = hb_font_create (face);
+ if (!info->hb_font)
+ goto bail;
+
+ factor = font->pixel_size;
+
+ /* Set the scale and PPEM values. */
+ hb_font_set_scale (info->hb_font, factor * 64, factor * 64);
+ hb_font_set_ppem (info->hb_font, factor, factor);
+
+#ifdef HAVE_HB_FONT_SET_VAR_NAMED_INSTANCE
+ /* Set the instance if this is a distortable font. */
+ if (info->instance != -1)
+ hb_font_set_var_named_instance (info->hb_font,
+ info->instance);
+#endif /* HAVE_HB_FONT_SET_VAR_NAMED_INSTANCE */
+
+ /* This is needed for HarfBuzz before 2.0.0; it is the default
+ in later versions. */
+ hb_ot_font_set_funcs (info->hb_font);
+ }
+
+ bail:
+ hb_face_destroy (face);
+
+ /* Calculate the scale factor. */
+ *position_unit = 1.0 / 64.0;
+ return info->hb_font;
+}
+
+#endif /* HAVE_HARFBUZZ */
+
+
+
+void
+syms_of_sfntfont (void)
+{
+ DEFSYM (Qutf_16be, "utf-16be");
+ DEFSYM (Qmac_roman, "mac-roman");
+ DEFSYM (Qchinese_big5, "chinese-big5");
+ DEFSYM (Qunicode_bmp, "unicode-bmp");
+ DEFSYM (Qucs, "ucs");
+ DEFSYM (Qjapanese_jisx0208, "japanese-jisx0208");
+ DEFSYM (Qgbk, "gbk");
+ DEFSYM (Qkorean_ksc5601, "korean-ksc5601");
+ DEFSYM (Qapple_roman, "apple-roman");
+ DEFSYM (Qjisx0208_1983_0, "jisx0208.1983-0");
+ DEFSYM (Qksc5601_1987_0, "ksc5601.1987-0");
+ DEFSYM (Qzh, "zh");
+ DEFSYM (Qja, "ja");
+ DEFSYM (Qko, "ko");
+ DEFSYM (Qfont_instance, "font-instance");
+
+ /* Char-table purpose. */
+ DEFSYM (Qfont_lookup_cache, "font-lookup-cache");
+
+ /* Default foundry name. */
+ DEFSYM (Qmisc, "misc");
+
+ /* Predicated employed for sorting font family lists. */
+ DEFSYM (Qstring_lessp, "string-lessp");
+
+ /* Set up staticpros. */
+ sfnt_vendor_name = Qnil;
+ staticpro (&sfnt_vendor_name);
+
+ /* This variable is supposed to be set by the platform specific part
+ of the font backend. */
+ DEFVAR_LISP ("sfnt-default-family-alist", Vsfnt_default_family_alist,
+ doc: /* Alist between "emulated" and actual font family names.
+Much Emacs code assumes that font families named "Monospace" and "Sans
+Serif" exist, and map to the default monospace and Sans Serif fonts on
+a system. When the `sfnt' font driver is asked to look for a font
+with one of the families in this alist, it uses its value instead. */);
+ Vsfnt_default_family_alist = Qnil;
+
+ DEFVAR_LISP ("sfnt-uninstructable-family-regexp",
+ Vsfnt_uninstructable_family_regexp,
+ doc: /* Regexp matching font families whose glyphs must not be instructed.
+If nil, instruction code supplied by all fonts will be executed. This
+variable takes effect when a font entity is opened, not after, and
+therefore won't affect the scaling of realized faces until their
+frames' font caches are cleared (see `clear-font-cache').
+
+TrueType fonts incorporate instruction code executed to fit each glyph
+to a pixel grid, so as to improve the visual fidelity of each glyph by
+eliminating artifacts and chance effects consequent upon the direct
+upscaling of glyph outline data. Instruction code is occasionally
+incompatible with Emacs and must be disregarded. */);
+ Vsfnt_uninstructable_family_regexp = Qnil;
+
+ DEFVAR_BOOL ("sfnt-raster-glyphs-exactly", sfnt_raster_glyphs_exactly,
+ doc: /* How font glyph outlines should be converted to graphics.
+If non-nil, glyphs will be displayed in a more precise manner, at the
+cost of performance on devices where floating-point math operations
+are slow. */);
+ sfnt_raster_glyphs_exactly = true;
+}
+
+void
+mark_sfntfont (void)
+{
+ struct sfnt_font_desc *desc;
+
+ /* Mark each font desc. */
+ for (desc = system_fonts; desc; desc = desc->next)
+ {
+ mark_object (desc->family);
+ mark_object (desc->style);
+ mark_object (desc->adstyle);
+ mark_object (desc->instances);
+ mark_object (desc->languages);
+ mark_object (desc->registry);
+ mark_object (desc->char_cache);
+ mark_object (desc->designer);
+ }
+}
+
+void
+init_sfntfont (void)
+{
+
+}
+
+
+
+/* Initialize the sfntfont font driver. VENDOR_TYPE is the type of
+ all font entities created. DRIVER is the font driver that is saved
+ in font objects. PUT_GLYPHS is a function that is called with 8
+ arguments, S, FROM, TO, X, Y, WITH_BACKGROUND, RASTERS, and
+ X_COORDS, and should draw all the rasters in RASTERS to S->f,
+ originating at X_COORDS[i], Y, along with filling the background if
+ WITH_BACKGROUND is specified. */
+
+void
+init_sfntfont_vendor (Lisp_Object vendor_name,
+ const struct font_driver *driver,
+ sfntfont_put_glyph_proc put_glyphs)
+{
+ sfnt_vendor_name = vendor_name;
+ sfnt_font_driver = driver;
+ sfnt_put_glyphs = put_glyphs;
+}
diff --git a/src/sfntfont.h b/src/sfntfont.h
new file mode 100644
index 00000000000..0e57ee35028
--- /dev/null
+++ b/src/sfntfont.h
@@ -0,0 +1,78 @@
+/* sfnt format font driver for GNU Emacs.
+
+Copyright (C) 2023-2024 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 <https://www.gnu.org/licenses/>. */
+
+#ifndef _SFNTFONT_H_
+#define _SFNTFONT_H_
+
+#include "lisp.h"
+#include "frame.h"
+#include "font.h"
+#include "sfnt.h"
+
+extern int sfnt_enum_font (const char *);
+
+
+/* Font driver callbacks. */
+
+extern Lisp_Object sfntfont_list (struct frame *, Lisp_Object);
+extern Lisp_Object sfntfont_match (struct frame *, Lisp_Object);
+extern Lisp_Object sfntfont_open (struct frame *, Lisp_Object, int);
+
+extern unsigned int sfntfont_encode_char (struct font *, int);
+extern void sfntfont_text_extents (struct font *, const unsigned int *,
+ int, struct font_metrics *);
+extern void sfntfont_close (struct font *);
+extern int sfntfont_draw (struct glyph_string *, int, int,
+ int, int, bool);
+extern Lisp_Object sfntfont_list_family (struct frame *);
+extern int sfntfont_get_variation_glyphs (struct font *, int, unsigned[256]);
+
+
+/* Initialization functions. */
+
+typedef void (*sfntfont_put_glyph_proc) (struct glyph_string *, int, int,
+ int, int, bool, struct sfnt_raster **,
+ int *);
+
+extern void syms_of_sfntfont (void);
+extern void init_sfntfont (void);
+extern void mark_sfntfont (void);
+extern void init_sfntfont_vendor (Lisp_Object, const struct font_driver *,
+ sfntfont_put_glyph_proc);
+
+
+/* mmap specific functions. */
+
+#ifdef HAVE_MMAP
+
+extern bool sfntfont_detect_sigbus (void *);
+
+#endif /* HAVE_MMAP */
+
+
+
+/* HarfBuzz specific functions. */
+
+#ifdef HAVE_HARFBUZZ
+
+extern hb_font_t *sfntfont_begin_hb_font (struct font *, double *);
+
+#endif /* HAVE_HARFBUZZ */
+
+#endif /* _SFNTFONT_H_ */
diff --git a/src/sort.c b/src/sort.c
index da3c9ee1e17..527d5550342 100644
--- a/src/sort.c
+++ b/src/sort.c
@@ -34,13 +34,97 @@ along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. */
#include "lisp.h"
+/* Reverse a slice of a vector in place, from lo up to (exclusive) hi. */
+static void
+reverse_slice(Lisp_Object *lo, Lisp_Object *hi)
+{
+ eassert (lo && hi);
+
+ --hi;
+ while (lo < hi) {
+ Lisp_Object t = *lo;
+ *lo = *hi;
+ *hi = t;
+ ++lo;
+ --hi;
+ }
+}
+
+/* A sortslice contains a pointer to an array of keys and a pointer to
+ an array of corresponding values. In other words, keys[i]
+ corresponds with values[i]. If values == NULL, then the keys are
+ also the values.
+
+ Several convenience routines are provided here, so that keys and
+ values are always moved in sync. */
+
+typedef struct {
+ Lisp_Object *keys;
+ Lisp_Object *values;
+} sortslice;
+
+/* FIXME: Instead of values=NULL, can we set values=keys, so that they
+ are both moved in lockstep and we avoid a lot of branches?
+ We may do some useless work but it might be cheaper overall. */
+
+static inline void
+sortslice_copy (sortslice *s1, ptrdiff_t i, sortslice *s2, ptrdiff_t j)
+{
+ s1->keys[i] = s2->keys[j];
+ if (s1->values != NULL)
+ s1->values[i] = s2->values[j];
+}
+
+static inline void
+sortslice_copy_incr (sortslice *dst, sortslice *src)
+{
+ *dst->keys++ = *src->keys++;
+ if (dst->values != NULL)
+ *dst->values++ = *src->values++;
+}
+
+static inline void
+sortslice_copy_decr (sortslice *dst, sortslice *src)
+{
+ *dst->keys-- = *src->keys--;
+ if (dst->values != NULL)
+ *dst->values-- = *src->values--;
+}
+
+
+static inline void
+sortslice_memcpy (sortslice *s1, ptrdiff_t i, sortslice *s2, ptrdiff_t j,
+ ptrdiff_t n)
+{
+ memcpy (&s1->keys[i], &s2->keys[j], sizeof s1->keys[0] * n);
+ if (s1->values != NULL)
+ memcpy (&s1->values[i], &s2->values[j], sizeof s1->values[0] * n);
+}
+
+static inline void
+sortslice_memmove (sortslice *s1, ptrdiff_t i, sortslice *s2, ptrdiff_t j,
+ ptrdiff_t n)
+{
+ memmove (&s1->keys[i], &s2->keys[j], sizeof s1->keys[0] * n);
+ if (s1->values != NULL)
+ memmove (&s1->values[i], &s2->values[j], sizeof s1->values[0] * n);
+}
+
+static inline void
+sortslice_advance (sortslice *slice, ptrdiff_t n)
+{
+ slice->keys += n;
+ if (slice->values != NULL)
+ slice->values += n;
+}
+
/* 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)
+#define MAX_MERGE_PENDING PTRDIFF_WIDTH
/* Once we get into galloping mode, we stay there as long as both runs
win at least GALLOP_WIN_MIN consecutive times. */
@@ -54,23 +138,24 @@ along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. */
struct stretch
{
- Lisp_Object *base;
+ sortslice base;
ptrdiff_t len;
int power;
};
struct reloc
{
- Lisp_Object **src;
- Lisp_Object **dst;
+ sortslice *src;
+ sortslice *dst;
ptrdiff_t *size;
int order; /* -1 while in merge_lo; +1 while in merg_hi; 0 otherwise. */
};
-typedef struct
+typedef struct merge_state
{
- Lisp_Object *listbase;
+ Lisp_Object *basekeys;
+ Lisp_Object *allocated_keys; /* heap-alloc'ed key array or NULL */
ptrdiff_t listlen;
/* PENDING is a stack of N pending stretches yet to be merged.
@@ -91,7 +176,7 @@ typedef struct
with merges. 'A' initially points to TEMPARRAY, and subsequently
to newly allocated memory if needed. */
- Lisp_Object *a;
+ sortslice a;
ptrdiff_t alloced;
specpdl_ref count;
Lisp_Object temparray[MERGESTATE_TEMP_SIZE];
@@ -102,20 +187,32 @@ typedef struct
struct reloc reloc;
- /* PREDICATE is the lisp comparison predicate for the sort. */
+ /* The C ordering (less-than) predicate. */
+ bool (*pred_fun) (struct merge_state *ms, Lisp_Object a, Lisp_Object b);
+ /* The Lisp ordering predicate; Qnil means value<. */
Lisp_Object predicate;
} merge_state;
-/* Return true iff (PREDICATE A B) is non-nil. */
+static bool
+order_pred_lisp (merge_state *ms, Lisp_Object a, Lisp_Object b)
+{
+ return !NILP (call2 (ms->predicate, a, b));
+}
-static inline bool
-inorder (const Lisp_Object predicate, const Lisp_Object a, const Lisp_Object b)
+static bool
+order_pred_valuelt (merge_state *ms, Lisp_Object a, Lisp_Object b)
{
- return !NILP (call2 (predicate, a, b));
+ return !NILP (Fvaluelt (a, b));
}
+/* Return true iff A < B according to the order predicate. */
+static inline bool
+inorder (merge_state *ms, Lisp_Object a, Lisp_Object b)
+{
+ return ms->pred_fun (ms, 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
@@ -124,24 +221,22 @@ inorder (const Lisp_Object predicate, const Lisp_Object a, const Lisp_Object b)
permutation of the input (nothing is lost or duplicated). */
static void
-binarysort (merge_state *ms, Lisp_Object *lo, const Lisp_Object *hi,
+binarysort (merge_state *ms, sortslice lo, const Lisp_Object *hi,
Lisp_Object *start)
{
- Lisp_Object pred = ms->predicate;
-
- eassume (lo <= start && start <= hi);
- if (lo == start)
+ eassume (lo.keys <= start && start <= hi);
+ if (lo.keys == start)
++start;
for (; start < hi; ++start)
{
- Lisp_Object *l = lo;
+ Lisp_Object *l = lo.keys;
Lisp_Object *r = start;
Lisp_Object pivot = *r;
eassume (l < r);
do {
Lisp_Object *p = l + ((r - l) >> 1);
- if (inorder (pred, pivot, *p))
+ if (inorder (ms, pivot, *p))
r = p;
else
l = p + 1;
@@ -150,6 +245,17 @@ binarysort (merge_state *ms, Lisp_Object *lo, const Lisp_Object *hi,
for (Lisp_Object *p = start; p > l; --p)
p[0] = p[-1];
*l = pivot;
+
+ if (lo.values != NULL)
+ {
+ ptrdiff_t offset = lo.values - lo.keys;
+ Lisp_Object *p = start + offset;
+ pivot = *p;
+ l += offset;
+ for (Lisp_Object *p = start + offset; p > l; --p)
+ p[0] = p[-1];
+ *l = pivot;
+ }
}
}
@@ -167,8 +273,6 @@ 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;
@@ -177,12 +281,12 @@ count_run (merge_state *ms, Lisp_Object *lo, const Lisp_Object *hi,
return n;
n = 2;
- if (inorder (pred, lo[0], lo[-1]))
+ if (inorder (ms, lo[0], lo[-1]))
{
*descending = 1;
for (lo = lo + 1; lo < hi; ++lo, ++n)
{
- if (!inorder (pred, lo[0], lo[-1]))
+ if (!inorder (ms, lo[0], lo[-1]))
break;
}
}
@@ -190,7 +294,7 @@ count_run (merge_state *ms, Lisp_Object *lo, const Lisp_Object *hi,
{
for (lo = lo + 1; lo < hi; ++lo, ++n)
{
- if (inorder (pred, lo[0], lo[-1]))
+ if (inorder (ms, lo[0], lo[-1]))
break;
}
}
@@ -223,21 +327,19 @@ 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))
+ if (inorder (ms, *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))
+ if (inorder (ms, a[ofs], key))
{
lastofs = ofs;
eassume (ofs <= (PTRDIFF_MAX - 1) / 2);
@@ -259,7 +361,7 @@ gallop_left (merge_state *ms, const Lisp_Object key, Lisp_Object *a,
const ptrdiff_t maxofs = hint + 1; /* Here &a[0] is lowest. */
while (ofs < maxofs)
{
- if (inorder (pred, a[-ofs], key))
+ if (inorder (ms, a[-ofs], key))
break;
/* Here key <= a[hint - ofs]. */
lastofs = ofs;
@@ -284,7 +386,7 @@ gallop_left (merge_state *ms, const Lisp_Object key, Lisp_Object *a,
{
ptrdiff_t m = lastofs + ((ofs - lastofs) >> 1);
- if (inorder (pred, a[m], key))
+ if (inorder (ms, a[m], key))
lastofs = m + 1; /* Here a[m] < key. */
else
ofs = m; /* Here key <= a[m]. */
@@ -307,21 +409,19 @@ 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))
+ if (inorder (ms, 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]))
+ if (inorder (ms, key, a[-ofs]))
{
lastofs = ofs;
eassume (ofs <= (PTRDIFF_MAX - 1) / 2);
@@ -344,7 +444,7 @@ gallop_right (merge_state *ms, const Lisp_Object key, Lisp_Object *a,
const ptrdiff_t maxofs = n - hint; /* Here &a[n-1] is highest. */
while (ofs < maxofs)
{
- if (inorder (pred, key, a[ofs]))
+ if (inorder (ms, key, a[ofs]))
break;
/* Here a[hint + ofs] <= key. */
lastofs = ofs;
@@ -368,7 +468,7 @@ gallop_right (merge_state *ms, const Lisp_Object key, Lisp_Object *a,
{
ptrdiff_t m = lastofs + ((ofs - lastofs) >> 1);
- if (inorder (pred, key, a[m]))
+ if (inorder (ms, key, a[m]))
ofs = m; /* Here key < a[m]. */
else
lastofs = m + 1; /* Here a[m] <= key. */
@@ -378,21 +478,47 @@ gallop_right (merge_state *ms, const Lisp_Object key, Lisp_Object *a,
}
+static void merge_register_cleanup (merge_state *ms);
+
static void
-merge_init (merge_state *ms, const ptrdiff_t list_size, Lisp_Object *lo,
- const Lisp_Object predicate)
+merge_init (merge_state *ms, const ptrdiff_t list_size,
+ Lisp_Object *allocated_keys, sortslice *lo, Lisp_Object predicate)
{
eassume (ms != NULL);
- ms->a = ms->temparray;
- ms->alloced = MERGESTATE_TEMP_SIZE;
+ if (lo->values != NULL)
+ {
+ /* The temporary space for merging will need at most half the list
+ size rounded up. Use the minimum possible space so we can use the
+ rest of temparray for other things. In particular, if there is
+ enough extra space, if will be used to store the keys. */
+ ms->alloced = (list_size + 1) / 2;
+
+ /* ms->alloced describes how many keys will be stored at
+ ms->temparray, but we also need to store the values. Hence,
+ ms->alloced is capped at half of MERGESTATE_TEMP_SIZE. */
+ if (MERGESTATE_TEMP_SIZE / 2 < ms->alloced)
+ ms->alloced = MERGESTATE_TEMP_SIZE / 2;
+ ms->a.values = &ms->temparray[ms->alloced];
+ }
+ else
+ {
+ ms->alloced = MERGESTATE_TEMP_SIZE;
+ ms->a.values = NULL;
+ }
+ ms->a.keys = ms->temparray;
ms->n = 0;
ms->min_gallop = GALLOP_WIN_MIN;
ms->listlen = list_size;
- ms->listbase = lo;
+ ms->basekeys = lo->keys;
+ ms->allocated_keys = allocated_keys;
+ ms->pred_fun = NILP (predicate) ? order_pred_valuelt : order_pred_lisp;
ms->predicate = predicate;
ms->reloc = (struct reloc){NULL, NULL, NULL, 0};
+ ms->count = make_invalid_specpdl_ref ();
+ if (allocated_keys != NULL)
+ merge_register_cleanup (ms);
}
@@ -408,8 +534,10 @@ merge_markmem (void *arg)
if (ms->reloc.size != NULL && *ms->reloc.size > 0)
{
- eassume (ms->reloc.src != NULL);
- mark_objects (*ms->reloc.src, *ms->reloc.size);
+ Lisp_Object *src = (ms->reloc.src->values
+ ? ms->reloc.src->values : ms->reloc.src->keys);
+ eassume (src != NULL);
+ mark_objects (src, *ms->reloc.size);
}
}
@@ -432,16 +560,37 @@ cleanup_mem (void *arg)
if (ms->reloc.order != 0 && *ms->reloc.size > 0)
{
- eassume (*ms->reloc.src != NULL && *ms->reloc.dst != NULL);
+ Lisp_Object *src = (ms->reloc.src->values
+ ? ms->reloc.src->values : ms->reloc.src->keys);
+ Lisp_Object *dst = (ms->reloc.dst->values
+ ? ms->reloc.dst->values : ms->reloc.dst->keys);
+ eassume (src != NULL && 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);
+ memcpy (dst - shift, src, n * word_size);
}
/* Free any remaining temp storage. */
- xfree (ms->a);
+ if (ms->a.keys != ms->temparray)
+ {
+ xfree (ms->a.keys);
+ ms->a.keys = NULL;
+ }
+
+ if (ms->allocated_keys != NULL)
+ {
+ xfree (ms->allocated_keys);
+ ms->allocated_keys = NULL;
+ }
}
+static void
+merge_register_cleanup (merge_state *ms)
+{
+ specpdl_ref count = SPECPDL_INDEX ();
+ record_unwind_protect_ptr_mark (cleanup_mem, ms, merge_markmem);
+ ms->count = count;
+}
/* Allocate enough temp memory for NEED array slots. Any previously
allocated memory is first freed, and a cleanup routine is
@@ -453,13 +602,12 @@ merge_getmem (merge_state *ms, const ptrdiff_t need)
{
eassume (ms != NULL);
- if (ms->a == ms->temparray)
+ if (ms->a.keys == 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;
+ if (!specpdl_ref_valid_p (ms->count))
+ merge_register_cleanup (ms);
}
else
{
@@ -467,10 +615,13 @@ merge_getmem (merge_state *ms, const ptrdiff_t need)
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);
+ xfree (ms->a.keys);
}
- ms->a = xmalloc (need * word_size);
+ ptrdiff_t bytes = (need * word_size) << (ms->a.values != NULL ? 1 : 0);
+ ms->a.keys = xmalloc (bytes);
ms->alloced = need;
+ if (ms->a.values != NULL)
+ ms->a.values = &ms->a.keys[need];
}
@@ -488,21 +639,19 @@ needmem (merge_state *ms, ptrdiff_t na)
NB. */
static void
-merge_lo (merge_state *ms, Lisp_Object *ssa, ptrdiff_t na, Lisp_Object *ssb,
- ptrdiff_t nb)
+merge_lo (merge_state *ms, sortslice ssa, ptrdiff_t na,
+ sortslice ssb, ptrdiff_t nb)
{
- Lisp_Object pred = ms->predicate;
-
- eassume (ms && ssa && ssb && na > 0 && nb > 0);
- eassume (ssa + na == ssb);
+ eassume (ms && ssa.keys && ssb.keys && na > 0 && nb > 0);
+ eassume (ssa.keys + na == ssb.keys);
needmem (ms, na);
- memcpy (ms->a, ssa, na * word_size);
- Lisp_Object *dest = ssa;
+ sortslice_memcpy (&ms->a, 0, &ssa, 0, na);
+ sortslice dest = ssa;
ssa = ms->a;
ms->reloc = (struct reloc){&ssa, &dest, &na, -1};
- *dest++ = *ssb++;
+ sortslice_copy_incr (&dest, &ssb);
--nb;
if (nb == 0)
goto Succeed;
@@ -519,9 +668,9 @@ merge_lo (merge_state *ms, Lisp_Object *ssa, ptrdiff_t na, Lisp_Object *ssb,
for (;;)
{
eassume (na > 1 && nb > 0);
- if (inorder (pred, *ssb, *ssa))
+ if (inorder (ms, ssb.keys[0], ssa.keys[0]))
{
- *dest++ = *ssb++ ;
+ sortslice_copy_incr (&dest, &ssb);
++bcount;
acount = 0;
--nb;
@@ -532,7 +681,7 @@ merge_lo (merge_state *ms, Lisp_Object *ssa, ptrdiff_t na, Lisp_Object *ssb,
}
else
{
- *dest++ = *ssa++;
+ sortslice_copy_incr (&dest, &ssa);
++acount;
bcount = 0;
--na;
@@ -552,13 +701,13 @@ merge_lo (merge_state *ms, Lisp_Object *ssa, ptrdiff_t na, Lisp_Object *ssb,
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);
+ ptrdiff_t k = gallop_right (ms, ssb.keys[0], ssa.keys, na, 0);
acount = k;
if (k)
{
- memcpy (dest, ssa, k * word_size);
- dest += k;
- ssa += k;
+ sortslice_memcpy (&dest, 0, &ssa, 0, k);
+ sortslice_advance (&dest, k);
+ sortslice_advance (&ssa, k);
na -= k;
if (na == 1)
goto CopyB;
@@ -567,23 +716,23 @@ merge_lo (merge_state *ms, Lisp_Object *ssa, ptrdiff_t na, Lisp_Object *ssb,
if (na == 0)
goto Succeed;
}
- *dest++ = *ssb++ ;
+ sortslice_copy_incr (&dest, &ssb);
--nb;
if (nb == 0)
goto Succeed;
- k = gallop_left (ms, ssa[0], ssb, nb, 0);
+ k = gallop_left (ms, ssa.keys[0], ssb.keys, nb, 0);
bcount = k;
if (k)
{
- memmove (dest, ssb, k * word_size);
- dest += k;
- ssb += k;
+ sortslice_memmove (&dest, 0, &ssb, 0, k);
+ sortslice_advance (&dest, k);
+ sortslice_advance (&ssb, k);
nb -= k;
if (nb == 0)
goto Succeed;
}
- *dest++ = *ssa++;
+ sortslice_copy_incr (&dest, &ssa);
--na;
if (na == 1)
goto CopyB;
@@ -595,15 +744,15 @@ merge_lo (merge_state *ms, Lisp_Object *ssa, ptrdiff_t na, Lisp_Object *ssb,
ms->reloc = (struct reloc){NULL, NULL, NULL, 0};
if (na)
- memcpy (dest, ssa, na * word_size);
+ sortslice_memcpy(&dest, 0, &ssa, 0, na);
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];
+ sortslice_memmove (&dest, 0, &ssb, 0, nb);
+ sortslice_copy (&dest, nb, &ssa, 0);
}
@@ -613,25 +762,25 @@ merge_lo (merge_state *ms, Lisp_Object *ssa, ptrdiff_t na, Lisp_Object *ssb,
NB. */
static void
-merge_hi (merge_state *ms, Lisp_Object *ssa, ptrdiff_t na,
- Lisp_Object *ssb, ptrdiff_t nb)
+merge_hi (merge_state *ms, sortslice ssa, ptrdiff_t na,
+ sortslice ssb, ptrdiff_t nb)
{
- Lisp_Object pred = ms->predicate;
-
- eassume (ms && ssa && ssb && na > 0 && nb > 0);
- eassume (ssa + na == ssb);
+ eassume (ms && ssa.keys && ssb.keys && na > 0 && nb > 0);
+ eassume (ssa.keys + na == ssb.keys);
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;
+ sortslice dest = ssb;
+ sortslice_advance (&dest, nb-1);
+ sortslice_memcpy (&ms->a, 0, &ssb, 0, nb);
+ sortslice basea = ssa;
+ sortslice baseb = ms->a;
+ ssb.keys = ms->a.keys + nb - 1;
+ if (ssb.values != NULL)
+ ssb.values = ms->a.values + nb - 1;
+ sortslice_advance (&ssa, na - 1);
ms->reloc = (struct reloc){&baseb, &dest, &nb, 1};
- *dest-- = *ssa--;
+ sortslice_copy_decr (&dest, &ssa);
--na;
if (na == 0)
goto Succeed;
@@ -645,9 +794,9 @@ merge_hi (merge_state *ms, Lisp_Object *ssa, ptrdiff_t na,
for (;;) {
eassume (na > 0 && nb > 1);
- if (inorder (pred, *ssb, *ssa))
+ if (inorder (ms, ssb.keys[0], ssa.keys[0]))
{
- *dest-- = *ssa--;
+ sortslice_copy_decr (&dest, &ssa);
++acount;
bcount = 0;
--na;
@@ -658,7 +807,7 @@ merge_hi (merge_state *ms, Lisp_Object *ssa, ptrdiff_t na,
}
else
{
- *dest-- = *ssb--;
+ sortslice_copy_decr (&dest, &ssb);
++bcount;
acount = 0;
--nb;
@@ -677,31 +826,31 @@ merge_hi (merge_state *ms, Lisp_Object *ssa, ptrdiff_t na,
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);
+ ptrdiff_t k = gallop_right (ms, ssb.keys[0], basea.keys, na, na - 1);
k = na - k;
acount = k;
if (k)
{
- dest += -k;
- ssa += -k;
- memmove(dest + 1, ssa + 1, k * word_size);
+ sortslice_advance (&dest, -k);
+ sortslice_advance (&ssa, -k);
+ sortslice_memmove (&dest, 1, &ssa, 1, k);
na -= k;
if (na == 0)
goto Succeed;
}
- *dest-- = *ssb--;
+ sortslice_copy_decr(&dest, &ssb);
--nb;
if (nb == 1)
goto CopyA;
- k = gallop_left (ms, ssa[0], baseb, nb, nb - 1);
+ k = gallop_left (ms, ssa.keys[0], baseb.keys, nb, nb - 1);
k = nb - k;
bcount = k;
if (k)
{
- dest += -k;
- ssb += -k;
- memcpy(dest + 1, ssb + 1, k * word_size);
+ sortslice_advance (&dest, -k);
+ sortslice_advance (&ssb, -k);
+ sortslice_memcpy (&dest, 1, &ssb, 1, k);
nb -= k;
if (nb == 1)
goto CopyA;
@@ -710,7 +859,7 @@ merge_hi (merge_state *ms, Lisp_Object *ssa, ptrdiff_t na,
if (nb == 0)
goto Succeed;
}
- *dest-- = *ssa--;
+ sortslice_copy_decr (&dest, &ssa);
--na;
if (na == 0)
goto Succeed;
@@ -721,16 +870,16 @@ merge_hi (merge_state *ms, Lisp_Object *ssa, ptrdiff_t na,
Succeed:
ms->reloc = (struct reloc){NULL, NULL, NULL, 0};
if (nb)
- memcpy (dest - nb + 1, baseb, nb * word_size);
+ sortslice_memcpy (&dest, -(nb-1), &baseb, 0, nb);
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];
+ sortslice_memmove (&dest, 1-na, &ssa, 1-na, na);
+ sortslice_advance (&dest, -na);
+ sortslice_advance (&ssa, -na);
+ sortslice_copy (&dest, 0, &ssb, 0);
}
@@ -744,12 +893,12 @@ merge_at (merge_state *ms, const ptrdiff_t i)
eassume (i >= 0);
eassume (i == ms->n - 2 || i == ms->n - 3);
- Lisp_Object *ssa = ms->pending[i].base;
+ sortslice ssa = ms->pending[i].base;
ptrdiff_t na = ms->pending[i].len;
- Lisp_Object *ssb = ms->pending[i + 1].base;
+ sortslice ssb = ms->pending[i + 1].base;
ptrdiff_t nb = ms->pending[i + 1].len;
eassume (na > 0 && nb > 0);
- eassume (ssa + na == ssb);
+ eassume (ssa.keys + na == ssb.keys);
/* 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
@@ -761,16 +910,16 @@ merge_at (merge_state *ms, const ptrdiff_t i)
/* 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);
+ ptrdiff_t k = gallop_right (ms, *ssb.keys, ssa.keys, na, 0);
eassume (k >= 0);
- ssa += k;
+ sortslice_advance (&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);
+ nb = gallop_left (ms, ssa.keys[na - 1], ssb.keys, nb, nb - 1);
if (nb == 0)
return;
eassume (nb > 0);
@@ -841,7 +990,7 @@ found_new_run (merge_state *ms, const ptrdiff_t n2)
{
eassume (ms->n > 0);
struct stretch *p = ms->pending;
- ptrdiff_t s1 = p[ms->n - 1].base - ms->listbase;
+ ptrdiff_t s1 = p[ms->n - 1].base.keys - ms->basekeys;
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)
@@ -898,39 +1047,80 @@ merge_compute_minrun (ptrdiff_t n)
static void
-reverse_vector (Lisp_Object *s, const ptrdiff_t n)
+reverse_sortslice (sortslice *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;
- }
+ reverse_slice(s->keys, &s->keys[n]);
+ if (s->values != NULL)
+ reverse_slice(s->values, &s->values[n]);
}
-/* 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)
+static Lisp_Object
+resolve_fun (Lisp_Object fun)
{
- if (SYMBOLP (predicate))
+ if (SYMBOLP (fun))
{
/* 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))
+ Lisp_Object f = XSYMBOL (fun)->u.s.function;
+ if (SYMBOLP (f))
/* Function was an alias; use slow-path resolution. */
- fun = indirect_function (fun);
+ f = indirect_function (f);
/* Don't resolve to an autoload spec; that would be very slow. */
- if (!NILP (fun) && !(CONSP (fun) && EQ (XCAR (fun), Qautoload)))
- predicate = fun;
+ if (!NILP (f) && !(CONSP (f) && EQ (XCAR (f), Qautoload)))
+ fun = f;
}
+ return fun;
+}
+/* Sort the array SEQ with LENGTH elements in the order determined by
+ PREDICATE (where Qnil means value<) and KEYFUNC (where Qnil means identity),
+ optionally reversed. */
+void
+tim_sort (Lisp_Object predicate, Lisp_Object keyfunc,
+ Lisp_Object *seq, const ptrdiff_t length, bool reverse)
+{
+ /* FIXME: hoist this to the caller? */
+ if (EQ (predicate, Qvaluelt))
+ predicate = Qnil;
+ if (!NILP (predicate))
+ predicate = resolve_fun (predicate);
+ if (EQ (keyfunc, Qidentity))
+ keyfunc = Qnil;
+
+ sortslice lo;
+ Lisp_Object *keys;
+ Lisp_Object *allocated_keys = NULL;
merge_state ms;
- Lisp_Object *lo = seq;
- merge_init (&ms, length, lo, predicate);
+ if (reverse)
+ reverse_slice (seq, seq + length); /* preserve stability */
+
+ if (NILP (keyfunc))
+ {
+ keys = NULL;
+ lo.keys = seq;
+ lo.values = NULL;
+ }
+ else
+ {
+ keyfunc = resolve_fun (keyfunc);
+ if (length < MERGESTATE_TEMP_SIZE / 2)
+ keys = &ms.temparray[length + 1];
+ else
+ keys = allocated_keys = xmalloc (length * word_size);
+
+ for (ptrdiff_t i = 0; i < length; i++)
+ keys[i] = call1 (keyfunc, seq[i]);
+
+ lo.keys = keys;
+ lo.values = seq;
+ }
+
+ /* FIXME: This is where we would check the keys for interesting
+ properties for more optimised comparison (such as all being fixnums
+ etc). */
+
+ merge_init (&ms, length, allocated_keys, &lo, predicate);
/* March over the array once, left to right, finding natural runs,
and extending short natural runs to minrun elements. */
@@ -940,19 +1130,19 @@ tim_sort (Lisp_Object predicate, Lisp_Object *seq, const ptrdiff_t length)
bool descending;
/* Identify the next run. */
- ptrdiff_t n = count_run (&ms, lo, lo + nremaining, &descending);
+ ptrdiff_t n = count_run (&ms, lo.keys, lo.keys + nremaining, &descending);
if (descending)
- reverse_vector (lo, n);
+ reverse_sortslice (&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);
+ const ptrdiff_t force = min (nremaining, minrun);
+ binarysort (&ms, lo, lo.keys + force, lo.keys + n);
n = force;
}
- eassume (ms.n == 0 || ms.pending[ms.n - 1].base +
- ms.pending[ms.n - 1].len == lo);
+ eassume (ms.n == 0
+ || (ms.pending[ms.n - 1].base.keys + ms.pending[ms.n - 1].len
+ == lo.keys));
found_new_run (&ms, n);
/* Push the new run on to the stack. */
eassume (ms.n < MAX_MERGE_PENDING);
@@ -960,7 +1150,7 @@ tim_sort (Lisp_Object predicate, Lisp_Object *seq, const ptrdiff_t length)
ms.pending[ms.n].len = n;
++ms.n;
/* Advance to find the next run. */
- lo += n;
+ sortslice_advance(&lo, n);
nremaining -= n;
} while (nremaining);
@@ -969,6 +1159,9 @@ tim_sort (Lisp_Object predicate, Lisp_Object *seq, const ptrdiff_t length)
eassume (ms.pending[0].len == length);
lo = ms.pending[0].base;
- if (ms.a != ms.temparray)
+ if (reverse)
+ reverse_slice (seq, seq + length);
+
+ if (ms.a.keys != ms.temparray || allocated_keys != NULL)
unbind_to (ms.count, Qnil);
}
diff --git a/src/sound.c b/src/sound.c
index 1d40af5dfda..004015fc936 100644
--- a/src/sound.c
+++ b/src/sound.c
@@ -1386,7 +1386,7 @@ Internal use only, use `play-sound' instead. */)
/* Open the sound file. */
current_sound->fd =
openp (list1 (Vdata_directory), attrs[SOUND_FILE], Qnil, &file, Qnil,
- false, false);
+ false, false, NULL);
if (current_sound->fd < 0)
sound_perror ("Could not open sound file");
diff --git a/src/sqlite.c b/src/sqlite.c
index 7a018b28aa4..261080da673 100644
--- a/src/sqlite.c
+++ b/src/sqlite.c
@@ -349,9 +349,7 @@ bind_values (sqlite3 *db, sqlite3_stmt *stmt, Lisp_Object values)
value = XCAR (values);
values = XCDR (values);
}
- Lisp_Object type = Ftype_of (value);
-
- if (EQ (type, Qstring))
+ if (STRINGP (value))
{
Lisp_Object encoded;
bool blob = false;
@@ -385,14 +383,11 @@ bind_values (sqlite3 *db, sqlite3_stmt *stmt, Lisp_Object values)
SSDATA (encoded), SBYTES (encoded),
NULL);
}
- else if (EQ (type, Qinteger))
- {
- if (BIGNUMP (value))
- ret = sqlite3_bind_int64 (stmt, i + 1, bignum_to_intmax (value));
- else
- ret = sqlite3_bind_int64 (stmt, i + 1, XFIXNUM (value));
- }
- else if (EQ (type, Qfloat))
+ else if (FIXNUMP (value))
+ ret = sqlite3_bind_int64 (stmt, i + 1, XFIXNUM (value));
+ else if (BIGNUMP (value))
+ ret = sqlite3_bind_int64 (stmt, i + 1, bignum_to_intmax (value));
+ else if (FLOATP (value))
ret = sqlite3_bind_double (stmt, i + 1, XFLOAT_DATA (value));
else if (NILP (value))
ret = sqlite3_bind_null (stmt, i + 1);
diff --git a/src/syntax.c b/src/syntax.c
index 0f9297a46a7..a4ad61328e6 100644
--- a/src/syntax.c
+++ b/src/syntax.c
@@ -178,14 +178,14 @@ static ptrdiff_t find_start_begv;
static modiff_count find_start_modiff;
-static Lisp_Object skip_chars (bool, Lisp_Object, Lisp_Object, bool);
+static Lisp_Object skip_chars (bool, Lisp_Object, Lisp_Object);
static Lisp_Object skip_syntaxes (bool, Lisp_Object, Lisp_Object);
static Lisp_Object scan_lists (EMACS_INT, EMACS_INT, EMACS_INT, bool);
static void scan_sexps_forward (struct lisp_parse_state *,
ptrdiff_t, ptrdiff_t, ptrdiff_t, EMACS_INT,
bool, int);
static void internalize_parse_state (Lisp_Object, struct lisp_parse_state *);
-static bool in_classes (int, Lisp_Object);
+static bool in_classes (int c, int num_classes, const unsigned char *classes);
static void parse_sexp_propertize (ptrdiff_t charpos);
/* This setter is used only in this file, so it can be private. */
@@ -250,7 +250,6 @@ SETUP_SYNTAX_TABLE (ptrdiff_t from, ptrdiff_t count)
gl_state.b_property = BEGV;
gl_state.e_property = ZV + 1;
gl_state.object = Qnil;
- gl_state.offset = 0;
if (parse_sexp_lookup_properties)
{
if (count > 0)
@@ -266,46 +265,38 @@ SETUP_SYNTAX_TABLE (ptrdiff_t from, ptrdiff_t count)
/* Same as above, but in OBJECT. If OBJECT is nil, use current buffer.
If it is t (which is only used in fast_c_string_match_ignore_case),
ignore properties altogether.
-
- This is meant for regex-emacs.c to use. For buffers, regex-emacs.c
- passes arguments to the UPDATE_SYNTAX_TABLE functions which are
- relative to BEGV. So if it is a buffer, we set the offset field to
- BEGV. */
+ FROMBYTE is an regexp-byteoffset. */
void
-SETUP_SYNTAX_TABLE_FOR_OBJECT (Lisp_Object object,
- ptrdiff_t from, ptrdiff_t count)
+RE_SETUP_SYNTAX_TABLE_FOR_OBJECT (Lisp_Object object,
+ ptrdiff_t frombyte)
{
SETUP_BUFFER_SYNTAX_TABLE ();
gl_state.object = object;
if (BUFFERP (gl_state.object))
{
struct buffer *buf = XBUFFER (gl_state.object);
- gl_state.b_property = 1;
- gl_state.e_property = BUF_ZV (buf) - BUF_BEGV (buf) + 1;
- gl_state.offset = BUF_BEGV (buf) - 1;
+ gl_state.b_property = BEG;
+ gl_state.e_property = BUF_ZV (buf);
}
else if (NILP (gl_state.object))
{
- gl_state.b_property = 1;
- gl_state.e_property = ZV - BEGV + 1;
- gl_state.offset = BEGV - 1;
+ gl_state.b_property = BEG;
+ gl_state.e_property = ZV; /* FIXME: Why not +1 like in SETUP_SYNTAX_TABLE? */
}
else if (EQ (gl_state.object, Qt))
{
gl_state.b_property = 0;
gl_state.e_property = PTRDIFF_MAX;
- gl_state.offset = 0;
}
else
{
gl_state.b_property = 0;
gl_state.e_property = 1 + SCHARS (gl_state.object);
- gl_state.offset = 0;
}
if (parse_sexp_lookup_properties)
- update_syntax_table (from + gl_state.offset - (count <= 0),
- count, 1, gl_state.object);
+ update_syntax_table (RE_SYNTAX_TABLE_BYTE_TO_CHAR (frombyte),
+ 1, 1, gl_state.object);
}
/* Update gl_state to an appropriate interval which contains CHARPOS. The
@@ -341,8 +332,8 @@ update_syntax_table (ptrdiff_t charpos, EMACS_INT count, bool init,
if (!i)
return;
i = gl_state.forward_i;
- gl_state.b_property = i->position - gl_state.offset;
- gl_state.e_property = INTERVAL_LAST_POS (i) - gl_state.offset;
+ gl_state.b_property = i->position;
+ gl_state.e_property = INTERVAL_LAST_POS (i);
}
else
{
@@ -362,7 +353,7 @@ update_syntax_table (ptrdiff_t charpos, EMACS_INT count, bool init,
{
invalidate = false;
gl_state.forward_i = i;
- gl_state.e_property = INTERVAL_LAST_POS (i) - gl_state.offset;
+ gl_state.e_property = INTERVAL_LAST_POS (i);
}
}
else if (charpos >= INTERVAL_LAST_POS (i)) /* Move right. */
@@ -375,7 +366,7 @@ update_syntax_table (ptrdiff_t charpos, EMACS_INT count, bool init,
{
invalidate = false;
gl_state.backward_i = i;
- gl_state.b_property = i->position - gl_state.offset;
+ gl_state.b_property = i->position;
}
}
}
@@ -391,12 +382,12 @@ update_syntax_table (ptrdiff_t charpos, EMACS_INT count, bool init,
if (count > 0)
{
gl_state.backward_i = i;
- gl_state.b_property = i->position - gl_state.offset;
+ gl_state.b_property = i->position;
}
else
{
gl_state.forward_i = i;
- gl_state.e_property = INTERVAL_LAST_POS (i) - gl_state.offset;
+ gl_state.e_property = INTERVAL_LAST_POS (i);
}
}
@@ -426,13 +417,13 @@ update_syntax_table (ptrdiff_t charpos, EMACS_INT count, bool init,
{
if (count > 0)
{
- gl_state.e_property = i->position - gl_state.offset;
+ gl_state.e_property = i->position;
gl_state.forward_i = i;
}
else
{
gl_state.b_property
- = i->position + LENGTH (i) - gl_state.offset;
+ = i->position + LENGTH (i);
gl_state.backward_i = i;
}
return;
@@ -442,7 +433,7 @@ update_syntax_table (ptrdiff_t charpos, EMACS_INT count, bool init,
if (count > 0)
{
gl_state.e_property
- = i->position + LENGTH (i) - gl_state.offset
+ = i->position + LENGTH (i)
/* e_property at EOB is not set to ZV but to ZV+1, so that
we can do INC(from);UPDATE_SYNTAX_TABLE_FORWARD without
having to check eob between the two. */
@@ -451,7 +442,7 @@ update_syntax_table (ptrdiff_t charpos, EMACS_INT count, bool init,
}
else
{
- gl_state.b_property = i->position - gl_state.offset;
+ gl_state.b_property = i->position;
gl_state.backward_i = i;
}
return;
@@ -477,7 +468,7 @@ parse_sexp_propertize (ptrdiff_t charpos)
&& syntax_propertize__done < zv)
{
modiff_count modiffs = CHARS_MODIFF;
- safe_call1 (Qinternal__syntax_propertize,
+ safe_calln (Qinternal__syntax_propertize,
make_fixnum (min (zv, 1 + charpos)));
if (modiffs != CHARS_MODIFF)
error ("internal--syntax-propertize modified the buffer!");
@@ -1616,7 +1607,7 @@ Char classes, e.g. `[:alpha:]', are supported.
Returns the distance traveled, either zero or positive. */)
(Lisp_Object string, Lisp_Object lim)
{
- return skip_chars (1, string, lim, 1);
+ return skip_chars (1, string, lim);
}
DEFUN ("skip-chars-backward", Fskip_chars_backward, Sskip_chars_backward, 1, 2, 0,
@@ -1625,7 +1616,7 @@ See `skip-chars-forward' for details.
Returns the distance traveled, either zero or negative. */)
(Lisp_Object string, Lisp_Object lim)
{
- return skip_chars (0, string, lim, 1);
+ return skip_chars (0, string, lim);
}
DEFUN ("skip-syntax-forward", Fskip_syntax_forward, Sskip_syntax_forward, 1, 2, 0,
@@ -1652,8 +1643,7 @@ of this is the distance traveled. */)
}
static Lisp_Object
-skip_chars (bool forwardp, Lisp_Object string, Lisp_Object lim,
- bool handle_iso_classes)
+skip_chars (bool forwardp, Lisp_Object string, Lisp_Object lim)
{
int c;
char fastmap[0400];
@@ -1670,11 +1660,9 @@ skip_chars (bool forwardp, Lisp_Object string, Lisp_Object lim,
ptrdiff_t size_byte;
const unsigned char *str;
int len;
- Lisp_Object iso_classes;
USE_SAFE_ALLOCA;
CHECK_STRING (string);
- iso_classes = Qnil;
if (NILP (lim))
XSETINT (lim, forwardp ? ZV : BEGV);
@@ -1709,6 +1697,8 @@ skip_chars (bool forwardp, Lisp_Object string, Lisp_Object lim,
If STRING contains non-ASCII characters, setup char_ranges for
them and use fastmap only for their leading codes. */
+ int nclasses = 0;
+ unsigned char classes[RECC_NUM_CLASSES];
if (! string_multibyte)
{
bool string_has_eight_bit = 0;
@@ -1716,18 +1706,16 @@ skip_chars (bool forwardp, Lisp_Object string, Lisp_Object lim,
/* At first setup fastmap. */
while (i_byte < size_byte)
{
- if (handle_iso_classes)
+ const unsigned char *ch = str + i_byte;
+ re_wctype_t cc = re_wctype_parse (&ch, size_byte - i_byte);
+ if (cc == 0)
+ error ("Invalid ISO C character class");
+ if (cc != -1)
{
- const unsigned char *ch = str + i_byte;
- re_wctype_t cc = re_wctype_parse (&ch, size_byte - i_byte);
- if (cc == 0)
- error ("Invalid ISO C character class");
- if (cc != -1)
- {
- iso_classes = Fcons (make_fixnum (cc), iso_classes);
- i_byte = ch - str;
- continue;
- }
+ if (!(nclasses && memchr (classes, cc, nclasses)))
+ classes[nclasses++] = cc;
+ i_byte = ch - str;
+ continue;
}
c = str[i_byte++];
@@ -1812,18 +1800,16 @@ skip_chars (bool forwardp, Lisp_Object string, Lisp_Object lim,
{
int leading_code = str[i_byte];
- if (handle_iso_classes)
+ const unsigned char *ch = str + i_byte;
+ re_wctype_t cc = re_wctype_parse (&ch, size_byte - i_byte);
+ if (cc == 0)
+ error ("Invalid ISO C character class");
+ if (cc != -1)
{
- const unsigned char *ch = str + i_byte;
- re_wctype_t cc = re_wctype_parse (&ch, size_byte - i_byte);
- if (cc == 0)
- error ("Invalid ISO C character class");
- if (cc != -1)
- {
- iso_classes = Fcons (make_fixnum (cc), iso_classes);
- i_byte = ch - str;
- continue;
- }
+ if (!(nclasses && memchr (classes, cc, nclasses)))
+ classes[nclasses++] = cc;
+ i_byte = ch - str;
+ continue;
}
if (leading_code== '\\')
@@ -1969,7 +1955,7 @@ skip_chars (bool forwardp, Lisp_Object string, Lisp_Object lim,
stop = endp;
}
c = string_char_and_length (p, &nbytes);
- if (! NILP (iso_classes) && in_classes (c, iso_classes))
+ if (nclasses && in_classes (c, nclasses, classes))
{
if (negate)
break;
@@ -2010,7 +1996,7 @@ skip_chars (bool forwardp, Lisp_Object string, Lisp_Object lim,
stop = endp;
}
- if (!NILP (iso_classes) && in_classes (*p, iso_classes))
+ if (nclasses && in_classes (*p, nclasses, classes))
{
if (negate)
break;
@@ -2044,7 +2030,7 @@ skip_chars (bool forwardp, Lisp_Object string, Lisp_Object lim,
c = STRING_CHAR (p);
- if (! NILP (iso_classes) && in_classes (c, iso_classes))
+ if (nclasses && in_classes (c, nclasses, classes))
{
if (negate)
break;
@@ -2078,7 +2064,7 @@ skip_chars (bool forwardp, Lisp_Object string, Lisp_Object lim,
stop = endp;
}
- if (! NILP (iso_classes) && in_classes (p[-1], iso_classes))
+ if (nclasses && in_classes (p[-1], nclasses, classes))
{
if (negate)
break;
@@ -2201,8 +2187,7 @@ skip_syntaxes (bool forwardp, Lisp_Object string, Lisp_Object lim)
while (!parse_sexp_lookup_properties
|| pos < gl_state.e_property);
- update_syntax_table_forward (pos + gl_state.offset,
- false, gl_state.object);
+ update_syntax_table_forward (pos, false, gl_state.object);
}
}
else
@@ -2263,26 +2248,16 @@ skip_syntaxes (bool forwardp, Lisp_Object string, Lisp_Object lim)
}
}
-/* Return true if character C belongs to one of the ISO classes
- in the list ISO_CLASSES. Each class is represented by an
- integer which is its type according to re_wctype. */
+/* Return true if character C belongs to one of the ISO classes in the
+ array. */
static bool
-in_classes (int c, Lisp_Object iso_classes)
+in_classes (int c, int nclasses, const unsigned char *classes)
{
- bool fits_class = 0;
-
- while (CONSP (iso_classes))
- {
- Lisp_Object elt;
- elt = XCAR (iso_classes);
- iso_classes = XCDR (iso_classes);
-
- if (re_iswctype (c, XFIXNAT (elt)))
- fits_class = 1;
- }
-
- return fits_class;
+ for (int i = 0; i < nclasses; i++)
+ if (re_iswctype (c, classes[i]))
+ return true;
+ return false;
}
/* Jump over a comment, assuming we are at the beginning of one.
@@ -2348,13 +2323,16 @@ forw_comment (ptrdiff_t from, ptrdiff_t from_byte, ptrdiff_t stop,
return 0;
}
c = FETCH_CHAR_AS_MULTIBYTE (from_byte);
+ prev_syntax = syntax;
syntax = SYNTAX_WITH_FLAGS (c);
code = syntax & 0xff;
if (code == Sendcomment
&& SYNTAX_FLAGS_COMMENT_STYLE (syntax, 0) == style
&& (SYNTAX_FLAGS_COMMENT_NESTED (syntax) ?
(nesting > 0 && --nesting == 0) : nesting < 0)
- && !(comment_end_can_be_escaped && char_quoted (from, from_byte)))
+ && !(comment_end_can_be_escaped
+ && ((prev_syntax & 0xff) == Sescape
+ || (prev_syntax & 0xff) == Scharquote)))
/* We have encountered a comment end of the same style
as the comment sequence which began this comment
section. */
@@ -2378,7 +2356,11 @@ forw_comment (ptrdiff_t from, ptrdiff_t from_byte, ptrdiff_t stop,
inc_both (&from, &from_byte);
UPDATE_SYNTAX_TABLE_FORWARD (from);
if (from == stop) continue; /* Failure */
- }
+ c = FETCH_CHAR_AS_MULTIBYTE (from_byte);
+ prev_syntax = syntax;
+ syntax = Smax;
+ code = syntax;
+ }
inc_both (&from, &from_byte);
UPDATE_SYNTAX_TABLE_FORWARD (from);
@@ -3359,7 +3341,14 @@ do { prev_from = from; \
are invalid now. Luckily, the `done' doesn't use them
and the INC_FROM sets them to a sane value without
looking at them. */
- if (!found) goto done;
+ if (!found)
+ {
+ if ((prev_from_syntax & 0xff) == Sescape
+ || (prev_from_syntax & 0xff) == Scharquote)
+ goto endquoted;
+ else
+ goto done;
+ }
INC_FROM;
state->incomment = 0;
state->comstyle = 0; /* reset the comment style */
diff --git a/src/syntax.h b/src/syntax.h
index 9035348e50a..34e53775a97 100644
--- a/src/syntax.h
+++ b/src/syntax.h
@@ -85,8 +85,6 @@ struct gl_state_s
and possibly at the
intervals too, depending
on: */
- /* Offset for positions specified to UPDATE_SYNTAX_TABLE. */
- ptrdiff_t offset;
};
extern struct gl_state_s gl_state;
@@ -147,28 +145,27 @@ extern bool syntax_prefix_flag_p (int c);
extern unsigned char const syntax_spec_code[0400];
-/* Convert the byte offset BYTEPOS into a character position,
- for the object recorded in gl_state with SETUP_SYNTAX_TABLE_FOR_OBJECT.
+/* Convert the regexp's BYTEOFFSET into a character position,
+ for the object recorded in gl_state with RE_SETUP_SYNTAX_TABLE_FOR_OBJECT.
The value is meant for use in code that does nothing when
parse_sexp_lookup_properties is false, so return 0 in that case,
for speed. */
INLINE ptrdiff_t
-SYNTAX_TABLE_BYTE_TO_CHAR (ptrdiff_t bytepos)
+RE_SYNTAX_TABLE_BYTE_TO_CHAR (ptrdiff_t byteoffset)
{
return (! parse_sexp_lookup_properties
? 0
: STRINGP (gl_state.object)
- ? string_byte_to_char (gl_state.object, bytepos)
+ ? string_byte_to_char (gl_state.object, byteoffset)
: BUFFERP (gl_state.object)
? ((buf_bytepos_to_charpos
(XBUFFER (gl_state.object),
- (bytepos + BUF_BEGV_BYTE (XBUFFER (gl_state.object)) - 1)))
- - BUF_BEGV (XBUFFER (gl_state.object)) + 1)
+ (byteoffset + BUF_BEGV_BYTE (XBUFFER (gl_state.object))))))
: NILP (gl_state.object)
- ? BYTE_TO_CHAR (bytepos + BEGV_BYTE - 1) - BEGV + 1
- : bytepos);
+ ? BYTE_TO_CHAR (byteoffset + BEGV_BYTE)
+ : byteoffset);
}
/* Make syntax table state (gl_state) good for CHARPOS, assuming it is
@@ -178,8 +175,7 @@ INLINE void
UPDATE_SYNTAX_TABLE_FORWARD (ptrdiff_t charpos)
{ /* Performs just-in-time syntax-propertization. */
if (parse_sexp_lookup_properties && charpos >= gl_state.e_property)
- update_syntax_table_forward (charpos + gl_state.offset,
- false, gl_state.object);
+ update_syntax_table_forward (charpos, false, gl_state.object);
}
/* Make syntax table state (gl_state) good for CHARPOS, assuming it is
@@ -189,7 +185,7 @@ INLINE void
UPDATE_SYNTAX_TABLE_BACKWARD (ptrdiff_t charpos)
{
if (parse_sexp_lookup_properties && charpos < gl_state.b_property)
- update_syntax_table (charpos + gl_state.offset, -1, false, gl_state.object);
+ update_syntax_table (charpos, -1, false, gl_state.object);
}
/* Make syntax table good for CHARPOS. */
@@ -212,7 +208,7 @@ SETUP_BUFFER_SYNTAX_TABLE (void)
}
extern ptrdiff_t scan_words (ptrdiff_t, EMACS_INT);
-extern void SETUP_SYNTAX_TABLE_FOR_OBJECT (Lisp_Object, ptrdiff_t, ptrdiff_t);
+extern void RE_SETUP_SYNTAX_TABLE_FOR_OBJECT (Lisp_Object, ptrdiff_t);
INLINE_HEADER_END
diff --git a/src/sysdep.c b/src/sysdep.c
index ef2dc127e2a..cf2985b4b89 100644
--- a/src/sysdep.c
+++ b/src/sysdep.c
@@ -36,7 +36,6 @@ along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. */
#include <utimens.h>
#include "lisp.h"
-#include "sheap.h"
#include "sysselect.h"
#include "blockinput.h"
@@ -134,6 +133,14 @@ int _cdecl _spawnlp (int, const char *, const char *, ...);
# include <sys/socket.h>
#endif
+#ifdef HAVE_ANDROID
+#include "android.h"
+#endif
+
+#if defined HAVE_ANDROID && !defined ANDROID_STUBIFY
+#include "sfntfont.h"
+#endif
+
/* Declare here, including term.h is problematic on some systems. */
extern void tputs (const char *, int, int (*)(int));
@@ -252,7 +259,7 @@ init_standard_fds (void)
/* Set buferr if possible on platforms defining _PC_PIPE_BUF, as
they support the notion of atomic writes to pipes. */
#ifdef _PC_PIPE_BUF
- buferr = fdopen (STDERR_FILENO, "w");
+ buferr = emacs_fdopen (STDERR_FILENO, "w");
if (buferr)
setvbuf (buferr, NULL, _IOLBF, 0);
#endif
@@ -790,6 +797,7 @@ init_sigio (int fd)
#endif
}
+#ifndef HAVE_ANDROID
#ifndef DOS_NT
#ifdef F_SETOWN
static void
@@ -801,6 +809,7 @@ reset_sigio (int fd)
}
#endif /* F_SETOWN */
#endif
+#endif
void
request_sigio (void)
@@ -972,6 +981,8 @@ narrow_foreground_group (int fd)
tcsetpgrp_without_stopping (fd, getpid ());
}
+#ifndef HAVE_ANDROID
+
/* Set the tty to our original foreground group. */
static void
widen_foreground_group (int fd)
@@ -979,6 +990,9 @@ widen_foreground_group (int fd)
if (inherited_pgroup && setpgid (0, inherited_pgroup) == 0)
tcsetpgrp_without_stopping (fd, inherited_pgroup);
}
+
+#endif
+
/* Getting and setting emacs_tty structures. */
@@ -1496,6 +1510,8 @@ reset_sys_modes (struct tty_display_info *tty_out)
fflush (stdout);
return;
}
+
+#ifndef HAVE_ANDROID
if (!tty_out->term_initted)
return;
@@ -1552,6 +1568,7 @@ reset_sys_modes (struct tty_display_info *tty_out)
#endif
widen_foreground_group (fileno (tty_out->input));
+#endif
}
#ifdef HAVE_PTYS
@@ -1802,6 +1819,40 @@ handle_arith_signal (int sig)
xsignal0 (Qarith_error);
}
+#if defined HAVE_ANDROID && !defined ANDROID_STUBIFY && defined HAVE_MMAP
+
+static void
+handle_sigbus (int sig, siginfo_t *siginfo, void *arg)
+{
+ /* If this arrives during sfntfont_open, then Emacs may be
+ screwed. */
+
+ if (sfntfont_detect_sigbus (siginfo->si_addr))
+ return;
+
+ handle_fatal_signal (sig);
+}
+
+/* Try to set up SIGBUS handling for the sfnt font driver.
+ Value is 1 upon failure, 0 otherwise. */
+
+static int
+init_sigbus (void)
+{
+ struct sigaction sa;
+
+ sigfillset (&sa.sa_mask);
+ sa.sa_sigaction = handle_sigbus;
+ sa.sa_flags = SA_SIGINFO;
+
+ if (sigaction (SIGBUS, &sa, NULL))
+ return 1;
+
+ return 0;
+}
+
+#endif
+
#if defined HAVE_STACK_OVERFLOW_HANDLING && !defined WINDOWSNT
/* Alternate stack used by SIGSEGV handler below. */
@@ -1866,6 +1917,8 @@ stack_overflow (siginfo_t *siginfo)
return 0 <= top - addr && top - addr < (bot - top) >> LG_STACK_HEURISTIC;
}
+/* Signal handler for SIGSEGV before our new handler was installed. */
+static struct sigaction old_sigsegv_handler;
/* Attempt to recover from SIGSEGV caused by C stack overflow. */
@@ -1884,6 +1937,15 @@ handle_sigsegv (int sig, siginfo_t *siginfo, void *arg)
if (!fatal && stack_overflow (siginfo))
siglongjmp (return_to_command_loop, 1);
+#if defined HAVE_ANDROID && !defined ANDROID_STUBIFY
+ /* Tombstones (crash reports with stack traces) won't be generated on
+ Android unless the original SIGSEGV handler is installed and the
+ signal is resent, such as by returning from the first signal
+ handler called. */
+ sigaction (SIGSEGV, &old_sigsegv_handler, NULL);
+ return;
+#endif /* HAVE_ANDROID && ANDROID_STUBIFY */
+
/* Otherwise we can't do anything with this. */
deliver_fatal_thread_signal (sig);
}
@@ -1906,7 +1968,7 @@ init_sigsegv (void)
sigfillset (&sa.sa_mask);
sa.sa_sigaction = handle_sigsegv;
sa.sa_flags = SA_SIGINFO | SA_ONSTACK | emacs_sigaction_flags ();
- if (sigaction (SIGSEGV, &sa, NULL) < 0)
+ if (sigaction (SIGSEGV, &sa, &old_sigsegv_handler) < 0)
return 0;
return 1;
@@ -2027,12 +2089,17 @@ init_signals (void)
#endif /* __vax__ */
}
+ /* SIGUSR1 and SIGUSR2 are used internally by the android_select
+ function. */
+#if !defined HAVE_ANDROID
#ifdef SIGUSR1
add_user_signal (SIGUSR1, "sigusr1");
#endif
#ifdef SIGUSR2
add_user_signal (SIGUSR2, "sigusr2");
#endif
+#endif
+
sigaction (SIGABRT, &thread_fatal_action, 0);
#ifdef SIGPRE
sigaction (SIGPRE, &thread_fatal_action, 0);
@@ -2056,7 +2123,10 @@ init_signals (void)
sigaction (SIGEMT, &thread_fatal_action, 0);
#endif
#ifdef SIGBUS
- sigaction (SIGBUS, &thread_fatal_action, 0);
+#if defined HAVE_ANDROID && !defined ANDROID_STUBIFY && defined HAVE_MMAP
+ if (init_sigbus ())
+#endif
+ sigaction (SIGBUS, &thread_fatal_action, 0);
#endif
if (!init_sigsegv ())
sigaction (SIGSEGV, &thread_fatal_action, 0);
@@ -2313,7 +2383,8 @@ emacs_backtrace (int backtrace_limit)
}
}
-#ifndef HAVE_NTGUI
+#if !defined HAVE_NTGUI && !(defined HAVE_ANDROID \
+ && !defined ANDROID_STUBIFY)
void
emacs_abort (void)
{
@@ -2335,11 +2406,20 @@ int
emacs_fstatat (int dirfd, char const *filename, void *st, int flags)
{
int r;
- while ((r = fstatat (dirfd, filename, st, flags)) != 0 && errno == EINTR)
+#if !(defined HAVE_ANDROID && !defined ANDROID_STUBIFY)
+ while ((r = fstatat (dirfd, filename, st, flags)) != 0
+ && errno == EINTR)
+ maybe_quit ();
+#else
+ while ((r = android_fstatat (dirfd, filename, st, flags)) != 0
+ && errno == EINTR)
maybe_quit ();
+#endif
return r;
}
+#if !(defined HAVE_ANDROID && !defined ANDROID_STUBIFY)
+
static int
sys_openat (int dirfd, char const *file, int oflags, int mode)
{
@@ -2354,6 +2434,28 @@ sys_openat (int dirfd, char const *file, int oflags, int mode)
#endif
}
+#endif
+
+int
+sys_fstat (int fd, struct stat *statb)
+{
+#if !(defined HAVE_ANDROID && !defined ANDROID_STUBIFY)
+ return fstat (fd, statb);
+#else
+ return android_fstat (fd, statb);
+#endif
+}
+
+int
+sys_faccessat (int fd, const char *pathname, int mode, int flags)
+{
+#if !(defined HAVE_ANDROID && !defined ANDROID_STUBIFY)
+ return faccessat (fd, pathname, mode, flags);
+#else
+ return android_faccessat (fd, pathname, mode, flags);
+#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.
@@ -2362,6 +2464,8 @@ sys_openat (int dirfd, char const *file, int oflags, int mode)
Do not fail merely because the open was interrupted by a signal.
Allow the user to quit. */
+#if !(defined HAVE_ANDROID && !defined ANDROID_STUBIFY)
+
int
emacs_openat (int dirfd, char const *file, int oflags, int mode)
{
@@ -2374,10 +2478,23 @@ emacs_openat (int dirfd, char const *file, int oflags, int mode)
return fd;
}
+#endif
+
int
emacs_open (char const *file, int oflags, int mode)
{
+#if defined HAVE_ANDROID && !defined ANDROID_STUBIFY
+ int fd;
+#endif
+
+#if !(defined HAVE_ANDROID && !defined ANDROID_STUBIFY)
return emacs_openat (AT_FDCWD, file, oflags, mode);
+#else
+ while ((fd = android_open (file, oflags, mode)) < 0 && errno == EINTR)
+ maybe_quit ();
+
+ return fd;
+#endif
}
/* Same as above, but doesn't allow the user to quit. */
@@ -2389,9 +2506,15 @@ emacs_open_noquit (char const *file, int oflags, int mode)
if (! (oflags & O_TEXT))
oflags |= O_BINARY;
oflags |= O_CLOEXEC;
+#if !(defined HAVE_ANDROID && !defined ANDROID_STUBIFY)
do
fd = open (file, oflags, mode);
while (fd < 0 && errno == EINTR);
+#else
+ do
+ fd = android_open (file, oflags, mode);
+ while (fd < 0 && errno == EINTR);
+#endif
return fd;
}
@@ -2422,7 +2545,7 @@ emacs_fopen (char const *file, char const *mode)
}
fd = emacs_open (file, omode | oflags | bflag, 0666);
- return fd < 0 ? 0 : fdopen (fd, mode);
+ return fd < 0 ? 0 : emacs_fdopen (fd, mode);
}
/* Create a pipe for Emacs use. */
@@ -2441,6 +2564,8 @@ emacs_pipe (int fd[2])
For the background behind this mess, please see Austin Group defect 529
<https://austingroupbugs.net/view.php?id=529>. */
+#if !(defined HAVE_ANDROID && !defined ANDROID_STUBIFY)
+
#ifndef POSIX_CLOSE_RESTART
# define POSIX_CLOSE_RESTART 1
static int
@@ -2467,6 +2592,8 @@ posix_close (int fd, int flag)
}
#endif
+#endif
+
/* Close FD, retrying if interrupted. If successful, return 0;
otherwise, return -1 and set errno to a non-EINTR value. Consider
an EINPROGRESS error to be successful, as that's merely a signal
@@ -2479,9 +2606,17 @@ posix_close (int fd, int flag)
int
emacs_close (int fd)
{
+ int r;
+
while (1)
{
- int r = posix_close (fd, POSIX_CLOSE_RESTART);
+#if !(defined HAVE_ANDROID && !defined ANDROID_STUBIFY)
+ r = posix_close (fd, POSIX_CLOSE_RESTART);
+#else
+ r = android_close (fd) == 0 || errno == EINTR ? 0 : -1;
+#define POSIX_CLOSE_RESTART 1
+#endif
+
if (r == 0)
return r;
if (!POSIX_CLOSE_RESTART || errno != EINTR)
@@ -2492,6 +2627,106 @@ emacs_close (int fd)
}
}
+/* Wrapper around fdopen. On Android, this calls `android_fclose' to
+ clear information associated with FD if necessary. */
+
+FILE *
+emacs_fdopen (int fd, const char *mode)
+{
+#if !(defined HAVE_ANDROID && !defined ANDROID_STUBIFY)
+ return fdopen (fd, mode);
+#else /* !defined HAVE_ANDROID || defined ANDROID_STUBIFY */
+ return android_fdopen (fd, mode);
+#endif /* !(defined HAVE_ANDROID && !defined ANDROID_STUBIFY) */
+}
+
+/* Wrapper around fclose. On Android, this calls `android_fclose' to
+ clear information associated with the FILE's file descriptor if
+ necessary. */
+
+#if defined HAVE_ANDROID && !defined ANDROID_STUBIFY
+int
+emacs_fclose (FILE *stream)
+{
+ return android_fclose (stream);
+}
+#endif
+
+/* Wrappers around unlink, symlink, rename, renameat_noreplace, and
+ rmdir. These operations handle asset and content directories on
+ Android, and may return EINTR. */
+
+int
+emacs_unlink (const char *name)
+{
+#if !(defined HAVE_ANDROID && !defined ANDROID_STUBIFY)
+ return unlink (name);
+#else /* !defined HAVE_ANDROID || defined ANDROID_STUBIFY */
+ return android_unlink (name);
+#endif /* !(defined HAVE_ANDROID && !defined ANDROID_STUBIFY) */
+}
+
+int
+emacs_symlink (const char *target, const char *linkname)
+{
+#if !(defined HAVE_ANDROID && !defined ANDROID_STUBIFY)
+ return symlink (target, linkname);
+#else /* !defined HAVE_ANDROID || defined ANDROID_STUBIFY */
+ return android_symlink (target, linkname);
+#endif /* !(defined HAVE_ANDROID && !defined ANDROID_STUBIFY) */
+}
+
+int
+emacs_rmdir (const char *dirname)
+{
+#if !(defined HAVE_ANDROID && !defined ANDROID_STUBIFY)
+ return rmdir (dirname);
+#else /* !defined HAVE_ANDROID || defined ANDROID_STUBIFY */
+ return android_rmdir (dirname);
+#endif /* !(defined HAVE_ANDROID && !defined ANDROID_STUBIFY) */
+}
+
+int
+emacs_mkdir (const char *dirname, mode_t mode)
+{
+#if !(defined HAVE_ANDROID && !defined ANDROID_STUBIFY)
+ return mkdir (dirname, mode);
+#else /* !defined HAVE_ANDROID || defined ANDROID_STUBIFY */
+ return android_mkdir (dirname, mode);
+#endif /* !(defined HAVE_ANDROID && !defined ANDROID_STUBIFY) */
+}
+
+int
+emacs_renameat_noreplace (int srcfd, const char *src,
+ int dstfd, const char *dst)
+{
+#if !(defined HAVE_ANDROID && !defined ANDROID_STUBIFY)
+ return renameat_noreplace (srcfd, src, dstfd, dst);
+#else /* !defined HAVE_ANDROID || defined ANDROID_STUBIFY */
+ return android_renameat_noreplace (srcfd, src, dstfd, dst);
+#endif /* !(defined HAVE_ANDROID && !defined ANDROID_STUBIFY) */
+}
+
+int
+emacs_rename (const char *src, const char *dst)
+{
+#if !(defined HAVE_ANDROID && !defined ANDROID_STUBIFY)
+ return rename (src, dst);
+#else /* !defined HAVE_ANDROID || defined ANDROID_STUBIFY */
+ return android_rename (src, dst);
+#endif /* !(defined HAVE_ANDROID && !defined ANDROID_STUBIFY) */
+}
+
+int
+emacs_fchmodat (int fd, const char *path, mode_t mode, int flags)
+{
+#if !(defined HAVE_ANDROID && !defined ANDROID_STUBIFY)
+ return fchmodat (fd, path, mode, flags);
+#else /* !defined HAVE_ANDROID || defined ANDROID_STUBIFY */
+ return android_fchmodat (fd, path, mode, flags);
+#endif /* !(defined HAVE_ANDROID && !defined ANDROID_STUBIFY) */
+}
+
/* Maximum number of bytes to read or write in a single system call.
This works around a serious bug in Linux kernels before 2.6.16; see
<https://bugzilla.redhat.com/show_bug.cgi?format=multiple&id=612839>.
@@ -2660,10 +2895,11 @@ emacs_perror (char const *message)
int
renameat_noreplace (int srcfd, char const *src, int dstfd, char const *dst)
{
-#if defined SYS_renameat2 && defined RENAME_NOREPLACE
- return syscall (SYS_renameat2, srcfd, src, dstfd, dst, RENAME_NOREPLACE);
-#elif defined CYGWIN && defined RENAME_NOREPLACE
+#if HAVE_RENAMEAT2 && defined RENAME_NOREPLACE
return renameat2 (srcfd, src, dstfd, dst, RENAME_NOREPLACE);
+#elif defined SYS_renameat2 && defined RENAME_NOREPLACE
+ /* Linux kernel 3.15 (2014) or later, with glibc 2.27 (2018) or earlier. */
+ return syscall (SYS_renameat2, srcfd, src, dstfd, dst, RENAME_NOREPLACE);
#elif defined RENAME_EXCL
return renameatx_np (srcfd, src, dstfd, dst, RENAME_EXCL);
#else
@@ -2735,6 +2971,17 @@ errwrite (void const *buf, ptrdiff_t nbuf)
void
close_output_streams (void)
{
+ /* Android comes with some kind of ``file descriptor sanitizer''
+ that aborts when stdout or stderr is closed. (bug#65340)
+
+ Perform this unconditionally as long as __ANDROID__ is defined,
+ since the file descriptor sanitizer also applies to regular TTY
+ builds under Android. */
+
+#ifdef __ANDROID__
+ fflush (stderr);
+ fflush (stdout);
+#else /* !__ANDROID__ */
if (close_stream (stdout) != 0)
{
emacs_perror ("Write error to standard output");
@@ -2748,6 +2995,7 @@ close_output_streams (void)
? fflush (stderr) != 0 || ferror (stderr)
: close_stream (stderr) != 0))
_exit (EXIT_FAILURE);
+#endif /* __ANDROID__ */
}
#ifndef DOS_NT
@@ -3204,7 +3452,7 @@ make_lisp_timeval (struct timeval t)
#endif
-#if defined (GNU_LINUX) || defined (CYGWIN)
+#if defined (GNU_LINUX) || defined (CYGWIN) || defined __ANDROID__
static Lisp_Object
time_from_jiffies (unsigned long long ticks, Lisp_Object hz, Lisp_Object form)
@@ -3245,14 +3493,14 @@ get_up_time (void)
Lisp_Object subsec = Fcons (make_fixnum (upfrac), make_fixnum (hz));
up = Ftime_add (sec, subsec);
}
- fclose (fup);
+ emacs_fclose (fup);
}
unblock_input ();
return up;
}
-# ifdef GNU_LINUX
+# if defined GNU_LINUX || defined __ANDROID__
#define MAJOR(d) (((unsigned)(d) >> 8) & 0xfff)
#define MINOR(d) (((unsigned)(d) & 0xff) | (((unsigned)(d) & 0xfff00000) >> 12))
@@ -3293,12 +3541,12 @@ procfs_ttyname (int rdev)
}
}
}
- fclose (fdev);
+ emacs_fclose (fdev);
}
unblock_input ();
return build_string (name);
}
-# endif /* GNU_LINUX */
+# endif /* GNU_LINUX || __ANDROID__ */
static uintmax_t
procfs_get_total_memory (void)
@@ -3335,7 +3583,7 @@ procfs_get_total_memory (void)
}
while (!done);
- fclose (fmem);
+ emacs_fclose (fmem);
}
unblock_input ();
return retval;
@@ -3447,9 +3695,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
+# if defined GNU_LINUX || defined __ANDROID__
attrs = Fcons (Fcons (Qttname, procfs_ttyname (tty)), attrs);
-# endif
+# endif /* GNU_LINUX || __ANDROID__ */
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);
diff --git a/src/sysstdio.h b/src/sysstdio.h
index 99b4b01d7be..3a3d23ee0a8 100644
--- a/src/sysstdio.h
+++ b/src/sysstdio.h
@@ -28,8 +28,6 @@ along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. */
#include <attribute.h>
#include <unlocked-io.h>
-extern FILE *emacs_fopen (char const *, char const *)
- ATTRIBUTE_MALLOC ATTRIBUTE_DEALLOC (fclose, 1);
extern void errputc (int);
extern void errwrite (void const *, ptrdiff_t);
extern void close_output_streams (void);
diff --git a/src/term.c b/src/term.c
index dfb15afdb3f..3fa244be824 100644
--- a/src/term.c
+++ b/src/term.c
@@ -62,6 +62,8 @@ static int been_here = -1;
#include "w32term.h"
#endif
+#ifndef HAVE_ANDROID
+
static void tty_set_scroll_region (struct frame *f, int start, int stop);
static void turn_on_face (struct frame *, int face_id);
static void turn_off_face (struct frame *, int face_id);
@@ -73,19 +75,23 @@ static void clear_tty_hooks (struct terminal *terminal);
static void set_tty_hooks (struct terminal *terminal);
static void dissociate_if_controlling_tty (int fd);
static void delete_tty (struct terminal *);
+
+#endif /* !HAVE_ANDROID */
+
static AVOID maybe_fatal (bool, struct terminal *, const char *, const char *,
...)
ATTRIBUTE_FORMAT_PRINTF (3, 5) ATTRIBUTE_FORMAT_PRINTF (4, 5);
static AVOID vfatal (const char *, va_list) ATTRIBUTE_FORMAT_PRINTF (1, 0);
+#ifndef HAVE_ANDROID
#define OUTPUT(tty, a) \
- emacs_tputs ((tty), a, \
+ emacs_tputs (tty, a, \
FRAME_TOTAL_LINES (XFRAME (selected_frame)) - curY (tty), \
cmputc)
-#define OUTPUT1(tty, a) emacs_tputs ((tty), a, 1, cmputc)
-#define OUTPUTL(tty, a, lines) emacs_tputs ((tty), a, lines, cmputc)
+#define OUTPUT1(tty, a) emacs_tputs (tty, a, 1, cmputc)
+#define OUTPUTL(tty, a, lines) emacs_tputs (tty, a, lines, cmputc)
#define OUTPUT_IF(tty, a) \
do { \
@@ -93,7 +99,10 @@ static AVOID vfatal (const char *, va_list) ATTRIBUTE_FORMAT_PRINTF (1, 0);
OUTPUT (tty, a); \
} while (0)
-#define OUTPUT1_IF(tty, a) do { if (a) emacs_tputs ((tty), a, 1, cmputc); } while (0)
+#define OUTPUT1_IF(tty, a) \
+ do { if (a) emacs_tputs (tty, a, 1, cmputc); } while (0)
+
+#endif
/* Display space properties. */
@@ -117,10 +126,14 @@ enum no_color_bit
/* internal state */
+#ifndef HAVE_ANDROID
+
/* The largest frame width in any call to calculate_costs. */
static int max_frame_cols;
+#endif
+
#ifdef HAVE_GPM
@@ -133,6 +146,8 @@ struct tty_display_info *gpm_tty = NULL;
static int last_mouse_x, last_mouse_y;
#endif /* HAVE_GPM */
+#ifndef HAVE_ANDROID
+
/* Ring the bell on a tty. */
static void
@@ -533,7 +548,7 @@ encode_terminal_code (struct glyph *src, int src_len,
multibyte-form. But, it may be enlarged on demand if
Vglyph_table contains a string or a composite glyph is
encountered. */
- if (INT_MULTIPLY_WRAPV (src_len, MAX_MULTIBYTE_LENGTH, &required))
+ if (ckd_mul (&required, src_len, MAX_MULTIBYTE_LENGTH))
memory_full (SIZE_MAX);
if (encode_terminal_src_size < required)
encode_terminal_src = xpalloc (encode_terminal_src,
@@ -718,7 +733,20 @@ encode_terminal_code (struct glyph *src, int src_len,
return (encode_terminal_dst);
}
+#else /* !HAVE_ANDROID */
+unsigned char *
+encode_terminal_code (struct glyph *src, int src_len,
+ struct coding_system *coding)
+{
+ /* Text terminals are simply not supported on Android. */
+ coding->produced = 0;
+ return NULL;
+}
+
+#endif /* HAVE_ANDROID */
+
+#ifndef HAVE_ANDROID
/* An implementation of write_glyphs for termcap frames. */
@@ -1046,8 +1074,10 @@ int
string_cost (const char *str)
{
cost = 0;
+#ifndef HAVE_ANDROID
if (str)
tputs (str, 0, evalcost);
+#endif
return cost;
}
@@ -1058,8 +1088,10 @@ static int
string_cost_one_line (const char *str)
{
cost = 0;
+#ifndef HAVE_ANDROID
if (str)
tputs (str, 1, evalcost);
+#endif
return cost;
}
@@ -1070,11 +1102,13 @@ int
per_line_cost (const char *str)
{
cost = 0;
+#ifndef HAVE_ANDROID
if (str)
tputs (str, 0, evalcost);
cost = - cost;
if (str)
tputs (str, 10, evalcost);
+#endif
return cost;
}
@@ -1084,7 +1118,7 @@ per_line_cost (const char *str)
int *char_ins_del_vector;
-#define char_ins_del_cost(f) (&char_ins_del_vector[FRAME_COLS ((f))])
+#define char_ins_del_cost(f) (&char_ins_del_vector[FRAME_COLS (f)])
static void
calculate_ins_del_char_costs (struct frame *f)
@@ -1147,11 +1181,14 @@ calculate_ins_del_char_costs (struct frame *f)
*p++ = (ins_startup_cost += ins_cost_per_char);
}
+#endif
+
void
calculate_costs (struct frame *frame)
{
FRAME_COST_BAUD_RATE (frame) = baud_rate;
+#ifndef HAVE_ANDROID
if (FRAME_TERMCAP_P (frame))
{
struct tty_display_info *tty = FRAME_TTY (frame);
@@ -1206,13 +1243,15 @@ calculate_costs (struct frame *frame)
cmcostinit (FRAME_TTY (frame)); /* set up cursor motion costs */
}
+#endif
}
-struct fkey_table {
+struct fkey_table
+{
const char *cap, *name;
};
-#ifndef DOS_NT
+#if !defined DOS_NT && !defined HAVE_ANDROID
/* Termcap capability names that correspond directly to X keysyms.
Some of these (marked "terminfo") aren't supplied by old-style
(Berkeley) termcap entries. They're listed in X keysym order;
@@ -1443,6 +1482,9 @@ term_get_fkeys_1 (void)
#endif /* not DOS_NT */
+
+#ifndef HAVE_ANDROID
+
/***********************************************************************
Character Display Information
***********************************************************************/
@@ -1519,14 +1561,17 @@ append_glyph (struct it *it)
}
}
+#endif
+
/* For external use. */
void
tty_append_glyph (struct it *it)
{
+#ifndef HAVE_ANDROID
append_glyph (it);
+#endif
}
-
/* Produce glyphs for the display element described by IT. *IT
specifies what we want to produce a glyph for (character, image, ...),
and where in the glyph matrix we currently are (glyph row and hpos).
@@ -1549,6 +1594,7 @@ tty_append_glyph (struct it *it)
void
produce_glyphs (struct it *it)
{
+#ifndef HAVE_ANDROID
/* If a hook is installed, let it do the work. */
/* Nothing but characters are supported on terminal frames. */
@@ -1585,8 +1631,19 @@ produce_glyphs (struct it *it)
it->pixel_width = it->nglyphs = 0;
else if (it->char_to_display == '\t')
{
+ /* wrap-prefix strings are prepended to continuation lines, so
+ the width of tab characters inside should be computed from
+ the start of this screen line rather than as a product of the
+ total width of the physical line being wrapped. */
int absolute_x = (it->current_x
- + it->continuation_lines_width);
+ + (it->string_from_prefix_prop_p
+ /* Subtract the width of the
+ prefix from it->current_x if
+ it exists. */
+ ? 0 : (it->continuation_lines_width
+ ? (it->continuation_lines_width
+ - it->wrap_prefix_width)
+ : 0)));
int x0 = absolute_x;
/* Adjust for line numbers. */
if (!NILP (Vdisplay_line_numbers) && it->line_number_produced_p)
@@ -1658,11 +1715,20 @@ produce_glyphs (struct it *it)
/* Advance current_x by the pixel width as a convenience for
the caller. */
if (it->area == TEXT_AREA)
- it->current_x += it->pixel_width;
+ {
+ it->current_x += it->pixel_width;
+
+ if (it->continuation_lines_width
+ && it->string_from_prefix_prop_p)
+ it->wrap_prefix_width = it->current_x;
+ }
it->ascent = it->max_ascent = it->phys_ascent = it->max_phys_ascent = 0;
it->descent = it->max_descent = it->phys_descent = it->max_phys_descent = 1;
+#endif
}
+#ifndef HAVE_ANDROID
+
/* Append glyphs to IT's glyph_row for the composition IT->cmp_id.
Called from produce_composite_glyph for terminal frames if
IT->glyph_row != NULL. IT->face_id contains the character's
@@ -2020,6 +2086,7 @@ turn_off_face (struct frame *f, int face_id)
OUTPUT1_IF (tty, tty->TS_orig_pair);
}
+#endif /* !HAVE_ANDROID */
/* Return true if the terminal on frame F supports all of the
capabilities in CAPS simultaneously. */
@@ -2027,8 +2094,9 @@ turn_off_face (struct frame *f, int face_id)
bool
tty_capable_p (struct tty_display_info *tty, unsigned int caps)
{
+#ifndef HAVE_ANDROID
#define TTY_CAPABLE_P_TRY(tty, cap, TS, NC_bit) \
- if ((caps & (cap)) && (!(TS) || !MAY_USE_WITH_COLORS_P(tty, NC_bit))) \
+ if ((caps & (cap)) && (!(TS) || !MAY_USE_WITH_COLORS_P (tty, NC_bit))) \
return 0;
TTY_CAPABLE_P_TRY (tty,
@@ -2048,6 +2116,9 @@ tty_capable_p (struct tty_display_info *tty, unsigned int caps)
/* We can do it! */
return 1;
+#else
+ return false;
+#endif
}
/* Return non-zero if the terminal is capable to display colors. */
@@ -2081,7 +2152,7 @@ TERMINAL does not refer to a text terminal. */)
return make_fixnum (t ? t->display_info.tty->TN_max_colors : 0);
}
-#ifndef DOS_NT
+#if !defined DOS_NT && !defined HAVE_ANDROID
/* Declare here rather than in the function, as in the rest of Emacs,
to work around an HPUX compiler bug (?). See
@@ -2182,11 +2253,11 @@ set_tty_color_mode (struct tty_display_info *tty, struct frame *f)
tty->previous_color_mode = mode;
tty_setup_colors (tty , mode);
/* This recomputes all the faces given the new color definitions. */
- safe_call (1, intern ("tty-set-up-initial-frame-faces"));
+ safe_calln (intern ("tty-set-up-initial-frame-faces"));
}
}
-#endif /* !DOS_NT */
+#endif /* !DOS_NT && !HAVE_ANDROID */
char *
tty_type_name (Lisp_Object terminal)
@@ -2278,6 +2349,7 @@ suspended.
A suspended tty may be resumed by calling `resume-tty' on it. */)
(Lisp_Object tty)
{
+#ifndef HAVE_ANDROID
struct terminal *t = decode_tty_terminal (tty);
FILE *f;
@@ -2300,9 +2372,9 @@ A suspended tty may be resumed by calling `resume-tty' on it. */)
#ifndef MSDOS
if (f != t->display_info.tty->output)
- fclose (t->display_info.tty->output);
- fclose (f);
-#endif
+ emacs_fclose (t->display_info.tty->output);
+ emacs_fclose (f);
+#endif /* !MSDOS */
t->display_info.tty->input = 0;
t->display_info.tty->output = 0;
@@ -2314,6 +2386,11 @@ A suspended tty may be resumed by calling `resume-tty' on it. */)
/* Clear display hooks to prevent further output. */
clear_tty_hooks (t);
+#else /* HAVE_ANDROID */
+ /* Android doesn't support TTY terminal devices, so unconditionally
+ signal. */
+ error ("Attempt to suspend a non-text terminal device");
+#endif /* !HAVE_ANDROID */
return Qnil;
}
@@ -2337,9 +2414,12 @@ TTY may be a terminal object, a frame, or nil (meaning the selected
frame's terminal). */)
(Lisp_Object tty)
{
- struct terminal *t = decode_tty_terminal (tty);
+#ifndef HAVE_ANDROID
+ struct terminal *t;
int fd;
+ t = decode_tty_terminal (tty);
+
if (!t)
error ("Attempt to resume a non-text terminal device");
@@ -2354,7 +2434,7 @@ frame's terminal). */)
#else /* !MSDOS */
fd = emacs_open (t->display_info.tty->name, O_RDWR | O_NOCTTY, 0);
t->display_info.tty->input = t->display_info.tty->output
- = fd < 0 ? 0 : fdopen (fd, "w+");
+ = fd < 0 ? 0 : emacs_fdopen (fd, "w+");
if (! t->display_info.tty->input)
{
@@ -2367,7 +2447,7 @@ frame's terminal). */)
if (!O_IGNORE_CTTY && strcmp (t->display_info.tty->name, DEV_TTY) != 0)
dissociate_if_controlling_tty (fd);
-#endif
+#endif /* MSDOS */
add_keyboard_wait_descriptor (fd);
@@ -2396,10 +2476,17 @@ frame's terminal). */)
}
set_tty_hooks (t);
+#else /* HAVE_ANDROID */
+ /* Android doesn't support TTY terminal devices, so unconditionally
+ signal. */
+ error ("Attempt to suspend a non-text terminal device");
+#endif /* !HAVE_ANDROID */
return Qnil;
}
+#ifndef HAVE_ANDROID
+
DEFUN ("tty--set-output-buffer-size", Ftty__set_output_buffer_size,
Stty__set_output_buffer_size, 1, 2, 0, doc:
/* Set the output buffer size for a TTY.
@@ -2438,12 +2525,14 @@ A value of zero means TTY uses the system's default value. */)
error ("Not a tty terminal");
}
+#endif /* !HAVE_ANDROID */
+
/***********************************************************************
Mouse
***********************************************************************/
-#ifndef DOS_NT
+#if !defined DOS_NT && !defined HAVE_ANDROID
/* Implementation of draw_row_with_mouse_face for TTY/GPM and macOS. */
void
@@ -2713,7 +2802,7 @@ DEFUN ("gpm-mouse-stop", Fgpm_mouse_stop, Sgpm_mouse_stop,
Menus
***********************************************************************/
-#if !defined (MSDOS)
+#if !defined (MSDOS) && !defined HAVE_ANDROID
/* TTY menu implementation and main ideas are borrowed from msdos.c.
@@ -3319,7 +3408,7 @@ tty_menu_activate (tty_menu *menu, int *pane, int *selidx,
active submenu. */
if (i != statecount - 2
|| state[i].menu->submenu[dy] != state[i + 1].menu)
- while (i != statecount - 1)
+ while (i < statecount - 1)
{
statecount--;
screen_update (sf, state[statecount].screen_behind);
@@ -3813,10 +3902,12 @@ tty_menu_show (struct frame *f, int x, int y, int menuflags,
return SAFE_FREE_UNBIND_TO (specpdl_count, entry);
}
-#endif /* !MSDOS */
+#endif /* !MSDOS && !defined HAVE_ANDROID */
-#ifndef MSDOS
+
+#if !defined MSDOS && !defined HAVE_ANDROID
+
/***********************************************************************
Initialization
***********************************************************************/
@@ -3846,7 +3937,7 @@ tty_free_frame_resources (struct frame *f)
xfree (f->output_data.tty);
}
-#else /* MSDOS */
+#elif defined MSDOS
/* Delete frame F's face cache. */
@@ -3856,8 +3947,13 @@ tty_free_frame_resources (struct frame *f)
eassert (FRAME_TERMCAP_P (f) || FRAME_MSDOS_P (f));
free_frame_faces (f);
}
-#endif /* MSDOS */
+
+#endif
+
+
+#ifndef HAVE_ANDROID
+
/* Reset the hooks in TERMINAL. */
static void
@@ -3952,6 +4048,8 @@ dissociate_if_controlling_tty (int fd)
}
}
+#endif /* !HAVE_ANDROID */
+
/* Create a termcap display on the tty device with the given name and
type.
@@ -3961,11 +4059,23 @@ dissociate_if_controlling_tty (int fd)
TERMINAL_TYPE is the termcap type of the device, e.g. "vt100".
- If MUST_SUCCEED is true, then all errors are fatal. */
+ If MUST_SUCCEED is true, then all errors are fatal. This function
+ always signals on Android, where text terminals are prohibited by
+ system policy (and the required libraries are usually not
+ available.) */
+
+#ifdef HAVE_ANDROID
+_Noreturn
+#endif
struct terminal *
init_tty (const char *name, const char *terminal_type, bool must_succeed)
{
+#ifdef HAVE_ANDROID
+ maybe_fatal (must_succeed, 0, "Text terminals are not supported"
+ " under Android", "Text terminals are not supported"
+ " under Android");
+#else
struct tty_display_info *tty = NULL;
struct terminal *terminal = NULL;
#ifndef DOS_NT
@@ -4039,7 +4149,7 @@ init_tty (const char *name, const char *terminal_type, bool must_succeed)
tty->input = tty->output
= ((fd < 0 || ! isatty (fd))
? NULL
- : fdopen (fd, "w+"));
+ : emacs_fdopen (fd, "w+"));
if (! tty->input)
{
@@ -4455,6 +4565,7 @@ use the Bourne shell command 'TERM=...; export TERM' (C-shell:\n\
init_sys_modes (tty);
return terminal;
+#endif /* !HAVE_ANDROID */
}
@@ -4479,8 +4590,13 @@ maybe_fatal (bool must_succeed, struct terminal *terminal,
{
va_list ap;
va_start (ap, str2);
+
+#ifndef HAVE_ANDROID
if (terminal)
delete_tty (terminal);
+#else
+ eassert (terminal == NULL);
+#endif
if (must_succeed)
vfatal (str2, ap);
@@ -4498,6 +4614,8 @@ fatal (const char *str, ...)
+#ifndef HAVE_ANDROID
+
/* Delete the given tty terminal, closing all frames on it. */
static void
@@ -4543,25 +4661,27 @@ delete_tty (struct terminal *terminal)
{
delete_keyboard_wait_descriptor (fileno (tty->input));
if (tty->input != stdin)
- fclose (tty->input);
+ emacs_fclose (tty->input);
}
if (tty->output && tty->output != stdout && tty->output != tty->input)
- fclose (tty->output);
+ emacs_fclose (tty->output);
if (tty->termscript)
- fclose (tty->termscript);
+ emacs_fclose (tty->termscript);
xfree (tty->old_tty);
xfree (tty->Wcm);
xfree (tty);
}
+#endif
+
void
syms_of_term (void)
{
DEFVAR_BOOL ("system-uses-terminfo", system_uses_terminfo,
doc: /* Non-nil means the system uses terminfo rather than termcap.
This variable can be used by terminal emulator packages. */);
-#ifdef TERMINFO
+#if defined TERMINFO || (defined HAVE_ANDROID && !defined ANDROID_STUBIFY)
system_uses_terminfo = 1;
#else
system_uses_terminfo = 0;
@@ -4602,21 +4722,25 @@ trigger redisplay. */);
defsubr (&Stty_top_frame);
defsubr (&Ssuspend_tty);
defsubr (&Sresume_tty);
+#ifndef HAVE_ANDROID
defsubr (&Stty__set_output_buffer_size);
defsubr (&Stty__output_buffer_size);
+#endif /* !HAVE_ANDROID */
#ifdef HAVE_GPM
defsubr (&Sgpm_mouse_start);
defsubr (&Sgpm_mouse_stop);
#endif /* HAVE_GPM */
-#ifndef DOS_NT
+#if !defined DOS_NT && !defined HAVE_ANDROID
default_orig_pair = NULL;
default_set_foreground = NULL;
default_set_background = NULL;
-#endif /* !DOS_NT */
+#endif /* !DOS_NT && !HAVE_ANDROID */
+#ifndef HAVE_ANDROID
encode_terminal_src = NULL;
encode_terminal_dst = NULL;
+#endif
DEFSYM (Qtty_mode_set_strings, "tty-mode-set-strings");
DEFSYM (Qtty_mode_reset_strings, "tty-mode-reset-strings");
diff --git a/src/termcap.c b/src/termcap.c
index 4d1aac7c502..a8c1cef2456 100644
--- a/src/termcap.c
+++ b/src/termcap.c
@@ -296,7 +296,7 @@ tputs (register const char *str, int nlines, int (*outfun) (int))
BAUD_RATE is measured in characters per 10 seconds.
Compute PADFACTOR = 100000 * (how many padding bytes are needed). */
intmax_t padfactor;
- if (INT_MULTIPLY_WRAPV (padcount, baud_rate, &padfactor))
+ if (ckd_mul (&padfactor, padcount, baud_rate))
padfactor = baud_rate < 0 ? INTMAX_MIN : INTMAX_MAX;
for (; 50000 <= padfactor; padfactor -= 100000)
diff --git a/src/termhooks.h b/src/termhooks.h
index 2fc04250155..d828c62ce33 100644
--- a/src/termhooks.h
+++ b/src/termhooks.h
@@ -63,7 +63,8 @@ enum output_method
output_w32,
output_ns,
output_pgtk,
- output_haiku
+ output_haiku,
+ output_android,
};
/* Input queue declarations and hooks. */
@@ -307,7 +308,11 @@ enum event_kind
In TOUCHSCREEN_BEGIN_EVENT and TOUCHSCREEN_END_EVENT, ARG is the
unique ID of the touchpoint, and X and Y are the frame-relative
- positions of the touchpoint. */
+ positions of the touchpoint.
+
+ In TOUCHSCREEN_END_EVENT, non-0 modifiers means that the
+ touchpoint has been canceled. (See (elisp)Touchscreen
+ Events.) */
, TOUCHSCREEN_UPDATE_EVENT
, TOUCHSCREEN_BEGIN_EVENT
@@ -332,6 +337,16 @@ enum event_kind
monitor configuration changed. .timestamp gives the time on
which the monitors changed. */
, MONITORS_CHANGED_EVENT
+
+#ifdef HAVE_HAIKU
+ /* In a NOTIFICATION_CLICKED_EVENT, .arg is an integer identifying
+ the notification that was clicked. */
+ , NOTIFICATION_CLICKED_EVENT
+#endif /* HAVE_HAIKU */
+#ifdef HAVE_ANDROID
+ /* In a NOTIFICATION_EVENT, .arg is a lambda to evaluate. */
+ , NOTIFICATION_EVENT
+#endif /* HAVE_ANDROID */
};
/* Bit width of an enum event_kind tag at the start of structs and unions. */
@@ -516,12 +531,13 @@ struct terminal
/* Device-type dependent data shared amongst all frames on this terminal. */
union display_info
{
- struct tty_display_info *tty; /* termchar.h */
- struct x_display_info *x; /* xterm.h */
- struct w32_display_info *w32; /* w32term.h */
- struct ns_display_info *ns; /* nsterm.h */
- struct pgtk_display_info *pgtk; /* pgtkterm.h */
- struct haiku_display_info *haiku; /* haikuterm.h */
+ struct tty_display_info *tty; /* termchar.h */
+ struct x_display_info *x; /* xterm.h */
+ struct w32_display_info *w32; /* w32term.h */
+ struct ns_display_info *ns; /* nsterm.h */
+ struct pgtk_display_info *pgtk; /* pgtkterm.h */
+ struct haiku_display_info *haiku; /* haikuterm.h */
+ struct android_display_info *android; /* androidterm.h */
} display_info;
@@ -595,7 +611,8 @@ struct terminal
BGCOLOR. */
void (*query_frame_background_color) (struct frame *f, Emacs_Color *bgcolor);
-#if defined (HAVE_X_WINDOWS) || defined (HAVE_NTGUI) || defined (HAVE_PGTK)
+#if defined (HAVE_X_WINDOWS) || defined (HAVE_NTGUI) || defined (HAVE_PGTK) \
+ || defined (HAVE_ANDROID)
/* On frame F, translate pixel colors to RGB values for the NCOLORS
colors in COLORS. Use cached information, if available. */
@@ -930,6 +947,9 @@ extern struct terminal *terminal_list;
#elif defined (HAVE_HAIKU)
#define TERMINAL_FONT_CACHE(t) \
(t->type == output_haiku ? t->display_info.haiku->name_list_element : Qnil)
+#elif defined (HAVE_ANDROID)
+#define TERMINAL_FONT_CACHE(t) \
+ (t->type == output_android ? t->display_info.android->name_list_element : Qnil)
#endif
extern struct terminal *decode_live_terminal (Lisp_Object);
diff --git a/src/terminal.c b/src/terminal.c
index 48fc426273a..23a5582d4d9 100644
--- a/src/terminal.c
+++ b/src/terminal.c
@@ -389,7 +389,7 @@ but if the second argument FORCE is non-nil, you may do so. */)
Qdelete_terminal_functions, terminal),
pending_funcalls);
else
- safe_call2 (Qrun_hook_with_args, Qdelete_terminal_functions, terminal);
+ safe_calln (Qrun_hook_with_args, Qdelete_terminal_functions, terminal);
if (t->delete_terminal_hook)
(*t->delete_terminal_hook) (t);
@@ -451,6 +451,8 @@ return values. */)
return Qpgtk;
case output_haiku:
return Qhaiku;
+ case output_android:
+ return Qandroid;
default:
emacs_abort ();
}
diff --git a/src/textconv.c b/src/textconv.c
new file mode 100644
index 00000000000..9625c884e16
--- /dev/null
+++ b/src/textconv.c
@@ -0,0 +1,2374 @@
+/* String conversion support for graphics terminals.
+
+Copyright (C) 2023-2024 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 <https://www.gnu.org/licenses/>. */
+
+/* String conversion support.
+
+ Many input methods require access to text surrounding the cursor.
+ They may then request that the text editor remove or substitute
+ that text for something else, for example when providing the
+ ability to ``undo'' or ``edit'' previously composed text. This is
+ most commonly seen in input methods for CJK languages for X Windows,
+ and is extensively used throughout Android by input methods for all
+ kinds of scripts.
+
+ In addition, these input methods may also need to make detailed
+ edits to the content of a buffer. That is also handled here. */
+
+#include <config.h>
+
+#include "textconv.h"
+#include "buffer.h"
+#include "syntax.h"
+#include "blockinput.h"
+#include "keyboard.h"
+
+
+
+/* Define debugging macros. */
+
+#if defined HAVE_ANDROID && !defined ANDROID_STUBIFY
+#if 0
+#include <android/log.h>
+
+#define TEXTCONV_DEBUG(fmt, ...) \
+ __android_log_print (ANDROID_LOG_VERBOSE, "EmacsInputConnection", \
+ "%s: " fmt, __func__, ## __VA_ARGS__)
+#endif /* 0 */
+#endif /* defined HAVE_ANDROID && !defined ANDROID_STUBIFY */
+
+#ifndef TEXTCONV_DEBUG
+#define TEXTCONV_DEBUG(...) ((void) 0)
+#endif /* TEXTCONV_DEBUG */
+
+
+
+/* The window system's text conversion interface. NULL when the
+ window system has not set up text conversion. */
+
+static struct textconv_interface *text_interface;
+
+/* How many times text conversion has been disabled. */
+
+static int suppress_conversion_count;
+
+/* Flags used to determine what must be sent after a batch edit
+ ends. */
+
+enum textconv_batch_edit_flags
+ {
+ PENDING_POINT_CHANGE = 1,
+ PENDING_COMPOSE_CHANGE = 2,
+ };
+
+
+
+/* Copy the portion of the current buffer's text described by BEG,
+ BEG_BYTE, END, END_BYTE to the char * buffer BUFFER, which should
+ be at least END_BYTE - BEG_BYTEs long. */
+
+static void
+copy_buffer_text (ptrdiff_t beg, ptrdiff_t beg_byte,
+ ptrdiff_t end, ptrdiff_t end_byte,
+ char *buffer)
+{
+ ptrdiff_t beg0, end0, beg1, end1, size;
+
+ if (beg_byte < GPT_BYTE && GPT_BYTE < end_byte)
+ {
+ /* Two regions, before and after the gap. */
+ beg0 = beg_byte;
+ end0 = GPT_BYTE;
+ beg1 = GPT_BYTE + GAP_SIZE - BEG_BYTE;
+ end1 = end_byte + GAP_SIZE - BEG_BYTE;
+ }
+ else
+ {
+ /* The only region. */
+ beg0 = beg_byte;
+ end0 = end_byte;
+ beg1 = -1;
+ end1 = -1;
+ }
+
+ size = end0 - beg0;
+ memcpy (buffer, BYTE_POS_ADDR (beg0), size);
+ if (beg1 != -1)
+ memcpy (buffer + size, BEG_ADDR + beg1, end1 - beg1);
+}
+
+
+
+/* Conversion query. */
+
+/* Return the position of the active mark, or -1 if there is no mark
+ or it is not active. */
+
+static ptrdiff_t
+get_mark (void)
+{
+ if (!NILP (BVAR (current_buffer, mark_active))
+ && XMARKER (BVAR (current_buffer, mark))->buffer)
+ return marker_position (BVAR (current_buffer,
+ mark));
+
+ return -1;
+}
+
+/* Like Fselect_window. However, if WINDOW is a minibuffer window
+ but not the active minibuffer window, select its frame's selected
+ window instead. */
+
+static void
+select_window (Lisp_Object window, Lisp_Object norecord)
+{
+ struct window *w;
+
+ w = XWINDOW (window);
+
+ if (MINI_WINDOW_P (w)
+ && WINDOW_LIVE_P (window)
+ && !EQ (window, Factive_minibuffer_window ()))
+ window = WINDOW_XFRAME (w)->selected_window;
+
+ Fselect_window (window, norecord);
+}
+
+/* Perform the text conversion operation specified in QUERY and return
+ the results.
+
+ Find the text between QUERY->position from point on frame F's
+ selected window and QUERY->factor times QUERY->direction from that
+ position. Return it in QUERY->text.
+
+ If QUERY->position is TYPE_MINIMUM (EMACS_INT) or EMACS_INT_MAX,
+ start at the window's last point or mark, whichever is greater or
+ smaller.
+
+ Then, either delete that text from the buffer if QUERY->operation
+ is TEXTCONV_SUBSTITUTION, or return 0.
+
+ If FLAGS & TEXTCONV_SKIP_CONVERSION_REGION, then first move point
+ past the conversion region in the specified direction if it is
+ inside.
+
+ Value is 0 if QUERY->operation was not TEXTCONV_SUBSTITUTION
+ or if deleting the text was successful, and 1 otherwise. */
+
+int
+textconv_query (struct frame *f, struct textconv_callback_struct *query,
+ int flags)
+{
+ specpdl_ref count;
+ ptrdiff_t pos, pos_byte, end, end_byte, start;
+ ptrdiff_t temp, temp1, mark;
+ char *buffer;
+ struct window *w;
+
+ /* Save the excursion, as there will be extensive changes to the
+ selected window. */
+ count = SPECPDL_INDEX ();
+ record_unwind_protect_excursion ();
+
+ /* Inhibit quitting. */
+ specbind (Qinhibit_quit, Qt);
+
+ /* Temporarily switch to F's selected window at the time of the last
+ redisplay. */
+ select_window ((WINDOW_LIVE_P (f->old_selected_window)
+ ? f->old_selected_window
+ : f->selected_window), Qt);
+ w = XWINDOW (selected_window);
+
+ /* Now find the appropriate text bounds for QUERY. First, move
+ point QUERY->position steps forward or backwards. */
+
+ pos = PT;
+
+ /* If QUERY->position is EMACS_INT_MAX, use the last mark or the
+ ephemeral last point, whichever is greater.
+
+ The opposite applies for EMACS_INT_MIN. */
+
+ mark = get_mark ();
+
+ if (query->position == EMACS_INT_MAX)
+ {
+ pos = (mark == -1
+ ? w->ephemeral_last_point
+ : max (w->ephemeral_last_point, mark));
+ goto escape1;
+ }
+ else if (query->position == TYPE_MINIMUM (EMACS_INT))
+ {
+ pos = (mark == -1
+ ? w->ephemeral_last_point
+ : min (w->ephemeral_last_point, mark));
+ goto escape1;
+ }
+
+ /* Next, if POS lies within the conversion region and the caller
+ asked for it to be moved away, move it away from the conversion
+ region. */
+
+ if (flags & TEXTCONV_SKIP_CONVERSION_REGION
+ && MARKERP (f->conversion.compose_region_start))
+ {
+ start = marker_position (f->conversion.compose_region_start);
+ end = marker_position (f->conversion.compose_region_end);
+
+ if (pos >= start && pos < end)
+ {
+ switch (query->direction)
+ {
+ case TEXTCONV_FORWARD_CHAR:
+ case TEXTCONV_FORWARD_WORD:
+ case TEXTCONV_CARET_DOWN:
+ case TEXTCONV_NEXT_LINE:
+ case TEXTCONV_LINE_START:
+ pos = end;
+ break;
+
+ default:
+ pos = max (BEGV, start - 1);
+ break;
+ }
+ }
+ }
+
+ /* If pos is outside the accessible part of the buffer or if it
+ overflows, move back to point or to the extremes of the
+ accessible region. */
+
+ if (ckd_add (&pos, pos, query->position))
+ pos = PT;
+
+ escape1:
+
+ if (pos < BEGV)
+ pos = BEGV;
+
+ if (pos > ZV)
+ pos = ZV;
+
+ /* Move to pos. */
+ set_point (pos);
+ pos = PT;
+ pos_byte = PT_BYTE;
+
+ /* Now scan forward or backwards according to what is in QUERY. */
+
+ switch (query->direction)
+ {
+ case TEXTCONV_FORWARD_CHAR:
+ /* Move forward by query->factor characters. */
+ if (ckd_add (&end, pos, query->factor) || end > ZV)
+ end = ZV;
+
+ end_byte = CHAR_TO_BYTE (end);
+ break;
+
+ case TEXTCONV_BACKWARD_CHAR:
+ /* Move backward by query->factor characters. */
+ if (ckd_sub (&end, pos, query->factor) || end < BEGV)
+ end = BEGV;
+
+ end_byte = CHAR_TO_BYTE (end);
+ break;
+
+ case TEXTCONV_FORWARD_WORD:
+ /* Move forward by query->factor words. */
+ end = scan_words (pos, (EMACS_INT) query->factor);
+
+ if (!end)
+ {
+ end = ZV;
+ end_byte = ZV_BYTE;
+ }
+ else
+ end_byte = CHAR_TO_BYTE (end);
+
+ break;
+
+ case TEXTCONV_BACKWARD_WORD:
+ /* Move backwards by query->factor words. */
+ end = scan_words (pos, 0 - (EMACS_INT) query->factor);
+
+ if (!end)
+ {
+ end = BEGV;
+ end_byte = BEGV_BYTE;
+ }
+ else
+ end_byte = CHAR_TO_BYTE (end);
+
+ break;
+
+ case TEXTCONV_CARET_UP:
+ /* Move upwards one visual line, keeping the column intact. */
+ Fvertical_motion (Fcons (Fcurrent_column (), make_fixnum (-1)),
+ Qnil, Qnil);
+ end = PT;
+ end_byte = PT_BYTE;
+ break;
+
+ case TEXTCONV_CARET_DOWN:
+ /* Move downwards one visual line, keeping the column
+ intact. */
+ Fvertical_motion (Fcons (Fcurrent_column (), make_fixnum (1)),
+ Qnil, Qnil);
+ end = PT;
+ end_byte = PT_BYTE;
+ break;
+
+ case TEXTCONV_NEXT_LINE:
+ /* Move one line forward. */
+ scan_newline (pos, pos_byte, ZV, ZV_BYTE,
+ query->factor, false);
+ end = PT;
+ end_byte = PT_BYTE;
+ break;
+
+ case TEXTCONV_PREVIOUS_LINE:
+ /* Move one line backwards. */
+ scan_newline (pos, pos_byte, BEGV, BEGV_BYTE,
+ 0 - (EMACS_INT) query->factor, false);
+ end = PT;
+ end_byte = PT_BYTE;
+ break;
+
+ case TEXTCONV_LINE_START:
+ /* Move to the beginning of the line. */
+ Fbeginning_of_line (Qnil);
+ end = PT;
+ end_byte = PT_BYTE;
+ break;
+
+ case TEXTCONV_LINE_END:
+ /* Move to the end of the line. */
+ Fend_of_line (Qnil);
+ end = PT;
+ end_byte = PT_BYTE;
+ break;
+
+ case TEXTCONV_ABSOLUTE_POSITION:
+ /* How to implement this is unclear. */
+ SET_PT (query->factor);
+ end = PT;
+ end_byte = PT_BYTE;
+ break;
+
+ default:
+ unbind_to (count, Qnil);
+ return 1;
+ }
+
+ /* Sort end and pos. */
+
+ if (end < pos)
+ {
+ eassert (end_byte < pos_byte);
+ temp = pos_byte;
+ temp1 = pos;
+ pos_byte = end_byte;
+ pos = end;
+ end = temp1;
+ end_byte = temp;
+ }
+
+ /* Return the string first. */
+ buffer = xmalloc (end_byte - pos_byte);
+ copy_buffer_text (pos, pos_byte, end, end_byte, buffer);
+ query->text.text = buffer;
+ query->text.length = end - pos;
+ query->text.bytes = end_byte - pos_byte;
+
+ /* Next, perform any operation specified. */
+
+ switch (query->operation)
+ {
+ case TEXTCONV_SUBSTITUTION:
+ if (safe_del_range (pos, end))
+ {
+ /* Undo any changes to the excursion. */
+ unbind_to (count, Qnil);
+ return 1;
+ }
+
+ default:
+ break;
+ }
+
+ /* Undo any changes to the excursion. */
+ unbind_to (count, Qnil);
+ return 0;
+}
+
+/* Update the overlay displaying the conversion area on frame F after
+ a change to the conversion region. */
+
+static void
+sync_overlay (struct frame *f)
+{
+ if (MARKERP (f->conversion.compose_region_start)
+ && !NILP (Vtext_conversion_face))
+ {
+ if (NILP (f->conversion.compose_region_overlay))
+ {
+ f->conversion.compose_region_overlay
+ = Fmake_overlay (f->conversion.compose_region_start,
+ f->conversion.compose_region_end, Qnil,
+ Qt, Qnil);
+ Foverlay_put (f->conversion.compose_region_overlay,
+ Qface, Vtext_conversion_face);
+ }
+
+ Fmove_overlay (f->conversion.compose_region_overlay,
+ f->conversion.compose_region_start,
+ f->conversion.compose_region_end, Qnil);
+ }
+ else if (!NILP (f->conversion.compose_region_overlay))
+ {
+ Fdelete_overlay (f->conversion.compose_region_overlay);
+ f->conversion.compose_region_overlay = Qnil;
+ }
+}
+
+/* Record a change to the current buffer as a result of an
+ asynchronous text conversion operation.
+
+ Consult the doc string of `text-conversion-edits' for the meaning
+ of BEG, END, and EPHEMERAL. */
+
+static void
+record_buffer_change (ptrdiff_t beg, ptrdiff_t end,
+ Lisp_Object ephemeral)
+{
+ Lisp_Object buffer, beg_marker, end_marker;
+
+ XSETBUFFER (buffer, current_buffer);
+
+ /* Make markers for both BEG and END. */
+ beg_marker = build_marker (current_buffer, beg,
+ CHAR_TO_BYTE (beg));
+
+ /* If BEG and END are identical, make sure to keep the markers
+ eq. */
+
+ if (beg == end)
+ end_marker = beg_marker;
+ else
+ {
+ end_marker = build_marker (current_buffer, end,
+ CHAR_TO_BYTE (end));
+
+ /* Otherwise, make sure the marker extends past inserted
+ text. */
+ Fset_marker_insertion_type (end_marker, Qt);
+ }
+
+ Vtext_conversion_edits
+ = Fcons (list4 (buffer, beg_marker, end_marker,
+ ephemeral),
+ Vtext_conversion_edits);
+}
+
+/* Reset text conversion state of frame F. Delete any overlays or
+ markers inside. */
+
+void
+reset_frame_state (struct frame *f)
+{
+ struct text_conversion_action *last, *next;
+
+ /* Make the composition region markers point elsewhere. */
+
+ if (!NILP (f->conversion.compose_region_start))
+ {
+ Fset_marker (f->conversion.compose_region_start, Qnil, Qnil);
+ Fset_marker (f->conversion.compose_region_end, Qnil, Qnil);
+ f->conversion.compose_region_start = Qnil;
+ f->conversion.compose_region_end = Qnil;
+ }
+
+ /* Delete the composition region overlay. */
+
+ if (!NILP (f->conversion.compose_region_overlay))
+ Fdelete_overlay (f->conversion.compose_region_overlay);
+
+ /* Delete each text conversion action queued up. */
+
+ next = f->conversion.actions;
+ while (next)
+ {
+ last = next;
+ next = next->next;
+
+ /* Say that the conversion is finished. */
+ if (text_interface && text_interface->notify_conversion)
+ text_interface->notify_conversion (last->counter);
+
+ xfree (last);
+ }
+ f->conversion.actions = NULL;
+
+ /* Clear batch edit state. */
+ f->conversion.batch_edit_count = 0;
+ f->conversion.batch_edit_flags = 0;
+}
+
+/* Return whether or not there are pending edits from an input method
+ on any frame. */
+
+bool
+detect_conversion_events (void)
+{
+ Lisp_Object tail, frame;
+
+ FOR_EACH_FRAME (tail, frame)
+ {
+ /* See if there's a pending edit on this frame. */
+ if (XFRAME (frame)->conversion.actions
+ && ((XFRAME (frame)->conversion.actions->operation
+ != TEXTCONV_BARRIER)
+ || (kbd_fetch_ptr == kbd_store_ptr)))
+ return true;
+ }
+
+ return false;
+}
+
+/* Restore the selected window WINDOW. */
+
+static void
+restore_selected_window (Lisp_Object window)
+{
+ /* FIXME: not sure what to do if WINDOW has been deleted. */
+ select_window (window, Qt);
+}
+
+/* Commit the given text in the composing region. If there is no
+ composing region, then insert the text after frame F's selected
+ window's last point instead, unless the mark is active. Finally,
+ remove the composing region.
+
+ If the mark is active, delete the text between mark and point.
+
+ Then, move point to POSITION relative to TEXT. If POSITION is
+ greater than zero, it is relative to the character at the end of
+ TEXT; otherwise, it is relative to the start of TEXT. */
+
+static void
+really_commit_text (struct frame *f, EMACS_INT position,
+ Lisp_Object text)
+{
+ specpdl_ref count;
+ ptrdiff_t wanted, start, end, mark;
+ struct window *w;
+
+ /* If F's old selected window is no longer alive, fail. */
+
+ if (!WINDOW_LIVE_P (f->old_selected_window))
+ return;
+
+ count = SPECPDL_INDEX ();
+ record_unwind_protect (restore_selected_window,
+ selected_window);
+
+ /* Temporarily switch to F's selected window at the time of the last
+ redisplay. */
+ select_window (f->old_selected_window, Qt);
+
+ /* Now detect whether or not there is a composing or active region.
+ If there is, then replace it with TEXT. Don't do that
+ otherwise. */
+
+ mark = get_mark ();
+ if (MARKERP (f->conversion.compose_region_start) || mark != -1)
+ {
+ /* Replace its contents. Set START and END to the start and end
+ of the composing region if it exists. */
+
+ if (MARKERP (f->conversion.compose_region_start))
+ {
+ start = marker_position (f->conversion.compose_region_start);
+ end = marker_position (f->conversion.compose_region_end);
+ }
+ else
+ {
+ /* Otherwise, set it to the start and end of the region. */
+ start = min (mark, PT);
+ end = max (mark, PT);
+ }
+
+ /* If it transpires that the start of the compose region is not
+ point, move point there. */
+
+ if (start != PT)
+ set_point (start);
+
+ /* Now delete whatever needs to go. */
+
+ del_range_1 (start, end, true, false);
+ record_buffer_change (start, start, Qt);
+
+ /* Don't record changes if TEXT is empty. */
+
+ if (SCHARS (text))
+ {
+ /* Insert the new text. Make sure to inherit text
+ properties from the surroundings: if this doesn't happen,
+ CC Mode fontification can get thrown off and become very
+ slow. */
+
+ insert_from_string (text, 0, 0, SCHARS (text),
+ SBYTES (text), true);
+ record_buffer_change (start, PT, text);
+ }
+
+ /* Move to the position specified in POSITION. */
+
+ if (position <= 0)
+ {
+ /* If POSITION is less than zero, it is relative to the
+ start of the text that was inserted. */
+ wanted = start;
+
+ if (ckd_add (&wanted, wanted, position) || wanted < BEGV)
+ wanted = BEGV;
+
+ if (wanted > ZV)
+ wanted = ZV;
+
+ set_point (wanted);
+ }
+ else
+ {
+ /* Otherwise, it is relative to the last character in
+ TEXT. */
+ wanted = PT;
+
+ if (ckd_add (&wanted, wanted, position - 1) || wanted > ZV)
+ wanted = ZV;
+
+ if (wanted < BEGV)
+ wanted = BEGV;
+
+ set_point (wanted);
+ }
+
+ /* Make the composition region markers point elsewhere. */
+
+ if (!NILP (f->conversion.compose_region_start))
+ {
+ Fset_marker (f->conversion.compose_region_start, Qnil, Qnil);
+ Fset_marker (f->conversion.compose_region_end, Qnil, Qnil);
+ f->conversion.compose_region_start = Qnil;
+ f->conversion.compose_region_end = Qnil;
+ }
+
+ /* Delete the composition region overlay. */
+
+ if (!NILP (f->conversion.compose_region_overlay))
+ Fdelete_overlay (f->conversion.compose_region_overlay);
+ }
+ else
+ {
+ /* Otherwise, move the text and point to an appropriate
+ location. */
+ wanted = PT;
+
+ /* Don't record changes if TEXT is empty. */
+
+ if (SCHARS (text))
+ {
+ /* Insert the new text. Make sure to inherit text
+ properties from the surroundings: if this doesn't happen,
+ CC Mode fontification can get thrown off and become very
+ slow. */
+
+ insert_from_string (text, 0, 0, SCHARS (text),
+ SBYTES (text), true);
+
+ record_buffer_change (wanted, PT, text);
+ }
+
+ if (position <= 0)
+ {
+ if (ckd_add (&wanted, wanted, position) || wanted < BEGV)
+ wanted = BEGV;
+
+ if (wanted > ZV)
+ wanted = ZV;
+
+ set_point (wanted);
+ }
+ else
+ {
+ wanted = PT;
+
+ if (ckd_add (&wanted, wanted, position - 1) || wanted > ZV)
+ wanted = ZV;
+
+ if (wanted < BEGV)
+ wanted = BEGV;
+
+ set_point (wanted);
+ }
+ }
+
+ /* This should deactivate the mark. */
+ call0 (Qdeactivate_mark);
+
+ /* Print some debugging information. */
+ TEXTCONV_DEBUG ("text inserted: %s, point now: %zd",
+ SSDATA (text), PT);
+
+ /* Update the ephemeral last point. */
+ w = XWINDOW (selected_window);
+ w->ephemeral_last_point = PT;
+ unbind_to (count, Qnil);
+}
+
+/* Remove the composition region on the frame F, while leaving its
+ contents intact. If UPDATE, also notify the input method of the
+ change. */
+
+static void
+really_finish_composing_text (struct frame *f, bool update)
+{
+ if (!NILP (f->conversion.compose_region_start))
+ {
+ Fset_marker (f->conversion.compose_region_start, Qnil, Qnil);
+ Fset_marker (f->conversion.compose_region_end, Qnil, Qnil);
+ f->conversion.compose_region_start = Qnil;
+ f->conversion.compose_region_end = Qnil;
+
+ if (update && text_interface
+ && text_interface->compose_region_changed)
+ (*text_interface->compose_region_changed) (f);
+ }
+
+ /* Delete the composition region overlay. */
+
+ if (!NILP (f->conversion.compose_region_overlay))
+ Fdelete_overlay (f->conversion.compose_region_overlay);
+
+ TEXTCONV_DEBUG ("conversion region removed");
+}
+
+/* Set the composing text on frame F to TEXT. Then, move point to an
+ appropriate position relative to POSITION, and call
+ `compose_region_changed' in the text conversion interface should
+ point not have been changed relative to F's old selected window's
+ last point. */
+
+static void
+really_set_composing_text (struct frame *f, ptrdiff_t position,
+ Lisp_Object text)
+{
+ specpdl_ref count;
+ ptrdiff_t start, wanted, end;
+ struct window *w;
+
+ /* If F's old selected window is no longer live, fail. */
+
+ if (!WINDOW_LIVE_P (f->old_selected_window))
+ return;
+
+ count = SPECPDL_INDEX ();
+ record_unwind_protect (restore_selected_window,
+ selected_window);
+
+ /* Temporarily switch to F's selected window at the time of the last
+ redisplay. */
+ w = XWINDOW (f->old_selected_window);
+ select_window (f->old_selected_window, Qt);
+
+ /* Now set up the composition region if necessary. */
+
+ if (!MARKERP (f->conversion.compose_region_start))
+ {
+ /* Set START and END. */
+ start = PT;
+ wanted = end = get_mark ();
+
+ /* If END is -1, set it to start. */
+
+ if (end == -1)
+ end = start;
+ else
+ {
+ /* Now sort start and end. */
+ start = min (start, end);
+ end = max (PT, wanted);
+ }
+
+ /* If END is not the same as start, delete the text in
+ between. */
+
+ if (end != start)
+ {
+ del_range_1 (start, end, true, false);
+ set_point (start);
+ record_buffer_change (start, start, Qt);
+ }
+
+ /* Now set the markers which denote the composition region. */
+ f->conversion.compose_region_start
+ = build_marker (current_buffer, PT, PT_BYTE);
+ f->conversion.compose_region_end
+ = build_marker (current_buffer, PT, PT_BYTE);
+
+ Fset_marker_insertion_type (f->conversion.compose_region_end,
+ Qt);
+ }
+ else
+ {
+ /* Delete the text between the start of the composing region and
+ its end. */
+ start = marker_position (f->conversion.compose_region_start);
+ end = marker_position (f->conversion.compose_region_end);
+ del_range_1 (start, end, true, false);
+ set_point (start);
+
+ if (start != end)
+ record_buffer_change (start, start, Qt);
+ }
+
+ /* Insert the new text. Make sure to inherit text properties from
+ the surroundings: if this doesn't happen, CC Mode fontification
+ can get thrown off and become very slow. */
+
+ insert_from_string (text, 0, 0, SCHARS (text),
+ SBYTES (text), true);
+
+ if (start != PT)
+ record_buffer_change (start, PT, Qt);
+
+ /* Now move point to an appropriate location. */
+ if (position <= 0)
+ {
+ wanted = start;
+
+ if (ckd_sub (&wanted, wanted, position) || wanted < BEGV)
+ wanted = BEGV;
+
+ if (wanted > ZV)
+ wanted = ZV;
+ }
+ else
+ {
+ end = marker_position (f->conversion.compose_region_end);
+ wanted = end;
+
+ /* end should be PT after the edit. */
+ eassert (end == PT);
+
+ if (ckd_add (&wanted, wanted, position - 1) || wanted > ZV)
+ wanted = ZV;
+
+ if (wanted < BEGV)
+ wanted = BEGV;
+ }
+
+ set_point (wanted);
+
+ /* This should deactivate the mark. */
+ call0 (Qdeactivate_mark);
+
+ /* Move the composition overlay. */
+ sync_overlay (f);
+
+ /* If TEXT is empty, remove the composing region. This goes against
+ the documentation, but is ultimately what programs expect. */
+
+ if (!SCHARS (text))
+ really_finish_composing_text (f, false);
+
+ /* If PT hasn't changed, the conversion region definitely has.
+ Otherwise, redisplay will update the input method instead. */
+
+ if (PT == w->ephemeral_last_point
+ && text_interface
+ && text_interface->compose_region_changed)
+ {
+ if (f->conversion.batch_edit_count > 0)
+ f->conversion.batch_edit_flags |= PENDING_COMPOSE_CHANGE;
+ else
+ text_interface->compose_region_changed (f);
+ }
+
+ /* Update the ephemeral last point. */
+ w = XWINDOW (selected_window);
+ w->ephemeral_last_point = PT;
+
+ if (SCHARS (text))
+ TEXTCONV_DEBUG ("conversion region set to: %td %td",
+ marker_position (f->conversion.compose_region_start),
+ marker_position (f->conversion.compose_region_end));
+ else
+ TEXTCONV_DEBUG ("conversion region removed; PT is now: %td", PT);
+
+ unbind_to (count, Qnil);
+}
+
+/* Set the composing region of frame F to START by END. Make it if
+ it is not already set. */
+
+static void
+really_set_composing_region (struct frame *f, ptrdiff_t start,
+ ptrdiff_t end)
+{
+ specpdl_ref count;
+ struct window *w;
+
+ /* If F's old selected window is no longer live, fail. */
+
+ if (!WINDOW_LIVE_P (f->old_selected_window))
+ return;
+
+ /* If MAX (0, start) == end, then this should behave the same as
+ really_finish_composing_text. */
+
+ if (max (0, start) == max (0, end))
+ {
+ really_finish_composing_text (f, false);
+ return;
+ }
+
+ count = SPECPDL_INDEX ();
+ record_unwind_protect (restore_selected_window,
+ selected_window);
+
+ /* Temporarily switch to F's selected window at the time of the last
+ redisplay. */
+ select_window (f->old_selected_window, Qt);
+
+ /* Now set up the composition region if necessary. */
+
+ if (!MARKERP (f->conversion.compose_region_start))
+ {
+ f->conversion.compose_region_start = Fmake_marker ();
+ f->conversion.compose_region_end = Fmake_marker ();
+ Fset_marker_insertion_type (f->conversion.compose_region_end,
+ Qt);
+ }
+
+ Fset_marker (f->conversion.compose_region_start,
+ make_fixnum (start), Qnil);
+ Fset_marker (f->conversion.compose_region_end,
+ make_fixnum (end), Qnil);
+ sync_overlay (f);
+
+ TEXTCONV_DEBUG ("composing region set to: %td, %td; point is: %td",
+ start, end, PT);
+
+ /* Update the ephemeral last point. */
+ w = XWINDOW (selected_window);
+ w->ephemeral_last_point = PT;
+
+ unbind_to (count, Qnil);
+}
+
+/* Delete LEFT and RIGHT chars around point or the active mark,
+ whichever is larger, in frame F's selected window, avoiding the
+ composing region if necessary. */
+
+static void
+really_delete_surrounding_text (struct frame *f, ptrdiff_t left,
+ ptrdiff_t right)
+{
+ specpdl_ref count;
+ ptrdiff_t start, end, a, b, a1, b1, lstart, rstart;
+ struct window *w;
+ Lisp_Object text;
+
+ /* If F's old selected window is no longer live, fail. */
+
+ if (!WINDOW_LIVE_P (f->old_selected_window))
+ return;
+
+ count = SPECPDL_INDEX ();
+ record_unwind_protect (restore_selected_window,
+ selected_window);
+
+ /* Temporarily switch to F's selected window at the time of the last
+ redisplay. */
+ select_window (f->old_selected_window, Qt);
+
+ /* Figure out where to start deleting from. */
+
+ a = get_mark ();
+
+ if (a != -1 && a != PT)
+ lstart = rstart = max (a, PT);
+ else
+ lstart = rstart = PT;
+
+ /* Avoid the composing text. This behavior is identical to how
+ Android's BaseInputConnection actually implements avoiding the
+ composing span. */
+
+ if (MARKERP (f->conversion.compose_region_start))
+ {
+ a = marker_position (f->conversion.compose_region_start);
+ b = marker_position (f->conversion.compose_region_end);
+
+ a1 = min (a, b);
+ b1 = max (a, b);
+
+ lstart = min (lstart, min (PT, a1));
+ rstart = max (rstart, max (PT, b1));
+ }
+
+ if (lstart == rstart)
+ {
+ start = max (BEGV, lstart - left);
+ end = min (ZV, rstart + right);
+
+ text = del_range_1 (start, end, true, true);
+ record_buffer_change (start, start, text);
+ }
+ else
+ {
+ /* Don't record a deletion if the text which was deleted lies
+ after point. */
+
+ start = rstart;
+ end = min (ZV, rstart + right);
+ text = del_range_1 (start, end, true, true);
+ record_buffer_change (start, start, Qnil);
+
+ /* Now delete what must be deleted on the left. */
+
+ start = max (BEGV, lstart - left);
+ end = lstart;
+ text = del_range_1 (start, end, true, true);
+ record_buffer_change (start, start, text);
+ }
+
+ TEXTCONV_DEBUG ("deleted surrounding text: %td, %td; PT is now %td",
+ left, right, PT);
+
+ /* if the mark is now equal to start, deactivate it. */
+
+ if (get_mark () == PT)
+ call0 (Qdeactivate_mark);
+
+ /* Update the ephemeral last point. */
+ w = XWINDOW (selected_window);
+ w->ephemeral_last_point = PT;
+
+ unbind_to (count, Qnil);
+}
+
+/* Update the interface with frame F's new point and mark. If a batch
+ edit is in progress, schedule the update for when it finishes
+ instead. */
+
+static void
+really_request_point_update (struct frame *f)
+{
+ /* If F's old selected window is no longer live, fail. */
+
+ if (!WINDOW_LIVE_P (f->old_selected_window))
+ return;
+
+ if (f->conversion.batch_edit_count > 0)
+ f->conversion.batch_edit_flags |= PENDING_POINT_CHANGE;
+ else if (text_interface && text_interface->point_changed)
+ text_interface->point_changed (f,
+ XWINDOW (f->old_selected_window),
+ current_buffer);
+}
+
+/* Set point in frame F's selected window to POSITION. If MARK is not
+ at POSITION, activate the mark and set MARK to that as well.
+
+ If point was not changed, signal an update through the text input
+ interface, which is necessary for the IME to acknowledge that the
+ change has completed. */
+
+static void
+really_set_point_and_mark (struct frame *f, ptrdiff_t point,
+ ptrdiff_t mark)
+{
+ specpdl_ref count;
+ struct window *w;
+
+ /* If F's old selected window is no longer live, fail. */
+
+ if (!WINDOW_LIVE_P (f->old_selected_window))
+ return;
+
+ count = SPECPDL_INDEX ();
+ record_unwind_protect (restore_selected_window,
+ selected_window);
+
+ /* Temporarily switch to F's selected window at the time of the last
+ redisplay. */
+ select_window (f->old_selected_window, Qt);
+
+ if (point == PT)
+ {
+ if (f->conversion.batch_edit_count > 0)
+ f->conversion.batch_edit_flags |= PENDING_POINT_CHANGE;
+ else if (text_interface && text_interface->point_changed)
+ text_interface->point_changed (f,
+ XWINDOW (f->old_selected_window),
+ current_buffer);
+ }
+ else
+ /* Set the point. */
+ Fgoto_char (make_fixnum (point));
+
+ if (mark == point
+ && !NILP (BVAR (current_buffer, mark_active)))
+ call0 (Qdeactivate_mark);
+ else
+ call1 (Qpush_mark, make_fixnum (mark));
+
+ /* Update the ephemeral last point. */
+ w = XWINDOW (selected_window);
+ w->ephemeral_last_point = PT;
+
+ TEXTCONV_DEBUG ("set point and mark: %td %td",
+ PT, get_mark ());
+
+ unbind_to (count, Qnil);
+}
+
+/* Remove the composing region. Replace the text between START and
+ END in F's selected window with TEXT, then set point to POSITION
+ relative to it. If the mark is active, deactivate it. */
+
+static void
+really_replace_text (struct frame *f, ptrdiff_t start, ptrdiff_t end,
+ Lisp_Object text, ptrdiff_t position)
+{
+ specpdl_ref count;
+ ptrdiff_t new_start, new_end, wanted;
+ struct window *w;
+
+ /* If F's old selected window is no longer alive, fail. */
+
+ if (!WINDOW_LIVE_P (f->old_selected_window))
+ return;
+
+ count = SPECPDL_INDEX ();
+ record_unwind_protect (restore_selected_window,
+ selected_window);
+
+ /* Make the composition region markers point elsewhere. */
+
+ if (!NILP (f->conversion.compose_region_start))
+ {
+ Fset_marker (f->conversion.compose_region_start, Qnil, Qnil);
+ Fset_marker (f->conversion.compose_region_end, Qnil, Qnil);
+ f->conversion.compose_region_start = Qnil;
+ f->conversion.compose_region_end = Qnil;
+
+ /* Notify the IME of an update to the composition region,
+ inasmuch as the point might not change if START and END are
+ identical and TEXT is empty, among other circumstances. */
+
+ if (text_interface
+ && text_interface->compose_region_changed)
+ (*text_interface->compose_region_changed) (f);
+ }
+
+ /* Delete the composition region overlay. */
+
+ if (!NILP (f->conversion.compose_region_overlay))
+ Fdelete_overlay (f->conversion.compose_region_overlay);
+
+ /* Temporarily switch to F's selected window at the time of the last
+ redisplay. */
+ select_window (f->old_selected_window, Qt);
+
+ /* Sort START and END by magnitude. */
+ new_start = min (start, end);
+ new_end = max (start, end);
+
+ /* Now constrain both to the accessible region. */
+
+ if (new_start < BEGV)
+ new_start = BEGV;
+ else if (new_start > ZV)
+ new_start = ZV;
+
+ if (new_end < BEGV)
+ new_end = BEGV;
+ else if (new_end > ZV)
+ new_end = ZV;
+
+ start = new_start;
+ end = new_end;
+
+ /* This should deactivate the mark. */
+ call0 (Qdeactivate_mark);
+
+ /* Go to start. */
+ set_point (start);
+
+ /* Now delete the text in between, and save PT before TEXT is
+ inserted. */
+ del_range_1 (start, end, true, false);
+ record_buffer_change (start, start, Qt);
+ wanted = PT;
+
+ /* So long as TEXT isn't empty, insert it now. */
+
+ if (SCHARS (text))
+ {
+ /* Insert the new text. Make sure to inherit text properties
+ from the surroundings: if this doesn't happen, CC Mode
+ fontification might grow confused and become very slow. */
+
+ insert_from_string (text, 0, 0, SCHARS (text),
+ SBYTES (text), true);
+ record_buffer_change (start, PT, text);
+ }
+
+ /* Now, move point to the position designated by POSITION. */
+
+ if (position <= 0)
+ {
+ if (ckd_add (&wanted, wanted, position) || wanted < BEGV)
+ wanted = BEGV;
+
+ if (wanted > ZV)
+ wanted = ZV;
+
+ set_point (wanted);
+ }
+ else
+ {
+ wanted = PT;
+
+ if (ckd_add (&wanted, wanted, position - 1) || wanted > ZV)
+ wanted = ZV;
+
+ if (wanted < BEGV)
+ wanted = BEGV;
+
+ set_point (wanted);
+ }
+
+ /* Print some debugging information. */
+ TEXTCONV_DEBUG ("text inserted: %s, point now: %zd",
+ SSDATA (text), PT);
+
+ /* Update the ephemeral last point. */
+ w = XWINDOW (selected_window);
+ w->ephemeral_last_point = PT;
+ unbind_to (count, Qnil);
+}
+
+/* Complete the edit specified by the counter value inside *TOKEN. */
+
+static void
+complete_edit (void *token)
+{
+ if (text_interface && text_interface->notify_conversion)
+ text_interface->notify_conversion (*(unsigned long *) token);
+}
+
+/* Context for complete_edit_check. */
+
+struct complete_edit_check_context
+{
+ /* The window. */
+ struct window *w;
+
+ /* Whether or not editing was successful. */
+ bool check;
+};
+
+/* Convert PTR to CONTEXT. If CONTEXT->check is false, then update
+ CONTEXT->w's ephemeral last point and give it to the input method,
+ the assumption being that an editing operation signaled. */
+
+static void
+complete_edit_check (void *ptr)
+{
+ struct complete_edit_check_context *context;
+ struct frame *f;
+
+ context = ptr;
+
+ if (!context->check)
+ {
+ /* Figure out the new position of point. */
+ context->w->ephemeral_last_point
+ = window_point (context->w);
+
+ /* See if the frame is still alive. */
+
+ f = WINDOW_XFRAME (context->w);
+
+ if (!FRAME_LIVE_P (f))
+ return;
+
+ if (text_interface && text_interface->point_changed)
+ {
+ if (f->conversion.batch_edit_count > 0)
+ f->conversion.batch_edit_flags |= PENDING_POINT_CHANGE;
+ else
+ text_interface->point_changed (f, context->w, NULL);
+ }
+ }
+}
+
+/* Process and free the text conversion ACTION. F must be the frame
+ on which ACTION will be performed.
+
+ Value is the window which was used, or NULL. */
+
+static struct window *
+handle_pending_conversion_events_1 (struct frame *f,
+ struct text_conversion_action *action)
+{
+ Lisp_Object data;
+ enum text_conversion_operation operation;
+ struct buffer *buffer UNINIT;
+ struct window *w;
+ specpdl_ref count;
+ unsigned long token;
+ struct complete_edit_check_context context;
+
+ /* Next, process this action and free it. */
+
+ data = action->data;
+ operation = action->operation;
+ token = action->counter;
+ xfree (action);
+
+ /* Text conversion events can still arrive immediately after
+ `conversion_disabled_p' becomes true. In that case, process all
+ events, but don't perform any associated actions. */
+
+ if (conversion_disabled_p ())
+ return NULL;
+
+ /* check is a flag used by complete_edit_check to determine whether
+ or not the editing operation completed successfully. */
+ context.check = false;
+
+ /* Make sure completion is signaled. */
+ count = SPECPDL_INDEX ();
+ record_unwind_protect_ptr (complete_edit, &token);
+ w = NULL;
+
+ if (WINDOW_LIVE_P (f->old_selected_window))
+ {
+ w = XWINDOW (f->old_selected_window);
+ buffer = XBUFFER (WINDOW_BUFFER (w));
+ context.w = w;
+
+ /* Notify the input method of any editing failures. */
+ record_unwind_protect_ptr (complete_edit_check, &context);
+ }
+
+ switch (operation)
+ {
+ case TEXTCONV_START_BATCH_EDIT:
+ f->conversion.batch_edit_count++;
+ break;
+
+ case TEXTCONV_END_BATCH_EDIT:
+ if (f->conversion.batch_edit_count > 0)
+ f->conversion.batch_edit_count--;
+
+ if (!WINDOW_LIVE_P (f->old_selected_window))
+ break;
+
+ if (f->conversion.batch_edit_flags & PENDING_POINT_CHANGE)
+ text_interface->point_changed (f, w, buffer);
+
+ if (f->conversion.batch_edit_flags & PENDING_COMPOSE_CHANGE)
+ text_interface->compose_region_changed (f);
+
+ f->conversion.batch_edit_flags = 0;
+ break;
+
+ case TEXTCONV_COMMIT_TEXT:
+ really_commit_text (f, XFIXNUM (XCAR (data)), XCDR (data));
+ break;
+
+ case TEXTCONV_FINISH_COMPOSING_TEXT:
+ really_finish_composing_text (f, !NILP (data));
+ break;
+
+ case TEXTCONV_SET_COMPOSING_TEXT:
+ really_set_composing_text (f, XFIXNUM (XCAR (data)),
+ XCDR (data));
+ break;
+
+ case TEXTCONV_SET_COMPOSING_REGION:
+ really_set_composing_region (f, XFIXNUM (XCAR (data)),
+ XFIXNUM (XCDR (data)));
+ break;
+
+ case TEXTCONV_SET_POINT_AND_MARK:
+ really_set_point_and_mark (f, XFIXNUM (XCAR (data)),
+ XFIXNUM (XCDR (data)));
+ break;
+
+ case TEXTCONV_DELETE_SURROUNDING_TEXT:
+ really_delete_surrounding_text (f, XFIXNUM (XCAR (data)),
+ XFIXNUM (XCDR (data)));
+ break;
+
+ case TEXTCONV_REQUEST_POINT_UPDATE:
+ really_request_point_update (f);
+ break;
+
+ case TEXTCONV_BARRIER:
+ if (kbd_fetch_ptr != kbd_store_ptr)
+ emacs_abort ();
+
+ /* Once a barrier is hit, synchronize F's selected window's
+ `ephemeral_last_point' with its current point. The reason
+ for this is because otherwise a previous keyboard event may
+ have taken place without redisplay happening in between. */
+
+ if (w)
+ w->ephemeral_last_point = window_point (w);
+ break;
+
+ case TEXTCONV_REPLACE_TEXT:
+ really_replace_text (f, XFIXNUM (XCAR (data)),
+ XFIXNUM (XCAR (XCDR (data))),
+ XCAR (XCDR (XCDR (data))),
+ XFIXNUM (XCAR (XCDR (XCDR (XCDR (data))))));
+ break;
+ }
+
+ /* Signal success. */
+ context.check = true;
+ unbind_to (count, Qnil);
+
+ return w;
+}
+
+/* Decrement the variable pointed to by *PTR. */
+
+static void
+decrement_inside (void *ptr)
+{
+ int *i;
+
+ i = ptr;
+ (*i)--;
+}
+
+/* Process any outstanding text conversion events.
+ This may run Lisp or signal. */
+
+void
+handle_pending_conversion_events (void)
+{
+ struct frame *f;
+ Lisp_Object tail, frame;
+ struct text_conversion_action *action, *next;
+ bool handled;
+ static int inside;
+ specpdl_ref count;
+ ptrdiff_t last_point;
+ struct window *w;
+
+ handled = false;
+
+ /* Reset Vtext_conversion_edits. Do not do this if called
+ reentrantly. */
+
+ if (!inside)
+ Vtext_conversion_edits = Qnil;
+
+ inside++;
+
+ count = SPECPDL_INDEX ();
+ record_unwind_protect_ptr (decrement_inside, &inside);
+
+ FOR_EACH_FRAME (tail, frame)
+ {
+ f = XFRAME (frame);
+ last_point = -1;
+ w = NULL;
+
+ /* Test if F has any outstanding conversion events. Then
+ process them in bottom to up order. */
+ while (true)
+ {
+ /* Update the input method if handled &&
+ w->ephemeral_last_point != last_point. */
+ if (w && (last_point != w->ephemeral_last_point))
+ {
+ if (handled
+ && last_point != -1
+ && text_interface
+ && text_interface->point_changed)
+ {
+ if (f->conversion.batch_edit_count > 0)
+ f->conversion.batch_edit_flags |= PENDING_POINT_CHANGE;
+ else
+ text_interface->point_changed (f, NULL, NULL);
+ }
+
+ last_point = w->ephemeral_last_point;
+ }
+
+ /* Reload action. This needs to be reentrant as buffer
+ modification functions can call `read-char'. */
+ action = f->conversion.actions;
+
+ /* If there are no more actions, break. */
+
+ if (!action)
+ break;
+
+ /* If action is a barrier event and the keyboard buffer is
+ not yet empty, break out of the loop. */
+
+ if (action->operation == TEXTCONV_BARRIER
+ && kbd_store_ptr != kbd_fetch_ptr)
+ break;
+
+ /* Unlink this action. */
+ next = action->next;
+ f->conversion.actions = next;
+
+ /* Handle and free the action. */
+ w = handle_pending_conversion_events_1 (f, action);
+ handled = true;
+ }
+ }
+
+ unbind_to (count, Qnil);
+}
+
+/* Start a ``batch edit'' in frame F. During a batch edit,
+ point_changed will not be called until the batch edit ends.
+
+ Process the actual operation in the event loop in keyboard.c; then,
+ call `notify_conversion' in the text conversion interface with
+ COUNTER. */
+
+void
+start_batch_edit (struct frame *f, unsigned long counter)
+{
+ struct text_conversion_action *action, **last;
+
+ action = xmalloc (sizeof *action);
+ action->operation = TEXTCONV_START_BATCH_EDIT;
+ action->data = Qnil;
+ action->next = NULL;
+ action->counter = counter;
+ for (last = &f->conversion.actions; *last; last = &(*last)->next)
+ ;;
+ *last = action;
+ input_pending = true;
+}
+
+/* End a ``batch edit''. It is ok to call this function even if a
+ batch edit has not yet started, in which case it does nothing.
+
+ COUNTER means the same as in `start_batch_edit'. */
+
+void
+end_batch_edit (struct frame *f, unsigned long counter)
+{
+ struct text_conversion_action *action, **last;
+
+ action = xmalloc (sizeof *action);
+ action->operation = TEXTCONV_END_BATCH_EDIT;
+ action->data = Qnil;
+ action->next = NULL;
+ action->counter = counter;
+ for (last = &f->conversion.actions; *last; last = &(*last)->next)
+ ;;
+ *last = action;
+ input_pending = true;
+}
+
+/* Insert the specified STRING into frame F's selected-window's
+ buffer's composition region, and set point to POSITION relative to
+ STRING.
+
+ If there is no composition region, use the active region instead.
+ If that doesn't exist either, insert STRING after point.
+
+ COUNTER means the same as in `start_batch_edit'. */
+
+void
+commit_text (struct frame *f, Lisp_Object string,
+ ptrdiff_t position, unsigned long counter)
+{
+ struct text_conversion_action *action, **last;
+
+ action = xmalloc (sizeof *action);
+ action->operation = TEXTCONV_COMMIT_TEXT;
+ action->data = Fcons (make_fixnum (position), string);
+ action->next = NULL;
+ action->counter = counter;
+ for (last = &f->conversion.actions; *last; last = &(*last)->next)
+ ;;
+ *last = action;
+ input_pending = true;
+}
+
+/* Remove the composition region and its overlay from frame F's
+ selected-window's current buffer. Leave the text being composed
+ intact.
+
+ If UPDATE, call `compose_region_changed' after the region is
+ removed.
+
+ COUNTER means the same as in `start_batch_edit'. */
+
+void
+finish_composing_text (struct frame *f, unsigned long counter,
+ bool update)
+{
+ struct text_conversion_action *action, **last;
+
+ action = xmalloc (sizeof *action);
+ action->operation = TEXTCONV_FINISH_COMPOSING_TEXT;
+ action->data = update ? Qt : Qnil;
+ action->next = NULL;
+ action->counter = counter;
+ for (last = &f->conversion.actions; *last; last = &(*last)->next)
+ ;;
+ *last = action;
+ input_pending = true;
+}
+
+/* Insert the given STRING and make it the currently active
+ composition.
+
+ If there is currently no composing or active region, then the new
+ value of point is used as the composing region.
+
+ Then, the composing or active region is replaced with the text in
+ the specified string.
+
+ Finally, move point to new_point, which is relative to either the
+ start or the end of OBJECT depending on whether or not it is less
+ than zero.
+
+ COUNTER means the same as in `start_batch_edit'. */
+
+void
+set_composing_text (struct frame *f, Lisp_Object object,
+ ptrdiff_t new_point, unsigned long counter)
+{
+ struct text_conversion_action *action, **last;
+
+ action = xmalloc (sizeof *action);
+ action->operation = TEXTCONV_SET_COMPOSING_TEXT;
+ action->data = Fcons (make_fixnum (new_point),
+ object);
+ action->next = NULL;
+ action->counter = counter;
+ for (last = &f->conversion.actions; *last; last = &(*last)->next)
+ ;;
+ *last = action;
+ input_pending = true;
+}
+
+/* Make the region between START and END the currently active
+ ``composing region'' on frame F.
+
+ The ``composing region'' is a region of text in the buffer that is
+ about to undergo editing by the input method. */
+
+void
+set_composing_region (struct frame *f, ptrdiff_t start,
+ ptrdiff_t end, unsigned long counter)
+{
+ struct text_conversion_action *action, **last;
+
+ start = min (start, MOST_POSITIVE_FIXNUM);
+ end = min (end, MOST_POSITIVE_FIXNUM);
+
+ action = xmalloc (sizeof *action);
+ action->operation = TEXTCONV_SET_COMPOSING_REGION;
+ action->data = Fcons (make_fixnum (start),
+ make_fixnum (end));
+ action->next = NULL;
+ action->counter = counter;
+ for (last = &f->conversion.actions; *last; last = &(*last)->next)
+ ;;
+ *last = action;
+ input_pending = true;
+}
+
+/* Move point in frame F's selected-window's buffer to POINT and maybe
+ push MARK.
+
+ COUNTER means the same as in `start_batch_edit'. */
+
+void
+textconv_set_point_and_mark (struct frame *f, ptrdiff_t point,
+ ptrdiff_t mark, unsigned long counter)
+{
+ struct text_conversion_action *action, **last;
+
+ point = min (point, MOST_POSITIVE_FIXNUM);
+
+ action = xmalloc (sizeof *action);
+ action->operation = TEXTCONV_SET_POINT_AND_MARK;
+ action->data = Fcons (make_fixnum (point),
+ make_fixnum (mark));
+ action->next = NULL;
+ action->counter = counter;
+ for (last = &f->conversion.actions; *last; last = &(*last)->next)
+ ;;
+ *last = action;
+ input_pending = true;
+}
+
+/* Delete LEFT and RIGHT characters around point in frame F's old
+ selected window. */
+
+void
+delete_surrounding_text (struct frame *f, ptrdiff_t left,
+ ptrdiff_t right, unsigned long counter)
+{
+ struct text_conversion_action *action, **last;
+
+ action = xmalloc (sizeof *action);
+ action->operation = TEXTCONV_DELETE_SURROUNDING_TEXT;
+ action->data = Fcons (make_fixnum (left),
+ make_fixnum (right));
+ action->next = NULL;
+ action->counter = counter;
+ for (last = &f->conversion.actions; *last; last = &(*last)->next)
+ ;;
+ *last = action;
+ input_pending = true;
+}
+
+/* Request an immediate call to TEXT_INTERFACE->point_changed with the
+ new details of frame F's region unless a batch edit is in
+ progress. */
+
+void
+request_point_update (struct frame *f, unsigned long counter)
+{
+ struct text_conversion_action *action, **last;
+
+ action = xmalloc (sizeof *action);
+ action->operation = TEXTCONV_REQUEST_POINT_UPDATE;
+ action->data = Qnil;
+ action->next = NULL;
+ action->counter = counter;
+ for (last = &f->conversion.actions; *last; last = &(*last)->next)
+ ;;
+ *last = action;
+ input_pending = true;
+}
+
+/* Request that text conversion on frame F pause until the keyboard
+ buffer becomes empty.
+
+ Use this function to ensure that edits associated with a keyboard
+ event complete before the text conversion edits after the barrier
+ take place. */
+
+void
+textconv_barrier (struct frame *f, unsigned long counter)
+{
+ struct text_conversion_action *action, **last;
+
+ action = xmalloc (sizeof *action);
+ action->operation = TEXTCONV_BARRIER;
+ action->data = Qnil;
+ action->next = NULL;
+ action->counter = counter;
+ for (last = &f->conversion.actions; *last; last = &(*last)->next)
+ ;;
+ *last = action;
+ input_pending = true;
+}
+
+/* Remove the composing region. Replace the text between START and
+ END within F's selected window with TEXT; deactivate the mark if it
+ is active. Subsequently, set point to POSITION relative to TEXT,
+ much as `commit_text' would. */
+
+void
+replace_text (struct frame *f, ptrdiff_t start, ptrdiff_t end,
+ Lisp_Object text, ptrdiff_t position,
+ unsigned long counter)
+{
+ struct text_conversion_action *action, **last;
+
+ action = xmalloc (sizeof *action);
+ action->operation = TEXTCONV_REPLACE_TEXT;
+ action->data = list4 (make_fixnum (start), make_fixnum (end),
+ text, make_fixnum (position));
+ action->next = NULL;
+ action->counter = counter;
+ for (last = &f->conversion.actions; *last; last = &(*last)->next)
+ ;;
+ *last = action;
+ input_pending = true;
+}
+
+/* Return N characters of text around point in frame F's old selected
+ window.
+
+ If N is -1, return the text between point and mark instead, given
+ that the mark is active.
+
+ Set *START_RETURN to the position of the first character returned,
+ *START_OFFSET to the offset of the lesser of mark and point within
+ that text, *END_OFFSET to the greater of mark and point within that
+ text, and *LENGTH to the actual number of characters returned,
+ *BYTES to the actual number of bytes returned, and *MARK_ACTIVE to
+ whether or not the mark is active.
+
+ Value is NULL upon failure, and a malloced string upon success. */
+
+char *
+get_extracted_text (struct frame *f, ptrdiff_t n,
+ ptrdiff_t *start_return,
+ ptrdiff_t *start_offset,
+ ptrdiff_t *end_offset, ptrdiff_t *length,
+ ptrdiff_t *bytes, bool *mark_active)
+{
+ specpdl_ref count;
+ ptrdiff_t start, end, start_byte, end_byte, mark;
+ char *buffer;
+
+ if (!WINDOW_LIVE_P (f->old_selected_window))
+ return NULL;
+
+ /* Save the excursion, as there will be extensive changes to the
+ selected window. */
+ count = SPECPDL_INDEX ();
+ record_unwind_protect_excursion ();
+
+ /* Inhibit quitting. */
+ specbind (Qinhibit_quit, Qt);
+
+ /* Temporarily switch to F's selected window at the time of the last
+ redisplay. */
+ select_window (f->old_selected_window, Qt);
+ buffer = NULL;
+
+ /* Figure out the bounds of the text to return. */
+ if (n != -1)
+ {
+ /* Make sure n is at least 4, leaving two characters around
+ PT. */
+ n = max (4, n);
+
+ start = PT - n / 2;
+ end = PT + n - n / 2;
+ }
+ else
+ {
+ if (!NILP (BVAR (current_buffer, mark_active))
+ && XMARKER (BVAR (current_buffer, mark))->buffer)
+ {
+ start = marker_position (BVAR (current_buffer, mark));
+ end = PT;
+
+ /* Sort start and end. start_byte is used to hold a
+ temporary value. */
+
+ if (start > end)
+ {
+ start_byte = end;
+ end = start;
+ start = start_byte;
+ }
+ }
+ else
+ goto finish;
+ }
+
+ start = max (start, BEGV);
+ end = min (end, ZV);
+
+ /* Detect overflow. */
+
+ if (!(start <= PT && PT <= end))
+ goto finish;
+
+ /* Convert the character positions to byte positions. */
+ start_byte = CHAR_TO_BYTE (start);
+ end_byte = CHAR_TO_BYTE (end);
+
+ /* Extract the text from the buffer. */
+ buffer = xmalloc (end_byte - start_byte);
+ copy_buffer_text (start, start_byte, end, end_byte, buffer);
+
+ /* Get the mark. If it's not active, use PT. */
+
+ mark = get_mark ();
+ *mark_active = true;
+
+ if (mark == -1)
+ {
+ mark = PT;
+ *mark_active = false;
+ }
+
+ /* Return the offsets. */
+ *start_return = start;
+ *start_offset = min (mark - start, PT - start);
+ *end_offset = max (mark - start, PT - start);
+ *length = end - start;
+ *bytes = end_byte - start_byte;
+
+ TEXTCONV_DEBUG ("get_extracted_text: PT, mark, start: %td, %td, %td",
+ PT, mark, start);
+
+ finish:
+ unbind_to (count, Qnil);
+ return buffer;
+}
+
+/* Return the text between the positions pt - LEFT and pt + RIGHT,
+ where pt is the position of point in frame F's selected window. If
+ the mark is active, return the range of text relative to the bounds
+ of the region instead.
+
+ Set *LENGTH to the number of characters returned, *BYTES to the
+ number of bytes returned, *OFFSET to the character position of the
+ returned text, and *START_RETURN and *END_RETURN to the mark and
+ point relative to that position. */
+
+char *
+get_surrounding_text (struct frame *f, ptrdiff_t left,
+ ptrdiff_t right, ptrdiff_t *length,
+ ptrdiff_t *bytes, ptrdiff_t *offset,
+ ptrdiff_t *start_return,
+ ptrdiff_t *end_return)
+{
+ specpdl_ref count;
+ ptrdiff_t start, end, start_byte, end_byte, mark, temp;
+ char *buffer;
+
+ if (!WINDOW_LIVE_P (f->old_selected_window))
+ return NULL;
+
+ /* Save the excursion, as there will be extensive changes to the
+ selected window. */
+ count = SPECPDL_INDEX ();
+ record_unwind_protect_excursion ();
+
+ /* Inhibit quitting. */
+ specbind (Qinhibit_quit, Qt);
+
+ /* Temporarily switch to F's selected window at the time of the last
+ redisplay. */
+ select_window (f->old_selected_window, Qt);
+ buffer = NULL;
+
+ /* Figure out the bounds of the text to return. */
+
+ /* First, obtain start and end. */
+ end = get_mark ();
+ start = PT;
+
+ /* If the mark is not active, make it start and end. */
+
+ if (end == -1)
+ end = start;
+
+ /* Now sort start and end. */
+
+ if (end < start)
+ {
+ temp = start;
+ start = end;
+ end = temp;
+ }
+
+ /* And subtract left and right. */
+
+ if (ckd_sub (&start, start, left)
+ || ckd_add (&end, end, right))
+ goto finish;
+
+ start = max (start, BEGV);
+ end = min (end, ZV);
+
+ /* Detect overflow. */
+
+ if (!(start <= PT && PT <= end))
+ goto finish;
+
+ /* Convert the character positions to byte positions. */
+ start_byte = CHAR_TO_BYTE (start);
+ end_byte = CHAR_TO_BYTE (end);
+
+ /* Extract the text from the buffer. */
+ buffer = xmalloc (end_byte - start_byte);
+ copy_buffer_text (start, start_byte, end, end_byte, buffer);
+
+ /* Get the mark. If it's not active, use PT. */
+
+ mark = get_mark ();
+
+ if (mark == -1)
+ mark = PT;
+
+ /* Return the offsets. Unlike `get_extracted_text', this need not
+ sort mark and point. */
+
+ *offset = start;
+ *start_return = mark - start;
+ *end_return = PT - start;
+ *length = end - start;
+ *bytes = end_byte - start_byte;
+
+ finish:
+ unbind_to (count, Qnil);
+ return buffer;
+}
+
+/* Return whether or not text conversion is temporarily disabled.
+ `reset' should always call this to determine whether or not to
+ disable the input method. */
+
+bool
+conversion_disabled_p (void)
+{
+ return suppress_conversion_count > 0;
+}
+
+
+
+/* Window system interface. These are called from the rest of
+ Emacs. */
+
+/* Notice that frame F's selected window has been set from redisplay.
+ Reset F's input method state. */
+
+void
+report_selected_window_change (struct frame *f)
+{
+ struct window *w;
+
+ reset_frame_state (f);
+
+ if (!text_interface)
+ return;
+
+ /* When called from window.c, F's selected window has already been
+ redisplayed, but w->last_point has not yet been updated. Update
+ it here to avoid race conditions when the IM asks for the initial
+ selection position immediately after. */
+
+ if (WINDOWP (f->selected_window))
+ {
+ w = XWINDOW (f->selected_window);
+ w->ephemeral_last_point = window_point (w);
+ }
+
+ text_interface->reset (f);
+}
+
+/* Notice that point in frame F's selected window's current buffer has
+ changed.
+
+ F is the frame whose selected window was changed, WINDOW is the
+ window in question, and BUFFER is that window's buffer.
+
+ Tell the text conversion interface about the change; it will likely
+ pass the information on to the system input method. */
+
+void
+report_point_change (struct frame *f, struct window *window,
+ struct buffer *buffer)
+{
+ if (!text_interface || !text_interface->point_changed)
+ return;
+
+ if (f->conversion.batch_edit_count > 0)
+ f->conversion.batch_edit_flags |= PENDING_POINT_CHANGE;
+ else
+ text_interface->point_changed (f, window, buffer);
+}
+
+/* Temporarily disable text conversion. Must be paired with a
+ corresponding call to resume_text_conversion. */
+
+void
+disable_text_conversion (void)
+{
+ Lisp_Object tail, frame;
+ struct frame *f;
+
+ suppress_conversion_count++;
+
+ if (!text_interface || suppress_conversion_count > 1)
+ return;
+
+ /* Loop through and reset the input method on each window system
+ frame. It should call conversion_disabled_p and then DTRT. */
+
+ FOR_EACH_FRAME (tail, frame)
+ {
+ f = XFRAME (frame);
+ reset_frame_state (f);
+
+ if (FRAME_WINDOW_P (f) && FRAME_VISIBLE_P (f))
+ text_interface->reset (f);
+ }
+}
+
+/* Undo the effect of the last call to `disable_text_conversion'. */
+
+void
+resume_text_conversion (void)
+{
+ Lisp_Object tail, frame;
+ struct frame *f;
+
+ suppress_conversion_count--;
+ eassert (suppress_conversion_count >= 0);
+
+ if (!text_interface || suppress_conversion_count)
+ return;
+
+ /* Loop through and reset the input method on each window system
+ frame. It should call conversion_disabled_p and then DTRT. */
+
+ FOR_EACH_FRAME (tail, frame)
+ {
+ f = XFRAME (frame);
+ reset_frame_state (f);
+
+ if (FRAME_WINDOW_P (f) && FRAME_VISIBLE_P (f))
+ text_interface->reset (f);
+ }
+}
+
+/* Register INTERFACE as the text conversion interface. */
+
+void
+register_textconv_interface (struct textconv_interface *interface)
+{
+ text_interface = interface;
+}
+
+
+
+/* List of buffers whose text conversion state will be reset after a
+ key sequence is read. */
+static Lisp_Object postponed_buffers;
+
+/* Reset the text conversion style of each frame whose selected buffer
+ is contained inside `postponed_buffers'. Set `postponed_buffers'
+ to nil. */
+
+void
+check_postponed_buffers (void)
+{
+ Lisp_Object buffer, tail, frame;
+ struct buffer *b;
+ struct frame *f;
+
+ buffer = postponed_buffers;
+ postponed_buffers = Qnil;
+
+ if (!text_interface->reset)
+ return;
+
+ FOR_EACH_TAIL (buffer)
+ {
+ b = XBUFFER (XCAR (buffer));
+
+ /* Continue if this is a dead buffer. */
+
+ if (!BUFFER_LIVE_P (b))
+ continue;
+
+ /* If no windows are displaying B anymore, continue. */
+
+ if (!buffer_window_count (b))
+ continue;
+
+ /* Look for frames which have B selected. */
+
+ FOR_EACH_FRAME (tail, frame)
+ {
+ f = XFRAME (frame);
+
+ if (WINDOW_LIVE_P (f->old_selected_window)
+ && FRAME_WINDOW_P (f)
+ /* N.B. that the same frame can't be reset twice as long
+ as the list of buffers remains unique. */
+ && EQ (XWINDOW (f->old_selected_window)->contents,
+ XCAR (buffer)))
+ {
+ block_input ();
+ reset_frame_state (f);
+ text_interface->reset (f);
+ unblock_input ();
+ }
+ }
+ }
+}
+
+/* Lisp interface. */
+
+DEFUN ("set-text-conversion-style", Fset_text_conversion_style,
+ Sset_text_conversion_style, 1, 2, 0,
+ doc: /* Set the current buffer's text conversion style to VALUE.
+
+After setting `text-conversion-style', force input methods
+editing in a selected window displaying this buffer on any frame
+to stop themselves.
+
+This can lead to a significant amount of time being taken by the input
+method resetting itself, so you should not use this function lightly;
+instead, set `text-conversion-style' before your buffer is displayed,
+and let redisplay manage the input method appropriately.
+
+If a key sequence is currently being read (either through the command
+loop or by a call to `read-key-sequence') and AFTER-KEY-SEQUENCE is
+non-nil, don't perform changes to the input method until the key
+sequence is read. This is useful within a function bound to
+`input-decode-map' or `local-function-key-map', as it prevents the
+input method from being redundantly enabled according to VALUE if the
+replacement key sequence returned starts a new key sequence and makes
+`read-key-sequence' disable text conversion again. */)
+ (Lisp_Object value, Lisp_Object after_key_sequence)
+{
+ Lisp_Object tail, frame;
+ struct frame *f;
+ Lisp_Object buffer;
+
+ bset_text_conversion_style (current_buffer, value);
+
+ if (!text_interface)
+ return Qnil;
+
+ /* If there are any selected windows displaying this buffer, reset
+ text conversion on their associated frames. */
+
+ if (buffer_window_count (current_buffer))
+ {
+ buffer = Fcurrent_buffer ();
+
+ /* Postpone changes to the actual text conversion state if
+ AFTER_KEY_SEQUENCE is non-nil and a key sequence is being
+ read. */
+
+ if (reading_key_sequence && !NILP (after_key_sequence))
+ {
+ if (NILP (Fmemq (buffer, postponed_buffers)))
+ /* `check_postponed_buffers' will hopefully be called soon
+ enough to avoid postponed_buffers growing
+ indefinitely. */
+ postponed_buffers = Fcons (buffer, postponed_buffers);
+ return Qnil;
+ }
+
+ FOR_EACH_FRAME (tail, frame)
+ {
+ f = XFRAME (frame);
+
+ if (WINDOW_LIVE_P (f->old_selected_window)
+ && FRAME_WINDOW_P (f)
+ && (EQ (XWINDOW (f->old_selected_window)->contents,
+ buffer)
+ /* Always reset the text conversion style of the
+ selected frame. */
+ || (f == SELECTED_FRAME ())))
+ {
+ block_input ();
+ reset_frame_state (f);
+ text_interface->reset (f);
+ unblock_input ();
+ }
+ }
+ }
+
+ return Qnil;
+}
+
+
+
+void
+syms_of_textconv (void)
+{
+ DEFSYM (Qaction, "action");
+ DEFSYM (Qpassword, "password");
+ DEFSYM (Qtext_conversion, "text-conversion");
+ DEFSYM (Qpush_mark, "push-mark");
+ DEFSYM (Qunderline, "underline");
+ DEFSYM (Qoverriding_text_conversion_style,
+ "overriding-text-conversion-style");
+
+ DEFVAR_LISP ("text-conversion-edits", Vtext_conversion_edits,
+ doc: /* List of buffers last edited as a result of text conversion.
+
+This list can be used while handling a `text-conversion' event to
+determine which changes have taken place.
+
+Each element of the list describes a single edit in a buffer, and
+is of the form:
+
+ (BUFFER BEG END EPHEMERAL)
+
+If an insertion or an edit to the buffer text is described, then BEG
+and END are markers which denote the bounds of the text that was
+changed or inserted. If a deletion is described, then BEG and END are
+the same object.
+
+If EPHEMERAL is t, then the input method is preparing to make further
+edits to the text, so any actions that would otherwise be taken, such
+as indenting or automatically filling text, should not take place.
+
+Otherwise, it is either a string containing text that was inserted,
+text deleted before point, or nil if text was deleted after point.
+
+The list contents are ordered in the reverse order of editing, i.e.
+the latest edit first, so you must iterate through the list in reverse. */);
+ Vtext_conversion_edits = Qnil;
+
+ DEFVAR_LISP ("overriding-text-conversion-style",
+ Voverriding_text_conversion_style,
+ doc: /* Non-buffer local version of `text-conversion-style'.
+
+If this variable is the symbol `lambda', it means to consult the
+buffer-local value of `text-conversion-style' to determine whether or
+not to activate the input method. Otherwise, the value is used in
+preference to any buffer-local value of `text-conversion-style'. */);
+ Voverriding_text_conversion_style = Qlambda;
+
+ DEFVAR_LISP ("text-conversion-face", Vtext_conversion_face,
+ doc: /* Face in which to display temporary edits by an input method.
+The value nil means to display no indication of a temporary edit. */);
+ Vtext_conversion_face = Qunderline;
+
+ defsubr (&Sset_text_conversion_style);
+
+ postponed_buffers = Qnil;
+ staticpro (&postponed_buffers);
+}
diff --git a/src/textconv.h b/src/textconv.h
new file mode 100644
index 00000000000..61f13ebcb43
--- /dev/null
+++ b/src/textconv.h
@@ -0,0 +1,160 @@
+/* String conversion support for graphics terminals.
+
+Copyright (C) 2023-2024 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 <https://www.gnu.org/licenses/>. */
+
+#ifndef _TEXTCONV_H_
+
+#include "lisp.h"
+#include "frame.h"
+
+/* The function pointers in this structure should be filled out by
+ each GUI backend interested in supporting text conversion.
+
+ Finally, register_texconv_interface must be called at some point
+ during terminal initialization. */
+
+struct textconv_interface
+{
+ /* Notice that the text conversion context has changed (which can
+ happen if the window is deleted or switches buffers, or an
+ unexpected buffer change occurs.) */
+ void (*reset) (struct frame *);
+
+ /* Notice that point or mark has moved in the specified frame's
+ selected window's selected buffer. The second argument is the
+ window whose point changed, and the third argument is the
+ buffer. */
+ void (*point_changed) (struct frame *, struct window *,
+ struct buffer *);
+
+ /* Notice that the preconversion region has changed without point
+ being moved. */
+ void (*compose_region_changed) (struct frame *);
+
+ /* Notice that an asynch conversion identified by COUNTER has
+ completed. */
+ void (*notify_conversion) (unsigned long);
+};
+
+
+
+enum textconv_caret_direction
+ {
+ TEXTCONV_FORWARD_CHAR,
+ TEXTCONV_BACKWARD_CHAR,
+ TEXTCONV_FORWARD_WORD,
+ TEXTCONV_BACKWARD_WORD,
+ TEXTCONV_CARET_UP,
+ TEXTCONV_CARET_DOWN,
+ TEXTCONV_NEXT_LINE,
+ TEXTCONV_PREVIOUS_LINE,
+ TEXTCONV_LINE_START,
+ TEXTCONV_LINE_END,
+ TEXTCONV_ABSOLUTE_POSITION,
+ };
+
+enum textconv_operation
+ {
+ TEXTCONV_SUBSTITUTION,
+ TEXTCONV_RETRIEVAL,
+ };
+
+/* Structure describing text in a buffer corresponding to a ``struct
+ textconv_callback_struct''. */
+
+struct textconv_conversion_text
+{
+ /* Length of the text in characters and bytes. */
+ size_t length, bytes;
+
+ /* Pointer to the text data. This must be deallocated by the
+ caller. */
+ char *text;
+};
+
+/* Structure describing a single query submitted by the input
+ method. */
+
+struct textconv_callback_struct
+{
+ /* Character position, relative to the current spot location, from
+ where on text should be returned. */
+ EMACS_INT position;
+
+ /* The type of scanning to perform to determine either the start or
+ the end of the conversion. */
+ enum textconv_caret_direction direction;
+
+ /* The the number of times for which to repeat the scanning in order
+ to determine the starting position of the text to return. */
+ unsigned short factor;
+
+ /* The operation to perform upon the current buffer contents.
+
+ If this is TEXTCONV_SUBSTITUTION, then the text that is returned
+ will be deleted from the buffer itself.
+
+ Otherwise, the text is simply returned without modifying the
+ buffer contents. */
+ enum textconv_operation operation;
+
+ /* Structure that will be filled with a description of the resulting
+ text. */
+ struct textconv_conversion_text text;
+};
+
+
+
+#define TEXTCONV_SKIP_CONVERSION_REGION (1 << 0)
+
+extern int textconv_query (struct frame *, struct textconv_callback_struct *,
+ int);
+extern bool detect_conversion_events (void);
+extern void handle_pending_conversion_events (void);
+extern void start_batch_edit (struct frame *, unsigned long);
+extern void end_batch_edit (struct frame *, unsigned long);
+extern void commit_text (struct frame *, Lisp_Object, ptrdiff_t,
+ unsigned long);
+extern void finish_composing_text (struct frame *, unsigned long,
+ bool);
+extern void set_composing_text (struct frame *, Lisp_Object,
+ ptrdiff_t, unsigned long);
+extern void set_composing_region (struct frame *, ptrdiff_t, ptrdiff_t,
+ unsigned long);
+extern void textconv_set_point_and_mark (struct frame *, ptrdiff_t,
+ ptrdiff_t, unsigned long);
+extern void delete_surrounding_text (struct frame *, ptrdiff_t,
+ ptrdiff_t, unsigned long);
+extern void request_point_update (struct frame *, unsigned long);
+extern void textconv_barrier (struct frame *, unsigned long);
+extern void replace_text (struct frame *, ptrdiff_t, ptrdiff_t,
+ Lisp_Object, ptrdiff_t, unsigned long);
+
+extern char *get_extracted_text (struct frame *, ptrdiff_t, ptrdiff_t *,
+ ptrdiff_t *, ptrdiff_t *, ptrdiff_t *,
+ ptrdiff_t *, bool *);
+extern char *get_surrounding_text (struct frame *, ptrdiff_t,
+ ptrdiff_t, ptrdiff_t *,
+ ptrdiff_t *, ptrdiff_t *,
+ ptrdiff_t *, ptrdiff_t *);
+extern bool conversion_disabled_p (void);
+extern void check_postponed_buffers (void);
+
+extern void register_textconv_interface (struct textconv_interface *);
+
+#endif /* _TEXTCONV_H_ */
diff --git a/src/thread.c b/src/thread.c
index 040ca39511e..2f5d7a08838 100644
--- a/src/thread.c
+++ b/src/thread.c
@@ -106,6 +106,12 @@ post_acquire_global_lock (struct thread_state *self)
{
struct thread_state *prev_thread = current_thread;
+ /* Switch the JNI interface pointer to the environment assigned to the
+ current thread. */
+#if defined HAVE_ANDROID && !defined ANDROID_STUBIFY
+ android_java_env = self->java_env;
+#endif /* defined HAVE_ANDROID && !defined ANDROID_STUBIFY */
+
/* Do this early on, so that code below could signal errors (e.g.,
unbind_for_thread_switch might) correctly, because we are already
running in the context of the thread pointed by SELF. */
@@ -126,6 +132,12 @@ post_acquire_global_lock (struct thread_state *self)
set_buffer_internal_2 (current_buffer);
}
+#if defined HAVE_ANDROID && !defined ANDROID_STUBIFY
+ /* This step is performed in android_select when built without
+ threads. */
+ android_check_query ();
+#endif /* defined HAVE_ANDROID && !defined ANDROID_STUBIFY */
+
/* We could have been signaled while waiting to grab the global lock
for the first time since this thread was created, in which case
we didn't yet have the opportunity to set up the handlers. Delay
@@ -756,6 +768,11 @@ run_thread (void *state)
struct thread_state *self = state;
struct thread_state **iter;
+#ifdef THREADS_ENABLED
+#if defined HAVE_ANDROID && !defined ANDROID_STUBIFY
+ jint rc;
+#endif /* #if defined HAVE_ANDROID && !defined ANDROID_STUBIFY */
+#endif /* THREADS_ENABLED */
#ifdef HAVE_NS
/* Allocate an autorelease pool in case this thread calls any
@@ -766,6 +783,16 @@ run_thread (void *state)
void *pool = ns_alloc_autorelease_pool ();
#endif
+#ifdef THREADS_ENABLED
+#if defined HAVE_ANDROID && !defined ANDROID_STUBIFY
+ rc
+ = (*android_jvm)->AttachCurrentThread (android_jvm, &self->java_env,
+ NULL);
+ if (rc != JNI_OK)
+ emacs_abort ();
+#endif /* defined HAVE_ANDROID && !defined ANDROID_STUBIFY */
+#endif /* THREADS_ENABLED */
+
self->m_stack_bottom = self->stack_top = &stack_pos.c;
self->thread_id = sys_thread_self ();
@@ -812,6 +839,14 @@ run_thread (void *state)
ns_release_autorelease_pool (pool);
#endif
+#ifdef THREADS_ENABLED
+#if defined HAVE_ANDROID && !defined ANDROID_STUBIFY
+ rc = (*android_jvm)->DetachCurrentThread (android_jvm);
+ if (rc != JNI_OK)
+ emacs_abort ();
+#endif /* defined HAVE_ANDROID && !defined ANDROID_STUBIFY */
+#endif /* THREADS_ENABLED */
+
/* Unlink this thread from the list of all threads. Note that we
have to do this very late, after broadcasting our death.
Otherwise the GC may decide to reap the thread_state object,
@@ -1131,6 +1166,10 @@ init_threads (void)
sys_mutex_init (&global_lock);
sys_mutex_lock (&global_lock);
current_thread = &main_thread.s;
+#if defined HAVE_ANDROID && !defined ANDROID_STUBIFY
+ current_thread->java_env = android_java_env;
+#endif /* defined HAVE_ANDROID && !defined ANDROID_STUBIFY */
+
main_thread.s.thread_id = sys_thread_self ();
init_bc_thread (&main_thread.s.bc);
}
diff --git a/src/thread.h b/src/thread.h
index b7920307d38..1844cf03967 100644
--- a/src/thread.h
+++ b/src/thread.h
@@ -30,9 +30,24 @@ along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. */
#include <signal.h> /* sigset_t */
#endif
+#ifdef HAVE_ANDROID
+#ifndef ANDROID_STUBIFY
+#include "android.h"
+#endif /* ANDROID_STUBIFY */
+#endif /* HAVE_ANDROID */
+
#include "sysselect.h" /* FIXME */
#include "systhread.h"
+/* Yield an address close enough to the top of the stack that the
+ garbage collector need not scan above it. Callers should be
+ declared NO_INLINE. */
+#ifdef HAVE___BUILTIN_FRAME_ADDRESS
+# define NEAR_STACK_TOP(addr) ((void) (addr), __builtin_frame_address (0))
+#else
+# define NEAR_STACK_TOP(addr) (addr)
+#endif
+
INLINE_HEADER_BEGIN
/* Byte-code interpreter thread state. */
@@ -75,6 +90,11 @@ struct thread_state
Lisp_Object event_object;
/* event_object must be the last Lisp field. */
+#if defined HAVE_ANDROID && !defined ANDROID_STUBIFY
+ /* Pointer to an object to call Java functions through. */
+ JNIEnv *java_env;
+#endif /* HAVE_ANDROID && !ANDROID_STUBIFY */
+
/* An address near the bottom of the stack.
Tells GC how to save a copy of the stack. */
char const *m_stack_bottom;
diff --git a/src/timefns.c b/src/timefns.c
index 97338830993..0ecbb6e6793 100644
--- a/src/timefns.c
+++ b/src/timefns.c
@@ -225,7 +225,7 @@ tzlookup (Lisp_Object zone, bool settz)
if (NILP (zone))
return local_tz;
- else if (BASE_EQ (zone, make_fixnum (0)) || BASE2_EQ (zone, Qt))
+ else if (BASE_EQ (zone, make_fixnum (0)) || EQ (zone, Qt))
{
zone_string = "UTC0";
new_tz = utc_tz;
@@ -234,7 +234,7 @@ tzlookup (Lisp_Object zone, bool settz)
{
bool plain_integer = FIXNUMP (zone);
- if (BASE2_EQ (zone, Qwall))
+ if (EQ (zone, Qwall))
zone_string = 0;
else if (STRINGP (zone))
zone_string = SSDATA (ENCODE_SYSTEM (zone));
@@ -514,8 +514,8 @@ timespec_ticks (struct timespec t)
/* For speed, use intmax_t arithmetic if it will do. */
intmax_t accum;
if (FASTER_TIMEFNS
- && !INT_MULTIPLY_WRAPV (t.tv_sec, TIMESPEC_HZ, &accum)
- && !INT_ADD_WRAPV (t.tv_nsec, accum, &accum))
+ && !ckd_mul (&accum, t.tv_sec, TIMESPEC_HZ)
+ && !ckd_add (&accum, accum, t.tv_nsec))
return make_int (accum);
/* Fall back on bignum arithmetic. */
@@ -543,7 +543,7 @@ lisp_time_hz_ticks (struct lisp_time t, Lisp_Object hz)
/* For speed, use intmax_t arithmetic if it will do. */
intmax_t ticks;
if (FASTER_TIMEFNS && FIXNUMP (t.ticks) && FIXNUMP (t.hz)
- && !INT_MULTIPLY_WRAPV (XFIXNUM (t.ticks), XFIXNUM (hz), &ticks))
+ && !ckd_mul (&ticks, XFIXNUM (t.ticks), XFIXNUM (hz)))
return make_int (ticks / XFIXNUM (t.hz)
- (ticks % XFIXNUM (t.hz) < 0));
}
@@ -1548,7 +1548,7 @@ usage: (decode-time &optional TIME ZONE FORM) */)
/* Compute SEC from LOCAL_TM.tm_sec and HZ. */
Lisp_Object hz = lt.hz, sec;
- if (BASE_EQ (hz, make_fixnum (1)) || !BASE2_EQ (form, Qt))
+ if (BASE_EQ (hz, make_fixnum (1)) || !EQ (form, Qt))
sec = make_fixnum (local_tm.tm_sec);
else
{
@@ -1557,12 +1557,10 @@ usage: (decode-time &optional TIME ZONE FORM) */)
Lisp_Object ticks;
intmax_t n;
if (FASTER_TIMEFNS && FIXNUMP (lt.ticks) && FIXNUMP (hz)
- && !INT_MULTIPLY_WRAPV (XFIXNUM (hz), local_tm.tm_sec, &n)
- && ! (INT_ADD_WRAPV
- (n, (XFIXNUM (lt.ticks) % XFIXNUM (hz)
- + (XFIXNUM (lt.ticks) % XFIXNUM (hz) < 0
- ? XFIXNUM (hz) : 0)),
- &n)))
+ && !ckd_mul (&n, XFIXNUM (hz), local_tm.tm_sec)
+ && !ckd_add (&n, n, (XFIXNUM (lt.ticks) % XFIXNUM (hz)
+ + (XFIXNUM (lt.ticks) % XFIXNUM (hz) < 0
+ ? XFIXNUM (hz) : 0))))
ticks = make_int (n);
else
{
@@ -1603,7 +1601,7 @@ check_tm_member (Lisp_Object obj, int offset)
CHECK_FIXNUM (obj);
EMACS_INT n = XFIXNUM (obj);
int i;
- if (INT_SUBTRACT_WRAPV (n, offset, &i))
+ if (ckd_sub (&i, n, offset))
time_overflow ();
return i;
}
@@ -1767,10 +1765,8 @@ but new code should not rely on it. */)
well, since we accept it as input? */
struct lisp_time t;
enum timeform input_form = decode_lisp_time (time, false, &t, 0);
- if (NILP (form))
- form = current_time_list ? Qlist : Qt;
- if (symbols_with_pos_enabled && SYMBOL_WITH_POS_P (form))
- form = SYMBOL_WITH_POS_SYM (form);
+ form = (!NILP (form) ? maybe_remove_pos_from_symbol (form)
+ : current_time_list ? Qlist : Qt);
if (BASE_EQ (form, Qlist))
return ticks_hz_list4 (t.ticks, t.hz);
if (BASE_EQ (form, Qinteger))
diff --git a/src/tparam.c b/src/tparam.c
index 26a53351019..d19d484430d 100644
--- a/src/tparam.c
+++ b/src/tparam.c
@@ -173,8 +173,7 @@ tparam1 (const char *string, char *outstring, int len,
doup++, append_len_incr = strlen (up);
else
doleft++, append_len_incr = strlen (left);
- if (INT_ADD_WRAPV (append_len_incr,
- append_len, &append_len))
+ if (ckd_add (&append_len, append_len, append_len_incr))
memory_full (SIZE_MAX);
}
}
diff --git a/src/treesit.c b/src/treesit.c
index 21c61a35e70..d86ab501187 100644
--- a/src/treesit.c
+++ b/src/treesit.c
@@ -428,10 +428,17 @@ static Lisp_Object Vtreesit_str_match;
static Lisp_Object Vtreesit_str_pred;
/* This is the limit on recursion levels for some tree-sitter
- functions. Remember to update docstrings when changing this
- value. */
-const ptrdiff_t treesit_recursion_limit = 1000;
-bool treesit_initialized = false;
+ functions. Remember to update docstrings when changing this value.
+
+ If we think of programs and AST, it is very rare for any program to
+ have a very deep AST. For example, you would need 1000+ levels of
+ nested if-statements, or a struct somehow nested for 1000+ levels.
+ It’s hard for me to imagine any hand-written or machine generated
+ program to be like that. So I think 1000 is already generous. If
+ we look at xdisp.c, its AST only have 30 levels. */
+#define TREESIT_RECURSION_LIMIT 1000
+
+static bool treesit_initialized = false;
static bool
load_tree_sitter_if_necessary (bool required)
@@ -485,40 +492,47 @@ treesit_initialize (void)
static void
treesit_symbol_to_c_name (char *symbol_name)
{
- for (int idx = 0; idx < strlen (symbol_name); idx++)
+ size_t len = strlen (symbol_name);
+ for (int idx = 0; idx < len; idx++)
{
if (symbol_name[idx] == '-')
symbol_name[idx] = '_';
}
}
+/* Find the override name for LANGUAGE_SYMBOL in
+ treesit-load-name-override-list. Set NAME and C_SYMBOL to the
+ override name, and return true if there exists one, otherwise
+ return false.
+
+ This function may signal if treesit-load-name-override-list is
+ malformed. */
static bool
treesit_find_override_name (Lisp_Object language_symbol, Lisp_Object *name,
Lisp_Object *c_symbol)
{
- Lisp_Object tem;
-
CHECK_LIST (Vtreesit_load_name_override_list);
+ Lisp_Object tail = Vtreesit_load_name_override_list;
- tem = Vtreesit_load_name_override_list;
-
- FOR_EACH_TAIL (tem)
+ FOR_EACH_TAIL (tail)
{
- Lisp_Object lang = XCAR (XCAR (tem));
+ Lisp_Object entry = XCAR (tail);
+ CHECK_LIST (entry);
+ Lisp_Object lang = XCAR (entry);
CHECK_SYMBOL (lang);
if (EQ (lang, language_symbol))
{
- *name = Fnth (make_fixnum (1), XCAR (tem));
+ *name = Fnth (make_fixnum (1), entry);
CHECK_STRING (*name);
- *c_symbol = Fnth (make_fixnum (2), XCAR (tem));
+ *c_symbol = Fnth (make_fixnum (2), entry);
CHECK_STRING (*c_symbol);
return true;
}
}
- CHECK_LIST_END (tem, Vtreesit_load_name_override_list);
+ CHECK_LIST_END (tail, Vtreesit_load_name_override_list);
return false;
}
@@ -586,8 +600,6 @@ treesit_load_language (Lisp_Object language_symbol,
/* First push just the filenames to the candidate list, which will
make dynlib_open look under standard system load paths. */
treesit_load_language_push_for_each_suffix (lib_base_name, &path_candidates);
- /* This is used for reporting errors (i.e., just filenames). */
- Lisp_Object base_candidates = path_candidates;
/* Then push ~/.emacs.d/tree-sitter paths. */
Lisp_Object lib_name
= Fexpand_file_name (concat2 (build_string ("tree-sitter/"), lib_base_name),
@@ -610,6 +622,7 @@ treesit_load_language (Lisp_Object language_symbol,
fail. */
dynlib_handle_ptr handle;
const char *error;
+ Lisp_Object error_list = Qnil;
tail = path_candidates;
error = NULL;
@@ -623,13 +636,17 @@ treesit_load_language (Lisp_Object language_symbol,
error = dynlib_error ();
if (error == NULL)
break;
+ else
+ error_list = Fcons (build_string (error), error_list);
}
if (error != NULL)
{
+ /* Yes, the error message list gets a bit verbose, but those
+ messages will be helpful for certain errors like libc version
+ mismatch. */
*signal_symbol = Qtreesit_load_language_error;
- *signal_data = list3 (Qnot_found, base_candidates,
- build_string ("No such file or directory"));
+ *signal_data = Fcons (Qnot_found, Fnreverse (error_list));
return NULL;
}
@@ -1029,7 +1046,7 @@ treesit_call_after_change_functions (TSTree *old_tree, TSTree *new_tree,
for each of them. */
Lisp_Object functions = XTS_PARSER (parser)->after_change_functions;
FOR_EACH_TAIL (functions)
- safe_call2 (XCAR (functions), lisp_ranges, parser);
+ safe_calln (XCAR (functions), lisp_ranges, parser);
unbind_to (count, Qnil);
}
@@ -1142,7 +1159,8 @@ treesit_read_buffer (void *parser, uint32_t byte_index,
machine. */
Lisp_Object
make_treesit_parser (Lisp_Object buffer, TSParser *parser,
- TSTree *tree, Lisp_Object language_symbol)
+ TSTree *tree, Lisp_Object language_symbol,
+ Lisp_Object tag)
{
struct Lisp_TS_Parser *lisp_parser;
@@ -1151,6 +1169,8 @@ make_treesit_parser (Lisp_Object buffer, TSParser *parser,
lisp_parser->language_symbol = language_symbol;
lisp_parser->after_change_functions = Qnil;
+ lisp_parser->tag = tag;
+ lisp_parser->last_set_ranges = Qnil;
lisp_parser->buffer = buffer;
lisp_parser->parser = parser;
lisp_parser->tree = tree;
@@ -1161,7 +1181,6 @@ make_treesit_parser (Lisp_Object buffer, TSParser *parser,
lisp_parser->visible_end = BUF_ZV_BYTE (XBUFFER (buffer));
lisp_parser->timestamp = 0;
lisp_parser->deleted = false;
- lisp_parser->has_range = false;
eassert (lisp_parser->visible_beg <= lisp_parser->visible_end);
return make_lisp_ptr (lisp_parser, Lisp_Vectorlike);
}
@@ -1368,24 +1387,29 @@ DEFUN ("treesit-node-parser",
DEFUN ("treesit-parser-create",
Ftreesit_parser_create, Streesit_parser_create,
- 1, 3, 0,
- doc: /* Create and return a parser in BUFFER for LANGUAGE.
+ 1, 4, 0,
+ doc: /* Create and return a parser in BUFFER for LANGUAGE with TAG.
The parser is automatically added to BUFFER's parser list, as returned
by `treesit-parser-list'. LANGUAGE is a language symbol. If BUFFER
is nil or omitted, it defaults to the current buffer. If BUFFER
-already has a parser for LANGUAGE, return that parser, but if NO-REUSE
-is non-nil, always create a new parser.
+already has a parser for LANGUAGE with TAG, return that parser, but if
+NO-REUSE is non-nil, always create a new parser.
+
+TAG can be any symbol except t, and defaults to nil. Different
+parsers can have the same tag.
If that buffer is an indirect buffer, its base buffer is used instead.
That is, indirect buffers use their base buffer's parsers. Lisp
programs should widen as necessary should they want to use a parser in
an indirect buffer. */)
- (Lisp_Object language, Lisp_Object buffer, Lisp_Object no_reuse)
+ (Lisp_Object language, Lisp_Object buffer, Lisp_Object no_reuse,
+ Lisp_Object tag)
{
treesit_initialize ();
CHECK_SYMBOL (language);
+ CHECK_SYMBOL (tag);
struct buffer *buf;
if (NILP (buffer))
buf = current_buffer;
@@ -1397,6 +1421,9 @@ an indirect buffer. */)
if (buf->base_buffer)
buf = buf->base_buffer;
+ if (EQ (tag, Qt))
+ xsignal2(Qwrong_type_argument, list2(Qnot, Qt), Qt);
+
treesit_check_buffer_size (buf);
/* See if we can reuse a parser. */
@@ -1406,7 +1433,8 @@ an indirect buffer. */)
FOR_EACH_TAIL (tail)
{
struct Lisp_TS_Parser *parser = XTS_PARSER (XCAR (tail));
- if (EQ (parser->language_symbol, language))
+ if (EQ (parser->tag, tag)
+ && EQ (parser->language_symbol, language))
return XCAR (tail);
}
}
@@ -1426,7 +1454,7 @@ an indirect buffer. */)
/* Create parser. */
Lisp_Object lisp_parser = make_treesit_parser (Fcurrent_buffer (),
parser, NULL,
- language);
+ language, tag);
/* Update parser-list. */
BVAR (buf, ts_parser_list) = Fcons (lisp_parser, BVAR (buf, ts_parser_list));
@@ -1455,13 +1483,19 @@ See `treesit-parser-list' for the buffer's parser list. */)
DEFUN ("treesit-parser-list",
Ftreesit_parser_list, Streesit_parser_list,
- 0, 1, 0,
- doc: /* Return BUFFER's parser list.
+ 0, 3, 0,
+ doc: /* Return BUFFER's parser list, filtered by LANGUAGE and TAG.
BUFFER defaults to the current buffer. If that buffer is an indirect
buffer, its base buffer is used instead. That is, indirect buffers
-use their base buffer's parsers. */)
- (Lisp_Object buffer)
+use their base buffer's parsers.
+
+If LANGUAGE is non-nil, only return parsers for that language.
+
+The returned list only contain parsers with TAG. TAG defaults to nil.
+If TAG is t, include parsers in the returned list regardless of their
+tag. */)
+ (Lisp_Object buffer, Lisp_Object language, Lisp_Object tag)
{
struct buffer *buf;
if (NILP (buffer))
@@ -1482,7 +1516,12 @@ use their base buffer's parsers. */)
tail = BVAR (buf, ts_parser_list);
FOR_EACH_TAIL (tail)
- return_list = Fcons (XCAR (tail), return_list);
+ {
+ struct Lisp_TS_Parser *parser = XTS_PARSER (XCAR (tail));
+ if ((NILP (language) || EQ (language, parser->language_symbol))
+ && (EQ (tag, Qt) || EQ (tag, parser->tag)))
+ return_list = Fcons (XCAR (tail), return_list);
+ }
return Freverse (return_list);
}
@@ -1510,6 +1549,16 @@ This symbol is the one used to create the parser. */)
return XTS_PARSER (parser)->language_symbol;
}
+DEFUN ("treesit-parser-tag",
+ Ftreesit_parser_tag, Streesit_parser_tag,
+ 1, 1, 0,
+ doc: /* Return PARSER's tag. */)
+ (Lisp_Object parser)
+{
+ treesit_check_parser (parser);
+ return XTS_PARSER (parser)->tag;
+}
+
/* Return true if PARSER is not deleted and its buffer is live. */
static bool
treesit_parser_live_p (Lisp_Object parser)
@@ -1613,6 +1662,10 @@ buffer. */)
treesit_check_parser (parser);
if (!NILP (ranges))
CHECK_CONS (ranges);
+
+ if (!NILP (Fequal (XTS_PARSER (parser)->last_set_ranges, ranges)))
+ return Qnil;
+
treesit_check_range_argument (ranges);
treesit_initialize ();
@@ -1620,10 +1673,10 @@ buffer. */)
treesit_check_buffer_size (XBUFFER (XTS_PARSER (parser)->buffer));
treesit_sync_visible_region (parser);
+ XTS_PARSER (parser)->last_set_ranges = ranges;
bool success;
if (NILP (ranges))
{
- XTS_PARSER (parser)->has_range = false;
/* If RANGES is nil, make parser to parse the whole document.
To do that we give tree-sitter a 0 length, the range is a
dummy. */
@@ -1634,14 +1687,15 @@ buffer. */)
else
{
/* Set ranges for PARSER. */
- XTS_PARSER (parser)->has_range = true;
-
if (list_length (ranges) > UINT32_MAX)
xsignal (Qargs_out_of_range, list2 (ranges, Flength (ranges)));
uint32_t len = (uint32_t) list_length (ranges);
TSRange *treesit_ranges = xmalloc (sizeof (TSRange) * len);
struct buffer *buffer = XBUFFER (XTS_PARSER (parser)->buffer);
+ /* We can use XFIXNUM, XCAR, XCDR freely because we have checked
+ the input by treesit_check_range_argument. */
+
for (int idx = 0; !NILP (ranges); idx++, ranges = XCDR (ranges))
{
Lisp_Object range = XCAR (ranges);
@@ -1662,9 +1716,6 @@ buffer. */)
}
success = ts_parser_set_included_ranges (XTS_PARSER (parser)->parser,
treesit_ranges, len);
- /* Although XFIXNUM could signal, it should be impossible
- because we have checked the input by treesit_check_range_argument.
- So there is no need for unwind-protect. */
xfree (treesit_ranges);
}
@@ -1692,10 +1743,10 @@ See also `treesit-parser-set-included-ranges'. */)
/* When the parser doesn't have a range set and we call
ts_parser_included_ranges on it, it doesn't return an empty list,
- but rather return some garbled data. (A single range where
- start_byte = 0, end_byte = UINT32_MAX). So we need to track
- whether the parser is ranged ourselves. */
- if (!XTS_PARSER (parser)->has_range)
+ but rather return DEFAULT_RANGE. (A single range where start_byte
+ = 0, end_byte = UINT32_MAX). So we need to track whether the
+ parser is ranged ourselves. */
+ if (NILP (XTS_PARSER (parser)->last_set_ranges))
return Qnil;
uint32_t len;
@@ -1990,19 +2041,19 @@ live. */)
TSNode treesit_node = XTS_NODE (node)->node;
bool result;
- if (EQ (property, Qoutdated))
+ if (BASE_EQ (property, Qoutdated))
return treesit_node_uptodate_p (node) ? Qnil : Qt;
treesit_check_node (node);
- if (EQ (property, Qnamed))
+ if (BASE_EQ (property, Qnamed))
result = ts_node_is_named (treesit_node);
- else if (EQ (property, Qmissing))
+ else if (BASE_EQ (property, Qmissing))
result = ts_node_is_missing (treesit_node);
- else if (EQ (property, Qextra))
+ else if (BASE_EQ (property, Qextra))
result = ts_node_is_extra (treesit_node);
- else if (EQ (property, Qhas_error))
+ else if (BASE_EQ (property, Qhas_error))
result = ts_node_has_error (treesit_node);
- else if (EQ (property, Qlive))
+ else if (BASE_EQ (property, Qlive))
result = treesit_parser_live_p (XTS_NODE (node)->parser);
else
signal_error ("Expecting `named', `missing', `extra', "
@@ -2300,6 +2351,49 @@ produced by tree-sitter. */)
/*** Query functions */
+/* Convert a Lisp string to its printed representation in the tree-sitter
+ query syntax. */
+static Lisp_Object
+treesit_query_string_string (Lisp_Object str)
+{
+ /* Strings in the treesit query syntax only have the escapes
+ \n \r \t \0 and any other escaped char stands for that character.
+ Literal LF, NUL and " are forbidden. */
+ ptrdiff_t nbytes = SBYTES (str);
+ ptrdiff_t escapes = 0;
+ for (ptrdiff_t i = 0; i < nbytes; i++)
+ {
+ unsigned char c = SREF (str, i);
+ escapes += (c == '\0' || c == '\n' || c == '\r' || c == '\t'
+ || c == '"' || c == '\\');
+ }
+ ptrdiff_t nchars = SCHARS (str);
+ ptrdiff_t extra = escapes + 2; /* backslashes + double quotes */
+ Lisp_Object dst = (STRING_MULTIBYTE (str)
+ ? make_uninit_multibyte_string (nchars + extra,
+ nbytes + extra)
+ : make_uninit_string (nbytes + extra));
+ unsigned char *d = SDATA (dst);
+ *d++ = '"';
+ for (ptrdiff_t i = 0; i < nbytes; i++)
+ {
+ unsigned char c = SREF (str, i);
+ switch (c)
+ {
+ case '\0': *d++ = '\\'; *d++ = '0'; break;
+ case '\n': *d++ = '\\'; *d++ = 'n'; break;
+ case '\r': *d++ = '\\'; *d++ = 'r'; break;
+ case '\t': *d++ = '\\'; *d++ = 't'; break;
+ case '"':
+ case '\\': *d++ = '\\'; *d++ = c; break;
+ default: *d++ = c; break;
+ }
+ }
+ *d++ = '"';
+ eassert (d == SDATA (dst) + SBYTES (dst));
+ return dst;
+}
+
DEFUN ("treesit-pattern-expand",
Ftreesit_pattern_expand,
Streesit_pattern_expand, 1, 1, 0,
@@ -2324,19 +2418,19 @@ PATTERN can be
See Info node `(elisp)Pattern Matching' for detailed explanation. */)
(Lisp_Object pattern)
{
- if (EQ (pattern, QCanchor))
+ if (BASE_EQ (pattern, QCanchor))
return Vtreesit_str_dot;
- if (EQ (pattern, intern_c_string (":?")))
+ if (BASE_EQ (pattern, QCquestion))
return Vtreesit_str_question_mark;
- if (EQ (pattern, intern_c_string (":*")))
+ if (BASE_EQ (pattern, QCstar))
return Vtreesit_str_star;
- if (EQ (pattern, intern_c_string (":+")))
+ if (BASE_EQ (pattern, QCplus))
return Vtreesit_str_plus;
- if (EQ (pattern, QCequal))
+ if (BASE_EQ (pattern, QCequal))
return Vtreesit_str_pound_equal;
- if (EQ (pattern, QCmatch))
+ if (BASE_EQ (pattern, QCmatch))
return Vtreesit_str_pound_match;
- if (EQ (pattern, QCpred))
+ if (BASE_EQ (pattern, QCpred))
return Vtreesit_str_pound_pred;
Lisp_Object opening_delimeter
= VECTORP (pattern)
@@ -2350,6 +2444,9 @@ See Info node `(elisp)Pattern Matching' for detailed explanation. */)
pattern,
Vtreesit_str_space),
closing_delimiter);
+ if (STRINGP (pattern))
+ return treesit_query_string_string (pattern);
+
return Fprin1_to_string (pattern, Qnil, Qt);
}
@@ -2438,87 +2535,111 @@ treesit_predicates_for_pattern (TSQuery *query, uint32_t pattern_index)
return Fnreverse (result);
}
-/* Translate a capture NAME (symbol) to a node.
- Signals treesit-query-error if such node is not captured. */
-static Lisp_Object
+/* Translate a capture NAME (symbol) to a node. If everything goes
+ fine, set NODE and return true; if error occurs (e.g., when there
+ is no node for the capture name), set NODE to Qnil, SIGNAL_DATA to
+ a suitable signal data, and return false. */
+static bool
treesit_predicate_capture_name_to_node (Lisp_Object name,
- struct capture_range captures)
+ struct capture_range captures,
+ Lisp_Object *node,
+ Lisp_Object *signal_data)
{
- Lisp_Object node = Qnil;
+ *node = Qnil;
for (Lisp_Object tail = captures.start; !EQ (tail, captures.end);
tail = XCDR (tail))
{
if (EQ (XCAR (XCAR (tail)), name))
{
- node = XCDR (XCAR (tail));
+ *node = XCDR (XCAR (tail));
break;
}
}
- if (NILP (node))
- xsignal3 (Qtreesit_query_error,
- build_string ("Cannot find captured node"),
- name, build_string ("A predicate can only refer"
- " to captured nodes in the "
- "same pattern"));
- return node;
+ if (NILP (*node))
+ {
+ *signal_data = list3 (build_string ("Cannot find captured node"),
+ name, build_string ("A predicate can only refer"
+ " to captured nodes in the "
+ "same pattern"));
+ return false;
+ }
+ return true;
}
/* Translate a capture NAME (symbol) to the text of the captured node.
- Signals treesit-query-error if such node is not captured. */
-static Lisp_Object
+ If everything goes fine, set TEXT to the text and return true;
+ otherwise set TEXT to Qnil and set SIGNAL_DATA to a suitable signal
+ data. */
+static bool
treesit_predicate_capture_name_to_text (Lisp_Object name,
- struct capture_range captures)
+ struct capture_range captures,
+ Lisp_Object *text,
+ Lisp_Object *signal_data)
{
- Lisp_Object node = treesit_predicate_capture_name_to_node (name, captures);
+ Lisp_Object node = Qnil;
+ if (!treesit_predicate_capture_name_to_node (name, captures, &node, signal_data))
+ return false;
struct buffer *old_buffer = current_buffer;
set_buffer_internal (XBUFFER (XTS_PARSER (XTS_NODE (node)->parser)->buffer));
- Lisp_Object text = Fbuffer_substring (Ftreesit_node_start (node),
- Ftreesit_node_end (node));
+ *text = Fbuffer_substring (Ftreesit_node_start (node),
+ Ftreesit_node_end (node));
set_buffer_internal (old_buffer);
- return text;
+ return true;
}
/* Handles predicate (#equal A B). Return true if A equals B; return
false otherwise. A and B can be either string, or a capture name.
The capture name evaluates to the text its captured node spans in
- the buffer. */
+ the buffer. If everything goes fine, don't touch SIGNAL_DATA; if
+ error occurs, set it to a suitable signal data. */
static bool
-treesit_predicate_equal (Lisp_Object args, struct capture_range captures)
+treesit_predicate_equal (Lisp_Object args, struct capture_range captures,
+ Lisp_Object *signal_data)
{
- if (XFIXNUM (Flength (args)) != 2)
- xsignal2 (Qtreesit_query_error,
- build_string ("Predicate `equal' requires "
- "two arguments but only given"),
- Flength (args));
-
+ if (list_length (args) != 2)
+ {
+ *signal_data = list2 (build_string ("Predicate `equal' requires "
+ "two arguments but got"),
+ Flength (args));
+ return false;
+ }
Lisp_Object arg1 = XCAR (args);
Lisp_Object arg2 = XCAR (XCDR (args));
- Lisp_Object text1 = (STRINGP (arg1)
- ? arg1
- : treesit_predicate_capture_name_to_text (arg1,
- captures));
- Lisp_Object text2 = (STRINGP (arg2)
- ? arg2
- : treesit_predicate_capture_name_to_text (arg2,
- captures));
+ Lisp_Object text1 = arg1;
+ Lisp_Object text2 = arg2;
+ if (SYMBOLP (arg1))
+ {
+ if (!treesit_predicate_capture_name_to_text (arg1, captures, &text1,
+ signal_data))
+ return false;
+ }
+ if (SYMBOLP (arg2))
+ {
+ if (!treesit_predicate_capture_name_to_text (arg2, captures, &text2,
+ signal_data))
+ return false;
+ }
return !NILP (Fstring_equal (text1, text2));
}
/* Handles predicate (#match "regexp" @node). Return true if "regexp"
- matches the text spanned by @node; return false otherwise. Matching
- is case-sensitive. */
+ matches the text spanned by @node; return false otherwise.
+ Matching is case-sensitive. If everything goes fine, don't touch
+ SIGNAL_DATA; if error occurs, set it to a suitable signal data. */
static bool
-treesit_predicate_match (Lisp_Object args, struct capture_range captures)
+treesit_predicate_match (Lisp_Object args, struct capture_range captures,
+ Lisp_Object *signal_data)
{
- if (XFIXNUM (Flength (args)) != 2)
- xsignal2 (Qtreesit_query_error,
- build_string ("Predicate `match' requires two "
- "arguments but only given"),
- Flength (args));
-
+ if (list_length (args) != 2)
+ {
+ *signal_data = list2 (build_string ("Predicate `match' requires two "
+ "arguments but got"),
+ Flength (args));
+ return false;
+ }
Lisp_Object regexp = XCAR (args);
Lisp_Object capture_name = XCAR (XCDR (args));
@@ -2535,12 +2656,10 @@ treesit_predicate_match (Lisp_Object args, struct capture_range captures)
build_string ("The second argument to `match' should "
"be a capture name, not a string"));
- Lisp_Object node = treesit_predicate_capture_name_to_node (capture_name,
- captures);
-
- struct buffer *old_buffer = current_buffer;
- struct buffer *buffer = XBUFFER (XTS_PARSER (XTS_NODE (node)->parser)->buffer);
- set_buffer_internal (buffer);
+ Lisp_Object node = Qnil;
+ if (!treesit_predicate_capture_name_to_node (capture_name, captures, &node,
+ signal_data))
+ return false;
TSNode treesit_node = XTS_NODE (node)->node;
ptrdiff_t visible_beg = XTS_PARSER (XTS_NODE (node)->parser)->visible_beg;
@@ -2561,68 +2680,78 @@ treesit_predicate_match (Lisp_Object args, struct capture_range captures)
ZV_BYTE = end_byte;
ptrdiff_t val = search_buffer (regexp, start_pos, start_byte,
- end_pos, end_byte, 1, 1, Qnil, Qnil, false);
+ end_pos, end_byte, 1, true, Qnil, Qnil, false);
BEGV = old_begv;
BEGV_BYTE = old_begv_byte;
ZV = old_zv;
ZV_BYTE = old_zv_byte;
- set_buffer_internal (old_buffer);
-
return (val > 0);
}
/* Handles predicate (#pred FN ARG...). Return true if FN returns
non-nil; return false otherwise. The arity of FN must match the
- number of ARGs */
+ number of ARGs. If everything goes fine, don't touch SIGNAL_DATA;
+ if error occurs, set it to a suitable signal data. */
static bool
-treesit_predicate_pred (Lisp_Object args, struct capture_range captures)
+treesit_predicate_pred (Lisp_Object args, struct capture_range captures,
+ Lisp_Object *signal_data)
{
- if (XFIXNUM (Flength (args)) < 2)
- xsignal2 (Qtreesit_query_error,
- build_string ("Predicate `pred' requires "
- "at least two arguments, "
- "but was only given"),
- Flength (args));
+ if (list_length (args) < 2)
+ {
+ *signal_data = list2 (build_string ("Predicate `pred' requires "
+ "at least two arguments, "
+ "but only got"),
+ Flength (args));
+ return false;
+ }
Lisp_Object fn = Fintern (XCAR (args), Qnil);
Lisp_Object nodes = Qnil;
Lisp_Object tail = XCDR (args);
FOR_EACH_TAIL (tail)
- nodes = Fcons (treesit_predicate_capture_name_to_node (XCAR (tail),
- captures),
- nodes);
+ {
+ Lisp_Object node = Qnil;
+ if (!treesit_predicate_capture_name_to_node (XCAR (tail), captures, &node,
+ signal_data))
+ return false;
+ nodes = Fcons (node, nodes);
+ }
nodes = Fnreverse (nodes);
return !NILP (CALLN (Fapply, fn, nodes));
}
-/* If all predicates in PREDICATES passes, return true; otherwise
- return false. */
+/* If all predicates in PREDICATES pass, return true; otherwise
+ return false. If everything goes fine, don't touch SIGNAL_DATA; if
+ error occurs, set it to a suitable signal data. */
static bool
-treesit_eval_predicates (struct capture_range captures, Lisp_Object predicates)
+treesit_eval_predicates (struct capture_range captures, Lisp_Object predicates,
+ Lisp_Object *signal_data)
{
bool pass = true;
/* Evaluate each predicates. */
for (Lisp_Object tail = predicates;
- !NILP (tail); tail = XCDR (tail))
+ pass && !NILP (tail); tail = XCDR (tail))
{
Lisp_Object predicate = XCAR (tail);
Lisp_Object fn = XCAR (predicate);
Lisp_Object args = XCDR (predicate);
if (!NILP (Fstring_equal (fn, Vtreesit_str_equal)))
- pass &= treesit_predicate_equal (args, captures);
+ pass &= treesit_predicate_equal (args, captures, signal_data);
else if (!NILP (Fstring_equal (fn, Vtreesit_str_match)))
- pass &= treesit_predicate_match (args, captures);
+ pass &= treesit_predicate_match (args, captures, signal_data);
else if (!NILP (Fstring_equal (fn, Vtreesit_str_pred)))
- pass &= treesit_predicate_pred (args, captures);
+ pass &= treesit_predicate_pred (args, captures, signal_data);
else
- xsignal3 (Qtreesit_query_error,
- build_string ("Invalid predicate"),
- fn, build_string ("Currently Emacs only supports"
- " equal, match, and pred"
- " predicate"));
+ {
+ *signal_data = list3 (build_string ("Invalid predicate"),
+ fn, build_string ("Currently Emacs only supports"
+ " `equal', `match', and `pred'"
+ " predicates"));
+ pass = false;
+ }
}
/* If all predicates passed, add captures to result list. */
return pass;
@@ -2662,8 +2791,8 @@ You can use `treesit-query-validate' to validate and debug a query. */)
Lisp_Object signal_symbol = Qnil;
Lisp_Object signal_data = Qnil;
TSQuery *treesit_query = treesit_ensure_query_compiled (lisp_query,
- &signal_symbol,
- &signal_data);
+ &signal_symbol,
+ &signal_data);
if (treesit_query == NULL)
xsignal (signal_symbol, signal_data);
@@ -2672,6 +2801,92 @@ You can use `treesit-query-validate' to validate and debug a query. */)
}
}
+/* Resolve OBJ into a tree-sitter node Lisp_Object. OBJ can be a
+ node, a parser, or a language symbol. Note that this function can
+ signal. */
+static Lisp_Object treesit_resolve_node (Lisp_Object obj)
+{
+ if (TS_NODEP (obj))
+ {
+ treesit_check_node (obj); /* Check if up-to-date. */
+ return obj;
+ }
+ else if (TS_PARSERP (obj))
+ {
+ treesit_check_parser (obj); /* Check if deleted. */
+ return Ftreesit_parser_root_node (obj);
+ }
+ else if (SYMBOLP (obj))
+ {
+ Lisp_Object parser
+ = Ftreesit_parser_create (obj, Fcurrent_buffer (), Qnil, Qnil);
+ return Ftreesit_parser_root_node (parser);
+ }
+ else
+ xsignal2 (Qwrong_type_argument,
+ list4 (Qor, Qtreesit_node_p, Qtreesit_parser_p, Qsymbolp),
+ obj);
+}
+
+/* Create and initialize QUERY. When success, initialize TS_QUERY,
+ CURSOR, and NEED_FREE, and return true; if failed, initialize
+ SIGNAL_SYMBOL and SIGNAL_DATA, and return false. If NEED_FREE is
+ initialized to true, the TS_QUERY and CURSOR needs to be freed
+ after use; otherwise they shouldn't be freed by hand.
+
+ Basically this function looks at QUERY and check its type, if QUERY
+ is a compiled query, this function takes out its query and cursor;
+ if QUERY is a string or a cons, this function creates a new query
+ and cursor (so they need to be manually freed).
+
+ This function assumes QUERY is either a compiled query, a string or
+ a cons, the caller should make sure QUERY is valid.
+
+ LANG is the language to use if we need to create the query and
+ cursor. */
+static bool
+treesit_initialize_query (Lisp_Object query, const TSLanguage *lang,
+ TSQuery **ts_query, TSQueryCursor **cursor,
+ bool *need_free, Lisp_Object *signal_symbol,
+ Lisp_Object *signal_data)
+{
+ if (TS_COMPILED_QUERY_P (query))
+ {
+ *ts_query = treesit_ensure_query_compiled (query, signal_symbol,
+ signal_data);
+ *cursor = XTS_COMPILED_QUERY (query)->cursor;
+ /* We don't need to free ts_query and cursor because they
+ are stored in a lisp object, which is tracked by gc. */
+ *need_free = false;
+ return (*ts_query != NULL);
+ }
+ else
+ {
+ /* Since query is not TS_COMPILED_QUERY, it can only be a string
+ or a cons. */
+ if (CONSP (query))
+ query = Ftreesit_query_expand (query);
+ char *query_string = SSDATA (query);
+ uint32_t error_offset;
+ TSQueryError error_type;
+ *ts_query = ts_query_new (lang, query_string, strlen (query_string),
+ &error_offset, &error_type);
+ if (*ts_query == NULL)
+ {
+ *signal_symbol = Qtreesit_query_error;
+ *signal_data = treesit_compose_query_signal_data (error_offset,
+ error_type, query);
+ return false;
+ }
+ else
+ {
+ *cursor = ts_query_cursor_new ();
+ *need_free = true;
+ return true;
+ }
+ }
+}
+
DEFUN ("treesit-query-capture",
Ftreesit_query_capture,
Streesit_query_capture, 2, 5, 0,
@@ -2712,35 +2927,12 @@ the query. */)
treesit_initialize ();
/* Resolve NODE into an actual node. */
- Lisp_Object lisp_node;
- if (TS_NODEP (node))
- {
- treesit_check_node (node); /* Check if up-to-date. */
- lisp_node = node;
- }
- else if (TS_PARSERP (node))
- {
- treesit_check_parser (node); /* Check if deleted. */
- lisp_node = Ftreesit_parser_root_node (node);
- }
- else if (SYMBOLP (node))
- {
- Lisp_Object parser
- = Ftreesit_parser_create (node, Fcurrent_buffer (), Qnil);
- lisp_node = Ftreesit_parser_root_node (parser);
- }
- else
- xsignal2 (Qwrong_type_argument,
- list4 (Qor, Qtreesit_node_p, Qtreesit_parser_p, Qsymbolp),
- node);
+ Lisp_Object lisp_node = treesit_resolve_node (node);
/* Extract C values from Lisp objects. */
- TSNode treesit_node
- = XTS_NODE (lisp_node)->node;
- Lisp_Object lisp_parser
- = XTS_NODE (lisp_node)->parser;
- ptrdiff_t visible_beg
- = XTS_PARSER (XTS_NODE (lisp_node)->parser)->visible_beg;
+ TSNode treesit_node = XTS_NODE (lisp_node)->node;
+ Lisp_Object lisp_parser = XTS_NODE (lisp_node)->parser;
+
const TSLanguage *lang
= ts_parser_language (XTS_PARSER (lisp_parser)->parser);
@@ -2756,44 +2948,21 @@ the query. */)
TSQuery *treesit_query;
TSQueryCursor *cursor;
bool needs_to_free_query_and_cursor;
- if (TS_COMPILED_QUERY_P (query))
- {
- Lisp_Object signal_symbol = Qnil;
- Lisp_Object signal_data = Qnil;
- treesit_query = treesit_ensure_query_compiled (query, &signal_symbol,
- &signal_data);
- cursor = XTS_COMPILED_QUERY (query)->cursor;
- /* We don't need to free ts_query and cursor because they
- are stored in a lisp object, which is tracked by gc. */
- needs_to_free_query_and_cursor = false;
- if (treesit_query == NULL)
- xsignal (signal_symbol, signal_data);
- }
- else
- {
- /* Since query is not TS_COMPILED_QUERY, it can only be a string
- or a cons. */
- if (CONSP (query))
- query = Ftreesit_query_expand (query);
- char *query_string = SSDATA (query);
- uint32_t error_offset;
- TSQueryError error_type;
- treesit_query = ts_query_new (lang, query_string, strlen (query_string),
- &error_offset, &error_type);
- if (treesit_query == NULL)
- xsignal (Qtreesit_query_error,
- treesit_compose_query_signal_data (error_offset,
- error_type, query));
- cursor = ts_query_cursor_new ();
- needs_to_free_query_and_cursor = true;
- }
+ Lisp_Object signal_symbol;
+ Lisp_Object signal_data;
+ if (!treesit_initialize_query (query, lang, &treesit_query, &cursor,
+ &needs_to_free_query_and_cursor,
+ &signal_symbol, &signal_data))
+ xsignal (signal_symbol, signal_data);
- /* WARN: After this point, free treesit_query and cursor before every
- signal and return. */
+ /* WARN: After this point, free TREESIT_QUERY and CURSOR before every
+ signal and return if NEEDS_TO_FREE_QUERY_AND_CURSOR is true. */
/* Set query range. */
if (!NILP (beg) && !NILP (end))
{
+ ptrdiff_t visible_beg
+ = XTS_PARSER (XTS_NODE (lisp_node)->parser)->visible_beg;
ptrdiff_t beg_byte = CHAR_TO_BYTE (XFIXNUM (beg));
ptrdiff_t end_byte = CHAR_TO_BYTE (XFIXNUM (end));
/* We never let tree-sitter run on buffers too large, so these
@@ -2822,11 +2991,16 @@ the query. */)
Lisp_Object result = Qnil;
Lisp_Object prev_result = result;
Lisp_Object predicates_table = make_vector (patterns_count, Qt);
+ Lisp_Object predicate_signal_data = Qnil;
+
+ struct buffer *old_buf = current_buffer;
+ set_buffer_internal (buf);
+
while (ts_query_cursor_next_match (cursor, &match))
{
/* Record the checkpoint that we may roll back to. */
prev_result = result;
- /* Get captured nodes. */
+ /* 1. Get captured nodes. */
const TSQueryCapture *captures = match.captures;
for (int idx = 0; idx < match.capture_count; idx++)
{
@@ -2849,9 +3023,10 @@ the query. */)
result = Fcons (cap, result);
}
- /* Get predicates. */
+ /* 2. Get predicates and check whether this match can be
+ included in the result list. */
Lisp_Object predicates = AREF (predicates_table, match.pattern_index);
- if (EQ (predicates, Qt))
+ if (BASE_EQ (predicates, Qt))
{
predicates = treesit_predicates_for_pattern (treesit_query,
match.pattern_index);
@@ -2860,15 +3035,28 @@ the query. */)
/* captures_lisp = Fnreverse (captures_lisp); */
struct capture_range captures_range = { result, prev_result };
- if (!treesit_eval_predicates (captures_range, predicates))
- /* Predicates didn't pass, roll back. */
+ bool match = treesit_eval_predicates (captures_range, predicates,
+ &predicate_signal_data);
+ if (!NILP (predicate_signal_data))
+ break;
+
+ /* Predicates didn't pass, roll back. */
+ if (!match)
result = prev_result;
}
+
+ /* Final clean up. */
if (needs_to_free_query_and_cursor)
{
ts_query_delete (treesit_query);
ts_query_cursor_delete (cursor);
}
+ set_buffer_internal (old_buf);
+
+ /* Some capture predicate signaled an error. */
+ if (!NILP (predicate_signal_data))
+ xsignal (Qtreesit_query_error, predicate_signal_data);
+
return Fnreverse (result);
}
@@ -2948,7 +3136,7 @@ treesit_cursor_helper (TSTreeCursor *cursor, TSNode node, Lisp_Object parser)
TSNode root = ts_tree_root_node (XTS_PARSER (parser)->tree);
*cursor = ts_tree_cursor_new (root);
bool success = treesit_cursor_helper_1 (cursor, &node, start_pos,
- end_pos, treesit_recursion_limit);
+ end_pos, TREESIT_RECURSION_LIMIT);
if (!success)
ts_tree_cursor_delete (cursor);
return success;
@@ -3079,10 +3267,143 @@ treesit_traverse_child_helper (TSTreeCursor *cursor,
}
}
-/* Return true if the node at CURSOR matches PRED. PRED can be a
- string or a function. This function assumes PRED is either a
- string or a function. If NAMED is true, also check that the node
- is named. */
+/* Given a symbol THING, and a language symbol LANGUAGE, find the
+ corresponding predicate definition in treesit-thing-settings.
+ Don't check for the type of THING and LANGUAGE.
+
+ If there isn't one, return Qnil. */
+static Lisp_Object
+treesit_traverse_get_predicate (Lisp_Object thing, Lisp_Object language)
+{
+ Lisp_Object cons = assq_no_signal (language, Vtreesit_thing_settings);
+ if (NILP (cons))
+ return Qnil;
+ Lisp_Object definitions = XCDR (cons);
+ Lisp_Object entry = assq_no_signal (thing, definitions);
+ if (NILP (entry))
+ return Qnil;
+ /* ENTRY looks like (THING PRED). */
+ Lisp_Object cdr = XCDR (entry);
+ if (!CONSP (cdr))
+ return Qnil;
+ return XCAR (cdr);
+}
+
+/* Validate the PRED passed to treesit_traverse_match_predicate. If
+ there's an error, set SIGNAL_DATA to (ERR . DATA), where ERR is an
+ error symbol, and DATA is something signal accepts, and return
+ false, otherwise return true. This function also check for
+ recursion levels: we place a arbitrary 100 level limit on recursive
+ predicates. RECURSION_LEVEL is the current recursion level (that
+ starts at 0), if it goes over 99, return false and set SIGNAL_DATA.
+ LANGUAGE is a LANGUAGE symbol. */
+static bool
+treesit_traverse_validate_predicate (Lisp_Object pred,
+ Lisp_Object language,
+ Lisp_Object *signal_data,
+ ptrdiff_t recursion_level)
+{
+ if (recursion_level > 99)
+ {
+ *signal_data = list2 (Qtreesit_invalid_predicate,
+ build_string ("Predicate recursion level "
+ "exceeded: it must not exceed "
+ "100 levels"));
+ return false;
+ }
+ if (STRINGP (pred))
+ return true;
+ else if (FUNCTIONP (pred))
+ return true;
+ else if (SYMBOLP (pred))
+ {
+ Lisp_Object definition = treesit_traverse_get_predicate (pred,
+ language);
+ if (NILP (definition))
+ {
+ *signal_data = list3 (Qtreesit_predicate_not_found,
+ build_string ("Cannot find the definition "
+ "of the predicate in "
+ "`treesit-thing-settings'"),
+ pred);
+ return false;
+ }
+ return treesit_traverse_validate_predicate (definition,
+ language,
+ signal_data,
+ recursion_level + 1);
+ }
+ else if (CONSP (pred))
+ {
+ Lisp_Object car = XCAR (pred);
+ Lisp_Object cdr = XCDR (pred);
+ if (BASE_EQ (car, Qnot))
+ {
+ if (!CONSP (cdr))
+ {
+ *signal_data = list3 (Qtreesit_invalid_predicate,
+ build_string ("Invalid `not' "
+ "predicate"),
+ pred);
+ return false;
+ }
+ /* At this point CDR must be a cons. */
+ if (XFIXNUM (Flength (cdr)) != 1)
+ {
+ *signal_data = list3 (Qtreesit_invalid_predicate,
+ build_string ("`not' can only "
+ "have one argument"),
+ pred);
+ return false;
+ }
+ return treesit_traverse_validate_predicate (XCAR (cdr),
+ language,
+ signal_data,
+ recursion_level + 1);
+ }
+ else if (BASE_EQ (car, Qor))
+ {
+ if (!CONSP (cdr) || NILP (cdr))
+ {
+ *signal_data = list3 (Qtreesit_invalid_predicate,
+ build_string ("`or' must have a list "
+ "of patterns as "
+ "arguments "),
+ pred);
+ return false;
+ }
+ FOR_EACH_TAIL (cdr)
+ {
+ if (!treesit_traverse_validate_predicate (XCAR (cdr),
+ language,
+ signal_data,
+ recursion_level + 1))
+ return false;
+ }
+ return true;
+ }
+ else if (STRINGP (car) && FUNCTIONP (cdr))
+ return true;
+ }
+ *signal_data = list3 (Qtreesit_invalid_predicate,
+ build_string ("Invalid predicate, see `treesit-thing-settings' for valid forms of predicate"),
+ pred);
+ return false;
+}
+
+/* Return true if the node at CURSOR matches PRED. PRED can be a lot
+ of things:
+
+ PRED := string | function | (string . function)
+ | (or PRED...) | (not PRED)
+
+ See docstring of treesit-search-forward and friends for the meaning
+ of each shape.
+
+ This function assumes PRED is in one of its valid forms. If NAMED
+ is true, also check that the node is named.
+
+ This function may signal if the predicate function signals. */
static bool
treesit_traverse_match_predicate (TSTreeCursor *cursor, Lisp_Object pred,
Lisp_Object parser, bool named)
@@ -3096,24 +3417,67 @@ treesit_traverse_match_predicate (TSTreeCursor *cursor, Lisp_Object pred,
const char *type = ts_node_type (node);
return fast_c_string_match (pred, type, strlen (type)) >= 0;
}
- else
+ else if (FUNCTIONP (pred))
{
Lisp_Object lisp_node = make_treesit_node (parser, node);
return !NILP (CALLN (Ffuncall, pred, lisp_node));
}
+ else if (SYMBOLP (pred))
+ {
+ Lisp_Object language = XTS_PARSER (parser)->language_symbol;
+ Lisp_Object definition = treesit_traverse_get_predicate (pred,
+ language);
+ return treesit_traverse_match_predicate (cursor, definition,
+ parser, named);
+ }
+ else if (CONSP (pred))
+ {
+ Lisp_Object car = XCAR (pred);
+ Lisp_Object cdr = XCDR (pred);
+
+ if (BASE_EQ (car, Qnot))
+ return !treesit_traverse_match_predicate (cursor, XCAR (cdr),
+ parser, named);
+ else if (BASE_EQ (car, Qor))
+ {
+ FOR_EACH_TAIL (cdr)
+ {
+ if (treesit_traverse_match_predicate (cursor, XCAR (cdr),
+ parser, named))
+ return true;
+ }
+ return false;
+ }
+ else if (STRINGP (car) && FUNCTIONP (cdr))
+ {
+ /* A bit of code duplication here, but should be fine. */
+ const char *type = ts_node_type (node);
+ if (!(fast_c_string_match (car, type, strlen (type)) >= 0))
+ return false;
+
+ Lisp_Object lisp_node = make_treesit_node (parser, node);
+ if (NILP (CALLN (Ffuncall, cdr, lisp_node)))
+ return false;
+
+ return true;
+ }
+ }
+ /* Returning false is better than UB. */
+ return false;
}
-/* Traverse the parse tree starting from CURSOR. PRED can be a
- function (takes a node and returns nil/non-nil), or a string
- (treated as regexp matching the node's type, must be all single
- byte characters). If the node satisfies PRED, leave CURSOR on that
- node and return true. If no node satisfies PRED, move CURSOR back
- to starting position and return false.
+/* Traverse the parse tree starting from CURSOR. See
+ `treesit-thing-settings' for the shapes PRED can have. If the
+ node satisfies PRED, leave CURSOR on that node and return true. If
+ no node satisfies PRED, move CURSOR back to starting position and
+ return false.
LIMIT is the number of levels we descend in the tree. FORWARD
controls the direction in which we traverse the tree, true means
forward, false backward. If SKIP_ROOT is true, don't match ROOT.
- */
+
+ This function may signal if the predicate function signals. */
+
static bool
treesit_search_dfs (TSTreeCursor *cursor,
Lisp_Object pred, Lisp_Object parser,
@@ -3149,7 +3513,10 @@ treesit_search_dfs (TSTreeCursor *cursor,
START. PRED, PARSER, NAMED, FORWARD are the same as in
ts_search_subtree. If a match is found, leave CURSOR at that node,
and return true, if no match is found, return false, and CURSOR's
- position is undefined. */
+ position is undefined.
+
+ This function may signal if the predicate function signals. */
+
static bool
treesit_search_forward (TSTreeCursor *cursor,
Lisp_Object pred, Lisp_Object parser,
@@ -3159,8 +3526,7 @@ treesit_search_forward (TSTreeCursor *cursor,
nodes. This way repeated call of this function traverses each
node in the tree once and only once:
- (while node (setq node (treesit-search-forward node)))
- */
+ (while node (setq node (treesit-search-forward node))) */
bool initial = true;
while (true)
{
@@ -3187,11 +3553,12 @@ treesit_search_forward (TSTreeCursor *cursor,
}
}
-/* Cleanup function for cursor. */
+/* Clean up the given tree cursor CURSOR. */
+
static void
-treesit_traverse_cleanup_cursor(void *cursor)
+treesit_traverse_cleanup_cursor (void *cursor)
{
- ts_tree_cursor_delete ((TSTreeCursor *) cursor);
+ ts_tree_cursor_delete (cursor);
}
DEFUN ("treesit-search-subtree",
@@ -3200,8 +3567,13 @@ DEFUN ("treesit-search-subtree",
doc: /* Traverse the parse tree of NODE depth-first using PREDICATE.
Traverse the subtree of NODE, and match PREDICATE with each node along
-the way. PREDICATE is a regexp string that matches against each
-node's type, or a function that takes a node and returns nil/non-nil.
+the way.
+
+PREDICATE can be a regexp string that matches against each node's
+type, a predicate function, and more. See `treesit-thing-settings'
+for the possible predicates. PREDICATE can also be a thing defined in
+`treesit-thing-settings'. Using an undefined thing doesn't raise an
+error.
By default, only traverse named nodes, but if ALL is non-nil, traverse
all nodes. If BACKWARD is non-nil, traverse backwards. If DEPTH is
@@ -3213,14 +3585,12 @@ Return the first matched node, or nil if none matches. */)
Lisp_Object all, Lisp_Object depth)
{
CHECK_TS_NODE (node);
- CHECK_TYPE (STRINGP (predicate) || FUNCTIONP (predicate),
- list3 (Qor, Qstringp, Qfunctionp), predicate);
CHECK_SYMBOL (all);
CHECK_SYMBOL (backward);
/* We use a default limit of 1000. See bug#59426 for the
discussion. */
- ptrdiff_t the_limit = treesit_recursion_limit;
+ ptrdiff_t the_limit = TREESIT_RECURSION_LIMIT;
if (!NILP (depth))
{
CHECK_FIXNUM (depth);
@@ -3230,6 +3600,19 @@ Return the first matched node, or nil if none matches. */)
treesit_initialize ();
Lisp_Object parser = XTS_NODE (node)->parser;
+ Lisp_Object language = XTS_PARSER (parser)->language_symbol;
+
+ Lisp_Object signal_data = Qnil;
+ if (!treesit_traverse_validate_predicate (predicate, language,
+ &signal_data, 0))
+ {
+ Lisp_Object err_symbol = XCAR (signal_data);
+ Lisp_Object data = XCDR (signal_data);
+ if (EQ (err_symbol, Qtreesit_predicate_not_found))
+ return Qnil;
+ xsignal1 (err_symbol, data);
+ }
+
Lisp_Object return_value = Qnil;
TSTreeCursor cursor;
if (!treesit_cursor_helper (&cursor, XTS_NODE (node)->node, parser))
@@ -3254,9 +3637,13 @@ DEFUN ("treesit-search-forward",
doc: /* Search for node matching PREDICATE in the parse tree of START.
Start traversing the tree from node START, and match PREDICATE with
-each node (except START itself) along the way. PREDICATE is a regexp
-string that matches against each node's type, or a function that takes
-a node and returns non-nil if it matches.
+each node (except START itself) along the way.
+
+PREDICATE can be a regexp string that matches against each node's
+type, a predicate function, and more. See `treesit-thing-settings'
+for the possible predicates. PREDICATE can also be a thing defined in
+`treesit-thing-settings'. Using an undefined thing doesn't raise an
+error.
By default, only search for named nodes, but if ALL is non-nil, search
for all nodes. If BACKWARD is non-nil, search backwards.
@@ -3282,14 +3669,25 @@ always traverse leaf nodes first, then upwards. */)
Lisp_Object all)
{
CHECK_TS_NODE (start);
- CHECK_TYPE (STRINGP (predicate) || FUNCTIONP (predicate),
- list3 (Qor, Qstringp, Qfunctionp), predicate);
CHECK_SYMBOL (all);
CHECK_SYMBOL (backward);
treesit_initialize ();
Lisp_Object parser = XTS_NODE (start)->parser;
+ Lisp_Object language = XTS_PARSER (parser)->language_symbol;
+
+ Lisp_Object signal_data = Qnil;
+ if (!treesit_traverse_validate_predicate (predicate, language,
+ &signal_data, 0))
+ {
+ Lisp_Object err_symbol = XCAR (signal_data);
+ Lisp_Object data = XCDR (signal_data);
+ if (EQ (err_symbol, Qtreesit_predicate_not_found))
+ return Qnil;
+ xsignal1 (err_symbol, data);
+ }
+
Lisp_Object return_value = Qnil;
TSTreeCursor cursor;
if (!treesit_cursor_helper (&cursor, XTS_NODE (start)->node, parser))
@@ -3311,7 +3709,9 @@ always traverse leaf nodes first, then upwards. */)
/* Recursively traverse the tree under CURSOR, and append the result
subtree to PARENT's cdr. See more in Ftreesit_induce_sparse_tree.
Note that the top-level children list is reversed, because
- reasons. */
+ reasons.
+
+ This function may signal if the predicate function signals. */
static void
treesit_build_sparse_tree (TSTreeCursor *cursor, Lisp_Object parent,
Lisp_Object pred, Lisp_Object process_fn,
@@ -3359,9 +3759,14 @@ DEFUN ("treesit-induce-sparse-tree",
Streesit_induce_sparse_tree, 2, 4, 0,
doc: /* Create a sparse tree of ROOT's subtree.
-This takes the subtree under ROOT, and combs it so only the nodes
-that match PREDICATE are left, like picking out grapes on the vine.
-PREDICATE is a regexp string that matches against each node's type.
+This takes the subtree under ROOT, and combs it so only the nodes that
+match PREDICATE are left, like picking out grapes on the vine.
+
+PREDICATE can be a regexp string that matches against each node's
+type, a predicate function, and more. See `treesit-thing-settings'
+for the possible predicates. PREDICATE can also be a thing defined in
+`treesit-thing-settings'. Using an undefined thing doesn't raise an
+error.
For a subtree on the left that consist of both numbers and letters, if
PREDICATE is "is letter", the returned tree is the one on the right.
@@ -3388,24 +3793,18 @@ ROOT. If DEPTH is nil or omitted, it defaults to 1000.
Each node in the returned tree looks like (NODE . (CHILD ...)). The
root of this tree might be nil, if ROOT doesn't match PREDICATE.
-If no node matches PREDICATE, return nil.
-
-PREDICATE can also be a function that takes a node and returns
-nil/non-nil, but it is slower and more memory consuming than using
-a regexp. */)
+If no node matches PREDICATE, return nil. */)
(Lisp_Object root, Lisp_Object predicate, Lisp_Object process_fn,
Lisp_Object depth)
{
CHECK_TS_NODE (root);
- CHECK_TYPE (STRINGP (predicate) || FUNCTIONP (predicate),
- list3 (Qor, Qstringp, Qfunctionp), predicate);
if (!NILP (process_fn))
CHECK_TYPE (FUNCTIONP (process_fn), Qfunctionp, process_fn);
/* We use a default limit of 1000. See bug#59426 for the
discussion. */
- ptrdiff_t the_limit = treesit_recursion_limit;
+ ptrdiff_t the_limit = TREESIT_RECURSION_LIMIT;
if (!NILP (depth))
{
CHECK_FIXNUM (depth);
@@ -3415,6 +3814,19 @@ a regexp. */)
treesit_initialize ();
Lisp_Object parser = XTS_NODE (root)->parser;
+ Lisp_Object language = XTS_PARSER (parser)->language_symbol;
+
+ Lisp_Object signal_data = Qnil;
+ if (!treesit_traverse_validate_predicate (predicate, language,
+ &signal_data, 0))
+ {
+ Lisp_Object err_symbol = XCAR (signal_data);
+ Lisp_Object data = XCDR (signal_data);
+ if (EQ (err_symbol, Qtreesit_predicate_not_found))
+ return Qnil;
+ xsignal1 (err_symbol, data);
+ }
+
Lisp_Object parent = Fcons (Qnil, Qnil);
/* In this function we never traverse above NODE, so we don't need
to use treesit_cursor_helper. */
@@ -3429,12 +3841,63 @@ a regexp. */)
unbind_to (count, Qnil);
Fsetcdr (parent, Fnreverse (Fcdr (parent)));
+
if (NILP (Fcdr (parent)))
return Qnil;
else
return parent;
}
+DEFUN ("treesit-node-match-p",
+ Ftreesit_node_match_p,
+ Streesit_node_match_p, 2, 3, 0,
+ doc: /* Check whether NODE matches PREDICATE.
+
+PREDICATE can be a symbol representing a thing in
+`treesit-thing-settings', or a predicate, like regexp matching node
+type, etc. See `treesit-thing-settings' for more details.
+
+Return non-nil if NODE matches PREDICATE, nil otherwise.
+
+Signals `treesit-invalid-predicate' if there's no definition of THING
+in `treesit-thing-settings', or if PREDICATE is malformed. If
+IGNORE-MISSING is non-nil, don't signal an error for missing THING
+definition, but still signal for malformed PREDICATE. */)
+ (Lisp_Object node, Lisp_Object predicate, Lisp_Object ignore_missing)
+{
+ CHECK_TS_NODE (node);
+
+ Lisp_Object parser = XTS_NODE (node)->parser;
+ Lisp_Object language = XTS_PARSER (parser)->language_symbol;
+
+ Lisp_Object signal_data = Qnil;
+ if (!treesit_traverse_validate_predicate (predicate, language,
+ &signal_data, 0))
+ {
+ Lisp_Object err_symbol = XCAR (signal_data);
+ Lisp_Object data = XCDR (signal_data);
+
+ if (!NILP (ignore_missing)
+ && EQ (err_symbol, Qtreesit_predicate_not_found))
+ return Qnil;
+
+ xsignal1 (err_symbol, data);
+ }
+
+ TSTreeCursor cursor = ts_tree_cursor_new (XTS_NODE (node)->node);
+
+ specpdl_ref count = SPECPDL_INDEX ();
+ record_unwind_protect_ptr (treesit_traverse_cleanup_cursor, &cursor);
+
+ bool match = false;
+ match = treesit_traverse_match_predicate (&cursor, predicate,
+ parser, false);
+
+ unbind_to (count, Qnil);
+
+ return match ? Qt : Qnil;
+}
+
DEFUN ("treesit-subtree-stat",
Ftreesit_subtree_stat,
Streesit_subtree_stat, 1, 1, 0,
@@ -3529,8 +3992,12 @@ syms_of_treesit (void)
DEFSYM (Qoutdated, "outdated");
DEFSYM (Qhas_error, "has-error");
DEFSYM (Qlive, "live");
+ DEFSYM (Qnot, "not");
DEFSYM (QCanchor, ":anchor");
+ DEFSYM (QCquestion, ":?");
+ DEFSYM (QCstar, ":*");
+ DEFSYM (QCplus, ":+");
DEFSYM (QCequal, ":equal");
DEFSYM (QCmatch, ":match");
DEFSYM (QCpred, ":pred");
@@ -3553,6 +4020,8 @@ syms_of_treesit (void)
"user-emacs-directory");
DEFSYM (Qtreesit_parser_deleted, "treesit-parser-deleted");
DEFSYM (Qtreesit_pattern_expand, "treesit-pattern-expand");
+ DEFSYM (Qtreesit_invalid_predicate, "treesit-invalid-predicate");
+ DEFSYM (Qtreesit_predicate_not_found, "treesit-predicate-not-found");
DEFSYM (Qor, "or");
@@ -3580,6 +4049,10 @@ syms_of_treesit (void)
define_error (Qtreesit_parser_deleted,
"This parser is deleted and cannot be used",
Qtreesit_error);
+ define_error (Qtreesit_invalid_predicate,
+ "Invalid predicate, see `treesit-thing-settings' "
+ "for valid forms for a predicate",
+ Qtreesit_error);
DEFVAR_LISP ("treesit-load-name-override-list",
Vtreesit_load_name_override_list,
@@ -3610,6 +4083,33 @@ then in the `tree-sitter' subdirectory of `user-emacs-directory', and
then in the system default locations for dynamic libraries, in that order. */);
Vtreesit_extra_load_path = Qnil;
+ DEFVAR_LISP ("treesit-thing-settings",
+ Vtreesit_thing_settings,
+ doc:
+ /* A list defining things.
+
+The value should be an alist of (LANGUAGE . DEFINITIONS), where
+LANGUAGE is a language symbol, and DEFINITIONS is a list of
+
+ (THING PRED)
+
+THING is a symbol representing the thing, like `defun', `sexp', or
+`sentence'; PRED defines what kind of node can be qualified as THING.
+
+PRED can be a regexp string that matches the type of the node; it can
+be a predicate function that takes the node as the sole argument and
+returns t if the node is the thing, and nil otherwise; it can be a
+cons (REGEXP . FN), which is a combination of a regexp and a predicate
+function, and the node has to match both to qualify as the thing.
+
+PRED can also be recursively defined. It can be (or PRED...), meaning
+satisfying anyone of the inner PREDs qualifies the node; or (not
+PRED), meaning not satisfying the inner PRED qualifies the node.
+
+Finally, PRED can refer to other THINGs defined in this list by using
+the symbol of that THING. For example, (or sexp sentence). */);
+ Vtreesit_thing_settings = Qnil;
+
staticpro (&Vtreesit_str_libtree_sitter);
Vtreesit_str_libtree_sitter = build_pure_c_string ("libtree-sitter-");
staticpro (&Vtreesit_str_tree_sitter);
@@ -3666,6 +4166,7 @@ then in the system default locations for dynamic libraries, in that order. */);
defsubr (&Streesit_parser_list);
defsubr (&Streesit_parser_buffer);
defsubr (&Streesit_parser_language);
+ defsubr (&Streesit_parser_tag);
defsubr (&Streesit_parser_root_node);
/* defsubr (&Streesit_parse_string); */
@@ -3701,6 +4202,7 @@ then in the system default locations for dynamic libraries, in that order. */);
defsubr (&Streesit_search_subtree);
defsubr (&Streesit_search_forward);
defsubr (&Streesit_induce_sparse_tree);
+ defsubr (&Streesit_node_match_p);
defsubr (&Streesit_subtree_stat);
#endif /* HAVE_TREE_SITTER */
defsubr (&Streesit_available_p);
diff --git a/src/treesit.h b/src/treesit.h
index f5c8c67395d..bb81bf0e2b3 100644
--- a/src/treesit.h
+++ b/src/treesit.h
@@ -34,13 +34,21 @@ INLINE_HEADER_BEGIN
struct Lisp_TS_Parser
{
union vectorlike_header header;
- /* A symbol representing the language this parser uses. See the
+ /* A symbol representing the language this parser uses. See the
manual for more explanation. */
Lisp_Object language_symbol;
/* A list of functions to call after re-parse. Every function is
called with the changed ranges and the parser. The changed
ranges is a list of (BEG . END). */
Lisp_Object after_change_functions;
+ /* A tag (symbol) for the parser. Different parsers can have the
+ same tag. A tag is primarily used to differentiate between
+ parsers for the same language. */
+ Lisp_Object tag;
+ /* The Lisp ranges last set. This is use to compare to the new
+ ranges the users wants to set, and avoid reparse if the new
+ ranges is the same as the last set one. */
+ Lisp_Object last_set_ranges;
/* The buffer associated with this parser. */
Lisp_Object buffer;
/* The pointer to the tree-sitter parser. Never NULL. */
@@ -74,9 +82,6 @@ struct Lisp_TS_Parser
/* If this field is true, parser functions raises
treesit-parser-deleted signal. */
bool deleted;
- /* If this field is true, the parser has ranges set. See
- Ftreesit_parser_included_ranges for why we need this. */
- bool has_range;
};
/* A wrapper around a tree-sitter node. */
@@ -185,7 +190,7 @@ INLINE_HEADER_END
extern void treesit_record_change (ptrdiff_t, ptrdiff_t, ptrdiff_t);
extern Lisp_Object make_treesit_parser (Lisp_Object, TSParser *, TSTree *,
- Lisp_Object);
+ Lisp_Object, Lisp_Object);
extern Lisp_Object make_treesit_node (Lisp_Object, TSNode);
extern bool treesit_node_uptodate_p (Lisp_Object);
diff --git a/src/verbose.mk.in b/src/verbose.mk.in
index 11a625d3722..6efb6b9416b 100644
--- a/src/verbose.mk.in
+++ b/src/verbose.mk.in
@@ -32,6 +32,11 @@ AM_V_GEN =
AM_V_GLOBALS =
AM_V_NO_PD =
AM_V_RC =
+AM_V_JAVAC =
+AM_V_DX =
+AM_V_AAPT =
+AM_V_ZIPALIGN =
+AM_V_SILENT =
else
# Whether $(info ...) works. This is to work around a bug in GNU Make
@@ -48,32 +53,39 @@ have_working_info = $(filter notintermediate,$(value .FEATURES))
# The workaround is done only for AM_V_ELC and AM_V_ELN,
# since the bug is not annoying elsewhere.
-AM_V_AR = @$(info $ AR $@)
+. :=
+AM_V_AR = @$(info $. AR $@)
AM_V_at = @
-AM_V_CC = @$(info $ CC $@)
-AM_V_CXX = @$(info $ CXX $@)
-AM_V_CCLD = @$(info $ CCLD $@)
-AM_V_CXXLD = @$(info $ CXXLD $@)
+AM_V_CC = @$(info $. CC $@)
+AM_V_CXX = @$(info $. CXX $@)
+AM_V_CCLD = @$(info $. CCLD $@)
+AM_V_CXXLD = @$(info $. CXXLD $@)
ifeq ($(HAVE_NATIVE_COMP)-$(NATIVE_DISABLED)-$(ANCIENT),yes--)
ifneq (,$(have_working_info))
-AM_V_ELC = @$(info $ ELC+ELN $@)
-AM_V_ELN = @$(info $ ELN $@)
+AM_V_ELC = @$(info $. ELC+ELN $@)
+AM_V_ELN = @$(info $. ELN $@)
else
AM_V_ELC = @echo " ELC+ELN " $@;
AM_V_ELN = @echo " ELN " $@;
endif
else
ifneq (,$(have_working_info))
-AM_V_ELC = @$(info $ ELC $@)
+AM_V_ELC = @$(info $. ELC $@)
else
AM_V_ELC = @echo " ELC " $@;
endif
AM_V_ELN =
endif
-AM_V_GEN = @$(info $ GEN $@)
-AM_V_GLOBALS = @$(info $ GEN globals.h)
+AM_V_GEN = @$(info $. GEN $@)
+AM_V_GLOBALS = @$(info $. GEN globals.h)
AM_V_NO_PD = --no-print-directory
-AM_V_RC = @$(info $ RC $@)
+AM_V_RC = @$(info $. RC $@)
+
+# These are used for the Android port.
+AM_V_JAVAC = @$(info $. JAVAC $@)
+AM_V_D8 = @$(info $. D8 $@)
+AM_V_AAPT = @$(info $. AAPT $@)
+AM_V_SILENT = @
endif
diff --git a/src/w16select.c b/src/w16select.c
index c8b91bfa883..ed450c665ff 100644
--- a/src/w16select.c
+++ b/src/w16select.c
@@ -275,7 +275,7 @@ set_clipboard_data (unsigned Format, void *Data, unsigned Size, int Raw)
{
clipboard_storage_size = truelen + 100;
last_clipboard_text =
- (char *) xrealloc (last_clipboard_text, clipboard_storage_size);
+ xrealloc (last_clipboard_text, clipboard_storage_size);
}
if (last_clipboard_text)
dosmemget (xbuf_addr, truelen, last_clipboard_text);
diff --git a/src/w32.c b/src/w32.c
index d463962b6c3..d34ab70f82d 100644
--- a/src/w32.c
+++ b/src/w32.c
@@ -9414,7 +9414,7 @@ sys_write (int fd, const void * buffer, unsigned int count)
errno = 0;
while (count > 0)
{
- unsigned this_chunk = count < chunk ? count : chunk;
+ unsigned this_chunk = min (count, chunk);
int n = _write (fd, p, this_chunk);
if (n > 0)
@@ -10335,7 +10335,8 @@ check_windows_init_file (void)
names from UTF-8 to ANSI. */
init_file = build_string ("term/w32-win");
fd =
- openp (Vload_path, init_file, Fget_load_suffixes (), NULL, Qnil, 0, 0);
+ openp (Vload_path, init_file, Fget_load_suffixes (), NULL, Qnil, 0, 0,
+ NULL);
if (fd < 0)
{
Lisp_Object load_path_print = Fprin1_to_string (Vload_path,
@@ -10391,11 +10392,16 @@ check_windows_init_file (void)
}
}
+/* from w32fns.c */
+extern void remove_w32_kbdhook (void);
+
void
term_ntproc (int ignored)
{
(void)ignored;
+ remove_w32_kbdhook ();
+
term_timers ();
/* shutdown the socket interface if necessary */
diff --git a/src/w32console.c b/src/w32console.c
index 0936b5f37e6..7dcbc795cac 100644
--- a/src/w32console.c
+++ b/src/w32console.c
@@ -659,6 +659,24 @@ w32_face_attributes (struct frame *f, int face_id)
return char_attr;
}
+/* The IME window is needed to receive the session notifications
+ required to reset the low level keyboard hook state. */
+
+static BOOL CALLBACK
+find_ime_window (HWND hwnd, LPARAM arg)
+{
+ char window_class[32];
+
+ GetClassName (hwnd, window_class, sizeof (window_class));
+ if (strcmp (window_class, "IME") == 0)
+ {
+ *(HWND *) arg = hwnd;
+ return FALSE;
+ }
+ /* keep looking */
+ return TRUE;
+}
+
void
initialize_w32_display (struct terminal *term, int *width, int *height)
{
@@ -818,11 +836,14 @@ initialize_w32_display (struct terminal *term, int *width, int *height)
else
w32_console_unicode_input = 0;
- /* Setup w32_display_info structure for this frame. */
+ /* Setup w32_display_info structure for this frame. */
w32_initialize_display_info (build_string ("Console"));
+ HWND hwnd = NULL;
+ EnumThreadWindows (GetCurrentThreadId (), find_ime_window, (LPARAM) &hwnd);
+
/* Set up the keyboard hook. */
- setup_w32_kbdhook ();
+ setup_w32_kbdhook (hwnd);
}
diff --git a/src/w32fns.c b/src/w32fns.c
index 8c7ac0959b8..ace8d1016a5 100644
--- a/src/w32fns.c
+++ b/src/w32fns.c
@@ -47,8 +47,16 @@ along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. */
#include "w32inevt.h"
#ifdef WINDOWSNT
+/* mingw.org's MinGW headers mistakenly omit this enumeration: */
+# ifndef MINGW_W64
+typedef enum _WTS_VIRTUAL_CLASS {
+ WTSVirtualClientData,
+ WTSVirtualFileHandle
+} WTS_VIRTUAL_CLASS;
+# endif
#include <mbstring.h>
#include <mbctype.h> /* for _getmbcp */
+#include <wtsapi32.h> /* for WTS(Un)RegisterSessionNotification */
#endif /* WINDOWSNT */
#if CYGWIN
@@ -204,6 +212,10 @@ typedef HRESULT (WINAPI * SetWindowTheme_Proc)
typedef HRESULT (WINAPI * DwmSetWindowAttribute_Proc)
(HWND hwnd, DWORD dwAttribute, IN LPCVOID pvAttribute, DWORD cbAttribute);
+typedef BOOL (WINAPI * WTSRegisterSessionNotification_Proc)
+ (HWND hwnd, DWORD dwFlags);
+typedef BOOL (WINAPI * WTSUnRegisterSessionNotification_Proc) (HWND hwnd);
+
TrackMouseEvent_Proc track_mouse_event_fn = NULL;
ImmGetCompositionString_Proc get_composition_string_fn = NULL;
ImmGetContext_Proc get_ime_context_fn = NULL;
@@ -220,6 +232,8 @@ IsDebuggerPresent_Proc is_debugger_present = NULL;
SetThreadDescription_Proc set_thread_description = NULL;
SetWindowTheme_Proc SetWindowTheme_fn = NULL;
DwmSetWindowAttribute_Proc DwmSetWindowAttribute_fn = NULL;
+WTSUnRegisterSessionNotification_Proc WTSUnRegisterSessionNotification_fn = NULL;
+WTSRegisterSessionNotification_Proc WTSRegisterSessionNotification_fn = NULL;
extern AppendMenuW_Proc unicode_append_menu;
@@ -291,10 +305,12 @@ static unsigned int sound_type = 0xFFFFFFFF;
/* Special virtual key code for indicating "any" key. */
#define VK_ANY 0xFF
-#ifndef WM_WTSSESSION_CHANGE
+#ifdef WINDOWSNT
+# ifndef WM_WTSSESSION_CHANGE
/* 32-bit MinGW does not define these constants. */
-# define WM_WTSSESSION_CHANGE 0x02B1
-# define WTS_SESSION_LOCK 0x7
+# define WM_WTSSESSION_CHANGE 0x02B1
+# define WTS_SESSION_LOCK 0x7
+# endif
#endif
#ifndef WS_EX_NOACTIVATE
@@ -307,6 +323,7 @@ static struct
int hook_count; /* counter, if several windows are created */
HHOOK hook; /* hook handle */
HWND console; /* console window handle */
+ HWND notified_wnd; /* window that receives session notifications */
int lwindown; /* Left Windows key currently pressed (and hooked) */
int rwindown; /* Right Windows key currently pressed (and hooked) */
@@ -1537,14 +1554,16 @@ w32_clear_under_internal_border (struct frame *f)
{
int width = FRAME_PIXEL_WIDTH (f);
int height = FRAME_PIXEL_HEIGHT (f);
- int face_id =
- (FRAME_PARENT_FRAME (f)
- ? (!NILP (Vface_remapping_alist)
- ? lookup_basic_face (NULL, f, CHILD_FRAME_BORDER_FACE_ID)
- : CHILD_FRAME_BORDER_FACE_ID)
- : (!NILP (Vface_remapping_alist)
- ? lookup_basic_face (NULL, f, INTERNAL_BORDER_FACE_ID)
- : INTERNAL_BORDER_FACE_ID));
+ int bottom_margin = FRAME_BOTTOM_MARGIN_HEIGHT (f);
+ int face_id = (FRAME_PARENT_FRAME (f)
+ ? (!NILP (Vface_remapping_alist)
+ ? lookup_basic_face (NULL, f,
+ CHILD_FRAME_BORDER_FACE_ID)
+ : CHILD_FRAME_BORDER_FACE_ID)
+ : (!NILP (Vface_remapping_alist)
+ ? lookup_basic_face (NULL, f,
+ INTERNAL_BORDER_FACE_ID)
+ : INTERNAL_BORDER_FACE_ID));
struct face *face = FACE_FROM_ID_OR_NULL (f, face_id);
block_input ();
@@ -1554,17 +1573,21 @@ w32_clear_under_internal_border (struct frame *f)
/* Fill border with internal border face. */
unsigned long color = face->background;
- w32_fill_area (f, hdc, color, 0, FRAME_TOP_MARGIN_HEIGHT (f), width, border);
+ w32_fill_area (f, hdc, color, 0, FRAME_TOP_MARGIN_HEIGHT (f),
+ width, border);
w32_fill_area (f, hdc, color, 0, 0, border, height);
w32_fill_area (f, hdc, color, width - border, 0, border, height);
- w32_fill_area (f, hdc, color, 0, height - border, width, border);
+ w32_fill_area (f, hdc, color, 0, height - bottom_margin - border,
+ width, border);
}
else
{
- w32_clear_area (f, hdc, 0, FRAME_TOP_MARGIN_HEIGHT (f), width, border);
+ w32_clear_area (f, hdc, 0, FRAME_TOP_MARGIN_HEIGHT (f),
+ width, border);
w32_clear_area (f, hdc, 0, 0, border, height);
w32_clear_area (f, hdc, width - border, 0, border, height);
- w32_clear_area (f, hdc, 0, height - border, width, border);
+ w32_clear_area (f, hdc, 0, height - bottom_margin - border,
+ width, border);
}
release_frame_dc (f, hdc);
unblock_input ();
@@ -1726,6 +1749,11 @@ w32_change_tab_bar_height (struct frame *f, int height)
leading to the tab bar height being incorrectly set upon the next
call to x_set_font. (bug#59285) */
int lines = height / unit;
+
+ /* Even so, HEIGHT might be less than unit if the tab bar face is
+ not so tall as the frame's font height; which if true lines will
+ be set to 0 and the tab bar will thus vanish. */
+
if (lines == 0 && height != 0)
lines = 1;
@@ -1806,6 +1834,33 @@ 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));
}
+static void
+w32_set_tool_bar_position (struct frame *f,
+ Lisp_Object new_value,
+ Lisp_Object old_value)
+{
+ if (!EQ (new_value, Qtop) && !EQ (new_value, Qbottom))
+ error ("Tool bar position must be either `top' or `bottom'");
+
+ if (EQ (new_value, old_value))
+ return;
+
+ /* Set the tool bar position. */
+ fset_tool_bar_position (f, new_value);
+
+ /* Now reconfigure frame glyphs to place the tool bar at the
+ bottom. While the inner height has not changed, call
+ `resize_frame_windows' to place each of the windows at its
+ new position. */
+
+ adjust_frame_size (f, -1, -1, 3, false, Qtool_bar_position);
+ adjust_frame_glyphs (f);
+ SET_FRAME_GARBAGED (f);
+
+ if (FRAME_W32_WINDOW (f))
+ w32_clear_under_internal_border (f);
+}
+
/* Enable or disable double buffering on frame F.
When double buffering is enabled, all drawing happens on a back
@@ -2338,7 +2393,7 @@ w32_init_class (HINSTANCE hinst)
static void
w32_applytheme (HWND hwnd)
{
- if (w32_darkmode)
+ if (w32_darkmode && w32_follow_system_dark_mode)
{
/* Set window theme to that of a built-in Windows app (Explorer),
because it has dark scroll bars and other UI elements. */
@@ -2706,7 +2761,7 @@ funhook (int code, WPARAM w, LPARAM l)
/* Set up the hook; can be called several times, with matching
remove_w32_kbdhook calls. */
void
-setup_w32_kbdhook (void)
+setup_w32_kbdhook (HWND hwnd)
{
kbdhook.hook_count++;
@@ -2762,6 +2817,15 @@ setup_w32_kbdhook (void)
/* Set the hook. */
kbdhook.hook = SetWindowsHookEx (WH_KEYBOARD_LL, funhook,
GetModuleHandle (NULL), 0);
+
+ /* Register session notifications so we get notified about the
+ computer being locked. */
+ kbdhook.notified_wnd = NULL;
+ if (hwnd != NULL && WTSRegisterSessionNotification_fn != NULL)
+ {
+ WTSRegisterSessionNotification_fn (hwnd, NOTIFY_FOR_THIS_SESSION);
+ kbdhook.notified_wnd = hwnd;
+ }
}
}
@@ -2773,7 +2837,11 @@ remove_w32_kbdhook (void)
if (kbdhook.hook_count == 0 && w32_kbdhook_active)
{
UnhookWindowsHookEx (kbdhook.hook);
+ if (kbdhook.notified_wnd != NULL
+ && WTSUnRegisterSessionNotification_fn != NULL)
+ WTSUnRegisterSessionNotification_fn (kbdhook.notified_wnd);
kbdhook.hook = NULL;
+ kbdhook.notified_wnd = NULL;
}
}
#endif /* WINDOWSNT */
@@ -2846,13 +2914,12 @@ check_w32_winkey_state (int vkey)
}
return 0;
}
-#endif /* WINDOWSNT */
/* Reset the keyboard hook state. Locking the workstation with Win-L
leaves the Win key(s) "down" from the hook's point of view - the
keyup event is never seen. Thus, this function must be called when
the system is locked. */
-static void
+void
reset_w32_kbdhook_state (void)
{
kbdhook.lwindown = 0;
@@ -2862,6 +2929,7 @@ reset_w32_kbdhook_state (void)
kbdhook.suppress_lone = 0;
kbdhook.winseen = 0;
}
+#endif /* WINDOWSNT */
/* GetKeyState and MapVirtualKey on Windows 95 do not actually distinguish
between left and right keys as advertised. We test for this
@@ -3819,7 +3887,7 @@ deliver_wm_chars (int do_translate, HWND hwnd, UINT msg, UINT wParam,
/* What follows is just heuristics; the correct treatment requires
non-destructive ToUnicode():
- http://search.cpan.org/~ilyaz/UI-KeyboardLayout/lib/UI/KeyboardLayout.pm#Can_an_application_on_Windows_accept_keyboard_events?_Part_IV:_application-specific_modifiers
+ https://metacpan.org/dist/UI-KeyboardLayout/view/lib/UI/KeyboardLayout.pm#Can-an-application-on-Windows-accept-keyboard-events?-Part-IV:-application-specific-modifiers
What one needs to find is:
* which of the present modifiers AFFECT the resulting char(s)
@@ -3881,7 +3949,7 @@ deliver_wm_chars (int do_translate, HWND hwnd, UINT msg, UINT wParam,
character is the same for AltGr-* (=rAlt-*) and Ctrl-Alt-* (in any
combination of handedness). For description of masks, see
- http://search.cpan.org/~ilyaz/UI-KeyboardLayout/lib/UI/KeyboardLayout.pm#Keyboard_input_on_Windows,_Part_I:_what_is_the_kernel_doing?
+ https://metacpan.org/dist/UI-KeyboardLayout/view/lib/UI/KeyboardLayout.pm#Keyboard-input-on-Windows,-Part-I:-what-is-the-kernel-doing?
By default, Emacs was using these coincidences via the following
heuristics: it was treating:
@@ -4091,6 +4159,47 @@ deliver_wm_chars (int do_translate, HWND hwnd, UINT msg, UINT wParam,
return 0;
}
+/* Maybe pass session notification registration to another frame. If
+ the frame with window handle HWND is deleted, we must pass the
+ notifications to some other frame, if they have been sent to this
+ frame before and have not already been passed on. If there is no
+ other frame, do nothing. */
+
+#ifdef WINDOWSNT
+static void
+maybe_pass_notification (HWND hwnd)
+{
+ if (hwnd == kbdhook.notified_wnd
+ && kbdhook.hook_count > 0 && w32_kbdhook_active)
+ {
+ Lisp_Object tail, frame;
+ struct frame *f;
+ bool found_frame = false;
+
+ FOR_EACH_FRAME (tail, frame)
+ {
+ f = XFRAME (frame);
+ if (FRAME_W32_P (f) && FRAME_OUTPUT_DATA (f) != NULL
+ && FRAME_W32_WINDOW (f) != hwnd)
+ {
+ found_frame = true;
+ break;
+ }
+ }
+
+ if (found_frame && WTSUnRegisterSessionNotification_fn != NULL
+ && WTSRegisterSessionNotification_fn != NULL)
+ {
+ /* There is another frame, pass on the session notification. */
+ HWND next_wnd = FRAME_W32_WINDOW (f);
+ WTSUnRegisterSessionNotification_fn (hwnd);
+ WTSRegisterSessionNotification_fn (next_wnd, NOTIFY_FOR_THIS_SESSION);
+ kbdhook.notified_wnd = next_wnd;
+ }
+ }
+}
+#endif /* WINDOWSNT */
+
/* Main window procedure */
static LRESULT CALLBACK
@@ -5263,23 +5372,29 @@ w32_wnd_proc (HWND hwnd, UINT msg, WPARAM wParam, LPARAM lParam)
#ifdef WINDOWSNT
case WM_CREATE:
- setup_w32_kbdhook ();
+ setup_w32_kbdhook (hwnd);
goto dflt;
#endif
case WM_DESTROY:
#ifdef WINDOWSNT
+ maybe_pass_notification (hwnd);
remove_w32_kbdhook ();
#endif
CoUninitialize ();
return 0;
+#ifdef WINDOWSNT
case WM_WTSSESSION_CHANGE:
if (wParam == WTS_SESSION_LOCK)
reset_w32_kbdhook_state ();
goto dflt;
+#endif
case WM_CLOSE:
+#ifdef WINDOWSNT
+ maybe_pass_notification (hwnd);
+#endif
wmsg.dwModifiers = w32_get_modifiers ();
my_post_msg (&wmsg, hwnd, msg, wParam, lParam);
return 0;
@@ -8993,7 +9108,9 @@ and width values are in pixels.
: 0),
make_fixnum (tab_bar_height))),
Fcons (Qtool_bar_external, Qnil),
- Fcons (Qtool_bar_position, tool_bar_height ? Qtop : Qnil),
+ Fcons (Qtool_bar_position, (tool_bar_height
+ ? FRAME_TOOL_BAR_POSITION (f)
+ : Qnil)),
Fcons (Qtool_bar_size,
Fcons (make_fixnum
(tool_bar_height
@@ -9084,10 +9201,11 @@ menu bar or tool bar of FRAME. */)
return list4 (make_fixnum (left + internal_border_width),
make_fixnum (top
+ FRAME_TAB_BAR_HEIGHT (f)
- + FRAME_TOOL_BAR_HEIGHT (f)
+ + FRAME_TOOL_BAR_TOP_HEIGHT (f)
+ internal_border_width),
make_fixnum (right - internal_border_width),
- make_fixnum (bottom - internal_border_width));
+ make_fixnum (bottom - internal_border_width
+ - FRAME_TOOL_BAR_BOTTOM_HEIGHT (f)));
}
else
return list4 (make_fixnum (left), make_fixnum (top),
@@ -10556,7 +10674,7 @@ frame_parm_handler w32_frame_parm_handlers[] =
gui_set_font_backend,
gui_set_alpha,
0, /* x_set_sticky */
- 0, /* x_set_tool_bar_position */
+ w32_set_tool_bar_position,
w32_set_inhibit_double_buffering,
w32_set_undecorated,
w32_set_parent_frame,
@@ -11080,12 +11198,20 @@ my_exception_handler (EXCEPTION_POINTERS * exception_data)
return prev_exception_handler (exception_data);
return EXCEPTION_EXECUTE_HANDLER;
}
-#endif
+#endif /* !CYGWIN */
typedef USHORT (WINAPI * CaptureStackBackTrace_proc) (ULONG, ULONG, PVOID *,
PULONG);
#define BACKTRACE_LIMIT_MAX 62
+/* The below must be kept in sync with the value of the
+ -Wl,-image-base switch we use in LD_SWITCH_SYSTEM_TEMACS, see
+ configure.ac. */
+#if defined MINGW_W64 && EMACS_INT_MAX > LONG_MAX
+# define DEFAULT_IMAGE_BASE (ptrdiff_t)0x400000000
+#else /* 32-bit MinGW build */
+# define DEFAULT_IMAGE_BASE (ptrdiff_t)0x01000000
+#endif
static int
w32_backtrace (void **buffer, int limit)
@@ -11140,6 +11266,13 @@ emacs_abort (void)
{
void *stack[BACKTRACE_LIMIT_MAX + 1];
int i = w32_backtrace (stack, BACKTRACE_LIMIT_MAX + 1);
+#ifdef CYGWIN
+ ptrdiff_t addr_offset = 0;
+#else /* MinGW */
+ /* The offset below is zero unless ASLR is in effect. */
+ ptrdiff_t addr_offset
+ = DEFAULT_IMAGE_BASE - (ptrdiff_t)GetModuleHandle (NULL);
+#endif /* MinGW */
if (i)
{
@@ -11190,8 +11323,13 @@ emacs_abort (void)
{
/* stack[] gives the return addresses, whereas we want
the address of the call, so decrease each address
- by approximate size of 1 CALL instruction. */
- sprintf (buf, "%p\r\n", (char *)stack[j] - sizeof(void *));
+ by approximate size of 1 CALL instruction. We add
+ ADDR_OFFSET to account for ASLR which changes the
+ base address of the program's image in memory,
+ whereas 'addr2line' needs to see addresses relative
+ to the fixed base recorded in the PE header. */
+ sprintf (buf, "%p\r\n",
+ (char *)stack[j] - sizeof(void *) + addr_offset);
if (stderr_fd >= 0)
write (stderr_fd, buf, strlen (buf));
if (errfile_fd >= 0)
@@ -11274,6 +11412,14 @@ globals_of_w32fns (void)
set_thread_description = (SetThreadDescription_Proc)
get_proc_addr (hm_kernel32, "SetThreadDescription");
+#ifdef WINDOWSNT
+ HMODULE wtsapi32_lib = LoadLibrary ("wtsapi32.dll");
+ WTSRegisterSessionNotification_fn = (WTSRegisterSessionNotification_Proc)
+ get_proc_addr (wtsapi32_lib, "WTSRegisterSessionNotification");
+ WTSUnRegisterSessionNotification_fn = (WTSUnRegisterSessionNotification_Proc)
+ get_proc_addr (wtsapi32_lib, "WTSUnRegisterSessionNotification");
+#endif
+
/* Support OS dark mode on Windows 10 version 1809 and higher.
See `w32_applytheme' which uses appropriate APIs per version of Windows.
For future wretches who may need to understand Windows build numbers:
@@ -11332,6 +11478,14 @@ This variable is used for debugging, and takes precedence over any
value of the `inhibit-double-buffering' frame parameter. */);
w32_disable_double_buffering = false;
+ DEFVAR_BOOL ("w32-follow-system-dark-mode", w32_follow_system_dark_mode,
+ doc: /* Whether to follow the system's Dark mode on MS-Windows.
+If this is nil, Emacs on MS-Windows will not follow the system's Dark
+mode as far as the appearance of title bars and scroll bars is
+concerned, it will always use the default Light mode instead.
+Changing the value takes effect only for frames created after the change. */);
+ w32_follow_system_dark_mode = true;
+
if (os_subtype == OS_SUBTYPE_NT)
w32_unicode_gui = 1;
else
diff --git a/src/w32font.c b/src/w32font.c
index f2d4e5e45e8..56061c0d9ce 100644
--- a/src/w32font.c
+++ b/src/w32font.c
@@ -1072,7 +1072,7 @@ w32font_open_internal (struct frame *f, Lisp_Object font_entity,
name to be usable in x-list-fonts. Eventually we expect to change
x-list-fonts and other places that use fonts so that this can be
an fcname or similar. */
- font->props[FONT_NAME_INDEX] = Ffont_xlfd_name (font_object, Qnil);
+ font->props[FONT_NAME_INDEX] = Ffont_xlfd_name (font_object, Qnil, Qt);
return 1;
}
@@ -2031,7 +2031,7 @@ static void
fill_in_logfont (struct frame *f, LOGFONT *logfont, Lisp_Object font_spec)
{
Lisp_Object tmp, extra;
- int dpi = FRAME_RES_Y (f);
+ int dpi = FRAME_RES (f);
tmp = AREF (font_spec, FONT_DPI_INDEX);
if (FIXNUMP (tmp))
@@ -2265,14 +2265,14 @@ font_supported_scripts (FONTSIGNATURE * sig)
/* Match a single subrange. SYM is set if bit N is set in subranges. */
#define SUBRANGE(n,sym) \
if (subranges[(n) / 32] & (1U << ((n) % 32))) \
- supported = Fcons ((sym), supported)
+ supported = Fcons (sym, supported)
/* Match multiple subranges. SYM is set if any MASK bit is set in
subranges[0 - 3]. */
#define MASK_ANY(mask0,mask1,mask2,mask3,sym) \
if ((subranges[0] & (mask0)) || (subranges[1] & (mask1)) \
|| (subranges[2] & (mask2)) || (subranges[3] & (mask3))) \
- supported = Fcons ((sym), supported)
+ supported = Fcons (sym, supported)
/* 0: ASCII (a.k.a. "Basic Latin"),
1: Latin-1 supplement, 2: Latin Extended A, 3: Latin Extended B,
diff --git a/src/w32heap.c b/src/w32heap.c
index ef7b1202048..601686f5331 100644
--- a/src/w32heap.c
+++ b/src/w32heap.c
@@ -121,9 +121,9 @@ typedef struct _RTL_HEAP_PARAMETERS {
# define DUMPED_HEAP_SIZE 10
#else
# if defined _WIN64 || defined WIDE_EMACS_INT
-# define DUMPED_HEAP_SIZE (23*1024*1024)
+# define DUMPED_HEAP_SIZE (28*1024*1024)
# else
-# define DUMPED_HEAP_SIZE (13*1024*1024)
+# define DUMPED_HEAP_SIZE (24*1024*1024)
# endif
#endif
diff --git a/src/w32inevt.c b/src/w32inevt.c
index 7243e9618e9..35d3420e39f 100644
--- a/src/w32inevt.c
+++ b/src/w32inevt.c
@@ -496,7 +496,7 @@ do_mouse_event (MOUSE_EVENT_RECORD *event,
if (!NILP (Vmouse_autoselect_window))
{
Lisp_Object mouse_window = window_from_coordinates (f, mx, my,
- 0, 0, 0);
+ 0, 0, 0, 0);
/* A window will be selected only when it is not
selected now, and the last mouse movement event was
not in it. A minibuffer window will be selected iff
diff --git a/src/w32notify.c b/src/w32notify.c
index 9f8a62a1daa..c93e8796fe2 100644
--- a/src/w32notify.c
+++ b/src/w32notify.c
@@ -350,6 +350,7 @@ start_watching (const char *file, HANDLE hdir, BOOL subdirs, DWORD flags)
xfree (dirwatch->io_info);
xfree (dirwatch->watchee);
xfree (dirwatch);
+ return NULL;
}
return dirwatch;
}
@@ -412,10 +413,7 @@ add_watch (const char *parent_dir, const char *file, BOOL subdirs, DWORD flags)
return NULL;
if ((dirwatch = start_watching (file, hdir, subdirs, flags)) == NULL)
- {
- CloseHandle (hdir);
- dirwatch->dir = NULL;
- }
+ CloseHandle (hdir);
return dirwatch;
}
diff --git a/src/w32proc.c b/src/w32proc.c
index 462ef0cebec..55ead13647b 100644
--- a/src/w32proc.c
+++ b/src/w32proc.c
@@ -1956,7 +1956,7 @@ sys_spawnve (int mode, char *cmdname, char **argv, char **envp)
program = build_string (cmdname);
full = Qnil;
openp (Vexec_path, program, Vexec_suffixes, &full, make_fixnum (X_OK),
- 0, 0);
+ 0, 0, NULL);
if (NILP (full))
{
errno = EINVAL;
diff --git a/src/w32term.c b/src/w32term.c
index 281ce3c663a..7afd1303b4d 100644
--- a/src/w32term.c
+++ b/src/w32term.c
@@ -950,7 +950,7 @@ w32_define_fringe_bitmap (int which, unsigned short *bits, int h, int wd)
{
int i = max_fringe_bmp;
max_fringe_bmp = which + 20;
- fringe_bmp = (HBITMAP *) xrealloc (fringe_bmp, max_fringe_bmp * sizeof (HBITMAP));
+ fringe_bmp = xrealloc (fringe_bmp, max_fringe_bmp * sizeof (HBITMAP));
while (i < max_fringe_bmp)
fringe_bmp[i++] = 0;
}
@@ -3377,7 +3377,7 @@ w32_construct_mouse_wheel (struct input_event *result, W32Msg *msg,
if (w32_wheel_scroll_lines == UINT_MAX)
{
Lisp_Object window = window_from_coordinates (f, p.x, p.y, NULL,
- false, false);
+ false, false, false);
if (!WINDOWP (window))
{
result->kind = NO_EVENT;
@@ -5336,7 +5336,7 @@ w32_read_socket (struct terminal *terminal,
{
static Lisp_Object last_mouse_window;
Lisp_Object window = window_from_coordinates
- (f, LOWORD (msg.msg.lParam), HIWORD (msg.msg.lParam), 0, 0, 0);
+ (f, LOWORD (msg.msg.lParam), HIWORD (msg.msg.lParam), 0, 0, 0, 0);
/* Window will be selected only when it is not
selected now and last mouse movement event was
@@ -5408,7 +5408,7 @@ w32_read_socket (struct terminal *terminal,
int x = XFIXNAT (inev.x);
int y = XFIXNAT (inev.y);
- window = window_from_coordinates (f, x, y, 0, 1, 1);
+ window = window_from_coordinates (f, x, y, 0, 1, 1, 1);
if (EQ (window, f->tab_bar_window))
{
@@ -5436,7 +5436,7 @@ w32_read_socket (struct terminal *terminal,
int x = XFIXNAT (inev.x);
int y = XFIXNAT (inev.y);
- window = window_from_coordinates (f, x, y, 0, 1, 1);
+ window = window_from_coordinates (f, x, y, 0, 1, 1, 1);
if (EQ (window, f->tool_bar_window)
/* Make sure the tool bar was previously
@@ -7379,7 +7379,7 @@ w32_initialize_display_info (Lisp_Object display_name)
{
static char const at[] = " at ";
ptrdiff_t nbytes = sizeof (title) + sizeof (at);
- if (INT_ADD_WRAPV (nbytes, SCHARS (Vsystem_name), &nbytes))
+ if (ckd_add (&nbytes, nbytes, SCHARS (Vsystem_name)))
memory_full (SIZE_MAX);
dpyinfo->w32_id_name = xmalloc (nbytes);
sprintf (dpyinfo->w32_id_name, "%s%s%s", title, at, SDATA (Vsystem_name));
diff --git a/src/w32term.h b/src/w32term.h
index 6930839ed18..3120c8bd71f 100644
--- a/src/w32term.h
+++ b/src/w32term.h
@@ -29,7 +29,7 @@ along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. */
calls us. The ALIGN_STACK attribute forces GCC to emit a preamble
code to re-align the stack at function entry. Further details
about this can be found in
- http://www.peterstock.co.uk/games/mingw_sse/. */
+ https://www.peterstock.co.uk/games/mingw_sse/. */
#ifdef __GNUC__
# if USE_STACK_LISP_OBJECTS && !defined _WIN64 && !defined __x86_64__ \
&& __GNUC__ + (__GNUC_MINOR__ > 1) >= 5
@@ -779,8 +779,9 @@ extern bool w32_image_rotations_p (void);
#ifdef WINDOWSNT
/* Keyboard hooks. */
-extern void setup_w32_kbdhook (void);
+extern void setup_w32_kbdhook (HWND);
extern void remove_w32_kbdhook (void);
+extern void reset_w32_kbdhook_state (void);
extern int check_w32_winkey_state (int);
#define w32_kbdhook_active (os_subtype != OS_SUBTYPE_9X)
#else
diff --git a/src/w32uniscribe.c b/src/w32uniscribe.c
index a73c0de06f9..b3112912c76 100644
--- a/src/w32uniscribe.c
+++ b/src/w32uniscribe.c
@@ -33,11 +33,6 @@ along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. */
#ifdef HAVE_HARFBUZZ
# include <hb.h>
# include <hb-ot.h> /* for hb_ot_font_set_funcs */
-# if GNUC_PREREQ (4, 3, 0)
-# define bswap_32(v) __builtin_bswap32(v)
-# else
-# include <byteswap.h>
-# endif
#endif
#include "lisp.h"
@@ -330,8 +325,7 @@ uniscribe_shape (Lisp_Object lgstring, Lisp_Object direction)
{
/* If that wasn't enough, keep trying with one more run. */
max_items++;
- items = (SCRIPT_ITEM *) xrealloc (items,
- sizeof (SCRIPT_ITEM) * max_items + 1);
+ items = xrealloc (items, sizeof (SCRIPT_ITEM) * max_items + 1);
}
if (FAILED (result))
@@ -1271,7 +1265,11 @@ w32hb_get_font_table (hb_face_t *face, hb_tag_t tag, void *data)
HFONT old_font = SelectObject (context, (HFONT) data);
char *font_data = NULL;
DWORD font_data_size = 0, val;
+#if GNUC_PREREQ (4, 3, 0)
+ DWORD table = __builtin_bswap32 (tag);
+#else
DWORD table = bswap_32 (tag);
+#endif
hb_blob_t *blob = NULL;
val = GetFontData (context, table, 0, font_data, font_data_size);
diff --git a/src/w32xfns.c b/src/w32xfns.c
index fa7d5fbdb61..b248697e658 100644
--- a/src/w32xfns.c
+++ b/src/w32xfns.c
@@ -23,6 +23,20 @@ along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. */
#include <windows.h>
#include <windowsx.h>
+#ifdef WINDOWSNT
+/* Override API version to get the required functionality. */
+# undef _WIN32_WINNT
+# define _WIN32_WINNT 0x0501
+/* mingw.org's MinGW headers mistakenly omit this enumeration: */
+# ifndef MINGW_W64
+typedef enum _WTS_VIRTUAL_CLASS {
+ WTSVirtualClientData,
+ WTSVirtualFileHandle
+} WTS_VIRTUAL_CLASS;
+# endif
+#include <wtsapi32.h> /* for WM_WTSSESSION_CHANGE, WTS_SESSION_LOCK */
+#endif /* WINDOWSNT */
+
#include "lisp.h"
#include "frame.h"
#include "w32term.h"
@@ -413,8 +427,18 @@ drain_message_queue (void)
while (PeekMessage (&msg, NULL, 0, 0, PM_REMOVE))
{
- if (msg.message == WM_EMACS_FILENOTIFY)
- retval = 1;
+ switch (msg.message)
+ {
+#ifdef WINDOWSNT
+ case WM_WTSSESSION_CHANGE:
+ if (msg.wParam == WTS_SESSION_LOCK)
+ reset_w32_kbdhook_state ();
+ break;
+#endif
+ case WM_EMACS_FILENOTIFY:
+ retval = 1;
+ break;
+ }
TranslateMessage (&msg);
DispatchMessage (&msg);
}
diff --git a/src/window.c b/src/window.c
index 8d4bde8d6db..748ad9e77d4 100644
--- a/src/window.c
+++ b/src/window.c
@@ -1680,7 +1680,8 @@ check_window_containing (struct window *w, void *user_data)
Lisp_Object
window_from_coordinates (struct frame *f, int x, int y,
- enum window_part *part, bool tab_bar_p, bool tool_bar_p)
+ enum window_part *part, bool menu_bar_p,
+ bool tab_bar_p, bool tool_bar_p)
{
Lisp_Object window;
struct check_window_data cw;
@@ -1693,6 +1694,21 @@ window_from_coordinates (struct frame *f, int x, int y,
cw.window = &window, cw.x = x, cw.y = y; cw.part = part;
foreach_window (f, check_window_containing, &cw);
+#if defined (HAVE_WINDOW_SYSTEM) && ! defined (HAVE_EXT_MENU_BAR)
+ /* If not found above, see if it's in the menu bar window, if a menu
+ bar exists. */
+ if (NILP (window)
+ && menu_bar_p
+ && WINDOWP (f->menu_bar_window)
+ && WINDOW_TOTAL_LINES (XWINDOW (f->menu_bar_window)) > 0
+ && (coordinates_in_window (XWINDOW (f->menu_bar_window), x, y)
+ != ON_NOTHING))
+ {
+ *part = ON_TEXT;
+ window = f->menu_bar_window;
+ }
+#endif
+
#if defined (HAVE_WINDOW_SYSTEM)
/* If not found above, see if it's in the tab bar window, if a tab
bar exists. */
@@ -1746,7 +1762,7 @@ function returns nil. */)
+ FRAME_INTERNAL_BORDER_WIDTH (f)),
(FRAME_PIXEL_Y_FROM_CANON_Y (f, y)
+ FRAME_INTERNAL_BORDER_WIDTH (f)),
- 0, false, false);
+ 0, false, false, false);
}
ptrdiff_t
@@ -3514,7 +3530,10 @@ window-start value is reasonable when this function is called. */)
void
replace_buffer_in_windows (Lisp_Object buffer)
{
- call1 (Qreplace_buffer_in_windows, buffer);
+ /* When kill-buffer is called early during loadup, this function is
+ undefined. */
+ if (!NILP (Ffboundp (Qreplace_buffer_in_windows)))
+ call1 (Qreplace_buffer_in_windows, buffer);
}
/* If BUFFER is shown in a window, safely replace it with some other
@@ -3810,7 +3829,7 @@ run_window_change_functions_1 (Lisp_Object symbol, Lisp_Object buffer,
frame. Make sure to record changes for each live frame
in window_change_record later. */
window_change_record_frames = true;
- safe_call1 (XCAR (funs), window_or_frame);
+ safe_calln (XCAR (funs), window_or_frame);
}
funs = XCDR (funs);
@@ -3876,6 +3895,9 @@ run_window_change_functions_1 (Lisp_Object symbol, Lisp_Object buffer,
*
* This function does not save and restore match data. Any functions
* it calls are responsible for doing that themselves.
+ *
+ * Additionally, report changes to each frame's selected window to the
+ * input method in textconv.c.
*/
void
run_window_change_functions (void)
@@ -4035,6 +4057,18 @@ run_window_change_functions (void)
run_window_change_functions_1
(Qwindow_selection_change_functions, Qnil, frame);
+#if defined HAVE_TEXT_CONVERSION
+
+ /* If the buffer or selected window has changed, also reset the
+ input method composition state. */
+
+ if ((frame_selected_window_change || frame_buffer_change)
+ && FRAME_LIVE_P (f)
+ && FRAME_WINDOW_P (f))
+ report_selected_window_change (f);
+
+#endif
+
/* A frame has changed state when a size or buffer change
occurred, its selected window has changed, when it was
(de-)selected or its window state change flag was set. */
@@ -4117,6 +4151,8 @@ set_window_buffer (Lisp_Object window, Lisp_Object buffer,
buffer);
w->start_at_line_beg = false;
w->force_start = false;
+ /* Flush the base_line cache since it applied to another buffer. */
+ w->base_line_number = 0;
}
wset_redisplay (w);
@@ -4813,10 +4849,9 @@ values. */)
return Qt;
}
+/* Resize frame F's windows when F's inner height (inner width if
+ HORFLAG is true) has been set to SIZE pixels. */
-/**
-Resize frame F's windows when F's inner height (inner width if HORFLAG
-is true) has been set to SIZE pixels. */
void
resize_frame_windows (struct frame *f, int size, bool horflag)
{
@@ -5298,7 +5333,17 @@ resize_mini_window_apply (struct window *w, int delta)
w->pixel_top = r->pixel_top + r->pixel_height;
w->top_line = r->top_line + r->total_lines;
- /* Enforce full redisplay of the frame. */
+ /* Enforce full redisplay of the frame. If f->redisplay is already
+ set, which it generally is in the wake of a ConfigureNotify
+ (frame resize) event, merely setting f->redisplay is insufficient
+ for redisplay_internal to continue redisplaying the frame, as
+ redisplay_internal cannot distinguish between f->redisplay set
+ before it calls redisplay_window and that after, so garbage the
+ frame as well. */
+
+ if (f->redisplay)
+ SET_FRAME_GARBAGED (f);
+
/* FIXME: Shouldn't some of the caller do it? */
fset_redisplay (f);
adjust_frame_glyphs (f);
@@ -5335,7 +5380,14 @@ grow_mini_window (struct window *w, int delta)
grow = call3 (Qwindow__resize_root_window_vertically,
root, make_fixnum (- delta), Qt);
- if (FIXNUMP (grow) && window_resize_check (r, false))
+ if (FIXNUMP (grow)
+ /* It might be impossible to resize the window, in which case
+ calling resize_mini_window_apply will set off an infinite
+ loop where the redisplay cycle so forced returns to
+ resize_mini_window, making endless attempts to expand the
+ minibuffer window to this impossible size. (bug#69140) */
+ && XFIXNUM (grow) != 0
+ && window_resize_check (r, false))
resize_mini_window_apply (w, -XFIXNUM (grow));
}
}
@@ -7057,6 +7109,10 @@ current at the start of the function. If DONT-SET-MINIWINDOW is non-nil,
the mini-window of the frame doesn't get set to the corresponding element
of CONFIGURATION.
+This function consults the variable `window-restore-killed-buffer-windows'
+when restoring a window whose buffer was killed after CONFIGURATION was
+recorded.
+
If CONFIGURATION was made from a frame that is now deleted,
only frame-independent values can be restored. In this case,
the return value is nil. Otherwise the value is t. */)
@@ -7067,6 +7123,7 @@ the return value is nil. Otherwise the value is t. */)
struct Lisp_Vector *saved_windows;
Lisp_Object new_current_buffer;
Lisp_Object frame;
+ Lisp_Object kept_windows = Qnil;
Lisp_Object old_frame = selected_frame;
struct frame *f;
ptrdiff_t old_point = -1;
@@ -7307,6 +7364,13 @@ the return value is nil. Otherwise the value is t. */)
BUF_PT (XBUFFER (w->contents)),
BUF_PT_BYTE (XBUFFER (w->contents)));
w->start_at_line_beg = true;
+ if (FUNCTIONP (window_restore_killed_buffer_windows)
+ && !MINI_WINDOW_P (w))
+ kept_windows = Fcons (listn (6, window, p->buffer,
+ Fmarker_last_position (p->start),
+ Fmarker_last_position (p->pointm),
+ p->dedicated, Qt),
+ kept_windows);
}
else if (!NILP (w->start))
/* Leaf window has no live buffer, get one. */
@@ -7322,11 +7386,25 @@ the return value is nil. Otherwise the value is t. */)
set_marker_restricted_both (w->pointm, w->contents, 0, 0);
set_marker_restricted_both (w->old_pointm, w->contents, 0, 0);
w->start_at_line_beg = true;
- if (!NILP (w->dedicated))
- /* Record this window as dead. */
- dead_windows = Fcons (window, dead_windows);
- /* Make sure window is no more dedicated. */
- wset_dedicated (w, Qnil);
+ if (!MINI_WINDOW_P (w))
+ {
+ if (FUNCTIONP (window_restore_killed_buffer_windows))
+ kept_windows
+ = Fcons (listn (6, window, p->buffer,
+ Fmarker_last_position (p->start),
+ Fmarker_last_position (p->pointm),
+ p->dedicated, Qnil),
+ kept_windows);
+ else if (EQ (window_restore_killed_buffer_windows, Qdelete)
+ || (!NILP (p->dedicated)
+ && (NILP (window_restore_killed_buffer_windows)
+ || EQ (window_restore_killed_buffer_windows,
+ Qdedicated))))
+ /* Try to delete this window later. */
+ dead_windows = Fcons (window, dead_windows);
+ /* Make sure window is no more dedicated. */
+ wset_dedicated (w, Qnil);
+ }
}
}
@@ -7430,6 +7508,11 @@ the return value is nil. Otherwise the value is t. */)
minibuf_selected_window = data->minibuf_selected_window;
SAFE_FREE ();
+
+ if (!NILP (Vrun_hooks) && FUNCTIONP (window_restore_killed_buffer_windows))
+ safe_calln (window_restore_killed_buffer_windows,
+ frame, kept_windows, Qconfiguration);
+
return FRAME_LIVE_P (f) ? Qt : Qnil;
}
@@ -8427,6 +8510,9 @@ syms_of_window (void)
DEFSYM (Qheader_line_format, "header-line-format");
DEFSYM (Qtab_line_format, "tab-line-format");
DEFSYM (Qno_other_window, "no-other-window");
+ DEFSYM (Qconfiguration, "configuration");
+ DEFSYM (Qdelete, "delete");
+ DEFSYM (Qdedicated, "dedicated");
DEFVAR_LISP ("temp-buffer-show-function", Vtemp_buffer_show_function,
doc: /* Non-nil means call as function to display a help buffer.
@@ -8584,6 +8670,62 @@ its buffer or its total or body size since the last redisplay. Each
call is performed with the frame temporarily selected. */);
Vwindow_configuration_change_hook = Qnil;
+ DEFVAR_LISP ("window-restore-killed-buffer-windows",
+ window_restore_killed_buffer_windows,
+ doc: /* Control restoring windows whose buffer was killed.
+This variable specifies how the functions `set-window-configuration' and
+`window-state-put' shall handle a window whose buffer has been killed
+since the corresponding configuration or state was recorded. Any such
+window may be live -- in which case it shows some other buffer -- or
+dead at the time one of these functions is called.
+
+By default, `set-window-configuration' leaves the window alone if it is
+live, while `window-state-put' deletes it. The following values can be
+used to override the default behavior for dead windows in the case of
+`set-window-configuration' and for dead and live windows in the case of
+`window-state-put'.
+
+ - t means to restore the window and show some other buffer in it.
+
+ - `delete' means to try to delete the window.
+
+ - `dedicated' means to try to delete the window if and only if it is
+ dedicated to its buffer.
+
+ - nil, the default, which means that `set-window-configuration' will
+ try to delete the window if and only if it is dedicated to its
+ buffer while `window-state-put' will unconditionally try to delete
+ it.
+
+ - a function means to restore the window and show some other buffer in
+ it, like if the value were t, but also to add an entry for that
+ window to a list that will be later passed as argument to that
+ function.
+
+If a window cannot be deleted (typically, because it is the last window
+on its frame), show another buffer in it.
+
+If the value is a function, it should take three arguments. The first
+argument specifies the frame whose windows have been restored. The
+third argument is the symbol `configuration' if the windows are
+restored by `set-window-configuration' and the symbol `state' if the
+windows are restored by `window-state-put'.
+
+The second argument specifies a list of entries for all windows whose
+previous buffers have been found dead at the time
+`set-window-configuration' or `window-state-put' tried to restore them
+(minibuffer windows are excluded). This means that the function
+specified by this variable may also delete windows which were found to
+be alive by `set-window-configuration'.
+
+Each entry is a list of six values: the window whose buffer was found
+dead, the dead buffer or its name, the positions of window-start and
+window-point of the buffer in that window, the dedicated state of the
+window as reported by `window-dedicated-p', and a boolean -- t if the
+window was live when `set-window-configuration' tried to restore it,
+and nil otherwise. */);
+ window_restore_killed_buffer_windows = Qnil;
+
DEFVAR_LISP ("recenter-redisplay", Vrecenter_redisplay,
doc: /* Non-nil means `recenter' redraws entire frame.
If this option is non-nil, then the `recenter' command with a nil
diff --git a/src/window.h b/src/window.h
index 27fab7ca463..19283725931 100644
--- a/src/window.h
+++ b/src/window.h
@@ -286,6 +286,25 @@ struct window
it should be positive. */
ptrdiff_t last_point;
+#ifdef HAVE_TEXT_CONVERSION
+ /* ``ephemeral'' last point position. This is used while
+ processing text conversion events.
+
+ `last_point' is normally used during redisplay to indicate the
+ position of point as seem by the input method. However, it is
+ not updated if consecutive conversions are processed at the
+ same time.
+
+ This `ephemeral_last_point' field is either the last point as
+ set in redisplay or the last point after a text editing
+ operation. */
+ ptrdiff_t ephemeral_last_point;
+#endif
+
+ /* Value of mark in the selected window at the time of the last
+ redisplay. -1 if the mark is not valid or active. */
+ ptrdiff_t last_mark;
+
/* Line number and position of a line somewhere above the top of the
screen. If this field is zero, it means we don't have a base line. */
ptrdiff_t base_line_number;
@@ -576,11 +595,11 @@ wset_next_buffers (struct window *w, Lisp_Object val)
/* Non-nil if window W is leaf window (has a buffer). */
#define WINDOW_LEAF_P(W) \
- (BUFFERP ((W)->contents))
+ BUFFERP ((W)->contents)
/* Non-nil if window W is internal (is a parent window). */
#define WINDOW_INTERNAL_P(W) \
- (WINDOWP ((W)->contents))
+ WINDOWP ((W)->contents)
/* True if window W is a horizontal combination of windows. */
#define WINDOW_HORIZONTAL_COMBINATION_P(W) \
@@ -591,7 +610,7 @@ wset_next_buffers (struct window *w, Lisp_Object val)
(WINDOW_INTERNAL_P (W) && !(W)->horizontal)
/* Window W's XFRAME. */
-#define WINDOW_XFRAME(W) (XFRAME (WINDOW_FRAME ((W))))
+#define WINDOW_XFRAME(W) XFRAME (WINDOW_FRAME (W))
/* Whether window W is a pseudo window. */
#define WINDOW_PSEUDO_P(W) ((W)->pseudo_window_p)
@@ -611,11 +630,11 @@ wset_next_buffers (struct window *w, Lisp_Object val)
/* Return the canonical column width of the frame of window W. */
#define WINDOW_FRAME_COLUMN_WIDTH(W) \
- (FRAME_COLUMN_WIDTH (WINDOW_XFRAME ((W))))
+ FRAME_COLUMN_WIDTH (WINDOW_XFRAME (W))
/* Return the canonical line height of the frame of window W. */
#define WINDOW_FRAME_LINE_HEIGHT(W) \
- (FRAME_LINE_HEIGHT (WINDOW_XFRAME ((W))))
+ FRAME_LINE_HEIGHT (WINDOW_XFRAME (W))
/* Return the pixel width of window W. This includes dividers, scroll
bars, fringes and margins, if any. */
@@ -647,7 +666,7 @@ wset_next_buffers (struct window *w, Lisp_Object val)
#define MIN_SAFE_WINDOW_HEIGHT (1)
#define MIN_SAFE_WINDOW_PIXEL_HEIGHT(W) \
- (WINDOW_FRAME_LINE_HEIGHT (W))
+ WINDOW_FRAME_LINE_HEIGHT (W)
/* True if window W has no other windows to its left on its frame. */
#define WINDOW_LEFTMOST_P(W) \
@@ -740,17 +759,17 @@ wset_next_buffers (struct window *w, Lisp_Object val)
+ WINDOW_RIGHT_PIXEL_EDGE (W))
/* True if W is a menu bar window. */
-#if defined (HAVE_X_WINDOWS) && ! defined (USE_X_TOOLKIT) && ! defined (USE_GTK)
+#if defined HAVE_WINDOW_SYSTEM && !defined HAVE_EXT_MENU_BAR
#define WINDOW_MENU_BAR_P(W) \
(WINDOWP (WINDOW_XFRAME (W)->menu_bar_window) \
&& (W) == XWINDOW (WINDOW_XFRAME (W)->menu_bar_window))
-#else
+#else /* !HAVE_WINDOW_SYSTEM || HAVE_EXT_MENU_BAR */
/* No menu bar windows if X toolkit is in use. */
#define WINDOW_MENU_BAR_P(W) false
-#endif
+#endif /* HAVE_WINDOW_SYSTEM && !HAVE_EXT_MENU_BAR */
/* True if W is a tab bar window. */
-#if defined (HAVE_WINDOW_SYSTEM) && !defined (HAVE_PGTK)
+#if defined (HAVE_WINDOW_SYSTEM)
# define WINDOW_TAB_BAR_P(W) \
(WINDOWP (WINDOW_XFRAME (W)->tab_bar_window) \
&& (W) == XWINDOW (WINDOW_XFRAME (W)->tab_bar_window))
@@ -992,7 +1011,7 @@ wset_next_buffers (struct window *w, Lisp_Object val)
/* Height in pixels of the mode line.
May be zero if W doesn't have a mode line. */
#define WINDOW_MODE_LINE_HEIGHT(W) \
- (window_wants_mode_line ((W)) \
+ (window_wants_mode_line (W) \
? CURRENT_MODE_LINE_HEIGHT (W) \
: 0)
@@ -1030,7 +1049,7 @@ wset_next_buffers (struct window *w, Lisp_Object val)
/* Pixel height of window W without mode and header/tab line and bottom
divider. */
#define WINDOW_BOX_TEXT_HEIGHT(W) \
- (WINDOW_PIXEL_HEIGHT ((W)) \
+ (WINDOW_PIXEL_HEIGHT (W) \
- WINDOW_BOTTOM_DIVIDER_WIDTH (W) \
- WINDOW_SCROLL_BAR_AREA_HEIGHT (W) \
- WINDOW_MODE_LINE_HEIGHT (W) \
@@ -1046,7 +1065,7 @@ wset_next_buffers (struct window *w, Lisp_Object val)
/* Convert window W relative pixel X to frame pixel coordinates. */
#define WINDOW_TO_FRAME_PIXEL_X(W, X) \
- ((X) + WINDOW_BOX_LEFT_EDGE_X ((W)))
+ ((X) + WINDOW_BOX_LEFT_EDGE_X (W))
/* Convert window W relative pixel Y to frame pixel coordinates. */
#define WINDOW_TO_FRAME_PIXEL_Y(W, Y) \
@@ -1054,7 +1073,7 @@ wset_next_buffers (struct window *w, Lisp_Object val)
/* Convert frame relative pixel X to window relative pixel X. */
#define FRAME_TO_WINDOW_PIXEL_X(W, X) \
- ((X) - WINDOW_BOX_LEFT_EDGE_X ((W)))
+ ((X) - WINDOW_BOX_LEFT_EDGE_X (W))
/* Convert frame relative pixel Y to window relative pixel Y. */
#define FRAME_TO_WINDOW_PIXEL_Y(W, Y) \
@@ -1063,7 +1082,7 @@ wset_next_buffers (struct window *w, Lisp_Object val)
/* Convert a text area relative x-position in window W to frame X
pixel coordinates. */
#define WINDOW_TEXT_TO_FRAME_PIXEL_X(W, X) \
- (window_box_left ((W), TEXT_AREA) + (X))
+ window_box_left (W, TEXT_AREA) + (X)
/* This is the window in which the terminal's cursor should be left when
nothing is being done with it. This must always be a leaf window, and its
@@ -1092,7 +1111,7 @@ extern Lisp_Object minibuf_selected_window;
extern Lisp_Object make_window (void);
extern Lisp_Object window_from_coordinates (struct frame *, int, int,
- enum window_part *, bool, bool);
+ enum window_part *, bool, bool, bool);
extern void resize_frame_windows (struct frame *, int, bool);
extern void restore_window_configuration (Lisp_Object);
extern void delete_all_child_windows (Lisp_Object);
@@ -1114,9 +1133,11 @@ void set_window_buffer (Lisp_Object window, Lisp_Object buffer,
extern Lisp_Object echo_area_window;
-/* Non-zero if we should redraw the mode lines on the next redisplay.
+/* Non-zero if we should redraw the mode line*s* on the next redisplay.
Usually set to a unique small integer so we can track the main causes of
- full redisplays in `redisplay--mode-lines-cause'. */
+ full redisplays in `redisplay--mode-lines-cause'.
+ Here "mode lines" includes other elements not coming from the buffer's
+ text, such as header-lines, tab lines, frame names, menu-bars, .... */
extern int update_mode_lines;
@@ -1134,6 +1155,11 @@ extern int windows_or_buffers_changed;
extern void wset_redisplay (struct window *w);
extern void fset_redisplay (struct frame *f);
extern void bset_redisplay (struct buffer *b);
+
+/* Routines to indicate that the mode-lines might need to be redisplayed.
+ Just as for `update_mode_lines`, this includes other elements not coming
+ from the buffer's text, such as header-lines, tab lines, frame names,
+ menu-bars, .... */
extern void bset_update_mode_line (struct buffer *b);
extern void wset_update_mode_line (struct window *w);
/* Call this to tell redisplay to look for other windows than selected-window
diff --git a/src/xdisp.c b/src/xdisp.c
index 2d85a991e77..140d71129f3 100644
--- a/src/xdisp.c
+++ b/src/xdisp.c
@@ -637,8 +637,8 @@ fill_column_indicator_column (struct it *it, int char_width)
if (RANGED_FIXNUMP (0, col, INT_MAX))
{
int icol = XFIXNUM (col);
- if (!INT_MULTIPLY_WRAPV (char_width, icol, &icol)
- && !INT_ADD_WRAPV (it->lnum_pixel_width, icol, &icol))
+ if (!ckd_mul (&icol, icol, char_width)
+ && !ckd_add (&icol, icol, it->lnum_pixel_width))
return icol;
}
}
@@ -1229,6 +1229,7 @@ static void get_cursor_offset_for_mouse_face (struct window *w,
#endif /* HAVE_WINDOW_SYSTEM */
static void produce_special_glyphs (struct it *, enum display_element_type);
+static void pad_mode_line (struct it *, bool);
static void show_mouse_face (Mouse_HLInfo *, enum draw_glyphs_face);
static bool coords_in_mouse_face_p (struct window *, int, int);
static void reset_box_start_end_flags (struct it *);
@@ -2507,7 +2508,7 @@ get_glyph_string_clip_rects (struct glyph_string *s, NativeRectangle *rects, int
r.x = s->clip_head->x;
}
if (s->clip_tail)
- if (r.x + r.width > s->clip_tail->x + s->clip_tail->background_width)
+ if (r.x + (int) r.width > s->clip_tail->x + s->clip_tail->background_width)
{
if (s->clip_tail->x + s->clip_tail->background_width >= r.x)
r.width = s->clip_tail->x + s->clip_tail->background_width - r.x;
@@ -2587,7 +2588,7 @@ get_glyph_string_clip_rects (struct glyph_string *s, NativeRectangle *rects, int
height = max (FRAME_LINE_HEIGHT (s->f), glyph->ascent + glyph->descent);
if (height < r.height)
{
- max_y = r.y + r.height;
+ max_y = r.y + (int) r.height;
r.y = min (max_y, max (r.y, s->ybase + glyph->descent - height));
r.height = min (max_y - r.y, height);
}
@@ -2628,7 +2629,7 @@ get_glyph_string_clip_rects (struct glyph_string *s, NativeRectangle *rects, int
if (s->for_overlaps & OVERLAPS_PRED)
{
rs[i] = r;
- if (r.y + r.height > row_y)
+ if (r.y + (int) r.height > row_y)
{
if (r.y < row_y)
rs[i].height = row_y - r.y;
@@ -2642,10 +2643,10 @@ get_glyph_string_clip_rects (struct glyph_string *s, NativeRectangle *rects, int
rs[i] = r;
if (r.y < row_y + s->row->visible_height)
{
- if (r.y + r.height > row_y + s->row->visible_height)
+ if (r.y + (int) r.height > row_y + s->row->visible_height)
{
rs[i].y = row_y + s->row->visible_height;
- rs[i].height = r.y + r.height - rs[i].y;
+ rs[i].height = r.y + (int) r.height - rs[i].y;
}
else
rs[i].height = 0;
@@ -2758,6 +2759,7 @@ remember_mouse_glyph (struct frame *f, int gx, int gy, NativeRectangle *rect)
enum window_part part;
enum glyph_row_area area;
int x, y, width, height;
+ int original_gx;
if (mouse_fine_grained_tracking)
{
@@ -2768,13 +2770,15 @@ remember_mouse_glyph (struct frame *f, int gx, int gy, NativeRectangle *rect)
/* Try to determine frame pixel position and size of the glyph under
frame pixel coordinates X/Y on frame F. */
+ original_gx = gx;
+
if (window_resize_pixelwise)
{
width = height = 1;
goto virtual_glyph;
}
else if (!f->glyphs_initialized_p
- || (window = window_from_coordinates (f, gx, gy, &part, false, false),
+ || (window = window_from_coordinates (f, gx, gy, &part, false, false, false),
NILP (window)))
{
width = FRAME_SMALLEST_CHAR_WIDTH (f);
@@ -2827,7 +2831,7 @@ remember_mouse_glyph (struct frame *f, int gx, int gy, NativeRectangle *rect)
text_glyph:
gr = 0; gy = 0;
for (; r <= end_row && r->enabled_p; ++r)
- if (r->y + r->height > y)
+ if (r->y + (int) r->height > y)
{
gr = r; gy = r->y;
break;
@@ -2927,7 +2931,7 @@ remember_mouse_glyph (struct frame *f, int gx, int gy, NativeRectangle *rect)
row_glyph:
gr = 0, gy = 0;
for (; r <= end_row && r->enabled_p; ++r)
- if (r->y + r->height > y)
+ if (r->y + (int) r->height > y)
{
gr = r; gy = r->y;
break;
@@ -2983,6 +2987,15 @@ remember_mouse_glyph (struct frame *f, int gx, int gy, NativeRectangle *rect)
gy += WINDOW_TOP_EDGE_Y (w);
store_rect:
+ if (mouse_prefer_closest_glyph)
+ {
+ int half_width = width / 2;
+ width = half_width;
+
+ int bisection = gx + half_width;
+ if (original_gx > bisection)
+ gx = bisection;
+ }
STORE_NATIVE_RECT (*rect, gx, gy, width, height);
/* Visible feedback for debugging. */
@@ -3018,10 +3031,10 @@ hscrolling_current_line_p (struct window *w)
Lisp form evaluation
***********************************************************************/
-/* Error handler for safe_eval and safe_call. */
+/* Error handler for dsafe_eval and dsafe_call. */
static Lisp_Object
-safe_eval_handler (Lisp_Object arg, ptrdiff_t nargs, Lisp_Object *args)
+dsafe_eval_handler (Lisp_Object arg, ptrdiff_t nargs, Lisp_Object *args)
{
add_to_log ("Error during redisplay: %S signaled %S",
Flist (nargs, args), arg);
@@ -3032,8 +3045,11 @@ safe_eval_handler (Lisp_Object arg, ptrdiff_t nargs, Lisp_Object *args)
following. Return the result, or nil if something went
wrong. Prevent redisplay during the evaluation. */
+/* FIXME: What's the guiding principle behind the choice
+ of which calls should set 'inhibit_quit' and which don't. */
static Lisp_Object
-safe__call (bool inhibit_quit, ptrdiff_t nargs, Lisp_Object func, va_list ap)
+dsafe__call (bool inhibit_quit, Lisp_Object (f) (ptrdiff_t, Lisp_Object *),
+ ptrdiff_t nargs, Lisp_Object *args)
{
Lisp_Object val;
@@ -3041,84 +3057,52 @@ safe__call (bool inhibit_quit, ptrdiff_t nargs, Lisp_Object func, va_list ap)
val = Qnil;
else
{
- ptrdiff_t i;
specpdl_ref count = SPECPDL_INDEX ();
- Lisp_Object *args;
- USE_SAFE_ALLOCA;
- SAFE_ALLOCA_LISP (args, nargs);
-
- args[0] = func;
- for (i = 1; i < nargs; i++)
- args[i] = va_arg (ap, Lisp_Object);
specbind (Qinhibit_redisplay, Qt);
if (inhibit_quit)
specbind (Qinhibit_quit, Qt);
/* Use Qt to ensure debugger does not run,
so there is no possibility of wanting to redisplay. */
- val = internal_condition_case_n (Ffuncall, nargs, args, Qt,
- safe_eval_handler);
- val = SAFE_FREE_UNBIND_TO (count, val);
+ val = internal_condition_case_n (f, nargs, args, Qt,
+ dsafe_eval_handler);
+ val = unbind_to (count, val);
}
return val;
}
-Lisp_Object
-safe_call (ptrdiff_t nargs, Lisp_Object func, ...)
-{
- Lisp_Object retval;
- va_list ap;
-
- va_start (ap, func);
- retval = safe__call (false, nargs, func, ap);
- va_end (ap);
- return retval;
-}
-
-/* Call function FN with one argument ARG.
- Return the result, or nil if something went wrong. */
-
-Lisp_Object
-safe_call1 (Lisp_Object fn, Lisp_Object arg)
-{
- return safe_call (2, fn, arg);
-}
-
static Lisp_Object
-safe__call1 (bool inhibit_quit, Lisp_Object fn, ...)
+funcall_with_backtraces (ptrdiff_t nargs, Lisp_Object *args)
{
- Lisp_Object retval;
- va_list ap;
-
- va_start (ap, fn);
- retval = safe__call (inhibit_quit, 2, fn, ap);
- va_end (ap);
- return retval;
+ /* If an error is signaled during a Lisp hook in redisplay, write a
+ backtrace into the buffer *Redisplay-trace*. */
+ push_handler_bind (list_of_error, Qdebug_early__muted, 0);
+ Lisp_Object res = Ffuncall (nargs, args);
+ pop_handler ();
+ return res;
}
-Lisp_Object
-safe_eval (Lisp_Object sexpr)
-{
- return safe__call1 (false, Qeval, sexpr);
-}
+#define SAFE_CALLMANY(inhibit_quit, f, array) \
+ dsafe__call (inhibit_quit, f, ARRAYELTS (array), array)
+#define dsafe_calln(inhibit_quit, ...) \
+ SAFE_CALLMANY (inhibit_quit, \
+ backtrace_on_redisplay_error \
+ ? funcall_with_backtraces : Ffuncall, \
+ ((Lisp_Object []) {__VA_ARGS__}))
static Lisp_Object
-safe__eval (bool inhibit_quit, Lisp_Object sexpr)
+dsafe_call1 (Lisp_Object f, Lisp_Object arg)
{
- return safe__call1 (inhibit_quit, Qeval, sexpr);
+ return dsafe_calln (false, f, arg);
}
-/* Call function FN with two arguments ARG1 and ARG2.
- Return the result, or nil if something went wrong. */
-
-Lisp_Object
-safe_call2 (Lisp_Object fn, Lisp_Object arg1, Lisp_Object arg2)
+static Lisp_Object
+dsafe_eval (Lisp_Object sexpr)
{
- return safe_call (3, fn, arg1, arg2);
+ return dsafe_calln (true, Qeval, sexpr, Qt);
}
-
/***********************************************************************
Debugging
@@ -3753,18 +3737,25 @@ start_display (struct it *it, struct window *w, struct text_pos pos)
/* Don't reseat to previous visible line start if current start
position is in a string or image. */
- if (it->method == GET_FROM_BUFFER && it->line_wrap != TRUNCATE)
+ if (it->line_wrap != TRUNCATE)
{
- int first_y = it->current_y;
+ enum it_method method = it->method;
- /* If window start is not at a line start, skip forward to POS to
- get the correct continuation lines width. */
+ /* If window start is not at a line start, skip forward to POS
+ from the beginning of physical line to get the correct
+ continuation lines width. */
bool start_at_line_beg_p = (CHARPOS (pos) == BEGV
|| FETCH_BYTE (BYTEPOS (pos) - 1) == '\n');
if (!start_at_line_beg_p)
{
+ int first_y = it->current_y;
+ int continuation_width;
+ void *itdata = NULL;
+ struct it it2;
int new_x;
+ if (method != GET_FROM_BUFFER)
+ SAVE_IT (it2, *it, itdata);
reseat_at_previous_visible_line_start (it);
move_it_to (it, CHARPOS (pos), -1, -1, -1, MOVE_TO_POS);
@@ -3811,6 +3802,17 @@ start_display (struct it *it, struct window *w, struct text_pos pos)
else if (it->current.dpvec_index >= 0)
it->current.dpvec_index = 0;
+ continuation_width = it->continuation_lines_width;
+ /* If we started from a position in something other than a
+ buffer, restore the original iterator state, keeping only
+ the continuation_lines_width, since we could now be very
+ far from the original position. */
+ if (method != GET_FROM_BUFFER)
+ {
+ RESTORE_IT (it, &it2, itdata);
+ it->continuation_lines_width = continuation_width;
+ }
+
/* We're starting a new display line, not affected by the
height of the continued line, so clear the appropriate
fields in the iterator structure. */
@@ -3819,7 +3821,7 @@ start_display (struct it *it, struct window *w, struct text_pos pos)
it->current_y = first_y;
it->vpos = 0;
- it->current_x = it->hpos = 0;
+ it->current_x = it->hpos = it->wrap_prefix_width = 0;
}
}
}
@@ -4212,7 +4214,7 @@ compute_stop_pos (struct it *it)
{
register INTERVAL iv, next_iv;
Lisp_Object object, limit, position;
- ptrdiff_t charpos, bytepos;
+ ptrdiff_t charpos, bytepos, cmp_limit_pos = -1;
if (STRINGP (it->string))
{
@@ -4282,7 +4284,10 @@ compute_stop_pos (struct it *it)
}
}
if (found)
- pos--;
+ {
+ pos--;
+ cmp_limit_pos = pos;
+ }
else if (it->stop_charpos < endpos)
pos = it->stop_charpos;
else
@@ -4344,10 +4349,20 @@ compute_stop_pos (struct it *it)
{
ptrdiff_t stoppos = it->end_charpos;
+ /* If we found, above, a buffer position that cannot be part of
+ an automatic composition, limit the search of composable
+ characters to that position. */
if (it->bidi_p && it->bidi_it.scan_dir < 0)
- stoppos = -1;
+ stoppos = bidi_level_start (it->bidi_it.resolved_level) - 1;
+ else if (!STRINGP (it->string)
+ && it->cmp_it.stop_pos <= IT_CHARPOS (*it)
+ && cmp_limit_pos > 0)
+ stoppos = cmp_limit_pos;
+ /* Force composition_compute_stop_pos avoid the costly search
+ for static compositions, since those were already found by
+ looking at text properties, above. */
composition_compute_stop_pos (&it->cmp_it, charpos, bytepos,
- stoppos, it->string);
+ stoppos, it->string, false);
}
eassert (STRINGP (it->string)
@@ -4570,7 +4585,7 @@ handle_fontified_prop (struct it *it)
it->f->inhibit_clear_image_cache = true;
if (!CONSP (val) || EQ (XCAR (val), Qlambda))
- safe_call1 (val, pos);
+ dsafe_call1 (val, pos);
else
{
Lisp_Object fns, fn;
@@ -4594,11 +4609,11 @@ handle_fontified_prop (struct it *it)
{
fn = XCAR (fns);
if (!EQ (fn, Qt))
- safe_call1 (fn, pos);
+ dsafe_call1 (fn, pos);
}
}
else
- safe_call1 (fn, pos);
+ dsafe_call1 (fn, pos);
}
}
@@ -5046,31 +5061,169 @@ handle_invisible_prop (struct it *it)
{
enum prop_handled handled = HANDLED_NORMALLY;
int invis;
- Lisp_Object prop;
+ ptrdiff_t curpos, endpos;
+ Lisp_Object prop, pos, overlay;
+ /* Get the value of the invisible text property at the current
+ position. Value will be nil if there is no such property. */
if (STRINGP (it->string))
{
- Lisp_Object end_charpos, limit;
+ curpos = IT_STRING_CHARPOS (*it);
+ endpos = SCHARS (it->string);
+ pos = make_fixnum (curpos);
+ prop = Fget_text_property (pos, Qinvisible, it->string);
+ }
+ else /* buffer */
+ {
+ curpos = IT_CHARPOS (*it);
+ endpos = ZV;
+ pos = make_fixnum (curpos);
+ prop = get_char_property_and_overlay (pos, Qinvisible, it->window,
+ &overlay);
+ }
- /* Get the value of the invisible text property at the
- current position. Value will be nil if there is no such
- property. */
- end_charpos = make_fixnum (IT_STRING_CHARPOS (*it));
- prop = Fget_text_property (end_charpos, Qinvisible, it->string);
- invis = TEXT_PROP_MEANS_INVISIBLE (prop);
+ /* Do we have anything to do here? */
+ invis = TEXT_PROP_MEANS_INVISIBLE (prop);
+ if (invis == 0 || curpos >= it->end_charpos)
+ return handled;
- if (invis != 0 && IT_STRING_CHARPOS (*it) < it->end_charpos)
+ /* If not bidi, or the bidi iteration is at base paragraph level, we
+ can use a faster method; otherwise we need to check invisibility
+ of every character while bidi-iterating out of invisible text. */
+ bool slow = it->bidi_p && !BIDI_AT_BASE_LEVEL (it->bidi_it);
+ /* Record whether we have to display an ellipsis for the
+ invisible text. */
+ bool display_ellipsis_p = (invis == 2);
+
+ handled = HANDLED_RECOMPUTE_PROPS;
+
+ if (slow)
+ {
+ if (it->bidi_it.first_elt && it->bidi_it.charpos < endpos)
+ bidi_paragraph_init (it->paragraph_embedding, &it->bidi_it, true);
+
+ if (STRINGP (it->string))
{
- /* Record whether we have to display an ellipsis for the
- invisible text. */
- bool display_ellipsis_p = (invis == 2);
- ptrdiff_t len, endpos;
+ bool done = false;
+ /* Bidi-iterate out of the invisible part of the string. */
+ do
+ {
+ bidi_move_to_visually_next (&it->bidi_it);
+ if (it->bidi_it.charpos < 0 || it->bidi_it.charpos >= endpos)
+ done = true;
+ else
+ {
+ pos = make_fixnum (it->bidi_it.charpos);
+ prop = Fget_text_property (pos, Qinvisible, it->string);
+ invis = TEXT_PROP_MEANS_INVISIBLE (prop);
+ /* If there are adjacent invisible texts, don't lose
+ the second one's ellipsis. */
+ if (invis == 2)
+ display_ellipsis_p = true;
+ }
+ }
+ while (!done && invis != 0);
- handled = HANDLED_RECOMPUTE_PROPS;
+ if (display_ellipsis_p)
+ it->ellipsis_p = true;
+ IT_STRING_CHARPOS (*it) = it->bidi_it.charpos;
+ IT_STRING_BYTEPOS (*it) = it->bidi_it.bytepos;
+ if (IT_STRING_BYTEPOS (*it) >= endpos)
+ {
+ /* The rest of the string is invisible. If this is an
+ overlay string, proceed with the next overlay string
+ or whatever comes and return a character from there. */
+ if (it->current.overlay_string_index >= 0
+ && !display_ellipsis_p)
+ {
+ next_overlay_string (it);
+ /* Don't check for overlay strings when we just
+ finished processing them. */
+ handled = HANDLED_OVERLAY_STRING_CONSUMED;
+ }
+ }
+ }
+ else
+ {
+ bool done = false;
+ /* Bidi-iterate out of the invisible text. */
+ do
+ {
+ bidi_move_to_visually_next (&it->bidi_it);
+ if (it->bidi_it.charpos < BEGV || it->bidi_it.charpos >= endpos)
+ done = true;
+ else
+ {
+ pos = make_fixnum (it->bidi_it.charpos);
+ prop = Fget_char_property (pos, Qinvisible, it->window);
+ invis = TEXT_PROP_MEANS_INVISIBLE (prop);
+ /* If there are adjacent invisible texts, don't lose
+ the second one's ellipsis. */
+ if (invis == 2)
+ display_ellipsis_p = true;
+ }
+ }
+ while (!done && invis != 0);
+
+ IT_CHARPOS (*it) = it->bidi_it.charpos;
+ IT_BYTEPOS (*it) = it->bidi_it.bytepos;
+ if (display_ellipsis_p)
+ {
+ /* Make sure that the glyphs of the ellipsis will get
+ correct `charpos' values. See below for detailed
+ explanation why this is needed. */
+ it->position.charpos = IT_CHARPOS (*it) - 1;
+ it->position.bytepos = CHAR_TO_BYTE (it->position.charpos);
+ }
+ /* If there are before-strings at the start of invisible
+ text, and the text is invisible because of a text
+ property, arrange to show before-strings because 20.x did
+ it that way. (If the text is invisible because of an
+ overlay property instead of a text property, this is
+ already handled in the overlay code.) */
+ if (NILP (overlay)
+ && get_overlay_strings (it, it->stop_charpos))
+ {
+ handled = HANDLED_RECOMPUTE_PROPS;
+ if (it->sp > 0)
+ {
+ it->stack[it->sp - 1].display_ellipsis_p = display_ellipsis_p;
+ /* The call to get_overlay_strings above recomputes
+ it->stop_charpos, but it only considers changes
+ in properties and overlays beyond iterator's
+ current position. This causes us to miss changes
+ that happen exactly where the invisible property
+ ended. So we play it safe here and force the
+ iterator to check for potential stop positions
+ immediately after the invisible text. Note that
+ if get_overlay_strings returns true, it
+ normally also pushed the iterator stack, so we
+ need to update the stop position in the slot
+ below the current one. */
+ it->stack[it->sp - 1].stop_charpos
+ = CHARPOS (it->stack[it->sp - 1].current.pos);
+ }
+ }
+ else if (display_ellipsis_p)
+ {
+ it->ellipsis_p = true;
+ /* Let the ellipsis display before
+ considering any properties of the following char.
+ Fixes jasonr@gnu.org 01 Oct 07 bug. */
+ handled = HANDLED_RETURN;
+ }
+ }
+ }
+ else if (STRINGP (it->string))
+ {
+ Lisp_Object end_charpos = pos, limit;
+
+ if (invis != 0 && IT_STRING_CHARPOS (*it) < it->end_charpos)
+ {
+ ptrdiff_t len = endpos;
/* Get the position at which the next visible text can be
found in IT->string, if any. */
- endpos = len = SCHARS (it->string);
XSETINT (limit, len);
do
{
@@ -5121,7 +5274,7 @@ handle_invisible_prop (struct it *it)
IT_STRING_CHARPOS (*it) = it->bidi_it.charpos;
IT_STRING_BYTEPOS (*it) = it->bidi_it.bytepos;
- if (IT_CHARPOS (*it) >= endpos)
+ if (IT_STRING_CHARPOS (*it) >= endpos)
it->prev_stop = endpos;
}
else
@@ -5151,27 +5304,14 @@ handle_invisible_prop (struct it *it)
}
}
}
- else
+ else /* we are iterating over buffer text at base paragraph level */
{
- ptrdiff_t newpos, next_stop, start_charpos, tem;
- Lisp_Object pos, overlay;
-
- /* First of all, is there invisible text at this position? */
- tem = start_charpos = IT_CHARPOS (*it);
- pos = make_fixnum (tem);
- prop = get_char_property_and_overlay (pos, Qinvisible, it->window,
- &overlay);
- invis = TEXT_PROP_MEANS_INVISIBLE (prop);
+ ptrdiff_t newpos, next_stop, tem = curpos;
+ Lisp_Object pos;
/* If we are on invisible text, skip over it. */
- if (invis != 0 && start_charpos < it->end_charpos)
+ if (invis != 0 && curpos < it->end_charpos)
{
- /* Record whether we have to display an ellipsis for the
- invisible text. */
- bool display_ellipsis_p = invis == 2;
-
- handled = HANDLED_RECOMPUTE_PROPS;
-
/* Loop skipping over invisible text. The loop is left at
ZV or with IT on the first char being visible again. */
do
@@ -5471,9 +5611,6 @@ display_min_width (struct it *it, ptrdiff_t bufpos,
if (!NILP (it->min_width_property)
&& !EQ (width_spec, it->min_width_property))
{
- if (!it->glyph_row)
- return;
-
/* When called from display_string (i.e., the mode line),
we're being called with a string as the object, and we
may be called with many sub-strings belonging to the same
@@ -5516,7 +5653,13 @@ display_min_width (struct it *it, ptrdiff_t bufpos,
it->object = list3 (Qspace, QCwidth, w);
produce_stretch_glyph (it);
if (it->area == TEXT_AREA)
- it->current_x += it->pixel_width;
+ {
+ it->current_x += it->pixel_width;
+
+ if (it->continuation_lines_width
+ && it->string_from_prefix_prop_p)
+ it->wrap_prefix_width = it->current_x;
+ }
it->min_width_property = Qnil;
}
}
@@ -5810,7 +5953,7 @@ handle_single_display_spec (struct it *it, Lisp_Object spec, Lisp_Object object,
/* Save and restore the bidi cache, since FORM could be crazy
enough to re-enter redisplay, e.g., by calling 'message'. */
itdata = bidi_shelve_cache ();
- form = safe_eval (form);
+ form = dsafe_eval (form);
bidi_unshelve_cache (itdata, false);
form = unbind_to (count, form);
}
@@ -5852,7 +5995,7 @@ handle_single_display_spec (struct it *it, Lisp_Object spec, Lisp_Object object,
struct face *face = FACE_FROM_ID (it->f, it->face_id);
Lisp_Object height;
itdata = bidi_shelve_cache ();
- height = safe_call1 (it->font_height,
+ height = dsafe_call1 (it->font_height,
face->lface[LFACE_HEIGHT_INDEX]);
bidi_unshelve_cache (itdata, false);
if (NUMBERP (height))
@@ -5877,7 +6020,7 @@ handle_single_display_spec (struct it *it, Lisp_Object spec, Lisp_Object object,
specbind (Qheight, face->lface[LFACE_HEIGHT_INDEX]);
itdata = bidi_shelve_cache ();
- value = safe_eval (it->font_height);
+ value = dsafe_eval (it->font_height);
bidi_unshelve_cache (itdata, false);
value = unbind_to (count, value);
@@ -6759,7 +6902,7 @@ load_overlay_strings (struct it *it, ptrdiff_t charpos)
\
entries[n].string = (STRING); \
entries[n].overlay = (OVERLAY); \
- priority = Foverlay_get ((OVERLAY), Qpriority); \
+ priority = Foverlay_get (OVERLAY, Qpriority); \
entries[n].priority = FIXNUMP (priority) ? XFIXNUM (priority) : 0; \
entries[n].after_string_p = (AFTER_P); \
++n; \
@@ -7877,7 +8020,7 @@ reseat_to_string (struct it *it, const char *s, Lisp_Object string,
if (endpos > it->end_charpos)
endpos = it->end_charpos;
composition_compute_stop_pos (&it->cmp_it, charpos, -1, endpos,
- it->string);
+ it->string, true);
}
CHECK_IT (it);
}
@@ -8569,11 +8712,10 @@ set_iterator_to_next (struct it *it, bool reseat_p)
ptrdiff_t stop = it->end_charpos;
if (it->bidi_it.scan_dir < 0)
- /* Now we are scanning backward and don't know
- where to stop. */
- stop = -1;
+ /* Now we are scanning backward; figure out where to stop. */
+ stop = bidi_level_start (it->bidi_it.resolved_level) - 1;
composition_compute_stop_pos (&it->cmp_it, IT_CHARPOS (*it),
- IT_BYTEPOS (*it), stop, Qnil);
+ IT_BYTEPOS (*it), stop, Qnil, true);
}
}
else
@@ -8602,9 +8744,10 @@ set_iterator_to_next (struct it *it, bool reseat_p)
re-compute the stop position for composition. */
ptrdiff_t stop = it->end_charpos;
if (it->bidi_it.scan_dir < 0)
- stop = -1;
+ stop = bidi_level_start (it->bidi_it.resolved_level) - 1;
composition_compute_stop_pos (&it->cmp_it, IT_CHARPOS (*it),
- IT_BYTEPOS (*it), stop, Qnil);
+ IT_BYTEPOS (*it), stop, Qnil,
+ true);
}
}
eassert (IT_BYTEPOS (*it) == CHAR_TO_BYTE (IT_CHARPOS (*it)));
@@ -8760,7 +8903,7 @@ set_iterator_to_next (struct it *it, bool reseat_p)
composition_compute_stop_pos (&it->cmp_it,
IT_STRING_CHARPOS (*it),
IT_STRING_BYTEPOS (*it), stop,
- it->string);
+ it->string, true);
}
}
else
@@ -8797,7 +8940,7 @@ set_iterator_to_next (struct it *it, bool reseat_p)
composition_compute_stop_pos (&it->cmp_it,
IT_STRING_CHARPOS (*it),
IT_STRING_BYTEPOS (*it), stop,
- it->string);
+ it->string, true);
}
}
}
@@ -9046,9 +9189,11 @@ get_visually_first_element (struct it *it)
bytepos = IT_BYTEPOS (*it);
}
if (it->bidi_it.scan_dir < 0)
- stop = -1;
+ stop = STRINGP (it->string)
+ ? -1
+ : bidi_level_start (it->bidi_it.resolved_level) - 1;
composition_compute_stop_pos (&it->cmp_it, charpos, bytepos, stop,
- it->string);
+ it->string, true);
}
}
@@ -9550,9 +9695,10 @@ next_element_from_buffer (struct it *it)
&& PT < it->end_charpos) ? PT : it->end_charpos;
}
else
- stop = it->bidi_it.scan_dir < 0 ? -1 : it->end_charpos;
- if (CHAR_COMPOSED_P (it, IT_CHARPOS (*it), IT_BYTEPOS (*it),
- stop)
+ stop = it->bidi_it.scan_dir < 0
+ ? bidi_level_start (it->bidi_it.resolved_level) - 1
+ : it->end_charpos;
+ if (CHAR_COMPOSED_P (it, IT_CHARPOS (*it), IT_BYTEPOS (*it), stop)
&& next_element_from_composition (it))
{
return true;
@@ -9716,6 +9862,13 @@ move_it_in_display_line_to (struct it *it,
ptrdiff_t prev_pos = IT_CHARPOS (*it);
bool saw_smaller_pos = prev_pos < to_charpos;
bool line_number_pending = false;
+ int this_line_subject_to_line_prefix = 0;
+
+#ifdef GLYPH_DEBUG
+ /* atx_flag, atpos_flag and wrap_flag are assigned but never used;
+ these hold information useful while debugging. */
+ int atx_flag, atpos_flag, wrap_flag;
+#endif /* GLYPH_DEBUG */
/* Don't produce glyphs in produce_glyphs. */
saved_glyph_row = it->glyph_row;
@@ -9781,6 +9934,11 @@ move_it_in_display_line_to (struct it *it,
/* If there's a line-/wrap-prefix, handle it, if we didn't already. */
if (it->area == TEXT_AREA && !it->string_from_prefix_prop_p)
handle_line_prefix (it);
+
+ /* Save whether this line has received a wrap prefix, as this
+ affects whether Emacs attempts to move glyphs into
+ continuation lines. */
+ this_line_subject_to_line_prefix = it->string_from_prefix_prop_p;
}
if (IT_CHARPOS (*it) < CHARPOS (this_line_min_pos))
@@ -9824,10 +9982,15 @@ move_it_in_display_line_to (struct it *it,
break;
}
else if (it->line_wrap == WORD_WRAP && atpos_it.sp < 0)
- /* If wrap_it is valid, the current position might be in a
- word that is wrapped. So, save the iterator in
- atpos_it and continue to see if wrapping happens. */
- SAVE_IT (atpos_it, *it, atpos_data);
+ {
+ /* If wrap_it is valid, the current position might be in
+ a word that is wrapped. So, save the iterator in
+ atpos_it and continue to see if wrapping happens. */
+ SAVE_IT (atpos_it, *it, atpos_data);
+#ifdef GLYPH_DEBUG
+ atpos_flag = this_line_subject_to_line_prefix;
+#endif /* GLYPH_DEBUG */
+ }
}
/* Stop when ZV reached.
@@ -9889,6 +10052,9 @@ move_it_in_display_line_to (struct it *it,
}
/* Otherwise, we can wrap here. */
SAVE_IT (wrap_it, *it, wrap_data);
+#ifdef GLYPH_DEBUG
+ wrap_flag = this_line_subject_to_line_prefix;
+#endif /* GLYPH_DEBUG */
}
/* Update may_wrap for the next iteration. */
may_wrap = next_may_wrap;
@@ -9967,6 +10133,9 @@ move_it_in_display_line_to (struct it *it,
{
SAVE_IT (atpos_it, *it, atpos_data);
IT_RESET_X_ASCENT_DESCENT (&atpos_it);
+#ifdef GLYPH_DEBUG
+ atpos_flag = this_line_subject_to_line_prefix;
+#endif /* GLYPH_DEBUG */
}
}
else
@@ -9981,6 +10150,9 @@ move_it_in_display_line_to (struct it *it,
{
SAVE_IT (atx_it, *it, atx_data);
IT_RESET_X_ASCENT_DESCENT (&atx_it);
+#ifdef GLYPH_DEBUG
+ atx_flag = this_line_subject_to_line_prefix;
+#endif /* GLYPH_DEBUG */
}
}
}
@@ -9995,12 +10167,27 @@ move_it_in_display_line_to (struct it *it,
&& FRAME_WINDOW_P (it->f)
&& ((it->bidi_p && it->bidi_it.paragraph_dir == R2L)
? WINDOW_LEFT_FRINGE_WIDTH (it->w)
- : WINDOW_RIGHT_FRINGE_WIDTH (it->w)))))
+ : WINDOW_RIGHT_FRINGE_WIDTH (it->w))))
+ /* There is no line prefix, next to which the
+ iterator _must_ produce a minimum of one actual
+ glyph. */
+ && (!this_line_subject_to_line_prefix
+ /* Or this is the second glyph to be produced
+ beyond the confines of the line. */
+ || (i != 0
+ && (x > it->last_visible_x
+ || (x == it->last_visible_x
+ && FRAME_WINDOW_P (it->f)
+ && ((it->bidi_p
+ && it->bidi_it.paragraph_dir == R2L)
+ ? WINDOW_LEFT_FRINGE_WIDTH (it->w)
+ : WINDOW_RIGHT_FRINGE_WIDTH (it->w)))))))
{
bool moved_forward = false;
if (/* IT->hpos == 0 means the very first glyph
- doesn't fit on the line, e.g. a wide image. */
+ doesn't fit on the line, e.g. a wide
+ image. */
it->hpos == 0
|| (new_x == it->last_visible_x
&& FRAME_WINDOW_P (it->f)))
@@ -10061,6 +10248,9 @@ move_it_in_display_line_to (struct it *it,
SAVE_IT (atpos_it, *it, atpos_data);
atpos_it.current_x = x_before_this_char;
atpos_it.hpos = hpos_before_this_char;
+#ifdef GLYPH_DEBUG
+ atpos_flag = this_line_subject_to_line_prefix;
+#endif /* GLYPH_DEBUG */
}
}
@@ -10158,6 +10348,9 @@ move_it_in_display_line_to (struct it *it,
if (it->line_wrap == WORD_WRAP && atpos_it.sp < 0)
{
SAVE_IT (atpos_it, *it, atpos_data);
+#ifdef GLYPH_DEBUG
+ atpos_flag = this_line_subject_to_line_prefix;
+#endif /* GLYPH_DEBUG */
IT_RESET_X_ASCENT_DESCENT (&atpos_it);
}
}
@@ -10256,24 +10449,24 @@ move_it_in_display_line_to (struct it *it,
if (it->method == GET_FROM_BUFFER)
prev_pos = IT_CHARPOS (*it);
- /* Detect overly-wide wrap-prefixes made of (space ...) display
- properties. When such a wrap prefix reaches past the right
- margin of the window, we need to avoid the call to
- set_iterator_to_next below, so that it->line_wrap is left at
- its TRUNCATE value wisely set by handle_line_prefix.
- Otherwise, set_iterator_to_next will pop the iterator stack,
- restore it->line_wrap, and we might miss the opportunity to
- exit the loop and return. */
- bool overwide_wrap_prefix =
- CONSP (it->object) && EQ (XCAR (it->object), Qspace)
- && it->sp > 0 && it->method == GET_FROM_STRETCH
- && it->current_x >= it->last_visible_x
- && it->continuation_lines_width > 0
- && it->line_wrap == TRUNCATE && it->stack[0].line_wrap != TRUNCATE;
- /* The current display element has been consumed. Advance
- to the next. */
- if (!overwide_wrap_prefix)
- set_iterator_to_next (it, true);
+ /* The current display element has been consumed. Advance to
+ the next. */
+ set_iterator_to_next (it, true);
+
+ /* If IT has just finished producing glyphs for the wrap prefix
+ and is proceeding to the next method, there might not be
+ sufficient space remaining in this line to accommodate its
+ glyphs, and one real glyph must be produced to prevent an
+ infinite loop. Next, clear this flag if such a glyph has
+ already been produced. */
+
+ if (this_line_subject_to_line_prefix == 1
+ && !it->string_from_prefix_prop_p)
+ this_line_subject_to_line_prefix = 2;
+ else if (this_line_subject_to_line_prefix == 2
+ && !it->string_from_prefix_prop_p)
+ this_line_subject_to_line_prefix = 0;
+
if (IT_CHARPOS (*it) < CHARPOS (this_line_min_pos))
SET_TEXT_POS (this_line_min_pos, IT_CHARPOS (*it), IT_BYTEPOS (*it));
if (IT_CHARPOS (*it) < to_charpos)
@@ -10357,11 +10550,26 @@ move_it_in_display_line_to (struct it *it,
&& wrap_it.sp >= 0
&& ((atpos_it.sp >= 0 && wrap_it.current_x < atpos_it.current_x)
|| (atx_it.sp >= 0 && wrap_it.current_x < atx_it.current_x)))
- RESTORE_IT (it, &wrap_it, wrap_data);
+ {
+#ifdef GLYPH_DEBUG
+ this_line_subject_to_line_prefix = wrap_flag;
+#endif /* GLYPH_DEBUG */
+ RESTORE_IT (it, &wrap_it, wrap_data);
+ }
else if (atpos_it.sp >= 0)
- RESTORE_IT (it, &atpos_it, atpos_data);
+ {
+#ifdef GLYPH_DEBUG
+ this_line_subject_to_line_prefix = atpos_flag;
+#endif /* GLYPH_DEBUG */
+ RESTORE_IT (it, &atpos_it, atpos_data);
+ }
else if (atx_it.sp >= 0)
- RESTORE_IT (it, &atx_it, atx_data);
+ {
+#ifdef GLYPH_DEBUG
+ this_line_subject_to_line_prefix = atx_flag;
+#endif /* GLYPH_DEBUG */
+ RESTORE_IT (it, &atx_it, atx_data);
+ }
done:
@@ -10435,13 +10643,9 @@ move_it_to (struct it *it, ptrdiff_t to_charpos, int to_x, int to_y, int to_vpos
int line_height, line_start_x = 0, reached = 0;
int max_current_x = 0;
void *backup_data = NULL;
- ptrdiff_t orig_charpos = -1;
- enum it_method orig_method = NUM_IT_METHODS;
for (;;)
{
- orig_charpos = IT_CHARPOS (*it);
- orig_method = it->method;
if (op & MOVE_TO_VPOS)
{
/* If no TO_CHARPOS and no TO_X specified, stop at the
@@ -10713,21 +10917,7 @@ move_it_to (struct it *it, ptrdiff_t to_charpos, int to_x, int to_y, int to_vpos
}
}
else
- {
- /* Make sure we do advance, otherwise we might infloop.
- This could happen when the first display element is
- wider than the window, or if we have a wrap-prefix
- that doesn't leave enough space after it to display
- even a single character. We only do this for moving
- through buffer text, as with display/overlay strings
- we'd need to also compare it->object's, and this is
- unlikely to happen in that case anyway. */
- if (IT_CHARPOS (*it) == orig_charpos
- && it->method == orig_method
- && orig_method == GET_FROM_BUFFER)
- set_iterator_to_next (it, false);
- it->continuation_lines_width += it->current_x;
- }
+ it->continuation_lines_width += it->current_x;
break;
default:
@@ -10736,6 +10926,7 @@ move_it_to (struct it *it, ptrdiff_t to_charpos, int to_x, int to_y, int to_vpos
/* Reset/increment for the next run. */
it->current_x = line_start_x;
+ it->wrap_prefix_width = 0;
line_start_x = 0;
it->hpos = 0;
it->line_number_produced_p = false;
@@ -10766,6 +10957,7 @@ move_it_to (struct it *it, ptrdiff_t to_charpos, int to_x, int to_y, int to_vpos
{
it->continuation_lines_width += it->current_x;
it->current_x = it->hpos = it->max_ascent = it->max_descent = 0;
+ it->wrap_prefix_width = 0;
it->current_y += it->max_ascent + it->max_descent;
++it->vpos;
last_height = it->max_ascent + it->max_descent;
@@ -10825,6 +11017,7 @@ move_it_vertically_backward (struct it *it, int dy)
reseat_1 (it, it->current.pos, true);
/* We are now surely at a line start. */
+ it->wrap_prefix_width = 0;
it->current_x = it->hpos = 0; /* FIXME: this is incorrect when bidi
reordering is in effect. */
it->continuation_lines_width = 0;
@@ -11103,7 +11296,7 @@ move_it_by_lines (struct it *it, ptrdiff_t dvpos)
dvpos--;
}
- it->current_x = it->hpos = 0;
+ it->current_x = it->hpos = it->wrap_prefix_width = 0;
/* Above call may have moved too far if continuation lines
are involved. Scan forward and see if it did. */
@@ -11112,7 +11305,7 @@ move_it_by_lines (struct it *it, ptrdiff_t dvpos)
move_it_to (&it2, start_charpos, -1, -1, -1, MOVE_TO_POS);
it->vpos -= it2.vpos;
it->current_y -= it2.current_y;
- it->current_x = it->hpos = 0;
+ it->current_x = it->hpos = it->wrap_prefix_width = 0;
/* If we moved too far back, move IT some lines forward. */
if (it2.vpos > -dvpos)
@@ -11390,8 +11583,8 @@ window_text_pixel_size (Lisp_Object window, Lisp_Object from, Lisp_Object to,
/* Start at the beginning of the line containing FROM. Otherwise
IT.current_x will be incorrectly set to zero at some arbitrary
non-zero X coordinate. */
- reseat_at_previous_visible_line_start (&it);
- it.current_x = it.hpos = 0;
+ move_it_by_lines (&it, 0);
+ it.current_x = it.hpos = it.wrap_prefix_width = 0;
if (IT_CHARPOS (it) != start)
{
void *it1data = NULL;
@@ -11444,7 +11637,7 @@ window_text_pixel_size (Lisp_Object window, Lisp_Object from, Lisp_Object to,
/* If FROM is on a newline, pretend that we start at the beginning
of the next line, because the newline takes no place on display. */
if (FETCH_BYTE (start) == '\n')
- it.current_x = 0;
+ it.current_x = 0, it.wrap_prefix_width = 0;
if (!NILP (x_limit))
{
it.last_visible_x = max_x;
@@ -11467,6 +11660,8 @@ window_text_pixel_size (Lisp_Object window, Lisp_Object from, Lisp_Object to,
the width of the last buffer position manually. */
if (IT_CHARPOS (it) > end)
{
+ int end_y = it.current_y;
+
end--;
RESTORE_IT (&it, &it2, it2data);
x = move_it_to (&it, end, to_x, max_y, -1, move_op);
@@ -11479,14 +11674,29 @@ window_text_pixel_size (Lisp_Object window, Lisp_Object from, Lisp_Object to,
/* DTRT if ignore_line_at_end is t. */
if (!NILP (ignore_line_at_end))
- doff = (max (it.max_ascent, it.ascent)
- + max (it.max_descent, it.descent));
+ {
+ /* If END-1 is on the previous screen line, we need to
+ account for the vertical dimensions of previous line. */
+ if (it.current_y < end_y)
+ doff = (max (it.max_ascent, it.ascent)
+ + max (it.max_descent, it.descent));
+ }
else
{
it.max_ascent = max (it.max_ascent, it.ascent);
it.max_descent = max (it.max_descent, it.descent);
}
}
+ else if (IT_CHARPOS (it) > end
+ && it.line_wrap == TRUNCATE
+ && it.current_x - it.first_visible_x >= it.last_visible_x)
+ {
+ /* If the display property at END is at the beginning of the
+ line, and the previous line was truncated, we are at END,
+ but it.current_y is not yet updated to reflect that. */
+ it.current_y += max (it.max_ascent, it.ascent)
+ + max (it.max_descent, it.descent);
+ }
}
else
bidi_unshelve_cache (it2data, true);
@@ -11677,6 +11887,8 @@ WINDOW. */)
set_buffer_internal_1 (b);
+ ptrdiff_t base_line_pos = w->base_line_pos;
+ int end_valid = w->window_end_valid;
if (!EQ (buffer, w->contents))
{
wset_buffer (w, buffer);
@@ -11689,6 +11901,11 @@ WINDOW. */)
unbind_to (count, Qnil);
+ /* Restore original values. This is important if this function is
+ called from some ':eval' form in the middle of redisplay. */
+ w->base_line_pos = base_line_pos;
+ w->window_end_valid = end_valid;
+
return value;
}
@@ -11773,7 +11990,7 @@ vadd_to_log (char const *format, va_list ap)
eassert (nargs <= ARRAYELTS (args));
AUTO_STRING (args0, format);
args[0] = args0;
- for (ptrdiff_t i = 1; i <= nargs; i++)
+ for (ptrdiff_t i = 1; i < nargs; i++)
args[i] = va_arg (ap, Lisp_Object);
Lisp_Object msg = Qnil;
msg = Fformat_message (nargs, args);
@@ -12616,7 +12833,7 @@ display_echo_area (struct window *w)
reset the echo_area_buffer in question to nil at the end because
with_echo_area_buffer will set it to an empty buffer. */
bool i = display_last_displayed_message_p;
- /* According to the C99, C11 and C++11 standards, the integral value
+ /* According to the C standard, the integral value
of a "bool" is always 0 or 1, so this array access is safe here,
if oddly typed. */
no_message_p = NILP (echo_area_buffer[i]);
@@ -12731,7 +12948,7 @@ resize_mini_window (struct window *w, bool exact_p)
displaying changes from under them. Such a resizing can happen,
for instance, when which-func prints a long message while
we are running fontification-functions. We're running these
- functions with safe_call which binds inhibit-redisplay to t. */
+ functions with dsafe_call which binds inhibit-redisplay to t. */
if (!NILP (Vinhibit_redisplay))
return false;
@@ -12750,7 +12967,7 @@ resize_mini_window (struct window *w, bool exact_p)
if (FRAME_MINIBUF_ONLY_P (f))
{
if (!NILP (resize_mini_frames))
- safe_call1 (Qwindow__resize_mini_frame, WINDOW_FRAME (w));
+ dsafe_call1 (Qwindow__resize_mini_frame, WINDOW_FRAME (w));
}
else
{
@@ -12997,7 +13214,7 @@ set_message (Lisp_Object string)
{
specpdl_ref count = SPECPDL_INDEX ();
specbind (Qinhibit_quit, Qt);
- message = safe_call1 (Vset_message_function, string);
+ message = dsafe_call1 (Vset_message_function, string);
unbind_to (count, Qnil);
if (STRINGP (message))
@@ -13076,7 +13293,7 @@ clear_message (bool current_p, bool last_displayed_p)
{
specpdl_ref count = SPECPDL_INDEX ();
specbind (Qinhibit_quit, Qt);
- preserve = safe_call (1, Vclear_message_function);
+ preserve = dsafe_calln (false, Vclear_message_function);
unbind_to (count, Qnil);
}
@@ -13114,7 +13331,7 @@ clear_garbaged_frames (void)
{
struct frame *f = XFRAME (frame);
- if (FRAME_VISIBLE_P (f) && FRAME_GARBAGED_P (f))
+ if (FRAME_REDISPLAY_P (f) && FRAME_GARBAGED_P (f))
{
if (f->resized_p
/* It makes no sense to redraw a non-selected TTY
@@ -13163,7 +13380,7 @@ echo_area_display (bool update_frame_p)
f = XFRAME (WINDOW_FRAME (w));
/* Don't display if frame is invisible or not yet initialized. */
- if (!FRAME_VISIBLE_P (f) || !f->glyphs_initialized_p)
+ if (!FRAME_REDISPLAY_P (f) || !f->glyphs_initialized_p)
return;
#ifdef HAVE_WINDOW_SYSTEM
@@ -13687,7 +13904,7 @@ prepare_menu_bars (void)
windows = Fcons (this, windows);
}
}
- safe__call1 (true, Vpre_redisplay_function, windows);
+ dsafe_calln (true, Vpre_redisplay_function, windows);
}
/* Update all frame titles based on their buffer names, etc. We do
@@ -13720,7 +13937,7 @@ prepare_menu_bars (void)
TTY frames to be completely redrawn, when there
are more than one of them, even though nothing
should be changed on display. */
- || (FRAME_VISIBLE_P (f) == 2 && FRAME_WINDOW_P (f))))
+ || (FRAME_REDISPLAY_P (f) && FRAME_WINDOW_P (f))))
gui_consider_frame_title (frame);
}
}
@@ -14332,7 +14549,7 @@ display_tab_bar_line (struct it *it, int height)
row->truncated_on_left_p = false;
row->truncated_on_right_p = false;
- it->current_x = it->hpos = 0;
+ it->current_x = it->hpos = it->wrap_prefix_width = 0;
it->current_y += row->height;
++it->vpos;
++it->glyph_row;
@@ -14611,21 +14828,32 @@ tab_bar_item_info (struct frame *f, struct glyph *glyph,
Qmenu_item, f->current_tab_bar_string);
if (! FIXNUMP (prop))
return false;
+
*prop_idx = XFIXNUM (prop);
- *close_p = !NILP (Fget_text_property (make_fixnum (charpos),
- Qclose_tab,
- f->current_tab_bar_string));
+ if (close_p)
+ *close_p = !NILP (Fget_text_property (make_fixnum (charpos),
+ Qclose_tab,
+ f->current_tab_bar_string));
return true;
}
-/* Get information about the tab-bar item at position X/Y on frame F.
- Return in *GLYPH a pointer to the glyph of the tab-bar item in
- the current matrix of the tab-bar window of F, or NULL if not
- on a tab-bar item. Return in *PROP_IDX the index of the tab-bar
- item in F->tab_bar_items. Value is
+/* Get information about the tab-bar item at position X/Y on frame F's
+ tab bar window.
+
+ Set *GLYPH to a pointer to the glyph of the tab-bar item in the
+ current matrix of the tab-bar window of F, or NULL if not on a
+ tab-bar item. Return in *PROP_IDX the index of the tab-bar item in
+ F->tab_bar_items.
+
+ Place the window-relative vpos of Y in *VPOS, and the
+ window-relative hpos of X in *HPOS. If CLOSE_P, set it to whether
+ or not the tab bar item represents a button that should close a
+ tab.
+
+ Value is
-1 if X/Y is not on a tab-bar item
0 if X/Y is on the same item that was highlighted before.
@@ -14633,7 +14861,7 @@ tab_bar_item_info (struct frame *f, struct glyph *glyph,
static int
get_tab_bar_item (struct frame *f, int x, int y, struct glyph **glyph,
- int *hpos, int *vpos, int *prop_idx, bool *close_p)
+ int *hpos, int *vpos, int *prop_idx, bool *close_p)
{
struct window *w = XWINDOW (f->tab_bar_window);
int area;
@@ -14651,6 +14879,38 @@ get_tab_bar_item (struct frame *f, int x, int y, struct glyph **glyph,
return *prop_idx == f->last_tab_bar_item ? 0 : 1;
}
+/* EXPORT:
+
+ Like `get_tab_bar_item'. However, don't return anything for GLYPH,
+ HPOS, or VPOS, and treat X and Y as relative to F itself, as
+ opposed to its tab bar window. */
+
+int
+get_tab_bar_item_kbd (struct frame *f, int x, int y, int *prop_idx,
+ bool *close_p)
+{
+ struct window *w;
+ int area, vpos, hpos;
+ struct glyph *glyph;
+
+ w = XWINDOW (f->tab_bar_window);
+
+ /* Convert X and Y to window coordinates. */
+ frame_to_window_pixel_xy (w, &x, &y);
+
+ /* Find the glyph under X/Y. */
+ glyph = x_y_to_hpos_vpos (w, x, y, &hpos, &vpos, 0,
+ 0, &area);
+ if (glyph == NULL)
+ return -1;
+
+ /* Get the start of this tab-bar item's properties in
+ f->tab_bar_items. */
+ if (!tab_bar_item_info (f, glyph, prop_idx, close_p))
+ return -1;
+
+ return *prop_idx == f->last_tab_bar_item ? 0 : 1;
+}
/* EXPORT:
Handle mouse button event on the tab-bar of frame F, at
@@ -14983,7 +15243,10 @@ update_tool_bar (struct frame *f, bool save_match_data)
/* Set F->desired_tool_bar_string to a Lisp string representing frame
F's desired tool-bar contents. F->tool_bar_items must have
- been set up previously by calling prepare_menu_bars. */
+ been set up previously by calling prepare_menu_bars.
+
+ Also set F->tool_bar_wraps_p to whether or not the tool bar
+ contains explicit line breaking items. */
static void
build_desired_tool_bar_string (struct frame *f)
@@ -15005,9 +15268,11 @@ build_desired_tool_bar_string (struct frame *f)
size_needed = f->n_tool_bar_items;
/* Reuse f->desired_tool_bar_string, if possible. */
+
if (size < size_needed || NILP (f->desired_tool_bar_string))
- fset_desired_tool_bar_string
- (f, Fmake_string (make_fixnum (size_needed), make_fixnum (' '), Qnil));
+ /* Don't initialize the contents of this string yet, as they will
+ be set within the loop below. */
+ fset_desired_tool_bar_string (f, make_uninit_string (size_needed));
else
{
AUTO_LIST4 (props, Qdisplay, Qnil, Qmenu_item, Qnil);
@@ -15015,6 +15280,8 @@ build_desired_tool_bar_string (struct frame *f)
props, f->desired_tool_bar_string);
}
+ f->tool_bar_wraps_p = false;
+
/* Put a `display' property on the string for the images to display,
put a `menu_item' property on tool-bar items with a value that
is the index of the item in F's tool-bar item vector. */
@@ -15027,6 +15294,21 @@ build_desired_tool_bar_string (struct frame *f)
bool selected_p = !NILP (PROP (TOOL_BAR_ITEM_SELECTED_P));
int hmargin, vmargin, relief, idx, end;
+ if (!NILP (PROP (TOOL_BAR_ITEM_WRAP)))
+ {
+ /* This is a line wrap. Instead of building a tool bar
+ item, display a new line character instead. */
+ SSET (f->desired_tool_bar_string, i, '\n');
+
+ /* Set F->tool_bar_wraps_p. This tells redisplay_tool_bar
+ to allow individual rows to be different heights. */
+ f->tool_bar_wraps_p = true;
+ continue;
+ }
+
+ /* Replace this with a space character. */
+ SSET (f->desired_tool_bar_string, i, ' ');
+
/* If image is a vector, choose the image according to the
button state. */
image = PROP (TOOL_BAR_ITEM_IMAGES);
@@ -15138,6 +15420,16 @@ build_desired_tool_bar_string (struct frame *f)
props, f->desired_tool_bar_string);
#undef PROP
}
+
+ /* Now replace each character between i and the end of the tool bar
+ string with spaces, to prevent stray newlines from accumulating
+ when the number of tool bar items decreases. `size' is 0 if the
+ tool bar string is new, but in that case the string will have
+ been completely initialized anyway. */
+
+ for (; i < size; ++i)
+ /* Replace this with a space character. */
+ SSET (f->desired_tool_bar_string, i, ' ');
}
@@ -15151,7 +15443,10 @@ build_desired_tool_bar_string (struct frame *f)
If HEIGHT is -1, we are counting needed tool-bar lines, so don't
count a final empty row in case the tool-bar width exactly matches
the window width.
-*/
+
+ HEIGHT may also be -1 if there is an explicit line wrapping item
+ inside the tool bar; in that case, allow individual rows of the
+ tool bar to differ in height. */
static void
display_tool_bar_line (struct it *it, int height)
@@ -15215,8 +15510,18 @@ display_tool_bar_line (struct it *it, int height)
++i;
}
- /* Stop at line end. */
+ /* Stop at the end of the iterator, and move to the next line
+ upon a '\n' appearing in the tool bar string. Tool bar
+ strings may contain multiple new line characters when
+ explicit wrap items are encountered. */
+
if (ITERATOR_AT_END_OF_LINE_P (it))
+ {
+ reseat_at_next_visible_line_start (it, false);
+ break;
+ }
+
+ if (ITERATOR_AT_END_P (it))
break;
set_iterator_to_next (it, true);
@@ -15243,7 +15548,8 @@ display_tool_bar_line (struct it *it, int height)
last->left_box_line_p = true;
/* Make line the desired height and center it vertically. */
- if ((height -= it->max_ascent + it->max_descent) > 0)
+ if (height != -1
+ && (height -= it->max_ascent + it->max_descent) > 0)
{
/* Don't add more than one line height. */
height %= FRAME_LINE_HEIGHT (it->f);
@@ -15267,7 +15573,7 @@ display_tool_bar_line (struct it *it, int height)
row->truncated_on_left_p = false;
row->truncated_on_right_p = false;
- it->current_x = it->hpos = 0;
+ it->current_x = it->hpos = it->wrap_prefix_width = 0;
it->current_y += row->height;
++it->vpos;
++it->glyph_row;
@@ -15277,6 +15583,7 @@ display_tool_bar_line (struct it *it, int height)
/* Value is the number of pixels needed to make all tool-bar items of
frame F visible. The actual number of glyph rows needed is
returned in *N_ROWS if non-NULL. */
+
static int
tool_bar_height (struct frame *f, int *n_rows, bool pixelwise)
{
@@ -15354,7 +15661,9 @@ redisplay_tool_bar (struct frame *f)
struct window *w;
struct it it;
struct glyph_row *row;
+ bool change_height_p;
+ change_height_p = false;
f->tool_bar_redisplayed = true;
/* If frame hasn't a tool-bar window or if it is zero-height, don't
@@ -15407,6 +15716,15 @@ redisplay_tool_bar (struct frame *f)
/* Always do that now. */
clear_glyph_matrix (w->desired_matrix);
f->fonts_changed = true;
+
+ /* Kludge (this applies to the X Windows version as well as
+ Android): when the tool bar size changes,
+ adjust_window_size (presumably called by
+ change_tool_bar_height_hook) does not call through to
+ resize_frame_windows. Pending further investigation,
+ just call it here as well. */
+ resize_frame_windows (f, FRAME_INNER_HEIGHT (f), false);
+
return true;
}
}
@@ -15429,18 +15747,39 @@ redisplay_tool_bar (struct frame *f)
border = 0;
rows = f->n_tool_bar_rows;
- height = max (1, (it.last_visible_y - border) / rows);
- extra = it.last_visible_y - border - height * rows;
- while (it.current_y < it.last_visible_y)
+ if (f->tool_bar_wraps_p)
{
- int h = 0;
- if (extra > 0 && rows-- > 0)
+ /* If the tool bar contains explicit line wrapping items,
+ don't force each row to have a fixed height. */
+
+ while (!ITERATOR_AT_END_P (&it))
+ display_tool_bar_line (&it, -1);
+
+ /* Because changes to individual tool bar items may now
+ change the height of the tool bar, adjust the height of
+ the tool bar window if it is different from the tool bar
+ height in any way. */
+
+ if (it.current_y != it.last_visible_y)
+ change_height_p = true;
+ }
+ else
+ {
+ height = max (1, (it.last_visible_y - border) / rows);
+ extra = it.last_visible_y - border - height * rows;
+
+ while (it.current_y < it.last_visible_y)
{
- h = (extra + rows - 1) / rows;
- extra -= h;
+ int h = 0;
+ if (extra > 0 && rows-- > 0)
+ {
+ h = (extra + rows - 1) / rows;
+ extra -= h;
+ }
+
+ display_tool_bar_line (&it, height + h);
}
- display_tool_bar_line (&it, height + h);
}
}
else
@@ -15456,8 +15795,6 @@ redisplay_tool_bar (struct frame *f)
if (!NILP (Vauto_resize_tool_bars))
{
- bool change_height_p = false;
-
/* If we couldn't display everything, change the tool-bar's
height if there is room for more. */
if (IT_STRING_CHARPOS (it) < it.end_charpos)
@@ -16516,8 +16853,9 @@ redisplay_internal (void)
enum {MAX_GARBAGED_FRAME_RETRIES = 2 };
int garbaged_frame_retries = 0;
- /* True means redisplay has to consider all windows on all
- frames. False, only selected_window is considered. */
+ /* False means that only the selected_window needs to be updated.
+ True means that other windows may need to be updated as well,
+ so we need to consult `needs_no_update` for all windows. */
bool consider_all_windows_p;
/* True means redisplay has to redisplay the miniwindow. */
@@ -16594,7 +16932,7 @@ redisplay_internal (void)
display area, displaying a different frame means redisplay
the whole thing. */
SET_FRAME_GARBAGED (sf);
-#ifndef DOS_NT
+#if !defined DOS_NT && !defined HAVE_ANDROID
set_tty_color_mode (FRAME_TTY (sf), sf);
#endif
FRAME_TTY (sf)->previous_frame = sf;
@@ -16609,7 +16947,7 @@ redisplay_internal (void)
{
struct frame *f = XFRAME (frame);
- if (FRAME_VISIBLE_P (f))
+ if (FRAME_REDISPLAY_P (f))
{
++number_of_visible_frames;
/* Adjust matrices for visible frames only. */
@@ -16751,7 +17089,7 @@ redisplay_internal (void)
&& !w->update_mode_line
&& !current_buffer->clip_changed
&& !current_buffer->prevent_redisplay_optimizations_p
- && FRAME_VISIBLE_P (XFRAME (w->frame))
+ && FRAME_REDISPLAY_P (XFRAME (w->frame))
&& !FRAME_OBSCURED_P (XFRAME (w->frame))
&& !XFRAME (w->frame)->cursor_type_changed
&& !XFRAME (w->frame)->face_change
@@ -16935,6 +17273,7 @@ redisplay_internal (void)
NULL, DEFAULT_FACE_ID);
it.current_x = this_line_start_x;
it.current_y = this_line_y;
+ it.wrap_prefix_width = 0;
it.vpos = this_line_vpos;
if (current_buffer->long_line_optimizations_p
@@ -17029,7 +17368,7 @@ redisplay_internal (void)
if (gcscrollbars && FRAME_TERMINAL (f)->condemn_scroll_bars_hook)
FRAME_TERMINAL (f)->condemn_scroll_bars_hook (f);
- if (FRAME_VISIBLE_P (f) && !FRAME_OBSCURED_P (f))
+ if (FRAME_REDISPLAY_P (f) && !FRAME_OBSCURED_P (f))
{
/* Don't allow freeing images and faces for this
frame as long as the frame's update wasn't
@@ -17055,7 +17394,7 @@ redisplay_internal (void)
if (gcscrollbars && FRAME_TERMINAL (f)->judge_scroll_bars_hook)
FRAME_TERMINAL (f)->judge_scroll_bars_hook (f);
- if (FRAME_VISIBLE_P (f) && !FRAME_OBSCURED_P (f))
+ if (FRAME_REDISPLAY_P (f) && !FRAME_OBSCURED_P (f))
{
/* If fonts changed on visible frame, display again. */
if (f->fonts_changed)
@@ -17161,7 +17500,7 @@ redisplay_internal (void)
}
}
}
- else if (FRAME_VISIBLE_P (sf) && !FRAME_OBSCURED_P (sf))
+ else if (FRAME_REDISPLAY_P (sf) && !FRAME_OBSCURED_P (sf))
{
sf->inhibit_clear_image_cache = true;
displayed_buffer = XBUFFER (XWINDOW (selected_window)->contents);
@@ -17212,7 +17551,7 @@ redisplay_internal (void)
unrequest_sigio ();
STOP_POLLING;
- if (FRAME_VISIBLE_P (sf) && !FRAME_OBSCURED_P (sf))
+ if (FRAME_REDISPLAY_P (sf) && !FRAME_OBSCURED_P (sf))
{
if (hscroll_retries <= MAX_HSCROLL_RETRIES
&& hscroll_windows (selected_window))
@@ -17311,7 +17650,7 @@ redisplay_internal (void)
FOR_EACH_FRAME (tail, frame)
{
- if (XFRAME (frame)->visible)
+ if (FRAME_REDISPLAY_P (XFRAME (frame)))
new_count++;
}
@@ -17435,6 +17774,9 @@ static void
mark_window_display_accurate_1 (struct window *w, bool accurate_p)
{
struct buffer *b = XBUFFER (w->contents);
+#ifdef HAVE_TEXT_CONVERSION
+ ptrdiff_t prev_point, prev_mark;
+#endif /* HAVE_TEXT_CONVERSION */
w->last_modified = accurate_p ? BUF_MODIFF (b) : 0;
w->last_overlay_modified = accurate_p ? BUF_OVERLAY_MODIFF (b) : 0;
@@ -17464,12 +17806,59 @@ mark_window_display_accurate_1 (struct window *w, bool accurate_p)
w->last_cursor_vpos = w->cursor.vpos;
w->last_cursor_off_p = w->cursor_off_p;
+#ifdef HAVE_TEXT_CONVERSION
+ prev_point = w->last_point;
+ prev_mark = w->last_mark;
+#endif /* HAVE_TEXT_CONVERSION */
+
if (w == XWINDOW (selected_window))
w->last_point = BUF_PT (b);
else
w->last_point = marker_position (w->pointm);
- w->window_end_valid = true;
+ /* w->last_mark is recorded for text conversion purposes.
+ Input methods aren't interested in the value of the mark
+ if it is inactive, so set it to -1 if it's not. */
+
+ if (XMARKER (BVAR (b, mark))->buffer == b
+ && !NILP (BVAR (b, mark_active)))
+ w->last_mark = marker_position (BVAR (b, mark));
+ else
+ w->last_mark = -1;
+
+#ifdef HAVE_TEXT_CONVERSION
+ /* See the description of this field in struct window. */
+ w->ephemeral_last_point = w->last_point;
+
+ /* Point motion is only propagated to the input method for use
+ in text conversion during a redisplay. While this can lead
+ to inconsistencies when point has moved but the change has
+ not yet been displayed, it leads to better results most of
+ the time, as point often changes within calls to
+ `save-excursion', and the only way to detect such calls is to
+ observe that the next redisplay never ends with those changes
+ applied.
+
+ Changes to buffer text are immediately propagated to the
+ input method, and the position of point is also updated
+ during such a change, so the consequences are not that
+ severe. */
+
+ if ((prev_point != w->last_point
+ || prev_mark != w->last_mark)
+ && FRAME_WINDOW_P (WINDOW_XFRAME (w))
+ && w == XWINDOW (WINDOW_XFRAME (w)->selected_window))
+ report_point_change (WINDOW_XFRAME (w), w, b);
+#endif /* HAVE_TEXT_CONVERSION */
+
+ struct glyph_row *row;
+ /* These conditions should be consistent with CHECK_WINDOW_END. */
+ if (w->window_end_vpos < w->current_matrix->nrows
+ && ((row = MATRIX_ROW (w->current_matrix, w->window_end_vpos),
+ !row->enabled_p
+ || MATRIX_ROW_DISPLAYS_TEXT_P (row)
+ || MATRIX_ROW_VPOS (row, w->current_matrix) == 0)))
+ w->window_end_valid = true;
w->update_mode_line = false;
w->preserve_vscroll_p = false;
}
@@ -18350,11 +18739,8 @@ run_window_scroll_functions (Lisp_Object window, struct text_pos startp)
if (!NILP (Vwindow_scroll_functions))
{
- specpdl_ref count = SPECPDL_INDEX ();
- specbind (Qinhibit_quit, Qt);
safe_run_hooks_2
(Qwindow_scroll_functions, window, make_fixnum (CHARPOS (startp)));
- unbind_to (count, Qnil);
SET_TEXT_POS_FROM_MARKER (startp, w->start);
/* In case the hook functions switch buffers. */
set_buffer_internal (XBUFFER (w->contents));
@@ -18406,7 +18792,7 @@ cursor_row_fully_visible_p (struct window *w, bool force_p,
XSETWINDOW (window, w);
/* Implementation note: if the function we call here signals an
error, we will NOT scroll when the cursor is partially-visible. */
- Lisp_Object val = safe_call1 (mclfv_p, window);
+ Lisp_Object val = dsafe_call1 (mclfv_p, window);
if (NILP (val))
return true;
else if (just_test_user_preference_p)
@@ -18473,6 +18859,14 @@ enum
`scroll-conservatively' and the Emacs manual. */
#define SCROLL_LIMIT 100
+/* The freshness of the w->base_line_number cache is only ensured at every
+ redisplay cycle, so the cache can be used only if there's been
+ no relevant changes to the buffer since the last redisplay. */
+#define BASE_LINE_NUMBER_VALID_P(w) \
+ (eassert (current_buffer == XBUFFER ((w)->contents)), \
+ !current_buffer->clip_changed \
+ && BEG_UNCHANGED >= (w)->base_line_pos)
+
static int
try_scrolling (Lisp_Object window, bool just_this_one_p,
intmax_t arg_scroll_conservatively, intmax_t scroll_step,
@@ -18773,9 +19167,10 @@ try_scrolling (Lisp_Object window, bool just_this_one_p,
else
{
/* Maybe forget recorded base line for line number display. */
- if (!just_this_one_p
- || current_buffer->clip_changed
- || BEG_UNCHANGED < CHARPOS (startp))
+ /* FIXME: Why do we need this? `try_scrolling` can only be called from
+ `redisplay_window` which should have flushed this cache already when
+ eeded. */
+ if (!BASE_LINE_NUMBER_VALID_P (w))
w->base_line_number = 0;
/* If cursor ends up on a partially visible line,
@@ -18966,7 +19361,7 @@ try_cursor_movement (Lisp_Object window, struct text_pos startp,
&& !f->cursor_type_changed
&& NILP (Vshow_trailing_whitespace)
/* When display-line-numbers is in relative mode, moving point
- requires to redraw the entire window. */
+ requires redrawing the entire window. */
&& !EQ (Vdisplay_line_numbers, Qrelative)
&& !EQ (Vdisplay_line_numbers, Qvisual)
/* When the current line number should be displayed in a
@@ -19545,9 +19940,6 @@ redisplay_window (Lisp_Object window, bool just_this_one_p)
/* Record it now because it's overwritten. */
bool current_matrix_up_to_date_p = false;
bool used_current_matrix_p = false;
- /* This is less strict than current_matrix_up_to_date_p.
- It indicates that the buffer contents and narrowing are unchanged. */
- bool buffer_unchanged_p = false;
bool temp_scroll_step = false;
specpdl_ref count = SPECPDL_INDEX ();
int rc;
@@ -19653,11 +20045,6 @@ redisplay_window (Lisp_Object window, bool just_this_one_p)
specbind (Qinhibit_point_motion_hooks, Qt);
- buffer_unchanged_p
- = (w->window_end_valid
- && !current_buffer->clip_changed
- && !window_outdated (w));
-
/* When windows_or_buffers_changed is non-zero, we can't rely
on the window end being valid, so set it to zero there. */
if (windows_or_buffers_changed)
@@ -19797,6 +20184,10 @@ redisplay_window (Lisp_Object window, bool just_this_one_p)
}
}
+ if (!BASE_LINE_NUMBER_VALID_P (w))
+ /* Forget any recorded base line for line number display. */
+ w->base_line_number = 0;
+
force_start:
/* Handle case where place to start displaying has been specified,
@@ -19817,10 +20208,6 @@ redisplay_window (Lisp_Object window, bool just_this_one_p)
w->preserve_vscroll_p = false;
w->window_end_valid = false;
- /* Forget any recorded base line for line number display. */
- if (!buffer_unchanged_p)
- w->base_line_number = 0;
-
/* Redisplay the mode line. Select the buffer properly for that.
Also, run the hook window-scroll-functions
because we have scrolled. */
@@ -19974,7 +20361,7 @@ redisplay_window (Lisp_Object window, bool just_this_one_p)
propagated its info to `w' anyway. */
w->redisplay = false;
XBUFFER (w->contents)->text->redisplay = false;
- safe__call1 (true, Vpre_redisplay_function, Fcons (window, Qnil));
+ dsafe_calln (true, Vpre_redisplay_function, Fcons (window, Qnil));
if (w->redisplay || XBUFFER (w->contents)->text->redisplay
|| ((EQ (Vdisplay_line_numbers, Qrelative)
@@ -20149,12 +20536,6 @@ redisplay_window (Lisp_Object window, bool just_this_one_p)
if (w->cursor.vpos >= 0)
{
- if (!just_this_one_p
- || current_buffer->clip_changed
- || BEG_UNCHANGED < CHARPOS (startp))
- /* Forget any recorded base line for line number display. */
- w->base_line_number = 0;
-
if (!cursor_row_fully_visible_p (w, true, false, false))
{
clear_glyph_matrix (w->desired_matrix);
@@ -20225,10 +20606,6 @@ redisplay_window (Lisp_Object window, bool just_this_one_p)
debug_method_add (w, "recenter");
#endif
- /* Forget any previously recorded base line for line number display. */
- if (!buffer_unchanged_p)
- w->base_line_number = 0;
-
/* Determine the window start relative to point. */
init_iterator (&it, w, PT, PT_BYTE, NULL, DEFAULT_FACE_ID);
it.current_y = it.last_visible_y;
@@ -20334,7 +20711,7 @@ redisplay_window (Lisp_Object window, bool just_this_one_p)
it.current_y = 0;
}
- it.current_x = it.hpos = 0;
+ it.current_x = it.wrap_prefix_width = it.hpos = 0;
/* Set the window start position here explicitly, to avoid an
infinite loop in case the functions in window-scroll-functions
@@ -22302,7 +22679,7 @@ try_window_id (struct window *w)
/* We may start in a continuation line. If so, we have to
get the right continuation_lines_width and current_x. */
it.continuation_lines_width = last_row->continuation_lines_width;
- it.hpos = it.current_x = 0;
+ it.hpos = it.current_x = it.wrap_prefix_width = 0;
/* Display the rest of the lines at the window end. */
it.glyph_row = MATRIX_ROW (desired_matrix, it.vpos);
@@ -22907,6 +23284,7 @@ insert_left_trunc_glyphs (struct it *it)
/* Get the truncation glyphs. */
truncate_it = *it;
truncate_it.current_x = 0;
+ truncate_it.wrap_prefix_width = 0;
truncate_it.face_id = DEFAULT_FACE_ID;
truncate_it.glyph_row = &scratch_glyph_row;
truncate_it.area = TEXT_AREA;
@@ -23669,6 +24047,10 @@ extend_face_to_end_of_line (struct it *it)
for (it->current_x = 0; g < e; g++)
it->current_x += g->pixel_width;
+ if (it->continuation_lines_width
+ && it->string_from_prefix_prop_p)
+ it->wrap_prefix_width = it->current_x;
+
it->area = LEFT_MARGIN_AREA;
it->face_id = default_face->id;
while (it->glyph_row->used[LEFT_MARGIN_AREA]
@@ -24390,6 +24772,13 @@ maybe_produce_line_number (struct it *it)
if (!last_line)
{
/* If possible, reuse data cached by line-number-mode. */
+ /* NOTE: We use `base_line_number` without checking
+ BASE_LINE_NUMBER_VALID_P because we assume that `redisplay_window`
+ has already flushed this cache for us when needed.
+ NOTE2: Checking BASE_LINE_NUMBER_VALID_P here would be
+ overly pessimistic because it might say that the cache
+ was invalid before entering `redisplay_window` yet the
+ value has just been refreshed. */
if (it->w->base_line_number > 0
&& it->w->base_line_pos > 0
&& it->w->base_line_pos <= IT_CHARPOS (*it)
@@ -24439,7 +24828,7 @@ maybe_produce_line_number (struct it *it)
/* Produce the glyphs for the line number. */
struct it tem_it;
char lnum_buf[INT_STRLEN_BOUND (ptrdiff_t) + 1];
- bool beyond_zv = IT_BYTEPOS (*it) >= ZV_BYTE ? true : false;
+ bool beyond_zv = IT_BYTEPOS (*it) >= ZV_BYTE;
ptrdiff_t lnum_offset = -1; /* to produce 1-based line numbers */
int lnum_face_id = merge_faces (it->w, Qline_number, 0, DEFAULT_FACE_ID);
int current_lnum_face_id
@@ -24669,7 +25058,7 @@ should_produce_line_number (struct it *it)
because get-char-property always returns nil for ZV, except if
the property is in 'default-text-properties'. */
if (NILP (val) && IT_CHARPOS (*it) >= ZV)
- val = disable_line_numbers_overlay_at_eob ();
+ return !disable_line_numbers_overlay_at_eob ();
return NILP (val) ? true : false;
}
@@ -24734,6 +25123,7 @@ display_line (struct it *it, int cursor_vpos)
int first_visible_x = it->first_visible_x;
int last_visible_x = it->last_visible_x;
int x_incr = 0;
+ int this_line_subject_to_line_prefix = 0;
/* We always start displaying at hpos zero even if hscrolled. */
eassert (it->hpos == 0 && it->current_x == 0);
@@ -24810,7 +25200,10 @@ display_line (struct it *it, int cursor_vpos)
if (it->current_x < it->first_visible_x
&& (move_result == MOVE_NEWLINE_OR_CR
|| move_result == MOVE_POS_MATCH_OR_ZV))
- it->current_x = it->first_visible_x;
+ {
+ it->current_x = it->first_visible_x;
+ it->wrap_prefix_width = 0;
+ }
/* In case move_it_in_display_line_to above "produced" the line
number. */
@@ -24839,6 +25232,7 @@ display_line (struct it *it, int cursor_vpos)
/* We only do this when not calling move_it_in_display_line_to
above, because that function calls itself handle_line_prefix. */
handle_line_prefix (it);
+ this_line_subject_to_line_prefix = it->string_from_prefix_prop_p;
}
else
{
@@ -25005,12 +25399,15 @@ display_line (struct it *it, int cursor_vpos)
process the prefix now. */
if (it->area == TEXT_AREA && pending_handle_line_prefix)
{
- /* Line numbers should precede the line-prefix or wrap-prefix. */
+ /* Line numbers should precede the line-prefix or
+ wrap-prefix. */
if (line_number_needed)
maybe_produce_line_number (it);
pending_handle_line_prefix = false;
handle_line_prefix (it);
+ this_line_subject_to_line_prefix
+ = it->string_from_prefix_prop_p;
}
continue;
}
@@ -25031,7 +25428,16 @@ display_line (struct it *it, int cursor_vpos)
if (/* Not a newline. */
nglyphs > 0
/* Glyphs produced fit entirely in the line. */
- && it->current_x < it->last_visible_x)
+ && (it->current_x < it->last_visible_x
+ /* Or a line or wrap prefix is in effect, and not
+ truncating the glyph produced immediately after it
+ would cause an infinite cycle. */
+ || (it->line_wrap != TRUNCATE
+ /* This code is not valid if multiple glyphs were
+ produced, as some of these glyphs might remain
+ within this line. */
+ && nglyphs == 1
+ && this_line_subject_to_line_prefix)))
{
it->hpos += nglyphs;
row->ascent = max (row->ascent, it->max_ascent);
@@ -25082,7 +25488,20 @@ display_line (struct it *it, int cursor_vpos)
&& FRAME_WINDOW_P (it->f)
&& (row->reversed_p
? WINDOW_LEFT_FRINGE_WIDTH (it->w)
- : WINDOW_RIGHT_FRINGE_WIDTH (it->w)))))
+ : WINDOW_RIGHT_FRINGE_WIDTH (it->w))))
+ /* There is no line prefix, next to which the
+ iterator _must_ produce a minimum of one actual
+ glyph. */
+ && (!this_line_subject_to_line_prefix
+ /* Or this is the second glyph to be produced
+ beyond the confines of the line. */
+ || (i != 0
+ && (x > it->last_visible_x
+ || (x == it->last_visible_x
+ && FRAME_WINDOW_P (it->f)
+ && (row->reversed_p
+ ? WINDOW_LEFT_FRINGE_WIDTH (it->w)
+ : WINDOW_RIGHT_FRINGE_WIDTH (it->w)))))))
{
/* End of a continued line. */
@@ -25379,24 +25798,23 @@ display_line (struct it *it, int cursor_vpos)
break;
}
- /* Detect overly-wide wrap-prefixes made of (space ...) display
- properties. When such a wrap prefix reaches past the right
- margin of the window, we need to avoid the call to
- set_iterator_to_next below, so that it->line_wrap is left at
- its TRUNCATE value wisely set by handle_line_prefix.
- Otherwise, set_iterator_to_next will pop the iterator stack,
- restore it->line_wrap, and redisplay might infloop. */
- bool overwide_wrap_prefix =
- CONSP (it->object) && EQ (XCAR (it->object), Qspace)
- && it->sp > 0 && it->method == GET_FROM_STRETCH
- && it->current_x >= it->last_visible_x
- && it->continuation_lines_width > 0
- && it->line_wrap == TRUNCATE && it->stack[0].line_wrap != TRUNCATE;
-
/* Proceed with next display element. Note that this skips
over lines invisible because of selective display. */
- if (!overwide_wrap_prefix)
- set_iterator_to_next (it, true);
+ set_iterator_to_next (it, true);
+
+ /* If IT has just finished producing glyphs for the wrap prefix
+ and is proceeding to the next method, there might not be
+ sufficient space remaining in this line to accommodate its
+ glyphs, and one real glyph must be produced to prevent an
+ infinite loop. Next, clear this flag if such a glyph has
+ already been produced. */
+
+ if (this_line_subject_to_line_prefix == 1
+ && !it->string_from_prefix_prop_p)
+ this_line_subject_to_line_prefix = 2;
+ else if (this_line_subject_to_line_prefix == 2
+ && !it->string_from_prefix_prop_p)
+ this_line_subject_to_line_prefix = 0;
/* If we truncate lines, we are done when the last displayed
glyphs reach past the right margin of the window. */
@@ -25642,7 +26060,7 @@ display_line (struct it *it, int cursor_vpos)
HPOS) = (0 0). Vertical positions are incremented. As a
convenience for the caller, IT->glyph_row is set to the next
row to be used. */
- it->current_x = it->hpos = 0;
+ it->wrap_prefix_width = it->current_x = it->hpos = 0;
it->current_y += row->height;
/* Restore the first and last visible X if we adjusted them for
current-line hscrolling. */
@@ -26121,7 +26539,7 @@ Value is the new character position of point. */)
{
struct text_pos pt;
struct it it;
- int pt_x, target_x, pixel_width, pt_vpos;
+ int pt_x, pt_wrap_prefix_x, target_x, pixel_width, pt_vpos;
bool at_eol_p;
bool overshoot_expected = false;
bool target_is_eol_p = false;
@@ -26153,6 +26571,7 @@ Value is the new character position of point. */)
reseat:
reseat_at_previous_visible_line_start (&it);
it.current_x = it.hpos = it.current_y = it.vpos = 0;
+ it.wrap_prefix_width = 0;
if (IT_CHARPOS (it) != PT)
{
move_it_to (&it, overshoot_expected ? PT - 1 : PT,
@@ -26171,6 +26590,7 @@ Value is the new character position of point. */)
move_it_in_display_line (&it, PT, -1, MOVE_TO_POS);
}
pt_x = it.current_x;
+ pt_wrap_prefix_x = it.wrap_prefix_width;
pt_vpos = it.vpos;
if (dir > 0 || overshoot_expected)
{
@@ -26185,10 +26605,11 @@ Value is the new character position of point. */)
it.glyph_row = NULL;
PRODUCE_GLYPHS (&it); /* compute it.pixel_width */
it.glyph_row = row;
- /* PRODUCE_GLYPHS advances it.current_x, so we must restore
- it, lest it will become out of sync with it's buffer
+ /* PRODUCE_GLYPHS advances it.current_x, so it must be
+ restored, lest it become out of sync with its buffer
position. */
it.current_x = pt_x;
+ it.wrap_prefix_width = pt_wrap_prefix_x;
}
else
at_eol_p = ITERATOR_AT_END_OF_LINE_P (&it);
@@ -26233,6 +26654,7 @@ Value is the new character position of point. */)
it.last_visible_x = DISP_INFINITY;
reseat_at_previous_visible_line_start (&it);
it.current_x = it.current_y = it.hpos = 0;
+ it.wrap_prefix_width = 0;
if (pt_vpos != 0)
move_it_by_lines (&it, pt_vpos);
}
@@ -26523,17 +26945,18 @@ display_menu_bar (struct window *w)
init_iterator (&it, w, -1, -1, f->desired_matrix->rows, MENU_FACE_ID);
it.first_visible_x = 0;
it.last_visible_x = FRAME_PIXEL_WIDTH (f);
-#elif defined (HAVE_X_WINDOWS) /* X without toolkit. */
+#elif defined (HAVE_X_WINDOWS) || defined (HAVE_ANDROID)
+ struct window *menu_window = NULL;
+ struct face *face = FACE_FROM_ID (f, MENU_FACE_ID);
+
if (FRAME_WINDOW_P (f))
{
/* Menu bar lines are displayed in the desired matrix of the
dummy window menu_bar_window. */
- struct window *menu_w;
- menu_w = XWINDOW (f->menu_bar_window);
- init_iterator (&it, menu_w, -1, -1, menu_w->desired_matrix->rows,
+ menu_window = XWINDOW (f->menu_bar_window);
+ init_iterator (&it, menu_window, -1, -1,
+ menu_window->desired_matrix->rows,
MENU_FACE_ID);
- it.first_visible_x = 0;
- it.last_visible_x = FRAME_PIXEL_WIDTH (f);
}
else
#endif /* not USE_X_TOOLKIT and not USE_GTK */
@@ -26587,8 +27010,61 @@ display_menu_bar (struct window *w)
/* Compute the total height of the lines. */
compute_line_metrics (&it);
+ it.glyph_row->full_width_p = true;
+ it.glyph_row->continued_p = false;
+ it.glyph_row->truncated_on_left_p = false;
+ it.glyph_row->truncated_on_right_p = false;
+
+ /* This will break the moment someone tries to add another window
+ system that uses the no toolkit menu bar. Oh well. At least
+ there will be an error, meaning he will correct the ifdef inside
+ which `face' is defined. */
+#if defined HAVE_WINDOW_SYSTEM && !defined HAVE_EXT_MENU_BAR
+ /* Make a 3D menu bar have a shadow at its right end. */
+ extend_face_to_end_of_line (&it);
+ if (face->box != FACE_NO_BOX)
+ {
+ struct glyph *last = (it.glyph_row->glyphs[TEXT_AREA]
+ + it.glyph_row->used[TEXT_AREA] - 1);
+ int box_thickness = face->box_vertical_line_width;
+ last->right_box_line_p = true;
+ /* Add back the space for the right box line we subtracted in
+ init_iterator, since the right_box_line_p flag will make the
+ glyph wider. We actually add only as much space as is
+ available for the last glyph of the menu bar and whatever
+ space is left beyond it, since that glyph could be only
+ partially visible. */
+ if (box_thickness > 0)
+ last->pixel_width += max (0, (box_thickness
+ - (it.current_x - it.last_visible_x)));
+ }
+
+ /* With the non-toolkit version, modify the menu bar window height
+ accordingly. */
+ if (FRAME_WINDOW_P (it.f) && menu_window)
+ {
+ struct glyph_row *row;
+ int delta_height;
+
+ row = it.glyph_row;
+ delta_height
+ = ((row->y + row->height)
+ - WINDOW_BOX_HEIGHT_NO_MODE_LINE (menu_window));
+
+ if (delta_height != 0)
+ {
+ FRAME_MENU_BAR_HEIGHT (it.f) += delta_height;
+ adjust_frame_size (it.f, -1, -1, 3, false, Qmenu_bar_lines);
+ }
+ }
+#endif
}
+/* This code is never used on Android where there are only GUI and
+ initial frames. */
+
+#ifndef HAVE_ANDROID
+
/* Deep copy of a glyph row, including the glyphs. */
static void
deep_copy_glyph_row (struct glyph_row *to, struct glyph_row *from)
@@ -26709,6 +27185,9 @@ display_tty_menu_item (const char *item_text, int width, int face_id,
row->full_width_p = saved_width;
row->reversed_p = saved_reversed;
}
+
+#endif
+
/***********************************************************************
Mode Line
@@ -26794,7 +27273,7 @@ display_mode_lines (struct window *w)
can reasonably tell whether a mouse click will select w. */
XSETWINDOW (window, w);
if (FUNCTIONP (default_help))
- wset_mode_line_help_echo (w, safe_call1 (default_help, window));
+ wset_mode_line_help_echo (w, dsafe_call1 (default_help, window));
else if (STRINGP (default_help))
wset_mode_line_help_echo (w, default_help);
else
@@ -27133,6 +27612,7 @@ display_mode_element (struct it *it, int depth, int field_width, int precision,
/* PROPS might cause set-text-properties to signal
an error, so we call it via internal_condition_case_n,
to avoid an infloop in redisplay due to the error. */
+ /* FIXME: Use 'SAFE_CALLMANY'? */
internal_condition_case_n (safe_set_text_properties,
4,
((Lisp_Object [])
@@ -27140,7 +27620,7 @@ display_mode_element (struct it *it, int depth, int field_width, int precision,
Flength (elt),
props,
elt}),
- Qt, safe_eval_handler);
+ Qt, dsafe_eval_handler);
/* Add this item to mode_line_proptrans_alist. */
mode_line_proptrans_alist
= Fcons (Fcons (elt, props),
@@ -27393,7 +27873,7 @@ display_mode_element (struct it *it, int depth, int field_width, int precision,
if (CONSP (XCDR (elt)))
{
Lisp_Object spec;
- spec = safe__eval (true, XCAR (XCDR (elt)));
+ spec = dsafe_eval (XCAR (XCDR (elt)));
/* The :eval form could delete the frame stored in the
iterator, which will cause a crash if we try to
access faces and other fields (e.g., FRAME_KBOARD)
@@ -27691,6 +28171,11 @@ are the selected window and the WINDOW's buffer). */)
init_iterator (&it, w, -1, -1, NULL, face_id);
+ /* Make sure `base_line_number` is fresh in case we encounter a `%l`. */
+ if (current_buffer == XBUFFER ((w)->contents)
+ && !BASE_LINE_NUMBER_VALID_P (w))
+ w->base_line_number = 0;
+
if (no_props)
{
mode_line_target = MODE_LINE_NOPROP;
@@ -27770,7 +28255,9 @@ static const char power_letter[] =
'P', /* peta */
'E', /* exa */
'Z', /* zetta */
- 'Y' /* yotta */
+ 'Y', /* yotta */
+ 'R', /* ronna */
+ 'Q' /* quetta */
};
static void
@@ -28141,30 +28628,29 @@ decode_mode_spec (struct window *w, register int c, int field_width,
when the buffer's restriction was changed, but the window
wasn't yet redisplayed after that. If that happens, we
need to determine a new base line. */
- if (!(BUF_BEGV_BYTE (b) <= startpos_byte
+ if (current_buffer != XBUFFER (w->contents)
+ || !(BUF_BEGV_BYTE (b) <= startpos_byte
&& startpos_byte <= BUF_ZV_BYTE (b)))
{
startpos = BUF_BEGV (b);
startpos_byte = BUF_BEGV_BYTE (b);
- w->base_line_pos = 0;
- w->base_line_number = 0;
}
/* If we decided that this buffer isn't suitable for line numbers,
- don't forget that too fast. */
+ don't forget that too fast.
+ FIXME: What if `current_buffer != w->contents`? */
if (w->base_line_pos == -1)
goto no_value;
/* If the buffer is very big, don't waste time. */
if (FIXNUMP (Vline_number_display_limit)
&& BUF_ZV (b) - BUF_BEGV (b) > XFIXNUM (Vline_number_display_limit))
- {
- w->base_line_pos = 0;
- w->base_line_number = 0;
- goto no_value;
- }
+ goto no_value;
- if (w->base_line_number > 0
+ /* Callers of `display_mode_element` are in charge of flushing
+ any stale `base_line_number` cache. */
+ if (current_buffer == XBUFFER ((w)->contents)
+ && w->base_line_number > 0
&& w->base_line_pos > 0
&& w->base_line_pos <= startpos)
{
@@ -28190,7 +28676,9 @@ decode_mode_spec (struct window *w, register int c, int field_width,
or too far away, or if we did not have one.
"Too close" means it's plausible a scroll-down would
go back past it. */
- if (startpos == BUF_BEGV (b))
+ if (current_buffer != XBUFFER (w->contents))
+ ; /* The base line is for another buffer, don't touch it! */
+ else if (startpos == BUF_BEGV (b))
{
w->base_line_number = topline;
w->base_line_pos = BUF_BEGV (b);
@@ -28203,9 +28691,8 @@ decode_mode_spec (struct window *w, register int c, int field_width,
ptrdiff_t position;
ptrdiff_t distance
= (line_number_display_limit_width < 0 ? 0
- : INT_MULTIPLY_WRAPV (line_number_display_limit_width,
- height * 2 + 30,
- &distance)
+ : ckd_mul (&distance, line_number_display_limit_width,
+ height * 2 + 30)
? PTRDIFF_MAX : distance);
if (startpos - distance > limit)
@@ -28228,6 +28715,12 @@ decode_mode_spec (struct window *w, register int c, int field_width,
goto no_value;
}
+ /* NOTE: if `clip_changed` is set or if `BEG_UNCHANGED` is
+ before `position`, this new cached value may get flushed
+ soon needlessly, because we can't reset `BEG_UNCHANGED` or
+ `clip_changed` from here (since they reflect the changes
+ since the last redisplay so they can only be reset from
+ `mark_window_display_accurate_1`). :-( */
w->base_line_number = topline - nlines;
w->base_line_pos = BYTE_TO_CHAR (position);
}
@@ -28364,7 +28857,7 @@ decode_mode_spec (struct window *w, register int c, int field_width,
Lisp_Object val = Qnil;
if (STRINGP (curdir))
- val = safe_call1 (intern ("file-remote-p"), curdir);
+ val = dsafe_call1 (intern ("file-remote-p"), curdir);
val = unbind_to (count, val);
@@ -28756,7 +29249,11 @@ display_string (const char *string, Lisp_Object lisp_string, Lisp_Object face_st
{
/* Add truncation mark, but don't do it if the line is
truncated at a padding space. */
- if (it_charpos < it->string_nchars)
+ /* Need to do the below for the last string character as
+ well, since it could be a double-width character, in
+ which case the previous character ends before
+ last_visible_x. Thus, comparison with <=, not <. */
+ if (it_charpos <= it->string_nchars)
{
if (!FRAME_WINDOW_P (it->f))
{
@@ -28764,6 +29261,18 @@ display_string (const char *string, Lisp_Object lisp_string, Lisp_Object face_st
if (it->current_x > it->last_visible_x)
{
+ /* This flag is true if we are displaying mode
+ line, false for header-line or tab-line. */
+ bool mode_line_p = false;
+
+ /* ROW->mode_line_p is true if we display mode
+ line or header-line or tab-line. */
+ if (row->mode_line_p)
+ {
+ struct window *w = it->w;
+ if (row == MATRIX_MODE_LINE_ROW (w->desired_matrix))
+ mode_line_p = true;
+ }
if (!row->reversed_p)
{
for (ii = row->used[TEXT_AREA] - 1; ii > 0; --ii)
@@ -28781,7 +29290,10 @@ display_string (const char *string, Lisp_Object lisp_string, Lisp_Object face_st
for (n = row->used[TEXT_AREA]; ii < n; ++ii)
{
row->used[TEXT_AREA] = ii;
- produce_special_glyphs (it, IT_TRUNCATION);
+ if (row->mode_line_p)
+ pad_mode_line (it, mode_line_p);
+ else
+ produce_special_glyphs (it, IT_TRUNCATION);
}
}
produce_special_glyphs (it, IT_TRUNCATION);
@@ -29016,7 +29528,9 @@ calc_pixel_width_or_height (double *res, struct it *it, Lisp_Object prop,
/* 'width': the width of FONT. */
if (EQ (prop, Qwidth))
return OK_PIXELS (font
- ? FONT_WIDTH (font)
+ ? (font->average_width
+ ? font->average_width
+ : font->space_width)
: FRAME_COLUMN_WIDTH (it->f));
#else
if (EQ (prop, Qheight) || EQ (prop, Qwidth))
@@ -29234,9 +29748,9 @@ dump_glyph_string (struct glyph_string *s)
# define ALLOCATE_HDC(hdc, f) \
Lisp_Object prev_quit = Vinhibit_quit; \
Vinhibit_quit = Qt; \
- HDC hdc = get_frame_dc ((f))
+ HDC hdc = get_frame_dc (f)
# define RELEASE_HDC(hdc, f) \
- release_frame_dc ((f), (hdc)); \
+ release_frame_dc (f, hdc); \
Vinhibit_quit = prev_quit
#else
# define ALLOCATE_HDC(hdc, f)
@@ -29355,9 +29869,9 @@ get_char_face_and_encoding (struct frame *f, int c, int face_id,
}
-/* Get face and two-byte form of character glyph GLYPH on frame F.
- The encoding of GLYPH->u.ch is returned in *CHAR2B. Value is
- a pointer to a realized face that is ready for display. */
+/* Get face glyph GLYPH on frame F, and if a character glyph, its
+ multi-byte character form in *CHAR2B. Value is a pointer to a
+ realized face that is ready for display. */
static struct face *
get_glyph_face_and_encoding (struct frame *f, struct glyph *glyph,
@@ -29366,25 +29880,28 @@ get_glyph_face_and_encoding (struct frame *f, struct glyph *glyph,
struct face *face;
unsigned code = 0;
- eassert (glyph->type == CHAR_GLYPH);
face = FACE_FROM_ID (f, glyph->face_id);
/* Make sure X resources of the face are allocated. */
prepare_face_for_display (f, face);
- if (face->font)
+ if (glyph->type == CHAR_GLYPH)
{
- if (CHAR_BYTE8_P (glyph->u.ch))
- code = CHAR_TO_BYTE8 (glyph->u.ch);
- else
- code = face->font->driver->encode_char (face->font, glyph->u.ch);
+ if (face->font)
+ {
+ if (CHAR_BYTE8_P (glyph->u.ch))
+ code = CHAR_TO_BYTE8 (glyph->u.ch);
+ else
+ code = face->font->driver->encode_char (face->font, glyph->u.ch);
- if (code == FONT_INVALID_CODE)
- code = 0;
+ if (code == FONT_INVALID_CODE)
+ code = 0;
+ }
+
+ /* Ensure that the code is only 2 bytes wide. */
+ *char2b = code & 0xFFFF;
}
- /* Ensure that the code is only 2 bytes wide. */
- *char2b = code & 0xFFFF;
return face;
}
@@ -29884,17 +30401,28 @@ normal_char_height (struct font *font, int c)
void
gui_get_glyph_overhangs (struct glyph *glyph, struct frame *f, int *left, int *right)
{
+ unsigned char2b;
+ struct face *face;
+
*left = *right = 0;
+ face = get_glyph_face_and_encoding (f, glyph, &char2b);
if (glyph->type == CHAR_GLYPH)
{
- unsigned char2b;
- struct face *face = get_glyph_face_and_encoding (f, glyph, &char2b);
if (face->font)
{
- struct font_metrics *pcm = get_per_char_metric (face->font, &char2b);
+ struct font_metrics *pcm
+ = get_per_char_metric (face->font, &char2b);
+
if (pcm)
{
+ /* Overstruck text is displayed twice, the second time
+ one pixel to the right. Increase the right-side
+ bearing to match. */
+
+ if (face->overstrike)
+ pcm->rbearing++;
+
if (pcm->rbearing > pcm->width)
*right = pcm->rbearing - pcm->width;
if (pcm->lbearing < 0)
@@ -29907,8 +30435,18 @@ gui_get_glyph_overhangs (struct glyph *glyph, struct frame *f, int *left, int *r
if (! glyph->u.cmp.automatic)
{
struct composition *cmp = composition_table[glyph->u.cmp.id];
+ int rbearing;
+
+ rbearing = cmp->rbearing;
+
+ /* Overstruck text is displayed twice, the second time one
+ pixel to the right. Increase the right-side bearing to
+ match. */
+
+ if (face->overstrike)
+ rbearing++;
- if (cmp->rbearing > cmp->pixel_width)
+ if (rbearing > cmp->pixel_width)
*right = cmp->rbearing - cmp->pixel_width;
if (cmp->lbearing < 0)
*left = - cmp->lbearing;
@@ -29920,6 +30458,14 @@ gui_get_glyph_overhangs (struct glyph *glyph, struct frame *f, int *left, int *r
composition_gstring_width (gstring, glyph->slice.cmp.from,
glyph->slice.cmp.to + 1, &metrics);
+
+ /* Overstruck text is displayed twice, the second time one
+ pixel to the right. Increase the right-side bearing to
+ match. */
+
+ if (face->overstrike)
+ metrics.rbearing++;
+
if (metrics.rbearing > metrics.width)
*right = metrics.rbearing - metrics.width;
if (metrics.lbearing < 0)
@@ -30633,6 +31179,26 @@ draw_glyphs (struct window *w, int x, struct glyph_row *row,
}
}
+#ifdef HAVE_RSVG
+ /* Update SVG image glyphs with mouse face features. FIXME: it
+ should be possible to have this behavior with transparent
+ background PNG. */
+ if (hl == DRAW_MOUSE_FACE)
+ {
+ Mouse_HLInfo *hlinfo = MOUSE_HL_INFO (f);
+ for (s = head; s; s = s->next)
+ if (s->first_glyph->type == IMAGE_GLYPH)
+ if (s->img
+ && (EQ (image_spec_value (s->img->spec, QCtype, NULL), Qsvg)))
+ {
+ ptrdiff_t id;
+ id = lookup_image (f, s->img->spec, hlinfo->mouse_face_face_id);
+ s->img = IMAGE_FROM_ID (f, id);
+ prepare_image_for_display (f, s->img);
+ }
+ }
+#endif
+
/* Draw all strings. */
for (s = head; s; s = s->next)
FRAME_RIF (f)->draw_glyph_string (s);
@@ -31008,9 +31574,16 @@ produce_image_glyph (struct it *it)
take_vertical_position_into_account (it);
- /* Automatically crop wide image glyphs at right edge so we can
- draw the cursor on same display row. */
- if ((crop = it->pixel_width - (it->last_visible_x - it->current_x), crop > 0)
+ /* Automatically crop wide image glyphs at right edge so we can draw
+ the cursor on same display row. But don't do that under
+ word-wrap, unless the image starts at column zero, because
+ wrapping correctly needs the real pixel width of the image. */
+ if ((it->line_wrap != WORD_WRAP
+ || it->hpos == 0
+ /* Always crop images larger than the window-width, minus 1 space. */
+ || it->pixel_width > it->last_visible_x - FRAME_COLUMN_WIDTH (it->f))
+ && (crop = it->pixel_width - (it->last_visible_x - it->current_x),
+ crop > 0)
&& (it->hpos == 0 || it->pixel_width > it->last_visible_x / 4))
{
it->pixel_width -= crop;
@@ -31607,6 +32180,38 @@ produce_special_glyphs (struct it *it, enum display_element_type what)
it->nglyphs = temp_it.nglyphs;
}
+/* Produce padding glyphs for mode/header/tab-line whose text needs to
+ be truncated. This is used when the last visible character leaves
+ one or more columns till the window edge, but the next character is
+ wider than that number of columns, and therefore cannot fit on the
+ line. We then replace these columns with the appropriate padding
+ character: '-' for the mode line and SPC for the other two. That's
+ because these lines should not show the usual truncation glyphs
+ there. This function is only used on TTY frames. */
+static void
+pad_mode_line (struct it *it, bool mode_line_p)
+{
+ struct it temp_it;
+ GLYPH glyph;
+
+ eassert (!FRAME_WINDOW_P (it->f));
+ temp_it = *it;
+ temp_it.object = Qnil;
+ memset (&temp_it.current, 0, sizeof temp_it.current);
+
+ SET_GLYPH (glyph, mode_line_p ? '-' : ' ', it->base_face_id);
+
+ temp_it.dp = NULL;
+ temp_it.what = IT_CHARACTER;
+ temp_it.c = temp_it.char_to_display = GLYPH_CHAR (glyph);
+ temp_it.face_id = GLYPH_FACE (glyph);
+ temp_it.len = CHAR_BYTES (temp_it.c);
+
+ PRODUCE_GLYPHS (&temp_it);
+ it->pixel_width = temp_it.pixel_width;
+ it->nglyphs = temp_it.nglyphs;
+}
+
#ifdef HAVE_WINDOW_SYSTEM
/* Calculate line-height and line-spacing properties.
@@ -31996,6 +32601,14 @@ gui_produce_glyphs (struct it *it)
if (get_char_glyph_code (it->char_to_display, font, &char2b))
{
pcm = get_per_char_metric (font, &char2b);
+
+ /* Overstruck text is displayed twice, the second time
+ one pixel to the right. Increase the right-side
+ bearing to match. */
+
+ if (pcm && face->overstrike)
+ pcm->rbearing++;
+
if (pcm->width == 0
&& pcm->rbearing == 0 && pcm->lbearing == 0)
pcm = NULL;
@@ -32201,7 +32814,19 @@ gui_produce_glyphs (struct it *it)
if (font->space_width > 0)
{
int tab_width = it->tab_width * font->space_width;
- int x = it->current_x + it->continuation_lines_width;
+ /* wrap-prefix strings are prepended to continuation
+ lines, so the width of tab characters inside should
+ be computed from the start of this screen line rather
+ than as a product of the total width of the physical
+ line being wrapped. */
+ int x = it->current_x + (it->string_from_prefix_prop_p
+ /* Subtract the width of the
+ prefix from it->current_x if
+ it exists. */
+ ? 0 : (it->continuation_lines_width
+ ? (it->continuation_lines_width
+ - it->wrap_prefix_width)
+ : 0));
int x0 = x;
/* Adjust for line numbers, if needed. */
if (!NILP (Vdisplay_line_numbers) && it->line_number_produced_p)
@@ -32388,6 +33013,13 @@ gui_produce_glyphs (struct it *it)
/* Initialize the bounding box. */
if (pcm)
{
+ /* Overstruck text is displayed twice, the second time
+ one pixel to the right. Increase the right-side
+ bearing to match. */
+
+ if (face->overstrike)
+ pcm->rbearing++;
+
width = cmp->glyph_len > 0 ? pcm->width : 0;
ascent = pcm->ascent;
descent = pcm->descent;
@@ -32449,6 +33081,13 @@ gui_produce_glyphs (struct it *it)
cmp->offsets[i * 2] = cmp->offsets[i * 2 + 1] = 0;
else
{
+ /* Overstruck text is displayed twice, the second
+ time one pixel to the right. Increase the
+ right-side bearing to match. */
+
+ if (face->overstrike)
+ pcm->rbearing++;
+
width = pcm->width;
ascent = pcm->ascent;
descent = pcm->descent;
@@ -32658,7 +33297,13 @@ gui_produce_glyphs (struct it *it)
because this isn't true for images with `:ascent 100'. */
eassert (it->ascent >= 0 && it->descent >= 0);
if (it->area == TEXT_AREA)
- it->current_x += it->pixel_width;
+ {
+ it->current_x += it->pixel_width;
+
+ if (it->continuation_lines_width
+ && it->string_from_prefix_prop_p)
+ it->wrap_prefix_width = it->current_x;
+ }
if (extra_line_spacing > 0)
{
@@ -33177,13 +33822,18 @@ notice_overwritten_cursor (struct window *w, enum glyph_row_area area,
void
gui_fix_overlapping_area (struct window *w, struct glyph_row *row,
- enum glyph_row_area area, int overlaps)
+ enum glyph_row_area area, int overlaps)
{
int i, x;
block_input ();
- x = 0;
+ /* row->x might be smaller than zero when produced from an iterator
+ under horizontal scrolling. Offset all measurements by this
+ basic value, lest hscrolled text with overlaps be displayed with
+ its overlapping portions misaligned. */
+ x = row->x;
+
for (i = 0; i < row->used[area];)
{
if (row->glyphs[area][i].overlaps_vertically_p)
@@ -33418,7 +34068,7 @@ display_and_set_cursor (struct window *w, bool on,
windows and frames; in the latter case, the frame or window may
be in the midst of changing its size, and x and y may be off the
window. */
- if (! FRAME_VISIBLE_P (f)
+ if (! FRAME_REDISPLAY_P (f)
|| vpos >= w->current_matrix->nrows
|| hpos >= w->current_matrix->matrix_w)
return;
@@ -33487,6 +34137,7 @@ display_and_set_cursor (struct window *w, bool on,
completely erased, to avoid the extra work of erasing the cursor
twice. In other words, phys_cursor_on_p can be true and the cursor
still not be visible, or it has only been partly erased. */
+
if (on)
{
w->phys_cursor_ascent = glyph_row->ascent;
@@ -33500,9 +34151,15 @@ display_and_set_cursor (struct window *w, bool on,
w->phys_cursor.vpos = vpos;
}
- FRAME_RIF (f)->draw_window_cursor (w, glyph_row, x, y,
- new_cursor_type, new_cursor_width,
- on, active_cursor);
+ /* If make_cursor_line_fully_visible is nil and the row is in fact
+ vscrolled out of the window, then glyph_row->y +
+ glyph_row->height will be less than or equal to 0. Eschew
+ displaying the cursor in that case. */
+
+ if (MATRIX_ROW_BOTTOM_Y (glyph_row) > 0)
+ FRAME_RIF (f)->draw_window_cursor (w, glyph_row, x, y,
+ new_cursor_type, new_cursor_width,
+ on, active_cursor);
}
@@ -33579,7 +34236,7 @@ gui_update_cursor (struct frame *f, bool on_p)
void
gui_clear_cursor (struct window *w)
{
- if (FRAME_VISIBLE_P (XFRAME (w->frame)) && w->phys_cursor_on_p)
+ if (FRAME_REDISPLAY_P (XFRAME (w->frame)) && w->phys_cursor_on_p)
update_window_cursor (w, false);
}
@@ -33600,7 +34257,9 @@ draw_row_with_mouse_face (struct window *w, int start_x, struct glyph_row *row,
}
#endif
+#ifndef HAVE_ANDROID
tty_draw_row_with_mouse_face (w, row, start_hpos, end_hpos, draw);
+#endif
}
/* Display the active region described by mouse_face_* according to DRAW. */
@@ -35091,7 +35750,8 @@ note_mouse_highlight (struct frame *f, int x, int y)
struct buffer *b;
/* When a menu is active, don't highlight because this looks odd. */
-#if defined (HAVE_X_WINDOWS) || defined (HAVE_NS) || defined (MSDOS)
+#if defined (HAVE_X_WINDOWS) || defined (HAVE_NS) || defined (MSDOS) \
+ || defined (HAVE_ANDROID)
if (popup_activated ())
return;
#endif
@@ -35113,7 +35773,7 @@ note_mouse_highlight (struct frame *f, int x, int y)
return;
/* Which window is that in? */
- window = window_from_coordinates (f, x, y, &part, true, true);
+ window = window_from_coordinates (f, x, y, &part, true, true, true);
/* If displaying active text in another window, clear that. */
if (! EQ (window, hlinfo->mouse_face_window)
@@ -35212,6 +35872,16 @@ note_mouse_highlight (struct frame *f, int x, int y)
w = XWINDOW (window);
frame_to_window_pixel_xy (w, &x, &y);
+#if defined (HAVE_WINDOW_SYSTEM) && ! defined (HAVE_EXT_MENU_BAR)
+ /* Handle menu-bar window differently since it doesn't display a
+ buffer. */
+ if (EQ (window, f->menu_bar_window))
+ {
+ cursor = FRAME_OUTPUT_DATA (f)->nontext_cursor;
+ goto set_cursor;
+ }
+#endif
+
#if defined (HAVE_WINDOW_SYSTEM)
/* Handle tab-bar window differently since it doesn't display a
buffer. */
@@ -35219,12 +35889,10 @@ note_mouse_highlight (struct frame *f, int x, int y)
{
note_tab_bar_highlight (f, x, y);
if (tab_bar__dragging_in_progress)
- {
cursor = FRAME_OUTPUT_DATA (f)->hand_cursor;
- goto set_cursor;
- }
else
- return;
+ cursor = FRAME_OUTPUT_DATA (f)->nontext_cursor;
+ goto set_cursor;
}
else
{
@@ -35242,7 +35910,8 @@ note_mouse_highlight (struct frame *f, int x, int y)
if (EQ (window, f->tool_bar_window))
{
note_tool_bar_highlight (f, x, y);
- return;
+ cursor = FRAME_OUTPUT_DATA (f)->nontext_cursor;
+ goto set_cursor;
}
#endif
@@ -35793,7 +36462,7 @@ expose_area (struct window *w, struct glyph_row *row, const Emacs_Rectangle *r,
/* Use a signed int intermediate value to avoid catastrophic
failures due to comparison between signed and unsigned, when
x is negative (can happen for wide images that are hscrolled). */
- int r_end = r->x + r->width;
+ int r_end = r->x + (int) r->width;
while (last < end && x < r_end)
{
x += last->pixel_width;
@@ -36092,7 +36761,7 @@ expose_window (struct window *w, const Emacs_Rectangle *fr)
/* Use a signed int intermediate value to avoid catastrophic
failures due to comparison between signed and unsigned, when
y0 or y1 is negative (can happen for tall images). */
- int r_bottom = r.y + r.height;
+ int r_bottom = r.y + (int) r.height;
/* We must temporarily switch to the window's buffer, in case
the fringe face has been remapped in that buffer's
@@ -36139,7 +36808,7 @@ expose_window (struct window *w, const Emacs_Rectangle *fr)
/* We must redraw a row overlapping the exposed area. */
if (y0 < r.y
? y0 + row->phys_height > r.y
- : y0 + row->ascent - row->phys_ascent < r.y +r.height)
+ : y0 + row->ascent - row->phys_ascent < r.y + (int) r.height)
{
if (first_overlapping_row == NULL)
first_overlapping_row = row;
@@ -36272,14 +36941,10 @@ expose_frame (struct frame *f, int x, int y, int w, int h)
|= expose_window (XWINDOW (f->tool_bar_window), &r);
#endif
-#ifdef HAVE_X_WINDOWS
-#ifndef MSDOS
-#if ! defined (USE_X_TOOLKIT) && ! defined (USE_GTK)
+#if defined HAVE_WINDOW_SYSTEM && !defined HAVE_EXT_MENU_BAR
if (WINDOWP (f->menu_bar_window))
mouse_face_overwritten_p
|= expose_window (XWINDOW (f->menu_bar_window), &r);
-#endif /* not USE_X_TOOLKIT and not USE_GTK */
-#endif
#endif
/* Some window managers support a focus-follows-mouse style with
@@ -36322,7 +36987,7 @@ gui_intersect_rectangles (const Emacs_Rectangle *r1, const Emacs_Rectangle *r2,
const Emacs_Rectangle *upper, *lower;
bool intersection_p = false;
- /* Rearrange so that R1 is the left-most rectangle. */
+ /* Rearrange so that left is the left-most rectangle. */
if (r1->x < r2->x)
left = r1, right = r2;
else
@@ -36330,13 +36995,14 @@ gui_intersect_rectangles (const Emacs_Rectangle *r1, const Emacs_Rectangle *r2,
/* X0 of the intersection is right.x0, if this is inside R1,
otherwise there is no intersection. */
- if (right->x <= left->x + left->width)
+ if (right->x <= left->x + (int) left->width)
{
result->x = right->x;
/* The right end of the intersection is the minimum of
the right ends of left and right. */
- result->width = (min (left->x + left->width, right->x + right->width)
+ result->width = (min (left->x + (int) left->width,
+ right->x + (int) right->width)
- result->x);
/* Same game for Y. */
@@ -36347,14 +37013,14 @@ gui_intersect_rectangles (const Emacs_Rectangle *r1, const Emacs_Rectangle *r2,
/* The upper end of the intersection is lower.y0, if this is inside
of upper. Otherwise, there is no intersection. */
- if (lower->y <= upper->y + upper->height)
+ if (lower->y <= upper->y + (int) upper->height)
{
result->y = lower->y;
/* The lower end of the intersection is the minimum of the lower
ends of upper and lower. */
- result->height = (min (lower->y + lower->height,
- upper->y + upper->height)
+ result->height = (min (lower->y + (int) lower->height,
+ upper->y + (int) upper->height)
- result->y);
intersection_p = true;
}
@@ -36363,6 +37029,55 @@ gui_intersect_rectangles (const Emacs_Rectangle *r1, const Emacs_Rectangle *r2,
return intersection_p;
}
+/* EXPORT:
+ Determine the union of the rectangles A and B. Return the smallest
+ rectangle encompassing both the bounds of A and B in *RESULT. It
+ is safe for all three arguments to point to each other. */
+
+void
+gui_union_rectangles (const Emacs_Rectangle *a, const Emacs_Rectangle *b,
+ Emacs_Rectangle *result)
+{
+ struct gui_box a_box, b_box, result_box;
+
+ /* Handle special cases where one of the rectangles is empty. */
+
+ if (!a->width || !a->height)
+ {
+ *result = *b;
+ return;
+ }
+ else if (!b->width || !b->height)
+ {
+ *result = *a;
+ return;
+ }
+
+ /* Convert A and B to boxes. */
+ a_box.x1 = a->x;
+ a_box.y1 = a->y;
+ a_box.x2 = a->x + a->width;
+ a_box.y2 = a->y + a->height;
+
+ b_box.x1 = b->x;
+ b_box.y1 = b->y;
+ b_box.x2 = b->x + b->width;
+ b_box.y2 = b->y + b->height;
+
+ /* Compute the union of the boxes. */
+ result_box.x1 = min (a_box.x1, b_box.x1);
+ result_box.y1 = min (a_box.y1, b_box.y1);
+ result_box.x2 = max (a_box.x2, b_box.x2);
+ result_box.y2 = max (a_box.y2, b_box.y2);
+
+ /* Convert result_box to an XRectangle and put the result in
+ RESULT. */
+ result->x = result_box.x1;
+ result->y = result_box.y1;
+ result->width = result_box.x2 - result_box.x1;
+ result->height = result_box.y2 - result_box.y1;
+}
+
#endif /* HAVE_WINDOW_SYSTEM */
@@ -37296,6 +38011,8 @@ cursor shapes. */);
DEFSYM (Qthin_space, "thin-space");
DEFSYM (Qzero_width, "zero-width");
+ DEFSYM (Qdebug_early__muted, "debug-early--muted");
+
DEFVAR_LISP ("pre-redisplay-function", Vpre_redisplay_function,
doc: /* Function run just before redisplay.
It is called with one argument, which is the set of windows that are to
@@ -37394,9 +38111,12 @@ may be more familiar to users. */);
display_raw_bytes_as_hex = false;
DEFVAR_BOOL ("mouse-fine-grained-tracking", mouse_fine_grained_tracking,
- doc: /* Non-nil for pixel-wise mouse-movement.
+ doc: /* Non-nil for pixelwise mouse-movement.
When nil, mouse-movement events will not be generated as long as the
-mouse stays within the extent of a single glyph (except for images). */);
+mouse stays within the extent of a single glyph (except for images).
+When nil and `mouse-prefer-closest-glyph' is non-nil, mouse-movement
+events will instead not be generated as long as the mouse stays within
+the extent of a single left/right half glyph (except for images). */);
mouse_fine_grained_tracking = false;
DEFVAR_BOOL ("tab-bar--dragging-in-progress", tab_bar__dragging_in_progress,
@@ -37441,13 +38161,13 @@ composed on display. */);
DEFVAR_INT ("max-redisplay-ticks", max_redisplay_ticks,
doc: /* Maximum number of redisplay ticks before aborting redisplay of a window.
-This allows to abort the display of a window if the amount of low-level
-redisplay operations exceeds the value of this variable. When display of
-a window is aborted due to this reason, the buffer shown in that window
-will not have its windows redisplayed until the buffer is modified or until
-you type \\[recenter-top-bottom] with one of its windows selected.
-You can also decide to kill the buffer and visit it in some
-other way, like under `so-long-mode' or literally.
+This enables aborting the display of a window if the amount of
+low-level redisplay operations exceeds the value of this variable.
+When display of a window is aborted due to this reason, the buffer
+shown in that window will not have its windows redisplayed until the
+buffer is modified or until you type \\[recenter-top-bottom] with one
+of its windows selected. You can also decide to kill the buffer and
+visit it in some other way, like under `so-long-mode' or literally.
The default value is zero, which disables this feature.
The recommended non-zero value is between 100000 and 1000000,
@@ -37478,7 +38198,7 @@ init_xdisp (void)
r->pixel_top = r->top_line * FRAME_LINE_HEIGHT (f);
r->total_cols = FRAME_COLS (f);
r->pixel_width = r->total_cols * FRAME_COLUMN_WIDTH (f);
- r->total_lines = FRAME_TOTAL_LINES (f) - 1 - FRAME_TOP_MARGIN (f);
+ r->total_lines = FRAME_TOTAL_LINES (f) - 1 - FRAME_MARGINS (f);
r->pixel_height = r->total_lines * FRAME_LINE_HEIGHT (f);
m->top_line = FRAME_TOTAL_LINES (f) - 1;
diff --git a/src/xfaces.c b/src/xfaces.c
index b820f6366a8..a558e7328c0 100644
--- a/src/xfaces.c
+++ b/src/xfaces.c
@@ -254,6 +254,10 @@ along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. */
#ifdef HAVE_HAIKU
#define GCGraphicsExposures 0
#endif /* HAVE_HAIKU */
+
+#ifdef HAVE_ANDROID
+#define GCGraphicsExposures 0
+#endif /* HAVE_ANDROID */
#endif /* HAVE_WINDOW_SYSTEM */
#include "buffer.h"
@@ -289,15 +293,15 @@ along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. */
/* True if face attribute ATTR is unspecified. */
-#define UNSPECIFIEDP(ATTR) EQ ((ATTR), Qunspecified)
+#define UNSPECIFIEDP(ATTR) EQ (ATTR, Qunspecified)
/* True if face attribute ATTR is `ignore-defface'. */
-#define IGNORE_DEFFACE_P(ATTR) EQ ((ATTR), QCignore_defface)
+#define IGNORE_DEFFACE_P(ATTR) EQ (ATTR, QCignore_defface)
/* True if face attribute ATTR is `reset'. */
-#define RESET_P(ATTR) EQ ((ATTR), Qreset)
+#define RESET_P(ATTR) EQ (ATTR, Qreset)
/* Size of hash table of realized faces in face caches (should be a
prime number). */
@@ -607,6 +611,39 @@ x_free_gc (struct frame *f, Emacs_GC *gc)
}
#endif /* HAVE_NS */
+#ifdef HAVE_ANDROID
+
+/* Android real GCs. */
+
+static struct android_gc *
+x_create_gc (struct frame *f, unsigned long value_mask,
+ Emacs_GC *xgcv)
+{
+ struct android_gc_values gcv;
+ unsigned long mask;
+
+ gcv.foreground = xgcv->foreground;
+ gcv.background = xgcv->background;
+
+ mask = 0;
+
+ if (value_mask & GCForeground)
+ mask |= ANDROID_GC_FOREGROUND;
+
+ if (value_mask & GCBackground)
+ mask |= ANDROID_GC_BACKGROUND;
+
+ return android_create_gc (mask, &gcv);
+}
+
+static void
+x_free_gc (struct frame *f, struct android_gc *gc)
+{
+ android_free_gc (gc);
+}
+
+#endif
+
/***********************************************************************
Frames and faces
***********************************************************************/
@@ -1575,7 +1612,7 @@ the face font sort order, see `face-font-selection-order'. */)
{
Lisp_Object font = AREF (vec, i);
int point = PIXEL_TO_POINT (XFIXNUM (AREF (font, FONT_SIZE_INDEX)) * 10,
- FRAME_RES_Y (f));
+ FRAME_RES (f));
Lisp_Object spacing = Ffont_get (font, QCspacing);
Lisp_Object v = CALLN (Fvector,
AREF (font, FONT_FAMILY_INDEX),
@@ -1592,7 +1629,7 @@ the face font sort order, see `face-font-selection-order'. */)
make_fixnum
(FONT_SPACING_PROPORTIONAL)))
? Qnil : Qt,
- Ffont_xlfd_name (font, Qnil),
+ Ffont_xlfd_name (font, Qnil, Qt),
AREF (font, FONT_REGISTRY_INDEX));
result = Fcons (v, result);
}
@@ -1701,7 +1738,7 @@ the WIDTH times as wide as FACE on FRAME. */)
ASET (font_entity, FONT_SIZE_INDEX,
AREF (font_spec, FONT_SIZE_INDEX));
}
- XSETCAR (tail, Ffont_xlfd_name (font_entity, Qnil));
+ XSETCAR (tail, Ffont_xlfd_name (font_entity, Qnil, Qt));
}
if (NILP (frame))
/* We don't have to check fontsets. */
@@ -1719,26 +1756,26 @@ the WIDTH times as wide as FACE on FRAME. */)
/* Access face attributes of face LFACE, a Lisp vector. */
-#define LFACE_FAMILY(LFACE) AREF ((LFACE), LFACE_FAMILY_INDEX)
-#define LFACE_FOUNDRY(LFACE) AREF ((LFACE), LFACE_FOUNDRY_INDEX)
-#define LFACE_HEIGHT(LFACE) AREF ((LFACE), LFACE_HEIGHT_INDEX)
-#define LFACE_WEIGHT(LFACE) AREF ((LFACE), LFACE_WEIGHT_INDEX)
-#define LFACE_SLANT(LFACE) AREF ((LFACE), LFACE_SLANT_INDEX)
-#define LFACE_UNDERLINE(LFACE) AREF ((LFACE), LFACE_UNDERLINE_INDEX)
-#define LFACE_INVERSE(LFACE) AREF ((LFACE), LFACE_INVERSE_INDEX)
-#define LFACE_FOREGROUND(LFACE) AREF ((LFACE), LFACE_FOREGROUND_INDEX)
-#define LFACE_BACKGROUND(LFACE) AREF ((LFACE), LFACE_BACKGROUND_INDEX)
-#define LFACE_STIPPLE(LFACE) AREF ((LFACE), LFACE_STIPPLE_INDEX)
-#define LFACE_SWIDTH(LFACE) AREF ((LFACE), LFACE_SWIDTH_INDEX)
-#define LFACE_OVERLINE(LFACE) AREF ((LFACE), LFACE_OVERLINE_INDEX)
-#define LFACE_STRIKE_THROUGH(LFACE) AREF ((LFACE), LFACE_STRIKE_THROUGH_INDEX)
-#define LFACE_BOX(LFACE) AREF ((LFACE), LFACE_BOX_INDEX)
-#define LFACE_FONT(LFACE) AREF ((LFACE), LFACE_FONT_INDEX)
-#define LFACE_INHERIT(LFACE) AREF ((LFACE), LFACE_INHERIT_INDEX)
-#define LFACE_FONTSET(LFACE) AREF ((LFACE), LFACE_FONTSET_INDEX)
-#define LFACE_EXTEND(LFACE) AREF ((LFACE), LFACE_EXTEND_INDEX)
+#define LFACE_FAMILY(LFACE) AREF (LFACE, LFACE_FAMILY_INDEX)
+#define LFACE_FOUNDRY(LFACE) AREF (LFACE, LFACE_FOUNDRY_INDEX)
+#define LFACE_HEIGHT(LFACE) AREF (LFACE, LFACE_HEIGHT_INDEX)
+#define LFACE_WEIGHT(LFACE) AREF (LFACE, LFACE_WEIGHT_INDEX)
+#define LFACE_SLANT(LFACE) AREF (LFACE, LFACE_SLANT_INDEX)
+#define LFACE_UNDERLINE(LFACE) AREF (LFACE, LFACE_UNDERLINE_INDEX)
+#define LFACE_INVERSE(LFACE) AREF (LFACE, LFACE_INVERSE_INDEX)
+#define LFACE_FOREGROUND(LFACE) AREF (LFACE, LFACE_FOREGROUND_INDEX)
+#define LFACE_BACKGROUND(LFACE) AREF (LFACE, LFACE_BACKGROUND_INDEX)
+#define LFACE_STIPPLE(LFACE) AREF (LFACE, LFACE_STIPPLE_INDEX)
+#define LFACE_SWIDTH(LFACE) AREF (LFACE, LFACE_SWIDTH_INDEX)
+#define LFACE_OVERLINE(LFACE) AREF (LFACE, LFACE_OVERLINE_INDEX)
+#define LFACE_STRIKE_THROUGH(LFACE) AREF (LFACE, LFACE_STRIKE_THROUGH_INDEX)
+#define LFACE_BOX(LFACE) AREF (LFACE, LFACE_BOX_INDEX)
+#define LFACE_FONT(LFACE) AREF (LFACE, LFACE_FONT_INDEX)
+#define LFACE_INHERIT(LFACE) AREF (LFACE, LFACE_INHERIT_INDEX)
+#define LFACE_FONTSET(LFACE) AREF (LFACE, LFACE_FONTSET_INDEX)
+#define LFACE_EXTEND(LFACE) AREF (LFACE, LFACE_EXTEND_INDEX)
#define LFACE_DISTANT_FOREGROUND(LFACE) \
- AREF ((LFACE), LFACE_DISTANT_FOREGROUND_INDEX)
+ AREF (LFACE, LFACE_DISTANT_FOREGROUND_INDEX)
/* True if LFACE is a Lisp face. A Lisp face is a vector of size
LFACE_VECTOR_SIZE which has the symbol `face' in slot 0. */
@@ -2136,7 +2173,7 @@ set_lface_from_font (struct frame *f, Lisp_Object lface,
if (force_p || UNSPECIFIEDP (LFACE_HEIGHT (lface)))
{
- int pt = PIXEL_TO_POINT (font->pixel_size * 10, FRAME_RES_Y (f));
+ int pt = PIXEL_TO_POINT (font->pixel_size * 10, FRAME_RES (f));
eassert (pt > 0);
ASET (lface, LFACE_HEIGHT_INDEX, make_fixnum (pt));
@@ -2195,7 +2232,7 @@ merge_face_heights (Lisp_Object from, Lisp_Object to, Lisp_Object invalid)
{
/* Call function with current height as argument.
From is the new height. */
- result = safe_call1 (from, to);
+ result = safe_calln (from, to);
/* Ensure that if TO was absolute, so is the result. */
if (FIXNUMP (to) && !FIXNUMP (result))
@@ -2208,20 +2245,20 @@ merge_face_heights (Lisp_Object from, Lisp_Object to, Lisp_Object invalid)
/* Merge two Lisp face attribute vectors on frame F, FROM and TO, and
store the resulting attributes in TO, which must be already be
- completely specified and contain only absolute attributes.
- Every specified attribute of FROM overrides the corresponding
- attribute of TO; relative attributes in FROM are merged with the
- absolute value in TO and replace it. NAMED_MERGE_POINTS is used
- internally to detect loops in face inheritance/remapping; it should
- be 0 when called from other places. If window W is non-NULL, use W
- to interpret face specifications. */
+ completely specified and contain only absolute attributes. Every
+ specified attribute of FROM overrides the corresponding attribute of
+ TO; merge relative attributes in FROM with the absolute value in TO,
+ which attributes also replace it. Use NAMED_MERGE_POINTS internally
+ to detect loops in face inheritance/remapping; it should be 0 when
+ called from other places. If window W is non-NULL, use W to
+ interpret face specifications. */
static void
merge_face_vectors (struct window *w,
struct frame *f, const Lisp_Object *from, Lisp_Object *to,
struct named_merge_point *named_merge_points)
{
int i;
- Lisp_Object font = Qnil;
+ Lisp_Object font = Qnil, tospec, adstyle;
/* If FROM inherits from some other faces, merge their attributes into
TO before merging FROM's direct attributes. Note that an :inherit
@@ -2281,6 +2318,25 @@ merge_face_vectors (struct window *w,
to[LFACE_SLANT_INDEX] = FONT_SLANT_FOR_FACE (font);
if (! NILP (AREF (font, FONT_WIDTH_INDEX)))
to[LFACE_SWIDTH_INDEX] = FONT_WIDTH_FOR_FACE (font);
+
+ if (!NILP (AREF (font, FONT_ADSTYLE_INDEX)))
+ {
+ /* If an adstyle is specified in FROM's font spec, create a
+ font spec for TO if none exists, and transfer the adstyle
+ there. */
+
+ tospec = to[LFACE_FONT_INDEX];
+ adstyle = AREF (font, FONT_ADSTYLE_INDEX);
+
+ if (!NILP (tospec))
+ tospec = copy_font_spec (tospec);
+ else
+ tospec = Ffont_spec (0, NULL);
+
+ to[LFACE_FONT_INDEX] = tospec;
+ ASET (tospec, FONT_ADSTYLE_INDEX, adstyle);
+ }
+
ASET (font, FONT_SIZE_INDEX, Qnil);
}
@@ -3334,12 +3390,13 @@ FRAME 0 means change the face on all frames, and change the default
if (!CONSP (tem))
break;
v = XCAR (tem);
- tem = XCDR (tem);
if (EQ (k, QCline_width))
{
- if ((!CONSP(v) || !FIXNUMP (XCAR (v)) || XFIXNUM (XCAR (v)) == 0
- || !FIXNUMP (XCDR (v)) || XFIXNUM (XCDR (v)) == 0)
+ if ((!CONSP(v)
+ || !FIXNUMP (XCAR (v))
+ || XFIXNUM (XCAR (v)) == 0
+ || !FIXNUMP (XCDR (v)) || XFIXNUM (XCDR (v)) == 0)
&& (!FIXNUMP (v) || XFIXNUM (v) == 0))
break;
}
@@ -3350,12 +3407,16 @@ FRAME 0 means change the face on all frames, and change the default
}
else if (EQ (k, QCstyle))
{
- if (!EQ (v, Qpressed_button) && !EQ (v, Qreleased_button)
- && !EQ(v, Qflat_button))
+ if (!NILP (v)
+ && !EQ (v, Qpressed_button)
+ && !EQ (v, Qreleased_button)
+ && !EQ (v, Qflat_button))
break;
}
else
break;
+
+ tem = XCDR (tem);
}
valid_p = NILP (tem);
@@ -3981,7 +4042,8 @@ x_update_menu_appearance (struct frame *f)
|| !UNSPECIFIEDP (LFACE_SLANT (lface))
|| !UNSPECIFIEDP (LFACE_HEIGHT (lface))))
{
- Lisp_Object xlfd = Ffont_xlfd_name (LFACE_FONT (lface), Qnil);
+ Lisp_Object xlfd = Ffont_xlfd_name (LFACE_FONT (lface), Qnil,
+ Qnil);
#ifdef USE_MOTIF
const char *suffix = "List";
bool motif = true;
@@ -6603,7 +6665,7 @@ face_at_buffer_position (struct window *w, ptrdiff_t pos,
/* Get the `face' or `mouse_face' text property at POS, and
determine the next position at which the property changes. */
prop = Fget_text_property (position, propname, w->contents);
- XSETFASTINT (limit1, (limit < endpos ? limit : endpos));
+ XSETFASTINT (limit1, min (limit, endpos));
end = Fnext_single_property_change (position, propname, w->contents, limit1);
if (FIXNUMP (end))
endpos = XFIXNUM (end);
@@ -6739,7 +6801,7 @@ face_for_overlay_string (struct window *w, ptrdiff_t pos,
/* Get the `face' or `mouse_face' text property at POS, and
determine the next position at which the property changes. */
prop = Fget_text_property (position, propname, w->contents);
- XSETFASTINT (limit1, (limit < endpos ? limit : endpos));
+ XSETFASTINT (limit1, min (limit, endpos));
end = Fnext_single_property_change (position, propname, w->contents, limit1);
if (FIXNUMP (end))
endpos = XFIXNUM (end);
@@ -6952,20 +7014,22 @@ where R,G,B are numbers between 0 and 255 and name is an arbitrary string. */)
int num;
while (fgets (buf, sizeof (buf), fp) != NULL)
- if (sscanf (buf, "%d %d %d %n", &red, &green, &blue, &num) == 3)
- {
+ {
+ if (sscanf (buf, "%d %d %d %n", &red, &green, &blue, &num) == 3)
+ {
#ifdef HAVE_NTGUI
- int color = RGB (red, green, blue);
+ int color = RGB (red, green, blue);
#else
- int color = (red << 16) | (green << 8) | blue;
+ int color = (red << 16) | (green << 8) | blue;
#endif
- char *name = buf + num;
- ptrdiff_t len = strlen (name);
- len -= 0 < len && name[len - 1] == '\n';
- cmap = Fcons (Fcons (make_string (name, len), make_fixnum (color)),
- cmap);
- }
- fclose (fp);
+ char *name = buf + num;
+ ptrdiff_t len = strlen (name);
+ len -= 0 < len && name[len - 1] == '\n';
+ cmap = Fcons (Fcons (make_string (name, len), make_fixnum (color)),
+ cmap);
+ }
+ }
+ emacs_fclose (fp);
}
unblock_input ();
return cmap;
@@ -7288,8 +7352,7 @@ only for this purpose. */);
doc: /* Hash table of global face definitions (for internal use only.) */);
Vface_new_frame_defaults =
/* 33 entries is enough to fit all basic faces */
- make_hash_table (hashtest_eq, 33, DEFAULT_REHASH_SIZE,
- DEFAULT_REHASH_THRESHOLD, Qnil, false);
+ make_hash_table (&hashtest_eq, 33, Weak_None, false);
DEFVAR_LISP ("face-default-stipple", Vface_default_stipple,
doc: /* Default stipple pattern used on monochrome displays.
diff --git a/src/xfns.c b/src/xfns.c
index 5a618908be1..d610c839bfc 100644
--- a/src/xfns.c
+++ b/src/xfns.c
@@ -37,13 +37,16 @@ along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. */
#include "termhooks.h"
#include "font.h"
+#ifdef HAVE_X_I18N
+#include "textconv.h"
+#endif
+
#include <sys/types.h>
#include <sys/stat.h>
#ifdef USE_XCB
#include <xcb/xcb.h>
#include <xcb/xproto.h>
-#include <xcb/xcb_aux.h>
#endif
#include "bitmaps/gray.xbm"
@@ -804,23 +807,45 @@ x_set_tool_bar_position (struct frame *f,
Lisp_Object new_value,
Lisp_Object old_value)
{
- Lisp_Object choice = list4 (Qleft, Qright, Qtop, Qbottom);
+#ifdef USE_GTK
+ Lisp_Object choice;
+
+ choice = list4 (Qleft, Qright, Qtop, Qbottom);
if (!NILP (Fmemq (new_value, choice)))
{
-#ifdef USE_GTK
if (!EQ (new_value, old_value))
{
xg_change_toolbar_position (f, new_value);
fset_tool_bar_position (f, new_value);
}
-#else
- if (!EQ (new_value, Qtop))
- error ("The only supported tool bar position is top");
-#endif
+#else /* !USE_GTK */
+ if (!EQ (new_value, Qtop) && !EQ (new_value, Qbottom))
+ error ("Tool bar position must be either `top' or `bottom'");
+
+ if (EQ (new_value, old_value))
+ return;
+
+ /* Set the tool bar position. */
+ fset_tool_bar_position (f, new_value);
+
+ /* Now reconfigure frame glyphs to place the tool bar at the
+ bottom. While the inner height has not changed, call
+ `resize_frame_windows' to place each of the windows at its
+ new position. */
+
+ adjust_frame_size (f, -1, -1, 3, false, Qtool_bar_position);
+ adjust_frame_glyphs (f);
+ SET_FRAME_GARBAGED (f);
+
+ if (FRAME_X_WINDOW (f))
+ x_clear_under_internal_border (f);
+#endif /* USE_GTK */
+#ifdef USE_GTK
}
else
wrong_choice (choice, new_value);
+#endif /* USE_GTK */
}
#ifdef HAVE_XDBE
@@ -1368,7 +1393,7 @@ x_set_mouse_color (struct frame *f, Lisp_Object arg, Lisp_Object oldval)
XCreateFontCursor is not a request that waits for a reply,
and as such can return IDs that will not actually be used by
the server. */
- x_ignore_errors_for_next_request (FRAME_DISPLAY_INFO (f));
+ x_ignore_errors_for_next_request (FRAME_DISPLAY_INFO (f), 0);
/* Free any successfully created cursors. */
for (i = 0; i < mouse_cursor_max; i++)
@@ -1767,6 +1792,11 @@ x_change_tab_bar_height (struct frame *f, int height)
leading to the tab bar height being incorrectly set upon the next
call to x_set_font. (bug#59285) */
int lines = height / unit;
+
+ /* Even so, HEIGHT might be less than unit if the tab bar face is
+ not so tall as the frame's font height; which if true lines will
+ be set to 0 and the tab bar will thus vanish. */
+
if (lines == 0 && height != 0)
lines = 1;
@@ -2643,12 +2673,18 @@ append_wm_protocols (struct x_display_info *dpyinfo,
if (existing)
XFree (existing);
- if (!found_wm_ping)
- protos[num_protos++] = dpyinfo->Xatom_net_wm_ping;
+ if (!dpyinfo->untrusted)
+ {
+ /* Untrusted clients cannot use these protocols which require
+ communicating with the window manager. */
+
+ if (!found_wm_ping)
+ protos[num_protos++] = dpyinfo->Xatom_net_wm_ping;
#if !defined HAVE_GTK3 && defined HAVE_XSYNC
- if (!found_wm_sync_request && dpyinfo->xsync_supported_p)
- protos[num_protos++] = dpyinfo->Xatom_net_wm_sync_request;
+ if (!found_wm_sync_request && dpyinfo->xsync_supported_p)
+ protos[num_protos++] = dpyinfo->Xatom_net_wm_sync_request;
#endif
+ }
if (num_protos)
XChangeProperty (dpyinfo->display,
@@ -2666,24 +2702,50 @@ append_wm_protocols (struct x_display_info *dpyinfo,
#ifdef HAVE_X_I18N
-static void xic_preedit_draw_callback (XIC, XPointer, XIMPreeditDrawCallbackStruct *);
-static void xic_preedit_caret_callback (XIC, XPointer, XIMPreeditCaretCallbackStruct *);
+static void xic_preedit_draw_callback (XIC, XPointer,
+ XIMPreeditDrawCallbackStruct *);
+static void xic_preedit_caret_callback (XIC, XPointer,
+ XIMPreeditCaretCallbackStruct *);
static void xic_preedit_done_callback (XIC, XPointer, XPointer);
static int xic_preedit_start_callback (XIC, XPointer, XPointer);
+static void xic_string_conversion_callback (XIC, XPointer,
+ XIMStringConversionCallbackStruct *);
#ifndef HAVE_XICCALLBACK_CALLBACK
#define XICCallback XIMCallback
#define XICProc XIMProc
#endif
-static XIMCallback Xxic_preedit_draw_callback = { NULL,
- (XIMProc) xic_preedit_draw_callback };
-static XIMCallback Xxic_preedit_caret_callback = { NULL,
- (XIMProc) xic_preedit_caret_callback };
-static XIMCallback Xxic_preedit_done_callback = { NULL,
- (XIMProc) xic_preedit_done_callback };
-static XICCallback Xxic_preedit_start_callback = { NULL,
- (XICProc) xic_preedit_start_callback };
+static XIMCallback Xxic_preedit_draw_callback =
+ {
+ NULL,
+ (XIMProc) xic_preedit_draw_callback,
+ };
+
+static XIMCallback Xxic_preedit_caret_callback =
+ {
+ NULL,
+ (XIMProc) xic_preedit_caret_callback,
+ };
+
+static XIMCallback Xxic_preedit_done_callback =
+ {
+ NULL,
+ (XIMProc) xic_preedit_done_callback,
+ };
+
+static XICCallback Xxic_preedit_start_callback =
+ {
+ NULL,
+ (XICProc) xic_preedit_start_callback,
+ };
+
+static XIMCallback Xxic_string_conversion_callback =
+ {
+ /* This is actually an XICCallback! */
+ NULL,
+ (XIMProc) xic_string_conversion_callback,
+ };
#if defined HAVE_X_WINDOWS && defined USE_X_TOOLKIT
/* Create an X fontset on frame F with base font name BASE_FONTNAME. */
@@ -3089,6 +3151,8 @@ create_frame_xic (struct frame *f)
XNFocusWindow, FRAME_X_WINDOW (f),
XNStatusAttributes, status_attr,
XNPreeditAttributes, preedit_attr,
+ XNStringConversionCallback,
+ &Xxic_string_conversion_callback,
NULL);
else if (preedit_attr)
xic = XCreateIC (xim,
@@ -3096,6 +3160,8 @@ create_frame_xic (struct frame *f)
XNClientWindow, FRAME_X_WINDOW (f),
XNFocusWindow, FRAME_X_WINDOW (f),
XNPreeditAttributes, preedit_attr,
+ XNStringConversionCallback,
+ &Xxic_string_conversion_callback,
NULL);
else if (status_attr)
xic = XCreateIC (xim,
@@ -3103,12 +3169,16 @@ create_frame_xic (struct frame *f)
XNClientWindow, FRAME_X_WINDOW (f),
XNFocusWindow, FRAME_X_WINDOW (f),
XNStatusAttributes, status_attr,
+ XNStringConversionCallback,
+ &Xxic_string_conversion_callback,
NULL);
else
xic = XCreateIC (xim,
XNInputStyle, xic_style,
XNClientWindow, FRAME_X_WINDOW (f),
XNFocusWindow, FRAME_X_WINDOW (f),
+ XNStringConversionCallback,
+ &Xxic_string_conversion_callback,
NULL);
if (!xic)
@@ -3372,6 +3442,7 @@ struct x_xim_text_conversion_data
struct coding_system *coding;
char *source;
struct x_display_info *dpyinfo;
+ size_t size;
};
static Lisp_Object
@@ -3407,6 +3478,38 @@ x_xim_text_to_utf8_unix_1 (ptrdiff_t nargs, Lisp_Object *args)
}
static Lisp_Object
+x_encode_xim_text_1 (ptrdiff_t nargs, Lisp_Object *args)
+{
+ struct x_xim_text_conversion_data *data;
+ ptrdiff_t nbytes;
+ Lisp_Object coding_system;
+
+ data = xmint_pointer (args[0]);
+
+ if (SYMBOLP (Vx_input_coding_system))
+ coding_system = Vx_input_coding_system;
+ else if (!NILP (data->dpyinfo->xim_coding))
+ coding_system = data->dpyinfo->xim_coding;
+ else
+ coding_system = Vlocale_coding_system;
+
+ nbytes = data->size;
+
+ data->coding->destination = NULL;
+
+ setup_coding_system (coding_system, data->coding);
+ data->coding->mode |= (CODING_MODE_LAST_BLOCK
+ | CODING_MODE_SAFE_ENCODING);
+ data->coding->source = (const unsigned char *) data->source;
+ data->coding->dst_bytes = 2048;
+ data->coding->destination = xmalloc (2048);
+ encode_coding_object (data->coding, Qnil, 0, 0,
+ nbytes, nbytes, Qnil);
+
+ return Qnil;
+}
+
+static Lisp_Object
x_xim_text_to_utf8_unix_2 (Lisp_Object val, ptrdiff_t nargs,
Lisp_Object *args)
{
@@ -3463,6 +3566,46 @@ x_xim_text_to_utf8_unix (struct x_display_info *dpyinfo,
return (char *) coding.destination;
}
+/* Convert SIZE bytes of the specified text from Emacs's internal
+ coding system to the input method coding system. Return the
+ result, its byte length in *LENGTH, and its character length in
+ *CHARS, or NULL.
+
+ The string returned is not NULL terminated. */
+
+static char *
+x_encode_xim_text (struct x_display_info *dpyinfo, char *text,
+ size_t size, ptrdiff_t *length,
+ ptrdiff_t *chars)
+{
+ struct coding_system coding;
+ struct x_xim_text_conversion_data data;
+ Lisp_Object arg;
+ bool was_waiting_for_input_p;
+
+ data.coding = &coding;
+ data.source = text;
+ data.dpyinfo = dpyinfo;
+ data.size = size;
+
+ was_waiting_for_input_p = waiting_for_input;
+ /* Otherwise Fsignal will crash. */
+ waiting_for_input = false;
+
+ arg = make_mint_ptr (&data);
+ internal_condition_case_n (x_encode_xim_text_1, 1, &arg,
+ Qt, x_xim_text_to_utf8_unix_2);
+ waiting_for_input = was_waiting_for_input_p;
+
+ if (length)
+ *length = coding.produced;
+
+ if (chars)
+ *chars = coding.produced_char;
+
+ return (char *) coding.destination;
+}
+
static void
xic_preedit_draw_callback (XIC xic, XPointer client_data,
XIMPreeditDrawCallbackStruct *call_data)
@@ -3659,6 +3802,128 @@ xic_set_xfontset (struct frame *f, const char *base_fontname)
FRAME_XIC_FONTSET (f) = xfs;
}
+
+
+/* String conversion support. See textconv.c for more details. */
+
+static void
+xic_string_conversion_callback (XIC ic, XPointer client_data,
+ XIMStringConversionCallbackStruct *call_data)
+{
+ struct textconv_callback_struct request;
+ ptrdiff_t length;
+ struct frame *f;
+ int rc;
+
+ /* Find the frame associated with this IC. */
+ f = x_xic_to_frame (ic);
+
+ if (!f)
+ goto failure;
+
+ /* Fill in CALL_DATA as early as possible. */
+ call_data->text->feedback = NULL;
+ call_data->text->encoding_is_wchar = False;
+
+ /* Now translate the conversion request to the format understood by
+ textconv.c. */
+ request.position = call_data->position;
+
+ switch (call_data->direction)
+ {
+ case XIMForwardChar:
+ request.direction = TEXTCONV_FORWARD_CHAR;
+ break;
+
+ case XIMBackwardChar:
+ request.direction = TEXTCONV_BACKWARD_CHAR;
+ break;
+
+ case XIMForwardWord:
+ request.direction = TEXTCONV_FORWARD_WORD;
+ break;
+
+ case XIMBackwardWord:
+ request.direction = TEXTCONV_BACKWARD_WORD;
+ break;
+
+ case XIMCaretUp:
+ request.direction = TEXTCONV_CARET_UP;
+ break;
+
+ case XIMCaretDown:
+ request.direction = TEXTCONV_CARET_DOWN;
+ break;
+
+ case XIMNextLine:
+ request.direction = TEXTCONV_NEXT_LINE;
+ break;
+
+ case XIMPreviousLine:
+ request.direction = TEXTCONV_PREVIOUS_LINE;
+ break;
+
+ case XIMLineStart:
+ request.direction = TEXTCONV_LINE_START;
+ break;
+
+ case XIMLineEnd:
+ request.direction = TEXTCONV_LINE_END;
+ break;
+
+ case XIMAbsolutePosition:
+ request.direction = TEXTCONV_ABSOLUTE_POSITION;
+ break;
+
+ default:
+ goto failure;
+ }
+
+ /* factor is signed in call_data but is actually a CARD16. */
+ request.factor = call_data->factor;
+
+ if (call_data->operation == XIMStringConversionSubstitution)
+ request.operation = TEXTCONV_SUBSTITUTION;
+ else
+ request.operation = TEXTCONV_RETRIEVAL;
+
+ /* Now perform the string conversion. */
+ rc = textconv_query (f, &request, 0);
+
+ if (rc)
+ {
+ xfree (request.text.text);
+ goto failure;
+ }
+
+ /* Encode the text in the locale coding system and give it back to
+ the input method. */
+ request.text.text = NULL;
+ call_data->text->string.mbs
+ = x_encode_xim_text (FRAME_DISPLAY_INFO (f),
+ request.text.text,
+ request.text.bytes, NULL,
+ &length);
+ call_data->text->length = length;
+
+ /* Free the encoded text. This is always set to something
+ valid. */
+ xfree (request.text.text);
+
+ /* Detect failure. */
+ if (!call_data->text->string.mbs)
+ goto failure;
+
+ return;
+
+ failure:
+ /* Return a string of length 0 using the C library malloc. This
+ assumes XFree is able to free data allocated with our malloc
+ wrapper. */
+ call_data->text->length = 0;
+ call_data->text->string.mbs = malloc (0);
+}
+
#endif /* HAVE_X_I18N */
@@ -3761,6 +4026,7 @@ initial_set_up_x_back_buffer (struct frame *f)
}
#if defined HAVE_XINPUT2
+
static void
setup_xi_event_mask (struct frame *f)
{
@@ -3776,7 +4042,7 @@ setup_xi_event_mask (struct frame *f)
selected->mask = ((unsigned char *) selected) + sizeof *selected;
selected->mask_len = l;
selected->deviceid = XIAllMasterDevices;
-#endif
+#endif /* !HAVE_XINPUT2_1 */
mask.mask = m = alloca (l);
memset (m, 0, l);
@@ -3796,16 +4062,27 @@ setup_xi_event_mask (struct frame *f)
XISetMask (m, XI_FocusOut);
XISetMask (m, XI_KeyPress);
XISetMask (m, XI_KeyRelease);
-#endif
- XISelectEvents (FRAME_X_DISPLAY (f),
- FRAME_X_WINDOW (f),
+#endif /* !USE_GTK */
+#if defined HAVE_XINPUT2_4
+ if (FRAME_DISPLAY_INFO (f)->xi2_version >= 4)
+ {
+ /* Select for gesture events. Since this configuration doesn't
+ use GTK 3, Emacs is the only code that can change the XI
+ event mask, and can safely select for gesture events on
+ master pointers only. */
+ XISetMask (m, XI_GesturePinchBegin);
+ XISetMask (m, XI_GesturePinchUpdate);
+ XISetMask (m, XI_GesturePinchEnd);
+ }
+#endif /* HAVE_XINPUT2_4 */
+ XISelectEvents (FRAME_X_DISPLAY (f), FRAME_X_WINDOW (f),
&mask, 1);
/* Fortunately `xi_masks' isn't used on GTK 3, where we really have
to get the event mask from the X server. */
#ifndef HAVE_XINPUT2_1
memcpy (selected->mask, m, l);
-#endif
+#endif /* !HAVE_XINPUT2_1 */
memset (m, 0, l);
#endif /* !HAVE_GTK3 */
@@ -3813,45 +4090,54 @@ setup_xi_event_mask (struct frame *f)
#ifdef USE_X_TOOLKIT
XISetMask (m, XI_KeyPress);
XISetMask (m, XI_KeyRelease);
- XISetMask (m, XI_FocusIn);
- XISetMask (m, XI_FocusOut);
- XISelectEvents (FRAME_X_DISPLAY (f),
- FRAME_OUTER_WINDOW (f),
+ XISelectEvents (FRAME_X_DISPLAY (f), FRAME_OUTER_WINDOW (f),
&mask, 1);
memset (m, 0, l);
-#endif
+#endif /* USE_X_TOOLKIT */
#ifdef HAVE_XINPUT2_2
if (FRAME_DISPLAY_INFO (f)->xi2_version >= 2)
{
+ /* Select for touch events from all devices.
+
+ Emacs will only process touch events originating
+ from slave devices, as master pointers may also
+ represent dependent touch devices. */
mask.deviceid = XIAllDevices;
XISetMask (m, XI_TouchBegin);
XISetMask (m, XI_TouchUpdate);
XISetMask (m, XI_TouchEnd);
-#ifdef HAVE_XINPUT2_4
+ XISetMask (m, XI_TouchOwnership);
+
+#if defined HAVE_XINPUT2_4 && defined USE_GTK3
if (FRAME_DISPLAY_INFO (f)->xi2_version >= 4)
{
+ /* Now select for gesture events from all pointer devices.
+ Emacs will only handle gesture events from the master
+ pointer, but cannot afford to overwrite the event mask
+ set by GDK. */
+
XISetMask (m, XI_GesturePinchBegin);
XISetMask (m, XI_GesturePinchUpdate);
XISetMask (m, XI_GesturePinchEnd);
}
-#endif
+#endif /* HAVE_XINPUT2_4 && USE_GTK3 */
- XISelectEvents (FRAME_X_DISPLAY (f),
- FRAME_X_WINDOW (f),
+ XISelectEvents (FRAME_X_DISPLAY (f), FRAME_X_WINDOW (f),
&mask, 1);
}
-#endif
+#endif /* HAVE_XINPUT2_2 */
#ifndef HAVE_XINPUT2_1
FRAME_X_OUTPUT (f)->xi_masks = selected;
FRAME_X_OUTPUT (f)->num_xi_masks = 1;
-#endif
+#endif /* HAVE_XINPUT2_1 */
unblock_input ();
}
+
#endif
#ifdef USE_X_TOOLKIT
@@ -4014,9 +4300,9 @@ x_window (struct frame *f, long window_prompting)
#ifdef HAVE_X_I18N
FRAME_XIC (f) = NULL;
- if (use_xim)
+ if (FRAME_DISPLAY_INFO (f)->use_xim)
create_frame_xic (f);
-#endif
+#endif /* HAVE_X_I18N */
f->output_data.x->wm_hints.input = True;
f->output_data.x->wm_hints.flags |= InputHint;
@@ -4117,32 +4403,32 @@ x_window (struct frame *f)
#ifdef HAVE_X_I18N
FRAME_XIC (f) = NULL;
- if (use_xim)
- {
- block_input ();
- create_frame_xic (f);
- if (FRAME_XIC (f))
- {
- /* XIM server might require some X events. */
- unsigned long fevent = NoEventMask;
- XGetICValues (FRAME_XIC (f), XNFilterEvents, &fevent, NULL);
+ if (FRAME_DISPLAY_INFO (f)->use_xim)
+ {
+ block_input ();
+ create_frame_xic (f);
+ if (FRAME_XIC (f))
+ {
+ /* XIM server might require some X events. */
+ unsigned long fevent = NoEventMask;
+ XGetICValues (FRAME_XIC (f), XNFilterEvents, &fevent, NULL);
- if (fevent != NoEventMask)
- {
- XSetWindowAttributes attributes;
- XWindowAttributes wattr;
- unsigned long attribute_mask;
-
- XGetWindowAttributes (FRAME_X_DISPLAY (f), FRAME_X_WINDOW (f),
- &wattr);
- attributes.event_mask = wattr.your_event_mask | fevent;
- attribute_mask = CWEventMask;
- XChangeWindowAttributes (FRAME_X_DISPLAY (f), FRAME_X_WINDOW (f),
- attribute_mask, &attributes);
- }
- }
- unblock_input ();
- }
+ if (fevent != NoEventMask)
+ {
+ XSetWindowAttributes attributes;
+ XWindowAttributes wattr;
+ unsigned long attribute_mask;
+
+ XGetWindowAttributes (FRAME_X_DISPLAY (f), FRAME_X_WINDOW (f),
+ &wattr);
+ attributes.event_mask = wattr.your_event_mask | fevent;
+ attribute_mask = CWEventMask;
+ XChangeWindowAttributes (FRAME_X_DISPLAY (f), FRAME_X_WINDOW (f),
+ attribute_mask, &attributes);
+ }
+ }
+ unblock_input ();
+ }
#endif
append_wm_protocols (FRAME_DISPLAY_INFO (f), f);
@@ -4189,7 +4475,7 @@ x_window (struct frame *f)
initial_set_up_x_back_buffer (f);
#ifdef HAVE_X_I18N
- if (use_xim)
+ if (FRAME_DISPLAY_INFO (f)->use_xim)
{
create_frame_xic (f);
if (FRAME_XIC (f))
@@ -4736,6 +5022,7 @@ This function is an internal primitive--use `make-frame' instead. */)
#endif /* USE_LUCID && USE_TOOLKIT_SCROLL_BARS */
f->output_data.x->white_relief.pixel = -1;
f->output_data.x->black_relief.pixel = -1;
+ f->output_data.x->visibility_state = VisibilityFullyObscured;
fset_icon_name (f, gui_display_get_arg (dpyinfo,
parms,
@@ -5445,6 +5732,8 @@ that operating systems cannot be developed and distributed noncommercially.)
The optional argument TERMINAL specifies which display to ask about.
For GNU and Unix systems, this queries the X server software.
+For Android systems, value is the manufacturer who developed the Android
+system that is being used.
For MS Windows and Nextstep the result is hard-coded.
TERMINAL should be a terminal object, a frame or a display name (a string).
@@ -5468,7 +5757,8 @@ Protocol used on TERMINAL and the 3rd number is the distributor-specific
release number. For MS Windows, the 3 numbers report the OS major and
minor version and build number. For Nextstep, the first 2 numbers are
hard-coded and the 3rd represents the OS version. For Haiku, all 3
-numbers are hard-coded.
+numbers are hard-coded. For Android, the first number represents the
+Android API level, and the next two numbers are all zero.
See also the function `x-server-vendor'.
@@ -5734,13 +6024,13 @@ x_get_net_workarea (struct x_display_info *dpyinfo, XRectangle *rect)
= 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);
+ XA_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);
+ XA_CARDINAL, 0, UINT32_MAX);
reply = xcb_get_property_reply (dpyinfo->xcb_connection,
current_desktop_cookie, &error);
@@ -5751,7 +6041,7 @@ x_get_net_workarea (struct x_display_info *dpyinfo, XRectangle *rect)
else
{
if (xcb_get_property_value_length (reply) != 4
- || reply->type != XCB_ATOM_CARDINAL || reply->format != 32)
+ || reply->type != XA_CARDINAL || reply->format != 32)
rc = false;
else
current_workspace = *(uint32_t *) xcb_get_property_value (reply);
@@ -5766,7 +6056,7 @@ x_get_net_workarea (struct x_display_info *dpyinfo, XRectangle *rect)
free (error), rc = false;
else
{
- if (rc && reply->type == XCB_ATOM_CARDINAL && reply->format == 32
+ if (rc && reply->type == XA_CARDINAL && reply->format == 32
&& (xcb_get_property_value_length (reply) / sizeof (uint32_t)
>= current_workspace + 4))
{
@@ -6445,10 +6735,11 @@ Internal use only, use `display-monitor-attributes-list' instead. */)
}
/* Return geometric attributes of FRAME. According to the value of
- ATTRIBUTES return the outer edges of FRAME (Qouter_edges), the native
- edges of FRAME (Qnative_edges), or the inner edges of frame
+ ATTRIBUTES return the outer edges of FRAME (Qouter_edges), the
+ native edges of FRAME (Qnative_edges), or the inner edges of frame
(Qinner_edges). Any other value means to return the geometry as
returned by Fx_frame_geometry. */
+
static Lisp_Object
frame_geometry (Lisp_Object frame, Lisp_Object attribute)
{
@@ -6537,8 +6828,8 @@ frame_geometry (Lisp_Object frame, Lisp_Object attribute)
tab_bar_height = FRAME_TAB_BAR_HEIGHT (f);
tab_bar_width = (tab_bar_height
- ? native_width - 2 * internal_border_width
- : 0);
+ ? native_width - 2 * internal_border_width
+ : 0);
inner_top += tab_bar_height;
#ifdef HAVE_EXT_TOOL_BAR
@@ -6578,7 +6869,14 @@ frame_geometry (Lisp_Object frame, Lisp_Object attribute)
tool_bar_width = (tool_bar_height
? native_width - 2 * internal_border_width
: 0);
- inner_top += tool_bar_height;
+
+ /* Subtract or add to the inner dimensions based on the tool bar
+ position. */
+
+ if (EQ (FRAME_TOOL_BAR_POSITION (f), Qtop))
+ inner_top += tool_bar_height;
+ else
+ inner_bottom -= tool_bar_height;
#endif
/* Construct list. */
@@ -7090,8 +7388,8 @@ that mouse buttons are being held down, such as immediately after a
/* Catch errors since interning lots of targets can potentially
generate a BadAlloc error. */
x_catch_errors (FRAME_X_DISPLAY (f));
- XInternAtoms (FRAME_X_DISPLAY (f), target_names,
- ntargets, False, target_atoms);
+ x_intern_atoms (FRAME_DISPLAY_INFO (f), target_names,
+ ntargets, target_atoms);
x_check_errors (FRAME_X_DISPLAY (f),
"Failed to intern target atoms: %s");
x_uncatch_errors_after_check ();
@@ -7388,20 +7686,6 @@ If TERMINAL is omitted or nil, that stands for the selected frame's display. */
return Qnil;
}
-/* Wait for responses to all X commands issued so far for frame F. */
-
-void
-x_sync (struct frame *f)
-{
- block_input ();
-#ifndef USE_XCB
- XSync (FRAME_X_DISPLAY (f), False);
-#else
- xcb_aux_sync (FRAME_DISPLAY_INFO (f)->xcb_connection);
-#endif
- unblock_input ();
-}
-
/***********************************************************************
Window properties
@@ -7495,7 +7779,7 @@ silently ignored. */)
elsize = element_format == 32 ? sizeof (long) : element_format >> 3;
data = xnmalloc (nelements, elsize);
- x_fill_property_data (FRAME_X_DISPLAY (f), value, data, nelements,
+ x_fill_property_data (FRAME_DISPLAY_INFO (f), value, data, nelements,
element_format);
}
else
@@ -9790,6 +10074,53 @@ This should be called from a variable watcher for `x-gtk-use-native-input'. */)
return Qnil;
}
+
+#if 0
+
+DEFUN ("x-test-string-conversion", Fx_test_string_conversion,
+ Sx_test_string_conversion, 5, 5, 0,
+ doc: /* Perform tests on the XIM string conversion support. */)
+ (Lisp_Object frame, Lisp_Object position,
+ Lisp_Object direction, Lisp_Object operation, Lisp_Object factor)
+{
+ struct frame *f;
+ XIMStringConversionCallbackStruct call_data;
+ XIMStringConversionText text;
+
+ f = decode_window_system_frame (frame);
+
+ if (!FRAME_XIC (f))
+ error ("No XIC on FRAME!");
+
+ CHECK_FIXNUM (position);
+ CHECK_FIXNUM (direction);
+ CHECK_FIXNUM (operation);
+ CHECK_FIXNUM (factor);
+
+ /* xic_string_conversion_callback (XIC ic, XPointer client_data,
+ XIMStringConversionCallbackStruct *call_data) */
+
+ call_data.position = XFIXNUM (position);
+ call_data.direction = XFIXNUM (direction);
+ call_data.operation = XFIXNUM (operation);
+ call_data.factor = XFIXNUM (factor);
+ call_data.text = &text;
+
+ block_input ();
+ xic_string_conversion_callback (FRAME_XIC (f), NULL,
+ &call_data);
+ unblock_input ();
+
+ /* Place a breakpoint here to inspect TEXT! */
+
+ while (1)
+ maybe_quit ();
+
+ return Qnil;
+}
+
+#endif
+
/***********************************************************************
Initialization
@@ -10165,7 +10496,6 @@ eliminated in future versions of Emacs. */);
accepts --with-x-toolkit=gtk. */
Fprovide (intern_c_string ("x-toolkit"), Qnil);
Fprovide (intern_c_string ("gtk"), Qnil);
- Fprovide (intern_c_string ("move-toolbar"), Qnil);
DEFVAR_LISP ("gtk-version-string", Vgtk_version_string,
doc: /* Version info for GTK+. */);
@@ -10236,6 +10566,9 @@ eliminated in future versions of Emacs. */);
defsubr (&Sx_display_set_last_user_time);
defsubr (&Sx_translate_coordinates);
defsubr (&Sx_get_modifier_masks);
+#if 0
+ defsubr (&Sx_test_string_conversion);
+#endif
tip_timer = Qnil;
staticpro (&tip_timer);
diff --git a/src/xftfont.c b/src/xftfont.c
index 04aff72cfeb..41941509bc2 100644
--- a/src/xftfont.c
+++ b/src/xftfont.c
@@ -628,6 +628,12 @@ xftfont_shape (Lisp_Object lgstring, Lisp_Object direction)
static int
xftfont_end_for_frame (struct frame *f)
{
+ /* XftDrawDestroy tries to access dpyinfo->display, which could've
+ been destroyed by now, causing Emacs to crash. The alternative
+ is to leak the XftDraw, but that's better than a crash. */
+ if (!FRAME_X_DISPLAY (f))
+ return 0;
+
block_input ();
XftDraw *xft_draw;
diff --git a/src/xmenu.c b/src/xmenu.c
index ca25aa594fc..ef1eeb5925f 100644
--- a/src/xmenu.c
+++ b/src/xmenu.c
@@ -1617,6 +1617,7 @@ popup_selection_callback (Widget widget, LWLIB_ID id, XtPointer client_data)
#ifdef HAVE_XINPUT2
+
static void
prepare_for_entry_into_toolkit_menu (struct frame *f)
{
@@ -1680,6 +1681,19 @@ leave_toolkit_menu (void *data)
XISetMask (m, XI_Enter);
XISetMask (m, XI_Leave);
+#ifdef HAVE_XINPUT2_4
+ /* Select for gesture events. Emacs selects for gesture events from
+ all master devices on non-GTK3 builds, so that event mask is also
+ clobbered by prepare_for_entry_into_toolkit_menu. (bug#65129) */
+
+ if (dpyinfo->xi2_version >= 4)
+ {
+ XISetMask (m, XI_GesturePinchBegin);
+ XISetMask (m, XI_GesturePinchUpdate);
+ XISetMask (m, XI_GesturePinchEnd);
+ }
+#endif /* HAVE_XINPUT2_4 */
+
FOR_EACH_FRAME (tail, frame)
{
f = XFRAME (frame);
@@ -1691,7 +1705,8 @@ leave_toolkit_menu (void *data)
&mask, 1);
}
}
-#endif
+
+#endif /* HAVE_XINPUT2 */
/* ID is the LWLIB ID of the dialog box. */
diff --git a/src/xselect.c b/src/xselect.c
index 6557cefb846..fd0f06eeed9 100644
--- a/src/xselect.c
+++ b/src/xselect.c
@@ -16,10 +16,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 <https://www.gnu.org/licenses/>. */
-
/* Rewritten by jwz */
#include <config.h>
+
+/* Work around GCC bug 102671. */
+#if 10 <= __GNUC__
+# pragma GCC diagnostic ignored "-Wanalyzer-null-dereference"
+#endif
+
#include <limits.h>
#ifdef HAVE_SYS_TYPES_H
@@ -44,7 +49,7 @@ struct prop_location;
struct selection_data;
static void x_decline_selection_request (struct selection_input_event *);
-static bool x_convert_selection (Lisp_Object, Lisp_Object, Atom, bool,
+static bool x_convert_selection (Lisp_Object, Lisp_Object, Atom,
struct x_display_info *, bool);
static bool waiting_for_other_props_on_window (Display *, Window);
static struct prop_location *expect_property_change (Display *, Window,
@@ -77,18 +82,20 @@ static void x_send_client_event (Lisp_Object, Lisp_Object, Lisp_Object,
#define TRACE0(fmt) (void) 0
#define TRACE1(fmt, a0) (void) 0
#define TRACE2(fmt, a0, a1) (void) 0
+#define TRACE3(fmt, a0, a1, a2) (void) 0
#endif
/* Bytes needed to represent 'long' data. This is as per libX11; it
is not necessarily sizeof (long). */
#define X_LONG_SIZE 4
-/* If this is a smaller number than the max-request-size of the display,
- emacs will use INCR selection transfer when the selection is larger
- than this. The max-request-size is usually around 64k, so if you want
- emacs to use incremental selection transfers when the selection is
- smaller than that, set this. I added this mostly for debugging the
- incremental transfer stuff, but it might improve server performance.
+/* If this is a smaller number than the max-request-size of the
+ display, Emacs will use INCR selection transfer when the selection
+ is larger than this. The max-request-size is usually around 64k,
+ so if you want emacs to use incremental selection transfers when
+ the selection is smaller than that, set this. I added this mostly
+ for debugging the incremental transfer stuff, but it might improve
+ server performance.
This value cannot exceed INT_MAX / max (X_LONG_SIZE, sizeof (long))
because it is multiplied by X_LONG_SIZE and by sizeof (long) in
@@ -101,7 +108,9 @@ static void x_send_client_event (Lisp_Object, Lisp_Object, Lisp_Object,
static int
selection_quantum (Display *display)
{
- long mrs = XExtendedMaxRequestSize (display);
+ long mrs;
+
+ mrs = XExtendedMaxRequestSize (display);
if (!mrs)
mrs = XMaxRequestSize (display);
@@ -281,10 +290,8 @@ x_own_selection (Lisp_Object selection_name, Lisp_Object selection_value,
timestamp = dpyinfo->last_user_time;
block_input ();
- x_catch_errors (display);
- XSetSelectionOwner (display, selection_atom, selecting_window, timestamp);
- x_check_errors (display, "Can't set selection: %s");
- x_uncatch_errors_after_check ();
+ XSetSelectionOwner (display, selection_atom, selecting_window,
+ timestamp);
unblock_input ();
/* Now update the local cache */
@@ -459,7 +466,7 @@ x_decline_selection_request (struct selection_input_event *event)
/* The reason for the error may be that the receiver has
died in the meantime. Handle that case. */
block_input ();
- x_ignore_errors_for_next_request (dpyinfo);
+ x_ignore_errors_for_next_request (dpyinfo, 0);
XSendEvent (dpyinfo->display, reply->requestor,
False, 0, &reply_base);
x_stop_ignoring_errors (dpyinfo);
@@ -472,19 +479,65 @@ x_decline_selection_request (struct selection_input_event *event)
struct selection_data
{
+ /* Pointer to the selection data. */
unsigned char *data;
+
+ /* A Lisp_Object containing the selection data. This is either
+ Qnil, or `data' is NULL. If non-nil, then this must be a string
+ whose contents will be written out verbatim. */
+ Lisp_Object string;
+
+ /* The size, in number of items, of the selection data.
+ The value is meaningless if string is non-nil. */
ptrdiff_t size;
+
+ /* The format of the selection data. */
int format;
+
+ /* The type of the selection data. */
Atom type;
- bool nofree;
+
+ /* The property describing the selection data. */
Atom property;
- /* This can be set to non-NULL during x_reply_selection_request, if
- the selection is waiting for an INCR transfer to complete. Don't
- free these; that's done by unexpect_property_change. */
- struct prop_location *wait_object;
+
+ /* The next piece of selection data in the current selection request
+ stack frame. This can be NULL. */
struct selection_data *next;
};
+/* Structure representing a single outstanding selection request (or
+ subrequest if MULTIPLE is being used.) */
+
+struct transfer
+{
+ /* The requestor of this transfer. */
+ Window requestor;
+
+ /* The current offset in items into the selection data, and the
+ number of items to send with each ChangeProperty request. */
+ size_t offset, items_per_request;
+
+ /* The display info associated with the transfer. */
+ struct x_display_info *dpyinfo;
+
+ /* The converted selection data. */
+ struct selection_data data;
+
+ /* The next and last selection transfers on this list. */
+ struct transfer *next, *last;
+
+ /* The atimer for the timeout. */
+ struct atimer *timeout;
+
+ /* The selection serial. */
+ unsigned int serial;
+
+ /* Flags. */
+ int flags;
+};
+
+#define SELECTED_EVENTS 1
+
struct x_selection_request
{
/* The last element in this stack. */
@@ -499,8 +552,8 @@ struct x_selection_request
/* Linked list of the above (in support of MULTIPLE targets). */
struct selection_data *converted_selections;
- /* "Data" to send a requestor for a failed MULTIPLE subtarget. */
- Atom conversion_fail_tag;
+ /* The serial used to handle X errors. */
+ unsigned int serial;
/* Whether or not conversion was successful. */
bool converted;
@@ -511,6 +564,50 @@ struct x_selection_request
struct x_selection_request *selection_request_stack;
+/* List of all outstanding selection transfers which are currently
+ being processed. */
+
+struct transfer outstanding_transfers;
+
+/* A counter for selection serials. */
+
+static unsigned int selection_serial;
+
+
+
+struct prop_location
+{
+ int identifier;
+ Display *display;
+ Window window;
+ Atom property;
+ int desired_state;
+ bool arrived;
+ struct prop_location *next;
+};
+
+static int prop_location_identifier;
+
+static Lisp_Object property_change_reply;
+
+static struct prop_location *property_change_reply_object;
+
+static struct prop_location *property_change_wait_list;
+
+static void
+set_property_change_object (struct prop_location *location)
+{
+ /* Input must be blocked so we don't get the event before we set
+ these. */
+ if (! input_blocked_p ())
+ emacs_abort ();
+
+ XSETCAR (property_change_reply, Qnil);
+ property_change_reply_object = location;
+}
+
+
+
static void
x_push_current_selection_request (struct selection_input_event *se,
struct x_display_info *dpyinfo)
@@ -523,7 +620,6 @@ x_push_current_selection_request (struct selection_input_event *se,
frame->request = se;
frame->dpyinfo = dpyinfo;
frame->converted_selections = NULL;
- frame->conversion_fail_tag = None;
selection_request_stack = frame;
}
@@ -554,7 +650,7 @@ x_selection_request_lisp_error (void)
for (cs = frame->converted_selections; cs; cs = next)
{
next = cs->next;
- if (! cs->nofree && cs->data)
+ if (cs->data)
xfree (cs->data);
xfree (cs);
}
@@ -564,250 +660,450 @@ x_selection_request_lisp_error (void)
x_decline_selection_request (frame->request);
}
-static void
-x_catch_errors_unwind (void)
+
+
+static size_t
+c_size_for_format (int format)
{
- block_input ();
- x_uncatch_errors ();
- unblock_input ();
+ switch (format)
+ {
+ case 8:
+ return sizeof (char);
+
+ case 16:
+ return sizeof (short);
+
+ case 32:
+ return sizeof (long);
+ }
+
+ emacs_abort ();
}
-
-/* This stuff is so that INCR selections are reentrant (that is, so we can
- be servicing multiple INCR selection requests simultaneously.) I haven't
- actually tested that yet. */
+static size_t
+x_size_for_format (int format)
+{
+ switch (format)
+ {
+ case 8:
+ return 1;
+
+ case 16:
+ return 2;
-/* Keep a list of the property changes that are awaited. */
+ case 32:
+ return 4;
+ }
-struct prop_location
+ emacs_abort ();
+}
+
+/* Return a pointer to the remaining part of the selection data, given
+ a pointer to a struct selection_data and an offset in items. Place
+ the number of items remaining in REMAINING. Garbage collection
+ must not happen, or the returned pointer becomes invalid. */
+
+static unsigned char *
+selection_data_for_offset (struct selection_data *data,
+ long offset, size_t *remaining)
{
- int identifier;
- Display *display;
- Window window;
- Atom property;
- int desired_state;
- bool arrived;
- struct prop_location *next;
-};
+ unsigned char *base;
+ size_t size;
-static int prop_location_identifier;
+ if (!NILP (data->string))
+ {
+ base = SDATA (data->string);
+ size = SBYTES (data->string);
+ }
+ else
+ {
+ base = data->data;
+ size = data->size;
+ }
-static Lisp_Object property_change_reply;
+ if (offset >= size)
+ {
+ *remaining = 0;
+ return NULL;
+ }
-static struct prop_location *property_change_reply_object;
+ base += (offset * c_size_for_format (data->format));
+ *remaining = size - offset;
+ return base;
+}
-static struct prop_location *property_change_wait_list;
+/* Return the size, in bytes transferred to the X server, of
+ data->size items of selection data in data->format-bit
+ quantities. */
-static void
-set_property_change_object (struct prop_location *location)
+static size_t
+selection_data_size (struct selection_data *data)
{
- /* Input must be blocked so we don't get the event before we set these. */
- if (! input_blocked_p ())
- emacs_abort ();
- XSETCAR (property_change_reply, Qnil);
- property_change_reply_object = location;
+ size_t scratch;
+
+ if (!NILP (data->string))
+ return SBYTES (data->string);
+
+ switch (data->format)
+ {
+ case 8:
+ return (size_t) data->size;
+
+ case 16:
+ if (ckd_mul (&scratch, data->size, 2))
+ return SIZE_MAX;
+
+ return scratch;
+
+ case 32:
+ if (ckd_mul (&scratch, data->size, 4))
+ return SIZE_MAX;
+
+ return scratch;
+ }
+
+ /* The specified format is invalid. */
+ emacs_abort ();
}
-
-/* Send the reply to a selection request event EVENT. */
+/* Return whether or not another outstanding selection transfer is
+ still selecting for events on the specified requestor window. */
-#ifdef TRACE_SELECTION
-static int x_reply_selection_request_cnt;
-#endif /* TRACE_SELECTION */
+static bool
+transfer_selecting_event (struct x_display_info *dpyinfo,
+ Window requestor)
+{
+ struct transfer *next;
+
+ next = outstanding_transfers.next;
+ for (; next != &outstanding_transfers; next = next->next)
+ {
+ if (next->requestor == requestor
+ && next->dpyinfo == dpyinfo)
+ return true;
+ }
+
+ return false;
+}
+
+/* Cancel the specified selection transfer. When called by
+ `start_transfer', the transfer may be partially formed. */
static void
-x_reply_selection_request (struct selection_input_event *event,
- struct x_display_info *dpyinfo)
+x_cancel_selection_transfer (struct transfer *transfer)
{
- XEvent reply_base;
- XSelectionEvent *reply = &(reply_base.xselection);
- Display *display = SELECTION_EVENT_DISPLAY (event);
- Window window = SELECTION_EVENT_REQUESTOR (event);
- ptrdiff_t bytes_remaining;
- int max_bytes = selection_quantum (display);
- specpdl_ref count = SPECPDL_INDEX ();
- struct selection_data *cs;
- struct x_selection_request *frame;
+ xfree (transfer->data.data);
- frame = selection_request_stack;
+ if (transfer->next)
+ {
+ transfer->next->last = transfer->last;
+ transfer->last->next = transfer->next;
+ }
- reply->type = SelectionNotify;
- reply->display = display;
- reply->requestor = window;
- reply->selection = SELECTION_EVENT_SELECTION (event);
- reply->time = SELECTION_EVENT_TIME (event);
- reply->target = SELECTION_EVENT_TARGET (event);
- reply->property = SELECTION_EVENT_PROPERTY (event);
- if (reply->property == None)
- reply->property = reply->target;
+ if (transfer->flags & SELECTED_EVENTS
+ && !transfer_selecting_event (transfer->dpyinfo,
+ transfer->requestor)
+ /* This can be called from x_delete_display. */
+ && transfer->dpyinfo->display)
+ {
+ /* Ignore errors generated by the change window request in case
+ the window has gone away. */
+ block_input ();
+ x_ignore_errors_for_next_request (transfer->dpyinfo, 0);
+ XSelectInput (transfer->dpyinfo->display,
+ transfer->requestor, NoEventMask);
+ x_stop_ignoring_errors (transfer->dpyinfo);
+ unblock_input ();
+ }
- block_input ();
- /* The protected block contains wait_for_property_change, which can
- run random lisp code (process handlers) or signal. Therefore, we
- put the x_uncatch_errors call in an unwind. */
- record_unwind_protect_void (x_catch_errors_unwind);
- x_catch_errors (display);
+ cancel_atimer (transfer->timeout);
+ xfree (transfer);
+}
- /* Loop over converted selections, storing them in the requested
- properties. If data is large, only store the first N bytes
- (section 2.7.2 of ICCCM). Note that we store the data for a
- MULTIPLE request in the opposite order; the ICCM says only that
- the conversion itself must be done in the same order. */
- for (cs = frame->converted_selections; cs; cs = cs->next)
+static void
+x_selection_transfer_timeout (struct atimer *atimer)
+{
+ struct transfer *transfer;
+
+ transfer = atimer->client_data;
+ x_cancel_selection_transfer (transfer);
+}
+
+/* Start a selection transfer to write the specified selection data to
+ its requestor. If the data is small enough, write it to the
+ requestor window and return. Otherwise, start INCR transfer and
+ begin listening for PropertyNotify events on the requestor. */
+
+static void
+x_start_selection_transfer (struct x_display_info *dpyinfo, Window requestor,
+ struct selection_data *data)
+{
+ struct transfer *transfer;
+ intmax_t timeout;
+ intmax_t secs;
+ int nsecs;
+ size_t remaining, max_size;
+ unsigned char *xdata;
+ unsigned long data_size;
+
+ timeout = max (0, x_selection_timeout);
+ secs = timeout / 1000;
+ nsecs = (timeout % 1000) * 1000000;
+
+ transfer = xzalloc (sizeof *transfer);
+ transfer->requestor = requestor;
+ transfer->dpyinfo = dpyinfo;
+
+ transfer->timeout = start_atimer (ATIMER_RELATIVE,
+ make_timespec (secs, nsecs),
+ x_selection_transfer_timeout,
+ transfer);
+
+ /* Note that DATA is copied into transfer. DATA->data is then set
+ to NULL, giving the struct transfer ownership over the selection
+ data. */
+
+ transfer->data = *data;
+ data->data = NULL;
+
+ /* Finally, transfer now holds a reference to data->string, if it is
+ present. GC cannot be allowed to happen until this function
+ returns. */
+ data->string = Qnil;
+
+ /* Now, try to write the selection data. If it is bigger than
+ selection_quantum (dpyinfo->display), start incremental transfer
+ and link the transfer onto the list of pending selections.
+ Otherwise, write the transfer at once. */
+
+ max_size = selection_quantum (dpyinfo->display);
+
+ TRACE3 (" x_start_selection_transfer: transferring to 0x%lx. "
+ "transfer consists of %zu bytes, quantum being %zu",
+ requestor, selection_data_size (&transfer->data),
+ max_size);
+
+ if (selection_data_size (&transfer->data) > max_size)
{
- if (cs->property == None)
- continue;
+ /* Begin incremental selection transfer. First, calculate how
+ many elements it is ok to write for every ChangeProperty
+ request. */
+ transfer->items_per_request
+ = (max_size / x_size_for_format (transfer->data.format));
+ TRACE1 (" x_start_selection_transfer: starting incremental"
+ " selection transfer, with %zu items per request",
+ transfer->items_per_request);
+
+ /* Next, link the transfer onto the list of pending selection
+ transfers. */
+ transfer->next = outstanding_transfers.next;
+ transfer->last = &outstanding_transfers;
+ transfer->next->last = transfer;
+ transfer->last->next = transfer;
+
+ /* Find a valid (non-zero) serial for the selection transfer.
+ Any asynchronously trapped errors will then cause the
+ selection transfer to be canceled. */
+ transfer->serial = (++selection_serial
+ ? selection_serial
+ : ++selection_serial);
+
+ /* Now, write the INCR property to begin incremental selection
+ transfer. offset is currently 0. */
+
+ data_size = selection_data_size (&transfer->data);
+
+ /* Set SELECTED_EVENTS before the actual XSelectInput
+ request. */
+ transfer->flags |= SELECTED_EVENTS;
+
+ x_ignore_errors_for_next_request (dpyinfo, transfer->serial);
+ XChangeProperty (dpyinfo->display, requestor,
+ transfer->data.property,
+ dpyinfo->Xatom_INCR, 32, PropModeReplace,
+ (unsigned char *) &data_size, 1);
+
+ /* This assumes that Emacs is not selecting for any other events
+ from the requestor!
+
+ If the holder of some manager selections (i.e. the settings
+ manager) asks Emacs for selection data, things will subtly go
+ wrong. */
+ XSelectInput (dpyinfo->display, requestor, PropertyChangeMask);
+ x_stop_ignoring_errors (dpyinfo);
+ }
+ else
+ {
+ /* Write the property data now. */
+ xdata = selection_data_for_offset (&transfer->data,
+ 0, &remaining);
+ eassert (remaining <= INT_MAX);
+
+ TRACE1 (" x_start_selection_transfer: writing"
+ " %zu elements directly to requestor window",
+ remaining);
+
+ x_ignore_errors_for_next_request (dpyinfo, 0);
+ XChangeProperty (dpyinfo->display, requestor,
+ transfer->data.property,
+ transfer->data.type,
+ transfer->data.format,
+ PropModeReplace, xdata, remaining);
+ x_stop_ignoring_errors (dpyinfo);
+
+ /* Next, get rid of the transfer. */
+ x_cancel_selection_transfer (transfer);
+ }
+}
- bytes_remaining = cs->size;
- bytes_remaining *= cs->format >> 3;
- if (bytes_remaining <= max_bytes)
- {
- /* Send all the data at once, with minimal handshaking. */
- TRACE1 ("Sending all %"pD"d bytes", bytes_remaining);
- XChangeProperty (display, window, cs->property,
- cs->type, cs->format, PropModeReplace,
- cs->data, cs->size);
- }
- else
- {
- /* Send an INCR tag to initiate incremental transfer. */
- long value[1];
-
- TRACE2 ("Start sending %"pD"d bytes incrementally (%s)",
- bytes_remaining, XGetAtomName (display, cs->property));
- cs->wait_object
- = expect_property_change (display, window, cs->property,
- PropertyDelete);
-
- /* XChangeProperty expects an array of long even if long is
- more than 32 bits. */
- value[0] = min (bytes_remaining, X_LONG_MAX);
- XChangeProperty (display, window, cs->property,
- dpyinfo->Xatom_INCR, 32, PropModeReplace,
- (unsigned char *) value, 1);
- XSelectInput (display, window, PropertyChangeMask);
- }
+/* Write out the next piece of data that is part of the specified
+ selection transfer. If no more data remains to be written, write
+ the EOF property and complete the transfer. */
+
+static void
+x_continue_selection_transfer (struct transfer *transfer)
+{
+ size_t remaining;
+ unsigned char *xdata;
+
+ xdata = selection_data_for_offset (&transfer->data,
+ transfer->offset,
+ &remaining);
+ remaining = min (remaining, transfer->items_per_request);
+
+ if (!remaining)
+ {
+ /* The transfer is finished. Write zero-length property data to
+ signal EOF and remove the transfer. */
+ TRACE0 (" x_continue_selection_transfer: writing 0 items to"
+ " indicate EOF");
+ x_ignore_errors_for_next_request (transfer->dpyinfo, 0);
+ XChangeProperty (transfer->dpyinfo->display,
+ transfer->requestor,
+ transfer->data.property,
+ transfer->data.type,
+ transfer->data.format,
+ PropModeReplace,
+ NULL, 0);
+ x_stop_ignoring_errors (transfer->dpyinfo);
+ TRACE0 (" x_continue_selection_transfer: done sending incrementally");
+
+ x_cancel_selection_transfer (transfer);
}
+ else
+ {
+ TRACE2 (" x_continue_selection_transfer: writing %zu items"
+ "; current offset is %zu", remaining, transfer->offset);
+ eassert (remaining <= INT_MAX);
+
+ transfer->offset += remaining;
+
+ x_ignore_errors_for_next_request (transfer->dpyinfo,
+ transfer->serial);
+ XChangeProperty (transfer->dpyinfo->display,
+ transfer->requestor,
+ transfer->data.property,
+ transfer->data.type,
+ transfer->data.format,
+ PropModeReplace, xdata,
+ remaining);
+ x_stop_ignoring_errors (transfer->dpyinfo);
+ }
+}
- /* Now issue the SelectionNotify event. */
- XSendEvent (display, window, False, 0, &reply_base);
- XFlush (display);
+void
+x_remove_selection_transfers (struct x_display_info *dpyinfo)
+{
+ struct transfer *next, *last;
-#ifdef TRACE_SELECTION
- {
- char *sel = XGetAtomName (display, reply->selection);
- char *tgt = XGetAtomName (display, reply->target);
- TRACE3 ("Sent SelectionNotify: %s, target %s (%d)",
- sel, tgt, ++x_reply_selection_request_cnt);
- if (sel) XFree (sel);
- if (tgt) XFree (tgt);
- }
-#endif /* TRACE_SELECTION */
+ next = outstanding_transfers.next;
+ while (next != &outstanding_transfers)
+ {
+ last = next;
+ next = next->next;
- /* Finish sending the rest of each of the INCR values. This should
- be improved; there's a chance of deadlock if more than one
- subtarget in a MULTIPLE selection requires an INCR transfer, and
- the requestor and Emacs loop waiting on different transfers. */
- for (cs = frame->converted_selections; cs; cs = cs->next)
- if (cs->wait_object)
- {
- int format_bytes = cs->format / 8;
- bool had_errors_p = x_had_errors_p (display);
+ if (last->dpyinfo == dpyinfo)
+ x_cancel_selection_transfer (last);
+ }
+}
- /* Must set this inside block_input (). unblock_input may read
- events and setting property_change_reply in
- wait_for_property_change is then too late. */
- set_property_change_object (cs->wait_object);
- unblock_input ();
+/* Handle an X error generated trying to write to a window. SERIAL
+ identifies the outstanding incremental selection transfer, which is
+ immediately removed. */
- bytes_remaining = cs->size;
- bytes_remaining *= format_bytes;
+void
+x_handle_selection_error (unsigned int serial, XErrorEvent *error)
+{
+ struct transfer *next, *last;
- /* Wait for the requestor to ack by deleting the property.
- This can run Lisp code (process handlers) or signal. */
- if (! had_errors_p)
- {
- TRACE1 ("Waiting for ACK (deletion of %s)",
- XGetAtomName (display, cs->property));
- wait_for_property_change (cs->wait_object);
- }
- else
- unexpect_property_change (cs->wait_object);
+ if (error->error_code != BadWindow)
+ /* The error was not caused by the window going away. As such,
+ Emacs must deselect for PropertyChangeMask from the requestor
+ window, which isn't safe here. Return and wait for the timeout
+ to run. */
+ return;
- while (bytes_remaining)
- {
- int i = ((bytes_remaining < max_bytes)
- ? bytes_remaining
- : max_bytes) / format_bytes;
- block_input ();
-
- cs->wait_object
- = expect_property_change (display, window, cs->property,
- PropertyDelete);
-
- TRACE1 ("Sending increment of %d elements", i);
- TRACE1 ("Set %s to increment data",
- XGetAtomName (display, cs->property));
-
- /* Append the next chunk of data to the property. */
- XChangeProperty (display, window, cs->property,
- cs->type, cs->format, PropModeAppend,
- cs->data, i);
- bytes_remaining -= i * format_bytes;
- cs->data += i * ((cs->format == 32) ? sizeof (long)
- : format_bytes);
- XFlush (display);
- had_errors_p = x_had_errors_p (display);
- /* See comment above about property_change_reply. */
- set_property_change_object (cs->wait_object);
- unblock_input ();
-
- if (had_errors_p) break;
-
- /* Wait for the requestor to ack this chunk by deleting
- the property. This can run Lisp code or signal. */
- TRACE1 ("Waiting for increment ACK (deletion of %s)",
- XGetAtomName (display, cs->property));
- wait_for_property_change (cs->wait_object);
- }
+ next = outstanding_transfers.next;
+ while (next != &outstanding_transfers)
+ {
+ last = next;
+ next = next->next;
- /* Now write a zero-length chunk to the property to tell the
- requestor that we're done. */
- block_input ();
- if (! waiting_for_other_props_on_window (display, window))
- XSelectInput (display, window, 0);
-
- TRACE1 ("Set %s to a 0-length chunk to indicate EOF",
- XGetAtomName (display, cs->property));
- XChangeProperty (display, window, cs->property,
- cs->type, cs->format, PropModeReplace,
- cs->data, 0);
- TRACE0 ("Done sending incrementally");
- }
+ if (last->serial == serial)
+ {
+ /* Clear SELECTED_EVENTS, so x_cancel_selection_transfer
+ will not make X requests. That is unsafe inside an error
+ handler, and unnecessary because the window has already
+ gone. */
+ last->flags &= ~SELECTED_EVENTS;
+ x_cancel_selection_transfer (last);
+ }
+ }
+}
- /* rms, 2003-01-03: I think I have fixed this bug. */
- /* The window we're communicating with may have been deleted
- in the meantime (that's a real situation from a bug report).
- In this case, there may be events in the event queue still
- referring to the deleted window, and we'll get a BadWindow error
- in XTread_socket when processing the events. I don't have
- an idea how to fix that. gerd, 2001-01-98. */
- /* 2004-09-10: XSync and UNBLOCK so that possible protocol errors are
- delivered before uncatch errors. */
- XSync (display, False);
- unblock_input ();
+/* Send the reply to a selection request event EVENT. */
+
+static void
+x_reply_selection_request (struct selection_input_event *event,
+ struct x_display_info *dpyinfo)
+{
+ XEvent message;
+ struct selection_data *cs;
+ struct x_selection_request *frame;
- /* GTK queues events in addition to the queue in Xlib. So we
- UNBLOCK to enter the event loop and get possible errors delivered,
- and then BLOCK again because x_uncatch_errors requires it. */
block_input ();
- /* This calls x_uncatch_errors. */
- unbind_to (count, Qnil);
+ frame = selection_request_stack;
+
+ message.xselection.type = SelectionNotify;
+ message.xselection.display = dpyinfo->display;
+ message.xselection.requestor = SELECTION_EVENT_REQUESTOR (event);
+ message.xselection.selection = SELECTION_EVENT_SELECTION (event);
+ message.xselection.time = SELECTION_EVENT_TIME (event);
+ message.xselection.target = SELECTION_EVENT_TARGET (event);
+ message.xselection.property = SELECTION_EVENT_PROPERTY (event);
+
+ if (message.xselection.property == None)
+ message.xselection.property = message.xselection.target;
+
+ /* For each of the converted selections, start a write transfer from
+ Emacs to the requestor. */
+ for (cs = frame->converted_selections; cs; cs = cs->next)
+ x_start_selection_transfer (dpyinfo,
+ SELECTION_EVENT_REQUESTOR (event),
+ cs);
+
+
+ /* Send the SelectionNotify event to the requestor, telling it that
+ the property data has arrived. */
+ x_ignore_errors_for_next_request (dpyinfo, 0);
+ XSendEvent (dpyinfo->display, SELECTION_EVENT_REQUESTOR (event),
+ False, NoEventMask, &message);
+ x_stop_ignoring_errors (dpyinfo);
unblock_input ();
}
-
-/* Handle a SelectionRequest event EVENT.
- This is called from keyboard.c when such an event is found in the queue. */
+
+/* Handle a SelectionRequest event EVENT. This is called from
+ keyboard.c when such an event is found in the queue. */
static void
x_handle_selection_request (struct selection_input_event *event)
@@ -892,7 +1188,9 @@ x_handle_selection_request (struct selection_input_event *event)
ptrdiff_t j, nselections;
struct selection_data cs;
- if (property == None) goto DONE;
+ if (property == None)
+ goto DONE;
+
multprop
= x_get_window_property_as_lisp_data (dpyinfo, requestor, property,
QMULTIPLE, selection, true);
@@ -904,23 +1202,24 @@ x_handle_selection_request (struct selection_input_event *event)
/* Perform conversions. This can signal. */
for (j = 0; j < nselections; j++)
{
- Lisp_Object subtarget = AREF (multprop, 2*j);
+ Lisp_Object subtarget = AREF (multprop, 2 * j);
Atom subproperty = symbol_to_x_atom (dpyinfo,
AREF (multprop, 2*j+1));
bool subsuccess = false;
if (subproperty != None)
subsuccess = x_convert_selection (selection_symbol, subtarget,
- subproperty, true, dpyinfo,
+ subproperty, dpyinfo,
use_alternate);
if (!subsuccess)
- ASET (multprop, 2*j+1, Qnil);
+ ASET (multprop, 2 * j + 1, Qnil);
}
+
/* Save conversion results */
lisp_data_to_selection_data (dpyinfo, multprop, &cs);
- /* If cs.type is ATOM, change it to ATOM_PAIR. This is because
- the parameters to a MULTIPLE are ATOM_PAIRs. */
+ /* If cs.type is ATOM, change it to ATOM_PAIR. This is
+ because the parameters to a MULTIPLE are ATOM_PAIRs. */
if (cs.type == XA_ATOM)
cs.type = dpyinfo->Xatom_ATOM_PAIR;
@@ -929,27 +1228,29 @@ x_handle_selection_request (struct selection_input_event *event)
cs.type, cs.format, PropModeReplace,
cs.data, cs.size);
success = true;
+
+ xfree (cs.data);
}
else
{
if (property == None)
property = SELECTION_EVENT_TARGET (event);
+
success = x_convert_selection (selection_symbol,
target_symbol, property,
- false, dpyinfo,
- use_alternate);
+ dpyinfo, use_alternate);
}
DONE:
- if (pushed)
- selection_request_stack->converted = true;
-
if (success)
x_reply_selection_request (event, dpyinfo);
else
x_decline_selection_request (event);
+ if (pushed)
+ selection_request_stack->converted = true;
+
/* Run the `x-sent-selection-functions' abnormal hook. */
if (!NILP (Vx_sent_selection_functions)
&& !BASE_EQ (Vx_sent_selection_functions, Qunbound))
@@ -960,19 +1261,18 @@ x_handle_selection_request (struct selection_input_event *event)
REALLY_DONE:
unbind_to (count, Qnil);
+ return;
}
/* Perform the requested selection conversion, and write the data to
the converted_selections linked list, where it can be accessed by
- x_reply_selection_request. If FOR_MULTIPLE, write out
- the data even if conversion fails, using conversion_fail_tag.
+ x_reply_selection_request.
Return true if successful. */
static bool
-x_convert_selection (Lisp_Object selection_symbol,
- Lisp_Object target_symbol, Atom property,
- bool for_multiple, struct x_display_info *dpyinfo,
+x_convert_selection (Lisp_Object selection_symbol, Lisp_Object target_symbol,
+ Atom property, struct x_display_info *dpyinfo,
bool use_alternate)
{
Lisp_Object lisp_selection;
@@ -988,33 +1288,16 @@ x_convert_selection (Lisp_Object selection_symbol,
/* A nil return value means we can't perform the conversion. */
if (NILP (lisp_selection)
|| (CONSP (lisp_selection) && NILP (XCDR (lisp_selection))))
- {
- if (for_multiple)
- {
- cs = xmalloc (sizeof *cs);
- cs->data = ((unsigned char *)
- &selection_request_stack->conversion_fail_tag);
- cs->size = 1;
- cs->format = 32;
- cs->type = XA_ATOM;
- cs->nofree = true;
- cs->property = property;
- cs->wait_object = NULL;
- cs->next = frame->converted_selections;
- frame->converted_selections = cs;
- }
-
- return false;
- }
+ return false;
/* Otherwise, record the converted selection to binary. */
cs = xmalloc (sizeof *cs);
cs->data = NULL;
- cs->nofree = true;
+ cs->string = Qnil;
cs->property = property;
- cs->wait_object = NULL;
cs->next = frame->converted_selections;
frame->converted_selections = cs;
+
lisp_data_to_selection_data (dpyinfo, lisp_selection, cs);
return true;
}
@@ -1274,6 +1557,10 @@ void
x_handle_property_notify (const XPropertyEvent *event)
{
struct prop_location *rest;
+ struct transfer *next;
+#ifdef TRACE_SELECTION
+ char *name;
+#endif
for (rest = property_change_wait_list; rest; rest = rest->next)
{
@@ -1283,9 +1570,16 @@ x_handle_property_notify (const XPropertyEvent *event)
&& rest->display == event->display
&& rest->desired_state == event->state)
{
+#ifdef TRACE_SELECTION
+ name = XGetAtomName (event->display, event->atom);
+
TRACE2 ("Expected %s of property %s",
(event->state == PropertyDelete ? "deletion" : "change"),
- XGetAtomName (event->display, event->atom));
+ name ? name : "unknown");
+
+ if (name)
+ XFree (name);
+#endif
rest->arrived = true;
@@ -1297,6 +1591,26 @@ x_handle_property_notify (const XPropertyEvent *event)
return;
}
}
+
+ /* Look for a property change for an outstanding selection
+ transfer. */
+ next = outstanding_transfers.next;
+ while (next != &outstanding_transfers)
+ {
+ if (next->dpyinfo->display == event->display
+ && next->requestor == event->window
+ && next->data.property == event->atom
+ && event->state == PropertyDelete)
+ {
+ TRACE1 ("Expected PropertyDelete event arrived from the"
+ " requestor window %lx", next->requestor);
+
+ x_continue_selection_transfer (next);
+ return;
+ }
+
+ next = next->next;
+ }
}
static void
@@ -1450,10 +1764,10 @@ x_get_window_property (Display *display, Window window, Atom property,
/* Maximum value for TOTAL_SIZE. It cannot exceed PTRDIFF_MAX - 1
and SIZE_MAX - 1, for an extra byte at the end. And it cannot
exceed LONG_MAX * X_LONG_SIZE, for XGetWindowProperty. */
- ptrdiff_t total_size_max =
- ((min (PTRDIFF_MAX, SIZE_MAX) - 1) / x_long_size < LONG_MAX
- ? min (PTRDIFF_MAX, SIZE_MAX) - 1
- : LONG_MAX * x_long_size);
+ ptrdiff_t total_size_max
+ = ((min (PTRDIFF_MAX, SIZE_MAX) - 1) / x_long_size < LONG_MAX
+ ? min (PTRDIFF_MAX, SIZE_MAX) - 1
+ : LONG_MAX * x_long_size);
block_input ();
@@ -1681,9 +1995,22 @@ receive_incremental_selection (struct x_display_info *dpyinfo,
}
+
+/* Free the selection data allocated inside *DATA, which is actually a
+ pointer to unsigned char *. */
+
+static void
+x_free_selection_data (void *data)
+{
+ unsigned char **ptr;
+
+ ptr = data;
+ xfree (*ptr);
+}
+
/* Fetch a value from property PROPERTY of X window WINDOW on display
- DISPLAY. TARGET_TYPE and SELECTION_ATOM are used in error message
- if this fails. */
+ DISPLAY. TARGET_TYPE and SELECTION_ATOM are used in the error
+ message signaled if this fails. */
static Lisp_Object
x_get_window_property_as_lisp_data (struct x_display_info *dpyinfo,
@@ -1699,6 +2026,7 @@ x_get_window_property_as_lisp_data (struct x_display_info *dpyinfo,
ptrdiff_t bytes = 0, array_bytes;
Lisp_Object val;
Display *display = dpyinfo->display;
+ specpdl_ref count;
/* array_bytes is only used as an argument to xpalloc. The actual
size of the data inside the buffer is inside bytes. */
@@ -1734,6 +2062,13 @@ x_get_window_property_as_lisp_data (struct x_display_info *dpyinfo,
}
}
+ /* Make sure DATA is freed even if `receive_incremental_connection'
+ quits. Use xfree, not XFree, because x_get_window_property calls
+ xmalloc itself. */
+
+ count = SPECPDL_INDEX ();
+ record_unwind_protect_ptr (x_free_selection_data, &data);
+
if (!for_multiple && actual_type == dpyinfo->Xatom_INCR)
{
/* That wasn't really the data, just the beginning. */
@@ -1743,6 +2078,9 @@ x_get_window_property_as_lisp_data (struct x_display_info *dpyinfo,
/* Use xfree, not XFree, because x_get_window_property
calls xmalloc itself. */
xfree (data);
+
+ /* In case quitting happens below. */
+ data = NULL;
unblock_input ();
/* Clear bytes again. Previously, receive_incremental_selection
@@ -1769,10 +2107,8 @@ x_get_window_property_as_lisp_data (struct x_display_info *dpyinfo,
val = selection_data_to_lisp_data (dpyinfo, data, bytes,
actual_type, actual_format);
- /* Use xfree, not XFree, because x_get_window_property
- calls xmalloc itself. */
- xfree (data);
- return val;
+ /* This will also free `data'. */
+ return unbind_to (count, val);
}
/* These functions convert from the selection data read from the server into
@@ -1946,10 +2282,14 @@ static void
lisp_data_to_selection_data (struct x_display_info *dpyinfo,
Lisp_Object obj, struct selection_data *cs)
{
- Lisp_Object type = Qnil;
+ Lisp_Object type;
+ char **name_buffer;
+
+ USE_SAFE_ALLOCA;
+
+ type = Qnil;
eassert (cs != NULL);
- cs->nofree = false;
if (CONSP (obj) && SYMBOLP (XCAR (obj)))
{
@@ -1959,8 +2299,10 @@ lisp_data_to_selection_data (struct x_display_info *dpyinfo,
obj = XCAR (obj);
}
+ /* This is not the same as declining. */
+
if (EQ (obj, QNULL) || (EQ (type, QNULL)))
- { /* This is not the same as declining */
+ {
cs->format = 32;
cs->size = 0;
cs->data = NULL;
@@ -1971,12 +2313,14 @@ lisp_data_to_selection_data (struct x_display_info *dpyinfo,
if (SCHARS (obj) < SBYTES (obj))
/* OBJ is a multibyte string containing a non-ASCII char. */
signal_error ("Non-ASCII string must be encoded in advance", obj);
+
if (NILP (type))
type = QSTRING;
+
cs->format = 8;
- cs->size = SBYTES (obj);
- cs->data = SDATA (obj);
- cs->nofree = true;
+ cs->size = -1;
+ cs->data = NULL;
+ cs->string = obj;
}
else if (SYMBOLP (obj))
{
@@ -2048,8 +2392,19 @@ lisp_data_to_selection_data (struct x_display_info *dpyinfo,
x_atoms = data;
cs->format = 32;
cs->size = size;
- for (i = 0; i < size; i++)
- x_atoms[i] = symbol_to_x_atom (dpyinfo, AREF (obj, i));
+
+ if (size == 1)
+ x_atoms[0] = symbol_to_x_atom (dpyinfo, AREF (obj, i));
+ else
+ {
+ SAFE_NALLOCA (name_buffer, sizeof *x_atoms, size);
+
+ for (i = 0; i < size; i++)
+ name_buffer[i] = SSDATA (SYMBOL_NAME (AREF (obj, i)));
+
+ x_intern_atoms (dpyinfo, name_buffer, size,
+ x_atoms);
+ }
}
else
/* This vector is an INTEGER set, or something like it */
@@ -2091,6 +2446,8 @@ lisp_data_to_selection_data (struct x_display_info *dpyinfo,
signal_error (/* Qselection_error */ "Unrecognized selection data", obj);
cs->type = symbol_to_x_atom (dpyinfo, type);
+
+ SAFE_FREE ();
}
static Lisp_Object
@@ -2618,8 +2975,8 @@ x_check_property_data (Lisp_Object data)
XClientMessageEvent). */
void
-x_fill_property_data (Display *dpy, Lisp_Object data, void *ret,
- int nelements_max, int format)
+x_fill_property_data (struct x_display_info *dpyinfo, Lisp_Object data,
+ void *ret, int nelements_max, int format)
{
unsigned long val;
unsigned long *d32 = (unsigned long *) ret;
@@ -2654,7 +3011,7 @@ x_fill_property_data (Display *dpy, Lisp_Object data, void *ret,
else if (STRINGP (o))
{
block_input ();
- val = XInternAtom (dpy, SSDATA (o), False);
+ val = x_intern_cached_atom (dpyinfo, SSDATA (o), false);
unblock_input ();
}
else
@@ -2698,7 +3055,7 @@ x_property_data_to_lisp (struct frame *f, const unsigned char *data,
{
ptrdiff_t format_bytes = format >> 3;
ptrdiff_t data_bytes;
- if (INT_MULTIPLY_WRAPV (size, format_bytes, &data_bytes))
+ if (ckd_mul (&data_bytes, size, format_bytes))
memory_full (SIZE_MAX);
return selection_data_to_lisp_data (FRAME_DISPLAY_INFO (f), data,
data_bytes, type, format);
@@ -2942,7 +3299,7 @@ x_send_client_event (Lisp_Object display, Lisp_Object dest, Lisp_Object from,
memset (event.xclient.data.l, 0, sizeof (event.xclient.data.l));
/* event.xclient.data can hold 20 chars, 10 shorts, or 5 longs. */
- x_fill_property_data (dpyinfo->display, values, event.xclient.data.b,
+ x_fill_property_data (dpyinfo, values, event.xclient.data.b,
5 * 32 / event.xclient.format,
event.xclient.format);
@@ -3002,10 +3359,11 @@ syms_of_xselect (void)
reading_selection_reply = Fcons (Qnil, Qnil);
staticpro (&reading_selection_reply);
-
staticpro (&property_change_reply);
- /* FIXME: Duplicate definition in nsselect.c. */
+ outstanding_transfers.next = &outstanding_transfers;
+ outstanding_transfers.last = &outstanding_transfers;
+
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:
@@ -3120,9 +3478,43 @@ Note that this does not affect setting or owning selections. */);
static void
syms_of_xselect_for_pdumper (void)
{
+ outstanding_transfers.next = &outstanding_transfers;
+ outstanding_transfers.last = &outstanding_transfers;
+
reading_selection_window = 0;
reading_which_selection = 0;
property_change_wait_list = 0;
prop_location_identifier = 0;
property_change_reply = Fcons (Qnil, Qnil);
}
+
+void
+mark_xselect (void)
+{
+ struct transfer *next;
+ struct x_selection_request *frame;
+ struct selection_data *cs;
+
+ /* Mark all the strings being used as selection data. A string that
+ is still reachable is always reachable via either the selection
+ request stack or the list of outstanding transfers. */
+
+ next = outstanding_transfers.next;
+
+ if (!next)
+ /* syms_of_xselect has not yet been called. */
+ return;
+
+ while (next != &outstanding_transfers)
+ {
+ mark_object (next->data.string);
+ next = next->next;
+ }
+
+ frame = selection_request_stack;
+ for (; frame; frame = frame->last)
+ {
+ for (cs = frame->converted_selections; cs; cs = cs->next)
+ mark_object (cs->string);
+ }
+}
diff --git a/src/xsmfns.c b/src/xsmfns.c
index b0858b2d6a1..8827d08af3e 100644
--- a/src/xsmfns.c
+++ b/src/xsmfns.c
@@ -223,7 +223,7 @@ smc_save_yourself_CB (SmcConn smcConn,
props[props_idx]->name = xstrdup (SmRestartCommand);
props[props_idx]->type = xstrdup (SmLISTofARRAY8);
/* /path/to/emacs, --smid=xxx --no-splash --chdir=dir ... */
- if (INT_ADD_WRAPV (initial_argc, 3, &i))
+ if (ckd_add (&i, initial_argc, 3))
memory_full (SIZE_MAX);
props[props_idx]->num_vals = i;
vp = xnmalloc (i, sizeof *vp);
diff --git a/src/xterm.c b/src/xterm.c
index 524e2a32574..c0aef65ab66 100644
--- a/src/xterm.c
+++ b/src/xterm.c
@@ -26,6 +26,22 @@ along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. */
contains subroutines comprising the redisplay interface, setting up
scroll bars and widgets, and handling input.
+ X WINDOW SYSTEM
+
+ The X Window System is a windowing system for bitmap graphics
+ displays which originated at MIT in 1984. Version 11, which is
+ currently supported by Emacs, first appeared in September 1987.
+
+ X has a long history and has been developed by many different
+ organizations over the years; at present, it is being primarily
+ developed by the X.Org Foundation. It is the main window system
+ that Emacs is developed and tested against, and X version 10 was
+ the first window system that Emacs was ported to. As a consequence
+ of its age and wide availability, X contains many idiosyncrasies,
+ but that has not prevented it from becoming the dominant free
+ window system, and the platform of reference for all GUI code in
+ Emacs.
+
Some of what is explained below also applies to the other window
systems that Emacs supports, to varying degrees. YMMV.
@@ -555,7 +571,56 @@ along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. */
drop happening with the primary selection and synthetic button
events (see `x_dnd_do_unsupported_drop'). That function implements
the OffiX drag-and-drop protocol by default. See
- `x-dnd-handle-unsupported-drop' in `x-dnd.el' for more details. */
+ `x-dnd-handle-unsupported-drop' in `x-dnd.el' for more details.
+
+ DISPLAY ERROR HANDLING
+
+ While error handling under X was originally designed solely as a
+ mechanism for the X server to report fatal errors to clients, most
+ clients (including Emacs) have adopted a system of "error traps" to
+ handle or discard these errors as they arrive. Discarding errors is
+ usually necessary when Emacs performs an X request that might fail:
+ for example, sending a message to a window that may no longer exist,
+ or might not exist at all. Handling errors is then necessary when
+ the detailed error must be reported to another piece of code: for
+ example, as a Lisp error.
+
+ It is not acceptable for Emacs to crash when it is sent invalid data
+ by another client, or by Lisp. As a result, errors must be caught
+ around Xlib functions generating requests containing resource
+ identifiers that could potentially be invalid, such as window or
+ atom identifiers provided in a client message from another program,
+ or a child window ID obtained through XTranslateCoordinates that may
+ refer to a window that has been deleted in the meantime.
+
+ There are two sets of functions used to perform this "error
+ trapping". Which one should be used depends on what kind of
+ processing must be done on the error. The first consists of the
+ functions `x_ignore_errors_for_next_request' and
+ `x_stop_ignoring_errors', which ignore errors generated by requests
+ made in between a call to the first function and a corresponding
+ call to the second. They should be used for simple asynchronous
+ requests that do not require a reply from the X server: using them
+ instead of the second set improves performance, as they simply
+ record a range of request serials to ignore errors from, instead of
+ synchronizing with the X server to handle errors.
+
+ The second set consists of the following functions:
+
+ - x_catch_errors_with_handler
+ - x_catch_errors
+ - x_uncatch_errors_after_check
+ - x_uncatch_errors
+ - x_check_errors
+ - x_had_errors_p
+ - x_clear_errors
+
+ Callers using this set should consult the comment(s) on top of the
+ aforementioned functions. They should not be used when the requests
+ being made do not require roundtrips to the X server, and obtaining
+ the details of any error generated is unnecessary, as
+ `x_uncatch_errors' will always synchronize with the X server, which
+ is a potentially slow operation. */
#include <config.h>
#include <stdlib.h>
@@ -571,10 +636,13 @@ along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. */
#include "xterm.h"
#include <X11/cursorfont.h>
+#ifdef HAVE_X_I18N
+#include "textconv.h"
+#endif
+
#ifdef USE_XCB
#include <xcb/xproto.h>
#include <xcb/xcb.h>
-#include <xcb/xcb_aux.h>
#endif
/* If we have Xfixes extension, use it for pointer blanking. */
@@ -730,13 +798,6 @@ typedef int (*Emacs_XIOErrorHandler) (Display *);
#define USE_CAIRO_XCB_SURFACE
#endif
-/* Default to using XIM if available. */
-#ifdef USE_XIM
-bool use_xim = true;
-#else
-bool use_xim = false; /* configure --without-xim */
-#endif
-
#if XCB_SHAPE_MAJOR_VERSION > 1 \
|| (XCB_SHAPE_MAJOR_VERSION == 1 && \
XCB_SHAPE_MINOR_VERSION >= 1)
@@ -1052,6 +1113,20 @@ static const struct x_atom_ref x_atom_refs[] =
/* Old OffiX (a.k.a. old KDE) drop protocol support. */
ATOM_REFS_INIT ("DndProtocol", Xatom_DndProtocol)
ATOM_REFS_INIT ("_DND_PROTOCOL", Xatom_DND_PROTOCOL)
+ /* Here are some atoms that are not actually used from C, just
+ defined to make replying to selection requests fast. */
+ ATOM_REFS_INIT ("text/plain;charset=utf-8", Xatom_text_plain_charset_utf_8)
+ ATOM_REFS_INIT ("LENGTH", Xatom_LENGTH)
+ ATOM_REFS_INIT ("FILE_NAME", Xatom_FILE_NAME)
+ ATOM_REFS_INIT ("CHARACTER_POSITION", Xatom_CHARACTER_POSITION)
+ ATOM_REFS_INIT ("LINE_NUMBER", Xatom_LINE_NUMBER)
+ ATOM_REFS_INIT ("COLUMN_NUMBER", Xatom_COLUMN_NUMBER)
+ ATOM_REFS_INIT ("OWNER_OS", Xatom_OWNER_OS)
+ ATOM_REFS_INIT ("HOST_NAME", Xatom_HOST_NAME)
+ ATOM_REFS_INIT ("USER", Xatom_USER)
+ ATOM_REFS_INIT ("CLASS", Xatom_CLASS)
+ ATOM_REFS_INIT ("NAME", Xatom_NAME)
+ ATOM_REFS_INIT ("SAVE_TARGETS", Xatom_SAVE_TARGETS)
};
enum
@@ -1092,7 +1167,7 @@ static struct terminal *x_create_terminal (struct x_display_info *);
static void x_frame_rehighlight (struct x_display_info *);
static void x_clip_to_row (struct window *, struct glyph_row *,
- enum glyph_row_area, GC);
+ enum glyph_row_area, GC, XRectangle *);
static struct scroll_bar *x_window_to_scroll_bar (Display *, Window, int);
static struct frame *x_window_to_frame (struct x_display_info *, int);
static void x_scroll_bar_report_motion (struct frame **, Lisp_Object *,
@@ -1140,6 +1215,8 @@ static void x_set_input_focus (struct x_display_info *, Window, Time);
static void x_scroll_bar_redraw (struct scroll_bar *);
#endif
+
+
/* Global state maintained during a drag-and-drop operation. */
/* Flag that indicates if a drag-and-drop operation is in progress. */
@@ -1468,6 +1545,8 @@ static struct x_client_list_window *x_dnd_toplevels;
for `x_dnd_toplevels' to work. */
static bool x_dnd_use_toplevels;
+
+
/* Motif drag-and-drop protocol support. */
/* Pointer to a variable which stores whether or not an X error
@@ -2240,13 +2319,10 @@ xm_setup_dnd_targets (struct x_display_info *dpyinfo,
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))
+ if (ckd_add (&header.target_list_count, header.target_list_count, 1)
+ || ckd_mul (&size, ntargets, 4)
+ || ckd_add (&header.total_data_size, header.total_data_size, size)
+ || ckd_add (&header.total_data_size, header.total_data_size, 2))
{
/* Overflow, remove every entry from the targets table
and add one for our current targets list. This
@@ -2509,7 +2585,7 @@ xm_send_drop_message (struct x_display_info *dpyinfo, Window source,
*((uint32_t *) &msg.xclient.data.b[12]) = dmsg->index_atom;
*((uint32_t *) &msg.xclient.data.b[16]) = dmsg->source_window;
- x_ignore_errors_for_next_request (dpyinfo);
+ x_ignore_errors_for_next_request (dpyinfo, 0);
XSendEvent (dpyinfo->display, target, False, NoEventMask, &msg);
x_stop_ignoring_errors (dpyinfo);
}
@@ -2536,7 +2612,7 @@ xm_send_top_level_enter_message (struct x_display_info *dpyinfo, Window source,
msg.xclient.data.b[18] = 0;
msg.xclient.data.b[19] = 0;
- x_ignore_errors_for_next_request (dpyinfo);
+ x_ignore_errors_for_next_request (dpyinfo, 0);
XSendEvent (dpyinfo->display, target, False, NoEventMask, &msg);
x_stop_ignoring_errors (dpyinfo);
}
@@ -2567,7 +2643,7 @@ xm_send_drag_motion_message (struct x_display_info *dpyinfo, Window source,
msg.xclient.data.b[18] = 0;
msg.xclient.data.b[19] = 0;
- x_ignore_errors_for_next_request (dpyinfo);
+ x_ignore_errors_for_next_request (dpyinfo, 0);
XSendEvent (dpyinfo->display, target, False, NoEventMask, &msg);
x_stop_ignoring_errors (dpyinfo);
}
@@ -2626,7 +2702,7 @@ xm_send_top_level_leave_message (struct x_display_info *dpyinfo, Window source,
msg.xclient.data.b[18] = 0;
msg.xclient.data.b[19] = 0;
- x_ignore_errors_for_next_request (dpyinfo);
+ x_ignore_errors_for_next_request (dpyinfo, 0);
XSendEvent (dpyinfo->display, target, False, NoEventMask, &msg);
x_stop_ignoring_errors (dpyinfo);
}
@@ -2842,6 +2918,11 @@ x_dnd_send_xm_leave_for_drop (struct x_display_info *dpyinfo,
wdesc, &lmsg);
}
+
+
+/* Drag-and-drop and XDND protocol primitives employed by the event
+ loop. */
+
static void
x_dnd_free_toplevels (bool display_alive)
{
@@ -2921,7 +3002,7 @@ x_dnd_free_toplevels (bool display_alive)
if (n_windows)
{
eassume (dpyinfo);
- x_ignore_errors_for_next_request (dpyinfo);
+ x_ignore_errors_for_next_request (dpyinfo, 0);
for (i = 0; i < n_windows; ++i)
{
@@ -3058,7 +3139,7 @@ x_dnd_compute_toplevels (struct x_display_info *dpyinfo)
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,
+ (xcb_atom_t) dpyinfo->Xatom_wm_state, 0,
0, 2);
xm_property_cookies[i]
= xcb_get_property (dpyinfo->xcb_connection, 0, (xcb_window_t) toplevels[i],
@@ -3069,7 +3150,7 @@ x_dnd_compute_toplevels (struct x_display_info *dpyinfo)
= 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);
+ XA_CARDINAL, 0, 4);
get_geometry_cookies[i]
= xcb_get_geometry (dpyinfo->xcb_connection, (xcb_window_t) toplevels[i]);
@@ -3187,9 +3268,10 @@ x_dnd_compute_toplevels (struct x_display_info *dpyinfo)
if (!xm_property_reply)
free (error);
- extent_property_reply = xcb_get_property_reply (dpyinfo->xcb_connection,
- extent_property_cookies[i],
- &error);
+ extent_property_reply
+ = xcb_get_property_reply (dpyinfo->xcb_connection,
+ extent_property_cookies[i],
+ &error);
if (!extent_property_reply)
free (error);
@@ -3197,7 +3279,7 @@ x_dnd_compute_toplevels (struct x_display_info *dpyinfo)
{
if (xcb_get_property_value_length (extent_property_reply) == 16
&& extent_property_reply->format == 32
- && extent_property_reply->type == XCB_ATOM_CARDINAL)
+ && extent_property_reply->type == XA_CARDINAL)
{
fextents = xcb_get_property_value (extent_property_reply);
frame_extents[0] = fextents[0];
@@ -3270,7 +3352,8 @@ x_dnd_compute_toplevels (struct x_display_info *dpyinfo)
#else
if (xm_property_reply
&& xm_property_reply->format == 8
- && xm_property_reply->type == dpyinfo->Xatom_MOTIF_DRAG_RECEIVER_INFO
+ && (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);
@@ -3291,7 +3374,7 @@ x_dnd_compute_toplevels (struct x_display_info *dpyinfo)
if (dpyinfo->xshape_supported_p)
{
- x_ignore_errors_for_next_request (dpyinfo);
+ x_ignore_errors_for_next_request (dpyinfo, 0);
XShapeSelectInput (dpyinfo->display,
toplevels[i],
ShapeNotifyMask);
@@ -3319,9 +3402,10 @@ x_dnd_compute_toplevels (struct x_display_info *dpyinfo)
XFree (rects);
}
#else
- bounding_rect_reply = xcb_shape_get_rectangles_reply (dpyinfo->xcb_connection,
- bounding_rect_cookies[i],
- &error);
+ bounding_rect_reply
+ = xcb_shape_get_rectangles_reply (dpyinfo->xcb_connection,
+ bounding_rect_cookies[i],
+ &error);
if (bounding_rect_reply)
{
@@ -3332,7 +3416,8 @@ x_dnd_compute_toplevels (struct x_display_info *dpyinfo)
* sizeof *tem->bounding_rects);
tem->n_bounding_rects = 0;
- for (; bounding_rect_iterator.rem; xcb_rectangle_next (&bounding_rect_iterator))
+ for (; bounding_rect_iterator.rem;
+ xcb_rectangle_next (&bounding_rect_iterator))
{
tem->bounding_rects[tem->n_bounding_rects].x
= bounding_rect_iterator.data->x;
@@ -3357,9 +3442,10 @@ x_dnd_compute_toplevels (struct x_display_info *dpyinfo)
|| (dpyinfo->xshape_major == 1
&& dpyinfo->xshape_minor >= 1))
{
- input_rect_reply = xcb_shape_get_rectangles_reply (dpyinfo->xcb_connection,
- input_rect_cookies[i],
- &error);
+ input_rect_reply
+ = xcb_shape_get_rectangles_reply (dpyinfo->xcb_connection,
+ input_rect_cookies[i],
+ &error);
if (input_rect_reply)
{
@@ -3370,7 +3456,8 @@ x_dnd_compute_toplevels (struct x_display_info *dpyinfo)
* sizeof *tem->input_rects);
tem->n_input_rects = 0;
- for (; input_rect_iterator.rem; xcb_rectangle_next (&input_rect_iterator))
+ for (; input_rect_iterator.rem;
+ xcb_rectangle_next (&input_rect_iterator))
{
tem->input_rects[tem->n_input_rects].x
= input_rect_iterator.data->x;
@@ -3437,17 +3524,25 @@ x_dnd_compute_toplevels (struct x_display_info *dpyinfo)
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
+ && (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
+ && (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
)
{
@@ -3456,7 +3551,7 @@ x_dnd_compute_toplevels (struct x_display_info *dpyinfo)
}
#endif
- x_ignore_errors_for_next_request (dpyinfo);
+ x_ignore_errors_for_next_request (dpyinfo, 0);
XSelectInput (dpyinfo->display, toplevels[i],
(attrs.your_event_mask
| StructureNotifyMask
@@ -3470,9 +3565,10 @@ x_dnd_compute_toplevels (struct x_display_info *dpyinfo)
#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);
+ bounding_rect_reply
+ = xcb_shape_get_rectangles_reply (dpyinfo->xcb_connection,
+ bounding_rect_cookies[i],
+ &error);
if (bounding_rect_reply)
free (bounding_rect_reply);
@@ -3487,9 +3583,10 @@ x_dnd_compute_toplevels (struct x_display_info *dpyinfo)
|| (dpyinfo->xshape_major == 1
&& dpyinfo->xshape_minor >= 1)))
{
- input_rect_reply = xcb_shape_get_rectangles_reply (dpyinfo->xcb_connection,
- input_rect_cookies[i],
- &error);
+ input_rect_reply
+ = xcb_shape_get_rectangles_reply (dpyinfo->xcb_connection,
+ input_rect_cookies[i],
+ &error);
if (input_rect_reply)
free (input_rect_reply);
@@ -3571,13 +3668,13 @@ x_dnd_get_proxy_proto (struct x_display_info *dpyinfo, Window wdesc,
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);
+ XA_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);
+ XA_ATOM, 0, 1);
if (proxy_out)
{
@@ -3589,7 +3686,7 @@ x_dnd_get_proxy_proto (struct x_display_info *dpyinfo, Window wdesc,
else
{
if (reply->format == 32
- && reply->type == XCB_ATOM_WINDOW
+ && reply->type == XA_WINDOW
&& (xcb_get_property_value_length (reply) >= 4))
*proxy_out = *(xcb_window_t *) xcb_get_property_value (reply);
@@ -3607,7 +3704,7 @@ x_dnd_get_proxy_proto (struct x_display_info *dpyinfo, Window wdesc,
else
{
if (reply->format == 32
- && reply->type == XCB_ATOM_ATOM
+ && reply->type == XA_ATOM
&& (xcb_get_property_value_length (reply) >= 4))
*proto_out = (int) *(xcb_atom_t *) xcb_get_property_value (reply);
@@ -3712,8 +3809,10 @@ x_dnd_get_target_window_1 (struct x_display_info *dpyinfo,
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))
+ (tem->border_width
+ + root_x - tem->x),
+ (tem->border_width
+ + root_y - tem->y)))
{
chosen = tem;
break;
@@ -3791,20 +3890,21 @@ x_dnd_get_wm_state_and_proto (struct x_display_info *dpyinfo,
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);
+ 0, 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);
+ XA_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);
+ XA_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);
@@ -3846,7 +3946,7 @@ x_dnd_get_wm_state_and_proto (struct x_display_info *dpyinfo,
else
{
if (reply->format == 32
- && reply->type == XCB_ATOM_WINDOW
+ && reply->type == XA_WINDOW
&& (xcb_get_property_value_length (reply) >= 4))
*proxy_out = *(xcb_window_t *) xcb_get_property_value (reply);
@@ -3962,6 +4062,12 @@ x_dnd_do_unsupported_drop (struct x_display_info *dpyinfo,
if (owner != FRAME_X_WINDOW (f))
return;
+ /* mouse-drag-and-drop-region will immediately deactivate the mark
+ after this is set. Make sure the primary selection is not
+ clobbered in that case by setting `deactivate-mark' to
+ Qdont_save. */
+ Vdeactivate_mark = Qdont_save;
+
event.xbutton.window = child;
event.xbutton.subwindow = None;
event.xbutton.x = dest_x;
@@ -3975,7 +4081,7 @@ x_dnd_do_unsupported_drop (struct x_display_info *dpyinfo,
event.xbutton.type = ButtonPress;
event.xbutton.time = before + 1;
- x_ignore_errors_for_next_request (dpyinfo);
+ x_ignore_errors_for_next_request (dpyinfo, 0);
XSendEvent (dpyinfo->display, child,
True, ButtonPressMask, &event);
@@ -4487,7 +4593,7 @@ x_dnd_send_enter (struct frame *f, Window target, Window toplevel,
so we don't have to set it again. */
x_dnd_init_type_lists = true;
- x_ignore_errors_for_next_request (dpyinfo);
+ x_ignore_errors_for_next_request (dpyinfo, 0);
XSendEvent (FRAME_X_DISPLAY (f), target, False, NoEventMask, &msg);
x_stop_ignoring_errors (dpyinfo);
}
@@ -4559,7 +4665,7 @@ x_dnd_send_position (struct frame *f, Window target, Window toplevel,
return;
}
- x_ignore_errors_for_next_request (dpyinfo);
+ x_ignore_errors_for_next_request (dpyinfo, 0);
XSendEvent (FRAME_X_DISPLAY (f), target, False, NoEventMask, &msg);
x_stop_ignoring_errors (dpyinfo);
@@ -4586,7 +4692,7 @@ x_dnd_send_leave (struct frame *f, Window target, Window toplevel)
x_dnd_waiting_for_status_window = None;
x_dnd_pending_send_position.type = 0;
- x_ignore_errors_for_next_request (dpyinfo);
+ x_ignore_errors_for_next_request (dpyinfo, 0);
XSendEvent (FRAME_X_DISPLAY (f), target, False, NoEventMask, &msg);
x_stop_ignoring_errors (dpyinfo);
}
@@ -4619,7 +4725,7 @@ x_dnd_send_drop (struct frame *f, Window target, Window toplevel,
if (supported >= 1)
msg.xclient.data.l[2] = timestamp;
- x_ignore_errors_for_next_request (dpyinfo);
+ x_ignore_errors_for_next_request (dpyinfo, 0);
XSendEvent (FRAME_X_DISPLAY (f), target, False, NoEventMask, &msg);
x_stop_ignoring_errors (dpyinfo);
return true;
@@ -4842,6 +4948,11 @@ x_dnd_cleanup_drag_and_drop (void *frame)
x_restore_events_after_dnd (f, &x_dnd_old_window_attrs);
}
+
+
+/* Primitives for simplified drag-and-drop tracking when items are
+ being dragged between frames comprising the same Emacs session. */
+
static void
x_dnd_note_self_position (struct x_display_info *dpyinfo, Window target,
unsigned short root_x, unsigned short root_y)
@@ -4925,7 +5036,7 @@ x_dnd_note_self_drop (struct x_display_info *dpyinfo, Window target,
XSETFRAME (lval, f);
x_dnd_action = None;
x_dnd_action_symbol
- = safe_call2 (Vx_dnd_native_test_function,
+ = safe_calln (Vx_dnd_native_test_function,
Fposn_at_x_y (make_fixnum (win_x),
make_fixnum (win_y),
lval, Qnil),
@@ -4972,6 +5083,10 @@ x_dnd_note_self_drop (struct x_display_info *dpyinfo, Window target,
kbd_buffer_store_event (&ie);
}
+
+
+/* Miscellaneous X event and graphics extension functions. */
+
/* Flush display of frame F. */
static void
@@ -5056,28 +5171,9 @@ 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
+/* Miscellaneous event handling functions. */
static void
x_toolkit_position (struct frame *f, int x, int y,
@@ -5222,10 +5318,36 @@ x_extension_initialize (struct x_display_info *dpyinfo)
#endif /* HAVE_CAIRO */
+
+
+/* X input extension device and event mask management functions. */
+
#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;
+}
+
/* Convert XI2 button state IN to a standard X button modifier
mask, and place it in OUT. */
+
static void
xi_convert_button_state (XIButtonState *in, unsigned int *out)
{
@@ -5247,7 +5369,7 @@ xi_convert_button_state (XIButtonState *in, unsigned int *out)
#ifdef USE_GTK
static
-#endif
+#endif /* USE_GTK */
unsigned int
xi_convert_event_state (XIDeviceEvent *xev)
{
@@ -5273,12 +5395,13 @@ xi_convert_event_keyboard_state (XIDeviceEvent *xev)
}
/* Free all XI2 devices on DPYINFO. */
+
static void
x_free_xi_devices (struct x_display_info *dpyinfo)
{
#ifdef HAVE_XINPUT2_2
struct xi_touch_point_t *tem, *last;
-#endif
+#endif /* HAVE_XINPUT2_2 */
block_input ();
@@ -5288,7 +5411,7 @@ x_free_xi_devices (struct x_display_info *dpyinfo)
{
#ifdef HAVE_XINPUT2_1
xfree (dpyinfo->devices[i].valuators);
-#endif
+#endif /* HAVE_XINPUT2_1 */
#ifdef HAVE_XINPUT2_2
tem = dpyinfo->devices[i].touchpoints;
@@ -5298,7 +5421,7 @@ x_free_xi_devices (struct x_display_info *dpyinfo)
tem = tem->next;
xfree (last);
}
-#endif
+#endif /* HAVE_XINPUT2_2 */
}
xfree (dpyinfo->devices);
@@ -5363,7 +5486,7 @@ xi_populate_scroll_valuator (struct xi_device_t *device,
valuator->number = info->number;
}
-#endif
+#endif /* HAVE_XINPUT2_1 */
static void
xi_populate_device_from_info (struct x_display_info *dpyinfo,
@@ -5375,14 +5498,14 @@ xi_populate_device_from_info (struct x_display_info *dpyinfo,
int actual_valuator_count, c;
XIScrollClassInfo *info;
XIValuatorClassInfo *valuator_info;
-#endif
+#endif /* HAVE_XINPUT2_1 */
#ifdef HAVE_XINPUT2_2
XITouchClassInfo *touch_info;
-#endif
+#endif /* HAVE_XINPUT2_2 */
#ifdef HAVE_XINPUT2_1
USE_SAFE_ALLOCA;
-#endif
+#endif /* HAVE_XINPUT2_1 */
/* Initialize generic information about the device: its ID, which
buttons are currently pressed and thus presumably actively
@@ -5419,12 +5542,24 @@ xi_populate_device_from_info (struct x_display_info *dpyinfo,
no input.
The device attachment is a device ID whose meaning varies
- depending on the device use. If the device is a master device,
- then the attachment is the device ID of the other device in its
- seat (the master keyboard for master pointer devices, and vice
- versa). Otherwise, it is the ID of the master device the slave
+ depending on the device's use. If a device is a master device,
+ then its attachment is the device ID of the other device in its
+ seat (the master keyboard for master pointer devices and vice
+ versa.) Otherwise, it is the ID of the master device the slave
device is attached to. For slave devices not attached to any
- seat, its value is undefined. */
+ seat, its value is undefined.
+
+ Emacs receives ordinary pointer and keyboard events from the
+ master devices associated with each seat, discarding events from
+ slave devices. However, multiplexing events from touch devices
+ onto a master device poses problems: if both dependent and direct
+ touch devices are attached to the same master pointer device, the
+ coordinate space of touch events sent from that seat becomes
+ ambiguous. In addition, the X server does not send TouchEnd
+ events to cancel ongoing touch sequences if the slave device that
+ is their source is detached. As a result of these ambiguities,
+ touch events are processed from and recorded onto their slave
+ devices instead. */
xi_device->device_id = device->deviceid;
xi_device->grab = 0;
@@ -5438,7 +5573,7 @@ xi_populate_device_from_info (struct x_display_info *dpyinfo,
#ifdef HAVE_XINPUT2_2
xi_device->touchpoints = NULL;
xi_device->direct_p = false;
-#endif
+#endif /* HAVE_XINPUT2_1 */
#ifdef HAVE_XINPUT2_1
if (!dpyinfo->xi2_version)
@@ -5504,9 +5639,34 @@ xi_populate_device_from_info (struct x_display_info *dpyinfo,
case XITouchClass:
{
touch_info = (XITouchClassInfo *) device->classes[c];
- xi_device->direct_p = touch_info->mode == XIDirectTouch;
+
+ /* touch_info->mode indicates the coordinate space that
+ this device reports in its touch events.
+
+ DirectTouch means that the device uses a coordinate
+ space that corresponds to locations on the screen. It
+ is set by touch screen devices which are overlaid
+ over the raster itself.
+
+ The other value (DependentTouch) means that the device
+ uses a separate abstract coordinate space corresponding
+ to its own surface. Emacs ignores events from these
+ devices because it does not support recognizing touch
+ gestures from surfaces other than the screen.
+
+ Master devices may report multiple touch classes for
+ attached slave devices, leaving the nature of touch
+ events they send ambiguous. The problem of
+ discriminating between these events is bypassed
+ entirely through only processing touch events from the
+ slave devices where they originate. */
+
+ if (touch_info->mode == XIDirectTouch)
+ xi_device->direct_p = true;
+ else
+ xi_device->direct_p = false;
}
-#endif
+#endif /* HAVE_XINPUT2_2 */
default:
break;
}
@@ -5533,7 +5693,7 @@ xi_populate_device_from_info (struct x_display_info *dpyinfo,
}
SAFE_FREE ();
-#endif
+#endif /* HAVE_XINPUT2_1 */
}
/* Populate our client-side record of all devices, which includes
@@ -5664,26 +5824,41 @@ xi_device_from_id (struct x_display_info *dpyinfo, int deviceid)
#ifdef HAVE_XINPUT2_2
+/* Record a touch sequence with the identifier DETAIL from the given
+ FRAME on the specified DEVICE. Round X and Y and record them as
+ its current position. */
+
static void
xi_link_touch_point (struct xi_device_t *device,
- int detail, double x, double y)
+ int detail, double x, double y,
+ struct frame *frame)
{
struct xi_touch_point_t *touchpoint;
touchpoint = xmalloc (sizeof *touchpoint);
touchpoint->next = device->touchpoints;
- touchpoint->x = x;
- touchpoint->y = y;
+ touchpoint->x = lrint (x);
+ touchpoint->y = lrint (y);
touchpoint->number = detail;
+ touchpoint->frame = frame;
+ touchpoint->ownership = TOUCH_OWNERSHIP_NONE;
device->touchpoints = touchpoint;
}
-static bool
-xi_unlink_touch_point (int detail,
- struct xi_device_t *device)
+/* Free and remove the touch sequence with the identifier DETAIL.
+ DEVICE is the device in which the touch sequence should be
+ recorded.
+
+ Value is 0 if no touch sequence by that identifier exists inside
+ DEVICE, 1 if a touch sequence has been found but is not owned by
+ Emacs, and 2 otherwise. */
+
+static int
+xi_unlink_touch_point (int detail, struct xi_device_t *device)
{
struct xi_touch_point_t *last, *tem;
+ enum xi_touch_ownership ownership;
for (last = NULL, tem = device->touchpoints; tem;
last = tem, tem = tem->next)
@@ -5695,14 +5870,53 @@ xi_unlink_touch_point (int detail,
else
last->next = tem->next;
+ ownership = tem->ownership;
xfree (tem);
- return true;
+
+ if (ownership == TOUCH_OWNERSHIP_SELF)
+ return 2;
+
+ return 1;
}
}
- return false;
+ return 0;
+}
+
+/* Unlink all touch points associated with the frame F.
+ This is done upon unmapping or destroying F's window, because
+ touch point delivery after that point is undefined. */
+
+static void
+xi_unlink_touch_points (struct frame *f)
+{
+ struct xi_device_t *device;
+ struct xi_touch_point_t **next, *last;
+ int i;
+
+ for (i = 0; i < FRAME_DISPLAY_INFO (f)->num_devices; ++i)
+ {
+ device = &FRAME_DISPLAY_INFO (f)->devices[i];
+
+ /* Now unlink all touch points on DEVICE matching F. */
+
+ for (next = &device->touchpoints; (last = *next);)
+ {
+ if (last->frame == f)
+ {
+ *next = last->next;
+ xfree (last);
+ }
+ else
+ next = &last->next;
+ }
+ }
}
+/* Return the data associated with a touch sequence DETAIL recorded by
+ `xi_link_touch_point' from DEVICE, or NULL if it can't be
+ found. */
+
static struct xi_touch_point_t *
xi_find_touch_point (struct xi_device_t *device, int detail)
{
@@ -5748,8 +5962,12 @@ xi_reset_scroll_valuators_for_device_id (struct x_display_info *dpyinfo,
}
#endif /* HAVE_XINPUT2_1 */
+#endif /* HAVE_XINPUT2 */
-#endif
+
+
+/* Cairo context, X rendering extension, and GC auxiliary data
+ management functions. */
#ifdef USE_CAIRO
@@ -6235,6 +6453,7 @@ x_cr_export_frames (Lisp_Object frames, cairo_surface_type_t surface_type)
#endif /* USE_CAIRO */
#if defined HAVE_XRENDER
+
void
x_xr_apply_ext_clip (struct frame *f, GC gc)
{
@@ -6258,7 +6477,8 @@ x_xr_reset_ext_clip (struct frame *f)
FRAME_X_PICTURE (f),
CPClipMask, &attrs);
}
-#endif
+
+#endif /* HAVE_XRENDER */
static void
x_set_clip_rectangles (struct frame *f, GC gc, XRectangle *rectangles, int n)
@@ -6462,6 +6682,9 @@ x_fill_rectangle (struct frame *f, GC gc, int x, int y, int width, int height,
#endif
}
+
+
+/* Graphics primitives. */
static void
x_clear_rectangle (struct frame *f, GC gc, int x, int y, int width, int height,
@@ -6733,7 +6956,7 @@ x_set_frame_alpha (struct frame *f)
Do this unconditionally as this function is called on reparent when
alpha has not changed on the frame. */
- x_ignore_errors_for_next_request (dpyinfo);
+ x_ignore_errors_for_next_request (dpyinfo, 0);
if (!FRAME_PARENT_FRAME (f))
{
@@ -6754,6 +6977,8 @@ x_set_frame_alpha (struct frame *f)
x_stop_ignoring_errors (dpyinfo);
}
+
+
/***********************************************************************
Starting and ending an update
***********************************************************************/
@@ -6829,8 +7054,7 @@ x_sync_get_monotonic_time (struct x_display_info *dpyinfo,
return 0;
uint_fast64_t t;
- return (INT_SUBTRACT_WRAPV (timestamp, dpyinfo->server_time_offset, &t)
- ? 0 : t);
+ return ckd_sub (&t, timestamp, dpyinfo->server_time_offset) ? 0 : t;
}
# ifndef CLOCK_MONOTONIC
@@ -6848,8 +7072,8 @@ x_sync_current_monotonic_time (void)
return (((clock_gettime (CLOCK_MONOTONIC, &time) != 0
&& (CLOCK_MONOTONIC == CLOCK_REALTIME
|| clock_gettime (CLOCK_REALTIME, &time) != 0))
- || INT_MULTIPLY_WRAPV (time.tv_sec, 1000000, &t)
- || INT_ADD_WRAPV (t, time.tv_nsec / 1000, &t))
+ || ckd_mul (&t, time.tv_sec, 1000000)
+ || ckd_add (&t, t, time.tv_nsec / 1000))
? 0 : t);
}
@@ -6870,8 +7094,7 @@ x_sync_note_frame_times (struct x_display_info *dpyinfo,
time = x_sync_get_monotonic_time (dpyinfo, low | (high << 32));
if (!time || !output->temp_frame_time
- || INT_SUBTRACT_WRAPV (time, output->temp_frame_time,
- &output->last_frame_time))
+ || ckd_sub (&output->last_frame_time, time, output->temp_frame_time))
output->last_frame_time = 0;
#ifdef FRAME_DEBUG
@@ -6909,6 +7132,7 @@ static void
x_sync_wait_for_frame_drawn_event (struct frame *f)
{
XEvent event;
+ struct x_display_info *dpyinfo;
if (!FRAME_X_WAITING_FOR_DRAW (f)
/* The compositing manager can't draw a frame if it is
@@ -6916,6 +7140,8 @@ x_sync_wait_for_frame_drawn_event (struct frame *f)
|| !FRAME_VISIBLE_P (f))
return;
+ dpyinfo = FRAME_DISPLAY_INFO (f);
+
/* Wait for the frame drawn message to arrive. */
if (x_if_event (FRAME_X_DISPLAY (f), &event,
x_sync_is_frame_drawn_event, (XPointer) f,
@@ -6931,6 +7157,11 @@ x_sync_wait_for_frame_drawn_event (struct frame *f)
"been disabled\n");
FRAME_X_OUTPUT (f)->use_vsync_p = false;
+ /* Remove the compositor bypass property from the outer
+ window. */
+ XDeleteProperty (dpyinfo->display, FRAME_OUTER_WINDOW (f),
+ dpyinfo->Xatom_net_wm_bypass_compositor);
+
/* Also change the frame parameter to reflect the new
state. */
store_frame_param (f, Quse_frame_synchronization, Qnil);
@@ -6944,7 +7175,7 @@ x_sync_wait_for_frame_drawn_event (struct frame *f)
}
}
else
- x_sync_note_frame_times (FRAME_DISPLAY_INFO (f), f, &event);
+ x_sync_note_frame_times (dpyinfo, f, &event);
FRAME_X_WAITING_FOR_DRAW (f) = false;
}
@@ -7061,6 +7292,11 @@ x_sync_init_fences (struct frame *f)
&& dpyinfo->xsync_minor < 1))
return;
+ /* Suppress errors around XSyncCreateFence requests, since its
+ implementations on certain X servers erroneously reject valid
+ drawables, such as the frame's inner window. (bug#69762) */
+
+ x_catch_errors (dpyinfo->display);
output->sync_fences[0]
= XSyncCreateFence (FRAME_X_DISPLAY (f),
/* The drawable given below is only used to
@@ -7072,6 +7308,9 @@ x_sync_init_fences (struct frame *f)
= XSyncCreateFence (FRAME_X_DISPLAY (f),
FRAME_X_WINDOW (f),
False);
+ if (x_had_errors_p (dpyinfo->display))
+ output->sync_fences[1] = output->sync_fences[0] = None;
+ x_uncatch_errors_after_check ();
XChangeProperty (FRAME_X_DISPLAY (f), FRAME_OUTER_WINDOW (f),
dpyinfo->Xatom_net_wm_sync_fences, XA_CARDINAL,
@@ -7443,6 +7682,8 @@ XTbuffer_flipping_unblocked_hook (struct frame *f)
}
#endif
+
+
/**
* x_clear_under_internal_border:
*
@@ -7458,14 +7699,16 @@ x_clear_under_internal_border (struct frame *f)
int width = FRAME_PIXEL_WIDTH (f);
int height = FRAME_PIXEL_HEIGHT (f);
int margin = FRAME_TOP_MARGIN_HEIGHT (f);
- int face_id =
- (FRAME_PARENT_FRAME (f)
- ? (!NILP (Vface_remapping_alist)
- ? lookup_basic_face (NULL, f, CHILD_FRAME_BORDER_FACE_ID)
- : CHILD_FRAME_BORDER_FACE_ID)
- : (!NILP (Vface_remapping_alist)
- ? lookup_basic_face (NULL, f, INTERNAL_BORDER_FACE_ID)
- : INTERNAL_BORDER_FACE_ID));
+ int bottom_margin = FRAME_BOTTOM_MARGIN_HEIGHT (f);
+ int face_id = (FRAME_PARENT_FRAME (f)
+ ? (!NILP (Vface_remapping_alist)
+ ? lookup_basic_face (NULL, f,
+ CHILD_FRAME_BORDER_FACE_ID)
+ : CHILD_FRAME_BORDER_FACE_ID)
+ : (!NILP (Vface_remapping_alist)
+ ? lookup_basic_face (NULL, f,
+ INTERNAL_BORDER_FACE_ID)
+ : INTERNAL_BORDER_FACE_ID));
struct face *face = FACE_FROM_ID_OR_NULL (f, face_id);
if (face)
@@ -7478,7 +7721,8 @@ x_clear_under_internal_border (struct frame *f)
x_fill_rectangle (f, gc, 0, margin, width, border, false);
x_fill_rectangle (f, gc, 0, 0, border, height, false);
x_fill_rectangle (f, gc, width - border, 0, border, height, false);
- x_fill_rectangle (f, gc, 0, height - border, width, border, false);
+ x_fill_rectangle (f, gc, 0, height - bottom_margin - border,
+ width, border, false);
XSetForeground (display, gc, FRAME_FOREGROUND_PIXEL (f));
}
else
@@ -7486,7 +7730,8 @@ x_clear_under_internal_border (struct frame *f)
x_clear_area (f, 0, 0, border, height);
x_clear_area (f, 0, margin, width, border);
x_clear_area (f, width - border, 0, border, height);
- x_clear_area (f, 0, height - border, width, border);
+ x_clear_area (f, 0, height - bottom_margin - border,
+ width, border);
}
}
}
@@ -7557,6 +7802,46 @@ x_after_update_window_line (struct window *w, struct glyph_row *desired_row)
#endif
}
+/* Generate a premultiplied pixel value for COLOR with ALPHA applied
+ on the given display. COLOR will be modified. The display must
+ use a visual that supports an alpha channel.
+
+ This is possibly dead code on builds which do not support
+ XRender. */
+
+#ifndef USE_CAIRO
+
+static unsigned long
+x_premultiply_pixel (struct x_display_info *dpyinfo,
+ XColor *color, double alpha)
+{
+ unsigned long pixel;
+
+ eassert (dpyinfo->alpha_bits);
+
+ /* Multiply the RGB channels. */
+ color->red *= alpha;
+ color->green *= alpha;
+ color->blue *= alpha;
+
+ /* First, allocate a fully opaque pixel. */
+ pixel = x_make_truecolor_pixel (dpyinfo, color->red,
+ color->green,
+ color->blue);
+
+ /* Next, erase the alpha component. */
+ pixel &= ~dpyinfo->alpha_mask;
+
+ /* And add an alpha channel. */
+ pixel |= (((unsigned long) (alpha * 65535)
+ >> (16 - dpyinfo->alpha_bits))
+ << dpyinfo->alpha_offset);
+
+ return pixel;
+}
+
+#endif
+
static void
x_draw_fringe_bitmap (struct window *w, struct glyph_row *row,
struct draw_fringe_bitmap_params *p)
@@ -7565,9 +7850,10 @@ x_draw_fringe_bitmap (struct window *w, struct glyph_row *row,
Display *display = FRAME_X_DISPLAY (f);
GC gc = f->output_data.x->normal_gc;
struct face *face = p->face;
+ XRectangle clip_rect;
/* Must clip because of partially visible lines. */
- x_clip_to_row (w, row, ANY_AREA, gc);
+ x_clip_to_row (w, row, ANY_AREA, gc, &clip_rect);
if (p->bx >= 0 && !p->overlay_p)
{
@@ -7637,6 +7923,29 @@ x_draw_fringe_bitmap (struct window *w, struct glyph_row *row,
memset (&attrs, 0, sizeof attrs);
#endif
+ XRectangle image_rect, dest;
+ int px, py, pwidth, pheight;
+
+ /* Intersect the destination rectangle with that of the row.
+ Setting a clip mask overrides the clip rectangles provided by
+ x_clip_to_row, so clipping must be performed by hand. */
+
+ image_rect.x = p->x;
+ image_rect.y = p->y;
+ image_rect.width = p->wd;
+ image_rect.height = p->h;
+
+ if (!gui_intersect_rectangles (&clip_rect, &image_rect, &dest))
+ /* The entire destination rectangle falls outside the row. */
+ goto undo_clip;
+
+ /* Extrapolate the source rectangle from the difference between
+ the destination and image rectangles. */
+
+ px = dest.x - image_rect.x;
+ py = dest.y - image_rect.y;
+ pwidth = dest.width;
+ pheight = dest.height;
if (p->wd > 8)
bits = (char *) (p->bits + p->dh);
@@ -7646,18 +7955,15 @@ x_draw_fringe_bitmap (struct window *w, struct glyph_row *row,
if (FRAME_DISPLAY_INFO (f)->alpha_bits
&& f->alpha_background < 1.0)
{
+ /* Extend the background color with an alpha channel
+ according to f->alpha_background. */
bg.pixel = background;
x_query_colors (f, &bg, 1);
- bg.red *= f->alpha_background;
- bg.green *= f->alpha_background;
- bg.blue *= f->alpha_background;
- background = x_make_truecolor_pixel (FRAME_DISPLAY_INFO (f),
- bg.red, bg.green, bg.blue);
- background &= ~FRAME_DISPLAY_INFO (f)->alpha_mask;
- background |= (((unsigned long) (f->alpha_background * 0xffff)
- >> (16 - FRAME_DISPLAY_INFO (f)->alpha_bits))
- << FRAME_DISPLAY_INFO (f)->alpha_offset);
+ background
+ = x_premultiply_pixel (FRAME_DISPLAY_INFO (f),
+ &bg,
+ f->alpha_background);
}
/* Draw the bitmap. I believe these small pixmaps can be cached
@@ -7711,15 +8017,16 @@ x_draw_fringe_bitmap (struct window *w, struct glyph_row *row,
x_xr_apply_ext_clip (f, gc);
XRenderComposite (display, PictOpSrc, picture,
None, FRAME_X_PICTURE (f),
- 0, 0, 0, 0, p->x, p->y, p->wd, p->h);
+ px, py, px, py, dest.x, dest.y,
+ pwidth, pheight);
x_xr_reset_ext_clip (f);
XRenderFreePicture (display, picture);
}
else
#endif
- XCopyArea (display, pixmap, drawable, gc, 0, 0,
- p->wd, p->h, p->x, p->y);
+ XCopyArea (display, pixmap, drawable, gc, px, py,
+ pwidth, pheight, dest.x, dest.y);
XFreePixmap (display, pixmap);
if (p->overlay_p)
@@ -7729,6 +8036,8 @@ x_draw_fringe_bitmap (struct window *w, struct glyph_row *row,
XFreePixmap (display, clipmask);
}
}
+
+ undo_clip:
#endif /* not USE_CAIRO */
x_reset_clip_rectangles (f, gc);
@@ -7802,7 +8111,7 @@ x_display_set_last_user_time (struct x_display_info *dpyinfo, Time time,
dpyinfo->server_time_monotonic_p
= (monotonic_time != 0
- && !INT_SUBTRACT_WRAPV (time, monotonic_ms, &diff_ms)
+ && !ckd_sub (&diff_ms, time, monotonic_ms)
&& -500 < diff_ms && diff_ms < 500);
if (!dpyinfo->server_time_monotonic_p)
@@ -7811,10 +8120,9 @@ x_display_set_last_user_time (struct x_display_info *dpyinfo, Time time,
time to estimate the monotonic time on the X server. */
if (!monotonic_time
- || INT_MULTIPLY_WRAPV (time, 1000, &dpyinfo->server_time_offset)
- || INT_SUBTRACT_WRAPV (dpyinfo->server_time_offset,
- monotonic_time,
- &dpyinfo->server_time_offset))
+ || ckd_mul (&dpyinfo->server_time_offset, time, 1000)
+ || ckd_sub (&dpyinfo->server_time_offset,
+ dpyinfo->server_time_offset, monotonic_time))
dpyinfo->server_time_offset = 0;
/* If the server time is reasonably close to the monotonic
@@ -7823,18 +8131,18 @@ x_display_set_last_user_time (struct x_display_info *dpyinfo, Time time,
actual time in ms. */
monotonic_ms = monotonic_ms & 0xffffffff;
- if (!INT_SUBTRACT_WRAPV (time, monotonic_ms, &diff_ms)
+ if (!ckd_sub (&diff_ms, time, monotonic_ms)
&& -500 < diff_ms && diff_ms < 500)
{
/* The server timestamp overflowed. Make the time
offset exactly how much it overflowed by. */
- if (INT_SUBTRACT_WRAPV (monotonic_time / 1000, monotonic_ms,
- &dpyinfo->server_time_offset)
- || INT_MULTIPLY_WRAPV (dpyinfo->server_time_offset,
- 1000, &dpyinfo->server_time_offset)
- || INT_SUBTRACT_WRAPV (0, dpyinfo->server_time_offset,
- &dpyinfo->server_time_offset))
+ if (ckd_sub (&dpyinfo->server_time_offset,
+ monotonic_time / 1000, monotonic_ms)
+ || ckd_mul (&dpyinfo->server_time_offset,
+ dpyinfo->server_time_offset, 1000)
+ || ckd_sub (&dpyinfo->server_time_offset,
+ 0, dpyinfo->server_time_offset))
dpyinfo->server_time_offset = 0;
}
}
@@ -8806,7 +9114,11 @@ x_color_cells (Display *dpy, int *ncells)
/* On frame F, translate pixel colors to RGB values for the NCOLORS
- colors in COLORS. Use cached information, if available. */
+ colors in COLORS. Use cached information, if available.
+
+ Pixel values are in unsigned normalized format, meaning that
+ extending missing bits is done straightforwardly without any
+ complex colorspace conversions. */
void
x_query_colors (struct frame *f, XColor *colors, int ncolors)
@@ -8854,6 +9166,7 @@ x_query_colors (struct frame *f, XColor *colors, int ncolors)
colors[i].green = (g * gmult) >> 16;
colors[i].blue = (b * bmult) >> 16;
}
+
return;
}
@@ -8896,16 +9209,10 @@ x_query_frame_background_color (struct frame *f, XColor *bgcolor)
{
bg.pixel = background;
x_query_colors (f, &bg, 1);
- bg.red *= f->alpha_background;
- bg.green *= f->alpha_background;
- bg.blue *= f->alpha_background;
- background = x_make_truecolor_pixel (FRAME_DISPLAY_INFO (f),
- bg.red, bg.green, bg.blue);
- background &= ~FRAME_DISPLAY_INFO (f)->alpha_mask;
- background |= (((unsigned long) (f->alpha_background * 0xffff)
- >> (16 - FRAME_DISPLAY_INFO (f)->alpha_bits))
- << FRAME_DISPLAY_INFO (f)->alpha_offset);
+ background
+ = x_premultiply_pixel (FRAME_DISPLAY_INFO (f),
+ &bg, f->alpha_background);
}
#endif
}
@@ -10995,6 +11302,31 @@ x_clear_frame (struct frame *f)
unblock_input ();
}
+/* Send a message to frame F telling the event loop to track whether
+ or not an hourglass is being displayed. This is required to ignore
+ the right events when the hourglass is mapped without calling XSync
+ after displaying or hiding the hourglass. */
+
+static void
+x_send_hourglass_message (struct frame *f, bool hourglass_enabled)
+{
+ struct x_display_info *dpyinfo;
+ XEvent msg;
+
+ dpyinfo = FRAME_DISPLAY_INFO (f);
+ memset (&msg, 0, sizeof msg);
+
+ msg.xclient.type = ClientMessage;
+ msg.xclient.message_type
+ = dpyinfo->Xatom_EMACS_TMP;
+ msg.xclient.format = 8;
+ msg.xclient.window = FRAME_X_WINDOW (f);
+ msg.xclient.data.b[0] = hourglass_enabled ? 1 : 0;
+
+ XSendEvent (dpyinfo->display, FRAME_X_WINDOW (f),
+ False, NoEventMask, &msg);
+}
+
/* RIF: Show hourglass cursor on frame F. */
static void
@@ -11015,14 +11347,14 @@ x_show_hourglass (struct frame *f)
if (popup_activated ())
return;
+ x_send_hourglass_message (f, true);
+
#ifdef USE_X_TOOLKIT
if (x->widget)
#else
if (FRAME_OUTER_WINDOW (f))
#endif
{
- x->hourglass_p = true;
-
if (!x->hourglass_window)
{
#ifndef USE_XCB
@@ -11089,15 +11421,11 @@ x_hide_hourglass (struct frame *f)
{
#ifndef USE_XCB
XUnmapWindow (FRAME_X_DISPLAY (f), x->hourglass_window);
- /* Sync here because XTread_socket looks at the
- hourglass_p flag that is reset to zero below. */
- XSync (FRAME_X_DISPLAY (f), False);
#else
xcb_unmap_window (FRAME_DISPLAY_INFO (f)->xcb_connection,
(xcb_window_t) x->hourglass_window);
- xcb_aux_sync (FRAME_DISPLAY_INFO (f)->xcb_connection);
#endif
- x->hourglass_p = false;
+ x_send_hourglass_message (f, false);
}
}
@@ -11146,7 +11474,8 @@ XTflash (struct frame *f)
XFillRectangle (FRAME_X_DISPLAY (f), FRAME_X_WINDOW (f), gc,
flash_left,
(height - flash_height
- - FRAME_INTERNAL_BORDER_WIDTH (f)),
+ - FRAME_INTERNAL_BORDER_WIDTH (f)
+ - FRAME_BOTTOM_MARGIN_HEIGHT (f)),
width, flash_height);
}
@@ -11200,7 +11529,8 @@ XTflash (struct frame *f)
XFillRectangle (FRAME_X_DISPLAY (f), FRAME_X_WINDOW (f), gc,
flash_left,
(height - flash_height
- - FRAME_INTERNAL_BORDER_WIDTH (f)),
+ - FRAME_INTERNAL_BORDER_WIDTH (f)
+ - FRAME_BOTTOM_MARGIN_HEIGHT (f)),
width, flash_height);
}
else
@@ -11221,21 +11551,32 @@ XTflash (struct frame *f)
static void
XTring_bell (struct frame *f)
{
- if (FRAME_X_DISPLAY (f))
+ struct x_display_info *dpyinfo;
+
+ if (!FRAME_X_DISPLAY (f))
+ return;
+
+ dpyinfo = FRAME_DISPLAY_INFO (f);
+
+ if (visible_bell)
+ XTflash (f);
+ else
{
- if (visible_bell)
- XTflash (f);
- else
- {
- block_input ();
+ /* When Emacs is untrusted, Bell requests sometimes generate
+ Access errors. This is not in the security extension
+ specification but seems to be a bug in the X consortium XKB
+ implementation. */
+
+ block_input ();
+ x_ignore_errors_for_next_request (dpyinfo, 0);
#ifdef HAVE_XKB
- XkbBell (FRAME_X_DISPLAY (f), None, 0, None);
+ XkbBell (FRAME_X_DISPLAY (f), FRAME_X_WINDOW (f), 0, None);
#else
- XBell (FRAME_X_DISPLAY (f), 0);
+ XBell (FRAME_X_DISPLAY (f), 0);
#endif
- XFlush (FRAME_X_DISPLAY (f));
- unblock_input ();
- }
+ XFlush (FRAME_X_DISPLAY (f));
+ x_stop_ignoring_errors (dpyinfo);
+ unblock_input ();
}
}
@@ -11481,7 +11822,7 @@ x_frame_highlight (struct frame *f)
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). */
- x_ignore_errors_for_next_request (dpyinfo);
+ x_ignore_errors_for_next_request (dpyinfo, 0);
XSetWindowBorder (FRAME_X_DISPLAY (f), FRAME_X_WINDOW (f),
f->output_data.x->border_pixel);
x_stop_ignoring_errors (dpyinfo);
@@ -11506,7 +11847,7 @@ x_frame_unhighlight (struct frame *f)
block_input ();
/* Same as above for XSetWindowBorder (bug#9310). */
- x_ignore_errors_for_next_request (dpyinfo);
+ x_ignore_errors_for_next_request (dpyinfo, 0);
XSetWindowBorderPixmap (FRAME_X_DISPLAY (f), FRAME_X_WINDOW (f),
f->output_data.x->border_tile);
x_stop_ignoring_errors (dpyinfo);
@@ -11578,7 +11919,7 @@ x_new_focus_frame (struct x_display_info *dpyinfo, struct frame *frame)
x_frame_rehighlight (dpyinfo);
}
-#ifdef HAVE_XFIXES
+#if defined HAVE_XFIXES && XFIXES_VERSION >= 40000
/* True if the display in DPYINFO supports a version of Xfixes
sufficient for pointer blanking. */
@@ -11590,11 +11931,12 @@ x_fixes_pointer_blanking_supported (struct x_display_info *dpyinfo)
&& dpyinfo->xfixes_major >= 4);
}
-#endif /* HAVE_XFIXES */
+#endif /* HAVE_XFIXES && XFIXES_VERSION >= 40000 */
/* Toggle mouse pointer visibility on frame F using the XFixes
extension. */
-#ifdef HAVE_XFIXES
+#if defined HAVE_XFIXES && XFIXES_VERSION >= 40000
+
static void
xfixes_toggle_visible_pointer (struct frame *f, bool invisible)
@@ -11605,6 +11947,7 @@ xfixes_toggle_visible_pointer (struct frame *f, bool invisible)
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. */
@@ -11653,7 +11996,7 @@ x_toggle_visible_pointer (struct frame *f, bool invisible)
if (dpyinfo->invisible_cursor == None)
dpyinfo->invisible_cursor = make_invisible_cursor (dpyinfo);
-#ifndef HAVE_XFIXES
+#if !defined HAVE_XFIXES || XFIXES_VERSION < 40000
if (dpyinfo->invisible_cursor == None)
invisible = false;
#else
@@ -11686,7 +12029,7 @@ static void
XTtoggle_invisible_pointer (struct frame *f, bool invisible)
{
block_input ();
-#ifdef HAVE_XFIXES
+#if defined HAVE_XFIXES && XFIXES_VERSION >= 40000
if (FRAME_DISPLAY_INFO (f)->fixes_pointer_blanking
&& x_fixes_pointer_blanking_supported (FRAME_DISPLAY_INFO (f)))
xfixes_toggle_visible_pointer (f, invisible);
@@ -12275,6 +12618,13 @@ x_dnd_begin_drag_and_drop (struct frame *f, Time time, Atom xaction,
struct xi_device_t *device;
#endif
+ if (FRAME_DISPLAY_INFO (f)->untrusted)
+ /* Untrusted clients cannot send messages to trusted clients or
+ read the window tree, so drag and drop will likely not work at
+ all. */
+ error ("Drag-and-drop is not possible when the client is"
+ " not trusted by the X server.");
+
base = SPECPDL_INDEX ();
/* Bind this here to avoid juggling bindings and SAFE_FREE in
@@ -12865,6 +13215,12 @@ x_dnd_begin_drag_and_drop (struct frame *f, Time time, Atom xaction,
#ifdef HAVE_XINPUT2
+/* Disable per-device keyboard focus tracking within X toolkit and GTK
+ 2.x builds, given that these builds receive updates to the keyboard
+ input focus as core events. */
+
+#if !defined USE_X_TOOLKIT && (!defined USE_GTK || defined HAVE_GTK3)
+
/* Since the input extension assigns a keyboard focus to each master
device, there is no longer a 1:1 correspondence between the
selected frame and the focus frame immediately after the keyboard
@@ -13022,13 +13378,12 @@ xi_focus_handle_for_device (struct x_display_info *dpyinfo,
frame's user time. */
x_display_set_last_user_time (dpyinfo, event->time,
event->send_event, false);
-
device->focus_frame = NULL;
/* So, unfortunately, the X Input Extension is implemented such
- that means XI_Leave events will not have their focus field
- set if the core focus is transferred to another window after
- an entry event that pretends to (or really does) set the
+ that XI_Leave events will not have their focus field set if
+ the core focus is transferred to another window after an
+ entry event that pretends to (or really does) set the
implicit focus. In addition, if the core focus is set, but
the extension focus on the client pointer is not, all
XI_Enter events will have their focus fields set, despite not
@@ -13076,6 +13431,8 @@ xi_focus_handle_for_device (struct x_display_info *dpyinfo,
xi_handle_focus_change (dpyinfo);
}
+#endif /* !USE_X_TOOLKIT && (!USE_GTK || HAVE_GTK3) */
+
static void
xi_handle_delete_frame (struct x_display_info *dpyinfo,
struct frame *f)
@@ -13104,6 +13461,7 @@ xi_handle_interaction (struct x_display_info *dpyinfo,
struct frame *f, struct xi_device_t *device,
Time time)
{
+#if !defined USE_X_TOOLKIT && (!defined USE_GTK || defined HAVE_GTK3)
bool change;
/* If DEVICE is a pointer, use its attached keyboard device. */
@@ -13130,6 +13488,7 @@ xi_handle_interaction (struct x_display_info *dpyinfo,
/* If F isn't currently focused, update the focus state. */
if (change && f != dpyinfo->x_focus_frame)
xi_handle_focus_change (dpyinfo);
+#endif /* !USE_X_TOOLKIT && (!USE_GTK || HAVE_GTK3) */
}
/* Return whether or not XEV actually represents a change in the
@@ -13233,7 +13592,7 @@ xi_handle_new_classes (struct x_display_info *dpyinfo, struct xi_device_t *devic
device->scroll_valuator_count = 0;
#ifdef HAVE_XINPUT2_2
device->direct_p = false;
-#endif
+#endif /* HAVE_XINPUT2_2 */
for (i = 0; i < num_classes; ++i)
{
@@ -13251,10 +13610,34 @@ xi_handle_new_classes (struct x_display_info *dpyinfo, struct xi_device_t *devic
case XITouchClass:
touch = (XITouchClassInfo *) classes[i];
+ /* touch_info->mode indicates the coordinate space that this
+ device reports in its touch events.
+
+ DirectTouch means that the device uses a coordinate space
+ that corresponds to locations on the screen. It is set
+ by touch screen devices which are overlaid over the
+ raster itself.
+
+ The other value (DependentTouch) means that the device
+ uses a separate abstract coordinate space corresponding
+ to its own surface. Emacs ignores events from these
+ devices because it does not support recognizing touch
+ gestures from surfaces other than the screen.
+
+ Master devices may report multiple touch classes for
+ attached slave devices, leaving the nature of touch
+ events they send ambiguous. The problem of
+ discriminating between these events is bypassed entirely
+ through only processing touch events from the slave
+ devices where they originate. */
+
if (touch->mode == XIDirectTouch)
device->direct_p = true;
+ else
+ device->direct_p = false;
+
break;
-#endif
+#endif /* HAVE_XINPUT2_2 */
}
}
@@ -13292,7 +13675,7 @@ xi_handle_new_classes (struct x_display_info *dpyinfo, struct xi_device_t *devic
}
}
-#endif
+#endif /* HAVE_XINPUT2_1 */
/* Handle EVENT, a DeviceChanged event. Look up the device that
changed, and update its information with the data in EVENT. */
@@ -13380,6 +13763,10 @@ xi_disable_devices (struct x_display_info *dpyinfo,
#ifdef HAVE_XINPUT2_2
struct xi_touch_point_t *tem, *last;
#endif
+#if defined HAVE_XINPUT2_2 && !defined HAVE_EXT_TOOL_BAR
+ struct x_output *output;
+ Lisp_Object tail, frame;
+#endif
/* Don't pointlessly copy dpyinfo->devices if there are no devices
to disable. */
@@ -13422,6 +13809,34 @@ xi_disable_devices (struct x_display_info *dpyinfo,
tem = tem->next;
xfree (last);
}
+
+#ifndef HAVE_EXT_TOOL_BAR
+
+ /* Now look through each frame on DPYINFO. If it has an
+ outstanding tool bar press for this device, release
+ the tool bar. */
+
+ FOR_EACH_FRAME (tail, frame)
+ {
+ if (!FRAME_X_P (XFRAME (frame))
+ || (FRAME_DISPLAY_INFO (XFRAME (frame))
+ != dpyinfo))
+ continue;
+
+ output = FRAME_OUTPUT_DATA (XFRAME (frame));
+
+ if (output->tool_bar_touch_device
+ == dpyinfo->devices[i].device_id)
+ {
+ if (XFRAME (frame)->last_tool_bar_item != -1
+ && WINDOWP (XFRAME (frame)->tool_bar_window))
+ handle_tool_bar_click (XFRAME (frame), 0, 0,
+ false, 0);
+
+ output->tool_bar_touch_device = 0;
+ }
+ }
+#endif
#endif
goto out;
@@ -15046,9 +15461,7 @@ x_send_scroll_bar_event (Lisp_Object window, enum scroll_bar_part part,
XClientMessageEvent *ev = &event.xclient;
struct window *w = XWINDOW (window);
struct frame *f = XFRAME (w->frame);
- intptr_t iw = (intptr_t) w;
verify (INTPTR_WIDTH <= 64);
- int sign_shift = INTPTR_WIDTH - 32;
/* Don't do anything if too many scroll bar events have been
sent but not received. */
@@ -15065,15 +15478,11 @@ x_send_scroll_bar_event (Lisp_Object window, enum scroll_bar_part part,
ev->window = FRAME_X_WINDOW (f);
ev->format = 32;
- /* A 32-bit X client can pass a window pointer through the X server
- as-is.
-
- A 64-bit client is in trouble because a pointer does not fit in
- the 32 bits given for ClientMessage data and will be truncated by
- Xlib. So use two slots and hope that X12 will resolve such
- issues someday. */
- ev->data.l[0] = iw >> 31 >> 1;
- ev->data.l[1] = sign_shift <= 0 ? iw : iw << sign_shift >> sign_shift;
+ /* These messages formerly contained a pointer to the window, but
+ now that information is kept internally. The following two
+ fields are thus zero. */
+ ev->data.l[0] = 0;
+ ev->data.l[1] = 0;
ev->data.l[2] = part;
ev->data.l[3] = portion;
ev->data.l[4] = whole;
@@ -18504,7 +18913,7 @@ handle_one_xevent (struct x_display_info *dpyinfo,
x_dnd_waiting_for_status_window = None;
else
{
- x_ignore_errors_for_next_request (dpyinfo);
+ x_ignore_errors_for_next_request (dpyinfo, 0);
XSendEvent (dpyinfo->display, target,
False, NoEventMask,
&x_dnd_pending_send_position);
@@ -18618,6 +19027,16 @@ handle_one_xevent (struct x_display_info *dpyinfo,
}
}
+ if (event->xclient.message_type == dpyinfo->Xatom_EMACS_TMP
+ && event->xclient.format == 8)
+ {
+ /* This is actually an hourglass message. Set whether or
+ not events from here on have the hourglass enabled. */
+
+ if (any)
+ FRAME_X_OUTPUT (any)->hourglass_p = event->xclient.data.b[0];
+ }
+
if (event->xclient.message_type == dpyinfo->Xatom_wm_protocols
&& event->xclient.format == 32)
{
@@ -19206,7 +19625,7 @@ handle_one_xevent (struct x_display_info *dpyinfo,
= xcb_get_property (dpyinfo->xcb_connection, 0,
(xcb_window_t) FRAME_OUTER_WINDOW (f),
(xcb_atom_t) dpyinfo->Xatom_net_wm_window_opacity,
- XCB_ATOM_CARDINAL, 0, 1);
+ XA_CARDINAL, 0, 1);
opacity_reply
= xcb_get_property_reply (dpyinfo->xcb_connection,
opacity_cookie, &error);
@@ -19215,9 +19634,9 @@ handle_one_xevent (struct x_display_info *dpyinfo,
free (error), rc = false;
else
rc = (opacity_reply->format == 32
- && (opacity_reply->type == XCB_ATOM_CARDINAL
- || opacity_reply->type == XCB_ATOM_ATOM
- || opacity_reply->type == XCB_ATOM_WINDOW)
+ && (opacity_reply->type == XA_CARDINAL
+ || opacity_reply->type == XA_ATOM
+ || opacity_reply->type == XA_WINDOW)
&& (xcb_get_property_value_length (opacity_reply) >= 4));
if (rc)
@@ -19833,15 +20252,24 @@ handle_one_xevent (struct x_display_info *dpyinfo,
#ifdef HAVE_XKB
int overflow;
unsigned int consumed;
+ KeySym sym;
if (dpyinfo->xkb_desc)
{
+ /* Translate the keycode into the keysym it
+ represents, using STATE. CONSUMED is set to the
+ modifier bits consumed while undertaking this
+ translation and should be subsequently ignored
+ during keysym translation. */
+
if (!XkbTranslateKeyCode (dpyinfo->xkb_desc,
xkey.keycode, xkey.state,
&consumed, &keysym))
goto done_keysym;
- overflow = 0;
+ /* Save the original keysym in case
+ XkbTranslateKeysym overflows. */
+ sym = keysym, overflow = 0;
nbytes = XkbTranslateKeySym (dpyinfo->display, &keysym,
xkey.state & ~consumed,
@@ -19853,7 +20281,11 @@ handle_one_xevent (struct x_display_info *dpyinfo,
copy_bufptr = SAFE_ALLOCA ((copy_bufsiz += overflow)
* sizeof *copy_bufptr);
overflow = 0;
- nbytes = XkbTranslateKeySym (dpyinfo->display, &keysym,
+
+ /* Use the original keysym derived from the
+ keycode translation in this second call to
+ XkbTranslateKeysym. */
+ nbytes = XkbTranslateKeySym (dpyinfo->display, &sym,
xkey.state & ~consumed,
(char *) copy_bufptr,
copy_bufsiz, &overflow);
@@ -19880,6 +20312,27 @@ handle_one_xevent (struct x_display_info *dpyinfo,
}
#endif
+ /* See if keysym should make Emacs quit. */
+
+ if (dpyinfo->quit_keysym)
+ {
+ if (keysym == dpyinfo->quit_keysym
+ && (xkey.time - dpyinfo->quit_keysym_time
+ <= 350))
+ {
+ Vquit_flag = Qt;
+ goto done_keysym;
+ }
+
+ if (keysym == dpyinfo->quit_keysym)
+ {
+ /* Otherwise, set the last time that keysym was
+ pressed. */
+ dpyinfo->quit_keysym_time = xkey.time;
+ goto done_keysym;
+ }
+ }
+
/* 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)
@@ -20179,6 +20632,14 @@ handle_one_xevent (struct x_display_info *dpyinfo,
}
#endif
+ /* Apply the fix for bug#57468 on GTK 3.x and no toolkit builds,
+ but not GTK+ 2.x and X toolkit builds, where it is required
+ to treat implicit focus correctly. (bug#65919) */
+#if defined USE_X_TOOLKIT || (defined USE_GTK && !defined HAVE_GTK3)
+ if (x_top_window_to_frame (dpyinfo, event->xcrossing.window))
+ x_detect_focus_change (dpyinfo, any, event, &inev.ie);
+#endif /* defined USE_X_TOOLKIT || (defined USE_GTK && !defined HAVE_GTK3) */
+
#ifdef HAVE_XINPUT2
/* For whatever reason, the X server continues to deliver
EnterNotify and LeaveNotify events despite us selecting for
@@ -20189,10 +20650,14 @@ handle_one_xevent (struct x_display_info *dpyinfo,
if (dpyinfo->supports_xi2)
goto OTHER;
-#endif
+#endif /* HAVE_XINPUT2 */
+ /* Apply the fix for bug#57468 on GTK 3.x and no toolkit
+ builds. */
+#if !defined USE_X_TOOLKIT || (!defined USE_GTK || defined HAVE_GTK3)
if (x_top_window_to_frame (dpyinfo, event->xcrossing.window))
x_detect_focus_change (dpyinfo, any, event, &inev.ie);
+#endif /* !defined USE_X_TOOLKIT || (!defined USE_GTK || defined HAVE_GTK3) */
f = any;
@@ -20253,8 +20718,8 @@ handle_one_xevent (struct x_display_info *dpyinfo,
https://lists.gnu.org/archive/html/emacs-devel/2017-02/msg00133.html.
That is fixed above but bites us here again.
- The option x_set_frame_visibility_more_laxly allows to override
- the default behavior (Bug#49955, Bug#53298). */
+ The option x_set_frame_visibility_more_laxly enables
+ overriding the default behavior (Bug#49955, Bug#53298). */
if (EQ (x_set_frame_visibility_more_laxly, Qfocus_in)
|| EQ (x_set_frame_visibility_more_laxly, Qt))
#endif /* USE_GTK */
@@ -20277,6 +20742,14 @@ handle_one_xevent (struct x_display_info *dpyinfo,
x_display_set_last_user_time (dpyinfo, event->xcrossing.time,
event->xcrossing.send_event, false);
+ /* Apply the fix for bug#57468 on GTK 3.x and no toolkit builds,
+ but not GTK+ 2.x and X toolkit builds, where it is required
+ to treat implicit focus correctly. */
+#if defined USE_X_TOOLKIT || (defined USE_GTK && !defined HAVE_GTK3)
+ if (x_top_window_to_frame (dpyinfo, event->xcrossing.window))
+ x_detect_focus_change (dpyinfo, any, event, &inev.ie);
+#endif /* defined USE_X_TOOLKIT || (defined USE_GTK && !defined HAVE_GTK3) */
+
#ifdef HAVE_XINPUT2
/* For whatever reason, the X server continues to deliver
EnterNotify and LeaveNotify events despite us selecting for
@@ -20289,7 +20762,7 @@ handle_one_xevent (struct x_display_info *dpyinfo,
{
#if !defined USE_X_TOOLKIT && (!defined USE_GTK || defined HAVE_GTK3)
goto OTHER;
-#else
+#else /* USE_X_TOOLKIT || (USE_GTK && !HAVE_GTK3) */
/* Unfortunately, X toolkit popups generate LeaveNotify
events due to the core grabs they acquire (and our
releasing of the device grab). This leads to the mouse
@@ -20298,9 +20771,16 @@ handle_one_xevent (struct x_display_info *dpyinfo,
outside the frame, in which case no XI_Enter event is
generated for the grab. */
goto just_clear_mouse_face;
-#endif
+#endif /* !USE_X_TOOLKIT && (!USE_GTK || HAVE_GTK3) */
}
-#endif
+#endif /* HAVE_XINPUT2 */
+
+ /* Apply the fix for bug#57468 on GTK 3.x and no toolkit
+ builds. */
+#if !defined USE_X_TOOLKIT || (!defined USE_GTK || defined HAVE_GTK3)
+ if (x_top_window_to_frame (dpyinfo, event->xcrossing.window))
+ x_detect_focus_change (dpyinfo, any, event, &inev.ie);
+#endif /* !defined USE_X_TOOLKIT || (!defined USE_GTK || defined HAVE_GTK3) */
#ifdef HAVE_XWIDGETS
{
@@ -20316,9 +20796,6 @@ handle_one_xevent (struct x_display_info *dpyinfo,
}
#endif
- if (x_top_window_to_frame (dpyinfo, event->xcrossing.window))
- x_detect_focus_change (dpyinfo, any, event, &inev.ie);
-
#if defined HAVE_XINPUT2 \
&& (defined USE_X_TOOLKIT || (defined USE_GTK && !defined HAVE_GTK3))
just_clear_mouse_face:
@@ -20701,7 +21178,7 @@ handle_one_xevent (struct x_display_info *dpyinfo,
}
Lisp_Object window = window_from_coordinates
- (f, xmotion.x, xmotion.y, 0, false, false);
+ (f, xmotion.x, xmotion.y, 0, false, false, false);
/* A window will be autoselected only when it is not
selected now and the last mouse movement event was
@@ -20947,14 +21424,28 @@ handle_one_xevent (struct x_display_info *dpyinfo,
x_cr_update_surface_desired_size (any,
configureEvent.xconfigure.width,
configureEvent.xconfigure.height);
- if (f || (any && configureEvent.xconfigure.window == FRAME_X_WINDOW (any)))
- x_update_opaque_region (f ? f : any, &configureEvent);
#endif
+
+#if !defined USE_X_TOOLKIT && !defined USE_GTK
+
+ /* Make the new size of the frame its opaque region. This is a
+ region describing areas of the window which are always
+ guaranteed to be completely opaque and can be treated as such
+ by the compositor. It is set to the width and height of the
+ only window in no-toolkit builds when `alpha_background' is
+ not set, and is cleared otherwise. */
+
+ if (f || (any && configureEvent.xconfigure.window
+ == FRAME_OUTER_WINDOW (any)))
+ x_update_opaque_region (f ? f : any, &configureEvent);
+
+#endif /* !defined USE_X_TOOLKIT && !defined USE_GTK */
+
#ifdef USE_GTK
if (!f
&& (f = any)
&& configureEvent.xconfigure.window == FRAME_X_WINDOW (f)
- && (FRAME_VISIBLE_P(f)
+ && (FRAME_VISIBLE_P (f)
|| !(configureEvent.xconfigure.width <= 1
&& configureEvent.xconfigure.height <= 1)))
{
@@ -20981,10 +21472,9 @@ handle_one_xevent (struct x_display_info *dpyinfo,
f = 0;
}
#endif
- if (f
- && (FRAME_VISIBLE_P(f)
- || !(configureEvent.xconfigure.width <= 1
- && configureEvent.xconfigure.height <= 1)))
+ if (f && (FRAME_VISIBLE_P (f)
+ || !(configureEvent.xconfigure.width <= 1
+ && configureEvent.xconfigure.height <= 1)))
{
#ifdef USE_GTK
/* For GTK+ don't call x_net_wm_state for the scroll bar
@@ -21365,7 +21855,7 @@ handle_one_xevent (struct x_display_info *dpyinfo,
if (FRAME_PARENT_FRAME (f) || (hf && frame_ancestor_p (f, hf)))
{
- x_ignore_errors_for_next_request (dpyinfo);
+ x_ignore_errors_for_next_request (dpyinfo, 0);
XSetInputFocus (FRAME_X_DISPLAY (f), FRAME_OUTER_WINDOW (f),
RevertToParent, event->xbutton.time);
x_stop_ignoring_errors (dpyinfo);
@@ -21419,7 +21909,7 @@ handle_one_xevent (struct x_display_info *dpyinfo,
int x = event->xbutton.x;
int y = event->xbutton.y;
- window = window_from_coordinates (f, x, y, 0, true, true);
+ window = window_from_coordinates (f, x, y, 0, true, true, true);
tab_bar_p = EQ (window, f->tab_bar_window);
if (tab_bar_p)
@@ -21440,7 +21930,7 @@ handle_one_xevent (struct x_display_info *dpyinfo,
int x = event->xbutton.x;
int y = event->xbutton.y;
- window = window_from_coordinates (f, x, y, 0, true, true);
+ window = window_from_coordinates (f, x, y, 0, true, true, true);
tool_bar_p = (EQ (window, f->tool_bar_window)
&& (event->xbutton.type != ButtonRelease
|| f->last_tool_bar_item != -1));
@@ -21586,9 +22076,9 @@ handle_one_xevent (struct x_display_info *dpyinfo,
case VisibilityNotify:
f = x_top_window_to_frame (dpyinfo, event->xvisibility.window);
- if (f && (event->xvisibility.state == VisibilityUnobscured
- || event->xvisibility.state == VisibilityPartiallyObscured))
- SET_FRAME_VISIBLE (f, 1);
+
+ if (f)
+ FRAME_X_OUTPUT (f)->visibility_state = event->xvisibility.state;
goto OTHER;
@@ -21673,6 +22163,10 @@ handle_one_xevent (struct x_display_info *dpyinfo,
switch (event->xcookie.evtype)
{
+ /* XI focus events aren't employed under X toolkit or GTK+
+ 2.x because windows created by these two toolkits are
+ incompatible with input extension focus events. */
+#if !defined USE_X_TOOLKIT && (!defined USE_GTK || defined HAVE_GTK3)
case XI_FocusIn:
{
XIFocusInEvent *focusin;
@@ -21682,17 +22176,19 @@ handle_one_xevent (struct x_display_info *dpyinfo,
#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
- a MapNotify when unminimizing/deiconifying. Check here if we
- are deiconizing a window (Bug42655).
+ minimized/iconified windows; thus, for those WMs we
+ won't get a MapNotify when unminimizing/deiconifying.
+ Check here if we are deiconizing a window (Bug42655).
- But don't do that by default on GTK since it may cause a plain
- invisible frame get reported as iconified, compare
+ But don't do that by default on GTK since it may
+ cause a plain invisible frame get reported as
+ iconified, compare
https://lists.gnu.org/archive/html/emacs-devel/2017-02/msg00133.html.
That is fixed above but bites us here again.
- The option x_set_frame_visibility_more_laxly allows to override
- the default behavior (Bug#49955, Bug#53298). */
+ The option x_set_frame_visibility_more_laxly enables
+ overriding the default behavior (Bug#49955,
+ Bug#53298). */
if (EQ (x_set_frame_visibility_more_laxly, Qfocus_in)
|| EQ (x_set_frame_visibility_more_laxly, Qt))
#endif /* USE_GTK */
@@ -21723,6 +22219,7 @@ handle_one_xevent (struct x_display_info *dpyinfo,
goto XI_OTHER;
}
+#endif /* !USE_X_TOOLKIT && (!USE_GTK || HAVE_GTK3) */
case XI_Enter:
{
@@ -21768,8 +22265,11 @@ handle_one_xevent (struct x_display_info *dpyinfo,
passive focus from non-top windows at all, since they
are an inferiors of the frame's top window, which will
get virtual events. */
+
+#if !defined USE_X_TOOLKIT && (!defined USE_GTK || defined HAVE_GTK3)
if (any)
xi_focus_handle_for_device (dpyinfo, any, xi_event);
+#endif /* !USE_X_TOOLKIT && (!USE_GTK || HAVE_GTK3) */
if (!any)
any = x_any_window_to_frame (dpyinfo, enter->event);
@@ -21949,8 +22449,10 @@ handle_one_xevent (struct x_display_info *dpyinfo,
}
#endif
+#if !defined USE_X_TOOLKIT && (!defined USE_GTK || defined HAVE_GTK3)
if (any)
xi_focus_handle_for_device (dpyinfo, any, xi_event);
+#endif /* !USE_X_TOOLKIT && (!USE_GTK || HAVE_GTK3) */
#ifndef USE_X_TOOLKIT
f = x_top_window_to_frame (dpyinfo, leave->event);
@@ -22161,7 +22663,7 @@ handle_one_xevent (struct x_display_info *dpyinfo,
continue;
window = window_from_coordinates (f, real_x, real_y, NULL,
- false, false);
+ false, false, false);
if (WINDOWP (window))
scroll_height = XWINDOW (window)->pixel_height;
@@ -22604,7 +23106,8 @@ handle_one_xevent (struct x_display_info *dpyinfo,
|| !NILP (focus_follows_mouse)))
{
static Lisp_Object last_mouse_window;
- Lisp_Object window = window_from_coordinates (f, ev.x, ev.y, 0, false, false);
+ Lisp_Object window = window_from_coordinates (f, ev.x, ev.y, 0, false, false,
+ false);
/* A window will be autoselected only when it is not
selected now and the last mouse movement event was
@@ -23063,7 +23566,7 @@ handle_one_xevent (struct x_display_info *dpyinfo,
/* This can generate XI_BadDevice if the
device's attachment was destroyed
server-side. */
- x_ignore_errors_for_next_request (dpyinfo);
+ x_ignore_errors_for_next_request (dpyinfo, 0);
XISetFocus (dpyinfo->display, device->attachment,
/* Note that the input extension
only supports RevertToParent-type
@@ -23076,7 +23579,7 @@ handle_one_xevent (struct x_display_info *dpyinfo,
events to handle focus. Errors are still
caught here in case the window is not
viewable. */
- x_ignore_errors_for_next_request (dpyinfo);
+ x_ignore_errors_for_next_request (dpyinfo, 0);
XSetInputFocus (FRAME_X_DISPLAY (f), FRAME_OUTER_WINDOW (f),
RevertToParent, xev->time);
x_stop_ignoring_errors (dpyinfo);
@@ -23182,7 +23685,7 @@ handle_one_xevent (struct x_display_info *dpyinfo,
int x = bv.x;
int y = bv.y;
- window = window_from_coordinates (f, x, y, 0, true, true);
+ window = window_from_coordinates (f, x, y, 0, true, true, true);
tab_bar_p = EQ (window, f->tab_bar_window);
if (tab_bar_p)
@@ -23203,7 +23706,7 @@ handle_one_xevent (struct x_display_info *dpyinfo,
int x = bv.x;
int y = bv.y;
- window = window_from_coordinates (f, x, y, 0, true, true);
+ window = window_from_coordinates (f, x, y, 0, true, true, true);
/* Ignore button release events if the mouse
wasn't previously pressed on the tool bar.
We do this because otherwise selecting some
@@ -23329,7 +23832,7 @@ handle_one_xevent (struct x_display_info *dpyinfo,
Lisp_Object c;
#ifdef HAVE_XKB
unsigned int mods_rtrn;
-#endif
+#endif /* HAVE_XKB */
int keycode = xev->detail;
KeySym keysym;
char copy_buffer[81];
@@ -23338,15 +23841,123 @@ handle_one_xevent (struct x_display_info *dpyinfo,
ptrdiff_t i;
unsigned int old_state;
struct xi_device_t *device, *source;
+ XKeyPressedEvent xkey;
coding = Qlatin_1;
+ /* The code under this label is quite desultory. There
+ are also several important discrepancies with the
+ core KeyPress code to mind.
+
+ There are three principal objectives:
+
+ The first is to produce a core or GDK translation of
+ this XI_KeyPress event, which is relayed to the
+ toolkit. This transpires by setting `copy' to a
+ close copy of XEV, which is later copied or
+ dispatched to the toolkit by the code beneath the
+ OTHER label.
+
+ The second objective is to filter the event through
+ an input method, by generating a second copy of the
+ event expressly tailored for such a purpose. The
+ core KeyPress code does not endeavor to do so;
+ instead, this action is taken prior to calling
+ handle_one_xevent. Calls to `x_filter_event' or
+ `xg_filter_key' serve to implement this objective.
+
+ If the event is not removed by the input method's
+ filter, the third objective is to establish either a
+ keysym or a sequence of characters to insert, using
+ the information supplied within the key event.
+
+ When an input method connection is available, this
+ responsibility is vested in the hands of the input
+ method -- yet another copy of XEV as a core event is
+ produced, and the input method is responsible for
+ deriving a keysym or text to insert.
+
+ Otherwise, if the XKB extension is available, calls
+ are made to XkbTranslateKeyCode and
+ XkbTranslateKeySym.
+
+ And if all else fails, XEV is transformed into a core
+ event and provided to XLookupString, in a manner
+ analogous to the core event processing under the
+ KeyPress label.
+
+ A wide number of variables are employed during this
+ translation process. The most pertinent ones are:
+
+ `copy'
+
+ This variable is defined when an X toolkit
+ incognizant of input extension events is being
+ employed. If a popup is active, Emacs copies
+ fields of interest from the extension event to
+ COPY, sets the `use_copy' flag, and jumps to the
+ XI_OTHER label. `copy' is then relayed to the
+ toolkit.
+
+ `xkey'
+
+ This variable is defined to a copy of the event
+ used by input methods or XLookupString at various
+ points during the execution of this label.
+
+ `coding'
+
+ This variable is consulted at the conclusion of
+ event generation, and holds the coding system
+ for any generated string.
+
+ `keysym'
+
+ This variable is eventually set to the keysym tied
+ to the event, which may be directly provided within
+ a generated struct input_event, should it bear a
+ direct relation to an ASCII or Unicode character,
+ or if it is a control key.
+
+ `copy_buffer', `copy_bufptr', `copy_bufsiz'
+
+ These variables hold the buffer that incorporates
+ characters generated during the keycode-to-keysym
+ conversion process.
+
+ `nbytes'
+
+ Holds the number of characters within that buffer,
+ in bytes. These characters are encoded using the
+ coding system in `coding'.
+
+ If greater than 0 and KEYSYM does not immediately
+ relate to a function key, control key or character,
+ it is provided as the string to insert within a
+ MULTIBYTE_CHAR_KEYSTROKE_EVENT.
+
+ `state'
+
+ Holds the keyboard and group (but not button)
+ state. After event filtering concludes, modifier
+ bits within `extra_keyboard_modifiers' are also
+ introduced.
+
+ This illustration may reflect the treatment taken
+ towards core key events to some degree. */
+
device = xi_device_from_id (dpyinfo, xev->deviceid);
source = xi_device_from_id (dpyinfo, xev->sourceid);
if (!device)
goto XI_OTHER;
+ /* Convert the keyboard state within XEV to a core
+ modifier mask, later supplied as arguments to XKB and
+ core functions. This encompasses the keyboard group
+ and effective modifiers but not the button state. */
+ state = xi_convert_event_keyboard_state (xev);
+
#if defined (USE_X_TOOLKIT) || defined (USE_GTK)
/* Dispatch XI_KeyPress events when in menu. */
if (popup_activated ())
@@ -23362,7 +23973,7 @@ handle_one_xevent (struct x_display_info *dpyinfo,
copy.xkey.root = xev->root;
copy.xkey.subwindow = xev->child;
copy.xkey.time = xev->time;
- copy.xkey.state = xi_convert_event_keyboard_state (xev);
+ copy.xkey.state = state;
xi_convert_button_state (&xev->buttons, &copy.xkey.state);
copy.xkey.x = lrint (xev->event_x);
@@ -23371,10 +23982,10 @@ handle_one_xevent (struct x_display_info *dpyinfo,
copy.xkey.y_root = lrint (xev->root_y);
copy.xkey.keycode = xev->detail;
copy.xkey.same_screen = True;
-#endif
+#endif /* USE_LUCID */
goto XI_OTHER;
}
-#endif
+#endif /* USE_X_TOOLKIT || USE_GTK */
x_display_set_last_user_time (dpyinfo, xev->time,
xev->send_event, true);
@@ -23394,7 +24005,7 @@ handle_one_xevent (struct x_display_info *dpyinfo,
#ifdef USE_GTK
if (f)
x_set_gtk_user_time (f, xev->time);
-#endif
+#endif /* USE_GTK */
if (f)
{
@@ -23406,7 +24017,9 @@ handle_one_xevent (struct x_display_info *dpyinfo,
xev->time);
}
- XKeyPressedEvent xkey;
+ /* Convert the XI event into a core event structure
+ provided to old Xlib functions and input method
+ filter functions. */
memset (&xkey, 0, sizeof xkey);
@@ -23418,8 +24031,7 @@ handle_one_xevent (struct x_display_info *dpyinfo,
xkey.root = xev->root;
xkey.subwindow = xev->child;
xkey.time = xev->time;
- xkey.state = xi_convert_event_keyboard_state (xev);
-
+ xkey.state = state;
xkey.x = lrint (xev->event_x);
xkey.y = lrint (xev->event_y);
xkey.x_root = lrint (xev->root_x);
@@ -23448,7 +24060,7 @@ handle_one_xevent (struct x_display_info *dpyinfo,
*finish = X_EVENT_DROP;
goto XI_OTHER;
}
-#else
+#else /* !USE_GTK */
if (x_filter_event (dpyinfo, (XEvent *) &xkey))
{
/* Try to attribute core key events from the input
@@ -23460,8 +24072,8 @@ handle_one_xevent (struct x_display_info *dpyinfo,
*finish = X_EVENT_DROP;
goto XI_OTHER;
}
-#endif
-#elif USE_GTK
+#endif /* HAVE_X_I18N */
+#elif USE_GTK /* && !HAVE_X_I18N */
if ((x_gtk_use_native_input
|| dpyinfo->prefer_native_input)
&& xg_filter_key (any, event))
@@ -23475,48 +24087,17 @@ handle_one_xevent (struct x_display_info *dpyinfo,
*finish = X_EVENT_DROP;
goto XI_OTHER;
}
-#endif
+#endif /* HAVE_X_I18N || USE_GTK */
state |= x_emacs_to_x_modifiers (dpyinfo, extra_keyboard_modifiers);
-#ifdef HAVE_XKB
- if (dpyinfo->xkb_desc)
- {
- unsigned int xkb_state;
-
- xkb_state = state & ~(1 << 13 | 1 << 14);
- xkb_state |= xev->group.effective << 13;
-
- if (!XkbTranslateKeyCode (dpyinfo->xkb_desc, keycode,
- xkb_state, &mods_rtrn, &keysym))
- goto XI_OTHER;
- }
- else
- {
-#endif
- int keysyms_per_keycode_return;
- KeySym *ksms = XGetKeyboardMapping (dpyinfo->display, keycode, 1,
- &keysyms_per_keycode_return);
- if (!(keysym = ksms[0]))
- {
- XFree (ksms);
- goto XI_OTHER;
- }
- XFree (ksms);
-#ifdef HAVE_XKB
- }
-#endif
-
- if (keysym == NoSymbol)
- goto XI_OTHER;
-
/* If mouse-highlight is an integer, input clears out
mouse highlighting. */
if (!hlinfo->mouse_face_hidden && FIXNUMP (Vmouse_highlight)
&& (f == 0
#if ! defined (USE_GTK)
|| !EQ (f->tool_bar_window, hlinfo->mouse_face_window)
-#endif
+#endif /* !USE_GTK */
|| !EQ (f->tab_bar_window, hlinfo->mouse_face_window))
)
{
@@ -23537,7 +24118,7 @@ handle_one_xevent (struct x_display_info *dpyinfo,
dialogs because in that case popup_activated is nonzero
(see above). */
*finish = X_EVENT_DROP;
-#endif
+#endif /* USE_GTK */
XSETFRAME (inev.ie.frame_or_window, f);
inev.ie.timestamp = xev->time;
@@ -23574,25 +24155,54 @@ handle_one_xevent (struct x_display_info *dpyinfo,
emacs_abort ();
}
else
-#endif
+#endif /* HAVE_X_I18N */
{
#ifdef HAVE_XKB
- int overflow = 0;
- KeySym sym = keysym;
-
if (dpyinfo->xkb_desc)
{
- nbytes = XkbTranslateKeySym (dpyinfo->display, &sym,
- state & ~mods_rtrn, copy_bufptr,
- copy_bufsiz, &overflow);
+ KeySym sym;
+ int overflow;
+
+ /* Translate the keycode into the keysym it
+ represents, using STATE. MODS_RTRN is
+ set to the modifier bits consumed while
+ undertaking this translation and should
+ be subsequently ignored during keysym
+ translation. */
+
+ if (!XkbTranslateKeyCode (dpyinfo->xkb_desc,
+ keycode, state,
+ &mods_rtrn, &keysym))
+ goto xi_done_keysym;
+
+ /* Save the original keysym in case
+ XkbTranslateKeySym overflows. */
+ sym = keysym, overflow = 0;
+
+ /* Translate this keysym and its modifier
+ state into the actual symbol and string
+ it represents. */
+ nbytes = XkbTranslateKeySym (dpyinfo->display,
+ &keysym,
+ state & ~mods_rtrn,
+ copy_bufptr,
+ copy_bufsiz,
+ &overflow);
if (overflow)
{
- copy_bufptr = SAFE_ALLOCA ((copy_bufsiz += overflow)
- * sizeof *copy_bufptr);
+ copy_bufptr
+ = SAFE_ALLOCA ((copy_bufsiz += overflow)
+ * sizeof *copy_bufptr);
overflow = 0;
- nbytes = XkbTranslateKeySym (dpyinfo->display, &sym,
- state & ~mods_rtrn, copy_bufptr,
- copy_bufsiz, &overflow);
+
+ /* Use the original keysym derived from
+ the keycode translation. */
+ nbytes = XkbTranslateKeySym (dpyinfo->display,
+ &sym,
+ state & ~mods_rtrn,
+ copy_bufptr,
+ copy_bufsiz,
+ &overflow);
if (overflow)
nbytes = 0;
@@ -23601,8 +24211,14 @@ handle_one_xevent (struct x_display_info *dpyinfo,
coding = Qnil;
}
else
-#endif
+#endif /* HAVE_XKB */
{
+ /* Save the state within XKEY, then remove
+ all modifier keys Emacs understands from
+ it, forestalling any attempt by
+ XLookupString to introduce control
+ characters. */
+
old_state = xkey.state;
xkey.state &= ~ControlMask;
xkey.state &= ~(dpyinfo->meta_mod_mask
@@ -23628,7 +24244,28 @@ handle_one_xevent (struct x_display_info *dpyinfo,
x_dnd_xm_use_help = true;
goto xi_done_keysym;
}
-#endif
+#endif /* XK_F1 */
+
+ /* See if keysym should make Emacs quit. */
+
+ if (dpyinfo->quit_keysym)
+ {
+ if (keysym == dpyinfo->quit_keysym
+ && (xev->time - dpyinfo->quit_keysym_time
+ <= 350))
+ {
+ Vquit_flag = Qt;
+ goto xi_done_keysym;
+ }
+
+ if (keysym == dpyinfo->quit_keysym)
+ {
+ /* Otherwise, set the last time that keysym
+ was pressed. */
+ dpyinfo->quit_keysym_time = xev->time;
+ goto xi_done_keysym;
+ }
+ }
/* First deal with keysyms which have defined
translations to characters. */
@@ -23890,9 +24527,11 @@ handle_one_xevent (struct x_display_info *dpyinfo,
XIDeviceInfo *info;
int i, ndevices, n_disabled, *disabled;
struct xi_device_t *device;
+#if !defined USE_X_TOOLKIT && (!defined USE_GTK || defined HAVE_GTK3)
bool any_changed;
any_changed = false;
+#endif /* !USE_X_TOOLKIT && (!USE_GTK || HAVE_GTK3) */
hev = (XIHierarchyEvent *) xi_event;
disabled = SAFE_ALLOCA (sizeof *disabled * hev->num_info);
n_disabled = 0;
@@ -23909,10 +24548,12 @@ handle_one_xevent (struct x_display_info *dpyinfo,
xi_disable_devices (dpyinfo, disabled, n_disabled);
n_disabled = 0;
+#if !defined USE_X_TOOLKIT && (!defined USE_GTK || defined HAVE_GTK3)
/* This flag really just means that disabled
devices were handled early and should be
used in conjunction with n_disabled. */
any_changed = true;
+#endif /* !USE_X_TOOLKIT && (!USE_GTK || HAVE_GTK3) */
}
/* Under unknown circumstances, multiple
@@ -23979,12 +24620,14 @@ handle_one_xevent (struct x_display_info *dpyinfo,
event. */
xi_disable_devices (dpyinfo, disabled, n_disabled);
+#if !defined USE_X_TOOLKIT && (!defined USE_GTK || defined HAVE_GTK3)
/* If the device hierarchy has been changed, recompute
focus. This might seem like a micro-optimization but
it actually keeps the focus from changing in some
cases where it would be undesierable. */
if (any_changed || n_disabled)
xi_handle_focus_change (dpyinfo);
+#endif /* !USE_X_TOOLKIT && (!USE_GTK || HAVE_GTK3) */
goto XI_OTHER;
}
@@ -24022,7 +24665,13 @@ handle_one_xevent (struct x_display_info *dpyinfo,
x_display_set_last_user_time (dpyinfo, xev->time,
xev->send_event, true);
- if (!device)
+ /* Don't process touch sequences from this device if
+ it's a master pointer. Touch sequences aren't
+ canceled by the X server if a slave device is
+ detached, and master pointers may also represent
+ dependent touch devices. */
+
+ if (!device || device->use == XIMasterPointer)
goto XI_OTHER;
if (xi_find_touch_point (device, xev->detail))
@@ -24052,6 +24701,73 @@ handle_one_xevent (struct x_display_info *dpyinfo,
}
#endif
+#ifndef HAVE_EXT_TOOL_BAR
+ /* Is this a touch from a direct touch device that is in
+ the tool-bar? */
+ if (device->direct_p
+ && WINDOWP (f->tool_bar_window)
+ && WINDOW_TOTAL_LINES (XWINDOW (f->tool_bar_window)))
+ {
+ Lisp_Object window;
+ int x = xev->event_x;
+ int y = xev->event_y;
+
+ window = window_from_coordinates (f, x, y, 0, true, true, true);
+ /* 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);
+
+ /* If this touch has started in the tool bar, do not
+ send it to Lisp. Instead, simulate a tool bar
+ click, releasing it once it goes away. */
+
+ if (tool_bar_p)
+ {
+ /* Call note_mouse_highlight on the tool bar
+ item. Otherwise, get_tool_bar_item will
+ return 1.
+
+ This is not necessary when mouse-highlight is
+ nil. */
+
+ if (!NILP (Vmouse_highlight))
+ {
+ note_mouse_highlight (f, x, y);
+
+ /* Always allow future mouse motion to
+ update the mouse highlight, no matter
+ where it is. */
+ memset (&dpyinfo->last_mouse_glyph, 0,
+ sizeof dpyinfo->last_mouse_glyph);
+ dpyinfo->last_mouse_glyph_frame = f;
+ }
+
+ handle_tool_bar_click_with_device (f, x, y, true, 0,
+ (source
+ ? source->name : Qt));
+
+ /* Flush any changes made by that to the front
+ buffer. */
+ x_flush_dirty_back_buffer_on (f);
+
+ /* Record the device and the touch ID on the
+ frame. That way, Emacs knows when to dismiss
+ the tool bar click later. */
+
+ FRAME_OUTPUT_DATA (f)->tool_bar_touch_device
+ = device->device_id;
+ FRAME_OUTPUT_DATA (f)->tool_bar_touch_id = xev->detail;
+
+ goto XI_OTHER;
+ }
+ }
+#endif
+
if (!menu_bar_p && !tool_bar_p)
{
if (f && device->direct_p)
@@ -24061,13 +24777,16 @@ handle_one_xevent (struct x_display_info *dpyinfo,
x_catch_errors (dpyinfo->display);
if (x_input_grab_touch_events)
- XIAllowTouchEvents (dpyinfo->display, xev->deviceid,
- xev->detail, xev->event, XIAcceptTouch);
+ 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,
- xev->event_y);
+ xi_link_touch_point (device, xev->detail,
+ xev->event_x,
+ xev->event_y, f);
inev.ie.kind = TOUCHSCREEN_BEGIN_EVENT;
inev.ie.timestamp = xev->time;
@@ -24085,7 +24804,7 @@ handle_one_xevent (struct x_display_info *dpyinfo,
#ifndef HAVE_GTK3
else if (x_input_grab_touch_events)
{
- x_ignore_errors_for_next_request (dpyinfo);
+ x_ignore_errors_for_next_request (dpyinfo, 0);
XIAllowTouchEvents (dpyinfo->display, xev->deviceid,
xev->detail, xev->event, XIRejectTouch);
x_stop_ignoring_errors (dpyinfo);
@@ -24109,27 +24828,75 @@ handle_one_xevent (struct x_display_info *dpyinfo,
goto XI_OTHER;
}
+ case XI_TouchOwnership:
+ {
+ struct xi_device_t *device;
+ struct xi_touch_point_t *touchpoint;
+ XITouchOwnershipEvent *event;
+
+ /* All grabbing clients have decided to reject ownership
+ of this touch sequence. */
+
+ event = (XITouchOwnershipEvent *) xi_event;
+ device = xi_device_from_id (dpyinfo, event->deviceid);
+
+ if (!device || device->use == XIMasterPointer)
+ goto XI_OTHER;
+
+ touchpoint = xi_find_touch_point (device, event->touchid);
+
+ if (!touchpoint)
+ goto XI_OTHER;
+
+ /* As a result, Emacs should complete whatever editing
+ operations result from this touch sequence. */
+ touchpoint->ownership = TOUCH_OWNERSHIP_SELF;
+
+ goto XI_OTHER;
+ }
+
case XI_TouchUpdate:
{
struct xi_device_t *device, *source;
struct xi_touch_point_t *touchpoint;
Lisp_Object arg = Qnil;
+ /* If flags & TouchPendingEnd, the touch sequence has
+ already ended, but some grabbing clients remain
+ undecided as to whether they will obtain ownership of
+ the touch sequence.
+
+ Wait for them to make their decision, resulting in
+ TouchOwnership and TouchEnd events being sent. */
+
+ if (xev->flags & XITouchPendingEnd)
+ goto XI_OTHER;
+
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,
xev->send_event, true);
- if (!device)
+ /* Don't process touch sequences from this device if
+ it's a master pointer. Touch sequences aren't
+ canceled by the X server if a slave device is
+ detached, and master pointers may also represent
+ dependent touch devices. */
+
+ if (!device || device->use == XIMasterPointer)
goto XI_OTHER;
touchpoint = xi_find_touch_point (device, xev->detail);
- if (!touchpoint)
+ if (!touchpoint
+ /* Don't send this event if nothing has changed
+ either. */
+ || (touchpoint->x == lrint (xev->event_x)
+ && touchpoint->y == lrint (xev->event_y)))
goto XI_OTHER;
- touchpoint->x = xev->event_x;
- touchpoint->y = xev->event_y;
+ touchpoint->x = lrint (xev->event_x);
+ touchpoint->y = lrint (xev->event_y);
f = x_window_to_frame (dpyinfo, xev->event);
@@ -24142,10 +24909,10 @@ handle_one_xevent (struct x_display_info *dpyinfo,
for (touchpoint = device->touchpoints;
touchpoint; touchpoint = touchpoint->next)
{
- arg = Fcons (list3i (lrint (touchpoint->x),
- lrint (touchpoint->y),
- lrint (touchpoint->number)),
- arg);
+ if (touchpoint->frame == f)
+ arg = Fcons (list3i (touchpoint->x, touchpoint->y,
+ lrint (touchpoint->number)),
+ arg);
}
if (source)
@@ -24160,19 +24927,25 @@ handle_one_xevent (struct x_display_info *dpyinfo,
case XI_TouchEnd:
{
struct xi_device_t *device, *source;
- bool unlinked_p;
+ int state;
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,
xev->send_event, true);
- if (!device)
+ /* Don't process touch sequences from this device if
+ it's a master pointer. Touch sequences aren't
+ canceled by the X server if a slave device is
+ detached, and master pointers may also represent
+ dependent touch devices. */
+
+ if (!device || device->use == XIMasterPointer)
goto XI_OTHER;
- unlinked_p = xi_unlink_touch_point (xev->detail, device);
+ state = xi_unlink_touch_point (xev->detail, device);
- if (unlinked_p)
+ if (state)
{
f = x_window_to_frame (dpyinfo, xev->event);
@@ -24180,6 +24953,7 @@ handle_one_xevent (struct x_display_info *dpyinfo,
{
inev.ie.kind = TOUCHSCREEN_END_EVENT;
inev.ie.timestamp = xev->time;
+ inev.ie.modifiers = state != 2;
XSETFRAME (inev.ie.frame_or_window, f);
XSETINT (inev.ie.x, lrint (xev->event_x));
@@ -24191,6 +24965,33 @@ handle_one_xevent (struct x_display_info *dpyinfo,
}
}
+#ifndef HAVE_EXT_TOOL_BAR
+ /* Now see if the touchpoint was previously on the tool bar.
+ If it was, release the tool bar. */
+
+ if (!f)
+ f = x_window_to_frame (dpyinfo, xev->event);
+
+ if (f && (FRAME_OUTPUT_DATA (f)->tool_bar_touch_id
+ == xev->detail))
+ {
+ if (f->last_tool_bar_item != -1)
+ handle_tool_bar_click_with_device (f, xev->event_x,
+ xev->event_y,
+ false, 0,
+ (source
+ ? source->name
+ : Qnil));
+
+ /* Cancel any outstanding mouse highlight. */
+ note_mouse_highlight (f, -1, -1);
+ x_flush_dirty_back_buffer_on (f);
+
+ /* Now clear the tool bar device. */
+ FRAME_OUTPUT_DATA (f)->tool_bar_touch_device = 0;
+ }
+#endif
+
goto XI_OTHER;
}
@@ -24208,7 +25009,7 @@ handle_one_xevent (struct x_display_info *dpyinfo,
x_display_set_last_user_time (dpyinfo, pev->time,
pev->send_event, true);
- if (!device)
+ if (!device || device->use != XIMasterPointer)
goto XI_OTHER;
#ifdef HAVE_XWIDGETS
@@ -24896,13 +25697,17 @@ XTread_socket (struct terminal *terminal, struct input_event *hold_quit)
/* Set clipping for output in glyph row ROW. W is the window in which
we operate. GC is the graphics context to set clipping in.
+ If RECT_RETURN is non-NULL, return the clip rectangle within
+ *RECT_RETURN.
+
ROW may be a text row or, e.g., a mode line. Text rows must be
clipped to the interior of the window dedicated to text display,
mode lines must be clipped to the whole window. */
static void
x_clip_to_row (struct window *w, struct glyph_row *row,
- enum glyph_row_area area, GC gc)
+ enum glyph_row_area area, GC gc,
+ XRectangle *rect_return)
{
struct frame *f = XFRAME (WINDOW_FRAME (w));
XRectangle clip_rect;
@@ -24917,6 +25722,9 @@ x_clip_to_row (struct window *w, struct glyph_row *row,
clip_rect.height = row->visible_height;
x_set_clip_rectangles (f, gc, &clip_rect, 1);
+
+ if (rect_return)
+ *rect_return = clip_rect;
}
@@ -24965,7 +25773,7 @@ x_draw_hollow_cursor (struct window *w, struct glyph_row *row)
wd -= 1;
}
/* Set clipping, draw the rectangle, and reset clipping again. */
- x_clip_to_row (w, row, TEXT_AREA, gc);
+ x_clip_to_row (w, row, TEXT_AREA, gc, NULL);
x_draw_rectangle (f, gc, x, y, wd, h - 1);
x_reset_clip_rectangles (f, gc);
}
@@ -25035,7 +25843,7 @@ x_draw_bar_cursor (struct window *w, struct glyph_row *row, int width, enum text
FRAME_DISPLAY_INFO (f)->scratch_cursor_gc = gc;
}
- x_clip_to_row (w, row, TEXT_AREA, gc);
+ x_clip_to_row (w, row, TEXT_AREA, gc, NULL);
if (kind == BAR_CURSOR)
{
@@ -25513,19 +26321,27 @@ x_clean_failable_requests (struct x_display_info *dpyinfo)
+ (last - first));
}
-/* Protect a section of X requests: ignore errors generated by X
- requests made from now until `x_stop_ignoring_errors'. Each call
- must be paired with a call to `x_stop_ignoring_errors', and
- recursive calls inside the protected section are not allowed.
+/* Protect a section of X requests.
+
+ Ignore errors generated by X requests made from now until
+ `x_stop_ignoring_errors'. Each call must be paired with a call to
+ `x_stop_ignoring_errors', and recursive calls inside the protected
+ section are not allowed.
The advantage over x_catch_errors followed by
x_uncatch_errors_after_check is that this function does not sync to
catch errors if requests were made. It should be used instead of
those two functions for catching errors around requests that do not
- require a reply. */
+ require a reply.
+
+ If SELECTION_SERIAL is an arbitrary number greater than zero,
+ x_select_handle_selection_error is called with the specified number
+ after any errors within the protected section are received to
+ delete the selection request that encountered errors. */
void
-x_ignore_errors_for_next_request (struct x_display_info *dpyinfo)
+x_ignore_errors_for_next_request (struct x_display_info *dpyinfo,
+ unsigned int selection_serial)
{
struct x_failable_request *request, *max;
unsigned long next_request;
@@ -25579,6 +26395,7 @@ x_ignore_errors_for_next_request (struct x_display_info *dpyinfo)
request->start = next_request;
request->end = 0;
+ request->selection_serial = selection_serial;
dpyinfo->next_failable_request++;
}
@@ -26000,9 +26817,11 @@ For details, see etc/PROBLEMS.\n",
if (!ioerror && dpyinfo)
{
/* Dump the list of error handlers for debugging
- purposes. */
+ purposes if the list exists. */
- fprintf (stderr, "X error handlers currently installed:\n");
+ if ((dpyinfo->failable_requests
+ != dpyinfo->next_failable_request) || x_error_message)
+ fprintf (stderr, "X error handlers currently installed:\n");
for (failable = dpyinfo->failable_requests;
failable < dpyinfo->next_failable_request;
@@ -26091,6 +26910,21 @@ x_error_handler (Display *display, XErrorEvent *event)
+ (last - fail));
}
+ /* If a selection transfer is the cause of this error,
+ remove the selection transfer now. */
+
+ if (fail->selection_serial)
+ {
+ x_handle_selection_error (fail->selection_serial,
+ event);
+
+ /* Clear selection_serial to prevent
+ x_handle_selection_error from being called again if
+ any more requests within the protected section cause
+ errors to be reported. */
+ fail->selection_serial = 0;
+ }
+
return 0;
}
}
@@ -26127,8 +26961,10 @@ x_error_handler (Display *display, XErrorEvent *event)
static void NO_INLINE
x_error_quitter (Display *display, XErrorEvent *event)
{
- char buf[256], buf1[400 + INT_STRLEN_BOUND (int)
- + INT_STRLEN_BOUND (unsigned long)];
+ char buf[256], buf1[800 + INT_STRLEN_BOUND (int)
+ + INT_STRLEN_BOUND (unsigned long)
+ + INT_STRLEN_BOUND (XID)
+ + INT_STRLEN_BOUND (int)];
/* Ignore BadName errors. They can happen because of fonts
or colors that are not defined. */
@@ -26141,8 +26977,12 @@ x_error_quitter (Display *display, XErrorEvent *event)
XGetErrorText (display, event->error_code, buf, sizeof (buf));
sprintf (buf1, "X protocol error: %s on protocol request %d\n"
- "Serial no: %lu\n", buf, event->request_code,
- event->serial);
+ "Serial no: %lu\n"
+ "Failing resource ID (if any): 0x%lx\n"
+ "Minor code: %d\n"
+ "This is a bug! Please report this to bug-gnu-emacs@gnu.org!\n",
+ buf, event->request_code, event->serial, event->resourceid,
+ event->minor_code);
x_connection_closed (display, buf1, false);
}
@@ -26308,7 +27148,12 @@ xim_destroy_callback (XIM xim, XPointer client_data, XPointer call_data)
/* No need to call XCloseIM. */
dpyinfo->xim = NULL;
- XFree (dpyinfo->xim_styles);
+
+ /* Also free IM values; those are allocated separately upon
+ XGetIMValues. */
+ if (dpyinfo->xim_styles)
+ XFree (dpyinfo->xim_styles);
+ dpyinfo->xim_styles = NULL;
unblock_input ();
}
@@ -26326,10 +27171,20 @@ xim_open_dpy (struct x_display_info *dpyinfo, char *resource_name)
XIM xim;
const char *locale;
- if (use_xim)
+ if (dpyinfo->use_xim)
{
if (dpyinfo->xim)
- XCloseIM (dpyinfo->xim);
+ {
+ XCloseIM (dpyinfo->xim);
+
+ /* Free values left over from the last time the IM
+ connection was established. */
+
+ if (dpyinfo->xim_styles)
+ XFree (dpyinfo->xim_styles);
+ dpyinfo->xim_styles = NULL;
+ }
+
xim = XOpenIM (dpyinfo->display, dpyinfo->rdb, resource_name,
emacs_class);
dpyinfo->xim = xim;
@@ -26354,11 +27209,10 @@ xim_open_dpy (struct x_display_info *dpyinfo, char *resource_name)
/* Now try to determine the coding system that should be
used. locale is in Host Portable Character Encoding, and
as such can be passed to build_string as is. */
- dpyinfo->xim_coding = safe_call1 (Vx_input_coding_function,
+ dpyinfo->xim_coding = safe_calln (Vx_input_coding_function,
build_string (locale));
}
}
-
else
#endif /* HAVE_XIM */
dpyinfo->xim = NULL;
@@ -26427,7 +27281,7 @@ xim_initialize (struct x_display_info *dpyinfo, char *resource_name)
{
dpyinfo->xim = NULL;
#ifdef HAVE_XIM
- if (use_xim)
+ if (dpyinfo->use_xim)
{
#ifdef HAVE_X11R6_XIM
struct xim_inst_t *xim_inst = xmalloc (sizeof *xim_inst);
@@ -26436,15 +27290,19 @@ xim_initialize (struct x_display_info *dpyinfo, char *resource_name)
dpyinfo->xim_callback_data = xim_inst;
xim_inst->dpyinfo = dpyinfo;
xim_inst->resource_name = xstrdup (resource_name);
- ret = XRegisterIMInstantiateCallback
- (dpyinfo->display, dpyinfo->rdb, xim_inst->resource_name,
- emacs_class, xim_instantiate_callback,
- /* This is XPointer in XFree86 but (XPointer *) on Tru64, at
- least, but the configure test doesn't work because
- xim_instantiate_callback can either be XIMProc or
- XIDProc, so just cast to void *. */
- (void *) xim_inst);
- eassert (ret == True);
+
+ /* The last argument is XPointer in XFree86 but (XPointer *) on
+ Tru64, at least, but the configure test doesn't work because
+ xim_instantiate_callback can either be XIMProc or XIDProc, so
+ just cast to void *. */
+
+ ret = XRegisterIMInstantiateCallback (dpyinfo->display,
+ dpyinfo->rdb,
+ xim_inst->resource_name,
+ emacs_class,
+ xim_instantiate_callback,
+ (void *) xim_inst);
+ eassert (ret);
#else /* not HAVE_X11R6_XIM */
xim_open_dpy (dpyinfo, resource_name);
#endif /* not HAVE_X11R6_XIM */
@@ -26453,32 +27311,56 @@ xim_initialize (struct x_display_info *dpyinfo, char *resource_name)
}
-/* Close the connection to the XIM server on display DPYINFO. */
+/* Close the connection to the XIM server on display DPYINFO.
+ Unregister any IM instantiation callback previously installed,
+ close the connection to the IM server if possible, and free any
+ retrieved IM values. */
static void
xim_close_dpy (struct x_display_info *dpyinfo)
{
#ifdef HAVE_XIM
- if (use_xim)
- {
#ifdef HAVE_X11R6_XIM
- struct xim_inst_t *xim_inst = dpyinfo->xim_callback_data;
+ struct xim_inst_t *xim_inst;
+ Bool rc;
+
+ /* If dpyinfo->xim_callback_data is not set, then IM support wasn't
+ initialized, which can happen if Xlib doesn't understand the C
+ locale being used. */
+
+ if (dpyinfo->xim_callback_data)
+ {
+ xim_inst = dpyinfo->xim_callback_data;
if (dpyinfo->display)
{
- Bool ret = XUnregisterIMInstantiateCallback
- (dpyinfo->display, dpyinfo->rdb, xim_inst->resource_name,
- emacs_class, xim_instantiate_callback, (void *) xim_inst);
- eassert (ret == True);
+ rc = XUnregisterIMInstantiateCallback (dpyinfo->display,
+ dpyinfo->rdb,
+ xim_inst->resource_name,
+ emacs_class,
+ xim_instantiate_callback,
+ (void *) xim_inst);
+ eassert (rc);
}
+
xfree (xim_inst->resource_name);
xfree (xim_inst);
-#endif /* HAVE_X11R6_XIM */
- if (dpyinfo->display)
- XCloseIM (dpyinfo->xim);
- dpyinfo->xim = NULL;
- XFree (dpyinfo->xim_styles);
}
+#endif /* HAVE_X11R6_XIM */
+
+ /* Now close the connection to the input method server. This may
+ access the display connection, and isn't safe if the display has
+ already been closed. */
+
+ if (dpyinfo->display && dpyinfo->xim)
+ XCloseIM (dpyinfo->xim);
+ dpyinfo->xim = NULL;
+
+ /* Free the list of XIM styles retrieved. */
+
+ if (dpyinfo->xim_styles)
+ XFree (dpyinfo->xim_styles);
+ dpyinfo->xim_styles = NULL;
#endif /* HAVE_XIM */
}
@@ -26643,38 +27525,43 @@ x_set_offset (struct frame *f, int xoff, int yoff, int change_gravity)
modified_left, modified_top);
#endif
- /* 'x_sync_with_move' is too costly for dragging child frames. */
- if (!FRAME_PARENT_FRAME (f)
- /* If no window manager exists, just calling XSync will be
- sufficient to ensure that the window geometry has been
- updated. */
- && NILP (Vx_no_window_manager))
- {
- x_sync_with_move (f, f->left_pos, f->top_pos,
- FRAME_DISPLAY_INFO (f)->wm_type == X_WMTYPE_UNKNOWN);
-
- /* change_gravity is non-zero when this function is called from Lisp to
- programmatically move a frame. In that case, we call
- x_check_expected_move to discover if we have a "Type A" or "Type B"
- window manager, and, for a "Type A" window manager, adjust the position
- of the frame.
-
- We call x_check_expected_move if a programmatic move occurred, and
- either the window manager type (A/B) is unknown or it is Type A but we
- need to compute the top/left offset adjustment for this frame. */
-
- if (change_gravity != 0
- && (FRAME_DISPLAY_INFO (f)->wm_type == X_WMTYPE_UNKNOWN
- || (FRAME_DISPLAY_INFO (f)->wm_type == X_WMTYPE_A
- && (FRAME_X_OUTPUT (f)->move_offset_left == 0
- && FRAME_X_OUTPUT (f)->move_offset_top == 0))))
- x_check_expected_move (f, modified_left, modified_top);
- }
- /* Instead, just wait for the last ConfigureWindow request to
- complete. No window manager is involved when moving child
- frames. */
- else
- XSync (FRAME_X_DISPLAY (f), False);
+ /* The following code is too slow over a latent network
+ connection. */
+ if (NILP (Vx_lax_frame_positioning))
+ {
+ /* 'x_sync_with_move' is too costly for dragging child frames. */
+ if (!FRAME_PARENT_FRAME (f)
+ /* If no window manager exists, just calling XSync will be
+ sufficient to ensure that the window geometry has been
+ updated. */
+ && NILP (Vx_no_window_manager))
+ {
+ x_sync_with_move (f, f->left_pos, f->top_pos,
+ FRAME_DISPLAY_INFO (f)->wm_type == X_WMTYPE_UNKNOWN);
+
+ /* change_gravity is non-zero when this function is called from Lisp to
+ programmatically move a frame. In that case, we call
+ x_check_expected_move to discover if we have a "Type A" or "Type B"
+ window manager, and, for a "Type A" window manager, adjust the position
+ of the frame.
+
+ We call x_check_expected_move if a programmatic move occurred, and
+ either the window manager type (A/B) is unknown or it is Type A but we
+ need to compute the top/left offset adjustment for this frame. */
+
+ if (change_gravity != 0
+ && (FRAME_DISPLAY_INFO (f)->wm_type == X_WMTYPE_UNKNOWN
+ || (FRAME_DISPLAY_INFO (f)->wm_type == X_WMTYPE_A
+ && (FRAME_X_OUTPUT (f)->move_offset_left == 0
+ && FRAME_X_OUTPUT (f)->move_offset_top == 0))))
+ x_check_expected_move (f, modified_left, modified_top);
+ }
+ /* Instead, just wait for the last ConfigureWindow request to
+ complete. No window manager is involved when moving child
+ frames. */
+ else
+ XSync (FRAME_X_DISPLAY (f), False);
+ }
unblock_input ();
}
@@ -26734,6 +27621,12 @@ x_wm_supports_1 (struct x_display_info *dpyinfo, Atom want_atom)
if (!NILP (Vx_no_window_manager))
return false;
+ /* If the window system says Emacs is untrusted, there will be no
+ way to send any information to the window manager, making any
+ hints useless. */
+ if (dpyinfo->untrusted)
+ return false;
+
block_input ();
x_catch_errors (dpy);
@@ -27204,13 +28097,12 @@ do_ewmh_fullscreen (struct frame *f)
static void
XTfullscreen_hook (struct frame *f)
{
- if (FRAME_VISIBLE_P (f))
- {
- block_input ();
- x_check_fullscreen (f);
- x_sync (f);
- unblock_input ();
- }
+ if (!FRAME_VISIBLE_P (f))
+ return;
+
+ block_input ();
+ x_check_fullscreen (f);
+ unblock_input ();
}
@@ -27304,10 +28196,7 @@ x_check_fullscreen (struct frame *f)
if (FRAME_VISIBLE_P (f))
x_wait_for_event (f, ConfigureNotify);
else
- {
- change_frame_size (f, width, height, false, true, false);
- x_sync (f);
- }
+ change_frame_size (f, width, height, false, true, false);
}
/* `x_net_wm_state' might have reset the fullscreen frame parameter,
@@ -27481,6 +28370,12 @@ x_set_window_size_1 (struct frame *f, bool change_gravity,
we have to make sure to do it here. */
SET_FRAME_GARBAGED (f);
+ /* The following code is too slow over a latent network
+ connection, so skip it when the user says so. */
+
+ if (!NILP (Vx_lax_frame_positioning))
+ return;
+
/* Now, strictly speaking, we can't be sure that this is accurate,
but the window manager will get around to dealing with the size
change request eventually, and we'll hear how it went when the
@@ -27521,8 +28416,6 @@ x_set_window_size_1 (struct frame *f, bool change_gravity,
adjust_frame_size (f, FRAME_PIXEL_TO_TEXT_WIDTH (f, width),
FRAME_PIXEL_TO_TEXT_HEIGHT (f, height),
5, 0, Qx_set_window_size_1);
-
- x_sync (f);
}
}
@@ -27576,7 +28469,7 @@ frame_set_mouse_pixel_position (struct frame *f, int pix_x, int pix_y)
&& deviceid != -1)
{
block_input ();
- x_ignore_errors_for_next_request (FRAME_DISPLAY_INFO (f));
+ x_ignore_errors_for_next_request (FRAME_DISPLAY_INFO (f), 0);
XIWarpPointer (FRAME_X_DISPLAY (f), deviceid, None,
FRAME_X_WINDOW (f), 0, 0, 0, 0, pix_x, pix_y);
x_stop_ignoring_errors (FRAME_DISPLAY_INFO (f));
@@ -27873,7 +28766,7 @@ x_set_input_focus (struct x_display_info *dpyinfo, Window window,
{
eassert (device->use == XIMasterPointer);
- x_ignore_errors_for_next_request (dpyinfo);
+ x_ignore_errors_for_next_request (dpyinfo, 0);
XISetFocus (dpyinfo->display, device->attachment,
/* Note that the input extension
only supports RevertToParent-type
@@ -27888,7 +28781,7 @@ x_set_input_focus (struct x_display_info *dpyinfo, Window window,
/* Otherwise, use the pointer device that the X server says is the
client pointer. */
- x_ignore_errors_for_next_request (dpyinfo);
+ x_ignore_errors_for_next_request (dpyinfo, 0);
XSetInputFocus (dpyinfo->display, window, RevertToParent, time);
x_stop_ignoring_errors (dpyinfo);
}
@@ -27908,11 +28801,46 @@ x_focus_frame (struct frame *f, bool noactivate)
struct x_display_info *dpyinfo;
Time time;
+ dpyinfo = FRAME_DISPLAY_INFO (f);
+
+ if (dpyinfo->untrusted)
+ /* The X server ignores all input focus related requests from
+ untrusted clients. */
+ return;
+
/* The code below is not reentrant wrt to dpyinfo->x_focus_frame and
friends being set. */
block_input ();
- dpyinfo = FRAME_DISPLAY_INFO (f);
+#ifdef HAVE_GTK3
+ /* read_minibuf assumes that calling Fx_focus_frame on a frame that
+ is already selected won't move the focus elsewhere, and thereby
+ disrupt any focus redirection to e.g. a minibuffer frame that
+ might be activated between that call being made and the
+ consequent XI_FocusIn/Out events arriving. This is true whether
+ the focus is ultimately transferred back to the frame it was
+ initially on or not.
+
+ GTK 3 moves the keyboard focus to the edit widget's window
+ whenever it receives a FocusIn event targeting the outer window.
+ This operation gives rise to a FocusOut event that clears
+ device->focus_frame, which in turn prompts xi_handle_focus_change
+ to clear the display's focus frame. The next FocusIn event
+ destined for the same frame registers as a new focus, which
+ cancels any focus redirection from that frame.
+
+ To prevent this chain of events from disrupting focus redirection
+ when the minibuffer is activated twice in rapid succession while
+ configured to redirect focus to a minibuffer frame, ignore frames
+ which hold the input focus and are connected to a minibuffer
+ window. (bug#65116)*/
+
+ if (f == dpyinfo->x_focus_frame && !FRAME_HAS_MINIBUF_P (f))
+ {
+ unblock_input ();
+ return;
+ }
+#endif /* HAVE_GTK3 */
if (FRAME_X_EMBEDDED_P (f))
/* For Xembedded frames, normally the embedder forwards key
@@ -28025,7 +28953,7 @@ xembed_send_message (struct frame *f, Time t, enum xembed_message msg,
but I don't understand why: there is no way for clients to
survive the death of the parent anyway. */
- x_ignore_errors_for_next_request (FRAME_DISPLAY_INFO (f));
+ x_ignore_errors_for_next_request (FRAME_DISPLAY_INFO (f), 0);
XSendEvent (FRAME_X_DISPLAY (f), FRAME_X_OUTPUT (f)->parent_desc,
False, NoEventMask, &event);
x_stop_ignoring_errors (FRAME_DISPLAY_INFO (f));
@@ -28176,6 +29104,7 @@ x_make_frame_visible (struct frame *f)
&& !FRAME_ICONIFIED_P (f)
&& !FRAME_X_EMBEDDED_P (f)
&& !FRAME_PARENT_FRAME (f)
+ && NILP (Vx_lax_frame_positioning)
&& f->win_gravity == NorthWestGravity
&& previously_visible)
{
@@ -28204,7 +29133,8 @@ x_make_frame_visible (struct frame *f)
}
/* Try to wait for a MapNotify event (that is what tells us when a
- frame becomes visible). */
+ frame becomes visible). Unless `x-lax-frame-positioning' is
+ non-nil: there, that is a little slow. */
#ifdef CYGWIN
/* On Cygwin, which uses input polling, we need to force input to
@@ -28222,7 +29152,8 @@ x_make_frame_visible (struct frame *f)
poll_suppress_count = old_poll_suppress_count;
#endif
- if (!FRAME_VISIBLE_P (f))
+ if (!FRAME_VISIBLE_P (f)
+ && NILP (Vx_lax_frame_positioning))
{
if (CONSP (frame_size_history))
frame_size_history_plain
@@ -28255,6 +29186,11 @@ x_make_frame_invisible (struct frame *f)
block_input ();
+#ifdef HAVE_XINPUT2_2
+ /* Remove any touch points associated with F. */
+ xi_unlink_touch_points (f);
+#endif
+
/* Before unmapping the window, update the WM_SIZE_HINTS property to claim
that the current position of the window is user-specified, rather than
program-specified, so that when the window is mapped again, it will be
@@ -28279,7 +29215,10 @@ x_make_frame_invisible (struct frame *f)
error ("Can't notify window manager of window withdrawal");
}
- x_sync (f);
+ /* Don't perform the synchronization if the network connection is
+ slow, and the user says it is unwanted. */
+ if (NILP (Vx_lax_frame_positioning))
+ XSync (FRAME_X_DISPLAY (f), False);
/* We can't distinguish this from iconification
just by the event that we get from the server.
@@ -28290,8 +29229,7 @@ x_make_frame_invisible (struct frame *f)
SET_FRAME_ICONIFIED (f, false);
if (CONSP (frame_size_history))
- frame_size_history_plain
- (f, build_string ("x_make_frame_invisible"));
+ frame_size_history_plain (f, build_string ("x_make_frame_invisible"));
unblock_input ();
}
@@ -28458,6 +29396,11 @@ x_free_frame_resources (struct frame *f)
xi_handle_delete_frame (dpyinfo, f);
#endif
+#ifdef HAVE_XINPUT2_2
+ /* Remove any touch points associated with F. */
+ xi_unlink_touch_points (f);
+#endif
+
/* If a display connection is dead, don't try sending more
commands to the X server. */
if (dpyinfo->display)
@@ -28641,7 +29584,15 @@ x_free_frame_resources (struct frame *f)
if (f == hlinfo->mouse_face_mouse_frame)
reset_mouse_highlight (hlinfo);
+ /* These two need to be freed now that they are used to compute the
+ mouse position, I think. */
+ if (f == dpyinfo->last_mouse_motion_frame)
+ dpyinfo->last_mouse_motion_frame = NULL;
+ if (f == dpyinfo->last_mouse_frame)
+ dpyinfo->last_mouse_frame = NULL;
+
#ifdef HAVE_XINPUT2
+#if !defined USE_X_TOOLKIT && (!defined USE_GTK || defined HAVE_GTK3)
/* Consider a frame being unfocused with no following FocusIn event
while an older focus from another seat exists. The client
pointer should then revert to the other seat, so handle potential
@@ -28649,7 +29600,8 @@ x_free_frame_resources (struct frame *f)
if (dpyinfo->supports_xi2)
xi_handle_focus_change (dpyinfo);
-#endif
+#endif /* !USE_X_TOOLKIT && (!USE_GTK || HAVE_GTK3) */
+#endif /* HAVE_XINPUT2 */
unblock_input ();
}
@@ -28877,6 +29829,53 @@ x_get_atom_name (struct x_display_info *dpyinfo, Atom atom,
return value;
}
+/* Intern an array of atoms, and do so quickly, avoiding extraneous
+ roundtrips to the X server.
+
+ Avoid sending atoms that have already been found to the X server.
+ This cannot do anything that will end up triggering garbage
+ collection. */
+
+void
+x_intern_atoms (struct x_display_info *dpyinfo, char **names, int count,
+ Atom *atoms_return)
+{
+ int i, j, indices[256];
+ char *new_names[256];
+ Atom results[256], candidate;
+
+ if (count > 256)
+ /* Atoms array too big to inspect reasonably, just send it to the
+ server and back. */
+ XInternAtoms (dpyinfo->display, new_names, count, False, atoms_return);
+ else
+ {
+ for (i = 0, j = 0; i < count; ++i)
+ {
+ candidate = x_intern_cached_atom (dpyinfo, names[i],
+ true);
+
+ if (candidate)
+ atoms_return[i] = candidate;
+ else
+ {
+ indices[j++] = i;
+ new_names[j - 1] = names[i];
+ }
+ }
+
+ if (!j)
+ return;
+
+ /* Now, get the results back from the X server. */
+ XInternAtoms (dpyinfo->display, new_names, j, False,
+ results);
+
+ for (i = 0; i < j; ++i)
+ atoms_return[indices[i]] = results[i];
+ }
+}
+
#ifndef USE_GTK
/* Set up XEmbed for F, and change its save set to handle the parent
@@ -29425,9 +30424,11 @@ struct x_display_info *
x_term_init (Lisp_Object display_name, char *xrm_option, char *resource_name)
{
Display *dpy;
+ XKeyboardState keyboard_state;
struct terminal *terminal;
struct x_display_info *dpyinfo;
XrmDatabase xrdb;
+ Lisp_Object tem, quit_keysym;
#ifdef USE_XCB
xcb_connection_t *xcb_conn;
#endif
@@ -29438,7 +30439,7 @@ x_term_init (Lisp_Object display_name, char *xrm_option, char *resource_name)
GdkScreen *gscr;
#endif
#ifdef HAVE_XFIXES
- Lisp_Object tem, lisp_name;
+ Lisp_Object lisp_name;
int num_fast_selections;
Atom selection_name;
#ifdef USE_XCB
@@ -29644,6 +30645,32 @@ x_term_init (Lisp_Object display_name, char *xrm_option, char *resource_name)
dpyinfo = xzalloc (sizeof *dpyinfo);
terminal = x_create_terminal (dpyinfo);
+ if (!NILP (Vx_detect_server_trust))
+ {
+ /* Detect whether or not the X server trusts this client, which
+ is done by making a SetKeyboardControl request and checking
+ for an Access error. */
+ XGrabServer (dpy);
+ XGetKeyboardControl (dpy, &keyboard_state);
+
+ x_catch_errors (dpy);
+
+ /* At this point, the display is not on x_display_list, so
+ x_uncatch_errors won't sync. However, that's okay because
+ x_had_errors_p will. */
+
+ if (keyboard_state.global_auto_repeat
+ == AutoRepeatModeOn)
+ XAutoRepeatOn (dpy);
+ else
+ XAutoRepeatOff (dpy);
+
+ if (x_had_errors_p (dpy))
+ dpyinfo->untrusted = true;
+ x_uncatch_errors_after_check ();
+ XUngrabServer (dpy);
+ }
+
dpyinfo->next_failable_request = dpyinfo->failable_requests;
{
@@ -29664,13 +30691,17 @@ x_term_init (Lisp_Object display_name, char *xrm_option, char *resource_name)
{
char *vendor = ServerVendor (dpy);
- /* Temporarily hide the partially initialized terminal. */
+ /* Temporarily hide the partially initialized terminal.
+ Use safe_call so that if a signal happens, a partially
+ initialized display (and display connection) is not
+ kept around. */
terminal_list = terminal->next_terminal;
unblock_input ();
- kset_system_key_alist
- (terminal->kboard,
- call1 (Qvendor_specific_keysyms,
- vendor ? build_string (vendor) : empty_unibyte_string));
+ kset_system_key_alist (terminal->kboard,
+ safe_calln (Qvendor_specific_keysyms,
+ (vendor
+ ? build_string (vendor)
+ : empty_unibyte_string)));
block_input ();
terminal->next_terminal = terminal_list;
terminal_list = terminal;
@@ -29685,6 +30716,28 @@ x_term_init (Lisp_Object display_name, char *xrm_option, char *resource_name)
terminal->kboard->reference_count++;
}
+ /* Now look through Vx_quit_keysym for the quit keysym associated
+ with this display. */
+ tem = Vx_quit_keysym;
+ FOR_EACH_TAIL_SAFE (tem)
+ {
+ quit_keysym = XCAR (tem);
+
+ /* Check if its car is a string and its cdr a valid keysym.
+ Skip if it is not. */
+
+ if (!CONSP (quit_keysym) || !FIXNUMP (XCDR (quit_keysym))
+ || !STRINGP (XCAR (quit_keysym)))
+ continue;
+
+ /* Check if this is the keysym to be used. */
+
+ if (strcmp (SSDATA (XCAR (quit_keysym)), ServerVendor (dpy)))
+ continue;
+
+ dpyinfo->quit_keysym = XFIXNUM (XCDR (quit_keysym));
+ }
+
/* Put this display on the chain. */
dpyinfo->next = x_display_list;
x_display_list = dpyinfo;
@@ -29719,7 +30772,7 @@ x_term_init (Lisp_Object display_name, char *xrm_option, char *resource_name)
{
static char const at[] = " at ";
ptrdiff_t nbytes = sizeof (title) + sizeof (at);
- if (INT_ADD_WRAPV (nbytes, SBYTES (system_name), &nbytes))
+ if (ckd_add (&nbytes, nbytes, SBYTES (system_name)))
memory_full (SIZE_MAX);
dpyinfo->x_id_name = xmalloc (nbytes);
sprintf (dpyinfo->x_id_name, "%s%s%s", title, at, SDATA (system_name));
@@ -30198,7 +31251,7 @@ x_term_init (Lisp_Object display_name, char *xrm_option, char *resource_name)
#ifdef XkbLC_ControlFallback
XkbSetXlibControls (dpyinfo->display, XkbLC_ControlFallback, 0);
#endif /* XkbLC_ControlFallback */
-#endif
+#endif /* HAVE_XKB */
#ifdef HAVE_XFIXES
int xfixes_error_base;
@@ -30298,16 +31351,8 @@ x_term_init (Lisp_Object display_name, char *xrm_option, char *resource_name)
1, 0, 1);
dpyinfo->invisible_cursor = make_invisible_cursor (dpyinfo);
-#ifdef HAVE_XFIXES
- dpyinfo->fixes_pointer_blanking = egetenv ("EMACS_XFIXES");
-#endif
-
-#ifdef HAVE_X_I18N
- /* Avoid initializing input methods if the X library does not
- support Emacs's locale. When the current locale is not
- supported, decoding input method strings becomes undefined. */
- if (XSupportsLocale ())
- xim_initialize (dpyinfo, resource_name);
+#if defined HAVE_XFIXES && XFIXES_VERSION >= 40000
+ dpyinfo->fixes_pointer_blanking = (egetenv ("EMACS_XFIXES") != NULL);
#endif
xsettings_initialize (dpyinfo);
@@ -30368,25 +31413,33 @@ x_term_init (Lisp_Object display_name, char *xrm_option, char *resource_name)
XSynchronize (dpyinfo->display, True);
}
+#ifdef HAVE_X_I18N
{
AUTO_STRING (useXIM, "useXIM");
AUTO_STRING (UseXIM, "UseXIM");
Lisp_Object value = gui_display_get_resource (dpyinfo, useXIM, UseXIM,
Qnil, Qnil);
+
+ /* `USE_XIM' controls whether Emacs should use X input methods by
+ default, not whether or not XIM is available. */
+
#ifdef USE_XIM
+ dpyinfo->use_xim = true;
+
if (STRINGP (value)
&& (!strcmp (SSDATA (value), "false")
|| !strcmp (SSDATA (value), "off")))
- use_xim = false;
-#else
+ dpyinfo->use_xim = false;
+#else /* !USE_XIM */
+ dpyinfo->use_xim = false;
+
if (STRINGP (value)
&& (!strcmp (SSDATA (value), "true")
|| !strcmp (SSDATA (value), "on")))
- use_xim = true;
-#endif
+ dpyinfo->use_xim = true;
+#endif /* USE_XIM */
}
-#ifdef HAVE_X_I18N
{
AUTO_STRING (inputStyle, "inputStyle");
AUTO_STRING (InputStyle, "InputStyle");
@@ -30408,10 +31461,19 @@ x_term_init (Lisp_Object display_name, char *xrm_option, char *resource_name)
#ifdef USE_GTK
else if (!strcmp (SSDATA (value), "native"))
dpyinfo->prefer_native_input = true;
-#endif
+#endif /* HAVE_GTK */
}
}
-#endif
+
+ /* Now that defaults have been set up, initialize input method
+ support. */
+
+ /* Avoid initializing input methods if the X library does not
+ support Emacs's locale. When the current locale is not
+ supported, decoding input method strings becomes undefined. */
+ if (XSupportsLocale ())
+ xim_initialize (dpyinfo, resource_name);
+#endif /* HAVE_X_I18N */
#ifdef HAVE_X_SM
/* Only do this for the very first display in the Emacs session.
@@ -30478,7 +31540,6 @@ x_term_init (Lisp_Object display_name, char *xrm_option, char *resource_name)
dpyinfo->selection_tracking_window,
selection_name,
(XFixesSetSelectionOwnerNotifyMask
- | XFixesSetSelectionOwnerNotifyMask
| XFixesSelectionClientCloseNotifyMask));
}
@@ -30626,8 +31687,13 @@ x_delete_display (struct x_display_info *dpyinfo)
last = ie;
}
+ /* Delete selection requests bound for dpyinfo from the keyboard
+ buffer. */
x_delete_selection_requests (dpyinfo);
+ /* And remove any outstanding selection transfers. */
+ x_remove_selection_transfers (dpyinfo);
+
if (next_noop_dpyinfo == dpyinfo)
next_noop_dpyinfo = dpyinfo->next;
@@ -30799,14 +31865,22 @@ x_delete_terminal (struct terminal *terminal)
#ifdef HAVE_X_I18N
/* We must close our connection to the XIM server before closing the
X display. */
- if (dpyinfo->xim)
- xim_close_dpy (dpyinfo);
+ xim_close_dpy (dpyinfo);
#endif
+ /* Destroy all bitmap images created on the display. */
+ image_destroy_all_bitmaps (dpyinfo);
+
+ /* Free the storage allocated to hold bitmap records. */
+ xfree (dpyinfo->bitmaps);
+
+ /* In case someone decides to use `bitmaps' again... */
+ dpyinfo->bitmaps = NULL;
+ dpyinfo->bitmaps_last = 0;
+
/* Normally, the display is available... */
if (dpyinfo->display)
{
- image_destroy_all_bitmaps (dpyinfo);
XSetCloseDownMode (dpyinfo->display, DestroyAll);
/* Delete the scratch cursor GC, should it exist. */
@@ -31054,7 +32128,37 @@ x_initialize (void)
XSetIOErrorHandler (x_io_error_quitter);
}
-#ifdef USE_GTK
+#ifdef HAVE_X_I18N
+
+/* Notice that a change has occurred on F that requires its input
+ method state to be reset. */
+
+static void
+x_reset_conversion (struct frame *f)
+{
+ char *string;
+
+ if (FRAME_XIC (f))
+ {
+ string = XmbResetIC (FRAME_XIC (f));
+
+ /* string is actually any string that was being composed at the
+ time of the reset. */
+
+ if (string)
+ XFree (string);
+ }
+}
+
+/* Interface used to control input method ``text conversion''. */
+
+static struct textconv_interface text_conversion_interface =
+ {
+ x_reset_conversion,
+ };
+
+#endif
+
void
init_xterm (void)
{
@@ -31068,8 +32172,11 @@ init_xterm (void)
gdk_disable_multidevice ();
#endif
#endif
-}
+
+#ifdef HAVE_X_I18N
+ register_textconv_interface (&text_conversion_interface);
#endif
+}
void
mark_xterm (void)
@@ -31133,7 +32240,7 @@ x_catch_errors_for_lisp (struct x_display_info *dpyinfo)
if (!x_fast_protocol_requests)
x_catch_errors (dpyinfo->display);
else
- x_ignore_errors_for_next_request (dpyinfo);
+ x_ignore_errors_for_next_request (dpyinfo, 0);
}
void
@@ -31342,6 +32449,8 @@ syms_of_xterm (void)
DEFSYM (Qnow, "now");
DEFSYM (Qx_dnd_targets_list, "x-dnd-targets-list");
DEFSYM (Qx_auto_preserve_selections, "x-auto-preserve-selections");
+ DEFSYM (Qexpose, "expose");
+ DEFSYM (Qdont_save, "dont-save");
#ifdef USE_GTK
xg_default_icon_file = build_pure_c_string ("icons/hicolor/scalable/apps/emacs.svg");
@@ -31399,7 +32508,9 @@ adjusted if the default value does not work for whatever reason. */);
A value of nil means Emacs doesn't use toolkit scroll bars.
With the X Window system, the value is a symbol describing the
X toolkit. Possible values are: gtk, motif, xaw, or xaw3d.
-With MS Windows, Haiku windowing or Nextstep, the value is t. */);
+With MS Windows, Haiku windowing or Nextstep, the value is t.
+With Android, the value is nil, but that is because Emacs on
+Android does not support scroll bars at all. */);
#ifdef USE_TOOLKIT_SCROLL_BARS
#ifdef USE_MOTIF
Vx_toolkit_scroll_bars = intern_c_string ("motif");
@@ -31433,38 +32544,45 @@ With MS Windows, Haiku windowing or Nextstep, the value is t. */);
DEFSYM (Qreally_fast, "really-fast");
DEFVAR_LISP ("x-ctrl-keysym", Vx_ctrl_keysym,
- doc: /* Which keys Emacs uses for the ctrl modifier.
-This should be one of the symbols `ctrl', `alt', `hyper', `meta',
-`super'. For example, `ctrl' means use the Ctrl_L and Ctrl_R keysyms.
-The default is nil, which is the same as `ctrl'. */);
+ doc: /* Which modifer value Emacs reports when Ctrl is depressed.
+This should be one of the symbols `ctrl', `alt', `hyper', `meta', or
+`super', representing a modifier to be reported for key events with the
+Ctrl modifier (i.e. the keysym Ctrl_L or Ctrl_R) depressed, with nil or
+any other value equivalent to `ctrl'. */);
Vx_ctrl_keysym = Qnil;
DEFVAR_LISP ("x-alt-keysym", Vx_alt_keysym,
- doc: /* Which keys Emacs uses for the alt modifier.
-This should be one of the symbols `ctrl', `alt', `hyper', `meta',
-`super'. For example, `alt' means use the Alt_L and Alt_R keysyms.
-The default is nil, which is the same as `alt'. */);
+ doc: /* Which modifer value Emacs reports when Alt is depressed.
+This should be one of the symbols `ctrl', `alt', `hyper', `meta', or
+`super', representing a modifier to be reported for key events with the
+Alt modifier (e.g. the keysym Alt_L or Alt_R, if the keyboard features a
+dedicated key for Meta) depressed, with nil or any other value
+equivalent to `alt'. */);
Vx_alt_keysym = Qnil;
DEFVAR_LISP ("x-hyper-keysym", Vx_hyper_keysym,
- doc: /* Which keys Emacs uses for the hyper modifier.
-This should be one of the symbols `ctrl', `alt', `hyper', `meta',
-`super'. For example, `hyper' means use the Hyper_L and Hyper_R
-keysyms. The default is nil, which is the same as `hyper'. */);
+ doc: /* Which modifer value Emacs reports when Hyper is depressed.
+This should be one of the symbols `ctrl', `alt', `hyper', `meta', or
+`super', representing a modifier to be reported for key events with the
+Hyper modifier (i.e. the keysym Hyper_L or Hyper_R) depressed, with nil
+or any other value equivalent to `hyper'. */);
Vx_hyper_keysym = Qnil;
DEFVAR_LISP ("x-meta-keysym", Vx_meta_keysym,
- doc: /* Which keys Emacs uses for the meta modifier.
-This should be one of the symbols `ctrl', `alt', `hyper', `meta',
-`super'. For example, `meta' means use the Meta_L and Meta_R keysyms.
-The default is nil, which is the same as `meta'. */);
+ doc: /* Which modifer value Emacs reports when Meta is depressed.
+This should be one of the symbols `ctrl', `alt', `hyper', `meta', or
+`super', representing a modifier to be reported for key events with the
+Meta modifier (e.g. the keysym Alt_L or Alt_R, when the keyboard does
+not feature a dedicated key for Meta) depressed, with nil or any other
+value equivalent to `meta'. */);
Vx_meta_keysym = Qnil;
DEFVAR_LISP ("x-super-keysym", Vx_super_keysym,
- doc: /* Which keys Emacs uses for the super modifier.
-This should be one of the symbols `ctrl', `alt', `hyper', `meta',
-`super'. For example, `super' means use the Super_L and Super_R
-keysyms. The default is nil, which is the same as `super'. */);
+ doc: /* Which modifer value Emacs reports when Super is depressed.
+This should be one of the symbols `ctrl', `alt', `hyper', `meta', or
+`super', representing a modifier to be reported for key events with the
+Super modifier (i.e. the keysym Super_L or Super_R) depressed, with nil
+or any other value equivalent to `super'. */);
Vx_super_keysym = Qnil;
DEFVAR_LISP ("x-wait-for-event-timeout", Vx_wait_for_event_timeout,
@@ -31480,10 +32598,7 @@ If set to a non-float value, there will be no wait at all. */);
DEFVAR_LISP ("x-keysym-table", Vx_keysym_table,
doc: /* Hash table of character codes indexed by X keysym codes. */);
- Vx_keysym_table = make_hash_table (hashtest_eql, 900,
- DEFAULT_REHASH_SIZE,
- DEFAULT_REHASH_THRESHOLD,
- Qnil, false);
+ Vx_keysym_table = make_hash_table (&hashtest_eql, 900, Weak_None, false);
DEFVAR_BOOL ("x-frame-normalize-before-maximize",
x_frame_normalize_before_maximize,
@@ -31511,7 +32626,6 @@ always uses gtk_window_move and ignores the value of this variable. */);
This option is only effective when Emacs is built with XInput 2
support. */);
Vx_scroll_event_delta_factor = make_float (1.0);
- DEFSYM (Qexpose, "expose");
DEFVAR_BOOL ("x-gtk-use-native-input", x_gtk_use_native_input,
doc: /* Non-nil means to use GTK for input method support.
@@ -31536,10 +32650,12 @@ reported as iconified. */);
DEFVAR_BOOL ("x-input-grab-touch-events", x_input_grab_touch_events,
doc: /* Non-nil means to actively grab touch events.
-This means touch sequences that started on an Emacs frame will
-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. */);
+This means touch sequences that are obtained through a passive grab on
+an Emacs frame (or a parent window of such a frame) will reliably
+continue to receive updates, but may cause crashes with some window
+managers and/or external programs. Changing this option is only
+useful when other programs are making their own X requests pertaining
+to the window hierarchy of an Emacs frame. */);
x_input_grab_touch_events = true;
DEFVAR_BOOL ("x-dnd-fix-motif-leave", x_dnd_fix_motif_leave,
@@ -31725,4 +32841,40 @@ select text over slow X connections.
If that is still too slow, setting this variable to the symbol
`really-fast' will make Emacs return only cached values. */);
Vx_use_fast_mouse_position = Qnil;
+
+ DEFVAR_LISP ("x-detect-server-trust", Vx_detect_server_trust,
+ doc: /* If non-nil, Emacs should detect whether or not it is trusted by X.
+
+If non-nil, Emacs will make an X request at connection startup that is
+prohibited to untrusted clients under the X Security Extension and
+check whether or not a resulting Access error is generated by the X
+server. If the X server reports the error, Emacs will disable certain
+features that do not work for untrusted clients. */);
+ Vx_detect_server_trust = Qnil;
+
+ DEFVAR_LISP ("x-lax-frame-positioning", Vx_lax_frame_positioning,
+ doc: /* If non-nil, Emacs won't compensate for WM geometry behavior.
+
+Setting this to non-nil is useful when the compensation proves to be
+too slow, which is usually true when the X server is located over a
+network connection with high latency. Doing so will make frame
+creation and placement faster at the cost of reducing the accuracy of
+frame placement via frame parameters, `set-frame-position', and
+`set-frame-size', along with the actual state of a frame after
+`x_make_frame_invisible'. */);
+ Vx_lax_frame_positioning = Qnil;
+
+ DEFVAR_LISP ("x-quit-keysym", Vx_quit_keysym,
+ doc: /* Keysyms which will cause Emacs to quit if rapidly pressed twice.
+
+This is used to support quitting on devices that do not have any kind
+of physical keyboard, or where the physical keyboard is incapable of
+entering `C-g'.
+
+The value is an alist associating between strings, describing X server
+vendor names, and a single number describing the keysym to use. The
+keysym to use for each display connection is determined upon
+connection setup, and does not reflect further changes to this
+variable. */);
+ Vx_quit_keysym = Qnil;
}
diff --git a/src/xterm.h b/src/xterm.h
index 1f8a7ba5d5f..2c00b1e7bec 100644
--- a/src/xterm.h
+++ b/src/xterm.h
@@ -21,6 +21,22 @@ along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. */
#define XTERM_H
#include <X11/Xlib.h>
+
+#ifdef HAVE_XFIXES
+#include <X11/extensions/Xfixes.h>
+
+#if defined HAVE_XINPUT2 && XFIXES_MAJOR < 5
+/* XI2 headers need PointerBarrier, which is not defined in old
+ versions of the fixes library. Define that type here. */
+typedef XID PointerBarrier;
+#endif
+#if defined HAVE_XCOMPOSITE && XFIXES_MAJOR < 2
+/* Recent Composite headers need XserverRegion, which is not defined
+ in old versions of the fixes library. Define that type here. */
+typedef XID XserverRegion;
+#endif
+#endif
+
#include <X11/cursorfont.h>
/* Include Xutil.h after keysym.h to work around a bug that prevents
@@ -68,7 +84,7 @@ typedef GtkWidget *xt_or_gtk_widget;
#undef XSync
/* gdk_window_process_all_updates is deprecated in GDK 3.22. */
#if GTK_CHECK_VERSION (3, 22, 0)
-#define XSync(d, b) do { XSync ((d), (b)); } while (false)
+#define XSync(d, b) do { XSync (d, b); } while (false)
#else
#define XSync(d, b) do { gdk_window_process_all_updates (); \
XSync (d, b); } while (false)
@@ -239,12 +255,71 @@ struct xi_scroll_valuator_t
#ifdef HAVE_XINPUT2_2
+/* Enum describing the ownership of a touch point.
+
+ The input extension allows other clients to intercept touch
+ sequences destined for a client window through passively grabbing
+ for touch events on a parent window.
+
+ When a passive touch grab for an XI_TouchBegin event activates, one
+ grabbing client is designated the ``owner'' of the touch sequence
+ started by the grabbed event. Touch events are then delivered to
+ both the grabbing client and other clients that have selected for
+ touch events on the subwindow.
+
+ The X server will not deliver TouchEnd events to clients other than
+ the owner until one grabbing client decides to take over processing
+ the touch event sequence, or no more grabbing clients remain.
+ Instead, a TouchUpdate event with the TouchPendingEnd flag is sent,
+ and the TouchEnd event is postponed until the decision is made and
+ all XI_TouchOwnership events are sent.
+
+ If the owner decides to take over processing the touch sequence, an
+ XI_TouchEnd event is delivered to all other clients receiving
+ events for the current touch sequence, who are then expected to
+ cancel or undo any actions which have taken place in reaction to
+ events from that sequence.
+
+ If the owner decides to relinquish ownership over the touch
+ sequence, the X server looks for another grabbing client, and
+ transfers touch ownership to that client instead. Nothing changes
+ from the perspective of clients who have merely selected for events
+ from the subwindow, while an XI_TouchEnd event is delivered to the
+ old owner, and an XI_TouchOwnership event is delivered to the new
+ owner.
+
+ If all grabbing clients reject ownership over the touch sequence,
+ the X server delivers an XI_TouchOwnership event to the client that
+ has selected for touch events on the subwindow, the only client
+ that will receive events for this touch sequence from this time
+ forward. */
+
+enum xi_touch_ownership
+ {
+ /* Emacs doesn't own this touch sequence. */
+ TOUCH_OWNERSHIP_NONE,
+
+ /* Emacs owns this touch sequence. */
+ TOUCH_OWNERSHIP_SELF,
+ };
+
struct xi_touch_point_t
{
- struct xi_touch_point_t *next;
-
+ /* The touchpoint detail. */
int number;
- double x, y;
+
+ /* Whether or not Emacs has ``exclusive'' access to this touch
+ point. */
+ enum xi_touch_ownership ownership;
+
+ /* The last known rounded X and Y positions of the touchpoint. */
+ int x, y;
+
+ /* The frame associated with this touch point. */
+ struct frame *frame;
+
+ /* The next touch point in this list. */
+ struct xi_touch_point_t *next;
};
#endif
@@ -318,6 +393,9 @@ struct x_failable_request
/* If this is zero, then the request has not yet been made.
Otherwise, this is the request that ends this sequence. */
unsigned long end;
+
+ /* Any selection event serial associated with this error trap. */
+ unsigned int selection_serial;
};
#ifdef HAVE_XFIXES
@@ -360,6 +438,10 @@ struct x_display_info
/* Number of frames that are on this display. */
int reference_count;
+ /* True if this display connection cannot communicate with the
+ window manager because it is not trusted by the X server. */
+ bool untrusted;
+
/* The Screen this connection is connected to. */
Screen *screen;
@@ -406,7 +488,7 @@ struct x_display_info
Unused if this display supports Xfixes extension. */
Cursor invisible_cursor;
-#ifdef HAVE_XFIXES
+#if defined HAVE_XFIXES && XFIXES_VERSION >= 40000
/* Whether or not to use Xfixes for pointer blanking. */
bool fixes_pointer_blanking;
#endif
@@ -537,6 +619,12 @@ struct x_display_info
KDE" protocol in x-dnd.el). */
Atom Xatom_DndProtocol, Xatom_DND_PROTOCOL;
+ /* Atoms to make x_intern_cached_atom fast. */
+ Atom Xatom_text_plain_charset_utf_8, Xatom_LENGTH, Xatom_FILE_NAME,
+ Xatom_CHARACTER_POSITION, Xatom_LINE_NUMBER, Xatom_COLUMN_NUMBER,
+ Xatom_OWNER_OS, Xatom_HOST_NAME, Xatom_USER, Xatom_CLASS,
+ Xatom_NAME, Xatom_SAVE_TARGETS;
+
/* 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
@@ -613,7 +701,11 @@ struct x_display_info
/* The named coding system to use for this input method. */
Lisp_Object xim_coding;
-#endif
+
+ /* Whether or not X input methods should be used on this
+ display. */
+ bool use_xim;
+#endif /* HAVE_X_I18N */
/* A cache mapping color names to RGB values. */
struct color_name_cache_entry **color_names;
@@ -884,12 +976,14 @@ struct x_display_info
server_time_monotonic_p will be true). */
int_fast64_t server_time_offset;
#endif
-};
-#ifdef HAVE_X_I18N
-/* Whether or not to use XIM if we have it. */
-extern bool use_xim;
-#endif
+ /* Keysym that will cause Emacs to quit if pressed twice within 150
+ ms. */
+ KeySym quit_keysym;
+
+ /* The last time that keysym was pressed. */
+ Time quit_keysym_time;
+};
#ifdef HAVE_XINPUT2
/* Defined in xmenu.c. */
@@ -1261,6 +1355,21 @@ struct x_output
strictly an optimization to avoid extraneous synchronizing in
some cases. */
int root_x, root_y;
+
+ /* The frame visibility state. This starts out
+ VisibilityFullyObscured, but is set to something else in
+ handle_one_xevent. */
+ int visibility_state;
+
+#ifdef HAVE_XINPUT2_2
+ /* The touch ID of the last touch point to have touched the tool
+ bar. */
+ int tool_bar_touch_id;
+
+ /* The device that last touched the tool bar. 0 if no device
+ touched the tool bar. */
+ int tool_bar_touch_device;
+#endif
};
enum
@@ -1293,7 +1402,7 @@ 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) \
@@ -1338,7 +1447,7 @@ extern void x_mark_frame_dirty (struct frame *f);
FRAME_X_WINDOW (f))
#else /* !USE_GTK */
-#define FRAME_OUTER_WINDOW(f) (FRAME_X_WINDOW (f))
+#define FRAME_OUTER_WINDOW(f) FRAME_X_WINDOW (f)
#endif /* !USE_GTK */
#endif
@@ -1379,6 +1488,11 @@ extern void x_mark_frame_dirty (struct frame *f);
/* And its corresponding visual info. */
#define FRAME_X_VISUAL_INFO(f) (&FRAME_DISPLAY_INFO (f)->visual_info)
+/* Whether or not the frame is visible. Do not test this alone.
+ Instead, use FRAME_REDISPLAY_P. */
+#define FRAME_X_VISIBLE(f) (FRAME_X_OUTPUT (f)->visibility_state \
+ != VisibilityFullyObscured)
+
#ifdef HAVE_XRENDER
#define FRAME_X_PICTURE_FORMAT(f) FRAME_DISPLAY_INFO (f)->pict_format
#define FRAME_X_PICTURE(f) ((f)->output_data.x->picture)
@@ -1644,7 +1758,8 @@ extern bool x_had_errors_p (Display *);
extern void x_unwind_errors_to (int);
extern void x_uncatch_errors (void);
extern void x_uncatch_errors_after_check (void);
-extern void x_ignore_errors_for_next_request (struct x_display_info *);
+extern void x_ignore_errors_for_next_request (struct x_display_info *,
+ unsigned int);
extern void x_stop_ignoring_errors (struct x_display_info *);
extern void x_clear_errors (Display *);
extern void x_set_window_size (struct frame *, bool, int, int);
@@ -1717,6 +1832,11 @@ extern Lisp_Object x_handle_translate_coordinates (struct frame *, Lisp_Object,
extern Bool x_query_pointer (Display *, Window, Window *, Window *, int *,
int *, int *, int *, unsigned int *);
+extern Atom x_intern_cached_atom (struct x_display_info *, const char *,
+ bool);
+extern void x_intern_atoms (struct x_display_info *, char **, int, Atom *);
+extern char *x_get_atom_name (struct x_display_info *, Atom, bool *)
+ ATTRIBUTE_MALLOC ATTRIBUTE_DEALLOC_FREE;
#ifdef HAVE_GTK3
extern void x_scroll_bar_configure (GdkEvent *);
@@ -1798,6 +1918,9 @@ extern void x_handle_property_notify (const XPropertyEvent *);
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_remove_selection_transfers (struct x_display_info *);
+extern void x_handle_selection_error (unsigned int, XErrorEvent *);
+
extern Lisp_Object x_atom_to_symbol (struct x_display_info *, Atom);
extern Atom symbol_to_x_atom (struct x_display_info *, Lisp_Object);
@@ -1807,11 +1930,8 @@ extern bool x_handle_dnd_message (struct frame *,
struct input_event *,
bool, int, int);
extern int x_check_property_data (Lisp_Object);
-extern void x_fill_property_data (Display *,
- Lisp_Object,
- void *,
- int,
- int);
+extern void x_fill_property_data (struct x_display_info *, Lisp_Object,
+ void *, int, int);
extern Lisp_Object x_property_data_to_lisp (struct frame *,
const unsigned char *,
Atom,
@@ -1824,10 +1944,10 @@ extern Lisp_Object x_timestamp_for_selection (struct x_display_info *,
Lisp_Object);
extern void x_own_selection (Lisp_Object, Lisp_Object, Lisp_Object,
Lisp_Object, Time);
-extern Atom x_intern_cached_atom (struct x_display_info *, const char *,
- bool);
-extern char *x_get_atom_name (struct x_display_info *, Atom, bool *)
- ATTRIBUTE_MALLOC ATTRIBUTE_DEALLOC_FREE;
+
+extern void mark_xselect (void);
+
+/* Misc definitions. */
#ifdef USE_GTK
extern bool xg_set_icon (struct frame *, Lisp_Object);
diff --git a/src/xwidget.c b/src/xwidget.c
index 58910459142..389c48ca7f5 100644
--- a/src/xwidget.c
+++ b/src/xwidget.c
@@ -22,7 +22,6 @@ along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. */
#include "buffer.h"
#include "coding.h"
#include "xwidget.h"
-
#include "lisp.h"
#include "blockinput.h"
#include "dispextern.h"
@@ -379,6 +378,8 @@ fails. */)
/* Enable the developer extras. */
settings = webkit_web_view_get_settings (WEBKIT_WEB_VIEW (xw->widget_osr));
g_object_set (G_OBJECT (settings), "enable-developer-extras", TRUE, NULL);
+ g_object_set (G_OBJECT (settings), "enable-javascript",
+ (gboolean) (!xwidget_webkit_disable_javascript), NULL);
}
gtk_widget_set_size_request (GTK_WIDGET (xw->widget_osr), xw->width,
@@ -3972,6 +3973,13 @@ syms_of_xwidget (void)
doc: /* List of all xwidget views. */);
Vxwidget_view_list = Qnil;
+ DEFVAR_BOOL ("xwidget-webkit-disable-javascript", xwidget_webkit_disable_javascript,
+ doc: /* If non-nil, disable execution of JavaScript in xwidget WebKit widgets.
+Modifications to this setting do not take effect in existing WebKit
+widgets; kill all xwidget-webkit buffers for changes in this setting
+to take effect. */);
+ xwidget_webkit_disable_javascript = false;
+
Fprovide (intern ("xwidget-internal"), Qnil);
id_to_xwidget_map = CALLN (Fmake_hash_table, QCtest, Qeq,
diff --git a/test/Makefile.in b/test/Makefile.in
index 3236b040d03..3cbdbec4414 100644
--- a/test/Makefile.in
+++ b/test/Makefile.in
@@ -92,6 +92,10 @@ export TEST_LOAD_EL ?= \
# Additional settings for ert.
ert_opts =
+# Supply a path to local tree-sitter installations, as we run tests
+# without a valid HOME.
+ert_opts += --eval "(setq treesit-extra-load-path '(\"$(HOME)/.emacs.d/tree-sitter\"))"
+
# Maximum length of lines in ert backtraces; nil for no limit.
# (if empty, use the default ert-batch-backtrace-right-margin).
TEST_BACKTRACE_LINE_LENGTH =
@@ -271,8 +275,8 @@ endif
GMP_H = @GMP_H@
LIBGMP = @LIBGMP@
-LIB_CLOCK_GETTIME = @LIB_CLOCK_GETTIME@
-LIB_NANOSLEEP = @LIB_NANOSLEEP@
+CLOCK_TIME_LIB = @CLOCK_TIME_LIB@
+NANOSLEEP_LIB = @NANOSLEEP_LIB@
MODULE_CFLAGS = $(and $(GMP_H),-I.) -I../src -I$(srcdir)/../src \
$(FPIC_CFLAGS) $(PROFILING_CFLAGS) \
@@ -293,7 +297,7 @@ $(test_module): $(test_module:${SO}=.c) ../src/emacs-module.h \
$(AM_V_at)$(CC) -shared $(CPPFLAGS) $(MODULE_CFLAGS) $(LDFLAGS) \
-o $@ $< $(LIBGMP) \
$(and $(GMP_H),$(srcdir)/../lib/mini-gmp.c) \
- $(LIB_CLOCK_GETTIME) $(LIB_NANOSLEEP)
+ $(CLOCK_TIME_LIB) $(NANOSLEEP_LIB)
endif
src/emacs-tests.log: ../lib-src/seccomp-filter.c
@@ -326,6 +330,9 @@ check-all: mostlyclean check-no-automated-subdir
check-maybe: check-no-automated-subdir
@${MAKE} check-doit SELECTOR="${SELECTOR_ACTUAL}"
+check-byte-compile:
+ @${MAKE} $(ELFILES:.el=.elc)
+
## Run the tests.
.PHONY: check-doit
## We can't put LOGFILES as prerequisites, because that would stop the
diff --git a/test/infra/Dockerfile.emba b/test/infra/Dockerfile.emba
index 84f2d2f1806..d79072b06b5 100644
--- a/test/infra/Dockerfile.emba
+++ b/test/infra/Dockerfile.emba
@@ -60,6 +60,80 @@ RUN ./autogen.sh autoconf
RUN ./configure --with-file-notification=gfile
RUN make bootstrap
+# Debian bullseye doesn't provide proper packages. So we use Debian
+# sid for this.
+FROM debian:sid as emacs-eglot
+
+# This corresponds to emacs-base.
+RUN apt-get update && \
+ apt-get install -y --no-install-recommends -o=Dpkg::Use-Pty=0 \
+ libc-dev gcc g++ make autoconf automake libncurses-dev gnutls-dev \
+ libdbus-1-dev libacl1-dev acl git texinfo gdb \
+ && rm -rf /var/lib/apt/lists/*
+
+# Install clangd.
+RUN apt-get update && \
+ apt-get install -y --no-install-recommends -o=Dpkg::Use-Pty=0 \
+ clangd \
+ && rm -rf /var/lib/apt/lists/*
+
+COPY . /checkout
+WORKDIR /checkout
+RUN ./autogen.sh autoconf
+RUN ./configure
+RUN make bootstrap
+
+# Debian bullseye doesn't provide proper packages. So we use Debian
+# sid for this.
+FROM debian:sid as emacs-tree-sitter
+
+# This corresponds to emacs-base.
+RUN apt-get update && \
+ apt-get install -y --no-install-recommends -o=Dpkg::Use-Pty=0 \
+ libc-dev gcc g++ make autoconf automake libncurses-dev gnutls-dev \
+ libdbus-1-dev libacl1-dev acl git texinfo gdb \
+ && rm -rf /var/lib/apt/lists/*
+
+# Install tree-sitter library.
+RUN apt-get update && \
+ apt-get install -y --no-install-recommends -o=Dpkg::Use-Pty=0 \
+ libtree-sitter0 libtree-sitter-dev \
+ && rm -rf /var/lib/apt/lists/*
+
+COPY . /checkout
+WORKDIR /checkout
+RUN ./autogen.sh autoconf
+RUN ./configure --with-tree-sitter
+RUN make bootstrap
+
+# Install language grammars.
+RUN mkdir -p /root/.emacs.d/tree-sitter
+RUN git config --global http.sslverify "false"
+# See https://github.com/emacs-tree-sitter/tree-sitter-langs/tree/master/repos
+RUN src/emacs -Q --batch \
+ --eval '(setq \
+ treesit-extra-load-path (list "/root/.emacs.d/tree-sitter") \
+ treesit-language-source-alist \
+ (quote ((bash "https://github.com/tree-sitter/tree-sitter-bash") \
+ (c "https://github.com/tree-sitter/tree-sitter-c") \
+ (cpp "https://github.com/tree-sitter/tree-sitter-cpp") \
+ (css "https://github.com/tree-sitter/tree-sitter-css") \
+ (elixir "https://github.com/elixir-lang/tree-sitter-elixir") \
+ (go "https://github.com/tree-sitter/tree-sitter-go") \
+ (gomod "https://github.com/camdencheek/tree-sitter-go-mod") \
+ (heex "https://github.com/phoenixframework/tree-sitter-heex") \
+ (html "https://github.com/tree-sitter/tree-sitter-html") \
+ (java "https://github.com/tree-sitter/tree-sitter-java") \
+ (javascript "https://github.com/tree-sitter/tree-sitter-javascript") \
+ (json "https://github.com/tree-sitter/tree-sitter-json") \
+ (lua "https://github.com/tree-sitter-grammars/tree-sitter-lua") \
+ (python "https://github.com/tree-sitter/tree-sitter-python") \
+ (ruby "https://github.com/tree-sitter/tree-sitter-ruby") \
+ (tsx "https://github.com/tree-sitter/tree-sitter-typescript" "master" "tsx/src") \
+ (typescript "https://github.com/tree-sitter/tree-sitter-typescript" "master" "typescript/src"))))' \
+ --eval '(dolist (lang (mapcar (quote car) treesit-language-source-alist)) \
+ (treesit-install-language-grammar lang "/root/.emacs.d/tree-sitter"))'
+
FROM emacs-base as emacs-gnustep
RUN apt-get update && \
diff --git a/test/infra/Makefile.in b/test/infra/Makefile.in
index f20f6ba1c0d..5ae32e7e005 100644
--- a/test/infra/Makefile.in
+++ b/test/infra/Makefile.in
@@ -41,10 +41,18 @@ define subdir_template
SUBDIR_TARGETS += $(target)
$(eval
- ifeq ($(findstring src, $(1)), src)
+ ifeq ($(findstring lib-src, $(1)), lib-src)
define changes
@echo ' - $(1)/*.{h,c}' >>$(FILE)
endef
+ else ifeq ($(findstring src, $(1)), src)
+ define changes
+ @echo ' - $(1)/treesit.{h,c}' >>$(FILE)
+ @echo ' - test/$(1)/treesit-tests.el' >>$(FILE)
+ @echo ' when: never' >>$(FILE)
+ @echo ' - changes:' >>$(FILE)
+ @echo ' - $(1)/*.{h,c}' >>$(FILE)
+ endef
else ifeq ($(findstring eieio, $(1)), eieio)
define changes
@echo ' - lisp/emacs-lisp/eieio*.el' >>$(FILE)
@@ -53,6 +61,17 @@ define subdir_template
define changes
@echo ' - lisp/emacs-lisp/faceup*.el' >>$(FILE)
endef
+ else ifeq ($(findstring progmodes, $(1)), progmodes)
+ define changes
+ @echo ' - $(1)/eglot.el' >>$(FILE)
+ @echo ' - $(1)/*-ts-mode.el' >>$(FILE)
+ @echo ' - test/$(1)/eglot-tests.el' >>$(FILE)
+ @echo ' - test/$(1)/*-ts-mode-resources/**' >>$(FILE)
+ @echo ' - test/$(1)/*-ts-mode-tests.el' >>$(FILE)
+ @echo ' when: never' >>$(FILE)
+ @echo ' - changes:' >>$(FILE)
+ @echo ' - $(1)/*.el' >>$(FILE)
+ endef
else ifeq ($(findstring so-long, $(1)), so-long)
define changes
@echo ' - lisp/so-long*.el' >>$(FILE)
@@ -80,8 +99,8 @@ define subdir_template
@echo ' when: never' >>$(FILE)
@echo ' - changes:' >>$(FILE)
$(changes)
- @echo ' - test/$(1)/*.el' >>$(FILE)
@echo ' - test/$(1)/*resources/**' >>$(FILE)
+ @echo ' - test/$(1)/*.el' >>$(FILE)
@echo ' variables:' >>$(FILE)
@echo ' target: emacs-inotify' >>$(FILE)
@echo ' make_params: "-k -C test $(target)"' >>$(FILE)
@@ -89,11 +108,22 @@ endef
$(foreach subdir, $(SUBDIRS), $(eval $(call subdir_template,$(subdir))))
+TREE-SITTER-FILES ?= $(shell cd .. ; \
+ find lisp src \( -name "*-ts-mode-tests.el" -o -name "treesit-tests.el" \) | \
+ sort | sed s/\\.el/.log/)
+
all: generate-test-jobs
-.PHONY: generate-test-jobs $(FILE) $(SUBDIR_TARGETS)
+.PHONY: generate-test-jobs $(FILE) $(SUBDIR_TARGETS) tree-sitter-files-template
+
+generate-test-jobs: $(FILE) $(SUBDIR_TARGETS) tree-sitter-files-template
-generate-test-jobs: $(FILE) $(SUBDIR_TARGETS)
+tree-sitter-files-template:
+ @echo >>$(FILE)
+ @echo '.tree-sitter-files-template:' >>$(FILE)
+ @echo ' variables:' >>$(FILE)
+ @echo ' tree_sitter_files: >-' >>$(FILE)
+ @for name in $(TREE-SITTER-FILES) ; do echo " $${name}" >>$(FILE) ; done
$(FILE):
$(AM_V_GEN)
diff --git a/test/infra/gitlab-ci.yml b/test/infra/gitlab-ci.yml
index 886503ef0bf..5299aee746b 100644
--- a/test/infra/gitlab-ci.yml
+++ b/test/infra/gitlab-ci.yml
@@ -86,7 +86,7 @@ default:
# TODO: with make -j4 several of the tests were failing, for
# example shadowfile-tests, but passed without it.
- 'export PWD=$(pwd)'
- - 'docker run -i -e EMACS_EMBA_CI=${EMACS_EMBA_CI} -e EMACS_TEST_JUNIT_REPORT=${EMACS_TEST_JUNIT_REPORT} -e EMACS_TEST_TIMEOUT=${EMACS_TEST_TIMEOUT} -e EMACS_TEST_VERBOSE=${EMACS_TEST_VERBOSE} --volumes-from $(docker ps -q -f "label=com.gitlab.gitlab-runner.job.id=${CI_JOB_ID}"):ro --name ${test_name} ${CI_REGISTRY_IMAGE}:${target}-${BUILD_TAG} /bin/bash -c "git fetch ${PWD} HEAD && echo checking out these updated files && git diff --name-only FETCH_HEAD && ( git diff --name-only FETCH_HEAD | xargs git checkout -f FETCH_HEAD ) && make -j4 && make ${make_params}"'
+ - 'docker run -i -e EMACS_EMBA_CI=${EMACS_EMBA_CI} -e EMACS_TEST_JUNIT_REPORT=${EMACS_TEST_JUNIT_REPORT} -e EMACS_TEST_TIMEOUT=${EMACS_TEST_TIMEOUT} -e EMACS_TEST_VERBOSE=${EMACS_TEST_VERBOSE} --volumes-from $(docker ps -q -f "label=com.gitlab.gitlab-runner.job.id=${CI_JOB_ID}"):ro --name ${test_name} ${CI_REGISTRY_IMAGE}:${target}-${BUILD_TAG} /bin/bash -xvc "git fetch ${PWD} HEAD && echo checking out these updated files && git diff --name-only FETCH_HEAD && ( git diff --name-only FETCH_HEAD | xargs git checkout -f FETCH_HEAD ) && make -j4 && make ${make_params}"'
after_script:
# - docker ps -a
# - printenv
@@ -166,16 +166,37 @@ default:
- test/lisp/autorevert-tests.el
- test/lisp/filenotify-tests.el
+.eglot-template:
+ rules:
+ - if: '$CI_PIPELINE_SOURCE == "web"'
+ - if: '$CI_PIPELINE_SOURCE == "schedule"'
+ changes:
+ - "**.in"
+ - lisp/progmodes/eglot.el
+ - test/infra/*
+ - test/lisp/progmodes/eglot-tests.el
+
+.tree-sitter-template:
+ rules:
+ - if: '$CI_PIPELINE_SOURCE == "web"'
+ - if: '$CI_PIPELINE_SOURCE == "schedule"'
+ changes:
+ - "**.in"
+ - lisp/progmodes/*-ts-mode.el
+ - test/infra/*
+ - test/lisp/progmodes/*-ts-mode-resources/**
+ - test/lisp/progmodes/*-ts-mode-tests.el
+
.native-comp-template:
rules:
- if: '$CI_PIPELINE_SOURCE == "web"'
- if: '$CI_PIPELINE_SOURCE == "schedule"'
changes:
- "**.in"
- - lisp/emacs-lisp/comp.el
- - lisp/emacs-lisp/comp-cstr.el
+ - lisp/emacs-lisp/comp*.el
- src/comp.{h,m}
- test/infra/*
+ - test/lisp/emacs-lisp/comp*-tests.el
- test/src/comp-resources/*.el
- test/src/comp-tests.el
timeout: 8 hours
@@ -229,6 +250,40 @@ test-filenotify-gio:
# This is needed in order to get a JUnit test report.
make_params: '-k -C test check-expensive LOGFILES="lisp/autorevert-tests.log lisp/filenotify-tests.log"'
+build-image-eglot:
+ stage: platform-images
+ extends: [.job-template, .build-template, .eglot-template]
+ variables:
+ target: emacs-eglot
+
+test-eglot:
+ stage: platforms
+ extends: [.job-template, .test-template, .eglot-template]
+ needs:
+ - job: build-image-eglot
+ optional: true
+ variables:
+ target: emacs-eglot
+ # This is needed in order to get a JUnit test report.
+ make_params: '-k -C test check-expensive LOGFILES="lisp/progmodes/eglot-tests.log"'
+
+build-image-tree-sitter:
+ stage: platform-images
+ extends: [.job-template, .build-template, .tree-sitter-template]
+ variables:
+ target: emacs-tree-sitter
+
+test-tree-sitter:
+ stage: platforms
+ extends: [.job-template, .test-template, .tree-sitter-template, .tree-sitter-files-template]
+ needs:
+ - job: build-image-tree-sitter
+ optional: true
+ variables:
+ target: emacs-tree-sitter
+ # This is needed in order to get a JUnit test report.
+ make_params: '-k -C test check-expensive TEST_HOME=/root LOGFILES="$tree_sitter_files"'
+
build-image-gnustep:
stage: platform-images
extends: [.job-template, .build-template, .gnustep-template]
diff --git a/test/infra/test-jobs.yml b/test/infra/test-jobs.yml
index 55ce590af89..1f5d607eda4 100644
--- a/test/infra/test-jobs.yml
+++ b/test/infra/test-jobs.yml
@@ -11,8 +11,8 @@ test-lib-src-inotify:
when: never
- changes:
- lib-src/*.{h,c}
- - test/lib-src/*.el
- test/lib-src/*resources/**
+ - test/lib-src/*.el
variables:
target: emacs-inotify
make_params: "-k -C test check-lib-src"
@@ -28,8 +28,8 @@ test-lisp-inotify:
when: never
- changes:
- lisp/*.el
- - test/lisp/*.el
- test/lisp/*resources/**
+ - test/lisp/*.el
variables:
target: emacs-inotify
make_params: "-k -C test check-lisp"
@@ -45,8 +45,8 @@ test-lisp-calc-inotify:
when: never
- changes:
- lisp/calc/*.el
- - test/lisp/calc/*.el
- test/lisp/calc/*resources/**
+ - test/lisp/calc/*.el
variables:
target: emacs-inotify
make_params: "-k -C test check-lisp-calc"
@@ -62,8 +62,8 @@ test-lisp-calendar-inotify:
when: never
- changes:
- lisp/calendar/*.el
- - test/lisp/calendar/*.el
- test/lisp/calendar/*resources/**
+ - test/lisp/calendar/*.el
variables:
target: emacs-inotify
make_params: "-k -C test check-lisp-calendar"
@@ -79,8 +79,8 @@ test-lisp-cedet-inotify:
when: never
- changes:
- lisp/cedet/*.el
- - test/lisp/cedet/*.el
- test/lisp/cedet/*resources/**
+ - test/lisp/cedet/*.el
variables:
target: emacs-inotify
make_params: "-k -C test check-lisp-cedet"
@@ -96,8 +96,8 @@ test-lisp-cedet-semantic-inotify:
when: never
- changes:
- lisp/cedet/semantic/*.el
- - test/lisp/cedet/semantic/*.el
- test/lisp/cedet/semantic/*resources/**
+ - test/lisp/cedet/semantic/*.el
variables:
target: emacs-inotify
make_params: "-k -C test check-lisp-cedet-semantic"
@@ -113,8 +113,8 @@ test-lisp-cedet-semantic-bovine-inotify:
when: never
- changes:
- lisp/cedet/semantic/bovine/*.el
- - test/lisp/cedet/semantic/bovine/*.el
- test/lisp/cedet/semantic/bovine/*resources/**
+ - test/lisp/cedet/semantic/bovine/*.el
variables:
target: emacs-inotify
make_params: "-k -C test check-lisp-cedet-semantic-bovine"
@@ -130,8 +130,8 @@ test-lisp-cedet-srecode-inotify:
when: never
- changes:
- lisp/cedet/srecode/*.el
- - test/lisp/cedet/srecode/*.el
- test/lisp/cedet/srecode/*resources/**
+ - test/lisp/cedet/srecode/*.el
variables:
target: emacs-inotify
make_params: "-k -C test check-lisp-cedet-srecode"
@@ -147,8 +147,8 @@ test-lisp-emacs-lisp-inotify:
when: never
- changes:
- lisp/emacs-lisp/*.el
- - test/lisp/emacs-lisp/*.el
- test/lisp/emacs-lisp/*resources/**
+ - test/lisp/emacs-lisp/*.el
variables:
target: emacs-inotify
make_params: "-k -C test check-lisp-emacs-lisp"
@@ -164,8 +164,8 @@ test-lisp-emacs-lisp-eieio-tests-inotify:
when: never
- changes:
- lisp/emacs-lisp/eieio*.el
- - test/lisp/emacs-lisp/eieio-tests/*.el
- test/lisp/emacs-lisp/eieio-tests/*resources/**
+ - test/lisp/emacs-lisp/eieio-tests/*.el
variables:
target: emacs-inotify
make_params: "-k -C test check-lisp-emacs-lisp-eieio-tests"
@@ -181,8 +181,8 @@ test-lisp-emacs-lisp-faceup-tests-inotify:
when: never
- changes:
- lisp/emacs-lisp/faceup*.el
- - test/lisp/emacs-lisp/faceup-tests/*.el
- test/lisp/emacs-lisp/faceup-tests/*resources/**
+ - test/lisp/emacs-lisp/faceup-tests/*.el
variables:
target: emacs-inotify
make_params: "-k -C test check-lisp-emacs-lisp-faceup-tests"
@@ -198,8 +198,8 @@ test-lisp-emulation-inotify:
when: never
- changes:
- lisp/emulation/*.el
- - test/lisp/emulation/*.el
- test/lisp/emulation/*resources/**
+ - test/lisp/emulation/*.el
variables:
target: emacs-inotify
make_params: "-k -C test check-lisp-emulation"
@@ -215,8 +215,8 @@ test-lisp-erc-inotify:
when: never
- changes:
- lisp/erc/*.el
- - test/lisp/erc/*.el
- test/lisp/erc/*resources/**
+ - test/lisp/erc/*.el
variables:
target: emacs-inotify
make_params: "-k -C test check-lisp-erc"
@@ -232,8 +232,8 @@ test-lisp-eshell-inotify:
when: never
- changes:
- lisp/eshell/*.el
- - test/lisp/eshell/*.el
- test/lisp/eshell/*resources/**
+ - test/lisp/eshell/*.el
variables:
target: emacs-inotify
make_params: "-k -C test check-lisp-eshell"
@@ -249,8 +249,8 @@ test-lisp-gnus-inotify:
when: never
- changes:
- lisp/gnus/*.el
- - test/lisp/gnus/*.el
- test/lisp/gnus/*resources/**
+ - test/lisp/gnus/*.el
variables:
target: emacs-inotify
make_params: "-k -C test check-lisp-gnus"
@@ -266,8 +266,8 @@ test-lisp-image-inotify:
when: never
- changes:
- lisp/image/*.el
- - test/lisp/image/*.el
- test/lisp/image/*resources/**
+ - test/lisp/image/*.el
variables:
target: emacs-inotify
make_params: "-k -C test check-lisp-image"
@@ -283,8 +283,8 @@ test-lisp-international-inotify:
when: never
- changes:
- lisp/international/*.el
- - test/lisp/international/*.el
- test/lisp/international/*resources/**
+ - test/lisp/international/*.el
variables:
target: emacs-inotify
make_params: "-k -C test check-lisp-international"
@@ -300,8 +300,8 @@ test-lisp-mail-inotify:
when: never
- changes:
- lisp/mail/*.el
- - test/lisp/mail/*.el
- test/lisp/mail/*resources/**
+ - test/lisp/mail/*.el
variables:
target: emacs-inotify
make_params: "-k -C test check-lisp-mail"
@@ -317,8 +317,8 @@ test-lisp-mh-e-inotify:
when: never
- changes:
- lisp/mh-e/*.el
- - test/lisp/mh-e/*.el
- test/lisp/mh-e/*resources/**
+ - test/lisp/mh-e/*.el
variables:
target: emacs-inotify
make_params: "-k -C test check-lisp-mh-e"
@@ -334,8 +334,8 @@ test-lisp-net-inotify:
when: never
- changes:
- lisp/net/*.el
- - test/lisp/net/*.el
- test/lisp/net/*resources/**
+ - test/lisp/net/*.el
variables:
target: emacs-inotify
make_params: "-k -C test check-lisp-net"
@@ -351,8 +351,8 @@ test-lisp-nxml-inotify:
when: never
- changes:
- lisp/nxml/*.el
- - test/lisp/nxml/*.el
- test/lisp/nxml/*resources/**
+ - test/lisp/nxml/*.el
variables:
target: emacs-inotify
make_params: "-k -C test check-lisp-nxml"
@@ -368,8 +368,8 @@ test-lisp-obsolete-inotify:
when: never
- changes:
- lisp/obsolete/*.el
- - test/lisp/obsolete/*.el
- test/lisp/obsolete/*resources/**
+ - test/lisp/obsolete/*.el
variables:
target: emacs-inotify
make_params: "-k -C test check-lisp-obsolete"
@@ -385,8 +385,8 @@ test-lisp-org-inotify:
when: never
- changes:
- lisp/org/*.el
- - test/lisp/org/*.el
- test/lisp/org/*resources/**
+ - test/lisp/org/*.el
variables:
target: emacs-inotify
make_params: "-k -C test check-lisp-org"
@@ -402,8 +402,8 @@ test-lisp-play-inotify:
when: never
- changes:
- lisp/play/*.el
- - test/lisp/play/*.el
- test/lisp/play/*resources/**
+ - test/lisp/play/*.el
variables:
target: emacs-inotify
make_params: "-k -C test check-lisp-play"
@@ -418,9 +418,16 @@ test-lisp-progmodes-inotify:
- if: '$CI_PIPELINE_SOURCE == "schedule"'
when: never
- changes:
+ - lisp/progmodes/eglot.el
+ - lisp/progmodes/*-ts-mode.el
+ - test/lisp/progmodes/eglot-tests.el
+ - test/lisp/progmodes/*-ts-mode-resources/**
+ - test/lisp/progmodes/*-ts-mode-tests.el
+ when: never
+ - changes:
- lisp/progmodes/*.el
- - test/lisp/progmodes/*.el
- test/lisp/progmodes/*resources/**
+ - test/lisp/progmodes/*.el
variables:
target: emacs-inotify
make_params: "-k -C test check-lisp-progmodes"
@@ -436,8 +443,8 @@ test-lisp-so-long-tests-inotify:
when: never
- changes:
- lisp/so-long*.el
- - test/lisp/so-long-tests/*.el
- test/lisp/so-long-tests/*resources/**
+ - test/lisp/so-long-tests/*.el
variables:
target: emacs-inotify
make_params: "-k -C test check-lisp-so-long-tests"
@@ -453,8 +460,8 @@ test-lisp-term-inotify:
when: never
- changes:
- lisp/term/*.el
- - test/lisp/term/*.el
- test/lisp/term/*resources/**
+ - test/lisp/term/*.el
variables:
target: emacs-inotify
make_params: "-k -C test check-lisp-term"
@@ -470,8 +477,8 @@ test-lisp-textmodes-inotify:
when: never
- changes:
- lisp/textmodes/*.el
- - test/lisp/textmodes/*.el
- test/lisp/textmodes/*resources/**
+ - test/lisp/textmodes/*.el
variables:
target: emacs-inotify
make_params: "-k -C test check-lisp-textmodes"
@@ -487,8 +494,8 @@ test-lisp-url-inotify:
when: never
- changes:
- lisp/url/*.el
- - test/lisp/url/*.el
- test/lisp/url/*resources/**
+ - test/lisp/url/*.el
variables:
target: emacs-inotify
make_params: "-k -C test check-lisp-url"
@@ -504,8 +511,8 @@ test-lisp-use-package-inotify:
when: never
- changes:
- lisp/use-package/*.el
- - test/lisp/use-package/*.el
- test/lisp/use-package/*resources/**
+ - test/lisp/use-package/*.el
variables:
target: emacs-inotify
make_params: "-k -C test check-lisp-use-package"
@@ -521,8 +528,8 @@ test-lisp-vc-inotify:
when: never
- changes:
- lisp/vc/*.el
- - test/lisp/vc/*.el
- test/lisp/vc/*resources/**
+ - test/lisp/vc/*.el
variables:
target: emacs-inotify
make_params: "-k -C test check-lisp-vc"
@@ -538,8 +545,8 @@ test-misc-inotify:
when: never
- changes:
- admin/*.el
- - test/misc/*.el
- test/misc/*resources/**
+ - test/misc/*.el
variables:
target: emacs-inotify
make_params: "-k -C test check-misc"
@@ -554,9 +561,26 @@ test-src-inotify:
- if: '$CI_PIPELINE_SOURCE == "schedule"'
when: never
- changes:
+ - src/treesit.{h,c}
+ - test/src/treesit-tests.el
+ when: never
+ - changes:
- src/*.{h,c}
- - test/src/*.el
- test/src/*resources/**
+ - test/src/*.el
variables:
target: emacs-inotify
make_params: "-k -C test check-src"
+
+.tree-sitter-files-template:
+ variables:
+ tree_sitter_files: >-
+ lisp/progmodes/c-ts-mode-tests.log
+ lisp/progmodes/elixir-ts-mode-tests.log
+ lisp/progmodes/go-ts-mode-tests.log
+ lisp/progmodes/heex-ts-mode-tests.log
+ lisp/progmodes/java-ts-mode-tests.log
+ lisp/progmodes/lua-ts-mode-tests.log
+ lisp/progmodes/ruby-ts-mode-tests.log
+ lisp/progmodes/typescript-ts-mode-tests.log
+ src/treesit-tests.log
diff --git a/test/lisp/abbrev-tests.el b/test/lisp/abbrev-tests.el
index bfdfac8be1b..cdd1a7832d3 100644
--- a/test/lisp/abbrev-tests.el
+++ b/test/lisp/abbrev-tests.el
@@ -57,12 +57,10 @@
(ert-deftest abbrev-make-abbrev-table-test ()
;; Table without properties:
(let ((table (make-abbrev-table)))
- (should (abbrev-table-p table))
- (should (= (length table) obarray-default-size)))
+ (should (abbrev-table-p table)))
;; Table with one property 'foo with value 'bar:
(let ((table (make-abbrev-table '(foo bar))))
(should (abbrev-table-p table))
- (should (= (length table) obarray-default-size))
(should (eq (abbrev-table-get table 'foo) 'bar))))
(ert-deftest abbrev--table-symbols-test ()
diff --git a/test/lisp/align-resources/align-post.c b/test/lisp/align-resources/align-post.c
deleted file mode 100644
index 157e1d6242a..00000000000
--- a/test/lisp/align-resources/align-post.c
+++ /dev/null
@@ -1,3 +0,0 @@
-int
-main (int argc,
- char *argv[]);
diff --git a/test/lisp/align-resources/align-post.java b/test/lisp/align-resources/align-post.java
deleted file mode 100644
index e0ea8e727f1..00000000000
--- a/test/lisp/align-resources/align-post.java
+++ /dev/null
@@ -1,9 +0,0 @@
-class X
-{
- String field1;
- String[] field2;
- int field3;
- int[] field4;
- X field5;
- X[] field6;
-}
diff --git a/test/lisp/align-resources/align-pre.c b/test/lisp/align-resources/align-pre.c
deleted file mode 100644
index b1774181a40..00000000000
--- a/test/lisp/align-resources/align-pre.c
+++ /dev/null
@@ -1,3 +0,0 @@
-int
-main (int argc,
- char *argv[]);
diff --git a/test/lisp/align-resources/align-pre.java b/test/lisp/align-resources/align-pre.java
deleted file mode 100644
index fe7a87a9393..00000000000
--- a/test/lisp/align-resources/align-pre.java
+++ /dev/null
@@ -1,9 +0,0 @@
-class X
-{
- String field1;
- String[] field2;
- int field3;
- int[] field4;
- X field5;
- X[] field6;
-}
diff --git a/test/lisp/align-resources/align-regexp.erts b/test/lisp/align-resources/align-regexp.erts
new file mode 100644
index 00000000000..fbbd6d6bd33
--- /dev/null
+++ b/test/lisp/align-resources/align-regexp.erts
@@ -0,0 +1,13 @@
+Name: align function declaration
+
+=-=
+Fred (123) 456-7890
+Alice (123) 456-7890
+Mary-Anne (123) 456-7890
+Joe (123) 456-7890
+=-=
+Fred (123) 456-7890
+Alice (123) 456-7890
+Mary-Anne (123) 456-7890
+Joe (123) 456-7890
+=-=-=
diff --git a/test/lisp/align-resources/c-mode.erts b/test/lisp/align-resources/c-mode.erts
new file mode 100644
index 00000000000..a28c2bdbed0
--- /dev/null
+++ b/test/lisp/align-resources/c-mode.erts
@@ -0,0 +1,23 @@
+Name: align function declaration
+
+=-=
+int
+main (int argc,
+ char *argv[]);
+=-=
+int
+main (int argc,
+ char *argv[]);
+=-=-=
+
+Name: example from Commentary
+
+=-=
+ int a = 1;
+ short foo = 2;
+ double blah = 4;
+=-=
+ int a = 1;
+ short foo = 2;
+ double blah = 4;
+=-=-=
diff --git a/test/lisp/align-resources/conf-toml-mode.erts b/test/lisp/align-resources/conf-toml-mode.erts
new file mode 100644
index 00000000000..d1fcbd58708
--- /dev/null
+++ b/test/lisp/align-resources/conf-toml-mode.erts
@@ -0,0 +1,45 @@
+Name: align key-value pairs
+
+=-=
+[foo]
+foo1=10
+foo22=20
+
+[bar]
+bar333="example.org"
+bar4444 = "zzz"
+=-=
+[foo]
+foo1 = 10
+foo22 = 20
+
+[bar]
+bar333 = "example.org"
+bar4444 = "zzz"
+=-=-=
+
+Name: align list values
+
+=-=
+[foo]
+a = 1
+some_list = [
+ true,
+ false,
+]
+some_other_list = [
+ 1,
+ 2,
+]
+=-=
+[foo]
+a = 1
+some_list = [
+ true,
+ false,
+]
+some_other_list = [
+ 1,
+ 2,
+]
+=-=-=
diff --git a/test/lisp/align-resources/css-mode.erts b/test/lisp/align-resources/css-mode.erts
new file mode 100644
index 00000000000..e4455601083
--- /dev/null
+++ b/test/lisp/align-resources/css-mode.erts
@@ -0,0 +1,23 @@
+Name: align attributes
+
+=-=
+div {
+ border: 1px solid black;
+ padding: 25px 50px 75px 100px;
+ background-color: lightblue;
+}
+p.center {
+ text-align: center;
+ color: red;
+}
+=-=
+div {
+ border: 1px solid black;
+ padding: 25px 50px 75px 100px;
+ background-color: lightblue;
+}
+p.center {
+ text-align: center;
+ color: red;
+}
+=-=-=
diff --git a/test/lisp/align-resources/java-mode.erts b/test/lisp/align-resources/java-mode.erts
new file mode 100644
index 00000000000..693a4123121
--- /dev/null
+++ b/test/lisp/align-resources/java-mode.erts
@@ -0,0 +1,23 @@
+Name: align class fields
+
+=-=
+class X
+{
+ String field1;
+ String[] field2;
+ int field3;
+ int[] field4;
+ X field5;
+ X[] field6;
+}
+=-=
+class X
+{
+ String field1;
+ String[] field2;
+ int field3;
+ int[] field4;
+ X field5;
+ X[] field6;
+}
+=-=-=
diff --git a/test/lisp/align-resources/latex-mode.erts b/test/lisp/align-resources/latex-mode.erts
new file mode 100644
index 00000000000..cdc93e4a925
--- /dev/null
+++ b/test/lisp/align-resources/latex-mode.erts
@@ -0,0 +1,29 @@
+Name: tex-record-separator and basic-line-continuation
+
+=-=
+\documentclass{}
+
+\begin{document}
+
+\begin{tabular}{l|l}
+ \textit{Player name} &\textit{Career home runs} \\
+ \hline
+ Hank Aaron &755 \\
+ Babe Ruth &714
+\end{tabular}
+
+\end{document}
+=-=
+\documentclass{}
+
+\begin{document}
+
+\begin{tabular}{l|l}
+ \textit{Player name} & \textit{Career home runs} \\
+ \hline
+ Hank Aaron & 755 \\
+ Babe Ruth & 714
+\end{tabular}
+
+\end{document}
+=-=-=
diff --git a/test/lisp/align-resources/lua-ts-mode.erts b/test/lisp/align-resources/lua-ts-mode.erts
new file mode 100644
index 00000000000..b0473ad6cdf
--- /dev/null
+++ b/test/lisp/align-resources/lua-ts-mode.erts
@@ -0,0 +1,67 @@
+Name: align assignments
+
+=-=
+local first=1
+local s <const> =2
+local last=3
+=-=
+local first = 1
+local s <const> = 2
+local last = 3
+=-=-=
+
+Name: align fields
+
+=-=
+local Table={
+first=1,
+second=2,
+last=3,
+}
+=-=
+local Table = {
+ first = 1,
+ second = 2,
+ last = 3,
+}
+=-=-=
+
+Name: align comments
+
+=-=
+local first-- 1
+local second -- 2
+local last -- 3
+=-=
+local first -- 1
+local second -- 2
+local last -- 3
+=-=-=
+
+Name: align assignments and comments
+
+=-=
+local first=1-- one
+local second=2 -- two
+local last=3 -- three
+=-=
+local first = 1 -- one
+local second = 2 -- two
+local last = 3 -- three
+=-=-=
+
+Name: align fields and comments
+
+=-=
+local T={
+first=1,--one
+second=2, --two
+last=3, --three
+}
+=-=
+local T = {
+ first = 1, --one
+ second = 2, --two
+ last = 3, --three
+}
+=-=-=
diff --git a/test/lisp/align-resources/python-mode.erts b/test/lisp/align-resources/python-mode.erts
new file mode 100644
index 00000000000..1ce50b32dba
--- /dev/null
+++ b/test/lisp/align-resources/python-mode.erts
@@ -0,0 +1,29 @@
+Name: align assignments
+
+=-=
+foo = "bar"
+x = 1
+zzzzz = True
+y = None
+=-=
+foo = "bar"
+x = 1
+zzzzz = True
+y = None
+=-=-=
+
+Name: python-chain-logic and basic-line-continuation
+
+=-=
+if foo or\
+ b and \
+ bcxxx and \
+ c:
+ pass
+=-=
+if foo or \
+ b and \
+ bcxxx and \
+ c:
+ pass
+=-=-=
diff --git a/test/lisp/align-tests.el b/test/lisp/align-tests.el
index 2804b0f2a5d..cd309ea07bf 100644
--- a/test/lisp/align-tests.el
+++ b/test/lisp/align-tests.el
@@ -25,22 +25,56 @@
(require 'ert-x)
(require 'align)
-(defun test-align-compare (file function)
- (should (equal
- (with-temp-buffer
- (insert-file-contents (ert-resource-file (format file "pre")))
- (funcall function)
- (align (point-min) (point-max))
- (buffer-substring-no-properties (point-min) (point-max)))
- (with-temp-buffer
- (insert-file-contents (ert-resource-file (format file "post")))
- (buffer-string)))))
+;;;; align
-(ert-deftest align-java ()
- (test-align-compare "align-%s.java" #'java-mode))
+(defun test-align-transform-fun (function)
+ (lambda ()
+ (funcall function)
+ (align (point-min) (point-max))))
(ert-deftest align-c ()
- (test-align-compare "align-%s.c" #'c-mode))
+ (ert-test-erts-file (ert-resource-file "c-mode.erts")
+ (test-align-transform-fun #'c-mode)))
+
+(ert-deftest align-css ()
+ (let ((indent-tabs-mode nil))
+ (ert-test-erts-file (ert-resource-file "css-mode.erts")
+ (test-align-transform-fun #'css-mode))))
+
+(ert-deftest align-java ()
+ (ert-test-erts-file (ert-resource-file "java-mode.erts")
+ (test-align-transform-fun #'java-mode)))
+
+(ert-deftest align-latex ()
+ (ert-test-erts-file (ert-resource-file "latex-mode.erts")
+ (test-align-transform-fun #'latex-mode)))
+
+(autoload 'treesit-ready-p "treesit")
+
+(ert-deftest align-lua ()
+ (skip-unless (treesit-ready-p 'lua))
+ (let ((comment-column 20)
+ (indent-tabs-mode nil))
+ (ert-test-erts-file (ert-resource-file "lua-ts-mode.erts")
+ (test-align-transform-fun #'lua-ts-mode))))
+
+(ert-deftest align-python ()
+ (ert-test-erts-file (ert-resource-file "python-mode.erts")
+ (test-align-transform-fun #'python-mode)))
+
+(ert-deftest align-toml ()
+ (let ((indent-tabs-mode nil))
+ (ert-test-erts-file (ert-resource-file "conf-toml-mode.erts")
+ (test-align-transform-fun #'conf-toml-mode))))
+
+;;;; align-regexp
+
+(ert-deftest align-regexp ()
+ (let ((indent-tabs-mode nil))
+ (ert-test-erts-file (ert-resource-file "align-regexp.erts")
+ (lambda ()
+ (align-regexp (point-min) (point-max)
+ "\\(\\s-*\\)(")))))
(provide 'align-tests)
diff --git a/test/lisp/arc-mode-tests.el b/test/lisp/arc-mode-tests.el
index 1a8328d529a..acc416d6f78 100644
--- a/test/lisp/arc-mode-tests.el
+++ b/test/lisp/arc-mode-tests.el
@@ -46,6 +46,85 @@
(when (buffer-live-p zip-buffer) (kill-buffer zip-buffer))
(when (buffer-live-p gz-buffer) (kill-buffer gz-buffer)))))
+(ert-deftest arc-mode-test-zip-ensure-ext ()
+ "Regression test for bug#61326."
+ (skip-unless (executable-find "zip"))
+ (let* ((default-directory arc-mode-tests-data-directory)
+ (created-files nil)
+ (base-zip-1 "base-1.zip")
+ (base-zip-2 "base-2.zip")
+ (content-1 '("1" "2"))
+ (content-2 '("3" "4"))
+ (make-file (lambda (name)
+ (push name created-files)
+ (with-temp-buffer
+ (insert name)
+ (write-file name))))
+ (make-zip
+ (lambda (zip files)
+ (delete-file zip nil)
+ (push zip created-files)
+ (funcall (archive--act-files '("zip") files) zip)))
+ (update-fn
+ (lambda (zip-nonempty)
+ (with-current-buffer (find-file-noselect zip-nonempty)
+ (save-excursion
+ (goto-char archive-file-list-start)
+ (save-current-buffer
+ (archive-extract)
+ (save-excursion
+ (goto-char (point-max))
+ (insert ?a)
+ (save-buffer))
+ (kill-buffer (current-buffer)))
+ (archive-extract)
+ ;; [2] must be ?a; [3] must be (eobp)
+ (should (eq (char-after 2) ?a))
+ (should (eq (point-max) 3))))))
+ (delete-fn
+ (lambda (zip-nonempty)
+ (with-current-buffer (find-file-noselect zip-nonempty)
+ ;; mark delete and expunge first entry
+ (save-excursion
+ (goto-char archive-file-list-start)
+ (should (length= archive-files 2))
+ (archive-flag-deleted 1)
+ (archive--expunge-maybe-force t)
+ (should (length= archive-files 1))))))
+ (test-modify
+ (lambda (zip mod-fn)
+ (let ((zip-base (concat zip ".zip"))
+ (tag (gensym)))
+ (push zip created-files)
+ (copy-file base-zip-1 zip t)
+ (push zip-base created-files)
+ (copy-file base-zip-2 zip-base t)
+ (file-has-changed-p zip tag)
+ (file-has-changed-p zip-base tag)
+ (funcall mod-fn zip)
+ (should-not (file-has-changed-p zip-base tag))
+ (should (file-has-changed-p zip tag))))))
+ (unwind-protect
+ (progn
+ ;; setup: make two zip files with different contents
+ (mapc make-file (append content-1 content-2))
+ (funcall make-zip base-zip-1 content-1)
+ (funcall make-zip base-zip-2 content-2)
+
+ ;; test 1: with "test-update" and "test-update.zip", update
+ ;; "test-update": (1) ensure only "test-update" is modified, (2)
+ ;; ensure the contents of the new member is expected.
+ (funcall test-modify "test-update" update-fn)
+
+ ;; test 2: with "test-delete" and "test-delete.zip", delete entry
+ ;; from "test-delete": (1) ensure only "test-delete" is modified,
+ ;; (2) ensure the file list is reduced as expected.
+ (funcall test-modify "test-delete" delete-fn))
+
+ ;; Clean up created files.
+ (dolist (file created-files)
+ (ignore-errors (delete-file file))))))
+
(provide 'arc-mode-tests)
;;; arc-mode-tests.el ends here
diff --git a/test/lisp/auth-source-tests.el b/test/lisp/auth-source-tests.el
index d7c65cc566b..c091a7dd060 100644
--- a/test/lisp/auth-source-tests.el
+++ b/test/lisp/auth-source-tests.el
@@ -33,8 +33,8 @@
(require 'secrets)
(defun auth-source-ensure-ignored-backend (source)
- (auth-source-validate-backend source '((:source . "")
- (:type . ignore))))
+ (auth-source-validate-backend source '((source . "")
+ (type . ignore))))
(defun auth-source-validate-backend (source validation-alist)
(let ((backend (auth-source-backend-parse source)))
@@ -44,84 +44,101 @@
(ert-deftest auth-source-backend-parse-macos-keychain ()
(auth-source-validate-backend '(:source (:macos-keychain-generic foobar))
- '((:source . "foobar")
- (:type . macos-keychain-generic)
- (:search-function . auth-source-macos-keychain-search)
- (:create-function . auth-source-macos-keychain-create))))
+ '((source . "foobar")
+ (type . macos-keychain-generic)
+ (search-function . auth-source-macos-keychain-search)
+ (create-function . auth-source-macos-keychain-create))))
(ert-deftest auth-source-backend-parse-macos-keychain-generic-string ()
(auth-source-validate-backend "macos-keychain-generic:foobar"
- '((:source . "foobar")
- (:type . macos-keychain-generic)
- (:search-function . auth-source-macos-keychain-search)
- (:create-function . auth-source-macos-keychain-create))))
+ '((source . "foobar")
+ (type . macos-keychain-generic)
+ (search-function
+ . auth-source-macos-keychain-search)
+ (create-function
+ . auth-source-macos-keychain-create))))
(ert-deftest auth-source-backend-parse-macos-keychain-internet-string ()
(auth-source-validate-backend "macos-keychain-internet:foobar"
- '((:source . "foobar")
- (:type . macos-keychain-internet)
- (:search-function . auth-source-macos-keychain-search)
- (:create-function . auth-source-macos-keychain-create))))
+ '((source . "foobar")
+ (type . macos-keychain-internet)
+ (search-function
+ . auth-source-macos-keychain-search)
+ (create-function
+ . auth-source-macos-keychain-create))))
(ert-deftest auth-source-backend-parse-macos-keychain-internet-symbol ()
(auth-source-validate-backend 'macos-keychain-internet
- '((:source . "default")
- (:type . macos-keychain-internet)
- (:search-function . auth-source-macos-keychain-search)
- (:create-function . auth-source-macos-keychain-create))))
+ '((source . "default")
+ (type . macos-keychain-internet)
+ (search-function
+ . auth-source-macos-keychain-search)
+ (create-function
+ . auth-source-macos-keychain-create))))
(ert-deftest auth-source-backend-parse-macos-keychain-generic-symbol ()
(auth-source-validate-backend 'macos-keychain-generic
- '((:source . "default")
- (:type . macos-keychain-generic)
- (:search-function . auth-source-macos-keychain-search)
- (:create-function . auth-source-macos-keychain-create))))
+ '((source . "default")
+ (type . macos-keychain-generic)
+ (search-function
+ . auth-source-macos-keychain-search)
+ (create-function
+ . auth-source-macos-keychain-create))))
(ert-deftest auth-source-backend-parse-macos-keychain-internet-default-string ()
(auth-source-validate-backend 'macos-keychain-internet
- '((:source . "default")
- (:type . macos-keychain-internet)
- (:search-function . auth-source-macos-keychain-search)
- (:create-function . auth-source-macos-keychain-create))))
+ '((source . "default")
+ (type . macos-keychain-internet)
+ (search-function
+ . auth-source-macos-keychain-search)
+ (create-function
+ . auth-source-macos-keychain-create))))
(ert-deftest auth-source-backend-parse-plstore ()
(auth-source-validate-backend '(:source "foo.plist")
- '((:source . "foo.plist")
- (:type . plstore)
- (:search-function . auth-source-plstore-search)
- (:create-function . auth-source-plstore-create))))
+ '((source . "foo.plist")
+ (type . plstore)
+ (search-function . auth-source-plstore-search)
+ (create-function
+ . auth-source-plstore-create))))
(ert-deftest auth-source-backend-parse-netrc ()
(auth-source-validate-backend '(:source "foo")
- '((:source . "foo")
- (:type . netrc)
- (:search-function . auth-source-netrc-search)
- (:create-function . auth-source-netrc-create))))
+ '((source . "foo")
+ (type . netrc)
+ (search-function . auth-source-netrc-search)
+ (create-function
+ . auth-source-netrc-create))))
(ert-deftest auth-source-backend-parse-netrc-string ()
(auth-source-validate-backend "foo"
- '((:source . "foo")
- (:type . netrc)
- (:search-function . auth-source-netrc-search)
- (:create-function . auth-source-netrc-create))))
+ '((source . "foo")
+ (type . netrc)
+ (search-function . auth-source-netrc-search)
+ (create-function
+ . auth-source-netrc-create))))
(ert-deftest auth-source-backend-parse-secrets ()
(provide 'secrets) ; simulates the presence of the `secrets' package
(let ((secrets-enabled t))
(auth-source-validate-backend '(:source (:secrets "foo"))
- '((:source . "foo")
- (:type . secrets)
- (:search-function . auth-source-secrets-search)
- (:create-function . auth-source-secrets-create)))))
+ '((source . "foo")
+ (type . secrets)
+ (search-function
+ . auth-source-secrets-search)
+ (create-function
+ . auth-source-secrets-create)))))
(ert-deftest auth-source-backend-parse-secrets-strings ()
(provide 'secrets) ; simulates the presence of the `secrets' package
(let ((secrets-enabled t))
(auth-source-validate-backend "secrets:foo"
- '((:source . "foo")
- (:type . secrets)
- (:search-function . auth-source-secrets-search)
- (:create-function . auth-source-secrets-create)))))
+ '((source . "foo")
+ (type . secrets)
+ (search-function
+ . auth-source-secrets-search)
+ (create-function
+ . auth-source-secrets-create)))))
(ert-deftest auth-source-backend-parse-secrets-alias ()
(provide 'secrets) ; simulates the presence of the `secrets' package
@@ -129,10 +146,12 @@
;; Redefine `secrets-get-alias' to map 'foo to "foo"
(cl-letf (((symbol-function 'secrets-get-alias) (lambda (_) "foo")))
(auth-source-validate-backend '(:source (:secrets foo))
- '((:source . "foo")
- (:type . secrets)
- (:search-function . auth-source-secrets-search)
- (:create-function . auth-source-secrets-create))))))
+ '((source . "foo")
+ (type . secrets)
+ (search-function
+ . auth-source-secrets-search)
+ (create-function
+ . auth-source-secrets-create))))))
(ert-deftest auth-source-backend-parse-secrets-symbol ()
(provide 'secrets) ; simulates the presence of the `secrets' package
@@ -140,10 +159,12 @@
;; Redefine `secrets-get-alias' to map 'default to "foo"
(cl-letf (((symbol-function 'secrets-get-alias) (lambda (_) "foo")))
(auth-source-validate-backend 'default
- '((:source . "foo")
- (:type . secrets)
- (:search-function . auth-source-secrets-search)
- (:create-function . auth-source-secrets-create))))))
+ '((source . "foo")
+ (type . secrets)
+ (search-function
+ . auth-source-secrets-search)
+ (create-function
+ . auth-source-secrets-create))))))
(ert-deftest auth-source-backend-parse-secrets-no-alias ()
(provide 'secrets) ; simulates the presence of the `secrets' package
@@ -152,10 +173,12 @@
;; "Login" is used by default
(cl-letf (((symbol-function 'secrets-get-alias) (lambda (_) nil)))
(auth-source-validate-backend '(:source (:secrets foo))
- '((:source . "Login")
- (:type . secrets)
- (:search-function . auth-source-secrets-search)
- (:create-function . auth-source-secrets-create))))))
+ '((source . "Login")
+ (type . secrets)
+ (search-function
+ . auth-source-secrets-search)
+ (create-function
+ . auth-source-secrets-create))))))
(ert-deftest auth-source-backend-parse-invalid-or-nil-source ()
(provide 'secrets) ; simulates the presence of the `secrets' package
@@ -341,13 +364,14 @@
(should
(string-equal (plist-get auth-info :user) (user-login-name)))
(should (string-equal (plist-get auth-info :host) host))
- (should (string-equal auth-passwd passwd)))))
+ (should (string-equal auth-passwd passwd))))
- ;; Cleanup.
- ;; Should use `auth-source-delete' when implemented for :secrets backend.
- (secrets-delete-item
- "session"
- (format "%s@%s" (plist-get auth-info :user) (plist-get auth-info :host))))))
+ ;; Cleanup.
+ ;; Should use `auth-source-delete' when implemented for :secrets backend.
+ (secrets-delete-item
+ "session"
+ (format
+ "%s@%s" (plist-get auth-info :user) (plist-get auth-info :host)))))))
(ert-deftest auth-source-test-netrc-create-secret ()
(ert-with-temp-file netrc-file
@@ -410,7 +434,7 @@ machine c1 port c2 user c3 password c4\n"
;; this is actually the same as `auth-source-search'.
(should (equal found expected)))))
-(ert-deftest test-netrc-credentials ()
+(ert-deftest auth-source-test-netrc-credentials ()
(let ((data (auth-source-netrc-parse-all (ert-resource-file "authinfo"))))
(should data)
(let ((imap (seq-find (lambda (elem)
@@ -426,7 +450,7 @@ machine c1 port c2 user c3 password c4\n"
(should (equal (cdr (assoc "login" imap)) "jrh"))
(should (equal (cdr (assoc "password" imap)) "*baz*")))))
-(ert-deftest test-netrc-credentials-2 ()
+(ert-deftest auth-source-test-netrc-credentials-2 ()
(let ((data (auth-source-netrc-parse-all
(ert-resource-file "netrc-folding"))))
(should
@@ -434,5 +458,33 @@ machine c1 port c2 user c3 password c4\n"
'((("machine" . "XM") ("login" . "XL") ("password" . "XP"))
(("machine" . "YM") ("login" . "YL") ("password" . "YP")))))))
+(ert-deftest auth-source-test-macos-keychain-search ()
+ "Test if the constructed command line arglist is correct."
+ (let ((auth-sources '(macos-keychain-internet macos-keychain-generic)))
+ ;; Redefine `call-process' to check command line arguments.
+ (cl-letf (((symbol-function 'call-process)
+ (lambda (_program _infile _destination _display
+ &rest args)
+ ;; Arguments must be all strings.
+ (should (cl-every #'stringp args))
+ ;; Argument number should be even.
+ (should (cl-evenp (length args)))
+ (should
+ (cond
+ ((string= (car args) "find-internet-password")
+ (let ((protocol-r (cl-member "-r" args :test #'string=))
+ (protocol-P (cl-member "-P" args :test #'string=)))
+ (cond (protocol-r
+ (= 4 (length (cadr protocol-r))))
+ (protocol-P
+ (string-match-p
+ "\\`[[:digit:]]+\\'" (cadr protocol-P)))
+ (t))))
+ ((string= (car args) "find-generic-password")
+ t))))))
+ (auth-source-search
+ :user '("a" "b") :host '("example.org")
+ :port '("irc" "ftp" "https" 123)))))
+
(provide 'auth-source-tests)
;;; auth-source-tests.el ends here
diff --git a/test/lisp/autorevert-tests.el b/test/lisp/autorevert-tests.el
index ef6e9563536..c202970e0b2 100644
--- a/test/lisp/autorevert-tests.el
+++ b/test/lisp/autorevert-tests.el
@@ -257,7 +257,7 @@ This expects `auto-revert--messages' to be bound by
;; Repeated unpredictable failures, bug#32645.
:tags '(:unstable)
;; Unlikely to be hydra-specific?
- ;; (skip-unless (not (getenv "EMACS_HYDRA_CI")))
+ ;; (skip-when (getenv "EMACS_HYDRA_CI"))
(with-auto-revert-test
(ert-with-temp-file tmpfile
(let (;; Try to catch bug#32645.
diff --git a/test/lisp/calc/calc-tests.el b/test/lisp/calc/calc-tests.el
index 7e192709c06..b64c1682efe 100644
--- a/test/lisp/calc/calc-tests.el
+++ b/test/lisp/calc/calc-tests.el
@@ -698,8 +698,8 @@ An existing calc stack is reused, otherwise a new one is created."
(calc-tests--not x w)))
(dolist (n '(0 1 4 16 32 -1 -4 -16 -32))
- (equal (calcFunc-clip x n)
- (calc-tests--clip x n)))
+ (should (equal (calcFunc-clip x n)
+ (calc-tests--clip x n))))
(dolist (y '(0 1 #x1234 #x8000 #xabcd #xffff
#x12345678 #xabcdef12 #x80000000 #xffffffff
@@ -734,6 +734,31 @@ An existing calc stack is reused, otherwise a new one is created."
(var c var-c))))))
(calc-set-language nil)))
+(ert-deftest calc-frac-input ()
+ ;; precomposed fraction
+ (should (equal (math-read-expr "½")
+ '(frac 1 2)))
+ ;; ascii solidus
+ (should (equal (math-read-expr "123/456")
+ '(/ 123 456)))
+ (should (equal (math-read-expr "a/b")
+ '(/ (var a var-a) (var b var-b))))
+ ;; fraction slash
+ (should (equal (math-read-expr "123⁄456")
+ '(frac 41 152)))
+ (should (equal (math-read-expr "a⁄b")
+ '(error 1 "Syntax error")))
+ ;; division slash
+ (should (equal (math-read-expr "123∕456")
+ '(/ 123 456)))
+ (should (equal (math-read-expr "a∕b")
+ '(/ (var a var-a) (var b var-b))))
+ ;; division sign
+ (should (equal (math-read-expr "123÷456")
+ '(frac 41 152)))
+ (should (equal (math-read-expr "a÷b") ; I think this one is wrong
+ '(error 1 "Syntax error"))))
+
(defvar var-g)
;; Test `let'.
@@ -816,5 +841,43 @@ An existing calc stack is reused, otherwise a new one is created."
(x (calc-tests--calc-to-number (math-pow 8 '(frac 1 6)))))
(should (< (abs (- x (sqrt 2.0))) 1.0e-10))))
+(require 'calc-aent)
+
+(ert-deftest calc-math-read-preprocess-string ()
+ "Test replacement of allowed special Unicode symbols."
+ ;; ... doesn't change an empty string
+ (should (string= "" (math-read-preprocess-string "")))
+ ;; ... doesn't change a string without characters from
+ ;; ‘math-read-replacement-list’
+ (let ((str "don't replace here"))
+ (should (string= str (math-read-preprocess-string str))))
+ ;; ... replaces irrespective of position in input string
+ (should (string= "^(1)" (math-read-preprocess-string "¹")))
+ (should (string= "some^(1)" (math-read-preprocess-string "some¹")))
+ (should (string= "^(1)time" (math-read-preprocess-string "¹time")))
+ (should (string= "some^(1)else" (math-read-preprocess-string "some¹else")))
+ ;; ... replaces every element of ‘math-read-replacement-list’ correctly,
+ ;; in particular combining consecutive super-/subscripts into one
+ ;; exponent/subscript
+ (should (string= (concat "+/-*:-/*inf<=>=<=>=μ(1:4)(1:2)(3:4)(1:3)(2:3)"
+ "(1:5)(2:5)(3:5)(4:5)(1:6)(5:6)"
+ "(1:8)(3:8)(5:8)(7:8)1::^(0123456789+-()ni)"
+ "_(0123456789+-())")
+ (math-read-preprocess-string
+ (mapconcat #'car math-read-replacement-list))))
+ ;; ... replaces strings of more than a single character correctly
+ (let ((math-read-replacement-list (append
+ math-read-replacement-list
+ '(("𝚤𝚥" "ij"))
+ '(("¼½" "(1:4)(1:2)")))))
+ (should (string= "(1:4)(1:2)ij"
+ (math-read-preprocess-string "¼½𝚤𝚥"))))
+ ;; ... handles an empty replacement list gracefully
+ (let ((math-read-replacement-list '()))
+ (should (string= "¼" (math-read-preprocess-string "¼"))))
+ ;; ... signals an error if the argument is not a string
+ (should-error (math-read-preprocess-string nil))
+ (should-error (math-read-preprocess-string 42)))
+
(provide 'calc-tests)
;;; calc-tests.el ends here
diff --git a/test/lisp/calculator-tests.el b/test/lisp/calculator-tests.el
index 00e8fe046a6..5b485fe6dc5 100644
--- a/test/lisp/calculator-tests.el
+++ b/test/lisp/calculator-tests.el
@@ -47,5 +47,11 @@
(let ((calculator-input-radix nil))
(should (equal (calculator-string-to-number str) expected)))))))
+(ert-deftest calculator-expt ()
+ (should (= (calculator-expt 2 -1) 0.5))
+ (should (= (calculator-expt -2 2) 4))
+ (should (= (calculator-expt -2 3) -8))
+ (should (= (calculator-expt 2 64) 18446744073709551616)))
+
(provide 'calculator-tests)
;;; calculator-tests.el ends here
diff --git a/test/lisp/calendar/icalendar-tests.el b/test/lisp/calendar/icalendar-tests.el
index 7d3af25ea49..39ad735a789 100644
--- a/test/lisp/calendar/icalendar-tests.el
+++ b/test/lisp/calendar/icalendar-tests.el
@@ -68,7 +68,7 @@
(with-temp-buffer
(insert diary-string)
(icalendar-export-region (point-min) (point-max) file))
- (with-current-buffer (get-buffer "*icalendar-errors*")
+ (with-current-buffer "*icalendar-errors*"
(buffer-string))))
;; ======================================================================
diff --git a/test/lisp/calendar/lunar-tests.el b/test/lisp/calendar/lunar-tests.el
index cc6bd6eec24..d9f6f6ca56a 100644
--- a/test/lisp/calendar/lunar-tests.el
+++ b/test/lisp/calendar/lunar-tests.el
@@ -41,10 +41,10 @@
(should (equal (lunar-phase 1)
'((1 8 1900) "05:40" 1 "")))))
-(ert-deftest lunar-test-eclipse-check ()
+(ert-deftest lunar-test-check-for-eclipse ()
(with-lunar-test
- (should (equal (eclipse-check 10.0 1) ""))
- (should (equal (eclipse-check 10.0 2) "** Lunar Eclipse **"))))
+ (should (equal (lunar-check-for-eclipse 10.0 1) ""))
+ (should (equal (lunar-check-for-eclipse 10.0 2) "** Lunar Eclipse **"))))
(ert-deftest lunar-test-phase-list ()
(with-lunar-test
diff --git a/test/lisp/calendar/todo-mode-tests.el b/test/lisp/calendar/todo-mode-tests.el
index 96c8397e66b..8c76792ec41 100644
--- a/test/lisp/calendar/todo-mode-tests.el
+++ b/test/lisp/calendar/todo-mode-tests.el
@@ -934,5 +934,70 @@ since all non-initial item lines must begin with whitespace."
(insert (concat "\n" item1))
(should-error (todo-edit-quit) :type 'user-error))))
+(ert-deftest todo-test-item-insertion-with-priority-1 ()
+ "Test inserting new item when point is not on a todo item.
+When point is on the empty line at the end of the todo items
+section, insertion with priority setting should succeed."
+ (with-todo-test
+ (todo-test--show 1)
+ (goto-char (point-max))
+ ;; Now point should not be on a todo item.
+ (should-not (todo-item-start))
+ (let ((item "Point was on empty line at end of todo items section."))
+ (todo-test--insert-item item 1)
+ ;; Move point to item that was just inserted.
+ (goto-char (point-min))
+ (re-search-forward (concat todo-date-string-start todo-date-pattern
+ (regexp-quote todo-nondiary-end) " ")
+ (pos-eol) t)
+ (should (looking-at (regexp-quote item))))))
+
+(ert-deftest todo-test-item-insertion-with-priority-2 ()
+ "Test inserting new item when point is not on a todo item.
+When point is on the empty line at the end of the done items
+section, insertion with priority setting should succeed."
+ (with-todo-test
+ (todo-test--show 1)
+ (goto-char (point-max))
+ ;; See comment about recentering in todo-test-raise-lower-priority.
+ (set-window-buffer nil (current-buffer))
+ (todo-toggle-view-done-items)
+ (todo-next-item)
+ (goto-char (point-max))
+ ;; Now point should be at end of done items section, so not be on a
+ ;; todo item.
+ (should (todo-done-item-section-p))
+ (should-not (todo-item-start))
+ (let ((item "Point was on empty line at end of done items section."))
+ (todo-test--insert-item item 1)
+ ;; Move point to item that was just inserted.
+ (goto-char (point-min))
+ (re-search-forward (concat todo-date-string-start todo-date-pattern
+ (regexp-quote todo-nondiary-end) " ")
+ (pos-eol) t)
+ (should (looking-at (regexp-quote item))))))
+
+(ert-deftest todo-test-item-insertion-with-priority-3 ()
+ "Test inserting new item when point is not on a todo item.
+When point is on a done item, insertion with priority setting
+should succeed."
+ (with-todo-test
+ (todo-test--show 1)
+ (goto-char (point-max))
+ ;; See comment about recentering in todo-test-raise-lower-priority.
+ (set-window-buffer nil (current-buffer))
+ (todo-toggle-view-done-items)
+ (todo-next-item)
+ ;; Now point should be on first done item.
+ (should (and (todo-item-start) (todo-done-item-section-p)))
+ (let ((item "Point was on a done item."))
+ (todo-test--insert-item item 1)
+ ;; Move point to item that was just inserted.
+ (goto-char (point-min))
+ (re-search-forward (concat todo-date-string-start todo-date-pattern
+ (regexp-quote todo-nondiary-end) " ")
+ (pos-eol) t)
+ (should (looking-at (regexp-quote item))))))
+
(provide 'todo-mode-tests)
;;; todo-mode-tests.el ends here
diff --git a/test/lisp/cedet/semantic/bovine/gcc-tests.el b/test/lisp/cedet/semantic/bovine/gcc-tests.el
index 299c6b9fb4a..bfdf2a22286 100644
--- a/test/lisp/cedet/semantic/bovine/gcc-tests.el
+++ b/test/lisp/cedet/semantic/bovine/gcc-tests.el
@@ -31,62 +31,88 @@
;;; From bovine-gcc:
-;; Example output of "gcc -v"
-(defvar semantic-gcc-test-strings
- '(;; My old box:
- "Reading specs from /usr/lib/gcc-lib/i386-redhat-linux/3.2.2/specs
+(defmacro semantic-gcc-test (str)
+ `(let ((fields (semantic-gcc-fields ,str)))
+ (let-alist fields
+ (message "%S" fields)
+ ;; No longer test for prefixes.
+ ;; (should .--prefix)
+ (should .version)
+ (should (or .target
+ .--target
+ .--host)))))
+
+;; A bunch of sample gcc -v outputs from different machines.
+
+(ert-deftest semantic-gcc-test/1 ()
+ ;; My old box:
+ (semantic-gcc-test "Reading specs from /usr/lib/gcc-lib/i386-redhat-linux/3.2.2/specs
Configured with: ../configure --prefix=/usr --mandir=/usr/share/man --infodir=/usr/share/info --enable-shared --enable-threads=posix --disable-checking --with-system-zlib --enable-__cxa_atexit --host=i386-redhat-linux
Thread model: posix
-gcc version 3.2.2 20030222 (Red Hat Linux 3.2.2-5)"
- ;; Alex Ott:
- "Using built-in specs.
+gcc version 3.2.2 20030222 (Red Hat Linux 3.2.2-5)"))
+
+(ert-deftest semantic-gcc-test/2 ()
+ ;; Alex Ott:
+ (semantic-gcc-test "Using built-in specs.
Target: i486-linux-gnu
Configured with: ../src/configure -v --with-pkgversion='Ubuntu 4.3.1-9ubuntu1' --with-bugurl=file:///usr/share/doc/gcc-4.3/README.Bugs --enable-languages=c,c++,fortran,objc,obj-c++ --prefix=/usr --enable-shared --with-system-zlib --libexecdir=/usr/lib --without-included-gettext --enable-threads=posix --enable-nls --with-gxx-include-dir=/usr/include/c++/4.3 --program-suffix=-4.3 --enable-clocale=gnu --enable-libstdcxx-debug --enable-objc-gc --enable-mpfr --enable-targets=all --enable-checking=release --build=i486-linux-gnu --host=i486-linux-gnu --target=i486-linux-gnu
Thread model: posix
-gcc version 4.3.1 (Ubuntu 4.3.1-9ubuntu1)"
- ;; My debian box:
- "Using built-in specs.
+gcc version 4.3.1 (Ubuntu 4.3.1-9ubuntu1)"))
+
+(ert-deftest semantic-gcc-test/3 ()
+ ;; My Debian box:
+ (semantic-gcc-test "Using built-in specs.
Target: x86_64-unknown-linux-gnu
Configured with: ../../../sources/gcc/configure --prefix=/usr/local/glibc-2.3.6/x86_64/apps/gcc-4.2.3 --with-gmp=/usr/local/gcc/gmp --with-mpfr=/usr/local/gcc/mpfr --enable-languages=c,c++,fortran --with-as=/usr/local/glibc-2.3.6/x86_64/apps/gcc-4.2.3/bin/as --with-ld=/usr/local/glibc-2.3.6/x86_64/apps/gcc-4.2.3/bin/ld --disable-multilib
Thread model: posix
-gcc version 4.2.3"
- ;; My mac:
- "Using built-in specs.
+gcc version 4.2.3"))
+
+(ert-deftest semantic-gcc-test/4 ()
+ ;; My mac:
+ (semantic-gcc-test "Using built-in specs.
Target: i686-apple-darwin8
Configured with: /private/var/tmp/gcc/gcc-5341.obj~1/src/configure --disable-checking -enable-werror --prefix=/usr --mandir=/share/man --enable-languages=c,objc,c++,obj-c++ --program-transform-name=/^[cg][^.-]*$/s/$/-4.0/ --with-gxx-include-dir=/include/c++/4.0.0 --with-slibdir=/usr/lib --build=powerpc-apple-darwin8 --with-arch=pentium-m --with-tune=prescott --program-prefix= --host=i686-apple-darwin8 --target=i686-apple-darwin8
Thread model: posix
-gcc version 4.0.1 (Apple Computer, Inc. build 5341)"
- ;; Ubuntu Intrepid
- "Using built-in specs.
+gcc version 4.0.1 (Apple Computer, Inc. build 5341)"))
+
+(ert-deftest semantic-gcc-test/5 ()
+ ;; Ubuntu Intrepid
+ (semantic-gcc-test "Using built-in specs.
Target: x86_64-linux-gnu
Configured with: ../src/configure -v --with-pkgversion='Ubuntu 4.3.2-1ubuntu12' --with-bugurl=file:///usr/share/doc/gcc-4.3/README.Bugs --enable-languages=c,c++,fortran,objc,obj-c++ --prefix=/usr --enable-shared --with-system-zlib --libexecdir=/usr/lib --without-included-gettext --enable-threads=posix --enable-nls --with-gxx-include-dir=/usr/include/c++/4.3 --program-suffix=-4.3 --enable-clocale=gnu --enable-libstdcxx-debug --enable-objc-gc --enable-mpfr --enable-checking=release --build=x86_64-linux-gnu --host=x86_64-linux-gnu --target=x86_64-linux-gnu
Thread model: posix
-gcc version 4.3.2 (Ubuntu 4.3.2-1ubuntu12)"
- ;; Red Hat EL4
- "Reading specs from /usr/lib/gcc/x86_64-redhat-linux/3.4.6/specs
+gcc version 4.3.2 (Ubuntu 4.3.2-1ubuntu12)"))
+
+(ert-deftest semantic-gcc-test/6 ()
+ ;; Red Hat EL4
+ (semantic-gcc-test "Reading specs from /usr/lib/gcc/x86_64-redhat-linux/3.4.6/specs
Configured with: ../configure --prefix=/usr --mandir=/usr/share/man --infodir=/usr/share/info --enable-shared --enable-threads=posix --disable-checking --with-system-zlib --enable-__cxa_atexit --disable-libunwind-exceptions --enable-java-awt=gtk --host=x86_64-redhat-linux
Thread model: posix
-gcc version 3.4.6 20060404 (Red Hat 3.4.6-10)"
- ;; Red Hat EL5
- "Using built-in specs.
+gcc version 3.4.6 20060404 (Red Hat 3.4.6-10)"))
+
+(ert-deftest semantic-gcc-test/7 ()
+ ;; Red Hat EL5
+ (semantic-gcc-test "Using built-in specs.
Target: x86_64-redhat-linux
Configured with: ../configure --prefix=/usr --mandir=/usr/share/man --infodir=/usr/share/info --enable-shared --enable-threads=posix --enable-checking=release --with-system-zlib --enable-__cxa_atexit --disable-libunwind-exceptions --enable-libgcj-multifile --enable-languages=c,c++,objc,obj-c++,java,fortran,ada --enable-java-awt=gtk --disable-dssi --enable-plugin --with-java-home=/usr/lib/jvm/java-1.4.2-gcj-1.4.2.0/jre --with-cpu=generic --host=x86_64-redhat-linux
Thread model: posix
-gcc version 4.1.2 20080704 (Red Hat 4.1.2-44)"
- ;; David Engster's german gcc on ubuntu 4.3
- "Es werden eingebaute Spezifikationen verwendet.
+gcc version 4.1.2 20080704 (Red Hat 4.1.2-44)"))
+
+(ert-deftest semantic-gcc-test/8 ()
+ ;; David Engster's german gcc on ubuntu 4.3
+ (semantic-gcc-test "Es werden eingebaute Spezifikationen verwendet.
Ziel: i486-linux-gnu
Konfiguriert mit: ../src/configure -v --with-pkgversion='Ubuntu 4.3.2-1ubuntu12' --with-bugurl=file:///usr/share/doc/gcc-4.3/README.Bugs --enable-languages=c,c++,fortran,objc,obj-c++ --prefix=/usr --enable-shared --with-system-zlib --libexecdir=/usr/lib --without-included-gettext --enable-threads=posix --enable-nls --with-gxx-include-dir=/usr/include/c++/4.3 --program-suffix=-4.3 --enable-clocale=gnu --enable-libstdcxx-debug --enable-objc-gc --enable-mpfr --enable-targets=all --enable-checking=release --build=i486-linux-gnu --host=i486-linux-gnu --target=i486-linux-gnu
Thread-Modell: posix
-gcc-Version 4.3.2 (Ubuntu 4.3.2-1ubuntu12)"
- ;; Damien Deville bsd
- "Using built-in specs.
+gcc-Version 4.3.2 (Ubuntu 4.3.2-1ubuntu12)"))
+
+(ert-deftest semantic-gcc-test/9 ()
+ ;; Damien Deville bsd
+ (semantic-gcc-test "Using built-in specs.
Target: i386-undermydesk-freebsd
Configured with: FreeBSD/i386 system compiler
Thread model: posix
-gcc version 4.2.1 20070719 [FreeBSD]"
- )
- "A bunch of sample gcc -v outputs from different machines.")
+gcc version 4.2.1 20070719 [FreeBSD]"))
(defvar semantic-gcc-test-strings-fail
'(;; A really old solaris box I found
@@ -95,19 +121,8 @@ gcc version 2.95.2 19991024 (release)"
)
"A bunch of sample gcc -v outputs that fail to provide the info we want.")
-(defun semantic-gcc-test-output-parser ()
+(ert-deftest semantic-gcc-test-output-parser/fail ()
"Test the output parser against some collected strings."
- (dolist (S semantic-gcc-test-strings)
- (let* ((fields (semantic-gcc-fields S))
- (v (cdr (assoc 'version fields)))
- (h (or (cdr (assoc 'target fields))
- (cdr (assoc '--target fields))
- (cdr (assoc '--host fields))))
- (p (cdr (assoc '--prefix fields))))
- ;; No longer test for prefixes.
- (when (not (and v h))
- (let ((strs (split-string S "\n")))
- (error "Test failed on %S\nV H P:\n%S %S %S" (car strs) v h p)))))
(dolist (S semantic-gcc-test-strings-fail)
(let* ((fields (semantic-gcc-fields S))
(v (cdr (assoc 'version fields)))
@@ -118,14 +133,10 @@ gcc version 2.95.2 19991024 (release)"
(when (and v h p)
(error "Negative test failed on %S" S)))))
-(ert-deftest semantic-gcc-test-output-parser ()
- (semantic-gcc-test-output-parser))
-
-(ert-deftest semantic-gcc-test-output-parser-this-machine ()
+(ert-deftest semantic-gcc-test-output-parser/this-machine ()
"Test the output parser against the machine currently running Emacs."
(skip-unless (and (executable-find "gcc")
(not (ert-gcc-is-clang-p))))
- (let ((semantic-gcc-test-strings (list (semantic-gcc-query "gcc" "-v"))))
- (semantic-gcc-test-output-parser)))
+ (semantic-gcc-test (semantic-gcc-query "gcc" "-v")))
;;; gcc-tests.el ends here
diff --git a/test/lisp/completion-preview-tests.el b/test/lisp/completion-preview-tests.el
new file mode 100644
index 00000000000..5b2c28bd3dd
--- /dev/null
+++ b/test/lisp/completion-preview-tests.el
@@ -0,0 +1,199 @@
+;;; completion-preview-tests.el --- tests for completion-preview.el -*- lexical-binding: t -*-
+
+;; Copyright (C) 2023-2024 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 <https://www.gnu.org/licenses/>.
+
+;;; Code:
+
+(require 'ert)
+(require 'completion-preview)
+
+(defun completion-preview-tests--capf (completions &rest props)
+ (lambda ()
+ (when-let ((bounds (bounds-of-thing-at-point 'symbol)))
+ (append (list (car bounds) (cdr bounds) completions) props))))
+
+(defun completion-preview-tests--check-preview (string &optional exact)
+ "Check that the completion preview is showing STRING.
+
+If EXACT is non-nil, check that STRING has the
+`completion-preview-exact' face. Otherwise check that STRING has
+the `completion-preview' face.
+
+If STRING is nil, check that there is no completion preview
+instead."
+ (if (not string)
+ (should (not completion-preview--overlay))
+ (should completion-preview--overlay)
+ (let ((after-string (completion-preview--get 'after-string)))
+ (should (string= after-string string))
+ (should (eq (get-text-property 0 'face after-string)
+ (if exact
+ 'completion-preview-exact
+ 'completion-preview))))))
+
+(ert-deftest completion-preview ()
+ "Test Completion Preview mode."
+ (with-temp-buffer
+ (setq-local completion-at-point-functions
+ (list (completion-preview-tests--capf '("foobarbaz"))))
+
+ (insert "foo")
+ (let ((this-command 'self-insert-command))
+ (completion-preview--post-command))
+
+ ;; Exact match
+ (completion-preview-tests--check-preview "barbaz" 'exact)
+
+ (insert "v")
+ (let ((this-command 'self-insert-command))
+ (completion-preview--post-command))
+
+ ;; No match, no preview
+ (completion-preview-tests--check-preview nil)
+
+ (delete-char -1)
+ (let ((this-command 'delete-backward-char))
+ (completion-preview--post-command))
+
+ ;; Exact match again
+ (completion-preview-tests--check-preview "barbaz" 'exact)))
+
+(ert-deftest completion-preview-multiple-matches ()
+ "Test Completion Preview mode with multiple matching candidates."
+ (with-temp-buffer
+ (setq-local completion-at-point-functions
+ (list (completion-preview-tests--capf
+ '("foobar" "foobaz"))))
+ (insert "foo")
+ (let ((this-command 'self-insert-command))
+ (completion-preview--post-command))
+
+ ;; Multiple matches, the preview shows the first one
+ (completion-preview-tests--check-preview "bar")
+
+ (completion-preview-next-candidate 1)
+
+ ;; Next match
+ (completion-preview-tests--check-preview "baz")))
+
+(ert-deftest completion-preview-exact-match-only ()
+ "Test `completion-preview-exact-match-only'."
+ (with-temp-buffer
+ (setq-local completion-at-point-functions
+ (list (completion-preview-tests--capf
+ '("spam" "foobar" "foobaz")))
+ completion-preview-exact-match-only t)
+ (insert "foo")
+ (let ((this-command 'self-insert-command))
+ (completion-preview--post-command))
+
+ ;; Multiple matches, so no preview
+ (completion-preview-tests--check-preview nil)
+
+ (delete-region (point-min) (point-max))
+ (insert "spa")
+ (let ((this-command 'self-insert-command))
+ (completion-preview--post-command))
+
+ ;; Exact match
+ (completion-preview-tests--check-preview "m" 'exact)))
+
+(ert-deftest completion-preview-function-capfs ()
+ "Test Completion Preview mode with capfs that return a function."
+ (with-temp-buffer
+ (setq-local completion-at-point-functions
+ (list
+ (lambda () #'ignore)
+ (completion-preview-tests--capf
+ '("foobar" "foobaz"))))
+ (insert "foo")
+ (let ((this-command 'self-insert-command))
+ (completion-preview--post-command))
+ (completion-preview-tests--check-preview "bar")))
+
+(ert-deftest completion-preview-non-exclusive-capfs ()
+ "Test Completion Preview mode with non-exclusive capfs."
+ (with-temp-buffer
+ (setq-local completion-at-point-functions
+ (list
+ (completion-preview-tests--capf
+ '("spam") :exclusive 'no)
+ (completion-preview-tests--capf
+ '("foobar" "foobaz") :exclusive 'no)
+ (completion-preview-tests--capf
+ '("foobarbaz"))))
+ (insert "foo")
+ (let ((this-command 'self-insert-command))
+ (completion-preview--post-command))
+ (completion-preview-tests--check-preview "bar")
+ (setq-local completion-preview-exact-match-only t)
+ (let ((this-command 'self-insert-command))
+ (completion-preview--post-command))
+ (completion-preview-tests--check-preview "barbaz" 'exact)))
+
+(ert-deftest completion-preview-face-updates ()
+ "Test updating the face in completion preview when match is no longer exact."
+ (with-temp-buffer
+ (setq-local completion-at-point-functions
+ (list
+ (completion-preview-tests--capf
+ '("foobarbaz" "food"))))
+ (insert "foo")
+ (let ((this-command 'self-insert-command))
+ (completion-preview--post-command))
+ (completion-preview-tests--check-preview "d")
+ (insert "b")
+ (let ((this-command 'self-insert-command))
+ (completion-preview--post-command))
+ (completion-preview-tests--check-preview "arbaz" 'exact)
+ (delete-char -1)
+ (let ((this-command 'delete-backward-char))
+ (completion-preview--post-command))
+ (completion-preview-tests--check-preview "d")))
+
+(ert-deftest completion-preview-capf-errors ()
+ "Test Completion Preview mode with capfs that signal errors.
+
+`dabbrev-capf' is one example of such a capf."
+ (with-temp-buffer
+ (setq-local completion-at-point-functions
+ (list
+ (lambda () (user-error "bad"))
+ (completion-preview-tests--capf
+ '("foobarbaz"))))
+ (insert "foo")
+ (let ((this-command 'self-insert-command))
+ (completion-preview--post-command))
+ (completion-preview-tests--check-preview "barbaz" 'exact)))
+
+(ert-deftest completion-preview-mid-symbol-cycle ()
+ "Test cycling the completion preview with point at the middle of a symbol."
+ (with-temp-buffer
+ (setq-local completion-at-point-functions
+ (list
+ (completion-preview-tests--capf
+ '("foobar" "foobaz"))))
+ (insert "fooba")
+ (forward-char -2)
+ (let ((this-command 'self-insert-command))
+ (completion-preview--post-command))
+ (completion-preview-tests--check-preview "r")
+ (completion-preview-next-candidate 1)
+ (completion-preview-tests--check-preview "z")))
+
+;;; completion-preview-tests.el ends here
diff --git a/test/lisp/cus-edit-tests.el b/test/lisp/cus-edit-tests.el
index fee695a90b3..535711e02cf 100644
--- a/test/lisp/cus-edit-tests.el
+++ b/test/lisp/cus-edit-tests.el
@@ -92,5 +92,47 @@
(buffer-substring-no-properties (point-min) (point-max)))))
(should (string-search "Value `:foo' does not match type number"
warn-txt))))
+
+(defcustom cus-edit-test-bug63290-option nil
+ "Choice option for testing Bug#63290."
+ :type '(choice (alist
+ :key-type (string :tag "key")
+ :value-type (string :tag "value"))
+ (const :tag "auto" auto)))
+
+(defcustom cus-edit-test-bug63290-option2 'some
+ "Choice option for testing Bug#63290."
+ :type '(choice
+ (const :tag "some" some)
+ (alist
+ :key-type (string :tag "key")
+ :value-type (string :tag "value"))))
+
+(ert-deftest cus-edit-test-bug63290 ()
+ "Test that changing a choice value back to an alist respects its nil value."
+ (customize-variable 'cus-edit-test-bug63290-option)
+ (search-forward "Value")
+ ;; Simulate changing the value.
+ (let* ((choice (widget-at))
+ (args (widget-get choice :args))
+ (list-opt (car (widget-get choice :children)))
+ (const-opt (nth 1 args)))
+ (widget-put choice :explicit-choice const-opt)
+ (widget-value-set choice (widget-default-get const-opt))
+ (widget-put choice :explicit-choice list-opt)
+ (widget-value-set choice (widget-default-get list-opt)))
+ ;; No empty key/value pairs should show up.
+ (should-not (search-forward "key" nil t))
+ (customize-variable 'cus-edit-test-bug63290-option2)
+ (search-forward "Value")
+ ;; Simulate changing the value.
+ (let* ((choice (widget-at))
+ (args (widget-get choice :args))
+ (list-opt (nth 1 args)))
+ (widget-put choice :explicit-choice list-opt)
+ (widget-value-set choice (widget-default-get list-opt)))
+ ;; No empty key/value pairs should show up.
+ (should-not (search-forward "key" nil t)))
+
(provide 'cus-edit-tests)
;;; cus-edit-tests.el ends here
diff --git a/test/lisp/dired-aux-tests.el b/test/lisp/dired-aux-tests.el
index 08a5a9a3d4b..f1542cb5e83 100644
--- a/test/lisp/dired-aux-tests.el
+++ b/test/lisp/dired-aux-tests.el
@@ -55,12 +55,11 @@
(setq to-mv
(expand-file-name
"foo-mv" (file-name-as-directory (expand-file-name "qux" ,foo))))
- (unwind-protect
- (if ,yes-or-no
- (cl-letf (((symbol-function 'yes-or-no-p)
- (lambda (_prompt) (eq ,yes-or-no 'yes))))
- ,@body)
- ,@body)))))))
+ (if ,yes-or-no
+ (cl-letf (((symbol-function 'yes-or-no-p)
+ (lambda (_prompt) (eq ,yes-or-no 'yes))))
+ ,@body)
+ ,@body))))))
(ert-deftest dired-test-bug28834 ()
"test for https://debbugs.gnu.org/28834 ."
diff --git a/test/lisp/dired-tests.el b/test/lisp/dired-tests.el
index 2589281e5e1..651b77500a1 100644
--- a/test/lisp/dired-tests.el
+++ b/test/lisp/dired-tests.el
@@ -241,12 +241,12 @@
(let ((buffers (find-file (concat (file-name-as-directory test-dir)
"*")
t)))
+ (setq allbufs (append buffers allbufs))
(dolist (buf buffers)
(let ((pt (with-current-buffer buf (point))))
(switch-to-buffer (find-file-noselect test-dir))
(find-file (buffer-name buf))
- (should (equal (point) pt))))
- (append buffers allbufs)))
+ (should (equal (point) pt))))))
(dolist (buf allbufs)
(when (buffer-live-p buf) (kill-buffer buf)))))))
@@ -270,8 +270,8 @@
"Test for https://debbugs.gnu.org/27631 ."
;; For dired using 'ls' emulation we test for this bug in
;; ls-lisp-tests.el and em-ls-tests.el.
- (skip-unless (and (not (featurep 'ls-lisp))
- (not (featurep 'eshell))))
+ (skip-unless (not (or (featurep 'ls-lisp)
+ (featurep 'eshell))))
(ert-with-temp-directory dir
(let* ((dir1 (expand-file-name "dir1" dir))
(dir2 (expand-file-name "dir2" dir))
@@ -477,9 +477,9 @@
;;(should (= 0 (length (directory-files testdir nil "[0-9]" t -1))))
(should (= 5 (length (directory-files testdir nil "[0-9]" t))))
(should (= 5 (length (directory-files testdir nil "[0-9]" t 50))))
- (should-not (directory-empty-p testdir)))
+ (should-not (directory-empty-p testdir))))
- (delete-directory testdir t)))))
+ (delete-directory testdir t))))
(ert-deftest dired-test-directory-files-and-attributes ()
"Test for `directory-files-and-attributes'."
diff --git a/test/lisp/dnd-tests.el b/test/lisp/dnd-tests.el
index 3e727a2e835..3d4f28b9ae1 100644
--- a/test/lisp/dnd-tests.el
+++ b/test/lisp/dnd-tests.el
@@ -33,6 +33,7 @@
(require 'tramp)
(require 'select)
(require 'ert-x)
+(require 'browse-url)
(defvar dnd-tests-selection-table nil
"Alist of selection names to their values.")
@@ -172,7 +173,7 @@ This function only tries to handle strings."
(extracted-1 (dnd-tests-extract-selection-data string-data-1 t))
(extracted (dnd-tests-extract-selection-data string-data t)))
(should (and (stringp extracted) (stringp extracted-1)))
- (should (equal extracted extracted)))
+ (should (equal extracted extracted-1)))
;; Now check text/plain.
(let ((string-data (dnd-tests-verify-selection-data
'text/plain)))
@@ -437,5 +438,162 @@ This function only tries to handle strings."
(ignore-errors
(delete-file normal-temp-file)))))
+
+
+(defvar dnd-tests-list-1 '("file:///usr/openwin/include/pixrect/pr_impl.h"
+ "file:///usr/openwin/include/pixrect/pr_io.h")
+ "Sample data for tests concerning the treatment of drag-and-drop URLs.")
+
+(defvar dnd-tests-list-2 '("file:///usr/openwin/include/pixrect/pr_impl.h"
+ "file://remote/usr/openwin/include/pixrect/pr_io.h")
+ "Sample data for tests concerning the treatment of drag-and-drop URLs.")
+
+(defvar dnd-tests-list-3 (append dnd-tests-list-2 '("http://example.com"))
+ "Sample data for tests concerning the treatment of drag-and-drop URLs.")
+
+(defvar dnd-tests-list-4 (append dnd-tests-list-3 '("scheme1://foo.bar"
+ "scheme2://foo.bar"))
+ "Sample data for tests concerning the treatment of drag-and-drop URLs.")
+
+(defun dnd-tests-local-file-function (urls _action)
+ "Signal an error if URLS doesn't match `dnd-tests-list-1'.
+ACTION is ignored. Return the symbol `copy' otherwise."
+ (should (equal urls dnd-tests-list-1))
+ 'copy)
+
+(put 'dnd-tests-local-file-function 'dnd-multiple-handler t)
+
+(defun dnd-tests-remote-file-function (urls _action)
+ "Signal an error if URLS doesn't match `dnd-tests-list-2'.
+ACTION is ignored. Return the symbol `copy' otherwise."
+ (should (equal urls dnd-tests-list-2))
+ 'copy)
+
+(put 'dnd-tests-remote-file-function 'dnd-multiple-handler t)
+
+(defun dnd-tests-http-scheme-function (url _action)
+ "Signal an error if URLS doesn't match `dnd-tests-list-3''s third element.
+ACTION is ignored. Return the symbol `private' otherwise."
+ (should (equal url (car (last dnd-tests-list-3))))
+ 'private)
+
+(defun dnd-tests-browse-url-handler (url &rest _ignored)
+ "Verify URL is `dnd-tests-list-4''s fourth element."
+ (should (equal url (nth 3 dnd-tests-list-4))))
+
+(put 'dnd-tests-browse-url-handler 'browse-url-browser-kind 'internal)
+
+(ert-deftest dnd-tests-receive-multiple-urls ()
+ (let ((dnd-protocol-alist '(("^file:///" . dnd-tests-local-file-function)
+ ("^file:" . error)
+ ("^unrelated-scheme:" . error)))
+ (browse-url-handlers nil))
+ ;; Check that the order of the alist is respected when the
+ ;; precedences of two handlers are equal.
+ (should (equal (dnd-handle-multiple-urls (selected-window)
+ (copy-sequence
+ dnd-tests-list-1)
+ 'copy)
+ 'copy))
+ ;; Check that sorting handlers by precedence functions correctly.
+ (setq dnd-protocol-alist '(("^file:///" . error)
+ ("^file:" . dnd-tests-remote-file-function)
+ ("^unrelated-scheme:" . error)))
+ (should (equal (dnd-handle-multiple-urls (selected-window)
+ (copy-sequence
+ dnd-tests-list-2)
+ 'copy)
+ 'copy))
+ ;; Check that multiple handlers can be called at once, and actions
+ ;; are properly "downgraded" to private when multiple handlers
+ ;; return inconsistent values.
+ (setq dnd-protocol-alist '(("^file:" . dnd-tests-remote-file-function)
+ ("^file:///" . error)
+ ("^http://" . dnd-tests-http-scheme-function)))
+ (should (equal (dnd-handle-multiple-urls (selected-window)
+ (copy-sequence
+ dnd-tests-list-3)
+ 'copy)
+ 'private))
+ ;; Now verify that the function's documented fallback behavior
+ ;; functions correctly. Set browse-url-handlers to an association
+ ;; list incorporating a test function, then guarantee that is
+ ;; called.
+ (setq browse-url-handlers '(("^scheme1://" . dnd-tests-browse-url-handler)))
+ ;; Furthermore, guarantee the fifth argument of the test data is
+ ;; inserted, for no apposite handler exists.
+ (save-window-excursion
+ (set-window-buffer nil (get-buffer-create " *dnd-tests*"))
+ (set-buffer (get-buffer-create " *dnd-tests*"))
+ (erase-buffer)
+ (should (equal (dnd-handle-multiple-urls (selected-window)
+ (copy-sequence
+ dnd-tests-list-4)
+ 'copy)
+ 'private))
+ (should (equal (buffer-string) (nth 4 dnd-tests-list-4))))
+ ;; Check that a handler enumerated twice in the handler list
+ ;; receives URIs assigned to it only once.
+ (let* ((received-p nil)
+ (lambda (lambda (uri _action)
+ (should (equal uri "scheme1://test"))
+ (should (null received-p))
+ (setq received-p 'copy))))
+ (setq dnd-protocol-alist (list (cons "scheme1://" lambda)
+ (cons "scheme1://" lambda)))
+ (should (equal (dnd-handle-multiple-urls (selected-window)
+ (list "scheme1://test")
+ 'copy)
+ 'copy)))))
+
+(ert-deftest dnd-tests-default-file-name-handlers ()
+ (let* ((local-files-opened nil)
+ (remote-files-opened nil)
+ (function-1 (lambda (file _uri)
+ (push file local-files-opened)
+ 'copy))
+ (function-2 (lambda (file _uri)
+ (push file remote-files-opened)
+ 'copy)))
+ (unwind-protect
+ (progn
+ (advice-add #'dnd-open-local-file :override
+ function-1)
+ (advice-add #'dnd-open-file :override
+ function-2)
+ ;; Guarantee that file names are properly categorized as either
+ ;; local or remote by the default dnd-protocol-alist.
+ (dnd-handle-multiple-urls
+ (selected-window)
+ (list
+ ;; These are run-of-the-mill local file URIs.
+ "file:///usr/include/sys/acct.h"
+ "file:///usr/include/sys/acctctl.h"
+ ;; These URIs incorporate a host; they should match
+ ;; function-2 but never function-1.
+ "file://remotehost/usr/src/emacs/configure.ac"
+ "file://remotehost/usr/src/emacs/configure"
+ ;; These URIs are generated by drag-and-drop event
+ ;; handlers from local file names alone; they are not
+ ;; echt URIs in and of themselves, but a product of our
+ ;; drag and drop code.
+ "file:/etc/vfstab"
+ "file:/etc/dfs/sharetab"
+ ;; These URIs are generated under MS-Windows.
+ "file:c:/path/to/file/name"
+ "file:d:/path/to/file/name")
+ 'copy)
+ (should (equal (sort local-files-opened #'string<)
+ '("file:///usr/include/sys/acct.h"
+ "file:///usr/include/sys/acctctl.h"
+ "file:/etc/dfs/sharetab"
+ "file:/etc/vfstab"
+ "file:c:/path/to/file/name"
+ "file:d:/path/to/file/name")))
+ (should (equal (sort remote-files-opened #'string<)
+ '("file://remotehost/usr/src/emacs/configure"
+ "file://remotehost/usr/src/emacs/configure.ac"))))
+ (advice-remove #'dnd-open-local-file function-2))))
+
(provide 'dnd-tests)
;;; dnd-tests.el ends here
diff --git a/test/lisp/dom-tests.el b/test/lisp/dom-tests.el
index 8cbfb9ad9df..a4e913541bf 100644
--- a/test/lisp/dom-tests.el
+++ b/test/lisp/dom-tests.el
@@ -209,6 +209,16 @@ child results in an error."
(dom-pp node t)
(should (equal (buffer-string) "(\"foo\" nil)")))))
+(ert-deftest dom-tests-print ()
+ "Test that `dom-print' correctly encodes HTML reserved characters."
+ (with-temp-buffer
+ (dom-print '(samp ((class . "samp")) "<div class=\"default\"> </div>"))
+ (should (equal
+ (buffer-string)
+ (concat "<samp class=\"samp\">"
+ "&lt;div class=&quot;default&quot;&gt; &lt;/div&gt;"
+ "</samp>")))))
+
(ert-deftest dom-test-search ()
(let ((dom '(a nil (b nil (c nil)))))
(should (equal (dom-search dom (lambda (d) (eq (dom-tag d) 'a)))
diff --git a/test/lisp/elide-head-tests.el b/test/lisp/elide-head-tests.el
index 6fc945f4eb8..3f1db75928a 100644
--- a/test/lisp/elide-head-tests.el
+++ b/test/lisp/elide-head-tests.el
@@ -180,6 +180,90 @@
;; along with Mentor. If not, see <https://www.gnu.org/licenses>.
" "Mentor is distributed in the hope that")
+;; from GnuTLS [has a line break in snail mail address]
+(elide-head--add-test gpl3-6 "\
+# This file is part of GnuTLS.
+#
+# 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, write to the Free Software
+# Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301
+# USA
+" "This program is distributed in the hope that")
+
+;; from GnuTLS [has a different line break in snail mail address]
+(elide-head--add-test gpl3-7 "\
+# This file is part of GnuTLS.
+#
+# The GnuTLS is free software; you can redistribute it and/or
+# modify it under the terms of the GNU Lesser General Public License
+# as published by the Free Software Foundation; either version 2.1 of
+# the License, or (at your option) any later version.
+#
+# The GnuTLS 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
+# Lesser General Public License for more details.
+#
+# You should have received a copy of the GNU Lesser General Public
+# License along with GnuTLS; if not, write to the Free
+# Software Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston,
+# MA 02110-1301, USA
+" "The GnuTLS is distributed in the hope that")
+
+;; from GnuTLS [has a typo in the 02111-1301 part]
+(elide-head--add-test gpl3-8 "\
+/* nettle, low-level cryptographics library
+ *
+ * Copyright (C) 2002 Niels Möller
+ * Copyright (C) 2014 Red Hat
+ *\s\s
+ * The nettle library is free software; you can redistribute it and/or modify
+ * it under the terms of the GNU Lesser General Public License as published by
+ * the Free Software Foundation; either version 2.1 of the License, or (at your
+ * option) any later version.
+ *\s
+ * The nettle library 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 Lesser General Public
+ * License for more details.
+ *\s
+ * You should have received a copy of the GNU Lesser General Public License
+ * along with the nettle library; see the file COPYING.LIB. If not, write to
+ * the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston,
+ * MA 02111-1301, USA.
+ */
+" "The nettle library is distributed in the hope that")
+
+;; from GnuTLS-EXTRA [has a different line break in snail mail address]
+(elide-head--add-test gpl3-9 "\
+# This file is part of GnuTLS-EXTRA.
+#
+# GnuTLS-extra 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.
+#
+# GnuTLS-extra 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 GnuTLS-EXTRA; if not, write to the Free Software
+# Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
+# 02110-1301, USA.
+" "GnuTLS-extra is distributed in the hope that")
+
;;; GPLv2
@@ -201,6 +285,28 @@
" "This program is distributed in the hope that")
+;;; Apache License
+
+(elide-head--add-test apache1-1 "\
+/*
+ * Copyright 2011-2016 The Pkcs11Interop Project
+ *
+ * Licensed under the Apache License, Version 2.0 (the \"License\");
+ * you may not use this file except in compliance with the License.
+ * You may obtain a copy of the License at
+ *
+ * https://www.apache.org/licenses/LICENSE-2.0
+ *
+ * Unless required by applicable law or agreed to in writing, software
+ * distributed under the License is distributed on an \"AS IS\" BASIS,
+ * WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
+ * See the License for the specific language governing permissions and
+ * limitations under the License.
+ */
+" "Unless required by applicable law")
+
+
+
;;; Obsolete
(with-suppressed-warnings ((obsolete elide-head)
diff --git a/test/lisp/emacs-lisp/backtrace-tests.el b/test/lisp/emacs-lisp/backtrace-tests.el
index 9ebbba2ced5..3248403078f 100644
--- a/test/lisp/emacs-lisp/backtrace-tests.el
+++ b/test/lisp/emacs-lisp/backtrace-tests.el
@@ -226,6 +226,9 @@
"Forms in backtrace frames can be on a single line or on multiple lines."
(ert-with-test-buffer (:name "single-multi-line")
(let* ((arg '(lambda (x) ; Quote this so it isn't made into a closure.
+ ;; Make the form long enough so `number' should not
+ ;; appear on the first line once pretty-printed.
+ (interactive (region-beginning))
(let ((number (1+ x)))
(+ x number))))
(header-string "Test header: ")
@@ -280,7 +283,8 @@ line contains the strings \"lambda\" and \"number\"."
;; Verify that the form is now back on one line,
;; and that point is at the same place.
(should (string= (backtrace-tests--get-substring
- (- (point) 6) (point)) "number"))
+ (- (point) 6) (point))
+ "number"))
(should-not (= (point) (pos-bol)))
(should (string= (backtrace-tests--get-substring
(pos-bol) (1+ (pos-eol)))
diff --git a/test/lisp/emacs-lisp/benchmark-tests.el b/test/lisp/emacs-lisp/benchmark-tests.el
index 27f5c3c6c10..72095ea5b09 100644
--- a/test/lisp/emacs-lisp/benchmark-tests.el
+++ b/test/lisp/emacs-lisp/benchmark-tests.el
@@ -25,8 +25,8 @@
(ert-deftest benchmark-tests ()
;; Avoid fork failures on Cygwin. See bug#62450 and etc/PROBLEMS
;; ("Fork failures in a build with native compilation").
- (skip-unless (not (and (eq system-type 'cygwin)
- (featurep 'native-compile))))
+ (skip-when (and (eq system-type 'cygwin)
+ (featurep 'native-compile)))
(let (str t-long t-short m)
(should (consp (benchmark-run nil (setq m (1+ 0)))))
(should (consp (benchmark-run 1 (setq m (1+ 0)))))
diff --git a/test/lisp/emacs-lisp/byte-run-tests.el b/test/lisp/emacs-lisp/byte-run-tests.el
new file mode 100644
index 00000000000..6180022f198
--- /dev/null
+++ b/test/lisp/emacs-lisp/byte-run-tests.el
@@ -0,0 +1,32 @@
+;;; byte-run-tests.el --- Tests for byte-run.el -*- lexical-binding: t -*-
+
+;; Copyright (C) 2023-2024 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 <https://www.gnu.org/licenses/>.
+
+;;; Code:
+
+(require 'ert)
+
+(ert-deftest make-obsolete ()
+ (should-error (make-obsolete nil 'foo "30.1"))
+ (should-error (make-obsolete t 'foo "30.1") ))
+
+(ert-deftest make-obsolete-variable ()
+ (should-error (make-obsolete-variable nil 'foo "30.1"))
+ (should-error (make-obsolete-variable t 'foo "30.1")))
+
+;;; byte-run-tests.el ends here
diff --git a/test/lisp/emacs-lisp/bytecomp-resources/no-byte-compile.el b/test/lisp/emacs-lisp/bytecomp-resources/no-byte-compile.el
index 00ad1947507..1de5cf66b66 100644
--- a/test/lisp/emacs-lisp/bytecomp-resources/no-byte-compile.el
+++ b/test/lisp/emacs-lisp/bytecomp-resources/no-byte-compile.el
@@ -1 +1 @@
-;; -*- no-byte-compile: t; -*-
+;; -*- no-byte-compile: t; lexical-binding: t; -*-
diff --git a/test/lisp/emacs-lisp/bytecomp-resources/warn-make-process-missing-keyword-arg.el b/test/lisp/emacs-lisp/bytecomp-resources/warn-make-process-missing-keyword-arg.el
new file mode 100644
index 00000000000..9369e78ff54
--- /dev/null
+++ b/test/lisp/emacs-lisp/bytecomp-resources/warn-make-process-missing-keyword-arg.el
@@ -0,0 +1,3 @@
+;;; -*- lexical-binding: t -*-
+(defun foo ()
+ (make-process :name "ls"))
diff --git a/test/lisp/emacs-lisp/bytecomp-resources/warn-make-process-missing-keyword-value.el b/test/lisp/emacs-lisp/bytecomp-resources/warn-make-process-missing-keyword-value.el
new file mode 100644
index 00000000000..4226349afef
--- /dev/null
+++ b/test/lisp/emacs-lisp/bytecomp-resources/warn-make-process-missing-keyword-value.el
@@ -0,0 +1,3 @@
+;;; -*- lexical-binding: t -*-
+(defun foo ()
+ (make-process :name "ls" :command))
diff --git a/test/lisp/emacs-lisp/bytecomp-resources/warn-make-process-repeated-keyword-arg.el b/test/lisp/emacs-lisp/bytecomp-resources/warn-make-process-repeated-keyword-arg.el
new file mode 100644
index 00000000000..18250f14ee9
--- /dev/null
+++ b/test/lisp/emacs-lisp/bytecomp-resources/warn-make-process-repeated-keyword-arg.el
@@ -0,0 +1,3 @@
+;;; -*- lexical-binding: t -*-
+(defun foo ()
+ (make-process :name "ls" :command "ls" :name "ls"))
diff --git a/test/lisp/emacs-lisp/bytecomp-resources/warn-make-process-unknown-keyword-arg.el b/test/lisp/emacs-lisp/bytecomp-resources/warn-make-process-unknown-keyword-arg.el
new file mode 100644
index 00000000000..4721035780b
--- /dev/null
+++ b/test/lisp/emacs-lisp/bytecomp-resources/warn-make-process-unknown-keyword-arg.el
@@ -0,0 +1,4 @@
+;;; -*- lexical-binding: t -*-
+(defun foo ()
+ (make-process :name "ls" :command "ls"
+ :coding-system 'binary))
diff --git a/test/lisp/emacs-lisp/bytecomp-resources/warn-wide-docstring-defun.el b/test/lisp/emacs-lisp/bytecomp-resources/warn-wide-docstring-defun.el
index 94b0e80c979..571f7f6f095 100644
--- a/test/lisp/emacs-lisp/bytecomp-resources/warn-wide-docstring-defun.el
+++ b/test/lisp/emacs-lisp/bytecomp-resources/warn-wide-docstring-defun.el
@@ -1,3 +1,4 @@
;;; -*- lexical-binding: t -*-
(defun foo ()
- "xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx")
+ "xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx"
+ nil)
diff --git a/test/lisp/emacs-lisp/bytecomp-tests.el b/test/lisp/emacs-lisp/bytecomp-tests.el
index 32501368516..26408e8685a 100644
--- a/test/lisp/emacs-lisp/bytecomp-tests.el
+++ b/test/lisp/emacs-lisp/bytecomp-tests.el
@@ -643,6 +643,16 @@ inner loops respectively."
(funcall (car f) 3)
(list a b))
+ (let ((x (list 1)))
+ (let ((y x)
+ (z (setq x (vector x))))
+ (list x y z)))
+
+ (let ((x (list 1)))
+ (let* ((y x)
+ (z (setq x (vector x))))
+ (list x y z)))
+
(cond)
(mapcar (lambda (x) (cond ((= x 0)))) '(0 1))
@@ -677,16 +687,18 @@ inner loops respectively."
(list x (funcall g))))))))
(funcall (funcall f 'b)))
(let ((f (lambda (x)
- (let ((g (lambda () x))
- (h (lambda () (setq x (list x x)))))
- (let ((x 'a))
- (list x (funcall g) (funcall h)))))))
+ (lambda ()
+ (let ((g (lambda () x))
+ (h (lambda () (setq x (list x x)))))
+ (let ((x 'a))
+ (list x (funcall g) (funcall h))))))))
(funcall (funcall f 'b)))
(let ((f (lambda (x)
- (let ((g (lambda () x))
- (h (lambda () (setq x (list x x)))))
- (let* ((x 'a))
- (list x (funcall g) (funcall h)))))))
+ (lambda ()
+ (let ((g (lambda () x))
+ (h (lambda () (setq x (list x x)))))
+ (let* ((x 'a))
+ (list x (funcall g) (funcall h))))))))
(funcall (funcall f 'b)))
;; Test constant-propagation of access to captured variables.
@@ -704,6 +716,93 @@ inner loops respectively."
(let ((bytecomp-tests--xx 1))
(set (make-local-variable 'bytecomp-tests--xx) 2)
bytecomp-tests--xx)
+
+ ;; Check for-effect optimization of `condition-case' body form.
+ ;; With `condition-case' in for-effect context:
+ (let ((x (bytecomp-test-identity ?A))
+ (r nil))
+ (condition-case e
+ (characterp x) ; value (:success, var)
+ (error (setq r 'bad))
+ (:success (setq r (list 'good e))))
+ r)
+ (let ((x (bytecomp-test-identity ?B))
+ (r nil))
+ (condition-case nil
+ (characterp x) ; for-effect (:success, no var)
+ (error (setq r 'bad))
+ (:success (setq r 'good)))
+ r)
+ (let ((x (bytecomp-test-identity ?C))
+ (r nil))
+ (condition-case e
+ (characterp x) ; for-effect (no :success, var)
+ (error (setq r (list 'bad e))))
+ r)
+ (let ((x (bytecomp-test-identity ?D))
+ (r nil))
+ (condition-case nil
+ (characterp x) ; for-effect (no :success, no var)
+ (error (setq r 'bad)))
+ r)
+ ;; With `condition-case' in value context:
+ (let ((x (bytecomp-test-identity ?E)))
+ (condition-case e
+ (characterp x) ; for-effect (:success, var)
+ (error (list 'bad e))
+ (:success (list 'good e))))
+ (let ((x (bytecomp-test-identity ?F)))
+ (condition-case nil
+ (characterp x) ; for-effect (:success, no var)
+ (error 'bad)
+ (:success 'good)))
+ (let ((x (bytecomp-test-identity ?G)))
+ (condition-case e
+ (characterp x) ; value (no :success, var)
+ (error (list 'bad e))))
+ (let ((x (bytecomp-test-identity ?H)))
+ (condition-case nil
+ (characterp x) ; value (no :success, no var)
+ (error 'bad)))
+
+ (condition-case nil
+ (bytecomp-test-identity 3)
+ (error 'bad)
+ (:success)) ; empty handler
+
+ ;; `cond' miscompilation bug
+ (let ((fn (lambda (x)
+ (let ((y nil))
+ (cond ((progn (setq x (1+ x)) (> x 10)) (setq y 'a))
+ ((eq x 1) (setq y 'b))
+ ((eq x 2) (setq y 'c)))
+ (list x y)))))
+ (mapcar fn (bytecomp-test-identity '(0 1 2 3 10 11))))
+
+ ;; `nconc' nil arg elimination
+ (nconc (list 1 2 3 4) nil)
+ (nconc (list 1 2 3 4) nil nil)
+ (let ((x (cons 1 (cons 2 (cons 3 4)))))
+ (nconc x nil))
+ (let ((x (cons 1 (cons 2 (cons 3 4)))))
+ (nconc x nil nil))
+ (let ((x (cons 1 (cons 2 (cons 3 4)))))
+ (nconc nil x nil (list 5 6) nil))
+
+ ;; (+ 0 -0.0) etc
+ (let ((x (bytecomp-test-identity -0.0)))
+ (list x (+ x) (+ 0 x) (+ x 0) (+ 1 2 -3 x) (+ 0 x 0)))
+
+ ;; Unary comparisons: keep side-effect, return t
+ (let ((x 0))
+ (list (= (setq x 1))
+ x))
+ ;; Aristotelian identity optimization
+ (let ((x (bytecomp-test-identity 1)))
+ (list (eq x x) (eql x x) (equal x x)))
+
+ ;; Legacy single-arg `apply' call
+ (apply '(* 2 3))
)
"List of expressions for cross-testing interpreted and compiled code.")
@@ -752,6 +851,27 @@ byte-compiled. Run with dynamic binding."
(should (equal (bytecomp-tests--eval-interpreted form)
(bytecomp-tests--eval-compiled form)))))))
+(ert-deftest bytecomp--fun-value-as-head ()
+ ;; Check that (FUN-VALUE ...) is a valid call, for compatibility (bug#68931).
+ ;; (There is also a warning but this test does not check that.)
+ (dolist (lb '(nil t))
+ (ert-info ((prin1-to-string lb) :prefix "lexical-binding: ")
+ (let* ((lexical-binding lb)
+ (s-int '(lambda (x) (1+ x)))
+ (s-comp (byte-compile s-int))
+ (v-int (lambda (x) (1+ x)))
+ (v-comp (byte-compile v-int))
+ (comp (lambda (f) (funcall (byte-compile `(lambda () (,f 3)))))))
+ (should (equal (funcall comp s-int) 4))
+ (should (equal (funcall comp s-comp) 4))
+ (should (equal (funcall comp v-int) 4))
+ (should (equal (funcall comp v-comp) 4))))))
+
+(defmacro bytecomp-tests--with-fresh-warnings (&rest body)
+ `(let ((macroexp--warned ; oh dear
+ (make-hash-table :test #'equal :weakness 'key)))
+ ,@body))
+
(defun test-byte-comp-compile-and-load (compile &rest forms)
(declare (indent 1))
(ert-with-temp-file elfile
@@ -766,7 +886,8 @@ byte-compiled. Run with dynamic binding."
(if compile
(let ((byte-compile-dest-file-function
(lambda (e) elcfile)))
- (byte-compile-file elfile)))
+ (bytecomp-tests--with-fresh-warnings
+ (byte-compile-file elfile))))
(load elfile nil 'nomessage))))
(ert-deftest test-byte-comp-macro-expansion ()
@@ -833,13 +954,30 @@ byte-compiled. Run with dynamic binding."
;; Should not warn that mt--test2 is not known to be defined.
(should-not (re-search-forward "my--test2" nil t))))
-(defmacro bytecomp--with-warning-test (re-warning &rest form)
+(defun bytecomp--with-warning-test (re-warning form)
(declare (indent 1))
- `(with-current-buffer (get-buffer-create "*Compile-Log*")
+ (with-current-buffer (get-buffer-create "*Compile-Log*")
(let ((inhibit-read-only t)) (erase-buffer))
- (byte-compile ,@form)
- (ert-info ((prin1-to-string (buffer-string)) :prefix "buffer: ")
- (should (re-search-forward ,(string-replace " " "[ \n]+" re-warning))))))
+ (ert-info ((prin1-to-string form) :prefix "form: ")
+ (let ((text-quoting-style 'grave))
+ (bytecomp-tests--with-fresh-warnings
+ (byte-compile form)))
+ (ert-info ((prin1-to-string (buffer-string)) :prefix "buffer: ")
+ (should (re-search-forward
+ (string-replace " " "[ \n]+" re-warning)))))))
+
+(defun bytecomp--without-warning-test (form)
+ (bytecomp--with-warning-test "\\`\\'" form))
+
+(ert-deftest bytecomp-warn--ignore ()
+ (bytecomp--with-warning-test "unused"
+ '(lambda (y) 6))
+ (bytecomp--without-warning-test
+ '(lambda (y) (ignore y) 6))
+ (bytecomp--with-warning-test "assq"
+ '(lambda (x y) (progn (assq x y) 5)))
+ (bytecomp--without-warning-test
+ '(lambda (x y) (progn (ignore (assq x y)) 5))))
(ert-deftest bytecomp-warn-wrong-args ()
(bytecomp--with-warning-test "remq.*3.*2"
@@ -863,6 +1001,94 @@ byte-compiled. Run with dynamic binding."
(bytecomp--with-warning-test "defvar.*foo.*wider than.*characters"
`(defvar foo t ,bytecomp-tests--docstring)))
+(ert-deftest bytecomp-warn-wide-docstring/cl-defsubst ()
+ (bytecomp--without-warning-test
+ `(cl-defsubst short-name ()
+ "Do something."))
+ (bytecomp--without-warning-test
+ `(cl-defsubst long-name-with-less-80-characters-but-still-quite-a-bit ()
+ "Do something."))
+ (bytecomp--with-warning-test "wider than.*characters"
+ `(cl-defsubst long-name-with-more-than-80-characters-yes-this-is-a-very-long-name-but-why-not!! ()
+ "Do something.")))
+
+(ert-deftest bytecomp-warn-wide-docstring/cl-defstruct ()
+ (bytecomp--without-warning-test
+ `(cl-defstruct short-name
+ field))
+ (bytecomp--without-warning-test
+ `(cl-defstruct short-name
+ long-name-with-less-80-characters-but-still-quite-a-bit))
+ (bytecomp--without-warning-test
+ `(cl-defstruct long-name-with-less-80-characters-but-still-quite-a-bit
+ field))
+ (bytecomp--with-warning-test "wider than.*characters"
+ `(cl-defstruct short-name
+ long-name-with-more-than-80-characters-yes-this-is-a-very-long-name-but-why-not!!))
+ (bytecomp--with-warning-test "wider than.*characters"
+ `(cl-defstruct long-name-with-more-than-80-characters-yes-this-is-a-very-long-name-but-why-not!!
+ field)))
+
+(ert-deftest bytecomp-warn-quoted-condition ()
+ (bytecomp--with-warning-test
+ "Warning: `condition-case' condition should not be quoted: 'arith-error"
+ '(condition-case nil
+ (abc)
+ ('arith-error "ugh")))
+ (bytecomp--with-warning-test
+ "Warning: `ignore-error' condition argument should not be quoted: 'error"
+ '(ignore-error 'error (abc))))
+
+(ert-deftest bytecomp-warn-dodgy-args-eq ()
+ (dolist (fn '(eq eql))
+ (cl-flet ((msg (type arg)
+ (format
+ "`%s' called with literal %s that may never match (arg %d)"
+ fn type arg)))
+ (bytecomp--with-warning-test (msg "list" 1) `(,fn '(a) 'x))
+ (bytecomp--with-warning-test (msg "string" 2) `(,fn 'x "a"))
+ (bytecomp--with-warning-test (msg "vector" 2) `(,fn 'x [a]))
+ (bytecomp--with-warning-test (msg "function" 2) `(,fn 'x (lambda () 1)))
+ (bytecomp--with-warning-test (msg "function" 2) `(,fn 'x #'(lambda () 1)))
+ (unless (eq fn 'eql)
+ (bytecomp--with-warning-test (msg "integer" 2) `(,fn 'x #x10000000000))
+ (bytecomp--with-warning-test (msg "float" 2) `(,fn 'x 1.0))))))
+
+(ert-deftest bytecomp-warn-dodgy-args-memq ()
+ (dolist (fn '(memq memql remq delq assq rassq))
+ (cl-labels
+ ((msg1 (type)
+ (format
+ "`%s' called with literal %s that may never match (arg 1)"
+ fn type))
+ (msg2 (type)
+ (format
+ "`%s' called with literal %s that may never match (element 2 of arg 2)"
+ fn type))
+ (lst (elt)
+ (cond ((eq fn 'assq) `((a . 1) (,elt . 2) (c . 3)))
+ ((eq fn 'rassq) `((1 . a) (2 . ,elt) (3 . c)))
+ (t `(a ,elt c))))
+ (form2 (elt)
+ `(,fn 'x ',(lst elt))))
+
+ (bytecomp--with-warning-test (msg1 "list") `(,fn '(a) '(x)))
+ (bytecomp--with-warning-test (msg1 "string") `(,fn "a" '(x)))
+ (bytecomp--with-warning-test (msg1 "vector") `(,fn [a] '(x)))
+ (bytecomp--with-warning-test (msg1 "function") `(,fn (lambda () 1) '(x)))
+ (bytecomp--with-warning-test (msg1 "function") `(,fn #'(lambda () 1) '(x)))
+ (unless (eq fn 'memql)
+ (bytecomp--with-warning-test (msg1 "integer") `(,fn #x10000000000 '(x)))
+ (bytecomp--with-warning-test (msg1 "float") `(,fn 1.0 '(x))))
+
+ (bytecomp--with-warning-test (msg2 "list") (form2 '(b)))
+ (bytecomp--with-warning-test (msg2 "list") (form2 ''b))
+ (bytecomp--with-warning-test (msg2 "string") (form2 "b"))
+ (bytecomp--with-warning-test (msg2 "vector") (form2 [b]))
+ (unless (eq fn 'memql)
+ (bytecomp--with-warning-test (msg2 "integer") (form2 #x10000000000))
+ (bytecomp--with-warning-test (msg2 "float") (form2 1.0))))))
+
(defmacro bytecomp--define-warning-file-test (file re-warning &optional reverse)
`(ert-deftest ,(intern (format "bytecomp/%s" file)) ()
(with-current-buffer (get-buffer-create "*Compile-Log*")
@@ -903,7 +1129,7 @@ byte-compiled. Run with dynamic binding."
"fails to specify containing group")
(bytecomp--define-warning-file-test "warn-defcustom-notype.el"
- "fails to specify type")
+ "missing :type keyword parameter")
(bytecomp--define-warning-file-test "warn-defvar-lacks-prefix.el"
"var.*foo.*lacks a prefix")
@@ -1043,6 +1269,22 @@ byte-compiled. Run with dynamic binding."
"nowarn-inline-after-defvar.el"
"Lexical argument shadows" 'reverse)
+(bytecomp--define-warning-file-test
+ "warn-make-process-missing-keyword-arg.el"
+ "called without required keyword argument :command")
+
+(bytecomp--define-warning-file-test
+ "warn-make-process-unknown-keyword-arg.el"
+ "called with unknown keyword argument :coding-system")
+
+(bytecomp--define-warning-file-test
+ "warn-make-process-repeated-keyword-arg.el"
+ "called with repeated keyword argument :name")
+
+(bytecomp--define-warning-file-test
+ "warn-make-process-missing-keyword-value.el"
+ "missing value for keyword argument :command")
+
;;;; Macro expansion.
@@ -1089,14 +1331,41 @@ byte-compiled. Run with dynamic binding."
(let ((elc (concat ,file-name-var ".elc")))
(if (file-exists-p elc) (delete-file elc))))))
+(defun bytecomp-tests--log-from-compilation (source)
+ "Compile the string SOURCE and return the compilation log output."
+ (let ((text-quoting-style 'grave)
+ (byte-compile-log-buffer (generate-new-buffer " *Compile-Log*")))
+ (with-current-buffer byte-compile-log-buffer
+ (let ((inhibit-read-only t)) (erase-buffer)))
+ (bytecomp-tests--with-temp-file el-file
+ (write-region source nil el-file)
+ (byte-compile-file el-file))
+ (with-current-buffer byte-compile-log-buffer
+ (buffer-string))))
+
+(ert-deftest bytecomp-tests--lexical-binding-cookie ()
+ (cl-flet ((cookie-warning (source)
+ (string-search
+ "file has no `lexical-binding' directive on its first line"
+ (bytecomp-tests--log-from-compilation source))))
+ (let ((some-code "(defun my-fun () 12)\n"))
+ (should-not (cookie-warning
+ (concat ";;; -*-lexical-binding:t-*-\n" some-code)))
+ (should-not (cookie-warning
+ (concat ";;; -*-lexical-binding:nil-*-\n" some-code)))
+ (should (cookie-warning some-code)))))
+
(ert-deftest bytecomp-tests--unescaped-char-literals ()
"Check that byte compiling warns about unescaped character
literals (Bug#20852)."
(should (boundp 'lread--unescaped-character-literals))
(let ((byte-compile-error-on-warn t)
- (byte-compile-debug t))
+ (byte-compile-debug t)
+ (text-quoting-style 'grave))
(bytecomp-tests--with-temp-file source
- (write-region "(list ?) ?( ?; ?\" ?[ ?])" nil source)
+ (write-region (concat ";;; -*-lexical-binding:t-*-\n"
+ "(list ?) ?( ?; ?\" ?[ ?])")
+ nil source)
(bytecomp-tests--with-temp-file destination
(let* ((byte-compile-dest-file-function (lambda (_) destination))
(err (should-error (byte-compile-file source))))
@@ -1108,7 +1377,9 @@ literals (Bug#20852)."
"`?\\]' expected!")))))))
;; But don't warn in subsequent compilations (Bug#36068).
(bytecomp-tests--with-temp-file source
- (write-region "(list 1 2 3)" nil source)
+ (write-region (concat ";;; -*-lexical-binding:t-*-\n"
+ "(list 1 2 3)")
+ nil source)
(bytecomp-tests--with-temp-file destination
(let ((byte-compile-dest-file-function (lambda (_) destination)))
(should (byte-compile-file source)))))))
@@ -1116,6 +1387,7 @@ literals (Bug#20852)."
(ert-deftest bytecomp-tests-function-put ()
"Check `function-put' operates during compilation."
(bytecomp-tests--with-temp-file source
+ (insert ";;; -*-lexical-binding:t-*-\n")
(dolist (form '((function-put 'bytecomp-tests--foo 'foo 1)
(function-put 'bytecomp-tests--foo 'bar 2)
(defmacro bytecomp-tests--foobar ()
@@ -1213,6 +1485,7 @@ literals (Bug#20852)."
(defun test-suppression (form suppress match)
(let ((lexical-binding t)
+ (text-quoting-style 'grave)
(byte-compile-log-buffer (generate-new-buffer " *Compile-Log*")))
;; Check that we get a warning without suppression.
(with-current-buffer byte-compile-log-buffer
@@ -1299,8 +1572,8 @@ literals (Bug#20852)."
'(defun zot ()
(mapcar #'list '(1 2 3))
nil)
- '((mapcar mapcar))
- "Warning: .mapcar. called for effect")
+ '((ignored-return-value mapcar))
+ "Warning: value from call to `mapcar' is unused; use `mapc' or `dolist' instead")
(test-suppression
'(defun zot ()
@@ -1314,7 +1587,101 @@ literals (Bug#20852)."
(set-buffer (get-buffer-create "foo"))
nil))
'((suspicious set-buffer))
- "Warning: Use .with-current-buffer. rather than"))
+ "Warning: Use .with-current-buffer. rather than")
+
+ (test-suppression
+ '(defun zot (x)
+ (condition-case nil (list x)))
+ '((suspicious condition-case))
+ "Warning: `condition-case' without handlers")
+
+ (test-suppression
+ '(defun zot (x)
+ (unwind-protect (print x)))
+ '((suspicious unwind-protect))
+ "Warning: `unwind-protect' without unwind forms")
+
+ (test-suppression
+ '(defun zot (x)
+ (cond
+ ((zerop x) 'zero)
+ (t 'nonzero)
+ (happy puppy)))
+ '((suspicious cond))
+ "Warning: Useless clause following default `cond' clause")
+
+ (test-suppression
+ '(defun zot ()
+ (let ((_ 1))
+ ))
+ '((empty-body let))
+ "Warning: `let' with empty body")
+
+ (test-suppression
+ '(defun zot ()
+ (let* ((_ 1))
+ ))
+ '((empty-body let*))
+ "Warning: `let\\*' with empty body")
+
+ (test-suppression
+ '(defun zot (x)
+ (when x
+ ))
+ '((empty-body when))
+ "Warning: `when' with empty body")
+
+ (test-suppression
+ '(defun zot (x)
+ (unless x
+ ))
+ '((empty-body unless))
+ "Warning: `unless' with empty body")
+
+ (test-suppression
+ '(defun zot (x)
+ (ignore-error arith-error
+ ))
+ '((empty-body ignore-error))
+ "Warning: `ignore-error' with empty body")
+
+ (test-suppression
+ '(defun zot (x)
+ (with-suppressed-warnings ((suspicious eq))
+ ))
+ '((empty-body with-suppressed-warnings))
+ "Warning: `with-suppressed-warnings' with empty body")
+
+ (test-suppression
+ '(defun zot ()
+ (setcar '(1 2) 3))
+ '((mutate-constant setcar))
+ "Warning: `setcar' on constant list (arg 1)")
+
+ (test-suppression
+ '(defun zot ()
+ (aset [1 2] 1 3))
+ '((mutate-constant aset))
+ "Warning: `aset' on constant vector (arg 1)")
+
+ (test-suppression
+ '(defun zot ()
+ (aset "abc" 1 ?d))
+ '((mutate-constant aset))
+ "Warning: `aset' on constant string (arg 1)")
+
+ (test-suppression
+ '(defun zot (x y)
+ (nconc x y '(1 2) '(3 4)))
+ '((mutate-constant nconc))
+ "Warning: `nconc' on constant list (arg 3)")
+
+ (test-suppression
+ '(defun zot ()
+ (put-text-property 0 2 'prop 'val "abc"))
+ '((mutate-constant put-text-property))
+ "Warning: `put-text-property' on constant string (arg 5)")
+ )
(ert-deftest bytecomp-tests--not-writable-directory ()
"Test that byte compilation works if the output directory isn't
@@ -1327,7 +1694,8 @@ writable (Bug#44631)."
(byte-compile-error-on-warn t))
(unwind-protect
(progn
- (write-region "" nil input-file nil nil nil 'excl)
+ (write-region ";;; -*-lexical-binding:t-*-\n"
+ nil input-file nil nil nil 'excl)
(write-region "" nil output-file nil nil nil 'excl)
(set-file-modes input-file #o400)
(set-file-modes output-file #o200)
@@ -1358,7 +1726,8 @@ mountpoint (Bug#44631)."
(byte-compile-error-on-warn t))
(should-not (file-remote-p input-file))
(should-not (file-remote-p output-file))
- (write-region "" nil input-file nil nil nil 'excl)
+ (write-region ";;; -*-lexical-binding:t-*-\n"
+ nil input-file nil nil nil 'excl)
(write-region "" nil output-file nil nil nil 'excl)
(unwind-protect
(progn
@@ -1391,7 +1760,8 @@ mountpoint (Bug#44631)."
(let* ((default-directory directory)
(byte-compile-dest-file-function (lambda (_) "test.elc"))
(byte-compile-error-on-warn t))
- (write-region "" nil "test.el" nil nil nil 'excl)
+ (write-region ";;; -*-lexical-binding:t-*-\n"
+ nil "test.el" nil nil nil 'excl)
(should (byte-compile-file "test.el"))
(should (file-regular-p "test.elc"))
(should (cl-plusp (file-attribute-size
@@ -1565,12 +1935,53 @@ EXPECTED-POINT BINDINGS (MODES \\='\\='(ruby-mode js-mode python-mode)) \
(TEST-IN-COMMENTS t) (TEST-IN-STRINGS t) (TEST-IN-CODE t) \
(FIXTURE-FN \\='#\\='electric-pair-mode))" fill-column)))
-(defun test-bytecomp-defgroup-choice ()
- (should-not (byte-compile--suspicious-defcustom-choice 'integer))
- (should-not (byte-compile--suspicious-defcustom-choice
- '(choice (const :tag "foo" bar))))
- (should (byte-compile--suspicious-defcustom-choice
- '(choice (const :tag "foo" 'bar)))))
+(ert-deftest bytecomp-test-defcustom-type ()
+ (cl-flet ((dc (type) `(defcustom mytest nil "doc" :type ',type :group 'test)))
+ (bytecomp--with-warning-test
+ (rx "type should not be quoted") (dc ''integer))
+ (bytecomp--with-warning-test
+ (rx "type should not be quoted") (dc '(choice '(repeat boolean))))
+ (bytecomp--with-warning-test
+ (rx "misplaced :tag keyword") (dc '(choice (const b :tag "a"))))
+ (bytecomp--with-warning-test
+ (rx "`choice' without any types inside") (dc '(choice :tag "a")))
+ (bytecomp--with-warning-test
+ (rx "`other' not last in `choice'")
+ (dc '(choice (const a) (other b) (const c))))
+ (bytecomp--with-warning-test
+ (rx "duplicated value in `choice': `a'")
+ (dc '(choice (const a) (const b) (const a))))
+ (bytecomp--with-warning-test
+ (rx "duplicated :tag string in `choice': \"X\"")
+ (dc '(choice (const :tag "X" a) (const :tag "Y" b) (other :tag "X" c))))
+ (bytecomp--with-warning-test
+ (rx "`cons' requires 2 type specs, found 1")
+ (dc '(cons :tag "a" integer)))
+ (bytecomp--with-warning-test
+ (rx "`repeat' without type specs")
+ (dc '(repeat :tag "a")))
+ (bytecomp--with-warning-test
+ (rx "`const' with too many values")
+ (dc '(const :tag "a" x y)))
+ (bytecomp--with-warning-test
+ (rx "`const' with quoted value")
+ (dc '(const :tag "a" 'x)))
+ (bytecomp--with-warning-test
+ (rx "`bool' is not a valid type")
+ (dc '(bool :tag "a")))
+ (bytecomp--with-warning-test
+ (rx "irregular type `:tag'")
+ (dc '(:tag "a")))
+ (bytecomp--with-warning-test
+ (rx "irregular type `\"string\"'")
+ (dc '(list "string")))
+ (bytecomp--with-warning-test
+ (rx "`list' without arguments")
+ (dc 'list))
+ (bytecomp--with-warning-test
+ (rx "`integerp' is not a valid type")
+ (dc 'integerp))
+ ))
(ert-deftest bytecomp-function-attributes ()
;; Check that `byte-compile' keeps the declarations, interactive spec and
@@ -1662,6 +2073,129 @@ EXPECTED-POINT BINDINGS (MODES \\='\\='(ruby-mode js-mode python-mode)) \
(should (eq (byte-compile-file src-file) 'no-byte-compile))
(should-not (file-exists-p dest-file))))
+(ert-deftest bytecomp--copy-tree ()
+ (should (null (bytecomp--copy-tree nil)))
+ (let ((print-circle t))
+ (let* ((x '(1 2 (3 4)))
+ (y (bytecomp--copy-tree x)))
+ (should (equal (prin1-to-string (list x y))
+ "((1 2 (3 4)) (1 2 (3 4)))")))
+ (let* ((x '#1=(a #1#))
+ (y (bytecomp--copy-tree x)))
+ (should (equal (prin1-to-string (list x y))
+ "(#1=(a #1#) #2=(a #2#))")))
+ (let* ((x '#1=(#1# a))
+ (y (bytecomp--copy-tree x)))
+ (should (equal (prin1-to-string (list x y))
+ "(#1=(#1# a) #2=(#2# a))")))
+ (let* ((x '((a . #1=(b)) #1#))
+ (y (bytecomp--copy-tree x)))
+ (should (equal (prin1-to-string (list x y))
+ "(((a . #1=(b)) #1#) ((a . #2=(b)) #2#))")))
+ (let* ((x '#1=(a #2=(#1# b . #3=(#2# c . #1#)) (#3# d)))
+ (y (bytecomp--copy-tree x)))
+ (should (equal (prin1-to-string (list x y))
+ (concat
+ "("
+ "#1=(a #2=(#1# b . #3=(#2# c . #1#)) (#3# d))"
+ " "
+ "#4=(a #5=(#4# b . #6=(#5# c . #4#)) (#6# d))"
+ ")"))))))
+
+(require 'backtrace)
+
+(defun bytecomp-tests--error-frame (fun args)
+ "Call FUN with ARGS. Return result or (ERROR . BACKTRACE-FRAME)."
+ (letrec ((handler (lambda (e)
+ (throw 'bytecomp-tests--backtrace
+ (cons e (cadr (backtrace-get-frames handler)))))))
+ (catch 'bytecomp-tests--backtrace
+ (handler-bind ((error handler))
+ (apply fun args)))))
+
+(defconst bytecomp-tests--byte-op-error-cases
+ '(((car a) (wrong-type-argument listp a))
+ ((cdr 3) (wrong-type-argument listp 3))
+ ((setcar 4 b) (wrong-type-argument consp 4))
+ ((setcdr c 5) (wrong-type-argument consp c))
+ ((nth 2 "abcd") (wrong-type-argument listp "abcd"))
+ ((elt (x y . z) 2) (wrong-type-argument listp z))
+ ((aref [2 3 5] p) (wrong-type-argument fixnump p))
+ ((aref #s(a b c) p) (wrong-type-argument fixnump p))
+ ((aref "abc" p) (wrong-type-argument fixnump p))
+ ((aref [2 3 5] 3) (args-out-of-range [2 3 5] 3))
+ ((aref #s(a b c) 3) (args-out-of-range #s(a b c) 3))
+ ((aset [2 3 5] q 1) (wrong-type-argument fixnump q))
+ ((aset #s(a b c) q 1) (wrong-type-argument fixnump q))
+ ((aset [2 3 5] -1 1) (args-out-of-range [2 3 5] -1))
+ ((aset #s(a b c) -1 1) (args-out-of-range #s(a b c) -1))
+ ;; Many more to add
+ ))
+
+(ert-deftest bytecomp--byte-op-error-backtrace ()
+ "Check that signaling byte ops show up in the backtrace."
+ (dolist (case bytecomp-tests--byte-op-error-cases)
+ (ert-info ((prin1-to-string case) :prefix "case: ")
+ (let* ((call (nth 0 case))
+ (expected-error (nth 1 case))
+ (fun-sym (car call))
+ (actuals (cdr call)))
+ ;; Test both calling the function directly, and calling
+ ;; a byte-compiled η-expansion (lambda (ARGS...) (FUN ARGS...))
+ ;; which should turn the function call into a byte-op.
+ (dolist (mode '(funcall byte-op))
+ (ert-info ((symbol-name mode) :prefix "mode: ")
+ (let* ((fun (pcase-exhaustive mode
+ ('funcall fun-sym)
+ ('byte-op
+ (let* ((nargs (length (cdr call)))
+ (formals (mapcar (lambda (i)
+ (intern (format "x%d" i)))
+ (number-sequence 1 nargs))))
+ (byte-compile
+ `(lambda ,formals (,fun-sym ,@formals)))))))
+ (error-frame (bytecomp-tests--error-frame fun actuals)))
+ (should (consp error-frame))
+ (should (equal (car error-frame) expected-error))
+ (let ((frame (cdr error-frame)))
+ (should (equal (type-of frame) 'backtrace-frame))
+ (should (equal (cons (backtrace-frame-fun frame)
+ (backtrace-frame-args frame))
+ call))))))))))
+
+(ert-deftest bytecomp--eq-symbols-with-pos-enabled ()
+ ;; Verify that we don't optimize away a binding of
+ ;; `symbols-with-pos-enabled' around an application of `eq' (bug#65017).
+ (let* ((sym-with-pos1 (read-positioning-symbols "sym"))
+ (sym-with-pos2 (read-positioning-symbols " sym")) ; <- space!
+ (without-pos-eq (lambda (a b)
+ (let ((symbols-with-pos-enabled nil))
+ (eq a b))))
+ (without-pos-eq-compiled (byte-compile without-pos-eq))
+ (with-pos-eq (lambda (a b)
+ (let ((symbols-with-pos-enabled t))
+ (eq a b))))
+ (with-pos-eq-compiled (byte-compile with-pos-eq)))
+ (dolist (mode '(interpreted compiled))
+ (ert-info ((symbol-name mode) :prefix "mode: ")
+ (ert-info ("disabled" :prefix "symbol-pos: ")
+ (let ((eq-fn (pcase-exhaustive mode
+ ('interpreted without-pos-eq)
+ ('compiled without-pos-eq-compiled))))
+ (should (equal (funcall eq-fn 'sym 'sym) t))
+ (should (equal (funcall eq-fn sym-with-pos1 'sym) nil))
+ (should (equal (funcall eq-fn 'sym sym-with-pos1) nil))
+ (should (equal (funcall eq-fn sym-with-pos1 sym-with-pos1) t))
+ (should (equal (funcall eq-fn sym-with-pos1 sym-with-pos2) nil))))
+ (ert-info ("enabled" :prefix "symbol-pos: ")
+ (let ((eq-fn (pcase-exhaustive mode
+ ('interpreted with-pos-eq)
+ ('compiled with-pos-eq-compiled))))
+ (should (equal (funcall eq-fn 'sym 'sym) t))
+ (should (equal (funcall eq-fn sym-with-pos1 'sym) t))
+ (should (equal (funcall eq-fn 'sym sym-with-pos1) t))
+ (should (equal (funcall eq-fn sym-with-pos1 sym-with-pos1) t))
+ (should (equal (funcall eq-fn sym-with-pos1 sym-with-pos2) t))))))))
;; Local Variables:
;; no-byte-compile: t
diff --git a/test/lisp/emacs-lisp/cconv-tests.el b/test/lisp/emacs-lisp/cconv-tests.el
index ac3409f3999..8cab859b5b5 100644
--- a/test/lisp/emacs-lisp/cconv-tests.el
+++ b/test/lisp/emacs-lisp/cconv-tests.el
@@ -364,5 +364,30 @@
(call-interactively f))
'((t 51696) (nil 51695) (t 51697)))))))
+(ert-deftest cconv-safe-for-space ()
+ (let* ((magic-string "This-is-a-magic-string")
+ (safe-p (lambda (x) (not (string-match magic-string (format "%S" x))))))
+ (should (funcall safe-p (lambda (x) (+ x 1))))
+ (should (funcall safe-p (eval '(lambda (x) (+ x 1))
+ `((y . ,magic-string)))))
+ (should (funcall safe-p (eval '(lambda (x) :closure-dont-trim-context)
+ `((y . ,magic-string)))))
+ (should-not (funcall safe-p
+ (eval '(lambda (x) :closure-dont-trim-context (+ x 1))
+ `((y . ,magic-string)))))))
+
+(ert-deftest cconv-tests-interactive-form-modify-bug60974 ()
+ (let* ((f '(function (lambda (&optional arg)
+ (interactive
+ (list (if current-prefix-arg
+ (prefix-numeric-value current-prefix-arg)
+ 'toggle)))
+ (ignore arg))))
+ (if (cadr (nth 2 (cadr f))))
+ (if2))
+ (cconv-closure-convert f)
+ (setq if2 (cadr (nth 2 (cadr f))))
+ (should (eq if if2))))
+
(provide 'cconv-tests)
;;; cconv-tests.el ends here
diff --git a/test/lisp/emacs-lisp/checkdoc-tests.el b/test/lisp/emacs-lisp/checkdoc-tests.el
index 6ca316beff2..049d2d953a0 100644
--- a/test/lisp/emacs-lisp/checkdoc-tests.el
+++ b/test/lisp/emacs-lisp/checkdoc-tests.el
@@ -37,6 +37,15 @@
(insert "(defun foo())")
(should-error (checkdoc-defun) :type 'user-error)))
+(ert-deftest checkdoc-docstring-avoid-false-positive-ok ()
+ "Check that Bug#68002 is fixed."
+ (with-temp-buffer
+ (emacs-lisp-mode)
+ (insert "(defvar org-element--cache-interrupt-C-g-count 0
+ \"Current number of `org-element--cache-sync' calls.
+See `org-element--cache-interrupt-C-g'.\")")
+ (checkdoc-defun)))
+
(ert-deftest checkdoc-cl-defmethod-ok ()
"Checkdoc should be happy with a simple correct cl-defmethod."
(with-temp-buffer
diff --git a/test/lisp/emacs-lisp/cl-generic-tests.el b/test/lisp/emacs-lisp/cl-generic-tests.el
index 086ac399352..1241d28ab74 100644
--- a/test/lisp/emacs-lisp/cl-generic-tests.el
+++ b/test/lisp/emacs-lisp/cl-generic-tests.el
@@ -319,5 +319,18 @@ Edebug symbols (Bug#42672)."
(and (eq 'error (car err))
(string-match "Stray.*declare" (cadr err)))))))
+(cl-defmethod cl-generic-tests--print-quoted-method ((function (eql '4)))
+ (+ function 1))
+
+(ert-deftest cl-generic-tests--print-quoted ()
+ (with-temp-buffer
+ (cl--generic-describe 'cl-generic-tests--print-quoted-method)
+ (goto-char (point-min))
+ ;; Bug#54628: We don't want (function (eql '4)) to turn into #'(eql '4)
+ (should-not (re-search-forward "#'" nil t))
+ (goto-char (point-min))
+ ;; But we don't want (eql '4) to turn into (eql (quote 4)) either.
+ (should (re-search-forward "(eql '4)" nil t))))
+
(provide 'cl-generic-tests)
;;; cl-generic-tests.el ends here
diff --git a/test/lisp/emacs-lisp/cl-lib-tests.el b/test/lisp/emacs-lisp/cl-lib-tests.el
index 0eafd376028..14ff8628fb8 100644
--- a/test/lisp/emacs-lisp/cl-lib-tests.el
+++ b/test/lisp/emacs-lisp/cl-lib-tests.el
@@ -404,7 +404,7 @@
(ert-deftest cl-lib-nth-value-test-multiple-values ()
"While CL multiple values are an alias to list, these won't work."
:expected-result :failed
- (should (eq (cl-nth-value 0 '(2 3)) '(2 3)))
+ (should (equal (cl-nth-value 0 '(2 3)) '(2 3)))
(should (= (cl-nth-value 0 1) 1))
(should (null (cl-nth-value 1 1)))
(should-error (cl-nth-value -1 (cl-values 2 3)) :type 'args-out-of-range)
@@ -431,7 +431,8 @@
(should (eq nums (cdr (cl-adjoin 3 nums))))
;; add only when not already there
(should (eq nums (cl-adjoin 2 nums)))
- (should (equal '(2 1 (2)) (cl-adjoin 2 '(1 (2)))))
+ (with-suppressed-warnings ((suspicious memql))
+ (should (equal '(2 1 (2)) (cl-adjoin 2 '(1 (2))))))
;; default test function is eql
(should (equal '(1.0 1 2) (cl-adjoin 1.0 nums)))
;; own :test function - returns true if match
@@ -529,27 +530,29 @@
(ert-deftest old-struct ()
(cl-defstruct foo x)
- (let ((x [cl-struct-foo])
- (saved cl-old-struct-compat-mode))
- (cl-old-struct-compat-mode -1)
- (should (eq (type-of x) 'vector))
+ (with-suppressed-warnings ((obsolete cl-old-struct-compat-mode))
+ (let ((x (vector 'cl-struct-foo))
+ (saved cl-old-struct-compat-mode))
+ (cl-old-struct-compat-mode -1)
+ (should (eq (type-of x) 'vector))
- (cl-old-struct-compat-mode 1)
- (defvar cl-struct-foo)
- (let ((cl-struct-foo (cl--struct-get-class 'foo)))
- (setf (symbol-function 'cl-struct-foo) :quick-object-witness-check)
- (should (eq (type-of x) 'foo))
- (should (eq (type-of [foo]) 'vector)))
+ (cl-old-struct-compat-mode 1)
+ (defvar cl-struct-foo)
+ (let ((cl-struct-foo (cl--struct-get-class 'foo)))
+ (setf (symbol-function 'cl-struct-foo) :quick-object-witness-check)
+ (should (eq (type-of x) 'foo))
+ (should (eq (type-of (vector 'foo)) 'vector)))
- (cl-old-struct-compat-mode (if saved 1 -1))))
+ (cl-old-struct-compat-mode (if saved 1 -1)))))
(ert-deftest cl-lib-old-struct ()
- (let ((saved cl-old-struct-compat-mode))
- (cl-old-struct-compat-mode -1)
- (cl-struct-define 'foo "" 'cl-structure-object nil nil nil
- 'cl-struct-foo-tags 'cl-struct-foo t)
- (should cl-old-struct-compat-mode)
- (cl-old-struct-compat-mode (if saved 1 -1))))
+ (with-suppressed-warnings ((obsolete cl-old-struct-compat-mode))
+ (let ((saved cl-old-struct-compat-mode))
+ (cl-old-struct-compat-mode -1)
+ (cl-struct-define 'foo "" 'cl-structure-object nil nil nil
+ 'cl-struct-foo-tags 'cl-struct-foo t)
+ (should cl-old-struct-compat-mode)
+ (cl-old-struct-compat-mode (if saved 1 -1)))))
(ert-deftest cl-constantly ()
(should (equal (mapcar (cl-constantly 3) '(a b c d))
diff --git a/test/lisp/emacs-lisp/cl-macs-tests.el b/test/lisp/emacs-lisp/cl-macs-tests.el
index b3f0c9213b4..3fabcbc50c9 100644
--- a/test/lisp/emacs-lisp/cl-macs-tests.el
+++ b/test/lisp/emacs-lisp/cl-macs-tests.el
@@ -535,7 +535,7 @@ collection clause."
(eval '(let ((l (list 1))) (cl-symbol-macrolet ((x 1)) (setq (car l) 0))) t))
;; Make sure `gv-synthetic-place' isn't macro-expanded before `setf' gets to
;; see its `gv-expander'.
- (should (equal (let ((l '(0)))
+ (should (equal (let ((l (list 0)))
(let ((cl (car l)))
(cl-symbol-macrolet
((p (gv-synthetic-place cl (lambda (v) `(setcar l ,v)))))
@@ -708,6 +708,23 @@ collection clause."
(f lex-var)))))
(should (equal (f nil) 'a)))))
+(ert-deftest cl-flet/edebug ()
+ "Check that we can instrument `cl-flet' forms (bug#65344)."
+ (with-temp-buffer
+ (print '(cl-flet (;; "Obscure" form of binding supported by cl-flet
+ (x (progn (list 1 2) (lambda ())))
+ ;; Destructuring lambda-list
+ (y ((min max)) (list min max))
+ ;; Regular binding plus shadowing.
+ (z (a) a)
+ (z (a) a))
+ (y '(1 2)))
+ (current-buffer))
+ (let ((edebug-all-forms t)
+ (edebug-initial-mode 'Go-nonstop))
+ ;; Just make sure the forms can be instrumented.
+ (eval-buffer))))
+
(ert-deftest cl-macs--progv ()
(defvar cl-macs--test)
(defvar cl-macs--test1)
@@ -803,10 +820,30 @@ See Bug#57915."
(macroexpand form)
(should (string-empty-p messages))))))))
+(defvar cl--test-a)
+
(ert-deftest cl-&key-arguments ()
(cl-flet ((fn (&key x) x))
(should-error (fn :x))
- (should (eq (fn :x :a) :a))))
-
+ (should (eq (fn :x :a) :a)))
+ ;; In ELisp function arguments are always statically scoped (bug#47552).
+ (let ((cl--test-a 'dyn)
+ ;; FIXME: How do we silence the "Lexical argument shadows" warning?
+ (f
+ (with-suppressed-warnings ((lexical cl--test-a))
+ (cl-function (lambda (&key cl--test-a b)
+ (list cl--test-a (symbol-value 'cl--test-a) b))))))
+ (should (equal (funcall f :cl--test-a 'lex :b 2) '(lex dyn 2)))))
+
+(cl-defstruct cl--test-s
+ cl--test-a b)
+
+(ert-deftest cl-defstruct-dynbound-label-47552 ()
+ "Check that labels can have the same name as dynbound vars."
+ (let ((cl--test-a 'dyn))
+ (let ((x (make-cl--test-s :cl--test-a 4 :b cl--test-a)))
+ (should (cl--test-s-p x))
+ (should (equal (cl--test-s-cl--test-a x) 4))
+ (should (equal (cl--test-s-b x) 'dyn)))))
;;; cl-macs-tests.el ends here
diff --git a/test/lisp/emacs-lisp/cl-print-tests.el b/test/lisp/emacs-lisp/cl-print-tests.el
index 32f7173a8a1..c752afaaf24 100644
--- a/test/lisp/emacs-lisp/cl-print-tests.el
+++ b/test/lisp/emacs-lisp/cl-print-tests.el
@@ -25,6 +25,7 @@
;;; Code:
(require 'ert)
+(require 'cl-print)
(cl-defstruct (cl-print-tests-struct
(:constructor cl-print-tests-con))
@@ -59,18 +60,20 @@
(ert-deftest cl-print-tests-ellipsis-string ()
"Ellipsis expansion works in strings."
- (let ((print-length 4)
- (print-level 3))
+ (let ((cl-print-string-length 4))
(cl-print-tests-check-ellipsis-expansion
"abcdefg" "\"abcd...\"" "efg")
(cl-print-tests-check-ellipsis-expansion
"abcdefghijk" "\"abcd...\"" "efgh...")
- (cl-print-tests-check-ellipsis-expansion
- '(1 (2 (3 #("abcde" 0 5 (test t)))))
- "(1 (2 (3 ...)))" "#(\"abcd...\" 0 5 (test t))")
- (cl-print-tests-check-ellipsis-expansion
- #("abcd" 0 1 (bold t) 1 2 (invisible t) 3 4 (italic t))
- "#(\"abcd\" 0 1 (bold t) ...)" "1 2 (invisible t) ...")))
+ (let ((print-length 4)
+ (print-level 3))
+ (cl-print-tests-check-ellipsis-expansion
+ '(1 (2 (3 #("abcde" 0 5 (test t)))))
+ "(1 (2 (3 ...)))" "#(\"abcd...\" 0 5 (test t))"))
+ (let ((print-length 4))
+ (cl-print-tests-check-ellipsis-expansion
+ #("abcd" 0 1 (bold t) 1 2 (invisible t) 3 4 (italic t))
+ "#(\"abcd\" 0 1 (bold t) ...)" "1 2 (invisible t) ..."))))
(ert-deftest cl-print-tests-ellipsis-struct ()
"Ellipsis expansion works in structures."
@@ -90,7 +93,7 @@
(ert-deftest cl-print-tests-ellipsis-circular ()
"Ellipsis expansion works with circular objects."
(let ((wide-obj (list 0 1 2 3 4))
- (deep-obj `(0 (1 (2 (3 (4))))))
+ (deep-obj (list 0 (list 1 (list 2 (list 3 (list 4))))))
(print-length 4)
(print-level 3))
(setf (nth 4 wide-obj) wide-obj)
@@ -113,7 +116,7 @@
(should pos)
(setq value (get-text-property pos 'cl-print-ellipsis result))
(should (equal expected result))
- (should (equal expanded (with-output-to-string (cl-print-expand-ellipsis
+ (should (equal expanded (with-output-to-string (cl-print--expand-ellipsis
value nil))))))
(defun cl-print-tests-check-ellipsis-expansion-rx (obj expected expanded)
@@ -122,7 +125,7 @@
(value (get-text-property pos 'cl-print-ellipsis result)))
(should (string-match expected result))
(should (string-match expanded (with-output-to-string
- (cl-print-expand-ellipsis value nil))))))
+ (cl-print--expand-ellipsis value nil))))))
(ert-deftest cl-print-tests-print-to-string-with-limit ()
(let* ((thing10 (make-list 10 'a))
diff --git a/test/lisp/emacs-lisp/comp-cstr-tests.el b/test/lisp/emacs-lisp/comp-cstr-tests.el
index 4b1ab81a93c..b823a190d5a 100644
--- a/test/lisp/emacs-lisp/comp-cstr-tests.el
+++ b/test/lisp/emacs-lisp/comp-cstr-tests.el
@@ -29,205 +29,211 @@
(require 'cl-lib)
(require 'comp-cstr)
-(cl-eval-when (compile eval load)
-
- (defun comp-cstr-test-ts (type-spec)
- "Create a constraint from TYPE-SPEC and convert it back to type specifier."
- (let ((comp-ctxt (make-comp-cstr-ctxt)))
- (comp-cstr-to-type-spec (comp-type-spec-to-cstr type-spec))))
-
- (defun comp-cstr-typespec-test (number type-spec expected-type-spec)
- `(ert-deftest ,(intern (concat "comp-cstr-test-" (int-to-string number))) ()
- (should (equal (comp-cstr-test-ts ',type-spec)
- ',expected-type-spec))))
-
- (defconst comp-cstr-typespec-tests-alist
- `(;; 1
- (symbol . symbol)
- ;; 2
- ((or string array) . array)
- ;; 3
- ((or symbol number) . (or number symbol))
- ;; 4
- ((or cons atom) . (or atom cons)) ;; SBCL return T
- ;; 5
- ((or integer number) . number)
- ;; 6
- ((or (or integer symbol) number) . (or number symbol))
- ;; 7
- ((or (or integer symbol) (or number list)) . (or list number symbol))
- ;; 8
- ((or (or integer number) nil) . number)
- ;; 9
- ((member foo) . (member foo))
- ;; 10
- ((member foo bar) . (member bar foo))
- ;; 11
- ((or (member foo) (member bar)) . (member bar foo))
- ;; 12
- ((or (member foo) symbol) . symbol) ;; SBCL return (OR SYMBOL (MEMBER FOO))
- ;; 13
- ((or (member foo) number) . (or (member foo) number))
- ;; 14
- ((or (integer 1 3) number) . number)
- ;; 15
- (integer . integer)
- ;; 16
- ((integer 1 2) . (integer 1 2))
- ;; 17
- ((or (integer -1 0) (integer 3 4)) . (or (integer -1 0) (integer 3 4)))
- ;; 18
- ((or (integer -1 2) (integer 3 4)) . (integer -1 4))
- ;; 19
- ((or (integer -1 3) (integer 3 4)) . (integer -1 4))
- ;; 20
- ((or (integer -1 4) (integer 3 4)) . (integer -1 4))
- ;; 21
- ((or (integer -1 5) (integer 3 4)) . (integer -1 5))
- ;; 22
- ((or (integer -1 *) (integer 3 4)) . (integer -1 *))
- ;; 23
- ((or (integer -1 2) (integer * 4)) . (integer * 4))
- ;; 24
- ((and string array) . string)
- ;; 25
- ((and cons atom) . nil)
- ;; 26
- ((and (member foo) (member foo bar baz)) . (member foo))
- ;; 27
- ((and (member foo) (member bar)) . nil)
- ;; 28
- ((and (member foo) symbol) . (member foo))
- ;; 29
- ((and (member foo) string) . nil)
- ;; 30
- ((and (member foo) (integer 1 2)) . nil)
- ;; 31
- ((and (member 1 2) (member 3 2)) . (integer 2 2))
- ;; 32
- ((and number (integer 1 2)) . (integer 1 2))
- ;; 33
- ((and integer (integer 1 2)) . (integer 1 2))
- ;; 34
- ((and (integer -1 0) (integer 3 5)) . nil)
- ;; 35
- ((and (integer -1 2) (integer 3 5)) . nil)
- ;; 36
- ((and (integer -1 3) (integer 3 5)) . (integer 3 3))
- ;; 37
- ((and (integer -1 4) (integer 3 5)) . (integer 3 4))
- ;; 38
- ((and (integer -1 5) nil) . nil)
- ;; 39
- ((not symbol) . (not symbol))
- ;; 40
- ((or (member foo) (not (member foo bar))) . (not (member bar)))
- ;; 41
- ((or (member foo bar) (not (member foo))) . t)
- ;; 42
- ((or symbol (not sequence)) . (not sequence))
- ;; 43
- ((or symbol (not symbol)) . t)
- ;; 44
- ((or symbol (not sequence)) . (not sequence))
- ;; 45 Conservative.
- ((or vector (not sequence)) . t)
- ;; 46
- ((or (integer 1 10) (not (integer * 5))) . (not (integer * 0)))
- ;; 47
- ((or symbol (integer 1 10) (not (integer * 5))) . (not (integer * 0)))
- ;; 48
- ((or (not symbol) (integer 1 10) (not (integer * 5))) . (not (or symbol (integer * 0))))
- ;; 49
- ((or symbol (not (member foo))) . (not (member foo)))
- ;; 50
- ((or (not symbol) (not (member foo))) . (not symbol))
- ;; 51 Conservative.
- ((or (not (member foo)) string) . (not (member foo)))
- ;; 52 Conservative.
- ((or (member foo) (not string)) . (not string))
- ;; 53
- ((or (not (integer 1 2)) integer) . t)
- ;; 54
- ((or (not (integer 1 2)) (not integer)) . (not integer))
- ;; 55
- ((or (integer 1 2) (not integer)) . (not (or (integer * 0) (integer 3 *))))
- ;; 56
- ((or number (not (integer 1 2))) . t)
- ;; 57
- ((or atom (not (integer 1 2))) . t)
- ;; 58
- ((or atom (not (member foo))) . t)
- ;; 59
- ((and symbol (not cons)) . symbol)
- ;; 60
- ((and symbol (not symbol)) . nil)
- ;; 61
- ((and atom (not symbol)) . atom)
- ;; 62
- ((and atom (not string)) . (or array sequence atom))
- ;; 63 Conservative
- ((and symbol (not (member foo))) . symbol)
- ;; 64 Conservative
- ((and symbol (not (member 3))) . symbol)
- ;; 65
- ((and (not (member foo)) (integer 1 10)) . (integer 1 10))
- ;; 66
- ((and (member foo) (not (integer 1 10))) . (member foo))
- ;; 67
- ((and t (not (member foo))) . (not (member foo)))
- ;; 68
- ((and integer (not (integer 3 4))) . (or (integer * 2) (integer 5 *)))
- ;; 69
- ((and (integer 0 20) (not (integer 5 10))) . (or (integer 0 4) (integer 11 20)))
- ;; 70
- ((and (not (member a)) (not (member b))) . (not (member a b)))
- ;; 71
- ((and (not boolean) (not (member b))) . (not (or (member b) boolean)))
- ;; 72
- ((and t (integer 1 1)) . (integer 1 1))
- ;; 73
- ((not (integer -1 5)) . (not (integer -1 5)))
- ;; 74
- ((and boolean (or number marker)) . nil)
- ;; 75
- ((and atom (or number marker)) . (or marker number))
- ;; 76
- ((and symbol (or number marker)) . nil)
- ;; 77
- ((and (or symbol string) (or number marker)) . nil)
- ;; 78
- ((and t t) . t)
- ;; 79
- ((and (or marker number) (integer 0 0)) . (integer 0 0))
- ;; 80
- ((and t (not t)) . nil)
- ;; 81
- ((or (integer 1 1) (not (integer 1 1))) . t)
- ;; 82
- ((not t) . nil)
- ;; 83
- ((not nil) . t)
- ;; 84
- ((or (not string) t) . t)
- ;; 85
- ((or (not vector) sequence) . sequence)
- ;; 86
- ((or (not symbol) null) . t)
- ;; 87
- ((and (or null integer) (not (or null integer))) . nil)
- ;; 88
- ((and (or (member a b c)) (not (or (member a b)))) . (member c)))
- "Alist type specifier -> expected type specifier."))
-
-(defmacro comp-cstr-synthesize-tests ()
- "Generate all tests from `comp-cstr-typespec-tests-alist'."
+(defun comp-cstr-test-ts (type-spec)
+ "Create a constraint from TYPE-SPEC and convert it back to type specifier."
+ (let ((comp-ctxt (make-comp-cstr-ctxt)))
+ (comp-cstr-to-type-spec (comp-type-spec-to-cstr type-spec))))
+
+(defmacro comp-cstr-synthesize-tests (typespec-tests-alist)
+ "Generate all tests from TYPESPEC-TESTS-ALIST.
+The arg is an alist of: type specifier -> expected type specifier."
`(progn
,@(cl-loop
for i from 1
- for (ts . exp-ts) in comp-cstr-typespec-tests-alist
- append (list (comp-cstr-typespec-test i ts exp-ts)))))
-
-(comp-cstr-synthesize-tests)
+ for (type-spec . expected-type-spec) in typespec-tests-alist
+ collect
+ `(ert-deftest ,(intern (format "comp-cstr-test-%d" i)) ()
+ (should (equal (comp-cstr-test-ts ',type-spec)
+ ',expected-type-spec))))))
+
+(comp-cstr-synthesize-tests
+ (;; 1
+ (symbol . symbol)
+ ;; 2
+ ((or string array) . array)
+ ;; 3
+ ((or symbol number) . (or number symbol))
+ ;; 4
+ ((or cons atom) . t) ;; Like SBCL
+ ;; 5
+ ((or integer number) . number)
+ ;; 6
+ ((or (or integer symbol) number) . (or number symbol))
+ ;; 7
+ ((or (or integer symbol) (or number list)) . (or list number symbol))
+ ;; 8
+ ((or (or integer number) nil) . number)
+ ;; 9
+ ((member foo) . (member foo))
+ ;; 10
+ ((member foo bar) . (member bar foo))
+ ;; 11
+ ((or (member foo) (member bar)) . (member bar foo))
+ ;; 12
+ ((or (member foo) symbol) . symbol) ;; SBCL return (OR SYMBOL (MEMBER FOO))
+ ;; 13
+ ((or (member foo) number) . (or (member foo) number))
+ ;; 14
+ ((or (integer 1 3) number) . number)
+ ;; 15
+ (integer . integer)
+ ;; 16
+ ((integer 1 2) . (integer 1 2))
+ ;; 17
+ ((or (integer -1 0) (integer 3 4)) . (or (integer -1 0) (integer 3 4)))
+ ;; 18
+ ((or (integer -1 2) (integer 3 4)) . (integer -1 4))
+ ;; 19
+ ((or (integer -1 3) (integer 3 4)) . (integer -1 4))
+ ;; 20
+ ((or (integer -1 4) (integer 3 4)) . (integer -1 4))
+ ;; 21
+ ((or (integer -1 5) (integer 3 4)) . (integer -1 5))
+ ;; 22
+ ((or (integer -1 *) (integer 3 4)) . (integer -1 *))
+ ;; 23
+ ((or (integer -1 2) (integer * 4)) . (integer * 4))
+ ;; 24
+ ((and string array) . string)
+ ;; 25
+ ((and cons atom) . nil)
+ ;; 26
+ ((and (member foo) (member foo bar baz)) . (member foo))
+ ;; 27
+ ((and (member foo) (member bar)) . nil)
+ ;; 28
+ ((and (member foo) symbol) . (member foo))
+ ;; 29
+ ((and (member foo) string) . nil)
+ ;; 30
+ ((and (member foo) (integer 1 2)) . nil)
+ ;; 31
+ ((and (member 1 2) (member 3 2)) . (integer 2 2))
+ ;; 32
+ ((and number (integer 1 2)) . (integer 1 2))
+ ;; 33
+ ((and integer (integer 1 2)) . (integer 1 2))
+ ;; 34
+ ((and (integer -1 0) (integer 3 5)) . nil)
+ ;; 35
+ ((and (integer -1 2) (integer 3 5)) . nil)
+ ;; 36
+ ((and (integer -1 3) (integer 3 5)) . (integer 3 3))
+ ;; 37
+ ((and (integer -1 4) (integer 3 5)) . (integer 3 4))
+ ;; 38
+ ((and (integer -1 5) nil) . nil)
+ ;; 39
+ ((not symbol) . (not symbol))
+ ;; 40
+ ((or (member foo) (not (member foo bar))) . (not (member bar)))
+ ;; 41
+ ((or (member foo bar) (not (member foo))) . t)
+ ;; 42
+ ((or symbol (not sequence)) . (not sequence))
+ ;; 43
+ ((or symbol (not symbol)) . t)
+ ;; 44
+ ((or symbol (not sequence)) . (not sequence))
+ ;; 45 Conservative.
+ ((or vector (not sequence)) . t)
+ ;; 46
+ ((or (integer 1 10) (not (integer * 5))) . (not (integer * 0)))
+ ;; 47
+ ((or symbol (integer 1 10) (not (integer * 5))) . (not (integer * 0)))
+ ;; 48
+ ((or (not symbol) (integer 1 10) (not (integer * 5))) . (not (or symbol (integer * 0))))
+ ;; 49
+ ((or symbol (not (member foo))) . (not (member foo)))
+ ;; 50
+ ((or (not symbol) (not (member foo))) . (not symbol))
+ ;; 51 Conservative.
+ ((or (not (member foo)) string) . (not (member foo)))
+ ;; 52 Conservative.
+ ((or (member foo) (not string)) . (not string))
+ ;; 53
+ ((or (not (integer 1 2)) integer) . t)
+ ;; 54
+ ((or (not (integer 1 2)) (not integer)) . (not integer))
+ ;; 55
+ ((or (integer 1 2) (not integer)) . (not (or (integer * 0) (integer 3 *))))
+ ;; 56
+ ((or number (not (integer 1 2))) . t)
+ ;; 57
+ ((or atom (not (integer 1 2))) . t)
+ ;; 58
+ ((or atom (not (member foo))) . t)
+ ;; 59
+ ((and symbol (not cons)) . symbol)
+ ;; 60
+ ((and symbol (not symbol)) . nil)
+ ;; 61
+ ((and atom (not symbol)) . atom)
+ ;; 62 Conservative FIXME
+ ((and atom (not string)) . (or array sequence atom))
+ ;; 63 Conservative
+ ((and symbol (not (member foo))) . symbol)
+ ;; 64 Conservative
+ ((and symbol (not (member 3))) . symbol)
+ ;; 65
+ ((and (not (member foo)) (integer 1 10)) . (integer 1 10))
+ ;; 66
+ ((and (member foo) (not (integer 1 10))) . (member foo))
+ ;; 67
+ ((and t (not (member foo))) . (not (member foo)))
+ ;; 68
+ ((and integer (not (integer 3 4))) . (or (integer * 2) (integer 5 *)))
+ ;; 69
+ ((and (integer 0 20) (not (integer 5 10))) . (or (integer 0 4) (integer 11 20)))
+ ;; 70
+ ((and (not (member a)) (not (member b))) . (not (member a b)))
+ ;; 71
+ ((and (not boolean) (not (member b))) . (not (or (member b) boolean)))
+ ;; 72
+ ((and t (integer 1 1)) . (integer 1 1))
+ ;; 73
+ ((not (integer -1 5)) . (not (integer -1 5)))
+ ;; 74
+ ((and boolean (or number marker)) . nil)
+ ;; 75
+ ((and atom (or number marker)) . number-or-marker)
+ ;; 76
+ ((and symbol (or number marker)) . nil)
+ ;; 77
+ ((and (or symbol string) (or number marker)) . nil)
+ ;; 78
+ ((and t t) . t)
+ ;; 79
+ ((and (or marker number) (integer 0 0)) . (integer 0 0))
+ ;; 80
+ ((and t (not t)) . nil)
+ ;; 81
+ ((or (integer 1 1) (not (integer 1 1))) . t)
+ ;; 82
+ ((not t) . nil)
+ ;; 83
+ ((not nil) . t)
+ ;; 84
+ ((or (not string) t) . t)
+ ;; 85
+ ((or (not vector) sequence) . sequence)
+ ;; 86
+ ((or (not symbol) null) . t)
+ ;; 87
+ ((and (or null integer) (not (or null integer))) . nil)
+ ;; 88
+ ((and (or (member a b c)) (not (or (member a b)))) . (member c))
+ ;; 89
+ ((or cons symbol) . (or list symbol)) ;; FIXME: Why `list'?
+ ;; 90
+ ((or string char-table bool-vector vector) . array)
+ ;; 91
+ ((or string char-table bool-vector vector number) . (or array number))
+ ;; 92
+ ((or string char-table bool-vector vector cons symbol number) .
+ (or number sequence symbol))
+ ;; 93
+ ((or list (not null)) . t)
+ ))
;;; comp-cstr-tests.el ends here
diff --git a/test/lisp/emacs-lisp/edebug-tests.el b/test/lisp/emacs-lisp/edebug-tests.el
index 8f1ab32c562..29adbcff947 100644
--- a/test/lisp/emacs-lisp/edebug-tests.el
+++ b/test/lisp/emacs-lisp/edebug-tests.el
@@ -116,6 +116,7 @@ back to the top level.")
(with-current-buffer (find-file edebug-tests-temp-file)
(read-only-mode)
(setq lexical-binding t)
+ (syntax-ppss)
(eval-buffer)
,@body
(when edebug-tests-failure-in-post-command
@@ -859,8 +860,7 @@ test and possibly others should be updated."
(let ((inhibit-read-only t))
(delete-region (point-min) (point-max))
(insert "`1"))
- (with-suppressed-warnings ((obsolete edebug-eval-defun))
- (edebug-eval-defun nil))
+ (eval-defun nil)
;; `eval-defun' outputs its message to the echo area in a rather
;; funny way, so the "1" and the " (#o1, #x1, ?\C-a)" end up placed
;; there in separate pieces (via `print' rather than via `message').
@@ -870,18 +870,21 @@ test and possibly others should be updated."
(setq edebug-initial-mode 'go)
;; In Bug#23651 Edebug would hang reading `1.
- (with-suppressed-warnings ((obsolete edebug-eval-defun))
- (edebug-eval-defun t))))
+ (eval-defun t)
+ (should (string-match-p (regexp-quote " (#o1, #x1, ?\\C-a)")
+ edebug-tests-messages))))
(ert-deftest edebug-tests-trivial-comma ()
"Edebug can read a trivial comma expression (Bug#23651)."
(edebug-tests-with-normal-env
- (read-only-mode -1)
- (delete-region (point-min) (point-max))
- (insert ",1")
- (read-only-mode)
- (with-suppressed-warnings ((obsolete edebug-eval-defun))
- (should-error (edebug-eval-defun t)))))
+ (let ((inhibit-read-only t))
+ (delete-region (point-min) (point-max))
+ (insert ",1"))
+ ;; FIXME: This currently signals a "Source has changed" error, which is
+ ;; itself a bug (the source hasn't changed). All we're testing here
+ ;; is that the Edebug gets past the step of reading the sexp.
+ (should-error (let ((eval-expression-debug-on-error nil))
+ (eval-defun t)))))
(ert-deftest edebug-tests-circular-read-syntax ()
"Edebug can instrument code using circular read object syntax (Bug#23660)."
diff --git a/test/lisp/emacs-lisp/eieio-tests/eieio-test-methodinvoke.el b/test/lisp/emacs-lisp/eieio-tests/eieio-test-methodinvoke.el
index b244a56779a..fb2c6ea3b68 100644
--- a/test/lisp/emacs-lisp/eieio-tests/eieio-test-methodinvoke.el
+++ b/test/lisp/emacs-lisp/eieio-tests/eieio-test-methodinvoke.el
@@ -259,7 +259,7 @@
(ans '(
(:PRIMARY D)
(:PRIMARY D-base1)
- ;; (:PRIMARY D-base2)
+ (:PRIMARY D-base2)
(:PRIMARY D-base0)
)))
(eitest-F (D nil))
diff --git a/test/lisp/emacs-lisp/eieio-tests/eieio-test-persist.el b/test/lisp/emacs-lisp/eieio-tests/eieio-test-persist.el
index ef34c590164..1bb75ae81f8 100644
--- a/test/lisp/emacs-lisp/eieio-tests/eieio-test-persist.el
+++ b/test/lisp/emacs-lisp/eieio-tests/eieio-test-persist.el
@@ -40,7 +40,7 @@ This is usually a symbol that starts with `:'."
(car tuple)
nil)))
-(defun hash-equal (hash1 hash2)
+(defun eieio-test--hash-equal (hash1 hash2)
"Compare two hash tables to see whether they are equal."
(and (= (hash-table-count hash1)
(hash-table-count hash2))
@@ -78,7 +78,7 @@ This is usually a symbol that starts with `:'."
(if initarg-p
(unless
(cond ((and (hash-table-p origvalue) (hash-table-p fromdiskvalue))
- (hash-equal origvalue fromdiskvalue))
+ (eieio-test--hash-equal origvalue fromdiskvalue))
(t (equal origvalue fromdiskvalue)))
(error "Slot %S Original Val %S != Persistent Val %S"
oneslot origvalue fromdiskvalue))
@@ -87,7 +87,7 @@ This is usually a symbol that starts with `:'."
(diskval fromdiskvalue))
(unless
(cond ((and (hash-table-p origval) (hash-table-p diskval))
- (hash-equal origval diskval))
+ (eieio-test--hash-equal origval diskval))
(t (equal origval diskval)))
(error "Slot %S Persistent Val %S != Default Value %S"
oneslot diskval origvalue))))))))
@@ -329,8 +329,8 @@ persistent class.")
"container-" emacs-version ".eieio")))
(john (make-instance 'person :name "John"))
(alexie (make-instance 'person :name "Alexie"))
- (alst '(("first" (one two three))
- ("second" (four five six)))))
+ (alst (list (list "first" (list 'one 'two 'three))
+ (list "second" (list 'four 'five 'six)))))
(setf (slot-value thing 'alist) alst)
(puthash "alst" alst (slot-value thing 'htab))
(aset (slot-value thing 'vec) 0 alst)
diff --git a/test/lisp/emacs-lisp/eieio-tests/eieio-tests.el b/test/lisp/emacs-lisp/eieio-tests/eieio-tests.el
index 9fd0622c359..bc226757ff2 100644
--- a/test/lisp/emacs-lisp/eieio-tests/eieio-tests.el
+++ b/test/lisp/emacs-lisp/eieio-tests/eieio-tests.el
@@ -1011,24 +1011,24 @@ Subclasses to override slot attributes."))
(B (clone A :b "bb"))
(C (clone B :a "aa")))
- (should (string= "aa" (oref C :a)))
- (should (string= "bb" (oref C :b)))
+ (should (string= "aa" (oref C a)))
+ (should (string= "bb" (oref C b)))
- (should (slot-boundp A :a))
- (should-not (slot-boundp A :b))
- (should-not (slot-boundp A :c))
+ (should (slot-boundp A 'a))
+ (should-not (slot-boundp A 'b))
+ (should-not (slot-boundp A 'c))
- (should-not (slot-boundp B :a))
- (should (slot-boundp B :b))
- (should-not (slot-boundp A :c))
+ (should-not (slot-boundp B 'a))
+ (should (slot-boundp B 'b))
+ (should-not (slot-boundp A 'c))
- (should (slot-boundp C :a))
- (should-not (slot-boundp C :b))
- (should-not (slot-boundp C :c))
+ (should (slot-boundp C 'a))
+ (should-not (slot-boundp C 'b))
+ (should-not (slot-boundp C 'c))
- (should (eieio-instance-inheritor-slot-boundp C :a))
- (should (eieio-instance-inheritor-slot-boundp C :b))
- (should-not (eieio-instance-inheritor-slot-boundp C :c))))
+ (should (eieio-instance-inheritor-slot-boundp C 'a))
+ (should (eieio-instance-inheritor-slot-boundp C 'b))
+ (should-not (eieio-instance-inheritor-slot-boundp C 'c))))
;;;; Interaction with defstruct
@@ -1046,6 +1046,27 @@ Subclasses to override slot attributes."))
(should (eq (eieio-test--struct-a x) 1))
(should-error (setf (slot-value x 'c) 3) :type 'eieio-read-only)))
+(defclass foo-bug-66938 (eieio-instance-inheritor)
+ ((x :initarg :x
+ :accessor ref-x
+ :reader get-x))
+ "A class to test that delegation occurs under certain
+circumstances when using an accessor function, as it would when
+using the reader function.")
+
+(ert-deftest eieio-test-use-accessor-function-with-cloned-object ()
+ "The class FOO-BUG-66938 is a subclass of
+`eieio-instance-inheritor'. Therefore, given an instance OBJ1 of
+FOO-BUG-66938, and a clone (OBJ2), OBJ2 should delegate to OBJ1
+when accessing an unbound slot.
+
+In particular, its behavior should be identical to that of the
+reader function, when reading a slot."
+ (let* ((obj1 (foo-bug-66938 :x 4))
+ (obj2 (clone obj1)))
+ (should (eql (ref-x obj2) 4))
+ (should (eql (get-x obj2) (ref-x obj2)))))
+
(provide 'eieio-tests)
;;; eieio-tests.el ends here
diff --git a/test/lisp/emacs-lisp/ert-font-lock-resources/broken.js b/test/lisp/emacs-lisp/ert-font-lock-resources/broken.js
new file mode 100644
index 00000000000..69c1c5cca88
--- /dev/null
+++ b/test/lisp/emacs-lisp/ert-font-lock-resources/broken.js
@@ -0,0 +1,3 @@
+var abc = function(d) {
+// ^ wrong-face
+};
diff --git a/test/lisp/emacs-lisp/ert-font-lock-resources/correct.js b/test/lisp/emacs-lisp/ert-font-lock-resources/correct.js
new file mode 100644
index 00000000000..5e614c64755
--- /dev/null
+++ b/test/lisp/emacs-lisp/ert-font-lock-resources/correct.js
@@ -0,0 +1,3 @@
+var abc = function(d) {
+// ^ font-lock-variable-name-face
+};
diff --git a/test/lisp/emacs-lisp/ert-font-lock-resources/no-asserts.js b/test/lisp/emacs-lisp/ert-font-lock-resources/no-asserts.js
new file mode 100644
index 00000000000..5eae9af212f
--- /dev/null
+++ b/test/lisp/emacs-lisp/ert-font-lock-resources/no-asserts.js
@@ -0,0 +1,2 @@
+var abc = function(d) {
+};
diff --git a/test/lisp/emacs-lisp/ert-font-lock-tests.el b/test/lisp/emacs-lisp/ert-font-lock-tests.el
new file mode 100644
index 00000000000..fa2e5dc4db7
--- /dev/null
+++ b/test/lisp/emacs-lisp/ert-font-lock-tests.el
@@ -0,0 +1,567 @@
+;;; ert-font-lock-tests.el --- ERT Font Lock tests -*- lexical-binding: t -*-
+
+;; Copyright (C) 2023-2024 Free Software Foundation, Inc.
+
+;; Author: Vladimir Kazanov
+
+;; This file is part of GNU Emacs.
+
+;; GNU Emacs is free software: you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+
+;; GNU Emacs is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>.
+
+;;; Commentary:
+
+;; This file is part of ERT Font Lock, an extension to the Emacs Lisp
+;; Regression Test library (ERT) providing a convenient way to check
+;; syntax highlighting provided by font-lock.
+;;
+;; See ert-font-lock.el for details, and below for example usage of
+;; ert-font-lock facilities.
+
+(require 'ert)
+(require 'ert-x)
+(require 'ert-font-lock)
+
+;;; Helpers
+;;
+
+(defmacro with-temp-buffer-str-mode (mode str &rest body)
+ "Create a buffer with STR contents and MODE. "
+ (declare (indent 1) (debug t))
+ `(with-temp-buffer
+ (insert ,str)
+ (,mode)
+ (goto-char (point-min))
+ ,@body))
+
+;;; Comment parsing tests
+;;
+
+(ert-deftest test-line-comment-p--fundamental ()
+ (with-temp-buffer-str-mode fundamental-mode
+ "// comment\n"
+ (should-not (ert-font-lock--line-comment-p))))
+
+(ert-deftest test-line-comment-p--emacs-lisp ()
+ (with-temp-buffer-str-mode emacs-lisp-mode
+ "not comment
+;; comment
+"
+ (should-not (ert-font-lock--line-comment-p))
+ (forward-line)
+ (should (ert-font-lock--line-comment-p))
+ (forward-line)
+ (should-not (ert-font-lock--line-comment-p))))
+
+(ert-deftest test-line-comment-p--shell-script ()
+ (with-temp-buffer-str-mode shell-script-mode
+ "echo Not a comment
+# comment
+"
+ (should-not (ert-font-lock--line-comment-p))
+ (forward-line)
+ (should (ert-font-lock--line-comment-p))))
+
+(declare-function php-mode "php-mode")
+(ert-deftest test-line-comment-p--php ()
+ (skip-unless (featurep 'php-mode))
+
+ (with-temp-buffer-str-mode php-mode
+ "echo 'Not a comment'
+// comment
+/* comment */
+"
+ (should-not (ert-font-lock--line-comment-p))
+ (forward-line)
+ (should (ert-font-lock--line-comment-p))
+ (forward-line)
+ (should (ert-font-lock--line-comment-p))))
+
+
+(ert-deftest test-line-comment-p--javascript ()
+ (with-temp-buffer-str-mode javascript-mode
+ "// comment
+
+ // comment, after a blank line
+
+var abc = function(d) {};
+"
+ (should (ert-font-lock--line-comment-p))
+
+ (forward-line)
+ (should-not (ert-font-lock--line-comment-p))
+
+ (forward-line)
+ (should (ert-font-lock--line-comment-p))
+
+ (forward-line)
+ (should-not (ert-font-lock--line-comment-p))
+
+ (forward-line)
+ (should-not (ert-font-lock--line-comment-p))))
+
+(ert-deftest test-line-comment-p--python ()
+
+ (with-temp-buffer-str-mode python-mode
+ "# comment
+
+ # comment
+print(\"Hello, world!\")"
+ (should (ert-font-lock--line-comment-p))
+
+ (forward-line)
+ (should-not (ert-font-lock--line-comment-p))
+
+ (forward-line)
+ (should (ert-font-lock--line-comment-p))
+
+ (forward-line)
+ (should-not (ert-font-lock--line-comment-p))))
+
+(ert-deftest test-line-comment-p--c ()
+
+ (with-temp-buffer-str-mode c-mode
+ "// comment
+/* also comment */"
+ (should (ert-font-lock--line-comment-p))
+
+ (forward-line)
+ (should (ert-font-lock--line-comment-p))))
+
+(ert-deftest test-parse-comments--no-assertion-error ()
+ (let* ((str "
+not_an_assertion
+random_symbol
+"))
+ (with-temp-buffer
+ (insert str)
+ (javascript-mode)
+
+ (should-error (ert-font-lock--parse-comments) :type 'user-error))))
+
+(ert-deftest test-parse-comments--single-line-error ()
+ (let* ((str "// ^ face.face1"))
+ (with-temp-buffer
+ (insert str)
+ (javascript-mode)
+
+ (should-error (ert-font-lock--parse-comments) :type 'user-error))))
+
+(ert-deftest test-parse-comments--single-line-single-caret ()
+ (let* ((str "
+first
+// ^ face.face1
+")
+ asserts)
+ (with-temp-buffer
+ (insert str)
+ (javascript-mode)
+
+ (setq asserts (ert-font-lock--parse-comments))
+ (should (eql (length asserts) 1))
+ (should (equal (car asserts)
+ '(:line-checked 2 :line-assert 3 :column-checked 3 :face face.face1 :negation nil))))))
+
+(ert-deftest test-parse-comments--single-line-many-carets ()
+ (let* ((str "
+multiplecarets
+//^^^ ^^ ^ face.face1
+")
+ asserts)
+ (with-temp-buffer
+ (insert str)
+ (javascript-mode)
+
+ (setq asserts (ert-font-lock--parse-comments))
+ (should (eql (length asserts) 6))
+ (should (equal asserts
+ '((:line-checked 2 :line-assert 3 :column-checked 2 :face face.face1 :negation nil)
+ (:line-checked 2 :line-assert 3 :column-checked 3 :face face.face1 :negation nil)
+ (:line-checked 2 :line-assert 3 :column-checked 4 :face face.face1 :negation nil)
+ (:line-checked 2 :line-assert 3 :column-checked 6 :face face.face1 :negation nil)
+ (:line-checked 2 :line-assert 3 :column-checked 7 :face face.face1 :negation nil)
+ (:line-checked 2 :line-assert 3 :column-checked 9 :face face.face1 :negation nil)))))))
+
+(ert-deftest test-parse-comments--face-list ()
+ (let* ((str "
+facelist
+// ^ (face1 face2)
+// ^ !(face3 face4)
+// ^ (face5)
+")
+ asserts)
+ (with-temp-buffer
+ (insert str)
+ (javascript-mode)
+
+ (setq asserts (ert-font-lock--parse-comments))
+ (should (eql (length asserts) 3))
+ (should (equal asserts
+ '((:line-checked 2 :line-assert 3 :column-checked 3 :face (face1 face2) :negation nil)
+ (:line-checked 2 :line-assert 4 :column-checked 3 :face (face3 face4) :negation t)
+ (:line-checked 2 :line-assert 5 :column-checked 3 :face (face5) :negation nil)))))))
+
+(ert-deftest test-parse-comments--caret-negation ()
+ (let* ((str "
+first
+// ^ !face
+// ^ face
+")
+ asserts)
+ (with-temp-buffer
+ (insert str)
+ (javascript-mode)
+
+ (setq asserts (ert-font-lock--parse-comments))
+ (should (eql (length asserts) 2))
+ (should (equal asserts
+ '((:line-checked 2 :line-assert 3 :column-checked 3 :face face :negation t)
+ (:line-checked 2 :line-assert 4 :column-checked 3 :face face :negation nil)))))))
+
+
+(ert-deftest test-parse-comments--single-line-multiple-assert-lines ()
+ (let* ((str "
+first
+// ^ face1
+// ^ face.face2
+// ^ face-face.face3
+ // ^ face_face.face4
+")
+ asserts)
+
+ (with-temp-buffer
+ (insert str)
+ (javascript-mode)
+
+ (setq asserts (ert-font-lock--parse-comments))
+ (should (eql (length asserts) 4))
+ (should (equal asserts
+ '((:line-checked 2 :line-assert 3 :column-checked 3 :face face1 :negation nil)
+ (:line-checked 2 :line-assert 4 :column-checked 7 :face face.face2 :negation nil)
+ (:line-checked 2 :line-assert 5 :column-checked 7 :face face-face.face3 :negation nil)
+ (:line-checked 2 :line-assert 6 :column-checked 7 :face face_face.face4 :negation nil)))))))
+
+(ert-deftest test-parse-comments--multiple-line-multiple-assert-lines ()
+ (let* ((str "
+first
+// ^ face1
+second
+// ^ face2
+// ^ face3
+third
+")
+ asserts)
+ (with-temp-buffer
+ (insert str)
+ (javascript-mode)
+
+ (setq asserts (ert-font-lock--parse-comments))
+ (should (eql (length asserts) 3))
+ (should (equal asserts
+ '((:line-checked 2 :line-assert 3 :column-checked 3 :face face1 :negation nil)
+ (:line-checked 4 :line-assert 5 :column-checked 3 :face face2 :negation nil)
+ (:line-checked 4 :line-assert 6 :column-checked 5 :face face3 :negation nil)))))))
+
+
+(ert-deftest test-parse-comments--arrow-single-line-single ()
+ (let* ((str "
+first
+// <- face1
+")
+ asserts)
+ (with-temp-buffer
+ (insert str)
+ (javascript-mode)
+
+ (setq asserts (ert-font-lock--parse-comments))
+ (should (eql (length asserts) 1))
+ (should (equal (car asserts)
+ '(:line-checked 2 :line-assert 3 :column-checked 0 :face face1 :negation nil))))))
+
+
+(ert-deftest test-parse-comments-arrow-multiple-line-single ()
+ (let* ((str "
+first
+// <- face1
+ // <- face2
+ // <- face3
+")
+ asserts)
+ (with-temp-buffer
+ (insert str)
+ (javascript-mode)
+
+ (setq asserts (ert-font-lock--parse-comments))
+ (should (eql (length asserts) 3))
+ (should (equal asserts
+ '((:line-checked 2 :line-assert 3 :column-checked 0 :face face1 :negation nil)
+ (:line-checked 2 :line-assert 4 :column-checked 2 :face face2 :negation nil)
+ (:line-checked 2 :line-assert 5 :column-checked 4 :face face3 :negation nil)))))))
+
+(ert-deftest test-parse-comments--non-assert-comment-single ()
+ (let* ((str "
+// first
+// ^ comment-face
+")
+ asserts)
+ (with-temp-buffer
+ (insert str)
+ (javascript-mode)
+
+ (setq asserts (ert-font-lock--parse-comments))
+ (should (eql (length asserts) 1))
+ (should (equal (car asserts)
+ '(:line-checked 2 :line-assert 3 :column-checked 4 :face comment-face :negation nil))))))
+
+(ert-deftest test-parse-comments--non-assert-comment-multiple ()
+ (let* ((str "
+// first second third
+// ^ comment-face
+// ^ comment-face
+// ^ comment-face
+")
+ asserts)
+ (with-temp-buffer
+ (insert str)
+ (javascript-mode)
+
+ (setq asserts (ert-font-lock--parse-comments))
+ (should (eql (length asserts) 3))
+ (should (equal asserts
+ '((:line-checked 2 :line-assert 3 :column-checked 4 :face comment-face :negation nil)
+ (:line-checked 2 :line-assert 4 :column-checked 10 :face comment-face :negation nil)
+ (:line-checked 2 :line-assert 5 :column-checked 18 :face comment-face :negation nil)))))))
+
+
+(ert-deftest test-parse-comments--multiline-comment-single ()
+ (let* ((str "
+/*
+ this is a comment
+ ^ comment-face
+ */
+")
+ asserts)
+ (with-temp-buffer
+ (insert str)
+ (c-mode)
+
+ (setq asserts (ert-font-lock--parse-comments))
+ (should (eql (length asserts) 1))
+ (should (equal (car asserts)
+ '(:line-checked 3 :line-assert 4 :column-checked 3 :face comment-face :negation nil))))))
+
+(ert-deftest test-parse-comments--multiline-comment-multiple ()
+ (let* ((str "
+/*
+ this is a comment
+ ^ comment-face
+ another comment
+ ^ comment-face
+ */
+")
+ asserts)
+ (with-temp-buffer
+ (insert str)
+ (c-mode)
+
+ (setq asserts (ert-font-lock--parse-comments))
+ (should (eql (length asserts) 2))
+ (should (equal asserts
+ '((:line-checked 3 :line-assert 4 :column-checked 3 :face comment-face :negation nil)
+ (:line-checked 5 :line-assert 6 :column-checked 4 :face comment-face :negation nil)))))))
+
+;;; Syntax highlighting assertion tests
+;;
+
+(ert-deftest test-syntax-highlight-inline--nil-list ()
+ (let ((str "
+var abc = function(d) {
+// ^ nil
+// ^ !nil
+};
+
+"))
+ (with-temp-buffer
+ (insert str)
+ (javascript-mode)
+ (font-lock-ensure)
+
+ (ert-font-lock--check-faces
+ (ert-font-lock--parse-comments)))))
+
+(ert-deftest test-syntax-highlight-inline--face-list ()
+ (let ((str "
+var abc = function(d) {
+// ^ (test-face-2 test-face-1 font-lock-variable-name-face)
+};
+
+"))
+ (with-temp-buffer
+ (insert str)
+ (javascript-mode)
+ (font-lock-ensure)
+
+ (add-face-text-property (point-min) (point-max) 'test-face-1)
+ (add-face-text-property (point-min) (point-max) 'test-face-2)
+
+ (ert-font-lock--check-faces
+ (ert-font-lock--parse-comments)))))
+
+(ert-deftest test-syntax-highlight-inline--caret-multiple-assertions ()
+ (let ((str "
+var abc = function(d) {
+// ^ font-lock-variable-name-face
+ // ^ font-lock-keyword-face
+ // ^ font-lock-variable-name-face
+};
+
+"))
+ (with-temp-buffer
+ (insert str)
+ (javascript-mode)
+ (font-lock-ensure)
+
+ (ert-font-lock--check-faces
+ (ert-font-lock--parse-comments)))))
+
+(ert-deftest test-syntax-highlight-inline--caret-wrong-face ()
+ (let* ((str "
+var abc = function(d) {
+// ^ not-a-face
+};
+"))
+ (with-temp-buffer
+ (insert str)
+ (javascript-mode)
+ (font-lock-ensure)
+
+ (should-error (ert-font-lock--check-faces
+ (ert-font-lock--parse-comments))))))
+
+(ert-deftest test-syntax-highlight-inline--caret-negated-wrong-face ()
+ (let* ((str "
+var abc = function(d) {
+// ^ !not-a-face
+};
+"))
+ (with-temp-buffer
+ (insert str)
+ (javascript-mode)
+ (font-lock-ensure)
+
+ (ert-font-lock--check-faces
+ (ert-font-lock--parse-comments)))))
+
+(ert-deftest test-syntax-highlight-inline--comment-face ()
+ (let* ((str "
+// this is a comment
+// ^ font-lock-comment-face
+// ^ font-lock-comment-face
+// ^ font-lock-comment-face
+"))
+ (with-temp-buffer
+ (insert str)
+ (javascript-mode)
+ (font-lock-ensure)
+
+ (ert-font-lock--check-faces
+ (ert-font-lock--parse-comments)))))
+
+
+(ert-deftest test-syntax-highlight-inline--multiline-comment-face ()
+ (let* ((str "
+/*
+ this is a comment
+ ^ font-lock-comment-face
+ another comment
+ more comments
+ ^ font-lock-comment-face
+ */
+"))
+ (with-temp-buffer
+ (insert str)
+ (c-mode)
+ (font-lock-ensure)
+
+ (ert-font-lock--check-faces
+ (ert-font-lock--parse-comments)))))
+
+
+(ert-deftest test-font-lock-test-string--correct ()
+ (ert-font-lock-test-string
+ "
+var abc = function(d) {
+// <- font-lock-keyword-face
+// ^ font-lock-variable-name-face
+ // ^ font-lock-keyword-face
+ // ^ font-lock-variable-name-face
+};
+
+"
+ 'javascript-mode))
+
+(ert-deftest test-font-lock-test-file--correct ()
+ (ert-font-lock-test-file
+ (ert-resource-file "correct.js")
+ 'javascript-mode))
+
+(ert-deftest test-font-lock-test-file--wrong ()
+ :expected-result :failed
+ (ert-font-lock-test-file
+ (ert-resource-file "broken.js")
+ 'javascript-mode))
+
+;;; Macro tests
+;;
+
+(ert-font-lock-deftest test-macro-test--correct-highlighting
+ emacs-lisp-mode
+ "
+(defun fun ())
+;; ^ font-lock-keyword-face
+;; ^ font-lock-function-name-face")
+
+(ert-font-lock-deftest test-macro-test--docstring
+ "A test with a docstring."
+ emacs-lisp-mode
+ "
+(defun fun ())
+;; ^ font-lock-keyword-face"
+ )
+
+(ert-font-lock-deftest test-macro-test--failing
+ "A failing test."
+ :expected-result :failed
+ emacs-lisp-mode
+ "
+(defun fun ())
+;; ^ wrong-face")
+
+(ert-font-lock-deftest-file test-macro-test--file
+ "Test reading correct assertions from a file"
+ javascript-mode
+ "correct.js")
+
+(ert-font-lock-deftest-file test-macro-test--file-no-asserts
+ "Check failing on files without assertions"
+ :expected-result :failed
+ javascript-mode
+ "no-asserts.js")
+
+(ert-font-lock-deftest-file test-macro-test--file-failing
+ "Test reading wrong assertions from a file"
+ :expected-result :failed
+ javascript-mode
+ "broken.js")
+
+;;; ert-font-lock-tests.el ends here
diff --git a/test/lisp/emacs-lisp/ert-tests.el b/test/lisp/emacs-lisp/ert-tests.el
index 5245d923833..1aff73d66f6 100644
--- a/test/lisp/emacs-lisp/ert-tests.el
+++ b/test/lisp/emacs-lisp/ert-tests.el
@@ -1,6 +1,6 @@
;;; ert-tests.el --- ERT's self-tests -*- lexical-binding: t -*-
-;; Copyright (C) 2007-2008, 2010-2024 Free Software Foundation, Inc.
+;; Copyright (C) 2007-2024 Free Software Foundation, Inc.
;; Author: Christian Ohler <ohler@gnu.org>
@@ -93,16 +93,6 @@ failed or if there was a problem."
'(ert-test-failed "failure message"))
t))))
-(ert-deftest ert-test-fail-debug-with-condition-case ()
- (let ((test (make-ert-test :body (lambda () (ert-fail "failure message")))))
- (condition-case condition
- (progn
- (let ((ert-debug-on-error t))
- (ert-run-test test))
- (cl-assert nil))
- ((error)
- (cl-assert (equal condition '(ert-test-failed "failure message")) t)))))
-
(ert-deftest ert-test-fail-debug-with-debugger-1 ()
(let ((test (make-ert-test :body (lambda () (ert-fail "failure message")))))
(let ((debugger (lambda (&rest _args)
@@ -146,16 +136,6 @@ failed or if there was a problem."
'(error "Error message"))
t))))
-(ert-deftest ert-test-error-debug ()
- (let ((test (make-ert-test :body (lambda () (error "Error message")))))
- (condition-case condition
- (progn
- (let ((ert-debug-on-error t))
- (ert-run-test test))
- (cl-assert nil))
- ((error)
- (cl-assert (equal condition '(error "Error message")) t)))))
-
;;; Test that `should' works.
(ert-deftest ert-test-should ()
@@ -304,6 +284,20 @@ failed or if there was a problem."
(cl-macrolet ((test () (error "Foo")))
(should-error (test))))
+(ert-deftest ert-test-skip-when ()
+ ;; Don't skip.
+ (let ((test (make-ert-test :body (lambda () (skip-when nil)))))
+ (let ((result (ert-run-test test)))
+ (should (ert-test-passed-p result))))
+ ;; Skip.
+ (let ((test (make-ert-test :body (lambda () (skip-when t)))))
+ (let ((result (ert-run-test test)))
+ (should (ert-test-skipped-p result))))
+ ;; Skip in case of error.
+ (let ((test (make-ert-test :body (lambda () (skip-when (error "Foo"))))))
+ (let ((result (ert-run-test test)))
+ (should (ert-test-skipped-p result)))))
+
(ert-deftest ert-test-skip-unless ()
;; Don't skip.
(let ((test (make-ert-test :body (lambda () (skip-unless t)))))
@@ -345,14 +339,10 @@ This macro is used to test if macroexpansion in `should' works."
(,(lambda () (let ((_x t)) (should (error "Foo"))))
(error "Foo")))
do
- (let ((test (make-ert-test :body body)))
- (condition-case actual-condition
- (progn
- (let ((ert-debug-on-error t))
- (ert-run-test test))
- (cl-assert nil))
- ((error)
- (should (equal actual-condition expected-condition)))))))
+ (let* ((test (make-ert-test :body body))
+ (result (ert-run-test test)))
+ (should (ert-test-failed-p result))
+ (should (equal (ert-test-failed-condition result) expected-condition)))))
(defun ert-test--which-file ()
"Dummy function to help test `symbol-file' for tests.")
@@ -378,9 +368,9 @@ This macro is used to test if macroexpansion in `should' works."
(result (ert-run-test test)))
(should (ert-test-failed-p result))
(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).
+ ;; 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 ()
@@ -577,13 +567,12 @@ This macro is used to test if macroexpansion in `should' works."
(lambda (format-string &rest args)
(push (apply #'format format-string args) messages))))
(save-window-excursion
- (unwind-protect
- (let ((case-fold-search nil)
- (ert-batch-backtrace-right-margin nil)
- (ert-batch-print-level 10)
- (ert-batch-print-length 11))
- (ert-run-tests-batch
- `(member ,failing-test-1 ,failing-test-2))))))
+ (let ((case-fold-search nil)
+ (ert-batch-backtrace-right-margin nil)
+ (ert-batch-print-level 10)
+ (ert-batch-print-length 11))
+ (ert-run-tests-batch
+ `(member ,failing-test-1 ,failing-test-2)))))
(let ((long-text "(different-types[ \t\n]+(1 1 1 1 1 1 1 1 1 1 1)[ \t\n]+1)))[ \t\n]*$")
(complex-text "(different-types[ \t\n]+((:1[ \t\n]+(:2[ \t\n]+(:3[ \t\n]+(:4[ \t\n]+(:5[ \t\n]+(:6[ \t\n]+\"abc\")))))))[ \t\n]+1)))[ \t\n]*$")
found-long
@@ -609,14 +598,13 @@ This macro is used to test if macroexpansion in `should' works."
(lambda (format-string &rest args)
(push (apply #'format format-string args) messages))))
(save-window-excursion
- (unwind-protect
- (let ((case-fold-search nil)
- (ert-batch-backtrace-right-margin nil)
- (ert-batch-backtrace-line-length nil)
- (ert-batch-print-level 6)
- (ert-batch-print-length 11))
- (ert-run-tests-batch
- `(member ,failing-test-1))))))
+ (let ((case-fold-search nil)
+ (ert-batch-backtrace-right-margin nil)
+ (ert-batch-backtrace-line-length nil)
+ (ert-batch-print-level 6)
+ (ert-batch-print-length 11))
+ (ert-run-tests-batch
+ `(member ,failing-test-1)))))
(let ((frame "ert-fail(((should (equal complex-list 1)) :form (equal ((:1 (:2 (:3 (:4 (:5 (:6 \"abc\"))))))) 1) :value nil :explanation (different-types ((:1 (:2 (:3 (:4 (:5 (:6 \"abc\"))))))) 1)))")
found-frame)
(cl-loop for msg in (reverse messages)
@@ -868,7 +856,6 @@ This macro is used to test if macroexpansion in `should' works."
(ert-deftest ert-test-with-demoted-errors ()
"Check that ERT correctly handles `with-demoted-errors'."
- :expected-result :failed ;; FIXME! Bug#11218
(should-not (with-demoted-errors "FOO: %S" (error "Foo"))))
(ert-deftest ert-test-fail-inside-should ()
diff --git a/test/lisp/emacs-lisp/find-func-tests.el b/test/lisp/emacs-lisp/find-func-tests.el
index 49a0ff2ea8b..a685a6cbabb 100644
--- a/test/lisp/emacs-lisp/find-func-tests.el
+++ b/test/lisp/emacs-lisp/find-func-tests.el
@@ -32,7 +32,7 @@
(ert-deftest find-func-tests--library-completion () ;bug#43393
;; FIXME: How can we make this work in batch (see also
;; `mule-cmds--test-universal-coding-system-argument')?
- ;; (skip-unless (not noninteractive))
+ ;; (skip-when noninteractive)
;; Check that `partial-completion' works when completing library names.
(should (equal "org/org"
(ert-simulate-keys
diff --git a/test/lisp/emacs-lisp/hierarchy-tests.el b/test/lisp/emacs-lisp/hierarchy-tests.el
index 97a0f7ba52c..3333f4014e6 100644
--- a/test/lisp/emacs-lisp/hierarchy-tests.el
+++ b/test/lisp/emacs-lisp/hierarchy-tests.el
@@ -570,8 +570,9 @@ should fail as this function will crash."
(defun hierarchy-examples-delayed--childrenfn (hier-elem)
"Return the children of HIER-ELEM.
-Basially, feed the number, minus 1, to `hierarchy-examples-delayed--find-number'
-and then create a list of the number plus 0.0–0.9."
+Basically, feed the number, minus 1, to
+`hierarchy-examples-delayed--find-number' and then create a list of the
+number plus 0.0–0.9."
(when (> hier-elem 1)
(let ((next (hierarchy-examples-delayed--find-number (1- hier-elem))))
diff --git a/test/lisp/emacs-lisp/lisp-mnt-tests.el b/test/lisp/emacs-lisp/lisp-mnt-tests.el
index 87f0fd7ed5f..e32480ada46 100644
--- a/test/lisp/emacs-lisp/lisp-mnt-tests.el
+++ b/test/lisp/emacs-lisp/lisp-mnt-tests.el
@@ -30,6 +30,26 @@
'(("Bob Weiner" . "rsw@gnu.org")
("Mats Lidell" . "matsl@gnu.org")))))
+(ert-deftest lm--tests-lm-package-requires ()
+ (with-temp-buffer
+ (insert ";; Package-Requires: ((emacs 29.1))")
+ (should (equal (lm-package-requires) '((emacs 29.1)))))
+ (with-temp-buffer
+ (insert ";; Package-Requires: ((emacs \"26.3\") (jsonrpc \"1.0.16\") (flymake \"1.2.1\") (project \"0.9.8\") (xref \"1.6.2\") (eldoc \"1.14.0\") (seq \"2.23\") (external-completion \"0.1\"))")
+ (should (equal (lm-package-requires)
+ '((emacs "26.3") (jsonrpc "1.0.16") (flymake "1.2.1")
+ (project "0.9.8") (xref "1.6.2") (eldoc "1.14.0")
+ (seq "2.23") (external-completion "0.1")))))
+ (with-temp-buffer
+ (insert ";; Package-Requires: ((emacs \"26.3\") (jsonrpc \"1.0.16\") (flymake \"1.2.1\")\n"
+ ";; (project \"0.9.8\") (xref \"1.6.2\") (eldoc \"1.14.0\")\n"
+ ";; (seq \"2.23\") (external-completion \"0.1\"))")
+ (should (equal (lm-package-requires)
+ '((emacs "26.3") (jsonrpc "1.0.16") (flymake "1.2.1")
+ (project "0.9.8") (xref "1.6.2") (eldoc "1.14.0")
+ (seq "2.23") (external-completion "0.1"))))))
+
+
(ert-deftest lm--tests-lm-website ()
(with-temp-buffer
(insert ";; URL: https://example.org/foo")
diff --git a/test/lisp/emacs-lisp/lisp-mode-tests.el b/test/lisp/emacs-lisp/lisp-mode-tests.el
index 110063537db..da02be65d03 100644
--- a/test/lisp/emacs-lisp/lisp-mode-tests.el
+++ b/test/lisp/emacs-lisp/lisp-mode-tests.el
@@ -355,5 +355,28 @@ Expected initialization file: `%s'\"
;; (should (equal (lisp-current-defun-name) "defblarg")))
)
+(ert-deftest test-font-lock-keywords ()
+ "Keywords should be fontified in `font-lock-keyword-face`."
+ (with-temp-buffer
+ (emacs-lisp-mode)
+ (mapc (lambda (el-keyword)
+ (erase-buffer)
+ (insert (format "(%s some-symbol () \"hello\"" el-keyword))
+ (font-lock-ensure)
+ ;; Verify face property throughout the keyword
+ (let* ((begin (1+ (point-min)))
+ (end (1- (+ begin (length el-keyword)))))
+ (mapc (lambda (pos)
+ (should (equal (get-text-property pos 'face)
+ 'font-lock-keyword-face)))
+ (number-sequence begin end))))
+ '("defsubst" "cl-defsubst" "define-inline"
+ "define-advice" "defadvice" "defalias"
+ "define-derived-mode" "define-minor-mode"
+ "define-generic-mode" "define-global-minor-mode"
+ "define-globalized-minor-mode" "define-skeleton"
+ "define-widget" "ert-deftest" "defconst" "defcustom"
+ "defvaralias" "defvar-local" "defface" "define-error"))))
+
(provide 'lisp-mode-tests)
;;; lisp-mode-tests.el ends here
diff --git a/test/lisp/emacs-lisp/macroexp-resources/vk.el b/test/lisp/emacs-lisp/macroexp-resources/vk.el
index 460b7a8e516..5358bcaeb5c 100644
--- a/test/lisp/emacs-lisp/macroexp-resources/vk.el
+++ b/test/lisp/emacs-lisp/macroexp-resources/vk.el
@@ -25,7 +25,7 @@
(if (macroexp--dynamic-variable-p var) ''dyn ''lex))
(defvar vk-a 1)
-(defconst vk-b 2)
+(defvar vk-b 2)
(defvar vk-c)
(defun vk-f1 (x)
diff --git a/test/lisp/emacs-lisp/macroexp-tests.el b/test/lisp/emacs-lisp/macroexp-tests.el
index 4da4704a793..2a57de248a2 100644
--- a/test/lisp/emacs-lisp/macroexp-tests.el
+++ b/test/lisp/emacs-lisp/macroexp-tests.el
@@ -124,4 +124,20 @@
(dyn dyn dyn dyn)
(dyn dyn dyn lex))))))
+(defmacro macroexp--test-macro1 ()
+ (declare (obsolete "new-replacement" nil))
+ 1)
+
+(defmacro macroexp--test-macro2 ()
+ '(macroexp--test-macro1))
+
+(ert-deftest macroexp--test-obsolete-macro ()
+ (should
+ (let ((res
+ (cl-letf (((symbol-function 'message) #'user-error))
+ (condition-case err
+ (macroexpand-all '(macroexp--test-macro2))
+ (user-error (error-message-string err))))))
+ (should (and (stringp res) (string-match "new-replacement" res))))))
+
;;; macroexp-tests.el ends here
diff --git a/test/lisp/emacs-lisp/map-tests.el b/test/lisp/emacs-lisp/map-tests.el
index e22c1681506..dc8121b0582 100644
--- a/test/lisp/emacs-lisp/map-tests.el
+++ b/test/lisp/emacs-lisp/map-tests.el
@@ -577,6 +577,13 @@ See bug#58531#25 and bug#58563."
(should (= b 2))
(should-not c)))
+(ert-deftest test-map-let-default ()
+ (map-let (('foo a 3)
+ ('baz b 4))
+ '((foo . 1))
+ (should (equal a 1))
+ (should (equal b 4))))
+
(ert-deftest test-map-merge ()
"Test `map-merge'."
(should (equal (sort (map-merge 'list '(a 1) '((b . 2) (c . 3))
@@ -617,6 +624,58 @@ See bug#58531#25 and bug#58563."
(list one two))
'(1 2)))))
+(ert-deftest test-map-plist-pcase-default ()
+ (let ((plist '(:two 2)))
+ (should (equal (pcase-let (((map (:two two 33)
+ (:three three 44))
+ plist))
+ (list two three))
+ '(2 44)))))
+
+(ert-deftest test-map-pcase-matches ()
+ (let ((plist '(:two 2)))
+ (should (equal (pcase plist
+ ((map (:two two 33)
+ (:three three))
+ (list two three))
+ (_ 'fail))
+ '(2 nil)))
+
+ (should (equal (pcase plist
+ ((map (:two two 33)
+ (:three three 44))
+ (list two three))
+ (_ 'fail))
+ '(2 44)))
+
+ (should (equal (pcase plist
+ ((map (:two two 33)
+ (:three `(,a . ,b) '(11 . 22)))
+ (list two a b))
+ (_ 'fail))
+ '(2 11 22)))
+
+ (should (equal 'fail
+ (pcase plist
+ ((map (:two two 33)
+ (:three `(,a . ,b) 44))
+ (list two a b))
+ (_ 'fail))))
+
+ (should (equal 'fail
+ (pcase plist
+ ((map (:two two 33)
+ (:three `(,a . ,b) nil))
+ (list two a b))
+ (_ 'fail))))
+
+ (should (equal 'fail
+ (pcase plist
+ ((map (:two two 33)
+ (:three `(,a . ,b)))
+ (list two a b))
+ (_ 'fail))))))
+
(ert-deftest test-map-setf-alist-insert-key ()
(let ((alist))
(should (equal (setf (map-elt alist 'key) 'value)
diff --git a/test/lisp/emacs-lisp/multisession-tests.el b/test/lisp/emacs-lisp/multisession-tests.el
index 4f4f6edf399..edbc6bf02c4 100644
--- a/test/lisp/emacs-lisp/multisession-tests.el
+++ b/test/lisp/emacs-lisp/multisession-tests.el
@@ -94,7 +94,7 @@
(dotimes (i 100)
(cl-incf (multisession-value multisession--bar))))))))
(while (process-live-p proc)
- (ignore-error 'sqlite-locked-error
+ (ignore-error sqlite-locked-error
(message "multisession--bar %s" (multisession-value multisession--bar))
;;(cl-incf (multisession-value multisession--bar))
)
diff --git a/test/lisp/emacs-lisp/nadvice-tests.el b/test/lisp/emacs-lisp/nadvice-tests.el
index 105645b2225..1a0b8468841 100644
--- a/test/lisp/emacs-lisp/nadvice-tests.el
+++ b/test/lisp/emacs-lisp/nadvice-tests.el
@@ -29,6 +29,7 @@
(advice-add 'sm-test1 :around (lambda (f y) (* (funcall f y) 2)))
(advice-remove 'sm-test1 (lambda (f y) (* (funcall f y) 5)))
(defun sm-test1 (x) (+ x 4))
+ (declare-function sm-test1 nil)
(should (equal (sm-test1 6) 20))
(advice-remove 'sm-test1 (lambda (f y) (* (funcall f y) 2)))
(should (equal (sm-test1 6) 10))
@@ -62,9 +63,11 @@
(ert-deftest advice-tests-advice ()
"Test advice code."
(defun sm-test2 (x) (+ x 4))
+ (declare-function sm-test2 nil)
(should (equal (sm-test2 6) 10))
- (defadvice sm-test2 (around sm-test activate)
- ad-do-it (setq ad-return-value (* ad-return-value 5)))
+ (with-suppressed-warnings ((obsolete defadvice))
+ (defadvice sm-test2 (around sm-test activate)
+ ad-do-it (setq ad-return-value (* ad-return-value 5))))
(should (equal (sm-test2 6) 50))
(ad-deactivate 'sm-test2)
(should (equal (sm-test2 6) 10))
@@ -79,8 +82,9 @@
(should (equal (sm-test2 6) 20))
(should (equal (null (get 'sm-test2 'defalias-fset-function)) t))
- (defadvice sm-test4 (around wrap-with-toto activate)
- ad-do-it (setq ad-return-value `(toto ,ad-return-value)))
+ (with-suppressed-warnings ((obsolete defadvice))
+ (defadvice sm-test4 (around wrap-with-toto activate)
+ ad-do-it (setq ad-return-value `(toto ,ad-return-value))))
(defmacro sm-test4 (x) `(call-test4 ,x))
(should (equal (macroexpand '(sm-test4 56)) '(toto (call-test4 56))))
(defmacro sm-test4 (x) `(call-testq ,x))
@@ -88,17 +92,20 @@
;; This used to signal an error (bug#12858).
(autoload 'sm-test6 "foo")
- (defadvice sm-test6 (around test activate)
- ad-do-it))
+ (with-suppressed-warnings ((obsolete defadvice))
+ (defadvice sm-test6 (around test activate)
+ ad-do-it)))
(ert-deftest advice-tests-combination ()
"Combining old style and new style advices."
(defun sm-test5 (x) (+ x 4))
+ (declare-function sm-test5 nil)
(should (equal (sm-test5 6) 10))
(advice-add 'sm-test5 :around (lambda (f y) (* (funcall f y) 5)))
(should (equal (sm-test5 6) 50))
- (defadvice sm-test5 (around test activate)
- ad-do-it (setq ad-return-value (+ ad-return-value 0.1)))
+ (with-suppressed-warnings ((obsolete defadvice))
+ (defadvice sm-test5 (around test activate)
+ ad-do-it (setq ad-return-value (+ ad-return-value 0.1))))
(should (equal (sm-test5 5) 45.1))
(ad-deactivate 'sm-test5)
(should (equal (sm-test5 6) 50))
@@ -112,22 +119,23 @@
(ert-deftest advice-test-called-interactively-p ()
"Check interaction between advice and called-interactively-p."
(defun sm-test7 (&optional x) (interactive) (+ (or x 7) 4))
+ (declare-function sm-test7 nil)
(advice-add 'sm-test7 :around
(lambda (f &rest args)
- (list (cons 1 (called-interactively-p)) (apply f args))))
+ (list (cons 1 (called-interactively-p 'any)) (apply f args))))
(should (equal (sm-test7) '((1 . nil) 11)))
(should (equal (call-interactively 'sm-test7) '((1 . t) 11)))
(let ((smi 7))
(advice-add 'sm-test7 :before
- (lambda (&rest args)
- (setq smi (called-interactively-p))))
+ (lambda (&rest _args)
+ (setq smi (called-interactively-p 'any))))
(should (equal (list (sm-test7) smi)
'(((1 . nil) 11) nil)))
(should (equal (list (call-interactively 'sm-test7) smi)
'(((1 . t) 11) t))))
(advice-add 'sm-test7 :around
(lambda (f &rest args)
- (cons (cons 2 (called-interactively-p)) (apply f args))))
+ (cons (cons 2 (called-interactively-p 'any)) (apply f args))))
(should (equal (call-interactively 'sm-test7) '((2 . t) (1 . t) 11))))
(ert-deftest advice-test-called-interactively-p-around ()
@@ -136,24 +144,28 @@
This tests the currently broken case of the innermost advice to a
function being an around advice."
:expected-result :failed
- (defun sm-test7.2 () (interactive) (cons 1 (called-interactively-p)))
+ (defun sm-test7.2 () (interactive) (cons 1 (called-interactively-p 'any)))
+ (declare-function sm-test7.2 nil)
(advice-add 'sm-test7.2 :around
(lambda (f &rest args)
- (list (cons 1 (called-interactively-p)) (apply f args))))
+ (list (cons 1 (called-interactively-p 'any)) (apply f args))))
(should (equal (sm-test7.2) '((1 . nil) (1 . nil))))
(should (equal (call-interactively 'sm-test7.2) '((1 . t) (1 . t)))))
(ert-deftest advice-test-called-interactively-p-filter-args ()
"Check interaction between filter-args advice and called-interactively-p."
:expected-result :failed
- (defun sm-test7.3 () (interactive) (cons 1 (called-interactively-p)))
+ (defun sm-test7.3 () (interactive) (cons 1 (called-interactively-p 'any)))
+ (declare-function sm-test7.3 nil)
(advice-add 'sm-test7.3 :filter-args #'list)
(should (equal (sm-test7.3) '(1 . nil)))
(should (equal (call-interactively 'sm-test7.3) '(1 . t))))
(ert-deftest advice-test-call-interactively ()
"Check interaction between advice on call-interactively and called-interactively-p."
- (let ((sm-test7.4 (lambda () (interactive) (cons 1 (called-interactively-p))))
+ (let ((sm-test7.4 (lambda ()
+ (interactive)
+ (cons 1 (called-interactively-p 'any))))
(old (symbol-function 'call-interactively)))
(unwind-protect
(progn
@@ -166,18 +178,20 @@ function being an around advice."
(ert-deftest advice-test-interactive ()
"Check handling of interactive spec."
(defun sm-test8 (a) (interactive "p") a)
- (defadvice sm-test8 (before adv1 activate) nil)
- (defadvice sm-test8 (before adv2 activate) (interactive "P") nil)
+ (with-suppressed-warnings ((obsolete defadvice))
+ (defadvice sm-test8 (before adv1 activate) nil)
+ (defadvice sm-test8 (before adv2 activate) (interactive "P") nil))
(should (equal (interactive-form 'sm-test8) '(interactive "P"))))
(ert-deftest advice-test-preactivate ()
(should (equal (null (get 'sm-test9 'defalias-fset-function)) t))
(defun sm-test9 (a) (interactive "p") a)
(should (equal (null (get 'sm-test9 'defalias-fset-function)) t))
- (defadvice sm-test9 (before adv1 pre act protect compile) nil)
- (should (equal (null (get 'sm-test9 'defalias-fset-function)) nil))
- (defadvice sm-test9 (before adv2 pre act protect compile)
- (interactive "P") nil)
+ (with-suppressed-warnings ((obsolete defadvice))
+ (defadvice sm-test9 (before adv1 pre act protect compile) nil)
+ (should (equal (null (get 'sm-test9 'defalias-fset-function)) nil))
+ (defadvice sm-test9 (before adv2 pre act protect compile)
+ (interactive "P") nil))
(should (equal (interactive-form 'sm-test9) '(interactive "P"))))
(ert-deftest advice-test-multiples ()
@@ -213,8 +227,16 @@ function being an around advice."
(should (equal (cl-prin1-to-string (car x))
"#f(advice first :before #f(advice car :after cdr))"))))
-;; Local Variables:
-;; no-byte-compile: t
-;; End:
+(ert-deftest advice-test-bug61179 ()
+ (let* ((magic 42)
+ (ad (lambda (&rest _)
+ (interactive (lambda (is)
+ (cons magic (advice-eval-interactive-spec is))))
+ nil))
+ (sym (make-symbol "adtest")))
+ (defalias sym (lambda (&rest args) (interactive (list 'main)) args))
+ (should (equal (call-interactively sym) '(main)))
+ (advice-add sym :before ad)
+ (should (equal (call-interactively sym) '(42 main)))))
;;; nadvice-tests.el ends here
diff --git a/test/lisp/emacs-lisp/package-tests.el b/test/lisp/emacs-lisp/package-tests.el
index 5176c6abcd8..d95b94f2145 100644
--- a/test/lisp/emacs-lisp/package-tests.el
+++ b/test/lisp/emacs-lisp/package-tests.el
@@ -125,6 +125,7 @@
abbreviated-home-dir
package--initialized
package-alist
+ package-selected-packages
,@(if update-news
'(package-update-news-on-upload t)
(list (cl-gensym)))
@@ -219,9 +220,14 @@ Must called from within a `tar-mode' buffer."
(ert-deftest package-test-desc-from-buffer ()
"Parse an elisp buffer to get a `package-desc' object."
- (with-package-test (:basedir (ert-resource-directory) :file "simple-single-1.3.el")
- (should (package-test--compatible-p
- (package-buffer-info) simple-single-desc 'kind)))
+ (with-package-test (:basedir (ert-resource-directory)
+ :file "simple-single-1.3.el")
+ (let ((pi (package-buffer-info)))
+ (should (package-test--compatible-p pi simple-single-desc 'kind))
+ ;; The terminating line is not mandatory any more.
+ (re-search-forward "^;;; .* ends here")
+ (delete-region (match-beginning 0) (point-max))
+ (should (equal (package-buffer-info) pi))))
(with-package-test (:basedir (ert-resource-directory) :file "simple-depend-1.0.el")
(should (package-test--compatible-p
(package-buffer-info) simple-depend-desc 'kind)))
@@ -302,6 +308,21 @@ Must called from within a `tar-mode' buffer."
(package-delete (cadr (assq 'v7-withsub package-alist))))
))
+(ert-deftest package-test-bug65475 ()
+ "Deleting the last package clears `package-selected-packages'."
+ (with-package-test (:basedir (ert-resource-directory))
+ (package-initialize)
+ (let* ((pkg-el "simple-single-1.3.el")
+ (source-file (expand-file-name pkg-el (ert-resource-directory))))
+ (package-install-file source-file)
+ (should package-alist)
+ (should package-selected-packages)
+ (let ((desc (cadr (assq 'simple-single package-alist))))
+ (should desc)
+ (package-delete desc))
+ (should-not package-alist)
+ (should-not package-selected-packages))))
+
(ert-deftest package-test-install-file-EOLs ()
"Install same file multiple time with `package-install-file'
but with a different end of line convention (bug#48137)."
diff --git a/test/lisp/emacs-lisp/pcase-tests.el b/test/lisp/emacs-lisp/pcase-tests.el
index d062965952a..c79adcdfec5 100644
--- a/test/lisp/emacs-lisp/pcase-tests.el
+++ b/test/lisp/emacs-lisp/pcase-tests.el
@@ -160,4 +160,18 @@
(should-error (pcase-setq a)
:type '(wrong-number-of-arguments)))
+(ert-deftest pcase-tests-mutually-exclusive ()
+ (dolist (x '((functionp consp nil)
+ (functionp stringp t)
+ (compiled-function-p consp t)
+ (keywordp symbolp nil)
+ (keywordp symbol-with-pos-p nil)
+ (keywordp stringp t)))
+ (if (nth 2 x)
+ (should (pcase--mutually-exclusive-p (nth 0 x) (nth 1 x)))
+ (should-not (pcase--mutually-exclusive-p (nth 0 x) (nth 1 x))))
+ (if (nth 2 x)
+ (should (pcase--mutually-exclusive-p (nth 1 x) (nth 0 x)))
+ (should-not (pcase--mutually-exclusive-p (nth 1 x) (nth 0 x))))))
+
;;; pcase-tests.el ends here.
diff --git a/test/lisp/emacs-lisp/pp-tests.el b/test/lisp/emacs-lisp/pp-tests.el
index 9de8b879207..7606183d645 100644
--- a/test/lisp/emacs-lisp/pp-tests.el
+++ b/test/lisp/emacs-lisp/pp-tests.el
@@ -23,8 +23,8 @@
(require 'ert-x)
(ert-deftest pp-print-quote ()
- (should (string= (pp-to-string 'quote) "quote"))
- (should (string= (pp-to-string ''quote) "'quote"))
+ (should (string= (pp-to-string 'quote) "quote\n"))
+ (should (string= (pp-to-string ''quote) "'quote\n"))
(should (string= (pp-to-string '('a 'b)) "('a 'b)\n"))
(should (string= (pp-to-string '(''quote 'quote)) "(''quote 'quote)\n"))
(should (string= (pp-to-string '(quote)) "(quote)\n"))
@@ -36,4 +36,53 @@
(ert-deftest test-indentation ()
(ert-test-erts-file (ert-resource-file "code-formats.erts")))
+(defun pp-tests--dimensions ()
+ (save-excursion
+ (let ((width 0)
+ (height 0))
+ (goto-char (point-min))
+ (while (not (eobp))
+ (end-of-line)
+ (setq height (1+ height))
+ (setq width (max width (current-column)))
+ (forward-char 1))
+ (cons width height))))
+
+(ert-deftest pp-tests--cut-before ()
+ (with-temp-buffer
+ (lisp-data-mode)
+ (pp '(1 (quite-a-long-package-name
+ . [(0 10 0) ((avy (0 5 0))) "Quickly switch windows." tar
+ ((:url . "https://github.com/abo-abo/ace-window")
+ (:maintainer "Oleh Krehel" . "ohwoeowho@gmail.com")
+ (:authors ("Oleh Krehel" . "ohwoeowho@gmail.com"))
+ (:keywords "window" "location"))]))
+ (current-buffer))
+ ;; (message "Filled:\n%s" (buffer-string))
+ (let ((dimensions (pp-tests--dimensions)))
+ (should (< (car dimensions) 80))
+ (should (< (cdr dimensions) 8)))
+ (goto-char (point-min))
+ (while (search-forward "." nil t)
+ (should (not (eolp))))))
+
+(ert-deftest pp-tests--sanity ()
+ (with-temp-buffer
+ (lisp-data-mode)
+ (let ((testdata "(a b c #1=#[0 \"\" [] 0] #s(foo #1# bar))"))
+ (let ((res (car (read-from-string testdata))))
+ (dotimes (i (length testdata))
+ (erase-buffer)
+ (insert testdata)
+ (let ((fill-column i))
+ (pp-fill (point-min) (point-max))
+ (goto-char (point-min))
+ (condition-case err
+ (should (equal (read (current-buffer)) res))
+ (invalid-read-syntax
+ (message "Invalid fill result with i=%d:\n%s"
+ i (buffer-string))
+ (signal (car err) (cdr err))
+ ))))))))
+
;;; pp-tests.el ends here.
diff --git a/test/lisp/emacs-lisp/rx-tests.el b/test/lisp/emacs-lisp/rx-tests.el
index d7b97d7cd9a..072209bcbcc 100644
--- a/test/lisp/emacs-lisp/rx-tests.el
+++ b/test/lisp/emacs-lisp/rx-tests.el
@@ -41,19 +41,31 @@
(should (equal (rx "" (or "ab" nonl) "")
"ab\\|.")))
+;; FIXME: Extend tests for `or', `not' etc to cover char pattern combination,
+;; including (syntax whitespace) and (syntax word).
+
(ert-deftest rx-or ()
- (should (equal (rx (or "ab" (| "c" nonl) "de"))
- "ab\\|c\\|.\\|de"))
+ (should (equal (rx (or "ab" (| "cd" nonl) "de"))
+ "ab\\|cd\\|.\\|de"))
(should (equal (rx (or "ab" "abc" ?a))
"\\(?:a\\(?:bc?\\)?\\)"))
(should (equal (rx (or "ab" (| (or "abcd" "abcde")) (or "a" "abc")))
"\\(?:a\\(?:b\\(?:c\\(?:de?\\)?\\)?\\)?\\)"))
(should (equal (rx (or "a" (eval (string ?a ?b))))
"\\(?:ab?\\)"))
+ (should (equal (rx (| nonl "ac") (| "bd" blank))
+ "\\(?:.\\|ac\\)\\(?:bd\\|[[:blank:]]\\)"))
(should (equal (rx (| nonl "a") (| "b" blank))
- "\\(?:.\\|a\\)\\(?:b\\|[[:blank:]]\\)"))
+ ".[b[:blank:]]"))
(should (equal (rx (|))
- "\\`a\\`")))
+ "\\`a\\`"))
+ (should (equal (rx (or "a" (not anychar) punct ?c "b" (not (not ?d))))
+ "[a-d[:punct:]]"))
+ (should (equal (rx (or nonl ?\n))
+ "[^z-a]"))
+ (should (equal (rx (or "ab" "a" "b" blank (syntax whitespace) word "z"))
+ "ab\\|[ab[:blank:]]\\|\\s-\\|[z[:word:]]"))
+ )
(ert-deftest rx-def-in-or ()
(rx-let ((a b)
@@ -98,7 +110,21 @@
"[\177Å\211\326-\377]"))
;; Split range; \177-\377ÿ should not be optimized to \177-\377.
(should (equal (rx (any "\177-\377" ?ÿ))
- "[\177ÿ\200-\377]")))
+ "[\177ÿ\200-\377]"))
+ ;; Range between normal chars and raw bytes: must be split to be parsed
+ ;; correctly by the Emacs regexp engine.
+ (should (equal (rx (any (0 . #x3fffff) word) (any (?G . #x3fff9a) word)
+ (any (?Ü . #x3ffff2) word))
+ (concat "[\0-\x3fff7f\x80-\xff[:word:]]"
+ "[G-\x3fff7f\x80-\x9a[:word:]]"
+ "[Ü-\x3fff7f\x80-\xf2[:word:]]")))
+ ;; As above but with ranges in string form. For historical reasons,
+ ;; we special-case ASCII-to-raw ranges to exclude non-ASCII unicode.
+ (should (equal (rx (any "\x00-\xff" alpha) (any "G-\x9a" alpha)
+ (any "Ü-\xf2" alpha))
+ (concat "[\0-\x7f\x80-\xff[:alpha:]]"
+ "[G-\x7f\x80-\x9a[:alpha:]]"
+ "[Ü-\x3fff7f\x80-\xf2[:alpha:]]"))))
(ert-deftest rx-any ()
(should (equal (rx (any ?A (?C . ?D) "F-H" "J-L" "M" "N-P" "Q" "RS"))
@@ -138,7 +164,7 @@
(should (equal (rx (any "-]^" ascii) (not (any "-]^" ascii)))
"[]^[:ascii:]-][^]^[:ascii:]-]"))
(should (equal (rx (any "^" lower upper) (not (any "^" lower upper)))
- "[[:lower:]^[:upper:]][^^[:lower:][:upper:]]"))
+ "[[:lower:][:upper:]^][^^[:lower:][:upper:]]"))
(should (equal (rx (any "-" lower upper) (not (any "-" lower upper)))
"[[:lower:][:upper:]-][^[:lower:][:upper:]-]"))
(should (equal (rx (any "]" lower upper) (not (any "]" lower upper)))
@@ -165,7 +191,10 @@
"[a[:space:][:digit:]]"))
(should (equal (rx (not "\n") (not ?\n) (not (any "\n")) (not-char ?\n)
(| (not (in "a\n")) (not (char ?\n (?b . ?b)))))
- ".....")))
+ "....."))
+ (should (equal (rx (or (in "g-k") (in "a-f") (or ?r (in "i-m" "n-q"))))
+ "[a-r]"))
+ )
(ert-deftest rx-pcase ()
(should (equal (pcase "i18n" ((rx (let x (+ digit))) (list 'ok x)))
@@ -274,7 +303,7 @@
"^\\`\\'\\`\\'\\`\\'\\`\\'$"))
(should (equal (rx point word-start word-end bow eow symbol-start symbol-end
word-boundary not-word-boundary not-wordchar)
- "\\=\\<\\>\\<\\>\\_<\\_>\\b\\B\\W"))
+ "\\=\\<\\>\\<\\>\\_<\\_>\\b\\B[^[:word:]]"))
(should (equal (rx digit numeric num control cntrl)
"[[:digit:]][[:digit:]][[:digit:]][[:cntrl:]][[:cntrl:]]"))
(should (equal (rx hex-digit hex xdigit blank)
@@ -296,7 +325,7 @@
(should (equal (rx (syntax whitespace) (syntax punctuation)
(syntax word) (syntax symbol)
(syntax open-parenthesis) (syntax close-parenthesis))
- "\\s-\\s.\\sw\\s_\\s(\\s)"))
+ "\\s-\\s.\\w\\s_\\s(\\s)"))
(should (equal (rx (syntax string-quote) (syntax paired-delimiter)
(syntax escape) (syntax character-quote)
(syntax comment-start) (syntax comment-end)
@@ -344,8 +373,9 @@
"\\B"))
(should (equal (rx (not ascii) (not lower-case) (not wordchar))
"[^[:ascii:]][^[:lower:]][^[:word:]]"))
- (should (equal (rx (not (syntax punctuation)) (not (syntax escape)))
- "\\S.\\S\\"))
+ (should (equal (rx (not (syntax punctuation)) (not (syntax escape))
+ (not (syntax word)))
+ "\\S.\\S\\\\W"))
(should (equal (rx (not (category tone-mark)) (not (category lao)))
"\\C4\\Co"))
(should (equal (rx (not (not ascii)) (not (not (not (any "a-z")))))
@@ -381,7 +411,16 @@
(should (equal (rx (or (not (in "abc")) (not (char "bcd"))))
"[^bc]"))
(should (equal (rx (or "x" (? "yz")))
- "x\\|\\(?:yz\\)?")))
+ "x\\|\\(?:yz\\)?"))
+ (should (equal (rx (or anychar (not anychar)))
+ "[^z-a]"))
+ (should (equal (rx (or (not (in "a-p")) (not (in "k-u"))))
+ "[^k-p]"))
+ (should (equal (rx (or (not (in "a-p")) word (not (in "k-u"))))
+ "[\0-jq-\x3fff7f\x80-\xff[:word:]]"))
+ (should (equal (rx (or (in "a-f" blank) (in "c-z") blank))
+ "[a-z[:blank:]]"))
+ )
(ert-deftest rx-def-in-charset-or ()
(rx-let ((a (any "badc"))
@@ -600,6 +639,57 @@
(rx-submatch-n '(group-n 3 (+ nonl) eol)))
"\\(?3:.+$\\)")))
+;;; unit tests for internal functions
+
+(ert-deftest rx--interval-set-complement ()
+ (should (equal (rx--interval-set-complement '())
+ '((0 . #x3fffff))))
+ (should (equal (rx--interval-set-complement '((10 . 20) (30 . 40)))
+ '((0 . 9) (21 . 29) (41 . #x3fffff))))
+ (should (equal (rx--interval-set-complement '((0 . #x3fffff)))
+ '()))
+ (should (equal (rx--interval-set-complement
+ '((0 . 10) (20 . 20) (30 . #x3fffff)))
+ '((11 . 19) (21 . 29)))))
+
+(ert-deftest rx--interval-set-union ()
+ (should (equal (rx--interval-set-union '() '()) '()))
+ (should (equal (rx--interval-set-union '() '((10 . 20) (30 . 40)))
+ '((10 . 20) (30 . 40))))
+ (should (equal (rx--interval-set-union '((10 . 20) (30 . 40)) '())
+ '((10 . 20) (30 . 40))))
+ (should (equal (rx--interval-set-union '((5 . 15) (18 . 24) (32 . 40))
+ '((10 . 20) (30 . 40) (50 . 60)))
+ '((5 . 24) (30 . 40) (50 . 60))))
+ (should (equal (rx--interval-set-union '((10 . 20) (30 . 40) (50 . 60))
+ '((0 . 9) (21 . 29) (41 . 50)))
+ '((0 . 60))))
+ (should (equal (rx--interval-set-union '((10 . 20) (30 . 40))
+ '((12 . 18) (28 . 42)))
+ '((10 . 20) (28 . 42))))
+ (should (equal (rx--interval-set-union '((10 . 20) (30 . 40))
+ '((0 . #x3fffff)))
+ '((0 . #x3fffff)))))
+
+(ert-deftest rx--interval-set-intersection ()
+ (should (equal (rx--interval-set-intersection '() '()) '()))
+ (should (equal (rx--interval-set-intersection '() '((10 . 20) (30 . 40)))
+ '()))
+ (should (equal (rx--interval-set-intersection '((10 . 20) (30 . 40)) '())
+ '()))
+ (should (equal (rx--interval-set-intersection '((5 . 15) (18 . 24) (32 . 40))
+ '((10 . 20) (30 . 40) (50 . 60)))
+ '((10 . 15) (18 . 20) (32 . 40))))
+ (should (equal (rx--interval-set-intersection '((10 . 20) (30 . 40) (50 . 60))
+ '((0 . 9) (21 . 29) (41 . 50)))
+ '((50 . 50))))
+ (should (equal (rx--interval-set-intersection '((10 . 20) (30 . 40))
+ '((12 . 18) (28 . 42)))
+ '((12 . 18) (30 . 40))))
+ (should (equal (rx--interval-set-intersection '((10 . 20) (30 . 40))
+ '((0 . #x3fffff)))
+ '((10 . 20) (30 . 40)))))
+
(provide 'rx-tests)
;;; rx-tests.el ends here
diff --git a/test/lisp/emacs-lisp/shortdoc-tests.el b/test/lisp/emacs-lisp/shortdoc-tests.el
index d84a9c9cfc9..3aaccff707c 100644
--- a/test/lisp/emacs-lisp/shortdoc-tests.el
+++ b/test/lisp/emacs-lisp/shortdoc-tests.el
@@ -65,6 +65,49 @@
(when buf
(kill-buffer buf))))))
+(defun shortdoc-tests--to-ascii (x)
+ "Translate Unicode arrows to ASCII for making the test work everywhere."
+ (cond ((consp x)
+ (cons (shortdoc-tests--to-ascii (car x))
+ (shortdoc-tests--to-ascii (cdr x))))
+ ((stringp x)
+ (thread-last x
+ (string-replace "⇒" "=>")
+ (string-replace "→" "->")))
+ (t x)))
+
+(ert-deftest shortdoc-function-examples-test ()
+ "Test the extraction of usage examples of some Elisp functions."
+ (should (equal '((list . "(delete 2 (list 1 2 3 4))\n => (1 3 4)\n (delete \"a\" (list \"a\" \"b\" \"c\" \"d\"))\n => (\"b\" \"c\" \"d\")"))
+ (shortdoc-tests--to-ascii
+ (shortdoc-function-examples 'delete))))
+ (should (equal '((alist . "(assq 'foo '((foo . bar) (zot . baz)))\n => (foo . bar)")
+ (list . "(assq 'b '((a . 1) (b . 2)))\n => (b . 2)"))
+ (shortdoc-tests--to-ascii
+ (shortdoc-function-examples 'assq))))
+ (should (equal '((regexp . "(string-match-p \"^[fo]+\" \"foobar\")\n => 0"))
+ (shortdoc-tests--to-ascii
+ (shortdoc-function-examples 'string-match-p)))))
+
+(ert-deftest shortdoc-help-fns-examples-function-test ()
+ "Test that `shortdoc-help-fns-examples-function' correctly prints ELisp function examples."
+ (with-temp-buffer
+ (shortdoc-help-fns-examples-function 'string-fill)
+ (should (equal "\n Examples:\n\n (string-fill \"Three short words\" 12)\n => \"Three short\\nwords\"\n (string-fill \"Long-word\" 3)\n => \"Long-word\"\n\n"
+ (shortdoc-tests--to-ascii
+ (buffer-substring-no-properties (point-min) (point-max)))))
+ (erase-buffer)
+ (shortdoc-help-fns-examples-function 'assq)
+ (should (equal "\n Examples:\n\n (assq 'foo '((foo . bar) (zot . baz)))\n => (foo . bar)\n\n (assq 'b '((a . 1) (b . 2)))\n => (b . 2)\n\n"
+ (shortdoc-tests--to-ascii
+ (buffer-substring-no-properties (point-min) (point-max)))))
+ (erase-buffer)
+ (shortdoc-help-fns-examples-function 'string-trim)
+ (should (equal "\n Example:\n\n (string-trim \" foo \")\n => \"foo\"\n\n"
+ (shortdoc-tests--to-ascii
+ (buffer-substring-no-properties (point-min)
+ (point-max)))))))
+
(provide 'shortdoc-tests)
;;; shortdoc-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 23a35307b01..162cad23b88 100644
--- a/test/lisp/emacs-lisp/subr-x-tests.el
+++ b/test/lisp/emacs-lisp/subr-x-tests.el
@@ -709,14 +709,15 @@
[(raise 0.5) (height 2.0)]))
(should (equal (get-text-property 9 'display) '(raise 0.5))))
(with-temp-buffer
- (should (equal (let ((str "some useless string"))
- (add-display-text-property 4 8 'height 2.0 str)
- (add-display-text-property 2 12 'raise 0.5 str)
- str)
- #("some useless string"
- 2 4 (display (raise 0.5))
- 4 8 (display ((raise 0.5) (height 2.0)))
- 8 12 (display (raise 0.5)))))))
+ (should (equal-including-properties
+ (let ((str (copy-sequence "some useless string")))
+ (add-display-text-property 4 8 'height 2.0 str)
+ (add-display-text-property 2 12 'raise 0.5 str)
+ str)
+ #("some useless string"
+ 2 4 (display (raise 0.5))
+ 4 8 (display ((raise 0.5) (height 2.0)))
+ 8 12 (display (raise 0.5)))))))
(ert-deftest subr-x-named-let ()
(let ((funs ()))
diff --git a/test/lisp/emacs-lisp/tabulated-list-tests.el b/test/lisp/emacs-lisp/tabulated-list-tests.el
index 8be2be3139e..e53268b3f14 100644
--- a/test/lisp/emacs-lisp/tabulated-list-tests.el
+++ b/test/lisp/emacs-lisp/tabulated-list-tests.el
@@ -130,4 +130,45 @@
(should-error (tabulated-list-sort) :type 'user-error)
(should-error (tabulated-list-sort 4) :type 'user-error)))
+(ert-deftest tabulated-list-groups ()
+ (with-temp-buffer
+ (tabulated-list-mode)
+ (setq tabulated-list-groups
+ (reverse
+ (seq-group-by (lambda (b) (concat "* " (aref (cadr b) 3)))
+ tabulated-list--test-entries)))
+ (setq tabulated-list-format tabulated-list--test-format)
+ (setq tabulated-list-padding 7)
+ (tabulated-list-init-header)
+ (tabulated-list-print)
+ ;; Basic printing.
+ (should (string-equal
+ (buffer-substring-no-properties (point-min) (point-max))
+ "\
+* installed
+ zzzz-game zzzz-game 2113 installed play zzzz in Emacs
+ mode mode 1128 installed A simple mode for editing Actionscript 3 files
+* available
+ abc-mode abc-mode 944 available Major mode for editing abc music files
+* obsolete
+ 4clojure 4clojure 1507 obsolete Open and evaluate 4clojure.com questions
+"))
+ ;; Sort and preserve position.
+ (forward-line 2)
+ (let ((pos (thing-at-point 'line)))
+ (tabulated-list-next-column 2)
+ (tabulated-list-sort)
+ (should (equal (thing-at-point 'line) pos))
+ (should (string-equal
+ (buffer-substring-no-properties (point-min) (point-max))
+ "\
+* installed
+ mode mode 1128 installed A simple mode for editing Actionscript 3 files
+ zzzz-game zzzz-game 2113 installed play zzzz in Emacs
+* available
+ abc-mode abc-mode 944 available Major mode for editing abc music files
+* obsolete
+ 4clojure 4clojure 1507 obsolete Open and evaluate 4clojure.com questions
+")))))
+
;;; tabulated-list-tests.el ends here
diff --git a/test/lisp/epg-tests.el b/test/lisp/epg-tests.el
index f0bf3ba4d9c..a1748b39f74 100644
--- a/test/lisp/epg-tests.el
+++ b/test/lisp/epg-tests.el
@@ -111,14 +111,23 @@ jA0ECQMCdW8+qtS9Tin/0jUBO1/9Oz69BWPmtFKEeBM62WpFP4o1+bNzdxogdyeg
-----END PGP MESSAGE-----
")))))
+(defun epg--gnupg-version-is-not-buggy ()
+ ;; We need to skip some versions of GnuPG, as they make tests hang.
+ ;; See Bug#63256 and https://dev.gnupg.org/T6481 as well as PROBLEMS.
+ ;; Known bad versions for now are 2.4.1--2.4.3.
+ (not (string-match (rx bos "gpg (GnuPG) 2.4." (+ digit))
+ (shell-command-to-string "gpg --version"))))
+
(ert-deftest epg-roundtrip-1 ()
- :expected-result (if (getenv "EMACS_HYDRA_CI") :failed :passed) ; fixme
+ :expected-result (if (getenv "EMACS_HYDRA_CI") :failed :passed) ; fixme
+ (skip-unless (epg--gnupg-version-is-not-buggy))
(with-epg-tests (:require-passphrase t)
(let ((cipher (epg-encrypt-string epg-tests-context "symmetric" nil)))
(should (equal "symmetric"
(epg-decrypt-string epg-tests-context cipher))))))
(ert-deftest epg-roundtrip-2 ()
+ (skip-unless (epg--gnupg-version-is-not-buggy))
(with-epg-tests (:require-passphrase t
:require-public-key t
:require-secret-key t)
diff --git a/test/lisp/erc/erc-button-tests.el b/test/lisp/erc/erc-button-tests.el
new file mode 100644
index 00000000000..603b3745a27
--- /dev/null
+++ b/test/lisp/erc/erc-button-tests.el
@@ -0,0 +1,307 @@
+;;; erc-button-tests.el --- Tests for erc-button -*- lexical-binding:t -*-
+
+;; Copyright (C) 2023-2024 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 <https://www.gnu.org/licenses/>.
+
+;;; Commentary:
+
+;;; Code:
+(require 'erc-button)
+
+(require 'ert-x) ; cl-lib
+(eval-and-compile
+ (let ((load-path (cons (ert-resource-directory) load-path)))
+ (require 'erc-tests-common)))
+
+(ert-deftest erc-button-alist--url ()
+ (erc-tests-common-init-server-proc "sleep" "1")
+ (with-current-buffer (erc--open-target "#chan")
+ (let ((verify
+ (lambda (p url)
+ (should (equal (get-text-property p 'erc-data) (list url)))
+ (should (equal (get-text-property p 'mouse-face) 'highlight))
+ (should (eq (get-text-property p 'font-lock-face) 'erc-button))
+ (should (eq (get-text-property p 'erc-callback)
+ 'browse-url-button-open-url)))))
+ (goto-char (point-min))
+
+ ;; Most common (unbracketed)
+ (erc-display-message nil nil (current-buffer)
+ "Foo https://example.com bar.")
+ (search-forward "https")
+ (funcall verify (point) "https://example.com")
+
+ ;; The <URL: form> still works despite being removed in ERC 5.6.
+ (erc-display-message nil nil (current-buffer)
+ "Foo <URL: https://gnu.org> bar.")
+ (search-forward "https")
+ (funcall verify (point) "https://gnu.org")
+
+ ;; Bracketed
+ (erc-display-message nil nil (current-buffer) "Foo <ftp://gnu.org> bar.")
+ (search-forward "ftp")
+ (funcall verify (point) "ftp://gnu.org"))
+
+ (when noninteractive
+ (kill-buffer))))
+
+(defvar erc-button-tests--form nil)
+(defvar erc-button-tests--some-var nil)
+
+(defun erc-button-tests--form (&rest rest)
+ (push rest erc-button-tests--form)
+ (apply #'erc-button-add-button rest))
+
+(defun erc-button-tests--erc-button-alist--function-as-form (func)
+ (erc-tests-common-init-server-proc "sleep" "1")
+
+ (with-current-buffer (erc--open-target "#chan")
+ (let* ((erc-button-tests--form nil)
+ (entry (list (rx "+1") 0 func #'ignore 0))
+ (erc-button-alist (cons entry erc-button-alist)))
+
+ (erc-display-message nil 'notice (current-buffer) "Foo bar baz")
+ (erc-display-message nil nil (current-buffer) "+1")
+ (erc-display-message nil 'notice (current-buffer) "Spam")
+ (should (equal (pop erc-button-tests--form)
+ '(53 55 ignore nil ("+1") "\\+1")))
+ (should-not erc-button-tests--form)
+ (goto-char (point-min))
+ (search-forward "+")
+ (should (equal (get-text-property (point) 'erc-data) '("+1")))
+ (should (equal (get-text-property (point) 'mouse-face) 'highlight))
+ (should (eq (get-text-property (point) 'font-lock-face) 'erc-button))
+ (should (eq (get-text-property (point) 'erc-callback) 'ignore)))
+
+ (when noninteractive
+ (kill-buffer))))
+
+(ert-deftest erc-button-alist--function-as-form ()
+ (erc-button-tests--erc-button-alist--function-as-form
+ #'erc-button-tests--form)
+
+ (erc-button-tests--erc-button-alist--function-as-form
+ (symbol-function #'erc-button-tests--form))
+
+ (erc-button-tests--erc-button-alist--function-as-form
+ (lambda (&rest r) (push r erc-button-tests--form)
+ (apply #'erc-button-add-button r))))
+
+(defun erc-button-tests--erc-button-alist--nil-form (form)
+ (erc-tests-common-init-server-proc "sleep" "1")
+
+ (with-current-buffer (erc--open-target "#chan")
+ (let* ((erc-button-tests--form nil)
+ (entry (list (rx "+1") 0 form #'ignore 0))
+ (erc-button-alist (cons entry erc-button-alist)))
+
+ (erc-display-message nil 'notice (current-buffer) "Foo bar baz")
+ (erc-display-message nil nil (current-buffer) "+1")
+ (erc-display-message nil 'notice (current-buffer) "Spam")
+ (should-not erc-button-tests--form)
+ (goto-char (point-min))
+ (search-forward "+")
+ (should-not (get-text-property (point) 'erc-data))
+ (should-not (get-text-property (point) 'mouse-face))
+ (should-not (get-text-property (point) 'font-lock-face))
+ (should-not (get-text-property (point) 'erc-callback)))
+
+ (when noninteractive
+ (kill-buffer))))
+
+(ert-deftest erc-button-alist--nil-form ()
+ (erc-button-tests--erc-button-alist--nil-form nil)
+ (erc-button-tests--erc-button-alist--nil-form 'erc-button-tests--some-var))
+
+(defun erc-button-tests--insert-privmsg (speaker &rest msg-parts)
+ (declare (indent 1))
+ (let ((msg (erc-format-privmessage speaker
+ (apply #'concat msg-parts) nil t)))
+ (erc-display-message nil nil (current-buffer) msg)))
+
+(defun erc-button-tests--populate (test)
+ (let ((inhibit-message noninteractive)
+ erc-kill-channel-hook erc-kill-server-hook erc-kill-buffer-hook)
+
+ (with-current-buffer
+ (cl-letf
+ (((symbol-function 'erc-server-connect)
+ (lambda (&rest _)
+ (setq erc-server-process
+ (start-process "sleep" (current-buffer) "sleep" "1"))
+ (set-process-query-on-exit-flag erc-server-process nil))))
+
+ (erc-open "localhost" 6667 "tester" "Tester" 'connect
+ nil nil nil nil nil "tester" 'foonet))
+
+ (with-current-buffer (erc--open-target "#chan")
+ (erc-update-channel-member
+ "#chan" "alice" "alice" t nil nil nil nil nil "fake" "~u" nil nil t)
+
+ (erc-update-channel-member
+ "#chan" "bob" "bob" t nil nil nil nil nil "fake" "~u" nil nil t)
+
+ (erc-display-message
+ nil 'notice (current-buffer)
+ (concat "This server is in debug mode and is logging all user I/O. "
+ "Blah alice (1) bob (2) blah."))
+
+ (funcall test))
+
+ (when noninteractive
+ (kill-buffer "#chan")
+ (kill-buffer)))))
+
+(ert-deftest erc-button-next ()
+ (erc-button-tests--populate
+ (lambda ()
+ (erc-button-tests--insert-privmsg "alice"
+ "(3) bob (4) come, you are a tedious fool: to the purpose.")
+
+ (erc-button-tests--insert-privmsg "bob"
+ "(5) alice (6) Come me to what was done to her.")
+
+ (should (= erc-input-marker (point)))
+
+ ;; Break out of input area
+ (erc-button-previous 1)
+ (should (looking-at (rx "alice (6)")))
+
+ ;; No next button
+ (should-error (erc-button-next 1) :type 'user-error)
+ (should (looking-at (rx "alice (6)")))
+
+ ;; Next with negative arg is equivalent to previous
+ (erc-button-next -1)
+ (should (looking-at (rx "bob> (5)")))
+
+ ;; One past end of button
+ (forward-char 3)
+ (should (looking-at (rx "> (5)")))
+ (should-not (get-text-property (point) 'erc-callback))
+ (erc-button-previous 1)
+ (should (looking-at (rx "bob> (5)")))
+
+ ;; At end of button
+ (forward-char 2)
+ (should (looking-at (rx "b> (5)")))
+ (erc-button-previous 1)
+ (should (looking-at (rx "bob (4)")))
+
+ ;; Skip multiple buttons back
+ (erc-button-previous 2)
+ (should (looking-at (rx "bob (2)")))
+
+ ;; Skip multiple buttons forward
+ (erc-button-next 2)
+ (should (looking-at (rx "bob (4)")))
+
+ ;; No error as long as some progress made
+ (erc-button-previous 100)
+ (should (looking-at (rx "alice (1)")))
+
+ ;; Error when no progress made
+ (should-error (erc-button-previous 1) :type 'user-error)
+ (should (looking-at (rx "alice (1)"))))))
+
+;; See also `erc-scenarios-networks-announced-missing' in
+;; erc-scenarios-misc.el for a more realistic example.
+(ert-deftest erc-button--display-error-notice-with-keys ()
+ (with-current-buffer (get-buffer-create "*fake*")
+ (let ((mode erc-button-mode)
+ (inhibit-message noninteractive)
+ erc-modules
+ erc-kill-channel-hook erc-kill-server-hook erc-kill-buffer-hook)
+ (erc-tests-common-prep-for-insertion)
+ (erc-tests-common-init-server-proc "sleep" "1")
+
+ (erc-button-mode +1)
+ (should (equal (erc-button--display-error-notice-with-keys
+ "If \\[erc-bol] fails, "
+ "see \\[erc-bug] or `erc-mode-map'.")
+ "*** If C-a fails, see M-x erc-bug or `erc-mode-map'."))
+ (goto-char (point-min))
+
+ (ert-info ("Keymap substitution succeeds")
+ (erc-button-next 1)
+ (should (looking-at "C-a"))
+ (should (eq (get-text-property (point) 'mouse-face) 'highlight))
+ (erc-button-press-button)
+ (with-current-buffer "*Help*"
+ (goto-char (point-min))
+ (should (search-forward "erc-bol" nil t)))
+ (erc-button-next 1)
+ ;; End of interval correct
+ (erc-button-previous 1)
+ (should (looking-at "C-a fails")))
+
+ (ert-info ("Extended command mapping succeeds")
+ (erc-button-next 1)
+ (should (looking-at "M-x erc-bug"))
+ (erc-button-press-button)
+ (should (eq (get-text-property (point) 'mouse-face) 'highlight))
+ (with-current-buffer "*Help*"
+ (goto-char (point-min))
+ (should (search-forward "erc-bug" nil t))))
+
+ (ert-info ("Symbol-description face preserved") ; mutated by d-e-n-w-k
+ (erc-button-next 1)
+ (should (equal (get-text-property (point) 'font-lock-face)
+ '(erc-button erc-error-face erc-notice-face)))
+ (should (eq (get-text-property (point) 'mouse-face) 'highlight))
+ (should (eq erc-button-face 'erc-button))) ; extent evaporates
+
+ (ert-info ("Format when trailing args include non-strings")
+ (should (equal (erc-button--display-error-notice-with-keys
+ "abc" " %d def" " 45%s" 123 '\6)
+ "*** abc 123 def 456")))
+
+ (ert-info ("Respects buffer as first argument when given")
+ (should (equal (erc-button--display-error-notice-with-keys
+ (make-erc-response) "abc") ; compat
+ "*** abc"))
+ (should (equal (erc-button--display-error-notice-with-keys
+ (current-buffer) "abc")
+ "*** abc")))
+
+ (ert-info ("Accounts for nil members when concatenating")
+ (should (equal (erc-button--display-error-notice-with-keys
+ "a" nil)
+ "*** a"))
+ (should (equal (erc-button--display-error-notice-with-keys
+ "a" nil " b")
+ "*** a b"))
+ (should (equal (erc-button--display-error-notice-with-keys
+ "a: %d" nil 1)
+ "*** a: 1"))
+ (should (equal (erc-button--display-error-notice-with-keys
+ "a: %d %s" 1 nil)
+ "*** a: 1 nil"))
+ (should (equal (erc-button--display-error-notice-with-keys
+ "a: " "%d %s" 1 nil)
+ "*** a: 1 nil"))
+ (should (equal (erc-button--display-error-notice-with-keys
+ "a: " nil "%d %s" 1 nil)
+ "*** a: 1 nil")))
+
+ (when noninteractive
+ (unless mode
+ (erc-button-mode -1))
+ (kill-buffer "*Help*")
+ (kill-buffer)))))
+
+;;; erc-button-tests.el ends here
diff --git a/test/lisp/erc/erc-dcc-tests.el b/test/lisp/erc/erc-dcc-tests.el
index ce28c5e8420..d4b5919a1cc 100644
--- a/test/lisp/erc/erc-dcc-tests.el
+++ b/test/lisp/erc/erc-dcc-tests.el
@@ -57,9 +57,8 @@
(erc-mode)
(setq erc-server-process
(start-process "fake" (current-buffer) "sleep" "10")
- erc-input-marker (make-marker)
- erc-insert-marker (make-marker)
erc-server-current-nick "dummy")
+ (erc--initialize-markers (point) nil)
(set-process-query-on-exit-flag erc-server-process nil)
(should-not erc-dcc-list)
(erc-ctcp-query-DCC erc-server-process
@@ -100,17 +99,19 @@
(ert-deftest erc-dcc-handle-ctcp-send--turbo ()
(erc-dcc-tests--dcc-handle-ctcp-send t))
-(ert-deftest erc-dcc-do-GET-command ()
+(defun erc-dcc-tests--erc-dcc-do-GET-command (file &optional sep nuh)
+ (unless nuh (setq nuh "tester!~tester@fake.irc"))
(with-temp-buffer
(let* ((proc (start-process "fake" (current-buffer) "sleep" "10"))
- (elt (list :nick "tester!~tester@fake.irc"
+ (elt (list :nick nuh
:type 'GET
:peer nil
:parent proc
:ip "127.0.0.1"
:port "9899"
- :file "foo.bin"
+ :file file
:size 1405135128))
+ (nic (erc-extract-nick nuh))
(erc-dcc-list (list elt))
;;
erc-accidental-paste-threshold-seconds
@@ -119,53 +120,63 @@
calls)
(erc-mode)
(setq erc-server-process proc
- erc-input-marker (make-marker)
- erc-insert-marker (make-marker)
erc-server-current-nick "dummy")
+ (erc--initialize-markers (point) nil)
(set-process-query-on-exit-flag proc nil)
(cl-letf (((symbol-function 'read-file-name)
- (lambda (&rest _) "foo.bin"))
+ (lambda (&rest _) file))
((symbol-function 'erc-dcc-get-file)
(lambda (&rest r) (push r calls))))
(goto-char (point-max))
- (set-marker erc-insert-marker (point-max))
- (erc-display-prompt)
(ert-info ("No turbo")
(should-not (plist-member elt :turbo))
(goto-char erc-input-marker)
- (insert "/dcc GET tester foo.bin")
+ (insert "/dcc GET " nic " " (or sep "") (prin1-to-string file))
(erc-send-current-line)
(should-not (plist-member (car erc-dcc-list) :turbo))
- (should (equal (pop calls) (list elt "foo.bin" proc))))
+ (should (equal (pop calls) (list elt file proc))))
(ert-info ("Arg turbo in pos 2")
(should-not (plist-member elt :turbo))
(goto-char erc-input-marker)
- (insert "/dcc GET -t tester foo.bin")
+ (insert "/dcc GET -t " nic " " (or sep "") (prin1-to-string file))
(erc-send-current-line)
(should (eq t (plist-get (car erc-dcc-list) :turbo)))
- (should (equal (pop calls) (list elt "foo.bin" proc))))
+ (should (equal (pop calls) (list elt file proc))))
(ert-info ("Arg turbo in pos 4")
(setq elt (plist-put elt :turbo nil)
erc-dcc-list (list elt))
(goto-char erc-input-marker)
- (insert "/dcc GET tester -t foo.bin")
+ (insert "/dcc GET " nic " -t " (or sep "") (prin1-to-string file))
(erc-send-current-line)
(should (eq t (plist-get (car erc-dcc-list) :turbo)))
- (should (equal (pop calls) (list elt "foo.bin" proc))))
+ (should (equal (pop calls) (list elt file proc))))
(ert-info ("Arg turbo in pos 6")
(setq elt (plist-put elt :turbo nil)
erc-dcc-list (list elt))
(goto-char erc-input-marker)
- (insert "/dcc GET tester foo.bin -t")
+ (insert "/dcc GET " nic " " (prin1-to-string file) " -t" (or sep ""))
(erc-send-current-line)
- (should (eq t (plist-get (car erc-dcc-list) :turbo)))
- (should (equal (pop calls) (list elt "foo.bin" proc))))))))
+ (should (eq (if sep nil t) (plist-get (car erc-dcc-list) :turbo)))
+ (should (equal (pop calls) (if sep nil (list elt file proc)))))))))
+
+(ert-deftest erc-dcc-do-GET-command ()
+ (erc-dcc-tests--erc-dcc-do-GET-command "foo.bin")
+ (erc-dcc-tests--erc-dcc-do-GET-command "foo - file.bin")
+ (erc-dcc-tests--erc-dcc-do-GET-command "foo -t file.bin")
+ (erc-dcc-tests--erc-dcc-do-GET-command "-t" "-- ")
-(defun erc-dcc-tests--pcomplete-common (test-fn)
+ ;; Regression involving pipe character in nickname.
+ (let ((nuh "test|r!~test|r@fake.irc"))
+ (erc-dcc-tests--erc-dcc-do-GET-command "foo.bin" nil nuh)
+ (erc-dcc-tests--erc-dcc-do-GET-command "foo - file.bin" nil nuh)
+ (erc-dcc-tests--erc-dcc-do-GET-command "foo -t file.bin" nil nuh)
+ (erc-dcc-tests--erc-dcc-do-GET-command "-t" "-- " nuh)))
+
+(defun erc-dcc-tests--pcomplete-common (test-fn &optional file)
(with-current-buffer (get-buffer-create "*erc-dcc-do-GET-command*")
(let* ((inhibit-message noninteractive)
(proc (start-process "fake" (current-buffer) "sleep" "10"))
@@ -175,7 +186,7 @@
:parent proc
:ip "127.0.0.1"
:port "9899"
- :file "foo.bin"
+ :file (or file "foo.bin")
:size 1405135128))
;;
erc-accidental-paste-threshold-seconds
@@ -211,6 +222,20 @@
(beginning-of-line)
(should (search-forward "/dcc get tester foo.bin" nil t))))))
+(ert-deftest pcomplete/erc-mode/DCC--get-quoted ()
+ (erc-dcc-tests--pcomplete-common
+ (lambda ()
+ (insert "/dcc get ")
+ (call-interactively #'completion-at-point)
+ (save-excursion
+ (beginning-of-line)
+ (should (search-forward "/dcc get tester" nil t)))
+ (call-interactively #'completion-at-point)
+ (save-excursion
+ (beginning-of-line)
+ (should (search-forward "/dcc get tester \"foo bar.bin\"" nil t))))
+ "foo bar.bin"))
+
(ert-deftest pcomplete/erc-mode/DCC--get-1flag ()
(erc-dcc-tests--pcomplete-common
(lambda ()
@@ -218,7 +243,7 @@
(delete-region (point) (point-max))
(insert "/dcc get -")
(call-interactively #'completion-at-point)
- (with-current-buffer (get-buffer "*Completions*")
+ (with-current-buffer "*Completions*"
(goto-char (point-min))
(search-forward "-s")
(search-forward "-t"))
@@ -239,7 +264,7 @@
(delete-region (point) (point-max))
(insert "/dcc get -")
(call-interactively #'completion-at-point)
- (with-current-buffer (get-buffer "*Completions*")
+ (with-current-buffer "*Completions*"
(goto-char (point-min))
(search-forward "-s")
(search-forward "-t"))
@@ -264,7 +289,7 @@
(delete-region (point) (point-max))
(insert "/dcc get -")
(call-interactively #'completion-at-point)
- (with-current-buffer (get-buffer "*Completions*")
+ (with-current-buffer "*Completions*"
(goto-char (point-min))
(search-forward "-s")
(search-forward "-t"))
@@ -282,4 +307,23 @@
(beginning-of-line)
(should (search-forward "/dcc get -t -s tester foo.bin" nil t))))))
+(ert-deftest pcomplete/erc-mode/DCC--get-sep ()
+ (erc-dcc-tests--pcomplete-common
+ (lambda ()
+ (insert "/dcc get ")
+ (call-interactively #'completion-at-point)
+ (save-excursion
+ (beginning-of-line)
+ (should (search-forward "/dcc get tester" nil t)))
+ (insert "-")
+ (call-interactively #'completion-at-point)
+ (save-excursion
+ (beginning-of-line)
+ (should (search-forward "/dcc get tester -- " nil t)))
+ (call-interactively #'completion-at-point)
+ (save-excursion
+ (beginning-of-line)
+ (should (search-forward "/dcc get tester -- -t" nil t))))
+ "-t"))
+
;;; erc-dcc-tests.el ends here
diff --git a/test/lisp/erc/erc-fill-tests.el b/test/lisp/erc/erc-fill-tests.el
new file mode 100644
index 00000000000..3c4ad04abd7
--- /dev/null
+++ b/test/lisp/erc/erc-fill-tests.el
@@ -0,0 +1,453 @@
+;;; erc-fill-tests.el --- Tests for erc-fill -*- lexical-binding:t -*-
+
+;; Copyright (C) 2023-2024 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 <https://www.gnu.org/licenses/>.
+
+;;; Commentary:
+
+;; FIXME these tests are brittle and error prone. Replace with
+;; scenarios.
+
+;;; Code:
+(require 'erc-fill)
+
+(require 'ert-x)
+(eval-and-compile
+ (let ((load-path (cons (ert-resource-directory) load-path)))
+ (require 'erc-tests-common)))
+
+(defvar erc-fill-tests--buffers nil)
+(defvar erc-fill-tests--current-time-value nil)
+
+(cl-defmethod erc-stamp--current-time
+ (&context (erc-fill-tests--current-time-value integer))
+ erc-fill-tests--current-time-value)
+
+(defun erc-fill-tests--insert-privmsg (speaker &rest msg-parts)
+ (declare (indent 1))
+ (let* ((erc--msg-prop-overrides `((erc--msg . msg)))
+ (msg (erc-format-privmessage speaker
+ (apply #'concat msg-parts) nil t))
+ (parsed (make-erc-response :unparsed (format ":%s PRIVMSG #chan :%s"
+ speaker msg)
+ :sender speaker
+ :command "PRIVMSG"
+ :command-args (list "#chan" msg)
+ :contents msg)))
+ (erc-display-message parsed nil (current-buffer) msg)))
+
+(defun erc-fill-tests--wrap-populate (test)
+ (let ((original-window-buffer (window-buffer (selected-window)))
+ (erc--fill-wrap-scrolltobottom-exempt-p t)
+ (erc-stamp--tz t)
+ (erc-fill-function 'erc-fill-wrap)
+ (pre-command-hook pre-command-hook)
+ (inhibit-message noninteractive)
+ (erc-fill-tests--current-time-value 0)
+ erc-insert-post-hook
+ extended-command-history
+ erc-kill-channel-hook erc-kill-server-hook erc-kill-buffer-hook)
+ (cl-letf (((symbol-function 'erc-server-connect)
+ (lambda (&rest _)
+ (erc-tests-common-init-server-proc "sleep" "1"))))
+ (with-current-buffer
+ (car (push (erc-open "localhost" 6667 "tester" "Tester" 'connect
+ nil nil nil nil nil "tester" 'foonet)
+ erc-fill-tests--buffers))
+ (setq erc-network 'foonet
+ erc-server-connected t)
+ (with-current-buffer (erc--open-target "#chan")
+ (set-window-buffer (selected-window) (current-buffer))
+
+ (erc-update-channel-member
+ "#chan" "alice" "alice" t nil nil nil nil nil "fake" "~u" nil nil t)
+
+ (erc-update-channel-member
+ "#chan" "bob" "bob" t nil nil nil nil nil "fake" "~u" nil nil t)
+
+ (erc-display-message
+ nil 'notice (current-buffer)
+ (concat "This server is in debug mode and is logging all user I/O. "
+ "If you do not wish for everything you send to be readable "
+ "by the server owner(s), please disconnect."))
+
+ (erc-fill-tests--insert-privmsg "alice"
+ "bob: come, you are a tedious fool: to the purpose. "
+ "What was done to Elbow's wife, that he hath cause to complain of?"
+ " Come me to what was done to her.")
+
+ ;; Introduce an artificial gap in properties `line-prefix' and
+ ;; `wrap-prefix' and later ensure they're not incremented twice.
+ (save-excursion
+ (forward-line -1)
+ (search-forward "? ")
+ (with-silent-modifications
+ (remove-text-properties (1- (point)) (point)
+ '(line-prefix t wrap-prefix t))))
+
+ (erc-fill-tests--insert-privmsg "bob"
+ "alice: Either your unparagoned mistress is dead, "
+ "or she's outprized by a trifle.")
+
+ ;; Defend against non-local exits from `ert-skip'
+ (unwind-protect
+ (funcall test)
+ (when set-transient-map-timer
+ (timer-event-handler set-transient-map-timer))
+ (set-window-buffer (selected-window) original-window-buffer)
+ (when (or noninteractive (getenv "ERC_TESTS_GRAPHICAL"))
+ (erc-tests-common-kill-buffers erc-fill-tests--buffers)
+ (setq erc-fill-tests--buffers nil))))))))
+
+(defun erc-fill-tests--wrap-check-prefixes (&rest prefixes)
+ ;; Check that prefix props are applied over correct intervals.
+ (save-excursion
+ (goto-char (point-min))
+ (dolist (prefix prefixes)
+ (should (search-forward prefix nil t))
+ (should (get-text-property (pos-bol) 'line-prefix))
+ (should (get-text-property (1- (pos-eol)) 'line-prefix))
+ (should-not (get-text-property (pos-eol) 'line-prefix))
+ ;; Spans entire line uninterrupted.
+ (let* ((val (get-text-property (pos-bol) 'line-prefix))
+ (end (text-property-not-all (pos-bol) (point-max)
+ 'line-prefix val)))
+ (when (and (/= end (pos-eol)) (= ?? (char-before end)))
+ (setq end (text-property-not-all (1+ end) (point-max)
+ 'line-prefix val)))
+ (should (eq end (pos-eol))))
+ (should (equal (get-text-property (pos-bol) 'wrap-prefix)
+ '(space :width erc-fill--wrap-value)))
+ (should-not (get-text-property (pos-eol) 'wrap-prefix))
+ (should (equal (get-text-property (1- (pos-eol)) 'wrap-prefix)
+ '(space :width erc-fill--wrap-value))))))
+
+;; On graphical displays, echo .graphic >> .git/info/exclude
+(defvar erc-fill-tests--graphic-dir "fill/snapshots/.graphic/")
+
+(defun erc-fill-tests--compare (name)
+ (let ((dir (expand-file-name (if (display-graphic-p)
+ erc-fill-tests--graphic-dir
+ "fill/snapshots/" )
+ (ert-resource-directory)))
+ (transform-fn (lambda (got)
+ (string-replace "erc-fill--wrap-value"
+ (number-to-string erc-fill--wrap-value)
+ got)))
+ (buffer-setup-fn (lambda ()
+ (push (current-buffer) erc-fill-tests--buffers))))
+ (erc-tests-common-snapshot-compare name dir transform-fn buffer-setup-fn)))
+
+;; To inspect variable pitch, set `erc-mode-hook' to
+;;
+;; (lambda () (face-remap-add-relative 'default :family "Sans Serif"))
+;;
+;; or similar.
+
+(ert-deftest erc-fill-wrap--monospace ()
+ :tags `(:unstable
+ ,@(and (getenv "ERC_TESTS_GRAPHICAL") '(:erc--graphical)))
+ (unless (>= emacs-major-version 29)
+ (ert-skip "Emacs version too low, missing `buffer-text-pixel-size'"))
+
+ (let ((erc-prompt (lambda () "ABC>")))
+ (erc-fill-tests--wrap-populate
+
+ (lambda ()
+ (should (= erc-fill--wrap-value 27))
+ (erc-fill-tests--wrap-check-prefixes "*** " "<alice> " "<bob> ")
+ (erc-fill-tests--compare "monospace-01-start")
+
+ (ert-info ("Shift right by one (plus)")
+ ;; Args are all `erc-fill-wrap-nudge' +1 because interactive "p"
+ (ert-with-message-capture messages
+ ;; M-x erc-fill-wrap-nudge RET =
+ (ert-simulate-command '(erc-fill-wrap-nudge 2))
+ (should (string-match (rx "for further adjustment") messages)))
+ (should (= erc-fill--wrap-value 29))
+ (erc-fill-tests--wrap-check-prefixes "*** " "<alice> " "<bob> ")
+ (erc-fill-tests--compare "monospace-02-right"))
+
+ (ert-info ("Shift left by five")
+ ;; "M-x erc-fill-wrap-nudge RET -----"
+ (ert-simulate-command '(erc-fill-wrap-nudge -4))
+ (should (= erc-fill--wrap-value 25))
+ (erc-fill-tests--wrap-check-prefixes "*** " "<alice> " "<bob> ")
+ (erc-fill-tests--compare "monospace-03-left"))
+
+ (ert-info ("Reset")
+ ;; M-x erc-fill-wrap-nudge RET 0
+ (ert-simulate-command '(erc-fill-wrap-nudge 0))
+ (should (= erc-fill--wrap-value 27))
+ (erc-fill-tests--wrap-check-prefixes "*** " "<alice> " "<bob> ")
+ (erc-fill-tests--compare "monospace-04-reset"))
+
+ (erc--assert-input-bounds)))))
+
+(defun erc-fill-tests--simulate-refill ()
+ ;; Simulate `erc-fill-wrap-refill-buffer' synchronously and without
+ ;; a progress reporter.
+ (save-excursion
+ (with-silent-modifications
+ (erc-fill--wrap-rejigger-region (point-min) erc-insert-marker nil nil))))
+
+(ert-deftest erc-fill-wrap--merge ()
+ :tags `(:unstable
+ ,@(and (getenv "ERC_TESTS_GRAPHICAL") '(:erc--graphical)))
+ (unless (>= emacs-major-version 29)
+ (ert-skip "Emacs version too low, missing `buffer-text-pixel-size'"))
+
+ (erc-fill-tests--wrap-populate
+
+ (lambda ()
+ (erc-update-channel-member
+ "#chan" "Dummy" "Dummy" t nil nil nil nil nil "fake" "~u" nil nil t)
+
+ ;; Set this here so that the first few messages are from 1970.
+ ;; Following the current date stamp, the speaker isn't merged
+ ;; even though it's continued: "<bob> zero."
+ (let ((erc-fill-tests--current-time-value 1680332400))
+ (erc-fill-tests--insert-privmsg "bob" "zero.")
+ (erc-fill-tests--insert-privmsg "alice" "one.")
+ (erc-fill-tests--insert-privmsg "alice" "two.")
+ (erc-fill-tests--insert-privmsg "bob" "three.")
+ (erc-fill-tests--insert-privmsg "bob" "four.")
+ (erc-fill-tests--insert-privmsg "Dummy" "five.")
+ (erc-fill-tests--insert-privmsg "Dummy" "six."))
+
+ (should (= erc-fill--wrap-value 27))
+ (erc-fill-tests--wrap-check-prefixes
+ "*** " "<alice> " "<bob> "
+ "<bob> " "<alice> " "<alice> " "<bob> " "<bob> " "<Dummy> " "<Dummy> ")
+ (erc-fill-tests--compare "merge-01-start")
+
+ (ert-info ("Shift right by one (plus)")
+ (ert-simulate-command '(erc-fill-wrap-nudge 2))
+ (should (= erc-fill--wrap-value 29))
+ (erc-fill-tests--wrap-check-prefixes
+ "*** " "<alice> " "<bob> "
+ "<bob> " "<alice> " "<alice> " "<bob> " "<bob> " "<Dummy> " "<Dummy> ")
+ (erc-fill-tests--compare "merge-02-right")
+
+ (ert-info ("Command `erc-fill-wrap-refill-buffer' is idempotent")
+ (kill-buffer (pop erc-fill-tests--buffers))
+ (erc-fill-tests--simulate-refill) ; idempotent
+ (erc-fill-tests--compare "merge-02-right"))))))
+
+(defun erc-fill-wrap-tests--merge-action (compare-file)
+ (unless (>= emacs-major-version 29)
+ (ert-skip "Emacs version too low, missing `buffer-text-pixel-size'"))
+
+ (erc-fill-tests--wrap-populate
+
+ (lambda ()
+ ;; Allow prior messages to be from 1970.
+ (let ((erc-fill-tests--current-time-value 1680332400))
+ (erc-fill-tests--insert-privmsg "bob" "zero.")
+ (erc-fill-tests--insert-privmsg "bob" "0.5")
+
+ (erc-process-ctcp-query
+ erc-server-process
+ (make-erc-response
+ :unparsed ":bob!~u@fake PRIVMSG #chan :\1ACTION one.\1"
+ :sender "bob!~u@fake"
+ :command "PRIVMSG"
+ :command-args '("#chan" "\1ACTION one.\1")
+ :contents "\1ACTION one.\1")
+ "bob" "~u" "fake")
+
+ (erc-fill-tests--insert-privmsg "bob" "two.")
+ (erc-fill-tests--insert-privmsg "bob" "2.5")
+
+ ;; Compat switch to opt out of overhanging speaker.
+ (let (erc-fill--wrap-action-dedent-p)
+ (erc-process-ctcp-query
+ erc-server-process
+ (make-erc-response
+ :unparsed ":bob!~u@fake PRIVMSG #chan :\1ACTION three\1"
+ :sender "bob!~u@fake" :command "PRIVMSG"
+ :command-args '("#chan" "\1ACTION three\1")
+ :contents "\1ACTION three\1")
+ "bob" "~u" "fake"))
+
+ (erc-fill-tests--insert-privmsg "bob" "four."))
+
+ (should (= erc-fill--wrap-value 27))
+ (erc-fill-tests--wrap-check-prefixes
+ "*** " "<alice> " "<bob> " "<bob> " "* bob " "<bob> " "* " "<bob> ")
+ (erc-fill-tests--compare compare-file))))
+
+(ert-deftest erc-fill-wrap--merge-action ()
+ :tags `(:unstable
+ ,@(and (getenv "ERC_TESTS_GRAPHICAL") '(:erc--graphical)))
+ (erc-fill-wrap-tests--merge-action "merge-wrap-01"))
+
+(ert-deftest erc-fill-wrap--merge-action/indicator-pre ()
+ :tags `(:unstable
+ ,@(and (getenv "ERC_TESTS_GRAPHICAL") '(:erc--graphical)))
+ (let ((erc-fill-wrap-merge-indicator '(pre ?> shadow)))
+ (erc-fill-wrap-tests--merge-action "merge-wrap-indicator-pre-01")))
+
+;; One crucial thing this test asserts is that the indicator is
+;; omitted when the previous line ends in a stamp.
+(ert-deftest erc-fill-wrap--merge-action/indicator-post ()
+ :tags `(:unstable
+ ,@(and (getenv "ERC_TESTS_GRAPHICAL") '(:erc--graphical)))
+ (let ((erc-fill-wrap-merge-indicator '(post ?~ shadow)))
+ (erc-fill-wrap-tests--merge-action "merge-wrap-indicator-post-01")))
+
+(ert-deftest erc-fill-line-spacing ()
+ :tags `(:unstable
+ ,@(and (getenv "ERC_TESTS_GRAPHICAL") '(:erc--graphical)))
+ (unless (>= emacs-major-version 29)
+ (ert-skip "Emacs version too low, missing `buffer-text-pixel-size'"))
+
+ (let ((erc-fill-line-spacing 0.5))
+ (erc-fill-tests--wrap-populate
+ (lambda ()
+ (erc-fill-tests--insert-privmsg "bob" "This buffer is for text.")
+ (erc-display-message nil 'notice (current-buffer) "one two three")
+ (erc-display-message nil 'notice (current-buffer) "four five six")
+ (erc-fill-tests--insert-privmsg "bob" "Somebody stop me")
+ (erc-fill-tests--compare "spacing-01-mono")))))
+
+(ert-deftest erc-fill-wrap-visual-keys--body ()
+ :tags `(:unstable
+ ,@(and (getenv "ERC_TESTS_GRAPHICAL") '(:erc--graphical)))
+ (erc-fill-tests--wrap-populate
+
+ (lambda ()
+ (ert-info ("Value: non-input")
+ (should (eq erc-fill--wrap-visual-keys 'non-input))
+ (goto-char (point-min))
+ (should (search-forward "that he hath" nil t))
+ (execute-kbd-macro "\C-a")
+ (should-not (looking-at (rx "<alice> ")))
+ (execute-kbd-macro "\C-e")
+ (should (search-backward "tedious fool" nil t))
+ (should-not (looking-back "done to her\\."))
+ (forward-char)
+ (execute-kbd-macro "\C-e")
+ (should (search-forward "done to her." nil t)))
+
+ (ert-info ("Value: nil")
+ (execute-kbd-macro "\C-ca")
+ (should-not erc-fill--wrap-visual-keys)
+ (goto-char (point-min))
+ (should (search-forward "in debug mode" nil t))
+ (execute-kbd-macro "\C-a")
+ (should (looking-at (rx "*** ")))
+ (execute-kbd-macro "\C-e")
+ (should (eql ?\] (char-before (point)))))
+
+ (ert-info ("Value: t")
+ (execute-kbd-macro "\C-ca")
+ (should (eq erc-fill--wrap-visual-keys t))
+ (goto-char (point-min))
+ (should (search-forward "that he hath" nil t))
+ (execute-kbd-macro "\C-a")
+ (should-not (looking-at (rx "<alice> ")))
+ (should (search-backward "tedious fool" nil t))
+ (execute-kbd-macro "\C-e")
+ (should-not (looking-back (rx "done to her\\.")))
+ (should (search-forward "done to her." nil t))
+ (execute-kbd-macro "\C-a")
+ (should-not (looking-at (rx "<alice> ")))))))
+
+(ert-deftest erc-fill-wrap-visual-keys--prompt ()
+ :tags `(:unstable
+ ,@(and (getenv "ERC_TESTS_GRAPHICAL") '(:erc--graphical)))
+ (erc-fill-tests--wrap-populate
+
+ (lambda ()
+ (set-window-buffer (selected-window) (current-buffer))
+ (goto-char erc-input-marker)
+ (insert "This buffer is for text that is not saved, and for Lisp "
+ "evaluation. To create a file, visit it with C-x C-f and "
+ "enter text in its buffer.")
+
+ (ert-info ("Value: non-input")
+ (should (eq erc-fill--wrap-visual-keys 'non-input))
+ (execute-kbd-macro "\C-a")
+ (should (looking-at "This buffer"))
+ (execute-kbd-macro "\C-e")
+ (should (looking-back "its buffer\\."))
+ (execute-kbd-macro "\C-a")
+ (execute-kbd-macro "\C-k")
+ (should (eobp)))
+
+ (ert-info ("Value: nil") ; same
+ (execute-kbd-macro "\C-ca")
+ (should-not erc-fill--wrap-visual-keys)
+ (execute-kbd-macro "\C-y")
+ (should (looking-back "its buffer\\."))
+ (execute-kbd-macro "\C-a")
+ (should (looking-at "This buffer"))
+ (execute-kbd-macro "\C-k")
+ (should (eobp)))
+
+ (ert-info ("Value: non-input")
+ (execute-kbd-macro "\C-ca")
+ (should (eq erc-fill--wrap-visual-keys t))
+ (execute-kbd-macro "\C-y")
+ (execute-kbd-macro "\C-a")
+ (should-not (looking-at "This buffer"))
+ (execute-kbd-macro "\C-p")
+ (should-not (looking-back "its buffer\\."))
+ (should (search-forward "its buffer." nil t))
+ (should (search-backward "ERC> " nil t))
+ (execute-kbd-macro "\C-a")))))
+
+(ert-deftest erc-fill--left-hand-stamps ()
+ :tags `(:unstable
+ ,@(and (getenv "ERC_TESTS_GRAPHICAL") '(:erc--graphical)))
+ (unless (>= emacs-major-version 29)
+ (ert-skip "Emacs version too low, missing `buffer-text-pixel-size'"))
+
+ (let ((erc-timestamp-only-if-changed-flag nil)
+ (erc-insert-timestamp-function #'erc-insert-timestamp-left))
+ (erc-fill-tests--wrap-populate
+ (lambda ()
+ (should (= 8 left-margin-width))
+ (pcase-let ((`((margin left-margin) ,displayed)
+ (get-text-property erc-insert-marker 'display)))
+ (should (equal-including-properties
+ displayed #(" ERC>" 4 8
+ ( read-only t
+ front-sticky t
+ field erc-prompt
+ erc-prompt t
+ rear-nonsticky t
+ font-lock-face erc-prompt-face)))))
+ (erc-fill-tests--compare "stamps-left-01")
+
+ (ert-info ("Shrink left margin by 1 col")
+ (erc-stamp--adjust-margin -1)
+ (with-silent-modifications (erc--refresh-prompt))
+ (should (= 7 left-margin-width))
+ (pcase-let ((`((margin left-margin) ,displayed)
+ (get-text-property erc-insert-marker 'display)))
+ (should (equal-including-properties
+ displayed #(" ERC>" 3 7
+ ( read-only t
+ front-sticky t
+ field erc-prompt
+ erc-prompt t
+ rear-nonsticky t
+ font-lock-face erc-prompt-face))))))))))
+
+;;; erc-fill-tests.el ends here
diff --git a/test/lisp/erc/erc-goodies-tests.el b/test/lisp/erc/erc-goodies-tests.el
new file mode 100644
index 00000000000..7cbaa39d3f7
--- /dev/null
+++ b/test/lisp/erc/erc-goodies-tests.el
@@ -0,0 +1,612 @@
+;;; erc-goodies-tests.el --- Tests for erc-goodies -*- lexical-binding:t -*-
+
+;; Copyright (C) 2023-2024 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 <https://www.gnu.org/licenses/>.
+
+;;; Commentary:
+;;; Code:
+(require 'erc-goodies)
+
+(require 'ert-x)
+(eval-and-compile
+ (let ((load-path (cons (ert-resource-directory) load-path)))
+ (require 'erc-tests-common)))
+
+(defun erc-goodies-tests--assert-face (beg end-str present &optional absent)
+ (setq beg (+ beg (point-min)))
+ (let ((end (+ beg (1- (length end-str)))))
+ (ert-info ((format "beg: %S, end-str: %S" beg end-str))
+ (while (and beg (< beg end))
+ (let* ((val (get-text-property beg 'font-lock-face))
+ (ft (flatten-tree (ensure-list val))))
+ (ert-info ((format "looking-at: %S, val: %S"
+ (buffer-substring-no-properties beg end)
+ val))
+ (dolist (p (ensure-list present))
+ (if (consp p)
+ (should (member p val))
+ (should (memq p ft))))
+ (dolist (a (ensure-list absent))
+ (if (consp a)
+ (should-not (member a val))
+ (should-not (memq a ft)))))
+ (setq beg (text-property-not-all beg (point-max)
+ 'font-lock-face val)))))))
+
+;; These are from the "Examples" section of
+;; https://modern.ircdocs.horse/formatting.html
+
+(ert-deftest erc-controls-highlight--examples ()
+ (should (eq t erc-interpret-controls-p))
+ (let ((erc-insert-modify-hook '(erc-controls-highlight))
+ erc-kill-channel-hook erc-kill-server-hook erc-kill-buffer-hook)
+ (with-current-buffer (get-buffer-create "#chan")
+ (erc-mode)
+ (setq-local erc-interpret-mirc-color t)
+ (erc--initialize-markers (point) nil)
+
+ (let* ((m "I love \C-c3IRC!\C-c It is the \C-c7best protocol ever!")
+ (msg (erc-format-privmessage "bob" m nil t)))
+ (erc-display-message nil nil (current-buffer) msg))
+ (forward-line -1)
+ (should (search-forward "<bob> " nil t))
+ (save-restriction
+ (narrow-to-region (point) (pos-eol))
+ (erc-goodies-tests--assert-face
+ 0 "I love" 'erc-default-face 'fg:erc-color-face3)
+ (erc-goodies-tests--assert-face
+ 7 " IRC!" 'fg:erc-color-face3)
+ (erc-goodies-tests--assert-face
+ 11 " It is the " 'erc-default-face 'fg:erc-color-face7)
+ (erc-goodies-tests--assert-face
+ 22 "best protocol ever!" 'fg:erc-color-face7))
+
+ (let* ((m "This is a \C-]\C-c13,9cool \C-cmessage")
+ (msg (erc-format-privmessage "alice" m nil t)))
+ (erc-display-message nil nil (current-buffer) msg))
+ (should (search-forward "<alice> " nil t))
+ (save-restriction
+ (narrow-to-region (point) (pos-eol))
+ (erc-goodies-tests--assert-face
+ 0 "this is a " 'erc-default-face 'erc-italic-face)
+ (erc-goodies-tests--assert-face
+ 10 "cool " '(erc-italic-face fg:erc-color-face13 bg:erc-color-face9))
+ (erc-goodies-tests--assert-face
+ 15 "message" 'erc-italic-face
+ '(fg:erc-color-face13 bg:erc-color-face9)))
+
+ (let* ((m "IRC \C-bis \C-c4,12so \C-cgreat\C-o!")
+ (msg (erc-format-privmessage "bob" m nil t)))
+ (erc-display-message nil nil (current-buffer) msg))
+ (should (search-forward "<bob> " nil t))
+ (save-restriction
+ (narrow-to-region (point) (pos-eol))
+ (erc-goodies-tests--assert-face
+ 0 "IRC " 'erc-default-face 'erc-bold-face)
+ (erc-goodies-tests--assert-face
+ 4 "is " 'erc-bold-face '(fg:erc-color-face4 bg:erc-color-face12))
+ (erc-goodies-tests--assert-face
+ 7 "so " '(erc-bold-face fg:erc-color-face4 bg:erc-color-face12))
+ (erc-goodies-tests--assert-face
+ 10 "great" 'erc-bold-face '(fg:erc-color-face4 bg:erc-color-face12))
+ (erc-goodies-tests--assert-face
+ 15 "!" 'erc-default-face 'erc-bold-face))
+
+ (let* ((m (concat "Rules: Don't spam 5\C-c13,8,6\C-c,7,8, "
+ "and especially not \C-b9\C-b\C-]!"))
+ (msg (erc-format-privmessage "alice" m nil t)))
+ (erc-display-message nil nil (current-buffer) msg))
+ (should (search-forward "<alice> " nil t))
+ (save-restriction
+ (narrow-to-region (point) (pos-eol))
+ (erc-goodies-tests--assert-face
+ 0 "Rules: Don't spam 5" 'erc-default-face
+ '(fg:erc-color-face13 bg:erc-color-face8))
+ (erc-goodies-tests--assert-face
+ 19 ",6" '(fg:erc-color-face13 bg:erc-color-face8))
+ (erc-goodies-tests--assert-face
+ 21 ",7,8, and especially not " 'erc-default-face
+ '(fg:erc-color-face13 bg:erc-color-face8 erc-bold-face))
+ (erc-goodies-tests--assert-face
+ 44 "9" 'erc-bold-face 'erc-italic-face)
+ (erc-goodies-tests--assert-face
+ 45 "!" 'erc-italic-face 'erc-bold-face))
+
+ (when noninteractive
+ (kill-buffer)))))
+
+;; Like the test above, this is most intuitive when run interactively.
+;; Hovering over the redacted area should reveal its underlying text
+;; in a high-contrast face.
+
+(ert-deftest erc-controls-highlight--spoilers ()
+ (should (eq t erc-interpret-controls-p))
+ (erc-tests-common-make-server-buf)
+ (with-current-buffer (erc--open-target "#chan")
+ (setq-local erc-interpret-mirc-color t)
+ (let* ((raw (concat "BEGIN "
+ "\C-c0,0 WhiteOnWhite "
+ "\C-c1,1 BlackOnBlack "
+ "\C-c99,99 Default "
+ "\C-o END"))
+ (msg (erc-format-privmessage "bob" raw nil t)))
+ (erc-display-message nil nil (current-buffer) msg))
+ (forward-line -1)
+ (should (search-forward "<bob> " nil t))
+ (save-restriction
+ ;; Narrow to EOL or start of right-side stamp.
+ (narrow-to-region (point) (line-end-position))
+ (save-excursion
+ (search-forward "WhiteOn")
+ (should (eq (get-text-property (point) 'mouse-face)
+ 'erc-spoiler-face))
+ (search-forward "BlackOn")
+ (should (eq (get-text-property (point) 'mouse-face)
+ 'erc-spoiler-face)))
+ ;; Start wtih ERC default face.
+ (erc-goodies-tests--assert-face
+ 0 "BEGIN " 'erc-default-face
+ '(fg:erc-color-face0 bg:erc-color-face0))
+ ;; Masked in all white.
+ (erc-goodies-tests--assert-face
+ 6 "WhiteOnWhite" '(fg:erc-color-face0 bg:erc-color-face0)
+ '(fg:erc-color-face1 bg:erc-color-face1))
+ ;; Masked in all black.
+ (erc-goodies-tests--assert-face
+ 20 "BlackOnBlack" '(fg:erc-color-face1 bg:erc-color-face1) nil)
+ ;; Explicit "default" code ignoerd.
+ (erc-goodies-tests--assert-face
+ 34 "Default" '(erc-default-face)
+ '(fg:erc-color-face1 bg:erc-color-face1))
+ (erc-goodies-tests--assert-face
+ 43 "END" 'erc-default-face nil)))
+ (when noninteractive
+ (erc-tests-common-kill-buffers)))
+
+(ert-deftest erc-controls-highlight--inverse ()
+ (should (eq t erc-interpret-controls-p))
+ (erc-tests-common-make-server-buf)
+ (with-current-buffer (erc--open-target "#chan")
+ (setq-local erc-interpret-mirc-color t)
+ (defvar erc-fill-column)
+ (let* ((erc-fill-column 90)
+ (raw (concat "BEGIN "
+ "\C-c3,13 GreenOnPink "
+ "\C-v PinkOnGreen "
+ "\C-c99,99 ReversedDefault "
+ "\C-v NormalDefault "
+ "\C-o END"))
+ (msg (erc-format-privmessage "bob" raw nil t)))
+ (erc-display-message nil nil (current-buffer) msg))
+ (forward-line -1)
+ (should (search-forward "<bob> " nil t))
+ (save-restriction
+ ;; Narrow to EOL or start of right-side stamp.
+ (narrow-to-region (point) (line-end-position))
+ ;; Baseline.
+ (erc-goodies-tests--assert-face
+ 0 "BEGIN " 'erc-default-face
+ '(fg:erc-color-face0 bg:erc-color-face0))
+ ;; Normal fg/bg combo.
+ (erc-goodies-tests--assert-face
+ 6 "GreenOnPink" '(fg:erc-color-face3 bg:erc-color-face13)
+ '(erc-inverse-face))
+ ;; Reverse of previous, so former-bg on former-fg.
+ (erc-goodies-tests--assert-face
+ 19 "PinkOnGreen"
+ '(erc-inverse-face fg:erc-color-face3 bg:erc-color-face13)
+ nil)
+ ;; The inverse of `default' because reverse still in effect.
+ (erc-goodies-tests--assert-face
+ 32 "ReversedDefault" '(erc-inverse-face erc-default-face)
+ '(fg:erc-color-face3 bg:erc-color-face13))
+ (erc-goodies-tests--assert-face
+ 49 "NormalDefault" '(erc-default-face)
+ '(erc-inverse-face fg:erc-color-face1 bg:erc-color-face1))
+ (erc-goodies-tests--assert-face
+ 64 "END" 'erc-default-face
+ '(fg:erc-color-face0 bg:erc-color-face0))))
+ (when noninteractive
+ (erc-tests-common-kill-buffers)))
+
+;; This is meant to assert two behavioral properties:
+;;
+;; 1) The background is preserved when only a new foreground is
+;; defined, in accordance with this bit from the spec: "If only the
+;; foreground color is set, the background color stays the same."
+;; https://modern.ircdocs.horse/formatting#color
+;;
+;; 2) The same holds true for a new, lone foreground of 99. Rather
+;; than prepend `erc-default-face', this causes the removal of an
+;; existing foreground face and likewise doesn't clobber the
+;; existing background.
+(ert-deftest erc-controls-highlight/default-foreground ()
+ (should (eq t erc-interpret-controls-p))
+ (erc-tests-common-make-server-buf)
+ (with-current-buffer (erc--open-target "#chan")
+ (setq-local erc-interpret-mirc-color t)
+ (defvar erc-fill-column)
+ (let ((erc-fill-column 90))
+ (erc-display-message nil nil (current-buffer)
+ (erc-format-privmessage
+ "bob" (concat "BEGIN "
+ "\C-c03,08 GreenOnYellow "
+ "\C-c99 BlackOnYellow "
+ "\C-o END")
+ nil t)))
+ (forward-line -1)
+ (should (search-forward "<bob> " nil t))
+ (should (erc-tests-common-equal-with-props
+ (erc--remove-text-properties
+ (buffer-substring (point) (line-end-position)))
+ #("BEGIN GreenOnYellow BlackOnYellow END"
+ 0 6 (font-lock-face erc-default-face)
+ 6 21 (font-lock-face (fg:erc-color-face3
+ bg:erc-color-face8
+ erc-default-face))
+ 21 36 (font-lock-face (bg:erc-color-face8
+ erc-default-face))
+ 36 40 (font-lock-face (erc-default-face)))))
+ (should (search-forward "BlackOnYellow"))
+ (let ((faces (get-text-property (point) 'font-lock-face)))
+ (should (equal (face-background (car faces) nil (cdr faces))
+ "yellow")))
+
+ ;; Redefine background color alongside default foreground.
+ (let ((erc-fill-column 90))
+ (erc-display-message nil nil (current-buffer)
+ (erc-format-privmessage
+ "bob" (concat "BEGIN "
+ "\C-c03,08 GreenOnYellow "
+ "\C-c99,07 BlackOnOrange "
+ "\C-o END")
+ nil t)))
+ (should (search-forward "<bob> " nil t))
+ (should (erc-tests-common-equal-with-props
+ (erc--remove-text-properties
+ (buffer-substring (point) (line-end-position)))
+ #("BEGIN GreenOnYellow BlackOnOrange END"
+ 0 6 (font-lock-face erc-default-face)
+ 6 21 (font-lock-face (fg:erc-color-face3
+ bg:erc-color-face8
+ erc-default-face))
+ 21 36 (font-lock-face (bg:erc-color-face7
+ erc-default-face))
+ 36 40 (font-lock-face (erc-default-face)))))
+ (should (search-forward "BlackOnOrange"))
+ (let ((faces (get-text-property (point) 'font-lock-face)))
+ (should (equal (face-background (car faces) nil (cdr faces))
+ "orange")))) ; as opposed to white or black
+ (when noninteractive
+ (erc-tests-common-kill-buffers)))
+
+;; This merely asserts our current interpretation of "default faces":
+;; that they reflect the foreground and background exhibited by normal
+;; chat messages before any control-code formatting is applied (rather
+;; than, e.g., some sort of negation or no-op).
+(ert-deftest erc-controls-highlight/default-background ()
+ (should (eq t erc-interpret-controls-p))
+ (erc-tests-common-make-server-buf)
+ (with-current-buffer (erc--open-target "#chan")
+ (setq-local erc-interpret-mirc-color t)
+ (defvar erc-fill-column)
+ (let ((erc-fill-column 90))
+ (erc-display-message nil nil (current-buffer)
+ (erc-format-privmessage
+ "bob" (concat "BEGIN "
+ "\C-c03,08 GreenOnYellow "
+ "\C-c05,99 BrownOnWhite "
+ "\C-o END")
+ nil t)))
+ (forward-line -1)
+ (should (search-forward "<bob> " nil t))
+ (should (erc-tests-common-equal-with-props
+ (erc--remove-text-properties
+ (buffer-substring (point) (line-end-position)))
+ #("BEGIN GreenOnYellow BrownOnWhite END"
+ 0 6 (font-lock-face erc-default-face)
+ 6 21 (font-lock-face (fg:erc-color-face3
+ bg:erc-color-face8
+ erc-default-face))
+ 21 35 (font-lock-face (fg:erc-color-face5
+ erc-default-face))
+ 35 39 (font-lock-face (erc-default-face)))))
+ ;; Ensure the background is white or black, rather than yellow.
+ (should (search-forward "BrownOnWhite"))
+ (let ((faces (get-text-property (point) 'font-lock-face)))
+ (should (equal (face-background (car faces) nil `(,@(cdr faces) default))
+ (face-background 'default)))))
+ (when noninteractive
+ (erc-tests-common-kill-buffers)))
+
+(defvar erc-goodies-tests--motd
+ ;; This is from ergo's MOTD
+ '((":- - this is \2bold text\17.")
+ (":- - this is \35italics text\17.")
+ (":- - this is \0034red\3 and \0032blue\3 text.")
+ (":- - this is \0034,12red text with a light blue background\3.")
+ (":- - this is a normal escaped dollarsign: $")
+ (":- ")
+ (":- "
+ "\0031,0 00 \0030,1 01 \0030,2 02 \0030,3 03 "
+ "\0031,4 04 \0030,5 05 \0030,6 06 \0031,7 07 ")
+ (":- "
+ "\0031,8 08 \0031,9 09 \0030,10 10 \0031,11 11 "
+ "\0030,12 12 \0031,13 13 \0031,14 14 \0031,15 15 ")
+ (":- ")
+ (":- "
+ "\0030,16 16 \0030,17 17 \0030,18 18 \0030,19 19 "
+ "\0030,20 20 \0030,21 21 \0030,22 22 \0030,23 23 "
+ "\0030,24 24 \0030,25 25 \0030,26 26 \0030,27 27 ")
+ (":- "
+ "\0030,28 28 \0030,29 29 \0030,30 30 \0030,31 31 "
+ "\0030,32 32 \0030,33 33 \0030,34 34 \0030,35 35 "
+ "\0030,36 36 \0030,37 37 \0030,38 38 \0030,39 39 ")
+ (":- "
+ "\0030,40 40 \0030,41 41 \0030,42 42 \0030,43 43 "
+ "\0030,44 44 \0030,45 45 \0030,46 46 \0030,47 47 "
+ "\0030,48 48 \0030,49 49 \0030,50 50 \0030,51 51 ")
+ (":- "
+ "\0030,52 52 \0030,53 53 \0031,54 54 \0031,55 55 "
+ "\0031,56 56 \0031,57 57 \0031,58 58 \0030,59 59 "
+ "\0030,60 60 \0030,61 61 \0030,62 62 \0030,63 63 ")
+ (":- "
+ "\0030,64 64 \0031,65 65 \0031,66 66 \0031,67 67 "
+ "\0031,68 68 \0031,69 69 \0031,70 70 \0031,71 71 "
+ "\0030,72 72 \0030,73 73 \0030,74 74 \0030,75 75 ")
+ (":- "
+ "\0031,76 76 \0031,77 77 \0031,78 78 \0031,79 79 "
+ "\0031,80 80 \0031,81 81 \0031,82 82 \0031,83 83 "
+ "\0031,84 84 \0031,85 85 \0031,86 86 \0031,87 87 ")
+ (":- "
+ "\0030,88 88 \0030,89 89 \0030,90 90 \0030,91 91 "
+ "\0030,92 92 \0030,93 93 \0030,94 94 \0030,95 95 "
+ "\0031,96 96 \0031,97 97 \0031,98 98 \399,99 99 ")
+ (":- ")))
+
+(ert-deftest erc-controls-highlight--motd ()
+ (should (eq t erc-interpret-controls-p))
+ (let ((erc-insert-modify-hook '(erc-controls-highlight))
+ erc-kill-channel-hook erc-kill-server-hook erc-kill-buffer-hook)
+ (with-current-buffer (get-buffer-create "#chan")
+ (erc-mode)
+ (setq-local erc-interpret-mirc-color t)
+ (erc--initialize-markers (point) nil)
+
+ (dolist (parts erc-goodies-tests--motd)
+ (erc-display-message nil 'notice (current-buffer) (string-join parts)))
+
+ ;; Spot check
+ (goto-char (point-min))
+ (should (search-forward " 16 " nil t))
+ (save-restriction
+ (narrow-to-region (point) (pos-eol))
+ (erc-goodies-tests--assert-face
+ 0 " 17 " '(fg:erc-color-face0 (:background "#472100")))
+ (erc-goodies-tests--assert-face
+ 4 " 18 " '(fg:erc-color-face0 (:background "#474700"))
+ '((:background "#472100"))))
+
+ (should (search-forward " 71 " nil t))
+ (save-restriction
+ (narrow-to-region (point) (pos-eol))
+ (erc-goodies-tests--assert-face
+ 0 " 72 " '(fg:erc-color-face0 (:background "#5959ff")))
+ (erc-goodies-tests--assert-face
+ 4 " 73 " '(fg:erc-color-face0 (:background "#c459ff"))
+ '((:background "#5959ff"))))
+
+ (goto-char (point-min))
+ (when noninteractive
+ (kill-buffer)))))
+
+
+;; Among other things, this test also asserts that a local module's
+;; minor-mode toggle is allowed to disable its mode variable as
+;; needed.
+
+(defun erc-goodies-tests--assert-kp-indicator-on ()
+ (should erc--keep-place-indicator-overlay)
+ (should (memq 'erc--keep-place-indicator-on-window-buffer-change
+ window-buffer-change-functions))
+ (should (memq 'erc-keep-place erc-insert-pre-hook))
+ (should (eq erc-keep-place-mode
+ (not (local-variable-p 'erc-insert-pre-hook)))))
+
+(defun erc-goodies-tests--assert-kp-indicator-off ()
+ (should-not (local-variable-p 'erc-insert-pre-hook))
+ (should-not (memq 'erc--keep-place-indicator-on-window-buffer-change
+ window-buffer-change-functions))
+ (should-not erc--keep-place-indicator-overlay))
+
+(defun erc-goodies-tests--kp-indicator-populate ()
+ (erc-display-message nil 'notice (current-buffer)
+ "This buffer is for text that is not saved")
+ (erc-display-message nil 'notice (current-buffer)
+ "and for lisp evaluation")
+ (should (search-forward "saved" nil t))
+ (erc-keep-place-move nil)
+ (goto-char erc-input-marker))
+
+(defun erc-goodies-tests--keep-place-indicator (test)
+ (erc-keep-place-mode -1)
+ (with-current-buffer (erc-tests-common-make-server-buf
+ "*erc-keep-place-indicator-mode*")
+ (let (erc-connect-pre-hook
+ erc-modules)
+
+ (ert-info ("Clean slate")
+ (erc-goodies-tests--assert-kp-indicator-off)
+ (should-not erc-keep-place-mode)
+ (should-not (memq 'keep-place erc-modules)))
+
+ (funcall test))
+
+ (when noninteractive
+ (erc-keep-place-indicator-mode -1)
+ (erc-keep-place-mode -1)
+ (should-not (member 'erc-keep-place
+ (default-value 'erc-insert-pre-hook)))
+ (should-not (local-variable-p 'erc-insert-pre-hook))
+ (erc-tests-common-kill-buffers))))
+
+(ert-deftest erc-keep-place-indicator-mode--no-global ()
+ (erc-goodies-tests--keep-place-indicator
+ (lambda ()
+
+ (ert-info ("Value t")
+ (should (eq erc-keep-place-indicator-buffer-type t))
+ (erc-keep-place-indicator-mode +1)
+ (erc-goodies-tests--assert-kp-indicator-on)
+ (goto-char (point-min)))
+
+ (erc-keep-place-indicator-mode -1)
+ (erc-goodies-tests--assert-kp-indicator-off)
+
+ (ert-info ("Value `target'")
+ (let ((erc-keep-place-indicator-buffer-type 'target))
+ ;; No-op because server buffer.
+ (erc-keep-place-indicator-mode +1)
+ (erc-goodies-tests--assert-kp-indicator-off)
+ ;; Spoof target buffer (no longer no-op).
+ (setq erc--target (erc--target-from-string "#chan"))
+ (erc-keep-place-indicator-mode +1)
+ (erc-goodies-tests--assert-kp-indicator-on)))
+
+ (erc-keep-place-indicator-mode -1)
+ (erc-goodies-tests--assert-kp-indicator-off)
+
+ (ert-info ("Value `server'")
+ (let ((erc-keep-place-indicator-buffer-type 'server))
+ (erc-keep-place-indicator-mode +1)
+ (erc-goodies-tests--assert-kp-indicator-off)
+ (setq erc--target nil)
+ (erc-keep-place-indicator-mode +1)
+ (erc-goodies-tests--assert-kp-indicator-on)))
+
+ ;; Populate buffer
+ (erc-goodies-tests--kp-indicator-populate)
+
+ (ert-info ("Indicator survives reconnect")
+ (let ((erc--server-reconnecting (buffer-local-variables)))
+ (cl-letf (((symbol-function 'erc-server-connect) #'ignore))
+ (erc-open "localhost" 6667 "tester" "Tester" 'connect
+ nil nil nil nil nil "tester" nil)))
+ (erc-goodies-tests--assert-kp-indicator-on)
+ (should (= (point) erc-input-marker))
+ (goto-char (overlay-start erc--keep-place-indicator-overlay))
+ (should (looking-at (rx "*** This buffer is for text")))))))
+
+(ert-deftest erc-keep-place-indicator-mode--global ()
+ (erc-goodies-tests--keep-place-indicator
+ (lambda ()
+
+ (push 'keep-place erc-modules)
+
+ (ert-info ("Value t")
+ (should (eq erc-keep-place-indicator-buffer-type t))
+ (erc-keep-place-indicator-mode +1)
+ (erc-goodies-tests--assert-kp-indicator-on)
+ ;; Local module activates global `keep-place'.
+ (should erc-keep-place-mode)
+ ;; Does not register local version of hook (otherwise would run
+ ;; twice).
+ (should-not (local-variable-p 'erc-insert-pre-hook))
+ (goto-char (point-min)))
+
+ (erc-keep-place-indicator-mode -1)
+ (erc-goodies-tests--assert-kp-indicator-off)
+ (should erc-keep-place-mode)
+ (should (member 'erc-keep-place erc-insert-pre-hook))
+
+ (ert-info ("Value `target'")
+ (let ((erc-keep-place-indicator-buffer-type 'target))
+ ;; No-op because server buffer.
+ (erc-keep-place-indicator-mode +1)
+ (erc-goodies-tests--assert-kp-indicator-off)
+ ;; Does not interfere with global activation state.
+ (should erc-keep-place-mode)
+ (should (member 'erc-keep-place erc-insert-pre-hook))
+ ;; Morph into a target buffer (no longer no-op).
+ (setq erc--target (erc--target-from-string "#chan"))
+ (erc-keep-place-indicator-mode +1)
+ (erc-goodies-tests--assert-kp-indicator-on)
+ ;; Does not register local version of hook.
+ (should-not (local-variable-p 'erc-insert-pre-hook))))
+
+ (erc-keep-place-indicator-mode -1)
+ (erc-goodies-tests--assert-kp-indicator-off)
+ (should erc-keep-place-mode)
+ (should (member 'erc-keep-place erc-insert-pre-hook))
+
+ (ert-info ("Value `server'")
+ (let ((erc-keep-place-indicator-buffer-type 'server))
+ ;; No-op because we're now a target buffer.
+ (erc-keep-place-indicator-mode +1)
+ (erc-goodies-tests--assert-kp-indicator-off)
+ (should erc-keep-place-mode)
+ (should (member 'erc-keep-place erc-insert-pre-hook))
+ ;; Back to server.
+ (setq erc--target nil)
+ (erc-keep-place-indicator-mode +1)
+ (erc-goodies-tests--assert-kp-indicator-on)
+ (should-not (local-variable-p 'erc-insert-pre-hook))))
+
+ (ert-info ("Local adapts to global toggle")
+ (erc-keep-place-mode -1)
+ (should-not (member 'erc-keep-place
+ (default-value 'erc-insert-pre-hook)))
+ (should (member 'erc-keep-place erc-insert-pre-hook))
+ (erc-goodies-tests--assert-kp-indicator-on)
+ (erc-keep-place-mode +1)
+ (should (member 'erc-keep-place (default-value 'erc-insert-pre-hook)))
+ (should-not (local-variable-p 'erc-insert-pre-hook))
+ (erc-goodies-tests--assert-kp-indicator-on))
+
+ ;; Populate buffer
+ (erc-goodies-tests--kp-indicator-populate)
+
+ (ert-info ("Indicator survives reconnect")
+ (let ((erc--server-reconnecting (buffer-local-variables)))
+ (cl-letf (((symbol-function 'erc-server-connect) #'ignore))
+ (erc-open "localhost" 6667 "tester" "Tester" 'connect
+ nil nil nil nil nil "tester" nil)))
+ (erc-goodies-tests--assert-kp-indicator-on)
+ (should erc-keep-place-mode)
+ (should (member 'erc-keep-place erc-insert-pre-hook))
+ (should (= (point) erc-input-marker))
+ (goto-char (overlay-start erc--keep-place-indicator-overlay))
+ (should (looking-at (rx "*** This buffer is for text")))))))
+
+(ert-deftest erc--get-inserted-msg-beg/readonly ()
+ (erc-tests-common-assert-get-inserted-msg-readonly-with
+ #'erc-tests-common-assert-get-inserted-msg/basic
+ (lambda (arg) (should (= 3 (erc--get-inserted-msg-beg arg))))))
+
+(ert-deftest erc--get-inserted-msg-end/readonly ()
+ (erc-tests-common-assert-get-inserted-msg-readonly-with
+ #'erc-tests-common-assert-get-inserted-msg/basic
+ (lambda (arg) (should (= 11 (erc--get-inserted-msg-end arg))))))
+
+(ert-deftest erc--get-inserted-msg-bounds/readonly ()
+ (erc-tests-common-assert-get-inserted-msg-readonly-with
+ #'erc-tests-common-assert-get-inserted-msg/basic
+ (lambda (arg)
+ (should (equal '(3 . 11) (erc--get-inserted-msg-bounds arg))))))
+
+
+;;; erc-goodies-tests.el ends here
diff --git a/test/lisp/erc/erc-networks-tests.el b/test/lisp/erc/erc-networks-tests.el
index 370502f62d6..0d8861f2167 100644
--- a/test/lisp/erc/erc-networks-tests.el
+++ b/test/lisp/erc/erc-networks-tests.el
@@ -18,27 +18,24 @@
;; along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>.
;;; Code:
+(require 'erc-compat)
(require 'ert-x) ; cl-lib
-(require 'erc)
+(eval-and-compile
+ (let ((load-path (cons (ert-resource-directory) load-path)))
+ (require 'erc-tests-common)))
(defun erc-networks-tests--create-dead-proc (&optional buf)
(let ((p (start-process "true" (or buf (current-buffer)) "true")))
(while (process-live-p p) (sit-for 0.1))
p))
-(defun erc-networks-tests--create-live-proc (&optional buf)
- (let ((proc (start-process "sleep" (or buf (current-buffer)) "sleep" "1")))
- (set-process-query-on-exit-flag proc nil)
- proc))
+(defun erc-networks-tests--create-live-proc ()
+ (erc-tests-common-init-server-proc "sleep" "1"))
;; When we drop 27, call `get-buffer-create with INHIBIT-BUFFER-HOOKS.
(defun erc-networks-tests--clean-bufs ()
- (let (erc-kill-channel-hook
- erc-kill-server-hook
- erc-kill-buffer-hook)
- (dolist (buf (erc-buffer-list))
- (kill-buffer buf))))
+ (erc-tests-common-kill-buffers))
(defun erc-networks-tests--bufnames (prefix)
(let* ((case-fold-search)
@@ -623,11 +620,6 @@
:symbol 'foonet/dummy
:parts [foonet "dummy"]
:len 2)
- ;; `erc-kill-buffer-function' uses legacy target detection
- ;; but falls back on buffer name, so no need for:
- ;;
- ;; erc-default-recipients '("#a")
- ;;
erc--target (erc--target-from-string "#a")
erc-server-process (with-temp-buffer
(erc-networks-tests--create-dead-proc)))
@@ -1206,7 +1198,7 @@
calls)
(erc-mode)
- (cl-letf (((symbol-function 'erc-display-line)
+ (cl-letf (((symbol-function 'erc--route-insertion)
(lambda (&rest r) (push r calls))))
(ert-info ("Signals when `erc-server-announced-name' unset")
@@ -1233,10 +1225,7 @@
:contents "MOTD File is missing")))
(erc-mode) ; boilerplate displayable start (needs `erc-server-process')
- (insert "\n\n")
- (setq erc-input-marker (make-marker) erc-insert-marker (make-marker))
- (set-marker erc-insert-marker (point-max))
- (erc-display-prompt) ; boilerplate displayable end
+ (erc--initialize-markers (point) nil)
(erc-networks--ensure-announced erc-server-process parsed)
(goto-char (point-min))
@@ -1277,9 +1266,9 @@
(with-current-buffer old-buf
(erc-mode)
(insert "*** Old buf")
+ (erc--initialize-markers (point) nil)
(setq erc-network 'FooNet
erc-server-current-nick "tester"
- erc-insert-marker (set-marker (make-marker) (point-max))
erc-server-process old-proc
erc-networks--id (erc-networks--id-create nil)))
@@ -1328,10 +1317,10 @@
erc-reuse-buffers)
(with-current-buffer old-buf
(erc-mode)
+ (erc--initialize-markers (point) nil)
(insert "*** Old buf")
(setq erc-network 'FooNet
erc-server-current-nick "tester"
- erc-insert-marker (set-marker (make-marker) (point-max))
erc-server-process old-proc
erc-networks--id (erc-networks--id-create nil)))
(with-current-buffer (get-buffer-create "#chan")
@@ -1360,7 +1349,7 @@
(should-not
(erc-server-process-alive
(should (get-buffer "#chan/irc.foonet.org"))))
- (with-current-buffer (get-buffer "#chan/irc.foonet.org")
+ (with-current-buffer "#chan/irc.foonet.org"
(should-not erc-server-connected)
(should (eq erc-server-process old-proc))
(erc-with-server-buffer
@@ -1377,10 +1366,10 @@
(with-current-buffer old-buf
(erc-mode)
+ (erc--initialize-markers (point) nil)
(insert "*** Old buf")
(setq erc-network 'FooNet
erc-server-current-nick "tester"
- erc-insert-marker (set-marker (make-marker) (point-max))
erc-server-process old-proc
erc-networks--id (erc-networks--id-create nil)))
@@ -1415,10 +1404,10 @@
(with-current-buffer old-buf
(erc-mode)
+ (erc--initialize-markers (point) nil)
(insert "*** Old buf")
(setq erc-network 'FooNet
erc-networks--id (erc-networks--id-create 'MySession)
- erc-insert-marker (set-marker (make-marker) (point-max))
erc-server-process old-proc))
(with-current-buffer (get-buffer-create "#chan")
@@ -1450,14 +1439,16 @@
(let* (erc-kill-server-hook
erc-insert-modify-hook
(old-buf (get-buffer-create "FooNet"))
- (old-proc (erc-networks-tests--create-live-proc old-buf))) ; live
+ ;;
+ old-proc) ; live
(with-current-buffer old-buf
(erc-mode)
+ (setq old-proc (erc-networks-tests--create-live-proc))
+ (erc--initialize-markers (point) nil)
(insert "*** Old buf")
(setq erc-network 'FooNet
erc-server-current-nick "tester"
- erc-insert-marker (set-marker (make-marker) (point-max))
erc-server-process old-proc
erc-networks--id (erc-networks--id-create nil))
(should (erc-server-process-alive)))
@@ -1473,12 +1464,15 @@
(ert-info ("New buffer rejected, abandoned, not killed")
(with-current-buffer (get-buffer-create "irc.foonet.org")
(erc-mode)
+ (erc--initialize-markers (point) nil)
(setq erc-network 'FooNet
erc-server-current-nick "tester"
- erc-insert-marker (set-marker (make-marker) (point-max))
erc-server-process (erc-networks-tests--create-live-proc)
erc-networks--id (erc-networks--id-create nil))
- (should-not (erc-networks--rename-server-buffer erc-server-process))
+ (set-process-sentinel erc-server-process #'ignore)
+ (erc-display-message nil 'notice (current-buffer) "notice")
+ (with-silent-modifications
+ (should-not (erc-networks--rename-server-buffer erc-server-process)))
(should (eq erc-active-buffer old-buf))
(should-not (erc-server-process-alive))
(should (string= (buffer-name) "irc.foonet.org"))
@@ -1508,10 +1502,10 @@
(with-current-buffer old-buf
(erc-mode)
(insert "*** Old buf")
+ (erc--initialize-markers (point) nil)
(setq erc-network 'FooNet
erc-server-current-nick "tester"
erc-server-announced-name "us-east.foonet.org"
- erc-insert-marker (set-marker (make-marker) (point-max))
erc-server-process old-proc
erc--isupport-params (make-hash-table)
erc-networks--id (erc-networks--id-create nil))
@@ -1560,10 +1554,10 @@
(with-current-buffer old-buf
(erc-mode)
(insert "*** Old buf")
+ (erc--initialize-markers (point) nil)
(setq erc-network 'FooNet
erc-server-current-nick "tester"
erc-server-announced-name "us-west.foonet.org"
- erc-insert-marker (set-marker (make-marker) (point-max))
erc-server-process old-proc
erc--isupport-params (make-hash-table)
erc-networks--id (erc-networks--id-create nil))
@@ -1750,4 +1744,68 @@
(should (eq (erc-networks--determine)
erc-networks--name-missing-sentinel))))
+(ert-deftest erc-ports-list ()
+ (with-suppressed-warnings ((obsolete erc-server-alist))
+ (let* ((srv (assoc "Libera.Chat: Random server" erc-server-alist)))
+ (should (equal (erc-ports-list (nth 3 srv))
+ '(6665 6666 6667 8000 8001 8002)))
+ (should (equal (erc-ports-list (nth 4 srv))
+ '(6697 7000 7070))))
+
+ (let* ((srv (assoc "Libera.Chat: Random Europe server" erc-server-alist)))
+ (should (equal (erc-ports-list (nth 3 srv)) '(6667)))
+ (should (equal (erc-ports-list (nth 4 srv)) '(6697))))
+
+ (let* ((srv (assoc "OFTC: Random server" erc-server-alist)))
+ (should (equal (erc-ports-list (nth 3 srv))
+ '(6667 6668 6669 6670 7000)))
+ (should (equal (erc-ports-list (nth 4 srv))
+ '(6697 9999))))))
+
+(ert-deftest erc-networks--examine-targets ()
+ (with-current-buffer (erc-tests-common-make-server-buf "foonet")
+ (erc--open-target "#chan")
+ (erc--open-target "#spam"))
+
+ (with-current-buffer (erc-tests-common-make-server-buf "barnet")
+ (with-current-buffer (erc--open-target "*query")
+ (setq erc-networks--id nil))
+ (with-current-buffer (erc--open-target "#chan")
+ (let ((calls ())
+ (snap (lambda (parameter)
+ (list parameter
+ (erc-target)
+ (erc-networks--id-symbol erc-networks--id)))))
+
+ ;; Search for "#chan" dupes among targets of all servers.
+ (should (equal
+ (erc-networks--examine-targets erc-networks--id erc--target
+ (lambda () (push (funcall snap 'ON-DUPE) calls))
+ (lambda () (push (funcall snap 'ON-COLL) calls)))
+ (list (get-buffer "#chan@foonet")
+ (get-buffer "#chan@barnet"))))
+
+ (should (equal (pop calls) '(ON-DUPE "#chan" barnet)))
+ (should (equal (pop calls) '(ON-COLL "#chan" foonet)))
+ (should-not calls)
+ (should-not (get-buffer "#chan"))
+ (should (get-buffer "#chan@barnet"))
+ (should (get-buffer "#chan@foonet"))
+
+ ;; Search for "*query" dupes among targets of all servers.
+ (should (equal (erc-networks--examine-targets erc-networks--id
+ (buffer-local-value 'erc--target
+ (get-buffer "*query"))
+ (lambda () (push (funcall snap 'ON-DUPE) calls))
+ (lambda () (push (funcall snap 'ON-COLL) calls)))
+ (list (get-buffer "*query"))))
+
+ (should (equal (pop calls) '(ON-DUPE "*query" barnet)))
+ (should-not calls)))
+
+ (goto-char (point-min))
+ (should (search-forward "Missing network session" nil t)))
+
+ (erc-tests-common-kill-buffers))
+
;;; erc-networks-tests.el ends here
diff --git a/test/lisp/erc/erc-nicks-tests.el b/test/lisp/erc/erc-nicks-tests.el
new file mode 100644
index 00000000000..08080d249d5
--- /dev/null
+++ b/test/lisp/erc/erc-nicks-tests.el
@@ -0,0 +1,571 @@
+;;; erc-nicks-tests.el --- Tests for erc-nicks -*- lexical-binding:t -*-
+
+;; Copyright (C) 2023-2024 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 <https://www.gnu.org/licenses/>.
+
+;;; Commentary:
+
+;; Unlike most of ERC's tests, the ones in this file can be run
+;; interactively in the same session.
+
+;; TODO:
+;;
+;; * Add mock session (or scenario) with buffer snapshots, like those
+;; in erc-fill-tests.el. (Should probably move helpers to a common
+;; library under ./resources.)
+
+;;; Code:
+
+(require 'ert-x)
+(require 'erc-nicks)
+
+;; This function replicates the behavior of older "invert" strategy
+;; implementations from EmacsWiki, etc. The values for the lower and
+;; upper bounds (0.33 and 0.66) are likewise inherited. See
+;; `erc-nicks--invert-classic--dark' below for one reason its results
+;; may not be plainly obvious.
+(defun erc-nicks-tests--invert-classic (color)
+ (if (pcase (erc-nicks--bg-mode)
+ ('dark (< (erc-nicks--get-luminance color) (/ 1 3.0)))
+ ('light (> (erc-nicks--get-luminance color) (/ 2 3.0))))
+ (list (- 1.0 (nth 0 color)) (- 1.0 (nth 1 color)) (- 1.0 (nth 2 color)))
+ color))
+
+
+(ert-deftest erc-nicks--get-luminance ()
+ (should (eql 0.0 (erc-nicks--get-luminance "black")))
+ (should (eql 1.0 (erc-nicks--get-luminance "white")))
+ (should (eql 21.0 (/ (+ 0.05 1.0) (+ 0.05 0.0))))
+
+ ;; RGB floats from a `display-graphic-p' session.
+ (let ((a (erc-nicks--get-luminance ; #9439ad
+ '(0.5803921568627451 0.2235294117647059 0.6784313725490196)))
+ (b (erc-nicks--get-luminance ; #ae54c7
+ '(0.6823529411764706 0.32941176470588235 0.7803921568627451)))
+ (c (erc-nicks--get-luminance ; #d19ddf
+ '(0.8196078431372549 0.615686274509804 0.8745098039215686)))
+ (d (erc-nicks--get-luminance ; #f5e8f8
+ '(0.9607843137254902 0.9098039215686274 0.9725490196078431))))
+ ;; Low, med, high contrast comparisons against known values from
+ ;; an external source.
+ (should (eql 1.42 (/ (round (* 100 (/ (+ 0.05 b) (+ 0.05 a)))) 100.0)))
+ (should (eql 2.78 (/ (round (* 100 (/ (+ 0.05 c) (+ 0.05 a)))) 100.0)))
+ (should (eql 5.16 (/ (round (* 100 (/ (+ 0.05 d) (+ 0.05 a)))) 100.0)))))
+
+(ert-deftest erc-nicks-invert--classic ()
+ (let ((convert (lambda (n) (apply #'color-rgb-to-hex
+ (erc-nicks-tests--invert-classic
+ (color-name-to-rgb n))))))
+ (let ((erc-nicks--bg-mode-value 'dark))
+ (should (equal (funcall convert "white") "#ffffffffffff"))
+ (should (equal (funcall convert "black") "#ffffffffffff"))
+ (should (equal (funcall convert "green") "#0000ffff0000")))
+ (let ((erc-nicks--bg-mode-value 'light))
+ (should (equal (funcall convert "white") "#000000000000"))
+ (should (equal (funcall convert "black") "#000000000000"))
+ (should (equal (funcall convert "green") "#ffff0000ffff")))))
+
+(ert-deftest erc-nicks--get-contrast ()
+ (should (= 21.0 (erc-nicks--get-contrast "white" "black")))
+ (should (= 21.0 (erc-nicks--get-contrast "black" "white")))
+ (should (= 1.0 (erc-nicks--get-contrast "black" "black")))
+ (should (= 1.0 (erc-nicks--get-contrast "white" "white"))))
+
+(defun erc-nicks-tests--print-contrast (fn color)
+ (let* ((erc-nicks-color-adjustments (list fn))
+ (result (erc-nicks--reduce color))
+ (start (point)))
+ (insert (format "%16s%-16s%16s%-16s\n"
+ (concat color "-")
+ (concat ">" result)
+ (concat color " ")
+ (concat " " result)))
+ (put-text-property (+ start 32) (+ start 48) 'face
+ (list :background color :foreground result))
+ (put-text-property (+ start 48) (+ start 64) 'face
+ (list :background result :foreground color))
+ result))
+
+(ert-deftest erc-nicks--invert-classic--light ()
+ (let ((erc-nicks--bg-luminance 1.0)
+ (erc-nicks--bg-mode-value 'light)
+ (show (lambda (c) (erc-nicks-tests--print-contrast
+ #'erc-nicks-tests--invert-classic c))))
+
+ (with-current-buffer (get-buffer-create
+ "*erc-nicks--invert-classic--light*")
+ (should (equal "#000000000000" (funcall show "white")))
+ (should (equal "#000000000000" (funcall show "black")))
+ (should (equal "#ffff00000000" (funcall show "red")))
+ (should (equal "#ffff0000ffff" (funcall show "green"))) ; magenta
+ (should (equal "#00000000ffff" (funcall show "blue")))
+
+ (unless noninteractive
+ (should (equal "#bbbbbbbbbbbb" (funcall show "#bbbbbbbbbbbb")))
+ (should (equal "#cccccccccccc" (funcall show "#cccccccccccc")))
+ (should (equal "#222122212221" (funcall show "#dddddddddddd")))
+ (should (equal "#111011101110" (funcall show "#eeeeeeeeeeee"))))
+
+ (when noninteractive
+ (kill-buffer)))))
+
+;; This shows that the output can be darker (have less contrast) than
+;; the input.
+(ert-deftest erc-nicks--invert-classic--dark ()
+ (let ((erc-nicks--bg-luminance 0.0)
+ (erc-nicks--bg-mode-value 'dark)
+ (show (lambda (c) (erc-nicks-tests--print-contrast
+ #'erc-nicks-tests--invert-classic c))))
+
+ (with-current-buffer (get-buffer-create
+ "*erc-nicks--invert-classic--dark*")
+ (should (equal "#ffffffffffff" (funcall show "white")))
+ (should (equal "#ffffffffffff" (funcall show "black")))
+ (should (equal "#0000ffffffff" (funcall show "red"))) ; cyan
+ (should (equal "#0000ffff0000" (funcall show "green")))
+ (should (equal "#ffffffff0000" (funcall show "blue"))) ; yellow
+
+ (unless noninteractive
+ (should (equal "#aaaaaaaaaaaa" (funcall show "#555555555555")))
+ (should (equal "#999999999999" (funcall show "#666666666666")))
+ (should (equal "#888888888888" (funcall show "#777777777777")))
+ (should (equal "#777777777777" (funcall show "#888888888888")))
+ (should (equal "#666666666666" (funcall show "#999999999999")))
+ (should (equal "#aaaaaaaaaaaa" (funcall show "#aaaaaaaaaaaa"))))
+
+ (when noninteractive
+ (kill-buffer)))))
+
+;; These are the same as the legacy version but work in terms of
+;; contrast ratios. Converting the original bounds to contrast ratios
+;; (assuming pure white and black backgrounds) gives:
+;;
+;; min-lum of 0.33 ~~> 1.465
+;; max-lum of 0.66 ~~> 7.666
+;;
+(ert-deftest erc-nicks-invert--light ()
+ (let ((erc-nicks--bg-luminance 1.0)
+ (erc-nicks--bg-mode-value 'light)
+ (erc-nicks-contrast-range '(1.465))
+ (show (lambda (c) (erc-nicks-tests--print-contrast
+ #'erc-nicks-invert c))))
+
+ (with-current-buffer (get-buffer-create
+ "*erc-nicks--invert-classic--light*")
+ (should (equal "#000000000000" (funcall show "white")))
+ (should (equal "#000000000000" (funcall show "black")))
+ (should (equal "#ffff00000000" (funcall show "red")))
+ (should (equal "#ffff0000ffff" (funcall show "green"))) ; magenta
+ (should (equal "#00000000ffff" (funcall show "blue")))
+
+ (unless noninteractive
+ (should (equal "#bbbbbbbbbbbb" (funcall show "#bbbbbbbbbbbb")))
+ (should (equal "#cccccccccccc" (funcall show "#cccccccccccc")))
+ (should (equal "#222122212221" (funcall show "#dddddddddddd")))
+ (should (equal "#111011101110" (funcall show "#eeeeeeeeeeee"))))
+
+ (when noninteractive
+ (kill-buffer)))))
+
+(ert-deftest erc-nicks-invert--dark ()
+ (let ((erc-nicks--bg-luminance 0.0)
+ (erc-nicks--bg-mode-value 'dark)
+ (erc-nicks-contrast-range '(7.666))
+ (show (lambda (c) (erc-nicks-tests--print-contrast
+ #'erc-nicks-invert c))))
+
+ (with-current-buffer (get-buffer-create "*erc-nicks-invert--dark*")
+ (should (equal "#ffffffffffff" (funcall show "white")))
+ (should (equal "#ffffffffffff" (funcall show "black")))
+ (should (equal "#0000ffffffff" (funcall show "red"))) ; cyan
+ (should (equal "#0000ffff0000" (funcall show "green")))
+ (should (equal "#ffffffff0000" (funcall show "blue"))) ; yellow
+
+ (unless noninteractive
+ (should (equal "#aaaaaaaaaaaa" (funcall show "#555555555555")))
+ (should (equal "#999999999999" (funcall show "#666666666666")))
+ (should (equal "#888888888888" (funcall show "#777777777777")))
+ (should (equal "#888888888888" (funcall show "#888888888888")))
+ (should (equal "#999999999999" (funcall show "#999999999999"))))
+
+ (when noninteractive
+ (kill-buffer)))))
+
+(ert-deftest erc-nicks-add-contrast ()
+ (let ((erc-nicks--bg-luminance 1.0)
+ (erc-nicks--bg-mode-value 'light)
+ (erc-nicks--fg-rgb '(0.0 0.0 0.0))
+ (erc-nicks-bg-color "white")
+ (erc-nicks-contrast-range '(3.5))
+ (show (lambda (c) (erc-nicks-tests--print-contrast
+ #'erc-nicks-add-contrast c))))
+
+ (with-current-buffer (get-buffer-create "*erc-nicks-add-contrast*")
+ (should (equal "#893a893a893a" (funcall show "white")))
+ (should (equal "#893a893a893a" (funcall show "#893a893a893a")))
+ (should (equal "#000000000000" (funcall show "black")))
+ (should (equal "#ffff00000000" (funcall show "red")))
+ (should (equal "#0000a12e0000" (funcall show "green")))
+ (should (equal "#00000000ffff" (funcall show "blue")))
+
+ ;; When the input is already near the desired ratio, the result
+ ;; may not be in bounds, only close. But the difference is
+ ;; usually imperceptible.
+ (unless noninteractive
+ ;; Well inside (light slate gray)
+ (should (equal "#777788889999" (funcall show "#777788889999")))
+ ;; Slightly outside -> just outside
+ (should (equal "#7c498bd39b5c" (funcall show "#88889999aaaa")))
+ ;; Just outside -> just inside
+ (should (equal "#7bcc8b479ac0" (funcall show "#7c498bd39b5c")))
+ ;; Just inside
+ (should (equal "#7bcc8b479ac0" (funcall show "#7bcc8b479ac0"))))
+
+ (when noninteractive
+ (kill-buffer)))))
+
+(ert-deftest erc-nicks-cap-contrast ()
+ (should (= 12.5 (cdr erc-nicks-contrast-range)))
+ (let ((erc-nicks--bg-luminance 1.0)
+ (erc-nicks--bg-mode-value 'light)
+ (erc-nicks--fg-rgb '(0.0 0.0 0.0))
+ (erc-nicks-bg-color "white")
+ (show (lambda (c) (erc-nicks-tests--print-contrast
+ #'erc-nicks-cap-contrast c))))
+
+ (with-current-buffer (get-buffer-create "*erc-nicks-remove-contrast*")
+ (should (equal (funcall show "black") "#34e534e534e5" )) ; 21.0 -> 12.14
+ (should ; 12.32 -> 12.32 (same)
+ (equal (funcall show "#34e534e534e5") "#34e534e534e5"))
+ (should (equal (funcall show "white") "#ffffffffffff"))
+
+ (unless noninteractive
+ (should (equal (funcall show "DarkRed") "#8b8b00000000"))
+ (should (equal (funcall show "DarkGreen") "#000064640000"))
+ ;; 15.29 -> 12.38
+ (should (equal (funcall show "DarkBlue") "#1cf11cf198b5"))
+
+ ;; 12.50 -> 12.22
+ (should (equal (funcall show "#33e033e033e0") "#34ab34ab34ab"))
+ ;; 12.57 -> 12.28
+ (should (equal (funcall show "#338033803380") "#344c344c344c"))
+ ;; 12.67 -> 12.37
+ (should (equal (funcall show "#330033003300") "#33cc33cc33cc")))
+
+ (when noninteractive
+ (kill-buffer)))))
+
+(ert-deftest erc-nicks--skip-p ()
+ ;; Baseline
+ (should-not (erc-nicks--skip-p 'bold nil 10000000))
+ (should-not (erc-nicks--skip-p '(bold) nil 10000000))
+ (should-not (erc-nicks--skip-p nil '(bold) 10000000))
+ (should-not (erc-nicks--skip-p 'bold '(bold) 0))
+ (should-not (erc-nicks--skip-p '(bold) '(bold) 0))
+ (should-not (erc-nicks--skip-p 'bold '(foo bold) 0))
+ (should-not (erc-nicks--skip-p '((:inherit bold)) '(bold) 1))
+ (should (erc-nicks--skip-p 'bold '(bold) 1))
+ (should (erc-nicks--skip-p 'bold '(fake bold) 1))
+ (should (erc-nicks--skip-p 'bold '(foo bar bold) 1))
+ (should (erc-nicks--skip-p '(bold) '(bold) 1))
+ (should (erc-nicks--skip-p '((bold)) '(bold) 1))
+ (should (erc-nicks--skip-p '((((bold)))) '(bold) 1))
+ (should (erc-nicks--skip-p '(bold) '(foo bold) 1))
+ (should (erc-nicks--skip-p '(:inherit bold) '((:inherit bold)) 1))
+ (should (erc-nicks--skip-p '((:inherit bold)) '((:inherit bold)) 1))
+ (should (erc-nicks--skip-p '(((:inherit bold))) '((:inherit bold)) 1))
+
+ ;; Composed
+ (should-not (erc-nicks--skip-p '(italic bold) '(bold) 1))
+ (should-not (erc-nicks--skip-p '((italic) bold) '(bold) 1))
+ (should-not (erc-nicks--skip-p '(italic (bold)) '(bold) 1))
+ (should (erc-nicks--skip-p '(italic bold) '(bold) 2))
+ (should (erc-nicks--skip-p '((italic) bold) '(bold) 2))
+ (should (erc-nicks--skip-p '(italic (bold)) '(bold) 2))
+
+ (should-not (erc-nicks--skip-p '(italic default bold) '(bold) 2))
+ (should-not (erc-nicks--skip-p '((default italic) bold) '(bold) 2))
+ (should-not (erc-nicks--skip-p '(italic (default bold)) '(bold) 2))
+ (should-not (erc-nicks--skip-p '((default italic) (bold shadow)) '(bold) 2))
+ (should (erc-nicks--skip-p '((default italic) bold) '(bold) 3))
+ (should (erc-nicks--skip-p '(italic (default bold)) '(bold) 3))
+ (should (erc-nicks--skip-p '((default italic) (bold shadow)) '(bold) 3))
+ (should (erc-nicks--skip-p '(italic (default (bold shadow))) '(bold) 3)))
+
+(ert-deftest erc-nicks--trim ()
+ (should (equal (erc-nicks--trim "Bob`") "bob"))
+ (should (equal (erc-nicks--trim "Bob``") "bob"))
+
+ ;; `erc--casemapping-rfc1459'
+ (let ((erc-nicks-ignore-chars "^"))
+ (should (equal (erc-nicks--trim "Bob~") "bob^"))
+ (should (equal (erc-nicks--trim "Bob^") "bob"))))
+
+(defvar erc-nicks-tests--fake-face-list nil)
+
+;; Since we can't delete faces, mock `face-list' to only return those
+;; in `erc-nicks--face-table' created by the current test.
+(defun erc-nicks-tests--face-list ()
+ (let ((table (buffer-local-value 'erc-nicks--face-table
+ (get-buffer "foonet")))
+ out)
+ (maphash (lambda (k v)
+ (when (member k erc-nicks-tests--fake-face-list)
+ (push v out)))
+ table)
+ (nreverse out)))
+
+(defun erc-nicks-tests--create-session (test alice bob)
+ (should-not (memq 'nicks erc-modules))
+ (advice-add 'face-list :override #'erc-nicks-tests--face-list)
+ (let ((erc-modules (cons 'nicks erc-modules))
+ (inhibit-message noninteractive)
+ (erc-nicks-tests--fake-face-list
+ (list (downcase alice) (downcase bob)))
+ erc-kill-channel-hook erc-kill-server-hook erc-kill-buffer-hook)
+
+ (with-current-buffer
+ (cl-letf
+ (((symbol-function 'erc-server-connect)
+ (lambda (&rest _)
+ (setq erc-server-process
+ (start-process "sleep" (current-buffer) "sleep" "1"))
+ (set-process-query-on-exit-flag erc-server-process nil))))
+
+ (erc-open "localhost" 6667 "tester" "Tester" 'connect
+ nil nil nil nil nil "tester"))
+
+ (let ((inhibit-message noninteractive))
+ (dolist (line (split-string "\
+:irc.foonet.org 004 tester irc.foonet.org irc.d abc 123 456
+:irc.foonet.org 005 tester NETWORK=foonet :are supported
+:irc.foonet.org 376 tester :End of /MOTD command."
+ "\n"))
+ (erc-parse-server-response erc-server-process line)))
+
+ (with-current-buffer (erc--open-target "#chan")
+ (erc-update-channel-member
+ "#chan" alice alice t nil nil nil nil nil "fake" "~u" nil nil t)
+
+ (erc-update-channel-member
+ "#chan" bob bob t nil nil nil nil nil "fake" "~u" nil nil t)
+
+ (erc-display-message
+ nil 'notice (current-buffer)
+ (concat "This server is in debug mode and is logging all user I/O. "
+ "Blah " alice " (1) " bob " (2) blah."))
+
+ (erc-display-message nil nil (current-buffer)
+ (erc-format-privmessage bob "Hi Alice" nil t))
+
+ (erc-display-message nil nil (current-buffer)
+ (erc-format-privmessage alice "Hi Bob" nil t)))
+
+ (funcall test)
+
+ (when noninteractive
+ (kill-buffer "#chan")
+ (when (get-buffer " *Custom-Work*")
+ (kill-buffer " *Custom-Work*"))
+ (kill-buffer))))
+ (advice-remove 'face-list #'erc-nicks-tests--face-list))
+
+(ert-deftest erc-nicks-list-faces ()
+ (erc-nicks-tests--create-session
+ (lambda ()
+ (erc-nicks-list-faces)
+ (let ((table (buffer-local-value 'erc-nicks--face-table
+ (get-buffer "foonet")))
+ calls)
+ (cl-letf (((symbol-function 'erc-nicks--list-faces-help-button-action)
+ (lambda (&rest r) (push r calls))))
+ (with-current-buffer "*Faces*"
+ (set-window-buffer (selected-window) (current-buffer))
+ (goto-char (point-min))
+
+ (ert-info ("Clicking on face link runs action function")
+ (forward-button 1)
+ (should (looking-at "erc-nicks-alice1-face"))
+ (push-button)
+ (should (eq (car (car calls)) (gethash "alice1" table))))
+
+ (ert-info ("Clicking on sample text describes face")
+ (forward-button 1)
+ (should (looking-at (rx "#" (+ xdigit))))
+ (push-button)
+ (should (search-forward-regexp
+ (rx "Foreground: #" (group (+ xdigit)) eol)))
+ (forward-button 2) ; skip Inherit:...
+ (push-button))
+
+ (ert-info ("First entry's sample is rendered correctly")
+ (let ((hex (match-string 1)))
+ (should (looking-at (concat "#" hex)))
+ (goto-char (button-end (point)))
+ (should (looking-back " foonet"))
+ (should (eq (button-get (1- (point)) 'face) (car (pop calls))))
+ (should-not calls)))
+
+ (ert-info ("Clicking on another entry's face link runs action")
+ (forward-button 1)
+ (should (looking-at "erc-nicks-bob1-face"))
+ (push-button)
+ (should (eq (car (car calls)) (gethash "bob1" table))))
+
+ (ert-info ("Second entry's sample is rendered correctly")
+ (forward-button 1)
+ (should (looking-at (rx "#" (+ xdigit))))
+ (goto-char (button-end (point)))
+ (should (looking-back " foonet"))
+ (should (eq (button-get (1- (point)) 'face) (car (pop calls))))
+ (should-not calls))
+
+ (when noninteractive
+ (kill-buffer))))))
+ "Alice1" "Bob1"))
+
+(ert-deftest erc-nicks-customize-face ()
+ (unless (>= emacs-major-version 28)
+ (ert-skip "Face link required in customize-face buffers"))
+ (erc-nicks-tests--create-session
+ (lambda ()
+ (erc-nicks-list-faces)
+ (with-current-buffer "*Faces*"
+ (set-window-buffer (selected-window) (current-buffer))
+ (goto-char (point-min))
+
+ (ert-info ("Clicking on face link runs action function")
+ (forward-button 1)
+ (should (looking-at "erc-nicks-alice2"))
+ (ert-simulate-keys "y\r"
+ (call-interactively #'push-button nil)))
+
+ (with-current-buffer "*Customize Face: Erc Nicks Alice2@Foonet Face*"
+ (should (search-forward "Erc Nicks Alice2@Foonet Face" nil t))
+ (widget-button-press (1- (point))))
+
+ (with-current-buffer "*New face erc-nicks-alice2@foonet-face*"
+ (goto-char (point-min))
+ (should (search-forward "(use-package erc-nicks" nil t))
+ (should (search-forward ":foreground \"#" nil t))
+ (when noninteractive
+ (kill-buffer)))
+
+ (with-current-buffer "*Customize Face: Erc Nicks Alice2@Foonet Face*"
+ (should (search-forward "Foreground: #" nil t))
+ (when noninteractive
+ (kill-buffer)))
+
+ (when noninteractive
+ (kill-buffer))))
+ "Alice2" "Bob2"))
+
+(ert-deftest erc-nicks--gen-key-from-format-spec ()
+ (let ((erc-network 'OFTC)
+ (erc-nicks-key-suffix-format "@%-012n")
+ (erc-server-current-nick "tester"))
+ (should (equal (erc-nicks--gen-key-from-format-spec "bob")
+ "bob@OFTC00000000")))
+
+ (let ((erc-network 'Libera.Chat)
+ (erc-nicks-key-suffix-format "@%-012n")
+ (erc-server-current-nick "tester"))
+ (should (equal (erc-nicks--gen-key-from-format-spec "bob")
+ "bob@Libera.Chat0")))
+
+ (let* ((erc-network 'Libera.Chat)
+ (erc-nicks-key-suffix-format "@%n/%m")
+ (erc-server-current-nick "tester"))
+ (should (equal (erc-nicks--gen-key-from-format-spec "bob")
+ "bob@Libera.Chat/tester"))))
+
+(ert-deftest erc-nicks--create-culled-pool ()
+ (let ((erc-nicks--bg-luminance 1.0)
+ (erc-nicks--bg-mode-value 'light)
+ (erc-nicks--fg-rgb '(0.0 0.0 0.0))
+ (erc-nicks-bg-color "white")
+ ;;
+ (erc-nicks--colors-rejects '(t)))
+
+ ;; Reject
+ (should-not (erc-nicks--create-culled-pool '(erc-nicks-invert) '("white")))
+ (should (equal (pop erc-nicks--colors-rejects) "white")) ; too close
+ (should-not
+ (erc-nicks--create-culled-pool '(erc-nicks-cap-contrast) '("black")))
+ (should (equal (pop erc-nicks--colors-rejects) "black")) ; too far
+ (should-not
+ (erc-nicks--create-culled-pool '(erc-nicks-ensaturate) '("white")))
+ (should (equal (pop erc-nicks--colors-rejects) "white")) ; lacks color
+ (should-not
+ (erc-nicks--create-culled-pool '(erc-nicks-ensaturate) '("red")))
+ (should (equal (pop erc-nicks--colors-rejects) "red")) ; too much color
+
+ ;; Safe
+ (should (equal (erc-nicks--create-culled-pool '(erc-nicks-invert)
+ '("black"))
+ '("black")))
+ (should (equal (erc-nicks--create-culled-pool '(erc-nicks-add-contrast)
+ '("black"))
+ '("black")))
+ (should (equal (erc-nicks--create-culled-pool '(erc-nicks-cap-contrast)
+ '("white"))
+ '("white")))
+ (let ((erc-nicks-saturation-range '(0.5 . 1.0)))
+ (should (equal (erc-nicks--create-culled-pool '(erc-nicks-ensaturate)
+ '("green"))
+ '("green"))))
+ (let ((erc-nicks-saturation-range '(0.0 . 0.5)))
+ (should (equal (erc-nicks--create-culled-pool '(erc-nicks-ensaturate)
+ '("gray"))
+ '("gray"))))
+ (unless noninteractive
+ (should (equal (erc-nicks--create-culled-pool '(erc-nicks-ensaturate)
+ '("firebrick"))
+ '("firebrick"))))
+ (should (equal erc-nicks--colors-rejects '(t)))))
+
+(ert-deftest erc-nicks--create-coerced-pool ()
+ (let ((erc-nicks--bg-luminance 1.0)
+ (erc-nicks--bg-mode-value 'light)
+ (erc-nicks--fg-rgb '(0.0 0.0 0.0))
+ (erc-nicks-bg-color "white")
+ (num-colors (length (defined-colors)))
+ ;;
+ (erc-nicks--colors-rejects '(t)))
+
+ ;; Deduplication.
+ (when (= 8 num-colors)
+ (should (equal (erc-nicks--create-coerced-pool '(erc-nicks-ensaturate)
+ '("#ee0000" "#f80000"))
+ '("red")))
+ (should (equal (pop erc-nicks--colors-rejects) "#f80000")))
+
+ ;; "Coercion" in Xterm.
+ (unless noninteractive
+ (when (= 665 num-colors)
+ (pcase-dolist (`(,adjustments ,candidates ,result)
+ '(((erc-nicks-invert) ("white") ("gray10"))
+ ((erc-nicks-cap-contrast) ("black") ("gray20"))
+ ((erc-nicks-ensaturate) ("white") ("lavenderblush2"))
+ ((erc-nicks-ensaturate) ("red") ("firebrick"))))
+ (should (equal (erc-nicks--create-coerced-pool adjustments
+ candidates)
+ result)))))
+
+ (should (equal erc-nicks--colors-rejects '(t)))))
+
+;;; erc-nicks-tests.el ends here
diff --git a/test/lisp/erc/erc-scenarios-auth-source.el b/test/lisp/erc/erc-scenarios-auth-source.el
index b25acf2fbd8..f0a7a4cbaca 100644
--- a/test/lisp/erc/erc-scenarios-auth-source.el
+++ b/test/lisp/erc/erc-scenarios-auth-source.el
@@ -56,7 +56,7 @@
(should (string= (buffer-name) (if id
(symbol-name id)
(format "127.0.0.1:%d" port))))
- (erc-d-t-wait-for 5 (eq erc-network 'FooNet))))))
+ (erc-d-t-wait-for 10 (eq erc-network 'FooNet))))))
(ert-deftest erc-scenarios-base-auth-source-server--dialed ()
:tags '(:expensive-test)
diff --git a/test/lisp/erc/erc-scenarios-base-association.el b/test/lisp/erc/erc-scenarios-base-association.el
index 07b71c3ac14..deac0e0cac7 100644
--- a/test/lisp/erc/erc-scenarios-base-association.el
+++ b/test/lisp/erc/erc-scenarios-base-association.el
@@ -78,7 +78,7 @@
(with-current-buffer "#chan@foonet"
(funcall expect 3 "bob")
(funcall expect 3 "was created on")
- (funcall expect 3 "prosperous")))
+ (funcall expect 10 "prosperous")))
(ert-info ("All #chan@barnet output consumed")
(with-current-buffer "#chan@barnet"
diff --git a/test/lisp/erc/erc-scenarios-base-attach.el b/test/lisp/erc/erc-scenarios-base-attach.el
new file mode 100644
index 00000000000..dcd16ed6bca
--- /dev/null
+++ b/test/lisp/erc/erc-scenarios-base-attach.el
@@ -0,0 +1,191 @@
+;;; erc-scenarios-base-attach.el --- Reattach scenarios -*- lexical-binding: t -*-
+
+;; Copyright (C) 2023-2024 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 <https://www.gnu.org/licenses/>.
+
+;;; Commentary:
+
+;; See also: `erc-scenarios-base-channel-buffer-revival'.
+;;
+;; ERC 5.5 silently dropped support for the ancient option
+;; `erc-query-on-unjoined-chan-privmsg' because the tangled logic in
+;; and around the function `erc-auto-query' made it difficult to
+;; divine its purpose.
+;;
+;; Based on the name, it was thought this option likely involved
+;; controlling the creation of query buffers for unsolicited messages
+;; from users with whom you don't share a common channel. However,
+;; additional spelunking has recently revealed that it was instead
+;; meant to service a feature offered by most bouncers that sends
+;; PRIVMSGs directed at a channel you're no longer in and that you
+;; haven't received a(nother) JOIN message for. IOW, this is meant to
+;; support the following sequence of events:
+;;
+;; 1. /detach #chan
+;; 2. kill buffer #chan or reconnect in new Emacs session
+;; 3. /playbuffer #chan
+;;
+;; Note that the above slash commands are bouncer-specific aliases.
+;;
+;; Interested users can find more info by looking at this change set
+;; from the ancient CVS repo:
+;;
+;; Author: Mario Lang <mlang@delysid.org>
+;; AuthorDate: Mon Nov 26 18:33:19 2001 +0000
+;;
+;; * new function erc-BBDB-NICK to handle nickname annotation ...
+;; * Applied antifuchs/mhp patches, the latest on erc-help, unmodified
+;; * New variable: erc-reuse-buffers default to t.
+;; * Modified erc-generate-new-buffer-name to use it. it checks if
+;; server and port are the same, then one can assume that's the same
+;; channel/query target again.
+
+;;; Code:
+
+(require 'ert-x)
+(eval-and-compile
+ (let ((load-path (cons (ert-resource-directory) load-path)))
+ (require 'erc-scenarios-common)))
+
+(ert-deftest erc-scenarios-base-attach--ensure-target-buffer--enabled ()
+ :tags '(:expensive-test)
+ (should erc-ensure-target-buffer-on-privmsg)
+
+ (erc-scenarios-common-with-cleanup
+ ((erc-scenarios-common-dialog "base/channel-buffer-revival")
+ (dumb-server (erc-d-run "localhost" t 'reattach))
+ (port (process-contact dumb-server :service))
+ (erc-server-flood-penalty 0.1)
+ (expect (erc-d-t-make-expecter)))
+
+ (ert-info ("Connect to foonet")
+ (with-current-buffer (erc :server "127.0.0.1"
+ :port port
+ :nick "tester"
+ :password "tester@vanilla/foonet:changeme"
+ :full-name "tester")
+ (should (string= (buffer-name) (format "127.0.0.1:%d" port)))))
+
+ (with-current-buffer (erc-d-t-wait-for 10 (get-buffer "foonet"))
+ (erc-cmd-MSG "*status playbuffer #chan"))
+
+ (ert-info ("Playback appears in buffer #chan")
+ (with-current-buffer (erc-d-t-wait-for 10 (get-buffer "#chan"))
+ (funcall expect 10 "Buffer Playback...")
+ (funcall expect 10 "Was I a child")
+ (funcall expect 10 "Thou counterfeit'st most lively")
+ (funcall expect 10 "Playback Complete")))
+
+ (with-current-buffer "foonet"
+ (erc-cmd-MSG "*status attach #chan"))
+
+ (ert-info ("Live output from #chan after more playback")
+ (with-current-buffer "#chan"
+ (funcall expect 10 "Buffer Playback...")
+ (funcall expect 10 "With what it loathes")
+ (funcall expect 10 "Not by his breath")
+ (funcall expect 10 "Playback Complete")
+ (funcall expect 10 "Ay, and the captain")
+ (erc-scenarios-common-say "bob: hi")
+ (funcall expect 10 "Pawn me to this")))))
+
+(ert-deftest erc-scenarios-base-attach--ensure-target-buffer--disabled ()
+ :tags '(:expensive-test)
+ (should erc-ensure-target-buffer-on-privmsg)
+
+ (erc-scenarios-common-with-cleanup
+ ((erc-scenarios-common-dialog "base/channel-buffer-revival")
+ (dumb-server (erc-d-run "localhost" t 'reattach))
+ (port (process-contact dumb-server :service))
+ (erc-server-flood-penalty 0.1)
+ (erc-ensure-target-buffer-on-privmsg nil) ; off
+ (expect (erc-d-t-make-expecter)))
+
+ (ert-info ("Connect to foonet")
+ (with-current-buffer (erc :server "127.0.0.1"
+ :port port
+ :nick "tester"
+ :password "tester@vanilla/foonet:changeme"
+ :full-name "tester")
+ (should (string= (buffer-name) (format "127.0.0.1:%d" port)))))
+
+ (with-current-buffer (erc-d-t-wait-for 10 (get-buffer "foonet"))
+ (erc-cmd-MSG "*status playbuffer #chan")
+ (ert-info ("Playback appears in buffer server buffer")
+ (erc-d-t-ensure-for -1 (not (get-buffer "#chan")))
+ (funcall expect 10 "Buffer Playback...")
+ (funcall expect 10 "Was I a child")
+ (funcall expect 10 "Thou counterfeit'st most lively")
+ (funcall expect 10 "Playback Complete"))
+ (should-not (get-buffer "#chan"))
+ (erc-cmd-MSG "*status attach #chan"))
+
+ (ert-info ("Buffer #chan joined")
+ (with-current-buffer (erc-d-t-wait-for 10 (get-buffer "#chan"))
+ (funcall expect 10 "Buffer Playback...")
+ (funcall expect 10 "With what it loathes")
+ (funcall expect 10 "Not by his breath")
+ (funcall expect 10 "Playback Complete")
+ (funcall expect 10 "Ay, and the captain")
+ (erc-scenarios-common-say "bob: hi")
+ (funcall expect 10 "Pawn me to this")))))
+
+
+;; We omit the `enabled' case for queries because it's the default for
+;; this option and already covered many times over by other tests in
+;; this directory.
+
+(ert-deftest erc-scenarios-base-attach--ensure-target-buffer--disabled-query ()
+ :tags '(:expensive-test)
+ (should erc-ensure-target-buffer-on-privmsg)
+
+ (erc-scenarios-common-with-cleanup
+ ((erc-scenarios-common-dialog "base/assoc/queries")
+ (dumb-server (erc-d-run "localhost" t 'non-erc))
+ (port (process-contact dumb-server :service))
+ (expect (erc-d-t-make-expecter))
+ (erc-ensure-target-buffer-on-privmsg nil)
+ (erc-server-flood-penalty 0.1))
+
+ (ert-info ("Connect to foonet")
+ (with-current-buffer (erc :server "127.0.0.1"
+ :port port
+ :nick "tester"
+ :user "tester"
+ :full-name "tester")
+ (erc-scenarios-common-assert-initial-buf-name nil port)
+ (erc-d-t-wait-for 5 (eq erc-network 'foonet))
+ (funcall expect 15 "debug mode")))
+
+ (ert-info ("User dummy's greeting appears in server buffer")
+ (erc-d-t-wait-for -1 (get-buffer "dummy"))
+ (with-current-buffer "foonet"
+ (funcall expect 5 "hi")
+
+ (ert-info ("Option being nil doesn't queries we create")
+ (with-current-buffer (erc-cmd-QUERY "nitwit")
+ (should (equal (buffer-name) "nitwit"))
+ (erc-scenarios-common-say "hola")
+ (funcall expect 5 "ciao")))
+
+ (erc-scenarios-common-say "howdy")
+ (funcall expect 5 "no target")
+ (erc-cmd-MSG "dummy howdy")
+ (funcall expect 5 "bye")
+ (erc-cmd-QUIT "")))))
+
+;;; erc-scenarios-base-attach.el ends here
diff --git a/test/lisp/erc/erc-scenarios-base-auto-recon.el b/test/lisp/erc/erc-scenarios-base-auto-recon.el
new file mode 100644
index 00000000000..808b1d8c4d4
--- /dev/null
+++ b/test/lisp/erc/erc-scenarios-base-auto-recon.el
@@ -0,0 +1,141 @@
+;;; erc-scenarios-base-auto-recon.el --- auto-recon scenarios -*- lexical-binding: t -*-
+
+;; Copyright (C) 2023-2024 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 <https://www.gnu.org/licenses/>.
+
+;;; Code:
+
+(require 'ert-x)
+(eval-and-compile
+ (let ((load-path (cons (ert-resource-directory) load-path)))
+ (require 'erc-scenarios-common)))
+
+(defun erc-scenarios-base-auto-recon--get-unused-port ()
+ (let ((server (make-network-process :name "*erc-scenarios-base-auto-recon*"
+ :host "localhost"
+ :service t
+ :server t)))
+ (delete-process server)
+ (process-contact server :service)))
+
+;; This demos one possible flavor of intermittent service.
+;; It may end up needing to be marked :unstable.
+
+(ert-deftest erc-scenarios-base-auto-recon-unavailable ()
+ :tags '(:expensive-test)
+ (erc-scenarios-common-with-cleanup
+ ((erc-server-flood-penalty 0.1)
+ (port (erc-scenarios-base-auto-recon--get-unused-port))
+ (erc--server-reconnect-timeout-scale-function (lambda (_) 1))
+ (erc-server-auto-reconnect t)
+ (erc-server-reconnect-function #'erc-server-delayed-check-reconnect)
+ (expect (erc-d-t-make-expecter))
+ (erc-scenarios-common-dialog "base/reconnect")
+ (dumb-server nil))
+
+ (ert-info ("Dialing fails: nobody home")
+ (with-current-buffer (erc :server "127.0.0.1"
+ :port port
+ :nick "tester"
+ :full-name "tester")
+ (erc-d-t-wait-for 10 (not (erc-server-process-alive)))
+ (erc-d-t-wait-for 10 erc--server-reconnect-timer)
+ (funcall expect 10 "Opening connection")
+ (funcall expect 10 "failed")
+
+ (ert-info ("Reconnect function freezes attempts at 1")
+ (funcall expect 10 '(: "reconnecting" (+ nonl) "attempt 1/2"))
+ (funcall expect 10 "nobody home")
+ (funcall expect 10 '(: "reconnecting" (+ nonl) "attempt 1/2"))
+ (funcall expect 10 "nobody home"))))
+
+ (ert-info ("Service appears")
+ (setq dumb-server (erc-d-run "localhost" port
+ 'just-eof 'unexpected-disconnect))
+ (with-current-buffer (format "127.0.0.1:%d" port)
+ (funcall expect 10 "server is in debug mode")
+ (should (equal (buffer-name) "FooNet"))))
+
+ (ert-info ("Service interrupted, reconnect starts again")
+ (with-current-buffer "FooNet"
+ (funcall expect 10 "failed")
+ (funcall expect 10 '(: "reconnecting" (+ nonl) "attempt 1/2"))))
+
+ (ert-info ("Service restored")
+ (delete-process dumb-server)
+ (setq dumb-server (erc-d-run "localhost" port
+ 'just-eof 'unexpected-disconnect))
+ (with-current-buffer "FooNet"
+ (funcall expect 10 "server is in debug mode")))
+
+ (ert-info ("Service interrupted a third time, reconnect starts yet again")
+ (with-current-buffer "FooNet"
+ (funcall expect 10 "failed")
+ (funcall expect 10 '(: "reconnecting" (+ nonl) "attempt 1/2"))
+ (erc-cmd-RECONNECT "cancel")
+ (funcall expect 10 "canceled")))))
+
+;; In this test, a listener accepts but doesn't respond to any messages.
+
+(ert-deftest erc-scenarios-base-auto-recon-no-proto ()
+ :tags '(:expensive-test)
+ (erc-scenarios-common-with-cleanup
+ ((erc-server-flood-penalty 0.1)
+ (erc-scenarios-common-dialog "base/reconnect")
+ (erc-d-auto-pong nil)
+ (dumb-server (erc-d-run "localhost" t 'unexpected-disconnect))
+ (port (process-contact dumb-server :service))
+ (erc--server-reconnect-timeout-scale-function (lambda (_) 1))
+ (erc--server-reconnect-timeout-check 0.5)
+ (erc-server-auto-reconnect t)
+ (erc-server-reconnect-function #'erc-server-delayed-check-reconnect)
+ (expect (erc-d-t-make-expecter)))
+
+ (ert-info ("Session succeeds but cut short")
+ (with-current-buffer (erc :server "127.0.0.1"
+ :port port
+ :nick "tester"
+ :full-name "tester")
+ (funcall expect 10 "server is in debug mode")
+ (should (equal (buffer-name) "FooNet"))
+ (erc-d-t-wait-for 10 erc--server-reconnect-timer)
+ (delete-process dumb-server)
+ (funcall expect 10 "failed")
+
+ (ert-info ("Reconnect function freezes attempts at 1")
+ (funcall expect 10 '(: "reconnecting" (+ nonl) "attempt 1/2"))
+ (funcall expect 10 "nobody home")
+ (funcall expect 10 "timed out while dialing")
+ (funcall expect 10 '(: "reconnecting" (+ nonl) "attempt 1/2"))
+ (funcall expect 10 "nobody home"))))
+
+ (ert-info ("Service restored")
+ (setq dumb-server (erc-d-run "localhost" port
+ 'just-ping
+ 'ping-pong
+ 'unexpected-disconnect))
+ (with-current-buffer "FooNet"
+ (funcall expect 30 "server is in debug mode")))
+
+ (ert-info ("Service interrupted again, reconnect starts again")
+ (with-current-buffer "FooNet"
+ (funcall expect 10 "failed")
+ (funcall expect 10 '(: "reconnecting" (+ nonl) "attempt 1/2"))
+ (erc-cmd-RECONNECT "cancel")
+ (funcall expect 10 "canceled")))))
+
+;;; erc-scenarios-base-auto-recon.el ends here
diff --git a/test/lisp/erc/erc-scenarios-base-buffer-display.el b/test/lisp/erc/erc-scenarios-base-buffer-display.el
new file mode 100644
index 00000000000..5c3c526f86d
--- /dev/null
+++ b/test/lisp/erc/erc-scenarios-base-buffer-display.el
@@ -0,0 +1,249 @@
+;;; erc-scenarios-base-buffer-display.el --- Buffer display scenarios -*- lexical-binding: t -*-
+
+;; Copyright (C) 2023-2024 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 <https://www.gnu.org/licenses/>.
+
+;;; Code:
+
+(require 'ert-x)
+(eval-and-compile
+ (let ((load-path (cons (ert-resource-directory) load-path)))
+ (require 'erc-scenarios-common)))
+
+(eval-when-compile (require 'erc-join))
+
+;; These first couple `erc-auto-reconnect-display' tests used to live
+;; in erc-scenarios-base-reconnect but have since been renamed. Note
+;; that these are somewhat difficult to reason about because the user
+;; joins a second channel after reconnecting, and the first is
+;; controlled by `autojoin'.
+
+(defun erc-scenarios-base-buffer-display--reconnect-common
+ (assert-server assert-chan assert-rest)
+ (erc-scenarios-common-with-cleanup
+ ((erc-scenarios-common-dialog "base/reconnect")
+ (dumb-server (erc-d-run "localhost" t 'options 'options-again))
+ (port (process-contact dumb-server :service))
+ (expect (erc-d-t-make-expecter))
+ (erc-server-flood-penalty 0.1)
+ (erc-server-auto-reconnect t)
+ erc-autojoin-channels-alist)
+
+ (should (memq 'autojoin erc-modules))
+
+ (ert-info ("Connect to foonet")
+ (with-current-buffer (erc :server "127.0.0.1"
+ :port port
+ :nick "tester"
+ :password "changeme"
+ :full-name "tester")
+ (funcall assert-server expect)
+ (should (string= (buffer-name) (format "127.0.0.1:%d" port)))
+ (funcall expect 10 "debug mode")))
+
+ (ert-info ("Wait for some output in channels")
+ (with-current-buffer (erc-d-t-wait-for 10 (get-buffer "#chan"))
+ (funcall assert-chan expect)
+ (funcall expect 10 "welcome")
+ (funcall expect 10 "welcome")))
+
+ (ert-info ("Server buffer shows connection failed")
+ (with-current-buffer "FooNet"
+ (funcall expect 10 "Connection failed! Re-establishing")))
+
+ (should (equal erc-autojoin-channels-alist '((FooNet "#chan"))))
+ (delete-other-windows)
+ (pop-to-buffer-same-window "*Messages*")
+
+ (ert-info ("Wait for auto reconnect")
+ (with-current-buffer "FooNet" (funcall expect 10 "still in debug mode")))
+
+ (ert-info ("Lone window still shows messages buffer")
+ (should (eq (window-buffer) (messages-buffer)))
+ (should (frame-root-window-p (selected-window))))
+
+ (funcall assert-rest expect)
+
+ (ert-info ("Wait for activity to recommence in both channels")
+ (with-current-buffer (erc-d-t-wait-for 10 (get-buffer "#chan"))
+ (funcall expect 10 "forest of Arden"))
+ (with-current-buffer (erc-d-t-wait-for 10 (get-buffer "#spam"))
+ (funcall expect 10 "her elves come here anon")))))
+
+;; Interactively issuing a slash command resets the auto-reconnect
+;; count, making ERC ignore the option `erc-auto-reconnect-display'
+;; when next displaying a newly set up buffer. In the case of a
+;; /JOIN, the option `erc-interactive-display' takes precedence.
+(ert-deftest erc-scenarios-base-buffer-display--defwin-recbury-intbuf ()
+ :tags '(:expensive-test)
+ (should (eq erc-buffer-display 'bury))
+ (should (eq erc-interactive-display 'window))
+ (should-not erc-auto-reconnect-display)
+
+ (let ((erc-buffer-display 'window) ; defwin
+ (erc-interactive-display 'buffer) ; intbuf
+ (erc-auto-reconnect-display 'bury)) ; recbury
+
+ (erc-scenarios-base-buffer-display--reconnect-common
+
+ (lambda (_)
+ (ert-info ("New server buffer appears in a selected split")
+ (should (eq (window-buffer) (current-buffer)))
+ (should-not (frame-root-window-p (selected-window)))))
+
+ (lambda (_)
+ (ert-info ("New channel buffer appears in other window")
+ (should (eq (window-buffer) (current-buffer))) ; selected
+ (should (equal (get-buffer "FooNet") (window-buffer (next-window))))))
+
+ (lambda (expect)
+ ;; If we /JOIN #spam now, we'll cancel the auto-reconnect
+ ;; timer, and "#chan" may well pop up in a split before we can
+ ;; verify that the lone window displays #spam (a race, IOW).
+ (ert-info ("Autojoined channel #chan buried on JOIN")
+ (with-current-buffer "#chan"
+ (funcall expect 10 "You have joined channel #chan"))
+ (should (frame-root-window-p (selected-window)))
+ (should (eq (window-buffer) (messages-buffer))))
+
+ (with-current-buffer "FooNet" (erc-scenarios-common-say "/JOIN #spam"))
+
+ (ert-info ("A /JOIN ignores `erc-auto-reconnect-display'")
+ (with-current-buffer (erc-d-t-wait-for 10 (get-buffer "#spam"))
+ (should (eq (window-buffer) (get-buffer "#spam")))
+ ;; Option `erc-interactive-display' being `buffer' means
+ ;; Emacs reuses the selected window (no split).
+ (should (frame-root-window-p (selected-window)))))))))
+
+(ert-deftest erc-scenarios-base-buffer-display--defwino-recbury-intbuf ()
+ :tags '(:expensive-test)
+ (should (eq erc-buffer-display 'bury))
+ (should (eq erc-interactive-display 'window))
+ (should-not erc-auto-reconnect-display)
+
+ (let ((erc-buffer-display 'window-noselect) ; defwino
+ (erc-auto-reconnect-display 'bury)
+ (erc-interactive-display 'buffer))
+ (erc-scenarios-base-buffer-display--reconnect-common
+
+ (lambda (_)
+ ;; Selected window shows some non-ERC buffer. New server
+ ;; buffer appears in another window (other side of split).
+ (should-not (frame-root-window-p (selected-window)))
+ (should-not (eq (window-buffer) (current-buffer)))
+ (with-current-buffer (window-buffer)
+ (should-not (derived-mode-p 'erc-mode)))
+ (should (eq (current-buffer) (window-buffer (next-window)))))
+
+ (lambda (_)
+ (should-not (frame-root-window-p (selected-window)))
+ ;; Current split likely shows scratch.
+ (with-current-buffer (window-buffer)
+ (should-not (derived-mode-p 'erc-mode)))
+ (should (eq (current-buffer) (window-buffer (next-window)))))
+
+ (lambda (_)
+ ;; A JOIN command sent from lisp code is "non-interactive" and
+ ;; doesn't reset the auto-reconnect count, so ERC treats the
+ ;; response as possibly server-initiated or otherwise the
+ ;; result of an autojoin and continues to favor
+ ;; `erc-auto-reconnect-display'.
+ (ert-info ("Join chan non-interactively and open a /QUERY")
+ (with-current-buffer "FooNet"
+ (erc-cmd-JOIN "#spam") ; "non-interactive" according to ERC
+ (erc-scenarios-common-say "/QUERY bob") ; resets count
+ (should (eq (window-buffer) (get-buffer "bob")))
+ (should (frame-root-window-p (selected-window)))))
+
+ ;; The /QUERY above resets the count, and `erc-buffer-display'
+ ;; again decides how #spam is displayed.
+ (ert-info ("Newly joined chan ignores `erc-auto-reconnect-display'")
+ (with-current-buffer (erc-d-t-wait-for 10 (get-buffer "#spam"))
+ (should (eq (window-buffer) (get-buffer "bob")))
+ (should-not (frame-root-window-p (selected-window))) ; noselect
+ (should (eq (current-buffer) (window-buffer (next-window))))))))))
+
+(ert-deftest erc-scenarios-base-buffer-display--count-reset-timeout ()
+ :tags '(:expensive-test)
+ (should (eq erc-buffer-display 'bury))
+ (should (eq erc-interactive-display 'window))
+ (should (eq erc-auto-reconnect-display-timeout 10))
+ (should-not erc-auto-reconnect-display)
+
+ (let ((erc-buffer-display 'window-noselect)
+ (erc-auto-reconnect-display 'bury)
+ (erc-interactive-display 'buffer)
+ (erc-auto-reconnect-display-timeout 0.5))
+ (erc-scenarios-base-buffer-display--reconnect-common
+ #'ignore #'ignore ; These two are identical to the previous test.
+
+ (lambda (_)
+ (with-current-buffer "FooNet"
+ (erc-d-t-wait-for 1 erc--server-reconnect-display-timer))
+
+ ;; A non-interactive JOIN command doesn't signal that we're
+ ;; done auto-reconnecting.
+ (ert-info ("Join channel #spam non-interactively")
+ (with-current-buffer "FooNet"
+ (erc-d-t-wait-for 1 (null erc--server-reconnect-display-timer))
+ (erc-cmd-JOIN "#spam"))) ; not processed as a /JOIN
+
+ (ert-info ("Option `erc-auto-reconnect-display' ignored w/o timer")
+ (should (eq (window-buffer) (messages-buffer)))
+ (erc-d-t-wait-for 10 (get-buffer "#spam"))
+ ;; If `erc-auto-reconnect-display-timeout' were left alone,
+ ;; this would be (frame-root-window-p #<window 1 on scratch*>).
+ (should-not (frame-root-window-p (selected-window)))
+ (should (eq (get-buffer "#spam") (window-buffer (next-window)))))))))
+
+;; This shows that the option `erc-interactive-display' overrides
+;; `erc-join-buffer' during cold opens and interactive /JOINs.
+
+(ert-deftest erc-scenarios-base-buffer-display--interactive-default ()
+ :tags '(:expensive-test)
+ (should (eq erc-join-buffer 'bury))
+ (should (eq erc-interactive-display 'window))
+
+ (erc-scenarios-common-with-cleanup
+ ((erc-scenarios-common-dialog "join/legacy")
+ (dumb-server (erc-d-run "localhost" t 'foonet))
+ (port (process-contact dumb-server :service))
+ (url (format "tester:changeme@127.0.0.1:%d\r\r" port))
+ (expect (erc-d-t-make-expecter))
+ (erc-server-flood-penalty 0.1)
+ (erc-server-auto-reconnect t)
+ (erc-user-full-name "tester"))
+
+ (ert-info ("Connect to foonet")
+ (with-current-buffer (let (inhibit-interaction)
+ (ert-simulate-keys url
+ (call-interactively #'erc)))
+ (should (string= (buffer-name) (format "127.0.0.1:%d" port)))
+
+ (erc-d-t-wait-for 10 "Server buffer shown"
+ (eq (window-buffer) (current-buffer)))
+ (funcall expect 10 "debug mode")
+ (erc-scenarios-common-say "/JOIN #chan")))
+
+ (ert-info ("Wait for output in #chan")
+ (with-current-buffer (erc-d-t-wait-for 10 (get-buffer "#chan"))
+ (funcall expect 10 "welcome")
+ (erc-d-t-ensure-for 3 "Channel #chan shown"
+ (eq (window-buffer) (current-buffer)))
+ (funcall expect 10 "be prosperous")))))
+
+;;; erc-scenarios-base-buffer-display.el ends here
diff --git a/test/lisp/erc/erc-scenarios-base-chan-modes.el b/test/lisp/erc/erc-scenarios-base-chan-modes.el
new file mode 100644
index 00000000000..3183cd27370
--- /dev/null
+++ b/test/lisp/erc/erc-scenarios-base-chan-modes.el
@@ -0,0 +1,142 @@
+;;; erc-scenarios-base-chan-modes.el --- Channel mode scenarios -*- lexical-binding: t -*-
+
+;; Copyright (C) 2023-2024 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 <https://www.gnu.org/licenses/>.
+
+;;; Code:
+
+(require 'ert-x)
+(eval-and-compile
+ (let ((load-path (cons (ert-resource-directory) load-path)))
+ (require 'erc-scenarios-common)))
+
+;; This asserts that a bug present in ERC 5.4+ is now absent.
+;; Previously, ERC would attempt to parse a nullary channel mode as if
+;; it were a status prefix update, which led to a wrong-type error.
+;; This test does not address similar collisions with unary modes,
+;; such as "MODE +q foo!*@*", but it should.
+(ert-deftest erc-scenarios-base-chan-modes--plus-q ()
+ :tags '(:expensive-test)
+ (erc-scenarios-common-with-cleanup
+ ((erc-scenarios-common-dialog "base/modes")
+ (erc-server-flood-penalty 0.1)
+ (dumb-server (erc-d-run "localhost" t 'chan-changed))
+ (erc-modules (cons 'fill-wrap erc-modules))
+ (erc-autojoin-channels-alist '((Libera.Chat "#chan")))
+ (expect (erc-d-t-make-expecter)))
+
+ (ert-info ("Connect to Libera.Chat")
+ (with-current-buffer (erc :server "127.0.0.1"
+ :port (process-contact dumb-server :service)
+ :nick "tester"
+ :full-name "tester")
+ (funcall expect 5 "changed mode")))
+
+ (with-current-buffer (erc-d-t-wait-for 5 (get-buffer "#chan"))
+ (should-not erc-channel-key)
+ (should-not erc-channel-user-limit)
+
+ (ert-info ("Receive notice that mode has changed")
+ (erc-d-t-wait-for 10 (equal erc-channel-modes '("n" "t")))
+ (erc-scenarios-common-say "ready before")
+ (funcall expect 10 "<Chad> before")
+ (funcall expect 10 " has changed mode for #chan to +Qu")
+ (erc-d-t-wait-for 10 (equal erc-channel-modes '("Q" "n" "t" "u"))))
+
+ (ert-info ("Key stored locally")
+ (erc-scenarios-common-say "ready key")
+ (funcall expect 10 "<Chad> doing key")
+ (funcall expect 10 " has changed mode for #chan to +k hunter2")
+ (should (equal erc-channel-key "hunter2")))
+
+ (ert-info ("Limit stored locally")
+ (erc-scenarios-common-say "ready limit")
+ (funcall expect 10 "<Chad> doing limit")
+ (funcall expect 10 " has changed mode for #chan to +l 3")
+ (erc-d-t-wait-for 10 (eql erc-channel-user-limit 3))
+ (should (equal erc-channel-modes '("Q" "n" "t" "u"))))
+
+ (ert-info ("Modes removed and local state deletion succeeds")
+ (erc-scenarios-common-say "ready drop")
+ (funcall expect 10 "<Chad> dropping")
+ (funcall expect 10 " has changed mode for #chan to -lu")
+ (funcall expect 10 " has changed mode for #chan to -Qk *")
+ (erc-d-t-wait-for 10 (equal erc-channel-modes '("n" "t"))))
+
+ (should-not erc-channel-key)
+ (should-not erc-channel-user-limit)
+ (funcall expect 10 "<Chad> after"))))
+
+;; This asserts proper recognition of nonstandard prefixes advertised
+;; via the "PREFIX=" ISUPPORT parameter. Note that without the IRCv3
+;; `multi-prefix' extension, we can't easily sync a user's channel
+;; membership status on receipt of a 352/353 by parsing the "flags"
+;; parameter because even though servers remember multiple prefixes,
+;; they only ever return the one with the highest rank. For example,
+;; if on receipt of a 352, we were to "update" someone we believe to
+;; be @+ by changing them to a to @, we'd be guilty of willful
+;; munging. And if they later lose that @, we'd then see them as null
+;; when in fact they're still +. However, we *could* use a single
+;; degenerate prefix to "validate" an existing record to ensure
+;; correctness of our processing logic, but it's unclear how such a
+;; discrepancy ought to be handled beyond asking the user to file a
+;; bug.
+(ert-deftest erc-scenarios-base-chan-modes--speaker-status ()
+ :tags '(:expensive-test)
+ (erc-scenarios-common-with-cleanup
+ ((erc-scenarios-common-dialog "base/modes")
+ (erc-server-flood-penalty 0.1)
+ (dumb-server (erc-d-run "localhost" t 'speaker-status))
+ (erc-show-speaker-membership-status t)
+ (erc-autojoin-channels-alist '(("." "#chan")))
+ (expect (erc-d-t-make-expecter)))
+
+ (ert-info ("Connect to foonet")
+ (with-current-buffer (erc :server "127.0.0.1"
+ :port (process-contact dumb-server :service)
+ :nick "tester"
+ :user "tester")
+ (funcall expect 5 "Here on foonet, we provide services")))
+
+ (with-current-buffer (erc-d-t-wait-for 5 (get-buffer "#chan"))
+
+ (ert-info ("Prefixes printed correctly in 353")
+ (funcall expect 10 "chan: +alice @fsbot -bob !foop"))
+
+ (ert-info ("Speakers honor option `erc-show-speaker-membership-status'")
+ (funcall expect 10 "<-bob> alice: Of that which hath")
+ (funcall expect 10 "<+alice> Hie you, make haste")
+ (funcall expect 10 "<!foop> hi"))
+
+ (ert-info ("Status conferred and rescinded")
+ (funcall expect 10 "*** foop (user@netadmin.example.net) has changed ")
+ (funcall expect 10 "mode for #chan to +v bob")
+ (funcall expect 10 "<+bob> alice: Fair as a text B")
+ (funcall expect 10 "<+alice> bob: Even as Apemantus")
+ (funcall expect 10 "mode for #chan to -v bob")
+ (funcall expect 10 "<-bob> alice: That's the way")
+ (funcall expect 10 "<+alice> Give it the beasts"))
+
+ ;; If it had instead overwritten it, our two states would be
+ ;; out of sync. (See comment above.)
+ (ert-info ("/WHO output confirms server shadowed V status")
+ (erc-scenarios-common-say "/who #chan")
+ (funcall expect 10 '(: "bob" (+ " ") "H-"))
+ (funcall expect 10 "<-bob> alice: Remains in danger")
+ (erc-cmd-QUIT "")))))
+
+;;; erc-scenarios-base-chan-modes.el ends here
diff --git a/test/lisp/erc/erc-scenarios-base-local-module-modes.el b/test/lisp/erc/erc-scenarios-base-local-module-modes.el
new file mode 100644
index 00000000000..a3612070f7e
--- /dev/null
+++ b/test/lisp/erc/erc-scenarios-base-local-module-modes.el
@@ -0,0 +1,211 @@
+;;; erc-scenarios-base-local-module-modes.el --- More local-mod ERC tests -*- lexical-binding: t -*-
+
+;; Copyright (C) 2023-2024 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 <https://www.gnu.org/licenses/>.
+
+;;; Commentary:
+
+;; A local module doubles as a minor mode whose mode variable and
+;; associated local data can withstand service disruptions.
+;; Unfortunately, the current implementation is too unwieldy to be
+;; made public because it doesn't perform any of the boiler plate
+;; needed to save and restore buffer-local and "network-local" copies
+;; of user options. Ultimately, a user-friendly framework must fill
+;; this void if third-party local modules are ever to become
+;; practical.
+;;
+;; The following tests all use `sasl' because, as of ERC 5.5, it's the
+;; only local module.
+
+;;; Code:
+
+(require 'ert-x)
+(eval-and-compile
+ (let ((load-path (cons (ert-resource-directory) load-path)))
+ (require 'erc-scenarios-common)))
+
+(require 'erc-sasl)
+
+;; After quitting a session for which `sasl' is enabled, you
+;; disconnect and toggle `erc-sasl-mode' off. You then reconnect
+;; using an alternate nickname. You again disconnect and reconnect,
+;; this time immediately, and the mode stays disabled. Finally, you
+;; once again disconnect, toggle the mode back on, and reconnect. You
+;; are authenticated successfully, just like in the initial session.
+;;
+;; This is meant to show that a user's local mode settings persist
+;; between sessions. It also happens to show (in round four, below)
+;; that a server renicking a user on 001 after a 903 is handled just
+;; like a user-initiated renick, although this is not the main thrust.
+
+(ert-deftest erc-scenarios-base-local-module-modes--reconnect ()
+ :tags '(:expensive-test)
+ (erc-scenarios-common-with-cleanup
+ ((erc-scenarios-common-dialog "base/local-modules")
+ (erc-server-flood-penalty 0.1)
+ (dumb-server (erc-d-run "localhost" t 'first 'second 'third 'fourth))
+ (port (process-contact dumb-server :service))
+ (erc-modules (cons 'sasl erc-modules))
+ (expect (erc-d-t-make-expecter))
+ (server-buffer-name (format "127.0.0.1:%d" port)))
+
+ (ert-info ("Round one, initial authentication succeeds as expected")
+ (with-current-buffer (erc :server "127.0.0.1"
+ :port port
+ :nick "tester"
+ :user "tester"
+ :password "changeme"
+ :full-name "tester")
+ (should (string= (buffer-name) server-buffer-name))
+ (funcall expect 10 "You are now logged in as tester"))
+
+ (with-current-buffer (erc-d-t-wait-for 10 (get-buffer "foonet"))
+ (funcall expect 10 "This server is in debug mode")
+ (erc-cmd-JOIN "#chan")
+
+ (with-current-buffer (erc-d-t-wait-for 10 (get-buffer "#chan"))
+ (funcall expect 20 "She is Lavinia, therefore must"))
+
+ (erc-cmd-QUIT "")
+ (funcall expect 10 "finished")))
+
+ (ert-info ("Round two, nick rejected, alternate granted")
+ (with-current-buffer "foonet"
+
+ (ert-info ("Toggle mode off, reconnect")
+ (erc-sasl-mode -1)
+ (erc-cmd-RECONNECT))
+
+ (funcall expect 10 "User modes for tester`")
+ (should-not (cdr (erc-scenarios-common-buflist "foonet")))
+ (should (equal (buffer-name) "foonet"))
+ (should-not (cdr (erc-scenarios-common-buflist "#chan")))
+
+ (with-current-buffer "#chan"
+ (funcall expect 10 "Some enigma, some riddle"))
+
+ (erc-cmd-QUIT "")
+ (funcall expect 10 "finished")))
+
+ (ert-info ("Round three, send alternate nick initially")
+ (with-current-buffer "foonet"
+
+ (ert-info ("Keep mode off, reconnect")
+ (should-not erc-sasl-mode)
+ (should (local-variable-p 'erc-sasl-mode))
+ (erc-cmd-RECONNECT))
+
+ (funcall expect 10 "User modes for tester`")
+ (should-not (cdr (erc-scenarios-common-buflist "foonet")))
+ (should (equal (buffer-name) "foonet"))
+ (should-not (cdr (erc-scenarios-common-buflist "#chan")))
+
+ (with-current-buffer "#chan"
+ (funcall expect 10 "Let our reciprocal vows be remembered."))
+
+ (erc-cmd-QUIT "")
+ (funcall expect 10 "finished")))
+
+ (ert-info ("Round four, authenticated successfully again")
+ (with-current-buffer "foonet"
+
+ (ert-info ("Toggle mode on, reconnect")
+ (should-not erc-sasl-mode)
+ (should (local-variable-p 'erc-sasl-mode))
+ (erc-sasl-mode +1)
+ (erc-cmd-RECONNECT))
+
+ (funcall expect 10 "User modes for tester")
+ (should-not (cdr (erc-scenarios-common-buflist "foonet")))
+ (should (equal (buffer-name) "foonet"))
+ (should-not (cdr (erc-scenarios-common-buflist "#chan")))
+
+ (with-current-buffer "#chan"
+ (funcall expect 10 "Well met; good morrow, Titus and Hortensius."))
+
+ (erc-cmd-QUIT "")))))
+
+;; In contrast to the mode-persistence test above, this one
+;; demonstrates that a user reinvoking an entry point declares their
+;; intention to reset local-module state for the server buffer.
+;; Whether a local-module's state variable is also reset in target
+;; buffers up to the module. That is, by default, they're left alone.
+
+(ert-deftest erc-scenarios-base-local-module-modes--entrypoint ()
+ :tags '(:expensive-test)
+ (erc-scenarios-common-with-cleanup
+ ((erc-scenarios-common-dialog "base/local-modules")
+ (erc-server-flood-penalty 0.1)
+ (dumb-server (erc-d-run "localhost" t 'first 'first))
+ (port (process-contact dumb-server :service))
+ (erc-modules (cons 'sasl erc-modules))
+ (expect (erc-d-t-make-expecter))
+ (server-buffer-name (format "127.0.0.1:%d" port)))
+
+ (ert-info ("Round one, initial authentication succeeds as expected")
+ (with-current-buffer (erc :server "127.0.0.1"
+ :port port
+ :nick "tester"
+ :user "tester"
+ :password "changeme"
+ :full-name "tester")
+ (should (string= (buffer-name) server-buffer-name))
+ (funcall expect 10 "You are now logged in as tester"))
+
+ (with-current-buffer (erc-d-t-wait-for 10 (get-buffer "foonet"))
+ (funcall expect 10 "This server is in debug mode")
+ (erc-cmd-JOIN "#chan")
+
+ (ert-info ("Toggle local-module off in target buffer")
+ (with-current-buffer (erc-d-t-wait-for 10 (get-buffer "#chan"))
+ (funcall expect 20 "She is Lavinia, therefore must")
+ (erc-sasl-mode -1)))
+
+ (erc-cmd-QUIT "")
+ (funcall expect 10 "finished")
+
+ (ert-info ("Toggle mode off")
+ (erc-sasl-mode -1)
+ (should (local-variable-p 'erc-sasl-mode)))))
+
+ (ert-info ("Reconnecting via entry point discards `erc-sasl-mode' value.")
+ ;; If you were to /RECONNECT here, no PASS changeme would be
+ ;; sent instead of CAP SASL, resulting in a failure.
+ (with-current-buffer (erc :server "127.0.0.1"
+ :port port
+ :nick "tester"
+ :user "tester"
+ :password "changeme"
+ :full-name "tester")
+ (should (string= (buffer-name) server-buffer-name))
+ (funcall expect 10 "You are now logged in as tester")
+
+ (erc-d-t-wait-for 10 (equal (buffer-name) "foonet"))
+ (funcall expect 10 "User modes for tester")
+ (should erc-sasl-mode)) ; obviously
+
+ ;; No other foonet buffer exists, e.g., foonet<2>
+ (should-not (cdr (erc-scenarios-common-buflist "foonet")))
+
+ (ert-info ("Target buffer retains local-module state")
+ (with-current-buffer (erc-d-t-wait-for 10 (get-buffer "#chan"))
+ (funcall expect 20 "She is Lavinia, therefore must")
+ (should-not erc-sasl-mode)
+ (should (local-variable-p 'erc-sasl-mode))
+ (erc-cmd-QUIT ""))))))
+
+;;; erc-scenarios-base-local-module-modes.el ends here
diff --git a/test/lisp/erc/erc-scenarios-base-local-modules.el b/test/lisp/erc/erc-scenarios-base-local-modules.el
index 6a48da0d574..9604c6ea17c 100644
--- a/test/lisp/erc/erc-scenarios-base-local-modules.el
+++ b/test/lisp/erc/erc-scenarios-base-local-modules.el
@@ -82,105 +82,6 @@
(erc-cmd-QUIT "")
(funcall expect 10 "finished")))))
-;; After quitting a session for which `sasl' is enabled, you
-;; disconnect and toggle `erc-sasl-mode' off. You then reconnect
-;; using an alternate nickname. You again disconnect and reconnect,
-;; this time immediately, and the mode stays disabled. Finally, you
-;; once again disconnect, toggle the mode back on, and reconnect. You
-;; are authenticated successfully, just like in the initial session.
-;;
-;; This is meant to show that a user's local mode settings persist
-;; between sessions. It also happens to show (in round four, below)
-;; that a server renicking a user on 001 after a 903 is handled just
-;; like a user-initiated renick, although this is not the main thrust.
-
-(ert-deftest erc-scenarios-base-local-modules--mode-persistence ()
- :tags '(:expensive-test)
- (erc-scenarios-common-with-cleanup
- ((erc-scenarios-common-dialog "base/local-modules")
- (erc-server-flood-penalty 0.1)
- (dumb-server (erc-d-run "localhost" t 'first 'second 'third 'fourth))
- (port (process-contact dumb-server :service))
- (erc-modules (cons 'sasl erc-modules))
- (expect (erc-d-t-make-expecter))
- (server-buffer-name (format "127.0.0.1:%d" port)))
-
- (ert-info ("Round one, initial authentication succeeds as expected")
- (with-current-buffer (erc :server "127.0.0.1"
- :port port
- :nick "tester"
- :user "tester"
- :password "changeme"
- :full-name "tester")
- (should (string= (buffer-name) server-buffer-name))
- (funcall expect 10 "You are now logged in as tester"))
-
- (with-current-buffer (erc-d-t-wait-for 10 (get-buffer "foonet"))
- (funcall expect 10 "This server is in debug mode")
- (erc-cmd-JOIN "#chan")
-
- (with-current-buffer (erc-d-t-wait-for 10 (get-buffer "#chan"))
- (funcall expect 20 "She is Lavinia, therefore must"))
-
- (erc-cmd-QUIT "")
- (funcall expect 10 "finished")))
-
- (ert-info ("Round two, nick rejected, alternate granted")
- (with-current-buffer "foonet"
-
- (ert-info ("Toggle mode off, reconnect")
- (erc-sasl-mode -1)
- (erc-cmd-RECONNECT))
-
- (funcall expect 10 "User modes for tester`")
- (should-not (cdr (erc-scenarios-common-buflist "foonet")))
- (should (equal (buffer-name) "foonet"))
- (should-not (cdr (erc-scenarios-common-buflist "#chan")))
-
- (with-current-buffer "#chan"
- (funcall expect 10 "Some enigma, some riddle"))
-
- (erc-cmd-QUIT "")
- (funcall expect 10 "finished")))
-
- (ert-info ("Round three, send alternate nick initially")
- (with-current-buffer "foonet"
-
- (ert-info ("Keep mode off, reconnect")
- (should-not erc-sasl-mode)
- (should (local-variable-p 'erc-sasl-mode))
- (erc-cmd-RECONNECT))
-
- (funcall expect 10 "User modes for tester`")
- (should-not (cdr (erc-scenarios-common-buflist "foonet")))
- (should (equal (buffer-name) "foonet"))
- (should-not (cdr (erc-scenarios-common-buflist "#chan")))
-
- (with-current-buffer "#chan"
- (funcall expect 10 "Let our reciprocal vows be remembered."))
-
- (erc-cmd-QUIT "")
- (funcall expect 10 "finished")))
-
- (ert-info ("Round four, authenticated successfully again")
- (with-current-buffer "foonet"
-
- (ert-info ("Toggle mode on, reconnect")
- (should-not erc-sasl-mode)
- (should (local-variable-p 'erc-sasl-mode))
- (erc-sasl-mode +1)
- (erc-cmd-RECONNECT))
-
- (funcall expect 10 "User modes for tester")
- (should-not (cdr (erc-scenarios-common-buflist "foonet")))
- (should (equal (buffer-name) "foonet"))
- (should-not (cdr (erc-scenarios-common-buflist "#chan")))
-
- (with-current-buffer "#chan"
- (funcall expect 10 "Well met; good morrow, Titus and Hortensius."))
-
- (erc-cmd-QUIT "")))))
-
;; For local modules, the twin toggle commands `erc-FOO-enable' and
;; `erc-FOO-disable' affect all buffers of a connection, whereas
;; `erc-FOO-mode' continues to operate only on the current buffer.
diff --git a/test/lisp/erc/erc-scenarios-base-misc-regressions.el b/test/lisp/erc/erc-scenarios-base-misc-regressions.el
index 7a16b8f57c1..df2aa8e82ec 100644
--- a/test/lisp/erc/erc-scenarios-base-misc-regressions.el
+++ b/test/lisp/erc/erc-scenarios-base-misc-regressions.el
@@ -77,7 +77,7 @@ Originally from scenario rebuffed/gapless as explained in Bug#48598:
(with-current-buffer (erc-d-t-wait-for 20 (get-buffer "#bar"))
(funcall expect 10 "was created on")
- (funcall expect 2 "his second fit"))
+ (funcall expect 10 "his second fit"))
(with-current-buffer (erc-d-t-wait-for 20 (get-buffer "#foo"))
(funcall expect 10 "was created on")
@@ -108,7 +108,7 @@ Originally from scenario rebuffed/gapless as explained in Bug#48598:
(should (string= (buffer-name) (format "127.0.0.1:%d" port)))))
(ert-info ("Server buffer is unique and temp name is absent")
- (erc-d-t-wait-for 1 (get-buffer "FooNet"))
+ (erc-d-t-wait-for 10 (get-buffer "FooNet"))
(should-not (erc-scenarios-common-buflist "127.0.0.1"))
(with-current-buffer erc-server-buffer-foo
(erc-cmd-JOIN "#chan")))
diff --git a/test/lisp/erc/erc-scenarios-base-reconnect.el b/test/lisp/erc/erc-scenarios-base-reconnect.el
index 04aa3802259..6f968b9fcbc 100644
--- a/test/lisp/erc/erc-scenarios-base-reconnect.el
+++ b/test/lisp/erc/erc-scenarios-base-reconnect.el
@@ -65,95 +65,6 @@
(should (equal (list (get-buffer (format "127.0.0.1:%d" port)))
(erc-scenarios-common-buflist "127.0.0.1"))))))
-(defun erc-scenarios-common--base-reconnect-options (test)
- (erc-scenarios-common-with-cleanup
- ((erc-scenarios-common-dialog "base/reconnect")
- (dumb-server (erc-d-run "localhost" t 'options 'options-again))
- (port (process-contact dumb-server :service))
- (expect (erc-d-t-make-expecter))
- (erc-server-flood-penalty 0.1)
- (erc-server-auto-reconnect t)
- erc-autojoin-channels-alist
- erc-server-buffer)
-
- (should (memq 'autojoin erc-modules))
-
- (ert-info ("Connect to foonet")
- (setq erc-server-buffer (erc :server "127.0.0.1"
- :port port
- :nick "tester"
- :password "changeme"
- :full-name "tester"))
- (with-current-buffer erc-server-buffer
- (should (string= (buffer-name) (format "127.0.0.1:%d" port)))
- (funcall expect 10 "debug mode")))
-
- (ert-info ("Wait for some output in channels")
- (with-current-buffer (erc-d-t-wait-for 10 (get-buffer "#chan"))
- (funcall expect 10 "welcome")))
-
- (ert-info ("Server buffer shows connection failed")
- (with-current-buffer erc-server-buffer
- (funcall expect 10 "Connection failed! Re-establishing")))
-
- (should (equal erc-autojoin-channels-alist '((FooNet "#chan"))))
-
- (funcall test)
-
- ;; A manual /JOIN command tells ERC we're done auto-reconnecting
- (with-current-buffer "FooNet" (erc-cmd-JOIN "#spam"))
-
- (erc-d-t-ensure-for 1 "Newly joined chan ignores `erc-reconnect-display'"
- (not (eq (window-buffer) (get-buffer "#spam"))))
-
- (ert-info ("Wait for auto reconnect")
- (with-current-buffer erc-server-buffer
- (funcall expect 10 "still in debug mode")))
-
- (ert-info ("Wait for activity to recommence in channels")
- (with-current-buffer (erc-d-t-wait-for 10 (get-buffer "#chan"))
- (funcall expect 10 "forest of Arden"))
- (with-current-buffer (erc-d-t-wait-for 10 (get-buffer "#spam"))
- (funcall expect 10 "her elves come here anon")))))
-
-(ert-deftest erc-scenarios-base-reconnect-options--buffer ()
- :tags '(:expensive-test)
- (should (eq erc-join-buffer 'bury))
- (should-not erc-reconnect-display)
-
- ;; FooNet (the server buffer) is not switched to because it's
- ;; already current (but not shown) when `erc-open' is called. See
- ;; related conditional guard towards the end of that function.
-
- (let ((erc-reconnect-display 'buffer))
- (erc-scenarios-common--base-reconnect-options
- (lambda ()
- (pop-to-buffer-same-window "*Messages*")
-
- (erc-d-t-ensure-for 1 "Server buffer not shown"
- (not (eq (window-buffer) (get-buffer "FooNet"))))
-
- (erc-d-t-wait-for 5 "Channel #chan shown when autojoined"
- (eq (window-buffer) (get-buffer "#chan")))))))
-
-(ert-deftest erc-scenarios-base-reconnect-options--default ()
- :tags '(:expensive-test)
- (should (eq erc-join-buffer 'bury))
- (should-not erc-reconnect-display)
-
- (erc-scenarios-common--base-reconnect-options
-
- (lambda ()
- (pop-to-buffer-same-window "*Messages*")
-
- (erc-d-t-ensure-for 1 "Server buffer not shown"
- (not (eq (window-buffer) (get-buffer "FooNet"))))
-
- (erc-d-t-ensure-for 3 "Channel #chan not shown"
- (not (eq (window-buffer) (get-buffer "#chan"))))
-
- (eq (window-buffer) (messages-buffer)))))
-
;; Upon reconnecting, playback for channel and target buffers is
;; routed correctly. Autojoin is irrelevant here, but for the
;; skeptical, see `erc-scenarios-common--join-network-id', which
@@ -260,7 +171,7 @@
(funcall expect 2 "Canceled")
(funcall expect 3 "Opening connection")
(funcall expect 2 "Password incorrect")
- (funcall expect 2 "Connection failed!")
+ (funcall expect 10 "Connection failed!")
(funcall expect 2 "Re-establishing connection"))
(ert-info ("Explicitly cancel timer")
(erc-cmd-RECONNECT "cancel")
diff --git a/test/lisp/erc/erc-scenarios-base-renick.el b/test/lisp/erc/erc-scenarios-base-renick.el
index d454c8ce3a5..e0fcb8b9366 100644
--- a/test/lisp/erc/erc-scenarios-base-renick.el
+++ b/test/lisp/erc/erc-scenarios-base-renick.el
@@ -173,7 +173,7 @@
(with-current-buffer erc-server-buffer-foo
(should (string= (buffer-name) (format "127.0.0.1:%d" port)))))
- (erc-d-t-wait-for 1 (get-buffer "foonet"))
+ (erc-d-t-wait-for 10 (get-buffer "foonet"))
(ert-info ("Joined by bouncer to #foo, pal persent")
(with-current-buffer (erc-d-t-wait-for 1 (get-buffer "#foo"))
@@ -267,7 +267,7 @@
(ert-info ("Sync convo for rando@foonet")
(with-current-buffer "rando@foonet"
- (funcall expect 1 "u are dumb")
+ (funcall expect 10 "u are dumb")
(erc-scenarios-common-say "not so")))
(ert-info ("Sync convo for rando@barnet")
@@ -275,18 +275,18 @@
(funcall expect 3 "I never saw her before")
(erc-scenarios-common-say "You aren't with Wage?")))
- (erc-d-t-wait-for 3 (get-buffer "frenemy@foonet"))
- (erc-d-t-wait-for 3 (get-buffer "frenemy@barnet"))
+ (erc-d-t-wait-for 10 (get-buffer "frenemy@foonet"))
+ (erc-d-t-wait-for 10 (get-buffer "frenemy@barnet"))
(should-not (get-buffer "rando@foonet"))
(should-not (get-buffer "rando@barnet"))
(with-current-buffer "frenemy@foonet"
- (funcall expect 1 "now known as")
- (funcall expect 1 "doubly so"))
+ (funcall expect 10 "now known as")
+ (funcall expect 10 "doubly so"))
(with-current-buffer "frenemy@barnet"
- (funcall expect 1 "now known as")
- (funcall expect 1 "reality picture"))
+ (funcall expect 10 "now known as")
+ (funcall expect 10 "reality picture"))
(when noninteractive
(with-current-buffer "frenemy@barnet" (kill-buffer))
diff --git a/test/lisp/erc/erc-scenarios-base-reuse-buffers.el b/test/lisp/erc/erc-scenarios-base-reuse-buffers.el
index 6d6fe0536f5..f07b7024bf3 100644
--- a/test/lisp/erc/erc-scenarios-base-reuse-buffers.el
+++ b/test/lisp/erc/erc-scenarios-base-reuse-buffers.el
@@ -124,6 +124,7 @@ Adapted from scenario clash-of-chans/uniquify described in Bug#48598:
(erc-d-t-search-for 1 "shake my sword")
(erc-cmd-PART "#chan")
(funcall expect 3 "You have left channel #chan")
+ (should-not (erc-get-channel-user (erc-current-nick)))
(erc-cmd-JOIN "#chan")))
(ert-info ("Part #chan@barnet")
@@ -139,6 +140,7 @@ Adapted from scenario clash-of-chans/uniquify described in Bug#48598:
(get-buffer "#chan/127.0.0.1<3>"))
(ert-info ("Activity continues in new, <n>-suffixed #chan@foonet buffer")
+ ;; The first /JOIN did not cause the same buffer to be reused.
(with-current-buffer "#chan/127.0.0.1"
(should-not (erc-get-channel-user (erc-current-nick))))
(with-current-buffer "#chan/127.0.0.1<3>"
diff --git a/test/lisp/erc/erc-scenarios-base-send-message.el b/test/lisp/erc/erc-scenarios-base-send-message.el
new file mode 100644
index 00000000000..729c94f5ab7
--- /dev/null
+++ b/test/lisp/erc/erc-scenarios-base-send-message.el
@@ -0,0 +1,126 @@
+;;; erc-scenarios-base-send-message.el --- `send-message' scenarios -*- lexical-binding: t -*-
+
+;; Copyright (C) 2022-2024 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 <https://www.gnu.org/licenses/>.
+
+;;; Code:
+
+(require 'ert-x)
+(eval-and-compile
+ (let ((load-path (cons (ert-resource-directory) load-path)))
+ (require 'erc-scenarios-common)))
+
+;; So-called "noncommands" are those that massage input submitted at
+;; the prompt and send it on behalf of the user.
+
+(ert-deftest erc-scenarios-base-send-message--noncommands ()
+ :tags '(:expensive-test)
+ (erc-scenarios-common-with-cleanup
+ ((erc-scenarios-common-dialog "base/send-message")
+ (erc-server-flood-penalty 0.1)
+ (dumb-server (erc-d-run "localhost" t 'noncommands))
+ (erc-modules (cons 'fill-wrap erc-modules))
+ (erc-autojoin-channels-alist '((foonet "#chan")))
+ (expect (erc-d-t-make-expecter)))
+
+ (ert-info ("Connect to foonet")
+ (with-current-buffer (erc :server "127.0.0.1"
+ :port (process-contact dumb-server :service)
+ :nick "tester"
+ :full-name "tester")
+ (funcall expect 5 "debug mode")))
+
+ (with-current-buffer (erc-d-t-wait-for 5 (get-buffer "#chan"))
+ (ert-info ("Send CTCP ACTION")
+ (funcall expect 10 "<bob> alice: For hands, to do Rome")
+ (erc-scenarios-common-say "/me sad")
+ (funcall expect 10 "* tester sad"))
+
+ (ert-info ("Send literal command")
+ (funcall expect 10 "<alice> bob: Spotted, detested")
+ (erc-scenarios-common-say "/say /me sad")
+ (funcall expect 10 "<tester> /me sad"))
+
+ (ert-info ("\"Nested\" `noncommands'")
+
+ (ert-info ("Send version via /SV")
+ (funcall expect 10 "<bob> Marcus, my brother!")
+ (erc-scenarios-common-say "/sv")
+ (funcall expect 10 "<tester> I'm using ERC"))
+
+ (ert-info ("Send module list via /SM")
+ (funcall expect 10 "<bob> alice: You still wrangle")
+ (erc-scenarios-common-say "/sm")
+ (funcall expect 10 "<tester> I'm using the following modules: ")
+ (funcall expect 10 "<alice> No, not till Thursday;"))))))
+
+
+;; This asserts that the `command-indicator' module only inserts
+;; prompt-like prefixes for normal slash commands, like /JOIN.
+
+(ert-deftest erc-scenarios-base-send-message--command-indicator ()
+ :tags '(:expensive-test)
+ (erc-scenarios-common-with-cleanup
+ ((erc-scenarios-common-dialog "base/send-message")
+ (erc-server-flood-penalty 0.1)
+ (dumb-server (erc-d-run "localhost" t 'noncommands))
+ (erc-modules `(command-indicator fill-wrap ,@erc-modules))
+ (expect (erc-d-t-make-expecter)))
+
+ (ert-info ("Connect to foonet")
+ (with-current-buffer (erc :server "127.0.0.1"
+ :port (process-contact dumb-server :service)
+ :nick "tester"
+ :full-name "tester")
+ (funcall expect 5 "debug mode")
+ (erc-scenarios-common-say "/join #chan")
+ (funcall expect 10 "ERC> /join #chan")))
+
+ (with-current-buffer (erc-d-t-wait-for 5 (get-buffer "#chan"))
+ (ert-info ("Prompt absent for CTCP ACTION")
+ (funcall expect 10 "<bob> alice: For hands, to do Rome")
+ (erc-scenarios-common-say "/me sad")
+ (funcall expect -0.1 "ERC> /me sad")
+ (funcall expect 10 "* tester sad"))
+
+ (ert-info ("Prompt absent for literal command")
+ (funcall expect 10 "<alice> bob: Spotted, detested")
+ (erc-scenarios-common-say "/say /me sad")
+ (funcall expect -0.1 "ERC> /say /me sad")
+ (funcall expect 10 "<tester> /me sad"))
+
+ (ert-info ("Prompt absent for /SV")
+ (funcall expect 10 "<bob> Marcus, my brother!")
+ (erc-scenarios-common-say "/sv")
+ (funcall expect -0.1 "ERC> /sv")
+ (funcall expect 10 "<tester> I'm using ERC"))
+
+ (ert-info ("Prompt absent module list via /SM")
+ (funcall expect 10 "<bob> alice: You still wrangle")
+ (erc-scenarios-common-say "/sm")
+ (funcall expect -0.1 "ERC> /sm")
+ (funcall expect 10 "<tester> I'm using the following modules: ")
+ (funcall expect 10 "<alice> No, not till Thursday;"))
+
+ (ert-info ("Prompt present for /QUIT in issuing buffer")
+ (erc-scenarios-common-say "/quit")
+ (funcall expect 10 "ERC> /quit"))
+
+ (with-current-buffer "foonet"
+ (funcall expect 10 "ERC finished")))))
+
+;;; erc-scenarios-base-send-message.el ends here
diff --git a/test/lisp/erc/erc-scenarios-base-split-line.el b/test/lisp/erc/erc-scenarios-base-split-line.el
new file mode 100644
index 00000000000..dee5950f8ef
--- /dev/null
+++ b/test/lisp/erc/erc-scenarios-base-split-line.el
@@ -0,0 +1,202 @@
+;;; erc-scenarios-base-split-line.el --- ERC line splitting -*- lexical-binding: t -*-
+
+;; Copyright (C) 2023-2024 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 <https://www.gnu.org/licenses/>.
+
+;;; Code:
+
+(require 'ert-x)
+(eval-and-compile
+ (let ((load-path (cons (ert-resource-directory) load-path)))
+ (require 'erc-scenarios-common)))
+
+(ert-deftest erc-scenarios-base-split-line--koi8-r ()
+ :tags '(:expensive-test)
+ (should (equal erc-split-line-length 440))
+ (erc-scenarios-common-with-cleanup
+ ((erc-scenarios-common-dialog "base/flood")
+ (erc-server-flood-penalty 0.1)
+ (dumb-server (erc-d-run "localhost" t 'koi8-r))
+ (erc-encoding-coding-alist '(("#koi8" . cyrillic-koi8)))
+ (port (process-contact dumb-server :service))
+ (expect (erc-d-t-make-expecter)))
+
+ (ert-info ("Connect to server")
+ (with-current-buffer (erc :server "127.0.0.1"
+ :port port
+ :nick "tester"
+ :full-name "tester")
+ (funcall expect 10 "debug mode")
+ (erc-cmd-JOIN "#koi8")))
+
+ (with-current-buffer (erc-d-t-wait-for 8 (get-buffer "#koi8"))
+ (funcall expect 10 "короче теперь")
+ (ert-info ("Message well within `erc-split-line-length'")
+ (erc-scenarios-common-say
+ (concat
+ "короче теперь если по русски написать все четко или все равно"
+ " короче теперь если по русски написать все четко или все равно"
+ " короче теперь если по русски написать все четко или все равно"
+ " короче теперь если по русски написать все четко или все равно"))
+ (funcall expect 1 "<tester>")
+ (funcall expect -0.1 "<tester>"))
+
+ (ert-info ("Message over `erc-split-line-length'")
+ (erc-scenarios-common-say
+ (concat
+ "короче теперь если по русски написать все четко или все равно"
+ " короче теперь если по русски написать все четко или все равно"
+ " короче теперь если по русски написать все четко или все равно"
+ " короче теперь если по русски написать все четко или все равно"
+ " короче теперь если по русски написать все четко или все равно"
+ " короче теперь если по русски написать все четко или все равно"
+ " короче теперь если по русски написать все четко или все равно"
+ " будет разрыв строки непонятно где"))
+ (funcall expect 1 "<tester>")
+ (funcall expect 1 "<tester> разрыв")))
+
+ (with-current-buffer "foonet"
+ (erc-cmd-QUIT "")
+ (funcall expect 10 "finished"))))
+
+(ert-deftest erc-scenarios-base-split-line--ascii ()
+ :tags '(:expensive-test)
+ (should (equal erc-split-line-length 440))
+ (erc-scenarios-common-with-cleanup
+ ((erc-scenarios-common-dialog "base/flood")
+ (msg-432 (string-join (make-list 18 "twenty-three characters") " "))
+ (erc-server-flood-penalty 0.1)
+ (dumb-server (erc-d-run "localhost" t 'ascii))
+ (port (process-contact dumb-server :service))
+ (expect (erc-d-t-make-expecter)))
+
+ (ert-info ("Connect to server")
+ (with-current-buffer (erc :server "127.0.0.1"
+ :port port
+ :nick "tester"
+ :full-name "tester")
+ (funcall expect 10 "debug mode")
+ (erc-cmd-JOIN "#ascii")))
+
+ (with-current-buffer (erc-d-t-wait-for 8 (get-buffer "#ascii"))
+ (ert-info ("Message with spaces fits exactly")
+ (funcall expect 10 "Welcome")
+ (should (= (length (concat msg-432 " 12345678")) 440))
+ (erc-scenarios-common-say (concat msg-432 " 12345678"))
+ (funcall expect 1 "<tester>")
+ ;; Sent in a single go, hence no second <speaker>.
+ (funcall expect -0.1 "<tester>")
+ (funcall expect 0.1 "12345678"))
+
+ (ert-info ("Message with spaces too long.")
+ (erc-scenarios-common-say (concat msg-432 " 123456789"))
+ (funcall expect 1 "<tester>")
+ ;; Sent in two passes, split at last word.
+ (funcall expect 0.1 "<tester> 123456789"))
+
+ (ert-info ("Message sans spaces fits exactly")
+ (erc-scenarios-common-say (make-string 440 ?x))
+ (funcall expect 1 "<tester>")
+ ;; Sent in a single go, hence no second <speaker>.
+ (funcall expect -0.1 "<tester>"))
+
+ (ert-info ("Message sans spaces too long.")
+ (erc-scenarios-common-say (concat (make-string 440 ?y) "z"))
+ (funcall expect 1 "<tester>")
+ ;; Sent in two passes, split at last word.
+ (funcall expect 0.1 "<tester> z"))
+
+ (ert-info ("Rejected when escape-hatch set")
+ (let ((erc--reject-unbreakable-lines t))
+ (should-error
+ (erc-scenarios-common-say
+ (concat
+ "https://mail.example.org/verify?token="
+ (string-join (make-list 18 "twenty-three_characters") "_")))))))
+
+ (with-current-buffer "foonet"
+ (erc-cmd-QUIT "")
+ (funcall expect 10 "finished"))))
+
+(ert-deftest erc-scenarios-base-split-line--utf-8 ()
+ :tags '(:expensive-test)
+ (unless (> emacs-major-version 27)
+ (ert-skip "No emojis in Emacs 27"))
+
+ (should (equal erc-split-line-length 440))
+ (erc-scenarios-common-with-cleanup
+ ((erc-scenarios-common-dialog "base/flood")
+ (msg-432 (string-join (make-list 18 "twenty-three characters") " "))
+ (erc-server-flood-penalty 0.1)
+ (dumb-server (erc-d-run "localhost" t 'utf-8))
+ (port (process-contact dumb-server :service))
+ (expect (erc-d-t-make-expecter)))
+
+ (ert-info ("Connect to server")
+ (with-current-buffer (erc :server "127.0.0.1"
+ :port port
+ :nick "tester"
+ :full-name "tester")
+ (funcall expect 10 "debug mode")
+ (erc-cmd-JOIN "#utf-8")))
+
+ (with-current-buffer (erc-d-t-wait-for 8 (get-buffer "#utf-8"))
+ (funcall expect 10 "Welcome")
+
+ (ert-info ("Message with spaces over `erc-split-line-length'")
+ (erc-scenarios-common-say
+ (concat
+ "короче теперь если по русски написать все четко или все равно"
+ " короче теперь если по русски написать все четко или все равно"
+ " короче теперь если по русски написать все четко или все равно"
+ " короче теперь если по русски написать все четко или все равно"
+ " короче теперь если по русски написать все четко или все равно"
+ " короче теперь если по русски написать все четко или все равно"
+ " короче теперь если по русски написать все четко или все равно"
+ " будет разрыв строки непонятно где"
+ " будет разрыв строки непонятно где"))
+ (funcall expect 1 "<tester> короче")
+ (funcall expect 1 "<tester> все")
+ (funcall expect 1 "<tester> разрыв")
+ (funcall expect 1 "Entirely honour"))
+
+ (ert-info ("Message sans spaces over `erc-split-line-length'")
+ (erc-scenarios-common-say
+ (concat "話說天下大勢,分久必合,合久必分:周末七國分爭,并入於秦。"
+ "及秦滅之後,楚、漢分爭,又并入於漢。漢朝自高祖斬白蛇而起義,"
+ "一統天下。後來光武中興,傳至獻帝,遂分為三國。推其致亂之由,"
+ "殆始於桓、靈二帝。桓帝禁錮善類,崇信宦官。及桓帝崩,靈帝即位,"
+ "大將軍竇武、太傅陳蕃,共相輔佐。時有宦官曹節等弄權,竇武、陳蕃謀誅之,"
+ "作事不密,反為所害。中涓自此愈橫"))
+ (funcall expect 1 "<tester>")
+ ;; Sent in two passes, split at last word.
+ (funcall expect 0.1 "<tester> 竇武")
+ (funcall expect 1 "this prey out"))
+
+ ;; Combining emojis are respected.
+ (ert-info ("Message sans spaces over small `erc-split-line-length'")
+ (let ((erc-split-line-length 100))
+ (erc-scenarios-common-say
+ "будет разрыв строки непонятно где🏁🚩🎌🏴🏳️🏳️‍🌈🏳️‍⚧️🏴‍☠️"))
+ (funcall expect 1 "<tester>")
+ (funcall expect 1 "<tester> 🏳️‍🌈")))
+
+ (with-current-buffer "foonet"
+ (erc-cmd-QUIT "")
+ (funcall expect 10 "finished"))))
+
+;;; erc-scenarios-base-split-line.el ends here
diff --git a/test/lisp/erc/erc-scenarios-base-statusmsg.el b/test/lisp/erc/erc-scenarios-base-statusmsg.el
new file mode 100644
index 00000000000..480ba7fa8d0
--- /dev/null
+++ b/test/lisp/erc/erc-scenarios-base-statusmsg.el
@@ -0,0 +1,103 @@
+;;; erc-scenarios-base-statusmsg.el --- statusmsg tests -*- lexical-binding: t -*-
+
+;; Copyright (C) 2023-2024 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 <https://www.gnu.org/licenses/>.
+
+;;; Code:
+
+(require 'ert-x)
+(eval-and-compile
+ (let ((load-path (cons (ert-resource-directory) load-path)))
+ (require 'erc-scenarios-common)))
+
+(ert-deftest erc-scenarios-base-statusmsg ()
+
+ (erc-scenarios-common-with-cleanup
+ ((erc-scenarios-common-dialog "base/display-message")
+ (dumb-server (erc-d-run "localhost" t 'statusmsg))
+ (erc-autojoin-channels-alist '((foonet "#mine")))
+ (erc-modules (cons 'fill-wrap erc-modules))
+ (port (process-contact dumb-server :service))
+ (erc-show-speaker-membership-status nil)
+ (erc-server-flood-penalty 0.1)
+ (expect (erc-d-t-make-expecter)))
+
+ (ert-info ("Connect")
+ (with-current-buffer (erc :server "127.0.0.1"
+ :port port
+ :nick "tester"
+ :user "tester"
+ :full-name "tester")
+ (funcall expect 5 "This server is in debug mode")))
+
+ (with-current-buffer (erc-d-t-wait-for 10 (get-buffer "#mine"))
+
+ (ert-info ("Receive status messages unprefixed")
+ (funcall expect 5 "+dummy")
+ (funcall expect 5 "(dummy+) hello")
+ (should (eq 'statusmsg (erc--get-inserted-msg-prop 'erc--msg)))
+ (should (equal "dummy" (erc--get-inserted-msg-prop 'erc--spkr)))
+ (should (eq (get-text-property (1- (point)) 'font-lock-face)
+ 'erc-default-face))
+ (funcall expect 5 "(dummy+) there")
+ (should (equal "" (get-text-property (pos-bol) 'display)))
+
+ ;; CTCP ACTION
+ (funcall expect 5 "* (dummy+) sad")
+ (should (eq 'ctcp-action-statusmsg
+ (erc--get-inserted-msg-prop 'erc--msg)))
+ (should (eq (get-text-property (1- (point)) 'font-lock-face)
+ 'erc-action-face))
+ (funcall expect 5 "* (dummy+) glad")
+ (should (equal "" (get-text-property (pos-bol) 'display))))
+
+ (ert-info ("Send status messages")
+ ;; We don't have `echo-message' yet, so ERC doesn't currently
+ ;; insert commands like "/msg +#mine foo".
+ (let ((erc-default-recipients '("+#mine")))
+ (erc-send-message "howdy"))
+ (funcall expect 5 "(@tester+) howdy")
+ (should (eq 'statusmsg-input (erc--get-inserted-msg-prop 'erc--msg)))
+ (should (equal "tester" (erc--get-inserted-msg-prop 'erc--spkr)))
+ (should (eq (get-text-property (1- (point)) 'font-lock-face)
+ 'erc-input-face))
+ (let ((erc-default-recipients '("+#mine")))
+ (erc-send-message "tenderfoot"))
+ (funcall expect 5 "(@tester+) tenderfoot")
+ (should (equal "" (get-text-property (pos-bol) 'display)))
+
+ ;; Simulate some "echoed" CTCP ACTION messages since we don't
+ ;; actually support that yet.
+ (funcall expect 5 "* (@tester+) mad")
+ (should (eq 'ctcp-action-statusmsg-input
+ (erc--get-inserted-msg-prop 'erc--msg)))
+ (should (equal (get-text-property (1- (point)) 'font-lock-face)
+ '(erc-input-face erc-action-face)))
+ (funcall expect 5 "* (@tester+) chad")
+ (should (equal "" (get-text-property (pos-bol) 'display))))
+
+ (ert-info ("Receive status messages prefixed")
+ (setq erc-show-speaker-membership-status t)
+ (erc-scenarios-common-say "/me ready") ; sync
+ (funcall expect 5 "* @tester ready")
+ (funcall expect 5 "(+dummy+) okie")
+
+ ;; CTCP ACTION
+ (funcall expect 5 "* (+dummy+) dokie")
+ (funcall expect 5 "* +dummy out")))))
+
+;;; erc-scenarios-base-statusmsg.el ends here
diff --git a/test/lisp/erc/erc-scenarios-base-upstream-recon-znc.el b/test/lisp/erc/erc-scenarios-base-upstream-recon-znc.el
index bbd9c79f593..f3905974a11 100644
--- a/test/lisp/erc/erc-scenarios-base-upstream-recon-znc.el
+++ b/test/lisp/erc/erc-scenarios-base-upstream-recon-znc.el
@@ -42,4 +42,50 @@
'znc-foonet
'znc-barnet))
+;; Here, the upstream connection is already severed when first
+;; connecting. The bouncer therefore sends query messages from an
+;; administrative bot before the first numerics burst, which results
+;; in a target buffer not being associated with an `erc-networks--id'.
+;; The problem only manifests later, when the buffer-association
+;; machinery checks the names of all target buffers and assumes a
+;; non-nil `erc-networks--id'.
+(ert-deftest erc-scenarios-upstream-recon--znc/severed ()
+ (erc-scenarios-common-with-cleanup
+ ((erc-scenarios-common-dialog "base/upstream-reconnect")
+ (erc-d-t-cleanup-sleep-secs 1)
+ (erc-server-flood-penalty 0.1)
+ (dumb-server (erc-d-run "localhost" t 'znc-severed))
+ (port (process-contact dumb-server :service))
+ (expect (erc-d-t-make-expecter)))
+
+ (ert-info ("Connect to foonet")
+ (with-current-buffer (erc :server "127.0.0.1"
+ :port port
+ :nick "tester"
+ :user "tester@vanilla/foonet"
+ :password "changeme"
+ :full-name "tester")
+ (erc-scenarios-common-assert-initial-buf-name nil port)
+ (erc-d-t-wait-for 6 (eq (erc-network) 'foonet))))
+
+ (with-current-buffer (erc-d-t-wait-for 5 (get-buffer "*status"))
+ (funcall expect 10 "Connection Refused. Reconnecting...")
+ (funcall expect 10 "Connected!"))
+
+ (ert-info ("Join #chan")
+ (with-current-buffer (erc-d-t-wait-for 10 (get-buffer "#chan"))
+ (funcall expect 10 "<alice> tester, welcome!")
+ (funcall expect 10 "<bob> alice: And see a fearful sight")
+ (funcall expect 10 "<eve> hola")
+ (funcall expect 10 "<Evel> hell o")
+ ;;
+ (funcall expect 10 "<alice> bob: Or to drown my clothes")))
+
+ (ert-info ("Buffer not renamed with net id")
+ (should (get-buffer "*status")))
+
+ (ert-info ("No error")
+ (with-current-buffer (messages-buffer)
+ (funcall expect -0.1 "error in process filter")))))
+
;;; erc-scenarios-base-upstream-recon-znc.el ends here
diff --git a/test/lisp/erc/erc-scenarios-display-message.el b/test/lisp/erc/erc-scenarios-display-message.el
new file mode 100644
index 00000000000..8e9c355576e
--- /dev/null
+++ b/test/lisp/erc/erc-scenarios-display-message.el
@@ -0,0 +1,63 @@
+;;; erc-scenarios-display-message.el --- erc-display-message -*- lexical-binding: t -*-
+
+;; Copyright (C) 2023-2024 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 <https://www.gnu.org/licenses/>.
+
+;;; Code:
+
+(require 'ert-x)
+(eval-and-compile
+ (let ((load-path (cons (ert-resource-directory) load-path)))
+ (require 'erc-scenarios-common)))
+
+(ert-deftest erc-scenarios-display-message--multibuf ()
+ :tags '(:expensive-test)
+ (erc-scenarios-common-with-cleanup
+ ((erc-scenarios-common-dialog "base/display-message")
+ (dumb-server (erc-d-run "localhost" t 'multibuf))
+ (port (process-contact dumb-server :service))
+ (erc-server-flood-penalty 0.1)
+ (erc-modules (cons 'fill-wrap erc-modules))
+ (erc-autojoin-channels-alist '((foonet "#chan")))
+ (expect (erc-d-t-make-expecter)))
+
+ (ert-info ("Connect to foonet")
+ (with-current-buffer (erc :server "127.0.0.1"
+ :port port
+ :nick "tester"
+ :full-name "tester")
+ (funcall expect 10 "debug mode")))
+
+ (ert-info ("User dummy is a member of #chan")
+ (with-current-buffer (erc-d-t-wait-for 5 (get-buffer "#chan"))
+ (funcall expect 10 "dummy")))
+
+ (ert-info ("Dummy's QUIT notice in query contains metadata props")
+ (with-current-buffer (erc-d-t-wait-for 5 (get-buffer "dummy"))
+ (funcall expect 10 "<dummy> hi")
+ (funcall expect 10 "*** dummy (~u@rdjcgiwfuwqmc.irc) has quit")
+ (should (eq 'QUIT (get-text-property (match-beginning 0) 'erc--msg)))))
+
+ (ert-info ("Dummy's QUIT notice in #chan contains metadata props")
+ (with-current-buffer (erc-d-t-wait-for 5 (get-buffer "#chan"))
+ (funcall expect 10 "*** dummy (~u@rdjcgiwfuwqmc.irc) has quit")
+ (should (eq 'QUIT (get-text-property (match-beginning 0) 'erc--msg)))))
+
+ (with-current-buffer "foonet"
+ (erc-cmd-QUIT ""))))
+
+;;; erc-scenarios-display-message.el ends here
diff --git a/test/lisp/erc/erc-scenarios-internal.el b/test/lisp/erc/erc-scenarios-internal.el
index 79d6a02ac64..6911bcc9aac 100644
--- a/test/lisp/erc/erc-scenarios-internal.el
+++ b/test/lisp/erc/erc-scenarios-internal.el
@@ -24,8 +24,37 @@
(when (and (getenv "EMACS_TEST_DIRECTORY")
(getenv "EMACS_TEST_JUNIT_REPORT"))
(setq ert-load-file-name (or (macroexp-file-name) buffer-file-name)))
- (let ((load-path (cons (expand-file-name "erc-d" (ert-resource-directory))
- load-path)))
- (load "erc-d-tests" nil 'silent)))
+ (let ((load-path `(,(expand-file-name "erc-d" (ert-resource-directory))
+ ,(ert-resource-directory)
+ ,@load-path)))
+ ;; Run all tests in ./resources/erc-d/erc-d-tests.el.
+ (load "erc-d-tests" nil 'silent)
+ (require 'erc-tests-common)))
+
+;; Run all tests tagged `:erc--graphical' in an "interactive"
+;; subprocess. Time out after 90 seconds.
+(ert-deftest erc-scenarios-internal--run-graphical-all ()
+ :tags '(:expensive-test :unstable)
+ (unless (and (getenv "ERC_TESTS_GRAPHICAL_ALL")
+ (not (getenv "ERC_TESTS_GRAPHICAL"))
+ (not (getenv "CI")))
+ (ert-skip "Environmental conditions unmet"))
+
+ (let* ((default-directory (expand-file-name "../" (ert-resource-directory)))
+ (libs (directory-files default-directory 'full (rx ".el" eot)))
+ (process-environment (cons "ERC_TESTS_GRAPHICAL=1"
+ process-environment))
+ (program '(progn (ert (quote (tag :erc--graphical)))
+ (with-current-buffer ert--output-buffer-name
+ (kill-emacs (ert--stats-failed-unexpected
+ ert--results-stats)))))
+ (proc (erc-tests-common-create-subprocess program
+ '( "-L" "." "-l" "ert")
+ libs)))
+
+ (erc-d-t-wait-for 90 "interactive tests to complete"
+ (not (process-live-p proc)))
+
+ (should (zerop (process-exit-status proc)))))
;;; erc-scenarios-internal.el ends here
diff --git a/test/lisp/erc/erc-scenarios-join-display-context.el b/test/lisp/erc/erc-scenarios-join-display-context.el
new file mode 100644
index 00000000000..84297de7acd
--- /dev/null
+++ b/test/lisp/erc/erc-scenarios-join-display-context.el
@@ -0,0 +1,66 @@
+;;; erc-scenarios-join-display-context.el --- buffer-display autojoin ctx -*- lexical-binding: t -*-
+
+;; Copyright (C) 2023-2024 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 <https://www.gnu.org/licenses/>.
+
+;;; Commentary:
+
+;;; Code:
+
+(require 'ert-x)
+(eval-and-compile
+ (let ((load-path (cons (ert-resource-directory) load-path)))
+ (require 'erc-scenarios-common)))
+
+(ert-deftest erc-scenarios-join-display-context--errors ()
+ :tags '(:expensive-test)
+ (erc-scenarios-common-with-cleanup
+ ((erc-scenarios-common-dialog "join/buffer-display")
+ (erc-server-flood-penalty 0.1)
+ (dumb-server (erc-d-run "localhost" t 'mode-context))
+ (port (process-contact dumb-server :service))
+ (erc-buffer-display (lambda (buf action)
+ (when (equal
+ (alist-get 'erc-autojoin-mode action)
+ "#chan")
+ (pop-to-buffer buf))))
+ (erc-autojoin-channels-alist '((foonet "#chan" "#spam" "#foo")))
+ (expect (erc-d-t-make-expecter)))
+
+ (ert-info ("Connect without password")
+ (with-current-buffer (erc :server "127.0.0.1"
+ :port port
+ :nick "tester"
+ :full-name "tester")
+ (should (string= (buffer-name) (format "127.0.0.1:%d" port)))
+ ;; FIXME test for effect rather than inspecting interval variables.
+ (erc-d-t-wait-for 10 (equal erc-join--requested-channels
+ '("#foo" "#spam" "#chan")))
+ (funcall expect 10 "Max occupancy for channel #spam exceeded")
+ (funcall expect 10 "Channel #foo is invitation only")))
+
+ (ert-info ("New #chan buffer displayed in new window")
+ (with-current-buffer (erc-d-t-wait-for 10 (get-buffer "#chan"))
+ (should (eq (window-buffer) (current-buffer)))
+ (funcall expect 10 "#chan was created on")))
+
+ ;; FIXME find a less dishonest way to do this than inspecting
+ ;; interval variables.
+ (ert-info ("Ensure channels no longer tracked")
+ (should-not erc-join--requested-channels))))
+
+;;; erc-scenarios-join-display-context.el ends here
diff --git a/test/lisp/erc/erc-scenarios-keep-place-indicator.el b/test/lisp/erc/erc-scenarios-keep-place-indicator.el
new file mode 100644
index 00000000000..ccd6f81b7d2
--- /dev/null
+++ b/test/lisp/erc/erc-scenarios-keep-place-indicator.el
@@ -0,0 +1,141 @@
+;;; erc-scenarios-keep-place-indicator.el --- erc-keep-place-indicator-mode -*- lexical-binding: t -*-
+
+;; Copyright (C) 2023-2024 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 <https://www.gnu.org/licenses/>.
+
+;;; Code:
+
+(require 'ert-x)
+(eval-and-compile
+ (let ((load-path (cons (ert-resource-directory) load-path)))
+ (require 'erc-scenarios-common)))
+
+(require 'erc-goodies)
+
+;; This test shows that the indicator does not update when at least
+;; one window remains. When the last window showing a buffer switches
+;; away, the indicator is updated if it's earlier in the buffer.
+(ert-deftest erc-scenarios-keep-place-indicator--follow ()
+ :tags `(:expensive-test
+ ,@(and (getenv "ERC_TESTS_GRAPHICAL") '(:erc--graphical)))
+ (when (version< emacs-version "29") (ert-skip "Times out"))
+ ;; XXX verify that this continues to be the case ^.
+
+ (should-not erc-scrolltobottom-all)
+ (should-not erc-scrolltobottom-mode)
+ (should-not erc-keep-place-mode)
+
+ (erc-scenarios-common-with-noninteractive-in-term
+ ((erc-scenarios-common-dialog "keep-place")
+ (dumb-server (erc-d-run "localhost" t 'follow))
+ (port (process-contact dumb-server :service))
+ (erc-modules `( keep-place-indicator scrolltobottom fill-wrap
+ ,@erc-modules))
+ (erc-keep-place-indicator-follow t)
+ (erc-scrolltobottom-all t)
+ (erc-server-flood-penalty 0.1)
+ (erc-autojoin-channels-alist '((foonet "#chan" "#spam")))
+ (expect (erc-d-t-make-expecter)))
+
+ (ert-info ("Connect")
+ (with-current-buffer (erc :server "127.0.0.1"
+ :port port
+ :full-name "tester"
+ :nick "tester"
+ :user "tester")
+ (funcall expect 10 "debug mode")))
+
+ (with-current-buffer (erc-d-t-wait-for 10 (get-buffer "#chan"))
+ (set-window-buffer nil (current-buffer))
+ (delete-other-windows)
+ (split-window-below)
+ (funcall expect 10 "<bob> tester, welcome!")
+ (recenter 0)
+ (other-window 1)
+ (funcall expect 10 "<alice> tester, welcome!")
+ (recenter 0)
+ (should (= 2 (length (window-list))))
+
+ (ert-info ("Last window to switch away has point earlier in buffer")
+ ;; Lower window, with point later in buffer, switches away first.
+ (switch-to-buffer (erc-d-t-wait-for 10 (get-buffer "#spam"))) ; lower
+ (other-window 1)
+ (switch-to-buffer "#spam") ; upper
+ (erc-scenarios-common-say "one")
+ (funcall expect 10 "Ay, the heads")
+
+ ;; Overlay has moved to upper window start.
+ (switch-to-buffer "#chan")
+ (redisplay) ; force overlay to update
+ (save-excursion
+ (goto-char (window-point))
+ (should (looking-back (rx "<bob> tester, welcome!")))
+ (should (= (pos-bol) (window-start)))
+ (erc-d-t-wait-for 20
+ (= (overlay-start erc--keep-place-indicator-overlay) (pos-bol))))
+ ;; Lower window is still centered at start.
+ (other-window 1)
+ (switch-to-buffer "#chan")
+ (save-excursion
+ (goto-char (window-point))
+ (should (looking-back (rx "<alice> tester, welcome!")))
+ (should (= (pos-bol) (window-start)))))
+
+ (ert-info ("Last window to switch away has point later in buffer")
+ ;; Lower window advances.
+ (funcall expect 10 "<bob> alice: Since you can cog")
+ (recenter 0)
+ (redisplay) ; force ^ to appear on first line
+
+ (other-window 1) ; upper still at indicator, switches first
+ (switch-to-buffer "#spam")
+ (other-window 1)
+ (switch-to-buffer "#spam") ; lower follows, speaks to sync
+ (erc-scenarios-common-say "two")
+ (funcall expect 10 "<bob> Cause they take")
+ (goto-char (point-max))
+
+ ;; Upper switches back first, finds indicator gone.
+ (other-window 1)
+ (switch-to-buffer "#chan")
+ (save-excursion
+ (goto-char (window-point))
+ (should (looking-back (rx "<bob> tester, welcome!")))
+ (should (= (pos-bol) (window-start)))
+ (should (> (overlay-start erc--keep-place-indicator-overlay)
+ (pos-eol))))
+
+ ;; Lower window follows, window-start preserved.
+ (other-window 1)
+ (switch-to-buffer "#chan")
+ (save-excursion
+ (goto-char (window-point))
+ (should (looking-back (rx "you can cog")))
+ (should (= (pos-bol) (window-start)))
+ (should (= (overlay-start erc--keep-place-indicator-overlay)
+ (pos-bol)))))
+
+ (ert-info ("description")
+ (erc-send-input-line "#spam" "three")
+ (save-excursion (erc-d-t-search-for 10 "Ready"))
+ (switch-to-buffer "#spam")
+ (should (< (point) erc-input-marker))))
+
+ (erc-keep-place-mode -1)
+ (erc-scrolltobottom-mode -1)))
+
+;;; erc-scenarios-keep-place-indicator.el ends here
diff --git a/test/lisp/erc/erc-scenarios-log.el b/test/lisp/erc/erc-scenarios-log.el
new file mode 100644
index 00000000000..3c738822f96
--- /dev/null
+++ b/test/lisp/erc/erc-scenarios-log.el
@@ -0,0 +1,264 @@
+;;; erc-scenarios-log.el --- erc-log scenarios -*- lexical-binding: t -*-
+
+;; Copyright (C) 2023-2024 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 <https://www.gnu.org/licenses/>.
+
+;;; Commentary:
+
+;;; Code:
+
+(require 'ert-x)
+(eval-and-compile
+ (let ((load-path (cons (ert-resource-directory) load-path)))
+ (require 'erc-scenarios-common)))
+
+(require 'erc-log)
+(require 'erc-truncate)
+
+(defvar erc-timestamp-format-left)
+
+(ert-deftest erc-scenarios-log--kill-hook ()
+ :tags '(:expensive-test)
+ (erc-scenarios-common-with-cleanup
+ ((erc-scenarios-common-dialog "base/assoc/bouncer-history")
+ (dumb-server (erc-d-run "localhost" t 'foonet))
+ (tempdir (make-temp-file "erc-tests-log." t nil nil))
+ (erc-log-channels-directory tempdir)
+ (erc-modules (cons 'log erc-modules))
+ (port (process-contact dumb-server :service))
+ (logfile (expand-file-name (format "#chan!tester@127.0.0.1:%d.txt" port)
+ tempdir))
+ (erc-server-flood-penalty 0.1)
+ (expect (erc-d-t-make-expecter)))
+
+ (ert-info ("Connect to foonet")
+ (with-current-buffer (erc :server "127.0.0.1"
+ :port port
+ :nick "tester"
+ :password "foonet:changeme"
+ :full-name "tester")
+ (should (string= (buffer-name) (format "127.0.0.1:%d" port)))
+ (funcall expect 5 "foonet")))
+
+ (with-current-buffer (erc-d-t-wait-for 5 (get-buffer "#chan"))
+ (funcall expect 10 "was created on")
+ (funcall expect 10 "please your lordship")
+ (with-current-buffer "foonet"
+ (delete-process erc-server-process)
+ (funcall expect 5 "failed"))
+ (should-not (file-exists-p logfile))
+ (kill-buffer)
+ (should (file-exists-p logfile)))
+
+ (with-temp-buffer
+ (insert-file-contents logfile)
+ (funcall expect 1 "You have joined")
+ (funcall expect 1 "Playback Complete.")
+ (funcall expect 1 "please your lordship"))
+
+ (erc-log-mode -1)
+ (if noninteractive
+ (delete-directory tempdir :recursive)
+ (add-hook 'kill-emacs-hook
+ (lambda () (delete-directory tempdir :recursive))))))
+
+;; This shows that, in addition to truncating the buffer, /clear also
+;; syncs the log.
+
+(ert-deftest erc-scenarios-log--clear-stamp ()
+ :tags '(:expensive-test)
+ (require 'erc-stamp)
+ (erc-scenarios-common-with-cleanup
+ ((erc-scenarios-common-dialog "base/assoc/bouncer-history")
+ (dumb-server (erc-d-run "localhost" t 'foonet))
+ (tempdir (make-temp-file "erc-tests-log." t nil nil))
+ (erc-log-channels-directory tempdir)
+ (erc-modules (cons 'log erc-modules))
+ (erc-timestamp-format-left "\n[%a %b %e %Y @@STAMP@@]\n")
+ (port (process-contact dumb-server :service))
+ (logfile (expand-file-name (format "#chan!tester@127.0.0.1:%d.txt" port)
+ tempdir))
+ (erc-server-flood-penalty 0.1)
+ (expect (erc-d-t-make-expecter)))
+
+ (unless noninteractive
+ (add-hook 'kill-emacs-hook
+ (lambda () (delete-directory tempdir :recursive))))
+
+ (ert-info ("Connect to foonet")
+ (with-current-buffer (erc :server "127.0.0.1"
+ :port port
+ :nick "tester"
+ :password "foonet:changeme"
+ :full-name "tester")
+ (should (string= (buffer-name) (format "127.0.0.1:%d" port)))
+ (funcall expect 5 "foonet")))
+
+ (with-current-buffer (erc-d-t-wait-for 5 (get-buffer "#chan"))
+ (funcall expect 10 "@@STAMP@@")
+ (funcall expect 10 "Grows, lives")
+ (should-not (file-exists-p logfile))
+ (goto-char (point-max))
+ (erc-cmd-CLEAR)
+ (should (file-exists-p logfile))
+ (funcall expect 10 "please your lordship")
+ (ert-info ("Buffer truncated")
+ (goto-char (point-min))
+ (funcall expect 10 "@@STAMP@@" (point)) ; reset
+ (funcall expect -0.1 "Grows, lives")
+ (funcall expect 1 "For these two")))
+
+ (ert-info ("Current contents saved")
+ (with-temp-buffer
+ (insert-file-contents logfile)
+ (funcall expect 1 "@@STAMP@@")
+ (funcall expect 1 "You have joined")
+ (funcall expect 1 "Playback Complete.")
+ (funcall expect 1 "Grows, lives")
+ (funcall expect -0.01 "please your lordship")))
+
+ (ert-info ("Remainder saved, timestamp printed when option non-nil")
+ (with-current-buffer "foonet"
+ (delete-process erc-server-process)
+ (funcall expect 5 "failed"))
+ (kill-buffer "#chan")
+ (with-temp-buffer
+ (insert-file-contents logfile)
+ (funcall expect 1 "@@STAMP@@")
+ (funcall expect 1 "Grows, lives")
+ (funcall expect -0.01 "@@STAMP@@")
+ (forward-line 1) ; no blank, no timestamp
+ (should (looking-at (rx "<bob> alice: For these two hours,")))
+ (funcall expect 1 "please your lordship")))
+
+ (erc-log-mode -1)
+ (when noninteractive (delete-directory tempdir :recursive))))
+
+(ert-deftest erc-scenarios-log--truncate ()
+ :tags '(:expensive-test :unstable)
+ (erc-scenarios-common-with-cleanup
+ ((erc-scenarios-common-dialog "base/assoc/bouncer-history")
+ (dumb-server (erc-d-run "localhost" t 'foonet))
+ (tempdir (make-temp-file "erc-tests-log." t nil nil))
+ (erc-log-channels-directory tempdir)
+ (erc-modules (cons 'truncate (cons 'log erc-modules)))
+ (erc-max-buffer-size 512)
+ (port (process-contact dumb-server :service))
+ (logchan (expand-file-name (format "#chan!tester@127.0.0.1:%d.txt" port)
+ tempdir))
+ (logserv (expand-file-name
+ (format "127.0.0.1:%d!tester@127.0.0.1:%d.txt" port port)
+ tempdir))
+ (erc-server-flood-penalty 0.1)
+ (expect (erc-d-t-make-expecter)))
+
+ (unless noninteractive
+ (add-hook 'kill-emacs-hook
+ (lambda () (delete-directory tempdir :recursive))))
+
+ (ert-info ("Connect to foonet")
+ (with-current-buffer (erc :server "127.0.0.1"
+ :port port
+ :nick "tester"
+ :password "foonet:changeme"
+ :full-name "tester")
+ (should (string= (buffer-name) (format "127.0.0.1:%d" port)))
+ (should-not (file-exists-p logserv))
+ (should-not (file-exists-p logchan))
+ (funcall expect 10 "*** MAXLIST=beI:60")
+ (should (= (pos-bol) (point-min)))
+ (should (file-exists-p logserv))))
+
+ (ert-info ("Log file ahead of truncation point")
+ ;; Log contains lines still present in buffer.
+ (with-temp-buffer
+ (insert-file-contents logserv)
+ (funcall expect 10 "*** MAXLIST=beI:60")))
+
+ (with-current-buffer (erc-d-t-wait-for 5 (get-buffer "#chan"))
+ (funcall expect 10 "please your lordship")
+ (should (file-exists-p logchan))
+ (funcall expect -0.1 "[07:04:37] alice: Here," (point-min)))
+
+ (ert-info ("Log ahead of truncation point")
+ (with-temp-buffer
+ (insert-file-contents logchan)
+ (funcall expect 1 "You have joined")
+ (funcall expect 1 "[07:04:37] alice: Here,")
+ (funcall expect 1 "loathed enemy")
+ (funcall expect -0.1 "please your lordship")))
+
+ (erc-log-mode -1)
+ (erc-truncate-mode -1)
+ (when noninteractive (delete-directory tempdir :recursive))))
+
+(defvar erc-insert-timestamp-function)
+(declare-function erc-insert-timestamp-left "erc-stamp" (string))
+
+(ert-deftest erc-scenarios-log--save-buffer-in-logs/truncate-on-save ()
+ :tags '(:expensive-test)
+ (erc-scenarios-common-with-cleanup
+ ((erc-scenarios-common-dialog "base/assoc/bouncer-history")
+ (dumb-server (erc-d-run "localhost" t 'foonet))
+ (tempdir (make-temp-file "erc-tests-log." t nil nil))
+ (erc-log-channels-directory tempdir)
+ (erc-modules (cons 'log erc-modules))
+ (port (process-contact dumb-server :service))
+ (erc-truncate-buffer-on-save t)
+ (logchan (expand-file-name (format "#chan!tester@127.0.0.1:%d.txt" port)
+ tempdir))
+ (erc-server-flood-penalty 0.1)
+ (erc-insert-timestamp-function #'erc-insert-timestamp-left)
+ (expect (erc-d-t-make-expecter)))
+
+ (unless noninteractive
+ (add-hook 'kill-emacs-hook
+ (lambda () (delete-directory tempdir :recursive))))
+
+ (ert-info ("Connect to foonet")
+ (with-current-buffer (erc :server "127.0.0.1"
+ :port port
+ :nick "tester"
+ :password "foonet:changeme"
+ :full-name "tester")
+ (should (string= (buffer-name) (format "127.0.0.1:%d" port)))))
+
+ (with-current-buffer (erc-d-t-wait-for 5 (get-buffer "#chan"))
+ (funcall expect 10 "<someone> [07:04:10] hi everyone")
+ (should-not (file-exists-p logchan))
+ ;; Simulate an M-x erc-save-buffer-in-logs RET
+ (cl-letf (((symbol-function 'called-interactively-p) #'always))
+ (call-interactively #'erc-save-buffer-in-logs))
+ (should (file-exists-p logchan))
+ (funcall expect 10 "<alice> bob: As't please your lordship")
+ (erc-save-buffer-in-logs)
+ ;; Not truncated when called by lisp code.
+ (should (> (buffer-size) 400)))
+
+ (ert-info ("No double entries")
+ (with-temp-buffer
+ (insert-file-contents logchan)
+ (funcall expect 0.1 "hi everyone")
+ (funcall expect -0.1 "hi everyone")
+ (funcall expect 0.1 "Playback Complete")
+ (funcall expect -0.1 "Playback Complete")
+ (funcall expect 10 "<alice> bob: As't")))
+
+ (erc-log-mode -1)
+ (when noninteractive (delete-directory tempdir :recursive))))
+
+;;; erc-scenarios-log.el ends here
diff --git a/test/lisp/erc/erc-scenarios-match.el b/test/lisp/erc/erc-scenarios-match.el
new file mode 100644
index 00000000000..22e34a8efe8
--- /dev/null
+++ b/test/lisp/erc/erc-scenarios-match.el
@@ -0,0 +1,555 @@
+;;; erc-scenarios-match.el --- Misc `erc-match' scenarios -*- lexical-binding: t -*-
+
+;; Copyright (C) 2023-2024 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 <https://www.gnu.org/licenses/>.
+
+;;; Code:
+
+(require 'ert-x)
+(eval-and-compile
+ (let ((load-path (cons (ert-resource-directory) load-path)))
+ (require 'erc-scenarios-common)))
+
+(eval-when-compile
+ (require 'erc-join)
+ (require 'erc-match))
+
+(require 'erc-stamp)
+(require 'erc-fill)
+
+;; This defends against a regression in which all matching by the
+;; `erc-match-message' fails when `erc-add-timestamp' precedes it in
+;; `erc-insert-modify-hook'. Basically, `erc-match-message' used to
+;; expect an `erc-parsed' text property on the first character in a
+;; message, which doesn't exist, when the message content is prefixed
+;; by a leading timestamp.
+
+(ert-deftest erc-scenarios-match--stamp-left-current-nick ()
+ :tags '(:expensive-test)
+ (erc-scenarios-common-with-cleanup
+ ((erc-scenarios-common-dialog "base/reconnect")
+ (dumb-server (erc-d-run "localhost" t 'unexpected-disconnect))
+ (port (process-contact dumb-server :service))
+ (erc-server-flood-penalty 0.1)
+ (erc-insert-timestamp-function 'erc-insert-timestamp-left)
+ (expect (erc-d-t-make-expecter)))
+
+ (ert-info ("Connect")
+ (with-current-buffer (erc :server "127.0.0.1"
+ :port port
+ :full-name "tester"
+ :nick "tester")
+ ;; Module `timestamp' follows `match' in insertion hooks.
+ (should (memq 'erc-add-timestamp
+ (memq 'erc-match-message
+ (default-value 'erc-insert-modify-hook))))
+ ;; The "match type" is `current-nick'.
+ (funcall expect 5 "tester")
+ (should (eq (get-text-property (1- (point)) 'font-lock-face)
+ 'erc-current-nick-face))))))
+
+;; When hacking on tests that use this fixture, it's best to run it
+;; interactively, and visually inspect the output with various
+;; combinations of:
+;;
+;; M-x erc-match-toggle-hidden-fools RET
+;; M-x erc-toggle-timestamps RET
+;;
+(defun erc-scenarios-match--invisible-stamp (hiddenp visiblep)
+ (unless noninteractive
+ (kill-new "erc-match-toggle-hidden-fools"))
+
+ (erc-scenarios-common-with-cleanup
+ ((erc-scenarios-common-dialog "join/legacy")
+ (dumb-server (erc-d-run "localhost" t 'foonet))
+ (port (process-contact dumb-server :service))
+ (erc-server-flood-penalty 0.1)
+ (erc-timestamp-only-if-changed-flag nil)
+ (erc-fools '("bob"))
+ (erc-text-matched-hook '(erc-hide-fools))
+ (erc-autojoin-channels-alist '((FooNet "#chan")))
+ (expect (erc-d-t-make-expecter)))
+
+ (ert-info ("Connect")
+ (with-current-buffer (erc :server "127.0.0.1"
+ :port port
+ :full-name "tester"
+ :password "changeme"
+ :nick "tester")
+ ;; Module `timestamp' follows `match' in insertion hooks.
+ (should (memq 'erc-add-timestamp
+ (memq 'erc-match-message
+ (default-value 'erc-insert-modify-hook))))
+ (funcall expect 5 "This server is in debug mode")))
+
+ (ert-info ("Ensure lines featuring \"bob\" are invisible")
+ (with-current-buffer (erc-d-t-wait-for 10 (get-buffer "#chan"))
+ (should (funcall expect 10 "<bob> tester, welcome!"))
+ (ert-info ("<bob> tester, welcome!") (funcall hiddenp))
+
+ ;; Alice's is the only one visible.
+ (should (funcall expect 10 "<alice> tester, welcome!"))
+ (ert-info ("<alice> tester, welcome!") (funcall visiblep))
+
+ (should (funcall expect 10 "<bob> alice: But, as it seems"))
+ (ert-info ("<bob> alice: But, as it seems") (funcall hiddenp))
+
+ (should (funcall expect 10 "<alice> bob: Well, this is the forest"))
+ (ert-info ("<alice> bob: Well, this is the forest") (funcall hiddenp))
+
+ (should (funcall expect 10 "<alice> bob: And will you"))
+ (ert-info ("<alice> bob: And will you") (funcall hiddenp))
+
+ (should (funcall expect 10 "<bob> alice: Live, and be prosperous"))
+ (ert-info ("<bob> alice: Live, and be prosperous") (funcall hiddenp))
+
+ (should (funcall expect 10 "ERC>"))
+ (should-not (get-text-property (pos-bol) 'invisible))
+ (should-not (get-text-property (point) 'invisible))))))
+
+;; This asserts that when stamps appear before a message, registered
+;; invisibility properties owned by modules span the entire message.
+(ert-deftest erc-scenarios-match--stamp-left-fools-invisible ()
+ :tags '(:expensive-test)
+ (let ((erc-insert-timestamp-function #'erc-insert-timestamp-left))
+ (erc-scenarios-match--invisible-stamp
+
+ (lambda ()
+ ;; This is a time-stamped message.
+ (should (eq (field-at-pos (pos-bol)) 'erc-timestamp))
+
+ ;; Leading stamp has combined `invisible' property value.
+ (should (equal (get-text-property (pos-bol) 'invisible)
+ '(match-fools timestamp)))
+
+ ;; Message proper has the `invisible' property `match-fools'.
+ (let ((msg-beg (next-single-property-change (pos-bol) 'invisible)))
+ (should (eq (get-text-property msg-beg 'invisible) 'match-fools))
+ (should (>= (next-single-property-change msg-beg 'invisible nil)
+ (pos-eol)))))
+
+ (lambda ()
+ ;; This is a time-stamped message.
+ (should (eq (field-at-pos (pos-bol)) 'erc-timestamp))
+ (should (get-text-property (pos-bol) 'invisible))
+
+ ;; The entire message proper is visible.
+ (let ((msg-beg (next-single-property-change (pos-bol) 'invisible)))
+ (should
+ (= (next-single-property-change msg-beg 'invisible nil (pos-eol))
+ (pos-eol))))))))
+
+;; In most cases, `erc-hide-fools' makes line endings invisible.
+(defun erc-scenarios-match--stamp-right-fools-invisible ()
+ (let ((erc-insert-timestamp-function #'erc-insert-timestamp-right))
+ (erc-scenarios-match--invisible-stamp
+
+ (lambda ()
+ (pcase-let ((`(,beg . ,end) (erc--get-inserted-msg-bounds)))
+ ;; The end of the message is a newline.
+ (should (= ?\n (char-after end)))
+
+ ;; Every message has a trailing time stamp.
+ (should (eq (field-at-pos (1- end)) 'erc-timestamp))
+
+ ;; Stamps have a combined `invisible' property value.
+ (should (equal (get-text-property (1- end) 'invisible)
+ '(match-fools timestamp)))
+
+ ;; The final newline is hidden by `match', not `stamps'
+ (with-suppressed-warnings ((obsolete erc-legacy-invisible-bounds-p))
+ (if erc-legacy-invisible-bounds-p
+ (should (eq (get-text-property end 'invisible) 'match-fools))
+ (should (eq (get-text-property beg 'invisible) 'match-fools))
+ (should-not (get-text-property end 'invisible))))
+
+ ;; The message proper has the `invisible' property `match-fools',
+ ;; and it starts after the preceding newline.
+ (should (eq (get-text-property (pos-bol) 'invisible) 'match-fools))
+
+ ;; It ends just before the timestamp.
+ (let ((msg-end (next-single-property-change (pos-bol) 'invisible)))
+ (should (equal (get-text-property msg-end 'invisible)
+ '(match-fools timestamp)))
+
+ ;; Stamp's `invisible' property extends throughout the stamp
+ ;; and ends before the trailing newline.
+ (should (= (next-single-property-change msg-end 'invisible) end)))))
+
+ (lambda ()
+ (let ((end (erc--get-inserted-msg-end (point))))
+ ;; This message has a time stamp like all the others.
+ (should (eq (field-at-pos (1- end)) 'erc-timestamp))
+
+ ;; The entire message proper is visible.
+ (should-not (get-text-property (pos-bol) 'invisible))
+ (let ((inv-beg (next-single-property-change (pos-bol) 'invisible)))
+ (should (eq (get-text-property inv-beg 'invisible)
+ 'timestamp))))))))
+
+(ert-deftest erc-scenarios-match--stamp-right-fools-invisible ()
+ :tags '(:expensive-test)
+ (erc-scenarios-match--stamp-right-fools-invisible))
+
+(ert-deftest erc-scenarios-match--stamp-right-fools-invisible--nooffset ()
+ :tags '(:expensive-test)
+ (with-suppressed-warnings ((obsolete erc-legacy-invisible-bounds-p))
+ (should-not erc-legacy-invisible-bounds-p)
+ (let ((erc-legacy-invisible-bounds-p t))
+ (erc-scenarios-match--stamp-right-fools-invisible))))
+
+;; This asserts that when `erc-fill-wrap-mode' is enabled, ERC hides
+;; the preceding message's line ending.
+(ert-deftest erc-scenarios-match--stamp-right-invisible-fill-wrap ()
+ :tags '(:expensive-test)
+ (let ((erc-insert-timestamp-function #'erc-insert-timestamp-right)
+ (erc-fill-function #'erc-fill-wrap))
+ (erc-scenarios-match--invisible-stamp
+
+ (lambda ()
+ ;; Every message has a trailing time stamp.
+ (should (eq (field-at-pos (1- (pos-eol))) 'erc-timestamp))
+
+ ;; Stamps appear in the right margin.
+ (should (equal (car (get-text-property (1- (pos-eol)) 'display))
+ '(margin right-margin)))
+
+ ;; Stamps have a combined `invisible' property value.
+ (should (equal (get-text-property (1- (pos-eol)) 'invisible)
+ '(match-fools timestamp)))
+
+ ;; The message proper has the `invisible' property `match-fools',
+ ;; which starts at the preceding newline...
+ (should (eq (get-text-property (1- (pos-bol)) 'invisible) 'match-fools))
+
+ ;; ... and ends just before the timestamp.
+ (let ((msgend (next-single-property-change (1- (pos-bol)) 'invisible)))
+ (should (equal (get-text-property msgend 'invisible)
+ '(match-fools timestamp)))
+
+ ;; The newline before `erc-insert-marker' is still visible.
+ (should-not (get-text-property (pos-eol) 'invisible))
+ (should (= (next-single-property-change msgend 'invisible)
+ (pos-eol)))))
+
+ (lambda ()
+ ;; This message has a time stamp like all the others.
+ (should (eq (field-at-pos (1- (pos-eol))) 'erc-timestamp))
+
+ ;; Unlike hidden messages, the preceding newline is visible.
+ (should-not (get-text-property (1- (pos-bol)) 'invisible))
+
+ ;; The entire message proper is visible.
+ (let ((inv-beg (next-single-property-change (1- (pos-bol)) 'invisible)))
+ (should (eq (get-text-property inv-beg 'invisible) 'timestamp)))))))
+
+(defun erc-scenarios-match--fill-wrap-stamp-dedented-p (point)
+ (pcase (get-text-property point 'line-prefix)
+ (`(space :width (- erc-fill--wrap-value (,n)))
+ (if (display-graphic-p) (< 100 n 200) (< 10 n 30)))
+ (`(space :width (- erc-fill--wrap-value ,n))
+ (< 10 n 30))))
+
+(ert-deftest erc-scenarios-match--hide-fools/stamp-both/fill-wrap ()
+
+ ;; Rewind the clock to known date artificially. We should probably
+ ;; use a ticks/hz cons on 29+.
+ (let ((erc-stamp--current-time 704591940)
+ (erc-stamp--tz t)
+ (erc-fill-function #'erc-fill-wrap)
+ (bob-utterance-counter 0))
+
+ (erc-scenarios-match--invisible-stamp
+
+ (lambda ()
+ (ert-info ("Baseline check")
+ ;; False date printed initially before anyone speaks.
+ (when (zerop bob-utterance-counter)
+ (save-excursion
+ (goto-char (point-min))
+ (search-forward "[Wed Apr 29 1992]")
+ ;; First stamp in a buffer is not invisible from previous
+ ;; newline (before stamp's own leading newline).
+ (should (= 4 (match-beginning 0)))
+ (should (get-text-property 3 'invisible))
+ (should-not (get-text-property 2 'invisible))
+ (should (erc-scenarios-match--fill-wrap-stamp-dedented-p 4))
+ (search-forward "[23:59]"))))
+
+ (ert-info ("Line endings in Bob's messages are invisible")
+ ;; The message proper has the `invisible' property `match-fools'.
+ (should (eq (get-text-property (pos-bol) 'invisible) 'match-fools))
+ (pcase-let ((`(,mbeg . ,mend) (erc--get-inserted-msg-bounds)))
+ (should (= (char-after mend) ?\n))
+ (should-not (field-at-pos mend))
+ (should-not (field-at-pos mbeg))
+
+ (when (= bob-utterance-counter 1)
+ (let ((right-stamp (field-end mbeg)))
+ (should (eq 'erc-timestamp (field-at-pos right-stamp)))
+ (should (= mend (field-end right-stamp)))
+ (should (eq (field-at-pos (1- mend)) 'erc-timestamp))))
+
+ ;; The `erc--ts' property is present in prop stack.
+ (should (get-text-property (pos-bol) 'erc--ts))
+ (should-not (next-single-property-change (1+ (pos-bol)) 'erc--ts))
+
+ ;; Line ending has the `invisible' property `match-fools'.
+ (should (eq (get-text-property mbeg 'invisible) 'match-fools))
+ (should-not (get-text-property mend 'invisible))))
+
+ ;; Only the message right after Alice speaks contains stamps.
+ (when (= 1 bob-utterance-counter)
+
+ (ert-info ("Date stamp occupying previous line is invisible")
+ (should (eq 'match-fools (get-text-property (point) 'invisible)))
+ (save-excursion
+ (forward-line -1)
+ (goto-char (pos-bol))
+ (should (looking-at (rx "[Mon May 4 1992]")))
+ (ert-info ("Stamp's NL `invisible' as fool, not timestamp")
+ (let ((end (match-end 0)))
+ (should (eq (char-after end) ?\n))
+ (should (eq 'timestamp
+ (get-text-property (1- end) 'invisible)))
+ (should (eq 'match-fools
+ (get-text-property end 'invisible)))))
+ (should (erc-scenarios-match--fill-wrap-stamp-dedented-p (point)))
+ ;; Date stamp has a combined `invisible' property value
+ ;; that starts at the previous message's trailing newline
+ ;; and extends until the start of the message proper.
+ (should (equal ?\n (char-before (point))))
+ (should (equal ?\n (char-before (1- (point)))))
+ (let ((val (get-text-property (- (point) 2) 'invisible)))
+ (should (equal val 'timestamp))
+ (should (= (text-property-not-all (- (point) 2) (point-max)
+ 'invisible val)
+ (pos-eol))))))
+
+ (ert-info ("Current message's RHS stamp is hidden")
+ ;; Right stamp has `match-fools' property.
+ (save-excursion
+ (should-not (field-at-pos (point)))
+ (should (eq (field-at-pos (1- (pos-eol))) 'erc-timestamp)))
+
+ ;; Stamp invisibility starts where message's ends.
+ (let ((msgend (next-single-property-change (pos-bol) 'invisible)))
+ ;; Stamp has a combined `invisible' property value.
+ (should (equal (get-text-property msgend 'invisible)
+ '(match-fools timestamp)))
+
+ ;; Combined `invisible' property spans entire timestamp.
+ (should (= (next-single-property-change msgend 'invisible)
+ (pos-eol))))))
+
+ (cl-incf bob-utterance-counter))
+
+ ;; Alice.
+ (lambda ()
+ ;; Set clock ahead a week or so.
+ (setq erc-stamp--current-time 704962800)
+
+ ;; This message has no time stamp and is completely visible.
+ (should-not (eq (field-at-pos (1- (pos-eol))) 'erc-timestamp))
+ (should-not (next-single-property-change (pos-bol) 'invisible))))))
+
+;; This asserts that speaker hiding by `erc-fill-wrap-merge' doesn't
+;; take place after a series of hidden fool messages with an
+;; intervening outgoing message followed immediately by a non-fool
+;; message from the last non-hidden speaker (other than the user).
+(ert-deftest erc-scenarios-match--hide-fools/stamp-both/fill-wrap/speak ()
+
+ (erc-scenarios-common-with-cleanup
+ ((erc-scenarios-common-dialog "match/fools")
+ (erc-stamp--current-time 704591940)
+ (dumb-server (erc-d-run "localhost" t 'fill-wrap))
+ (erc-stamp--tz t)
+ (erc-fill-function #'erc-fill-wrap)
+ (port (process-contact dumb-server :service))
+ (erc-server-flood-penalty 0.1)
+ (erc-timestamp-only-if-changed-flag nil)
+ (erc-fools '("bob"))
+ (erc-text-matched-hook '(erc-hide-fools))
+ (erc-autojoin-channels-alist '((FooNet "#chan")))
+ (expect (erc-d-t-make-expecter)))
+
+ (ert-info ("Connect")
+ (with-current-buffer (erc :server "127.0.0.1"
+ :port port
+ :full-name "tester"
+ :password "changeme"
+ :nick "tester")
+ ;; Module `timestamp' follows `match' in insertion hooks.
+ (should (memq 'erc-add-timestamp
+ (memq 'erc-match-message
+ (default-value 'erc-insert-modify-hook))))
+ (funcall expect 5 "This server is in debug mode")))
+
+ (ert-info ("Ensure lines featuring \"bob\" are invisible")
+ (with-current-buffer (erc-d-t-wait-for 10 (get-buffer "#chan"))
+ (should (funcall expect 10 "<alice> None better than"))
+ (should (funcall expect 10 "<alice> bob: Still we went"))
+ (should (funcall expect 10 "<bob> alice: Give me your hand"))
+ (erc-scenarios-common-say "hey")
+ (should (funcall expect 10 "<bob> You have paid the heavens"))
+ (should (funcall expect 10 "<alice> bob: In the sick air"))
+ (should (funcall expect 10 "<alice> The web of our life"))
+
+ ;; Regression (see leading comment).
+ (should-not (equal "" (get-text-property (pos-bol) 'display)))
+
+ ;; No remaining meta-data positions, no more timestamps.
+ (should-not (next-single-property-change (1+ (pos-bol)) 'erc--ts))
+ ;; No remaining invisible messages.
+ (should-not (text-property-not-all (pos-bol) erc-insert-marker
+ 'invisible nil))
+
+ (should (funcall expect 10 "ERC>"))
+ (should-not (get-text-property (pos-bol) 'invisible))
+ (should-not (get-text-property (point) 'invisible))))))
+
+(defun erc-scenarios-match--stamp-both-invisible-fill-static (assert-ds)
+ (should (eq erc-insert-timestamp-function
+ #'erc-insert-timestamp-left-and-right))
+
+ ;; Rewind the clock to known date artificially.
+ (let ((erc-stamp--current-time 704591940)
+ (erc-stamp--tz t)
+ (erc-fill-function #'erc-fill-static)
+ (bob-utterance-counter 0))
+
+ (erc-scenarios-match--invisible-stamp
+
+ (lambda ()
+ (ert-info ("Baseline check")
+ ;; False date printed initially before anyone speaks.
+ (when (zerop bob-utterance-counter)
+ (save-excursion
+ (goto-char (point-min))
+ (search-forward "[Wed Apr 29 1992]")
+ (search-forward "[23:59]"))))
+
+ (ert-info ("Line endings in Bob's messages are invisible")
+ ;; The message proper has the `invisible' property `match-fools'.
+ (should (eq (get-text-property (pos-bol) 'invisible) 'match-fools))
+ (pcase-let ((`(,mbeg . ,mend) (erc--get-inserted-msg-bounds)))
+
+ (should (= (char-after mend) ?\n))
+ (should-not (field-at-pos mbeg))
+ (should-not (field-at-pos mend))
+ (when (= 1 bob-utterance-counter)
+ ;; For Bob's stamped message, check newline after stamp.
+ (should (eq (field-at-pos (field-end mbeg)) 'erc-timestamp))
+ (should (eq (field-at-pos (1- mend)) 'erc-timestamp)))
+
+ ;; The `erc--ts' property is present in the message's
+ ;; width 1 prop collection at its first char.
+ (should (get-text-property (pos-bol) 'erc--ts))
+ (should-not (next-single-property-change (1+ (pos-bol)) 'erc--ts))
+
+ ;; Line ending has the `invisible' property `match-fools'.
+ (should (= (char-after mend) ?\n))
+ (with-suppressed-warnings ((obsolete erc-legacy-invisible-bounds-p))
+ (if erc-legacy-invisible-bounds-p
+ (should (eq (get-text-property mend 'invisible) 'match-fools))
+ (should (eq (get-text-property mbeg 'invisible) 'match-fools))
+ (should-not (get-text-property mend 'invisible))))))
+
+ ;; Only the message right after Alice speaks contains stamps.
+ (when (= 1 bob-utterance-counter)
+
+ (ert-info ("Date stamp occupying previous line is invisible")
+ (save-excursion
+ (forward-line -1)
+ (goto-char (pos-bol))
+ (should (looking-at (rx "[Mon May 4 1992]")))
+ (should (= ?\n (char-after (- (point) 2)))) ; welcome!\n
+ (funcall assert-ds))) ; "assert date stamp"
+
+ (ert-info ("Folding preserved despite invisibility")
+ ;; Message has a trailing time stamp, but it's been folded
+ ;; over to the next line.
+ (should-not (eq (field-at-pos (1- (pos-eol))) 'erc-timestamp))
+ (save-excursion
+ (forward-line)
+ (should (eq (field-at-pos (1- (pos-eol))) 'erc-timestamp)))
+
+ ;; Stamp invisibility starts where message's ends.
+ (let ((msgend (next-single-property-change (pos-bol) 'invisible)))
+ ;; Stamp has a combined `invisible' property value.
+ (should (equal (get-text-property msgend 'invisible)
+ '(match-fools timestamp)))
+
+ ;; Combined `invisible' property spans entire timestamp.
+ (should (= (next-single-property-change msgend 'invisible)
+ (save-excursion (forward-line) (pos-eol)))))))
+
+ (cl-incf bob-utterance-counter))
+
+ ;; Alice.
+ (lambda ()
+ ;; Set clock ahead a week or so.
+ (setq erc-stamp--current-time 704962800)
+
+ ;; This message has no time stamp and is completely visible.
+ (should-not (eq (field-at-pos (1- (pos-eol))) 'erc-timestamp))
+ (should-not (next-single-property-change (pos-bol) 'invisible))))))
+
+(ert-deftest erc-scenarios-match--stamp-both-invisible-fill-static ()
+ :tags '(:expensive-test)
+ (erc-scenarios-match--stamp-both-invisible-fill-static
+
+ (lambda ()
+ ;; Date stamp has an `invisible' property that starts from the
+ ;; newline delimiting the current and previous messages and
+ ;; extends until the stamp's final newline. It is not combined
+ ;; with the old value, `match-fools'.
+ (let ((delim-pos (- (point) 2)))
+ (should (equal 'timestamp (get-text-property delim-pos 'invisible)))
+ ;; Stamp-only invisibility ends before its last newline.
+ (should (= (text-property-not-all delim-pos (point-max)
+ 'invisible 'timestamp)
+ (match-end 0))))))) ; pos-eol
+
+(ert-deftest erc-scenarios-match--stamp-both-invisible-fill-static--nooffset ()
+ :tags '(:expensive-test)
+ (with-suppressed-warnings ((obsolete erc-legacy-invisible-bounds-p))
+ (should-not erc-legacy-invisible-bounds-p)
+
+ (let ((erc-legacy-invisible-bounds-p t))
+ (erc-scenarios-match--stamp-both-invisible-fill-static
+
+ (lambda ()
+ ;; Date stamp has an `invisible' property that covers its
+ ;; format string exactly. It is not combined with the old
+ ;; value, `match-fools'.
+ (let ((delim-prev (- (point) 2)))
+ (should-not (get-text-property delim-prev 'invisible))
+ (should (eq 'erc-timestamp (field-at-pos (point))))
+ (should (= (next-single-property-change delim-prev 'invisible)
+ (field-beginning (point))))
+ (should (equal 'timestamp
+ (get-text-property (1- (point)) 'invisible)))
+ ;; Field stops before final newline because the date stamp
+ ;; is (now, as of ERC 5.6) its own standalone message.
+ (should (= ?\n (char-after (field-end (point)))))
+ ;; Stamp-only invisibility includes last newline.
+ (should (= (text-property-not-all (1- (point)) (point-max)
+ 'invisible 'timestamp)
+ (1+ (field-end (point)))))))))))
+
+;;; erc-scenarios-match.el ends here
diff --git a/test/lisp/erc/erc-scenarios-misc-commands.el b/test/lisp/erc/erc-scenarios-misc-commands.el
new file mode 100644
index 00000000000..da6855caf57
--- /dev/null
+++ b/test/lisp/erc/erc-scenarios-misc-commands.el
@@ -0,0 +1,216 @@
+;;; erc-scenarios-misc-commands.el --- Misc commands for ERC -*- lexical-binding: t -*-
+
+;; Copyright (C) 2023-2024 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 <https://www.gnu.org/licenses/>.
+
+;;; Code:
+
+(require 'ert-x)
+(eval-and-compile
+ (let ((load-path (cons (ert-resource-directory) load-path)))
+ (require 'erc-scenarios-common)))
+
+;; This defends against a partial regression in which an /MOTD caused
+;; 376 and 422 handlers in erc-networks to run.
+
+(ert-deftest erc-scenarios-misc-commands--MOTD ()
+ :tags '(:expensive-test)
+ (erc-scenarios-common-with-cleanup
+ ((erc-scenarios-common-dialog "commands")
+ (erc-server-flood-penalty 0.1)
+ (dumb-server (erc-d-run "localhost" t 'motd))
+ (port (process-contact dumb-server :service))
+ (expect (erc-d-t-make-expecter)))
+
+ (ert-info ("Connect to server")
+ (with-current-buffer (erc :server "127.0.0.1"
+ :port port
+ :nick "tester"
+ :full-name "tester")
+ (funcall expect 10 "This is the default Ergo MOTD")
+ (funcall expect 10 "debug mode")))
+
+ (ert-info ("Send plain MOTD")
+ (with-current-buffer "foonet"
+ (erc-cmd-MOTD)
+ (funcall expect -0.2 "Unexpected state detected")
+ (funcall expect 10 "This is the default Ergo MOTD")))
+
+ (ert-info ("Send MOTD with known target")
+ (with-current-buffer "foonet"
+ (erc-scenarios-common-say "/MOTD irc1.foonet.org")
+ (funcall expect -0.2 "Unexpected state detected")
+ (funcall expect 10 "This is the default Ergo MOTD")))
+
+ (ert-info ("Send MOTD with erroneous target")
+ (with-current-buffer "foonet"
+ (erc-scenarios-common-say "/MOTD fake.foonet.org")
+ (funcall expect -0.2 "Unexpected state detected")
+ (funcall expect 10 "No such server")
+ ;; Message may show up before the handler runs.
+ (erc-d-t-wait-for 10
+ (not (local-variable-p 'erc-server-402-functions)))
+ (should-not (local-variable-p 'erc-server-376-functions))
+ (should-not (local-variable-p 'erc-server-422-functions))
+ (erc-cmd-QUIT "")))))
+
+
+(ert-deftest erc-scenarios-misc-commands--SQUERY ()
+ :tags '(:expensive-test)
+ (erc-scenarios-common-with-cleanup
+ ((erc-scenarios-common-dialog "commands")
+ (erc-server-flood-penalty 0.1)
+ (dumb-server (erc-d-run "localhost" t 'squery))
+ (port (process-contact dumb-server :service))
+ (expect (erc-d-t-make-expecter)))
+
+ (ert-info ("Connect to server")
+ (with-current-buffer (erc :server "127.0.0.1"
+ :port port
+ :nick "tester"
+ :full-name "tester")
+ (funcall expect 10 "Your connection is secure")))
+
+ (ert-info ("Send SQUERY")
+ (with-current-buffer "IRCnet"
+ (erc-scenarios-common-say "/SQUERY alis help list")
+ (funcall expect -0.1 "Incorrect arguments")
+ (funcall expect 10 "See also: HELP EXAMPLES")))))
+
+;; Note that as of ERC 5.6, there is no actual slash-command function
+;; named `erc-cmd-vhost'. At the moment, this test merely exists to
+;; assert that the `erc-server-396' response handler updates the rolls
+;; correctly.
+(ert-deftest erc-scenarios-misc-commands--VHOST ()
+ :tags '(:expensive-test)
+ (erc-scenarios-common-with-cleanup
+ ((erc-scenarios-common-dialog "commands")
+ (erc-server-flood-penalty 0.1)
+ (dumb-server (erc-d-run "localhost" t 'vhost))
+ ;; As of ERC 5.6, we must join a channel before ERC adds itself
+ ;; to `erc-server-users'. Without such an entry, there's
+ ;; nothing to update when the 396 arrives.
+ (erc-autojoin-channels-alist '((foonet "#chan")))
+ (port (process-contact dumb-server :service))
+ (expect (erc-d-t-make-expecter)))
+
+ (ert-info ("Connect to server")
+ (with-current-buffer (erc :server "127.0.0.1"
+ :port port
+ :nick "tester"
+ :password "changeme"
+ :full-name "tester")
+ (funcall expect 10 "debug mode")))
+
+ (ert-info ("Send VHOST")
+ (with-current-buffer (erc-d-t-wait-for 10 (get-buffer "#chan"))
+ (erc-scenarios-common-say "/VHOST tester changeme")
+ (funcall expect 10 "visible host")
+ (should (string= (erc-server-user-host (erc-get-server-user "tester"))
+ "some.host.test.cc"))))))
+
+;; This tests four related slash commands, /AMSG, /GMSG, /AME, /GME,
+;; the latter three introduced by bug#68401. It mainly asserts
+;; correct routing behavior, especially not sending or inserting
+;; messages in buffers belonging to disconnected sessions. Left
+;; unaddressed are interactions with the `command-indicator' module
+;; (`erc-noncommands-list') and whatever future `echo-message'
+;; implementation manifests out of bug#49860.
+(ert-deftest erc-scenarios-misc-commands--AMSG-GMSG-AME-GME ()
+ (erc-scenarios-common-with-cleanup
+ ((erc-scenarios-common-dialog "commands")
+ (erc-server-flood-penalty 0.1)
+ (dumb-server-foonet (erc-d-run "localhost" t "srv-foonet" 'amsg-foonet))
+ (dumb-server-barnet (erc-d-run "localhost" t "srv-barnet" 'amsg-barnet))
+ (expect (erc-d-t-make-expecter)))
+
+ (ert-info ("Connect to foonet and join #foo")
+ (with-current-buffer
+ (erc :server "127.0.0.1"
+ :port (process-contact dumb-server-foonet :service)
+ :nick "tester")
+ (funcall expect 10 "debug mode")
+ (erc-cmd-JOIN "#foo")))
+
+ (ert-info ("Connect to barnet and join #bar")
+ (with-current-buffer
+ (erc :server "127.0.0.1"
+ :port (process-contact dumb-server-barnet :service)
+ :nick "tester")
+ (funcall expect 10 "debug mode")
+ (erc-cmd-JOIN "#bar")))
+
+ (with-current-buffer (erc-d-t-wait-for 10 (get-buffer "#foo"))
+ (funcall expect 10 "welcome"))
+ (with-current-buffer (erc-d-t-wait-for 10 (get-buffer "#bar"))
+ (funcall expect 10 "welcome"))
+
+ (ert-info ("/AMSG only sent to issuing context's server")
+ (with-current-buffer "foonet"
+ (erc-scenarios-common-say "/amsg 1 foonet only"))
+ (with-current-buffer "barnet"
+ (erc-scenarios-common-say "/amsg 2 barnet only"))
+ (with-current-buffer "#foo"
+ (funcall expect 10 "<tester> 1 foonet only")
+ (funcall expect 10 "<alice> bob: Our queen and all"))
+ (with-current-buffer "#bar"
+ (funcall expect 10 "<tester> 2 barnet only")
+ (funcall expect 10 "<joe> mike: And secretly to greet")))
+
+ (ert-info ("/AME only sent to issuing context's server")
+ (with-current-buffer "foonet"
+ (erc-scenarios-common-say "/ame 3 foonet only"))
+ (with-current-buffer "barnet"
+ (erc-scenarios-common-say "/ame 4 barnet only"))
+ (with-current-buffer "#foo"
+ (funcall expect 10 "* tester 3 foonet only")
+ (funcall expect 10 "<alice> bob: You have discharged this"))
+ (with-current-buffer "#bar"
+ (funcall expect 10 "* tester 4 barnet only")
+ (funcall expect 10 "<joe> mike: That same Berowne")))
+
+ (ert-info ("/GMSG and /GME sent to all servers")
+ (with-current-buffer "foonet"
+ (erc-scenarios-common-say "/gmsg 5 all nets")
+ (erc-scenarios-common-say "/gme 6 all nets"))
+ (with-current-buffer "#bar"
+ (funcall expect 10 "<tester> 5 all nets")
+ (funcall expect 10 "* tester 6 all nets")
+ (funcall expect 10 "<joe> mike: Mehercle! if their sons")))
+
+ (ert-info ("/GMSG and /GME only sent to connected servers")
+ (with-current-buffer "barnet"
+ (erc-cmd-QUIT "")
+ (funcall expect 10 "ERC finished"))
+ (with-current-buffer "#foo"
+ (funcall expect 10 "<tester> 5 all nets")
+ (funcall expect 10 "* tester 6 all nets")
+ (funcall expect 10 "<alice> bob: Stand you!"))
+ (with-current-buffer "foonet"
+ (erc-scenarios-common-say "/gmsg 7 all live nets")
+ (erc-scenarios-common-say "/gme 8 all live nets"))
+ ;; Message *not* inserted in disconnected buffer.
+ (with-current-buffer "#bar"
+ (funcall expect -0.1 "<tester> 7 all live nets")
+ (funcall expect -0.1 "* tester 8 all live nets")))
+
+ (with-current-buffer "#foo"
+ (funcall expect 10 "<tester> 7 all live nets")
+ (funcall expect 10 "* tester 8 all live nets")
+ (funcall expect 10 "<bob> alice: Live, and be prosperous;"))))
+
+;;; erc-scenarios-misc-commands.el ends here
diff --git a/test/lisp/erc/erc-scenarios-misc.el b/test/lisp/erc/erc-scenarios-misc.el
index eb1ff6a046a..2afa1ce67a4 100644
--- a/test/lisp/erc/erc-scenarios-misc.el
+++ b/test/lisp/erc/erc-scenarios-misc.el
@@ -75,7 +75,7 @@
(ert-info ("All output sent")
(with-current-buffer "#chan/foonet"
- (funcall expect 8 "Some man or other"))
+ (funcall expect 16 "Some man or other"))
(with-current-buffer "#chan/barnet"
(funcall expect 10 "That's he that was Othello")))))
@@ -126,7 +126,7 @@
(erc-d-t-wait-for 10 (get-buffer "foonet"))
(ert-info ("Channel buffer #foo playback received")
- (with-current-buffer (erc-d-t-wait-for 3 (get-buffer "#foo"))
+ (with-current-buffer (erc-d-t-wait-for 10 (get-buffer "#foo"))
(funcall expect 10 "Excellent workman")))
(ert-info ("Global notices routed to server buffer")
@@ -205,4 +205,38 @@
(with-current-buffer (erc-d-t-wait-for 10 (get-buffer "#chan"))
(funcall expect 10 "welcome")))))
+;; Ensure that ERC does not attempt to switch to a killed server
+;; buffer via `erc-track-switch-buffer'.
+
+(declare-function erc-track-switch-buffer "erc-track" (arg))
+(defvar erc-track-mode)
+
+(ert-deftest erc-scenarios-base-kill-server-track ()
+ :tags '(:expensive-test)
+ (erc-scenarios-common-with-cleanup
+ ((erc-scenarios-common-dialog "networks/merge-server")
+ (dumb-server (erc-d-run "localhost" t 'track))
+ (port (process-contact dumb-server :service))
+ (erc-server-flood-penalty 0.1)
+ (expect (erc-d-t-make-expecter)))
+
+ (ert-info ("Connect")
+ (with-current-buffer (erc :server "127.0.0.1"
+ :port port
+ :nick "tester")
+ (should (string= (buffer-name) (format "127.0.0.1:%d" port)))
+ (should erc-track-mode)
+ (funcall expect 5 "changed mode for tester")
+ (erc-cmd-JOIN "#chan")))
+
+ (ert-info ("Join channel and kill server buffer")
+ (with-current-buffer (erc-d-t-wait-for 10 (get-buffer "#chan"))
+ (funcall expect 5 "The hour that fools should ask"))
+ (with-current-buffer "FooNet"
+ (set-process-query-on-exit-flag erc-server-process nil)
+ (kill-buffer))
+ (should-not (eq (current-buffer) (get-buffer "#chan"))) ; *temp*
+ (ert-simulate-command '(erc-track-switch-buffer 1)) ; No longer signals
+ (should (eq (current-buffer) (get-buffer "#chan"))))))
+
;;; erc-scenarios-misc.el ends here
diff --git a/test/lisp/erc/erc-scenarios-prompt-format.el b/test/lisp/erc/erc-scenarios-prompt-format.el
new file mode 100644
index 00000000000..613ad87ccf5
--- /dev/null
+++ b/test/lisp/erc/erc-scenarios-prompt-format.el
@@ -0,0 +1,117 @@
+;;; erc-scenarios-prompt-format.el --- erc-prompt-format-mode -*- lexical-binding: t -*-
+
+;; Copyright (C) 2023-2024 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 <https://www.gnu.org/licenses/>.
+
+;;; Code:
+
+(require 'ert-x)
+(eval-and-compile
+ (let ((load-path (cons (ert-resource-directory) load-path)))
+ (require 'erc-scenarios-common)))
+
+(defvar erc-fill-wrap-align-prompt)
+(defvar erc-fill-wrap-use-pixels)
+
+(defun erc-scenarios-prompt-format--assert (needle &rest props)
+ (save-excursion
+ (goto-char erc-insert-marker)
+ (should (search-forward needle nil t))
+ (pcase-dolist (`(,k . ,v) props)
+ (should (equal (get-text-property (point) k) v)))))
+
+;; This makes assertions about the option `erc-fill-wrap-align-prompt'
+;; as well as the standard value of `erc-prompt-format'. One minor
+;; omission is that this doesn't check behavior in query buffers.
+(ert-deftest erc-scenarios-prompt-format ()
+ :tags '(:expensive-test)
+ (erc-scenarios-common-with-cleanup
+ ((erc-scenarios-common-dialog "base/modes")
+ (erc-server-flood-penalty 0.1)
+ (dumb-server (erc-d-run "localhost" t 'chan-changed))
+ (erc-modules (cons 'fill-wrap erc-modules))
+ (erc-fill-wrap-align-prompt t)
+ (erc-fill-wrap-use-pixels nil)
+ (erc-prompt #'erc-prompt-format)
+ (erc-autojoin-channels-alist '((Libera.Chat "#chan")))
+ (expect (erc-d-t-make-expecter))
+ ;; Collect samples of `line-prefix' to verify deltas as the
+ ;; prompt grows and shrinks.
+ (line-prefixes nil)
+ (stash-pfx (lambda ()
+ (pcase (get-text-property erc-insert-marker 'line-prefix)
+ (`(space :width (- erc-fill--wrap-value ,n))
+ (car (push n line-prefixes)))))))
+
+ (ert-info ("Connect to Libera.Chat")
+ (with-current-buffer (erc :server "127.0.0.1"
+ :port (process-contact dumb-server :service)
+ :nick "tester"
+ :full-name "tester")
+ (funcall expect 5 "Welcome to the Libera.Chat")
+ (funcall stash-pfx)
+ (funcall expect 5 "changed mode")
+ ;; New prompt is shorter than default with placeholders, like
+ ;; "(foo?)(bar?)" (assuming we win the inherent race).
+ (should (>= (car line-prefixes) (funcall stash-pfx)))
+ (erc-scenarios-prompt-format--assert "user-" '(display . ("Ziw")))))
+
+ (with-current-buffer (erc-d-t-wait-for 5 (get-buffer "#chan"))
+ (should-not erc-channel-key)
+ (should-not erc-channel-user-limit)
+
+ (ert-info ("Receive notice that mode has changed")
+ (erc-d-t-wait-for 10 (equal erc-channel-modes '("n" "t")))
+ (funcall stash-pfx)
+ (erc-scenarios-common-say "ready before")
+ (funcall expect 10 " has changed mode for #chan to +Qu")
+ (erc-d-t-wait-for 10 (equal erc-channel-modes '("Q" "n" "t" "u")))
+ ;; Prompt is longer now, so too is the `line-prefix' subtrahend.
+ (should (< (car line-prefixes) (funcall stash-pfx)))
+ (erc-scenarios-prompt-format--assert "Qntu")
+ (erc-scenarios-prompt-format--assert "#chan>"))
+
+ (ert-info ("Key stored locally")
+ (erc-scenarios-common-say "ready key")
+ (funcall expect 10 " has changed mode for #chan to +k hunter2")
+ ;; Prompt has grown by 1.
+ (should (< (car line-prefixes) (funcall stash-pfx)))
+ (erc-scenarios-prompt-format--assert "Qkntu"))
+
+ (ert-info ("Limit stored locally")
+ (erc-scenarios-common-say "ready limit")
+ (funcall expect 10 " has changed mode for #chan to +l 3")
+ (erc-d-t-wait-for 10 (eql erc-channel-user-limit 3))
+ (should (equal erc-channel-modes '("Q" "n" "t" "u")))
+ ;; Prompt has grown by 1 again.
+ (should (< (car line-prefixes) (funcall stash-pfx)))
+ (erc-scenarios-prompt-format--assert "Qklntu"))
+
+ (ert-info ("Modes removed and local state deletion succeeds")
+ (erc-scenarios-common-say "ready drop")
+ (funcall expect 10 " has changed mode for #chan to -lu")
+ (funcall expect 10 " has changed mode for #chan to -Qk *")
+ (erc-d-t-wait-for 10 (equal erc-channel-modes '("n" "t")))
+ ;; Prompt has shrunk.
+ (should (> (car line-prefixes) (funcall stash-pfx)))
+ (erc-scenarios-prompt-format--assert "nt"))
+
+ (should-not erc-channel-key)
+ (should-not erc-channel-user-limit)
+ (funcall expect 10 "<Chad> after"))))
+
+;;; erc-scenarios-prompt-format.el ends here
diff --git a/test/lisp/erc/erc-scenarios-sasl.el b/test/lisp/erc/erc-scenarios-sasl.el
index 2a3bfe7bda1..e070c675446 100644
--- a/test/lisp/erc/erc-scenarios-sasl.el
+++ b/test/lisp/erc/erc-scenarios-sasl.el
@@ -51,6 +51,70 @@
;; Regression "\0\0\0\0 ..." caused by (fillarray passphrase 0)
(should (string= erc-sasl-password "password123"))))))
+;; The user's unreasonably long password is apportioned into chunks on
+;; the way out the door.
+
+(ert-deftest erc-scenarios-sasl--plain-overlong-split ()
+ :tags '(:expensive-test)
+ (erc-scenarios-common-with-cleanup
+ ((erc-scenarios-common-dialog "sasl")
+ (erc-server-flood-penalty 0.1)
+ (dumb-server (erc-d-run "localhost" t 'plain-overlong-split))
+ (port (process-contact dumb-server :service))
+ (erc-modules (cons 'sasl erc-modules))
+ (erc-sasl-password
+ (concat
+ "Est ut beatae omnis ipsam. "
+ "Quis fugiat deleniti totam qui. "
+ "Ipsum quam a dolorum tempora velit laborum odit. "
+ "Et saepe voluptate sed cumque vel. "
+ "Voluptas sint ab pariatur libero veritatis corrupti. "
+ "Vero iure omnis ullam. "
+ "Vero beatae dolores facere fugiat ipsam. "
+ "Ea est pariatur minima nobis sunt aut ut. "
+ "Dolores ut laudantium maiores temporibus voluptates. "
+ "Reiciendis impedit omnis et unde delectus quas ab. "
+ "Quae eligendi necessitatibus doloribus "
+ "molestias tempora magnam assumenda."))
+ (expect (erc-d-t-make-expecter)))
+
+ (ert-info ("Connect")
+ (with-current-buffer (erc :server "127.0.0.1"
+ :port port
+ :nick "emersion"
+ :user "emersion"
+ :full-name "emersion")
+ (funcall expect 10 "This server is in debug mode")
+ (erc-cmd-QUIT "")))))
+
+(ert-deftest erc-scenarios-sasl--plain-overlong-aligned ()
+ :tags '(:expensive-test)
+ (erc-scenarios-common-with-cleanup
+ ((erc-scenarios-common-dialog "sasl")
+ (erc-server-flood-penalty 0.1)
+ (dumb-server (erc-d-run "localhost" t 'plain-overlong-aligned))
+ (port (process-contact dumb-server :service))
+ (erc-modules (cons 'sasl erc-modules))
+ (erc-sasl-password
+ (concat
+ "Est ut beatae omnis ipsam. "
+ "Quis fugiat deleniti totam qui. "
+ "Ipsum quam a dolorum tempora velit laborum odit. "
+ "Et saepe voluptate sed cumque vel. "
+ "Voluptas sint ab pariatur libero veritatis corrupti. "
+ "Vero iure omnis ullam. Vero beatae dolores facere fugiat ipsam. "
+ "Ea est pariatur minima nobis"))
+ (expect (erc-d-t-make-expecter)))
+
+ (ert-info ("Connect")
+ (with-current-buffer (erc :server "127.0.0.1"
+ :port port
+ :nick "emersion"
+ :user "emersion"
+ :full-name "emersion")
+ (funcall expect 10 "This server is in debug mode")
+ (erc-cmd-QUIT "")))))
+
(ert-deftest erc-scenarios-sasl--external ()
:tags '(:expensive-test)
(erc-scenarios-common-with-cleanup
@@ -85,23 +149,26 @@
(erc-modules (cons 'sasl erc-modules))
(erc-sasl-password "wrong")
(erc-sasl-mechanism 'plain)
- (expect (erc-d-t-make-expecter))
- (buf nil))
+ (erc--warnings-buffer-name "*ERC test warnings*")
+ (warnings-buffer (get-buffer-create erc--warnings-buffer-name))
+ (inhibit-message noninteractive)
+ (expect (erc-d-t-make-expecter)))
- (ert-info ("Connect")
- (setq buf (erc :server "127.0.0.1"
- :port port
- :nick "tester"
- :user "tester"
- :full-name "tester"))
- (let ((err (should-error
- (with-current-buffer buf
- (funcall expect 20 "Connection failed!")))))
- (should (string-search "please review" (cadr err)))
- (with-current-buffer buf
- (funcall expect 10 "Opening connection")
- (funcall expect 20 "SASL authentication failed")
- (should-not (erc-server-process-alive)))))))
+ (with-current-buffer (erc :server "127.0.0.1"
+ :port port
+ :nick "tester"
+ :user "tester"
+ :full-name "tester")
+ (funcall expect 10 "Opening connection")
+ (funcall expect 20 "SASL authentication failed")
+ (funcall expect 20 "Connection failed!")
+ (should-not (erc-server-process-alive)))
+
+ (with-current-buffer warnings-buffer
+ (funcall expect 10 "please review SASL settings")))
+
+ (when noninteractive
+ (should-not (get-buffer "*ERC test warnings*"))))
(defun erc-scenarios--common--sasl (mech)
(erc-scenarios-common-with-cleanup
diff --git a/test/lisp/erc/erc-scenarios-scrolltobottom-relaxed.el b/test/lisp/erc/erc-scenarios-scrolltobottom-relaxed.el
new file mode 100644
index 00000000000..c7260500b7d
--- /dev/null
+++ b/test/lisp/erc/erc-scenarios-scrolltobottom-relaxed.el
@@ -0,0 +1,140 @@
+;;; erc-scenarios-scrolltobottom-relaxed.el --- erc-scrolltobottom-all relaxed -*- lexical-binding: t -*-
+
+;; Copyright (C) 2023-2024 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 <https://www.gnu.org/licenses/>.
+
+;; TODO assert behavior of prompt input spanning multiple lines, with
+;; and without line endings.
+
+;;; Code:
+
+(require 'ert-x)
+(eval-and-compile
+ (let ((load-path (cons (ert-resource-directory) load-path)))
+ (require 'erc-scenarios-common)))
+
+(require 'erc-goodies)
+
+(ert-deftest erc-scenarios-scrolltobottom--relaxed ()
+ :tags `(:expensive-test
+ ,@(and (getenv "ERC_TESTS_GRAPHICAL") '(:erc--graphical)))
+ (when (version< emacs-version "29") (ert-skip "Times out"))
+
+ (should-not erc-scrolltobottom-all)
+
+ (erc-scenarios-common-with-noninteractive-in-term
+ ((erc-scenarios-common-dialog "scrolltobottom")
+ (dumb-server (erc-d-run "localhost" t 'help))
+ (port (process-contact dumb-server :service))
+ (erc-modules `(scrolltobottom fill-wrap ,@erc-modules))
+ (erc-scrolltobottom-all 'relaxed)
+ (erc-server-flood-penalty 0.1)
+ (expect (erc-d-t-make-expecter))
+ lower upper)
+
+ (ert-info ("Connect")
+ (with-current-buffer (erc :server "127.0.0.1"
+ :port port
+ :full-name "tester"
+ :nick "tester")
+ (funcall expect 10 "debug mode")))
+
+ (with-current-buffer "foonet"
+ (should (looking-at " and"))
+ (set-window-buffer nil (current-buffer))
+ (delete-other-windows)
+ (split-window-below 15)
+ (recenter 0)
+
+ (ert-info ("Moving into prompt does not trigger scroll")
+ (with-selected-window (next-window)
+ (should-not (erc-scenarios-common--at-win-end-p))
+ (recenter 0)
+ (goto-char (1- erc-insert-marker))
+ (execute-kbd-macro "\C-n")
+ (should-not (erc-scenarios-common--at-win-end-p))
+ (should (= (point) (point-max)))
+ (setq lower (count-screen-lines (window-start) (window-point)))))
+
+ (ert-info ("Module `move-to-prompt' still works")
+ ;; Prompt is somewhere in the middle of the window.
+ (should (erc-scenarios-common--above-win-end-p))
+ (should-not (= (point-max) (point)))
+ ;; Hitting a self-insert key triggers `move-to-prompt' but not
+ ;; a scroll (to bottom).
+ (execute-kbd-macro "hi")
+ ;; Prompt and input appear on same line.
+ (should (= (point-max) (point)))
+ (setq upper (count-screen-lines (window-start) (window-point)))
+ (should-not (= upper (window-body-height))))
+
+ (ert-info ("Command `recenter-top-bottom' allowed at prompt")
+ ;; Hitting C-l recenters the window.
+ (should (= upper (count-screen-lines (window-start) (window-point))))
+ (let ((lines (list upper)))
+ (erc-scenarios-common--recenter-top-bottom)
+ (push (count-screen-lines (window-start) (window-point)) lines)
+ (erc-scenarios-common--recenter-top-bottom)
+ (push (count-screen-lines (window-start) (window-point)) lines)
+ (erc-scenarios-common--recenter-top-bottom)
+ (push (count-screen-lines (window-start) (window-point)) lines)
+ (setq lines (delete-dups lines))
+ (should (= (length lines) 4))))
+
+ (ert-info ("Command `beginning-of-buffer' allowed at prompt")
+ ;; Hitting C-< goes to beginning of buffer.
+ (execute-kbd-macro "\M-<")
+ (should (= 1 (point)))
+ (redisplay)
+ (should (zerop (count-screen-lines (window-start) (window-point))))
+ (should (erc-scenarios-common--prompt-past-win-end-p)))
+
+ (ert-info ("New message doesn't trigger scroll when away from prompt")
+ ;; Arriving insertions don't trigger a scroll when away from the
+ ;; prompt. New output not seen.
+ (erc-cmd-MSG "NickServ help register")
+ (save-excursion (erc-d-t-search-for 10 "End of NickServ"))
+ (should (= 1 (point)))
+ (should (zerop (count-screen-lines (window-start) (window-point))))
+ (should (erc-scenarios-common--prompt-past-win-end-p)))
+
+ (ert-info ("New insertion keeps prompt stationary in other window")
+ (let ((w (next-window)))
+ ;; We're at prompt and completely stationary.
+ (should (>= (window-point w) erc-input-marker))
+ (erc-d-t-wait-for 10
+ (= lower (count-screen-lines (window-start w) (window-point w))))
+ (erc-d-t-ensure-for 0.5
+ (= lower (count-screen-lines (window-start w)
+ (window-point w))))))
+
+ (should (= 2 (length (window-list))))
+ (ert-info ("New message does not trigger a scroll when at prompt")
+ ;; Recenter so prompt is above rather than at window's end.
+ (funcall expect 10 "End of NickServ HELP")
+ (recenter 0)
+ (set-window-point nil (point-max))
+ (setq upper (count-screen-lines (window-start) (window-point)))
+ ;; Prompt is somewhere in the middle of the window.
+ (erc-d-t-wait-for 10 (erc-scenarios-common--above-win-end-p))
+ (erc-scenarios-common-say "/msg NickServ help identify")
+ ;; New arriving messages don't move prompt.
+ (erc-d-t-ensure-for 1
+ (= upper (count-screen-lines (window-start) (window-point))))
+ (funcall expect 10 "IDENTIFY lets you login")))))
+
+;;; erc-scenarios-scrolltobottom-relaxed.el ends here
diff --git a/test/lisp/erc/erc-scenarios-scrolltobottom.el b/test/lisp/erc/erc-scenarios-scrolltobottom.el
new file mode 100644
index 00000000000..d35d3654cd5
--- /dev/null
+++ b/test/lisp/erc/erc-scenarios-scrolltobottom.el
@@ -0,0 +1,68 @@
+;;; erc-scenarios-scrolltobottom.el --- erc-scrolltobottom-mode -*- lexical-binding: t -*-
+
+;; Copyright (C) 2023-2024 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 <https://www.gnu.org/licenses/>.
+
+;;; Code:
+
+(require 'ert-x)
+(eval-and-compile
+ (let ((load-path (cons (ert-resource-directory) load-path)))
+ (require 'erc-scenarios-common)))
+
+(require 'erc-goodies)
+
+;; These two actually seem to run fine on Emacs 28, but skip them for
+;; now to stay in sync with `erc-scenarios-scrolltobottom--relaxed'.
+
+(ert-deftest erc-scenarios-scrolltobottom--normal ()
+ :tags `(:expensive-test ,@(and (getenv "ERC_TESTS_GRAPHICAL")
+ '(:erc--graphical)))
+ (when (version< emacs-version "29") (ert-skip "Times out"))
+
+ (should-not erc-scrolltobottom-all)
+
+ (erc-scenarios-common-scrolltobottom--normal
+ (lambda ()
+ (ert-info ("New insertion doesn't anchor prompt in other window")
+ (let ((w (next-window)))
+ ;; We're at prompt but not aligned to bottom.
+ (should (>= (window-point w) erc-input-marker))
+ (erc-d-t-wait-for 10
+ (not (erc-scenarios-common--at-win-end-p w))))))))
+
+(ert-deftest erc-scenarios-scrolltobottom--all ()
+ :tags `(:expensive-test ,@(and (getenv "ERC_TESTS_GRAPHICAL")
+ '(:erc--graphical)))
+ (when (version< emacs-version "29") (ert-skip "Times out"))
+
+ (should-not erc-scrolltobottom-all)
+
+ (let ((erc-scrolltobottom-all t))
+
+ (erc-scenarios-common-scrolltobottom--normal
+ (lambda ()
+ (ert-info ("New insertion anchors prompt in other window")
+ (let ((w (next-window)))
+ ;; We're at prompt and aligned to bottom.
+ (should (>= (window-point w) erc-input-marker))
+ (erc-d-t-wait-for 10
+ (erc-scenarios-common--at-win-end-p w))
+ (erc-d-t-ensure-for 0.5
+ (erc-scenarios-common--at-win-end-p w))))))))
+
+;;; erc-scenarios-scrolltobottom.el ends here
diff --git a/test/lisp/erc/erc-scenarios-services-misc.el b/test/lisp/erc/erc-scenarios-services-misc.el
index e79c5fc75db..47d0bcff41a 100644
--- a/test/lisp/erc/erc-scenarios-services-misc.el
+++ b/test/lisp/erc/erc-scenarios-services-misc.el
@@ -143,4 +143,109 @@
(erc-services-mode -1)))
+;; The server rejects your nick during registration, so ERC acquires a
+;; placeholder and successfully renicks once the connection is up.
+;; See also `erc-scenarios-base-renick-self-auto'.
+
+(ert-deftest erc-scenarios-services-misc--reconnect-retry-nick ()
+ :tags '(:expensive-test)
+ (erc-scenarios-common-with-cleanup
+ ((erc-server-flood-penalty 0.1)
+ (erc-scenarios-common-dialog "services/regain")
+ (dumb-server (erc-d-run "localhost" t 'reconnect-retry
+ 'reconnect-retry-again))
+ (port (process-contact dumb-server :service))
+ (erc-server-auto-reconnect t)
+ (erc-modules `(services-regain sasl ,@erc-modules))
+ (erc-services-regain-alist
+ '((Libera.Chat . erc-services-retry-nick-on-connect)))
+ (expect (erc-d-t-make-expecter)))
+
+ ;; FIXME figure out and explain why this is so.
+ (should (featurep 'erc-services))
+
+ (ert-info ("Session succeeds but cut short")
+ (with-current-buffer (erc :server "127.0.0.1"
+ :port port
+ :nick "tester"
+ :user "tester"
+ :password "changeme"
+ :full-name "tester")
+ (funcall expect 10 "Last login from")
+ (erc-cmd-JOIN "#test")))
+
+ (with-current-buffer (erc-d-t-wait-for 10 (get-buffer "#test"))
+ (funcall expect 10 "was created on"))
+
+ (ert-info ("Service restored")
+ (with-current-buffer "Libera.Chat"
+ (erc-d-t-wait-for 10 erc--server-reconnect-timer)
+ (funcall expect 10 "Connection failed!")
+ (funcall expect 10 "already in use")
+ (funcall expect 10 "changed mode for tester`")
+ (funcall expect 10 "Last login from")
+ (funcall expect 10 "Your new nickname is tester")))
+
+ (with-current-buffer "#test"
+ (funcall expect 10 "tester ")
+ (funcall expect 10 "was created on"))))
+
+;; This only asserts that the handler fires and issues the right
+;; NickServ command, but it doesn't accurately recreate a
+;; disconnection, but it probably should.
+(ert-deftest erc-scenarios-services-misc--regain-command ()
+ :tags '(:expensive-test)
+ (erc-scenarios-common-with-cleanup
+ ((erc-server-flood-penalty 0.1)
+ (erc-scenarios-common-dialog "services/regain")
+ (dumb-server (erc-d-run "localhost" t 'taken-regain))
+ (port (process-contact dumb-server :service))
+ (erc-server-auto-reconnect t)
+ (erc-modules `(services-regain sasl ,@erc-modules))
+ (erc-services-regain-alist
+ '((ExampleNet . erc-services-issue-regain)))
+ (expect (erc-d-t-make-expecter)))
+
+ (should (featurep 'erc-services)) ; see note in prior test
+
+ (with-current-buffer (erc :server "127.0.0.1"
+ :port port
+ :nick "dummy"
+ :user "tester"
+ :password "changeme"
+ :full-name "tester"
+ :id 'ExampleNet)
+ (funcall expect 10 "dummy is already in use, trying dummy`")
+ (funcall expect 10 "You are now logged in as tester")
+ (funcall expect 10 "-NickServ- dummy has been regained.")
+ (funcall expect 10 "*** Your new nickname is dummy")
+ ;; Works with "given" `:id'.
+ (should (and (erc-network) (not (eq (erc-network) 'ExampleNet)))))))
+
+(ert-deftest erc-scenarios-services-misc--ghost-and-retry-nick ()
+ :tags '(:expensive-test)
+ (erc-scenarios-common-with-cleanup
+ ((erc-server-flood-penalty 0.1)
+ (erc-scenarios-common-dialog "services/regain")
+ (dumb-server (erc-d-run "localhost" t 'taken-ghost))
+ (port (process-contact dumb-server :service))
+ (erc-server-auto-reconnect t)
+ (erc-modules `(services-regain sasl ,@erc-modules))
+ (erc-services-regain-alist
+ '((FooNet . erc-services-issue-ghost-and-retry-nick)))
+ (expect (erc-d-t-make-expecter)))
+
+ (should (featurep 'erc-services)) ; see note in prior test
+
+ (with-current-buffer (erc :server "127.0.0.1"
+ :port port
+ :nick "dummy"
+ :user "tester"
+ :password "changeme"
+ :full-name "tester")
+ (funcall expect 10 "dummy is already in use, trying dummy`")
+ (funcall expect 10 "You are now logged in as tester")
+ (funcall expect 10 "-NickServ- dummy has been ghosted.")
+ (funcall expect 10 "*** Your new nickname is dummy"))))
+
;;; erc-scenarios-services-misc.el ends here
diff --git a/test/lisp/erc/erc-scenarios-stamp.el b/test/lisp/erc/erc-scenarios-stamp.el
new file mode 100644
index 00000000000..3a10f709548
--- /dev/null
+++ b/test/lisp/erc/erc-scenarios-stamp.el
@@ -0,0 +1,181 @@
+;;; erc-scenarios-stamp.el --- Misc `erc-stamp' scenarios -*- lexical-binding: t -*-
+
+;; Copyright (C) 2023-2024 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 <https://www.gnu.org/licenses/>.
+
+;;; Code:
+
+(require 'ert-x)
+(eval-and-compile
+ (let ((load-path (cons (ert-resource-directory) load-path)))
+ (require 'erc-scenarios-common)))
+
+(require 'erc-stamp)
+
+(defvar erc-scenarios-stamp--user-marker nil)
+
+(defun erc-scenarios-stamp--on-post-modify ()
+ (when-let (((erc--check-msg-prop 'erc--cmd 4)))
+ (set-marker erc-scenarios-stamp--user-marker (point-max))
+ (ert-info ("User marker correctly placed at `erc-insert-marker'")
+ (should (= ?\n (char-before erc-scenarios-stamp--user-marker)))
+ (should (= erc-scenarios-stamp--user-marker erc-insert-marker))
+ (save-excursion
+ (goto-char erc-scenarios-stamp--user-marker)
+ ;; The raw message ends in " Iabefhkloqv". However,
+ ;; `erc-server-004' only prints up to the 5th parameter.
+ (should (looking-back "CEIMRUabefhiklmnoqstuv\n"))))))
+
+(ert-deftest erc-scenarios-stamp--left/display-margin-mode ()
+
+ (erc-scenarios-common-with-cleanup
+ ((erc-scenarios-common-dialog "base/reconnect")
+ (dumb-server (erc-d-run "localhost" t 'unexpected-disconnect))
+ (port (process-contact dumb-server :service))
+ (erc-scenarios-stamp--user-marker (make-marker))
+ (erc-stamp--current-time 704591940)
+ (erc-stamp--tz t)
+ (erc-server-flood-penalty 0.1)
+ (erc-insert-timestamp-function #'erc-insert-timestamp-left)
+ (erc-modules (cons 'fill-wrap erc-modules))
+ (erc-timestamp-only-if-changed-flag nil)
+ (expect (erc-d-t-make-expecter)))
+
+ (ert-info ("Connect")
+ (with-current-buffer (erc :server "127.0.0.1"
+ :port port
+ :full-name "tester"
+ :nick "tester")
+
+ (add-hook 'erc-insert-post-hook #'erc-scenarios-stamp--on-post-modify
+ nil t)
+ (funcall expect 5 "This server is in debug mode")
+
+ (ert-info ("Stamps appear in left margin and are invisible")
+ (should (eq 'erc-timestamp (field-at-pos (pos-bol))))
+ (should (= (pos-bol) (field-beginning (pos-bol))))
+ (should (eq 'query-notice (get-text-property (pos-bol) 'erc--msg)))
+ (should (eq 'NOTICE (get-text-property (pos-bol) 'erc--cmd)))
+ (should (= ?- (char-after (field-end (pos-bol)))))
+ (should (equal (get-text-property (1+ (field-end (pos-bol)))
+ 'erc--speaker)
+ "irc.foonet.org"))
+ (should (pcase (get-text-property (pos-bol) 'display)
+ (`((margin left-margin) ,s)
+ (eq 'timestamp (get-text-property 0 'invisible s))))))
+
+ ;; We set a third-party marker at the end of 004's message (on
+ ;; then "\n"), post-insertion.
+ (ert-info ("User markers untouched by subsequent message left stamp")
+ (save-excursion
+ (goto-char erc-scenarios-stamp--user-marker)
+ (should (looking-back "CEIMRUabefhiklmnoqstuv\n"))
+ (should (looking-at (rx "[")))))))))
+
+(ert-deftest erc-scenarios-stamp--legacy-date-stamps ()
+ (with-suppressed-warnings ((obsolete erc-stamp-prepend-date-stamps-p))
+ (erc-scenarios-common-with-cleanup
+ ((erc-scenarios-common-dialog "base/reconnect")
+ (erc-stamp-prepend-date-stamps-p t)
+ (dumb-server (erc-d-run "localhost" t 'unexpected-disconnect))
+ (port (process-contact dumb-server :service))
+ (erc-server-flood-penalty 0.1)
+ (expect (erc-d-t-make-expecter)))
+
+ (ert-info ("Connect")
+ (with-current-buffer (erc :server "127.0.0.1"
+ :port port
+ :full-name "tester"
+ :nick "tester")
+ (funcall expect 5 "Opening connection")
+ (goto-char (1- (match-beginning 0)))
+ (should (eq 'erc-timestamp (field-at-pos (point))))
+ (should (eq 'unknown (erc--get-inserted-msg-prop 'erc--msg)))
+ ;; Force redraw of date stamp.
+ (setq erc-timestamp-last-inserted-left nil)
+
+ (funcall expect 5 "This server is in debug mode")
+ (while (and (zerop (forward-line -1))
+ (not (eq 'erc-timestamp (field-at-pos (point))))))
+ (should (erc--get-inserted-msg-prop 'erc--cmd)))))))
+
+;; This user-owned hook member places a marker on the first message in
+;; a buffer. Inserting a date stamp in front of it shouldn't move the
+;; marker.
+(defun erc-scenarios-stamp--on-insert-modify ()
+ (unless (marker-position erc-scenarios-stamp--user-marker)
+ (set-marker erc-scenarios-stamp--user-marker (point-min))
+ (save-excursion
+ (goto-char erc-scenarios-stamp--user-marker)
+ (should (looking-at "Opening"))))
+
+ ;; Sometime after the first message ("Opening connection.."), assert
+ ;; that the marker we just placed hasn't moved.
+ (when (erc--check-msg-prop 'erc--cmd 2)
+ (save-restriction
+ (widen)
+ (ert-info ("Date stamp preserves opening user marker")
+ (goto-char erc-scenarios-stamp--user-marker)
+ (should-not (eq 'erc-timestamp (field-at-pos (point))))
+ (should (looking-at "Opening"))
+ (should (eq 'unknown (get-text-property (point) 'erc--msg))))))
+
+ ;; On 003 ("*** This server was created on"), clear state to force a
+ ;; new date stamp on the next message.
+ (when (erc--check-msg-prop 'erc--cmd 3)
+ (setq erc-timestamp-last-inserted-left nil)
+ (set-marker erc-scenarios-stamp--user-marker erc-insert-marker)))
+
+(ert-deftest erc-scenarios-stamp--date-mode/left-and-right ()
+
+ (should (eq erc-insert-timestamp-function
+ #'erc-insert-timestamp-left-and-right))
+
+ (erc-scenarios-common-with-cleanup
+ ((erc-scenarios-common-dialog "base/reconnect")
+ (dumb-server (erc-d-run "localhost" t 'unexpected-disconnect))
+ (port (process-contact dumb-server :service))
+ (erc-scenarios-stamp--user-marker (make-marker))
+ (erc-server-flood-penalty 0.1)
+ (erc-modules (if (zerop (random 2))
+ (cons 'fill-wrap erc-modules)
+ erc-modules))
+ (expect (erc-d-t-make-expecter))
+ (erc-mode-hook
+ (cons (lambda ()
+ (add-hook 'erc-insert-modify-hook
+ #'erc-scenarios-stamp--on-insert-modify -99 t))
+ erc-mode-hook)))
+
+ (ert-info ("Connect")
+ (with-current-buffer (erc :server "127.0.0.1"
+ :port port
+ :full-name "tester"
+ :nick "tester")
+
+ (funcall expect 5 "Welcome to the foonet")
+ (funcall expect 5 "*** AWAYLEN=390")
+
+ (ert-info ("Date stamp preserves other user marker")
+ (goto-char erc-scenarios-stamp--user-marker)
+ (should-not (eq 'erc-timestamp (field-at-pos (point))))
+ (should (looking-at (rx "*** irc.foonet.org oragono")))
+ (should (eq 's004 (get-text-property (point) 'erc--msg))))
+
+ (funcall expect 5 "This server is in debug mode")))))
+
+;;; erc-scenarios-stamp.el ends here
diff --git a/test/lisp/erc/erc-scenarios-status-sidebar.el b/test/lisp/erc/erc-scenarios-status-sidebar.el
new file mode 100644
index 00000000000..2523ff9ee46
--- /dev/null
+++ b/test/lisp/erc/erc-scenarios-status-sidebar.el
@@ -0,0 +1,174 @@
+;;; erc-scenarios-status-sidebar.el --- erc-sidebar/speedbar tests -*- lexical-binding: t -*-
+
+;; Copyright (C) 2023-2024 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 <https://www.gnu.org/licenses/>.
+
+;;; Code:
+
+(require 'ert-x)
+(eval-and-compile
+ (let ((load-path (cons (ert-resource-directory) load-path)))
+ (require 'erc-scenarios-common)))
+
+(require 'erc-status-sidebar)
+
+
+(ert-deftest erc-scenarios-status-sidebar--bufbar ()
+ :tags '(:expensive-test)
+ (erc-scenarios-common-with-cleanup
+ ((erc-scenarios-common-dialog "base/gapless-connect")
+ (erc-server-flood-penalty 0.1)
+ (erc-server-flood-penalty erc-server-flood-penalty)
+ (erc-modules `(bufbar ,@erc-modules))
+ (dumb-server (erc-d-run "localhost" t 'foonet 'barnet))
+ (port (process-contact dumb-server :service))
+ (expect (erc-d-t-make-expecter)))
+
+ (ert-info ("Connect to two different endpoints")
+ (with-current-buffer (erc :server "127.0.0.1"
+ :port port
+ :nick "tester"
+ :password "foonet:changeme"
+ :full-name "tester")
+ (funcall expect 10 "MOTD File is missing"))
+ (with-current-buffer (erc :server "127.0.0.1"
+ :port port
+ :nick "tester"
+ :password "barnet:changeme"
+ :full-name "tester")
+ (funcall expect 10 "marked as being away")))
+
+
+ (with-current-buffer (erc-d-t-wait-for 20 (get-buffer "#bar"))
+ (funcall expect 10 "was created on")
+ (funcall expect 2 "his second fit"))
+
+ (with-current-buffer (erc-d-t-wait-for 20 (get-buffer "#foo"))
+ (funcall expect 10 "was created on")
+ (funcall expect 2 "no use of him")
+ (ert-info ("Activity marker is in the right spot")
+ (let ((obuf (window-buffer))) ; *scratch*
+ (set-window-buffer (selected-window) "#foo")
+ (erc-d-t-wait-for 5
+ (erc-status-sidebar-refresh)
+ (with-current-buffer "*ERC Status*"
+ (and (marker-position erc-status-sidebar--active-marker)
+ (goto-char erc-status-sidebar--active-marker)
+ ;; The " [N]" suffix disappears because it's selected
+ (search-forward "#foo" (pos-eol) t))))
+ (set-window-buffer (selected-window) obuf))))
+
+ (with-current-buffer (erc-d-t-wait-for 20 (get-buffer "*ERC Status*"))
+ (ert-info ("Hierarchy printed correctly")
+ (funcall expect 10 "barnet [")
+ (funcall expect 10 "#bar [")
+ (funcall expect 10 "foonet [")
+ (funcall expect 10 "#foo")))
+
+ (with-current-buffer "#foo"
+ (ert-info ("Core toggle and kill commands work")
+ ;; Avoid using API, e.g., `erc-status-sidebar-buffer-exists-p',
+ ;; etc. for testing commands that call those same functions.
+ (should (get-buffer-window "*ERC Status*"))
+ (erc-bufbar-mode -1)
+ (should-not (get-buffer-window "*ERC Status*"))
+ (erc-status-sidebar-kill)
+ (should-not (get-buffer "*ERC Status*"))))))
+
+;; We can't currently run this on EMBA because it needs a usable
+;; terminal, and we lack a fixture for that. Please try running this
+;; test interactively with both graphical Emacs and non.
+(declare-function erc-nickbar-mode "erc-speedbar" (arg))
+(declare-function erc-speedbar--get-timers "erc-speedbar" nil)
+(declare-function speedbar-timer-fn "speedbar" nil)
+(defvar erc-nickbar-mode)
+(defvar speedbar-buffer)
+
+(ert-deftest erc-scenarios-status-sidebar--nickbar ()
+ :tags `(:expensive-test :unstable ,@(and (getenv "ERC_TESTS_GRAPHICAL")
+ '(:erc--graphical)))
+ (when noninteractive (ert-skip "Interactive only"))
+
+ (erc-scenarios-common-with-cleanup
+ ((erc-scenarios-common-dialog "base/gapless-connect")
+ (erc-server-flood-penalty 0.1)
+ (erc-server-flood-penalty erc-server-flood-penalty)
+ (erc-modules `(nickbar ,@erc-modules))
+ (dumb-server (erc-d-run "localhost" t 'foonet 'barnet))
+ (port (process-contact dumb-server :service))
+ (expect (erc-d-t-make-expecter)))
+
+ (ert-info ("Connect to two different endpoints")
+ (with-current-buffer (erc :server "127.0.0.1"
+ :port port
+ :nick "tester"
+ :password "foonet:changeme"
+ :full-name "tester")
+ (funcall expect 10 "MOTD File is missing"))
+ (with-current-buffer (erc :server "127.0.0.1"
+ :port port
+ :nick "tester"
+ :password "barnet:changeme"
+ :full-name "tester")
+ (funcall expect 10 "marked as being away")))
+
+ (erc-d-t-wait-for 20 (get-buffer "#bar"))
+ (with-current-buffer (pop-to-buffer "#bar")
+ (funcall expect 10 "was created on")
+ (funcall expect 2 "his second fit")
+ (erc-d-t-wait-for 10 (and speedbar-buffer (get-buffer speedbar-buffer)))
+ (speedbar-timer-fn)
+ (with-current-buffer speedbar-buffer
+ (funcall expect 10 "#bar (3)")
+ (funcall expect 10 '(| "@mike" "joe"))
+ (funcall expect 10 '(| "@mike" "joe"))
+ (funcall expect 10 "tester")))
+
+ (erc-d-t-wait-for 20 (get-buffer "#foo"))
+ (with-current-buffer (pop-to-buffer "#foo")
+ (delete-other-windows)
+ (funcall expect 10 "was created on")
+ (funcall expect 2 "no use of him")
+ (speedbar-timer-fn)
+ (with-current-buffer speedbar-buffer
+ (funcall expect 10 "#foo (3)")
+ (funcall expect 10 '(| "alice" "@bob"))
+ (funcall expect 10 '(| "alice" "@bob"))
+ (funcall expect 10 "tester")))
+
+ (with-current-buffer "#foo"
+ (ert-info ("Core toggle and kill commands work")
+ ;; Avoid using API, e.g., `erc-status-sidebar-buffer-exists-p',
+ ;; etc. for testing commands that call those same functions.
+ (call-interactively #'erc-nickbar-mode)
+ (should-not erc-nickbar-mode)
+ (should-not (and speedbar-buffer
+ (get-buffer-window speedbar-buffer)))
+ (should speedbar-buffer)
+
+ (erc-nickbar-mode +1)
+ (should (and speedbar-buffer
+ (get-buffer-window speedbar-buffer)))
+ (should (get-buffer " SPEEDBAR"))
+ (erc-nickbar-mode -1)
+ (should-not (get-buffer " SPEEDBAR"))
+ (should-not erc-nickbar-mode)
+ (should-not (cdr (frame-list)))))
+
+ (should-not (erc-speedbar--get-timers))))
+
+;;; erc-scenarios-status-sidebar.el ends here
diff --git a/test/lisp/erc/erc-services-tests.el b/test/lisp/erc/erc-services-tests.el
index 2302ca83df6..9bafba98dc6 100644
--- a/test/lisp/erc/erc-services-tests.el
+++ b/test/lisp/erc/erc-services-tests.el
@@ -212,39 +212,32 @@
(advice-remove 'epg-decrypt-string 'erc--auth-source-plstore)
(advice-remove 'epg-find-configuration 'erc--auth-source-plstore)))
-(defvar erc-services-tests--auth-source-plstore-standard-entries
- '(("ba950d38118a76d71f9f0591bb373d6cb366a512"
- :secret-secret t
- :host "irc.gnu.org"
- :user "#chan"
- :port "irc")
- ("7f17ca445d11158065e911a6d0f4cbf52ca250e3"
- :secret-secret t
- :host "my.gnu.org"
- :user "#chan"
- :port "irc")
- ("fcd3c8bd6daf4509de0ad6ee98e744ce0fca9377"
- :secret-secret t
- :host "GNU.chat"
- :user "#chan"
- :port "irc")))
-
-(defvar erc-services-tests--auth-source-plstore-standard-secrets
- '(("ba950d38118a76d71f9f0591bb373d6cb366a512" :secret "bar")
- ("7f17ca445d11158065e911a6d0f4cbf52ca250e3" :secret "baz")
- ("fcd3c8bd6daf4509de0ad6ee98e744ce0fca9377" :secret "foo")))
+(defvar erc-services-tests--auth-source-plstore-standard-announced "\
+;;; public entries -*- mode: plstore -*-
+((\"ba950d38118a76d71f9f0591bb373d6cb366a512\"
+ :secret-secret t
+ :host \"irc.gnu.org\"
+ :user \"#chan\"
+ :port \"irc\")
+ (\"7f17ca445d11158065e911a6d0f4cbf52ca250e3\"
+ :secret-secret t
+ :host \"my.gnu.org\"
+ :user \"#chan\"
+ :port \"irc\")
+ (\"fcd3c8bd6daf4509de0ad6ee98e744ce0fca9377\"
+ :secret-secret t
+ :host \"GNU.chat\"
+ :user \"#chan\"
+ :port \"irc\"))
+;;; secret entries
+((\"ba950d38118a76d71f9f0591bb373d6cb366a512\" :secret \"bar\")
+ (\"7f17ca445d11158065e911a6d0f4cbf52ca250e3\" :secret \"baz\")
+ (\"fcd3c8bd6daf4509de0ad6ee98e744ce0fca9377\" :secret \"foo\"))")
(ert-deftest erc--auth-source-search--plstore-standard ()
(ert-with-temp-file plstore-file
:suffix ".plist"
- :text (concat ";;; public entries -*- mode: plstore -*- \n"
- (prin1-to-string
- erc-services-tests--auth-source-plstore-standard-entries)
- "\n;;; secret entries\n"
- (prin1-to-string
- erc-services-tests--auth-source-plstore-standard-secrets)
- "\n")
-
+ :text erc-services-tests--auth-source-plstore-standard-announced
(let ((auth-sources (list plstore-file))
(auth-source-do-cache nil))
(erc-services-tests--auth-source-standard
@@ -254,14 +247,7 @@
(ert-deftest erc--auth-source-search--plstore-announced ()
(ert-with-temp-file plstore-file
:suffix ".plist"
- :text (concat ";;; public entries -*- mode: plstore -*- \n"
- (prin1-to-string
- erc-services-tests--auth-source-plstore-standard-entries)
- "\n;;; secret entries\n"
- (prin1-to-string
- erc-services-tests--auth-source-plstore-standard-secrets)
- "\n")
-
+ :text erc-services-tests--auth-source-plstore-standard-announced
(let ((auth-sources (list plstore-file))
(auth-source-do-cache nil))
(erc-services-tests--auth-source-announced
@@ -271,29 +257,33 @@
(ert-deftest erc--auth-source-search--plstore-overrides ()
(ert-with-temp-file plstore-file
:suffix ".plist"
- :text (concat
- ";;; public entries -*- mode: plstore -*- \n"
- (prin1-to-string
- `(,@erc-services-tests--auth-source-plstore-standard-entries
- ("1b3fab249a8dff77a4d8fe7eb4b0171b25cc711a"
- :secret-secret t :host "GNU.chat" :user "#chan" :port "6697")
- ("6cbcdc39476b8cfcca6f3e9a7876f41ec3f708cc"
- :secret-secret t :host "my.gnu.org" :user "#fsf" :port "irc")
- ("a33e2b3bd2d6f33995a4b88710a594a100c5e41d"
- :secret-secret t :host "irc.gnu.org" :port "6667")
- ("ab2fd349b2b7d6a9215bb35a92d054261b0b1537"
- :secret-secret t :host "MyHost" :port "irc")
- ("61a6bd552059494f479ff720e8de33e22574650a"
- :secret-secret t :host "MyHost" :port "6667")))
- "\n;;; secret entries\n"
- (prin1-to-string
- `(,@erc-services-tests--auth-source-plstore-standard-secrets
- ("1b3fab249a8dff77a4d8fe7eb4b0171b25cc711a" :secret "spam")
- ("6cbcdc39476b8cfcca6f3e9a7876f41ec3f708cc" :secret "42")
- ("a33e2b3bd2d6f33995a4b88710a594a100c5e41d" :secret "sesame")
- ("ab2fd349b2b7d6a9215bb35a92d054261b0b1537" :secret "456")
- ("61a6bd552059494f479ff720e8de33e22574650a" :secret "123")))
- "\n")
+ :text "\
+;;; public entries -*- mode: plstore -*-
+((\"ba950d38118a76d71f9f0591bb373d6cb366a512\"
+ :secret-secret t :host \"irc.gnu.org\" :user \"#chan\" :port \"irc\")
+ (\"7f17ca445d11158065e911a6d0f4cbf52ca250e3\"
+ :secret-secret t :host \"my.gnu.org\" :user \"#chan\" :port \"irc\")
+ (\"fcd3c8bd6daf4509de0ad6ee98e744ce0fca9377\"
+ :secret-secret t :host \"GNU.chat\" :user \"#chan\" :port \"irc\")
+ (\"1b3fab249a8dff77a4d8fe7eb4b0171b25cc711a\"
+ :secret-secret t :host \"GNU.chat\" :user \"#chan\" :port \"6697\")
+ (\"6cbcdc39476b8cfcca6f3e9a7876f41ec3f708cc\"
+ :secret-secret t :host \"my.gnu.org\" :user \"#fsf\" :port \"irc\")
+ (\"a33e2b3bd2d6f33995a4b88710a594a100c5e41d\"
+ :secret-secret t :host \"irc.gnu.org\" :port \"6667\")
+ (\"ab2fd349b2b7d6a9215bb35a92d054261b0b1537\"
+ :secret-secret t :host \"MyHost\" :port \"irc\")
+ (\"61a6bd552059494f479ff720e8de33e22574650a\"
+ :secret-secret t :host \"MyHost\" :port \"6667\"))
+;;; secret entries
+((\"ba950d38118a76d71f9f0591bb373d6cb366a512\" :secret \"bar\")
+ (\"7f17ca445d11158065e911a6d0f4cbf52ca250e3\" :secret \"baz\")
+ (\"fcd3c8bd6daf4509de0ad6ee98e744ce0fca9377\" :secret \"foo\")
+ (\"1b3fab249a8dff77a4d8fe7eb4b0171b25cc711a\" :secret \"spam\")
+ (\"6cbcdc39476b8cfcca6f3e9a7876f41ec3f708cc\" :secret \"42\")
+ (\"a33e2b3bd2d6f33995a4b88710a594a100c5e41d\" :secret \"sesame\")
+ (\"ab2fd349b2b7d6a9215bb35a92d054261b0b1537\" :secret \"456\")
+ (\"61a6bd552059494f479ff720e8de33e22574650a\" :secret \"123\"))"
(let ((auth-sources (list plstore-file))
(auth-source-do-cache nil))
@@ -303,17 +293,24 @@
;; auth-source JSON backend
-(defvar erc-services-tests--auth-source-json-standard-entries
- [(:host "irc.gnu.org" :port "irc" :user "#chan" :secret "bar")
- (:host "my.gnu.org" :port "irc" :user "#chan" :secret "baz")
- (:host "GNU.chat" :port "irc" :user "#chan" :secret "foo")])
+(defvar erc-services-tests--auth-source-json-standard-announced "\
+[{\"host\": \"irc.gnu.org\",
+ \"port\": \"irc\",
+ \"user\": \"#chan\",
+ \"secret\": \"bar\"},
+ {\"host\": \"my.gnu.org\",
+ \"port\": \"irc\",
+ \"user\": \"#chan\",
+ \"secret\": \"baz\"},
+ {\"host\": \"GNU.chat\",
+ \"port\": \"irc\",
+ \"user\": \"#chan\",
+ \"secret\": \"foo\"}]")
(ert-deftest erc--auth-source-search--json-standard ()
(ert-with-temp-file json-store
+ :text erc-services-tests--auth-source-json-standard-announced
:suffix ".json"
- :text (let ((json-object-type 'plist))
- (json-encode
- erc-services-tests--auth-source-json-standard-entries))
(let ((auth-sources (list json-store))
(auth-source-do-cache nil))
(erc-services-tests--auth-source-standard #'erc-auth-source-search))))
@@ -321,10 +318,7 @@
(ert-deftest erc--auth-source-search--json-announced ()
(ert-with-temp-file plstore-file
:suffix ".json"
- :text (let ((json-object-type 'plist))
- (json-encode
- erc-services-tests--auth-source-json-standard-entries))
-
+ :text erc-services-tests--auth-source-json-standard-announced
(let ((auth-sources (list plstore-file))
(auth-source-do-cache nil))
(erc-services-tests--auth-source-announced #'erc-auth-source-search))))
@@ -332,16 +326,36 @@
(ert-deftest erc--auth-source-search--json-overrides ()
(ert-with-temp-file json-file
:suffix ".json"
- :text (let ((json-object-type 'plist))
- (json-encode
- (vconcat
- erc-services-tests--auth-source-json-standard-entries
- [(:secret "spam" :host "GNU.chat" :user "#chan" :port "6697")
- (:secret "42" :host "my.gnu.org" :user "#fsf" :port "irc")
- (:secret "sesame" :host "irc.gnu.org" :port "6667")
- (:secret "456" :host "MyHost" :port "irc")
- (:secret "123" :host "MyHost" :port "6667")])))
-
+ :text "\
+[{\"host\": \"irc.gnu.org\",
+ \"port\": \"irc\",
+ \"user\": \"#chan\",
+ \"secret\": \"bar\"},
+ {\"host\": \"my.gnu.org\",
+ \"port\": \"irc\",
+ \"user\": \"#chan\",
+ \"secret\": \"baz\"},
+ {\"host\": \"GNU.chat\",
+ \"port\": \"irc\",
+ \"user\": \"#chan\",
+ \"secret\": \"foo\"},
+ {\"host\": \"GNU.chat\",
+ \"user\": \"#chan\",
+ \"port\": \"6697\",
+ \"secret\": \"spam\"},
+ {\"host\": \"my.gnu.org\",
+ \"user\": \"#fsf\",
+ \"port\": \"irc\",
+ \"secret\": \"42\"},
+ {\"host\": \"irc.gnu.org\",
+ \"port\": \"6667\",
+ \"secret\": \"sesame\"},
+ {\"host\": \"MyHost\",
+ \"port\": \"irc\",
+ \"secret\": \"456\"},
+ {\"host\": \"MyHost\",
+ \"port\": \"6667\",
+ \"secret\": \"123\"}]"
(let ((auth-sources (list json-file))
(auth-source-do-cache nil))
(erc-services-tests--auth-source-overrides #'erc-auth-source-search))))
@@ -370,6 +384,14 @@
("#chan@my.gnu.org:irc" . "baz")
("#chan@GNU.chat:irc" . "foo")))
+(defun erc-services-tests--secrets-search-items (entries _ &rest r)
+ (mapcan (lambda (s)
+ (and (seq-every-p (pcase-lambda (`(,k . ,v))
+ (equal v (alist-get k (cdr s))))
+ (map-pairs r))
+ (list (car s))))
+ entries))
+
(ert-deftest erc--auth-source-search--secrets-standard ()
(skip-unless (bound-and-true-p secrets-enabled))
(let ((auth-sources '("secrets:Test"))
@@ -378,18 +400,12 @@
(secrets erc-services-tests--auth-source-secrets-standard-secrets))
(cl-letf (((symbol-function 'secrets-search-items)
- (lambda (col &rest r)
- (should (equal col "Test"))
- (should (plist-get r :user))
- (map-keys entries)))
+ (apply-partially #'erc-services-tests--secrets-search-items
+ entries))
((symbol-function 'secrets-get-secret)
- (lambda (col label)
- (should (equal col "Test"))
- (assoc-default label secrets)))
+ (lambda (_ label) (assoc-default label secrets)))
((symbol-function 'secrets-get-attributes)
- (lambda (col label)
- (should (equal col "Test"))
- (assoc-default label entries))))
+ (lambda (_ label) (assoc-default label entries))))
(erc-services-tests--auth-source-standard #'erc-auth-source-search))))
@@ -401,18 +417,12 @@
(secrets erc-services-tests--auth-source-secrets-standard-secrets))
(cl-letf (((symbol-function 'secrets-search-items)
- (lambda (col &rest r)
- (should (equal col "Test"))
- (should (plist-get r :user))
- (map-keys entries)))
+ (apply-partially #'erc-services-tests--secrets-search-items
+ entries))
((symbol-function 'secrets-get-secret)
- (lambda (col label)
- (should (equal col "Test"))
- (assoc-default label secrets)))
+ (lambda (_ label) (assoc-default label secrets)))
((symbol-function 'secrets-get-attributes)
- (lambda (col label)
- (should (equal col "Test"))
- (assoc-default label entries))))
+ (lambda (_ label) (assoc-default label entries))))
(erc-services-tests--auth-source-announced #'erc-auth-source-search))))
@@ -444,17 +454,12 @@
("MyHost:6667" . "123"))))
(cl-letf (((symbol-function 'secrets-search-items)
- (lambda (col &rest _)
- (should (equal col "Test"))
- (map-keys entries)))
+ (apply-partially #'erc-services-tests--secrets-search-items
+ entries))
((symbol-function 'secrets-get-secret)
- (lambda (col label)
- (should (equal col "Test"))
- (assoc-default label secrets)))
+ (lambda (_ label) (assoc-default label secrets)))
((symbol-function 'secrets-get-attributes)
- (lambda (col label)
- (should (equal col "Test"))
- (assoc-default label entries))))
+ (lambda (_ label) (assoc-default label entries))))
(erc-services-tests--auth-source-overrides #'erc-auth-source-search))))
diff --git a/test/lisp/erc/erc-stamp-tests.el b/test/lisp/erc/erc-stamp-tests.el
new file mode 100644
index 00000000000..5fee21ec28f
--- /dev/null
+++ b/test/lisp/erc/erc-stamp-tests.el
@@ -0,0 +1,352 @@
+;;; erc-stamp-tests.el --- Tests for erc-stamp. -*- lexical-binding:t -*-
+
+;; Copyright (C) 2023-2024 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 <https://www.gnu.org/licenses/>.
+
+;;; Commentary:
+
+;;; Code:
+(require 'erc-stamp)
+(require 'erc-goodies) ; for `erc-make-read-only'
+
+(require 'ert-x)
+(eval-and-compile
+ (let ((load-path (cons (ert-resource-directory) load-path)))
+ (require 'erc-tests-common)))
+
+;; These display-oriented tests are brittle because many factors
+;; influence how text properties are applied. We should just
+;; rework these into full scenarios.
+
+(defun erc-stamp-tests--insert-right (test)
+ (let ((val (list 0 0))
+ (erc-insert-modify-hook '(erc-add-timestamp))
+ (erc-insert-post-hook '(erc-make-read-only)) ; see comment above
+ (erc-timestamp-only-if-changed-flag nil)
+ ;;
+ erc-kill-channel-hook erc-kill-server-hook erc-kill-buffer-hook)
+
+ (advice-add 'erc-format-timestamp :filter-args
+ (lambda (args) (cons (cl-incf (cadr val) 60) (cdr args)))
+ '((name . ert-deftest--erc-timestamp-use-align-to)))
+
+ (with-current-buffer (get-buffer-create "*erc-stamp-tests--insert-right*")
+ (erc-mode)
+ (erc-stamp--manage-local-options-state)
+ (erc--initialize-markers (point) nil)
+ (erc-tests-common-init-server-proc "sleep" "1")
+
+ (funcall test)
+
+ (when noninteractive
+ (kill-buffer)))
+
+ (advice-remove 'erc-format-timestamp
+ 'ert-deftest--erc-timestamp-use-align-to)))
+
+(defun erc-stamp-tests--use-align-to--nil (compat)
+ (erc-stamp-tests--insert-right
+ (lambda ()
+
+ (ert-info ("nil, normal")
+ (let ((erc-timestamp-use-align-to nil))
+ (erc-display-message nil 'notice (current-buffer) "begin"))
+ (goto-char (point-min))
+ (should (search-forward-regexp
+ (rx "begin" (+ "\t") (* " ") "[") nil t))
+ ;; Field includes intervening spaces
+ (should (eql ?n (char-before (field-beginning (point)))))
+ ;; Timestamp extends to the end of the line
+ (should (eql ?\n (char-after (field-end (point))))))
+
+ ;; The option `erc-timestamp-right-column' is normally nil by
+ ;; default, but it's a convenient stand in for a sufficiently
+ ;; small `erc-fill-column' (we can force a line break without
+ ;; involving that module).
+ (should-not erc-timestamp-right-column)
+
+ (ert-info ("nil, overlong (hard wrap)")
+ (let ((erc-timestamp-use-align-to nil)
+ (erc-timestamp-right-column 20))
+ (erc-display-message nil 'notice (current-buffer)
+ "twenty characters"))
+ (should (search-forward-regexp (rx bol (+ "\t") (* " ") "[") nil t))
+ ;; Field includes leading whitespace.
+ (should (eql (if compat ?\[ ?\n)
+ (char-after (field-beginning (point)))))
+ ;; Timestamp extends to the end of the line.
+ (should (eql ?\n (char-after (field-end (point)))))))))
+
+(ert-deftest erc-timestamp-use-align-to--nil ()
+ (ert-info ("Field starts on stamp text (compat)")
+ (let ((erc-stamp--omit-properties-on-folded-lines t))
+ (erc-stamp-tests--use-align-to--nil 'compat)))
+ (ert-info ("Field includes leaidng white space")
+ (erc-stamp-tests--use-align-to--nil nil)))
+
+(defun erc-stamp-tests--use-align-to--t (compat)
+ (erc-stamp-tests--insert-right
+ (lambda ()
+
+ (ert-info ("t, normal")
+ (let ((erc-timestamp-use-align-to t))
+ (let ((msg (erc-format-privmessage "bob" "msg one" nil t)))
+ (erc-display-message nil nil (current-buffer) msg)))
+ (goto-char (point-min))
+ ;; Exactly two spaces, one from format, one added by erc-stamp.
+ (should (search-forward "msg one [" nil t))
+ ;; Field covers space between.
+ (should (eql ?e (char-before (field-beginning (point)))))
+ (should (eql ?\n (char-after (field-end (point))))))
+
+ (ert-info ("t, overlong (hard wrap)")
+ (let ((erc-timestamp-use-align-to t)
+ (erc-timestamp-right-column 20))
+ (let ((msg (erc-format-privmessage "bob" "tttt wwww oooo" nil t)))
+ (erc-display-message nil nil (current-buffer) msg)))
+ ;; Indented to pos (this is arguably a bug).
+ (should (search-forward-regexp (rx bol (+ "\t") (* " ") "[") nil t))
+ ;; Field includes leading space.
+ (should (eql (if compat ?\[ ?\n) (char-after (field-beginning (point)))))
+ (should (eql ?\n (char-after (field-end (point)))))))))
+
+(ert-deftest erc-timestamp-use-align-to--t ()
+ (ert-info ("Field starts on stamp text (compat)")
+ (let ((erc-stamp--omit-properties-on-folded-lines t))
+ (erc-stamp-tests--use-align-to--t 'compat)))
+ (ert-info ("Field includes leaidng white space")
+ (erc-stamp-tests--use-align-to--t nil)))
+
+(ert-deftest erc-timestamp-use-align-to--integer ()
+ (erc-stamp-tests--insert-right
+ (lambda ()
+
+ (ert-info ("integer, normal")
+ (let ((erc-timestamp-use-align-to 1))
+ (let ((msg (erc-format-privmessage "bob" "msg one" nil t)))
+ (erc-display-message nil nil (current-buffer) msg)))
+ (goto-char (point-min))
+ ;; Space not added because included in format string.
+ (should (search-forward "msg one [" nil t))
+ ;; Field covers space between.
+ (should (eql ?e (char-before (field-beginning (point)))))
+ (should (eql ?\n (char-after (field-end (point))))))
+
+ (ert-info ("integer, overlong (hard wrap)")
+ (let ((erc-timestamp-use-align-to 1)
+ (erc-timestamp-right-column 20))
+ (let ((msg (erc-format-privmessage "bob" "tttt wwww oooo" nil t)))
+ (erc-display-message nil nil (current-buffer) msg)))
+ ;; No hard wrap
+ (should (search-forward "oooo [" nil t))
+ ;; Field starts at leading space.
+ (should (eql ?\s (char-after (field-beginning (point)))))
+ (should (eql ?\n (char-after (field-end (point)))))))))
+
+(ert-deftest erc-stamp--display-margin-mode--right ()
+ (erc-stamp-tests--insert-right
+ (lambda ()
+ (erc-stamp--display-margin-mode +1)
+
+ (ert-info ("margin, normal")
+ (let ((erc-timestamp-use-align-to 'margin))
+ (let ((msg (erc-format-privmessage "bob" "msg one" nil t)))
+ (put-text-property 0 (length msg) 'wrap-prefix 10 msg)
+ (erc-display-message nil nil (current-buffer) msg)))
+ (goto-char (point-min))
+ ;; Leading space added as part of the stamp's field.
+ (should (search-forward "msg one [" nil t))
+ ;; Field covers stamp and space.
+ (should (eql ?e (char-before (field-beginning (point)))))
+ ;; Vanity props extended.
+ (should (get-text-property (field-beginning (point)) 'wrap-prefix))
+ (should (get-text-property (1+ (field-beginning (point))) 'wrap-prefix))
+ (should (get-text-property (1- (field-end (point))) 'wrap-prefix))
+ (should (eql ?\n (char-after (field-end (point))))))
+
+ (ert-info ("margin, overlong (hard wrap)")
+ (let ((erc-timestamp-use-align-to 'margin)
+ (erc-timestamp-right-column 20))
+ (let ((msg (erc-format-privmessage "bob" "tttt wwww oooo" nil t)))
+ (erc-display-message nil nil (current-buffer) msg)))
+ ;; No hard wrap.
+ (should (search-forward "oooo [" nil t))
+ ;; Field starts at managed space before format string.
+ (should (eql ?\s (char-after (field-beginning (point)))))
+ (should (eql ?\n (char-after (field-end (point)))))))))
+
+;; This concerns a proposed partial reversal of the changes resulting
+;; from:
+;;
+;; 24.1.50; Wrong behavior of move-end-of-line in ERC (Bug#11706)
+;;
+;; Perhaps core behavior has changed since this bug was reported, but
+;; C-e stopping one char short of EOL no longer seems a problem.
+;; However, invoking C-n (`next-line') exhibits a similar effect.
+;; When point is in a stamp or near the beginning of a line, issuing a
+;; C-n puts point one past the start of the message (i.e., two chars
+;; beyond the timestamp's closing "]". Dropping the invisible
+;; property when timestamps are hidden does indeed prevent this, but
+;; it's also a lasting commitment. The docs mention that it's
+;; pointless to pair the old `intangible' property with `invisible'
+;; and suggest users look at `cursor-intangible-mode'. Turning off
+;; the latter does indeed do the trick as does decrementing the end of
+;; the `cursor-intangible' interval so that, in addition to C-n
+;; working, a C-f from before the timestamp doesn't overshoot. This
+;; appears to be the case whether `erc-hide-timestamps' is enabled or
+;; not, but it may be inadvisable for some reason (a hack) and
+;; therefore warrants further investigation.
+;;
+;; Note some striking omissions here:
+;;
+;; 1. a lack of `fill' module integration (we simulate it by
+;; making lines short enough to not wrap)
+;; 2. functions like `line-move' behave differently when
+;; `noninteractive'
+;; 3. no actual test assertions involving `cursor-sensor' movement
+;; even though that's a huge ingredient
+
+(ert-deftest erc-timestamp-intangible--left ()
+ (let ((erc-timestamp-only-if-changed-flag nil)
+ (erc-timestamp-intangible t) ; default changed to nil in 2014
+ (erc-hide-timestamps t)
+ (erc-insert-timestamp-function 'erc-insert-timestamp-left)
+ (erc-insert-modify-hook '(erc-make-read-only erc-add-timestamp))
+ msg
+ erc-kill-channel-hook erc-kill-server-hook erc-kill-buffer-hook)
+ (should (not cursor-sensor-inhibit))
+
+ (erc-mode)
+ (erc-tests-common-init-server-proc "true")
+ (with-current-buffer (get-buffer-create "*erc-timestamp-intangible*")
+ (erc-mode)
+ (erc--initialize-markers (point) nil)
+ (erc-stamp--manage-local-options-state)
+ (erc-display-message nil 'notice (current-buffer) "Welcome")
+ ;;
+ ;; Pretend `fill' is active and that these lines are
+ ;; folded. Otherwise, there's an annoying issue on wrapped lines
+ ;; (when visual-line-mode is off and stamps are visible) where
+ ;; C-e sends you to the end of the previous line.
+ (setq msg "Lorem ipsum dolor sit amet")
+ (erc-display-message nil nil (current-buffer)
+ (erc-format-privmessage "alyssa" msg nil t))
+ (erc-display-message nil 'notice (current-buffer) "Home")
+ (goto-char (point-min))
+
+ ;; EOL is actually EOL (Bug#11706)
+
+ (ert-info ("Notice before stamp, C-e") ; first line/stamp
+ (should (search-forward "Welcome" nil t))
+ (ert-simulate-command '(erc-bol))
+ (should (looking-at (rx "[")))
+ (let ((end (pos-eol))) ; `line-end-position' fails because fields
+ (ert-simulate-command '(move-end-of-line 1))
+ (should (= end (point)))))
+
+ (ert-info ("Privmsg before stamp, C-e")
+ (should (search-forward "Lorem" nil t))
+ (goto-char (pos-bol))
+ (should (looking-at (rx "[")))
+ (let ((end (pos-eol)))
+ (ert-simulate-command '(move-end-of-line 1))
+ (should (= end (point)))))
+
+ (ert-info ("Privmsg first line, C-e")
+ (goto-char (pos-bol))
+ (should (search-forward "ipsum" nil t))
+ (let ((end (pos-eol)))
+ (ert-simulate-command '(move-end-of-line 1))
+ (should (= end (point)))))
+
+ (when noninteractive
+ (kill-buffer)))))
+
+(ert-deftest erc-echo-timestamp ()
+ :tags (and (null (getenv "CI")) '(:unstable))
+
+ (should-not erc-echo-timestamps)
+ (should-not erc-stamp--last-stamp)
+ (insert (propertize "a" 'erc--ts 433483200 'erc--msg 'msg) "bc")
+ (goto-char (point-min))
+ (let ((inhibit-message t)
+ (erc-echo-timestamp-format "%Y-%m-%d %H:%M:%S %Z")
+ (erc-echo-timestamp-zone (list (* 60 60 -4) "EDT")))
+
+ ;; No-op when non-interactive and option is nil
+ (should-not (erc--echo-ts-csf nil nil 'entered))
+ (should-not erc-stamp--last-stamp)
+
+ ;; Non-interactive (cursor sensor function)
+ (let ((erc-echo-timestamps t))
+ (should (equal (erc--echo-ts-csf nil nil 'entered)
+ "1983-09-27 00:00:00 EDT")))
+ (should (= 433483200 erc-stamp--last-stamp))
+
+ ;; Interactive
+ (should (equal (call-interactively #'erc-echo-timestamp)
+ "1983-09-27 00:00:00 EDT"))
+ ;; Interactive with zone
+ (let ((current-prefix-arg '(4)))
+ (should (member (call-interactively #'erc-echo-timestamp)
+ '("1983-09-27 04:00:00 GMT"
+ "1983-09-27 04:00:00 UTC"))))
+ (let ((current-prefix-arg -7))
+ (should (equal (call-interactively #'erc-echo-timestamp)
+ "1983-09-26 21:00:00 -07")))))
+
+(defun erc-stamp-tests--assert-get-inserted-msg/stamp (test-fn)
+ (let ((erc-insert-modify-hook erc-insert-modify-hook)
+ (erc-insert-timestamp-function 'erc-insert-timestamp-right)
+ (erc-timestamp-use-align-to 0)
+ (erc-timestamp-format "[00:00]"))
+ (cl-pushnew 'erc-add-timestamp erc-insert-modify-hook)
+ (erc-tests-common-get-inserted-msg-setup))
+ (goto-char 19)
+ (should (looking-back (rx "<bob> hi [00:00]")))
+ (erc-tests-common-assert-get-inserted-msg 3 19 test-fn))
+
+(ert-deftest erc--get-inserted-msg-beg/stamp ()
+ (erc-stamp-tests--assert-get-inserted-msg/stamp
+ (lambda (arg) (should (= 3 (erc--get-inserted-msg-beg arg))))))
+
+(ert-deftest erc--get-inserted-msg-beg/readonly/stamp ()
+ (erc-tests-common-assert-get-inserted-msg-readonly-with
+ #'erc-stamp-tests--assert-get-inserted-msg/stamp
+ (lambda (arg) (should (= 3 (erc--get-inserted-msg-beg arg))))))
+
+(ert-deftest erc--get-inserted-msg-end/stamp ()
+ (erc-stamp-tests--assert-get-inserted-msg/stamp
+ (lambda (arg) (should (= 19 (erc--get-inserted-msg-end arg))))))
+
+(ert-deftest erc--get-inserted-msg-end/readonly/stamp ()
+ (erc-tests-common-assert-get-inserted-msg-readonly-with
+ #'erc-stamp-tests--assert-get-inserted-msg/stamp
+ (lambda (arg) (should (= 19 (erc--get-inserted-msg-end arg))))))
+
+(ert-deftest erc--get-inserted-msg-bounds/stamp ()
+ (erc-stamp-tests--assert-get-inserted-msg/stamp
+ (lambda (arg)
+ (should (equal '(3 . 19) (erc--get-inserted-msg-bounds arg))))))
+
+(ert-deftest erc--get-inserted-msg-bounds/readonly/stamp ()
+ (erc-tests-common-assert-get-inserted-msg-readonly-with
+ #'erc-stamp-tests--assert-get-inserted-msg/stamp
+ (lambda (arg)
+ (should (equal '(3 . 19) (erc--get-inserted-msg-bounds arg))))))
+
+;;; erc-stamp-tests.el ends here
diff --git a/test/lisp/erc/erc-tests.el b/test/lisp/erc/erc-tests.el
index 9a72671ad97..3e8ddef3731 100644
--- a/test/lisp/erc/erc-tests.el
+++ b/test/lisp/erc/erc-tests.el
@@ -20,10 +20,13 @@
;; along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>.
;;; Code:
+(require 'erc-ring)
(require 'ert-x)
-(require 'erc)
-(require 'erc-ring)
+(eval-and-compile
+ (let ((load-path (cons (ert-resource-directory) load-path)))
+ (require 'erc-tests-common)))
+
(ert-deftest erc--read-time-period ()
(cl-letf (((symbol-function 'read-string) (lambda (&rest _) "")))
@@ -69,26 +72,25 @@
(with-current-buffer (get-buffer-create "#foo")
(erc-mode)
(setq erc-server-process proc-exnet)
- (setq erc-default-recipients '("#foo")))
+ (setq erc--target (erc--target-from-string "#foo")))
(with-current-buffer (get-buffer-create "#spam")
(erc-mode)
(setq erc-server-process proc-onet)
- (setq erc-default-recipients '("#spam")))
+ (setq erc--target (erc--target-from-string "#spam")))
(with-current-buffer (get-buffer-create "#bar")
(erc-mode)
(setq erc-server-process proc-onet)
- (setq erc-default-recipients '("#bar")))
+ (setq erc--target (erc--target-from-string "#bar")))
(with-current-buffer (get-buffer-create "#baz")
(erc-mode)
(setq erc-server-process proc-exnet)
- (setq erc-default-recipients '("#baz")))
+ (setq erc--target (erc--target-from-string "#baz")))
(should (eq (get-buffer-process "ExampleNet") proc-exnet))
- (erc-with-all-buffers-of-server (get-buffer-process "ExampleNet")
- nil
+ (erc-with-all-buffers-of-server (get-buffer-process "ExampleNet") nil
(kill-buffer))
(should-not (get-buffer "ExampleNet"))
@@ -102,8 +104,7 @@
(calls 0)
(get-test (lambda () (cl-incf calls) test)))
- (erc-with-all-buffers-of-server proc-onet
- (funcall get-test)
+ (erc-with-all-buffers-of-server proc-onet (funcall get-test)
(kill-buffer))
(should (= calls 1)))
@@ -113,36 +114,66 @@
(should (get-buffer "#spam"))
(kill-buffer "#spam")))
-(defun erc-tests--send-prep ()
- ;; Caller should probably shadow `erc-insert-modify-hook' or
- ;; populate user tables for erc-button.
- (erc-mode)
- (insert "\n\n")
- (setq erc-input-marker (make-marker)
- erc-insert-marker (make-marker))
- (set-marker erc-insert-marker (point-max))
- (erc-display-prompt)
- (should (= (point) erc-input-marker)))
-
-(defun erc-tests--set-fake-server-process (&rest args)
- (setq erc-server-process
- (apply #'start-process (car args) (current-buffer) args))
- (set-process-query-on-exit-flag erc-server-process nil))
+(ert-deftest erc-with-server-buffer ()
+ (setq erc-away 1)
+ (erc-tests-common-init-server-proc "sleep" "1")
+
+ (let (mockingp calls)
+ (advice-add 'buffer-local-value :after
+ (lambda (&rest r) (when mockingp (push r calls)))
+ '((name . erc-with-server-buffer)))
+
+ (should (= 1 (prog2 (setq mockingp t)
+ (erc-with-server-buffer erc-away)
+ (setq mockingp nil))))
+
+ (should (equal (pop calls) (list 'erc-away (current-buffer))))
+
+ (should (= 1 (prog2 (setq mockingp t)
+ (erc-with-server-buffer (ignore 'me) erc-away)
+ (setq mockingp nil))))
+ (should-not calls)
+
+ (advice-remove 'buffer-local-value 'erc-with-server-buffer)))
+
+(ert-deftest erc--with-dependent-type-match ()
+ (should (equal (macroexpand-1
+ '(erc--with-dependent-type-match (repeat face) erc-match))
+ '(backquote-list*
+ 'repeat :match (lambda (w v)
+ (require 'erc-match)
+ (widget-editable-list-match w v))
+ '(face)))))
+
+(ert-deftest erc--doarray ()
+ (let ((array "abcdefg")
+ out)
+ ;; No return form.
+ (should-not (erc--doarray (c array) (push c out)))
+ (should (equal out '(?g ?f ?e ?d ?c ?b ?a)))
+
+ ;; Return form evaluated upon completion.
+ (setq out nil)
+ (should (= 42 (erc--doarray (c array (+ 39 (length out)))
+ (when (cl-evenp c) (push c out)))))
+ (should (equal out '(?f ?d ?b)))))
(ert-deftest erc-hide-prompt ()
- (let (erc-kill-channel-hook erc-kill-server-hook erc-kill-buffer-hook)
+ (let ((erc-hide-prompt erc-hide-prompt)
+ ;;
+ erc-kill-channel-hook erc-kill-server-hook erc-kill-buffer-hook)
(with-current-buffer (get-buffer-create "ServNet")
- (erc-tests--send-prep)
+ (erc-tests-common-prep-for-insertion)
(goto-char erc-insert-marker)
(should (looking-at-p (regexp-quote erc-prompt)))
- (erc-tests--set-fake-server-process "sleep" "1")
+ (erc-tests-common-init-server-proc "sleep" "1")
(set-process-sentinel erc-server-process #'ignore)
(setq erc-network 'ServNet)
(set-process-query-on-exit-flag erc-server-process nil))
(with-current-buffer (get-buffer-create "#chan")
- (erc-tests--send-prep)
+ (erc-tests-common-prep-for-insertion)
(goto-char erc-insert-marker)
(should (looking-at-p (regexp-quote erc-prompt)))
(setq erc-server-process (buffer-local-value 'erc-server-process
@@ -150,7 +181,7 @@
erc--target (erc--target-from-string "#chan")))
(with-current-buffer (get-buffer-create "bob")
- (erc-tests--send-prep)
+ (erc-tests-common-prep-for-insertion)
(goto-char erc-insert-marker)
(should (looking-at-p (regexp-quote erc-prompt)))
(setq erc-server-process (buffer-local-value 'erc-server-process
@@ -162,101 +193,292 @@
(with-current-buffer "ServNet"
(should (= (point) erc-insert-marker))
(erc--hide-prompt erc-server-process)
- (should (string= ">" (get-text-property (point) 'display))))
+ (should (string= ">" (get-char-property (point) 'display))))
(with-current-buffer "#chan"
(goto-char erc-insert-marker)
- (should (string= ">" (get-text-property (point) 'display)))
+ (should (string= ">" (get-char-property (point) 'display)))
(should (memq #'erc--unhide-prompt-on-self-insert pre-command-hook))
(goto-char erc-input-marker)
(ert-simulate-command '(self-insert-command 1 ?/))
(goto-char erc-insert-marker)
- (should-not (get-text-property (point) 'display))
+ (should-not (get-char-property (point) 'display))
(should-not (memq #'erc--unhide-prompt-on-self-insert
pre-command-hook)))
(with-current-buffer "bob"
(goto-char erc-insert-marker)
- (should (string= ">" (get-text-property (point) 'display)))
+ (should (string= ">" (get-char-property (point) 'display)))
(should (memq #'erc--unhide-prompt-on-self-insert pre-command-hook))
(goto-char erc-input-marker)
(ert-simulate-command '(self-insert-command 1 ?/))
(goto-char erc-insert-marker)
- (should-not (get-text-property (point) 'display))
+ (should-not (get-char-property (point) 'display))
(should-not (memq #'erc--unhide-prompt-on-self-insert
pre-command-hook)))
(with-current-buffer "ServNet"
- (should (get-text-property erc-insert-marker 'display))
+ (should (get-char-property erc-insert-marker 'display))
(should (memq #'erc--unhide-prompt-on-self-insert pre-command-hook))
(erc--unhide-prompt)
(should-not (memq #'erc--unhide-prompt-on-self-insert
pre-command-hook))
- (should-not (get-text-property erc-insert-marker 'display))))
+ (should-not (get-char-property erc-insert-marker 'display))))
(ert-info ("Value: server")
(setq erc-hide-prompt '(server))
(with-current-buffer "ServNet"
(erc--hide-prompt erc-server-process)
- (should (string= ">" (get-text-property erc-insert-marker 'display))))
+ (should (eq (get-text-property erc-insert-marker 'erc-prompt) 'hidden))
+ (should (string= ">" (get-char-property erc-insert-marker 'display))))
(with-current-buffer "#chan"
- (should-not (get-text-property erc-insert-marker 'display)))
+ (should-not (get-char-property erc-insert-marker 'display)))
(with-current-buffer "bob"
- (should-not (get-text-property erc-insert-marker 'display)))
+ (should-not (get-char-property erc-insert-marker 'display)))
(with-current-buffer "ServNet"
(erc--unhide-prompt)
- (should-not (get-text-property erc-insert-marker 'display))))
+ (should (eq (get-text-property erc-insert-marker 'erc-prompt) t))
+ (should-not (get-char-property erc-insert-marker 'display))))
(ert-info ("Value: channel")
(setq erc-hide-prompt '(channel))
(with-current-buffer "ServNet"
(erc--hide-prompt erc-server-process)
- (should-not (get-text-property erc-insert-marker 'display)))
+ (should-not (get-char-property erc-insert-marker 'display)))
(with-current-buffer "bob"
- (should-not (get-text-property erc-insert-marker 'display)))
+ (should-not (get-char-property erc-insert-marker 'display)))
(with-current-buffer "#chan"
- (should (string= ">" (get-text-property erc-insert-marker 'display)))
+ (should (string= ">" (get-char-property erc-insert-marker 'display)))
+ (should (eq (get-text-property erc-insert-marker 'erc-prompt) 'hidden))
(erc--unhide-prompt)
- (should-not (get-text-property erc-insert-marker 'display))))
+ (should (eq (get-text-property erc-insert-marker 'erc-prompt) t))
+ (should-not (get-char-property erc-insert-marker 'display))))
(ert-info ("Value: query")
(setq erc-hide-prompt '(query))
(with-current-buffer "ServNet"
(erc--hide-prompt erc-server-process)
- (should-not (get-text-property erc-insert-marker 'display)))
+ (should-not (get-char-property erc-insert-marker 'display)))
(with-current-buffer "bob"
- (should (string= ">" (get-text-property erc-insert-marker 'display)))
+ (should (string= ">" (get-char-property erc-insert-marker 'display)))
+ (should (eq (get-text-property erc-insert-marker 'erc-prompt) 'hidden))
(erc--unhide-prompt)
- (should-not (get-text-property erc-insert-marker 'display)))
+ (should (eq (get-text-property erc-insert-marker 'erc-prompt) t))
+ (should-not (get-char-property erc-insert-marker 'display)))
(with-current-buffer "#chan"
- (should-not (get-text-property erc-insert-marker 'display))))
+ (should-not (get-char-property erc-insert-marker 'display))))
(ert-info ("Value: nil")
(setq erc-hide-prompt nil)
(with-current-buffer "ServNet"
(erc--hide-prompt erc-server-process)
- (should-not (get-text-property erc-insert-marker 'display)))
+ (should-not (get-char-property erc-insert-marker 'display)))
(with-current-buffer "bob"
- (should-not (get-text-property erc-insert-marker 'display)))
+ (should-not (get-char-property erc-insert-marker 'display)))
(with-current-buffer "#chan"
- (should-not (get-text-property erc-insert-marker 'display))
+ (should-not (get-char-property erc-insert-marker 'display))
(erc--unhide-prompt) ; won't blow up when prompt already showing
- (should-not (get-text-property erc-insert-marker 'display))))
+ (should-not (get-char-property erc-insert-marker 'display))))
(when noninteractive
(kill-buffer "#chan")
(kill-buffer "bob")
(kill-buffer "ServNet"))))
+(ert-deftest erc--refresh-prompt ()
+ (let* ((counter 0)
+ (erc-prompt (lambda ()
+ (format "%s %d>"
+ (erc-format-target-and/or-network)
+ (cl-incf counter))))
+ erc-accidental-paste-threshold-seconds
+ erc-insert-modify-hook
+ (erc-last-input-time 0)
+ (erc-modules (remq 'stamp erc-modules))
+ (erc-send-input-line-function #'ignore)
+ (erc--input-review-functions erc--input-review-functions)
+ erc-send-completed-hook)
+
+ (ert-info ("Server buffer")
+ (with-current-buffer (get-buffer-create "ServNet")
+ (erc-tests-common-prep-for-insertion)
+ (goto-char erc-insert-marker)
+ (should (looking-at-p "ServNet 3>"))
+ (erc-tests-common-init-server-proc "sleep" "1")
+ (set-process-sentinel erc-server-process #'ignore)
+ (setq erc-network 'ServNet
+ erc-server-current-nick "tester"
+ erc-networks--id (erc-networks--id-create nil)
+ erc-server-users (make-hash-table :test 'equal))
+ (set-process-query-on-exit-flag erc-server-process nil)
+ ;; Incoming message redraws prompt
+ (erc-display-message nil 'notice nil "Welcome")
+ (should (looking-at-p (rx "*** Welcome")))
+ (forward-line)
+ (should (looking-at-p "ServNet 4>"))
+ ;; Say something
+ (goto-char erc-input-marker)
+ (insert "Howdy")
+ (erc-send-current-line)
+ (save-excursion (forward-line -1)
+ (should (looking-at (rx "*** No target")))
+ (forward-line -1)
+ (should (looking-at "<tester> Howdy")))
+ (should (looking-back "ServNet 6> "))
+ (should (= erc-input-marker (point)))
+ ;; Space after prompt is unpropertized
+ (should (get-text-property (1- erc-input-marker) 'erc-prompt))
+ (should-not (get-text-property erc-input-marker 'erc-prompt))
+ ;; No sign of old prompts
+ (save-excursion
+ (goto-char (point-min))
+ (should-not (search-forward (rx (any "3-5") ">") nil t)))))
+
+ (ert-info ("Channel buffer")
+ (with-current-buffer (get-buffer-create "#chan")
+ (erc-tests-common-prep-for-insertion)
+ (goto-char erc-insert-marker)
+ (should (looking-at-p "#chan 9>"))
+ (goto-char erc-input-marker)
+ (setq erc-server-process (buffer-local-value 'erc-server-process
+ (get-buffer "ServNet"))
+ erc-networks--id (erc-with-server-buffer erc-networks--id)
+ erc--target (erc--target-from-string "#chan")
+ erc-default-recipients (list "#chan")
+ erc-channel-users (make-hash-table :test 'equal))
+ (erc-update-current-channel-member "alice" "alice")
+ (erc-update-current-channel-member "bob" "bob")
+ (erc-update-current-channel-member "tester" "tester")
+ (erc-display-message nil nil (current-buffer)
+ (erc-format-privmessage "alice" "Hi" nil t))
+ (should (looking-back "#chan@ServNet 10> "))
+ (goto-char erc-input-marker)
+ (insert "Howdy")
+ (erc-send-current-line)
+ (save-excursion (forward-line -1)
+ (should (looking-at "<tester> Howdy")))
+ (should (looking-back "#chan@ServNet 11> "))
+ (should (= (point) erc-input-marker))
+ (insert "/query bob")
+ (let (erc-modules)
+ (erc-send-current-line))
+ ;; Last command not inserted
+ (save-excursion (forward-line -1)
+ (should (looking-at "<tester> Howdy")))
+ ;; Query does not redraw (nor /help, only message input)
+ (should (looking-back "#chan@ServNet 11> "))
+ ;; No sign of old prompts
+ (save-excursion
+ (goto-char (point-min))
+ (should-not (search-forward (rx (or "9" "10") ">") nil t)))))
+
+ (ert-info ("Query buffer")
+ (with-current-buffer "bob"
+ (goto-char erc-insert-marker)
+ (should (looking-at-p "bob@ServNet 14>"))
+ (goto-char erc-input-marker)
+ (erc-display-message nil nil (current-buffer)
+ (erc-format-privmessage "bob" "Hi" nil t))
+ (should (looking-back "bob@ServNet 15> "))
+ (goto-char erc-input-marker)
+ (insert "Howdy")
+ (erc-send-current-line)
+ (save-excursion (forward-line -1)
+ (should (looking-at "<tester> Howdy")))
+ (should (looking-back "bob@ServNet 16> "))
+ ;; No sign of old prompts
+ (save-excursion
+ (goto-char (point-min))
+ (should-not (search-forward (rx (or "14" "15") ">") nil t)))))
+
+ (when noninteractive
+ (kill-buffer "#chan")
+ (kill-buffer "bob")
+ (kill-buffer "ServNet"))))
+
+(ert-deftest erc--initialize-markers ()
+ (let ((proc (start-process "true" (current-buffer) "true"))
+ erc-modules
+ erc-connect-pre-hook
+ erc-insert-modify-hook
+ erc-kill-channel-hook erc-kill-server-hook erc-kill-buffer-hook)
+ (set-process-query-on-exit-flag proc nil)
+ (erc-mode)
+ (setq erc-server-process proc
+ erc-networks--id (erc-networks--id-create 'foonet))
+ (erc-open "localhost" 6667 "tester" "Tester" nil
+ "fake" nil "#chan" proc nil "user" nil)
+ (with-current-buffer (should (get-buffer "#chan"))
+ (should (= ?\n (char-after 1)))
+ (should (= ?E (char-after erc-insert-marker)))
+ (should (= 3 (marker-position erc-insert-marker)))
+ (should (= 8 (marker-position erc-input-marker)))
+ (should (= 8 (point-max)))
+ (should (= 8 (point)))
+ ;; These prompt properties are a continual source of confusion.
+ ;; Including the literal defaults here can hopefully serve as a
+ ;; quick reference for anyone operating in that area.
+ (should (equal (buffer-string)
+ #("\n\nERC> "
+ 2 6 ( font-lock-face erc-prompt-face
+ rear-nonsticky t
+ erc-prompt t
+ field erc-prompt
+ front-sticky t
+ read-only t)
+ 6 7 ( rear-nonsticky t
+ erc-prompt t
+ field erc-prompt
+ front-sticky t
+ read-only t))))
+
+ ;; Simulate some activity by inserting some text before and
+ ;; after the prompt (multiline).
+ (erc-display-error-notice nil "Welcome")
+ (goto-char (point-max))
+ (insert "Hello\nWorld")
+ (goto-char 3)
+ (should (looking-at-p (regexp-quote "*** Welcome"))))
+
+ (ert-info ("Reconnect")
+ (with-current-buffer (erc-server-buffer)
+ (erc-open "localhost" 6667 "tester" "Tester" nil
+ "fake" nil "#chan" proc nil "user" nil))
+ (should-not (get-buffer "#chan<2>")))
+
+ (ert-info ("Existing prompt respected")
+ (with-current-buffer (should (get-buffer "#chan"))
+ (should (= ?\n (char-after 1)))
+ (should (= ?E (char-after erc-insert-marker)))
+ (should (= 15 (marker-position erc-insert-marker)))
+ (should (= 20 (marker-position erc-input-marker)))
+ (should (= 3 (point))) ; point restored
+ (should (equal (buffer-string)
+ #("\n\n*** Welcome\nERC> Hello\nWorld"
+ 2 13 (font-lock-face erc-error-face)
+ 14 18 ( font-lock-face erc-prompt-face
+ rear-nonsticky t
+ erc-prompt t
+ field erc-prompt
+ front-sticky t
+ read-only t)
+ 18 19 ( rear-nonsticky t
+ erc-prompt t
+ field erc-prompt
+ front-sticky t
+ read-only t))))
+ (when noninteractive
+ (kill-buffer))))))
+
(ert-deftest erc--switch-to-buffer ()
(defvar erc-modified-channels-alist) ; lisp/erc/erc-track.el
@@ -314,6 +536,80 @@
(dolist (b '("server" "other" "#chan" "#foo" "#fake"))
(kill-buffer b))))
+(ert-deftest erc-setup-buffer--custom-action ()
+ (erc-mode)
+ (erc-tests-common-init-server-proc "sleep" "1")
+ (setq erc--server-last-reconnect-count 0)
+ (let ((owin (selected-window))
+ (obuf (window-buffer))
+ (mbuf (messages-buffer))
+ calls)
+ (cl-letf (((symbol-function 'switch-to-buffer) ; regression
+ (lambda (&rest r) (push (cons 'switch-to-buffer r) calls)))
+ ((symbol-function 'erc--test-fun)
+ (lambda (&rest r) (push (cons 'erc--test-fun r) calls)))
+ ((symbol-function 'display-buffer)
+ (lambda (&rest r) (push (cons 'display-buffer r) calls))))
+
+ ;; Baseline
+ (let ((erc-join-buffer 'bury))
+ (erc-setup-buffer mbuf)
+ (should-not calls))
+
+ (should-not erc--display-context)
+
+ ;; `display-buffer'
+ (let ((erc--display-context '((erc-buffer-display . 1)))
+ (erc-join-buffer 'erc--test-fun))
+ (erc-setup-buffer mbuf)
+ (should (equal `(erc--test-fun ,mbuf (nil (erc-buffer-display . 1)))
+ (pop calls)))
+ (should-not calls))
+
+ ;; `pop-to-buffer' with `erc-auto-reconnect-display'
+ (let* ((erc--server-last-reconnect-count 1)
+ (erc--display-context '((erc-buffer-display . 1)))
+ (erc-auto-reconnect-display 'erc--test-fun))
+ (erc-setup-buffer mbuf)
+ (should (equal `(erc--test-fun ,mbuf
+ (nil (erc-auto-reconnect-display . t)
+ (erc-buffer-display . 1)))
+ (pop calls)))
+ (should-not calls)))
+
+ ;; Mimic simplistic version of example in "(erc) display-buffer".
+ (when (>= emacs-major-version 29)
+ (let ((proc erc-server-process))
+ (with-temp-buffer
+ (should-not (eq (window-buffer) (current-buffer)))
+ (erc-mode)
+ (setq erc-server-process proc)
+
+ (cl-letf (((symbol-function 'erc--test-fun-p)
+ (lambda (buf action)
+ (should (eql 1 (alist-get 'erc-buffer-display action)))
+ (push (cons 'erc--test-fun-p buf) calls)))
+ ((symbol-function 'action-fn)
+ (lambda (buf action)
+ (should (eql 1 (alist-get 'erc-buffer-display action)))
+ (should (eql 42 (alist-get 'foo action)))
+ (push (cons 'action-fn buf) calls)
+ (selected-window))))
+
+ (let ((erc--display-context '((erc-buffer-display . 1)))
+ (display-buffer-alist
+ `(((and (major-mode . erc-mode) erc--test-fun-p)
+ action-fn (foo . 42))))
+ (erc-buffer-display 'display-buffer))
+
+ (erc-setup-buffer (current-buffer))
+ (should (equal 'action-fn (car (pop calls))))
+ (should (equal 'erc--test-fun-p (car (pop calls))))
+ (should-not calls))))))
+
+ (should (eq owin (selected-window)))
+ (should (eq obuf (window-buffer)))))
+
(ert-deftest erc-lurker-maybe-trim ()
(let (erc-lurker-trim-nicks
(erc-lurker-ignore-chars "_`"))
@@ -327,6 +623,418 @@
(setq erc-lurker-ignore-chars "_-`") ; set of chars, not character alts
(should (string= "nick" (erc-lurker-maybe-trim "nick-_`")))))
+(ert-deftest erc-parse-user ()
+ (should (equal '("" "" "") (erc-parse-user "!@")))
+ (should (equal '("" "!" "") (erc-parse-user "!!@")))
+ (should (equal '("" "" "@") (erc-parse-user "!@@")))
+ (should (equal '("" "!" "@") (erc-parse-user "!!@@")))
+
+ (should (equal '("abc" "" "") (erc-parse-user "abc")))
+ (should (equal '("" "123" "fake") (erc-parse-user "!123@fake")))
+ (should (equal '("abc" "" "123") (erc-parse-user "abc!123")))
+
+ (should (equal '("abc" "123" "fake") (erc-parse-user "abc!123@fake")))
+ (should (equal '("abc" "!123" "@xy") (erc-parse-user "abc!!123@@xy")))
+
+ (should (equal '("de" "fg" "xy") (erc-parse-user "abc\nde!fg@xy"))))
+
+(ert-deftest erc--parse-nuh ()
+ (should (equal '(nil nil nil) (erc--parse-nuh "!@")))
+ (should (equal '(nil nil nil) (erc--parse-nuh "@")))
+ (should (equal '(nil nil nil) (erc--parse-nuh "!")))
+ (should (equal '(nil "!" nil) (erc--parse-nuh "!!@")))
+ (should (equal '(nil "@" nil) (erc--parse-nuh "!@@")))
+ (should (equal '(nil "!@" nil) (erc--parse-nuh "!!@@")))
+
+ (should (equal '("abc" nil nil) (erc--parse-nuh "abc!")))
+ (should (equal '(nil "abc" nil) (erc--parse-nuh "abc@")))
+ (should (equal '(nil "abc" nil) (erc--parse-nuh "!abc@")))
+
+ (should (equal '("abc" "123" "fake") (erc--parse-nuh "abc!123@fake")))
+ (should (equal '("abc" "!123@" "xy") (erc--parse-nuh "abc!!123@@xy")))
+
+ ;; Missing leading components.
+ (should (equal '(nil "abc" "123") (erc--parse-nuh "abc@123")))
+ (should (equal '(nil "123" "fake") (erc--parse-nuh "!123@fake")))
+ (should (equal '(nil nil "gnu.org") (erc--parse-nuh "@gnu.org")))
+
+ ;; Host "wins" over nick and user (sans "@").
+ (should (equal '(nil nil "abc") (erc--parse-nuh "abc")))
+ (should (equal '(nil nil "gnu.org") (erc--parse-nuh "gnu.org")))
+ (should (equal '(nil nil "gnu.org") (erc--parse-nuh "!gnu.org")))
+ (should (equal '("abc" nil "123") (erc--parse-nuh "abc!123")))
+
+ ;; No fallback behavior.
+ (should-not (erc--parse-nuh "abc\nde!fg@xy")))
+
+(ert-deftest erc--parsed-prefix ()
+ (erc-tests-common-make-server-buf (buffer-name))
+
+ ;; Uses fallback values when no PREFIX parameter yet received, thus
+ ;; ensuring caller can use slot accessors immediately instead of
+ ;; checking if null beforehand.
+ (should-not erc--parsed-prefix)
+ (should (equal (erc--parsed-prefix)
+ #s(erc--parsed-prefix nil "vhoaq" "+%@&~"
+ ((?q . ?~) (?a . ?&)
+ (?o . ?@) (?h . ?%) (?v . ?+)))))
+ (let ((cached (should erc--parsed-prefix)))
+ (should (eq (erc--parsed-prefix) cached)))
+
+ ;; Cache broken. (Notice not setting `erc--parsed-prefix' to nil).
+ (setq erc-server-parameters '(("PREFIX" . "(ov)@+")))
+
+ (let ((proc erc-server-process)
+ (expected '((?o . ?@) (?v . ?+)))
+ cached)
+
+ (with-temp-buffer
+ (erc-mode)
+ (setq erc-server-process proc)
+ (should (equal expected
+ (erc--parsed-prefix-alist (erc--parsed-prefix)))))
+
+ (should (equal expected (erc--parsed-prefix-alist erc--parsed-prefix)))
+ (setq cached erc--parsed-prefix)
+ (should (equal cached
+ #s(erc--parsed-prefix ("(ov)@+") "vo" "+@"
+ ((?o . ?@) (?v . ?+)))))
+ ;; Second target buffer reuses cached value.
+ (with-temp-buffer
+ (erc-mode)
+ (setq erc-server-process proc)
+ (should (eq cached (erc--parsed-prefix))))
+
+ ;; New value computed when cache broken.
+ (puthash 'PREFIX (list "(qh)~%") erc--isupport-params)
+ (with-temp-buffer
+ (erc-mode)
+ (setq erc-server-process proc)
+ (should-not (eq cached (erc--parsed-prefix)))
+ (should (equal (erc--parsed-prefix-alist
+ (erc-with-server-buffer erc--parsed-prefix))
+ '((?q . ?~) (?h . ?%)))))))
+
+(ert-deftest erc--get-prefix-flag ()
+ (erc-tests-common-make-server-buf (buffer-name))
+ (should-not erc--parsed-prefix)
+ (should (= (erc--get-prefix-flag ?v) 1))
+ (should (= (erc--get-prefix-flag ?h) 2))
+ (should (= (erc--get-prefix-flag ?o) 4))
+ (should (= (erc--get-prefix-flag ?a) 8))
+ (should (= (erc--get-prefix-flag ?q) 16))
+
+ (ert-info ("With optional `from-prefix-p'")
+ (should (= (erc--get-prefix-flag ?+ nil 'fpp) 1))
+ (should (= (erc--get-prefix-flag ?% nil 'fpp) 2))
+ (should (= (erc--get-prefix-flag ?@ nil 'fpp) 4))
+ (should (= (erc--get-prefix-flag ?& nil 'fpp) 8))
+ (should (= (erc--get-prefix-flag ?~ nil 'fpp) 16)))
+ (should erc--parsed-prefix))
+
+(ert-deftest erc--init-cusr-fallback-status ()
+ ;; Fallback behavior active because no `erc--parsed-prefix'.
+ (should-not erc--parsed-prefix)
+ (should (= 0 (erc--init-cusr-fallback-status nil nil nil nil nil)))
+ (should (= 1 (erc--init-cusr-fallback-status t nil nil nil nil)))
+ (should (= 4 (erc--init-cusr-fallback-status nil nil t nil nil)))
+ (should-not erc--parsed-prefix) ; not created in non-ERC buffer.
+
+ ;; Uses advertised server parameter.
+ (erc-tests-common-make-server-buf (buffer-name))
+ (setq erc-server-parameters '(("PREFIX" . "(YqaohvV)!~&@%+-")))
+ (should (= 0 (erc--init-cusr-fallback-status nil nil nil nil nil)))
+ (should (= 2 (erc--init-cusr-fallback-status t nil nil nil nil)))
+ (should (= 8 (erc--init-cusr-fallback-status nil nil t nil nil)))
+ (should erc--parsed-prefix))
+
+(ert-deftest erc--compute-cusr-fallback-status ()
+ ;; Useless without an `erc--parsed-prefix'.
+ (should (= 0 (erc--compute-cusr-fallback-status 0 nil nil nil nil nil)))
+ (should (= 0 (erc--compute-cusr-fallback-status 0 'on 'on 'on 'on 'on)))
+
+ (erc-tests-common-make-server-buf (buffer-name))
+ (should (= 0 (erc--compute-cusr-fallback-status 0 nil nil nil nil nil)))
+ (should (= 1 (erc--compute-cusr-fallback-status 0 'on nil nil nil nil)))
+ (should (= 1 (erc--compute-cusr-fallback-status 0 'on 'off 'off 'off 'off)))
+ (should (= 1 (erc--compute-cusr-fallback-status 1 'on 'off 'off 'off 'off)))
+ (should (= 1 (erc--compute-cusr-fallback-status 1 nil nil nil nil nil)))
+ (should (= 1 (erc--compute-cusr-fallback-status 3 nil 'off nil nil nil)))
+ (should (= 1 (erc--compute-cusr-fallback-status 7 nil 'off 'off nil nil)))
+ (should (= 4 (erc--compute-cusr-fallback-status 1 'off nil 'on nil nil))))
+
+(ert-deftest erc--cusr-status-p ()
+ (erc-tests-common-make-server-buf (buffer-name))
+ (should-not erc--parsed-prefix)
+ (let ((cusr (make-erc-channel-user :voice t :op t)))
+ (should-not (erc--cusr-status-p cusr ?q))
+ (should-not (erc--cusr-status-p cusr ?a))
+ (should-not (erc--cusr-status-p cusr ?h))
+ (should (erc--cusr-status-p cusr ?o))
+ (should (erc--cusr-status-p cusr ?v)))
+ (should erc--parsed-prefix))
+
+(ert-deftest erc--cusr-change-status ()
+ (erc-tests-common-make-server-buf (buffer-name))
+ (let ((cusr (make-erc-channel-user)))
+ (should-not (erc--cusr-status-p cusr ?o))
+ (should-not (erc--cusr-status-p cusr ?v))
+ (erc--cusr-change-status cusr ?o t)
+ (erc--cusr-change-status cusr ?v t)
+ (should (erc--cusr-status-p cusr ?o))
+ (should (erc--cusr-status-p cusr ?v))
+
+ (ert-info ("Reset with optional param")
+ (erc--cusr-change-status cusr ?q t 'reset)
+ (should-not (erc--cusr-status-p cusr ?o))
+ (should-not (erc--cusr-status-p cusr ?v))
+ (should (erc--cusr-status-p cusr ?q)))
+
+ (ert-info ("Clear with optional param")
+ (erc--cusr-change-status cusr ?v t)
+ (should (erc--cusr-status-p cusr ?v))
+ (erc--cusr-change-status cusr ?q nil 'reset)
+ (should-not (erc--cusr-status-p cusr ?v))
+ (should-not (erc--cusr-status-p cusr ?q)))))
+
+;; This exists as a reference to assert legacy behavior in order to
+;; preserve and incorporate it as a fallback in the 5.6+ replacement.
+(ert-deftest erc-parse-modes ()
+ (with-suppressed-warnings ((obsolete erc-parse-modes))
+ (should (equal (erc-parse-modes "+u") '(("u") nil nil)))
+ (should (equal (erc-parse-modes "-u") '(nil ("u") nil)))
+ (should (equal (erc-parse-modes "+o bob") '(nil nil (("o" on "bob")))))
+ (should (equal (erc-parse-modes "-o bob") '(nil nil (("o" off "bob")))))
+ (should (equal (erc-parse-modes "+uo bob") '(("u") nil (("o" on "bob")))))
+ (should (equal (erc-parse-modes "+o-u bob") '(nil ("u") (("o" on "bob")))))
+ (should (equal (erc-parse-modes "+uo-tv bob alice")
+ '(("u") ("t") (("o" on "bob") ("v" off "alice")))))
+
+ (ert-info ("Modes of type B are always grouped as unary")
+ (should (equal (erc-parse-modes "+k h2") '(nil nil (("k" on "h2")))))
+ ;; Channel key args are thrown away.
+ (should (equal (erc-parse-modes "-k *") '(nil nil (("k" off nil))))))
+
+ (ert-info ("Modes of type C are grouped as unary even when disabling")
+ (should (equal (erc-parse-modes "+l 3") '(nil nil (("l" on "3")))))
+ (should (equal (erc-parse-modes "-l") '(nil nil (("l" off nil))))))))
+
+(ert-deftest erc--update-channel-modes ()
+ (erc-tests-common-make-server-buf)
+ (setq erc-channel-users (make-hash-table :test #'equal)
+ erc--target (erc--target-from-string "#test"))
+
+ (let ((orig-handle-fn (symbol-function 'erc--handle-channel-mode))
+ calls)
+ (cl-letf (((symbol-function 'erc--handle-channel-mode)
+ (lambda (&rest r) (push r calls) (apply orig-handle-fn r)))
+ ((symbol-function 'erc-update-mode-line) #'ignore))
+
+ (ert-info ("Unknown user not created")
+ (erc--update-channel-modes "+o" "bob")
+ (should-not (erc-get-channel-user "bob")))
+
+ (ert-info ("Status updated when user known")
+ (puthash "bob" (cons (erc-add-server-user
+ "bob" (make-erc-server-user
+ :nickname "bob"
+ :buffers (list (current-buffer))))
+ (make-erc-channel-user))
+ erc-channel-users)
+ ;; Also asserts fallback behavior for traditional prefixes.
+ (should-not (erc-channel-user-op-p "bob"))
+ (erc--update-channel-modes "+o" "bob")
+ (should (erc-channel-user-op-p "bob"))
+ (erc--update-channel-modes "-o" "bob") ; status revoked
+ (should-not (erc-channel-user-op-p "bob")))
+
+ (ert-info ("Unknown nullary added and removed")
+ (should-not erc--channel-modes)
+ (should-not erc-channel-modes)
+ (erc--update-channel-modes "+u")
+ (should (equal erc-channel-modes '("u")))
+ (should (eq t (gethash ?u erc--channel-modes)))
+ (should (equal (pop calls) '(?d ?u t nil)))
+ (erc--update-channel-modes "-u")
+ (should (equal (pop calls) '(?d ?u nil nil)))
+ (should-not (gethash ?u erc--channel-modes))
+ (should-not erc-channel-modes)
+ (should-not calls))
+
+ (ert-info ("Fallback for Type B includes mode letter k")
+ (erc--update-channel-modes "+k" "h2")
+ (should (equal (pop calls) '(?b ?k t "h2")))
+ (should-not erc-channel-modes)
+ (should (equal "h2" (gethash ?k erc--channel-modes)))
+ (erc--update-channel-modes "-k" "*")
+ (should (equal (pop calls) '(?b ?k nil "*")))
+ (should-not calls)
+ (should-not (gethash ?k erc--channel-modes))
+ (should-not erc-channel-modes))
+
+ (ert-info ("Fallback for Type C includes mode letter l")
+ (erc--update-channel-modes "+l" "3")
+ (should (equal (pop calls) '(?c ?l t "3")))
+ (should-not erc-channel-modes)
+ (should (equal "3" (gethash ?l erc--channel-modes)))
+ (erc--update-channel-modes "-l" nil)
+ (should (equal (pop calls) '(?c ?l nil nil)))
+ (should-not (gethash ?l erc--channel-modes))
+ (should-not erc-channel-modes))
+
+ (ert-info ("Advertised supersedes heuristics")
+ (setq erc-server-parameters
+ '(("PREFIX" . "(ov)@+")
+ ;; Add phony 5th type for this CHANMODES value for
+ ;; robustness in case some server gets creative.
+ ("CHANMODES" . "eIbq,k,flj,CFLMPQRSTcgimnprstuz,FAKE")))
+ (erc--update-channel-modes "+qu" "fool!*@*")
+ (should (equal (pop calls) '(?d ?u t nil)))
+ (should (equal (pop calls) '(?a ?q t "fool!*@*")))
+ (should (equal 1 (gethash ?q erc--channel-modes)))
+ (should (eq t (gethash ?u erc--channel-modes)))
+ (should (equal erc-channel-modes '("u")))
+ (should-not (erc-channel-user-owner-p "bob"))
+
+ ;; Remove fool!*@* from list mode "q".
+ (erc--update-channel-modes "-uq" "fool!*@*")
+ (should (equal (pop calls) '(?a ?q nil "fool!*@*")))
+ (should (equal (pop calls) '(?d ?u nil nil)))
+ (should-not (gethash ?u erc--channel-modes))
+ (should-not erc-channel-modes)
+ (should (equal 0 (gethash ?q erc--channel-modes))))
+
+ (should-not calls))))
+
+(ert-deftest erc--channel-modes ()
+ :tags (and (null (getenv "CI")) '(:unstable))
+
+ (setq erc--isupport-params (make-hash-table)
+ erc--target (erc--target-from-string "#test")
+ erc-server-parameters
+ '(("CHANMODES" . "eIbq,k,flj,CFLMPQRSTcgimnprstuz")))
+
+ (erc-tests-common-init-server-proc "sleep" "1")
+
+ (cl-letf (((symbol-function 'erc-update-mode-line) #'ignore))
+ (erc--update-channel-modes "+bltk" "fool!*@*" "3" "h2"))
+
+ (should (equal (erc--channel-modes 'string) "klt"))
+ (should (equal (erc--channel-modes 'strings) '("k" "l" "t")))
+ (should (equal (erc--channel-modes) '((?k . "h2") (?l . "3") (?t))))
+ (should (equal (erc--channel-modes 3 ",") "klt h2,3"))
+
+ ;; The function this tests behaves differently in different
+ ;; environments. For example, on one GNU Linux system, it returns
+ ;; truncation ellipsis when run interactively. Rather than have
+ ;; hard-to-read "nondeterministic" comparisons against sets of
+ ;; acceptable values, we use separate tests.
+ (when (char-displayable-p ?…) (ert-pass))
+
+ ;; Truncation cache populated and used.
+ (let ((cache (erc--channel-mode-types-shortargs erc--channel-mode-types))
+ first-run)
+ (should (zerop (hash-table-count cache)))
+ (should (equal (erc--channel-modes 1 ",") "klt h,3"))
+ (should (equal (setq first-run (map-pairs cache)) '(((1 ?k "h2") . "h"))))
+
+ ;; Second call uses cache.
+ (cl-letf (((symbol-function 'truncate-string-to-width)
+ (lambda (&rest _) (ert-fail "Shouldn't run"))))
+ (should (equal (erc--channel-modes 1 ",") "klt h,3")))
+
+ ;; Same key for only entry matches that of first result.
+ (should (pcase (map-pairs cache)
+ ((and '(((1 ?k "h2") . "h")) second-run)
+ (eq (pcase first-run (`((,k . ,_)) k))
+ (pcase second-run (`((,k . ,_)) k)))))))
+
+ (should (equal (erc--channel-modes 0 ",") "klt ,"))
+ (should (equal (erc--channel-modes 2) "klt h2 3"))
+ (should (equal (erc--channel-modes 1) "klt h 3"))
+ (should (equal (erc--channel-modes 0) "klt "))) ; 2 spaces
+
+(ert-deftest erc--channel-modes/graphic-p ()
+ :tags `(:unstable ,@(and (getenv "ERC_TESTS_GRAPHICAL")
+ '(:erc--graphical)))
+ (unless (char-displayable-p ?…) (ert-skip "See non-/graphic-p variant"))
+
+ (erc-tests-common-init-server-proc "sleep" "1")
+ (setq erc--isupport-params (make-hash-table)
+ erc--target (erc--target-from-string "#test")
+ erc-server-parameters
+ '(("CHANMODES" . "eIbq,k,flj,CFLMPQRSTcgimnprstuz")))
+
+ (cl-letf (((symbol-function 'erc-update-mode-line) #'ignore))
+ (erc--update-channel-modes "+bltk" "fool!*@*" "3" "hun2"))
+
+ ;; Truncation cache populated and used.
+ (let ((cache (erc--channel-mode-types-shortargs erc--channel-mode-types))
+ first-run)
+ (should (zerop (hash-table-count cache)))
+ (should (equal (erc--channel-modes 2 ",") "klt h…,3" ))
+ (should (equal (setq first-run (map-pairs cache))
+ '(((2 ?k "hun2") . "h…"))))
+
+ ;; Second call uses cache.
+ (cl-letf (((symbol-function 'truncate-string-to-width)
+ (lambda (&rest _) (ert-fail "Shouldn't run"))))
+ (should (equal (erc--channel-modes 2 ",") "klt h…,3" )))
+
+ ;; Same key for only entry matches that of first result.
+ (should (pcase (map-pairs cache)
+ ((and `(((2 ?k "hun2") . "h…")) second-run)
+ (eq (pcase first-run (`((,k . ,_)) k))
+ (pcase second-run (`((,k . ,_)) k)))))))
+
+ ;; A max length of 0 is nonsensical anyway, so skip those.
+ (should (equal (erc--channel-modes 3) "klt hu… 3"))
+ (should (equal (erc--channel-modes 2) "klt h… 3"))
+ (should (equal (erc--channel-modes 1) "klt … 3")))
+
+(ert-deftest erc--update-user-modes ()
+ (let ((erc--user-modes (list ?a)))
+ (should (equal (erc--update-user-modes "+a") '(?a)))
+ (should (equal (erc--update-user-modes "-b") '(?a)))
+ (should (equal erc--user-modes '(?a))))
+
+ (let ((erc--user-modes (list ?b)))
+ (should (equal (erc--update-user-modes "+ac") '(?a ?b ?c)))
+ (should (equal (erc--update-user-modes "+a-bc") '(?a)))
+ (should (equal erc--user-modes '(?a)))))
+
+(ert-deftest erc--user-modes ()
+ (let ((erc--user-modes '(?a ?b)))
+ (should (equal (erc--user-modes) '(?a ?b)))
+ (should (equal (erc--user-modes 'string) "ab"))
+ (should (equal (erc--user-modes 'strings) '("a" "b")))))
+
+(ert-deftest erc--parse-user-modes ()
+ (should (equal (erc--parse-user-modes "a" '(?a)) '(() ())))
+ (should (equal (erc--parse-user-modes "+a" '(?a)) '(() ())))
+ (should (equal (erc--parse-user-modes "a" '()) '((?a) ())))
+ (should (equal (erc--parse-user-modes "+a" '()) '((?a) ())))
+ (should (equal (erc--parse-user-modes "-a" '()) '(() ())))
+ (should (equal (erc--parse-user-modes "-a" '(?a)) '(() (?a))))
+
+ (should (equal (erc--parse-user-modes "+a-b" '(?a)) '(() ())))
+ (should (equal (erc--parse-user-modes "+a-b" '(?b)) '((?a) (?b))))
+ (should (equal (erc--parse-user-modes "+ab-c" '(?b)) '((?a) ())))
+ (should (equal (erc--parse-user-modes "+ab-c" '(?b ?c)) '((?a) (?c))))
+ (should (equal (erc--parse-user-modes "+a-c+b" '(?b ?c)) '((?a) (?c))))
+ (should (equal (erc--parse-user-modes "-c+ab" '(?b ?c)) '((?a) (?c))))
+
+ ;; Param `extrap' returns groups of redundant chars.
+ (should (equal (erc--parse-user-modes "+a" '() t) '((?a) () () ())))
+ (should (equal (erc--parse-user-modes "+a" '(?a) t) '(() () (?a) ())))
+ (should (equal (erc--parse-user-modes "-a" '() t) '(() () () (?a))))
+ (should (equal (erc--parse-user-modes "-a" '(?a) t) '(() (?a) () ())))
+
+ (should (equal (erc--parse-user-modes "+a-b" '(?a) t) '(() () (?a) (?b))))
+ (should (equal (erc--parse-user-modes "-b+a" '(?a) t) '(() () (?a) (?b))))
+ (should (equal (erc--parse-user-modes "+a-b" '(?b) t) '((?a) (?b) () ())))
+ (should (equal (erc--parse-user-modes "-b+a" '(?b) t) '((?a) (?b) () ()))))
+
(ert-deftest erc--parse-isupport-value ()
(should (equal (erc--parse-isupport-value "a,b") '("a" "b")))
(should (equal (erc--parse-isupport-value "a,b,c") '("a" "b" "c")))
@@ -341,11 +1049,13 @@
(should (equal (erc--parse-isupport-value "\\x20\\x20\\x20") '(" ")))
(should (equal (erc--parse-isupport-value "\\x5Co/") '("\\o/")))
(should (equal (erc--parse-isupport-value "\\x7F,\\x19") '("\\x7F" "\\x19")))
+ (should (equal (erc--parse-isupport-value "a\\x3Db") '("a=b")))
(should (equal (erc--parse-isupport-value "a\\x2Cb,c") '("a,b" "c"))))
(ert-deftest erc--get-isupport-entry ()
(let ((erc--isupport-params (make-hash-table))
- (erc-server-parameters '(("FOO" . "1") ("BAR") ("BAZ" . "A,B,C")))
+ (erc-server-parameters '(("FOO" . "1") ("BAR") ("BAZ" . "A,B,C")
+ ("SPAM" . "")))
(items (lambda ()
(cl-loop for k being the hash-keys of erc--isupport-params
using (hash-values v) collect (cons k v)))))
@@ -366,7 +1076,9 @@
(should (equal (erc--get-isupport-entry 'FOO) '(FOO "1")))
(should (equal (funcall items)
- '((BAR . --empty--) (BAZ "A" "B" "C") (FOO "1"))))))
+ '((BAR . --empty--) (BAZ "A" "B" "C") (FOO "1"))))
+ (should (equal (erc--get-isupport-entry 'SPAM) '(SPAM)))
+ (should-not (erc--get-isupport-entry 'SPAM 'single))))
(ert-deftest erc-server-005 ()
(let* ((hooked 0)
@@ -384,34 +1096,41 @@
(lambda (_ _ _ line) (push line calls))))
(ert-info ("Baseline")
- (setq args '("tester" "BOT=B" "EXCEPTS" "PREFIX=(ov)@+" "are supp...")
+ (setq args '("tester" "BOT=B" "CHANTYPES=" "EXCEPTS" "PREFIX=(ov)@+"
+ "are supp...")
parsed (make-erc-response :command-args args :command "005"))
(setq verify
(lambda ()
(should (equal erc-server-parameters
'(("PREFIX" . "(ov)@+") ("EXCEPTS")
+ ;; Should be ("CHANTYPES") but
+ ;; retained for compatibility.
+ ("CHANTYPES" . "")
("BOT" . "B"))))
(should (zerop (hash-table-count erc--isupport-params)))
(should (equal "(ov)@+" (erc--get-isupport-entry 'PREFIX t)))
(should (equal '(EXCEPTS) (erc--get-isupport-entry 'EXCEPTS)))
(should (equal "B" (erc--get-isupport-entry 'BOT t)))
- (should (string= (pop calls)
- "BOT=B EXCEPTS PREFIX=(ov)@+ are supp..."))
+ (should (string=
+ (pop calls)
+ "BOT=B CHANTYPES= EXCEPTS PREFIX=(ov)@+ are supp..."))
(should (equal args (erc-response.command-args parsed)))))
(erc-call-hooks nil parsed))
(ert-info ("Negated, updated")
- (setq args '("tester" "-EXCEPTS" "-FAKE" "PREFIX=(ohv)@%+" "are su...")
+ (setq args '("tester" "-EXCEPTS" "-CHANTYPES" "-FAKE" "PREFIX=(ohv)@%+"
+ "are su...")
parsed (make-erc-response :command-args args :command "005"))
(setq verify
(lambda ()
(should (equal erc-server-parameters
'(("PREFIX" . "(ohv)@%+") ("BOT" . "B"))))
- (should (string= (pop calls)
- "-EXCEPTS -FAKE PREFIX=(ohv)@%+ are su..."))
+ (should (string-prefix-p
+ "-EXCEPTS -CHANTYPES -FAKE PREFIX=(ohv)@%+ "
+ (pop calls)))
(should (equal "(ohv)@%+" (erc--get-isupport-entry 'PREFIX t)))
(should (equal "B" (erc--get-isupport-entry 'BOT t)))
(should-not (erc--get-isupport-entry 'EXCEPTS))
@@ -447,6 +1166,39 @@
(should (equal (erc-downcase "Tilde~") "tilde~" ))
(should (equal (erc-downcase "\\O/") "|o/" )))))
+(ert-deftest erc-channel-p ()
+ (erc-tests-common-make-server-buf)
+
+ (should (erc-channel-p "#chan"))
+ (should (erc-channel-p "##chan"))
+ (should (erc-channel-p "&chan"))
+ (should-not (erc-channel-p "+chan"))
+ (should-not (erc-channel-p "!chan"))
+ (should-not (erc-channel-p "@chan"))
+
+ ;; Server sends "CHANTYPES=#&+!"
+ (should-not erc-server-parameters)
+ (setq erc-server-parameters '(("CHANTYPES" . "#&+!")))
+ (should (erc-channel-p "#chan"))
+ (should (erc-channel-p "&chan"))
+ (should (erc-channel-p "+chan"))
+ (should (erc-channel-p "!chan"))
+
+ (with-current-buffer (erc--open-target "#chan")
+ (should (erc-channel-p (current-buffer))))
+ (with-current-buffer (erc--open-target "+chan")
+ (should (erc-channel-p (current-buffer))))
+ (should (erc-channel-p (get-buffer "#chan")))
+ (should (erc-channel-p (get-buffer "+chan")))
+
+ ;; Server sends "CHANTYPES=" because it's query only.
+ (puthash 'CHANTYPES '("CHANTYPES") erc--isupport-params)
+ (should-not (erc-channel-p "#spam"))
+ (should-not (erc-channel-p "&spam"))
+ (should-not (erc-channel-p (save-excursion (erc--open-target "#spam"))))
+
+ (erc-tests-common-kill-buffers))
+
(ert-deftest erc--valid-local-channel-p ()
(ert-info ("Local channels not supported")
(let ((erc--isupport-params (make-hash-table)))
@@ -459,9 +1211,25 @@
(should-not (erc--valid-local-channel-p "#chan"))
(should (erc--valid-local-channel-p "&local")))))
+(ert-deftest erc--restore-initialize-priors ()
+ (unless (>= emacs-major-version 28)
+ (ert-skip "Lisp nesting exceeds `max-lisp-eval-depth'"))
+ (should (pcase (macroexpand-1 '(erc--restore-initialize-priors erc-my-mode
+ foo (ignore 1 2 3)
+ bar #'spam
+ baz nil))
+ (`(let* ((,p (or erc--server-reconnecting erc--target-priors))
+ (,q (and ,p (alist-get 'erc-my-mode ,p))))
+ (unless (local-variable-if-set-p 'erc-my-mode)
+ (error "Not a local minor mode var: %s" 'erc-my-mode))
+ (setq foo (if ,q (alist-get 'foo ,p) (ignore 1 2 3))
+ bar (if ,q (alist-get 'bar ,p) #'spam)
+ baz (if ,q (alist-get 'baz ,p) nil)))
+ t))))
+
(ert-deftest erc--target-from-string ()
(should (equal (erc--target-from-string "#chan")
- #s(erc--target-channel "#chan" \#chan)))
+ #s(erc--target-channel "#chan" \#chan nil)))
(should (equal (erc--target-from-string "Bob")
#s(erc--target "Bob" bob)))
@@ -469,7 +1237,51 @@
(let ((erc--isupport-params (make-hash-table)))
(puthash 'CHANTYPES '("&#") erc--isupport-params)
(should (equal (erc--target-from-string "&Bitlbee")
- #s(erc--target-channel-local "&Bitlbee" &bitlbee)))))
+ #s(erc--target-channel-local "&Bitlbee" &bitlbee nil)))))
+
+(ert-deftest erc--modify-local-map ()
+ (when (and (bound-and-true-p erc-irccontrols-mode)
+ (fboundp 'erc-irccontrols-mode))
+ (erc-irccontrols-mode -1))
+ (when (and (bound-and-true-p erc-match-mode)
+ (fboundp 'erc-match-mode))
+ (erc-match-mode -1))
+ (let* (calls
+ (inhibit-message noninteractive)
+ (cmd-foo (lambda () (interactive) (push 'foo calls)))
+ (cmd-bar (lambda () (interactive) (push 'bar calls))))
+
+ (ert-info ("Add non-existing")
+ (erc--modify-local-map t "C-c C-c" cmd-foo "C-c C-k" cmd-bar)
+ (with-temp-buffer
+ (set-window-buffer (selected-window) (current-buffer))
+ (use-local-map erc-mode-map)
+ (execute-kbd-macro "\C-c\C-c")
+ (execute-kbd-macro "\C-c\C-k"))
+ (should (equal calls '(bar foo))))
+ (setq calls nil)
+
+ (ert-info ("Add existing") ; Attempt to swap definitions fails
+ (erc--modify-local-map t "C-c C-c" cmd-bar "C-c C-k" cmd-foo)
+ (with-temp-buffer
+ (set-window-buffer (selected-window) (current-buffer))
+ (use-local-map erc-mode-map)
+ (execute-kbd-macro "\C-c\C-c")
+ (execute-kbd-macro "\C-c\C-k"))
+ (should (equal calls '(bar foo))))
+ (setq calls nil)
+
+ (ert-info ("Remove existing")
+ (ert-with-message-capture messages
+ (erc--modify-local-map nil "C-c C-c" cmd-foo "C-c C-k" cmd-bar)
+ (with-temp-buffer
+ (set-window-buffer (selected-window) (current-buffer))
+ (use-local-map erc-mode-map)
+ (execute-kbd-macro "\C-c\C-c")
+ (execute-kbd-macro "\C-c\C-k"))
+ (should (string-search "C-c C-c is undefined" messages))
+ (should (string-search "C-c C-k is undefined" messages))
+ (should-not calls)))))
(ert-deftest erc-ring-previous-command-base-case ()
(ert-info ("Create ring when nonexistent and do nothing")
@@ -484,18 +1296,19 @@
(ert-deftest erc-ring-previous-command ()
(with-current-buffer (get-buffer-create "*#fake*")
(erc-mode)
- (erc-tests--send-prep)
+ (erc-tests-common-prep-for-insertion)
+ (setq erc-server-current-nick "tester")
(setq-local erc-last-input-time 0)
(should-not (local-variable-if-set-p 'erc-send-completed-hook))
- (set (make-local-variable 'erc-send-completed-hook) nil) ; skip t (globals)
+ (setq-local erc-send-completed-hook nil) ; skip t (globals)
;; Just in case erc-ring-mode is already on
- (setq-local erc-pre-send-functions nil)
- (add-hook 'erc-pre-send-functions #'erc-add-to-input-ring)
+ (setq-local erc--input-review-functions erc--input-review-functions)
+ (add-hook 'erc--input-review-functions #'erc-add-to-input-ring)
;;
(cl-letf (((symbol-function 'erc-process-input-line)
(lambda (&rest _)
- (insert-before-markers
- (erc-display-message-highlight 'notice "echo: one\n"))))
+ (erc-display-message
+ nil 'notice (current-buffer) "echo: one\n")))
((symbol-function 'erc-command-no-process-p)
(lambda (&rest _) t)))
(ert-info ("Create ring, populate, recall")
@@ -591,6 +1404,56 @@
(kill-buffer "*erc-protocol*")
(should-not erc-debug-irc-protocol)))
+(ert-deftest erc--split-line ()
+ (let ((erc-split-line-length 0))
+ (should (equal (erc--split-line "") '("")))
+ (should (equal (erc--split-line " ") '(" ")))
+ (should (equal (erc--split-line "1") '("1")))
+ (should (equal (erc--split-line " 1") '(" 1")))
+ (should (equal (erc--split-line "1 ") '("1 ")))
+ (should (equal (erc--split-line "abc") '("abc"))))
+
+ (let ((erc-default-recipients '("#chan"))
+ (erc-split-line-length 10))
+ (should (equal (erc--split-line "") '("")))
+ (should (equal (erc--split-line "0123456789") '("0123456789")))
+ (should (equal (erc--split-line "0123456789a") '("0123456789" "a")))
+
+ (should (equal (erc--split-line "0123456789 ") '("0123456789" " ")))
+ (should (equal (erc--split-line "01234567 89") '("01234567 " "89")))
+ (should (equal (erc--split-line "0123456 789") '("0123456 " "789")))
+ (should (equal (erc--split-line "0 123456789") '("0 " "123456789")))
+ (should (equal (erc--split-line " 0123456789") '(" " "0123456789")))
+ (should (equal (erc--split-line "012345678 9a") '("012345678 " "9a")))
+ (should (equal (erc--split-line "0123456789 a") '("0123456789" " a")))
+
+ ;; UTF-8 vs. KOI-8
+ (should (= 10 (string-bytes "Русск"))) ; utf-8
+ (should (equal (erc--split-line "Русск") '("Русск")))
+ (should (equal (erc--split-line "РусскийТекст") '("Русск" "ийТек" "ст")))
+ (should (equal (erc--split-line "Русский Текст") '("Русск" "ий " "Текст")))
+ (let ((erc-encoding-coding-alist '(("#chan" . cyrillic-koi8))))
+ (should (equal (erc--split-line "Русск") '("Русск")))
+ (should (equal (erc--split-line "РусскийТекст") '("РусскийТек" "ст")))
+ (should (equal (erc--split-line "Русский Текст") '("Русский " "Текст"))))
+
+ ;; UTF-8 vs. Latin 1
+ (should (= 17 (string-bytes "Hyvää päivää")))
+ (should (equal (erc--split-line "Hyvää päivää") '("Hyvää " "päivää")))
+ (should (equal (erc--split-line "HyvääPäivää") '("HyvääPä" "ivää")))
+ (let ((erc-encoding-coding-alist '(("#chan" . latin-1))))
+ (should (equal (erc--split-line "Hyvää päivää") '("Hyvää " "päivää")))
+ (should (equal (erc--split-line "HyvääPäivää") '("HyvääPäivä" "ä"))))
+
+ ;; Combining characters
+ (should (= 10 (string-bytes "Åström")))
+ (should (equal (erc--split-line "_Åström") '("_Åströ" "m")))
+ (should (equal (erc--split-line "__Åström") '("__Åstr" "öm")))
+ (should (equal (erc--split-line "___Åström") '("___Åstr" "öm")))
+ (when (> emacs-major-version 27)
+ (should (equal (erc--split-line "🏁🚩🎌🏴🏳️🏳️‍🌈🏳️‍⚧️🏴‍☠️")
+ '("🏁🚩" "🎌🏴" "🏳️" "🏳️‍🌈" "🏳️‍⚧️" "🏴‍☠️"))))))
+
(ert-deftest erc--input-line-delim-regexp ()
(let ((p erc--input-line-delim-regexp))
;; none
@@ -622,64 +1485,8 @@
(should (equal '("" "" "") (split-string "\n\n" p)))
(should (equal '("" "" "") (split-string "\n\r" p)))))
-(ert-deftest erc--blank-in-multiline-input-p ()
- (let ((check (lambda (s)
- (erc--blank-in-multiline-input-p
- (split-string s erc--input-line-delim-regexp)))))
-
- (ert-info ("With `erc-send-whitespace-lines'")
- (let ((erc-send-whitespace-lines t))
- (should (funcall check ""))
- (should-not (funcall check "\na"))
- (should-not (funcall check "/msg a\n")) ; real /cmd
- (should-not (funcall check "a\n\nb")) ; "" allowed
- (should-not (funcall check "/msg a\n\nb")) ; non-/cmd
- (should-not (funcall check " "))
- (should-not (funcall check "\t"))
- (should-not (funcall check "a\nb"))
- (should-not (funcall check "a\n "))
- (should-not (funcall check "a\n \t"))
- (should-not (funcall check "a\n \f"))
- (should-not (funcall check "a\n \nb"))
- (should-not (funcall check "a\n \t\nb"))
- (should-not (funcall check "a\n \f\nb"))))
-
- (should (funcall check ""))
- (should (funcall check " "))
- (should (funcall check "\t"))
- (should (funcall check "a\n\nb"))
- (should (funcall check "a\n\nb"))
- (should (funcall check "a\n "))
- (should (funcall check "a\n \t"))
- (should (funcall check "a\n \f"))
- (should (funcall check "a\n \nb"))
- (should (funcall check "a\n \t\nb"))
-
- (should-not (funcall check "a\rb"))
- (should-not (funcall check "a\nb"))
- (should-not (funcall check "a\r\nb"))))
-
-(defun erc-tests--with-process-input-spy (test)
- (with-current-buffer (get-buffer-create "FakeNet")
- (let* ((erc-pre-send-functions
- (remove #'erc-add-to-input-ring erc-pre-send-functions)) ; for now
- (inhibit-message noninteractive)
- (erc-server-current-nick "tester")
- (erc-last-input-time 0)
- erc-accidental-paste-threshold-seconds
- erc-send-modify-hook
- ;;
- calls)
- (cl-letf (((symbol-function 'erc-process-input-line)
- (lambda (&rest r) (push r calls)))
- ((symbol-function 'erc-server-buffer)
- (lambda () (current-buffer))))
- (erc-tests--send-prep)
- (funcall test (lambda () (pop calls)))))
- (when noninteractive (kill-buffer))))
-
(ert-deftest erc--check-prompt-input-functions ()
- (erc-tests--with-process-input-spy
+ (erc-tests-common-with-process-input-spy
(lambda (next)
(ert-info ("Errors when point not in prompt area") ; actually just dings
@@ -691,9 +1498,9 @@
(ert-info ("Input remains untouched")
(should (save-excursion (erc-bol) (looking-at "/msg #chan hi")))))
- (ert-info ("Errors when no process running")
+ (ert-info ("Errors when server buffer absent")
(let ((e (should-error (erc-send-current-line))))
- (should (equal "ERC: No process running" (cadr e))))
+ (should (equal "Server buffer missing" (cadr e))))
(ert-info ("Input remains untouched")
(should (save-excursion (erc-bol) (looking-at "/msg #chan hi")))))
@@ -702,7 +1509,7 @@
(delete-region (point) (point-max))
(insert "one\n")
(let ((e (should-error (erc-send-current-line))))
- (should (equal "Blank line - ignoring..." (cadr e))))
+ (should (string-prefix-p "Trailing line detected" (cadr e))))
(goto-char (point-max))
(ert-info ("Input remains untouched")
(should (save-excursion (goto-char erc-input-marker)
@@ -714,9 +1521,9 @@
;; These also indirectly tests `erc-send-input'
(ert-deftest erc-send-current-line ()
- (erc-tests--with-process-input-spy
+ (erc-tests-common-with-process-input-spy
(lambda (next)
- (erc-tests--set-fake-server-process "sleep" "1")
+ (erc-tests-common-init-server-proc "sleep" "1")
(should (= 0 erc-last-input-time))
(ert-info ("Simple command")
@@ -728,8 +1535,9 @@
(ert-info ("Input cleared")
(erc-bol)
(should (eq (point) (point-max))))
- ;; Commands are forced (no flood protection)
- (should (equal (funcall next) '("/msg #chan hi\n" t nil))))
+ ;; The `force' argument is irrelevant here because it can't
+ ;; influence dispatched handlers, such as `erc-cmd-MSG'.
+ (should (pcase (funcall next) (`("/msg #chan hi\n" ,_ nil) t))))
(ert-info ("Simple non-command")
(insert "hi")
@@ -737,15 +1545,147 @@
(should (eq (point) (point-max)))
(should (save-excursion (forward-line -1)
(search-forward "<tester> hi")))
- ;; Non-ommands are forced only when `erc-flood-protect' is nil
+ ;; Non-commands are forced only when `erc-flood-protect' is
+ ;; nil, which conflates two orthogonal concerns.
(should (equal (funcall next) '("hi\n" nil t))))
(should (consp erc-last-input-time)))))
+(ert-deftest erc--discard-trailing-multiline-nulls ()
+ (pcase-dolist (`(,input ,want) '((("") (""))
+ (("" "") (""))
+ (("a") ("a"))
+ (("a" "") ("a"))
+ (("" "a") ("" "a"))
+ (("" "a" "") ("" "a"))))
+ (ert-info ((format "Input: %S, want: %S" input want))
+ (let ((s (make-erc--input-split :lines input)))
+ (erc--discard-trailing-multiline-nulls s)
+ (should (equal (erc--input-split-lines s) want))))))
+
+(ert-deftest erc--count-blank-lines ()
+ (pcase-dolist (`(,input ,want) '((() (0 0 0))
+ (("") (1 1 0))
+ (("" "") (2 1 1))
+ (("" "" "") (3 1 2))
+ ((" " "") (2 0 1))
+ ((" " "" "") (3 0 2))
+ (("" " " "") (3 1 1))
+ (("" "" " ") (3 2 0))
+ (("a") (0 0 0))
+ (("a" "") (1 0 1))
+ (("a" " " "") (2 0 1))
+ (("a" "" "") (2 0 2))
+ (("a" "b") (0 0 0))
+ (("a" "" "b") (1 1 0))
+ (("a" " " "b") (1 0 0))
+ (("" "a") (1 1 0))
+ ((" " "a") (1 0 0))
+ (("" "a" "") (2 1 1))
+ (("" " " "a" "" " ") (4 2 0))
+ (("" " " "a" "" " " "") (5 2 1))))
+ (ert-info ((format "Input: %S, want: %S" input want))
+ (should (equal (erc--count-blank-lines input) want)))))
+
+;; Opt `wb': `erc-warn-about-blank-lines'
+;; Opt `sw': `erc-send-whitespace-lines'
+;; `s': " \n",`a': "a\n",`b': "b\n"
+(defvar erc-tests--check-prompt-input--expect
+ ;; opts "" " " "\n" "\n " " \n" "\n\n" "a\n" "a\n " "a\n \nb"
+ '(((+wb -sw) err err err err err err err err err)
+ ((-wb -sw) nop nop nop nop nop nop nop nop nop)
+ ((+wb +sw) err (s) (0 s) (1 s s) (s) (0 s) (0 a) (a s) (a s b))
+ ((-wb +sw) nop (s) (s) (s s) (s) (s) (a) (a s) (a s b))))
+
+;; Help messages echoed (not IRC message) was emitted
+(defvar erc-tests--check-prompt-input-messages
+ '("Stripping" "Padding"))
+
+(ert-deftest erc--check-prompt-input-for-multiline-blanks ()
+ (erc-tests-common-with-process-input-spy
+ (lambda (next)
+ (erc-tests-common-init-server-proc "sleep" "10")
+ (should-not erc-send-whitespace-lines)
+ (should erc-warn-about-blank-lines)
+
+ (pcase-dolist (`((,wb ,sw) . ,ex) erc-tests--check-prompt-input--expect)
+ (let ((print-escape-newlines t)
+ (erc-warn-about-blank-lines (eq wb '+wb))
+ (erc-send-whitespace-lines (eq sw '+sw))
+ (samples '("" " " "\n" "\n " " \n" "\n\n"
+ "a\n" "a\n " "a\n \nb")))
+ (setq ex `(,@ex (a) (a b)) ; baseline, same for all combos
+ samples `(,@samples "a" "a\nb"))
+ (dolist (input samples)
+ (insert input)
+ (ert-info ((format "Opts: %S, Input: %S, want: %S"
+ (list wb sw) input (car ex)))
+ (ert-with-message-capture messages
+ (pcase-exhaustive (pop ex)
+ ('err (let ((e (should-error (erc-send-current-line))))
+ (should (string-match (rx (| "trailing" "blank"))
+ (cadr e))))
+ (should (equal (erc-user-input) input))
+ (should-not (funcall next)))
+ ('nop (erc-send-current-line)
+ (should (equal (erc-user-input) input))
+ (should-not (funcall next)))
+ ('clr (erc-send-current-line)
+ (should (string-empty-p (erc-user-input)))
+ (should-not (funcall next)))
+ ((and (pred consp) v)
+ (erc-send-current-line)
+ (should (string-empty-p (erc-user-input)))
+ (setq v (reverse v)) ; don't use `nreverse' here
+ (while v
+ (pcase (pop v)
+ ((and (pred integerp) n)
+ (should (string-search
+ (nth n erc-tests--check-prompt-input-messages)
+ messages)))
+ ('s (should (equal " \n" (car (funcall next)))))
+ ('a (should (equal "a\n" (car (funcall next)))))
+ ('b (should (equal "b\n" (car (funcall next)))))))
+ (should-not (funcall next))))))
+ (delete-region erc-input-marker (point-max))))))))
+
+(ert-deftest erc--check-prompt-input-for-multiline-blanks/explanations ()
+ (should erc-warn-about-blank-lines)
+ (should-not erc-send-whitespace-lines)
+
+ (let ((erc-send-whitespace-lines t))
+ (pcase-dolist (`(,input ,msg)
+ '((("") "Padding (1) blank line")
+ (("" " ") "Padding (1) blank line")
+ ((" " "") "Stripping (1) blank line")
+ (("a" "") "Stripping (1) blank line")
+ (("" "") "Stripping (1) and padding (1) blank lines")
+ (("" "" "") "Stripping (2) and padding (1) blank lines")
+ (("" "a" "" "b" "" "c" "" "")
+ "Stripping (2) and padding (3) blank lines")))
+ (ert-info ((format "Input: %S, Msg: %S" input msg))
+ (let (erc--check-prompt-explanation)
+ (should-not (erc--check-prompt-input-for-multiline-blanks nil input))
+ (should (equal (list msg) erc--check-prompt-explanation))))))
+
+ (pcase-dolist (`(,input ,msg)
+ '((("") "Blank line detected")
+ (("" " ") "2 blank lines detected")
+ ((" " "") "2 blank (1 trailing) lines detected")
+ (("a" "") "Trailing line detected")
+ (("" "") "2 blank (1 trailing) lines detected")
+ (("a" "" "") "2 trailing lines detected")
+ (("" "a" "" "b" "" "c" "" "")
+ "5 blank (2 trailing) lines detected")))
+ (ert-info ((format "Input: %S, Msg: %S" input msg))
+ (let ((rv (erc--check-prompt-input-for-multiline-blanks nil input)))
+ (should (equal (concat msg " (see `erc-send-whitespace-lines')")
+ rv ))))))
+
(ert-deftest erc-send-whitespace-lines ()
- (erc-tests--with-process-input-spy
+ (erc-tests-common-with-process-input-spy
(lambda (next)
- (erc-tests--set-fake-server-process "sleep" "1")
+ (erc-tests-common-init-server-proc "sleep" "1")
(setq-local erc-send-whitespace-lines t)
(ert-info ("Multiline hunk with blank line correctly split")
@@ -758,7 +1698,7 @@
(erc-bol)
(should (eq (point) (point-max))))
(should (equal (funcall next) '("two\n" nil t)))
- (should (equal (funcall next) '("\n" nil t)))
+ (should (equal (funcall next) '(" \n" nil t)))
(should (equal (funcall next) '("one\n" nil t))))
(ert-info ("Multiline hunk with trailing newline filtered")
@@ -780,18 +1720,21 @@
(should-not (funcall next)))
(ert-info ("Multiline command with trailing blank filtered")
- (pcase-dolist (`(,p . ,q)
- '(("/a b\r" "/a b\n") ("/a b\n" "/a b\n")
- ("/a b\n\n" "/a b\n") ("/a b\r\n" "/a b\n")
- ("a b\nc\n\n" "c\n" "a b\n")
- ("/a b\nc\n\n" "c\n" "/a b\n")
- ("/a b\n\nc\n\n" "c\n" "\n" "/a b\n")))
+ (dolist (p '("/a b" "/a b\n" "/a b\n\n" "/a b\n\n\n"))
(insert p)
(erc-send-current-line)
(erc-bol)
(should (eq (point) (point-max)))
- (while q
- (should (equal (funcall next) (list (pop q) nil t))))
+ (should (pcase (funcall next) (`(,cmd ,_ nil) (equal cmd "/a b\n"))))
+ (should-not (funcall next))))
+
+ (ert-info ("Multiline command with non-blanks errors")
+ (dolist (p '("/a b\nc\n\n" "/a b\n/c\n\n" "/a b\n\nc\n\n"
+ "/a\n c\n" "/a\nb\n" "/a\n/b\n" "/a \n \n"))
+ (insert p)
+ (should-error (erc-send-current-line))
+ (goto-char erc-input-marker)
+ (delete-region (point) (point-max))
(should-not (funcall next))))
(ert-info ("Multiline hunk with trailing whitespace not filtered")
@@ -809,13 +1752,14 @@
(ert-info ("With `erc-inhibit-multiline-input' as t (2)")
(let ((erc-inhibit-multiline-input t))
(should-not (erc--check-prompt-input-for-excess-lines "" '("a")))
- (should-not (erc--check-prompt-input-for-excess-lines "" '("a" "")))
+ ;; Does not trim trailing blanks.
+ (should (erc--check-prompt-input-for-excess-lines "" '("a" "")))
(should (erc--check-prompt-input-for-excess-lines "" '("a" "b")))))
(ert-info ("With `erc-inhibit-multiline-input' as 3")
(let ((erc-inhibit-multiline-input 3))
(should-not (erc--check-prompt-input-for-excess-lines "" '("a" "b")))
- (should-not (erc--check-prompt-input-for-excess-lines "" '("a" "b" "")))
+ (should (erc--check-prompt-input-for-excess-lines "" '("a" "b" "")))
(should (erc--check-prompt-input-for-excess-lines "" '("a" "b" "c")))))
(ert-info ("With `erc-ask-about-multiline-input'")
@@ -826,24 +1770,69 @@
(should-not (erc--check-prompt-input-for-excess-lines "" '("a" "b")))))
(should-not erc-ask-about-multiline-input)))
+(ert-deftest erc-extract-command-from-line ()
+ ;; FIXME when next modifying `erc-command-regexp's default value,
+ ;; move the single quote in the first group's character alternative
+ ;; to the front, i.e., [A-Za-z'] -> ['A-Za-z], so we can assert
+ ;; equivalence with this more readable `rx' form.
+ (rx bol
+ "/"
+ (group (+ (in "'A-Za-z")))
+ (group (| (: (+ (syntax whitespace)) (* nonl))
+ (* (syntax whitespace))))
+ eol)
+ (erc-mode) ; for `erc-mode-syntax-table'
+
+ ;; Non-command.
+ (should-not (erc-extract-command-from-line "FAKE\n"))
+ ;; Unknown command.
+ (should (equal (erc-extract-command-from-line "/FAKE\n")
+ '(erc-cmd-default "/FAKE\n")))
+
+ (ert-info ("With `do-not-parse-args'")
+ (should (equal (erc-extract-command-from-line "/MSG\n")
+ '(erc-cmd-MSG "\n")))
+ (should (equal (erc-extract-command-from-line "/MSG \n")
+ '(erc-cmd-MSG " \n")))
+ (should (equal (erc-extract-command-from-line "/MSG \n\n")
+ '(erc-cmd-MSG " \n\n")))
+ (should (equal (erc-extract-command-from-line "/MSG foo\n")
+ '(erc-cmd-MSG " foo")))
+ (should (equal (erc-extract-command-from-line "/MSG foo\n\n")
+ '(erc-cmd-MSG " foo")))
+ (should (equal (erc-extract-command-from-line "/MSG foo\n \n")
+ '(erc-cmd-MSG " foo")))
+ (should (equal (erc-extract-command-from-line "/MSG foo\n")
+ '(erc-cmd-MSG " foo"))))
+
+ (ert-info ("Without `do-not-parse-args'")
+ (should (equal (erc-extract-command-from-line "/HELP\n")
+ '(erc-cmd-HELP nil)))
+ (should (equal (erc-extract-command-from-line "/HELP \n")
+ '(erc-cmd-HELP nil)))
+ (should (equal (erc-extract-command-from-line "/HELP foo\n")
+ '(erc-cmd-HELP ("foo"))))
+ (should (equal (erc-extract-command-from-line "/HELP foo\n")
+ '(erc-cmd-HELP ("foo"))))
+ (should (equal (erc-extract-command-from-line "/HELP foo bar\n")
+ '(erc-cmd-HELP ("foo" "bar"))))))
+
;; The point of this test is to ensure output is handled identically
;; regardless of whether a command handler is summoned.
(ert-deftest erc-process-input-line ()
- (let (erc-server-last-sent-time
- erc-server-flood-queue
- (orig-erc-cmd-MSG (symbol-function 'erc-cmd-MSG))
- (erc-default-recipients '("#chan"))
+ (erc-tests-common-make-server-buf)
+ (let ((orig-erc-cmd-MSG (symbol-function 'erc-cmd-MSG))
+ (pop-flood-queue (lambda () (erc-with-server-buffer
+ (pop erc-server-flood-queue))))
calls)
- (with-temp-buffer
+ (setq erc-server-current-nick "tester")
+ (with-current-buffer (erc--open-target "#chan")
(cl-letf (((symbol-function 'erc-cmd-MSG)
(lambda (line)
(push line calls)
+ (should erc--called-as-input-p)
(funcall orig-erc-cmd-MSG line)))
- ((symbol-function 'erc-server-buffer)
- (lambda () (current-buffer)))
- ((symbol-function 'erc-server-process-alive)
- (lambda () t))
((symbol-function 'erc-server-send-queue)
#'ignore))
@@ -852,49 +1841,583 @@
(ert-info ("Baseline")
(erc-process-input-line "/msg #chan hi\n")
(should (equal (pop calls) " #chan hi"))
- (should (equal (pop erc-server-flood-queue)
+ (should (equal (funcall pop-flood-queue)
'("PRIVMSG #chan :hi\r\n" . utf-8))))
(ert-info ("Quote preserves line intact")
(erc-process-input-line "/QUOTE FAKE foo bar\n")
- (should (equal (pop erc-server-flood-queue)
+ (should (equal (funcall pop-flood-queue)
'("FAKE foo bar\r\n" . utf-8))))
(ert-info ("Unknown command respected")
(erc-process-input-line "/FAKE foo bar\n")
- (should (equal (pop erc-server-flood-queue)
+ (should (equal (funcall pop-flood-queue)
'("FAKE foo bar\r\n" . utf-8))))
(ert-info ("Spaces preserved")
(erc-process-input-line "/msg #chan hi you\n")
(should (equal (pop calls) " #chan hi you"))
- (should (equal (pop erc-server-flood-queue)
+ (should (equal (funcall pop-flood-queue)
'("PRIVMSG #chan :hi you\r\n" . utf-8))))
(ert-info ("Empty line honored")
(erc-process-input-line "/msg #chan\n")
(should (equal (pop calls) " #chan"))
- (should (equal (pop erc-server-flood-queue)
+ (should (equal (funcall pop-flood-queue)
'("PRIVMSG #chan :\r\n" . utf-8)))))
(ert-info ("Implicit cmd via `erc-send-input-line-function'")
(ert-info ("Baseline")
(erc-process-input-line "hi\n")
- (should (equal (pop erc-server-flood-queue)
+ (should (equal (funcall pop-flood-queue)
'("PRIVMSG #chan :hi\r\n" . utf-8))))
(ert-info ("Spaces preserved")
(erc-process-input-line "hi you\n")
- (should (equal (pop erc-server-flood-queue)
+ (should (equal (funcall pop-flood-queue)
'("PRIVMSG #chan :hi you\r\n" . utf-8))))
(ert-info ("Empty line transmitted with injected-space kludge")
(erc-process-input-line "\n")
- (should (equal (pop erc-server-flood-queue)
+ (should (equal (funcall pop-flood-queue)
'("PRIVMSG #chan : \r\n" . utf-8))))
- (should-not calls))))))
+ (should-not calls)))))
+ (erc-tests-common-kill-buffers))
+
+(ert-deftest erc--get-inserted-msg-beg/basic ()
+ (erc-tests-common-assert-get-inserted-msg/basic
+ (lambda (arg) (should (= 3 (erc--get-inserted-msg-beg arg))))))
+
+(ert-deftest erc--get-inserted-msg-end/basic ()
+ (erc-tests-common-assert-get-inserted-msg/basic
+ (lambda (arg) (should (= 11 (erc--get-inserted-msg-end arg))))))
+
+(ert-deftest erc--get-inserted-msg-bounds/basic ()
+ (erc-tests-common-assert-get-inserted-msg/basic
+ (lambda (arg)
+ (should (equal '(3 . 11) (erc--get-inserted-msg-bounds arg))))))
+
+(ert-deftest erc--delete-inserted-message ()
+ (erc-mode)
+ (erc--initialize-markers (point) nil)
+ ;; Put unique invisible properties on the line endings.
+ (erc-display-message nil 'notice nil "one")
+ (put-text-property (1- erc-insert-marker) erc-insert-marker 'invisible 'a)
+ (let ((erc--msg-prop-overrides '((erc--msg . datestamp) (erc--ts . 0))))
+ (erc-display-message nil nil nil
+ (propertize "\n[date]" 'field 'erc-timestamp)))
+ (put-text-property (1- erc-insert-marker) erc-insert-marker 'invisible 'b)
+ (erc-display-message nil 'notice nil "two")
+
+ (ert-info ("Date stamp deleted cleanly")
+ (goto-char 11)
+ (should (looking-at (rx "\n[date]")))
+ (should (eq 'datestamp (get-text-property (point) 'erc--msg)))
+ (should (eq (point) (field-beginning (1+ (point)))))
+
+ (erc--delete-inserted-message (point))
+
+ ;; Preceding line ending clobbered, replaced by trailing.
+ (should (looking-back (rx "*** one\n")))
+ (should (looking-at (rx "*** two")))
+ (should (eq 'b (get-text-property (1- (point)) 'invisible))))
+
+ (ert-info ("Markers at pos-bol preserved")
+ (erc-display-message nil 'notice nil "three")
+ (should (looking-at (rx "*** two")))
+
+ (let ((m (point-marker))
+ (n (point-marker))
+ (p (point)))
+ (set-marker-insertion-type m t)
+ (goto-char (point-max))
+ (erc--delete-inserted-message p)
+ (should (= (marker-position n) p))
+ (should (= (marker-position m) p))
+ (goto-char p)
+ (set-marker m nil)
+ (set-marker n nil)
+ (should (looking-back (rx "*** one\n")))
+ (should (looking-at (rx "*** three")))))
+
+ (ert-info ("Compat")
+ (erc-display-message nil 'notice nil "four")
+ (should (looking-at (rx "*** three\n")))
+ (with-suppressed-warnings ((obsolete erc-legacy-invisible-bounds-p))
+ (let ((erc-legacy-invisible-bounds-p t))
+ (erc--delete-inserted-message (point))))
+ (should (looking-at (rx "*** four\n"))))
+
+ (ert-info ("Deleting most recent message preserves markers")
+ (let ((m (point-marker))
+ (n (point-marker))
+ (p (point)))
+ (should (equal "*** four\n" (buffer-substring p erc-insert-marker)))
+ (set-marker-insertion-type m t)
+ (goto-char (point-max))
+ (erc--delete-inserted-message p)
+ (should (= (marker-position m) p))
+ (should (= (marker-position n) p))
+ (goto-char p)
+ (should (looking-back (rx "*** one\n")))
+ (should (looking-at erc-prompt))
+ (erc--assert-input-bounds)
+
+ ;; However, `m' is now forever "trapped" at `erc-insert-marker'.
+ (erc-display-message nil 'notice nil "two")
+ (should (= m erc-insert-marker))
+ (goto-char n)
+ (should (looking-at (rx "*** two\n")))
+ (set-marker m nil)
+ (set-marker n nil))))
+
+(ert-deftest erc--order-text-properties-from-hash ()
+ (let ((table (map-into '((a . 1)
+ (erc--ts . 0)
+ (erc--msg . s005)
+ (b . 2)
+ (erc--cmd . 5)
+ (erc--spkr . "X")
+ (c . 3))
+ 'hash-table)))
+ (with-temp-buffer
+ (erc-mode)
+ (insert "abc\n")
+ (add-text-properties 1 2 (erc--order-text-properties-from-hash table))
+ (should (equal '( erc--msg s005
+ erc--spkr "X"
+ erc--ts 0
+ erc--cmd 5
+ a 1
+ b 2
+ c 3)
+ (text-properties-at (point-min)))))))
+
+(ert-deftest erc--check-msg-prop ()
+ (let ((erc--msg-props (map-into '((a . 1) (b . x)) 'hash-table)))
+ (should (eq 1 (erc--check-msg-prop 'a)))
+ (should (erc--check-msg-prop 'a 1))
+ (should-not (erc--check-msg-prop 'a 2))
+
+ (should (eq 'x (erc--check-msg-prop 'b)))
+ (should (erc--check-msg-prop 'b 'x))
+ (should-not (erc--check-msg-prop 'b 1))
+
+ (should (erc--check-msg-prop 'a '(1 42)))
+ (should-not (erc--check-msg-prop 'a '(2 42)))
+
+ (let ((props '(42 x)))
+ (should (erc--check-msg-prop 'b props)))
+ (let ((v '(42 y)))
+ (should-not (erc--check-msg-prop 'b v)))))
+
+(ert-deftest erc--merge-prop ()
+ (with-current-buffer (get-buffer-create "*erc-test*")
+ ;; Baseline.
+ (insert "abc\n")
+ (erc--merge-prop 1 3 'erc-test 'x)
+ (should (erc-tests-common-equal-with-props
+ (buffer-substring 1 4) #("abc" 0 2 (erc-test x))))
+ (erc--merge-prop 1 3 'erc-test 'y)
+ (should (erc-tests-common-equal-with-props
+ (buffer-substring 1 4) #("abc" 0 2 (erc-test (y x)))))
+
+ ;; Multiple intervals.
+ (goto-char (point-min))
+ (insert "def\n")
+ (erc--merge-prop 1 2 'erc-test 'x)
+ (erc--merge-prop 2 3 'erc-test 'y)
+ (should (erc-tests-common-equal-with-props
+ (buffer-substring 1 4)
+ #("def" 0 1 (erc-test x) 1 2 (erc-test y))))
+ (erc--merge-prop 1 3 'erc-test 'z)
+ (should (erc-tests-common-equal-with-props
+ (buffer-substring 1 4)
+ #("def" 0 1 (erc-test (z x)) 1 2 (erc-test (z y)))))
+
+ ;; New val as list.
+ (goto-char (point-min))
+ (insert "ghi\n")
+ (erc--merge-prop 2 3 'erc-test '(y z))
+ (should (erc-tests-common-equal-with-props
+ (buffer-substring 1 4) #("ghi" 1 2 (erc-test (y z)))))
+ (erc--merge-prop 1 3 'erc-test '(w x))
+ (should (erc-tests-common-equal-with-props
+ (buffer-substring 1 4)
+ #("ghi" 0 1 (erc-test (w x)) 1 2 (erc-test (w x y z)))))
+
+ ;; Flag `erc--merge-prop-behind-p'.
+ (goto-char (point-min))
+ (insert "jkl\n")
+ (erc--merge-prop 2 3 'erc-test '(y z))
+ (should (erc-tests-common-equal-with-props
+ (buffer-substring 1 4) #("jkl" 1 2 (erc-test (y z)))))
+ (let ((erc--merge-prop-behind-p t))
+ (erc--merge-prop 1 3 'erc-test '(w x)))
+ (should (erc-tests-common-equal-with-props
+ (buffer-substring 1 4)
+ #("jkl" 0 1 (erc-test (w x)) 1 2 (erc-test (y z w x)))))
+
+ (when noninteractive
+ (kill-buffer))))
+
+(ert-deftest erc--remove-from-prop-value-list ()
+ (with-current-buffer (get-buffer-create "*erc-test*")
+ ;; Non-list match.
+ (insert "abc\n")
+ (put-text-property 1 2 'erc-test 'a)
+ (put-text-property 2 3 'erc-test 'b)
+ (put-text-property 3 4 'erc-test 'c)
+ (should (erc-tests-common-equal-with-props
+ (buffer-substring 1 4) #("abc"
+ 0 1 (erc-test a)
+ 1 2 (erc-test b)
+ 2 3 (erc-test c))))
+
+ (erc--remove-from-prop-value-list 1 4 'erc-test 'b)
+ (should (erc-tests-common-equal-with-props
+ (buffer-substring 1 4) #("abc"
+ 0 1 (erc-test a)
+ 2 3 (erc-test c))))
+ (erc--remove-from-prop-value-list 1 4 'erc-test 'a)
+ (should (erc-tests-common-equal-with-props
+ (buffer-substring 1 4) #("abc" 2 3 (erc-test c))))
+ (erc--remove-from-prop-value-list 1 4 'erc-test 'c)
+ (should (erc-tests-common-equal-with-props
+ (buffer-substring 1 4) "abc"))
+
+ ;; List match.
+ (goto-char (point-min))
+ (insert "def\n")
+ (put-text-property 1 2 'erc-test '(d x))
+ (put-text-property 2 3 'erc-test '(e y))
+ (put-text-property 3 4 'erc-test '(f z))
+ (should (erc-tests-common-equal-with-props
+ (buffer-substring 1 4) #("def"
+ 0 1 (erc-test (d x))
+ 1 2 (erc-test (e y))
+ 2 3 (erc-test (f z)))))
+ (erc--remove-from-prop-value-list 1 4 'erc-test 'y)
+ (should (erc-tests-common-equal-with-props
+ (buffer-substring 1 4) #("def"
+ 0 1 (erc-test (d x))
+ 1 2 (erc-test e)
+ 2 3 (erc-test (f z)))))
+ (erc--remove-from-prop-value-list 1 4 'erc-test 'd)
+ (erc--remove-from-prop-value-list 1 4 'erc-test 'f)
+ (should (erc-tests-common-equal-with-props
+ (buffer-substring 1 4) #("def"
+ 0 1 (erc-test x)
+ 1 2 (erc-test e)
+ 2 3 (erc-test z))))
+ (erc--remove-from-prop-value-list 1 4 'erc-test 'e)
+ (erc--remove-from-prop-value-list 1 4 'erc-test 'z)
+ (erc--remove-from-prop-value-list 1 4 'erc-test 'x)
+ (should (erc-tests-common-equal-with-props
+ (buffer-substring 1 4) "def"))
+
+ ;; List match.
+ (goto-char (point-min))
+ (insert "ghi\n")
+ (put-text-property 1 2 'erc-test '(g x))
+ (put-text-property 2 3 'erc-test '(h x))
+ (put-text-property 3 4 'erc-test '(i y))
+ (should (erc-tests-common-equal-with-props
+ (buffer-substring 1 4) #("ghi"
+ 0 1 (erc-test (g x))
+ 1 2 (erc-test (h x))
+ 2 3 (erc-test (i y)))))
+ (erc--remove-from-prop-value-list 1 4 'erc-test 'x)
+ (should (erc-tests-common-equal-with-props
+ (buffer-substring 1 4) #("ghi"
+ 0 1 (erc-test g)
+ 1 2 (erc-test h)
+ 2 3 (erc-test (i y)))))
+ (erc--remove-from-prop-value-list 1 2 'erc-test 'g) ; narrowed
+ (erc--remove-from-prop-value-list 3 4 'erc-test 'i) ; narrowed
+ (should (erc-tests-common-equal-with-props
+ (buffer-substring 1 4) #("ghi"
+ 1 2 (erc-test h)
+ 2 3 (erc-test y))))
+
+ ;; Pathological (,c) case (hopefully not created by ERC)
+ (goto-char (point-min))
+ (insert "jkl\n")
+ (put-text-property 1 2 'erc-test '(j x))
+ (put-text-property 2 3 'erc-test '(k))
+ (put-text-property 3 4 'erc-test '(k))
+ (erc--remove-from-prop-value-list 1 4 'erc-test 'k)
+ (should (erc-tests-common-equal-with-props
+ (buffer-substring 1 4) #("jkl" 0 1 (erc-test (j x)))))
+
+ (when noninteractive
+ (kill-buffer))))
+
+(ert-deftest erc--remove-from-prop-value-list/many ()
+ (with-current-buffer (get-buffer-create "*erc-test*")
+ ;; Non-list match.
+ (insert "abc\n")
+ (put-text-property 1 2 'erc-test 'a)
+ (put-text-property 2 3 'erc-test 'b)
+ (put-text-property 3 4 'erc-test 'c)
+ (should (erc-tests-common-equal-with-props
+ (buffer-substring 1 4) #("abc"
+ 0 1 (erc-test a)
+ 1 2 (erc-test b)
+ 2 3 (erc-test c))))
+
+ (erc--remove-from-prop-value-list 1 4 'erc-test '(a b))
+ (should (erc-tests-common-equal-with-props
+ (buffer-substring 1 4) #("abc" 2 3 (erc-test c))))
+ (erc--remove-from-prop-value-list 1 4 'erc-test 'a)
+ (should (erc-tests-common-equal-with-props
+ (buffer-substring 1 4) #("abc" 2 3 (erc-test c))))
+ (erc--remove-from-prop-value-list 1 4 'erc-test '(c))
+ (should (erc-tests-common-equal-with-props
+ (buffer-substring 1 4) "abc"))
+
+ ;; List match.
+ (goto-char (point-min))
+ (insert "def\n")
+ (put-text-property 1 2 'erc-test '(d x y))
+ (put-text-property 2 3 'erc-test '(e y))
+ (put-text-property 3 4 'erc-test '(f z))
+ (should (erc-tests-common-equal-with-props
+ (buffer-substring 1 4) #("def"
+ 0 1 (erc-test (d x y))
+ 1 2 (erc-test (e y))
+ 2 3 (erc-test (f z)))))
+ (erc--remove-from-prop-value-list 1 4 'erc-test '(d y f))
+ (should (erc-tests-common-equal-with-props
+ (buffer-substring 1 4) #("def"
+ 0 1 (erc-test x)
+ 1 2 (erc-test e)
+ 2 3 (erc-test z))))
+ (erc--remove-from-prop-value-list 1 4 'erc-test '(e z x))
+ (should (erc-tests-common-equal-with-props
+ (buffer-substring 1 4) "def"))
+
+ ;; Narrowed beg.
+ (goto-char (point-min))
+ (insert "ghi\n")
+ (put-text-property 1 2 'erc-test '(g x))
+ (put-text-property 2 3 'erc-test '(h x))
+ (put-text-property 3 4 'erc-test '(i x))
+ (should (erc-tests-common-equal-with-props
+ (buffer-substring 1 4) #("ghi"
+ 0 1 (erc-test (g x))
+ 1 2 (erc-test (h x))
+ 2 3 (erc-test (i x)))))
+ (erc--remove-from-prop-value-list 1 3 'erc-test '(x g i))
+ (should (erc-tests-common-equal-with-props
+ (buffer-substring 1 4) #("ghi"
+ 1 2 (erc-test h)
+ 2 3 (erc-test (i x)))))
+
+ ;; Narrowed middle.
+ (goto-char (point-min))
+ (insert "jkl\n")
+ (put-text-property 1 2 'erc-test '(j x))
+ (put-text-property 2 3 'erc-test '(k))
+ (put-text-property 3 4 'erc-test '(l y z))
+ (erc--remove-from-prop-value-list 3 4 'erc-test '(k x y z))
+ (should (erc-tests-common-equal-with-props
+ (buffer-substring 1 4) #("jkl"
+ 0 1 (erc-test (j x))
+ 1 2 (erc-test (k))
+ 2 3 (erc-test l))))
+
+ (when noninteractive
+ (kill-buffer))))
+
+(ert-deftest erc--restore-important-text-props ()
+ (erc-mode)
+ (let ((erc--msg-props (map-into '((erc--important-prop-names a))
+ 'hash-table)))
+ (insert (propertize "foo" 'a 'A 'b 'B 'erc--important-props '(a A))
+ " "
+ (propertize "bar" 'c 'C 'a 'A 'b 'B
+ 'erc--important-props '(a A c C)))
+
+ ;; Attempt to restore a and c when only a is registered.
+ (remove-list-of-text-properties (point-min) (point-max) '(a c))
+ (erc--restore-important-text-props '(a c))
+ (should (erc-tests-common-equal-with-props
+ (buffer-string)
+ #("foo bar"
+ 0 3 (a A b B erc--important-props (a A))
+ 4 7 (a A b B erc--important-props (a A c C)))))
+
+ ;; Add d between 3 and 6.
+ (erc--reserve-important-text-props 3 6 '(d D))
+ (put-text-property 3 6 'd 'D)
+ (should (erc-tests-common-equal-with-props
+ (buffer-string)
+ #("foo bar" ; #1
+ 0 2 (a A b B erc--important-props (a A))
+ 2 3 (d D a A b B erc--important-props (d D a A))
+ 3 4 (d D erc--important-props (d D))
+ 4 5 (d D a A b B erc--important-props (d D a A c C))
+ 5 7 (a A b B erc--important-props (a A c C)))))
+ ;; Remove a and d, and attempt to restore d.
+ (remove-list-of-text-properties (point-min) (point-max) '(a d))
+ (erc--restore-important-text-props '(d))
+ (should (erc-tests-common-equal-with-props
+ (buffer-string)
+ #("foo bar"
+ 0 2 (b B erc--important-props (a A))
+ 2 3 (d D b B erc--important-props (d D a A))
+ 3 4 (d D erc--important-props (d D))
+ 4 5 (d D b B erc--important-props (d D a A c C))
+ 5 7 (b B erc--important-props (a A c C)))))
+
+ ;; Restore a only.
+ (erc--restore-important-text-props '(a))
+ (should (erc-tests-common-equal-with-props
+ (buffer-string)
+ #("foo bar" ; same as #1 above
+ 0 2 (a A b B erc--important-props (a A))
+ 2 3 (d D a A b B erc--important-props (d D a A))
+ 3 4 (d D erc--important-props (d D))
+ 4 5 (d D a A b B erc--important-props (d D a A c C))
+ 5 7 (a A b B erc--important-props (a A c C)))))))
+
+(ert-deftest erc--split-string-shell-cmd ()
+
+ ;; Leading and trailing space
+ (should (equal (erc--split-string-shell-cmd "1 2 3") '("1" "2" "3")))
+ (should (equal (erc--split-string-shell-cmd " 1 2 3 ") '("1" "2" "3")))
+
+ ;; Empty string
+ (should (equal (erc--split-string-shell-cmd "\"\"") '("")))
+ (should (equal (erc--split-string-shell-cmd " \"\" ") '("")))
+ (should (equal (erc--split-string-shell-cmd "1 \"\"") '("1" "")))
+ (should (equal (erc--split-string-shell-cmd "1 \"\" ") '("1" "")))
+ (should (equal (erc--split-string-shell-cmd "\"\" 1") '("" "1")))
+ (should (equal (erc--split-string-shell-cmd " \"\" 1") '("" "1")))
+
+ (should (equal (erc--split-string-shell-cmd "''") '("")))
+ (should (equal (erc--split-string-shell-cmd " '' ") '("")))
+ (should (equal (erc--split-string-shell-cmd "1 ''") '("1" "")))
+ (should (equal (erc--split-string-shell-cmd "1 '' ") '("1" "")))
+ (should (equal (erc--split-string-shell-cmd "'' 1") '("" "1")))
+ (should (equal (erc--split-string-shell-cmd " '' 1") '("" "1")))
+
+ ;; Backslash
+ (should (equal (erc--split-string-shell-cmd "\\ ") '(" ")))
+ (should (equal (erc--split-string-shell-cmd " \\ ") '(" ")))
+ (should (equal (erc--split-string-shell-cmd "1\\ ") '("1 ")))
+ (should (equal (erc--split-string-shell-cmd "1\\ 2") '("1 2")))
+
+ ;; Embedded
+ (should (equal (erc--split-string-shell-cmd "\"\\\"\"") '("\"")))
+ (should (equal (erc--split-string-shell-cmd "1 \"2 \\\" \\\" 3\"")
+ '("1" "2 \" \" 3")))
+ (should (equal (erc--split-string-shell-cmd "1 \"2 ' ' 3\"")
+ '("1" "2 ' ' 3")))
+ (should (equal (erc--split-string-shell-cmd "1 '2 \" \" 3'")
+ '("1" "2 \" \" 3")))
+ (should (equal (erc--split-string-shell-cmd "1 '2 \\ 3'")
+ '("1" "2 \\ 3")))
+ (should (equal (erc--split-string-shell-cmd "1 \"2 \\\\ 3\"")
+ '("1" "2 \\ 3"))) ; see comment re ^
+
+ ;; Realistic
+ (should (equal (erc--split-string-shell-cmd "GET bob \"my file.txt\"")
+ '("GET" "bob" "my file.txt")))
+ (should (equal (erc--split-string-shell-cmd "GET EXAMPLE|bob \"my file.txt\"")
+ '("GET" "EXAMPLE|bob" "my file.txt")))) ; regression
+
+
+;; The behavior of `erc-pre-send-functions' differs between versions
+;; in how hook members see and influence a trailing newline that's
+;; part of the original prompt submission:
+;;
+;; 5.4: both seen and sent
+;; 5.5: seen but not sent*
+;; 5.6: neither seen nor sent*
+;;
+;; * requires `erc-send-whitespace-lines' for hook to run
+;;
+;; Two aspects that have remained consistent are
+;;
+;; - a final nonempty line in any submission is always sent
+;; - a trailing newline appended by a hook member is always sent
+;;
+;; The last bullet would seem to contradict the "not sent" behavior of
+;; 5.5 and 5.6, but what's actually happening is that exactly one
+;; trailing newline is culled, so anything added always goes through.
+;; Also, in ERC 5.6, all empty lines are actually padded, but this is
+;; merely incidental WRT the above.
+;;
+;; Note that this test doesn't run any input-prep hooks and thus can't
+;; account for the "seen" dimension noted above.
+
+(ert-deftest erc--run-send-hooks ()
+ (with-suppressed-warnings ((obsolete erc-send-this)
+ (obsolete erc-send-pre-hook))
+ (should erc-insert-this)
+ (should erc-send-this) ; populates `erc--input-split-sendp'
+
+ (let (erc-pre-send-functions erc-send-pre-hook)
+
+ (ert-info ("String preserved, lines rewritten, empties padded")
+ (setq erc-pre-send-functions
+ (lambda (o) (setf (erc-input-string o) "bar\n\nbaz\n")))
+ (should (pcase (erc--run-send-hooks (make-erc--input-split
+ :string "foo" :lines '("foo")))
+ ((cl-struct erc--input-split
+ (string "foo") (sendp 't) (insertp 't)
+ (lines '("bar" " " "baz" " ")) (cmdp 'nil))
+ t))))
+
+ (ert-info ("Multiline commands rejected")
+ (should-error (erc--run-send-hooks (make-erc--input-split
+ :string "/mycmd foo"
+ :lines '("/mycmd foo")
+ :cmdp t))))
+
+ (ert-info ("Single-line commands pass")
+ (setq erc-pre-send-functions
+ (lambda (o) (setf (erc-input-sendp o) nil
+ (erc-input-string o) "/mycmd bar")))
+ (should (pcase (erc--run-send-hooks (make-erc--input-split
+ :string "/mycmd foo"
+ :lines '("/mycmd foo")
+ :cmdp t))
+ ((cl-struct erc--input-split
+ (string "/mycmd foo") (sendp 'nil) (insertp 't)
+ (lines '("/mycmd bar")) (cmdp 't))
+ t))))
+
+ (ert-info ("Legacy hook respected, special vars confined")
+ (setq erc-send-pre-hook (lambda (_) (setq erc-send-this nil))
+ erc-pre-send-functions (lambda (o) ; propagates
+ (should-not (erc-input-sendp o))))
+ (should (pcase (erc--run-send-hooks (make-erc--input-split
+ :string "foo" :lines '("foo")))
+ ((cl-struct erc--input-split
+ (string "foo") (sendp 'nil) (insertp 't)
+ (lines '("foo")) (cmdp 'nil))
+ t)))
+ (should erc-send-this))
+
+ (ert-info ("Request to resplit honored")
+ (setq erc-send-pre-hook nil
+ erc-pre-send-functions
+ (lambda (o) (setf (erc-input-string o) "foo bar baz"
+ (erc-input-refoldp o) t)))
+ (let* ((split (make-erc--input-split :string "foo" :lines '("foo")))
+ (erc--current-line-input-split split)
+ (erc-split-line-length 8))
+ (should
+ (pcase (erc--run-send-hooks split)
+ ((cl-struct erc--input-split
+ (string "foo") (sendp 't) (insertp 't)
+ (lines '("foo bar " "baz")) (cmdp 'nil))
+ t))))))))
;; Note: if adding an erc-backend-tests.el, please relocate this there.
@@ -904,7 +2427,8 @@
calls
erc-kill-channel-hook erc-kill-server-hook erc-kill-buffer-hook)
(cl-letf (((symbol-function 'erc-display-message)
- (lambda (_ _ _ line) (push line calls)))
+ (lambda (_ _ _ msg &rest args)
+ (push (apply #'erc-format-message msg args) calls)))
((symbol-function 'erc-server-send)
(lambda (line _) (push line calls)))
((symbol-function 'erc-server-buffer)
@@ -923,6 +2447,7 @@
(erc-mode)
(setq erc-server-process (buffer-local-value 'erc-server-process
(get-buffer "ExampleNet"))
+ erc--target (erc--target-from-string "#chan")
erc-default-recipients '("#chan")
erc-channel-users (make-hash-table :test 'equal)
erc-network 'ExampleNet)
@@ -945,7 +2470,7 @@
(should-not erc-server-last-peers)
(erc-message "PRIVMSG" ". hi")
(should-not erc-server-last-peers)
- (should (eq 'no-target (pop calls)))
+ (should (equal "No target" (pop calls)))
(erc-message "PRIVMSG" ", hi")
(should-not erc-server-last-peers)
(should (string-match "alice :hi" (pop calls)))))
@@ -978,6 +2503,333 @@
(kill-buffer "ExampleNet")
(kill-buffer "#chan")))
+(ert-deftest erc-get-channel-membership-prefix ()
+ (ert-info ("Uses default prefixes when `erc--parsed-prefix' not available")
+ (should-not (erc--parsed-prefix))
+ ;; Baseline.
+ (should-not (erc-get-channel-membership-prefix nil))
+ (should (equal (erc-get-channel-membership-prefix "Bob") ""))
+ (should (equal (erc-get-channel-membership-prefix (make-erc-channel-user))
+ ""))
+ ;; Defaults.
+ (should
+ (erc-tests-common-equal-with-props
+ (erc-get-channel-membership-prefix (make-erc-channel-user :owner t))
+ #("~" 0 1 (help-echo "owner"))))
+ (should
+ (erc-tests-common-equal-with-props
+ (erc-get-channel-membership-prefix (make-erc-channel-user :admin t))
+ #("&" 0 1 (help-echo "admin"))))
+ (should
+ (erc-tests-common-equal-with-props
+ (erc-get-channel-membership-prefix (make-erc-channel-user :op t))
+ #("@" 0 1 (help-echo "operator"))))
+ (should
+ (erc-tests-common-equal-with-props
+ (erc-get-channel-membership-prefix (make-erc-channel-user :halfop t))
+ #("%" 0 1 (help-echo "half-op"))))
+ (should
+ (erc-tests-common-equal-with-props
+ (erc-get-channel-membership-prefix (make-erc-channel-user :voice t))
+ #("+" 0 1 (help-echo "voice")))))
+
+ (ert-info ("Uses advertised prefixes when `erc--parsed-prefix' is available")
+ (erc-tests-common-make-server-buf (buffer-name))
+ (push '("PREFIX" . "(ov)@+") erc-server-parameters)
+ (should (erc--parsed-prefix))
+
+ (with-current-buffer (erc--open-target "#chan")
+ (erc-update-current-channel-member "Bob" nil t nil nil 'on)
+
+ ;; Baseline.
+ (should-not (erc-get-channel-membership-prefix nil))
+ (should (string-empty-p (erc-get-channel-membership-prefix
+ (make-erc-channel-user))))
+
+ ;; Defaults.
+ (should (string-empty-p (erc-get-channel-membership-prefix
+ (make-erc-channel-user :owner t))))
+ (should (string-empty-p (erc-get-channel-membership-prefix
+ (make-erc-channel-user :admin t))))
+ (should (string-empty-p (erc-get-channel-membership-prefix
+ (make-erc-channel-user :halfop t))))
+
+ (should (erc-tests-common-equal-with-props
+ (erc-get-channel-membership-prefix "Bob")
+ #("@" 0 1 (help-echo "operator"))))
+ (should (erc-tests-common-equal-with-props
+ (erc-get-channel-membership-prefix
+ (make-erc-channel-user :voice t))
+ #("+" 0 1 (help-echo "voice"))))
+
+ (kill-buffer))))
+
+;; This is an adapter that uses formatting templates from the
+;; `-speaker' catalog to mimic `erc-format-privmessage', for testing
+;; purposes.
+(defun erc-tests--format-privmessage (nick msg privp msgp &optional inputp pfx)
+ (let ((erc-current-message-catalog erc--message-speaker-catalog))
+ (apply #'erc-format-message
+ (erc--determine-speaker-message-format-args nick msg privp msgp
+ inputp nil pfx))))
+
+;; This asserts that `erc--determine-speaker-message-format-args'
+;; behaves identically to `erc-format-privmessage', the function whose
+;; role it basically replaced.
+(ert-deftest erc--determine-speaker-message-format-args ()
+ ;; Basic PRIVMSG.
+ (let ((expect #("<bob> oh my"
+ 0 1 (font-lock-face erc-default-face)
+ 1 4 (erc--speaker "bob" font-lock-face erc-nick-default-face)
+ 4 11 (font-lock-face erc-default-face)))
+ (args (list (concat "bob") (concat "oh my") nil 'msgp)))
+ (should (erc-tests-common-equal-with-props
+ (apply #'erc-format-privmessage args)
+ expect))
+ (should (erc-tests-common-equal-with-props
+ (apply #'erc-tests--format-privmessage args)
+ expect)))
+
+ ;; Basic NOTICE.
+ (let ((expect #("-bob- oh my"
+ 0 1 (font-lock-face erc-default-face)
+ 1 4 (erc--speaker "bob" font-lock-face erc-nick-default-face)
+ 4 11 (font-lock-face erc-default-face)))
+ (args (list (copy-sequence "bob") (copy-sequence "oh my") nil nil)))
+ (should (erc-tests-common-equal-with-props
+ (apply #'erc-format-privmessage args)
+ expect))
+ (should (erc-tests-common-equal-with-props
+ (apply #'erc-tests--format-privmessage args)
+ expect)))
+
+ ;; Status-prefixed PRIVMSG.
+ (let* ((expect
+ #("<@Bob> oh my"
+ 0 1 (font-lock-face erc-default-face)
+ 1 2 (font-lock-face erc-nick-prefix-face help-echo "operator")
+ 2 5 (erc--speaker "Bob" font-lock-face erc-nick-default-face)
+ 5 12 (font-lock-face erc-default-face)))
+ (user (make-erc-server-user :nickname (copy-sequence "Bob")))
+ (cuser (make-erc-channel-user :op t))
+ (erc-channel-users (make-hash-table :test #'equal)))
+ (puthash "bob" (cons user cuser) erc-channel-users)
+
+ (with-suppressed-warnings ((obsolete erc-format-@nick))
+ (should (erc-tests-common-equal-with-props
+ (erc-format-privmessage (erc-format-@nick user cuser)
+ (copy-sequence "oh my")
+ nil 'msgp)
+ expect)))
+ (let ((nick "Bob")
+ (msg "oh my"))
+ (should (erc-tests-common-equal-with-props
+ (erc-tests--format-privmessage nick msg nil 'msgp nil cuser)
+ expect)) ; overloaded on PREFIX arg
+ (should (erc-tests-common-equal-with-props
+ (erc-tests--format-privmessage nick msg nil 'msgp nil t)
+ expect))
+ ;; The new version makes a copy instead of adding properties to
+ ;; the input.
+ (should-not
+ (text-property-not-all 0 (length nick) 'font-lock-face nil nick))
+ (should-not
+ (text-property-not-all 0 (length msg) 'font-lock-face nil msg)))))
+
+(ert-deftest erc--determine-speaker-message-format-args/queries-as-channel ()
+ (should erc-format-query-as-channel-p)
+
+ (with-current-buffer (get-buffer-create "bob")
+ (erc-mode)
+ (setq erc--target (erc--target-from-string "alice"))
+
+ (insert "PRIVMSG\n"
+ (erc-tests--format-privmessage "bob" "oh my" 'queryp 'msgp))
+ (should (erc-tests-common-equal-with-props
+ #("<bob> oh my"
+ 0 1 (font-lock-face erc-default-face)
+ 1 4 (erc--speaker "bob" font-lock-face erc-nick-default-face)
+ 4 11 (font-lock-face erc-default-face))
+ (buffer-substring (pos-bol) (pos-eol))))
+
+ (insert "\nNOTICE\n"
+ (erc-tests--format-privmessage "bob" "oh my" 'queryp nil))
+ (should (erc-tests-common-equal-with-props
+ #("-bob- oh my"
+ 0 1 (font-lock-face erc-default-face)
+ 1 4 (erc--speaker "bob" font-lock-face erc-nick-default-face)
+ 4 11 (font-lock-face erc-default-face))
+ (buffer-substring (pos-bol) (pos-eol))))
+
+ (insert "\nInput PRIVMSG\n"
+ (erc-tests--format-privmessage "bob" "oh my"
+ 'queryp 'privmsgp 'inputp))
+ (should (erc-tests-common-equal-with-props
+ #("<bob> oh my"
+ 0 1 (font-lock-face erc-default-face)
+ 1 4 (erc--speaker "bob" font-lock-face erc-my-nick-face)
+ 4 6 (font-lock-face erc-default-face)
+ 6 11 (font-lock-face erc-input-face))
+ (buffer-substring (pos-bol) (pos-eol))))
+
+ (insert "\nInput NOTICE\n"
+ (erc-tests--format-privmessage "bob" "oh my" 'queryp nil 'inputp))
+ (should (erc-tests-common-equal-with-props
+ #("-bob- oh my"
+ 0 1 (font-lock-face erc-default-face)
+ 1 4 (erc--speaker "bob" font-lock-face erc-my-nick-face)
+ 4 6 (font-lock-face erc-default-face)
+ 6 11 (font-lock-face erc-input-face))
+ (buffer-substring (pos-bol) (pos-eol))))
+
+ (when noninteractive (kill-buffer))))
+
+(ert-deftest erc--determine-speaker-message-format-args/queries ()
+ (should erc-format-query-as-channel-p)
+
+ (with-current-buffer (get-buffer-create "bob")
+ (erc-mode)
+ (setq-local erc-format-query-as-channel-p nil)
+ (setq erc--target (erc--target-from-string "alice"))
+
+ (insert "PRIVMSG\n"
+ (erc-tests--format-privmessage "bob" "oh my" 'queryp 'msgp))
+ (should (erc-tests-common-equal-with-props
+ #("*bob* oh my"
+ 0 1 (font-lock-face erc-direct-msg-face)
+ 1 4 (erc--speaker "bob" font-lock-face erc-nick-msg-face)
+ 4 11 (font-lock-face erc-direct-msg-face))
+ (buffer-substring (pos-bol) (pos-eol))))
+
+ (insert "\nNOTICE\n"
+ (erc-tests--format-privmessage "bob" "oh my" 'queryp nil))
+ (should (erc-tests-common-equal-with-props
+ #("-bob- oh my"
+ 0 1 (font-lock-face erc-direct-msg-face)
+ 1 4 (erc--speaker "bob" font-lock-face erc-nick-msg-face)
+ 4 11 (font-lock-face erc-direct-msg-face))
+ (buffer-substring (pos-bol) (pos-eol))))
+
+ (insert "\nInput PRIVMSG\n"
+ (erc-tests--format-privmessage "bob" "oh my"
+ 'queryp 'privmsgp 'inputp))
+ (should (erc-tests-common-equal-with-props
+ #("*bob* oh my"
+ 0 1 (font-lock-face erc-direct-msg-face)
+ 1 4 (erc--speaker "bob" font-lock-face erc-my-nick-face)
+ 4 6 (font-lock-face erc-direct-msg-face)
+ 6 11 (font-lock-face erc-input-face))
+ (buffer-substring (pos-bol) (pos-eol))))
+
+ (insert "\nInput NOTICE\n"
+ (erc-tests--format-privmessage "bob" "oh my" 'queryp nil 'inputp))
+ (should (erc-tests-common-equal-with-props
+ #("-bob- oh my"
+ 0 1 (font-lock-face erc-direct-msg-face)
+ 1 4 (erc--speaker "bob" font-lock-face erc-my-nick-face)
+ 4 6 (font-lock-face erc-direct-msg-face)
+ 6 11 (font-lock-face erc-input-face))
+ (buffer-substring (pos-bol) (pos-eol))))
+
+ (when noninteractive (kill-buffer))))
+
+(defun erc-tests--format-my-nick (message)
+ (concat (erc-format-my-nick)
+ (propertize message 'font-lock-face 'erc-input-face)))
+
+;; This tests that the default behavior of the replacement formatting
+;; function for prompt input, `erc--format-speaker-input-message'
+;; matches that of the original being replaced, `erc-format-my-nick',
+;; though it only handled the speaker portion.
+(ert-deftest erc--format-speaker-input-message ()
+ ;; No status prefix.
+ (let ((erc-server-current-nick "tester")
+ (expect #("<tester> oh my"
+ 0 1 (font-lock-face erc-default-face)
+ 1 7 (font-lock-face erc-my-nick-face erc--speaker "tester")
+ 7 9 (font-lock-face erc-default-face)
+ 9 14 (font-lock-face erc-input-face))))
+ (should (equal (erc-tests--format-my-nick "oh my") expect))
+ (should (equal (erc--format-speaker-input-message "oh my") expect)))
+
+ ;; With channel-operator status prefix.
+ (let* ((erc-server-current-nick "tester")
+ (cmem (cons (make-erc-server-user :nickname "tester")
+ (make-erc-channel-user :op t)))
+ (erc-channel-users (map-into (list "tester" cmem)
+ '(hash-table :test equal)))
+ (expect #("<@tester> oh my"
+ 0 1 (font-lock-face erc-default-face)
+ 1 2 (font-lock-face erc-my-nick-prefix-face)
+ 2 5 (font-lock-face erc-my-nick-face erc--speaker "bob")
+ 5 7 (font-lock-face erc-default-face)
+ 7 12 (font-lock-face erc-input-face))))
+ (should (equal (erc-tests--format-my-nick "oh my") expect))
+ (should (equal (erc--format-speaker-input-message "oh my") expect))))
+
+(ert-deftest erc--route-insertion ()
+ (erc-tests-common-prep-for-insertion)
+ (erc-tests-common-init-server-proc "sleep" "1")
+ (setq erc-networks--id (erc-networks--id-create 'foonet))
+
+ (let* ((erc-modules) ; for `erc--open-target'
+ (server-buffer (current-buffer))
+ (spam-buffer (save-excursion (erc--open-target "#spam")))
+ (chan-buffer (save-excursion (erc--open-target "#chan")))
+ calls)
+ (cl-letf (((symbol-function 'erc-insert-line)
+ (lambda (&rest r) (push (cons 'line-1 r) calls))))
+
+ (with-current-buffer chan-buffer
+
+ (ert-info ("Null `buffer' routes to live server-buffer")
+ (erc--route-insertion "null" nil)
+ (should (equal (pop calls) `(line-1 "null" ,server-buffer)))
+ (should-not calls))
+
+ (ert-info ("Cons `buffer' routes to live members")
+ ;; Copies a let-bound `erc--msg-props' before mutating.
+ (let* ((table (map-into '(erc--msg msg) 'hash-table))
+ (erc--msg-props table))
+ (erc--route-insertion "cons" (list server-buffer spam-buffer))
+ (should-not (eq table erc--msg-props)))
+ (should (equal (pop calls) `(line-1 "cons" ,spam-buffer)))
+ (should (equal (pop calls) `(line-1 "cons" ,server-buffer)))
+ (should-not calls))
+
+ (ert-info ("Variant `all' inserts in all session buffers")
+ (erc--route-insertion "all" 'all)
+ (should (equal (pop calls) `(line-1 "all" ,chan-buffer)))
+ (should (equal (pop calls) `(line-1 "all" ,spam-buffer)))
+ (should (equal (pop calls) `(line-1 "all" ,server-buffer)))
+ (should-not calls))
+
+ (ert-info ("Variant `active' routes to active buffer if alive")
+ (should (eq chan-buffer (erc-with-server-buffer erc-active-buffer)))
+ (erc-set-active-buffer spam-buffer)
+ (erc--route-insertion "act" 'active)
+ (should (equal (pop calls) `(line-1 "act" ,spam-buffer)))
+ (should (eq (erc-active-buffer) spam-buffer))
+ (should-not calls))
+
+ (ert-info ("Variant `active' falls back to current buffer")
+ (should (eq spam-buffer (erc-active-buffer)))
+ (kill-buffer "#spam")
+ (erc--route-insertion "nact" 'active)
+ (should (equal (pop calls) `(line-1 "nact" ,server-buffer)))
+ (should (eq (erc-with-server-buffer erc-active-buffer)
+ server-buffer))
+ (should-not calls))
+
+ (ert-info ("Dead single buffer defaults to live server-buffer")
+ (should-not (get-buffer "#spam"))
+ (erc--route-insertion "dead" 'spam-buffer)
+ (should (equal (pop calls) `(line-1 "dead" ,server-buffer)))
+ (should-not calls))))
+
+ (should-not (buffer-live-p spam-buffer))
+ (kill-buffer chan-buffer)))
+
(defvar erc-tests--ipv6-examples
'("1:2:3:4:5:6:7:8"
"::ffff:10.0.0.1" "::ffff:1.2.3.4" "::ffff:0.0.0.0"
@@ -999,32 +2851,71 @@
(should (string-match erc--server-connect-dumb-ipv6-regexp
(concat "[" a "]")))))
+(ert-deftest erc--with-entrypoint-environment ()
+ (let ((env '((erc-join-buffer . foo)
+ (erc-server-connect-function . bar))))
+ (erc--with-entrypoint-environment env
+ (should (eq erc-join-buffer 'foo))
+ (should (eq erc-server-connect-function 'bar)))))
+
(ert-deftest erc-select-read-args ()
- (ert-info ("Does not default to TLS")
- (should (equal (ert-simulate-keys "\r\r\r\r"
+ (ert-info ("Prompts for switch to TLS by default")
+ (should (equal (ert-simulate-keys "\r\r\r\ry\r"
(erc-select-read-args))
(list :server "irc.libera.chat"
- :port 6667
+ :port 6697
:nick (user-login-name)
- :password nil))))
+ '--interactive-env--
+ '((erc-server-connect-function . erc-open-tls-stream)
+ (erc-join-buffer . window))))))
+
+ (ert-info ("Switches to TLS when port matches default TLS port")
+ (should (equal (ert-simulate-keys "irc.gnu.org\r6697\r\r\r"
+ (erc-select-read-args))
+ (list :server "irc.gnu.org"
+ :port 6697
+ :nick (user-login-name)
+ '--interactive-env--
+ '((erc-server-connect-function . erc-open-tls-stream)
+ (erc-join-buffer . window))))))
+
+ (ert-info ("Switches to TLS when URL is ircs://")
+ (let ((erc--display-context '((erc-interactive-display . erc))))
+ (should (equal (ert-simulate-keys "ircs://irc.gnu.org\r\r\r\r"
+ (erc-select-read-args))
+ (list :server "irc.gnu.org"
+ :port 6697
+ :nick (user-login-name)
+ '--interactive-env--
+ '((erc-server-connect-function
+ . erc-open-tls-stream)
+ (erc--display-context
+ . ((erc-interactive-display . erc)))
+ (erc-join-buffer . window)))))))
+
+ (setq-local erc-interactive-display nil) ; cheat to save space
+
+ (ert-info ("Opt out of non-TLS warning manually")
+ (should (equal (ert-simulate-keys "\r\r\r\rn\r"
+ (erc-select-read-args))
+ (list :server "irc.libera.chat"
+ :port 6667
+ :nick (user-login-name)))))
(ert-info ("Override default TLS")
(should (equal (ert-simulate-keys "irc://irc.libera.chat\r\r\r\r"
(erc-select-read-args))
(list :server "irc.libera.chat"
:port 6667
- :nick (user-login-name)
- :password nil))))
+ :nick (user-login-name)))))
(ert-info ("Address includes port")
- (should (equal (ert-simulate-keys
- "localhost:6667\rnick\r\r"
+ (should (equal (ert-simulate-keys "localhost:6667\rnick\r\r"
(erc-select-read-args))
(list :server "localhost"
:port 6667
- :nick "nick"
- :password nil))))
+ :nick "nick"))))
(ert-info ("Address includes nick, password skipped via option")
(should (equal (ert-simulate-keys "nick@localhost:6667\r"
@@ -1032,8 +2923,7 @@
(erc-select-read-args)))
(list :server "localhost"
:port 6667
- :nick "nick"
- :password nil))))
+ :nick "nick"))))
(ert-info ("Address includes nick and password")
(should (equal (ert-simulate-keys "nick:sesame@localhost:6667\r\r"
@@ -1048,37 +2938,55 @@
(erc-select-read-args))
(list :server "[::1]"
:port 6667
- :nick (user-login-name)
- :password nil))))
+ :nick (user-login-name)))))
(ert-info ("IPv6 address with port")
(should (equal (ert-simulate-keys "[::1]:6667\r\r\r"
(erc-select-read-args))
(list :server "[::1]"
:port 6667
- :nick (user-login-name)
- :password nil))))
+ :nick (user-login-name)))))
(ert-info ("IPv6 address includes nick")
(should (equal (ert-simulate-keys "nick@[::1]:6667\r\r"
(erc-select-read-args))
(list :server "[::1]"
:port 6667
+ :nick "nick"))))
+
+ (ert-info ("Extra args use URL nick by default")
+ (should (equal (ert-simulate-keys "nick:sesame@localhost:6667\r\r\r\r"
+ (let ((current-prefix-arg '(4)))
+ (erc-select-read-args)))
+ (list :server "localhost"
+ :port 6667
:nick "nick"
- :password nil)))))
+ :user "nick"
+ :password "sesame"
+ :full-name "nick")))))
(ert-deftest erc-tls ()
- (let (calls)
+ (let (calls env)
(cl-letf (((symbol-function 'user-login-name)
(lambda (&optional _) "tester"))
((symbol-function 'erc-open)
- (lambda (&rest r) (push r calls))))
+ (lambda (&rest r)
+ (push `((erc-join-buffer ,erc-join-buffer)
+ (erc--display-context ,@erc--display-context)
+ (erc-server-connect-function
+ ,erc-server-connect-function))
+ env)
+ (push r calls))))
(ert-info ("Defaults")
(erc-tls)
(should (equal (pop calls)
'("irc.libera.chat" 6697 "tester" "unknown" t
- nil nil nil nil nil "user" nil))))
+ nil nil nil nil nil "user" nil)))
+ (should (equal (pop env)
+ '((erc-join-buffer bury)
+ (erc--display-context (erc-buffer-display . erc-tls))
+ (erc-server-connect-function erc-open-tls-stream)))))
(ert-info ("Full")
(erc-tls :server "irc.gnu.org"
@@ -1091,7 +2999,11 @@
:id 'GNU.org)
(should (equal (pop calls)
'("irc.gnu.org" 7000 "bob" "Bob's Name" t
- "bob:changeme" nil nil nil t "bobo" GNU.org))))
+ "bob:changeme" nil nil nil t "bobo" GNU.org)))
+ (should (equal (pop env)
+ '((erc-join-buffer bury)
+ (erc--display-context (erc-buffer-display . erc-tls))
+ (erc-server-connect-function erc-open-tls-stream)))))
;; Values are often nil when called by lisp code, which leads to
;; null params. This is why `erc-open' recomputes almost
@@ -1107,31 +3019,141 @@
:password "bob:changeme"))
(should (equal (pop calls)
'(nil 7000 nil "Bob's Name" t
- "bob:changeme" nil nil nil nil "bobo" nil)))))))
-
-(defun erc-tests--make-server-buf (name)
- (with-current-buffer (get-buffer-create name)
- (erc-mode)
- (setq erc-server-process (start-process "sleep" (current-buffer)
- "sleep" "1")
- erc-session-server (concat "irc." name ".org")
- erc-session-port 6667
- erc-network (intern name))
- (set-process-query-on-exit-flag erc-server-process nil)
- (current-buffer)))
-
-(defun erc-tests--make-client-buf (server name)
- (unless (bufferp server)
- (setq server (get-buffer server)))
- (with-current-buffer (get-buffer-create name)
- (erc-mode)
- (setq erc--target (erc--target-from-string name))
- (dolist (v '(erc-server-process
- erc-session-server
- erc-session-port
- erc-network))
- (set v (buffer-local-value v server)))
- (current-buffer)))
+ "bob:changeme" nil nil nil nil "bobo" nil)))
+ (should (equal (pop env)
+ '((erc-join-buffer bury)
+ (erc--display-context (erc-buffer-display . erc-tls))
+ (erc-server-connect-function erc-open-tls-stream)))))
+
+ (ert-info ("Interactive")
+ (ert-simulate-keys "nick:sesame@localhost:6667\r\r"
+ (call-interactively #'erc-tls))
+ (should (equal (pop calls)
+ '("localhost" 6667 "nick" "unknown" t "sesame"
+ nil nil nil nil "user" nil)))
+ (should (equal (pop env)
+ '((erc-join-buffer window)
+ (erc--display-context
+ (erc-interactive-display . erc-tls))
+ (erc-server-connect-function erc-open-tls-stream)))))
+
+ (ert-info ("Custom connect function")
+ (let ((erc-server-connect-function 'my-connect-func))
+ (erc-tls)
+ (should (equal (pop calls)
+ '("irc.libera.chat" 6697 "tester" "unknown" t
+ nil nil nil nil nil "user" nil)))
+ (should (equal (pop env)
+ '((erc-join-buffer bury)
+ (erc--display-context
+ (erc-buffer-display . erc-tls))
+ (erc-server-connect-function my-connect-func))))))
+
+ (ert-info ("Advised default function overlooked") ; intentional
+ (advice-add 'erc-server-connect-function :around #'ignore
+ '((name . erc-tests--erc-tls)))
+ (erc-tls)
+ (should (equal (pop calls)
+ '("irc.libera.chat" 6697 "tester" "unknown" t
+ nil nil nil nil nil "user" nil)))
+ (should (equal (pop env)
+ '((erc-join-buffer bury)
+ (erc--display-context (erc-buffer-display . erc-tls))
+ (erc-server-connect-function erc-open-tls-stream))))
+ (advice-remove 'erc-server-connect-function 'erc-tests--erc-tls))
+
+ (ert-info ("Advised non-default function honored")
+ (let ((f (lambda (&rest r) (ignore r))))
+ (cl-letf (((symbol-value 'erc-server-connect-function) f))
+ (advice-add 'erc-server-connect-function :around #'ignore
+ '((name . erc-tests--erc-tls)))
+ (erc-tls)
+ (should (equal (pop calls)
+ '("irc.libera.chat" 6697 "tester" "unknown" t
+ nil nil nil nil nil "user" nil)))
+ (should (equal (pop env) `((erc-join-buffer bury)
+ (erc--display-context
+ (erc-buffer-display . erc-tls))
+ (erc-server-connect-function ,f))))
+ (advice-remove 'erc-server-connect-function
+ 'erc-tests--erc-tls)))))))
+
+;; See `erc-select-read-args' above for argument parsing.
+;; This only tests the "hidden" arguments.
+
+(ert-deftest erc--interactive ()
+ (let (calls env)
+ (cl-letf (((symbol-function 'user-login-name)
+ (lambda (&optional _) "tester"))
+ ((symbol-function 'erc-open)
+ (lambda (&rest r)
+ (push `((erc-join-buffer ,erc-join-buffer)
+ (erc--display-context ,@erc--display-context)
+ (erc-server-connect-function
+ ,erc-server-connect-function))
+ env)
+ (push r calls))))
+
+ (ert-info ("Default click-through accept TLS upgrade")
+ (ert-simulate-keys "\r\r\r\ry\r"
+ (call-interactively #'erc))
+ (should (equal (pop calls)
+ '("irc.libera.chat" 6697 "tester" "unknown" t nil
+ nil nil nil nil "user" nil)))
+ (should (equal (pop env)
+ '((erc-join-buffer window)
+ (erc--display-context (erc-interactive-display . erc))
+ (erc-server-connect-function erc-open-tls-stream)))))
+
+ (ert-info ("Nick supplied, decline TLS upgrade")
+ (ert-simulate-keys "\r\rdummy\r\rn\r"
+ (call-interactively #'erc))
+ (should (equal (pop calls)
+ '("irc.libera.chat" 6667 "dummy" "unknown" t nil
+ nil nil nil nil "user" nil)))
+ (should (equal (pop env)
+ '((erc-join-buffer window)
+ (erc--display-context (erc-interactive-display . erc))
+ (erc-server-connect-function
+ erc-open-network-stream))))))))
+
+(ert-deftest erc-server-select ()
+ (let (calls env)
+ (cl-letf (((symbol-function 'user-login-name)
+ (lambda (&optional _) "tester"))
+ ((symbol-function 'erc-open)
+ (lambda (&rest r)
+ (push `((erc-join-buffer ,erc-join-buffer)
+ (erc--display-context ,@erc--display-context)
+ (erc-server-connect-function
+ ,erc-server-connect-function))
+ env)
+ (push r calls))))
+
+ (ert-info ("Selects Libera.Chat Europe, automatic TSL")
+ (ert-simulate-keys "Libera.Chat\rirc.eu.\t\r\r\r"
+ (with-suppressed-warnings ((obsolete erc-server-select))
+ (call-interactively #'erc-server-select)))
+ (should (equal (pop calls)
+ '("irc.eu.libera.chat" 6697 "tester" "unknown" t nil
+ nil nil nil nil "user" nil)))
+ (should (equal (pop env)
+ '((erc-join-buffer window)
+ (erc--display-context (erc-interactive-display . erc))
+ (erc-server-connect-function erc-open-tls-stream)))))
+
+ (ert-info ("Selects entry that doesn't support TLS")
+ (ert-simulate-keys "IRCnet\rirc.fr.\t\rdummy\r\r"
+ (with-suppressed-warnings ((obsolete erc-server-select))
+ (call-interactively #'erc-server-select)))
+ (should (equal (pop calls)
+ '("irc.fr.ircnet.net" 6667 "dummy" "unknown" t nil
+ nil nil nil nil "user" nil)))
+ (should (equal (pop env)
+ '((erc-join-buffer window)
+ (erc--display-context (erc-interactive-display . erc))
+ (erc-server-connect-function
+ erc-open-network-stream))))))))
(ert-deftest erc-handle-irc-url ()
(let* (calls
@@ -1146,10 +3168,10 @@
(cl-letf (((symbol-function 'erc-cmd-JOIN)
(lambda (&rest r) (push r calls))))
- (with-current-buffer (erc-tests--make-server-buf "foonet")
+ (with-current-buffer (erc-tests-common-make-server-buf "foonet")
(setq rvbuf (current-buffer)))
- (erc-tests--make-server-buf "barnet")
- (erc-tests--make-server-buf "baznet")
+ (erc-tests-common-make-server-buf "barnet")
+ (erc-tests-common-make-server-buf "baznet")
(ert-info ("Unknown network")
(erc-handle-irc-url "irc.foonet.org" 6667 "#chan" nil nil "irc")
@@ -1173,7 +3195,8 @@
(should-not calls))
(ert-info ("Known network, existing chan with key")
- (erc-tests--make-client-buf "foonet" "#chan")
+ (save-excursion
+ (with-current-buffer "foonet" (erc--open-target "#chan")))
(erc-handle-irc-url "irc.foonet.org" nil "#chan?sec" nil nil "irc")
(should (equal '("#chan" "sec") (pop calls)))
(should-not calls))
@@ -1186,7 +3209,7 @@
(ert-info ("Unknown network, connect, chan")
(with-current-buffer "foonet"
(should-not (local-variable-p 'erc-after-connect)))
- (setq rvbuf (lambda () (erc-tests--make-server-buf "gnu")))
+ (setq rvbuf (lambda () (erc-tests-common-make-server-buf "gnu")))
(erc-handle-irc-url "irc.gnu.org" nil "#spam" nil nil "irc")
(should (equal '("irc" :server "irc.gnu.org") (pop calls)))
(should-not calls)
@@ -1198,10 +3221,142 @@
(should-not calls))))
(when noninteractive
- (kill-buffer "foonet")
- (kill-buffer "barnet")
- (kill-buffer "baznet")
- (kill-buffer "#chan")))
+ (erc-tests-common-kill-buffers)))
+
+(ert-deftest erc-channel-user ()
+ ;; Traditional and alternate constructor swapped for compatibility.
+ (should (= 0 (erc-channel-user-status (erc-channel-user--make))))
+ (should-not (erc-channel-user-last-message-time (erc-channel-user--make)))
+
+ (should (= 42 (erc-channel-user-last-message-time
+ (make-erc-channel-user :last-message-time 42))))
+
+ (should (zerop (erc-channel-user-status (make-erc-channel-user))))
+
+ (let ((u (make-erc-channel-user)))
+
+ (ert-info ("Add voice status to user")
+ (should (= 0 (erc-channel-user-status u)))
+ (should-not (erc-channel-user-voice u))
+ (should (eq t (setf (erc-channel-user-voice u) t)))
+ (should (eq t (erc-channel-user-voice u))))
+
+ (ert-info ("Add op status to user")
+ (should (= 1 (erc-channel-user-status u)))
+ (should-not (erc-channel-user-op u))
+ (should (eq t (setf (erc-channel-user-op u) t)))
+ (should (eq t (erc-channel-user-op u))))
+
+ (ert-info ("Add owner status to user")
+ (should (= 5 (erc-channel-user-status u)))
+ (should-not (erc-channel-user-owner u))
+ (should (eq t (setf (erc-channel-user-owner u) t)))
+ (should (eq t (erc-channel-user-owner u))))
+
+ (ert-info ("Remove owner status from user")
+ (should (= 21 (erc-channel-user-status u)))
+ (should-not (setf (erc-channel-user-owner u) nil))
+ (should-not (erc-channel-user-owner u)))
+
+ (ert-info ("Remove op status from user")
+ (should (= 5 (erc-channel-user-status u)))
+ (should-not (setf (erc-channel-user-op u) nil))
+ (should-not (erc-channel-user-op u)))
+
+ (ert-info ("Remove voice status from user")
+ (should (= 1 (erc-channel-user-status u)))
+ (should-not (setf (erc-channel-user-voice u) nil))
+ (should-not (erc-channel-user-voice u)))
+
+ (ert-info ("Remove voice status from zeroed user")
+ (should (= 0 (erc-channel-user-status u)))
+ (should-not (setf (erc-channel-user-voice u) nil))
+ (should-not (erc-channel-user-voice u))
+ (should (= 0 (erc-channel-user-status u))))))
+
+(defconst erc-tests--modules
+ '( autoaway autojoin bufbar button capab-identify
+ command-indicator completion dcc fill identd
+ imenu irccontrols keep-place list log match menu move-to-prompt netsplit
+ networks nickbar nicks noncommands notifications notify page readonly
+ replace ring sasl scrolltobottom services smiley sound
+ spelling stamp track truncate unmorse xdcc))
+
+;; Ensure that `:initialize' doesn't change the ordering of the
+;; members because otherwise the widget's state is "edited".
+
+(ert-deftest erc-modules--initialize ()
+ ;; This is `custom--standard-value' from Emacs 28.
+ (should (equal (eval (car (get 'erc-modules 'standard-value)) t)
+ erc-modules)))
+
+;; Ensure the `:initialize' function for `erc-modules' successfully
+;; tags all built-in modules with the internal property `erc--module'.
+
+(ert-deftest erc-modules--internal-property ()
+ (let (ours)
+ (mapatoms (lambda (s)
+ (when-let ((v (get s 'erc--module))
+ ((eq v s)))
+ (push s ours))))
+ (should (equal (sort ours #'string-lessp) erc-tests--modules))))
+
+(ert-deftest erc--normalize-module-symbol ()
+ (dolist (mod erc-tests--modules)
+ (should (eq (erc--normalize-module-symbol mod) mod)))
+ (should (eq (erc--normalize-module-symbol 'pcomplete) 'completion))
+ (should (eq (erc--normalize-module-symbol 'Completion) 'completion))
+ (should (eq (erc--normalize-module-symbol 'ctcp-page) 'page))
+ (should (eq (erc--normalize-module-symbol 'ctcp-sound) 'sound))
+ (should (eq (erc--normalize-module-symbol 'timestamp) 'stamp))
+ (should (eq (erc--normalize-module-symbol 'nickserv) 'services)))
+
+(defun erc-tests--assert-printed-in-subprocess (code expected)
+ (let ((proc (erc-tests-common-create-subprocess code '("-batch") nil)))
+ (while (accept-process-output proc 10))
+ (goto-char (point-min))
+ (unless (equal (read (current-buffer)) expected)
+ (message "Expected: %S\nGot: %s" expected (buffer-string))
+ (ert-fail "Mismatch"))))
+
+;; Worrying about which library a module comes from is mostly not
+;; worth the hassle so long as ERC can find its minor mode. However,
+;; bugs involving multiple modules living in the same library may slip
+;; by because a module's loading problems may remain hidden on account
+;; of its place in the default ordering.
+
+(ert-deftest erc--find-mode ()
+ (erc-tests--assert-printed-in-subprocess
+ `(let ((mods (mapcar #'cadddr (cdddr (get 'erc-modules 'custom-type))))
+ moded)
+ (setq mods (sort mods (lambda (a b) (if (zerop (random 2)) a b))))
+ (dolist (mod mods)
+ (unless (keywordp mod)
+ (push (if-let ((mode (erc--find-mode mod))) mod (list :missing mod))
+ moded)))
+ (message "%S"
+ (sort moded (lambda (a b)
+ (string< (symbol-name a) (symbol-name b))))))
+ erc-tests--modules))
+
+(ert-deftest erc--essential-hook-ordering ()
+ (erc-tests--assert-printed-in-subprocess
+ '(progn
+ (erc-update-modules)
+ (message "%S"
+ (list :erc-insert-modify-hook erc-insert-modify-hook
+ :erc-send-modify-hook erc-send-modify-hook)))
+
+ '( :erc-insert-modify-hook (erc-controls-highlight ; 0
+ erc-button-add-buttons ; 30
+ erc-match-message ; 50
+ erc-fill ; 60
+ erc-add-timestamp) ; 70
+
+ :erc-send-modify-hook ( erc-controls-highlight ; 0
+ erc-button-add-buttons ; 30
+ erc-fill ; 40
+ erc-add-timestamp)))) ; 70
(ert-deftest erc-migrate-modules ()
(should (equal (erc-migrate-modules '(autojoin timestamp button))
@@ -1209,46 +3364,163 @@
;; Default unchanged
(should (equal (erc-migrate-modules erc-modules) erc-modules)))
-(ert-deftest erc--update-modules ()
- (let (calls
- erc-modules
- erc-kill-channel-hook erc-kill-server-hook erc-kill-buffer-hook)
- (cl-letf (((symbol-function 'require)
- (lambda (s &rest _) (push s calls)))
-
- ;; Local modules
- ((symbol-function 'erc-fake-bar-mode)
- (lambda (n) (push (cons 'fake-bar n) calls)))
+(ert-deftest erc--find-group ()
+ ;; These two are loaded by default
+ (should (eq (erc--find-group 'keep-place nil) 'erc))
+ (should (eq (erc--find-group 'networks nil) 'erc-networks))
+ ;; These are fake
+ (cl-letf (((get 'erc-bar 'group-documentation) "")
+ ((get 'baz 'erc-group) 'erc-foo))
+ (should (eq (erc--find-group 'foo 'bar) 'erc-bar))
+ (should (eq (erc--find-group 'bar 'foo) 'erc-bar))
+ (should (eq (erc--find-group 'bar nil) 'erc-bar))
+ (should (eq (erc--find-group 'foo nil) 'erc))
+ (should (eq (erc--find-group 'fake 'baz) 'erc-foo))))
+
+(ert-deftest erc--find-group--real ()
+ :tags '(:unstable)
+ (require 'erc-services)
+ (require 'erc-stamp)
+ (require 'erc-sound)
+ (require 'erc-page)
+ (require 'erc-join)
+ (require 'erc-capab)
+ (require 'erc-pcomplete)
+ (should (eq (erc--find-group 'services 'nickserv) 'erc-services))
+ (should (eq (erc--find-group 'stamp 'timestamp) 'erc-stamp))
+ (should (eq (erc--find-group 'sound 'ctcp-sound) 'erc-sound))
+ (should (eq (erc--find-group 'page 'ctcp-page) 'erc-page))
+ (should (eq (erc--find-group 'autojoin) 'erc-autojoin))
+ (should (eq (erc--find-group 'pcomplete 'Completion) 'erc-pcomplete))
+ (should (eq (erc--find-group 'capab-identify) 'erc-capab))
+ (should (eq (erc--find-group 'completion) 'erc-pcomplete))
+ ;; No group specified.
+ (should (eq (erc--find-group 'smiley nil) 'erc))
+ (should (eq (erc--find-group 'unmorse nil) 'erc)))
+
+(ert-deftest erc--sort-modules ()
+ (should (equal (erc--sort-modules '(networks foo fill bar fill stamp bar))
+ ;; Third-party mods appear in original order.
+ '(fill networks stamp foo bar))))
+
+(defun erc-tests--update-modules (fn)
+ (let* ((calls nil)
+ (custom-modes nil)
+ (on-load nil)
+ (text-quoting-style 'grave)
+
+ (get-calls (lambda () (prog1 (nreverse calls) (setq calls nil))))
+
+ (add-onload (lambda (m k v)
+ (put (intern m) 'erc--feature k)
+ (push (cons k (lambda () (funcall v m))) on-load)))
+
+ (mk-cmd (lambda (module)
+ (let ((mode (intern (format "erc-%s-mode" module))))
+ (fset mode (lambda (n) (push (cons mode n) calls))))))
+
+ (mk-builtin (lambda (module-string)
+ (let ((s (intern module-string)))
+ (put s 'erc--module s))))
+
+ (mk-global (lambda (module)
+ (push (intern (format "erc-%s-mode" module))
+ custom-modes))))
- ;; Global modules
- ((symbol-function 'erc-fake-foo-mode)
- (lambda (n) (push (cons 'fake-foo n) calls)))
- ((get 'erc-fake-foo-mode 'standard-value) 'ignore)
+ (cl-letf (((symbol-function 'require)
+ (lambda (s &rest _)
+ ;; Simulate library being loaded, things defined.
+ (when-let ((h (alist-get s on-load))) (funcall h))
+ (push (cons 'req s) calls)))
+
+ ;; Spoof global module detection.
+ ((symbol-function 'custom-variable-p)
+ (lambda (v) (memq v custom-modes))))
+
+ (funcall fn get-calls add-onload mk-cmd mk-builtin mk-global))
+ (should-not erc--aberrant-modules)))
+
+(ert-deftest erc--update-modules/unknown ()
+ (erc-tests--update-modules
+
+ (lambda (get-calls _ mk-cmd _ mk-global)
+
+ (ert-info ("Baseline")
+ (let* ((erc-modules '(foo))
+ (obarray (obarray-make))
+ (err (should-error (erc--update-modules erc-modules))))
+ (should (equal (cadr err) "`foo' is not a known ERC module"))
+ (should (equal (mapcar #'prin1-to-string (funcall get-calls))
+ '("(req . erc-foo)")))))
+
+ ;; Module's mode command exists but lacks an associated file.
+ (ert-info ("Bad autoload flagged as suspect")
+ (should-not erc--aberrant-modules)
+ (let* ((erc--aberrant-modules nil)
+ (obarray (obarray-make))
+ (erc-modules (list (intern "foo"))))
+
+ ;; Create a mode-activation command and make mode-var global.
+ (funcall mk-cmd "foo")
+ (funcall mk-global "foo")
+
+ ;; No local modules to return.
+ (should-not (erc--update-modules erc-modules))
+ (should (equal (mapcar #'prin1-to-string erc--aberrant-modules)
+ '("foo")))
+ ;; ERC requires the library via prefixed module name.
+ (should (equal (mapcar #'prin1-to-string (funcall get-calls))
+ '("(req . erc-foo)" "(erc-foo-mode . 1)"))))))))
+
+;; A local module (here, `lo2') lacks a mode toggle, so ERC tries to
+;; load its defining library, first via the symbol property
+;; `erc--feature', and then via an "erc-" prefixed symbol.
+(ert-deftest erc--update-modules/local ()
+ (erc-tests--update-modules
+
+ (lambda (get-calls add-onload mk-cmd mk-builtin mk-global)
+
+ (let* ((obarray (obarray-make 20))
+ (erc-modules (mapcar #'intern '("glo" "lo1" "lo2"))))
+
+ ;; Create a global and a local module.
+ (mapc mk-cmd '("glo" "lo1"))
+ (mapc mk-builtin '("glo" "lo1"))
+ (funcall mk-global "glo")
+ (funcall add-onload "lo2" 'explicit-feature-lib mk-cmd)
+
+ ;; Returns local modules.
+ (should (equal (mapcar #'symbol-name (erc--update-modules erc-modules))
+ '("erc-lo2-mode" "erc-lo1-mode")))
+
+ ;; Requiring `erc-lo2' defines `erc-lo2-mode'.
+ (should (equal (mapcar #'prin1-to-string (funcall get-calls))
+ `("(erc-glo-mode . 1)"
+ "(req . explicit-feature-lib)")))))))
+
+(ert-deftest erc--update-modules/realistic ()
+ (let ((calls nil)
+ ;; Module `pcomplete' "resolves" to `completion'.
+ (erc-modules '(pcomplete autojoin networks)))
+ (cl-letf (((symbol-function 'require)
+ (lambda (s &rest _) (push (cons 'req s) calls)))
+
+ ;; Spoof global module detection.
+ ((symbol-function 'custom-variable-p)
+ (lambda (v)
+ (memq v '(erc-autojoin-mode erc-networks-mode
+ erc-completion-mode))))
+ ;; Mock and spy real builtins.
((symbol-function 'erc-autojoin-mode)
(lambda (n) (push (cons 'autojoin n) calls)))
- ((get 'erc-autojoin-mode 'standard-value) 'ignore)
((symbol-function 'erc-networks-mode)
(lambda (n) (push (cons 'networks n) calls)))
- ((get 'erc-networks-mode 'standard-value) 'ignore)
((symbol-function 'erc-completion-mode)
- (lambda (n) (push (cons 'completion n) calls)))
- ((get 'erc-completion-mode 'standard-value) 'ignore))
-
- (ert-info ("Local modules")
- (setq erc-modules '(fake-foo fake-bar))
- (should (equal (erc--update-modules) '(erc-fake-bar-mode)))
- ;; Bar the feature is still required but the mode is not activated
- (should (equal (nreverse calls)
- '(erc-fake-foo (fake-foo . 1) erc-fake-bar)))
- (setq calls nil))
-
- (ert-info ("Module name overrides")
- (setq erc-modules '(completion autojoin networks))
- (should-not (erc--update-modules)) ; no locals
- (should (equal (nreverse calls) '( erc-pcomplete (completion . 1)
- erc-join (autojoin . 1)
- erc-networks (networks . 1))))
- (setq calls nil)))))
+ (lambda (n) (push (cons 'completion n) calls))))
+
+ (should-not (erc--update-modules erc-modules)) ; no locals
+ (should (equal (nreverse calls)
+ '((completion . 1) (autojoin . 1) (networks . 1)))))))
(ert-deftest erc--merge-local-modes ()
(cl-letf (((get 'erc-b-mode 'erc-module) 'b)
@@ -1276,36 +3548,51 @@
(ert-deftest define-erc-module--global ()
(let ((global-module '(define-erc-module mname malias
- "Some docstring"
+ "Some docstring."
((ignore a) (ignore b))
((ignore c) (ignore d)))))
- (should (equal (macroexpand global-module)
+ (should (equal (cl-letf (((symbol-function
+ 'erc--prepare-custom-module-type)
+ #'symbol-name))
+ (macroexpand global-module))
`(progn
(define-minor-mode erc-mname-mode
"Toggle ERC mname mode.
-With a prefix argument ARG, enable mname if ARG is positive,
-and disable it otherwise. If called from Lisp, enable the mode
-if ARG is omitted or nil.
-Some docstring"
+With a prefix argument ARG, enable mname if ARG is positive, and
+disable it otherwise. If called from Lisp, enable the mode if
+ARG is omitted or nil.
+
+Some docstring."
:global t
- :group 'erc-mname
- (if erc-mname-mode
- (erc-mname-enable)
- (erc-mname-disable)))
+ :group (erc--find-group 'mname 'malias)
+ :require 'nil
+ :type "mname"
+ (let ((erc--module-toggle-prefix-arg arg))
+ (if erc-mname-mode
+ (erc-mname-enable)
+ (erc-mname-disable))))
(defun erc-mname-enable ()
"Enable ERC mname mode."
(interactive)
- (cl-pushnew 'mname erc-modules)
+ (unless (or erc--inside-mode-toggle-p
+ (memq 'mname erc-modules))
+ (let ((erc--inside-mode-toggle-p t))
+ (erc--favor-changed-reverted-modules-state
+ 'mname #'cons)))
(setq erc-mname-mode t)
(ignore a) (ignore b))
(defun erc-mname-disable ()
"Disable ERC mname mode."
(interactive)
- (setq erc-modules (delq 'mname erc-modules))
+ (unless (or erc--inside-mode-toggle-p
+ (not (memq 'mname erc-modules)))
+ (let ((erc--inside-mode-toggle-p t))
+ (erc--favor-changed-reverted-modules-state
+ 'mname #'delq)))
(setq erc-mname-mode nil)
(ignore c) (ignore d))
@@ -1319,7 +3606,7 @@ Some docstring"
(ert-deftest define-erc-module--local ()
(let* ((global-module '(define-erc-module mname nil ; no alias
- "Some docstring"
+ "Some docstring."
((ignore a) (ignore b))
((ignore c) (ignore d))
'local))
@@ -1331,19 +3618,22 @@ Some docstring"
`(progn
(define-minor-mode erc-mname-mode
"Toggle ERC mname mode.
-With a prefix argument ARG, enable mname if ARG is positive,
-and disable it otherwise. If called from Lisp, enable the mode
-if ARG is omitted or nil.
-Some docstring"
+With a prefix argument ARG, enable mname if ARG is positive, and
+disable it otherwise. If called from Lisp, enable the mode if
+ARG is omitted or nil.
+
+Some docstring."
:global nil
- :group 'erc-mname
- (if erc-mname-mode
- (erc-mname-enable)
- (erc-mname-disable)))
+ :group (erc--find-group 'mname nil)
+ (let ((erc--module-toggle-prefix-arg arg))
+ (if erc-mname-mode
+ (erc-mname-enable)
+ (erc-mname-disable))))
(defun erc-mname-enable (&optional ,arg-en)
"Enable ERC mname mode.
-When called interactively, do so in all buffers for the current connection."
+When called interactively, do so in all buffers for the current
+connection."
(interactive "p")
(when (derived-mode-p 'erc-mode)
(if ,arg-en
@@ -1355,7 +3645,8 @@ When called interactively, do so in all buffers for the current connection."
(defun erc-mname-disable (&optional ,arg-dis)
"Disable ERC mname mode.
-When called interactively, do so in all buffers for the current connection."
+When called interactively, do so in all buffers for the current
+connection."
(interactive "p")
(when (derived-mode-p 'erc-mode)
(if ,arg-dis
@@ -1370,4 +3661,100 @@ When called interactively, do so in all buffers for the current connection."
(put 'erc-mname-enable 'definition-name 'mname)
(put 'erc-mname-disable 'definition-name 'mname))))))
+(ert-deftest erc-tests-common-string-to-propertized-parts ()
+ :tags '(:unstable) ; only run this locally
+ (unless (>= emacs-major-version 28) (ert-skip "Missing `object-intervals'"))
+
+ (should (equal (erc-tests-common-string-to-propertized-parts
+ #("abc"
+ 0 1 (face default foo 1)
+ 1 3 (face (default italic) bar "2")))
+ '(concat (propertize "a" 'foo 1 'face 'default)
+ (propertize "bc" 'bar "2" 'face '(default italic)))))
+ (should (equal #("abc"
+ 0 1 (face default foo 1)
+ 1 3 (face (default italic) bar "2"))
+ (concat (propertize "a" 'foo 1 'face 'default)
+ (propertize "bc" 'bar "2" 'face '(default italic))))))
+
+(ert-deftest erc--make-message-variable-name ()
+ (should (erc--make-message-variable-name 'english 'QUIT 'softp))
+ (should (erc--make-message-variable-name 'english 'QUIT nil))
+
+ (let ((obarray (obarray-make)))
+ (should-not (erc--make-message-variable-name 'testcat 'testkey 'softp))
+ (should (erc--make-message-variable-name 'testcat 'testkey nil))
+ (should (intern-soft "erc-message-testcat-testkey" obarray))
+ (should-not (erc--make-message-variable-name 'testcat 'testkey 'softp))
+ (set (intern "erc-message-testcat-testkey" obarray) "hello world")
+ (should (equal (symbol-value
+ (erc--make-message-variable-name 'testcat 'testkey nil))
+ "hello world")))
+
+ ;; Hyphenated (internal catalog).
+ (let ((obarray (obarray-make)))
+ (should-not (erc--make-message-variable-name '-testcat 'testkey 'softp))
+ (should (erc--make-message-variable-name '-testcat 'testkey nil))
+ (should (intern-soft "erc--message-testcat-testkey" obarray))
+ (should-not (erc--make-message-variable-name '-testcat 'testkey 'softp))
+ (set (intern "erc--message-testcat-testkey" obarray) "hello world")
+ (should (equal (symbol-value
+ (erc--make-message-variable-name '-testcat 'testkey nil))
+ "hello world"))))
+
+(ert-deftest erc-retrieve-catalog-entry ()
+ (should (eq 'english erc-current-message-catalog))
+ (should (equal (erc-retrieve-catalog-entry 's221) "User modes for %n: %m"))
+
+ ;; Local binding.
+ (with-temp-buffer
+ (should (equal (erc-retrieve-catalog-entry 's221) "User modes for %n: %m"))
+ (setq erc-current-message-catalog 'test)
+ ;; No catalog named `test'.
+ (should (equal (erc-retrieve-catalog-entry 's221) "User modes for %n: %m"))
+
+ (let ((obarray (obarray-make)))
+ (set (intern "erc-message-test-s221") "test 221 val")
+ (should (equal (erc-retrieve-catalog-entry 's221) "test 221 val"))
+ (set (intern "erc-message-english-s221") "eng 221 val")
+
+ (let ((erc-current-message-catalog 'english))
+ (should (equal (erc-retrieve-catalog-entry 's221) "eng 221 val")))
+
+ (with-temp-buffer
+ (should (equal (erc-retrieve-catalog-entry 's221) "eng 221 val"))
+ (let ((erc-current-message-catalog 'test))
+ (should (equal (erc-retrieve-catalog-entry 's221) "test 221 val"))))
+
+ (should (equal (erc-retrieve-catalog-entry 's221) "test 221 val")))
+
+ (should (equal (erc-retrieve-catalog-entry 's221) "User modes for %n: %m"))
+ (should (equal erc-current-message-catalog 'test)))
+
+ ;; Default top-level value.
+ (set-default-toplevel-value 'erc-current-message-catalog 'test-top)
+ (should (equal (erc-retrieve-catalog-entry 's221) "User modes for %n: %m"))
+ (set (intern "erc-message-test-top-s221") "test-top 221 val")
+ (should (equal (erc-retrieve-catalog-entry 's221) "test-top 221 val"))
+
+ (setq erc-current-message-catalog 'test-local)
+ (should (equal (erc-retrieve-catalog-entry 's221) "test-top 221 val"))
+
+ (makunbound (intern "erc-message-test-top-s221"))
+ (unintern "erc-message-test-top-s221" obarray)
+
+ ;; Inheritance.
+ (let ((obarray (obarray-make)))
+ (set (intern "erc-message-test1-abc") "val test1 abc")
+ (set (intern "erc-message-test2-abc") "val test2 abc")
+ (set (intern "erc-message-test2-def") "val test2 def")
+ (put (intern "test0") 'erc--base-format-catalog (intern "test1"))
+ (put (intern "test1") 'erc--base-format-catalog (intern "test2"))
+ (should (equal (erc-retrieve-catalog-entry 'abc (intern "test0"))
+ "val test1 abc"))
+ (should (equal (erc-retrieve-catalog-entry 'def (intern "test0"))
+ "val test2 def"))
+ ;; Terminates.
+ (should-not (erc-retrieve-catalog-entry 'ghi (intern "test0")))))
+
;;; erc-tests.el ends here
diff --git a/test/lisp/erc/erc-track-tests.el b/test/lisp/erc/erc-track-tests.el
index 3af2333587f..3288c42a42e 100644
--- a/test/lisp/erc/erc-track-tests.el
+++ b/test/lisp/erc/erc-track-tests.el
@@ -104,6 +104,42 @@
'("#emacs" "#vi"))
'("#e" "#v"))) ))
+(ert-deftest erc-track--shortened-names ()
+ (let (erc-track--shortened-names
+ erc-track--shortened-names-current-hash
+ results)
+
+ (with-memoization (erc-track--shortened-names-get
+ '("apple" "banana" "cherries"))
+ '("a" "b" "c"))
+ (should (integerp (car erc-track--shortened-names)))
+ (should (equal (cdr erc-track--shortened-names) '("a" "b" "c")))
+ (push erc-track--shortened-names results)
+
+ ;; Redundant call doesn't run.
+ (with-memoization (erc-track--shortened-names-get
+ '("apple" "banana" "cherries"))
+ (should-not 'run)
+ '("a" "b" "c"))
+ (should (equal erc-track--shortened-names (car results)))
+
+ ;; Change in environment or context forces run.
+ (with-temp-buffer
+ (with-memoization (erc-track--shortened-names-get
+ '("apple" "banana" "cherries"))
+ '("x" "y" "z")))
+ (should (and (integerp (car erc-track--shortened-names))
+ (/= (car erc-track--shortened-names) (caar results))))
+ (should (equal (cdr erc-track--shortened-names) '("x" "y" "z")))
+ (push erc-track--shortened-names results)
+
+ (with-memoization (erc-track--shortened-names-get
+ '("apple" "banana" "cherries"))
+ '("1" "2" "3"))
+ (should (and (integerp (car erc-track--shortened-names))
+ (/= (car erc-track--shortened-names) (caar results))))
+ (should (equal (cdr erc-track--shortened-names) '("1" "2" "3")))))
+
(ert-deftest erc-track--erc-faces-in ()
"`erc-faces-in' should pick up both 'face and 'font-lock-face properties."
(let ((str0 (copy-sequence "is bold"))
@@ -120,4 +156,134 @@
(should (erc-faces-in str0))
(should (erc-faces-in str1)) ))
+;; This simulates an alternating bold/non-bold [#c] in the mode-line,
+;; i.e., an `erc-modified-channels-alist' that vacillates between
+;;
+;; ((#<buffer #chan> 42 . erc-default-face))
+;;
+;; and
+;;
+;; ((#<buffer #chan> 42 erc-nick-default-face erc-default-face))
+;;
+;; This is a fairly typical scenario where consecutive messages
+;; feature speaker and addressee button highlighting and otherwise
+;; plain message bodies. This mapping of phony to real faces
+;; describes the picture in 5.6:
+;;
+;; `1': (erc-button erc-default-face) ; URL
+;; `2': (erc-nick-default-face erc-default-face) ; mention
+;; `3': erc-default-face ; body
+;; `_': (erc-nick-default-face erc-nick-default-face) ; speaker
+;;
+;; The `_' represents a commonly occurring face (a <speaker>) that's
+;; not present in either option's default (standard) value. It's a
+;; no-op from the POV of `erc-track-select-mode-line-face'.
+
+(ert-deftest erc-track-select-mode-line-face ()
+
+ ;; Observed (see key above).
+ (let ((erc-track-faces-priority-list '(1 2 3))
+ (erc-track-faces-normal-list '(1 2 3)))
+
+ (should (equal 2 (erc-track-select-mode-line-face 3 '(2 _ 3))))
+ (should (equal 2 (erc-track-select-mode-line-face 2 '(2 _ 3))))
+ (should (equal 3 (erc-track-select-mode-line-face 2 '(_ 3))))
+ (should (equal 2 (erc-track-select-mode-line-face 3 '(2 3))))
+ (should (equal 3 (erc-track-select-mode-line-face 2 '(3))))
+
+ (should (equal 1 (erc-track-select-mode-line-face 1 '(2 1 3))))
+ (should (equal 1 (erc-track-select-mode-line-face 1 '(1 3))))
+ (should (equal 1 (erc-track-select-mode-line-face 1 '(1 3 2))))
+ (should (equal 1 (erc-track-select-mode-line-face 1 '(3 1)))))
+
+ ;; When the current face outranks all new faces and doesn't appear
+ ;; among them, it's eligible to be replaced with a fellow "normal"
+ ;; from those new faces. But if it does appear among them, it's
+ ;; never replaced.
+ (let ((erc-track-faces-priority-list '(a b))
+ (erc-track-faces-normal-list '(a b)))
+
+ (should (equal 'a (erc-track-select-mode-line-face 'a '(b a))))
+ (should (equal 'a (erc-track-select-mode-line-face 'a '(a b))))
+ (should (equal 'a (erc-track-select-mode-line-face 'b '(b a))))
+ (should (equal 'a (erc-track-select-mode-line-face 'b '(a b))))
+
+ (should (equal 'a (erc-track-select-mode-line-face 'b '(a))))
+ (should (equal 'b (erc-track-select-mode-line-face 'a '(b)))))
+
+ ;; The ordering of the "normal" list doesn't matter.
+ (let ((erc-track-faces-priority-list '(a b))
+ (erc-track-faces-normal-list '(b a)))
+
+ (should (equal 'a (erc-track-select-mode-line-face 'a '(b a))))
+ (should (equal 'a (erc-track-select-mode-line-face 'a '(a b))))
+ (should (equal 'a (erc-track-select-mode-line-face 'b '(b a))))
+ (should (equal 'a (erc-track-select-mode-line-face 'b '(a b))))))
+
+(defun erc-track-tests--select-mode-line-face (ranked normals cases)
+ (setq normals (map-into (mapcar (lambda (f) (cons f t)) normals)
+ '(hash-table :test equal)))
+ (pcase-dolist (`(,want ,cur-face ,new-faces) cases)
+
+ (ert-info ((format "Observed: {cur: %S, new: %S, want: %S}"
+ cur-face new-faces want))
+ (setq new-faces (cons (map-into
+ (mapcar (lambda (f) (cons f t)) new-faces)
+ '(hash-table :test equal))
+ (reverse new-faces)))
+ (should (equal want (funcall #'erc-track--select-mode-line-face
+ cur-face new-faces ranked normals))))))
+
+;; The main difference between these variants is that with the above,
+;; when given alternating lines like
+;;
+;; CUR NEW CHOICE
+;; text (mention $speaker text) => mention
+;; mention ($speaker text) => text
+;;
+;; we see the effect of alternating faces in the indicator. But when
+;; given consecutive lines with a similar composition, like
+;;
+;; text (mention $speaker text) => mention
+;; text (mention $speaker text) => mention
+;;
+;; we lose the effect. With the variant below, we get
+;;
+;; text (mention $speaker text) => mention
+;; text (mention $speaker text) => text
+;;
+
+(ert-deftest erc-track--select-mode-line-face ()
+ (should-not erc-track-ignore-normal-contenders-p)
+
+ ;; These are the same test cases from the previous test. The syntax
+ ;; is (expected cur-face new-faces).
+ (erc-track-tests--select-mode-line-face
+ '(1 2 3) '(1 2 3)
+ '((2 3 (2 _ 3))
+ (3 2 (2 _ 3))
+ (3 2 (_ 3))
+ (2 3 (2 3))
+ (3 2 (3))
+ (2 1 (2 1 3))
+ (3 1 (1 3))
+ (2 1 (1 3 2))
+ (3 1 (3 1))))
+
+ (erc-track-tests--select-mode-line-face
+ '(a b) '(a b)
+ '((b a (b a))
+ (b a (a b))
+ (a b (b a))
+ (a b (a b))
+ (a b (a))
+ (b a (b))))
+
+ (erc-track-tests--select-mode-line-face
+ '(a b) '(b a)
+ '((b a (b a))
+ (b a (a b))
+ (a b (b a))
+ (a b (a b)))))
+
;;; erc-track-tests.el ends here
diff --git a/test/lisp/erc/resources/base/assoc/bouncer-history/barnet.eld b/test/lisp/erc/resources/base/assoc/bouncer-history/barnet.eld
index 35a9a570b6d..060f4178723 100644
--- a/test/lisp/erc/resources/base/assoc/bouncer-history/barnet.eld
+++ b/test/lisp/erc/resources/base/assoc/bouncer-history/barnet.eld
@@ -17,7 +17,7 @@
(0 ":irc.barnet.org 266 tester 3 3 :Current global users 3, max 3")
(0 ":irc.barnet.org 422 tester :MOTD File is missing"))
-((mode-user 3.2 "MODE tester +i")
+((mode-user 10 "MODE tester +i")
;; No mode answer ^
(0 ":irc.znc.in 306 tester :You have been marked as being away")
(0 ":tester!~u@xrir8fpe4d7ak.irc JOIN #chan")
@@ -34,7 +34,7 @@
(0 ":irc.barnet.org NOTICE tester :[07:00:01] This server is in debug mode and is logging all user I/O. If you do not wish for everything you send to be readable by the server owner(s), please disconnect.")
(0 ":irc.barnet.org 305 tester :You are no longer marked as being away"))
-((mode 6 "MODE #chan")
+((mode 10 "MODE #chan")
(0 ":irc.barnet.org 324 tester #chan +nt")
(0 ":irc.barnet.org 329 tester #chan 1619593200")
(0.25 ":joe!~u@svpn88yjcdj42.irc PRIVMSG #chan :mike: But, in defense, by mercy, 'tis most just.")
diff --git a/test/lisp/erc/resources/base/assoc/bouncer-history/foonet.eld b/test/lisp/erc/resources/base/assoc/bouncer-history/foonet.eld
index 58df79e19fa..ecde8adaec4 100644
--- a/test/lisp/erc/resources/base/assoc/bouncer-history/foonet.eld
+++ b/test/lisp/erc/resources/base/assoc/bouncer-history/foonet.eld
@@ -17,7 +17,7 @@
(0 ":irc.foonet.org 266 tester 3 3 :Current global users 3, max 3")
(0 ":irc.foonet.org 422 tester :MOTD File is missing"))
-((mode-user 3.2 "MODE tester +i")
+((mode-user 10 "MODE tester +i")
;; No mode answer ^
(0 ":irc.znc.in 306 tester :You have been marked as being away")
(0 ":tester!~u@nvfhxvqm92rm6.irc JOIN #chan")
@@ -27,6 +27,7 @@
(0 ":bob!~u@svpn88yjcdj42.irc PRIVMSG #chan :[07:04:02] alice: Here come the lovers, full of joy and mirth.")
(0 ":alice!~u@svpn88yjcdj42.irc PRIVMSG #chan :[07:04:07] bob: According to the fool's bolt, sir, and such dulcet diseases.")
(0 ":bob!~u@svpn88yjcdj42.irc PRIVMSG #chan :[07:04:10] alice: And hang himself. I pray you, do my greeting.")
+ (0 ":someone!~u@abcdefg.irc PRIVMSG #chan :[07:04:10] hi everyone.")
(0 ":alice!~u@svpn88yjcdj42.irc PRIVMSG #chan :[07:04:18] bob: And you sat smiling at his cruel prey.")
(0 ":bob!~u@svpn88yjcdj42.irc PRIVMSG #chan :[07:04:21] alice: Or never after look me in the face.")
(0 ":alice!~u@svpn88yjcdj42.irc PRIVMSG #chan :[07:04:25] bob: If that may be, than all is well. Come, sit down, every mother's son, and rehearse your parts. Pyramus, you begin: when you have spoken your speech, enter into that brake; and so every one according to his cue.")
@@ -38,7 +39,7 @@
(0 ":irc.foonet.org NOTICE tester :[07:00:32] This server is in debug mode and is logging all user I/O. If you do not wish for everything you send to be readable by the server owner(s), please disconnect.")
(0 ":irc.foonet.org 305 tester :You are no longer marked as being away"))
-((mode 6 "MODE #chan")
+((mode 10 "MODE #chan")
(0 ":irc.foonet.org 324 tester #chan +nt")
(0 ":irc.foonet.org 329 tester #chan 1619593200")
(0.9 ":alice!~u@svpn88yjcdj42.irc PRIVMSG #chan :bob: Grows, lives, and dies, in single blessedness.")
diff --git a/test/lisp/erc/resources/base/assoc/bumped/again.eld b/test/lisp/erc/resources/base/assoc/bumped/again.eld
index ab3c7b06214..aef164b6237 100644
--- a/test/lisp/erc/resources/base/assoc/bumped/again.eld
+++ b/test/lisp/erc/resources/base/assoc/bumped/again.eld
@@ -1,10 +1,10 @@
;; -*- mode: lisp-data; -*-
-((nick 1 "NICK tester"))
-((user 1 "USER user 0 * :tester")
+((nick 10 "NICK tester"))
+((user 10 "USER user 0 * :tester")
(0.0 ":irc.foonet.org 433 * tester :Nickname is reserved by a different account")
(0.0 ":irc.foonet.org FAIL NICK NICKNAME_RESERVED tester :Nickname is reserved by a different account"))
-((nick 3 "NICK tester`")
+((nick 10 "NICK tester`")
(0.1 ":irc.foonet.org 001 tester` :Welcome to the foonet IRC Network tester`")
(0.0 ":irc.foonet.org 002 tester` :Your host is irc.foonet.org, running version oragono-2.6.1-937b9b02368748e5")
(0.0 ":irc.foonet.org 003 tester` :This server was created Fri, 24 Sep 2021 01:38:36 UTC")
@@ -21,10 +21,10 @@
(0.2 ":irc.foonet.org 266 tester` 3 3 :Current global users 3, max 3")
(0.0 ":irc.foonet.org 422 tester` :MOTD File is missing"))
-((mode-user 3.2 "MODE tester` +i")
+((mode-user 10 "MODE tester` +i")
(0.0 ":irc.foonet.org 221 tester` +i")
(0.0 ":irc.foonet.org NOTICE tester` :This server is in debug mode and is logging all user I/O. If you do not wish for everything you send to be readable by the server owner(s), please disconnect."))
-((privmsg 42.6 "PRIVMSG NickServ :IDENTIFY tester changeme")
+((privmsg 10 "PRIVMSG NickServ :IDENTIFY tester changeme")
(0.01 ":tester`!~u@rpaau95je67ci.irc NICK tester")
(0.0 ":NickServ!NickServ@localhost NOTICE tester :You're now logged in as tester"))
diff --git a/test/lisp/erc/resources/base/assoc/bumped/foisted.eld b/test/lisp/erc/resources/base/assoc/bumped/foisted.eld
index 5c36e58d9d3..0f7aadac564 100644
--- a/test/lisp/erc/resources/base/assoc/bumped/foisted.eld
+++ b/test/lisp/erc/resources/base/assoc/bumped/foisted.eld
@@ -1,6 +1,6 @@
;; -*- mode: lisp-data; -*-
-((nick 1 "NICK tester"))
-((user 1 "USER user 0 * :tester")
+((nick 10 "NICK tester"))
+((user 10 "USER user 0 * :tester")
(0.0 ":irc.foonet.org 001 tester :Welcome to the foonet IRC Network tester")
(0.0 ":irc.foonet.org 002 tester :Your host is irc.foonet.org, running version oragono-2.6.1-937b9b02368748e5")
(0.0 ":irc.foonet.org 003 tester :This server was created Fri, 24 Sep 2021 01:38:36 UTC")
@@ -17,14 +17,14 @@
(0.0 ":irc.foonet.org 266 tester 3 3 :Current global users 3, max 3")
(0.0 ":irc.foonet.org 422 tester :MOTD File is missing"))
-((mode-user 1.2 "MODE tester +i")
+((mode-user 10 "MODE tester +i")
(0.0 ":irc.foonet.org 221 tester +i")
(0.0 ":irc.foonet.org NOTICE tester :This server is in debug mode and is logging all user I/O. If you do not wish for everything you send to be readable by the server owner(s), please disconnect."))
-((privmsg 17.21 "PRIVMSG bob :hi")
+((privmsg 10 "PRIVMSG bob :hi")
(0.02 ":bob!~u@ecnnh95wr67pv.net PRIVMSG tester :hola")
(0.01 ":bob!~u@ecnnh95wr67pv.net PRIVMSG tester :how r u?"))
-((quit 18.19 "QUIT :" quit)
+((quit 10 "QUIT :" quit)
(0.01 ":tester!~u@rpaau95je67ci.irc QUIT :Quit: " quit))
((drop 1 DROP))
diff --git a/test/lisp/erc/resources/base/assoc/bumped/refoisted.eld b/test/lisp/erc/resources/base/assoc/bumped/refoisted.eld
index 33e4168ac46..63366d3f576 100644
--- a/test/lisp/erc/resources/base/assoc/bumped/refoisted.eld
+++ b/test/lisp/erc/resources/base/assoc/bumped/refoisted.eld
@@ -1,6 +1,6 @@
;; -*- mode: lisp-data; -*-
-((nick 1 "NICK tester"))
-((user 1 "USER user 0 * :tester")
+((nick 10 "NICK tester"))
+((user 10 "USER user 0 * :tester")
(0.1 ":irc.foonet.org 001 dummy :Welcome to the foonet IRC Network dummy")
(0.0 ":irc.foonet.org 002 dummy :Your host is irc.foonet.org, running version oragono-2.6.1-937b9b02368748e5")
(0.0 ":irc.foonet.org 003 dummy :This server was created Fri, 24 Sep 2021 01:38:36 UTC")
@@ -22,10 +22,10 @@
(0.01 ":bob!~u@ecnnh95wr67pv.net PRIVMSG dummy :back?")
)
-((mode-user 1.2 "MODE dummy +i")
+((mode-user 10 "MODE dummy +i")
(0.0 ":irc.foonet.org 221 dummy +i")
(0.0 ":irc.foonet.org NOTICE dummy :This server is in debug mode and is logging all user I/O. If you do not wish for everything you send to be readable by the server owner(s), please disconnect."))
-((renick 42.6 "NICK tester")
+((renick 10 "NICK tester")
(0.01 ":dummy!~u@rpaau95je67ci.irc NICK tester")
(0.0 ":NickServ!NickServ@localhost NOTICE dummy :You're now logged in as tester"))
diff --git a/test/lisp/erc/resources/base/assoc/multi-net/barnet.eld b/test/lisp/erc/resources/base/assoc/multi-net/barnet.eld
index c62a22a11c7..4c2b1d61e24 100644
--- a/test/lisp/erc/resources/base/assoc/multi-net/barnet.eld
+++ b/test/lisp/erc/resources/base/assoc/multi-net/barnet.eld
@@ -1,7 +1,7 @@
;; -*- mode: lisp-data; -*-
-((pass 1 "PASS :changeme"))
-((nick 1 "NICK tester"))
-((user 1 "USER user 0 * :tester")
+((pass 10 "PASS :changeme"))
+((nick 10 "NICK tester"))
+((user 10 "USER user 0 * :tester")
(0 ":irc.barnet.org 001 tester :Welcome to the barnet IRC Network tester")
(0 ":irc.barnet.org 002 tester :Your host is irc.barnet.org, running version oragono-2.6.0-7481bf0385b95b16")
(0 ":irc.barnet.org 003 tester :This server was created Tue, 04 May 2021 05:06:19 UTC")
@@ -18,16 +18,16 @@
(0 ":irc.barnet.org 266 tester 3 3 :Current global users 3, max 3")
(0 ":irc.barnet.org 422 tester :MOTD File is missing"))
-((mode-user 8 "MODE tester +i")
+((mode-user 10 "MODE tester +i")
(0 ":irc.barnet.org 221 tester +i")
(0 ":irc.barnet.org NOTICE tester :This server is in debug mode and is logging all user I/O. If you do not wish for everything you send to be readable by the server owner(s), please disconnect."))
-((join 2 "JOIN #chan")
+((join 10 "JOIN #chan")
(0 ":tester!~u@jnu48g2wrycbw.irc JOIN #chan")
(0 ":irc.barnet.org 353 tester = #chan :@mike joe tester")
(0 ":irc.barnet.org 366 tester #chan :End of NAMES list"))
-((mode 2 "MODE #chan")
+((mode 10 "MODE #chan")
(0 ":irc.barnet.org 324 tester #chan +nt")
(0 ":irc.barnet.org 329 tester #chan 1620104779")
(0.1 ":mike!~u@kd7gmjbnbkn8c.irc PRIVMSG #chan :tester, welcome!")
diff --git a/test/lisp/erc/resources/base/assoc/multi-net/foonet.eld b/test/lisp/erc/resources/base/assoc/multi-net/foonet.eld
index f30b7deca11..bfa324642ce 100644
--- a/test/lisp/erc/resources/base/assoc/multi-net/foonet.eld
+++ b/test/lisp/erc/resources/base/assoc/multi-net/foonet.eld
@@ -1,7 +1,7 @@
;; -*- mode: lisp-data; -*-
-((pass 1 "PASS :changeme"))
-((nick 1 "NICK tester"))
-((user 1 "USER user 0 * :tester")
+((pass 10 "PASS :changeme"))
+((nick 10 "NICK tester"))
+((user 10 "USER user 0 * :tester")
(0 ":irc.foonet.org 001 tester :Welcome to the foonet IRC Network tester")
(0 ":irc.foonet.org 002 tester :Your host is irc.foonet.org, running version oragono-2.6.0-7481bf0385b95b16")
(0 ":irc.foonet.org 003 tester :This server was created Tue, 04 May 2021 05:06:18 UTC")
@@ -18,16 +18,16 @@
(0 ":irc.foonet.org 266 tester 3 3 :Current global users 3, max 3")
(0 ":irc.foonet.org 422 tester :MOTD File is missing"))
-((mode-user 8 "MODE tester +i")
+((mode-user 10 "MODE tester +i")
(0 ":irc.foonet.org 221 tester +i")
(0 ":irc.foonet.org NOTICE tester :This server is in debug mode and is logging all user I/O. If you do not wish for everything you send to be readable by the server owner(s), please disconnect."))
-((join 2 "JOIN #chan")
+((join 10 "JOIN #chan")
(0 ":tester!~u@9g6b728983yd2.irc JOIN #chan")
(0 ":irc.foonet.org 353 tester = #chan :alice tester @bob")
(0 ":irc.foonet.org 366 tester #chan :End of NAMES list"))
-((mode 2 "MODE #chan")
+((mode 10 "MODE #chan")
(0 ":irc.foonet.org 324 tester #chan +nt")
(0 ":irc.foonet.org 329 tester #chan 1620104779")
(0.1 ":bob!~u@rz2v467q4rwhy.irc PRIVMSG #chan :tester, welcome!")
diff --git a/test/lisp/erc/resources/base/assoc/reconplay/foonet.eld b/test/lisp/erc/resources/base/assoc/reconplay/foonet.eld
index f916fea2374..15bcca2a623 100644
--- a/test/lisp/erc/resources/base/assoc/reconplay/foonet.eld
+++ b/test/lisp/erc/resources/base/assoc/reconplay/foonet.eld
@@ -1,5 +1,5 @@
;; -*- mode: lisp-data; -*-
-((pass 1 "PASS :changeme"))
+((pass 10 "PASS :changeme"))
((nick 1 "NICK tester"))
((user 1 "USER user 0 * :tester")
(0.0 ":irc.foonet.org 001 tester :Welcome to the foonet IRC Network tester")
diff --git a/test/lisp/erc/resources/base/channel-buffer-revival/reattach.eld b/test/lisp/erc/resources/base/channel-buffer-revival/reattach.eld
new file mode 100644
index 00000000000..c3791ac3d49
--- /dev/null
+++ b/test/lisp/erc/resources/base/channel-buffer-revival/reattach.eld
@@ -0,0 +1,56 @@
+;; -*- mode: lisp-data; -*-
+((pass 10 "PASS :tester@vanilla/foonet:changeme"))
+((nick 10 "NICK tester"))
+((user 10 "USER user 0 * :tester")
+ (0.00 ":irc.foonet.org 001 tester :Welcome to the foonet IRC Network tester")
+ (0.00 ":irc.foonet.org 002 tester :Your host is irc.foonet.org, running version ergo-v2.11.1")
+ (0.00 ":irc.foonet.org 003 tester :This server was created Thu, 13 Apr 2023 05:55:22 UTC")
+ (0.00 ":irc.foonet.org 004 tester irc.foonet.org ergo-v2.11.1 BERTZios CEIMRUabefhiklmnoqstuv Iabefhkloqv")
+ (0.00 ":irc.foonet.org 005 tester AWAYLEN=390 BOT=B CASEMAPPING=ascii CHANLIMIT=#:100 CHANMODES=Ibe,k,fl,CEMRUimnstu CHANNELLEN=64 CHANTYPES=# CHATHISTORY=1000 ELIST=U EXCEPTS EXTBAN=,m FORWARD=f INVEX :are supported by this server")
+ (0.00 ":irc.foonet.org 005 tester KICKLEN=390 MAXLIST=beI:60 MAXTARGETS=4 MODES MONITOR=100 NETWORK=foonet NICKLEN=32 PREFIX=(qaohv)~&@%+ STATUSMSG=~&@%+ TARGMAX=NAMES:1,LIST:1,KICK:,WHOIS:1,USERHOST:10,PRIVMSG:4,TAGMSG:4,NOTICE:4,MONITOR:100 TOPICLEN=390 UTF8ONLY WHOX :are supported by this server")
+ (0.00 ":irc.foonet.org 005 tester draft/CHATHISTORY=1000 :are supported by this server")
+ (0.00 ":irc.foonet.org 251 tester :There are 0 users and 3 invisible on 1 server(s)")
+ (0.01 ":irc.foonet.org 252 tester 0 :IRC Operators online")
+ (0.00 ":irc.foonet.org 254 tester 1 :channels formed")
+ (0.00 ":irc.foonet.org 255 tester :I have 3 clients and 0 servers")
+ (0.00 ":irc.foonet.org 265 tester 3 3 :Current local users 3, max 3")
+ (0.00 ":irc.foonet.org 266 tester 3 3 :Current global users 3, max 3")
+ (0.00 ":irc.foonet.org 422 tester :MOTD File is missing"))
+
+((mode 10 "MODE tester +i")
+ (0.01 ":irc.foonet.org 221 tester +Zi"))
+
+((privmsg-play 10 "PRIVMSG *status :playbuffer #chan")
+ (0.05 ":***!znc@znc.in PRIVMSG #chan :Buffer Playback...")
+ (0.02 ":bob!~u@q2weir96jk3r2.irc PRIVMSG #chan :[06:08:24] alice: Was I a child, to fear I know not what.")
+ (0.02 ":alice!~u@q2weir96jk3r2.irc PRIVMSG #chan :[06:08:29] bob: My lord, I do confess the ring was hers.")
+ (0.01 ":bob!~u@q2weir96jk3r2.irc PRIVMSG #chan :[06:08:40] alice: My sons would never so dishonour me.")
+ (0.01 ":alice!~u@q2weir96jk3r2.irc PRIVMSG #chan :[06:09:54] bob: By the hand of a soldier, I will undertake it.")
+ (0.01 ":bob!~u@q2weir96jk3r2.irc PRIVMSG #chan :[06:09:57] alice: Thou counterfeit'st most lively.")
+ (0.01 ":***!znc@znc.in PRIVMSG #chan :Playback Complete."))
+
+((privmsg-attach 10 "PRIVMSG *status :attach #chan")
+ (0.01 ":tester!~u@78a58pgahbr24.irc JOIN #chan"))
+
+((mode-chan 10 "MODE #chan")
+ (0.01 ":irc.foonet.org 353 tester = #chan :@alice bob tester")
+ (0.00 ":irc.foonet.org 366 tester #chan :End of /NAMES list.")
+ (0.00 ":***!znc@znc.in PRIVMSG #chan :Buffer Playback...")
+ (0.00 ":alice!~u@q2weir96jk3r2.irc PRIVMSG #chan :[06:10:01] bob: With what it loathes for that which is away.")
+ (0.00 ":bob!~u@q2weir96jk3r2.irc PRIVMSG #chan :[06:10:30] alice: Ties up my tongue, and will not let me speak.")
+ (0.00 ":alice!~u@q2weir96jk3r2.irc PRIVMSG #chan :[06:11:26] bob: They say he is already in the forest of Arden, and a many merry men with him; and there they live like the old Robin Hood of England. They say many young gentlemen flock to him every day, and fleet the time carelessly, as they did in the golden world.")
+ (0.01 ":bob!~u@q2weir96jk3r2.irc PRIVMSG #chan :[06:11:29] alice: Not by his breath that is more miserable.")
+ (0.00 ":***!znc@znc.in PRIVMSG #chan :Playback Complete.")
+ (0.00 ":*status!znc@znc.in PRIVMSG tester :There was 1 channel matching [#chan]")
+ (0.03 ":*status!znc@znc.in PRIVMSG tester :Attached 1 channel")
+ (0.00 ":irc.foonet.org 324 tester #chan +Cnt")
+ (0.00 ":irc.foonet.org 329 tester #chan 1681365340")
+ (0.03 ":alice!~u@q2weir96jk3r2.irc PRIVMSG #chan :bob: Five or six thousand horse, I said,I will say true,or thereabouts, set down, for I'll speak truth.")
+ (0.02 ":bob!~u@q2weir96jk3r2.irc PRIVMSG #chan :alice: Riddling confession finds but riddling shrift.")
+ (0.04 ":alice!~u@q2weir96jk3r2.irc PRIVMSG #chan :bob: Ay, and the captain of his horse, Count Rousillon."))
+
+((privmsg-bob 10 "PRIVMSG #chan :bob: hi")
+ (0.02 ":bob!~u@q2weir96jk3r2.irc PRIVMSG #chan :alice: But thankful even for hate, that is meant love.")
+ (0.02 ":bob!~u@q2weir96jk3r2.irc PRIVMSG #chan :tester: Come, come, elder brother, you are too young in this.")
+ (0.02 ":alice!~u@q2weir96jk3r2.irc PRIVMSG #chan :bob: Sir, we have known together in Orleans.")
+ (0.05 ":bob!~u@q2weir96jk3r2.irc PRIVMSG #chan :alice: Pawn me to this your honour, she is his."))
diff --git a/test/lisp/erc/resources/base/display-message/multibuf.eld b/test/lisp/erc/resources/base/display-message/multibuf.eld
new file mode 100644
index 00000000000..424a687e749
--- /dev/null
+++ b/test/lisp/erc/resources/base/display-message/multibuf.eld
@@ -0,0 +1,45 @@
+;; -*- mode: lisp-data; -*-
+((nick 10 "NICK tester"))
+((user 10 "USER user 0 * :tester")
+ (0.00 ":irc.foonet.org 001 tester :Welcome to the foonet IRC Network tester")
+ (0.01 ":irc.foonet.org 002 tester :Your host is irc.foonet.org, running version ergo-v2.11.1")
+ (0.01 ":irc.foonet.org 003 tester :This server was created Sat, 14 Oct 2023 16:08:20 UTC")
+ (0.02 ":irc.foonet.org 004 tester irc.foonet.org ergo-v2.11.1 BERTZios CEIMRUabefhiklmnoqstuv Iabefhkloqv")
+ (0.00 ":irc.foonet.org 005 tester AWAYLEN=390 BOT=B CASEMAPPING=ascii CHANLIMIT=#:100 CHANMODES=Ibe,k,fl,CEMRUimnstu CHANNELLEN=64 CHANTYPES=# CHATHISTORY=1000 ELIST=U EXCEPTS EXTBAN=,m FORWARD=f INVEX :are supported by this server")
+ (0.01 ":irc.foonet.org 005 tester KICKLEN=390 MAXLIST=beI:60 MAXTARGETS=4 MODES MONITOR=100 NETWORK=foonet NICKLEN=32 PREFIX=(qaohv)~&@%+ STATUSMSG=~&@%+ TARGMAX=NAMES:1,LIST:1,KICK:,WHOIS:1,USERHOST:10,PRIVMSG:4,TAGMSG:4,NOTICE:4,MONITOR:100 TOPICLEN=390 UTF8ONLY WHOX :are supported by this server")
+ (0.01 ":irc.foonet.org 005 tester draft/CHATHISTORY=1000 :are supported by this server")
+ (0.00 ":irc.foonet.org 251 tester :There are 0 users and 5 invisible on 1 server(s)")
+ (0.00 ":irc.foonet.org 252 tester 0 :IRC Operators online")
+ (0.00 ":irc.foonet.org 253 tester 0 :unregistered connections")
+ (0.00 ":irc.foonet.org 254 tester 2 :channels formed")
+ (0.00 ":irc.foonet.org 255 tester :I have 5 clients and 0 servers")
+ (0.00 ":irc.foonet.org 265 tester 5 5 :Current local users 5, max 5")
+ (0.02 ":irc.foonet.org 266 tester 5 5 :Current global users 5, max 5")
+ (0.01 ":irc.foonet.org 422 tester :MOTD File is missing")
+ (0.00 ":irc.foonet.org 221 tester +i")
+ (0.01 ":irc.foonet.org NOTICE tester :This server is in debug mode and is logging all user I/O. If you do not wish for everything you send to be readable by the server owner(s), please disconnect."))
+
+((mode 10 "MODE tester +i")
+ (0.00 ":irc.foonet.org 221 tester +i"))
+
+((join 10 "JOIN #chan")
+ (0.03 ":tester!~u@rdjcgiwfuwqmc.irc JOIN #chan")
+ (0.03 ":irc.foonet.org 353 tester = #chan :@fsbot bob alice dummy tester")
+ (0.01 ":irc.foonet.org 366 tester #chan :End of NAMES list")
+ (0.00 ":bob!~u@uee7kge7ua5sy.irc PRIVMSG #chan :tester, welcome!")
+ (0.01 ":alice!~u@uee7kge7ua5sy.irc PRIVMSG #chan :tester, welcome!"))
+
+((mode 10 "MODE #chan")
+ (0.01 ":bob!~u@uee7kge7ua5sy.irc PRIVMSG #chan :alice: Persuade this rude wretch willingly to die.")
+ (0.01 ":irc.foonet.org 324 tester #chan +Cnt")
+ (0.01 ":irc.foonet.org 329 tester #chan 1697299707")
+ (0.03 ":alice!~u@uee7kge7ua5sy.irc PRIVMSG #chan :bob: It might be yours or hers, for aught I know.")
+ (0.07 ":bob!~u@uee7kge7ua5sy.irc PRIVMSG #chan :Would all themselves laugh mortal.")
+ (0.04 ":dummy!~u@rdjcgiwfuwqmc.irc PRIVMSG tester :hi")
+ (0.06 ":bob!~u@uee7kge7ua5sy.irc PRIVMSG #chan :alice: It hath pleased the devil drunkenness to give place to the devil wrath; one unperfectness shows me another, to make me frankly despise myself.")
+ (0.05 ":dummy!~u@rdjcgiwfuwqmc.irc QUIT :Quit: \2ERC\2 5.x (IRC client for GNU Emacs)")
+ (0.08 ":alice!~u@uee7kge7ua5sy.irc PRIVMSG #chan :You speak of him when he was less furnished than now he is with that which makes him both without and within."))
+
+((quit 10 "QUIT :\2ERC\2")
+ (0.04 ":tester!~u@rdjcgiwfuwqmc.irc QUIT :Quit: \2ERC\2 5.x (IRC client for GNU Emacs)")
+ (0.02 "ERROR :Quit: \2ERC\2 5.x (IRC client for GNU Emacs)"))
diff --git a/test/lisp/erc/resources/base/display-message/statusmsg.eld b/test/lisp/erc/resources/base/display-message/statusmsg.eld
new file mode 100644
index 00000000000..7c42117080c
--- /dev/null
+++ b/test/lisp/erc/resources/base/display-message/statusmsg.eld
@@ -0,0 +1,47 @@
+;; -*- mode: lisp-data; -*-
+((nick 10 "NICK tester"))
+((user 10 "USER tester 0 * :tester")
+ (0.00 ":irc.foonet.org 001 tester :Welcome to the foonet IRC Network tester")
+ (0.02 ":irc.foonet.org 002 tester :Your host is irc.foonet.org, running version ergo-v2.11.1")
+ (0.01 ":irc.foonet.org 003 tester :This server was created Thu, 07 Dec 2023 08:04:35 UTC")
+ (0.00 ":irc.foonet.org 004 tester irc.foonet.org ergo-v2.11.1 BERTZios CEIMRUabefhiklmnoqstuv Iabefhkloqv")
+ (0.00 ":irc.foonet.org 005 tester AWAYLEN=390 BOT=B CASEMAPPING=ascii CHANLIMIT=#:100 CHANMODES=Ibe,k,fl,CEMRUimnstu CHANNELLEN=64 CHANTYPES=# CHATHISTORY=1000 ELIST=U EXCEPTS EXTBAN=,m FORWARD=f INVEX :are supported by this server")
+ (0.01 ":irc.foonet.org 005 tester KICKLEN=390 MAXLIST=beI:60 MAXTARGETS=4 MODES MONITOR=100 NETWORK=foonet NICKLEN=32 PREFIX=(qaohv)~&@%+ STATUSMSG=~&@%+ TARGMAX=NAMES:1,LIST:1,KICK:,WHOIS:1,USERHOST:10,PRIVMSG:4,TAGMSG:4,NOTICE:4,MONITOR:100 TOPICLEN=390 UTF8ONLY WHOX :are supported by this server")
+ (0.01 ":irc.foonet.org 005 tester draft/CHATHISTORY=1000 :are supported by this server")
+ (0.00 ":irc.foonet.org 251 tester :There are 0 users and 4 invisible on 1 server(s)")
+ (0.00 ":irc.foonet.org 252 tester 0 :IRC Operators online")
+ (0.00 ":irc.foonet.org 253 tester 0 :unregistered connections")
+ (0.00 ":irc.foonet.org 254 tester 2 :channels formed")
+ (0.00 ":irc.foonet.org 255 tester :I have 4 clients and 0 servers")
+ (0.02 ":irc.foonet.org 265 tester 4 5 :Current local users 4, max 5")
+ (0.00 ":irc.foonet.org 266 tester 4 5 :Current global users 4, max 5")
+ (0.00 ":irc.foonet.org 422 tester :MOTD File is missing")
+ (0.00 ":irc.foonet.org 221 tester +i")
+ (0.00 ":irc.foonet.org NOTICE tester :This server is in debug mode and is logging all user I/O. If you do not wish for everything you send to be readable by the server owner(s), please disconnect."))
+
+((mode-tester 10 "MODE tester +i"))
+
+((join-mine 10 "JOIN #mine")
+ (0.01 ":irc.foonet.org 221 tester +i")
+ (0.00 ":tester!~u@2jv6nwu4af69s.irc JOIN #mine")
+ (0.02 ":irc.foonet.org 353 tester = #mine :@tester +dummy")
+ (0.01 ":irc.foonet.org 366 tester #mine :End of NAMES list"))
+
+((mode-mine 10 "MODE #mine")
+ (0.00 ":irc.foonet.org 324 tester #mine +Cnt")
+ (0.02 ":irc.foonet.org 329 tester #mine 1702026418")
+ (0.04 ":dummy!~u@2jv6nwu4af69s.irc PRIVMSG +#mine :hello")
+ (0.03 ":dummy!~u@2jv6nwu4af69s.irc PRIVMSG +#mine :there")
+ (0.05 ":dummy!~u@2jv6nwu4af69s.irc PRIVMSG +#mine :\1ACTION sad\1")
+ (0.03 ":dummy!~u@2jv6nwu4af69s.irc PRIVMSG +#mine :\1ACTION glad\1"))
+
+((privmsg-statusmsg 10 "PRIVMSG +#mine :howdy"))
+((privmsg-statusmsg-action 10 "PRIVMSG +#mine :tenderfoot")
+ ;; These are simulated "echoed messages"
+ (0.05 ":tester!~u@2jv6nwu4af69s.irc PRIVMSG +#mine :\1ACTION mad\1")
+ (0.05 ":tester!~u@2jv6nwu4af69s.irc PRIVMSG +#mine :\1ACTION chad\1"))
+
+((privmsg-prefixed 10 "PRIVMSG #mine :\1ACTION ready\1")
+ (0.04 ":dummy!~u@2jv6nwu4af69s.irc PRIVMSG +#mine :okie")
+ (0.05 ":dummy!~u@2jv6nwu4af69s.irc PRIVMSG +#mine :\1ACTION dokie\1")
+ (0.04 ":dummy!~u@2jv6nwu4af69s.irc PRIVMSG #mine :\1ACTION out\1"))
diff --git a/test/lisp/erc/resources/base/flood/ascii.eld b/test/lisp/erc/resources/base/flood/ascii.eld
new file mode 100644
index 00000000000..a3d127326c3
--- /dev/null
+++ b/test/lisp/erc/resources/base/flood/ascii.eld
@@ -0,0 +1,49 @@
+;; -*- mode: lisp-data; -*-
+((nick 10 "NICK tester"))
+((user 10 "USER user 0 * :tester")
+ (0.00 ":irc.foonet.org 001 tester :Welcome to the foonet IRC Network tester")
+ (0.01 ":irc.foonet.org 002 tester :Your host is irc.foonet.org, running version ergo-v2.11.1")
+ (0.01 ":irc.foonet.org 003 tester :This server was created Sun, 12 Mar 2023 02:30:29 UTC")
+ (0.00 ":irc.foonet.org 004 tester irc.foonet.org ergo-v2.11.1 BERTZios CEIMRUabefhiklmnoqstuv Iabefhkloqv")
+ (0.00 ":irc.foonet.org 005 tester AWAYLEN=390 BOT=B CASEMAPPING=ascii CHANLIMIT=#:100 CHANMODES=Ibe,k,fl,CEMRUimnstu CHANNELLEN=64 CHANTYPES=# CHATHISTORY=1000 ELIST=U EXCEPTS EXTBAN=,m FORWARD=f INVEX :are supported by this server")
+ (0.01 ":irc.foonet.org 005 tester KICKLEN=390 MAXLIST=beI:60 MAXTARGETS=4 MODES MONITOR=100 NETWORK=foonet NICKLEN=32 PREFIX=(qaohv)~&@%+ STATUSMSG=~&@%+ TARGMAX=NAMES:1,LIST:1,KICK:,WHOIS:1,USERHOST:10,PRIVMSG:4,TAGMSG:4,NOTICE:4,MONITOR:100 TOPICLEN=390 UTF8ONLY WHOX :are supported by this server")
+ (0.01 ":irc.foonet.org 005 tester draft/CHATHISTORY=1000 :are supported by this server")
+ (0.00 ":irc.foonet.org 251 tester :There are 0 users and 3 invisible on 1 server(s)")
+ (0.00 ":irc.foonet.org 252 tester 0 :IRC Operators online")
+ (0.00 ":irc.foonet.org 253 tester 0 :unregistered connections")
+ (0.00 ":irc.foonet.org 254 tester 1 :channels formed")
+ (0.00 ":irc.foonet.org 255 tester :I have 3 clients and 0 servers")
+ (0.00 ":irc.foonet.org 265 tester 3 3 :Current local users 3, max 3")
+ (0.00 ":irc.foonet.org 266 tester 3 3 :Current global users 3, max 3")
+ (0.00 ":irc.foonet.org 375 tester :- irc.foonet.org Message of the day - ")
+ (0.00 ":irc.foonet.org 372 tester :- This is the default Ergo MOTD.")
+ (0.01 ":irc.foonet.org 372 tester :- ")
+ (0.02 ":irc.foonet.org 372 tester :- For more information on using these, see MOTDFORMATTING.md")
+ (0.00 ":irc.foonet.org 376 tester :End of MOTD command"))
+
+((mode-tester 10 "MODE tester +i")
+ (0.00 ":irc.foonet.org 221 tester +i")
+ (0.00 ":irc.foonet.org NOTICE tester :This server is in debug mode and is logging all user I/O. If you do not wish for everything you send to be readable by the server owner(s), please disconnect.")
+ (0.05 ":irc.foonet.org 221 tester +i"))
+
+((join-spam 10 "JOIN #ascii")
+ (0 ":tester!~u@9g6b728983yd2.irc JOIN #ascii")
+ (0 ":irc.foonet.org 353 tester = #ascii :alice tester @bob")
+ (0 ":irc.foonet.org 366 tester #ascii :End of NAMES list"))
+
+((mode-spam 10 "MODE #ascii")
+ (0 ":irc.foonet.org 324 tester #ascii +nt")
+ (0 ":irc.foonet.org 329 tester #ascii 1620104779")
+ (0.1 ":bob!~u@rz2v467q4rwhy.irc PRIVMSG #ascii :tester, welcome!")
+ (0.0 ":alice!~u@rz2v467q4rwhy.irc PRIVMSG #ascii :tester, welcome!"))
+
+((privmsg 10 "PRIVMSG #ascii :twenty-three characters twenty-three characters twenty-three characters twenty-three characters twenty-three characters twenty-three characters twenty-three characters twenty-three characters twenty-three characters twenty-three characters twenty-three characters twenty-three characters twenty-three characters twenty-three characters twenty-three characters twenty-three characters twenty-three characters twenty-three characters 12345678"))
+((privmsg 10 "PRIVMSG #ascii :twenty-three characters twenty-three characters twenty-three characters twenty-three characters twenty-three characters twenty-three characters twenty-three characters twenty-three characters twenty-three characters twenty-three characters twenty-three characters twenty-three characters twenty-three characters twenty-three characters twenty-three characters twenty-three characters twenty-three characters twenty-three characters "))
+((privmsg 10 "PRIVMSG #ascii :123456789"))
+((privmsg 10 "PRIVMSG #ascii :xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx"))
+((privmsg 10 "PRIVMSG #ascii :yyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyy"))
+((privmsg 10 "PRIVMSG #ascii :z"))
+
+((quit 10 "QUIT :\2ERC\2")
+ (0.07 ":tester!~u@h3f95zveyc38a.irc QUIT :Quit: \2ERC\2 5.5 (IRC client for GNU Emacs 30.0.50)")
+ (0.01 "ERROR :Quit: \2ERC\2 5.5 (IRC client for GNU Emacs 30.0.50)"))
diff --git a/test/lisp/erc/resources/base/flood/koi8-r.eld b/test/lisp/erc/resources/base/flood/koi8-r.eld
new file mode 100644
index 00000000000..0f10717fc2c
--- /dev/null
+++ b/test/lisp/erc/resources/base/flood/koi8-r.eld
@@ -0,0 +1,47 @@
+;; -*- mode: lisp-data; -*-
+((nick 10 "NICK tester"))
+((user 10 "USER user 0 * :tester")
+ (0.00 ":irc.foonet.org 001 tester :Welcome to the foonet IRC Network tester")
+ (0.01 ":irc.foonet.org 002 tester :Your host is irc.foonet.org, running version ergo-v2.11.1")
+ (0.01 ":irc.foonet.org 003 tester :This server was created Sun, 12 Mar 2023 02:30:29 UTC")
+ (0.00 ":irc.foonet.org 004 tester irc.foonet.org ergo-v2.11.1 BERTZios CEIMRUabefhiklmnoqstuv Iabefhkloqv")
+ (0.00 ":irc.foonet.org 005 tester AWAYLEN=390 BOT=B CASEMAPPING=ascii CHANLIMIT=#:100 CHANMODES=Ibe,k,fl,CEMRUimnstu CHANNELLEN=64 CHANTYPES=# CHATHISTORY=1000 ELIST=U EXCEPTS EXTBAN=,m FORWARD=f INVEX :are supported by this server")
+ (0.01 ":irc.foonet.org 005 tester KICKLEN=390 MAXLIST=beI:60 MAXTARGETS=4 MODES MONITOR=100 NETWORK=foonet NICKLEN=32 PREFIX=(qaohv)~&@%+ STATUSMSG=~&@%+ TARGMAX=NAMES:1,LIST:1,KICK:,WHOIS:1,USERHOST:10,PRIVMSG:4,TAGMSG:4,NOTICE:4,MONITOR:100 TOPICLEN=390 UTF8ONLY WHOX :are supported by this server")
+ (0.01 ":irc.foonet.org 005 tester draft/CHATHISTORY=1000 :are supported by this server")
+ (0.00 ":irc.foonet.org 251 tester :There are 0 users and 3 invisible on 1 server(s)")
+ (0.00 ":irc.foonet.org 252 tester 0 :IRC Operators online")
+ (0.00 ":irc.foonet.org 253 tester 0 :unregistered connections")
+ (0.00 ":irc.foonet.org 254 tester 1 :channels formed")
+ (0.00 ":irc.foonet.org 255 tester :I have 3 clients and 0 servers")
+ (0.00 ":irc.foonet.org 265 tester 3 3 :Current local users 3, max 3")
+ (0.00 ":irc.foonet.org 266 tester 3 3 :Current global users 3, max 3")
+ (0.00 ":irc.foonet.org 375 tester :- irc.foonet.org Message of the day - ")
+ (0.00 ":irc.foonet.org 372 tester :- This is the default Ergo MOTD.")
+ (0.01 ":irc.foonet.org 372 tester :- ")
+ (0.02 ":irc.foonet.org 372 tester :- For more information on using these, see MOTDFORMATTING.md")
+ (0.00 ":irc.foonet.org 376 tester :End of MOTD command"))
+
+((mode-tester 10 "MODE tester +i")
+ (0.00 ":irc.foonet.org 221 tester +i")
+ (0.00 ":irc.foonet.org NOTICE tester :This server is in debug mode and is logging all user I/O. If you do not wish for everything you send to be readable by the server owner(s), please disconnect.")
+ (0.05 ":irc.foonet.org 221 tester +i"))
+
+((join-chan 6 "JOIN #koi8")
+ (0 ":tester!~u@9g6b728983yd2.irc JOIN #koi8")
+ (0 ":irc.foonet.org 353 tester = #koi8 :alice tester @bob")
+ (0 ":irc.foonet.org 366 tester #koi8 :End of NAMES list"))
+
+((mode-chan 8 "MODE #koi8")
+ (0 ":irc.foonet.org 324 tester #koi8 +nt")
+ (0 ":irc.foonet.org 329 tester #koi8 1620104779")
+ (0.1 ":bob!~u@rz2v467q4rwhy.irc PRIVMSG #koi8 :tester, welcome!")
+ (0.0 ":alice!~u@rz2v467q4rwhy.irc PRIVMSG #koi8 :tester, welcome!")
+ (0.0 ":bob!~u@rz2v467q4rwhy.irc PRIVMSG #koi8 :\313\317\322\317\336\305 \324\305\320\305\322\330 \305\323\314\311 \320\317 \322\325\323\323\313\311 \316\301\320\311\323\301\324\330 \327\323\305 \336\305\324\313\317 \311\314\311 \327\323\305 \322\301\327\316\317 \313\317\322\317\336\305 \324\305\320\305\322\330 \305\323\314\311 \320\317 \322\325\323\323\313\311 \316\301\320\311\323\301\324\330 \327\323\305 \336\305\324\313\317 \311\314\311 \327\323\305 \322\301\327\316\317"))
+
+((privmsg 10 "PRIVMSG #koi8 :\313\317\322\317\336\305 \324\305\320\305\322\330 \305\323\314\311 \320\317 \322\325\323\323\313\311 \316\301\320\311\323\301\324\330 \327\323\305 \336\305\324\313\317 \311\314\311 \327\323\305 \322\301\327\316\317 \313\317\322\317\336\305 \324\305\320\305\322\330 \305\323\314\311 \320\317 \322\325\323\323\313\311 \316\301\320\311\323\301\324\330 \327\323\305 \336\305\324\313\317 \311\314\311 \327\323\305 \322\301\327\316\317 \313\317\322\317\336\305 \324\305\320\305\322\330 \305\323\314\311 \320\317 \322\325\323\323\313\311 \316\301\320\311\323\301\324\330 \327\323\305 \336\305\324\313\317 \311\314\311 \327\323\305 \322\301\327\316\317 \313\317\322\317\336\305 \324\305\320\305\322\330 \305\323\314\311 \320\317 \322\325\323\323\313\311 \316\301\320\311\323\301\324\330 \327\323\305 \336\305\324\313\317 \311\314\311 \327\323\305 \322\301\327\316\317"))
+((privmsg 10 "PRIVMSG #koi8 :\313\317\322\317\336\305 \324\305\320\305\322\330 \305\323\314\311 \320\317 \322\325\323\323\313\311 \316\301\320\311\323\301\324\330 \327\323\305 \336\305\324\313\317 \311\314\311 \327\323\305 \322\301\327\316\317 \313\317\322\317\336\305 \324\305\320\305\322\330 \305\323\314\311 \320\317 \322\325\323\323\313\311 \316\301\320\311\323\301\324\330 \327\323\305 \336\305\324\313\317 \311\314\311 \327\323\305 \322\301\327\316\317 \313\317\322\317\336\305 \324\305\320\305\322\330 \305\323\314\311 \320\317 \322\325\323\323\313\311 \316\301\320\311\323\301\324\330 \327\323\305 \336\305\324\313\317 \311\314\311 \327\323\305 \322\301\327\316\317 \313\317\322\317\336\305 \324\305\320\305\322\330 \305\323\314\311 \320\317 \322\325\323\323\313\311 \316\301\320\311\323\301\324\330 \327\323\305 \336\305\324\313\317 \311\314\311 \327\323\305 \322\301\327\316\317 \313\317\322\317\336\305 \324\305\320\305\322\330 \305\323\314\311 \320\317 \322\325\323\323\313\311 \316\301\320\311\323\301\324\330 \327\323\305 \336\305\324\313\317 \311\314\311 \327\323\305 \322\301\327\316\317 \313\317\322\317\336\305 \324\305\320\305\322\330 \305\323\314\311 \320\317 \322\325\323\323\313\311 \316\301\320\311\323\301\324\330 \327\323\305 \336\305\324\313\317 \311\314\311 \327\323\305 \322\301\327\316\317 \313\317\322\317\336\305 \324\305\320\305\322\330 \305\323\314\311 \320\317 \322\325\323\323\313\311 \316\301\320\311\323\301\324\330 \327\323\305 \336\305\324\313\317 \311\314\311 \327\323\305 \322\301\327\316\317 \302\325\304\305\324 "))
+((privmsg 10 "PRIVMSG #koi8 :\322\301\332\322\331\327 \323\324\322\317\313\311 \316\305\320\317\316\321\324\316\317 \307\304\305"))
+
+((quit 10 "QUIT :\2ERC\2")
+ (0.07 ":tester!~u@h3f95zveyc38a.irc QUIT :Quit: \2ERC\2 5.5 (IRC client for GNU Emacs 30.0.50)")
+ (0.01 "ERROR :Quit: \2ERC\2 5.5 (IRC client for GNU Emacs 30.0.50)"))
diff --git a/test/lisp/erc/resources/base/flood/soju.eld b/test/lisp/erc/resources/base/flood/soju.eld
index 05266ca9411..9e936499a2d 100644
--- a/test/lisp/erc/resources/base/flood/soju.eld
+++ b/test/lisp/erc/resources/base/flood/soju.eld
@@ -8,7 +8,7 @@
(0.0 ":soju.im 005 tester CHATHISTORY=1000 CASEMAPPING=ascii NETWORK=Soju :are supported")
(0.0 ":soju.im 422 tester :No MOTD"))
-((mode 1 "MODE tester +i")
+((mode 10 "MODE tester +i")
(0.0 ":tester!tester@10.0.2.100 JOIN #chan/foonet")
(0.25 ":soju.im 331 tester #chan/foonet :No topic is set")
(0.0 ":soju.im 353 tester = #chan/foonet :@bob/foonet alice/foonet tester")
diff --git a/test/lisp/erc/resources/base/flood/utf-8.eld b/test/lisp/erc/resources/base/flood/utf-8.eld
new file mode 100644
index 00000000000..8e7f8f7eed2
--- /dev/null
+++ b/test/lisp/erc/resources/base/flood/utf-8.eld
@@ -0,0 +1,54 @@
+;; -*- mode: lisp-data; -*-
+((nick 10 "NICK tester"))
+((user 10 "USER user 0 * :tester")
+ (0.00 ":irc.foonet.org 001 tester :Welcome to the foonet IRC Network tester")
+ (0.01 ":irc.foonet.org 002 tester :Your host is irc.foonet.org, running version ergo-v2.11.1")
+ (0.01 ":irc.foonet.org 003 tester :This server was created Sun, 12 Mar 2023 02:30:29 UTC")
+ (0.00 ":irc.foonet.org 004 tester irc.foonet.org ergo-v2.11.1 BERTZios CEIMRUabefhiklmnoqstuv Iabefhkloqv")
+ (0.00 ":irc.foonet.org 005 tester AWAYLEN=390 BOT=B CASEMAPPING=ascii CHANLIMIT=#:100 CHANMODES=Ibe,k,fl,CEMRUimnstu CHANNELLEN=64 CHANTYPES=# CHATHISTORY=1000 ELIST=U EXCEPTS EXTBAN=,m FORWARD=f INVEX :are supported by this server")
+ (0.01 ":irc.foonet.org 005 tester KICKLEN=390 MAXLIST=beI:60 MAXTARGETS=4 MODES MONITOR=100 NETWORK=foonet NICKLEN=32 PREFIX=(qaohv)~&@%+ STATUSMSG=~&@%+ TARGMAX=NAMES:1,LIST:1,KICK:,WHOIS:1,USERHOST:10,PRIVMSG:4,TAGMSG:4,NOTICE:4,MONITOR:100 TOPICLEN=390 UTF8ONLY WHOX :are supported by this server")
+ (0.01 ":irc.foonet.org 005 tester draft/CHATHISTORY=1000 :are supported by this server")
+ (0.00 ":irc.foonet.org 251 tester :There are 0 users and 3 invisible on 1 server(s)")
+ (0.00 ":irc.foonet.org 252 tester 0 :IRC Operators online")
+ (0.00 ":irc.foonet.org 253 tester 0 :unregistered connections")
+ (0.00 ":irc.foonet.org 254 tester 1 :channels formed")
+ (0.00 ":irc.foonet.org 255 tester :I have 3 clients and 0 servers")
+ (0.00 ":irc.foonet.org 265 tester 3 3 :Current local users 3, max 3")
+ (0.00 ":irc.foonet.org 266 tester 3 3 :Current global users 3, max 3")
+ (0.00 ":irc.foonet.org 375 tester :- irc.foonet.org Message of the day - ")
+ (0.00 ":irc.foonet.org 372 tester :- This is the default Ergo MOTD.")
+ (0.01 ":irc.foonet.org 372 tester :- ")
+ (0.02 ":irc.foonet.org 372 tester :- For more information on using these, see MOTDFORMATTING.md")
+ (0.00 ":irc.foonet.org 376 tester :End of MOTD command"))
+
+((mode-tester 10 "MODE tester +i")
+ (0.00 ":irc.foonet.org 221 tester +i")
+ (0.00 ":irc.foonet.org NOTICE tester :This server is in debug mode and is logging all user I/O. If you do not wish for everything you send to be readable by the server owner(s), please disconnect.")
+ (0.05 ":irc.foonet.org 221 tester +i"))
+
+((join-spam 10 "JOIN #utf-8")
+ (0 ":tester!~u@9g6b728983yd2.irc JOIN #utf-8")
+ (0 ":irc.foonet.org 353 tester = #utf-8 :alice tester @bob")
+ (0 ":irc.foonet.org 366 tester #utf-8 :End of NAMES list"))
+
+((mode-spam 10 "MODE #utf-8")
+ (0 ":irc.foonet.org 324 tester #utf-8 +nt")
+ (0 ":irc.foonet.org 329 tester #utf-8 1620104779")
+ (0.1 ":bob!~u@rz2v467q4rwhy.irc PRIVMSG #utf-8 :tester, welcome!")
+ (0.0 ":alice!~u@rz2v467q4rwhy.irc PRIVMSG #utf-8 :tester, welcome!"))
+
+((privmsg-a 10 "PRIVMSG #utf-8 :\320\272\320\276\321\200\320\276\321\207\320\265 \321\202\320\265\320\277\320\265\321\200\321\214 \320\265\321\201\320\273\320\270 \320\277\320\276 \321\200\321\203\321\201\321\201\320\272\320\270 \320\275\320\260\320\277\320\270\321\201\320\260\321\202\321\214 \320\262\321\201\320\265 \321\207\320\265\321\202\320\272\320\276 \320\270\320\273\320\270 \320\262\321\201\320\265 \321\200\320\260\320\262\320\275\320\276 \320\272\320\276\321\200\320\276\321\207\320\265 \321\202\320\265\320\277\320\265\321\200\321\214 \320\265\321\201\320\273\320\270 \320\277\320\276 \321\200\321\203\321\201\321\201\320\272\320\270 \320\275\320\260\320\277\320\270\321\201\320\260\321\202\321\214 \320\262\321\201\320\265 \321\207\320\265\321\202\320\272\320\276 \320\270\320\273\320\270 \320\262\321\201\320\265 \321\200\320\260\320\262\320\275\320\276 \320\272\320\276\321\200\320\276\321\207\320\265 \321\202\320\265\320\277\320\265\321\200\321\214 \320\265\321\201\320\273\320\270 \320\277\320\276 \321\200\321\203\321\201\321\201\320\272\320\270 \320\275\320\260\320\277\320\270\321\201\320\260\321\202\321\214 \320\262\321\201\320\265 \321\207\320\265\321\202\320\272\320\276 \320\270\320\273\320\270 \320\262\321\201\320\265 \321\200\320\260\320\262\320\275\320\276 \320\272\320\276\321\200\320\276\321\207\320\265 \321\202\320\265\320\277\320\265\321\200\321\214 \320\265\321\201\320\273\320\270 \320\277\320\276 \321\200\321\203\321\201\321\201\320\272\320\270 \320\275\320\260\320\277\320\270\321\201\320\260\321\202\321\214 \320\262\321\201\320\265 \321\207\320\265\321\202\320\272\320\276 \320\270\320\273\320\270 "))
+((privmsg-b 10 "PRIVMSG #utf-8 :\320\262\321\201\320\265 \321\200\320\260\320\262\320\275\320\276 \320\272\320\276\321\200\320\276\321\207\320\265 \321\202\320\265\320\277\320\265\321\200\321\214 \320\265\321\201\320\273\320\270 \320\277\320\276 \321\200\321\203\321\201\321\201\320\272\320\270 \320\275\320\260\320\277\320\270\321\201\320\260\321\202\321\214 \320\262\321\201\320\265 \321\207\320\265\321\202\320\272\320\276 \320\270\320\273\320\270 \320\262\321\201\320\265 \321\200\320\260\320\262\320\275\320\276 \320\272\320\276\321\200\320\276\321\207\320\265 \321\202\320\265\320\277\320\265\321\200\321\214 \320\265\321\201\320\273\320\270 \320\277\320\276 \321\200\321\203\321\201\321\201\320\272\320\270 \320\275\320\260\320\277\320\270\321\201\320\260\321\202\321\214 \320\262\321\201\320\265 \321\207\320\265\321\202\320\272\320\276 \320\270\320\273\320\270 \320\262\321\201\320\265 \321\200\320\260\320\262\320\275\320\276 \320\272\320\276\321\200\320\276\321\207\320\265 \321\202\320\265\320\277\320\265\321\200\321\214 \320\265\321\201\320\273\320\270 \320\277\320\276 \321\200\321\203\321\201\321\201\320\272\320\270 \320\275\320\260\320\277\320\270\321\201\320\260\321\202\321\214 \320\262\321\201\320\265 \321\207\320\265\321\202\320\272\320\276 \320\270\320\273\320\270 \320\262\321\201\320\265 \321\200\320\260\320\262\320\275\320\276 \320\261\321\203\320\264\320\265\321\202 \321\200\320\260\320\267\321\200\321\213\320\262 \321\201\321\202\321\200\320\276\320\272\320\270 \320\275\320\265\320\277\320\276\320\275\321\217\321\202\320\275\320\276 \320\263\320\264\320\265 \320\261\321\203\320\264\320\265\321\202 "))
+((privmsg-c 10 "PRIVMSG #utf-8 :\321\200\320\260\320\267\321\200\321\213\320\262 \321\201\321\202\321\200\320\276\320\272\320\270 \320\275\320\265\320\277\320\276\320\275\321\217\321\202\320\275\320\276 \320\263\320\264\320\265")
+ (0.1 ":bob!~u@rz2v467q4rwhy.irc PRIVMSG #utf-8 :alice: Entirely honour; I would not be delay'd."))
+
+((privmsg-g 10 "PRIVMSG #utf-8 :\350\251\261\350\252\252\345\244\251\344\270\213\345\244\247\345\213\242\357\274\214\345\210\206\344\271\205\345\277\205\345\220\210\357\274\214\345\220\210\344\271\205\345\277\205\345\210\206\357\274\232\345\221\250\346\234\253\344\270\203\345\234\213\345\210\206\347\210\255\357\274\214\345\271\266\345\205\245\346\226\274\347\247\246\343\200\202\345\217\212\347\247\246\346\273\205\344\271\213\345\276\214\357\274\214\346\245\232\343\200\201\346\274\242\345\210\206\347\210\255\357\274\214\345\217\210\345\271\266\345\205\245\346\226\274\346\274\242\343\200\202\346\274\242\346\234\235\350\207\252\351\253\230\347\245\226\346\226\254\347\231\275\350\233\207\350\200\214\350\265\267\347\276\251\357\274\214\344\270\200\347\265\261\345\244\251\344\270\213\343\200\202\345\276\214\344\276\206\345\205\211\346\255\246\344\270\255\350\210\210\357\274\214\345\202\263\350\207\263\347\215\273\345\270\235\357\274\214\351\201\202\345\210\206\347\202\272\344\270\211\345\234\213\343\200\202\346\216\250\345\205\266\350\207\264\344\272\202\344\271\213\347\224\261\357\274\214\346\256\206\345\247\213\346\226\274\346\241\223\343\200\201\351\235\210\344\272\214\345\270\235\343\200\202\346\241\223\345\270\235\347\246\201\351\214\256\345\226\204\351\241\236\357\274\214\345\264\207\344\277\241\345\256\246\345\256\230\343\200\202\345\217\212\346\241\223\345\270\235\345\264\251\357\274\214\351\235\210\345\270\235\345\215\263\344\275\215\357\274\214\345\244\247\345\260\207\350\273\215\347\253\207\346\255\246\343\200\201\345\244\252\345\202\205\351\231\263\350\225\203\357\274\214\345\205\261\347\233\270\350\274\224\344\275\220\343\200\202\346\231\202\346\234\211\345\256\246\345\256\230\346\233\271\347\257\200\347\255\211\345\274\204\346\254\212\357\274\214"))
+((privmsg-h 10 "PRIVMSG #utf-8 :\347\253\207\346\255\246\343\200\201\351\231\263\350\225\203\350\254\200\350\252\205\344\271\213\357\274\214\344\275\234\344\272\213\344\270\215\345\257\206\357\274\214\345\217\215\347\202\272\346\211\200\345\256\263\343\200\202\344\270\255\346\266\223\350\207\252\346\255\244\346\204\210\346\251\253")
+ (0.0 ":alice!~u@rz2v467q4rwhy.irc PRIVMSG #utf-8 :Shall seize this prey out of his father's hands."))
+
+((privmsg-d 10 "PRIVMSG #utf-8 :\320\261\321\203\320\264\320\265\321\202\302\240\321\200\320\260\320\267\321\200\321\213\320\262\302\240\321\201\321\202\321\200\320\276\320\272\320\270\302\240\320\275\320\265\320\277\320\276\320\275\321\217\321\202\320\275\320\276\302\240\320\263\320\264\320\265\360\237\217\201\360\237\232\251\360\237\216\214\360\237\217\264\360\237\217\263\357\270\217"))
+((privmsg-e 10 "PRIVMSG #utf-8 :\360\237\217\263\357\270\217\342\200\215\360\237\214\210\360\237\217\263\357\270\217\342\200\215\342\232\247\357\270\217\360\237\217\264\342\200\215\342\230\240\357\270\217"))
+
+((quit 10 "QUIT :\2ERC\2")
+ (0.07 ":tester!~u@h3f95zveyc38a.irc QUIT :Quit: \2ERC\2 5.5 (IRC client for GNU Emacs 30.0.50)")
+ (0.01 "ERROR :Quit: \2ERC\2 5.5 (IRC client for GNU Emacs 30.0.50)"))
diff --git a/test/lisp/erc/resources/base/gapless-connect/foonet.eld b/test/lisp/erc/resources/base/gapless-connect/foonet.eld
index 4ac4a3e5968..10b742fdb34 100644
--- a/test/lisp/erc/resources/base/gapless-connect/foonet.eld
+++ b/test/lisp/erc/resources/base/gapless-connect/foonet.eld
@@ -1,7 +1,7 @@
;; -*- mode: lisp-data; -*-
-((pass 1 "PASS :foonet:changeme"))
-((nick 1 "NICK tester"))
-((user 1 "USER user 0 * :tester")
+((pass 10 "PASS :foonet:changeme"))
+((nick 10 "NICK tester"))
+((user 10 "USER user 0 * :tester")
(0 ":irc.foonet.org 001 tester :Welcome to the foonet IRC Network tester")
(0 ":irc.foonet.org 002 tester :Your host is irc.foonet.org, running version oragono-2.6.0-7481bf0385b95b16")
(0 ":irc.foonet.org 003 tester :This server was created Sun, 25 Apr 2021 11:28:28 UTC")
@@ -21,7 +21,7 @@
;; No mode answer
(0 ":irc.znc.in 306 tester :You have been marked as being away")
(0 ":tester!~u@xrir8fpe4d7ak.irc JOIN #foo")
- (0 ":irc.foonet.org 353 tester = #foo :joe @mike tester")
+ (0 ":irc.foonet.org 353 tester = #foo :alice @bob tester")
(0 ":irc.foonet.org 366 tester #foo :End of /NAMES list.")
(0 ":***!znc@znc.in PRIVMSG #foo :Buffer Playback...")
(0 ":alice!~u@svpn88yjcdj42.irc PRIVMSG #foo :[07:02:41] bob: To-morrow is the joyful day, Audrey; to-morrow will we be married.")
diff --git a/test/lisp/erc/resources/base/local-modules/first.eld b/test/lisp/erc/resources/base/local-modules/first.eld
index f9181a80fb7..4e923270e24 100644
--- a/test/lisp/erc/resources/base/local-modules/first.eld
+++ b/test/lisp/erc/resources/base/local-modules/first.eld
@@ -1,7 +1,7 @@
;; -*- mode: lisp-data; -*-
((cap 10 "CAP REQ :sasl"))
-((nick 1 "NICK tester"))
-((user 1 "USER tester 0 * :tester"))
+((nick 10 "NICK tester"))
+((user 10 "USER tester 0 * :tester"))
((authenticate 5 "AUTHENTICATE PLAIN")
(0.0 ":irc.foonet.org CAP * ACK sasl")
@@ -11,7 +11,7 @@
(0.0 ":irc.foonet.org 900 * * tester :You are now logged in as tester")
(0.01 ":irc.foonet.org 903 * :Authentication successful"))
-((cap 3.2 "CAP END")
+((cap 10 "CAP END")
(0.0 ":irc.foonet.org 001 tester :Welcome to the foonet IRC Network tester")
(0.0 ":irc.foonet.org 002 tester :Your host is irc.foonet.org, running version ergo-v2.8.0")
(0.2 ":irc.foonet.org 003 tester :This server was created Sun, 20 Nov 2022 23:10:36 UTC")
diff --git a/test/lisp/erc/resources/base/local-modules/second.eld b/test/lisp/erc/resources/base/local-modules/second.eld
index a96103b2aa1..5823d63b874 100644
--- a/test/lisp/erc/resources/base/local-modules/second.eld
+++ b/test/lisp/erc/resources/base/local-modules/second.eld
@@ -41,7 +41,7 @@
(0.07 ":alice!~u@2fzfcku68ehqa.irc PRIVMSG #chan :bob: To you that know them not. This to my mother.")
(0.00 ":bob!~u@2fzfcku68ehqa.irc PRIVMSG #chan :alice: Some enigma, some riddle: come, thy l'envoy; begin."))
-((quit 1 "QUIT :\2ERC\2")
+((quit 10 "QUIT :\2ERC\2")
(0.03 ":tester`!~u@u9iqi96sfwk9s.irc QUIT"))
((drop 0 DROP))
diff --git a/test/lisp/erc/resources/base/local-modules/third.eld b/test/lisp/erc/resources/base/local-modules/third.eld
index 19bdd6efcce..e24825c3217 100644
--- a/test/lisp/erc/resources/base/local-modules/third.eld
+++ b/test/lisp/erc/resources/base/local-modules/third.eld
@@ -37,7 +37,7 @@
(0.00 ":alice!~u@2fzfcku68ehqa.irc PRIVMSG #chan :bob: No remedy, my lord, when walls are so wilful to hear without warning.")
(0.01 ":bob!~u@2fzfcku68ehqa.irc PRIVMSG #chan :alice: Let our reciprocal vows be remembered. You have many opportunities to cut him off; if your will want not, time and place will be fruitfully offered. There is nothing done if he return the conqueror; then am I the prisoner, and his bed my gaol; from the loathed warmth whereof deliver me, and supply the place for your labor."))
-((quit 1 "QUIT :\2ERC\2")
+((quit 10 "QUIT :\2ERC\2")
(0.03 ":tester`!~u@u9iqi96sfwk9s.irc QUIT :Quit"))
((drop 0 DROP))
diff --git a/test/lisp/erc/resources/base/modes/chan-changed.eld b/test/lisp/erc/resources/base/modes/chan-changed.eld
new file mode 100644
index 00000000000..6cf6596b0b2
--- /dev/null
+++ b/test/lisp/erc/resources/base/modes/chan-changed.eld
@@ -0,0 +1,55 @@
+;; -*- mode: lisp-data; -*-
+((nick 10 "NICK tester"))
+((user 10 "USER user 0 * :tester")
+ (0.03 ":cadmium.libera.chat 001 tester :Welcome to the Libera.Chat Internet Relay Chat Network tester")
+ (0.02 ":cadmium.libera.chat 002 tester :Your host is cadmium.libera.chat[103.196.37.95/6697], running version solanum-1.0-dev")
+ (0.01 ":cadmium.libera.chat 003 tester :This server was created Wed Jan 25 2023 at 10:22:45 UTC")
+ (0.01 ":cadmium.libera.chat 004 tester cadmium.libera.chat solanum-1.0-dev DGMQRSZaghilopsuwz CFILMPQRSTbcefgijklmnopqrstuvz bkloveqjfI")
+ (0.00 ":cadmium.libera.chat 005 tester CALLERID=g WHOX ETRACE FNC SAFELIST ELIST=CMNTU KNOCK MONITOR=100 CHANTYPES=# EXCEPTS INVEX CHANMODES=eIbq,k,flj,CFLMPQRSTcgimnprstuz :are supported by this server")
+ (0.01 ":cadmium.libera.chat 005 tester CHANLIMIT=#:250 PREFIX=(ov)@+ MAXLIST=bqeI:100 MODES=4 NETWORK=Libera.Chat STATUSMSG=@+ CASEMAPPING=rfc1459 NICKLEN=16 MAXNICKLEN=16 CHANNELLEN=50 TOPICLEN=390 DEAF=D :are supported by this server")
+ (0.01 ":cadmium.libera.chat 005 tester TARGMAX=NAMES:1,LIST:1,KICK:1,WHOIS:1,PRIVMSG:4,NOTICE:4,ACCEPT:,MONITOR: EXTBAN=$,ajrxz :are supported by this server")
+ (0.01 ":cadmium.libera.chat 251 tester :There are 70 users and 42996 invisible on 28 servers")
+ (0.02 ":cadmium.libera.chat 252 tester 38 :IRC Operators online")
+ (0.01 ":cadmium.libera.chat 253 tester 57 :unknown connection(s)")
+ (0.01 ":cadmium.libera.chat 254 tester 22912 :channels formed")
+ (0.01 ":cadmium.libera.chat 255 tester :I have 2499 clients and 1 servers")
+ (0.01 ":cadmium.libera.chat 265 tester 2499 4187 :Current local users 2499, max 4187")
+ (0.01 ":cadmium.libera.chat 266 tester 43066 51827 :Current global users 43066, max 51827")
+ (0.01 ":cadmium.libera.chat 250 tester :Highest connection count: 4188 (4187 clients) (319420 connections received)")
+ (0.01 ":cadmium.libera.chat 375 tester :- cadmium.libera.chat Message of the Day - ")
+ (0.01 ":cadmium.libera.chat 372 tester :- This server kindly provided by Mach Dilemma (www.m-d.net)")
+ (0.01 ":cadmium.libera.chat 372 tester :- Welcome to Libera Chat, the IRC network for")
+ (0.00 ":cadmium.libera.chat 372 tester :- Email: support@libera.chat")
+ (0.00 ":cadmium.libera.chat 376 tester :End of /MOTD command.")
+ (0.00 ":tester MODE tester :+Ziw"))
+
+((mode-tester 10 "MODE tester +i"))
+
+((join-chan 10 "JOIN #chan")
+ (0.09 ":tester!~tester@127.0.0.1 JOIN #chan"))
+
+((mode-chan 10 "MODE #chan")
+ (0.03 ":cadmium.libera.chat 353 tester = #chan :tester @Chad dummy")
+ (0.02 ":cadmium.libera.chat 366 tester #chan :End of /NAMES list.")
+ (0.00 ":cadmium.libera.chat 324 tester #chan +nt")
+ (0.01 ":cadmium.libera.chat 329 tester #chan 1621432263"))
+
+((privmsg-before 10 "PRIVMSG #chan :ready before")
+ (0.02 ":Chad!~u@ggpg6r3a68wak.irc PRIVMSG #chan before")
+ (0.00 ":Chad!~u@ggpg6r3a68wak.irc MODE #chan +Qu"))
+
+((privmsg-key 10 "PRIVMSG #chan :ready key")
+ (0.02 ":Chad!~u@ggpg6r3a68wak.irc PRIVMSG #chan :doing key")
+ (0.00 ":Chad!~u@ggpg6r3a68wak.irc MODE #chan +k hunter2"))
+
+((privmsg-limit 10 "PRIVMSG #chan :ready limit")
+ (0.02 ":Chad!~u@ggpg6r3a68wak.irc PRIVMSG #chan :doing limit")
+ (0.00 ":Chad!~u@ggpg6r3a68wak.irc MODE #chan +l 3"))
+
+((privmsg-drop 10 "PRIVMSG #chan :ready drop")
+ (0.02 ":Chad!~u@ggpg6r3a68wak.irc PRIVMSG #chan dropping")
+ (0.00 ":Chad!~u@ggpg6r3a68wak.irc MODE #chan -lu")
+ (0.00 ":Chad!~u@ggpg6r3a68wak.irc MODE #chan -Qk *")
+ (0.02 ":Chad!~u@ggpg6r3a68wak.irc PRIVMSG #chan after"))
+
+((drop 0 DROP))
diff --git a/test/lisp/erc/resources/base/modes/speaker-status.eld b/test/lisp/erc/resources/base/modes/speaker-status.eld
new file mode 100644
index 00000000000..4a7d508e35c
--- /dev/null
+++ b/test/lisp/erc/resources/base/modes/speaker-status.eld
@@ -0,0 +1,69 @@
+;; -*- mode: lisp-data; -*-
+((nick 10 "NICK tester"))
+((user 10 "USER tester 0 * :unknown")
+ (0.00 ":irc.example.net NOTICE * :*** Looking up your hostname...")
+ (0.00 ":irc.example.net NOTICE tester :*** Could not resolve your hostname: Domain not found; using your IP address (10.0.2.100) instead.")
+ (0.09 ":irc.example.net 001 tester :Welcome to the foonet IRC Network tester!tester@10.0.2.100")
+ (0.01 ":irc.example.net 002 tester :Your host is irc.example.net, running version InspIRCd-3")
+ (0.01 ":irc.example.net 003 tester :This server was created 07:50:59 Jan 22 2024")
+ (0.03 ":irc.example.net 004 tester irc.example.net InspIRCd-3 BIRcgikorsw ACHIKMORTVXabcefghijklmnopqrstvyz :HIVXabefghjkloqvy")
+ (0.00 ":irc.example.net 005 tester ACCEPT=30 AWAYLEN=200 BOT=B CALLERID=g CASEMAPPING=ascii CHANLIMIT=#:20 CHANMODES=IXbeg,k,Hfjl,ACKMORTcimnprstz CHANNELLEN=64 CHANTYPES=# ELIST=CMNTU ESILENCE=CcdiNnPpTtx EXCEPTS=e :are supported by this server")
+ (0.01 ":irc.example.net 005 tester EXTBAN=,ACORTUacjrwz HOSTLEN=64 INVEX=I KEYLEN=32 KICKLEN=255 LINELEN=512 MAXLIST=I:100,X:100,b:100,e:100,g:100 MAXTARGETS=20 MODES=20 MONITOR=30 NAMELEN=128 NAMESX NETWORK=foonet :are supported by this server")
+ (0.01 ":irc.example.net 005 tester NICKLEN=30 PREFIX=(yqaohvV)!~&@%+- SAFELIST SILENCE=32 STATUSMSG=!~&@%+- TOPICLEN=307 UHNAMES USERIP USERLEN=10 USERMODES=,,s,BIRcgikorw WHOX :are supported by this server")
+ (0.01 ":irc.example.net 251 tester :There are 2 users and 2 invisible on 2 servers")
+ (0.00 ":irc.example.net 252 tester 1 :operator(s) online")
+ (0.00 ":irc.example.net 253 tester 1 :unknown connections")
+ (0.00 ":irc.example.net 254 tester 2 :channels formed")
+ (0.00 ":irc.example.net 255 tester :I have 4 clients and 1 servers")
+ (0.00 ":irc.example.net 265 tester :Current local users: 4 Max: 5")
+ (0.00 ":irc.example.net 266 tester :Current global users: 4 Max: 5")
+ (0.00 ":irc.example.net 375 tester :irc.example.net message of the day")
+ (0.00 ":irc.example.net 372 tester : https://github.com/inspircd/inspircd-docker/issues")
+ (0.00 ":irc.example.net 372 tester : ")
+ (0.00 ":irc.example.net 372 tester : Have fun with the image!")
+ (0.00 ":irc.example.net 376 tester :End of message of the day.")
+ (0.00 ":irc.example.net 501 tester x :is not a recognised user mode.")
+ (0.00 ":NickServ!NickServ@services.int NOTICE tester :Welcome to foonet, tester! Here on foonet, we provide services to enable the registration of nicknames and channels! For details, type \2/msg NickServ help\2 and \2/msg ChanServ help\2."))
+
+((mode 10 "MODE tester +i")
+ (0.01 ":tester!tester@10.0.2.100 MODE tester :+i"))
+
+((join 10 "JOIN #chan")
+ (0.02 ":tester!tester@10.0.2.100 JOIN :#chan")
+ (0.02 ":irc.example.net 353 tester = #chan :+alice @fsbot -bob !foop tester")
+ (0.03 ":irc.example.net 366 tester #chan :End of /NAMES list.")
+ (0.00 ":bob!bob@localhost PRIVMSG #chan :tester, welcome!")
+ (0.01 ":alice!alice@localhost PRIVMSG #chan :tester, welcome!"))
+
+((mode-chan 10 "MODE #chan")
+ (0.00 ":irc.example.net 324 tester #chan :+nt")
+ (0.01 ":irc.example.net 329 tester #chan :1705909863")
+ (0.03 ":bob!bob@localhost PRIVMSG #chan :alice: Of that which hath so faithfully been paid.")
+ (0.03 ":alice!alice@localhost PRIVMSG #chan :Hie you, make haste, for it grows very late.")
+ (0.03 ":foop!user@netadmin.example.net PRIVMSG #chan :hi")
+ ;; (0.07 ":alice!alice@localhost PRIVMSG #chan :bob: And make a clear way to the gods.")
+ ;; (0.04 ":bob!bob@localhost PRIVMSG #chan :Why, that they have; and bid them so be gone.")
+ ;; (0.08 ":bob!bob@localhost PRIVMSG #chan :alice: Now stay your strife: what shall be is dispatch'd.")
+ (0.06 ":foop!user@netadmin.example.net MODE #chan +v :bob")
+ (0.05 ":bob!bob@localhost PRIVMSG #chan :alice: Fair as a text B in a copy-book.")
+ (0.07 ":alice!alice@localhost PRIVMSG #chan :bob: Even as Apemantus does now; hate a lord with my heart.")
+ (0.03 ":bob!bob@localhost PRIVMSG #chan :Then here is a supplication for you. And when you come to him, at the first approach you must kneel; then kiss his foot; then deliver up your pigeons; and then look for your reward. I'll be at hand, sir; see you do it bravely.")
+ (0.05 ":foop!user@netadmin.example.net MODE #chan -v :bob")
+ (0.04 ":bob!bob@localhost PRIVMSG #chan :alice: That's the way: for women are light at midnight.")
+ (0.04 ":alice!alice@localhost PRIVMSG #chan :Give it the beasts, to be rid of the men.")
+ ;; (0.02 ":alice!alice@localhost PRIVMSG #chan :bob: Here comes young Master Ganymede, my new mistress's brother.")
+ )
+
+((who-chan 10 "who #chan")
+ (0.03 ":irc.example.net 352 tester #chan alice localhost irc.example.net alice H+ :0 Irc bot based on irc3 http://irc3.readthedocs.io")
+ (0.03 ":irc.example.net 352 tester #chan fsbot localhost irc.example.net fsbot H@ :0 fsbot")
+ (0.01 ":irc.example.net 352 tester #chan bob localhost irc.example.net bob H- :0 Irc bot based on irc3 http://irc3.readthedocs.io")
+ (0.01 ":irc.example.net 352 tester #chan user netadmin.example.net irc.example.net foop H*! :0 unknown")
+ (0.01 ":irc.example.net 352 tester #chan tester 10.0.2.100 irc.example.net tester H :0 unknown")
+ (0.01 ":irc.example.net 315 tester #chan :End of /WHO list.")
+ ;; (0.09 ":bob!bob@localhost PRIVMSG #chan :alice: Shall nothing wrong him. Thus it is, general.")
+ ;; (0.04 ":alice!alice@localhost PRIVMSG #chan :bob: His father and I were soldiers together; to whom I have been often bound for no less than my life. Here comes the Briton: let him be so entertained amongst you as suits, with gentlemen of your knowing, to a stranger of his quality.")
+ (0.04 ":bob!bob@localhost PRIVMSG #chan :alice: Remains in danger of her former tooth."))
+
+((quit 10 "QUIT :\2ERC\2")
+ (0.03 "ERROR :Closing link: (tester@10.0.2.100) [Quit: \2ERC\2 5.x (IRC client for GNU Emacs)]"))
diff --git a/test/lisp/erc/resources/base/netid/bouncer/barnet-drop.eld b/test/lisp/erc/resources/base/netid/bouncer/barnet-drop.eld
index 686a47f68a3..04959954c4f 100644
--- a/test/lisp/erc/resources/base/netid/bouncer/barnet-drop.eld
+++ b/test/lisp/erc/resources/base/netid/bouncer/barnet-drop.eld
@@ -22,14 +22,14 @@
(0 ":irc.znc.in 306 tester :You have been marked as being away")
(0 ":irc.barnet.org 305 tester :You are no longer marked as being away"))
-((join 1 "JOIN #chan")
+((join 10 "JOIN #chan")
(0 ":tester!~u@awyxgybtkx7uq.irc JOIN #chan")
(0 ":irc.barnet.org 353 tester = #chan :@joe mike tester")
(0 ":irc.barnet.org 366 tester #chan :End of NAMES list")
(0.1 ":joe!~u@awyxgybtkx7uq.irc PRIVMSG #chan :tester, welcome!")
(0 ":mike!~u@awyxgybtkx7uq.irc PRIVMSG #chan :tester, welcome!"))
-((mode 1 "MODE #chan")
+((mode 10 "MODE #chan")
(0 ":irc.barnet.org 324 tester #chan +nt")
(0 ":irc.barnet.org 329 tester #chan 1620805269")
(0.1 ":mike!~u@awyxgybtkx7uq.irc PRIVMSG #chan :joe: But you have outfaced them all.")
diff --git a/test/lisp/erc/resources/base/netid/bouncer/barnet.eld b/test/lisp/erc/resources/base/netid/bouncer/barnet.eld
index d0fe3af8ea4..596383c2699 100644
--- a/test/lisp/erc/resources/base/netid/bouncer/barnet.eld
+++ b/test/lisp/erc/resources/base/netid/bouncer/barnet.eld
@@ -1,7 +1,7 @@
;; -*- mode: lisp-data; -*-
-((pass 3 "PASS :barnet:changeme"))
-((nick 3 "NICK tester"))
-((user 3 "USER user 0 * :tester")
+((pass 10 "PASS :barnet:changeme"))
+((nick 10 "NICK tester"))
+((user 10 "USER user 0 * :tester")
(0 ":irc.barnet.org 001 tester :Welcome to the barnet IRC Network tester")
(0 ":irc.barnet.org 002 tester :Your host is irc.barnet.org, running version oragono-2.6.0-7481bf0385b95b16")
(0 ":irc.barnet.org 003 tester :This server was created Wed, 12 May 2021 07:41:08 UTC")
@@ -17,19 +17,19 @@
(0 ":irc.barnet.org 266 tester 3 3 :Current global users 3, max 3")
(0 ":irc.barnet.org 422 tester :MOTD File is missing"))
-((mode-user 10.2 "MODE tester +i")
+((mode-user 10 "MODE tester +i")
;; No mode answer ^
(0 ":irc.znc.in 306 tester :You have been marked as being away")
(0 ":irc.barnet.org 305 tester :You are no longer marked as being away"))
-((join 1 "JOIN #chan")
+((join 10 "JOIN #chan")
(0 ":tester!~u@awyxgybtkx7uq.irc JOIN #chan")
(0 ":irc.barnet.org 353 tester = #chan :@joe mike tester")
(0 ":irc.barnet.org 366 tester #chan :End of NAMES list")
(0.1 ":joe!~u@awyxgybtkx7uq.irc PRIVMSG #chan :tester, welcome!")
(0 ":mike!~u@awyxgybtkx7uq.irc PRIVMSG #chan :tester, welcome!"))
-((mode 3 "MODE #chan")
+((mode 10 "MODE #chan")
(0 ":irc.barnet.org 324 tester #chan +nt")
(0 ":irc.barnet.org 329 tester #chan 1620805269")
(0.1 ":mike!~u@awyxgybtkx7uq.irc PRIVMSG #chan :joe: But you have outfaced them all.")
@@ -38,4 +38,4 @@
(0.05 ":joe!~u@awyxgybtkx7uq.irc PRIVMSG #chan :mike: As he regards his aged father's life.")
(0.05 ":mike!~u@awyxgybtkx7uq.irc PRIVMSG #chan :joe: It is a rupture that you may easily heal; and the cure of it not only saves your brother, but keeps you from dishonor in doing it."))
-((linger 1 LINGER))
+((linger 2 LINGER))
diff --git a/test/lisp/erc/resources/base/netid/bouncer/foonet-drop.eld b/test/lisp/erc/resources/base/netid/bouncer/foonet-drop.eld
index b99621cc311..d0445cd1dd5 100644
--- a/test/lisp/erc/resources/base/netid/bouncer/foonet-drop.eld
+++ b/test/lisp/erc/resources/base/netid/bouncer/foonet-drop.eld
@@ -1,5 +1,5 @@
;; -*- mode: lisp-data; -*-
-((pass 1 "PASS :foonet:changeme"))
+((pass 10 "PASS :foonet:changeme"))
((nick 1 "NICK tester"))
((user 1 "USER user 0 * :tester")
(0 ":irc.foonet.org 001 tester :Welcome to the foonet IRC Network tester")
@@ -22,14 +22,14 @@
(0 ":irc.znc.in 306 tester :You have been marked as being away")
(0 ":irc.foonet.org 305 tester :You are no longer marked as being away"))
-((join 1 "JOIN #chan")
+((join 10 "JOIN #chan")
(0 ":tester!~u@ertp7idh9jtgi.irc JOIN #chan")
(0 ":irc.foonet.org 353 tester = #chan :@alice bob tester")
(0 ":irc.foonet.org 366 tester #chan :End of NAMES list")
(0.1 ":alice!~u@ertp7idh9jtgi.irc PRIVMSG #chan :tester, welcome!")
(0 ":bob!~u@ertp7idh9jtgi.irc PRIVMSG #chan :tester, welcome!"))
-((mode 1 "MODE #chan")
+((mode 10 "MODE #chan")
(0 ":irc.foonet.org 324 tester #chan +nt")
(0 ":irc.foonet.org 329 tester #chan 1620805271")
(0.1 ":alice!~u@ertp7idh9jtgi.irc PRIVMSG #chan :bob: He cannot be heard of. Out of doubt he is transported.")
diff --git a/test/lisp/erc/resources/base/netid/bouncer/foonet.eld b/test/lisp/erc/resources/base/netid/bouncer/foonet.eld
index b0964fb9537..2e1a3ac27da 100644
--- a/test/lisp/erc/resources/base/netid/bouncer/foonet.eld
+++ b/test/lisp/erc/resources/base/netid/bouncer/foonet.eld
@@ -1,7 +1,7 @@
;; -*- mode: lisp-data; -*-
-((pass 3 "PASS :foonet:changeme"))
-((nick 3 "NICK tester"))
-((user 3 "USER user 0 * :tester")
+((pass 10 "PASS :foonet:changeme"))
+((nick 10 "NICK tester"))
+((user 10 "USER user 0 * :tester")
(0 ":irc.foonet.org 001 tester :Welcome to the foonet IRC Network tester")
(0 ":irc.foonet.org 002 tester :Your host is irc.foonet.org, running version oragono-2.6.0-7481bf0385b95b16")
(0 ":irc.foonet.org 003 tester :This server was created Wed, 12 May 2021 07:41:09 UTC")
@@ -17,19 +17,19 @@
(0 ":irc.foonet.org 266 tester 3 3 :Current global users 3, max 3")
(0 ":irc.foonet.org 422 tester :MOTD File is missing"))
-((mode-user 4.2 "MODE tester +i")
+((mode-user 10 "MODE tester +i")
;; No mode answer ^
(0 ":irc.znc.in 306 tester :You have been marked as being away")
(0 ":irc.foonet.org 305 tester :You are no longer marked as being away"))
-((join 1 "JOIN #chan")
+((join 10 "JOIN #chan")
(0 ":tester!~u@ertp7idh9jtgi.irc JOIN #chan")
(0 ":irc.foonet.org 353 tester = #chan :@alice bob tester")
(0 ":irc.foonet.org 366 tester #chan :End of NAMES list")
(0.1 ":alice!~u@ertp7idh9jtgi.irc PRIVMSG #chan :tester, welcome!")
(0 ":bob!~u@ertp7idh9jtgi.irc PRIVMSG #chan :tester, welcome!"))
-((mode 3 "MODE #chan")
+((mode 10 "MODE #chan")
(0 ":irc.foonet.org 324 tester #chan +nt")
(0 ":irc.foonet.org 329 tester #chan 1620805271")
(0.1 ":alice!~u@ertp7idh9jtgi.irc PRIVMSG #chan :bob: He cannot be heard of. Out of doubt he is transported.")
@@ -43,4 +43,4 @@
(0.1 ":alice!~u@ertp7idh9jtgi.irc PRIVMSG #chan :bob: Orlando, my liege; the youngest son of Sir Rowland de Boys.")
(0.1 ":bob!~u@ertp7idh9jtgi.irc PRIVMSG #chan :alice: The ape is dead, and I must conjure him."))
-((linger 1 LINGER))
+((linger 2 LINGER))
diff --git a/test/lisp/erc/resources/base/reconnect/aborted-dupe.eld b/test/lisp/erc/resources/base/reconnect/aborted-dupe.eld
index 8e299ec44c0..35906f608b5 100644
--- a/test/lisp/erc/resources/base/reconnect/aborted-dupe.eld
+++ b/test/lisp/erc/resources/base/reconnect/aborted-dupe.eld
@@ -19,7 +19,7 @@
(-0.02 ":irc.foonet.org 266 tester 3 3 :Current global users 3, max 3")
(-0.02 ":irc.foonet.org 422 tester :MOTD File is missing"))
-((~mode-user 3.2 "MODE tester +i")
+((~mode-user 10 "MODE tester +i")
(-0.02 ":irc.foonet.org 221 tester +i")
(-0.02 ":irc.foonet.org NOTICE tester :This server is in debug mode and is logging all user I/O. If you do not wish for everything you send to be readable by the server owner(s), please disconnect."))
diff --git a/test/lisp/erc/resources/base/reconnect/aborted.eld b/test/lisp/erc/resources/base/reconnect/aborted.eld
index 5c32070d85f..e3abcdf8415 100644
--- a/test/lisp/erc/resources/base/reconnect/aborted.eld
+++ b/test/lisp/erc/resources/base/reconnect/aborted.eld
@@ -18,7 +18,7 @@
(0 ":irc.foonet.org 266 tester 3 3 :Current global users 3, max 3")
(0 ":irc.foonet.org 422 tester :MOTD File is missing"))
-((mode-user 3.2 "MODE tester +i")
+((mode-user 10 "MODE tester +i")
(0 ":irc.foonet.org 221 tester +i")
(0 ":irc.foonet.org NOTICE tester :This server is in debug mode and is logging all user I/O. If you do not wish for everything you send to be readable by the server owner(s), please disconnect."))
diff --git a/test/lisp/erc/resources/base/reconnect/just-eof.eld b/test/lisp/erc/resources/base/reconnect/just-eof.eld
new file mode 100644
index 00000000000..c80a39b3170
--- /dev/null
+++ b/test/lisp/erc/resources/base/reconnect/just-eof.eld
@@ -0,0 +1,3 @@
+;; -*- mode: lisp-data; -*-
+((eof 5 EOF))
+((drop 0 DROP))
diff --git a/test/lisp/erc/resources/base/reconnect/just-ping.eld b/test/lisp/erc/resources/base/reconnect/just-ping.eld
new file mode 100644
index 00000000000..d57888b42d3
--- /dev/null
+++ b/test/lisp/erc/resources/base/reconnect/just-ping.eld
@@ -0,0 +1,4 @@
+;; -*- mode: lisp-data; -*-
+((ping 20 "PING"))
+
+((eof 10 EOF))
diff --git a/test/lisp/erc/resources/base/reconnect/options-again.eld b/test/lisp/erc/resources/base/reconnect/options-again.eld
index f1fcc439cc3..8a3264fda9c 100644
--- a/test/lisp/erc/resources/base/reconnect/options-again.eld
+++ b/test/lisp/erc/resources/base/reconnect/options-again.eld
@@ -32,13 +32,13 @@
(0 ":irc.foonet.org 353 tester = #spam :alice tester @bob")
(0 ":irc.foonet.org 366 tester #spam :End of NAMES list"))
-((~mode-chan 4 "MODE #chan")
+((~mode-chan 10 "MODE #chan")
(0 ":irc.foonet.org 324 tester #chan +nt")
(0 ":irc.foonet.org 329 tester #chan 1620104779")
(0.1 ":bob!~u@rz2v467q4rwhy.irc PRIVMSG #chan :alice: But, as it seems, did violence on herself.")
(0.1 ":alice!~u@rz2v467q4rwhy.irc PRIVMSG #chan :bob: Well, this is the forest of Arden."))
-((mode-spam 4 "MODE #spam")
+((mode-spam 20 "MODE #spam")
(0 ":irc.foonet.org 324 tester #spam +nt")
(0 ":irc.foonet.org 329 tester #spam 1620104779")
(0.1 ":bob!~u@rz2v467q4rwhy.irc PRIVMSG #spam :alice: Signior Iachimo will not from it. Pray, let us follow 'em.")
diff --git a/test/lisp/erc/resources/base/reconnect/options.eld b/test/lisp/erc/resources/base/reconnect/options.eld
index 3b305d85594..e0952a2aece 100644
--- a/test/lisp/erc/resources/base/reconnect/options.eld
+++ b/test/lisp/erc/resources/base/reconnect/options.eld
@@ -1,7 +1,7 @@
;; -*- mode: lisp-data; -*-
-((pass 1 "PASS :changeme"))
-((nick 1 "NICK tester"))
-((user 1 "USER user 0 * :tester")
+((pass 10 "PASS :changeme"))
+((nick 10 "NICK tester"))
+((user 10 "USER user 0 * :tester")
(0 ":irc.foonet.org 001 tester :Welcome to the foonet IRC Network tester")
(0 ":irc.foonet.org 002 tester :Your host is irc.foonet.org, running version oragono-2.6.0-7481bf0385b95b16")
(0 ":irc.foonet.org 003 tester :This server was created Tue, 04 May 2021 05:06:18 UTC")
@@ -18,7 +18,7 @@
(0 ":irc.foonet.org 266 tester 3 3 :Current global users 3, max 3")
(0 ":irc.foonet.org 422 tester :MOTD File is missing"))
-((mode-user 3.2 "MODE tester +i")
+((mode-user 10 "MODE tester +i")
(0 ":irc.foonet.org 221 tester +i")
(0 ":irc.foonet.org NOTICE tester :This server is in debug mode.")
@@ -26,7 +26,7 @@
(0 ":irc.foonet.org 353 tester = #chan :alice tester @bob")
(0 ":irc.foonet.org 366 tester #chan :End of NAMES list"))
-((mode-chan 4 "MODE #chan")
+((mode-chan 10 "MODE #chan")
(0 ":irc.foonet.org 324 tester #chan +nt")
(0 ":irc.foonet.org 329 tester #chan 1620104779")
(0.1 ":bob!~u@rz2v467q4rwhy.irc PRIVMSG #chan :tester, welcome!")
diff --git a/test/lisp/erc/resources/base/reconnect/ping-pong.eld b/test/lisp/erc/resources/base/reconnect/ping-pong.eld
new file mode 100644
index 00000000000..b3d36cf6cec
--- /dev/null
+++ b/test/lisp/erc/resources/base/reconnect/ping-pong.eld
@@ -0,0 +1,6 @@
+;; -*- mode: lisp-data; -*-
+((ping 10 "PING ")
+ (0 "PONG fake"))
+
+((eof 10 EOF))
+((drop 0 DROP))
diff --git a/test/lisp/erc/resources/base/reconnect/unexpected-disconnect.eld b/test/lisp/erc/resources/base/reconnect/unexpected-disconnect.eld
new file mode 100644
index 00000000000..386d0f4b085
--- /dev/null
+++ b/test/lisp/erc/resources/base/reconnect/unexpected-disconnect.eld
@@ -0,0 +1,24 @@
+;; -*- mode: lisp-data; -*-
+((nick 10 "NICK tester"))
+((user 10 "USER user 0 * :tester")
+ (0 ":irc.foonet.org 001 tester :Welcome to the foonet IRC Network tester")
+ (0 ":irc.foonet.org 002 tester :Your host is irc.foonet.org, running version oragono-2.6.0-7481bf0385b95b16")
+ (0 ":irc.foonet.org 003 tester :This server was created Tue, 04 May 2021 05:06:18 UTC")
+ (0 ":irc.foonet.org 004 tester irc.foonet.org oragono-2.6.0-7481bf0385b95b16 BERTZios CEIMRUabefhiklmnoqstuv Iabefhkloqv")
+ (0 ":irc.foonet.org 005 tester AWAYLEN=390 BOT=B CASEMAPPING=ascii CHANLIMIT=#:100 CHANMODES=Ibe,k,fl,CEMRUimnstu CHANNELLEN=64 CHANTYPES=# ELIST=U EXCEPTS EXTBAN=,m FORWARD=f INVEX KICKLEN=390 :are supported by this server")
+ (0 ":irc.foonet.org 005 tester MAXLIST=beI:60 MAXTARGETS=4 MODES MONITOR=100 NETWORK=FooNet NICKLEN=32 PREFIX=(qaohv)~&@%+ STATUSMSG=~&@%+ TARGMAX=NAMES:1,LIST:1,KICK:1,WHOIS:1,USERHOST:10,PRIVMSG:4,TAGMSG:4,NOTICE:4,MONITOR:100 TOPICLEN=390 UTF8MAPPING=rfc8265 UTF8ONLY WHOX :are supported by this server")
+ (0 ":irc.foonet.org 005 tester draft/CHATHISTORY=100 :are supported by this server")
+ (0 ":irc.foonet.org 251 tester :There are 0 users and 3 invisible on 1 server(s)")
+ (0 ":irc.foonet.org 252 tester 0 :IRC Operators online")
+ (0 ":irc.foonet.org 253 tester 0 :unregistered connections")
+ (0 ":irc.foonet.org 254 tester 1 :channels formed")
+ (0 ":irc.foonet.org 255 tester :I have 3 clients and 0 servers")
+ (0 ":irc.foonet.org 265 tester 3 3 :Current local users 3, max 3")
+ (0 ":irc.foonet.org 266 tester 3 3 :Current global users 3, max 3")
+ (0 ":irc.foonet.org 422 tester :MOTD File is missing"))
+
+((mode-user 10 "MODE tester +i")
+ (0 ":irc.foonet.org 221 tester +i")
+ (0 ":irc.foonet.org NOTICE tester :This server is in debug mode and is logging all user I/O. If you do not wish for everything you send to be readable by the server owner(s), please disconnect."))
+
+((drop 0 DROP))
diff --git a/test/lisp/erc/resources/base/renick/queries/bouncer-barnet.eld b/test/lisp/erc/resources/base/renick/queries/bouncer-barnet.eld
index 0c8cdac0379..c9080cf39e9 100644
--- a/test/lisp/erc/resources/base/renick/queries/bouncer-barnet.eld
+++ b/test/lisp/erc/resources/base/renick/queries/bouncer-barnet.eld
@@ -1,7 +1,7 @@
;; -*- mode: lisp-data; -*-
-((pass 3 "PASS :barnet:changeme"))
-((nick 3 "NICK tester"))
-((user 3 "USER user 0 * :tester")
+((pass 10 "PASS :barnet:changeme"))
+((nick 10 "NICK tester"))
+((user 10 "USER user 0 * :tester")
(0 ":irc.barnet.org 001 tester :Welcome to the barnet IRC Network tester")
(0 ":irc.barnet.org 002 tester :Your host is irc.barnet.org, running version oragono-2.6.0-7481bf0385b95b16")
(0 ":irc.barnet.org 003 tester :This server was created Tue, 01 Jun 2021 07:49:23 UTC")
@@ -17,7 +17,7 @@
(0 ":irc.barnet.org 266 tester 3 3 :Current global users 3, max 3")
(0 ":irc.barnet.org 422 tester :MOTD File is missing"))
-((mode-user 3.2 "MODE tester +i")
+((mode-user 10 "MODE tester +i")
;; No mode answer
(0 ":irc.znc.in 306 tester :You have been marked as being away")
(0 ":tester!~u@286u8jcpis84e.irc JOIN #chan")
@@ -32,18 +32,18 @@
(0 ":irc.barnet.org NOTICE tester :[09:13:24] This server is in debug mode and is logging all user I/O. If you do not wish for everything you send to be readable by the server owner(s), please disconnect.")
(0 ":irc.barnet.org 305 tester :You are no longer marked as being away"))
-((mode 5 "MODE #chan")
+((mode 10 "MODE #chan")
(0 ":irc.barnet.org 324 tester #chan +nt")
(0 ":irc.barnet.org 329 tester #chan 1622538742")
(0.1 ":joe!~u@286u8jcpis84e.irc PRIVMSG #chan :mike: By favors several which they did bestow.")
(0.1 ":mike!~u@286u8jcpis84e.irc PRIVMSG #chan :joe: You, Roderigo! come, sir, I am for you."))
-((privmsg-a 5 "PRIVMSG rando :Linda said you were gonna kill me.")
+((privmsg-a 10 "PRIVMSG rando :Linda said you were gonna kill me.")
(0.1 ":joe!~u@286u8jcpis84e.irc PRIVMSG #chan :mike: Play, music, then! Nay, you must do it soon.")
(0.1 ":rando!~u@95i756tt32ym8.irc PRIVMSG tester :Linda said? I never saw her before I came up here.")
(0.1 ":mike!~u@286u8jcpis84e.irc PRIVMSG #chan :joe: Of arts inhibited and out of warrant."))
-((privmsg-b 3 "PRIVMSG rando :You aren't with Wage?")
+((privmsg-b 10 "PRIVMSG rando :You aren't with Wage?")
(0.1 ":joe!~u@286u8jcpis84e.irc PRIVMSG #chan :mike: But most of all, agreeing with the proclamation.")
(0.1 ":rando!~u@95i756tt32ym8.irc PRIVMSG tester :I think you screwed up, Case.")
(0.1 ":mike!~u@286u8jcpis84e.irc PRIVMSG #chan :joe: Good gentleman, go your gait, and let poor volk pass. An chud ha' bin zwaggered out of my life, 'twould not ha' bin zo long as 'tis by a vortnight. Nay, come not near th' old man; keep out, che vor ye, or ise try whether your costard or my ballow be the harder. Chill be plain with you.")
diff --git a/test/lisp/erc/resources/base/renick/queries/bouncer-foonet.eld b/test/lisp/erc/resources/base/renick/queries/bouncer-foonet.eld
index 162e8bf9655..2421651ebe8 100644
--- a/test/lisp/erc/resources/base/renick/queries/bouncer-foonet.eld
+++ b/test/lisp/erc/resources/base/renick/queries/bouncer-foonet.eld
@@ -1,7 +1,7 @@
;; -*- mode: lisp-data; -*-
-((pass 1 "PASS :foonet:changeme"))
-((nick 1 "NICK tester"))
-((user 1 "USER user 0 * :tester")
+((pass 10 "PASS :foonet:changeme"))
+((nick 10 "NICK tester"))
+((user 10 "USER user 0 * :tester")
(0 ":irc.foonet.org 001 tester :Welcome to the foonet IRC Network tester")
(0 ":irc.foonet.org 002 tester :Your host is irc.foonet.org, running version oragono-2.6.0-7481bf0385b95b16")
(0 ":irc.foonet.org 003 tester :This server was created Tue, 01 Jun 2021 07:49:22 UTC")
@@ -17,7 +17,7 @@
(0 ":irc.foonet.org 266 tester 3 3 :Current global users 3, max 3")
(0 ":irc.foonet.org 422 tester :MOTD File is missing"))
-((mode-user 5.2 "MODE tester +i")
+((mode-user 10 "MODE tester +i")
;; No mode answer
(0 ":irc.znc.in 306 tester :You have been marked as being away")
(0 ":tester!~u@u4mvbswyw8gbg.irc JOIN #chan")
@@ -38,12 +38,12 @@
(0.1 ":bob!~u@u4mvbswyw8gbg.irc PRIVMSG #chan :alice: When there is nothing living but thee, thou shalt be welcome. I had rather be a beggar's dog than Apemantus.")
(0.1 ":alice!~u@u4mvbswyw8gbg.irc PRIVMSG #chan :bob: You have simply misused our sex in your love-prate: we must have your doublot and hose plucked over your head, and show the world what the bird hath done to her own nest."))
-((privmsg-a 6 "PRIVMSG rando :I here")
+((privmsg-a 10 "PRIVMSG rando :I here")
(0.1 ":bob!~u@u4mvbswyw8gbg.irc PRIVMSG #chan :alice: And I will make thee think thy swan a crow.")
(0.1 ":rando!~u@bivkhq8yav938.irc PRIVMSG tester :u are dumb")
(0.1 ":alice!~u@u4mvbswyw8gbg.irc PRIVMSG #chan :bob: Lie not, to say mine eyes are murderers."))
-((privmsg-b 3 "PRIVMSG rando :not so")
+((privmsg-b 10 "PRIVMSG rando :not so")
(0.1 ":bob!~u@u4mvbswyw8gbg.irc PRIVMSG #chan :alice: Commit myself, my person, and the cause.")
;; Nick change
(0.1 ":rando!~u@bivkhq8yav938.irc NICK frenemy")
diff --git a/test/lisp/erc/resources/base/renick/queries/solo.eld b/test/lisp/erc/resources/base/renick/queries/solo.eld
index 12fa7d264e9..fa4c075adac 100644
--- a/test/lisp/erc/resources/base/renick/queries/solo.eld
+++ b/test/lisp/erc/resources/base/renick/queries/solo.eld
@@ -30,7 +30,7 @@
(0 ":irc.foonet.org NOTICE tester :[09:56:57] This server is in debug mode and is logging all user I/O. If you do not wish for everything you send to be readable by the server owner(s), please disconnect.")
(0 ":irc.foonet.org 305 tester :You are no longer marked as being away"))
-((mode 1 "MODE #foo")
+((mode 10 "MODE #foo")
(0 ":irc.foonet.org 324 tester #foo +nt")
(0 ":irc.foonet.org 329 tester #foo 1622454985")
(0.1 ":alice!~u@gq7yjr7gsu7nn.irc PRIVMSG #foo :bob: Farewell, pretty lady: you must hold the credit of your father.")
diff --git a/test/lisp/erc/resources/base/renick/self/qual-chester.eld b/test/lisp/erc/resources/base/renick/self/qual-chester.eld
index 75b50fe68bd..a224e0451d7 100644
--- a/test/lisp/erc/resources/base/renick/self/qual-chester.eld
+++ b/test/lisp/erc/resources/base/renick/self/qual-chester.eld
@@ -18,7 +18,7 @@
(0 ":irc.foonet.org 266 chester 3 4 :Current global users 3, max 4")
(0 ":irc.foonet.org 422 chester :MOTD File is missing"))
-((mode-user 1.2 "MODE chester +i")
+((mode-user 10 "MODE chester +i")
(0 ":irc.foonet.org 221 chester +i")
(0 ":irc.foonet.org NOTICE chester :This server is in debug mode and is logging all user I/O. If you do not wish for everything you send to be readable by the server owner(s), please disconnect."))
diff --git a/test/lisp/erc/resources/base/renick/self/qual-tester.eld b/test/lisp/erc/resources/base/renick/self/qual-tester.eld
index 25199226658..27061c65223 100644
--- a/test/lisp/erc/resources/base/renick/self/qual-tester.eld
+++ b/test/lisp/erc/resources/base/renick/self/qual-tester.eld
@@ -18,7 +18,7 @@
(0 ":irc.foonet.org 266 tester 4 4 :Current global users 4, max 4")
(0 ":irc.foonet.org 422 tester :MOTD File is missing"))
-((mode-user 1.2 "MODE tester +i")
+((mode-user 10 "MODE tester +i")
(0 ":irc.foonet.org 221 tester +i")
(0 ":irc.foonet.org NOTICE tester :This server is in debug mode and is logging all user I/O. If you do not wish for everything you send to be readable by the server owner(s), please disconnect."))
diff --git a/test/lisp/erc/resources/base/reuse-buffers/channel/barnet.eld b/test/lisp/erc/resources/base/reuse-buffers/channel/barnet.eld
index efc2506fd6f..d106a45cf66 100644
--- a/test/lisp/erc/resources/base/reuse-buffers/channel/barnet.eld
+++ b/test/lisp/erc/resources/base/reuse-buffers/channel/barnet.eld
@@ -56,7 +56,7 @@
(0.1 ":mike!~u@wvys46tx8tpmk.irc PRIVMSG #chan :tester, welcome!")
(0 ":joe!~u@wvys46tx8tpmk.irc PRIVMSG #chan :tester, welcome!"))
-((mode 1 "MODE #chan")
+((mode 10 "MODE #chan")
(0 ":irc.barnet.org 324 tester #chan +nt")
(0 ":irc.barnet.org 329 tester #chan 1620205534")
(0.1 ":mike!~u@wvys46tx8tpmk.irc PRIVMSG #chan :joe: Chi non te vede, non te pretia.")
diff --git a/test/lisp/erc/resources/base/reuse-buffers/channel/foonet.eld b/test/lisp/erc/resources/base/reuse-buffers/channel/foonet.eld
index a11cfac2e73..603afa2fc3e 100644
--- a/test/lisp/erc/resources/base/reuse-buffers/channel/foonet.eld
+++ b/test/lisp/erc/resources/base/reuse-buffers/channel/foonet.eld
@@ -52,7 +52,7 @@
(0.1 ":alice!~u@yppdd5tt4admc.irc PRIVMSG #chan :tester, welcome!")
(0 ":bob!~u@yppdd5tt4admc.irc PRIVMSG #chan :tester, welcome!"))
-((mode 1 "MODE #chan")
+((mode 10 "MODE #chan")
(0 ":irc.foonet.org 324 tester #chan +nt")
(0 ":irc.foonet.org 329 tester #chan 1620205534")
(0.1 ":bob!~u@yppdd5tt4admc.irc PRIVMSG #chan :alice: Thou desirest me to stop in my tale against the hair.")
diff --git a/test/lisp/erc/resources/base/reuse-buffers/server/barnet.eld b/test/lisp/erc/resources/base/reuse-buffers/server/barnet.eld
index cc7aff10076..5b64a58c98f 100644
--- a/test/lisp/erc/resources/base/reuse-buffers/server/barnet.eld
+++ b/test/lisp/erc/resources/base/reuse-buffers/server/barnet.eld
@@ -1,7 +1,7 @@
;; -*- mode: lisp-data; -*-
-((pass 1 "PASS :barnet:changeme"))
-((nick 1 "NICK tester"))
-((user 2 "USER user 0 * :tester")
+((pass 10 "PASS :barnet:changeme"))
+((nick 10 "NICK tester"))
+((user 10 "USER user 0 * :tester")
(0 ":irc.barnet.org 001 tester :Welcome to the barnet IRC Network tester")
(0 ":irc.barnet.org 002 tester :Your host is irc.barnet.org, running version oragono-2.6.0-7481bf0385b95b16")
(0 ":irc.barnet.org 003 tester :This server was created Sun, 25 Apr 2021 11:28:28 UTC")
diff --git a/test/lisp/erc/resources/base/reuse-buffers/server/foonet.eld b/test/lisp/erc/resources/base/reuse-buffers/server/foonet.eld
index 3a846108466..260ff74c20c 100644
--- a/test/lisp/erc/resources/base/reuse-buffers/server/foonet.eld
+++ b/test/lisp/erc/resources/base/reuse-buffers/server/foonet.eld
@@ -1,7 +1,7 @@
;; -*- mode: lisp-data; -*-
-((pass 1 "PASS :foonet:changeme"))
-((nick 1 "NICK tester"))
-((user 1 "USER user 0 * :tester")
+((pass 10 "PASS :foonet:changeme"))
+((nick 10 "NICK tester"))
+((user 10 "USER user 0 * :tester")
(0 ":irc.foonet.org 001 tester :Welcome to the foonet IRC Network tester")
(0 ":irc.foonet.org 002 tester :Your host is irc.foonet.org, running version oragono-2.6.0-7481bf0385b95b16")
(0 ":irc.foonet.org 003 tester :This server was created Sun, 25 Apr 2021 11:28:28 UTC")
diff --git a/test/lisp/erc/resources/base/send-message/noncommands.eld b/test/lisp/erc/resources/base/send-message/noncommands.eld
new file mode 100644
index 00000000000..ba210bfff6f
--- /dev/null
+++ b/test/lisp/erc/resources/base/send-message/noncommands.eld
@@ -0,0 +1,52 @@
+;; -*- mode: lisp-data; -*-
+((nick 10 "NICK tester"))
+((user 10 "USER user 0 * :tester")
+ (0.00 ":irc.foonet.org 001 tester :Welcome to the foonet IRC Network tester")
+ (0.01 ":irc.foonet.org 002 tester :Your host is irc.foonet.org, running version ergo-v2.11.1")
+ (0.01 ":irc.foonet.org 003 tester :This server was created Sun, 12 Nov 2023 17:40:20 UTC")
+ (0.01 ":irc.foonet.org 004 tester irc.foonet.org ergo-v2.11.1 BERTZios CEIMRUabefhiklmnoqstuv Iabefhkloqv")
+ (0.00 ":irc.foonet.org 005 tester AWAYLEN=390 BOT=B CASEMAPPING=ascii CHANLIMIT=#:100 CHANMODES=Ibe,k,fl,CEMRUimnstu CHANNELLEN=64 CHANTYPES=# CHATHISTORY=1000 ELIST=U EXCEPTS EXTBAN=,m FORWARD=f INVEX :are supported by this server")
+ (0.02 ":irc.foonet.org 005 tester KICKLEN=390 MAXLIST=beI:60 MAXTARGETS=4 MODES MONITOR=100 NETWORK=foonet NICKLEN=32 PREFIX=(qaohv)~&@%+ STATUSMSG=~&@%+ TARGMAX=NAMES:1,LIST:1,KICK:,WHOIS:1,USERHOST:10,PRIVMSG:4,TAGMSG:4,NOTICE:4,MONITOR:100 TOPICLEN=390 UTF8ONLY WHOX :are supported by this server")
+ (0.01 ":irc.foonet.org 005 tester draft/CHATHISTORY=1000 :are supported by this server")
+ (0.01 ":irc.foonet.org 251 tester :There are 0 users and 4 invisible on 1 server(s)")
+ (0.01 ":irc.foonet.org 252 tester 0 :IRC Operators online")
+ (0.01 ":irc.foonet.org 253 tester 0 :unregistered connections")
+ (0.01 ":irc.foonet.org 254 tester 2 :channels formed")
+ (0.01 ":irc.foonet.org 255 tester :I have 4 clients and 0 servers")
+ (0.01 ":irc.foonet.org 265 tester 4 4 :Current local users 4, max 4")
+ (0.01 ":irc.foonet.org 266 tester 4 4 :Current global users 4, max 4")
+ (0.02 ":irc.foonet.org 422 tester :MOTD File is missing")
+ (0.00 ":irc.foonet.org 221 tester +i")
+ (0.01 ":irc.foonet.org NOTICE tester :This server is in debug mode and is logging all user I/O. If you do not wish for everything you send to be readable by the server owner(s), please disconnect."))
+
+((mode-tester 10 "MODE tester +i"))
+
+((join-chan 10 "JOIN #chan")
+ (0.00 ":irc.foonet.org 221 tester +i")
+ (0.01 ":tester!~u@ggpg6r3a68wak.irc JOIN #chan")
+ (0.03 ":irc.foonet.org 353 tester = #chan :@fsbot bob alice tester")
+ (0.01 ":irc.foonet.org 366 tester #chan :End of NAMES list")
+ (0.00 ":bob!~u@cjn7mjwx57gbi.irc PRIVMSG #chan :tester, welcome!")
+ (0.01 ":alice!~u@cjn7mjwx57gbi.irc PRIVMSG #chan :tester, welcome!"))
+
+((mode-chan 10 "MODE #chan")
+ (0.00 ":irc.foonet.org 324 tester #chan +Cnt")
+ (0.02 ":irc.foonet.org 329 tester #chan 1699810829")
+ (0.01 ":alice!~u@cjn7mjwx57gbi.irc PRIVMSG #chan :bob: To prove him false that says I love thee not.")
+ (0.02 ":bob!~u@cjn7mjwx57gbi.irc PRIVMSG #chan :alice: For hands, to do Rome service, are but vain."))
+
+((privmsg-action 10 "PRIVMSG #chan :\1ACTION sad\1")
+ (0.07 ":alice!~u@cjn7mjwx57gbi.irc PRIVMSG #chan :bob: Spotted, detested, and abominable."))
+
+((privmsg-me 10 "PRIVMSG #chan :/me sad")
+ (0.03 ":bob!~u@cjn7mjwx57gbi.irc PRIVMSG #chan :Marcus, my brother! 'tis sad Titus calls."))
+
+((privmsg-sv 10 "PRIVMSG #chan :I'm using ERC " (+ (not " ")) " with GNU Emacs")
+ (0.07 ":bob!~u@cjn7mjwx57gbi.irc PRIVMSG #chan :alice: You still wrangle with her, Boyet, and she strikes at the brow."))
+
+((privmsg-sm 10 "PRIVMSG #chan :I'm using the following modules: `erc-autojoin-mode', ")
+ (0.04 ":alice!~u@cjn7mjwx57gbi.irc PRIVMSG #chan :No, not till Thursday; there is time enough."))
+
+((quit 10 "QUIT :\2ERC\2")
+ (0.05 ":tester!~u@ggpg6r3a68wak.irc QUIT :Quit: \2ERC\2 5.x (IRC client for GNU Emacs)")
+ (0.02 "ERROR :Quit: \2ERC\2 5.x (IRC client for GNU Emacs)"))
diff --git a/test/lisp/erc/resources/base/upstream-reconnect/znc-severed.eld b/test/lisp/erc/resources/base/upstream-reconnect/znc-severed.eld
new file mode 100644
index 00000000000..32d05cc8a3a
--- /dev/null
+++ b/test/lisp/erc/resources/base/upstream-reconnect/znc-severed.eld
@@ -0,0 +1,87 @@
+;; -*- mode: lisp-data; -*-
+((pass 10 "PASS :changeme"))
+((nick 10 "NICK tester"))
+((user 10 "USER tester@vanilla/foonet 0 * :tester")
+ (0.00 ":irc.znc.in 001 tester :Welcome to ZNC")
+ (0.03 ":*status!znc@znc.in PRIVMSG tester :Connection Refused. Reconnecting...")
+ (0.01 ":*status!znc@znc.in PRIVMSG tester :Connection Refused. Reconnecting...")
+ (0.00 ":*status!znc@znc.in PRIVMSG tester :Connection Refused. Reconnecting...")
+ (0.01 ":*status!znc@znc.in PRIVMSG tester :Connected!")
+ (0.02 ":irc.foonet.org 001 tester :Welcome to the foonet IRC Network tester")
+ (0.01 ":irc.foonet.org 002 tester :Your host is irc.foonet.org, running version ergo-v2.11.1")
+ (0.01 ":irc.foonet.org 003 tester :This server was created Wed, 31 Jan 2024 10:58:16 UTC")
+ (0.01 ":irc.foonet.org 004 tester irc.foonet.org ergo-v2.11.1 BERTZios CEIMRUabefhiklmnoqstuv Iabefhkloqv")
+ (0.00 ":irc.foonet.org 005 tester AWAYLEN=390 BOT=B CASEMAPPING=ascii CHANLIMIT=#:100 CHANMODES=Ibe,k,fl,CEMRUimnstu CHANNELLEN=64 CHANTYPES=# CHATHISTORY=1000 ELIST=U EXCEPTS EXTBAN=,m FORWARD=f INVEX :are supported by this server")
+ (0.01 ":irc.foonet.org 005 tester KICKLEN=390 MAXLIST=beI:60 MAXTARGETS=4 MODES MONITOR=100 NETWORK=foonet NICKLEN=32 PREFIX=(qaohv)~&@%+ STATUSMSG=~&@%+ TARGMAX=NAMES:1,LIST:1,KICK:,WHOIS:1,USERHOST:10,PRIVMSG:4,TAGMSG:4,NOTICE:4,MONITOR:100 TOPICLEN=390 UTF8ONLY WHOX :are supported by this server")
+ (0.01 ":irc.foonet.org 005 tester draft/CHATHISTORY=1000 :are supported by this server")
+ (0.00 ":irc.foonet.org 251 tester :There are 0 users and 3 invisible on 1 server(s)")
+ (0.00 ":irc.foonet.org 252 tester 0 :IRC Operators online")
+ (0.00 ":irc.foonet.org 253 tester 0 :unregistered connections")
+ (0.00 ":irc.foonet.org 254 tester 1 :channels formed")
+ (0.00 ":irc.foonet.org 255 tester :I have 3 clients and 0 servers")
+ (0.00 ":irc.foonet.org 265 tester 3 3 :Current local users 3, max 3")
+ (0.00 ":irc.foonet.org 266 tester 3 3 :Current global users 3, max 3")
+ (0.00 ":irc.foonet.org 422 tester :MOTD File is missing")
+ (0.00 ":irc.foonet.org 221 tester +Zi")
+ (0.00 ":irc.foonet.org NOTICE tester :This server is in debug mode and is logging all user I/O. If you do not wish for everything you send to be readable by the server owner(s), please disconnect."))
+
+((mode 10 "MODE tester +i")
+ (0.01 ":irc.foonet.org 352 tester * ~u pfa3tpa5ig5ty.irc irc.foonet.org tester H :0 ZNC - https://znc.in")
+ (0.01 ":irc.foonet.org 315 tester tester :End of WHO list")
+
+ (0.02 ":tester!~u@pfa3tpa5ig5ty.irc JOIN #chan")
+ (0.03 ":irc.foonet.org 353 tester = #chan :bob tester @alice eve"))
+
+((mode 10 "MODE #chan")
+ (0.00 ":irc.foonet.org 366 tester #chan :End of NAMES list")
+ (0.00 ":bob!~u@euegh6mj3y8r2.irc PRIVMSG #chan :tester, welcome!")
+ (0.01 ":alice!~u@euegh6mj3y8r2.irc PRIVMSG #chan :tester, welcome!")
+ (0.01 ":bob!~u@euegh6mj3y8r2.irc PRIVMSG #chan :alice: And see how he will take it at your hands.")
+ (0.02 ":irc.foonet.org 221 tester +Zi")
+ (0.01 ":alice!~u@euegh6mj3y8r2.irc PRIVMSG #chan :bob: Fear not, my lord, your servant shall do so.")
+ (0.02 ":bob!~u@euegh6mj3y8r2.irc PRIVMSG #chan :alice: If I thrive well, I'll visit thee again.")
+ (0.01 ":irc.foonet.org 324 tester #chan +Cnt")
+ (0.03 ":irc.foonet.org 329 tester #chan 1706698713")
+ (0.05 ":alice!~u@euegh6mj3y8r2.irc PRIVMSG #chan :bob: Let it be forbid, sir; so should I be a great deal of his act.")
+ (0.04 ":bob!~u@euegh6mj3y8r2.irc PRIVMSG #chan :alice: And see a fearful sight of blood and death.")
+ (0.00 ":eve!~u@euegh6mj3y8r2.irc PRIVMSG #chan :hola")
+ (0.01 ":eve!~u@euegh6mj3y8r2.irc NICK :Evel")
+ (0.01 ":Evel!~u@euegh6mj3y8r2.irc PRIVMSG #chan :hell o")
+ (0.02 ":alice!~u@euegh6mj3y8r2.irc PRIVMSG #chan :bob: His highness comes post from Marseilles, of as able body as when he numbered thirty: he will be here to-morrow, or I am deceived by him that in such intelligence hath seldom failed.")
+ (0.03 ":bob!~u@euegh6mj3y8r2.irc PRIVMSG #chan :alice: See, by good hap, yonder's my lord; I have sweat to see his honour.")
+ (0.02 ":alice!~u@euegh6mj3y8r2.irc PRIVMSG #chan :bob: With the rich worth of your virginity.")
+
+ (0.02 ":*status!znc@znc.in PRIVMSG tester :Disconnected from IRC. Reconnecting...")
+ (0.05 ":*status!znc@znc.in PRIVMSG tester :Connection Refused. Reconnecting...")
+ (0.03 ":*status!znc@znc.in PRIVMSG tester :Connected!")
+ (0.01 ":irc.foonet.org 001 tester :Welcome to the foonet IRC Network tester")
+ (0.04 ":irc.foonet.org 002 tester :Your host is irc.foonet.org, running version ergo-v2.11.1")
+ (0.01 ":irc.foonet.org 003 tester :This server was created Wed, 31 Jan 2024 10:58:16 UTC")
+ (0.01 ":irc.foonet.org 004 tester irc.foonet.org ergo-v2.11.1 BERTZios CEIMRUabefhiklmnoqstuv Iabefhkloqv")
+ (0.03 ":irc.foonet.org 005 tester AWAYLEN=390 BOT=B CASEMAPPING=ascii CHANLIMIT=#:100 CHANMODES=Ibe,k,fl,CEMRUimnstu CHANNELLEN=64 CHANTYPES=# CHATHISTORY=1000 ELIST=U EXCEPTS EXTBAN=,m FORWARD=f INVEX :are supported by this server")
+ (0.01 ":irc.foonet.org 005 tester KICKLEN=390 MAXLIST=beI:60 MAXTARGETS=4 MODES MONITOR=100 NETWORK=foonet NICKLEN=32 PREFIX=(qaohv)~&@%+ STATUSMSG=~&@%+ TARGMAX=NAMES:1,LIST:1,KICK:,WHOIS:1,USERHOST:10,PRIVMSG:4,TAGMSG:4,NOTICE:4,MONITOR:100 TOPICLEN=390 UTF8ONLY WHOX :are supported by this server")
+ (0.01 ":irc.foonet.org 005 tester draft/CHATHISTORY=1000 :are supported by this server")
+ (0.00 ":irc.foonet.org 251 tester :There are 0 users and 3 invisible on 1 server(s)")
+ (0.00 ":irc.foonet.org 252 tester 0 :IRC Operators online")
+ (0.00 ":irc.foonet.org 253 tester 0 :unregistered connections")
+ (0.00 ":irc.foonet.org 254 tester 1 :channels formed")
+ (0.00 ":irc.foonet.org 255 tester :I have 3 clients and 0 servers")
+ (0.00 ":irc.foonet.org 265 tester 3 3 :Current local users 3, max 3")
+ (0.00 ":irc.foonet.org 266 tester 3 3 :Current global users 3, max 3")
+ (0.00 ":irc.foonet.org 422 tester :MOTD File is missing")
+ (0.02 ":irc.foonet.org 221 tester +i")
+ (0.01 ":irc.foonet.org NOTICE tester :This server is in debug mode and is logging all user I/O. If you do not wish for everything you send to be readable by the server owner(s), please disconnect.")
+ (0.02 ":irc.foonet.org 352 tester * ~u hrn2ea3rpeyck.irc irc.foonet.org tester H :0 ZNC - https://znc.in")
+ (0.01 ":irc.foonet.org 315 tester tester :End of WHO list")
+ (0.02 ":tester!~u@hrn2ea3rpeyck.irc JOIN #chan"))
+
+((mode 10 "MODE #chan")
+ (0.00 ":irc.foonet.org 353 tester = #chan :tester @alice bob")
+ (0.01 ":irc.foonet.org 366 tester #chan :End of NAMES list")
+ (0.00 ":alice!~u@euegh6mj3y8r2.irc PRIVMSG #chan :tester, welcome!")
+ (0.01 ":bob!~u@euegh6mj3y8r2.irc PRIVMSG #chan :tester, welcome!")
+ (0.02 ":alice!~u@euegh6mj3y8r2.irc PRIVMSG #chan :bob: Nay, I assure you, a peace concluded.")
+ (0.03 ":irc.foonet.org 324 tester #chan +Cnt")
+ (0.01 ":irc.foonet.org 329 tester #chan 1706698713")
+ (0.05 ":bob!~u@euegh6mj3y8r2.irc PRIVMSG #chan :alice: But, in defence, by mercy, 'tis most just.")
+ (0.04 ":alice!~u@euegh6mj3y8r2.irc PRIVMSG #chan :bob: Or to drown my clothes, and say I was stripped."))
diff --git a/test/lisp/erc/resources/commands/amsg-barnet.eld b/test/lisp/erc/resources/commands/amsg-barnet.eld
new file mode 100644
index 00000000000..53b3e18651a
--- /dev/null
+++ b/test/lisp/erc/resources/commands/amsg-barnet.eld
@@ -0,0 +1,54 @@
+;; -*- mode: lisp-data; -*-
+((nick 10 "NICK tester"))
+((user 10 "USER user 0 * :unknown")
+ (0 ":irc.barnet.org 001 tester :Welcome to the barnet IRC Network tester")
+ (0 ":irc.barnet.org 002 tester :Your host is irc.barnet.org, running version oragono-2.6.0-7481bf0385b95b16")
+ (0 ":irc.barnet.org 003 tester :This server was created Tue, 04 May 2021 05:06:19 UTC")
+ (0 ":irc.barnet.org 004 tester irc.barnet.org oragono-2.6.0-7481bf0385b95b16 BERTZios CEIMRUabefhiklmnoqstuv Iabefhkloqv")
+ (0 ":irc.barnet.org 005 tester AWAYLEN=390 BOT=B CASEMAPPING=ascii CHANLIMIT=#:100 CHANMODES=Ibe,k,fl,CEMRUimnstu CHANNELLEN=64 CHANTYPES=# ELIST=U EXCEPTS EXTBAN=,m FORWARD=f INVEX KICKLEN=390 :are supported by this server")
+ (0 ":irc.barnet.org 005 tester MAXLIST=beI:60 MAXTARGETS=4 MODES MONITOR=100 NETWORK=barnet NICKLEN=32 PREFIX=(qaohv)~&@%+ STATUSMSG=~&@%+ TARGMAX=NAMES:1,LIST:1,KICK:1,WHOIS:1,USERHOST:10,PRIVMSG:4,TAGMSG:4,NOTICE:4,MONITOR:100 TOPICLEN=390 UTF8MAPPING=rfc8265 UTF8ONLY WHOX :are supported by this server")
+ (0 ":irc.barnet.org 005 tester draft/CHATHISTORY=100 :are supported by this server")
+ (0 ":irc.barnet.org 251 tester :There are 0 users and 3 invisible on 1 server(s)")
+ (0 ":irc.barnet.org 252 tester 0 :IRC Operators online")
+ (0 ":irc.barnet.org 253 tester 0 :unregistered connections")
+ (0 ":irc.barnet.org 254 tester 1 :channels formed")
+ (0 ":irc.barnet.org 255 tester :I have 3 clients and 0 servers")
+ (0 ":irc.barnet.org 265 tester 3 3 :Current local users 3, max 3")
+ (0 ":irc.barnet.org 266 tester 3 3 :Current global users 3, max 3")
+ (0 ":irc.barnet.org 422 tester :MOTD File is missing"))
+
+((mode-user 10 "MODE tester +i")
+ (0 ":irc.barnet.org 221 tester +i")
+ (0 ":irc.barnet.org NOTICE tester :This server is in debug mode and is logging all user I/O. If you do not wish for everything you send to be readable by the server owner(s), please disconnect."))
+
+((join 10 "JOIN #bar")
+ (0 ":tester!~u@jnu48g2wrycbw.irc JOIN #bar")
+ (0 ":irc.barnet.org 353 tester = #bar :@mike joe tester")
+ (0 ":irc.barnet.org 366 tester #bar :End of NAMES list"))
+
+((mode-bar 10 "MODE #bar")
+ (0 ":irc.barnet.org 324 tester #bar +nt")
+ (0 ":irc.barnet.org 329 tester #bar 1620104779")
+ (0.1 ":mike!~u@kd7gmjbnbkn8c.irc PRIVMSG #bar :tester, welcome!")
+ (0.1 ":joe!~u@kd7gmjbnbkn8c.irc PRIVMSG #bar :tester, welcome!")
+ (0.1 ":mike!~u@kd7gmjbnbkn8c.irc PRIVMSG #bar :joe: Whipp'd first, sir, and hang'd after.")
+ (0.1 ":joe!~u@kd7gmjbnbkn8c.irc PRIVMSG #bar :mike: We have yet many among us can gripe as hard as Cassibelan; I do not say I am one, but I have a hand. Why tribute ? why should we pay tribute ? If C sar can hide the sun from us with a blanket, or put the moon in his pocket, we will pay him tribute for light; else, sir, no more tribute, pray you now."))
+
+((privmsg-2 10 "PRIVMSG #bar :2 barnet only")
+ (0.1 ":mike!~u@kd7gmjbnbkn8c.irc PRIVMSG #bar :joe: Double and treble admonition, and still forfeit in the same kind ? This would make mercy swear, and play the tyrant.")
+ (0.1 ":joe!~u@kd7gmjbnbkn8c.irc PRIVMSG #bar :mike: And secretly to greet the empress' friends."))
+
+((privmsg-4 10 "PRIVMSG #bar :\1ACTION 4 barnet only\1")
+ (0.1 ":mike!~u@kd7gmjbnbkn8c.irc PRIVMSG #bar :joe: You have not been inquired after: I have sat here all day.")
+ (0.1 ":joe!~u@kd7gmjbnbkn8c.irc PRIVMSG #bar :mike: That same Berowne I'll torture ere I go."))
+
+((privmsg-5 10 "PRIVMSG #bar :5 all nets"))
+
+((privmsg-6 10 "PRIVMSG #bar :\1ACTION 6 all nets\1")
+ (0.1 ":mike!~u@kd7gmjbnbkn8c.irc PRIVMSG #bar :joe: For mine own part,no offence to the general, nor any man of quality,I hope to be saved.")
+ (0.1 ":joe!~u@kd7gmjbnbkn8c.irc PRIVMSG #bar :mike: Mehercle! if their sons be ingenuous, they shall want no instruction; if their daughters be capable, I will put it to them. But, vir sapit qui pauca loquitur. A soul feminine saluteth us."))
+
+((quit 5 "QUIT :\2ERC\2")
+ (0 ":tester!~u@jnu48g2wrycbw.irc QUIT :Quit"))
+
+((drop 0 DROP))
diff --git a/test/lisp/erc/resources/commands/amsg-foonet.eld b/test/lisp/erc/resources/commands/amsg-foonet.eld
new file mode 100644
index 00000000000..eb3d84d646a
--- /dev/null
+++ b/test/lisp/erc/resources/commands/amsg-foonet.eld
@@ -0,0 +1,56 @@
+;; -*- mode: lisp-data; -*-
+((nick 10 "NICK tester"))
+((user 10 "USER user 0 * :unknown")
+ (0 ":irc.foonet.org 001 tester :Welcome to the foonet IRC Network tester")
+ (0 ":irc.foonet.org 002 tester :Your host is irc.foonet.org, running version oragono-2.6.0-7481bf0385b95b16")
+ (0 ":irc.foonet.org 003 tester :This server was created Tue, 04 May 2021 05:06:18 UTC")
+ (0 ":irc.foonet.org 004 tester irc.foonet.org oragono-2.6.0-7481bf0385b95b16 BERTZios CEIMRUabefhiklmnoqstuv Iabefhkloqv")
+ (0 ":irc.foonet.org 005 tester AWAYLEN=390 BOT=B CASEMAPPING=ascii CHANLIMIT=#:100 CHANMODES=Ibe,k,fl,CEMRUimnstu CHANNELLEN=64 CHANTYPES=# ELIST=U EXCEPTS EXTBAN=,m FORWARD=f INVEX KICKLEN=390 :are supported by this server")
+ (0 ":irc.foonet.org 005 tester MAXLIST=beI:60 MAXTARGETS=4 MODES MONITOR=100 NETWORK=foonet NICKLEN=32 PREFIX=(qaohv)~&@%+ STATUSMSG=~&@%+ TARGMAX=NAMES:1,LIST:1,KICK:1,WHOIS:1,USERHOST:10,PRIVMSG:4,TAGMSG:4,NOTICE:4,MONITOR:100 TOPICLEN=390 UTF8MAPPING=rfc8265 UTF8ONLY WHOX :are supported by this server")
+ (0 ":irc.foonet.org 005 tester draft/CHATHISTORY=100 :are supported by this server")
+ (0 ":irc.foonet.org 251 tester :There are 0 users and 3 invisible on 1 server(s)")
+ (0 ":irc.foonet.org 252 tester 0 :IRC Operators online")
+ (0 ":irc.foonet.org 253 tester 0 :unregistered connections")
+ (0 ":irc.foonet.org 254 tester 1 :channels formed")
+ (0 ":irc.foonet.org 255 tester :I have 3 clients and 0 servers")
+ (0 ":irc.foonet.org 265 tester 3 3 :Current local users 3, max 3")
+ (0 ":irc.foonet.org 266 tester 3 3 :Current global users 3, max 3")
+ (0 ":irc.foonet.org 422 tester :MOTD File is missing"))
+
+((mode-user 10 "MODE tester +i")
+ (0 ":irc.foonet.org 221 tester +i")
+ (0 ":irc.foonet.org NOTICE tester :This server is in debug mode and is logging all user I/O. If you do not wish for everything you send to be readable by the server owner(s), please disconnect."))
+
+((join 10 "JOIN #foo")
+ (0 ":tester!~u@9g6b728983yd2.irc JOIN #foo")
+ (0 ":irc.foonet.org 353 tester = #foo :alice tester @bob")
+ (0 ":irc.foonet.org 366 tester #foo :End of NAMES list"))
+
+((mode-foo 10 "MODE #foo")
+ (0 ":irc.foonet.org 324 tester #foo +nt")
+ (0 ":irc.foonet.org 329 tester #foo 1620104779")
+ (0.1 ":bob!~u@rz2v467q4rwhy.irc PRIVMSG #foo :tester, welcome!")
+ (0.1 ":alice!~u@rz2v467q4rwhy.irc PRIVMSG #foo :tester, welcome!")
+ (0.1 ":bob!~u@rz2v467q4rwhy.irc PRIVMSG #foo :alice: But, as it seems, did violence on herself.")
+ (0.1 ":alice!~u@rz2v467q4rwhy.irc PRIVMSG #foo :bob: Well, this is the forest of Arden."))
+
+((privmsg-1 10 "PRIVMSG #foo :1 foonet only")
+ (0.1 ":bob!~u@rz2v467q4rwhy.irc PRIVMSG #foo :alice: Signior Iachimo will not from it. Pray, let us follow 'em.")
+ (0.1 ":alice!~u@rz2v467q4rwhy.irc PRIVMSG #foo :bob: Our queen and all her elves come here anon."))
+
+((privmsg-3 10 "PRIVMSG #foo :\1ACTION 3 foonet only\1")
+ (0.1 ":bob!~u@rz2v467q4rwhy.irc PRIVMSG #foo :alice: The ground is bloody; search about the churchyard.")
+ (0.1 ":alice!~u@rz2v467q4rwhy.irc PRIVMSG #foo :bob: You have discharged this honestly: keep it to yourself. Many likelihoods informed me of this before, which hung so tottering in the balance that I could neither believe nor misdoubt. Pray you, leave me: stall this in your bosom; and I thank you for your honest care. I will speak with you further anon."))
+
+((privmsg-5 10 "PRIVMSG #foo :5 all nets"))
+
+((privmsg-6 10 "PRIVMSG #foo :\1ACTION 6 all nets\1")
+ (0.1 ":bob!~u@rz2v467q4rwhy.irc PRIVMSG #foo :alice: Give me that mattock, and the wrenching iron.")
+ (0.1 ":alice!~u@rz2v467q4rwhy.irc PRIVMSG #foo :bob: Stand you! You have land enough of your own; but he added to your having, gave you some ground."))
+
+((privmsg-6 10 "PRIVMSG #foo :7 all live nets")
+ (0.1 ":bob!~u@rz2v467q4rwhy.irc PRIVMSG #foo :alice: Excellent workman! Thou canst not paint a man so bad as is thyself."))
+
+((privmsg-6 10 "PRIVMSG #foo :\1ACTION 8 all live nets\1")
+ (0.1 ":alice!~u@rz2v467q4rwhy.irc PRIVMSG #foo :bob: And will you, being a man of your breeding, be married under a bush, like a beggar ? Get you to church, and have a good priest that can tell you what marriage is: this fellow will but join you together as they join wainscot; then one of you will prove a shrunk panel, and like green timber, warp, warp.")
+ (0.1 ":bob!~u@rz2v467q4rwhy.irc PRIVMSG #foo :alice: Live, and be prosperous; and farewell, good fellow."))
diff --git a/test/lisp/erc/resources/commands/motd.eld b/test/lisp/erc/resources/commands/motd.eld
new file mode 100644
index 00000000000..6d10ee122e2
--- /dev/null
+++ b/test/lisp/erc/resources/commands/motd.eld
@@ -0,0 +1,48 @@
+;; -*- mode: lisp-data; -*-
+((nick 10 "NICK tester"))
+((user 10 "USER user 0 * :tester")
+ (0.00 ":irc.foonet.org 001 tester :Welcome to the foonet IRC Network tester")
+ (0.01 ":irc.foonet.org 002 tester :Your host is irc.foonet.org, running version ergo-v2.11.1")
+ (0.01 ":irc.foonet.org 003 tester :This server was created Sun, 12 Mar 2023 02:30:29 UTC")
+ (0.00 ":irc.foonet.org 004 tester irc.foonet.org ergo-v2.11.1 BERTZios CEIMRUabefhiklmnoqstuv Iabefhkloqv")
+ (0.00 ":irc.foonet.org 005 tester AWAYLEN=390 BOT=B CASEMAPPING=ascii CHANLIMIT=#:100 CHANMODES=Ibe,k,fl,CEMRUimnstu CHANNELLEN=64 CHANTYPES=# CHATHISTORY=1000 ELIST=U EXCEPTS EXTBAN=,m FORWARD=f INVEX :are supported by this server")
+ (0.01 ":irc.foonet.org 005 tester KICKLEN=390 MAXLIST=beI:60 MAXTARGETS=4 MODES MONITOR=100 NETWORK=foonet NICKLEN=32 PREFIX=(qaohv)~&@%+ STATUSMSG=~&@%+ TARGMAX=NAMES:1,LIST:1,KICK:,WHOIS:1,USERHOST:10,PRIVMSG:4,TAGMSG:4,NOTICE:4,MONITOR:100 TOPICLEN=390 UTF8ONLY WHOX :are supported by this server")
+ (0.01 ":irc.foonet.org 005 tester draft/CHATHISTORY=1000 :are supported by this server")
+ (0.00 ":irc.foonet.org 251 tester :There are 0 users and 3 invisible on 1 server(s)")
+ (0.00 ":irc.foonet.org 252 tester 0 :IRC Operators online")
+ (0.00 ":irc.foonet.org 253 tester 0 :unregistered connections")
+ (0.00 ":irc.foonet.org 254 tester 1 :channels formed")
+ (0.00 ":irc.foonet.org 255 tester :I have 3 clients and 0 servers")
+ (0.00 ":irc.foonet.org 265 tester 3 3 :Current local users 3, max 3")
+ (0.00 ":irc.foonet.org 266 tester 3 3 :Current global users 3, max 3")
+ (0.00 ":irc.foonet.org 375 tester :- irc.foonet.org Message of the day - ")
+ (0.00 ":irc.foonet.org 372 tester :- This is the default Ergo MOTD.")
+ (0.01 ":irc.foonet.org 372 tester :- ")
+ (0.02 ":irc.foonet.org 372 tester :- For more information on using these, see MOTDFORMATTING.md")
+ (0.00 ":irc.foonet.org 376 tester :End of MOTD command"))
+
+((mode 10 "MODE tester +i")
+ (0.00 ":irc.foonet.org 221 tester +i")
+ (0.00 ":irc.foonet.org NOTICE tester :This server is in debug mode and is logging all user I/O. If you do not wish for everything you send to be readable by the server owner(s), please disconnect.")
+ (0.05 ":irc.foonet.org 221 tester +i"))
+
+((motd-1 10 "MOTD")
+ (0.08 ":irc.foonet.org 375 tester :- irc.foonet.org Message of the day - ")
+ (0.02 ":irc.foonet.org 372 tester :- This is the default Ergo MOTD.")
+ (0.01 ":irc.foonet.org 372 tester :- ")
+ (0.00 ":irc.foonet.org 372 tester :- For more information on using these, see MOTDFORMATTING.md")
+ (0.00 ":irc.foonet.org 376 tester :End of MOTD command"))
+
+((motd-2 10 "MOTD irc1.foonet.org")
+ (0.08 ":irc1.foonet.org 375 tester :- irc1.foonet.org Message of the day - ")
+ (0.02 ":irc1.foonet.org 372 tester :- This is the default Ergo MOTD.")
+ (0.01 ":irc1.foonet.org 372 tester :- ")
+ (0.00 ":irc1.foonet.org 372 tester :- For more information on using these, see MOTDFORMATTING.md")
+ (0.00 ":irc1.foonet.org 376 tester :End of MOTD command"))
+
+((motd-3 10 "MOTD fake.foonet.org")
+ (0.00 ":irc.foonet.org 402 tester fake.foonet.org :No such server"))
+
+((quit 10 "QUIT :\2ERC\2")
+ (0.07 ":tester!~u@h3f95zveyc38a.irc QUIT :Quit: \2ERC\2 5.5 (IRC client for GNU Emacs 30.0.50)")
+ (0.01 "ERROR :Quit: \2ERC\2 5.5 (IRC client for GNU Emacs 30.0.50)"))
diff --git a/test/lisp/erc/resources/commands/squery.eld b/test/lisp/erc/resources/commands/squery.eld
new file mode 100644
index 00000000000..bcd176e515b
--- /dev/null
+++ b/test/lisp/erc/resources/commands/squery.eld
@@ -0,0 +1,31 @@
+;; -*- mode: lisp-data; -*-
+((nick 10 "NICK tester"))
+((user 10 "USER user 0 * :tester")
+ (0.07 ":ircnet.hostsailor.com 020 * :Please wait while we process your connection.")
+ (0.03 ":ircnet.hostsailor.com 001 tester :Welcome to the Internet Relay Network tester!~user@93.184.216.34")
+ (0.02 ":ircnet.hostsailor.com 002 tester :Your host is ircnet.hostsailor.com, running version 2.11.2p3+0PNv1.06")
+ (0.03 ":ircnet.hostsailor.com 003 tester :This server was created Thu May 20 2021 at 17:13:24 EDT")
+ (0.01 ":ircnet.hostsailor.com 004 tester ircnet.hostsailor.com 2.11.2p3+0PNv1.06 aoOirw abeiIklmnoOpqrRstv")
+ (0.00 ":ircnet.hostsailor.com 005 tester RFC2812 PREFIX=(ov)@+ CHANTYPES=#&!+ MODES=3 CHANLIMIT=#&!+:42 NICKLEN=15 TOPICLEN=255 KICKLEN=255 MAXLIST=beIR:64 CHANNELLEN=50 IDCHAN=!:5 CHANMODES=beIR,k,l,imnpstaqrzZ :are supported by this server")
+ (0.01 ":ircnet.hostsailor.com 005 tester PENALTY FNC EXCEPTS=e INVEX=I CASEMAPPING=ascii NETWORK=IRCnet :are supported by this server")
+ (0.01 ":ircnet.hostsailor.com 042 tester 0PNHANAWX :your unique ID")
+ (0.01 ":ircnet.hostsailor.com 251 tester :There are 18711 users and 2 services on 26 servers")
+ (0.01 ":ircnet.hostsailor.com 252 tester 63 :operators online")
+ (0.01 ":ircnet.hostsailor.com 253 tester 4 :unknown connections")
+ (0.01 ":ircnet.hostsailor.com 254 tester 10493 :channels formed")
+ (0.01 ":ircnet.hostsailor.com 255 tester :I have 933 users, 0 services and 1 servers")
+ (0.01 ":ircnet.hostsailor.com 265 tester 933 1328 :Current local users 933, max 1328")
+ (0.01 ":ircnet.hostsailor.com 266 tester 18711 25625 :Current global users 18711, max 25625")
+ (0.02 ":ircnet.hostsailor.com 375 tester :- ircnet.hostsailor.com Message of the Day - ")
+ (0.01 ":ircnet.hostsailor.com 372 tester :- 17/11/2023 3:08")
+ (0.02 ":ircnet.hostsailor.com 376 tester :End of MOTD command."))
+
+((mode 10 "MODE tester +i")
+ (0.00 ":ircnet.hostsailor.com NOTICE tester :Your connection is secure (SSL/TLS).")
+ (0.01 ":tester MODE tester :+i"))
+
+((squery 10 "SQUERY alis :help list")
+ (0.08 ":Alis@hub.uk NOTICE tester :Searches for a channel")
+ (0.01 ":Alis@hub.uk NOTICE tester :/SQUERY Alis LIST mask [-options]")
+ (0.04 ":Alis@hub.uk NOTICE tester :[...]")
+ (0.01 ":Alis@hub.uk NOTICE tester :See also: HELP EXAMPLES"))
diff --git a/test/lisp/erc/resources/commands/vhost.eld b/test/lisp/erc/resources/commands/vhost.eld
new file mode 100644
index 00000000000..42013198fbc
--- /dev/null
+++ b/test/lisp/erc/resources/commands/vhost.eld
@@ -0,0 +1,40 @@
+;; -*- mode: lisp-data; -*-
+((pass 10 "PASS :changeme"))
+((nick 10 "NICK tester"))
+((user 10 "USER user 0 * :tester")
+ (0 ":irc.foonet.org 001 tester :Welcome to the foonet IRC Network tester")
+ (0 ":irc.foonet.org 002 tester :Your host is irc.foonet.org, running version oragono-2.6.0-7481bf0385b95b16")
+ (0 ":irc.foonet.org 003 tester :This server was created Tue, 04 May 2021 05:06:18 UTC")
+ (0 ":irc.foonet.org 004 tester irc.foonet.org oragono-2.6.0-7481bf0385b95b16 BERTZios CEIMRUabefhiklmnoqstuv Iabefhkloqv")
+ (0 ":irc.foonet.org 005 tester AWAYLEN=390 BOT=B CASEMAPPING=ascii CHANLIMIT=#:100 CHANMODES=Ibe,k,fl,CEMRUimnstu CHANNELLEN=64 CHANTYPES=# ELIST=U EXCEPTS EXTBAN=,m FORWARD=f INVEX KICKLEN=390 :are supported by this server")
+ (0 ":irc.foonet.org 005 tester MAXLIST=beI:60 MAXTARGETS=4 MODES MONITOR=100 NETWORK=foonet NICKLEN=32 PREFIX=(qaohv)~&@%+ STATUSMSG=~&@%+ TARGMAX=NAMES:1,LIST:1,KICK:1,WHOIS:1,USERHOST:10,PRIVMSG:4,TAGMSG:4,NOTICE:4,MONITOR:100 TOPICLEN=390 UTF8MAPPING=rfc8265 UTF8ONLY WHOX :are supported by this server")
+ (0 ":irc.foonet.org 005 tester draft/CHATHISTORY=100 :are supported by this server")
+ (0 ":irc.foonet.org 251 tester :There are 0 users and 3 invisible on 1 server(s)")
+ (0 ":irc.foonet.org 252 tester 0 :IRC Operators online")
+ (0 ":irc.foonet.org 253 tester 0 :unregistered connections")
+ (0 ":irc.foonet.org 254 tester 1 :channels formed")
+ (0 ":irc.foonet.org 255 tester :I have 3 clients and 0 servers")
+ (0 ":irc.foonet.org 265 tester 3 3 :Current local users 3, max 3")
+ (0 ":irc.foonet.org 266 tester 3 3 :Current global users 3, max 3")
+ (0 ":irc.foonet.org 422 tester :MOTD File is missing"))
+
+((mode-user 10 "MODE tester +i")
+ (0 ":irc.foonet.org 221 tester +i")
+ (0 ":irc.foonet.org NOTICE tester :This server is in debug mode and is logging all user I/O. If you do not wish for everything you send to be readable by the server owner(s), please disconnect."))
+
+((join 10 "JOIN #chan")
+ (0 ":tester!~u@9g6b728983yd2.irc JOIN #chan")
+ (0 ":irc.foonet.org 353 tester = #chan :alice tester @bob")
+ (0 ":irc.foonet.org 366 tester #chan :End of NAMES list"))
+
+((mode-chan 10 "MODE #chan")
+ (0 ":irc.foonet.org 324 tester #chan +nt")
+ (0 ":irc.foonet.org 329 tester #chan 1620104779")
+ (0 ":bob!~u@rz2v467q4rwhy.irc PRIVMSG #chan :tester, welcome!")
+ (0 ":alice!~u@rz2v467q4rwhy.irc PRIVMSG #chan :tester, welcome!"))
+
+((vhost 10 "VHOST tester changeme")
+ (0 ":irc.foonet.org NOTICE tester :Setting your VHost: some.host.test.cc")
+ (0 ":irc.foonet.org 396 tester some.host.test.cc :is now your displayed host")
+ (0 ":bob!~u@rz2v467q4rwhy.irc PRIVMSG #chan :alice: But, as it seems, did violence on herself.")
+ (0 ":alice!~u@rz2v467q4rwhy.irc PRIVMSG #chan :bob: Well, this is the forest of Arden."))
diff --git a/test/lisp/erc/resources/dcc/chat/accept.eld b/test/lisp/erc/resources/dcc/chat/accept.eld
index a23e9580bcc..463f931d26f 100644
--- a/test/lisp/erc/resources/dcc/chat/accept.eld
+++ b/test/lisp/erc/resources/dcc/chat/accept.eld
@@ -17,7 +17,7 @@
(0 ":irc.foonet.org 266 tester 4 4 :Current global users 4, max 4")
(0 ":irc.foonet.org 422 tester :MOTD File is missing"))
-((mode-user 1.2 "MODE tester +i")
+((mode-user 10 "MODE tester +i")
;; No mode answer
(0 ":irc.foonet.org NOTICE tester :This server is in debug mode and is logging all user I/O. If you do not wish for everything you send to be readable by the server owner(s), please disconnect.")
(0.2 ":dummy!~u@34n9brushbpj2.irc PRIVMSG tester :\C-aDCC CHAT chat 2130706433 " port "\C-a"))
diff --git a/test/lisp/erc/resources/erc-d/erc-d-t.el b/test/lisp/erc/resources/erc-d/erc-d-t.el
index 5914419ba61..2dc8398198f 100644
--- a/test/lisp/erc/resources/erc-d/erc-d-t.el
+++ b/test/lisp/erc/resources/erc-d/erc-d-t.el
@@ -83,6 +83,8 @@ returning."
(ignore-errors (kill-buffer buf)))))
(sleep-for erc-d-t-cleanup-sleep-secs)))))
+(defvar erc-d-t--wait-message-prefix "Awaiting: ")
+
(defmacro erc-d-t-wait-for (max-secs msg &rest body)
"Wait for BODY to become non-nil.
Or signal error with MSG after MAX-SECS. When MAX-SECS is negative,
@@ -99,7 +101,7 @@ be desirable."
(let ((inverted (make-symbol "inverted"))
(time-out (make-symbol "time-out"))
(result (make-symbol "result")))
- `(ert-info ((concat "Awaiting: " ,msg))
+ `(ert-info ((concat erc-d-t--wait-message-prefix ,msg))
(let ((,time-out (abs ,max-secs))
(,inverted (< ,max-secs 0))
(,result ',result))
@@ -120,7 +122,8 @@ On failure, emit MSG."
(unless (or (stringp msg) (memq (car-safe msg) '(format concat)))
(push msg body)
(setq msg (prin1-to-string body)))
- `(erc-d-t-wait-for (- (abs ,max-secs)) ,msg (not (progn ,@body))))
+ `(let ((erc-d-t--wait-message-prefix "Sustaining: "))
+ (erc-d-t-wait-for (- (abs ,max-secs)) ,msg (not (progn ,@body)))))
(defun erc-d-t-search-for (timeout text &optional from on-success)
"Wait for TEXT to appear in current buffer before TIMEOUT secs.
@@ -154,6 +157,7 @@ ON-SUCCESS, is nonexistent. To reset, specify a FROM argument."
(let (positions)
(lambda (timeout text &optional reset-from)
(let* ((pos (cdr (assq (current-buffer) positions)))
+ (erc-d-t--wait-message-prefix (and (< timeout 0) "Sustaining: "))
(cb (lambda ()
(unless pos
(push (cons (current-buffer) (setq pos (make-marker)))
diff --git a/test/lisp/erc/resources/erc-d/erc-d-tests.el b/test/lisp/erc/resources/erc-d/erc-d-tests.el
index edc83c0b0ab..78f87399afb 100644
--- a/test/lisp/erc/resources/erc-d/erc-d-tests.el
+++ b/test/lisp/erc/resources/erc-d/erc-d-tests.el
@@ -674,7 +674,7 @@ nonzero for this to work."
(ert-deftest erc-d-run-linger ()
:tags '(:unstable :expensive-test)
(erc-d-tests-with-server (dumb-s _) linger
- (with-current-buffer (erc-d-t-wait-for 6 (get-buffer "#chan"))
+ (with-current-buffer (erc-d-t-wait-for 10 (get-buffer "#chan"))
(erc-d-t-search-for 2 "hey"))
(with-current-buffer (process-buffer dumb-s)
(erc-d-t-search-for 2 "Lingering for 1.00 seconds"))
diff --git a/test/lisp/erc/resources/erc-d/erc-d-u.el b/test/lisp/erc/resources/erc-d/erc-d-u.el
index c735a2c6114..11202f41112 100644
--- a/test/lisp/erc/resources/erc-d/erc-d-u.el
+++ b/test/lisp/erc/resources/erc-d/erc-d-u.el
@@ -74,6 +74,7 @@
(let ((hunks (erc-d-u-scan-e-sd info))
(pos (erc-d-u-scan-e-pos info)))
(or (and (erc-d-u-scan-d-hunks hunks)
+ (buffer-live-p (erc-d-u-scan-d-buf hunks))
(with-current-buffer (erc-d-u-scan-d-buf hunks)
(goto-char pos)
(condition-case _err
diff --git a/test/lisp/erc/resources/erc-d/erc-d.el b/test/lisp/erc/resources/erc-d/erc-d.el
index b605930de94..89701442ff6 100644
--- a/test/lisp/erc/resources/erc-d/erc-d.el
+++ b/test/lisp/erc/resources/erc-d/erc-d.el
@@ -254,7 +254,7 @@ return a replacement.")
(ending (process-get process :dialog-ending))
(dialog (make-erc-d-dialog :name name
:process process
- :queue (make-ring 5)
+ :queue (make-ring 10)
:exchanges (make-ring 10)
:match-handlers mat-h
:server-fqdn fqdn)))
@@ -292,32 +292,27 @@ With int SKIP, advance past that many exchanges."
(defvar erc-d--m-debug (getenv "ERC_D_DEBUG"))
-(defmacro erc-d--m (process format-string &rest args)
- "Output ARGS using FORMAT-STRING somewhere depending on context.
-PROCESS should be a client connection or a server network process."
- `(let ((format-string (if erc-d--m-debug
- (concat (format-time-string "%s.%N: ")
- ,format-string)
- ,format-string))
- (want-insert (and ,process erc-d--in-process)))
- (when want-insert
- (with-current-buffer (process-buffer (process-get ,process :server))
- (goto-char (point-max))
- (insert (concat (format ,format-string ,@args) "\n"))))
- (when (or erc-d--m-debug (not want-insert))
- (message format-string ,@args))))
-
-(defmacro erc-d--log (process string &optional outbound)
- "Log STRING sent to (OUTBOUND) or received from PROCESS peer."
- `(let ((id (or (process-get ,process :log-id)
- (let ((port (erc-d-u--get-remote-port ,process)))
- (process-put ,process :log-id port)
- port)))
- (name (erc-d-dialog-name (process-get ,process :dialog))))
- (if ,outbound
- (erc-d--m process "-> %s:%s %s" name id ,string)
- (dolist (line (split-string ,string (process-get process :ending)))
- (erc-d--m process "<- %s:%s %s" name id line)))))
+(defun erc-d--m (process format-string &rest args)
+ "Output ARGS using FORMAT-STRING to PROCESS's buffer or elsewhere."
+ (when erc-d--m-debug
+ (setq format-string (concat (format-time-string "%s.%N: ") format-string)))
+ (let ((insertp (and process erc-d--in-process))
+ (buffer (and process (process-buffer (process-get process :server)))))
+ (when (and insertp (buffer-live-p buffer))
+ (princ (concat (apply #'format format-string args) "\n") buffer))
+ (when (or erc-d--m-debug (not insertp))
+ (apply #'message format-string args))))
+
+(defun erc-d--log (process string &optional outbound)
+ "Log STRING received from or OUTBOUND to PROCESS peer."
+ (let ((id (or (process-get process :log-id)
+ (let ((port (erc-d-u--get-remote-port process)))
+ (process-put process :log-id port) port)))
+ (name (erc-d-dialog-name (process-get process :dialog))))
+ (if outbound
+ (erc-d--m process "-> %s:%s %s" name id string)
+ (dolist (line (split-string string (process-get process :ending)))
+ (erc-d--m process "<- %s:%s %s" name id line)))))
(defun erc-d--log-process-event (server process msg)
(erc-d--m server "%s: %s" process (string-trim-right msg)))
@@ -455,14 +450,14 @@ including line delimiters."
(setq string (unless (= (match-end 0) (length string))
(substring string (match-end 0))))
(erc-d--log process line nil)
- (ring-insert queue (erc-d-i--parse-message line 'decode))))
+ (ring-insert queue (erc-d-i--parse-message line nil))))
(when string
(setf (process-get process :stashed-input) string))))
;; Misc process properties:
;;
;; The server property `:dialog-dialogs' is an alist of (symbol
-;; . erc-d-u-scan-d) conses, each of which pairs a dialogs name with
+;; . erc-d-u-scan-d) conses, each of which pairs a dialog's name with
;; info on its read progress (described above in the Commentary).
;; This list is populated by `erc-d-run' at the start of each session.
;;
diff --git a/test/lisp/erc/resources/erc-d/resources/basic.eld b/test/lisp/erc/resources/erc-d/resources/basic.eld
index a020eec3fff..80e46d9a279 100644
--- a/test/lisp/erc/resources/erc-d/resources/basic.eld
+++ b/test/lisp/erc/resources/erc-d/resources/basic.eld
@@ -8,8 +8,7 @@
(0 ":irc.example.org 002 tester :Your host is irc.example.org")
(0 ":irc.example.org 003 tester :This server was created just now")
(0 ":irc.example.org 004 tester irc.example.org BERios CEIRabehiklmnoqstv Iabehkloqv")
- (0 ":irc.example.org 005 tester MODES NETWORK=ExampleOrg NICKLEN=32 PREFIX=(qaohv)~&@%+"
- " :are supported by this server")
+ (0 ":irc.example.org 005 tester MODES NETWORK=ExampleOrg NICKLEN=32 PREFIX=(qaohv)~&@%+ :are supported by this server")
(0 ":irc.example.org 251 tester :There are 3 users and 0 invisible on 1 server(s)")
;; Just to mix thing's up (force handler to schedule timer)
(0.1 ":irc.example.org 252 tester 0 :IRC Operators online")
@@ -24,7 +23,7 @@
(0 ":irc.example.org 221 tester +Zi")
(0 ":irc.example.org 306 tester :You have been marked as being away")
(0 ":tester!~tester@localhost JOIN #chan")
- (0 ":irc.example.org 353 alice = #chan :+alice!~alice@example.com @%+bob!~bob@example.org")
+ (0 ":irc.example.org 353 alice = #chan :+alice @bob")
(0 ":irc.example.org 366 alice #chan :End of NAMES list"))
;; Some comment (to prevent regression)
diff --git a/test/lisp/erc/resources/erc-d/resources/dynamic-barnet.eld b/test/lisp/erc/resources/erc-d/resources/dynamic-barnet.eld
index 4994e9c5503..47be0722115 100644
--- a/test/lisp/erc/resources/erc-d/resources/dynamic-barnet.eld
+++ b/test/lisp/erc/resources/erc-d/resources/dynamic-barnet.eld
@@ -18,14 +18,14 @@
(0. ":irc.barnet.org 266 tester 3 3 :Current global users 3, max 3")
(0. ":irc.barnet.org 422 tester :MOTD File is missing"))
-((mode-user 1.2 "MODE tester +i")
+((mode-user 2 "MODE tester +i")
(0. ":irc.barnet.org 221 tester +Zi")
(0. ":irc.barnet.org 306 tester :You have been marked as being away")
(0 ":tester!~u@awyxgybtkx7uq.irc JOIN #chan")
- (0 ":irc.barnet.org 353 joe = #chan :+joe!~joe@example.com @%+mike!~mike@example.org")
+ (0 ":irc.barnet.org 353 joe = #chan :+joe @mike")
(0 ":irc.barnet.org 366 joe #chan :End of NAMES list"))
-((mode 1 "MODE #chan")
+((mode 3 "MODE #chan")
(0 ":irc.barnet.org 324 tester #chan +nt")
(0 ":irc.barnet.org 329 tester #chan 1620805269")
(0.1 ":joe!~u@awyxgybtkx7uq.irc PRIVMSG #chan :mike: Yes, a dozen; and as many to the vantage, as would store the world they played for.")
diff --git a/test/lisp/erc/resources/erc-d/resources/dynamic-foonet.eld b/test/lisp/erc/resources/erc-d/resources/dynamic-foonet.eld
index a47998e7d32..5d5f8ed18a8 100644
--- a/test/lisp/erc/resources/erc-d/resources/dynamic-foonet.eld
+++ b/test/lisp/erc/resources/erc-d/resources/dynamic-foonet.eld
@@ -17,14 +17,14 @@
(0. ":irc.foonet.org 266 tester 3 3 :Current global users 3, max 3")
(0. ":irc.foonet.org 422 tester :MOTD File is missing"))
-((mode-user 1.2 "MODE tester +i")
+((mode-user 4 "MODE tester +i")
(0. ":irc.foonet.org 221 tester +Zi")
(0. ":irc.foonet.org 306 tester :You have been marked as being away")
(0 ":tester!~u@awyxgybtkx7uq.irc JOIN #chan")
- (0 ":irc.foonet.org 353 alice = #chan :+alice!~alice@example.com @%+bob!~bob@example.org")
+ (0 ":irc.foonet.org 353 alice = #chan :+alice @bob")
(0 ":irc.foonet.org 366 alice #chan :End of NAMES list"))
-((mode 2 "MODE #chan")
+((mode 3 "MODE #chan")
(0 ":irc.foonet.org 324 tester #chan +nt")
(0 ":irc.foonet.org 329 tester #chan 1620805269")
(0.1 ":alice!~u@awyxgybtkx7uq.irc PRIVMSG #chan :bob: Yes, a dozen; and as many to the vantage, as would store the world they played for.")
diff --git a/test/lisp/erc/resources/erc-d/resources/dynamic.eld b/test/lisp/erc/resources/erc-d/resources/dynamic.eld
index 459b6e52bfe..64d8c091ad7 100644
--- a/test/lisp/erc/resources/erc-d/resources/dynamic.eld
+++ b/test/lisp/erc/resources/erc-d/resources/dynamic.eld
@@ -7,8 +7,7 @@
(0.0 ":" dom " 002 " nick " :Your host is " dom)
(0.0 ":" dom " 003 " nick " :This server was created just now")
(0.0 ":" dom " 004 " nick " " dom " BERios CEIRabehiklmnoqstv Iabehkloqv")
- (0.0 ":" dom " 005 " nick " MODES NETWORK=ExampleOrg NICKLEN=32 PREFIX=(qaohv)~&@%+"
- " :are supported by this server")
+ (0.0 ":" dom " 005 " nick " MODES NETWORK=ExampleOrg NICKLEN=32 PREFIX=(qaohv)~&@%+ :are supported by this server")
(0.0 ":" dom " 251 " nick " :There are 3 users and 0 invisible on 1 server(s)")
(0.0 ":" dom " 252 " nick " 0 :IRC Operators online")
(0.0 ":" dom " 253 " nick " 0 :unregistered connections")
@@ -23,7 +22,7 @@
(0.0 ":" dom " 306 " nick " :You have been marked as being away")
(0.0 ":" nick "!~" nick "@localhost JOIN #chan")
- (0.0 ":" dom " 353 alice = #chan :+alice!~alice@example.com @%+bob!~bob@example.org")
+ (0.0 ":" dom " 353 alice = #chan :+alice @bob")
(0.0 ":" dom " 366 alice #chan :End of NAMES list"))
((mode 2.2 "MODE #chan")
diff --git a/test/lisp/erc/resources/erc-d/resources/eof.eld b/test/lisp/erc/resources/erc-d/resources/eof.eld
index 5da84b2e74f..db39b3d4af1 100644
--- a/test/lisp/erc/resources/erc-d/resources/eof.eld
+++ b/test/lisp/erc/resources/erc-d/resources/eof.eld
@@ -8,8 +8,7 @@
(0 ":irc.example.org 002 tester :Your host is irc.example.org")
(0 ":irc.example.org 003 tester :This server was created just now")
(0 ":irc.example.org 004 tester irc.example.org BERios CEIRabehiklmnoqstv Iabehkloqv")
- (0 ":irc.example.org 005 tester MODES NETWORK=ExampleOrg NICKLEN=32 PREFIX=(qaohv)~&@%+"
- " :are supported by this server")
+ (0 ":irc.example.org 005 tester MODES NETWORK=ExampleOrg NICKLEN=32 PREFIX=(qaohv)~&@%+ :are supported by this server")
(0 ":irc.example.org 251 tester :There are 3 users and 0 invisible on 1 server(s)")
;; Just to mix thing's up (force handler to schedule timer)
(0.1 ":irc.example.org 252 tester 0 :IRC Operators online")
@@ -24,7 +23,7 @@
(0 ":irc.example.org 221 tester +Zi")
(0 ":irc.example.org 306 tester :You have been marked as being away")
(0 ":tester!~tester@localhost JOIN #chan")
- (0 ":irc.example.org 353 alice = #chan :+alice!~alice@example.com @%+bob!~bob@example.org")
+ (0 ":irc.example.org 353 alice = #chan :+alice @bob")
(0 ":irc.example.org 366 alice #chan :End of NAMES list"))
((mode-chan 1.2 "MODE #chan")
diff --git a/test/lisp/erc/resources/erc-d/resources/fuzzy.eld b/test/lisp/erc/resources/erc-d/resources/fuzzy.eld
index 0504b6a6682..cf64004da0d 100644
--- a/test/lisp/erc/resources/erc-d/resources/fuzzy.eld
+++ b/test/lisp/erc/resources/erc-d/resources/fuzzy.eld
@@ -23,12 +23,12 @@
((~join-foo 3.2 "JOIN #foo")
(0 "@time=" now " :tester!~tester@localhost JOIN #foo")
- (0 "@time=" now " :irc.example.org 353 alice = #foo :+alice!~alice@example.com @%+bob!~bob@example.org")
+ (0 "@time=" now " :irc.example.org 353 alice = #foo :+alice @bob")
(0 "@time=" now " :irc.example.org 366 alice #foo :End of NAMES list"))
((~join-bar 1.2 "JOIN #bar")
(0 "@time=" now " :tester!~tester@localhost JOIN #bar")
- (0 "@time=" now " :irc.example.org 353 alice = #bar :+alice!~alice@example.com @%+bob!~bob@example.org")
+ (0 "@time=" now " :irc.example.org 353 alice = #bar :+alice @bob")
(0 "@time=" now " :irc.example.org 366 alice #bar :End of NAMES list"))
((~mode-foo 3.2 "MODE #foo")
diff --git a/test/lisp/erc/resources/erc-d/resources/incremental.eld b/test/lisp/erc/resources/erc-d/resources/incremental.eld
index a1b48495ec3..7d192a53066 100644
--- a/test/lisp/erc/resources/erc-d/resources/incremental.eld
+++ b/test/lisp/erc/resources/erc-d/resources/incremental.eld
@@ -7,8 +7,7 @@
(0.0 ":irc.foo.net 002 tester :Your host is irc.foo.net")
(0.0 ":irc.foo.net 003 tester :This server was created just now")
(0.0 ":irc.foo.net 004 tester irc.foo.net BERios CEIRabehiklmnoqstv Iabehkloqv")
- (0.0 ":irc.foo.net 005 tester MODES NETWORK=FooNet NICKLEN=32 PREFIX=(qaohv)~&@%+"
- " :are supported by this server")
+ (0.0 ":irc.foo.net 005 tester MODES NETWORK=FooNet NICKLEN=32 PREFIX=(qaohv)~&@%+ :are supported by this server")
(0.0 ":irc.foo.net 251 tester :There are 3 users and 0 invisible on 1 server(s)")
(0.0 ":irc.foo.net 252 tester 0 :IRC Operators online")
(0.0 ":irc.foo.net 253 tester 0 :unregistered connections")
@@ -24,7 +23,7 @@
((join 3 "JOIN #foo")
(0 ":tester!~tester@localhost JOIN #foo")
- (0 ":irc.foo.net 353 alice = #foo :+alice!~alice@example.com @%+bob!~bob@example.org")
+ (0 ":irc.foo.net 353 alice = #foo :+alice @bob")
(0 ":irc.foo.net 366 alice #foo :End of NAMES list"))
((mode 3 "MODE #foo")
diff --git a/test/lisp/erc/resources/erc-d/resources/linger.eld b/test/lisp/erc/resources/erc-d/resources/linger.eld
index 36c81a3af4b..d68da730581 100644
--- a/test/lisp/erc/resources/erc-d/resources/linger.eld
+++ b/test/lisp/erc/resources/erc-d/resources/linger.eld
@@ -8,8 +8,7 @@
(0 ":irc.example.org 002 tester :Your host is irc.example.org")
(0 ":irc.example.org 003 tester :This server was created just now")
(0 ":irc.example.org 004 tester irc.example.org BERios CEIRabehiklmnoqstv Iabehkloqv")
- (0 ":irc.example.org 005 tester MODES NETWORK=ExampleOrg NICKLEN=32 PREFIX=(qaohv)~&@%+"
- " :are supported by this server")
+ (0 ":irc.example.org 005 tester MODES NETWORK=ExampleOrg NICKLEN=32 PREFIX=(qaohv)~&@%+ :are supported by this server")
(0 ":irc.example.org 251 tester :There are 3 users and 0 invisible on 1 server(s)")
;; Just to mix thing's up (force handler to schedule timer)
(0.1 ":irc.example.org 252 tester 0 :IRC Operators online")
@@ -20,14 +19,14 @@
(0 ":irc.example.org 266 tester 3 3 :Current global users 3, max 3")
(0 ":irc.example.org 422 tester :MOTD File is missing"))
-((mode-user 1.2 "MODE tester +i")
+((mode-user 2 "MODE tester +i")
(0 ":irc.example.org 221 tester +Zi")
(0 ":irc.example.org 306 tester :You have been marked as being away")
(0 ":tester!~tester@localhost JOIN #chan")
- (0 ":irc.example.org 353 alice = #chan :+alice!~alice@example.com @%+bob!~bob@example.org")
+ (0 ":irc.example.org 353 alice = #chan :+alice @bob")
(0 ":irc.example.org 366 alice #chan :End of NAMES list"))
-((mode-chan 1.2 "MODE #chan")
+((mode-chan 2 "MODE #chan")
(0 ":bob!~bob@example.org PRIVMSG #chan :hey"))
((linger 1.0 LINGER))
diff --git a/test/lisp/erc/resources/erc-d/resources/no-block.eld b/test/lisp/erc/resources/erc-d/resources/no-block.eld
index 2811923d8ac..af2f4a83ff6 100644
--- a/test/lisp/erc/resources/erc-d/resources/no-block.eld
+++ b/test/lisp/erc/resources/erc-d/resources/no-block.eld
@@ -7,8 +7,7 @@
(0.0 ":irc.org 002 tester :Your host is irc.org")
(0.0 ":irc.org 003 tester :This server was created just now")
(0.0 ":irc.org 004 tester irc.org BERios CEIRabehiklmnoqstv Iabehkloqv")
- (0.0 ":irc.org 005 tester MODES NETWORK=ExampleOrg NICKLEN=32 PREFIX=(qaohv)~&@%+"
- " :are supported by this server")
+ (0.0 ":irc.org 005 tester MODES NETWORK=ExampleOrg NICKLEN=32 PREFIX=(qaohv)~&@%+ :are supported by this server")
(0.0 ":irc.org 251 tester :There are 3 users and 0 invisible on 1 server(s)")
(0.0 ":irc.org 252 tester 0 :IRC Operators online")
(0.0 ":irc.org 253 tester 0 :unregistered connections")
@@ -24,13 +23,13 @@
((join-foo 1.2 "JOIN #foo")
(0 ":tester!~tester@localhost JOIN #foo")
- (0 ":irc.example.org 353 alice = #foo :+alice!~alice@example.com @%+bob!~bob@example.org")
+ (0 ":irc.example.org 353 alice = #foo :+alice @bob")
(0 ":irc.example.org 366 alice #foo :End of NAMES list"))
;; This would time out if the mode-foo's outgoing blocked (remove minus signs to see)
((~join-bar 1.5 "JOIN #bar")
(0 ":tester!~tester@localhost JOIN #bar")
- (0 ":irc.example.org 353 alice = #bar :+alice!~alice@example.com @%+bob!~bob@example.org")
+ (0 ":irc.example.org 353 alice = #bar :+alice @bob")
(0 ":irc.example.org 366 alice #bar :End of NAMES list"))
((mode-foo 1.2 "MODE #foo")
diff --git a/test/lisp/erc/resources/erc-d/resources/no-match.eld b/test/lisp/erc/resources/erc-d/resources/no-match.eld
index d147be1e084..d12854de551 100644
--- a/test/lisp/erc/resources/erc-d/resources/no-match.eld
+++ b/test/lisp/erc/resources/erc-d/resources/no-match.eld
@@ -8,8 +8,7 @@
(0 ":irc.example.org 002 tester :Your host is irc.example.org")
(0 ":irc.example.org 003 tester :This server was created just now")
(0 ":irc.example.org 004 tester irc.example.org BERios CEIRabehiklmnoqstv Iabehkloqv")
- (0 ":irc.example.org 005 tester MODES NETWORK=ExampleOrg NICKLEN=32 PREFIX=(qaohv)~&@%+"
- " :are supported by this server")
+ (0 ":irc.example.org 005 tester MODES NETWORK=ExampleOrg NICKLEN=32 PREFIX=(qaohv)~&@%+ :are supported by this server")
(0 ":irc.example.org 251 tester :There are 3 users and 0 invisible on 1 server(s)")
(0 ":irc.example.org 252 tester 0 :IRC Operators online")
(0 ":irc.example.org 253 tester 0 :unregistered connections")
@@ -25,7 +24,7 @@
((join 1.2 "JOIN #chan")
(0 ":tester!~tester@localhost JOIN #chan")
- (0 ":irc.example.org 353 alice = #chan :+alice!~alice@example.com @%+bob!~bob@example.org")
+ (0 ":irc.example.org 353 alice = #chan :+alice @bob")
(0 ":irc.example.org 366 alice #chan :End of NAMES list"))
((mode-chan 0.2 "MODE #chan")
diff --git a/test/lisp/erc/resources/erc-d/resources/unexpected.eld b/test/lisp/erc/resources/erc-d/resources/unexpected.eld
index ac0a8fecfa6..c03b1dbcfdb 100644
--- a/test/lisp/erc/resources/erc-d/resources/unexpected.eld
+++ b/test/lisp/erc/resources/erc-d/resources/unexpected.eld
@@ -7,8 +7,7 @@
(0.0 ":irc.example.org 002 tester :Your host is irc.example.org")
(0.0 ":irc.example.org 003 tester :This server was created just now")
(0.0 ":irc.example.org 004 tester irc.example.org BERios CEIRabehiklmnoqstv Iabehkloqv")
- (0.0 ":irc.example.org 005 tester MODES NETWORK=ExampleOrg NICKLEN=32 PREFIX=(qaohv)~&@%+"
- " :are supported by this server")
+ (0.0 ":irc.example.org 005 tester MODES NETWORK=ExampleOrg NICKLEN=32 PREFIX=(qaohv)~&@%+ :are supported by this server")
(0.0 ":irc.example.org 251 tester :There are 3 users and 0 invisible on 1 server(s)")
(0.0 ":irc.example.org 252 tester 0 :IRC Operators online")
(0.0 ":irc.example.org 253 tester 0 :unregistered connections")
@@ -23,6 +22,6 @@
(0.0 ":irc.example.org 306 tester :You have been marked as being away")
(0.0 ":tester!~tester@localhost JOIN #chan")
- (0.0 ":irc.example.org 353 alice = #chan :+alice!~alice@example.com @%+bob!~bob@example.org")
+ (0.0 ":irc.example.org 353 alice = #chan :+alice @bob")
(0.0 ":irc.example.org 366 alice #chan :End of NAMES list")
(0.1 ":bob!~bob@example.org PRIVMSG #chan :hey"))
diff --git a/test/lisp/erc/resources/erc-scenarios-common.el b/test/lisp/erc/resources/erc-scenarios-common.el
index 0f06255540d..9ad5ce49429 100644
--- a/test/lisp/erc/resources/erc-scenarios-common.el
+++ b/test/lisp/erc/resources/erc-scenarios-common.el
@@ -51,7 +51,7 @@
;; argument, a `let*'-style VAR-LIST. Relying on such a macro is
;; unfortunate because in many ways it actually hampers readability by
;; favoring magic over verbosity. But without it (or something
-;; similar), any failing test would cause all subsequent tests in this
+;; similar), any failing test would cause all subsequent tests in a
;; file to fail like dominoes (making all but the first backtrace
;; useless).
;;
@@ -61,6 +61,25 @@
;; always associated with the fake network FooNet, while nicks Joe and
;; Mike are always on BarNet. (Networks are sometimes downcased.)
;;
+;; Environment variables:
+;;
+;; `ERC_TESTS_GRAPHICAL': Internal variable to unskip those few tests
+;; capable of running consecutively while interactive on a graphical
+;; display. This triggers both the tests and the suite to commence
+;; with teardown activities normally skipped to allow for inspection
+;; while interactive. This is also handy when needing to quickly
+;; run `ert-results-rerun-test-at-point-debugging-errors' on a
+;; failing test because you don't have to go around hunting for and
+;; killing associated buffers and processes.
+;;
+;; `ERC_TESTS_GRAPHICAL_ALL': Currently targets a single "meta" test,
+;; `erc-scenarios-internal--run-interactive-all', that runs all
+;; tests tagged `:erc--graphical' in an interactive subprocess.
+;;
+;; `ERC_TESTS_SUBPROCESS': Used internally to detect nested tests.
+;;
+;; `ERC_D_DEBUG': Tells `erc-d' to emit debugging info to stderr.
+;;
;; XXX This file should *not* contain any test cases.
;;; Code:
@@ -75,7 +94,8 @@
(require 'erc)
(eval-when-compile (require 'erc-join)
- (require 'erc-services))
+ (require 'erc-services)
+ (require 'erc-fill))
(declare-function erc-network "erc-networks")
(defvar erc-network)
@@ -91,6 +111,7 @@
(defvar erc-scenarios-common-dialog nil)
(defvar erc-scenarios-common-extra-teardown nil)
+(defvar erc-scenarios-common--graphical-p nil)
(defun erc-scenarios-common--add-silence ()
(advice-add #'erc-login :around #'erc-d-t-silence-around)
@@ -110,7 +131,11 @@
(eval-and-compile
(defun erc-scenarios-common--make-bindings (bindings)
- `((erc-d-u-canned-dialog-dir (expand-file-name
+ `((erc-scenarios-common--graphical-p
+ (and (or erc-scenarios-common--graphical-p
+ (memq :erc--graphical (ert-test-tags (ert-running-test))))
+ (not (and noninteractive (ert-skip "Interactive only")))))
+ (erc-d-u-canned-dialog-dir (expand-file-name
(or erc-scenarios-common-dialog
(cadr (assq 'erc-scenarios-common-dialog
',bindings)))
@@ -119,12 +144,16 @@
(quit . ,(erc-quit/part-reason-default))
(erc-version . ,erc-version)))
(erc-modules (copy-sequence erc-modules))
- (inhibit-interaction t)
+ (inhibit-interaction noninteractive)
(auth-source-do-cache nil)
+ (timer-list (copy-sequence timer-list))
+ (timer-idle-list (copy-sequence timer-idle-list))
(erc-auth-source-parameters-join-function nil)
+ (erc--fill-wrap-scrolltobottom-exempt-p t)
(erc-autojoin-channels-alist nil)
(erc-server-auto-reconnect nil)
(erc-after-connect nil)
+ (erc-last-input-time 0)
(erc-d-linger-secs 10)
,@bindings)))
@@ -137,13 +166,19 @@ disabled by BODY. Other defaults common to these test cases are added
below and can be overridden, except when wanting the \"real\" default
value, which must be looked up or captured outside of the calling form.
+When running tests tagged as serially runnable while interactive
+and the flag `erc-scenarios-common--graphical-p' is non-nil, run
+teardown tasks normally inhibited when interactive. That is,
+behave almost as if `noninteractive' were also non-nil, and
+ensure buffers and other resources are destroyed on completion.
+
Dialog resource directories are located by expanding the variable
`erc-scenarios-common-dialog' or its value in BINDINGS."
(declare (indent 1))
(let* ((orig-autojoin-mode (make-symbol "orig-autojoin-mode"))
(combined `((,orig-autojoin-mode (bound-and-true-p erc-autojoin-mode))
- ,@(erc-scenarios-common--make-bindings bindings))))
+ ,@(erc-scenarios-common--make-bindings bindings))))
`(erc-d-t-with-cleanup (,@combined)
@@ -163,8 +198,9 @@ Dialog resource directories are located by expanding the variable
(not (eq erc-autojoin-mode ,orig-autojoin-mode)))
(erc-autojoin-mode (if ,orig-autojoin-mode +1 -1)))
- (when noninteractive
- (erc-scenarios-common--print-trace)
+ (when (or noninteractive erc-scenarios-common--graphical-p)
+ (when noninteractive
+ (erc-scenarios-common--print-trace))
(erc-d-t-kill-related-buffers)
(delete-other-windows)))
@@ -177,11 +213,118 @@ Dialog resource directories are located by expanding the variable
(erc-d-t-search-for 3 "Starting")))))
(ert-info ("Activate erc-debug-irc-protocol")
- (unless (and noninteractive (not erc-debug-irc-protocol))
+ (unless (and (or noninteractive erc-scenarios-common--graphical-p)
+ (not erc-debug-irc-protocol))
(erc-toggle-debug-irc-protocol)))
,@body)))
+(defvar erc-scenarios-common--term-size '(34 . 80))
+(declare-function term-char-mode "term" nil)
+(declare-function term-line-mode "term" nil)
+
+;; Much of this concerns accommodating test environments outside of
+;; the emacs.git tree, such as CI jobs running ERC's ELPA-package on
+;; older Emacsen. See also `erc-tests--assert-printed-in-subprocess'.
+(defun erc-scenarios-common--run-in-term (&optional debug)
+ (require 'term)
+ (let* ((default-directory (or (getenv "EMACS_TEST_DIRECTORY")
+ (expand-file-name
+ ".." erc-scenarios-common--resources-dir)))
+ ;; In the emacs.git tree, "HOME" will be "/nonexistent", which
+ ;; is fine because we don't need any ELPA packages.
+ (process-environment (cons "ERC_TESTS_SUBPROCESS=1"
+ process-environment))
+ (name (ert-test-name (ert-running-test)))
+ (temp-file (make-temp-file "erc-term-test-"))
+ (cmd `(let ((stats 1))
+ (setq enable-dir-local-variables nil)
+ (unwind-protect
+ (setq stats (ert-run-tests-batch ',name))
+ (unless ',debug
+ (let ((buf (with-current-buffer (messages-buffer)
+ (buffer-string))))
+ (with-temp-file ,temp-file
+ (insert buf)))
+ (kill-emacs (ert-stats-completed-unexpected stats))))))
+ ;; The `ert-test' object in Emacs 29 has a `file-name' field.
+ (file-name (symbol-file name 'ert--test))
+ (default-directory (expand-file-name (file-name-directory file-name)))
+ (package (if-let* ((found (getenv "ERC_PACKAGE_NAME"))
+ ((string-prefix-p "erc-" found)))
+ (intern found)
+ 'erc))
+ (init (and-let* ((found (getenv "ERC_TESTS_INIT"))
+ (files (split-string found ",")))
+ (mapcan (lambda (f) (list "-l" f)) files)))
+ (setup `(progn
+ ,@(and (not init) (featurep 'compat)
+ `((require 'package)
+ (let ((package-load-list
+ '((compat t) (,package t))))
+ (package-initialize))))
+ (require 'erc)
+ (cl-assert (equal erc-version ,erc-version) t)))
+ ;; Make subprocess terminal bigger than controlling.
+ (buf (cl-letf (((symbol-function 'window-screen-lines)
+ (lambda () (car erc-scenarios-common--term-size)))
+ ((symbol-function 'window-max-chars-per-line)
+ (lambda () (cdr erc-scenarios-common--term-size))))
+ (apply #'make-term (symbol-name name)
+ (expand-file-name invocation-name invocation-directory)
+ nil `(,@(or init '("-Q")) "-nw"
+ "-eval" ,(format "%S" setup)
+ "-l" ,file-name
+ "-eval" ,(format "%S" cmd)))))
+ (proc (get-buffer-process buf))
+ (err (lambda ()
+ (with-temp-buffer
+ (insert-file-contents temp-file)
+ (message "Subprocess: %s" (buffer-string))
+ (delete-file temp-file)))))
+ (unless noninteractive
+ (set-window-buffer (selected-window) buf)
+ (delete-other-windows))
+ (with-current-buffer buf
+ (set-process-query-on-exit-flag proc nil)
+ (unless noninteractive (term-char-mode))
+ (erc-d-t-wait-for 30 (process-live-p proc))
+ (while (accept-process-output proc))
+ (term-line-mode)
+ (goto-char (point-min))
+ ;; Otherwise gives process exited abnormally with exit-code >0
+ (unless (search-forward (format "Process %s finished" name) nil t)
+ (funcall err)
+ (ert-fail (when (search-forward "exited" nil t)
+ (buffer-substring-no-properties (line-beginning-position)
+ (line-end-position)))))
+ (delete-file temp-file)
+ (when noninteractive
+ (kill-buffer)))))
+
+(defvar erc-scenarios-common-interactive-debug-term-p nil
+ "Non-nil means run test in an inferior Emacs, even if interactive.")
+
+(defmacro erc-scenarios-common-with-noninteractive-in-term (&rest body)
+ "Run BODY via `erc-scenarios-common-with-cleanup' in a `term' subprocess.
+Also do so when `erc-scenarios-common-interactive-debug-term-p'
+is non-nil. When debugging, leave the `term-mode' buffer around
+for inspection and name it after the test, bounded by asterisks.
+When debugging, ensure the test always fails, as a reminder to
+disable `erc-scenarios-common-interactive-debug-term-p'.
+
+See Info node `(emacs) Term Mode' for the various commands."
+ (declare (indent 1))
+ `(if (and (or erc-scenarios-common-interactive-debug-term-p
+ noninteractive)
+ (not (getenv "ERC_TESTS_SUBPROCESS")))
+ (progn
+ (when (memq system-type '(windows-nt ms-dos cygwin haiku))
+ (ert-skip "System must be UNIX-like"))
+ (erc-scenarios-common--run-in-term
+ erc-scenarios-common-interactive-debug-term-p))
+ (erc-scenarios-common-with-cleanup ,@body)))
+
(defun erc-scenarios-common-assert-initial-buf-name (id port)
;; Assert no limbo period when explicit ID given
(should (string= (if id
@@ -208,9 +351,111 @@ Dialog resource directories are located by expanding the variable
(insert str)
(erc-send-current-line)))
+(defun erc-scenarios-common--at-win-end-p (&optional window)
+ (= (window-body-height window)
+ (count-screen-lines (window-start window) (point-max) nil window)))
+
+(defun erc-scenarios-common--above-win-end-p (&optional window)
+ (> (window-body-height window)
+ (count-screen-lines (window-start window) (point-max))))
+
+(defun erc-scenarios-common--prompt-past-win-end-p (&optional window)
+ (< (window-body-height window)
+ (count-screen-lines (window-start window) (point-max))))
+
+(defun erc-scenarios-common--recenter-top-bottom-around (orig &rest args)
+ (let (this-command last-command) (apply orig args)))
+
+(defun erc-scenarios-common--recenter-top-bottom ()
+ (advice-add 'recenter-top-bottom
+ :around #'erc-scenarios-common--recenter-top-bottom-around)
+ (execute-kbd-macro "\C-l")
+ (advice-remove 'recenter-top-bottom
+ #'erc-scenarios-common--recenter-top-bottom-around))
+
;;;; Fixtures
+(defun erc-scenarios-common-scrolltobottom--normal (test)
+ (erc-scenarios-common-with-noninteractive-in-term
+ ((erc-scenarios-common-dialog "scrolltobottom")
+ (dumb-server (erc-d-run "localhost" t 'help))
+ (port (process-contact dumb-server :service))
+ (erc-modules `(scrolltobottom fill-wrap ,@erc-modules))
+ (erc-server-flood-penalty 0.1)
+ (expect (erc-d-t-make-expecter)))
+
+ (ert-info ("Connect")
+ (with-current-buffer (erc :server "127.0.0.1"
+ :port port
+ :full-name "tester"
+ :nick "tester")
+ (funcall expect 10 "debug mode")))
+
+ (with-current-buffer "foonet"
+ (should (looking-at " and"))
+ (set-window-buffer nil (current-buffer))
+ (delete-other-windows)
+ (split-window-below 15)
+ (recenter 0)
+
+ (ert-info ("Moving into prompt in other window triggers scroll")
+ (with-selected-window (next-window)
+ (should-not (erc-scenarios-common--at-win-end-p))
+ (goto-char (1- erc-insert-marker))
+ (execute-kbd-macro "\C-n")
+ ;; Ensure point is at prompt and aligned to bottom.
+ (should (erc-scenarios-common--at-win-end-p))))
+
+ (ert-info ("Module `move-to-prompt' still works")
+ ;; Prompt is somewhere in the middle of the window.
+ (should (erc-scenarios-common--above-win-end-p))
+ ;; Hitting a self-insert key triggers `move-to-prompt' as well
+ ;; as a scroll (to bottom).
+ (execute-kbd-macro "hi")
+ ;; Prompt and input appear on last line of window.
+ (should (erc-scenarios-common--at-win-end-p)))
+
+ (ert-info ("Command `recenter-top-bottom' disallowed at prompt")
+ ;; Hitting C-l does not recenter the window.
+ (erc-scenarios-common--recenter-top-bottom)
+ (should (erc-scenarios-common--at-win-end-p))
+ (erc-scenarios-common--recenter-top-bottom)
+ (should (erc-scenarios-common--at-win-end-p)))
+
+ (ert-info ("Command `beginning-of-buffer' allowed at prompt")
+ ;; Hitting C-< goes to beginning of buffer.
+ (call-interactively #'beginning-of-buffer)
+ (should (= 1 (point)))
+ (redisplay)
+ (should (zerop (count-screen-lines (window-start) (point))))
+ (should (erc-scenarios-common--prompt-past-win-end-p)))
+
+ (ert-info ("New message doesn't trigger scroll when away from prompt")
+ ;; Arriving insertions don't trigger a scroll when away from the
+ ;; prompt. New output not seen.
+ (erc-cmd-MSG "NickServ help register")
+ (save-excursion (erc-d-t-search-for 10 "End of NickServ"))
+ (should (= 1 (point)))
+ (redisplay)
+ (should (zerop (count-screen-lines (window-start) (window-point))))
+ (should (erc-scenarios-common--prompt-past-win-end-p)))
+
+ (funcall test)
+
+ (ert-info ("New message does trigger a scroll when at prompt")
+ ;; Recenter so prompt is above rather than at window's end.
+ (funcall expect 10 "If you are currently logged in")
+ (recenter 0)
+ ;; Prompt is somewhere in the middle of the window.
+ (erc-d-t-wait-for 10 (erc-scenarios-common--above-win-end-p))
+ (erc-scenarios-common-say "/msg NickServ help identify")
+ ;; New arriving messages trigger a snap when inserted.
+ (erc-d-t-wait-for 10 (erc-scenarios-common--at-win-end-p))
+ (funcall expect 10 "IDENTIFY lets you login"))
+
+ (erc-scrolltobottom-mode -1))))
+
(cl-defun erc-scenarios-common--base-network-id-bouncer
((&key autop foo-id bar-id after
&aux
@@ -247,7 +492,7 @@ buffer-naming collisions involving bouncers in ERC."
:id foo-id))
(setq erc-server-process-foo erc-server-process)
(erc-scenarios-common-assert-initial-buf-name foo-id port)
- (erc-d-t-wait-for 3 (eq (erc-network) 'foonet))
+ (erc-d-t-wait-for 6 (eq (erc-network) 'foonet))
(erc-d-t-wait-for 3 (string= (buffer-name) serv-buf-foo))
(funcall expect 5 "foonet")))
@@ -287,7 +532,7 @@ buffer-naming collisions involving bouncers in ERC."
(erc-d-t-search-for 1 "<bob>")
(erc-d-t-absent-for 0.1 "<joe>")
(should (eq erc-server-process erc-server-process-foo))
- (erc-d-t-search-for 10 "ape is dead")
+ (erc-d-t-search-for 15 "ape is dead")
(erc-d-t-wait-for 5 (not (erc-server-process-alive)))))
(ert-info ("#chan@<esid> is exclusive to barnet")
@@ -366,7 +611,7 @@ buffer-naming collisions involving bouncers in ERC."
:password "changeme"
:full-name "tester")
(erc-scenarios-common-assert-initial-buf-name nil port)
- (erc-d-t-wait-for 3 (eq (erc-network) 'foonet))
+ (erc-d-t-wait-for 6 (eq (erc-network) 'foonet))
(erc-d-t-wait-for 3 (string= (buffer-name) "foonet"))
(funcall expect 5 "foonet")))
@@ -446,10 +691,17 @@ Bug#48598: 28.0.50; buffer-naming collisions involving bouncers in ERC."
(with-current-buffer erc-server-buffer-foo (erc-cmd-JOIN "#chan"))
(with-current-buffer (erc-d-t-wait-for 5 (get-buffer "#chan"))
(funcall expect 5 "vile thing")
- (erc-cmd-QUIT "")))
+ (erc-cmd-QUIT "")
+
+ (ert-info ("Prompt hidden in channel buffer upon quitting")
+ (erc-d-t-wait-for 10 (erc--prompt-hidden-p))
+ (should (overlays-in erc-insert-marker erc-input-marker)))))
- (erc-d-t-wait-for 2 "Foonet connection deceased"
- (not (erc-server-process-alive erc-server-buffer-foo)))
+ (with-current-buffer erc-server-buffer-foo
+ (ert-info ("Prompt hidden after process dies in server buffer")
+ (erc-d-t-wait-for 2 (not (erc-server-process-alive)))
+ (erc-d-t-wait-for 10 (erc--prompt-hidden-p))
+ (should (overlays-in erc-insert-marker erc-input-marker))))
(should (equal erc-autojoin-channels-alist
(if foo-id '((oofnet "#chan")) '((foonet "#chan")))))
@@ -498,6 +750,10 @@ Bug#48598: 28.0.50; buffer-naming collisions involving bouncers in ERC."
(setq erc-server-process-foo erc-server-process)
(erc-d-t-wait-for 2 (eq erc-network 'foonet))
(should (string= (buffer-name) (if foo-id "oofnet" "foonet")))
+
+ (ert-info ("Prompt unhidden")
+ (should-not (erc--prompt-hidden-p))
+ (should-not (overlays-in erc-insert-marker erc-input-marker)))
(funcall expect 5 "foonet")))
(ert-info ("#chan@foonet is clean, no cross-contamination")
@@ -505,7 +761,11 @@ Bug#48598: 28.0.50; buffer-naming collisions involving bouncers in ERC."
(erc-d-t-wait-for 3 (eq erc-server-process erc-server-process-foo))
(funcall expect 3 "<bob>")
(erc-d-t-absent-for 0.1 "<joe>")
- (funcall expect 10 "not given me")))
+ (funcall expect 30 "not given me")
+
+ (ert-info ("Prompt unhidden")
+ (should-not (erc--prompt-hidden-p))
+ (should-not (overlays-in erc-insert-marker erc-input-marker)))))
(ert-info ("All #chan@barnet output received")
(with-current-buffer chan-buf-bar
diff --git a/test/lisp/erc/resources/erc-tests-common.el b/test/lisp/erc/resources/erc-tests-common.el
new file mode 100644
index 00000000000..99f15b89b03
--- /dev/null
+++ b/test/lisp/erc/resources/erc-tests-common.el
@@ -0,0 +1,301 @@
+;;; erc-tests-common.el --- Common helpers for ERC tests -*- lexical-binding: t -*-
+
+;; Copyright (C) 2023-2024 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 <https://www.gnu.org/licenses/>.
+
+;;; Commentary:
+
+;; This file must *not* contain any `ert-deftest' definitions. See
+;; top of test/lisp/erc/erc-tests.el for loading example.
+;;
+;; Environment variables:
+;;
+;; `ERC_PACKAGE_NAME': Name of the installed ERC package currently
+;; running. ERC needs this in order to load the same package in
+;; tests that run in a subprocess. Necessary even when the package
+;; name is `erc' and not something like `erc-49860'.
+;;
+;; `ERC_TESTS_INIT': The name of an alternate init file. Mainly for
+;; integrations tests involving starter kits.
+;;
+;; `ERC_TESTS_SNAPSHOT_SAVE': When set, ERC saves the current test's
+;; snapshots to disk.
+;;
+
+;;; Code:
+(require 'ert-x)
+(require 'erc)
+
+
+(defmacro erc-tests-common-equal-with-props (a b)
+ "Compare strings A and B for equality including text props.
+Use `ert-equal-including-properties' on older Emacsen."
+ (list (if (< emacs-major-version 29)
+ 'ert-equal-including-properties
+ 'equal-including-properties)
+ a b))
+
+;; Caller should probably shadow `erc-insert-modify-hook' or populate
+;; user tables for erc-button.
+;; FIXME explain this comment ^ in more detail or delete.
+(defun erc-tests-common-prep-for-insertion ()
+ "Initialize current buffer with essentials for message insertion.
+Assume caller intends to use `erc-display-message'."
+ (erc-mode)
+ (erc--initialize-markers (point) nil)
+ (should (= (point) erc-input-marker)))
+
+(defun erc-tests-common-init-server-proc (&rest args)
+ "Create a process with `start-process' from ARGS.
+Assign the result to `erc-server-process' in the current buffer."
+ (setq erc-server-process
+ (apply #'start-process (car args) (current-buffer) args))
+ (set-process-query-on-exit-flag erc-server-process nil)
+ erc-server-process)
+
+;; After dropping support for Emacs 27, callers can use
+;; `get-buffer-create' with INHIBIT-BUFFER-HOOKS.
+(defun erc-tests-common-kill-buffers (&rest extra-buffers)
+ "Kill all ERC buffers and possibly EXTRA-BUFFERS."
+ (let (erc-kill-channel-hook erc-kill-server-hook erc-kill-buffer-hook)
+ (dolist (buf (erc-buffer-list))
+ (kill-buffer buf))
+ (named-let doit ((buffers extra-buffers))
+ (dolist (buf buffers)
+ (if (consp buf) (doit buf) (kill-buffer buf))))))
+
+(defun erc-tests-common-with-process-input-spy (test-fn)
+ "Mock `erc-process-input-line' and call TEST-FN.
+Shadow `erc--input-review-functions' and `erc-pre-send-functions'
+with `erc-add-to-input-ring' removed. Shadow other relevant
+variables as nil, and bind `erc-last-input-time' to 0. Also mock
+`erc-server-buffer' to return the current buffer. Call TEST-FN
+with a utility function that returns the set of arguments most
+recently passed to the mocked `erc-process-input-line'. Make
+`inhibit-message' non-nil unless running interactively."
+ (with-current-buffer (get-buffer-create "FakeNet")
+ (let* ((erc--input-review-functions
+ (remove 'erc-add-to-input-ring erc--input-review-functions))
+ (erc-pre-send-functions
+ (remove 'erc-add-to-input-ring erc-pre-send-functions)) ; for now
+ (inhibit-message noninteractive)
+ (erc-server-current-nick "tester")
+ (erc-last-input-time 0)
+ erc-accidental-paste-threshold-seconds
+ erc-send-modify-hook
+ ;;
+ calls)
+ (cl-letf (((symbol-function 'erc-process-input-line)
+ (lambda (&rest r) (push r calls)))
+ ((symbol-function 'erc-server-buffer)
+ (lambda () (current-buffer))))
+ (erc-tests-common-prep-for-insertion)
+ (funcall test-fn (lambda () (pop calls)))))
+ (when noninteractive (kill-buffer))))
+
+(defun erc-tests-common-make-server-buf (&optional name)
+ "Return a server buffer named NAME, creating it if necessary.
+Use NAME for the network and the session server as well."
+ (unless name
+ (cl-assert (string-prefix-p " *temp*" (setq name (buffer-name)))))
+ (with-current-buffer (get-buffer-create name)
+ (erc-tests-common-prep-for-insertion)
+ (erc-tests-common-init-server-proc "sleep" "1")
+ (setq erc-session-server (concat "irc." name ".org")
+ erc-server-announced-name (concat "west." name ".org")
+ erc-server-users (make-hash-table :test #'equal)
+ erc-server-parameters nil
+ erc--isupport-params (make-hash-table)
+ erc-session-port 6667
+ erc-network (intern name)
+ erc-networks--id (erc-networks--id-create name))
+ (current-buffer)))
+
+(defun erc-tests-common-string-to-propertized-parts (string)
+ "Return a sequence of `propertize' forms for generating STRING.
+Expect maintainers manipulating template catalogs to use this
+with `pp-eval-last-sexp' or similar to convert back and forth
+between literal strings."
+ `(concat
+ ,@(mapcar
+ (pcase-lambda (`(,beg ,end ,plist))
+ ;; At the time of writing, `propertize' produces a string
+ ;; with the order of the input plist reversed.
+ `(propertize ,(substring-no-properties string beg end)
+ ,@(let (out)
+ (while-let ((plist)
+ (k (pop plist))
+ (v (pop plist)))
+ (push (if (or (consp v) (symbolp v)) `',v v) out)
+ (push `',k out))
+ out)))
+ (object-intervals string))))
+
+(defun erc-tests-common-pp-propertized-parts (arg)
+ "Convert literal string before point into a `propertize'd form.
+For simplicity, assume string evaluates to itself."
+ (interactive "P")
+ (let ((sexp (erc-tests-common-string-to-propertized-parts (pp-last-sexp))))
+ (if arg (insert (pp-to-string sexp)) (pp-macroexpand-expression sexp))))
+
+;; The following utilities are meant to help prepare tests for
+;; `erc--get-inserted-msg-bounds' and friends.
+(defun erc-tests-common-get-inserted-msg-setup ()
+ (erc-tests-common-prep-for-insertion)
+ (let ((parsed (make-erc-response :unparsed ":bob PRIVMSG #chan :hi"
+ :sender "bob"
+ :command "PRIVMSG"
+ :command-args (list "#chan" "hi")
+ :contents "hi"))
+ (erc--msg-prop-overrides '((erc--ts . 0))))
+ (erc-display-message parsed nil (current-buffer)
+ (erc-format-privmessage "bob" "hi" nil t)))
+ (goto-char 3)
+ (should (looking-at "<bob> hi")))
+
+;; All these bounds-finding functions take an optional POINT argument.
+;; So run each case with and without it at each pos in the message.
+(defun erc-tests-common-assert-get-inserted-msg (from to assert-fn)
+ (dolist (pt-arg '(nil t))
+ (dolist (i (number-sequence from to))
+ (goto-char i)
+ (ert-info ((format "At %d (%c) %s param" i (char-after i)
+ (if pt-arg "with" "")))
+ (funcall assert-fn (and pt-arg i))))))
+
+(defun erc-tests-common-assert-get-inserted-msg/basic (test-fn)
+ (erc-tests-common-get-inserted-msg-setup)
+ (goto-char 11)
+ (should (looking-back "<bob> hi"))
+ (erc-tests-common-assert-get-inserted-msg 3 11 test-fn))
+
+;; This is a "mixin" and requires a base assertion function, like
+;; `erc-tests-common-assert-get-inserted-msg/basic', to work.
+(defun erc-tests-common-assert-get-inserted-msg-readonly-with
+ (assert-fn test-fn)
+ (defvar erc-readonly-mode)
+ (defvar erc-readonly-mode-hook)
+ (let ((erc-readonly-mode nil)
+ (erc-readonly-mode-hook nil)
+ (erc-send-post-hook erc-send-post-hook)
+ (erc-insert-post-hook erc-insert-post-hook))
+ (erc-readonly-mode +1)
+ (funcall assert-fn test-fn)))
+
+
+;;;; Buffer snapshots
+
+;; Use this variable to generate new snapshots after carefully
+;; reviewing the output of *each* snapshot (not just first and last).
+;; Obviously, only run one test at a time.
+(defvar erc-tests-common-snapshot-save-p (getenv "ERC_TESTS_SNAPSHOT_SAVE"))
+
+(defun erc-tests-common-snapshot-compare (name dir trans-fn buf-init-fn)
+ "Compare `buffer-string' to snapshot NAME.eld in DIR, if present.
+When non-nil, run TRANS-FN to filter the current buffer string,
+and expect a similar string in return. Call BUF-INIT-FN, when
+non-nil, in the preview buffer after inserting the filtered
+string."
+ (let* ((expect-file (file-name-with-extension (expand-file-name name dir)
+ "eld"))
+ (erc--own-property-names
+ (seq-difference `(font-lock-face ,@erc--own-property-names)
+ `(field display wrap-prefix line-prefix
+ erc--msg erc--cmd erc--spkr erc--ts erc--ctcp
+ erc--ephemeral)
+ #'eq))
+ (print-circle t)
+ (print-escape-newlines t)
+ (print-escape-nonascii t)
+ (got (erc--remove-text-properties
+ (buffer-substring (point-min) erc-insert-marker)))
+ (repr (funcall (or trans-fn #'identity) (prin1-to-string got))))
+ (with-current-buffer (generate-new-buffer name)
+ (with-silent-modifications
+ (insert (setq got (read repr))))
+ (when buf-init-fn (funcall buf-init-fn))
+ (erc-mode))
+ ;; LHS is a string, RHS is a symbol.
+ (if (string= erc-tests-common-snapshot-save-p
+ (ert-test-name (ert-running-test)))
+ (let (inhibit-message)
+ (with-temp-file expect-file
+ (insert repr))
+ ;; Limit writing snapshots to one test at a time.
+ (message "erc-tests-common-snapshot-compare: wrote %S" expect-file))
+ (if (file-exists-p expect-file)
+ ;; Ensure string-valued properties, like timestamps, aren't
+ ;; recursive (signals `max-lisp-eval-depth' exceeded).
+ (named-let assert-equal
+ ((latest (read repr))
+ (expect (read (with-temp-buffer
+ (insert-file-contents-literally expect-file)
+ (buffer-string)))))
+ (pcase latest
+ ((or "" 'nil) t)
+ ((pred stringp)
+ (should (equal-including-properties latest expect))
+ (let ((latest-intervals (object-intervals latest))
+ (expect-intervals (object-intervals expect)))
+ (while-let ((l-iv (pop latest-intervals))
+ (x-iv (pop expect-intervals))
+ (l-tab (map-into (nth 2 l-iv) 'hash-table))
+ (x-tab (map-into (nth 2 x-iv) 'hash-table)))
+ (pcase-dolist (`(,l-k . ,l-v) (map-pairs l-tab))
+ (assert-equal l-v (gethash l-k x-tab))
+ (remhash l-k x-tab))
+ (should (zerop (hash-table-count x-tab))))))
+ ((pred sequencep)
+ (assert-equal (seq-first latest) (seq-first expect))
+ (assert-equal (seq-rest latest) (seq-rest expect)))
+ (_ (should (equal latest expect)))))
+ (message "Snapshot file missing: %S" expect-file)))))
+
+(defun erc-tests-common-create-subprocess (code switches libs)
+ "Return subprocess for running CODE in an inferior Emacs.
+Include SWITCHES, like \"-batch\", as well as libs, after
+interspersing \"-l\" between members."
+ (let* ((package (if-let ((found (getenv "ERC_PACKAGE_NAME"))
+ ((string-prefix-p "erc-" found)))
+ (intern found)
+ 'erc))
+ ;; For integrations testing with managed configs that use a
+ ;; different package manager.
+ (init (and-let* ((found (getenv "ERC_TESTS_INIT"))
+ (files (split-string found ",")))
+ (mapcan (lambda (f) (list "-l" f)) files)))
+ (prog
+ `(progn
+ ,@(and (not init) (featurep 'compat)
+ `((require 'package)
+ (let ((package-load-list '((compat t) (,package t))))
+ (package-initialize))))
+ (require 'erc)
+ (cl-assert (equal erc-version ,erc-version) t)
+ ,code))
+ (proc (apply #'start-process
+ (symbol-name (ert-test-name (ert-running-test)))
+ (current-buffer)
+ (concat invocation-directory invocation-name)
+ `(,@(or init '("-Q"))
+ ,@switches
+ ,@(mapcan (lambda (f) (list "-l" f)) libs)
+ "-eval" ,(format "%S" prog)))))
+ (set-process-query-on-exit-flag proc t)
+ proc))
+
+(provide 'erc-tests-common)
diff --git a/test/lisp/erc/resources/fill/snapshots/merge-01-start.eld b/test/lisp/erc/resources/fill/snapshots/merge-01-start.eld
new file mode 100644
index 00000000000..6ff7af218c0
--- /dev/null
+++ b/test/lisp/erc/resources/fill/snapshots/merge-01-start.eld
@@ -0,0 +1 @@
+#("\n\n\n[Thu Jan 1 1970]\n*** This server is in debug mode and is logging all user I/O. If you do not wish for everything you send to be readable by the server owner(s), please disconnect. [00:00]\n<alice> bob: come, you are a tedious fool: to the purpose. What was done to Elbow's wife, that he hath cause to complain of? Come me to what was done to her.\n<bob> alice: Either your unparagoned mistress is dead, or she's outprized by a trifle.\n\n[Sat Apr 1 2023]\n<bob> zero. [07:00]\n<alice> one.\n<alice> two.\n<bob> three.\n<bob> four.\n<Dummy> five.\n<Dummy> six.\n" 2 3 (erc--msg datestamp erc--ts 0 field erc-timestamp) 3 20 (field erc-timestamp wrap-prefix #1=(space :width 27) line-prefix (space :width (- 27 (18)))) 21 22 (erc--msg notice erc--ts 0 wrap-prefix #1# line-prefix #2=(space :width (- 27 (4)))) 22 183 (wrap-prefix #1# line-prefix #2#) 183 184 (field erc-timestamp wrap-prefix #1# line-prefix #2#) 184 191 (field erc-timestamp wrap-prefix #1# line-prefix #2# display (#6=(margin right-margin) #("[00:00]" 0 7 (invisible timestamp)))) 192 193 (erc--msg msg erc--spkr "alice" erc--ts 0 erc--cmd PRIVMSG wrap-prefix #1# line-prefix #3=(space :width (- 27 (8)))) 193 198 (wrap-prefix #1# line-prefix #3#) 198 200 (wrap-prefix #1# line-prefix #3#) 200 203 (wrap-prefix #1# line-prefix #3#) 203 316 (wrap-prefix #1# line-prefix #3#) 317 349 (wrap-prefix #1# line-prefix #3#) 350 351 (erc--msg msg erc--spkr "bob" erc--ts 0 erc--cmd PRIVMSG wrap-prefix #1# line-prefix #4=(space :width (- 27 (6)))) 351 354 (wrap-prefix #1# line-prefix #4#) 354 356 (wrap-prefix #1# line-prefix #4#) 356 361 (wrap-prefix #1# line-prefix #4#) 361 436 (wrap-prefix #1# line-prefix #4#) 437 438 (erc--msg datestamp erc--ts 1680307200 field erc-timestamp) 438 455 (field erc-timestamp wrap-prefix #1# line-prefix (space :width (- 27 (18)))) 456 457 (erc--msg msg erc--spkr "bob" erc--ts 1680332400 erc--cmd PRIVMSG wrap-prefix #1# line-prefix #5=(space :width (- 27 (6)))) 457 460 (wrap-prefix #1# line-prefix #5#) 460 467 (wrap-prefix #1# line-prefix #5#) 467 468 (field erc-timestamp wrap-prefix #1# line-prefix #5#) 468 475 (field erc-timestamp wrap-prefix #1# line-prefix #5# display (#6# #("[07:00]" 0 7 (invisible timestamp)))) 476 477 (erc--msg msg erc--spkr "alice" erc--ts 1680332400 erc--cmd PRIVMSG wrap-prefix #1# line-prefix #7=(space :width (- 27 (8)))) 477 482 (wrap-prefix #1# line-prefix #7#) 482 488 (wrap-prefix #1# line-prefix #7#) 489 490 (erc--msg msg erc--spkr "alice" erc--ts 1680332400 erc--cmd PRIVMSG wrap-prefix #1# line-prefix #8=(space :width (- 27 0)) display #9="") 490 495 (wrap-prefix #1# line-prefix #8# display #9#) 495 497 (wrap-prefix #1# line-prefix #8# display #9#) 497 501 (wrap-prefix #1# line-prefix #8#) 502 503 (erc--msg msg erc--spkr "bob" erc--ts 1680332400 erc--cmd PRIVMSG wrap-prefix #1# line-prefix #10=(space :width (- 27 (6)))) 503 506 (wrap-prefix #1# line-prefix #10#) 506 514 (wrap-prefix #1# line-prefix #10#) 515 516 (erc--msg msg erc--spkr "bob" erc--ts 1680332400 erc--cmd PRIVMSG wrap-prefix #1# line-prefix #11=(space :width (- 27 0)) display #9#) 516 519 (wrap-prefix #1# line-prefix #11# display #9#) 519 521 (wrap-prefix #1# line-prefix #11# display #9#) 521 526 (wrap-prefix #1# line-prefix #11#) 527 528 (erc--msg msg erc--spkr "Dummy" erc--ts 1680332400 erc--cmd PRIVMSG wrap-prefix #1# line-prefix #12=(space :width (- 27 (8)))) 528 533 (wrap-prefix #1# line-prefix #12#) 533 540 (wrap-prefix #1# line-prefix #12#) 541 542 (erc--msg msg erc--spkr "Dummy" erc--ts 1680332400 erc--cmd PRIVMSG wrap-prefix #1# line-prefix #13=(space :width (- 27 0)) display #9#) 542 547 (wrap-prefix #1# line-prefix #13# display #9#) 547 549 (wrap-prefix #1# line-prefix #13# display #9#) 549 553 (wrap-prefix #1# line-prefix #13#)) \ No newline at end of file
diff --git a/test/lisp/erc/resources/fill/snapshots/merge-02-right.eld b/test/lisp/erc/resources/fill/snapshots/merge-02-right.eld
new file mode 100644
index 00000000000..7d9822c80bc
--- /dev/null
+++ b/test/lisp/erc/resources/fill/snapshots/merge-02-right.eld
@@ -0,0 +1 @@
+#("\n\n\n[Thu Jan 1 1970]\n*** This server is in debug mode and is logging all user I/O. If you do not wish for everything you send to be readable by the server owner(s), please disconnect. [00:00]\n<alice> bob: come, you are a tedious fool: to the purpose. What was done to Elbow's wife, that he hath cause to complain of? Come me to what was done to her.\n<bob> alice: Either your unparagoned mistress is dead, or she's outprized by a trifle.\n\n[Sat Apr 1 2023]\n<bob> zero. [07:00]\n<alice> one.\n<alice> two.\n<bob> three.\n<bob> four.\n<Dummy> five.\n<Dummy> six.\n" 2 3 (erc--msg datestamp erc--ts 0 field erc-timestamp) 3 20 (wrap-prefix #1=(space :width 29) line-prefix (space :width (- 29 (18))) field erc-timestamp) 21 22 (wrap-prefix #1# line-prefix #2=(space :width (- 29 (4))) erc--msg notice erc--ts 0) 22 183 (wrap-prefix #1# line-prefix #2#) 183 184 (wrap-prefix #1# line-prefix #2# field erc-timestamp) 184 191 (wrap-prefix #1# line-prefix #2# field erc-timestamp display (#6=(margin right-margin) #("[00:00]" 0 7 (invisible timestamp)))) 192 193 (wrap-prefix #1# line-prefix #3=(space :width (- 29 (8))) erc--msg msg erc--spkr "alice" erc--ts 0 erc--cmd PRIVMSG) 193 198 (wrap-prefix #1# line-prefix #3#) 198 200 (wrap-prefix #1# line-prefix #3#) 200 203 (wrap-prefix #1# line-prefix #3#) 203 316 (wrap-prefix #1# line-prefix #3#) 317 349 (wrap-prefix #1# line-prefix (space :width (- 29 (8)))) 350 351 (wrap-prefix #1# line-prefix #4=(space :width (- 29 (6))) erc--msg msg erc--spkr "bob" erc--ts 0 erc--cmd PRIVMSG) 351 354 (wrap-prefix #1# line-prefix #4#) 354 356 (wrap-prefix #1# line-prefix #4#) 356 361 (wrap-prefix #1# line-prefix #4#) 361 436 (wrap-prefix #1# line-prefix #4#) 437 438 (erc--msg datestamp erc--ts 1680307200 field erc-timestamp) 438 455 (wrap-prefix #1# line-prefix (space :width (- 29 (18))) field erc-timestamp) 456 457 (wrap-prefix #1# line-prefix #5=(space :width (- 29 (6))) erc--msg msg erc--spkr "bob" erc--ts 1680332400 erc--cmd PRIVMSG) 457 460 (wrap-prefix #1# line-prefix #5#) 460 467 (wrap-prefix #1# line-prefix #5#) 467 468 (wrap-prefix #1# line-prefix #5# field erc-timestamp) 468 475 (wrap-prefix #1# line-prefix #5# field erc-timestamp display (#6# #("[07:00]" 0 7 (invisible timestamp)))) 476 477 (wrap-prefix #1# line-prefix #7=(space :width (- 29 (8))) erc--msg msg erc--spkr "alice" erc--ts 1680332400 erc--cmd PRIVMSG) 477 482 (wrap-prefix #1# line-prefix #7#) 482 488 (wrap-prefix #1# line-prefix #7#) 489 490 (wrap-prefix #1# line-prefix #8=(space :width (- 29 0)) erc--msg msg erc--spkr "alice" erc--ts 1680332400 erc--cmd PRIVMSG display #9="") 490 495 (wrap-prefix #1# line-prefix #8# display #9#) 495 497 (wrap-prefix #1# line-prefix #8# display #9#) 497 501 (wrap-prefix #1# line-prefix #8#) 502 503 (wrap-prefix #1# line-prefix #10=(space :width (- 29 (6))) erc--msg msg erc--spkr "bob" erc--ts 1680332400 erc--cmd PRIVMSG) 503 506 (wrap-prefix #1# line-prefix #10#) 506 514 (wrap-prefix #1# line-prefix #10#) 515 516 (wrap-prefix #1# line-prefix #11=(space :width (- 29 0)) erc--msg msg erc--spkr "bob" erc--ts 1680332400 erc--cmd PRIVMSG display #9#) 516 519 (wrap-prefix #1# line-prefix #11# display #9#) 519 521 (wrap-prefix #1# line-prefix #11# display #9#) 521 526 (wrap-prefix #1# line-prefix #11#) 527 528 (wrap-prefix #1# line-prefix #12=(space :width (- 29 (8))) erc--msg msg erc--spkr "Dummy" erc--ts 1680332400 erc--cmd PRIVMSG) 528 533 (wrap-prefix #1# line-prefix #12#) 533 540 (wrap-prefix #1# line-prefix #12#) 541 542 (wrap-prefix #1# line-prefix #13=(space :width (- 29 0)) erc--msg msg erc--spkr "Dummy" erc--ts 1680332400 erc--cmd PRIVMSG display #9#) 542 547 (wrap-prefix #1# line-prefix #13# display #9#) 547 549 (wrap-prefix #1# line-prefix #13# display #9#) 549 553 (wrap-prefix #1# line-prefix #13#)) \ No newline at end of file
diff --git a/test/lisp/erc/resources/fill/snapshots/merge-wrap-01.eld b/test/lisp/erc/resources/fill/snapshots/merge-wrap-01.eld
new file mode 100644
index 00000000000..2d0e5a5965f
--- /dev/null
+++ b/test/lisp/erc/resources/fill/snapshots/merge-wrap-01.eld
@@ -0,0 +1 @@
+#("\n\n\n[Thu Jan 1 1970]\n*** This server is in debug mode and is logging all user I/O. If you do not wish for everything you send to be readable by the server owner(s), please disconnect. [00:00]\n<alice> bob: come, you are a tedious fool: to the purpose. What was done to Elbow's wife, that he hath cause to complain of? Come me to what was done to her.\n<bob> alice: Either your unparagoned mistress is dead, or she's outprized by a trifle.\n\n[Sat Apr 1 2023]\n<bob> zero. [07:00]\n<bob> 0.5\n* bob one.\n<bob> two.\n<bob> 2.5\n* bob three\n<bob> four.\n" 2 3 (erc--msg datestamp erc--ts 0 field erc-timestamp) 3 20 (field erc-timestamp wrap-prefix #1=(space :width 27) line-prefix (space :width (- 27 (18)))) 21 22 (erc--msg notice erc--ts 0 wrap-prefix #1# line-prefix #2=(space :width (- 27 (4)))) 22 183 (wrap-prefix #1# line-prefix #2#) 183 184 (field erc-timestamp wrap-prefix #1# line-prefix #2#) 184 191 (field erc-timestamp wrap-prefix #1# line-prefix #2# display (#5=(margin right-margin) #("[00:00]" 0 7 (invisible timestamp)))) 192 193 (erc--msg msg erc--spkr "alice" erc--ts 0 erc--cmd PRIVMSG wrap-prefix #1# line-prefix #3=(space :width (- 27 (8)))) 193 198 (wrap-prefix #1# line-prefix #3#) 198 200 (wrap-prefix #1# line-prefix #3#) 200 203 (wrap-prefix #1# line-prefix #3#) 203 316 (wrap-prefix #1# line-prefix #3#) 317 349 (wrap-prefix #1# line-prefix #3#) 350 351 (erc--msg msg erc--spkr "bob" erc--ts 0 erc--cmd PRIVMSG wrap-prefix #1# line-prefix #4=(space :width (- 27 (6)))) 351 354 (wrap-prefix #1# line-prefix #4#) 354 356 (wrap-prefix #1# line-prefix #4#) 356 361 (wrap-prefix #1# line-prefix #4#) 361 436 (wrap-prefix #1# line-prefix #4#) 437 438 (erc--msg datestamp erc--ts 1680307200 field erc-timestamp) 438 455 (field erc-timestamp wrap-prefix #1# line-prefix (space :width (- 27 (18)))) 456 457 (erc--msg msg erc--spkr "bob" erc--ts 1680332400 erc--cmd PRIVMSG wrap-prefix #1# line-prefix #6=(space :width (- 27 (6)))) 457 460 (wrap-prefix #1# line-prefix #6#) 460 467 (wrap-prefix #1# line-prefix #6#) 467 468 (field erc-timestamp wrap-prefix #1# line-prefix #6#) 468 475 (field erc-timestamp wrap-prefix #1# line-prefix #6# display (#5# #("[07:00]" 0 7 (invisible timestamp)))) 476 477 (erc--msg msg erc--spkr "bob" erc--ts 1680332400 erc--cmd PRIVMSG wrap-prefix #1# line-prefix #7=(space :width (- 27 0)) display #8="") 477 480 (wrap-prefix #1# line-prefix #7# display #8#) 480 482 (wrap-prefix #1# line-prefix #7# display #8#) 482 485 (wrap-prefix #1# line-prefix #7#) 486 487 (erc--msg ctcp-action erc--spkr "bob" erc--ts 1680332400 erc--cmd PRIVMSG erc--ctcp ACTION wrap-prefix #1# line-prefix #9=(space :width (- 27 (6)))) 487 488 (wrap-prefix #1# line-prefix #9#) 488 491 (wrap-prefix #1# line-prefix #9#) 491 496 (wrap-prefix #1# line-prefix #9#) 497 498 (erc--msg msg erc--spkr "bob" erc--ts 1680332400 erc--cmd PRIVMSG wrap-prefix #1# line-prefix #10=(space :width (- 27 (6)))) 498 501 (wrap-prefix #1# line-prefix #10#) 501 507 (wrap-prefix #1# line-prefix #10#) 508 509 (erc--msg msg erc--spkr "bob" erc--ts 1680332400 erc--cmd PRIVMSG wrap-prefix #1# line-prefix #11=(space :width (- 27 0)) display #8#) 509 512 (wrap-prefix #1# line-prefix #11# display #8#) 512 514 (wrap-prefix #1# line-prefix #11# display #8#) 514 517 (wrap-prefix #1# line-prefix #11#) 518 519 (erc--msg ctcp-action erc--spkr "bob" erc--ts 1680332400 erc--cmd PRIVMSG erc--ctcp ACTION wrap-prefix #1# line-prefix #12=(space :width (- 27 (2)))) 519 520 (wrap-prefix #1# line-prefix #12#) 520 523 (wrap-prefix #1# line-prefix #12#) 523 529 (wrap-prefix #1# line-prefix #12#) 530 531 (erc--msg msg erc--spkr "bob" erc--ts 1680332400 erc--cmd PRIVMSG wrap-prefix #1# line-prefix #13=(space :width (- 27 (6)))) 531 534 (wrap-prefix #1# line-prefix #13#) 534 541 (wrap-prefix #1# line-prefix #13#)) \ No newline at end of file
diff --git a/test/lisp/erc/resources/fill/snapshots/merge-wrap-indicator-post-01.eld b/test/lisp/erc/resources/fill/snapshots/merge-wrap-indicator-post-01.eld
new file mode 100644
index 00000000000..e019e60bb26
--- /dev/null
+++ b/test/lisp/erc/resources/fill/snapshots/merge-wrap-indicator-post-01.eld
@@ -0,0 +1 @@
+#("\n\n\n[Thu Jan 1 1970]\n*** This server is in debug mode and is logging all user I/O. If you do not wish for everything you send to be readable by the server owner(s), please disconnect. [00:00]\n<alice> bob: come, you are a tedious fool: to the purpose. What was done to Elbow's wife, that he hath cause to complain of? Come me to what was done to her.\n<bob> alice: Either your unparagoned mistress is dead, or she's outprized by a trifle.\n\n[Sat Apr 1 2023]\n<bob> zero. [07:00]\n<bob> 0.5\n* bob one.\n<bob> two.\n<bob> 2.5\n* bob three\n<bob> four.\n" 2 3 (erc--msg datestamp erc--ts 0 field erc-timestamp) 3 20 (field erc-timestamp wrap-prefix #1=(space :width 27) line-prefix (space :width (- 27 (18)))) 21 22 (erc--msg notice erc--ts 0 wrap-prefix #1# line-prefix #2=(space :width (- 27 (4)))) 22 183 (wrap-prefix #1# line-prefix #2#) 183 184 (field erc-timestamp wrap-prefix #1# line-prefix #2#) 184 191 (field erc-timestamp wrap-prefix #1# line-prefix #2# display (#5=(margin right-margin) #("[00:00]" 0 7 (invisible timestamp)))) 192 193 (erc--msg msg erc--spkr "alice" erc--ts 0 erc--cmd PRIVMSG wrap-prefix #1# line-prefix #3=(space :width (- 27 (8)))) 193 198 (wrap-prefix #1# line-prefix #3#) 198 200 (wrap-prefix #1# line-prefix #3#) 200 203 (wrap-prefix #1# line-prefix #3#) 203 316 (wrap-prefix #1# line-prefix #3#) 317 349 (wrap-prefix #1# line-prefix #3#) 350 351 (erc--msg msg erc--spkr "bob" erc--ts 0 erc--cmd PRIVMSG wrap-prefix #1# line-prefix #4=(space :width (- 27 (6)))) 351 354 (wrap-prefix #1# line-prefix #4#) 354 356 (wrap-prefix #1# line-prefix #4#) 356 361 (wrap-prefix #1# line-prefix #4#) 361 436 (wrap-prefix #1# line-prefix #4#) 437 438 (erc--msg datestamp erc--ts 1680307200 field erc-timestamp) 438 455 (field erc-timestamp wrap-prefix #1# line-prefix (space :width (- 27 (18)))) 456 457 (erc--msg msg erc--spkr "bob" erc--ts 1680332400 erc--cmd PRIVMSG wrap-prefix #1# line-prefix #6=(space :width (- 27 (6)))) 457 460 (wrap-prefix #1# line-prefix #6#) 460 467 (wrap-prefix #1# line-prefix #6#) 467 468 (field erc-timestamp wrap-prefix #1# line-prefix #6#) 468 475 (field erc-timestamp wrap-prefix #1# line-prefix #6# display (#5# #("[07:00]" 0 7 (invisible timestamp)))) 476 477 (erc--msg msg erc--spkr "bob" erc--ts 1680332400 erc--cmd PRIVMSG wrap-prefix #1# line-prefix #7=(space :width (- 27 0)) display #8="") 477 480 (wrap-prefix #1# line-prefix #7# display #8#) 480 482 (wrap-prefix #1# line-prefix #7# display #8#) 482 485 (wrap-prefix #1# line-prefix #7#) 486 487 (erc--msg ctcp-action erc--spkr "bob" erc--ts 1680332400 erc--cmd PRIVMSG erc--ctcp ACTION wrap-prefix #1# line-prefix #9=(space :width (- 27 (6)))) 487 488 (wrap-prefix #1# line-prefix #9#) 488 491 (wrap-prefix #1# line-prefix #9#) 491 496 (wrap-prefix #1# line-prefix #9#) 497 498 (erc--msg msg erc--spkr "bob" erc--ts 1680332400 erc--cmd PRIVMSG wrap-prefix #1# line-prefix #10=(space :width (- 27 (6)))) 498 501 (wrap-prefix #1# line-prefix #10#) 501 507 (wrap-prefix #1# line-prefix #10#) 507 508 (display #("~\n" 0 2 (font-lock-face shadow))) 508 509 (erc--msg msg erc--spkr "bob" erc--ts 1680332400 erc--cmd PRIVMSG wrap-prefix #1# line-prefix #11=(space :width (- 27 0)) display #8#) 509 512 (wrap-prefix #1# line-prefix #11# display #8#) 512 514 (wrap-prefix #1# line-prefix #11# display #8#) 514 517 (wrap-prefix #1# line-prefix #11#) 518 519 (erc--msg ctcp-action erc--spkr "bob" erc--ts 1680332400 erc--cmd PRIVMSG erc--ctcp ACTION wrap-prefix #1# line-prefix #12=(space :width (- 27 (2)))) 519 520 (wrap-prefix #1# line-prefix #12#) 520 523 (wrap-prefix #1# line-prefix #12#) 523 529 (wrap-prefix #1# line-prefix #12#) 530 531 (erc--msg msg erc--spkr "bob" erc--ts 1680332400 erc--cmd PRIVMSG wrap-prefix #1# line-prefix #13=(space :width (- 27 (6)))) 531 534 (wrap-prefix #1# line-prefix #13#) 534 541 (wrap-prefix #1# line-prefix #13#)) \ No newline at end of file
diff --git a/test/lisp/erc/resources/fill/snapshots/merge-wrap-indicator-pre-01.eld b/test/lisp/erc/resources/fill/snapshots/merge-wrap-indicator-pre-01.eld
new file mode 100644
index 00000000000..615de982b1e
--- /dev/null
+++ b/test/lisp/erc/resources/fill/snapshots/merge-wrap-indicator-pre-01.eld
@@ -0,0 +1 @@
+#("\n\n\n[Thu Jan 1 1970]\n*** This server is in debug mode and is logging all user I/O. If you do not wish for everything you send to be readable by the server owner(s), please disconnect. [00:00]\n<alice> bob: come, you are a tedious fool: to the purpose. What was done to Elbow's wife, that he hath cause to complain of? Come me to what was done to her.\n<bob> alice: Either your unparagoned mistress is dead, or she's outprized by a trifle.\n\n[Sat Apr 1 2023]\n<bob> zero. [07:00]\n<bob> 0.5\n* bob one.\n<bob> two.\n<bob> 2.5\n* bob three\n<bob> four.\n" 2 3 (erc--msg datestamp erc--ts 0 field erc-timestamp) 3 20 (field erc-timestamp wrap-prefix #1=(space :width 27) line-prefix (space :width (- 27 (18)))) 21 22 (erc--msg notice erc--ts 0 wrap-prefix #1# line-prefix #2=(space :width (- 27 (4)))) 22 183 (wrap-prefix #1# line-prefix #2#) 183 184 (field erc-timestamp wrap-prefix #1# line-prefix #2#) 184 191 (field erc-timestamp wrap-prefix #1# line-prefix #2# display (#5=(margin right-margin) #("[00:00]" 0 7 (invisible timestamp)))) 192 193 (erc--msg msg erc--spkr "alice" erc--ts 0 erc--cmd PRIVMSG wrap-prefix #1# line-prefix #3=(space :width (- 27 (8)))) 193 198 (wrap-prefix #1# line-prefix #3#) 198 200 (wrap-prefix #1# line-prefix #3#) 200 203 (wrap-prefix #1# line-prefix #3#) 203 316 (wrap-prefix #1# line-prefix #3#) 317 349 (wrap-prefix #1# line-prefix #3#) 350 351 (erc--msg msg erc--spkr "bob" erc--ts 0 erc--cmd PRIVMSG wrap-prefix #1# line-prefix #4=(space :width (- 27 (6)))) 351 354 (wrap-prefix #1# line-prefix #4#) 354 356 (wrap-prefix #1# line-prefix #4#) 356 361 (wrap-prefix #1# line-prefix #4#) 361 436 (wrap-prefix #1# line-prefix #4#) 437 438 (erc--msg datestamp erc--ts 1680307200 field erc-timestamp) 438 455 (field erc-timestamp wrap-prefix #1# line-prefix (space :width (- 27 (18)))) 456 457 (erc--msg msg erc--spkr "bob" erc--ts 1680332400 erc--cmd PRIVMSG wrap-prefix #1# line-prefix #6=(space :width (- 27 (6)))) 457 460 (wrap-prefix #1# line-prefix #6#) 460 467 (wrap-prefix #1# line-prefix #6#) 467 468 (field erc-timestamp wrap-prefix #1# line-prefix #6#) 468 475 (field erc-timestamp wrap-prefix #1# line-prefix #6# display (#5# #("[07:00]" 0 7 (invisible timestamp)))) 476 477 (erc--msg msg erc--spkr "bob" erc--ts 1680332400 erc--cmd PRIVMSG wrap-prefix #1# line-prefix #7=(space :width (- 27 #10=(2))) display #8=#("> " 0 1 (font-lock-face shadow))) 477 480 (wrap-prefix #1# line-prefix #7# display #8#) 480 482 (wrap-prefix #1# line-prefix #7# display #8#) 482 485 (wrap-prefix #1# line-prefix #7#) 486 487 (erc--msg ctcp-action erc--spkr "bob" erc--ts 1680332400 erc--cmd PRIVMSG erc--ctcp ACTION wrap-prefix #1# line-prefix #9=(space :width (- 27 (6)))) 487 488 (wrap-prefix #1# line-prefix #9#) 488 491 (wrap-prefix #1# line-prefix #9#) 491 496 (wrap-prefix #1# line-prefix #9#) 497 498 (erc--msg msg erc--spkr "bob" erc--ts 1680332400 erc--cmd PRIVMSG wrap-prefix #1# line-prefix #11=(space :width (- 27 (6)))) 498 501 (wrap-prefix #1# line-prefix #11#) 501 507 (wrap-prefix #1# line-prefix #11#) 508 509 (erc--msg msg erc--spkr "bob" erc--ts 1680332400 erc--cmd PRIVMSG wrap-prefix #1# line-prefix #12=(space :width (- 27 #10#)) display #8#) 509 512 (wrap-prefix #1# line-prefix #12# display #8#) 512 514 (wrap-prefix #1# line-prefix #12# display #8#) 514 517 (wrap-prefix #1# line-prefix #12#) 518 519 (erc--msg ctcp-action erc--spkr "bob" erc--ts 1680332400 erc--cmd PRIVMSG erc--ctcp ACTION wrap-prefix #1# line-prefix #13=(space :width (- 27 (2)))) 519 520 (wrap-prefix #1# line-prefix #13#) 520 523 (wrap-prefix #1# line-prefix #13#) 523 529 (wrap-prefix #1# line-prefix #13#) 530 531 (erc--msg msg erc--spkr "bob" erc--ts 1680332400 erc--cmd PRIVMSG wrap-prefix #1# line-prefix #14=(space :width (- 27 (6)))) 531 534 (wrap-prefix #1# line-prefix #14#) 534 541 (wrap-prefix #1# line-prefix #14#)) \ No newline at end of file
diff --git a/test/lisp/erc/resources/fill/snapshots/monospace-01-start.eld b/test/lisp/erc/resources/fill/snapshots/monospace-01-start.eld
new file mode 100644
index 00000000000..0228e716731
--- /dev/null
+++ b/test/lisp/erc/resources/fill/snapshots/monospace-01-start.eld
@@ -0,0 +1 @@
+#("\n\n\n[Thu Jan 1 1970]\n*** This server is in debug mode and is logging all user I/O. If you do not wish for everything you send to be readable by the server owner(s), please disconnect. [00:00]\n<alice> bob: come, you are a tedious fool: to the purpose. What was done to Elbow's wife, that he hath cause to complain of? Come me to what was done to her.\n<bob> alice: Either your unparagoned mistress is dead, or she's outprized by a trifle.\n" 2 3 (erc--msg datestamp erc--ts 0 field erc-timestamp) 3 20 (field erc-timestamp wrap-prefix #1=(space :width 27) line-prefix (space :width (- 27 (18)))) 21 22 (erc--msg notice erc--ts 0 wrap-prefix #1# line-prefix #2=(space :width (- 27 (4)))) 22 183 (wrap-prefix #1# line-prefix #2#) 183 184 (field erc-timestamp wrap-prefix #1# line-prefix #2#) 184 191 (field erc-timestamp wrap-prefix #1# line-prefix #2# display ((margin right-margin) #("[00:00]" 0 7 (invisible timestamp)))) 192 193 (erc--msg msg erc--spkr "alice" erc--ts 0 erc--cmd PRIVMSG wrap-prefix #1# line-prefix #3=(space :width (- 27 (8)))) 193 198 (wrap-prefix #1# line-prefix #3#) 198 200 (wrap-prefix #1# line-prefix #3#) 200 203 (wrap-prefix #1# line-prefix #3#) 203 316 (wrap-prefix #1# line-prefix #3#) 317 349 (wrap-prefix #1# line-prefix #3#) 350 351 (erc--msg msg erc--spkr "bob" erc--ts 0 erc--cmd PRIVMSG wrap-prefix #1# line-prefix #4=(space :width (- 27 (6)))) 351 354 (wrap-prefix #1# line-prefix #4#) 354 356 (wrap-prefix #1# line-prefix #4#) 356 361 (wrap-prefix #1# line-prefix #4#) 361 436 (wrap-prefix #1# line-prefix #4#)) \ No newline at end of file
diff --git a/test/lisp/erc/resources/fill/snapshots/monospace-02-right.eld b/test/lisp/erc/resources/fill/snapshots/monospace-02-right.eld
new file mode 100644
index 00000000000..9ab89041b53
--- /dev/null
+++ b/test/lisp/erc/resources/fill/snapshots/monospace-02-right.eld
@@ -0,0 +1 @@
+#("\n\n\n[Thu Jan 1 1970]\n*** This server is in debug mode and is logging all user I/O. If you do not wish for everything you send to be readable by the server owner(s), please disconnect. [00:00]\n<alice> bob: come, you are a tedious fool: to the purpose. What was done to Elbow's wife, that he hath cause to complain of? Come me to what was done to her.\n<bob> alice: Either your unparagoned mistress is dead, or she's outprized by a trifle.\n" 2 3 (erc--msg datestamp erc--ts 0 field erc-timestamp) 3 20 (field erc-timestamp wrap-prefix #1=(space :width 29) line-prefix (space :width (- 29 (18)))) 21 22 (erc--msg notice erc--ts 0 wrap-prefix #1# line-prefix #2=(space :width (- 29 (4)))) 22 183 (wrap-prefix #1# line-prefix #2#) 183 184 (field erc-timestamp wrap-prefix #1# line-prefix #2#) 184 191 (field erc-timestamp wrap-prefix #1# line-prefix #2# display ((margin right-margin) #("[00:00]" 0 7 (invisible timestamp)))) 192 193 (erc--msg msg erc--spkr "alice" erc--ts 0 erc--cmd PRIVMSG wrap-prefix #1# line-prefix #3=(space :width (- 29 (8)))) 193 198 (wrap-prefix #1# line-prefix #3#) 198 200 (wrap-prefix #1# line-prefix #3#) 200 203 (wrap-prefix #1# line-prefix #3#) 203 316 (wrap-prefix #1# line-prefix #3#) 317 349 (wrap-prefix #1# line-prefix #3#) 350 351 (erc--msg msg erc--spkr "bob" erc--ts 0 erc--cmd PRIVMSG wrap-prefix #1# line-prefix #4=(space :width (- 29 (6)))) 351 354 (wrap-prefix #1# line-prefix #4#) 354 356 (wrap-prefix #1# line-prefix #4#) 356 361 (wrap-prefix #1# line-prefix #4#) 361 436 (wrap-prefix #1# line-prefix #4#)) \ No newline at end of file
diff --git a/test/lisp/erc/resources/fill/snapshots/monospace-03-left.eld b/test/lisp/erc/resources/fill/snapshots/monospace-03-left.eld
new file mode 100644
index 00000000000..87ea4692d9d
--- /dev/null
+++ b/test/lisp/erc/resources/fill/snapshots/monospace-03-left.eld
@@ -0,0 +1 @@
+#("\n\n\n[Thu Jan 1 1970]\n*** This server is in debug mode and is logging all user I/O. If you do not wish for everything you send to be readable by the server owner(s), please disconnect. [00:00]\n<alice> bob: come, you are a tedious fool: to the purpose. What was done to Elbow's wife, that he hath cause to complain of? Come me to what was done to her.\n<bob> alice: Either your unparagoned mistress is dead, or she's outprized by a trifle.\n" 2 3 (erc--msg datestamp erc--ts 0 field erc-timestamp) 3 20 (field erc-timestamp wrap-prefix #1=(space :width 25) line-prefix (space :width (- 25 (18)))) 21 22 (erc--msg notice erc--ts 0 wrap-prefix #1# line-prefix #2=(space :width (- 25 (4)))) 22 183 (wrap-prefix #1# line-prefix #2#) 183 184 (field erc-timestamp wrap-prefix #1# line-prefix #2#) 184 191 (field erc-timestamp wrap-prefix #1# line-prefix #2# display ((margin right-margin) #("[00:00]" 0 7 (invisible timestamp)))) 192 193 (erc--msg msg erc--spkr "alice" erc--ts 0 erc--cmd PRIVMSG wrap-prefix #1# line-prefix #3=(space :width (- 25 (8)))) 193 198 (wrap-prefix #1# line-prefix #3#) 198 200 (wrap-prefix #1# line-prefix #3#) 200 203 (wrap-prefix #1# line-prefix #3#) 203 316 (wrap-prefix #1# line-prefix #3#) 317 349 (wrap-prefix #1# line-prefix #3#) 350 351 (erc--msg msg erc--spkr "bob" erc--ts 0 erc--cmd PRIVMSG wrap-prefix #1# line-prefix #4=(space :width (- 25 (6)))) 351 354 (wrap-prefix #1# line-prefix #4#) 354 356 (wrap-prefix #1# line-prefix #4#) 356 361 (wrap-prefix #1# line-prefix #4#) 361 436 (wrap-prefix #1# line-prefix #4#)) \ No newline at end of file
diff --git a/test/lisp/erc/resources/fill/snapshots/monospace-04-reset.eld b/test/lisp/erc/resources/fill/snapshots/monospace-04-reset.eld
new file mode 100644
index 00000000000..0228e716731
--- /dev/null
+++ b/test/lisp/erc/resources/fill/snapshots/monospace-04-reset.eld
@@ -0,0 +1 @@
+#("\n\n\n[Thu Jan 1 1970]\n*** This server is in debug mode and is logging all user I/O. If you do not wish for everything you send to be readable by the server owner(s), please disconnect. [00:00]\n<alice> bob: come, you are a tedious fool: to the purpose. What was done to Elbow's wife, that he hath cause to complain of? Come me to what was done to her.\n<bob> alice: Either your unparagoned mistress is dead, or she's outprized by a trifle.\n" 2 3 (erc--msg datestamp erc--ts 0 field erc-timestamp) 3 20 (field erc-timestamp wrap-prefix #1=(space :width 27) line-prefix (space :width (- 27 (18)))) 21 22 (erc--msg notice erc--ts 0 wrap-prefix #1# line-prefix #2=(space :width (- 27 (4)))) 22 183 (wrap-prefix #1# line-prefix #2#) 183 184 (field erc-timestamp wrap-prefix #1# line-prefix #2#) 184 191 (field erc-timestamp wrap-prefix #1# line-prefix #2# display ((margin right-margin) #("[00:00]" 0 7 (invisible timestamp)))) 192 193 (erc--msg msg erc--spkr "alice" erc--ts 0 erc--cmd PRIVMSG wrap-prefix #1# line-prefix #3=(space :width (- 27 (8)))) 193 198 (wrap-prefix #1# line-prefix #3#) 198 200 (wrap-prefix #1# line-prefix #3#) 200 203 (wrap-prefix #1# line-prefix #3#) 203 316 (wrap-prefix #1# line-prefix #3#) 317 349 (wrap-prefix #1# line-prefix #3#) 350 351 (erc--msg msg erc--spkr "bob" erc--ts 0 erc--cmd PRIVMSG wrap-prefix #1# line-prefix #4=(space :width (- 27 (6)))) 351 354 (wrap-prefix #1# line-prefix #4#) 354 356 (wrap-prefix #1# line-prefix #4#) 356 361 (wrap-prefix #1# line-prefix #4#) 361 436 (wrap-prefix #1# line-prefix #4#)) \ No newline at end of file
diff --git a/test/lisp/erc/resources/fill/snapshots/spacing-01-mono.eld b/test/lisp/erc/resources/fill/snapshots/spacing-01-mono.eld
new file mode 100644
index 00000000000..ae364accdea
--- /dev/null
+++ b/test/lisp/erc/resources/fill/snapshots/spacing-01-mono.eld
@@ -0,0 +1 @@
+#("\n\n\n[Thu Jan 1 1970]\n*** This server is in debug mode and is logging all user I/O. If you do not wish for everything you send to be readable by the server owner(s), please disconnect. [00:00]\n<alice> bob: come, you are a tedious fool: to the purpose. What was done to Elbow's wife, that he hath cause to complain of? Come me to what was done to her.\n<bob> alice: Either your unparagoned mistress is dead, or she's outprized by a trifle.\n<bob> This buffer is for text.\n*** one two three\n*** four five six\n<bob> Somebody stop me\n" 2 3 (erc--msg datestamp erc--ts 0 field erc-timestamp) 3 20 (field erc-timestamp wrap-prefix #1=(space :width 27) line-prefix (space :width (- 27 (18)))) 21 22 (erc--msg notice erc--ts 0 wrap-prefix #1# line-prefix #2=(space :width (- 27 (4)))) 22 183 (wrap-prefix #1# line-prefix #2#) 183 184 (field erc-timestamp wrap-prefix #1# line-prefix #2#) 184 191 (field erc-timestamp wrap-prefix #1# line-prefix #2# display ((margin right-margin) #("[00:00]" 0 7 (invisible timestamp)))) 191 192 (line-spacing 0.5) 192 193 (erc--msg msg erc--spkr "alice" erc--ts 0 erc--cmd PRIVMSG wrap-prefix #1# line-prefix #3=(space :width (- 27 (8)))) 193 198 (wrap-prefix #1# line-prefix #3#) 198 200 (wrap-prefix #1# line-prefix #3#) 200 203 (wrap-prefix #1# line-prefix #3#) 203 316 (wrap-prefix #1# line-prefix #3#) 317 349 (wrap-prefix #1# line-prefix #3#) 349 350 (line-spacing 0.5) 350 351 (erc--msg msg erc--spkr "bob" erc--ts 0 erc--cmd PRIVMSG wrap-prefix #1# line-prefix #4=(space :width (- 27 (6)))) 351 354 (wrap-prefix #1# line-prefix #4#) 354 356 (wrap-prefix #1# line-prefix #4#) 356 361 (wrap-prefix #1# line-prefix #4#) 361 436 (wrap-prefix #1# line-prefix #4#) 436 437 (line-spacing 0.5) 437 438 (erc--msg msg erc--spkr "bob" erc--ts 0 erc--cmd PRIVMSG wrap-prefix #1# line-prefix #5=(space :width (- 27 0)) display #6="") 438 441 (wrap-prefix #1# line-prefix #5# display #6#) 441 443 (wrap-prefix #1# line-prefix #5# display #6#) 443 467 (wrap-prefix #1# line-prefix #5#) 467 468 (line-spacing 0.5) 468 469 (erc--msg notice erc--ts 0 wrap-prefix #1# line-prefix #7=(space :width (- 27 (4)))) 469 485 (wrap-prefix #1# line-prefix #7#) 486 487 (erc--msg notice erc--ts 0 wrap-prefix #1# line-prefix #8=(space :width (- 27 (4)))) 487 503 (wrap-prefix #1# line-prefix #8#) 503 504 (line-spacing 0.5) 504 505 (erc--msg msg erc--spkr "bob" erc--ts 0 erc--cmd PRIVMSG wrap-prefix #1# line-prefix #9=(space :width (- 27 (6)))) 505 508 (wrap-prefix #1# line-prefix #9#) 508 526 (wrap-prefix #1# line-prefix #9#)) \ No newline at end of file
diff --git a/test/lisp/erc/resources/fill/snapshots/stamps-left-01.eld b/test/lisp/erc/resources/fill/snapshots/stamps-left-01.eld
new file mode 100644
index 00000000000..1b22b6c5cfd
--- /dev/null
+++ b/test/lisp/erc/resources/fill/snapshots/stamps-left-01.eld
@@ -0,0 +1 @@
+#("\n\n[00:00]*** This server is in debug mode and is logging all user I/O. If you do not wish for everything you send to be readable by the server owner(s), please disconnect.\n[00:00]<alice> bob: come, you are a tedious fool: to the purpose. What was done to Elbow's wife, that he hath cause to complain of? Come me to what was done to her.\n[00:00]<bob> alice: Either your unparagoned mistress is dead, or she's outprized by a trifle.\n" 2 3 (erc--msg notice erc--ts 0 display #3=(#5=(margin left-margin) #("[00:00]" 0 7 (invisible timestamp font-lock-face erc-timestamp-face))) field erc-timestamp wrap-prefix #1=(space :width 27) line-prefix #2=(space :width (- 27 (4)))) 3 9 (display #3# field erc-timestamp wrap-prefix #1# line-prefix #2#) 9 171 (wrap-prefix #1# line-prefix #2#) 172 173 (erc--msg msg erc--ts 0 erc--spkr "alice" erc--cmd PRIVMSG display #6=(#5# #("[00:00]" 0 7 (invisible timestamp font-lock-face erc-timestamp-face))) field erc-timestamp wrap-prefix #1# line-prefix #4=(space :width (- 27 (8)))) 173 179 (display #6# field erc-timestamp wrap-prefix #1# line-prefix #4#) 179 180 (wrap-prefix #1# line-prefix #4#) 180 185 (wrap-prefix #1# line-prefix #4#) 185 187 (wrap-prefix #1# line-prefix #4#) 187 190 (wrap-prefix #1# line-prefix #4#) 190 303 (wrap-prefix #1# line-prefix #4#) 304 336 (wrap-prefix #1# line-prefix #4#) 337 338 (erc--msg msg erc--ts 0 erc--spkr "bob" erc--cmd PRIVMSG display #8=(#5# #("[00:00]" 0 7 (invisible timestamp font-lock-face erc-timestamp-face))) field erc-timestamp wrap-prefix #1# line-prefix #7=(space :width (- 27 (6)))) 338 344 (display #8# field erc-timestamp wrap-prefix #1# line-prefix #7#) 344 345 (wrap-prefix #1# line-prefix #7#) 345 348 (wrap-prefix #1# line-prefix #7#) 348 350 (wrap-prefix #1# line-prefix #7#) 350 355 (wrap-prefix #1# line-prefix #7#) 355 430 (wrap-prefix #1# line-prefix #7#)) \ No newline at end of file
diff --git a/test/lisp/erc/resources/join/buffer-display/mode-context.eld b/test/lisp/erc/resources/join/buffer-display/mode-context.eld
new file mode 100644
index 00000000000..6ebbdc7e824
--- /dev/null
+++ b/test/lisp/erc/resources/join/buffer-display/mode-context.eld
@@ -0,0 +1,38 @@
+;; -*- mode: lisp-data; -*-
+((nick 1 "NICK tester"))
+((user 1 "USER user 0 * :tester")
+ (0.00 ":irc.foonet.org 001 tester :Welcome to the foonet IRC Network tester")
+ (0.01 ":irc.foonet.org 002 tester :Your host is irc.foonet.org, running version ergo-v2.8.0")
+ (0.00 ":irc.foonet.org 003 tester :This server was created Tue, 24 May 2022 05:28:42 UTC")
+ (0.00 ":irc.foonet.org 004 tester irc.foonet.org ergo-v2.8.0 BERTZios CEIMRUabefhiklmnoqstuv Iabefhkloqv")
+ (0.00 ":irc.foonet.org 005 tester AWAYLEN=390 BOT=B CASEMAPPING=ascii CHANLIMIT=#:100 CHANMODES=Ibe,k,fl,CEMRUimnstu CHANNELLEN=64 CHANTYPES=# ELIST=U EXCEPTS EXTBAN=,m FORWARD=f INVEX KICKLEN=390 :are supported by this server")
+ (0.01 ":irc.foonet.org 005 tester MAXLIST=beI:60 MAXTARGETS=4 MODES MONITOR=100 NETWORK=foonet NICKLEN=32 PREFIX=(qaohv)~&@%+ STATUSMSG=~&@%+ TARGMAX=NAMES:1,LIST:1,KICK:,WHOIS:1,USERHOST:10,PRIVMSG:4,TAGMSG:4,NOTICE:4,MONITOR:100 TOPICLEN=390 UTF8MAPPING=rfc8265 UTF8ONLY WHOX :are supported by this server")
+ (0.01 ":irc.foonet.org 005 tester draft/CHATHISTORY=100 :are supported by this server")
+ (0.00 ":irc.foonet.org 251 tester :There are 0 users and 4 invisible on 1 server(s)")
+ (0.00 ":irc.foonet.org 252 tester 0 :IRC Operators online")
+ (0.00 ":irc.foonet.org 253 tester 0 :unregistered connections")
+ (0.00 ":irc.foonet.org 254 tester 2 :channels formed")
+ (0.00 ":irc.foonet.org 255 tester :I have 4 clients and 0 servers")
+ (0.00 ":irc.foonet.org 265 tester 4 4 :Current local users 4, max 4")
+ (0.00 ":irc.foonet.org 266 tester 4 4 :Current global users 4, max 4")
+ (0.00 ":irc.foonet.org 422 tester :MOTD File is missing"))
+
+((mode 6 "MODE tester +i")
+ (0.00 ":irc.foonet.org 221 tester +i")
+ (0.00 ":irc.foonet.org NOTICE tester :This server is in debug mode and is logging all user I/O. If you do not wish for everything you send to be readable by the server owner(s), please disconnect.")
+ (0.02 ":irc.foonet.org 221 tester +i"))
+
+((join-chan 10 "JOIN #chan")
+ (0.03 ":tester!~u@w9rfqveugz722.irc JOIN #chan"))
+
+((~mode-chan 10 "MODE #chan")
+ (0.01 ":irc.foonet.org 353 tester = #chan :@tester")
+ (0.00 ":irc.foonet.org 366 tester #chan :End of NAMES list")
+ (0.01 ":irc.foonet.org 324 tester #chan +nt")
+ (0.03 ":irc.foonet.org 329 tester #chan 1653370308"))
+
+((~join-spam 10 "JOIN #spam")
+ (0.03 ":irc.foonet.org 471 tester #spam :Cannot join channel (+l)"))
+
+((~join-foo 10 "JOIN #foo")
+ (0.03 ":irc.foonet.org 473 tester #foo :Cannot join channel (+i)"))
diff --git a/test/lisp/erc/resources/join/legacy/foonet.eld b/test/lisp/erc/resources/join/legacy/foonet.eld
index 4025094a59c..5c0ea13b6a7 100644
--- a/test/lisp/erc/resources/join/legacy/foonet.eld
+++ b/test/lisp/erc/resources/join/legacy/foonet.eld
@@ -18,7 +18,7 @@
(0 ":irc.foonet.org 266 tester 3 3 :Current global users 3, max 3")
(0 ":irc.foonet.org 422 tester :MOTD File is missing"))
-((mode-user 3.2 "MODE tester +i")
+((mode-user 10 "MODE tester +i")
(0 ":irc.foonet.org 221 tester +i")
(0 ":irc.foonet.org NOTICE tester :This server is in debug mode and is logging all user I/O. If you do not wish for everything you send to be readable by the server owner(s), please disconnect."))
diff --git a/test/lisp/erc/resources/join/network-id/barnet.eld b/test/lisp/erc/resources/join/network-id/barnet.eld
index e33dd6be29e..ad6a7c820a9 100644
--- a/test/lisp/erc/resources/join/network-id/barnet.eld
+++ b/test/lisp/erc/resources/join/network-id/barnet.eld
@@ -40,4 +40,4 @@
(0.05 ":mike!~u@6yximxrnkg65a.irc PRIVMSG #chan :joe: And now, dear maid, be you as free to us.")
(0.00 ":joe!~u@6yximxrnkg65a.irc PRIVMSG #chan :mike: He hath an uncle here in Messina will be very much glad of it."))
-((linger 3.5 LINGER))
+((linger 30 LINGER))
diff --git a/test/lisp/erc/resources/join/network-id/foonet-again.eld b/test/lisp/erc/resources/join/network-id/foonet-again.eld
index b230eff27c7..a8b8a52f87a 100644
--- a/test/lisp/erc/resources/join/network-id/foonet-again.eld
+++ b/test/lisp/erc/resources/join/network-id/foonet-again.eld
@@ -43,4 +43,4 @@
(0.1 ":bob!~u@q6ddatxcq6txy.irc PRIVMSG #chan :alice: But we are spirits of another sort.")
(0.1 ":alice!~u@q6ddatxcq6txy.irc PRIVMSG #chan :bob: It was not given me, nor I did not buy it."))
-((linger 6 LINGER))
+((linger 30 LINGER))
diff --git a/test/lisp/erc/resources/join/network-id/foonet.eld b/test/lisp/erc/resources/join/network-id/foonet.eld
index 7d63f5f0c6c..74a107f8144 100644
--- a/test/lisp/erc/resources/join/network-id/foonet.eld
+++ b/test/lisp/erc/resources/join/network-id/foonet.eld
@@ -1,8 +1,8 @@
;; -*- mode: lisp-data; -*-
((pass 10 "PASS :foonet:changeme"))
-((nick 1 "NICK tester"))
+((nick 10 "NICK tester"))
-((user 1 "USER user 0 * :tester")
+((user 10 "USER user 0 * :tester")
(0 ":irc.foonet.org 001 tester :Welcome to the foonet IRC Network tester")
(0 ":irc.foonet.org 002 tester :Your host is irc.foonet.org, running version oragono-2.6.0-7481bf0385b95b16")
(0 ":irc.foonet.org 003 tester :This server was created Mon, 10 May 2021 00:58:22 UTC")
diff --git a/test/lisp/erc/resources/keep-place/follow.eld b/test/lisp/erc/resources/keep-place/follow.eld
new file mode 100644
index 00000000000..db9352d93be
--- /dev/null
+++ b/test/lisp/erc/resources/keep-place/follow.eld
@@ -0,0 +1,78 @@
+;; -*- mode: lisp-data; -*-
+((nick 10 "NICK tester"))
+((user 10 "USER tester 0 * :tester")
+ (0.00 ":irc.foonet.org 001 tester :Welcome to the foonet IRC Network tester")
+ (0.01 ":irc.foonet.org 002 tester :Your host is irc.foonet.org, running version ergo-v2.11.1")
+ (0.01 ":irc.foonet.org 003 tester :This server was created Tue, 26 Dec 2023 08:36:35 UTC")
+ (0.01 ":irc.foonet.org 004 tester irc.foonet.org ergo-v2.11.1 BERTZios CEIMRUabefhiklmnoqstuv Iabefhkloqv")
+ (0.00 ":irc.foonet.org 005 tester AWAYLEN=390 BOT=B CASEMAPPING=ascii CHANLIMIT=#:100 CHANMODES=Ibe,k,fl,CEMRUimnstu CHANNELLEN=64 CHANTYPES=# CHATHISTORY=1000 ELIST=U EXCEPTS EXTBAN=,m FORWARD=f INVEX :are supported by this server")
+ (0.01 ":irc.foonet.org 005 tester KICKLEN=390 MAXLIST=beI:60 MAXTARGETS=4 MODES MONITOR=100 NETWORK=foonet NICKLEN=32 PREFIX=(qaohv)~&@%+ STATUSMSG=~&@%+ TARGMAX=NAMES:1,LIST:1,KICK:,WHOIS:1,USERHOST:10,PRIVMSG:4,TAGMSG:4,NOTICE:4,MONITOR:100 TOPICLEN=390 UTF8ONLY WHOX :are supported by this server")
+ (0.01 ":irc.foonet.org 005 tester draft/CHATHISTORY=1000 :are supported by this server")
+ (0.01 ":irc.foonet.org 251 tester :There are 0 users and 4 invisible on 1 server(s)")
+ (0.01 ":irc.foonet.org 252 tester 0 :IRC Operators online")
+ (0.00 ":irc.foonet.org 253 tester 0 :unregistered connections")
+ (0.00 ":irc.foonet.org 254 tester 2 :channels formed")
+ (0.00 ":irc.foonet.org 255 tester :I have 4 clients and 0 servers")
+ (0.00 ":irc.foonet.org 265 tester 4 4 :Current local users 4, max 4")
+ (0.00 ":irc.foonet.org 266 tester 4 4 :Current global users 4, max 4")
+ (0.03 ":irc.foonet.org 422 tester :MOTD File is missing")
+ (0.01 ":irc.foonet.org NOTICE tester :This server is in debug mode and is logging all user I/O. If you do not wish for everything you send to be readable by the server owner(s), please disconnect."))
+
+((mode 10 "MODE tester +i"))
+
+((join 10 "JOIN #chan")
+ (0.01 ":irc.foonet.org 221 tester +i")
+ (0.01 ":tester!~u@p64eqfwvvbxrk.irc JOIN #chan")
+ (0.03 ":irc.foonet.org 353 tester = #chan :@fsbot bob alice tester")
+ (0.01 ":irc.foonet.org 366 tester #chan :End of NAMES list")
+ (0.00 ":bob!~u@2q6ysndq32az6.irc PRIVMSG #chan :tester, welcome!")
+ (0.01 ":alice!~u@2q6ysndq32az6.irc PRIVMSG #chan :tester, welcome!"))
+
+((join 10 "JOIN #spam")
+ (0.00 ":tester!~u@p64eqfwvvbxrk.irc JOIN #spam")
+ (0.06 ":irc.foonet.org 353 tester = #spam :@fsbot bob alice tester")
+ (0.01 ":irc.foonet.org 366 tester #spam :End of NAMES list")
+ (0.03 ":alice!~u@2q6ysndq32az6.irc PRIVMSG #spam :tester, welcome!")
+ (0.01 ":bob!~u@2q6ysndq32az6.irc PRIVMSG #spam :tester, welcome!"))
+
+((mode 10 "MODE #chan")
+ (0.00 ":irc.foonet.org 324 tester #chan +Cnt")
+ (0.02 ":irc.foonet.org 329 tester #chan 1703579802")
+ (0.02 ":alice!~u@2q6ysndq32az6.irc PRIVMSG #chan :bob: Madam, my lord is gone, for ever gone.")
+ (0.10 ":alice!~u@2q6ysndq32az6.irc PRIVMSG #chan :The kinder we, to give them thanks for nothing."))
+
+((mode 10 "MODE #spam")
+ (0.00 ":irc.foonet.org 324 tester #spam +Cnt")
+ (0.02 ":irc.foonet.org 329 tester #spam 1703579805")
+ (0.02 ":bob!~u@2q6ysndq32az6.irc PRIVMSG #chan :Most manifest, and not denied by himself.")
+ (0.02 ":bob!~u@2q6ysndq32az6.irc PRIVMSG #chan :alice: To bed, to bed: there's knocking at the gate. Come, come, come, come, give me your hand. What's done cannot be undone.")
+ (0.02 ":alice!~u@2q6ysndq32az6.irc PRIVMSG #chan :bob: And what I spake, I spake it to my face.")
+ (0.08 ":bob!~u@2q6ysndq32az6.irc PRIVMSG #chan :alice: Since you can cog, I'll play no more with you.")
+ (0.06 ":alice!~u@2q6ysndq32az6.irc PRIVMSG #chan :bob: The little casket bring me hither.")
+ (0.01 ":bob!~u@2q6ysndq32az6.irc PRIVMSG #chan :alice: Not to-night, good Iago: I have very poor and unhappy brains for drinking: I could well wish courtesy would invent some other custom of entertainment.")
+ (0.02 ":alice!~u@2q6ysndq32az6.irc PRIVMSG #chan :Yes, faith will I, Fridays and Saturdays and all."))
+
+((privmsg 10 "PRIVMSG #spam :one")
+ (0.03 ":alice!~u@2q6ysndq32az6.irc PRIVMSG #chan :bob: This is the first truth that e'er thine own tongue was guilty of.")
+ (0.02 ":bob!~u@2q6ysndq32az6.irc PRIVMSG #chan :alice: Drown the lamenting fool in sea-salt tears.")
+
+ ;; Insert some lines ^ before rendezvous, so #chan can update scrolltobottom.
+ (0.01 ":bob!~u@2q6ysndq32az6.irc PRIVMSG #spam :Ay, the heads of the maids, or their maidenheads; take it in what sense thou wilt.")
+
+ (0.05 ":bob!~u@2q6ysndq32az6.irc PRIVMSG #chan :alice: And work confusion on his enemies.")
+ (0.06 ":alice!~u@2q6ysndq32az6.irc PRIVMSG #chan :bob: Truly, she must be given, or the marriage is not lawful."))
+
+((privmsg 10 "PRIVMSG #spam :two")
+ (0.02 ":bob!~u@2q6ysndq32az6.irc PRIVMSG #chan :To be whipped; and yet a better love than my master.")
+ (0.06 ":alice!~u@2q6ysndq32az6.irc PRIVMSG #chan :And duty in his service perishing.")
+
+ ;; Second check point.
+ (0.01 ":bob!~u@2q6ysndq32az6.irc PRIVMSG #spam :Cause they take vengeance of such kind of men.")
+
+ (0.03 ":bob!~u@2q6ysndq32az6.irc PRIVMSG #chan :alice: No egma, no riddle, no l'envoy; no salve in the mail, sir. O! sir, plantain, a plain plantain: no l'envoy, no l'envoy: no salve, sir, but a plantain.")
+ (0.03 ":alice!~u@2q6ysndq32az6.irc PRIVMSG #chan :Signior Iachimo will not from it. Pray, let us follow 'em."))
+
+((privmsg 10 "PRIVMSG #spam :three")
+ ;; Third check point.
+ (0.01 ":bob!~u@2q6ysndq32az6.irc PRIVMSG #spam :Moved.")
+ (0.01 ":bob!~u@2q6ysndq32az6.irc PRIVMSG #chan :Ready."))
diff --git a/test/lisp/erc/resources/match/fools/fill-wrap.eld b/test/lisp/erc/resources/match/fools/fill-wrap.eld
new file mode 100644
index 00000000000..dff75ef9cd2
--- /dev/null
+++ b/test/lisp/erc/resources/match/fools/fill-wrap.eld
@@ -0,0 +1,41 @@
+;; -*- mode: lisp-data; -*-
+((pass 10 "PASS :changeme"))
+((nick 1 "NICK tester"))
+((user 1 "USER user 0 * :tester")
+ (0 ":irc.foonet.org 001 tester :Welcome to the foonet IRC Network tester")
+ (0 ":irc.foonet.org 002 tester :Your host is irc.foonet.org, running version oragono-2.6.0-7481bf0385b95b16")
+ (0 ":irc.foonet.org 003 tester :This server was created Tue, 04 May 2021 05:06:18 UTC")
+ (0 ":irc.foonet.org 004 tester irc.foonet.org oragono-2.6.0-7481bf0385b95b16 BERTZios CEIMRUabefhiklmnoqstuv Iabefhkloqv")
+ (0 ":irc.foonet.org 005 tester AWAYLEN=390 BOT=B CASEMAPPING=ascii CHANLIMIT=#:100 CHANMODES=Ibe,k,fl,CEMRUimnstu CHANNELLEN=64 CHANTYPES=# ELIST=U EXCEPTS EXTBAN=,m FORWARD=f INVEX KICKLEN=390 :are supported by this server")
+ (0 ":irc.foonet.org 005 tester MAXLIST=beI:60 MAXTARGETS=4 MODES MONITOR=100 NETWORK=FooNet NICKLEN=32 PREFIX=(qaohv)~&@%+ STATUSMSG=~&@%+ TARGMAX=NAMES:1,LIST:1,KICK:1,WHOIS:1,USERHOST:10,PRIVMSG:4,TAGMSG:4,NOTICE:4,MONITOR:100 TOPICLEN=390 UTF8MAPPING=rfc8265 UTF8ONLY WHOX :are supported by this server")
+ (0 ":irc.foonet.org 005 tester draft/CHATHISTORY=100 :are supported by this server")
+ (0 ":irc.foonet.org 251 tester :There are 0 users and 3 invisible on 1 server(s)")
+ (0 ":irc.foonet.org 252 tester 0 :IRC Operators online")
+ (0 ":irc.foonet.org 253 tester 0 :unregistered connections")
+ (0 ":irc.foonet.org 254 tester 1 :channels formed")
+ (0 ":irc.foonet.org 255 tester :I have 3 clients and 0 servers")
+ (0 ":irc.foonet.org 265 tester 3 3 :Current local users 3, max 3")
+ (0 ":irc.foonet.org 266 tester 3 3 :Current global users 3, max 3")
+ (0 ":irc.foonet.org 422 tester :MOTD File is missing"))
+
+((mode-user 10 "MODE tester +i")
+ (0 ":irc.foonet.org 221 tester +i")
+ (0 ":irc.foonet.org NOTICE tester :This server is in debug mode and is logging all user I/O. If you do not wish for everything you send to be readable by the server owner(s), please disconnect."))
+
+((join 6 "JOIN #chan")
+ (0 ":tester!~u@9g6b728983yd2.irc JOIN #chan")
+ (0 ":irc.foonet.org 353 tester = #chan :alice tester @bob")
+ (0 ":irc.foonet.org 366 tester #chan :End of NAMES list"))
+
+((mode 5 "MODE #chan")
+ (0 ":irc.foonet.org 324 tester #chan +nt")
+ (0 ":irc.foonet.org 329 tester #chan 1620104779")
+ (0.1 ":bob!~u@rz2v467q4rwhy.irc PRIVMSG #chan :tester, welcome!")
+ (0 ":alice!~u@rz2v467q4rwhy.irc PRIVMSG #chan :None better than to let him fetch off his drum, which you hear him so confidently undertake to do.")
+ (0 ":alice!~u@rz2v467q4rwhy.irc PRIVMSG #chan :bob: Still we went coupled and inseparable.")
+ (0 ":bob!~u@rz2v467q4rwhy.irc PRIVMSG #chan :alice: Give me your hand. This hand is moist, my lady."))
+
+((privmsg 5 "PRIVMSG #chan :hey")
+ (0 ":bob!~u@rz2v467q4rwhy.irc PRIVMSG #chan :You have paid the heavens your function, and the prisoner the very debt of your calling. I have laboured for the poor gentleman to the extremest shore of my modesty; but my brother justice have I found so severe, that he hath forced me to tell him he is indeed Justice.")
+ (0 ":alice!~u@rz2v467q4rwhy.irc PRIVMSG #chan :bob: In the sick air: let not thy sword skip one.")
+ (0 ":alice!~u@rz2v467q4rwhy.irc PRIVMSG #chan :The web of our life is of a mingled yarn, good and ill together: our virtues would be proud if our faults whipped them not; and our crimes would despair if they were not cherished by our virtues."))
diff --git a/test/lisp/erc/resources/sasl/plain-failed.eld b/test/lisp/erc/resources/sasl/plain-failed.eld
index 336700290c5..47d13de18e5 100644
--- a/test/lisp/erc/resources/sasl/plain-failed.eld
+++ b/test/lisp/erc/resources/sasl/plain-failed.eld
@@ -1,16 +1,16 @@
;; -*- mode: lisp-data; -*-
((cap-req 10 "CAP REQ :sasl"))
-((nick 1 "NICK tester"))
-((user 1 "USER tester 0 * :tester")
+((nick 10 "NICK tester"))
+((user 10 "USER tester 0 * :tester")
(0.0 ":irc.foonet.org NOTICE * :*** Looking up your hostname...")
(0.0 ":irc.foonet.org NOTICE * :*** Found your hostname")
(0.0 ":irc.foonet.org CAP * ACK :cap-notify sasl"))
-((authenticate-plain 3.2 "AUTHENTICATE PLAIN")
+((authenticate-plain 10 "AUTHENTICATE PLAIN")
(0.0 ":irc.foonet.org AUTHENTICATE +"))
-((authenticate-gimme 3.2 "AUTHENTICATE AHRlc3RlcgB3cm9uZw==")
+((authenticate-gimme 10 "AUTHENTICATE AHRlc3RlcgB3cm9uZw==")
(0.0 ":irc.foonet.org 900 * * tester :You are now logged in as tester")
(0.0 ":irc.foonet.org 904 * :SASL authentication failed: Invalid account credentials"))
-((cap-end 3.2 "CAP END"))
+((eof 10 EOF))
diff --git a/test/lisp/erc/resources/sasl/plain-overlong-aligned.eld b/test/lisp/erc/resources/sasl/plain-overlong-aligned.eld
new file mode 100644
index 00000000000..6ed8981be0f
--- /dev/null
+++ b/test/lisp/erc/resources/sasl/plain-overlong-aligned.eld
@@ -0,0 +1,39 @@
+;; -*- mode: lisp-data; -*-
+((cap-req 10 "CAP REQ :sasl"))
+((nick 10 "NICK emersion"))
+((user 10 "USER emersion 0 * :emersion")
+ (0.0 ":irc.example.org NOTICE * :*** Looking up your hostname...")
+ (0.0 ":irc.example.org NOTICE * :*** Found your hostname")
+ (0.0 ":irc.example.org CAP * ACK :sasl"))
+
+((authenticate-plain 10 "AUTHENTICATE PLAIN")
+ (0.0 ":irc.example.org AUTHENTICATE +"))
+((authenticate-gimme-1 10 "AUTHENTICATE AGVtZXJzaW9uAEVzdCB1dCBiZWF0YWUgb21uaXMgaXBzYW0uIFF1aXMgZnVnaWF0IGRlbGVuaXRpIHRvdGFtIHF1aS4gSXBzdW0gcXVhbSBhIGRvbG9ydW0gdGVtcG9yYSB2ZWxpdCBsYWJvcnVtIG9kaXQuIEV0IHNhZXBlIHZvbHVwdGF0ZSBzZWQgY3VtcXVlIHZlbC4gVm9sdXB0YXMgc2ludCBhYiBwYXJpYXR1ciBsaWJlcm8gdmVyaXRhdGlzIGNvcnJ1cHRpLiBWZXJvIGl1cmUgb21uaXMgdWxsYW0uIFZlcm8gYmVhdGFlIGRvbG9yZXMgZmFjZXJlIGZ1Z2lhdCBpcHNhbS4gRWEgZXN0IHBhcmlhdHVyIG1pbmltYSBub2Jpcw=="))
+((authenticate-gimme-2 10 "AUTHENTICATE +")
+ (0.0 ":irc.example.org 900 * * emersion :You are now logged in as emersion")
+ (0.0 ":irc.example.org 903 * :Authentication successful"))
+
+((cap-end 10 "CAP END")
+ (0.0 ":irc.example.org 001 emersion :Welcome to the ExampleOrg IRC Network emersion")
+ (0.0 ":irc.example.org 002 emersion :Your host is irc.example.org, running version oragono-2.6.1")
+ (0.0 ":irc.example.org 003 emersion :This server was created Sat, 17 Jul 2021 09:06:42 UTC")
+ (0.0 ":irc.example.org 004 emersion irc.example.org oragono-2.6.1 BERTZios CEIMRUabefhiklmnoqstuv Iabefhkloqv")
+ (0.0 ":irc.example.org 005 emersion AWAYLEN=200 BOT=B CASEMAPPING=ascii CHANLIMIT=#:100 CHANMODES=Ibe,k,fl,CEMRUimnstu CHANNELLEN=64 CHANTYPES=# ELIST=U EXCEPTS EXTBAN=,m FORWARD=f INVEX KICKLEN=390 :are supported by this server")
+ (0.0 ":irc.example.org 005 emersion MAXLIST=beI:60 MAXTARGETS=4 MODES MONITOR=100 NETWORK=ExampleOrg NICKLEN=32 PREFIX=(qaohv)~&@%+ STATUSMSG=~&@%+ TARGMAX=NAMES:1,LIST:1,KICK:1,WHOIS:1,USERHOST:10,PRIVMSG:4,TAGMSG:4,NOTICE:4,MONITOR:100 TOPICLEN=390 UTF8MAPPING=rfc8265 UTF8ONLY :are supported by this server")
+ (0.0 ":irc.example.org 005 emersion draft/CHATHISTORY=100 :are supported by this server")
+ (0.0 ":irc.example.org 251 emersion :There are 1 users and 0 invisible on 1 server(s)")
+ (0.0 ":irc.example.org 252 emersion 0 :IRC Operators online")
+ (0.0 ":irc.example.org 253 emersion 0 :unregistered connections")
+ (0.0 ":irc.example.org 254 emersion 0 :channels formed")
+ (0.0 ":irc.example.org 255 emersion :I have 1 clients and 0 servers")
+ (0.0 ":irc.example.org 265 emersion 1 1 :Current local users 1, max 1")
+ (0.0 ":irc.example.org 266 emersion 1 1 :Current global users 1, max 1")
+ (0.0 ":irc.example.org 422 emersion :MOTD File is missing"))
+
+((mode-user 10 "MODE emersion +i")
+ (0.0 ":irc.example.org 221 emersion +Zi")
+ (0.0 ":irc.example.org NOTICE emersion :This server is in debug mode and is logging all user I/O. If you do not wish for everything you send to be readable by the server owner(s), please disconnect."))
+
+((quit 5 "QUIT :\2ERC\2")
+ (0 ":emersion!~u@yuvqisyu7m7qs.irc QUIT :Quit"))
+((drop 1 DROP))
diff --git a/test/lisp/erc/resources/sasl/plain-overlong-split.eld b/test/lisp/erc/resources/sasl/plain-overlong-split.eld
new file mode 100644
index 00000000000..3e6870790f3
--- /dev/null
+++ b/test/lisp/erc/resources/sasl/plain-overlong-split.eld
@@ -0,0 +1,39 @@
+;; -*- mode: lisp-data; -*-
+((cap-req 10 "CAP REQ :sasl"))
+((nick 10 "NICK emersion"))
+((user 10 "USER emersion 0 * :emersion")
+ (0.0 ":irc.example.org NOTICE * :*** Looking up your hostname...")
+ (0.0 ":irc.example.org NOTICE * :*** Found your hostname")
+ (0.0 ":irc.example.org CAP * ACK :sasl"))
+
+((authenticate-plain 10 "AUTHENTICATE PLAIN")
+ (0.0 ":irc.example.org AUTHENTICATE +"))
+((authenticate-gimme-1 10 "AUTHENTICATE AGVtZXJzaW9uAEVzdCB1dCBiZWF0YWUgb21uaXMgaXBzYW0uIFF1aXMgZnVnaWF0IGRlbGVuaXRpIHRvdGFtIHF1aS4gSXBzdW0gcXVhbSBhIGRvbG9ydW0gdGVtcG9yYSB2ZWxpdCBsYWJvcnVtIG9kaXQuIEV0IHNhZXBlIHZvbHVwdGF0ZSBzZWQgY3VtcXVlIHZlbC4gVm9sdXB0YXMgc2ludCBhYiBwYXJpYXR1ciBsaWJlcm8gdmVyaXRhdGlzIGNvcnJ1cHRpLiBWZXJvIGl1cmUgb21uaXMgdWxsYW0uIFZlcm8gYmVhdGFlIGRvbG9yZXMgZmFjZXJlIGZ1Z2lhdCBpcHNhbS4gRWEgZXN0IHBhcmlhdHVyIG1pbmltYSBub2JpcyBz"))
+((authenticate-gimme-2 10 "AUTHENTICATE dW50IGF1dCB1dC4gRG9sb3JlcyB1dCBsYXVkYW50aXVtIG1haW9yZXMgdGVtcG9yaWJ1cyB2b2x1cHRhdGVzLiBSZWljaWVuZGlzIGltcGVkaXQgb21uaXMgZXQgdW5kZSBkZWxlY3R1cyBxdWFzIGFiLiBRdWFlIGVsaWdlbmRpIG5lY2Vzc2l0YXRpYnVzIGRvbG9yaWJ1cyBtb2xlc3RpYXMgdGVtcG9yYSBtYWduYW0gYXNzdW1lbmRhLg==")
+ (0.0 ":irc.example.org 900 * * emersion :You are now logged in as emersion")
+ (0.0 ":irc.example.org 903 * :Authentication successful"))
+
+((cap-end 10 "CAP END")
+ (0.0 ":irc.example.org 001 emersion :Welcome to the ExampleOrg IRC Network emersion")
+ (0.0 ":irc.example.org 002 emersion :Your host is irc.example.org, running version oragono-2.6.1")
+ (0.0 ":irc.example.org 003 emersion :This server was created Sat, 17 Jul 2021 09:06:42 UTC")
+ (0.0 ":irc.example.org 004 emersion irc.example.org oragono-2.6.1 BERTZios CEIMRUabefhiklmnoqstuv Iabefhkloqv")
+ (0.0 ":irc.example.org 005 emersion AWAYLEN=200 BOT=B CASEMAPPING=ascii CHANLIMIT=#:100 CHANMODES=Ibe,k,fl,CEMRUimnstu CHANNELLEN=64 CHANTYPES=# ELIST=U EXCEPTS EXTBAN=,m FORWARD=f INVEX KICKLEN=390 :are supported by this server")
+ (0.0 ":irc.example.org 005 emersion MAXLIST=beI:60 MAXTARGETS=4 MODES MONITOR=100 NETWORK=ExampleOrg NICKLEN=32 PREFIX=(qaohv)~&@%+ STATUSMSG=~&@%+ TARGMAX=NAMES:1,LIST:1,KICK:1,WHOIS:1,USERHOST:10,PRIVMSG:4,TAGMSG:4,NOTICE:4,MONITOR:100 TOPICLEN=390 UTF8MAPPING=rfc8265 UTF8ONLY :are supported by this server")
+ (0.0 ":irc.example.org 005 emersion draft/CHATHISTORY=100 :are supported by this server")
+ (0.0 ":irc.example.org 251 emersion :There are 1 users and 0 invisible on 1 server(s)")
+ (0.0 ":irc.example.org 252 emersion 0 :IRC Operators online")
+ (0.0 ":irc.example.org 253 emersion 0 :unregistered connections")
+ (0.0 ":irc.example.org 254 emersion 0 :channels formed")
+ (0.0 ":irc.example.org 255 emersion :I have 1 clients and 0 servers")
+ (0.0 ":irc.example.org 265 emersion 1 1 :Current local users 1, max 1")
+ (0.0 ":irc.example.org 266 emersion 1 1 :Current global users 1, max 1")
+ (0.0 ":irc.example.org 422 emersion :MOTD File is missing"))
+
+((mode-user 10 "MODE emersion +i")
+ (0.0 ":irc.example.org 221 emersion +Zi")
+ (0.0 ":irc.example.org NOTICE emersion :This server is in debug mode and is logging all user I/O. If you do not wish for everything you send to be readable by the server owner(s), please disconnect."))
+
+((quit 5 "QUIT :\2ERC\2")
+ (0 ":emersion!~u@yuvqisyu7m7qs.irc QUIT :Quit"))
+((drop 1 DROP))
diff --git a/test/lisp/erc/resources/sasl/scram-sha-1.eld b/test/lisp/erc/resources/sasl/scram-sha-1.eld
index 49980e9e12a..d6adf529c5d 100644
--- a/test/lisp/erc/resources/sasl/scram-sha-1.eld
+++ b/test/lisp/erc/resources/sasl/scram-sha-1.eld
@@ -42,6 +42,6 @@
(0 ":jaguar.test 372 jilles : ~~ or rkpryyrag gb rnpu bgure ~~")
(0 ":jaguar.test 376 jilles :End of message of the day."))
-((mode-user 1.2 "MODE jilles +i")
+((mode-user 10 "MODE jilles +i")
(0 ":jilles!~jilles@127.0.0.1 MODE jilles :+ri")
(0 ":jaguar.test 306 jilles :You have been marked as being away"))
diff --git a/test/lisp/erc/resources/sasl/scram-sha-256.eld b/test/lisp/erc/resources/sasl/scram-sha-256.eld
index 74de9a23ecf..8b16f7109cf 100644
--- a/test/lisp/erc/resources/sasl/scram-sha-256.eld
+++ b/test/lisp/erc/resources/sasl/scram-sha-256.eld
@@ -42,6 +42,6 @@
(0 ":jaguar.test 372 jilles : ~~ or rkpryyrag gb rnpu bgure ~~")
(0 ":jaguar.test 376 jilles :End of message of the day."))
-((mode-user 1.2 "MODE jilles +i")
+((mode-user 10 "MODE jilles +i")
(0 ":jilles!~jilles@127.0.0.1 MODE jilles :+ri")
(0 ":jaguar.test 306 jilles :You have been marked as being away"))
diff --git a/test/lisp/erc/resources/scrolltobottom/help.eld b/test/lisp/erc/resources/scrolltobottom/help.eld
new file mode 100644
index 00000000000..ba44a0def39
--- /dev/null
+++ b/test/lisp/erc/resources/scrolltobottom/help.eld
@@ -0,0 +1,46 @@
+;; -*- mode: lisp-data; -*-
+((nick 10 "NICK tester"))
+((user 10 "USER user 0 * :tester")
+ (0.00 ":irc.foonet.org 001 tester :Welcome to the foonet IRC Network tester")
+ (0.01 ":irc.foonet.org 002 tester :Your host is irc.foonet.org, running version ergo-v2.11.1")
+ (0.01 ":irc.foonet.org 003 tester :This server was created Mon, 21 Aug 2023 06:18:36 UTC")
+ (0.02 ":irc.foonet.org 004 tester irc.foonet.org ergo-v2.11.1 BERTZios CEIMRUabefhiklmnoqstuv Iabefhkloqv")
+ (0.00 ":irc.foonet.org 005 tester AWAYLEN=390 BOT=B CASEMAPPING=ascii CHANLIMIT=#:100 CHANMODES=Ibe,k,fl,CEMRUimnstu CHANNELLEN=64 CHANTYPES=# CHATHISTORY=1000 ELIST=U EXCEPTS EXTBAN=,m FORWARD=f INVEX :are supported by this server")
+ (0.01 ":irc.foonet.org 005 tester KICKLEN=390 MAXLIST=beI:60 MAXTARGETS=4 MODES MONITOR=100 NETWORK=foonet NICKLEN=32 PREFIX=(qaohv)~&@%+ STATUSMSG=~&@%+ TARGMAX=NAMES:1,LIST:1,KICK:,WHOIS:1,USERHOST:10,PRIVMSG:4,TAGMSG:4,NOTICE:4,MONITOR:100 TOPICLEN=390 UTF8ONLY WHOX :are supported by this server")
+ (0.01 ":irc.foonet.org 005 tester draft/CHATHISTORY=1000 :are supported by this server")
+ (0.01 ":irc.foonet.org 251 tester :There are 0 users and 4 invisible on 1 server(s)")
+ (0.01 ":irc.foonet.org 252 tester 0 :IRC Operators online")
+ (0.01 ":irc.foonet.org 253 tester 0 :unregistered connections")
+ (0.01 ":irc.foonet.org 254 tester 2 :channels formed")
+ (0.01 ":irc.foonet.org 255 tester :I have 4 clients and 0 servers")
+ (0.01 ":irc.foonet.org 265 tester 4 4 :Current local users 4, max 4")
+ (0.01 ":irc.foonet.org 266 tester 4 4 :Current global users 4, max 4")
+ (0.01 ":irc.foonet.org 422 tester :MOTD File is missing"))
+
+((mode 10 "MODE tester +i")
+ (0.00 ":irc.foonet.org 221 tester +i")
+ (0.01 ":irc.foonet.org NOTICE tester :This server is in debug mode and is logging all user I/O. If you do not wish for everything you send to be readable by the server owner(s), please disconnect.")
+ (0.02 ":irc.foonet.org 221 tester +i"))
+
+((privmsg-help-register 10 "PRIVMSG NickServ :help register")
+ (0.05 ":NickServ!NickServ@localhost NOTICE tester :*** \2NickServ HELP\2 ***")
+ (0.02 ":NickServ!NickServ@localhost NOTICE tester :Syntax: \2REGISTER <password> [email]\2")
+ (0.02 ":NickServ!NickServ@localhost NOTICE tester :")
+ (0.01 ":NickServ!NickServ@localhost NOTICE tester :REGISTER lets you register your current nickname as a user account. If the")
+ (0.01 ":NickServ!NickServ@localhost NOTICE tester :server allows anonymous registration, you can omit the e-mail address.")
+ (0.01 ":NickServ!NickServ@localhost NOTICE tester :")
+ (0.01 ":NickServ!NickServ@localhost NOTICE tester :If you are currently logged in with a TLS client certificate and wish to use")
+ (0.02 ":NickServ!NickServ@localhost NOTICE tester :it instead of a password to log in, send * as the password.")
+ (0.02 ":NickServ!NickServ@localhost NOTICE tester :*** \2End of NickServ HELP\2 ***"))
+
+((privmsg-help-identify 20 "PRIVMSG NickServ :help identify")
+ (0.06 ":NickServ!NickServ@localhost NOTICE tester :*** \2NickServ HELP\2 ***")
+ (0.02 ":NickServ!NickServ@localhost NOTICE tester :Syntax: \2IDENTIFY <username> [password]\2")
+ (0.02 ":NickServ!NickServ@localhost NOTICE tester :")
+ (0.02 ":NickServ!NickServ@localhost NOTICE tester :IDENTIFY lets you login to the given username using either password auth, or")
+ (0.02 ":NickServ!NickServ@localhost NOTICE tester :certfp (your client certificate) if a password is not given.")
+ (0.02 ":NickServ!NickServ@localhost NOTICE tester :*** \2End of NickServ HELP\2 ***"))
+
+((quit 10 "QUIT :\2ERC\2 ")
+ (0.07 ":tester!~u@26axz8nh8zaag.irc QUIT :Quit: \2ERC\2")
+ (0.02 "ERROR :Quit: \2ERC\2"))
diff --git a/test/lisp/erc/resources/services/auth-source/libera.eld b/test/lisp/erc/resources/services/auth-source/libera.eld
index c8dbc9d425a..dfc25221508 100644
--- a/test/lisp/erc/resources/services/auth-source/libera.eld
+++ b/test/lisp/erc/resources/services/auth-source/libera.eld
@@ -1,6 +1,6 @@
;; -*- mode: lisp-data; -*-
-((nick 1 "NICK tester"))
-((user 1 "USER user 0 * :tester")
+((nick 10 "NICK tester"))
+((user 5 "USER user 0 * :tester")
(0.26 ":zirconium.libera.chat NOTICE * :*** Checking Ident")
(0.01 ":zirconium.libera.chat NOTICE * :*** Looking up your hostname...")
(0.01 ":zirconium.libera.chat NOTICE * :*** No Ident response")
@@ -35,15 +35,15 @@
(0.01 ":zirconium.libera.chat 372 tester :- Email: support@libera.chat")
(0.00 ":zirconium.libera.chat 376 tester :End of /MOTD command."))
-((mode-user 1.2 "MODE tester +i")
+((mode-user 10 "MODE tester +i")
(0.02 ":tester MODE tester :+Zi")
(0.02 ":NickServ!NickServ@services.libera.chat NOTICE tester :This nickname is registered. Please choose a different nickname, or identify via \2/msg NickServ IDENTIFY tester <password>\2"))
-((privmsg 2 "PRIVMSG NickServ :IDENTIFY changeme")
+((privmsg 10 "PRIVMSG NickServ :IDENTIFY changeme")
(0.96 ":NickServ!NickServ@services.libera.chat NOTICE tester :You are now identified for \2tester\2.")
(0.25 ":NickServ!NickServ@services.libera.chat NOTICE tester :Last login from: \2~tester@school.edu/tester\2 on Jun 18 01:15:56 2021 +0000."))
-((quit 5 "QUIT :\2ERC\2")
+((quit 10 "QUIT :\2ERC\2")
(0.19 ":tester!~user@static-198-54-131-100.cust.tzulo.com QUIT :Client Quit"))
((linger 1 LINGER))
diff --git a/test/lisp/erc/resources/services/regain/reconnect-retry-again.eld b/test/lisp/erc/resources/services/regain/reconnect-retry-again.eld
new file mode 100644
index 00000000000..c0529052c70
--- /dev/null
+++ b/test/lisp/erc/resources/services/regain/reconnect-retry-again.eld
@@ -0,0 +1,56 @@
+;; -*- mode: lisp-data; -*-
+((cap 10 "CAP REQ :sasl"))
+((nick 10 "NICK tester"))
+((user 10 "USER tester 0 * :tester"))
+
+((authenticate 10 "AUTHENTICATE PLAIN")
+ (0.04 ":tantalum.libera.chat NOTICE * :*** Checking Ident")
+ (0.01 ":tantalum.libera.chat NOTICE * :*** Looking up your hostname...")
+ (0.01 ":tantalum.libera.chat NOTICE * :*** Couldn't look up your hostname")
+ (0.06 ":tantalum.libera.chat NOTICE * :*** No Ident response")
+ (0.02 ":tantalum.libera.chat CAP * ACK :sasl")
+ (0.03 ":tantalum.libera.chat 433 * tester :Nickname is already in use."))
+
+((nick 10 "NICK tester`")
+ (0.03 "AUTHENTICATE +"))
+
+((authenticate 10 "AUTHENTICATE AHRlc3RlcgBjaGFuZ2VtZQ==")
+ (0.06 ":tantalum.libera.chat 900 tester` tester`!tester@127.0.0.1 tester :You are now logged in as tester")
+ (0.02 ":tantalum.libera.chat 903 tester` :SASL authentication successful"))
+
+((cap 10 "CAP END")
+ (0.02 ":tantalum.libera.chat 001 tester` :Welcome to the Libera.Chat Internet Relay Chat Network tester`")
+ (0.02 ":tantalum.libera.chat 002 tester` :Your host is tantalum.libera.chat[93.158.237.2/6697], running version solanum-1.0-dev")
+ (0.02 ":tantalum.libera.chat 003 tester` :This server was created Mon Feb 13 2023 at 12:05:04 UTC")
+ (0.01 ":tantalum.libera.chat 004 tester` tantalum.libera.chat solanum-1.0-dev DGMQRSZaghilopsuwz CFILMPQRSTbcefgijklmnopqrstuvz bkloveqjfI")
+ (0.01 ":tantalum.libera.chat 005 tester` WHOX MONITOR=100 SAFELIST ELIST=CMNTU ETRACE FNC CALLERID=g KNOCK CHANTYPES=# EXCEPTS INVEX CHANMODES=eIbq,k,flj,CFLMPQRSTcgimnprstuz :are supported by this server")
+ (0.01 ":tantalum.libera.chat 005 tester` CHANLIMIT=#:250 PREFIX=(ov)@+ MAXLIST=bqeI:100 MODES=4 NETWORK=Libera.Chat STATUSMSG=@+ CASEMAPPING=rfc1459 NICKLEN=16 MAXNICKLEN=16 CHANNELLEN=50 TOPICLEN=390 DEAF=D :are supported by this server")
+ (0.03 ":tantalum.libera.chat 005 tester` TARGMAX=NAMES:1,LIST:1,KICK:1,WHOIS:1,PRIVMSG:4,NOTICE:4,ACCEPT:,MONITOR: EXTBAN=$,ajrxz :are supported by this server")
+ (0.01 ":tantalum.libera.chat 251 tester` :There are 70 users and 42977 invisible on 28 servers")
+ (0.00 ":tantalum.libera.chat 252 tester` 38 :IRC Operators online")
+ (0.00 ":tantalum.libera.chat 253 tester` 87 :unknown connection(s)")
+ (0.00 ":tantalum.libera.chat 254 tester` 22908 :channels formed")
+ (0.00 ":tantalum.libera.chat 255 tester` :I have 2507 clients and 1 servers")
+ (0.00 ":tantalum.libera.chat 265 tester` 2507 3232 :Current local users 2507, max 3232")
+ (0.00 ":tantalum.libera.chat 266 tester` 43047 51777 :Current global users 43047, max 51777")
+ (0.00 ":tantalum.libera.chat 250 tester` :Highest connection count: 3233 (3232 clients) (284887 connections received)")
+ (0.03 ":tantalum.libera.chat 375 tester` :- tantalum.libera.chat Message of the Day - ")
+ (0.00 ":tantalum.libera.chat 372 tester` :- This server provided by Hyperfilter (https://hyperfilter.com)")
+ (0.00 ":tantalum.libera.chat 372 tester` :- Email: support@libera.chat")
+ (0.02 ":tantalum.libera.chat 376 tester` :End of /MOTD command."))
+
+((mode 10 "MODE tester` +i")
+ (0.01 ":tester` MODE tester` :+Ziw")
+ (0.02 ":SaslServ!SaslServ@services.libera.chat NOTICE tester` :Last login from: \2~tester@127.0.0.1\2 on Apr 07 01:36:25 2023 +0000."))
+
+((nick 10 "NICK tester")
+ (0.02 ":tester`!~tester@127.0.0.1 NICK :tester"))
+
+((join 10 "JOIN #test")
+ (0.02 ":tester!~tester@127.0.0.1 JOIN #test")
+ (0.02 ":tantalum.libera.chat 353 tester = #test :tester zbyqbepbqre7 pusevgfpu Thrfg2187 zngbeb qnexNssvavgl wrebzr- rqpentt Ilehf grfg2 AvtugZbaxrl pevfgvvbna xrivap_ fnvybePng shohxv gxan arrqyr avpx16 NeanhqW_kzcc jvyyr wrnaogeq Wnarg cnefavc0 Xbentt RcvpArb flfqrs wfgbxre hafcrag__ Lbevpx_")
+ (0.02 ":tantalum.libera.chat 366 tester #test :End of /NAMES list."))
+
+((mode 10 "MODE #test")
+ (0.02 ":tantalum.libera.chat 324 tester #test +nt")
+ (0.02 ":tantalum.libera.chat 329 tester #test 1621432263"))
diff --git a/test/lisp/erc/resources/services/regain/reconnect-retry.eld b/test/lisp/erc/resources/services/regain/reconnect-retry.eld
new file mode 100644
index 00000000000..9f4df70e580
--- /dev/null
+++ b/test/lisp/erc/resources/services/regain/reconnect-retry.eld
@@ -0,0 +1,53 @@
+;; -*- mode: lisp-data; -*-
+((cap 10 "CAP REQ :sasl"))
+((nick 10 "NICK tester"))
+((user 10 "USER tester 0 * :tester"))
+
+((authenticate 10 "AUTHENTICATE PLAIN")
+ (0.02 ":cadmium.libera.chat NOTICE * :*** Checking Ident")
+ (0.01 ":cadmium.libera.chat NOTICE * :*** Looking up your hostname...")
+ (0.01 ":cadmium.libera.chat NOTICE * :*** Couldn't look up your hostname")
+ (0.06 ":cadmium.libera.chat NOTICE * :*** No Ident response")
+ (0.09 ":cadmium.libera.chat CAP * ACK :sasl")
+ (0.01 "AUTHENTICATE +"))
+
+((authenticate 10 "AUTHENTICATE AHRlc3RlcgBjaGFuZ2VtZQ==")
+ (0.03 ":cadmium.libera.chat 900 tester tester!tester@127.0.0.1 tester :You are now logged in as tester")
+ (0.01 ":cadmium.libera.chat 903 tester :SASL authentication successful"))
+
+((cap 10 "CAP END")
+ (0.03 ":cadmium.libera.chat 001 tester :Welcome to the Libera.Chat Internet Relay Chat Network tester")
+ (0.02 ":cadmium.libera.chat 002 tester :Your host is cadmium.libera.chat[103.196.37.95/6697], running version solanum-1.0-dev")
+ (0.01 ":cadmium.libera.chat 003 tester :This server was created Wed Jan 25 2023 at 10:22:45 UTC")
+ (0.01 ":cadmium.libera.chat 004 tester cadmium.libera.chat solanum-1.0-dev DGMQRSZaghilopsuwz CFILMPQRSTbcefgijklmnopqrstuvz bkloveqjfI")
+ (0.00 ":cadmium.libera.chat 005 tester CALLERID=g WHOX ETRACE FNC SAFELIST ELIST=CMNTU KNOCK MONITOR=100 CHANTYPES=# EXCEPTS INVEX CHANMODES=eIbq,k,flj,CFLMPQRSTcgimnprstuz :are supported by this server")
+ (0.01 ":cadmium.libera.chat 005 tester CHANLIMIT=#:250 PREFIX=(ov)@+ MAXLIST=bqeI:100 MODES=4 NETWORK=Libera.Chat STATUSMSG=@+ CASEMAPPING=rfc1459 NICKLEN=16 MAXNICKLEN=16 CHANNELLEN=50 TOPICLEN=390 DEAF=D :are supported by this server")
+ (0.01 ":cadmium.libera.chat 005 tester TARGMAX=NAMES:1,LIST:1,KICK:1,WHOIS:1,PRIVMSG:4,NOTICE:4,ACCEPT:,MONITOR: EXTBAN=$,ajrxz :are supported by this server")
+ (0.01 ":cadmium.libera.chat 251 tester :There are 70 users and 42996 invisible on 28 servers")
+ (0.02 ":cadmium.libera.chat 252 tester 38 :IRC Operators online")
+ (0.01 ":cadmium.libera.chat 253 tester 57 :unknown connection(s)")
+ (0.01 ":cadmium.libera.chat 254 tester 22912 :channels formed")
+ (0.01 ":cadmium.libera.chat 255 tester :I have 2499 clients and 1 servers")
+ (0.01 ":cadmium.libera.chat 265 tester 2499 4187 :Current local users 2499, max 4187")
+ (0.01 ":cadmium.libera.chat 266 tester 43066 51827 :Current global users 43066, max 51827")
+ (0.01 ":cadmium.libera.chat 250 tester :Highest connection count: 4188 (4187 clients) (319420 connections received)")
+ (0.01 ":cadmium.libera.chat 375 tester :- cadmium.libera.chat Message of the Day - ")
+ (0.01 ":cadmium.libera.chat 372 tester :- This server kindly provided by Mach Dilemma (www.m-d.net)")
+ (0.01 ":cadmium.libera.chat 372 tester :- Welcome to Libera Chat, the IRC network for")
+ (0.00 ":cadmium.libera.chat 372 tester :- Email: support@libera.chat")
+ (0.00 ":cadmium.libera.chat 376 tester :End of /MOTD command.")
+ (0.00 ":tester MODE tester :+Ziw")
+ (0.02 ":SaslServ!SaslServ@services.libera.chat NOTICE tester :Last login from: \2~tester@127.0.0.1\2 on Apr 07 01:02:11 2023 +0000."))
+
+((mode 10 "MODE tester +i"))
+
+((join 10 "JOIN #test")
+ (0.09 ":tester!~tester@127.0.0.1 JOIN #test"))
+
+((mode 10 "MODE #test")
+ (0.03 ":cadmium.libera.chat 353 tester = #test :tester zbyqbepbqre7 pusevgfpu Thrfg2187 zngbeb qnexNssvavgl wrebzr- rqpentt Ilehf grfg2 AvtugZbaxrl pevfgvvbna xrivap_ fnvybePng shohxv gxan arrqyr avpx16 NeanhqW_kzcc Lbevpx_ hafcrag__ wfgbxre flfqrs RcvpArb Xbentt jvyyr cnefavc0 Wnarg wrnaogeq")
+ (0.02 ":cadmium.libera.chat 366 tester #test :End of /NAMES list.")
+ (0.00 ":cadmium.libera.chat 324 tester #test +nt")
+ (0.01 ":cadmium.libera.chat 329 tester #test 1621432263"))
+
+((drop 0 DROP))
diff --git a/test/lisp/erc/resources/services/regain/taken-ghost.eld b/test/lisp/erc/resources/services/regain/taken-ghost.eld
new file mode 100644
index 00000000000..d5afd124a43
--- /dev/null
+++ b/test/lisp/erc/resources/services/regain/taken-ghost.eld
@@ -0,0 +1,42 @@
+;; -*- mode: lisp-data; -*-
+((cap 10 "CAP REQ :sasl")
+ (0.00 ":irc.example.net NOTICE * :*** Looking up your hostname...")
+ (0.01 ":irc.example.net NOTICE * :*** Could not resolve your hostname: Domain not found; using your IP address (10.0.2.100) instead."))
+((nick 10 "NICK dummy"))
+((user 10 "USER dummy 0 * :tester"))
+((authenticate 10 "AUTHENTICATE PLAIN")
+ (0.00 ":irc.example.net CAP * ACK :sasl")
+ (0.03 ":irc.example.net 433 * dummy :Nickname is already in use.")
+ (0.04 "AUTHENTICATE :+"))
+((nick 10 "NICK dummy`")
+ (0.00 "PING :orrMOjk^|V"))
+((~pong 10 "PONG :orrMOjk^|V"))
+((authenticate 10 "AUTHENTICATE AHRlc3RlcgBjaGFuZ2VtZQ==")
+ (0.01 ":irc.example.net 900 dummy` dummy`!dummy@10.0.2.100 tester :You are now logged in as tester")
+ (0.01 ":irc.example.net 903 dummy` :SASL authentication successful"))
+((cap 10 "CAP END")
+ (0.00 ":irc.example.net 001 dummy` :Welcome to the FooNet IRC Network dummy`!dummy@10.0.2.100")
+ (0.03 ":irc.example.net 002 dummy` :Your host is irc.example.net, running version InspIRCd-3")
+ (0.01 ":irc.example.net 003 dummy` :This server was created 13:01:55 Jun 08 2023")
+ (0.01 ":irc.example.net 004 dummy` irc.example.net InspIRCd-3 BIRcgikorsw ACHIKMORTXabcefghijklmnopqrstvz :HIXabefghjkloqv")
+ (0.00 ":irc.example.net 005 dummy` ACCEPT=30 AWAYLEN=200 BOT=B CALLERID=g CASEMAPPING=ascii CHANLIMIT=#:20 CHANMODES=IXbeg,k,Hfjl,ACKMORTcimnprstz CHANNELLEN=64 CHANTYPES=# ELIST=CMNTU ESILENCE=CcdiNnPpTtx EXCEPTS=e :are supported by this server")
+ (0.01 ":irc.example.net 005 dummy` EXTBAN=,ACORTUacjrwz HOSTLEN=64 INVEX=I KEYLEN=32 KICKLEN=255 LINELEN=512 MAXLIST=I:100,X:100,b:100,e:100,g:100 MAXTARGETS=20 MODES=20 MONITOR=30 NAMELEN=128 NAMESX NETWORK=FooNet :are supported by this server")
+ (0.01 ":irc.example.net 005 dummy` NICKLEN=30 PREFIX=(qaohv)~&@%+ SAFELIST SILENCE=32 STATUSMSG=~&@%+ TOPICLEN=307 UHNAMES USERIP USERLEN=10 USERMODES=,,s,BIRcgikorw WHOX :are supported by this server")
+ (0.01 ":irc.example.net 251 dummy` :There are 2 users and 1 invisible on 2 servers")
+ (0.01 ":irc.example.net 253 dummy` 1 :unknown connections")
+ (0.00 ":irc.example.net 254 dummy` 1 :channels formed")
+ (0.00 ":irc.example.net 255 dummy` :I have 3 clients and 1 servers")
+ (0.00 ":irc.example.net 265 dummy` :Current local users: 3 Max: 4")
+ (0.00 ":irc.example.net 266 dummy` :Current global users: 3 Max: 4")
+ (0.00 ":irc.example.net 375 dummy` :irc.example.net message of the day")
+ (0.00 ":irc.example.net 372 dummy` : Have fun with the image!")
+ (0.00 ":irc.example.net 376 dummy` :End of message of the day."))
+
+((mode 10 "MODE dummy` +i"))
+((privmsg 10 "PRIVMSG NickServ :GHOST dummy")
+ (0.00 ":irc.example.net 501 dummy` x :is not a recognised user mode.")
+ (0.00 ":irc.example.net NOTICE dummy` :*** You are connected to irc.example.net using TLS (SSL) cipher 'TLS1.3-ECDHE-RSA-AES-256-GCM-AEAD'")
+ (0.03 ":dummy`!dummy@10.0.2.100 MODE dummy` :+i")
+ (0.02 ":NickServ!NickServ@services.int NOTICE dummy` :\2dummy\2 has been ghosted."))
+((nick 10 "NICK dummy")
+ (0.02 ":dummy`!dummy@10.0.2.100 NICK :dummy"))
diff --git a/test/lisp/erc/resources/services/regain/taken-regain.eld b/test/lisp/erc/resources/services/regain/taken-regain.eld
new file mode 100644
index 00000000000..22635d4cc89
--- /dev/null
+++ b/test/lisp/erc/resources/services/regain/taken-regain.eld
@@ -0,0 +1,42 @@
+;; -*- mode: lisp-data; -*-
+((cap 10 "CAP REQ :sasl")
+ (0.00 ":irc.example.net NOTICE * :*** Looking up your hostname...")
+ (0.01 ":irc.example.net NOTICE * :*** Could not resolve your hostname: Domain not found; using your IP address (10.0.2.100) instead."))
+((nick 10 "NICK dummy"))
+((user 10 "USER dummy 0 * :tester"))
+;; This also happens to a test late ACK (see ghost variant for server-sent PING)
+((authenticate 10 "AUTHENTICATE PLAIN")
+ (0.00 ":irc.example.net CAP * ACK :sasl")
+ (0.09 ":irc.example.net 433 * dummy :Nickname is already in use.")
+ (0.04 "AUTHENTICATE :+"))
+((nick 10 "NICK dummy`"))
+((authenticate 10 "AUTHENTICATE AHRlc3RlcgBjaGFuZ2VtZQ==")
+ (0.00 ":irc.example.net 900 dummy` dummy`!dummy@10.0.2.100 tester :You are now logged in as tester")
+ (0.01 ":irc.example.net 903 dummy` :SASL authentication successful"))
+
+((cap 10 "CAP END")
+ (0.00 ":irc.example.net 001 dummy` :Welcome to the FooNet IRC Network dummy`!dummy@10.0.2.100")
+ (0.02 ":irc.example.net 002 dummy` :Your host is irc.example.net, running version InspIRCd-3")
+ (0.02 ":irc.example.net 003 dummy` :This server was created 08:16:52 Jun 08 2023")
+ (0.01 ":irc.example.net 004 dummy` irc.example.net InspIRCd-3 BIRcgikorsw ACHIKMORTXabcefghijklmnopqrstvz :HIXabefghjkloqv")
+ (0.00 ":irc.example.net 005 dummy` ACCEPT=30 AWAYLEN=200 BOT=B CALLERID=g CASEMAPPING=ascii CHANLIMIT=#:20 CHANMODES=IXbeg,k,Hfjl,ACKMORTcimnprstz CHANNELLEN=64 CHANTYPES=# ELIST=CMNTU ESILENCE=CcdiNnPpTtx EXCEPTS=e :are supported by this server")
+ (0.01 ":irc.example.net 005 dummy` EXTBAN=,ACORTUacjrwz HOSTLEN=64 INVEX=I KEYLEN=32 KICKLEN=255 LINELEN=512 MAXLIST=I:100,X:100,b:100,e:100,g:100 MAXTARGETS=20 MODES=20 MONITOR=30 NAMELEN=128 NAMESX NETWORK=FooNet :are supported by this server")
+ (0.01 ":irc.example.net 005 dummy` NICKLEN=30 PREFIX=(qaohv)~&@%+ SAFELIST SILENCE=32 STATUSMSG=~&@%+ TOPICLEN=307 UHNAMES USERIP USERLEN=10 USERMODES=,,s,BIRcgikorw WHOX :are supported by this server")
+ (0.01 ":irc.example.net 251 dummy` :There are 2 users and 1 invisible on 2 servers")
+ (0.01 ":irc.example.net 253 dummy` 1 :unknown connections")
+ (0.00 ":irc.example.net 254 dummy` 1 :channels formed")
+ (0.02 ":irc.example.net 255 dummy` :I have 3 clients and 1 servers")
+ (0.00 ":irc.example.net 265 dummy` :Current local users: 3 Max: 4")
+ (0.00 ":irc.example.net 266 dummy` :Current global users: 3 Max: 4")
+ (0.00 ":irc.example.net 375 dummy` :irc.example.net message of the day")
+ (0.00 ":irc.example.net 372 dummy` : Have fun with the image!")
+ (0.00 ":irc.example.net 376 dummy` :End of message of the day.")
+ (0.00 ":irc.example.net 501 dummy` x :is not a recognised user mode.")
+ (0.00 ":irc.example.net NOTICE dummy` :*** You are connected to irc.example.net using TLS (SSL) cipher 'TLS1.3-ECDHE-RSA-AES-256-GCM-AEAD'"))
+
+((mode 10 "MODE dummy` +i"))
+
+((privmsg 10 "PRIVMSG NickServ :REGAIN dummy")
+ (0.00 ":dummy`!dummy@10.0.2.100 MODE dummy` :+i")
+ (0.02 ":NickServ!NickServ@services.int NOTICE dummy` :\2dummy\2 has been regained.")
+ (0.02 ":dummy`!dummy@10.0.2.100 NICK :dummy"))
diff --git a/test/lisp/eshell/em-alias-tests.el b/test/lisp/eshell/em-alias-tests.el
index 996a938451a..b70ca185730 100644
--- a/test/lisp/eshell/em-alias-tests.el
+++ b/test/lisp/eshell/em-alias-tests.el
@@ -72,6 +72,15 @@
(eshell-match-command-output "show-all-args a" "a\n")
(eshell-match-command-output "show-all-args a b c" "a\nb\nc\n")))
+(ert-deftest em-alias-test/alias-all-args-var-splice ()
+ "Test alias with splicing the $* variable"
+ (with-temp-eshell
+ (eshell-insert-command "alias show-all-args 'echo args: $@*'")
+ (eshell-match-command-output "show-all-args" "args:\n")
+ (eshell-match-command-output "show-all-args a" "(\"args:\" \"a\")\n")
+ (eshell-match-command-output "show-all-args a b c"
+ "(\"args:\" \"a\" \"b\" \"c\")\n")))
+
(ert-deftest em-alias-test/alias-all-args-var-indices ()
"Test alias with the $* variable using indices"
(with-temp-eshell
diff --git a/test/lisp/eshell/em-basic-tests.el b/test/lisp/eshell/em-basic-tests.el
index 960e04690a5..ebb91cdeea0 100644
--- a/test/lisp/eshell/em-basic-tests.el
+++ b/test/lisp/eshell/em-basic-tests.el
@@ -33,7 +33,7 @@
;;; Tests:
-(ert-deftest em-basic-test/umask-print-numeric ()
+(ert-deftest em-basic-test/umask/print-numeric ()
"Test printing umask numerically."
(cl-letf (((symbol-function 'default-file-modes) (lambda () #o775)))
(eshell-command-result-equal "umask" "002\n"))
@@ -43,7 +43,7 @@
(cl-letf (((symbol-function 'default-file-modes) (lambda () #o1775)))
(eshell-command-result-equal "umask" "002\n")))
-(ert-deftest em-basic-test/umask-read-symbolic ()
+(ert-deftest em-basic-test/umask/print-symbolic ()
"Test printing umask symbolically."
(cl-letf (((symbol-function 'default-file-modes) (lambda () #o775)))
(eshell-command-result-equal "umask -S"
@@ -56,8 +56,8 @@
(eshell-command-result-equal "umask -S"
"u=rwx,g=rwx,o=rx\n")))
-(ert-deftest em-basic-test/umask-set ()
- "Test setting umask."
+(ert-deftest em-basic-test/umask/set-numeric ()
+ "Test setting umask numerically."
(let ((file-modes 0))
(cl-letf (((symbol-function 'set-default-file-modes)
(lambda (mode) (setq file-modes mode))))
@@ -68,4 +68,30 @@
(eshell-test-command-result "umask $(identity #o222)")
(should (= file-modes #o555)))))
+(ert-deftest em-basic-test/umask/set-symbolic ()
+ "Test setting umask symbolically."
+ (let ((file-modes 0))
+ (cl-letf (((symbol-function 'default-file-modes)
+ (lambda() file-modes))
+ ((symbol-function 'set-default-file-modes)
+ (lambda (mode) (setq file-modes mode))))
+ (eshell-test-command-result "umask u=rwx,g=rwx,o=rx")
+ (should (= file-modes #o775))
+ (eshell-test-command-result "umask u=rw,g=rx,o=x")
+ (should (= file-modes #o651))
+ (eshell-test-command-result "umask u+x,o-x")
+ (should (= file-modes #o750))
+ (eshell-test-command-result "umask a+rx")
+ (should (= file-modes #o755)))))
+
+(ert-deftest em-basic-test/umask/set-with-S ()
+ "Test that passing \"-S\" and a umask still sets the umask."
+ (let ((file-modes 0))
+ (cl-letf (((symbol-function 'set-default-file-modes)
+ (lambda (mode) (setq file-modes mode))))
+ (eshell-test-command-result "umask -S 002")
+ (should (= file-modes #o775))
+ (eshell-test-command-result "umask -S 123")
+ (should (= file-modes #o654)))))
+
;; em-basic-tests.el ends here
diff --git a/test/lisp/eshell/em-cmpl-tests.el b/test/lisp/eshell/em-cmpl-tests.el
new file mode 100644
index 00000000000..f778816c4e1
--- /dev/null
+++ b/test/lisp/eshell/em-cmpl-tests.el
@@ -0,0 +1,380 @@
+;;; em-cmpl-tests.el --- em-cmpl test suite -*- lexical-binding:t -*-
+
+;; Copyright (C) 2023-2024 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 <https://www.gnu.org/licenses/>.
+
+;;; Commentary:
+
+;; Tests for Eshell's interactive completion.
+
+;;; Code:
+
+(require 'ert)
+(require 'eshell)
+(require 'em-cmpl)
+(require 'em-dirs)
+(require 'em-hist)
+(require 'em-tramp)
+(require 'em-unix)
+
+(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-insert-and-complete (input)
+ "Insert INPUT and invoke completion, returning the result."
+ (insert input)
+ (completion-at-point)
+ (eshell-get-old-input))
+
+(defun eshell-arguments-equal (actual expected)
+ "Return t if ACTUAL and EXPECTED are equal, including properties of strings.
+ACTUAL and EXPECTED should both be lists of strings."
+ (when (length= actual (length expected))
+ (catch 'not-equal
+ (cl-mapc (lambda (i j)
+ (unless (equal-including-properties i j)
+ (throw 'not-equal nil)))
+ actual expected)
+ t)))
+
+(defun eshell-arguments-equal--equal-explainer (actual expected)
+ "Explain the result of `eshell-arguments-equal'."
+ `(nonequal-result
+ (actual ,actual)
+ (expected ,expected)))
+
+(put 'eshell-arguments-equal 'ert-explainer
+ #'eshell-arguments-equal--equal-explainer)
+
+;;; Tests:
+
+(ert-deftest em-cmpl-test/parse-arguments/pipeline ()
+ "Test that parsing arguments for completion discards earlier commands."
+ (with-temp-eshell
+ (insert "echo hi | cat")
+ (should (eshell-arguments-equal
+ (car (eshell-complete-parse-arguments))
+ '("cat")))))
+
+(ert-deftest em-cmpl-test/parse-arguments/multiple-dots ()
+ "Test parsing arguments with multiple dots like \".../\"."
+ (with-temp-eshell
+ (insert "echo .../file.txt")
+ (should (eshell-arguments-equal
+ (car (eshell-complete-parse-arguments))
+ `("echo" ,(propertize "../../file.txt"
+ 'pcomplete-arg-value
+ ".../file.txt"))))))
+
+(ert-deftest em-cmpl-test/parse-arguments/variable/numeric ()
+ "Test parsing arguments with a numeric variable interpolation."
+ (with-temp-eshell
+ (let ((eshell-test-value 42))
+ (insert "echo $eshell-test-value")
+ (should (eshell-arguments-equal
+ (car (eshell-complete-parse-arguments))
+ `("echo" ,(propertize "42" 'pcomplete-arg-value 42)))))))
+
+(ert-deftest em-cmpl-test/parse-arguments/variable/nil ()
+ "Test parsing arguments with a nil variable interpolation."
+ (with-temp-eshell
+ (let ((eshell-test-value nil))
+ (insert "echo $eshell-test-value")
+ (should (eshell-arguments-equal
+ (car (eshell-complete-parse-arguments))
+ `("echo" ,(propertize "" 'pcomplete-arg-value nil)))))))
+
+(ert-deftest em-cmpl-test/parse-arguments/variable/list ()
+ "Test parsing arguments with a list variable interpolation."
+ (with-temp-eshell
+ (let ((eshell-test-value '("foo" "bar")))
+ (insert "echo $eshell-test-value")
+ (should (eshell-arguments-equal
+ (car (eshell-complete-parse-arguments))
+ `("echo" ,(propertize "(\"foo\" \"bar\")"
+ 'pcomplete-arg-value
+ eshell-test-value)))))))
+
+(ert-deftest em-cmpl-test/parse-arguments/variable/splice ()
+ "Test parsing arguments with a spliced variable interpolation."
+ (with-temp-eshell
+ (let ((eshell-test-value '("foo" "bar")))
+ (insert "echo $@eshell-test-value")
+ (should (eshell-arguments-equal
+ (car (eshell-complete-parse-arguments))
+ '("echo" "foo" "bar"))))))
+
+(ert-deftest em-cmpl-test/parse-arguments/unevaluated-subcommand ()
+ "Test that subcommands return a stub when parsing for completion."
+ (with-temp-eshell
+ (insert "echo {echo hi}")
+ (should (eshell-arguments-equal
+ (car (eshell-complete-parse-arguments))
+ `("echo" ,(propertize
+ "\0" 'eshell-argument-stub 'named-command)))))
+ (with-temp-eshell
+ (insert "echo ${echo hi}")
+ (should (eshell-arguments-equal
+ (car (eshell-complete-parse-arguments))
+ `("echo" ,(propertize
+ "\0" 'eshell-argument-stub 'named-command))))))
+
+(ert-deftest em-cmpl-test/parse-arguments/unevaluated-lisp-form ()
+ "Test that Lisp forms return a stub when parsing for completion."
+ (with-temp-eshell
+ (insert "echo (concat \"hi\")")
+ (should (eshell-arguments-equal
+ (car (eshell-complete-parse-arguments))
+ `("echo" ,(propertize
+ "\0" 'eshell-argument-stub 'lisp-command)))))
+ (with-temp-eshell
+ (insert "echo $(concat \"hi\")")
+ (should (eshell-arguments-equal
+ (car (eshell-complete-parse-arguments))
+ `("echo" ,(propertize
+ "\0" 'eshell-argument-stub 'lisp-command))))))
+
+(ert-deftest em-cmpl-test/parse-arguments/unevaluated-inner-subcommand ()
+ "Test that nested subcommands return a stub when parsing for completion."
+ (with-temp-eshell
+ (insert "echo $exec-path[${echo 0}]")
+ (should (eshell-arguments-equal
+ (car (eshell-complete-parse-arguments))
+ `("echo" ,(propertize
+ "\0" 'eshell-argument-stub 'named-command))))))
+
+(ert-deftest em-cmpl-test/file-completion/unique ()
+ "Test completion of file names when there's a unique result."
+ (with-temp-eshell
+ (ert-with-temp-directory default-directory
+ (write-region nil nil (expand-file-name "file.txt"))
+ (should (equal (eshell-insert-and-complete "echo fi")
+ "echo file.txt ")))))
+
+(ert-deftest em-cmpl-test/file-completion/non-unique ()
+ "Test completion of file names when there are multiple results."
+ (with-temp-eshell
+ (ert-with-temp-directory default-directory
+ (write-region nil nil (expand-file-name "file.txt"))
+ (write-region nil nil (expand-file-name "file.el"))
+ ;; Complete the first time. This should insert the common prefix
+ ;; of our completions.
+ (should (equal (eshell-insert-and-complete "echo fi")
+ "echo file."))
+ ;; Make sure the completions buffer isn't displayed.
+ (should-not (get-buffer-window "*Completions*"))
+ ;; Now try completing again.
+ (let ((minibuffer-message-timeout 0)
+ (inhibit-message t))
+ (completion-at-point))
+ ;; This time, we should display the completions buffer.
+ (should (get-buffer-window "*Completions*")))))
+
+(ert-deftest em-cmpl-test/file-completion/glob ()
+ "Test completion of file names using a glob."
+ (with-temp-eshell
+ (ert-with-temp-directory default-directory
+ (write-region nil nil (expand-file-name "file.txt"))
+ (write-region nil nil (expand-file-name "file.el"))
+ (should (equal (eshell-insert-and-complete "echo fi*.el")
+ "echo file.el ")))))
+
+(ert-deftest em-cmpl-test/file-completion/after-list ()
+ "Test completion of file names after previous list arguments.
+See bug#59956."
+ (with-temp-eshell
+ (let ((eshell-test-value '("foo" "bar")))
+ (ert-with-temp-directory default-directory
+ (write-region nil nil (expand-file-name "file.txt"))
+ (should (equal (eshell-insert-and-complete "echo $eshell-test-value fi")
+ "echo $eshell-test-value file.txt "))))))
+
+(ert-deftest em-cmpl-test/command-completion ()
+ "Test completion of command names like \"command\"."
+ (with-temp-eshell
+ (should (equal (eshell-insert-and-complete "listif")
+ "listify "))))
+
+(ert-deftest em-cmpl-test/subcommand-completion ()
+ "Test completion of command names like \"{command}\"."
+ (with-temp-eshell
+ (should (equal (eshell-insert-and-complete "{ listif")
+ "{ listify ")))
+ (with-temp-eshell
+ (should (equal (eshell-insert-and-complete "echo ${ listif")
+ "echo ${ listify "))))
+
+(ert-deftest em-cmpl-test/lisp-symbol-completion ()
+ "Test completion of Lisp forms like \"#'symbol\" and \"`symbol\".
+See <lisp/eshell/esh-cmd.el>."
+ (with-temp-eshell
+ (should (equal (eshell-insert-and-complete "echo #'system-nam")
+ "echo #'system-name ")))
+ (with-temp-eshell
+ (should (equal (eshell-insert-and-complete "echo `system-nam")
+ "echo `system-name "))))
+
+(ert-deftest em-cmpl-test/lisp-function-completion ()
+ "Test completion of Lisp forms like \"(func)\".
+See <lisp/eshell/esh-cmd.el>."
+ (with-temp-eshell
+ (should (equal (eshell-insert-and-complete "echo (eshell/ech")
+ "echo (eshell/echo")))
+ (with-temp-eshell
+ (should (equal (eshell-insert-and-complete "echo $(eshell/ech")
+ "echo $(eshell/echo"))))
+
+(ert-deftest em-cmpl-test/special-ref-completion/type ()
+ "Test completion of the start of special reference types like \"#<buffer\".
+See <lisp/eshell/esh-arg.el>."
+ (with-temp-eshell
+ (should (equal (eshell-insert-and-complete "echo hi > #<buf")
+ "echo hi > #<buffer ")))
+ (with-temp-eshell
+ (should (equal (eshell-insert-and-complete "echo hi > #<proc")
+ "echo hi > #<process ")))
+ (with-temp-eshell
+ (should (equal (eshell-insert-and-complete "echo hi > #<mark")
+ "echo hi > #<marker "))))
+
+(ert-deftest em-cmpl-test/special-ref-completion/implicit-buffer ()
+ "Test completion of special references like \"#<buf>\".
+See <lisp/eshell/esh-arg.el>."
+ (let (bufname)
+ (with-temp-buffer
+ (setq bufname (rename-buffer "my-buffer" t))
+ (with-temp-eshell
+ (should (equal (eshell-insert-and-complete "echo hi > #<my-buf")
+ (format "echo hi > #<%s> " bufname))))
+ (setq bufname (rename-buffer "another buffer" t))
+ (with-temp-eshell
+ (should (equal (eshell-insert-and-complete "echo hi > #<anoth")
+ (format "echo hi > #<%s> "
+ (string-replace " " "\\ " bufname))))))))
+
+(ert-deftest em-cmpl-test/special-ref-completion/buffer ()
+ "Test completion of special references like \"#<buffer buf>\".
+See <lisp/eshell/esh-arg.el>."
+ (let (bufname)
+ (with-temp-buffer
+ (setq bufname (rename-buffer "my-buffer" t))
+ (with-temp-eshell
+ (should (equal (eshell-insert-and-complete "echo hi > #<buffer my-buf")
+ (format "echo hi > #<buffer %s> " bufname))))
+ (setq bufname (rename-buffer "another buffer" t))
+ (with-temp-eshell
+ (should (equal (eshell-insert-and-complete "echo hi > #<buffer anoth")
+ (format "echo hi > #<buffer %s> "
+ (string-replace " " "\\ " bufname))))))))
+
+(ert-deftest em-cmpl-test/special-ref-completion/marker ()
+ "Test completion of special references like \"#<marker 1 buf>\".
+See <lisp/eshell/esh-arg.el>."
+ (let (bufname)
+ (with-temp-buffer
+ (setq bufname (rename-buffer "my-buffer" t))
+ ;; Complete the buffer name in various forms.
+ (with-temp-eshell
+ (should (equal (eshell-insert-and-complete
+ "echo hi > #<marker 1 my-buf")
+ (format "echo hi > #<marker 1 %s> " bufname))))
+ (with-temp-eshell
+ (should (equal (eshell-insert-and-complete
+ "echo hi > #<marker 1 #<my-buf")
+ (format "echo hi > #<marker 1 #<%s>> " bufname))))
+ (with-temp-eshell
+ (should (equal (eshell-insert-and-complete
+ "echo hi > #<marker 1 #<buffer my-buf")
+ (format "echo hi > #<marker 1 #<buffer %s>> " bufname))))
+ ;; Partially-complete the "buffer" type name.
+ (with-temp-eshell
+ (should (equal (eshell-insert-and-complete
+ "echo hi > #<marker 1 #<buf")
+ "echo hi > #<marker 1 #<buffer "))))))
+
+(ert-deftest em-cmpl-test/variable-ref-completion ()
+ "Test completion of variable references like \"$var\".
+See <lisp/eshell/esh-var.el>."
+ (with-temp-eshell
+ (should (equal (eshell-insert-and-complete "echo $system-nam")
+ "echo $system-name "))))
+
+(ert-deftest em-cmpl-test/quoted-variable-ref-completion ()
+ "Test completion of variable references like \"$'var'\".
+See <lisp/eshell/esh-var.el>."
+ (with-temp-eshell
+ (should (equal (eshell-insert-and-complete "echo $'system-nam")
+ "echo $'system-name' ")))
+ (with-temp-eshell
+ (should (equal (eshell-insert-and-complete "echo $\"system-nam")
+ "echo $\"system-name\" "))))
+
+(ert-deftest em-cmpl-test/variable-ref-completion/directory ()
+ "Test completion of variable references that expand to directories.
+See <lisp/eshell/esh-var.el>."
+ (with-temp-eshell
+ (should (equal (eshell-insert-and-complete "echo $PW")
+ "echo $PWD/")))
+ (with-temp-eshell
+ (let ((minibuffer-message-timeout 0)
+ (inhibit-message t))
+ (should (equal (eshell-insert-and-complete "echo $PWD")
+ "echo $PWD/"))))
+ (with-temp-eshell
+ (should (equal (eshell-insert-and-complete "echo $'PW")
+ "echo $'PWD'/"))))
+
+(ert-deftest em-cmpl-test/variable-assign-completion ()
+ "Test completion of variable assignments like \"var=value\".
+See <lisp/eshell/esh-var.el>."
+ (with-temp-eshell
+ (ert-with-temp-directory default-directory
+ (write-region nil nil (expand-file-name "file.txt"))
+ (should (equal (eshell-insert-and-complete "VAR=f")
+ "VAR=file.txt ")))))
+
+(ert-deftest em-cmpl-test/variable-assign-completion/non-assignment ()
+ "Test completion of things that look like variable assignment, but aren't.
+For example, the second argument in \"tar --directory=dir\" looks
+like it could be a variable assignment, but it's not. We should
+let `pcomplete/tar' handle it instead.
+
+See <lisp/eshell/esh-var.el>."
+ (with-temp-eshell
+ (ert-with-temp-directory default-directory
+ (write-region nil nil (expand-file-name "file.txt"))
+ (make-directory "dir")
+ (should (equal (eshell-insert-and-complete "tar --directory=")
+ "tar --directory=dir/")))))
+
+(ert-deftest em-cmpl-test/user-ref-completion ()
+ "Test completion of user references like \"~user\".
+See <lisp/eshell/em-dirs.el>."
+ (unwind-protect
+ (with-temp-eshell
+ (cl-letf (((symbol-function 'eshell-read-user-names)
+ (lambda () (setq eshell-user-names '((1234 . "user"))))))
+ (should (equal (eshell-insert-and-complete "echo ~us")
+ "echo ~user/"))))
+ ;; Clear the cached user names we set above.
+ (setq eshell-user-names nil)))
+
+;;; em-cmpl-tests.el ends here
diff --git a/test/lisp/eshell/em-dirs-tests.el b/test/lisp/eshell/em-dirs-tests.el
index f6784340eb4..9789e519f4c 100644
--- a/test/lisp/eshell/em-dirs-tests.el
+++ b/test/lisp/eshell/em-dirs-tests.el
@@ -34,6 +34,9 @@
default-directory))))
;;; Tests:
+
+;; Variables
+
(ert-deftest em-dirs-test/pwd-var ()
"Test using the $PWD variable."
(let ((default-directory "/some/path"))
@@ -99,4 +102,46 @@
(eshell-match-command-output "echo $-[1][/ 1 3]"
"(\"some\" \"here\")\n"))))
+
+;; Argument expansion
+
+(ert-deftest em-dirs-test/expand-user-reference/local ()
+ "Test expansion of \"~USER\" references."
+ (eshell-command-result-equal "echo ~" (expand-file-name "~"))
+ (eshell-command-result-equal
+ (format "echo ~%s" user-login-name)
+ (expand-file-name (format "~%s" user-login-name))))
+
+(ert-deftest em-dirs-test/expand-user-reference/quoted ()
+ "Test that a quoted \"~\" isn't expanded."
+ (eshell-command-result-equal "echo \\~" "~")
+ (eshell-command-result-equal "echo \"~\"" "~")
+ (eshell-command-result-equal "echo '~'" "~"))
+
+
+;; `cd'
+
+(ert-deftest em-dirs-test/cd ()
+ "Test that changing directories with `cd' works."
+ (ert-with-temp-directory tmpdir
+ (write-region "text" nil (expand-file-name "file.txt" tmpdir))
+ (with-temp-eshell
+ (eshell-match-command-output (format "cd '%s'" tmpdir)
+ "\\`\\'")
+ (should (equal default-directory tmpdir)))))
+
+(ert-deftest em-dirs-test/cd/list-files-after-cd ()
+ "Test that listing files after `cd' works."
+ (let ((eshell-list-files-after-cd t))
+ (ert-with-temp-directory tmpdir
+ (write-region "text" nil (expand-file-name "file.txt" tmpdir))
+ (with-temp-eshell
+ (eshell-match-command-output (format "cd '%s'" tmpdir)
+ "file.txt\n")
+ (should (equal default-directory tmpdir))
+ ;; Make sure we didn't update the last-command information when
+ ;; running "ls".
+ (should (equal eshell-last-command-name "#<function eshell/cd>"))
+ (should (equal eshell-last-arguments (list tmpdir)))))))
+
;; em-dirs-tests.el ends here
diff --git a/test/lisp/eshell/em-extpipe-tests.el b/test/lisp/eshell/em-extpipe-tests.el
index 668dcba7c44..610e3d41524 100644
--- a/test/lisp/eshell/em-extpipe-tests.el
+++ b/test/lisp/eshell/em-extpipe-tests.el
@@ -42,32 +42,37 @@
(shell-command-switch "-c"))
;; Strip `eshell-trap-errors'.
(should (equal ,expected
- (cadr (eshell-parse-command input))))))
+ (cadadr (eshell-parse-command input))))))
(with-substitute-for-temp (&rest body)
;; Substitute name of an actual temporary file and/or
;; buffer into `input'. The substitution logic is
;; appropriate for only the use we put it to in this file.
`(ert-with-temp-file temp
- (let ((temp-buffer (generate-new-buffer " *temp*" t)))
+ (let ((temp-buffer (generate-new-buffer " *tmp*" t)))
(unwind-protect
(let ((input
(replace-regexp-in-string
"temp\\([^>]\\|\\'\\)" temp
- (string-replace "#<buffer temp>"
- (buffer-name temp-buffer)
- input))))
+ (string-replace
+ "#<buffer temp>"
+ (format "#<buffer %s>"
+ (eshell-quote-argument
+ (buffer-name temp-buffer)))
+ input))))
,@body)
(when (buffer-name temp-buffer)
(kill-buffer temp-buffer))))))
(temp-should-string= (expected)
- `(string= ,expected (string-trim-right
- (with-temp-buffer
- (insert-file-contents temp)
- (buffer-string)))))
+ `(should (string= ,expected
+ (string-trim-right
+ (with-temp-buffer
+ (insert-file-contents temp)
+ (buffer-string))))))
(temp-buffer-should-string= (expected)
- `(string= ,expected (string-trim-right
- (with-current-buffer temp-buffer
- (buffer-string))))))
+ `(should (string= ,expected
+ (string-trim-right
+ (with-current-buffer temp-buffer
+ (buffer-string)))))))
(skip-unless shell-file-name)
(skip-unless shell-command-switch)
(skip-unless (executable-find shell-file-name))
@@ -107,7 +112,7 @@
'(progn
(ignore
(eshell-set-output-handle 1 'overwrite
- (get-buffer-create "temp")))
+ (eshell-get-buffer "temp")))
(eshell-named-command "sh"
(list "-c" "echo \"bar\" | rev"))))
(with-substitute-for-temp
@@ -130,7 +135,7 @@
'(progn
(ignore
(eshell-set-output-handle 1 'overwrite
- (get-buffer-create "quux")))
+ (eshell-get-buffer "quux")))
(ignore
(eshell-set-output-handle 1 'append
(get-process "other")))
diff --git a/test/lisp/eshell/em-glob-tests.el b/test/lisp/eshell/em-glob-tests.el
index 44d7b1fa60d..fc460a59eed 100644
--- a/test/lisp/eshell/em-glob-tests.el
+++ b/test/lisp/eshell/em-glob-tests.el
@@ -26,6 +26,13 @@
(require 'ert)
(require 'em-glob)
+(require 'eshell-tests-helpers
+ (expand-file-name "eshell-tests-helpers"
+ (file-name-directory (or load-file-name
+ default-directory))))
+
+(defvar eshell-prefer-lisp-functions)
+
(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
@@ -54,6 +61,90 @@ component ending in \"symlink\" is treated as a symbolic link."
;;; Tests:
+
+;; Glob expansion
+
+(ert-deftest em-glob-test/expand/splice-results ()
+ "Test that globs are spliced into the argument list when
+`eshell-glob-splice-results' is non-nil."
+ (let ((eshell-prefer-lisp-functions t)
+ (eshell-glob-splice-results t))
+ (with-fake-files '("a.el" "b.el" "c.txt")
+ ;; Ensure the default expansion splices the glob.
+ (eshell-command-result-equal "list *.el" '("a.el" "b.el"))
+ (eshell-command-result-equal "list *.txt" '("c.txt"))
+ (eshell-command-result-equal "list *.no" '("*.no")))))
+
+(ert-deftest em-glob-test/expand/no-splice-results ()
+ "Test that globs are treated as lists when
+`eshell-glob-splice-results' is nil."
+ (let ((eshell-prefer-lisp-functions t)
+ (eshell-glob-splice-results nil))
+ (with-fake-files '("a.el" "b.el" "c.txt")
+ ;; Ensure the default expansion splices the glob.
+ (eshell-command-result-equal "list *.el" '(("a.el" "b.el")))
+ (eshell-command-result-equal "list *.txt" '(("c.txt")))
+ ;; The no-matches case is special here: the glob is just the
+ ;; string, not the list of results.
+ (eshell-command-result-equal "list *.no" '("*.no")))))
+
+(ert-deftest em-glob-test/expand/explicitly-splice-results ()
+ "Test explicitly splicing globs works the same no matter the
+value of `eshell-glob-splice-results'."
+ (let ((eshell-prefer-lisp-functions t))
+ (dolist (eshell-glob-splice-results '(nil t))
+ (ert-info ((format "eshell-glob-splice-results: %s"
+ eshell-glob-splice-results))
+ (with-fake-files '("a.el" "b.el" "c.txt")
+ (eshell-command-result-equal "list $@{listify *.el}"
+ '("a.el" "b.el"))
+ (eshell-command-result-equal "list $@{listify *.txt}"
+ '("c.txt"))
+ (eshell-command-result-equal "list $@{listify *.no}"
+ '("*.no")))))))
+
+(ert-deftest em-glob-test/expand/explicitly-listify-results ()
+ "Test explicitly listifying globs works the same no matter the
+value of `eshell-glob-splice-results'."
+ (let ((eshell-prefer-lisp-functions t))
+ (dolist (eshell-glob-splice-results '(nil t))
+ (ert-info ((format "eshell-glob-splice-results: %s"
+ eshell-glob-splice-results))
+ (with-fake-files '("a.el" "b.el" "c.txt")
+ (eshell-command-result-equal "list ${listify *.el}"
+ '(("a.el" "b.el")))
+ (eshell-command-result-equal "list ${listify *.txt}"
+ '(("c.txt")))
+ (eshell-command-result-equal "list ${listify *.no}"
+ '(("*.no"))))))))
+
+
+;; Glob conversion
+
+(ert-deftest em-glob-test/convert/current-start-directory ()
+ "Test converting a glob starting in the current directory."
+ (should (equal (eshell-glob-convert "*.el")
+ '("./" (("\\`.*\\.el\\'" . "\\`\\.")) nil))))
+
+(ert-deftest em-glob-test/convert/relative-start-directory ()
+ "Test converting a glob starting in a relative directory."
+ (should (equal (eshell-glob-convert "some/where/*.el")
+ '("./some/where/" (("\\`.*\\.el\\'" . "\\`\\.")) nil))))
+
+(ert-deftest em-glob-test/convert/absolute-start-directory ()
+ "Test converting a glob starting in an absolute directory."
+ (should (equal (eshell-glob-convert "/some/where/*.el")
+ '("/some/where/" (("\\`.*\\.el\\'" . "\\`\\.")) nil))))
+
+(ert-deftest em-glob-test/convert/remote-start-directory ()
+ "Test converting a glob starting in a remote directory."
+ (should (equal (eshell-glob-convert "/ssh:nowhere.invalid:some/where/*.el")
+ '("/ssh:nowhere.invalid:/some/where/"
+ (("\\`.*\\.el\\'" . "\\`\\.")) nil))))
+
+
+;; Glob matching
+
(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")
@@ -191,6 +282,9 @@ component ending in \"symlink\" is treated as a symbolic link."
(with-fake-files '("foo.el" "bar.el")
(should (equal (eshell-extended-glob "*.txt")
"*.txt"))
+ (let ((eshell-glob-splice-results t))
+ (should (equal (eshell-extended-glob "*.txt")
+ '("*.txt"))))
(let ((eshell-error-if-no-glob t))
(should-error (eshell-extended-glob "*.txt")))))
diff --git a/test/lisp/eshell/em-hist-tests.el b/test/lisp/eshell/em-hist-tests.el
index d325e3a6402..a4e1e01b124 100644
--- a/test/lisp/eshell/em-hist-tests.el
+++ b/test/lisp/eshell/em-hist-tests.el
@@ -19,11 +19,107 @@
;;; Code:
+(eval-when-compile
+ (require 'cl-lib))
+
(require 'ert)
(require 'ert-x)
(require 'em-hist)
+(require 'eshell)
+
+(require 'eshell-tests-helpers
+ (expand-file-name "eshell-tests-helpers"
+ (file-name-directory (or load-file-name
+ default-directory))))
+
+(cl-defun em-hist-test/check-history-file (file-name expected &optional
+ (expected-ring t))
+ "Check that the contents of FILE-NAME match the EXPECTED history entries.
+Additionally, check that after loading the file, the history ring
+matches too. If EXPECTED-RING is a list, compare the ring
+elements against that; if t (the default), check against EXPECTED."
+ (when (eq expected-ring t) (setq expected-ring expected))
+ ;; First check the actual file.
+ (should (equal (with-temp-buffer
+ (insert-file-contents file-name)
+ (buffer-string))
+ (mapconcat (lambda (i) (concat i "\n")) expected)))
+ ;; Now read the history ring and check that too.
+ (let (eshell-history-ring eshell-history-index eshell-hist--new-items)
+ (eshell-read-history file-name)
+ (should (equal (nreverse (ring-elements eshell-history-ring))
+ expected-ring))))
+
+;;; Tests:
+
+(ert-deftest em-hist-test/write-history/append ()
+ "Test appending new history to history file."
+ (ert-with-temp-file histfile
+ (with-temp-eshell
+ (em-hist-test/check-history-file histfile nil)
+ (eshell-insert-command "echo hi")
+ (eshell-write-history histfile 'append)
+ (em-hist-test/check-history-file histfile '("echo hi"))
+ (eshell-insert-command "echo bye")
+ (eshell-write-history histfile 'append)
+ (em-hist-test/check-history-file histfile '("echo hi" "echo bye")))))
+
+(ert-deftest em-hist-test/write-history/append-multiple-eshells ()
+ "Test appending new history to history file from multiple Eshells."
+ (ert-with-temp-file histfile
+ (with-temp-eshell
+ (with-temp-eshell
+ ;; Enter some commands and save them.
+ (eshell-insert-command "echo foo")
+ (eshell-insert-command "echo bar")
+ (eshell-write-history histfile 'append)
+ (em-hist-test/check-history-file histfile '("echo foo" "echo bar")))
+ ;; Now do the same in the first Eshell buffer.
+ (eshell-insert-command "echo goat")
+ (eshell-insert-command "echo panda")
+ (eshell-write-history histfile 'append)
+ (em-hist-test/check-history-file
+ histfile '("echo foo" "echo bar" "echo goat" "echo panda")))))
-(ert-deftest eshell-write-readonly-history ()
+(ert-deftest em-hist-test/write-history/overwrite ()
+ "Test overwriting history file."
+ (ert-with-temp-file histfile
+ (with-temp-eshell
+ (em-hist-test/check-history-file histfile nil)
+ (eshell-insert-command "echo hi")
+ (eshell-insert-command "echo bye")
+ (eshell-insert-command "echo bye")
+ (eshell-insert-command "echo hi")
+ (eshell-write-history histfile)
+ (em-hist-test/check-history-file
+ histfile '("echo hi" "echo bye" "echo bye" "echo hi"))
+ (let ((eshell-hist-ignoredups t))
+ (em-hist-test/check-history-file
+ histfile '("echo hi" "echo bye" "echo bye" "echo hi")
+ '("echo hi" "echo bye" "echo hi")))
+ (let ((eshell-hist-ignoredups 'erase))
+ (em-hist-test/check-history-file
+ histfile '("echo hi" "echo bye" "echo bye" "echo hi")
+ '("echo bye" "echo hi"))))))
+
+(ert-deftest em-hist-test/write-history/overwrite-multiple-shells ()
+ "Test overwriting history file from multiple Eshells."
+ (ert-with-temp-file histfile
+ (with-temp-eshell
+ (with-temp-eshell
+ ;; Enter some commands and save them.
+ (eshell-insert-command "echo foo")
+ (eshell-insert-command "echo bar")
+ (eshell-write-history histfile)
+ (em-hist-test/check-history-file histfile '("echo foo" "echo bar")))
+ ;; Now do the same in the first Eshell buffer.
+ (eshell-insert-command "echo goat")
+ (eshell-insert-command "echo panda")
+ (eshell-write-history histfile)
+ (em-hist-test/check-history-file
+ histfile '("echo goat" "echo panda")))))
+
+(ert-deftest em-hist-test/write-history/read-only ()
"Test that having read-only strings in history is okay."
(ert-with-temp-file histfile
(let ((eshell-history-ring (make-ring 2)))
@@ -31,7 +127,41 @@
(propertize "echo foo" 'read-only t))
(ring-insert eshell-history-ring
(propertize "echo bar" 'read-only t))
- (eshell-write-history histfile))))
+ (eshell-write-history histfile)
+ (em-hist-test/check-history-file histfile '("echo foo" "echo bar")))))
+
+(ert-deftest em-hist-test/add-to-history/allow-dups ()
+ "Test adding to history, allowing dups."
+ (let ((eshell-hist-ignoredups nil))
+ (with-temp-eshell
+ (eshell-insert-command "echo hi")
+ (eshell-insert-command "echo bye")
+ (eshell-insert-command "echo bye")
+ (eshell-insert-command "echo hi")
+ (should (equal (ring-elements eshell-history-ring)
+ '("echo hi" "echo bye" "echo bye" "echo hi"))))))
+
+(ert-deftest em-hist-test/add-to-history/no-consecutive-dups ()
+ "Test adding to history, ignoring consecutive dups."
+ (let ((eshell-hist-ignoredups t))
+ (with-temp-eshell
+ (eshell-insert-command "echo hi")
+ (eshell-insert-command "echo bye")
+ (eshell-insert-command "echo bye")
+ (eshell-insert-command "echo hi")
+ (should (equal (ring-elements eshell-history-ring)
+ '("echo hi" "echo bye" "echo hi"))))))
+
+(ert-deftest em-hist-test/add-to-history/erase-dups ()
+ "Test adding to history, erasing any old dups."
+ (let ((eshell-hist-ignoredups 'erase))
+ (with-temp-eshell
+ (eshell-insert-command "echo hi")
+ (eshell-insert-command "echo bye")
+ (eshell-insert-command "echo bye")
+ (eshell-insert-command "echo hi")
+ (should (equal (ring-elements eshell-history-ring)
+ '("echo hi" "echo bye"))))))
(provide 'em-hist-test)
diff --git a/test/lisp/eshell/em-prompt-tests.el b/test/lisp/eshell/em-prompt-tests.el
new file mode 100644
index 00000000000..964609e6410
--- /dev/null
+++ b/test/lisp/eshell/em-prompt-tests.el
@@ -0,0 +1,192 @@
+;;; em-prompt-tests.el --- em-prompt test suite -*- lexical-binding:t -*-
+
+;; Copyright (C) 2023-2024 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 <https://www.gnu.org/licenses/>.
+
+;;; Commentary:
+
+;; Tests for Eshell's prompt support.
+
+;;; Code:
+
+(require 'ert)
+(require 'eshell)
+(require 'em-prompt)
+
+(require 'eshell-tests-helpers
+ (expand-file-name "eshell-tests-helpers"
+ (file-name-directory (or load-file-name
+ default-directory))))
+
+(defmacro em-prompt-test--with-multiline (&rest body)
+ "Execute BODY with a multiline Eshell prompt."
+ `(let ((eshell-prompt-function (lambda () "multiline prompt\n$ ")))
+ ,@body))
+
+;;; Tests:
+
+(ert-deftest em-prompt-test/field-properties ()
+ "Check that field properties are properly set on Eshell output/prompts."
+ (with-temp-eshell
+ (eshell-insert-command "echo hello")
+ (let ((last-prompt (field-string (1- eshell-last-input-start)))
+ (last-input (field-string (1+ eshell-last-input-start)))
+ (last-output (field-string (1+ eshell-last-input-end))))
+ (should (equal-including-properties
+ last-prompt
+ (propertize
+ (format "%s %s " (directory-file-name default-directory)
+ (if (= (file-user-uid) 0) "#" "$"))
+ 'read-only t
+ 'field 'prompt
+ 'font-lock-face 'eshell-prompt
+ 'front-sticky '(read-only field font-lock-face)
+ 'rear-nonsticky '(read-only field font-lock-face))))
+ (should (equal last-input "echo hello\n"))
+ (should (equal-including-properties
+ last-output
+ (apply #'propertize "hello\n"
+ eshell-command-output-properties))))))
+
+(ert-deftest em-prompt-test/field-properties/no-highlight ()
+ "Check that field properties are properly set on Eshell output/prompts.
+This tests the case when `eshell-highlight-prompt' is nil."
+ (let ((eshell-highlight-prompt nil))
+ (with-temp-eshell
+ (eshell-insert-command "echo hello")
+ (let ((last-prompt (field-string (1- eshell-last-input-start)))
+ (last-input (field-string (1+ eshell-last-input-start)))
+ (last-output (field-string (1+ eshell-last-input-end))))
+ (should (equal-including-properties
+ last-prompt
+ (propertize
+ (format "%s %s " (directory-file-name default-directory)
+ (if (= (file-user-uid) 0) "#" "$"))
+ 'field 'prompt
+ 'front-sticky '(field)
+ 'rear-nonsticky '(field))))
+ (should (equal last-input "echo hello\n"))
+ (should (equal-including-properties
+ last-output
+ (apply #'propertize "hello\n"
+ eshell-command-output-properties)))))))
+
+(ert-deftest em-prompt-test/after-failure ()
+ "Check that current prompt shows the exit code of the last failed command."
+ (with-temp-eshell
+ (let ((debug-on-error nil))
+ (eshell-insert-command "(zerop \"foo\")"))
+ (let ((current-prompt (field-string (1- (point)))))
+ (should (equal-including-properties
+ current-prompt
+ (propertize
+ (concat (directory-file-name default-directory)
+ (unless (eshell-exit-success-p)
+ (format " [%d]" eshell-last-command-status))
+ (if (= (file-user-uid) 0) " # " " $ "))
+ 'read-only t
+ 'field 'prompt
+ 'font-lock-face 'eshell-prompt
+ 'front-sticky '(read-only field font-lock-face)
+ 'rear-nonsticky '(read-only field font-lock-face)))))))
+
+(defun em-prompt-test/next-previous-prompt-1 ()
+ "Helper for checking forward/backward navigation of old prompts."
+ (with-temp-eshell
+ (eshell-insert-command "echo one")
+ (eshell-insert-command "echo two")
+ (eshell-insert-command "echo three")
+ (let ((debug-on-error nil)) ; A failed command.
+ (eshell-insert-command "(zerop \"foo\")"))
+ (insert "echo fou") ; A partially-entered command.
+ (ert-info ("Go back one prompt")
+ (eshell-previous-prompt)
+ (should (equal (point) (field-beginning)))
+ (should (equal (field-string) "(zerop \"foo\")\n")))
+ (ert-info ("Go back three prompts, starting from the end of the input")
+ (end-of-line)
+ (eshell-previous-prompt 3)
+ (should (equal (point) (field-beginning)))
+ (should (equal (field-string) "echo one\n")))
+ (ert-info ("Go to the current prompt, starting from the end of the input")
+ (end-of-line)
+ (eshell-previous-prompt 0)
+ (should (equal (point) (field-beginning)))
+ (should (equal (field-string) "echo one\n")))
+ (ert-info ("Go forward one prompt")
+ (eshell-next-prompt)
+ (should (equal (point) (field-beginning)))
+ (should (equal (field-string) "echo two\n")))
+ (ert-info ("Go forward three prompts")
+ (eshell-next-prompt 3)
+ (should (equal (point) (field-beginning)))
+ (should (equal (field-string) "echo fou")))
+ (ert-info ("Go back one prompt, starting from the beginning of the line")
+ (forward-line 0)
+ (eshell-previous-prompt 1)
+ (should (equal (point) (field-beginning)))
+ (should (equal (field-string) "(zerop \"foo\")\n")))
+ (ert-info ("Go back one prompt, starting from the previous prompt's output")
+ (forward-line -1)
+ (eshell-previous-prompt 1)
+ (should (equal (point) (field-beginning)))
+ (should (equal (field-string) "echo three\n")))))
+
+(ert-deftest em-prompt-test/next-previous-prompt ()
+ "Check that navigating forward/backward through old prompts works correctly."
+ (em-prompt-test/next-previous-prompt-1))
+
+(ert-deftest em-prompt-test/next-previous-prompt-multiline ()
+ "Check old prompt forward/backward navigation for multiline prompts."
+ (em-prompt-test--with-multiline
+ (em-prompt-test/next-previous-prompt-1)))
+
+(defun em-prompt-test/forward-backward-matching-input-1 ()
+ "Helper for checking forward/backward navigation via regexps."
+ (with-temp-eshell
+ (eshell-insert-command "echo one")
+ (eshell-insert-command "printnl something else")
+ (eshell-insert-command "echo two")
+ (eshell-insert-command "echo three")
+ (let ((debug-on-error nil)) ; A failed command.
+ (eshell-insert-command "(zerop \"foo\")"))
+ (insert "echo fou") ; A partially-entered command.
+ (ert-info ("Search for \"echo\", back one prompt")
+ (eshell-backward-matching-input "echo" 1)
+ (should (equal (point) (field-beginning)))
+ (should (equal (field-string) "echo three\n")))
+ (ert-info ((concat "Search for \"echo\", back two prompts, "
+ "starting from the end of this line"))
+ (end-of-line)
+ (eshell-backward-matching-input "echo" 2)
+ (should (equal (point) (field-beginning)))
+ (should (equal (field-string) "echo one\n")))
+ (ert-info ("Search for \"echo\", forward three prompts")
+ (eshell-forward-matching-input "echo" 3)
+ (should (equal (point) (field-beginning)))
+ (should (equal (field-string) "echo fou")))))
+
+(ert-deftest em-prompt-test/forward-backward-matching-input ()
+ "Check that navigating forward/backward via regexps works correctly."
+ (em-prompt-test/forward-backward-matching-input-1))
+
+(ert-deftest em-prompt-test/forward-backward-matching-input-multiline ()
+ "Check forward/backward regexp navigation for multiline prompts."
+ (em-prompt-test--with-multiline
+ (em-prompt-test/forward-backward-matching-input-1)))
+
+;;; em-prompt-tests.el ends here
diff --git a/test/lisp/eshell/em-script-tests.el b/test/lisp/eshell/em-script-tests.el
index 646410ac5a4..f77c4568ea8 100644
--- a/test/lisp/eshell/em-script-tests.el
+++ b/test/lisp/eshell/em-script-tests.el
@@ -35,21 +35,56 @@
;;; Tests:
(ert-deftest em-script-test/source-script ()
- "Test sourcing script with no argumentss"
+ "Test sourcing a simple script."
(ert-with-temp-file temp-file :text "echo hi"
(with-temp-eshell
(eshell-match-command-output (format "source %s" temp-file)
"hi\n"))))
-(ert-deftest em-script-test/source-script-arg-vars ()
- "Test sourcing script with $0, $1, ... variables"
+(ert-deftest em-script-test/source-script/redirect ()
+ "Test sourcing a script and redirecting its output."
+ (ert-with-temp-file temp-file
+ :text "echo hi\necho bye"
+ (eshell-with-temp-buffer bufname "old"
+ (with-temp-eshell
+ (eshell-match-command-output
+ (format "source %s > #<%s>" temp-file bufname)
+ "\\`\\'"))
+ (should (equal (buffer-string) "hibye")))))
+
+(ert-deftest em-script-test/source-script/redirect/dev-null ()
+ "Test sourcing a script and redirecting its output, including to /dev/null."
+ (ert-with-temp-file temp-file
+ :text "echo hi\necho bad > /dev/null\necho bye"
+ (eshell-with-temp-buffer bufname "old"
+ (with-temp-eshell
+ (eshell-match-command-output
+ (format "source %s > #<%s>" temp-file bufname)
+ "\\`\\'"))
+ (should (equal (buffer-string) "hibye")))))
+
+(ert-deftest em-script-test/source-script/background ()
+ "Test sourcing a script in the background."
+ (skip-unless (executable-find "echo"))
+ (ert-with-temp-file temp-file
+ :text "*echo hi\nif {[ foo = foo ]} {*echo bye}"
+ (eshell-with-temp-buffer bufname "old"
+ (with-temp-eshell
+ (eshell-match-command-output
+ (format "source %s > #<%s> &" temp-file bufname)
+ "\\`\\'")
+ (eshell-wait-for-subprocess t))
+ (should (equal (buffer-string) "hi\nbye\n")))))
+
+(ert-deftest em-script-test/source-script/arg-vars ()
+ "Test sourcing script with $0, $1, ... variables."
(ert-with-temp-file temp-file :text "printnl $0 \"$1 $2\""
(with-temp-eshell
(eshell-match-command-output (format "source %s one two" temp-file)
(format "%s\none two\n" temp-file)))))
-(ert-deftest em-script-test/source-script-all-args-var ()
- "Test sourcing script with the $* variable"
+(ert-deftest em-script-test/source-script/all-args-var ()
+ "Test sourcing script with the $* variable."
(ert-with-temp-file temp-file :text "printnl $*"
(with-temp-eshell
(eshell-match-command-output (format "source %s" temp-file)
diff --git a/test/lisp/eshell/em-tramp-tests.el b/test/lisp/eshell/em-tramp-tests.el
index 2cc6808fe94..3be5d3542ca 100644
--- a/test/lisp/eshell/em-tramp-tests.el
+++ b/test/lisp/eshell/em-tramp-tests.el
@@ -23,141 +23,128 @@
(require 'em-tramp)
(require 'tramp)
+(defmacro em-tramp-test/should-replace-command (form replacement)
+ "Check that calling FORM results in it being replaced with REPLACEMENT."
+ (declare (indent 1))
+ `(should (equal
+ (catch 'eshell-replace-command ,form)
+ (list 'eshell-with-copied-handles
+ (list 'eshell-trap-errors
+ ,replacement)
+ t))))
+
(ert-deftest em-tramp-test/su-default ()
"Test Eshell `su' command with no arguments."
- (should (equal
- (catch 'eshell-replace-command (eshell/su))
- `(eshell-trap-errors
- (eshell-named-command
- "cd"
- (list ,(format "/su:root@%s:%s"
- tramp-default-host default-directory)))))))
+ (em-tramp-test/should-replace-command (eshell/su)
+ `(eshell-named-command
+ "cd"
+ (list ,(format "/su:root@%s:%s"
+ tramp-default-host default-directory)))))
(ert-deftest em-tramp-test/su-user ()
"Test Eshell `su' command with USER argument."
- (should (equal
- (catch 'eshell-replace-command (eshell/su "USER"))
- `(eshell-trap-errors
- (eshell-named-command
- "cd"
- (list ,(format "/su:USER@%s:%s"
- tramp-default-host default-directory)))))))
+ (em-tramp-test/should-replace-command (eshell/su "USER")
+ `(eshell-named-command
+ "cd"
+ (list ,(format "/su:USER@%s:%s"
+ tramp-default-host default-directory)))))
(ert-deftest em-tramp-test/su-login ()
"Test Eshell `su' command with -/-l/--login option."
(dolist (args '(("--login")
("-l")
("-")))
- (should (equal
- (catch 'eshell-replace-command (apply #'eshell/su args))
- `(eshell-trap-errors
- (eshell-named-command
- "cd"
- (list ,(format "/su:root@%s:~/" tramp-default-host))))))))
-
-(defun mock-eshell-named-command (&rest args)
- "Dummy function to test Eshell `sudo' command rewriting."
- (list default-directory args))
+ (em-tramp-test/should-replace-command (apply #'eshell/su args)
+ `(eshell-named-command
+ "cd"
+ (list ,(format "/su:root@%s:~/" tramp-default-host))))))
(ert-deftest em-tramp-test/sudo-basic ()
"Test Eshell `sudo' command with default user."
- (cl-letf (((symbol-function 'eshell-named-command)
- #'mock-eshell-named-command))
- (should (equal
- (catch 'eshell-external (eshell/sudo "echo" "hi"))
- `(,(format "/sudo:root@%s:%s" tramp-default-host default-directory)
- ("echo" ("hi")))))
- (should (equal
- (catch 'eshell-external (eshell/sudo "echo" "-u" "hi"))
- `(,(format "/sudo:root@%s:%s" tramp-default-host default-directory)
- ("echo" ("-u" "hi")))))))
+ (let ((sudo-directory (format "/sudo:root@%s:%s"
+ tramp-default-host default-directory)))
+ (should (equal (catch 'eshell-replace-command
+ (eshell/sudo "echo" "hi"))
+ `(let ((default-directory ,sudo-directory))
+ (eshell-named-command '"echo" '("hi")))))
+ (should (equal (catch 'eshell-replace-command
+ (eshell/sudo "echo" "-u" "hi"))
+ `(let ((default-directory ,sudo-directory))
+ (eshell-named-command '"echo" '("-u" "hi")))))))
(ert-deftest em-tramp-test/sudo-user ()
"Test Eshell `sudo' command with specified user."
- (cl-letf (((symbol-function 'eshell-named-command)
- #'mock-eshell-named-command))
- (should (equal
- (catch 'eshell-external (eshell/sudo "-u" "USER" "echo" "hi"))
- `(,(format "/sudo:USER@%s:%s" tramp-default-host default-directory)
- ("echo" ("hi")))))
- (should (equal
- (catch 'eshell-external (eshell/sudo "-u" "USER" "echo" "-u" "hi"))
- `(,(format "/sudo:USER@%s:%s" tramp-default-host default-directory)
- ("echo" ("-u" "hi")))))))
+ (let ((sudo-directory (format "/sudo:USER@%s:%s"
+ tramp-default-host default-directory)))
+ (should (equal (catch 'eshell-replace-command
+ (eshell/sudo "-u" "USER" "echo" "hi"))
+ `(let ((default-directory ,sudo-directory))
+ (eshell-named-command '"echo" '("hi")))))
+ (should (equal (catch 'eshell-replace-command
+ (eshell/sudo "-u" "USER" "echo" "-u" "hi"))
+ `(let ((default-directory ,sudo-directory))
+ (eshell-named-command '"echo" '("-u" "hi")))))))
(ert-deftest em-tramp-test/sudo-shell ()
"Test Eshell `sudo' command with -s/--shell option."
(dolist (args '(("--shell")
("-s")))
- (should (equal
- (catch 'eshell-replace-command (apply #'eshell/sudo args))
- `(eshell-trap-errors
- (eshell-named-command
- "cd"
- (list ,(format "/sudo:root@%s:%s"
- tramp-default-host default-directory))))))))
+ (em-tramp-test/should-replace-command (apply #'eshell/sudo args)
+ `(eshell-named-command
+ "cd"
+ (list ,(format "/sudo:root@%s:%s"
+ tramp-default-host default-directory))))))
(ert-deftest em-tramp-test/sudo-user-shell ()
"Test Eshell `sudo' command with -s and -u options."
- (should (equal
- (catch 'eshell-replace-command (eshell/sudo "-u" "USER" "-s"))
- `(eshell-trap-errors
- (eshell-named-command
- "cd"
- (list ,(format "/sudo:USER@%s:%s"
- tramp-default-host default-directory)))))))
+ (em-tramp-test/should-replace-command (eshell/sudo "-u" "USER" "-s")
+ `(eshell-named-command
+ "cd"
+ (list ,(format "/sudo:USER@%s:%s"
+ tramp-default-host default-directory)))))
(ert-deftest em-tramp-test/doas-basic ()
"Test Eshell `doas' command with default user."
- (cl-letf (((symbol-function 'eshell-named-command)
- #'mock-eshell-named-command))
- (should (equal
- (catch 'eshell-external (eshell/doas "echo" "hi"))
- `(,(format "/doas:root@%s:%s"
- tramp-default-host default-directory)
- ("echo" ("hi")))))
- (should (equal
- (catch 'eshell-external (eshell/doas "echo" "-u" "hi"))
- `(,(format "/doas:root@%s:%s"
- tramp-default-host default-directory)
- ("echo" ("-u" "hi")))))))
+ (let ((doas-directory (format "/doas:root@%s:%s"
+ tramp-default-host default-directory)))
+ (should (equal (catch 'eshell-replace-command
+ (eshell/doas "echo" "hi"))
+ `(let ((default-directory ,doas-directory))
+ (eshell-named-command '"echo" '("hi")))))
+ (should (equal (catch 'eshell-replace-command
+ (eshell/doas "echo" "-u" "hi"))
+ `(let ((default-directory ,doas-directory))
+ (eshell-named-command '"echo" '("-u" "hi")))))))
(ert-deftest em-tramp-test/doas-user ()
"Test Eshell `doas' command with specified user."
- (cl-letf (((symbol-function 'eshell-named-command)
- #'mock-eshell-named-command))
- (should (equal
- (catch 'eshell-external (eshell/doas "-u" "USER" "echo" "hi"))
- `(,(format "/doas:USER@%s:%s"
- tramp-default-host default-directory)
- ("echo" ("hi")))))
- (should (equal
- (catch 'eshell-external
- (eshell/doas "-u" "USER" "echo" "-u" "hi"))
- `(,(format "/doas:USER@%s:%s"
- tramp-default-host default-directory)
- ("echo" ("-u" "hi")))))))
+ (let ((doas-directory (format "/doas:USER@%s:%s"
+ tramp-default-host default-directory)))
+ (should (equal (catch 'eshell-replace-command
+ (eshell/doas "-u" "USER" "echo" "hi"))
+ `(let ((default-directory ,doas-directory))
+ (eshell-named-command '"echo" '("hi")))))
+ (should (equal (catch 'eshell-replace-command
+ (eshell/doas "-u" "USER" "echo" "-u" "hi"))
+ `(let ((default-directory ,doas-directory))
+ (eshell-named-command '"echo" '("-u" "hi")))))))
(ert-deftest em-tramp-test/doas-shell ()
"Test Eshell `doas' command with -s/--shell option."
(dolist (args '(("--shell")
("-s")))
- (should (equal
- (catch 'eshell-replace-command (apply #'eshell/doas args))
- `(eshell-trap-errors
- (eshell-named-command
- "cd"
- (list ,(format "/doas:root@%s:%s"
- tramp-default-host default-directory))))))))
+ (em-tramp-test/should-replace-command (apply #'eshell/doas args)
+ `(eshell-named-command
+ "cd"
+ (list ,(format "/doas:root@%s:%s"
+ tramp-default-host default-directory))))))
(ert-deftest em-tramp-test/doas-user-shell ()
"Test Eshell `doas' command with -s and -u options."
- (should (equal
- (catch 'eshell-replace-command (eshell/doas "-u" "USER" "-s"))
- `(eshell-trap-errors
- (eshell-named-command
- "cd"
- (list ,(format "/doas:USER@%s:%s"
- tramp-default-host default-directory)))))))
+ (em-tramp-test/should-replace-command (eshell/doas "-u" "USER" "-s")
+ `(eshell-named-command
+ "cd"
+ (list ,(format "/doas:USER@%s:%s"
+ tramp-default-host default-directory)))))
;;; em-tramp-tests.el ends here
diff --git a/test/lisp/eshell/em-unix-tests.el b/test/lisp/eshell/em-unix-tests.el
new file mode 100644
index 00000000000..a92c7d3f80a
--- /dev/null
+++ b/test/lisp/eshell/em-unix-tests.el
@@ -0,0 +1,68 @@
+;;; em-unix-tests.el --- em-unix test suite -*- lexical-binding:t -*-
+
+;; Copyright (C) 2023-2024 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 <https://www.gnu.org/licenses/>.
+
+;;; Commentary:
+
+;; Tests for Eshell's implementation of various UNIX commands.
+
+;;; Code:
+
+(require 'ert)
+(require 'em-unix)
+
+(require 'eshell-tests-helpers
+ (expand-file-name "eshell-tests-helpers"
+ (file-name-directory (or load-file-name
+ default-directory))))
+
+;;; Tests:
+
+(ert-deftest em-unix-test/compile/interactive ()
+ "Check that `eshell/compile' opens a compilation buffer interactively."
+ (skip-unless (executable-find "echo"))
+ (with-temp-eshell
+ (eshell-match-command-output "compile echo hello"
+ "#<buffer \\*compilation\\*>")
+ (with-current-buffer "*compilation*"
+ (forward-line 3)
+ (should (looking-at "echo hello")))))
+
+(ert-deftest em-unix-test/compile/noninteractive ()
+ "Check that `eshell/compile' writes to stdout noninteractively."
+ (skip-unless (executable-find "echo"))
+ (eshell-command-result-equal "compile echo hello"
+ "hello\n"))
+
+(ert-deftest em-unix-test/compile/pipeline ()
+ "Check that `eshell/compile' writes to stdout from a pipeline."
+ (skip-unless (and (executable-find "echo")
+ (executable-find "cat")))
+ (with-temp-eshell
+ (eshell-match-command-output "compile echo hello | *cat"
+ "\\`hello\n")))
+
+(ert-deftest em-unix-test/compile/subcommand ()
+ "Check that `eshell/compile' writes to stdout from a subcommand."
+ (skip-unless (and (executable-find "echo")
+ (executable-find "cat")))
+ (with-temp-eshell
+ (eshell-match-command-output "echo ${compile echo hello}"
+ "\\`hello\n")))
+
+;; em-unix-tests.el ends here
diff --git a/test/lisp/eshell/esh-arg-tests.el b/test/lisp/eshell/esh-arg-tests.el
index a6f69c261e7..b748c5ab4c0 100644
--- a/test/lisp/eshell/esh-arg-tests.el
+++ b/test/lisp/eshell/esh-arg-tests.el
@@ -60,13 +60,17 @@ chars."
"he\\\\llo\n")))
(ert-deftest esh-arg-test/escape/newline ()
- "Test that an escaped newline is equivalent to the empty string.
-When newlines are *nonspecial*, an escaped newline should be
-treated as just a newline."
+ "Test that an escaped newline is equivalent to the empty string."
(with-temp-eshell
(eshell-match-command-output "echo hi\\\nthere"
"hithere\n")))
+(ert-deftest esh-arg-test/escape/trailing-newline ()
+ "Test that an escaped newline is equivalent to the empty string."
+ (with-temp-eshell
+ (eshell-match-command-output "echo hi\\\n"
+ "hi\n")))
+
(ert-deftest esh-arg-test/escape/newline-conditional ()
"Test invocation of an if/else statement using line continuations."
(let ((eshell-test-value t))
@@ -95,11 +99,100 @@ chars."
"\\\"hi\\\\\n")))
(ert-deftest esh-arg-test/escape-quoted/newline ()
- "Test that an escaped newline is equivalent to the empty string.
-When newlines are *nonspecial*, an escaped newline should be
-treated literally, as a backslash and a newline."
+ "Test that an escaped newline is equivalent to the empty string."
(with-temp-eshell
(eshell-match-command-output "echo \"hi\\\nthere\""
"hithere\n")))
+(ert-deftest esh-arg-test/special-reference/default ()
+ "Test that \"#<buf>\" refers to the buffer \"buf\"."
+ (with-temp-buffer
+ (rename-buffer "my-buffer" t)
+ (eshell-command-result-equal
+ (format "echo #<%s>" (buffer-name))
+ (current-buffer))))
+
+(ert-deftest esh-arg-test/special-reference/buffer ()
+ "Test that \"#<buffer buf>\" refers to the buffer \"buf\"."
+ (with-temp-buffer
+ (rename-buffer "my-buffer" t)
+ (eshell-command-result-equal
+ (format "echo #<buffer %s>" (buffer-name))
+ (current-buffer))))
+
+(ert-deftest esh-arg-test/special-reference/marker ()
+ "Test that \"#<marker N buf>\" refers to a marker in the buffer \"buf\"."
+ (with-temp-buffer
+ (rename-buffer "my-buffer" t)
+ (insert "hello")
+ (let ((marker (make-marker)))
+ (set-marker marker 1 (current-buffer))
+ (eshell-command-result-equal
+ (format "echo #<marker 1 %s>" (buffer-name))
+ marker))))
+
+(ert-deftest esh-arg-test/special-reference/quoted ()
+ "Test that '#<buffer \"foo bar\">' refers to the buffer \"foo bar\"."
+ (with-temp-buffer
+ (rename-buffer "foo bar" t)
+ (eshell-command-result-equal
+ (format "echo #<buffer \"%s\">" (buffer-name))
+ (current-buffer))
+ (eshell-command-result-equal
+ (format "echo #<buffer '%s'>" (buffer-name))
+ (current-buffer))))
+
+(ert-deftest esh-arg-test/special-reference/nested ()
+ "Test that nested special references work correctly."
+ (with-temp-buffer
+ (rename-buffer "my-buffer" t)
+ (insert "hello")
+ (let ((marker (make-marker)))
+ (set-marker marker 1 (current-buffer))
+ (eshell-command-result-equal
+ (format "echo #<marker 1 #<%s>>" (buffer-name))
+ marker)
+ (eshell-command-result-equal
+ (format "echo #<marker 1 #<buffer %s>>" (buffer-name))
+ marker))))
+
+(ert-deftest esh-arg-test/special-reference/var-expansion ()
+ "Test that variable expansion inside special references works."
+ (with-temp-buffer
+ (rename-buffer "my-buffer" t)
+ (let ((eshell-test-value (buffer-name)))
+ (eshell-command-result-equal
+ "echo #<buffer $eshell-test-value>"
+ (current-buffer))
+ (eshell-command-result-equal
+ "echo #<buffer \"$eshell-test-value\">"
+ (current-buffer)))))
+
+(ert-deftest esh-arg-test/special-reference/lisp-form ()
+ "Test that Lisp forms inside special references work."
+ (with-temp-eshell
+ (let ((marker (make-marker))
+ eshell-test-value)
+ (set-marker marker 1 (current-buffer))
+ (eshell-insert-command
+ "setq eshell-test-value #<marker 1 (current-buffer)>")
+ (should (equal eshell-test-value marker))
+ (eshell-insert-command
+ "setq eshell-test-value #<marker 1 #<buffer (buffer-name)>>")
+ (should (equal eshell-test-value marker)))))
+
+(ert-deftest esh-arg-test/special-reference/special-characters ()
+ "Test that \"#<...>\" works correctly when escaping special characters."
+ (with-temp-buffer
+ (rename-buffer "<my buffer>" t)
+ (let ((escaped-bufname (replace-regexp-in-string
+ (rx (group (or "\\" "<" ">" space))) "\\\\\\1"
+ (buffer-name))))
+ (eshell-command-result-equal
+ (format "echo #<%s>" escaped-bufname)
+ (current-buffer))
+ (eshell-command-result-equal
+ (format "echo #<buffer %s>" escaped-bufname)
+ (current-buffer)))))
+
;; esh-arg-tests.el ends here
diff --git a/test/lisp/eshell/esh-cmd-tests.el b/test/lisp/eshell/esh-cmd-tests.el
index 4ee2c5bcb0e..ef965a896c1 100644
--- a/test/lisp/eshell/esh-cmd-tests.el
+++ b/test/lisp/eshell/esh-cmd-tests.el
@@ -73,6 +73,62 @@ Test that trailing arguments outside the subcommand are ignored.
e.g. \"{(+ 1 2)} 3\" => 3"
(eshell-command-result-equal "{(+ 1 2)} 3" 3))
+(ert-deftest esh-cmd-test/subcommand-shadow-value ()
+ "Test that the variable `value' isn't shadowed inside subcommands."
+ (with-temp-eshell
+ (with-no-warnings (setq-local value "hello"))
+ (eshell-match-command-output "echo ${echo $value}"
+ "hello\n")))
+
+(ert-deftest esh-cmd-test/skip-leading-nils ()
+ "Test that Eshell skips leading nil arguments for named commands."
+ (eshell-command-result-equal "$eshell-test-value echo hello" "hello")
+ (eshell-command-result-equal
+ "$eshell-test-value $eshell-test-value echo hello" "hello"))
+
+(ert-deftest esh-cmd-test/let-rebinds-after-defer ()
+ "Test that let-bound values are properly updated after `eshell-defer'.
+When inside a `let' block in an Eshell command form, we need to
+ensure that deferred commands update any let-bound variables so
+they have the correct values when resuming evaluation. See
+bug#59469."
+ (skip-unless (executable-find "echo"))
+ (with-temp-eshell
+ (eshell-match-command-output
+ (concat "{"
+ " export LOCAL=value; "
+ " echo \"$LOCAL\"; "
+ " *echo external; " ; This will throw `eshell-defer'.
+ " echo \"$LOCAL\"; "
+ "}")
+ "value\nexternal\nvalue\n")))
+
+
+;; Background command invocation
+
+(ert-deftest esh-cmd-test/background/simple-command ()
+ "Test invocation with a simple background command."
+ (skip-unless (executable-find "echo"))
+ (eshell-with-temp-buffer bufname ""
+ (with-temp-eshell
+ (eshell-match-command-output
+ (format "*echo hi > #<%s> &" bufname)
+ (rx "[echo" (? ".exe") "] " (+ digit) "\n"))
+ (eshell-wait-for-subprocess t))
+ (should (equal (buffer-string) "hi\n"))))
+
+(ert-deftest esh-cmd-test/background/subcommand ()
+ "Test invocation with a background command containing subcommands."
+ (skip-unless (and (executable-find "echo")
+ (executable-find "rev")))
+ (eshell-with-temp-buffer bufname ""
+ (with-temp-eshell
+ (eshell-match-command-output
+ (format "*echo ${*echo hello | rev} > #<%s> &" bufname)
+ (rx "[echo" (? ".exe") "] " (+ digit) "\n"))
+ (eshell-wait-for-subprocess t))
+ (should (equal (buffer-string) "olleh\n"))))
+
;; Lisp forms
@@ -114,6 +170,78 @@ e.g. \"{(+ 1 2)} 3\" => 3"
"hi\n")))
+;; Pipelines
+
+(ert-deftest esh-cmd-test/pipeline-wait/head-proc ()
+ "Check that piping a non-process to a process command waits for the process."
+ (skip-unless (executable-find "cat"))
+ (with-temp-eshell
+ (eshell-match-command-output "echo hi | *cat"
+ "hi")))
+
+(ert-deftest esh-cmd-test/pipeline-wait/tail-proc ()
+ "Check that piping a process to a non-process command waits for the process."
+ (skip-unless (executable-find "echo"))
+ (with-temp-eshell
+ (eshell-match-command-output "*echo hi | echo bye"
+ "bye\nhi\n")))
+
+(ert-deftest esh-cmd-test/pipeline-wait/multi-proc ()
+ "Check that a pipeline waits for all its processes before returning."
+ (skip-unless (and (executable-find "echo")
+ (executable-find "sh")
+ (executable-find "rev")))
+ (with-temp-eshell
+ (eshell-match-command-output
+ "*echo hello | sh -c 'sleep 1; rev' 1>&2 | *echo goodbye"
+ "goodbye\nolleh\n")))
+
+(ert-deftest esh-cmd-test/pipeline-wait/subcommand ()
+ "Check that piping with an asynchronous subcommand waits for the subcommand."
+ (skip-unless (and (executable-find "echo")
+ (executable-find "cat")))
+ (with-temp-eshell
+ (eshell-match-command-output "echo ${*echo hi} | *cat"
+ "hi")))
+
+(ert-deftest esh-cmd-test/pipeline-wait/subcommand-with-pipe ()
+ "Check that piping with an asynchronous subcommand with its own pipe works.
+This should also wait for the subcommand."
+ (skip-unless (and (executable-find "echo")
+ (executable-find "cat")))
+ (with-temp-eshell
+ (eshell-match-command-output "echo ${*echo hi | *cat} | *cat"
+ "hi")))
+
+(ert-deftest esh-cmd-test/reset-in-pipeline/subcommand ()
+ "Check that subcommands reset `eshell-in-pipeline-p'."
+ (skip-unless (executable-find "cat"))
+ (dolist (template '("echo {%s} | *cat"
+ "echo ${%s} | *cat"
+ "*cat $<%s> | *cat"))
+ (eshell-command-result-equal
+ (format template "echo $eshell-in-pipeline-p")
+ nil)
+ (eshell-command-result-equal
+ (format template "echo | echo $eshell-in-pipeline-p")
+ "last")
+ (eshell-command-result-equal
+ (format template "echo $eshell-in-pipeline-p | echo")
+ "first")
+ (eshell-command-result-equal
+ (format template "echo | echo $eshell-in-pipeline-p | echo")
+ "t")))
+
+(ert-deftest esh-cmd-test/reset-in-pipeline/lisp ()
+ "Check that interpolated Lisp forms reset `eshell-in-pipeline-p'."
+ (skip-unless (executable-find "cat"))
+ (dolist (template '("echo (%s) | *cat"
+ "echo $(%s) | *cat"))
+ (eshell-command-result-equal
+ (format template "format \"%s\" eshell-in-pipeline-p")
+ "nil")))
+
+
;; Control flow statements
(ert-deftest esh-cmd-test/for-loop ()
@@ -134,13 +262,13 @@ e.g. \"{(+ 1 2)} 3\" => 3"
(eshell-match-command-output "for i in 1 2 (list 3 4) { echo $i }"
"1\n2\n3\n4\n")))
-(ert-deftest esh-cmd-test/for-name-loop () ; bug#15231
+(ert-deftest esh-cmd-test/for-loop-name () ; bug#15231
"Test invocation of a for loop using `name'."
(let ((process-environment (cons "name" process-environment)))
(eshell-command-result-equal "for name in 3 { echo $name }"
3)))
-(ert-deftest esh-cmd-test/for-name-shadow-loop () ; bug#15372
+(ert-deftest esh-cmd-test/for-loop-name-shadow () ; bug#15372
"Test invocation of a for loop using an env-var."
(let ((process-environment (cons "name=env-value" process-environment)))
(with-temp-eshell
@@ -148,14 +276,28 @@ e.g. \"{(+ 1 2)} 3\" => 3"
"echo $name; for name in 3 { echo $name }; echo $name"
"env-value\n3\nenv-value\n"))))
+(ert-deftest esh-cmd-test/for-loop-for-items-shadow ()
+ "Test that the variable `for-items' isn't shadowed inside for loops."
+ (with-temp-eshell
+ (with-no-warnings (setq-local for-items "hello"))
+ (eshell-match-command-output "for i in 1 { echo $for-items }"
+ "hello\n")))
+
+(ert-deftest esh-cmd-test/for-loop-pipe ()
+ "Test invocation of a for loop piped to another command."
+ (skip-unless (executable-find "rev"))
+ (with-temp-eshell
+ (eshell-match-command-output "for i in foo bar baz { echo $i } | rev"
+ "zabraboof")))
+
(ert-deftest esh-cmd-test/while-loop ()
"Test invocation of a while loop."
(with-temp-eshell
(let ((eshell-test-value '(0 1 2)))
(eshell-match-command-output
(concat "while $eshell-test-value "
- "{ setq eshell-test-value (cdr eshell-test-value) }")
- "(1 2)\n(2)\n"))))
+ "{ (pop eshell-test-value) }")
+ "0\n1\n2\n"))))
(ert-deftest esh-cmd-test/while-loop-lisp-form ()
"Test invocation of a while loop using a Lisp form."
@@ -176,6 +318,17 @@ e.g. \"{(+ 1 2)} 3\" => 3"
"{ setq eshell-test-value (1+ eshell-test-value) }")
"1\n2\n3\n"))))
+(ert-deftest esh-cmd-test/while-loop-pipe ()
+ "Test invocation of a while loop piped to another command."
+ (skip-unless (executable-find "rev"))
+ (with-temp-eshell
+ (let ((eshell-test-value '("foo" "bar" "baz")))
+ (eshell-match-command-output
+ (concat "while $eshell-test-value "
+ "{ (pop eshell-test-value) }"
+ " | rev")
+ "zabraboof"))))
+
(ert-deftest esh-cmd-test/until-loop ()
"Test invocation of an until loop."
(with-temp-eshell
@@ -253,6 +406,30 @@ This tests when `eshell-lisp-form-nil-is-failure' is nil."
(eshell-command-result-equal "if {[ foo = bar ]} {echo yes} {echo no}"
"no"))
+(ert-deftest esh-cmd-test/if-statement-pipe ()
+ "Test invocation of an if statement piped to another command."
+ (skip-unless (executable-find "rev"))
+ (with-temp-eshell
+ (let ((eshell-test-value t))
+ (eshell-match-command-output "if $eshell-test-value {echo yes} | rev"
+ "\\`sey\n?"))
+ (let ((eshell-test-value nil))
+ (eshell-match-command-output "if $eshell-test-value {echo yes} | rev"
+ "\\`\n?"))))
+
+(ert-deftest esh-cmd-test/if-else-statement-pipe ()
+ "Test invocation of an if/else statement piped to another command."
+ (skip-unless (executable-find "rev"))
+ (with-temp-eshell
+ (let ((eshell-test-value t))
+ (eshell-match-command-output
+ "if $eshell-test-value {echo yes} {echo no} | rev"
+ "\\`sey\n?"))
+ (let ((eshell-test-value nil))
+ (eshell-match-command-output
+ "if $eshell-test-value {echo yes} {echo no} | rev"
+ "\\`on\n?"))))
+
(ert-deftest esh-cmd-test/unless-statement ()
"Test invocation of an unless statement."
(let ((eshell-test-value t))
@@ -291,4 +468,41 @@ This tests when `eshell-lisp-form-nil-is-failure' is nil."
(eshell-command-result-equal "unless {[ foo = bar ]} {echo no} {echo yes}"
"no"))
+
+;; Direct invocation
+
+(defmacro esh-cmd-test--deftest-invoke-directly (name command expected)
+ "Test `eshell-invoke-directly-p' returns EXPECTED for COMMAND.
+NAME is the name of the test case."
+ (declare (indent 2))
+ `(ert-deftest ,(intern (concat "esh-cmd-test/invoke-directly/"
+ (symbol-name name)))
+ ()
+ (with-temp-eshell
+ (should (equal (eshell-invoke-directly-p
+ (eshell-parse-command ,command nil t))
+ ,expected)))))
+
+(esh-cmd-test--deftest-invoke-directly no-args "echo" t)
+(esh-cmd-test--deftest-invoke-directly with-args "echo hi" t)
+(esh-cmd-test--deftest-invoke-directly multiple-cmds "echo hi; echo bye" nil)
+(esh-cmd-test--deftest-invoke-directly subcmd "echo ${echo hi}" t)
+(esh-cmd-test--deftest-invoke-directly complex "ls ." nil)
+(esh-cmd-test--deftest-invoke-directly complex-subcmd "echo {ls .}" nil)
+
+
+;; Error handling
+
+(ert-deftest esh-cmd-test/throw ()
+ "Test that calling `throw' as an Eshell command unwinds everything properly."
+ (with-temp-eshell
+ (should (= (catch 'tag
+ (eshell-insert-command
+ "echo hi; (throw 'tag 42); echo bye"))
+ 42))
+ (should (eshell-match-output "\\`hi\n\\'"))
+ (should-not eshell-foreground-command)
+ ;; Make sure we can call another command after throwing.
+ (eshell-match-command-output "echo again" "\\`again\n")))
+
;; esh-cmd-tests.el ends here
diff --git a/test/lisp/eshell/esh-ext-tests.el b/test/lisp/eshell/esh-ext-tests.el
index 05049dd6f80..8abbd74f737 100644
--- a/test/lisp/eshell/esh-ext-tests.el
+++ b/test/lisp/eshell/esh-ext-tests.el
@@ -23,6 +23,7 @@
;;; Code:
+(require 'tramp)
(require 'ert)
(require 'esh-mode)
(require 'esh-ext)
@@ -73,4 +74,35 @@
(eshell-match-command-output "echo $PATH"
(concat original-path "\n")))))
+(ert-deftest esh-ext-test/explicitly-remote-command ()
+ "Test that an explicitly-remote command is remote no matter the current dir."
+ (skip-unless (and (eshell-tests-remote-accessible-p)
+ (executable-find "sh")))
+ (dolist (default-directory (list default-directory
+ ert-remote-temporary-file-directory))
+ (dolist (cmd (list "sh" (executable-find "sh")))
+ (ert-info ((format "Directory: %s; executable: %s" default-directory cmd))
+ (with-temp-eshell
+ ;; Check the value of $INSIDE_EMACS using `sh' in order to
+ ;; delay variable expansion.
+ (eshell-match-command-output
+ (format "%s%s -c 'echo $INSIDE_EMACS'"
+ (file-remote-p ert-remote-temporary-file-directory) cmd)
+ "eshell,tramp"))))))
+
+(ert-deftest esh-ext-test/explicitly-local-command ()
+ "Test that an explicitly-local command is local no matter the current dir."
+ (skip-unless (and (eshell-tests-remote-accessible-p)
+ (executable-find "sh")))
+ (dolist (default-directory (list default-directory
+ ert-remote-temporary-file-directory))
+ (dolist (cmd (list "sh" (executable-find "sh")))
+ (ert-info ((format "In directory: %s" default-directory))
+ (with-temp-eshell
+ ;; Check the value of $INSIDE_EMACS using `sh' in order to
+ ;; delay variable expansion.
+ (eshell-match-command-output
+ (format "/:%s -c 'echo $INSIDE_EMACS'" cmd)
+ "eshell\n"))))))
+
;; esh-ext-tests.el ends here
diff --git a/test/lisp/eshell/esh-io-tests.el b/test/lisp/eshell/esh-io-tests.el
index c5541a133b1..188570161c7 100644
--- a/test/lisp/eshell/esh-io-tests.el
+++ b/test/lisp/eshell/esh-io-tests.el
@@ -31,6 +31,9 @@
(defvar eshell-test-value nil)
+(defvar eshell-test-value-with-fun nil)
+(defun eshell-test-value-with-fun ())
+
(defun eshell-test-file-string (file)
"Return the contents of FILE as a string."
(with-temp-buffer
@@ -117,6 +120,13 @@
(eshell-insert-command "echo new >> #'eshell-test-value"))
(should (equal eshell-test-value "oldnew"))))
+(ert-deftest esh-io-test/redirect-symbol/with-function-slot ()
+ "Check that redirecting to a symbol with function slot set works."
+ (let ((eshell-test-value-with-fun))
+ (with-temp-eshell
+ (eshell-insert-command "echo hi > #'eshell-test-value-with-fun"))
+ (should (equal eshell-test-value-with-fun "hi"))))
+
(ert-deftest esh-io-test/redirect-marker ()
"Check that redirecting to a marker works."
(with-temp-buffer
@@ -146,6 +156,45 @@
(should (equal (buffer-string) "new"))
(should (equal eshell-test-value "new")))))
+(ert-deftest esh-io-test/redirect-subcommands ()
+ "Check that redirecting subcommands applies to all subcommands."
+ (eshell-with-temp-buffer bufname "old"
+ (with-temp-eshell
+ (eshell-insert-command (format "{echo foo; echo bar} > #<%s>" bufname)))
+ (should (equal (buffer-string) "foobar"))))
+
+(ert-deftest esh-io-test/redirect-subcommands/override ()
+ "Check that redirecting subcommands applies to all subcommands.
+Include a redirect to another location in the subcommand to
+ensure only its statement is redirected."
+ (eshell-with-temp-buffer bufname "old"
+ (eshell-with-temp-buffer bufname-2 "also old"
+ (with-temp-eshell
+ (eshell-insert-command
+ (format "{echo foo; echo bar > #<%s>; echo baz} > #<%s>"
+ bufname-2 bufname)))
+ (should (equal (buffer-string) "bar")))
+ (should (equal (buffer-string) "foobaz"))))
+
+(ert-deftest esh-io-test/redirect-subcommands/dev-null ()
+ "Check that redirecting subcommands applies to all subcommands.
+Include a redirect to /dev/null to ensure it only applies to its
+statement."
+ (eshell-with-temp-buffer bufname "old"
+ (with-temp-eshell
+ (eshell-insert-command
+ (format "{echo foo; echo bar > /dev/null; echo baz} > #<%s>"
+ bufname)))
+ (should (equal (buffer-string) "foobaz"))))
+
+(ert-deftest esh-io-test/redirect-subcommands/interpolated ()
+ "Check that redirecting interpolated subcommands applies to all subcommands."
+ (eshell-with-temp-buffer bufname "old"
+ (with-temp-eshell
+ (eshell-insert-command
+ (format "echo ${echo foo; echo bar} > #<%s>" bufname)))
+ (should (equal (buffer-string) "foobar"))))
+
;; Redirecting specific handles
@@ -262,24 +311,67 @@ stdout originally pointed (the terminal)."
"stderr\n"))
(should (equal (buffer-string) "stdout\n"))))
-(ert-deftest esh-io-test/redirect-pipe ()
- "Check that \"redirecting\" to a pipe works."
- ;; `|' should only redirect stdout.
+
+;; Pipelines
+
+(ert-deftest esh-io-test/pipeline/default ()
+ "Check that `|' only pipes stdout."
+ (skip-unless (executable-find "rev"))
(eshell-command-result-equal "test-output | rev"
- "stderr\ntuodts\n")
- ;; `|&' should redirect stdout and stderr.
+ "stderr\ntuodts\n"))
+
+
+(ert-deftest esh-io-test/pipeline/all ()
+ "Check that `|&' only pipes stdout and stderr."
+ (skip-unless (executable-find "rev"))
(eshell-command-result-equal "test-output |& rev"
"tuodts\nrredts\n"))
+(ert-deftest esh-io-test/pipeline/subcommands ()
+ "Check that all commands in a subcommand are properly piped."
+ (skip-unless (executable-find "rev"))
+ (with-temp-eshell
+ (eshell-match-command-output "{echo foo; echo bar} | rev"
+ "\\`raboof\n?")))
+
+(ert-deftest esh-io-test/pipeline/stdin-to-head ()
+ "Check that standard input is sent to the head process in a pipeline."
+ (skip-unless (and (executable-find "tr")
+ (executable-find "rev")))
+ (with-temp-eshell
+ (eshell-insert-command "tr a-z A-Z | rev")
+ (eshell-insert-command "hello")
+ (eshell-send-eof-to-process)
+ (eshell-wait-for-subprocess)
+ (should (eshell-match-output "OLLEH\n"))))
+
;; Virtual targets
-(ert-deftest esh-io-test/virtual-dev-eshell ()
+(ert-deftest esh-io-test/virtual/dev-null ()
+ "Check that redirecting to /dev/null works."
+ (with-temp-eshell
+ (eshell-match-command-output "echo hi > /dev/null" "\\`\\'")))
+
+(ert-deftest esh-io-test/virtual/dev-null/multiple ()
+ "Check that redirecting to /dev/null works alongside other redirections."
+ (eshell-with-temp-buffer bufname "old"
+ (with-temp-eshell
+ (eshell-match-command-output
+ (format "echo new > /dev/null > #<%s>" bufname) "\\`\\'"))
+ (should (equal (buffer-string) "new")))
+ (eshell-with-temp-buffer bufname "old"
+ (with-temp-eshell
+ (eshell-match-command-output
+ (format "echo new > #<%s> > /dev/null" bufname) "\\`\\'"))
+ (should (equal (buffer-string) "new"))))
+
+(ert-deftest esh-io-test/virtual/dev-eshell ()
"Check that redirecting to /dev/eshell works."
(with-temp-eshell
(eshell-match-command-output "echo hi > /dev/eshell" "hi")))
-(ert-deftest esh-io-test/virtual-dev-kill ()
+(ert-deftest esh-io-test/virtual/dev-kill ()
"Check that redirecting to /dev/kill works."
(with-temp-eshell
(eshell-insert-command "echo one > /dev/kill")
diff --git a/test/lisp/eshell/esh-opt-tests.el b/test/lisp/eshell/esh-opt-tests.el
index 8d6e0c1e426..4e5373e53cd 100644
--- a/test/lisp/eshell/esh-opt-tests.el
+++ b/test/lisp/eshell/esh-opt-tests.el
@@ -29,13 +29,15 @@
(eshell--process-args
"sudo" '("-a")
'((?a "all" nil show-all
- "do not ignore entries starting with .")))))
+ "do not ignore entries starting with ."))
+ '(show-all))))
(should
(equal '("root" "world")
(eshell--process-args
"sudo" '("-u" "root" "world")
'((?u "user" t user
- "execute a command as another USER"))))))
+ "execute a command as another USER"))
+ '(user)))))
(ert-deftest esh-opt-test/process-args-parse-leading-options-only ()
"Test behavior of :parse-leading-options-only in `eshell--process-args'."
@@ -45,20 +47,23 @@
"sudo" '("emerge" "-uDN" "world")
'((?u "user" t user
"execute a command as another USER")
- :parse-leading-options-only))))
+ :parse-leading-options-only)
+ '(user))))
(should
(equal '("root" "emerge" "-uDN" "world")
(eshell--process-args
"sudo" '("-u" "root" "emerge" "-uDN" "world")
'((?u "user" t user
"execute a command as another USER")
- :parse-leading-options-only))))
+ :parse-leading-options-only)
+ '(user))))
(should
(equal '("DN" "emerge" "world")
(eshell--process-args
"sudo" '("-u" "root" "emerge" "-uDN" "world")
'((?u "user" t user
- "execute a command as another USER"))))))
+ "execute a command as another USER"))
+ '(user)))))
(ert-deftest esh-opt-test/process-args-external ()
"Test behavior of :external in `eshell--process-args'."
@@ -69,7 +74,8 @@
"ls" '("/some/path")
'((?a "all" nil show-all
"do not ignore entries starting with .")
- :external "ls")))))
+ :external "ls")
+ '(show-all)))))
(cl-letf (((symbol-function 'eshell-search-path) #'identity))
(should
(equal '(no-catch eshell-ext-command "ls")
@@ -78,7 +84,8 @@
"ls" '("-u" "/some/path")
'((?a "all" nil show-all
"do not ignore entries starting with .")
- :external "ls"))
+ :external "ls")
+ '(show-all))
:type 'no-catch))))
(cl-letf (((symbol-function 'eshell-search-path) #'ignore))
(should-error
@@ -86,7 +93,8 @@
"ls" '("-u" "/some/path")
'((?a "all" nil show-all
"do not ignore entries starting with .")
- :external "ls"))
+ :external "ls")
+ '(show-all))
:type 'error)))
(ert-deftest esh-opt-test/eval-using-options-short ()
diff --git a/test/lisp/eshell/esh-proc-tests.el b/test/lisp/eshell/esh-proc-tests.el
index f8b47c78bae..63fb8f46dfa 100644
--- a/test/lisp/eshell/esh-proc-tests.el
+++ b/test/lisp/eshell/esh-proc-tests.el
@@ -86,7 +86,7 @@
"\\`\\'"))
(should (equal (buffer-string) "stdout\nstderr\n"))))
-(ert-deftest esh-var-test/output/remote-redirect ()
+(ert-deftest esh-proc-test/output/remote-redirect ()
"Check that redirecting stdout for a remote process works."
(skip-unless (and (eshell-tests-remote-accessible-p)
(executable-find "echo")))
@@ -137,18 +137,19 @@
(skip-unless (and (executable-find "sh")
(executable-find "echo")
(executable-find "sleep")))
- (with-temp-eshell
- (eshell-match-command-output
- ;; The first command is like `yes' but slower. This is to prevent
- ;; it from taxing Emacs's process filter too much and causing a
- ;; hang. Note that we use "|&" to connect the processes so that
- ;; Emacs doesn't create an extra pipe process for the first "sh"
- ;; invocation.
- (concat "sh -c 'while true; do echo y; sleep 1; done' |& "
- "sh -c 'read NAME; echo ${NAME}'")
- "y\n")
- (eshell-wait-for-subprocess t)
- (should (eq (process-list) nil))))
+ (let ((starting-process-list (process-list)))
+ (with-temp-eshell
+ (eshell-match-command-output
+ ;; The first command is like `yes' but slower. This is to prevent
+ ;; it from taxing Emacs's process filter too much and causing a
+ ;; hang. Note that we use "|&" to connect the processes so that
+ ;; Emacs doesn't create an extra pipe process for the first "sh"
+ ;; invocation.
+ (concat "sh -c 'while true; do echo y; sleep 1; done' |& "
+ "sh -c 'read NAME; echo ${NAME}'")
+ "y\n")
+ (eshell-wait-for-subprocess t)
+ (should (equal (process-list) starting-process-list)))))
(ert-deftest esh-proc-test/pipeline-connection-type/no-pipeline ()
"Test that all streams are PTYs when a command is not in a pipeline."
@@ -173,23 +174,70 @@
pipeline."
(skip-unless (and (executable-find "sh")
(executable-find "cat")))
- ;; An `eshell-pipe-broken' signal might occur internally; let Eshell
- ;; handle it!
- (let ((debug-on-error nil))
- (eshell-command-result-equal
- (concat "echo hi | " esh-proc-test--detect-pty-cmd " | cat")
- nil)))
+ (eshell-command-result-equal
+ (concat "(ignore) | " esh-proc-test--detect-pty-cmd " | cat")
+ nil))
(ert-deftest esh-proc-test/pipeline-connection-type/last ()
"Test that only output streams are PTYs when a command ends a pipeline."
(skip-unless (executable-find "sh"))
- ;; An `eshell-pipe-broken' signal might occur internally; let Eshell
- ;; handle it!
- (let ((debug-on-error nil))
- (eshell-command-result-equal
- (concat "echo hi | " esh-proc-test--detect-pty-cmd)
- (unless (eq system-type 'windows-nt)
- "stdout\nstderr\n"))))
+ (eshell-command-result-equal
+ (concat "(ignore) | " esh-proc-test--detect-pty-cmd)
+ (unless (eq system-type 'windows-nt)
+ "stdout\nstderr\n")))
+
+
+;; Synchronous processes
+
+;; These tests check that synchronous subprocesses (only used on
+;; MS-DOS by default) work correctly. To help them run on MS-DOS as
+;; well, we use the Emacs executable as our subprocess to test
+;; against; that way, users don't need to have GNU coreutils (or
+;; similar) installed.
+
+(defsubst esh-proc-test/emacs-command (command)
+ "Evaluate COMMAND in a new Emacs batch instance."
+ (mapconcat #'shell-quote-argument
+ `(,(expand-file-name invocation-name invocation-directory)
+ "-Q" "--batch" "--eval" ,(prin1-to-string command))
+ " "))
+
+(defvar esh-proc-test/emacs-echo
+ (esh-proc-test/emacs-command '(princ "hello\n"))
+ "A command that prints \"hello\" to stdout using Emacs.")
+
+(defvar esh-proc-test/emacs-upcase
+ (esh-proc-test/emacs-command
+ '(princ (upcase (concat (read-string "") "\n"))))
+ "A command that upcases the text from stdin using Emacs.")
+
+(ert-deftest esh-proc-test/synchronous-proc/simple/interactive ()
+ "Test that synchronous processes work in an interactive shell."
+ (let ((eshell-supports-asynchronous-processes nil))
+ (with-temp-eshell
+ (eshell-match-command-output esh-proc-test/emacs-echo
+ "\\`hello\n"))))
+
+(ert-deftest esh-proc-test/synchronous-proc/simple/command-result ()
+ "Test that synchronous processes work via `eshell-command-result'."
+ (let ((eshell-supports-asynchronous-processes nil))
+ (eshell-command-result-equal esh-proc-test/emacs-echo
+ "hello\n")))
+
+(ert-deftest esh-proc-test/synchronous-proc/pipeline/interactive ()
+ "Test that synchronous pipelines work in an interactive shell."
+ (let ((eshell-supports-asynchronous-processes nil))
+ (with-temp-eshell
+ (eshell-match-command-output (concat esh-proc-test/emacs-echo " | "
+ esh-proc-test/emacs-upcase)
+ "\\`HELLO\n"))))
+
+(ert-deftest esh-proc-test/synchronous-proc/pipeline/command-result ()
+ "Test that synchronous pipelines work via `eshell-command-result'."
+ (let ((eshell-supports-asynchronous-processes nil))
+ (eshell-command-result-equal (concat esh-proc-test/emacs-echo " | "
+ esh-proc-test/emacs-upcase)
+ "HELLO\n")))
;; Killing processes
@@ -228,7 +276,7 @@ prompt. See bug#54136."
(executable-find "sleep")))
;; This test doesn't work on EMBA with AOT nativecomp, but works
;; fine elsewhere.
- (skip-unless (not (getenv "EMACS_EMBA_CI")))
+ (skip-when (getenv "EMACS_EMBA_CI"))
(with-temp-eshell
(eshell-insert-command
(concat "sh -c 'while true; do echo y; sleep 1; done' | "
@@ -259,6 +307,15 @@ write the exit status to the pipe. See bug#54136."
output-start (eshell-end-of-output))
"")))))
+(ert-deftest esh-proc-test/kill-process/redirect-message ()
+ "Test that killing a process with a redirected stderr omits the exit status."
+ (skip-unless (executable-find "sleep"))
+ (eshell-with-temp-buffer bufname ""
+ (with-temp-eshell
+ (eshell-insert-command (format "sleep 100 2> #<buffer %s>" bufname))
+ (kill-process (eshell-head-process)))
+ (should (equal (buffer-string) ""))))
+
;; Remote processes
diff --git a/test/lisp/eshell/esh-util-tests.el b/test/lisp/eshell/esh-util-tests.el
index 81bb98828a8..71a047b1801 100644
--- a/test/lisp/eshell/esh-util-tests.el
+++ b/test/lisp/eshell/esh-util-tests.el
@@ -52,14 +52,116 @@
(ert-deftest esh-util-test/eshell-stringify/list ()
"Test that `eshell-stringify' correctly stringifies lists."
+ ;; These tests depend on the particulars of how Emacs pretty-prints
+ ;; lists; changes to the pretty-printer could result in different
+ ;; whitespace. We don't care about that, except to ensure there's
+ ;; no leading/trailing whitespace.
(should (equal (eshell-stringify '(1 2 3)) "(1 2 3)"))
- (should (equal (eshell-stringify '((1 2) (3 . 4)))
- "((1 2)\n (3 . 4))")))
+ (should (equal (replace-regexp-in-string
+ (rx (+ (any space "\n"))) " "
+ (eshell-stringify '((1 2) (3 . 4))))
+ "((1 2) (3 . 4))")))
(ert-deftest esh-util-test/eshell-stringify/complex ()
"Test that `eshell-stringify' correctly stringifies complex objects."
(should (equal (eshell-stringify (list 'quote 'hello)) "'hello")))
+(ert-deftest esh-util-test/eshell-convert-to-number/integer ()
+ "Test that `eshell-convert-to-number' correctly converts integers."
+ (should (equal (eshell-convert-to-number "123") 123))
+ (should (equal (eshell-convert-to-number "-123") -123))
+ ;; These are technially integers, since Emacs Lisp requires at least
+ ;; one digit after the "." to be a float:
+ (should (equal (eshell-convert-to-number "123.") 123))
+ (should (equal (eshell-convert-to-number "-123.") -123)))
+
+(ert-deftest esh-util-test/eshell-convert-to-number/floating-point ()
+ "Test that `eshell-convert-to-number' correctly converts floats."
+ (should (equal (eshell-convert-to-number "1.23") 1.23))
+ (should (equal (eshell-convert-to-number "-1.23") -1.23))
+ (should (equal (eshell-convert-to-number ".1") 0.1))
+ (should (equal (eshell-convert-to-number "-.1") -0.1)))
+
+(ert-deftest esh-util-test/eshell-convert-to-number/floating-point-exponent ()
+ "Test that `eshell-convert-to-number' correctly converts exponent notation."
+ ;; Positive exponent:
+ (dolist (exp '("e2" "e+2" "E2" "E+2"))
+ (should (equal (eshell-convert-to-number (concat "123" exp)) 12300.0))
+ (should (equal (eshell-convert-to-number (concat "-123" exp)) -12300.0))
+ (should (equal (eshell-convert-to-number (concat "1.23" exp)) 123.0))
+ (should (equal (eshell-convert-to-number (concat "-1.23" exp)) -123.0))
+ (should (equal (eshell-convert-to-number (concat "1." exp)) 100.0))
+ (should (equal (eshell-convert-to-number (concat "-1." exp)) -100.0))
+ (should (equal (eshell-convert-to-number (concat ".1" exp)) 10.0))
+ (should (equal (eshell-convert-to-number (concat "-.1" exp)) -10.0)))
+ ;; Negative exponent:
+ (dolist (exp '("e-2" "E-2"))
+ (should (equal (eshell-convert-to-number (concat "123" exp)) 1.23))
+ (should (equal (eshell-convert-to-number (concat "-123" exp)) -1.23))
+ (should (equal (eshell-convert-to-number (concat "1.23" exp)) 0.0123))
+ (should (equal (eshell-convert-to-number (concat "-1.23" exp)) -0.0123))
+ (should (equal (eshell-convert-to-number (concat "1." exp)) 0.01))
+ (should (equal (eshell-convert-to-number (concat "-1." exp)) -0.01))
+ (should (equal (eshell-convert-to-number (concat ".1" exp)) 0.001))
+ (should (equal (eshell-convert-to-number (concat "-.1" exp)) -0.001))))
+
+(ert-deftest esh-util-test/eshell-convert-to-number/floating-point/infinite ()
+ "Test that `eshell-convert-to-number' correctly converts infinite floats."
+ (should (equal (eshell-convert-to-number "1.0e+INF") 1.0e+INF))
+ (should (equal (eshell-convert-to-number "2.e+INF") 1.0e+INF))
+ (should (equal (eshell-convert-to-number "-1.0e+INF") -1.0e+INF))
+ (should (equal (eshell-convert-to-number "-2.e+INF") -1.0e+INF)))
+
+(ert-deftest esh-util-test/eshell-convert-to-number/floating-point/nan ()
+ "Test that `eshell-convert-to-number' correctly converts NaNs."
+ (should (equal (eshell-convert-to-number "1.0e+NaN") 1.0e+NaN))
+ (should (equal (eshell-convert-to-number "2.e+NaN") 2.0e+NaN))
+ (should (equal (eshell-convert-to-number "-1.0e+NaN") -1.0e+NaN))
+ (should (equal (eshell-convert-to-number "-2.e+NaN") -2.0e+NaN)))
+
+(ert-deftest esh-util-test/eshell-convert-to-number/non-numeric ()
+ "Test that `eshell-convert-to-number' does nothing to non-numeric values."
+ (should (equal (eshell-convert-to-number "foo") "foo"))
+ (should (equal (eshell-convert-to-number "") ""))
+ (should (equal (eshell-convert-to-number "123foo") "123foo")))
+
+(ert-deftest esh-util-test/eshell-convert-to-number/no-convert ()
+ "Test that `eshell-convert-to-number' does nothing when disabled."
+ (let ((eshell-convert-numeric-arguments nil))
+ (should (equal (eshell-convert-to-number "123") "123"))
+ (should (equal (eshell-convert-to-number "1.23") "1.23"))))
+
+(ert-deftest esh-util-test/eshell-printable-size ()
+ (should (equal (eshell-printable-size (expt 2 16)) "65536"))
+ (should (equal (eshell-printable-size (expt 2 32)) "4294967296")))
+
+(ert-deftest esh-util-test/eshell-printable-size/zero ()
+ (should (equal (eshell-printable-size 0 1000 nil t) "0")))
+
+(ert-deftest esh-util-test/eshell-printable-size/terabyte ()
+ (should (equal (eshell-printable-size (1- (expt 2 40)) 1024 nil t) "1024G"))
+ (should (equal (eshell-printable-size (expt 2 40) 1024 nil t) "1T"))
+ (should (equal (eshell-printable-size (1- (expt 10 12)) 1000 nil t) "1000G"))
+ (should (equal (eshell-printable-size (expt 10 12) 1000 nil t) "1T")))
+
+(ert-deftest esh-util-test/eshell-printable-size/use-colors ()
+ (should (equal-including-properties
+ (eshell-printable-size (1- (expt 2 20)) 1024 nil t)
+ "1024k"))
+ (should (equal-including-properties
+ (eshell-printable-size (1- (expt 2 30)) 1024 nil t)
+ (propertize "1024M" 'face 'bold)))
+ (should (equal-including-properties
+ (eshell-printable-size (1- (expt 2 40)) 1024 nil t)
+ (propertize "1024G" 'face 'bold-italic))))
+
+(ert-deftest esh-util-test/eshell-printable-size/block-size ()
+ (should (equal (eshell-printable-size (1- (expt 2 20)) nil 4096) "256"))
+ (should (equal (eshell-printable-size (1- (expt 2 30)) nil 4096) "262144")))
+
+(ert-deftest esh-util-test/eshell-printable-size/human-readable-arg ()
+ (should-error (eshell-printable-size 0 999 nil t)))
+
(ert-deftest esh-util-test/path/get ()
"Test that getting the Eshell path returns the expected results."
(let ((expected-path (butlast (exec-path))))
diff --git a/test/lisp/eshell/esh-var-tests.el b/test/lisp/eshell/esh-var-tests.el
index 9c76033aab0..b94e8a276d7 100644
--- a/test/lisp/eshell/esh-var-tests.el
+++ b/test/lisp/eshell/esh-var-tests.el
@@ -60,41 +60,101 @@
(eshell-command-result-equal "echo $\"user-login-name\"-foo"
(concat user-login-name "-foo")))
-(ert-deftest esh-var-test/interp-var-indices ()
- "Interpolate list variable with indices"
- (let ((eshell-test-value '("zero" "one" "two" "three" "four")))
+(ert-deftest esh-var-test/interp-list-var ()
+ "Interpolate list variable"
+ (let ((eshell-test-value '(1 2 3)))
+ (eshell-command-result-equal "echo $eshell-test-value"
+ '(1 2 3))))
+
+(ert-deftest esh-var-test/interp-list-var-concat ()
+ "Interpolate and concat list variable"
+ (let ((eshell-test-value '(1 2 3)))
+ (eshell-command-result-equal "echo a$'eshell-test-value'z"
+ '("a1" 2 "3z"))))
+
+(defun esh-var-test/interp-var-indices (function &optional range-function)
+ "Test interpolation of an indexable value with indices.
+FUNCTION is a function that takes a list of elements and returns
+the object to test.
+
+RANGE-FUNCTION is a function that takes a list of elements and
+returns the expected result of an index range for the object; if
+nil, use FUNCTION instead."
+ (let ((eshell-test-value
+ (funcall function '("zero" "one" "two" "three" "four")))
+ (range-function (or range-function function)))
+ ;; Positive indices
(eshell-command-result-equal "echo $eshell-test-value[0]"
"zero")
(eshell-command-result-equal "echo $eshell-test-value[0 2]"
'("zero" "two"))
(eshell-command-result-equal "echo $eshell-test-value[0 2 4]"
- '("zero" "two" "four"))))
+ '("zero" "two" "four"))
+ ;; Negative indices
+ (eshell-command-result-equal "echo $eshell-test-value[-1]"
+ "four")
+ (eshell-command-result-equal "echo $eshell-test-value[-1 -3]"
+ '("four" "two"))
+ ;; Index ranges
+ (eshell-command-result-equal
+ "echo $eshell-test-value[1..4]"
+ (funcall range-function '("one" "two" "three")))
+ (eshell-command-result-equal
+ "echo $eshell-test-value[..2]"
+ (funcall range-function '("zero" "one")))
+ (eshell-command-result-equal
+ "echo $eshell-test-value[-2..]"
+ (funcall range-function '("three" "four")))
+ (eshell-command-result-equal
+ "echo $eshell-test-value[..]"
+ (funcall range-function '("zero" "one" "two" "three" "four")))
+ (eshell-command-result-equal
+ "echo $eshell-test-value[1..4 -2..]"
+ (list (funcall range-function '("one" "two" "three"))
+ (funcall range-function '("three" "four"))))))
-(ert-deftest esh-var-test/interp-var-split-indices ()
- "Interpolate string variable with indices"
- (let ((eshell-test-value "zero one two three four"))
- (eshell-command-result-equal "echo $eshell-test-value[0]"
- "zero")
- (eshell-command-result-equal "echo $eshell-test-value[0 2]"
- '("zero" "two"))
- (eshell-command-result-equal "echo $eshell-test-value[0 2 4]"
- '("zero" "two" "four"))))
+(ert-deftest esh-var-test/interp-var-indices/list ()
+ "Interpolate list variable with indices."
+ (esh-var-test/interp-var-indices #'identity))
+
+(ert-deftest esh-var-test/interp-var-indices/vector ()
+ "Interpolate vector variable with indices."
+ (esh-var-test/interp-var-indices #'vconcat))
+
+(ert-deftest esh-var-test/interp-var-indices/ring ()
+ "Interpolate ring variable with indices."
+ (esh-var-test/interp-var-indices #'ring-convert-sequence-to-ring))
+
+(ert-deftest esh-var-test/interp-var-indices/split ()
+ "Interpolate string variable with indices."
+ (esh-var-test/interp-var-indices
+ (lambda (values) (string-join values " "))
+ #'identity))
(ert-deftest esh-var-test/interp-var-string-split-indices ()
- "Interpolate string variable with string splitter and indices"
+ "Interpolate string variable with string splitter and indices."
+ ;; Test using punctuation as a delimiter.
(let ((eshell-test-value "zero:one:two:three:four"))
(eshell-command-result-equal "echo $eshell-test-value[: 0]"
"zero")
(eshell-command-result-equal "echo $eshell-test-value[: 0 2]"
'("zero" "two")))
+ ;; Test using a letter as a delimiter.
(let ((eshell-test-value "zeroXoneXtwoXthreeXfour"))
(eshell-command-result-equal "echo $eshell-test-value[X 0]"
"zero")
(eshell-command-result-equal "echo $eshell-test-value[X 0 2]"
+ '("zero" "two")))
+ ;; Test using a number as a delimiter.
+ (let ((eshell-test-value "zero0one0two0three0four"))
+ (eshell-command-result-equal "echo $eshell-test-value[\"0\" 0]"
+ "zero")
+ (eshell-command-result-equal "echo $eshell-test-value[\"0\" 0 2]"
'("zero" "two"))))
(ert-deftest esh-var-test/interp-var-regexp-split-indices ()
- "Interpolate string variable with regexp splitter and indices"
+ "Interpolate string variable with regexp splitter and indices."
+ ;; Test using a regexp as a delimiter.
(let ((eshell-test-value "zero:one!two:three!four"))
(eshell-command-result-equal "echo $eshell-test-value['[:!]' 0]"
"zero")
@@ -103,18 +163,37 @@
(eshell-command-result-equal "echo $eshell-test-value[\"[:!]\" 0]"
"zero")
(eshell-command-result-equal "echo $eshell-test-value[\"[:!]\" 0 2]"
+ '("zero" "two")))
+ ;; Test using a regexp that looks like range syntax as a delimiter.
+ (let ((eshell-test-value "zero0..0one0..0two0..0three0..0four"))
+ (eshell-command-result-equal "echo $eshell-test-value[\"0..0\" 0]"
+ "zero")
+ (eshell-command-result-equal "echo $eshell-test-value[\"0..0\" 0 2]"
'("zero" "two"))))
(ert-deftest esh-var-test/interp-var-assoc ()
- "Interpolate alist variable with index"
- (let ((eshell-test-value '(("foo" . 1) (bar . 2))))
+ "Interpolate alist variable with index."
+ (let ((eshell-test-value '(("foo" . 1) (bar . 2) ("3" . "three"))))
(eshell-command-result-equal "echo $eshell-test-value[foo]"
1)
(eshell-command-result-equal "echo $eshell-test-value[#'bar]"
- 2)))
+ 2)
+ (eshell-command-result-equal "echo $eshell-test-value[\"3\"]"
+ "three")))
+
+(ert-deftest esh-var-test/interp-var-indices-subcommand ()
+ "Interpolate list variable with subcommand expansion for indices."
+ (skip-unless (executable-find "echo"))
+ (let ((eshell-test-value '("zero" "one" "two" "three" "four")))
+ (eshell-command-result-equal
+ "echo $eshell-test-value[${*echo 0}]"
+ "zero")
+ (eshell-command-result-equal
+ "echo $eshell-test-value[${*echo 0} ${*echo 2}]"
+ '("zero" "two"))))
(ert-deftest esh-var-test/interp-var-length-list ()
- "Interpolate length of list variable"
+ "Interpolate length of list variable."
(let ((eshell-test-value '((1 2) (3) (5 (6 7 8 9)))))
(eshell-command-result-equal "echo $#eshell-test-value" 3)
(eshell-command-result-equal "echo $#eshell-test-value[1]" 1)
@@ -126,55 +205,75 @@
(eshell-command-result-equal "echo $#eshell-test-value" 6)))
(ert-deftest esh-var-test/interp-var-length-alist ()
- "Interpolate length of alist variable"
+ "Interpolate length of alist variable."
(let ((eshell-test-value '(("foo" . (1 2 3)))))
(eshell-command-result-equal "echo $#eshell-test-value" 1)
(eshell-command-result-equal "echo $#eshell-test-value[foo]" 3)))
+(ert-deftest esh-var-test/interp-var-splice ()
+ "Splice-interpolate list variable."
+ (let ((eshell-test-value '(1 2 3)))
+ (eshell-command-result-equal "echo a $@eshell-test-value z"
+ '("a" 1 2 3 "z"))))
+
+(ert-deftest esh-var-test/interp-var-splice-concat ()
+ "Splice-interpolate and concat list variable."
+ (let ((eshell-test-value '(1 2 3)))
+ (eshell-command-result-equal "echo it is a$@'eshell-test-value'z"
+ '("it" "is" "a1" 2 "3z"))
+ ;; This is a tricky case. We're concatenating a spliced list and
+ ;; a non-spliced list. The general rule is that splicing should
+ ;; work as though the user typed "$X[0] $X[1] ... $X[N]". That
+ ;; means that the last value of our splice should get concatenated
+ ;; into the first value of the non-spliced list.
+ (eshell-command-result-equal
+ "echo it is $@'eshell-test-value'$eshell-test-value"
+ '("it" "is" 1 2 (31 2 3)))))
+
(ert-deftest esh-var-test/interp-lisp ()
- "Interpolate Lisp form evaluation"
+ "Interpolate Lisp form evaluation."
(eshell-command-result-equal "+ $(+ 1 2) 3" 6))
(ert-deftest esh-var-test/interp-lisp-indices ()
- "Interpolate Lisp form evaluation with index"
+ "Interpolate Lisp form evaluation with index."
(eshell-command-result-equal "+ $(list 1 2)[1] 3" 5))
(ert-deftest esh-var-test/interp-cmd ()
- "Interpolate command result"
+ "Interpolate command result."
(eshell-command-result-equal "+ ${+ 1 2} 3" 6))
(ert-deftest esh-var-test/interp-cmd-indices ()
- "Interpolate command result with index"
+ "Interpolate command result with index."
(eshell-command-result-equal "+ ${listify 1 2}[1] 3" 5))
(ert-deftest esh-var-test/interp-cmd-external ()
- "Interpolate command result from external command"
+ "Interpolate command result from external command."
(skip-unless (executable-find "echo"))
(with-temp-eshell
(eshell-match-command-output "echo ${*echo hi}"
"hi\n")))
(ert-deftest esh-var-test/interp-cmd-external-indices ()
- "Interpolate command result from external command with index"
+ "Interpolate command result from external command with index."
(skip-unless (executable-find "echo"))
(with-temp-eshell
(eshell-match-command-output "echo ${*echo \"hi\nbye\"}[1]"
"bye\n")))
(ert-deftest esh-var-test/interp-temp-cmd ()
- "Interpolate command result redirected to temp file"
+ "Interpolate command result redirected to temp file."
(eshell-command-result-equal "cat $<echo hi>" "hi"))
(ert-deftest esh-var-test/interp-concat-lisp ()
- "Interpolate and concat Lisp form"
+ "Interpolate and concat Lisp form."
(eshell-command-result-equal "+ $(+ 1 2)3 3" 36))
(ert-deftest esh-var-test/interp-concat-lisp2 ()
- "Interpolate and concat two Lisp forms"
+ "Interpolate and concat two Lisp forms."
(eshell-command-result-equal "+ $(+ 1 2)$(+ 1 2) 3" 36))
(ert-deftest esh-var-test/interp-concat-cmd ()
- "Interpolate and concat command with literal"
+ "Interpolate and concat command with literal."
(eshell-command-result-equal "+ ${+ 1 2}3 3" 36)
(eshell-command-result-equal "echo ${*echo \"foo\nbar\"}-baz"
'("foo" "bar-baz"))
@@ -187,18 +286,21 @@
'("hi" "23")))
(ert-deftest esh-var-test/interp-concat-cmd2 ()
- "Interpolate and concat two commands"
+ "Interpolate and concat two commands."
(eshell-command-result-equal "+ ${+ 1 2}${+ 1 2} 3" 36))
(ert-deftest esh-var-test/interp-concat-cmd-external ()
- "Interpolate command result from external command with concatenation"
+ "Interpolate command result from external command with concatenation."
(skip-unless (executable-find "echo"))
(with-temp-eshell
(eshell-match-command-output "echo ${echo hi}-${*echo there}"
"hi-there\n")))
+
+;; Quoted variable interpolation
+
(ert-deftest esh-var-test/quoted-interp-var ()
- "Interpolate variable inside double-quotes"
+ "Interpolate variable inside double-quotes."
(eshell-command-result-equal "echo \"$user-login-name\""
user-login-name))
@@ -209,8 +311,20 @@
(eshell-command-result-equal "echo \"hi, $\\\"user-login-name\\\"\""
(concat "hi, " user-login-name)))
+(ert-deftest esh-var-test/quoted-interp-list-var ()
+ "Interpolate list variable inside double-quotes."
+ (let ((eshell-test-value '(1 2 3)))
+ (eshell-command-result-equal "echo \"$eshell-test-value\""
+ "(1 2 3)")))
+
+(ert-deftest esh-var-test/quoted-interp-list-var-concat ()
+ "Interpolate and concat list variable inside double-quotes"
+ (let ((eshell-test-value '(1 2 3)))
+ (eshell-command-result-equal "echo \"a$'eshell-test-value'z\""
+ "a(1 2 3)z")))
+
(ert-deftest esh-var-test/quoted-interp-var-indices ()
- "Interpolate string variable with indices inside double-quotes"
+ "Interpolate string variable with indices inside double-quotes."
(let ((eshell-test-value '("zero" "one" "two" "three" "four")))
(eshell-command-result-equal "echo \"$eshell-test-value[0]\""
"zero")
@@ -224,8 +338,21 @@
(eshell-command-result-equal "echo \"$eshell-test-value[1 2 4]\""
"(\"one\" \"two\" \"four\")")))
+(ert-deftest esh-var-test/quote-interp-var-indices-subcommand ()
+ "Interpolate list variable with subcommand expansion for indices inside double-quotes."
+ (skip-unless (executable-find "echo"))
+ (let ((eshell-test-value '("zero" "one" "two" "three" "four")))
+ (eshell-command-result-equal
+ "echo \"$eshell-test-value[${*echo 0}]\""
+ "zero")
+ ;; FIXME: These tests would use the 0th index like the other tests
+ ;; here, but see above.
+ (eshell-command-result-equal
+ "echo \"$eshell-test-value[${*echo 1} ${*echo 2}]\""
+ "(\"one\" \"two\")")))
+
(ert-deftest esh-var-test/quoted-interp-var-split-indices ()
- "Interpolate string variable with indices inside double-quotes"
+ "Interpolate string variable with indices inside double-quotes."
(let ((eshell-test-value "zero one two three four"))
(eshell-command-result-equal "echo \"$eshell-test-value[0]\""
"zero")
@@ -233,8 +360,7 @@
"(\"zero\" \"two\")")))
(ert-deftest esh-var-test/quoted-interp-var-string-split-indices ()
- "Interpolate string variable with string splitter and indices
-inside double-quotes"
+ "Interpolate string variable with string splitter and indices inside double-quotes."
(let ((eshell-test-value "zero:one:two:three:four"))
(eshell-command-result-equal "echo \"$eshell-test-value[: 0]\""
"zero")
@@ -247,7 +373,7 @@ inside double-quotes"
"(\"zero\" \"two\")")))
(ert-deftest esh-var-test/quoted-interp-var-regexp-split-indices ()
- "Interpolate string variable with regexp splitter and indices"
+ "Interpolate string variable with regexp splitter and indices."
(let ((eshell-test-value "zero:one!two:three!four"))
(eshell-command-result-equal "echo \"$eshell-test-value['[:!]' 0]\""
"zero")
@@ -260,7 +386,7 @@ inside double-quotes"
"(\"zero\" \"two\")")))
(ert-deftest esh-var-test/quoted-interp-var-assoc ()
- "Interpolate alist variable with index inside double-quotes"
+ "Interpolate alist variable with index inside double-quotes."
(let ((eshell-test-value '(("foo" . 1) (bar . 2))))
(eshell-command-result-equal "echo \"$eshell-test-value[foo]\""
"1")
@@ -268,7 +394,7 @@ inside double-quotes"
"2")))
(ert-deftest esh-var-test/quoted-interp-var-length-list ()
- "Interpolate length of list variable inside double-quotes"
+ "Interpolate length of list variable inside double-quotes."
(let ((eshell-test-value '((1 2) (3) (5 (6 7 8 9)))))
(eshell-command-result-equal "echo \"$#eshell-test-value\""
"3")
@@ -278,63 +404,90 @@ inside double-quotes"
"4")))
(ert-deftest esh-var-test/quoted-interp-var-length-string ()
- "Interpolate length of string variable inside double-quotes"
+ "Interpolate length of string variable inside double-quotes."
(let ((eshell-test-value "foobar"))
(eshell-command-result-equal "echo \"$#eshell-test-value\""
"6")))
(ert-deftest esh-var-test/quoted-interp-var-length-alist ()
- "Interpolate length of alist variable inside double-quotes"
+ "Interpolate length of alist variable inside double-quotes."
(let ((eshell-test-value '(("foo" . (1 2 3)))))
(eshell-command-result-equal "echo \"$#eshell-test-value\""
"1")
(eshell-command-result-equal "echo \"$#eshell-test-value[foo]\""
"3")))
+(ert-deftest esh-var-test/quoted-interp-var-splice ()
+ "Splice-interpolate list variable inside double-quotes."
+ (let ((eshell-test-value '(1 2 3)))
+ (eshell-command-result-equal "echo a \"$@eshell-test-value\" z"
+ '("a" "1 2 3" "z"))))
+
+(ert-deftest esh-var-test/quoted-interp-var-splice-concat ()
+ "Splice-interpolate and concat list variable inside double-quotes"
+ (let ((eshell-test-value '(1 2 3)))
+ (eshell-command-result-equal "echo \"a$@'eshell-test-value'z\""
+ "a1 2 3z")))
+
(ert-deftest esh-var-test/quoted-interp-lisp ()
- "Interpolate Lisp form evaluation inside double-quotes"
+ "Interpolate Lisp form evaluation inside double-quotes."
(eshell-command-result-equal "echo \"hi $(concat \\\"the\\\" \\\"re\\\")\""
"hi there"))
(ert-deftest esh-var-test/quoted-interp-lisp-indices ()
- "Interpolate Lisp form evaluation with index"
+ "Interpolate Lisp form evaluation with index."
(eshell-command-result-equal "concat \"$(list 1 2)[1]\" cool"
"2cool"))
(ert-deftest esh-var-test/quoted-interp-cmd ()
- "Interpolate command result inside double-quotes"
+ "Interpolate command result inside double-quotes."
(eshell-command-result-equal "echo \"hi ${echo \\\"there\\\"}\""
"hi there"))
(ert-deftest esh-var-test/quoted-interp-cmd-indices ()
- "Interpolate command result with index inside double-quotes"
+ "Interpolate command result with index inside double-quotes."
(eshell-command-result-equal "concat \"${listify 1 2}[1]\" cool"
"2cool"))
(ert-deftest esh-var-test/quoted-interp-temp-cmd ()
- "Interpolate command result redirected to temp file inside double-quotes"
+ "Interpolate command result redirected to temp file inside double-quotes."
(let ((temporary-file-directory
(file-name-as-directory (make-temp-file "esh-vars-tests" t))))
(unwind-protect
- (eshell-command-result-equal "cat \"$<echo hi>\"" "hi")
+ (eshell-command-result-equal "cat \"$<echo \\\"hi\\\">\"" "hi")
(delete-directory temporary-file-directory t))))
(ert-deftest esh-var-test/quoted-interp-concat-cmd ()
- "Interpolate and concat command with literal"
+ "Interpolate and concat command with literal."
(eshell-command-result-equal "echo \"${echo \\\"foo\nbar\\\"} baz\""
"foo\nbar baz"))
+;; Interpolating commands
+
+(ert-deftest esh-var-test/command-interp ()
+ "Interpolate a variable as a command name."
+ (let ((eshell-test-value "printnl"))
+ (eshell-command-result-equal "$eshell-test-value hello there"
+ "hello\nthere\n")))
+
+(ert-deftest esh-var-test/command-interp-splice ()
+ "Interpolate a splice variable as a command name with arguments."
+ (let ((eshell-test-value '("printnl" "hello" "there")))
+ (eshell-command-result-equal "$@eshell-test-value"
+ "hello\nthere\n")))
+
+
;; Interpolated variable conversion
(ert-deftest esh-var-test/interp-convert-var-number ()
- "Interpolate numeric variable"
+ "Interpolate numeric variable."
(let ((eshell-test-value 123))
(eshell-command-result-equal "type-of $eshell-test-value"
'integer)))
(ert-deftest esh-var-test/interp-convert-var-split-indices ()
- "Interpolate and convert string variable with indices"
+ "Interpolate and convert string variable with indices."
;; Check that numeric forms are converted to numbers.
(let ((eshell-test-value "000 010 020 030 040"))
(eshell-command-result-equal "echo $eshell-test-value[0]"
@@ -349,7 +502,7 @@ inside double-quotes"
"baz\n")))
(ert-deftest esh-var-test/interp-convert-quoted-var-number ()
- "Interpolate numeric quoted numeric variable"
+ "Interpolate numeric quoted numeric variable."
(let ((eshell-test-value 123))
(eshell-command-result-equal "type-of $'eshell-test-value'"
'integer)
@@ -357,7 +510,7 @@ inside double-quotes"
'integer)))
(ert-deftest esh-var-test/interp-convert-quoted-var-split-indices ()
- "Interpolate and convert quoted string variable with indices"
+ "Interpolate and convert quoted string variable with indices."
(let ((eshell-test-value "000 010 020 030 040"))
(eshell-command-result-equal "echo $'eshell-test-value'[0]"
0)
@@ -365,11 +518,11 @@ inside double-quotes"
'(0 20))))
(ert-deftest esh-var-test/interp-convert-cmd-string-newline ()
- "Interpolate trailing-newline command result"
+ "Interpolate trailing-newline command result."
(eshell-command-result-equal "echo ${echo \"foo\n\"}" "foo"))
(ert-deftest esh-var-test/interp-convert-cmd-multiline ()
- "Interpolate multi-line command result"
+ "Interpolate multi-line command result."
(eshell-command-result-equal "echo ${echo \"foo\nbar\"}"
'("foo" "bar"))
;; Numeric output should be converted to numbers...
@@ -380,24 +533,24 @@ inside double-quotes"
'("01" "02" "hi")))
(ert-deftest esh-var-test/interp-convert-cmd-number ()
- "Interpolate numeric command result"
+ "Interpolate numeric command result."
(eshell-command-result-equal "echo ${echo \"1\"}" 1))
(ert-deftest esh-var-test/interp-convert-cmd-split-indices ()
- "Interpolate command result with indices"
+ "Interpolate command result with indices."
(eshell-command-result-equal "echo ${echo \"000 010 020\"}[0]"
0)
(eshell-command-result-equal "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"
+ "Interpolate numeric variable inside double-quotes."
(let ((eshell-test-value 123))
(eshell-command-result-equal "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"
+ "Interpolate string variable with indices inside double-quotes."
(let ((eshell-test-value "000 010 020 030 040"))
(eshell-command-result-equal "echo \"$eshell-test-value[0]\""
"000")
@@ -405,7 +558,7 @@ inside double-quotes"
"(\"000\" \"020\")")))
(ert-deftest esh-var-test/quoted-interp-convert-quoted-var-number ()
- "Interpolate numeric quoted variable inside double-quotes"
+ "Interpolate numeric quoted variable inside double-quotes."
(let ((eshell-test-value 123))
(eshell-command-result-equal "type-of \"$'eshell-test-value'\""
'string)
@@ -413,7 +566,7 @@ inside double-quotes"
'string)))
(ert-deftest esh-var-test/quoted-interp-convert-quoted-var-split-indices ()
- "Interpolate quoted string variable with indices inside double-quotes"
+ "Interpolate quoted string variable with indices inside double-quotes."
(let ((eshell-test-value "000 010 020 030 040"))
(eshell-command-result-equal "echo \"$eshell-test-value[0]\""
"000")
@@ -421,23 +574,23 @@ inside double-quotes"
"(\"000\" \"020\")")))
(ert-deftest esh-var-test/quoted-interp-convert-cmd-string-newline ()
- "Interpolate trailing-newline command result inside double-quotes"
+ "Interpolate trailing-newline command result inside double-quotes."
(eshell-command-result-equal "echo \"${echo \\\"foo\n\\\"}\""
"foo")
(eshell-command-result-equal "echo \"${echo \\\"foo\n\n\\\"}\""
"foo"))
(ert-deftest esh-var-test/quoted-interp-convert-cmd-multiline ()
- "Interpolate multi-line command result inside double-quotes"
+ "Interpolate multi-line command result inside double-quotes."
(eshell-command-result-equal "echo \"${echo \\\"foo\nbar\\\"}\""
"foo\nbar"))
(ert-deftest esh-var-test/quoted-interp-convert-cmd-number ()
- "Interpolate numeric command result inside double-quotes"
+ "Interpolate numeric command result inside double-quotes."
(eshell-command-result-equal "echo \"${echo \\\"1\\\"}\"" "1"))
(ert-deftest esh-var-test/quoted-interp-convert-cmd-split-indices ()
- "Interpolate command result with indices inside double-quotes"
+ "Interpolate command result with indices inside double-quotes."
(eshell-command-result-equal "echo \"${echo \\\"000 010 020\\\"}[0]\""
"000"))
@@ -492,6 +645,29 @@ inside double-quotes"
(eshell-match-command-output "VAR=hello env" "VAR=hello\n")
(should (equal (getenv "VAR") "value"))))
+(ert-deftest esh-var-test/local-variables/skip-nil ()
+ "Test that Eshell skips leading nil arguments after local variable setting."
+ (with-temp-eshell
+ (push "VAR=value" process-environment)
+ (eshell-match-command-output "VAR=hello $eshell-test-value env"
+ "VAR=hello\n")
+ (should (equal (getenv "VAR") "value"))))
+
+(ert-deftest esh-var-test/local-variables/cd ()
+ "Test that \"VAR=value cd DIR\" properly changes the directory."
+ (let ((parent-directory (file-name-directory
+ (directory-file-name default-directory))))
+ (with-temp-eshell
+ (eshell-insert-command "VAR=hello cd ..")
+ (should (equal default-directory parent-directory)))))
+
+(ert-deftest esh-var-test/local-variables/env ()
+ "Test that \"env VAR=value command\" temporarily sets variables."
+ (with-temp-eshell
+ (push "VAR=value" process-environment)
+ (eshell-match-command-output "env VAR=hello env" "VAR=hello\n")
+ (should (equal (getenv "VAR") "value"))))
+
;; Variable aliases
@@ -596,23 +772,69 @@ it, since the setter is nil."
(window-body-height nil 'remap)))
(ert-deftest esh-var-test/columns-var ()
- "$COLUMNS should equal (window-body-width nil 'remap)"
+ "$COLUMNS should equal (window-body-width nil 'remap)."
(eshell-command-result-equal "echo $COLUMNS"
(window-body-width nil 'remap)))
(ert-deftest esh-var-test/inside-emacs-var ()
- "Test presence of \"INSIDE_EMACS\" in subprocesses"
+ "Test presence of \"INSIDE_EMACS\" in subprocesses."
(with-temp-eshell
(eshell-match-command-output "env"
(format "INSIDE_EMACS=%s,eshell"
emacs-version))))
(ert-deftest esh-var-test/inside-emacs-var-split-indices ()
- "Test using \"INSIDE_EMACS\" with split indices"
+ "Test using \"INSIDE_EMACS\" with split indices."
(with-temp-eshell
(eshell-match-command-output "echo $INSIDE_EMACS[, 1]"
"eshell")))
+(ert-deftest esh-var-test/pager-var/default ()
+ "Test that retrieving the default value of $PAGER works.
+This should be the value of `comint-pager' if non-nil, otherwise
+the value of the $PAGER env var."
+ (let ((comint-pager nil)
+ (process-environment (cons "PAGER=cat" process-environment)))
+ (eshell-command-result-equal "echo $PAGER" "cat")
+ (setq comint-pager "less")
+ (eshell-command-result-equal "echo $PAGER" "less")))
+
+(ert-deftest esh-var-test/pager-var/set ()
+ "Test that setting $PAGER in Eshell overrides the default value."
+ (let ((comint-pager nil)
+ (process-environment (cons "PAGER=cat" process-environment)))
+ (with-temp-eshell
+ (eshell-match-command-output "set PAGER bat" "bat")
+ (eshell-match-command-output "echo $PAGER" "bat"))
+ (setq comint-pager "less")
+ (with-temp-eshell
+ (eshell-match-command-output "set PAGER bat" "bat")
+ (eshell-match-command-output "echo $PAGER" "bat"))))
+
+(ert-deftest esh-var-test/pager-var/unset ()
+ "Test that unsetting $PAGER in Eshell overrides the default value."
+ (let ((comint-pager nil)
+ (process-environment (cons "PAGER=cat" process-environment)))
+ (with-temp-eshell
+ (eshell-insert-command "unset PAGER")
+ (eshell-match-command-output "echo $PAGER" "\\`\\'"))
+ (setq comint-pager "less")
+ (with-temp-eshell
+ (eshell-insert-command "unset PAGER")
+ (eshell-match-command-output "echo $PAGER" "\\`\\'"))))
+
+(ert-deftest esh-var-test/pager-var/set-locally ()
+ "Test setting $PAGER temporarily for a single command."
+ (let ((comint-pager nil)
+ (process-environment (cons "PAGER=cat" process-environment)))
+ (with-temp-eshell
+ (eshell-match-command-output "PAGER=bat env" "PAGER=bat\n")
+ (eshell-match-command-output "echo $PAGER" "cat"))
+ (setq comint-pager "less")
+ (with-temp-eshell
+ (eshell-match-command-output "PAGER=bat env" "PAGER=bat\n")
+ (eshell-match-command-output "echo $PAGER" "less"))))
+
(ert-deftest esh-var-test/path-var/local-directory ()
"Test using $PATH in a local directory."
(let ((expected-path (string-join (eshell-get-path t) (path-separator))))
@@ -672,8 +894,16 @@ it, since the setter is nil."
(format "cd %s" ert-remote-temporary-file-directory))
(eshell-match-command-output "echo $PATH" (regexp-quote remote-path)))))
+(ert-deftest esh-var-test/uid-var ()
+ "Test that $UID is equivalent to (user-uid) for local directories."
+ (eshell-command-result-equal "echo $UID" (user-uid)))
+
+(ert-deftest esh-var-test/gid-var ()
+ "Test that $GID is equivalent to (group-gid) for local directories."
+ (eshell-command-result-equal "echo $GID" (group-gid)))
+
(ert-deftest esh-var-test/last-status-var-lisp-command ()
- "Test using the \"last exit status\" ($?) variable with a Lisp command"
+ "Test using the \"last exit status\" ($?) variable with a Lisp command."
(with-temp-eshell
(eshell-match-command-output "zerop 0; echo $?"
"t\n0\n")
@@ -683,7 +913,7 @@ it, since the setter is nil."
"1\n" nil t)))
(ert-deftest esh-var-test/last-status-var-lisp-form ()
- "Test using the \"last exit status\" ($?) variable with a Lisp form"
+ "Test using the \"last exit status\" ($?) variable with a Lisp form."
(let ((eshell-lisp-form-nil-is-failure t))
(with-temp-eshell
(eshell-match-command-output "(zerop 0); echo $?"
@@ -706,7 +936,7 @@ This tests when `eshell-lisp-form-nil-is-failure' is nil."
"1\n" nil t))))
(ert-deftest esh-var-test/last-status-var-ext-cmd ()
- "Test using the \"last exit status\" ($?) variable with an external command"
+ "Test using the \"last exit status\" ($?) variable with an external command."
(skip-unless (executable-find "["))
(with-temp-eshell
(eshell-match-command-output "[ foo = foo ]; echo $?"
@@ -715,19 +945,19 @@ This tests when `eshell-lisp-form-nil-is-failure' is nil."
"1\n")))
(ert-deftest esh-var-test/last-result-var ()
- "Test using the \"last result\" ($$) variable"
+ "Test using the \"last result\" ($$) variable."
(with-temp-eshell
(eshell-match-command-output "+ 1 2; + $$ 2"
"3\n5\n")))
(ert-deftest esh-var-test/last-result-var-twice ()
- "Test using the \"last result\" ($$) variable twice"
+ "Test using the \"last result\" ($$) variable twice."
(with-temp-eshell
(eshell-match-command-output "+ 1 2; + $$ $$"
"3\n6\n")))
(ert-deftest esh-var-test/last-result-var-ext-cmd ()
- "Test using the \"last result\" ($$) variable with an external command"
+ "Test using the \"last result\" ($$) variable with an external command."
(skip-unless (executable-find "["))
(with-temp-eshell
;; MS-DOS/MS-Windows have an external command 'format', which we
@@ -739,7 +969,7 @@ This tests when `eshell-lisp-form-nil-is-failure' is nil."
"nil\n"))))
(ert-deftest esh-var-test/last-result-var-split-indices ()
- "Test using the \"last result\" ($$) variable with split indices"
+ "Test using the \"last result\" ($$) variable with split indices."
(with-temp-eshell
(eshell-match-command-output
"string-join (list \"01\" \"02\") :; + $$[: 1] 3"
@@ -749,13 +979,13 @@ This tests when `eshell-lisp-form-nil-is-failure' is nil."
"01:02\n02\n")))
(ert-deftest esh-var-test/last-arg-var ()
- "Test using the \"last arg\" ($_) variable"
+ "Test using the \"last arg\" ($_) variable."
(with-temp-eshell
(eshell-match-command-output "+ 1 2; + $_ 4"
"3\n6\n")))
(ert-deftest esh-var-test/last-arg-var-indices ()
- "Test using the \"last arg\" ($_) variable with indices"
+ "Test using the \"last arg\" ($_) variable with indices."
(with-temp-eshell
(eshell-match-command-output "+ 1 2; + $_[0] 4"
"3\n5\n")
@@ -763,7 +993,7 @@ This tests when `eshell-lisp-form-nil-is-failure' is nil."
"3\n6\n")))
(ert-deftest esh-var-test/last-arg-var-split-indices ()
- "Test using the \"last arg\" ($_) variable with split indices"
+ "Test using the \"last arg\" ($_) variable with split indices."
(with-temp-eshell
(eshell-match-command-output "concat 01:02 03:04; + $_[0][: 1] 5"
"01:0203:04\n7\n")
diff --git a/test/lisp/eshell/eshell-tests-helpers.el b/test/lisp/eshell/eshell-tests-helpers.el
index 4c833c96e7e..652146fefcc 100644
--- a/test/lisp/eshell/eshell-tests-helpers.el
+++ b/test/lisp/eshell/eshell-tests-helpers.el
@@ -33,9 +33,9 @@
(defvar eshell-history-file-name nil)
(defvar eshell-last-dir-ring-file-name nil)
-(defvar eshell-test--max-subprocess-time 5
- "The maximum amount of time to wait for a subprocess to finish, in seconds.
-See `eshell-wait-for-subprocess'.")
+(defvar eshell-test--max-wait-time 5
+ "The maximum amount of time to wait for a condition to resolve, in seconds.
+See `eshell-wait-for'.")
(defun eshell-tests-remote-accessible-p ()
"Return if a test involving remote files can proceed.
@@ -54,6 +54,13 @@ beginning of the test file."
(let* (;; We want no history file, so prevent Eshell from falling
;; back on $HISTFILE.
(process-environment (cons "HISTFILE" process-environment))
+ ;; Enable process debug instrumentation. We may be able
+ ;; to remove this eventually once we're confident that
+ ;; all the process bugs have been worked out. (At that
+ ;; point, we can just enable this selectively when
+ ;; needed.) See also `eshell-test-command-result'
+ ;; below.
+ (eshell-debug-command (cons 'process eshell-debug-command))
(eshell-history-file-name nil)
(eshell-last-dir-ring-file-name nil)
(eshell-buffer (eshell t)))
@@ -73,19 +80,35 @@ BUFNAME will be set to the name of the temporary buffer."
(let ((,bufname (buffer-name)))
,@body)))
+(defun eshell-wait-for (predicate &optional message)
+ "Wait until PREDICATE returns non-nil.
+If this takes longer than `eshell-test--max-wait-time', raise an
+error. MESSAGE is an optional message to use if this times out."
+ (let ((start (current-time))
+ (message (or message "timed out waiting for condition")))
+ (while (not (funcall predicate))
+ (when (> (float-time (time-since start))
+ eshell-test--max-wait-time)
+ (error message))
+ (sit-for 0.1))))
+
(defun eshell-wait-for-subprocess (&optional all)
"Wait until there is no interactive subprocess running in Eshell.
If ALL is non-nil, wait until there are no Eshell subprocesses at
all running.
-If this takes longer than `eshell-test--max-subprocess-time',
+If this takes longer than `eshell-test--max-wait-time',
raise an error."
- (let ((start (current-time)))
- (while (if all eshell-process-list (eshell-interactive-process-p))
- (when (> (float-time (time-since start))
- eshell-test--max-subprocess-time)
- (error "timed out waiting for subprocess(es)"))
- (sit-for 0.1))))
+ (eshell-wait-for
+ (lambda ()
+ (not (if all eshell-process-list (eshell-interactive-process-p))))))
+
+(defun eshell-get-debug-logs ()
+ "Get debug command logs for displaying on test failures."
+ (when (get-buffer eshell-debug-command-buffer)
+ (let ((separator (make-string 40 ?-)))
+ (with-current-buffer eshell-debug-command-buffer
+ (string-replace "\f" separator (buffer-string))))))
(defun eshell-insert-command (command &optional func)
"Insert a COMMAND at the end of the buffer.
@@ -126,17 +149,21 @@ FUNC is the function to call after inserting the text (see
If IGNORE-ERRORS is non-nil, ignore any errors signaled when
inserting the command."
- (let ((debug-on-error (and (not ignore-errors) debug-on-error)))
- (eshell-insert-command command func))
- (eshell-wait-for-subprocess)
- (should (eshell-match-output regexp)))
+ (ert-info (#'eshell-get-debug-logs :prefix "Command logs: ")
+ (let ((debug-on-error (and (not ignore-errors) debug-on-error)))
+ (eshell-insert-command command func))
+ (eshell-wait-for-subprocess)
+ (should (eshell-match-output regexp))))
(defvar eshell-history-file-name)
(defun eshell-test-command-result (command)
"Like `eshell-command-result', but not using HOME."
(ert-with-temp-directory eshell-directory-name
- (let ((eshell-history-file-name nil))
+ (let ((eshell-history-file-name nil)
+ ;; Enable process debug instrumentation. See
+ ;; `with-temp-eshell' above.
+ (eshell-debug-command (cons 'process eshell-debug-command)))
(eshell-command-result command))))
(defun eshell-command-result--equal (_command actual expected)
@@ -155,10 +182,11 @@ inserting the command."
(defun eshell-command-result-equal (command result)
"Execute COMMAND non-interactively and compare it to RESULT."
- (should (eshell-command-result--equal
- command
- (eshell-test-command-result command)
- result)))
+ (ert-info (#'eshell-get-debug-logs :prefix "Command logs: ")
+ (should (eshell-command-result--equal
+ command
+ (eshell-test-command-result command)
+ result))))
(provide 'eshell-tests-helpers)
diff --git a/test/lisp/eshell/eshell-tests-unload.el b/test/lisp/eshell/eshell-tests-unload.el
new file mode 100644
index 00000000000..bf8291ba47a
--- /dev/null
+++ b/test/lisp/eshell/eshell-tests-unload.el
@@ -0,0 +1,99 @@
+;;; eshell-tests-unload.el --- test unloading Eshell -*- lexical-binding:t -*-
+
+;; Copyright (C) 2023-2024 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 <https://www.gnu.org/licenses/>.
+
+;;; Commentary:
+
+;; Tests for unloading Eshell.
+
+;;; Code:
+
+(require 'ert)
+(require 'ert-x)
+
+;; In order to test unloading Eshell, don't require any of its files
+;; at the top level. This means we need to explicitly declare some of
+;; the variables and functions we'll use.
+(defvar eshell-directory-name)
+(defvar eshell-history-file-name)
+(defvar eshell-last-dir-ring-file-name)
+(defvar eshell-modules-list)
+
+(declare-function eshell-module--feature-name "esh-module"
+ (module &optional kind))
+(declare-function eshell-subgroups "esh-util" (groupsym))
+
+(defvar max-unload-time 5
+ "The maximum amount of time to wait to unload Eshell modules, in seconds.
+See `unload-eshell'.")
+
+(defun load-eshell ()
+ "Load Eshell by calling the `eshell' function and immediately closing it."
+ (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-last-dir-ring-file-name nil)
+ (eshell-buffer (eshell t)))
+ (let (kill-buffer-query-functions)
+ (kill-buffer eshell-buffer))))))
+
+(defun unload-eshell ()
+ "Unload Eshell, waiting until the core modules are unloaded as well."
+ (let ((debug-on-error t)
+ (inhibit-message t))
+ (unload-feature 'eshell)
+ ;; We unload core modules are unloaded from a timer, since they
+ ;; need to wait until after `eshell' itself is unloaded. Wait for
+ ;; this to finish.
+ (let ((start (current-time)))
+ (while (featurep 'esh-arg)
+ (when (> (float-time (time-since start))
+ max-unload-time)
+ (error "timed out waiting to unload Eshell modules"))
+ (sit-for 0.1)))))
+
+;;; Tests:
+
+(ert-deftest eshell-test-unload/default ()
+ "Test unloading Eshell with the default list of extension modules."
+ (load-eshell)
+ (unload-eshell))
+
+(ert-deftest eshell-test-unload/no-modules ()
+ "Test unloading Eshell with no extension modules."
+ (require 'esh-module)
+ (let (eshell-modules-list)
+ (load-eshell))
+ (dolist (module (eshell-subgroups 'eshell-module))
+ (should-not (featurep (intern (eshell-module--feature-name module)))))
+ (unload-eshell))
+
+(ert-deftest eshell-test-unload/all-modules ()
+ "Test unloading Eshell with every extension module."
+ (require 'esh-module)
+ (let ((eshell-modules-list (eshell-subgroups 'eshell-module)))
+ (load-eshell))
+ (dolist (module (eshell-subgroups 'eshell-module))
+ (should (featurep (intern (eshell-module--feature-name module)))))
+ (unload-eshell))
+
+(provide 'eshell-tests-unload)
+;;; eshell-tests-unload.el ends here
diff --git a/test/lisp/eshell/eshell-tests.el b/test/lisp/eshell/eshell-tests.el
index 3812a4117ac..e58b5a14ed9 100644
--- a/test/lisp/eshell/eshell-tests.el
+++ b/test/lisp/eshell/eshell-tests.el
@@ -34,76 +34,9 @@
(file-name-directory (or load-file-name
default-directory))))
-;;; Tests:
-
-(ert-deftest eshell-test/pipe-headproc ()
- "Check that piping a non-process to a process command waits for the process"
- (skip-unless (executable-find "cat"))
- (with-temp-eshell
- (eshell-match-command-output "echo hi | *cat"
- "hi")))
-
-(ert-deftest eshell-test/pipe-tailproc ()
- "Check that piping a process to a non-process command waits for the process"
- (skip-unless (executable-find "echo"))
- (with-temp-eshell
- (eshell-match-command-output "*echo hi | echo bye"
- "bye\nhi\n")))
-
-(ert-deftest eshell-test/pipe-headproc-stdin ()
- "Check that standard input is sent to the head process in a pipeline"
- (skip-unless (and (executable-find "tr")
- (executable-find "rev")))
- (with-temp-eshell
- (eshell-insert-command "tr a-z A-Z | rev")
- (eshell-insert-command "hello")
- (eshell-send-eof-to-process)
- (eshell-wait-for-subprocess)
- (should (eshell-match-output "OLLEH\n"))))
-
-(ert-deftest eshell-test/pipe-subcommand ()
- "Check that piping with an asynchronous subcommand works"
- (skip-unless (and (executable-find "echo")
- (executable-find "cat")))
- (with-temp-eshell
- (eshell-match-command-output "echo ${*echo hi} | *cat"
- "hi")))
+(defvar eshell-test-value nil)
-(ert-deftest eshell-test/pipe-subcommand-with-pipe ()
- "Check that piping with an asynchronous subcommand with its own pipe works"
- (skip-unless (and (executable-find "echo")
- (executable-find "cat")))
- (with-temp-eshell
- (eshell-match-command-output "echo ${*echo hi | *cat} | *cat"
- "hi")))
-
-(ert-deftest eshell-test/subcommand-reset-in-pipeline ()
- "Check that subcommands reset `eshell-in-pipeline-p'."
- (skip-unless (executable-find "cat"))
- (dolist (template '("echo {%s} | *cat"
- "echo ${%s} | *cat"
- "*cat $<%s> | *cat"))
- (eshell-command-result-equal
- (format template "echo $eshell-in-pipeline-p")
- nil)
- (eshell-command-result-equal
- (format template "echo | echo $eshell-in-pipeline-p")
- "last")
- (eshell-command-result-equal
- (format template "echo $eshell-in-pipeline-p | echo")
- "first")
- (eshell-command-result-equal
- (format template "echo | echo $eshell-in-pipeline-p | echo")
- "t")))
-
-(ert-deftest eshell-test/lisp-reset-in-pipeline ()
- "Check that interpolated Lisp forms reset `eshell-in-pipeline-p'."
- (skip-unless (executable-find "cat"))
- (dolist (template '("echo (%s) | *cat"
- "echo $(%s) | *cat"))
- (eshell-command-result-equal
- (format template "format \"%s\" eshell-in-pipeline-p")
- "nil")))
+;;; Tests:
(ert-deftest eshell-test/eshell-command/simple ()
"Test that the `eshell-command' function writes to the current buffer."
@@ -125,21 +58,28 @@ This test uses a pipeline for the command."
(eshell-command "*echo hi | *cat" t)
(should (equal (buffer-string) "hi\n"))))))
+(ert-deftest eshell-test/eshell-command/pipeline-wait ()
+ "Check that `eshell-command' waits for all its processes before returning."
+ (skip-unless (and (executable-find "echo")
+ (executable-find "sh")
+ (executable-find "rev")))
+ (ert-with-temp-directory eshell-directory-name
+ (let ((eshell-history-file-name nil))
+ (with-temp-buffer
+ (eshell-command
+ "*echo hello | sh -c 'sleep 1; rev' 1>&2 | *echo goodbye" t)
+ (should (equal (buffer-string) "goodbye\nolleh\n"))))))
+
(ert-deftest eshell-test/eshell-command/background ()
"Test that `eshell-command' works for background commands."
(skip-unless (executable-find "echo"))
(ert-with-temp-directory eshell-directory-name
- (let ((eshell-history-file-name nil))
- ;; XXX: We can't write to the current buffer here, since
- ;; `eshell-command' will produce an invalid command in that
- ;; case. Just make sure the command runs and produces an output
- ;; buffer.
- (eshell-command "*echo hi &")
- (with-current-buffer "*Eshell Async Command Output*"
- (while (get-buffer-process (current-buffer))
- (accept-process-output))
- (goto-char (point-min))
- (should (looking-at "\\[echo\\(\\.exe\\)?\\(<[0-9]+>\\)?\\]"))))))
+ (let ((orig-processes (process-list))
+ (eshell-history-file-name nil))
+ (with-temp-buffer
+ (eshell-command "*echo hi &" t)
+ (eshell-wait-for (lambda () (equal (process-list) orig-processes)))
+ (should (equal (buffer-string) "hi\n"))))))
(ert-deftest eshell-test/eshell-command/background-pipeline ()
"Test that `eshell-command' works for background commands.
@@ -147,14 +87,35 @@ This test uses a pipeline for the command."
(skip-unless (and (executable-find "echo")
(executable-find "cat")))
(ert-with-temp-directory eshell-directory-name
+ (let ((orig-processes (process-list))
+ (eshell-history-file-name nil))
+ (with-temp-buffer
+ (eshell-command "*echo hi | *cat &" t)
+ (eshell-wait-for (lambda () (equal (process-list) orig-processes)))
+ (should (equal (buffer-string) "hi\n"))))))
+
+(ert-deftest eshell-test/eshell-command/output-buffer/sync ()
+ "Test that the `eshell-command' function writes to its output buffer."
+ (skip-unless (executable-find "echo"))
+ (ert-with-temp-directory eshell-directory-name
(let ((eshell-history-file-name nil))
- ;; XXX: As above, we can't write to the current buffer here.
- (eshell-command "*echo hi | *cat &")
+ (eshell-command "*echo 'hi\nbye'")
+ (with-current-buffer "*Eshell Command Output*"
+ (should (equal (buffer-string) "hi\nbye")))
+ (kill-buffer "*Eshell Command Output*"))))
+
+(ert-deftest eshell-test/eshell-command/output-buffer/async ()
+ "Test that the `eshell-command' function writes to its async output buffer."
+ (skip-unless (executable-find "echo"))
+ (ert-with-temp-directory eshell-directory-name
+ (let ((orig-processes (process-list))
+ (eshell-history-file-name nil))
+ (eshell-command "*echo hi &")
+ (eshell-wait-for (lambda () (equal (process-list) orig-processes)))
(with-current-buffer "*Eshell Async Command Output*"
- (while (get-buffer-process (current-buffer))
- (accept-process-output))
(goto-char (point-min))
- (should (looking-at "\\[cat\\(\\.exe\\)?\\(<[0-9]+>\\)?\\]"))))))
+ (forward-line)
+ (should (looking-at "hi\n"))))))
(ert-deftest eshell-test/command-running-p ()
"Modeline should show no command running"
@@ -167,43 +128,91 @@ This test uses a pipeline for the command."
"Test moving across command arguments"
(with-temp-eshell
(eshell-insert-command "echo $(+ 1 (- 4 3)) \"alpha beta\" file" 'ignore)
- (let ((here (point)) begin valid)
- (eshell-bol)
+ (let ((end (point)) begin)
+ (beginning-of-line)
(setq begin (point))
(eshell-forward-argument 4)
- (setq valid (= here (point)))
+ (should (= end (point)))
(eshell-backward-argument 4)
- (prog1
- (and valid (= begin (point)))
- (eshell-bol)
- (delete-region (point) (point-max))))))
+ (should (= begin (point))))))
(ert-deftest eshell-test/queue-input ()
- "Test queuing command input"
+ "Test queuing command input.
+This should let the current command finish, then automatically
+insert the queued one at the next prompt, and finally run it."
(with-temp-eshell
- (eshell-insert-command "sleep 2")
- (eshell-insert-command "echo alpha" 'eshell-queue-input)
- (let ((count 10))
- (while (and eshell-current-command
- (> count 0))
- (sit-for 1)
- (setq count (1- count))))
- (should (eshell-match-output "alpha\n"))))
+ (eshell-insert-command "sleep 1; echo slept")
+ (eshell-insert-command "echo alpha" #'eshell-queue-input)
+ (let ((start (marker-position (eshell-beginning-of-output))))
+ (eshell-wait-for (lambda () (not eshell-foreground-command)))
+ (should (string-match "^slept\n.*echo alpha\nalpha\n$"
+ (buffer-substring-no-properties
+ start (eshell-end-of-output)))))))
(ert-deftest eshell-test/flush-output ()
"Test flushing of previous output"
(with-temp-eshell
(eshell-insert-command "echo alpha")
- (eshell-kill-output)
+ (eshell-delete-output)
(should (eshell-match-output
(concat "^" (regexp-quote "*** output flushed ***\n") "$")))))
-(ert-deftest eshell-test/run-old-command ()
- "Re-run an old command"
+(ert-deftest eshell-test/get-old-input ()
+ "Test that we can get the input of a previous command."
(with-temp-eshell
(eshell-insert-command "echo alpha")
(goto-char eshell-last-input-start)
- (string= (eshell-get-old-input) "echo alpha")))
+ (should (string= (eshell-get-old-input) "echo alpha"))
+ ;; Make sure that `eshell-get-old-input' works even if the point is
+ ;; inside the prompt.
+ (let ((inhibit-field-text-motion t))
+ (beginning-of-line))
+ (should (string= (eshell-get-old-input) "echo alpha"))))
+
+(ert-deftest eshell-test/get-old-input/rerun-command ()
+ "Test that we can rerun an old command when point is on it."
+ (with-temp-eshell
+ (let ((eshell-test-value "first"))
+ (eshell-match-command-output "echo $eshell-test-value" "first"))
+ ;; Go to the previous prompt.
+ (forward-line -2)
+ (let ((inhibit-field-text-motion t))
+ (end-of-line))
+ ;; Rerun the command, but with a different variable value.
+ (let ((eshell-test-value "second"))
+ (eshell-send-input))
+ (eshell-match-output "second")))
+
+(ert-deftest eshell-test/get-old-input/run-output ()
+ "Test that we can run a line of output as a command when point is on it."
+ (with-temp-eshell
+ (eshell-match-command-output "echo \"echo there\"" "echo there")
+ ;; Go to the output, and insert "hello" after "echo".
+ (forward-line -1)
+ (forward-word)
+ (insert " hello")
+ ;; Run the line as a command.
+ (eshell-send-input)
+ (eshell-match-output "(\"hello\" \"there\")")))
+
+(ert-deftest eshell-test/yank-output ()
+ "Test that yanking a line of output into the next prompt works (bug#66469)."
+ (with-temp-eshell
+ (eshell-insert-command "echo hello")
+ ;; Go to the output and kill the line of text.
+ (forward-line -1)
+ (kill-line)
+ ;; Go to the last prompt and yank the previous output.
+ (goto-char (point-max))
+ (yank)
+ ;; Go to the beginning of the prompt and add some text.
+ (move-beginning-of-line 1)
+ (insert-and-inherit "echo ")
+ ;; Make sure when we go to the beginning of the line, we go to the
+ ;; right spot (before the "echo").
+ (move-end-of-line 1)
+ (move-beginning-of-line 1)
+ (should (looking-at "echo hello"))))
(provide 'eshell-tests)
diff --git a/test/lisp/filenotify-tests.el b/test/lisp/filenotify-tests.el
index f16cc09b6f1..28f4d5fa181 100644
--- a/test/lisp/filenotify-tests.el
+++ b/test/lisp/filenotify-tests.el
@@ -74,8 +74,8 @@
(defvar file-notify--test-events nil)
(defvar file-notify--test-monitors nil)
-(defun file-notify--test-read-event ()
- "Read one event.
+(defun file-notify--test-wait-event ()
+ "Wait for one event.
There are different timeouts for local and remote file notification libraries."
(read-event
nil nil
@@ -87,7 +87,8 @@ There are different timeouts for local and remote file notification libraries."
;; for any monitor.
((file-notify--test-monitor) 7)
((file-remote-p temporary-file-directory) 0.1)
- (t 0.01))))
+ (t 0.01)))
+ nil)
(defun file-notify--test-timeout ()
"Timeout to wait for arriving a bunch of events, in seconds."
@@ -103,7 +104,7 @@ There are different timeouts for local and remote file notification libraries."
TIMEOUT is the maximum time to wait for, in seconds."
`(with-timeout (,timeout (ignore))
(while (null ,until)
- (file-notify--test-read-event))))
+ (file-notify--test-wait-event))))
(defun file-notify--test-no-descriptors ()
"Check that `file-notify-descriptors' is an empty hash table.
@@ -452,7 +453,7 @@ If UNSTABLE is non-nil, the test is tagged as `:unstable'."
;; Check, that removing watch descriptors out of order do not
;; harm. This fails on cygwin because of timing issues unless a
;; long `sit-for' is added before the call to
- ;; `file-notify--test-read-event'.
+ ;; `file-notify--test-wait-event'.
(unless (eq system-type 'cygwin)
(let (results)
(cl-flet ((first-callback (event)
@@ -480,7 +481,7 @@ If UNSTABLE is non-nil, the test is tagged as `:unstable'."
;; Remove first watch.
(file-notify-rm-watch file-notify--test-desc)
;; Only the second callback shall run.
- (file-notify--test-read-event)
+ (file-notify--test-wait-event)
(delete-file file-notify--test-tmpfile)
(file-notify--test-wait-for-events
(file-notify--test-timeout) results)
@@ -622,7 +623,7 @@ delivered."
(cons 'file-notify while-no-input-ignore-events))
create-lockfiles)
;; Flush pending actions.
- (file-notify--test-read-event)
+ (file-notify--test-wait-event)
(file-notify--test-wait-for-events
(file-notify--test-timeout)
(not (input-pending-p)))
@@ -671,7 +672,7 @@ delivered."
(t '(created changed deleted stopped)))
(write-region
"another text" nil file-notify--test-tmpfile nil 'no-message)
- (file-notify--test-read-event)
+ (file-notify--test-wait-event)
(delete-file file-notify--test-tmpfile))
(file-notify-rm-watch file-notify--test-desc)
@@ -707,7 +708,7 @@ delivered."
(changed changed deleted stopped))))
(write-region
"another text" nil file-notify--test-tmpfile nil 'no-message)
- (file-notify--test-read-event)
+ (file-notify--test-wait-event)
(delete-file file-notify--test-tmpfile))
(file-notify-rm-watch file-notify--test-desc)
@@ -755,7 +756,7 @@ delivered."
(t '(created changed deleted deleted stopped)))
(write-region
"any text" nil file-notify--test-tmpfile nil 'no-message)
- (file-notify--test-read-event)
+ (file-notify--test-wait-event)
(delete-directory file-notify--test-tmpdir 'recursive))
(file-notify-rm-watch file-notify--test-desc)
@@ -805,14 +806,14 @@ delivered."
deleted deleted deleted stopped)))
(write-region
"any text" nil file-notify--test-tmpfile nil 'no-message)
- (file-notify--test-read-event)
+ (file-notify--test-wait-event)
(copy-file file-notify--test-tmpfile file-notify--test-tmpfile1)
;; The next two events shall not be visible.
- (file-notify--test-read-event)
+ (file-notify--test-wait-event)
(set-file-modes file-notify--test-tmpfile 000 'nofollow)
- (file-notify--test-read-event)
+ (file-notify--test-wait-event)
(set-file-times file-notify--test-tmpfile '(0 0) 'nofollow)
- (file-notify--test-read-event)
+ (file-notify--test-wait-event)
(delete-directory file-notify--test-tmpdir 'recursive))
(file-notify-rm-watch file-notify--test-desc)
@@ -860,10 +861,10 @@ delivered."
(t '(created changed renamed deleted deleted stopped)))
(write-region
"any text" nil file-notify--test-tmpfile nil 'no-message)
- (file-notify--test-read-event)
+ (file-notify--test-wait-event)
(rename-file file-notify--test-tmpfile file-notify--test-tmpfile1)
;; After the rename, we won't get events anymore.
- (file-notify--test-read-event)
+ (file-notify--test-wait-event)
(delete-directory file-notify--test-tmpdir 'recursive))
(file-notify-rm-watch file-notify--test-desc)
@@ -912,11 +913,11 @@ delivered."
(t '(attribute-changed attribute-changed)))
(write-region
"any text" nil file-notify--test-tmpfile nil 'no-message)
- (file-notify--test-read-event)
+ (file-notify--test-wait-event)
(set-file-modes file-notify--test-tmpfile 000 'nofollow)
- (file-notify--test-read-event)
+ (file-notify--test-wait-event)
(set-file-times file-notify--test-tmpfile '(0 0) 'nofollow)
- (file-notify--test-read-event)
+ (file-notify--test-wait-event)
(delete-file file-notify--test-tmpfile))
(file-notify-rm-watch file-notify--test-desc)
@@ -939,10 +940,13 @@ delivered."
:tags '(:expensive-test)
(skip-unless (file-notify--test-local-enabled))
- ;; `auto-revert-buffers' runs every 5". And we must wait, until the
- ;; file has been reverted.
- (let ((timeout (if (file-remote-p temporary-file-directory) 60 10))
- buf)
+ ;; Run with shortened `auto-revert-interval' for a faster test.
+ (let* ((auto-revert-interval 1)
+ (timeout (if (file-remote-p temporary-file-directory)
+ 60 ; FIXME: can this be shortened?
+ (* auto-revert-interval 2.5)))
+ buf)
+ (auto-revert-set-timer)
(unwind-protect
(progn
;; In the remote case, `vc-refresh-state' returns undesired
@@ -960,10 +964,9 @@ delivered."
(sleep-for 1)
(auto-revert-mode 1)
- ;; `auto-revert-buffers' runs every 5".
(with-timeout (timeout (ignore))
(while (null auto-revert-notify-watch-descriptor)
- (sleep-for 1)))
+ (sleep-for 0.2)))
;; `file-notify--test-monitor' needs to know
;; `file-notify--test-desc' in order to compute proper
@@ -971,8 +974,7 @@ delivered."
(setq file-notify--test-desc auto-revert-notify-watch-descriptor)
;; GKqueueFileMonitor does not report the `changed' event.
- (skip-unless
- (not (eq (file-notify--test-monitor) 'GKqueueFileMonitor)))
+ (skip-when (eq (file-notify--test-monitor) 'GKqueueFileMonitor))
;; Check, that file notification has been used.
(should auto-revert-mode)
@@ -1032,7 +1034,7 @@ delivered."
(file-notify--test-cleanup))))
(file-notify--deftest-remote file-notify-test04-autorevert
- "Check autorevert via file notification for remote files.")
+ "Check autorevert via file notification for remote files." t)
(ert-deftest file-notify-test05-file-validity ()
"Check `file-notify-valid-p' for files."
@@ -1086,7 +1088,7 @@ delivered."
(changed changed deleted stopped))))
(write-region
"another text" nil file-notify--test-tmpfile nil 'no-message)
- (file-notify--test-read-event)
+ (file-notify--test-wait-event)
(delete-file file-notify--test-tmpfile))
;; After deleting the file, the descriptor is not valid anymore.
(should-not (file-notify-valid-p file-notify--test-desc))
@@ -1133,7 +1135,7 @@ delivered."
(t '(created changed deleted deleted stopped)))
(write-region
"any text" nil file-notify--test-tmpfile nil 'no-message)
- (file-notify--test-read-event)
+ (file-notify--test-wait-event)
(delete-directory file-notify--test-tmpdir 'recursive))
;; After deleting the parent directory, the descriptor must
;; not be valid anymore.
@@ -1246,9 +1248,9 @@ delivered."
(let ((source-file-list source-file-list)
(target-file-list target-file-list))
(while (and source-file-list target-file-list)
- (file-notify--test-read-event)
+ (file-notify--test-wait-event)
(write-region "" nil (pop source-file-list) nil 'no-message)
- (file-notify--test-read-event)
+ (file-notify--test-wait-event)
(write-region "" nil (pop target-file-list) nil 'no-message))))
(file-notify--test-with-actions
(cond
@@ -1271,11 +1273,11 @@ delivered."
(let ((source-file-list source-file-list)
(target-file-list target-file-list))
(while (and source-file-list target-file-list)
- (file-notify--test-read-event)
+ (file-notify--test-wait-event)
(rename-file (pop source-file-list) (pop target-file-list) t))))
(file-notify--test-with-actions (make-list n 'deleted)
(dolist (file target-file-list)
- (file-notify--test-read-event)
+ (file-notify--test-wait-event)
(delete-file file)))
(delete-directory file-notify--test-tmpfile)
(if (or (string-equal (file-notify--test-library) "w32notify")
@@ -1463,7 +1465,7 @@ the file watch."
;; does not report the `changed' event.
(make-list (/ n 2) 'created)))
(dotimes (i n)
- (file-notify--test-read-event)
+ (file-notify--test-wait-event)
(if (zerop (mod i 2))
(write-region
"any text" nil file-notify--test-tmpfile1 t 'no-message)
@@ -1581,7 +1583,7 @@ the file watch."
:tags '(:expensive-test)
(skip-unless (file-notify--test-local-enabled))
;; This test does not work for kqueue (yet).
- (skip-unless (not (string-equal (file-notify--test-library) "kqueue")))
+ (skip-when (string-equal (file-notify--test-library) "kqueue"))
(setq file-notify--test-tmpfile (file-notify--test-make-temp-name)
file-notify--test-tmpfile1 (file-notify--test-make-temp-name))
@@ -1706,6 +1708,71 @@ the file watch."
(file-notify--deftest-remote file-notify-test11-symlinks
"Check `file-notify-test11-symlinks' for remote files.")
+(ert-deftest file-notify-test12-unmount ()
+ "Check that file notification stop after unmounting the filesystem."
+ :tags '(:expensive-test)
+ (skip-unless (file-notify--test-local-enabled))
+ ;; This test does not work for w32notify.
+ (skip-when (string-equal (file-notify--test-library) "w32notify"))
+
+ (unwind-protect
+ (progn
+ (setq file-notify--test-tmpfile (file-notify--test-make-temp-name))
+ ;; File monitors like kqueue insist, that the watched file
+ ;; exists. Directory monitors are not bound to this
+ ;; restriction.
+ (when (string-equal (file-notify--test-library) "kqueue")
+ (write-region
+ "any text" nil file-notify--test-tmpfile nil 'no-message))
+
+ (should
+ (setq file-notify--test-desc
+ (file-notify--test-add-watch
+ file-notify--test-tmpfile
+ '(attribute-change change) #'file-notify--test-event-handler)))
+ (should (file-notify-valid-p file-notify--test-desc))
+
+ ;; Unmounting the filesystem should stop watching.
+ (file-notify--test-with-actions '(stopped)
+ ;; We emulate unmounting by calling
+ ;; `file-notify-handle-event' with a corresponding event.
+ (file-notify-handle-event
+ (make-file-notify
+ :-event
+ (list file-notify--test-desc
+ (pcase (file-notify--test-library)
+ ((or "inotify" "inotifywait") '(unmount isdir))
+ ((or "gfilenotify" "gio") '(unmounted))
+ ("kqueue" '(revoke))
+ (err (ert-fail (format "Library %s not supported" err))))
+ (pcase (file-notify--test-library)
+ ("kqueue" (file-local-name file-notify--test-tmpfile))
+ (_ (file-local-name file-notify--test-tmpdir)))
+ ;; In the inotify case, there is a 4th slot `cookie'.
+ ;; Since it is unused for `unmount', we ignore it.
+ )
+ :-callback
+ (pcase (file-notify--test-library)
+ ("inotify" #'file-notify--callback-inotify)
+ ("gfilenotify" #'file-notify--callback-gfilenotify)
+ ("kqueue" #'file-notify--callback-kqueue)
+ ((or "inotifywait" "gio") #'file-notify-callback)
+ (err (ert-fail (format "Library %s not supported" err)))))))
+
+ ;; The watch has been stopped.
+ (should-not (file-notify-valid-p file-notify--test-desc))
+
+ ;; The environment shall be cleaned up.
+ (when (string-equal (file-notify--test-library) "kqueue")
+ (delete-file file-notify--test-tmpfile))
+ (file-notify--test-cleanup-p))
+
+ ;; Cleanup.
+ (file-notify--test-cleanup)))
+
+(file-notify--deftest-remote file-notify-test12-unmount
+ "Check `file-notify-test12-unmount' for remote files.")
+
(defun file-notify-test-all (&optional interactive)
"Run all tests for \\[file-notify]."
(interactive "p")
diff --git a/test/lisp/files-tests.el b/test/lisp/files-tests.el
index 2c1fff06f70..d4c1ef3ba67 100644
--- a/test/lisp/files-tests.el
+++ b/test/lisp/files-tests.el
@@ -166,6 +166,27 @@ form.")
(hack-local-variables)
(should (eq lexical-binding nil)))))
+(ert-deftest files-tests-safe-local-variable-directories ()
+ ;; safe-local-variable-directories should be risky,
+ ;; so use it as an arbitrary risky variable.
+ (let ((test-alist '((safe-local-variable-directories . "some_val")))
+ (fakedir default-directory)
+ (enable-local-eval t))
+ (with-temp-buffer
+ (setq safe-local-variable-directories (list fakedir))
+ (hack-local-variables-filter test-alist fakedir)
+ (should (equal file-local-variables-alist test-alist)))
+ (with-temp-buffer
+ (setq safe-local-variable-directories (list fakedir))
+ (setq noninteractive t)
+ (hack-local-variables-filter test-alist "wrong")
+ (should-not (equal file-local-variables-alist test-alist)))
+ (with-temp-buffer
+ (setq safe-local-variable-directories '())
+ (setq noninteractive t)
+ (hack-local-variables-filter test-alist fakedir)
+ (should-not (equal file-local-variables-alist test-alist)))))
+
(defvar files-test-bug-18141-file
(ert-resource-file "files-bug18141.el.gz")
"Test file for bug#18141.")
@@ -1201,30 +1222,30 @@ unquoted file names."
(let ((process-environment (cons "FOO=foo" process-environment))
(nospecial-foo (files-tests--new-name nospecial "$FOO")))
;; The "/:" prevents substitution.
- (equal (substitute-in-file-name nospecial-foo) nospecial-foo)))
+ (should (equal (substitute-in-file-name nospecial-foo) nospecial-foo))))
(files-tests--with-temp-non-special-and-file-name-handler (tmpfile nospecial)
(let ((process-environment (cons "FOO=foo" process-environment))
(nospecial-foo (files-tests--new-name nospecial "$FOO")))
;; The "/:" prevents substitution.
- (equal (substitute-in-file-name nospecial-foo) nospecial-foo))))
+ (should (equal (substitute-in-file-name nospecial-foo) nospecial-foo)))))
(ert-deftest files-tests-file-name-non-special-temporary-file-directory ()
(files-tests--with-temp-non-special (tmpdir nospecial-dir t)
(let ((default-directory nospecial-dir))
- (equal (temporary-file-directory) temporary-file-directory)))
+ (should (equal (temporary-file-directory) temporary-file-directory))))
(files-tests--with-temp-non-special-and-file-name-handler
(tmpdir nospecial-dir t)
(let ((default-directory nospecial-dir))
- (equal (temporary-file-directory) temporary-file-directory))))
+ (should (equal (temporary-file-directory) temporary-file-directory)))))
(ert-deftest files-tests-file-name-non-special-unhandled-file-name-directory ()
(files-tests--with-temp-non-special (tmpdir nospecial-dir t)
- (equal (unhandled-file-name-directory nospecial-dir)
- (file-name-as-directory tmpdir)))
+ (should (equal (unhandled-file-name-directory nospecial-dir)
+ (file-name-as-directory tmpdir))))
(files-tests--with-temp-non-special-and-file-name-handler
(tmpdir nospecial-dir t)
- (equal (unhandled-file-name-directory nospecial-dir)
- (file-name-as-directory tmpdir))))
+ (should-not (equal (unhandled-file-name-directory nospecial-dir)
+ (file-name-as-directory tmpdir)))))
(ert-deftest files-tests-file-name-non-special-vc-registered ()
(files-tests--with-temp-non-special (tmpfile nospecial)
@@ -1635,6 +1656,48 @@ The door of all subtleties!
(should (equal (file-name-base "foo") "foo"))
(should (equal (file-name-base "foo/bar") "bar")))
+(defvar sh-shell)
+
+(defun files-tests--check-shebang (shebang expected-mode &optional expected-dialect)
+ "Assert that mode for SHEBANG derives from EXPECTED-MODE.
+
+If EXPECTED-MODE is sh-base-mode, DIALECT says what `sh-shell' should be
+set to."
+ (ert-with-temp-file script-file
+ :text shebang
+ (find-file script-file)
+ (let ((actual-mode (if (derived-mode-p expected-mode)
+ expected-mode
+ major-mode)))
+ ;; Tuck all the information we need in the `should' form: input
+ ;; shebang, expected mode vs actual.
+ (should
+ (equal (list shebang actual-mode)
+ (list shebang expected-mode)))
+ (when (eq expected-mode 'sh-base-mode)
+ (should (eq sh-shell expected-dialect))))))
+
+(ert-deftest files-tests-auto-mode-interpreter ()
+ "Test that `set-auto-mode' deduces correct modes from shebangs."
+ ;; Straightforward interpreter invocation.
+ (files-tests--check-shebang "#!/bin/bash" 'sh-base-mode 'bash)
+ (files-tests--check-shebang "#!/usr/bin/make -f" 'makefile-mode)
+ ;; Invocation through env.
+ (files-tests--check-shebang "#!/usr/bin/env bash" 'sh-base-mode 'bash)
+ (files-tests--check-shebang "#!/usr/bin/env python" 'python-base-mode)
+ (files-tests--check-shebang "#!/usr/bin/env python3" 'python-base-mode)
+ ;; Invocation through env, with supplementary arguments.
+ (files-tests--check-shebang "#!/usr/bin/env --split-string=bash -eux" 'sh-base-mode 'bash)
+ (files-tests--check-shebang "#!/usr/bin/env --split-string=-iv --default-signal bash -eux" 'sh-base-mode 'bash)
+ (files-tests--check-shebang "#!/usr/bin/env -S awk -v FS=\"\\t\" -v OFS=\"\\t\" -f" 'awk-mode)
+ (files-tests--check-shebang "#!/usr/bin/env -S make -f" 'makefile-mode)
+ (files-tests--check-shebang "#!/usr/bin/env -S-vi bash -eux" 'sh-base-mode 'bash)
+ (files-tests--check-shebang "#!/usr/bin/env -ivS --default-signal=INT bash -eux" 'sh-base-mode 'bash)
+ (files-tests--check-shebang "#!/usr/bin/env -ivS --default-signal bash -eux" 'sh-base-mode 'bash)
+ (files-tests--check-shebang "#!/usr/bin/env -vS -uFOOBAR bash -eux" 'sh-base-mode 'bash)
+ ;; Invocation through env, with modified environment.
+ (files-tests--check-shebang "#!/usr/bin/env -S PYTHONPATH=/...:${PYTHONPATH} python" 'python-base-mode))
+
(ert-deftest files-test-dir-locals-auto-mode-alist ()
"Test an `auto-mode-alist' entry in `.dir-locals.el'"
(find-file (ert-resource-file "whatever.quux"))
@@ -1696,6 +1759,157 @@ let-bound to PRED and passing nil as second arg of
(set-buffer-modified-p nil)
(kill-buffer buf)))))))
+(defmacro files-tests--with-yes-or-no-p (reply &rest body)
+ "Execute BODY, providing replies to `yes-or-no-p' queries.
+REPLY should be a cons (PROMPT . VALUE), and during execution of
+BODY this macro provides VALUE as return value to all
+`yes-or-no-p' calls prompting for PROMPT and nil to all other
+`yes-or-no-p' calls. After execution of BODY, this macro ensures
+that exactly one `yes-or-no-p' call prompting for PROMPT has been
+executed during execution of BODY."
+ (declare (indent 1) (debug (sexp body)))
+ `(cl-letf*
+ ((reply ,reply)
+ (prompts nil)
+ ((symbol-function 'yes-or-no-p)
+ (lambda (prompt)
+ (let ((reply (cdr (assoc prompt (list reply)))))
+ (push (cons prompt reply) prompts)
+ reply))))
+ ,@body
+ (should (equal prompts (list reply)))))
+
+(ert-deftest files-tests-save-buffer-read-only-file ()
+ "Test writing to write-protected files with `save-buffer'.
+Ensure that the issues from bug#66546 are fixed."
+ (ert-with-temp-directory dir
+ (cl-flet (;; Define convenience functions.
+ (file-contents (file)
+ (if (file-exists-p file)
+ (condition-case err
+ (with-temp-buffer
+ (insert-file-contents-literally file)
+ (buffer-string))
+ (error err))
+ 'missing))
+ (signal-write-failed (&rest _)
+ (signal 'file-error "Write failed")))
+
+ (let* (;; Sanitize environment.
+ ;; The tests below test text for equality, so we need to
+ ;; disable any code- and EOL-conversions to avoid false
+ ;; positives and false negatives.
+ (coding-system-for-read 'no-conversion)
+ (coding-system-for-write 'no-conversion)
+ (auto-save-default nil)
+ (backup-enable-predicate nil)
+ (before-save-hook nil)
+ (write-contents-functions nil)
+ (write-file-functions nil)
+ (after-save-hook nil)
+
+ ;; Set the name of the game.
+ (base "read-only-test")
+ (file (expand-file-name base dir))
+ (backup (make-backup-file-name file))
+
+ (override-read-only-prompt
+ (format "File %s is write-protected; try to save anyway? "
+ base)))
+
+ ;; Ensure that set-file-modes renders our test file read-only,
+ ;; otherwise skip this test. Use `file-writable-p' to test
+ ;; for read-only-ness, because that's what function
+ ;; `save-buffer' uses as well.
+ (with-temp-file file (insert "foo\n"))
+ (skip-unless (file-writable-p file))
+ (set-file-modes file (logand (file-modes file)
+ (lognot #o0222)))
+ (skip-unless (not (file-writable-p file)))
+
+ (with-current-buffer (find-file-noselect file)
+ ;; Prepare for tests backing up the file.
+ (setq buffer-read-only nil)
+ (goto-char (point-min))
+ (insert "bar\n")
+
+ ;; Save to read-only file with backup, declining prompt.
+ (files-tests--with-yes-or-no-p
+ (cons override-read-only-prompt nil)
+ (should-error
+ (save-buffer)
+ ;; "Attempt to save to a file that you aren't allowed to write"
+ :type 'error))
+ (should-not buffer-backed-up)
+ (should (buffer-modified-p))
+ (should-not (file-writable-p file))
+ (should (equal (file-contents file) "foo\n"))
+ (should (equal (file-contents backup) 'missing))
+
+ ;; Save to read-only file with backup, accepting prompt,
+ ;; experiencing a write error.
+ (files-tests--with-yes-or-no-p
+ (cons override-read-only-prompt t)
+ (should-error
+ (cl-letf (((symbol-function 'write-region)
+ #'signal-write-failed))
+ (save-buffer))
+ ;; "Write failed"
+ :type 'file-error))
+ (should-not buffer-backed-up)
+ (should (buffer-modified-p))
+ (should-not (file-writable-p file))
+ (should (equal (file-contents file) "foo\n"))
+ (should (equal (file-contents backup) 'missing))
+
+ ;; Save to read-only file with backup, accepting prompt.
+ (files-tests--with-yes-or-no-p
+ (cons override-read-only-prompt t)
+ (save-buffer))
+ (should buffer-backed-up)
+ (should-not (buffer-modified-p))
+ (should-not (file-writable-p file))
+ (should-not (file-writable-p backup))
+ (should (equal (file-contents file) "bar\nfoo\n"))
+ (should (equal (file-contents backup) "foo\n"))
+
+ ;; Prepare for tests not backing up the file.
+ (setq buffer-backed-up nil)
+ (delete-file backup)
+ (goto-char (point-min))
+ (insert "baz\n")
+
+ ;; Save to read-only file without backup, accepting prompt,
+ ;; experiencing a write error. This tests that issue B of
+ ;; bug#66546 is fixed. The results of the "with backup" and
+ ;; "without backup" subtests are identical when a write
+ ;; error occurs, but the code paths to reach these results
+ ;; are not. In other words, this subtest is not redundant.
+ (files-tests--with-yes-or-no-p
+ (cons override-read-only-prompt t)
+ (should-error
+ (cl-letf (((symbol-function 'write-region)
+ #'signal-write-failed))
+ (save-buffer 0))
+ ;; "Write failed"
+ :type 'file-error))
+ (should-not buffer-backed-up)
+ (should (buffer-modified-p))
+ (should-not (file-writable-p file))
+ (should (equal (file-contents file) "bar\nfoo\n"))
+ (should (equal (file-contents backup) 'missing))
+
+ ;; Save to read-only file without backup, accepting prompt.
+ ;; This tests that issue A of bug#66546 is fixed.
+ (files-tests--with-yes-or-no-p
+ (cons override-read-only-prompt t)
+ (save-buffer 0))
+ (should-not buffer-backed-up)
+ (should-not (buffer-modified-p))
+ (should-not (file-writable-p file))
+ (should (equal (file-contents file) "baz\nbar\nfoo\n"))
+ (should (equal (file-contents backup) 'missing)))))))
+
(ert-deftest files-tests-save-some-buffers ()
"Test `save-some-buffers'.
Test the 3 cases for the second argument PRED, i.e., nil, t, or
@@ -1904,5 +2118,9 @@ Prompt users for any modified buffer with `buffer-offer-save' non-nil."
(should (documentation 'bar))
(should (documentation 'zot)))))
+(ert-deftest files-tests--expand-wildcards ()
+ (should (file-expand-wildcards
+ (concat (directory-file-name default-directory) "*/"))))
+
(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 9e6a46390a5..528467a5641 100644
--- a/test/lisp/files-x-tests.el
+++ b/test/lisp/files-x-tests.el
@@ -39,6 +39,7 @@
(defconst files-x-test--variables5
'((remote-lazy-var . nil)
(remote-null-device . "/dev/null")))
+(defvar remote-shell-file-name)
(defvar remote-null-device)
(defvar remote-lazy-var nil)
(put 'remote-shell-file-name 'safe-local-variable #'identity)
@@ -482,5 +483,123 @@ If it's not initialized yet, initialize it."
`(connection-local-profile-alist ',clpa now)
`(connection-local-criteria-alist ',clca now))))
+(ert-deftest files-x-test-connection-local-value ()
+ "Test getting connection-local values."
+
+ (let ((clpa connection-local-profile-alist)
+ (clca connection-local-criteria-alist))
+ (connection-local-set-profile-variables
+ 'remote-bash files-x-test--variables1)
+ (connection-local-set-profile-variables
+ 'remote-ksh files-x-test--variables2)
+ (connection-local-set-profile-variables
+ 'remote-nullfile files-x-test--variables3)
+
+ (connection-local-set-profiles
+ nil 'remote-ksh 'remote-nullfile)
+
+ (connection-local-set-profile-variables
+ 'remote-lazy files-x-test--variables5)
+ (connection-local-set-profiles
+ files-x-test--application 'remote-lazy 'remote-bash)
+
+ (with-temp-buffer
+ ;; We need a remote `default-directory'.
+ (let ((enable-connection-local-variables t)
+ (default-directory "/method:host:")
+ (remote-null-device "null"))
+ (should-not connection-local-variables-alist)
+ (should-not (local-variable-p 'remote-shell-file-name))
+ (should-not (local-variable-p 'remote-null-device))
+ (should-not (boundp 'remote-shell-file-name))
+ (should (string-equal (symbol-value 'remote-null-device) "null"))
+
+ ;; The proper variable values are set.
+ (should (connection-local-p remote-shell-file-name))
+ (should
+ (string-equal
+ (connection-local-value remote-shell-file-name) "/bin/ksh"))
+ (should (connection-local-p remote-null-device))
+ (should
+ (string-equal
+ (connection-local-value remote-null-device) "/dev/null"))
+ (should-not (connection-local-p remote-lazy-var))
+
+ ;; Run with a different application.
+ (should
+ (connection-local-p
+ remote-shell-file-name (cadr files-x-test--application)))
+ (should
+ (string-equal
+ (connection-local-value
+ remote-shell-file-name (cadr files-x-test--application))
+ "/bin/bash"))
+ (should
+ (connection-local-p
+ remote-null-device (cadr files-x-test--application)))
+ (should
+ (string-equal
+ (connection-local-value
+ remote-null-device (cadr files-x-test--application))
+ "/dev/null"))
+ (should
+ (connection-local-p
+ remote-lazy-var (cadr files-x-test--application)))
+
+ ;; The previous bindings haven't changed.
+ (should-not connection-local-variables-alist)
+ (should-not (local-variable-p 'remote-shell-file-name))
+ (should-not (local-variable-p 'remote-null-device))
+ (should-not (boundp 'remote-shell-file-name))
+ (should (string-equal (symbol-value 'remote-null-device) "null"))))
+
+ ;; `connection-local-value' and `connection-local-p' care about a
+ ;; local default directory.
+ (with-temp-buffer
+ (let ((enable-connection-local-variables t)
+ (default-directory temporary-file-directory)
+ (remote-null-device "null"))
+ (should-not connection-local-variables-alist)
+ (should-not (local-variable-p 'remote-shell-file-name))
+ (should-not (local-variable-p 'remote-null-device))
+ (should-not (boundp 'remote-shell-file-name))
+ (should (string-equal (symbol-value 'remote-null-device) "null"))
+
+ ;; The recent variable values are used.
+ (should-not (connection-local-p remote-shell-file-name))
+ ;; `remote-shell-file-name' is not defined, so we get an error.
+ (should-error
+ (connection-local-value remote-shell-file-name) :type 'void-variable)
+ (should-not (connection-local-p remote-null-device))
+ (should
+ (string-equal
+ (connection-local-value remote-null-device) remote-null-device))
+ (should-not (connection-local-p remote-lazy-var))
+
+ ;; Run with a different application.
+ (should-not
+ (connection-local-p
+ remote-shell-file-name (cadr files-x-test--application)))
+ ;; `remote-shell-file-name' is not defined, so we get an error.
+ (should-error
+ (connection-local-value
+ remote-shell-file-name (cadr files-x-test--application))
+ :type 'void-variable)
+ (should-not
+ (connection-local-p
+ remote-null-device (cadr files-x-test--application)))
+ (should
+ (string-equal
+ (connection-local-value
+ remote-null-device (cadr files-x-test--application))
+ remote-null-device))
+ (should-not
+ (connection-local-p remote-lazy-var (cadr files-x-test--application)))))
+
+ ;; Cleanup.
+ (custom-set-variables
+ `(connection-local-profile-alist ',clpa now)
+ `(connection-local-criteria-alist ',clca now))))
+
(provide 'files-x-tests)
;;; files-x-tests.el ends here
diff --git a/test/lisp/find-cmd-tests.el b/test/lisp/find-cmd-tests.el
index 498992e367a..d1c57cc4cfa 100644
--- a/test/lisp/find-cmd-tests.el
+++ b/test/lisp/find-cmd-tests.el
@@ -25,7 +25,7 @@
(ert-deftest find-cmd-test-find-cmd ()
(should
(string-match
- (rx "find " (+ any)
+ (rx "find " (+ nonl)
" \\( \\( -name .svn -or -name .git -or -name .CVS \\)"
" -prune -or -true \\)"
" \\( \\( \\(" " -name \\*.pl -or -name \\*.pm -or -name \\*.t \\)"
diff --git a/test/lisp/gnus/mml-sec-tests.el b/test/lisp/gnus/mml-sec-tests.el
index 7abd1bd65a3..2a18a13ba38 100644
--- a/test/lisp/gnus/mml-sec-tests.el
+++ b/test/lisp/gnus/mml-sec-tests.el
@@ -66,34 +66,29 @@ This fixture temporarily unsets GPG_AGENT_INFO to enable passphrase tests,
which will neither work with gpgsm nor GnuPG 2.1 any longer, I guess.
Actually, I'm not sure why people would want to cache passwords in Emacs
instead of gpg-agent."
- (unwind-protect
- (let ((agent-info (getenv "GPG_AGENT_INFO"))
- (gpghome (getenv "GNUPGHOME")))
- (condition-case error
- (let ((epg-gpg-home-directory (ert-resource-directory))
- (mml-smime-use 'epg)
- ;; Create debug output in empty epg-debug-buffer.
- (epg-debug t)
- (epg-debug-buffer (get-buffer-create " *epg-test*"))
- (mml-secure-fail-when-key-problem (not interactive)))
- (with-current-buffer epg-debug-buffer
- (erase-buffer))
- ;; Unset GPG_AGENT_INFO to enable passphrase caching inside Emacs.
- ;; Just for testing. Jens does not recommend this for daily use.
- (setenv "GPG_AGENT_INFO")
- ;; Set GNUPGHOME as gpg-agent started by gpgsm does
- ;; not look in the proper places otherwise, see:
- ;; https://bugs.gnupg.org/gnupg/issue2126
- (setenv "GNUPGHOME" epg-gpg-home-directory)
- (unwind-protect
- (funcall body)
- (mml-sec-test--kill-gpg-agent)))
- (error
- (setenv "GPG_AGENT_INFO" agent-info)
- (setenv "GNUPGHOME" gpghome)
- (signal (car error) (cdr error))))
- (setenv "GPG_AGENT_INFO" agent-info)
- (setenv "GNUPGHOME" gpghome))))
+ (let ((agent-info (getenv "GPG_AGENT_INFO"))
+ (gpghome (getenv "GNUPGHOME")))
+ (unwind-protect
+ (let ((epg-gpg-home-directory (ert-resource-directory))
+ (mml-smime-use 'epg)
+ ;; Create debug output in empty epg-debug-buffer.
+ (epg-debug t)
+ (epg-debug-buffer (get-buffer-create " *epg-test*"))
+ (mml-secure-fail-when-key-problem (not interactive)))
+ (with-current-buffer epg-debug-buffer
+ (erase-buffer))
+ ;; Unset GPG_AGENT_INFO to enable passphrase caching inside Emacs.
+ ;; Just for testing. Jens does not recommend this for daily use.
+ (setenv "GPG_AGENT_INFO")
+ ;; Set GNUPGHOME as gpg-agent started by gpgsm does
+ ;; not look in the proper places otherwise, see:
+ ;; https://bugs.gnupg.org/gnupg/issue2126
+ (setenv "GNUPGHOME" epg-gpg-home-directory)
+ (unwind-protect
+ (funcall body)
+ (mml-sec-test--kill-gpg-agent)))
+ (setenv "GPG_AGENT_INFO" agent-info)
+ (setenv "GNUPGHOME" gpghome))))
(defun mml-secure-test-message-setup (method to from &optional text bcc)
"Setup a buffer with MML METHOD, TO, and FROM headers.
diff --git a/test/lisp/help-fns-tests.el b/test/lisp/help-fns-tests.el
index c3e8ca49723..1beeb77640c 100644
--- a/test/lisp/help-fns-tests.el
+++ b/test/lisp/help-fns-tests.el
@@ -48,12 +48,12 @@ Return first line of the output of (describe-function-1 FUNC)."
(should (string-match regexp result))))
(ert-deftest help-fns-test-built-in ()
- (let ((regexp "a built-in function in .C source code")
+ (let ((regexp "a primitive-function in .C source code")
(result (help-fns-tests--describe-function 'mapcar)))
(should (string-match regexp result))))
(ert-deftest help-fns-test-interactive-built-in ()
- (let ((regexp "an interactive built-in function in .C source code")
+ (let ((regexp "an interactive primitive-function in .C source code")
(result (help-fns-tests--describe-function 're-search-forward)))
(should (string-match regexp result))))
@@ -64,13 +64,13 @@ Return first line of the output of (describe-function-1 FUNC)."
(ert-deftest help-fns-test-lisp-defun ()
(let ((regexp (if (featurep 'native-compile)
- "a native-compiled Lisp function in .+subr\\.el"
- "a byte-compiled Lisp function in .+subr\\.el"))
+ "a subr-native-elisp in .+subr\\.el"
+ "a compiled-function in .+subr\\.el"))
(result (help-fns-tests--describe-function 'last)))
(should (string-match regexp result))))
(ert-deftest help-fns-test-lisp-defsubst ()
- (let ((regexp "a byte-compiled Lisp function in .+subr\\.el")
+ (let ((regexp "a compiled-function in .+subr\\.el")
(result (help-fns-tests--describe-function 'posn-window)))
(should (string-match regexp result))))
@@ -132,6 +132,12 @@ Return first line of the output of (describe-function-1 FUNC)."
;;; Tests for describe-keymap
+
+(defvar-keymap help-fns-test-map
+ "a" 'test-cmd-a
+ "b" 'test-cmd-b
+ "c" 'test-cmd-c)
+
(ert-deftest help-fns-test-find-keymap-name ()
(should (equal (help-fns-find-keymap-name lisp-mode-map) 'lisp-mode-map))
;; Follow aliasing.
@@ -142,27 +148,32 @@ Return first line of the output of (describe-function-1 FUNC)."
(makunbound 'foo-test-map)))
(ert-deftest help-fns-test-describe-keymap/symbol ()
- (describe-keymap 'minibuffer-local-must-match-map)
+ (describe-keymap 'help-fns-test-map)
(with-current-buffer "*Help*"
- (should (looking-at "^minibuffer-local-must-match-map is"))))
+ (should (looking-at "^help-fns-test-map is"))
+ (should (re-search-forward (rx word-start "a" word-end
+ (+ blank)
+ word-start "test-cmd-a" word-end)
+ nil t))))
(ert-deftest help-fns-test-describe-keymap/value ()
- (describe-keymap minibuffer-local-must-match-map)
+ (describe-keymap help-fns-test-map)
(with-current-buffer "*Help*"
(should (looking-at "\nKey"))))
(ert-deftest help-fns-test-describe-keymap/not-keymap ()
(should-error (describe-keymap nil))
- (should-error (describe-keymap emacs-version)))
+ (should-error (describe-keymap emacs-version))
+ (should-error (describe-keymap 'some-undefined-variable-foobar)))
(ert-deftest help-fns-test-describe-keymap/let-bound ()
- (let ((foobar minibuffer-local-must-match-map))
+ (let ((foobar help-fns-test-map))
(describe-keymap foobar)
(with-current-buffer "*Help*"
(should (looking-at "\nKey")))))
(ert-deftest help-fns-test-describe-keymap/dynamically-bound-no-file ()
- (setq help-fns-test--describe-keymap-foo minibuffer-local-must-match-map)
+ (setq help-fns-test--describe-keymap-foo help-fns-test-map)
(describe-keymap 'help-fns-test--describe-keymap-foo)
(with-current-buffer "*Help*"
(should (looking-at "^help-fns-test--describe-keymap-foo is"))))
@@ -181,10 +192,6 @@ Return first line of the output of (describe-function-1 FUNC)."
(ert-deftest help-fns--analyze-function-recursive ()
(defalias 'help-fns--a 'help-fns--b)
(should (equal (help-fns--analyze-function 'help-fns--a)
- '(help-fns--a help-fns--b t help-fns--b)))
- ;; Make a loop and see that it doesn't infloop.
- (defalias 'help-fns--b 'help-fns--a)
- (should (equal (help-fns--analyze-function 'help-fns--a)
'(help-fns--a help-fns--b t help-fns--b))))
;;; help-fns-tests.el ends here
diff --git a/test/lisp/help-tests.el b/test/lisp/help-tests.el
index 7df21393013..f27fa979ef0 100644
--- a/test/lisp/help-tests.el
+++ b/test/lisp/help-tests.el
@@ -378,7 +378,7 @@ Key Binding
(foo menu-item "Foo" foo
:enable mark-active
:help "Help text"))))))
- (describe-map-tree map nil nil nil nil t nil nil nil)
+ (help--describe-map-tree map nil nil nil nil t nil nil nil)
(should (string-match "
Key Binding
-+
@@ -393,7 +393,7 @@ C-a foo\n"
(foo menu-item "Foo" foo
:enable mark-active
:help "Help text"))))))
- (describe-map-tree map nil nil nil nil nil nil nil nil)
+ (help--describe-map-tree map nil nil nil nil nil nil nil nil)
(should (string-match "
Key Binding
-+
@@ -408,7 +408,7 @@ C-a foo
(map '(keymap . ((1 . foo)
(2 . bar))))
(shadow-maps '((keymap . ((1 . baz))))))
- (describe-map-tree map t shadow-maps nil nil t nil nil t)
+ (help--describe-map-tree map t shadow-maps nil nil t nil nil t)
(should (string-match "
Key Binding
-+
@@ -423,7 +423,7 @@ C-b bar\n"
(map '(keymap . ((1 . foo)
(2 . bar))))
(shadow-maps '((keymap . ((1 . baz))))))
- (describe-map-tree map t shadow-maps nil nil t nil nil nil)
+ (help--describe-map-tree map t shadow-maps nil nil t nil nil nil)
(should (string-match "
Key Binding
-+
@@ -435,7 +435,7 @@ C-b bar\n"
(let ((standard-output (current-buffer))
(map '(keymap . ((1 . foo)
(2 . undefined)))))
- (describe-map-tree map t nil nil nil nil nil nil nil)
+ (help--describe-map-tree map t nil nil nil nil nil nil nil)
(should (string-match "
Key Binding
-+
@@ -447,7 +447,7 @@ C-a foo\n"
(let ((standard-output (current-buffer))
(map '(keymap . ((1 . foo)
(2 . undefined)))))
- (describe-map-tree map nil nil nil nil nil nil nil nil)
+ (help--describe-map-tree map nil nil nil nil nil nil nil nil)
(should (string-match "
Key Binding
-+
diff --git a/test/lisp/hl-line-tests.el b/test/lisp/hl-line-tests.el
index b8df3dc5742..1b0b0ebe015 100644
--- a/test/lisp/hl-line-tests.el
+++ b/test/lisp/hl-line-tests.el
@@ -104,10 +104,10 @@
(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)))))
+ (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)
diff --git a/test/lisp/ibuffer-tests.el b/test/lisp/ibuffer-tests.el
index 7bc491a343a..ea9e663b1ad 100644
--- a/test/lisp/ibuffer-tests.el
+++ b/test/lisp/ibuffer-tests.el
@@ -34,7 +34,7 @@
(ert-deftest ibuffer-0autoload () ; sort first
"Tests to see whether ibuffer has been autoloaded"
- (skip-unless (not (featurep 'ibuf-ext)))
+ (skip-when (featurep 'ibuf-ext))
(should
(fboundp 'ibuffer-mark-unsaved-buffers))
(should
diff --git a/test/lisp/image-tests.el b/test/lisp/image-tests.el
index 80142d6d6de..6a5f03e38a0 100644
--- a/test/lisp/image-tests.el
+++ b/test/lisp/image-tests.el
@@ -153,4 +153,148 @@
(image-rotate -154.5)
(should (equal image '(image :rotation 91.0)))))
+;;;; Transforming maps
+
+(ert-deftest image-create-image-with-map ()
+ "Test that `create-image' correctly adds :map and/or :original-map."
+ (skip-unless (display-images-p))
+ (let ((data "foo")
+ (map '(((circle (1 . 1) . 1) a)))
+ (original-map '(((circle (2 . 2) . 2) a)))
+ (original-map-other '(((circle (3 . 3) . 3) a))))
+ ;; Generate :original-map from :map.
+ (let* ((image (create-image data 'svg t :map map :scale 0.5))
+ (got-original-map (image-property image :original-map)))
+ (should (equal got-original-map original-map)))
+ ;; Generate :map from :original-map.
+ (let* ((image (create-image
+ data 'svg t :original-map original-map :scale 0.5))
+ (got-map (image-property image :map)))
+ (should (equal got-map map)))
+ ;; Use :original-map if both it and :map are specified.
+ (let* ((image (create-image
+ data 'svg t :map map
+ :original-map original-map-other :scale 0.5))
+ (got-original-map (image-property image :original-map)))
+ (should (equal got-original-map original-map-other)))))
+
+(defun image-tests--map-equal (a b &optional tolerance)
+ "Return t if maps A and B have the same coordinates within TOLERANCE.
+Since image sizes calculations vary on different machines, this function
+allows for each image map coordinate in A to be within TOLERANCE to the
+corresponding coordinate in B. When nil, TOLERANCE defaults to 5."
+ (unless tolerance (setq tolerance 5))
+ (catch 'different
+ (cl-labels ((check-tolerance
+ (coord-a coord-b)
+ (unless (>= tolerance (abs (- coord-a coord-b)))
+ (throw 'different nil))))
+ (dotimes (i (length a))
+ (pcase-let ((`((,type-a . ,coords-a) ,_id ,_plist) (nth i a))
+ (`((,type-b . ,coords-b) ,_id ,_plist) (nth i b)))
+ (unless (eq type-a type-b)
+ (throw 'different nil))
+ (pcase-exhaustive type-a
+ ('rect
+ (check-tolerance (caar coords-a) (caar coords-b))
+ (check-tolerance (cdar coords-a) (cdar coords-b))
+ (check-tolerance (cadr coords-a) (cadr coords-b))
+ (check-tolerance (cddr coords-a) (cddr coords-b)))
+ ('circle
+ (check-tolerance (caar coords-a) (caar coords-b))
+ (check-tolerance (cdar coords-a) (cdar coords-b))
+ (check-tolerance (cdar coords-a) (cdar coords-b)))
+ ('poly
+ (dotimes (i (length coords-a))
+ (check-tolerance (aref coords-a i) (aref coords-b i))))))))
+ t))
+
+(ert-deftest image--compute-map-and-original-map ()
+ "Test `image--compute-map' and `image--compute-original-map'."
+ (skip-unless (display-images-p))
+ (let* ((svg-string "<?xml version=\"1.0\" encoding=\"UTF-8\" standalone=\"no\"?><svg width=\"125pt\" height=\"116pt\" viewBox=\"0.00 0.00 125.00 116.00\" xmlns=\"http://www.w3.org/2000/svg\" xmlns:xlink=\"http://www.w3.org/1999/xlink\"><g transform=\"scale(1 1) rotate(0) translate(4 112)\"><polygon fill=\"white\" stroke=\"transparent\" points=\"-4,4 -4,-112 121,-112 121,4 -4,4\"/><a xlink:href=\"a\"><ellipse fill=\"none\" stroke=\"black\" cx=\"27\" cy=\"-90\" rx=\"18\" ry=\"18\"/><text text-anchor=\"middle\" x=\"27\" y=\"-86.3\" fill=\"#000000\">A</text></a><a xlink:href=\"b\"><polygon fill=\"none\" stroke=\"black\" points=\"54,-36 0,-36 0,0 54,0 54,-36\"/><text text-anchor=\"middle\" x=\"27\" y=\"-14.3\" fill=\"#000000\">B</text></a><a xlink:href=\"c\"><ellipse fill=\"none\" stroke=\"black\" cx=\"90\" cy=\"-90\" rx=\"27\" ry=\"18\"/><text text-anchor=\"middle\" x=\"90\" y=\"-86.3\" fill=\"#000000\">C</text></a></g></svg>")
+ (original-map
+ '(((circle (41 . 29) . 24) "a" (help-echo "A"))
+ ((rect (5 . 101) 77 . 149) "b" (help-echo "B"))
+ ((poly . [161 29 160 22 154 15 146 10 136 7 125 5 114 7 104 10 96 15 91 22 89 29 91 37 96 43 104 49 114 52 125 53 136 52 146 49 154 43 160 37]) "c" (help-echo "C"))))
+ (scaled-map
+ '(((circle (82 . 58) . 48) "a" (help-echo "A"))
+ ((rect (10 . 202) 154 . 298) "b" (help-echo "B"))
+ ((poly . [322 58 320 44 308 30 292 20 272 14 250 10 228 14 208 20 192 30 182 44 178 58 182 74 192 86 208 98 228 104 250 106 272 104 292 98 308 86 320 74]) "c" (help-echo "C"))))
+ (flipped-map
+ '(((circle (125 . 29) . 24) "a" (help-echo "A"))
+ ((rect (89 . 101) 161 . 149) "b" (help-echo "B"))
+ ((poly . [5 29 6 22 12 15 20 10 30 7 41 5 52 7 62 10 70 15 75 22 77 29 75 37 70 43 62 49 52 52 41 53 30 52 20 49 12 43 6 37]) "c" (help-echo "C"))))
+ (rotated-map
+ '(((circle (126 . 41) . 24) "a" (help-echo "A"))
+ ((rect (6 . 5) 54 . 77) "b" (help-echo "B"))
+ ((poly . [126 161 133 160 140 154 145 146 148 136 150 125 148 114 145 104 140 96 133 91 126 89 118 91 112 96 106 104 103 114 102 125 103 136 106 146 112 154 118 160]) "c" (help-echo "C"))))
+ (scaled-rotated-flipped-map
+ '(((circle (58 . 82) . 48) "a" (help-echo "A"))
+ ((rect (202 . 10) 298 . 154) "b" (help-echo "B"))
+ ((poly . [58 322 44 320 30 308 20 292 14 272 10 250 14 228 20 208 30 192 44 182 58 178 74 182 86 192 98 208 104 228 106 250 104 272 98 292 86 308 74 320]) "c" (help-echo "C"))))
+ (image (create-image svg-string 'svg t :map scaled-rotated-flipped-map
+ :scale 2 :rotation 90 :flip t)))
+ ;; Test that `image--compute-original-map' correctly generates
+ ;; original-map when creating an already transformed image.
+ (should (image-tests--map-equal (image-property image :original-map)
+ original-map))
+ (setf (image-property image :flip) nil)
+ (setf (image-property image :rotation) 0)
+ (setf (image-property image :scale) 2)
+ (should (image-tests--map-equal (image--compute-map image)
+ scaled-map))
+ (setf (image-property image :scale) 1)
+ (setf (image-property image :rotation) 90)
+ (should (image-tests--map-equal (image--compute-map image)
+ rotated-map))
+ (setf (image-property image :rotation) 0)
+ (setf (image-property image :flip) t)
+ (should (image-tests--map-equal (image--compute-map image)
+ flipped-map))
+ (setf (image-property image :scale) 2)
+ (setf (image-property image :rotation) 90)
+ (should (image-tests--map-equal (image--compute-map image)
+ scaled-rotated-flipped-map))
+
+ ;; Uncomment to test manually by interactively transforming the
+ ;; image and checking the map boundaries by hovering them.
+
+ ;; (with-current-buffer (get-buffer-create "*test image map*")
+ ;; (erase-buffer)
+ ;; (insert-image image)
+ ;; (goto-char (point-min))
+ ;; (pop-to-buffer (current-buffer)))
+ ))
+
+(ert-deftest image-transform-map ()
+ "Test functions related to transforming image maps."
+ (let ((map '(((circle (4 . 3) . 2) "circle")
+ ((rect (3 . 6) 8 . 8) "rect")
+ ((poly . [6 11 7 13 2 14]) "poly")))
+ (width 10)
+ (height 15))
+ (should (equal (image--scale-map (copy-tree map t) 2)
+ '(((circle (8 . 6) . 4) "circle")
+ ((rect (6 . 12) 16 . 16) "rect")
+ ((poly . [12 22 14 26 4 28]) "poly"))))
+ (should (equal (image--rotate-map (copy-tree map t) 90 `(,width . ,height))
+ '(((circle (12 . 4) . 2) "circle")
+ ((rect (7 . 3) 9 . 8) "rect")
+ ((poly . [4 6 2 7 1 2]) "poly"))))
+ (should (equal (image--flip-map (copy-tree map t) t `(,width . ,height))
+ '(((circle (6 . 3) . 2) "circle")
+ ((rect (2 . 6) 7 . 8) "rect")
+ ((poly . [4 11 3 13 8 14]) "poly"))))
+ (let ((copy (copy-tree map t)))
+ (image--scale-map copy 2)
+ ;; Scale size because the map has been scaled.
+ (image--rotate-map copy 90 `(,(* 2 width) . ,(* 2 height)))
+ ;; Swap width and height because the map has been flipped.
+ (image--flip-map copy t `(,(* 2 height) . ,(* 2 width)))
+ (should (equal copy
+ '(((circle (6 . 8) . 4) "circle")
+ ((rect (12 . 6) 16 . 16) "rect")
+ ((poly . [22 12 26 14 28 4]) "poly")))))))
+
;;; image-tests.el ends here
diff --git a/test/lisp/image/image-dired-util-tests.el b/test/lisp/image/image-dired-util-tests.el
index 38aef7f39a5..5d3d0a512e6 100644
--- a/test/lisp/image/image-dired-util-tests.el
+++ b/test/lisp/image/image-dired-util-tests.el
@@ -47,10 +47,11 @@
(should (equal
(file-name-directory (image-dired-thumb-name "foo.jpg"))
(file-name-directory (image-dired-thumb-name "/tmp/foo.jpg"))))
- (should (equal (file-name-nondirectory
- ;; The checksum is based on the file name.
- (image-dired-thumb-name "/some/path/foo.jpg"))
- "dc4e6f7068157023e7f2e8362d15bdd2e3ca89e4.jpg"))
+ (should
+ (let* ((test-fn "/some/path/foo.jpg")
+ (thumb-fn (image-dired-thumb-name test-fn)))
+ (equal (file-name-nondirectory thumb-fn)
+ (concat (sha1 (expand-file-name test-fn)) ".jpg"))))
(should (equal (file-name-extension
(image-dired-thumb-name "foo.gif"))
"jpg")))))
@@ -62,8 +63,12 @@
(should (equal
(file-name-nondirectory (image-dired-thumb-name "foo.jpg"))
(file-name-nondirectory (image-dired-thumb-name "/tmp/foo.jpg"))))
- (should (equal (file-name-split (image-dired-thumb-name "/tmp/foo.jpg"))
- '("" "tmp" ".image-dired" "foo.jpg.thumb.jpg")))
+ ;; The cdr below avoids the system dependency in the car of the
+ ;; list returned by 'file-name-split': it's "" on Posix systems,
+ ;; but the drive letter on MS-Windows.
+ (should (equal (cdr (file-name-split
+ (image-dired-thumb-name "/tmp/foo.jpg")))
+ '("tmp" ".image-dired" "foo.jpg.thumb.jpg")))
(should (equal (file-name-nondirectory
(image-dired-thumb-name "foo.jpg"))
"foo.jpg.thumb.jpg"))))
diff --git a/test/lisp/info-tests.el b/test/lisp/info-tests.el
index ebe718167bf..8020a7419cf 100644
--- a/test/lisp/info-tests.el
+++ b/test/lisp/info-tests.el
@@ -28,12 +28,20 @@
(require 'ert-x)
(ert-deftest test-info-urls ()
+ (should (equal (Info-url-for-node "(tramp)Top")
+ "https://www.gnu.org/software/emacs/manual/html_node/tramp/"))
(should (equal (Info-url-for-node "(emacs)Minibuffer")
"https://www.gnu.org/software/emacs/manual/html_node/emacs/Minibuffer.html"))
(should (equal (Info-url-for-node "(emacs)Minibuffer File")
"https://www.gnu.org/software/emacs/manual/html_node/emacs/Minibuffer-File.html"))
(should (equal (Info-url-for-node "(elisp)Backups and Auto-Saving")
"https://www.gnu.org/software/emacs/manual/html_node/elisp/Backups-and-Auto_002dSaving.html"))
- (should-error (Info-url-for-node "(gnus)Minibuffer File")))
+ (should (equal (Info-url-for-node "(eintr)car & cdr")
+ "https://www.gnu.org/software/emacs/manual/html_node/eintr/car-_0026-cdr.html"))
+ (should (equal (Info-url-for-node "(emacs-mime)\tIndex")
+ "https://www.gnu.org/software/emacs/manual/html_node/emacs-mime/Index.html"))
+ (should (equal (Info-url-for-node "(gnus) Don't Panic")
+ "https://www.gnu.org/software/emacs/manual/html_node/gnus/Don_0027t-Panic.html"))
+ (should-error (Info-url-for-node "(nonexistent)Example")))
;;; info-tests.el ends here
diff --git a/test/lisp/international/mule-tests.el b/test/lisp/international/mule-tests.el
index 5c742451a57..9a80ced55ae 100644
--- a/test/lisp/international/mule-tests.el
+++ b/test/lisp/international/mule-tests.el
@@ -96,10 +96,10 @@
;;; Testing `sgml-html-meta-auto-coding-function'.
-(defconst sgml-html-meta-pre "<!doctype html><html><head>"
+(defvar sgml-html-meta-pre "<!doctype html><html><head>"
"The beginning of a minimal HTML document.")
-(defconst sgml-html-meta-post "</head></html>"
+(defvar sgml-html-meta-post "</head></html>"
"The end of a minimal HTML document.")
(defun sgml-html-meta-run (coding-system)
diff --git a/test/lisp/international/ucs-normalize-tests.el b/test/lisp/international/ucs-normalize-tests.el
index 9cffa4e1a9a..7b17ee56fb9 100644
--- a/test/lisp/international/ucs-normalize-tests.el
+++ b/test/lisp/international/ucs-normalize-tests.el
@@ -219,8 +219,8 @@ Must be called with `ucs-normalize-tests--norm-buf' as current buffer."
(ert-deftest ucs-normalize-part1 ()
:tags '(:expensive-test)
- (skip-unless (not (or (getenv "EMACS_HYDRA_CI")
- (getenv "EMACS_EMBA_CI")))) ; SLOW ~ 1800s
+ (skip-when (or (getenv "EMACS_HYDRA_CI")
+ (getenv "EMACS_EMBA_CI"))) ; SLOW ~ 1800s
;; This takes a long time, so make sure we're compiled.
(dolist (fun '(ucs-normalize-tests--part1-rule2
ucs-normalize-tests--rule1-failing-for-partX
diff --git a/test/lisp/isearch-tests.el b/test/lisp/isearch-tests.el
index e787287c958..b5b1b20e932 100644
--- a/test/lisp/isearch-tests.el
+++ b/test/lisp/isearch-tests.el
@@ -39,6 +39,157 @@
(isearch-done))
+;; Search invisible.
+
+(declare-function outline-hide-sublevels "outline")
+
+(ert-deftest isearch--test-invisible ()
+ (require 'outline)
+ (with-temp-buffer
+ (set-window-buffer nil (current-buffer))
+ (insert "\n1\n"
+ (propertize "2" 'invisible t)
+ (propertize "3" 'inhibit-isearch t)
+ "\n* h\n4\n\n")
+ (outline-mode)
+ (outline-hide-sublevels 1)
+ (goto-char (point-min))
+
+ (let ((isearch-lazy-count nil)
+ (search-invisible t)
+ (inhibit-message t))
+
+ (isearch-forward-regexp nil 1)
+ (isearch-process-search-string "[0-9]" "[0-9]")
+ (should (eq (point) 3))
+
+ (isearch-lazy-highlight-start)
+ (should (equal (seq-uniq (mapcar #'overlay-start isearch-lazy-highlight-overlays))
+ '(2)))
+
+ (isearch-repeat-forward)
+ (should (eq (point) 5))
+ (should (get-char-property 4 'invisible))
+ (isearch-repeat-forward)
+ (should (eq (point) 12))
+ (should (get-char-property 11 'invisible))
+
+ (goto-char isearch-opoint)
+ (isearch-done t)
+
+ (isearch-forward-regexp nil 1)
+ (setq isearch-invisible nil) ;; isearch-toggle-invisible
+ (isearch-process-search-string "[0-9]" "[0-9]")
+
+ (isearch-lazy-highlight-start)
+ (should (equal (seq-uniq (mapcar #'overlay-start isearch-lazy-highlight-overlays))
+ '(2)))
+
+ (goto-char isearch-opoint)
+ (isearch-done t)
+
+ (isearch-forward-regexp nil 1)
+ (setq isearch-invisible 'open) ;; isearch-toggle-invisible
+ (isearch-process-search-string "[0-9]" "[0-9]")
+ (should (eq (point) 3))
+
+ (isearch-lazy-highlight-start)
+ (should (equal (seq-uniq (mapcar #'overlay-start isearch-lazy-highlight-overlays))
+ '(2 11)))
+
+ (let ((isearch-hide-immediately t))
+ (isearch-repeat-forward)
+ (should (eq (point) 12))
+ (should-not (get-char-property 11 'invisible))
+ (isearch-delete-char)
+ (should (get-char-property 11 'invisible)))
+
+ (let ((isearch-hide-immediately nil))
+ (isearch-repeat-forward)
+ (should (eq (point) 12))
+ (should-not (get-char-property 11 'invisible))
+ (isearch-delete-char)
+ (should-not (get-char-property 11 'invisible)))
+
+ (goto-char isearch-opoint)
+ (isearch-done t)
+ (isearch-clean-overlays)
+ (should (get-char-property 11 'invisible)))
+
+ (let ((isearch-lazy-count t)
+ (search-invisible t)
+ (inhibit-message t))
+
+ (isearch-forward-regexp nil 1)
+ (isearch-process-search-string "[0-9]" "[0-9]")
+ (should (eq (point) 3))
+
+ (setq isearch-lazy-count-invisible nil isearch-lazy-count-total nil)
+ (isearch-lazy-highlight-start)
+ (isearch-lazy-highlight-buffer-update)
+ (should (eq isearch-lazy-count-invisible nil))
+ (should (eq isearch-lazy-count-total 3))
+ (should (equal (seq-uniq (mapcar #'overlay-start isearch-lazy-highlight-overlays))
+ '(2)))
+
+ (isearch-repeat-forward)
+ (should (eq (point) 5))
+ (should (get-char-property 4 'invisible))
+ (isearch-repeat-forward)
+ (should (eq (point) 12))
+ (should (get-char-property 11 'invisible))
+
+ (goto-char isearch-opoint)
+ (isearch-done t)
+
+ (isearch-forward-regexp nil 1)
+ (setq isearch-invisible nil) ;; isearch-toggle-invisible
+ (isearch-process-search-string "[0-9]" "[0-9]")
+
+ (setq isearch-lazy-count-invisible nil isearch-lazy-count-total nil)
+ (isearch-lazy-highlight-start)
+ (isearch-lazy-highlight-buffer-update)
+ (should (eq isearch-lazy-count-invisible 2))
+ (should (eq isearch-lazy-count-total 1))
+ (should (equal (seq-uniq (mapcar #'overlay-start isearch-lazy-highlight-overlays))
+ '(2)))
+
+ (goto-char isearch-opoint)
+ (isearch-done t)
+
+ (isearch-forward-regexp nil 1)
+ (setq isearch-invisible 'open) ;; isearch-toggle-invisible
+ (isearch-process-search-string "[0-9]" "[0-9]")
+ (should (eq (point) 3))
+
+ (setq isearch-lazy-count-invisible nil isearch-lazy-count-total nil)
+ (isearch-lazy-highlight-start)
+ (isearch-lazy-highlight-buffer-update)
+ (should (eq isearch-lazy-count-invisible 1))
+ (should (eq isearch-lazy-count-total 2))
+ (should (equal (seq-uniq (mapcar #'overlay-start isearch-lazy-highlight-overlays))
+ '(2 11)))
+
+ (let ((isearch-hide-immediately t))
+ (isearch-repeat-forward)
+ (should (eq (point) 12))
+ (should-not (get-char-property 11 'invisible))
+ (isearch-delete-char)
+ (should (get-char-property 11 'invisible)))
+
+ (let ((isearch-hide-immediately nil))
+ (isearch-repeat-forward)
+ (should (eq (point) 12))
+ (should-not (get-char-property 11 'invisible))
+ (isearch-delete-char)
+ (should-not (get-char-property 11 'invisible)))
+
+ (goto-char isearch-opoint)
+ (isearch-done t)
+ (isearch-clean-overlays)
+ (should (get-char-property 11 'invisible)))))
+
+
;; Search functions.
(defun isearch--test-search-within-boundaries (pairs)
diff --git a/test/lisp/jsonrpc-tests.el b/test/lisp/jsonrpc-tests.el
index 7b822179b8d..cfbea7378e2 100644
--- a/test/lisp/jsonrpc-tests.el
+++ b/test/lisp/jsonrpc-tests.el
@@ -103,6 +103,7 @@
(process-get listen-server 'handlers))))))))
(cl-defmacro jsonrpc--with-emacsrpc-fixture ((endpoint-sym) &body body)
+ (declare (indent 1))
`(jsonrpc--call-with-emacsrpc-fixture (lambda (,endpoint-sym) ,@body)))
(ert-deftest returns-3 ()
@@ -124,7 +125,7 @@
"Signals an -32603 JSONRPC error."
(jsonrpc--with-emacsrpc-fixture (conn)
(condition-case err
- (progn
+ (let ((jsonrpc-inhibit-debug-on-error t))
(jsonrpc-request conn '+ ["a" 2])
(ert-fail "A `jsonrpc-error' should have been signaled!"))
(jsonrpc-error
@@ -151,14 +152,6 @@
[1 2 3 3 4 5]
(jsonrpc-request conn 'vconcat [[1 2 3] [3 4 5]])))))
-(ert-deftest json-el-cant-serialize-this ()
- "Can't serialize a response that is half-vector/half-list."
- (jsonrpc--with-emacsrpc-fixture (conn)
- (should-error
- ;; (append [1 2 3] [3 4 5]) => (1 2 3 . [3 4 5]), which can't be
- ;; serialized
- (jsonrpc-request conn 'append [[1 2 3] [3 4 5]]))))
-
(cl-defmethod jsonrpc-connection-ready-p
((conn jsonrpc--test-client) what)
(and (cl-call-next-method)
diff --git a/test/lisp/ls-lisp-tests.el b/test/lisp/ls-lisp-tests.el
index a4e7d23a8e9..77046871ea7 100644
--- a/test/lisp/ls-lisp-tests.el
+++ b/test/lisp/ls-lisp-tests.el
@@ -29,13 +29,6 @@
(require 'ls-lisp)
(require 'dired)
-(ert-deftest ls-lisp-unload ()
- "Test for https://debbugs.gnu.org/xxxxx ."
- (should (advice-member-p 'ls-lisp--insert-directory 'insert-directory))
- (unload-feature 'ls-lisp 'force)
- (should-not (advice-member-p 'ls-lisp--insert-directory 'insert-directory))
- (require 'ls-lisp))
-
(ert-deftest ls-lisp-test-bug27762 ()
"Test for https://debbugs.gnu.org/27762 ."
(let* ((dir source-directory)
diff --git a/test/lisp/man-tests.el b/test/lisp/man-tests.el
index 140482ee622..ecda189b6b2 100644
--- a/test/lisp/man-tests.el
+++ b/test/lisp/man-tests.el
@@ -161,6 +161,24 @@ DESCRIPTION
(let ((button (button-at (match-beginning 0))))
(should (and button (eq 'Man-xref-header-file (button-type button))))))))))
+(ert-deftest man-tests-Man-translate-references ()
+ (should (equal (Man-translate-references "basename")
+ (if (memq system-type '(ms-dos windows-nt))
+ "\"basename\""
+ "basename")))
+ (should (equal (Man-translate-references "basename(3)")
+ "3 basename"))
+ (should (equal (Man-translate-references "basename(3v)")
+ "3v basename"))
+ (should (equal (Man-translate-references ";id")
+ (if (memq system-type '(ms-dos windows-nt))
+ "\";id\""
+ "\\;id")))
+ (should (equal (Man-translate-references "-k basename")
+ (if (memq system-type '(ms-dos windows-nt))
+ "\"-k\" \"basename\""
+ "-k basename"))))
+
(provide 'man-tests)
;;; man-tests.el ends here
diff --git a/test/lisp/mh-e/test-all-mh-variants.sh b/test/lisp/mh-e/test-all-mh-variants.sh
index 428e32b9fec..a23289701fc 100755
--- a/test/lisp/mh-e/test-all-mh-variants.sh
+++ b/test/lisp/mh-e/test-all-mh-variants.sh
@@ -81,8 +81,10 @@ for path in "${mh_sys_path[@]}"; do
fi
echo "** Testing with PATH $path"
((++tests_total))
+ # The LD_LIBRARY_PATH setting is needed
+ # to run locally installed Mailutils.
TEST_MH_PATH=$path TEST_MH_DEBUG=$debug \
- HOME=/nonexistent \
+ LD_LIBRARY_PATH=/usr/local/lib HOME=/nonexistent \
"${emacs[@]}" -l ert \
--eval "(setq load-prefer-newer t)" \
--eval "(load \"$PWD/test/lisp/mh-e/mh-utils-tests\" nil t)" \
diff --git a/test/lisp/minibuffer-tests.el b/test/lisp/minibuffer-tests.el
index f86f6739aec..c4a7de9e51f 100644
--- a/test/lisp/minibuffer-tests.el
+++ b/test/lisp/minibuffer-tests.el
@@ -33,14 +33,13 @@
(ert-deftest completion-test1 ()
(with-temp-buffer
- (cl-flet* ((test/completion-table (_string _pred action)
- (if (eq action 'lambda)
- nil
- "test: "))
+ (cl-flet* ((test/completion-table (string pred action)
+ (let ((completion-ignore-case t))
+ (complete-with-action action '("test: ") string pred)))
(test/completion-at-point ()
- (list (copy-marker (point-min))
- (copy-marker (point))
- #'test/completion-table)))
+ (list (copy-marker (point-min))
+ (copy-marker (point))
+ #'test/completion-table)))
(let ((completion-at-point-functions (list #'test/completion-at-point)))
(insert "TEST")
(completion-at-point)
@@ -139,7 +138,7 @@
(defun test-completion-all-sorted-completions (base def history-var history-list)
(with-temp-buffer
(insert base)
- (cl-letf (((symbol-function #'minibufferp) (lambda (&rest _) t)))
+ (cl-letf (((symbol-function #'minibufferp) #'always))
(let ((completion-styles '(basic))
(completion-category-defaults nil)
(completion-category-overrides nil)
@@ -190,7 +189,8 @@
(defun completion--pcm-score (comp)
"Get `completion-score' from COMP."
- (get-text-property 0 'completion-score comp))
+ ;; FIXME, uses minibuffer.el implementation details
+ (completion--flex-score comp completion-pcm--regexp))
(defun completion--pcm-first-difference-pos (comp)
"Get `completions-first-difference' from COMP."
@@ -201,6 +201,13 @@
'completions-first-difference)
return pos))
+(ert-deftest completion-test--pcm-bug38458 ()
+ (should (equal (let ((completion-ignore-case t))
+ (completion-pcm--merge-try '("tes" point "ing")
+ '("Testing" "testing")
+ "" ""))
+ '("testing" . 4))))
+
(ert-deftest completion-pcm-test-1 ()
;; Point is at end, this does not match anything
(should (null
@@ -298,6 +305,19 @@
"jab" '("dabjabstabby" "many") nil 3)))
6)))
+(ert-deftest completion-substring-test-5 ()
+ ;; merge-completions needs to work correctly when
+ (should (equal
+ (completion-pcm--merge-completions '("ab" "sab") '(prefix "b"))
+ '("b" "a" prefix)))
+ (should (equal
+ (completion-pcm--merge-completions '("ab" "ab") '(prefix "b"))
+ '("b" "a")))
+ ;; substring completion should successfully complete the entire string
+ (should (equal
+ (completion-substring-try-completion "b" '("ab" "ab") nil 0)
+ '("ab" . 2))))
+
(ert-deftest completion-flex-test-1 ()
;; Fuzzy match
(should (equal
@@ -407,6 +427,21 @@
(next-completion 5)
(should (equal "ac" (get-text-property (point) 'completion--string)))
(previous-completion 5)
+ (should (equal "aa" (get-text-property (point) 'completion--string)))
+
+ (first-completion)
+ (should (equal "aa" (get-text-property (point) 'completion--string)))
+ (next-line-completion 2)
+ (should (equal "ac" (get-text-property (point) 'completion--string)))
+ (next-line-completion 5)
+ (should (equal "ac" (get-text-property (point) 'completion--string)))
+ (previous-line-completion 5)
+ (should (equal "aa" (get-text-property (point) 'completion--string)))
+ (goto-char (point-min))
+ (next-line-completion 5)
+ (should (equal "ac" (get-text-property (point) 'completion--string)))
+ (goto-char (point-min))
+ (previous-line-completion 5)
(should (equal "aa" (get-text-property (point) 'completion--string)))))
(let ((completion-auto-wrap t))
(completing-read-with-minibuffer-setup
@@ -420,8 +455,37 @@
(next-completion 1)
(should (equal "aa" (get-text-property (point) 'completion--string)))
(previous-completion 1)
+ (should (equal "ac" (get-text-property (point) 'completion--string)))
+
+ (first-completion)
+ (should (equal "aa" (get-text-property (point) 'completion--string)))
+ (next-line-completion 2)
+ (should (equal "ac" (get-text-property (point) 'completion--string)))
+ (next-line-completion 1)
+ (should (equal "aa" (get-text-property (point) 'completion--string)))
+ (previous-line-completion 1)
+ (should (equal "ac" (get-text-property (point) 'completion--string)))
+ (goto-char (point-min))
+ (next-line-completion 4)
+ (should (equal "aa" (get-text-property (point) 'completion--string)))
+ (goto-char (point-min))
+ (previous-line-completion 4)
(should (equal "ac" (get-text-property (point) 'completion--string))))))
+(ert-deftest completion-next-line-multline-test ()
+ (let ((completion-auto-wrap t))
+ (completing-read-with-minibuffer-setup
+ '("a\na" "a\nb" "ac")
+ (insert "a")
+ (minibuffer-completion-help)
+ (switch-to-completions)
+ (goto-char (point-min))
+ (next-line-completion 5)
+ (should (equal "a\nb" (get-text-property (point) 'completion--string)))
+ (goto-char (point-min))
+ (previous-line-completion 5)
+ (should (equal "a\nb" (get-text-property (point) 'completion--string))))))
+
(ert-deftest completions-header-format-test ()
(let ((completion-show-help nil)
(completions-header-format nil))
@@ -441,6 +505,16 @@
(should (equal "ac" (get-text-property (point) 'completion--string)))
(next-completion 1)
(should (equal "aa" (get-text-property (point) 'completion--string)))
+
+ (next-line-completion 2)
+ (should (equal "ac" (get-text-property (point) 'completion--string)))
+ (previous-line-completion 2)
+ (should (equal "aa" (get-text-property (point) 'completion--string)))
+ (previous-line-completion 1)
+ (should (equal "ac" (get-text-property (point) 'completion--string)))
+ (next-line-completion 1)
+ (should (equal "aa" (get-text-property (point) 'completion--string)))
+
;; Fixed in bug#55430
(execute-kbd-macro (kbd "C-u RET"))
(should (equal (minibuffer-contents) "aa")))
@@ -452,11 +526,11 @@
(ert-deftest completions-affixation-navigation-test ()
(let ((completion-extra-properties
- '(:affixation-function
- (lambda (completions)
- (mapcar (lambda (c)
- (list c "prefix " " suffix"))
- completions)))))
+ `(:affixation-function
+ ,(lambda (completions)
+ (mapcar (lambda (c)
+ (list c "prefix " " suffix"))
+ completions)))))
(completing-read-with-minibuffer-setup
'("aa" "ab" "ac")
(insert "a")
@@ -475,8 +549,86 @@
;; Fixed in bug#54374
(goto-char (1- (point-max)))
(should-not (equal 'highlight (get-text-property (point) 'mouse-face)))
+
+ (first-completion)
+ (should (equal "aa" (get-text-property (point) 'completion--string)))
+ (let ((completion-auto-wrap t))
+ (next-line-completion 3))
+ (should (equal "aa" (get-text-property (point) 'completion--string)))
+ (let ((completion-auto-wrap nil))
+ (next-line-completion 3))
+ (should (equal "ac" (get-text-property (point) 'completion--string)))
+
(execute-kbd-macro (kbd "C-u RET"))
(should (equal (minibuffer-contents) "ac")))))
+(ert-deftest completions-group-navigation-test ()
+ (completing-read-with-minibuffer-setup
+ (lambda (string pred action)
+ (if (eq action 'metadata)
+ `(metadata
+ (group-function
+ . ,(lambda (name transform)
+ (if transform
+ name
+ (pcase name
+ (`"aa1" "Group 1")
+ (`"aa2" "Group 1")
+ (`"aa3" "Group 1")
+ (`"aa4" "Group 1")
+ (`"ab1" "Group 2")
+ (`"ac1" "Group 3")
+ (`"ac2" "Group 3")))))
+ (category . unicode-name))
+ (complete-with-action action '("aa1" "aa2" "aa3" "aa4" "ab1" "ac1" "ac2")
+ string pred)))
+ (insert "a")
+ (minibuffer-completion-help)
+ (switch-to-completions)
+ (should (equal "aa1" (get-text-property (point) 'completion--string)))
+ (let ((completion-auto-wrap t))
+ (next-completion 7))
+ (should (equal "aa1" (get-text-property (point) 'completion--string)))
+ (let ((completion-auto-wrap nil))
+ (next-completion 7))
+ (should (equal "ac2" (get-text-property (point) 'completion--string)))
+
+ (let ((completion-auto-wrap t))
+ ;; First column
+ (first-completion)
+ (next-line-completion 1)
+ (should (equal "aa4" (get-text-property (point) 'completion--string)))
+ (next-line-completion 3)
+ (should (equal "aa1" (get-text-property (point) 'completion--string)))
+ (previous-line-completion 2)
+ (should (equal "ab1" (get-text-property (point) 'completion--string)))
+
+ ;; Second column
+ (first-completion)
+ (next-completion 1)
+ (should (equal "aa2" (get-text-property (point) 'completion--string)))
+ (next-line-completion 1)
+ (should (equal "ac2" (get-text-property (point) 'completion--string)))
+ (next-line-completion 1)
+ (should (equal "aa2" (get-text-property (point) 'completion--string)))
+ (previous-line-completion 1)
+ (should (equal "ac2" (get-text-property (point) 'completion--string)))
+ (previous-line-completion 1)
+ (should (equal "aa2" (get-text-property (point) 'completion--string)))
+
+ ;; Third column
+ (first-completion)
+ (next-completion 2)
+ (should (equal "aa3" (get-text-property (point) 'completion--string)))
+ (next-line-completion 1)
+ (should (equal "aa3" (get-text-property (point) 'completion--string))))
+
+ (let ((completion-auto-wrap nil))
+ (first-completion)
+ (next-line-completion 7)
+ (should (equal "ac2" (get-text-property (point) 'completion--string)))
+ (previous-line-completion 7)
+ (should (equal "aa1" (get-text-property (point) 'completion--string))))))
+
(provide 'minibuffer-tests)
;;; minibuffer-tests.el ends here
diff --git a/test/lisp/misc-tests.el b/test/lisp/misc-tests.el
index e4178dd109d..c118aba50a1 100644
--- a/test/lisp/misc-tests.el
+++ b/test/lisp/misc-tests.el
@@ -114,40 +114,70 @@
(require 'rect)
(ert-deftest misc--duplicate-dwim ()
- ;; Duplicate a line.
- (with-temp-buffer
- (insert "abc\ndefg\nh\n")
- (goto-char 7)
- (duplicate-dwim 2)
- (should (equal (buffer-string) "abc\ndefg\ndefg\ndefg\nh\n"))
- (should (equal (point) 7)))
+ (let ((duplicate-line-final-position 0)
+ (duplicate-region-final-position 0))
+ ;; Duplicate a line.
+ (dolist (final-pos '(0 -1 1))
+ (ert-info ((prin1-to-string final-pos) :prefix "final-pos: ")
+ (with-temp-buffer
+ (insert "abc\ndefg\nh\n")
+ (goto-char 7)
+ (let ((duplicate-line-final-position final-pos))
+ (duplicate-dwim 3))
+ (should (equal (buffer-string) "abc\ndefg\ndefg\ndefg\ndefg\nh\n"))
+ (let ((delta (* 5 (if (< final-pos 0) 3 final-pos))))
+ (should (equal (point) (+ 7 delta)))))))
+
+ ;; Duplicate a region.
+ (dolist (final-pos '(0 -1 1))
+ (ert-info ((prin1-to-string final-pos) :prefix "final-pos: ")
+ (with-temp-buffer
+ (insert "abCDEFghi")
+ (set-mark 3)
+ (goto-char 7)
+ (transient-mark-mode)
+ (should (use-region-p))
+ (let ((duplicate-region-final-position final-pos))
+ (duplicate-dwim 3))
+ (should (equal (buffer-string) "abCDEFCDEFCDEFCDEFghi"))
+ (should (region-active-p))
+ (let ((delta (* 4 (if (< final-pos 0) 3 final-pos))))
+ (should (equal (point) (+ 7 delta)))
+ (should (equal (mark) (+ 3 delta)))))))
+
+ ;; Duplicate a rectangular region (sparse).
+ (with-temp-buffer
+ (insert "x\n>a\n>bcde\n>fg\nyz\n")
+ (goto-char 4)
+ (rectangle-mark-mode)
+ (goto-char 15)
+ (rectangle-forward-char 1)
+ (duplicate-dwim)
+ (should (equal (buffer-string) "x\n>a a \n>bcdbcde\n>fg fg \nyz\n"))
+ (should (equal (point) 24))
+ (should (region-active-p))
+ (should rectangle-mark-mode)
+ (should (equal (mark) 4)))
+
+ ;; Idem (dense).
+ (dolist (final-pos '(0 -1 1))
+ (ert-info ((prin1-to-string final-pos) :prefix "final-pos: ")
+ (with-temp-buffer
+ (insert "aBCd\neFGh\niJKl\n")
+ (goto-char 2)
+ (rectangle-mark-mode)
+ (goto-char 14)
+ (let ((duplicate-region-final-position final-pos))
+ (duplicate-dwim 3))
+ (should (equal (buffer-string)
+ "aBCBCBCBCd\neFGFGFGFGh\niJKJKJKJKl\n"))
+ (should (region-active-p))
+ (should rectangle-mark-mode)
+ (let ((hdelta (* 2 (if (< final-pos 0) 3 final-pos)))
+ (vdelta 12))
+ (should (equal (point) (+ 14 vdelta hdelta)))
+ (should (equal (mark) (+ 2 hdelta)))))))))
- ;; Duplicate a region.
- (with-temp-buffer
- (insert "abc\ndef\n")
- (set-mark 2)
- (goto-char 7)
- (transient-mark-mode)
- (should (use-region-p))
- (duplicate-dwim)
- (should (equal (buffer-string) "abc\ndebc\ndef\n"))
- (should (equal (point) 7))
- (should (region-active-p))
- (should (equal (mark) 2)))
-
- ;; Duplicate a rectangular region.
- (with-temp-buffer
- (insert "x\n>a\n>bcde\n>fg\nyz\n")
- (goto-char 4)
- (rectangle-mark-mode)
- (goto-char 15)
- (rectangle-forward-char 1)
- (duplicate-dwim)
- (should (equal (buffer-string) "x\n>a a \n>bcdbcde\n>fg fg \nyz\n"))
- (should (equal (point) 24))
- (should (region-active-p))
- (should rectangle-mark-mode)
- (should (equal (mark) 4))))
(provide 'misc-tests)
;;; misc-tests.el ends here
diff --git a/test/lisp/net/eww-tests.el b/test/lisp/net/eww-tests.el
new file mode 100644
index 00000000000..b83435e0bd9
--- /dev/null
+++ b/test/lisp/net/eww-tests.el
@@ -0,0 +1,247 @@
+;;; eww-tests.el --- tests for eww.el -*- lexical-binding: t; -*-
+
+;; Copyright (C) 2024 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 <https://www.gnu.org/licenses/>.
+
+;;; Commentary:
+
+;;; Code:
+
+(require 'ert)
+(require 'eww)
+
+(defvar eww-test--response-function (lambda (url) (concat "\n" url))
+ "A function for returning a mock response for URL.
+The default just returns an empty list of headers and the URL as the
+body.")
+
+(defmacro eww-test--with-mock-retrieve (&rest body)
+ "Evaluate BODY with a mock implementation of `eww-retrieve'.
+This avoids network requests during our tests. Additionally, prepare a
+temporary EWW buffer for our tests."
+ (declare (indent 0))
+ `(cl-letf (((symbol-function 'eww-retrieve)
+ (lambda (url callback args)
+ (with-temp-buffer
+ (insert (funcall eww-test--response-function url))
+ (apply callback nil args)))))
+ (with-temp-buffer
+ (eww-mode)
+ ,@body)))
+
+(defun eww-test--history-urls ()
+ (mapcar (lambda (elem) (plist-get elem :url)) eww-history))
+
+;;; Tests:
+
+(ert-deftest eww-test/display/html ()
+ "Test displaying a simple HTML page."
+ (eww-test--with-mock-retrieve
+ (let ((eww-test--response-function
+ (lambda (url)
+ (concat "Content-Type: text/html\n\n"
+ (format "<html><body><h1>Hello</h1>%s</body></html>"
+ url)))))
+ (eww "example.invalid")
+ ;; Check that the buffer contains the rendered HTML.
+ (should (equal (buffer-string) "Hello\n\n\nhttp://example.invalid/\n"))
+ (should (equal (get-text-property (point-min) 'face)
+ '(shr-text shr-h1)))
+ ;; Check that the DOM includes the `base'.
+ (should (equal (pcase (plist-get eww-data :dom)
+ (`(base ((href . ,url)) ,_) url))
+ "http://example.invalid/")))))
+
+(ert-deftest eww-test/history/new-page ()
+ "Test that when visiting a new page, the previous one goes into the history."
+ (eww-test--with-mock-retrieve
+ (eww "one.invalid")
+ (eww "two.invalid")
+ (should (equal (eww-test--history-urls)
+ '("http://one.invalid/")))
+ (eww "three.invalid")
+ (should (equal (eww-test--history-urls)
+ '("http://two.invalid/"
+ "http://one.invalid/")))))
+
+(ert-deftest eww-test/history/back-forward ()
+ "Test that navigating through history just changes our history position.
+See bug#69232."
+ (eww-test--with-mock-retrieve
+ (eww "one.invalid")
+ (eww "two.invalid")
+ (eww "three.invalid")
+ (let ((url-history '("http://three.invalid/"
+ "http://two.invalid/"
+ "http://one.invalid/")))
+ ;; Go back one page. This should add "three.invalid" to the
+ ;; history, making our position in the list 2.
+ (eww-back-url)
+ (should (equal (eww-test--history-urls) url-history))
+ (should (= eww-history-position 2))
+ ;; Go back again.
+ (eww-back-url)
+ (should (equal (eww-test--history-urls) url-history))
+ (should (= eww-history-position 3))
+ ;; At the beginning of the history, so trying to go back should
+ ;; signal an error.
+ (should-error (eww-back-url))
+ ;; Go forward once.
+ (eww-forward-url)
+ (should (equal (eww-test--history-urls) url-history))
+ (should (= eww-history-position 2))
+ ;; Go forward again.
+ (eww-forward-url)
+ (should (equal (eww-test--history-urls) url-history))
+ (should (= eww-history-position 1))
+ ;; At the end of the history, so trying to go forward should
+ ;; signal an error.
+ (should-error (eww-forward-url)))))
+
+(ert-deftest eww-test/history/reload-in-place ()
+ "Test that reloading historical pages updates their history entry in-place.
+See bug#69232."
+ (eww-test--with-mock-retrieve
+ (eww "one.invalid")
+ (eww "two.invalid")
+ (eww "three.invalid")
+ (eww-back-url)
+ ;; Make sure our history has the original page text.
+ (should (equal (plist-get (nth 1 eww-history) :text)
+ "http://two.invalid/"))
+ (should (= eww-history-position 2))
+ ;; Reload the page.
+ (let ((eww-test--response-function
+ (lambda (url) (concat "\nreloaded " url))))
+ (eww-reload)
+ (should (= eww-history-position 2)))
+ ;; Go to another page, and make sure the history is correct,
+ ;; including the reloaded page text.
+ (eww "four.invalid")
+ (should (equal (eww-test--history-urls) '("http://two.invalid/"
+ "http://one.invalid/")))
+ (should (equal (plist-get (nth 0 eww-history) :text)
+ "reloaded http://two.invalid/"))
+ (should (= eww-history-position 0))))
+
+(ert-deftest eww-test/history/before-navigate/delete-future-history ()
+ "Test that going to a new page from a historical one deletes future history.
+See bug#69232."
+ (eww-test--with-mock-retrieve
+ (eww "one.invalid")
+ (eww "two.invalid")
+ (eww "three.invalid")
+ (eww-back-url)
+ (eww "four.invalid")
+ (eww "five.invalid")
+ (should (equal (eww-test--history-urls) '("http://four.invalid/"
+ "http://two.invalid/"
+ "http://one.invalid/")))
+ (should (= eww-history-position 0))))
+
+(ert-deftest eww-test/history/before-navigate/ignore-history ()
+ "Test that going to a new page from a historical one preserves history.
+This sets `eww-before-browse-history-function' to `ignore' to preserve
+history. See bug#69232."
+ (let ((eww-before-browse-history-function #'ignore))
+ (eww-test--with-mock-retrieve
+ (eww "one.invalid")
+ (eww "two.invalid")
+ (eww "three.invalid")
+ (eww-back-url)
+ (eww "four.invalid")
+ (eww "five.invalid")
+ (should (equal (eww-test--history-urls) '("http://four.invalid/"
+ "http://three.invalid/"
+ "http://two.invalid/"
+ "http://one.invalid/")))
+ (should (= eww-history-position 0)))))
+
+(ert-deftest eww-test/history/before-navigate/clone-previous ()
+ "Test that going to a new page from a historical one clones prior history.
+This sets `eww-before-browse-history-function' to
+`eww-clone-previous-history' to clone the history. See bug#69232."
+ (let ((eww-before-browse-history-function #'eww-clone-previous-history))
+ (eww-test--with-mock-retrieve
+ (eww "one.invalid")
+ (eww "two.invalid")
+ (eww "three.invalid")
+ (eww-back-url)
+ (eww "four.invalid")
+ (eww "five.invalid")
+ (should (equal (eww-test--history-urls)
+ '(;; New page and cloned history.
+ "http://four.invalid/"
+ "http://two.invalid/"
+ "http://one.invalid/"
+ ;; Original history.
+ "http://three.invalid/"
+ "http://two.invalid/"
+ "http://one.invalid/")))
+ (should (= eww-history-position 0)))))
+
+(ert-deftest eww-test/readable/toggle-display ()
+ "Test toggling the display of the \"readable\" parts of a web page."
+ (eww-test--with-mock-retrieve
+ (let* ((shr-width most-positive-fixnum)
+ (shr-use-fonts nil)
+ (words (string-join
+ (make-list
+ 20 "All work and no play makes Jack a dull boy.")
+ " "))
+ (eww-test--response-function
+ (lambda (_url)
+ (concat "Content-Type: text/html\n\n"
+ "<html><body>"
+ "<a>This is an uninteresting sentence.</a>"
+ "<div>"
+ words
+ "</div>"
+ "</body></html>"))))
+ (eww "example.invalid")
+ ;; Make sure EWW renders the whole document.
+ (should-not (plist-get eww-data :readable))
+ (should (string-prefix-p
+ "This is an uninteresting sentence."
+ (buffer-substring-no-properties (point-min) (point-max))))
+ (eww-readable 'toggle)
+ ;; Now, EWW should render just the "readable" parts.
+ (should (plist-get eww-data :readable))
+ (should (string-match-p
+ (concat "\\`" (regexp-quote words) "\n*\\'")
+ (buffer-substring-no-properties (point-min) (point-max))))
+ (eww-readable 'toggle)
+ ;; Finally, EWW should render the whole document again.
+ (should-not (plist-get eww-data :readable))
+ (should (string-prefix-p
+ "This is an uninteresting sentence."
+ (buffer-substring-no-properties (point-min) (point-max)))))))
+
+(ert-deftest eww-test/readable/default-readable ()
+ "Test that EWW displays readable parts of pages by default when applicable."
+ (eww-test--with-mock-retrieve
+ (let* ((eww-test--response-function
+ (lambda (_url)
+ (concat "Content-Type: text/html\n\n"
+ "<html><body>Hello there</body></html>")))
+ (eww-readable-urls '("://example\\.invalid/")))
+ (eww "example.invalid")
+ ;; Make sure EWW uses "readable" mode.
+ (should (plist-get eww-data :readable)))))
+
+(provide 'eww-tests)
+;; eww-tests.el ends here
diff --git a/test/lisp/net/mailcap-tests.el b/test/lisp/net/mailcap-tests.el
index fe0c99291f5..5c03e73d371 100644
--- a/test/lisp/net/mailcap-tests.el
+++ b/test/lisp/net/mailcap-tests.el
@@ -537,5 +537,29 @@ help to verify the correct addition and merging of an entry."
("minor" . ((viewer . "viewer")
(edit . "edit")))))))))
+
+
+(ert-deftest mailcap-viewer-passes-test-w/o-test-returns-t ()
+ "A VIEWER-INFO without a test should return t with a valid viewer (Bug#65224)."
+
+ (should (equal t
+ (let ((mailcap-viewer-test-cache)
+ (viewer-info
+ (list (cons 'viewer "viewer-w/o-test"))))
+ (mailcap-viewer-passes-test viewer-info nil))))
+
+ (should (equal '(t t nil t)
+ (let ((mailcap-viewer-test-cache)
+ (viewer-infos
+ (list
+ (list (cons 'viewer "viewer-w/o-test"))
+ (list (cons 'viewer "viewer-w/o-test"))
+ (list (cons 'viewer "viewer-w/nil-test")
+ (cons 'test nil))
+ (list (cons 'viewer "viewer-w/o-test"))
+ )))
+ (mapcar (lambda (vi)
+ (mailcap-viewer-passes-test vi nil))
+ viewer-infos)))))
;;; mailcap-tests.el ends here
diff --git a/test/lisp/net/network-stream-tests.el b/test/lisp/net/network-stream-tests.el
index f42b43903ac..4e600573e7a 100644
--- a/test/lisp/net/network-stream-tests.el
+++ b/test/lisp/net/network-stream-tests.el
@@ -236,7 +236,7 @@
(while (and (eq (process-status proc) 'connect)
(< (setq times (1+ times)) 10))
(sit-for 0.1))
- (skip-unless (not (eq (process-status proc) 'connect)))
+ (skip-when (eq (process-status proc) 'connect))
(with-current-buffer (process-buffer proc)
(process-send-string proc "echo foo")
(sleep-for 0.1)
@@ -323,7 +323,7 @@
(while (and (eq (process-status proc) 'connect)
(< (setq times (1+ times)) 10))
(sit-for 0.1))
- (skip-unless (not (eq (process-status proc) 'connect))))
+ (skip-when (eq (process-status proc) 'connect)))
(if (process-live-p server) (delete-process server)))
(setq status (gnutls-peer-status proc))
(should (consp status))
@@ -336,7 +336,7 @@
(ert-deftest connect-to-tls-ipv6-nowait ()
(skip-unless (executable-find "gnutls-serv"))
(skip-unless (gnutls-available-p))
- (skip-unless (not (eq system-type 'windows-nt)))
+ (skip-when (eq system-type 'windows-nt))
(skip-unless (featurep 'make-network-process '(:family ipv6)))
(let ((server (make-tls-server 44333))
(times 0)
@@ -368,7 +368,7 @@
(while (and (eq (process-status proc) 'connect)
(< (setq times (1+ times)) 10))
(sit-for 0.1))
- (skip-unless (not (eq (process-status proc) 'connect))))
+ (skip-when (eq (process-status proc) 'connect)))
(if (process-live-p server) (delete-process server)))
(setq status (gnutls-peer-status proc))
(should (consp status))
@@ -403,7 +403,7 @@
(< (setq times (1+ times)) 10))
(sit-for 0.1))
(should proc)
- (skip-unless (not (eq (process-status proc) 'connect))))
+ (skip-when (eq (process-status proc) 'connect)))
(if (process-live-p server) (delete-process server)))
(setq status (gnutls-peer-status proc))
(should (consp status))
@@ -446,7 +446,7 @@
(while (and (eq (process-status proc) 'connect)
(< (setq times (1+ times)) 10))
(sit-for 0.1))
- (skip-unless (not (eq (process-status proc) 'connect))))
+ (skip-when (eq (process-status proc) 'connect)))
(if (process-live-p server) (delete-process server)))
(setq status (gnutls-peer-status proc))
(should (consp status))
@@ -484,7 +484,7 @@
(< (setq times (1+ times)) 10))
(sit-for 0.1))
(should proc)
- (skip-unless (not (eq (process-status proc) 'connect))))
+ (skip-when (eq (process-status proc) 'connect)))
(if (process-live-p server) (delete-process server)))
(setq status (gnutls-peer-status proc))
(should (consp status))
@@ -523,7 +523,7 @@
(< (setq times (1+ times)) 10))
(sit-for 0.1))
(should proc)
- (skip-unless (not (eq (process-status proc) 'connect))))
+ (skip-when (eq (process-status proc) 'connect)))
(if (process-live-p server) (delete-process server)))
(setq status (gnutls-peer-status proc))
(should (consp status))
@@ -673,7 +673,7 @@
(while (and (eq (process-status proc) 'connect)
(< (setq times (1+ times)) 10))
(sit-for 0.1))
- (skip-unless (not (eq (process-status proc) 'connect))))
+ (skip-when (eq (process-status proc) 'connect)))
(if (process-live-p server) (delete-process server)))
(setq status (gnutls-peer-status proc))
(should (consp status))
@@ -712,7 +712,7 @@
(while (and (eq (process-status proc) 'connect)
(< (setq times (1+ times)) 10))
(sit-for 0.1))
- (skip-unless (not (eq (process-status proc) 'connect))))
+ (skip-when (eq (process-status proc) 'connect)))
(if (process-live-p server) (delete-process server)))
(setq status (gnutls-peer-status proc))
(should (consp status))
diff --git a/test/lisp/net/shr-resources/blockquote.html b/test/lisp/net/shr-resources/blockquote.html
new file mode 100644
index 00000000000..412caf8bae6
--- /dev/null
+++ b/test/lisp/net/shr-resources/blockquote.html
@@ -0,0 +1,2 @@
+<blockquote>Citation.</blockquote>
+<div>Reply.</div>
diff --git a/test/lisp/net/shr-resources/blockquote.txt b/test/lisp/net/shr-resources/blockquote.txt
new file mode 100644
index 00000000000..8ed610b8ea2
--- /dev/null
+++ b/test/lisp/net/shr-resources/blockquote.txt
@@ -0,0 +1,3 @@
+ Citation.
+
+Reply.
diff --git a/test/lisp/net/shr-tests.el b/test/lisp/net/shr-tests.el
index 0c6e2c091bf..17138053450 100644
--- a/test/lisp/net/shr-tests.el
+++ b/test/lisp/net/shr-tests.el
@@ -29,30 +29,62 @@
(declare-function libxml-parse-html-region "xml.c")
-(defun shr-test (name)
- (with-temp-buffer
- (insert-file-contents (format (concat (ert-resource-directory) "/%s.html") name))
- (let ((dom (libxml-parse-html-region (point-min) (point-max)))
- (shr-width 80)
- (shr-use-fonts nil))
- (erase-buffer)
- (shr-insert-document dom)
- (cons (buffer-substring-no-properties (point-min) (point-max))
- (with-temp-buffer
- (insert-file-contents
- (format (concat (ert-resource-directory) "/%s.txt") name))
- (while (re-search-forward "%\\([0-9A-F][0-9A-F]\\)" nil t)
- (replace-match (string (string-to-number (match-string 1) 16))
- t t))
- (buffer-string))))))
+(defun shr-test--rendering-check (name &optional context)
+ "Render NAME.html and compare it to NAME.txt.
+Raise a test failure if the rendered buffer does not match NAME.txt.
+Append CONTEXT to the failure data, if non-nil."
+ (let ((text-file (file-name-concat (ert-resource-directory) (concat name ".txt")))
+ (html-file (file-name-concat (ert-resource-directory) (concat name ".html")))
+ (description (if context (format "%s (%s)" name context) name)))
+ (with-temp-buffer
+ (insert-file-contents html-file)
+ (let ((dom (libxml-parse-html-region (point-min) (point-max)))
+ (shr-width 80)
+ (shr-use-fonts nil))
+ (erase-buffer)
+ (shr-insert-document dom)
+ (let ((result (buffer-substring-no-properties (point-min) (point-max)))
+ (expected
+ (with-temp-buffer
+ (insert-file-contents text-file)
+ (while (re-search-forward "%\\([0-9A-F][0-9A-F]\\)" nil t)
+ (replace-match (string (string-to-number (match-string 1) 16))
+ t t))
+ (buffer-string))))
+ (unless (equal result expected)
+ (ert-fail (list description result expected))))))))
+
+(defconst shr-test--rendering-extra-configs
+ '(("blockquote"
+ ;; Make sure blockquotes remain indented even when filling is
+ ;; disabled (bug#69555).
+ . ((shr-fill-text . nil))))
+ "Extra customizations which can impact rendering.
+This is a list of (NAME . SETTINGS) pairs. NAME is the basename of a
+set of txt/html files under shr-resources/, as passed to `shr-test'.
+SETTINGS is a list of (OPTION . VALUE) pairs that are interesting to
+validate for the NAME testcase.
+
+The `rendering' testcase will test NAME once without altering any
+settings, then once more for each (OPTION . VALUE) pair.")
(ert-deftest rendering ()
(skip-unless (fboundp 'libxml-parse-html-region))
(dolist (file (directory-files (ert-resource-directory) nil "\\.html\\'"))
- (let* ((name (replace-regexp-in-string "\\.html\\'" "" file))
- (result (shr-test name)))
- (unless (equal (car result) (cdr result))
- (should (not (list name (car result) (cdr result))))))))
+ (let* ((name (string-remove-suffix ".html" file))
+ (extra-options (alist-get name shr-test--rendering-extra-configs
+ nil nil 'string=)))
+ ;; Test once with default settings.
+ (shr-test--rendering-check name)
+ ;; Test once more for every extra option for this specific NAME.
+ (pcase-dolist (`(,option-sym ,option-val)
+ extra-options)
+ (let ((option-old (symbol-value option-sym)))
+ (set option-sym option-val)
+ (unwind-protect
+ (shr-test--rendering-check
+ name (format "with %s %s" option-sym option-val))
+ (set option-sym option-old)))))))
(ert-deftest use-cookies ()
(let ((shr-cookie-policy 'same-origin))
diff --git a/test/lisp/net/socks-tests.el b/test/lisp/net/socks-tests.el
index 904d13b6d1f..b9515876d6c 100644
--- a/test/lisp/net/socks-tests.el
+++ b/test/lisp/net/socks-tests.el
@@ -63,21 +63,21 @@
(process-put proc 'socks-state socks-state-waiting)
(process-put proc 'socks-server-protocol 4)
(ert-info ("Receive initial incomplete segment")
- (socks-filter proc (concat [0 90 0 0 93 184 216]))
- ;; From example.com: OK status ^ ^ msg start
+ (socks-filter proc (unibyte-string 0 90 0 0 93 184 216))
+ ;; From example.com: OK status ^ ^ msg start
(ert-info ("State still set to waiting")
(should (eq (process-get proc 'socks-state) socks-state-waiting)))
(ert-info ("Response field is nil because processing incomplete")
(should-not (process-get proc 'socks-response)))
(ert-info ("Scratch field holds stashed partial payload")
- (should (string= (concat [0 90 0 0 93 184 216])
+ (should (string= (unibyte-string 0 90 0 0 93 184 216)
(process-get proc 'socks-scratch)))))
(ert-info ("Last part arrives")
(socks-filter proc "\42") ; ?\" 34
(ert-info ("State transitions to complete (length check passes)")
(should (eq (process-get proc 'socks-state) socks-state-connected)))
(ert-info ("Scratch and response fields hold stash w. last chunk")
- (should (string= (concat [0 90 0 0 93 184 216 34])
+ (should (string= (unibyte-string 0 90 0 0 93 184 216 34)
(process-get proc 'socks-response)))
(should (string= (process-get proc 'socks-response)
(process-get proc 'socks-scratch)))))
@@ -133,17 +133,19 @@ Vectors must match verbatim. Strings are considered regex patterns.")
(defun socks-tests-canned-server-create ()
"Create and return a fake SOCKS server."
(let* ((port (nth 2 socks-server))
- (name (format "socks-server:%d" port))
+ (name (format "socks-server:%s"
+ (if (numberp port) port (ert-test-name (ert-running-test)))))
(pats socks-tests-canned-server-patterns)
(filt (lambda (proc line)
(pcase-let ((`(,pat . ,resp) (pop pats)))
(unless (or (and (vectorp pat) (equal pat (vconcat line)))
- (string-match-p pat line))
+ (and (stringp pat) (string-match-p pat line)))
(error "Unknown request: %s" line))
+ (setq resp (apply #'unibyte-string (append resp nil)))
(let ((print-escape-control-characters t))
(message "[%s] <- %s" name (prin1-to-string line))
(message "[%s] -> %s" name (prin1-to-string resp)))
- (process-send-string proc (concat resp)))))
+ (process-send-string proc resp))))
(serv (make-network-process :server 1
:buffer (get-buffer-create name)
:filter filt
@@ -151,8 +153,10 @@ Vectors must match verbatim. Strings are considered regex patterns.")
:family 'ipv4
:host 'local
:coding 'binary
- :service port)))
+ :service (or port t))))
(set-process-query-on-exit-flag serv nil)
+ (unless (numberp (nth 2 socks-server))
+ (setf (nth 2 socks-server) (process-contact serv :service)))
serv))
(defvar socks-tests--hello-world-http-request-pattern
@@ -161,9 +165,9 @@ Vectors must match verbatim. Strings are considered regex patterns.")
"Content-Length: 13\r\n\r\n"
"Hello World!\n")))
-(defun socks-tests-perform-hello-world-http-request ()
+(defun socks-tests-perform-hello-world-http-request (&optional method)
"Start canned server, validate hello-world response, and finalize."
- (let* ((url-gateway-method 'socks)
+ (let* ((url-gateway-method (or method 'socks))
(url (url-generic-parse-url "http://example.com"))
(server (socks-tests-canned-server-create))
;;
@@ -191,8 +195,9 @@ Vectors must match verbatim. Strings are considered regex patterns.")
(ert-deftest socks-tests-v4-basic ()
"Show correct preparation of SOCKS4 connect command (Bug#46342)."
- (let ((socks-server '("server" "127.0.0.1" 10079 4))
+ (let ((socks-server '("server" "127.0.0.1" t 4))
(url-user-agent "Test/4-basic")
+ (socks-username "foo")
(socks-tests-canned-server-patterns
`(([4 1 0 80 93 184 216 34 ?f ?o ?o 0] . [0 90 0 0 0 0 0 0])
,socks-tests--hello-world-http-request-pattern))
@@ -201,11 +206,35 @@ Vectors must match verbatim. Strings are considered regex patterns.")
(cl-letf (((symbol-function 'socks-nslookup-host)
(lambda (host)
(should (equal host "example.com"))
- (list 93 184 216 34)))
- ((symbol-function 'user-full-name)
- (lambda (&optional _) "foo")))
+ (list 93 184 216 34))))
(socks-tests-perform-hello-world-http-request)))))
+(ert-deftest socks-tests-v4a-basic ()
+ "Show correct preparation of SOCKS4a connect command."
+ (let ((socks-server '("server" "127.0.0.1" t 4a))
+ (socks-username "foo")
+ (url-user-agent "Test/4a-basic")
+ (socks-tests-canned-server-patterns
+ `(([4 1 0 80 0 0 0 1 ?f ?o ?o 0 ?e ?x ?a ?m ?p ?l ?e ?. ?c ?o ?m 0]
+ . [0 90 0 0 0 0 0 0])
+ ,socks-tests--hello-world-http-request-pattern)))
+ (ert-info ("Make HTTP request over SOCKS4A")
+ (socks-tests-perform-hello-world-http-request))))
+
+(ert-deftest socks-tests-v4a-error ()
+ "Show error signaled when destination address rejected."
+ (let ((socks-server '("server" "127.0.0.1" t 4a))
+ (url-user-agent "Test/4a-basic")
+ (socks-username "")
+ (socks-tests-canned-server-patterns
+ `(([4 1 0 80 0 0 0 1 0 ?e ?x ?a ?m ?p ?l ?e ?. ?c ?o ?m 0]
+ . [0 91 0 0 0 0 0 0])
+ ,socks-tests--hello-world-http-request-pattern)))
+ (ert-info ("Make HTTP request over SOCKS4A")
+ (let ((err (should-error
+ (socks-tests-perform-hello-world-http-request))))
+ (should (equal err '(error "SOCKS: Rejected or failed")))))))
+
;; Replace first pattern below with ([5 3 0 1 2] . [5 2]) to validate
;; against curl 7.71 with the following options:
;; $ curl --verbose -U foo:bar --proxy socks5h://127.0.0.1:10080 example.com
@@ -213,7 +242,7 @@ Vectors must match verbatim. Strings are considered regex patterns.")
(ert-deftest socks-tests-v5-auth-user-pass ()
"Verify correct handling of SOCKS5 user/pass authentication."
(should (assq 2 socks-authentication-methods))
- (let ((socks-server '("server" "127.0.0.1" 10080 5))
+ (let ((socks-server '("server" "127.0.0.1" t 5))
(socks-username "foo")
(socks-password "bar")
(url-user-agent "Test/auth-user-pass")
@@ -247,7 +276,7 @@ Vectors must match verbatim. Strings are considered regex patterns.")
(ert-deftest socks-tests-v5-auth-user-pass-blank ()
"Verify correct SOCKS5 user/pass authentication with empty pass."
(should (assq 2 socks-authentication-methods))
- (let ((socks-server '("server" "127.0.0.1" 10081 5))
+ (let ((socks-server '("server" "127.0.0.1" t 5))
(socks-username "foo") ; defaults to (user-login-name)
(socks-password "") ; simulate user hitting enter when prompted
(url-user-agent "Test/auth-user-pass-blank")
@@ -264,9 +293,9 @@ Vectors must match verbatim. Strings are considered regex patterns.")
;; against curl 7.71 with the following options:
;; $ curl --verbose --proxy socks5h://127.0.0.1:10082 example.com
-(ert-deftest socks-tests-v5-auth-none ()
+(defun socks-tests-v5-auth-none (method)
"Verify correct handling of SOCKS5 when auth method 0 requested."
- (let ((socks-server '("server" "127.0.0.1" 10082 5))
+ (let ((socks-server '("server" "127.0.0.1" t 5))
(socks-authentication-methods (append socks-authentication-methods
nil))
(url-user-agent "Test/auth-none")
@@ -278,7 +307,24 @@ Vectors must match verbatim. Strings are considered regex patterns.")
(socks-unregister-authentication-method 2)
(should-not (assq 2 socks-authentication-methods))
(ert-info ("Make HTTP request over SOCKS5 with no auth method")
- (socks-tests-perform-hello-world-http-request)))
+ (socks-tests-perform-hello-world-http-request method)))
(should (assq 2 socks-authentication-methods)))
+(ert-deftest socks-tests-v5-auth-none ()
+ (socks-tests-v5-auth-none 'socks))
+
+;; This simulates the top-level advice around `open-network-stream'
+;; that's applied when loading the library with a non-nil
+;; `socks-override-functions'.
+(ert-deftest socks-override-functions ()
+ (should-not socks-override-functions)
+ (should-not (advice-member-p #'socks--open-network-stream
+ 'open-network-stream))
+ (advice-add 'open-network-stream :around #'socks--open-network-stream)
+ (unwind-protect (let ((socks-override-functions t))
+ (socks-tests-v5-auth-none 'native))
+ (advice-remove 'open-network-stream #'socks--open-network-stream))
+ (should-not (advice-member-p #'socks--open-network-stream
+ 'open-network-stream)))
+
;;; socks-tests.el ends here
diff --git a/test/lisp/net/tramp-archive-tests.el b/test/lisp/net/tramp-archive-tests.el
index 057a16aafce..1ca2fa9b9b3 100644
--- a/test/lisp/net/tramp-archive-tests.el
+++ b/test/lisp/net/tramp-archive-tests.el
@@ -77,7 +77,7 @@ A resource file is in the resource directory as per
`ert-resource-directory'."
`(expand-file-name ,file (ert-resource-directory)))))
-(defconst tramp-archive-test-file-archive (ert-resource-file "foo.tar.gz")
+(defvar tramp-archive-test-file-archive (ert-resource-file "foo.tar.gz")
"The test file archive.")
(defun tramp-archive-test-file-archive-hexlified ()
@@ -86,7 +86,7 @@ Do not hexlify \"/\". This hexlified string is used in `file:///' URLs."
(let* ((url-unreserved-chars (cons ?/ url-unreserved-chars)))
(url-hexify-string tramp-archive-test-file-archive)))
-(defconst tramp-archive-test-archive
+(defvar tramp-archive-test-archive
(file-name-as-directory tramp-archive-test-file-archive)
"The test archive.")
@@ -121,12 +121,6 @@ the origin of the temporary TMPFILE, have no write permissions."
(directory-files tmpfile 'full directory-files-no-dot-files-regexp))
(delete-directory tmpfile)))
-(defun tramp-archive--test-emacs27-p ()
- "Check for Emacs version >= 27.1.
-Some semantics has been changed for there, without new functions or
-variables, so we check the Emacs version directly."
- (>= emacs-major-version 27))
-
(defun tramp-archive--test-emacs28-p ()
"Check for Emacs version >= 28.1.
Some semantics has been changed for there, without new functions or
@@ -621,16 +615,13 @@ This checks also `file-name-as-directory', `file-name-directory',
(with-temp-buffer
(insert-directory tramp-archive-test-archive nil)
(goto-char (point-min))
- (should
- (looking-at-p
- (tramp-compat-rx (literal tramp-archive-test-archive)))))
+ (should (looking-at-p (rx (literal tramp-archive-test-archive)))))
(with-temp-buffer
(insert-directory tramp-archive-test-archive "-al")
(goto-char (point-min))
(should
(looking-at-p
- (tramp-compat-rx
- bol (+ nonl) blank (literal tramp-archive-test-archive) eol))))
+ (rx bol (+ nonl) blank (literal tramp-archive-test-archive) eol))))
(with-temp-buffer
(insert-directory
(file-name-as-directory tramp-archive-test-archive)
@@ -886,12 +877,8 @@ This tests also `file-executable-p', `file-writable-p' and `set-file-modes'."
(ert-deftest tramp-archive-test43-file-system-info ()
"Check that `file-system-info' returns proper values."
(skip-unless tramp-archive-enabled)
- ;; Since Emacs 27.1.
- (skip-unless (fboundp 'file-system-info))
- ;; `file-system-info' exists since Emacs 27. We don't want to see
- ;; compiler warnings for older Emacsen.
- (let ((fsi (with-no-warnings (file-system-info tramp-archive-test-archive))))
+ (let ((fsi (file-system-info tramp-archive-test-archive)))
(skip-unless fsi)
(should (and (consp fsi)
(tramp-compat-length= fsi 3)
@@ -900,12 +887,29 @@ 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-test47-auto-load ()
+;; `file-user-uid' and `file-group-gid' were introduced in Emacs 30.1.
+(ert-deftest tramp-archive-test44-user-group-ids ()
+ "Check results of user/group functions.
+`file-user-uid' and `file-group-gid' should return proper values."
+ (skip-unless tramp-archive-enabled)
+ (skip-unless (and (fboundp 'file-user-uid)
+ (fboundp 'file-group-gid)))
+
+ ;; `file-user-uid' and `file-group-gid' exist since Emacs 30.1.
+ ;; We don't want to see compiler warnings for older Emacsen.
+ (let* ((default-directory tramp-archive-test-archive)
+ (uid (with-no-warnings (file-user-uid)))
+ (gid (with-no-warnings (file-group-gid))))
+ (should (integerp uid))
+ (should (integerp gid))
+ (let ((default-directory tramp-archive-test-file-archive))
+ (should (equal uid (with-no-warnings (file-user-uid))))
+ (should (equal gid (with-no-warnings (file-group-gid)))))))
+
+(ert-deftest tramp-archive-test48-auto-load ()
"Check that `tramp-archive' autoloads properly."
:tags '(:expensive-test)
(skip-unless tramp-archive-enabled)
- ;; Autoloading tramp-archive works since Emacs 27.1.
- (skip-unless (tramp-archive--test-emacs27-p))
;; tramp-archive is neither loaded at Emacs startup, nor when
;; loading a file like "/mock::foo" (which loads Tramp).
@@ -931,7 +935,7 @@ This tests also `file-executable-p', `file-writable-p' and `set-file-modes'."
(dolist (file `("/mock::foo" ,(concat tramp-archive-test-archive "foo")))
(should
(string-match
- (tramp-compat-rx
+ (rx
"tramp-archive loaded: "
(literal (symbol-name
(tramp-archive-file-name-p default-directory)))
@@ -950,12 +954,10 @@ This tests also `file-executable-p', `file-writable-p' and `set-file-modes'."
(format "(setq tramp-archive-enabled %s)" enabled))
(shell-quote-argument (format code file)))))))))))
-(ert-deftest tramp-archive-test47-delay-load ()
+(ert-deftest tramp-archive-test48-delay-load ()
"Check that `tramp-archive' is loaded lazily, only when needed."
:tags '(:expensive-test)
(skip-unless tramp-archive-enabled)
- ;; Autoloading tramp-archive works since Emacs 27.1.
- (skip-unless (tramp-archive--test-emacs27-p))
;; tramp-archive is neither loaded at Emacs startup, nor when
;; loading a file like "/foo.tar". It is loaded only when
@@ -976,7 +978,7 @@ This tests also `file-executable-p', `file-writable-p' and `set-file-modes'."
(dolist (tae '(t nil))
(should
(string-match
- (tramp-compat-rx
+ (rx
"tramp-archive loaded: nil" (+ ascii)
"tramp-archive loaded: nil" (+ ascii)
"tramp-archive loaded: " (literal (symbol-name tae)))
@@ -991,6 +993,20 @@ This tests also `file-executable-p', `file-writable-p' and `set-file-modes'."
code tae tramp-archive-test-file-archive
(concat tramp-archive-test-archive "foo"))))))))))
+(ert-deftest tramp-archive-test49-without-remote-files ()
+ "Check that Tramp can be suppressed."
+ (skip-unless tramp-archive-enabled)
+
+ (should (file-exists-p tramp-archive-test-archive))
+ (should-not (without-remote-files (file-exists-p tramp-archive-test-archive)))
+ (should (file-exists-p tramp-archive-test-archive))
+
+ (inhibit-remote-files)
+ (should-not (file-exists-p tramp-archive-test-archive))
+ (tramp-register-file-name-handlers)
+ (setq tramp-mode t)
+ (should (file-exists-p tramp-archive-test-archive)))
+
(ert-deftest tramp-archive-test99-libarchive-tests ()
"Run tests of libarchive test files."
:tags '(:expensive-test :unstable)
diff --git a/test/lisp/net/tramp-tests.el b/test/lisp/net/tramp-tests.el
index 465afa87bb0..cdd2a1efdb2 100644
--- a/test/lisp/net/tramp-tests.el
+++ b/test/lisp/net/tramp-tests.el
@@ -33,7 +33,7 @@
;; remote host, set this environment variable to "/dev/null" or
;; whatever is appropriate on your system.
-;; For slow remote connections, `tramp-test44-asynchronous-requests'
+;; For slow remote connections, `tramp-test45-asynchronous-requests'
;; might be too heavy. Setting $REMOTE_PARALLEL_PROCESSES to a proper
;; value less than 10 could help.
@@ -72,17 +72,18 @@
(defvar tramp-persistency-file-name)
(defvar tramp-remote-path)
(defvar tramp-remote-process-environment)
+(defvar tramp-use-connection-share)
-;; Needed for Emacs 26.
-(declare-function with-connection-local-variables "files-x")
;; Needed for Emacs 27.
(defvar lock-file-name-transforms)
(defvar process-file-return-signal-string)
(defvar remote-file-name-inhibit-locks)
-(defvar shell-command-dont-erase-buffer)
-;; Needed for Emacs 28.
(defvar dired-copy-dereference)
+;; Declared in Emacs 30.
+(defvar remote-file-name-access-timeout)
+(defvar remote-file-name-inhibit-delete-by-moving-to-trash)
+
;; `ert-resource-file' was introduced in Emacs 28.1.
(unless (macrop 'ert-resource-file)
(eval-and-compile
@@ -133,7 +134,7 @@ A resource file is in the resource directory as per
(eval-and-compile
;; There is no default value on w32 systems, which could work out
;; of the box.
- (defconst ert-remote-temporary-file-directory
+ (defvar ert-remote-temporary-file-directory
(cond
((getenv "REMOTE_TEMPORARY_FILE_DIRECTORY"))
((eq system-type 'windows-nt) null-device)
@@ -226,7 +227,7 @@ If LOCAL is non-nil, a local file name is returned.
If QUOTED is non-nil, the local part of the file name is quoted.
The temporary file is not created."
(funcall
- (if quoted #'tramp-compat-file-name-quote #'identity)
+ (if quoted #'file-name-quote #'identity)
(expand-file-name
(make-temp-name "tramp-test")
(if local temporary-file-directory ert-remote-temporary-file-directory))))
@@ -262,11 +263,10 @@ is greater than 10.
`should-error' is not handled properly. BODY shall not contain a timeout."
(declare (indent 1) (debug (natnump body)))
`(let* ((tramp-verbose (max (or ,verbose 0) (or tramp-verbose 0)))
- (trace-buffer (tramp-trace-buffer-name tramp-test-vec))
(debug-ignored-errors
(append
- '("^make-symbolic-link not supported$"
- "^error with add-name-to-file")
+ '("\\`make-symbolic-link not supported\\'"
+ "\\`error with add-name-to-file")
debug-ignored-errors))
inhibit-message)
(unwind-protect
@@ -297,16 +297,6 @@ is greater than 10.
(tramp--test-message
"%s %f sec" ,message (float-time (time-subtract nil start))))))
-;; `always' is introduced with Emacs 28.1.
-(defalias 'tramp--test-always
- (if (fboundp 'always)
- #'always
- (lambda (&rest _arguments)
- "Do nothing and return t.
-This function accepts any number of ARGUMENTS, but ignores them.
-Also see `ignore'."
- t)))
-
(ert-deftest tramp-test00-availability ()
"Test availability of Tramp functions."
:expected-result (if (tramp--test-enabled) :passed :failed)
@@ -389,7 +379,7 @@ Also see `ignore'."
(let (tramp-mode)
(should-not (tramp-tramp-file-p "/method:user@host:")))
;; `tramp-ignored-file-name-regexp' suppresses Tramp.
- (let ((tramp-ignored-file-name-regexp "^/method:user@host:"))
+ (let ((tramp-ignored-file-name-regexp "\\`/method:user@host:"))
(should-not (tramp-tramp-file-p "/method:user@host:")))
;; Methods shall be at least two characters, except the
;; default method.
@@ -2451,10 +2441,9 @@ This checks also `file-name-as-directory', `file-name-directory',
;; Check `directory-abbrev-alist' abbreviation.
(let ((directory-abbrev-alist
- `((,(tramp-compat-rx bos (literal home-dir) "/foo")
- . ,(concat home-dir "/f"))
- (,(tramp-compat-rx bos (literal remote-host) "/nowhere")
- . ,(concat remote-host "/nw")))))
+ `((,(rx bos (literal home-dir) "/foo") . ,(concat home-dir "/f"))
+ (,(rx bos (literal remote-host) "/nowhere")
+ . ,(concat remote-host "/nw")))))
(should (equal (abbreviate-file-name (concat home-dir "/foo/bar"))
(concat remote-host-nohop "~/f/bar")))
(should (equal (abbreviate-file-name
@@ -2505,7 +2494,24 @@ This checks also `file-name-as-directory', `file-name-directory',
(expand-file-name
(file-name-nondirectory tmp-name) trash-directory))))
(delete-directory trash-directory 'recursive)
- (should-not (file-exists-p trash-directory)))))))
+ (should-not (file-exists-p trash-directory))))
+
+ ;; Setting `remote-file-name-inhibit-delete-by-moving-to-trash'
+ ;; prevents trashing remote files.
+ (let ((trash-directory (tramp--test-make-temp-name 'local quoted))
+ (delete-by-moving-to-trash t)
+ (remote-file-name-inhibit-delete-by-moving-to-trash t))
+ (make-directory trash-directory)
+ (should-not (file-exists-p tmp-name))
+ (write-region "foo" nil tmp-name)
+ (should (file-exists-p tmp-name))
+ (delete-file tmp-name 'trash)
+ (should-not (file-exists-p tmp-name))
+ (should-not
+ (file-exists-p
+ (expand-file-name (file-name-nondirectory tmp-name) trash-directory)))
+ (delete-directory trash-directory 'recursive)
+ (should-not (file-exists-p trash-directory))))))
(ert-deftest tramp-test08-file-local-copy ()
"Check `file-local-copy'."
@@ -2549,24 +2555,57 @@ This checks also `file-name-as-directory', `file-name-directory',
(with-temp-buffer
(write-region "foo" nil tmp-name)
(let ((point (point)))
- (insert-file-contents tmp-name)
+ (should
+ (equal
+ (insert-file-contents tmp-name)
+ `(,(expand-file-name tmp-name) 3)))
(should (string-equal (buffer-string) "foo"))
(should (= point (point))))
(goto-char (1+ (point)))
(let ((point (point)))
- (insert-file-contents tmp-name)
+ (should
+ (equal
+ (insert-file-contents tmp-name)
+ `(,(expand-file-name tmp-name) 3)))
(should (string-equal (buffer-string) "ffoooo"))
(should (= point (point))))
;; Insert partly.
(let ((point (point)))
- (insert-file-contents tmp-name nil 1 3)
+ (should
+ (equal
+ (insert-file-contents tmp-name nil 1 3)
+ `(,(expand-file-name tmp-name) 2)))
(should (string-equal (buffer-string) "foofoooo"))
(should (= point (point))))
+ (let ((point (point)))
+ (should
+ (equal
+ (insert-file-contents tmp-name nil 2 5)
+ `(,(expand-file-name tmp-name) 1)))
+ (should (string-equal (buffer-string) "fooofoooo"))
+ (should (= point (point))))
;; Replace.
(let ((point (point)))
- (insert-file-contents tmp-name nil nil nil 'replace)
+ ;; 0 characters replaced, because "foo" is already there.
+ (should
+ (equal
+ (insert-file-contents tmp-name nil nil nil 'replace)
+ `(,(expand-file-name tmp-name) 0)))
(should (string-equal (buffer-string) "foo"))
(should (= point (point))))
+ ;; Insert another string.
+ ;; `replace-string-in-region' was introduced in Emacs 28.1.
+ (when (tramp--test-emacs28-p)
+ (let ((point (point)))
+ (with-no-warnings
+ (replace-string-in-region "foo" "bar" (point-min) (point-max)))
+ (goto-char point)
+ (should
+ (equal
+ (insert-file-contents tmp-name nil nil nil 'replace)
+ `(,(expand-file-name tmp-name) 3)))
+ (should (string-equal (buffer-string) "foo"))
+ (should (= point (point)))))
;; Error case.
(delete-file tmp-name)
(should-error
@@ -2634,17 +2673,14 @@ This checks also `file-name-as-directory', `file-name-directory',
(should (string-equal (buffer-string) "foo")))
;; Write empty string. Used for creation of temporary files.
- ;; Since Emacs 27.1.
- (when (fboundp 'make-empty-file)
- (with-no-warnings
- (should-error
- (make-empty-file tmp-name)
- :type 'file-already-exists)
- (delete-file tmp-name)
- (make-empty-file tmp-name)
- (with-temp-buffer
- (insert-file-contents tmp-name)
- (should (string-equal (buffer-string) "")))))
+ (should-error
+ (make-empty-file tmp-name)
+ :type 'file-already-exists)
+ (delete-file tmp-name)
+ (make-empty-file tmp-name)
+ (with-temp-buffer
+ (insert-file-contents tmp-name)
+ (should (string-equal (buffer-string) "")))
;; Write partly.
(with-temp-buffer
@@ -2666,18 +2702,17 @@ This checks also `file-name-as-directory', `file-name-directory',
(string-match-p
(if (and (null noninteractive)
(or (eq visit t) (null visit) (stringp visit)))
- (tramp-compat-rx
- bol "Wrote " (literal tmp-name) "\n" eos)
+ (rx bol "Wrote " (literal tmp-name) "\n" eos)
(rx bos))
tramp--test-messages))))))
- ;; We do not test lockname here. See
+ ;; We do not test the lock file here. See
;; `tramp-test39-make-lock-file-name'.
;; Do not overwrite if excluded.
- (cl-letf (((symbol-function #'y-or-n-p) #'tramp--test-always)
+ (cl-letf (((symbol-function #'y-or-n-p) #'tramp-compat-always)
;; Ange-FTP.
- ((symbol-function #'yes-or-no-p) #'tramp--test-always))
+ ((symbol-function #'yes-or-no-p) #'tramp-compat-always))
(write-region "foo" nil tmp-name nil nil nil 'mustbenew))
(should-error
(cl-letf (((symbol-function #'y-or-n-p) #'ignore)
@@ -2710,8 +2745,6 @@ This checks also `file-name-as-directory', `file-name-directory',
"Check that `file-precious-flag' is respected with Tramp in use."
(skip-unless (tramp--test-enabled))
(skip-unless (tramp--test-sh-p))
- ;; The bug is fixed in Emacs 27.1.
- (skip-unless (tramp--test-emacs27-p))
(let* ((tmp-name (tramp--test-make-temp-name))
(inhibit-message t)
@@ -2794,10 +2827,7 @@ This checks also `file-name-as-directory', `file-name-directory',
"Check `copy-file'."
(skip-unless (tramp--test-enabled))
- ;; `filename-non-special' has been fixed in Emacs 27.1, see Bug#29579.
- (dolist (quoted
- (if (and (tramp--test-expensive-test-p) (tramp--test-emacs27-p))
- '(nil t) '(nil)))
+ (dolist (quoted (if (tramp--test-expensive-test-p) '(nil t) '(nil)))
(let ((tmp-name1 (tramp--test-make-temp-name nil quoted))
(tmp-name2 (tramp--test-make-temp-name nil quoted))
(tmp-name3 (tramp--test-make-temp-name 'local quoted)))
@@ -2906,10 +2936,7 @@ This checks also `file-name-as-directory', `file-name-directory',
"Check `rename-file'."
(skip-unless (tramp--test-enabled))
- ;; `filename-non-special' has been fixed in Emacs 27.1, see Bug#29579.
- (dolist (quoted
- (if (and (tramp--test-expensive-test-p) (tramp--test-emacs27-p))
- '(nil t) '(nil)))
+ (dolist (quoted (if (tramp--test-expensive-test-p) '(nil t) '(nil)))
(let ((tmp-name1 (tramp--test-make-temp-name nil quoted))
(tmp-name2 (tramp--test-make-temp-name nil quoted))
(tmp-name3 (tramp--test-make-temp-name 'local quoted)))
@@ -3025,6 +3052,7 @@ This checks also `file-name-as-directory', `file-name-directory',
This tests also `file-directory-p' and `file-accessible-directory-p'."
(skip-unless (tramp--test-enabled))
+ ;; Since Emacs 29.1, `make-directory' has defined return values.
(dolist (quoted (if (tramp--test-expensive-test-p) '(nil t) '(nil)))
(let* ((tmp-name1 (tramp--test-make-temp-name nil quoted))
(tmp-name2 (expand-file-name "foo/bar" tmp-name1))
@@ -3033,7 +3061,9 @@ This tests also `file-directory-p' and `file-accessible-directory-p'."
(unwind-protect
(progn
(with-file-modes unusual-file-mode-1
- (make-directory tmp-name1))
+ (if (tramp--test-emacs29-p)
+ (should-not (make-directory tmp-name1))
+ (make-directory tmp-name1)))
(should-error
(make-directory tmp-name1)
:type 'file-already-exists)
@@ -3046,15 +3076,19 @@ This tests also `file-directory-p' and `file-accessible-directory-p'."
(make-directory tmp-name2)
:type 'file-error)
(with-file-modes unusual-file-mode-2
- (make-directory tmp-name2 'parents))
+ (if (tramp--test-emacs29-p)
+ (should-not (make-directory tmp-name2 'parents))
+ (make-directory tmp-name2 'parents)))
(should (file-directory-p tmp-name2))
(should (file-accessible-directory-p tmp-name2))
(when (tramp--test-supports-set-file-modes-p)
(should (equal (format "%#o" unusual-file-mode-2)
(format "%#o" (file-modes tmp-name2)))))
;; If PARENTS is non-nil, `make-directory' shall not
- ;; signal an error when DIR exists already.
- (make-directory tmp-name2 'parents))
+ ;; signal an error when DIR exists already. It returns t.
+ (if (tramp--test-emacs29-p)
+ (should (make-directory tmp-name2 'parents))
+ (make-directory tmp-name2 'parents)))
;; Cleanup.
(ignore-errors (delete-directory tmp-name1 'recursive))))))
@@ -3086,13 +3120,11 @@ This tests also `file-directory-p' and `file-accessible-directory-p'."
(delete-directory tmp-name1 'recursive)
(should-not (file-directory-p tmp-name1))
- ;; Trashing directories works only since Emacs 27.1. It doesn't
- ;; work when `system-move-file-to-trash' is defined (on MS
- ;; Windows and macOS), for encrypted remote directories and for
- ;; ange-ftp.
+ ;; Trashing directories doesn't work when
+ ;; `system-move-file-to-trash' is defined (on MS Windows and
+ ;; macOS), for encrypted remote directories and for ange-ftp.
(when (and (not (fboundp 'system-move-file-to-trash))
- (not (tramp--test-crypt-p)) (not (tramp--test-ftp-p))
- (tramp--test-emacs27-p))
+ (not (tramp--test-crypt-p)) (not (tramp--test-ftp-p)))
(let ((trash-directory (tramp--test-make-temp-name 'local quoted))
(delete-by-moving-to-trash t))
(make-directory trash-directory)
@@ -3133,7 +3165,23 @@ This tests also `file-directory-p' and `file-accessible-directory-p'."
"%s/%s/%s/bla" trash-directory (file-name-nondirectory tmp-name1)
(file-name-nondirectory tmp-name2))))
(delete-directory trash-directory 'recursive)
- (should-not (file-exists-p trash-directory)))))))
+ (should-not (file-exists-p trash-directory))))
+
+ ;; Setting `remote-file-name-inhibit-delete-by-moving-to-trash'
+ ;; prevents trashing remote files.
+ (let ((trash-directory (tramp--test-make-temp-name 'local quoted))
+ (delete-by-moving-to-trash t)
+ (remote-file-name-inhibit-delete-by-moving-to-trash t))
+ (make-directory trash-directory)
+ (make-directory tmp-name1)
+ (should (file-directory-p tmp-name1))
+ (delete-directory tmp-name1 nil 'trash)
+ (should-not (file-exists-p tmp-name1))
+ (should-not
+ (file-exists-p
+ (expand-file-name (file-name-nondirectory tmp-name1) trash-directory)))
+ (delete-directory trash-directory 'recursive)
+ (should-not (file-exists-p trash-directory))))))
(ert-deftest tramp-test15-copy-directory ()
"Check `copy-directory'."
@@ -3361,9 +3409,6 @@ This tests also `file-directory-p' and `file-accessible-directory-p'."
;; (this is performed by `dired'). If FULL is nil, it shows just
;; one file. So we refrain from testing.
(skip-unless (not (tramp--test-ange-ftp-p)))
- ;; `insert-directory' of encrypted remote directories works only
- ;; since Emacs 27.1.
- (skip-unless (or (not (tramp--test-crypt-p)) (tramp--test-emacs27-p)))
(dolist (quoted (if (tramp--test-expensive-test-p) '(nil t) '(nil)))
(let* ((tmp-name1
@@ -3381,26 +3426,23 @@ This tests also `file-directory-p' and `file-accessible-directory-p'."
(with-temp-buffer
(insert-directory tmp-name1 nil)
(goto-char (point-min))
- (should (looking-at-p (tramp-compat-rx (literal tmp-name1)))))
+ (should (looking-at-p (rx (literal tmp-name1)))))
(with-temp-buffer
(insert-directory (file-name-as-directory tmp-name1) nil)
(goto-char (point-min))
(should
- (looking-at-p
- (tramp-compat-rx (literal (file-name-as-directory tmp-name1))))))
+ (looking-at-p (rx (literal (file-name-as-directory tmp-name1))))))
(with-temp-buffer
(insert-directory tmp-name1 "-al")
(goto-char (point-min))
(should
- (looking-at-p
- (tramp-compat-rx bol (+ nonl) blank (literal tmp-name1) eol))))
+ (looking-at-p (rx bol (+ nonl) blank (literal tmp-name1) eol))))
(with-temp-buffer
(insert-directory (file-name-as-directory tmp-name1) "-al")
(goto-char (point-min))
(should
(looking-at-p
- (tramp-compat-rx
- bol (+ nonl) blank (literal tmp-name1) "/" eol))))
+ (rx bol (+ nonl) blank (literal tmp-name1) "/" eol))))
(with-temp-buffer
(insert-directory
(file-name-as-directory tmp-name1) "-al" nil 'full-directory-p)
@@ -3410,12 +3452,12 @@ This tests also `file-directory-p' and `file-accessible-directory-p'."
(rx-to-string
`(:
;; There might be a summary line.
- (? "total" (+ nonl) (+ digit) (? blank)
+ (? (* blank) "total" (+ nonl) (+ digit) (? blank)
(? (any "EGKMPTYZk")) (? "i") (? "B") "\n")
;; We don't know in which order ".", ".." and "foo" appear.
(= ,(length (directory-files tmp-name1))
(+ nonl) blank
- (regexp ,(regexp-opt (directory-files tmp-name1)))
+ (| . ,(directory-files tmp-name1))
(? " ->" (+ nonl)) "\n"))))))
;; Check error cases.
@@ -3451,6 +3493,8 @@ This tests also `file-directory-p' and `file-accessible-directory-p'."
(skip-unless (not (tramp--test-rsync-p)))
;; Wildcards are not supported in tramp-crypt.el.
(skip-unless (not (tramp--test-crypt-p)))
+ ;; Wildcards are not supported with "docker cp ..." or "podman cp ...".
+ (skip-unless (not (tramp--test-container-oob-p)))
(dolist (quoted (if (tramp--test-expensive-test-p) '(nil t) '(nil)))
(let* ((tmp-name1
@@ -3461,7 +3505,7 @@ This tests also `file-directory-p' and `file-accessible-directory-p'."
(tmp-name4 (expand-file-name "bar" tmp-name2))
(ert-remote-temporary-file-directory
(funcall
- (if quoted #'tramp-compat-file-name-quote #'identity)
+ (if quoted #'file-name-quote #'identity)
ert-remote-temporary-file-directory))
buffer)
(unwind-protect
@@ -3483,15 +3527,15 @@ This tests also `file-directory-p' and `file-accessible-directory-p'."
"tramp-test*" ert-remote-temporary-file-directory)))
(goto-char (point-min))
(should
- (re-search-forward
- (tramp-compat-rx
+ (search-forward-regexp
+ (rx
(literal
(file-relative-name
tmp-name1 ert-remote-temporary-file-directory)))))
(goto-char (point-min))
(should
- (re-search-forward
- (tramp-compat-rx
+ (search-forward-regexp
+ (rx
(literal
(file-relative-name
tmp-name2 ert-remote-temporary-file-directory))))))
@@ -3505,15 +3549,15 @@ This tests also `file-directory-p' and `file-accessible-directory-p'."
"tramp-test*/*" ert-remote-temporary-file-directory)))
(goto-char (point-min))
(should
- (re-search-forward
- (tramp-compat-rx
+ (search-forward-regexp
+ (rx
(literal
(file-relative-name
tmp-name3 ert-remote-temporary-file-directory)))))
(goto-char (point-min))
(should
- (re-search-forward
- (tramp-compat-rx
+ (search-forward-regexp
+ (rx
(literal
(file-relative-name
tmp-name4
@@ -3535,15 +3579,15 @@ This tests also `file-directory-p' and `file-accessible-directory-p'."
"tramp-test*/*" ert-remote-temporary-file-directory)))
(goto-char (point-min))
(should
- (re-search-forward
- (tramp-compat-rx
+ (search-forward-regexp
+ (rx
(literal
(file-relative-name
tmp-name3 ert-remote-temporary-file-directory)))))
(goto-char (point-min))
(should
- (re-search-forward
- (tramp-compat-rx
+ (search-forward-regexp
+ (rx
(literal
(file-relative-name
tmp-name4
@@ -3636,6 +3680,18 @@ This tests also `access-file', `file-readable-p',
attr)
(unwind-protect
(progn
+ (write-region "foo" nil tmp-name1)
+ ;; `access-file' returns nil in case of success.
+ (should-not (access-file tmp-name1 "error"))
+ ;; `access-file' could use a timeout.
+ (let ((remote-file-name-access-timeout 1))
+ (cl-letf (((symbol-function #'file-exists-p)
+ (lambda (_filename) (sleep-for 5))))
+ (should-error
+ (access-file tmp-name1 "error")
+ :type 'file-error)))
+ (delete-file tmp-name1)
+
;; A sticky bit could damage the `file-ownership-preserved-p' test.
(when
(and test-file-ownership-preserved-p
@@ -3716,7 +3772,7 @@ This tests also `access-file', `file-readable-p',
(should
(string-equal
(funcall
- (if quoted #'tramp-compat-file-name-quote #'identity)
+ (if quoted #'file-name-quote #'identity)
(file-attribute-type attr))
(file-remote-p (file-truename tmp-name1) 'localname)))
(delete-file tmp-name2))
@@ -3761,15 +3817,24 @@ This tests also `access-file', `file-readable-p',
(ignore-errors (delete-file tmp-name1))
(ignore-errors (delete-file tmp-name2))))))
+(defun tramp--test-set-ert-test-documentation (test command)
+ "Set the documentation string for a derived test.
+The test is derived from TEST and COMMAND."
+ (let ((test-doc
+ (split-string (ert-test-documentation (get test 'ert--test)) "\n")))
+ ;; The first line must be extended.
+ (setcar
+ test-doc (format "%s Use the \"%s\" command." (car test-doc) command))
+ (setf (ert-test-documentation
+ (get (intern (format "%s-with-%s" test command)) 'ert--test))
+ (string-join test-doc "\n"))))
+
(defmacro tramp--test-deftest-with-stat (test)
"Define ert `TEST-with-stat'."
(declare (indent 1))
`(ert-deftest ,(intern (concat (symbol-name test) "-with-stat")) ()
- ;; This is the docstring. However, it must be expanded to a
- ;; string inside the macro. No idea.
- ;; (concat (ert-test-documentation (get ',test 'ert--test))
- ;; "\nUse the \"stat\" command.")
:tags '(:expensive-test)
+ (tramp--test-set-ert-test-documentation ',test "stat")
(skip-unless (tramp--test-enabled))
(skip-unless (tramp--test-sh-p))
(skip-unless (tramp-get-remote-stat tramp-test-vec))
@@ -3780,9 +3845,6 @@ This tests also `access-file', `file-readable-p',
(cons '(nil "perl" nil)
tramp-connection-properties)))
(progn
- ;; `ert-test-result-duration' exists since Emacs 27. It
- ;; doesn't hurt to call it unconditionally, because
- ;; `skip-unless' hides the error.
(skip-unless (< (ert-test-result-duration result) 300))
(funcall (ert-test-body ert-test)))
(ert-skip (format "Test `%s' must run before" ',test)))))
@@ -3791,11 +3853,8 @@ This tests also `access-file', `file-readable-p',
"Define ert `TEST-with-perl'."
(declare (indent 1))
`(ert-deftest ,(intern (concat (symbol-name test) "-with-perl")) ()
- ;; This is the docstring. However, it must be expanded to a
- ;; string inside the macro. No idea.
- ;; (concat (ert-test-documentation (get ',test 'ert--test))
- ;; "\nUse the \"perl\" command.")
:tags '(:expensive-test)
+ (tramp--test-set-ert-test-documentation ',test "perl")
(skip-unless (tramp--test-enabled))
(skip-unless (tramp--test-sh-p))
(skip-unless (tramp-get-remote-perl tramp-test-vec))
@@ -3811,9 +3870,6 @@ This tests also `access-file', `file-readable-p',
(nil "id" nil))
tramp-connection-properties)))
(progn
- ;; `ert-test-result-duration' exists since Emacs 27. It
- ;; doesn't hurt to call it unconditionally, because
- ;; `skip-unless' hides the error.
(skip-unless (< (ert-test-result-duration result) 300))
(funcall (ert-test-body ert-test)))
(ert-skip (format "Test `%s' must run before" ',test)))))
@@ -3822,11 +3878,8 @@ This tests also `access-file', `file-readable-p',
"Define ert `TEST-with-ls'."
(declare (indent 1))
`(ert-deftest ,(intern (concat (symbol-name test) "-with-ls")) ()
- ;; This is the docstring. However, it must be expanded to a
- ;; string inside the macro. No idea.
- ;; (concat (ert-test-documentation (get ',test 'ert--test))
- ;; "\nUse the \"ls\" command.")
:tags '(:expensive-test)
+ (tramp--test-set-ert-test-documentation ',test "ls")
(skip-unless (tramp--test-enabled))
(skip-unless (tramp--test-sh-p))
(if-let ((default-directory ert-remote-temporary-file-directory)
@@ -3840,9 +3893,6 @@ This tests also `access-file', `file-readable-p',
(nil "readlink" nil))
tramp-connection-properties)))
(progn
- ;; `ert-test-result-duration' exists since Emacs 27. It
- ;; doesn't hurt to call it unconditionally, because
- ;; `skip-unless' hides the error.
(skip-unless (< (ert-test-result-duration result) 300))
(funcall (ert-test-body ert-test)))
(ert-skip (format "Test `%s' must run before" ',test)))))
@@ -3878,9 +3928,9 @@ They might differ only in time attributes or directory size."
;; few seconds). We use a test start time minus 10 seconds, in
;; order to compensate a possible timestamp resolution higher than
;; a second on the remote machine.
- (when (or (tramp-compat-time-equal-p
+ (when (or (time-equal-p
(file-attribute-modification-time attr1) tramp-time-dont-know)
- (tramp-compat-time-equal-p
+ (time-equal-p
(file-attribute-modification-time attr2) tramp-time-dont-know))
(setcar (nthcdr 5 attr1) tramp-time-dont-know)
(setcar (nthcdr 5 attr2) tramp-time-dont-know))
@@ -3891,9 +3941,9 @@ They might differ only in time attributes or directory size."
(float-time (file-attribute-modification-time attr2)))
(setcar (nthcdr 5 attr2) tramp-time-dont-know))
;; Status change time. Ditto.
- (when (or (tramp-compat-time-equal-p
+ (when (or (time-equal-p
(file-attribute-status-change-time attr1) tramp-time-dont-know)
- (tramp-compat-time-equal-p
+ (time-equal-p
(file-attribute-status-change-time attr2) tramp-time-dont-know))
(setcar (nthcdr 6 attr1) tramp-time-dont-know)
(setcar (nthcdr 6 attr2) tramp-time-dont-know))
@@ -4032,7 +4082,7 @@ This tests also `file-executable-p', `file-writable-p' and `set-file-modes'."
(should
(string-equal
(funcall
- (if quoted #'tramp-compat-file-name-unquote #'identity)
+ (if quoted #'file-name-unquote #'identity)
(file-remote-p tmp-name1 'localname))
(file-symlink-p tmp-name2)))
;; Both report the modes of `tmp-name1'.
@@ -4105,7 +4155,7 @@ This tests also `make-symbolic-link', `file-truename' and `add-name-to-file'."
(should
(string-equal
(funcall
- (if quoted #'tramp-compat-file-name-unquote #'identity)
+ (if quoted #'file-name-unquote #'identity)
(file-remote-p tmp-name1 'localname))
(file-symlink-p tmp-name2)))
(when (tramp--test-expensive-test-p)
@@ -4118,19 +4168,19 @@ This tests also `make-symbolic-link', `file-truename' and `add-name-to-file'."
(should-error
(make-symbolic-link tmp-name1 tmp-name2 0)
:type 'file-already-exists)))
- (cl-letf (((symbol-function #'yes-or-no-p) #'tramp--test-always))
+ (cl-letf (((symbol-function #'yes-or-no-p) #'tramp-compat-always))
(make-symbolic-link tmp-name1 tmp-name2 0)
(should
(string-equal
(funcall
- (if quoted #'tramp-compat-file-name-unquote #'identity)
+ (if quoted #'file-name-unquote #'identity)
(file-remote-p tmp-name1 'localname))
(file-symlink-p tmp-name2))))
(make-symbolic-link tmp-name1 tmp-name2 'ok-if-already-exists)
(should
(string-equal
(funcall
- (if quoted #'tramp-compat-file-name-unquote #'identity)
+ (if quoted #'file-name-unquote #'identity)
(file-remote-p tmp-name1 'localname))
(file-symlink-p tmp-name2)))
;; If we use the local part of `tmp-name1', it shall still work.
@@ -4140,7 +4190,7 @@ This tests also `make-symbolic-link', `file-truename' and `add-name-to-file'."
(should
(string-equal
(funcall
- (if quoted #'tramp-compat-file-name-unquote #'identity)
+ (if quoted #'file-name-unquote #'identity)
(file-remote-p tmp-name1 'localname))
(file-symlink-p tmp-name2)))
;; `tmp-name3' is a local file name. Therefore, the link
@@ -4162,7 +4212,7 @@ This tests also `make-symbolic-link', `file-truename' and `add-name-to-file'."
(should
(string-equal
(funcall
- (if quoted #'tramp-compat-file-name-unquote #'identity)
+ (if quoted #'file-name-unquote #'identity)
(file-remote-p tmp-name1 'localname))
(file-symlink-p tmp-name5)))
;; Check, that files in symlinked directories still work.
@@ -4198,7 +4248,7 @@ This tests also `make-symbolic-link', `file-truename' and `add-name-to-file'."
(should-error
(add-name-to-file tmp-name1 tmp-name2 0)
:type 'file-already-exists))
- (cl-letf (((symbol-function #'yes-or-no-p) #'tramp--test-always))
+ (cl-letf (((symbol-function #'yes-or-no-p) #'tramp-compat-always))
(add-name-to-file tmp-name1 tmp-name2 0)
(should (file-regular-p tmp-name2)))
(add-name-to-file tmp-name1 tmp-name2 'ok-if-already-exists)
@@ -4256,16 +4306,14 @@ This tests also `make-symbolic-link', `file-truename' and `add-name-to-file'."
"/[penguin/motd]" "/penguin:motd:")))
(delete-file tmp-name2)
(make-symbolic-link
- (funcall
- (if quoted #'tramp-compat-file-name-unquote #'identity) penguin)
+ (funcall (if quoted #'file-name-unquote #'identity) penguin)
tmp-name2)
(should (file-symlink-p tmp-name2))
(should-not (file-regular-p tmp-name2))
(should
(string-equal
(file-truename tmp-name2)
- (tramp-compat-file-name-quote
- (concat (file-remote-p tmp-name2) penguin)))))
+ (file-name-quote (concat (file-remote-p tmp-name2) penguin)))))
;; `tmp-name3' is a local file name.
;; `make-symbolic-link' might not be permitted on w32 systems.
(unless (tramp--test-windows-nt-p)
@@ -4278,7 +4326,7 @@ This tests also `make-symbolic-link', `file-truename' and `add-name-to-file'."
(should
(string-equal
(file-truename tmp-name1)
- (tramp-compat-file-name-unquote (file-truename tmp-name3))))))
+ (file-name-unquote (file-truename tmp-name3))))))
;; Cleanup.
(ignore-errors
@@ -4365,7 +4413,7 @@ This tests also `make-symbolic-link', `file-truename' and `add-name-to-file'."
(let* ((dir1
(directory-file-name
(funcall
- (if quoted #'tramp-compat-file-name-quote #'identity)
+ (if quoted #'file-name-quote #'identity)
ert-remote-temporary-file-directory)))
(dir2 (file-name-as-directory dir1)))
(should (string-equal (file-truename dir1) (expand-file-name dir1)))
@@ -4394,12 +4442,12 @@ This tests also `make-symbolic-link', `file-truename' and `add-name-to-file'."
(skip-unless (set-file-times tmp-name1 (seconds-to-time 60)))
;; Dumb remote shells without perl(1) or stat(1) are not
;; able to return the date correctly. They say "don't know".
- (unless (tramp-compat-time-equal-p
+ (unless (time-equal-p
(file-attribute-modification-time
(file-attributes tmp-name1))
tramp-time-dont-know)
(should
- (tramp-compat-time-equal-p
+ (time-equal-p
(file-attribute-modification-time (file-attributes tmp-name1))
(seconds-to-time 60)))
;; Setting the time for not existing files shall fail.
@@ -4418,7 +4466,7 @@ This tests also `make-symbolic-link', `file-truename' and `add-name-to-file'."
(with-no-warnings
(set-file-times tmp-name1 (seconds-to-time 60) 'nofollow)
(should
- (tramp-compat-time-equal-p
+ (time-equal-p
(file-attribute-modification-time
(file-attributes tmp-name1))
(seconds-to-time 60)))))))
@@ -4464,10 +4512,7 @@ This tests also `make-symbolic-link', `file-truename' and `add-name-to-file'."
(skip-unless (file-acl ert-remote-temporary-file-directory))
(skip-unless (not (tramp--test-crypt-p)))
- ;; `filename-non-special' has been fixed in Emacs 27.1, see Bug#29579.
- (dolist (quoted
- (if (and (tramp--test-expensive-test-p) (tramp--test-emacs27-p))
- '(nil t) '(nil)))
+ (dolist (quoted (if (tramp--test-expensive-test-p) '(nil t) '(nil)))
(let ((tmp-name1 (tramp--test-make-temp-name nil quoted))
(tmp-name2 (tramp--test-make-temp-name nil quoted))
(tmp-name3 (tramp--test-make-temp-name 'local quoted)))
@@ -4544,10 +4589,7 @@ This tests also `make-symbolic-link', `file-truename' and `add-name-to-file'."
'(nil nil nil nil))))
(skip-unless (not (tramp--test-crypt-p)))
- ;; `filename-non-special' has been fixed in Emacs 27.1, see Bug#29579.
- (dolist (quoted
- (if (and (tramp--test-expensive-test-p) (tramp--test-emacs27-p))
- '(nil t) '(nil)))
+ (dolist (quoted (if (tramp--test-expensive-test-p) '(nil t) '(nil)))
(let ((tmp-name1 (tramp--test-make-temp-name nil quoted))
(tmp-name2 (tramp--test-make-temp-name nil quoted))
(tmp-name3 (tramp--test-make-temp-name 'local quoted)))
@@ -4682,57 +4724,55 @@ This tests also `make-symbolic-link', `file-truename' and `add-name-to-file'."
"Check `file-name-completion' and `file-name-all-completions'."
(skip-unless (tramp--test-enabled))
- ;; Method and host name in completion mode. This kind of completion
- ;; does not work on MS Windows.
- (unless (memq system-type '(cygwin windows-nt))
- (let ((tramp-fuse-remove-hidden-files t)
- (method (file-remote-p ert-remote-temporary-file-directory 'method))
- (host (file-remote-p ert-remote-temporary-file-directory 'host))
- (orig-syntax tramp-syntax)
- (minibuffer-completing-file-name t))
- (when (and (stringp host) (string-match tramp-host-with-port-regexp host))
- (setq host (match-string 1 host)))
+ ;; Method and host name in completion mode.
+ (let ((tramp-fuse-remove-hidden-files t)
+ (method (file-remote-p ert-remote-temporary-file-directory 'method))
+ (host (file-remote-p ert-remote-temporary-file-directory 'host))
+ (orig-syntax tramp-syntax)
+ (minibuffer-completing-file-name t))
+ (when (and (stringp host) (string-match tramp-host-with-port-regexp host))
+ (setq host (match-string 1 host)))
- (unwind-protect
- (dolist (syntax (if (tramp--test-expensive-test-p)
- (tramp-syntax-values) `(,orig-syntax)))
- (tramp-change-syntax syntax)
- ;; This has cleaned up all connection data, which are used
- ;; for completion. We must refill the cache.
- (tramp-set-connection-property tramp-test-vec "property" nil)
-
- (let (;; This is needed for the `separate' syntax.
- (prefix-format (substring tramp-prefix-format 1))
- ;; This is needed for the IPv6 host name syntax.
- (ipv6-prefix
- (and (string-match-p tramp-ipv6-regexp host)
- tramp-prefix-ipv6-format))
- (ipv6-postfix
- (and (string-match-p tramp-ipv6-regexp host)
- tramp-postfix-ipv6-format)))
- ;; Complete method name.
- (unless (or (tramp-string-empty-or-nil-p method)
- (string-empty-p tramp-method-regexp))
- (should
- (member
- (concat prefix-format method tramp-postfix-method-format)
- (file-name-all-completions
- (concat prefix-format (substring method 0 1)) "/"))))
- ;; Complete host name.
- (unless (or (tramp-string-empty-or-nil-p method)
- (string-empty-p tramp-method-regexp)
- (tramp-string-empty-or-nil-p host))
- (should
- (member
- (concat
- prefix-format method tramp-postfix-method-format
- ipv6-prefix host ipv6-postfix tramp-postfix-host-format)
- (file-name-all-completions
- (concat prefix-format method tramp-postfix-method-format)
- "/"))))))
+ (unwind-protect
+ (dolist (syntax (if (tramp--test-expensive-test-p)
+ (tramp-syntax-values) `(,orig-syntax)))
+ (tramp-change-syntax syntax)
+ ;; This has cleaned up all connection data, which are used
+ ;; for completion. We must refill the cache.
+ (tramp-set-connection-property tramp-test-vec "property" nil)
- ;; Cleanup.
- (tramp-change-syntax orig-syntax))))
+ (let (;; This is needed for the `separate' syntax.
+ (prefix-format (substring tramp-prefix-format 1))
+ ;; This is needed for the IPv6 host name syntax.
+ (ipv6-prefix
+ (and (string-match-p tramp-ipv6-regexp host)
+ tramp-prefix-ipv6-format))
+ (ipv6-postfix
+ (and (string-match-p tramp-ipv6-regexp host)
+ tramp-postfix-ipv6-format)))
+ ;; Complete method name.
+ (unless (or (tramp-string-empty-or-nil-p method)
+ (string-empty-p tramp-method-regexp))
+ (should
+ (member
+ (concat prefix-format method tramp-postfix-method-format)
+ (file-name-all-completions
+ (concat prefix-format (substring method 0 1)) "/"))))
+ ;; Complete host name.
+ (unless (or (tramp-string-empty-or-nil-p method)
+ (string-empty-p tramp-method-regexp)
+ (tramp-string-empty-or-nil-p host))
+ (should
+ (member
+ (concat
+ prefix-format method tramp-postfix-method-format
+ ipv6-prefix host ipv6-postfix tramp-postfix-host-format)
+ (file-name-all-completions
+ (concat prefix-format method tramp-postfix-method-format)
+ "/"))))))
+
+ ;; Cleanup.
+ (tramp-change-syntax orig-syntax)))
(dolist (non-essential '(nil t))
(dolist (quoted (if (tramp--test-expensive-test-p) '(nil t) '(nil)))
@@ -4814,9 +4854,7 @@ This tests also `make-symbolic-link', `file-truename' and `add-name-to-file'."
;; and Bug#60505.
(ert-deftest tramp-test26-interactive-file-name-completion ()
"Check interactive completion with different `completion-styles'."
- ;; Method, user and host name in completion mode. This kind of
- ;; completion does not work on MS Windows.
- (skip-unless (not (memq system-type '(cygwin windows-nt))))
+ ;; Method, user and host name in completion mode.
(tramp-cleanup-connection tramp-test-vec nil 'keep-password)
(let ((method (file-remote-p ert-remote-temporary-file-directory 'method))
@@ -4940,11 +4978,11 @@ This tests also `make-symbolic-link', `file-truename' and `add-name-to-file'."
(if (or (not (get-buffer "*Completions*"))
(string-match-p
(if (string-empty-p tramp-method-regexp)
- (tramp-compat-rx
+ (rx
(| (regexp tramp-postfix-user-regexp)
(regexp tramp-postfix-host-regexp))
eos)
- (tramp-compat-rx
+ (rx
(| (regexp tramp-postfix-method-regexp)
(regexp tramp-postfix-user-regexp)
(regexp tramp-postfix-host-regexp))
@@ -4967,10 +5005,10 @@ This tests also `make-symbolic-link', `file-truename' and `add-name-to-file'."
;; We must remove leading `default-directory'.
(goto-char (point-min))
(let ((inhibit-read-only t))
- (while (re-search-forward "//" nil 'noerror)
+ (while (search-forward-regexp "//" nil 'noerror)
(delete-region (line-beginning-position) (point))))
(goto-char (point-min))
- (re-search-forward
+ (search-forward-regexp
(rx bol (0+ nonl)
(any "Pp") "ossible completions"
(0+ nonl) eol))
@@ -5082,7 +5120,8 @@ This tests also `make-symbolic-link', `file-truename' and `add-name-to-file'."
(if (bufferp destination) destination (current-buffer))
;; "ls" could produce colorized output.
(goto-char (point-min))
- (while (re-search-forward ansi-color-control-seq-regexp nil t)
+ (while (search-forward-regexp
+ ansi-color-control-seq-regexp nil t)
(replace-match "" nil nil))
(should
(string-equal (if destination (format "%s\n" fnnd) "")
@@ -5096,7 +5135,8 @@ This tests also `make-symbolic-link', `file-truename' and `add-name-to-file'."
(if (bufferp destination) destination (current-buffer))
;; "ls" could produce colorized output.
(goto-char (point-min))
- (while (re-search-forward ansi-color-control-seq-regexp nil t)
+ (while (search-forward-regexp
+ ansi-color-control-seq-regexp nil t)
(replace-match "" nil nil))
(should
(string-equal
@@ -5120,8 +5160,8 @@ This tests also `make-symbolic-link', `file-truename' and `add-name-to-file'."
(should-not (get-buffer-window (current-buffer) t))
(delete-file tmp-name)))
- ;; Check remote and local DESTNATION file. This isn't
- ;; implemented yet ina all file name handler backends.
+ ;; Check remote and local DESTINATION file. This isn't
+ ;; implemented yet in all file name handler backends.
;; (dolist (local '(nil t))
;; (setq tmp-name (tramp--test-make-temp-name local quoted))
;; (should
@@ -5241,9 +5281,10 @@ This tests also `make-symbolic-link', `file-truename' and `add-name-to-file'."
(unless t
(unwind-protect
(with-temp-buffer
- (setq command '("cat")
- proc
- (apply #'start-file-process "test4" (current-buffer) command))
+ (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))
@@ -5263,12 +5304,7 @@ This tests also `make-symbolic-link', `file-truename' and `add-name-to-file'."
;; Process connection type.
(when (and (tramp--test-sh-p)
(not (tramp-direct-async-process-p))
- ;; `executable-find' has changed the number of
- ;; parameters in Emacs 27.1, so we use `apply' for
- ;; older Emacsen.
- (ignore-errors
- (with-no-warnings
- (apply #'executable-find '("hexdump" remote)))))
+ (executable-find "hexdump" 'remote))
(dolist (process-connection-type '(nil pipe t pty))
(unwind-protect
(with-temp-buffer
@@ -5323,33 +5359,29 @@ This tests also `make-symbolic-link', `file-truename' and `add-name-to-file'."
"Define ert test `TEST-direct-async' for direct async processes.
If UNSTABLE is non-nil, the test is tagged as `:unstable'."
(declare (indent 1))
- ;; `make-process' supports file name handlers since Emacs 27. We
- ;; cannot use `tramp--test-always' during compilation of the macro.
- (when (let ((file-name-handler-alist '(("" . (lambda (&rest _) t)))))
- (ignore-errors (make-process :name "" :command "" :file-handler t)))
- `(ert-deftest ,(intern (concat (symbol-name test) "-direct-async")) ()
- ;; This is the docstring. However, it must be expanded to a
- ;; string inside the macro. No idea.
- ;; (concat (ert-test-documentation (get ',test 'ert--test))
- ;; "\nUse direct async process.")
- :tags (append '(:expensive-test :tramp-asynchronous-processes)
- (and ,unstable '(:unstable)))
- (skip-unless (tramp--test-enabled))
- (let ((default-directory ert-remote-temporary-file-directory)
- (ert-test (ert-get-test ',test))
- (tramp-connection-properties
- (cons '(nil "direct-async-process" t)
- tramp-connection-properties)))
- (skip-unless (tramp-direct-async-process-p))
- ;; We do expect an established connection already,
- ;; `file-truename' does it by side-effect. Suppress
- ;; `tramp--test-enabled', in order to keep the connection.
- ;; Suppress "Process ... finished" messages.
- (cl-letf (((symbol-function #'tramp--test-enabled) #'tramp--test-always)
- ((symbol-function #'internal-default-process-sentinel)
- #'ignore))
- (file-truename ert-remote-temporary-file-directory)
- (funcall (ert-test-body ert-test)))))))
+ `(ert-deftest ,(intern (concat (symbol-name test) "-direct-async")) ()
+ ;; This is the docstring. However, it must be expanded to a
+ ;; string inside the macro. No idea.
+ ;; (concat (ert-test-documentation (get ',test 'ert--test))
+ ;; "\nUse direct async process.")
+ :tags (append '(:expensive-test :tramp-asynchronous-processes)
+ (and ,unstable '(:unstable)))
+ (skip-unless (tramp--test-enabled))
+ (let ((default-directory ert-remote-temporary-file-directory)
+ (ert-test (ert-get-test ',test))
+ (tramp-connection-properties
+ (cons '(nil "direct-async-process" t)
+ tramp-connection-properties)))
+ (skip-unless (tramp-direct-async-process-p))
+ ;; We do expect an established connection already,
+ ;; `file-truename' does it by side-effect. Suppress
+ ;; `tramp--test-enabled', in order to keep the connection.
+ ;; Suppress "Process ... finished" messages.
+ (cl-letf (((symbol-function #'tramp--test-enabled) #'tramp-compat-always)
+ ((symbol-function #'internal-default-process-sentinel)
+ #'ignore))
+ (file-truename ert-remote-temporary-file-directory)
+ (funcall (ert-test-body ert-test))))))
(tramp--test-deftest-direct-async-process tramp-test29-start-file-process)
@@ -5360,8 +5392,6 @@ If UNSTABLE is non-nil, the test is tagged as `:unstable'."
'(:unstable)))
(skip-unless (tramp--test-enabled))
(skip-unless (tramp--test-supports-processes-p))
- ;; `make-process' supports file name handlers since Emacs 27.
- (skip-unless (tramp--test-emacs27-p))
(dolist (quoted (if (tramp--test-expensive-test-p) '(nil t) '(nil)))
(let ((default-directory ert-remote-temporary-file-directory)
@@ -5374,10 +5404,9 @@ If UNSTABLE is non-nil, the test is tagged as `:unstable'."
(with-temp-buffer
(setq command '("cat")
proc
- (with-no-warnings
- (make-process
- :name "test1" :buffer (current-buffer) :command command
- :file-handler t)))
+ (make-process
+ :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))
@@ -5399,10 +5428,9 @@ If UNSTABLE is non-nil, the test is tagged as `:unstable'."
(should (file-exists-p tmp-name))
(setq command `("cat" ,(file-name-nondirectory tmp-name))
proc
- (with-no-warnings
- (make-process
- :name "test2" :buffer (current-buffer) :command command
- :file-handler t)))
+ (make-process
+ :name "test2" :buffer (current-buffer) :command command
+ :file-handler t))
(should (processp proc))
(should (equal (process-get proc 'remote-command) command))
;; Read output.
@@ -5421,13 +5449,12 @@ If UNSTABLE is non-nil, the test is tagged as `:unstable'."
(with-temp-buffer
(setq command '("cat")
proc
- (with-no-warnings
- (make-process
- :name "test3" :buffer (current-buffer) :command command
- :filter
- (lambda (p s)
- (with-current-buffer (process-buffer p) (insert s)))
- :file-handler t)))
+ (make-process
+ :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))
@@ -5448,11 +5475,9 @@ If UNSTABLE is non-nil, the test is tagged as `:unstable'."
(with-temp-buffer
(setq command '("cat")
proc
- (with-no-warnings
- (make-process
- :name "test4" :buffer (current-buffer) :command command
- :filter t
- :file-handler t)))
+ (make-process
+ :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))
@@ -5473,13 +5498,12 @@ If UNSTABLE is non-nil, the test is tagged as `:unstable'."
(with-temp-buffer
(setq command '("cat")
proc
- (with-no-warnings
- (make-process
- :name "test5" :buffer (current-buffer) :command command
- :sentinel
- (lambda (p s)
- (with-current-buffer (process-buffer p) (insert s)))
- :file-handler t)))
+ (make-process
+ :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))
@@ -5505,11 +5529,9 @@ If UNSTABLE is non-nil, the test is tagged as `:unstable'."
(with-temp-buffer
(setq command '("cat" "/does-not-exist")
proc
- (with-no-warnings
- (make-process
- :name "test6" :buffer (current-buffer) :command command
- :stderr stderr
- :file-handler t)))
+ (make-process
+ :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.
@@ -5538,11 +5560,9 @@ If UNSTABLE is non-nil, the test is tagged as `:unstable'."
(with-temp-buffer
(setq command '("cat" "/does-not-exist")
proc
- (with-no-warnings
- (make-process
- :name "test7" :buffer (current-buffer) :command command
- :stderr tmp-name
- :file-handler t)))
+ (make-process
+ :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.
@@ -5563,12 +5583,7 @@ If UNSTABLE is non-nil, the test is tagged as `:unstable'."
;; Process connection type.
(when (and (tramp--test-sh-p)
(not (tramp-direct-async-process-p))
- ;; `executable-find' has changed the number of
- ;; parameters in Emacs 27.1, so we use `apply' for
- ;; older Emacsen.
- (ignore-errors
- (with-no-warnings
- (apply #'executable-find '("hexdump" remote)))))
+ (executable-find "hexdump" 'remote))
(dolist (connection-type '(nil pipe t pty))
;; `process-connection-type' is taken when
;; `:connection-type' is nil.
@@ -5578,15 +5593,14 @@ If UNSTABLE is non-nil, the test is tagged as `:unstable'."
(with-temp-buffer
(setq command '("hexdump" "-v" "-e" "/1 \"%02X\n\"")
proc
- (with-no-warnings
- (make-process
- :name
- (format "test8-%s-%s"
- connection-type process-connection-type)
- :buffer (current-buffer)
- :connection-type connection-type
- :command command
- :file-handler t)))
+ (make-process
+ :name
+ (format "test8-%s-%s"
+ connection-type process-connection-type)
+ :buffer (current-buffer)
+ :connection-type connection-type
+ :command command
+ :file-handler t))
(should (processp proc))
(should (equal (process-status proc) 'run))
(should (equal (process-get proc 'remote-command) command))
@@ -5620,8 +5634,6 @@ If UNSTABLE is non-nil, the test is tagged as `:unstable'."
(skip-unless (tramp--test-sh-p))
(skip-unless (not (tramp--test-windows-nt-p)))
(skip-unless (not (tramp--test-crypt-p)))
- ;; Since Emacs 27.1.
- (skip-unless (macrop 'with-connection-local-variables))
;; We must use `file-truename' for the temporary directory, in
;; order to establish the connection prior running an asynchronous
@@ -5663,8 +5675,6 @@ If UNSTABLE is non-nil, the test is tagged as `:unstable'."
(skip-unless (tramp--test-sh-p))
(skip-unless (not (tramp--test-windows-nt-p)))
(skip-unless (not (tramp--test-crypt-p)))
- ;; Since Emacs 27.1.
- (skip-unless (macrop 'with-connection-local-variables))
;; Since Emacs 29.1.
(skip-unless (boundp 'signal-process-functions))
@@ -5779,7 +5789,7 @@ If UNSTABLE is non-nil, the test is tagged as `:unstable'."
;; (tramp--test-message "%s" attributes)
(should (equal (cdr (assq 'comm attributes)) (car command)))
(should (equal (cdr (assq 'args attributes))
- (mapconcat #'identity command " ")))))
+ (string-join command " ")))))
;; Cleanup.
(ignore-errors (delete-process proc)))))
@@ -5805,11 +5815,9 @@ If UNSTABLE is non-nil, the test is tagged as `:unstable'."
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))
- ;; Since Emacs 27.1.
- (when (macrop 'with-connection-local-variables)
- (should (equal (process-get proc 'remote-command)
- (with-connection-local-variables
- `(,shell-file-name ,shell-command-switch ,command)))))
+ (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))
@@ -5830,10 +5838,6 @@ INPUT, if non-nil, is a string sent to the process."
:tags '(:expensive-test)
(skip-unless (tramp--test-enabled))
(skip-unless (tramp--test-supports-processes-p))
- ;; Prior Emacs 27, `shell-file-name' was hard coded as "/bin/sh" for
- ;; remote processes in Emacs. That doesn't work for tramp-adb.el.
- (when (tramp--test-adb-p)
- (skip-unless (tramp--test-emacs27-p)))
(dolist (quoted (if (tramp--test-expensive-test-p) '(nil t) '(nil)))
(let ((tmp-name (tramp--test-make-temp-name nil quoted))
@@ -5861,7 +5865,7 @@ INPUT, if non-nil, is a string sent to the process."
(current-buffer))
;; "ls" could produce colorized output.
(goto-char (point-min))
- (while (re-search-forward ansi-color-control-seq-regexp nil t)
+ (while (search-forward-regexp ansi-color-control-seq-regexp nil t)
(replace-match "" nil nil))
(should
(string-equal
@@ -5900,7 +5904,7 @@ INPUT, if non-nil, is a string sent to the process."
(should
(string-match-p
;; Some shells echo, for example the "adb" or container methods.
- (tramp-compat-rx
+ (rx
bos (** 1 2 (literal (file-name-nondirectory tmp-name)) "\n")
eos)
(buffer-string))))
@@ -5908,10 +5912,8 @@ INPUT, if non-nil, is a string sent to the process."
;; Cleanup.
(ignore-errors (delete-file tmp-name))))))
- ;; Test `async-shell-command-width'. It exists since Emacs 26.1,
- ;; but seems to work since Emacs 27.1 only.
- (when (and (tramp--test-asynchronous-processes-p)
- (tramp--test-sh-p) (tramp--test-emacs27-p))
+ ;; Test `async-shell-command-width'.
+ (when (and (tramp--test-asynchronous-processes-p) (tramp--test-sh-p))
(let* ((async-shell-command-width 1024)
(default-directory ert-remote-temporary-file-directory)
(cols (ignore-errors
@@ -5931,8 +5933,6 @@ INPUT, if non-nil, is a string sent to the process."
(skip-unless (tramp--test-enabled))
(skip-unless nil)
(skip-unless (tramp--test-supports-processes-p))
- ;; Prior Emacs 27, `shell-command-dont-erase-buffer' wasn't working properly.
- (skip-unless (tramp--test-emacs27-p))
;; (message " s-c-d-e-b current-buffer buffer-string point")
;; (message "===============================================")
@@ -6107,8 +6107,7 @@ INPUT, if non-nil, is a string sent to the process."
;; Variable is set.
(should
(string-match-p
- (tramp-compat-rx (literal envvar))
- (funcall this-shell-command-to-string "set"))))
+ (rx (literal envvar)) (funcall this-shell-command-to-string "set"))))
(unless (tramp-direct-async-process-p)
;; We force a reconnect, in order to have a clean environment.
@@ -6136,7 +6135,7 @@ INPUT, if non-nil, is a string sent to the process."
;; Variable is unset.
(should-not
(string-match-p
- (tramp-compat-rx (literal envvar))
+ (rx (literal envvar))
;; We must remove PS1, the output is truncated otherwise.
;; We must suppress "_=VAR...".
(funcall
@@ -6181,13 +6180,10 @@ INPUT, if non-nil, is a string sent to the process."
(dolist (dir '("/mock:localhost#11111:" "/mock:localhost#22222:"))
(tramp-cleanup-connection (tramp-dissect-file-name dir)))))
-;; Connection-local variables are enabled per default since Emacs 27.1.
(ert-deftest tramp-test34-connection-local-variables ()
"Check that connection-local variables are enabled."
:tags '(:expensive-test)
(skip-unless (tramp--test-enabled))
- ;; Since Emacs 27.1.
- (skip-unless (macrop 'with-connection-local-variables))
(let* ((default-directory ert-remote-temporary-file-directory)
(tmp-name1 (tramp--test-make-temp-name))
@@ -6197,8 +6193,7 @@ INPUT, if non-nil, is a string sent to the process."
(inhibit-message t)
kill-buffer-query-functions
(clpa connection-local-profile-alist)
- (clca connection-local-criteria-alist)
- connection-local-profile-alist connection-local-criteria-alist)
+ (clca connection-local-criteria-alist))
(unwind-protect
(progn
(make-directory tmp-name1)
@@ -6228,22 +6223,42 @@ INPUT, if non-nil, is a string sent to the process."
(should (eq local-variable 'connect))
(kill-buffer (current-buffer)))
- ;; `local-variable' is dir-local due to existence of .dir-locals.el.
+ ;; `local-variable' is still connection-local due to Tramp.
+ ;; `find-file-hook' overrides dir-local settings.
(write-region
"((nil . ((local-variable . dir))))" nil
(expand-file-name ".dir-locals.el" tmp-name1))
(should (file-exists-p (expand-file-name ".dir-locals.el" tmp-name1)))
- (with-current-buffer (find-file-noselect tmp-name2)
- (should (eq local-variable 'dir))
- (kill-buffer (current-buffer)))
-
- ;; `local-variable' is file-local due to specifying as file variable.
+ (when (memq #'tramp-set-connection-local-variables-for-buffer
+ find-file-hook)
+ (with-current-buffer (find-file-noselect tmp-name2)
+ (should (eq local-variable 'connect))
+ (kill-buffer (current-buffer))))
+ ;; `local-variable' is dir-local due to existence of .dir-locals.el.
+ (let ((find-file-hook
+ (remq #'tramp-set-connection-local-variables-for-buffer
+ find-file-hook)))
+ (with-current-buffer (find-file-noselect tmp-name2)
+ (should (eq local-variable 'dir))
+ (kill-buffer (current-buffer))))
+
+ ;; `local-variable' is still connection-local due to Tramp.
+ ;; `find-file-hook' overrides dir-local settings.
(write-region
"-*- mode: comint; local-variable: file; -*-" nil tmp-name2)
(should (file-exists-p tmp-name2))
- (with-current-buffer (find-file-noselect tmp-name2)
- (should (eq local-variable 'file))
- (kill-buffer (current-buffer))))
+ (when (memq #'tramp-set-connection-local-variables-for-buffer
+ find-file-hook)
+ (with-current-buffer (find-file-noselect tmp-name2)
+ (should (eq local-variable 'connect))
+ (kill-buffer (current-buffer))))
+ ;; `local-variable' is file-local due to specifying as file variable.
+ (let ((find-file-hook
+ (remq #'tramp-set-connection-local-variables-for-buffer
+ find-file-hook)))
+ (with-current-buffer (find-file-noselect tmp-name2)
+ (should (eq local-variable 'file))
+ (kill-buffer (current-buffer)))))
;; Cleanup.
(custom-set-variables
@@ -6256,21 +6271,13 @@ INPUT, if non-nil, is a string sent to the process."
:tags '(:expensive-test :tramp-asynchronous-processes)
(skip-unless (tramp--test-enabled))
(skip-unless (tramp--test-supports-processes-p))
- ;; Prior Emacs 27, `shell-file-name' was hard coded as "/bin/sh" for
- ;; remote processes in Emacs. That doesn't work for tramp-adb.el.
- (when (tramp--test-adb-p)
- (skip-unless (tramp--test-emacs27-p)))
(let ((default-directory ert-remote-temporary-file-directory)
explicit-shell-file-name kill-buffer-query-functions
(clpa connection-local-profile-alist)
- (clca connection-local-criteria-alist)
- connection-local-profile-alist connection-local-criteria-alist)
+ (clca connection-local-criteria-alist))
(unwind-protect
(progn
- ;; `shell-mode' would ruin our test, because it deletes all
- ;; buffer local variables. Not needed in Emacs 27.1.
- (put 'explicit-shell-file-name 'permanent-local t)
(connection-local-set-profile-variables
'remote-sh
`((explicit-shell-file-name . ,(tramp--test-shell-file-name))
@@ -6304,29 +6311,24 @@ INPUT, if non-nil, is a string sent to the process."
`(connection-local-criteria-alist ',clca now))
(kill-buffer "*shell*"))))
-;; `exec-path' was introduced in Emacs 27.1. `executable-find' has
-;; changed the number of parameters, so we use `apply' for older
-;; Emacsen.
(ert-deftest tramp-test35-exec-path ()
"Check `exec-path' and `executable-find'."
(skip-unless (tramp--test-enabled))
(skip-unless (tramp--test-supports-processes-p))
(skip-unless (tramp--test-supports-set-file-modes-p))
- ;; Since Emacs 27.1.
- (skip-unless (fboundp 'exec-path))
(let ((tmp-name (tramp--test-make-temp-name))
(default-directory ert-remote-temporary-file-directory))
(unwind-protect
(progn
- (should (consp (with-no-warnings (exec-path))))
+ (should (consp (exec-path)))
;; Last element is the `exec-directory'.
(should
(string-equal
- (car (last (with-no-warnings (exec-path))))
+ (car (last (exec-path)))
(file-remote-p default-directory 'localname)))
;; The shell "sh" shall always exist.
- (should (apply #'executable-find '("sh" remote)))
+ (should (executable-find "sh" 'remote))
;; Since the last element in `exec-path' is the current
;; directory, an executable file in that directory will be
;; found.
@@ -6337,87 +6339,85 @@ INPUT, if non-nil, is a string sent to the process."
(should (file-executable-p tmp-name))
(should
(string-equal
- (apply
- #'executable-find `(,(file-name-nondirectory tmp-name) remote))
+ (executable-find (file-name-nondirectory tmp-name) 'remote)
(file-remote-p tmp-name 'localname)))
(should-not
- (apply
- #'executable-find
- `(,(concat (file-name-nondirectory tmp-name) "foo") remote))))
+ (executable-find
+ (concat (file-name-nondirectory tmp-name) "foo") 'remote)))
;; Cleanup.
(ignore-errors (delete-file tmp-name)))))
+(tramp--test-deftest-direct-async-process tramp-test35-exec-path)
+
;; This test is inspired by Bug#33781.
-;; `exec-path' was introduced in Emacs 27.1. `executable-find' has
-;; changed the number of parameters, so we use `apply' for older
-;; Emacsen.
(ert-deftest tramp-test35-remote-path ()
"Check loooong `tramp-remote-path'."
(skip-unless (tramp--test-enabled))
(skip-unless (tramp--test-sh-p))
(skip-unless (not (tramp--test-crypt-p)))
- ;; Since Emacs 27.1.
- (skip-unless (fboundp 'exec-path))
(let* ((tmp-name (tramp--test-make-temp-name))
(default-directory ert-remote-temporary-file-directory)
- (orig-exec-path (with-no-warnings (exec-path)))
+ (orig-exec-path (exec-path))
(tramp-remote-path tramp-remote-path)
(orig-tramp-remote-path tramp-remote-path)
path)
+ ;; The "flatpak" method modifies `tramp-remote-path'.
+ (skip-unless (not (tramp-compat-connection-local-p tramp-remote-path)))
(unwind-protect
(progn
;; Non existing directories are removed.
(setq tramp-remote-path
(cons (file-remote-p tmp-name 'localname) tramp-remote-path))
(tramp-cleanup-connection tramp-test-vec 'keep-debug 'keep-password)
- (should (equal (with-no-warnings (exec-path)) orig-exec-path))
+ (should (equal (exec-path) orig-exec-path))
(setq tramp-remote-path orig-tramp-remote-path)
;; Double entries are removed.
(setq tramp-remote-path (append '("/" "/") tramp-remote-path))
(tramp-cleanup-connection tramp-test-vec 'keep-debug 'keep-password)
- (should
- (equal (with-no-warnings (exec-path)) (cons "/" orig-exec-path)))
+ (should (equal (exec-path) (cons "/" orig-exec-path)))
(setq tramp-remote-path orig-tramp-remote-path)
;; We make a super long `tramp-remote-path'.
- (make-directory tmp-name)
- (should (file-directory-p tmp-name))
- (while (tramp-compat-length<
- (mapconcat #'identity orig-exec-path ":") 5000)
- (let ((dir (make-temp-file (file-name-as-directory tmp-name) 'dir)))
- (should (file-directory-p dir))
- (setq tramp-remote-path
- (append
- tramp-remote-path `(,(file-remote-p dir 'localname)))
- orig-exec-path
- (append
- (butlast orig-exec-path)
- `(,(file-remote-p dir 'localname))
- (last orig-exec-path)))))
- (tramp-cleanup-connection tramp-test-vec 'keep-debug 'keep-password)
- (should (equal (with-no-warnings (exec-path)) orig-exec-path))
- ;; Ignore trailing newline.
- (setq path (substring (shell-command-to-string "echo $PATH") nil -1))
- ;; The shell doesn't handle such long strings.
- (unless (tramp-compat-length>
- path
- (tramp-get-connection-property
- tramp-test-vec "pipe-buf" 4096))
- ;; The last element of `exec-path' is `exec-directory'.
- (should
- (string-equal
- path (mapconcat #'identity (butlast orig-exec-path) ":"))))
- ;; The shell "sh" shall always exist.
- (should (apply #'executable-find '("sh" remote))))
+ (unless (tramp--test-container-oob-p)
+ (make-directory tmp-name)
+ (should (file-directory-p tmp-name))
+ (while (tramp-compat-length< (string-join orig-exec-path ":") 5000)
+ (let ((dir (make-temp-file
+ (file-name-as-directory tmp-name) 'dir)))
+ (should (file-directory-p dir))
+ (setq tramp-remote-path
+ (append
+ tramp-remote-path `(,(file-remote-p dir 'localname)))
+ orig-exec-path
+ (append
+ (butlast orig-exec-path)
+ `(,(file-remote-p dir 'localname))
+ (last orig-exec-path)))))
+ (tramp-cleanup-connection tramp-test-vec 'keep-debug 'keep-password)
+ (should (equal (exec-path) orig-exec-path))
+ ;; Ignore trailing newline.
+ (setq path (substring (shell-command-to-string "echo $PATH") nil -1))
+ ;; The shell doesn't handle such long strings.
+ (unless (tramp-compat-length>
+ path
+ (tramp-get-connection-property
+ tramp-test-vec "pipe-buf" 4096))
+ ;; The last element of `exec-path' is `exec-directory'.
+ (should
+ (string-equal path (string-join (butlast orig-exec-path) ":"))))
+ ;; The shell "sh" shall always exist.
+ (should (executable-find "sh" 'remote))))
;; Cleanup.
(tramp-cleanup-connection tramp-test-vec 'keep-debug 'keep-password)
(setq tramp-remote-path orig-tramp-remote-path)
(ignore-errors (delete-directory tmp-name 'recursive)))))
+(tramp--test-deftest-direct-async-process tramp-test35-remote-path)
+
(ert-deftest tramp-test36-vc-registered ()
"Check `vc-registered'."
:tags '(:expensive-test)
@@ -6531,7 +6531,7 @@ INPUT, if non-nil, is a string sent to the process."
(string-equal
(make-auto-save-file-name)
(funcall
- (if quoted #'tramp-compat-file-name-quote #'identity)
+ (if quoted #'file-name-quote #'identity)
(expand-file-name
(format "#%s#" (file-name-nondirectory tmp-name1))
ert-remote-temporary-file-directory))))))
@@ -6556,7 +6556,7 @@ INPUT, if non-nil, is a string sent to the process."
("|" . "__")
("[" . "_l")
("]" . "_r"))
- (tramp-compat-file-name-unquote tmp-name1)))
+ (file-name-unquote tmp-name1)))
tmp-name2)))
(should (file-directory-p tmp-name2)))))
@@ -6580,7 +6580,7 @@ INPUT, if non-nil, is a string sent to the process."
("|" . "__")
("[" . "_l")
("]" . "_r"))
- (tramp-compat-file-name-unquote tmp-name1)))
+ (file-name-unquote tmp-name1)))
tmp-name2)))
(should (file-directory-p tmp-name2)))))
@@ -6606,7 +6606,7 @@ INPUT, if non-nil, is a string sent to the process."
(tramp-cleanup-connection
tramp-test-vec 'keep-debug 'keep-password)
(cl-letf (((symbol-function #'yes-or-no-p)
- #'tramp--test-always))
+ #'tramp-compat-always))
(should (stringp (make-auto-save-file-name))))))))
;; Cleanup.
@@ -6636,7 +6636,7 @@ INPUT, if non-nil, is a string sent to the process."
(find-backup-file-name tmp-name1)
(list
(funcall
- (if quoted #'tramp-compat-file-name-quote #'identity)
+ (if quoted #'file-name-quote #'identity)
(expand-file-name
(format "%s~" (file-name-nondirectory tmp-name1))
ert-remote-temporary-file-directory))))))
@@ -6653,7 +6653,7 @@ INPUT, if non-nil, is a string sent to the process."
(find-backup-file-name tmp-name1)
(list
(funcall
- (if quoted #'tramp-compat-file-name-quote #'identity)
+ (if quoted #'file-name-quote #'identity)
(expand-file-name
(format
"%s~"
@@ -6682,7 +6682,7 @@ INPUT, if non-nil, is a string sent to the process."
(find-backup-file-name tmp-name1)
(list
(funcall
- (if quoted #'tramp-compat-file-name-quote #'identity)
+ (if quoted #'file-name-quote #'identity)
(expand-file-name
(format
"%s~"
@@ -6713,7 +6713,7 @@ INPUT, if non-nil, is a string sent to the process."
(find-backup-file-name tmp-name1)
(list
(funcall
- (if quoted #'tramp-compat-file-name-quote #'identity)
+ (if quoted #'file-name-quote #'identity)
(expand-file-name
(format
"%s~"
@@ -6752,8 +6752,7 @@ INPUT, if non-nil, is a string sent to the process."
:type 'file-error))
(tramp-cleanup-connection
tramp-test-vec 'keep-debug 'keep-password)
- (cl-letf (((symbol-function #'yes-or-no-p)
- #'tramp--test-always))
+ (cl-letf (((symbol-function #'yes-or-no-p) #'tramp-compat-always))
(should (stringp (car (find-backup-file-name tmp-name1)))))))
;; Cleanup.
@@ -6770,7 +6769,7 @@ INPUT, if non-nil, is a string sent to the process."
(skip-unless (and (fboundp 'file-locked-p) (fboundp 'make-lock-file-name)))
;; `lock-file', `unlock-file', `file-locked-p' and
- ;; `make-lock-file-name' exists since Emacs 28.1. We don't want to
+ ;; `make-lock-file-name' exist since Emacs 28.1. We don't want to
;; see compiler warnings for older Emacsen.
(dolist (quoted (if (tramp--test-expensive-test-p) '(nil t) '(nil)))
(let ((tmp-name1 (tramp--test-make-temp-name nil quoted))
@@ -6804,11 +6803,33 @@ INPUT, if non-nil, is a string sent to the process."
(save-buffer)
(should-not (buffer-modified-p)))
(should-not (with-no-warnings (file-locked-p tmp-name1)))
+
+ ;; `kill-buffer' removes the lock.
(with-no-warnings (lock-file tmp-name1))
(should (eq (with-no-warnings (file-locked-p tmp-name1)) t))
+ (with-temp-buffer
+ (set-visited-file-name tmp-name1)
+ (insert "foo")
+ (should (buffer-modified-p))
+ (cl-letf (((symbol-function #'read-from-minibuffer)
+ (lambda (&rest _args) "yes")))
+ (kill-buffer)))
+ (should-not (with-no-warnings (file-locked-p tmp-name1)))
+ ;; `kill-buffer' should not remove the lock when the
+ ;; connection is broken. See Bug#61663.
+ (with-no-warnings (lock-file tmp-name1))
+ (should (eq (with-no-warnings (file-locked-p tmp-name1)) t))
+ (with-temp-buffer
+ (set-visited-file-name tmp-name1)
+ (insert "foo")
+ (should (buffer-modified-p))
+ (tramp-cleanup-connection tramp-test-vec 'keep-debug 'keep-password)
+ (cl-letf (((symbol-function #'read-from-minibuffer)
+ (lambda (&rest _args) "yes")))
+ (kill-buffer)))
;; A new connection changes process id, and also the
- ;; lockname contents.
+ ;; lock file contents. But it still exists.
(tramp-cleanup-connection tramp-test-vec 'keep-debug 'keep-password)
(should (stringp (with-no-warnings (file-locked-p tmp-name1))))
@@ -6886,8 +6907,7 @@ INPUT, if non-nil, is a string sent to the process."
:type 'file-error))
(tramp-cleanup-connection
tramp-test-vec 'keep-debug 'keep-password)
- (cl-letf (((symbol-function #'yes-or-no-p)
- #'tramp--test-always))
+ (cl-letf (((symbol-function #'yes-or-no-p) #'tramp-compat-always))
(write-region "foo" nil tmp-name1))))
;; Cleanup.
@@ -6958,7 +6978,8 @@ INPUT, if non-nil, is a string sent to the process."
(should (file-locked-p tmp-name)))))
;; `save-buffer' removes the file lock.
- (cl-letf (((symbol-function #'yes-or-no-p) #'tramp--test-always)
+ (cl-letf (((symbol-function #'yes-or-no-p)
+ #'tramp-compat-always)
((symbol-function #'read-char-choice)
(lambda (&rest _) ?y)))
(should (buffer-modified-p))
@@ -6972,7 +6993,6 @@ INPUT, if non-nil, is a string sent to the process."
(tramp-cleanup-connection
tramp-test-vec 'keep-debug 'keep-password)))))))
-;; The functions were introduced in Emacs 26.1.
(ert-deftest tramp-test40-make-nearby-temp-file ()
"Check `make-nearby-temp-file' and `temporary-file-directory'."
(skip-unless (tramp--test-enabled))
@@ -7004,12 +7024,6 @@ INPUT, if non-nil, is a string sent to the process."
(delete-directory tmp-file)
(should-not (file-exists-p tmp-file))))
-(defun tramp--test-emacs27-p ()
- "Check for Emacs version >= 27.1.
-Some semantics has been changed for there, without new functions
-or variables, so we check the Emacs version directly."
- (>= emacs-major-version 27))
-
(defun tramp--test-emacs28-p ()
"Check for Emacs version >= 28.1.
Some semantics has been changed for there, without new functions
@@ -7042,21 +7056,28 @@ This is used in tests which we don't want to tag
(ert--stats-selector ert--current-run-stats)
(list (make-ert-test :name (ert-test-name (ert-running-test))
:body nil :tags '(:tramp-asynchronous-processes))))
- ;; tramp-adb.el cannot apply multi-byte commands.
+ ;; tramp-adb.el cannot apply multibyte commands.
(not (and (tramp--test-adb-p)
- (string-match-p (tramp-compat-rx multibyte) default-directory)))))
-
-(defun tramp--test-crypt-p ()
- "Check, whether the remote directory is encrypted."
- (tramp-crypt-file-name-p ert-remote-temporary-file-directory))
+ (string-match-p (rx multibyte) default-directory)))))
(defun tramp--test-container-p ()
"Check, whether a container method is used.
This does not support some special file names."
(string-match-p
- (rx bol (| "docker" "podman") eol)
+ (rx bol (| "docker" "podman"))
(file-remote-p ert-remote-temporary-file-directory 'method)))
+(defun tramp--test-container-oob-p ()
+ "Check, whether the dockercp or podmancp method is used.
+They does not support wildcard copy."
+ (string-match-p
+ (rx bol (| "dockercp" "podmancp") eol)
+ (file-remote-p ert-remote-temporary-file-directory 'method)))
+
+(defun tramp--test-crypt-p ()
+ "Check, whether the remote directory is encrypted."
+ (tramp-crypt-file-name-p ert-remote-temporary-file-directory))
+
(defun tramp--test-expensive-test-p ()
"Whether expensive tests are run.
This is used in tests which we don't want to tag `:expensive'
@@ -7118,10 +7139,29 @@ This does not support external Emacs calls."
(string-equal
"mock" (file-remote-p ert-remote-temporary-file-directory 'method)))
+(defun tramp--test-netbsd-p ()
+ "Check, whether the remote host runs NetBSD."
+ ;; We must refill the cache. `file-truename' does it.
+ (file-truename ert-remote-temporary-file-directory)
+ (ignore-errors (tramp-check-remote-uname tramp-test-vec "NetBSD")))
+
+(defun tramp--test-openbsd-p ()
+ "Check, whether the remote host runs OpenBSD."
+ ;; We must refill the cache. `file-truename' does it.
+ (file-truename ert-remote-temporary-file-directory)
+ (ignore-errors (tramp-check-remote-uname tramp-test-vec "OpenBSD")))
+
(defun tramp--test-out-of-band-p ()
"Check, whether an out-of-band method is used."
(tramp-method-out-of-band-p tramp-test-vec 1))
+(defun tramp--test-putty-p ()
+ "Check, whether the method method usaes PuTTY.
+This does not support connection share for more than two connections."
+ (member
+ (file-remote-p ert-remote-temporary-file-directory 'method)
+ '("plink" "plinkx" "pscp" "psftp")))
+
(defun tramp--test-rclone-p ()
"Check, whether the remote host is offered by rclone.
This requires restrictions of file name syntax."
@@ -7209,10 +7249,7 @@ This requires restrictions of file name syntax."
(defun tramp--test-check-files (&rest files)
"Run a simple but comprehensive test over every file in FILES."
- ;; `filename-non-special' has been fixed in Emacs 27.1, see Bug#29579.
- (dolist (quoted
- (if (and (tramp--test-expensive-test-p) (tramp--test-emacs27-p))
- '(nil t) '(nil)))
+ (dolist (quoted (if (tramp--test-expensive-test-p) '(nil t) '(nil)))
;; We must use `file-truename' for the temporary directory,
;; because it could be located on a symlinked directory. This
;; would let the test fail.
@@ -7262,7 +7299,7 @@ This requires restrictions of file name syntax."
(should
(string-equal
(funcall
- (if quoted #'tramp-compat-file-name-quote #'identity)
+ (if quoted #'file-name-quote #'identity)
(file-attribute-type (file-attributes file3)))
(file-remote-p (file-truename file1) 'localname)))
;; Check file contents.
@@ -7345,22 +7382,24 @@ This requires restrictions of file name syntax."
;; Check symlink in `directory-files-and-attributes'.
;; It does not work in the "smb" case, only relative
- ;; symlinks to existing files are shown there.
+ ;; symlinks to existing files are shown there. On
+ ;; NetBSD, there are problems with loooong file names,
+ ;; see Bug#65324.
(tramp--test-ignore-make-symbolic-link-error
- (unless (tramp--test-smb-p)
+ (unless (or (tramp--test-netbsd-p) (tramp--test-smb-p))
(make-symbolic-link file2 file3)
(should (file-symlink-p file3))
(should
(string-equal
(caar (directory-files-and-attributes
- file1 nil (tramp-compat-rx (literal elt1))))
+ file1 nil (rx (literal elt1))))
elt1))
(should
(string-equal
(funcall
- (if quoted #'tramp-compat-file-name-quote #'identity)
+ (if quoted #'file-name-quote #'identity)
(cadr (car (directory-files-and-attributes
- file1 nil (tramp-compat-rx (literal elt1))))))
+ file1 nil (rx (literal elt1))))))
(file-remote-p (file-truename file2) 'localname)))
(delete-file file3)
(should-not (file-exists-p file3))))
@@ -7369,15 +7408,7 @@ This requires restrictions of file name syntax."
;; `default-directory' with special characters. See
;; Bug#53846.
(when (and (tramp--test-expensive-test-p)
- (tramp--test-supports-processes-p)
- ;; Prior Emacs 27, `shell-file-name' was
- ;; hard coded as "/bin/sh" for remote
- ;; processes in Emacs. That doesn't work
- ;; for tramp-adb.el. tramp-sshfs.el times
- ;; out for older Emacsen, reason unknown.
- (or (and (not (tramp--test-adb-p))
- (not (tramp--test-sshfs-p)))
- (tramp--test-emacs27-p)))
+ (tramp--test-supports-processes-p))
(let ((default-directory file1))
(dolist (this-shell-command
(append
@@ -7414,8 +7445,8 @@ This requires restrictions of file name syntax."
(when (zerop (process-file "printenv" nil t nil))
(goto-char (point-min))
(should
- (re-search-forward
- (tramp-compat-rx
+ (search-forward-regexp
+ (rx
bol (literal envvar)
"=" (literal (getenv envvar)) eol)))))))))
@@ -7443,6 +7474,7 @@ This requires restrictions of file name syntax."
(cond ((or (tramp--test-ange-ftp-p)
(tramp--test-container-p)
(tramp--test-gvfs-p)
+ (tramp--test-openbsd-p)
(tramp--test-rclone-p)
(tramp--test-sudoedit-p)
(tramp--test-windows-nt-or-smb-p))
@@ -7462,7 +7494,8 @@ This requires restrictions of file name syntax."
(tramp--test-gvfs-p)
(tramp--test-windows-nt-or-smb-p))
"?foo?bar?baz?")
- (unless (or (tramp--test-ftp-p)
+ (unless (or (tramp--test-container-oob-p)
+ (tramp--test-ftp-p)
(tramp--test-gvfs-p)
(tramp--test-windows-nt-or-smb-p))
"*foo+bar*baz+")
@@ -7482,12 +7515,15 @@ This requires restrictions of file name syntax."
(unless (or (tramp--test-gvfs-p) (tramp--test-windows-nt-or-smb-p))
"<foo>bar<baz>")
"(foo)bar(baz)"
- (unless (or (tramp--test-ftp-p) (tramp--test-gvfs-p)) "[foo]bar[baz]")
+ (unless (or (tramp--test-container-oob-p)
+ (tramp--test-ftp-p)
+ (tramp--test-gvfs-p))
+ "[foo]bar[baz]")
"{foo}bar{baz}")))
;; Simplify test in order to speed up.
(apply #'tramp--test-check-files
(if (tramp--test-expensive-test-p)
- files (list (mapconcat #'identity files ""))))))
+ files (list (string-join files ""))))))
(tramp--test-deftest-with-stat tramp-test41-special-characters)
@@ -7523,7 +7559,8 @@ This requires restrictions of file name syntax."
"Автостопом по гала́ктике"
;; Use codepoints without a name. See Bug#31272.
;; Works on some Android systems only.
- (unless (tramp--test-adb-p) "™›šbung")
+ (unless (or (tramp--test-adb-p) (tramp--test-openbsd-p))
+ "™›šbung")
;; Use codepoints from Supplementary Multilingual Plane (U+10000
;; to U+1FFFF).
"🌈🍒👋")
@@ -7563,23 +7600,51 @@ This requires restrictions of file name syntax."
(ert-deftest tramp-test43-file-system-info ()
"Check that `file-system-info' returns proper values."
(skip-unless (tramp--test-enabled))
- ;; Since Emacs 27.1.
- (skip-unless (fboundp 'file-system-info))
- ;; `file-system-info' exists since Emacs 27.1. We don't want to see
- ;; compiler warnings for older Emacsen.
- (when-let ((fsi (with-no-warnings
- (file-system-info ert-remote-temporary-file-directory))))
+ (when-let ((fsi (file-system-info ert-remote-temporary-file-directory)))
(should (consp fsi))
(should (tramp-compat-length= fsi 3))
(dotimes (i (length fsi))
(should (natnump (or (nth i fsi) 0))))))
-;; `tramp-test44-asynchronous-requests' could be blocked. So we set a
+;; `file-user-uid' and `file-group-gid' were introduced in Emacs 30.1.
+(ert-deftest tramp-test44-file-user-group-ids ()
+ "Check results of user/group functions.
+`file-user-uid', `file-group-gid', and `tramp-get-remote-*'
+should all return proper values."
+ (skip-unless (tramp--test-enabled))
+
+ (let ((default-directory ert-remote-temporary-file-directory))
+ ;; `file-user-uid' and `file-group-gid' exist since Emacs 30.1.
+ ;; We don't want to see compiler warnings for older Emacsen.
+ (when (fboundp 'file-user-uid)
+ (should (integerp (with-no-warnings (file-user-uid)))))
+ (when (fboundp 'file-group-gid)
+ (should (integerp (with-no-warnings (file-group-gid)))))
+
+ (with-parsed-tramp-file-name default-directory nil
+ (should (or (integerp (tramp-get-remote-uid v 'integer))
+ (null (tramp-get-remote-uid v 'integer))))
+ (should (or (stringp (tramp-get-remote-uid v 'string))
+ (null (tramp-get-remote-uid v 'string))))
+
+ (should (or (integerp (tramp-get-remote-gid v 'integer))
+ (null (tramp-get-remote-gid v 'integer))))
+ (should (or (stringp (tramp-get-remote-gid v 'string))
+ (null (tramp-get-remote-gid v 'string))))
+
+ (when-let ((groups (tramp-get-remote-groups v 'integer)))
+ (should (consp groups))
+ (dolist (group groups) (should (integerp group))))
+ (when-let ((groups (tramp-get-remote-groups v 'string)))
+ (should (consp groups))
+ (dolist (group groups) (should (stringp group)))))))
+
+;; `tramp-test45-asynchronous-requests' could be blocked. So we set a
;; timeout of 300 seconds, and we send a SIGUSR1 signal after 300
;; seconds. Similar check is performed in the timer function.
(defconst tramp--test-asynchronous-requests-timeout 300
- "Timeout for `tramp-test44-asynchronous-requests'.")
+ "Timeout for `tramp-test45-asynchronous-requests'.")
(defmacro tramp--test-with-proper-process-name-and-buffer (proc &rest body)
"Set \"process-name\" and \"process-buffer\" connection properties.
@@ -7615,17 +7680,13 @@ This is needed in timer functions as well as process filters and sentinels."
(tramp-flush-connection-property v "process-buffer")))))
;; This test is inspired by Bug#16928.
-(ert-deftest tramp-test44-asynchronous-requests ()
+(ert-deftest tramp-test45-asynchronous-requests ()
"Check parallel asynchronous requests.
Such requests could arrive from timers, process filters and
process sentinels. They shall not disturb each other."
- :tags '(:expensive-test :tramp-asynchronous-processes :unstable)
+ :tags '(:expensive-test :tramp-asynchronous-processes)
(skip-unless (tramp--test-enabled))
(skip-unless (tramp--test-supports-processes-p))
- ;; Prior Emacs 27, `shell-file-name' was hard coded as "/bin/sh" for
- ;; remote processes in Emacs. That doesn't work for tramp-adb.el.
- (when (tramp--test-adb-p)
- (skip-unless (tramp--test-emacs27-p)))
(skip-unless (not (tramp--test-container-p)))
(skip-unless (not (tramp--test-telnet-p)))
(skip-unless (not (tramp--test-sshfs-p)))
@@ -7661,6 +7722,10 @@ process sentinels. They shall not disturb each other."
(string-to-number (getenv "REMOTE_PARALLEL_PROCESSES"))))
((getenv "EMACS_HYDRA_CI") 5)
(t 10)))
+ ;; PuTTY-based methods can only share up to 10 connections.
+ (tramp-use-connection-share
+ (if (and (tramp--test-putty-p) (>= number-proc 10))
+ 'suppress (bound-and-true-p tramp-use-connection-share)))
;; On hydra, timings are bad.
(timer-repeat
(cond
@@ -7691,14 +7756,12 @@ process sentinels. They shall not disturb each other."
(when buffers
(let ((time (float-time))
(default-directory tmp-name)
- (file (buffer-name (seq-random-elt buffers)))
- ;; A remote operation in a timer could
- ;; confuse Tramp heavily. So we ignore this
- ;; error here.
- (debug-ignored-errors
- (cons 'remote-file-error debug-ignored-errors)))
+ (file (buffer-name (seq-random-elt buffers))))
(tramp--test-message
"Start timer %s %s" file (current-time-string))
+ (dired-uncache file)
+ (tramp--test-message
+ "Continue timer %s %s" file (file-attributes file))
(vc-registered file)
(tramp--test-message
"Stop timer %s %s" file (current-time-string))
@@ -7786,7 +7849,7 @@ process sentinels. They shall not disturb each other."
(setq buffers (delq buf buffers))))
(setq buffers (delq buf buffers)))))
- ;; Checks. All process output shall exists in the
+ ;; Checks. All process output shall exist in the
;; respective buffers. All created files shall be
;; deleted.
(tramp--test-message "Check %s" (current-time-string))
@@ -7812,10 +7875,10 @@ process sentinels. They shall not disturb each other."
(ignore-errors (cancel-timer timer))
(ignore-errors (delete-directory tmp-name 'recursive))))))
-;; (tramp--test-deftest-direct-async-process tramp-test44-asynchronous-requests
+;; (tramp--test-deftest-direct-async-process tramp-test45-asynchronous-requests
;; 'unstable)
-(ert-deftest tramp-test45-dired-compress-file ()
+(ert-deftest tramp-test46-dired-compress-file ()
"Check that Tramp (un)compresses normal files."
(skip-unless (tramp--test-enabled))
(skip-unless (tramp--test-sh-p))
@@ -7836,7 +7899,7 @@ process sentinels. They shall not disturb each other."
(should (string= tmp-name (dired-get-filename)))
(delete-file tmp-name)))
-(ert-deftest tramp-test45-dired-compress-dir ()
+(ert-deftest tramp-test46-dired-compress-dir ()
"Check that Tramp (un)compresses directories."
(skip-unless (tramp--test-enabled))
(skip-unless (tramp--test-sh-p))
@@ -7858,7 +7921,7 @@ 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 ()
+(ert-deftest tramp-test47-read-password ()
"Check Tramp password handling."
:tags '(:expensive-test)
(skip-unless (tramp--test-enabled))
@@ -7917,7 +7980,7 @@ process sentinels. They shall not disturb each other."
(let ((auth-sources `(,netrc-file)))
(should (file-exists-p ert-remote-temporary-file-directory)))))))))
-(ert-deftest tramp-test46-read-otp-password ()
+(ert-deftest tramp-test47-read-otp-password ()
"Check Tramp one-time password handling."
:tags '(:expensive-test)
(skip-unless (tramp--test-mock-p))
@@ -7977,7 +8040,7 @@ process sentinels. They shall not disturb each other."
(file-exists-p ert-remote-temporary-file-directory)))))))))
;; This test is inspired by Bug#29163.
-(ert-deftest tramp-test47-auto-load ()
+(ert-deftest tramp-test48-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.
@@ -8002,7 +8065,7 @@ process sentinels. They shall not disturb each other."
(mapconcat #'shell-quote-argument load-path " -L ")
(shell-quote-argument code)))))))
-(ert-deftest tramp-test47-delay-load ()
+(ert-deftest tramp-test48-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
@@ -8020,7 +8083,7 @@ process sentinels. They shall not disturb each other."
(dolist (tm '(t nil))
(should
(string-match-p
- (tramp-compat-rx
+ (rx
"Tramp loaded: nil" (+ (any "\r\n"))
"Tramp loaded: nil" (+ (any "\r\n"))
"Tramp loaded: " (literal (symbol-name tm)) (+ (any "\r\n")))
@@ -8032,7 +8095,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-test47-recursive-load ()
+(ert-deftest tramp-test48-recursive-load ()
"Check that Tramp does not fail due to recursive load."
(skip-unless (tramp--test-enabled))
@@ -8056,7 +8119,7 @@ process sentinels. They shall not disturb each other."
(mapconcat #'shell-quote-argument load-path " -L ")
(shell-quote-argument code))))))))
-(ert-deftest tramp-test47-remote-load-path ()
+(ert-deftest tramp-test48-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
@@ -8068,7 +8131,7 @@ process sentinels. They shall not disturb each other."
(tramp-cleanup-all-connections))"))
(should
(string-match-p
- (tramp-compat-rx
+ (rx
"Loading "
(literal
(expand-file-name
@@ -8081,7 +8144,22 @@ process sentinels. They shall not disturb each other."
(mapconcat #'shell-quote-argument load-path " -L ")
(shell-quote-argument code)))))))
-(ert-deftest tramp-test48-unload ()
+(ert-deftest tramp-test49-without-remote-files ()
+ "Check that Tramp can be suppressed."
+ (skip-unless (tramp--test-enabled))
+
+ (should (file-remote-p ert-remote-temporary-file-directory))
+ (should-not
+ (without-remote-files (file-remote-p ert-remote-temporary-file-directory)))
+ (should (file-remote-p ert-remote-temporary-file-directory))
+
+ (inhibit-remote-files)
+ (should-not (file-remote-p ert-remote-temporary-file-directory))
+ (tramp-register-file-name-handlers)
+ (setq tramp-mode t)
+ (should (file-remote-p ert-remote-temporary-file-directory)))
+
+(ert-deftest tramp-test50-unload ()
"Check that Tramp and its subpackages unload completely.
Since it unloads Tramp, it shall be the last test to run."
:tags '(:expensive-test)
@@ -8120,6 +8198,8 @@ Since it unloads Tramp, it shall be the last test to run."
;; `tramp-register-archive-file-name-handler' is autoloaded
;; in Emacs < 29.1.
(not (eq 'tramp-register-archive-file-name-handler x))
+ ;; `tramp-compat-rx' is autoloaded in Emacs 29.1.
+ (not (eq 'tramp-compat-rx x))
(not (string-match-p
(rx bol "tramp" (? "-archive") (** 1 2 "-") "test")
(symbol-name x)))
@@ -8181,12 +8261,10 @@ If INTERACTIVE is non-nil, the tests are run interactively."
;; * file-name-case-insensitive-p
;; * memory-info
;; * tramp-get-home-directory
-;; * tramp-get-remote-gid
-;; * tramp-get-remote-groups
-;; * tramp-get-remote-uid
;; * tramp-set-file-uid-gid
;; * Work on skipped tests. Make a comment, when it is impossible.
+;; * Use `skip-when' starting with Emacs 30.1.
;; * Revisit expensive tests, once problems in `tramp-error' are solved.
;; * Fix `tramp-test06-directory-file-name' for "ftp".
;; * Check, why a process filter t doesn't work in
@@ -8196,7 +8274,7 @@ If INTERACTIVE is non-nil, the tests are run interactively."
;; `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'.
+;; `tramp-test45-asynchronous-requests'.
(provide 'tramp-tests)
diff --git a/test/lisp/net/webjump-tests.el b/test/lisp/net/webjump-tests.el
index 66fc26bc658..eeec499b557 100644
--- a/test/lisp/net/webjump-tests.el
+++ b/test/lisp/net/webjump-tests.el
@@ -58,7 +58,7 @@
(ert-deftest webjump-tests-url-fix ()
(should (equal (webjump-url-fix nil) ""))
(should (equal (webjump-url-fix "/tmp/") "file:///tmp/"))
- (should (equal (webjump-url-fix "gnu.org") "http://gnu.org/"))
+ (should (equal (webjump-url-fix "gnu.org") "https://gnu.org/"))
(should (equal (webjump-url-fix "ftp.x.org") "ftp://ftp.x.org/"))
(should (equal (webjump-url-fix "https://gnu.org")
"https://gnu.org/")))
diff --git a/test/lisp/obarray-tests.el b/test/lisp/obarray-tests.el
index d7e547fcf29..f9f97dba535 100644
--- a/test/lisp/obarray-tests.el
+++ b/test/lisp/obarray-tests.el
@@ -32,27 +32,18 @@
(should-not (obarrayp "aoeu"))
(should-not (obarrayp '()))
(should-not (obarrayp []))
- (should (obarrayp (make-vector 7 0))))
-
-(ert-deftest obarrayp-unchecked-content-test ()
- "Should fail to check content of passed obarray."
- :expected-result :failed
(should-not (obarrayp ["a" "b" "c"]))
- (should-not (obarrayp [1 2 3])))
-
-(ert-deftest obarray-make-default-test ()
- (let ((table (obarray-make)))
- (should (obarrayp table))
- (should (eq (obarray-size table) obarray-default-size))))
+ (should-not (obarrayp [1 2 3]))
+ (should-not (obarrayp (make-vector 7 0)))
+ (should-not (obarrayp (vector (obarray-make))))
+ (should (obarrayp (obarray-make)))
+ (should (obarrayp (obarray-make 7))))
(ert-deftest obarray-make-with-size-test ()
;; FIXME: Actually, `wrong-type-argument' is not the right error to signal,
;; so we shouldn't enforce this misbehavior in tests!
(should-error (obarray-make -1) :type 'wrong-type-argument)
- (should-error (obarray-make 0) :type 'wrong-type-argument)
- (let ((table (obarray-make 1)))
- (should (obarrayp table))
- (should (eq (obarray-size table) 1))))
+ (should-error (obarray-make 'a) :type 'wrong-type-argument))
(ert-deftest obarray-get-test ()
(let ((table (obarray-make 3)))
@@ -88,5 +79,15 @@
(obarray-map collect-names table)
(should (equal (sort syms #'string<) '("a" "b" "c")))))
+(ert-deftest obarray-clear ()
+ (let ((o (obarray-make)))
+ (intern "a" o)
+ (intern "b" o)
+ (intern "c" o)
+ (obarray-clear o)
+ (let ((n 0))
+ (mapatoms (lambda (_) (setq n (1+ n))) o)
+ (should (equal n 0)))))
+
(provide 'obarray-tests)
;;; obarray-tests.el ends here
diff --git a/test/lisp/proced-tests.el b/test/lisp/proced-tests.el
new file mode 100644
index 00000000000..6f16a241146
--- /dev/null
+++ b/test/lisp/proced-tests.el
@@ -0,0 +1,136 @@
+;;; proced-tests.el --- Test suite for proced.el -*- lexical-binding: t -*-
+
+;; Copyright (C) 2022-2024 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 <https://www.gnu.org/licenses/>.
+
+;;; Code:
+
+(require 'ert)
+(require 'proced)
+(require 'thingatpt)
+
+(cl-defmacro proced--within-buffer (format filter &body body)
+ "Execute BODY within a proced buffer using format FORMAT and filter FILTER."
+ `(let ((proced-format ,format)
+ (proced-filter ,filter)
+ (proced-auto-update-flag nil)
+ (inhibit-message t))
+ (proced)
+ (unwind-protect
+ (with-current-buffer "*Proced*"
+ ,@body)
+ (kill-buffer "*Proced*"))))
+
+(defun proced--assert-emacs-pid-in-buffer ()
+ "Fail unless the process ID of the current Emacs process exists in buffer."
+ (should (string-match-p
+ (number-to-string (emacs-pid))
+ (buffer-substring-no-properties (point-min) (point-max)))))
+
+(defun proced--move-to-column (attribute)
+ "Move to the column under ATTRIBUTE in the current proced buffer."
+ (move-to-column (string-match attribute proced-header-line)))
+
+(defun proced--assert-process-valid-pid-refinement (pid)
+ "Fail unless the process at point could be present after a refinement using PID."
+ (proced--move-to-column "PID")
+ (let ((pid-equal (string= pid (word-at-point))))
+ (should
+ (or pid-equal
+ ;; Guard against the unlikely event a platform doesn't support PPID
+ (when (string-match "PPID" proced-header-line)
+ (proced--move-to-column "PPID")
+ (string= pid (word-at-point)))))))
+
+(ert-deftest proced-format-test ()
+ (dolist (format '(short medium long verbose))
+ (proced--within-buffer
+ format
+ 'user
+ (proced--assert-emacs-pid-in-buffer))))
+
+(ert-deftest proced-update-test ()
+ (proced--within-buffer
+ 'short
+ 'user
+ (proced-update)
+ (proced--assert-emacs-pid-in-buffer)))
+
+(ert-deftest proced-revert-test ()
+ (proced--within-buffer
+ 'short
+ 'user
+ (proced-revert)
+ (proced--assert-emacs-pid-in-buffer)))
+
+(ert-deftest proced-color-test ()
+ (let ((proced-enable-color-flag t))
+ (proced--within-buffer
+ 'short
+ 'user
+ (proced--assert-emacs-pid-in-buffer))))
+
+(ert-deftest proced-refine-test ()
+ ;;(skip-unless (memq system-type '(gnu/linux gnu/kfreebsd darwin)))
+ (proced--within-buffer
+ 'verbose
+ 'user
+ ;; When refining on PID for process A, a process is kept if and only
+ ;; if its PID is the same as process A, or its parent process is
+ ;; process A.
+ (proced--move-to-column "PID")
+ (let ((pid (word-at-point)))
+ (proced-refine)
+ (while (not (eobp))
+ (proced--assert-process-valid-pid-refinement pid)
+ (forward-line)))))
+
+(ert-deftest proced-refine-with-update-test ()
+ (proced--within-buffer
+ 'verbose
+ 'user
+ (proced--move-to-column "PID")
+ (let ((pid (word-at-point)))
+ (proced-refine)
+ ;; Don't use (proced-update t) since this will reset `proced-process-alist'
+ ;; and it's possible the process refined on would have exited by that
+ ;; point. In this case proced will skip the refinement and show all
+ ;; processes again, causing the test to fail.
+ (proced-update)
+ (while (not (eobp))
+ (proced--assert-process-valid-pid-refinement pid)
+ (forward-line)))))
+
+(ert-deftest proced-update-preserves-pid-at-point-test ()
+ (proced--within-buffer
+ 'medium
+ 'user
+ (goto-char (point-min))
+ (search-forward (number-to-string (emacs-pid)))
+ (proced--move-to-column "PID")
+ (save-window-excursion
+ (let ((pid (proced-pid-at-point))
+ (new-window (split-window))
+ (old-window (get-buffer-window)))
+ (select-window new-window)
+ (with-current-buffer "*Proced*"
+ (proced-update t t))
+ (select-window old-window)
+ (should (= pid (proced-pid-at-point)))))))
+
+(provide 'proced-tests)
+;;; proced-tests.el ends here
diff --git a/test/lisp/progmodes/bug-reference-tests.el b/test/lisp/progmodes/bug-reference-tests.el
index 237b79cface..8cca354705b 100644
--- a/test/lisp/progmodes/bug-reference-tests.el
+++ b/test/lisp/progmodes/bug-reference-tests.el
@@ -25,6 +25,7 @@
(require 'bug-reference)
(require 'ert)
+(require 'ert-x)
(defun test--get-github-entry (url)
(and (string-match
@@ -125,4 +126,18 @@
(test--get-gitea-entry "https://gitea.com/magit/magit/")
"magit/magit")))
+(ert-deftest test-thing-at-point ()
+ "Ensure that (thing-at-point 'url) returns the bug URL."
+ (ert-with-test-buffer (:name "thingatpt")
+ (setq-local bug-reference-url-format "https://debbugs.gnu.org/%s")
+ (insert "bug#1234")
+ (bug-reference-mode)
+ (jit-lock-fontify-now (point-min) (point-max))
+ (goto-char (point-min))
+ ;; Make sure we get the URL when `bug-reference-mode' is active...
+ (should (equal (thing-at-point 'url) "https://debbugs.gnu.org/1234"))
+ (bug-reference-mode -1)
+ ;; ... and get nil when `bug-reference-mode' is inactive.
+ (should-not (thing-at-point 'url))))
+
;;; bug-reference-tests.el ends here
diff --git a/test/lisp/progmodes/c-ts-mode-resources/indent.erts b/test/lisp/progmodes/c-ts-mode-resources/indent.erts
index 2fd26d75844..24b244c1611 100644
--- a/test/lisp/progmodes/c-ts-mode-resources/indent.erts
+++ b/test/lisp/progmodes/c-ts-mode-resources/indent.erts
@@ -84,7 +84,7 @@ int main()
}
=-=-=
-Name: Concecutive blocks (GNU Style) (bug#60873)
+Name: Consecutive blocks (GNU Style) (bug#60873)
=-=
int
diff --git a/test/lisp/progmodes/compile-tests.el b/test/lisp/progmodes/compile-tests.el
index fe40aa37241..20beed955d2 100644
--- a/test/lisp/progmodes/compile-tests.el
+++ b/test/lisp/progmodes/compile-tests.el
@@ -121,9 +121,7 @@
;; cucumber
(cucumber "Scenario: undefined step # features/cucumber.feature:3"
29 nil 3 "features/cucumber.feature")
- ;; This rule is actually handled by the `cucumber' pattern but when
- ;; `omake' is included, then `gnu' matches it first.
- (gnu " /home/gusev/.rvm/foo/bar.rb:500:in `_wrap_assertion'"
+ (cucumber " /home/gusev/.rvm/foo/bar.rb:500:in `_wrap_assertion'"
1 nil 500 "/home/gusev/.rvm/foo/bar.rb")
;; edg-1 edg-2
(edg-1 "build/intel/debug/../../../struct.cpp(42): error: identifier \"foo\" is undefined"
@@ -208,6 +206,33 @@
1 0 31 "/usr/include/c++/3.3/backward/iostream.h")
(gcc-include " from test_clt.cc:1:"
1 nil 1 "test_clt.cc")
+ ;; Lua
+ (lua "lua: database.lua:10: assertion failed!\nstack traceback:\n\t"
+ 6 nil 10 "database.lua")
+ (lua "lua 5.4: database 2.lua:10: assertion failed!\nstack traceback:\n\t"
+ 10 nil 10 "database 2.lua")
+ (lua "/usr/local/bin/lua: core/database.lua:20: assertion failed!\nstack traceback:\n\t"
+ 21 nil 20 "core/database.lua")
+ (lua "C:\\Lua\\Lua.exe: Core\\Database.lua:20: assertion failed!\nstack traceback:\n\t"
+ 17 nil 20 "Core\\Database.lua")
+ (lua "lua: /tmp/database.lua:20: assertion failed!\nstack traceback:\n\t"
+ 6 nil 20 "/tmp/database.lua")
+ (lua "Lua.exe: C:\\Temp\\Database.lua:20: assertion failed!\nstack traceback:\n\t"
+ 10 nil 20 "C:\\Temp\\Database.lua")
+ (lua-stack " database.lua: in field 'statement'"
+ 2 nil nil "database.lua" 0)
+ (lua-stack " database.lua:10: in field 'statement'"
+ 2 nil 10 "database.lua" 0)
+ (lua-stack " core/database.lua:20: in field 'statement'"
+ 2 nil 20 "core/database.lua" 0)
+ (lua-stack " database 2.lua: in field 'statement'"
+ 2 nil nil "database 2.lua" 0)
+ (lua-stack " Core\\Database.lua:20: in field 'statement'"
+ 2 nil 20 "Core\\Database.lua" 0)
+ (lua-stack " /tmp/database.lua: in field 'statement'"
+ 2 nil nil "/tmp/database.lua" 0)
+ (lua-stack " C:\\Core\\Database.lua: in field 'statement'"
+ 2 nil nil "C:\\Core\\Database.lua" 0)
;; gmake
(gmake "make: *** [Makefile:20: all] Error 2" 12 nil 20 "Makefile" 0)
(gmake "make[4]: *** [sub/make.mk:19: all] Error 127" 15 nil 19
@@ -312,10 +337,6 @@
1 nil 109 "..\\src\\ctrl\\lister.c")
(watcom "..\\src\\ctrl\\lister.c(120): Warning! W201: Unreachable code"
1 nil 120 "..\\src\\ctrl\\lister.c")
- ;; omake
- ;; FIXME: This doesn't actually test the omake rule.
- (gnu " alpha.c:5:15: error: expected ';' after expression"
- 1 15 5 "alpha.c")
;; oracle
(oracle "Semantic error at line 528, column 5, file erosacqdb.pc:"
1 5 528 "erosacqdb.pc")
@@ -497,11 +518,25 @@ The test data is in `compile-tests--test-regexps-data'."
(font-lock-mode -1)
(let ((compilation-num-errors-found 0)
(compilation-num-warnings-found 0)
- (compilation-num-infos-found 0))
- (mapc #'compile--test-error-line compile-tests--test-regexps-data)
- (should (eq compilation-num-errors-found 100))
+ (compilation-num-infos-found 0)
+ (all-rules (mapcar #'car compilation-error-regexp-alist-alist)))
+
+ ;; Test all built-in rules except `omake' to avoid interference.
+ (let ((compilation-error-regexp-alist (remq 'omake all-rules)))
+ (mapc #'compile--test-error-line compile-tests--test-regexps-data))
+
+ ;; Test the `omake' rule separately.
+ ;; This doesn't actually test the `omake' rule itself but its
+ ;; indirect effects.
+ (let ((compilation-error-regexp-alist all-rules)
+ (test
+ '(gnu " alpha.c:5:15: error: expected ';' after expression"
+ 1 15 5 "alpha.c")))
+ (compile--test-error-line test))
+
+ (should (eq compilation-num-errors-found 106))
(should (eq compilation-num-warnings-found 35))
- (should (eq compilation-num-infos-found 28)))))
+ (should (eq compilation-num-infos-found 35)))))
(ert-deftest compile-test-grep-regexps ()
"Test the `grep-regexp-alist' regexps.
diff --git a/test/lisp/progmodes/cperl-mode-resources/cperl-bug-11733.pl b/test/lisp/progmodes/cperl-mode-resources/cperl-bug-11733.pl
new file mode 100644
index 00000000000..a474e431222
--- /dev/null
+++ b/test/lisp/progmodes/cperl-mode-resources/cperl-bug-11733.pl
@@ -0,0 +1,50 @@
+# This resource file can be run with cperl--run-testcases from
+# cperl-tests.el and works with both perl-mode and cperl-mode.
+
+# -------- Multiline declaration: input -------
+#!/usr/bin/env perl
+# -*- mode: cperl -*-
+
+sub foo
+ {
+ }
+
+sub bar
+ {
+ }
+# -------- Multiline declaration: expected output -------
+#!/usr/bin/env perl
+# -*- mode: cperl -*-
+
+sub foo
+{
+}
+
+sub bar
+{
+}
+# -------- Multiline declaration: end -------
+
+# -------- Fred Colon at work: input --------
+#!/usr/bin/env perl
+# -*- mode: cperl -*-
+
+while (<>)
+{
+m:^ \d+ p:
+or die;
+m:^ \d+ :
+or die;
+}
+# -------- Fred Colon at work: expected output --------
+#!/usr/bin/env perl
+# -*- mode: cperl -*-
+
+while (<>)
+ {
+ m:^ \d+ p:
+ or die;
+ m:^ \d+ :
+ or die;
+ }
+# -------- Fred Colon at work: end --------
diff --git a/test/lisp/progmodes/cperl-mode-resources/cperl-bug-35925.pl b/test/lisp/progmodes/cperl-mode-resources/cperl-bug-35925.pl
new file mode 100644
index 00000000000..e3f96241ab7
--- /dev/null
+++ b/test/lisp/progmodes/cperl-mode-resources/cperl-bug-35925.pl
@@ -0,0 +1,36 @@
+# This resource file can be run with cperl--run-testcases from
+# cperl-tests.el and works with both perl-mode and cperl-mode.
+
+# -------- Bug#35925: input -------
+format FH =
+@### @.### @###
+42, 3.1415, 0
+.
+write FH;
+
+# -------- Bug#35925: expected output -------
+format FH =
+@### @.### @###
+42, 3.1415, 0
+.
+write FH;
+
+# -------- Bug#35925: end -------
+
+# -------- format not as top-level: input -------
+foo: {
+ format STDOUT =
+^<<<<
+$foo
+.
+write;
+}
+# -------- format not as top-level: expected output -------
+foo: {
+ format STDOUT =
+^<<<<
+$foo
+.
+ write;
+}
+# -------- format not as top-level: end -------
diff --git a/test/lisp/progmodes/cperl-mode-resources/cperl-bug-64190.pl b/test/lisp/progmodes/cperl-mode-resources/cperl-bug-64190.pl
new file mode 100644
index 00000000000..c7621e1c47b
--- /dev/null
+++ b/test/lisp/progmodes/cperl-mode-resources/cperl-bug-64190.pl
@@ -0,0 +1,24 @@
+# Example 1
+
+my ($var1,
+ $var2,
+ $var3);
+
+# Example 2
+
+package Foo
+ 0.1;
+
+# Example 3 (intentionally incomplete, body is inserted by test)
+
+sub do_stuff
+
+# Example 4
+
+sub do_more_stuff ($param1,
+$param2)
+{
+ ...;
+}
+
+sub oops { ...; }
diff --git a/test/lisp/progmodes/cperl-mode-resources/cperl-bug-64364.pl b/test/lisp/progmodes/cperl-mode-resources/cperl-bug-64364.pl
new file mode 100644
index 00000000000..62ef6982f38
--- /dev/null
+++ b/test/lisp/progmodes/cperl-mode-resources/cperl-bug-64364.pl
@@ -0,0 +1,55 @@
+# This resource file can be run with cperl--run-testcases from
+# cperl-tests.el and works with both perl-mode and cperl-mode.
+
+# -------- Bug#64364: input -------
+package P {
+sub way { ...; }
+#
+sub bus
+:lvalue
+($sig,$na,@ture)
+{
+...;
+}
+}
+# -------- Bug#64364: expected output -------
+package P {
+ sub way { ...; }
+ #
+ sub bus
+ :lvalue
+ ($sig,$na,@ture)
+ {
+ ...;
+ }
+}
+# -------- Bug#64364: end -------
+
+# Now do this with multiline initializers
+# -------- signature with init: input -------
+package P {
+sub way { ...; }
+# perl 5.38 or newer
+sub bus
+:lvalue
+($sig,
+$na //= 42,
+@ture)
+{
+...;
+}
+}
+# -------- signature with init: expected output -------
+package P {
+ sub way { ...; }
+ # perl 5.38 or newer
+ sub bus
+ :lvalue
+ ($sig,
+ $na //= 42,
+ @ture)
+ {
+ ...;
+ }
+}
+# -------- signature with init: end -------
diff --git a/test/lisp/progmodes/cperl-mode-resources/cperl-bug-65834.pl b/test/lisp/progmodes/cperl-mode-resources/cperl-bug-65834.pl
new file mode 100644
index 00000000000..775a113ac17
--- /dev/null
+++ b/test/lisp/progmodes/cperl-mode-resources/cperl-bug-65834.pl
@@ -0,0 +1,5 @@
+# -*- mode: cperl -*-
+if ($t->[3]<<5) {
+ return 0;
+}
+# comment
diff --git a/test/lisp/progmodes/cperl-mode-resources/cperl-bug-66145.pl b/test/lisp/progmodes/cperl-mode-resources/cperl-bug-66145.pl
new file mode 100644
index 00000000000..70f12346ded
--- /dev/null
+++ b/test/lisp/progmodes/cperl-mode-resources/cperl-bug-66145.pl
@@ -0,0 +1,62 @@
+# The original code, from the bug report, with variables renamed
+
+sub foo {
+ # Here we do something like
+ # this: $array_comment [ num_things ]->{key_comment}
+}
+
+# --------------------------------------------------
+# Comments containing hash and array sigils
+
+# This is an @array, and this is a %hash
+# $array_comment[$index] = $hash_comment{key_comment}
+# The last element has the index $#array_comment
+# my @a_slice = @array_comment[1,2,3];
+# my @h_slice = @hash_comment{qw(a b c)};
+# my %a_set = %array_comment[1,2,3];
+# my %h_set = %hash_comment{qw(a b c)};
+
+# --------------------------------------------------
+# in POD
+
+=head1 NAME
+
+cperl-bug-66145 - don't fontify arrays and hashes in POD
+
+=head1 SYNOPSIS
+
+ $array_comment[$index] = $hash_comment{key_comment};
+ @array_comment = qw(in pod);
+ %hash_comment = key_comment => q(pod);
+ @array_comment = @array_comment[1,2,3];
+ @array_comment = @hash_comment{qw(a b c)};
+ %hash_comment = %array_comment[1,2,3];
+ %hash_comment = %hash_comment{qw(a b c)};
+
+=cut
+
+# --------------------------------------------------
+# in strings
+
+my @strings = (
+ q/$array_string[$index] = $hash_string{key_string};/,
+ q/my @array_string = qw(in unquoted string);/,
+ q/my %hash_string = (key_string => q(pod);)/,
+ q/@array_string = @array_string[1,2,3];/,
+ q/@array_string = @hash_string{qw(a b c)};/,
+ q/%hash_string = %array_string[1,2,3];/,
+ q/%hash_string = %hash_string{qw(a b c)};/,
+);
+
+# --------------------------------------------------
+# in a HERE-document (perl-mode has an extra face for that)
+
+my $here = <<DONE;
+ $array_here[$index_here] = $hash_here{key_here};
+ @array_here = qw(in a hrere-document);
+ %hash_here = key_here => q(pod);
+ @array_here = @array_here[1,2,3];
+ @array_here = @hash_here{qw(a b c)};
+ %hash_here = %array_here[1,2,3];
+ %hash_here = %hash_here{qw(a b c)};
+DONE
diff --git a/test/lisp/progmodes/cperl-mode-resources/cperl-bug-66161.pl b/test/lisp/progmodes/cperl-mode-resources/cperl-bug-66161.pl
new file mode 100644
index 00000000000..e39cfdd3b24
--- /dev/null
+++ b/test/lisp/progmodes/cperl-mode-resources/cperl-bug-66161.pl
@@ -0,0 +1,13 @@
+#!/usr/bin/perl
+
+use strict;
+use warnings;
+
+print("Hello World\n");
+
+__END__
+
+TODO:
+What's happening?
+
+It's all messed up.
diff --git a/test/lisp/progmodes/cperl-mode-resources/cperl-indents.erts b/test/lisp/progmodes/cperl-mode-resources/cperl-indents.erts
index 6b874ffaa1f..ba35b1d0690 100644
--- a/test/lisp/progmodes/cperl-mode-resources/cperl-indents.erts
+++ b/test/lisp/progmodes/cperl-mode-resources/cperl-indents.erts
@@ -24,3 +24,58 @@ Name: cperl-indents1
"";
}
=-=-=
+
+Name: cperl-try-catch-finally
+
+=-=
+{
+ try {
+ call_a_function();
+ }
+ catch ($e) {
+ warn "Unable to call; $e";
+ }
+ finally {
+ print "Finished\n";
+ }
+}
+=-=-=
+
+Name: cperl-defer
+
+=-=
+use feature 'defer';
+
+{
+ say "This happens first";
+ defer {
+ say "This happens last";
+ }
+
+ say "And this happens inbetween";
+}
+=-=-=
+
+Name: cperl-feature-class
+
+=-=
+use 5.038;
+use feature "class";
+no warnings "experimental";
+
+class A {
+}
+
+class C
+ : isa(A)
+{
+ method with_sig_and_attr
+ : lvalue
+ ($top,$down)
+ {
+ return $top-$down;
+ }
+}
+
+say "done!";
+=-=-=
diff --git a/test/lisp/progmodes/cperl-mode-resources/grammar.pl b/test/lisp/progmodes/cperl-mode-resources/grammar.pl
index 96a86993082..9420c0d1fa8 100644
--- a/test/lisp/progmodes/cperl-mode-resources/grammar.pl
+++ b/test/lisp/progmodes/cperl-mode-resources/grammar.pl
@@ -169,4 +169,29 @@ sub erdős_number {
}
}
+=head1 And now, for something completely different
+
+Perl 5.38 supports classes with the same scope weirdness as packages.
+As long as this is experimental, CPAN tools don't play well with this,
+so some weird constructs are recommended to authors of CPAN modules.
+
+=cut
+
+package Class::Class;
+
+our $VERSION = 0.01;
+
+class Class::Class 0.01 {
+ method init ($with,$signature) {
+ ...;
+ }
+
+ class Class::Inner :isa(Class::Class);
+ # This class comes without a block, so takes over until the rest
+ # of the containing block.
+ method init_again (@with_parameters) {
+ ...;
+ }
+}
+
1;
diff --git a/test/lisp/progmodes/cperl-mode-resources/perl-class.pl b/test/lisp/progmodes/cperl-mode-resources/perl-class.pl
new file mode 100644
index 00000000000..032690d20a5
--- /dev/null
+++ b/test/lisp/progmodes/cperl-mode-resources/perl-class.pl
@@ -0,0 +1,19 @@
+use 5.038;
+use feature 'class';
+no warnings 'experimental';
+
+class A {
+}
+
+class C
+ : isa(A)
+{
+ method with_sig_and_attr
+ : lvalue
+ ($top,$down)
+ {
+ return $top-$down;
+ }
+}
+
+say "done!";
diff --git a/test/lisp/progmodes/cperl-mode-resources/proto-and-attrs.pl b/test/lisp/progmodes/cperl-mode-resources/proto-and-attrs.pl
index 7138bf631df..1f898250252 100644
--- a/test/lisp/progmodes/cperl-mode-resources/proto-and-attrs.pl
+++ b/test/lisp/progmodes/cperl-mode-resources/proto-and-attrs.pl
@@ -12,12 +12,10 @@ no warnings 'experimental::signatures';
# are somewhat frowned upon most of the times, but they are required
# for some Perl magic
-# FIXME: 2022-02-02 CPerl mode does not handle subroutine signatures.
-# In simple cases it mistakes them as prototypes, when attributes are
-# present, it doesn't handle them at all. Variables in signatures
-# SHOULD be fontified like variable declarations.
-
# Part 1: Named subroutines
+# A plain named subroutine without any optional stuff
+sub sub_0 { ...; }
+
# A prototype and a trivial subroutine attribute
{
no feature 'signatures'; # that's a prototype, not a signature
@@ -30,10 +28,24 @@ sub sub_2 :prototype($) { ...; }
# A signature (these will soon-ish leave the experimental state)
sub sub_3 ($foo,$bar) { ...; }
-# Attribute plus signature FIXME: Not yet supported
-sub bad_sub_4 :prototype($$$) ($foo,$bar,$baz) { ...; }
+# Attribute plus signature
+sub sub_4 :prototype($$$) ($foo,$bar,$baz) { ...; }
+
+# A signature with a trailing comma (weird, but legal)
+sub sub_5 ($foo,$bar,) { ...; }
+
+# Perl 5.38-style initializer
+sub sub_6
+ ($foo,
+ $bar //= "baz")
+{
+}
+
# Part 2: Same constructs for anonymous subs
+# A plain named subroutine without any optional stuff
+my $subref_0 = sub { ...; };
+
# A prototype and a trivial subroutine attribute
{
no feature 'signatures'; # that's a prototype, not a signature
diff --git a/test/lisp/progmodes/cperl-mode-resources/sub-names.pl b/test/lisp/progmodes/cperl-mode-resources/sub-names.pl
new file mode 100644
index 00000000000..46d05b4dbd2
--- /dev/null
+++ b/test/lisp/progmodes/cperl-mode-resources/sub-names.pl
@@ -0,0 +1,25 @@
+use 5.038;
+use feature 'class';
+use warnings;
+no warnings 'experimental';
+
+class C {
+ # "method" is not yet understood by perl-mode, but it isn't
+ # relevant here: We can use "sub" because what matters is the
+ # name, which collides with a builtin.
+ sub m {
+ "m called"
+ }
+}
+
+say C->new->m;
+
+# This comment has a method name in it, and we don't want "method"
+# to be fontified as a keyword, nor "name" fontified as a name.
+
+__END__
+
+=head1 Test using the keywords POD
+
+This piece of POD has a method name in it, and we don't want "method"
+to be fontified as a keyword, nor "name" fontified as a name.
diff --git a/test/lisp/progmodes/cperl-mode-tests.el b/test/lisp/progmodes/cperl-mode-tests.el
index 9611de0a918..9d9718f719c 100644
--- a/test/lisp/progmodes/cperl-mode-tests.el
+++ b/test/lisp/progmodes/cperl-mode-tests.el
@@ -25,6 +25,10 @@
;;; Commentary:
;; This is a collection of tests for CPerl-mode.
+;; The maintainer would like to use this test file with cperl-mode.el
+;; also in older Emacs versions (currently: Emacs 26.1): Please don't
+;; use Emacs features which are not available in that version (unless
+;; they're already used in existing tests).
;;; Code:
@@ -107,9 +111,8 @@ end of the statement."
(skip-unless (eq cperl-test-mode #'cperl-mode))
(cperl--run-test-cases
(ert-resource-file "cperl-indent-styles.pl")
- (cperl-set-style "PBP")
- (indent-region (point-min) (point-max)) ; here we go!
- (cperl-set-style-back)))
+ (cperl-file-style "PBP")
+ (indent-region (point-min) (point-max)))) ; here we go!
;;; Fontification tests
@@ -177,14 +180,19 @@ attributes, prototypes and signatures."
(should (equal (get-text-property (1+ (match-beginning 0)) 'face)
'font-lock-string-face)))
(goto-char start-of-sub)
+ ;; Attributes with their optional parameters
(when (search-forward-regexp "\\(:[a-z]+\\)\\((.*?)\\)?" end-of-sub t)
(should (equal (get-text-property (match-beginning 1) 'face)
'font-lock-constant-face))
(when (match-beginning 2)
(should (equal (get-text-property (match-beginning 2) 'face)
'font-lock-string-face))))
+ ;; Subroutine signatures
+ (goto-char start-of-sub)
+ (when (search-forward "$bar" end-of-sub t)
+ (should (equal (get-text-property (match-beginning 0) 'face)
+ 'font-lock-variable-name-face)))
(goto-char end-of-sub)))
-
;; Anonymous subroutines
(while (search-forward-regexp "= sub" nil t)
(let ((start-of-sub (match-beginning 0))
@@ -201,8 +209,40 @@ attributes, prototypes and signatures."
(when (match-beginning 2)
(should (equal (get-text-property (match-beginning 2) 'face)
'font-lock-string-face))))
+ ;; Subroutine signatures
+ (goto-char start-of-sub)
+ (when (search-forward "$bar" end-of-sub t)
+ (should (equal (get-text-property (match-beginning 0) 'face)
+ 'font-lock-variable-name-face)))
(goto-char end-of-sub))))))
+(ert-deftest cperl-test-fontify-class ()
+ "Test fontification of the various elements in a Perl class."
+ (skip-unless (eq cperl-test-mode #'cperl-mode))
+ (let ((file (ert-resource-file "perl-class.pl")))
+ (with-temp-buffer
+ (insert-file-contents file)
+ (goto-char (point-min))
+ (funcall cperl-test-mode)
+ (font-lock-ensure)
+
+ ;; The class name
+ (while (search-forward-regexp "class " nil t)
+ (should (equal (get-text-property (point) 'face)
+ 'font-lock-function-name-face)))
+ ;; The attributes (class and method)
+ (while (search-forward-regexp " : " nil t)
+ (should (equal (get-text-property (point) 'face)
+ 'font-lock-constant-face)))
+ ;; The signature
+ (goto-char (point-min))
+ (search-forward-regexp "\\(\\$top\\),\\(\\$down\\)")
+ (should (equal (get-text-property (match-beginning 1) 'face)
+ 'font-lock-variable-name-face))
+ (should (equal (get-text-property (match-beginning 1) 'face)
+ 'font-lock-variable-name-face))
+)))
+
(ert-deftest cperl-test-fontify-special-variables ()
"Test fontification of variables like $^T or ${^ENCODING}.
These can occur as \"local\" aliases."
@@ -219,6 +259,39 @@ These can occur as \"local\" aliases."
(should (equal (get-text-property (point) 'face)
'font-lock-variable-name-face))))
+(ert-deftest cperl-test-fontify-sub-names ()
+ "Test fontification of subroutines named like builtins.
+On declaration, they should look like other used defined
+functions. When called, they should not be fontified. In
+comments and POD they should be fontified as POD."
+ (let ((file (ert-resource-file "sub-names.pl")))
+ (with-temp-buffer
+ (insert-file-contents file)
+ (goto-char (point-min))
+ (funcall cperl-test-mode)
+ (font-lock-ensure)
+ ;; The declaration
+ (search-forward-regexp "sub \\(m\\)")
+ (should (equal (get-text-property (match-beginning 1) 'face)
+ 'font-lock-function-name-face))
+ ;; calling as a method
+ (search-forward-regexp "C->new->\\(m\\)")
+ (should (equal (get-text-property (match-beginning 1) 'face)
+ (if (equal cperl-test-mode 'perl-mode) nil
+ 'cperl-method-call)))
+ ;; POD
+ (search-forward-regexp "\\(method\\) \\(name\\)")
+ (should (equal (get-text-property (match-beginning 1) 'face)
+ 'font-lock-comment-face))
+ (should (equal (get-text-property (match-beginning 2) 'face)
+ 'font-lock-comment-face))
+ ;; comment
+ (search-forward-regexp "\\(method\\) \\(name\\)")
+ (should (equal (get-text-property (match-beginning 1) 'face)
+ 'font-lock-comment-face))
+ (should (equal (get-text-property (match-beginning 2) 'face)
+ 'font-lock-comment-face)))))
+
(ert-deftest cperl-test-identify-heredoc ()
"Test whether a construct containing \"<<\" followed by a
bareword is properly identified for a here-document if
@@ -306,6 +379,7 @@ issued by CPerl mode."
(defvar perl-continued-statement-offset)
(defvar perl-indent-level)
+(defvar perl-indent-parens-as-block)
(defconst cperl--tests-heredoc-face
(if (equal cperl-test-mode 'perl-mode) 'perl-heredoc
@@ -397,7 +471,7 @@ the whole string."
valid invalid)))
(ert-deftest cperl-test-package-regexp ()
- "Tests the regular expression of Perl package names with versions.
+ "Tests the regular expression of Perl package and class names with versions.
Also includes valid cases with whitespace in strange places."
(skip-unless (eq cperl-test-mode #'cperl-mode))
(let ((valid
@@ -405,13 +479,13 @@ Also includes valid cases with whitespace in strange places."
"package Foo::Bar"
"package Foo::Bar v1.2.3"
"package Foo::Bar::Baz 1.1"
+ "class O3D::Sphere" ; since Perl 5.38
"package \nFoo::Bar\n 1.00"))
(invalid
'("package Foo;" ; semicolon must not be included
"package Foo 1.1 {" ; nor the opening brace
"packageFoo" ; not a package declaration
- "package Foo1.1" ; invalid package name
- "class O3D::Sphere"))) ; class not yet supported
+ "package Foo1.1"))) ; invalid package name
(cperl-test--validate-regexp (rx (eval cperl--package-rx))
valid invalid)))
@@ -428,6 +502,66 @@ Also includes valid cases with whitespace in strange places."
(cperl-test--validate-regexp (rx (eval cperl--basic-identifier-rx))
valid invalid)))
+(ert-deftest cperl-test-attribute-rx ()
+ "Test attributes and attribute lists"
+ (skip-unless (eq cperl-test-mode #'cperl-mode))
+ (let ((valid
+ '("foo" "bar()" "baz(quux)"))
+ (invalid
+ '("+foo" ; not an identifier
+ "foo::bar" ; no package qualifiers allowed
+ "(no-identifier)" ; no attribute name
+ "baz (quux)"))) ; no space allowed before "("
+ (cperl-test--validate-regexp (rx (eval cperl--single-attribute-rx))
+ valid invalid)))
+
+(ert-deftest cperl-test-attribute-list-rx ()
+ "Test attributes and attribute lists"
+ (skip-unless (eq cperl-test-mode #'cperl-mode))
+ (let ((valid
+ '(":" ":foo" ": bar()" ":baz(quux):"
+ ":_" ":_foo"
+ ":isa(Foo) does(Bar)" ":isa(Foo):does(Bar)"
+ ":isa(Foo):does(Bar):"
+ ": isa(Foo::Bar) : does(Bar)"))
+ (invalid
+ '(":foo + bar" ; not an identifier
+ "::foo" ; not an attribute list
+ ": foo(bar : : baz" ; too many colons
+ ": foo(bar)baz" ; need a separator
+ ": baz (quux)"))) ; no space allowed before "("
+ (cperl-test--validate-regexp (rx (eval cperl--attribute-list-rx))
+ valid invalid)))
+
+(ert-deftest cperl-test-prototype-rx ()
+ "Test subroutine prototypes"
+ (skip-unless (eq cperl-test-mode #'cperl-mode))
+ (let ((valid
+ ;; Examples from perldoc perlsub
+ '("($$)" "($$$)" "($$;$)" "($$$;$)" "(@)" "($@)" "(\\@)" "(\\@$$@)"
+ "(\\[%@])" "(*;$)" "(**)" "(&@)" "(;$)" "()"))
+ (invalid
+ '("$" ; missing paren
+ "($self)" ; a variable, -> subroutine signature
+ "(!$)" ; not all punctuation is permitted
+ "{$$}"))) ; wrong type of paren
+ (cperl-test--validate-regexp (rx (eval cperl--prototype-rx))
+ valid invalid)))
+
+(ert-deftest cperl-test-signature-rx ()
+ "Test subroutine signatures."
+ (skip-unless (eq cperl-test-mode #'cperl-mode))
+ (let ((valid
+ '("()" "( )" "($self, %params)" "(@params)"))
+ (invalid
+ '("$self" ; missing paren
+ "($)" ; a subroutine signature
+ "($!)" ; globals not permitted in a signature
+ "(@par,%options)" ; two slurpy parameters
+ "{$self}"))) ; wrong type of paren
+ (cperl-test--validate-regexp (rx (eval cperl--signature-rx))
+ valid invalid)))
+
;;; Test unicode identifier in various places
(defun cperl--test-unicode-setup (code string)
@@ -717,7 +851,9 @@ created by CPerl mode, so skip it for Perl mode."
"lexical"
"Versioned::Block::signatured"
"Package::in_package_again"
- "Erdős::Number::erdős_number")))
+ "Erdős::Number::erdős_number"
+ "Class::Class::init"
+ "Class::Inner::init_again")))
(dolist (sub expected)
(should (assoc-string sub index)))))))
@@ -788,6 +924,17 @@ under timeout control."
(should (string-match
"poop ('foo', \n 'bar')" (buffer-string))))))
+(ert-deftest cperl-test-bug-11733 ()
+ "Verify indentation of braces after newline and non-labels."
+ (skip-unless (eq cperl-test-mode #'cperl-mode))
+ (cperl--run-test-cases
+ (ert-resource-file "cperl-bug-11733.pl")
+ (goto-char (point-min))
+ (while (null (eobp))
+ (cperl-indent-command)
+ (forward-line 1))))
+
+
(ert-deftest cperl-test-bug-11996 ()
"Verify that we give the right syntax property to a backslash operator."
(with-temp-buffer
@@ -995,6 +1142,19 @@ Perl is not Lisp: An open paren in column 0 does not start a function."
(cperl-indent-command)
(forward-line 1))))
+(ert-deftest cperl-test-bug-35925 ()
+ "Check that indentation is correct after a terminating format declaration."
+ (cperl--run-test-cases
+ (ert-resource-file "cperl-bug-35925.pl")
+ (cperl-file-style "PBP") ; Make cperl-mode use the same settings as perl-mode.
+ (let ((tab-function
+ (if (equal cperl-test-mode 'perl-mode)
+ #'indent-for-tab-command
+ #'cperl-indent-command)))
+ (goto-char (point-max))
+ (forward-line -2)
+ (funcall tab-function))))
+
(ert-deftest cperl-test-bug-37127 ()
"Verify that closing a paren in a regex goes without a message.
Also check that the message is issued if the regex terminator is
@@ -1145,6 +1305,151 @@ as a regex."
(funcall cperl-test-mode)
(should-not (nth 3 (syntax-ppss 3)))))
+(ert-deftest cperl-test-bug-64190 ()
+ "Verify correct fontification of multiline declarations"
+ (skip-unless (eq cperl-test-mode #'cperl-mode))
+ (let ((file (ert-resource-file "cperl-bug-64190.pl")))
+ (with-temp-buffer
+ (insert-file-contents file)
+ (goto-char (point-min))
+ (cperl-mode)
+ (font-lock-ensure)
+ ;; Example 1
+ (while (search-forward "var" nil t)
+ (should (equal (get-text-property (point) 'face)
+ 'font-lock-variable-name-face)))
+ ;; Example 2
+ (search-forward "package F")
+ (should (equal (get-text-property (point) 'face)
+ 'font-lock-function-name-face))
+
+ ;; Example 3 and 4 can't be directly tested because jit-lock and
+ ;; batch tests don't play together well. But we can approximate
+ ;; the behavior by calling the the fontification for the same
+ ;; region which would be used by jit-lock.
+ ;; Example 3
+ (search-forward "sub do_stuff")
+ (let ((start-change (point)))
+ (insert "\n{")
+ (cperl-font-lock-fontify-region-function start-change
+ (point-max)
+ nil) ; silent
+ (font-lock-ensure start-change (point-max))
+ (goto-char (1- start-change)) ; between the "ff" in "stuff"
+ (should (equal (get-text-property (point) 'face)
+ 'font-lock-function-name-face))
+ (search-forward "{")
+ (insert "}")) ; make it legal again
+
+ ;; Example 4
+ (search-forward "$param2")
+ (beginning-of-line)
+ (let ((start-change (point)))
+ (insert " ")
+ (cperl-font-lock-fontify-region-function start-change
+ (point-max)
+ nil) ; silent
+ (font-lock-ensure start-change (point-max))
+ (goto-char (1+ start-change))
+ (should (equal (get-text-property (point) 'face)
+ 'font-lock-variable-name-face))
+ (re-search-forward (rx (group "sub") " " (group "oops")))
+ (should (equal (get-text-property (match-beginning 1) 'face)
+ 'font-lock-keyword-face))
+ (should (equal (get-text-property (match-beginning 2) 'face)
+ 'font-lock-function-name-face))))))
+
+(ert-deftest cperl-test-bug-64364 ()
+ "Check that multi-line subroutine declarations indent correctly."
+ (cperl--run-test-cases
+ (ert-resource-file "cperl-bug-64364.pl")
+ (cperl-file-style "PBP") ; make cperl-mode use the same settings as perl-mode
+ (indent-region (point-min) (point-max)))
+ (cperl--run-test-cases
+ (ert-resource-file "cperl-bug-64364.pl")
+ (cperl-file-style "PBP") ; make cperl-mode use the same settings as perl-mode
+ (let ((tab-function
+ (if (equal cperl-test-mode 'perl-mode)
+ #'indent-for-tab-command
+ #'cperl-indent-command)))
+ (goto-char (point-min))
+ (while (null (eobp))
+ (funcall tab-function)
+ (forward-line 1)))))
+
+(ert-deftest cperl-test-bug-65834 ()
+ "Verify that CPerl mode identifies a left-shift operator.
+Left-shift and here-documents both use the \"<<\" operator.
+In the code provided by this bug report, it needs to be
+detected as left-shift operator."
+ (with-temp-buffer
+ (insert-file-contents (ert-resource-file "cperl-bug-65834.pl"))
+ (funcall cperl-test-mode)
+ (font-lock-ensure)
+ (search-forward "retur") ; leaves point before the "n"
+ (should (equal (get-text-property (point) 'face)
+ font-lock-keyword-face))
+ (search-forward "# comm") ; leaves point before "ent"
+ (should (equal (get-text-property (point) 'face)
+ font-lock-comment-face))))
+
+(ert-deftest cperl-test-bug-66145 ()
+ "Verify that hashes and arrays are only fontified in code.
+In strings, comments and POD the syntaxified faces should
+prevail. The tests exercise all combinations of sigils $@% and
+parenthesess [{ for comments, POD, strings and HERE-documents.
+Fontification in code for `cperl-mode' is done in the tests
+beginning with `cperl-test-unicode`."
+ (let ((types '("array" "hash" "key"))
+ (faces `(("string" . font-lock-string-face)
+ ("comment" . font-lock-comment-face)
+ ("here" . ,(if (equal cperl-test-mode 'perl-mode)
+ 'perl-heredoc
+ font-lock-string-face)))))
+ (with-temp-buffer
+ (insert-file-contents (ert-resource-file "cperl-bug-66145.pl"))
+ (funcall cperl-test-mode)
+ (font-lock-ensure)
+ (dolist (type types)
+ (goto-char (point-min))
+ (while (re-search-forward (concat type "_\\([a-z]+\\)") nil t)
+ (should (equal (get-text-property (match-beginning 1) 'face)
+ (cdr (assoc (match-string-no-properties 1)
+ faces)))))))))
+
+(ert-deftest cperl-test-bug-66161 ()
+ "Verify that text after \"__END__\" is fontified as comment.
+For `cperl-mode', this needs the custom variable
+`cperl-fontify-trailer' to be set to `comment'. Per default,
+cperl-mode fontifies text after the delimiter as Perl code."
+ (with-temp-buffer
+ (insert-file-contents (ert-resource-file "cperl-bug-66161.pl"))
+ (setq cperl-fontify-trailer 'comment)
+ (funcall cperl-test-mode)
+ (font-lock-ensure)
+ (search-forward "TODO") ; leaves point before the colon
+ (should (equal (get-text-property (point) 'face)
+ font-lock-comment-face))))
+
+(ert-deftest cperl-test-bug-69604 ()
+ "Verify that $\" in a double-quoted string does not end the string.
+Both `perl-mode' and `cperl-mode' treat ?$ as a quoting/escaping char to
+avoid issues with punctuation variables. In a string, however, this is
+not appropriate."
+ (let ((strings
+ '("\"$\\\" in string ---\"; # \"" ; $ must not quote \
+ "$\" . \" in string ---\"; # \"" ; $ must quote \
+ "\"\\$\" . \" in string ---\"; # \""))) ; \$ must not quote
+ (dolist (string strings)
+ (with-temp-buffer
+ (insert string)
+ (funcall cperl-test-mode)
+ (font-lock-ensure)
+ (goto-char (point-min))
+ (search-forward "in string")
+ (should (equal (get-text-property (point) 'face)
+ font-lock-string-face))))))
+
(ert-deftest test-indentation ()
(ert-test-erts-file (ert-resource-file "cperl-indents.erts")))
diff --git a/test/lisp/progmodes/eglot-tests.el b/test/lisp/progmodes/eglot-tests.el
index 0535afd6738..4725885038e 100644
--- a/test/lisp/progmodes/eglot-tests.el
+++ b/test/lisp/progmodes/eglot-tests.el
@@ -31,23 +31,20 @@
;; Some of these tests rely on the GNU ELPA package company.el and
;; yasnippet.el being available.
-;; Some of the tests require access to a remote host files. Since
-;; this could be problematic, a mock-up connection method "mock" is
-;; used. Emulating a remote connection, it simply calls "sh -i".
-;; Tramp's file name handlers still run, so this test is sufficient
-;; except for connection establishing.
-
-;; If you want to test a real Tramp connection, set
-;; $REMOTE_TEMPORARY_FILE_DIRECTORY to a suitable value in order to
-;; overwrite the default value. If you want to skip tests accessing a
-;; remote host, set this environment variable to "/dev/null" or
-;; whatever is appropriate on your system.
+;; Some of the tests require access to a remote host files, which is
+;; mocked in the simplest case. If you want to test a real Tramp
+;; connection, override $REMOTE_TEMPORARY_FILE_DIRECTORY to a suitable
+;; value (FIXME: like what?) in order to overwrite the default value.
+;;
+;; IMPORTANT: Since Eglot is a :core ELPA package, these tests are
+;; supposed to run on Emacsen down to 26.3. Do not use bleeding-edge
+;; functionality not compatible with that Emacs version.
;;; Code:
(require 'eglot)
(require 'cl-lib)
(require 'ert)
-(require 'tramp) ; must be prior ert-x
+(require 'tramp)
(require 'ert-x) ; ert-simulate-command
(require 'edebug)
(require 'cc-mode) ; c-mode-hook
@@ -58,73 +55,66 @@
;;; Helpers
+(defun eglot--test-message (format &rest args)
+ "Message out with FORMAT with ARGS."
+ (message "[eglot-tests] %s"
+ (apply #'format format args)))
+
(defmacro eglot--with-fixture (fixture &rest body)
- "Setup FIXTURE, call BODY, teardown FIXTURE.
+ "Set up FIXTURE, call BODY, tear down FIXTURE.
FIXTURE is a list. Its elements are of the form (FILE . CONTENT)
to create a readable FILE with CONTENT. FILE may be a directory
name and CONTENT another (FILE . CONTENT) list to specify a
-directory hierarchy. FIXTURE's elements can also be (SYMBOL
-VALUE) meaning SYMBOL should be bound to VALUE during BODY and
-then restored."
+directory hierarchy."
(declare (indent 1) (debug t))
- `(eglot--call-with-fixture
- ,fixture #'(lambda () ,@body)))
+ `(eglot--call-with-fixture ,fixture (lambda () ,@body)))
(defun eglot--make-file-or-dir (ass)
- (let ((file-or-dir-name (car ass))
+ (let ((file-or-dir-name (expand-file-name (car ass)))
(content (cdr ass)))
(cond ((listp content)
(make-directory file-or-dir-name 'parents)
- (let ((default-directory (concat default-directory "/" file-or-dir-name)))
+ (let ((default-directory (file-name-as-directory file-or-dir-name)))
(mapcan #'eglot--make-file-or-dir content)))
((stringp content)
- (with-temp-buffer
- (insert content)
- (write-region nil nil file-or-dir-name nil 'nomessage))
- (list (expand-file-name file-or-dir-name)))
+ (with-temp-file file-or-dir-name
+ (insert content))
+ (list file-or-dir-name))
(t
(eglot--error "Expected a string or a directory spec")))))
(defun eglot--call-with-fixture (fixture fn)
"Helper for `eglot--with-fixture'. Run FN under FIXTURE."
- (let* ((fixture-directory (make-nearby-temp-file "eglot--fixture" t))
- (default-directory fixture-directory)
- file-specs created-files
- syms-to-restore
+ (let* ((fixture-directory (make-nearby-temp-file "eglot--fixture-" t))
+ (default-directory (file-name-as-directory fixture-directory))
+ created-files
new-servers
test-body-successful-p)
- (dolist (spec fixture)
- (cond ((symbolp spec)
- (push (cons spec (symbol-value spec)) syms-to-restore)
- (set spec nil))
- ((symbolp (car spec))
- (push (cons (car spec) (symbol-value (car spec))) syms-to-restore)
- (set (car spec) (cadr spec)))
- ((stringp (car spec)) (push spec file-specs))))
+ (eglot--test-message "[%s]: test start" (ert-test-name (ert-running-test)))
(unwind-protect
- (let* ((process-environment
- (append
- `(;; Set XDF_CONFIG_HOME to /dev/null to prevent
- ;; user-configuration to have an influence on
- ;; language servers. (See github#441)
- "XDG_CONFIG_HOME=/dev/null"
- ;; ... on the flip-side, a similar technique by
- ;; Emacs's test makefiles means that HOME is
- ;; spoofed to /nonexistent, or sometimes /tmp.
- ;; This breaks some common installations for LSP
- ;; servers like pylsp, rust-analyzer making these
- ;; tests mostly useless, so we hack around it here
- ;; with a great big hack.
- ,(format "HOME=%s"
- (expand-file-name (format "~%s" (user-login-name)))))
- process-environment))
- (eglot-server-initialized-hook
- (lambda (server) (push server new-servers))))
- (setq created-files (mapcan #'eglot--make-file-or-dir file-specs))
+ (let ((process-environment
+ `(;; Set XDG_CONFIG_HOME to /dev/null to prevent
+ ;; user-configuration influencing language servers
+ ;; (see github#441).
+ ,(format "XDG_CONFIG_HOME=%s" null-device)
+ ;; ... on the flip-side, a similar technique in
+ ;; Emacs's `test/Makefile' spoofs HOME as
+ ;; /nonexistent (and as `temporary-file-directory' in
+ ;; `ert-remote-temporary-file-directory').
+ ;; This breaks some common installations for LSP
+ ;; servers like rust-analyzer, making these tests
+ ;; mostly useless, so we hack around it here with a
+ ;; great big hack.
+ ,(format "HOME=%s"
+ (expand-file-name (format "~%s" (user-login-name))))
+ ,@process-environment))
+ (eglot-server-initialized-hook
+ (lambda (server) (push server new-servers))))
+ (setq created-files (mapcan #'eglot--make-file-or-dir fixture))
(prog1 (funcall fn)
(setq test-body-successful-p t)))
- (eglot--message
- "Test body was %s" (if test-body-successful-p "OK" "A FAILURE"))
+ (eglot--test-message "[%s]: %s" (ert-test-name (ert-running-test))
+ (if test-body-successful-p "OK" "FAILED"))
(unwind-protect
(let ((eglot-autoreconnect nil))
(dolist (server new-servers)
@@ -133,8 +123,7 @@ then restored."
(eglot-shutdown
server nil 3 (not test-body-successful-p))
(error
- (eglot--message "Non-critical shutdown error after test: %S"
- oops))))
+ (eglot--test-message "Non-critical cleanup error: %S" oops))))
(when (not test-body-successful-p)
;; We want to do this after the sockets have
;; shut down such that any pending data has been
@@ -147,24 +136,21 @@ then restored."
(jsonrpc-events-buffer server)))))
(cond (noninteractive
(dolist (buffer buffers)
- (eglot--message "%s:" (buffer-name buffer))
+ (eglot--test-message "contents of `%s':" (buffer-name buffer))
(princ (with-current-buffer buffer (buffer-string))
'external-debugging-output)))
(t
- (eglot--message "Preserved for inspection: %s"
- (mapconcat #'buffer-name buffers ", "))))))))
- (eglot--cleanup-after-test fixture-directory created-files syms-to-restore)))))
+ (eglot--test-message "Preserved for inspection: %s"
+ (mapconcat #'buffer-name buffers ", "))))))))
+ (eglot--cleanup-after-test fixture-directory created-files)))))
-(defun eglot--cleanup-after-test (fixture-directory created-files syms-to-restore)
+(defun eglot--cleanup-after-test (fixture-directory created-files)
(let ((buffers-to-delete
- (delete nil (mapcar #'find-buffer-visiting created-files))))
- (eglot--message "Killing %s, wiping %s, restoring %s"
- buffers-to-delete
- fixture-directory
- (mapcar #'car syms-to-restore))
- (cl-loop for (sym . val) in syms-to-restore
- do (set sym val))
- (dolist (buf buffers-to-delete) ;; have to save otherwise will get prompted
+ (delq nil (mapcar #'find-buffer-visiting created-files))))
+ (eglot--test-message "Killing %s, wiping %s"
+ buffers-to-delete
+ fixture-directory)
+ (dolist (buf buffers-to-delete) ;; Have to save otherwise will get prompted.
(with-current-buffer buf (save-buffer) (kill-buffer)))
(delete-directory fixture-directory 'recursive)
;; Delete Tramp buffers if needed.
@@ -213,48 +199,48 @@ then restored."
&rest body)
"Run BODY saving LSP JSON messages in variables, most recent first."
(declare (indent 1) (debug (sexp &rest form)))
- (let ((log-event-ad-sym (make-symbol "eglot--event-sniff")))
- `(unwind-protect
- (let ,(delq nil (list server-requests
- server-notifications
- server-replies
- client-requests
- client-notifications
- client-replies))
- (advice-add
- #'jsonrpc--log-event :before
- (lambda (_proc message &optional type)
- (cl-destructuring-bind (&key method id _error &allow-other-keys)
- message
- (let ((req-p (and method id))
- (notif-p method)
- (reply-p id))
- (cond
- ((eq type 'server)
- (cond (req-p ,(when server-requests
- `(push message ,server-requests)))
- (notif-p ,(when server-notifications
- `(push message ,server-notifications)))
- (reply-p ,(when server-replies
- `(push message ,server-replies)))))
- ((eq type 'client)
- (cond (req-p ,(when client-requests
- `(push message ,client-requests)))
- (notif-p ,(when client-notifications
- `(push message ,client-notifications)))
- (reply-p ,(when client-replies
- `(push message ,client-replies)))))))))
- '((name . ,log-event-ad-sym)))
- ,@body)
- (advice-remove #'jsonrpc--log-event ',log-event-ad-sym))))
+ (let ((log-event-hook-sym (make-symbol "eglot--event-sniff")))
+ `(let* (,@(delq nil (list server-requests
+ server-notifications
+ server-replies
+ client-requests
+ client-notifications
+ client-replies)))
+ (cl-flet ((,log-event-hook-sym (_connection
+ origin
+ &key _json kind message _foreign-message
+ &allow-other-keys)
+ (let ((req-p (eq kind 'request))
+ (notif-p (eq kind 'notification))
+ (reply-p (eql kind 'reply)))
+ (cond
+ ((eq origin 'server)
+ (cond (req-p ,(when server-requests
+ `(push message ,server-requests)))
+ (notif-p ,(when server-notifications
+ `(push message ,server-notifications)))
+ (reply-p ,(when server-replies
+ `(push message ,server-replies)))))
+ ((eq origin 'client)
+ (cond (req-p ,(when client-requests
+ `(push message ,client-requests)))
+ (notif-p ,(when client-notifications
+ `(push message ,client-notifications)))
+ (reply-p ,(when client-replies
+ `(push message ,client-replies)))))))))
+ (unwind-protect
+ (progn
+ (add-hook 'jsonrpc-event-hook #',log-event-hook-sym)
+ ,@body)
+ (remove-hook 'jsonrpc-event-hook #',log-event-hook-sym))))))
(cl-defmacro eglot--wait-for ((events-sym &optional (timeout 1) message) args &body body)
- "Spin until FN match in EVENTS-SYM, flush events after it.
-Pass TIMEOUT to `eglot--with-timeout'."
(declare (indent 2) (debug (sexp sexp sexp &rest form)))
`(eglot--with-timeout '(,timeout ,(or message
(format "waiting for:\n%s" (pp-to-string body))))
- (let ((event
+ (eglot--test-message "waiting for `%s'" (with-output-to-string
+ (mapc #'princ ',body)))
+ (let ((events
(cl-loop thereis (cl-loop for json in ,events-sym
for method = (plist-get json :method)
when (keywordp method)
@@ -268,16 +254,21 @@ Pass TIMEOUT to `eglot--with-timeout'."
collect json into before)
for i from 0
when (zerop (mod i 5))
- ;; do (eglot--message "still struggling to find in %s"
- ;; ,events-sym)
+ ;; do (eglot--test-message "still struggling to find in %s"
+ ;; ,events-sym)
do
;; `read-event' is essential to have the file
;; watchers come through.
- (read-event "[eglot] Waiting a bit..." nil 0.1)
+ (cond ((fboundp 'flush-standard-output)
+ (read-event nil nil 0.1) (princ ".")
+ (flush-standard-output))
+ (t
+ (read-event "." nil 0.1)))
(accept-process-output nil 0.1))))
- (setq ,events-sym (cdr event))
- (eglot--message "Event detected:\n%s"
- (pp-to-string (car event))))))
+ (setq ,events-sym (cdr events))
+ (cl-destructuring-bind (&key method id &allow-other-keys) (car events)
+ (eglot--test-message "detected: %s"
+ (or method (and id (format "id=%s" id))))))))
;; `rust-mode' is not a part of Emacs, so we define these two shims
;; which should be more than enough for testing.
@@ -304,6 +295,13 @@ Pass TIMEOUT to `eglot--with-timeout'."
(setq last-command-event char)
(call-interactively (key-binding (vector char))))
+(defun eglot--clangd-version ()
+ "Report on the clangd version used in various tests."
+ (let ((version (shell-command-to-string "clangd --version")))
+ (when (string-match "version[[:space:]]+\\([0-9.]*\\)"
+ version)
+ (match-string 1 version))))
+
;;; Unit tests
@@ -311,8 +309,7 @@ Pass TIMEOUT to `eglot--with-timeout'."
"Connect to eclipse.jdt.ls server."
(skip-unless (executable-find "jdtls"))
(eglot--with-fixture
- '(("project/src/main/java/foo" . (("Main.java" . "")))
- ("project/.git/" . nil))
+ '(("project/src/main/java/foo" . (("Main.java" . ""))))
(with-current-buffer
(eglot--find-file-noselect "project/src/main/java/foo/Main.java")
(eglot--sniffing (:server-notifications s-notifs)
@@ -418,7 +415,7 @@ Pass TIMEOUT to `eglot--with-timeout'."
(and (string= method "workspace/didChangeWatchedFiles")
(cl-destructuring-bind (&key uri type)
(elt (plist-get params :changes) 0)
- (and (string= (eglot--path-to-uri "Cargo.toml") uri)
+ (and (string= (eglot-path-to-uri "Cargo.toml") uri)
(= type 3))))))))))
(ert-deftest eglot-test-basic-diagnostics ()
@@ -431,7 +428,7 @@ Pass TIMEOUT to `eglot--with-timeout'."
(eglot--find-file-noselect "diag-project/main.c")
(eglot--sniffing (:server-notifications s-notifs)
(eglot--tests-connect)
- (eglot--wait-for (s-notifs 2)
+ (eglot--wait-for (s-notifs 10)
(&key _id method &allow-other-keys)
(string= method "textDocument/publishDiagnostics"))
(flymake-start)
@@ -441,16 +438,20 @@ Pass TIMEOUT to `eglot--with-timeout'."
(ert-deftest eglot-test-diagnostic-tags-unnecessary-code ()
"Test rendering of diagnostics tagged \"unnecessary\"."
- (skip-unless (executable-find "rust-analyzer"))
- (skip-unless (executable-find "cargo"))
+ (skip-unless (executable-find "clangd"))
+ (skip-unless (version<= "14" (eglot--clangd-version)))
(eglot--with-fixture
- '(("diagnostic-tag-project" .
- (("main.rs" .
- "fn main() -> () { let test=3; }"))))
+ `(("diag-project" .
+ (("main.cpp" . "int main(){float a = 42.2; return 0;}"))))
(with-current-buffer
- (eglot--find-file-noselect "diagnostic-tag-project/main.rs")
- (let ((eglot-server-programs '((rust-mode . ("rust-analyzer")))))
- (should (zerop (shell-command "cargo init")))
+ (eglot--find-file-noselect "diag-project/main.cpp")
+ (eglot--make-file-or-dir '(".git"))
+ (eglot--make-file-or-dir
+ `("compile_commands.json" .
+ ,(jsonrpc--json-encode
+ `[(:directory ,default-directory :command "/usr/bin/c++ -Wall -c main.cpp"
+ :file ,(expand-file-name "main.cpp"))])))
+ (let ((eglot-server-programs '((c++-mode . ("clangd")))))
(eglot--sniffing (:server-notifications s-notifs)
(eglot--tests-connect)
(eglot--wait-for (s-notifs 10)
@@ -462,11 +463,11 @@ Pass TIMEOUT to `eglot--with-timeout'."
(should (eq 'eglot-diagnostic-tag-unnecessary-face (face-at-point))))))))
(defun eglot--eldoc-on-demand ()
- ;; Trick Eldoc 1.1.0 into accepting on-demand calls.
+ ;; Trick ElDoc 1.1.0 into accepting on-demand calls.
(eldoc t))
(defun eglot--tests-force-full-eldoc ()
- ;; FIXME: This uses some Eldoc implementation defatils.
+ ;; FIXME: This uses some ElDoc implementation details.
(when (buffer-live-p eldoc--doc-buffer)
(with-current-buffer eldoc--doc-buffer
(let ((inhibit-read-only t))
@@ -543,10 +544,7 @@ Pass TIMEOUT to `eglot--with-timeout'."
`(("project" . (("coiso.c" . "#include <stdio.h>\nint main () {fprin"))))
(with-current-buffer
(eglot--find-file-noselect "project/coiso.c")
- (eglot--sniffing (:server-notifications s-notifs)
- (eglot--wait-for-clangd)
- (eglot--wait-for (s-notifs 20) (&key method &allow-other-keys)
- (string= method "textDocument/publishDiagnostics")))
+ (eglot--wait-for-clangd)
(goto-char (point-max))
(completion-at-point)
(message (buffer-string))
@@ -652,7 +650,7 @@ int main() {
(should (string-match "^fprintf" (eglot--tests-force-full-eldoc))))))
(ert-deftest eglot-test-multiline-eldoc ()
- "Test Eldoc documentation from multiple osurces."
+ "Test ElDoc documentation from multiple osurces."
(skip-unless (executable-find "clangd"))
(eglot--with-fixture
`(("project" . (("coiso.c" .
@@ -704,8 +702,8 @@ int main() {
(should (zerop (shell-command "cargo init")))
(eglot--sniffing (:server-notifications s-notifs)
(should (eglot--tests-connect))
- (eglot--wait-for (s-notifs 10) (&key method &allow-other-keys)
- (string= method "textDocument/publishDiagnostics")))
+ (eglot--wait-for (s-notifs 20) (&key method &allow-other-keys)
+ (string= method "textDocument/publishDiagnostics")))
(goto-char (point-max))
(eglot--simulate-key-event ?.)
(should (looking-back "^ \\."))))))
@@ -770,33 +768,35 @@ int main() {
(should (= 4 (length (flymake--project-diagnostics))))))))))
(ert-deftest eglot-test-project-wide-diagnostics-rust-analyzer ()
- "Test diagnostics through multiple files in a TypeScript LSP."
+ "Test diagnostics through multiple files in rust-analyzer."
(skip-unless (executable-find "rust-analyzer"))
(skip-unless (executable-find "cargo"))
+ (skip-unless (executable-find "git"))
(eglot--with-fixture
'(("project" .
(("main.rs" .
- "fn main() -> () { let test=3; }")
+ "fn main() -> i32 { return 42.2;}")
("other-file.rs" .
"fn foo() -> () { let hi=3; }"))))
- (eglot--make-file-or-dir '(".git"))
(let ((eglot-server-programs '((rust-mode . ("rust-analyzer")))))
- ;; Open other-file, and see diagnostics arrive for main.rs
+ ;; Open other-file.rs, and see diagnostics arrive for main.rs,
+ ;; which we didn't open.
(with-current-buffer (eglot--find-file-noselect "project/other-file.rs")
+ (should (zerop (shell-command "git init")))
(should (zerop (shell-command "cargo init")))
(eglot--sniffing (:server-notifications s-notifs)
(eglot--tests-connect)
(flymake-start)
- (eglot--wait-for (s-notifs 10)
- (&key _id method &allow-other-keys)
- (string= method "textDocument/publishDiagnostics"))
- (let ((diags (flymake--project-diagnostics)))
- (should (= 2 (length diags)))
- ;; Check that we really get a diagnostic from main.rs, and
- ;; not from other-file.rs
- (should (string-suffix-p
- "main.rs"
- (flymake-diagnostic-buffer (car diags))))))))))
+ (eglot--wait-for (s-notifs 20)
+ (&key _id method params &allow-other-keys)
+ (and (string= method "textDocument/publishDiagnostics")
+ (string-suffix-p "main.rs" (plist-get params :uri))))
+ (let* ((diags (flymake--project-diagnostics)))
+ (should (cl-some (lambda (diag)
+ (let ((locus (flymake-diagnostic-buffer diag)))
+ (and (stringp (flymake-diagnostic-buffer diag))
+ (string-suffix-p "main.rs" locus))))
+ diags))))))))
(ert-deftest eglot-test-json-basic ()
"Test basic autocompletion in vscode-json-languageserver."
@@ -853,9 +853,9 @@ int main() {
(skip-unless (executable-find "clangd"))
(eglot--with-fixture
`(("project" . (("foo.c" . "int foo() {return 42;}")
- ("bar.c" . "int bar() {return 42;}")))
- (c-mode-hook (eglot-ensure)))
- (let (server)
+ ("bar.c" . "int bar() {return 42;}"))))
+ (let ((c-mode-hook '(eglot-ensure))
+ server)
;; need `ert-simulate-command' because `eglot-ensure'
;; relies on `post-command-hook'.
(with-current-buffer
@@ -924,7 +924,7 @@ int main() {
(should-error (apply #'eglot--connect (eglot--guess-contact)))))))
(ert-deftest eglot-test-capabilities ()
- "Unit test for `eglot--server-capable'."
+ "Unit test for `eglot-server-capable'."
(cl-letf (((symbol-function 'eglot--capabilities)
(lambda (_dummy)
;; test data lifted from Golangserver example at
@@ -939,11 +939,11 @@ int main() {
:xdefinitionProvider t :xworkspaceSymbolByProperties t)))
((symbol-function 'eglot--current-server-or-lose)
(lambda () nil)))
- (should (eql 2 (eglot--server-capable :textDocumentSync)))
- (should (eglot--server-capable :completionProvider :triggerCharacters))
- (should (equal '(:triggerCharacters ["."]) (eglot--server-capable :completionProvider)))
- (should-not (eglot--server-capable :foobarbaz))
- (should-not (eglot--server-capable :textDocumentSync :foobarbaz))))
+ (should (eql 2 (eglot-server-capable :textDocumentSync)))
+ (should (eglot-server-capable :completionProvider :triggerCharacters))
+ (should (equal '(:triggerCharacters ["."]) (eglot-server-capable :completionProvider)))
+ (should-not (eglot-server-capable :foobarbaz))
+ (should-not (eglot-server-capable :textDocumentSync :foobarbaz))))
(defmacro eglot--without-interface-warnings (&rest body)
(let ((eglot-strict-mode nil))
@@ -1039,7 +1039,8 @@ int main() {
(cl-defmacro eglot--guessing-contact ((interactive-sym
prompt-args-sym
guessed-class-sym guessed-contact-sym
- &optional guessed-lang-id-sym)
+ &optional guessed-major-modes-sym
+ guessed-lang-ids-sym)
&body body)
"Guess LSP contact with `eglot--guessing-contact', evaluate BODY.
@@ -1049,10 +1050,10 @@ BODY is evaluated twice, with INTERACTIVE bound to the boolean passed to
If the user would have been prompted, PROMPT-ARGS-SYM is bound to
the list of arguments that would have been passed to
`read-shell-command', else nil. GUESSED-CLASS-SYM,
-GUESSED-CONTACT-SYM and GUESSED-LANG-ID-SYM are bound to the
-useful return values of `eglot--guess-contact'. Unless the
-server program evaluates to \"a-missing-executable.exe\", this
-macro will assume it exists."
+GUESSED-CONTACT-SYM, GUESSED-LANG-IDS-SYM and
+GUESSED-MAJOR-MODES-SYM are bound to the useful return values of
+`eglot--guess-contact'. Unless the server program evaluates to
+\"a-missing-executable.exe\", this macro will assume it exists."
(declare (indent 1) (debug t))
(let ((i-sym (cl-gensym)))
`(dolist (,i-sym '(nil t))
@@ -1068,8 +1069,9 @@ macro will assume it exists."
`(lambda (&rest args) (setq ,prompt-args-sym args) "")
`(lambda (&rest _dummy) ""))))
(cl-destructuring-bind
- (_ _ ,guessed-class-sym ,guessed-contact-sym
- ,(or guessed-lang-id-sym '_))
+ (,(or guessed-major-modes-sym '_)
+ _ ,guessed-class-sym ,guessed-contact-sym
+ ,(or guessed-lang-ids-sym '_))
(eglot--guess-contact ,i-sym)
,@body))))))
@@ -1164,16 +1166,17 @@ macro will assume it exists."
(ert-deftest eglot-test-server-programs-guess-lang ()
(let ((major-mode 'foo-mode))
(let ((eglot-server-programs '((foo-mode . ("prog-executable")))))
- (eglot--guessing-contact (_ nil _ _ guessed-lang)
- (should (equal guessed-lang "foo"))))
+ (eglot--guessing-contact (_ nil _ _ _ guessed-langs)
+ (should (equal guessed-langs '("foo")))))
(let ((eglot-server-programs '(((foo-mode :language-id "bar")
. ("prog-executable")))))
- (eglot--guessing-contact (_ nil _ _ guessed-lang)
- (should (equal guessed-lang "bar"))))
+ (eglot--guessing-contact (_ nil _ _ _ guessed-langs)
+ (should (equal guessed-langs '("bar")))))
(let ((eglot-server-programs '(((baz-mode (foo-mode :language-id "bar"))
. ("prog-executable")))))
- (eglot--guessing-contact (_ nil _ _ guessed-lang)
- (should (equal guessed-lang "bar"))))))
+ (eglot--guessing-contact (_ nil _ _ modes guessed-langs)
+ (should (equal guessed-langs '("bar" "baz")))
+ (should (equal modes '(foo-mode baz-mode)))))))
(defun eglot--glob-match (glob str)
(funcall (eglot--glob-compile glob t t) str))
@@ -1233,14 +1236,27 @@ macro will assume it exists."
(defun eglot--call-with-tramp-test (fn)
;; Set up a Tramp method that’s just a shell so the remote host is
;; really just the local host.
- (let* ((tramp-remote-path (cons 'tramp-own-remote-path tramp-remote-path))
+ (let* ((tramp-remote-path (cons 'tramp-own-remote-path
+ tramp-remote-path))
(tramp-histfile-override t)
(tramp-allow-unsafe-temporary-files t)
(tramp-verbose 1)
- (temporary-file-directory ert-remote-temporary-file-directory)
+ (temporary-file-directory
+ (or (bound-and-true-p ert-remote-temporary-file-directory)
+ (prog1 (format "/mock::%s" temporary-file-directory)
+ (add-to-list
+ 'tramp-methods
+ '("mock"
+ (tramp-login-program "sh") (tramp-login-args (("-i")))
+ (tramp-direct-async ("-c")) (tramp-remote-shell "/bin/sh")
+ (tramp-remote-shell-args ("-c")) (tramp-connection-timeout 10)))
+ (add-to-list 'tramp-default-host-alist
+ `("\\`mock\\'" nil ,(system-name)))
+ (when (and noninteractive (not (file-directory-p "~/")))
+ (setenv "HOME" temporary-file-directory)))))
(default-directory temporary-file-directory))
;; We must check the remote LSP server. So far, just "clangd" is used.
- (unless (executable-find "clangd" 'remote)
+ (unless (ignore-errors (executable-find "clangd" 'remote))
(ert-skip "Remote clangd not found"))
(funcall fn)))
@@ -1257,9 +1273,9 @@ macro will assume it exists."
(ert-deftest eglot-test-path-to-uri-windows ()
(skip-unless (eq system-type 'windows-nt))
(should (string-prefix-p "file:///"
- (eglot--path-to-uri "c:/Users/Foo/bar.lisp")))
+ (eglot-path-to-uri "c:/Users/Foo/bar.lisp")))
(should (string-suffix-p "c%3A/Users/Foo/bar.lisp"
- (eglot--path-to-uri "c:/Users/Foo/bar.lisp"))))
+ (eglot-path-to-uri "c:/Users/Foo/bar.lisp"))))
(ert-deftest eglot-test-same-server-multi-mode ()
"Check single LSP instance manages multiple modes in same project."
@@ -1287,8 +1303,9 @@ macro will assume it exists."
(should (eq (eglot-current-server) server))))))
(provide 'eglot-tests)
-;;; eglot-tests.el ends here
;; Local Variables:
;; checkdoc-force-docstrings-flag: nil
;; End:
+
+;;; eglot-tests.el ends here
diff --git a/test/lisp/progmodes/elisp-mode-tests.el b/test/lisp/progmodes/elisp-mode-tests.el
index 619ab58f9f1..1d1ef9981e5 100644
--- a/test/lisp/progmodes/elisp-mode-tests.el
+++ b/test/lisp/progmodes/elisp-mode-tests.el
@@ -128,7 +128,7 @@
(ert-deftest eval-last-sexp-print-format-sym-echo ()
;; We can only check the echo area when running interactive.
- (skip-unless (not noninteractive))
+ (skip-when noninteractive)
(with-temp-buffer
(let ((current-prefix-arg nil))
(erase-buffer) (insert "t") (message nil)
@@ -147,7 +147,7 @@
(should (equal (buffer-string) "?A65 (#o101, #x41, ?A)")))))
(ert-deftest eval-last-sexp-print-format-small-int-echo ()
- (skip-unless (not noninteractive))
+ (skip-when noninteractive)
(with-temp-buffer
(let ((current-prefix-arg nil))
(erase-buffer) (insert "?A") (message nil)
@@ -171,7 +171,7 @@
(should (equal (buffer-string) "?B66 (#o102, #x42, ?B)"))))))
(ert-deftest eval-last-sexp-print-format-large-int-echo ()
- (skip-unless (not noninteractive))
+ (skip-when noninteractive)
(with-temp-buffer
(let ((eval-expression-print-maximum-character ?A))
(let ((current-prefix-arg nil))
@@ -186,7 +186,7 @@
;;; eval-defun
(ert-deftest eval-defun-prints-edebug-when-instrumented ()
- (skip-unless (not noninteractive))
+ (skip-when noninteractive)
(with-temp-buffer
(let ((current-prefix-arg '(4)))
(erase-buffer) (insert "(defun foo ())") (message nil)
@@ -1004,6 +1004,11 @@ evaluation of BODY."
(should (equal (elisp--xref-infer-namespace p6) 'function)))
(elisp-mode-test--with-buffer
+ (concat "(defclass child-class ({p1}parent-1 {p2}parent-2))\n")
+ (should (equal (elisp--xref-infer-namespace p1) 'function))
+ (should (equal (elisp--xref-infer-namespace p2) 'function)))
+
+ (elisp-mode-test--with-buffer
(concat "(require '{p1}alpha)\n"
"(fboundp '{p2}beta)\n"
"(boundp '{p3}gamma)\n"
diff --git a/test/lisp/progmodes/elixir-ts-mode-resources/indent.erts b/test/lisp/progmodes/elixir-ts-mode-resources/indent.erts
new file mode 100644
index 00000000000..f2d0eacee5b
--- /dev/null
+++ b/test/lisp/progmodes/elixir-ts-mode-resources/indent.erts
@@ -0,0 +1,390 @@
+Code:
+ (lambda ()
+ (elixir-ts-mode)
+ (indent-region (point-min) (point-max)))
+
+Point-Char: $
+
+Name: Basic modules
+
+=-=
+ defmodule Foobar do
+def bar() do
+"one"
+ end
+ end
+=-=
+defmodule Foobar do
+ def bar() do
+ "one"
+ end
+end
+=-=-=
+
+Name: Map
+
+=-=
+map = %{
+ "a" => 1,
+ "b" => 2
+}
+=-=-=
+
+Name: Map in function def
+
+=-=
+def foobar() do
+ %{
+ one: "one",
+ two: "two",
+ three: "three",
+ four: "four"
+ }
+end
+=-=-=
+
+Name: Map in tuple
+
+=-=
+def foo() do
+ {:ok,
+ %{
+ state
+ | extra_arguments: extra_arguments,
+ max_children: max_children,
+ max_restarts: max_restarts,
+ max_seconds: max_seconds,
+ strategy: strategy
+ }}
+end
+=-=-=
+
+Name: Nested maps
+
+=-=
+%{
+ foo: "bar",
+ bar: %{
+ foo: "bar"
+ }
+}
+
+def foo() do
+ %{
+ foo: "bar",
+ bar: %{
+ foo: "bar"
+ }
+ }
+end
+=-=-=
+
+Name: Bitstring mulitline
+
+=-=
+<<12, 22,
+22, 32
+ >>
+=-=
+<<12, 22,
+ 22, 32
+>>
+=-=-=
+
+Name: Block assignments
+
+=-=
+foo =
+ if true do
+ "yes"
+ else
+ "no"
+ end
+=-=-=
+
+Name: Function rescue
+
+=-=
+def foo do
+ "bar"
+rescue
+ e ->
+ "bar"
+end
+=-=-=
+
+Name: With statement
+=-=
+with one <- one(),
+ two <- two(),
+ {:ok, value} <- get_value(one, two) do
+ {:ok, value}
+else
+ {:error, %{"Message" => message}} ->
+ {:error, message}
+end
+=-=-=
+
+Name: Pipe statements with fn
+
+=-=
+[1, 2]
+|> Enum.map(fn num ->
+ num + 1
+end)
+=-=-=
+
+Name: Pipe statements stab clauses
+
+=-=
+[1, 2]
+|> Enum.map(fn
+ x when x < 10 -> x * 2
+ x -> x * 3
+end)
+=-=-=
+
+Name: Pipe statements params
+
+=-=
+[1, 2]
+|> foobar(
+ :one,
+ :two,
+ :three,
+ :four
+)
+=-=-=
+
+Name: Parameter maps
+
+=-=
+def something(%{
+ one: :one,
+ two: :two
+ }) do
+ {:ok, "done"}
+end
+=-=-=
+
+Name: Binary operator in else block
+
+=-=
+defp foobar() do
+ if false do
+ :foo
+ else
+ :bar |> foo
+ end
+end
+=-=-=
+
+Name: Tuple indentation
+
+=-=
+tuple = {
+ :one,
+ :two
+}
+
+{
+ :one,
+ :two
+}
+=-=-=
+
+Name: Call with keywords
+
+=-=
+def foo() do
+ bar(:one,
+ :two,
+ one: 1,
+ two: 2
+ )
+end
+=-=-=
+
+Name: Call with @spec
+
+=-=
+@spec foobar(
+ t,
+ acc,
+ (one, something -> :bar | far),
+ (two -> :bar | far)
+ ) :: any()
+ when chunk: any
+def foobar(enumerable, acc, chunk_fun, after_fun) do
+ {_, {res, acc}} =
+ case after_fun.(acc) do
+ {:one, "one"} ->
+ "one"
+
+ {:two, "two"} ->
+ "two"
+ end
+end
+=-=-=
+
+Name: Spec with multi-line result
+
+=-=
+@type result ::
+ {:done, term}
+ | {:two}
+ | {:one}
+
+@type result ::
+ {
+ :done,
+ term
+ }
+ | {:two}
+ | {:one}
+
+@type boo_bar ::
+ (foo :: pos_integer, bar :: pos_integer -> any())
+
+@spec foo_bar(
+ t,
+ (foo -> any),
+ (() -> any) | (foo, foo -> boolean) | module()
+ ) :: any
+ when foo: any
+def foo(one, fun, other)
+=-=-=
+
+Name: String concatenation in call
+
+=-=
+IO.warn(
+ "one" <>
+ "two" <>
+ "bar"
+)
+
+IO.warn(
+ "foo" <>
+ "bar"
+)
+=-=-=
+
+Name: Incomplete tuple
+
+=-=
+map = {
+:foo
+
+=-=
+map = {
+ :foo
+
+=-=-=
+
+Name: Incomplete map
+
+=-=
+map = %{
+ "a" => "a",
+=-=-=
+
+Name: Incomplete list
+
+=-=
+map = [
+:foo
+
+=-=
+map = [
+ :foo
+
+=-=-=
+
+Name: String concatenation
+
+=-=
+"one" <>
+ "two" <>
+ "three" <>
+ "four"
+=-=-=
+
+Name: Tuple with same line first node
+
+=-=
+{:one,
+ :two}
+
+{:ok,
+ fn one ->
+ one
+ |> String.upcase(one)
+ end}
+=-=-=
+
+Name: Long tuple
+
+=-=
+{"January", "February", "March", "April", "May", "June", "July", "August", "September",
+ "October", "November", "December"}
+=-=-=
+
+Name: Doc
+
+=-=
+defmodule Foo do
+"""
+ bar
+ """
+end
+=-=
+defmodule Foo do
+ """
+ bar
+ """
+end
+=-=-=
+
+Name: Embedded HEEx
+
+=-=
+ defmodule Foo do
+ def foo(assigns) do
+~H"""
+<span>
+text
+</span>
+"""
+ end
+ end
+=-=
+defmodule Foo do
+ def foo(assigns) do
+ ~H"""
+ <span>
+ text
+ </span>
+ """
+ end
+end
+=-=-=
+
+Code:
+ (lambda ()
+ (elixir-ts-mode)
+ (newline)
+ (indent-for-tab-command))
+
+Name: New list item
+
+=-=
+[
+ :foo,$
+]
+=-=
+[
+ :foo,
+ $
+]
+=-=-=
diff --git a/test/lisp/progmodes/elixir-ts-mode-tests.el b/test/lisp/progmodes/elixir-ts-mode-tests.el
new file mode 100644
index 00000000000..109030a4476
--- /dev/null
+++ b/test/lisp/progmodes/elixir-ts-mode-tests.el
@@ -0,0 +1,31 @@
+;;; elixir-ts-mode-tests.el --- Tests for elixir-ts-mode -*- lexical-binding: t; -*-
+
+;; Copyright (C) 2023-2024 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 <https://www.gnu.org/licenses/>.
+
+;;; Code:
+
+(require 'ert)
+(require 'ert-x)
+(require 'treesit)
+
+(ert-deftest elixir-ts-mode-test-indentation ()
+ (skip-unless (and (treesit-ready-p 'elixir) (treesit-ready-p 'heex)))
+ (ert-test-erts-file (ert-resource-file "indent.erts")))
+
+(provide 'elixir-ts-mode-tests)
+;;; elixir-ts-mode-tests.el ends here
diff --git a/test/lisp/progmodes/flymake-tests.el b/test/lisp/progmodes/flymake-tests.el
index 23ebca3dc25..21dbb0711d2 100644
--- a/test/lisp/progmodes/flymake-tests.el
+++ b/test/lisp/progmodes/flymake-tests.el
@@ -213,6 +213,7 @@ SEVERITY-PREDICATE is used to setup
(ert-deftest dummy-backends ()
"Test many different kinds of backends."
+ (let ((debug-on-error nil))
(with-temp-buffer
(cl-letf
(((symbol-function 'error-backend)
@@ -291,7 +292,7 @@ SEVERITY-PREDICATE is used to setup
(should (eq 'flymake-warning (face-at-point))) ; dolor
(flymake-goto-next-error)
(should (eq 'flymake-error (face-at-point))) ; prognata
- (should-error (flymake-goto-next-error nil nil t))))))
+ (should-error (flymake-goto-next-error nil nil t)))))))
(ert-deftest recurrent-backend ()
"Test a backend that calls REPORT-FN multiple times."
diff --git a/test/lisp/progmodes/grep-tests.el b/test/lisp/progmodes/grep-tests.el
index acca9b66eb1..303e5e90042 100644
--- a/test/lisp/progmodes/grep-tests.el
+++ b/test/lisp/progmodes/grep-tests.el
@@ -66,4 +66,18 @@
(cl-letf (((symbol-function 'w32-shell-dos-semantics) #'ignore))
(grep-tests--check-rgrep-abbreviation))))
+(ert-deftest grep-tests--grep-heading-regexp-without-null ()
+ (dolist (sep '(?: ?- ?=))
+ (let ((string (format "filename%c123%ctext" sep sep)))
+ (should (string-match grep-heading-regexp string))
+ (should (equal (match-string 1 string) "filename"))
+ (should (equal (match-string 2 string) (format "filename%c" sep))))))
+
+(ert-deftest grep-tests--grep-heading-regexp-with-null ()
+ (dolist (sep '(?: ?- ?=))
+ (let ((string (format "funny:0:filename%c123%ctext" 0 sep)))
+ (should (string-match grep-heading-regexp string))
+ (should (equal (match-string 1 string) "funny:0:filename"))
+ (should (equal (match-string 2 string) "funny:0:filename\0")))))
+
;;; grep-tests.el ends here
diff --git a/test/lisp/progmodes/heex-ts-mode-resources/indent.erts b/test/lisp/progmodes/heex-ts-mode-resources/indent.erts
new file mode 100644
index 00000000000..500ddb2b536
--- /dev/null
+++ b/test/lisp/progmodes/heex-ts-mode-resources/indent.erts
@@ -0,0 +1,47 @@
+Code:
+ (lambda ()
+ (setq indent-tabs-mode nil)
+ (heex-ts-mode)
+ (indent-region (point-min) (point-max)))
+
+Point-Char: $
+
+Name: Tag
+
+=-=
+ <div>
+ div
+ </div>
+=-=
+<div>
+ div
+</div>
+=-=-=
+
+Name: Component
+
+=-=
+ <Foo>
+ foobar
+ </Foo>
+=-=
+<Foo>
+ foobar
+</Foo>
+=-=-=
+
+Name: Slots
+
+=-=
+ <Foo>
+ <:bar>
+ foobar
+ </:bar>
+ </Foo>
+=-=
+<Foo>
+ <:bar>
+ foobar
+ </:bar>
+</Foo>
+=-=-=
diff --git a/test/lisp/progmodes/heex-ts-mode-tests.el b/test/lisp/progmodes/heex-ts-mode-tests.el
new file mode 100644
index 00000000000..7f9c0bf272c
--- /dev/null
+++ b/test/lisp/progmodes/heex-ts-mode-tests.el
@@ -0,0 +1,31 @@
+;;; heex-ts-mode-tests.el --- Tests for heex-ts-mode -*- lexical-binding: t; -*-
+
+;; Copyright (C) 2023-2024 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 <https://www.gnu.org/licenses/>.
+
+;;; Code:
+
+(require 'ert)
+(require 'ert-x)
+(require 'treesit)
+
+(ert-deftest heex-ts-mode-test-indentation ()
+ (skip-unless (treesit-ready-p 'heex))
+ (ert-test-erts-file (ert-resource-file "indent.erts")))
+
+(provide 'heex-ts-mode-tests)
+;;; heex-ts-mode-tests.el ends here
diff --git a/test/lisp/progmodes/java-ts-mode-tests.el b/test/lisp/progmodes/java-ts-mode-tests.el
index a05c60b797e..9fa313e173e 100644
--- a/test/lisp/progmodes/java-ts-mode-tests.el
+++ b/test/lisp/progmodes/java-ts-mode-tests.el
@@ -28,8 +28,6 @@
(ert-test-erts-file (ert-resource-file "indent.erts")))
(ert-deftest java-ts-mode-test-movement ()
- :expected-result :failed ;in emacs-29 no sexp
- ;navigation
(skip-unless (treesit-ready-p 'java))
(ert-test-erts-file (ert-resource-file "movement.erts")))
diff --git a/test/lisp/progmodes/lua-ts-mode-resources/font-lock.lua b/test/lisp/progmodes/lua-ts-mode-resources/font-lock.lua
new file mode 100644
index 00000000000..93d589e3825
--- /dev/null
+++ b/test/lisp/progmodes/lua-ts-mode-resources/font-lock.lua
@@ -0,0 +1,339 @@
+#!/usr/bin/env lua
+-- ^ font-lock-comment-face
+-- Comment
+-- <- font-lock-comment-delimiter-face
+-- ^ font-lock-comment-face
+--[[
+-- ^ font-lock-comment-face
+Multi-line comment
+-- ^ font-lock-comment-face
+]]
+-- <- font-lock-comment-face
+local line_comment = "comment" -- comment
+-- ^ font-lock-comment-face
+
+-- Definition
+local function f1() end
+-- ^ font-lock-function-name-face
+local f2 = function() end
+-- ^ font-lock-function-name-face
+local tb = { f1 = function() end }
+-- ^ font-lock-function-name-face
+function tb.f2() end
+-- ^ font-lock-function-name-face
+function tb:f3() end
+-- ^ font-lock-function-name-face
+tbl.f4 = function() end
+-- ^ font-lock-function-name-face
+function x.y:z() end
+-- ^ font-lock-function-name-face
+
+-- Keyword
+if true then
+-- <- font-lock-keyword-face
+-- ^ font-lock-keyword-face
+elseif true then
+-- <- font-lock-keyword-face
+else end
+-- <- font-lock-keyword-face
+-- ^ font-lock-keyword-face
+local p = {}
+-- ^ font-lock-keyword-face
+for k,v in pairs({}) do end
+-- <- font-lock-keyword-face
+-- ^ font-lock-keyword-face
+repeat if true then break end until false
+-- <- font-lock-keyword-face
+-- ^ font-lock-keyword-face
+-- ^ font-lock-keyword-face
+while true do end
+-- <- font-lock-keyword-face
+-- ^ font-lock-keyword-face
+function fn() return true end
+-- <- font-lock-keyword-face
+-- ^ font-lock-keyword-face
+goto label1
+-- ^ font-lock-keyword-face
+::label1::
+if true and not false or nil then
+-- ^ font-lock-keyword-face
+-- ^ font-lock-keyword-face
+-- ^ font-lock-keyword-face
+end
+
+-- String
+local _
+_ = "x"
+-- ^ font-lock-string-face
+_ = 'x'
+-- ^ font-lock-string-face
+_ = "x\ty"
+-- ^ font-lock-string-face
+-- ^ font-lock-string-face
+_ = "x\"y"
+-- ^ font-lock-string-face
+-- ^ font-lock-string-face
+_ = 'x\'y'
+-- ^ font-lock-string-face
+-- ^ font-lock-string-face
+_ = "x\z
+ y"
+-- ^ font-lock-string-face
+_ = "x\0900y"
+-- ^ font-lock-string-face
+_ = "x\09y"
+-- ^ font-lock-string-face
+_ = "x\0y"
+-- ^ font-lock-string-face
+_ = "x\u{1f602}y"
+-- ^ font-lock-string-face
+_ = [[x]]
+-- ^ font-lock-string-face
+_ = [=[x]=]
+-- ^ font-lock-string-face
+
+-- Assignment
+local n = 0
+-- ^ font-lock-variable-name-face
+o, p, q = 1, 2, 3
+-- <- font-lock-variable-name-face
+-- ^ font-lock-variable-name-face
+-- ^ font-lock-variable-name-face
+tbl[k] = "A"
+-- ^ font-lock-variable-name-face
+tbl.x = 1
+-- ^ font-lock-variable-name-face
+for i=0,9 do end
+-- ^ font-lock-variable-name-face
+
+-- Constant
+local x <const> = 1
+-- ^ font-lock-constant-face
+local f <close> = io.open('/file')
+-- ^ font-lock-constant-face
+local a, b, c = true, false, nil
+-- ^ font-lock-constant-face
+-- ^ font-lock-constant-face
+-- ^ font-lock-constant-face
+::label2::
+-- ^ font-lock-constant-face
+goto label2
+-- ^ font-lock-constant-face
+
+-- Number
+n = 123
+-- ^ font-lock-number-face
+print(99)
+-- ^ font-lock-number-face
+print(tbl[1])
+-- ^ font-lock-number-face
+
+-- Bracket
+local t = {}
+-- ^ font-lock-bracket-face
+-- ^ font-lock-bracket-face
+print(t[1])
+-- ^ font-lock-bracket-face
+-- ^ font-lock-bracket-face
+-- ^ font-lock-bracket-face
+-- ^ font-lock-bracket-face
+
+-- Builtin
+assert()
+-- <- font-lock-builtin-face
+bit32()
+-- <- font-lock-builtin-face
+collectgarbage()
+-- <- font-lock-builtin-face
+coroutine()
+-- <- font-lock-builtin-face
+debug()
+-- <- font-lock-builtin-face
+dofile()
+-- <- font-lock-builtin-face
+error()
+-- <- font-lock-builtin-face
+getmetatable()
+-- <- font-lock-builtin-face
+io()
+-- <- font-lock-builtin-face
+ipairs()
+-- <- font-lock-builtin-face
+load()
+-- <- font-lock-builtin-face
+loadfile()
+-- <- font-lock-builtin-face
+math()
+-- <- font-lock-builtin-face
+next()
+-- <- font-lock-builtin-face
+os()
+-- <- font-lock-builtin-face
+package()
+-- <- font-lock-builtin-face
+pairs()
+-- <- font-lock-builtin-face
+pcall()
+-- <- font-lock-builtin-face
+print()
+-- <- font-lock-builtin-face
+rawequal()
+-- <- font-lock-builtin-face
+rawget()
+-- <- font-lock-builtin-face
+rawlen()
+-- <- font-lock-builtin-face
+rawset()
+-- <- font-lock-builtin-face
+require()
+-- <- font-lock-builtin-face
+select()
+-- <- font-lock-builtin-face
+setmetatable()
+-- <- font-lock-builtin-face
+string()
+-- <- font-lock-builtin-face
+table()
+-- <- font-lock-builtin-face
+tonumber()
+-- <- font-lock-builtin-face
+tostring()
+-- <- font-lock-builtin-face
+type()
+-- <- font-lock-builtin-face
+utf8()
+-- <- font-lock-builtin-face
+warn()
+-- <- font-lock-builtin-face
+xpcall()
+-- <- font-lock-builtin-face
+print(_G)
+-- ^ font-lock-builtin-face
+print(_VERSION)
+-- ^ font-lock-builtin-face
+f.close()
+-- ^ font-lock-builtin-face
+f.flush()
+-- ^ font-lock-builtin-face
+f.lines()
+-- ^ font-lock-builtin-face
+f.read()
+-- ^ font-lock-builtin-face
+f.seek()
+-- ^ font-lock-builtin-face
+f.setvbuf()
+-- ^ font-lock-builtin-face
+f.write()
+-- ^ font-lock-builtin-face
+
+-- Delimiter
+t = { 1, 2 };
+-- ^ font-lock-delimiter-face
+-- ^ font-lock-delimiter-face
+
+-- Escape
+_ = "x\ty"
+-- ^ font-lock-escape-face
+-- ^ font-lock-escape-face
+_ = "x\"y"
+-- ^ font-lock-escape-face
+-- ^ font-lock-escape-face
+_ = 'x\'y'
+-- ^ font-lock-escape-face
+-- ^ font-lock-escape-face
+_ = "x\z
+ y"
+-- <- font-lock-escape-face
+_ = "x\x5Ay"
+-- ^ font-lock-escape-face
+-- ^ font-lock-escape-face
+_ = "x\0900y"
+-- ^ font-lock-escape-face
+_ = "x\09y"
+-- ^ font-lock-escape-face
+_ = "x\0y"
+-- ^ font-lock-escape-face
+_ = "x\u{1f602}y"
+-- ^ font-lock-escape-face
+-- ^ font-lock-escape-face
+
+-- Function
+func_one()
+-- ^ font-lock-function-call-face
+tbl.func_two()
+-- ^ font-lock-function-call-face
+tbl:func_three()
+-- ^ font-lock-function-call-face
+tbl.f = f4()
+-- ^ font-lock-function-call-face
+
+-- Operator
+local a, b = 1, 2
+-- ^ font-lock-operator-face
+print(a & b)
+-- ^ font-lock-operator-face
+print(a | b)
+-- ^ font-lock-operator-face
+print(a ~ b)
+-- ^ font-lock-operator-face
+print(a << 1)
+-- ^ font-lock-operator-face
+-- ^ font-lock-operator-face
+print(a >> 1)
+-- ^ font-lock-operator-face
+-- ^ font-lock-operator-face
+print(a+b-a*b/a%b^a//b)
+-- ^ font-lock-operator-face
+-- ^ font-lock-operator-face
+-- ^ font-lock-operator-face
+-- ^ font-lock-operator-face
+-- ^ font-lock-operator-face
+-- ^ font-lock-operator-face
+-- ^ font-lock-operator-face
+print(#t)
+-- ^ font-lock-operator-face
+print("h".."at")
+-- ^ font-lock-operator-face
+print(a==b)
+-- ^ font-lock-operator-face
+print(a~=b)
+-- ^ font-lock-operator-face
+print(a<=b)
+-- ^ font-lock-operator-face
+print(a>=b)
+-- ^ font-lock-operator-face
+print(a<b)
+-- ^ font-lock-operator-face
+print(a>b)
+-- ^ font-lock-operator-face
+function ff(...) end
+-- ^ font-lock-operator-face
+
+-- Property
+t = { a=1 }
+-- ^ font-lock-property-name-face
+print(t.a)
+-- ^ font-lock-property-use-face
+
+-- Punctuation
+tbl.f2()
+-- ^ font-lock-punctuation-face
+tbl:f3()
+-- ^ font-lock-punctuation-face
+
+-- Variable
+function fn(x, y) end
+-- ^ font-lock-variable-name-face
+-- ^ font-lock-variable-name-face
+fn(a, b)
+-- ^ font-lock-variable-use-face
+-- ^ font-lock-variable-use-face
+print(a + b)
+-- ^ font-lock-variable-use-face
+-- ^ font-lock-variable-use-face
+print(t[a])
+-- ^ font-lock-variable-use-face
+tbl.f1(p)
+-- ^ font-lock-variable-use-face
+tbl:f2(q)
+-- ^ font-lock-variable-use-face
diff --git a/test/lisp/progmodes/lua-ts-mode-resources/indent.erts b/test/lisp/progmodes/lua-ts-mode-resources/indent.erts
new file mode 100644
index 00000000000..48184160b4d
--- /dev/null
+++ b/test/lisp/progmodes/lua-ts-mode-resources/indent.erts
@@ -0,0 +1,785 @@
+Code:
+ (lambda ()
+ (setq indent-tabs-mode nil)
+ (setq lua-ts-indent-offset 2)
+ (lua-ts-mode)
+ (indent-region (point-min) (point-max)))
+
+Name: Chunk Indent
+
+=-=
+ print(1)
+ print(2)
+=-=
+print(1)
+print(2)
+=-=-=
+
+Name: Function Indent
+
+=-=
+function f1(n)
+print(n)
+return n + 1
+end
+
+local function f2(n)
+print(n)
+return n * 2
+end
+
+local f3 = function(n)
+print(n)
+return n / 3
+end
+
+function f4(...)
+local f = function (...)
+if ok
+then print(1)
+else print(0)
+end
+end
+return f
+end
+
+function f5(...)
+local f = function (...)
+if ok
+then
+print(1)
+else
+print(0)
+end
+end
+return f
+end
+
+function f6(...)
+local f = function (...)
+if ok then
+print(1)
+else
+print(0)
+end
+end
+return f
+end
+
+;(function ()
+ return true
+ end)()
+=-=
+function f1(n)
+ print(n)
+ return n + 1
+end
+
+local function f2(n)
+ print(n)
+ return n * 2
+end
+
+local f3 = function(n)
+ print(n)
+ return n / 3
+end
+
+function f4(...)
+ local f = function (...)
+ if ok
+ then print(1)
+ else print(0)
+ end
+ end
+ return f
+end
+
+function f5(...)
+ local f = function (...)
+ if ok
+ then
+ print(1)
+ else
+ print(0)
+ end
+ end
+ return f
+end
+
+function f6(...)
+ local f = function (...)
+ if ok then
+ print(1)
+ else
+ print(0)
+ end
+ end
+ return f
+end
+
+;(function ()
+ return true
+end)()
+=-=-=
+
+Name: Conditional Indent
+
+=-=
+if true then
+print(true)
+return 1
+elseif false then
+print(false)
+return -1
+else
+print(nil)
+return 0
+end
+
+if true
+ then
+ print(true)
+ return 1
+ elseif false
+ then
+ print(false)
+ return -1
+ else
+ print(nil)
+ return 0
+end
+
+if true
+ then return 1
+ elseif false
+ then return -1
+ else return 0
+end
+=-=
+if true then
+ print(true)
+ return 1
+elseif false then
+ print(false)
+ return -1
+else
+ print(nil)
+ return 0
+end
+
+if true
+then
+ print(true)
+ return 1
+elseif false
+then
+ print(false)
+ return -1
+else
+ print(nil)
+ return 0
+end
+
+if true
+then return 1
+elseif false
+then return -1
+else return 0
+end
+=-=-=
+
+Name: Loop Indent
+
+=-=
+for k,v in pairs({}) do
+ print(k)
+ print(v)
+end
+
+for i=1,10
+ do print(i)
+end
+
+while n < 10 do
+ n = n + 1
+ print(n)
+end
+
+while n < 10
+ do
+ n = n + 1
+ print(n)
+end
+
+for i=0,9 do
+repeat n = n+1
+ until n > 99
+end
+
+repeat
+z = z * 2
+print(z)
+until z > 12
+
+ for i,x in ipairs(t) do
+ while i < 9
+ do
+ local n = t[x]
+ repeat n = n + 1
+ until n > #t
+ while n < 99
+ do
+ print(n)
+ end
+ end
+ print(t[i])
+ end
+
+do
+local a = b
+print(a + 1)
+end
+=-=
+for k,v in pairs({}) do
+ print(k)
+ print(v)
+end
+
+for i=1,10
+do print(i)
+end
+
+while n < 10 do
+ n = n + 1
+ print(n)
+end
+
+while n < 10
+do
+ n = n + 1
+ print(n)
+end
+
+for i=0,9 do
+ repeat n = n+1
+ until n > 99
+end
+
+repeat
+ z = z * 2
+ print(z)
+until z > 12
+
+for i,x in ipairs(t) do
+ while i < 9
+ do
+ local n = t[x]
+ repeat n = n + 1
+ until n > #t
+ while n < 99
+ do
+ print(n)
+ end
+ end
+ print(t[i])
+end
+
+do
+ local a = b
+ print(a + 1)
+end
+=-=-=
+
+Name: Bracket Indent
+
+=-=
+fn(
+ )
+
+tb={
+ }
+=-=
+fn(
+)
+
+tb={
+}
+=-=-=
+
+Name: Multi-line String Indent
+
+=-=
+local s = [[
+ Multi-line
+ string content
+ ]]
+
+function f()
+ local str = [[
+ multi-line
+ string
+ ]]
+return true
+end
+=-=
+local s = [[
+ Multi-line
+ string content
+ ]]
+
+function f()
+ local str = [[
+ multi-line
+ string
+ ]]
+ return true
+end
+=-=-=
+
+Name: Multi-line Comment Indent
+
+=-=
+--[[
+ Multi-line
+ comment content
+ ]]
+
+function f()
+--[[
+multi-line
+ comment
+ ]]
+ return true
+end
+=-=
+--[[
+ Multi-line
+ comment content
+ ]]
+
+function f()
+--[[
+multi-line
+ comment
+ ]]
+ return true
+end
+=-=-=
+
+Name: Argument Indent
+
+=-=
+ h(
+ "string",
+ 1000
+ )
+
+local p = h(
+"string",
+ 1000
+)
+
+fn(1,
+2,
+ 3)
+
+fn( 1, 2,
+3, 4 )
+
+f({
+x = 1,
+y = 2,
+z = 3,
+})
+
+f({ x = 1,
+y = 2,
+z = 3, })
+
+Test({
+a=1
+})
+
+Test({
+a = 1,
+b = 2,
+},
+nil)
+=-=
+h(
+ "string",
+ 1000
+)
+
+local p = h(
+ "string",
+ 1000
+)
+
+fn(1,
+ 2,
+ 3)
+
+fn( 1, 2,
+ 3, 4 )
+
+f({
+ x = 1,
+ y = 2,
+ z = 3,
+})
+
+f({ x = 1,
+ y = 2,
+ z = 3, })
+
+Test({
+ a=1
+})
+
+Test({
+ a = 1,
+ b = 2,
+ },
+ nil)
+=-=-=
+
+Name: Parameter Indent
+
+=-=
+function f1(
+a,
+b
+)
+print(a,b)
+end
+
+local function f2(a,
+ b)
+print(a,b)
+end
+
+local f3 = function( a, b,
+ c, d )
+print(a,b,c,d)
+end
+=-=
+function f1(
+ a,
+ b
+)
+ print(a,b)
+end
+
+local function f2(a,
+ b)
+ print(a,b)
+end
+
+local f3 = function( a, b,
+ c, d )
+ print(a,b,c,d)
+end
+=-=-=
+
+Name: Table Indent
+
+=-=
+local Other = {
+ First={up={Step=true,Jump=true},
+ down={Step=true,Jump=true},
+ left={Step=true,Jump=true},
+ right={Step=true,Jump=true}},
+ Second={up={Step=true,Jump=true},
+ down={Step=true,Jump=true},
+ left={Step=true,Jump=true},
+ right={Step=true,Jump=true}},
+ Third={up={Goto=true},
+ down={Goto=true},
+ left={Goto=true},
+ right={Goto=true}}
+}
+
+local Other = {
+a = 1,
+ b = 2,
+ c = 3,
+}
+=-=
+local Other = {
+ First={up={Step=true,Jump=true},
+ down={Step=true,Jump=true},
+ left={Step=true,Jump=true},
+ right={Step=true,Jump=true}},
+ Second={up={Step=true,Jump=true},
+ down={Step=true,Jump=true},
+ left={Step=true,Jump=true},
+ right={Step=true,Jump=true}},
+ Third={up={Goto=true},
+ down={Goto=true},
+ left={Goto=true},
+ right={Goto=true}}
+}
+
+local Other = {
+ a = 1,
+ b = 2,
+ c = 3,
+}
+=-=-=
+
+Name: Continuation Indent
+
+=-=
+local very_long_variable_name =
+"ok"..
+ "ok"
+local n = a +
+b *
+c /
+1
+local x = "A"..
+"B"
+.."C"
+if a
+ and b
+ and c then
+ if x
+ and y then
+ local x = 1 +
+2 *
+ 3
+ end
+elseif a
+ or b
+ or c then
+end
+=-=
+local very_long_variable_name =
+ "ok"..
+ "ok"
+local n = a +
+ b *
+ c /
+ 1
+local x = "A"..
+ "B"
+ .."C"
+if a
+ and b
+ and c then
+ if x
+ and y then
+ local x = 1 +
+ 2 *
+ 3
+ end
+elseif a
+ or b
+ or c then
+end
+=-=-=
+
+Code:
+ (lambda ()
+ (setq indent-tabs-mode nil)
+ (setq lua-ts-indent-offset 4)
+ (lua-ts-mode)
+ (indent-region (point-min) (point-max)))
+
+Name: End Indent
+
+=-=
+function f(x)
+ for y=1,x.y do
+ for x=1,x.z do
+ if x.y and x.z then
+ if y <= x then
+ y = y + 1
+ end end end end
+ return {x,y} or {math.random(),math.random()}
+ end
+
+for y=1,x.y do
+ for x=1,x.z do
+ if x.y and x.z then
+ if y <= x then
+ y = y + 1
+ end
+ end end end
+=-=
+function f(x)
+ for y=1,x.y do
+ for x=1,x.z do
+ if x.y and x.z then
+ if y <= x then
+ y = y + 1
+ end end end end
+ return {x,y} or {math.random(),math.random()}
+end
+
+for y=1,x.y do
+ for x=1,x.z do
+ if x.y and x.z then
+ if y <= x then
+ y = y + 1
+ end
+end end end
+=-=-=
+
+Name: Nested Function Indent
+
+=-=
+function a(...)
+ return (function (x)
+ return x
+ end)(foo(...))
+end
+
+function b(n)
+ local x = 1
+ return function (i)
+ return function (...)
+ return (function (n, ...)
+ return function (f, ...)
+ return (function (...)
+ if ... and x < 9 then
+ x = x + 1
+ return ...
+ end end)(n(f, ...))
+ end, ...
+ end)(i(...))
+end end end
+
+function c(f)
+ local f1 = function (...)
+ if nil ~= ... then
+ return f(...)
+ end
+ end
+ return function (i)
+ return function (...)
+ local fn = function (n, ...)
+ local x = function (f, ...)
+ return f1(n(f, ...))
+ end
+ return x
+ end
+ return fn(i(...))
+ end
+ end
+end
+
+function d(f)
+ local f1 = function (c, f, ...)
+ if ... then
+ if f(...) then
+ return ...
+ else
+ return c(f, ...)
+ end end end
+ return function (i)
+ return function (...)
+ return (function (n, ...)
+ local function j (f, ...)
+ return f1(j, f, n(f, ...))
+ end
+ return j, ...
+ end)(i(...))
+end end end
+
+function e (n, t)
+ return function (i)
+ return function (...)
+ return (
+ function (n, ...)
+ local x, y, z = 0, {}
+ return (function (f, ...)
+ return (function (i, ...) return i(i, ...) end)(
+ function (i, ...)
+ return f(function (x, ...)
+ return i(i, ...)(x, ...)
+ end, ...)
+ end)
+ end)(function (j)
+ return function(f, ...)
+ return (function (c, f, ...)
+ if ... then
+ if n+1 == x then
+ local y1, x1 = y, x
+ y, x = {}, 0
+ return (function (...)
+ z = ...
+ return ...
+ end)(t(y1-1, x1-1, ...))
+ else
+ x = x - 1
+ return c(f,
+ (function (...)
+ z = ...
+ return ...
+ end)(t(y, x, ...)))
+ end
+ elseif x ~= 0 then
+ x = 0
+ return z, y
+ end end)(j, f, n(f, ...))
+ end end), ...
+ end)(i(...))
+end end end
+=-=-=
+
+Code:
+ (lambda ()
+ (setq indent-tabs-mode nil)
+ (setq lua-ts-indent-continuation-lines nil)
+ (setq lua-ts-indent-offset 2)
+ (lua-ts-mode)
+ (indent-region (point-min) (point-max)))
+
+Name: Unaligned Continuation Indent
+
+=-=
+local n = a +
+ b *
+ c /
+ 1
+if a
+ and b
+and c then
+ if x
+ and y then
+ local x = 1 +
+ 2 *
+ 3
+ end
+elseif a
+ or b
+ or c then
+ if x
+ or y
+ end
+end
+=-=
+local n = a +
+ b *
+ c /
+ 1
+if a
+and b
+and c then
+ if x
+ and y then
+ local x = 1 +
+ 2 *
+ 3
+ end
+elseif a
+or b
+or c then
+ if x
+ or y
+ end
+end
+=-=-=
diff --git a/test/lisp/progmodes/lua-ts-mode-resources/movement.erts b/test/lisp/progmodes/lua-ts-mode-resources/movement.erts
new file mode 100644
index 00000000000..11e86f12926
--- /dev/null
+++ b/test/lisp/progmodes/lua-ts-mode-resources/movement.erts
@@ -0,0 +1,603 @@
+Code:
+ (lambda ()
+ (lua-ts-mode)
+ (beginning-of-defun 1))
+
+Point-Char: |
+
+Name: beginning-of-defun moves to start of function declaration
+
+=-=
+local function Test()
+ if true then
+ print(1)
+ else
+ print(0)
+ end|
+end
+=-=
+|local function Test()
+ if true then
+ print(1)
+ else
+ print(0)
+ end
+end
+=-=-=
+
+Name: beginning-of-defun moves to start of function definition
+
+=-=
+local t = {
+ f = function()
+ return true
+ end,
+}|
+=-=
+local t = {
+| f = function()
+ return true
+ end,
+}
+=-=-=
+
+Code:
+ (lambda ()
+ (lua-ts-mode)
+ (end-of-defun 1))
+
+Point-Char: |
+
+Name: end-of-defun moves to end of function declaration
+
+=-=
+local function Test()
+ if true then
+ pr|int(1)
+ else
+ print(0)
+ end
+end
+
+local t = Test()
+=-=
+local function Test()
+ if true then
+ print(1)
+ else
+ print(0)
+ end
+end
+|
+local t = Test()
+=-=-=
+
+Name: end-of-defun moves to end of function definition
+
+=-=
+local t = {
+ f = function()
+ re|turn true
+ end,
+}
+=-=
+local t = {
+ f = function()
+ return true
+ end|,
+}
+=-=-=
+
+Code:
+ (lambda ()
+ (lua-ts-mode)
+ (forward-sentence 1))
+
+Point-Char: |
+
+Name: forward-sentence moves over if statements
+
+=-=
+function f()
+ |if true then
+ print(1)
+ elseif false then
+ print(0)
+ else
+ print(2)
+ end
+end
+=-=
+function f()
+ if true then
+ print(1)
+ elseif false then
+ print(0)
+ else
+ print(2)
+ end|
+end
+=-=-=
+
+Name: forward-sentence moves over variable declaration
+
+=-=
+|local n = 1
+
+print(n)
+=-=
+local n = 1|
+
+print(n)
+=-=-=
+
+Name: forward-sentence moves over for statements
+
+=-=
+|for k, v in pairs({}) do
+ print(k, v)
+end
+
+print(1)
+=-=
+for k, v in pairs({}) do
+ print(k, v)
+end|
+
+print(1)
+=-=-=
+
+Name: forward-sentence moves over do statements
+
+=-=
+|do
+ local x = 1
+ local y = 2
+
+ print(x, y)
+end
+
+print(1)
+=-=
+do
+ local x = 1
+ local y = 2
+
+ print(x, y)
+end|
+
+print(1)
+=-=-=
+
+Name: forward-sentence moves over while statements
+
+=-=
+local i = 0
+|while i < 9 do
+ print(i)
+ i = i + 1
+end
+
+print(1)
+=-=
+local i = 0
+while i < 9 do
+ print(i)
+ i = i + 1
+end|
+
+print(1)
+=-=-=
+
+Name: forward-sentence moves over repeat statements
+
+=-=
+local i = 0
+|repeat
+ print(i)
+ i = i + 1
+until i > 9
+
+print(1)
+=-=
+local i = 0
+repeat
+ print(i)
+ i = i + 1
+until i > 9|
+
+print(1)
+=-=-=
+
+Name: forward-sentence moves over function calls
+
+=-=
+|print(1)
+=-=
+print(1)|
+=-=-=
+
+Name: forward-sentence moves over return statements
+
+=-=
+function f()
+ |return math.random()
+end
+=-=
+function f()
+ return math.random()|
+end
+=-=-=
+
+Code:
+ (lambda ()
+ (lua-ts-mode)
+ (forward-sentence 2))
+
+Name: forward-sentence moves over table fields
+
+=-=
+local t = {
+ |a = 1,
+ b = 2,
+}
+=-=
+local t = {
+ a = 1,
+ b = 2|,
+}
+=-=-=
+
+Code:
+ (lambda ()
+ (lua-ts-mode)
+ (backward-sentence 1))
+
+Point-Char: |
+
+Name: backward-sentence moves over if statements
+
+=-=
+function f()
+ if true then
+ print(1)
+ elseif false then
+ print(0)
+ else
+ print(2)
+ end|
+end
+=-=
+function f()
+ |if true then
+ print(1)
+ elseif false then
+ print(0)
+ else
+ print(2)
+ end
+end
+=-=-=
+
+Name: backward-sentence moves over variable declaration
+
+=-=
+local n = 1|
+
+print(n)
+=-=
+|local n = 1
+
+print(n)
+=-=-=
+
+Name: backward-sentence moves over for statements
+
+=-=
+for k, v in pairs({}) do
+ print(k, v)
+end|
+
+print(1)
+=-=
+|for k, v in pairs({}) do
+ print(k, v)
+end
+
+print(1)
+=-=-=
+
+Name: backward-sentence moves over for statements
+
+=-=
+do
+ local x = 1
+ local y = 2
+
+ print(x, y)
+end|
+
+print(1)
+=-=
+|do
+ local x = 1
+ local y = 2
+
+ print(x, y)
+end
+
+print(1)
+=-=-=
+
+Name: backward-sentence moves over while statements
+
+=-=
+local i = 0
+while i < 9 do
+ print(i)
+ i = i + 1
+end|
+
+print(1)
+=-=
+local i = 0
+|while i < 9 do
+ print(i)
+ i = i + 1
+end
+
+print(1)
+=-=-=
+
+Name: backward-sentence moves over repeat statements
+
+=-=
+local i = 0
+repeat
+ print(i)
+ i = i + 1
+until i > 9|
+
+print(1)
+=-=
+local i = 0
+|repeat
+ print(i)
+ i = i + 1
+until i > 9
+
+print(1)
+=-=-=
+
+Name: backward-sentence moves over function calls
+
+=-=
+print(1)|
+=-=
+|print(1)
+=-=-=
+
+Name: backward-sentence moves over return statements
+
+=-=
+function f()
+ return math.random()|
+end
+=-=
+function f()
+ |return math.random()
+end
+=-=-=
+
+Code:
+ (lambda ()
+ (lua-ts-mode)
+ (backward-sentence 2))
+
+Point-Char: |
+
+Name: backward-sentence moves over table fields
+
+=-=
+local t = {
+ a = 1,
+ b = 2|,
+}
+=-=
+local t = {
+ |a = 1,
+ b = 2,
+}
+=-=-=
+
+Code:
+ (lambda ()
+ (lua-ts-mode)
+ (forward-sexp 1))
+
+Point-Char: |
+
+Name: forward-sexp moves over arguments
+
+=-=
+print|(1, 2, 3)
+=-=
+print(1, 2, 3)|
+=-=-=
+
+Name: forward-sexp moves over parameters
+
+=-=
+function f|(a, b) end
+=-=
+function f(a, b)| end
+=-=-=
+
+Name: forward-sexp moves over strings
+
+=-=
+print("|1, 2, 3")
+=-=
+print("1, 2, 3|")
+=-=-=
+
+Name: forward-sexp moves over tables
+
+=-=
+local t = |{ 1,
+ 2,
+ 3 }
+=-=
+local t = { 1,
+ 2,
+ 3 }|
+=-=-=
+
+Name: forward-sexp moves over parenthesized expressions
+
+=-=
+|(function (x) return x + 1 end)(41)
+=-=
+(function (x) return x + 1 end)|(41)
+=-=-=
+
+Name: forward-sexp moves over function declarations
+
+=-=
+|function foo (x)
+ if false then
+ print "foo"
+ elseif true then
+ print "bar"
+ end
+end
+=-=
+function foo (x)
+ if false then
+ print "foo"
+ elseif true then
+ print "bar"
+ end
+end|
+=-=-=
+
+Name: forward-sexp moves over do statements
+
+=-=
+|do
+ print(a + 1)
+end
+=-=
+do
+ print(a + 1)
+end|
+=-=-=
+
+Name: forward-sexp moves over for statements
+
+=-=
+|for k,v in pairs({}) do
+ print(k, v)
+end
+=-=
+for k,v in pairs({}) do
+ print(k, v)
+end|
+=-=-=
+
+Name: forward-sexp moves over repeat statements
+
+=-=
+|repeat
+ n = n + 1
+until n > 10
+=-=
+repeat
+ n = n + 1
+until n > 10|
+=-=-=
+
+Name: forward-sexp moves over while statements
+
+=-=
+|while n < 99
+do
+ n = n+1
+end
+=-=
+while n < 99
+do
+ n = n+1
+end|
+=-=-=
+
+Code:
+ (lambda ()
+ (lua-ts-mode)
+ (backward-sexp 1))
+
+Point-Char: |
+
+Name: backward-sexp moves over arguments
+
+=-=
+print(1, 2, 3)|
+=-=
+print|(1, 2, 3)
+=-=-=
+
+Name: backward-sexp moves over parameters
+
+=-=
+function f(a, b)| end
+=-=
+function f|(a, b) end
+=-=-=
+
+Name: backward-sexp moves over strings
+
+=-=
+print("1, 2, 3|")
+=-=
+print("|1, 2, 3")
+=-=-=
+
+Name: backward-sexp moves over tables
+
+=-=
+local t = { 1,
+ 2,
+ 3 }|
+=-=
+local t = |{ 1,
+ 2,
+ 3 }
+=-=-=
+
+Name: backward-sexp moves over parenthesized expressions
+
+=-=
+(function (x) return x + 1 end)|(41)
+=-=
+|(function (x) return x + 1 end)(41)
+=-=-=
+
+Name: backward-sexp moves over function declarations
+
+=-=
+function foo (x)
+ if false then
+ print "foo"
+ elseif true then
+ print "bar"
+ end
+end|
+=-=
+|function foo (x)
+ if false then
+ print "foo"
+ elseif true then
+ print "bar"
+ end
+end
+=-=-=
diff --git a/test/lisp/progmodes/lua-ts-mode-tests.el b/test/lisp/progmodes/lua-ts-mode-tests.el
new file mode 100644
index 00000000000..565e6f91dbd
--- /dev/null
+++ b/test/lisp/progmodes/lua-ts-mode-tests.el
@@ -0,0 +1,42 @@
+;;; lua-ts-mode-tests.el --- Tests for lua-ts-mode -*- lexical-binding: t; -*-
+
+;; Copyright (C) 2023-2024 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 <https://www.gnu.org/licenses/>.
+
+;;; Code:
+
+(require 'ert)
+(require 'ert-font-lock)
+(require 'ert-x)
+(require 'treesit)
+
+(ert-deftest lua-ts-test-indentation ()
+ (skip-unless (treesit-ready-p 'lua))
+ (ert-test-erts-file (ert-resource-file "indent.erts")))
+
+(ert-deftest lua-ts-test-movement ()
+ (skip-unless (treesit-ready-p 'lua))
+ (ert-test-erts-file (ert-resource-file "movement.erts")))
+
+(ert-deftest lua-ts-test-font-lock ()
+ (skip-unless (treesit-ready-p 'lua))
+ (let ((treesit-font-lock-level 4))
+ (ert-font-lock-test-file (ert-resource-file "font-lock.lua") 'lua-ts-mode)))
+
+(provide 'lua-ts-mode-tests)
+
+;;; lua-ts-mode-tests.el ends here
diff --git a/test/lisp/progmodes/perl-mode-tests.el b/test/lisp/progmodes/perl-mode-tests.el
index cf11d22da93..49320566139 100644
--- a/test/lisp/progmodes/perl-mode-tests.el
+++ b/test/lisp/progmodes/perl-mode-tests.el
@@ -28,6 +28,23 @@
(font-lock-ensure (point-min) (point-max))
(should (equal (get-text-property 4 'face) 'font-lock-variable-name-face))))
+(ert-deftest perl-test-bug-34245 ()
+ "Test correct indentation after a hanging paren, with and without comments."
+ (with-temp-buffer
+ (perl-mode)
+ (insert "my @foo = (\n\"bar\",\n\"baz\",\n);")
+ (insert "\n\n")
+ (insert "my @ofoo = (\t\t# A comment.\n\"obar\",\n\"obaz\",\n);")
+ (indent-region (point-min) (point-max))
+ (goto-char (point-min))
+ (forward-line)
+ (skip-chars-forward " \t")
+ (should (equal (current-column) perl-indent-level))
+ (search-forward "# A comment.")
+ (forward-line)
+ (skip-chars-forward " \t")
+ (should (equal (current-column) perl-indent-level))))
+
;;;; Reuse cperl-mode tests
(defvar cperl-test-mode)
diff --git a/test/lisp/progmodes/project-tests.el b/test/lisp/progmodes/project-tests.el
index 1111344387b..04cdf1dea29 100644
--- a/test/lisp/progmodes/project-tests.el
+++ b/test/lisp/progmodes/project-tests.el
@@ -137,6 +137,7 @@ When `project-ignores' includes a name matching project dir."
(project-vc-extra-root-markers '("files-x-tests.*"))
(project (project-current nil dir)))
(should-not (null project))
+ (should (nth 1 project))
(should (string-match-p "/test/lisp/\\'" (project-root project)))))
(ert-deftest project-vc-supports-project-in-different-dir ()
diff --git a/test/lisp/progmodes/python-tests.el b/test/lisp/progmodes/python-tests.el
index 95db93dd5cc..e11440cdb5b 100644
--- a/test/lisp/progmodes/python-tests.el
+++ b/test/lisp/progmodes/python-tests.el
@@ -55,21 +55,27 @@ BODY is code to be executed within the temp buffer. Point is
always located at the beginning of buffer. Native completion is
turned off. Shell buffer will be killed on exit."
(declare (indent 1) (debug t))
- `(with-temp-buffer
- (let ((python-indent-guess-indent-offset nil)
- (python-shell-completion-native-enable nil))
- (python-mode)
- (unwind-protect
- (progn
- (run-python nil t)
- (insert ,contents)
- (goto-char (point-min))
- (python-tests-shell-wait-for-prompt)
- ,@body)
- (when (python-shell-get-buffer)
- (python-shell-with-shell-buffer
- (let (kill-buffer-hook kill-buffer-query-functions)
- (kill-buffer))))))))
+ (let ((dir (make-symbol "dir")))
+ `(with-temp-buffer
+ (let ((python-indent-guess-indent-offset nil)
+ (python-shell-completion-native-enable nil))
+ (python-mode)
+ (unwind-protect
+ ;; Prevent test failures when Jedi is used as a completion
+ ;; backend, either directly or indirectly (e.g., via
+ ;; IPython). Jedi needs to store cache, but the
+ ;; "/nonexistent" HOME directory is not writable.
+ (ert-with-temp-directory ,dir
+ (with-environment-variables (("XDG_CACHE_HOME" ,dir))
+ (run-python nil t)
+ (insert ,contents)
+ (goto-char (point-min))
+ (python-tests-shell-wait-for-prompt)
+ ,@body))
+ (when (python-shell-get-buffer)
+ (python-shell-with-shell-buffer
+ (let (kill-buffer-hook kill-buffer-query-functions)
+ (kill-buffer)))))))))
(defmacro python-tests-with-temp-file (contents &rest body)
"Create a `python-mode' enabled file with CONTENTS.
@@ -474,6 +480,28 @@ def f(x: CustomInt) -> CustomInt:
(136 . font-lock-operator-face) (137)
(144 . font-lock-keyword-face) (150))))
+(ert-deftest python-font-lock-operator-1 ()
+ (python-tests-assert-faces
+ "1 << 2 ** 3 == +4%-5|~6&7^8%9"
+ '((1)
+ (3 . font-lock-operator-face) (5)
+ (8 . font-lock-operator-face) (10)
+ (13 . font-lock-operator-face) (15)
+ (16 . font-lock-operator-face) (17)
+ (18 . font-lock-operator-face) (20)
+ (21 . font-lock-operator-face) (23)
+ (24 . font-lock-operator-face) (25)
+ (26 . font-lock-operator-face) (27)
+ (28 . font-lock-operator-face) (29))))
+
+(ert-deftest python-font-lock-operator-2 ()
+ "Keyword operators are font-locked as keywords."
+ (python-tests-assert-faces
+ "is_ is None"
+ '((1)
+ (5 . font-lock-keyword-face) (7)
+ (8 . font-lock-constant-face))))
+
(ert-deftest python-font-lock-escape-sequence-string-newline ()
(python-tests-assert-faces
"'\\n'
@@ -585,62 +613,70 @@ u\"\\n\""
(845 . font-lock-string-face) (886))))
(ert-deftest python-font-lock-escape-sequence-bytes-newline ()
- :expected-result :failed
(python-tests-assert-faces
"b'\\n'
b\"\\n\""
'((1)
- (2 . font-lock-doc-face)
+ (2 . font-lock-string-face)
(3 . font-lock-constant-face)
- (5 . font-lock-doc-face) (6)
- (8 . font-lock-doc-face)
+ (5 . font-lock-string-face) (6)
+ (8 . font-lock-string-face)
(9 . font-lock-constant-face)
- (11 . font-lock-doc-face))))
+ (11 . font-lock-string-face))))
(ert-deftest python-font-lock-escape-sequence-hex-octal ()
- :expected-result :failed
(python-tests-assert-faces
"b'\\x12 \\777 \\1\\23'
'\\x12 \\777 \\1\\23'"
'((1)
- (2 . font-lock-doc-face)
+ (2 . font-lock-string-face)
(3 . font-lock-constant-face)
- (7 . font-lock-doc-face)
+ (7 . font-lock-string-face)
(8 . font-lock-constant-face)
- (12 . font-lock-doc-face)
+ (12 . font-lock-string-face)
(13 . font-lock-constant-face)
- (18 . font-lock-doc-face) (19)
- (20 . font-lock-doc-face)
+ (18 . font-lock-string-face) (19)
+ (20 . font-lock-string-face)
(21 . font-lock-constant-face)
- (25 . font-lock-doc-face)
+ (25 . font-lock-string-face)
(26 . font-lock-constant-face)
- (30 . font-lock-doc-face)
+ (30 . font-lock-string-face)
(31 . font-lock-constant-face)
- (36 . font-lock-doc-face))))
+ (36 . font-lock-string-face))))
(ert-deftest python-font-lock-escape-sequence-unicode ()
- :expected-result :failed
(python-tests-assert-faces
"b'\\u1234 \\U00010348 \\N{Plus-Minus Sign}'
'\\u1234 \\U00010348 \\N{Plus-Minus Sign}'"
'((1)
- (2 . font-lock-doc-face) (41)
- (42 . font-lock-doc-face)
+ (2 . font-lock-string-face) (41)
+ (42 . font-lock-string-face)
(43 . font-lock-constant-face)
- (49 . font-lock-doc-face)
+ (49 . font-lock-string-face)
(50 . font-lock-constant-face)
- (60 . font-lock-doc-face)
+ (60 . font-lock-string-face)
(61 . font-lock-constant-face)
- (80 . font-lock-doc-face))))
+ (80 . font-lock-string-face))))
(ert-deftest python-font-lock-raw-escape-sequence ()
- :expected-result :failed
(python-tests-assert-faces
"rb'\\x12 \123 \\n'
r'\\x12 \123 \\n \\u1234 \\U00010348 \\N{Plus-Minus Sign}'"
'((1)
- (3 . font-lock-doc-face) (14)
- (16 . font-lock-doc-face))))
+ (3 . font-lock-string-face) (14)
+ (16 . font-lock-string-face))))
+
+(ert-deftest python-font-lock-string-literal-concatenation ()
+ "Test for bug#45897."
+ (python-tests-assert-faces
+ "x = \"hello\"\"\"
+y = \"confused\""
+ '((1 . font-lock-variable-name-face) (2)
+ (3 . font-lock-operator-face) (4)
+ (5 . font-lock-string-face) (14)
+ (15 . font-lock-variable-name-face) (16)
+ (17 . font-lock-operator-face) (18)
+ (19 . font-lock-string-face))))
;;; Indentation
@@ -683,7 +719,7 @@ def long_function_name(
(should (= (python-indent-calculate-indentation) 8))
(python-tests-look-at "var_four):")
(should (eq (car (python-indent-context))
- :inside-paren-newline-start-from-block))
+ :inside-paren-continuation-line))
(should (= (python-indent-calculate-indentation) 8))
(python-tests-look-at "print (var_one)")
(should (eq (car (python-indent-context))
@@ -707,8 +743,8 @@ foo = long_function_name(
(should (eq (car (python-indent-context)) :inside-paren-newline-start))
(should (= (python-indent-calculate-indentation) 4))
(python-tests-look-at "var_three, var_four)")
- (should (eq (car (python-indent-context)) :inside-paren-newline-start))
- (should (= (python-indent-calculate-indentation) 4))))
+ (should (eq (car (python-indent-context)) :inside-paren-continuation-line))
+ (should (= (python-indent-calculate-indentation) 2))))
(ert-deftest python-indent-hanging-close-paren ()
"Like first pep8 case, but with hanging close paren." ;; See Bug#20742.
@@ -864,7 +900,7 @@ data = {
(should (eq (car (python-indent-context)) :inside-paren-newline-start))
(should (= (python-indent-calculate-indentation) 4))
(python-tests-look-at "{")
- (should (eq (car (python-indent-context)) :inside-paren-newline-start))
+ (should (eq (car (python-indent-context)) :inside-paren-continuation-line))
(should (= (python-indent-calculate-indentation) 4))
(python-tests-look-at "'objlist': [")
(should (eq (car (python-indent-context)) :inside-paren-newline-start))
@@ -876,20 +912,20 @@ data = {
(should (eq (car (python-indent-context)) :inside-paren-newline-start))
(should (= (python-indent-calculate-indentation) 16))
(python-tests-look-at "'name': 'first',")
- (should (eq (car (python-indent-context)) :inside-paren-newline-start))
+ (should (eq (car (python-indent-context)) :inside-paren-continuation-line))
(should (= (python-indent-calculate-indentation) 16))
(python-tests-look-at "},")
(should (eq (car (python-indent-context))
:inside-paren-at-closing-nested-paren))
(should (= (python-indent-calculate-indentation) 12))
(python-tests-look-at "{")
- (should (eq (car (python-indent-context)) :inside-paren-newline-start))
+ (should (eq (car (python-indent-context)) :inside-paren-continuation-line))
(should (= (python-indent-calculate-indentation) 12))
(python-tests-look-at "'pk': 2,")
(should (eq (car (python-indent-context)) :inside-paren-newline-start))
(should (= (python-indent-calculate-indentation) 16))
(python-tests-look-at "'name': 'second',")
- (should (eq (car (python-indent-context)) :inside-paren-newline-start))
+ (should (eq (car (python-indent-context)) :inside-paren-continuation-line))
(should (= (python-indent-calculate-indentation) 16))
(python-tests-look-at "}")
(should (eq (car (python-indent-context))
@@ -933,7 +969,7 @@ data = {'key': {
(should (eq (car (python-indent-context)) :inside-paren))
(should (= (python-indent-calculate-indentation) 9))
(python-tests-look-at "{'pk': 2,")
- (should (eq (car (python-indent-context)) :inside-paren-newline-start))
+ (should (eq (car (python-indent-context)) :inside-paren-continuation-line))
(should (= (python-indent-calculate-indentation) 8))
(python-tests-look-at "'name': 'second'}")
(should (eq (car (python-indent-context)) :inside-paren))
@@ -966,10 +1002,10 @@ data = ('these',
(should (eq (car (python-indent-context)) :inside-paren))
(should (= (python-indent-calculate-indentation) 8))
(forward-line 1)
- (should (eq (car (python-indent-context)) :inside-paren))
+ (should (eq (car (python-indent-context)) :inside-paren-continuation-line))
(should (= (python-indent-calculate-indentation) 8))
(forward-line 1)
- (should (eq (car (python-indent-context)) :inside-paren))
+ (should (eq (car (python-indent-context)) :inside-paren-continuation-line))
(should (= (python-indent-calculate-indentation) 8))))
(ert-deftest python-indent-inside-paren-4 ()
@@ -999,7 +1035,7 @@ while ((not some_condition) and
(should (eq (car (python-indent-context)) :no-indent))
(should (= (python-indent-calculate-indentation) 0))
(forward-line 1)
- (should (eq (car (python-indent-context)) :inside-paren))
+ (should (eq (car (python-indent-context)) :inside-paren-from-block))
(should (= (python-indent-calculate-indentation) 7))
(forward-line 1)
(should (eq (car (python-indent-context)) :after-block-start))
@@ -1023,7 +1059,7 @@ CHOICES = (('some', 'choice'),
(should (eq (car (python-indent-context)) :inside-paren))
(should (= (python-indent-calculate-indentation) 11))
(forward-line 1)
- (should (eq (car (python-indent-context)) :inside-paren))
+ (should (eq (car (python-indent-context)) :inside-paren-continuation-line))
(should (= (python-indent-calculate-indentation) 11))))
(ert-deftest python-indent-inside-paren-7 ()
@@ -1034,6 +1070,183 @@ CHOICES = (('some', 'choice'),
;; This signals an error if the test fails
(should (eq (car (python-indent-context)) :inside-paren-newline-start))))
+(ert-deftest python-indent-inside-paren-8 ()
+ "Test for Bug#63959."
+ (python-tests-with-temp-buffer
+ "
+for a in [ # comment
+ 'some', # Manually indented.
+ 'thing']: # Respect indentation of the previous line.
+"
+ (python-tests-look-at "for a in [ # comment")
+ (should (eq (car (python-indent-context)) :no-indent))
+ (should (= (python-indent-calculate-indentation) 0))
+ (forward-line 1)
+ (should (eq (car (python-indent-context))
+ :inside-paren-newline-start-from-block))
+ (should (= (python-indent-calculate-indentation) 8))
+ (forward-line 1)
+ (should (eq (car (python-indent-context)) :inside-paren-continuation-line))
+ (should (= (python-indent-calculate-indentation) 10))))
+
+(ert-deftest python-indent-inside-paren-9 ()
+ "Test `:inside-paren-continuation-line'."
+ (python-tests-with-temp-buffer
+ "
+a = (((
+ 1, 2),
+ 3), # Do not respect the indentation of the previous line
+ 4) # Do not respect the indentation of the previous line
+b = ((
+ 1, 2), # Manually indented
+ 3, # Do not respect the indentation of the previous line
+ 4, # Respect the indentation of the previous line
+ 5, # Manually indented
+ 6) # Respect the indentation of the previous line
+"
+ (python-tests-look-at "a = (((")
+ (should (eq (car (python-indent-context)) :no-indent))
+ (should (= (python-indent-calculate-indentation) 0))
+ (forward-line 1)
+ (should (eq (car (python-indent-context)) :inside-paren-newline-start))
+ (should (= (python-indent-calculate-indentation) 4))
+ (forward-line 1)
+ (should (eq (car (python-indent-context)) :inside-paren))
+ (should (= (python-indent-calculate-indentation) 6))
+ (forward-line 1)
+ (should (eq (car (python-indent-context)) :inside-paren))
+ (should (= (python-indent-calculate-indentation) 5))
+ (forward-line 1)
+ (should (eq (car (python-indent-context)) :after-line))
+ (should (= (python-indent-calculate-indentation) 0))
+ (forward-line 1)
+ (should (eq (car (python-indent-context)) :inside-paren-newline-start))
+ (should (= (python-indent-calculate-indentation) 4))
+ (forward-line 1)
+ (should (eq (car (python-indent-context)) :inside-paren))
+ (should (= (python-indent-calculate-indentation) 5))
+ (forward-line 1)
+ (should (eq (car (python-indent-context)) :inside-paren-continuation-line))
+ (should (= (python-indent-calculate-indentation) 5))
+ (forward-line 1)
+ (should (eq (car (python-indent-context)) :inside-paren-continuation-line))
+ (should (= (python-indent-calculate-indentation) 5))
+ (forward-line 1)
+ (should (eq (car (python-indent-context)) :inside-paren-continuation-line))
+ (should (= (python-indent-calculate-indentation) 8))))
+
+(ert-deftest python-indent-inside-paren-block-1 ()
+ "`python-indent-block-paren-deeper' set to nil (default).
+See Bug#62696."
+ (python-tests-with-temp-buffer
+ "
+if ('VALUE' in my_unnecessarily_long_dictionary and
+ some_other_long_condition_case):
+ do_something()
+elif (some_case or
+ another_case):
+ do_another()
+"
+ (python-tests-look-at "if")
+ (should (eq (car (python-indent-context)) :no-indent))
+ (should (= (python-indent-calculate-indentation) 0))
+ (forward-line 1)
+ (should (eq (car (python-indent-context)) :inside-paren-from-block))
+ (should (= (python-indent-calculate-indentation) 4))
+ (forward-line 1)
+ (should (eq (car (python-indent-context)) :after-block-start))
+ (should (= (python-indent-calculate-indentation) 4))
+ (forward-line 1)
+ (should (eq (car (python-indent-context)) :at-dedenter-block-start))
+ (should (= (python-indent-calculate-indentation) 0))
+ (forward-line 1)
+ (should (eq (car (python-indent-context)) :inside-paren-from-block))
+ (should (= (python-indent-calculate-indentation) 6))
+ (forward-line 1)
+ (should (eq (car (python-indent-context)) :after-block-start))
+ (should (= (python-indent-calculate-indentation) 4))))
+
+(ert-deftest python-indent-inside-paren-block-2 ()
+ "`python-indent-block-paren-deeper' set to t.
+See Bug#62696."
+ (python-tests-with-temp-buffer
+ "
+if ('VALUE' in my_unnecessarily_long_dictionary and
+ some_other_long_condition_case):
+ do_something()
+elif (some_case or
+ another_case):
+ do_another()
+"
+ (let ((python-indent-block-paren-deeper t))
+ (python-tests-look-at "if")
+ (should (eq (car (python-indent-context)) :no-indent))
+ (should (= (python-indent-calculate-indentation) 0))
+ (forward-line 1)
+ (should (eq (car (python-indent-context)) :inside-paren-from-block))
+ (should (= (python-indent-calculate-indentation) 8))
+ (forward-line 1)
+ (should (eq (car (python-indent-context)) :after-block-start))
+ (should (= (python-indent-calculate-indentation) 4))
+ (forward-line 1)
+ (should (eq (car (python-indent-context)) :at-dedenter-block-start))
+ (should (= (python-indent-calculate-indentation) 0))
+ (forward-line 1)
+ (should (eq (car (python-indent-context)) :inside-paren-from-block))
+ (should (= (python-indent-calculate-indentation) 6))
+ (forward-line 1)
+ (should (eq (car (python-indent-context)) :after-block-start))
+ (should (= (python-indent-calculate-indentation) 4)))))
+
+(ert-deftest python-indent-inside-paren-block-3 ()
+ "With backslash. `python-indent-block-paren-deeper' set to nil (default).
+See Bug#62696."
+ (python-tests-with-temp-buffer
+ "
+if 'VALUE' in my_uncessarily_long_dictionary and\\
+ (some_other_long_condition_case or
+ another_case):
+ do_something()
+"
+ (python-tests-look-at "if")
+ (should (eq (car (python-indent-context)) :no-indent))
+ (should (= (python-indent-calculate-indentation) 0))
+ (forward-line 1)
+ (should (eq (car (python-indent-context))
+ :after-backslash-block-continuation))
+ (should (= (python-indent-calculate-indentation) 3))
+ (forward-line 1)
+ (should (eq (car (python-indent-context)) :inside-paren-from-block))
+ (should (= (python-indent-calculate-indentation) 4))
+ (forward-line 1)
+ (should (eq (car (python-indent-context)) :after-block-start))
+ (should (= (python-indent-calculate-indentation) 4))))
+
+(ert-deftest python-indent-inside-paren-block-4 ()
+ "With backslash. `python-indent-block-paren-deeper' set to t.
+See Bug#62696."
+ (python-tests-with-temp-buffer
+ "
+if 'VALUE' in my_uncessarily_long_dictionary and\\
+ (some_other_long_condition_case or
+ another_case):
+ do_something()
+"
+ (let ((python-indent-block-paren-deeper t))
+ (python-tests-look-at "if")
+ (should (eq (car (python-indent-context)) :no-indent))
+ (should (= (python-indent-calculate-indentation) 0))
+ (forward-line 1)
+ (should (eq (car (python-indent-context))
+ :after-backslash-block-continuation))
+ (should (= (python-indent-calculate-indentation) 3))
+ (forward-line 1)
+ (should (eq (car (python-indent-context)) :inside-paren-from-block))
+ (should (= (python-indent-calculate-indentation) 8))
+ (forward-line 1)
+ (should (eq (car (python-indent-context)) :after-block-start))
+ (should (= (python-indent-calculate-indentation) 4)))))
+
(ert-deftest python-indent-after-block-1 ()
"The most simple after-block case that shouldn't fail."
(python-tests-with-temp-buffer
@@ -1159,7 +1372,7 @@ objects = Thing.objects.all() \\
(should (eq (car (python-indent-context)) :inside-paren-newline-start))
(should (= (python-indent-calculate-indentation) 27))
(python-tests-look-at "status='bought'")
- (should (eq (car (python-indent-context)) :inside-paren-newline-start))
+ (should (eq (car (python-indent-context)) :inside-paren-continuation-line))
(should (= (python-indent-calculate-indentation) 27))
(python-tests-look-at ") \\")
(should (eq (car (python-indent-context)) :inside-paren-at-closing-paren))
@@ -1530,7 +1743,7 @@ a == 4):
(should (= (python-indent-calculate-indentation) 0))
(should (= (python-indent-calculate-indentation t) 0))
(python-tests-look-at "a == 4):\n")
- (should (eq (car (python-indent-context)) :inside-paren))
+ (should (eq (car (python-indent-context)) :inside-paren-from-block))
(should (= (python-indent-calculate-indentation) 6))
(python-indent-line)
(should (= (python-indent-calculate-indentation t) 4))
@@ -4570,6 +4783,7 @@ def foo():
(python-tests-with-temp-buffer-with-shell
""
(python-shell-with-shell-buffer
+ (skip-unless python-shell-readline-completer-delims)
(insert "import abc")
(comint-send-input)
(python-tests-shell-wait-for-prompt)
@@ -4584,6 +4798,7 @@ def foo():
""
(python-shell-completion-native-turn-on)
(python-shell-with-shell-buffer
+ (skip-unless python-shell-readline-completer-delims)
(insert "import abc")
(comint-send-input)
(python-tests-shell-wait-for-prompt)
@@ -4592,6 +4807,114 @@ def foo():
(end-of-line 0)
(should-not (nth 2 (python-shell-completion-at-point))))))
+(defun python-tests--completion-module ()
+ "Check if modules can be completed in Python shell."
+ (insert "import datet")
+ (completion-at-point)
+ (beginning-of-line)
+ (should (looking-at-p "import datetime"))
+ (kill-line)
+ (insert "from datet")
+ (completion-at-point)
+ (beginning-of-line)
+ (should (looking-at-p "from datetime"))
+ (end-of-line)
+ (insert " import timed")
+ (completion-at-point)
+ (beginning-of-line)
+ (should (looking-at-p "from datetime import timedelta"))
+ (kill-line))
+
+(defun python-tests--completion-parameters ()
+ "Check if parameters can be completed in Python shell."
+ (insert "import re")
+ (comint-send-input)
+ (python-tests-shell-wait-for-prompt)
+ (insert "re.split('b', 'abc', maxs")
+ (completion-at-point)
+ (should (string= "re.split('b', 'abc', maxsplit="
+ (buffer-substring (line-beginning-position) (point))))
+ (insert "0, ")
+ (should (python-shell-completion-at-point))
+ ;; Test if cache is used.
+ (cl-letf (((symbol-function 'python-shell-completion-get-completions)
+ 'ignore)
+ ((symbol-function 'python-shell-completion-native-get-completions)
+ 'ignore))
+ (insert "fla")
+ (completion-at-point)
+ (should (string= "re.split('b', 'abc', maxsplit=0, flags="
+ (buffer-substring (line-beginning-position) (point)))))
+ (beginning-of-line)
+ (kill-line))
+
+(defun python-tests--completion-extra-context ()
+ "Check if extra context is used for completion."
+ (insert "re.split('b', 'abc',")
+ (comint-send-input)
+ (python-tests-shell-wait-for-prompt)
+ (insert "maxs")
+ (completion-at-point)
+ (should (string= "maxsplit="
+ (buffer-substring (line-beginning-position) (point))))
+ (insert "0)")
+ (comint-send-input)
+ (python-tests-shell-wait-for-prompt)
+ (insert "from re import (")
+ (comint-send-input)
+ (python-tests-shell-wait-for-prompt)
+ (insert "IGN")
+ (completion-at-point)
+ (should (string= "IGNORECASE"
+ (buffer-substring (line-beginning-position) (point)))))
+
+(defun python-tests--pythonstartup-file ()
+ "Return Jedi readline setup file if PYTHONSTARTUP is not set."
+ (or (getenv "PYTHONSTARTUP")
+ (with-temp-buffer
+ (if (eql 0 (call-process python-tests-shell-interpreter
+ nil t nil "-m" "jedi" "repl"))
+ (string-trim (buffer-string))
+ ""))))
+
+(ert-deftest python-shell-completion-at-point-jedi-completer ()
+ "Check if Python shell completion works when Jedi completer is used."
+ (skip-unless (executable-find python-tests-shell-interpreter))
+ (with-environment-variables
+ (("PYTHONSTARTUP" (python-tests--pythonstartup-file)))
+ (python-tests-with-temp-buffer-with-shell
+ ""
+ (python-shell-with-shell-buffer
+ (skip-unless (string= python-shell-readline-completer-delims ""))
+ (python-shell-completion-native-turn-off)
+ (python-tests--completion-module)
+ (python-tests--completion-parameters)
+ (python-shell-completion-native-turn-on)
+ (python-tests--completion-module)
+ (python-tests--completion-parameters)
+ (python-tests--completion-extra-context)))))
+
+(ert-deftest python-shell-completion-at-point-ipython ()
+ "Check if Python shell completion works for IPython."
+ (let ((python-shell-interpreter "ipython")
+ (python-shell-interpreter-args "-i --simple-prompt"))
+ (skip-unless
+ (and
+ (executable-find python-shell-interpreter)
+ (eql (call-process python-shell-interpreter nil nil nil "--version") 0)))
+ (with-environment-variables
+ (("PYTHONSTARTUP" (python-tests--pythonstartup-file)))
+ (python-tests-with-temp-buffer-with-shell
+ ""
+ (python-shell-with-shell-buffer
+ (python-shell-completion-native-turn-off)
+ (python-tests--completion-module)
+ (python-tests--completion-parameters)
+ (python-shell-completion-native-turn-on)
+ (skip-unless (string= python-shell-readline-completer-delims ""))
+ (python-tests--completion-module)
+ (python-tests--completion-parameters)
+ (python-tests--completion-extra-context))))))
;;; PDB Track integration
@@ -4606,6 +4929,8 @@ def foo():
import abc
"
(let ((inhibit-message t))
+ (python-shell-with-shell-buffer
+ (skip-unless python-shell-readline-completer-delims))
(python-shell-send-buffer)
(python-tests-shell-wait-for-prompt)
(goto-char (point-max))
@@ -4622,6 +4947,8 @@ import abc
import abc
"
(let ((inhibit-message t))
+ (python-shell-with-shell-buffer
+ (skip-unless python-shell-readline-completer-delims))
(python-shell-send-buffer)
(python-tests-shell-wait-for-prompt)
(python-shell-with-shell-buffer
@@ -4641,6 +4968,8 @@ pdb.set_trace()
print('Hello')
"
(let ((inhibit-message t))
+ (python-shell-with-shell-buffer
+ (skip-unless python-shell-readline-completer-delims))
(python-shell-send-buffer)
(python-tests-shell-wait-for-prompt)
(goto-char (point-max))
@@ -4657,6 +4986,8 @@ import time
time.sleep(3)
"
(let ((inhibit-message t))
+ (python-shell-with-shell-buffer
+ (skip-unless python-shell-readline-completer-delims))
(python-shell-send-buffer)
(goto-char (point-max))
(insert "time.")
@@ -4669,6 +5000,8 @@ time.sleep(3)
import abc
"
(let ((inhibit-message t))
+ (python-shell-with-shell-buffer
+ (skip-unless python-shell-readline-completer-delims))
(python-shell-completion-native-turn-on)
(python-shell-send-buffer)
(python-tests-shell-wait-for-prompt)
@@ -4686,6 +5019,8 @@ import abc
import abc
"
(let ((inhibit-message t))
+ (python-shell-with-shell-buffer
+ (skip-unless python-shell-readline-completer-delims))
(python-shell-completion-native-turn-on)
(python-shell-send-buffer)
(python-tests-shell-wait-for-prompt)
@@ -4702,6 +5037,8 @@ import abc
import abc
"
(let ((inhibit-message t))
+ (python-shell-with-shell-buffer
+ (skip-unless python-shell-readline-completer-delims))
(python-shell-completion-native-turn-on)
(python-shell-send-buffer)
(python-tests-shell-wait-for-prompt)
@@ -4718,6 +5055,8 @@ import abc
import abc
"
(let ((inhibit-message t))
+ (python-shell-with-shell-buffer
+ (skip-unless python-shell-readline-completer-delims))
(python-shell-completion-native-turn-on)
(python-shell-send-buffer)
(python-tests-shell-wait-for-prompt)
@@ -4738,11 +5077,6 @@ import abc
(ert-deftest python-ffap-module-path-1 ()
(skip-unless (executable-find python-tests-shell-interpreter))
- ;; Skip the test on macOS, since the standard Python installation uses
- ;; libedit rather than readline which confuses the running of an inferior
- ;; interpreter in this case (see bug#59477 and bug#25753).
- (skip-unless (not (eq system-type 'darwin)))
- (trace-function 'python-shell-output-filter)
(python-tests-with-temp-buffer-with-shell
"
import abc
@@ -5796,9 +6130,9 @@ def func():
else
"
(python-tests-look-at "else\n")
- (should
- (equal (list (python-tests-look-at "if (" -1 t))
- (python-info-dedenter-opening-block-positions)))))
+ (should
+ (equal (list (python-tests-look-at "if (" -1 t))
+ (python-info-dedenter-opening-block-positions)))))
(ert-deftest python-info-dedenter-opening-block-positions-7 ()
"Test case blocks."
@@ -5816,9 +6150,9 @@ match a:
(python-tests-look-at "case 2:")
(should-not (python-info-dedenter-opening-block-positions))
(python-tests-look-at "case 3:")
- (equal (list (python-tests-look-at "case 2:" -1)
- (python-tests-look-at "case 1:" -1 t))
- (python-info-dedenter-opening-block-positions))))
+ (should (equal (list (python-tests-look-at "case 2:" -1 t)
+ (python-tests-look-at "case 1:" -1 t))
+ (python-info-dedenter-opening-block-positions)))))
(ert-deftest python-info-dedenter-opening-block-message-1 ()
"Test dedenters inside strings are ignored."
@@ -6470,6 +6804,15 @@ class Class:
(python-tests-look-at "Also not a docstring")
(should-not (python-info-docstring-p))))
+(ert-deftest python-info-docstring-p-8 ()
+ "Test string in the 2nd line of a buffer."
+ (python-tests-with-temp-buffer
+ "import sys
+'''Not a docstring.'''
+"
+ (python-tests-look-at "Not a docstring")
+ (should-not (python-info-docstring-p))))
+
(ert-deftest python-info-triple-quoted-string-p-1 ()
"Test triple quoted string."
(python-tests-with-temp-buffer
diff --git a/test/lisp/progmodes/ruby-mode-resources/ruby.rb b/test/lisp/progmodes/ruby-mode-resources/ruby.rb
index 81d0dfd75c9..a411b39a8fc 100644
--- a/test/lisp/progmodes/ruby-mode-resources/ruby.rb
+++ b/test/lisp/progmodes/ruby-mode-resources/ruby.rb
@@ -34,11 +34,11 @@ x = # "tot %q/to"; =
# Regexp after whitelisted method.
"abc".sub /b/, 'd'
-# Don't mismatch "sub" at the end of words.
-a = asub / aslb + bsub / bslb;
+# Don't mistake division for regexp.
+a = sub / aslb + bsub / bslb;
# Highlight the regexp after "if".
-x = toto / foo if /do bar/ =~ "dobar"
+x = toto / foo if / do bar/ =~ "dobar"
# Regexp options are highlighted.
diff --git a/test/lisp/progmodes/ruby-mode-tests.el b/test/lisp/progmodes/ruby-mode-tests.el
index 5a097923001..2b8506a7adc 100644
--- a/test/lisp/progmodes/ruby-mode-tests.el
+++ b/test/lisp/progmodes/ruby-mode-tests.el
@@ -164,7 +164,7 @@ VALUES-PLIST is a list with alternating index and value elements."
(ruby-assert-state "x = index/3" 3 nil))
(ert-deftest ruby-regexp-not-division-when-only-space-before ()
- (ruby-assert-state "x = index /3" 3 ?/))
+ (ruby-assert-state "x = foo_index /3" 3 ?/))
(ert-deftest ruby-slash-not-regexp-when-only-space-after ()
(ruby-assert-state "x = index/ 3" 3 nil))
diff --git a/test/lisp/progmodes/sh-script-resources/sh-indents.erts b/test/lisp/progmodes/sh-script-resources/sh-indents.erts
index 1f92610b3aa..36f4e4c22ab 100644
--- a/test/lisp/progmodes/sh-script-resources/sh-indents.erts
+++ b/test/lisp/progmodes/sh-script-resources/sh-indents.erts
@@ -38,3 +38,10 @@ if test ;then
fi
other
=-=-=
+
+Name: sh-indents5
+
+=-=
+for i do echo 1; done
+for i; do echo 1; done
+=-=-=
diff --git a/test/lisp/progmodes/sh-script-tests.el b/test/lisp/progmodes/sh-script-tests.el
index 71e5dc86db0..e73d52399d3 100644
--- a/test/lisp/progmodes/sh-script-tests.el
+++ b/test/lisp/progmodes/sh-script-tests.el
@@ -52,6 +52,24 @@
(ert-deftest test-indentation ()
(ert-test-erts-file (ert-resource-file "sh-indents.erts")))
+(ert-deftest test-indent-after-continuation ()
+ (with-temp-buffer
+ (insert "for f \\\nin a; do \\\ntoto; \\\ndone\n")
+ (shell-script-mode)
+ (let ((sh-indent-for-continuation '++))
+ (let ((sh-indent-after-continuation t))
+ (indent-region (point-min) (point-max))
+ (should (equal (buffer-string)
+ "for f \\\n\tin a; do \\\n toto; \\\n done\n")))
+ (let ((sh-indent-after-continuation 'always))
+ (indent-region (point-min) (point-max))
+ (should (equal (buffer-string)
+ "for f \\\n\tin a; do \\\n\ttoto; \\\n\tdone\n")))
+ (let ((sh-indent-after-continuation nil))
+ (indent-region (point-min) (point-max))
+ (should (equal (buffer-string)
+ "for f \\\nin a; do \\\n toto; \\\ndone\n"))))))
+
(defun test-sh-back (string &optional pos)
(with-temp-buffer
(shell-script-mode)
@@ -69,4 +87,15 @@
(should-not (test-sh-back "foo;bar"))
(should (test-sh-back "foo#zot")))
+(ert-deftest sh-script-test-do-fontification ()
+ "Test that \"do\" gets fontified correctly, even with no \";\"."
+ (with-temp-buffer
+ (shell-script-mode)
+ (insert "for i do echo 1; done")
+ (font-lock-ensure)
+ (goto-char (point-min))
+ (search-forward "do")
+ (forward-char -1)
+ (should (equal (get-text-property (point) 'face) 'font-lock-keyword-face))))
+
;;; sh-script-tests.el ends here
diff --git a/test/lisp/progmodes/which-func-tests.el b/test/lisp/progmodes/which-func-tests.el
new file mode 100644
index 00000000000..0baee576463
--- /dev/null
+++ b/test/lisp/progmodes/which-func-tests.el
@@ -0,0 +1,58 @@
+;;; which-func-tests.el --- tests for which-func -*- lexical-binding: t; -*-
+
+;; Copyright (C) 2023-2024 Free Software Foundation, Inc.
+
+;; Author: Spencer Baugh <sbaugh@catern.com>
+
+;; This file is part of GNU Emacs.
+
+;; 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 GNU Emacs. If not, see <https://www.gnu.org/licenses/>.
+
+;;; Commentary:
+
+;;; Code:
+(require 'ert)
+(require 'which-func)
+
+(ert-deftest which-func-tests-toggle ()
+ (let ((which-func-display 'mode-and-header) buf-code buf-not)
+ (setq buf-code (find-file-noselect "which-func-tests.el"))
+ (setq buf-not (get-buffer-create "fundamental"))
+ (with-current-buffer buf-code
+ (should-not which-func-mode) (should-not header-line-format))
+ (with-current-buffer buf-not
+ (should-not which-func-mode) (should-not header-line-format))
+ (which-function-mode 1)
+ (with-current-buffer buf-code
+ (should which-func-mode) (should header-line-format))
+ (with-current-buffer buf-not
+ (should-not which-func-mode) (should-not header-line-format))
+ (which-function-mode -1)
+ ;; which-func-mode stays set even when which-function-mode is off.
+ (with-current-buffer buf-code
+ (should which-func-mode) (should-not header-line-format))
+ (with-current-buffer buf-not
+ (should-not which-func-mode) (should-not header-line-format))
+ (kill-buffer buf-code)
+ (kill-buffer buf-not)
+ (which-function-mode 1)
+ (setq buf-code (find-file-noselect "which-func-tests.el"))
+ (setq buf-not (get-buffer-create "fundamental"))
+ (with-current-buffer buf-code
+ (should which-func-mode) (should header-line-format))
+ (with-current-buffer buf-not
+ (should-not which-func-mode) (should-not header-line-format))))
+
+(provide 'which-func-tests)
+;;; which-func-tests.el ends here
diff --git a/test/lisp/server-tests.el b/test/lisp/server-tests.el
index e812795ee84..420338346f1 100644
--- a/test/lisp/server-tests.el
+++ b/test/lisp/server-tests.el
@@ -25,12 +25,18 @@
(defconst server-tests/can-create-frames-p
(and (not (memq system-type '(windows-nt ms-dos)))
- (not (member (getenv "TERM") '("dumb" "" nil))))
+ (not (member (getenv "TERM") '("dumb" "" nil)))
+ (or (not (eq system-type 'cygwin))
+ (featurep 'gfilenotify)
+ (featurep 'dbus)
+ (featurep 'threads)))
"Non-nil if we can create a new frame in the tests.
Some tests below need to create new frames for the emacsclient.
However, this doesn't work on all platforms. In particular,
-MS-Windows fails to create frames from a batch Emacs session. In
-cases like that, we just skip the test.")
+MS-Windows fails to create frames from a batch Emacs session.
+The same is true on Cygwin unless Emacs has at least one of the
+features gfilenotify, dbus, or threads (bug#65325). In cases
+like that, we just skip the test.")
(defconst server-tests/max-wait-time 5
"The maximum time to wait in `server-tests/wait-until', in seconds.")
diff --git a/test/lisp/ses-tests.el b/test/lisp/ses-tests.el
index 0c9d76ca3f6..a916aed9eb3 100644
--- a/test/lisp/ses-tests.el
+++ b/test/lisp/ses-tests.el
@@ -1,4 +1,4 @@
-;;; ses-tests.el --- Tests for ses.el -*- lexical-binding: t; -*-
+;;; SES-tests.el --- Tests for ses.el -*- lexical-binding: t; -*-
;; Copyright (C) 2015-2024 Free Software Foundation, Inc.
@@ -241,6 +241,28 @@ to `ses--bar' and inserting a row, makes A2 value empty, and `ses--bar' equal to
(ses-command-hook)
(should (eq (ses--cell-at-pos (point)) 'ses--toto)))))
+(ert-deftest ses-set-formula-write-cells-with-changed-references ()
+ "Test fix of bug#5852.
+When setting a formula has some cell with changed references, this
+cell has to be rewritten to data area."
+ (let ((ses-initial-size '(4 . 3))
+ (ses-after-entry-functions nil))
+ (with-temp-buffer
+ (ses-mode)
+ (dolist (c '((0 1 1); B1
+ (1 0 2) (1 1 (+ B1 A2)); A2 B2
+ (2 0 4); A3
+ (3 0 3) (3 1 (+ B2 A4))));A4 B4
+ (apply 'ses-cell-set-formula c)
+ (apply 'ses-calculate-cell (list (car c) (cadr c) nil)))
+ (ses-cell-set-formula 2 1 '(+ B2 A3)); B3
+ (ses-command-hook)
+ (ses-cell-set-formula 3 1 '(+ B3 A4)); B4
+ (ses-command-hook)
+ (should (equal (ses-cell-references 1 1) '(B3)))
+ (ses-mode)
+ (should (equal (ses-cell-references 1 1) '(B3))))))
+
(provide 'ses-tests)
;;; ses-tests.el ends here
diff --git a/test/lisp/shadowfile-tests.el b/test/lisp/shadowfile-tests.el
index 964679cd087..4485c73a7bc 100644
--- a/test/lisp/shadowfile-tests.el
+++ b/test/lisp/shadowfile-tests.el
@@ -101,7 +101,7 @@ Per definition, all files are identical on the different hosts of
a cluster (or site). This is not tested here; it must be
guaranteed by the originator of a cluster definition."
:tags '(:expensive-test)
- (skip-unless (not (memq system-type '(windows-nt ms-dos))))
+ (skip-when (memq system-type '(windows-nt ms-dos)))
(skip-unless (file-remote-p ert-remote-temporary-file-directory))
(let ((text-quoting-style 'grave) ;; We inspect the *Messages* buffer!
@@ -219,7 +219,7 @@ guaranteed by the originator of a cluster definition."
Per definition, all files are identical on the different hosts of
a cluster (or site). This is not tested here; it must be
guaranteed by the originator of a cluster definition."
- (skip-unless (not (memq system-type '(windows-nt ms-dos))))
+ (skip-when (memq system-type '(windows-nt ms-dos)))
(skip-unless (file-remote-p ert-remote-temporary-file-directory))
(let ((shadow-info-file shadow-test-info-file)
@@ -320,7 +320,7 @@ guaranteed by the originator of a cluster definition."
(ert-deftest shadow-test02-files ()
"Check file manipulation functions."
- (skip-unless (not (memq system-type '(windows-nt ms-dos))))
+ (skip-when (memq system-type '(windows-nt ms-dos)))
(skip-unless (file-remote-p ert-remote-temporary-file-directory))
(let ((shadow-info-file shadow-test-info-file)
@@ -391,7 +391,7 @@ guaranteed by the originator of a cluster definition."
(ert-deftest shadow-test03-expand-cluster-in-file-name ()
"Check canonical file name of a cluster or site."
- (skip-unless (not (memq system-type '(windows-nt ms-dos))))
+ (skip-when (memq system-type '(windows-nt ms-dos)))
(skip-unless (file-remote-p ert-remote-temporary-file-directory))
(let ((shadow-info-file shadow-test-info-file)
@@ -456,7 +456,7 @@ guaranteed by the originator of a cluster definition."
(ert-deftest shadow-test04-contract-file-name ()
"Check canonical file name of a cluster or site."
- (skip-unless (not (memq system-type '(windows-nt ms-dos))))
+ (skip-when (memq system-type '(windows-nt ms-dos)))
(skip-unless (file-remote-p ert-remote-temporary-file-directory))
(let ((shadow-info-file shadow-test-info-file)
@@ -511,7 +511,7 @@ guaranteed by the originator of a cluster definition."
(ert-deftest shadow-test05-file-match ()
"Check `shadow-same-site' and `shadow-file-match'."
- (skip-unless (not (memq system-type '(windows-nt ms-dos))))
+ (skip-when (memq system-type '(windows-nt ms-dos)))
(skip-unless (file-remote-p ert-remote-temporary-file-directory))
(let ((shadow-info-file shadow-test-info-file)
@@ -563,7 +563,7 @@ guaranteed by the originator of a cluster definition."
(ert-deftest shadow-test06-literal-groups ()
"Check literal group definitions."
- (skip-unless (not (memq system-type '(windows-nt ms-dos))))
+ (skip-when (memq system-type '(windows-nt ms-dos)))
(skip-unless (file-remote-p ert-remote-temporary-file-directory))
(let ((shadow-info-file shadow-test-info-file)
@@ -648,7 +648,7 @@ guaranteed by the originator of a cluster definition."
(ert-deftest shadow-test07-regexp-groups ()
"Check regexp group definitions."
- (skip-unless (not (memq system-type '(windows-nt ms-dos))))
+ (skip-when (memq system-type '(windows-nt ms-dos)))
(skip-unless (file-remote-p ert-remote-temporary-file-directory))
(let ((shadow-info-file shadow-test-info-file)
@@ -710,7 +710,7 @@ guaranteed by the originator of a cluster definition."
(ert-deftest shadow-test08-shadow-todo ()
"Check that needed shadows are added to todo."
- (skip-unless (not (memq system-type '(windows-nt ms-dos))))
+ (skip-when (memq system-type '(windows-nt ms-dos)))
(skip-unless (file-remote-p ert-remote-temporary-file-directory))
(skip-unless (file-writable-p ert-remote-temporary-file-directory))
@@ -855,7 +855,7 @@ guaranteed by the originator of a cluster definition."
(ert-deftest shadow-test09-shadow-copy-files ()
"Check that needed shadow files are copied."
:tags '(:expensive-test)
- (skip-unless (not (memq system-type '(windows-nt ms-dos))))
+ (skip-when (memq system-type '(windows-nt ms-dos)))
(skip-unless (file-remote-p ert-remote-temporary-file-directory))
(skip-unless (file-writable-p ert-remote-temporary-file-directory))
diff --git a/test/lisp/shell-tests.el b/test/lisp/shell-tests.el
index 58e9bd29c70..9bdf6b1c0eb 100644
--- a/test/lisp/shell-tests.el
+++ b/test/lisp/shell-tests.el
@@ -64,4 +64,35 @@
(should (equal (split-string-shell-command "ls /tmp/foo\\ bar")
'("ls" "/tmp/foo bar")))))
+(ert-deftest shell-dirtrack-on-by-default ()
+ (with-temp-buffer
+ (shell-mode)
+ (should shell-dirtrack-mode)))
+
+(ert-deftest shell-dirtrack-should-not-be-on-in-unrelated-modes ()
+ (with-temp-buffer
+ (should (not shell-dirtrack-mode))))
+
+(ert-deftest shell-dirtrack-sets-list-buffers-directory ()
+ (let ((start-dir default-directory))
+ (with-temp-buffer
+ (should-not list-buffers-directory)
+ (shell-mode)
+ (shell-cd "..")
+ (should list-buffers-directory)
+ (should (not (equal start-dir list-buffers-directory)))
+ (should (string-prefix-p list-buffers-directory start-dir)))))
+
+(ert-deftest shell-directory-tracker-cd ()
+ (let ((start-dir default-directory))
+ (with-temp-buffer
+ (should-not list-buffers-directory)
+ (shell-mode)
+ (cl-letf (((symbol-function 'shell-unquote-argument)
+ (lambda (x) x)))
+ (shell-directory-tracker "cd .."))
+ (should list-buffers-directory)
+ (should (not (equal start-dir list-buffers-directory)))
+ (should (string-prefix-p list-buffers-directory start-dir)))))
+
;;; shell-tests.el ends here
diff --git a/test/lisp/simple-tests.el b/test/lisp/simple-tests.el
index a58fa9d41f8..afd75786804 100644
--- a/test/lisp/simple-tests.el
+++ b/test/lisp/simple-tests.el
@@ -742,7 +742,7 @@ See Bug#21722."
(ert-deftest eval-expression-print-format-sym-echo ()
;; We can only check the echo area when running interactive.
- (skip-unless (not noninteractive))
+ (skip-when noninteractive)
(with-temp-buffer
(cl-letf (((symbol-function 'read--expression) (lambda (&rest _) t)))
(let ((current-prefix-arg nil))
@@ -763,7 +763,7 @@ See Bug#21722."
(should (equal (buffer-string) "65 (#o101, #x41, ?A)"))))))
(ert-deftest eval-expression-print-format-small-int-echo ()
- (skip-unless (not noninteractive))
+ (skip-when noninteractive)
(with-temp-buffer
(cl-letf (((symbol-function 'read--expression) (lambda (&rest _) ?A)))
(let ((current-prefix-arg nil))
@@ -789,7 +789,7 @@ See Bug#21722."
(should (equal (buffer-string) "66 (#o102, #x42, ?B)"))))))
(ert-deftest eval-expression-print-format-large-int-echo ()
- (skip-unless (not noninteractive))
+ (skip-when noninteractive)
(with-temp-buffer
(cl-letf (((symbol-function 'read--expression) (lambda (&rest _) ?B))
(eval-expression-print-maximum-character ?A))
@@ -839,7 +839,7 @@ See Bug#21722."
(forward-line 2)
(narrow-to-region (pos-bol) (pos-eol))
(should (equal (line-number-at-pos) 1))
- (line-number-at-pos nil t)
+ (should (equal (line-number-at-pos nil t) 3))
(should (equal (line-number-at-pos) 1))))
(ert-deftest line-number-at-pos-keeps-point ()
@@ -849,8 +849,8 @@ See Bug#21722."
(goto-char (point-min))
(forward-line 2)
(setq pos (point))
- (line-number-at-pos)
- (line-number-at-pos nil t)
+ (should (equal (line-number-at-pos) 3))
+ (should (equal (line-number-at-pos nil t) 3))
(should (equal pos (point))))))
(ert-deftest line-number-at-pos-when-passing-point ()
diff --git a/test/lisp/subr-tests.el b/test/lisp/subr-tests.el
index fb0129707c8..4e3f743cc93 100644
--- a/test/lisp/subr-tests.el
+++ b/test/lisp/subr-tests.el
@@ -345,18 +345,54 @@
;;;; Mode hooks.
-(defalias 'subr-tests--parent-mode
- (if (fboundp 'prog-mode) 'prog-mode 'fundamental-mode))
+(defalias 'subr-tests--parent-mode #'prog-mode)
+(define-derived-mode subr-tests--derived-mode-1 prog-mode "test")
+(define-derived-mode subr-tests--derived-mode-2 subr-tests--parent-mode "test")
(ert-deftest provided-mode-derived-p ()
;; base case: `derived-mode' directly derives `prog-mode'
- (should (progn
- (define-derived-mode derived-mode prog-mode "test")
- (provided-mode-derived-p 'derived-mode 'prog-mode)))
- ;; edge case: `derived-mode' derives an alias of `prog-mode'
- (should (progn
- (define-derived-mode derived-mode subr-tests--parent-mode "test")
- (provided-mode-derived-p 'derived-mode 'prog-mode))))
+ (should (provided-mode-derived-p 'subr-tests--derived-mode-1 'prog-mode))
+ ;; Edge cases: aliases along the derivation.
+ (should (provided-mode-derived-p 'subr-tests--parent-mode
+ 'subr-tests--parent-mode))
+ (should (provided-mode-derived-p 'subr-tests--derived-mode-2
+ 'subr-tests--parent-mode))
+ (should (provided-mode-derived-p 'subr-tests--derived-mode-2 'prog-mode)))
+
+
+(define-derived-mode subr-tests--mode-A subr-tests--derived-mode-1 "t")
+(define-derived-mode subr-tests--mode-B subr-tests--mode-A "t")
+(defalias 'subr-tests--mode-C #'subr-tests--mode-B)
+(derived-mode-add-parents 'subr-tests--mode-A '(subr-tests--mode-C))
+
+(ert-deftest subr-tests--derived-mode-add-parents ()
+ ;; The Right Answer is somewhat unclear in the presence of cycles,
+ ;; but let's make sure we get tolerable answers.
+ ;; FIXME: Currently `prog-mode' doesn't always end up at the end :-(
+ (let ((set-equal (lambda (a b)
+ (not (or (cl-set-difference a b)
+ (cl-set-difference b a))))))
+ (dolist (mode '(subr-tests--mode-A subr-tests--mode-B subr-tests--mode-C))
+ (should (eq (derived-mode-all-parents mode)
+ (derived-mode-all-parents mode)))
+ (should (eq mode (car (derived-mode-all-parents mode))))
+ (should (funcall set-equal
+ (derived-mode-all-parents mode)
+ '(subr-tests--mode-A subr-tests--mode-B prog-mode
+ subr-tests--mode-C subr-tests--derived-mode-1))))))
+
+(ert-deftest subr-tests--merge-ordered-lists ()
+ (should (equal (merge-ordered-lists
+ '((B A) (C A) (D B) (E D C))
+ (lambda (_) (error "cycle")))
+ '(E D B C A)))
+ (should (equal (merge-ordered-lists
+ '((E D C) (B A) (C A) (D B))
+ (lambda (_) (error "cycle")))
+ '(E D C B A)))
+ (should-error (merge-ordered-lists
+ '((E C D) (B A) (A C) (D B))
+ (lambda (_) (error "cycle")))))
(ert-deftest number-sequence-test ()
(should (= (length
@@ -579,7 +615,8 @@
(cons (mapcar (pcase-lambda (`(,evald ,func ,args ,_))
`(,evald ,func ,@args))
(backtrace-frames base))
- (subr-test--backtrace-frames-with-backtrace-frame base))))))
+ (subr-test--backtrace-frames-with-backtrace-frame base))
+ (sit-for 0))))) ; dummy unwind form
(defun subr-test--frames-1 (base)
(subr-test--frames-2 base))
@@ -1058,10 +1095,12 @@ final or penultimate step during initialization."))
'(subr-tests--b subr-tests--c)))
(defalias 'subr-tests--d 'subr-tests--e)
- (defalias 'subr-tests--e 'subr-tests--d)
- (should-error (function-alias-p 'subr-tests--d))
- (should (equal (function-alias-p 'subr-tests--d t)
- '(subr-tests--e))))
+ (should (equal (function-alias-p 'subr-tests--d)
+ '(subr-tests--e)))
+
+ (fset 'subr-tests--f 'subr-tests--a)
+ (should (equal (function-alias-p 'subr-tests--f)
+ '(subr-tests--a subr-tests--b subr-tests--c))))
(ert-deftest test-readablep ()
(should (readablep "foo"))
@@ -1169,5 +1208,120 @@ final or penultimate step during initialization."))
(should-not (list-of-strings-p '("a" nil "b")))
(should-not (list-of-strings-p '("a" "b" . "c"))))
+(ert-deftest subr--delete-dups ()
+ (should (equal (delete-dups nil) nil))
+ (let* ((a (list "a" "b" "c"))
+ (a-dedup (delete-dups a)))
+ (should (equal a-dedup '("a" "b" "c")))
+ (should (eq a a-dedup)))
+ (let* ((a (list "a" "a" "b" "b" "a" "c" "b" "c" "a"))
+ (a-b (cddr a)) ; link of first "b"
+ (a-dedup (delete-dups a)))
+ (should (equal a-dedup '("a" "b" "c")))
+ (should (eq a a-dedup))
+ (should (eq (cdr a-dedup) a-b))))
+
+(ert-deftest subr--delete-consecutive-dups ()
+ (should (equal (delete-consecutive-dups nil) nil))
+ (let* ((a (list "a" "b" "c"))
+ (a-dedup (delete-consecutive-dups a)))
+ (should (equal a-dedup '("a" "b" "c")))
+ (should (eq a a-dedup)))
+ (let* ((a (list "a" "a" "b" "a" "a" "b" "b" "b" "c" "c" "a" "a"))
+ (a-b (nthcdr 3 a)) ; link of third "a"
+ (a-dedup (delete-consecutive-dups a)))
+ (should (equal a-dedup '("a" "b" "a" "b" "c" "a")))
+ (should (eq a a-dedup))
+ (should (equal (nthcdr 2 a-dedup) a-b)))
+ (let* ((a (list "a" "b" "a"))
+ (a-dedup (delete-consecutive-dups a t)))
+ (should (equal a-dedup '("a" "b")))
+ (should (eq a a-dedup)))
+ (let* ((a (list "a" "a" "b" "a" "a" "b" "b" "b" "c" "c" "a" "a"))
+ (a-dedup (delete-consecutive-dups a t)))
+ (should (equal a-dedup '("a" "b" "a" "b" "c")))
+ (should (eq a a-dedup))))
+
+(ert-deftest subr--copy-tree ()
+ ;; Check that values other than conses, vectors and records are
+ ;; neither copied nor traversed.
+ (let ((s (propertize "abc" 'prop (list 11 12)))
+ (h (make-hash-table :test #'equal)))
+ (puthash (list 1 2) (list 3 4) h)
+ (dolist (x (list nil 'a "abc" s h))
+ (should (eq (copy-tree x) x))
+ (should (eq (copy-tree x t) x))))
+
+ ;; Use the printer to detect common parts of Lisp values.
+ (let ((print-circle t))
+ (cl-labels ((prn3 (x y z) (prin1-to-string (list x y z)))
+ (cat3 (x y z) (concat "(" x " " y " " z ")")))
+ (let ((x '(a (b ((c) . d) e) (f))))
+ (should (equal (prn3 x (copy-tree x) (copy-tree x t))
+ (cat3 "(a (b ((c) . d) e) (f))"
+ "(a (b ((c) . d) e) (f))"
+ "(a (b ((c) . d) e) (f))"))))
+ (let ((x '(a [b (c d)] #s(e (f [g])))))
+ (should (equal (prn3 x (copy-tree x) (copy-tree x t))
+ (cat3 "(a #1=[b (c d)] #2=#s(e (f [g])))"
+ "(a #1# #2#)"
+ "(a [b (c d)] #s(e (f [g])))"))))
+ (let ((x [a (b #s(c d))]))
+ (should (equal (prn3 x (copy-tree x) (copy-tree x t))
+ (cat3 "#1=[a (b #s(c d))]"
+ "#1#"
+ "[a (b #s(c d))]"))))
+ (let ((x #s(a (b [c d]))))
+ (should (equal (prn3 x (copy-tree x) (copy-tree x t))
+ (cat3 "#1=#s(a (b [c d]))"
+ "#1#"
+ "#s(a (b [c d]))"))))
+ ;; Check cdr recursion.
+ (let ((x '(a b . [(c . #s(d))])))
+ (should (equal (prn3 x (copy-tree x) (copy-tree x t))
+ (cat3 "(a b . #1=[(c . #s(d))])"
+ "(a b . #1#)"
+ "(a b . [(c . #s(d))])"))))
+ ;; Check that we can copy DAGs (the result is a tree).
+ (let ((x (list '(a b) nil [c d] nil #s(e f) nil)))
+ (setf (nth 1 x) (nth 0 x))
+ (setf (nth 3 x) (nth 2 x))
+ (setf (nth 5 x) (nth 4 x))
+ (should (equal (prn3 x (copy-tree x) (copy-tree x t))
+ (cat3 "(#1=(a b) #1# #2=[c d] #2# #3=#s(e f) #3#)"
+ "((a b) (a b) #2# #2# #3# #3#)"
+ "((a b) (a b) [c d] [c d] #s(e f) #s(e f))")))))))
+
+(ert-deftest condition-case-unless-debug ()
+ "Test `condition-case-unless-debug'."
+ (let ((debug-on-error nil))
+ (with-suppressed-warnings ((suspicious condition-case))
+ (should (= 0 (condition-case-unless-debug nil 0))))
+ (should (= 0 (condition-case-unless-debug nil 0 (t 1))))
+ (should (= 0 (condition-case-unless-debug x 0 (t (1+ x)))))
+ (should (= 1 (condition-case-unless-debug nil (error "") (t 1))))
+ (should (equal (condition-case-unless-debug x (error "") (t x))
+ '(error "")))))
+
+(ert-deftest condition-case-unless-debug-success ()
+ "Test `condition-case-unless-debug' with :success (bug#64404)."
+ (let ((debug-on-error nil))
+ (should (= 1 (condition-case-unless-debug nil 0 (:success 1))))
+ (should (= 1 (condition-case-unless-debug nil 0 (:success 1) (t 2))))
+ (should (= 1 (condition-case-unless-debug nil 0 (t 2) (:success 1))))
+ (should (= 1 (condition-case-unless-debug x 0 (:success (1+ x)))))
+ (should (= 1 (condition-case-unless-debug x 0 (:success (1+ x)) (t x))))
+ (should (= 1 (condition-case-unless-debug x 0 (t x) (:success (1+ x)))))
+ (should (= 2 (condition-case-unless-debug nil (error "")
+ (:success 1) (t 2))))
+ (should (= 2 (condition-case-unless-debug nil (error "")
+ (t 2) (:success 1))))
+ (should (equal (condition-case-unless-debug x (error "")
+ (:success (1+ x)) (t x))
+ '(error "")))
+ (should (equal (condition-case-unless-debug x (error "")
+ (t x) (:success (1+ x)))
+ '(error "")))))
+
(provide 'subr-tests)
;;; subr-tests.el ends here
diff --git a/test/lisp/term-tests.el b/test/lisp/term-tests.el
index f686e7611e9..f5209d6f580 100644
--- a/test/lisp/term-tests.el
+++ b/test/lisp/term-tests.el
@@ -110,7 +110,7 @@
(buffer-substring (point-min) (point-max))))))
(ert-deftest term-simple-lines ()
- (skip-unless (not (memq system-type '(windows-nt ms-dos))))
+ (skip-when (memq system-type '(windows-nt ms-dos)))
(let ((str "\
first line\r
next line\r\n"))
@@ -118,14 +118,14 @@ next line\r\n"))
(string-replace "\r" "" str)))))
(ert-deftest term-carriage-return ()
- (skip-unless (not (memq system-type '(windows-nt ms-dos))))
+ (skip-when (memq system-type '(windows-nt ms-dos)))
(let ((str "\
first line\r_next line\r\n"))
(should (equal (term-test-screen-from-input 40 12 str)
"_next line\n"))))
(ert-deftest term-line-wrap ()
- (skip-unless (not (memq system-type '(windows-nt ms-dos))))
+ (skip-when (memq system-type '(windows-nt ms-dos)))
(should (string-match-p
;; Don't be strict about trailing whitespace.
"\\`a\\{40\\}\na\\{20\\} *\\'"
@@ -137,7 +137,7 @@ first line\r_next line\r\n"))
(list str str))))))
(ert-deftest term-colors ()
- (skip-unless (not (memq system-type '(windows-nt ms-dos))))
+ (skip-when (memq system-type '(windows-nt ms-dos)))
(pcase-dolist (`(,str ,expected) ansi-test-strings)
(let ((result (term-test-screen-from-input 40 12 str)))
(should (equal result expected))
@@ -145,7 +145,7 @@ first line\r_next line\r\n"))
(text-properties-at 0 expected))))))
(ert-deftest term-colors-bold-is-bright ()
- (skip-unless (not (memq system-type '(windows-nt ms-dos))))
+ (skip-when (memq system-type '(windows-nt ms-dos)))
(let ((ansi-color-bold-is-bright t))
(pcase-dolist (`(,str ,expected ,bright-expected) ansi-test-strings)
(let ((expected (or bright-expected expected))
@@ -155,7 +155,7 @@ first line\r_next line\r\n"))
(text-properties-at 0 expected)))))))
(ert-deftest term-cursor-movement ()
- (skip-unless (not (memq system-type '(windows-nt ms-dos))))
+ (skip-when (memq system-type '(windows-nt ms-dos)))
;; Absolute positioning.
(should (equal "ab\ncd"
(term-test-screen-from-input
@@ -186,7 +186,7 @@ first line\r_next line\r\n"))
"\e[D\e[Da")))))
(ert-deftest term-scrolling-region ()
- (skip-unless (not (memq system-type '(windows-nt ms-dos))))
+ (skip-when (memq system-type '(windows-nt ms-dos)))
(should (equal "\
line3
line4
@@ -338,7 +338,7 @@ line6\r
line7")))))
(ert-deftest term-set-directory ()
- (skip-unless (not (memq system-type '(windows-nt ms-dos))))
+ (skip-when (memq system-type '(windows-nt ms-dos)))
(let ((term-ansi-at-user (user-real-login-name)))
(should (equal (term-test-screen-from-input
40 12 "\eAnSiTc /foo/\n" 'default-directory)
@@ -354,7 +354,7 @@ A real-life example is the default zsh prompt which writes spaces
to the end of line (triggering line-wrapping state), and then
sends a carriage return followed by another space to overwrite
the first character of the line."
- (skip-unless (not (memq system-type '(windows-nt ms-dos))))
+ (skip-when (memq system-type '(windows-nt ms-dos)))
(let* ((width 10)
(strs (list "x" (make-string (1- width) ?_)
"\r_")))
@@ -364,7 +364,7 @@ the first character of the line."
(ert-deftest term-to-margin ()
"Test cursor movement at the scroll margin.
This is a reduced example from GNU nano's initial screen."
- (skip-unless (not (memq system-type '(windows-nt ms-dos))))
+ (skip-when (memq system-type '(windows-nt ms-dos)))
(let* ((width 10)
(x (make-string width ?x))
(y (make-string width ?y)))
diff --git a/test/lisp/textmodes/conf-mode-tests.el b/test/lisp/textmodes/conf-mode-tests.el
index 03fdff1c367..343342be886 100644
--- a/test/lisp/textmodes/conf-mode-tests.el
+++ b/test/lisp/textmodes/conf-mode-tests.el
@@ -93,12 +93,13 @@ x.2.y.1.z.2.zz =")
(should (equal (face-at-point) 'font-lock-variable-name-face))
(search-forward "val")
(should-not (face-at-point)))
- (while (re-search-forward "a-z" nil t)
+ (while (re-search-forward "[xyz]" nil t)
(backward-char)
(should (equal (face-at-point) 'font-lock-variable-name-face))
- (re-search-forward "[0-0]" nil t)
- (backward-char)
- (should (equal (face-at-point) 'font-lock-constant-face)))))
+ (forward-char)
+ (when (re-search-forward "[0-9]" nil t)
+ (backward-char)
+ (should (equal (face-at-point) 'font-lock-constant-face))))))
(ert-deftest conf-test-space-mode ()
;; From `conf-space-mode' docstring.
@@ -157,7 +158,6 @@ image/tiff tiff tif
(should-not (face-at-point))))
(ert-deftest conf-test-toml-mode ()
- ;; From `conf-toml-mode' docstring.
(with-temp-buffer
(insert "[entry]
value = \"some string\"")
@@ -173,6 +173,22 @@ value = \"some string\"")
(search-forward "som")
(should (equal (face-at-point) 'font-lock-string-face))))
+(ert-deftest conf-test-toml-mode/boolean ()
+ ;; https://toml.io/en/v1.0.0#boolean
+ (with-temp-buffer
+ (insert "[entry]
+a = true
+b = True")
+ (goto-char (point-min))
+ (conf-toml-mode)
+ (font-lock-mode)
+ (font-lock-ensure)
+ (search-forward "tru")
+ (should (equal (face-at-point) 'font-lock-keyword-face))
+ ;; Do not fontify upper-case "True".
+ (search-forward "Tru")
+ (should (equal (face-at-point) nil))))
+
(ert-deftest conf-test-desktop-mode ()
;; From `conf-desktop-mode' dostring.
(with-temp-buffer
diff --git a/test/lisp/textmodes/fill-tests.el b/test/lisp/textmodes/fill-tests.el
index 36396b1e999..484f6ed395b 100644
--- a/test/lisp/textmodes/fill-tests.el
+++ b/test/lisp/textmodes/fill-tests.el
@@ -3,7 +3,7 @@
;; Copyright (C) 2017-2024 Free Software Foundation, Inc.
;; Author: Marcin Borkowski <mbork@mbork.pl>
-;; Keywords: text, wp
+;; Keywords: text
;; This file is part of GNU Emacs.
diff --git a/test/lisp/textmodes/page-tests.el b/test/lisp/textmodes/page-tests.el
index f3a2c5fbe00..fdefca36c0b 100644
--- a/test/lisp/textmodes/page-tests.el
+++ b/test/lisp/textmodes/page-tests.el
@@ -106,10 +106,14 @@
(insert "foo\n \nbar\n \nbaz")
(goto-char (point-min))
(should (equal (page--what-page) '(1 1)))
+ (forward-char)
+ (should (equal (page--what-page) '(1 1)))
(forward-page)
+ (should (equal (page--what-page) '(2 1)))
+ (forward-line)
(should (equal (page--what-page) '(2 2)))
(forward-page)
- (should (equal (page--what-page) '(3 4)))))
+ (should (equal (page--what-page) '(3 1)))))
;;; page-tests.el ends here
diff --git a/test/lisp/textmodes/reftex-tests.el b/test/lisp/textmodes/reftex-tests.el
index adbd2b73ed6..7f7c99a40a4 100644
--- a/test/lisp/textmodes/reftex-tests.el
+++ b/test/lisp/textmodes/reftex-tests.el
@@ -294,7 +294,8 @@ And this should be % \\cite{ignored}.
(find-file tex-file)
(setq keys (reftex-all-used-citation-keys))
(should (equal (sort keys #'string<)
- (sort '(;; Standard commands:
+ (sort (list
+ ;; Standard commands:
"cite:2022" "Cite:2022"
"parencite:2022" "Parencite:2022"
"footcite:2022" "footcitetext:2022"
diff --git a/test/lisp/textmodes/tildify-tests.el b/test/lisp/textmodes/tildify-tests.el
index 0da0a688974..b6bdae5edd5 100644
--- a/test/lisp/textmodes/tildify-tests.el
+++ b/test/lisp/textmodes/tildify-tests.el
@@ -4,7 +4,7 @@
;; Author: Michal Nazarewicz <mina86@mina86.com>
;; Version: 4.5
-;; Keywords: text, TeX, SGML, wp
+;; Keywords: text, TeX, SGML
;; This file is part of GNU Emacs.
diff --git a/test/lisp/thingatpt-tests.el b/test/lisp/thingatpt-tests.el
index e24153f254b..e50738f1122 100644
--- a/test/lisp/thingatpt-tests.el
+++ b/test/lisp/thingatpt-tests.el
@@ -72,7 +72,40 @@
("<url:ftp.example.net/abc/>" 1 url "ftp://ftp.example.net/abc/")
;; UUID, only hex is allowed
("01234567-89ab-cdef-ABCD-EF0123456789" 1 uuid "01234567-89ab-cdef-ABCD-EF0123456789")
- ("01234567-89ab-cdef-ABCD-EF012345678G" 1 uuid nil))
+ ("01234567-89ab-cdef-ABCD-EF012345678G" 1 uuid nil)
+ ;; email addresses
+ ("foo@example.com" 1 email "foo@example.com")
+ ("f@example.com" 1 email "f@example.com")
+ ("foo@example.com" 4 email "foo@example.com")
+ ("foo@example.com" 5 email "foo@example.com")
+ ("foo@example.com" 15 email "foo@example.com")
+ ("foo@example.com" 16 email "foo@example.com")
+ ("<foo@example.com>" 1 email "<foo@example.com>")
+ ("<foo@example.com>" 4 email "<foo@example.com>")
+ ("<foo@example.com>" 5 email "<foo@example.com>")
+ ("<foo@example.com>" 16 email "<foo@example.com>")
+ ("<foo@example.com>" 17 email "<foo@example.com>")
+ ;; email addresses containing numbers
+ ("foo1@example.com" 1 email "foo1@example.com")
+ ("1foo@example.com" 1 email "1foo@example.com")
+ ("11@example.com" 1 email "11@example.com")
+ ("1@example.com" 1 email "1@example.com")
+ ;; email addresses user portion containing dots
+ ("foo.bar@example.com" 1 email "foo.bar@example.com")
+ ("foo.bar@example.com" 5 email "foo.bar@example.com")
+ (" fo.ba@example.com" 6 email "fo.ba@example.com")
+ (".foobar@example.com" 1 email nil)
+ (".foobar@example.com" 2 email "foobar@example.com")
+ ;; email addresses domain portion containing dots and dashes
+ ("foobar@.example.com" 1 email nil)
+ ("foobar@-example.com" 1 email "foobar@-example.com")
+ ;; These are illegal, but thingatpt doesn't yet handle them
+ ;; ("foo..bar@example.com" 1 email nil)
+ ;; ("foobar@.example.com" 1 email nil)
+ ;; ("foobar@example..com" 1 email nil)
+ ;; ("foobar.@example.com" 1 email nil)
+
+ )
"List of `thing-at-point' tests.
Each list element should have the form
@@ -149,6 +182,13 @@ position to retrieve THING.")
(should (thing-at-point-looking-at "2abcd"))
(should (equal (match-data) m2)))))
+(ert-deftest thing-at-point-looking-at-overlapping-matches ()
+ (with-temp-buffer
+ (insert "foo.bar.baz")
+ (goto-char (point-max))
+ (should (thing-at-point-looking-at "[a-z]+\\.[a-z]+"))
+ (should (string= "bar.baz" (match-string 0)))))
+
(ert-deftest test-symbol-thing-1 ()
(with-temp-buffer
(insert "foo bar zot")
diff --git a/test/lisp/thread-tests.el b/test/lisp/thread-tests.el
index 0ac87ec5a77..c0f8396e6ec 100644
--- a/test/lisp/thread-tests.el
+++ b/test/lisp/thread-tests.el
@@ -88,7 +88,7 @@
(ert-deftest thread-tests-list-threads-error-when-not-configured ()
"Signal an error running `list-threads' if threads are not configured."
- (skip-unless (not (featurep 'threads)))
+ (skip-when (featurep 'threads))
(should-error (list-threads)))
(provide 'thread-tests)
diff --git a/test/lisp/time-stamp-tests.el b/test/lisp/time-stamp-tests.el
index 5a4f02e2251..a4c30d64225 100644
--- a/test/lisp/time-stamp-tests.el
+++ b/test/lisp/time-stamp-tests.el
@@ -89,12 +89,12 @@
(iter-defun time-stamp-test-pattern-sequential ()
"Iterate through each possibility for a part of `time-stamp-pattern'."
(let ((pattern-value-parts
- '(("4/" "10/" "-9/" "0/" "") ;0: line limit
- ("stamp<" "") ;1: start
- ("%-d" "%_H" "%^a" "%#Z" "%:A" "%09z" "%%" "") ;2: format part 1
- (" " "x" ":" "\n" "") ;3: format part 2
- ("%-d" "%_H" "%^a" "%#Z" "%:A" "%09z" "%%") ;4: format part 3
- (">end" "")))) ;5: end
+ '(("4/" "10/" "-9/" "0/" "") ;0: line limit
+ ("stamp:" "") ;1: start
+ ("%-d" "%_H" "%^a" "%#Z" "%:A" "%019z" "%%" "") ;2: format part 1
+ (" " "x" ":" "\n" "") ;3: format part 2
+ ("%-d" "%_H" "%^a" "%#Z" "%:A" "%019z" "%%") ;4: format part 3
+ ("end" "")))) ;5: end
(dotimes (cur (length pattern-value-parts))
(dotimes (cur-index (length (nth cur pattern-value-parts)))
(cl-flet ((extract-part
@@ -118,15 +118,21 @@
(iter-defun time-stamp-test-pattern-multiply ()
"Iterate through every combination of parts of `time-stamp-pattern'."
(let ((line-limit-values '("" "4/"))
- (start-values '("" "/stamp/"))
- (format-values '("%%" "%m"))
+ (start-values '("" "/stamp1/"))
+ (format-values '("" "%%" "%m"))
(end-values '("" ">end")))
;; yield all combinations of the above
(dolist (line-limit line-limit-values)
(dolist (start start-values)
(dolist (format format-values)
(dolist (end end-values)
- (iter-yield (list line-limit start format end))))))))
+ ;; If the format is not supplied, the end cannot be either,
+ ;; so not all generated combinations are valid.
+ ;; (This is why the format can be supplied as "%%" to
+ ;; preserve the default format.)
+ (if (or (not (equal format ""))
+ (equal end ""))
+ (iter-yield (list line-limit start format end)))))))))
(iter-defun time-stamp-test-pattern-all ()
(iter-yield-from (time-stamp-test-pattern-sequential))
@@ -156,7 +162,8 @@
(if (equal start1 "")
(should (equal ts-start time-stamp-start))
(should (equal ts-start start1)))
- (if (equal whole-format "%%")
+ (if (or (equal whole-format "")
+ (equal whole-format "%%"))
(should (equal ts-format time-stamp-format))
(should (equal ts-format whole-format)))
(if (equal end1 "")
@@ -165,7 +172,8 @@
;; return nil to stop time-stamp from calling us again
nil)))
(let ((time-stamp-pattern (concat
- line-limit1 start1 whole-format end1)))
+ line-limit1 start1 whole-format end1))
+ (case-fold-search nil))
(with-temp-buffer
;; prep the buffer with more than the
;; largest line-limit1 number of lines
@@ -758,12 +766,14 @@ and is called by some low-level `time-stamp' \"%z\" unit tests."
(defun fz-make+zone (h &optional m s)
"Creates a non-negative offset."
+ (declare (pure t))
(let ((m (or m 0))
(s (or s 0)))
(+ (* 3600 h) (* 60 m) s)))
(defun fz-make-zone (h &optional m s)
"Creates a negative offset. The arguments are all non-negative."
+ (declare (pure t))
(- (fz-make+zone h m s)))
(defmacro formatz-should-equal (zone expect)
diff --git a/test/lisp/uniquify-tests.el b/test/lisp/uniquify-tests.el
new file mode 100644
index 00000000000..4124ce056d3
--- /dev/null
+++ b/test/lisp/uniquify-tests.el
@@ -0,0 +1,150 @@
+;;; uniquify-tests.el --- Tests for uniquify -*- lexical-binding: t; -*-
+
+;; Copyright (C) 2023-2024 Free Software Foundation, Inc.
+
+;; Author: Spencer Baugh <sbaugh@janestreet.com>
+
+;; This program is free software; you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+
+;; This program is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with this program. If not, see <https://www.gnu.org/licenses/>.
+
+;;; Commentary:
+
+;;; Code:
+
+(require 'ert)
+(require 'ert-x)
+
+(ert-deftest uniquify-basic ()
+ (let (bufs old-names)
+ (cl-flet ((names-are (current-names &optional nosave)
+ (should (equal (mapcar #'buffer-name bufs) current-names))
+ (unless nosave (push current-names old-names))))
+ (should (eq (get-buffer "z") nil))
+ (push (find-file-noselect "a/b/z") bufs)
+ (names-are '("z"))
+ (push (find-file-noselect "a/b/c/z") bufs)
+ (names-are '("z<c>" "z<b>"))
+ (push (find-file-noselect "a/b/d/z") bufs)
+ (names-are '("z<d>" "z<c>" "z<b>"))
+ (push (find-file-noselect "e/b/z") bufs)
+ (names-are '("z<e/b>" "z<d>" "z<c>" "z<a/b>"))
+ ;; buffers without a buffer-file-name don't get uniquified by uniquify
+ (push (generate-new-buffer "z") bufs)
+ (names-are '("z" "z<e/b>" "z<d>" "z<c>" "z<a/b>"))
+ ;; but they do get uniquified by the C code which uses <n>
+ (push (generate-new-buffer "z") bufs)
+ (names-are '("z<2>" "z" "z<e/b>" "z<d>" "z<c>" "z<a/b>"))
+ (save-excursion
+ ;; uniquify will happily work with file-visiting buffers whose names don't match buffer-file-name
+ (find-file "f/y")
+ (push (current-buffer) bufs)
+ (rename-buffer "z" t)
+ (names-are '("z<f>" "z<2>" "z" "z<e/b>" "z<d>" "z<c>" "z<a/b>") 'nosave)
+ ;; somewhat confusing behavior results if a buffer is renamed to match an already-uniquified buffer
+ (rename-buffer "z<a/b>" t)
+ (names-are '("z<a/b><f>" "z<2>" "z" "z<e/b>" "z<d>" "z<c>" "z<a/b>") 'nosave))
+ (while bufs
+ (kill-buffer (pop bufs))
+ (names-are (pop old-names) 'nosave)))))
+
+(ert-deftest uniquify-dirs ()
+ "Check strip-common-suffix and trailing-separator-p work together; bug#47132"
+ (ert-with-temp-directory root
+ (let ((a-path (file-name-concat root "a/x/y/dir"))
+ (b-path (file-name-concat root "b/x/y/dir")))
+ (make-directory a-path 'parents)
+ (make-directory b-path 'parents)
+ (let ((uniquify-buffer-name-style 'forward)
+ (uniquify-strip-common-suffix t)
+ (uniquify-trailing-separator-p nil))
+ (let ((bufs (list (find-file-noselect a-path)
+ (find-file-noselect b-path))))
+ (should (equal (mapcar #'buffer-name bufs)
+ '("a/dir" "b/dir")))
+ (mapc #'kill-buffer bufs)))
+ (let ((uniquify-buffer-name-style 'forward)
+ (uniquify-strip-common-suffix nil)
+ (uniquify-trailing-separator-p t))
+ (let ((bufs (list (find-file-noselect a-path)
+ (find-file-noselect b-path))))
+ (should (equal (mapcar #'buffer-name bufs)
+ '("a/x/y/dir/" "b/x/y/dir/")))
+ (mapc #'kill-buffer bufs)))
+ (let ((uniquify-buffer-name-style 'forward)
+ (uniquify-strip-common-suffix t)
+ (uniquify-trailing-separator-p t))
+ (let ((bufs (list (find-file-noselect a-path)
+ (find-file-noselect b-path))))
+ (should (equal (mapcar #'buffer-name bufs)
+ '("a/dir/" "b/dir/")))
+ (mapc #'kill-buffer bufs))))))
+
+(ert-deftest uniquify-rename-to-dir ()
+ "Giving a buffer a name which matches a directory doesn't rename the buffer"
+ (let ((uniquify-buffer-name-style 'forward)
+ (uniquify-trailing-separator-p t))
+ (save-excursion
+ (find-file "../README")
+ (rename-buffer "lisp" t)
+ (should (equal (buffer-name) "lisp"))
+ (kill-buffer))))
+
+(ert-deftest uniquify-separator-style-reverse ()
+ (let ((uniquify-buffer-name-style 'reverse)
+ (uniquify-trailing-separator-p t))
+ (save-excursion
+ (should (file-directory-p "../lib-src"))
+ (find-file "../lib-src")
+ (should (equal (buffer-name) "\\lib-src"))
+ (kill-buffer))))
+
+(ert-deftest uniquify-separator-ignored ()
+ "If uniquify-buffer-name-style isn't forward or reverse,
+uniquify-trailing-separator-p is ignored"
+ (let ((uniquify-buffer-name-style 'post-forward-angle-brackets)
+ (uniquify-trailing-separator-p t))
+ (save-excursion
+ (should (file-directory-p "../lib-src"))
+ (find-file "../lib-src")
+ (should (equal (buffer-name) "lib-src"))
+ (kill-buffer))))
+
+(ert-deftest uniquify-space-prefix ()
+ "If a buffer starts with a space, | is added at the start"
+ (save-excursion
+ (find-file " foo")
+ (should (equal (buffer-name) "| foo"))
+ (kill-buffer)))
+
+(require 'project)
+(ert-deftest uniquify-project-transform ()
+ "`project-uniquify-dirname-transform' works"
+ (let ((uniquify-dirname-transform #'project-uniquify-dirname-transform)
+ (project-vc-name "foo1/bar")
+ bufs)
+ (save-excursion
+ (let ((default-directory (expand-file-name "test/" source-directory)))
+ (should (file-exists-p "../README"))
+ (push (find-file-noselect "../README") bufs)
+ (push (find-file-noselect "other/README") bufs)
+ (should (equal (mapcar #'buffer-name bufs)
+ '("README<other>" "README<bar>")))
+ (push (find-file-noselect "foo2/bar/README") bufs)
+ (should (equal (mapcar #'buffer-name bufs)
+ '("README<foo2/bar>" "README<other>"
+ "README<foo1/bar>")))
+ (while bufs
+ (kill-buffer (pop bufs)))))))
+
+(provide 'uniquify-tests)
+;;; uniquify-tests.el ends here
diff --git a/test/lisp/url/url-domsuf-tests.el b/test/lisp/url/url-domsuf-tests.el
index b52e544bd9c..cae25d8e04e 100644
--- a/test/lisp/url/url-domsuf-tests.el
+++ b/test/lisp/url/url-domsuf-tests.el
@@ -24,6 +24,10 @@
(require 'url-domsuf)
(require 'ert)
+(ert-deftest url-domsuf--public-suffix-file ()
+ ;; We should always have a file, since it ships with Emacs.
+ (should (file-readable-p (url-domsuf--public-suffix-file))))
+
(defun url-domsuf-tests--run ()
(should-not (url-domsuf-cookie-allowed-p "com"))
(should (url-domsuf-cookie-allowed-p "foo.bar.bd"))
diff --git a/test/lisp/url/url-expand-tests.el b/test/lisp/url/url-expand-tests.el
index 3c4e7cfe421..127c18b73b6 100644
--- a/test/lisp/url/url-expand-tests.el
+++ b/test/lisp/url/url-expand-tests.el
@@ -3,7 +3,6 @@
;; Copyright (C) 2012-2024 Free Software Foundation, Inc.
;; Author: Alain Schneble <a.s@realize.ch>
-;; Version: 1.0
;; This file is part of GNU Emacs.
diff --git a/test/lisp/url/url-future-tests.el b/test/lisp/url/url-future-tests.el
index 1dd6647c332..af56fb59ee0 100644
--- a/test/lisp/url/url-future-tests.el
+++ b/test/lisp/url/url-future-tests.el
@@ -52,7 +52,7 @@
(should (equal (url-future-cancel tocancel) tocancel))
(should-error (url-future-call tocancel))
(should (null url-future-tests--saver))
- (should (url-future-cancelled-p tocancel))))
+ (should (url-future-canceled-p tocancel))))
(provide 'url-future-tests)
diff --git a/test/lisp/url/url-parse-tests.el b/test/lisp/url/url-parse-tests.el
index 47c53e08c63..6882ed26932 100644
--- a/test/lisp/url/url-parse-tests.el
+++ b/test/lisp/url/url-parse-tests.el
@@ -3,7 +3,6 @@
;; Copyright (C) 2012-2024 Free Software Foundation, Inc.
;; Author: Alain Schneble <a.s@realize.ch>
-;; Version: 1.0
;; This file is part of GNU Emacs.
diff --git a/test/lisp/use-package/use-package-tests.el b/test/lisp/use-package/use-package-tests.el
index c82256958c6..d1e68c2a790 100644
--- a/test/lisp/use-package/use-package-tests.el
+++ b/test/lisp/use-package/use-package-tests.el
@@ -1951,6 +1951,71 @@
(should (eq (nth 1 binding) 'ignore))
(should (eq (nth 2 binding) nil))))
+(ert-deftest use-package-test/:vc-1 ()
+ (match-expansion
+ (use-package foo :vc (:url "bar"))
+ '(progn (use-package-vc-install '(foo (:url "bar") :last-release) nil)
+ (require 'foo nil nil))))
+
+(ert-deftest use-package-test/:vc-2 ()
+ (match-expansion
+ (use-package foo
+ :vc (baz . (:url "baz" :vc-backend "Git"
+ :main-file qux.el :rev "rev-string")))
+ '(progn (use-package-vc-install '(baz
+ (:url "baz" :vc-backend Git :main-file "qux.el")
+ "rev-string")
+ nil)
+ (require 'foo nil nil))))
+
+(ert-deftest use-package-test/:vc-3 ()
+ (match-expansion
+ (use-package foo :vc (bar . "baz"))
+ '(progn (use-package-vc-install '(bar "baz") nil)
+ (require 'foo nil nil))))
+
+(ert-deftest use-package-test/:vc-4 ()
+ (match-expansion
+ (use-package foo :vc (bar . (:url "baz" :rev :newest)))
+ '(progn (use-package-vc-install '(bar (:url "baz") nil) nil)
+ (require 'foo nil nil))))
+
+(ert-deftest use-package-test/:vc-5 ()
+ (let ((load-path? '(pred (apply-partially
+ #'string=
+ (expand-file-name "bar" user-emacs-directory)))))
+ (match-expansion
+ (use-package foo :vc other-name :load-path "bar")
+ `(progn (eval-and-compile
+ (add-to-list 'load-path ,load-path?))
+ (use-package-vc-install '(other-name) ,load-path?)
+ (require 'foo nil nil)))))
+
+(ert-deftest use-package-test-handler/:vc-6 ()
+ (let ((byte-compile-current-file "use-package-core.el")
+ tried-to-install)
+ (cl-letf (((symbol-function #'use-package-vc-install)
+ (lambda (arg &optional local-path)
+ (setq tried-to-install arg))))
+ (should (equal
+ (use-package-handler/:vc 'foo nil 'some-pkg '(:init (foo)) nil)
+ '(foo)))
+ (should (eq tried-to-install 'some-pkg)))))
+
+(ert-deftest use-package-test-normalize/:vc ()
+ (should (equal '(foo "version-string")
+ (use-package-normalize/:vc 'foo :vc '("version-string"))))
+ (should (equal '(bar "version-string")
+ (use-package-normalize/:vc 'foo :vc '((bar . "version-string")))))
+ (should (equal '(foo (:url "bar") "baz")
+ (use-package-normalize/:vc 'foo :vc '((:url "bar" :rev "baz")))))
+ (should (equal '(foo)
+ (use-package-normalize/:vc 'foo :vc '(t))))
+ (should (equal '(foo)
+ (use-package-normalize/:vc 'foo :vc nil)))
+ (should (equal '(bar)
+ (use-package-normalize/:vc 'foo :vc '(bar)))))
+
;; Local Variables:
;; no-byte-compile: t
;; no-update-autoloads: t
diff --git a/test/lisp/vc/log-edit-tests.el b/test/lisp/vc/log-edit-tests.el
index 1a2af716f34..8373156587d 100644
--- a/test/lisp/vc/log-edit-tests.el
+++ b/test/lisp/vc/log-edit-tests.el
@@ -134,4 +134,214 @@ lines."))))
* a-very-long-directory-name/another-long-directory-name/and-a-long-file-name.ext
\(a-really-long-function-name):"))))
+(ert-deftest log-edit-fill-entry-confinement ()
+ (let (string string1 string2 string3 string4)
+ (setq string
+ ;; This entry is precisely 65 columns in length;
+ ;; log-edit-fill-column should leave it unmodified.
+ "* file2.txt (fun4, fun5, fun6, fun7, fun8, fun9, fun10, fun1134):"
+ string1
+ ;; This entry is 66 columns in length, and must be filled.
+ "* file2.txt (fun4, fun5, fun6, fun7, fun8, fun9, fun10, fun11345):"
+ string2
+ ;; The first line of this entry totals 65 columns in length,
+ ;; and should be preserved intact.
+ "* file2.txt (fun4, fun5, fun6, fun7, fun8, fun9, fun10, fun11345)
+(fun11356):"
+ string3
+ ;; The first defun in this entry is a file name that brings
+ ;; the total to 40 columns in length and should be preserved
+ ;; intact.
+ "* file2.txt (abcdefghijklmnopqrstuvwxyz)
+(ABC):"
+ string4
+ ;; The first defun brings that total to 41, and should be
+ ;; placed on the next line.
+ "* file2.txt (abcdefghijklmnopqrstuvwxyz):")
+ (with-temp-buffer
+ (insert string)
+ (let ((fill-column 64)) (log-edit-fill-entry))
+ (should (equal (buffer-string) string))
+ (erase-buffer)
+ (insert string1)
+ (let ((fill-column 64)) (log-edit-fill-entry))
+ (should (equal (buffer-string)
+ "* file2.txt (fun4, fun5, fun6, fun7, fun8, fun9, fun10)
+(fun11345):"))
+ (erase-buffer)
+ (insert string2)
+ (let ((fill-column 64)) (log-edit-fill-entry))
+ (should (equal (buffer-string) string2))
+ (erase-buffer)
+ (insert string3)
+ (let ((fill-column 39)) (log-edit-fill-entry))
+ (should (equal (buffer-string) string3))
+ (erase-buffer)
+ (insert string4)
+ (let ((fill-column 39)) (log-edit-fill-entry))
+ (should (equal (buffer-string)
+ ;; There is whitespace after "file2.txt" which
+ ;; should not be erased!
+ "* file2.txt
+(abcdefghijklmnopqrstuvwxyz):")))))
+
+(ert-deftest log-edit-fill-entry-space-substitution ()
+ ;; This test verifies that filling the paragraph surrounding the
+ ;; last line of defuns does not break between defun lists with
+ ;; spaces in identifiers.
+ (let (string wanted)
+ (setq string "
+* src/sfnt.c (xmalloc, xrealloc): Improve behavior upon allocation
+failures during test.
+(sfnt_table_names): Add prep.
+(sfnt_transform_coordinates): Allow applying offsets during
+coordinate transform.
+(sfnt_decompose_compound_glyph): Defer offset computation until
+any component compound glyph is loaded, then apply it during the
+transform process.
+(sfnt_multiply_divide): Make available everywhere. Implement on
+64 bit systems.
+(sfnt_multiply_divide_signed): New function.
+(sfnt_mul_fixed): Fix division overflow.
+(sfnt_curve_to_and_build_1, sfnt_build_glyph_outline): Remove
+outdated comment.
+(sfnt_build_outline_edges): Fix coding style.
+(sfnt_lookup_glyph_metrics): Allow looking up metrics without
+scaling.
+(struct sfnt_cvt_table): Fix type of cvt values.
+(struct sfnt_prep_table): New structure.
+(sfnt_read_cvt_table): Read cvt values in terms of fwords, not
+longs (as Apple's doc seems to say).
+(sfnt_read_fpgm_table): Fix memory allocation for font program
+table.
+(sfnt_read_prep_table): New function.
+(struct sfnt_interpreter_zone): New structure.
+(struct sfnt_interpreter_graphics_state): New fields `project',
+`move', `vector_dot_product'. Rename to `sfnt_graphics_state'.
+(struct sfnt_interpreter, sfnt_mul_f26dot6): Stop doing rounding
+division.
+(sfnt_init_graphics_state, sfnt_make_interpreter, MOVE, SSW, RAW)
+(SDS, ADD, SUB, ABS, NEG, WCVTF, _MIN, S45ROUND, SVTCAx)
+(sfnt_set_srounding_state, sfnt_skip_code)
+(sfnt_interpret_unimplemented, sfnt_interpret_fdef)
+(sfnt_interpret_idef, sfnt_interpret_if, sfnt_interpret_else)
+(sfnt_round_none, sfnt_round_to_grid, sfnt_round_to_double_grid)
+"
+ wanted "
+* src/sfnt.c
+(xmalloc, xrealloc):
+Improve behavior
+upon allocation
+failures during
+test.
+(sfnt_table_names):
+Add prep.
+(sfnt_transform_coordinates):
+Allow applying
+offsets during
+coordinate
+transform.
+(sfnt_decompose_compound_glyph):
+Defer offset
+computation until
+any component
+compound glyph is
+loaded, then apply
+it during the
+transform process.
+(sfnt_multiply_divide):
+Make available
+everywhere.
+Implement on 64 bit
+systems.
+(sfnt_multiply_divide_signed):
+New function.
+(sfnt_mul_fixed):
+Fix division
+overflow.
+(sfnt_curve_to_and_build_1)
+(sfnt_build_glyph_outline):
+Remove outdated
+comment.
+(sfnt_build_outline_edges):
+Fix coding style.
+(sfnt_lookup_glyph_metrics):
+Allow looking up
+metrics without
+scaling.
+(struct sfnt_cvt_table):
+Fix type of cvt
+values.
+(struct sfnt_prep_table):
+New structure.
+(sfnt_read_cvt_table):
+Read cvt values in
+terms of fwords, not
+longs (as Apple's
+doc seems to say).
+(sfnt_read_fpgm_table):
+Fix memory
+allocation for font
+program table.
+(sfnt_read_prep_table):
+New function.
+(struct sfnt_interpreter_zone):
+New structure.
+(struct sfnt_interpreter_graphics_state):
+New fields
+`project', `move',
+`vector_dot_product'.
+Rename to
+`sfnt_graphics_state'.
+(struct sfnt_interpreter)
+(sfnt_mul_f26dot6):
+Stop doing rounding
+division.
+(sfnt_init_graphics_state)
+(sfnt_make_interpreter)
+(MOVE, SSW, RAW, SDS)
+(ADD, SUB, ABS, NEG)
+(WCVTF, _MIN)
+(S45ROUND, SVTCAx)
+(sfnt_set_srounding_state)
+(sfnt_skip_code)
+(sfnt_interpret_unimplemented)
+(sfnt_interpret_fdef)
+(sfnt_interpret_idef)
+(sfnt_interpret_if)
+(sfnt_interpret_else)
+(sfnt_round_none)
+(sfnt_round_to_grid)
+(sfnt_round_to_double_grid):
+")
+ (with-temp-buffer
+ (insert string)
+ (let ((fill-column 20)) (log-edit-fill-entry))
+ (should (equal (buffer-string) wanted)))))
+
+(ert-deftest log-edit-fill-entry-initial-wrapping ()
+ ;; This test verifies that a newline is inserted before a defun
+ ;; itself longer than the fill column when such a defun is being
+ ;; inserted after a file name, and not otherwise.
+ (let (string wanted)
+ (setq string "
+* src/sfnt.c (long_entry_1): This entry should be placed on a
+new line.
+(but_this_entry_should_not): With the prose displaced to the
+next line instead."
+ wanted "
+* src/sfnt.c
+(long_entry_1): This
+entry should be
+placed on a new
+line.
+(but_this_entry_should_not):
+With the prose
+displaced to the
+next line instead.")
+ (with-temp-buffer
+ (insert string)
+ (let ((fill-column 20)) (log-edit-fill-entry))
+ (should (equal (buffer-string) wanted)))))
+
;;; log-edit-tests.el ends here
diff --git a/test/lisp/vc/vc-cvs-tests.el b/test/lisp/vc/vc-cvs-tests.el
new file mode 100644
index 00000000000..f6fa7a81a1a
--- /dev/null
+++ b/test/lisp/vc/vc-cvs-tests.el
@@ -0,0 +1,107 @@
+;;; vc-cvs-tests.el --- tests for vc/vc-cvs.el -*- lexical-binding:t -*-
+
+;; Copyright (C) 2023-2024 Free Software Foundation, Inc.
+
+;; Author: Olivier Certner <olce.emacs@certner.fr>
+;; 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 <https://www.gnu.org/licenses/>.
+
+;;; Commentary:
+
+;;; Code:
+
+(require 'vc-cvs)
+
+(ert-deftest vc-cvs-test-parse-root--local-no-method ()
+ (vc-cvs-test--check-parse-root
+ "/home/joe/repo"
+ '("local" nil nil "/home/joe/repo")))
+
+(ert-deftest vc-cvs-test-parse-root--local-windows-drive-letter ()
+ (vc-cvs-test--check-parse-root
+ ":local:c:/users/joe/repo"
+ '("local" nil nil "c:/users/joe/repo")))
+
+(ert-deftest vc-cvs-test-parse-root--ext-no-method-host-no-port-colon ()
+ (vc-cvs-test--check-parse-root
+ "host/home/serv/repo"
+ '("ext" nil "host" "/home/serv/repo")))
+
+(ert-deftest vc-cvs-test-parse-root--pserver-host-no-port-colon ()
+ (vc-cvs-test--check-parse-root
+ ":pserver:host/home/serv/repo"
+ '("pserver" nil "host" "/home/serv/repo")))
+
+(ert-deftest vc-cvs-test-parse-root--pserver-host-port-colon ()
+ (vc-cvs-test--check-parse-root
+ ":pserver:host:/home/serv/repo"
+ '("pserver" nil "host" "/home/serv/repo")))
+
+(ert-deftest vc-cvs-test-parse-root--ext-no-method-user-host-no-port-colon ()
+ (vc-cvs-test--check-parse-root
+ "usr@host/home/serv/repo"
+ '("ext" "usr" "host" "/home/serv/repo")))
+
+(ert-deftest vc-cvs-test-parse-root--ext-no-method-user-host-port-colon ()
+ (vc-cvs-test--check-parse-root
+ "usr@host:/home/serv/repo"
+ '("ext" "usr" "host" "/home/serv/repo")))
+
+(ert-deftest vc-cvs-test-parse-root--pserver-user-password-host-no-port-colon ()
+ (vc-cvs-test--check-parse-root
+ ":pserver:usr:passwd@host/home/serv/repo"
+ '("pserver" "usr" "host" "/home/serv/repo")))
+
+(ert-deftest vc-cvs-test-parse-root--pserver-user-password-host-port-colon ()
+ (vc-cvs-test--check-parse-root
+ ":pserver:usr:passwd@host:/home/serv/repo"
+ '("pserver" "usr" "host" "/home/serv/repo")))
+
+(ert-deftest vc-cvs-test-parse-root--pserver-user-password-host-port ()
+ (vc-cvs-test--check-parse-root
+ ":pserver:usr:passwd@host:28/home/serv/repo"
+ '("pserver" "usr" "host" "/home/serv/repo")))
+
+;; Next 3 tests are just to err on the side of caution. It doesn't
+;; seem that CVS 1.12 can ever produce such lines.
+
+(ert-deftest
+ vc-cvs-test-parse-root--ext-no-method-user-password-host-no-port-colon
+ ()
+ (vc-cvs-test--check-parse-root
+ "usr:passwd@host/home/serv/repo"
+ '("ext" "usr" "host" "/home/serv/repo")))
+
+(ert-deftest
+ vc-cvs-test-parse-root--ext-no-method-user-password-host-port-colon
+ ()
+ (vc-cvs-test--check-parse-root
+ "usr:passwd@host:/home/serv/repo"
+ '("ext" "usr" "host" "/home/serv/repo")))
+
+(ert-deftest
+ vc-cvs-test-parse-root--ext-no-method-user-password-host-port
+ ()
+ (vc-cvs-test--check-parse-root
+ "usr:passwd@host:28/home/serv/repo"
+ '("ext" "usr" "host" "/home/serv/repo")))
+
+
+(defun vc-cvs-test--check-parse-root (input expected-output)
+ (should (equal (vc-cvs-parse-root input) expected-output)))
+
+;;; vc-cvs-tests.el ends here
diff --git a/test/lisp/vc/vc-git-tests.el b/test/lisp/vc/vc-git-tests.el
index 3e6536add39..f15a0f52e8c 100644
--- a/test/lisp/vc/vc-git-tests.el
+++ b/test/lisp/vc/vc-git-tests.el
@@ -24,6 +24,8 @@
;;; Code:
+(require 'ert-x)
+(require 'vc)
(require 'vc-git)
(ert-deftest vc-git-test-program-version-general ()
@@ -64,4 +66,66 @@
(actual-output (vc-git--program-version)))
(should (equal actual-output expected-output))))
+(ert-deftest vc-git-test-annotate-time ()
+ "Test `vc-git-annotate-time'."
+ (require 'vc-annotate)
+ (with-temp-buffer
+ (insert "\
+00000000 (Foo Bar 2023-06-14 1) a
+00000001 (Foo Bar 2023-06-14 00:00:00 -0130 2) b
+00000002 (Foo Bar 2023-06-14 00:00:00 +0145 3) c
+00000003 (Foo Bar 2023-06-14 00:00:00 4) d
+00000004 (Foo Bar 0-0-0 5) \n")
+ (goto-char (point-min))
+ (should (floatp (vc-git-annotate-time)))
+ (should (> (vc-git-annotate-time)
+ (vc-git-annotate-time)))
+ (should-not (vc-git-annotate-time))
+ (should-not (vc-git-annotate-time))))
+
+(defmacro vc-git-test--with-repo (name &rest body)
+ "Initialize a repository in a temporary directory and evaluate BODY.
+
+The current directory will be set to the top of that repository; NAME
+will be bound to that directory's file name. Once BODY exits, the
+directory will be deleted.
+
+Some dummy environment variables will be set for the duration of BODY to
+allow `git commit' to determine identities for authors and committers."
+ (declare (indent 1))
+ `(ert-with-temp-directory ,name
+ (let ((default-directory ,name)
+ (process-environment (append '("EMAIL=john@doe.ee"
+ "GIT_AUTHOR_NAME=A"
+ "GIT_COMMITTER_NAME=C")
+ process-environment)))
+ (vc-create-repo 'Git)
+ ,@body)))
+
+(defun vc-git-test--run (&rest args)
+ "Run git ARGS…, check for non-zero status, and return output."
+ (with-temp-buffer
+ (apply 'vc-git-command t 0 nil args)
+ (buffer-string)))
+
+(ert-deftest vc-git-test-dir-track-local-branch ()
+ "Test that `vc-dir' works when tracking local branches. Bug#68183."
+ (skip-unless (executable-find vc-git-program))
+ (vc-git-test--with-repo repo
+ ;; Create an initial commit to get a branch started.
+ (write-region "hello" nil "README")
+ (vc-git-test--run "add" "README")
+ (vc-git-test--run "commit" "-mFirst")
+ ;; Get current branch name lazily, to remain agnostic of
+ ;; init.defaultbranch.
+ (let ((upstream-branch
+ (string-trim (vc-git-test--run "branch" "--show-current"))))
+ (vc-git-test--run "checkout" "--track" "-b" "hack" upstream-branch)
+ (vc-dir default-directory)
+ (pcase-dolist (`(,header ,value)
+ `(("Branch" "hack")
+ ("Tracking" ,upstream-branch)))
+ (goto-char (point-min))
+ (re-search-forward (format "^%s *: %s$" header value))))))
+
;;; vc-git-tests.el ends here
diff --git a/test/lisp/vc/vc-hg-tests.el b/test/lisp/vc/vc-hg-tests.el
index a3d7d681808..f578c86d401 100644
--- a/test/lisp/vc/vc-hg-tests.el
+++ b/test/lisp/vc/vc-hg-tests.el
@@ -53,6 +53,8 @@
(ert-deftest vc-hg-annotate-time ()
(with-temp-buffer
(save-excursion (insert "philringnalda 218075 2014-11-28 CLOBBER:"))
- (should (floatp (vc-hg-annotate-time)))))
+ (should (equal (vc-hg-annotate-time)
+ (vc-annotate-convert-time
+ (encode-time 0 0 0 28 11 2014))))))
;;; vc-hg-tests.el ends here
diff --git a/test/lisp/vc/vc-tests.el b/test/lisp/vc/vc-tests.el
index 8cb71c33a3c..6be8af40e3a 100644
--- a/test/lisp/vc/vc-tests.el
+++ b/test/lisp/vc/vc-tests.el
@@ -781,7 +781,7 @@ This checks also `vc-backend' and `vc-responsible-backend'."
;; CVS calls vc-delete-file, which insists on prompting
;; "Really want to delete ...?", and `vc-mtn.el' does not implement
;; `delete-file' at all.
- (skip-unless (not (memq ',backend '(CVS Mtn))))
+ (skip-when (memq ',backend '(CVS Mtn)))
(vc-test--rename-file ',backend))
(ert-deftest
@@ -796,7 +796,7 @@ This checks also `vc-backend' and `vc-responsible-backend'."
(format "vc-test-%s01-register" backend-string))))))
;; `vc-mtn.el' gives me:
;; "Failed (status 1): mtn commit -m Testing vc-version-diff\n\n foo"
- (skip-unless (not (memq ',backend '(Mtn))))
+ (skip-when (memq ',backend '(Mtn)))
(vc-test--version-diff ',backend))
))))
diff --git a/test/lisp/whitespace-tests.el b/test/lisp/whitespace-tests.el
index 83685136ffe..73c7e742ec5 100644
--- a/test/lisp/whitespace-tests.el
+++ b/test/lisp/whitespace-tests.el
@@ -57,6 +57,24 @@ buffer's content."
(whitespace-cleanup)
(buffer-string)))
+(ert-deftest whitespace-tests--global ()
+ (let ((backup global-whitespace-mode)
+ (noninteractive nil)
+ (whitespace-enable-predicate (lambda () t)))
+ (unwind-protect
+ (progn
+ (global-whitespace-mode 1)
+ (ert-with-test-buffer-selected ()
+ (normal-mode)
+ (should whitespace-mode)
+ (global-whitespace-mode -1)
+ (should (null whitespace-mode))
+ (whitespace-mode 1)
+ (should whitespace-mode)
+ (global-whitespace-mode 1)
+ (should whitespace-mode)))
+ (global-whitespace-mode (if backup 1 -1)))))
+
(ert-deftest whitespace-cleanup-eob ()
(let ((whitespace-style '(empty)))
(should (equal (whitespace-tests--cleanup-string "a\n")
diff --git a/test/lisp/wid-edit-tests.el b/test/lisp/wid-edit-tests.el
index 172edd03f9f..4b049478b29 100644
--- a/test/lisp/wid-edit-tests.el
+++ b/test/lisp/wid-edit-tests.el
@@ -349,4 +349,46 @@ return nil, even with a non-nil bubblep argument."
(should-not (widget-apply widget :match "someundefinedcolorihope"))
(should-not (widget-apply widget :match "#11223"))))
+(ert-deftest widget-test-alist-default-value-1 ()
+ "Test getting the default value for an alist widget with options."
+ (with-temp-buffer
+ (let ((w (widget-create '(alist :key-type string
+ :value-type integer
+ :options (("0" (integer)))))))
+ (should (equal '(("0" . 0)) (widget-default-get w))))))
+
+(ert-deftest widget-test-alist-default-value-2 ()
+ "Test getting the default value for an alist widget without :value."
+ (with-temp-buffer
+ (let ((w (widget-create '(alist :key-type string
+ :value-type integer))))
+ (should-not (widget-default-get w)))))
+
+(ert-deftest widget-test-alist-default-value-3 ()
+ "Test getting the default value for an alist widget with nil :value."
+ (with-temp-buffer
+ (let ((w (widget-create '(alist :key-type string
+ :value-type integer
+ :value nil))))
+ (should-not (widget-default-get w)))))
+
+(ert-deftest widget-test-alist-default-value-4 ()
+ "Test getting the default value for an alist widget with non-nil :value."
+ (with-temp-buffer
+ (let ((w (widget-create '(alist :key-type string
+ :value-type integer
+ :value (("1" . 1) ("2" . 2))))))
+ (should (equal '(("1" . 1) ("2" . 2)) (widget-default-get w))))))
+
+(ert-deftest widget-test-restricted-sexp-empty-val ()
+ "Test that we handle an empty restricted-sexp widget just fine."
+ (with-temp-buffer
+ (let ((w (widget-create '(restricted-sexp
+ :value 3
+ :match-alternatives (integerp)))))
+ (widget-setup)
+ (widget-backward 1)
+ (delete-char 1)
+ (should (string= (widget-value w) "")))))
+
;;; wid-edit-tests.el ends here
diff --git a/test/manual/BidiCharacterTest.txt b/test/manual/BidiCharacterTest.txt
index 619d4b4412b..6b3ef016036 100644
--- a/test/manual/BidiCharacterTest.txt
+++ b/test/manual/BidiCharacterTest.txt
@@ -1,6 +1,6 @@
-# BidiCharacterTest-15.0.0.txt
-# Date: 2022-05-03, 18:46:00 GMT [LI]
-# © 2022 Unicode®, Inc.
+# BidiCharacterTest-15.1.0.txt
+# Date: 2023-01-05
+# © 2023 Unicode®, Inc.
# For terms of use, see https://www.unicode.org/terms_of_use.html
#
# Unicode Character Database
diff --git a/test/manual/image-tests.el b/test/manual/image-tests.el
index bfd6bb23ef4..e186586be3b 100644
--- a/test/manual/image-tests.el
+++ b/test/manual/image-tests.el
@@ -31,6 +31,8 @@
;;; Code:
+(require 'ert)
+
(defmacro image-skip-unless (format &rest condition)
`(skip-unless (and (and (display-images-p)
(image-type-available-p ,format))
@@ -41,9 +43,9 @@
source-directory))
(jpeg . ,(expand-file-name "test/data/image/black.jpg"
source-directory))
- (pbm . ,(find-image '((:file "splash.svg" :type svg))))
+ (svg . ,(find-image '((:file "splash.svg" :type svg))))
(png . ,(find-image '((:file "splash.png" :type png))))
- (svg . ,(find-image '((:file "splash.pbm" :type pbm))))
+ (pbm . ,(find-image '((:file "splash.pbm" :type pbm))))
(tiff . ,(expand-file-name
"nextstep/GNUstep/Emacs.base/Resources/emacs.tiff"
source-directory))
@@ -80,6 +82,7 @@
(image-tests-make-load-image-test 'xpm)
(ert-deftest image-tests-load-image/svg-too-big ()
+ (image-skip-unless svg)
(with-temp-buffer
(let* ((max-image-size 0)
(messages-buffer-name (buffer-name (current-buffer)))
@@ -95,6 +98,7 @@
(should-not (string-match-p "error parsing" (buffer-string))))))
(ert-deftest image-tests-load-image/svg-invalid ()
+ (image-skip-unless svg)
(with-temp-buffer
(let ((messages-buffer-name (buffer-name (current-buffer))))
(with-temp-buffer
@@ -240,6 +244,8 @@
(ert-deftest image-tests-image-metadata/gif ()
(image-skip-unless 'gif
+ ;; FIXME: Why is this failing on macOS?
+ (not (eq system-type 'darwin))
(not (bound-and-true-p w32-use-native-image-API)))
(should (memq 'delay
(image-metadata
@@ -268,7 +274,9 @@
(create-image (cdr (assq 'tiff image-tests--images))))))
(ert-deftest image-tests-image-metadata/webp ()
- (image-skip-unless 'webp)
+ (image-skip-unless 'webp
+ ;; FIXME: Why is this failing on macOS?
+ (not (eq system-type 'darwin)))
(should (memq 'delay
(image-metadata
(create-image (cdr (assq 'webp image-tests--images)))))))
diff --git a/test/manual/indent/shell.sh b/test/manual/indent/shell.sh
index bd4a74f7054..42a981d312e 100755
--- a/test/manual/indent/shell.sh
+++ b/test/manual/indent/shell.sh
@@ -140,6 +140,7 @@ foo () {
5) hello ;;
4) hello ;&
4) hello ;;&
+ 4) hello ;|
5) hello ;;
5) hello ;;
esac
@@ -188,3 +189,10 @@ bar () {
fi
}
+
+case $i { # Bug#55764
+ *pattern)
+ (cd .; echo hi);
+ do1 ;;
+ *pattern2) do2 ;;
+}
diff --git a/test/manual/noverlay/itree-tests.c b/test/manual/noverlay/itree-tests.c
index 74b584f19ab..4d380fc1d2c 100644
--- a/test/manual/noverlay/itree-tests.c
+++ b/test/manual/noverlay/itree-tests.c
@@ -26,7 +26,6 @@ along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. */
#include "emacs-compat.h"
#define EMACS_LISP_H /* lisp.h inclusion guard */
-#define ITREE_DEBUG 1
#define ITREE_TESTING
#include "itree.c"
@@ -53,7 +52,7 @@ test_insert1_setup (void)
enum { N = 6 };
const int values[N] = {50, 30, 20, 10, 15, 5};
struct itree_node *nodes[N] = {&N_50, &N_30, &N_20, &N_10, &N_15, &N_05};
- interval_tree_init (&tree);
+ itree_init (&tree);
for (int i = 0; i < N; ++i)
{
nodes[i]->begin = nodes[i]->end = values[i];
@@ -67,7 +66,7 @@ START_TEST (test_insert_1)
* [50]
*/
- interval_tree_insert (&tree, &N_50);
+ itree_insert_node (&tree, &N_50);
ck_assert (! N_50.red);
ck_assert_ptr_eq (&N_50, tree.root);
}
@@ -81,8 +80,8 @@ START_TEST (test_insert_2)
* (30)
*/
- interval_tree_insert (&tree, &N_50);
- interval_tree_insert (&tree, &N_30);
+ itree_insert_node (&tree, &N_50);
+ itree_insert_node (&tree, &N_30);
ck_assert (! N_50.red);
ck_assert (N_30.red);
ck_assert_ptr_eq (&N_50, tree.root);
@@ -102,9 +101,9 @@ START_TEST (test_insert_3)
* (20) (50)
*/
- interval_tree_insert (&tree, &N_50);
- interval_tree_insert (&tree, &N_30);
- interval_tree_insert (&tree, &N_20);
+ itree_insert_node (&tree, &N_50);
+ itree_insert_node (&tree, &N_30);
+ itree_insert_node (&tree, &N_20);
ck_assert (N_50.red);
ck_assert (! N_30.red);
ck_assert (N_20.red);
@@ -128,10 +127,10 @@ START_TEST (test_insert_4)
* (10)
*/
- interval_tree_insert (&tree, &N_50);
- interval_tree_insert (&tree, &N_30);
- interval_tree_insert (&tree, &N_20);
- interval_tree_insert (&tree, &N_10);
+ itree_insert_node (&tree, &N_50);
+ itree_insert_node (&tree, &N_30);
+ itree_insert_node (&tree, &N_20);
+ itree_insert_node (&tree, &N_10);
ck_assert (! N_50.red);
ck_assert (! N_30.red);
ck_assert (! N_20.red);
@@ -159,11 +158,11 @@ START_TEST (test_insert_5)
* (10) (20)
*/
- interval_tree_insert (&tree, &N_50);
- interval_tree_insert (&tree, &N_30);
- interval_tree_insert (&tree, &N_20);
- interval_tree_insert (&tree, &N_10);
- interval_tree_insert (&tree, &N_15);
+ itree_insert_node (&tree, &N_50);
+ itree_insert_node (&tree, &N_30);
+ itree_insert_node (&tree, &N_20);
+ itree_insert_node (&tree, &N_10);
+ itree_insert_node (&tree, &N_15);
ck_assert (! N_50.red);
ck_assert (! N_30.red);
ck_assert (N_20.red);
@@ -197,12 +196,12 @@ START_TEST (test_insert_6)
* (5)
*/
- interval_tree_insert (&tree, &N_50);
- interval_tree_insert (&tree, &N_30);
- interval_tree_insert (&tree, &N_20);
- interval_tree_insert (&tree, &N_10);
- interval_tree_insert (&tree, &N_15);
- interval_tree_insert (&tree, &N_05);
+ itree_insert_node (&tree, &N_50);
+ itree_insert_node (&tree, &N_30);
+ itree_insert_node (&tree, &N_20);
+ itree_insert_node (&tree, &N_10);
+ itree_insert_node (&tree, &N_15);
+ itree_insert_node (&tree, &N_05);
ck_assert (! N_50.red);
ck_assert (! N_30.red);
ck_assert (! N_20.red);
@@ -238,7 +237,7 @@ test_insert2_setup (void)
enum { N = 6 };
const int values[] = {50, 70, 80, 90, 85, 95};
struct itree_node *nodes[N] = {&N_50, &N_70, &N_80, &N_90, &N_85, &N_95};
- interval_tree_init (&tree);
+ itree_init (&tree);
for (int i = 0; i < N; ++i)
{
nodes[i]->begin = nodes[i]->end = values[i];
@@ -252,7 +251,7 @@ START_TEST (test_insert_7)
* [50]
*/
- interval_tree_insert (&tree, &N_50);
+ itree_insert_node (&tree, &N_50);
ck_assert (! N_50.red);
ck_assert_ptr_eq (&N_50, tree.root);
}
@@ -266,8 +265,8 @@ START_TEST (test_insert_8)
* (70)
*/
- interval_tree_insert (&tree, &N_50);
- interval_tree_insert (&tree, &N_70);
+ itree_insert_node (&tree, &N_50);
+ itree_insert_node (&tree, &N_70);
ck_assert (! N_50.red);
ck_assert (N_70.red);
ck_assert_ptr_eq (&N_50, tree.root);
@@ -287,9 +286,9 @@ START_TEST (test_insert_9)
* (50) (80)
*/
- interval_tree_insert (&tree, &N_50);
- interval_tree_insert (&tree, &N_70);
- interval_tree_insert (&tree, &N_80);
+ itree_insert_node (&tree, &N_50);
+ itree_insert_node (&tree, &N_70);
+ itree_insert_node (&tree, &N_80);
ck_assert (N_50.red);
ck_assert (! N_70.red);
ck_assert (N_80.red);
@@ -313,10 +312,10 @@ START_TEST (test_insert_10)
* (90)
*/
- interval_tree_insert (&tree, &N_50);
- interval_tree_insert (&tree, &N_70);
- interval_tree_insert (&tree, &N_80);
- interval_tree_insert (&tree, &N_90);
+ itree_insert_node (&tree, &N_50);
+ itree_insert_node (&tree, &N_70);
+ itree_insert_node (&tree, &N_80);
+ itree_insert_node (&tree, &N_90);
ck_assert (! N_50.red);
ck_assert (! N_70.red);
ck_assert (! N_80.red);
@@ -344,11 +343,11 @@ START_TEST (test_insert_11)
* (80) (90)
*/
- interval_tree_insert (&tree, &N_50);
- interval_tree_insert (&tree, &N_70);
- interval_tree_insert (&tree, &N_80);
- interval_tree_insert (&tree, &N_90);
- interval_tree_insert (&tree, &N_85);
+ itree_insert_node (&tree, &N_50);
+ itree_insert_node (&tree, &N_70);
+ itree_insert_node (&tree, &N_80);
+ itree_insert_node (&tree, &N_90);
+ itree_insert_node (&tree, &N_85);
ck_assert (! N_50.red);
ck_assert (! N_70.red);
ck_assert (N_80.red);
@@ -383,12 +382,12 @@ START_TEST (test_insert_12)
* (95)
*/
- interval_tree_insert (&tree, &N_50);
- interval_tree_insert (&tree, &N_70);
- interval_tree_insert (&tree, &N_80);
- interval_tree_insert (&tree, &N_90);
- interval_tree_insert (&tree, &N_85);
- interval_tree_insert (&tree, &N_95);
+ itree_insert_node (&tree, &N_50);
+ itree_insert_node (&tree, &N_70);
+ itree_insert_node (&tree, &N_80);
+ itree_insert_node (&tree, &N_90);
+ itree_insert_node (&tree, &N_85);
+ itree_insert_node (&tree, &N_95);
ck_assert (! N_50.red);
ck_assert (! N_70.red);
ck_assert (! N_80.red);
@@ -419,7 +418,7 @@ START_TEST (test_insert_13)
enum { N = 4 };
const int values[N] = {10, 20, 30, 40};
struct itree_node *nodes[N] = {&N_10, &N_20, &N_30, &N_40};
- interval_tree_init (&tree);
+ itree_init (&tree);
for (int i = 0; i < N; ++i)
itree_insert (&tree, nodes[i], values[i], values[i]);
@@ -437,13 +436,13 @@ END_TEST
START_TEST (test_insert_14)
{
enum { N = 3 };
- struct itree_node nodes[N];
- interval_tree_init (&tree);
+ struct itree_node nodes[N] = {0};
+ itree_init (&tree);
for (int i = 0; i < N; ++i)
itree_insert (&tree, &nodes[i], 10, 10);
for (int i = 0; i < N; ++i)
- ck_assert (interval_tree_contains (&tree, &nodes[i]));
+ ck_assert (itree_contains (&tree, &nodes[i]));
}
END_TEST
@@ -458,7 +457,7 @@ END_TEST
static void
test_remove1_setup (void)
{
- interval_tree_init (&tree);
+ itree_init (&tree);
tree.root = &B;
A.parent = &B; B.parent = NULL; C.parent = &D; D.parent = &B; E.parent = &D;
A.left = A.right = C.left = C.right = E.left = E.right = NULL;
@@ -480,7 +479,7 @@ START_TEST (test_remove_1)
{
B.red = A.red = C.red = E.red = false;
D.red = true;
- interval_tree_remove_fix (&tree, &A, &B);
+ itree_remove_fix (&tree, &A, &B);
ck_assert (! A.red);
ck_assert (! B.red);
@@ -502,7 +501,7 @@ END_TEST
START_TEST (test_remove_2)
{
B.red = D.red = A.red = C.red = E.red = false;
- interval_tree_remove_fix (&tree, &A, &B);
+ itree_remove_fix (&tree, &A, &B);
ck_assert (! A.red);
ck_assert (! B.red);
@@ -523,7 +522,7 @@ START_TEST (test_remove_3)
{
D.red = A.red = E.red = false;
B.red = C.red = true;
- interval_tree_remove_fix (&tree, &A, &B);
+ itree_remove_fix (&tree, &A, &B);
ck_assert (! A.red);
ck_assert (! B.red);
@@ -546,7 +545,7 @@ START_TEST (test_remove_4)
{
B.red = C.red = E.red = true;
A.red = D.red = false;
- interval_tree_remove_fix (&tree, &A, &B);
+ itree_remove_fix (&tree, &A, &B);
ck_assert (! A.red);
ck_assert (! B.red);
@@ -569,7 +568,7 @@ END_TEST
static void
test_remove2_setup (void)
{
- interval_tree_init (&tree);
+ itree_init (&tree);
tree.root = &B;
A.parent = &B; B.parent = NULL; C.parent = &D; D.parent = &B; E.parent = &D;
A.right = A.left = C.right = C.left = E.right = E.left = NULL;
@@ -589,7 +588,7 @@ START_TEST (test_remove_5)
{
B.red = A.red = C.red = E.red = false;
D.red = true;
- interval_tree_remove_fix (&tree, &A, &B);
+ itree_remove_fix (&tree, &A, &B);
ck_assert (! A.red);
ck_assert (! B.red);
@@ -611,7 +610,7 @@ END_TEST
START_TEST (test_remove_6)
{
B.red = D.red = A.red = C.red = E.red = false;
- interval_tree_remove_fix (&tree, &A, &B);
+ itree_remove_fix (&tree, &A, &B);
ck_assert (! A.red);
ck_assert (! B.red);
@@ -632,7 +631,7 @@ START_TEST (test_remove_7)
{
D.red = A.red = E.red = false;
B.red = C.red = true;
- interval_tree_remove_fix (&tree, &A, &B);
+ itree_remove_fix (&tree, &A, &B);
ck_assert (! A.red);
ck_assert (! B.red);
@@ -655,7 +654,7 @@ START_TEST (test_remove_8)
{
B.red = C.red = E.red = true;
A.red = D.red = false;
- interval_tree_remove_fix (&tree, &A, &B);
+ itree_remove_fix (&tree, &A, &B);
ck_assert (! A.red);
ck_assert (! B.red);
@@ -676,7 +675,7 @@ START_TEST (test_remove_9)
enum { N = 4 };
const int values[N] = {10, 20, 30, 40};
struct itree_node *nodes[N] = {&N_10, &N_20, &N_30, &N_40};
- interval_tree_init (&tree);
+ itree_init (&tree);
for (int i = 0; i < N; ++i)
itree_insert (&tree, nodes[i], values[i], values[i]);
@@ -722,8 +721,8 @@ START_TEST (test_remove_10)
srand (42);
shuffle (index, N);
- interval_tree_init (&tree);
- struct itree_node nodes[N];
+ itree_init (&tree);
+ struct itree_node nodes[N] = {0};
for (int i = 0; i < N; ++i)
{
ptrdiff_t pos = (i + 1) * 10;
@@ -733,10 +732,10 @@ START_TEST (test_remove_10)
shuffle (index, N);
for (int i = 0; i < N; ++i)
{
- ck_assert (interval_tree_contains (&tree, &nodes[index[i]]));
+ ck_assert (itree_contains (&tree, &nodes[index[i]]));
itree_remove (&tree, &nodes[index[i]]);
}
- ck_assert_ptr_null (tree.root);
+ ck_assert (itree_empty_p (&tree));
ck_assert_int_eq (tree.size, 0);
}
END_TEST
@@ -748,12 +747,12 @@ END_TEST
START_TEST (test_generator_1)
{
- struct itree_node node, *n;
- struct itree_iterator *g;
- interval_tree_init (&tree);
+ struct itree_node node = {0}, *n;
+ struct itree_iterator it, *g;
+ itree_init (&tree);
itree_insert (&tree, &node, 10, 20);
- g = itree_iterator_start (&tree, 0, 30, ITREE_ASCENDING, NULL, 0);
+ g = itree_iterator_start (&it, &tree, 0, 30, ITREE_ASCENDING);
n = itree_iterator_next (g);
ck_assert_ptr_eq (n, &node);
ck_assert_int_eq (n->begin, 10);
@@ -761,13 +760,11 @@ START_TEST (test_generator_1)
ck_assert_ptr_null (itree_iterator_next (g));
ck_assert_ptr_null (itree_iterator_next (g));
ck_assert_ptr_null (itree_iterator_next (g));
- itree_iterator_finish (g);
- g = itree_iterator_start (&tree, 30, 50, ITREE_ASCENDING, NULL, 0);
+ g = itree_iterator_start (&it, &tree, 30, 50, ITREE_ASCENDING);
ck_assert_ptr_null (itree_iterator_next (g));
ck_assert_ptr_null (itree_iterator_next (g));
ck_assert_ptr_null (itree_iterator_next (g));
- itree_iterator_finish (g);
}
END_TEST
@@ -777,8 +774,8 @@ test_check_generator (struct itree_tree *tree,
int n, ...)
{
va_list ap;
- struct itree_iterator *g =
- itree_iterator_start (tree, begin, end, ITREE_ASCENDING, NULL, 0);
+ struct itree_iterator it, *g =
+ itree_iterator_start (&it, tree, begin, end, ITREE_ASCENDING);
va_start (ap, n);
for (int i = 0; i < n; ++i)
@@ -790,13 +787,12 @@ test_check_generator (struct itree_tree *tree,
va_end (ap);
ck_assert_ptr_null (itree_iterator_next (g));
ck_assert_ptr_null (itree_iterator_next (g));
- itree_iterator_finish (g);
}
START_TEST (test_generator_2)
{
- interval_tree_init (&tree);
- struct itree_node nodes[3];
+ itree_init (&tree);
+ struct itree_node nodes[3] = {0};
for (int i = 0; i < 3; ++i)
itree_insert (&tree, &nodes[i], 10 * (i + 1), 10 * (i + 2));
@@ -830,7 +826,7 @@ test_create_tree (struct itree_node *nodes, int n, bool doshuffle)
shuffle (index, n);
}
- interval_tree_init (&tree);
+ itree_init (&tree);
for (int i = 0; i < n; ++i)
{
struct itree_node *node = &nodes[index[i]];
@@ -862,8 +858,8 @@ START_TEST (test_generator_5)
{.begin = 30, .end = 50},
{.begin = 40, .end = 60}};
test_create_tree (nodes, N, false);
- struct itree_iterator *g =
- itree_iterator_start (&tree, 0, 100, ITREE_PRE_ORDER, NULL, 0);
+ struct itree_iterator it, *g =
+ itree_iterator_start (&it, &tree, 0, 100, ITREE_PRE_ORDER);
for (int i = 0; i < N; ++i)
{
struct itree_node *n = itree_iterator_next (g);
@@ -876,7 +872,6 @@ START_TEST (test_generator_5)
case 3: ck_assert_int_eq (40, n->begin); break;
}
}
- itree_iterator_finish (g);
}
END_TEST
@@ -888,8 +883,8 @@ START_TEST (test_generator_6)
{.begin = 30, .end = 50},
{.begin = 40, .end = 60}};
test_create_tree (nodes, N, true);
- struct itree_iterator *g =
- itree_iterator_start (&tree, 0, 100, ITREE_ASCENDING, NULL, 0);
+ struct itree_iterator it, *g =
+ itree_iterator_start (&it, &tree, 0, 100, ITREE_ASCENDING);
for (int i = 0; i < N; ++i)
{
struct itree_node *n = itree_iterator_next (g);
@@ -902,7 +897,6 @@ START_TEST (test_generator_6)
case 3: ck_assert_int_eq (40, n->begin); break;
}
}
- itree_iterator_finish (g);
}
END_TEST
@@ -914,8 +908,8 @@ START_TEST (test_generator_7)
{.begin = 30, .end = 50},
{.begin = 40, .end = 60}};
test_create_tree (nodes, N, true);
- struct itree_iterator *g =
- itree_iterator_start (&tree, 0, 100, ITREE_DESCENDING, NULL, 0);
+ struct itree_iterator it, *g =
+ itree_iterator_start (&it, &tree, 0, 100, ITREE_DESCENDING);
for (int i = 0; i < N; ++i)
{
struct itree_node *n = itree_iterator_next (g);
@@ -928,7 +922,6 @@ START_TEST (test_generator_7)
case 3: ck_assert_int_eq (10, n->begin); break;
}
}
- itree_iterator_finish (g);
}
END_TEST
@@ -938,14 +931,13 @@ START_TEST (test_generator_8)
struct itree_node nodes[N] = {{.begin = 20, .end = 30},
{.begin = 40, .end = 50}};
test_create_tree (nodes, N, false);
- struct itree_iterator *g =
- itree_iterator_start (&tree, 1, 60, ITREE_DESCENDING, NULL, 0);
+ struct itree_iterator it, *g =
+ itree_iterator_start (&it, &tree, 1, 60, ITREE_DESCENDING);
struct itree_node *n = itree_iterator_next (g);
ck_assert_int_eq (n->begin, 40);
itree_iterator_narrow (g, 50, 60);
n = itree_iterator_next (g);
ck_assert_ptr_null (n);
- itree_iterator_finish (g);
}
END_TEST
@@ -955,14 +947,13 @@ START_TEST (test_generator_9)
struct itree_node nodes[N] = {{.begin = 25, .end = 25},
{.begin = 20, .end = 30}};
test_create_tree (nodes, N, false);
- struct itree_iterator *g =
- itree_iterator_start (&tree, 1, 30, ITREE_DESCENDING, NULL, 0);
+ struct itree_iterator it, *g =
+ itree_iterator_start (&it, &tree, 1, 30, ITREE_DESCENDING);
struct itree_node *n = itree_iterator_next (g);
ck_assert_int_eq (n->begin, 25);
itree_iterator_narrow (g, 25, 30);
n = itree_iterator_next (g);
ck_assert_int_eq (n->begin, 20);
- itree_iterator_finish (g);
}
END_TEST
@@ -981,7 +972,7 @@ static void
test_setup_gap_node (ptrdiff_t begin, ptrdiff_t end,
bool front_advance, bool rear_advance)
{
- interval_tree_init (&gap_tree);
+ itree_init (&gap_tree);
gap_node.front_advance = front_advance;
gap_node.rear_advance = rear_advance;
itree_insert (&gap_tree, &gap_node, begin, end);
@@ -1281,9 +1272,8 @@ main (void)
Suite *s = basic_suite ();
SRunner *sr = srunner_create (s);
- init_itree ();
srunner_run_all (sr, CK_ENV);
- int nfailed = srunner_ntests_failed (sr);
+ int failed = srunner_ntests_failed (sr);
srunner_free (sr);
- return (nfailed == 0) ? EXIT_SUCCESS : EXIT_FAILURE;
+ return failed ? EXIT_FAILURE : EXIT_SUCCESS;
}
diff --git a/test/manual/scroll-tests.el b/test/manual/scroll-tests.el
index 6ab24dfdbea..431a4514b36 100644
--- a/test/manual/scroll-tests.el
+++ b/test/manual/scroll-tests.el
@@ -80,25 +80,25 @@
,@body)))
(ert-deftest scroll-tests-scroll-margin-0 ()
- (skip-unless (not noninteractive))
+ (skip-when noninteractive)
(scroll-tests-with-buffer-window
(scroll-tests-up-and-down 0)))
(ert-deftest scroll-tests-scroll-margin-negative ()
"A negative `scroll-margin' should be the same as 0."
- (skip-unless (not noninteractive))
+ (skip-when noninteractive)
(scroll-tests-with-buffer-window
(scroll-tests-up-and-down -10 0)))
(ert-deftest scroll-tests-scroll-margin-max ()
- (skip-unless (not noninteractive))
+ (skip-when noninteractive)
(scroll-tests-with-buffer-window
(let ((max-margin (/ (window-text-height) 4)))
(scroll-tests-up-and-down max-margin))))
(ert-deftest scroll-tests-scroll-margin-over-max ()
"A `scroll-margin' more than max should be the same as max."
- (skip-unless (not noninteractive))
+ (skip-when noninteractive)
(scroll-tests-with-buffer-window 7
(let ((max-margin (/ (window-text-height) 4)))
(scroll-tests-up-and-down (+ max-margin 1) max-margin)
@@ -155,7 +155,7 @@ middle of the window."
(should (scroll-tests--point-in-middle-of-window-p)))))
(ert-deftest scroll-tests-scroll-margin-whole-window ()
- (skip-unless (not noninteractive))
+ (skip-when noninteractive)
(scroll-tests--scroll-margin-whole-window))
(ert-deftest scroll-tests-scroll-margin-whole-window-line-spacing ()
diff --git a/test/misc/test-custom-libs.el b/test/misc/test-custom-libs.el
index ac9e266ca90..0ecc64dd689 100644
--- a/test/misc/test-custom-libs.el
+++ b/test/misc/test-custom-libs.el
@@ -39,7 +39,7 @@
:tags '(:expensive-test)
:expected-result :failed ; FIXME: See above.
;; This test is very slow, and IMO not worth the time it takes.
- (skip-unless (not (getenv "EMACS_HYDRA_CI")))
+ (skip-when (getenv "EMACS_HYDRA_CI"))
(skip-unless (file-readable-p custom-test-admin-cus-test))
(load custom-test-admin-cus-test)
(cus-test-libs t)
diff --git a/test/src/casefiddle-tests.el b/test/src/casefiddle-tests.el
index d5195b2af67..0a456c094ab 100644
--- a/test/src/casefiddle-tests.el
+++ b/test/src/casefiddle-tests.el
@@ -294,4 +294,16 @@
;;(should (string-equal (capitalize "indIá") "İndıa"))
))
+(defun casefiddle-tests--check-syms (init with-words with-symbols)
+ (let ((case-symbols-as-words nil))
+ (should (string-equal (upcase-initials init) with-words)))
+ (let ((case-symbols-as-words t))
+ (should (string-equal (upcase-initials init) with-symbols))))
+
+(ert-deftest casefiddle-case-symbols-as-words ()
+ (casefiddle-tests--check-syms "Aa_bb Cc_dd" "Aa_Bb Cc_Dd" "Aa_bb Cc_dd")
+ (casefiddle-tests--check-syms "Aa_bb cc_DD" "Aa_Bb Cc_DD" "Aa_bb Cc_DD")
+ (casefiddle-tests--check-syms "aa_bb cc_dd" "Aa_Bb Cc_Dd" "Aa_bb Cc_dd")
+ (casefiddle-tests--check-syms "Aa_Bb Cc_Dd" "Aa_Bb Cc_Dd" "Aa_Bb Cc_Dd"))
+
;;; casefiddle-tests.el ends here
diff --git a/test/src/comp-resources/comp-test-funcs-dyn2.el b/test/src/comp-resources/comp-test-funcs-dyn2.el
new file mode 100644
index 00000000000..101674f74ce
--- /dev/null
+++ b/test/src/comp-resources/comp-test-funcs-dyn2.el
@@ -0,0 +1,31 @@
+;;; comp-test-funcs-dyn2.el -*- lexical-binding: nil; no-byte-compile: t; -*-
+
+;; Copyright (C) 2023-2024 Free Software Foundation, Inc.
+
+;; Author: Alan Mackenzie <acm@muc.de>
+
+;; This file is part of GNU Emacs.
+
+;; GNU Emacs is free software: you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+
+;; GNU Emacs is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>.
+
+;;; Commentary:
+;; Test the compilation of a function under dynamic binding.
+
+;;; Code:
+
+(defun comp-tests-result-lambda ()
+ (lambda (bar) (car bar)))
+
+(provide 'comp-test-funcs-dyn2)
+;;; comp-test-funcs-dyn2.el ends here.
diff --git a/test/src/comp-resources/comp-test-funcs.el b/test/src/comp-resources/comp-test-funcs.el
index 9f1f4c61244..54f339f6373 100644
--- a/test/src/comp-resources/comp-test-funcs.el
+++ b/test/src/comp-resources/comp-test-funcs.el
@@ -23,6 +23,8 @@
;;; Code:
+(require 'cl-lib)
+
(defvar comp-tests-var1 3)
(defun comp-tests-varref-f ()
@@ -240,6 +242,10 @@
(defun comp-tests-lambda-return-f ()
(lambda (x) (1+ x)))
+(defun comp-tests-lambda-return-f2 ()
+ (lambda ()
+ (lambda (x) (1+ x))))
+
(defun comp-tests-fib-f (n)
(cond ((= n 0) 0)
((= n 1) 1)
@@ -361,11 +367,11 @@
(while (consp insn)
(let ((newcar (car insn)))
(if (or (consp (car insn)) (comp-mvar-p (car insn)))
- (setf newcar (comp-copy-insn (car insn))))
+ (setf newcar (comp--copy-insn (car insn))))
(push newcar result))
(setf insn (cdr insn)))
(nconc (nreverse result)
- (if (comp-mvar-p insn) (comp-copy-insn insn) insn)))
+ (if (comp-mvar-p insn) (comp--copy-insn insn) insn)))
(if (comp-mvar-p insn)
(copy-comp-mvar insn)
insn)))
@@ -518,6 +524,44 @@
(defun comp-test-48029-nonascii-žžž-f (arg)
(when arg t))
+(defun comp-test-62537-1-f ())
+
+(defun comp-test-62537-2-f ()
+ (when (let ((val (comp-test-62537-1-f)))
+ (cond
+ ((eq val 'x)
+ t)
+ ((eq val 'y)
+ 'y)))
+ (comp-test-62537-1-f))
+ t)
+
+(cl-defstruct comp-test-struct)
+
+(defun comp-test-63674-1-f (x)
+ (or
+ (if (comp-test-struct-p pkg) x)
+ t))
+
+
+(cl-defstruct comp-test-time
+ unix)
+
+(defun comp-test-67239-00-f (a)
+ (cl-assert (stringp a)))
+
+(defsubst comp-test-67239-0-f (x _y)
+ (cl-etypecase x
+ (comp-test-time (error "foo"))
+ (string (comp-test-67239-00-f x))))
+
+(defun comp-test-67239-1-f ()
+ (let ((time (make-comp-test-time :unix (time-convert (current-time) 'integer))))
+ (comp-test-67239-0-f "%F" time)))
+
+(defun comp-test-67883-1-f ()
+ '#1=(1 . #1#))
+
;;;;;;;;;;;;;;;;;;;;
;; Tromey's tests ;;
diff --git a/test/src/comp-tests.el b/test/src/comp-tests.el
index 810aae0739b..b2fd2f68826 100644
--- a/test/src/comp-tests.el
+++ b/test/src/comp-tests.el
@@ -28,12 +28,14 @@
(require 'ert)
(require 'ert-x)
(require 'cl-lib)
+(require 'cl-seq)
(require 'comp)
(require 'comp-cstr)
(eval-and-compile
(defconst comp-test-src (ert-resource-file "comp-test-funcs.el"))
- (defconst comp-test-dyn-src (ert-resource-file "comp-test-funcs-dyn.el")))
+ (defconst comp-test-dyn-src (ert-resource-file "comp-test-funcs-dyn.el"))
+ (defconst comp-test-dyn-src2 (ert-resource-file "comp-test-funcs-dyn2.el")))
(when (native-comp-available-p)
(message "Compiling tests...")
@@ -44,6 +46,7 @@
;; names used in this file.
(require 'comp-test-funcs comp-test-src)
(require 'comp-test-dyn-funcs comp-test-dyn-src) ;Non-standard feature name!
+(require 'comp-test-funcs-dyn2 comp-test-dyn-src2)
(defmacro comp-deftest (name args &rest docstring-and-body)
"Define a test for the native compiler tagging it as :nativecomp."
@@ -308,7 +311,8 @@ Check that the resulting binaries do not differ."
(lambda () (throw 'foo 3)))
3))
(should (= (catch 'foo
- (comp-tests-throw-f 3)))))
+ (comp-tests-throw-f 3))
+ 3)))
(comp-deftest gc ()
"Try to do some longer computation to let the GC kick in."
@@ -324,6 +328,14 @@ Check that the resulting binaries do not differ."
(should (subr-native-elisp-p f))
(should (= (funcall f 3) 4))))
+(comp-deftest lambda-return2 ()
+ "Check a nested lambda function gets native compiled."
+ (let ((f (comp-tests-lambda-return-f2)))
+ (should (subr-native-elisp-p f))
+ (let ((f2 (funcall f)))
+ (should (subr-native-elisp-p f2))
+ (should (= (funcall f2 3) 4)))))
+
(comp-deftest recursive ()
(should (= (comp-tests-fib-f 10) 55)))
@@ -385,7 +397,27 @@ Check that the resulting binaries do not differ."
"Some doc."))
(should (commandp #'comp-tests-free-fun-f))
(should (equal (interactive-form #'comp-tests-free-fun-f)
- '(interactive))))
+ '(interactive nil))))
+
+(declare-function comp-tests-free-fun-f2 nil)
+
+(comp-deftest free-fun2 ()
+ "Check compiling a symbol's function compiles contained lambdas."
+ (eval '(defun comp-tests-free-fun-f2 ()
+ (lambda (x)
+ "Some doc."
+ (interactive)
+ x)))
+ (native-compile #'comp-tests-free-fun-f2)
+
+ (let* ((f (symbol-function 'comp-tests-free-fun-f2))
+ (f2 (funcall f)))
+ (should (subr-native-elisp-p f))
+ (should (subr-native-elisp-p f2))
+ (should (string= (documentation f2) "Some doc."))
+ (should (commandp f2))
+ (should (equal (interactive-form f2) '(interactive nil)))
+ (should (= (funcall f2 3) 3))))
(declare-function comp-tests/free\fun-f nil)
@@ -539,7 +571,7 @@ https://lists.gnu.org/archive/html/bug-gnu-emacs/2020-03/msg00914.html."
"Verify we can compile calls to redefined primitives with
dedicated byte-op code."
(let (x
- (f (lambda (fn &rest args)
+ (f (lambda (_fn &rest args)
(setq comp-test-primitive-redefine-args args))))
(advice-add #'delete-region :around f)
(unwind-protect
@@ -551,6 +583,10 @@ dedicated byte-op code."
(advice-remove #'delete-region f)
(should (equal comp-test-primitive-redefine-args '(1 2))))))
+(comp-deftest 67239-1 ()
+ "<https://lists.gnu.org/archive/html/bug-gnu-emacs/2023-11/msg00925.html>"
+ (should-not (comp-test-67239-1-f)))
+
;;;;;;;;;;;;;;;;;;;;;
;; Tromey's tests. ;;
@@ -868,16 +904,37 @@ Return a list of results."
(should (subr-native-elisp-p (symbol-function 'comp-tests-fw-prop-1-f)))
(should (= (comp-tests-fw-prop-1-f) 6))))
+(defun comp-tests--type-lists-equal (l1 l2)
+ (and (= (length l1) (length l2))
+ (cl-every #'comp-tests--types-equal l1 l2)))
+
+(defun comp-tests--types-equal (t1 t2)
+ "Whether the types T1 and T2 are equal."
+ (or (equal t1 t2) ; for atoms, and optimization for the common case
+ (and (consp t1) (consp t2)
+ (eq (car t1) (car t2))
+ (cond ((memq (car t1) '(and or member))
+ ;; Order or duplicates don't matter.
+ (null (cl-set-exclusive-or (cdr t1) (cdr t2)
+ :test #'comp-tests--types-equal)))
+ ((eq (car t1) 'function)
+ (and (comp-tests--type-lists-equal (nth 1 t1) (nth 1 t2))
+ (comp-tests--types-equal (nth 2 t1) (nth 2 t2))))
+ (t (comp-tests--type-lists-equal (cdr t1) (cdr t2)))))))
+
(defun comp-tests-check-ret-type-spec (func-form ret-type)
(let ((lexical-binding t)
(native-comp-speed 2)
(f-name (cl-second func-form)))
(eval func-form t)
(native-compile f-name)
- (should (equal (cl-third (subr-type (symbol-function f-name)))
- ret-type))))
+ (should (comp-tests--types-equal
+ (cl-third (subr-type (symbol-function f-name)))
+ ret-type))))
(cl-eval-when (compile eval load)
+ (cl-defstruct comp-foo a b)
+ (cl-defstruct (comp-bar (:include comp-foo)) c)
(defconst comp-tests-type-spec-tests
;; Why we quote everything here, you ask? So that values of
;; `most-positive-fixnum' and `most-negative-fixnum', which can be
@@ -972,7 +1029,7 @@ Return a list of results."
(if (= x y)
x
'foo))
- '(or (member foo) marker number))
+ '(or (member foo) number-or-marker))
;; 14
((defun comp-tests-ret-type-spec-f (x)
@@ -1112,7 +1169,7 @@ Return a list of results."
((defun comp-tests-ret-type-spec-f (x)
(when (> x 1.0)
x))
- '(or null marker number))
+ '(or null number-or-marker))
;; 36
((defun comp-tests-ret-type-spec-f (x y)
@@ -1407,7 +1464,46 @@ Return a list of results."
(if (eq x 0)
(error "")
(1+ x)))
- 'number)))
+ 'number)
+
+ ;; 75
+ ((defun comp-tests-ret-type-spec-f ()
+ (make-comp-foo))
+ 'comp-foo)
+
+ ;; 76
+ ((defun comp-tests-ret-type-spec-f ()
+ (make-comp-bar))
+ 'comp-bar)
+
+ ;; 77
+ ((defun comp-tests-ret-type-spec-f (x)
+ (setf (comp-foo-a x) 2)
+ x)
+ 'comp-foo)
+
+ ;; 78
+ ((defun comp-tests-ret-type-spec-f (x)
+ (if x
+ (if (> x 11)
+ x
+ (make-comp-foo))
+ (make-comp-bar)))
+ '(or comp-foo float (integer 12 *)))
+
+ ;; 79
+ ((defun comp-tests-ret-type-spec-f (x)
+ (if (comp-foo-p x)
+ x
+ (error "")))
+ 'comp-foo)
+
+ ;; 80
+ ((defun comp-tests-ret-type-spec-f (x)
+ (if (functionp x)
+ (error "")
+ x))
+ '(not function))))
(defun comp-tests-define-type-spec-test (number x)
`(comp-deftest ,(intern (format "ret-type-spec-%d" number)) ()
@@ -1496,4 +1592,7 @@ folded."
(equal (comp-mvar-typeset mvar)
comp-tests-cond-rw-expected-type))))))))
+(comp-deftest comp-tests-result-lambda ()
+ (native-compile 'comp-tests-result-lambda)
+ (should (eq (funcall (comp-tests-result-lambda) '(a . b)) 'a)))
;;; comp-tests.el ends here
diff --git a/test/src/data-tests.el b/test/src/data-tests.el
index 98b5ee69cb0..a1959f62fd3 100644
--- a/test/src/data-tests.el
+++ b/test/src/data-tests.el
@@ -768,8 +768,111 @@ comparing the subr with a much slower Lisp implementation."
(default-value 'last-coding-system-used))
'(no-conversion bug34318)))))
+(defvar-local data-tests--bug65209 :default-value)
+
+(ert-deftest data-tests-make-local-bug65209 ()
+ (dolist (sym '(data-tests--bug65209 ;A normal always-local Lisp var.
+ cursor-in-non-selected-windows)) ;Same but DEFVAR_PER_BUFFER.
+ ;; Note: For vars like `mode-name' that are *really* always buffer-local,
+ ;; this test isn't right because the `cl-progv' only binds the
+ ;; buffer-local value!
+ (let ((default (default-value sym))
+ vli vlo vgi vgo)
+ (with-temp-buffer
+ (cl-progv (list sym) '(:let-bound-value)
+ ;; While `setq' would not make the var buffer-local
+ ;; (because we'd be setq-ing the let-binding instead),
+ ;; `setq-local' definitely should.
+ (set (make-local-variable sym) :buffer-local-value)
+ (setq vgi (with-temp-buffer (symbol-value sym)))
+ (setq vli (symbol-value sym)))
+ (setq vgo (with-temp-buffer (symbol-value sym)))
+ (setq vlo (symbol-value sym)))
+ (should (equal (list vgo vgi vlo vli)
+ (cons default
+ '(:let-bound-value
+ :buffer-local-value :buffer-local-value)))))))
+
(ert-deftest data-tests-make_symbol_constant ()
"Can't set variable marked with 'make_symbol_constant'."
(should-error (setq most-positive-fixnum 1) :type 'setting-constant))
+(ert-deftest data-tests-fset ()
+ (fset 'data-tests--fs-fun (lambda () 'moo))
+ (declare-function data-tests--fs-fun nil)
+ (should (equal (data-tests--fs-fun) 'moo))
+
+ (fset 'data-tests--fs-fun1 'data-tests--fs-fun)
+ (declare-function data-tests--fs-fun1 nil)
+ (should (equal (data-tests--fs-fun1) 'moo))
+
+ (fset 'data-tests--fs-a 'data-tests--fs-b)
+ (fset 'data-tests--fs-b 'data-tests--fs-c)
+
+ (should-error (fset 'data-tests--fs-c 'data-tests--fs-c)
+ :type 'cyclic-function-indirection)
+ (fset 'data-tests--fs-d 'data-tests--fs-a)
+ (should-error (fset 'data-tests--fs-c 'data-tests--fs-d)
+ :type 'cyclic-function-indirection))
+
+(ert-deftest data-tests-defalias ()
+ (defalias 'data-tests--da-fun (lambda () 'baa))
+ (declare-function data-tests--da-fun nil)
+ (should (equal (data-tests--da-fun) 'baa))
+
+ (defalias 'data-tests--da-fun1 'data-tests--da-fun)
+ (declare-function data-tests--da-fun1 nil)
+ (should (equal (data-tests--da-fun1) 'baa))
+
+ (defalias 'data-tests--da-a 'data-tests--da-b)
+ (defalias 'data-tests--da-b 'data-tests--da-c)
+
+ (should-error (defalias 'data-tests--da-c 'data-tests--da-c)
+ :type 'cyclic-function-indirection)
+ (defalias 'data-tests--da-d 'data-tests--da-a)
+ (should-error (defalias 'data-tests--da-c 'data-tests--da-d)
+ :type 'cyclic-function-indirection))
+
+(ert-deftest data-tests-bare-symbol ()
+ (dolist (symbols-with-pos-enabled '(nil t))
+ (dolist (sym (list nil t 'xyzzy (make-symbol "")))
+ (should (eq sym (bare-symbol (position-symbol sym 0)))))))
+
+(require 'cl-extra) ;For `cl--class-children'.
+
+(ert-deftest data-tests--cl-type-of ()
+ ;; Make sure that `cl-type-of' returns the most precise type.
+ ;; Note: This doesn't work for list/vector structs since those types
+ ;; are too difficult/unreliable to detect (so `cl-type-of' only says
+ ;; it's a `cons' or a `vector').
+ (dolist (val (list -2 10 (expt 2 128) nil t 'car :car
+ (symbol-function 'car)
+ (symbol-function 'progn)
+ (eval '(lambda (x) (+ x 1)) t)
+ (position-symbol 'car 7)
+ (position-symbol :car 7)))
+ (let* ((type (cl-type-of val))
+ (class (cl-find-class type))
+ (alltypes (cl--class-allparents class))
+ ;; FIXME: Our type DAG is affected by `symbols-with-pos-enabled'.
+ ;; (e.g. `symbolp' returns nil on a sympos if that var is nil).
+ (symbols-with-pos-enabled t))
+ (dolist (parent alltypes)
+ (should (cl-typep val parent))
+ (dolist (subtype (cl--class-children (cl-find-class parent)))
+ (when (and (not (memq subtype alltypes))
+ (built-in-class-p (cl-find-class subtype))
+ (not (memq subtype
+ ;; FIXME: Some types don't have any associated
+ ;; predicate,
+ '( font-spec font-entity font-object
+ finalizer condvar terminal
+ native-comp-unit interpreted-function
+ tree-sitter-compiled-query
+ tree-sitter-node tree-sitter-parser))))
+ (cond
+ ((eq subtype 'function) (cl-functionp val))
+ (t (should-not (cl-typep val subtype))))))))))
+
+
;;; data-tests.el ends here
diff --git a/test/src/emacs-module-resources/mod-test.c b/test/src/emacs-module-resources/mod-test.c
index 06049364b1e..3aafae1b896 100644
--- a/test/src/emacs-module-resources/mod-test.c
+++ b/test/src/emacs-module-resources/mod-test.c
@@ -33,9 +33,9 @@ along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. */
#ifdef WINDOWSNT
/* Cannot include <process.h> because of the local header by the same
name, sigh. */
-uintptr_t _beginthread (void (__cdecl *)(void *), unsigned, void *);
+uintptr_t _beginthread (void (__cdecl *) (void *), unsigned, void *);
# if !defined __x86_64__
-# define ALIGN_STACK __attribute__((force_align_arg_pointer))
+# define ALIGN_STACK __attribute__ ((force_align_arg_pointer))
# endif
# include <windows.h> /* for Sleep */
#else /* !WINDOWSNT */
diff --git a/test/src/emacs-module-tests.el b/test/src/emacs-module-tests.el
index 91796cfd1b8..052fd83dc85 100644
--- a/test/src/emacs-module-tests.el
+++ b/test/src/emacs-module-tests.el
@@ -114,15 +114,14 @@ changes."
(ert-deftest mod-test-non-local-exit-signal-test ()
(should-error (mod-test-signal))
- (let (debugger-args backtrace)
+ (let (handler-err backtrace)
(should-error
- (let ((debugger (lambda (&rest args)
- (setq debugger-args args
- backtrace (with-output-to-string (backtrace)))
- (cl-incf num-nonmacro-input-events)))
- (debug-on-signal t))
+ (handler-bind
+ ((error (lambda (err)
+ (setq handler-err err
+ backtrace (with-output-to-string (backtrace))))))
(mod-test-signal)))
- (should (equal debugger-args '(error (error . 56))))
+ (should (equal handler-err '(error . 56)))
(should (string-match-p
(rx bol " mod-test-signal()" eol)
backtrace))))
@@ -316,7 +315,7 @@ local reference."
(replace-match "`src/emacs-module-resources/"))
(should (equal
(buffer-substring-no-properties 1 (point-max))
- (format "a module function in `src/emacs-module-resources/mod-test%s'.
+ (format "a module-function in `src/emacs-module-resources/mod-test%s'.
(mod-test-sum a b)
@@ -457,7 +456,7 @@ See Bug#36226."
(ert-deftest module/async-pipe ()
"Check that writing data from another thread works."
- (skip-unless (not (eq system-type 'windows-nt))) ; FIXME!
+ (skip-when (eq system-type 'windows-nt)) ; FIXME!
(with-temp-buffer
(let ((process (make-pipe-process :name "module/async-pipe"
:buffer (current-buffer)
diff --git a/test/src/eval-tests.el b/test/src/eval-tests.el
index b62178d9e8b..187dc2f34d5 100644
--- a/test/src/eval-tests.el
+++ b/test/src/eval-tests.el
@@ -247,4 +247,120 @@ expressions works for identifiers starting with period."
(should (equal (string-trim (buffer-string))
expected-messages))))))))
+(defvar-local eval-test--local-var 'global)
+
+(ert-deftest eval-test--bug62419 ()
+ (with-temp-buffer
+ (setq eval-test--local-var 'first-local)
+ (let ((eval-test--local-var t))
+ (kill-local-variable 'eval-test--local-var)
+ (setq eval-test--local-var 'second-local)
+ (should (eq eval-test--local-var 'second-local)))
+ ;; FIXME: It's not completely clear if exiting the above `let'
+ ;; should restore the buffer-local binding to `first-local'
+ ;; (i.e. reset the value of the second buffer-local binding to the
+ ;; first's initial value) or should do nothing (on the principle that
+ ;; the first buffer-local binding doesn't exists any more so there's
+ ;; nothing to restore). I think both semantics make sense.
+ ;;(should (eq eval-test--local-var 'first-local))
+ )
+ (should (eq eval-test--local-var 'global)))
+
+(ert-deftest eval-tests-defvaralias ()
+ (defvar eval-tests--my-var 'coo)
+ (defvaralias 'eval-tests--my-var1 'eval-tests--my-var)
+ (defvar eval-tests--my-var1)
+ (should (equal eval-tests--my-var 'coo))
+ (should (equal eval-tests--my-var1 'coo))
+
+ (defvaralias 'eval-tests--my-a 'eval-tests--my-b)
+ (defvaralias 'eval-tests--my-b 'eval-tests--my-c)
+
+ (should-error (defvaralias 'eval-tests--my-c 'eval-tests--my-c)
+ :type 'cyclic-variable-indirection)
+ (defvaralias 'eval-tests--my-d 'eval-tests--my-a)
+ (should-error (defvaralias 'eval-tests--my-c 'eval-tests--my-d)
+ :type 'cyclic-variable-indirection))
+
+(defvar eval-tests/global-var 'global-value)
+(defvar-local eval-tests/buffer-local-var 'default-value)
+(ert-deftest eval-tests/default-value ()
+ ;; `let' overrides the default value for global variables.
+ (should (default-boundp 'eval-tests/global-var))
+ (should (eq 'global-value (default-value 'eval-tests/global-var)))
+ (should (eq 'global-value eval-tests/global-var))
+ (let ((eval-tests/global-var 'let-value))
+ (should (eq 'let-value (default-value 'eval-tests/global-var)))
+ (should (eq 'let-value eval-tests/global-var)))
+ ;; `let' overrides the default value everywhere, but leaves
+ ;; buffer-local values unchanged in current buffer and in the
+ ;; buffers where there is no explicitly set buffer-local value.
+ (should (default-boundp 'eval-tests/buffer-local-var))
+ (should (eq 'default-value (default-value 'eval-tests/buffer-local-var)))
+ (should (eq 'default-value eval-tests/buffer-local-var))
+ (with-temp-buffer
+ (let ((eval-tests/buffer-local-var 'let-value))
+ (should (eq 'let-value (default-value 'eval-tests/buffer-local-var)))
+ (should (eq 'let-value eval-tests/buffer-local-var))))
+ ;; When current buffer has explicit buffer-local binding, `let' does
+ ;; not alter the default binding.
+ (with-temp-buffer
+ (setq-local eval-tests/buffer-local-var 'local-value)
+ (let ((eval-tests/buffer-local-var 'let-value))
+ ;; Let in a buffer with local binding does not change the
+ ;; default value for variable.
+ (should (eq 'default-value (default-value 'eval-tests/buffer-local-var)))
+ (should (eq 'let-value eval-tests/buffer-local-var))
+ (with-temp-buffer
+ ;; We are in a new buffer - `eval-tests/buffer-local-var' has its global default value.
+ (should (eq 'default-value (default-value 'eval-tests/buffer-local-var)))
+ (should (eq 'default-value eval-tests/buffer-local-var))))))
+
+(ert-deftest eval-tests--handler-bind ()
+ ;; A `handler-bind' has no effect if no error is signaled.
+ (should (equal (catch 'tag
+ (handler-bind ((error (lambda (_err) (throw 'tag 'wow))))
+ 'noerror))
+ 'noerror))
+ ;; The handler is called from within the dynamic extent where the
+ ;; error is signaled, unlike `condition-case'.
+ (should (equal (catch 'tag
+ (handler-bind ((error (lambda (_err) (throw 'tag 'err))))
+ (list 'inner-catch
+ (catch 'tag
+ (user-error "hello")))))
+ '(inner-catch err)))
+ ;; But inner condition handlers are temporarily muted.
+ (should (equal (condition-case nil
+ (handler-bind
+ ((error (lambda (_err)
+ (signal 'wrong-type-argument nil))))
+ (list 'result
+ (condition-case nil
+ (user-error "hello")
+ (wrong-type-argument 'inner-handler))))
+ (wrong-type-argument 'wrong-type-argument))
+ 'wrong-type-argument))
+ ;; Handlers do not apply to the code run within the handlers.
+ (should (equal (condition-case nil
+ (handler-bind
+ ((error (lambda (_err)
+ (signal 'wrong-type-argument nil)))
+ (wrong-type-argument
+ (lambda (_err) (user-error "wrong-type-argument"))))
+ (user-error "hello"))
+ (wrong-type-argument 'wrong-type-argument)
+ (error 'plain-error))
+ 'wrong-type-argument)))
+
+(ert-deftest eval-tests--error-id ()
+ (let* (inner-error
+ (outer-error
+ (condition-case err
+ (handler-bind ((error (lambda (err) (setq inner-error err))))
+ (car 1))
+ (error err))))
+ (should (eq inner-error outer-error))))
+
+
;;; eval-tests.el ends here
diff --git a/test/src/fileio-tests.el b/test/src/fileio-tests.el
index 764ae662e15..81eef37b903 100644
--- a/test/src/fileio-tests.el
+++ b/test/src/fileio-tests.el
@@ -50,7 +50,7 @@ Also check that an encoding error can appear in a symlink."
;; Some Windows versions don't support symlinks, and those which do
;; will pop up UAC elevation prompts, so we disable this test on
;; MS-Windows.
- (skip-unless (not (eq system-type 'windows-nt)))
+ (skip-when (eq system-type 'windows-nt))
(should (equal nil (fileio-tests--symlink-failure))))
(ert-deftest fileio-tests--directory-file-name ()
@@ -197,8 +197,7 @@ Also check that an encoding error can appear in a symlink."
(skip-unless (file-exists-p "/dev/urandom"))
(with-temp-buffer
(set-buffer-multibyte nil)
- ;; Fails in Emacs 29 because /dev/urandom is typically seekable (bug#65156)
- ;(should-error (insert-file-contents "/dev/urandom" nil 5 10))
+ (should-error (insert-file-contents "/dev/urandom" nil 5 10))
(insert-file-contents "/dev/urandom" nil nil 10)
(should (= (buffer-size) 10))))
diff --git a/test/src/filelock-tests.el b/test/src/filelock-tests.el
index 77345e1cbaa..c644747a23e 100644
--- a/test/src/filelock-tests.el
+++ b/test/src/filelock-tests.el
@@ -26,7 +26,7 @@
;;; Code:
-(require 'cl-macs)
+(require 'cl-lib)
(require 'ert)
(require 'ert-x)
(require 'seq)
@@ -38,8 +38,12 @@ Create a test directory and a buffer whose `buffer-file-name' and
Finally, delete the buffer and the test directory."
(declare (debug (body)))
`(ert-with-temp-directory temp-dir
- (let ((name (concat (file-name-as-directory temp-dir)
- "userfile"))
+ (let ((name
+ ;; Use file-truename for when 'temporary-file-directory'
+ ;; is a symlink, to make sure 'buffer-file-name' is set
+ ;; below to a real existing file.
+ (file-truename (concat (file-name-as-directory temp-dir)
+ "userfile")))
(create-lockfiles t))
(with-temp-buffer
(setq buffer-file-name name
@@ -105,7 +109,7 @@ the case)."
(ert-deftest filelock-tests-lock-spoiled ()
"Check `lock-buffer'."
- (skip-unless (not (eq system-type 'ms-dos))) ; no filelock support
+ (skip-when (eq system-type 'ms-dos)) ; no filelock support
(filelock-tests--fixture
(filelock-tests--spoil-lock-file buffer-file-truename)
;; FIXME: errors when locking a file are ignored; should they be?
@@ -115,7 +119,7 @@ the case)."
(ert-deftest filelock-tests-file-locked-p-spoiled ()
"Check that `file-locked-p' fails if the lockfile is \"spoiled\"."
- (skip-unless (not (eq system-type 'ms-dos))) ; no filelock support
+ (skip-when (eq system-type 'ms-dos)) ; no filelock support
(filelock-tests--fixture
(filelock-tests--spoil-lock-file buffer-file-truename)
(let ((err (should-error (file-locked-p (buffer-file-name)))))
@@ -126,7 +130,7 @@ the case)."
(ert-deftest filelock-tests-unlock-spoiled ()
"Check that `unlock-buffer' fails if the lockfile is \"spoiled\"."
- (skip-unless (not (eq system-type 'ms-dos))) ; no filelock support
+ (skip-when (eq system-type 'ms-dos)) ; no filelock support
(filelock-tests--fixture
;; Set the buffer modified with file locking temporarily disabled.
(let ((create-lockfiles nil))
@@ -146,7 +150,7 @@ the case)."
(ert-deftest filelock-tests-kill-buffer-spoiled ()
"Check that `kill-buffer' fails if a lockfile is \"spoiled\"."
- (skip-unless (not (eq system-type 'ms-dos))) ; no filelock support
+ (skip-when (eq system-type 'ms-dos)) ; no filelock support
(filelock-tests--fixture
;; Set the buffer modified with file locking temporarily disabled.
(let ((create-lockfiles nil))
@@ -172,7 +176,7 @@ the case)."
(ert-deftest filelock-tests-detect-external-change ()
"Check that an external file modification is reported."
- (skip-unless (not (eq system-type 'ms-dos))) ; no filelock support
+ (skip-when (eq system-type 'ms-dos)) ; no filelock support
(skip-unless (executable-find "touch"))
(skip-unless (executable-find "echo"))
(dolist (cl '(t nil))
@@ -184,7 +188,8 @@ the case)."
;; Just changing the file modification on disk doesn't hurt,
;; because file contents in buffer and on disk look equal.
- (shell-command (format "touch %s" (buffer-file-name)))
+ (shell-command (format "touch %s"
+ (shell-quote-argument (buffer-file-name))))
(insert "bar")
(when cl (filelock-tests--should-be-locked))
@@ -198,7 +203,8 @@ the case)."
;; Changing the file contents on disk hurts when buffer is
;; modified. There shall be a query, which we answer.
;; *Messages* buffer is checked for prompt.
- (shell-command (format "echo bar >>%s" (buffer-file-name)))
+ (shell-command (format "echo bar >>%s"
+ (shell-quote-argument (buffer-file-name))))
(cl-letf (((symbol-function 'read-char-choice)
(lambda (prompt &rest _) (message "%s" prompt) ?y)))
(ert-with-message-capture captured-messages
diff --git a/test/src/fns-tests.el b/test/src/fns-tests.el
index e5a4b6e8e56..1b13785a9fc 100644
--- a/test/src/fns-tests.el
+++ b/test/src/fns-tests.el
@@ -98,6 +98,26 @@
(should-not (equal-including-properties #("a" 0 1 (k "v"))
#("b" 0 1 (k "v")))))
+(ert-deftest fns-tests-equal-symbols-with-position ()
+ "Test `eq' and `equal' on symbols with position."
+ (let ((foo1 (position-symbol 'foo 42))
+ (foo2 (position-symbol 'foo 666))
+ (foo3 (position-symbol 'foo 42)))
+ (let (symbols-with-pos-enabled)
+ (should (eq foo1 foo1))
+ (should (equal foo1 foo1))
+ (should-not (eq foo1 foo2))
+ (should-not (equal foo1 foo2))
+ (should-not (eq foo1 foo3))
+ (should (equal foo1 foo3)))
+ (let ((symbols-with-pos-enabled t))
+ (should (eq foo1 foo1))
+ (should (equal foo1 foo1))
+ (should (eq foo1 foo2))
+ (should (equal foo1 foo2))
+ (should (eq foo1 foo3))
+ (should (equal foo1 foo3)))))
+
(ert-deftest fns-tests-reverse ()
(should-error (reverse))
(should-error (reverse 1))
@@ -114,22 +134,24 @@
(should-error (nreverse 1))
(should-error (nreverse (make-char-table 'foo)))
(should (equal (nreverse (copy-sequence "xyzzy")) "yzzyx"))
- (let ((A (vector)))
- (nreverse A)
- (should (equal A [])))
- (let ((A (vector 0)))
- (nreverse A)
- (should (equal A [0])))
- (let ((A (vector 1 2 3 4)))
- (nreverse A)
- (should (equal A [4 3 2 1])))
- (let ((A (vector 1 2 3 4)))
- (nreverse A)
- (nreverse A)
- (should (equal A [1 2 3 4])))
+ (let* ((A (vector))
+ (B (nreverse A)))
+ (should (equal A []))
+ (should (eq B A)))
+ (let* ((A (vector 0))
+ (B (nreverse A)))
+ (should (equal A [0]))
+ (should (eq B A)))
+ (let* ((A (vector 1 2 3 4))
+ (B (nreverse A)))
+ (should (equal A [4 3 2 1]))
+ (should (eq B A)))
(let* ((A (vector 1 2 3 4))
- (B (nreverse (nreverse A))))
- (should (equal A B))))
+ (B (nreverse A))
+ (C (nreverse A)))
+ (should (equal A [1 2 3 4]))
+ (should (eq B A))
+ (should (eq C A))))
(ert-deftest fns-tests-reverse-bool-vector ()
(let ((A (make-bool-vector 10 nil)))
@@ -140,9 +162,10 @@
(ert-deftest fns-tests-nreverse-bool-vector ()
(let ((A (make-bool-vector 10 nil)))
(dotimes (i 5) (aset A i t))
- (nreverse A)
- (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))))))
+ (let ((B (nreverse A)))
+ (should (eq B A))
+ (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
`(("abc" < "abd")
@@ -352,6 +375,49 @@
(should (equal (should-error (sort "cba" #'<) :type 'wrong-type-argument)
'(wrong-type-argument list-or-vector-p "cba"))))
+(defun fns-tests--shuffle-vector (vect)
+ "Shuffle VECT in place."
+ (let ((n (length vect)))
+ (dotimes (i (1- n))
+ (let* ((j (+ i (random (- n i))))
+ (vi (aref vect i)))
+ (aset vect i (aref vect j))
+ (aset vect j vi)))))
+
+(ert-deftest fns-tests-sort-kw ()
+ ;; Test the `sort' keyword calling convention by comparing with
+ ;; the results from using the old (positional) style tested above.
+ (random "my seed")
+ (dolist (size '(0 1 2 3 10 100 1000))
+ ;; Use a vector with both positive and negative numbers (asymmetric).
+ (let ((numbers (vconcat
+ (number-sequence (- (/ size 3)) (- size 1 (/ size 3))))))
+ (fns-tests--shuffle-vector numbers)
+ ;; Test both list and vector input.
+ (dolist (input (list (append numbers nil) numbers))
+ (dolist (in-place '(nil t))
+ (dolist (reverse '(nil t))
+ (dolist (key '(nil abs))
+ (dolist (lessp '(nil >))
+ (let* ((seq (copy-sequence input))
+ (res (sort seq :key key :lessp lessp
+ :in-place in-place :reverse reverse))
+ (pred (or lessp #'value<))
+ (exp-in (copy-sequence input))
+ (exp-out
+ (sort (if reverse (reverse exp-in) exp-in)
+ (if key
+ (lambda (a b)
+ (funcall pred
+ (funcall key a) (funcall key b)))
+ pred)))
+ (expected (if reverse (reverse exp-out) exp-out)))
+ (should (equal res expected))
+ (if in-place
+ (should (eq res seq))
+ (should-not (and (> size 0) (eq res seq)))
+ (should (equal seq input))))))))))))
+
(defvar w32-collate-ignore-punctuation)
(ert-deftest fns-tests-collate-sort ()
@@ -622,7 +688,7 @@
(insert "foo")
(goto-char 2)
(insert " ")
- (backward-delete-char 1)
+ (delete-char -1)
(buffer-hash))
(sha1 "foo"))))
@@ -1074,6 +1140,16 @@
(should (= (sxhash-equal (record 'a (make-string 10 ?a)))
(sxhash-equal (record 'a (make-string 10 ?a))))))
+(ert-deftest fns--define-hash-table-test ()
+ ;; Check that we can have two differently-named tests using the
+ ;; same functions (bug#68668).
+ (define-hash-table-test 'fns-tests--1 'my-cmp 'my-hash)
+ (define-hash-table-test 'fns-tests--2 'my-cmp 'my-hash)
+ (let ((h1 (make-hash-table :test 'fns-tests--1))
+ (h2 (make-hash-table :test 'fns-tests--2)))
+ (should (eq (hash-table-test h1) 'fns-tests--1))
+ (should (eq (hash-table-test h2) 'fns-tests--2))))
+
(ert-deftest test-secure-hash ()
(should (equal (secure-hash 'md5 "foobar")
"3858f62230ac3c915f300c664312c63f"))
@@ -1098,7 +1174,7 @@
(ert-deftest test-vector-delete ()
(let ((v1 (make-vector 1000 1)))
- (should (equal (delete t [nil t]) [nil]))
+ (should (equal (delete t (vector nil t)) [nil]))
(should (equal (delete 1 v1) (vector)))
(should (equal (delete 2 v1) v1))))
@@ -1480,4 +1556,222 @@
(should-error (copy-alist "abc")
:type 'wrong-type-argument))
+(ert-deftest fns-value<-ordered ()
+ ;; values (X . Y) where X<Y
+ (let* ((big (* 10 most-positive-fixnum))
+ (buf1 (get-buffer-create " *one*"))
+ (buf2 (get-buffer-create " *two*"))
+ (buf3 (get-buffer-create " *three*"))
+ (_ (progn (with-current-buffer buf1 (insert (make-string 20 ?a)))
+ (with-current-buffer buf2 (insert (make-string 20 ?b)))))
+ (mark1 (set-marker (make-marker) 12 buf1))
+ (mark2 (set-marker (make-marker) 13 buf1))
+ (mark3 (set-marker (make-marker) 12 buf2))
+ (mark4 (set-marker (make-marker) 13 buf2))
+ (proc1 (make-pipe-process :name " *proc one*"))
+ (proc2 (make-pipe-process :name " *proc two*")))
+ (kill-buffer buf3)
+ (unwind-protect
+ (dolist (c
+ `(
+ ;; fixnums
+ (1 . 2) (-2 . -1) (-2 . 1) (-1 . 2)
+ ;; bignums
+ (,big . ,(1+ big)) (,(- big) . ,big)
+ (,(- -1 big) . ,(- big))
+ ;; fixnums/bignums
+ (1 . ,big) (-1 . ,big) (,(- big) . -1) (,(- big) . 1)
+ ;; floats
+ (1.5 . 1.6) (-1.3 . -1.2) (-13.0 . 12.0)
+ ;; floats/fixnums
+ (1 . 1.1) (1.9 . 2) (-2.0 . 1) (-2 . 1.0)
+ ;; floats/bignums
+ (,big . ,(float (* 2 big))) (,(float big) . ,(* 2 big))
+ ;; symbols
+ (a . b) (nil . nix) (b . ba) (## . a) (A . a)
+ (#:a . #:b) (a . #:b) (#:a . b)
+ ;; strings
+ ("" . "a") ("a" . "b") ("A" . "a") ("abc" . "abd")
+ ("b" . "ba")
+
+ ;; lists
+ ((1 2 3) . (2 3 4)) ((2) . (2 1)) (() . (0))
+ ((1 2 3) . (1 3)) ((1 2 3) . (1 3 2))
+ (((b a) (c d) e) . ((b a) (c d) f))
+ (((b a) (c D) e) . ((b a) (c d) e))
+ (((b a) (c d () x) e) . ((b a) (c d (1) x) e))
+ ((1 . 2) . (1 . 3)) ((1 2 . 3) . (1 2 . 4))
+
+ ;; vectors
+ ([1 2 3] . [2 3 4]) ([2] . [2 1]) ([] . [0])
+ ([1 2 3] . [1 3]) ([1 2 3] . [1 3 2])
+ ([[b a] [c d] e] . [[b a] [c d] f])
+ ([[b a] [c D] e] . [[b a] [c d] e])
+ ([[b a] [c d [] x] e] . [[b a] [c d [1] x] e])
+
+ ;; bool-vectors
+ (,(bool-vector) . ,(bool-vector nil))
+ (,(bool-vector nil) . ,(bool-vector t))
+ (,(bool-vector t nil t nil) . ,(bool-vector t nil t t))
+ (,(bool-vector t nil t) . ,(bool-vector t nil t nil))
+
+ ;; records
+ (#s(a 2 3) . #s(b 3 4)) (#s(b) . #s(b a))
+ (#s(a 2 3) . #s(a 3)) (#s(a 2 3) . #s(a 3 2))
+ (#s(#s(b a) #s(c d) e) . #s(#s(b a) #s(c d) f))
+ (#s(#s(b a) #s(c D) e) . #s(#s(b a) #s(c d) e))
+ (#s(#s(b a) #s(c d #s(u) x) e)
+ . #s(#s(b a) #s(c d #s(v) x) e))
+
+ ;; markers
+ (,mark1 . ,mark2) (,mark1 . ,mark3) (,mark1 . ,mark4)
+ (,mark2 . ,mark3) (,mark2 . ,mark4) (,mark3 . ,mark4)
+
+ ;; buffers
+ (,buf1 . ,buf2) (,buf3 . ,buf1) (,buf3 . ,buf2)
+
+ ;; processes
+ (,proc1 . ,proc2)
+ ))
+ (let ((x (car c))
+ (y (cdr c)))
+ (should (value< x y))
+ (should-not (value< y x))
+ (should-not (value< x x))
+ (should-not (value< y y))))
+
+ (delete-process proc2)
+ (delete-process proc1)
+ (kill-buffer buf2)
+ (kill-buffer buf1))))
+
+(ert-deftest fns-value<-unordered ()
+ ;; values (X . Y) where neither X<Y nor Y<X
+
+ (let ((buf1 (get-buffer-create " *one*"))
+ (buf2 (get-buffer-create " *two*")))
+ (kill-buffer buf2)
+ (kill-buffer buf1)
+ (dolist (c `(
+ ;; numbers
+ (0 . 0.0) (0 . -0.0) (0.0 . -0.0)
+
+ ;; symbols
+ (a . #:a)
+
+ ;; (dead) buffers
+ (,buf1 . ,buf2)
+
+ ;; unordered types
+ (,(make-hash-table) . ,(make-hash-table))
+ (,(obarray-make) . ,(obarray-make))
+ ;; FIXME: more?
+ ))
+ (let ((x (car c))
+ (y (cdr c)))
+ (should-not (value< x y))
+ (should-not (value< y x))))))
+
+(ert-deftest fns-value<-type-mismatch ()
+ ;; values of disjoint (incomparable) types
+ (let ((incomparable
+ `( 1 a "a" (a b) [a b] ,(bool-vector nil t) #s(a b)
+ ,(make-char-table 'test)
+ ,(make-hash-table)
+ ,(obarray-make)
+ ;; FIXME: more?
+ )))
+ (let ((tail incomparable))
+ (while tail
+ (let ((x (car tail)))
+ (dolist (y (cdr tail))
+ (should-error (value< x y) :type 'type-mismatch)
+ (should-error (value< y x) :type 'type-mismatch)))
+ (setq tail (cdr tail))))))
+
+(ert-deftest fns-value<-symbol-with-pos ()
+ ;; values (X . Y) where X<Y
+ (let* ((a-sp-1 (position-symbol 'a 1))
+ (a-sp-2 (position-symbol 'a 2))
+ (b-sp-1 (position-symbol 'b 1))
+ (b-sp-2 (position-symbol 'b 2)))
+
+ (dolist (swp '(nil t))
+ (let ((symbols-with-pos-enabled swp))
+ ;; Enabled or not, they compare by name.
+ (dolist (c `((,a-sp-1 . ,b-sp-1) (,a-sp-1 . ,b-sp-2)
+ (,a-sp-2 . ,b-sp-1) (,a-sp-2 . ,b-sp-2)))
+ (let ((x (car c))
+ (y (cdr c)))
+ (should (value< x y))
+ (should-not (value< y x))
+ (should-not (value< x x))
+ (should-not (value< y y))))
+ (should-not (value< a-sp-1 a-sp-2))
+ (should-not (value< a-sp-2 a-sp-1))))
+
+ ;; When disabled, symbol-with-pos and symbols do not compare.
+ (should-error (value< a-sp-1 'a) :type 'type-mismatch)
+ (should-error (value< 'a a-sp-1) :type 'type-mismatch)
+
+ (let ((symbols-with-pos-enabled t))
+ ;; When enabled, a symbol-with-pos compares as a plain symbol.
+ (dolist (c `((,a-sp-1 . b) (a . ,b-sp-1)))
+ (let ((x (car c))
+ (y (cdr c)))
+ (should (value< x y))
+ (should-not (value< y x))
+ (should-not (value< x x))
+ (should-not (value< y y))))
+ (should-not (value< a-sp-1 'a))
+ (should-not (value< 'a a-sp-1)))))
+
+(ert-deftest fns-value<-circle ()
+ ;; Check that we at least don't hang when comparing two circular lists.
+ (let ((a (number-sequence 1 5))
+ (b (number-sequence 1 5)))
+ (setcdr (last a) (nthcdr 2 a))
+ (setcdr (last b) (nthcdr 2 b))
+ (should-error (value< a b :type 'circular))
+ (should-error (value< b a :type 'circular))))
+
+(ert-deftest fns-value<-bool-vector ()
+ ;; More thorough test of `value<' for bool-vectors.
+ (random "my seed")
+ (dolist (na '(0 1 5 8 9 32 63 64 65 200 1001 1024))
+ (let ((a (make-bool-vector na nil)))
+ (dotimes (i na)
+ (aset a i (zerop (random 2))))
+ (dolist (nb '(0 1 5 8 9 32 63 64 65 200 1001 1024))
+ (when (<= nb na)
+ (let ((b (make-bool-vector nb nil)))
+ (dotimes (i nb)
+ (aset b i (aref a i)))
+ ;; `b' is now a prefix of `a'.
+ (should-not (value< a b))
+ (cond ((= nb na)
+ (should (equal a b))
+ (should-not (value< b a)))
+ (t
+ (should-not (equal a b))
+ (should (value< b a))))
+ (unless (zerop nb)
+ ;; Flip random bits in `b' and check how it affects the order.
+ (dotimes (_ 3)
+ (let ((i (random nb)))
+ (let ((val (aref b i)))
+ (aset b i (not val))
+ (should-not (equal a b))
+ (cond
+ (val
+ ;; t -> nil: `b' is now always a proper prefix of `a'.
+ (should-not (value< a b))
+ (should (value< b a)))
+ (t
+ ;; nil -> t: `a' is now less than `b'.
+ (should (value< a b))
+ (should-not (value< b a))))
+ ;; Undo the flip.
+ (aset b i val)))))))))))
+
;;; fns-tests.el ends here
diff --git a/test/src/image-tests.el b/test/src/image-tests.el
index a4cdfd9ec82..24e60fb100f 100644
--- a/test/src/image-tests.el
+++ b/test/src/image-tests.el
@@ -44,15 +44,15 @@
(xpm . ,(find-image '((:file "splash.xpm" :type xpm))))))
(ert-deftest image-tests-image-size/error-on-nongraphical-display ()
- (skip-unless (not (display-images-p)))
+ (skip-when (display-images-p))
(should-error (image-size 'invalid-spec)))
(ert-deftest image-tests-image-mask-p/error-on-nongraphical-display ()
- (skip-unless (not (display-images-p)))
+ (skip-when (display-images-p))
(should-error (image-mask-p (cdr (assq 'xpm image-tests--images)))))
(ert-deftest image-tests-image-metadata/error-on-nongraphical-display ()
- (skip-unless (not (display-images-p)))
+ (skip-when (display-images-p))
(should-error (image-metadata (cdr (assq 'xpm image-tests--images)))))
(ert-deftest image-tests-imagemagick-types ()
diff --git a/test/src/keyboard-tests.el b/test/src/keyboard-tests.el
index b93431c15f2..4cb141804b2 100644
--- a/test/src/keyboard-tests.el
+++ b/test/src/keyboard-tests.el
@@ -23,6 +23,11 @@
(ert-deftest keyboard-unread-command-events ()
"Test `unread-command-events'."
+ ;; Avoid hang on Cygwin; see bug#65325.
+ (skip-unless (or (not (eq system-type 'cygwin))
+ (featurep 'gfilenotify)
+ (featurep 'dbus)
+ (featurep 'threads)))
(let ((unread-command-events nil))
(should (equal (progn (push ?\C-a unread-command-events)
(read-event nil nil 1))
diff --git a/test/src/keymap-tests.el b/test/src/keymap-tests.el
index bc9977f31bf..04b897045db 100644
--- a/test/src/keymap-tests.el
+++ b/test/src/keymap-tests.el
@@ -23,6 +23,7 @@
;;; Code:
(require 'ert)
+(require 'cl-lib)
(defun keymap-tests--make-keymap-test (fun)
(should (eq (car (funcall fun)) 'keymap))
@@ -470,10 +471,18 @@ g .. h foo
ert-keymap-duplicate
"a" #'next-line
"a" #'previous-line))
- (should-error
- (define-keymap
- "a" #'next-line
- "a" #'previous-line)))
+ (let ((msg ""))
+ ;; FIXME: It would be nicer to use `current-message' rather than override
+ ;; `message', but `current-message' returns always nil in batch mode :-(
+ (cl-letf (((symbol-function 'message)
+ (lambda (fmt &rest args) (setq msg (apply #'format fmt args)))))
+ (should
+ (string-match "duplicate"
+ (progn
+ (define-keymap
+ "a" #'next-line
+ "a" #'previous-line)
+ msg))))))
(ert-deftest keymap-unset-test-remove-and-inheritance ()
"Check various behaviors of keymap-unset. (Bug#62207)"
diff --git a/test/src/lread-tests.el b/test/src/lread-tests.el
index 2357a5012d0..4d7f8b71838 100644
--- a/test/src/lread-tests.el
+++ b/test/src/lread-tests.el
@@ -116,8 +116,27 @@
(should-error (read "#") :type 'invalid-read-syntax))
(ert-deftest lread-char-modifiers ()
- (should (eq ?\C-\M-é (+ (- ?\M-a ?a) ?\C-é)))
- (should (eq (- ?\C-ŗ ?ŗ) (- ?\C-é ?é))))
+ (should (equal ?\C-\M-é (+ (- ?\M-a ?a) ?\C-é)))
+ (should (equal (- ?\C-ŗ ?ŗ) (- ?\C-é ?é)))
+ (should (equal ?\C-\C-c #x4000003))
+ (should (equal ?\C-\M-\C-c #xc000003))
+ (should (equal ?\M-\C-\C-c #xc000003))
+ (should (equal ?\C-\C-\M-c #xc000003))
+ (should (equal ?\M-\S-\H-\A-\C-\s-x #xbc00018))
+
+ (should (equal "\s-x" " -x"))
+ (should (equal "\C-x" "\x18"))
+ (should (equal "\^x" "\x18"))
+ (should (equal "\M-x" "\xf8")))
+
+(ert-deftest lread-many-modifiers ()
+ ;; The string literal "\M-\M-...\M-a" should be equivalent to "\M-a",
+ ;; and we should not run out of stack space parsing it.
+ (let* ((n 500000)
+ (s (concat "\""
+ (apply #'concat (make-list n "\\M-"))
+ "a\"")))
+ (should (equal (read-from-string s) (cons "\M-a" (+ (* n 3) 3))))))
(ert-deftest lread-record-1 ()
(should (equal '(#s(foo) #s(foo))
@@ -137,11 +156,13 @@ literals (Bug#20852)."
(write-region "?) ?( ?; ?\" ?[ ?]" nil file-name)
(should (equal (load file-name nil :nomessage :nosuffix) t))
(should (equal (lread-tests--last-message)
- (concat (format-message "Loading `%s': " file-name)
- "unescaped character literals "
- "`?\"', `?(', `?)', `?;', `?[', `?]' detected, "
- "`?\\\"', `?\\(', `?\\)', `?\\;', `?\\[', `?\\]' "
- "expected!")))))
+ (format-message
+ (concat "Loading `%s': "
+ "unescaped character literals "
+ "`?\"', `?(', `?)', `?;', `?[', `?]' detected, "
+ "`?\\\"', `?\\(', `?\\)', `?\\;', `?\\[', `?\\]' "
+ "expected!")
+ file-name)))))
(ert-deftest lread-test-bug26837 ()
"Test for https://debbugs.gnu.org/26837 ."
diff --git a/test/src/minibuf-tests.el b/test/src/minibuf-tests.el
index 14d160df25c..99d522d1856 100644
--- a/test/src/minibuf-tests.el
+++ b/test/src/minibuf-tests.el
@@ -34,7 +34,7 @@
(let ((num 0))
(mapcar (lambda (str) (cons str (cl-incf num))) list)))
(defun minibuf-tests--strings-to-obarray (list)
- (let ((ob (make-vector 7 0)))
+ (let ((ob (obarray-make 7)))
(mapc (lambda (str) (intern str ob)) list)
ob))
(defun minibuf-tests--strings-to-string-hashtable (list)
@@ -61,6 +61,9 @@
;;; Testing functions that are agnostic to type of COLLECTION.
+(defun minibuf-tests--set-equal (a b)
+ (null (cl-set-exclusive-or a b :test #'equal)))
+
(defun minibuf-tests--try-completion (xform-collection)
(let* ((abcdef (funcall xform-collection '("abc" "def")))
(+abba (funcall xform-collection '("abc" "abba" "def"))))
@@ -101,7 +104,8 @@
(let* ((abcdef (funcall xform-collection '("abc" "def")))
(+abba (funcall xform-collection '("abc" "abba" "def"))))
(should (equal (all-completions "a" abcdef) '("abc")))
- (should (equal (all-completions "a" +abba) '("abc" "abba")))
+ (should (minibuf-tests--set-equal (all-completions "a" +abba)
+ '("abc" "abba")))
(should (equal (all-completions "abc" +abba) '("abc")))
(should (equal (all-completions "abcd" +abba) nil))))
@@ -111,7 +115,8 @@
(+abba (funcall xform-collection '("abc" "abba" "def")))
(+abba-member (funcall collection-member +abba)))
(should (equal (all-completions "a" abcdef abcdef-member) '("abc")))
- (should (equal (all-completions "a" +abba +abba-member) '("abc" "abba")))
+ (should (minibuf-tests--set-equal (all-completions "a" +abba +abba-member)
+ '("abc" "abba")))
(should (equal (all-completions "abc" +abba +abba-member) '("abc")))
(should (equal (all-completions "abcd" +abba +abba-member) nil))
(should-not (all-completions "a" abcdef #'ignore))
@@ -124,7 +129,8 @@
(+abba (funcall xform-collection '("abc" "abba" "def"))))
(let ((completion-regexp-list '(".")))
(should (equal (all-completions "a" abcdef) '("abc")))
- (should (equal (all-completions "a" +abba) '("abc" "abba")))
+ (should (minibuf-tests--set-equal (all-completions "a" +abba)
+ '("abc" "abba")))
(should (equal (all-completions "abc" +abba) '("abc")))
(should (equal (all-completions "abcd" +abba) nil)))
(let ((completion-regexp-list '("X")))
diff --git a/test/src/print-tests.el b/test/src/print-tests.el
index aedaa9a4e06..ff3a6fe7483 100644
--- a/test/src/print-tests.el
+++ b/test/src/print-tests.el
@@ -369,13 +369,6 @@ otherwise, use a different charset."
(should
(string-match
- "data ()"
- (let ((h (make-hash-table)))
- (let ((print-length 0))
- (format "%S" h)))))
-
- (should
- (string-match
"data (99 99)"
(let ((h (make-hash-table)))
(dotimes (i 100)
diff --git a/test/src/process-tests.el b/test/src/process-tests.el
index 15d46cbae15..19b14f2d0cb 100644
--- a/test/src/process-tests.el
+++ b/test/src/process-tests.el
@@ -231,7 +231,7 @@ process to complete."
(with-timeout (60 (ert-fail "Test timed out"))
;; Frequent random (?) failures on hydra.nixos.org, with no process output.
;; Maybe this test should be tagged unstable? See bug#31214.
- (skip-unless (not (getenv "EMACS_HYDRA_CI")))
+ (skip-when (getenv "EMACS_HYDRA_CI"))
(with-temp-buffer
(let ((process (make-process
:name "mix-stderr"
@@ -723,7 +723,7 @@ FD_SETSIZE file descriptors (Bug#24325)."
(skip-unless (featurep 'make-network-process '(:server t)))
(skip-unless (featurep 'make-network-process '(:family local)))
;; Avoid hang due to connect/accept handshake on Cygwin (bug#49496).
- (skip-unless (not (eq system-type 'cygwin)))
+ (skip-when (eq system-type 'cygwin))
(with-timeout (60 (ert-fail "Test timed out"))
(ert-with-temp-directory directory
(process-tests--with-processes processes
@@ -763,7 +763,7 @@ FD_SETSIZE file descriptors (Bug#24325)."
"Check that Emacs doesn't crash when trying to use more than
FD_SETSIZE file descriptors (Bug#24325)."
;; This test cannot be run if PTYs aren't supported.
- (skip-unless (not (eq system-type 'windows-nt)))
+ (skip-when (eq system-type 'windows-nt))
(with-timeout (60 (ert-fail "Test timed out"))
(process-tests--with-processes processes
;; In order to use `make-serial-process', we need to create some
@@ -830,7 +830,7 @@ Return nil if that can't be determined."
(when (eq process-tests--EMFILE-message :unknown)
(setq process-tests--EMFILE-message
(with-temp-buffer
- (when (eql (ignore-error 'file-error
+ (when (eql (ignore-error file-error
(call-process "errno" nil t nil "EMFILE"))
0)
(goto-char (point-min))
diff --git a/test/src/regex-emacs-tests.el b/test/src/regex-emacs-tests.el
index 9c55ee9866c..171d794360e 100644
--- a/test/src/regex-emacs-tests.el
+++ b/test/src/regex-emacs-tests.el
@@ -273,7 +273,7 @@ on success"
string
(condition-case nil
(if (string-match pattern string) nil 'search-failed)
- ('invalid-regexp 'compilation-failed))
+ (invalid-regexp 'compilation-failed))
bounds-ref substring-ref)))
@@ -518,7 +518,7 @@ known/benign differences in behavior.")
what-failed
(condition-case nil
(if (string-match pattern string) nil 'search-failed)
- ('invalid-regexp 'compilation-failed))
+ (invalid-regexp 'compilation-failed))
matches-observed
(cl-loop for x from 0 to 20
@@ -555,10 +555,10 @@ known/benign differences in behavior.")
(defconst regex-tests-PTESTS-whitelist
[
- ;; emacs doesn't see DEL (0x7f) as a [:cntrl:] character
+ ;; Emacs doesn't see DEL (0x7f) as a [:cntrl:] character
138
- ;; emacs doesn't barf on weird ranges such as [b-a], but simply
+ ;; Emacs doesn't barf on weird ranges such as [b-a], but simply
;; fails to match
168
]
@@ -872,20 +872,130 @@ This evaluates the TESTS test cases from glibc."
(should (equal (string-match "\\`\\(?:ab\\)*\\'" "a") nil))
(should (equal (string-match "\\`a\\{2\\}*\\'" "a") nil)))
-(ert-deftest regexp-tests-backtrack-optimization () ;bug#61514
- :expected-result :failed
+(ert-deftest regexp-tests-backtrack-optimization ()
;; Make sure we don't use up the regexp stack needlessly.
(with-current-buffer (get-buffer-create "*bug*")
(erase-buffer)
(insert (make-string 1000000 ?x) "=")
(goto-char (point-min))
+ ;; Make sure we do perform the optimization (if we don't, the
+ ;; below will burp with regexp-stack-overflow). ;bug#61514
(should (looking-at "x*=*"))
(should (looking-at "x*\\(=\\|:\\)"))
(should (looking-at "x*\\(=\\|:\\)*"))
- (should (looking-at "x*=*?"))))
+ (should (looking-at "x*=*?"))
+ ;; relint suppression: Repetition of expression matching an empty string
+ (should (looking-at "x*\\(=*\\|h\\)*?"))
+ ;; relint suppression: Repetition of expression matching an empty string
+ (should (looking-at "x*\\(=*\\|h\\)*"))
+ ;; relint suppression: Repetition of expression matching an empty string
+ (should (looking-at "x*\\(=*?\\|h\\)*"))
+ ;; relint suppression: Repetition of expression matching an empty string
+ (should (looking-at "x*\\(=*?\\|h\\)*?"))
+ ;; relint suppression: Repetition of expression matching an empty string
+ (should (looking-at "x*\\(=*\\|h\\)+?"))
+ ;; relint suppression: Repetition of expression matching an empty string
+ (should (looking-at "x*\\(=*\\|h\\)+"))
+ ;; relint suppression: Repetition of expression matching an empty string
+ (should (looking-at "x*\\(=*?\\|h\\)+"))
+ ;; relint suppression: Repetition of expression matching an empty string
+ (should (looking-at "x*\\(=*?\\|h\\)+?"))
+ (should (looking-at "x*\\(=+\\|h\\)+?"))
+ (should (looking-at "x*\\(=+\\|h\\)+"))
+ (should (looking-at "x*\\(=+?\\|h\\)+"))
+ (should (looking-at "x*\\(=+?\\|h\\)+?"))
+ ;; Regression check for overly optimistic optimization.
+ (should (eq 0 (string-match "\\(ca*\\|ab\\)+d" "cabd")))
+ (should (string-match "\\(aa*\\|b\\)*c" "ababc"))
+ (should (string-match " \\sw*\\bfoo" " foo"))
+ (should (string-match ".*\\>" "hello "))
+ ))
+
+(ert-deftest regexp-tests-zero-width-assertion-repetition ()
+ ;; Check compatibility behavior with repetition operators after
+ ;; certain zero-width assertions (bug#64128).
+
+ ;; This function is just to hide ugly regexps from relint so that it
+ ;; doesn't complain about them.
+ (cl-flet ((smatch (re str) (string-match re str)))
+ ;; Postfix operators after ^ and \` become literals, for historical
+ ;; compatibility. Only the first character of a lazy operator (like *?)
+ ;; becomes a literal.
+ (should (equal (smatch "^*a" "x\n*a") 2))
+ (should (equal (smatch "^*?a" "x\n*a") 2))
+ (should (equal (smatch "^*?a" "x\na") 2))
+ (should (equal (smatch "^*?a" "x\n**a") nil))
+
+ (should (equal (smatch "\\`*a" "*a") 0))
+ (should (equal (smatch "\\`*?a" "*a") 0))
+ (should (equal (smatch "\\`*?a" "a") 0))
+ (should (equal (smatch "\\`*?a" "**a") nil))
+
+ ;; Other zero-width assertions are treated as normal elements, so postfix
+ ;; operators apply to them alone (which is pointless but valid).
+ (should (equal (smatch "\\b*!" "*!") 1))
+ (should (equal (smatch "!\\b+;" "!;") nil))
+ (should (equal (smatch "!\\b+a" "!a") 0))
+
+ (should (equal (smatch "\\B*!" "*!") 1))
+ (should (equal (smatch "!\\B+;" "!;") 0))
+ (should (equal (smatch "!\\B+a" "!a") nil))
+
+ (should (equal (smatch "\\<*b" "*b") 1))
+ (should (equal (smatch "a\\<*b" "ab") 0))
+ (should (equal (smatch ";\\<*b" ";b") 0))
+ (should (equal (smatch "a\\<+b" "ab") nil))
+ (should (equal (smatch ";\\<+b" ";b") 0))
+
+ (should (equal (smatch "\\>*;" "*;") 1))
+ (should (equal (smatch "a\\>*b" "ab") 0))
+ (should (equal (smatch "a\\>*;" "a;") 0))
+ (should (equal (smatch "a\\>+b" "ab") nil))
+ (should (equal (smatch "a\\>+;" "a;") 0))
+
+ (should (equal (smatch "a\\'" "ab") nil))
+ (should (equal (smatch "b\\'" "ab") 1))
+ (should (equal (smatch "a\\'*b" "ab") 0))
+ (should (equal (smatch "a\\'+" "ab") nil))
+ (should (equal (smatch "b\\'+" "ab") 1))
+ (should (equal (smatch "\\'+" "+") 1))
+
+ (should (equal (smatch "\\_<*b" "*b") 1))
+ (should (equal (smatch "a\\_<*b" "ab") 0))
+ (should (equal (smatch " \\_<*b" " b") 0))
+ (should (equal (smatch "a\\_<+b" "ab") nil))
+ (should (equal (smatch " \\_<+b" " b") 0))
+
+ (should (equal (smatch "\\_>*;" "*;") 1))
+ (should (equal (smatch "a\\_>*b" "ab") 0))
+ (should (equal (smatch "a\\_>* " "a ") 0))
+ (should (equal (smatch "a\\_>+b" "ab") nil))
+ (should (equal (smatch "a\\_>+ " "a ") 0))
+
+ (should (equal (smatch "\\=*b" "*b") 1))
+ (should (equal (smatch "a\\=*b" "a*b") nil))
+ (should (equal (smatch "a\\=*b" "ab") 0))
+ ))
+
+(ert-deftest regex-emacs-syntax-properties ()
+ ;; Verify absence of character class syntax property ghost matching bug.
+ (let ((re "\\s-[[:space:]]")
+ (s (concat "a"
+ (propertize "b" 'syntax-table '(0)) ; whitespace
+ "éz"))
+ (parse-sexp-lookup-properties t))
+ ;; Test matching in a string...
+ (should (equal (string-match re s) nil))
+ ;; ... and in a buffer.
+ (should (equal (with-temp-buffer
+ (insert s)
+ (goto-char (point-min))
+ (re-search-forward re nil t))
+ nil))))
(ert-deftest regex-tests-mutual-exclusive-inf-rec ()
;; Regression test for bug#65726, where this crashed Emacs.
+ ;; relint suppression: Repetition of expression matching an empty string
(should (equal (string-match "a*\\(?:c\\|b*\\)*" "a") 0)))
;;; regex-emacs-tests.el ends here
diff --git a/test/src/regex-resources/PTESTS b/test/src/regex-resources/PTESTS
index 68acc314d37..59dd4b3bc21 100644
--- a/test/src/regex-resources/PTESTS
+++ b/test/src/regex-resources/PTESTS
@@ -269,6 +269,7 @@
#W the expected result for \([a-c]*\)\{2,\} is failure which isn't correct
1¦3¦\([a-c]*\)\{2,\}¦abcdefg¦
1¦3¦\([a-c]*\)\{1,\}¦abcdefg¦
+0¦0¦\([a-c]*\)\{2,\}¦gabcdefg¦
-1¦-1¦a\{64,\}¦aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa¦
# GA142
1¦3¦a\{2,3\}¦aaaa¦
diff --git a/test/src/search-tests.el b/test/src/search-tests.el
index ecdd5fdc101..bab503f36bf 100644
--- a/test/src/search-tests.el
+++ b/test/src/search-tests.el
@@ -39,4 +39,42 @@
(replace-match "bcd"))
(should (= (point) 10)))))
+(ert-deftest search-test--replace-match-update-data ()
+ (with-temp-buffer
+ (pcase-dolist (`(,pre ,post) '(("" "")
+ ("a" "")
+ ("" "b")
+ ("a" "b")))
+ (erase-buffer)
+ (insert "hello ")
+ (save-excursion (insert pre post " world"))
+ (should (looking-at
+ (concat "\\(\\)" pre "\\(\\)\\(\\(\\)\\)\\(\\)" post "\\(\\)")))
+ (let* ((beg0 (match-beginning 0))
+ (beg4 (+ beg0 (length pre)))
+ (end4 (+ beg4 (length "BOO")))
+ (end0 (+ end4 (length post))))
+ (replace-match "BOO" t t nil 4)
+ (should (equal (match-beginning 0) beg0))
+ (should (equal (match-beginning 1) beg0))
+ (should (equal (match-beginning 2) beg4))
+ (should (equal (match-beginning 3) beg4))
+ (should (equal (match-beginning 4) beg4))
+ (should (equal (match-end 6) end0))
+ (should (equal (match-end 5) end4))
+ (should (equal (match-end 4) end4))
+ (should (equal (match-end 3) end4))
+ (should (equal (match-end 0) end0))
+ ;; `update_search_regs' doesn't have enough information to get
+ ;; the ones below correctly in all cases.
+ (when (> (length post) 0)
+ (should (equal (match-beginning 6) end0)))
+ (when (> (length pre) 0)
+ (should (equal (match-end 1) beg0)))
+ ;; `update_search_regs' doesn't have enough information to get
+ ;; the ones below correctly at all.
+ ;;(should (equal (match-beginning 5) end4))
+ ;;(should (equal (match-end 2) beg4))
+ ))))
+
;;; search-tests.el ends here
diff --git a/test/src/syntax-tests.el b/test/src/syntax-tests.el
index 71ddecfcb97..f0f7cf28a3c 100644
--- a/test/src/syntax-tests.el
+++ b/test/src/syntax-tests.el
@@ -518,7 +518,6 @@ the `parse-partial-sexp's are expected to stop. See
(modify-syntax-entry (unibyte-char-to-multibyte 128) "_" st)
(set-syntax-table st)
(should (equal (eval '(char-syntax 128) t) ?_))
- (should (equal (funcall cs 128) ?_))))
- (list (char-syntax 128) (funcall cs 128))))
+ (should (equal (funcall cs 128) ?_))))))
;;; syntax-tests.el ends here
diff --git a/test/src/treesit-tests.el b/test/src/treesit-tests.el
index 3eda6fd3c53..bdc9630c783 100644
--- a/test/src/treesit-tests.el
+++ b/test/src/treesit-tests.el
@@ -34,6 +34,7 @@
(declare-function treesit-parser-buffer "treesit.c")
(declare-function treesit-parser-language "treesit.c")
+(declare-function treesit-pattern-expand "treesit.c")
(declare-function treesit-query-expand "treesit.c")
(declare-function treesit-query-compile "treesit.c")
(declare-function treesit-query-capture "treesit.c")
@@ -54,6 +55,9 @@
(declare-function treesit-node-descendant-for-range "treesit.c")
(declare-function treesit-node-eq "treesit.c")
+(declare-function treesit-search-forward "treesit.c")
+(declare-function treesit-search-subtree "treesit.c")
+
;;; Basic API
(ert-deftest treesit-basic-parsing ()
@@ -162,6 +166,13 @@
;; `treesit-node-eq'.
(should (treesit-node-eq root-node root-node))
(should (not (treesit-node-eq root-node doc-node)))
+ ;; `treesit-node-enclosed-p'
+ (should (treesit-node-enclosed-p '(1 . 3) '(1 . 4)))
+ (should (treesit-node-enclosed-p '(1 . 3) '(1 . 3)))
+ (should (not (treesit-node-enclosed-p '(1 . 3) '(1 . 4) t)))
+ (should (treesit-node-enclosed-p '(1 . 3) '(1 . 4) 'partial))
+ (should (treesit-node-enclosed-p '(2 . 3) '(1 . 4) t))
+ (should (treesit-node-enclosed-p object-node root-node))
;; Further test for `treesit-node-check'.
(treesit-parser-delete parser)
@@ -257,6 +268,7 @@
(defmacro treesit--ert-search-setup (&rest body)
"Setup macro used by `treesit-search-forward' and friends.
BODY is the test body."
+ (declare (debug (&rest form)))
`(with-temp-buffer
(let (parser root array)
(progn
@@ -332,6 +344,59 @@ BODY is the test body."
do (should (equal (treesit-node-text cursor)
text)))))
+(ert-deftest treesit-search-forward-predicate ()
+ "Test various form of supported predicates in search functions."
+ (skip-unless (treesit-language-available-p 'json))
+ (treesit--ert-search-setup
+ ;; The following tests are adapted from `treesit-search-forward'.
+
+ ;; Test `or'
+ (cl-loop for cursor = (treesit-node-child array 0)
+ then (treesit-search-forward cursor `(or "number" ,(rx "["))
+ nil t)
+ for text in '("[" "[" "1" "2" "3"
+ "[" "4" "5" "6"
+ "[" "7" "8" "9")
+ while cursor
+ do (should (equal (treesit-node-text cursor) text)))
+ ;; Test `not' and `or'
+ (cl-loop for cursor = (treesit-node-child array 0)
+ then (treesit-search-forward cursor
+ `(not (or "number" ,(rx "[")))
+ nil t)
+ for text in '("[" "," "," "]"
+ "[1,2,3]" ","
+ "," "," "]"
+ "[4,5,6]" ","
+ "," "," "]"
+ "[7,8,9]" "]"
+ "[[1,2,3], [4,5,6], [7,8,9]]")
+ while cursor
+ do (should (equal (treesit-node-text cursor) text)))
+ ;; Test (regexp . function)
+ (let ((is-odd (lambda (node)
+ (let ((string (treesit-node-text node)))
+ (and (eq 1 (length string))
+ (cl-oddp (string-to-number string)))))))
+ (cl-loop for cursor = (treesit-node-child array 0)
+ then (treesit-search-forward cursor `("number" . ,is-odd)
+ nil t)
+ for text in '("[" "1" "3" "5" "7" "9")
+ while cursor
+ do (should (equal (treesit-node-text cursor) text))))))
+
+(ert-deftest treesit-search-forward-predicate-invalid-predicate ()
+ "Test tree-sitter's ability to detect invalid predicates."
+ (skip-unless (treesit-language-available-p 'json))
+ (treesit--ert-search-setup
+ (dolist (pred '( 1 (not 1) (not "2" "3") (or) (or 1) 'a))
+ (should-error (treesit-search-forward (treesit-node-child array 0)
+ pred)
+ :type 'treesit-invalid-predicate))
+ (should-error (treesit-search-forward (treesit-node-child array 0)
+ (lambda (node) (car node)))
+ :type 'wrong-type-argument)))
+
(ert-deftest treesit-cursor-helper-with-missing-node ()
"Test treesit_cursor_helper with a missing node."
(skip-unless (treesit-language-available-p 'json))
@@ -404,7 +469,12 @@ BODY is the test body."
"(type field: (_) @capture .) ? * + \"return\""
(treesit-query-expand
'((type field: (_) @capture :anchor)
- :? :* :+ "return")))))))
+ :? :* :+ "return"))))
+
+ ;; Test string conversion in `treesit-pattern-expand'.
+ (should (equal
+ (treesit-pattern-expand "a\nb\rc\td\0e\"f\1g\\h\fi")
+ "\"a\\nb\\rc\\td\\0e\\\"f\1g\\\\h\fi\"")))))
;;; Narrow
@@ -599,6 +669,20 @@ visible_end.)"
;; TODO: More tests.
)))
+(ert-deftest treesit-range-offset ()
+ "Tests if range offsets work."
+ (skip-unless (treesit-language-available-p 'javascript))
+ (with-temp-buffer
+ (let ((query '(((call_expression (identifier) @_html_template_fn
+ (template_string) @capture)
+ (:equal "html" @_html_template_fn)))))
+ (progn
+ (insert "const x = html`<p>Hello</p>`;")
+ (treesit-parser-create 'javascript))
+ (should (equal '((15 . 29)) (treesit-query-range 'javascript query)))
+ (should (equal '((16 . 28)) (treesit-query-range
+ 'javascript query nil nil '(1 . -1)))))))
+
;;; Multiple language
(ert-deftest treesit-multi-lang ()
@@ -831,7 +915,7 @@ the return value is ((1 3) (1 3))."
(funcall fn)))))
(defun treesit--ert-test-defun-navigation
- (init program master &optional opening closing)
+ (init program master tactic &optional opening closing)
"Run defun navigation tests on PROGRAM and MASTER.
INIT is a setup function that runs right after this function
@@ -843,6 +927,8 @@ starting marker position, and the rest are marker positions the
corresponding navigation should stop at (after running
`treesit-defun-skipper').
+TACTIC is the same as in `treesit--navigate-thing'.
+
OPENING and CLOSING are the same as in
`treesit--ert-insert-and-parse-marker', by default they are \"[\"
and \"]\"."
@@ -860,8 +946,6 @@ and \"]\"."
collect
(cl-loop for pos in record
collect (alist-get pos marker-alist))))
- (`(,regexp . ,pred) (treesit--thing-unpack-pattern
- treesit-defun-type-regexp))
;; Collect positions each function returns.
(positions
(treesit--ert-collect-positions
@@ -873,7 +957,7 @@ and \"]\"."
(if-let ((pos (funcall
#'treesit--navigate-thing
(point) (car conf) (cdr conf)
- regexp pred)))
+ treesit-defun-type-regexp tactic)))
(save-excursion
(goto-char pos)
(funcall treesit-defun-skipper)
@@ -1025,43 +1109,42 @@ the prev-beg, now point should be at marker 103\", etc.")
"Test defun navigation."
(skip-unless (treesit-language-available-p 'python))
;; Nested defun navigation
- (let ((treesit-defun-tactic 'nested))
- (require 'python)
- (treesit--ert-test-defun-navigation
- 'python-ts-mode
- treesit--ert-defun-navigation-python-program
- treesit--ert-defun-navigation-nested-master)))
+ (require 'python)
+ (treesit--ert-test-defun-navigation
+ 'python-ts-mode
+ treesit--ert-defun-navigation-python-program
+ treesit--ert-defun-navigation-nested-master
+ 'nested))
(ert-deftest treesit-defun-navigation-nested-2 ()
"Test defun navigation using `js-ts-mode'."
(skip-unless (treesit-language-available-p 'javascript))
;; Nested defun navigation
- (let ((treesit-defun-tactic 'nested))
- (require 'js)
- (treesit--ert-test-defun-navigation
- 'js-ts-mode
- treesit--ert-defun-navigation-js-program
- treesit--ert-defun-navigation-nested-master)))
+ (require 'js)
+ (treesit--ert-test-defun-navigation
+ 'js-ts-mode
+ treesit--ert-defun-navigation-js-program
+ treesit--ert-defun-navigation-nested-master
+ 'nested))
(ert-deftest treesit-defun-navigation-nested-3 ()
"Test defun navigation using `bash-ts-mode'."
(skip-unless (treesit-language-available-p 'bash))
;; Nested defun navigation
- (let ((treesit-defun-tactic 'nested))
- (treesit--ert-test-defun-navigation
- (lambda ()
- (treesit-parser-create 'bash)
- (setq-local treesit-defun-type-regexp "function_definition"))
- treesit--ert-defun-navigation-bash-program
- treesit--ert-defun-navigation-nested-master)))
+ (treesit--ert-test-defun-navigation
+ (lambda ()
+ (treesit-parser-create 'bash)
+ (setq-local treesit-defun-type-regexp "function_definition"))
+ treesit--ert-defun-navigation-bash-program
+ treesit--ert-defun-navigation-nested-master
+ 'nested))
(ert-deftest treesit-defun-navigation-nested-4 ()
"Test defun navigation using Elixir.
This tests bug#60355."
(skip-unless (treesit-language-available-p 'elixir))
;; Nested defun navigation
- (let ((treesit-defun-tactic 'nested)
- (pred (lambda (node)
+ (let ((pred (lambda (node)
(member (treesit-node-text
(treesit-node-child-by-field-name node "target"))
'("def" "defmodule")))))
@@ -1070,18 +1153,19 @@ This tests bug#60355."
(treesit-parser-create 'elixir)
(setq-local treesit-defun-type-regexp `("call" . ,pred)))
treesit--ert-defun-navigation-elixir-program
- treesit--ert-defun-navigation-nested-master)))
+ treesit--ert-defun-navigation-nested-master
+ 'nested)))
(ert-deftest treesit-defun-navigation-top-level ()
"Test top-level only defun navigation."
(skip-unless (treesit-language-available-p 'python))
;; Nested defun navigation
- (let ((treesit-defun-tactic 'top-level))
- (require 'python)
- (treesit--ert-test-defun-navigation
- 'python-ts-mode
- treesit--ert-defun-navigation-python-program
- treesit--ert-defun-navigation-top-level-master)))
+ (require 'python)
+ (treesit--ert-test-defun-navigation
+ 'python-ts-mode
+ treesit--ert-defun-navigation-python-program
+ treesit--ert-defun-navigation-top-level-master
+ 'top-level))
(ert-deftest treesit-search-subtree-forward-1 ()
"Test search subtree forward."
diff --git a/test/src/undo-tests.el b/test/src/undo-tests.el
index d4017e18f8e..b4888771e70 100644
--- a/test/src/undo-tests.el
+++ b/test/src/undo-tests.el
@@ -439,6 +439,78 @@ Demonstrates bug 16818."
(should (string= (buffer-string) "aaaFirst line\nSecond line\nbbb"))))
+(ert-deftest undo-test-combine-change-calls-1 ()
+ "Test how `combine-change-calls' updates `buffer-undo-list'.
+Case 1: a file-visiting buffer with `buffer-undo-list' non-nil
+and `buffer-modified-p' non-nil when `combine-change-calls' is
+called."
+ (ert-with-temp-file tempfile
+ (with-current-buffer (find-file tempfile)
+ (insert "A")
+ (undo-boundary)
+ (insert "B")
+ (undo-boundary)
+ (insert "C")
+ (undo-boundary)
+ (insert " ")
+ (undo-boundary)
+ (insert "D")
+ (undo-boundary)
+ (insert "E")
+ (undo-boundary)
+ (insert "F")
+ (should (= (length buffer-undo-list) 14))
+ (goto-char (point-min))
+ (combine-change-calls (point-min) (point-max)
+ (re-search-forward "ABC ")
+ (replace-match "Z "))
+ (should (= (length buffer-undo-list) 15)))))
+
+(ert-deftest undo-test-combine-change-calls-2 ()
+ "Test how `combine-change-calls' updates `buffer-undo-list'.
+Case 2: a file-visiting buffer with `buffer-undo-list' non-nil
+and `buffer-modified-p' nil when `combine-change-calls' is
+called."
+ (ert-with-temp-file tempfile
+ (with-current-buffer (find-file tempfile)
+ (insert "A")
+ (undo-boundary)
+ (insert "B")
+ (undo-boundary)
+ (insert "C")
+ (undo-boundary)
+ (insert " ")
+ (undo-boundary)
+ (insert "D")
+ (undo-boundary)
+ (insert "E")
+ (undo-boundary)
+ (insert "F")
+ (should (= (length buffer-undo-list) 14))
+ (save-buffer)
+ (goto-char (point-min))
+ (combine-change-calls (point-min) (point-max)
+ (re-search-forward "ABC ")
+ (replace-match "Z "))
+ (should (= (length buffer-undo-list) 15)))))
+
+(ert-deftest undo-test-combine-change-calls-3 ()
+ "Test how `combine-change-calls' updates `buffer-undo-list'.
+Case 3: a file-visiting buffer with `buffer-undo-list' nil and
+`buffer-modified-p' nil when `combine-change-calls' is called."
+ (ert-with-temp-file tempfile
+ (with-current-buffer (find-file tempfile)
+ (insert "ABC DEF")
+ (save-buffer)
+ (kill-buffer))
+ (with-current-buffer (find-file tempfile)
+ (should (= (length buffer-undo-list) 0))
+ (goto-char (point-min))
+ (combine-change-calls (point-min) (point-max)
+ (re-search-forward "ABC ")
+ (replace-match "Z "))
+ (should (= (length buffer-undo-list) 1)))))
+
(defun undo-test-all (&optional interactive)
"Run all tests for \\[undo]."
(interactive "p")
diff --git a/test/src/xdisp-tests.el b/test/src/xdisp-tests.el
index 401e31e592c..f2a2a72c658 100644
--- a/test/src/xdisp-tests.el
+++ b/test/src/xdisp-tests.el
@@ -40,7 +40,7 @@
(insert "hello")
(let ((ol (make-overlay (point) (point)))
(max-mini-window-height 1)
- (text "askdjfhaklsjdfhlkasjdfhklasdhflkasdhflkajsdhflkashdfkljahsdlfkjahsdlfkjhasldkfhalskdjfhalskdfhlaksdhfklasdhflkasdhflkasdhflkajsdhklajsdgh"))
+ (text (copy-sequence "askdjfhaklsjdfhlkasjdfhklasdhflkasdhflkajsdhflkashdfkljahsdlfkjahsdlfkjhasldkfhalskdjfhalskdfhlaksdhfklasdhflkasdhflkasdhflkajsdhklajsdgh")))
;; (save-excursion (insert text))
;; (sit-for 2)
;; (delete-region (point) (point-max))